From ef33c16daf5551d51c7e83518cc480aeeec5df2f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 12 Jun 2024 16:05:34 +0900 Subject: [PATCH 001/359] updates in FEVariable_ --- src/modules/BaseType/src/BaseType.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 9e73cb795..5385572b3 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -190,6 +190,8 @@ MODULE BaseType PUBLIC :: Range_ PUBLIC :: Interval1D_ +INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 + !---------------------------------------------------------------------------- ! Math_ !---------------------------------------------------------------------------- @@ -1027,8 +1029,6 @@ END SUBROUTINE highorder_refelem ! ! {!pages/FEVariable_.md!} -INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 - TYPE :: FEVariable_ REAL(DFP), ALLOCATABLE :: val(:) !! values @@ -1046,6 +1046,10 @@ END SUBROUTINE highorder_refelem !! Scalar !! Vector !! Matrix + INTEGER(I4B) :: len = 0_I4B + !! current total size + INTEGER(I4B) :: capacity = 0_I4B + !! capacity of the val END TYPE FEVariable_ TYPE(FEVariable_), PARAMETER :: TypeFEVariable = FEVariable_(val=NULL()) From e9f7d0be681e042ac3bcab557ab1fa737a03ef20 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 12 Jun 2024 16:05:44 +0900 Subject: [PATCH 002/359] updates in CSRMatrix_GetMethods --- .../CSRMatrix/src/CSRMatrix_GetMethods.F90 | 98 ++++++++++--------- 1 file changed, 53 insertions(+), 45 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 index 7f7a903ba..1a66b9b33 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 @@ -39,7 +39,7 @@ MODULE CSRMatrix_GetMethods PUBLIC :: GetValue !---------------------------------------------------------------------------- -! GetIA@GetMethods +! GetIA !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -55,7 +55,7 @@ END FUNCTION obj_GetIA END INTERFACE GetIA !---------------------------------------------------------------------------- -! GetJA@GetMethods +! GetJA !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -111,7 +111,7 @@ END FUNCTION obj_GetSeveralValue END INTERFACE Get !---------------------------------------------------------------------------- -! GetStorageFMT@getMethods +! GetStorageFMT !---------------------------------------------------------------------------- INTERFACE GetStorageFMT @@ -127,7 +127,7 @@ END FUNCTION obj_GetStorageFMT END INTERFACE OPERATOR(.storageFMT.) !---------------------------------------------------------------------------- -! GetMatrixProp@getMethod +! GetMatrixProp !---------------------------------------------------------------------------- INTERFACE GetMatrixProp @@ -142,7 +142,7 @@ END FUNCTION obj_GetMatrixProp END INTERFACE OPERATOR(.MatrixProp.) !---------------------------------------------------------------------------- -! GetDOFPointer@getMethod +! GetDOFPointer !---------------------------------------------------------------------------- INTERFACE GetDOFPointer @@ -154,7 +154,7 @@ END FUNCTION obj_GetDOFPointer END INTERFACE GetDOFPointer !---------------------------------------------------------------------------- -! isSquare@GetMethod +! isSquare !---------------------------------------------------------------------------- INTERFACE isSquare @@ -165,7 +165,7 @@ END FUNCTION obj_isSquare END INTERFACE isSquare !---------------------------------------------------------------------------- -! isRectangle@GetMethod +! isRectangle !---------------------------------------------------------------------------- INTERFACE isRectangle @@ -176,7 +176,7 @@ END FUNCTION obj_isRectangle END INTERFACE isRectangle !---------------------------------------------------------------------------- -! GetColNumber@GetMethods +! GetColNumber !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -192,7 +192,7 @@ END FUNCTION obj_GetColNumber END INTERFACE GetColNumber !---------------------------------------------------------------------------- -! GetColIndex@GetMethods +! GetColIndex !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -208,7 +208,7 @@ END FUNCTION obj_GetColIndex END INTERFACE GetColIndex !---------------------------------------------------------------------------- -! startColumn@GetMethods +! startColumn !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -224,7 +224,7 @@ END FUNCTION obj_startColumn END INTERFACE OPERATOR(.startColumn.) !---------------------------------------------------------------------------- -! endColumn@GetMethods +! endColumn !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -240,7 +240,7 @@ END FUNCTION obj_endColumn END INTERFACE OPERATOR(.endColumn.) !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -255,15 +255,16 @@ END FUNCTION obj_endColumn ! - Symbolic we are performing following task `obj(nodenum, nodenum)=value` INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE) + MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get0 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -288,17 +289,18 @@ END SUBROUTINE obj_Get0 ! - Usually, element matrix is stored with `DOF_FMT` INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE) + MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) INTEGER(I4B), INTENT(IN) :: storageFMT !! storage format of value (desired format of value) + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get1 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -329,8 +331,12 @@ MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE) END SUBROUTINE obj_Get2 END INTERFACE GetValue +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE) + MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: irow(:) !! row index @@ -338,11 +344,12 @@ MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE) !! column index REAL(DFP), INTENT(INOUT) :: VALUE(:, :) !! value + INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get10 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -372,7 +379,7 @@ END SUBROUTINE obj_Get10 INTERFACE GetValue MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, iDOF, & - & jDOF, VALUE) + jDOF, VALUE) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number @@ -388,7 +395,7 @@ END SUBROUTINE obj_Get3 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -407,7 +414,7 @@ END SUBROUTINE obj_Get3 INTERFACE GetValue MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, & - & ivar, jvar, VALUE) + ivar, jvar, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj !! Block csr matrix INTEGER(I4B), INTENT(IN) :: iNodeNum(:) @@ -420,11 +427,12 @@ MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, & !! column physical variables REAL(DFP), INTENT(INOUT) :: VALUE(:, :) !! value + INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get4 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -452,8 +460,8 @@ END SUBROUTINE obj_Get4 !@endnote INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE) + MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, & + jvar, iDOF, jDOF, VALUE) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number @@ -473,7 +481,7 @@ END SUBROUTINE obj_Get5 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -481,8 +489,8 @@ END SUBROUTINE obj_Get5 ! summary: Gets the specific row and column entry from a given value INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE) + MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & + jvar, iDOF, jDOF, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj !! block matrix field INTEGER(I4B), INTENT(IN) :: iNodeNum(:) @@ -499,11 +507,12 @@ MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & !! col degree of freedom REAL(DFP), INTENT(INOUT) :: VALUE(:, :) !! Matrix value + INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get6 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@getMethods +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -531,8 +540,8 @@ END SUBROUTINE obj_Get6 !@endnote INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) + MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, & + jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number @@ -556,12 +565,13 @@ END SUBROUTINE obj_Get7 END INTERFACE GetValue !---------------------------------------------------------------------------- -! GetValue +! GetValue !---------------------------------------------------------------------------- INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) + MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, & + jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, & + nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum(:) !! row node number @@ -581,11 +591,12 @@ MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, & !! col time component REAL(DFP), INTENT(INOUT) :: VALUE(:, :) !! scalar value to be Get + INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get9 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@GetMethod +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -597,13 +608,10 @@ END SUBROUTINE obj_Get9 ! - The number of nodes in obj1 and obj2 should be same INTERFACE GetValue - MODULE SUBROUTINE obj_Get8(obj1, obj2, & - & ivar1, jvar1, & - & ispacecompo1, jspacecompo1, & - & itimecompo1, jtimecompo1, & - & ivar2, jvar2, & - & ispacecompo2, jspacecompo2, & - & itimecompo2, jtimecompo2, ierr) + MODULE SUBROUTINE obj_Get8(obj1, obj2, ivar1, jvar1, & + ispacecompo1, jspacecompo1, itimecompo1, jtimecompo1, & + ivar2, jvar2, ispacecompo2, jspacecompo2, itimecompo2, & + jtimecompo2, ierr) TYPE(CSRMatrix_), INTENT(IN) :: obj1 !! master object TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 @@ -638,7 +646,7 @@ END SUBROUTINE obj_Get8 END INTERFACE GetValue !---------------------------------------------------------------------------- -! Get@GetMethod +! Get !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -650,8 +658,8 @@ END SUBROUTINE obj_Get8 ! - The number of nodes in obj1 and obj2 should be same INTERFACE - MODULE SUBROUTINE CSR2CSR_Get_Master(obj1, obj2, idof1, jdof1, idof2, & - & jdof2, tNodes1, tNodes2) + MODULE SUBROUTINE CSR2CSR_Get_Master(obj1, obj2, idof1, jdof1, idof2, & + jdof2, tNodes1, tNodes2) TYPE(CSRMatrix_), INTENT(IN) :: obj1 !! master object TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 From 0d515fb8d5b677988c522e9e86fbb9f39d1d9769 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 12 Jun 2024 16:05:52 +0900 Subject: [PATCH 003/359] Updates in FEVariable_Method --- .../FEVariable/src/FEVariable_Method.F90 | 493 +++++------------- 1 file changed, 142 insertions(+), 351 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 887b43b2e..5f5432c8a 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -55,8 +55,8 @@ MODULE FEVariable_Method ! summary: Get lame parameter lambda from YoungsModulus INTERFACE GetLambdaFromYoungsModulus - MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus(youngsModulus, & - & shearModulus, lambda) + MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus(youngsModulus, & + shearModulus, lambda) TYPE(FEVariable_), INTENT(IN) :: youngsModulus, shearModulus TYPE(FEVariable_), INTENT(INOUT) :: lambda END SUBROUTINE fevar_GetLambdaFromYoungsModulus @@ -71,16 +71,12 @@ END SUBROUTINE fevar_GetLambdaFromYoungsModulus ! update: 2021-12-10 ! summary: Displays the content of [[FEVariable_]] -INTERFACE +INTERFACE Display MODULE SUBROUTINE fevar_Display(obj, Msg, UnitNo) TYPE(FEVariable_), INTENT(IN) :: obj CHARACTER(*), INTENT(IN) :: Msg INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo END SUBROUTINE fevar_Display -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE fevar_Display END INTERFACE Display !---------------------------------------------------------------------------- @@ -92,7 +88,7 @@ END SUBROUTINE fevar_Display ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, Constant -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -100,10 +96,6 @@ MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) & TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Quadrature_Scalar_Constant -END INTERFACE - -INTERFACE QuadratureVariable - MODULE PROCEDURE Quadrature_Scalar_Constant END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -115,7 +107,7 @@ END FUNCTION Quadrature_Scalar_Constant ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, Space -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Scalar_Space(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -123,10 +115,6 @@ MODULE PURE FUNCTION Quadrature_Scalar_Space(val, rank, vartype) & TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Quadrature_Scalar_Space -END INTERFACE - -INTERFACE QuadratureVariable - MODULE PROCEDURE Quadrature_Scalar_Space END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -138,7 +126,7 @@ END FUNCTION Quadrature_Scalar_Space ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, Time -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Scalar_Time(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -146,10 +134,6 @@ MODULE PURE FUNCTION Quadrature_Scalar_Time(val, rank, vartype) & TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype END FUNCTION Quadrature_Scalar_Time -END INTERFACE - -INTERFACE QuadratureVariable - MODULE PROCEDURE Quadrature_Scalar_Time END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -161,7 +145,7 @@ END FUNCTION Quadrature_Scalar_Time ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, SpaceTime -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -169,10 +153,6 @@ 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 !---------------------------------------------------------------------------- @@ -184,7 +164,7 @@ END FUNCTION Quadrature_Scalar_SpaceTime ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Constant -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -192,10 +172,6 @@ MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Quadrature_Vector_Constant -END INTERFACE - -INTERFACE QuadratureVariable - MODULE PROCEDURE Quadrature_Vector_Constant END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -230,7 +206,7 @@ END FUNCTION Quadrature_Vector_Space ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Time -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Vector_Time(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -238,10 +214,6 @@ 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 !---------------------------------------------------------------------------- @@ -253,7 +225,7 @@ END FUNCTION Quadrature_Vector_Time ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, SpaceTime -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -261,10 +233,6 @@ 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 !---------------------------------------------------------------------------- @@ -276,7 +244,7 @@ END FUNCTION Quadrature_Vector_SpaceTime ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Constant -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -284,10 +252,6 @@ 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 !---------------------------------------------------------------------------- @@ -299,7 +263,7 @@ END FUNCTION Quadrature_Matrix_Constant ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Space -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Matrix_Space(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -307,10 +271,6 @@ 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 !---------------------------------------------------------------------------- @@ -322,7 +282,7 @@ END FUNCTION Quadrature_Matrix_Space ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Time -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Matrix_Time(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -330,10 +290,6 @@ 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 !---------------------------------------------------------------------------- @@ -345,7 +301,7 @@ END FUNCTION Quadrature_Matrix_Time ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, SpaceTime -INTERFACE +INTERFACE QuadratureVariable MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -353,10 +309,6 @@ 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 !---------------------------------------------------------------------------- @@ -387,7 +339,7 @@ END SUBROUTINE fevar_Deallocate ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, constant -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -395,10 +347,6 @@ MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) & CLASS(FEVariableScalar_), INTENT(IN) :: rank CLASS(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Nodal_Scalar_Constant -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Scalar_Constant END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -432,17 +380,13 @@ END FUNCTION Nodal_Scalar_Space ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, Time -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Scalar_Time(val, rank, vartype) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:) TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype END FUNCTION Nodal_Scalar_Time -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Scalar_Time END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -454,17 +398,13 @@ END FUNCTION Nodal_Scalar_Time ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, SpaceTime -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Scalar_SpaceTime(val, rank, vartype) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:, :) TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype END FUNCTION Nodal_Scalar_SpaceTime -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Scalar_SpaceTime END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -476,7 +416,7 @@ END FUNCTION Nodal_Scalar_SpaceTime ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Constant -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -484,10 +424,6 @@ MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Nodal_Vector_Constant -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Vector_Constant END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -499,17 +435,13 @@ END FUNCTION Nodal_Vector_Constant ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Space -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Vector_Space(val, rank, vartype) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:, :) TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Nodal_Vector_Space -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Vector_Space END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -521,17 +453,13 @@ END FUNCTION Nodal_Vector_Space ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Time -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Vector_Time(val, rank, vartype) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:, :) TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype END FUNCTION Nodal_Vector_Time -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Vector_Time END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -543,7 +471,7 @@ END FUNCTION Nodal_Vector_Time ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, SpaceTime -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -551,10 +479,6 @@ 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 !---------------------------------------------------------------------------- @@ -566,7 +490,7 @@ END FUNCTION Nodal_Vector_SpaceTime ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Constant -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -574,10 +498,6 @@ 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 !---------------------------------------------------------------------------- @@ -589,17 +509,13 @@ END FUNCTION Nodal_Matrix_Constant ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Space -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Matrix_Space(val, rank, vartype) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Nodal_Matrix_Space -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Matrix_Space END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -611,17 +527,13 @@ END FUNCTION Nodal_Matrix_Space ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Time -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Matrix_Time(val, rank, vartype) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype END FUNCTION Nodal_Matrix_Time -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Matrix_Time END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -633,7 +545,7 @@ END FUNCTION Nodal_Matrix_Time ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, SpaceTime -INTERFACE +INTERFACE NodalVariable MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -641,41 +553,79 @@ 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 !---------------------------------------------------------------------------- ! SIZE@GetMethods !---------------------------------------------------------------------------- -INTERFACE - MODULE PURE FUNCTION fevar_Size(obj, Dim) RESULT(Ans) +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-12 +! summary: Returns the size of variable +! +!# Introduction +! +! If dim is present then obj%s(dim) is returned. +! +! In this case be careful that dim is not out of bound. +! +! Scalar, constant => dim <=1 +! Scalar, space or time => dim <=1 +! Scalar, spaceTime => dim <=2 +! +! Vector, constant => dim <=1 +! Vector, space => dim <=2 +! Vector, time => dim <=2 +! Vector, spaceTime => dim <=3 +! +! Matrix, constant => dim <=2 +! Matrix, space => dim <=3 +! Matrix, time => dim <=3 +! Matrix, spaceTime => dim <=4 +! +! If dim is absent then following rule is followed +! +! For scalar, ans = 1 +! For vector, ans = obj%s(1) +! For matrix, and = obj%s(1) * obj%s(2) + +INTERFACE Size + MODULE PURE FUNCTION fevar_Size(obj, Dim) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B), OPTIONAL, INTENT(IN) :: Dim - INTEGER(I4B) :: Ans + INTEGER(I4B) :: ans END FUNCTION fevar_Size -END INTERFACE - -INTERFACE SIZE - MODULE PROCEDURE fevar_Size -END INTERFACE SIZE +END INTERFACE Size !---------------------------------------------------------------------------- ! SHAPE@GetMethods !---------------------------------------------------------------------------- -INTERFACE - MODULE PURE FUNCTION fevar_Shape(obj) RESULT(Ans) - CLASS(FEVariable_), INTENT(IN) :: obj - INTEGER(I4B), ALLOCATABLE :: Ans(:) - END FUNCTION fevar_Shape -END INTERFACE +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-12 +! summary: Returns the shape of data +! +!# Introduction +! +! ans depends on the rank and vartype +! +!| rank | vartype | ans | +!| --- | --- | --- | +!| Scalar | Constant | [1] | +!| Scalar | Space, Time | [obj%s(1)] | +!| Scalar | SpaceTime | [obj%s(1), obj%s(2)] | +!| Vector | Constant | [obj%s(1)] | +!| Vector | Space, Time | [obj%s(1), obj%s(2)] | +!| Vector | SpaceTime | [obj%s(1), obj%s(2), obj%s(3)] | +!| Matrix | Constant | [obj%s(1), obj%s(2)] | +!| Matrix | Space, Time | [obj%s(1), obj%s(2), obj%s(3)] | +!| Matrix | SpaceTime | [obj%s(1), obj%s(2), obj%s(3), obj%s(4)] | INTERFACE Shape - MODULE PROCEDURE fevar_Shape + MODULE PURE FUNCTION fevar_Shape(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION fevar_Shape END INTERFACE Shape !---------------------------------------------------------------------------- @@ -687,17 +637,13 @@ END FUNCTION fevar_Shape ! update: 2021-11-27 ! summary: Returns the rank of FEvariable -INTERFACE +INTERFACE OPERATOR(.RANK.) MODULE PURE FUNCTION fevar_rank(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B) :: ans END FUNCTION fevar_rank END INTERFACE -INTERFACE OPERATOR(.RANK.) - MODULE PROCEDURE fevar_rank -END INTERFACE OPERATOR(.RANK.) - !---------------------------------------------------------------------------- ! vartype@GetMethods !---------------------------------------------------------------------------- @@ -707,17 +653,13 @@ END FUNCTION fevar_rank ! update: 2021-11-27 ! summary: Returns the vartype of FEvariable -INTERFACE +INTERFACE OPERATOR(.vartype.) MODULE PURE FUNCTION fevar_vartype(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B) :: ans END FUNCTION fevar_vartype END INTERFACE -INTERFACE OPERATOR(.vartype.) - MODULE PROCEDURE fevar_vartype -END INTERFACE OPERATOR(.varType.) - !---------------------------------------------------------------------------- ! defineon@GetMethods !---------------------------------------------------------------------------- @@ -727,17 +669,13 @@ END FUNCTION fevar_vartype ! update: 2021-11-27 ! summary: Returns the defineon of FEvariable -INTERFACE +INTERFACE OPERATOR(.defineon.) MODULE PURE FUNCTION fevar_defineon(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B) :: ans END FUNCTION fevar_defineon END INTERFACE -INTERFACE OPERATOR(.defineon.) - MODULE PROCEDURE fevar_defineon -END INTERFACE OPERATOR(.defineon.) - !---------------------------------------------------------------------------- ! isNodalVariable@GetMethods !---------------------------------------------------------------------------- @@ -747,15 +685,11 @@ END FUNCTION fevar_defineon ! update: 2021-11-27 ! summary: Returns the defineon of FEvariable -INTERFACE +INTERFACE isNodalVariable MODULE PURE FUNCTION fevar_isNodalVariable(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj LOGICAL(LGT) :: ans END FUNCTION fevar_isNodalVariable -END INTERFACE - -INTERFACE isNodalVariable - MODULE PROCEDURE fevar_isNodalVariable END INTERFACE isNodalVariable !---------------------------------------------------------------------------- @@ -767,15 +701,11 @@ END FUNCTION fevar_isNodalVariable ! update: 2021-11-27 ! summary: Returns the defineon of FEvariable -INTERFACE +INTERFACE isQuadratureVariable MODULE PURE FUNCTION fevar_isQuadratureVariable(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj LOGICAL(LGT) :: ans END FUNCTION fevar_isQuadratureVariable -END INTERFACE - -INTERFACE isQuadratureVariable - MODULE PROCEDURE fevar_isQuadratureVariable END INTERFACE isQuadratureVariable !---------------------------------------------------------------------------- @@ -786,17 +716,13 @@ END FUNCTION fevar_isQuadratureVariable ! date: 2 Jan 2022 ! summary: Returns value which is scalar, constant -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Scalar_Constant(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype REAL(DFP) :: val END FUNCTION Scalar_Constant -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Scalar_Constant END INTERFACE Get !---------------------------------------------------------------------------- @@ -807,17 +733,13 @@ END FUNCTION Scalar_Constant ! date: 2 Jan 2022 ! summary: Returns value which is scalar, space -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Scalar_Space(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:) END FUNCTION Scalar_Space -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Scalar_Space END INTERFACE Get !---------------------------------------------------------------------------- @@ -828,17 +750,13 @@ END FUNCTION Scalar_Space ! date: 2 Jan 2022 ! summary: Returns value which is scalar, time -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Scalar_Time(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:) END FUNCTION Scalar_Time -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Scalar_Time END INTERFACE Get !---------------------------------------------------------------------------- @@ -849,17 +767,13 @@ END FUNCTION Scalar_Time ! date: 2 Jan 2022 ! summary: Returns value which is scalar, SpaceTime -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Scalar_SpaceTime(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :) END FUNCTION Scalar_SpaceTime -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Scalar_SpaceTime END INTERFACE Get !---------------------------------------------------------------------------- @@ -870,17 +784,13 @@ END FUNCTION Scalar_SpaceTime ! date: 2 Jan 2022 ! summary: Returns value which is vector, constant -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Vector_Constant(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:) END FUNCTION Vector_Constant -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Vector_Constant END INTERFACE Get !---------------------------------------------------------------------------- @@ -891,17 +801,13 @@ END FUNCTION Vector_Constant ! date: 2 Jan 2022 ! summary: Returns value which is vector, space -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Vector_Space(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :) END FUNCTION Vector_Space -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Vector_Space END INTERFACE Get !---------------------------------------------------------------------------- @@ -912,17 +818,13 @@ END FUNCTION Vector_Space ! date: 2 Jan 2022 ! summary: Returns value which is vector, time -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Vector_Time(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :) END FUNCTION Vector_Time -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Vector_Time END INTERFACE Get !---------------------------------------------------------------------------- @@ -933,17 +835,13 @@ END FUNCTION Vector_Time ! date: 2 Jan 2022 ! summary: Returns value which is vector, spaceTime -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Vector_SpaceTime(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :, :) END FUNCTION Vector_SpaceTime -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Vector_SpaceTime END INTERFACE Get !---------------------------------------------------------------------------- @@ -954,17 +852,13 @@ END FUNCTION Vector_SpaceTime ! date: 2 Jan 2022 ! summary: Returns value which is Matrix, Constant -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Matrix_Constant(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :) END FUNCTION Matrix_Constant -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Matrix_Constant END INTERFACE Get !---------------------------------------------------------------------------- @@ -975,17 +869,13 @@ END FUNCTION Matrix_Constant ! date: 2 Jan 2022 ! summary: Returns value which is Matrix, Space -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Matrix_Space(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :, :) END FUNCTION Matrix_Space -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Matrix_Space END INTERFACE Get !---------------------------------------------------------------------------- @@ -996,17 +886,13 @@ END FUNCTION Matrix_Space ! date: 2 Jan 2022 ! summary: Returns value which is Matrix, Time -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Matrix_Time(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :, :) END FUNCTION Matrix_Time -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Matrix_Time END INTERFACE Get !---------------------------------------------------------------------------- @@ -1017,17 +903,13 @@ END FUNCTION Matrix_Time ! date: 2 Jan 2022 ! summary: Returns value which is Matrix, SpaceTime -INTERFACE +INTERFACE Get MODULE PURE FUNCTION Matrix_SpaceTime(obj, rank, vartype) RESULT(val) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype REAL(DFP), ALLOCATABLE :: val(:, :, :, :) END FUNCTION Matrix_SpaceTime -END INTERFACE - -INTERFACE Get - MODULE PROCEDURE Matrix_SpaceTime END INTERFACE Get !---------------------------------------------------------------------------- @@ -1039,18 +921,14 @@ END FUNCTION Matrix_SpaceTime ! update: 2021-12-12 ! summary: FEVariable = FEVariable + FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Addition1(obj1, obj2) RESULT(Ans) +INTERFACE OPERATOR(+) + MODULE PURE FUNCTION fevar_Addition1(obj1, obj2) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 CLASS(FEVariable_), INTENT(IN) :: obj2 TYPE(FEVariable_) :: ans END FUNCTION fevar_Addition1 END INTERFACE -INTERFACE OPERATOR(+) - MODULE PROCEDURE fevar_Addition1 -END INTERFACE OPERATOR(+) - !---------------------------------------------------------------------------- ! Addition@AdditioMethods !---------------------------------------------------------------------------- @@ -1060,18 +938,15 @@ END FUNCTION fevar_Addition1 ! update: 2021-12-12 ! summary: FEVariable = FEVariable + Real -INTERFACE - MODULE PURE FUNCTION fevar_Addition2(obj1, val) RESULT(Ans) +INTERFACE OPERATOR(+) + + MODULE PURE FUNCTION fevar_Addition2(obj1, val) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 REAL(DFP), INTENT(IN) :: val TYPE(FEVariable_) :: ans END FUNCTION fevar_Addition2 END INTERFACE -INTERFACE OPERATOR(+) - MODULE PROCEDURE fevar_Addition2 -END INTERFACE OPERATOR(+) - !---------------------------------------------------------------------------- ! Addition@AdditioMethods !---------------------------------------------------------------------------- @@ -1081,18 +956,14 @@ END FUNCTION fevar_Addition2 ! update: 2021-12-12 ! summary: FEVariable = Real + FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Addition3(val, obj1) RESULT(Ans) +INTERFACE OPERATOR(+) + MODULE PURE FUNCTION fevar_Addition3(val, obj1) RESULT(ans) REAL(DFP), INTENT(IN) :: val CLASS(FEVariable_), INTENT(IN) :: obj1 TYPE(FEVariable_) :: ans END FUNCTION fevar_Addition3 END INTERFACE -INTERFACE OPERATOR(+) - MODULE PROCEDURE fevar_Addition3 -END INTERFACE OPERATOR(+) - !---------------------------------------------------------------------------- ! Substraction@SubstractioMethods !---------------------------------------------------------------------------- @@ -1102,18 +973,14 @@ END FUNCTION fevar_Addition3 ! update: 2021-12-12 ! summary: FEVariable = FEVariable - FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Subtraction1(obj1, obj2) RESULT(Ans) +INTERFACE OPERATOR(-) + MODULE PURE FUNCTION fevar_Subtraction1(obj1, obj2) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 CLASS(FEVariable_), INTENT(IN) :: obj2 TYPE(FEVariable_) :: ans END FUNCTION fevar_Subtraction1 END INTERFACE -INTERFACE OPERATOR(-) - MODULE PROCEDURE fevar_Subtraction1 -END INTERFACE OPERATOR(-) - !---------------------------------------------------------------------------- ! Substraction@SubstractioMethods !---------------------------------------------------------------------------- @@ -1123,18 +990,14 @@ END FUNCTION fevar_Subtraction1 ! update: 2021-12-12 ! summary: FEVariable = FEVariable - RealVal -INTERFACE - MODULE PURE FUNCTION fevar_Subtraction2(obj1, val) RESULT(Ans) +INTERFACE OPERATOR(-) + MODULE PURE FUNCTION fevar_Subtraction2(obj1, val) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 REAL(DFP), INTENT(IN) :: val TYPE(FEVariable_) :: ans END FUNCTION fevar_Subtraction2 END INTERFACE -INTERFACE OPERATOR(-) - MODULE PROCEDURE fevar_Subtraction2 -END INTERFACE OPERATOR(-) - !---------------------------------------------------------------------------- ! Substraction@SubstractioMethods !---------------------------------------------------------------------------- @@ -1144,18 +1007,14 @@ END FUNCTION fevar_Subtraction2 ! update: 2021-12-12 ! summary: FEVariable = RealVal - FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Subtraction3(val, obj1) RESULT(Ans) +INTERFACE OPERATOR(-) + MODULE PURE FUNCTION fevar_Subtraction3(val, obj1) RESULT(ans) REAL(DFP), INTENT(IN) :: val CLASS(FEVariable_), INTENT(IN) :: obj1 TYPE(FEVariable_) :: ans END FUNCTION fevar_Subtraction3 END INTERFACE -INTERFACE OPERATOR(-) - MODULE PROCEDURE fevar_Subtraction3 -END INTERFACE OPERATOR(-) - !---------------------------------------------------------------------------- ! Multiplication@MultiplicationMethods !---------------------------------------------------------------------------- @@ -1165,18 +1024,14 @@ END FUNCTION fevar_Subtraction3 ! update: 2021-12-1 ! summary: FEVariable = FEVariable * FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Multiplication1(obj1, obj2) RESULT(Ans) +INTERFACE OPERATOR(*) + MODULE PURE FUNCTION fevar_Multiplication1(obj1, obj2) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 CLASS(FEVariable_), INTENT(IN) :: obj2 TYPE(FEVariable_) :: ans END FUNCTION fevar_Multiplication1 END INTERFACE -INTERFACE OPERATOR(*) - MODULE PROCEDURE fevar_Multiplication1 -END INTERFACE OPERATOR(*) - !---------------------------------------------------------------------------- ! Multiplication@MultiplicationMethods !---------------------------------------------------------------------------- @@ -1186,18 +1041,14 @@ END FUNCTION fevar_Multiplication1 ! update: 2021-12-12 ! summary: FEVariable = FEVariable * Real -INTERFACE - MODULE PURE FUNCTION fevar_Multiplication2(obj1, val) RESULT(Ans) +INTERFACE OPERATOR(*) + MODULE PURE FUNCTION fevar_Multiplication2(obj1, val) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 REAL(DFP), INTENT(IN) :: val TYPE(FEVariable_) :: ans END FUNCTION fevar_Multiplication2 END INTERFACE -INTERFACE OPERATOR(*) - MODULE PROCEDURE fevar_Multiplication2 -END INTERFACE OPERATOR(*) - !---------------------------------------------------------------------------- ! Multiplication@MultiplicationMethods !---------------------------------------------------------------------------- @@ -1207,34 +1058,26 @@ END FUNCTION fevar_Multiplication2 ! update: 2021-12-12 ! summary: FEVariable = Real * FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Multiplication3(val, obj1) RESULT(Ans) +INTERFACE OPERATOR(*) + MODULE PURE FUNCTION fevar_Multiplication3(val, obj1) RESULT(ans) REAL(DFP), INTENT(IN) :: val CLASS(FEVariable_), INTENT(IN) :: obj1 TYPE(FEVariable_) :: ans END FUNCTION fevar_Multiplication3 END INTERFACE -INTERFACE OPERATOR(*) - MODULE PROCEDURE fevar_Multiplication3 -END INTERFACE OPERATOR(*) - !> author: Vikas Sharma, Ph. D. ! date: 2021-12-12 ! update: 2021-12-12 ! summary: FEVariable = FEVariable + FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_abs(obj) RESULT(Ans) +INTERFACE ABS + MODULE PURE FUNCTION fevar_abs(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariable_) :: ans END FUNCTION fevar_abs END INTERFACE -INTERFACE ABS - MODULE PROCEDURE fevar_abs -END INTERFACE ABS - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -1244,18 +1087,14 @@ END FUNCTION fevar_abs ! update: 2021-12-12 ! summary: FEVariable = FEVariable + FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_dot_product(obj1, obj2) RESULT(Ans) +INTERFACE DOT_PRODUCT + MODULE PURE FUNCTION fevar_dot_product(obj1, obj2) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 CLASS(FEVariable_), INTENT(IN) :: obj2 TYPE(FEVariable_) :: ans END FUNCTION fevar_dot_product END INTERFACE -INTERFACE DOT_PRODUCT - MODULE PROCEDURE fevar_dot_product -END INTERFACE DOT_PRODUCT - !---------------------------------------------------------------------------- ! Division@DivisionMethods !---------------------------------------------------------------------------- @@ -1265,18 +1104,14 @@ END FUNCTION fevar_dot_product ! update: 2021-12-12 ! summary: FEVariable = FEVariable - FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Division1(obj1, obj2) RESULT(Ans) +INTERFACE OPERATOR(/) + MODULE PURE FUNCTION fevar_Division1(obj1, obj2) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 CLASS(FEVariable_), INTENT(IN) :: obj2 TYPE(FEVariable_) :: ans END FUNCTION fevar_Division1 END INTERFACE -INTERFACE OPERATOR(/) - MODULE PROCEDURE fevar_Division1 -END INTERFACE OPERATOR(/) - !---------------------------------------------------------------------------- ! Division@DivisionMethods !---------------------------------------------------------------------------- @@ -1286,18 +1121,14 @@ END FUNCTION fevar_Division1 ! update: 2021-12-12 ! summary: FEVariable = FEVariable - Real -INTERFACE - MODULE PURE FUNCTION fevar_Division2(obj1, val) RESULT(Ans) +INTERFACE OPERATOR(/) + MODULE PURE FUNCTION fevar_Division2(obj1, val) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 REAL(DFP), INTENT(IN) :: val TYPE(FEVariable_) :: ans END FUNCTION fevar_Division2 END INTERFACE -INTERFACE OPERATOR(/) - MODULE PROCEDURE fevar_Division2 -END INTERFACE OPERATOR(/) - !---------------------------------------------------------------------------- ! Division@DivisionMethods !---------------------------------------------------------------------------- @@ -1307,18 +1138,14 @@ END FUNCTION fevar_Division2 ! update: 2021-12-12 ! summary: FEVariable = Real - FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_Division3(val, obj1) RESULT(Ans) +INTERFACE OPERATOR(/) + MODULE PURE FUNCTION fevar_Division3(val, obj1) RESULT(ans) REAL(DFP), INTENT(IN) :: val CLASS(FEVariable_), INTENT(IN) :: obj1 TYPE(FEVariable_) :: ans END FUNCTION fevar_Division3 END INTERFACE -INTERFACE OPERATOR(/) - MODULE PROCEDURE fevar_Division3 -END INTERFACE OPERATOR(/) - !---------------------------------------------------------------------------- ! Power@PowerMethods !---------------------------------------------------------------------------- @@ -1328,18 +1155,14 @@ END FUNCTION fevar_Division3 ! update: 2021-12-12 ! summary: FEVariable = FEVariable + FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_power(obj, n) RESULT(Ans) +INTERFACE OPERATOR(**) + MODULE PURE FUNCTION fevar_power(obj, n) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: n TYPE(FEVariable_) :: ans END FUNCTION fevar_power END INTERFACE -INTERFACE OPERATOR(**) - MODULE PROCEDURE fevar_power -END INTERFACE OPERATOR(**) - !---------------------------------------------------------------------------- ! Power@PowerMethods !---------------------------------------------------------------------------- @@ -1349,33 +1172,25 @@ END FUNCTION fevar_power ! update: 2021-12-12 ! summary: FEVariable = FEVariable + FEVariable -INTERFACE - MODULE PURE FUNCTION fevar_sqrt(obj) RESULT(Ans) +INTERFACE SQRT + MODULE PURE FUNCTION fevar_sqrt(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariable_) :: ans END FUNCTION fevar_sqrt END INTERFACE -INTERFACE SQRT - MODULE PROCEDURE fevar_sqrt -END INTERFACE SQRT - !> author: Vikas Sharma, Ph. D. ! date: 2021-12-12 ! update: 2021-12-12 ! summary: FEVariable = NORM2(FEVariable) -INTERFACE - MODULE PURE FUNCTION fevar_norm2(obj) RESULT(Ans) +INTERFACE NORM2 + MODULE PURE FUNCTION fevar_norm2(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariable_) :: ans END FUNCTION fevar_norm2 END INTERFACE -INTERFACE NORM2 - MODULE PROCEDURE fevar_norm2 -END INTERFACE NORM2 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -1385,18 +1200,14 @@ END FUNCTION fevar_norm2 ! update: 2021-12-12 ! summary: FEVariable = NORM2(FEVariable) -INTERFACE - MODULE PURE FUNCTION fevar_isEqual(obj1, obj2) RESULT(Ans) +INTERFACE OPERATOR(.EQ.) + MODULE PURE FUNCTION fevar_isEqual(obj1, obj2) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 CLASS(FEVariable_), INTENT(IN) :: obj2 LOGICAL(LGT) :: ans END FUNCTION fevar_isEqual END INTERFACE -INTERFACE OPERATOR(.EQ.) - MODULE PROCEDURE fevar_isEqual -END INTERFACE OPERATOR(.EQ.) - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -1406,18 +1217,14 @@ END FUNCTION fevar_isEqual ! update: 2021-12-12 ! summary: FEVariable = NORM2(FEVariable) -INTERFACE - MODULE PURE FUNCTION fevar_notEqual(obj1, obj2) RESULT(Ans) +INTERFACE OPERATOR(.NE.) + MODULE PURE FUNCTION fevar_notEqual(obj1, obj2) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj1 CLASS(FEVariable_), INTENT(IN) :: obj2 LOGICAL(LGT) :: ans END FUNCTION fevar_notEqual END INTERFACE -INTERFACE OPERATOR(.NE.) - MODULE PROCEDURE fevar_notEqual -END INTERFACE OPERATOR(.NE.) - !---------------------------------------------------------------------------- ! MEAN@MeanMethods !---------------------------------------------------------------------------- @@ -1426,17 +1233,13 @@ END FUNCTION fevar_notEqual ! date: 27 May 2022 ! summary: FEVariable = Mean( obj ) -INTERFACE +INTERFACE MEAN MODULE PURE FUNCTION fevar_Mean1(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariable_) :: ans END FUNCTION fevar_Mean1 END INTERFACE -INTERFACE MEAN - MODULE PROCEDURE fevar_Mean1 -END INTERFACE MEAN - !---------------------------------------------------------------------------- ! MEAN@MeanMethods !---------------------------------------------------------------------------- @@ -1445,7 +1248,7 @@ END FUNCTION fevar_Mean1 ! date: 27 May 2022 ! summary: FEVariable = Mean( obj ) -INTERFACE +INTERFACE MEAN MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableScalar_), INTENT(IN) :: dataType @@ -1453,10 +1256,6 @@ MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans) END FUNCTION fevar_Mean2 END INTERFACE -INTERFACE MEAN - MODULE PROCEDURE fevar_Mean2 -END INTERFACE MEAN - !---------------------------------------------------------------------------- ! MEAN@MeanMethods !---------------------------------------------------------------------------- @@ -1465,7 +1264,7 @@ END FUNCTION fevar_Mean2 ! date: 27 May 2022 ! summary: FEVariable = Mean( obj ) -INTERFACE +INTERFACE MEAN MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableVector_), INTENT(IN) :: dataType @@ -1473,10 +1272,6 @@ MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans) END FUNCTION fevar_Mean3 END INTERFACE -INTERFACE MEAN - MODULE PROCEDURE fevar_Mean3 -END INTERFACE MEAN - !---------------------------------------------------------------------------- ! MEAN@MeanMethods !---------------------------------------------------------------------------- @@ -1485,7 +1280,7 @@ END FUNCTION fevar_Mean3 ! date: 27 May 2022 ! summary: FEVariable = Mean( obj ) -INTERFACE +INTERFACE MEAN MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj TYPE(FEVariableMatrix_), INTENT(IN) :: dataType @@ -1493,8 +1288,4 @@ MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans) END FUNCTION fevar_Mean4 END INTERFACE -INTERFACE MEAN - MODULE PROCEDURE fevar_Mean4 -END INTERFACE MEAN - END MODULE FEVariable_Method From 972c7588d2827bb390089fb31b8661f932405893 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 12 Jun 2024 16:05:59 +0900 Subject: [PATCH 004/359] updates in CSRMatrix_GetMethods --- .../src/CSRMatrix_GetMethods@Methods.F90 | 80 +++++++++---------- 1 file changed, 38 insertions(+), 42 deletions(-) diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 index ac5dcea7d..d87d4cf31 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 @@ -185,28 +185,29 @@ REAL(DFP) :: m2(SIZE(VALUE, 1), SIZE(VALUE, 2)) INTEGER(I4B) :: tdof, nns, myfmt -CALL GetValue(obj=obj, nodenum=nodenum, VALUE=m2) +CALL GetValue(obj=obj, nodenum=nodenum, VALUE=m2, nrow=nrow, ncol=ncol) -tdof = .tdof. (obj%csr%idof) -nns = SIZE(nodenum) myfmt = GetStorageFMT(obj, 1) IF (myfmt .EQ. storageFMT) THEN - VALUE = m2 + VALUE(1:nrow, 1:ncol) = m2(1:nrow, 1:ncol) RETURN END IF +tdof = .tdof. (obj%csr%idof) +nns = SIZE(nodenum) + SELECT CASE (storageFMT) CASE (FMT_NODES) - CALL ConvertSafe(From=m2, To=VALUE, Conversion=DOFToNodes, nns=nns, & - & tDOF=tdof) + CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), & + Conversion=DOFToNodes, nns=nns, tDOF=tdof) CASE (FMT_DOF) - CALL ConvertSafe(From=m2, To=VALUE, Conversion=NodesToDOF, nns=nns, & - & tDOF=tdof) + CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), & + Conversion=NodesToDOF, nns=nns, tDOF=tdof) END SELECT @@ -219,7 +220,7 @@ MODULE PROCEDURE obj_Get2 INTEGER(I4B) :: j -VALUE = 0.0_DFP +! VALUE = 0.0_DFP DO j = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 IF (obj%csr%JA(j) .EQ. icolumn) THEN VALUE = obj%A(j) @@ -234,15 +235,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Get10 -INTEGER(I4B) :: ii, jj, m, n +INTEGER(I4B) :: ii, jj -VALUE = 0.0_DFP -m = SIZE(irow) -n = SIZE(icolumn) -DO ii = 1, m - DO jj = 1, n - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=irow(ii), & - & icolumn=icolumn(jj)) +! VALUE = 0.0_DFP +nrow = SIZE(irow) +ncol = SIZE(icolumn) +DO jj = 1, ncol + DO ii = 1, nrow + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=irow(ii), & + icolumn=icolumn(jj)) END DO END DO @@ -271,10 +272,13 @@ row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar) col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar) -DO ii = 1, SIZE(row) - DO jj = 1, SIZE(col) - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & - & icolumn=col(jj)) +nrow = SIZE(row) +ncol = SIZE(col) + +DO ii = 1, nrow + DO jj = 1, ncol + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & + icolumn=col(jj)) END DO END DO @@ -300,18 +304,18 @@ MODULE PROCEDURE obj_Get6 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, trow, tcol +INTEGER(I4B) :: ii, jj row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof) col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof) -trow = SIZE(row) -tcol = SIZE(col) +nrow = SIZE(row) +ncol = SIZE(col) -DO ii = 1, trow - DO jj = 1, tcol - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & - & icolumn=col(jj)) +DO ii = 1, nrow + DO jj = 1, ncol + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & + icolumn=col(jj)) END DO END DO @@ -350,22 +354,14 @@ MODULE PROCEDURE obj_Get9 INTEGER(I4B) :: irow(SIZE(iNodeNum)), icolumn(SIZE(jNodeNum)) -irow = GetNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=iNodeNum, & - & ivar=ivar, & - & spacecompo=ispacecompo, & - & timecompo=itimecompo) +irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo) -icolumn = GetNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=jNodeNum, & - & ivar=jvar, & - & spacecompo=jspacecompo, & - & timecompo=jtimecompo) +icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo) -CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) -!! Get10 +CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, & + nrow=nrow, ncol=ncol) END PROCEDURE obj_Get9 !---------------------------------------------------------------------------- From af6e4c94798d6a226dbc66cebc68600f9e679c2e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 12 Jun 2024 16:06:06 +0900 Subject: [PATCH 005/359] Updates in FEVariable_Method --- .../src/FEVariable_Method@AdditionMethods.F90 | 28 ++-- .../FEVariable_Method@ConstructorMethods.F90 | 154 ++++++++++++------ .../src/FEVariable_Method@GetMethods.F90 | 9 +- 3 files changed, 117 insertions(+), 74 deletions(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 index 7efae1312..2f7209883 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 @@ -27,7 +27,7 @@ MODULE PROCEDURE fevar_addition1 !! -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:) +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) INTEGER(I4B) :: jj, kk !! SELECT CASE (obj1%rank) @@ -37,45 +37,45 @@ !! CASE (SCALAR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! scalar, scalar - case( scalar ) + CASE (scalar) #include "./ScalarOperatorScalar.inc" !! scalar, vector - case( vector ) + CASE (vector) #include "./ScalarOperatorVector.inc" !! scalar, matrix - case( matrix ) + CASE (matrix) #include "./ScalarOperatorMatrix.inc" - end select + END SELECT !! !! !! !! CASE (VECTOR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! vector, scalar - case( scalar ) + CASE (scalar) #include "./VectorOperatorScalar.inc" !! vector, vector - case( vector ) + CASE (vector) #include "./VectorOperatorVector.inc" - end select + END SELECT !! !! !! !! CASE (MATRIX) !! - select case( obj2%rank ) - case( scalar ) + SELECT CASE (obj2%rank) + CASE (scalar) !! matrix, scalar #include "./MatrixOperatorScalar.inc" - case( matrix ) + CASE (matrix) !! matrix, matrix #include "./MatrixOperatorMatrix.inc" - end select + END SELECT !! !! !! diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 index baa59dc5d..e82d0a0c3 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 @@ -27,9 +27,11 @@ MODULE PROCEDURE fevar_Deallocate IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) obj%s = 0 -obj%DefineOn = 0 -obj%VarType = 0 -obj%Rank = 0 +obj%defineOn = 0 +obj%varType = 0 +obj%rank = 0 +obj%len = 0 +obj%capacity = 0 END PROCEDURE fevar_Deallocate !---------------------------------------------------------------------------- @@ -38,10 +40,12 @@ MODULE PROCEDURE Nodal_Scalar_Constant obj%val = [val] -obj%s = 0 -obj%defineon = NODAL +obj%s(1) = 1 +obj%defineOn = NODAL obj%rank = SCALAR -obj%vartype = CONSTANT +obj%varType = CONSTANT +obj%len = 1 +obj%capacity = 1 END PROCEDURE Nodal_Scalar_Constant !---------------------------------------------------------------------------- @@ -51,9 +55,11 @@ MODULE PROCEDURE Nodal_Scalar_Space obj%val = val obj%s(1) = SIZE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = SCALAR -obj%vartype = SPACE +obj%varType = SPACE +obj%len = SIZE(val) +obj%capacity = obj%len END PROCEDURE Nodal_Scalar_Space !---------------------------------------------------------------------------- @@ -63,9 +69,11 @@ MODULE PROCEDURE Nodal_Scalar_Time obj%val = val obj%s(1) = SIZE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = SCALAR -obj%vartype = TIME +obj%varType = TIME +obj%len = SIZE(val) +obj%capacity = obj%len END PROCEDURE Nodal_Scalar_Time !---------------------------------------------------------------------------- @@ -75,9 +83,11 @@ MODULE PROCEDURE Nodal_Scalar_Spacetime obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = SCALAR -obj%vartype = SPACETIME +obj%varType = SPACETIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Scalar_Spacetime !---------------------------------------------------------------------------- @@ -87,9 +97,11 @@ MODULE PROCEDURE Nodal_Vector_Constant obj%val = val obj%s(1:1) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = VECTOR -obj%vartype = CONSTANT +obj%varType = CONSTANT +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Vector_Constant !---------------------------------------------------------------------------- @@ -99,9 +111,11 @@ MODULE PROCEDURE Nodal_Vector_Space obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = VECTOR -obj%vartype = SPACE +obj%varType = SPACE +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Vector_Space !---------------------------------------------------------------------------- @@ -111,9 +125,11 @@ MODULE PROCEDURE Nodal_Vector_Time obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = VECTOR -obj%vartype = TIME +obj%varType = TIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Vector_Time !---------------------------------------------------------------------------- @@ -123,9 +139,11 @@ MODULE PROCEDURE Nodal_Vector_Spacetime obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:3) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = VECTOR -obj%vartype = SPACETIME +obj%varType = SPACETIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Vector_Spacetime !---------------------------------------------------------------------------- @@ -135,9 +153,11 @@ MODULE PROCEDURE Nodal_Matrix_Constant obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = MATRIX -obj%vartype = CONSTANT +obj%varType = CONSTANT +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Matrix_Constant !---------------------------------------------------------------------------- @@ -147,9 +167,11 @@ MODULE PROCEDURE Nodal_Matrix_Space obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:3) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = MATRIX -obj%vartype = SPACE +obj%varType = SPACE +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Matrix_Space !---------------------------------------------------------------------------- @@ -159,9 +181,11 @@ MODULE PROCEDURE Nodal_Matrix_Time obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:3) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = MATRIX -obj%vartype = TIME +obj%varType = TIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Matrix_Time !---------------------------------------------------------------------------- @@ -171,9 +195,11 @@ MODULE PROCEDURE Nodal_Matrix_Spacetime obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:4) = SHAPE(val) -obj%defineon = NODAL +obj%defineOn = NODAL obj%rank = MATRIX -obj%vartype = SPACETIME +obj%varType = SPACETIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Nodal_Matrix_Spacetime !---------------------------------------------------------------------------- @@ -183,9 +209,11 @@ MODULE PROCEDURE Quadrature_Scalar_Constant obj%val = [val] obj%s = 0 -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = SCALAR -obj%vartype = CONSTANT +obj%varType = CONSTANT +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Scalar_Constant !---------------------------------------------------------------------------- @@ -195,9 +223,11 @@ MODULE PROCEDURE Quadrature_Scalar_Space obj%val = val obj%s(1) = SIZE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = SCALAR -obj%vartype = SPACE +obj%varType = SPACE +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Scalar_Space !---------------------------------------------------------------------------- @@ -207,9 +237,11 @@ MODULE PROCEDURE Quadrature_Scalar_Time obj%val = val obj%s(1) = SIZE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = SCALAR -obj%vartype = TIME +obj%varType = TIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Scalar_Time !---------------------------------------------------------------------------- @@ -219,9 +251,11 @@ MODULE PROCEDURE Quadrature_Scalar_Spacetime obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = SCALAR -obj%vartype = SPACETIME +obj%varType = SPACETIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Scalar_Spacetime !---------------------------------------------------------------------------- @@ -231,9 +265,11 @@ MODULE PROCEDURE Quadrature_Vector_Constant obj%val = val obj%s(1:1) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = VECTOR -obj%vartype = CONSTANT +obj%varType = CONSTANT +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Vector_Constant !---------------------------------------------------------------------------- @@ -243,9 +279,11 @@ MODULE PROCEDURE Quadrature_Vector_Space obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = VECTOR -obj%vartype = SPACE +obj%varType = SPACE +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Vector_Space !---------------------------------------------------------------------------- @@ -255,9 +293,11 @@ MODULE PROCEDURE Quadrature_Vector_Time obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = VECTOR -obj%vartype = TIME +obj%varType = TIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Vector_Time !---------------------------------------------------------------------------- @@ -267,9 +307,11 @@ MODULE PROCEDURE Quadrature_Vector_Spacetime obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:3) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = VECTOR -obj%vartype = SPACETIME +obj%varType = SPACETIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Vector_Spacetime !---------------------------------------------------------------------------- @@ -279,9 +321,11 @@ MODULE PROCEDURE Quadrature_Matrix_Constant obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:2) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = MATRIX -obj%vartype = CONSTANT +obj%varType = CONSTANT +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Matrix_Constant !---------------------------------------------------------------------------- @@ -291,9 +335,11 @@ MODULE PROCEDURE Quadrature_Matrix_Space obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:3) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = MATRIX -obj%vartype = SPACE +obj%varType = SPACE +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Matrix_Space !---------------------------------------------------------------------------- @@ -303,9 +349,11 @@ MODULE PROCEDURE Quadrature_Matrix_Time obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:3) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = MATRIX -obj%vartype = TIME +obj%varType = TIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Matrix_Time !---------------------------------------------------------------------------- @@ -315,9 +363,11 @@ MODULE PROCEDURE Quadrature_Matrix_Spacetime obj%val = RESHAPE(val, [SIZE(val)]) obj%s(1:4) = SHAPE(val) -obj%defineon = Quadrature +obj%defineOn = Quadrature obj%rank = MATRIX -obj%vartype = SPACETIME +obj%varType = SPACETIME +obj%len = SIZE(obj%val) +obj%capacity = obj%len END PROCEDURE Quadrature_Matrix_Spacetime END SUBMODULE ConstructorMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 index fe72dd320..59af867b2 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 @@ -57,14 +57,7 @@ IF (PRESENT(dim)) THEN ans = obj%s(dim) ELSE - SELECT CASE (obj%rank) - CASE (Scalar) - ans = 1 - CASE (Vector) - ans = obj%s(1) - CASE (Matrix) - ans = obj%s(1) * obj%s(2) - END SELECT + ans = obj%len END IF END PROCEDURE fevar_Size From cd9c77b84025dcee08cf96fa44f55d8cfc1852ec Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:18:28 +0900 Subject: [PATCH 006/359] update in fevariable --- .../FEVariable/src/FEVariable_Method.F90 | 363 +++++++++++++++++- 1 file changed, 348 insertions(+), 15 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 5f5432c8a..27d9cff7d 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -15,8 +15,16 @@ ! along with this program. If not, see MODULE FEVariable_Method -USE BaseType -USE GlobalData +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_ +USE GlobalData, ONLY: I4B, DFP, LGT + IMPLICIT NONE PRIVATE @@ -45,6 +53,10 @@ MODULE FEVariable_Method PUBLIC :: OPERATOR(.NE.) PUBLIC :: MEAN PUBLIC :: GetLambdaFromYoungsModulus +PUBLIC :: ASSIGNMENT(=) + +INTEGER(I4B), PARAMETER :: CAPACITY_EXPAND_FACTOR = 1 +! capacity = tsize * CAPACITY_EXPAND_FACTOR !---------------------------------------------------------------------------- ! GetLambdaFromYoungsModulus@SpecialMethods @@ -155,6 +167,26 @@ MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime(val, rank, 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 !---------------------------------------------------------------------------- @@ -183,7 +215,8 @@ END FUNCTION Quadrature_Vector_Constant ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Space -INTERFACE +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Vector_Space(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -191,10 +224,27 @@ MODULE PURE FUNCTION Quadrature_Vector_Space(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Quadrature_Vector_Space -END INTERFACE +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Space INTERFACE QuadratureVariable - MODULE PROCEDURE Quadrature_Vector_Space + + MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) & + & RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Vector_Space2 END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -220,6 +270,26 @@ END FUNCTION Quadrature_Vector_Time ! 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 @@ -239,6 +309,26 @@ END FUNCTION Quadrature_Vector_SpaceTime ! 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 @@ -258,6 +348,26 @@ END FUNCTION Quadrature_Matrix_Constant ! 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 @@ -277,6 +387,26 @@ END FUNCTION Quadrature_Matrix_Space ! 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 @@ -296,6 +426,26 @@ END FUNCTION Quadrature_Matrix_Time ! 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 @@ -311,6 +461,26 @@ MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, 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 !---------------------------------------------------------------------------- @@ -320,14 +490,10 @@ END FUNCTION Quadrature_Matrix_SpaceTime ! update: 2021-12-10 ! summary: Deallocates the content of FEVariable -INTERFACE +INTERFACE DEALLOCATE MODULE PURE SUBROUTINE fevar_Deallocate(obj) TYPE(FEVariable_), INTENT(INOUT) :: obj END SUBROUTINE fevar_Deallocate -END INTERFACE - -INTERFACE DEALLOCATE - MODULE PROCEDURE fevar_Deallocate END INTERFACE DEALLOCATE !---------------------------------------------------------------------------- @@ -358,17 +524,14 @@ END FUNCTION Nodal_Scalar_Constant ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, Space -INTERFACE +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Scalar_Space(val, rank, vartype) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:) TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Nodal_Scalar_Space -END INTERFACE - -INTERFACE NodalVariable - MODULE PROCEDURE Nodal_Scalar_Space END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -411,6 +574,25 @@ END FUNCTION Nodal_Scalar_SpaceTime ! 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 @@ -448,6 +630,25 @@ END FUNCTION Nodal_Vector_Space ! 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 @@ -466,6 +667,25 @@ END FUNCTION Nodal_Vector_Time ! 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 @@ -485,6 +705,26 @@ END FUNCTION Nodal_Vector_SpaceTime ! 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 @@ -504,6 +744,26 @@ END FUNCTION Nodal_Matrix_Constant ! 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 @@ -522,6 +782,25 @@ END FUNCTION Nodal_Matrix_Space ! 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 @@ -540,6 +819,25 @@ END FUNCTION Nodal_Matrix_Time ! 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 @@ -555,6 +853,41 @@ MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, 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 + !---------------------------------------------------------------------------- ! SIZE@GetMethods !---------------------------------------------------------------------------- From e53d46ee6d045399149ace9ef93f901d8c49cfdd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:18:39 +0900 Subject: [PATCH 007/359] updates in matrixelemmethods --- .../src/include/MatrixElemMethod.F90 | 50 +++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/MatrixElemMethod.F90 diff --git a/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 b/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 new file mode 100644 index 000000000..0f4640043 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 @@ -0,0 +1,50 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SELECT CASE (obj%vartype) +CASE (constant) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2)) + END IF +CASE (space) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3)) + END IF +CASE (time) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3)) + END IF +CASE (spacetime) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4)) + END IF +END SELECT From 75ac492984a884c4a30abbc6e5faa7db83dcc63d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:18:48 +0900 Subject: [PATCH 008/359] updates in fevariable --- .../src/include/MatrixOperatorMatrix.F90 | 265 ++++++++++++++++++ 1 file changed, 265 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 new file mode 100644 index 000000000..5704e3445 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 @@ -0,0 +1,265 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! Internal variable +!! +! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) +! INTEGER(I4B) :: jj, kk +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + SELECT CASE (obj2%vartype) + !! + !! constant = constant + constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + END IF + !! + !! space= constant _OP_ space + !! + CASE (space) + !! + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) + END DO + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + !! time=constant _OP_ time + !! + CASE (time) + !! + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) + END DO + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + !! + !! spacetime=constant _OP_ spacetime + !! + CASE (spacetime) + !! + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + r4 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r2(:, :) _OP_ r4(:, :, jj, kk) + END DO + END DO + !! + IF(obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (space) + !! + SELECT CASE (obj2%vartype) + !! + !! space=space _OP_ constant + !! + CASE (constant) + !! + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) + r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) + END DO + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + !! space=space _OP_ space + !! + CASE (space) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (time) + !! + SELECT CASE (obj2%vartype) + !! + !! time=time _OP_ constant + !! + CASE (constant) + !! + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) + r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) + END DO + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + !! + !! time=time _OP_ time + !! + CASE (time) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + END SELECT +!! +!! +!! +!! +CASE (spacetime) + !! + SELECT CASE (obj2%vartype) + !! + !! spacetime= spacetime _OP_ constant + !! + CASE (constant) + !! + r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(:, :) + END DO + END DO + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + !! + !! spacetime=spacetime _OP_ spacetime + !! + CASE (spacetime) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + END SELECT +!! +END SELECT From b09865989375650050054cfe963140bd27851efa Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:18:56 +0900 Subject: [PATCH 009/359] updates in fevariable --- .../src/include/MatrixOperatorReal.F90 | 92 +++++++++++++++++++ 1 file changed, 92 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 new file mode 100644 index 000000000..f90524bee --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 @@ -0,0 +1,92 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From 782460570024b37bb1e568112d910d1b783cfda0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:00 +0900 Subject: [PATCH 010/359] updates in fevariable --- .../src/include/MatrixOperatorScalar.F90 | 271 ++++++++++++++++++ 1 file changed, 271 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 new file mode 100644 index 000000000..0c4ac6645 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 @@ -0,0 +1,271 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + SELECT CASE (obj2%vartype) + !! + !! constant = constant _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + END IF + !! + !! space= constant _OP_ space + !! + CASE (space) + !! + r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1)) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2 _OP_ obj2%val(jj) + END DO + !! + IF( obj2%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + !! time=constant _OP_ time + !! + CASE (time) + !! + r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) + !! + CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1)) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2 _OP_ obj2%val(jj) + END DO + !! + IF( obj2%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + !! + !! spacetime=constant _OP_ spacetime + !! + CASE (spacetime) + !! + r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) + m2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) + !! + CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) ) + !! + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = m2 _OP_ r2(jj, kk) + END DO + END DO + !! + IF(obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + END SELECT +!! +!! +!! +!! +CASE (space) +!! + SELECT CASE (obj1%vartype) + !! + !! space=space _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + !! space=space _OP_ space + !! + CASE (space) + !! + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (time) +!! + SELECT CASE (obj1%vartype) + !! + !! time=time _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + !! + !! time=time _OP_ time + !! + CASE (time) + !! + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (spacetime) + !! + SELECT CASE (obj1%vartype) + !! + !! spacetime= spacetime _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + !! + !! spacetime=spacetime _OP_ spacetime + !! + CASE (spacetime) + !! + r4 = GET(obj1, typeFEVariableMatrix, typeFEVariableSpaceTime) + r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) + !! + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r4(:,:,jj,kk) _OP_ r2(jj, kk) + END DO + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +END SELECT From 4293f329467f6b161c722b4ef5dfa56732bee39a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:08 +0900 Subject: [PATCH 011/359] update in fevariable --- .../FEVariable/src/include/MatrixPower.F90 | 92 +++++++++++++++++++ 1 file changed, 92 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/MatrixPower.F90 diff --git a/src/submodules/FEVariable/src/include/MatrixPower.F90 b/src/submodules/FEVariable/src/include/MatrixPower.F90 new file mode 100644 index 000000000..1d6c8f911 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixPower.F90 @@ -0,0 +1,92 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! main +!! +SELECT CASE (obj%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From 87565e243790475b29f0e50c1f3ddf6c0d29f73f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:12 +0900 Subject: [PATCH 012/359] update in fevariable --- .../src/include/RealOperatorMatrix.F90 | 93 +++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 diff --git a/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 new file mode 100644 index 000000000..4e5fd0910 --- /dev/null +++ b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 @@ -0,0 +1,93 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From 1ec75e37b26366c2b1a4de87300cf30cf88a185d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:17 +0900 Subject: [PATCH 013/359] update in fevariable --- .../src/include/RealOperatorScalar.F90 | 97 +++++++++++++++++++ 1 file changed, 97 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/RealOperatorScalar.F90 diff --git a/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 new file mode 100644 index 000000000..65efe4e82 --- /dev/null +++ b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 @@ -0,0 +1,97 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & val _OP_ obj1%val(1), & + & typeFEVariableScalar, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & val _OP_ obj1%val(1), & + & typeFEVariableScalar, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & val _OP_ obj1%val(:), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & val _OP_ obj1%val(:), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & val _OP_ obj1%val(:) , & + & typeFEVariableScalar, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & val _OP_ obj1%val(:) , & + & typeFEVariableScalar, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From e3ae405ec2485929548244dfee636413bb8781f3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:21 +0900 Subject: [PATCH 014/359] update in fevariable --- .../src/include/RealOperatorVector.F90 | 93 +++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/RealOperatorVector.F90 diff --git a/src/submodules/FEVariable/src/include/RealOperatorVector.F90 b/src/submodules/FEVariable/src/include/RealOperatorVector.F90 new file mode 100644 index 000000000..c3967937d --- /dev/null +++ b/src/submodules/FEVariable/src/include/RealOperatorVector.F90 @@ -0,0 +1,93 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & val _OP_ obj1%val(:), & + & typeFEVariableVector, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & val _OP_ obj1%val(:), & + & typeFEVariableVector, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From 7aa35e503aacf2c262b490fb1bbd5a62961944ac Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:26 +0900 Subject: [PATCH 015/359] update in fevariable --- .../src/include/ScalarElemMethod.F90 | 61 +++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/ScalarElemMethod.F90 diff --git a/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 b/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 new file mode 100644 index 000000000..47f10e592 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 @@ -0,0 +1,61 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +SELECT CASE (obj%vartype) +CASE (constant) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, & + typeFEVariableConstant) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, & + typeFEVariableConstant) +CASE (space) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpace) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpace) + +CASE (time) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableTime) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableTime) + +CASE (spacetime) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2)) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2)) +END SELECT From 79439e897fd41bf0706f49f60232bc353fdff84f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:30 +0900 Subject: [PATCH 016/359] update in fevariable --- .../src/include/ScalarOperatorMatrix.F90 | 270 ++++++++++++++++++ 1 file changed, 270 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 new file mode 100644 index 000000000..94ae9d056 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 @@ -0,0 +1,270 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + SELECT CASE (obj2%vartype) + !! + !! constant = constant _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + END IF + !! + !! space= constant _OP_ space + !! + CASE (space) + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + !! time=constant _OP_ time + !! + CASE (time) + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + !! + !! spacetime=constant _OP_ spacetime + !! + CASE (spacetime) + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (space) + !! + SELECT CASE (obj2%vartype) + !! + !! space=space _OP_ constant + !! + CASE (constant) + !! + r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1)) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r2 + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + !! + !! space=space _OP_ space + !! + CASE (space) + !! + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable( & + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF + END SELECT +!! +!! +!! +!! +CASE (time) +!! + SELECT CASE (obj2%vartype) + !! + !! time=time _OP_ constant + !! + CASE (constant) + !! + r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) + !! + CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1)) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r2 + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + !! + !! time=time _OP_ time + !! + CASE (time) + !! + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) + !! + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF + END SELECT +!! +!! +!! +!! +CASE (spacetime) + !! + SELECT CASE (obj2%vartype) + !! + !! spacetime= spacetime _OP_ constant + !! + CASE (constant) + !! + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + m2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) + !! + CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) ) + !! + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r2(jj, kk) _OP_ m2 + END DO + END DO + !! + IF(obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + !! + !! spacetime=spacetime _OP_ spacetime + !! + CASE (spacetime) + !! + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + r4 = GET(obj2, typeFEVariableMatrix, typeFEVariableSpaceTime) + !! + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:,:,jj,kk) + END DO + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r4, & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +END SELECT From 5a36aae3a0367e62a10078f1a943106573aa695d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:34 +0900 Subject: [PATCH 017/359] update in fevarible --- .../src/include/ScalarOperatorReal.F90 | 97 +++++++++++++++++++ 1 file changed, 97 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 new file mode 100644 index 000000000..d0052e005 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 @@ -0,0 +1,97 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & obj1%val(1) _OP_ val, & + & typeFEVariableScalar, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj1%val(1) _OP_ val, & + & typeFEVariableScalar, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & obj1%val(:) _OP_ val, & + & typeFEVariableScalar, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & obj1%val(:) _OP_ val, & + & typeFEVariableScalar, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & obj1%val(:) _OP_ val, & + & typeFEVariableScalar, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & obj1%val(:) _OP_ val, & + & typeFEVariableScalar, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From b81cdabeb66a901a40bababff8b819aa91203424 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:38 +0900 Subject: [PATCH 018/359] update in fevariable --- .../src/include/ScalarOperatorScalar.F90 | 223 ++++++++++++++++++ 1 file changed, 223 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 new file mode 100644 index 000000000..57cf08dd1 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 @@ -0,0 +1,223 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) +!! + SELECT CASE (obj2%vartype) + !! + !! constant = constant + constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & obj1%val(1) _OP_ obj2%val(1), & + & typeFEVariableScalar, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj1%val(1) _OP_ obj2%val(1), & + & typeFEVariableScalar, & + & typeFEVariableConstant) + END IF + !! + !! space= constant _OP_ space + !! + CASE (space) + !! + IF( obj2%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & obj1%val(1) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & obj1%val(1) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + END IF + !! + !! time=constant _OP_ time + !! + CASE (time) + !! + IF( obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(& + & obj1%val(1) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & obj1%val(1) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableTime) + END IF + !! + !! spacetime=constant _OP_ spacetime + !! + CASE (spacetime) + !! + IF( obj2%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (space) +!! + SELECT CASE (obj2%vartype) + !! + !! space=space _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & obj1%val(:) _OP_ obj2%val(1), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & obj1%val(:) _OP_ obj2%val(1), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + END IF + !! + !! space=space _OP_ space + !! + CASE (space) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & obj1%val(:) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable( & + & obj1%val(:) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableSpace) + END IF + END SELECT +!! +!! +!! +!! +CASE (time) +!! + SELECT CASE (obj2%vartype) + !! + !! time=time _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & obj1%val(:) _OP_ obj2%val(1), & + & typeFEVariableScalar, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & obj1%val(:) _OP_ obj2%val(1), & + & typeFEVariableScalar, & + & typeFEVariableTime) + END IF + !! + !! time=time _OP_ time + !! + CASE (time) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & obj1%val(:) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & obj1%val(:) _OP_ obj2%val(:), & + & typeFEVariableScalar, & + & typeFEVariableTime) + END IF + END SELECT +!! +!! +!! +!! +CASE (spacetime) + !! + SELECT CASE (obj2%vartype) + !! + !! spacetime= spacetime _OP_ constant + !! + CASE (constant) + !! + IF(obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + END IF + !! + !! spacetime=spacetime _OP_ spacetime + !! + CASE (spacetime) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +END SELECT From c0d8e9b87395bd856e66850768abb3718160fffd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:43 +0900 Subject: [PATCH 019/359] update in fevariable --- .../src/include/ScalarOperatorVector.F90 | 265 ++++++++++++++++++ 1 file changed, 265 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 new file mode 100644 index 000000000..8721caf43 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 @@ -0,0 +1,265 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) +!! + SELECT CASE (obj2%vartype) + !! + !! constant = constant _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & obj1%val(1) _OP_ obj2%val(:), & + & typeFEVariableVector, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj1%val(1) _OP_ obj2%val(:), & + & typeFEVariableVector, & + & typeFEVariableConstant) + END IF + !! + !! space= constant _OP_ space + !! + CASE (space) + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + !! + !! time=constant _OP_ time + !! + CASE (time) + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + !! + !! spacetime=constant _OP_ spacetime + !! + CASE (spacetime) + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (space) +!! + SELECT CASE (obj2%vartype) + !! + !! space=space _OP_ constant + !! + CASE (constant) + !! + CALL Reallocate(r2, obj2%s(1), obj1%s(1) ) + !! + DO jj = 1, size(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + !! + !! space=space _OP_ space + !! + CASE (space) + !! + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) + !! + DO jj = 1, size(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + END SELECT +!! +!! +!! +!! +CASE (time) +!! + SELECT CASE (obj2%vartype) + !! + !! time=time _OP_ constant + !! + CASE (constant) + !! + CALL Reallocate(r2, obj2%s(1), obj1%s(1) ) + !! + DO jj = 1, size(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + !! + !! time=time _OP_ time + !! + CASE (time) + !! + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) + !! + DO jj = 1, size(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + END SELECT +!! +!! +!! +!! +CASE (spacetime) + !! + SELECT CASE (obj2%vartype) + !! + !! spacetime= spacetime _OP_ constant + !! + CASE (constant) + !! + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + CALL Reallocate( r3, obj2%s(1), size(r2,1), size(r2,2) ) + !! + DO kk = 1, size(r3, 3) + DO jj = 1, size(r3, 2) + r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(:) + END DO + END DO + !! + IF(obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + !! spacetime=spacetime _OP_ spacetime + !! + CASE (spacetime) + !! + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + r3 = GET(obj2, typeFEVariableVector, typeFEVariableSpaceTime) + !! + DO kk = 1, size(r3, 3) + DO jj = 1, size(r3, 2) + r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:,jj,kk) + END DO + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +END SELECT From ec98ecc5c1d97ebd513c05ccd14f1c826d0f04d5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:46 +0900 Subject: [PATCH 020/359] update in fevariable --- .../FEVariable/src/include/ScalarPower.F90 | 94 +++++++++++++++++++ 1 file changed, 94 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/ScalarPower.F90 diff --git a/src/submodules/FEVariable/src/include/ScalarPower.F90 b/src/submodules/FEVariable/src/include/ScalarPower.F90 new file mode 100644 index 000000000..2d2f8c032 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarPower.F90 @@ -0,0 +1,94 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +!! +!! main +!! +SELECT CASE (obj%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & obj%val(1) ** n, & + & typeFEVariableScalar, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj%val(1) ** n, & + & typeFEVariableScalar, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & obj%val(:) ** n, & + & typeFEVariableScalar, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & obj%val(:) ** n, & + & typeFEVariableScalar, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & obj%val(:) ** n, & + & typeFEVariableScalar, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & obj%val(:) ** n, & + & typeFEVariableScalar, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & + & typeFEVariableScalar, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From 0dfd42ac1b8da259dfd324af986bd9c8930e0b0d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 17:19:52 +0900 Subject: [PATCH 021/359] update in fevariable --- .../src/include/VectorElemMethod.F90 | 68 +++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/VectorElemMethod.F90 diff --git a/src/submodules/FEVariable/src/include/VectorElemMethod.F90 b/src/submodules/FEVariable/src/include/VectorElemMethod.F90 new file mode 100644 index 000000000..8dbc238b0 --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorElemMethod.F90 @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +SELECT CASE (obj%vartype) +CASE (constant) + + IF (obj%defineon .EQ. nodal) THEN + + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableConstant) + + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableConstant) + +CASE (space) + + IF (obj%defineon .EQ. nodal) THEN + + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpace, obj%s(1:2)) + RETURN + + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpace, obj%s(1:2)) + +CASE (time) + + IF (obj%defineon .EQ. nodal) THEN + + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableTime, obj%s(1:2)) + + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableTime, obj%s(1:2)) + +CASE (spacetime) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3)) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3)) + +END SELECT From 60508fe24bb1a3ab2d2896ebb3f296432f76f9d9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:15 +0900 Subject: [PATCH 022/359] updates in fevariable --- .../src/include/VectorOperatorReal.F90 | 97 +++++++++++++++++++ 1 file changed, 97 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/VectorOperatorReal.F90 diff --git a/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 new file mode 100644 index 000000000..439c71976 --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 @@ -0,0 +1,97 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & obj1%val(:) _OP_ val, & + & typeFEVariableVector, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj1%val(:) _OP_ val, & + & typeFEVariableVector, & + & typeFEVariableConstant) + ENDIF +!! +!! +!! +!! +CASE (space) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ENDIF +!! +!! +!! +!! +CASE (time) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ENDIF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ENDIF +!! +!! +!! +!! +END SELECT From e320aefb1e6886177c33ebe31ede188e8973b97a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:19 +0900 Subject: [PATCH 023/359] updates in fevariable --- .../src/include/VectorOperatorScalar.F90 | 265 ++++++++++++++++++ 1 file changed, 265 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 diff --git a/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 new file mode 100644 index 000000000..1f44747c1 --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 @@ -0,0 +1,265 @@ +! This PROGRAM is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This PROGRAM is free software: you can REDISTRIBUTE it and/or modify +! it under the terms of the GNU General PUBLIC License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This PROGRAM is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General PUBLIC License for more details. +! +! You should have received a copy of the GNU General PUBLIC License +! along WITH this PROGRAM. IF not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) + !! + SELECT CASE (obj2%vartype) + !! + !! constant = constant _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & obj1%val(:) _OP_ obj2%val(1), & + & typeFEVariableVector, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj1%val(:) _OP_ obj2%val(1), & + & typeFEVariableVector, & + & typeFEVariableConstant) + END IF + !! + !! space= constant _OP_ space + !! + CASE (space) + !! + CALL Reallocate(r2, obj1%s(1), obj2%s(1)) + !! + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj) + END DO + !! + IF( obj2%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + !! + !! time=constant _OP_ time + !! + CASE (time) + !! + CALL Reallocate(r2, obj1%s(1), obj2%s(1)) + !! + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj) + END DO + !! + IF( obj2%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + !! + !! spacetime=constant _OP_ spacetime + !! + CASE (spacetime) + !! + r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) + CALL Reallocate( r3, obj1%s(1), SIZE(r2,1), SIZE(r2,2) ) + !! + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = obj1%val(:) _OP_ r2(jj, kk) + END DO + END DO + !! + IF(obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (space) +!! + SELECT CASE (obj1%vartype) + !! + !! space=space _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + !! + !! space=space _OP_ space + !! + CASE (space) + !! + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) + !! + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + END SELECT +!! +!! +!! +!! +CASE (time) +!! + SELECT CASE (obj1%vartype) + !! + !! time=time _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + !! + !! time=time _OP_ time + !! + CASE (time) + !! + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) + !! + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + END SELECT +!! +!! +!! +!! +CASE (spacetime) + !! + SELECT CASE (obj1%vartype) + !! + !! spacetime= spacetime _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + !! spacetime=spacetime _OP_ spacetime + !! + CASE (spacetime) + !! + r3 = GET(obj1, typeFEVariableVector, typeFEVariableSpaceTime) + r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) + !! + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r3(:,jj,kk) _OP_ r2(jj, kk) + END DO + END DO + !! + IF( obj1%defineon .EQ. Nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +END SELECT From aadd9285f32e349c79b27ab67add58762ca460bf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:25 +0900 Subject: [PATCH 024/359] updates in fevariable --- .../src/include/VectorOperatorVector.F90 | 258 ++++++++++++++++++ 1 file changed, 258 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/VectorOperatorVector.F90 diff --git a/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 new file mode 100644 index 000000000..a8a1d632f --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 @@ -0,0 +1,258 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ScalarAddition +!---------------------------------------------------------------------------- + +!! Internal variable +! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) +! INTEGER(I4B) :: jj, kk +!! +!! main +!! +SELECT CASE (obj1%vartype) +!! +!! +!! +!! +CASE (constant) +!! + SELECT CASE (obj2%vartype) + !! + !! constant = constant _OP_ constant + !! + CASE (constant) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & obj1%val(:) _OP_ obj2%val(:), & + & typeFEVariableVector, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj1%val(:) _OP_ obj2%val(:), & + & typeFEVariableVector, & + & typeFEVariableConstant) + END IF + !! + !! space= constant _OP_ space + !! + CASE (space) + !! + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(:) _OP_ r2(:, jj) + END DO + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + !! + !! time=constant _OP_ time + !! + CASE (time) + !! + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(:) _OP_ r2(:, jj) + END DO + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + !! + !! spacetime=constant _OP_ spacetime + !! + CASE (spacetime) + !! + r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = obj1%val(:) _OP_ r3(:, jj, kk) + END DO + END DO + !! + IF( obj2%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (space) +!! + SELECT CASE (obj2%vartype) + !! + !! space=space _OP_ constant + !! + CASE (constant) + !! + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) + !! + DO jj = 1, SIZE(r2,2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(:) + END DO + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & r2, & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + !! + !! space=space _OP_ space + !! + CASE (space) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF + !! + END SELECT +!! +!! +!! +!! +CASE (time) +!! + SELECT CASE (obj2%vartype) + !! + !! time=time _OP_ constant + !! + CASE (constant) + !! + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) + DO jj = 1, SIZE(r2,2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(:) + END DO + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & r2, & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + !! + !! time=time _OP_ time + !! + CASE (time) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF + !! + END SELECT +!! +CASE (spacetime) + !! + SELECT CASE (obj2%vartype) + !! + !! spacetime= spacetime _OP_ constant + !! + CASE (constant) + !! + r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(:) + END DO + END DO + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & r3, & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + !! spacetime=spacetime _OP_ spacetime + !! + CASE (spacetime) + !! + IF( obj1%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF + !! + END SELECT + !! +END SELECT From 830eea49981844973ee977393a5c5da34b80c98e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:31 +0900 Subject: [PATCH 025/359] updates in fevariable --- .../FEVariable/src/include/VectorPower.F90 | 93 +++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/VectorPower.F90 diff --git a/src/submodules/FEVariable/src/include/VectorPower.F90 b/src/submodules/FEVariable/src/include/VectorPower.F90 new file mode 100644 index 000000000..83bc64b8d --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorPower.F90 @@ -0,0 +1,93 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! main +!! +SELECT CASE (obj%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable( & + & obj%val(:)**n, & + & typeFEVariableVector, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj%val(:)**n, & + & typeFEVariableVector, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable( & + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT From cbb563d716da061bc1ff94646a58e828e4e28b71 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:40 +0900 Subject: [PATCH 026/359] updates in fevariable --- .../src/include/matrix_constant.F90 | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_constant.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_constant.F90 b/src/submodules/FEVariable/src/include/matrix_constant.F90 new file mode 100644 index 000000000..bb2d804b9 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_constant.F90 @@ -0,0 +1,19 @@ +INTEGER(I4B) :: ii, jj, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Constant From 32a2da3bcf5370311c932212f90bf812eb8bf362 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:45 +0900 Subject: [PATCH 027/359] updates in fevariable --- .../FEVariable/src/include/matrix_constant2.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_constant2.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_constant2.F90 b/src/submodules/FEVariable/src/include/matrix_constant2.F90 new file mode 100644 index 000000000..062b751b9 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_constant2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Constant From 00379d9c292654d11cf6f9cea26cd479b26d762b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:50 +0900 Subject: [PATCH 028/359] updates in fevariable --- .../FEVariable/src/include/matrix_space.F90 | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_space.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_space.F90 b/src/submodules/FEVariable/src/include/matrix_space.F90 new file mode 100644 index 000000000..0cd267920 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space.F90 @@ -0,0 +1,21 @@ +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO + +obj%s(1:3) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Space From ad430755ce9b6229462328f8f6af3eb0917194e9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:12:54 +0900 Subject: [PATCH 029/359] updates in fevariable --- .../FEVariable/src/include/matrix_space2.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_space2.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_space2.F90 b/src/submodules/FEVariable/src/include/matrix_space2.F90 new file mode 100644 index 000000000..d9cd89b84 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:3) = s(1:3) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Space From 2983c190ad029711c4062a3fca4b546ed5bd318f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:00 +0900 Subject: [PATCH 030/359] updates in fevariable --- .../src/include/matrix_space_time.F90 | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_space_time.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_space_time.F90 b/src/submodules/FEVariable/src/include/matrix_space_time.F90 new file mode 100644 index 000000000..3a6463630 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space_time.F90 @@ -0,0 +1,23 @@ +INTEGER(I4B) :: ii, jj, kk, ll, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO ll = 1, SIZE(val, 4) + DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk, ll) + END DO + END DO + END DO +END DO + +obj%s(1:4) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = SpaceTime From 11697d3b8bcba6433a62c0b3c7e75789d6d7a932 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:05 +0900 Subject: [PATCH 031/359] updates in fevariable --- .../FEVariable/src/include/matrix_space_time2.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_space_time2.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 new file mode 100644 index 000000000..416f4d703 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:4) = s(1:4) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = SpaceTime From a9f26d174c97f6d83a698d25530dc25307fcbc90 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:11 +0900 Subject: [PATCH 032/359] updates in fevariable --- .../FEVariable/src/include/matrix_time.F90 | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_time.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_time.F90 b/src/submodules/FEVariable/src/include/matrix_time.F90 new file mode 100644 index 000000000..a4b831d86 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_time.F90 @@ -0,0 +1,21 @@ +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO + +obj%s(1:3) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Time From aaab370f9b74bbaeb5d7931e77dba042dabb9f34 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:15 +0900 Subject: [PATCH 033/359] updates in fevariable --- src/submodules/FEVariable/src/include/matrix_time2.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/matrix_time2.F90 diff --git a/src/submodules/FEVariable/src/include/matrix_time2.F90 b/src/submodules/FEVariable/src/include/matrix_time2.F90 new file mode 100644 index 000000000..aaa1007bb --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:3) = s(1:3) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Time From 722b36e8ee2a6ce7072549b6a2ccb61bf4d41265 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:19 +0900 Subject: [PATCH 034/359] updates in fevariable --- src/submodules/FEVariable/src/include/scalar_constant.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/scalar_constant.F90 diff --git a/src/submodules/FEVariable/src/include/scalar_constant.F90 b/src/submodules/FEVariable/src/include/scalar_constant.F90 new file mode 100644 index 000000000..628f7a7b6 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_constant.F90 @@ -0,0 +1,8 @@ +obj%len = 1 +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) +obj%val(1) = val +obj%s(1) = 1 +obj%defineOn = _DEFINEON_ +obj%rank = Scalar +obj%varType = Constant From 8a7d00eb823c7b6736d4dc0a2fec46cdcc382a16 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:26 +0900 Subject: [PATCH 035/359] updates in fevariable --- src/submodules/FEVariable/src/include/scalar_space.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/scalar_space.F90 diff --git a/src/submodules/FEVariable/src/include/scalar_space.F90 b/src/submodules/FEVariable/src/include/scalar_space.F90 new file mode 100644 index 000000000..c43d15d52 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_space.F90 @@ -0,0 +1,8 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) +obj%val(1:obj%len) = val +obj%s(1) = SIZE(val) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = Space From 9bc7629c1242da0848966d9f80b3fac0037b0a35 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:31 +0900 Subject: [PATCH 036/359] updates in fevariable --- .../src/include/scalar_space_time.F90 | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 src/submodules/FEVariable/src/include/scalar_space_time.F90 diff --git a/src/submodules/FEVariable/src/include/scalar_space_time.F90 b/src/submodules/FEVariable/src/include/scalar_space_time.F90 new file mode 100644 index 000000000..75ee2a726 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_space_time.F90 @@ -0,0 +1,18 @@ +INTEGER(I4B) :: ii, jj, kk + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +kk = 0 +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + kk = kk + 1 + obj%val(kk) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = SpaceTime From 43d4fbd2c9a9123db287ceb15011f05454077eb2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 13 Jun 2024 18:13:38 +0900 Subject: [PATCH 037/359] updates in fevariable --- .../src/FEVariable_Method@AbsMethods.F90 | 28 +- .../src/FEVariable_Method@AdditionMethods.F90 | 26 +- .../FEVariable_Method@ConstructorMethods.F90 | 480 +++++++++++------- .../src/FEVariable_Method@DivisionMethods.F90 | 54 +- .../src/FEVariable_Method@EqualMethods.F90 | 36 +- .../src/FEVariable_Method@GetMethods.F90 | 159 ++++-- .../src/FEVariable_Method@IOMethods.F90 | 174 +++---- ...EVariable_Method@MultiplicationMethods.F90 | 54 +- .../src/FEVariable_Method@PowerMethods.F90 | 6 +- .../src/FEVariable_Method@SqrtMethods.F90 | 6 +- .../FEVariable_Method@SubtractionMethods.F90 | 54 +- .../FEVariable/src/MatrixElemMethod.inc | 92 ---- .../FEVariable/src/MatrixOperatorMatrix.inc | 265 ---------- .../FEVariable/src/MatrixOperatorReal.inc | 92 ---- .../FEVariable/src/MatrixOperatorScalar.inc | 271 ---------- src/submodules/FEVariable/src/MatrixPower.inc | 92 ---- .../FEVariable/src/RealOperatorMatrix.inc | 93 ---- .../FEVariable/src/RealOperatorScalar.inc | 97 ---- .../FEVariable/src/RealOperatorVector.inc | 93 ---- .../FEVariable/src/ScalarElemMethod.inc | 94 ---- .../FEVariable/src/ScalarOperatorMatrix.inc | 270 ---------- .../FEVariable/src/ScalarOperatorReal.inc | 97 ---- .../FEVariable/src/ScalarOperatorScalar.inc | 223 -------- .../FEVariable/src/ScalarOperatorVector.inc | 265 ---------- src/submodules/FEVariable/src/ScalarPower.inc | 94 ---- .../FEVariable/src/VectorElemMethod.inc | 93 ---- .../FEVariable/src/VectorOperatorReal.inc | 97 ---- .../FEVariable/src/VectorOperatorScalar.inc | 265 ---------- .../FEVariable/src/VectorOperatorVector.inc | 258 ---------- src/submodules/FEVariable/src/VectorPower.inc | 93 ---- .../src/include/scalar_space_time2.F90 | 12 + .../FEVariable/src/include/scalar_time.F90 | 8 + .../src/include/vector_constant.F90 | 10 + .../FEVariable/src/include/vector_space.F90 | 18 + .../FEVariable/src/include/vector_space2.F90 | 10 + .../src/include/vector_space_time.F90 | 21 + .../src/include/vector_space_time2.F90 | 10 + .../FEVariable/src/include/vector_time.F90 | 18 + .../FEVariable/src/include/vector_time2.F90 | 10 + 39 files changed, 747 insertions(+), 3391 deletions(-) delete mode 100644 src/submodules/FEVariable/src/MatrixElemMethod.inc delete mode 100644 src/submodules/FEVariable/src/MatrixOperatorMatrix.inc delete mode 100644 src/submodules/FEVariable/src/MatrixOperatorReal.inc delete mode 100644 src/submodules/FEVariable/src/MatrixOperatorScalar.inc delete mode 100644 src/submodules/FEVariable/src/MatrixPower.inc delete mode 100644 src/submodules/FEVariable/src/RealOperatorMatrix.inc delete mode 100644 src/submodules/FEVariable/src/RealOperatorScalar.inc delete mode 100644 src/submodules/FEVariable/src/RealOperatorVector.inc delete mode 100644 src/submodules/FEVariable/src/ScalarElemMethod.inc delete mode 100644 src/submodules/FEVariable/src/ScalarOperatorMatrix.inc delete mode 100644 src/submodules/FEVariable/src/ScalarOperatorReal.inc delete mode 100644 src/submodules/FEVariable/src/ScalarOperatorScalar.inc delete mode 100644 src/submodules/FEVariable/src/ScalarOperatorVector.inc delete mode 100644 src/submodules/FEVariable/src/ScalarPower.inc delete mode 100644 src/submodules/FEVariable/src/VectorElemMethod.inc delete mode 100644 src/submodules/FEVariable/src/VectorOperatorReal.inc delete mode 100644 src/submodules/FEVariable/src/VectorOperatorScalar.inc delete mode 100644 src/submodules/FEVariable/src/VectorOperatorVector.inc delete mode 100644 src/submodules/FEVariable/src/VectorPower.inc create mode 100644 src/submodules/FEVariable/src/include/scalar_space_time2.F90 create mode 100644 src/submodules/FEVariable/src/include/scalar_time.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_constant.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space2.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space_time.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space_time2.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_time.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_time2.F90 diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 index 30baa84be..536a67668 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 @@ -18,7 +18,17 @@ #define _ELEM_METHOD_ ABS SUBMODULE(FEVariable_Method) AbsMethods -USE BaseMethod +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, & + Nodal, Quadrature +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + IMPLICIT NONE CONTAINS @@ -28,18 +38,18 @@ MODULE PROCEDURE fevar_Abs SELECT CASE (obj%rank) -!! + CASE (SCALAR) -#include "./ScalarElemMethod.inc" -!! +#include "./include/ScalarElemMethod.F90" + CASE (VECTOR) -#include "./VectorElemMethod.inc" -!! +#include "./include/VectorElemMethod.F90" + CASE (MATRIX) -#include "./MatrixElemMethod.inc" -!! +#include "./include/MatrixElemMethod.F90" + END SELECT -!! + END PROCEDURE fevar_Abs !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 index 2f7209883..c821e9660 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 @@ -40,13 +40,13 @@ SELECT CASE (obj2%rank) !! scalar, scalar CASE (scalar) -#include "./ScalarOperatorScalar.inc" +#include "./include/ScalarOperatorScalar.F90" !! scalar, vector CASE (vector) -#include "./ScalarOperatorVector.inc" +#include "./include/ScalarOperatorVector.F90" !! scalar, matrix CASE (matrix) -#include "./ScalarOperatorMatrix.inc" +#include "./include/ScalarOperatorMatrix.F90" END SELECT !! !! @@ -57,10 +57,10 @@ SELECT CASE (obj2%rank) !! vector, scalar CASE (scalar) -#include "./VectorOperatorScalar.inc" +#include "./include/VectorOperatorScalar.F90" !! vector, vector CASE (vector) -#include "./VectorOperatorVector.inc" +#include "./include/VectorOperatorVector.F90" END SELECT !! !! @@ -71,10 +71,10 @@ SELECT CASE (obj2%rank) CASE (scalar) !! matrix, scalar -#include "./MatrixOperatorScalar.inc" +#include "./include/MatrixOperatorScalar.F90" CASE (matrix) !! matrix, matrix -#include "./MatrixOperatorMatrix.inc" +#include "./include/MatrixOperatorMatrix.F90" END SELECT !! !! @@ -95,19 +95,19 @@ !! !! CASE (SCALAR) -#include "./ScalarOperatorReal.inc" +#include "./include/ScalarOperatorReal.F90" !! !! !! !! CASE (VECTOR) -#include "./VectorOperatorReal.inc" +#include "./include/VectorOperatorReal.F90" !! !! !! !! CASE (MATRIX) -#include "./MatrixOperatorReal.inc" +#include "./include/MatrixOperatorReal.F90" !! !! !! @@ -127,19 +127,19 @@ !! !! CASE (SCALAR) -#include "./RealOperatorScalar.inc" +#include "./include/RealOperatorScalar.F90" !! !! !! !! CASE (VECTOR) -#include "./RealOperatorVector.inc" +#include "./include/RealOperatorVector.F90" !! !! !! !! CASE (MATRIX) -#include "./RealOperatorMatrix.inc" +#include "./include/RealOperatorMatrix.F90" !! !! !! diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 index e82d0a0c3..4cd019838 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 @@ -16,7 +16,11 @@ ! SUBMODULE(FEVariable_Method) ConstructorMethods -USE BaseMethod +USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & + Time, SpaceTime, Nodal, Quadrature + +USE ReallocateUtility, ONLY: Reallocate + IMPLICIT NONE CONTAINS @@ -39,13 +43,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Nodal_Scalar_Constant -obj%val = [val] -obj%s(1) = 1 -obj%defineOn = NODAL -obj%rank = SCALAR -obj%varType = CONSTANT -obj%len = 1 -obj%capacity = 1 +#define _DEFINEON_ Nodal +#include "./include/scalar_constant.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Scalar_Constant !---------------------------------------------------------------------------- @@ -53,13 +53,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Nodal_Scalar_Space -obj%val = val -obj%s(1) = SIZE(val) -obj%defineOn = NODAL -obj%rank = SCALAR -obj%varType = SPACE -obj%len = SIZE(val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/scalar_space.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Scalar_Space !---------------------------------------------------------------------------- @@ -67,41 +63,39 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Nodal_Scalar_Time -obj%val = val -obj%s(1) = SIZE(val) -obj%defineOn = NODAL -obj%rank = SCALAR -obj%varType = TIME -obj%len = SIZE(val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/scalar_time.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Scalar_Time !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- -MODULE PROCEDURE Nodal_Scalar_Spacetime -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = SCALAR -obj%varType = SPACETIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len -END PROCEDURE Nodal_Scalar_Spacetime +MODULE PROCEDURE Nodal_Scalar_SpaceTime +#define _DEFINEON_ Nodal +#include "./include/scalar_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Scalar_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_SpaceTime2 +#define _DEFINEON_ Nodal +#include "./include/scalar_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Scalar_SpaceTime2 !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Nodal_Vector_Constant -obj%val = val -obj%s(1:1) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = VECTOR -obj%varType = CONSTANT -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/vector_constant.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Vector_Constant !---------------------------------------------------------------------------- @@ -109,265 +103,365 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Nodal_Vector_Space -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = VECTOR -obj%varType = SPACE -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/vector_space.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Vector_Space !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- +MODULE PROCEDURE Nodal_Vector_Space2 +#define _DEFINEON_ Nodal +#include "./include/vector_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_Space2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + MODULE PROCEDURE Nodal_Vector_Time -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = VECTOR -obj%varType = TIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/vector_time.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Vector_Time !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- -MODULE PROCEDURE Nodal_Vector_Spacetime -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:3) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = VECTOR -obj%varType = SPACETIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len -END PROCEDURE Nodal_Vector_Spacetime +MODULE PROCEDURE Nodal_Vector_Time2 +#define _DEFINEON_ Nodal +#include "./include/vector_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_Time2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_SpaceTime +#define _DEFINEON_ Nodal +#include "./include/vector_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_SpaceTime2 +#define _DEFINEON_ Nodal +#include "./include/vector_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_SpaceTime2 !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Nodal_Matrix_Constant -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = MATRIX -obj%varType = CONSTANT -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/matrix_constant.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Matrix_Constant !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- +MODULE PROCEDURE Nodal_Matrix_Constant2 +#define _DEFINEON_ Nodal +#include "./include/matrix_constant2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Constant2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + MODULE PROCEDURE Nodal_Matrix_Space -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:3) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = MATRIX -obj%varType = SPACE -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/matrix_space.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Matrix_Space !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- +MODULE PROCEDURE Nodal_Matrix_Space2 +#define _DEFINEON_ Nodal +#include "./include/matrix_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Space2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + MODULE PROCEDURE Nodal_Matrix_Time -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:3) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = MATRIX -obj%varType = TIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Nodal +#include "./include/matrix_time.F90" +#undef _DEFINEON_ END PROCEDURE Nodal_Matrix_Time !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- -MODULE PROCEDURE Nodal_Matrix_Spacetime -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:4) = SHAPE(val) -obj%defineOn = NODAL -obj%rank = MATRIX -obj%varType = SPACETIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len -END PROCEDURE Nodal_Matrix_Spacetime +MODULE PROCEDURE Nodal_Matrix_Time2 +#define _DEFINEON_ Nodal +#include "./include/matrix_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Time2 !---------------------------------------------------------------------------- -! QuadratureVariable +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_SpaceTime +#define _DEFINEON_ Nodal +#include "./include/matrix_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_SpaceTime2 +#define _DEFINEON_ Nodal +#include "./include/matrix_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_SpaceTime2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_Constant -obj%val = [val] -obj%s = 0 -obj%defineOn = Quadrature -obj%rank = SCALAR -obj%varType = CONSTANT -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/scalar_constant.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Scalar_Constant !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_Space -obj%val = val -obj%s(1) = SIZE(val) -obj%defineOn = Quadrature -obj%rank = SCALAR -obj%varType = SPACE -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/scalar_space.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Scalar_Space !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_Time -obj%val = val -obj%s(1) = SIZE(val) -obj%defineOn = Quadrature -obj%rank = SCALAR -obj%varType = TIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/scalar_time.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Scalar_Time !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable !---------------------------------------------------------------------------- -MODULE PROCEDURE Quadrature_Scalar_Spacetime -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = SCALAR -obj%varType = SPACETIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len -END PROCEDURE Quadrature_Scalar_Spacetime +MODULE PROCEDURE Quadrature_Scalar_SpaceTime +#define _DEFINEON_ Quadrature +#include "./include/scalar_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Scalar_SpaceTime !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_SpaceTime2 +#define _DEFINEON_ Quadrature +#include "./include/scalar_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Scalar_SpaceTime2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Constant -obj%val = val -obj%s(1:1) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = VECTOR -obj%varType = CONSTANT -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/vector_constant.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Vector_Constant !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Space -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = VECTOR -obj%varType = SPACE -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/vector_space.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Vector_Space !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Space2 +#define _DEFINEON_ Quadrature +#include "./include/vector_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_Space2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Time -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = VECTOR -obj%varType = TIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/vector_time.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Vector_Time !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Time2 +#define _DEFINEON_ Quadrature +#include "./include/vector_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_Time2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- -MODULE PROCEDURE Quadrature_Vector_Spacetime -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:3) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = VECTOR -obj%varType = SPACETIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len -END PROCEDURE Quadrature_Vector_Spacetime +MODULE PROCEDURE Quadrature_Vector_SpaceTime +#define _DEFINEON_ Quadrature +#include "./include/vector_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_SpaceTime !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_SpaceTime2 +#define _DEFINEON_ Quadrature +#include "./include/vector_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_SpaceTime2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Constant -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:2) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = MATRIX -obj%varType = CONSTANT -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/matrix_constant.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Matrix_Constant !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Constant2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_constant2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Constant2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Space -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:3) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = MATRIX -obj%varType = SPACE -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/matrix_space.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Matrix_Space !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Space2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Space2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Time -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:3) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = MATRIX -obj%varType = TIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len +#define _DEFINEON_ Quadrature +#include "./include/matrix_time.F90" +#undef _DEFINEON_ END PROCEDURE Quadrature_Matrix_Time !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Time2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Time2 + +!---------------------------------------------------------------------------- +! QuadratureVariable !---------------------------------------------------------------------------- -MODULE PROCEDURE Quadrature_Matrix_Spacetime -obj%val = RESHAPE(val, [SIZE(val)]) -obj%s(1:4) = SHAPE(val) -obj%defineOn = Quadrature -obj%rank = MATRIX -obj%varType = SPACETIME -obj%len = SIZE(obj%val) -obj%capacity = obj%len -END PROCEDURE Quadrature_Matrix_Spacetime +MODULE PROCEDURE Quadrature_Matrix_SpaceTime +#define _DEFINEON_ Quadrature +#include "./include/matrix_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_SpaceTime + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_SpaceTime2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_SpaceTime2 + +!---------------------------------------------------------------------------- +! Copy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Copy +obj1%s = obj2%s +obj1%defineOn = obj2%defineOn +obj1%rank = obj2%rank +obj1%varType = obj2%varType +obj1%len = obj2%len + +IF (obj1%capacity .GE. obj1%len) THEN + obj1%val(1:obj1%len) = obj2%val(1:obj1%len) + RETURN +END IF + +obj1%capacity = CAPACITY_EXPAND_FACTOR * obj1%len +CALL Reallocate(obj1%val, obj1%capacity) +obj1%val(1:obj1%len) = obj2%val(1:obj1%len) + +END PROCEDURE obj_Copy + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- END SUBMODULE ConstructorMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 index 2bf089160..8447ad19c 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 @@ -27,7 +27,7 @@ MODULE PROCEDURE fevar_Division1 !! -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:) +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) INTEGER(I4B) :: jj, kk !! SELECT CASE (obj1%rank) @@ -37,45 +37,45 @@ !! CASE (SCALAR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! scalar, scalar - case( scalar ) -#include "./ScalarOperatorScalar.inc" + CASE (scalar) +#include "./include/ScalarOperatorScalar.F90" !! scalar, vector - case( vector ) -#include "./ScalarOperatorVector.inc" + CASE (vector) +#include "./include/ScalarOperatorVector.F90" !! scalar, matrix - case( matrix ) -#include "./ScalarOperatorMatrix.inc" - end select + CASE (matrix) +#include "./include/ScalarOperatorMatrix.F90" + END SELECT !! !! !! !! CASE (VECTOR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! vector, scalar - case( scalar ) -#include "./VectorOperatorScalar.inc" + CASE (scalar) +#include "./include/VectorOperatorScalar.F90" !! vector, vector - case( vector ) -#include "./VectorOperatorVector.inc" - end select + CASE (vector) +#include "./include/VectorOperatorVector.F90" + END SELECT !! !! !! !! CASE (MATRIX) !! - select case( obj2%rank ) - case( scalar ) + SELECT CASE (obj2%rank) + CASE (scalar) !! matrix, scalar -#include "./MatrixOperatorScalar.inc" - case( matrix ) +#include "./include/MatrixOperatorScalar.F90" + CASE (matrix) !! matrix, matrix -#include "./MatrixOperatorMatrix.inc" - end select +#include "./include/MatrixOperatorMatrix.F90" + END SELECT !! !! !! @@ -95,19 +95,19 @@ !! !! CASE (SCALAR) -#include "./ScalarOperatorReal.inc" +#include "./include/ScalarOperatorReal.F90" !! !! !! !! CASE (VECTOR) -#include "./VectorOperatorReal.inc" +#include "./include/VectorOperatorReal.F90" !! !! !! !! CASE (MATRIX) -#include "./MatrixOperatorReal.inc" +#include "./include/MatrixOperatorReal.F90" !! !! !! @@ -127,19 +127,19 @@ !! !! CASE (SCALAR) -#include "./RealOperatorScalar.inc" +#include "./include/RealOperatorScalar.F90" !! !! !! !! CASE (VECTOR) -#include "./RealOperatorVector.inc" +#include "./include/RealOperatorVector.F90" !! !! !! !! CASE (MATRIX) -#include "./RealOperatorMatrix.inc" +#include "./include/RealOperatorMatrix.F90" !! !! !! diff --git a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 index a23c6c040..f43568827 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 @@ -16,7 +16,8 @@ ! SUBMODULE(FEVariable_Method) EqualMethods -USE BaseMethod +USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) + IMPLICIT NONE CONTAINS @@ -27,11 +28,13 @@ MODULE PROCEDURE fevar_isequal !! Internal variable ans = .FALSE. -IF( ALL(obj1%val .APPROXEQ. obj2%val) ) ans = .TRUE. -IF( obj1%defineon .ne. obj2%defineon ) ans = .FALSE. -IF( obj1%rank .ne. obj2%rank ) ans = .FALSE. -IF( obj1%varType .ne. obj2%varType ) ans = .FALSE. -IF( ANY(obj1%s .NE. obj2%s) ) ans = .FALSE. +IF (obj1%len .NE. obj2%len) RETURN +IF (obj1%defineon .NE. obj2%defineon) RETURN +IF (obj1%rank .NE. obj2%rank) RETURN +IF (obj1%varType .NE. obj2%varType) RETURN +IF (ANY(obj1%s .NE. obj2%s)) RETURN + +IF (ALL(obj1%val.APPROXEQ.obj2%val)) ans = .TRUE. !! END PROCEDURE fevar_isequal @@ -40,33 +43,32 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_notEqual -!! Internal variable ans = .FALSE. -IF( .NOT. ALL(obj1%val .APPROXEQ. obj2%val) ) THEN +IF (.NOT. ALL(obj1%val.APPROXEQ.obj2%val)) THEN ans = .TRUE. RETURN END IF -!! -IF( obj1%defineon .ne. obj2%defineon ) THEN + +IF (obj1%defineon .NE. obj2%defineon) THEN ans = .TRUE. RETURN END IF -!! -IF( obj1%rank .ne. obj2%rank ) THEN + +IF (obj1%rank .NE. obj2%rank) THEN ans = .TRUE. RETURN END IF -!! -IF( obj1%varType .ne. obj2%varType ) THEN + +IF (obj1%varType .NE. obj2%varType) THEN ans = .TRUE. RETURN END IF -!! -IF( ANY(obj1%s .NE. obj2%s) ) THEN + +IF (ANY(obj1%s .NE. obj2%s)) THEN ans = .TRUE. RETURN END IF -!! + END PROCEDURE fevar_notEqual !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 index 59af867b2..93c5e0c55 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 @@ -15,7 +15,9 @@ ! along with this program. If not, see SUBMODULE(FEVariable_Method) GetMethods -USE BaseMethod, ONLY: Reallocate +USE ReallocateUtility, ONLY: Reallocate +USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & + Time, SpaceTime, Nodal, Quadrature IMPLICIT NONE CONTAINS @@ -24,29 +26,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_GetLambdaFromYoungsModulus -INTEGER(I4B) :: tsize, ii -LOGICAL(LGT) :: isok +INTEGER(I4B) :: ii -isok = ALLOCATED(youngsModulus%val) +lambda = youngsModulus -IF (isok) THEN - tsize = SIZE(youngsModulus%val) -ELSE - tsize = 0 -END IF - -CALL Reallocate(lambda%val, tsize) - -DO ii = 1, tsize - lambda%val(1:tsize) = shearModulus%val * & - & (youngsModulus%val - 2.0_DFP * shearModulus%val) / & - & (3.0_DFP * shearModulus%val - youngsModulus%val) +DO CONCURRENT(ii=1:lambda%len) + lambda%val(ii) = shearModulus%val(ii) * & + (youngsModulus%val(ii) - 2.0_DFP * shearModulus%val(ii)) / & + (3.0_DFP * shearModulus%val(ii) - youngsModulus%val(ii)) END DO -lambda%s = youngsModulus%s -lambda%defineOn = youngsModulus%defineOn -lambda%varType = youngsModulus%varType -lambda%rank = youngsModulus%rank END PROCEDURE fevar_GetLambdaFromYoungsModulus !---------------------------------------------------------------------------- @@ -126,11 +115,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_isNodalVariable -IF (obj%defineon .EQ. nodal) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF +ans = obj%defineon .EQ. nodal END PROCEDURE fevar_isNodalVariable !---------------------------------------------------------------------------- @@ -138,11 +123,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_isQuadratureVariable -IF (obj%defineon .EQ. nodal) THEN - ans = .FALSE. -ELSE - ans = .TRUE. -END IF +ans = obj%defineon .NE. nodal END PROCEDURE fevar_isQuadratureVariable !---------------------------------------------------------------------------- @@ -158,7 +139,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Space -val = obj%val +ALLOCATE (val(obj%len)) +val = obj%val(1:obj%len) END PROCEDURE Scalar_Space !---------------------------------------------------------------------------- @@ -166,7 +148,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Time -val = obj%val +ALLOCATE (val(obj%len)) +val = obj%val(1:obj%len) END PROCEDURE Scalar_Time !---------------------------------------------------------------------------- @@ -174,7 +157,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_SpaceTime -val = RESHAPE(obj%val, obj%s(1:2)) +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + + END DO +END DO + END PROCEDURE Scalar_SpaceTime !---------------------------------------------------------------------------- @@ -182,7 +177,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Constant -val = obj%val +ALLOCATE (val(obj%len)) +val = obj%val(1:obj%len) END PROCEDURE Vector_Constant !---------------------------------------------------------------------------- @@ -190,7 +186,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Space -val = RESHAPE(obj%val, obj%s(1:2)) +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + END DO +END DO + END PROCEDURE Vector_Space !---------------------------------------------------------------------------- @@ -198,7 +205,17 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Time -val = RESHAPE(obj%val, obj%s(1:2)) +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + END DO +END DO END PROCEDURE Vector_Time !---------------------------------------------------------------------------- @@ -206,7 +223,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_SpaceTime -val = RESHAPE(obj%val, obj%s(1:3)) +INTEGER(I4B) :: ii, jj, kk, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) + +cnt = 0 +DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk) = obj%val(cnt) + END DO + END DO +END DO END PROCEDURE Vector_SpaceTime !---------------------------------------------------------------------------- @@ -214,7 +243,17 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Constant -val = RESHAPE(obj%val, obj%s(1:2)) +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + END DO +END DO END PROCEDURE Matrix_Constant !---------------------------------------------------------------------------- @@ -222,7 +261,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Space -val = RESHAPE(obj%val, obj%s(1:3)) +INTEGER(I4B) :: ii, jj, kk, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) + +cnt = 0 +DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk) = obj%val(cnt) + END DO + END DO +END DO END PROCEDURE Matrix_Space !---------------------------------------------------------------------------- @@ -230,7 +281,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Time -val = RESHAPE(obj%val, obj%s(1:3)) +INTEGER(I4B) :: ii, jj, kk, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) + +cnt = 0 +DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk) = obj%val(cnt) + END DO + END DO +END DO END PROCEDURE Matrix_Time !---------------------------------------------------------------------------- @@ -238,7 +301,21 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_SpaceTime -val = RESHAPE(obj%val, obj%s(1:4)) +INTEGER(I4B) :: ii, jj, kk, ll, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3), obj%s(4))) + +cnt = 0 +DO ll = 1, obj%s(4) + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk, ll) = obj%val(cnt) + END DO + END DO + END DO +END DO END PROCEDURE Matrix_SpaceTime !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 index 8afea2cb1..3ca31c4e0 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 @@ -16,7 +16,13 @@ ! SUBMODULE(FEVariable_Method) IOMethods -USE BaseMethod +USE Display_Method, ONLY: Util_Display => Display, ToString +USE GlobalData, ONLY: Scalar, Vector, Matrix, & + Constant, Space, Time, SpaceTime, Nodal, Quadrature +USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableTime, TypeFEVariableSpaceTime, & + TypeFEVariableScalar, TypeFEVariableVector, & + TypeFEVariableMatrix IMPLICIT NONE CONTAINS @@ -25,97 +31,91 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Display -!! -!! main -!! -CALL Display(msg, unitno=unitno) -!! +CALL Util_Display(msg, unitno=unitno) + SELECT CASE (obj%rank) -!! -!! rank: SCALAR -!! -CASE (SCALAR) - CALL Display("# RANK :: 0 (SCALAR)", unitno=unitno) - !! - SELECT CASE (obj%vartype) - CASE (CONSTANT) - CALL Display("# VarType: CONSTANT", unitno=unitno) - CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableConstant), & - & '# VALUE: ', unitno=unitno) - !! - CASE (SPACE) - CALL Display("# VarType: SPACE", unitno=unitno) - CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableSpace), & - & '# VALUE: ', unitno=unitno) - !! - CASE (TIME) - CALL Display("# VarType: TIME", unitno=unitno) - CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableTime), & - & '# VALUE: ', unitno=unitno) - !! - CASE (SPACETIME) - CALL Display("# VarType: SPACE & TIME", unitno=unitno) - CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableSpaceTime), & - & '# VALUE: ', unitno=unitno) + +CASE (Scalar) + + CALL Util_Display("RANK :: 0 (Scalar)", unitno=unitno) + + SELECT CASE (obj%varType) + CASE (Constant) + CALL Util_Display("VarType: Constant", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) + + CASE (Space) + CALL Util_Display("VarType: Space", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpace), & + 'VALUE: ', unitno=unitno) + CASE (Time) + CALL Util_Display("VarType: Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableTime), & + 'VALUE: ', unitno=unitno) + CASE (SpaceTime) + CALL Util_Display("VarType: Space & Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) + + CASE DEFAULT + CALL Util_Display("VarType: UNKNOWN", unitno=unitno) END SELECT -!! -!! rank: VECTOR -!! -CASE (VECTOR) - !! - CALL Display("RANK :: 1 (VECTOR)", unitno=unitno) - !! - SELECT CASE (obj%vartype) - CASE (CONSTANT) - CALL Display("# VarType: CONSTANT", unitno=unitno) - CALL Display(GET(obj, typeFEVariableVector, typeFEVariableConstant), & - & '# VALUE: ', unitno=unitno) - !! - CASE (SPACE) - CALL Display("# VarType: SPACE", unitno=unitno) - CALL Display(GET(obj, typeFEVariableVector, typeFEVariableSpace), & - & '# VALUE: ', unitno=unitno) - !! - CASE (TIME) - CALL Display("# VarType: TIME", unitno=unitno) - CALL Display(GET(obj, typeFEVariableVector, typeFEVariableTime), & - & '# VALUE: ', unitno=unitno) - !! - CASE (SPACETIME) - CALL Display("# VarType: SPACE & TIME", unitno=unitno) - CALL Display(GET(obj, typeFEVariableVector, typeFEVariableSpaceTime), & - & '# VALUE: ', unitno=unitno) + +CASE (Vector) + + CALL Util_Display("RANK :: 1 (Vector)", unitno=unitno) + SELECT CASE (obj%varType) + CASE (Constant) + CALL Util_Display("VarType: Constant", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) + CASE (Space) + CALL Util_Display("VarType: Space", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpace), & + 'VALUE: ', unitno=unitno) + CASE (Time) + CALL Util_Display("VarType: Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableTime), & + 'VALUE: ', unitno=unitno) + CASE (SpaceTime) + CALL Util_Display("VarType: Space & Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) + + CASE DEFAULT + CALL Util_Display("VarType: UNKNOWN", unitno=unitno) END SELECT -!! -!! rank: MATRIX -!! -CASE (MATRIX) - !! - CALL Display("RANK :: 2 (MATRIX)", unitno=unitno) - !! - SELECT CASE (obj%vartype) - CASE (CONSTANT) - CALL Display("# VarType: CONSTANT", unitno=unitno) - CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableConstant), & - & '# VALUE: ', unitno=unitno) - !! - CASE (SPACE) - CALL Display("# VarType: SPACE", unitno=unitno) - CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableSpace), & - & '# VALUE: ', unitno=unitno) - !! - CASE (TIME) - CALL Display("# VarType: TIME", unitno=unitno) - CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableTime), & - & '# VALUE: ', unitno=unitno) - !! - CASE (SPACETIME) - CALL Display("# VarType: SPACE & TIME", unitno=unitno) - CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableSpaceTime), & - & '# VALUE: ', unitno=unitno) + +CASE (Matrix) + + CALL Util_Display("RANK :: 2 (Matrix)", unitno=unitno) + SELECT CASE (obj%varType) + CASE (Constant) + CALL Util_Display("VarType: Constant", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) + CASE (Space) + CALL Util_Display("VarType: Space", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpace), & + 'VALUE: ', unitno=unitno) + CASE (Time) + CALL Util_Display("VarType: Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableTime), & + 'VALUE: ', unitno=unitno) + CASE (SpaceTime) + CALL Util_Display("VarType: Space & Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) + + CASE DEFAULT + CALL Util_Display("VarType: UNKNOWN", unitno=unitno) END SELECT + +CASE DEFAULT + CALL Util_Display("RANK: UNKNOWN", unitno=unitno) + END SELECT -!! END PROCEDURE fevar_Display END SUBMODULE IOMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 index 2ce794012..610aad3cb 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 @@ -27,7 +27,7 @@ MODULE PROCEDURE fevar_Multiplication1 !! -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:) +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) INTEGER(I4B) :: jj, kk !! SELECT CASE (obj1%rank) @@ -37,45 +37,45 @@ !! CASE (SCALAR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! scalar, scalar - case( scalar ) -#include "./ScalarOperatorScalar.inc" + CASE (scalar) +#include "./include/ScalarOperatorScalar.F90" !! scalar, vector - case( vector ) -#include "./ScalarOperatorVector.inc" + CASE (vector) +#include "./include/ScalarOperatorVector.F90" !! scalar, matrix - case( matrix ) -#include "./ScalarOperatorMatrix.inc" - end select + CASE (matrix) +#include "./include/ScalarOperatorMatrix.F90" + END SELECT !! !! !! !! CASE (VECTOR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! vector, scalar - case( scalar ) -#include "./VectorOperatorScalar.inc" + CASE (scalar) +#include "./include/VectorOperatorScalar.F90" !! vector, vector - case( vector ) -#include "./VectorOperatorVector.inc" - end select + CASE (vector) +#include "./include/VectorOperatorVector.F90" + END SELECT !! !! !! !! CASE (MATRIX) !! - select case( obj2%rank ) - case( scalar ) + SELECT CASE (obj2%rank) + CASE (scalar) !! matrix, scalar -#include "./MatrixOperatorScalar.inc" - case( matrix ) +#include "./include/MatrixOperatorScalar.F90" + CASE (matrix) !! matrix, matrix -#include "./MatrixOperatorMatrix.inc" - end select +#include "./include/MatrixOperatorMatrix.F90" + END SELECT !! !! !! @@ -95,19 +95,19 @@ !! !! CASE (SCALAR) -#include "./ScalarOperatorReal.inc" +#include "./include/ScalarOperatorReal.F90" !! !! !! !! CASE (VECTOR) -#include "./VectorOperatorReal.inc" +#include "./include/VectorOperatorReal.F90" !! !! !! !! CASE (MATRIX) -#include "./MatrixOperatorReal.inc" +#include "./include/MatrixOperatorReal.F90" !! !! !! @@ -127,19 +127,19 @@ !! !! CASE (SCALAR) -#include "./RealOperatorScalar.inc" +#include "./include/RealOperatorScalar.F90" !! !! !! !! CASE (VECTOR) -#include "./RealOperatorVector.inc" +#include "./include/RealOperatorVector.F90" !! !! !! !! CASE (MATRIX) -#include "./RealOperatorMatrix.inc" +#include "./include/RealOperatorMatrix.F90" !! !! !! diff --git a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 index e8eff5ef2..1ae2c444a 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 @@ -28,13 +28,13 @@ SELECT CASE (obj%rank) !! CASE (SCALAR) -#include "./ScalarPower.inc" +#include "./include/ScalarPower.F90" !! CASE (VECTOR) -#include "./VectorPower.inc" +#include "./include/VectorPower.F90" !! CASE (MATRIX) -#include "./MatrixPower.inc" +#include "./include/MatrixPower.F90" !! END SELECT !! diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 index b0fac6f68..3c098b459 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 @@ -30,13 +30,13 @@ SELECT CASE (obj%rank) !! CASE (SCALAR) -#include "./ScalarElemMethod.inc" +#include "./include/ScalarElemMethod.F90" !! CASE (VECTOR) -#include "./VectorElemMethod.inc" +#include "./include/VectorElemMethod.F90" !! CASE (MATRIX) -#include "./MatrixElemMethod.inc" +#include "./include/MatrixElemMethod.F90" !! END SELECT !! diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 index 7ce5b3cef..ff3394e60 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 @@ -27,7 +27,7 @@ MODULE PROCEDURE fevar_Subtraction1 !! -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:) +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) INTEGER(I4B) :: jj, kk !! SELECT CASE (obj1%rank) @@ -37,45 +37,45 @@ !! CASE (SCALAR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! scalar, scalar - case( scalar ) -#include "./ScalarOperatorScalar.inc" + CASE (scalar) +#include "./include/ScalarOperatorScalar.F90" !! scalar, vector - case( vector ) -#include "./ScalarOperatorVector.inc" + CASE (vector) +#include "./include/ScalarOperatorVector.F90" !! scalar, matrix - case( matrix ) -#include "./ScalarOperatorMatrix.inc" - end select + CASE (matrix) +#include "./include/ScalarOperatorMatrix.F90" + END SELECT !! !! !! !! CASE (VECTOR) !! - select case( obj2%rank ) + SELECT CASE (obj2%rank) !! vector, scalar - case( scalar ) -#include "./VectorOperatorScalar.inc" + CASE (scalar) +#include "./include/VectorOperatorScalar.F90" !! vector, vector - case( vector ) -#include "./VectorOperatorVector.inc" - end select + CASE (vector) +#include "./include/VectorOperatorVector.F90" + END SELECT !! !! !! !! CASE (MATRIX) !! - select case( obj2%rank ) - case( scalar ) + SELECT CASE (obj2%rank) + CASE (scalar) !! matrix, scalar -#include "./MatrixOperatorScalar.inc" - case( matrix ) +#include "./include/MatrixOperatorScalar.F90" + CASE (matrix) !! matrix, matrix -#include "./MatrixOperatorMatrix.inc" - end select +#include "./include/MatrixOperatorMatrix.F90" + END SELECT !! !! !! @@ -95,19 +95,19 @@ !! !! CASE (SCALAR) -#include "./ScalarOperatorReal.inc" +#include "./include/ScalarOperatorReal.F90" !! !! !! !! CASE (VECTOR) -#include "./VectorOperatorReal.inc" +#include "./include/VectorOperatorReal.F90" !! !! !! !! CASE (MATRIX) -#include "./MatrixOperatorReal.inc" +#include "./include/MatrixOperatorReal.F90" !! !! !! @@ -127,19 +127,19 @@ !! !! CASE (SCALAR) -#include "./RealOperatorScalar.inc" +#include "./include/RealOperatorScalar.F90" !! !! !! !! CASE (VECTOR) -#include "./RealOperatorVector.inc" +#include "./include/RealOperatorVector.F90" !! !! !! !! CASE (MATRIX) -#include "./RealOperatorMatrix.inc" +#include "./include/RealOperatorMatrix.F90" !! !! !! diff --git a/src/submodules/FEVariable/src/MatrixElemMethod.inc b/src/submodules/FEVariable/src/MatrixElemMethod.inc deleted file mode 100644 index b308a1b36..000000000 --- a/src/submodules/FEVariable/src/MatrixElemMethod.inc +++ /dev/null @@ -1,92 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/MatrixOperatorMatrix.inc b/src/submodules/FEVariable/src/MatrixOperatorMatrix.inc deleted file mode 100644 index 5704e3445..000000000 --- a/src/submodules/FEVariable/src/MatrixOperatorMatrix.inc +++ /dev/null @@ -1,265 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! Internal variable -!! -! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) -! INTEGER(I4B) :: jj, kk -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - SELECT CASE (obj2%vartype) - !! - !! constant = constant + constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF - !! - !! space= constant _OP_ space - !! - CASE (space) - !! - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) - END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - !! time=constant _OP_ time - !! - CASE (time) - !! - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) - END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant _OP_ spacetime - !! - CASE (spacetime) - !! - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - r4 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r2(:, :) _OP_ r4(:, :, jj, kk) - END DO - END DO - !! - IF(obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (space) - !! - SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! - CASE (constant) - !! - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) - r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - !! space=space _OP_ space - !! - CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (time) - !! - SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! - CASE (constant) - !! - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) - r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - !! - !! time=time _OP_ time - !! - CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - END SELECT -!! -!! -!! -!! -CASE (spacetime) - !! - SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! - CASE (constant) - !! - r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(:, :) - END DO - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! - CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - END SELECT -!! -END SELECT diff --git a/src/submodules/FEVariable/src/MatrixOperatorReal.inc b/src/submodules/FEVariable/src/MatrixOperatorReal.inc deleted file mode 100644 index f90524bee..000000000 --- a/src/submodules/FEVariable/src/MatrixOperatorReal.inc +++ /dev/null @@ -1,92 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/MatrixOperatorScalar.inc b/src/submodules/FEVariable/src/MatrixOperatorScalar.inc deleted file mode 100644 index 0c4ac6645..000000000 --- a/src/submodules/FEVariable/src/MatrixOperatorScalar.inc +++ /dev/null @@ -1,271 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF - !! - !! space= constant _OP_ space - !! - CASE (space) - !! - r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1)) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2 _OP_ obj2%val(jj) - END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - !! time=constant _OP_ time - !! - CASE (time) - !! - r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1)) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2 _OP_ obj2%val(jj) - END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant _OP_ spacetime - !! - CASE (spacetime) - !! - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - m2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) ) - !! - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = m2 _OP_ r2(jj, kk) - END DO - END DO - !! - IF(obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - END SELECT -!! -!! -!! -!! -CASE (space) -!! - SELECT CASE (obj1%vartype) - !! - !! space=space _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - !! space=space _OP_ space - !! - CASE (space) - !! - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (time) -!! - SELECT CASE (obj1%vartype) - !! - !! time=time _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - !! - !! time=time _OP_ time - !! - CASE (time) - !! - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (spacetime) - !! - SELECT CASE (obj1%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! - CASE (spacetime) - !! - r4 = GET(obj1, typeFEVariableMatrix, typeFEVariableSpaceTime) - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - !! - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r4(:,:,jj,kk) _OP_ r2(jj, kk) - END DO - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/MatrixPower.inc b/src/submodules/FEVariable/src/MatrixPower.inc deleted file mode 100644 index 1d6c8f911..000000000 --- a/src/submodules/FEVariable/src/MatrixPower.inc +++ /dev/null @@ -1,92 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/RealOperatorMatrix.inc b/src/submodules/FEVariable/src/RealOperatorMatrix.inc deleted file mode 100644 index 4e5fd0910..000000000 --- a/src/submodules/FEVariable/src/RealOperatorMatrix.inc +++ /dev/null @@ -1,93 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/RealOperatorScalar.inc b/src/submodules/FEVariable/src/RealOperatorScalar.inc deleted file mode 100644 index 65efe4e82..000000000 --- a/src/submodules/FEVariable/src/RealOperatorScalar.inc +++ /dev/null @@ -1,97 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & val _OP_ obj1%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & val _OP_ obj1%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & val _OP_ obj1%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & val _OP_ obj1%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & val _OP_ obj1%val(:) , & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & val _OP_ obj1%val(:) , & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/RealOperatorVector.inc b/src/submodules/FEVariable/src/RealOperatorVector.inc deleted file mode 100644 index c3967937d..000000000 --- a/src/submodules/FEVariable/src/RealOperatorVector.inc +++ /dev/null @@ -1,93 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & val _OP_ obj1%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & val _OP_ obj1%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/ScalarElemMethod.inc b/src/submodules/FEVariable/src/ScalarElemMethod.inc deleted file mode 100644 index 3d6619764..000000000 --- a/src/submodules/FEVariable/src/ScalarElemMethod.inc +++ /dev/null @@ -1,94 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & _ELEM_METHOD_(obj%val(1)), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & _ELEM_METHOD_(obj%val(1)), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & _ELEM_METHOD_(obj%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & _ELEM_METHOD_(obj%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & _ELEM_METHOD_(obj%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & _ELEM_METHOD_(obj%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/ScalarOperatorMatrix.inc b/src/submodules/FEVariable/src/ScalarOperatorMatrix.inc deleted file mode 100644 index 94ae9d056..000000000 --- a/src/submodules/FEVariable/src/ScalarOperatorMatrix.inc +++ /dev/null @@ -1,270 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF - !! - !! space= constant _OP_ space - !! - CASE (space) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - !! time=constant _OP_ time - !! - CASE (time) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant _OP_ spacetime - !! - CASE (spacetime) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (space) - !! - SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! - CASE (constant) - !! - r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1)) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r2 - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - !! - !! space=space _OP_ space - !! - CASE (space) - !! - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF - END SELECT -!! -!! -!! -!! -CASE (time) -!! - SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! - CASE (constant) - !! - r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1)) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r2 - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - !! - !! time=time _OP_ time - !! - CASE (time) - !! - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) - !! - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF - END SELECT -!! -!! -!! -!! -CASE (spacetime) - !! - SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! - CASE (constant) - !! - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - m2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) ) - !! - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r2(jj, kk) _OP_ m2 - END DO - END DO - !! - IF(obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! - CASE (spacetime) - !! - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - r4 = GET(obj2, typeFEVariableMatrix, typeFEVariableSpaceTime) - !! - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:,:,jj,kk) - END DO - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/ScalarOperatorReal.inc b/src/submodules/FEVariable/src/ScalarOperatorReal.inc deleted file mode 100644 index d0052e005..000000000 --- a/src/submodules/FEVariable/src/ScalarOperatorReal.inc +++ /dev/null @@ -1,97 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(1) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(1) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/ScalarOperatorScalar.inc b/src/submodules/FEVariable/src/ScalarOperatorScalar.inc deleted file mode 100644 index 57cf08dd1..000000000 --- a/src/submodules/FEVariable/src/ScalarOperatorScalar.inc +++ /dev/null @@ -1,223 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) -!! - SELECT CASE (obj2%vartype) - !! - !! constant = constant + constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(1) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(1) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - END IF - !! - !! space= constant _OP_ space - !! - CASE (space) - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF - !! - !! time=constant _OP_ time - !! - CASE (time) - !! - IF( obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant _OP_ spacetime - !! - CASE (spacetime) - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (space) -!! - SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF - !! - !! space=space _OP_ space - !! - CASE (space) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF - END SELECT -!! -!! -!! -!! -CASE (time) -!! - SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF - !! - !! time=time _OP_ time - !! - CASE (time) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF - END SELECT -!! -!! -!! -!! -CASE (spacetime) - !! - SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! - CASE (constant) - !! - IF(obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! - CASE (spacetime) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/ScalarOperatorVector.inc b/src/submodules/FEVariable/src/ScalarOperatorVector.inc deleted file mode 100644 index 8721caf43..000000000 --- a/src/submodules/FEVariable/src/ScalarOperatorVector.inc +++ /dev/null @@ -1,265 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) -!! - SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) - END IF - !! - !! space= constant _OP_ space - !! - CASE (space) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - !! - !! time=constant _OP_ time - !! - CASE (time) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant _OP_ spacetime - !! - CASE (spacetime) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (space) -!! - SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! - CASE (constant) - !! - CALL Reallocate(r2, obj2%s(1), obj1%s(1) ) - !! - DO jj = 1, size(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - !! - !! space=space _OP_ space - !! - CASE (space) - !! - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) - !! - DO jj = 1, size(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - END SELECT -!! -!! -!! -!! -CASE (time) -!! - SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! - CASE (constant) - !! - CALL Reallocate(r2, obj2%s(1), obj1%s(1) ) - !! - DO jj = 1, size(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - !! - !! time=time _OP_ time - !! - CASE (time) - !! - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) - !! - DO jj = 1, size(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - END SELECT -!! -!! -!! -!! -CASE (spacetime) - !! - SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! - CASE (constant) - !! - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - CALL Reallocate( r3, obj2%s(1), size(r2,1), size(r2,2) ) - !! - DO kk = 1, size(r3, 3) - DO jj = 1, size(r3, 2) - r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(:) - END DO - END DO - !! - IF(obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! - CASE (spacetime) - !! - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - r3 = GET(obj2, typeFEVariableVector, typeFEVariableSpaceTime) - !! - DO kk = 1, size(r3, 3) - DO jj = 1, size(r3, 2) - r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:,jj,kk) - END DO - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/ScalarPower.inc b/src/submodules/FEVariable/src/ScalarPower.inc deleted file mode 100644 index 2d2f8c032..000000000 --- a/src/submodules/FEVariable/src/ScalarPower.inc +++ /dev/null @@ -1,94 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj%val(1) ** n, & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj%val(1) ** n, & - & typeFEVariableScalar, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/VectorElemMethod.inc b/src/submodules/FEVariable/src/VectorElemMethod.inc deleted file mode 100644 index c36a5c454..000000000 --- a/src/submodules/FEVariable/src/VectorElemMethod.inc +++ /dev/null @@ -1,93 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & _ELEM_METHOD_(obj%val(:)), & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & _ELEM_METHOD_(obj%val(:)), & - & typeFEVariableVector, & - & typeFEVariableConstant) - ENDIF -!! -!! -!! -!! -CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ENDIF -!! -!! -!! -!! -CASE (time) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ENDIF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ENDIF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/VectorOperatorReal.inc b/src/submodules/FEVariable/src/VectorOperatorReal.inc deleted file mode 100644 index 439c71976..000000000 --- a/src/submodules/FEVariable/src/VectorOperatorReal.inc +++ /dev/null @@ -1,97 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableVector, & - & typeFEVariableConstant) - ENDIF -!! -!! -!! -!! -CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ENDIF -!! -!! -!! -!! -CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ENDIF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ENDIF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/VectorOperatorScalar.inc b/src/submodules/FEVariable/src/VectorOperatorScalar.inc deleted file mode 100644 index 1f44747c1..000000000 --- a/src/submodules/FEVariable/src/VectorOperatorScalar.inc +++ /dev/null @@ -1,265 +0,0 @@ -! This PROGRAM is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This PROGRAM is free software: you can REDISTRIBUTE it and/or modify -! it under the terms of the GNU General PUBLIC License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This PROGRAM is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General PUBLIC License for more details. -! -! You should have received a copy of the GNU General PUBLIC License -! along WITH this PROGRAM. IF not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) - !! - SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableVector, & - & typeFEVariableConstant) - END IF - !! - !! space= constant _OP_ space - !! - CASE (space) - !! - CALL Reallocate(r2, obj1%s(1), obj2%s(1)) - !! - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj) - END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - !! - !! time=constant _OP_ time - !! - CASE (time) - !! - CALL Reallocate(r2, obj1%s(1), obj2%s(1)) - !! - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj) - END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant _OP_ spacetime - !! - CASE (spacetime) - !! - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - CALL Reallocate( r3, obj1%s(1), SIZE(r2,1), SIZE(r2,2) ) - !! - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = obj1%val(:) _OP_ r2(jj, kk) - END DO - END DO - !! - IF(obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (space) -!! - SELECT CASE (obj1%vartype) - !! - !! space=space _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - !! - !! space=space _OP_ space - !! - CASE (space) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - !! - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - END SELECT -!! -!! -!! -!! -CASE (time) -!! - SELECT CASE (obj1%vartype) - !! - !! time=time _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - !! - !! time=time _OP_ time - !! - CASE (time) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - !! - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - END SELECT -!! -!! -!! -!! -CASE (spacetime) - !! - SELECT CASE (obj1%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! - CASE (spacetime) - !! - r3 = GET(obj1, typeFEVariableVector, typeFEVariableSpaceTime) - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - !! - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r3(:,jj,kk) _OP_ r2(jj, kk) - END DO - END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/VectorOperatorVector.inc b/src/submodules/FEVariable/src/VectorOperatorVector.inc deleted file mode 100644 index a8a1d632f..000000000 --- a/src/submodules/FEVariable/src/VectorOperatorVector.inc +++ /dev/null @@ -1,258 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- - -!! Internal variable -! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) -! INTEGER(I4B) :: jj, kk -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) -!! - SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) - END IF - !! - !! space= constant _OP_ space - !! - CASE (space) - !! - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ r2(:, jj) - END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - !! - !! time=constant _OP_ time - !! - CASE (time) - !! - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ r2(:, jj) - END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant _OP_ spacetime - !! - CASE (spacetime) - !! - r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = obj1%val(:) _OP_ r3(:, jj, kk) - END DO - END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (space) -!! - SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! - CASE (constant) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - !! - DO jj = 1, SIZE(r2,2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(:) - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - !! - !! space=space _OP_ space - !! - CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (time) -!! - SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! - CASE (constant) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - DO jj = 1, SIZE(r2,2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(:) - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - !! - !! time=time _OP_ time - !! - CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF - !! - END SELECT -!! -CASE (spacetime) - !! - SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! - CASE (constant) - !! - r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(:) - END DO - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! - CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT - !! -END SELECT diff --git a/src/submodules/FEVariable/src/VectorPower.inc b/src/submodules/FEVariable/src/VectorPower.inc deleted file mode 100644 index b87932282..000000000 --- a/src/submodules/FEVariable/src/VectorPower.inc +++ /dev/null @@ -1,93 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj%val(:) ** n, & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj%val(:) ** n, & - & typeFEVariableVector, & - & typeFEVariableConstant) - ENDIF -!! -!! -!! -!! -CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ENDIF -!! -!! -!! -!! -CASE (time) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ENDIF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ENDIF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 new file mode 100644 index 000000000..e85818d99 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 @@ -0,0 +1,12 @@ +INTEGER(I4B) :: ii + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/scalar_time.F90 b/src/submodules/FEVariable/src/include/scalar_time.F90 new file mode 100644 index 000000000..1a7b0d3e3 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_time.F90 @@ -0,0 +1,8 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) +obj%val(1:obj%len) = val +obj%s(1) = SIZE(val) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = Time diff --git a/src/submodules/FEVariable/src/include/vector_constant.F90 b/src/submodules/FEVariable/src/include/vector_constant.F90 new file mode 100644 index 000000000..42125ac15 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_constant.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len + +ALLOCATE (obj%val(obj%capacity)) +obj%val(1:obj%len) = val + +obj%s(1:1) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/vector_space.F90 b/src/submodules/FEVariable/src/include/vector_space.F90 new file mode 100644 index 000000000..2d6a663ef --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space.F90 @@ -0,0 +1,18 @@ +INTEGER(I4B) :: ii, jj, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/vector_space2.F90 b/src/submodules/FEVariable/src/include/vector_space2.F90 new file mode 100644 index 000000000..a2e7c5cbf --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/vector_space_time.F90 b/src/submodules/FEVariable/src/include/vector_space_time.F90 new file mode 100644 index 000000000..e8ee7a797 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space_time.F90 @@ -0,0 +1,21 @@ +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO + +obj%s(1:3) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/vector_space_time2.F90 b/src/submodules/FEVariable/src/include/vector_space_time2.F90 new file mode 100644 index 000000000..a671d1408 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:3) = s(1:3) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/vector_time.F90 b/src/submodules/FEVariable/src/include/vector_time.F90 new file mode 100644 index 000000000..7cc4a4a7f --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_time.F90 @@ -0,0 +1,18 @@ +INTEGER(I4B) :: ii, jj, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = TIME diff --git a/src/submodules/FEVariable/src/include/vector_time2.F90 b/src/submodules/FEVariable/src/include/vector_time2.F90 new file mode 100644 index 000000000..b3e52b512 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = TIME From 6d6d8c20320b6684912c2fa338eb37fc3efff847 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:27:31 +0900 Subject: [PATCH 038/359] minor changes in fevariable method --- src/modules/FEVariable/src/FEVariable_Method.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 27d9cff7d..965542d7e 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -23,9 +23,11 @@ MODULE FEVariable_Method FEVariableSpace_, & FEVariableTime_, & FEVariableSpaceTime_ + USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE + PRIVATE PUBLIC :: Display From 11a1522603f10aa1b522e8e2f6b83b041f7002d5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:27:41 +0900 Subject: [PATCH 039/359] minor update in reference element method --- src/modules/Geometry/src/ReferenceElement_Method.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index 8c459eff5..58a0500c0 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -272,8 +272,8 @@ END SUBROUTINE GetFaceConnectivity1 ! summary: Returns the element type of each face INTERFACE GetFaceElemType - MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, & - & tFaceNodes) + MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, & + tFaceNodes) INTEGER(I4B), INTENT(IN) :: elemType !! name of element INTEGER(I4B), INTENT(INOUT) :: faceElemType(:) From b0f58c7d7d15ca5513d0740a8209ded913221fda Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:28:07 +0900 Subject: [PATCH 040/359] adding get1dindex in integer utility --- src/modules/Utility/src/IntegerUtility.F90 | 64 ++++++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/src/modules/Utility/src/IntegerUtility.F90 b/src/modules/Utility/src/IntegerUtility.F90 index b785680f0..b52c57a50 100644 --- a/src/modules/Utility/src/IntegerUtility.F90 +++ b/src/modules/Utility/src/IntegerUtility.F90 @@ -31,6 +31,7 @@ MODULE IntegerUtility PUBLIC :: GetIndex PUBLIC :: Get PUBLIC :: GetIntersection +PUBLIC :: Get1DIndexFortran !---------------------------------------------------------------------------- ! Size@Methods @@ -466,6 +467,69 @@ MODULE PURE SUBROUTINE GetIntersection4(a, b, c, tsize) END SUBROUTINE GetIntersection4 END INTERFACE GetIntersection +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j) to ans from Fortran2D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom2DFortranIndex(i, j, dim1, dim2) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom2DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j,k) to ans from Fortran3D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom3DFortranIndex(i, j, k, dim1, dim2, & + dim3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: k + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom3DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Get1DIndexFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j,k,l) to ans from Fortran4D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom4DFortranIndex(i, j, k, l, dim1, dim2, & + dim3, dim4) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: k + INTEGER(I4B), INTENT(IN) :: l + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom4DFortranIndex +END INTERFACE Get1DIndexFortran + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From b7408bc0b20a7c11e6dd858ca47a13e591570b23 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:28:17 +0900 Subject: [PATCH 041/359] minor updates in mapping utility --- src/modules/Utility/src/MappingUtility.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 7b5f52e97..9ad5c7125 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -17,7 +17,7 @@ !> author: Vikas Sharma, Ph. D. ! date: 19 Oct 2022 -! summary: Some methods related to standard mapping are defined +! summary: Some methods related to standard mapping are defined ! !{!pages/MappingUtility_.md!} From a413a546b4f9d508722108ccf35fba430f735edf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:28:31 +0900 Subject: [PATCH 042/359] minor updates in string utility --- src/modules/Utility/src/StringUtility.F90 | 168 +++++++++++++++++----- 1 file changed, 132 insertions(+), 36 deletions(-) diff --git a/src/modules/Utility/src/StringUtility.F90 b/src/modules/Utility/src/StringUtility.F90 index d71a0bb0c..b4ad84c41 100644 --- a/src/modules/Utility/src/StringUtility.F90 +++ b/src/modules/Utility/src/StringUtility.F90 @@ -16,8 +16,11 @@ ! MODULE StringUtility -USE GlobalData +USE GlobalData, ONLY: I4B, LGT +USE String_Class, ONLY: String + IMPLICIT NONE + PRIVATE PUBLIC :: FindReplace @@ -39,6 +42,110 @@ MODULE StringUtility PUBLIC :: ToUpperCase PUBLIC :: UpperCase +PUBLIC :: PathJoin +PUBLIC :: PathBase +PUBLIC :: PathDir + +!---------------------------------------------------------------------------- +! PathBase +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Returns the base of the path +! +!# Introduction +! +! Base returns the last element of path. +! Trailing slashes are removed before extracting the +! last element. +! If the path is empty, Base returns ".". +! If the path consists entirely of slashes, Base returns "/". +! +! func main() { +! fmt.Println(path.Base("/a/b")) +! fmt.Println(path.Base("/")) +! fmt.Println(path.Base("")) +! } +! b +! / +! . + +INTERFACE + MODULE PURE FUNCTION PathBase(path) RESULT(ans) + CHARACTER(*), INTENT(in) :: path + CHARACTER(LEN=:), ALLOCATABLE :: ans + END FUNCTION PathBase +END INTERFACE + +!---------------------------------------------------------------------------- +! PathJoin +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Join two paths + +INTERFACE PathJoin + MODULE PURE FUNCTION PathJoin1(path1, path2) RESULT(ans) + CHARACTER(*), INTENT(in) :: path1 + CHARACTER(*), INTENT(in) :: path2 + CHARACTER(LEN=:), ALLOCATABLE :: ans + END FUNCTION PathJoin1 +END INTERFACE PathJoin + +!---------------------------------------------------------------------------- +! PathJoin +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Join two paths + +INTERFACE PathJoin + MODULE PURE FUNCTION PathJoin2(paths) RESULT(ans) + TYPE(String), INTENT(IN) :: paths(:) + CHARACTER(LEN=:), ALLOCATABLE :: ans + END FUNCTION PathJoin2 +END INTERFACE PathJoin + +!---------------------------------------------------------------------------- +! GetPath@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Returns the parent directory +! +!# Introduction +! +! Dir returns all but the last element of path, +! typically the path's directory. +! After dropping the final element using Split, +! the path is Cleaned and trailing slashes are removed. +! If the path is empty, Dir returns ".". +! If the path consists entirely of slashes followed by non-slash bytes, +! Dir returns a single slash. +! In any other case, the returned path does not end in a slash. + +INTERFACE + MODULE PURE FUNCTION PathDir(path) RESULT(ans) + CHARACTER(*), INTENT(IN) :: path + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION PathDir +END INTERFACE + +!---------------------------------------------------------------------------- +! GetPath@StringMethods +!---------------------------------------------------------------------------- + +INTERFACE GetPath + MODULE PURE SUBROUTINE GetPath_chars(chars, path) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(OUT) :: path + END SUBROUTINE GetPath_chars +END INTERFACE GetPath + !---------------------------------------------------------------------------- ! UpperCase@StringMethods !---------------------------------------------------------------------------- @@ -50,23 +157,23 @@ MODULE StringUtility INTERFACE UpperCase MODULE PURE FUNCTION UpperCase_char(chars) RESULT(Ans) CHARACTER(*), INTENT(IN) :: chars - CHARACTER(LEN(chars)) :: ans + CHARACTER(len=:), ALLOCATABLE :: ans END FUNCTION UpperCase_char END INTERFACE UpperCase !---------------------------------------------------------------------------- -! toUpperCase@StringMethods +! ToUpperCase@StringMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 5 Sept 2021 ! summary: Returns the upperCase version of chars -INTERFACE toUpperCase +INTERFACE ToUpperCase MODULE PURE SUBROUTINE ToUpperCase_Char(chars) CHARACTER(*), INTENT(INOUT) :: chars END SUBROUTINE ToUpperCase_Char -END INTERFACE toUpperCase +END INTERFACE ToUpperCase !---------------------------------------------------------------------------- ! LowerCase@StringMethods @@ -79,53 +186,53 @@ END SUBROUTINE ToUpperCase_Char INTERFACE LowerCase MODULE PURE FUNCTION LowerCase_char(chars) RESULT(Ans) CHARACTER(*), INTENT(IN) :: chars - CHARACTER(LEN(chars)) :: ans + CHARACTER(:), ALLOCATABLE :: ans END FUNCTION LowerCase_char END INTERFACE LowerCase !---------------------------------------------------------------------------- -! toLowerCase@StringMethods +! ToLowerCase@StringMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 5 Sept 2021 ! summary: Returns the LowerCase version of chars -INTERFACE toLowerCase +INTERFACE ToLowerCase MODULE PURE SUBROUTINE ToLowerCase_Char(chars) CHARACTER(*), INTENT(INOUT) :: chars END SUBROUTINE ToLowerCase_Char -END INTERFACE toLowerCase +END INTERFACE ToLowerCase !---------------------------------------------------------------------------- -! isWhiteChar@StringMethods +! IsWhiteChar@StringMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 5 Sept 2021 ! summary: Returns true if the char is a space(32) or a tab(9). -INTERFACE isWhiteChar - MODULE PURE FUNCTION isWhiteChar_char(char) RESULT(Ans) +INTERFACE IsWhiteChar + MODULE PURE FUNCTION IsWhiteChar_char(char) RESULT(Ans) CHARACTER(1), INTENT(IN) :: char LOGICAL(LGT) :: ans - END FUNCTION isWhiteChar_char -END INTERFACE isWhiteChar + END FUNCTION IsWhiteChar_char +END INTERFACE IsWhiteChar !---------------------------------------------------------------------------- -! isBlank@StringMethods +! IsBlank@StringMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 5 Sept 2021 ! summary: Returns true of the entire string is blank -INTERFACE isBlank - MODULE PURE FUNCTION isBlank_chars(chars) RESULT(Ans) +INTERFACE IsBlank + MODULE PURE FUNCTION IsBlank_chars(chars) RESULT(Ans) CHARACTER(*), INTENT(IN) :: chars LOGICAL(LGT) :: ans - END FUNCTION isBlank_chars -END INTERFACE isBlank + END FUNCTION IsBlank_chars +END INTERFACE IsBlank !---------------------------------------------------------------------------- ! numString@StringMethods @@ -144,12 +251,12 @@ END FUNCTION isBlank_chars ! (https://github.com/CASL/Futility/blob/master/src/IO_Strings.F90) ! -INTERFACE numStrings - MODULE PURE FUNCTION numStrings_chars(chars) RESULT(Ans) +INTERFACE NumStrings + MODULE PURE FUNCTION NumStrings_chars(chars) RESULT(Ans) CHARACTER(*), INTENT(IN) :: chars INTEGER(I4B) :: ans - END FUNCTION numStrings_chars -END INTERFACE numStrings + END FUNCTION NumStrings_chars +END INTERFACE NumStrings !---------------------------------------------------------------------------- ! nmatchstr@StringMethods @@ -193,14 +300,14 @@ END FUNCTION isPresent_chars END INTERFACE isPresent !---------------------------------------------------------------------------- -! strFind@StringMethods +! StrFind@StringMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 5 sept 2021 ! summary: Function returns the indices in a string where substring pattern -INTERFACE strFind +INTERFACE StrFind MODULE PURE SUBROUTINE strFind_chars(chars, pattern, indices) CHARACTER(*), INTENT(IN) :: chars CHARACTER(*), INTENT(IN) :: pattern @@ -291,17 +398,6 @@ MODULE PURE SUBROUTINE GetFileParts_chars(chars, path, fname, ext) END SUBROUTINE GetFileParts_chars END INTERFACE GetFileParts -!---------------------------------------------------------------------------- -! GetPath@StringMethods -!---------------------------------------------------------------------------- - -INTERFACE GetPath - MODULE PURE SUBROUTINE GetPath_chars(chars, path) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(OUT) :: path - END SUBROUTINE GetPath_chars -END INTERFACE GetPath - !---------------------------------------------------------------------------- ! GetFileName@StringMethods !---------------------------------------------------------------------------- From 936e9fb11fa71858bc1c89f3ac349517c2c8ab17 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:28:49 +0900 Subject: [PATCH 043/359] updates in fevariable --- .../src/include/MatrixOperatorMatrix.F90 | 238 +++--------- .../src/include/MatrixOperatorReal.F90 | 98 +---- .../src/include/MatrixOperatorScalar.F90 | 311 +++++----------- .../src/include/RealOperatorMatrix.F90 | 99 +---- .../src/include/RealOperatorScalar.F90 | 103 +----- .../src/include/RealOperatorVector.F90 | 108 ++---- .../src/include/ScalarOperatorMatrix.F90 | 330 +++++++---------- .../src/include/ScalarOperatorReal.F90 | 103 +----- .../src/include/ScalarOperatorScalar.F90 | 303 ++++++--------- .../src/include/ScalarOperatorVector.F90 | 347 +++++++----------- .../FEVariable/src/include/ScalarPower.F90 | 108 ++---- .../src/include/VectorOperatorReal.F90 | 111 ++---- .../src/include/VectorOperatorScalar.F90 | 247 +++---------- .../src/include/VectorOperatorVector.F90 | 262 ++++--------- 14 files changed, 800 insertions(+), 1968 deletions(-) diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 index 5704e3445..49ec28c4d 100644 --- a/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 +++ b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 @@ -1,104 +1,39 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! Internal variable -!! -! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) -! INTEGER(I4B) :: jj, kk -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) - !! SELECT CASE (obj2%vartype) - !! - !! constant = constant + constant - !! CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) END IF - !! - !! space= constant _OP_ space - !! CASE (space) - !! r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) END IF - !! - !! time=constant _OP_ time - !! + DEALLOCATE (r2, r3) CASE (time) - !! r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) END IF - !! - !! spacetime=constant _OP_ spacetime - !! + DEALLOCATE (r2, r3) CASE (spacetime) - !! r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) r4 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpaceTime) DO kk = 1, SIZE(r4, 4) @@ -106,125 +41,67 @@ r4(:, :, jj, kk) = r2(:, :) _OP_ r4(:, :, jj, kk) END DO END DO - !! - IF(obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(r4, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime) END IF - !! + DEALLOCATE (r2, r4) END SELECT -!! -!! -!! -!! CASE (space) - !! SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! CASE (constant) - !! r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableSpace) END IF - !! - !! space=space _OP_ space - !! + DEALLOCATE (r2, r3) CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) END IF - !! END SELECT -!! -!! -!! -!! CASE (time) - !! SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! CASE (constant) - !! r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableTime) ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableTime) END IF - !! - !! time=time _OP_ time - !! + DEALLOCATE (r2, r3) CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) END IF END SELECT -!! -!! -!! -!! CASE (spacetime) - !! SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! CASE (constant) - !! r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) DO kk = 1, SIZE(r4, 4) @@ -232,34 +109,21 @@ r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(:, :) END DO END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r4, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(r4, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime) END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! + DEALLOCATE (r2, r4) CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) END IF END SELECT -!! END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 index f90524bee..74cb5c110 100644 --- a/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 +++ b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 @@ -1,92 +1,34 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) END IF -!! -!! -!! -!! CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) END IF -!! -!! -!! -!! CASE (time) - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) END IF -!! -!! -!! -!! CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) END IF -!! -!! -!! -!! END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 index 0c4ac6645..3b66f3643 100644 --- a/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 +++ b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 @@ -1,271 +1,164 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! +SELECT CASE (obj1%varType) + CASE (constant) - !! - SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! + + SELECT CASE (obj2%varType) + CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) END IF - !! - !! space= constant _OP_ space - !! + CASE (space) - !! - r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1)) - !! + + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1)) DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r2 _OP_ obj2%val(jj) END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) END IF - !! - !! time=constant _OP_ time - !! + + DEALLOCATE (r2, r3) CASE (time) - !! - r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1)) - !! + + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1)) DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r2 _OP_ obj2%val(jj) END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) END IF - !! - !! spacetime=constant _OP_ spacetime - !! + + DEALLOCATE (r2, r3) CASE (spacetime) - !! - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - m2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) ) - !! + + r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime) + m2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2)) DO kk = 1, SIZE(r4, 4) DO jj = 1, SIZE(r4, 3) r4(:, :, jj, kk) = m2 _OP_ r2(jj, kk) END DO + END DO - !! - IF(obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(r4, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime) END IF + + DEALLOCATE (r2, r4, m2) END SELECT -!! -!! -!! -!! + CASE (space) -!! - SELECT CASE (obj1%vartype) - !! - !! space=space _OP_ constant - !! + + SELECT CASE (obj1%varType) + CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) END IF - !! - !! space=space _OP_ space - !! + CASE (space) - !! + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) - !! DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) END IF - !! + + DEALLOCATE (r3) END SELECT -!! -!! -!! -!! + CASE (time) -!! - SELECT CASE (obj1%vartype) - !! - !! time=time _OP_ constant - !! + + SELECT CASE (obj1%varType) + CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) END IF - !! - !! time=time _OP_ time - !! + CASE (time) - !! + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) - !! DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) END IF - !! + + DEALLOCATE (r3) END SELECT -!! -!! -!! -!! + CASE (spacetime) - !! - SELECT CASE (obj1%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! + + SELECT CASE (obj1%varType) + CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! + CASE (spacetime) - !! - r4 = GET(obj1, typeFEVariableMatrix, typeFEVariableSpaceTime) - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - !! + + r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime) DO kk = 1, SIZE(r4, 4) DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r4(:,:,jj,kk) _OP_ r2(jj, kk) + r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(jj, kk) END DO + END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(r4, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime) END IF - !! + + DEALLOCATE (r2, r4) END SELECT -!! -!! -!! -!! + END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 index 4e5fd0910..9295afd5d 100644 --- a/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 +++ b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 @@ -1,93 +1,34 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2)) ELSE - ans = QuadratureVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2)) END IF -!! -!! -!! -!! CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3)) END IF -!! -!! -!! -!! CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3)) ELSE - ans = QuadratureVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3)) END IF -!! -!! -!! -!! CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4)) ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4)) END IF -!! -!! -!! -!! END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 index 65efe4e82..6e0fbc67c 100644 --- a/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 +++ b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 @@ -1,97 +1,34 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & val _OP_ obj1%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) ELSE - ans = QuadratureVariable( & - & val _OP_ obj1%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) + ans = QuadratureVariable(val _OP_ obj1%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) END IF -!! -!! -!! -!! CASE (space) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & val _OP_ obj1%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & val _OP_ obj1%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpace) END IF -!! -!! -!! -!! CASE (time) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & val _OP_ obj1%val(:) , & - & typeFEVariableScalar, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableTime) ELSE - ans = QuadratureVariable( & - & val _OP_ obj1%val(:) , & - & typeFEVariableScalar, & - & typeFEVariableTime) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableTime) END IF -!! -!! -!! -!! CASE (spacetime) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) END IF -!! -!! -!! -!! END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorVector.F90 b/src/submodules/FEVariable/src/include/RealOperatorVector.F90 index c3967937d..69afa2912 100644 --- a/src/submodules/FEVariable/src/include/RealOperatorVector.F90 +++ b/src/submodules/FEVariable/src/include/RealOperatorVector.F90 @@ -1,93 +1,43 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! + CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & val _OP_ obj1%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableVector, TypeFEVariableConstant) ELSE - ans = QuadratureVariable( & - & val _OP_ obj1%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableVector, TypeFEVariableConstant) END IF -!! -!! -!! -!! + CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & + TypeFEVariableVector, TypeFEVariableSpace) END IF -!! -!! -!! -!! + CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & + TypeFEVariableVector, TypeFEVariableTime) ELSE - ans = QuadratureVariable( & - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & + TypeFEVariableVector, TypeFEVariableTime) END IF -!! -!! -!! -!! + CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), & + TypeFEVariableVector, TypeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), & + TypeFEVariableVector, TypeFEVariableSpaceTime) END IF -!! -!! -!! -!! + END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 index 94ae9d056..3692e97ec 100644 --- a/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 +++ b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 @@ -1,270 +1,186 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! + CASE (constant) - !! + SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! + CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2)) + + RETURN END IF - !! - !! space= constant _OP_ space - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2)) + CASE (space) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3)) + RETURN END IF - !! - !! time=constant _OP_ time - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3)) + CASE (time) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3)) + RETURN END IF - !! - !! spacetime=constant _OP_ spacetime - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3)) + CASE (spacetime) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4)) + RETURN END IF - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4)) + END SELECT -!! -!! -!! -!! + CASE (space) - !! + SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! + CASE (constant) - !! + r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1)) - !! + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1)) + DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = obj1%val(jj) _OP_ r2 END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r2, r3) + RETURN END IF - !! - !! space=space _OP_ space - !! + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r2, r3) + CASE (space) - !! + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) - !! + DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r3) + RETURN END IF + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r3) + END SELECT -!! -!! -!! -!! + CASE (time) -!! + SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! + CASE (constant) - !! + r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1)) - !! + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1)) + DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = obj1%val(jj) _OP_ r2 END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r2, r3) + RETURN END IF - !! - !! time=time _OP_ time - !! + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r2, r3) + CASE (time) - !! + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) - !! DO jj = 1, SIZE(r3, 3) r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableMatrix, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r3) + RETURN END IF + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r3) + END SELECT -!! -!! -!! -!! + CASE (spacetime) - !! + SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! + CASE (constant) - !! + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) m2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - !! - CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) ) - !! + CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2)) + DO kk = 1, SIZE(r4, 4) DO jj = 1, SIZE(r4, 3) r4(:, :, jj, kk) = r2(jj, kk) _OP_ m2 END DO END DO - !! - IF(obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, typeFEVariableMatrix, typeFEVariableSpaceTime) + DEALLOCATE (r2, m2, r4) + RETURN END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! + + ans = QuadratureVariable(r4, typeFEVariableMatrix, & + typeFEVariableSpaceTime) + + DEALLOCATE (r2, m2, r4) + CASE (spacetime) - !! + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) r4 = GET(obj2, typeFEVariableMatrix, typeFEVariableSpaceTime) - !! + DO kk = 1, SIZE(r4, 4) DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:,:,jj,kk) + r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:, :, jj, kk) END DO END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r4, & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, typeFEVariableMatrix, & + typeFEVariableSpaceTime) + DEALLOCATE (r2, r4) + RETURN END IF - !! + + ans = QuadratureVariable(r4, typeFEVariableMatrix, & + typeFEVariableSpaceTime) + DEALLOCATE (r2, r4) + END SELECT -!! -!! -!! -!! + END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 index d0052e005..fa3e91c56 100644 --- a/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 +++ b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 @@ -1,97 +1,34 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(1) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableConstant) ELSE - ans = QuadratureVariable( & - & obj1%val(1) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableConstant) + ans = QuadratureVariable(obj1%val(1) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableConstant) END IF -!! -!! -!! -!! CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableSpace) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpace) END IF -!! -!! -!! -!! CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableTime) ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableScalar, & - & typeFEVariableTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableTime) END IF -!! -!! -!! -!! CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) END IF -!! -!! -!! -!! END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 index 57cf08dd1..8e121f01d 100644 --- a/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 +++ b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 @@ -1,223 +1,148 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! + CASE (constant) -!! + SELECT CASE (obj2%vartype) - !! - !! constant = constant + constant - !! + CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(1) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(1) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableConstant) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) + + RETURN + END IF - !! - !! space= constant _OP_ space - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) + CASE (space) - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) + + IF (obj2%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + + RETURN END IF - !! - !! time=constant _OP_ time - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + CASE (time) - !! - IF( obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + + RETURN END IF - !! - !! spacetime=constant _OP_ spacetime - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + CASE (spacetime) - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + + IF (obj2%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2)) + + RETURN END IF - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2)) + END SELECT -!! -!! -!! -!! + CASE (space) -!! + SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! + CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpace) + + RETURN END IF - !! - !! space=space _OP_ space - !! + + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpace) + CASE (space) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + + RETURN END IF + + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + END SELECT -!! -!! -!! -!! + CASE (time) -!! + SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! + CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableScalar, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableTime) + + RETURN END IF - !! - !! time=time _OP_ time - !! + + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableTime) + CASE (time) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableScalar, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + RETURN END IF + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + END SELECT -!! -!! -!! -!! + CASE (spacetime) - !! + SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! + CASE (constant) - !! - IF(obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + RETURN END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + CASE (spacetime) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + RETURN END IF - !! + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + END SELECT -!! -!! -!! -!! + END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 index 8721caf43..594629b64 100644 --- a/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 +++ b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 @@ -1,265 +1,180 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! + CASE (constant) -!! + SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! + CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj1%val(1) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) + RETURN END IF - !! - !! space= constant _OP_ space - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) CASE (space) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2)) + + RETURN END IF - !! - !! time=constant _OP_ time - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2)) CASE (time) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj2%s(1:2)) + RETURN END IF - !! - !! spacetime=constant _OP_ spacetime - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj2%s(1:2)) + CASE (spacetime) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3)) + RETURN END IF - !! + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3)) + END SELECT -!! -!! -!! -!! + CASE (space) -!! + SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! + CASE (constant) - !! - CALL Reallocate(r2, obj2%s(1), obj1%s(1) ) - !! - DO jj = 1, size(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:) + + CALL Reallocate(r2, obj2%s(1), obj1%s(1)) + + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) + RETURN END IF - !! - !! space=space _OP_ space - !! + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + CASE (space) - !! + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) - !! - DO jj = 1, size(r2, 2) + + DO jj = 1, SIZE(r2, 2) r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) + RETURN END IF + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) + END SELECT -!! -!! -!! -!! + CASE (time) -!! + SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! + CASE (constant) - !! - CALL Reallocate(r2, obj2%s(1), obj1%s(1) ) - !! - DO jj = 1, size(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:) + + CALL Reallocate(r2, obj2%s(1), obj1%s(1)) + + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + RETURN END IF - !! - !! time=time _OP_ time - !! + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + CASE (time) - !! + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) - !! - DO jj = 1, size(r2, 2) + + DO jj = 1, SIZE(r2, 2) r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + RETURN END IF + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + END SELECT -!! -!! -!! -!! + CASE (spacetime) - !! + SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! + CASE (constant) - !! + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - CALL Reallocate( r3, obj2%s(1), size(r2,1), size(r2,2) ) - !! - DO kk = 1, size(r3, 3) - DO jj = 1, size(r3, 2) - r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(:) + CALL Reallocate(r3, obj2%s(1), SIZE(r2, 1), SIZE(r2, 2)) + + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(1:obj2%len) END DO END DO - !! - IF(obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) + + RETURN END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! + + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) + + DEALLOCATE (r2, r3) + CASE (spacetime) - !! r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) r3 = GET(obj2, typeFEVariableVector, typeFEVariableSpaceTime) - !! - DO kk = 1, size(r3, 3) - DO jj = 1, size(r3, 2) - r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:,jj,kk) + + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:, jj, kk) END DO END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) + RETURN END IF - !! + + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) + + DEALLOCATE (r2, r3) + END SELECT -!! -!! -!! -!! + END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarPower.F90 b/src/submodules/FEVariable/src/include/ScalarPower.F90 index 2d2f8c032..48f45c3dc 100644 --- a/src/submodules/FEVariable/src/include/ScalarPower.F90 +++ b/src/submodules/FEVariable/src/include/ScalarPower.F90 @@ -1,94 +1,42 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -!! -!! main -!! SELECT CASE (obj%vartype) -!! -!! -!! -!! + CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj%val(1) ** n, & - & typeFEVariableScalar, & - & typeFEVariableConstant) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1)**n, & + TypeFEVariableScalar, TypeFEVariableConstant) ELSE - ans = QuadratureVariable( & - & obj%val(1) ** n, & - & typeFEVariableScalar, & - & typeFEVariableConstant) + ans = QuadratureVariable(obj%val(1)**n, & + TypeFEVariableScalar, TypeFEVariableConstant) END IF -!! -!! -!! -!! + CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableSpace) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableSpace) + ans = QuadratureVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpace) END IF -!! -!! -!! -!! + CASE (time) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableTime) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableTime) ELSE - ans = QuadratureVariable( & - & obj%val(:) ** n, & - & typeFEVariableScalar, & - & typeFEVariableTime) + ans = QuadratureVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableTime) END IF -!! -!! -!! -!! + CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2)) END IF -!! -!! -!! -!! END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 index 439c71976..0aa58c55c 100644 --- a/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 +++ b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 @@ -1,97 +1,34 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableVector, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableConstant) ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ val, & - & typeFEVariableVector, & - & typeFEVariableConstant) - ENDIF -!! -!! -!! -!! + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableConstant) + END IF CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ENDIF -!! -!! -!! -!! + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) + END IF CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2)) ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ENDIF -!! -!! -!! -!! + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2)) + END IF CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ENDIF -!! -!! -!! -!! + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3)) + END IF END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 index 1f44747c1..74b2a8ad8 100644 --- a/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 +++ b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 @@ -1,265 +1,120 @@ -! This PROGRAM is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This PROGRAM is free software: you can REDISTRIBUTE it and/or modify -! it under the terms of the GNU General PUBLIC License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This PROGRAM is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General PUBLIC License for more details. -! -! You should have received a copy of the GNU General PUBLIC License -! along WITH this PROGRAM. IF not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) - !! SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! CASE (constant) - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableVector, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableConstant) ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(1), & - & typeFEVariableVector, & - & typeFEVariableConstant) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableConstant) END IF - !! - !! space= constant _OP_ space - !! CASE (space) - !! CALL Reallocate(r2, obj1%s(1), obj2%s(1)) - !! DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj) END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) END IF - !! - !! time=constant _OP_ time - !! + DEALLOCATE (r2) CASE (time) - !! CALL Reallocate(r2, obj1%s(1), obj2%s(1)) - !! DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj) END DO - !! - IF( obj2%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) END IF - !! - !! spacetime=constant _OP_ spacetime - !! + DEALLOCATE (r2) CASE (spacetime) - !! r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - CALL Reallocate( r3, obj1%s(1), SIZE(r2,1), SIZE(r2,2) ) - !! + CALL Reallocate(r3, obj1%s(1), SIZE(r2, 1), SIZE(r2, 2)) DO kk = 1, SIZE(r3, 3) DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = obj1%val(:) _OP_ r2(jj, kk) + r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r2(jj, kk) END DO END DO - !! - IF(obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) END IF - !! + DEALLOCATE (r2, r3) END SELECT -!! -!! -!! -!! CASE (space) -!! SELECT CASE (obj1%vartype) - !! - !! space=space _OP_ constant - !! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) END IF - !! - !! space=space _OP_ space - !! CASE (space) - !! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - !! DO jj = 1, SIZE(r2, 2) r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) END IF + DEALLOCATE (r2) END SELECT -!! -!! -!! -!! CASE (time) -!! SELECT CASE (obj1%vartype) - !! - !! time=time _OP_ constant - !! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) END IF - !! - !! time=time _OP_ time - !! CASE (time) - !! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - !! DO jj = 1, SIZE(r2, 2) r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) END IF + DEALLOCATE (r2) END SELECT -!! -!! -!! -!! CASE (spacetime) - !! SELECT CASE (obj1%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! CASE (spacetime) - !! r3 = GET(obj1, typeFEVariableVector, typeFEVariableSpaceTime) r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - !! DO kk = 1, SIZE(r3, 3) DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r3(:,jj,kk) _OP_ r2(jj, kk) + r3(:, jj, kk) = r3(:, jj, kk) _OP_ r2(jj, kk) END DO END DO - !! - IF( obj1%defineon .EQ. Nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) END IF - !! + DEALLOCATE (r2, r3) END SELECT -!! -!! -!! -!! END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 index a8a1d632f..32e88ebf9 100644 --- a/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 +++ b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 @@ -1,258 +1,130 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! ScalarAddition -!---------------------------------------------------------------------------- - -!! Internal variable -! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) -! INTEGER(I4B) :: jj, kk -!! -!! main -!! SELECT CASE (obj1%vartype) -!! -!! -!! -!! CASE (constant) -!! SELECT CASE (obj2%vartype) - !! - !! constant = constant _OP_ constant - !! CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) ELSE - ans = QuadratureVariable( & - & obj1%val(:) _OP_ obj2%val(:), & - & typeFEVariableVector, & - & typeFEVariableConstant) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) END IF - !! - !! space= constant _OP_ space - !! CASE (space) - !! r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ r2(:, jj) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj) END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) END IF - !! - !! time=constant _OP_ time - !! + DEALLOCATE (r2) CASE (time) - !! r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(:) _OP_ r2(:, jj) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj) END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableTime) ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableTime) END IF - !! - !! spacetime=constant _OP_ spacetime - !! + DEALLOCATE (r2) CASE (spacetime) - !! r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) DO kk = 1, SIZE(r3, 3) DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = obj1%val(:) _OP_ r3(:, jj, kk) + r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r3(:, jj, kk) END DO END DO - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) END IF - !! + DEALLOCATE (r3) + END SELECT -!! -!! -!! -!! CASE (space) -!! SELECT CASE (obj2%vartype) - !! - !! space=space _OP_ constant - !! CASE (constant) - !! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - !! - DO jj = 1, SIZE(r2,2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(:) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len) END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableVector, & - & typeFEVariableSpace) + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) END IF - !! - !! space=space _OP_ space - !! + DEALLOCATE (r2) CASE (space) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) ELSE - ans = QuadratureVariable( & - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) END IF - !! END SELECT -!! -!! -!! -!! CASE (time) -!! SELECT CASE (obj2%vartype) - !! - !! time=time _OP_ constant - !! CASE (constant) - !! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - DO jj = 1, SIZE(r2,2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(:) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len) END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableTime) ELSE - ans = QuadratureVariable( & - & r2, & - & typeFEVariableVector, & - & typeFEVariableTime) + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableTime) END IF - !! - !! time=time _OP_ time - !! CASE (time) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) END IF - !! END SELECT -!! CASE (spacetime) - !! SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime _OP_ constant - !! CASE (constant) - !! r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) DO kk = 1, SIZE(r3, 3) DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(:) + r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(1:obj2%len) END DO END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) ELSE - ans = QuadratureVariable(& - & r3, & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) END IF - !! - !! spacetime=spacetime _OP_ spacetime - !! + DEALLOCATE (r3) + CASE (spacetime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) ELSE - ans = QuadratureVariable(& - & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) END IF - !! END SELECT - !! + END SELECT From a2989b450f7679123e5038d92cc2dbed1e497138 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:28:55 +0900 Subject: [PATCH 044/359] update in fevariable --- .../FEVariable/src/FEVariable_Method@AbsMethods.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 index 536a67668..6cecc69f9 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 @@ -18,9 +18,11 @@ #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, & @@ -30,6 +32,7 @@ TypeFEVariableSpaceTime IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -39,13 +42,13 @@ MODULE PROCEDURE fevar_Abs SELECT CASE (obj%rank) -CASE (SCALAR) +CASE (scalar) #include "./include/ScalarElemMethod.F90" -CASE (VECTOR) +CASE (vector) #include "./include/VectorElemMethod.F90" -CASE (MATRIX) +CASE (matrix) #include "./include/MatrixElemMethod.F90" END SELECT From ef086149837b330650c8e025bbe782a41580949e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:29:00 +0900 Subject: [PATCH 045/359] update in fevariable --- .../src/FEVariable_Method@AdditionMethods.F90 | 99 +++++-------------- 1 file changed, 25 insertions(+), 74 deletions(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 index c821e9660..68d095928 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 @@ -14,10 +14,24 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see ! -#define _OP_ + SUBMODULE(FEVariable_Method) AdditionMethods -USE BaseMethod + +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, & + Nodal, Quadrature +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE ReallocateUtility, ONLY: Reallocate + +#define _OP_ + + IMPLICIT NONE CONTAINS @@ -26,62 +40,33 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_addition1 -!! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) INTEGER(I4B) :: jj, kk -!! SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) - !! +CASE (scalar) SELECT CASE (obj2%rank) - !! scalar, scalar CASE (scalar) #include "./include/ScalarOperatorScalar.F90" - !! scalar, vector CASE (vector) #include "./include/ScalarOperatorVector.F90" - !! scalar, matrix CASE (matrix) #include "./include/ScalarOperatorMatrix.F90" END SELECT -!! -!! -!! -!! -CASE (VECTOR) - !! +CASE (vector) SELECT CASE (obj2%rank) - !! vector, scalar CASE (scalar) #include "./include/VectorOperatorScalar.F90" - !! vector, vector CASE (vector) #include "./include/VectorOperatorVector.F90" END SELECT -!! -!! -!! -!! -CASE (MATRIX) - !! +CASE (matrix) SELECT CASE (obj2%rank) CASE (scalar) - !! matrix, scalar #include "./include/MatrixOperatorScalar.F90" CASE (matrix) - !! matrix, matrix #include "./include/MatrixOperatorMatrix.F90" END SELECT -!! -!! -!! -!! END SELECT -!! END PROCEDURE fevar_addition1 !---------------------------------------------------------------------------- @@ -90,30 +75,13 @@ MODULE PROCEDURE fevar_addition2 SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) +CASE (scalar) #include "./include/ScalarOperatorReal.F90" -!! -!! -!! -!! -CASE (VECTOR) +CASE (vector) #include "./include/VectorOperatorReal.F90" -!! -!! -!! -!! -CASE (MATRIX) +CASE (matrix) #include "./include/MatrixOperatorReal.F90" -!! -!! -!! -!! END SELECT -!! END PROCEDURE fevar_addition2 !---------------------------------------------------------------------------- @@ -122,30 +90,13 @@ MODULE PROCEDURE fevar_addition3 SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) +CASE (scalar) #include "./include/RealOperatorScalar.F90" -!! -!! -!! -!! -CASE (VECTOR) +CASE (vector) #include "./include/RealOperatorVector.F90" -!! -!! -!! -!! -CASE (MATRIX) +CASE (matrix) #include "./include/RealOperatorMatrix.F90" -!! -!! -!! -!! END SELECT -!! END PROCEDURE fevar_addition3 !---------------------------------------------------------------------------- From 78dd35c0eb911eb3a6a9405a22dcd4476af2f3f0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:29:04 +0900 Subject: [PATCH 046/359] update in fevariable --- .../src/FEVariable_Method@DivisionMethods.F90 | 123 +++++++----------- 1 file changed, 48 insertions(+), 75 deletions(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 index 8447ad19c..3046f33bf 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 @@ -14,11 +14,25 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see ! -#define _OP_ / SUBMODULE(FEVariable_Method) DivisionMethods -USE BaseMethod +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, & + Nodal, Quadrature +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE ReallocateUtility, ONLY: Reallocate + +#define _OP_ / + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -26,62 +40,47 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Division1 -!! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) INTEGER(I4B) :: jj, kk -!! SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) - !! + +CASE (scalar) + SELECT CASE (obj2%rank) - !! scalar, scalar + CASE (scalar) + #include "./include/ScalarOperatorScalar.F90" - !! scalar, vector CASE (vector) + #include "./include/ScalarOperatorVector.F90" - !! scalar, matrix CASE (matrix) + #include "./include/ScalarOperatorMatrix.F90" END SELECT -!! -!! -!! -!! -CASE (VECTOR) - !! +CASE (vector) + SELECT CASE (obj2%rank) - !! vector, scalar + CASE (scalar) + #include "./include/VectorOperatorScalar.F90" - !! vector, vector CASE (vector) + #include "./include/VectorOperatorVector.F90" END SELECT -!! -!! -!! -!! -CASE (MATRIX) - !! +CASE (matrix) + SELECT CASE (obj2%rank) + CASE (scalar) - !! matrix, scalar + #include "./include/MatrixOperatorScalar.F90" CASE (matrix) - !! matrix, matrix + #include "./include/MatrixOperatorMatrix.F90" END SELECT -!! -!! -!! -!! END SELECT -!! END PROCEDURE fevar_Division1 !---------------------------------------------------------------------------- @@ -90,30 +89,17 @@ MODULE PROCEDURE fevar_Division2 SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) + +CASE (scalar) + #include "./include/ScalarOperatorReal.F90" -!! -!! -!! -!! -CASE (VECTOR) +CASE (vector) + #include "./include/VectorOperatorReal.F90" -!! -!! -!! -!! -CASE (MATRIX) +CASE (matrix) + #include "./include/MatrixOperatorReal.F90" -!! -!! -!! -!! END SELECT -!! END PROCEDURE fevar_Division2 !---------------------------------------------------------------------------- @@ -122,35 +108,22 @@ MODULE PROCEDURE fevar_Division3 SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) + +CASE (scalar) + #include "./include/RealOperatorScalar.F90" -!! -!! -!! -!! -CASE (VECTOR) +CASE (vector) + #include "./include/RealOperatorVector.F90" -!! -!! -!! -!! -CASE (MATRIX) +CASE (matrix) + #include "./include/RealOperatorMatrix.F90" -!! -!! -!! -!! END SELECT -!! END PROCEDURE fevar_Division3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -END SUBMODULE DivisionMethods #undef _OP_ +END SUBMODULE DivisionMethods From 1483c2c5e8fa6f64434815ad2028c9a335e1843b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:29:09 +0900 Subject: [PATCH 047/359] update in fevariable --- .../FEVariable/src/FEVariable_Method@EqualMethods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 index f43568827..d7e92e320 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 @@ -34,7 +34,7 @@ IF (obj1%varType .NE. obj2%varType) RETURN IF (ANY(obj1%s .NE. obj2%s)) RETURN -IF (ALL(obj1%val.APPROXEQ.obj2%val)) ans = .TRUE. +IF (ALL(obj1%val(1:obj1%len) .APPROXEQ.obj2%val(1:obj2%len))) ans = .TRUE. !! END PROCEDURE fevar_isequal From 488bb86ee42fa1e7f53b986bfde821619c7569ae Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:29:14 +0900 Subject: [PATCH 048/359] update in fevariable --- .fortls | 28 - .gitattributes | 2 - .gitconfig | 5 - .github/.pr-labeler.yml | 4 - .github/ISSUE_TEMPLATE/bug_report.md | 39 - .github/ISSUE_TEMPLATE/feature_request.md | 21 - .github/ISSUE_TEMPLATE/inspiration.md | 23 - .github/workflows/pr-labeler.yml | 18 - .gitignore | 29 - .vscode/settings.json | 7 - .vscode/tasks.json | 112 - CMakeLists.txt | 334 - CMakePresets.json | 81 - FORDsetup.md | 45 - LICENSE | 94 - LICENSE.gpl3.md | 596 - README.md | 205 - Workspaces/BLAS.code-workspace | 13 - Workspaces/OpenMP.code-workspace | 13 - Workspaces/Polynomial | 0 Workspaces/SparseMatrix.code-workspace | 16 - Workspaces/Tensor.code-workspace | 10 - Workspaces/Utility.code-workspace | 10 - Workspaces/refelem.code-workspace | 25 - base.code-workspace | 10 - build.py | 53 - cmake/Config.cmake.in | 75 - cmake/Modules/FindLAPACK.cmake | 563 - cmake/addARPACK.cmake | 30 - cmake/addFFTW.cmake | 33 - cmake/addGTKFortran.cmake | 49 - cmake/addLIS.cmake | 37 - cmake/addLapack95.cmake | 33 - cmake/addLua.cmake | 41 - cmake/addMetis.cmake | 28 - cmake/addOpenBLAS.cmake | 45 - cmake/addOpenMP.cmake | 70 - cmake/addPLPLOT.cmake | 47 - cmake/addRaylib.cmake | 31 - cmake/addSparsekit.cmake | 28 - cmake/addSuperLU.cmake | 25 - cmake/addToml.cmake | 28 - cmake/packaging.cmake | 195 - compile_commands.json | 2812 -- easifemBase.py | 0 easifemvar.sh | 0 figures/banner.jpeg | Bin 79230 -> 0 bytes figures/favicon.ico | 88 - figures/figure-1.svg | 4 - figures/figure-2.svg | 4 - figures/logo_hero.svg | 105 - figures/what-is-easifem.svg | 780 - fortran.json | 237 - install.py | 53 - neovim.json | 1 - package-lock.json | 64 - package.json | 5 - package.py | 49 - pages/BaseMethods.md | 58 - pages/BaseType.md | 66 - pages/Environment.md | 152 - pages/Extpkgs.md | 20 - pages/Install_Linux.md | 149 - pages/Install_MacOSX.md | 21 - pages/Install_Windows.md | 3 - pages/IntVector_.md | 106 - release_install.py | 52 - selected | 0 setup.py | 76 - setup/install_pkgs_Darwin.sh | 40 - setup/install_pkgs_Ubuntu.sh | 58 - setup/requirements.txt | 11 - setup/set_envvar_CentOS.sh | 0 setup/set_envvar_Darwin.sh | 72 - setup/set_envvar_Ubuntu.sh | 70 - src/modules/ARPACK/CMakeLists.txt | 24 - src/modules/ARPACK/src/ARPACK_SAUPD.F90 | 253 - src/modules/ARPACK/src/EASIFEM_ARPACK.F90 | 25 - src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 | 158 - src/modules/BLAS95/CMakeLists.txt | 26 - src/modules/BLAS95/aux/blas95.lst | 219 - src/modules/BLAS95/aux/test.F90 | 21 - src/modules/BLAS95/src/F77_BLAS.F90 | 2590 -- src/modules/BLAS95/src/F95_BLAS.F90 | 422 - src/modules/BLAS95/src/blas95_src/caxpby.F90 | 66 - src/modules/BLAS95/src/blas95_src/caxpy.F90 | 58 - src/modules/BLAS95/src/blas95_src/caxpyi.F90 | 55 - src/modules/BLAS95/src/blas95_src/ccopy.F90 | 49 - src/modules/BLAS95/src/blas95_src/cdotc.F90 | 50 - src/modules/BLAS95/src/blas95_src/cdotci.F90 | 47 - src/modules/BLAS95/src/blas95_src/cdotu.F90 | 50 - src/modules/BLAS95/src/blas95_src/cdotui.F90 | 47 - src/modules/BLAS95/src/blas95_src/cgbmv.F90 | 94 - src/modules/BLAS95/src/blas95_src/cgem2vc.F90 | 78 - src/modules/BLAS95/src/blas95_src/cgemm.F90 | 94 - src/modules/BLAS95/src/blas95_src/cgemm3m.F90 | 94 - .../BLAS95/src/blas95_src/cgemm3m_batch.F90 | 190 - .../BLAS95/src/blas95_src/cgemm_batch.F90 | 190 - src/modules/BLAS95/src/blas95_src/cgemmt.F90 | 100 - src/modules/BLAS95/src/blas95_src/cgemv.F90 | 79 - src/modules/BLAS95/src/blas95_src/cgerc.F90 | 63 - src/modules/BLAS95/src/blas95_src/cgeru.F90 | 63 - src/modules/BLAS95/src/blas95_src/cgthr.F90 | 46 - src/modules/BLAS95/src/blas95_src/cgthrz.F90 | 46 - src/modules/BLAS95/src/blas95_src/chbmv.F90 | 79 - src/modules/BLAS95/src/blas95_src/chemm.F90 | 87 - src/modules/BLAS95/src/blas95_src/chemv.F90 | 77 - src/modules/BLAS95/src/blas95_src/cher.F90 | 66 - src/modules/BLAS95/src/blas95_src/cher2.F90 | 69 - src/modules/BLAS95/src/blas95_src/cher2k.F90 | 91 - src/modules/BLAS95/src/blas95_src/cherk.F90 | 88 - src/modules/BLAS95/src/blas95_src/chpmv.F90 | 75 - src/modules/BLAS95/src/blas95_src/chpr.F90 | 64 - src/modules/BLAS95/src/blas95_src/chpr2.F90 | 67 - src/modules/BLAS95/src/blas95_src/crotg.F90 | 40 - src/modules/BLAS95/src/blas95_src/cscal.F90 | 48 - src/modules/BLAS95/src/blas95_src/csctr.F90 | 46 - src/modules/BLAS95/src/blas95_src/csrot.F90 | 52 - src/modules/BLAS95/src/blas95_src/csscal.F90 | 48 - src/modules/BLAS95/src/blas95_src/cswap.F90 | 49 - src/modules/BLAS95/src/blas95_src/csymm.F90 | 87 - src/modules/BLAS95/src/blas95_src/csyr2k.F90 | 91 - src/modules/BLAS95/src/blas95_src/csyrk.F90 | 88 - src/modules/BLAS95/src/blas95_src/ctbmv.F90 | 76 - src/modules/BLAS95/src/blas95_src/ctbsv.F90 | 76 - src/modules/BLAS95/src/blas95_src/ctpmv.F90 | 72 - src/modules/BLAS95/src/blas95_src/ctpsv.F90 | 72 - src/modules/BLAS95/src/blas95_src/ctrmm.F90 | 92 - src/modules/BLAS95/src/blas95_src/ctrmv.F90 | 74 - src/modules/BLAS95/src/blas95_src/ctrsm.F90 | 92 - .../BLAS95/src/blas95_src/ctrsm_batch.F90 | 191 - src/modules/BLAS95/src/blas95_src/ctrsv.F90 | 74 - src/modules/BLAS95/src/blas95_src/dasum.F90 | 47 - src/modules/BLAS95/src/blas95_src/daxpby.F90 | 66 - src/modules/BLAS95/src/blas95_src/daxpy.F90 | 58 - src/modules/BLAS95/src/blas95_src/daxpyi.F90 | 55 - src/modules/BLAS95/src/blas95_src/dcabs1.F90 | 37 - src/modules/BLAS95/src/blas95_src/dcopy.F90 | 49 - src/modules/BLAS95/src/blas95_src/ddot.F90 | 50 - src/modules/BLAS95/src/blas95_src/ddoti.F90 | 47 - src/modules/BLAS95/src/blas95_src/dgbmv.F90 | 94 - src/modules/BLAS95/src/blas95_src/dgem2vu.F90 | 78 - src/modules/BLAS95/src/blas95_src/dgemm.F90 | 94 - .../BLAS95/src/blas95_src/dgemm_batch.F90 | 190 - src/modules/BLAS95/src/blas95_src/dgemmt.F90 | 100 - src/modules/BLAS95/src/blas95_src/dgemv.F90 | 79 - src/modules/BLAS95/src/blas95_src/dger.F90 | 63 - src/modules/BLAS95/src/blas95_src/dgthr.F90 | 46 - src/modules/BLAS95/src/blas95_src/dgthrz.F90 | 46 - src/modules/BLAS95/src/blas95_src/dnrm2.F90 | 47 - src/modules/BLAS95/src/blas95_src/drot.F90 | 52 - src/modules/BLAS95/src/blas95_src/drotg.F90 | 40 - src/modules/BLAS95/src/blas95_src/droti.F90 | 51 - src/modules/BLAS95/src/blas95_src/drotm.F90 | 50 - src/modules/BLAS95/src/blas95_src/drotmg.F90 | 45 - src/modules/BLAS95/src/blas95_src/dsbmv.F90 | 79 - src/modules/BLAS95/src/blas95_src/dscal.F90 | 48 - src/modules/BLAS95/src/blas95_src/dsctr.F90 | 46 - src/modules/BLAS95/src/blas95_src/dsdot.F90 | 51 - src/modules/BLAS95/src/blas95_src/dspmv.F90 | 75 - src/modules/BLAS95/src/blas95_src/dspr.F90 | 64 - src/modules/BLAS95/src/blas95_src/dspr2.F90 | 67 - src/modules/BLAS95/src/blas95_src/dswap.F90 | 49 - src/modules/BLAS95/src/blas95_src/dsymm.F90 | 87 - src/modules/BLAS95/src/blas95_src/dsymv.F90 | 77 - src/modules/BLAS95/src/blas95_src/dsyr.F90 | 66 - src/modules/BLAS95/src/blas95_src/dsyr2.F90 | 69 - src/modules/BLAS95/src/blas95_src/dsyr2k.F90 | 91 - src/modules/BLAS95/src/blas95_src/dsyrk.F90 | 88 - src/modules/BLAS95/src/blas95_src/dtbmv.F90 | 76 - src/modules/BLAS95/src/blas95_src/dtbsv.F90 | 76 - src/modules/BLAS95/src/blas95_src/dtpmv.F90 | 72 - src/modules/BLAS95/src/blas95_src/dtpsv.F90 | 72 - src/modules/BLAS95/src/blas95_src/dtrmm.F90 | 92 - src/modules/BLAS95/src/blas95_src/dtrmv.F90 | 74 - src/modules/BLAS95/src/blas95_src/dtrsm.F90 | 92 - .../BLAS95/src/blas95_src/dtrsm_batch.F90 | 191 - src/modules/BLAS95/src/blas95_src/dtrsv.F90 | 74 - src/modules/BLAS95/src/blas95_src/dzasum.F90 | 47 - src/modules/BLAS95/src/blas95_src/dzgemm.F90 | 94 - src/modules/BLAS95/src/blas95_src/dzgemv.F90 | 79 - src/modules/BLAS95/src/blas95_src/dznrm2.F90 | 47 - src/modules/BLAS95/src/blas95_src/icamax.F90 | 47 - src/modules/BLAS95/src/blas95_src/icamin.F90 | 47 - src/modules/BLAS95/src/blas95_src/idamax.F90 | 47 - src/modules/BLAS95/src/blas95_src/idamin.F90 | 47 - src/modules/BLAS95/src/blas95_src/isamax.F90 | 47 - src/modules/BLAS95/src/blas95_src/isamin.F90 | 47 - src/modules/BLAS95/src/blas95_src/izamax.F90 | 47 - src/modules/BLAS95/src/blas95_src/izamin.F90 | 47 - src/modules/BLAS95/src/blas95_src/sasum.F90 | 47 - src/modules/BLAS95/src/blas95_src/saxpby.F90 | 66 - src/modules/BLAS95/src/blas95_src/saxpy.F90 | 58 - src/modules/BLAS95/src/blas95_src/saxpyi.F90 | 55 - src/modules/BLAS95/src/blas95_src/scabs1.F90 | 37 - src/modules/BLAS95/src/blas95_src/scasum.F90 | 47 - src/modules/BLAS95/src/blas95_src/scgemm.F90 | 94 - src/modules/BLAS95/src/blas95_src/scgemv.F90 | 79 - src/modules/BLAS95/src/blas95_src/scnrm2.F90 | 47 - src/modules/BLAS95/src/blas95_src/scopy.F90 | 49 - src/modules/BLAS95/src/blas95_src/sdot.F90 | 50 - src/modules/BLAS95/src/blas95_src/sdoti.F90 | 47 - src/modules/BLAS95/src/blas95_src/sdsdot.F90 | 52 - src/modules/BLAS95/src/blas95_src/sgbmv.F90 | 94 - src/modules/BLAS95/src/blas95_src/sgem2vu.F90 | 78 - src/modules/BLAS95/src/blas95_src/sgemm.F90 | 94 - .../BLAS95/src/blas95_src/sgemm_batch.F90 | 190 - src/modules/BLAS95/src/blas95_src/sgemmt.F90 | 100 - src/modules/BLAS95/src/blas95_src/sgemv.F90 | 79 - src/modules/BLAS95/src/blas95_src/sger.F90 | 63 - src/modules/BLAS95/src/blas95_src/sgthr.F90 | 46 - src/modules/BLAS95/src/blas95_src/sgthrz.F90 | 46 - src/modules/BLAS95/src/blas95_src/snrm2.F90 | 47 - src/modules/BLAS95/src/blas95_src/srot.F90 | 52 - src/modules/BLAS95/src/blas95_src/srotg.F90 | 40 - src/modules/BLAS95/src/blas95_src/sroti.F90 | 51 - src/modules/BLAS95/src/blas95_src/srotm.F90 | 50 - src/modules/BLAS95/src/blas95_src/srotmg.F90 | 45 - src/modules/BLAS95/src/blas95_src/ssbmv.F90 | 79 - src/modules/BLAS95/src/blas95_src/sscal.F90 | 48 - src/modules/BLAS95/src/blas95_src/ssctr.F90 | 46 - src/modules/BLAS95/src/blas95_src/sspmv.F90 | 75 - src/modules/BLAS95/src/blas95_src/sspr.F90 | 64 - src/modules/BLAS95/src/blas95_src/sspr2.F90 | 67 - src/modules/BLAS95/src/blas95_src/sswap.F90 | 49 - src/modules/BLAS95/src/blas95_src/ssymm.F90 | 87 - src/modules/BLAS95/src/blas95_src/ssymv.F90 | 77 - src/modules/BLAS95/src/blas95_src/ssyr.F90 | 66 - src/modules/BLAS95/src/blas95_src/ssyr2.F90 | 69 - src/modules/BLAS95/src/blas95_src/ssyr2k.F90 | 91 - src/modules/BLAS95/src/blas95_src/ssyrk.F90 | 88 - src/modules/BLAS95/src/blas95_src/stbmv.F90 | 76 - src/modules/BLAS95/src/blas95_src/stbsv.F90 | 76 - src/modules/BLAS95/src/blas95_src/stpmv.F90 | 72 - src/modules/BLAS95/src/blas95_src/stpsv.F90 | 72 - src/modules/BLAS95/src/blas95_src/strmm.F90 | 92 - src/modules/BLAS95/src/blas95_src/strmv.F90 | 74 - src/modules/BLAS95/src/blas95_src/strsm.F90 | 92 - .../BLAS95/src/blas95_src/strsm_batch.F90 | 191 - src/modules/BLAS95/src/blas95_src/strsv.F90 | 74 - src/modules/BLAS95/src/blas95_src/zaxpby.F90 | 66 - src/modules/BLAS95/src/blas95_src/zaxpy.F90 | 58 - src/modules/BLAS95/src/blas95_src/zaxpyi.F90 | 55 - src/modules/BLAS95/src/blas95_src/zcopy.F90 | 49 - src/modules/BLAS95/src/blas95_src/zdotc.F90 | 50 - src/modules/BLAS95/src/blas95_src/zdotci.F90 | 47 - src/modules/BLAS95/src/blas95_src/zdotu.F90 | 50 - src/modules/BLAS95/src/blas95_src/zdotui.F90 | 47 - src/modules/BLAS95/src/blas95_src/zdrot.F90 | 52 - src/modules/BLAS95/src/blas95_src/zdscal.F90 | 48 - src/modules/BLAS95/src/blas95_src/zgbmv.F90 | 94 - src/modules/BLAS95/src/blas95_src/zgem2vc.F90 | 78 - src/modules/BLAS95/src/blas95_src/zgemm.F90 | 94 - src/modules/BLAS95/src/blas95_src/zgemm3m.F90 | 94 - .../BLAS95/src/blas95_src/zgemm3m_batch.F90 | 190 - .../BLAS95/src/blas95_src/zgemm_batch.F90 | 190 - src/modules/BLAS95/src/blas95_src/zgemmt.F90 | 100 - src/modules/BLAS95/src/blas95_src/zgemv.F90 | 79 - src/modules/BLAS95/src/blas95_src/zgerc.F90 | 63 - src/modules/BLAS95/src/blas95_src/zgeru.F90 | 63 - src/modules/BLAS95/src/blas95_src/zgthr.F90 | 46 - src/modules/BLAS95/src/blas95_src/zgthrz.F90 | 46 - src/modules/BLAS95/src/blas95_src/zhbmv.F90 | 79 - src/modules/BLAS95/src/blas95_src/zhemm.F90 | 87 - src/modules/BLAS95/src/blas95_src/zhemv.F90 | 77 - src/modules/BLAS95/src/blas95_src/zher.F90 | 66 - src/modules/BLAS95/src/blas95_src/zher2.F90 | 69 - src/modules/BLAS95/src/blas95_src/zher2k.F90 | 91 - src/modules/BLAS95/src/blas95_src/zherk.F90 | 88 - src/modules/BLAS95/src/blas95_src/zhpmv.F90 | 75 - src/modules/BLAS95/src/blas95_src/zhpr.F90 | 64 - src/modules/BLAS95/src/blas95_src/zhpr2.F90 | 67 - src/modules/BLAS95/src/blas95_src/zrotg.F90 | 40 - src/modules/BLAS95/src/blas95_src/zscal.F90 | 48 - src/modules/BLAS95/src/blas95_src/zsctr.F90 | 46 - src/modules/BLAS95/src/blas95_src/zswap.F90 | 49 - src/modules/BLAS95/src/blas95_src/zsymm.F90 | 87 - src/modules/BLAS95/src/blas95_src/zsyr2k.F90 | 91 - src/modules/BLAS95/src/blas95_src/zsyrk.F90 | 88 - src/modules/BLAS95/src/blas95_src/ztbmv.F90 | 76 - src/modules/BLAS95/src/blas95_src/ztbsv.F90 | 76 - src/modules/BLAS95/src/blas95_src/ztpmv.F90 | 72 - src/modules/BLAS95/src/blas95_src/ztpsv.F90 | 72 - src/modules/BLAS95/src/blas95_src/ztrmm.F90 | 92 - src/modules/BLAS95/src/blas95_src/ztrmv.F90 | 74 - src/modules/BLAS95/src/blas95_src/ztrsm.F90 | 92 - .../BLAS95/src/blas95_src/ztrsm_batch.F90 | 191 - src/modules/BLAS95/src/blas95_src/ztrsv.F90 | 74 - .../BLAS95/src/easifem_blas_interface.inc | 1870 - src/modules/BaseContinuity/CMakeLists.txt | 23 - .../src/BaseContinuity_Method.F90 | 177 - src/modules/BaseInterpolation/CMakeLists.txt | 22 - .../src/BaseInterpolation_Method.F90 | 449 - src/modules/BaseMethod/CMakeLists.txt | 13 - src/modules/BaseMethod/src/BaseMethod.F90 | 120 - src/modules/BaseType/CMakeLists.txt | 22 - src/modules/BaseType/src/BaseType.F90 | 1748 - src/modules/BeFoR64/CMakeLists.txt | 64 - src/modules/BeFoR64/src/befor64.F90 | 1122 - .../BeFoR64/src/befor64_pack_data_m.F90 | 848 - src/modules/BoundingBox/CMakeLists.txt | 13 - .../BoundingBox/src/BoundingBox_Method.F90 | 934 - src/modules/CInterface/CMakeLists.txt | 13 - src/modules/CInterface/src/CInterface.F90 | 1214 - src/modules/CMakeLists.txt | 211 - src/modules/CSRMatrix/CMakeLists.txt | 51 - .../CSRMatrix/src/CSRMatrix_AddMethods.F90 | 505 - .../src/CSRMatrix_ConstructorMethods.F90 | 391 - .../CSRMatrix/src/CSRMatrix_DBCMethods.F90 | 36 - .../src/CSRMatrix_DiagonalScalingMethods.F90 | 75 - .../src/CSRMatrix_GetBlockColMethods.F90 | 380 - .../src/CSRMatrix_GetBlockRowMethods.F90 | 385 - .../CSRMatrix/src/CSRMatrix_GetColMethods.F90 | 394 - .../CSRMatrix/src/CSRMatrix_GetMethods.F90 | 680 - .../CSRMatrix/src/CSRMatrix_GetRowMethods.F90 | 348 - .../src/CSRMatrix_GetSubMatrixMethods.F90 | 63 - .../CSRMatrix/src/CSRMatrix_ILUMethods.F90 | 513 - .../CSRMatrix/src/CSRMatrix_IOMethods.F90 | 110 - .../src/CSRMatrix_LUSolveMethods.F90 | 140 - .../src/CSRMatrix_LinSolveMethods.F90 | 162 - .../CSRMatrix/src/CSRMatrix_MatVecMethods.F90 | 257 - .../src/CSRMatrix_MatrixMarketIO.F90 | 97 - .../CSRMatrix/src/CSRMatrix_Method.F90 | 50 - .../src/CSRMatrix_ReorderingMethods.F90 | 81 - .../CSRMatrix/src/CSRMatrix_SchurMethods.F90 | 187 - .../src/CSRMatrix_SetBlockColMethods.F90 | 166 - .../src/CSRMatrix_SetBlockRowMethods.F90 | 166 - .../CSRMatrix/src/CSRMatrix_SetColMethods.F90 | 485 - .../CSRMatrix/src/CSRMatrix_SetMethods.F90 | 580 - .../CSRMatrix/src/CSRMatrix_SetRowMethods.F90 | 476 - .../src/CSRMatrix_SparsityMethods.F90 | 153 - .../src/CSRMatrix_SpectralMethods.F90 | 209 - .../CSRMatrix/src/CSRMatrix_SuperLU.F90 | 503 - .../src/CSRMatrix_SymMatmulMethods.F90 | 41 - .../CSRMatrix/src/CSRMatrix_UnaryMethods.F90 | 512 - src/modules/CSRSparsity/CMakeLists.txt | 13 - .../CSRSparsity/src/CSRSparsity_Method.F90 | 821 - src/modules/ConvectiveMatrix/CMakeLists.txt | 22 - .../src/ConvectiveMatrix_Method.F90 | 125 - src/modules/DOF/CMakeLists.txt | 27 - src/modules/DOF/src/DOF_AddMethods.F90 | 451 - .../DOF/src/DOF_ConstructorMethods.F90 | 220 - src/modules/DOF/src/DOF_GetMethods.F90 | 1595 - src/modules/DOF/src/DOF_GetValueMethods.F90 | 384 - src/modules/DOF/src/DOF_IOMethods.F90 | 111 - src/modules/DOF/src/DOF_Method.F90 | 31 - src/modules/DOF/src/DOF_SetMethods.F90 | 464 - src/modules/DiffusionMatrix/CMakeLists.txt | 22 - .../src/DiffusionMatrix_Method.F90 | 577 - src/modules/Display/CMakeLists.txt | 26 - src/modules/Display/src/Display_Mat2.inc | 68 - src/modules/Display/src/Display_Mat3.inc | 24 - src/modules/Display/src/Display_Mat4.inc | 31 - src/modules/Display/src/Display_Method.F90 | 1712 - src/modules/Display/src/Display_Scalar.inc | 29 - src/modules/Display/src/Display_Vector.inc | 73 - .../src/References/dispmodule-userman.pdf | Bin 162230 -> 0 bytes src/modules/Display/src/disp/disp_charmod.F90 | 178 - src/modules/Display/src/disp/disp_i1mod.F90 | 266 - src/modules/Display/src/disp/disp_i2mod.F90 | 276 - src/modules/Display/src/disp/disp_i4mod.F90 | 270 - src/modules/Display/src/disp/disp_i8mod.F90 | 270 - src/modules/Display/src/disp/disp_l1mod.F90 | 202 - src/modules/Display/src/disp/disp_r16mod.F90 | 553 - src/modules/Display/src/disp/disp_r4mod.F90 | 549 - src/modules/Display/src/disp/disp_r8mod.F90 | 666 - src/modules/Display/src/disp/dispmodule.F90 | 189 - .../Display/src/disp/dispmodule_util.F90 | 955 - src/modules/Display/src/disp/putstrmodule.F90 | 25 - .../ElasticNitscheMatrix/CMakeLists.txt | 22 - .../src/ElasticNitscheMatrix_Method.F90 | 552 - src/modules/ElemshapeData/CMakeLists.txt | 43 - .../src/ElemshapeData_ConstructorMethods.F90 | 224 - .../src/ElemshapeData_DGHermitMethods.F90 | 53 - .../src/ElemshapeData_DGHierarchyMethods.F90 | 53 - .../src/ElemshapeData_DGLagrangeMethods.F90 | 53 - .../src/ElemshapeData_DGMethods.F90 | 252 - .../ElemshapeData_DGSerendipityMethods.F90 | 54 - .../src/ElemshapeData_DivergenceMethods.F90 | 245 - .../src/ElemshapeData_GetMethods.F90 | 94 - .../src/ElemshapeData_GradientMethods.F90 | 323 - .../src/ElemshapeData_H1Methods.F90 | 252 - .../src/ElemshapeData_HCurlMethods.F90 | 253 - .../src/ElemshapeData_HDivMethods.F90 | 253 - .../src/ElemshapeData_HRGNParamMethods.F90 | 141 - .../src/ElemshapeData_HRQIParamMethods.F90 | 147 - .../src/ElemshapeData_HminHmaxMethods.F90 | 228 - .../src/ElemshapeData_IOMethods.F90 | 92 - .../src/ElemshapeData_InterpolMethods.F90 | 695 - .../ElemshapeData_LocalDivergenceMethods.F90 | 264 - .../ElemshapeData_LocalGradientMethods.F90 | 367 - .../src/ElemshapeData_Method.F90 | 37 - .../src/ElemshapeData_ProjectionMethods.F90 | 214 - .../src/ElemshapeData_SetMethods.F90 | 482 - ...lemshapeData_StabilizationParamMethods.F90 | 481 - .../src/ElemshapeData_UnitNormalMethods.F90 | 129 - src/modules/ErrorHandling/CMakeLists.txt | 13 - .../ErrorHandling/src/ErrorHandling.F90 | 195 - src/modules/FACE/CMakeLists.txt | 68 - src/modules/FACE/src/face.F90 | 287 - src/modules/FEMatrix/CMakeLists.txt | 13 - src/modules/FEMatrix/src/FEMatrix_Method.F90 | 28 - src/modules/FEVariable/CMakeLists.txt | 13 - .../FEVariable/src/FEVariable_Method.F90 | 1626 - src/modules/FEVector/CMakeLists.txt | 22 - src/modules/FEVector/src/FEVector_Method.F90 | 21 - src/modules/FFTW/CMakeLists.txt | 22 - src/modules/FFTW/src/FFTW3.F90 | 2231 - src/modules/FPL/CMakeLists.txt | 17 - src/modules/FPL/LICENSE | 165 - src/modules/FPL/src/ErrorMessages.F90 | 123 - src/modules/FPL/src/FPL.F90 | 54 - src/modules/FPL/src/FPL_utils.F90 | 45 - src/modules/FPL/src/ParameterEntry.F90 | 381 - .../FPL/src/ParameterEntryDictionary.F90 | 336 - src/modules/FPL/src/ParameterList.F90 | 2742 -- src/modules/FPL/src/ParameterRootEntry.F90 | 350 - .../FPL/src/Wrapper/DimensionsWrapper.F90 | 126 - .../DimensionsWrapper0D.F90 | 64 - .../DimensionsWrapper0D_DLCA.F90 | 219 - .../DimensionsWrapper0D_I1P.F90 | 218 - .../DimensionsWrapper0D_I2P.F90 | 217 - .../DimensionsWrapper0D_I4P.F90 | 216 - .../DimensionsWrapper0D_I8P.F90 | 217 - .../DimensionsWrapper0D_L.F90 | 218 - .../DimensionsWrapper0D_R4P.F90 | 216 - .../DimensionsWrapper0D_R8P.F90 | 217 - .../DimensionsWrapper1D.F90 | 64 - .../DimensionsWrapper1D_DLCA.F90 | 251 - .../DimensionsWrapper1D_I1P.F90 | 227 - .../DimensionsWrapper1D_I2P.F90 | 225 - .../DimensionsWrapper1D_I4P.F90 | 226 - .../DimensionsWrapper1D_I8P.F90 | 225 - .../DimensionsWrapper1D_L.F90 | 235 - .../DimensionsWrapper1D_R4P.F90 | 225 - .../DimensionsWrapper1D_R8P.F90 | 225 - .../DimensionsWrapper2D.F90 | 64 - .../DimensionsWrapper2D_DLCA.F90 | 257 - .../DimensionsWrapper2D_I1P.F90 | 241 - .../DimensionsWrapper2D_I2P.F90 | 241 - .../DimensionsWrapper2D_I4P.F90 | 240 - .../DimensionsWrapper2D_I8P.F90 | 241 - .../DimensionsWrapper2D_L.F90 | 243 - .../DimensionsWrapper2D_R4P.F90 | 241 - .../DimensionsWrapper2D_R8P.F90 | 241 - .../DimensionsWrapper3D.F90 | 64 - .../DimensionsWrapper3D_DLCA.F90 | 261 - .../DimensionsWrapper3D_I1P.F90 | 246 - .../DimensionsWrapper3D_I2P.F90 | 245 - .../DimensionsWrapper3D_I4P.F90 | 245 - .../DimensionsWrapper3D_I8P.F90 | 245 - .../DimensionsWrapper3D_L.F90 | 247 - .../DimensionsWrapper3D_R4P.F90 | 244 - .../DimensionsWrapper3D_R8P.F90 | 245 - .../DimensionsWrapper4D.F90 | 64 - .../DimensionsWrapper4D_DLCA.F90 | 265 - .../DimensionsWrapper4D_I1P.F90 | 249 - .../DimensionsWrapper4D_I2P.F90 | 249 - .../DimensionsWrapper4D_I4P.F90 | 249 - .../DimensionsWrapper4D_I8P.F90 | 250 - .../DimensionsWrapper4D_L.F90 | 252 - .../DimensionsWrapper4D_R4P.F90 | 249 - .../DimensionsWrapper4D_R8P.F90 | 249 - .../DimensionsWrapper5D.F90 | 64 - .../DimensionsWrapper5D_DLCA.F90 | 269 - .../DimensionsWrapper5D_I1P.F90 | 254 - .../DimensionsWrapper5D_I2P.F90 | 253 - .../DimensionsWrapper5D_I4P.F90 | 252 - .../DimensionsWrapper5D_I8P.F90 | 252 - .../DimensionsWrapper5D_L.F90 | 256 - .../DimensionsWrapper5D_R4P.F90 | 253 - .../DimensionsWrapper5D_R8P.F90 | 253 - .../DimensionsWrapper6D.F90 | 64 - .../DimensionsWrapper6D_DLCA.F90 | 273 - .../DimensionsWrapper6D_I1P.F90 | 257 - .../DimensionsWrapper6D_I2P.F90 | 257 - .../DimensionsWrapper6D_I4P.F90 | 257 - .../DimensionsWrapper6D_I8P.F90 | 258 - .../DimensionsWrapper6D_L.F90 | 260 - .../DimensionsWrapper6D_R4P.F90 | 257 - .../DimensionsWrapper6D_R8P.F90 | 257 - .../DimensionsWrapper7D.F90 | 64 - .../DimensionsWrapper7D_DLCA.F90 | 276 - .../DimensionsWrapper7D_I1P.F90 | 260 - .../DimensionsWrapper7D_I2P.F90 | 260 - .../DimensionsWrapper7D_I4P.F90 | 260 - .../DimensionsWrapper7D_I8P.F90 | 260 - .../DimensionsWrapper7D_L.F90 | 262 - .../DimensionsWrapper7D_R4P.F90 | 260 - .../DimensionsWrapper7D_R8P.F90 | 259 - .../WrapperFactory/DLACWrapperFactory.F90 | 354 - .../WrapperFactory/I1PWrapperFactory.F90 | 354 - .../WrapperFactory/I2PWrapperFactory.F90 | 353 - .../WrapperFactory/I4PWrapperFactory.F90 | 353 - .../WrapperFactory/I8PWrapperFactory.F90 | 353 - .../WrapperFactory/LWrapperFactory.F90 | 353 - .../WrapperFactory/R4PWrapperFactory.F90 | 353 - .../WrapperFactory/R8PWrapperFactory.F90 | 353 - .../Wrapper/WrapperFactory/WrapperFactory.F90 | 172 - .../FPL/src/Wrapper/WrapperFactoryList.F90 | 418 - .../Wrapper/WrapperFactoryListSingleton.F90 | 60 - src/modules/FacetMatrix/CMakeLists.txt | 22 - src/modules/FacetMatrix/src/FacetMatrix1.inc | 175 - src/modules/FacetMatrix/src/FacetMatrix11.inc | 178 - src/modules/FacetMatrix/src/FacetMatrix12.inc | 166 - src/modules/FacetMatrix/src/FacetMatrix13.inc | 187 - src/modules/FacetMatrix/src/FacetMatrix14.inc | 187 - src/modules/FacetMatrix/src/FacetMatrix15.inc | 214 - src/modules/FacetMatrix/src/FacetMatrix2.inc | 159 - src/modules/FacetMatrix/src/FacetMatrix21.inc | 103 - src/modules/FacetMatrix/src/FacetMatrix22.inc | 103 - src/modules/FacetMatrix/src/FacetMatrix3.inc | 154 - src/modules/FacetMatrix/src/FacetMatrix4.inc | 154 - src/modules/FacetMatrix/src/FacetMatrix5.inc | 214 - .../FacetMatrix/src/FacetMatrix_Method.F90 | 37 - src/modules/ForceVector/CMakeLists.txt | 22 - .../ForceVector/src/ForceVector_Method.F90 | 229 - src/modules/Geometry/CMakeLists.txt | 34 - src/modules/Geometry/src/Geometry_Method.F90 | 31 - src/modules/Geometry/src/Line_Method.F90 | 431 - src/modules/Geometry/src/Plane_Method.F90 | 69 - .../Geometry/src/ReferenceElement_Method.F90 | 1347 - .../src/ReferenceHexahedron_Method.F90 | 375 - .../Geometry/src/ReferenceLine_Method.F90 | 518 - .../Geometry/src/ReferencePrism_Method.F90 | 407 - .../Geometry/src/ReferencePyramid_Method.F90 | 354 - .../src/ReferenceQuadrangle_Method.F90 | 484 - .../src/ReferenceTetrahedron_Method.F90 | 368 - .../Geometry/src/ReferenceTriangle_Method.F90 | 825 - src/modules/Geometry/src/Triangle_Method.F90 | 1505 - .../src/assets/geometry_burkardt_line.inc | 2991 -- .../src/assets/geometry_burkardt_triangle.inc | 3469 -- .../src/assets/geometry_by_burkardt.inc | 34798 ---------------- src/modules/GlobalData/CMakeLists.txt | 23 - src/modules/GlobalData/src/ElementNames.txt | 138 - src/modules/GlobalData/src/GlobalData.F90 | 617 - src/modules/Gnuplot/CMakeLists.txt | 13 - src/modules/Gnuplot/src/ogpf.F90 | 2662 -- src/modules/Hashing/CMakeLists.txt | 23 - src/modules/Hashing/src/Hashing32.F90 | 315 - src/modules/IndexValue/CMakeLists.txt | 13 - .../IndexValue/src/IndexValue_Method.F90 | 70 - src/modules/IntVector/CMakeLists.txt | 29 - .../IntVector/src/IntVector_AppendMethod.F90 | 124 - .../src/IntVector_ConstructorMethod.F90 | 374 - .../IntVector/src/IntVector_EnquireMethod.F90 | 127 - .../IntVector/src/IntVector_GetMethod.F90 | 421 - .../IntVector/src/IntVector_IOMethod.F90 | 57 - .../IntVector/src/IntVector_Method.F90 | 38 - .../IntVector/src/IntVector_SetMethod.F90 | 101 - src/modules/IterationData/CMakeLists.txt | 13 - .../src/IterationData_Method.F90 | 108 - src/modules/Kdtree2/CMakeLists.txt | 23 - src/modules/Kdtree2/src/Kd2PQueue_Module.F90 | 448 - src/modules/Kdtree2/src/Kdtree2_Module.F90 | 1329 - src/modules/KeyValue/CMakeLists.txt | 13 - src/modules/KeyValue/src/KeyValue_Method.F90 | 1227 - src/modules/LISInterface/CMakeLists.txt | 27 - src/modules/LISInterface/src/LISBasic.F90 | 63 - src/modules/LISInterface/src/LISInterface.F90 | 22 - src/modules/LISInterface/src/LISParam.F90 | 128 - src/modules/LISInterface/src/LISVector.F90 | 434 - src/modules/Lapack/CMakeLists.txt | 37 - .../Lapack/src/GE_CompRoutineMethods.F90 | 158 - .../Lapack/src/GE_EigenValueMethods.F90 | 188 - src/modules/Lapack/src/GE_LUMethods.F90 | 251 - src/modules/Lapack/src/GE_Lapack_Method.F90 | 39 - .../Lapack/src/GE_LinearSolveMethods.F90 | 488 - .../Lapack/src/GE_SingularValueMethods.F90 | 22 - src/modules/Lapack/src/Lapack_Method.F90 | 21 - .../Lapack/src/Sym_CompRoutineMethods.F90 | 20 - .../Lapack/src/Sym_EigenValueMethods.F90 | 20 - src/modules/Lapack/src/Sym_LUMethods.F90 | 488 - src/modules/Lapack/src/Sym_Lapack_Method.F90 | 40 - .../Lapack/src/Sym_LinearSolveMethods.F90 | 290 - .../Lapack/src/Sym_SingularValueMethods.F90 | 20 - src/modules/LuaInterface/CMakeLists.txt | 30 - src/modules/LuaInterface/src/LuaInterface.F90 | 1499 - .../LuaInterface/src/No_LuaInterface.F90 | 21 - src/modules/Macro/vectorclass.inc | 46 - src/modules/MassMatrix/CMakeLists.txt | 22 - .../MassMatrix/src/MassMatrix_Method.F90 | 158 - src/modules/MdEncode/CMakeLists.txt | 22 - src/modules/MdEncode/src/MdEncode_Method.F90 | 427 - src/modules/MetisInterface/CMakeLists.txt | 25 - .../MetisInterface/src/MetisInterface.F90 | 650 - .../MetisInterface/src/MetisInterface.inc | 881 - src/modules/MultiIndices/CMakeLists.txt | 22 - .../MultiIndices/src/MultiIndices_Method.F90 | 154 - src/modules/OpenMP/CMakeLists.txt | 13 - src/modules/OpenMP/src/OpenMP_Method.F90 | 82 - src/modules/PENF/CMakeLists.txt | 85 - src/modules/PENF/LICENSE.gpl3.md | 596 - src/modules/PENF/src/BCTON.inc | 128 - src/modules/PENF/src/BSTR.inc | 136 - src/modules/PENF/src/COMPACT_REAL_STRING.inc | 84 - src/modules/PENF/src/CTOA.inc | 212 - src/modules/PENF/src/STR.inc | 1039 - src/modules/PENF/src/STRZ.inc | 108 - src/modules/PENF/src/STR_ASCII.inc | 68 - src/modules/PENF/src/STR_UCS4.inc | 68 - src/modules/PENF/src/penf.F90 | 239 - src/modules/PENF/src/penf_b_size.F90 | 227 - .../src/penf_global_parameters_variables.F90 | 213 - src/modules/PENF/src/penf_stringify.F90 | 193 - src/modules/Polynomial/CMakeLists.txt | 39 - .../src/Chebyshev1PolynomialUtility.F90 | 1098 - .../src/HexahedronInterpolationUtility.F90 | 2636 -- .../Polynomial/src/InterpolationUtility.F90 | 96 - .../src/JacobiPolynomialUtility.F90 | 1089 - .../src/LagrangePolynomialUtility.F90 | 456 - .../src/LegendrePolynomialUtility.F90 | 1150 - .../src/LineInterpolationUtility.F90 | 1179 - .../src/LobattoPolynomialUtility.F90 | 495 - .../src/OrthogonalPolynomialUtility.F90 | 226 - .../Polynomial/src/PolynomialUtility.F90 | 36 - .../src/PrismInterpolationUtility.F90 | 690 - .../src/PyramidInterpolationUtility.F90 | 701 - .../src/QuadrangleInterpolationUtility.F90 | 2042 - .../Polynomial/src/RecursiveNodesUtility.F90 | 215 - .../src/TetrahedronInterpolationUtility.F90 | 1998 - .../src/TriangleInterpolationUtility.F90 | 1633 - .../src/UltrasphericalPolynomialUtility.F90 | 1251 - .../src/UnscaledLobattoPolynomialUtility.F90 | 411 - src/modules/QuadraturePoint/CMakeLists.txt | 13 - .../src/QuadraturePoint_Method.F90 | 779 - src/modules/Random/CMakeLists.txt | 13 - src/modules/Random/src/Random_Method.F90 | 338 - src/modules/Rank2Tensor/CMakeLists.txt | 13 - .../Rank2Tensor/src/Rank2Tensor_Method.F90 | 1719 - src/modules/RaylibInterface/CMakeLists.txt | 38 - src/modules/RaylibInterface/src/Raylib.F90 | 22 - .../RaylibInterface/src/RaylibCamera.F90 | 130 - .../src/RaylibCheckMethods.F90 | 157 - .../RaylibInterface/src/RaylibDrawMethods.F90 | 1144 - .../RaylibInterface/src/RaylibEnums.F90 | 403 - .../RaylibInterface/src/RaylibGenMethods.F90 | 283 - .../RaylibInterface/src/RaylibGetMethods.F90 | 794 - .../src/RaylibImageMethods.F90 | 477 - .../RaylibInterface/src/RaylibIsMethods.F90 | 419 - .../RaylibInterface/src/RaylibLoadMethods.F90 | 450 - .../RaylibInterface/src/RaylibMath.F90 | 1140 - .../RaylibInterface/src/RaylibMethods.F90 | 1060 - .../RaylibInterface/src/RaylibSetMethods.F90 | 503 - .../RaylibInterface/src/RaylibTypes.F90 | 380 - .../src/RaylibUnloadMethods.F90 | 237 - .../RaylibInterface/src/RaylibUtil.F90 | 48 - src/modules/RaylibInterface/src/__Raylib.F90 | 5913 --- src/modules/RealMatrix/CMakeLists.txt | 13 - .../RealMatrix/src/RealMatrix_Method.F90 | 1360 - src/modules/RealVector/CMakeLists.txt | 35 - .../RealVector/src/RealVector_AddMethods.F90 | 717 - .../src/RealVector_AppendMethods.F90 | 72 - .../src/RealVector_AssignMethods.F90 | 129 - .../src/RealVector_Blas1Methods.F90 | 810 - .../src/RealVector_ComparisonMethods.F90 | 40 - .../src/RealVector_ConstructorMethods.F90 | 453 - .../RealVector/src/RealVector_GetMethods.F90 | 708 - .../src/RealVector_GetValueMethods.F90 | 1168 - .../RealVector/src/RealVector_IOMethods.F90 | 52 - .../RealVector/src/RealVector_Method.F90 | 45 - .../src/RealVector_Norm2ErrorMethods.F90 | 165 - .../src/RealVector_Norm2Methods.F90 | 153 - .../RealVector/src/RealVector_SetMethods.F90 | 772 - .../src/RealVector_ShallowCopyMethods.F90 | 159 - src/modules/STConvectiveMatrix/CMakeLists.txt | 22 - .../src/STConvectiveMatrix_Method.F90 | 294 - src/modules/STConvectiveMatrix/src/del.inc | 540 - src/modules/STDiffusionMatrix/CMakeLists.txt | 22 - .../src/STDiffusionMatrix_Method.F90 | 449 - src/modules/STForceVector/CMakeLists.txt | 22 - .../src/STForceVector_Method.F90 | 533 - src/modules/STMassMatrix/CMakeLists.txt | 22 - .../STMassMatrix/src/STMassMatrix_Method.F90 | 218 - src/modules/StiffnessMatrix/CMakeLists.txt | 22 - .../src/StiffnessMatrix_Method.F90 | 104 - src/modules/String/CMakeLists.txt | 38 - src/modules/String/src/String_Class.F90 | 5680 --- src/modules/String/src/String_Method.F90 | 255 - src/modules/SuperLUInterface/CMakeLists.txt | 38 - .../SuperLUInterface/src/SuperLUInterface.F90 | 34 - .../SuperLUInterface/src/SuperLU_Enums.F90 | 320 - .../SuperLUInterface/src/SuperLU_Types.F90 | 668 - .../src/SuperLU_Util_Methods.F90 | 556 - .../src/SuperLU_dUtil_Methods.F90 | 470 - .../src/SuperLU_dgscon_Methods.F90 | 95 - .../src/SuperLU_dgsequ_Methods.F90 | 108 - .../src/SuperLU_dgsisx_Methods.F90 | 446 - .../src/SuperLU_dgsitrf_Methods.F90 | 196 - .../src/SuperLU_dgsrfs_Methods.F90 | 165 - .../src/SuperLU_dgssv_Methods.F90 | 150 - .../src/SuperLU_dgssvx_Methods.F90 | 375 - .../src/SuperLU_dgstrf_Methods.F90 | 302 - .../src/SuperLU_dgstrs_Methods.F90 | 101 - .../src/SuperLU_dlaqgs_Methods.F90 | 101 - .../SuperLUInterface/src/include/macros.inc | 18 - src/modules/System/CMakeLists.txt | 43 - src/modules/System/src/System_Method.F90 | 5427 --- src/modules/System/src/System_Method.c | 641 - src/modules/Test/CMakeLists.txt | 26 - src/modules/Test/src/README.txt | 486 - src/modules/Test/src/Test_Base.F90 | 170 - src/modules/Test/src/Test_Is.F90 | 130 - src/modules/Test/src/Test_Method.F90 | 27 - src/modules/Test/src/Test_More.F90 | 154 - src/modules/Test/src/Test_Planning.F90 | 77 - src/modules/Test/src/is_i.inc | 24 - src/modules/Test/src/is_r.inc | 83 - src/modules/TriangleInterface/CMakeLists.txt | 63 - .../src/TriangleInterface.F90 | 257 - src/modules/TriangleInterface/src/report.c | 126 - src/modules/TriangleInterface/src/triangle.c | 15737 ------- src/modules/TriangleInterface/src/triangle.h | 297 - src/modules/Utility/CMakeLists.txt | 56 - src/modules/Utility/src/AppendUtility.F90 | 799 - src/modules/Utility/src/ApproxUtility.F90 | 385 - src/modules/Utility/src/ArangeUtility.F90 | 115 - src/modules/Utility/src/AssertUtility.F90 | 146 - src/modules/Utility/src/BinomUtility.F90 | 132 - .../Utility/src/ContractionUtility.F90 | 416 - src/modules/Utility/src/ConvertUtility.F90 | 151 - src/modules/Utility/src/DiagUtility.F90 | 441 - src/modules/Utility/src/EigenUtility.F90 | 187 - src/modules/Utility/src/EyeUtility.F90 | 140 - src/modules/Utility/src/GridPointUtility.F90 | 282 - src/modules/Utility/src/HashingUtility.F90 | 54 - src/modules/Utility/src/HeadUtility.F90 | 90 - src/modules/Utility/src/InputUtility.F90 | 266 - src/modules/Utility/src/IntegerUtility.F90 | 537 - src/modules/Utility/src/InvUtility.F90 | 94 - .../Utility/src/LinearAlgebraUtility.F90 | 48 - src/modules/Utility/src/MappingUtility.F90 | 966 - src/modules/Utility/src/MatmulUtility.F90 | 352 - src/modules/Utility/src/MedianUtility.F90 | 131 - src/modules/Utility/src/MiscUtility.F90 | 384 - src/modules/Utility/src/OnesUtility.F90 | 363 - src/modules/Utility/src/PartitionUtility.F90 | 174 - src/modules/Utility/src/ProductUtility.F90 | 1413 - src/modules/Utility/src/PushPopUtility.F90 | 272 - src/modules/Utility/src/ReallocateUtility.F90 | 801 - src/modules/Utility/src/SafeSizeUtility.F90 | 64 - src/modules/Utility/src/SortUtility.F90 | 808 - src/modules/Utility/src/SplitUtility.F90 | 129 - src/modules/Utility/src/StringUtility.F90 | 448 - src/modules/Utility/src/SwapUtility.F90 | 830 - src/modules/Utility/src/SymUtility.F90 | 163 - src/modules/Utility/src/TailUtility.F90 | 132 - src/modules/Utility/src/TriagUtility.F90 | 1081 - src/modules/Utility/src/Utility.F90 | 59 - src/modules/Utility/src/ZerosUtility.F90 | 400 - src/modules/Utility/src/refs/mathPlantFEM.inc | 2713 -- src/modules/Vector3D/CMakeLists.txt | 13 - src/modules/Vector3D/src/Vector3D_Method.F90 | 1019 - src/modules/VoigtRank2Tensor/CMakeLists.txt | 13 - .../src/VoigtRank2Tensor_Method.F90 | 297 - src/modules/easifemBase/CMakeLists.txt | 13 - src/modules/easifemBase/src/easifemBase.F90 | 21 - src/submodules/ARPACK/CMakeLists.txt | 22 - .../ARPACK/src/ARPACK_SAUPD@Methods.F90 | 617 - src/submodules/BoundingBox/CMakeLists.txt | 26 - .../BoundingBox_Method@ConstructorMethods.F90 | 180 - .../src/BoundingBox_Method@GetMethods.F90 | 300 - .../src/BoundingBox_Method@IOMethods.F90 | 41 - .../src/BoundingBox_Method@SetMethods.F90 | 70 - .../src/BoundingBox_Method@TomlMethods.F90 | 86 - src/submodules/CMakeLists.txt | 130 - src/submodules/CSRMatrix/CMakeLists.txt | 47 - .../src/CSRMatrix_AddMethods@Methods.F90 | 420 - .../CSRMatrix_ConstructorMethods@Methods.F90 | 382 - .../src/CSRMatrix_DBCMethods@Methods.F90 | 72 - ...RMatrix_DiagonalScalingMethods@Methods.F90 | 166 - .../CSRMatrix_GetBlockColMethods@Methods.F90 | 318 - .../CSRMatrix_GetBlockRowMethods@Methods.F90 | 291 - .../src/CSRMatrix_GetColMethods@Methods.F90 | 238 - .../src/CSRMatrix_GetMethods@Methods.F90 | 522 - .../src/CSRMatrix_GetRowMethods@Methods.F90 | 195 - .../CSRMatrix_GetSubMatrixMethods@Methods.F90 | 124 - .../src/CSRMatrix_ILUMethods@Methods.F90 | 486 - .../src/CSRMatrix_IOMethods@Methods.F90 | 353 - .../src/CSRMatrix_LUSolveMethods@Methods.F90 | 51 - .../src/CSRMatrix_LinSolveMethods@Methods.F90 | 607 - .../src/CSRMatrix_MatVecMethods@Methods.F90 | 265 - .../src/CSRMatrix_MatrixMarketIO@Methods.F90 | 340 - .../CSRMatrix_ReorderingMethods@Methods.F90 | 95 - .../src/CSRMatrix_SchurMethods@Methods.F90 | 322 - .../CSRMatrix_SetBlockColMethods@Methods.F90 | 241 - .../CSRMatrix_SetBlockRowMethods@Methods.F90 | 233 - .../src/CSRMatrix_SetColMethods@Methods.F90 | 351 - .../src/CSRMatrix_SetMethods@Methods.F90 | 403 - .../src/CSRMatrix_SetRowMethods@Methods.F90 | 314 - .../src/CSRMatrix_SparsityMethods@Methods.F90 | 96 - .../src/CSRMatrix_SpectralMethods@Methods.F90 | 458 - .../src/CSRMatrix_SuperLU@Methods.F90 | 1584 - .../CSRMatrix_SymMatmulMethods@Methods.F90 | 57 - .../src/CSRMatrix_UnaryMethods@Methods.F90 | 855 - src/submodules/CSRSparsity/CMakeLists.txt | 25 - .../CSRSparsity_Method@ConstructorMethods.F90 | 204 - .../src/CSRSparsity_Method@GetMethods.F90 | 345 - .../src/CSRSparsity_Method@IOMethods.F90 | 65 - .../src/CSRSparsity_Method@SetMethods.F90 | 341 - .../src/CSRSparsity_Method@SymMethods.F90 | 263 - .../ConvectiveMatrix/CMakeLists.txt | 13 - .../ConvectiveMatrix-old/Constructor.part | 99 - .../ConvectiveMatrix_10.part | 170 - .../ConvectiveMatrix_11.part | 191 - .../ConvectiveMatrix_12.part | 180 - .../ConvectiveMatrix_9.part | 173 - .../ConvectiveMatrix_Class.f90 | 81 - .../MdFiles/ConvectiveMatrix_Class.md | 1036 - .../ConvectiveMatrix-old/MethodNames.part | 12 - src/submodules/ConvectiveMatrix/src/CM_1.inc | 59 - src/submodules/ConvectiveMatrix/src/CM_10.inc | 76 - src/submodules/ConvectiveMatrix/src/CM_2.inc | 42 - src/submodules/ConvectiveMatrix/src/CM_3.inc | 41 - src/submodules/ConvectiveMatrix/src/CM_4.inc | 42 - src/submodules/ConvectiveMatrix/src/CM_5.inc | 77 - src/submodules/ConvectiveMatrix/src/CM_6.inc | 79 - src/submodules/ConvectiveMatrix/src/CM_7.inc | 56 - src/submodules/ConvectiveMatrix/src/CM_8.inc | 58 - src/submodules/ConvectiveMatrix/src/CM_9.inc | 73 - .../src/ConvectiveMatrix_Method@Methods.F90 | 137 - src/submodules/DOF/CMakeLists.txt | 27 - .../DOF/src/DOF_AddMethods@Methods.F90 | 433 - .../src/DOF_ConstructorMethods@Methods.F90 | 136 - .../DOF/src/DOF_GetMethods@Methods.F90 | 827 - .../DOF/src/DOF_GetValueMethods@Methods.F90 | 368 - .../DOF/src/DOF_IOMethods@Methods.F90 | 94 - .../DOF/src/DOF_SetMethods@Methods.F90 | 319 - src/submodules/DiffusionMatrix/CMakeLists.txt | 13 - src/submodules/DiffusionMatrix/src/DM_1.inc | 55 - src/submodules/DiffusionMatrix/src/DM_10.inc | 59 - src/submodules/DiffusionMatrix/src/DM_2.inc | 56 - src/submodules/DiffusionMatrix/src/DM_3.inc | 55 - src/submodules/DiffusionMatrix/src/DM_4.inc | 60 - src/submodules/DiffusionMatrix/src/DM_5.inc | 60 - src/submodules/DiffusionMatrix/src/DM_6.inc | 55 - src/submodules/DiffusionMatrix/src/DM_7.inc | 54 - src/submodules/DiffusionMatrix/src/DM_8.inc | 63 - src/submodules/DiffusionMatrix/src/DM_9.inc | 59 - .../src/DiffusionMatrix_Method@Methods.F90 | 548 - .../ElasticNitscheMatrix/CMakeLists.txt | 26 - .../ElasticNitscheMatrix_Method@Matrix1.F90 | 312 - .../ElasticNitscheMatrix_Method@Matrix2.F90 | 154 - .../ElasticNitscheMatrix_Method@Matrix3.F90 | 240 - ...asticNitscheMatrix_Method@MatrixNormal.F90 | 137 - ...sticNitscheMatrix_Method@MatrixTangent.F90 | 132 - src/submodules/ElemshapeData/CMakeLists.txt | 63 - .../ElemshapeData_DGMethods@HermitMethods.F90 | 36 - ...emshapeData_DGMethods@HierarchyMethods.F90 | 36 - ...lemshapeData_DGMethods@LagrangeMethods.F90 | 36 - ...mshapeData_DGMethods@OrthogonalMethods.F90 | 36 - ...shapeData_DGMethods@SerendipityMethods.F90 | 35 - ...emshapeData_ConstructorMethods@Methods.F90 | 362 - ...lemshapeData_DivergenceMethods@Methods.F90 | 205 - .../src/ElemshapeData_GetMethods@Methods.F90 | 95 - .../ElemshapeData_GradientMethods@Methods.F90 | 284 - ...ElemshapeData_HRGNParamMethods@Methods.F90 | 217 - ...ElemshapeData_HRQIParamMethods@Methods.F90 | 664 - .../ElemshapeData_HminHmaxMethods@Methods.F90 | 216 - .../src/ElemshapeData_IOMethods@Methods.F90 | 270 - .../ElemshapeData_InterpolMethods@Methods.F90 | 594 - ...apeData_LocalDivergenceMethods@Methods.F90 | 200 - ...shapeData_LocalGradientMethods@Methods.F90 | 244 - ...lemshapeData_ProjectionMethods@Methods.F90 | 167 - .../src/ElemshapeData_SetMethods@Methods.F90 | 285 - ...peData_StabilizationParamMethods@SUGN3.F90 | 147 - ...apeData_StabilizationParamMethods@SUPG.F90 | 567 - ...StabilizationParamMethods@Takizawa2018.F90 | 284 - ...lemshapeData_UnitNormalMethods@Methods.F90 | 168 - .../ElemshapeData_H1Methods@HermitMethods.F90 | 33 - ...emshapeData_H1Methods@HierarchyMethods.F90 | 127 - ...lemshapeData_H1Methods@LagrangeMethods.F90 | 133 - ...mshapeData_H1Methods@OrthogonalMethods.F90 | 169 - ...shapeData_H1Methods@SerendipityMethods.F90 | 36 - ...emshapeData_HCurlMethods@HermitMethods.F90 | 36 - ...hapeData_HCurlMethods@HierarchyMethods.F90 | 36 - ...shapeData_HCurlMethods@LagrangeMethods.F90 | 36 - ...apeData_HCurlMethods@OrthogonalMethods.F90 | 36 - ...peData_HCurlMethods@SerendipityMethods.F90 | 36 - ...lemshapeData_HDivMethods@HermitMethods.F90 | 36 - ...shapeData_HDivMethods@HierarchyMethods.F90 | 36 - ...mshapeData_HDivMethods@LagrangeMethods.F90 | 36 - ...hapeData_HDivMethods@OrthogonalMethods.F90 | 36 - ...apeData_HDivMethods@SerendipityMethods.F90 | 35 - src/submodules/FEMatrix/src/STCM/STCM_1.inc | 111 - src/submodules/FEVariable/CMakeLists.txt | 35 - .../src/FEVariable_Method@AbsMethods.F90 | 64 - .../src/FEVariable_Method@AdditionMethods.F90 | 107 - .../FEVariable_Method@ConstructorMethods.F90 | 467 - .../src/FEVariable_Method@DivisionMethods.F90 | 129 - .../FEVariable_Method@DotProductMethods.F90 | 282 - .../src/FEVariable_Method@EqualMethods.F90 | 78 - .../src/FEVariable_Method@GetMethods.F90 | 325 - .../src/FEVariable_Method@IOMethods.F90 | 121 - .../src/FEVariable_Method@MeanMethods.F90 | 181 - ...EVariable_Method@MultiplicationMethods.F90 | 156 - .../src/FEVariable_Method@Norm2Methods.F90 | 136 - .../src/FEVariable_Method@PowerMethods.F90 | 47 - .../src/FEVariable_Method@SqrtMethods.F90 | 51 - .../FEVariable_Method@SubtractionMethods.F90 | 156 - .../src/include/MatrixElemMethod.F90 | 50 - .../src/include/MatrixOperatorMatrix.F90 | 129 - .../src/include/MatrixOperatorReal.F90 | 34 - .../src/include/MatrixOperatorScalar.F90 | 164 - .../FEVariable/src/include/MatrixPower.F90 | 92 - .../src/include/RealOperatorMatrix.F90 | 34 - .../src/include/RealOperatorScalar.F90 | 34 - .../src/include/RealOperatorVector.F90 | 43 - .../src/include/ScalarElemMethod.F90 | 61 - .../src/include/ScalarOperatorMatrix.F90 | 186 - .../src/include/ScalarOperatorReal.F90 | 34 - .../src/include/ScalarOperatorScalar.F90 | 148 - .../src/include/ScalarOperatorVector.F90 | 180 - .../FEVariable/src/include/ScalarPower.F90 | 42 - .../src/include/VectorElemMethod.F90 | 68 - .../src/include/VectorOperatorReal.F90 | 34 - .../src/include/VectorOperatorScalar.F90 | 120 - .../src/include/VectorOperatorVector.F90 | 130 - .../FEVariable/src/include/VectorPower.F90 | 93 - .../src/include/matrix_constant.F90 | 19 - .../src/include/matrix_constant2.F90 | 10 - .../FEVariable/src/include/matrix_space.F90 | 21 - .../FEVariable/src/include/matrix_space2.F90 | 10 - .../src/include/matrix_space_time.F90 | 23 - .../src/include/matrix_space_time2.F90 | 10 - .../FEVariable/src/include/matrix_time.F90 | 21 - .../FEVariable/src/include/matrix_time2.F90 | 10 - .../src/include/scalar_constant.F90 | 8 - .../FEVariable/src/include/scalar_space.F90 | 8 - .../src/include/scalar_space_time.F90 | 18 - .../src/include/scalar_space_time2.F90 | 12 - .../FEVariable/src/include/scalar_time.F90 | 8 - .../src/include/vector_constant.F90 | 10 - .../FEVariable/src/include/vector_space.F90 | 18 - .../FEVariable/src/include/vector_space2.F90 | 10 - .../src/include/vector_space_time.F90 | 21 - .../src/include/vector_space_time2.F90 | 10 - .../FEVariable/src/include/vector_time.F90 | 18 - .../FEVariable/src/include/vector_time2.F90 | 10 - src/submodules/FacetMatrix/CMakeLists.txt | 32 - ...acetMatrix_Method@FacetMatrix11Methods.F90 | 306 - ...acetMatrix_Method@FacetMatrix12Methods.F90 | 157 - ...acetMatrix_Method@FacetMatrix13Methods.F90 | 276 - ...acetMatrix_Method@FacetMatrix14Methods.F90 | 276 - ...acetMatrix_Method@FacetMatrix15Methods.F90 | 501 - ...FacetMatrix_Method@FacetMatrix1Methods.F90 | 373 - ...acetMatrix_Method@FacetMatrix21Methods.F90 | 127 - ...acetMatrix_Method@FacetMatrix22Methods.F90 | 127 - ...FacetMatrix_Method@FacetMatrix2Methods.F90 | 273 - ...FacetMatrix_Method@FacetMatrix3Methods.F90 | 324 - ...FacetMatrix_Method@FacetMatrix4Methods.F90 | 334 - ...FacetMatrix_Method@FacetMatrix5Methods.F90 | 602 - src/submodules/ForceVector/CMakeLists.txt | 13 - .../src/ForceVector_Method@Methods.F90 | 203 - src/submodules/Geometry/CMakeLists.txt | 39 - .../Geometry/src/Line_Method@Methods.F90 | 339 - .../Geometry/src/Plane_Method@Methods.F90 | 87 - ...renceElement_Method@ConstructorMethods.F90 | 367 - ...ReferenceElement_Method@EnquireMethods.F90 | 296 - ...enceElement_Method@FacetElementMethods.F90 | 223 - ...eferenceElement_Method@GeometryMethods.F90 | 560 - .../src/ReferenceElement_Method@IOMethods.F90 | 283 - ...eElement_Method@LocalNodeCoordsMethods.F90 | 429 - .../ReferenceElement_Method@VTKMethods.F90 | 154 - .../ReferenceHexahedron_Method@Methods.F90 | 629 - .../src/ReferenceLine_Method@Methods.F90 | 376 - .../src/ReferencePoint_Method@Methods.F90 | 102 - .../src/ReferencePrism_Method@Methods.F90 | 392 - .../src/ReferencePyramid_Method@Methods.F90 | 368 - .../ReferenceQuadrangle_Method@Methods.F90 | 660 - .../ReferenceTetrahedron_Method@Methods.F90 | 608 - .../src/ReferenceTriangle_Method@Methods.F90 | 849 - .../Geometry/src/Triangle_Method@Methods.F90 | 1435 - src/submodules/Geometry/src/inc/aux.inc | 239 - .../Geometry/src/modified_burkardt.inc | 266 - src/submodules/Hashing/CMakeLists.txt | 24 - .../Hashing/src/Hashing32@fnvMethods.F90 | 121 - .../Hashing/src/Hashing32@nmMethods.F90 | 903 - .../Hashing/src/Hashing32@waterMethods.F90 | 313 - src/submodules/Hashing/src/delme.F90 | 0 src/submodules/IndexValue/CMakeLists.txt | 13 - .../src/IndexValue_Method@Constructor.F90 | 59 - src/submodules/IntVector/CMakeLists.txt | 27 - .../src/IntVector_AppendMethod@Methods.F90 | 102 - .../IntVector_ConstructorMethod@Methods.F90 | 244 - .../src/IntVector_EnquireMethod@Methods.F90 | 119 - .../src/IntVector_GetMethod@Methods.F90 | 284 - .../src/IntVector_IOMethod@Methods.F90 | 55 - .../src/IntVector_SetMethod@Methods.F90 | 102 - .../IntVector/src/include/intvec_get_10.inc | 32 - .../IntVector/src/include/intvec_get_11.inc | 28 - .../IntVector/src/include/intvec_get_12.inc | 28 - .../IntVector/src/include/intvec_get_13.inc | 18 - src/submodules/IterationData/CMakeLists.txt | 23 - ...terationData_Method@ConstructorMethods.F90 | 179 - .../src/IterationData_Method@IOMethods.F90 | 44 - src/submodules/KeyValue/CMakeLists.txt | 15 - .../src/KeyValue_Method@Constructor.F90 | 505 - .../src/KeyValue_Method@getMethod.F90 | 186 - .../src/KeyValue_Method@setMethod.F90 | 138 - src/submodules/Lapack/CMakeLists.txt | 41 - .../src/GE_CompRoutineMethods@Methods.F90 | 74 - .../src/GE_EigenValueMethods@Methods.F90 | 203 - .../Lapack/src/GE_LUMethods@Methods.F90 | 144 - .../GE_Lapack_Method@CompRoutineMethods.F90 | 74 - .../GE_Lapack_Method@EigenvalueMethods.F90 | 29 - .../Lapack/src/GE_Lapack_Method@LUMethods.F90 | 144 - .../GE_Lapack_Method@LinearSolveMethods.F90 | 278 - .../src/GE_LinearSolveMethods@Methods.F90 | 278 - .../src/GE_SingularValueMethods@Methods.F90 | 29 - .../src/Sym_CompRoutineMethods@Methods.F90 | 16 - .../src/Sym_EigenValueMethods@Methods.F90 | 16 - .../Lapack/src/Sym_LUMethods@Methods.F90 | 507 - .../src/Sym_Lapack_Method@LUMethods.F90 | 506 - .../Sym_Lapack_Method@LinearSolveMethods.F90 | 215 - .../src/Sym_LinearSolveMethods@Methods.F90 | 216 - .../src/Sym_SingularValueMethods@Methods.F90 | 16 - src/submodules/MassMatrix/CMakeLists.txt | 22 - 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 | 326 - src/submodules/MdEncode/CMakeLists.txt | 22 - .../MdEncode/src/MdEncode_Method@Methods.F90 | 403 - .../MdEncode/src/inc/MdEncode_2.inc | 35 - .../MdEncode/src/inc/MdEncode_3.inc | 39 - .../MdEncode/src/inc/MdEncode_3b.inc | 25 - .../MdEncode/src/inc/MdEncode_6.inc | 109 - .../MdEncode/src/inc/MdEncode_7.inc | 121 - src/submodules/MultiIndices/CMakeLists.txt | 22 - .../src/MultiIndices_Method@Methods.F90 | 96 - src/submodules/OpenMP/CMakeLists.txt | 13 - .../OpenMP/src/OpenMP_Method@Constructor.F90 | 72 - src/submodules/Polynomial/CMakeLists.txt | 43 - .../Chebyshev1PolynomialUtility@Methods.F90 | 1150 - .../src/EquidistanceLIP_Tetrahedron.inc | 267 - .../src/EquidistanceLIP_Triangle.inc | 403 - ...HexahedronInterpolationUtility@Methods.F90 | 2950 -- .../src/InterpolationUtility@Methods.F90 | 149 - .../src/JacobiPolynomialUtility@Methods.F90 | 1415 - .../src/LagrangePolynomialUtility@Methods.F90 | 927 - .../src/LegendrePolynomialUtility@Methods.F90 | 1182 - .../src/LineInterpolationUtility@Methods.F90 | 1404 - .../src/LobattoPolynomialUtility@Methods.F90 | 453 - .../OrthogonalPolynomialUtility@Methods.F90 | 159 - .../src/PrismInterpolationUtility@Methods.F90 | 285 - .../PyramidInterpolationUtility@Methods.F90 | 288 - ...QuadrangleInterpolationUtility@Methods.F90 | 2023 - .../src/QuadraturePoint_Tetrahedron_Solin.F90 | 3449 -- ...adraturePoint_Triangle_InternalUseOnly.F90 | 477 - .../src/QuadraturePoint_Triangle_Solin.F90 | 2170 - .../src/RecursiveNodesUtility@Methods.F90 | 346 - ...etrahedronInterpolationUtility@Methods.F90 | 2587 -- ...lationUtility@HeirarchicalBasisMethods.F90 | 666 - ...erpolationUtility@LagrangeBasisMethods.F90 | 346 - .../TriangleInterpolationUtility@Methods.F90 | 549 - ...polationUtility@OrthogonalBasisMethods.F90 | 116 - ...InterpolationUtility@QuadratureMethods.F90 | 219 - ...ltrasphericalPolynomialUtility@Methods.F90 | 1221 - ...scaledLobattoPolynomialUtility@Methods.F90 | 381 - .../TriangleInterpolationUtility@Methods.F90 | 376 - .../src/include/Quadrangle/edge_12.inc | 10 - .../src/include/Quadrangle/edge_14.inc | 9 - .../src/include/Quadrangle/edge_21.inc | 9 - .../src/include/Quadrangle/edge_23.inc | 10 - .../src/include/Quadrangle/edge_32.inc | 10 - .../src/include/Quadrangle/edge_34.inc | 10 - .../src/include/Quadrangle/edge_41.inc | 10 - .../src/include/Quadrangle/edge_43.inc | 10 - .../src/include/Quadrangle/vertex_1.inc | 8 - .../src/include/Quadrangle/vertex_2.inc | 8 - .../src/include/Quadrangle/vertex_3.inc | 8 - .../src/include/Quadrangle/vertex_4.inc | 8 - src/submodules/QuadraturePoint/CMakeLists.txt | 25 - ...draturePoint_Method@ConstructorMethods.F90 | 964 - .../src/QuadraturePoint_Method@GetMethods.F90 | 91 - .../src/QuadraturePoint_Method@IOMethods.F90 | 70 - src/submodules/Random/CMakeLists.txt | 22 - .../Random/src/Random_Method@Methods.F90 | 382 - src/submodules/Rank2Tensor/CMakeLists.txt | 19 - .../Rank2Tensor_Method@ConstructorMethods.F90 | 275 - .../Rank2Tensor_Method@ContractionMethods.F90 | 89 - .../src/Rank2Tensor_Method@IOMethods.F90 | 32 - .../src/Rank2Tensor_Method@InvarMethods.F90 | 335 - .../Rank2Tensor_Method@OperatorMethods.F90 | 163 - .../Rank2Tensor_Method@PullbackMethods.F90 | 90 - .../Rank2Tensor_Method@PushForwardMethods.F90 | 90 - .../Rank2Tensor/src/matrix_exponential.F90 | 502 - .../ContinuumSpin/ContinuumSpin_Class.F90 | 137 - .../DeformationGradient_Class.F90 | 218 - .../DeformationTensor.part | 100 - .../old data/DeformationGradient/Display.part | 120 - .../MdFiles/DeformationGradient_Class.md | 128 - .../DeformationGradient/StrainTensor.part | 112 - .../Rank2Tensor/src/old data/Interface.part | 314 - .../LeftCauchyGreen/LeftCauchyGreen_Class.F90 | 100 - .../old data/MaterialJacobian/Display.part | 71 - .../old data/MaterialJacobian/Initiate.part | 257 - .../MaterialJacobian/MaterialJacobian.part | 153 - .../MaterialJacobian_Class.F90 | 177 - .../MaterialJacobian_Pointer.part | 160 - .../MdFiles/MaterialJacobian_Class.md | 230 - .../src/old data/MaterialJacobian/Names.part | 174 - .../OperatorOverloading/Addition.part | 193 - .../OperatorOverloading/Asterics.part | 75 - .../OperatorOverloading/Cijkl.part | 424 - .../OperatorOverloading/Contraction.part | 130 - .../OperatorOverloading/Matmul.part | 91 - .../OperatorOverloading/Subtraction.part | 193 - .../old data/MaterialJacobian/getCijkl.part | 146 - .../src/old data/MdFiles/Tensor_Class.md | 2288 - .../src/old data/Old_Rank4Tensors.part | 518 - .../src/old data/Old_StrainMeasures.part | 349 - .../src/old data/Old_getCDash.part | 151 - .../src/old data/Old_getCSigmaTruesdell.part | 237 - .../src/old data/OperatorInterface.part | 217 - .../OperatorOverloading/Addition.part | 220 - .../OperatorOverloading/Asterics.part | 373 - .../OperatorOverloading/Determinant.part | 60 - .../old data/OperatorOverloading/Inverse.part | 65 - .../old data/OperatorOverloading/MatMul.part | 257 - .../old data/OperatorOverloading/Otimes.part | 292 - .../OperatorOverloading/Transpose.part | 72 - .../RightCauchyGreen_Class.F90 | 100 - .../old data/Strain/AlmansiStrain_Class.F90 | 145 - .../src/old data/Strain/GreenStrain_Class.F90 | 142 - .../src/old data/Strain/SmallStrain_Class.F90 | 88 - .../src/old data/Strain/Strain_Class.F90 | 96 - .../old data/StrainRate/StrainRate_Class.F90 | 137 - .../src/old data/Stress/CauchyStress.part | 109 - .../src/old data/Stress/Constructor.part | 563 - .../src/old data/Stress/Display.part | 71 - .../src/old data/Stress/EshelbyStress.part | 106 - .../src/old data/Stress/Interface.part | 0 .../src/old data/Stress/KirchhoffStress.part | 101 - .../old data/Stress/MdFiles/Stress_Class.md | 128 - .../Stress/OperatorOverloading/Addition.part | 372 - .../OperatorOverloading/Assignment.part | 94 - .../Stress/OperatorOverloading/Asterics.part | 445 - .../Stress/OperatorOverloading/Invariant.part | 346 - .../Stress/OperatorOverloading/Matmul.part | 334 - .../Stress/OperatorOverloading/Otimes.part | 422 - .../Stress/OperatorOverloading/Shape.part | 205 - .../src/old data/Stress/Pk1Stress.part | 108 - .../src/old data/Stress/Pk2Stress.part | 109 - .../Stress/SpectralDecomposition.part | 193 - .../src/old data/Stress/StressType.part | 57 - .../src/old data/Stress/Stress_Class.F90 | 355 - .../old data/Stress/TensorDecomposition.part | 126 - .../src/old data/Stress/getStress.part | 228 - .../src/old data/Stress_Old/Initiate.part | 48 - .../src/old data/Stress_Old/Invariants.part | 252 - .../Stress_Old/StressDecomposition.part | 66 - .../Stress_Old/StressDerivatives.part | 201 - .../src/old data/Stress_Old/Stress_Class.F90 | 126 - .../old data/Stress_Old/getHillTensor.part | 88 - .../src/old data/Stress_Old/getLength.part | 44 - .../src/old data/Stress_Old/getSigma.part | 60 - .../src/old data/Stress_Old/setSigma.part | 50 - .../Rank2Tensor/src/old data/Tensor.F90 | 33 - .../VelocityGradient_Class.F90 | 96 - src/submodules/RealMatrix/CMakeLists.txt | 28 - .../src/RealMatrix_Method@BLASMethods.F90 | 17 - .../RealMatrix_Method@ConstructorMethods.F90 | 295 - .../RealMatrix_Method@GetValuesMethods.F90 | 174 - .../src/RealMatrix_Method@IOMethods.F90 | 55 - ...alMatrix_Method@IterativeSolverMethods.F90 | 151 - .../src/RealMatrix_Method@LAPACKMethods.F90 | 22 - .../src/RealMatrix_Method@MatmulMethods.F90 | 49 - .../RealMatrix_Method@SetValuesMethods.F90 | 427 - src/submodules/RealVector/CMakeLists.txt | 34 - .../src/RealVector_AddMethods@Methods.F90 | 370 - .../src/RealVector_AppendMethods@Methods.F90 | 55 - .../src/RealVector_AssignMethods@Methods.F90 | 160 - .../src/RealVector_Blas1Methods@Methods.F90 | 426 - .../RealVector_ComparisonMethods@Methods.F90 | 52 - .../RealVector_ConstructorMethods@Methods.F90 | 265 - .../src/RealVector_GetMethods@Methods.F90 | 598 - .../RealVector_GetValueMethods@Methods.F90 | 526 - .../src/RealVector_IOMethods@Methods.F90 | 65 - .../RealVector_Norm2ErrorMethods@Methods.F90 | 183 - .../src/RealVector_Norm2Methods@Methods.F90 | 139 - .../src/RealVector_SetMethods@Methods.F90 | 362 - .../RealVector_ShallowCopyMethods@Methods.F90 | 156 - src/submodules/RealVector/src/Save_hdf5.F90 | 151 - .../STConvectiveMatrix/CMakeLists.txt | 13 - .../STConvectiveMatrix-old/Constructor.part | 139 - .../ConvectiveMatrix_10.part | 52 - .../ConvectiveMatrix_11.part | 199 - .../ConvectiveMatrix_12.part | 200 - .../ConvectiveMatrix_13.part | 239 - .../ConvectiveMatrix_14.part | 238 - .../ConvectiveMatrix_15.part | 53 - .../ConvectiveMatrix_16.part | 51 - .../ConvectiveMatrix_17.part | 53 - .../ConvectiveMatrix_18.part | 53 - .../ConvectiveMatrix_19.part | 347 - .../ConvectiveMatrix_20.part | 345 - .../ConvectiveMatrix_21.part | 316 - .../ConvectiveMatrix_22.part | 258 - .../ConvectiveMatrix_23.part | 50 - .../ConvectiveMatrix_24.part | 351 - .../ConvectiveMatrix_25.part | 347 - .../ConvectiveMatrix_26.part | 338 - .../ConvectiveMatrix_27.part | 200 - .../ConvectiveMatrix_28.part | 53 - .../ConvectiveMatrix_29.part | 208 - .../ConvectiveMatrix_30.part | 231 - .../ConvectiveMatrix_31.part | 229 - .../ConvectiveMatrix_32.part | 198 - .../ConvectiveMatrix_33.part | 238 - .../ConvectiveMatrix_34.part | 222 - .../ConvectiveMatrix_35.part | 163 - .../ConvectiveMatrix_36.part | 148 - .../ConvectiveMatrix_37.part | 248 - .../ConvectiveMatrix_38.part | 231 - .../ConvectiveMatrix_39.part | 177 - .../ConvectiveMatrix_9.part | 253 - .../MdFiles/STConvectiveMatrix_Class.md | 4393 -- .../STConvectiveMatrix-old/MethodNames.part | 39 - .../STConvectiveMatrix_Class.f90 | 112 - .../STConvectiveMatrix/src/STCM_1.inc | 115 - .../STConvectiveMatrix/src/STCM_10.inc | 125 - .../STConvectiveMatrix/src/STCM_11.inc | 215 - .../STConvectiveMatrix/src/STCM_12.inc | 122 - .../STConvectiveMatrix/src/STCM_13.inc | 272 - .../STConvectiveMatrix/src/STCM_14.inc | 272 - .../STConvectiveMatrix/src/STCM_15.inc | 292 - .../STConvectiveMatrix/src/STCM_16.inc | 292 - .../STConvectiveMatrix/src/STCM_17.inc | 311 - .../STConvectiveMatrix/src/STCM_2.inc | 134 - .../STConvectiveMatrix/src/STCM_3.inc | 231 - .../STConvectiveMatrix/src/STCM_4.inc | 128 - .../STConvectiveMatrix/src/STCM_5.inc | 217 - .../STConvectiveMatrix/src/STCM_6.inc | 119 - .../STConvectiveMatrix/src/STCM_7.inc | 201 - .../STConvectiveMatrix/src/STCM_8.inc | 112 - .../STConvectiveMatrix/src/STCM_9.inc | 122 - .../src/STConvectiveMatrix_Method@Methods.F90 | 805 - .../STDiffusionMatrix/CMakeLists.txt | 13 - .../STDiffusionMatrix-old/Constructor.part | 138 - .../DiffusionMatrix_1.part | 93 - .../DiffusionMatrix_10.part | 175 - .../DiffusionMatrix_11.part | 126 - .../DiffusionMatrix_12.part | 187 - .../DiffusionMatrix_13.part | 183 - .../DiffusionMatrix_14.part | 161 - .../DiffusionMatrix_15.part | 160 - .../DiffusionMatrix_16.part | 152 - .../DiffusionMatrix_17.part | 150 - .../DiffusionMatrix_18.part | 53 - .../DiffusionMatrix_19.part | 52 - .../DiffusionMatrix_2.part | 50 - .../DiffusionMatrix_20.part | 53 - .../DiffusionMatrix_21.part | 53 - .../DiffusionMatrix_22.part | 53 - .../DiffusionMatrix_23.part | 54 - .../DiffusionMatrix_24.part | 55 - .../DiffusionMatrix_25.part | 54 - .../DiffusionMatrix_26.part | 54 - .../DiffusionMatrix_27.part | 234 - .../DiffusionMatrix_28.part | 234 - .../DiffusionMatrix_29.part | 222 - .../DiffusionMatrix_3.part | 136 - .../DiffusionMatrix_30.part | 180 - .../DiffusionMatrix_31.part | 211 - .../DiffusionMatrix_4.part | 137 - .../DiffusionMatrix_5.part | 128 - .../DiffusionMatrix_6.part | 50 - .../DiffusionMatrix_7.part | 51 - .../DiffusionMatrix_8.part | 50 - .../DiffusionMatrix_9.part | 194 - .../STDiffusionMatrix-old/MethodNames.part | 31 - .../STDiffusionMatrix_Class.f90 | 100 - .../STDiffusionMatrix_Class.md | 1971 - .../STDiffusionMatrix/src/STDM_1.inc | 64 - .../STDiffusionMatrix/src/STDM_11.inc | 147 - .../STDiffusionMatrix/src/STDM_12.inc | 181 - .../STDiffusionMatrix/src/STDM_13.inc | 155 - .../STDiffusionMatrix/src/STDM_14.inc | 188 - .../STDiffusionMatrix/src/STDM_2.inc | 60 - .../STDiffusionMatrix/src/STDM_3.inc | 66 - .../STDiffusionMatrix/src/STDM_4.inc | 63 - .../STDiffusionMatrix/src/STDM_5.inc | 79 - .../STDiffusionMatrix/src/STDM_6.inc | 71 - .../STDiffusionMatrix/src/STDM_7.inc | 64 - .../STDiffusionMatrix/src/STDM_8.inc | 73 - .../src/STDiffusionMatrix_Method@Methods.F90 | 1180 - src/submodules/STFextVector/Constructor.part | 152 - src/submodules/STFextVector/FextVector_1.part | 111 - .../STFextVector/FextVector_10.part | 141 - .../STFextVector/FextVector_11.part | 161 - .../STFextVector/FextVector_12.part | 138 - .../STFextVector/FextVector_13.part | 133 - .../STFextVector/FextVector_14.part | 131 - .../STFextVector/FextVector_15.part | 136 - .../STFextVector/FextVector_16.part | 122 - .../STFextVector/FextVector_17.part | 104 - .../STFextVector/FextVector_18.part | 131 - .../STFextVector/FextVector_19.part | 124 - src/submodules/STFextVector/FextVector_2.part | 112 - .../STFextVector/FextVector_20.part | 131 - .../STFextVector/FextVector_21.part | 121 - .../STFextVector/FextVector_22.part | 116 - .../STFextVector/FextVector_23.part | 113 - .../STFextVector/FextVector_24.part | 149 - .../STFextVector/FextVector_25.part | 142 - .../STFextVector/FextVector_26.part | 113 - src/submodules/STFextVector/FextVector_3.part | 97 - src/submodules/STFextVector/FextVector_4.part | 135 - src/submodules/STFextVector/FextVector_5.part | 127 - src/submodules/STFextVector/FextVector_6.part | 169 - src/submodules/STFextVector/FextVector_7.part | 154 - src/submodules/STFextVector/FextVector_8.part | 109 - src/submodules/STFextVector/FextVector_9.part | 161 - .../MdFiles/STFextVector_Class.md | 1845 - src/submodules/STFextVector/MethodNames.part | 26 - .../STFextVector/STFextVector_Class.f90 | 102 - src/submodules/STFextVector/delme.f90 | 338 - src/submodules/STFintVector/Constructor.part | 152 - src/submodules/STFintVector/FintVector_1.part | 113 - src/submodules/STFintVector/FintVector_2.part | 112 - src/submodules/STFintVector/FintVector_3.part | 100 - src/submodules/STFintVector/FintVector_4.part | 100 - src/submodules/STFintVector/FintVector_5.part | 96 - src/submodules/STFintVector/FintVector_6.part | 81 - src/submodules/STFintVector/FintVector_7.part | 138 - src/submodules/STFintVector/FintVector_8.part | 103 - .../MdFiles/STFintVector_Class.md | 61 - src/submodules/STFintVector/MethodNames.part | 8 - .../STFintVector/STFintVector_Class.f90 | 80 - src/submodules/STForceVector/CMakeLists.txt | 13 - src/submodules/STForceVector/src/STFV_1.inc | 55 - src/submodules/STForceVector/src/STFV_10.inc | 63 - src/submodules/STForceVector/src/STFV_11.inc | 63 - src/submodules/STForceVector/src/STFV_12.inc | 63 - src/submodules/STForceVector/src/STFV_13.inc | 68 - src/submodules/STForceVector/src/STFV_14.inc | 68 - src/submodules/STForceVector/src/STFV_15.inc | 53 - src/submodules/STForceVector/src/STFV_16.inc | 58 - src/submodules/STForceVector/src/STFV_17.inc | 63 - src/submodules/STForceVector/src/STFV_18.inc | 63 - src/submodules/STForceVector/src/STFV_19.inc | 63 - src/submodules/STForceVector/src/STFV_2.inc | 60 - src/submodules/STForceVector/src/STFV_20.inc | 68 - src/submodules/STForceVector/src/STFV_21.inc | 68 - src/submodules/STForceVector/src/STFV_3.inc | 64 - src/submodules/STForceVector/src/STFV_4.inc | 64 - src/submodules/STForceVector/src/STFV_5.inc | 66 - src/submodules/STForceVector/src/STFV_6.inc | 69 - src/submodules/STForceVector/src/STFV_7.inc | 69 - src/submodules/STForceVector/src/STFV_8.inc | 53 - src/submodules/STForceVector/src/STFV_9.inc | 58 - .../src/STForceVector_Method@Methods.F90 | 865 - src/submodules/STMassMatrix/CMakeLists.txt | 13 - .../STMassMatrix-old/Constructor.part | 144 - .../STMassMatrix-old/MassMatrix_15.part | 284 - .../STMassMatrix-old/MassMatrix_16.part | 343 - .../STMassMatrix-old/MassMatrix_17.part | 305 - .../STMassMatrix-old/MassMatrix_18.part | 241 - .../STMassMatrix-old/MassMatrix_3.part | 236 - .../STMassMatrix-old/STMassMatrix_Class.md | 596 - src/submodules/STMassMatrix/src/STMM_1.inc | 57 - src/submodules/STMassMatrix/src/STMM_10.inc | 80 - src/submodules/STMassMatrix/src/STMM_10a.inc | 32 - src/submodules/STMassMatrix/src/STMM_10b.inc | 32 - src/submodules/STMassMatrix/src/STMM_10c.inc | 32 - src/submodules/STMassMatrix/src/STMM_10d.inc | 31 - src/submodules/STMassMatrix/src/STMM_11.inc | 79 - src/submodules/STMassMatrix/src/STMM_11a.inc | 31 - src/submodules/STMassMatrix/src/STMM_11b.inc | 31 - src/submodules/STMassMatrix/src/STMM_11c.inc | 31 - src/submodules/STMassMatrix/src/STMM_11d.inc | 31 - src/submodules/STMassMatrix/src/STMM_12.inc | 77 - src/submodules/STMassMatrix/src/STMM_12a.inc | 31 - src/submodules/STMassMatrix/src/STMM_12b.inc | 31 - src/submodules/STMassMatrix/src/STMM_12c.inc | 31 - src/submodules/STMassMatrix/src/STMM_12d.inc | 31 - src/submodules/STMassMatrix/src/STMM_13.inc | 69 - src/submodules/STMassMatrix/src/STMM_14.inc | 79 - src/submodules/STMassMatrix/src/STMM_15.inc | 71 - src/submodules/STMassMatrix/src/STMM_16.inc | 74 - src/submodules/STMassMatrix/src/STMM_17.inc | 24 - .../STMassMatrix/src/STMM_17_20.inc | 65 - src/submodules/STMassMatrix/src/STMM_18.inc | 24 - src/submodules/STMassMatrix/src/STMM_19.inc | 24 - src/submodules/STMassMatrix/src/STMM_2.inc | 58 - src/submodules/STMassMatrix/src/STMM_20.inc | 24 - src/submodules/STMassMatrix/src/STMM_21.inc | 70 - src/submodules/STMassMatrix/src/STMM_21a.inc | 31 - src/submodules/STMassMatrix/src/STMM_21b.inc | 31 - src/submodules/STMassMatrix/src/STMM_21c.inc | 31 - src/submodules/STMassMatrix/src/STMM_21d.inc | 31 - src/submodules/STMassMatrix/src/STMM_22.inc | 81 - src/submodules/STMassMatrix/src/STMM_22a.inc | 32 - src/submodules/STMassMatrix/src/STMM_22b.inc | 32 - src/submodules/STMassMatrix/src/STMM_22c.inc | 32 - src/submodules/STMassMatrix/src/STMM_22d.inc | 31 - src/submodules/STMassMatrix/src/STMM_23.inc | 80 - src/submodules/STMassMatrix/src/STMM_23a.inc | 31 - src/submodules/STMassMatrix/src/STMM_23b.inc | 31 - src/submodules/STMassMatrix/src/STMM_23c.inc | 31 - src/submodules/STMassMatrix/src/STMM_23d.inc | 31 - src/submodules/STMassMatrix/src/STMM_24.inc | 77 - src/submodules/STMassMatrix/src/STMM_24a.inc | 31 - src/submodules/STMassMatrix/src/STMM_24b.inc | 31 - src/submodules/STMassMatrix/src/STMM_24c.inc | 31 - src/submodules/STMassMatrix/src/STMM_24d.inc | 31 - src/submodules/STMassMatrix/src/STMM_25.inc | 73 - src/submodules/STMassMatrix/src/STMM_26.inc | 84 - src/submodules/STMassMatrix/src/STMM_27.inc | 75 - src/submodules/STMassMatrix/src/STMM_28.inc | 77 - src/submodules/STMassMatrix/src/STMM_3.inc | 57 - src/submodules/STMassMatrix/src/STMM_4.inc | 57 - src/submodules/STMassMatrix/src/STMM_5.inc | 61 - src/submodules/STMassMatrix/src/STMM_6.inc | 61 - src/submodules/STMassMatrix/src/STMM_7.inc | 66 - src/submodules/STMassMatrix/src/STMM_8.inc | 61 - src/submodules/STMassMatrix/src/STMM_9.inc | 67 - src/submodules/STMassMatrix/src/STMM_9a.inc | 31 - src/submodules/STMassMatrix/src/STMM_9b.inc | 31 - src/submodules/STMassMatrix/src/STMM_9c.inc | 31 - src/submodules/STMassMatrix/src/STMM_9d.inc | 31 - .../src/STMassMatrix_Method@Methods.F90 | 3653 -- .../STStiffnessMatrix/Constructor.part | 142 - .../MdFiles/STStiffnessMatrix_Class.md | 421 - .../STStiffnessMatrix/MethodNames.part | 14 - .../STStiffnessMatrix_Class.f90 | 85 - .../STStiffnessMatrix/StiffnessMatrix_1.part | 176 - .../STStiffnessMatrix/StiffnessMatrix_10.part | 106 - .../STStiffnessMatrix/StiffnessMatrix_11.part | 104 - .../STStiffnessMatrix/StiffnessMatrix_12.part | 85 - .../STStiffnessMatrix/StiffnessMatrix_13.part | 240 - .../STStiffnessMatrix/StiffnessMatrix_14.part | 106 - .../STStiffnessMatrix/StiffnessMatrix_2.part | 176 - .../STStiffnessMatrix/StiffnessMatrix_3.part | 171 - .../STStiffnessMatrix/StiffnessMatrix_4.part | 98 - .../STStiffnessMatrix/StiffnessMatrix_5.part | 98 - .../STStiffnessMatrix/StiffnessMatrix_6.part | 82 - .../STStiffnessMatrix/StiffnessMatrix_7.part | 229 - .../STStiffnessMatrix/StiffnessMatrix_8.part | 230 - .../STStiffnessMatrix/StiffnessMatrix_9.part | 221 - .../ST_Tau_SUPG_RGN/Constructor.part | 101 - .../MdFiles/._ST_TAU_SUPG_RGN_Class.md | Bin 299 -> 0 bytes .../MdFiles/ST_TAU_SUPG_RGN_Class.md | 1358 - .../ST_Tau_SUPG_RGN/MethodNamesForScalar.part | 12 - .../ST_Tau_SUPG_RGN/MethodNamesForVector.part | 12 - .../ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 | 100 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_1.part | 211 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_10.part | 223 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_11.part | 212 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_12.part | 64 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk | 190 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_2.part | 204 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_3.part | 178 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_4.part | 189 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_5.part | 178 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_6.part | 166 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_7.part | 234 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_8.part | 222 - .../ST_Tau_SUPG_RGN/SUPG_Scalar_9.part | 64 - .../ST_Tau_SUPG_RGN/SUPG_Vector_1.part | 211 - .../ST_Tau_SUPG_RGN/SUPG_Vector_10.part | 234 - .../ST_Tau_SUPG_RGN/SUPG_Vector_11.part | 222 - .../ST_Tau_SUPG_RGN/SUPG_Vector_12.part | 62 - .../ST_Tau_SUPG_RGN/SUPG_Vector_2.part | 199 - .../ST_Tau_SUPG_RGN/SUPG_Vector_3.part | 188 - .../ST_Tau_SUPG_RGN/SUPG_Vector_4.part | 200 - .../ST_Tau_SUPG_RGN/SUPG_Vector_5.part | 189 - .../ST_Tau_SUPG_RGN/SUPG_Vector_6.part | 177 - .../ST_Tau_SUPG_RGN/SUPG_Vector_7.part | 245 - .../ST_Tau_SUPG_RGN/SUPG_Vector_8.part | 234 - .../ST_Tau_SUPG_RGN/SUPG_Vector_9.part | 63 - src/submodules/StiffnessMatrix/CMakeLists.txt | 13 - .../src/StiffnessMatrix_Method@Methods.F90 | 338 - .../TriangleInterface/CMakeLists.txt | 21 - .../src/TriangleInterface@Methods.F90 | 179 - .../TriangleInterface/src/definemacro.h | 4 - .../TriangleInterface/src/undefinemacro.h | 4 - src/submodules/Utility/CMakeLists.txt | 55 - .../Utility/src/Append/Append_1.inc | 23 - .../Utility/src/Append/Append_1cd.inc | 27 - .../Utility/src/Append/Append_2.inc | 40 - .../Utility/src/Append/Append_2abcd.inc | 29 - .../Utility/src/Append/Append_2cd.inc | 53 - .../Utility/src/Append/Append_3.inc | 27 - .../Utility/src/Append/Append_3cd.inc | 38 - .../Utility/src/Append/Append_4.inc | 45 - .../Utility/src/Append/Append_4cd.inc | 63 - .../Utility/src/AppendUtility@Methods.F90 | 485 - .../Utility/src/ApproxUtility@Methods.F90 | 323 - .../Utility/src/ArangeUtility@Methods.F90 | 128 - .../Utility/src/AssertUtility@Methods.F90 | 214 - .../Utility/src/BinomUtility@Methods.F90 | 142 - .../Utility/src/ColConcat/ColConcat_1.inc | 22 - .../Utility/src/ColConcat/ColConcat_2.inc | 24 - .../Utility/src/ColConcat/ColConcat_3.inc | 24 - .../Utility/src/ColConcat/ColConcat_4.inc | 27 - .../src/ContractionUtility@Methods.F90 | 183 - .../Utility/src/ConvertUtility@Methods.F90 | 123 - src/submodules/Utility/src/Diag/SetDiag.inc | 62 - .../Utility/src/Diag/SetTriDiag.inc | 55 - src/submodules/Utility/src/Diag/Tridiag.inc | 23 - .../Utility/src/DiagUtility@Methods.F90 | 273 - .../Utility/src/EigenUtility@Methods.F90 | 335 - src/submodules/Utility/src/Expand/Expand.inc | 47 - .../Utility/src/Expand/ExpandMatrix.inc | 55 - .../Utility/src/EyeUtility@Methods.F90 | 120 - .../Utility/src/GridPointUtility@Methods.F90 | 239 - .../Utility/src/HashingUtility@Methods.F90 | 54 - .../Utility/src/HeadUtility@Methods.F90 | 67 - .../Utility/src/HeapSort/ArgHeapSort.inc | 76 - .../Utility/src/HeapSort/HeapSort.inc | 52 - src/submodules/Utility/src/In/In_1.inc | 32 - src/submodules/Utility/src/In/IsIn_1.inc | 23 - src/submodules/Utility/src/Input/Input1.inc | 22 - .../Utility/src/InputUtility@Methods.F90 | 150 - .../src/InsertionSort/ArgInsertionSort.inc | 28 - .../src/InsertionSort/InsertionSort.inc | 28 - .../Utility/src/IntegerUtility@Methods.F90 | 361 - .../Utility/src/Intersection/Intersection.inc | 22 - .../Utility/src/IntroSort/ArgIntroSort.inc | 16 - .../Utility/src/IntroSort/IntroSort.inc | 16 - .../src/IntroSort/Recursive_ArgIntroSort.inc | 31 - .../src/IntroSort/Recursive_IntroSort.inc | 32 - .../Utility/src/InvUtility@Methods.F90 | 225 - .../src/LinearAlgebraUtility@Methods.F90 | 65 - .../Utility/src/MappingUtility@Methods.F90 | 826 - .../Utility/src/MatmulUtility@Methods.F90 | 173 - .../Utility/src/Median/ArgMedian.inc | 20 - src/submodules/Utility/src/Median/Median.inc | 20 - .../Utility/src/MedianUtility@Methods.F90 | 119 - .../Utility/src/MiscUtility@Methods.F90 | 366 - .../Utility/src/OnesUtility@Methods.F90 | 253 - .../Utility/src/Partition/ArgPartition.inc | 34 - .../Utility/src/Partition/Partition.inc | 35 - .../Utility/src/PartitionUtility@Methods.F90 | 143 - .../Utility/src/ProductUtility@Methods.F90 | 500 - .../Utility/src/PushPop/Pop_Scalar.inc | 40 - .../Utility/src/PushPop/Push_Scalar.inc | 41 - .../Utility/src/PushPopUtility@Methods.F90 | 118 - .../Utility/src/QuickSort/QuickSort1Vec.inc | 34 - .../Utility/src/QuickSort/QuickSort2Vec.inc | 36 - .../Utility/src/QuickSort/QuickSort3Vec.inc | 38 - .../Utility/src/QuickSort/QuickSort4Vec.inc | 40 - .../Utility/src/ReallocateUtility@Methods.F90 | 1186 - .../RemoveDuplicates/RemoveDuplicates_1.inc | 46 - .../RemoveDuplicates/RemoveDuplicates_2.inc | 24 - .../Utility/src/Repeat/Repeat_1.inc | 23 - .../Utility/src/RowConcat/RowConcat_1.inc | 27 - .../Utility/src/RowConcat/RowConcat_2.inc | 28 - .../Utility/src/RowConcat/RowConcat_3.inc | 27 - .../Utility/src/RowConcat/RowConcat_4.inc | 28 - .../Utility/src/SafeSizeUtility@Methods.F90 | 64 - src/submodules/Utility/src/Sort/ArgSort.inc | 35 - src/submodules/Utility/src/Sort/Sort.inc | 37 - .../Utility/src/SortUtility@Methods.F90 | 615 - .../Utility/src/SplitUtility@Methods.F90 | 93 - .../Utility/src/StringUtility@Methods.F90 | 401 - .../Utility/src/SwapUtility@Methods.F90 | 817 - src/submodules/Utility/src/Sym/GetSym.inc | 28 - src/submodules/Utility/src/Sym/Sym.inc | 36 - .../Utility/src/SymUtility@Methods.F90 | 78 - .../Utility/src/TailUtility@Methods.F90 | 103 - src/submodules/Utility/src/Triag/GetTril1.inc | 26 - src/submodules/Utility/src/Triag/GetTril2.inc | 34 - src/submodules/Utility/src/Triag/GetTriu1.inc | 26 - src/submodules/Utility/src/Triag/GetTriu2.inc | 33 - src/submodules/Utility/src/Triag/SetTril1.inc | 25 - src/submodules/Utility/src/Triag/SetTril2.inc | 32 - src/submodules/Utility/src/Triag/SetTril3.inc | 25 - src/submodules/Utility/src/Triag/SetTriu1.inc | 25 - src/submodules/Utility/src/Triag/SetTriu2.inc | 31 - src/submodules/Utility/src/Triag/SetTriu3.inc | 25 - src/submodules/Utility/src/Triag/Tril1.inc | 26 - src/submodules/Utility/src/Triag/Tril2.inc | 34 - src/submodules/Utility/src/Triag/Triu1.inc | 26 - src/submodules/Utility/src/Triag/Triu2.inc | 33 - .../Utility/src/TriagUtility@Methods.F90 | 434 - .../Utility/src/ZerosUtility@Methods.F90 | 281 - .../src/inc/EquidistanceLIP_Tetrahedron.inc | 267 - .../src/inc/EquidistanceLIP_Triangle.inc | 403 - .../Vector/ToDo/VectorOperations.part | 366 - src/submodules/Vector3D/CMakeLists.txt | 14 - .../Vector3D/Vector3D_Method@Misc.F90 | 0 .../src/Vector3D_Method@Constructor.F90 | 143 - .../Vector3D/src/Vector3D_Method@Misc.F90 | 152 - .../VoigtRank2Tensor/CMakeLists.txt | 14 - .../VoigtRank2Tensor_Method@Constructor.F90 | 125 - .../src/VoigtRank2Tensor_Method@IO.F90 | 42 - 1593 files changed, 417223 deletions(-) delete mode 100644 .fortls delete mode 100644 .gitattributes delete mode 100644 .gitconfig delete mode 100644 .github/.pr-labeler.yml delete mode 100644 .github/ISSUE_TEMPLATE/bug_report.md delete mode 100644 .github/ISSUE_TEMPLATE/feature_request.md delete mode 100644 .github/ISSUE_TEMPLATE/inspiration.md delete mode 100644 .github/workflows/pr-labeler.yml delete mode 100644 .gitignore delete mode 100644 .vscode/settings.json delete mode 100644 .vscode/tasks.json delete mode 100644 CMakeLists.txt delete mode 100644 CMakePresets.json delete mode 100644 FORDsetup.md delete mode 100644 LICENSE delete mode 100644 LICENSE.gpl3.md delete mode 100644 README.md delete mode 100644 Workspaces/BLAS.code-workspace delete mode 100644 Workspaces/OpenMP.code-workspace delete mode 100644 Workspaces/Polynomial delete mode 100644 Workspaces/SparseMatrix.code-workspace delete mode 100644 Workspaces/Tensor.code-workspace delete mode 100644 Workspaces/Utility.code-workspace delete mode 100644 Workspaces/refelem.code-workspace delete mode 100644 base.code-workspace delete mode 100755 build.py delete mode 100644 cmake/Config.cmake.in delete mode 100644 cmake/Modules/FindLAPACK.cmake delete mode 100644 cmake/addARPACK.cmake delete mode 100644 cmake/addFFTW.cmake delete mode 100644 cmake/addGTKFortran.cmake delete mode 100644 cmake/addLIS.cmake delete mode 100644 cmake/addLapack95.cmake delete mode 100644 cmake/addLua.cmake delete mode 100644 cmake/addMetis.cmake delete mode 100644 cmake/addOpenBLAS.cmake delete mode 100644 cmake/addOpenMP.cmake delete mode 100644 cmake/addPLPLOT.cmake delete mode 100644 cmake/addRaylib.cmake delete mode 100644 cmake/addSparsekit.cmake delete mode 100644 cmake/addSuperLU.cmake delete mode 100644 cmake/addToml.cmake delete mode 100644 cmake/packaging.cmake delete mode 100644 compile_commands.json delete mode 100644 easifemBase.py delete mode 100644 easifemvar.sh delete mode 100644 figures/banner.jpeg delete mode 100644 figures/favicon.ico delete mode 100644 figures/figure-1.svg delete mode 100644 figures/figure-2.svg delete mode 100644 figures/logo_hero.svg delete mode 100644 figures/what-is-easifem.svg delete mode 100644 fortran.json delete mode 100755 install.py delete mode 100644 neovim.json delete mode 100644 package-lock.json delete mode 100644 package.json delete mode 100644 package.py delete mode 100644 pages/BaseMethods.md delete mode 100644 pages/BaseType.md delete mode 100644 pages/Environment.md delete mode 100644 pages/Extpkgs.md delete mode 100644 pages/Install_Linux.md delete mode 100644 pages/Install_MacOSX.md delete mode 100644 pages/Install_Windows.md delete mode 100644 pages/IntVector_.md delete mode 100755 release_install.py delete mode 100644 selected delete mode 100644 setup.py delete mode 100644 setup/install_pkgs_Darwin.sh delete mode 100644 setup/install_pkgs_Ubuntu.sh delete mode 100644 setup/requirements.txt delete mode 100644 setup/set_envvar_CentOS.sh delete mode 100644 setup/set_envvar_Darwin.sh delete mode 100644 setup/set_envvar_Ubuntu.sh delete mode 100644 src/modules/ARPACK/CMakeLists.txt delete mode 100644 src/modules/ARPACK/src/ARPACK_SAUPD.F90 delete mode 100644 src/modules/ARPACK/src/EASIFEM_ARPACK.F90 delete mode 100644 src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 delete mode 100644 src/modules/BLAS95/CMakeLists.txt delete mode 100755 src/modules/BLAS95/aux/blas95.lst delete mode 100644 src/modules/BLAS95/aux/test.F90 delete mode 100755 src/modules/BLAS95/src/F77_BLAS.F90 delete mode 100644 src/modules/BLAS95/src/F95_BLAS.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/caxpby.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/caxpy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/caxpyi.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ccopy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cdotc.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cdotci.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cdotu.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cdotui.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgem2vc.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgemm3m.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgemmt.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgerc.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgeru.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgthr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cgthrz.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/chbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/chemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/chemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cher.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cher2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cher2k.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cherk.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/chpmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/chpr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/chpr2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/crotg.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cscal.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/csctr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/csrot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/csscal.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/cswap.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/csymm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/csyr2k.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/csyrk.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctbsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctpmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctpsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctrmm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctrmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctrsm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ctrsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dasum.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/daxpby.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/daxpy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/daxpyi.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dcabs1.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dcopy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ddot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ddoti.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgem2vu.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgemmt.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dger.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgthr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dgthrz.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dnrm2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/drot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/drotg.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/droti.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/drotm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/drotmg.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dscal.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsctr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsdot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dspmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dspr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dspr2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dswap.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsymm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsymv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsyr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsyr2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsyr2k.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dsyrk.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtbsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtpmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtpsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtrmm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtrmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtrsm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dtrsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dzasum.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dzgemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dzgemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/dznrm2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/icamax.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/icamin.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/idamax.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/idamin.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/isamax.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/isamin.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/izamax.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/izamin.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sasum.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/saxpby.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/saxpy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/saxpyi.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/scabs1.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/scasum.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/scgemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/scgemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/scnrm2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/scopy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sdot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sdoti.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sdsdot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgem2vu.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgemmt.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sger.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgthr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sgthrz.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/snrm2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/srot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/srotg.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sroti.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/srotm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/srotmg.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sscal.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssctr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sspmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sspr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sspr2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/sswap.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssymm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssymv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssyr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssyr2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssyr2k.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ssyrk.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/stbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/stbsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/stpmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/stpsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/strmm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/strmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/strsm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/strsm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/strsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zaxpby.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zaxpy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zaxpyi.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zcopy.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zdotc.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zdotci.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zdotu.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zdotui.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zdrot.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zdscal.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgem2vc.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgemm3m.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgemmt.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgerc.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgeru.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgthr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zgthrz.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zhbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zhemm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zhemv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zher.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zher2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zher2k.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zherk.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zhpmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zhpr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zhpr2.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zrotg.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zscal.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zsctr.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zswap.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zsymm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zsyr2k.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/zsyrk.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztbmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztbsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztpmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztpsv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztrmm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztrmv.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztrsm.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 delete mode 100755 src/modules/BLAS95/src/blas95_src/ztrsv.F90 delete mode 100644 src/modules/BLAS95/src/easifem_blas_interface.inc delete mode 100644 src/modules/BaseContinuity/CMakeLists.txt delete mode 100644 src/modules/BaseContinuity/src/BaseContinuity_Method.F90 delete mode 100644 src/modules/BaseInterpolation/CMakeLists.txt delete mode 100644 src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 delete mode 100644 src/modules/BaseMethod/CMakeLists.txt delete mode 100644 src/modules/BaseMethod/src/BaseMethod.F90 delete mode 100644 src/modules/BaseType/CMakeLists.txt delete mode 100644 src/modules/BaseType/src/BaseType.F90 delete mode 100644 src/modules/BeFoR64/CMakeLists.txt delete mode 100644 src/modules/BeFoR64/src/befor64.F90 delete mode 100644 src/modules/BeFoR64/src/befor64_pack_data_m.F90 delete mode 100644 src/modules/BoundingBox/CMakeLists.txt delete mode 100644 src/modules/BoundingBox/src/BoundingBox_Method.F90 delete mode 100644 src/modules/CInterface/CMakeLists.txt delete mode 100644 src/modules/CInterface/src/CInterface.F90 delete mode 100644 src/modules/CMakeLists.txt delete mode 100644 src/modules/CSRMatrix/CMakeLists.txt delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_Method.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 delete mode 100644 src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 delete mode 100644 src/modules/CSRSparsity/CMakeLists.txt delete mode 100644 src/modules/CSRSparsity/src/CSRSparsity_Method.F90 delete mode 100644 src/modules/ConvectiveMatrix/CMakeLists.txt delete mode 100644 src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 delete mode 100644 src/modules/DOF/CMakeLists.txt delete mode 100644 src/modules/DOF/src/DOF_AddMethods.F90 delete mode 100644 src/modules/DOF/src/DOF_ConstructorMethods.F90 delete mode 100644 src/modules/DOF/src/DOF_GetMethods.F90 delete mode 100644 src/modules/DOF/src/DOF_GetValueMethods.F90 delete mode 100644 src/modules/DOF/src/DOF_IOMethods.F90 delete mode 100644 src/modules/DOF/src/DOF_Method.F90 delete mode 100644 src/modules/DOF/src/DOF_SetMethods.F90 delete mode 100644 src/modules/DiffusionMatrix/CMakeLists.txt delete mode 100644 src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 delete mode 100644 src/modules/Display/CMakeLists.txt delete mode 100644 src/modules/Display/src/Display_Mat2.inc delete mode 100644 src/modules/Display/src/Display_Mat3.inc delete mode 100644 src/modules/Display/src/Display_Mat4.inc delete mode 100755 src/modules/Display/src/Display_Method.F90 delete mode 100644 src/modules/Display/src/Display_Scalar.inc delete mode 100644 src/modules/Display/src/Display_Vector.inc delete mode 100755 src/modules/Display/src/References/dispmodule-userman.pdf delete mode 100755 src/modules/Display/src/disp/disp_charmod.F90 delete mode 100755 src/modules/Display/src/disp/disp_i1mod.F90 delete mode 100755 src/modules/Display/src/disp/disp_i2mod.F90 delete mode 100755 src/modules/Display/src/disp/disp_i4mod.F90 delete mode 100755 src/modules/Display/src/disp/disp_i8mod.F90 delete mode 100755 src/modules/Display/src/disp/disp_l1mod.F90 delete mode 100755 src/modules/Display/src/disp/disp_r16mod.F90 delete mode 100755 src/modules/Display/src/disp/disp_r4mod.F90 delete mode 100755 src/modules/Display/src/disp/disp_r8mod.F90 delete mode 100755 src/modules/Display/src/disp/dispmodule.F90 delete mode 100644 src/modules/Display/src/disp/dispmodule_util.F90 delete mode 100644 src/modules/Display/src/disp/putstrmodule.F90 delete mode 100644 src/modules/ElasticNitscheMatrix/CMakeLists.txt delete mode 100644 src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 delete mode 100644 src/modules/ElemshapeData/CMakeLists.txt delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_Method.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 delete mode 100644 src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 delete mode 100644 src/modules/ErrorHandling/CMakeLists.txt delete mode 100644 src/modules/ErrorHandling/src/ErrorHandling.F90 delete mode 100644 src/modules/FACE/CMakeLists.txt delete mode 100644 src/modules/FACE/src/face.F90 delete mode 100644 src/modules/FEMatrix/CMakeLists.txt delete mode 100644 src/modules/FEMatrix/src/FEMatrix_Method.F90 delete mode 100644 src/modules/FEVariable/CMakeLists.txt delete mode 100644 src/modules/FEVariable/src/FEVariable_Method.F90 delete mode 100644 src/modules/FEVector/CMakeLists.txt delete mode 100644 src/modules/FEVector/src/FEVector_Method.F90 delete mode 100644 src/modules/FFTW/CMakeLists.txt delete mode 100644 src/modules/FFTW/src/FFTW3.F90 delete mode 100644 src/modules/FPL/CMakeLists.txt delete mode 100644 src/modules/FPL/LICENSE delete mode 100644 src/modules/FPL/src/ErrorMessages.F90 delete mode 100644 src/modules/FPL/src/FPL.F90 delete mode 100644 src/modules/FPL/src/FPL_utils.F90 delete mode 100644 src/modules/FPL/src/ParameterEntry.F90 delete mode 100644 src/modules/FPL/src/ParameterEntryDictionary.F90 delete mode 100644 src/modules/FPL/src/ParameterList.F90 delete mode 100644 src/modules/FPL/src/ParameterRootEntry.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 delete mode 100644 src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 delete mode 100644 src/modules/FacetMatrix/CMakeLists.txt delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix1.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix11.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix12.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix13.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix14.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix15.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix2.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix21.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix22.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix3.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix4.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix5.inc delete mode 100644 src/modules/FacetMatrix/src/FacetMatrix_Method.F90 delete mode 100644 src/modules/ForceVector/CMakeLists.txt delete mode 100644 src/modules/ForceVector/src/ForceVector_Method.F90 delete mode 100644 src/modules/Geometry/CMakeLists.txt delete mode 100644 src/modules/Geometry/src/Geometry_Method.F90 delete mode 100644 src/modules/Geometry/src/Line_Method.F90 delete mode 100644 src/modules/Geometry/src/Plane_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferenceElement_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferenceHexahedron_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferenceLine_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferencePrism_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferencePyramid_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferenceTriangle_Method.F90 delete mode 100644 src/modules/Geometry/src/Triangle_Method.F90 delete mode 100644 src/modules/Geometry/src/assets/geometry_burkardt_line.inc delete mode 100644 src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc delete mode 100644 src/modules/Geometry/src/assets/geometry_by_burkardt.inc delete mode 100644 src/modules/GlobalData/CMakeLists.txt delete mode 100644 src/modules/GlobalData/src/ElementNames.txt delete mode 100755 src/modules/GlobalData/src/GlobalData.F90 delete mode 100644 src/modules/Gnuplot/CMakeLists.txt delete mode 100644 src/modules/Gnuplot/src/ogpf.F90 delete mode 100644 src/modules/Hashing/CMakeLists.txt delete mode 100644 src/modules/Hashing/src/Hashing32.F90 delete mode 100644 src/modules/IndexValue/CMakeLists.txt delete mode 100644 src/modules/IndexValue/src/IndexValue_Method.F90 delete mode 100644 src/modules/IntVector/CMakeLists.txt delete mode 100644 src/modules/IntVector/src/IntVector_AppendMethod.F90 delete mode 100644 src/modules/IntVector/src/IntVector_ConstructorMethod.F90 delete mode 100644 src/modules/IntVector/src/IntVector_EnquireMethod.F90 delete mode 100644 src/modules/IntVector/src/IntVector_GetMethod.F90 delete mode 100644 src/modules/IntVector/src/IntVector_IOMethod.F90 delete mode 100644 src/modules/IntVector/src/IntVector_Method.F90 delete mode 100644 src/modules/IntVector/src/IntVector_SetMethod.F90 delete mode 100644 src/modules/IterationData/CMakeLists.txt delete mode 100644 src/modules/IterationData/src/IterationData_Method.F90 delete mode 100644 src/modules/Kdtree2/CMakeLists.txt delete mode 100644 src/modules/Kdtree2/src/Kd2PQueue_Module.F90 delete mode 100644 src/modules/Kdtree2/src/Kdtree2_Module.F90 delete mode 100644 src/modules/KeyValue/CMakeLists.txt delete mode 100644 src/modules/KeyValue/src/KeyValue_Method.F90 delete mode 100644 src/modules/LISInterface/CMakeLists.txt delete mode 100644 src/modules/LISInterface/src/LISBasic.F90 delete mode 100644 src/modules/LISInterface/src/LISInterface.F90 delete mode 100644 src/modules/LISInterface/src/LISParam.F90 delete mode 100644 src/modules/LISInterface/src/LISVector.F90 delete mode 100644 src/modules/Lapack/CMakeLists.txt delete mode 100644 src/modules/Lapack/src/GE_CompRoutineMethods.F90 delete mode 100644 src/modules/Lapack/src/GE_EigenValueMethods.F90 delete mode 100644 src/modules/Lapack/src/GE_LUMethods.F90 delete mode 100644 src/modules/Lapack/src/GE_Lapack_Method.F90 delete mode 100644 src/modules/Lapack/src/GE_LinearSolveMethods.F90 delete mode 100644 src/modules/Lapack/src/GE_SingularValueMethods.F90 delete mode 100644 src/modules/Lapack/src/Lapack_Method.F90 delete mode 100644 src/modules/Lapack/src/Sym_CompRoutineMethods.F90 delete mode 100644 src/modules/Lapack/src/Sym_EigenValueMethods.F90 delete mode 100644 src/modules/Lapack/src/Sym_LUMethods.F90 delete mode 100644 src/modules/Lapack/src/Sym_Lapack_Method.F90 delete mode 100644 src/modules/Lapack/src/Sym_LinearSolveMethods.F90 delete mode 100644 src/modules/Lapack/src/Sym_SingularValueMethods.F90 delete mode 100644 src/modules/LuaInterface/CMakeLists.txt delete mode 100644 src/modules/LuaInterface/src/LuaInterface.F90 delete mode 100644 src/modules/LuaInterface/src/No_LuaInterface.F90 delete mode 100644 src/modules/Macro/vectorclass.inc delete mode 100644 src/modules/MassMatrix/CMakeLists.txt delete mode 100644 src/modules/MassMatrix/src/MassMatrix_Method.F90 delete mode 100644 src/modules/MdEncode/CMakeLists.txt delete mode 100644 src/modules/MdEncode/src/MdEncode_Method.F90 delete mode 100644 src/modules/MetisInterface/CMakeLists.txt delete mode 100644 src/modules/MetisInterface/src/MetisInterface.F90 delete mode 100644 src/modules/MetisInterface/src/MetisInterface.inc delete mode 100644 src/modules/MultiIndices/CMakeLists.txt delete mode 100644 src/modules/MultiIndices/src/MultiIndices_Method.F90 delete mode 100644 src/modules/OpenMP/CMakeLists.txt delete mode 100644 src/modules/OpenMP/src/OpenMP_Method.F90 delete mode 100644 src/modules/PENF/CMakeLists.txt delete mode 100644 src/modules/PENF/LICENSE.gpl3.md delete mode 100644 src/modules/PENF/src/BCTON.inc delete mode 100644 src/modules/PENF/src/BSTR.inc delete mode 100644 src/modules/PENF/src/COMPACT_REAL_STRING.inc delete mode 100644 src/modules/PENF/src/CTOA.inc delete mode 100644 src/modules/PENF/src/STR.inc delete mode 100644 src/modules/PENF/src/STRZ.inc delete mode 100644 src/modules/PENF/src/STR_ASCII.inc delete mode 100644 src/modules/PENF/src/STR_UCS4.inc delete mode 100644 src/modules/PENF/src/penf.F90 delete mode 100644 src/modules/PENF/src/penf_b_size.F90 delete mode 100644 src/modules/PENF/src/penf_global_parameters_variables.F90 delete mode 100644 src/modules/PENF/src/penf_stringify.F90 delete mode 100644 src/modules/Polynomial/CMakeLists.txt delete mode 100644 src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/InterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/JacobiPolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/LagrangePolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/LegendrePolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/LineInterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/LobattoPolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/PolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/PrismInterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/PyramidInterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/RecursiveNodesUtility.F90 delete mode 100644 src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/TriangleInterpolationUtility.F90 delete mode 100644 src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 delete mode 100644 src/modules/QuadraturePoint/CMakeLists.txt delete mode 100755 src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 delete mode 100644 src/modules/Random/CMakeLists.txt delete mode 100644 src/modules/Random/src/Random_Method.F90 delete mode 100644 src/modules/Rank2Tensor/CMakeLists.txt delete mode 100644 src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 delete mode 100644 src/modules/RaylibInterface/CMakeLists.txt delete mode 100644 src/modules/RaylibInterface/src/Raylib.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibCamera.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibCheckMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibDrawMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibEnums.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibGenMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibGetMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibImageMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibIsMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibLoadMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibMath.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibSetMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibTypes.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 delete mode 100644 src/modules/RaylibInterface/src/RaylibUtil.F90 delete mode 100644 src/modules/RaylibInterface/src/__Raylib.F90 delete mode 100644 src/modules/RealMatrix/CMakeLists.txt delete mode 100644 src/modules/RealMatrix/src/RealMatrix_Method.F90 delete mode 100644 src/modules/RealVector/CMakeLists.txt delete mode 100644 src/modules/RealVector/src/RealVector_AddMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_AppendMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_AssignMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_Blas1Methods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_ComparisonMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_ConstructorMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_GetMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_GetValueMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_IOMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_Method.F90 delete mode 100644 src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_Norm2Methods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_SetMethods.F90 delete mode 100644 src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 delete mode 100644 src/modules/STConvectiveMatrix/CMakeLists.txt delete mode 100644 src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 delete mode 100644 src/modules/STConvectiveMatrix/src/del.inc delete mode 100644 src/modules/STDiffusionMatrix/CMakeLists.txt delete mode 100644 src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 delete mode 100644 src/modules/STForceVector/CMakeLists.txt delete mode 100644 src/modules/STForceVector/src/STForceVector_Method.F90 delete mode 100644 src/modules/STMassMatrix/CMakeLists.txt delete mode 100644 src/modules/STMassMatrix/src/STMassMatrix_Method.F90 delete mode 100644 src/modules/StiffnessMatrix/CMakeLists.txt delete mode 100644 src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 delete mode 100644 src/modules/String/CMakeLists.txt delete mode 100644 src/modules/String/src/String_Class.F90 delete mode 100644 src/modules/String/src/String_Method.F90 delete mode 100644 src/modules/SuperLUInterface/CMakeLists.txt delete mode 100644 src/modules/SuperLUInterface/src/SuperLUInterface.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_Enums.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_Types.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_Util_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsitrf_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 delete mode 100644 src/modules/SuperLUInterface/src/include/macros.inc delete mode 100644 src/modules/System/CMakeLists.txt delete mode 100755 src/modules/System/src/System_Method.F90 delete mode 100755 src/modules/System/src/System_Method.c delete mode 100644 src/modules/Test/CMakeLists.txt delete mode 100644 src/modules/Test/src/README.txt delete mode 100644 src/modules/Test/src/Test_Base.F90 delete mode 100644 src/modules/Test/src/Test_Is.F90 delete mode 100644 src/modules/Test/src/Test_Method.F90 delete mode 100644 src/modules/Test/src/Test_More.F90 delete mode 100644 src/modules/Test/src/Test_Planning.F90 delete mode 100644 src/modules/Test/src/is_i.inc delete mode 100644 src/modules/Test/src/is_r.inc delete mode 100644 src/modules/TriangleInterface/CMakeLists.txt delete mode 100644 src/modules/TriangleInterface/src/TriangleInterface.F90 delete mode 100644 src/modules/TriangleInterface/src/report.c delete mode 100644 src/modules/TriangleInterface/src/triangle.c delete mode 100644 src/modules/TriangleInterface/src/triangle.h delete mode 100644 src/modules/Utility/CMakeLists.txt delete mode 100644 src/modules/Utility/src/AppendUtility.F90 delete mode 100644 src/modules/Utility/src/ApproxUtility.F90 delete mode 100644 src/modules/Utility/src/ArangeUtility.F90 delete mode 100644 src/modules/Utility/src/AssertUtility.F90 delete mode 100644 src/modules/Utility/src/BinomUtility.F90 delete mode 100644 src/modules/Utility/src/ContractionUtility.F90 delete mode 100644 src/modules/Utility/src/ConvertUtility.F90 delete mode 100644 src/modules/Utility/src/DiagUtility.F90 delete mode 100644 src/modules/Utility/src/EigenUtility.F90 delete mode 100644 src/modules/Utility/src/EyeUtility.F90 delete mode 100644 src/modules/Utility/src/GridPointUtility.F90 delete mode 100644 src/modules/Utility/src/HashingUtility.F90 delete mode 100644 src/modules/Utility/src/HeadUtility.F90 delete mode 100644 src/modules/Utility/src/InputUtility.F90 delete mode 100644 src/modules/Utility/src/IntegerUtility.F90 delete mode 100644 src/modules/Utility/src/InvUtility.F90 delete mode 100644 src/modules/Utility/src/LinearAlgebraUtility.F90 delete mode 100644 src/modules/Utility/src/MappingUtility.F90 delete mode 100644 src/modules/Utility/src/MatmulUtility.F90 delete mode 100644 src/modules/Utility/src/MedianUtility.F90 delete mode 100644 src/modules/Utility/src/MiscUtility.F90 delete mode 100644 src/modules/Utility/src/OnesUtility.F90 delete mode 100644 src/modules/Utility/src/PartitionUtility.F90 delete mode 100644 src/modules/Utility/src/ProductUtility.F90 delete mode 100644 src/modules/Utility/src/PushPopUtility.F90 delete mode 100644 src/modules/Utility/src/ReallocateUtility.F90 delete mode 100644 src/modules/Utility/src/SafeSizeUtility.F90 delete mode 100644 src/modules/Utility/src/SortUtility.F90 delete mode 100644 src/modules/Utility/src/SplitUtility.F90 delete mode 100644 src/modules/Utility/src/StringUtility.F90 delete mode 100644 src/modules/Utility/src/SwapUtility.F90 delete mode 100644 src/modules/Utility/src/SymUtility.F90 delete mode 100644 src/modules/Utility/src/TailUtility.F90 delete mode 100644 src/modules/Utility/src/TriagUtility.F90 delete mode 100755 src/modules/Utility/src/Utility.F90 delete mode 100644 src/modules/Utility/src/ZerosUtility.F90 delete mode 100644 src/modules/Utility/src/refs/mathPlantFEM.inc delete mode 100644 src/modules/Vector3D/CMakeLists.txt delete mode 100644 src/modules/Vector3D/src/Vector3D_Method.F90 delete mode 100644 src/modules/VoigtRank2Tensor/CMakeLists.txt delete mode 100644 src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 delete mode 100644 src/modules/easifemBase/CMakeLists.txt delete mode 100644 src/modules/easifemBase/src/easifemBase.F90 delete mode 100644 src/submodules/ARPACK/CMakeLists.txt delete mode 100644 src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 delete mode 100644 src/submodules/BoundingBox/CMakeLists.txt delete mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 delete mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 delete mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 delete mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 delete mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 delete mode 100644 src/submodules/CMakeLists.txt delete mode 100644 src/submodules/CSRMatrix/CMakeLists.txt delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 delete mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 delete mode 100644 src/submodules/CSRSparsity/CMakeLists.txt delete mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 delete mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 delete mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 delete mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 delete mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 delete mode 100644 src/submodules/ConvectiveMatrix/CMakeLists.txt delete mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part delete mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part delete mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part delete mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part delete mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part delete mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 delete mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md delete mode 100644 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_1.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_10.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_2.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_3.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_4.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_5.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_6.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_7.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_8.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/CM_9.inc delete mode 100644 src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 delete mode 100644 src/submodules/DOF/CMakeLists.txt delete mode 100644 src/submodules/DOF/src/DOF_AddMethods@Methods.F90 delete mode 100644 src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 delete mode 100644 src/submodules/DOF/src/DOF_GetMethods@Methods.F90 delete mode 100644 src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 delete mode 100644 src/submodules/DOF/src/DOF_IOMethods@Methods.F90 delete mode 100644 src/submodules/DOF/src/DOF_SetMethods@Methods.F90 delete mode 100644 src/submodules/DiffusionMatrix/CMakeLists.txt delete mode 100644 src/submodules/DiffusionMatrix/src/DM_1.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_10.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_2.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_3.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_4.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_5.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_6.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_7.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_8.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DM_9.inc delete mode 100644 src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 delete mode 100644 src/submodules/ElasticNitscheMatrix/CMakeLists.txt delete mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 delete mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 delete mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 delete mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 delete mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 delete mode 100644 src/submodules/ElemshapeData/CMakeLists.txt delete mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 delete mode 100755 src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 delete mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 delete mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 delete mode 100644 src/submodules/FEMatrix/src/STCM/STCM_1.inc delete mode 100644 src/submodules/FEVariable/CMakeLists.txt delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 delete mode 100644 src/submodules/FEVariable/src/include/MatrixElemMethod.F90 delete mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 delete mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 delete mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 delete mode 100644 src/submodules/FEVariable/src/include/MatrixPower.F90 delete mode 100644 src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 delete mode 100644 src/submodules/FEVariable/src/include/RealOperatorScalar.F90 delete mode 100644 src/submodules/FEVariable/src/include/RealOperatorVector.F90 delete mode 100644 src/submodules/FEVariable/src/include/ScalarElemMethod.F90 delete mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 delete mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 delete mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 delete mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 delete mode 100644 src/submodules/FEVariable/src/include/ScalarPower.F90 delete mode 100644 src/submodules/FEVariable/src/include/VectorElemMethod.F90 delete mode 100644 src/submodules/FEVariable/src/include/VectorOperatorReal.F90 delete mode 100644 src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 delete mode 100644 src/submodules/FEVariable/src/include/VectorOperatorVector.F90 delete mode 100644 src/submodules/FEVariable/src/include/VectorPower.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_constant.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_constant2.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_space.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_space2.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_space_time.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_space_time2.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_time.F90 delete mode 100644 src/submodules/FEVariable/src/include/matrix_time2.F90 delete mode 100644 src/submodules/FEVariable/src/include/scalar_constant.F90 delete mode 100644 src/submodules/FEVariable/src/include/scalar_space.F90 delete mode 100644 src/submodules/FEVariable/src/include/scalar_space_time.F90 delete mode 100644 src/submodules/FEVariable/src/include/scalar_space_time2.F90 delete mode 100644 src/submodules/FEVariable/src/include/scalar_time.F90 delete mode 100644 src/submodules/FEVariable/src/include/vector_constant.F90 delete mode 100644 src/submodules/FEVariable/src/include/vector_space.F90 delete mode 100644 src/submodules/FEVariable/src/include/vector_space2.F90 delete mode 100644 src/submodules/FEVariable/src/include/vector_space_time.F90 delete mode 100644 src/submodules/FEVariable/src/include/vector_space_time2.F90 delete mode 100644 src/submodules/FEVariable/src/include/vector_time.F90 delete mode 100644 src/submodules/FEVariable/src/include/vector_time2.F90 delete mode 100644 src/submodules/FacetMatrix/CMakeLists.txt delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 delete mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 delete mode 100644 src/submodules/ForceVector/CMakeLists.txt delete mode 100644 src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/CMakeLists.txt delete mode 100644 src/submodules/Geometry/src/Line_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/Plane_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/Triangle_Method@Methods.F90 delete mode 100644 src/submodules/Geometry/src/inc/aux.inc delete mode 100644 src/submodules/Geometry/src/modified_burkardt.inc delete mode 100644 src/submodules/Hashing/CMakeLists.txt delete mode 100644 src/submodules/Hashing/src/Hashing32@fnvMethods.F90 delete mode 100644 src/submodules/Hashing/src/Hashing32@nmMethods.F90 delete mode 100644 src/submodules/Hashing/src/Hashing32@waterMethods.F90 delete mode 100644 src/submodules/Hashing/src/delme.F90 delete mode 100644 src/submodules/IndexValue/CMakeLists.txt delete mode 100644 src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 delete mode 100644 src/submodules/IntVector/CMakeLists.txt delete mode 100644 src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 delete mode 100644 src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 delete mode 100644 src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 delete mode 100644 src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 delete mode 100644 src/submodules/IntVector/src/IntVector_IOMethod@Methods.F90 delete mode 100644 src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 delete mode 100644 src/submodules/IntVector/src/include/intvec_get_10.inc delete mode 100644 src/submodules/IntVector/src/include/intvec_get_11.inc delete mode 100644 src/submodules/IntVector/src/include/intvec_get_12.inc delete mode 100644 src/submodules/IntVector/src/include/intvec_get_13.inc delete mode 100644 src/submodules/IterationData/CMakeLists.txt delete mode 100644 src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 delete mode 100644 src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 delete mode 100644 src/submodules/KeyValue/CMakeLists.txt delete mode 100644 src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 delete mode 100644 src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 delete mode 100644 src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 delete mode 100644 src/submodules/Lapack/CMakeLists.txt delete mode 100644 src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/GE_LUMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 delete mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 delete mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 delete mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 delete mode 100644 src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 delete mode 100644 src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 delete mode 100644 src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 delete mode 100644 src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 delete mode 100644 src/submodules/MassMatrix/CMakeLists.txt 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 delete mode 100644 src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 delete mode 100644 src/submodules/MdEncode/CMakeLists.txt delete mode 100644 src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 delete mode 100644 src/submodules/MdEncode/src/inc/MdEncode_2.inc delete mode 100644 src/submodules/MdEncode/src/inc/MdEncode_3.inc delete mode 100644 src/submodules/MdEncode/src/inc/MdEncode_3b.inc delete mode 100644 src/submodules/MdEncode/src/inc/MdEncode_6.inc delete mode 100644 src/submodules/MdEncode/src/inc/MdEncode_7.inc delete mode 100644 src/submodules/MultiIndices/CMakeLists.txt delete mode 100644 src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 delete mode 100644 src/submodules/OpenMP/CMakeLists.txt delete mode 100644 src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 delete mode 100644 src/submodules/Polynomial/CMakeLists.txt delete mode 100644 src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc delete mode 100644 src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc delete mode 100644 src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 delete mode 100644 src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 delete mode 100644 src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 delete mode 100644 src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 delete mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 delete mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 delete mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 delete mode 100644 src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_12.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc delete mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc delete mode 100644 src/submodules/QuadraturePoint/CMakeLists.txt delete mode 100755 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 delete mode 100755 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 delete mode 100644 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 delete mode 100644 src/submodules/Random/CMakeLists.txt delete mode 100644 src/submodules/Random/src/Random_Method@Methods.F90 delete mode 100644 src/submodules/Rank2Tensor/CMakeLists.txt delete mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 delete mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 delete mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 delete mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 delete mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 delete mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 delete mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 delete mode 100644 src/submodules/Rank2Tensor/src/matrix_exponential.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md delete mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Interface.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md delete mode 100755 src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Old_getCDash.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorInterface.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Display.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Interface.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/StressType.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/getStress.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part delete mode 100755 src/submodules/Rank2Tensor/src/old data/Tensor.F90 delete mode 100755 src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 delete mode 100644 src/submodules/RealMatrix/CMakeLists.txt delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 delete mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 delete mode 100644 src/submodules/RealVector/CMakeLists.txt delete mode 100644 src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 delete mode 100644 src/submodules/RealVector/src/Save_hdf5.F90 delete mode 100644 src/submodules/STConvectiveMatrix/CMakeLists.txt delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md delete mode 100644 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part delete mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_1.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_10.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_11.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_12.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_13.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_14.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_15.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_16.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_17.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_2.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_3.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_4.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_5.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_6.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_7.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_8.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STCM_9.inc delete mode 100644 src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 delete mode 100644 src/submodules/STDiffusionMatrix/CMakeLists.txt delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part delete mode 100644 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 delete mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_1.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_11.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_12.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_13.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_14.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_2.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_3.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_4.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_5.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_6.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_7.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDM_8.inc delete mode 100644 src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 delete mode 100755 src/submodules/STFextVector/Constructor.part delete mode 100755 src/submodules/STFextVector/FextVector_1.part delete mode 100755 src/submodules/STFextVector/FextVector_10.part delete mode 100755 src/submodules/STFextVector/FextVector_11.part delete mode 100755 src/submodules/STFextVector/FextVector_12.part delete mode 100755 src/submodules/STFextVector/FextVector_13.part delete mode 100755 src/submodules/STFextVector/FextVector_14.part delete mode 100755 src/submodules/STFextVector/FextVector_15.part delete mode 100755 src/submodules/STFextVector/FextVector_16.part delete mode 100755 src/submodules/STFextVector/FextVector_17.part delete mode 100755 src/submodules/STFextVector/FextVector_18.part delete mode 100755 src/submodules/STFextVector/FextVector_19.part delete mode 100755 src/submodules/STFextVector/FextVector_2.part delete mode 100755 src/submodules/STFextVector/FextVector_20.part delete mode 100755 src/submodules/STFextVector/FextVector_21.part delete mode 100755 src/submodules/STFextVector/FextVector_22.part delete mode 100755 src/submodules/STFextVector/FextVector_23.part delete mode 100755 src/submodules/STFextVector/FextVector_24.part delete mode 100755 src/submodules/STFextVector/FextVector_25.part delete mode 100755 src/submodules/STFextVector/FextVector_26.part delete mode 100755 src/submodules/STFextVector/FextVector_3.part delete mode 100755 src/submodules/STFextVector/FextVector_4.part delete mode 100755 src/submodules/STFextVector/FextVector_5.part delete mode 100755 src/submodules/STFextVector/FextVector_6.part delete mode 100755 src/submodules/STFextVector/FextVector_7.part delete mode 100755 src/submodules/STFextVector/FextVector_8.part delete mode 100755 src/submodules/STFextVector/FextVector_9.part delete mode 100755 src/submodules/STFextVector/MdFiles/STFextVector_Class.md delete mode 100644 src/submodules/STFextVector/MethodNames.part delete mode 100755 src/submodules/STFextVector/STFextVector_Class.f90 delete mode 100644 src/submodules/STFextVector/delme.f90 delete mode 100755 src/submodules/STFintVector/Constructor.part delete mode 100755 src/submodules/STFintVector/FintVector_1.part delete mode 100755 src/submodules/STFintVector/FintVector_2.part delete mode 100755 src/submodules/STFintVector/FintVector_3.part delete mode 100755 src/submodules/STFintVector/FintVector_4.part delete mode 100755 src/submodules/STFintVector/FintVector_5.part delete mode 100755 src/submodules/STFintVector/FintVector_6.part delete mode 100755 src/submodules/STFintVector/FintVector_7.part delete mode 100755 src/submodules/STFintVector/FintVector_8.part delete mode 100755 src/submodules/STFintVector/MdFiles/STFintVector_Class.md delete mode 100644 src/submodules/STFintVector/MethodNames.part delete mode 100755 src/submodules/STFintVector/STFintVector_Class.f90 delete mode 100644 src/submodules/STForceVector/CMakeLists.txt delete mode 100644 src/submodules/STForceVector/src/STFV_1.inc delete mode 100644 src/submodules/STForceVector/src/STFV_10.inc delete mode 100644 src/submodules/STForceVector/src/STFV_11.inc delete mode 100644 src/submodules/STForceVector/src/STFV_12.inc delete mode 100644 src/submodules/STForceVector/src/STFV_13.inc delete mode 100644 src/submodules/STForceVector/src/STFV_14.inc delete mode 100644 src/submodules/STForceVector/src/STFV_15.inc delete mode 100644 src/submodules/STForceVector/src/STFV_16.inc delete mode 100644 src/submodules/STForceVector/src/STFV_17.inc delete mode 100644 src/submodules/STForceVector/src/STFV_18.inc delete mode 100644 src/submodules/STForceVector/src/STFV_19.inc delete mode 100644 src/submodules/STForceVector/src/STFV_2.inc delete mode 100644 src/submodules/STForceVector/src/STFV_20.inc delete mode 100644 src/submodules/STForceVector/src/STFV_21.inc delete mode 100644 src/submodules/STForceVector/src/STFV_3.inc delete mode 100644 src/submodules/STForceVector/src/STFV_4.inc delete mode 100644 src/submodules/STForceVector/src/STFV_5.inc delete mode 100644 src/submodules/STForceVector/src/STFV_6.inc delete mode 100644 src/submodules/STForceVector/src/STFV_7.inc delete mode 100644 src/submodules/STForceVector/src/STFV_8.inc delete mode 100644 src/submodules/STForceVector/src/STFV_9.inc delete mode 100644 src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 delete mode 100644 src/submodules/STMassMatrix/CMakeLists.txt delete mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part delete mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part delete mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part delete mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part delete mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part delete mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part delete mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md delete mode 100644 src/submodules/STMassMatrix/src/STMM_1.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_10.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_10a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_10b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_10c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_10d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_11.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_11a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_11b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_11c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_11d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_12.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_12a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_12b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_12c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_12d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_13.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_14.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_15.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_16.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_17.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_17_20.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_18.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_19.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_2.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_20.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_21.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_21a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_21b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_21c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_21d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_22.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_22a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_22b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_22c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_22d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_23.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_23a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_23b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_23c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_23d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_24.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_24a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_24b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_24c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_24d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_25.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_26.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_27.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_28.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_3.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_4.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_5.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_6.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_7.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_8.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_9.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_9a.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_9b.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_9c.inc delete mode 100644 src/submodules/STMassMatrix/src/STMM_9d.inc delete mode 100644 src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 delete mode 100755 src/submodules/STStiffnessMatrix/Constructor.part delete mode 100755 src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md delete mode 100644 src/submodules/STStiffnessMatrix/MethodNames.part delete mode 100755 src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part delete mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/Constructor.part delete mode 100644 src/submodules/ST_Tau_SUPG_RGN/MdFiles/._ST_TAU_SUPG_RGN_Class.md delete mode 100644 src/submodules/ST_Tau_SUPG_RGN/MdFiles/ST_TAU_SUPG_RGN_Class.md delete mode 100644 src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part delete mode 100644 src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part delete mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part delete mode 100644 src/submodules/StiffnessMatrix/CMakeLists.txt delete mode 100644 src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 delete mode 100644 src/submodules/TriangleInterface/CMakeLists.txt delete mode 100644 src/submodules/TriangleInterface/src/TriangleInterface@Methods.F90 delete mode 100644 src/submodules/TriangleInterface/src/definemacro.h delete mode 100644 src/submodules/TriangleInterface/src/undefinemacro.h delete mode 100644 src/submodules/Utility/CMakeLists.txt delete mode 100644 src/submodules/Utility/src/Append/Append_1.inc delete mode 100644 src/submodules/Utility/src/Append/Append_1cd.inc delete mode 100644 src/submodules/Utility/src/Append/Append_2.inc delete mode 100644 src/submodules/Utility/src/Append/Append_2abcd.inc delete mode 100644 src/submodules/Utility/src/Append/Append_2cd.inc delete mode 100644 src/submodules/Utility/src/Append/Append_3.inc delete mode 100644 src/submodules/Utility/src/Append/Append_3cd.inc delete mode 100644 src/submodules/Utility/src/Append/Append_4.inc delete mode 100644 src/submodules/Utility/src/Append/Append_4cd.inc delete mode 100644 src/submodules/Utility/src/AppendUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/ApproxUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/ArangeUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/AssertUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/BinomUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_1.inc delete mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_2.inc delete mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_3.inc delete mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_4.inc delete mode 100644 src/submodules/Utility/src/ContractionUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/ConvertUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Diag/SetDiag.inc delete mode 100644 src/submodules/Utility/src/Diag/SetTriDiag.inc delete mode 100644 src/submodules/Utility/src/Diag/Tridiag.inc delete mode 100644 src/submodules/Utility/src/DiagUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/EigenUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Expand/Expand.inc delete mode 100644 src/submodules/Utility/src/Expand/ExpandMatrix.inc delete mode 100644 src/submodules/Utility/src/EyeUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/GridPointUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/HashingUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/HeadUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/HeapSort/ArgHeapSort.inc delete mode 100644 src/submodules/Utility/src/HeapSort/HeapSort.inc delete mode 100644 src/submodules/Utility/src/In/In_1.inc delete mode 100644 src/submodules/Utility/src/In/IsIn_1.inc delete mode 100644 src/submodules/Utility/src/Input/Input1.inc delete mode 100644 src/submodules/Utility/src/InputUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc delete mode 100644 src/submodules/Utility/src/InsertionSort/InsertionSort.inc delete mode 100644 src/submodules/Utility/src/IntegerUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Intersection/Intersection.inc delete mode 100644 src/submodules/Utility/src/IntroSort/ArgIntroSort.inc delete mode 100644 src/submodules/Utility/src/IntroSort/IntroSort.inc delete mode 100644 src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc delete mode 100644 src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc delete mode 100644 src/submodules/Utility/src/InvUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/MappingUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/MatmulUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Median/ArgMedian.inc delete mode 100644 src/submodules/Utility/src/Median/Median.inc delete mode 100644 src/submodules/Utility/src/MedianUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/MiscUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/OnesUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Partition/ArgPartition.inc delete mode 100644 src/submodules/Utility/src/Partition/Partition.inc delete mode 100644 src/submodules/Utility/src/PartitionUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/ProductUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/PushPop/Pop_Scalar.inc delete mode 100644 src/submodules/Utility/src/PushPop/Push_Scalar.inc delete mode 100644 src/submodules/Utility/src/PushPopUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc delete mode 100644 src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc delete mode 100644 src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc delete mode 100644 src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc delete mode 100644 src/submodules/Utility/src/ReallocateUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc delete mode 100644 src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc delete mode 100644 src/submodules/Utility/src/Repeat/Repeat_1.inc delete mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_1.inc delete mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_2.inc delete mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_3.inc delete mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_4.inc delete mode 100644 src/submodules/Utility/src/SafeSizeUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Sort/ArgSort.inc delete mode 100644 src/submodules/Utility/src/Sort/Sort.inc delete mode 100644 src/submodules/Utility/src/SortUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/SplitUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/StringUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/SwapUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Sym/GetSym.inc delete mode 100644 src/submodules/Utility/src/Sym/Sym.inc delete mode 100644 src/submodules/Utility/src/SymUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/TailUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/Triag/GetTril1.inc delete mode 100644 src/submodules/Utility/src/Triag/GetTril2.inc delete mode 100644 src/submodules/Utility/src/Triag/GetTriu1.inc delete mode 100644 src/submodules/Utility/src/Triag/GetTriu2.inc delete mode 100644 src/submodules/Utility/src/Triag/SetTril1.inc delete mode 100644 src/submodules/Utility/src/Triag/SetTril2.inc delete mode 100644 src/submodules/Utility/src/Triag/SetTril3.inc delete mode 100644 src/submodules/Utility/src/Triag/SetTriu1.inc delete mode 100644 src/submodules/Utility/src/Triag/SetTriu2.inc delete mode 100644 src/submodules/Utility/src/Triag/SetTriu3.inc delete mode 100644 src/submodules/Utility/src/Triag/Tril1.inc delete mode 100644 src/submodules/Utility/src/Triag/Tril2.inc delete mode 100644 src/submodules/Utility/src/Triag/Triu1.inc delete mode 100644 src/submodules/Utility/src/Triag/Triu2.inc delete mode 100644 src/submodules/Utility/src/TriagUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/ZerosUtility@Methods.F90 delete mode 100644 src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc delete mode 100644 src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc delete mode 100755 src/submodules/Vector/ToDo/VectorOperations.part delete mode 100644 src/submodules/Vector3D/CMakeLists.txt delete mode 100644 src/submodules/Vector3D/Vector3D_Method@Misc.F90 delete mode 100644 src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 delete mode 100644 src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 delete mode 100644 src/submodules/VoigtRank2Tensor/CMakeLists.txt delete mode 100644 src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 delete mode 100644 src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 diff --git a/.fortls b/.fortls deleted file mode 100644 index 20162a203..000000000 --- a/.fortls +++ /dev/null @@ -1,28 +0,0 @@ -{ - "source_dirs": [ - "src/**" - ], - "excl_suffixes": [ - "_skip.F90", - ".bk", - ".ignore" - ], - "pp_suffixes": [ - ".F90", - ".inc", - ".part", - ".f90" - ], - "pp_defs": {}, - "include_dirs": [], - "ext_source_dirs": [], - "lowercase_intrinsics": false, - "debug_log": false, - "disable_diagnostics": false, - "sort_keywords": false, - "use_signature_help": true, - "hover_signature": true, - "hover_language": "fortran", - "enable_code_actions": false, - "symbol_skip_mem": false -} diff --git a/.gitattributes b/.gitattributes deleted file mode 100644 index dfe077042..000000000 --- a/.gitattributes +++ /dev/null @@ -1,2 +0,0 @@ -# Auto detect text files and perform LF normalization -* text=auto diff --git a/.gitconfig b/.gitconfig deleted file mode 100644 index c65769c48..000000000 --- a/.gitconfig +++ /dev/null @@ -1,5 +0,0 @@ -# This is Git's per-user configuration file. -[user] -# Please adapt and uncomment the following lines: - name = Vikas Sharma - email = vickysharma0812@gmail.com diff --git a/.github/.pr-labeler.yml b/.github/.pr-labeler.yml deleted file mode 100644 index c0922df6a..000000000 --- a/.github/.pr-labeler.yml +++ /dev/null @@ -1,4 +0,0 @@ -utility: utility/* -sparsematrix: sparsematrix/* -working: ['working/*', 'work/*'] -linalg: ['sparsematrix/*', 'sparse/*', 'monolish/*', 'blas/*', 'lapack/*'] diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md deleted file mode 100644 index 9f425977c..000000000 --- a/.github/ISSUE_TEMPLATE/bug_report.md +++ /dev/null @@ -1,39 +0,0 @@ ---- -name: Bug report -about: Create a report to help us improve -title: '' -labels: 'wishlist' - 'inspiration' -assignees: '' - ---- - -**Describe the bug** -A clear and concise description of what the bug is. - -**To Reproduce** -Steps to reproduce the behavior: -1. Go to '...' -2. Click on '....' -3. Scroll down to '....' -4. See error - -**Expected behavior** -A clear and concise description of what you expected to happen. - -**Screenshots** -If applicable, add screenshots to help explain your problem. - -**Desktop (please complete the following information):** - - OS: [e.g. iOS] - - Browser [e.g. chrome, safari] - - Version [e.g. 22] - -**Smartphone (please complete the following information):** - - Device: [e.g. iPhone6] - - OS: [e.g. iOS8.1] - - Browser [e.g. stock browser, safari] - - Version [e.g. 22] - -**Additional context** -Add any other context about the problem here. diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md deleted file mode 100644 index 8f3bcfb53..000000000 --- a/.github/ISSUE_TEMPLATE/feature_request.md +++ /dev/null @@ -1,21 +0,0 @@ ---- -name: Feature request -about: Suggest an idea for this project -title: '' -labels: 'wishlist' - 'inspiration' -assignees: '' - ---- - -**Is your feature request related to a problem? Please describe.** -A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] - -**Describe the solution you'd like** -A clear and concise description of what you want to happen. - -**Describe alternatives you've considered** -A clear and concise description of any alternative solutions or features you've considered. - -**Additional context** -Add any other context or screenshots about the feature request here. diff --git a/.github/ISSUE_TEMPLATE/inspiration.md b/.github/ISSUE_TEMPLATE/inspiration.md deleted file mode 100644 index 159dad60b..000000000 --- a/.github/ISSUE_TEMPLATE/inspiration.md +++ /dev/null @@ -1,23 +0,0 @@ ---- -name: Inspiration -about: Tell us about other projects so that we can use it in easifemBase -title: "[Inspiration]" -labels: 'Inspiration' - 'wishlist' -assignees: vickysharma0812 - ---- - -# EASIFEM-INSPIRATION - -## Project name - -### Developer - -### Age - -### Field of application - -### Activity status - -## Why should it be covered in easifemBase diff --git a/.github/workflows/pr-labeler.yml b/.github/workflows/pr-labeler.yml deleted file mode 100644 index 1bb104852..000000000 --- a/.github/workflows/pr-labeler.yml +++ /dev/null @@ -1,18 +0,0 @@ -name: PR Labeler -on: - pull_request: - types: [opened] - -jobs: - pr-labeler: - runs-on: ubuntu-latest - steps: - - uses: TimonVS/pr-labeler-action@v3 - with: - configuration-path: .github/pr-labeler.yml # optional, .github/pr-labeler.yml is the default value - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - - -# Reference -# https://github.com/marketplace/actions/pr-labeler \ No newline at end of file diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 7d5481641..000000000 --- a/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# ignore following extesions -# added by vikas -# 2-Dec-2018 -*.a -*.mod -*.smod -*.o -*.out -*.i90 -*.if90 -*.DS_Store -*.cache -*.prj -*.drawio -*.log -*.pdf -vscode-settings -docs/ -media/ -*/build/ -build/ -src/build/ -src/modules/build/ -src/submodules/build/ -_packages/ -compile_commands.json -compile_commands.json -neovim.json -selected diff --git a/.vscode/settings.json b/.vscode/settings.json deleted file mode 100644 index 8605764fb..000000000 --- a/.vscode/settings.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "C_Cpp.default.configurationProvider": "ms-vscode.cmake-tools", - "cmake.buildDirectory": "/home/vikassharma/temp/easifem-base/build", - "cmake.generator": "", - "cmake.installPrefix": "/home/vikassharma/.easifem/base", - "cmake.configureOnOpen": false -} \ No newline at end of file diff --git a/.vscode/tasks.json b/.vscode/tasks.json deleted file mode 100644 index ad530b010..000000000 --- a/.vscode/tasks.json +++ /dev/null @@ -1,112 +0,0 @@ -{ - "version": "2.0.0", - "tasks": [ - { - "label": "clean", - "type": "shell", - "command": "easifem", - "args": [ - "clean", - "base" - ], - "problemMatcher": [] - }, - { - "label": "build", - "type": "shell", - "command": "python3 ${workspaceFolder}/build.py", - "problemMatcher": [], - "group": { - "kind": "build", - "isDefault": true - } - }, - { - "label": "install", - "type": "shell", - "command": "python3 ${workspaceFolder}/install.py", - "problemMatcher": [], - "group": { - "kind": "build" - } - }, - { - "label": "dev", - "type": "shell", - "command": "gfortran", - "args": [ - "-DDEBUG_VER", - "-DAPPLE", - "-DASCII_SUPPORTED", - "-DDarwin_SYSTEM", - "-DUCS4_SUPPORTED", - "-DUSE_APPLE_NativeBLAS", - "-DUSE_ARPACK", - "-DUSE_BLAS95", - "-DUSE_CMAKE", - "-DUSE_FFTW", - "-DUSE_Int32", - "-DUSE_LAPACK95", - "-DUSE_LIS", - "-DUSE_NativeBLAS", - "-DUSE_OpenMP", - "-DUSE_PLPLOT", - "-DUSE_Real64", - "-DUSE_SuperLU", - "-D_ASCII_SUPPORTED", - "-D_R16P", - "-D_UCS4_SUPPORTED", - "-DeasifemBase_EXPORTS", - "-I/opt/homebrew/include", - "-I/opt/homebrew/Cellar/plplot/5.15.0_4/lib/fortran/modules/plplot", - "-I/Users/easifem/.easifem/install/easifem/extpkgs/include/arpack", - "-I/Users/easifem/.easifem/install/easifem/extpkgs/include", - "-I/Users/easifem/.easifem/install/easifem/base/include", - "-J/Users/easifem/.easifem/ide/include", - "-ffree-form", - "-ffree-line-length-none", - "-std=f2018", - "-fimplicit-none", - "-Waliasing", - "-Wall", - "-Wampersand", - "-Warray-bounds", - "-Wc-binding-type", - "-Wcharacter-truncation", - "-Wconversion", - "-Wdo-subscript", - "-Wfunction-elimination", - "-Wimplicit-interface", - "-Wimplicit-procedure", - "-Wintrinsic-shadow", - "-Wuse-without-only", - "-Wintrinsics-std", - "-Wline-truncation", - "-Wno-align-commons", - "-Wno-overwrite-recursive", - "-Wno-tabs", - "-Wreal-q-constant", - "-Wsurprising", - "-Wunderflow", - "-Wunused-parameter", - "-Wrealloc-lhs", - "-Wrealloc-lhs-all", - "-Wtarget-lifetime", - "-pedantic", - "-pedantic-errors", - "-c", - "${file}", - "-o", - "/Users/easifem/.easifem/ide/include/${fileBasenameNoExtension}.F90.o" - ], - "options": { - "cwd": "${fileDirname}" - }, - "problemMatcher": "$gcc", - "group": { - "kind": "build", - "isDefault": true - } - } - ] -} diff --git a/CMakeLists.txt b/CMakeLists.txt deleted file mode 100644 index d5bd3362b..000000000 --- a/CMakeLists.txt +++ /dev/null @@ -1,334 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -cmake_minimum_required(VERSION 3.28.0 FATAL_ERROR) - -set(PROJECT_NAME "easifemBase") -project(${PROJECT_NAME}) - -enable_language(C Fortran CXX) - -set(VERSION_MAJOR "24") -set(VERSION_MINOR "4") -set(VERSION_BugFix "5") - -set(PROJECT_VERSION ${VERSION_MAJOR}.${VERSION_MINOR}.${VERSION_BugFix}) - -set(CMAKE_PROJECT_DESCRIPTION - "${PROJECT_NAME} is part of EASIFEM platform. - EASIFEM: Expandable and Scalable Infrastructure for Finite Element Methods. - ") - -set(CMAKE_PROJECT_HOMEPAGE_URL "https://www.easifem.com") - -set(TARGETS_EXPORT_NAME "${PROJECT_NAME}Targets") - -set(namespace "${PROJECT_NAME}") - -include(CMakePrintHelpers) -include(FortranCInterface) - -FortranCInterface_VERIFY() - -list(APPEND TARGET_COMPILE_DEF "-DUSE_CMAKE") - -# find my cmake modules here... -list(APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) - -# check error -if(" ${CMAKE_CURRENT_SOURCE_DIR}" STREQUAL " ${CMAKE_CURRENT_BINARY_DIR}") - message( - FATAL_ERROR - "[ERROR] :: Build directory and Source directory cannot be same.") -endif() - -# make directories - -include(GNUInstallDirs) - -set(CMAKE_Fortran_MODULE_DIRECTORY - ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_INCLUDEDIR}) - -set(CMAKE_LIBRARY_OUTPUT_DIRECTORY - ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_LIBDIR}) - -set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY - ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_LIBDIR}) - -set(CMAKE_RUNTIME_OUTPUT_DIRECTORY - ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_BINDIR}) - -set(INSTALL_LIBDIR - ${CMAKE_INSTALL_LIBDIR} - CACHE PATH "Installation location of lib") - -set(INSTALL_INCLUDEDIR - ${CMAKE_INSTALL_INCLUDEDIR} - CACHE PATH "Installation location of module files") - -set(INSTALL_BINDIR - ${CMAKE_INSTALL_BINDIR} - CACHE PATH "Installation location of binary files") - -if(WIN32 AND NOT CYGWIN) - set(DEF_INSTALL_CMAKEDIR CMake) -else() - set(DEF_INSTALL_CMAKEDIR share/cmake/${PROJECT_NAME}) -endif() - -set(INSTALL_CMAKEDIR - ${DEF_INSTALL_CMAKEDIR} - CACHE PATH "Installation directory for CMake files") - -foreach(p LIB BIN INCLUDE CMAKE) - file(TO_NATIVE_PATH ${CMAKE_INSTALL_PREFIX}/${INSTALL_${p}DIR} _path) - message(STATUS "Installing ${p} componenets to ${_path}") -endforeach() - -option(BUILD_SHARED_LIBS "Build shared library" ON) - -if(BUILD_SHARED_LIBS) - message(STATUS "${PROJECT_NAME} will be built as a shared library.") - add_library(${PROJECT_NAME} SHARED "") - set_property(TARGET ${PROJECT_NAME} PROPERTY POSITION_INDEPENDENT_CODE TRUE) -else() - message(STATUS "${PROJECT_NAME} will be built as a static library.") - add_library(${PROJECT_NAME} STATIC "") -endif() - -# include(${PROJECT_SOURCE_DIR}/cmake/Compiler.cmake) - -message( - STATUS - "[INFO] :: Is the Fortran compiler loaded? ${CMAKE_Fortran_COMPILER_LOADED}" -) - -if(CMAKE_Fortran_COMPILER_LOADED) - message(STATUS "[INFO] :: Fortran compiler: ${CMAKE_Fortran_COMPILER_ID}") - message( - STATUS - "[INFO] :: Fortran compiler version is: ${CMAKE_Fortran_COMPILER_VERSION}" - ) -endif() - -if(NOT CMAKE_BUILD_TYPE) - set(CMAKE_BUILD_TYPE - Release - CACHE STRING "Build type" FORCE) -endif() - -if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU" OR Fortran_COMPILER_NAME MATCHES - "gfortran*") - - list( - APPEND - FORTRAN_FLAGS - "-ffree-form" - "-ffree-line-length-none" - "-std=f2018" - "-fimplicit-none" - "-fno-range-check") - - list(APPEND FORTRAN_FLAGS_RELEASE "-O3") - - if(APPLE) - list( - APPEND - FORTRAN_FLAGS_DEBUG - "-fbounds-check" - "-g" - "-fbacktrace" - "-Wextra" - "-Wall" - # "-fprofile-arcs" - "-ftest-coverage" - "-Wimplicit-interface") - - else() - list( - APPEND - FORTRAN_FLAGS_DEBUG - "-fbounds-check" - "-g" - "-fbacktrace" - "-Wextra" - "-Wall" - # "-fprofile-arcs" - "-ftest-coverage" - "-Wimplicit-interface") - endif() - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel" OR Fortran_COMPILER_NAME - MATCHES "ifort*") - list(APPEND FORTRAN_FLAGS "-r8" "-W1") - list(APPEND FORTRAN_FLAGS_RELEASE "-O3") - list( - APPEND - FORTRAN_FLAGS_DEBUG - "-O0" - "-traceback" - "-g" - "-debug all" - "-check all" - "-ftrapuv" - "-warn" - "nointerfaces") - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL "XL" OR Fortran_COMPILER_NAME - MATCHES "xlf*") - - list(APPEND FORTRAN_FLAGS "-q64" "-qrealsize=8" "-qsuffix=f=f90:cpp=f90") - list(APPEND FORTRAN_FLAGS_RELEASE "-O3" "-qstrict") - list(APPEND FORTRAN_FLAGS_DEBUG "-O0" "-g" "-qfullpath" "-qkeepparm") - -else() - message(ERROR "[ERROR] :: No optimized Fortran compiler flags are known") -endif() - -cmake_print_variables(FORTRAN_FLAGS) -cmake_print_variables(FORTRAN_FLAGS_RELEASE) -cmake_print_variables(FORTRAN_FLAGS_DEBUG) - -target_compile_options( - ${PROJECT_NAME} - PRIVATE ${TARGET_COMPILE_OPT} ${FORTRAN_FLAGS} - "$<$:${FORTRAN_FLAGS_DEBUG}>" - "$<$:${FORTRAN_FLAGS_RELEASE}>") - -target_include_directories( - ${PROJECT_NAME} - PUBLIC $ - $ - # "${EASIFEM_EXTPKGS}/include" -) - -# target properties -set_target_properties( - ${PROJECT_NAME} - PROPERTIES POSITION_INDEPENDENT_CODE 1 - SOVERSION ${VERSION_MAJOR} - OUTPUT_NAME ${PROJECT_NAME} - LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - MACOSX_RPATH ON - WINDOWS_EXPORT_ALL_SYMBOLS ON) - -# some options for easifem -option(USE_REAL32 OFF) -option(USE_REAL64 ON) - -if(USE_REAL32) - list(APPEND TARGET_COMPILE_DEF "-DUSE_Real32") -endif() - -if(USE_REAL64) - list(APPEND TARGET_COMPILE_DEF "-DUSE_Real64") -endif() - -option(USE_INT32 ON) -if(USE_INT32) - list(APPEND TARGET_COMPILE_DEF "-DUSE_Int32") -endif() - -option(USE_INT64 OFF) -if(USE_INT64) - list(APPEND TARGET_COMPILE_DEF "-DUSE_Int64") -endif() - -list(APPEND TARGET_COMPILE_DEF "-D${CMAKE_HOST_SYSTEM_NAME}_SYSTEM") - -# DEFINE DEBUG -if(${CMAKE_BUILD_TYPE} STREQUAL "Debug") - list(APPEND TARGET_COMPILE_DEF "-DDEBUG_VER") -endif() - -option(USE_COLORDISP ON) -if(USE_COLORDISP) - list(APPEND TARGET_COMPILE_DEF "-DCOLOR_DISP") -endif() - -# include(${PROJECT_SOURCE_DIR}/cmake/install.cmake) Installation -install( - DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY} - DESTINATION "./" - COMPONENT "${PROJECT_NAME}") - -install( - EXPORT ${TARGETS_EXPORT_NAME} - FILE "${TARGETS_EXPORT_NAME}.cmake" - NAMESPACE ${namespace}:: - DESTINATION ${INSTALL_CMAKEDIR} - COMPONENT "${PROJECT_NAME}") - -include(CMakePackageConfigHelpers) - -write_basic_package_version_file( - "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}ConfigVersion.cmake" - VERSION "${PROJECT_VERSION}" - COMPATIBILITY AnyNewerVersion) - -configure_package_config_file( - ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Config.cmake.in - ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}Config.cmake - INSTALL_DESTINATION ${INSTALL_CMAKEDIR} - PATH_VARS INSTALL_INCLUDEDIR) - -install( - FILES "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}Config.cmake" - "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}ConfigVersion.cmake" - DESTINATION ${INSTALL_CMAKEDIR} - COMPONENT "${PROJECT_NAME}-dev") - -# Find external dependency of the project FIXME: -if(NOT CMAKE_PREFIX_PATH) - list(APPEND CMAKE_PREFIX_PATH "$ENV{EASIFEM_EXTPKGS}") -endif() - -include(${PROJECT_SOURCE_DIR}/cmake/addRaylib.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addOpenBLAS.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addLapack95.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addSparsekit.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addToml.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addOpenMP.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addSuperLU.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addLIS.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addMetis.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addARPACK.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addPLPLOT.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addFFTW.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addGTKFortran.cmake) -include(${PROJECT_SOURCE_DIR}/cmake/addLua.cmake) - -# Add source files -include(src/modules/CMakeLists.txt) -include(src/submodules/CMakeLists.txt) - -# this should be in the end. -target_compile_definitions(${PROJECT_NAME} PUBLIC ${TARGET_COMPILE_DEF}) -message(STATUS "[INFO] :: Compiler definition : ${TARGET_COMPILE_DEF}") - -install( - TARGETS ${PROJECT_NAME} ${C_PROJECTS} - EXPORT ${TARGETS_EXPORT_NAME} - COMPONENT "${PROJECT_NAME}" - ARCHIVE DESTINATION ${INSTALL_LIBDIR} - RUNTIME DESTINATION ${INSTALL_BINDIR} - LIBRARY DESTINATION ${INSTALL_LIBDIR}) - -include(${PROJECT_SOURCE_DIR}/cmake/packaging.cmake) diff --git a/CMakePresets.json b/CMakePresets.json deleted file mode 100644 index ac86cde6a..000000000 --- a/CMakePresets.json +++ /dev/null @@ -1,81 +0,0 @@ -{ - "version": 7, - "cmakeMinimumRequired": { - "major": 3, - "minor": 23, - "patch": 0 - }, - "configurePresets": [ - { - "name": "default", - "displayName": "Default Config", - "description": "Default build using Ninja generator", - "generator": "Ninja", - "binaryDir": "$env{EASIFEM_BUILD_DIR}/easifem/base/build/default/", - "installDir": "$env{EASIFEM_BASE}", - "cacheVariables": { - "CMAKE_BUILD_TYPE": { "type": "STRING", "value": "Debug" }, - "BUILD_SHARED_LIBS": { "type": "BOOL", "value": "ON" }, - "CMAKE_EXPORT_COMPILE_COMMANDS": { "type": "BOOL", "value": "ON" }, - "USE_OPENMP": { "type": "BOOL", "value": "ON" }, - "USE_PLPLOT": { "type": "BOOL", "value": "ON" }, - "USE_BLAS95": { "type": "BOOL", "value": "ON" }, - "USE_LAPACK95": { "type": "BOOL", "value": "ON" }, - "USE_FFTW": { "type": "BOOL", "value": "ON" }, - "USE_GTK": { "type": "BOOL", "value": "OFF" }, - "USE_ARPACK": { "type": "BOOL", "value": "ON" }, - "USE_PARPACK": { "type": "BOOL", "value": "OFF" }, - "USE_SUPERLU": { "type": "BOOL", "value": "ON" }, - "USE_LIS": { "type": "BOOL", "value": "ON" }, - "USE_METIS": { "type": "BOOL", "value": "ON" }, - "USE_LUA": { "type": "BOOL", "value": "ON" }, - "USE_Int32": { "type": "BOOL", "value": "ON" }, - "USE_Real64": { "type": "BOOL", "value": "ON" }, - "USE_COLORDISP": { "type": "BOOL", "value": "OFF" } - } - }, - { - "name": "neovim-debug", - "inherits": "default", - "displayName": "Neovim Debug Dev", - "description": "Default build using Ninja generator for dev in neovim", - "binaryDir": "/home/easifem/.easifem/build/easifem/base/neovim/debug" - }, - { - "name": "ninja-multi", - "inherits": "default", - "displayName": "Ninja Multi-Config", - "description": "Default build using Ninja Multi-Config generator", - "generator": "Ninja Multi-Config" - } - ], - "buildPresets": [ - { - "name": "default", - "displayName": "Default build", - "description": "Default build", - "configurePreset": "default" - }, - { - "name": "neovim-debug", - "displayName": "Neovim debug build", - "description": "Default build", - "configurePreset": "neovim-debug" - } - ], - "workflowPresets": [ - { - "name": "default", - "steps": [ - { - "type": "configure", - "name": "default" - }, - { - "type": "build", - "name": "default" - } - ] - } - ] -} diff --git a/FORDsetup.md b/FORDsetup.md deleted file mode 100644 index ffa9af860..000000000 --- a/FORDsetup.md +++ /dev/null @@ -1,45 +0,0 @@ ---- -project: easifemBase -summary: easifemBase is part of easifem library, which is a framework for Expandable And Scalable Infrastructure for Finite Element Methods. -project_download: https://github.com/vickysharma0812/easifem-base -project_github: https://github.com/vickysharma0812/easifem-base -project_website: https://www.easifem.com -license: gfdl -project_dir: ./src/modules/Utility -media_dir: ./media -page_dir: ./pages -output_dir: ${HOME}/temp/ford -exclude_dir: ./src/submodules/ - ./src/modules/BLAS95/ -author: Vikas Sharma -author_description: Graduate School of Agriculture, Kyoto University, - Kyoto, Japan -email: vickysharma0812@gmail.com -github: https://vickysharma0812.github.io/ -author_pic: ./media/vikas.png -twitter: https://twitter.com/vickysharma0812 -website: http://vikas.easifem.com -graph: false -source: false -display: public - protected - private -page: false -sort: alpha -coloured_edges: true -extra_filetypes: inc ! -print_creation_date: true -creation_date: %Y-%m-%d %H:%M %z -md_extensions: markdown.extensions.toc - markdown.extensions.smarty -predocmark_alt: > -predocmark: < -docmark_alt: * -docmark: ! -fpp_extensions: F90 -preprocesses: true ---- - -{!./README.md!} - - diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 049e2e019..000000000 --- a/LICENSE +++ /dev/null @@ -1,94 +0,0 @@ -EASIFEM, Expandable And Scalable Infrastructure for Finite Element Methods, -is a framework for implementing finite element methods in Modern Fortran. -easifemBase is a part of EASIFEM library. -Copyright(C) 2020-2023 -Vikas Sharma -Ph.D. (Kyoto University, Japan) -B. Tech. (IIT Bombay, India) -vickysharma0812@gmail.com -https://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 - -=========================================================================== - -EASIFEM depends upon following fortran-libraries. -It is worth noting that some of these libraries have been -modified by EASIFEM depending upon necessary needs. - -(1) PENF -PENF is developed by [Mr. Szaghi](https://github.com/szaghi). -This library tries to exploit code portability for modern (2003+) Fortran projects. -It is a pure Fortran library for achieving portable codes for modern Fortran projects. -It provides many number-to-string and vice-versa facilities. -[Read more](https://github.com/szaghi/PENF/tree/master/src) - -(2) BeFoR64 - -This library is also a fortran project of [Mr. Szaghi](https://github.com/szaghi). -It is for *base64* encoding/decoding for modern Fortran projects. -[Read more](https://github.com/szaghi/BeFoR64) - -(3) StringiFor - -This library is also a fortran project of [Mr. Szaghi](https://github.com/szaghi). -This library makes an attempt to define string data type for handling characters in an object oriented way. -[Read more](https://github.com/szaghi/StringiFor) - -(4)) FoXy - -This is a fortran library which is designed to handle XML files. -[Read more](https://github.com/Fortran-FOSS-Programmers/FoXy) - -(5) vtkFortran - -This fortran library handles IO with vtk files. -[Read more](https://github.com/szaghi/VTKFortran) - -(6) H5Fortran - -This fortran project, which is developed by [Michael Hirsch](https://github.com/scivision), can handle IO with hdf5 files. -[Read more](https://github.com/geospace-code/h5fortran.git). - -(7) OGPF -This is program creates an interface between modern fortran and gnuplot. -This is a useful library for visualising fortran data using gnuplot. [Read more](https://github.com/kookma/ogpf). -In easifem this is renamed as `Gnuplot_Method.F90`. - -(8) Sparsekit - -Sparsekit is a legacy fortran code written by the great [Yusef Saad](https://en.wikipedia.org/wiki/Yousef_Saad) for -peforming linear algebra with sparse matrices. [Read more](https://www-users.cs.umn.edu/~saad/software/SPARSKIT/). -Some of these programs have been rewritten from F77 to Modern fortran. - -(9) M_SYSTEM - -This is Fortran interface to C system interface. It is taken from . -The original name of the program has been changed from M_SYSTEM to System_Method. -This is to confirm to the coding sytles of easifem. - -(10) FACE - -Fortran ANSI Color. Source: - -(11) ExceptionHandlerType - -This is libray can handle exceptions in fortran. Source: . -This library is modified as per the needs. - -(12) Fortran-TestAnything - -It is a library for testing fortran program. Source : . -The original name of the program is changed from Test.F90 to Test_Method.F90 to confirm the coding standards of easifem. diff --git a/LICENSE.gpl3.md b/LICENSE.gpl3.md deleted file mode 100644 index 98ec59e7c..000000000 --- a/LICENSE.gpl3.md +++ /dev/null @@ -1,596 +0,0 @@ -GNU GENERAL PUBLIC LICENSE -========================== - -Version 3, 29 June 2007 - -Copyright © 2007 Free Software Foundation, Inc. <> - -Everyone is permitted to copy and distribute verbatim copies of this license -document, but changing it is not allowed. - -## Preamble - -The GNU General Public License is a free, copyleft license for software and other -kinds of works. - -The licenses for most software and other practical works are designed to take away -your freedom to share and change the works. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change all versions of a -program--to make sure it remains free software for all its users. We, the Free -Software Foundation, use the GNU General Public License for most of our software; it -applies also to any other work released this way by its authors. You can apply it to -your programs, too. - -When we speak of free software, we are referring to freedom, not price. Our General -Public Licenses are designed to make sure that you have the freedom to distribute -copies of free software (and charge for them if you wish), that you receive source -code or can get it if you want it, that you can change the software or use pieces of -it in new free programs, and that you know you can do these things. - -To protect your rights, we need to prevent others from denying you these rights or -asking you to surrender the rights. Therefore, you have certain responsibilities if -you distribute copies of the software, or if you modify it: responsibilities to -respect the freedom of others. - -For example, if you distribute copies of such a program, whether gratis or for a fee, -you must pass on to the recipients the same freedoms that you received. You must make -sure that they, too, receive or can get the source code. And you must show them these -terms so they know their rights. - -Developers that use the GNU GPL protect your rights with two steps: (1) assert -copyright on the software, and (2) offer you this License giving you legal permission -to copy, distribute and/or modify it. - -For the developers' and authors' protection, the GPL clearly explains that there is -no warranty for this free software. For both users' and authors' sake, the GPL -requires that modified versions be marked as changed, so that their problems will not -be attributed erroneously to authors of previous versions. - -Some devices are designed to deny users access to install or run modified versions of -the software inside them, although the manufacturer can do so. This is fundamentally -incompatible with the aim of protecting users' freedom to change the software. The -systematic pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we have designed -this version of the GPL to prohibit the practice for those products. If such problems -arise substantially in other domains, we stand ready to extend this provision to -those domains in future versions of the GPL, as needed to protect the freedom of -users. - -Finally, every program is threatened constantly by software patents. States should -not allow patents to restrict development and use of software on general-purpose -computers, but in those that do, we wish to avoid the special danger that patents -applied to a free program could make it effectively proprietary. To prevent this, the -GPL assures that patents cannot be used to render the program non-free. - -The precise terms and conditions for copying, distribution and modification follow. - -## TERMS AND CONDITIONS - -### 0. Definitions. - -“This License” refers to version 3 of the GNU General Public License. - -“Copyright” also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - -“The Program” refers to any copyrightable work licensed under this -License. Each licensee is addressed as “you”. “Licensees” and -“recipients” may be individuals or organizations. - -To “modify” a work means to copy from or adapt all or part of the work in -a fashion requiring copyright permission, other than the making of an exact copy. The -resulting work is called a “modified version” of the earlier work or a -work “based on” the earlier work. - -A “covered work” means either the unmodified Program or a work based on -the Program. - -To “propagate” a work means to do anything with it that, without -permission, would make you directly or secondarily liable for infringement under -applicable copyright law, except executing it on a computer or modifying a private -copy. Propagation includes copying, distribution (with or without modification), -making available to the public, and in some countries other activities as well. - -To “convey” a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through a computer -network, with no transfer of a copy, is not conveying. - -An interactive user interface displays “Appropriate Legal Notices” to the -extent that it includes a convenient and prominently visible feature that (1) -displays an appropriate copyright notice, and (2) tells the user that there is no -warranty for the work (except to the extent that warranties are provided), that -licensees may convey the work under this License, and how to view a copy of this -License. If the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - -### 1. Source Code. - -The “source code” for a work means the preferred form of the work for -making modifications to it. “object code” means any non-source form of a -work. - -A “Standard Interface” means an interface that either is an official -standard defined by a recognized standards body, or, in the case of interfaces -specified for a particular programming language, one that is widely used among -developers working in that language. - -The “System Libraries” of an executable work include anything, other than -the work as a whole, that (a) is included in the normal form of packaging a Major -Component, but which is not part of that Major Component, and (b) serves only to -enable use of the work with that Major Component, or to implement a Standard -Interface for which an implementation is available to the public in source code form. -A “Major Component”, in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system (if any) on which -the executable work runs, or a compiler used to produce the work, or an object code -interpreter used to run it. - -The “Corresponding Source” for a work in object code form means all the -source code needed to generate, install, and (for an executable work) run the object -code and to modify the work, including scripts to control those activities. However, -it does not include the work's System Libraries, or general-purpose tools or -generally available free programs which are used unmodified in performing those -activities but which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for the work, and -the source code for shared libraries and dynamically linked subprograms that the work -is specifically designed to require, such as by intimate data communication or -control flow between those subprograms and other parts of the work. - -The Corresponding Source need not include anything that users can regenerate -automatically from other parts of the Corresponding Source. - -The Corresponding Source for a work in source code form is that same work. - -### 2. Basic Permissions. - -All rights granted under this License are granted for the term of copyright on the -Program, and are irrevocable provided the stated conditions are met. This License -explicitly affirms your unlimited permission to run the unmodified Program. The -output from running a covered work is covered by this License only if the output, -given its content, constitutes a covered work. This License acknowledges your rights -of fair use or other equivalent, as provided by copyright law. - -You may make, run and propagate covered works that you do not convey, without -conditions so long as your license otherwise remains in force. You may convey covered -works to others for the sole purpose of having them make modifications exclusively -for you, or provide you with facilities for running those works, provided that you -comply with the terms of this License in conveying all material for which you do not -control copyright. Those thus making or running the covered works for you must do so -exclusively on your behalf, under your direction and control, on terms that prohibit -them from making any copies of your copyrighted material outside their relationship -with you. - -Conveying under any other circumstances is permitted solely under the conditions -stated below. Sublicensing is not allowed; section 10 makes it unnecessary. - -### 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - -No covered work shall be deemed part of an effective technological measure under any -applicable law fulfilling obligations under article 11 of the WIPO copyright treaty -adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention -of such measures. - -When you convey a covered work, you waive any legal power to forbid circumvention of -technological measures to the extent such circumvention is effected by exercising -rights under this License with respect to the covered work, and you disclaim any -intention to limit operation or modification of the work as a means of enforcing, -against the work's users, your or third parties' legal rights to forbid circumvention -of technological measures. - -### 4. Conveying Verbatim Copies. - -You may convey verbatim copies of the Program's source code as you receive it, in any -medium, provided that you conspicuously and appropriately publish on each copy an -appropriate copyright notice; keep intact all notices stating that this License and -any non-permissive terms added in accord with section 7 apply to the code; keep -intact all notices of the absence of any warranty; and give all recipients a copy of -this License along with the Program. - -You may charge any price or no price for each copy that you convey, and you may offer -support or warranty protection for a fee. - -### 5. Conveying Modified Source Versions. - -You may convey a work based on the Program, or the modifications to produce it from -the Program, in the form of source code under the terms of section 4, provided that -you also meet all of these conditions: - -* **a)** The work must carry prominent notices stating that you modified it, and giving a -relevant date. -* **b)** The work must carry prominent notices stating that it is released under this -License and any conditions added under section 7. This requirement modifies the -requirement in section 4 to “keep intact all notices”. -* **c)** You must license the entire work, as a whole, under this License to anyone who -comes into possession of a copy. This License will therefore apply, along with any -applicable section 7 additional terms, to the whole of the work, and all its parts, -regardless of how they are packaged. This License gives no permission to license the -work in any other way, but it does not invalidate such permission if you have -separately received it. -* **d)** If the work has interactive user interfaces, each must display Appropriate Legal -Notices; however, if the Program has interactive interfaces that do not display -Appropriate Legal Notices, your work need not make them do so. - -A compilation of a covered work with other separate and independent works, which are -not by their nature extensions of the covered work, and which are not combined with -it such as to form a larger program, in or on a volume of a storage or distribution -medium, is called an “aggregate” if the compilation and its resulting -copyright are not used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work in an aggregate -does not cause this License to apply to the other parts of the aggregate. - -### 6. Conveying Non-Source Forms. - -You may convey a covered work in object code form under the terms of sections 4 and -5, provided that you also convey the machine-readable Corresponding Source under the -terms of this License, in one of these ways: - -* **a)** Convey the object code in, or embodied in, a physical product (including a -physical distribution medium), accompanied by the Corresponding Source fixed on a -durable physical medium customarily used for software interchange. -* **b)** Convey the object code in, or embodied in, a physical product (including a -physical distribution medium), accompanied by a written offer, valid for at least -three years and valid for as long as you offer spare parts or customer support for -that product model, to give anyone who possesses the object code either (1) a copy of -the Corresponding Source for all the software in the product that is covered by this -License, on a durable physical medium customarily used for software interchange, for -a price no more than your reasonable cost of physically performing this conveying of -source, or (2) access to copy the Corresponding Source from a network server at no -charge. -* **c)** Convey individual copies of the object code with a copy of the written offer to -provide the Corresponding Source. This alternative is allowed only occasionally and -noncommercially, and only if you received the object code with such an offer, in -accord with subsection 6b. -* **d)** Convey the object code by offering access from a designated place (gratis or for -a charge), and offer equivalent access to the Corresponding Source in the same way -through the same place at no further charge. You need not require recipients to copy -the Corresponding Source along with the object code. If the place to copy the object -code is a network server, the Corresponding Source may be on a different server -(operated by you or a third party) that supports equivalent copying facilities, -provided you maintain clear directions next to the object code saying where to find -the Corresponding Source. Regardless of what server hosts the Corresponding Source, -you remain obligated to ensure that it is available for as long as needed to satisfy -these requirements. -* **e)** Convey the object code using peer-to-peer transmission, provided you inform -other peers where the object code and Corresponding Source of the work are being -offered to the general public at no charge under subsection 6d. - -A separable portion of the object code, whose source code is excluded from the -Corresponding Source as a System Library, need not be included in conveying the -object code work. - -A “User Product” is either (1) a “consumer product”, which -means any tangible personal property which is normally used for personal, family, or -household purposes, or (2) anything designed or sold for incorporation into a -dwelling. In determining whether a product is a consumer product, doubtful cases -shall be resolved in favor of coverage. For a particular product received by a -particular user, “normally used” refers to a typical or common use of -that class of product, regardless of the status of the particular user or of the way -in which the particular user actually uses, or expects or is expected to use, the -product. A product is a consumer product regardless of whether the product has -substantial commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - -“Installation Information” for a User Product means any methods, -procedures, authorization keys, or other information required to install and execute -modified versions of a covered work in that User Product from a modified version of -its Corresponding Source. The information must suffice to ensure that the continued -functioning of the modified object code is in no case prevented or interfered with -solely because modification has been made. - -If you convey an object code work under this section in, or with, or specifically for -use in, a User Product, and the conveying occurs as part of a transaction in which -the right of possession and use of the User Product is transferred to the recipient -in perpetuity or for a fixed term (regardless of how the transaction is -characterized), the Corresponding Source conveyed under this section must be -accompanied by the Installation Information. But this requirement does not apply if -neither you nor any third party retains the ability to install modified object code -on the User Product (for example, the work has been installed in ROM). - -The requirement to provide Installation Information does not include a requirement to -continue to provide support service, warranty, or updates for a work that has been -modified or installed by the recipient, or for the User Product in which it has been -modified or installed. Access to a network may be denied when the modification itself -materially and adversely affects the operation of the network or violates the rules -and protocols for communication across the network. - -Corresponding Source conveyed, and Installation Information provided, in accord with -this section must be in a format that is publicly documented (and with an -implementation available to the public in source code form), and must require no -special password or key for unpacking, reading or copying. - -### 7. Additional Terms. - -“Additional permissions” are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. Additional -permissions that are applicable to the entire Program shall be treated as though they -were included in this License, to the extent that they are valid under applicable -law. If additional permissions apply only to part of the Program, that part may be -used separately under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - -When you convey a copy of a covered work, you may at your option remove any -additional permissions from that copy, or from any part of it. (Additional -permissions may be written to require their own removal in certain cases when you -modify the work.) You may place additional permissions on material, added by you to a -covered work, for which you have or can give appropriate copyright permission. - -Notwithstanding any other provision of this License, for material you add to a -covered work, you may (if authorized by the copyright holders of that material) -supplement the terms of this License with terms: - -* **a)** Disclaiming warranty or limiting liability differently from the terms of -sections 15 and 16 of this License; or -* **b)** Requiring preservation of specified reasonable legal notices or author -attributions in that material or in the Appropriate Legal Notices displayed by works -containing it; or -* **c)** Prohibiting misrepresentation of the origin of that material, or requiring that -modified versions of such material be marked in reasonable ways as different from the -original version; or -* **d)** Limiting the use for publicity purposes of names of licensors or authors of the -material; or -* **e)** Declining to grant rights under trademark law for use of some trade names, -trademarks, or service marks; or -* **f)** Requiring indemnification of licensors and authors of that material by anyone -who conveys the material (or modified versions of it) with contractual assumptions of -liability to the recipient, for any liability that these contractual assumptions -directly impose on those licensors and authors. - -All other non-permissive additional terms are considered “further -restrictions” within the meaning of section 10. If the Program as you received -it, or any part of it, contains a notice stating that it is governed by this License -along with a term that is a further restriction, you may remove that term. If a -license document contains a further restriction but permits relicensing or conveying -under this License, you may add to a covered work material governed by the terms of -that license document, provided that the further restriction does not survive such -relicensing or conveying. - -If you add terms to a covered work in accord with this section, you must place, in -the relevant source files, a statement of the additional terms that apply to those -files, or a notice indicating where to find the applicable terms. - -Additional terms, permissive or non-permissive, may be stated in the form of a -separately written license, or stated as exceptions; the above requirements apply -either way. - -### 8. Termination. - -You may not propagate or modify a covered work except as expressly provided under -this License. Any attempt otherwise to propagate or modify it is void, and will -automatically terminate your rights under this License (including any patent licenses -granted under the third paragraph of section 11). - -However, if you cease all violation of this License, then your license from a -particular copyright holder is reinstated (a) provisionally, unless and until the -copyright holder explicitly and finally terminates your license, and (b) permanently, -if the copyright holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - -Moreover, your license from a particular copyright holder is reinstated permanently -if the copyright holder notifies you of the violation by some reasonable means, this -is the first time you have received notice of violation of this License (for any -work) from that copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - -Termination of your rights under this section does not terminate the licenses of -parties who have received copies or rights from you under this License. If your -rights have been terminated and not permanently reinstated, you do not qualify to -receive new licenses for the same material under section 10. - -### 9. Acceptance Not Required for Having Copies. - -You are not required to accept this License in order to receive or run a copy of the -Program. Ancillary propagation of a covered work occurring solely as a consequence of -using peer-to-peer transmission to receive a copy likewise does not require -acceptance. However, nothing other than this License grants you permission to -propagate or modify any covered work. These actions infringe copyright if you do not -accept this License. Therefore, by modifying or propagating a covered work, you -indicate your acceptance of this License to do so. - -### 10. Automatic Licensing of Downstream Recipients. - -Each time you convey a covered work, the recipient automatically receives a license -from the original licensors, to run, modify and propagate that work, subject to this -License. You are not responsible for enforcing compliance by third parties with this -License. - -An “entity transaction” is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an organization, or -merging organizations. If propagation of a covered work results from an entity -transaction, each party to that transaction who receives a copy of the work also -receives whatever licenses to the work the party's predecessor in interest had or -could give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if the predecessor -has it or can get it with reasonable efforts. - -You may not impose any further restrictions on the exercise of the rights granted or -affirmed under this License. For example, you may not impose a license fee, royalty, -or other charge for exercise of rights granted under this License, and you may not -initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging -that any patent claim is infringed by making, using, selling, offering for sale, or -importing the Program or any portion of it. - -### 11. Patents. - -A “contributor” is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The work thus -licensed is called the contributor's “contributor version”. - -A contributor's “essential patent claims” are all patent claims owned or -controlled by the contributor, whether already acquired or hereafter acquired, that -would be infringed by some manner, permitted by this License, of making, using, or -selling its contributor version, but do not include claims that would be infringed -only as a consequence of further modification of the contributor version. For -purposes of this definition, “control” includes the right to grant patent -sublicenses in a manner consistent with the requirements of this License. - -Each contributor grants you a non-exclusive, worldwide, royalty-free patent license -under the contributor's essential patent claims, to make, use, sell, offer for sale, -import and otherwise run, modify and propagate the contents of its contributor -version. - -In the following three paragraphs, a “patent license” is any express -agreement or commitment, however denominated, not to enforce a patent (such as an -express permission to practice a patent or covenant not to sue for patent -infringement). To “grant” such a patent license to a party means to make -such an agreement or commitment not to enforce a patent against the party. - -If you convey a covered work, knowingly relying on a patent license, and the -Corresponding Source of the work is not available for anyone to copy, free of charge -and under the terms of this License, through a publicly available network server or -other readily accessible means, then you must either (1) cause the Corresponding -Source to be so available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner consistent with -the requirements of this License, to extend the patent license to downstream -recipients. “Knowingly relying” means you have actual knowledge that, but -for the patent license, your conveying the covered work in a country, or your -recipient's use of the covered work in a country, would infringe one or more -identifiable patents in that country that you have reason to believe are valid. - -If, pursuant to or in connection with a single transaction or arrangement, you -convey, or propagate by procuring conveyance of, a covered work, and grant a patent -license to some of the parties receiving the covered work authorizing them to use, -propagate, modify or convey a specific copy of the covered work, then the patent -license you grant is automatically extended to all recipients of the covered work and -works based on it. - -A patent license is “discriminatory” if it does not include within the -scope of its coverage, prohibits the exercise of, or is conditioned on the -non-exercise of one or more of the rights that are specifically granted under this -License. You may not convey a covered work if you are a party to an arrangement with -a third party that is in the business of distributing software, under which you make -payment to the third party based on the extent of your activity of conveying the -work, and under which the third party grants, to any of the parties who would receive -the covered work from you, a discriminatory patent license (a) in connection with -copies of the covered work conveyed by you (or copies made from those copies), or (b) -primarily for and in connection with specific products or compilations that contain -the covered work, unless you entered into that arrangement, or that patent license -was granted, prior to 28 March 2007. - -Nothing in this License shall be construed as excluding or limiting any implied -license or other defenses to infringement that may otherwise be available to you -under applicable patent law. - -### 12. No Surrender of Others' Freedom. - -If conditions are imposed on you (whether by court order, agreement or otherwise) -that contradict the conditions of this License, they do not excuse you from the -conditions of this License. If you cannot convey a covered work so as to satisfy -simultaneously your obligations under this License and any other pertinent -obligations, then as a consequence you may not convey it at all. For example, if you -agree to terms that obligate you to collect a royalty for further conveying from -those to whom you convey the Program, the only way you could satisfy both those terms -and this License would be to refrain entirely from conveying the Program. - -### 13. Use with the GNU Affero General Public License. - -Notwithstanding any other provision of this License, you have permission to link or -combine any covered work with a work licensed under version 3 of the GNU Affero -General Public License into a single combined work, and to convey the resulting work. -The terms of this License will continue to apply to the part which is the covered -work, but the special requirements of the GNU Affero General Public License, section -13, concerning interaction through a network will apply to the combination as such. - -### 14. Revised Versions of this License. - -The Free Software Foundation may publish revised and/or new versions of the GNU -General Public License from time to time. Such new versions will be similar in spirit -to the present version, but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Program specifies that -a certain numbered version of the GNU General Public License “or any later -version” applies to it, you have the option of following the terms and -conditions either of that numbered version or of any later version published by the -Free Software Foundation. If the Program does not specify a version number of the GNU -General Public License, you may choose any version ever published by the Free -Software Foundation. - -If the Program specifies that a proxy can decide which future versions of the GNU -General Public License can be used, that proxy's public statement of acceptance of a -version permanently authorizes you to choose that version for the Program. - -Later license versions may give you additional or different permissions. However, no -additional obligations are imposed on any author or copyright holder as a result of -your choosing to follow a later version. - -### 15. Disclaimer of Warranty. - -THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM “AS IS” WITHOUT WARRANTY OF ANY KIND, EITHER -EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE -QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE -DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - -### 16. Limitation of Liability. - -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY -COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS -PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, -INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE -OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE -WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - -### 17. Interpretation of Sections 15 and 16. - -If the disclaimer of warranty and limitation of liability provided above cannot be -given local legal effect according to their terms, reviewing courts shall apply local -law that most closely approximates an absolute waiver of all civil liability in -connection with the Program, unless a warranty or assumption of liability accompanies -a copy of the Program in return for a fee. - -END OF TERMS AND CONDITIONS - -## How to Apply These Terms to Your New Programs - -If you develop a new program, and you want it to be of the greatest possible use to -the public, the best way to achieve this is to make it free software which everyone -can redistribute and change under these terms. - -To do so, attach the following notices to the program. It is safest to attach them -to the start of each source file to most effectively state the exclusion of warranty; -and each file should have at least the “copyright” line and a pointer to -where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - -If the program does terminal interaction, make it output a short notice like this -when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type 'show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type 'show c' for details. - -The hypothetical commands 'show w' and 'show c' should show the appropriate parts of -the General Public License. Of course, your program's commands might be different; -for a GUI interface, you would use an “about box”. - -You should also get your employer (if you work as a programmer) or school, if any, to -sign a “copyright disclaimer” for the program, if necessary. For more -information on this, and how to apply and follow the GNU GPL, see -<>. - -The GNU General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may consider it -more useful to permit linking proprietary applications with the library. If this is -what you want to do, use the GNU Lesser General Public License instead of this -License. But first, please read -<>. \ No newline at end of file diff --git a/README.md b/README.md deleted file mode 100644 index 344387fc0..000000000 --- a/README.md +++ /dev/null @@ -1,205 +0,0 @@ -# 𑗕 easifemBase - - -![](./figures/what-is-easifem.svg) - -![](./figures/banner.jpeg) - -easifemBase (or, Base) library is the low level component in easifem. It contains routines and derived types which are helpful for implementing numerical methods for solving differential equation.| - -In Base library, we do not use object-oriented programming concepts and mainly use [multiple dispatch approach](https://en.wikipedia.org/wiki/Multiple_dispatch). This approach improves the flexibility and speed of easifemBase. All user-defined datatypes are declared in the `BaseType` module, and all methods are exposed through `BaseMethods` modules. In the Base library `string_class` is the only exception, wherein Object-oriented paradigm has been used. Currently, easifemBase has interface with BLAS95, Lapack95, Sparsekit, Metis, PlPlot, SuperLU, ARPACK, etc. - -## Usage - -### Use association - -```fortran -USE easifemBase -``` - -or - -```fortran -USE BaseType -USE BaseMethods -``` - -## System requirements - -EASIFEM requires following software packages to be installed on the system. - -| Component | Version | Latest tested version | Comment | -|:--- | :---: | :---: | :--- | -| **Gfortran**| >=9.0 | 12.0 | GNU Fortran compiler | -| **GCC**| >=9.0 | 12.0 | GNU-compiler collection| -| **OpenMP**| >= 4.5 | | Multithread shared memory parallelisation| -| **Curl**| >=7.87 | 7.87 | A command-line utility for transferring data from or to a remote server| -| **Git**| >=2.34 | 2.34.1 | A version control system and command-line utility for downloading packages from GitHub | -| **Cmake** | >=3.19 | 3.22.4 | Cross-platform family of tools designed to build, test and package software | -| **Ninja-build** | >=1.10 | 1.11.0 | Build system | -| **Python3** | >=3.7 | 3.11.0 | Scripting language | -| **Pip** | >=20 | 23.1.0 | Command line tool for downloading python packages | -| **LAPACK** | >=3.11.0 | 3.11.0 | Linear algebra package | -| **OpenBlas** | >= 0.3.20| 0.3.30 | Optimize BLAS library | -| **HDF5** | >=1.10 | 1.10.7 | High-performance data software-library and file-format | -| **PlPlot** | >=5.15.0 | 5.15.0 | Cross-platform, scientific graphics plotting library | -| **Boost** | | | | -| **Gnuplot** | >=5.0 | 5.4 | Portable command-line driven graphing utility | -| **Doxygen** | >=1.9.1 | 1.9.1 | documentation generation | -| **GTK-4** | | | n | - - -## External packages - -EASIFEM depends upon the following external packages (extpkgs) that are not shipped with the source-code. - -| extpkg| description | command | -|:--- | :--- | :--- | -| [OpenBlas](https://www.openblas.net/) | Highly optimized BLAS | easifem install openblas | -| [SuperLU](https://github.com/xiaoyeli/superlu.git) | Direct solution of large, sparse, nonsymmetric systems of linear equations | easifem install superlu | -| [LIS](https://github.com/anishida/lis.git) | Linear interative solver | easifem install lis| -| [METIS](https://github.com/KarypisLab/METIS) | Mesh partitioning library | easifem install metis | -| [SCOTCH](https://gitlab.inria.fr/scotch/scotch) | Mesh partitioning library | easifem install scotch | -| [ARPACK](https://github.com/opencollab/arpack-ng) | Eigensolver for sparse matrices | easifem install arpack | -| [FFTW](https://www.fftw.org/) | Fast Fourier Transform| easifem install fftw | -| [GTK-Fortran](https://github.com/vmagnin/gtk-fortran) | Fortran bindings for GTK-4 library | easifem install gtk-fortran | -| [LAPACK95](https://github.com/vickysharma0812/LAPACK95.git) | Fortran 95 interface for Lapack library | easifem install lapack95 | -| [Sparsekit](https://github.com/vickysharma0812/Sparsekit.git) | Fortran library for sparse matrices | easifem install sparsekit | -| [Gmsh](https://gmsh.info/) | Finite element mesh generator| easifem install gmsh | - - -## Installation - -You can use following instructions to install easifemBase depending upon your system. - -- [Linux](./pages/Install_Linux.md) -- [MacOSX](./pages/Install_MacOSX.md) -- [Windows](./pages/Install_Windows.md) - -## Structure - -The Base library consists two components: - -1. BaseType `BaseType.F90`, which contains the user-defined data-type. You can see the list of user-defined data type [here](./pages/BaseType.md) -2. BaseMethods `BaseMethods.F90`, contains the modules (each module defines the routines for data-types defined in `BaseType.F90`.) The list of modules defined in BaseMethods can be found [here](./pages/BaseMethods.md) - -The source directory is shown in figure given below. The source directory has two directories - -1. 📁 `modules` -2. 📁 `submodules` - -The `modules` directory mainly contains header and interface of methods. The implementation is given in submodules directory. - -:::info -Both `BaseType.F90` and `BaseMethods.F90` are included in `modules` directory. -::: - -Let us understand the structure of the Base library by an example of `CSRSparsity_` data type. - -1. First, we define `CSRSparsity_` in `BaseType.F90` as - - -```fortran -TYPE :: CSRSparsity_ - INTEGER(I4B) :: nnz = 0 - INTEGER(I4B) :: ncol = 0 - INTEGER(I4B) :: nrow = 0 - LOGICAL(LGT) :: isSorted = .FALSE. - LOGICAL(LGT) :: isInitiated = .FALSE. - LOGICAL(LGT) :: isSparsityLock = .FALSE. - LOGICAL(LGT) :: isDiagStored = .FALSE. - INTEGER(I4B), ALLOCATABLE :: IA(:) - INTEGER(I4B), ALLOCATABLE :: JA(:) - INTEGER(I4B), ALLOCATABLE :: idiag(:) - TYPE(IntVector_), ALLOCATABLE :: row(:) - TYPE(DOF_) :: idof - !! DOF for row - TYPE(DOF_) :: jdof - !! DOF for columns -END TYPE CSRSparsity_ -``` - - -2. Then we create a directory called `CSRSparsity` in both `modules` and `submodules` directory. -3. In `modules/CSRSparsity` we create `CSRSparsity_Method.F90` file. -4. In `modules/CSRSparsity/CSRSparsity_Method.F90` we define a module `CSRSparsity_Method` (same name as file). -5. In `CSRSparsity_Method` module, we only define interface of methods. In this way, this file can be considered as header file. See, the example given below: -6. In `submodules/CSRSparsity`, we create `CSRSparsity_Method@ConstructorMethods.F90`, which contains the contruction related routines. -7. Also, we create `CSRSparsity_Method@IOMethods.F90`, which include methods related to input and output. - - -```fortran -MODULE CSRSparsity_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -INTERFACE Initiate - MODULE SUBROUTINE csr_initiate1(obj, ncol, nrow, idof, jdof) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ncol, nrow - TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof - !! DOF for row - TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof - !! DOF for column - END SUBROUTINE csr_initiate1 -END INTERFACE Initiate - -INTERFACE Display - MODULE SUBROUTINE csr_Display(obj, Msg, UnitNo) - TYPE(CSRSparsity_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: Msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - END SUBROUTINE csr_Display -END INTERFACE Display - -END MODULE CSRSparsity_Method -``` - -CSRSparsity_Method@ConstructorMethods.F90 - -```fortran -SUBMODULE(CSRSparsity_Method) ConstructorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -MODULE PROCEDURE csr_initiate1 -obj%nnz = 0 -obj%ncol = ncol -obj%nrow = nrow -END PROCEDURE csr_initiate1 - -END SUBMODULE ConstructorMethods -``` - -CSRSparsity_Method@IOMethods.F90 - -```fortran -SUBMODULE(CSRSparsity_Method) IOMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -MODULE PROCEDURE csr_Display -CALL Display(Msg, unitNo=unitNo) -CALL Display(obj%nnz, "# NNZ : ", unitNo=unitNo) -END PROCEDURE csr_Display - -END SUBMODULE IOMethods -``` - -![](./figures/figure-2.svg) - -## Run on Cloud - -Coming soon. - -## Contributing - -## Credits - -## License - -[License](LICENSE) diff --git a/Workspaces/BLAS.code-workspace b/Workspaces/BLAS.code-workspace deleted file mode 100644 index 13b53c2e3..000000000 --- a/Workspaces/BLAS.code-workspace +++ /dev/null @@ -1,13 +0,0 @@ -{ - "folders": [ - { - "path": "../src/modules/BLAS" - }, - { - "path": "../src/submodules/BLAS" - }, - { - "path": "../tests/BLAS" - } - ] -} \ No newline at end of file diff --git a/Workspaces/OpenMP.code-workspace b/Workspaces/OpenMP.code-workspace deleted file mode 100644 index a14db76ea..000000000 --- a/Workspaces/OpenMP.code-workspace +++ /dev/null @@ -1,13 +0,0 @@ -{ - "folders": [ - { - "path": "../src/modules/BLAS" - }, - { - "path": "../src/submodules/BLAS" - }, - { - "path": "../tests/BLAS" - } - ] -} diff --git a/Workspaces/Polynomial b/Workspaces/Polynomial deleted file mode 100644 index e69de29bb..000000000 diff --git a/Workspaces/SparseMatrix.code-workspace b/Workspaces/SparseMatrix.code-workspace deleted file mode 100644 index 685515171..000000000 --- a/Workspaces/SparseMatrix.code-workspace +++ /dev/null @@ -1,16 +0,0 @@ -{ - "folders": [ - { - "path": "../src/modules/CSRMatrix" - }, - { - "path": "../src/modules/CSRSparsity" - }, - { - "path": "../src/submodules/CSRMatrix" - }, - { - "path": "../src/submodules/CSRSparsity" - } - ] -} \ No newline at end of file diff --git a/Workspaces/Tensor.code-workspace b/Workspaces/Tensor.code-workspace deleted file mode 100644 index 35b00a876..000000000 --- a/Workspaces/Tensor.code-workspace +++ /dev/null @@ -1,10 +0,0 @@ -{ - "folders": [ - { - "path": "../src/modules/Rank2Tensor" - }, - { - "path": "../src/submodules/Rank2Tensor" - } - ] -} \ No newline at end of file diff --git a/Workspaces/Utility.code-workspace b/Workspaces/Utility.code-workspace deleted file mode 100644 index 8ecd86e8d..000000000 --- a/Workspaces/Utility.code-workspace +++ /dev/null @@ -1,10 +0,0 @@ -{ - "folders": [ - { - "path": "../src/modules/Utility" - }, - { - "path": "../src/submodules/Utility" - } - ] -} \ No newline at end of file diff --git a/Workspaces/refelem.code-workspace b/Workspaces/refelem.code-workspace deleted file mode 100644 index ad3ce4813..000000000 --- a/Workspaces/refelem.code-workspace +++ /dev/null @@ -1,25 +0,0 @@ -{ - "folders": [ - { - "path": "../src/modules/ElemshapeData" - }, - { - "path": "../src/modules/Geometry" - }, - { - "path": "../src/modules/QuadraturePoint" - }, - { - "path": "../src/modules/ReferenceElement" - }, - { - "path": "../src/submodules/ElemshapeData" - }, - { - "path": "../src/submodules/QuadraturePoint" - }, - { - "path": "../src/submodules/ReferenceElement" - } - ] -} \ No newline at end of file diff --git a/base.code-workspace b/base.code-workspace deleted file mode 100644 index cc9258653..000000000 --- a/base.code-workspace +++ /dev/null @@ -1,10 +0,0 @@ -{ - "folders": [ - { - "path": "." - } - ], - "settings": { - "cmake.installPrefix": "~/.easifem/base" - } -} \ No newline at end of file diff --git a/build.py b/build.py deleted file mode 100755 index 2e1495c8f..000000000 --- a/build.py +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/env python3 -#!/Users/easifem/anaconda3/envs/easifem/bin/python3 - -# This program is a part of EASIFEM library. -# See. www.easifem.com -# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. -# - -import os -import platform - -print("Detecting OS type...") -_os = platform.system() -if _os == "Windows": - print("ERROR: INSTALLATION on windows is work in progress") - exit - # print("Please use Windows Subsystem Linux(WSL) ") - # print("Installation DONE!!") -else: - cmake_def = "" - cmake_def += ' -G "Ninja"' # Unix Makefiles, Ninja, Ninja Multi-Config - cmake_def += " -D USE_OPENMP:BOOL=ON" # OFF - cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Debug" # Release - cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" - cmake_def += " -D CMAKE_EXPORT_COMPILE_COMMANDS:BOOL=ON" - cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" - cmake_def += " -D USE_PLPLOT:BOOL=ON" - cmake_def += " -D USE_BLAS95:BOOL=ON" - cmake_def += " -D USE_LAPACK95:BOOL=ON" - cmake_def += " -D USE_FFTW:BOOL=ON" - cmake_def += " -D USE_GTK:BOOL=OFF" - cmake_def += " -D USE_ARPACK:BOOL=ON" - cmake_def += " -D USE_SUPERLU:BOOL=ON" - cmake_def += " -D USE_LIS:BOOL=ON" - cmake_def += " -D USE_PARPACK:BOOL=OFF" - cmake_def += " -D USE_METIS:BOOL=OFF" - cmake_def += " -D USE_LUA:BOOL=ON" - cmake_def += " -D USE_INT32:BOOL=ON" - cmake_def += " -D USE_REAL64:BOOL=ON" - cmake_def += " -D USE_RAYLIB:BOOL=ON" - cmake_def += " -D USE_COLORDISP:BOOL=OFF" - - print("CMAKE DEF : ", cmake_def) - - _build0 = os.path.join(os.environ["HOME"], "temp") - build_dir = os.path.join( - os.environ.get("EASIFEM_BUILD_DIR", _build0), "easifem", "base", "build" - ) - # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" - os.makedirs(build_dir, exist_ok=True) - os.system(f"cmake {cmake_def} -S ./ -B {build_dir}") - os.system(f"cmake --build {build_dir}") - print("Build DONE!!") diff --git a/cmake/Config.cmake.in b/cmake/Config.cmake.in deleted file mode 100644 index 3758fb80e..000000000 --- a/cmake/Config.cmake.in +++ /dev/null @@ -1,75 +0,0 @@ -@PACKAGE_INIT@ - -LIST( - APPEND - ExternalLibs - Sparsekit - toml-f -) - -IF( @USE_LAPACK95@ ) - LIST(APPEND - ExternalLibs - LAPACK95 - ) -ENDIF() - -IF( @USE_ARPACK@ ) - LIST(APPEND - ExternalLibs - arpackng - ) -ENDIF() - -IF( @USE_RAYLIB@ ) - LIST(APPEND - ExternalLibs - raylib - ) -ENDIF() - -FOREACH(LIB ${ExternalLibs}) - FIND_PACKAGE(${LIB} REQUIRED) -ENDFOREACH() - -IF( @USE_OPENMP@ ) - IF(APPLE) - IF(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES "AppleClang") - SET(OpenMP_C "${CMAKE_C_COMPILER}" CACHE STRING "" FORCE) - SET(OpenMP_C_FLAGS - "-fopenmp=libomp -Wno-unused-command-line-argument" - CACHE STRING - "" - FORCE - ) - SET(OpenMP_C_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE) - SET(OpenMP_libomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) - SET(OpenMP_libgomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) - SET(OpenMP_libiomp5_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) - - SET(OpenMP_CXX "${CMAKE_CXX_COMPILER}" CACHE STRING "" FORCE) - SET( - OpenMP_CXX_FLAGS - "-fopenmp=libomp -Wno-unused-command-line-argument" - CACHE STRING - "" - FORCE - ) - - SET(OpenMP_CXX_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE) - ENDIF() - ENDIF() - - FIND_PACKAGE(OpenMP REQUIRED) -ENDIF() - - -set_and_check( - "@PROJECT_NAME@_INCLUDE_DIR" "@PACKAGE_INSTALL_INCLUDEDIR@") - -include( - "${CMAKE_CURRENT_LIST_DIR}/@TARGETS_EXPORT_NAME@.cmake") - -check_required_components( - "@PROJECT_NAME@" - ) diff --git a/cmake/Modules/FindLAPACK.cmake b/cmake/Modules/FindLAPACK.cmake deleted file mode 100644 index 9f2f0e93e..000000000 --- a/cmake/Modules/FindLAPACK.cmake +++ /dev/null @@ -1,563 +0,0 @@ -# Distributed under the OSI-approved BSD 3-Clause License. See accompanying -# file Copyright.txt or https://cmake.org/licensing for details. - -#[=======================================================================[.rst: -FindLAPACK ----------- - -Find Linear Algebra PACKage (LAPACK) library - -This module finds an installed Fortran library that implements the -LAPACK linear-algebra interface (see http://www.netlib.org/lapack/). - -The approach follows that taken for the ``autoconf`` macro file, -``acx_lapack.m4`` (distributed at -http://ac-archive.sourceforge.net/ac-archive/acx_lapack.html). - -Input Variables -^^^^^^^^^^^^^^^ - -The following variables may be set to influence this module's behavior: - -``BLA_STATIC`` - if ``ON`` use static linkage - -``BLA_VENDOR`` - If set, checks only the specified vendor, if not set checks all the - possibilities. List of vendors valid in this module: - - * ``FlexiBLAS`` - * ``OpenBLAS`` - * ``FLAME`` - * ``Intel10_32`` (intel mkl v10 32 bit, threaded code) - * ``Intel10_64lp`` (intel mkl v10+ 64 bit, threaded code, lp64 model) - * ``Intel10_64lp_seq`` (intel mkl v10+ 64 bit, sequential code, lp64 model) - * ``Intel10_64ilp`` (intel mkl v10+ 64 bit, threaded code, ilp64 model) - * ``Intel10_64ilp_seq`` (intel mkl v10+ 64 bit, sequential code, ilp64 model) - * ``Intel10_64_dyn`` (intel mkl v10+ 64 bit, single dynamic library) - * ``Intel`` (obsolete versions of mkl 32 and 64 bit) - * ``ACML`` - * ``Apple`` - * ``NAS`` - * ``Arm`` - * ``Arm_mp`` - * ``Arm_ilp64`` - * ``Arm_ilp64_mp`` - * ``Generic`` - -``BLA_F95`` - if ``ON`` tries to find the BLAS95/LAPACK95 interfaces - -Imported targets -^^^^^^^^^^^^^^^^ - -This module defines the following :prop_tgt:`IMPORTED` target: - -``LAPACK::LAPACK`` - The libraries to use for LAPACK, if found. - -Result Variables -^^^^^^^^^^^^^^^^ - -This module defines the following variables: - -``LAPACK_FOUND`` - library implementing the LAPACK interface is found -``LAPACK_LINKER_FLAGS`` - uncached list of required linker flags (excluding ``-l`` and ``-L``). -``LAPACK_LIBRARIES`` - uncached list of libraries (using full path name) to link against - to use LAPACK -``LAPACK95_LIBRARIES`` - uncached list of libraries (using full path name) to link against - to use LAPACK95 -``LAPACK95_FOUND`` - library implementing the LAPACK95 interface is found - -.. note:: - - C, CXX or Fortran must be enabled to detect a BLAS/LAPACK library. - C or CXX must be enabled to use Intel Math Kernel Library (MKL). - - For example, to use Intel MKL libraries and/or Intel compiler: - - .. code-block:: cmake - - set(BLA_VENDOR Intel10_64lp) - find_package(LAPACK) -#]=======================================================================] - -if(CMAKE_Fortran_COMPILER_LOADED) - include(CheckFortranFunctionExists) - # include(${CMAKE_CURRENT_LIST_DIR}/CheckFortranFunctionExists.cmake) -else() - include(CheckFunctionExists) -endif() -include(CMakePushCheckState) -include(FindPackageHandleStandardArgs) - -macro(_lapack_find_library_setup) - cmake_push_check_state() - set(CMAKE_REQUIRED_QUIET ${LAPACK_FIND_QUIETLY}) - - set(_lapack_ORIG_CMAKE_FIND_LIBRARY_SUFFIXES ${CMAKE_FIND_LIBRARY_SUFFIXES}) - if(BLA_STATIC) - if(WIN32) - set(CMAKE_FIND_LIBRARY_SUFFIXES .lib ${CMAKE_FIND_LIBRARY_SUFFIXES}) - else() - set(CMAKE_FIND_LIBRARY_SUFFIXES .a ${CMAKE_FIND_LIBRARY_SUFFIXES}) - endif() - else() - if(CMAKE_SYSTEM_NAME STREQUAL "Linux") - # for ubuntu's libblas3gf and liblapack3gf packages - set(CMAKE_FIND_LIBRARY_SUFFIXES ${CMAKE_FIND_LIBRARY_SUFFIXES} .so.3gf) - endif() - endif() -endmacro() - -macro(_lapack_find_library_teardown) - set(CMAKE_FIND_LIBRARY_SUFFIXES ${_lapack_ORIG_CMAKE_FIND_LIBRARY_SUFFIXES}) - unset(_lapack_ORIG_CMAKE_FIND_LIBRARY_SUFFIXES) - cmake_pop_check_state() -endmacro() - -# TODO: move this stuff to a separate module - -macro( - CHECK_LAPACK_LIBRARIES - LIBRARIES - _prefix - _name - _flags - _list - _threadlibs - _addlibdir - _subdirs - _blas) - # This macro checks for the existence of the combination of fortran libraries - # given by _list. If the combination is found, this macro checks (using the - # Check_Fortran_Function_Exists macro) whether can link against that library - # combination using the name of a routine given by _name using the linker - # flags given by _flags. If the combination of libraries is found and passes - # the link test, LIBRARIES is set to the list of complete library paths that - # have been found. Otherwise, LIBRARIES is set to FALSE. - - # N.B. _prefix is the prefix applied to the names of all cached variables that - # are generated internally and marked advanced by this macro. _addlibdir is a - # list of additional search paths. _subdirs is a list of path suffixes to be - # used by find_library(). - - set(_libraries_work TRUE) - set(${LIBRARIES}) - set(_combined_name) - - set(_extaddlibdir "${_addlibdir}") - if(WIN32) - list(APPEND _extaddlibdir ENV LIB) - elseif(APPLE) - list(APPEND _extaddlibdir ENV DYLD_LIBRARY_PATH) - else() - list(APPEND _extaddlibdir ENV LD_LIBRARY_PATH) - endif() - list(APPEND _extaddlibdir "${CMAKE_C_IMPLICIT_LINK_DIRECTORIES}") - - foreach(_library ${_list}) - if(_library MATCHES "^-Wl,--(start|end)-group$") - # Respect linker flags like --start/end-group (required by MKL) - set(${LIBRARIES} ${${LIBRARIES}} "${_library}") - else() - set(_combined_name ${_combined_name}_${_library}) - if(_libraries_work) - find_library( - ${_prefix}_${_library}_LIBRARY - NAMES ${_library} NAMES_PER_DIR - PATHS ${_extaddlibdir} - PATH_SUFFIXES ${_subdirs}) - # message("DEBUG: find_library(${_library}) got - # ${${_prefix}_${_library}_LIBRARY}") - mark_as_advanced(${_prefix}_${_library}_LIBRARY) - set(${LIBRARIES} ${${LIBRARIES}} ${${_prefix}_${_library}_LIBRARY}) - set(_libraries_work ${${_prefix}_${_library}_LIBRARY}) - endif() - endif() - endforeach() - unset(_library) - - if(_libraries_work) - # Test this combination of libraries. - set(CMAKE_REQUIRED_LIBRARIES ${_flags} ${${LIBRARIES}} ${_blas} - ${_threadlibs}) - # message("DEBUG: CMAKE_REQUIRED_LIBRARIES = ${CMAKE_REQUIRED_LIBRARIES}") - if(CMAKE_Fortran_COMPILER_LOADED) - check_fortran_function_exists("${_name}" - ${_prefix}${_combined_name}_WORKS) - else() - check_function_exists("${_name}_" ${_prefix}${_combined_name}_WORKS) - endif() - set(CMAKE_REQUIRED_LIBRARIES) - set(_libraries_work ${${_prefix}${_combined_name}_WORKS}) - endif() - - if(_libraries_work) - if("${_list}${_blas}" STREQUAL "") - set(${LIBRARIES} "${LIBRARIES}-PLACEHOLDER-FOR-EMPTY-LIBRARIES") - else() - set(${LIBRARIES} ${${LIBRARIES}} ${_blas} ${_threadlibs}) - endif() - else() - set(${LIBRARIES} FALSE) - endif() - - unset(_extaddlibdir) - unset(_libraries_work) - unset(_combined_name) - # message("DEBUG: ${LIBRARIES} = ${${LIBRARIES}}") -endmacro() - -macro(_lapack_find_dependency dep) - set(_lapack_quiet_arg) - if(LAPACK_FIND_QUIETLY) - set(_lapack_quiet_arg QUIET) - endif() - set(_lapack_required_arg) - if(LAPACK_FIND_REQUIRED) - set(_lapack_required_arg REQUIRED) - endif() - find_package(${dep} ${ARGN} ${_lapack_quiet_arg} ${_lapack_required_arg}) - if(NOT ${dep}_FOUND) - set(LAPACK_NOT_FOUND_MESSAGE - "LAPACK could not be found because dependency ${dep} could not be found." - ) - endif() - - set(_lapack_required_arg) - set(_lapack_quiet_arg) -endmacro() - -_lapack_find_library_setup() - -set(LAPACK_LINKER_FLAGS) -set(LAPACK_LIBRARIES) -set(LAPACK95_LIBRARIES) - -# Check the language being used -if(NOT - (CMAKE_C_COMPILER_LOADED - OR CMAKE_CXX_COMPILER_LOADED - OR CMAKE_Fortran_COMPILER_LOADED)) - set(LAPACK_NOT_FOUND_MESSAGE - "FindLAPACK requires Fortran, C, or C++ to be enabled.") -endif() - -# Load BLAS -if(NOT LAPACK_NOT_FOUND_MESSAGE) - _lapack_find_dependency(BLAS) -endif() - -# Search for different LAPACK distributions if BLAS is found -if(NOT LAPACK_NOT_FOUND_MESSAGE) - set(LAPACK_LINKER_FLAGS ${BLAS_LINKER_FLAGS}) - if(NOT $ENV{BLA_VENDOR} STREQUAL "") - set(BLA_VENDOR $ENV{BLA_VENDOR}) - elseif(NOT BLA_VENDOR) - set(BLA_VENDOR "All") - endif() - - # LAPACK in the Intel MKL 10+ library? - if(NOT LAPACK_LIBRARIES - AND (BLA_VENDOR MATCHES "Intel" OR BLA_VENDOR STREQUAL "All") - AND (CMAKE_C_COMPILER_LOADED OR CMAKE_CXX_COMPILER_LOADED)) - # System-specific settings - if(NOT WIN32) - set(LAPACK_mkl_LM "-lm") - set(LAPACK_mkl_LDL "-ldl") - endif() - - _lapack_find_dependency(Threads) - - if(BLA_VENDOR MATCHES "_64ilp") - set(LAPACK_mkl_ILP_MODE "ilp64") - else() - set(LAPACK_mkl_ILP_MODE "lp64") - endif() - - set(LAPACK_SEARCH_LIBS "") - - if(BLA_F95) - set(LAPACK_mkl_SEARCH_SYMBOL "cheev_f95") - set(_LIBRARIES LAPACK95_LIBRARIES) - set(_BLAS_LIBRARIES ${BLAS95_LIBRARIES}) - - # old - list(APPEND LAPACK_SEARCH_LIBS "mkl_lapack95") - # new >= 10.3 - list(APPEND LAPACK_SEARCH_LIBS "mkl_intel_c") - list(APPEND LAPACK_SEARCH_LIBS "mkl_lapack95_${LAPACK_mkl_ILP_MODE}") - else() - set(LAPACK_mkl_SEARCH_SYMBOL "cheev") - set(_LIBRARIES LAPACK_LIBRARIES) - set(_BLAS_LIBRARIES ${BLAS_LIBRARIES}) - - # old and new >= 10.3 - list(APPEND LAPACK_SEARCH_LIBS "mkl_lapack") - endif() - - # MKL uses a multitude of partially platform-specific subdirectories: - if(BLA_VENDOR STREQUAL "Intel10_32") - set(LAPACK_mkl_ARCH_NAME "ia32") - else() - set(LAPACK_mkl_ARCH_NAME "intel64") - endif() - if(WIN32) - set(LAPACK_mkl_OS_NAME "win") - elseif(APPLE) - set(LAPACK_mkl_OS_NAME "mac") - else() - set(LAPACK_mkl_OS_NAME "lin") - endif() - if(DEFINED ENV{MKLROOT}) - file(TO_CMAKE_PATH "$ENV{MKLROOT}" LAPACK_mkl_MKLROOT) - # If MKLROOT points to the subdirectory 'mkl', use the parent directory - # instead so we can better detect other relevant libraries in 'compiler' - # or 'tbb': - get_filename_component(LAPACK_mkl_MKLROOT_LAST_DIR - "${LAPACK_mkl_MKLROOT}" NAME) - if(LAPACK_mkl_MKLROOT_LAST_DIR STREQUAL "mkl") - get_filename_component(LAPACK_mkl_MKLROOT "${LAPACK_mkl_MKLROOT}" - DIRECTORY) - endif() - endif() - set(LAPACK_mkl_LIB_PATH_SUFFIXES - "compiler/lib" - "compiler/lib/${LAPACK_mkl_ARCH_NAME}_${LAPACK_mkl_OS_NAME}" - "compiler/lib/${LAPACK_mkl_ARCH_NAME}" - "mkl/lib" - "mkl/lib/${LAPACK_mkl_ARCH_NAME}_${LAPACK_mkl_OS_NAME}" - "mkl/lib/${LAPACK_mkl_ARCH_NAME}" - "lib/${LAPACK_mkl_ARCH_NAME}_${LAPACK_mkl_OS_NAME}") - - # First try empty lapack libs - if(NOT ${_LIBRARIES}) - Check_Lapack_Libraries( - ${_LIBRARIES} - LAPACK - ${LAPACK_mkl_SEARCH_SYMBOL} - "" - "" - "${CMAKE_THREAD_LIBS_INIT};${LAPACK_mkl_LM};${LAPACK_mkl_LDL}" - "${LAPACK_mkl_MKLROOT}" - "${LAPACK_mkl_LIB_PATH_SUFFIXES}" - "${_BLAS_LIBRARIES}") - endif() - - # Then try the search libs - foreach(IT ${LAPACK_SEARCH_LIBS}) - string(REPLACE " " ";" SEARCH_LIBS ${IT}) - if(NOT ${_LIBRARIES}) - Check_Lapack_Libraries( - ${_LIBRARIES} - LAPACK - ${LAPACK_mkl_SEARCH_SYMBOL} - "" - "${SEARCH_LIBS}" - "${CMAKE_THREAD_LIBS_INIT};${LAPACK_mkl_LM};${LAPACK_mkl_LDL}" - "${LAPACK_mkl_MKLROOT}" - "${LAPACK_mkl_LIB_PATH_SUFFIXES}" - "${_BLAS_LIBRARIES}") - endif() - endforeach() - - unset(LAPACK_mkl_ILP_MODE) - unset(LAPACK_mkl_SEARCH_SYMBOL) - unset(LAPACK_mkl_LM) - unset(LAPACK_mkl_LDL) - unset(LAPACK_mkl_MKLROOT) - unset(LAPACK_mkl_ARCH_NAME) - unset(LAPACK_mkl_OS_NAME) - unset(LAPACK_mkl_LIB_PATH_SUFFIXES) - endif() - - # gotoblas? (http://www.tacc.utexas.edu/tacc-projects/gotoblas2) - if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "Goto" OR BLA_VENDOR STREQUAL - "All")) - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "goto2" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() - - # FlexiBLAS? (http://www.mpi-magdeburg.mpg.de/mpcsc/software/FlexiBLAS/) - if(NOT LAPACK_LIBRARIES - AND (BLA_VENDOR STREQUAL "FlexiBLAS" OR BLA_VENDOR STREQUAL "All")) - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "flexiblas" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() - - # OpenBLAS? (http://www.openblas.net) - if(NOT LAPACK_LIBRARIES - AND (BLA_VENDOR STREQUAL "OpenBLAS" OR BLA_VENDOR STREQUAL "All")) - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "openblas" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() - - # ArmPL? - # (https://developer.arm.com/tools-and-software/server-and-hpc/compile/arm-compiler-for-linux/arm-performance-libraries) - if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR MATCHES "Arm" OR BLA_VENDOR STREQUAL - "All")) - # Check for 64bit Integer support - if(BLA_VENDOR MATCHES "_ilp64") - set(LAPACK_armpl_LIB "armpl_ilp64") - else() - set(LAPACK_armpl_LIB "armpl_lp64") - endif() - - # Check for OpenMP support, VIA BLA_VENDOR of Arm_mp or Arm_ipl64_mp - if(BLA_VENDOR MATCHES "_mp") - set(LAPACK_armpl_LIB "${LAPACK_armpl_LIB}_mp") - endif() - - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "${LAPACK_armpl_LIB}" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() - - # FLAME's blis library? (https://github.com/flame/blis) - if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "FLAME" OR BLA_VENDOR - STREQUAL "All")) - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "flame" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() - - # BLAS in acml library? - if(BLA_VENDOR MATCHES "ACML" OR BLA_VENDOR STREQUAL "All") - if(BLAS_LIBRARIES MATCHES ".+acml.+") - set(LAPACK_LIBRARIES ${BLAS_LIBRARIES}) - endif() - endif() - - # Apple LAPACK library? - if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "Apple" OR BLA_VENDOR - STREQUAL "All")) - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "Accelerate" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() - - # Apple NAS (vecLib) library? - if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "NAS" OR BLA_VENDOR STREQUAL - "All")) - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "vecLib" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() - - # Generic LAPACK library? - if(NOT LAPACK_LIBRARIES - AND (BLA_VENDOR STREQUAL "Generic" - OR BLA_VENDOR STREQUAL "ATLAS" - OR BLA_VENDOR STREQUAL "All")) - Check_Lapack_Libraries( - LAPACK_LIBRARIES - LAPACK - cheev - "" - "lapack" - "" - "" - "" - "${BLAS_LIBRARIES}") - endif() -endif() - -if(BLA_F95) - set(LAPACK_LIBRARIES "${LAPACK95_LIBRARIES}") -endif() - -if(LAPACK_NOT_FOUND_MESSAGE) - set(LAPACK_NOT_FOUND_MESSAGE REASON_FAILURE_MESSAGE - ${LAPACK_NOT_FOUND_MESSAGE}) -endif() -find_package_handle_standard_args( - LAPACK REQUIRED_VARS LAPACK_LIBRARIES ${LAPACK_NOT_FOUND_MESSAGE}) -unset(LAPACK_NOT_FOUND_MESSAGE) - -if(BLA_F95) - set(LAPACK95_FOUND ${LAPACK_FOUND}) -endif() - -# On compilers that implicitly link LAPACK (such as ftn, cc, and CC on Cray HPC -# machines) we used a placeholder for empty LAPACK_LIBRARIES to get through our -# logic above. -if(LAPACK_LIBRARIES STREQUAL "LAPACK_LIBRARIES-PLACEHOLDER-FOR-EMPTY-LIBRARIES") - set(LAPACK_LIBRARIES "") -endif() - -if(LAPACK_FOUND AND NOT TARGET LAPACK::LAPACK) - add_library(LAPACK::LAPACK INTERFACE IMPORTED) - set(_lapack_libs "${LAPACK_LIBRARIES}") - if(_lapack_libs AND TARGET BLAS::BLAS) - # remove the ${BLAS_LIBRARIES} from the interface and replace it with the - # BLAS::BLAS target - list(REMOVE_ITEM _lapack_libs "${BLAS_LIBRARIES}") - endif() - - if(_lapack_libs) - set_target_properties(LAPACK::LAPACK PROPERTIES INTERFACE_LINK_LIBRARIES - "${_lapack_libs}") - endif() - unset(_lapack_libs) -endif() - -_lapack_find_library_teardown() - diff --git a/cmake/addARPACK.cmake b/cmake/addARPACK.cmake deleted file mode 100644 index 93a013037..000000000 --- a/cmake/addARPACK.cmake +++ /dev/null @@ -1,30 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_ARPACK OFF) -if(USE_ARPACK) - find_package(arpackng REQUIRED) - if(arpackng_FOUND) - message(STATUS "FOUND ARPACK-NG") - list(APPEND TARGET_COMPILE_DEF "-DUSE_ARPACK") - list(APPEND TARGET_COMPILE_OPT ${arpackng_Fortran_FLAGS}) - target_link_libraries(${PROJECT_NAME} PUBLIC ARPACK::ARPACK) - else() - message(ERROR "NOT FOUND ARPACK-NG") - endif() -endif() diff --git a/cmake/addFFTW.cmake b/cmake/addFFTW.cmake deleted file mode 100644 index 0632ce4eb..000000000 --- a/cmake/addFFTW.cmake +++ /dev/null @@ -1,33 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_FFTW OFF) -if(USE_FFTW) - - list(APPEND TARGET_COMPILE_DEF "-DUSE_FFTW") - - find_library(FFTW_LIBRARIES NAMES fftw fftw3 REQUIRED) - - target_link_libraries(${PROJECT_NAME} PUBLIC ${FFTW_LIBRARIES}) - message(STATUS "FFTW_LIBRARY : ${FFTW_LIBRARIES}") - -else() - - message(STATUS "NOT USING FFTW LIBRARIES") - -endif() diff --git a/cmake/addGTKFortran.cmake b/cmake/addGTKFortran.cmake deleted file mode 100644 index 7a10381c3..000000000 --- a/cmake/addGTKFortran.cmake +++ /dev/null @@ -1,49 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_GTK OFF) - -if(USE_GTK) - - list(APPEND TARGET_COMPILE_DEF "-DUSE_GTK") - - find_package(PkgConfig) - pkg_check_modules(GTKFORTRAN REQUIRED gtk-4-fortran) - find_path( - GTKFORTRAN_MODULE_DIRS - NAMES gtk.mod - PATHS ${GTKFORTRAN_INCLUDE_DIRS}) - find_library(GTKFORTRAN_LIBRARY NAMES gtk-4-fortran) - - message(STATUS "GTKFORTRAN_CFLAGS : ${GTKFORTRAN_CFLAGS}") - message(STATUS "GTKFORTRAN_LIBRARY : ${GTKFORTRAN_LIBRARY}") - message(STATUS "GTKFORTRAN_LIBRARIES : ${GTKFORTRAN_LIBRARIES}") - message(STATUS "GTKFORTRAN_LIBRARY_DIRS : ${GTKFORTRAN_LIBRARY_DIRS}") - message(STATUS "GTKFORTRAN_INCLUDE_DIRS : ${GTKFORTRAN_INCLUDE_DIRS}") - message(STATUS "GTKFORTRAN_MODULE_DIRS : ${GTKFORTRAN_MODULE_DIRS}") - - target_link_libraries(${PROJECT_NAME} PUBLIC ${GTKFORTRAN_LIBRARY} - ${GTKFORTRAN_LIBRARIES}) - target_include_directories(${PROJECT_NAME} PUBLIC ${GTKFORTRAN_INCLUDE_DIRS} - ${GTKFORTRAN_MODULE_DIRS}) - -else() - - message(STATUS "NOT USING GTK-Fortran") - -endif() diff --git a/cmake/addLIS.cmake b/cmake/addLIS.cmake deleted file mode 100644 index 9ad7dd5f9..000000000 --- a/cmake/addLIS.cmake +++ /dev/null @@ -1,37 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_LIS OFF) -if(USE_LIS) - - list(APPEND TARGET_COMPILE_DEF "-DUSE_LIS") - - find_library(LIS_LIBRARIES NAME lis REQUIRED) - find_path(LIS_INCLUDE_DIR NAMES lis_config.h lisf.h lis.h) - - target_link_libraries(${PROJECT_NAME} PUBLIC ${LIS_LIBRARIES}) - message(STATUS "LIS_LIBRARIES : ${LIS_LIBRARIES}") - - target_include_directories(${PROJECT_NAME} PUBLIC ${LIS_INCLUDE_DIR}) - message(STATUS "LIS_INCLUDE_DIR : ${LIS_INCLUDE_DIR}") - -else() - - message(STATUS "NOT USING LIS LIBRARIES") - -endif() diff --git a/cmake/addLapack95.cmake b/cmake/addLapack95.cmake deleted file mode 100644 index 756c98588..000000000 --- a/cmake/addLapack95.cmake +++ /dev/null @@ -1,33 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -if(USE_LAPACK95) - - find_package(LAPACK95 REQUIRED) - - if(LAPACK95_FOUND) - message(STATUS "[INFO] :: FOUND LAPACK95") - target_link_libraries(${PROJECT_NAME} PUBLIC LAPACK95::LAPACK95) - list(APPEND TARGET_COMPILE_DEF "-DUSE_LAPACK95") - - else() - message(ERROR "[ERROR] :: NOT FOUND LAPACK95") - - endif() - -endif() diff --git a/cmake/addLua.cmake b/cmake/addLua.cmake deleted file mode 100644 index 3c0fee1b2..000000000 --- a/cmake/addLua.cmake +++ /dev/null @@ -1,41 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_LUA OFF) -if(USE_LUA) - list(APPEND TARGET_COMPILE_DEF "-DUSE_LUA") - find_package(Lua 5.4 EXACT) - - if(NOT LUA_FOUND) - find_package(PkgConfig REQUIRED) - pkg_check_modules(LUA REQUIRED lua) - find_library(LUA_LIBRARY NAMES lua lua5.4) - set(LUA_LIBRARIES ${LUA_LIBRARY}) - find_path(LUA_INCLUDE_DIR NAMES lua5.4/lua.h lua5.4/lualib.h lua/lua.h - lua/lualib.h) - endif() - - target_link_libraries(${PROJECT_NAME} PUBLIC ${LUA_LIBRARIES}) - target_include_directories(${PROJECT_NAME} PUBLIC ${LUA_INCLUDE_DIR}) - - message(STATUS "LUA LIBRARIES :: ${LUA_LIBRARIES}") - message(STATUS "LUA INCLUDE DIR :: ${LUA_INCLUDE_DIR}") - -else() - message(STATUS "NOT USING LUA LIBRARIES") -endif() diff --git a/cmake/addMetis.cmake b/cmake/addMetis.cmake deleted file mode 100644 index b968fc4de..000000000 --- a/cmake/addMetis.cmake +++ /dev/null @@ -1,28 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_METIS ON) -if(USE_METIS) - find_library(METIS_LIB metis) - list(APPEND TARGET_COMPILE_DEF "-DUSE_METIS") - message(STATUS "FOUND ${METIS_LIB}") - message(STATUS "METIS_LIB = ${METIS_LIB}") - target_link_libraries(${PROJECT_NAME} PUBLIC ${METIS_LIB}) -else() - message(STATUS "NOT USING METIS") -endif() diff --git a/cmake/addOpenBLAS.cmake b/cmake/addOpenBLAS.cmake deleted file mode 100644 index cd8600199..000000000 --- a/cmake/addOpenBLAS.cmake +++ /dev/null @@ -1,45 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -# SET(BLA_VENDOR "OpenBLAS") -find_package(LAPACK REQUIRED) -if(LAPACK_FOUND) - message(STATUS "FOUND LAPACK") -endif() -if(BLA_VENDOR MATCHES "MKL") - message(STATUS "BLA_VENDOR : MKL") - list(APPEND TARGET_COMPILE_DEF "-DUSE_INTEL_MKL") -elseif(BLA_VENDOR MATCHES "OpenBLAS") - message(STATUS "BLA_VENDOR : OpenBLAS") - list(APPEND TARGET_COMPILE_DEF "-DUSE_OpenBLAS") -else() - message(STATUS "BLA_VENDOR : ${BLA_VENDOR}") - message(STATUS "BLA_VENDOR : System provided") - list(APPEND TARGET_COMPILE_DEF "-DUSE_NativeBLAS") - - if(APPLE) - list(APPEND TARGET_COMPILE_DEF "-DUSE_APPLE_NativeBLAS") - endif() - -endif() - -message(STATUS "BLAS_LIBRARIES: ${BLAS_LIBRARIES}") -message(STATUS "LAPACK_LIBRARIES: ${LAPACK_LIBRARIES}") - -target_link_libraries(${PROJECT_NAME} PUBLIC ${LAPACK_LIBRARIES} - ${BLAS_LIBRARIES}) diff --git a/cmake/addOpenMP.cmake b/cmake/addOpenMP.cmake deleted file mode 100644 index 1d61a1054..000000000 --- a/cmake/addOpenMP.cmake +++ /dev/null @@ -1,70 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_OPENMP OFF) -if(USE_OPENMP) - - if(APPLE) - if(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES - "AppleClang") - set(OpenMP_C - "${CMAKE_C_COMPILER}" - CACHE STRING "" FORCE) - set(OpenMP_C_FLAGS - "-fopenmp=libomp -Wno-unused-command-line-argument" - CACHE STRING "" FORCE) - set(OpenMP_C_LIB_NAMES - "libomp" "libgomp" "libiomp5" - CACHE STRING "" FORCE) - set(OpenMP_libomp_LIBRARY - ${OpenMP_C_LIB_NAMES} - CACHE STRING "" FORCE) - set(OpenMP_libgomp_LIBRARY - ${OpenMP_C_LIB_NAMES} - CACHE STRING "" FORCE) - set(OpenMP_libiomp5_LIBRARY - ${OpenMP_C_LIB_NAMES} - CACHE STRING "" FORCE) - - set(OpenMP_CXX - "${CMAKE_CXX_COMPILER}" - CACHE STRING "" FORCE) - set(OpenMP_CXX_FLAGS - "-fopenmp=libomp -Wno-unused-command-line-argument" - CACHE STRING "" FORCE) - - set(OpenMP_CXX_LIB_NAMES - "libomp" "libgomp" "libiomp5" - CACHE STRING "" FORCE) - endif() - endif() - - find_package(OpenMP REQUIRED) - -endif() - -if(OpenMP_FOUND) - message(STATUS "FOUND OpenMP") - message(STATUS "OpenMP_Fortran_LIBRARIES: ${OpenMP_Fortran_LIBRARIES}") - list(APPEND TARGET_COMPILE_DEF "-DUSE_OpenMP") - list(APPEND TARGET_COMPILE_OPT ${OpenMP_Fortran_FLAGS}) - # TARGET_LINK_LIBRARIES(${PROJECT_NAME} PUBLIC ${OpenMP_Fortran_LIBRARIES}) - target_link_libraries(${PROJECT_NAME} PUBLIC OpenMP::OpenMP_Fortran) -else() - message(ERROR "NOT FOUND OpenMP") -endif() diff --git a/cmake/addPLPLOT.cmake b/cmake/addPLPLOT.cmake deleted file mode 100644 index 821413d8e..000000000 --- a/cmake/addPLPLOT.cmake +++ /dev/null @@ -1,47 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see - -option(USE_PLPLOT OFF) -if(USE_PLPLOT) - list(APPEND TARGET_COMPILE_DEF "-DUSE_PLPLOT") - - find_package(PkgConfig REQUIRED) - pkg_check_modules(PLPLOT-FORTRAN REQUIRED plplot-fortran) - pkg_check_modules(PLPLOT REQUIRED plplot) - find_library(PLPLOT_LIBRARY NAMES plplot) - find_library(PLPLOT-FORTRAN_LIBRARY NAMES plplotfortran) - set(PLPLOT_LIBRARIES ${PLPLOT_LIBRARY} ${PLPLOT-FORTRAN_LIBRARY}) - find_path(PLPLOT_INCLUDE_DIR NAMES plplot/plplot.h) - find_path( - PLPLOT_MODULE_DIR - NAMES plplot.mod - PATHS ${PLPLOT-FORTRAN_INCLUDE_DIRS}) - include(FindPackageHandleStandardArgs) - find_package_handle_standard_args(PLPLOT DEFAULT_MSG PLPLOT_LIBRARIES - PLPLOT_INCLUDE_DIR) - - set(PLPLOT_FORTRAN_INCLUDE_DIR "${PLPLOT_MODULE_DIR}") - - target_link_libraries(${PROJECT_NAME} PUBLIC ${PLPLOT_LIBRARIES}) - target_include_directories( - ${PROJECT_NAME} PUBLIC ${PLPLOT_INCLUDE_DIR} ${PLPLOT_FORTRAN_INCLUDE_DIR}) - message(STATUS "PLPLOT_LIBRARIES : ${PLPLOT_LIBRARIES}") - message(STATUS "PLPLOT_FORTRAN_LIBRARY : ${PLPLOT_FORTRAN_LIBRARY}") - message(STATUS "PLPLOT_INCLUDE_DIR : ${PLPLOT_INCLUDE_DIR}") -else() - message(STATUS "NOT USING PLPLOT LIBRARIES") -endif() diff --git a/cmake/addRaylib.cmake b/cmake/addRaylib.cmake deleted file mode 100644 index 9c9961c82..000000000 --- a/cmake/addRaylib.cmake +++ /dev/null @@ -1,31 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_RAYLIB OFF) -if(USE_RAYLIB) - list(APPEND TARGET_COMPILE_DEF "-DUSE_RAYLIB") - find_package(raylib REQUIRED) - target_link_libraries(${PROJECT_NAME} PUBLIC raylib) - # target_link_libraries(${PROJECT_NAME} PUBLIC ${raylib_LIBRARIES}) - # target_include_directories(${PROJECT_NAME} PUBLIC ${raylib_INCLUDE_DIRS}) - message(STATUS "RAYLIB_LIBRARIES FOUND") - # message(STATUS "RAYLIB_INCLUDE_DIRS FOUND: ${raylib_INCLUDE_DIRS}") - -else() - message(STATUS "NOT USING RAYLIB_LIBRARIES") -endif() diff --git a/cmake/addSparsekit.cmake b/cmake/addSparsekit.cmake deleted file mode 100644 index 0ba985998..000000000 --- a/cmake/addSparsekit.cmake +++ /dev/null @@ -1,28 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -find_package(Sparsekit REQUIRED) - -if(Sparsekit_FOUND) - message(STATUS "[INFO] :: FOUND Sparsekit") - target_link_libraries(${PROJECT_NAME} PUBLIC Sparsekit::Sparsekit) - -else() - message(ERROR "[ERROR] :: NOT FOUND Sparsekit") - -endif() diff --git a/cmake/addSuperLU.cmake b/cmake/addSuperLU.cmake deleted file mode 100644 index 844fab01d..000000000 --- a/cmake/addSuperLU.cmake +++ /dev/null @@ -1,25 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -option(USE_SUPERLU ON) -if(USE_SUPERLU) - find_library(SuperLU_Libs superlu) - list(APPEND TARGET_COMPILE_DEF "-DUSE_SuperLU") - message(STATUS "[INFO] :: SuperLU_Libs = ${SuperLU_Libs}") -endif() -target_link_libraries(${PROJECT_NAME} PUBLIC ${SuperLU_Libs}) diff --git a/cmake/addToml.cmake b/cmake/addToml.cmake deleted file mode 100644 index 295bf1efd..000000000 --- a/cmake/addToml.cmake +++ /dev/null @@ -1,28 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -find_package(toml-f REQUIRED) - -if(Sparsekit_FOUND) - message(STATUS "[INFO] :: FOUND toml-f") - target_link_libraries(${PROJECT_NAME} PUBLIC toml-f::toml-f) - -else() - message(ERROR "[ERROR] :: NOT FOUND toml-f") - -endif() diff --git a/cmake/packaging.cmake b/cmake/packaging.cmake deleted file mode 100644 index 3cf7148aa..000000000 --- a/cmake/packaging.cmake +++ /dev/null @@ -1,195 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -set(CPACK_PACKAGE_NAME ${PROJECT_NAME}) -set(CPACK_PACKAGE_VENDOR "easifem.com") -set(CPACK_PACKAGE_HOMEPAGE_URL "https://www.easifem.com") -set(CPACK_PACKAGE_CONTACT "vickysharma0812@gmail.com") - -set(CPACK_VERBATIM_VARIABLES YES) -# If set to TRUE, values of variables prefixed with CPACK_ will be escaped -# before being written to the configuration files, so that the cpack program -# receives them exactly as they were specified. If not, characters like quotes -# and backslashes can cause parsing errors or alter the value received by the -# cpack program. Defaults to FALSE for backwards compatibility. - -set(CPACK_PACKAGE_DESCRIPTION - " -Expandable And Scalable Infrastructure for Finite Element Methods, -EASIFEM, is a computational framework for FEM written in Modern-Fortran. -easifemBase is a critical part of EASIFEM framework. It contains many -useful components which are necessary for building higher level classes -of finite element code. -") - -# CPACK_PACKAGE_DESCRIPTION_FILE A text file used to describe the project when -# CPACK_PACKAGE_DESCRIPTION is not explicitly set. The default value for -# CPACK_PACKAGE_DESCRIPTION_FILE points to a built-in template file -# Templates/CPack.GenericDescription.txt. - -set(CPACK_PACKAGE_DESCRIPTION_SUMMARY - " -Expandable And Scalable Infrastructure for Finite Element Methods, -EASIFEM, is a computational framework for FEM written in Modern-Fortran. -easifemBase is a critical part of EASIFEM framework. -======================================================================= -") - -# A description of the project, used in places such as the introduction screen -# of CPack-generated Windows installers. If not set, the value of this variable -# is populated from the file named by CPACK_PACKAGE_DESCRIPTION_FILE. - -set(CPACK_PACKAGE_VERSION "${PROJECT_VERSION}") - -set(CPACK_PACKAGE_VERSION_MAJOR "${VERSION_MAJOR}") -# Package major version. This variable will always be set, but its default value -# depends on whether or not version details were given to the project() command -# in the top level CMakeLists.txt file. If version details were given, the -# default value will be CMAKE_PROJECT_VERSION_MAJOR. If no version details were -# given, a default version of 0.1.1 will be assumed, leading to -# CPACK_PACKAGE_VERSION_MAJOR having a default value of 0. - -set(CPACK_PACKAGE_VERSION_MINOR "${VERSION_MINOR}") -# Package minor version. The default value is determined based on whether or not -# version details were given to the project() command in the top level -# CMakeLists.txt file. If version details were given, the default value willbe -# CMAKE_PROJECT_VERSION_MINOR, but if no minor version component was specified -# then CPACK_PACKAGE_VERSION_MINOR will be left unset. If no project version was -# given at all, a default version of 0.1.1 will be assumed, leading to -# CPACK_PACKAGE_VERSION_MINOR having a default value of 1. - -set(CPACK_PACKAGE_VERSION_PATCH "${VERSION_BugFix}") -# Package patch version. The default value is determined based on whether or not -# version details were given to the project() command in the top level -# CMakeLists.txt file. If version details were given, the default value will be -# CMAKE_PROJECT_VERSION_PATCH, but if no patch version component was specified -# then CPACK_PACKAGE_VERSION_PATCH will be left unset. If no project version was -# given at all, a default version of 0.1.1 will be assumed, leading to -# CPACK_PACKAGE_VERSION_PATCH having a default value of 1. - -# CPACK_PACKAGE_ICON A branding image that will be displayed inside the -# installer (used by GUI installers). - -set(CPACK_RESOURCE_FILE_LICENSE "${CMAKE_CURRENT_SOURCE_DIR}/LICENSE") -# License to be embedded in the installer. It will typically be displayed to the -# user by the produced installer (often with an explicit "Accept" button, for -# graphical installers) prior to installation. This license file is NOT added to -# the installed files but is used by some CPack generators like NSIS. If you -# want to use UTF-8 characters, the file needs to be encoded in UTF-8 BOM. If -# you want to install a license file (may be the same as this one) along with -# your project, you must add an appropriate CMake install() command in your -# CMakeLists.txt. - -# CPACK_RESOURCE_FILE_README -set(CPACK_RESOURCE_FILE_README "${CMAKE_CURRENT_SOURCE_DIR}/README.md") -# ReadMe file to be embedded in the installer. It typically describes in some -# detail the purpose of the project during the installation. Not all CPack -# generators use this file. - -# CPACK_RESOURCE_FILE_WELCOME Welcome file to be embedded in the installer. It -# welcomes users to this installer. Typically used in the graphical installers -# on Windows and Mac OS X. - -# CPACK_MONOLITHIC_INSTALL¶ Disables the component-based installation mechanism. -# When set, the component specification is ignored and all installed items are -# put in a single "MONOLITHIC" package. Some CPack generators do monolithic -# packaging by default and may be asked to do component packaging by setting -# CPACK__COMPONENT_INSTALL to TRUE. - -# CPACK_PACKAGE_CHECKSUM¶ An algorithm that will be used to generate an -# additional file with the checksum of the package. The output file name will -# be: - -set(CPACK_PACKAGE_DIRECTORY ${PROJECT_BINARY_DIR}/package) -# The directory in which CPack is doing its packaging. If it is not set then -# this will default (internally) to the build dir. This variable may be defined -# in a CPack config file or from the cpack command line option -B. If set, the -# command line option overrides the value found in the config file. - -set(CPACK_PACKAGE_INSTALL_DIRECTORY ${CPACK_PACKAGE_NAME}) -# Installation directory on the target system. This may be used by some CPack -# generators like NSIS to create an installation directory e.g., "CMake 2.5" -# below the installation prefix. All installed elements will be put inside this -# directory. - -list(APPEND CpackGen DEB) -# TGZ -set(CPACK_GENERATOR "${CpackGen}") -# SET(CPACK_SOURCE_GENERATOR "TGZ DEB") - -# List of CPack generators to use. If not specified, CPack will create a set of -# options following the naming pattern CPACK_BINARY_ (e.g. -# CPACK_BINARY_NSIS) allowing the user to enable/disable individual generators. -# If the -G option is given on the cpack command line, it will override this -# variable and any CPACK_BINARY_ options. - -set(CPACK_SOURCE_IGNORE_FILES - .git/ - .github/ - .vscode/ - .mypy_cache/ - _CPack_Packages/ - ${CMAKE_BINARY_DIR}/ - ${PROJECT_BINARY_DIR}/ - ".*~$") - -set(CPACK_STRIP_FILES YES) -# List of files to be stripped. Starting with CMake 2.6.0, CPACK_STRIP_FILES -# will be a boolean variable which enables stripping of all files (a list of -# files evaluates to TRUE in CMake, so this change is compatible). - -set(CPACK_OUTPUT_FILE_PREFIX "${CMAKE_SOURCE_DIR}/_packages") - -set(CPACK_PACKAGING_INSTALL_PREFIX "/opt/easifem/base/") -# /${CMAKE_PROJECT_VERSION}") - -set(CPACK_INSTALL_DEFAULT_DIRECTORY_PERMISSIONS - OWNER_READ - OWNER_WRITE - OWNER_EXECUTE - GROUP_READ - GROUP_EXECUTE - WORLD_READ - WORLD_EXECUTE) - -# CPACK_OUTPUT_CONFIG_FILE The name of the CPack binary configuration file. This -# file is the CPack configuration generated by the CPack module for binary -# installers. Defaults to CPackConfig.cmake. - -# CPACK_SOURCE_OUTPUT_CONFIG_FILE¶ The name of the CPack source configuration -# file. This file is the CPack configuration generated by the CPack module for -# source installers. Defaults to CPackSourceConfig.cmake. - -# CPACK_PACKAGE_EXECUTABLES¶ Lists each of the executables and associated text -# label to be used to create Start Menu shortcuts. For example, setting this to -# the list ccmake;CMake will create a shortcut named "CMake" that will execute -# the installed executable ccmake. Not all CPack generators use it (at least -# NSIS, and WIX do). - -set(CPACK_DEBIAN_FILE_NAME DEB-DEFAULT) -set(CPACK_COMPONENTS_GROUPING ALL_COMPONENTS_IN_ONE) -set(CPACK_DEB_COMPONENT_INSTALL YES) -set(CPACK_DEBIAN_PACKAGE_NAME, "${CPACK_PACKAGE_NAME}") -# SET(CPACK_DEBIAN_PACKAGE_ARCHITECTURE, "i386") -set(CPACK_DEBIAN_PACKAGE_SHLIBDEPS OFF) # ON -set(CPACK_DEBIAN_PACKAGE_MAINTAINER "Vikas Sharma <${CPACK_PACKAGE_CONTACT}>") -set(CPACK_DEBIAN_PACKAGE_SECTION, "devl") -set(CPACK_DEBIAN_PACKAGE_PRIORITY, "optional") - -include(CPack) -message(STATUS "Components to pack: ${CPACK_COMPONENTS_ALL}") diff --git a/compile_commands.json b/compile_commands.json deleted file mode 100644 index 0e56b6948..000000000 --- a/compile_commands.json +++ /dev/null @@ -1,2812 +0,0 @@ -[ -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FFTW/src/FFTW3.F90 -o CMakeFiles/easifemBase.dir/src/modules/FFTW/src/FFTW3.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FFTW/src/FFTW3.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_b_size.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf_b_size.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_b_size.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_global_parameters_variables.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf_global_parameters_variables.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_global_parameters_variables.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_stringify.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf_stringify.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_stringify.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64.F90 -o CMakeFiles/easifemBase.dir/src/modules/BeFoR64/src/befor64.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64_pack_data_m.F90 -o CMakeFiles/easifemBase.dir/src/modules/BeFoR64/src/befor64_pack_data_m.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64_pack_data_m.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Class.F90 -o CMakeFiles/easifemBase.dir/src/modules/String/src/String_Class.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Class.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/String/src/String_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FACE/src/face.F90 -o CMakeFiles/easifemBase.dir/src/modules/FACE/src/face.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FACE/src/face.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ErrorMessages.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ErrorMessages.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ErrorMessages.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL_utils.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/FPL_utils.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL_utils.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/FPL.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntry.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterEntry.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntry.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntryDictionary.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterEntryDictionary.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntryDictionary.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterList.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterList.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterList.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterRootEntry.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterRootEntry.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterRootEntry.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/System/src/System_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Test/src/Test_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Test/src/Test_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Test/src/Test_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/GlobalData/src/GlobalData.F90 -o CMakeFiles/easifemBase.dir/src/modules/GlobalData/src/GlobalData.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/GlobalData/src/GlobalData.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 -o CMakeFiles/easifemBase.dir/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/ARPACK_SAUPD.F90 -o CMakeFiles/easifemBase.dir/src/modules/ARPACK/src/ARPACK_SAUPD.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/ARPACK_SAUPD.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 -o CMakeFiles/easifemBase.dir/src/modules/ARPACK/src/EASIFEM_ARPACK.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_ARPACK.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Hashing/src/Hashing32.F90 -o CMakeFiles/easifemBase.dir/src/modules/Hashing/src/Hashing32.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Hashing/src/Hashing32.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Gnuplot/src/ogpf.F90 -o CMakeFiles/easifemBase.dir/src/modules/Gnuplot/src/ogpf.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Gnuplot/src/ogpf.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CInterface/src/CInterface.F90 -o CMakeFiles/easifemBase.dir/src/modules/CInterface/src/CInterface.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CInterface/src/CInterface.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i1mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i1mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i1mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i2mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i2mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i2mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i4mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i4mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i4mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i8mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i8mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i8mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_l1mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_l1mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_l1mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r4mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_r4mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r4mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r8mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_r8mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r8mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r16mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_r16mod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r16mod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_charmod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_charmod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_charmod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule_util.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/dispmodule_util.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule_util.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/dispmodule.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/putstrmodule.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/putstrmodule.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/putstrmodule.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/Display_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/Display_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/Display_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/MdEncode/src/MdEncode_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/MdEncode/src/MdEncode_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/MdEncode/src/MdEncode_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ErrorHandling/src/ErrorHandling.F90 -o CMakeFiles/easifemBase.dir/src/modules/ErrorHandling/src/ErrorHandling.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ErrorHandling/src/ErrorHandling.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MappingUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MappingUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MappingUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/BinomUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/BinomUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/BinomUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AppendUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/AppendUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AppendUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ApproxUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ApproxUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ApproxUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AssertUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/AssertUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AssertUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HeadUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/HeadUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HeadUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TailUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/TailUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TailUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SplitUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SplitUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SplitUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ArangeUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ArangeUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ArangeUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/GridPointUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/GridPointUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/GridPointUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/OnesUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/OnesUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/OnesUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ZerosUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ZerosUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ZerosUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EyeUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/EyeUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EyeUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/DiagUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/DiagUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/DiagUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HashingUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/HashingUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HashingUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InputUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/InputUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InputUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InvUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/InvUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InvUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MatmulUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MatmulUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MatmulUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ContractionUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ContractionUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ContractionUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MiscUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MiscUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MiscUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ProductUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ProductUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ProductUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ReallocateUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ReallocateUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ReallocateUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PartitionUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/PartitionUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PartitionUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MedianUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MedianUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MedianUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SortUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SortUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SortUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/StringUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/StringUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/StringUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SwapUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SwapUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SwapUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ConvertUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ConvertUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ConvertUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/IntegerUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/IntegerUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/IntegerUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PushPopUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/PushPopUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PushPopUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EigenUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/EigenUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EigenUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SymUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SymUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SymUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TriagUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/TriagUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TriagUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/LinearAlgebraUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/LinearAlgebraUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/LinearAlgebraUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/Utility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/Utility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/Utility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/InterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/InterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/InterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LagrangePolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LagrangePolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/JacobiPolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/JacobiPolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LegendrePolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LegendrePolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LobattoPolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LobattoPolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LineInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LineInterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LineInterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/TriangleInterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TriangleInterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PrismInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/PrismInterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PrismInterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/PyramidInterpolationUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PyramidInterpolationUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/RecursiveNodesUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/RecursiveNodesUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/RecursiveNodesUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/PolynomialUtility.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PolynomialUtility.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseType/src/BaseType.F90 -o CMakeFiles/easifemBase.dir/src/modules/BaseType/src/BaseType.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseType/src/BaseType.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/MultiIndices/src/MultiIndices_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/MultiIndices/src/MultiIndices_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/MultiIndices/src/MultiIndices_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/OpenMP/src/OpenMP_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/OpenMP/src/OpenMP_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/OpenMP/src/OpenMP_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Random/src/Random_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Random/src/Random_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Random/src/Random_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BoundingBox/src/BoundingBox_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/BoundingBox/src/BoundingBox_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BoundingBox/src/BoundingBox_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/IntVector/src/IntVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/IntVector/src/IntVector_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/IntVector/src/IntVector_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/IndexValue/src/IndexValue_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/IndexValue/src/IndexValue_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/IndexValue/src/IndexValue_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/IterationData/src/IterationData_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/IterationData/src/IterationData_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/IterationData/src/IterationData_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/KeyValue/src/KeyValue_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/KeyValue/src/KeyValue_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/KeyValue/src/KeyValue_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Vector3D/src/Vector3D_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Vector3D/src/Vector3D_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Vector3D/src/Vector3D_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AddMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_AddMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AddMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AppendMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_AppendMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AppendMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AssignMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_AssignMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AssignMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Blas1Methods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Blas1Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Blas1Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_ComparisonMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ComparisonMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetValueMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_GetValueMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetValueMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2Methods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Norm2Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_SetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_SetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetValueMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_GetValueMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetValueMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_SetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_SetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_AddMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_AddMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_AddMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceElement_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceElement_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceElement_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePoint_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferencePoint_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePoint_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Line_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Line_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Line_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceLine_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceLine_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceLine_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Triangle_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Triangle_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Triangle_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Plane_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Plane_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Plane_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTriangle_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceTriangle_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTriangle_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceHexahedron_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceHexahedron_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePrism_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferencePrism_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePrism_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePyramid_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferencePyramid_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePyramid_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Geometry_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Geometry_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Geometry_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVariable/src/FEVariable_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FEVariable/src/FEVariable_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVariable/src/FEVariable_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1HermitMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HermitMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealMatrix/src/RealMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealMatrix/src/RealMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealMatrix/src/RealMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/MassMatrix/src/MassMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/MassMatrix/src/MassMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/MassMatrix/src/MassMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STMassMatrix/src/STMassMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STMassMatrix/src/STMassMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FacetMatrix/src/FacetMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FacetMatrix/src/FacetMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FEMatrix/src/FEMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FEMatrix/src/FEMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FEMatrix/src/FEMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ForceVector/src/ForceVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ForceVector/src/ForceVector_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ForceVector/src/ForceVector_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STForceVector/src/STForceVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STForceVector/src/STForceVector_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STForceVector/src/STForceVector_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVector/src/FEVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FEVector/src/FEVector_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVector/src/FEVector_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRSparsity/src/CSRSparsity_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRSparsity/src/CSRSparsity_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatmulMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_MatmulMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatmulMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_Method.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_Method.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseMethod/src/BaseMethod.F90 -o CMakeFiles/easifemBase.dir/src/modules/BaseMethod/src/BaseMethod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseMethod/src/BaseMethod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/easifemBase/src/easifemBase.F90 -o CMakeFiles/easifemBase.dir/src/modules/easifemBase/src/easifemBase.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/easifemBase/src/easifemBase.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Hashing/src/Hashing32@fnvMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@fnvMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@nmMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Hashing/src/Hashing32@nmMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@nmMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@waterMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Hashing/src/Hashing32@waterMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@waterMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MappingUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MappingUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MappingUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/BinomUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/BinomUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/BinomUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MedianUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MedianUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MedianUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PartitionUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/PartitionUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PartitionUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SortUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SortUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SortUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SwapUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SwapUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SwapUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ConvertUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ConvertUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ConvertUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ReallocateUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ReallocateUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ReallocateUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ProductUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ProductUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ProductUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ArangeUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ArangeUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ArangeUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/GridPointUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/GridPointUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/GridPointUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HeadUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/HeadUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HeadUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TailUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/TailUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TailUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SplitUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SplitUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SplitUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/OnesUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/OnesUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/OnesUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ZerosUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ZerosUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ZerosUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EyeUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/EyeUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EyeUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/DiagUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/DiagUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/DiagUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AppendUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/AppendUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AppendUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InputUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/InputUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InputUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InvUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/InvUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InvUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MatmulUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MatmulUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MatmulUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ContractionUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ContractionUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ContractionUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AssertUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/AssertUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AssertUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ApproxUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ApproxUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ApproxUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HashingUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/HashingUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HashingUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MiscUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MiscUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MiscUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/StringUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/StringUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/StringUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/IntegerUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/IntegerUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/IntegerUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PushPopUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/PushPopUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PushPopUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EigenUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/EigenUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EigenUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SymUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SymUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SymUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TriagUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/TriagUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TriagUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Random/src/Random_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Random/src/Random_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Random/src/Random_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@SetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@SetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@AppendMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@AppendMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@AppendMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@EnquireMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@EnquireMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@EnquireMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 -o CMakeFiles/easifemBase.dir/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 -o CMakeFiles/easifemBase.dir/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_IOMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_IOMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_SetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_SetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_AddMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_AddMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_GetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Line_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/Line_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Line_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Triangle_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/Triangle_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Triangle_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Plane_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/Plane_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Plane_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/QuadraturePoint_Method@GaussLegendre.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/QuadraturePoint_Method@GaussLegendre.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/QuadraturePoint_Method@GaussLegendre.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Line_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Line_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Line_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Triangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Triangle_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Triangle_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Quadrangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Quadrangle_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Quadrangle_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Tetrahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Tetrahedron_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Tetrahedron_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Hexahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Hexahedron_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Hexahedron_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Prism_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Prism_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Prism_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Pyramid_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Pyramid_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Pyramid_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/QuadraturePoint_Method@GaussLegendreLobatto.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/QuadraturePoint_Method@GaussLegendreLobatto.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/QuadraturePoint_Method@GaussLegendreLobatto.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Line_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Line_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Line_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Triangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Triangle_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Triangle_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Quadrangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Quadrangle_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Quadrangle_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Tetrahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Tetrahedron_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Tetrahedron_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Hexahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Hexahedron_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Hexahedron_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Prism_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Prism_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Prism_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Pyramid_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Pyramid_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Pyramid_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauLeft/QuadraturePoint_Method@GaussLegendreRadauLeft.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreRadauLeft/QuadraturePoint_Method@GaussLegendreRadauLeft.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauLeft/QuadraturePoint_Method@GaussLegendreRadauLeft.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauRight/QuadraturePoint_Method@GaussLegendreRadauRight.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreRadauRight/QuadraturePoint_Method@GaussLegendreRadauRight.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauRight/QuadraturePoint_Method@GaussLegendreRadauRight.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGHermitMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHermitMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1HermitMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HermitMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Line_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Line_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Line_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Triangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Triangle_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Triangle_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Quadrangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Quadrangle_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Quadrangle_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Prism_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Prism_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Prism_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Pyramid_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Pyramid_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Pyramid_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Tetrahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Tetrahedron_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Tetrahedron_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Hexahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Hexahedron_Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Hexahedron_Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 -o CMakeFiles/easifemBase.dir/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90.o", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90" -}, -{ - "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", - "command": "/usr/bin/cc -g -fPIC -o CMakeFiles/easifemSystemMethodC.dir/src/modules/System/src/System_Method.c.o -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.c", - "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.c" -} -] \ No newline at end of file diff --git a/easifemBase.py b/easifemBase.py deleted file mode 100644 index e69de29bb..000000000 diff --git a/easifemvar.sh b/easifemvar.sh deleted file mode 100644 index e69de29bb..000000000 diff --git a/figures/banner.jpeg b/figures/banner.jpeg deleted file mode 100644 index 19cd1e23380fdaab96028ecf0032237d59fc6988..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 79230 zcmd42XIK;K_xBq`MVg^^hz&uiG-(00A|N0jy%PcH(m?`*M3D}GEnTWg6Oi6(Bncp0 zx*!4x0wN#@D2x!o$==WNe@=OEuJivrZ_ebpX70=+lUaA}S@-&U*P7GMrz;>j{(1v@ufk1|aAaM`~bP;s+3_FO9);dFbf#N(t=l*SjKsRVx5a{gd zv;Vc{?6cQ&|J6S8*FOhOcR)Yy+Zj5xGpBeEgmx9@&-}am`!(9?%vri~ z=P%G-WME{XeW00@cDZzPXV1}{KmX6qoQb3z2c2U(&wfSr&IJw=C;F=aoN~`!zPWhq zZhbG8=>+MzymMd_10y#NFCV|i4Nsu<|?*=LNP|6goQKmBi94_yp^CTkLwu@J^(V40YT?vh`DFnGQ=k#Qtj z*18vOZr!x>sJ@)FXN_Jv8S6JtR~_}0*>ycDVBlHiie5KMzPhF&*5~`B;S?0No%Q}u zIW!g?m(*ylp@;n=?ONpaIr}*Of<<(7GG4hXqjHSXMaK1Rkz7bUSAi<0)9!4Q5yMA{ z0T6Qvq6Z;IseC|oIo$ihDTqbmGDQ~%U>RwliU673irKN!QD@It6*7|?JN<-CLGe-- zuMeJr7;coVc-L7(KWz}xgT&gzD5~kOXQ&Pnko8HOC?$?#SX|FD5Xed-LTA~(iU~16`WQ9zHMq*` zeXWt+p`BiM`O|K*#{ExJQ!*F}V?{`gXuRoPR7@RmF)gVe$cvm$9BdSDD1SCuw=_i; zpB{CPhO4aN(P4+#;3o3?QzyA9{(O9R=CAW0PSAgC=x?qX3&G_H197zoo7H8`?;4j# zOZlC(iWoMpr@59z9IOxglaktI02w@Rop}@*wF;@}UEh5wZr@;#=yj$3q8aR7pvn4M^ z(T+_upu(|M0?n+h5&nDQxI^KG;X4Bf0;UfZdkW&AsDTryyuci8N$Hb_IQpFjf3i~1 zVe9D^ z5k`3#5FP4xQ7BN6}D=GWMV>pn)lxw8wQxKXe3QXY~&yuoo z+Pmi{7FF{e3xW5CM!DXbIU4XR)Yd%ZY@FKRj@X*7XDMykmlJtV&MWOXs2!UA&uz4~ zwWmHNOsKg+T$}=@`S%;Va-VOxxsXC9-aFe*bmg4Pv@t7YI9BESS!%~-F;%R?Q(#*c z6{yLsaq|?^8>Z>5++|Zi(F8nQRwrINdM?Di@*$seU2%WE=_ok2{^ioETF+%hMYId{ z=rE~E&9nPwEvl)xi1A0_qj~SwULOe}ghD5ypSMh#t9Mj<(|^8R@R3o`_4Y2-Y*DuR zevPQGmwy|DZ{CB{PT-x$ippo)e%Haf2F@^zb3DTbID*f=T9HfcZxt`q`T;zcVw~PJ zyVX0Wf+LL|Gy;CdRum7_>>c_lgwrV~_7ebebInBFL?}-0Dprer;8wC};}1>j;gBlK zuB9;hiCir_d@$VwdHbD7jn1di%V^mH$yi^dHWPF}roublNl(V6WS6!_sQAhJlwoK~ z$EGkHwZ?rm0@ECXY#&$qWdN4oKV4_tMeXLSIB}66&RKChTa6hVHA;~H=dT9*WID{T zWzfk--QLQfrfC$NPMm^Rn+dC!=cFwpQzJlf(tc!j1)*OdOb23AsfT)kFX6Hme5 z3sp$VadqG;s|hPXmGf&#S_~h4HH`l*QYUIeyd#k8C1P=_vN_+4ytBVd<8;sKKMf%( zTy0-H-Xv{MnRE%L`Kfy(3=W(`yT0GGUv%*Ys)=8KapEq{@1ixF=P%NFrr-toDTG=i z@n*31a&m4=%=Be2>k{Bi7_F)Bx!K9z-zh5sf}-2oJs(+;{1`!t|6qKWd>NNLB7>^5c2@n&12*D>k4u|tcL`J;%fE% zs2rPa2yH7CQ^xe(l}Ftfn!cwXcfWn$YXn&9J zB@15f9`@ z?JN@%Bz?6tQO}0G<5ru!(e0*NzytLshGCeenf!qjO3nXxO>ye4qE4Bfqx-rv!cwy6xQvXc?1Ca%Lbf+Im1ppGObc$>{;rg&ww7>|u5CX$1+DxnK0%tLnM?a~PC4b!;sp650bSN3D;q4q2$ zMO;TBJC1A)giQ9`!72;(qZcvxkR*(dh7<)(W`gGt$5Vdq^8N6d%v1g?@KQLvWI*m^K$x#*O}$8-)047C^f0gX z$dUF{it$i3{3{HzJ7<__zpL_4j=ODcw$cnag9H8q$!-ek>UDWXyp`EfrEj2hbnPSo zv-0*7#N8vdDGy0G1u?s{kThO!=+;mt4wO`lqY&pynr=ox?R&&}CJ}1V#nsb7E}HV4s1SbEyktNf?=( zBpk_}$WrdCcJ)+|t)i~z#_Z+#s?;U}w(}@v|1y}kN#iNV+A=J0crQF>D6O@r9GA1{ zqEc?8?8}!gkdLy|5JXr2e&h(;Cb1}1<2Gp{MS(kjV;P7rYsGM<|82LOi|)A9IVE#9 zYSi`Jmj#DPr(DqcGK@z58nD>Xh+8E!lQOGA7^l}Rxl%s)eXW4(_717@m>qw4p?vrP zsx{uQeV{L8M5Anj{vyx2?w?)NAxf<*phgsXZ z+r&-Bu%8Vh!fsz_YAtj#ugEAq_fOax;yX+gJOCnMffq^g4>a^}D!2a$dCR@{kQOhh z(fCn^o94mab&Lx55knSLGvEH1s=fY>%2);J$ud-?qT|~zcpM(aLgn5>7RBU#SBoI~%#E(Qt9Ph?)7hWSR3*3e&3ad7R(rFqLJ8#wO82<_^H|)AS^3Din%<# z{#D?MK-?#yYP+v14tO%W(6-DZzK65GRrI>^O5P)=!k#U+xJR9Wo}>!cr=}F~XQdVWy#$gqfj_qJ8Nml7&2 z+}>^Go$(n;4_E^#g93FVjwgMtcQs>N_B6Sb^RVwPSqKY}g;VVC>|+YU@SCow3Cc-o zc-w%|lO$Z5s&)QY*%gCa&LBq4x?iMB+x+^^Zrvp)EyZ#4DTrj`0W~3j0S{wFxYa=v zKybS8u16KvAc+!E8dvH4UTpHw>Z9R~6e55`K&te-B(mMEAVvmZsSv=>oj9sE z%j-0^HyZNkhf_`WTMKcS#8PGDDU8nQDA?1zs>!pg>9E;-e~dm#<7Lp$eku^xUgJ$T z1)X!g78Axp7cj@MvOlI8dx5LHz70{F;PnlmOD&dkb0owL`>T{`CT_V}XKbjr9!1C$ zoPxYgK^LeqC~k^$5t{-mp2~kxda+L51sVQ7 z#T35V9))bKeEq^%?$AA-KFLe;mk*S?97E&tONH%kfawyeo|bM;+D}m9dw6IwILrs* ziecDW{cyZ0Xfi(_Ge+9KPgJs$iWKhWbc76G!2ytNYy=`k1=U4~FFl(2hWh$l8MzPgP2$81%-S z7cnYWRC7^d`A)>K8g(X|=U};4CLtV>=zF=vpa6!Qy1!tIra*ZsZ_Ob@Dwuq{#?BR> zJG?x-HPHV;t;EM?nVl6@r8dZ)dOcO1GS;1#+^4@kQKiTnSQ%D|#K4IGy3JcC)9l~C ztmJBa*bOJ|CXz}E-*m5K{_E~yoN8UaNp$wCf79c|Yrm?!kWV1Dlt>+AT|io`0lu#q({k&q^d<3JU3s4Y~aS2vF<*IjvA z!y&3P_|N4nT0j2=5Bm5Ks`nnniqzVhRe1HJkjgKLPrbO6 zRnG)Vt&VUd8po(Qtlm+s}dC;#k%1o@$uDmPU}UrV2YLU9P5 zxDi>?;{4SmdJY}qJkf`l%-9m=Q&0lpo(sK>o`X3~@}4VwwZ3Vq4Cxd!DY2PQM1rt5 z?WbOZ-++4J=1Up9!NjRPr^cEyABf&}m3ohbA^k*Ih5c~$if#AjM0;JZRdI6Z^#;oD zrTlUVf#L}4l0#R=;|1``++CqHz_5u`#=O=$`}n3vVU>6}yYIFv8BZ6a6Q1C2!h?sI zEHbl4a-gLJm?y)5$*p3=+j83?f(nxD`Pagm`R8Y=rM;R0X%}@NO$g8Y=8^nQHu2L87e)oVChqrWUV0n++M^4J<<*-Cjh|KX2`={et!uT^N_}FQae>@)Q zPRd7)w{}1|hHH?Mg=gaKlLoe_GFQ z!8!jR1~9%Qg#R6w;Yz0O)r{3_G=3Ibl!%0o?w>SV?`};AAm0_psnK*po%KQ=29E~e z9Jyy|x?F0!TTC+(SB-%5kQH^|m0?x~CX+7;`tR0rDEmBSGS!KvAj>d2*u#K;@qpk{ zP$3$jEk^J(O`9>MW45qf_*tzskoRC2CrnQ=j&7i;4JkWCUKdR)X2fibs!nggMX;YY zz3Obr^!{GwO}RcA^gw|&=It2z;VJCHmHSgBL*x|s=VYZm;}jTYkNlF2F`2$EG`y^+ zMD!(Lnb}6m^9>-6ZF#P*>q_vW|6XSe54zKmB2;$@!gm_Qdai0K1=-(cnwwtxV+70W zH=vJ0t4xPh$LD3*TVA#5EWE~HG1l#=RJ$v#kay_9Sq)j2hLR0ZDEfFpCHW~Te!xi% zIF>BBhMjtoNt)G)Gf3mLPl}UUu(r>;SM8^rlnd4B71YZk^#|M?bP3FNeV|Y| zWoimXIEWxL)EI7OH}|f3I^W97%Ji^sB%H7y@tP!)Q&19$`%(4-V2aed3zZ@OSRnl% z=2OXJ*Oe6%OCSH02u!>T(R=3__Nf^cs>x_cc(%HBEjcXQ>ViG%&e7EMRfsw^dg+9ZU8JAG%0n>NPuTe4+p5Nk@h6qWpo{!t? zyx>MZbEWkqA;Oa^*5t5yK^SzGMufb!XoH36Fb#KIE>ns0GdSy4YP!Eu33GkM{|J8y znt+}LAAA|-s4~Ir;-^T{c7A(1=t)UiJ@xS;Mrj30;cgC5MFEI0e`kUn7J0z4-36y)Qt%keGWEVD8N z{lL*6=VAW<*amjU+Ywy4Qx~$GpUG^YYLPExqLpS6xVx2n^y$AT&Yw>G2M7V+4kk~^ zno{RCdToU>A$Xc{cM7_Qyh1T;oB0Kf6;=dV2^eKG%b2P)Ak1XI z`KEC?gKehOP6bK`)oK-^>1#=LEl)*xJ6QEWSc4;d3So2Rw7^hT9#1u#UnQ%)u)e|&N=pTNioFnheci{m2ZiJT50X5?au7%**gU} zA(%$HSZoaKhQ()VhO63b|K zuxwzIN$LlSF(f6j;#d&wa)3+6hqoqU+@y5z8VnP^;t@shFt!jw7ei8cuaBrUQ(lr^ z;=*Bap-dcqN^;hI*B;ytKjF0p>+Aaby|pnK-SW1|VJMTB-KWmUPCZV4*xaGE+%iDy zk#j2q>q=q2Er~icPw!U__{_0>yAl z+|P_7eoQ{`b1uaoxr|qem9Giag-q@mMZVdVA7t@oB z9qJWZVE3=2ozTLYB#q(#!Z3t+^WL9U9!ELylR4Ya*k54gp_a7}da`e+=j*R{v`^^9 zH3gY!v6;YbE@{_URl6~xO%bZ7pIuQdyfhE)kWKpfKq;|VIlM+YHM`+WraL@5EajSf zA4OsF@%)3E&hnB-cOH{SM-?Of8r6(%l_tU8+Q%oyIpG^rhGXG!!nuUsumwCuc> zviqh>qwq^sh|I1k<3#J>LV#K5^1R60A-Z{(GL`uab)SLIm;jeGQ(aj)Q+Rg%g5m0I zCtX>h@slbos-B>RjP%%k3h#$VQ;yQ-xPUP=IkakesZs{PV{j}k1v#B-yrWH~C-n7~ zld}6D;GXNqep_bDlLpfG_Vdz3xC^2D`5V7qNnuDS3M5Jmm7pO+RtUJ)8oF=_>f16z z1_WJ4d#^Hmd+AVC+nnLY!}rj3A+hNiRoPRyTP8eVx1?2f9&VRJ!o&e7g#t-|HJ1q( zzWRv+#eGel`iCPxI<$gh9>)+6{nbcdBye8eH+dwB#H}1Wrd$lN$yMnC0v?&8s7sZLp7L#={C7;x{R9z^2)1+i8QeB(NvQ(=$ zQ;?YtbkCRDMaOqNqlGE2btd{MYiEJ!n8KNyh{i7K37~M`*?nyfO*|vCs#k zpdqqJS_gKV1#MQ2uCmHLRMrpno~u?U*2&lyO5HX)0H3_pP^NhcRq*!Au{$ChxU-5` zU~;UR7A3XfQ0H*8RHAO5AA>azs@pjmlGCFApTf%3;zrd>8mFE>JEdf+Z;&sQOKze9 zh%EMlx02>@)9-Ri9ZN(^mOdqRt-6Mei}l>wX=ut@+5q-fYe6I(*X&h_9?AV#8}2IU zm<|SJ9#4>Or}4CZjSoz=Zvy+MwD;9*KjRZ8ywjGmtl&(&c#|AO^5!tuSO#m$o^5s< zj9fyo(e!k6`EA-9LS^ zu_j%cddHYm@MO`ZT|biLQFkgG+#5aS-_|V7+4W#lND_6%DIk9jH-mM;)Ya!C=H!pF zB%q&2J-88q{^&K)?^OBjk-Vfr*cxRP@d(%_N31T#gAo3cTlKi(* z(q8tkF#XkF7s;djysqbQxKB)ZzST(EzN_TUajad2Yr8hYDck9$)9anFmG;VM?`qqr z^(u>l5K(D|V%IlRad;BV?;<7Lc2&vrG=2DbU%wgLR=IL0%Z`R3hZU|iI{yg74e1RV zu}mzw3(ezJg}!E4?l_rbO%9Dq-t1dNEC`n>!1m`)nMSXymNeau<_80QlZP(wkH>}`?gV}SHPe?nWuCcFdGW$1}o&=*mxhA(br7{Y?gk)N6=uoV3>yaXj+zJbg3c^pm zC=%uT2ECKB)}|rcPZV_0Lsi(!*v-}MxL}cE-wMS53DUrU14$!+EIsgH=NM-1HT%if zovb5~vvHDz5Um{ItjT`oxx_i++hs;fWwl;Zn*SN>7tgZcQ z&&aFd>ztkzxPTeePgN_r;MMiaI^_}JJE?g0_Md(+)!~YJOVWM*DeP5G!!&M-duehb z%z+KE!K(U9Mvo@hVz#)YC>FX@lPIO=yYk%w?*TLb~5TPxi=*`(aXOYgVe>uc$spmwOcj;5IjI{;bgx_D|ohQCQ zMI2>EDZ9i_(}IJTbs`9BFs6O`j*K7f!g3@X$e9edNpuBokOA8OMWt}Hp$0POWuCe# zPE^)a8zw8~HaqA;VPG2aarz-DQm{w;%}0Uoh{c4pVqA=0wlRd9D$&vuKxaP3ykC4sch98-$>)n zDC(~61XNrPN2|cBgdYoB;%@BlUz7L%mFTaf`MH_Xj|8^1DwKwn4YR-fLE4Nvfy2Bh*Ka&q_4A_YXbe@Q6oP)&ZVv?!2F-e zj+^f~?Q&UaJPdFAac8(2uqm@ff~%##ak%aER92EPyBkF||6xOll32e5cC1=aL^Q5% zDk)gDO|PlD2F$0+7W2M)p~;a>Y#Es%;+pcZf|`{XIA0(l@#&uWY@JYv5U*eWBhX^><$|3l`gT5Hc@Z>liM@E251stD1X{}ud_`~JLx zkj2Eri)+QqRT9z`na|H#3$lG2^WMKuT|80E9|`_dCYQX*cURve%{2M#RPx)I>9;de zhH7O6xigNd?|A*v}PgZ8K!x6Aa#CJrl|-7ZK}`r#}j`<;l?giC6-J3YV+wk z_Kns&UY6NRYe%T*bcP&{N*^m zC2``224*{s^e#|Vd>7XKj9DJq74^G5Ai6%aPtUn{s9qw$70+H6X_i*0Up})2&E@hF zyq0XLyI~Oonb4ipY!E~>4qzaRZ%@A~DysuBQ`6n(IOXW) zgmOjgZlYk$xxYI!3rMU-23@Vnv|=E~{anPwO()C@03U$X1Et&Q4e&l3JN|B|xOt&4 zd6*|5rAAiU^k9f_OykV4!@#lqB1JvQN7WCsMD6!qa>uS7Xt0)VPk2f@d7Od>(hZ-^ z0x45{L}Rh9tpoSR(HGv%F}AYj=Z>|utQ~6%l-E;v#uoNbbHn3glVe(h?n)4nzEZ*b zK>mk@yiqnqT$5L2Il;okb078CYM?c1c1SR+J8{MRB=xteVVlT%l=M~x^{x8UL2%MR zTsE;V3e#{zG0^1JqG_bBDUzx~z;mCj&pp$Au>07uXT}+dFW$?2*K}P}d@}zhs;PWO zWv*dkV{_{8^5CMwuir+lMZi=E#mdE!n1AfJW zH9)HYa0>DybZeRdBE|4=>s$l7$DO3U@>q)YI}u7~Rn^xpEBQNLw<`t>wiv~mT*Olp z97g2~4(afO`wjPsS znY_QhbZB=?$ZWr<{V>i0VR{M@GEOvJtK6+PQNp2gk&sw#tt6Z)HpIo%Xf>lFJ5(Y&@RjOzOuwA%G)RC5k-DWxO!1v#MY>6hxK^k1i zE}R)ITzI~4J(0(0mb6uqrMfOHDAVoReGY3<8hC{ig7@qjO)A2YFdWy&;1|Ees(&xj z!QU>xc)f2e+5)Lq{w}Lr?swVTU#e}1b|TYPqV%}O4ra!VsI70(*4kSPG9-QZ4k!t%P+@if*+6ldDv@yV@ zyu^pOwCXuA3b%v4(YQKNG5aQ;^wWh|$07yo#q&md3OB%`pYg5kbFN&rLWF}fYF_uC zbo$p0`zZ*wj~s&VQ?w#I%RD=ZqPAry79{$<1!`%4P<27`#*2|gcroGqLguf7gWKhQ zb<9GQ%5^4}mOd1JtFe7a6pYIMfo&iP)+CFV29wQVAxb!tsKAUj36rrZX3_TFDl082 z)$YnoAKA0OKwVG!SN296P0T((ID(QbA#_m#{$m_GMQ{VWO3&>kF{gJ#<)8)gakzMy z5|?Ex5BMY<21#2Xi09-RiharWg-R@HM8#-2vxpBkl0&i8-Ulzqk4xXA_8*m)E+B_{ zxaO*V3Xg5*w!OfGXHZ4Rn0SS1%cTvYu8A(!ckm1SHm@@wxQ-}o@i}f-0a3ZKWYejU z(MDLvit$$R2cUASJCR9o_bdP%IoTxN=5K|L?(S^miETm)4c+w zil%+@m5U*aIjFOH%nO;GPFt=s@4mGSwQq2&1I&@kI!qi{>=$H_=z-SAh_s=n~xEL2J_|D41aI7vHr;66S@%eMzXwn_j`|e>n~q zr~Du)nuP@fT$Wz8$zD@tZje7J6uwnqWeen{Wj=AdYS->8Yhk}N>rNm_E;+j)=D9s$jZt26iiW6bo8H#q-F?8i1g$?}-NhK`4&UiP2u1tn&q z&G56;YGXD<%ssad4*-?-!!;B|a!NhHZuni#XvLTLVWIxint4`2(=Ho;JW{I$<82=& zT}x2d@iW3S_~7#bm*tk!q-Y^srXY=nuCgIM1zA?;JBaGMxA&TOmup!dp0QqC((Gjq zWh2T60DiBG6<2DmjRXoBh9d`rbXiQf8n)+{r%Zb{RCL6-_PRFcL~h<(X@m;PutQ#wxWDElPZ7!Yk8gdEO09@j;zfGj#q&p`Mbj{iUlh;xhpW zN-fgSxh75ZiJL`JT|8Lmm0#(_ImG&|GcfFfEvaJDo*-H|-$U#Qg@?uz2Pw4zk8KV# zrH0`~)z)Iv;~4qxI@Pw5Ra!BkybEUV)D=VxMJSun{-!xvK}1B+MHZ}FsDMwdyZfwJZMcJ^Kto=SUiYS zp2h`8>n5*}AaV7Ji*>ylIonBmb_x57voRh63$A?lHc=)^MfJ=FG+g)BP@@gdL)rk< ztg`_I@ODtyx2{n66)?-^dBBda93$0F7Q)0qx!!2Gy!PxDTg3Wl=XaEj(3t4>m6BSd zG%S5ZZY<2{9gk;lC~6hLs*^cokF>PR3;F=pYk9{ z@-R??ZP35%Nz#ipWa9e6;xy8jg)vjcN_YPC%`ScHxR4`1u^yh#{$Rc5pL#hoDb7*& z2H?Fa6x6%WoBFZ6=zix-p9)*Vm!=c%2RR0%TOE({@@Sx*r?#Vkc&XUvuGpg{)9Yp) z8LP%(z@dMbSOE#o#}sC2du4b@c$#Jq6en#9MK1*G^1;LMBzOPi^pQc_yk%83QP9K1 z|7hPy9?D{2btZS^e zYHS9yeU!4?lxVex8p2yV3%W6s+rlDgKQ>HBG6@PyorC-~K3!LkA6;tGM*`p}98pz* zvsr5NGK4joYEJ{Xe+q&e(53u2iAT-6Q+Gv0c96^LEh2+RbME9x z@bV>_Uf*-Iw!L@PPjS=-W)CX?X%xT9o+2Ld@+? z*AJ&3gnIAu=}r}s_WQkVoaILPO~^1{@YoUI3=EX?tqj)ws*S@iKA}%9MnC|EGVK*i zTzE)j4?rl=oq~$4T!-7h2GH^%ObG!*xVnfI^D&(^r6z9U=D z5B^*=^%NH$n=R&bRMi_BEJ}sH{1rzQz$1E!SZ4ZGlr^9EC(W<*2>DAh3M%$~R%NvR zRBk2Rt7ksyR(d?{okx_dQOy7G5X~h@cdSMlpd>j8pMvUy(@#Mq+`lP(FyJ?4YsdIR zs_567m#3hQ*9=`Rt|f23<$c< zpm)e;G=zZie*TT5_Xw#cxizh29&<;xGrcdBgX4BeB7-a%V!iG?uW1jed;BCZV6djP02(eDf5R1@%>93jE?wrN&I12tP*5fg}EY{p( zEz$aO$;&|j(BM^N@$Vnx>MlRK!?g<8`X$Q$GMOMY#*vsWdZCoBU!R=uxTcivMy}_4 zc}OI0Kdl{d>$G7-esa^INjBu2uF#UthCS&d!7lYr5qd|{FTQ%PH)0TbPAo- z=)?F`F}T;MvcfzgGCe8L`&FfB#-DcIX;(2Fa%js-2kQ8~s4xxr?)xzXJ&D8h2oZIO zmK+InHvOL2?u~@5PA(!+_iz8{y|w&_H(DI8*1A;s_?n>_?y-fignmLLk=*PQZ&4SN zSCX2G@<~7T0_1TE?k^~j1Rr`r>oyK0XHU_Xz_@+!7C_B=<6HJ`r45+Zla-=<{i>m% z?;Yc{e|SOIes|mTkBl735BPMIy4rmy$w))r*yS<+WJZ<0>UBEqXOwQ%A6Z3t_u6mV z!f)_h@=PTfbG*AVIZp1mK3!|pC)iRVT}AMAebueX6(}jfBdSLLg3iYdzO6Rm61SDh zURMu-OvO!{f*N+?F`g$pL?3kac5wii9~R#+f^yBi14O!pR^Pys#?GtPCP5Vs>`v(H zN%*^gM;XFWQ$HzcejJMZuj}#Xt6O?Arp>~>?xn@mbB9?KHI#*rr;Y9#!eVPnye@FJ zZa=OH(l>Z0y^J?Aiq)z(DvOSDPCf}+@bmsLl@`1Rp^grxvqjv1abrlFkA z!xeB_+gNItJc%PJr;FhuB()iNy>co)r5|7lF>I%xmAAqgevHcq(UWWh7oqkuZBO;5 zJ!y&(Da)=1utrKpDZ<~j(VlEf+;Jh-CWg?ROZze^(%hfw7vz4k0TWB*w5;)Tb{!tn z7e{NZ#nEav`ZN=I^1Pbn%#Ju>sVRRLM?C`E6IGVniKig`N#tafOW(^DjS<(XKy;4R%R4-5EOit~=?I)|%}pV{y4UQa{zLYfT*uhoaXT*hWe z{@lhls>w=@;M4T3rv>Ri!j})gG#7DS6@f^0iY6g%B__M9Zp4@*JEtW(H`;FM+_br# z)}Uu2#q}O>-hN|uV8@ukM!&MrCuMwqCF%A{Xr2LHQn}&o_kg&vEn&?(qpWdky;p8| z)bCO0Vg1ILU1*Xa%rfFje43B^{j?+M82e#%)+d`j5$w|yCs9Xv6GXkKk>#N;ai+F0 z^n1-*Sv^(q$d{bTXbgCKa$>8KQaf^zvOl|&r?VRbd#T&)f%Z*GbF3glN=;)I@hecOXDOsp!*nt^^ z?i5tvm~QKa*^?N-Y}4`4rn}!@O&s`-ilZ=UJ_rjt!VHg>_J~kFE%Q*%BWEy8i_4dw zP7!6E;pGFh$tJ)HtZnquqm3x2v5#mfMVqCsHlA{&sxR#Ij|%mcEz3ghE2wkq_a%3w z3cB#5I=dHz4|*0*_#l|qXog9BItixc07ym&kP&e?Nsrfj-e;-<2aFWkW8VC*(I z4sXmzi6mpoF9ZmS(mfjh>WNT!B&7dtiYJb5je-0$K);!JBQA*7Iq*Hg>r*$qZ5h9E zhk3b3EdEpaMpi*#@$n7hl-1LYr>(CCk8e<%XMGg@^;Q4}1c;K!T>1Tm}VPwRUptbi#g4!>2%t~znF4^d*=x2%h<2HE1O{{!* zYeT{4hlzpNEojxLr^&9JsZRy?ej&-Ul4bf=Yi389@YI~y@;KZ&LN>Z@V~O2;KI?{8 zfjGQ}f1{$%-<}Lln82BYsUvWry}i?Y&K^~P!g*w^13Oadwr;UCJe}x{L$OjPs1j{b zf~tMBUufl1aoF5xC9v0mCFcG2>}&lOFwo=3uCBdyHUT2>wzNvYky9V z;#I1=f+2$GV4+QeteVL9lF96*V*N^Md#Rgutt>VrgR?v4t~F{bryv+UB9m?0I8;}C znZ}?V<6A0s3tjIxH|)~EQS#-s@UTbnh+)Z^w(NwUC(?4!o92W23?xVX+FehJH|XRW zXDU-iA$pVRR_1aCxVbC9pY}^Msfimg!>l=g2F;1#~7}xm`5(?5uHEP z?lZm*=^{`eSKR$7hxZT|sh~oBG?^=;7F~POS+*@9B&6QLRduR!F8!5R>gQ;)dJ1Ns zM~b{0zr_$ulq8sb3>*)=PGC-Di2Vpxx?Iwpaq}@nKGO{6YOQ7kC*0!xQ}yJj!}E~}ab;Rz~3-$2`Eu;}k_Cg#$8(Z{mmclbNSW%A-ba!Mh~?_7UpYskqa!X%12fyn1c)E*& z=&cs^IL)TIi%t1%=3aZOJP)>>CgnA4x>>6<^V_(&TF^AhVGAxn43|#+4;TJ)K-T=m zWJ8v;TG7-Z9TqC_>kXb*2P3mILM|z{vgnsS8OEb7HGI}&ys6Lm)sxt^6|)a@W0E28 z4rMBt!k2i)Z#8)tg?O0|61%#d6E&k@4Yk{m)jw2a23XupPs)%=9vtyCNOm}*p;_-T zBSH~XFD*qRx27sGsrj*PP4bpRZ5^xOIzl?$xKI6#aN+p#-ed&+BEj=+jfD{(w}p+P zN{WY|$E`#4ZO$zJ4Diqu{C&1JPc>v|wrUh}aPOLEQK$h?mwK%gGR4h4?Pc zxejAoQS`xOTrou$uq)H0QAi8-o7U@AwvM^jRagdVLl^aO=X8CbV}!?!L4#F&mj9An z)-=3EKWDK&e0rpjF_jCQ-`QVsvLHS-Xp$WH_4?QD-H%h;WlD)(!YSxLVF>j*chES6%Vyq!vr(3@@^zM* z=oxe7G(BYybNYud@6GXzbNRW+W*H@u$)=q?-_!JWT7KzCA;x!uaQef9(KFUut`iES zu8*`Nm@b|*a->sPNKeXVyhHQ3tKbed>s7Lk#P_ zJw}zvaDBD+h3_^r$7en<#c5p+uQE$g>#O4NV^t>45c|%lB&i|6(sxAsE9?_UEV5C| za&56iyXyxVM+(2778A*lD))BDCz@h-vEqA03V zSh$>JUtN8b^D7+_>yWIeaW&yV{*6|-rS*|?MMN>pXsa-|8rh}YZts2~2b+NSK{#)p zxWNL+**$<`U!~Tk$bgE81KjG-3kuXpv_AzCKO1dY>*I8oUE!PO-qtwcIko-c>A#8!6S+Syk(V`p9EU3S=G%KOA3>A$sYqk4DqeE42}62F zhIGNBdwhNMsGObeFR!*5gl7MqqLxc?qUvrMyTFSc(ue6Xlja*b9Ao&eMQ5u8rAFhR zc*o+L1;+JHl?;j4vU)}N+4zfXtDe;dJq8h+7C=7^ezEl$ z{bCD2y`&{DN{yly4-M&c0J5jPq(Dz0{ZQ$khQ!V>mN@-0aj7sAj!>Z6QbakSA`CfN zYAM|rK#+7EH`9(wl`d0A3^!_ zcJfkXUM=8w@s5y&VX8}ge`}RA#$KA-UR15THZjmJf4U?Uz4hp5owPaJ$uT@ykxWX9#a|4xK`1`9Ynk0b!K(V(5kNdT(WrBe#!Ax3)riwdg9^6q zsk&g_?)Hs`o_Y>Xgj#YW(iHfd3NMFQhZca-S(hNwi-!S6V3A^;IeqdnnlTKy*x2FR z4QjB6Klq&m;bCa)Rl@^m-dm#)A4G}b8xn%lp51C~ACmqTXa75EV>3}cKQnwY5SF9X zn>3x;^=}|&WLdMsxfOeOG4z%!{0rp~!3lPv#j3y7qgx4UJGn<}?F!Bl)-6wMfaZZB58&xGchxX2EZyxlU^u0V3lj}gm*m}bG!jfW3b=IRS`MocrDWUHih z-J09z#L;A2C-)LhNv^Ov-T6As^C0+b3+KdOgGokJ8c`$VHd(RL8lV>z^vY#42RDZU ztXF%;m4r)~HYMk@gpVOT#MuT@AWVZvLh)dIuT3G_Cl|j+uk7D;nyEV}TUz-FIZ2{k9gWR*=9qVKs7w=)XV8={bq68U zW=}3$XnF$1B=yt6yc5dg`a3U_V#BOTMs2BMWjYHM8D@YRBO(1F1O9mxafP;X4z~FD z2%0#rogLgF=&7rH(cM)-l%^3^KQE1ZL;3)N=Ozc~JZiWn_*<6E`|k|XxWS;NZ+bRT ziN%I;1nfT|L}<60K0TkhNm#7!?J?6P=OmZV_qvV`+o(8#kp)$y7jka>a`>ypO{QTK z>cWC6(w)A7yIYr7j-3MYRJfLaGH!~CsaN%`(hH>7MPtcaov`ywL2vRjgXwN?JL|*> zJ&jm?KSSl(OJUO6=N;Y~eX1BAcnRkq{g9_1xXJ0KT7RDDjqq~rf$QdbwR7W9)}%mw zdX#e4sxa8?M$MCaURO`Jb?m^0#xi@Myr53Kc4zp9&v($mjE)nBE-mb~(aBw-V6G2$ z5&8`0H`hnn1KitaKRSW~W$n)sbhnq2V2=nh?isosifPpgKQA=Wk&-^;*n0Jer#sa_ zPi=Btt!bM7X~N}Raw3V3IXDrw65A^ zO?|Q|AX#yD8xIT`i2q{i`xjM(nPvcte`DWL!ztMLI@BTOE8r(<1JM}dcMJ)7BBu^v zI+83J4YUzou|l0^5Yv#xo?aYMc+tlx08Inr1c0NAQz?mYrrIZNm(sZRHD&=(Sg$=i z??R2(;oSDUpMqzP&s`7pj_}=*==6~93z=Vxua~8K_*!9A& z-!Wgi?5rbEw|%L=@MC-YjxhL7YSp>`#Xo?Pe9sLU-3xn7xHweLW#i)o*C@JQ6qsCQ z7axk7i47L9b3fmx`(CdpXwj+6B-G)_9T9_&6sM`J^pm>-;w_1dH<%d)N*kB1Tf#Cw zABO?iNfsL{)21-`?+G~X3XvR`z#XoC+wb?H%O5A&Z=!owp+IcqTGi9m^y}s}3dm~5 zr+fkN@Nw3PcS*IL z`GZqDIoZlP2JXbHFi?U&7~2NRyx-9Cj%JDY)Te$5T?{zsJ|%>Dj%ysGA;rHZ zemwk3#M+7`K&Y#z#z;z$tFkdr7I*J`UpzdA-Cw@FVUP>m&2R$} zwlnvCu^qU+FwkeKJO6is+CO-~f{jhxSmp)W>OyB0E5x|(eb0?K383*+yo4dn6GL8)tR^HG12errnDY5*#M zc$ooLJdkON0uM&PP};L_mI8)jjrAvso$ewG9x;+m@T{ii$vOcV1V?y5(+=_>MMDJ% zA)NSHK(`7y#&Mn%Nabs2^&XEyv&#CiKd?vfNzWiW2sLU#f-woqzSNWD^>i$@-IlW9 zh~%Xw*x5B;a7R&S`#8FQmi%96a23bf)u-$IJj@4&uR|bp={#migqOucaJu5&+VP_? zQ%S)L$4B)qzrUXT-tei;>ml%>44WY}CynhYGwN-nGn}uNj+%~u_5-tQDxBr|H*E_l zZL4x0RN7Q%N0^sV$IEp4KDEdhx7}E%S+suGaP#7S5bERkHT6G1Y5%DOGFyJv;@}?h zI#nhW45j{Laa2VCeDNuI30{JWW(QP2oH;{%PRJ&!aBloO7HmQfLcF13za8fN8{D0l zlDm?2zuwSES779=-#evV9$1TDRh8z})Q^QBe`Yu&KXg7-OAKDfqF)nRja1~ohxY*0Y!JWETdhyVU)gNQS@QISfdpYK@IeE*%^VuijK zlvO^zI+RORdt+=9WYuMu;^J{|A@M}+Uw|MPxb2Io-@zAZA7ZFGNi0d$aHrguBK#ET zTO^L$60eCmi^ca&ZL_Yy6ZvLI zfm-gJJS>UxJ7u5HTApp1AEuYh58c%om$gtYa2x z7?c$#Vrc0@Fb0&tC{z?{5WDNONVNi;$UqtrSdHlDs&~0mH3+Hf7aRH^f}I@BC{ig& zU}hCv`^C1|I&AS`vw%rwJ_4|A1e}eYO@YKgnsXDqM*pS){xc!gz{j1JjXTM}b*|(C z^pyX>5kdy8H7S#{Lx_y4tA{l*Rc=iLhDncETjq@T+p)jIC~wsS=u!94vXjr2V@fGR zm1jb$G4$#~%kcVxI!57sJcT9N*NW+aHy6oA?C^eP$t;BqTAT~|ezhRj_TKL>?^o2n zvK8}rZ0%EM!qv|N(?lM6Cd7GLj$7OK*j1SJU`bb)saUVY%x=9a%tiy{S>)gxWk}ne zirg9^72biQ|3Qyh^%ohsczo>znx$XpESoGs{!=f&xcA{q0+K)IH?IUHdO|(^*^&x~@;otF2tZ z{ApR9WnO^6)QJ{i1S(7=3DXHA^Q|j^Awb{nw*=`ZqPi{WSNmBcHBgOvX$0xak zJC7L_i3staz=Wf~*nJ&fo?lX+fRWVta__v!!Y7ER0{aNUwSVUM6+KwWltztSZUx*; zzS><*%TTlUvC*zq8_%Z30g`pD_!pZTCmmp?9`^P?nD&Tkwe377gEs-Oyj0`JXuS$x z1CDwihnl27=Hrk((ZlFpY#BdkSXTc}JcfDipprGvhy8Amjht=)$hP;5>5MJ78^F3X zkQ0~%=32klCUZ69;oLb62rb5y9FgluHuU19OBsJ|Wn2Z2ca`z7>s?Qs>yJRgRX2>6 zBQkt6slr1NRm=r+D5`rlvkVxoY~_ZZu1e^UWJJ2n`I1=+0|$UD-F)^ji)rzx6M~qy zY~Ds&r6k~>v!?s(4DFS z(|c1r5JzijE1l4b2+4a)Q<*c7yUMIVKK`DgotRF5NSFxz`N%_zb)_RugzW)`vHNSO z#NL7H0U1|iKetqLZySjBDUJaz|NONvS6kuo4r?<5qItp!$oR22YLt`UFdnX}XE)3PE&CE*m_{H|G77TkV_Iq9*cI#~J24a05;489H zXfdn-Fb>c`-@#FV{0+q4FB)ARGt&&d&2@LwRIy&?E+tLtOp#HD0Pi1O57~bIOJU8~ z_{OZU^jtunRMkIo9bjj^O}(sI=rmq27Q10nVOJnG7VENV6`GfF^<0mxNk}Fjspk8a zW(M?btZrwYXf7-w#*v~1QVciRVjPQ|p*Y#@t+kR+3(KB!qM=h2Nn?#CJ}A;EPU*5e z4U%XX;Gv52T~v-C#fIGLylR%-viC!TC@B`B@OioQo}piQSzLYs{&B^=)~`jL;32}pLF18V?!!7#bDo6DcJ zNbUjJqIQxs3{(RcSBsB?49?QsfWfavIo$&TE0T3mhdVV$+t0HIgcY|#Wa?ofl+mxg zZiDmeLn=$Rd`ceFYG`u2k87?u@Ty*>$IudD+Vw0rmyFIxiYLa&}R*8i}~ z$|~Q|MLSbVU?}R2>#V{ZL_SD(Y8*7={j-gfek9lqq*5OIb4K1(+B~|1rEMaoW>Lq^ zkWD_xUu>_HErHXt9ShV%%86#b-uO={V3Gf$4rPWh@DV-1fMqVBULelgsbFXTvRuq( zmKH4`c^`Wj#!f~i*xQXY=__yx8Rw1e+?sk)R!>uj0UNs?RyCB-lW}>4Wkb~sKicAt z`JE$4y*A%dAyD>%!%%zyr;1C3A2yx(3a9$)3TN&?9k%-mwJX zWdIq?mhFS3lb2=m_^xfl+@r+?Vj4NwdSvIXf%46~oA}ozIUfnh5y&!EO)E~nnP!72 z9rGe_LU6F}#}UkroAzNV1-WlY)LxOG7V+njyMsStHMTyzQm-sJ<+aah%C%30dbq+8 zUJpAw@nj!J{7jJ}1ZTTQ06m1ZQnDYjN{09mPE&GB6U1LYh)|st4xCQYriY(t;Vq^xQP*2i0+a1?Xz_6J^RfndBlZa z`-HtB?a#xiMaI!7Wp?QJ0-t~6nhP>-+e~t-6SJM(0`SqKw4i)7ha3zuw#eW)ZIbfj zc`8-r(12=JcA}1$qcQ}Um54L+9l(0J_&bBQv5wXPv>c$~^jdJX)ZShYCk*2Nx(t`Z z%(-qDaNm8J%!wauQqpscGN+jxR5`6#4Tat8Xz({rag}FeSM;l=LLx0Pb0+wh-`(mu z3ad*C8v{1;X$$(a7=0Z5?NSPTth-b9OKWbtMyFN{^m?DFCLP0p$EYtAjLCNa#*c{3 z-)a;MLgn9l-1khvJ(PTbU(S-RY+dWl)*Vmp#ZuoQ@Su9)k4`bV2TRnCqLmAxen7~r z9Vf&gy|7#x#;66l2gx4AlZ23A=H1q6_y*g#KiUq7yfkM$w%>Alc@jJ>2UnOQ9+lUa zsPu~xCruW=g}0rsA8Mzv8a#Qh%(tYn!%%bi??sL{iAk|+ zNz-e^NrST5_MC}5axxlYEH2jQFE-I%Y>#)&Ar_okdUik?Ea?~%W)j1gCjqVnn%PJG zPB$4sC^N+4MR_=2Du(emoPl^#{ESBvK#Y04{r%^~9?+ajTQ;2V-nPQlJ~Z>$-&>vi zO(xD#?~YUoI*Eh9sQ3b2(s1z74Zc`)E@?+=0g9n3xK};5k>Ksv;oS{~0%O*k9>KiR z^UXw|qdDfpT)Ipzw163>rwUK_{yYRUxw>Y=;KSV;Z^B$cOw1ajq8EKRHCqyVKc$U|2l(hZa+d2ueBT$sD{v)sk`c7@O4*{2H57Gek>{o9cJ`yp)( zuGjo2!Ga#@_Z}~m#2rpXRJ@a_>GsdO^N}QM!+&#Q@6a#o%#LktV5qtCX7w_t=vB3S z>YD{cyj?$>m*mU3`mkaG$N&=@jt04in zG3+()-EooAk5`Tk6+}}C<>b0^F26I^1&P!kAMK=Ig$)$eKE_Q}ov1Ku8UWZ?qttF1 zDvhRKqb0P*s~MJ+PK6fGmQ*Pk3g>U_*k+q|ykl;0iEcNPM_#UOTr=-sq57Bcj$Y2W zwy{2|GjOVoNl~`}kt2_E6?{`SN>3fR)w=QY-L~-12;QV0JciiEk~8s@5&*ADRsjLi zKK&QlY1mJ0Lc8tDoG>@of*ci_q}B@m3HpQ5;H#QyF11ws%+nRO&(Q#CJJDPU_c^oWM&A3lJ1(c>@**64>ROo(W7^o-DA=;mh5P3aU z?@vt7d!hs?LMf;A6-VnB=}O%GhIhm>pPZE}>Op~;%?Dv(;7fcr>`B(RDDCF4&h8E8q3J1#Vgg*sDb*yaa*X^W z>FLI3LB%*)XXTB($gSYUlIsUn$sgA}_R|mZneX?XTO20R7lE>eWV$_x2srY17}_*b z0t-ZK?s(M9;-ur2xCM!L?XN&I!hn{de->-3=|W@1pE0WHPLi0 z{9#pOn(eXc(%osFf_c$BiMPt8IR>a#zwhaHND*+yz}x?Z~pJ&-ZGLWw+TS# zE@VDD#Z88)ol!!u{p-t#a z+65u?Zu=~```Nzy*GfQw^~@}W3Qg~D0FSLV!p~VG9Ue|S`$%k@{mmxh^-;O#XK-?wn$DA*wV%Dh2uO($?`_c(>Q15{PdwP6 z@56XycN5T9-Q<}S{9H_2c#j-w~DOMuQx zEpel<>fY0%?oTcP;^`}d{)gLKh877xt#qT~oZAE`BJ&Gta$@oJ$b*Fz>Ep)&RbNOy zu9`{$j3N5;tD(K~I(jynw=xce6|etn)&SYcYtFj;Y$&gs$f;X4tA$Q>{$=pnFg6t- z4aC7*eEx!2f7Zna0?7@O&|Bh(cZyCG2gsYF~mA#x*P~u4T z9kn(Z-Z{As*Qcx3l(N2HxvaY*D=V7wDT_T0Pf;R_$DJ2CU0NhW>-{1aBGi6eN`(7k z2E^n2Mh!>O?b@D@vdvl6XM$I%4H+DTx9XU*%>CHvQh(Fm&1FC!4RF>w-7haKtkC&n z3UCd%>@eRV=zhc!?2+((;rUL*;B7^0BG{y-!i}#cgXC$_!X5Ode7AKuDa&20Ee5@{ zvZohDUU`V@x+PPDoYSTp75R9n!M^?>l4JB&@9%mya$etx8{kip67@(8dets_I&LZ^ z!$mD~MhdR+v=^F44 zvG$5rYJ_VpHKnKet*5V0_G5s&tT@e{61ZJQn=_$%FAZ7akq;)H${p0W{;3xp57+eq z3y@}joCdyAc0#HF7~vAON)oSU5vzO!tFD!t3vaavOd!qAsr0wn%T}b}$4ZFi^<@^0 zQy7(+DHDEK>y;WOvl*uXsm}I~ZAfqW5h+lDj@mDv*`MkX(@G!ita$5b8>-kP4+CdP z<7$Qb&|tgpB1)xueM$-U`QU6Ldr->XXklaP)r{rzB4oGRi9Caixtb2Y15^>4(e$P= zmn`CEYjzS?>}&P_6{Xm2O4IL4#!Kj{<`^S-mrS|!?-o+>h68!kFCBb4NV_tu*){Tu z&7KMbIp4I0=}Zp!-R|Hz+ZdEP5lUXwOD5Y0WEenBPJf1S++-;YBgx?49-gBzm;xxV zAFSL@Q^U3u(s~=>{d?SoT5XP7&Xa;7!tBqt`o0|`AC)kp*VLYBB|74xd|7cOje_XNfU;08S z{pN`&4D}g8HRC*Dgpp93tgjNB4b1v>ZR$K+mp&m;K?a(kI?rM0SIN&26f>&p)M3hH z>keM3})$rTsKK~0PzV(bp&~0u$>-6DK z_#b8Z;vY6<#Scr$&5`5Z49+=yFVqtlCzFrXcBbeb(G70Cn^a3Gn$RxOi_oRZ6b2!X zIkdCR1{Y{<>X=-zq!lc(R_qE3lZrFV6v!o$n}9_%Mm&kp^fkija$yK+ymt}Rpu%|D z!r)I}^%1v7zu0QzmMYiE7+e-~ALRNp>IEIBWROW-1ODPE^9p3!H?n%}VDZt9_4ATY(sd^^bPB-ofvEo#M8M1dEv0&NI`~vqoAI-^O>2p<%^S?lMG79PF*|wl#ZPj}Vn+WkkN*4tstFX0^+ZO`27V^;(47xenI&L%G{bg6 zD+(om7)4yA$;5+|{G}6XeX*Cm`W&)&qeb6dn|MdXym;CHx?49<-170ntyrn1eZA>& zo!g{l#jez?D(ip)XUmbjwUWw?65*;e5 zsS2!Mev0cReQ<~r1`A5W^KrzNo!5DyESL&50Pz?W*!YYV-^y|~$(Fq%+g+$*$eUz* zy&CZzs7m06EMG;QM{YUL(ZAR#cks4TFMqK`B$NVHvv{Q9b1mdDNC(X#6et0=<^?wo z#8>F98w*I3&bZOD0kB=v1f7Y{W+d)nP6U^b2ZFDEu@$B#FYZ2r0~&opA_03my5e2R z>RS{;$TJk^m?bm5E(wi^rx19*tV6%G$Qf@`pQYuCYC|jFjL6s$g z9UB4W1&0MLF0T)Z*kEP7?d-kta@o}0OBAYz%0-&@h2^6kf7p)oQd$1-gcZ7&60-LD zn`2l?bFGwRei}&P1Fe@N<@@HI+4zG7(r6s*2N`sJc1UW1;&c2&nHLPs zak-uQ=*TS6vaHDSKz;CxZCtuEpGMbMkzf`xMSkZcm+3J2siC^mov6b7}CRTEz-P~deabMeiHIuuZ%PJs$l~-ZW1xElY87B4h8TG z)u7GmgV{Se@lI5#+`{wfk@cTD?p2l1-ed2&=6>AP9{{58dN~pe=%lhZygZ%jo>Y9V z`)rARWvg$cmgc5T=-6`^B_e*0=M3Xt)TyLa4K-qY9&AB)5SDu_LR*x&pq{`RWFBD> zQ7d9ql@l!OC_l|%(xQ;13afArJ;VRaMO@!W6Y^x|NFOq*&l=FigP6uD8vsjVJfF$x zc>`f;oK9Z{*k8HR6m4cf5nu$Fm{g=fxaQ|)V445=)X-Wq`eV*%bhY_obIx65rPZWE z_N2$si5YjxQa?Y+(6%=`l@+ZpjS=pTd)y~yXj3U?Xspw?H1>}V+_0$dCq%kWVG`%9 zYc9#{R14z0t?_xH#4XNvw8pSn&8F;pR%I9A>BcQ%6OGss*~UDdQsR4LU~+ywW=`lZ z+Alxx$7Rqfz3fIMaQ(f9%`Neh3Q@4Zl;tbYTD-VR+iBPDzpDKEJQa3JEuH((e4S`>cY3(rv%C8*_nn2b0^VkIxmWCNcY|w6Lify9RX6bU*($r_A^3BPAxWvLiA1 znW^&kP59RdUt_IOtV~9Zcnyw$rV#9KX9_DKp%+9m+JhJZVnsAaz~BaJ9@=RBno8`- z!z8-(5{L$Mm4bS3cFHR#=tq=p8I?%lx=sY?0UG(>%J2HV3k0nQhE$AhHHDJ%o=Y6BIv1 z>-d2R2RQM=fTt(chot@l#Z^DZwVXV>H|T%Qz&gv_kPNB9}q%SnqE3b5g1K@3AvcOY0A+352WBWQlwY<4|czR#Mk@C*QQ*w*J&x347Tj zdh&E8&|mWg?YaW)^N}6YNcyvvTK8CvUWa_=n2^D1B3t?IZ|&4!)xF#=rV_La`E60&B`Gj zVaE3m0C${|# z#o{826EDF&esD7o*zz~Btr+I7$8Bm`A5ZuJ;(e@*^2&7>yB@zFcyZcKPkc+`+LzoR zk(>oLxS{yNYnhqJ$pK2fwI{Vzs~|jc?lV-p0reX!L3L<%D_@29L1aOc`{i)RmZuZ_ z-kp0l1RFO;bD-%Z+mbPOLYQ=+3H_eG$Sre~3#Ak*&==x1kcj`imstgQR6ZVt5uhuz zhf+s}N?#ku!SzhB7hzrtL&ge_ME^65PCGIER}%xIX=n4jOPCd`A@t_uoDmJ!K~U5C zZ~fq}EZ9cpbC12TcN@r>1%9S9L!Rd8PIYt(saKY&E)nWx{JFNIA)j58CgLCH2fh$c zkX5MjKut@ns4wcCAs;8=Rw0`4jtE>%1B;r#YG_GaNB(z?-0A;_k<-t9fFL36z$X-H z*1m_u&wPRP*+jl_0;)MrNQ*B!Wm&@#pb;Rp>zV05(~j9sWhX$W4J9;gOx!cyXCF~9 zfp69#T~|^oV3E6D*Yau#oKkBVjHTx7#j`4#Zq;YlUMn+}HUA+8@rjD+>shOw9D1@f z!-yc~#|HZa3Uw_>84(9ac2|2E= zHBWf(hPxqp>O*!}LY19bs+<*-NVh`OL$}pf*(Wy`fG!meqnAbOA#q^VNaxkKcF`)R zaSXGN+Hm+%aB}v^$@j`iXtwuhCx(IR6L58B?R;Ucj{uPJX>@AC3M8k+n-w7XnX@F_vqKo zNl|MEMY%Z!3Jq;bYk!)ATCUqaN|x_a7OlGj@g3eTJ$IWA#q8L&|FRIH=U?QiOU{ea8r9{!Whxfjh) zZETO`VVm8Mt)J_`Ff7Iy`rN7g6}fjitlrbMbhR)LFYN263D5O20soNR;^7?`1`R@# zXEI53TD!>KTcNyUKfFBZaoIsqv5(dB~SYPZeGm%9!5v9u~caUu;ZB40~^I9j^8D z+W5iZD^;ZTdZ*BbOpD2Y+RSc=v!j|r(l|T8*=VTSf}@j5Pm^AqW%Ya9%@IMv-e>a~{%7d2&Yv;5q}U)}#f= zULxm{9k#AH~Zse_$J+Jn2%4XG7ZG>C9 zZ8+6dMEn~}e~;ZQaoz4gI=;ZzEy@$q zMXI=!CdwIC@(*qrDR28{>`wXbv0KfgPXQFh`i$JY#Ka)Cx{$s|=AT;%B|II0C+vVB zq7)PdW3skM>`c_+dBEf9{|YR5h+t*|hMRFWfE|tnDz$OIsX6&rCQ01cDf;&hR8&H2 zzJoDYMbOv6=kLd>eI8)D7W;K%)MY)N$=uL0i4ACzGJD_PkROu+6KlCc7=`&0;zh8{ z5)bF@&bG2P*##?|LXsn?S{KxbG`kOk4FC;Kp7x;RpEVp4Wq**?+GJkU+!A`r6k`F0 zhXwFP1-`3@`hdg`+Hg+^J^DfEP+DR4$f0F51g>3xf9mCznAs=}EDB=;fvZ*jco#-EC6sLZSDJXkUlN2W#HJ$i1 z@GoH4NG~I9;b}i#&~ua9Z!gVjsa$IH024!tuHi@eeDriz9QK~z_})zX{Xt7!$4m3E z#l^Le?91b!iZ(Tub^qL2g(Mm9`RJ9$(N;-_^qTdL@u^koSOEs7&--bE`K>gglv3~+Fwe-RyJJD+Vm7YZmhgjqq|IR10rdLK?QCSH9(sQ zE#vv+X9tiWEYB_jVN1sTw%k_EDU`D!tPCN!7-*bI$JupJg0k0XXHVG_Cw7ysns=NZ zU&ut;@fNscBt?p%{(p*w9T+fcT;ob-;g7so#g;drAjtP)7+^p0_QnS?pJ>Eb90meg zi=ZT)G&lrJ=OgH)z5N@Oi=P!pNNksSrgV_b4oe%|vuJ0+#kZ|o9e~g6MV)0t zym#`;&7s)P%wpBFlUd@vvyEhpi0ALhv7{)E!{qhGO@9C6J;&ea2`YW+mHWj&eeuQv z)h0nfdEt9Rb`GoLLs&$c;*A@HTGZ~U;#WC;*-Dki5P(@?jdi zbY)%gy-pX4#3Gd>hBmp~3#5r3JwALMi#De5uzQKb+45AA>!(*{1lYIhY*k^84el}m zDLXTt$i%Kf3!D=%NmKN>^XFqiO*!fU+yapE{V1S#gmm0aiG%bA!}DDe;q8ixzgN2X zIMiZNz~*T72}}x+&tAAZQ>eH9;h+#~D<5{V^Rxhmd)@fun2#0lRl?(qf!$@P6H$axg7+~IazjlO0;U*u-y6ylD zeOE(gGj`l0$7TKe4(R=c#AtQG@QGDBJXvdCw^p!EozRgFyAAjoz+ovdn{*IR1N1+X9BDg zvDyO_Kn#DJN(I0Bvg5ua4p{CY9_EY&UTXC3h?J0drID&?1Noq;KDPNb4j|6udk%2R z>nDmTHt3WJxzh28Gt}PC>D+W~l46O0IuSzFrFC$q&~bD=RZKSBC!1`|l0fz@^oyV_ zo!p@4y6YHmByAi`3`~B}D;w`|T^cVaYy@sqZD+3&S-F}P0zBjPkU?s}g7&EGQ z%7@1YP}`gJThys;ln0vEn4&vA8^7PWZ6 zOT711MTWv4kY_bY{fd_v_w_BjWX01j6b2E`$U?3dPDj@^^m{V`0%iPF}}ZO zd}Yz3lqReG-J}U%L$n)gYl=H}6j!~YUKr7j2JV#99&2nviCwmou+d&*=R8ZrV33J@ zmxG*>q}cr15=iFZ>ETk7G*+zdTiW3&4eq@hO_Xdq{|bnIu>E#dV3#2_N=m6|&am-o zo~t*0SjXMGkSO&DSM=Qv7fY3Rpv|5->he9n1IyI52iY#jV| z_sB<=S?OZoX_i|!`GQ&Y-bgoO`<_cco9dn^H;2m6QPOgj>!9G_lNM|8@R19jG@&~Ib){HVc2|G=Sx&Q zt6FnY3-Bh2-xM!371ejveEpgG+HCh<3Lk_|y)hJip_WNdRX92fSuI$ZC|H)${1|#; zn~vJ?;^7tp=-k-Y0!ke48D$t^Y!X~-qM22ilh}7_TS<9;y3Oio-2ZF8{Qm{={ckrN z@_)1}N%mBA<;Itd+O#rP;j?yj!k(VGT-6-E^G56FuDmQKkH4D*a?sCwYOKv1%Zn<| zKOGp$%qry4+r{6oj~8P)uL9kFqJ9=Hrt}u^pLkNN{6IYI`eo(mNE(kBwX=mJ+yuEu zH+JgoJ|5k>I~4##d?+IU?Yi%w&>p|{78S>wMd)-ltR-tyfF*C3=i1en8}QLY;0or*@H$$`A(1YuF^_ zbvAbbom%q7eeHgs3s|-C5?UVAZ}e{ji32YB-w2W)rq&(-AjqrYxt_u_@U^viHAyqAmkUu0jJ_Ql{b zWy!$P=2@X@o-P7!SLkO7#!9x8u?-)PucRF0P96u19OW2e7)QN4+@T>Y%@m*@AwKaSB_3*0K^=wMOafkCn z%Q&l{+g-JlON&d8ojalH0kyICHg{|{kiiBFM`JFHYhQ~ERm)7Wu4TEK7f7Bfdz4}H z4O(Z!$VAQkWDU09QOB(Y7bf=+Vn$3D@;Kx*-98n$YXv(E3^pi$k(@M2PCrXOb)v|C zGvC7j>g5~}X!DIPx=L%pYupj6s&@WYj)VYpcOd=}J-H_`b9U{rsv4i>eK%j;g@t$O zK8G!#0%`9G<+EKYdIml@tJuGT-e|{!?!bVGD&987LJU+`CsJ80$5V8K@n zLWJ_e5tKmj1-h>*K*h3fTo2|44+kfiQ)McNfKk1(!N)6&s&cEYo}lHbAv zU!Q4zy&l<7;eNfBb#b%G)$0Ctw;9*FKMoibWKgP06h+$U!vcG-*J-70i}TpV)=SYY zy5!i6D1EX=Ob@v(JE)B%prt#OaL$8zl-rO|lK6SbACDTS$^>(N> ztzflz(c6tKQkmXEz8VDcpd6LcPQ$955r)l|l(mbUvL0pu6>&;ooC?52IL+>kS;a>P z9?#v6hpD`4lX+Sd#@%0r56yWv%3%wYQJPX>MXl)E!<|m+A!$6hq0RpGE5=HA>xPG6 zCrI3gZ)nI)=cCRW9IrW6Bj8<)@c2r2PVFu$rh5{I8tnT$sQikFtuR;NvFFqaQ{5}` z`(va~Mm_}nD9c4OwbAwL^qkv*o3qpU2Uk~LKC{b?bJIPVKQrb9C9It91YC}gR!UcT zcxJ#O@QTfn>NG&-aK;U&(%bFa-8yt0e4qo962Zdz8tyQ6(<8ipO=Ji)&NO|BJNmjB0XSx7FoBq)YFh0@8a6 z7+@;`(t`930#ZV+5+IVLK?|shR=Z|l@2>|b?|B?mxBcB+pUvq4;q9|)d(6>lzk~z13R*f zINClkSPEl)!_W%HX8(DGJP6k>#}HOL#9oyomg&U$A1A&30FfT3@`m1@z&mVrB%cyyH_EU0CQ&1!pA;-mQDnT8Q@XxYHwPdYo!eo%8(pW6dhx}ztSSq#-Gy7 z$A7~Bpza7gRZ0tu0D@hPhOoAaPR)5Z)uxVbGrE9ApnJH5xnMXH*oj*In2=42xr258 zsURnM33Z9LiIn=3sA>r{4iiU-7UAZYvU0m0 z97IG=I{9A$)!@tl(l-Mfq-j!3Gidij3&V1qkG-|I3aOj6XorwounOa1v5>kSnL_1Q zq@{fY#IdN5aZ1sil9(0Ua-<8gF(d28 z1%SY{ihYFgk9PNxVtA&J@*`?CO*`f#d50%1My%-@`JYzP16XA+oDZ1%=;Dj-8JtF4 zQVWp)&qBP02Y(WRsupY?;c_^Qy#&ux1A#WbddS+s5V-GYIwxU{<|K;DS9E`n)LYg1 zeT8N_A1)Q_zQ^0@|9acSk@DpcyaQ>J=_Z5IhV5$u&A$niTQ*Im9VfxA#={FHx<{44 zVRz>7d5u}0iwqpu0LV}!h2s4fNIaVH*h7d`A8d(3onxq2Q*=m{^;Y>zriL=kb*Apm zE6X`(o9ekjr+j_x_@pgQMNw1ZGXAkQXM2}Nz|T0-Boq005Pke3XWS>33A#N#3@H;h z?qP{;@X_l8L8xG+u0pk_325@Zd#Lk&E$VE;)X+H2dp?47p+IVrxtM+Hq##1)xg-G~ z<9=+wvJSB5+Xp;mVWoodKW1%_l5TUXnxwy(apAzU?AI**or(9HM3X=KWa4Z+hiEuO z(AM}x8F7!QsP8nRWc~9boOyd`m+?oOc}Y8o<&wVz_Qp0(zWmnF^3d4%-v%3M!a=$S zPv?!0L1eC#hyG+35*%3{%aQH;7EEMdAoNE=Pf5zCHKTxj>{WpUq@Pl z?X8~3kkW6*przgQ^h`6f_X4$4zZ4qQdWn`FP;m1fu<5K9A+0I7+|>n~V3tyN(p*G5 zI=-Kz?rONLl0h{I+!`!|^kKH$slkdWCANGZ5mTSWqHB|+=w&akDn6)T@xQS(iCp=E z;Xi7R0lx8<-xxFOt$8)Yf2pdv3Q&Bpcbhlw-+C!?zjw^=nqg_Kj{;CU*Ze#O8k2{{*n3ysX<|LESZQ^pmWZUZKfYwRD z{^!%B_m|O!8#@96oy>i3A-u}AH1mL!`psTN zZM?8MEZI>bSSHfYy&P_g!JX^dW-=f_s9=AU7@Kj3K_lb11ijy=khH52MO>lEbV?Kc zN!|QbrsMwbpI7es01M`~fqdDZGZ11=4JY2-^bM~))a2W7 zPPn`j$Mk8Vu&cX)uhfHg%qkBcQua%W;ayBWnztf~{s{P<0Hz=yZ7<6D&-Jr5)61yF zX`(U4^P}>Vbc8HdE05U`+1lKR{7;WFxFpLQszo9OzIvUB0;ZFDk@S&$stovu+NC_A zdK$^4UxV$Emp`^pj4Zw`@@4sNjfdaH*Lt@CNS>TJ_D*X&bnKzm%g z&J6EoAv-d^GV@7@QI;jOoJ9JPBky1jKU$w6PszzSzhs=1seBm zDnBfP-9}g7{E(zEFs4izkRfycnNM@l(G3tLqV%^YASLEj28WB68_UuDfM`rONLZiq zMTuS^zdXLjDK>0O$ihrquZFJQUwyxaRIvSay-WVxT0;p;hcF+dP_5=OO^}Wbj$pV7 zn;QuW>qyZ>QVC3bOLTj3EDuxPU9-pwI153Kpgyk+Mc#(Z4|L1AVrbSw*`CO)NE{}f z>A&z0!WD`@${M@xf+QS-*==bG38p3mAmAy5AvZ!r%qpMv*;2}el@u@5m2*`XObX8o z!iUX?GwmX3RJ!FE@nALUW1FP<)O2IwiG5-%j`b*QetUtIp-g?-@<2`rD zHDv#WY__+OttM;2h`42$5oPSVscJ_~%bS~B=`u6rqLvl*W2<8dY2{nK_9lFP=c57U z|HenfBaSet$)?E)wIkazK5s4Czjd0bXT7d2I*<>0v-@n)iggmKA;)X9;q$vJTO-?P zO;L!SdX!6N6>@$c^!VK%X9BPA=Yz{`v`v`9qdG_3eK+G=r}A|kId%S8%3LzxWtXr7 zkN;weV-jxuy$sKoJj~(VNC1l~S7d*t$pJfmpD;zzK*uHX<9>qJI8&ihj%jM|Aw`6t z*ykDsX1!|g0JGP?vi}KN!NaX_u-6RJuB48ZE&pQScil<%+&<^ICjEjA_x>)e5yzc) zzuH}P)B9Cc?G`!SopceU5O%7&zi$@c0~CTJQbGJB^vWWG;-k2yOK z2d{9X>rU~Q*fAOAfDDgy7&~X?e3B2O#?*W;y26Mi8?2M4Alr5tOp*$VRL@cp2a+C( zzSGy(#-ORQCG-sM&l9;gI(*J1`mrkmgW(x9C9a52FU+#TlBfUpoi$s}$K!qo)J??ZRw@-|oBML{G)lID+dZ#>B<{Mt7$6?D_jB_`jf%`y@I-RUl{hk_pc4WEF+BD> zW=?T2p`t-%<|SMx!*~3 J^$4=NwEzU6~!o z#c9~(sDh|Bhx_+V^qOL9*)5s=eulKo%lxS{aX___3)(-WUxlSsAn#H_s=S5Z17y3QR+?x&EhXqZOYV!jJa$ZydT~j43^Is$0 zN^0s(&cR;g>5=0rKkQUA3n4YOOrS4qyWsb@o|kMmlJK0 zQNJ{h9d)x?{+wrT%<3D6PH&kr0wIsUe0z)uM_9zN=frOEH+BdP)~q2{jwuA!s)=Q2Pdh(<+G zCsOrMI|BP0?$}t`PSUXG5k&OWmLm42NC0et=9ACO*U#^A;~~66gYQa2J2wWw=<<&$ zW{nc&c0S=OhZ)<1?1?{iL8j?qgdp07`B0~Z5zVAZ{bL9(zXdR2POMh2kI`QZ{yLWfTP-I00*r)z>6QP%goG*!EB5cP18*S zyIg5h4_el~xQf&^ax7LLnyiIi@^L%`2NaPrVh9F3%ma2h+2eBkfESW7#|>n2goZ>r zrFGh3bncdMDU=uvOQ2(FZIrDln`=_SYj0iH{Y6;+SJe30e^h_*&);*E(>xt>W#}D7 z{EB&c(qAdHFK_hn@JuKGlkaH=a5s3l6=~-jUGF;kHF8k>mR~#;5yi(db)YV91A`0` zQ5l5zW+Q5kZn@arNV)0GuwwP%67sV%!|4Oxfp~@YQqB4oV#`L|^Uh%h&3SpB&{t() z;nGDb`b)M2;%F)BAn`X-5Fog`%dhzK^RfCt(+`^q!$t!8F zEPs=npU6{3?i^r<$D6%5+Bev7@^G%4FMg3*W=a8x-WUs$PW(70`Bl6&X00LrlH$-W z>YV*E#;C0%IYZNbX?pfmx z3p7vGaLUJ)^6{X8?WqG^YG^cb+iMS9exA2%?P{7K6l!(1&Nvs+kZbgP)9w3$EBw=b z&gL?nN(8RtxBdVkXM!Zy{z-+PKdI2+V#Z%o$TaKkREX!Hc)PM#LX)|UsDq{N$FFm2 zEo|Lf$=<9staWK+?6H`b0@ZBjq~1iZyHZj9f&ZpA~=1mu+HD3#~ zr^J8hxEtl4TygHxc>T_tmsbV!`?Gm2I^;o(PiI*9xUYqV7_acFx2LDco;hy1wER;D z&U7~`Ju6C{lv{YLbrA}rC}y_+A_ReZSYz>sHUW7p}Hwue{;*$F}s>rl$F3njD{Rw(Lt&)mbm372X!K=>}KOu)Z$5i*!lVq4@fw z-<4D9Zp&5EaXD|tyS5uhCuQB|fgA>ZUXjJm;oKIe+J>t9?I@FmWyQcvd#>iLqCre( zQ<{{JbL-;dfhpweVd;TMBi45u9>L@?0!l6|G+p+0U4Efmi;j$p ziw`xmei6`0O>iQ@uR;?Dy|HKeAo4b0$Alm(q5tTv`R|Rc?J9nocH=ZTPa0|6*g-%e zZca6i7I1`q6!2)#VlzdDb1VCe`?NXYoO#fr#uiDQDtbq=tpF3ssLM`Lq+Z}^3tv!~ zPQ;mGAq55spU}gU4}xvcVo-6N#co@1aVyjq&D%UoM8pkWUum~og{GHdDsCN_>vcz| zt0J0u$Ls@{^}lS@x8_?|sd9{1NYlj*eAZ~gkou6_$7t)lD9krKgvi+5tyt465JVYuIjr>aH24h3EXb*Gd;@!fdFEQ;ngQjWHC<^(2VCNMQ# z)!cvKhb74ksm%X?0|mc+j{$CU#i?X8T$(Y{sY1J(nUT93taEd+-?*oX_9@e&AIhf9 zGyBan!}e~gr_<&M#QVTW>H~8{hibLzNfA5D+N_6}rox6A*t}cqT91^V(IbZ{D0!L! zr+Tu%Qs$l4BQihGKTlGjm`Pw|eR{ny@($|?den4TTagDH=DD180Mc79(B_Kqrn6J? z=Gg&iya>XOQm)`sK$uMizS((`nj#ROYwfKGrT8#9+trn%%+B6u$n&gjNk_2NWJUfe zlWpG(xy}(XW7U&(Z=YXDR_mXfNmfl2vB$Wn*Jukg z6f%?#6;>7(*>m2TDbY)|$%KVCEaF4EwQ@1S+&_r4Byrr@T%e;1d zZ!D9aF@Y#*ej1}tfkn|XnY&y@JipVOjL<21V+c0XbKsFUj+cuY>TFv>5{&NPwrD6X zr-d%MIHs(6+*!rGHmpcDzjG0b_*PDQ+LiNtJ{p)>*S;uZAm&CTJ2_RkhPq#G zYI~hik>nX2sfe|4pnS>j1#bvHo?fC_lQFhJRq>N~8Qwa&Vz$I0FIg|-wji1cYYcR8 z<$8WRRmP_8%&lK?p>6Vk%1d0Bf|zN=jj@79`Vu(N2mTowpg|=xr?|rYmx>(+4l+g< zRoldW9d140-F<7(ll}BrtP@c`hueU(8ZG_#byI?uBa2P{cdm3cKr#u|&Asl?Z+)B! ziM!%B4YTY^$d5=NTvCyOVh`1CuQy8IB;Pk&-o?*kS`M^R4-j{re44|OAWUiaZ5Uk9 zKxfYLNl=GMbU@(C7`?-nTk59D>!19$xn;-Oq~-Abqi`v1)@xqBq;xI-uT)*ya8bgJ9((bJ|vZP(gGP$F_~OBzh@D`9iTHIaVM!KVd? zBNUuQS2v!?v!)Zpp9Db(jo!q7LXEo_1`3!5U^*~b5oBCQ!)Rd=9my>*3f<6XJVvm| z74F*W2GhbB(QTVT-Gh-tIn+TYdVhr@y7Tz)W?sxY~oG zWvkZi=Gi-KzdJ7P8XH|N=AHDJN_=0F;mfq%==;0D>jwjpsX>l7>q2(rsi4>a zCwUvIghUzKc5ncTJhfGslqZH$pOu5?6c?D5p=Bdhl3pv`vUqVVx;nZRS!{XDlEIcz zH2~(>raM)EEMTer7qB$T$f%0*x%IZaqxB`0JN}Dnu0k_%O2xG!laPHQbrp0!W7~a6 z!0JWd!V=ZHs=8oVSiS`}!*3<=co&RCnGuyHC8XNU-0op%hKN&z@lVbL?*?X1c?JK9 zmZmr?QwDTC{kFD3>h}-UW=#SV+{Y^2wti2a2lxQ}N{PI+2l63rcG(ygUcL5Eet(+M zzijT2Xq`x>Y1Gl$HQ}vHNbX5dq-+%D&!A6Tw5Z)XSG3c%PBq0o7p@P3IAu-0Q%rpd z`eYfw^&-3qykG-g!-de;wY`J z1_P~*(lt)xHvaHBmzZOFrm!T=G#M^+N7?u<;uW(TOnR)p`s1G2-|^B1z{`2_gfNPW z?lM+9fR{pl;idUM@KR8yVNo#mQhQVeFtW<_I|Ws#Yf$Bx;LWU&{0iu};_T@@l^}Dg zA*=EMW**J-{K^QAN|Z@w&9eIehu(r7*^||u)&E;vP#HV2BKjwLH`bdtVSfEV*ibM% zj9*M|Xzo@Ma+kQhO2bhj+?naI@$)PRwP!wiaz`IVpc5Y%Z_=)R2@tPb9F-<}e4o=H znG2Mpt<>xpeAwilzH8oRj@Q#QLGop=?2a{+xk41C0p4XA&Sg=dox#;C%M1wE+oBc~ zHjiUCOm&Zks!C`6I!etfwa+pZPrf6;^3`_GQ^09#uttugV=%UjV4z)q6&^(_n*m?EvVdBLk_FTGvD7R7~eQLDLb5B!Xq(oDi z0H05QL`Hk`lut57%|pC)+h-a7F-;&g$F1%u}B= z8BaDuj_kT|Sei2DIm^XBQhsTh0A4A8G00TE&Y4oT=tMLc5(XA=#sn!Faf;Shhpi=c z3tPkQ&VvotjiOfB>kpI1qALafD8XKM4HI~VE*S3xY zgJISOAiF5a#0;vQ%B^fGeLbs$5SixoV*c_$kaiE3>klKwfU$tMF`#Kkg3T+6Fd|lH zi(BAu5i#kTi1C)>s%dd?0Log|oH2@#;X%osPOAbC3p|WjCMXCz=stFT;#zx_P%xsZwCz- z{9M0_tfGTYRF{FaFr#V)#tdpb_GU}?_1o6Br}TbE+!L~w5_bLYt4y0Gr;-ab2(Bpd zxLA*d(q^Je4{#?jIu3L6Nf&IL?KpnDj>s$iUo3F_mz$5}%45nu|C6lbe?xaBbWP)oO^FmeLb6R=|aKK znpdehdT`^sV5JRpjtyTKB6wV=R*GjF)Dthe=y!8nSYK|?OOvx;!*d!pJ0fFRtx1_} z8Wb$PweT^vf2tNzt*mvVqJMUVTNQoZ=p7|EbeMhWr7(PCP|J`wEX!EP&JQt@VYw~# zI}XTx&p4biK1nBmLM);y#+XhpdFjVJSAb5`@9VW^+;9~jjW<#3d=EGNLz>KgIZV&_ zbHDV)X`~Pky&4p!v9Aj}^X*>0HBT-EpY*V)-&t8Ul=3aq51-SvD;r&!A zbP{IZjtng-33vwm^(I~Ts_1-e49O1>vXb+31=17ZsuwtXUS%$HdRgs z6sZ25Y7$Kl8Isd2%{3qrsDtc}Fc0)W5g1`WS#p1++OwF)wCDGLhcNQx8|FQG^z ztn^NxRU2dAg-x>(ih8eN8;}B5!3yOSD%$yPmQxyFQ8=bgQ(lE^7r7xC45bx>vjWTe zB>QX^S5oEYFS_l8IE&N)^VucE&dF7M7deJ&E$L(rV(J{!eiGqHKMmv@ z9)Oo)>#b|<_hl;zN0HvLCk@GhlCJxJulwXf@&j_fyH2h)G%pHGl{rlTmG4l6zDAH6 zS>hmXEe<4d7>vQdLnsE>K}=ia`892%QicSC&e`9Jy92bvHN^Di6)W|2nhJ=b(~Z6X zqMFIPS>ueKWHTn>%-%*k{(7-rrB=XCBIEpbB4e>$FDab=`oU=Cpy2%Bm{-iGj5SJ` zu7E%y+pYc-YyLmb5?ZwVfLPo9Db@l|cR}%b5OcN8e~ymm>06k(*<$P{>=eCOcJ31@ zorLvDxy($O)S^GN>P{Q$0i%>4;z^PeRus!ve|3A^^1y?^! z);kBoAc6<6o+Dq4mQF$o?rJl$L+~ItnUvnGxnl|x<9z*8VP5c;Rx4A!C$c;01xZ#l z7jqVd6x?_KFr29*sCKSpex;tzUs5e?OFsfr1SJP)%|30I3a(vpIJ?gU`J-h{oqOv1 zfs}Nl{DXPa?K)Mp{tU6ba7eC{pphcj1-#^~mv}HUJS{lyxG2Y%NpXu zqjU`!SaZiJ$uHT=H95B=tFwqXeHIy(zLm&qLR|$KXLOWAb9v?t^Vn>iGbjwK6XN~)q8#Ee&+&_;Z$o@F<5)M<6fx4cLw5@_)Lu( z-^Q89%uUieor5^o{a(rd!?i2>Yr^5A8db+RN&SxjrsG+WYh9P z?;B+(ed|OaxHJc>;J3r5|3Vv~#P>no%gAHLoASCQM0(ZH-L347AJ3#(7-ajL2vLM{ zJ~1-5ivoD`6I;h|JLkchC`Wm*)OKv0xaTDY&H(E~~8JF!NIcQn3r;Nxd)@P3xTILd@ zO}hUA8$*n+SXx?xzG2Elqn#8t1um?HoiY{(;hP*h<}k(qdu%b(kF8Yal2y%SoNm-i z>OSAj>Sy>N?#P1Je@$KnB7W^5T}GT5o1cFMN4Rq*_k2T-j6neBajJB*#(owMSaM-T zpks*crXV>cbXxwg_9<6!bS$fc9HrGU+Z>-{VWU()%avSJdopTqq91X??J0j-voc+1 zAYRAk*9JLsC|T=WzI9)|?e8u};5_E|p(EehgR<7$LDo~fPuqRCI5XL*F5B~5++*LF z)QU*2IH}i5xQQ8>VhMXQsV_$R^R?2RE-JYoM`ULzoJotm>L`Y5M!DVhSXHxa>Qd@@ zCz1^e*7Gj5e6_UG{luDYvn-yKIewwKg#9Zx{)-9*pz{Cy75{$}BKz+^s`w>tRrZj* zPdeU@Q0*3Bt3S>|Zda7#+Y;!R2=T~s=+V7Bt6;nEak|#x(J^DH6)mZMC3#A4>uV(c9EUQA3;^Md==6h&T}snETx)Wh8*!Xwf5yQE@bA9%>bKIa-N;n zRaOk?s-|yepx*W_)nXa=V6E7B7m16KM^M7fl0c@cDMPY+%p|nB(EECY%EJ%TKL%od zTqRY>5#KGSe}xe+%RrW{IDOW-TGQw@E1zR?%Ydi5Eu+1fOedDFPwp=$GZv?iy;P=U&jp=jV5FA)DZfQwWimBlOa zay>iTZr_k*c7(3ps)IF4@;&UDmv+^Me%UYd@DAa~8DZxNIksKZ3Sg=KA$a@Q4?k!bPM3_1 zLt7NpdGZX@6Xsbqt;-mms#vh|8@lC0YNZo^JUk&I8dOrKy8=;yA*fg)e%co9NX`oIQ)u~q6aI*lUpG#h!ZI<;AK!de_f7_{q2FqE9r6;wcx9i5(> zZnX)xo2Cp>d+o45tS-jJ9AtSrMlVEw6YHO88Vzt7!3~i?rTnM4K*mP-7qAK`(2-*t z@XQd$Ubv9hA#XbxrX)hn25k*VbI7bv#$_#`6ri+OIdq~|aLpriz&hnI>R>`gaFEaI z3(T)?cf~z!5T?;L#{Z6-l1U`Nc#5v#IffdBVaIn+(u_uQdZmTX%%){of8?Es!@M|9$#0!^2rKNAvw&Oy0EF*e zpBXZ2U~%SX#UB2a)d3k2U#u6);3SJmESi;*pl1r$ik=gbH+ePq%D>M+ZaA>;&W6EQ zcPQ-uB~ZHBsirM`6_?FHET6_tmYH7D3#!POdtGU}?8dsMZPPmypj#+Pzzlb3_FwXL z^>nm%cXg1|lNColY#sp-LI$VkiZJ)KoXt!qM}AZ4J$XJ|@WHtbQnqbm0M+Klo9#>j z?fZ%+H0UiC0WlN%xHhQY@5jAWzz?>F z-!QuHXcQPduP4jXvKM^qXWt+@nQ?9`zgEErSNR*EY=Z=Z)iBj+Y z;@i2YnyJ0N9csjWu2J0ku{3NV`zZHgf?x2Dl(Z1mswJfqfvQ*4qvyBoT~-iL!q`X# zk~AJXz!=j{F6djR0TD;MkMf_&+G)J&yqAb~U)cR}El1V7;^T@XYIsk>C9x!?I`!$S zFjx9U{D_E<%6Tl6$%e$27??YaUNb%OAk_cT@V<*jhf3B>w_vF2f~RLUBSczy@RReC z_D^F?vgA+wkJHe|qPP6_n#u9RaW3+BFWc$ZYk?^VxbYu!;<#}0PA(l}a9n@2C!3n` zgXxXd>4PDRxAJvPX(7jN-&=c6-ljxHTT&?!v@N;QEW}5{eDew0CwwE=O)LSV07H8JHyq&8} z_R2E1bj6&nRTYkDm*`pg&1}|cGU}37MDTUw=KNU|qOkWr7Q2)GK{3$3VKhazc&}P3 zFyV-MwW2A(#LrDGHRhS@G};=kUNfY9!6WXSE6QY5#QijRc3$jVE18)%$JY%YI%9>i zhXro-&nphF%E~f_^c}Mk^W%{aPem0mfU`Dp{SI`rZdE}1D=0+<^&CH~T{kbYjD|S` zS3aoHm_0A#nfb^$kXz^&8}sN`doPzcsTkDd0&05;YH}k}Uh4EvAQqMh;}>9S%RIuz z^Q?0K3|wPr0YupQH6%d#JT3n|kdALK57hC>Qoe!Z5v7yh6eM?IbRp+lSyS^{()Xk^ zlPTdxwO=J|*huuRQ#C6+S}{rm;i+2Lt;4=<$()@zuU$HN^oV{;AfS=ej-*#c>u!~F zmz|SH$)zbbNMbBYc^~9yLgX1@71_?YtHj!{A1r3lC9K-S8}6T;!PSI@@{6Y*c5C7D zS+R_xbu4@4B{*wl>;_bYaLmIqXC0I79zF0lm}DlzdA9SQvP@KP*EH8c)sNb9?FKl4 zm_ldgsS3Q|QiGjyFO$KceB3QX7Khi{!}v;k?ko@g(K%WPbMP8`_^joi%x-nZVmUV= zj`9BT*A?MBvdX}@InF9+ShSWP&54VX^ZZHzE5_F5k)Id3h;D64bm6Fd=gx3V~q!v_juABLATefL^8ZAs9gZtpnl(p zsC694Y*lVCQm~0c(>(I|9K3w&7sfhbs_pzFZ|~#f??Am`5k2|E0NglxGvgypc7r;Wj*Co=Vr|$vK+R}N~qh$mWj=HSeku|$BybOP4zit*f0Z;-zSMV50CtA zAl@$$5N8}sMi(kJ^P6xWom>b3BvLHuz5VAgbw(-P&beSnTC%bJdijwIj<& z5yax(NQld#FMGRS51@^vhnRJdFC`0X#YM@0QNIGxKsXw)pF61W%@!$rewQ4w!OsCp z(Vl5C@1nkQO85Pz+LklqHM=$YYS08>%n~)e6T&M`A7LK{S&u z+6oOjb?>7|iBV@FXOJk3J6gH`=gM#q7rB(wl$h~$0?bG_tN8YIC%Ldp(2wseF>#qH zE@78OMZxEe4wH6kZnQu|WF9e780&kJB#)OEX8r4KZ>v!zR(UtT%>sbCeMKz+?+)7? zr^p2g*oy)zl&@N!Ntn~}+T{sXD4OI4z)r;r5yDuOwqaEQgbO=`i6wwDQJU$Gt#%#C!9k!7$|IZPha9ntjI<8 zxg3#Ai5?0F+MOGUwol^AJf6`|BuP~E(GBB-_JIW^es+1~QODc~l0YJCISD3AlkX;5 z0*r-9ZdqH>J|%l{D${J;w65XKXHm^0Mc1nC$}*bGc6yy6 zi+2QjgGd3<5eIpt{@DuDD9}%(+Bwzd#*t%&H#33iFIK)PWvt{B2r`3ZZ( zwl7g4PURMO%OaLdDHadY0?)?HQJKafN!5V#t>GI(flZDQ0;2Z>7eC-LL?;RRM`)Yh z(GV4Fmr>Q!q}$vCu|5YAPq8CUu`d==mfjaXQ-5(KRlc(+Tdrg+Np&P7?6BlxYEBx@Z9v^lW0t?CA7AhJ4!=l z(oCik26*`0P>e@^UP*?BZcy0i@CFRf!qRX#esL@ESph|?Pviz&wvWc72>Yx&XZ(<4 zdVb=Bd=V0 z3po#4nMkqJ?hecWF+58kKtwju`duTz55p*VwifK9pfPx7*OzG+p0tDtr@F6|^B7AJ z{6v4Cwy3LTNr1Q-v2#uA{c%1e=hL*_p>FeRr@Hg|sg*xc7>HgLy|ZPymU`0s>5yvO z{(Prov>4Ak!fwk_rH9ecGq>g~#*1qvP^Z!>JZ7#nV*CDyi{L4KyaK#K|9ii{&j1pN z{jEv*&)!$#z%!{E6_DENhi@v(Vjk7-4no^a)7{c{wiZ0hq5^zGrz?Qm_VE6IbQ?oO z?w_BISJPPj69pIo*a4Z#SU>z9(l8thkbpZpUoQJNvo4G0)b#s`7~wAK(n#@B4oY} zS1lvD2VoAv+!=)SvN*gGfxG<2Vhv3)*-Lz+f*||*1~_?LHhoJ|5kt$*^h9Ks&O{0g z9+I^(SY>hEvUn2^Tu$5tw()jb-?Ux|ubtmIbi}9ddz$Qg?_q(vhiphQtq!7hjaNJz zem(rKdD^!*>WW|ql&U3SM%7K6+LMK*zk0o_sXYFJcI`e9rO`WfgCvfp9jkFnCYdG& z*tz2umU0~2jTm3~v(s+Ka*oM0)qzeGDs@zdBfj=F5TsavYP+w#eMP^btV}}w`6?4G zpdW$lRE|d8jiuaF2n1socpR9_8uj}^A<=noY-fh;Q%+O+l(C!Kik32 z%e`vv5y?v6fex&=^rp-2&u59eBS~rUV2}-!EP*JF!5tk1Y-Mo6O5#;6D=zgR>Baue zo!P!2>e&ERn?UtG|4c1h4j=G%ObJMHF#t9c`^^fKmHI~s;wnafLxP9Is#4UsQ=y&Y z*sI50pYnf+O6LD5DtlfaHWLU8XLkdoFD#r4q<^`uHlBQb`|pr(cjDwP$Y?cbdA7_Y zF7Kn|<}He?5Wd3fz;N|(ZTtp`p%__W$!G&NdKG94#5Goqr^#c-?3&imqJdbs{HlTy zcH!6VC3thusrT|78J-U^KwB!Y3cGqT(SFew)-c_2OiSw9*`|zT^%vxv!)e@-G9D4f zCqORVpz&kaIW0@>w8TJxHKfIs`SZ|f=={>Rix26+@mCl5 zU!wg!A(%Vm2qSs;qMNX+K6P2_;fZ~2Ko9Hoq9qluQA(oZ`xy4@o;t8|VLnG);J07H z4HynHD(0~pLFZ;-AfOw{Rq;zC6brY`b!oFjHgw;7zvpI^fA@acllq)7uYvrVymf4F`7~(BCF$j#*gqoMAl>}8ECiXBRdk_^2aXmeu-1C<<&Gv zxQ~IY**E2xHlsY65v=wPTY;-w{J6W|wPvZ!Lx)E}U>z?QSbpP|VNe#59Eu&|dPfd@ z5)4A=YqF>^CmZiQD^H68I>+faXE6edJG zs+yJ~o=-F47h`B!`Qva-?)(-0m-aRsdQ)W*Y)0CFXp3s$&jai!6$!QKR%0{UU2BWs zzgoSq(fBLCjRy_L@xb72KC$O3Fqg9=Qxc2L^S?0ud1b#7cs9N82x7kA zBQX3BBs*RXuA~72kTz3(EE}6mZ6a72y=#&A{qz}{D9MC-T>mykN>bXpR#DtG0;69p zWRc(%ku3;wM`{5nw@*XF9sy_cGS zBfIF5K1M6}aga;&CZDt$zX6DVs(s;G1O++^2{$Ukx3)a9@E>4#c4~j*scM6xwHSo5 zP!}U$q-*`u&7FVSSY-#Qu#UzV+Z?4fBBh3p#t*2#t%;zBYnpNLT){Hu_xcvZ5KA21 z>Re)c!%`#AZEHUvv0yeX7U%IXve!!|dM?7qa?G)TBdr^`h94-~?!gEp4jxNr8MM-f zWyphb-<~$>H9uW06sG|ziRT8E@9O!jRuhbn-RvZd1h^vRT!a*CQ??j#!F6){?ov8+ z{648GxvRUxM`62PQ!t!A;q^-nbgr%fV3YkKX^v>XCz-dk8R4W@i6}8b{sz`T2Az9h z87JrcO#TH73j;@?WH{i!%Ry}%j5-y=lLD}YPtzD1v_ToOCingZ2asGJp))LbjFK3W zODa)(M=I0>^S2BKEQIrDrfPS);K;en{>{+oQ@ojL_S54E6XR%?B(zDa;@Vt0JGgUv zLy&p-+?Jf5b#wSyPs+KIDo`bFFkuIadR(~bYDsNiio0V-`i{7CJILF~VI59AQK$Ed-NFCVt|TqGPbTs*7{;pgnxtT}%SET6vkd3H6{ z=4W7&Ku|rRPx=gG=K^GfUw;zDL-pqsL8BXhYE(=`?6%Sdb>DayQN&4x(0I7EzC0OlYwh7CXg$N$DK3}x`mTr+DNWsJFW11{Z~gnuU^mbEIFK> zUHZ?fw_ge}{HU+>XHr{2P63>ml5n*$&qxK5ItER)#g#4t#TIj4&p!B`><+osqx|;A>6aaC-Z$Dh z?0q*@r&oWsSy}tlGJ%id@WhB{83)!U7I6?@L6Rfn<%A$_Objf50E1)6{bTEA&H^W6%U zB?&9n#TkAp*6vb{%U5sBHOI{X7DwDxlUr@=oO7BRWvseXO%_p_0fr!iBKN!bKecw8 zB)cFg1(IzCR1e;CWK;#|RFX@#g>vUsw<1HQn?w|bA0>9G6yDJXHo)k}y|kD(a%gO) zIH8ImHs`Lg#-P6n(u*3nc&mVmSN`Y4t3<3a6q&<1k!0b=!wq7b4oqnUdUgv5Chldq z{s#474(>StNUu1e_jB5}ym7cETfoJ8V(-AA*H9+GXQWqBW&>QjRTfTQduVz8Gql3u zb`OWfW;NUxI3|f3e$)7lf=Krb;q!tu7U0s`2xz@*YR~xw2PRd5jyDjC(!V2iF*lrG z{FgdLHxLVxfDX90XJh%|-P)0@KjI<-tnud+jQ8zNB+B!+pq?`pH^?r7X}LbNC$pgt-v1|(Rl&kE_-N`g)oa0n2*#(!I5iu@T3(R)OWdKl5g z3U(s&rQkc1bILtXWi}0F@?-Uar(W&1EhHhUqnqAwq2(*UiW#W(3S9pXgO{SM#;fp< za(F=F$P%OY21jW2)3n5~Lp=sY2N{%rWd5=qOQV50eTYzqmU+TQjpA~03O3&fXT2}C zf>n^GdK!kwG*8*YxiNZ4<5k3hR|>!;36_CabG$YU872Jz+(_&>&ybFHJkcNz0B_8a z+JJ2Gx`fom7oGUS#{axx1Ac$T2aGjSfl}=K-1j}-EMw%rzzGtl1s{L42AJVaq8^kSi%Q+B7aQN z8ZQisGcdf5$|I&QEc6m3^+1y6_lUzHW5rNE--JZAqR5WSoUJ|{8ZQ=2K#4qnr4TPX z3kAsW*ws6S+dwoD^;Ty@zjdS~ZC__=0xa~ZX56tDfPX4|*&+xJf(+T?0d=N*igl*# z{*GxekEED>rbg~z&#zdpG)`rJ)-Ai6V@wu)?-em15NFGp?gmT9abOD(+s;wCV?<|D zZLOk0tQ)6E*ap0c(9s+RE;5wh#|lgQ+iWB=xkb(J;9IrW(cZgmnFuw?{uY1RHQP~* z6L`OIF}W1vjIy?FdYcEppBci9lU{s~P(<5inn2EqZSiT8rb|u(@>H1M zMx^Iu|A)2j3~OrL)(xVfB1F1?5ET&>Au3HNiDfAwV(bVAS?WTXn5BS32?>I9fu$%c zL5Yo`l&BCuN&+Mhmn;lTkRYU~NS{+7Oil5A?t9ODo_p`J&pG?q_m_&A^389w_kG70 z$@U$Dwt%%@Bg9fNWssb}yE06_TsC}ipu?Q5&p7}o%V!(XZJ2W@wxX?Ih1MU;Y2=YO z3;ogD61mD9UVkA+FX=@?PsUcd!|PgNa)D_IdCs*RB(qKi2@Fr$!efE&-4c1Hp6)3! z#Q>sEo3Csu4YkT|arL`%hU}g6rQl}M&}UWa?+TMuwnf>D&(7!;zSe*O-^FlfT>bh7>bR~Jk>~sIaa~3gaKq$> zpY(HH4}aVX+^}ivmcG?|!*5bj{wE}+ZOLWAGH^@LJ5+j=BRMn8w|TYcTYw?(!vWomYkM2_^Wy_E+U+*BU$^sBcxFAw zl|Em7&d9n6ngV{}g!g6rY|5u%Kh|!?{qja(x zC3LVa+)lAIeKW53AB7SI6iRqdC>@AyCVtsQ_Efcn16<)iHS_CTJpcmJe};1c@YMZF zuH5;7QlwNe!#gROV*tQlf9RhLK}3)m1=hpBMBjmwHbL}yZlusXFb*OLZh?7BY)e+Z(5oca6!g{ zrp^}&91EQSkDzaN@lHP(a=x|7@IBk92}x{uk7-`9rt(~yF4!3Nv;n{2asWD4@6TS= zp=%c!7yadqHfAJM*cO@JDi7|cUmr_{N@Y7CtE*>U^fh?77TCi!kN+6jKDVwf&yXIi zxp?)>p8f7y{QsJt@R5F`;1dwYxSt7I+42JwNCbCs8kAH&{Fb_CN&ROo;`c#kG zlY?H>{yg%xr`=ByUW<>H!MB5t225GlaZj)JYPlCmUTU-VoxYLkDaQc?T2 z+Eo8%z}yLhi;LWLe88OP|3;0p&kHFnendE1?>09hZ~EpZVNcu*3p&f^XAy&n@5BY|1M0%gz?|EmxoK7G#>l(P|U_ zV(4weDSh+oxb(sa#Zq(Z`oH0Ksjr!oJwdmQm3!=|UR_q`Tzj`h@9N#By-!lOhue5U zUNF@PS%1L$XzYusk4l4UutnllPV(2Z%jbVBIjj5ESF4SsnD#_o@$82FqxU~oo0^yaM-mw7>LP@G`I8=-32r5{J z+>kJ?v)18^UWM{D{Nz>JZjHm{Vf@?=%c%it{(f{sSyyPaF?`?o*F~lqA7!<+jJ~;c z>M}h)P_^=Rwg%+1m=^YF6PZ6tTz%V>vA8|u?@*z2ORY-ceDHerT&QGZXZq-&`d{RB zV&cSA5mDVMu$=r*LNFoU?B09+zTG3A&(5*E`(Ny~EXvF54)9nCjQ?rK-^xAMv7mSv1bmCsG=dF5Ox+gMp!{K9E7(YJs zpC`5dX)>(-Z+CP3Cw6POK*ewo>U~a zV+`@X2~mpOFMAz^R(mKglE$4e>4W7vTfO>np9oL7c)7I|KYlH`Jg4X4;qZp;mfpay zY;E!1$HjliO{e`*fPyXb{tOz}y-#7*`ZAHS$I0kV5lD^$LbABM_d=1oJ?lz+^P*sb z!VR~d`%o>^4@ZR_<(@uuy+nXNCE^<+*@;hpt2hT-g`>$mSGN_mtK=&J^w9e@=#QS- z{H)k&VsytI`_a=Ol2yyWug=T7vznbpn()9`P>ABcW+x4%Bkf_^wEyKS?AE`v*~$F7 zR6p7zY;()g&`Ywj?yr(NPupBd9%Q zeER90yBD_oRv2Zll#jkPa!9*kZfvcOMU4Np6Ya5U zwk+K!xYgafw)ak?JOnkUd?0r39KX8Nq*~KO(y$wZ*poj)tog8BGoKfokz;dbTyek<(s z#|0}~LwAo879Y^d_^6Rux{zPdq<&xhCRuv(BBA%D$E@odV?zJtfZy?%siDEq(kpDI zzB#;ZBZziY#EZwl^j5?FqKN!Y?d|7CwSTw6;(wd_KO(cmeDfU|B^I@-vq7_fm%~{w zFu5-5X|P^(=^mz6BntHz^`T(vhr8LcYi`C8+&+8Q-1My}%B#7g^b2QA2R!&`p~0*V zhRno4ys>%0}UD}8S%$P|H4rt=y(lrz|-4xS>jIak|d2b6dOH0Tksa3i| z$=bfh-9Vdae>F%f2V*WvLi*;`zUdB`E^oqLDM8)W2A$lkgk<7;syPC%fL6xx-~u%y zN))~}oYWd%0~@@n?5@giHq2c4rPe!7@@eeTiH(tyxHqQv+>iF254Rt3?4D9h4GVrp ze~JN6f*DC}LH6U;)Ztr5ad;Ee#^4-pT|Y*8RM_-ViepbyU`9*&q|yGyTyEXhcl+;< zwd;$>F^61j+U|sU*sIMFC%k{4H1t&*A+w*0MpIV9TFIFpWg?~GY}m{$#d;FF(@h%` z-D~?9ANSf%qeB8*JEN>iHZsfih*ce@&}lQIr9PoXq_E7}|Y?zk9v8Iz3ZNQxT*buF`dRNqibwUowy+c`>5TIq!qqxAfg<|4-%Bn`_t&A!5KP>g=wXL%5AWCzR zpPn3zIO*py&`}cnJ^cM2w?Zb$-&cjIefTFgpPE5ycA<$F^h%OKznv@8b6pQvHT^)X zaJ4LXP&5PQe59tTQh2e+qD& zq5|5?9{f3>!bvzE|9w@7`Y3ilQ>Cq^yv`2C3b5juiNBzFaq^_geezdH20x`d5l zTF9|NWX~JIQe+nw=fHAqolB5O@-h%{mIZ^h>>bF(jg8% z8&UXIiJA35`T2z6KWF_+KcDiMylMKR2?yLtd?c;e7av4G);EH==jARUd_2p6yoZ)> ziMpf_c2S&!rmse>V@TlM;dKdn{TDQt!lt~e2+K-@aL75OS8xA`oEVF9b4i|wOq6oh ze+dHrM+EuTB{^s=2H9GvI%Fw#r@d>2uz+o2aOzO19W>FkA1H_*j3Yva&;o18G(Zsq z%aHfvGtKw~#qd-bMN_iX)uH4E>O4D)S4ORg$-glFT+p(=KE)-j zQ2%}t+_+!CE(D@b`4A6{kFpiqPK{}F3p!D?9I=3M#nH_)psfoAFs(6^Ebfn|8X=zY zfJxFU3EAVSCN8&Y$wSKuzw9`dTbCs}o*g0^tg5c@%cnaA#;+9Xt9J#fBfw=RJfq@h zExTd4EKHeiKR6^KYN||-1PMLWMwGo7qeD5|Z?v=92HS&&m5+ll=nQ4ahNZ^?Y-}|( zAL^?^K|DN~x)Ow(ZR}9OKxtbA$&@>62GJ(&$bFHJ^QbDIhS>mRT~%!u{%o|Q#6stD zfvx!}=r>X7;ZItt2~~HNz9>i0N{QDR4m~7GTUf?$aS}uC5Hymmz&|2C+TLpc&NlWT zIl-&?ZB^+jXzxJOndtfB@l@{>1yyRD2Q|L9gS&WE;R6$rsSBxp(H2J5kCzfODTk1B z7z;Y?YN~JUefZWEr}w!)>p3)=@$Gs^ZDr<&Bv4jVeZ(+vdS={IxbA(3?8`4|Ux^A+ zP;$>7R;IH4%^6_tlhDC$zxL4?RvX@)2c${5M2}c}I{1fUzO` zfga!I5HH zwas>gy1Z2Rhpoz*NPSJKjOFpd?Yz5K4z!j(kW(71_gsjB${G!>A3-C;khMA7`&_@K z@<9ZHLyL+^{lx9TPh+MJYINOFQ~9wWzv*xL*pv4_c(>RCDtww~4D|!Gk3T?CdF9F? zfraZq=>U8HGy6)^hf35H_kk09O8;_`Hb_^!Ntarwit3msTJROD!W4AQ&gZkcX7Wdc zvZSxmk?oo|}s!j6XyL-ueJZhq4RC zPfQ7Q^N%3+9)7-pPGyT-;aEm$d24bqgTd6o%bl%bHQgPvV;>!?{rVy3?%sU;4dLx5 zYEGxdHyOBqeV8vdu-E7^;M=s>vk|J!qiS>R3SEwB5mvrf^$!1xFrk#YQvzri>Jlus z+=Z7Lu*TdFNj&rLGmeyu+dv*^{vIu(-oYkDEw=HNV>kj@fyoz|<2e6M1Ks)C(eH=@ zXa4b8RG!dWg;8}07ZIg9kaVa|8c+wlg9%(~v#=dsDehwb=w?BdEa?t9G4h*jt{lU4 zPX5F23wp!&tGl^6_UF~)p4&0kgwRE_;$brAfXMo3#=WUg+^>*Zu#Ag2G`uL)8>@}4I&gXc@rK#hG^pe3NJA_5n;M>w^ z*V)j1;=4JCrRsqm>jp&dfXo|9PQHmNoNG>Hq7(BPryg0~_}H-_uHHyWfCwm(q!gC>BIK8eAlDd1pr^c_CA=*-zmnONtbFP-(b_pd+O7OY-$AN@t8 zY;-*a;JgJ3!R3FY*xxy0J-{eaZBV_%=_&6j&{3hP->f(R=CD;VsNQ3a_9XLHI9|yp z$Yfb=JmyV(bRqiULl0Y%IJ^%q#BqL{%v=X4mYXYrJMC-Bsap*82lw?OS6q+shUy~n2iPw2MqHEc>eK3YR6oEF8ds8 z)RJLw3~b8Vz2$OwkX1|LPA|QdOK(0*4+BQ|F|>Q!I`KEB{DmKm-aLqY=ZsS91^;)P z*6h@93VbbXWlp3u?b_lq7htK#J2eVzMse_z16}*XsLAa&_X3~t%R+v|G)FgO31VcQz>E7)f?)?Xr-LNXm{7uo z!!ce?5Kje|TLN6u9i20NC&{U5oI@Q6W-2Roy4p|br>jbjf@xkxyx+lpDj_=*v zVH+g2*tO6i{DAN%+;``EcYdR9tj4~0$rluQ?CXKvNF|Z*{B2eKxZ9C^Z#Paxnb{rb zsd&)XGi!#E>A$RGJ#VPKY%?`6HCdP@=^GpNSXE%Gd*a@Ww|~z2h@$08D-7kT!wh*4 zZD4N~dzOee$KksxWqtq$4piR5Ph3;{#9V3OG1Ocrcs}d!$cAFYW4dev;4cr6zrY&y zit_E4!fGNEF{02fYI)P$rsX6%|7BzO{irv%xXEW&=@VgXUO>=aL-IT7JyjRC|&Ram?yS z8mR6}y}Bs;Ws(;_2|aDXkg%xW5CnN#d*`X?#dtkS8N@hkikU#t$o@P{)WC?7o$ko))5 z)SW6tk`MYtm?g4vgKfmWPV0HD)0lQw=p?8#!{leF!|dwBnkGW#CE`L6v{9%@xh&Pl zZc;7mbH!KC!jKCyhlB}3YiEC;qF$xmEzy{u zDRhalCeUnt0UWP3INr1Y{?k}GmxdxrigLw9U#ss~;)5~sKG&f+PmV<|)D{{z5Ov=_ ze6;f3bN#?T+Zi=PEVrc?0(rJ5O9&ms3)X(`Sv|+YzaTb~G==AQxyn0mI>&q)Jaqq$ zg!(tCek5Y^FV>Z>v{sU~Y>C6XphLlYMFysZri{Y};gwqzq4&{~=l|On*1x_1;GenP z-@!L{JG~h3ZUy^2u#=i+B>bfat<~_ju+ppJEt8&774G84tf|B3v&?te{#w&pUU522 zw0q-?%Uuuu`uNxC^MW_)K!O8~(gHf8N;Tr36)P#$KTxmpP&2Qjnd`dO-LObob3&Tw zuz1CV`+}5|+M~Z5G&r_Lf9X=S?U>Cffza%M@(%vDEP<0$$~S8qX%Qxr%j5DgHPu13x@sF`hq8dR1u>EeIr)<~d@5eM zVQ+yg)b>PT2Bwf!|4vR?Q@boQy6$XQwqVR@nb+_Ae=r5@FJ@QOeLB(Gsqqd|ovbhj zlC>$>u9{*(GOemOO<^jbX(QIHbSRG;E!Px-_37)MoEUd^?~UBXmIOWY@$>gQ6LIEA zyDZ<>xcpOX&5PQ=uQsdg)s)L<&48@IT%B#9CCCCi!|2Gr2qvzUcr z!z+5i?LRAAp8AADU-C{b@6dno-i5fs`A@Z9QsW|C#@*Mh2X)=t1V~&LJXdB<;IN8) z$~zP%33h=$@~Bm{s2bw6c35zz7BDG^)ZpgUU{sT5lolB$U?f&B9yBC<63lV(DsrE+ zE)^*sxVD^7M}mM=3{#tET5M4PzWO(!CQCcix#|Z>lWIZP+=<(SIPL6bYP@CA7Wj@A zSi)J?W-*Jr%1&Zx!W>Pg<)Ze%4!y&@l%Zcff6vIFKOu(J72Jz?Iuu6>#Xux_rovk) zL@Y5A1K=4CHXaz~=u!4Vw&^9reP2&{i3y7oUU0x|asDccO3Vu~ZExBj$K;$R(`IH! zw|l_*oX@Xl!9L(+ZG?!;oT88@djoRc8;@vXz_p=hg+UX*Yp!jVJJSXhBf9~d{sYD7 zRh#MscZLQXBYg9~PXY%Kv>OHr&LjT5arj4#<0hd7aYsp zD}m)N-n;IbdfxEhj={V2YAL^J-;BfaYgF3LexPopQr3Ww;Dkg0r4(Hje;+;Su3EGU zVu+JdXrfz~7dSv5Y=z8UmJWaZfilSZdaTbCBc3E2t`DZVQV!RoycY(H_Pl>{x+ZD4 z#g^BttJ1dSE=s9VlN;YxI3N*XKlmwfrpbH>^r>Xk&G(_cAg{GCSNL_*yon14kvYzp z@2@xdJN@r>a_@`x9>%%&q7-XEUHJ#?qdwk*HW7nZfsf_RiBv<9f1nn!6?WY$2MP!b z@udp0e%I#@72e1ph$yZu3nXl@?`gOoo)!dgoH9q_Pq>qw)Qhx)*!F}plq$m267FyN zfl{Z=SM?KLM7_N?nMR3*@y(NVyqx`Fi=Jt4{s2QF(}{jAwe3kE(tc9T%986&gNA=F za`NNwkIVgldtWa^9ITHuzO0g)*TA_Fqj;75_=O2UAXtx)FUx|6$qJiGC*ppS2LW_r zF@pQBO?~kOZsAS)XcRa*Q5XH23I6;KlpIBUL;HRKdAl7W82WFoQN;YqBt5!~fnfPp z8^U3XYH^5sJF-hWlAt&u4-gErGho3J+f4|-B zb7Jshz)+Q8MYZe?Ld531r=t&|Mbom25MN=iOXdzAcqt`;c&srQ4du25tm!mu5qx5b z*>MH{Q?zmtolRvGM5^nv_VTGfi-jdbaOdWe63g=9EoR$T_@-l*%Ixtj6c z1*(h-rwaMS#Bb|0?vU2fLtp1FPC36Y4sTBreefqr7naJ^M?o-UX;K_Phc%Xn48ajC zCf@1x!erbM*!_BOk3vm!Dq1=|-f0q-^RHK|yg;eZ(A}!de7l5=hK^jPCdqMtZ}AwRcDo zf4lv)FPYEj&8+!;sgpPN?(e_RHetSToyJTvaEj{4N?I`EU9#*6vN@>O%-sj>Z<0I*+AXYJ+tljR$ksm$JW#(w^1rXwkQdQQkKyIr;+vE zO*BJtr7T?eKw%A3LcDSbF+qjzi=rpsbt7X<_`kri^b6q+hQ_{^&m~Qk*-v5*z{=c& zsPLV#@4r>mRP}t!30ZaYs|2{OJ$Wd_0`L%2Ao1Gr4`60HPK~VIMw@rehRM#tSAsAW z?#UTO=S{VHf$M)&5fuKY__`~$Xw2yAz&m$|pEX|#q4`6C(C9w~-dh&Ee7qATj$h($ z$NYtv$dX?KuX_X!kRgOG#w1V;kV=j@2F9lR)*nR&(3d%G5xGyg?*)9dvZ~vb;{IT; z7Aj7$SGphUshV_t1C4&?ggAr!4aHt=_u2>jPOh6DBm=-eJb+f4&(cD?ky0r(u>kjW zmTjPAwW|^QF>3)xN~wz}F3|ZuziOIUd-TqlZQ*%j?dn`z+t^4zll@(HNji>y8IvEn z+3wpP<=H;iiJrkLGw^5eOH^(27vPn%2J)M0UW5wpEi{ehhbO~c4BCKIeel``F_$H1 zWAeR;n;tn_B)3)2_OikzuC`7-k68Fe-OFW*->Z+-fkSnmAsZPJ3^@TAQ7yS3_eUz5 z@s-Iu#&WWsFOu;1f=9JSC9`K5&I`SDkctk1;w6<4HEe;8J>DA>lRzo zGV7VOnR{)+i+{;md_!`>;B8KvTSXlHZzI)`Fu5ft8$o6ipF|Y|tc7YOI^;XZxtuF= zlU6Y4Sf^sgeTp%XQ5Kx{CO1Z^bs)ygbKl#@X|0p*LLH5MclHXu9CX2<0e1dN|N3<; z6s;JYY(Z{tyWhIO^`iTukPCmUNIN8re16s6Z23a(;|qLF%zM0SyM?}5CFsJZEoMUz z$rH1%T*90D3RQAxnm7&0uSl+V96w;)WMVVi2yU{tIKwsYk?**n(1_|1@IJ)J83_Np z_O)pp80H`9nfmlRC#o(@@cqr@)h8-`y}TW7$I?=OjZg6(seHN?#SWs0-sH;9A?o7d zgwwqbARg#fh{M^$+U-d{(H8}%5|2<&k89gby{hkHhI<~&epCBLYQ=}e)tge{Fpp@^ z0RX=Ct2Cpf_(7WN48-7doRM+qqBr&M8BSd^H-$oiy!|>UmR5@9Yn~$IY8dmRhvUG%P3YLU88J-tJz}B zS1fFEv0`@~e}Df>toHaXa$I^TQa!h$E(3eqY{SU@moI8J<+~q6shBj;Gh$_KY6G}g z^LM|+pUt|)(uT2FOnMS)nKFlJ7K}56u*p$0z45xjTn^n7gmhcd#wvg9*Kw|vaA1Q8&Y*B1jOHv{Xl`r+L9#gzQqQkv+J11hl2w~&T^e%cD@F~_WAtR&GKD4V*DP?#YS1is zKQ?U8-}*JgH}O+?1^J3Z6jFC@DvSJEm%^hc`1=t3c1g(G@An&f%CC=_ydV5lUFpYP zrxEraQ$JQD$0=e(KTxS)ekfcV#~dfeP!pO@(pVJ{Lata>BDeH6;g-ga1_i+y*RhfQ z(cI&8TJ#%BpVnjtvrPJ<7K9}%H9wHQHRM{-n%}iL!hCvMT^@xFuk4#%-7^!exu4w^ z6}$7-Po`#e`$qo92NQ0*OXE&VcO1#V=E>K^QwB{M81lV%8H0 z-hiBYsJgq#-@Mgqm0m!=kca->o|B#n3Lh`&xDXR_Av`cdzdxdR>3wqps9x5s%u{V9 z_qB`J@v4=>gNXci4|bNVjo^7K6p{;Nb8**5BgY}fI{?xgUh)#|%P;cVmwP2+ zI-%!e_45}|jdeNJM?RHk^j3j+rmL*Lvo*>pry6-Me6d;6lvO3(Fa=W#-O!c1e> zerW0e!{RbNP;OblEDOn_r1j4ebzIgt;k#+-zF92lqPZG8m!MitcH#(^QPdc|WO{Rf zbx+SRNXGuPW^vHd(J!ty3g6ZZ?IQhd5wiNm_MAn+4b*@cR0s|SQC~_iMhbj))VQb6 zn7pvP<$Kn3`$ajTfZ*dehveh65VK>@b^ZCj$~X@~zxXN(LjKe=rocLzlTaXQzTU4| zg@C^w?d+ganuDkavlr%aSLB|pe|8Q=Xzus*0Z zZ|jYr?GDXL)z>ctyCF4JCcIjCJ$})LWtZpfF97W9W+q;TOxxWEsqU1G*EwcCAy*!w z?}RGoPsT1CHv-}cn<{@lZmzRa@}zBXT5Qm<8ffZj#rW4zL1eVkjo>=l@~0k4-i`L> zE<>H`{5ho0-M({>W7Eog-aKEYp@(l*c964lUw}v8jn|Jaw59nE4IDG@+>FxOZXOQh zN--QlCQCPqM_=4GvS!!Eoqt$IW4NHbaGzg~N9w zW-Eq2`!dVm_oG)b-mhsyT?q%04p^TC9b&)xB(6xzYK?V2mc~Ey*8UE|o|s59c4%~9 zY8f4>>vr&qiS_nCE?+JVFf}{S_NDFe#;M}O^WjC;x2@Zairpr{r-5sK&noQ{@zJ) zlDXvj{jNnaCy%tymQr-2m{fDOzDbIMh?cA}>Ib7hFgn7G(}DL9zn1UE`f3>CPU&I# zb2ec`A;-PFE6W@7_McAV9@_iyP#o3=p>wVzF=Ifl@3P>2szpzvzaBR)H@SS)Wqs77 z6K8ns%f54pZ53nATiyt6XWn20kR!N`R~#Qjg=rNPN8cYm-WNe|yiLgwnO3Qd&UXYK>Z&Z zUW(T9jEb2zpJTU9Bc4o>eNpBp{3SN(EqNMQ4ZAK^Aavhuh1)}c7nCk_%-8BGFDLFO z8m;agb1vqzyE(ROo3=fb<~g+UOLyDb<^1S~1$C|^YBNB%^gpABNj01mH~TY+oc($T z*1i#5`mVfX(DMoT2-lZ!tzmcY!!gs#4IS3pE9RwzCk<0p)xNmJ{nB#S8#VF20`ShA z@qcee>3VEMX?v^@p)}THe>)ww#nnw>rruhoogtww3CqK$DmF{pY=Wx1ESd2S6ae)&A320%Py6v~o-mZfye zVv2#ZQICt)#VrgV`*I}x2@?e$!ps-GgjqKn8^!j0t7>bKw&YD^lP+97<94^kaq1bt z^i?(&?wm*FNEt17lwv;sT1ai?uAMWOG|Y;}Fom{QVL+a2GsS5Jh$nTXq0to(2-I}4TrWMn5awf_{pP1@9)NGBd6tUMExRF zcf4%8DPVbz0)JUjdhZNZ5Kz#6rRdH%%C_R+amP}(JU;CdX^m|2$r95zmvqni7`dn4 zxX1Ar&vx?p$)Np-dBYNiJmaIAmKyFII(Z%?eu;v&8-ioj-qkV;LRLl;dPPWpVSl;9 zy!wY(ZA_+5A3>YkOxY~XGOkXboJ}$aYX-k1pE)sfuBTZBHrZcpJ7s?e6*cpJ z4DqD>zhXf}pfW=dA`b`_U?;Jspe$Joq62F*!74y`)kKV{tl<7hPbndB*rL8JSN0hB z^ZRw90PQYzASvy*;j)3@JLToJtKr*n;ULfKef9U4zxytruDDNT%TFlIDN`FPp>f%B zB)0*3^l?<{`WMb>EZIA1br$~CsmCQ;h zK~FGNU}dtR4z*x3m*q(w0jPNFUw&l$#L ziKEkJFc?or*n(UB0!h5z`h=X_9AJr@3bIP_ZmsK2v3209kNGCO46{wQ{6oV?gwMjc zL0OX)P(+i;2x*r4DSQzcoG#|^=!nNGT0j?BX0^EC+S@=Kh6#UC>lKr53QB{6>*tV!Yw6V=BXJxrP;oUCT5oNt=ko+hjZKdnF z`iOs^-tpUr%UH`X3lx}c)e?l=#9q;G49aa`Swr&ACIn7B*6_1xV;#iHs-PTJZR)0w z&WE!scCYWQ>cEP>3J~2_>SKiDE=rX0Da8XMPLhSW@_mY3h^crw35*t9tI$H6M11~@+EbMc$B!1oZQAXTm_HBxgKL6BM0H!tQn!s0ayGf33hSt_aM&a8BPCXA*%It zjWFdtMn}~_*K0Ubq3qP9tFw{B?GfI~Q*dLaz#_ zKU1_zgw_h7En+#0nVTS%_XEZQ*1d$;Sr|@rUD=hpZ1hY@!|unUbF5W)B6STe%>d_2 z`4uW|!7ON%3XKL4q1Z}cXbRxYc`A(JFfstmahx?;t%;~HfPfQHsH;wpi+Sei-H{|s zYD<~YQ(RCasjyt zOU1NFOUOcYzbg-&ehH(E7ds%au#>pB1#q31Q32r8XQz`?DC9CJTEsU*eA`>=h^drq z<)cn;aKUOOR47a&Ri$fAdhe}6eajWoCygZ-9Y2KyVtN6#l9eJJP`@a5f+$}VYDbW- zqyCLqhT95O0e>nJw<7yTGUNIyqdIl^nyY%b7&yp!x1Xdbu_ON!_ZLWi-icBMpf z=qzB~c68cAzHGuDVxOj`vh`V33gefJ2)mHnhcP63N{q578bOk248;NtYHFlOY7!c@ zl>;7j5w_Knk;t-x<`Sc_mINR*Elzo^1*@JX@944LA(7*C=;#ygKGRPuzw6?^n3f&X|T`pT)R-nEm$!%Muh-f1vC3z@_=z96>+4|!P&6Nx$` z)q?lb9$iI1CoRO_8AMBD5)8?^S}}`o%f}~SY>Uald{~`x<-NH%9GytDMmz(cH@OjI zpSyPz=_#L7AS7SUHJueGbPC3d7K|UDbA?QFQwCNtTnb0~CAG^I5C^0@p|L%7Q9u|S zO>vh;fGw3e__LbtC}9yI5}J(O2Qv~?E0FBwWfYIjo+I7mv+3`c*6hVVAv}3Agt2VF zw7^O1)XGSt8RA9sh)`iwGMAR2((0#$lNN>yuj^868YOC4^p&~#88y=~oino~!ug@X zr7AOplh>BlU##7NykM&Y>_k+#SO37py4=PR~L=j)ZhjIYI zaxf_e!KHMO@)Hg#Jp96@7a~$ge+yx`FU1$C;gm;kyh=akG151>dZFVT_B3?6+EH0n zJrh-Oy20o&KqS>9HsMI{Tr1XOkj#_ODwQn!Z%R{+$?>c392mj4fhfR=@NItlRQ6KJ zDwxlm^A12E5!m#yD1w$^B~l}Dv*P6?rx!wt<=)p6BoXj-dIEAxoAc{Y!7ZZ-6hA44 z#&nwWhO%1ORmJh_P>dc00|%wL65wOBAaJGzpbj2%OyLFS zqPMIJHg9<4Ga%US@aANXAK{1yh?9lBiMp9{@jMGJ8xcDk851S;bV<$HF$UVu{ zs>Mgd{3XJ7WDPFSh{;X@X<0XQtuRz&*#qA1$nHKs>!lQ|g}kphXkD7)0Dhs9aRx@G zmsR;`xfAj|Ya45RN0;M+gz12YnVu$25L52Nm8pyxpj&kZ?nIZ4 z9*Micm;}|S)dTP#--5`HB?nVE$89Ow@1v8z8W25MeX?rtkT`2_x)sk1%5=b|;mn|l z8}QC?abZ?GOB*mb3tW$g!mZo>@Cl`A!=S2Dt*}ZzAH`UXtTnw8MKl;SckCqDDt2BS1am)GWLzW}tV3K<%=Vh$l2IBDRJ{>_fJRC&Lb_ z1YmZmf>fy3gJj(I849j;!t08%xuY?KapdGAs;jEc8BoN)#W!QLm?VKZ&xkmm76N!t zbHf@ieOzUvaO%Q`#oz}X@r2qcLy)nh#(;>F9Iy&vBsQQKioMWNB%k{nSxqpcxMXpi z>G8v_V}MmYYO6l($v|DkPhzB6L`n373piLT1WpFruj>UHp^>ZjK(rB{DwdJJjaU*% z1iTE>J;C-d5(ZzyEC-d?12HibQz^X4Z~%*(b;@Tt7B|>QwXB-IM6qqBA zBR@x`+C%7P6z?$kL4w?qvPPNRU@SjImhXc6rzh&A^fbCIZqvB=VnnB$657j{p`{Nm z?*z%lhCe8nZkEAk>dHJ`>oX+Qp_HGLS8=tN?7rhA=mva>2)(OeAR8K|sjD_A_P`h* z^y0M^Si!&5)uiAIDHoN`U5!PP=f^#v*}HY_NuVjFy*1DM>g3s)o~nE;+iz7~F8eAo zJv(-`eUcvBbSKJ#VfNt?>f5x80z|*lGF~l2NMx{Ffg}v<-ZN3X0=LzhOG-6gh4??B zI6Mdch$baXYC<63w_Pb$J$gc}Z^B`LyGW#{iNmekUo=*BDNM!pbVs_+?tS zn6I__0kC5lkDmb4P5vWXATP8sOorWMWpD$|`kC^%Y7^qJ8!m34p()Fr(~m(z#Xtoe zNCpvI*VXGG(k~*UR^79f2J)}k{0iEBlz8`=TEsIVj8-u|Yy|B|W(b3?@BLpCEs2DcAxjtMYD_H>ix@ z72XAA^uv|U*u8JkV;+Weg$Viz)V>YKH?_j~tpzKT+3Y|JTGa(c^H~93kEU`k8noc) z6yQV4s%QzGaFB0;MBkCM1R+ACrtfJKtK{b42;tdu$hcB z%5L$F2MT|XH%4N$5RxBk6vv#NhxE&L9fA(zi`)pUEG=`r6H^K|N!XAlHyVX0r)z?K zTGBiOyB`|4PF+W41DwaEkp1#4ZY5dh3E8GrjC~z5>NgSwnYeRkix7*JE0=B;+BEgp zd%CzS3fS>j;8RrkWZd`9hPUUN@Ia^`Do|}zzL?<;oN20y=CB7iG8&v5SFVVF1#ak8 zs*a&@YTZRkU0`NstGTEP8jVEDl2 zDmr@f*A>{S>=1O;C1<0i>9o8cE^&|~#kXb|AvIzKceW87pO* zA_?w2dr6LS9#GCBIfiV)BQ{)5TwMGfso9=(kb7^ZP3^DfSNv=EDyLKmUc?w^mqm0_ zPQiR}@im8UKog3;F4P5>%Ql4?T*Kq1`)55`C5xZvAJV=>)jjF2%s(}o_mN@Fl z{wTf)S$Y(r4W3Ef0UUJ_W!uwHCzWM^>b?5gAmt-km~olH4k~SCxgq?=CqjYnkljqU zHoQRjkm{yt|6bFA#{dURYb7NLb)tmJgY$CZaqAV9$c6i0G?-BfO^57x$b^)ka1*&% z?Cg7#E*^y)?>zCiAVFMzQJc!cC$NLt8G>;Mc7owFnE}5bC447Le1rJXS$4YVF2n-E zbHN*tM|gk{rkbB5Z|G@*DHepKSk5UU&U4AvP>LqV53k`?*Cu;b!Qt$LoN-S7eGJH| zf1{l3tzyJsP@v9pk*>YR2*v2INkVN!05T5Dn(I2!d3`{Tz>n2pUw* z*wpVDR~`6i7eOcal@Tu19LuqX`ja!W%0h6<(_8BLuPfGl51ucWp0t*GhX~B;A)&Y? zQ?=E-*h@}OwW=0_W}!W*9?T1NDpj8hI<<(C8nC7>6y1tR8eRzjjr%nknE06@sA(yL zCVYDXHbCq|SA6tSax||%rz^^hLe3?;RqUp!&DuVApa@5zgxZmWU6;>F2>W733b3BhUa~ zxn}Mv-43V231Vg)`S?LC^mUdR?3I|SF!FA75}LBGNR}u5#lo7)R#z$Bj}@lRI;Zqn z=`XNcH$V5vw_xntG9;qSkPm(7Vv8|QgClE0Rc-cxrIZNlbtcof5fvL=@;{op_OGVS zbPZxbK?sO)l|<_xS_r9?ON)VBii$`vDk=zu)bRp=V(LIjgiV5S2^W#JjxvQpP(i$5 zqyn)R5+DKEQsfRA3dv47a+keFF8h$MJ)ghLnzhakbJm=-&Ofk|wb!@b?|Gl+d7oFI z58`*r(RP8&f=CtGuC``rC2e!rkeO^JynRTz3;lH%vFRl~;Dw&7Z{Xw{Pj$OAFCycg z>5!%T#JU{@-@8-g{+Rco1ks1>>ui6+6NL}h9;-JhKz<|!1al@oqGK(v9w?((j_QI?dw zzE(M@+LZy1qvJIIYz_7h+_o5GO zk-*k*gd(ejm0c&$>*}I~#1sY|k$^cLM7y)N&$`@$hh$r(AWNxZ;=LDfcFTv%CZHJx z_7P(f)E;I!yqJZNI#^b?uX4+ALL zUx!c0t>}C2!BD?<`ssa*gI+6)Bg1!kY>)n6^7_|*8r31a?fcgNRKp6Yo{7L9hX`uxO|jyCpD@q+xd^_^x=Ht}8`L$^UY`DY{)`Dh<+}sC&9F z%3nyv>;3<{oRAi{VcTiRE2H^tE8D=lKQkH%%uNoQ8fKO;RX2BRqp|+|k zTF2hS(;pjDw-eq0Rwyltz7r`GIrD@qlGI=YSa$8zLKbN($x8=-2-%2L7t!E7##nLQ zTccAhX{{n>umz)g4eSBPNRa|qhKTnjpoVQ?bVTdKr$~O3m*`HE^rUj1!GBJxFT#^K4>?ul7 zuE>s0Ws5B4FJb(#&KADSpv+-XzM8)|5Q{~8M5w5>Btqy(cddxTBeZ38kTrKTW+&24 ziyiUo;}nOOgaAryZyj~}Dy6(OIM=|yXo#Sll`pC%wRMvX!FcEeZ2`^v7d8UE2og%? zTVmZgG?=Cno1f%S_M^@ej3Zv#h`I*8r1}0IeZQxDdp4|>xq1~ViNUrdA;FQ)VilQ*} zImc;qLd6j-sGSX;48gI8OUh9oX^8CDsR7@E8_}borY0`JuT5ldb&9!Ei9a|rR9|z* zD0S499YCa8v^9Qu#$a|?*NP;ck$MLmICWh_c7QDlc7KKoZzbFik!rphrSA#OHk{>ZN=HFYkF@7K!h;U> z(5aePTV!xitSRjwovK|aq5&gfdUOYClk8)BT*tanjKmfZB%alqL!c$6+g89{s9dR! zwqUqSmv4IKWpj4lJ(o-VK+-!O8WsV>{r0;z8qfW;BseEoWW_EK=hkq)S@%Nz=Lbc= za8FS}#xg&ANz;7=;GAHjyP32xevxoNeGBJF`2lA5;nOLx8q4r@pb762`utG78~t{W zyVzqmfpnIc2gYh$7{Nm`+)*bNa>oIq<*gb{OO352BI6W#@R}G9aK6K-OL@}M+P6k7 zys_oZLzwWYAxRf@{*99FfpK!H`{rjU!8vb^4T{Ho8jok*jvI49iR)HnfU>ZfSUxVS znpCAfeUI@{uSpStBO({>G(bHdZ$SBGj3?;;1(qJ6qu4q-(!+F+3w#i3cm`mlBTp1l zda$mx?z^SK!-k;L1}reaQYNYjtY#nowyIooKG#@R?y!;vx^l|ZLhRXIjCF;of(j|? ziQSW9t73aut$x8*13rYe_44iDeSRs11H~tVp_q4jk(<)}+17h9H94Vt^T6$Izg!6M z_^U~hwsBPU6OF*JF&aI2e`sm?uF+TFL|gf0OmtOd4hMo6p3mW9 zc*_H#TVU-$Y=J-O_oVMeyPL}$g(oHGViQu(bh<5ya>?LYwO1?HFxBXr>pA1;{Y&+e z$9+`tB54gSP`KAjj~_Eynp0V5>@&fLclW9&Fg%i4oe%F!s{oE$mNmRqr#7BySf*Vi zHo<$)#HB@HHsF$14uTUu|8sqzXYA948{JVrurrD3qb>MbuzKs6_TjSHr$#6MIrv;V z;fklJk7N4T(Zc8^qm`@Ahi zYMc*YZn+%(rYZjFr!q;}r1oPj`kV?H56lB&}T!Y#VL0KM4ne0$1ndK736xl4ZJYv zn&;rIb1k#Gk$O>U8em*S8y7@tCPYu<1@d!@wIS4{tmIKaD`d4G&m%hnpR0R~TSOmy zYply~9^p78vq2X`+4Y6z701K&jT{V-GTGYD?;pi{W%Zi%Lefs&f#;!+R^7%?Nx(N& zB-_mIhOBLYx>;R|%3E2h@dNHuMhoCz(lL|IfSBRMFbS*XEJO60w zkkqqQH41waBQr|@TM}WDZUaD-t2Nh}<)&sc9SEcn>B@`sKJkqQZ{Ol6kY^|0PZ}}P zno8b{(0hjT3LZxb%dE*e!DceB$au=Bts~E)uC$;qV!yyTfsMXlq8{rfznL^5cjzcD zP9ttt&ftw;zmlZ26AKDnDSue^3B2)QRh*NsWj1M%)ilWEWRC5`Po#R4%4dqKaaOea z$>8R&7|Yl_Pl=BDK5<<^m(}#Kep<61MF>5K%}?g!JAs8SR|I4@5e##Xtq6B!ixp7-DS)!A#54_2aIy;xgeKy?**tyGZ!qBUENNHk{ zGW0=4YH*QkEl3x%Z)0Sr?YREYkv|T}j1pu4!&2`%FPyhjP5VODeDXBQiu*CQL#265QTmUiE#QGW) zWN-z2@V@C;7H4$jZ^@il%eO`}!({@@;6$3f${^*bYbBTXJKSaiN;>lC(bYw&+X~7$ zI#oxR8R~5ThoiMK{eU|7DLSmG>&%e&)>eo0>UE00kxQCUIor*cXG?+lMNvQuzd|)-CDjK65a{l^AA_X1C}+{ROk{P+NlqEa!{0 z)X{N8w8%P+Mdmx8X~bFNEe)9Uz`Q_6 zkWsPlcK^&m>1?=ixMXE17d}C|Lc25QQTI10(QykXFsGjzPm_&S%BsPIS!8BlVZt_& z9sD_7gm5y+fSl)QEjhucK&ZjUnPNj=A3e3?c@dADGXt?{*NuQ)Z%rt!#iy_~ff*~H?vS*_mx(p}UfKItL;g z$>Q9{xUbgpCh`Cf9lI2A>$bXLVtc;_=TUt$lW}}_&ahESF*_N*v#H{}2aFemuz7$} z0%T11;BPeQBKSSj4e6d47xQlQgEfFx=EeDHOJZZ>$tZj+@jmcQE?c%=g9_j++RcbTW+KZRk>#%+nBt4l9eYM4JrZ`u&jx z&Ql2}%r;LG~bS@JP;V(-+bs^0x>0NlXi%Bw^ zn}z^)mG}fFNByI`mGjbfzmS=}<(3qUXmw#Q2fZNccYt#8#(B^}bw2ui?|tuQiYkYj znKO+rsp)r<-)QnL@)$Y5q`~=g<+jX|7rhvbwKr+QB9ttn`Lf;3f{8H-_NYEZjE^9! zEdKUxq!_=1fN+ElWCQhS(cPpI@xJ6OJ@ZsfI68h=dJ19MBo|OOo6OGH^Mb-K!6gGj z9kus);Z`;#Jrcc_T2s^MyoX0#&C^-h?lV7R*6Adg zNvNJ&gjR7G+0aI5A}Rv7;;j*SRiTL$2K;FBqEWo0fEDIH|lK`_X?P6t!hG8x^6DK40OLrlH9D>p}A01}053SCbf8h3GZSmoO z*WUg?ZBb)QTK}UaubqrAkZ1xrSMa(ySp*s1i=;b?^&vp4KzRKxSjT1Hr-R8VM_cLWD+!7=49PQt07Cuhy zcgZ)3T&Vz```0#&jycK6z`9UP^rn{~ddK!YXOh_O6 zdDAIvnXAD!u5s5%ujK=kOO*5dw6(bvrVU~}EiP5m5f-ZR!@HF`*)nh36`9L`>}4B9 zCu3{|4Qnw*Gk@JvyhflI9IP6ULQsA(H8gmD{}KK?dJ^{6TDVjBzb07v9)0}XSnqEd zG6NC4NIBm3knarpW5Kh#Fd;y)Pv%-lHaMg#H^V>CQlaKUzpE)Zs+t?mP=!KZLu{KY zcc=rhKWz={Ka^Z%cDQ%GQ@;Wo!z?>;>TEFE7_4q*{NsepluwDiw?@YEaurJhcxTHg z;scCyX;vC^AGc*nu-NP`dR}u^ND=r&%&b+u-pgXdg0p@ybu2rnFs0QmIpz3r`Sr8} z{~wBXdbyS{jp!r5-?B8jv2uEueD47<2078gD<>Pu-MFZ05q&uZ`oc?;-5M&{FN3 zl9I!+m03-RoX?`wO1%YX&GeFAcQzD9%ClE*2zVce`Ab;~P38hi{7Lh0j9c-Zf#gyy zh_4B%nBv>^crz)=;}L=pib~_8a+?W7@Ht?T6gwNjaUtfc%`Tc<3&4vnfTA|uFAUUb zChxXVW{L*jt+{HW7}~^!^w;&aW92tKz>X!-wV&vCGI}jaIBvBY5Z`BP?>(D zZ@x3l_4_Ba{YtyX&plnA8vU1Qe9-}YRa%Xw9KlmChL)rd<;Sc6x=e^69*t;0m~8qg>}=78|U5?D|yrqJ@8b*icoOYN@Bv>-O@N)l=meZaUOjA7bv#t%rs=lcb*8a?eTJl zEb$1Wq3FVehh5uBPbWZm-j<8385Rb$a3YrL6X#EgvYKH*IpgEpX8N7r%((8Qd)c=g0qXbGz~QnCnUb--Y*}SzbSvu>g3qpF9L#l5*eW z!23LiO}Z1Ez#`GviKqmD6f8@S9OhXZ_VVmq+;3c?&Vo~r&ZZb@R5ZgO$o027X{#l* zxvPdj6+6w!k=dd0nG1-e*>TMK#_)RUvA)%!3Qooo>arjbRewyR|_c{$ZQvKKwQ0B!gF1r@<@h6qUFRFIQT^5Vz zwku&}eEt<4969vI@Pa7Q4{F;%|4?mRS9DobHLw(Qbj&{U@HOR7jJ5n38dIQ4cUPSI zwe@F{r+BH}E>5uCdrp-)4ja%+fp=Zw?ueOT>%TadjJt#{ZhRI- z(V8h}#{52tJ>P+N4tDU>&p9THdE!(g(HEI7tR&_6J-Yn}czx6gQtom!@P#Czy4C>t zkat-c0FzyQi(tYX9qi8azJYTd@oXpu!nT`8Fw%^WQ;Cm!jtlj4!y$|^Gop0>&L3aR zaBiJ^4ah%>aYuc@IeI@jsC~*)&J1+*TBEByZ@Qz V{%@c1Zx6@+U%#LKZ_|S>{~Nc1?Y{s3 diff --git a/figures/favicon.ico b/figures/favicon.ico deleted file mode 100644 index e2538a32f..000000000 --- a/figures/favicon.ico +++ /dev/null @@ -1,88 +0,0 @@ - - - - diff --git a/figures/figure-1.svg b/figures/figure-1.svg deleted file mode 100644 index decd48479..000000000 --- a/figures/figure-1.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - -
EASIFEM_INSTALL_DIR
EASIFEM_INSTALL_DIR
easifem
easifem
extpkgs
extpkgs
base
base
classes
classes
app
app
materials
materials
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
kernels
kernels
bin
bin
lib
lib
include
include
share
shareText is not SVG - cannot display \ No newline at end of file diff --git a/figures/figure-2.svg b/figures/figure-2.svg deleted file mode 100644 index d90a2d6aa..000000000 --- a/figures/figure-2.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - -
easifemBase
easifemBase
src
src
modules
modules
submodules
submodules
Header and Interface Only
Header and Interface Only
CSRSparsity
CSRSparsity
src
src
CSRSparsity_Method.F90
CSRSparsit...
CMakeLists.txt
CMakeLists...
Implementation
Implementation
CSRSparsity
CSRSparsity
src
src
CSRSparsity_Method@ConstructorMethods.F90
CSRSparsit...
CMakeLists.txt
CMakeLists...
CSRSparsity_Method@IOMethods.F90
CSRSparsit...Text is not SVG - cannot display \ No newline at end of file diff --git a/figures/logo_hero.svg b/figures/logo_hero.svg deleted file mode 100644 index 1a0aca649..000000000 --- a/figures/logo_hero.svg +++ /dev/null @@ -1,105 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/figures/what-is-easifem.svg b/figures/what-is-easifem.svg deleted file mode 100644 index c611e29ac..000000000 --- a/figures/what-is-easifem.svg +++ /dev/null @@ -1,780 +0,0 @@ - - - - - - - - - - - -image/svg+xml - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -BASEKERNELSCLASSESMid-level, Object Orientated Interface-Bindings: Gmsh, PlPlot, HDF5, XML, VTK, TOML, PETSc, MPI, CUDA-Fortran, OpenMP, etc.Physics simulatorsLow level, Multiple dispatch, BaseType, BaseMethods, Bindings: Sparsekit, LIS, Lapack, Blas, PlPlot, Metis, etc.EASIFEMMulti level design architecture of EASIFEM diff --git a/fortran.json b/fortran.json deleted file mode 100644 index 48b4191ee..000000000 --- a/fortran.json +++ /dev/null @@ -1,237 +0,0 @@ -"type": { - "prefix": "type", - "description": "define a new dataTYPE", - "body": [ - "!----------------------------------------------------------------------------", - "! ${name}", - "!----------------------------------------------------------------------------", - "TYPE :: ${name}", - "\t", - "END TYPE ${name}", - "", - "PUBLIC :: ${name}", - "", - "TYPE( ${name} ), PUBLIC, PARAMETER :: Type${name} = ", - "\t", - "", - "TYPE :: ${name}Pointer_", - "\tCLASS( ${name}, POINTER :: Ptr => NULL()", - "END TYPE ${name}Pointer_", - "", - "PUBLIC :: ${name}Pointer_", - ], - }, - "gnu-gpl3": { - "prefix": "gpl3", - "description": "GNU-GPL3 licence", - "body": [ - "! This program is a part of EASIFEM library", - "! Copyright (C) 2020-2021 Vikas Sharma, Ph.D", - "!", - "! This program is free software: you can redistribute it and/or modify", - "! it under the terms of the GNU General Public License as published by", - "! the Free Software Foundation, either version 3 of the License, or", - "! (at your option) any later version.", - "!", - "! This program is distributed in the hope that it will be useful,", - "! but WITHOUT ANY WARRANTY; without even the implied warranty of", - "! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the", - "! GNU General Public License for more details.", - "!", - "! You should have received a copy of the GNU General Public License", - "! along with this program. If not, see ", - "!", - ], - }, - "int": { - "prefix": "int", - "description": "integer", - "body": "INTEGER( I4B )", - }, - "real": { - "prefix": "real", - "body": "REAL( DFP ) ", - "description": "real", - }, - "logical": { - "prefix": "logi", - "description": "logical", - "body": "LOGICAL( LGT ) ", - }, - "modpuresub": { - "prefix": "mps", - "description": "module pure subroutine", - "body": [ - "INTERFACE", - "MODULE PURE SUBROUTINE ${NAME}( $0 )", - "\t", - "END SUBROUTINE ${NAME}", - "END INTERFACE", - "", - ], - }, - "warn": { - "prefix": "warn", - "description": "warning ", - "body": [ - "!@warning", - "! \t$0", - "!@endwarning", - ], - }, - "note": { - "prefix": "note", - "description": "note ", - "body": [ - "!@note", - "! \t$0", - "!@endnote", - ], - }, - "todo": { - "prefix": "todo", - "description": "todo ", - "body": [ - "!@todo", - "! \t$0", - "!@endtodo", - ], - } - "intro": { - "prefix": "intro", - "description": "introduction ", - "body": [ - "!# Introduction", - "! \t$0", - ], - }, - "vikas": { - "prefix": "vikas", - "description": "vikas", - "body": [ - "!> author: Vikas Sharma, Ph. D.", - "! date: \t$1", - "! summary: \t$2", - ], - }, - "usage": { - "prefix": "use", - "description": "use", - "body": [ - "! ", - "!### Usage", - "! ", - "!```fortran", - "!\t$0", - "!```", - ], - }, - "modsub": { - "prefix": "ms", - "description": "module subroutine", - "body": [ - "INTERFACE", - "MODULE SUBROUTINE ${NAME}( ${Name2} )", - "\t$0", - "END SUBROUTINE ${NAME}", - "END INTERFACE", - "", - ], - }, - "modpurefunc": { - "prefix": "mpf", - "description": "module pure function", - "body": [ - "INTERFACE", - "MODULE PURE FUNCTION ${NAME}( ${name2} ) RESULT( Ans )", - "\t$0", - "END FUNCTION ${NAME}", - "END INTERFACE", - "", - ], - }, - "class": { - "prefix": "cls", - "description": "class", - "body": "CLASS( $1 )", - }, - "intentin": { - "prefix": "in", - "description": "intent in", - "body": "INTENT( IN ) :: $1", - }, - "intentout": { - "prefix": "out", - "description": "intent out", - "body": "INTENT (OUT) :: $1", - }, - "intentinout": { - "prefix": "inout", - "description": "intent in out", - "body": "INTENT( INOUT ) :: $1", - }, - "generic": { - "prefix": "generic", - "description": "itnerface", - "body": [ - "INTERFACE ${NAME}", - "\tMODULE PROCEDURE $0", - "END INTERFACE ${NAME}", - "", - "PUBLIC :: ${NAME}", - ], - }, - "line": { - "prefix": "line", - "description": ".........", - "body": [ - "!----------------------------------------------------------------------------", - "! $1", - "!----------------------------------------------------------------------------", - ], - }, - "procedure": { - "prefix": "proc", - "description": "procedure", - "body": "PROCEDURE, PUBLIC, PASS( obj ) :: $1", - }, - "moduleprocedure":{ - "prefix": "mp", - "description": "module procedure", - "body": [ - "MODULE PROCEDURE ${NAME}", - "\t$0", - "END PROCEDURE ${NAME}", - ], - }, - "modulefunction":{ - "prefix": "mf", - "description": "module function", - "body": [ - "INTERFACE", - "MODULE FUNCTION $1( $2 ) RESULT( Ans )", - "\t$0", - "END FUNCTION $1", - "END INTERFACE", - ], - }, - "char":{ - "prefix": "char", - "description": "charcter(len=*)", - "body": "CHARACTER( LEN = * )", - }, - "display": { - "prefix": "disp", - "description": "display", - "body": [ - "INTERFACE", - "MODULE SUBROUTINE ${NAME1}( obj, Msg, UnitNo )", - "\tCLASS( ${NAME2} ), INTENT( IN ) :: obj", - "\tCHARACTER( LEN = * ), INTENT( IN ) :: Msg", - "\tINTEGER( I4B ), OPTIONAL, INTENT( IN ) :: UnitNo", - "END SUBROUTINE ${NAME1}", - "END INTERFACE", - "", - ], - }, -} diff --git a/install.py b/install.py deleted file mode 100755 index 560997cc9..000000000 --- a/install.py +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/env python3 -#!/Users/easifem/anaconda3/envs/easifem/bin/python3 - -# This program is a part of EASIFEM library. -# See. www.easifem.com -# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. -# - -import os -import platform - -print("Detecting OS type...") -_os = platform.system() -if _os == "Windows": - print("ERROR: INSTALLATION on windows is work in progress") - exit - # print("Please use Windows Subsystem Linux(WSL) ") - # print("Installation DONE!!") -else: - cmake_def = "" - cmake_def += ' -G "Ninja"' # Unix Makefiles, Ninja, Ninja Multi-Config - cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Debug" # Release - cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" - cmake_def += " -D CMAKE_EXPORT_COMPILE_COMMANDS:BOOL=ON" - cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" - cmake_def += " -D USE_OPENMP:BOOL=ON" # OFF - cmake_def += " -D USE_PLPLOT:BOOL=ON" - cmake_def += " -D USE_BLAS95:BOOL=ON" - cmake_def += " -D USE_LAPACK95:BOOL=ON" - cmake_def += " -D USE_FFTW:BOOL=ON" - cmake_def += " -D USE_GTK:BOOL=OFF" - cmake_def += " -D USE_ARPACK:BOOL=ON" - cmake_def += " -D USE_SUPERLU:BOOL=ON" - cmake_def += " -D USE_LIS:BOOL=ON" - cmake_def += " -D USE_PARPACK:BOOL=OFF" - cmake_def += " -D USE_METIS:BOOL=OFF" - cmake_def += " -D USE_LUA:BOOL=ON" - cmake_def += " -D USE_INT32:BOOL=ON" - cmake_def += " -D USE_REAL64:BOOL=ON" - cmake_def += " -D USE_RAYLIB:BOOL=ON" - cmake_def += " -D USE_COLORDISP:BOOL=OFF" - - print("CMAKE DEF : ", cmake_def) - - _build0 = os.path.join(os.environ["HOME"], "temp") - build_dir = os.path.join( - os.environ.get("EASIFEM_BUILD_DIR", _build0), "easifem", "base", "build" - ) - # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" - os.makedirs(build_dir, exist_ok=True) - os.system(f"cmake -S ./ -B {build_dir} {cmake_def}") - os.system(f"cmake --build {build_dir} --target install") - print("Installation DONE!!") diff --git a/neovim.json b/neovim.json deleted file mode 100644 index 0f02b3949..000000000 --- a/neovim.json +++ /dev/null @@ -1 +0,0 @@ -{"cargo":{"dap_name":"lldb"},"cmake":{"build_type":"Debug","dap_name":"lldb","args":{"configure":["-D","CMAKE_EXPORT_COMPILE_COMMANDS=1","-G","Ninja","-D","USE_OPENMP=ON"]},"env":{"configure":[]},"build_dir":"{cwd}\/build\/{os}-{build_type}","cmd":"cmake"}} \ No newline at end of file diff --git a/package-lock.json b/package-lock.json deleted file mode 100644 index 4616572a7..000000000 --- a/package-lock.json +++ /dev/null @@ -1,64 +0,0 @@ -{ - "name": "easifem-base", - "lockfileVersion": 2, - "requires": true, - "packages": { - "": { - "dependencies": { - "shiki": "^0.11.1" - } - }, - "node_modules/jsonc-parser": { - "version": "3.2.0", - "resolved": "https://registry.npmjs.org/jsonc-parser/-/jsonc-parser-3.2.0.tgz", - "integrity": "sha512-gfFQZrcTc8CnKXp6Y4/CBT3fTc0OVuDofpre4aEeEpSBPV5X5v4+Vmx+8snU7RLPrNHPKSgLxGo9YuQzz20o+w==" - }, - "node_modules/shiki": { - "version": "0.11.1", - "resolved": "https://registry.npmjs.org/shiki/-/shiki-0.11.1.tgz", - "integrity": "sha512-EugY9VASFuDqOexOgXR18ZV+TbFrQHeCpEYaXamO+SZlsnT/2LxuLBX25GGtIrwaEVFXUAbUQ601SWE2rMwWHA==", - "dependencies": { - "jsonc-parser": "^3.0.0", - "vscode-oniguruma": "^1.6.1", - "vscode-textmate": "^6.0.0" - } - }, - "node_modules/vscode-oniguruma": { - "version": "1.7.0", - "resolved": "https://registry.npmjs.org/vscode-oniguruma/-/vscode-oniguruma-1.7.0.tgz", - "integrity": "sha512-L9WMGRfrjOhgHSdOYgCt/yRMsXzLDJSL7BPrOZt73gU0iWO4mpqzqQzOz5srxqTvMBaR0XZTSrVWo4j55Rc6cA==" - }, - "node_modules/vscode-textmate": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/vscode-textmate/-/vscode-textmate-6.0.0.tgz", - "integrity": "sha512-gu73tuZfJgu+mvCSy4UZwd2JXykjK9zAZsfmDeut5dx/1a7FeTk0XwJsSuqQn+cuMCGVbIBfl+s53X4T19DnzQ==" - } - }, - "dependencies": { - "jsonc-parser": { - "version": "3.2.0", - "resolved": "https://registry.npmjs.org/jsonc-parser/-/jsonc-parser-3.2.0.tgz", - "integrity": "sha512-gfFQZrcTc8CnKXp6Y4/CBT3fTc0OVuDofpre4aEeEpSBPV5X5v4+Vmx+8snU7RLPrNHPKSgLxGo9YuQzz20o+w==" - }, - "shiki": { - "version": "0.11.1", - "resolved": "https://registry.npmjs.org/shiki/-/shiki-0.11.1.tgz", - "integrity": "sha512-EugY9VASFuDqOexOgXR18ZV+TbFrQHeCpEYaXamO+SZlsnT/2LxuLBX25GGtIrwaEVFXUAbUQ601SWE2rMwWHA==", - "requires": { - "jsonc-parser": "^3.0.0", - "vscode-oniguruma": "^1.6.1", - "vscode-textmate": "^6.0.0" - } - }, - "vscode-oniguruma": { - "version": "1.7.0", - "resolved": "https://registry.npmjs.org/vscode-oniguruma/-/vscode-oniguruma-1.7.0.tgz", - "integrity": "sha512-L9WMGRfrjOhgHSdOYgCt/yRMsXzLDJSL7BPrOZt73gU0iWO4mpqzqQzOz5srxqTvMBaR0XZTSrVWo4j55Rc6cA==" - }, - "vscode-textmate": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/vscode-textmate/-/vscode-textmate-6.0.0.tgz", - "integrity": "sha512-gu73tuZfJgu+mvCSy4UZwd2JXykjK9zAZsfmDeut5dx/1a7FeTk0XwJsSuqQn+cuMCGVbIBfl+s53X4T19DnzQ==" - } - } -} diff --git a/package.json b/package.json deleted file mode 100644 index cc4382947..000000000 --- a/package.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "dependencies": { - "shiki": "^0.11.1" - } -} diff --git a/package.py b/package.py deleted file mode 100644 index 8d3759121..000000000 --- a/package.py +++ /dev/null @@ -1,49 +0,0 @@ -# This program is a part of EASIFEM library. -# See. www.easifem.com -# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. -# - -import os -import platform - -print("Detecting OS type...") -_os = platform.system() -if _os == "Windows": - print("ERROR: INSTALLATION on windows is work in progress") - exit - # print("Please use Windows Subsystem Linux(WSL) ") - # print("Installation DONE!!") -else: - - cmake_def = "" - user_query = False - cmake_def = "" - cmake_def += ' -G "Ninja"' - cmake_def += " -D USE_OpenMP:BOOL=ON" - cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Release" - cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" - cmake_def += " -D USE_PLPLOT:BOOL=ON" - cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" - cmake_def += " -D USE_BLAS95:BOOL=ON" - cmake_def += " -D USE_LAPACK95:BOOL=ON" - cmake_def += " -D USE_FFTW:BOOL=ON" - cmake_def += " -D USE_GTK:BOOL=ON" - cmake_def += " -D USE_ARPACK:BOOL=ON" - cmake_def += " -D USE_SUPERLU:BOOL=ON" - cmake_def += " -D USE_LIS:BOOL=ON" - cmake_def += " -D USE_PARPACK:BOOL=OFF" - cmake_def += " -D USE_METIS:BOOL=OFF" - cmake_def += " -D USE_Int32:BOOL=ON" - cmake_def += " -D USE_Real64:BOOL=ON" - - print("CMAKE DEF : ", cmake_def) - - _build0 = os.path.join(os.environ["HOME"], "temp") - build_dir = os.path.join( - os.environ.get("EASIFEM_BUILD_DIR", _build0), "base", "build" - ) - # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" - os.makedirs(build_dir, exist_ok=True) - os.system(f"cmake -S ./ -B {build_dir} {cmake_def}") - os.system(f"cmake --build {build_dir} --target package") - print("Installation DONE!!") diff --git a/pages/BaseMethods.md b/pages/BaseMethods.md deleted file mode 100644 index b1c7c6c09..000000000 --- a/pages/BaseMethods.md +++ /dev/null @@ -1,58 +0,0 @@ -# BaseMethods - -`BaseMethods` library contains the modules which defines and implements methods (routines) for data types defined in BaseType. - -At present BaseMethods contains following modules. - -|Module|Comment|Category| -|---|---|---| -|String_Class|Defines String class and methods.|String| -|String_Method|Additional methods for handling strings.|String| -|PENF|For portability.|OS| -|BeFoR64|For portability.|OS| -|FACE|Colorful console printing.|IO| -|FPL|Fortran parameter list|Utility| -|System_Method|Interface to C system libray.|OS| -|CInterface|Utility for C-Fortran interface building.|OS| -|OpenMP_Method|Methods which uses OpenMP for acceleration.|Misc| -|GlobalData|GlobalData for easifem library|Misc| -|Hashing32|Hash functions.|Utility, Crypto| -|OGPF|Gnuplot library|Plot| -|Test_Method|Unit testing library|Test| -|MdEncode_Method|Encoding text into markdown.|IO| -|DispModule|Pretty printing on terminal.|IO| -|Display_Method|Pretty printing on terminal.|IO| -|ErrorHandling|Exception handling.|ExceptionHandling| -|Utility|Utility module.|Utility| -|PolynomialUtility|Collection of useful routine for polynomial interpolation.|Basis| -|BaseType|Collection of user define data types.|Core| -|MultiIndices_Method|Methods for MultiIndices_.|Math| -|Random_Method|Methods for Random_ data type.|Math| -|BoundingBox_Method|Methods for BoundingBox_ data type|Math| -|IntVector_Method|Methods for IntVector_ data type|Vector| -|IndexValue_Method|Methods for IndexValue_ data type|FEM| -|IterationData_Method|Methods for IterationData_ data type.|FEM| -|Vector3D_Method|Methods for Vector3D_ data type.|Vector| -|RealVector_Method|Methods for RealVector_ data type|Vector| -|DOF_Method|Methods for DOF_ data type|FEM| -|Geometry_Method|Geometry realted methods.|Math| -|QuadraturePoint_Method|Methods for QuadraturePoint_ data type.|FEM| -|FEVariable_Method|Methods for FEVariable_ data type|FEM| -|ElemshapeData_Method|Methods for ElemshapeData_ data type.|FEM| -|RealMatrix_Method|Methods for RealMatrix_ data type.|Matrix| -|FEMatrix_Method|Methods for FEMatrix_ data type.|FEM| -|FEVector_Method|Methods for FEVector_ data type.|FEM| -|Rank2Tensor_Method|Methods for Rank2Tensor_ data type.|Tensor| -|VoigtRank2Tensor_Method|Methods for VoigtRank2Tensor_ data type.|Tensor| -|CSRSparisty_Method|Methods for CSRSparisty_ data type.|Matrix| -|CSRMatrix_Method|Methods for CSRMatrix_ data type.|Matrix| -|SuperLUInterface|Fortran interface to SuperLU lib|LinearSolver| -|LISInterface|Fortran interface to LIS lib|LinearSolver| -|F77_BLAS|F77 interface to BLAS.|LinearAlgebra| -|F95_BLAS|Fortran 95 interface to BLAS lib.|LinearAlgebra| -|F77_LAPACK|Fortran interface to Lapack.|LinearAlgebra| -|F95_LAPACK|Fortran 95 interface to Lapack lib.|LinearAlgebra| -|Lapack_Method|Methods for linear algebra by using Lapack.|LinearAlgebra| -|EASIFEM_ARPACK|Fortran interface to ARPACK.|LinearAlgebra| -|FFTW3|Fast fourer tranform library|LinearAlgebra| -|MetisInterface|Fortran interface to Metis library.|LinearAlgebra| diff --git a/pages/BaseType.md b/pages/BaseType.md deleted file mode 100644 index 3023a6b7e..000000000 --- a/pages/BaseType.md +++ /dev/null @@ -1,66 +0,0 @@ -# BaseType - -`BaseType` contains user-define data type. - -|Data-type|Summary|Category| -|---|---|---| -|Math_|Contains mathematical constants.|Math| -|BoundingBox_|Data type for bounding box.|FEM| -|RealMatrix_|Extension for Fortran two-d array|Matrix| -|IntVector_|Vector of integers.|Vector| -|RealVector_|Vector of reals|Vector| -|Vector3D_|3D Vector|Vector| -|IndexValue_|Key (integer) and value (real), useful for defining nodal boundary conditions|FEM| -|DOF_|Degree of freedom object type|FEM| -|SparseMatixReOrdering_|Sparse matrix reordering scheme|LinearAlgebra| -|CSRSparisty_|Datatype for handling sparsity pattern|LinearAlgebra| -|SuperLU_|SuperLU data structure.|LinearAlgebra| -|CSRMatrix_|Compressed sparse row matrix|LinearAlgebra| -|IterationData_|Datatype for storing iteration data|FEM| -|VoigtRank2Tensor_|Rank2 tensor|Tensor| -|DeformationGradient_|Deformation Gradient tensor|Tensor| -|LeftCauchyGreen_|Left Cauchy Green tensor|Tensor| -|RightCauchyGreen_|Right Cauchy Green tensor|Tensor| -|Strain_|Strain tensor|Tensor| -|AlmansiStrain_|Almansi strain|Tensor| -|GreenStrain_|Green strain tensor|Tensor| -|SmallStrain_|Small strain tensor.|Tensor| -|ReferenceTopology_|Data type for handling reference element in FEM|FEM| -|ReferenceElement_|Data type for reference element in FEM|FEM| -|ReferencePoint_|Data type for reference point in FEM|FEM| -|ReferenceLine_|Data type for reference line in FEM|FEM| -|ReferenceTriangle_|Data type for reference triangle in FEM|FEM| -|ReferenceQuadrangle_|Data type for reference quadrangle in FEM|FEM| -|ReferenceTetrahedron_|Data type for reference tetrahedron in FEM|FEM| -|ReferenceHexahedron_|Data type for reference hexahedron in FEM|FEM| -|ReferencePrism_|Data type for reference prism in FEM|FEM| -|ReferencePyramid_|Data type for reference pyramid in FEM|FEM| -|KeyValue_|Poor man's implementation of dic.|Container| -|FEVariable_|Data type for finite element variables.|FEM| -|FEVariableConstant_|Constant finite element variable|FEM| -|FEVariableSpace_|Spatially variable finite element variable|FEM| -|FEVariableTime_|Time variable finite element variable|FEM| -|FEVariableSpaceTime_|Spatially and temporally changing finite element variable|FEM| -|FEVariableScalar_|Scalar finite element variable|FEM| -|FEVariableVector_|Vector finite element variable|FEM| -|FEVariableMatrix_|Matrix finite element variable|FEM| -|QuadraturePoint_|Quadrature points|FEM| -|BaseInterpolation_|Data type for basis interpolation|FEM| -|LagrangeInterpolation_|Lagrange interpolation|FEM| -|HermitInterpolation_|Hermit interpolation|FEM| -|SerendipityInterpolation_|Serendipity interpolation|FEM| -|HierarchyInterpolation_|Hierarchical interpolation|FEM| -|BaseContinuity_|Continuity type of basis functions.|FEM| -|H1_|H1 finite element basis|FEM| -|H1DIV_|H1(Div) finite element basis|FEM| -|H1Curl_|H1(Curl) finite element basis|FEM| -|DG_|Discontinuous Galerkin finite element basis|FEM| -|ElementData_|Data necessary for creating finite element.|FEM| -|ShapeData_|Storage for shape data|FEM| -|STShapeData_|Space-time shape function data|FEM| -|ElemshapeData_|Element shape function data|FEM| -|STElemShapeData_|Space-time element shape data.|FEM| -|QualityMeasure_|Datatype for mesh quality measure|FEM| -|Random_|Data type for random variables|FEM| -|OpenMP_|Data type for OpenMP parallel environment|FEM| -|MultiIndices_|Data type for multi indices|FEM| diff --git a/pages/Environment.md b/pages/Environment.md deleted file mode 100644 index d613afd44..000000000 --- a/pages/Environment.md +++ /dev/null @@ -1,152 +0,0 @@ -# 𑗕 Environment variables for easifem - -The structure of easifem library after installation is given in Figure 1. - -![](../figures/figure-1.svg) - -In this figure "EASIFEM_INSTALL_DIR" is the location of parent directory where EASIFEM will be installed. -For example, if you want to install easifem at `~/local`, then `EASIFEM_INSTALL_DIR=~/local`. - -## Environment variables - -| var-name | description | comment | -|:--- | :--- | :--- | -|**EASIFEM_INSTALL_DIR** | location where easifem is installed | example: `/opt`, `${HOME}`, `/usr/local/` | -| **EASIFEM_SOURCE_DIR** | location where the source code of easifem will be stored | example: `~/Dropbox`, `~/code` | -| **EASIFEM_BUILD_DIR** | location where easifem will be build | To keep your source directory clean, always keep your build directory separated from build directory | -| **EASIFEM_EXTPKGS** | location where external packages necessary for easifem are installed | It is given by `EASIFEM_INSTALL_DIR/easifem/extpkgs` | -| **EASIFEM_BASE** | location where easifemBase library is installed | It is given by: `EASIFEM_BASE=EASIFEM_INSTALL_DIR/easifem/base` | -|**EASIFEM_CLASSES** | location where easifemClasses library is installed | It is given by: `EASIFEM_INSTALL_DIR/easifem/classes` | -| **EASIFEM_MATERIALS** | location where easifemMaterials library is installed | It is given by: `EASIFEM_INSTALL_DIR/easifem/materials` | -| **EASIFEM_KERNELS** | location where easifemKernels library is installed | It is given by: `EASIFEM_INSTALL_DIR/easifem/kernels` | - -## Setting up environment on UNIX and LINUX - -### EASIFEM cli (recommended method) - -The easiest way to work with the EASIFEM is `easifem` command line interface. - -- First download the `easifem` from `pip` by using following command. - -```bash -pip install easifem -``` - -- Then, we can set up the environment variables by using following command. - -```bash -easifem setenv --install /home/easifem/install --build /home/easifem/build --source /home/easifem/src -``` - -- This command will create config files for bash, zsh, and fish shell in `~/.config/easifem` directory. For bash and zsh the name of the file is `easifemvar.sh`, and for fish the name of the file is `easifemvar.fish`. -- Then, you can run following command to bring the changes in your current shell session. - -```bash title="bash and zsh" -source ${HOME}/.config/easifem/easifemvar.sh -``` - -```bash title="fish" -source $HOME/.config/easifem/easifemvar.fish -``` - -:::info -- If you are using bash or zsh shell, then you can place `easifemvar.sh` in your shell. For bash or zsh shell, open `.bashrc` or `.zshrc` in your editor and add the following line at the end of the file: - -```bash -source ${HOME}/.config/easifem/easifemvar.sh -``` - -- If you are using fish shell, then you can place `easifemvar.fish` in your shell. For fish shell, open `config.fish` in your editor and add the following line at the end of the file: - -```bash -source $HOME/.config/easifem/easifemvar.fish -``` - -::: - -import Tabs from '@theme/Tabs'; -import TabItem from '@theme/TabItem'; - - - - - -The following file is generated by running the command. - -```bash -easifem setenv --install /home/easifem/.easifem --build /home/easifem/temp --source /home/easifem/temp/src -``` - -```bash - export EASIFEM_INSTALL_DIR=/home/easifem/.easifem - export EASIFEM_BUILD_DIR=/home/easifem/temp - export EASIFEM_SOURCE_DIR=/home/easifem/temp/source - export EASIFEM_BASE=/home/easifem/.easifem/easifem/base - export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_BASE}/lib" - export EASIFEM_CLASSES=/home/easifem/.easifem/easifem/classes - export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_CLASSES}/lib" - export EASIFEM_EXTPKGS=/home/easifem/.easifem/easifem/extpkgs - export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_EXTPKGS}/lib" - export EASIFEM_APP=/home/easifem/.easifem/easifem/app - export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_APP}/lib" - export EASIFEM_MATERIALS=/home/easifem/.easifem/easifem/materials - export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_MATERIALS}/lib" - export EASIFEM_KERNELS=/home/easifem/.easifem/easifem/kernels - export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_KERNELS}/lib" - export PKG_CONFIG_PATH="${PKG_CONFIG_PATH}:${EASIFEM_EXTPKGS}/lib/pkgconfig" - export PATH="${PATH}:${EASIFEM_EXTPKGS}/bin" - export PATH="${PATH}:${EASIFEM_APP}/bin" -``` - - - - - -The following file is generated by running the command. - -```bash -easifem setenv --install /home/easifem/.easifem --build /home/easifem/temp/build --source /home/easifem/temp/src -``` - -```bash -set -gx EASIFEM_INSTALL_DIR /Users/easifem/.easifem -set -gx EASIFEM_BUILD_DIR /Users/easifem/temp/build -set -gx EASIFEM_SOURCE_DIR /Users/easifem/temp/src -set -gx EASIFEM_BASE /Users/easifem/.easifem/easifem/base -set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_BASE/lib -set -gx EASIFEM_CLASSES /Users/easifem/.easifem/easifem/classes -set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_CLASSES/lib -set -gx EASIFEM_EXTPKGS /Users/easifem/.easifem/easifem/extpkgs -set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_EXTPKGS/lib -set -gx EASIFEM_APP /Users/easifem/.easifem/easifem/app -set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_APP/lib -set -gx EASIFEM_MATERIALS /Users/easifem/.easifem/easifem/materials -set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_MATERIALS/lib -set -gx EASIFEM_KERNELS /Users/easifem/.easifem/easifem/kernels -set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_KERNELS/lib -set -gx PKG_CONFIG_PATH $PKG_CONFIG_PATH $EASIFEM_EXTPKGS/lib/pkgconfig -set -gx PATH $PATH $EASIFEM_EXTPKGS/bin -set -gx PATH $PATH $EASIFEM_APP/bin -``` - - - - - - - - -### Bash, Zsh shell - -If you do not want to use EASIFEM-cli, then please copy the above-mentioned template file -and place it in `.bashrc` or `.zshrc`. - -### Fish shell - -If you do not want to use EASIFEM-cli, then please copy the above-mentioned template file -and place it in `config.fish`. - - -## Setting up environment on Windows  - -Coming soon. diff --git a/pages/Extpkgs.md b/pages/Extpkgs.md deleted file mode 100644 index fc4c2f298..000000000 --- a/pages/Extpkgs.md +++ /dev/null @@ -1,20 +0,0 @@ -# 𑗕 External packages - -EASIFEM depends upon the following external packages (extpkgs) that are not shipped with the source-code. - -| extpkg| description | command | -|:--- | :--- | :--- | -| [OpenBlas](https://www.openblas.net/) | Highly optimized BLAS | easifem install openblas | -| [SuperLU](https://github.com/xiaoyeli/superlu.git) | Direct solution of large, sparse, nonsymmetric systems of linear equations | easifem install superlu | -| [LIS](https://github.com/anishida/lis.git) | Linear interative solver | easifem install lis| -| [METIS](https://github.com/KarypisLab/METIS) | Mesh partitioning library | easifem install metis | -| [SCOTCH](https://gitlab.inria.fr/scotch/scotch) | Mesh partitioning library | easifem install scotch | -| [ARPACK](https://github.com/opencollab/arpack-ng) | Eigensolver for sparse matrices | easifem install arpack | -| [FFTW](https://www.fftw.org/) | Fast Fourier Transform| easifem install fftw | -| [GTK-Fortran](https://github.com/vmagnin/gtk-fortran) | Fortran bindings for GTK-4 library | easifem install gtk-fortran | -| [LAPACK95](https://github.com/vickysharma0812/LAPACK95.git) | Fortran 95 interface for Lapack library | easifem install lapack95 | -| [Sparsekit](https://github.com/vickysharma0812/Sparsekit.git) | Fortran library for sparse matrices | easifem install sparsekit | -| [Gmsh](https://gmsh.info/) | Finite element mesh generator| easifem install gmsh | - -More information about the extpkgs used in the EASIFEM are given [here.](../extpkgs/about.md) - diff --git a/pages/Install_Linux.md b/pages/Install_Linux.md deleted file mode 100644 index 15b0d46fa..000000000 --- a/pages/Install_Linux.md +++ /dev/null @@ -1,149 +0,0 @@ -# Installation of easifemBase on Linux - -## Ubuntu - -### System requirements - -Then download the requirements by copying following code and paste it in terminal. - -```bash -sudo apt-get update && sudo apt-get install -y gfortran gcc libomp-dev curl git \ -python3 python3-pip cmake ninja-build \ -liblapack-dev libopenblas-dev libhdf5-dev \ -libplplot-dev plplot-driver-cairo libboost-all-dev \ -gnuplot doxygen libgtk-4-dev -``` - -### Install easifem CLI - -The easiest way and the recommended way to install the components of easifem is through `easifem` command line interface. - -```bash -python3 -m pip install --upgrade easifem -``` - -### Set environment variables - -After downloading the easifem CLI, we need to set three environment variables related to the location of the source files, build files, and installation of the easifem. - -You can read about the environment variables [here](./Environment.md) - -```bash -easifem setenv --install ~/.easifem/install --build ~/.easifem/build --source ~/.easifem/src -``` - -### Install External packages - -```bash -easifem install extpkgs -``` - -You can also install individual package by using following: - -```bash -easifem install openblas superlu lis metis scotch arpack fftw gtk-fortran lapack95 sparsekit gmsh -``` - -- The packages will be stored at `EASIFEM_SOURCE_DIR/extpkgs/` -- The packages will be build at `EASIFEM_BUILD_DIR/extpkgs/` -- The packages will be installed at `EASIFEM_INSTALL_DIR/extpkgs/` - -### Install easifemBase - -```bash -easifem install base -``` - -### Installation by using CMake - -Download the source code: - -```bash -git clone https://github.com/vickysharma0812/easifem-base.git -``` - -or - -```bash -git clone git@github.com:vickysharma0812/easifem-base.git -``` - -or - -```bash -gh repo clone vickysharma0812/easifem-base -``` - -After downloading the source code, enter the source directory, and make a build directory. - -```bash -cd easifem-base -mkdir ./build -``` - -EASIFEM uses CMake build system. You can install the Base library from CMake by using following steps - -1. Configuration -2. Build -3. Install - -To configure the `Base` library you can define following variables: - -| Variable | Type | Options | -| --- | --- | --- | -| USE_OpenMP | BOOL | `ON`, `OFF` | -| CMAKE_BUILD_TYPE | STRING | `Release`, `Debug` | -| BUILD_SHARED_LIBS | BOOL | `ON`, `OFF` | -| USE_PLPLOT | BOOL | `ON`, `OFF`| -| CMAKE_INSTALL_PREFIX | PATH | | -| USE_BLAS95 | BOOL | `ON`, `OFF`| -| USE_LAPACK95 | BOOL | `ON`, `OFF`| -| USE_FFTW | BOOL | `ON`, `OFF`| -| USE_GTK | BOOL | `ON`, `OFF`| -| USE_ARPACK | BOOL | `ON`, `OFF`| -| USE_SUPERLU | BOOL | `ON`, `OFF`| -| USE_LIS | BOOL | `ON`, `OFF`| -| USE_PARPACK | BOOL | `ON`, `OFF`| -| USE_METIS | BOOL | `ON`, `OFF`| -| USE_Int32 | BOOL | `ON`, `OFF`| -| USE_Real64 | BOOL | `ON`, `OFF`| - -An example of configuration step is given below: - -```bash -export EASIFEM_BASE=${HOME}/.local/easifem/base -cmake -G "Ninja" -S ./ -B ./build \ --D USE_OpenMP:BOOL=ON \ --D CMAKE_BUILD_TYPE:STRING=Release \ --D BUILD_SHARED_LIBS:BOOL=ON \ --D USE_PLPLOT:BOOL=ON \ --D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE} \ --D USE_BLAS95:BOOL=ON \ --D USE_LAPACK95:BOOL=ON \ --D USE_FFTW:BOOL=ON \ --D USE_GTK:BOOL=ON \ --D USE_ARPACK:BOOL=ON \ --D USE_PARPACK:BOOL=ON \ --D USE_METIS:BOOL=ON \ --D USE_Int32:BOOL=ON \ --D USE_Real64:BOOL=ON -``` - -After configuration, you can build and install the library by using: - -```bash -cmake --build ./build --target --install -``` - -## Arch Linux - -Coming soon. - -## Fedora - -Coming soon. - -## Other Linux Distro - -Coming soon. - diff --git a/pages/Install_MacOSX.md b/pages/Install_MacOSX.md deleted file mode 100644 index d6590e6cd..000000000 --- a/pages/Install_MacOSX.md +++ /dev/null @@ -1,21 +0,0 @@ -# Install easifemBase on MacOSX - -## System requirements - -```bash -brew install gcc -brew install gfortran -brew install libomp -brew install curl -brew install git -brew install python3 -brew install cmake -brew install ninja -brew install lapack -brew install openblas -brew install hdf5 -brew install plplot -brew install gnuplot -brew install doxygen -brew install gtk4 -``` diff --git a/pages/Install_Windows.md b/pages/Install_Windows.md deleted file mode 100644 index 49c641b37..000000000 --- a/pages/Install_Windows.md +++ /dev/null @@ -1,3 +0,0 @@ -# Installation of easifemBase on Windows - -Coming soon. diff --git a/pages/IntVector_.md b/pages/IntVector_.md deleted file mode 100644 index 3cbea32cc..000000000 --- a/pages/IntVector_.md +++ /dev/null @@ -1,106 +0,0 @@ ---- -title: IntVector -author: Vikas Sharma, Ph.D. -date: 24 Feb 2021 ---- - -- [ ] TODO Finish documentation of IntVector#Set-Method and IntVector#Get-Method documentation. - -# IntVector - -!!! example "" - Intvector contains a dynamic array of rank 1 of integer type. It can be used to construct ragged vectors. Or vector or arrays of intvector. - -## Structure - -The structure of [[IntVector_]] is given below. - -```fortran -TYPE :: IntVector_ - INTEGER(I4B) :: tDimension = 1_I4B - INTEGER(I4B), ALLOCATABLE :: Val(:) -END TYPE IntVector_ -``` - -### tDimension - -Total dimension of the array, it is always one - -### Val - -Vectors of integers. - -## Constructor methods - -### Shape - -!!! note "" - Return the shape of IntVector in a fortran vector of size 1. See example [[IntVector_test_1]] - -### Size - -!!! note "" - Return the size of IntVector, If the instance of intvector is not allocated then it will return 0. See example [[IntVector_test_1]] - -### GetTotalDimension - -!!! note "" - Return a integer scalar, total dimension of IntVector. It will return 1. - See example [[IntVector_test_1]] - -### Allocate - -!!! note "" - Allocate the size of IntVector. See example [[IntVector_test_1]] - -### Deallocate - -!!! note "" - Deallocate the data stored inside IntVector. See example [[IntVector_test_1]] - -### Initiate - -!!! note "" - Initiate an instance of IntVector. See example [[IntVector_test_2]] for more details. - -### IntVector - -!!! note "" - This is a function, which returns an intance of [[IntVector_]]. You can find more details about this function here 👉⚡ [[IntVector_test_3]]. - -### IntVector_Pointer - -!!! note "" - This is a function, which returns a pointer to a newly created instance of [[IntVector_]]. You can find more details about this function here 👉⚡ [[IntVector_test_4]]. - -### isAllocated - -!!! note "" - This function returns true if the instance of intvector is allocated. See [[IntVector_test_1]] for usage. - -### isInitiated - -!!! note "" - Alias to isAllocated method. - -## IO methods - -### Display - -!!! note "" - This function displays the content of intvector. You can find more details about this function here 👉⚡ [[IntVector_test_1]] [[IntVector_test_2]] [[IntVector_test_3]] [[IntVector_test_4]]. - -## Get methods - -### Operator(.in.) - -!!! note "" - The operator (.in.) returns true if a integer set is subset of another integer set. You can find the usage and more details about this method 👉🔥 [[IntVector_test_5]] - -### Get - -!!! note "" - Returns the values stored inside intvector. See, 👉🔥 [[IntVector_test_6]] for more details. This routine has all the features of fortran for native integer vectors. - -## Set methods - diff --git a/release_install.py b/release_install.py deleted file mode 100755 index 29e917d2f..000000000 --- a/release_install.py +++ /dev/null @@ -1,52 +0,0 @@ -#!/usr/bin/env python3 -#!/Users/easifem/anaconda3/envs/easifem/bin/python3 - -# This program is a part of EASIFEM library. -# See. www.easifem.com -# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. -# - -import os -import platform - -print("Detecting OS type...") -_os = platform.system() -if _os == "Windows": - print("ERROR: INSTALLATION on windows is work in progress") - exit - # print("Please use Windows Subsystem Linux(WSL) ") - # print("Installation DONE!!") -else: - cmake_def = "" - cmake_def += ' -G "Ninja"' # Unix Makefiles, Ninja, Ninja Multi-Config - cmake_def += " -D USE_OPENMP:BOOL=ON" # OFF - cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Release" - cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" - cmake_def += " -D USE_PLPLOT:BOOL=ON" - cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" - cmake_def += " -D USE_BLAS95:BOOL=ON" - cmake_def += " -D USE_LAPACK95:BOOL=ON" - cmake_def += " -D USE_FFTW:BOOL=ON" - cmake_def += " -D USE_GTK:BOOL=OFF" - cmake_def += " -D USE_ARPACK:BOOL=ON" - cmake_def += " -D USE_SUPERLU:BOOL=ON" - cmake_def += " -D USE_LIS:BOOL=ON" - cmake_def += " -D USE_PARPACK:BOOL=OFF" - cmake_def += " -D USE_METIS:BOOL=OFF" - cmake_def += " -D USE_LUA:BOOL=ON" - cmake_def += " -D USE_INT32:BOOL=ON" - cmake_def += " -D USE_REAL64:BOOL=ON" - cmake_def += " -D COLOR_DISP:BOOL=OFF" - cmake_def += " -D CMAKE_EXPORT_COMPILE_COMMANDS:BOOL=ON" - - print("CMAKE DEF : ", cmake_def) - - _build0 = os.path.join(os.environ["HOME"], "temp") - build_dir = os.path.join( - os.environ.get("EASIFEM_BUILD_DIR", _build0), "easifem", "base", "build" - ) - # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" - os.makedirs(build_dir, exist_ok=True) - os.system(f"cmake -S ./ -B {build_dir} {cmake_def}") - os.system(f"cmake --build {build_dir} --target install") - print("Installation DONE!!") diff --git a/selected b/selected deleted file mode 100644 index e69de29bb..000000000 diff --git a/setup.py b/setup.py deleted file mode 100644 index 361e73bae..000000000 --- a/setup.py +++ /dev/null @@ -1,76 +0,0 @@ -# This program is a part of EASIFEM library. -# See. www.easifem.com -# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. -# - -import os -import sys -import platform - -str=" _______ ___ _______. __ _______ _______ .___ ___. " -print(str) -str="| ____| / \ / || | | ____|| ____|| \/ | " -print(str) -str="| |__ / ^ \ | (----`| | | |__ | |__ | \ / | " -print(str) -str="| __| / /_\ \ \ \ | | | __| | __| | |\/| | " -print(str) -str="| |____ / _____ \ .----) | | | | | | |____ | | | |" -print(str) -str="|_______/__/ \__\ |_______/ |__| |__| |_______||__| |__|" -print(str+"\n") -str = "Expandable And Scalable Infrastrcture for Finite Element Methods" -print(str) -str = "Developed by Vikas Sharma, Ph. D." -print(str) -str = "(c) 2020-present" -print(str) -print("") -print("================================================================\n") - -def installpkgs(): - while True: - choice = input( f"Do you want to automatically Install external packages? 'yes' or 'no' [Y/n]: " ).lower() - if choice in ['Y', 'y', 'ye', 'yes']: - return True - else: - return False - -def setEnvVar(): - while True: - choice = input( f"Do you want to automatically set environment variables? 'yes' or 'no' [Y/n]: " ).lower() - if choice in ['Y', 'y', 'ye', 'yes']: - return True - else: - return False - -print("Detecting OS type...") -_os = platform.system() -if _os == 'Windows': - print("Windows platform found") - print("Setting up for Windows...") - print("ERROR: INSTALLATION on windows is work in progress") - exit - #os.system("install.bat") - print("Please use Windows Subsystem Linux(WSL) ") - print("Installation DONE!!") - -elif _os == "Darwin": - print("MacOSX system found") - print("Setting up for MacOSX...") - if( installpkgs() ): - os.system( "sh ./setup/install_pkgs_Darwin.sh" ) - if( setEnvVar() ): - os.system("sh ./setup/set_envvar_Darwin.sh") - print("Installation DONE!!") - -elif _os == "Linux": - print("Linux system found") - print("Setting up for Linux...") - if(installpkgs()): - os.system("${SHELL} ./setup/install_pkgs_Ubuntu.sh") - if(setEnvVar()): - os.system("${SHELL} ./setup/set_envvar_Ubuntu.sh") - -else: - print("ERROR: Unknown Operating System") diff --git a/setup/install_pkgs_Darwin.sh b/setup/install_pkgs_Darwin.sh deleted file mode 100644 index 1967dfe5e..000000000 --- a/setup/install_pkgs_Darwin.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/sh -# This is a setup script for installing EASIFEM-base library. -# (c) 2021, Dr Vikas Sharma, all rights reserved -# -# -# Log (dd/mm/yyyy) -# 15/02/2021 this document was created -# -#-------------------------------------------------------------- - -/bin/bash -c "$(curl -fsSL https://raw.githubusercontent.com/Homebrew/install/HEAD/install.sh)" - -echo "==========================================" -echo "brew install curl" -brew install curl -echo "==========================================" -echo "brew install git" -brew install git -echo "==========================================" -echo "brew install gcc" -brew install gcc -echo "==========================================" -echo "brew install gfortran" -brew install gfortran -echo "==========================================" -echo "brew install python3" -brew install python3 -echo "==========================================" -echo "brew install lapack" -brew install lapack -echo "==========================================" -echo "brew install cmake" -brew install cmake -echo "==========================================" -echo "brew install gmsh" -brew install gmsh -echo "==========================================" -echo "brew install gnuplot" -brew install gnuplot -echo "==========================================" diff --git a/setup/install_pkgs_Ubuntu.sh b/setup/install_pkgs_Ubuntu.sh deleted file mode 100644 index 92ee0db39..000000000 --- a/setup/install_pkgs_Ubuntu.sh +++ /dev/null @@ -1,58 +0,0 @@ -#!/bin/sh -# This program is a part of EASIFEM library -# # Copyright (C) 2020-2021 Vikas Sharma, Ph.D -# This program is free software: you can redistribute it and/or modify -# under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# You should have received a copy of the GNU General Public License -# along with this program. If not, see - - -#sh -c "$(curl -fsSL https://api.cacher.io/raw/41c42c3479fa291be9d8/f7f3a874cad01c19127f/install_pkgs.sh)" - -# go to home -cd ${HOME} - -# run update and upgrade -echo "[try:] apt update" -sudo apt update -if [ $? -eq 0 ] ; then echo 'apt update [OK!]' ; else echo 'apt update [FAILED!]'; exit ; fi -echo "[try:] apt upgrade" -sudo apt upgrade -if [ $? -eq 0 ] ; then echo 'apt upgrade [OK!]' ; else echo 'apt upgrade [FAILED!]'; exit ; fi -# -# -# Install pkgs here -# -# sudo apt install -y gmsh -# sudo apt install -y gnuplot -# -pkg="curl git neovim zsh gfortran gcc g++ python3 python3-pip liblapack-dev libopenblas-dev" -echo "[try:] apt install -y ${pkg}" -sudo apt install -y ${pkg} -if [ $? -eq 0 ] ; then echo "${pkg} install [SUCCESSFUL!]" ; else echo "${pkg} install [FAILED!]"; exit ; fi -# -# Install cmake from pip -# -pip3 install cmake -# -# install spacevim -# -# -# -mkdir -p ${HOME}/.SpaceVim.d -echo "Download init.toml" -url="https://api.cacher.io/raw/5f5dd01fcf10a2d39603/6385a7e389aafd0c99c6/init.toml" -curl -o ${HOME}/.SpaceVim.d/init.toml ${url} -url="https://spacevim.org/install.sh" -# -# oh-my-zsh -# -sudo chsh -s /bin/zsh -url="https://raw.githubusercontent.com/ohmyzsh/ohmyzsh/master/tools/install.sh" -sh -c "$(curl -fsSL ${url})" diff --git a/setup/requirements.txt b/setup/requirements.txt deleted file mode 100644 index 197db5f37..000000000 --- a/setup/requirements.txt +++ /dev/null @@ -1,11 +0,0 @@ -numpy -scipy -matplotlib -jupyter -jupyterlab -plotly -dash -seaborn -pillow -opencv-python -pandas \ No newline at end of file diff --git a/setup/set_envvar_CentOS.sh b/setup/set_envvar_CentOS.sh deleted file mode 100644 index e69de29bb..000000000 diff --git a/setup/set_envvar_Darwin.sh b/setup/set_envvar_Darwin.sh deleted file mode 100644 index 0c952dcfa..000000000 --- a/setup/set_envvar_Darwin.sh +++ /dev/null @@ -1,72 +0,0 @@ -#!/bin/sh -# This is a setup script for installing EASIFEM-base library. -# (c) 2021, Dr Vikas Sharma, all rights reserved -# -# -# Log (dd/mm/yyyy) -# 15/02/2021 this document was created -# -#-------------------------------------------------------------- - -SHELL_=${SHELL} -if [[ $SHELL_ =~ .*zsh.* ]]; then - BP=${HOME}/.zshrc -fi -if [[ $SHELL_ =~ .*bash.* ]]; then - BP=${HOME}/.bashrc -fi -echo $BP - -if [ -f "$BP" ]; then - echo "${BP} found" -else - touch ${BP} - echo '#!/bin/sh' >> ${BP} -fi - -ERC=${HOME}/.easifemrc -if [ -f "$ERC" ]; then - echo "${ERC} found, removing it" - rm -rf ${ERC} - touch ${ERC} - echo '#!/bin/sh' >> ${ERC} -else - touch ${ERC} - echo '#!/bin/sh' >> ${ERC} -fi - -prefix=${HOME} -export EASIFEM_BASE=${prefix}/.easifem/base/ -export EASIFEM_CLASSES=${prefix}/.easifem/classes/ -export EASIFEM_KERNEL=${prefix}/.easifem/kernel/ -export EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs/ -echo "${EASIFEM_BASE}" -mkdir -p ${EASIFEM_EXTPKGS} -mkdir -p ${EASIFEM_BASE} -mkdir -p ${EASIFEM_CLASSES} -mkdir -p ${EASIFEM_KERNEL} - -echo "easifem_prefix=${prefix}" >> ${ERC} -echo "export EASIFEM_BASE=${prefix}/.easifem/base/" >> ${ERC} -echo "export EASIFEM_CLASSES=${prefix}/.easifem/classes/" >> ${ERC} -echo "export EASIFEM_KERNEL=${prefix}/.easifem/kernel/" >> ${ERC} -echo "export EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs/" >> ${ERC} -echo "mkdir -p ${EASIFEM_EXTPKGS}" >> ${ERC} -echo "mkdir -p ${EASIFEM_BASE}" >> ${ERC} -echo "mkdir -p ${EASIFEM_CLASSES}" >> ${ERC} -echo "mkdir -p ${EASIFEM_KERNEL}" >> ${ERC} - -echo "export CC=/usr/local/bin/gcc-10" >> ${ERC} -echo "export CXX=/usr/local/bin/g++-10" >> ${ERC} -echo "export CPP=/usr/local/bin/cpp-10" >> ${ERC} -echo "export LD=/usr/local/bin/gcc-10" >> ${ERC} -echo "export FC=/usr/local/bin/gfortran-10" >> ${ERC} -echo "alias c++=/usr/local/bin/c++-10" >> ${ERC} -echo "alias g++=/usr/local/bin/g++-10" >> ${ERC} -echo "alias gcc=/usr/local/bin/gcc-10" >> ${ERC} -echo "alias cpp=/usr/local/bin/cpp-10" >> ${ERC} -echo "alias ld=/usr/local/bin/gcc-10" >> ${ERC} -echo "alias cc=/usr/local/bin/gcc-10" >> ${ERC} -echo "alias gfortran=/usr/local/bin/gfortran-10" >> ${ERC} -echo "source ${ERC}" >> ${BP} -source ${BP} \ No newline at end of file diff --git a/setup/set_envvar_Ubuntu.sh b/setup/set_envvar_Ubuntu.sh deleted file mode 100644 index 5ddb0ec5e..000000000 --- a/setup/set_envvar_Ubuntu.sh +++ /dev/null @@ -1,70 +0,0 @@ -#!/bin/sh -# This is a setup script for installing EASIFEM-base library. -# (c) 2021, Dr Vikas Sharma, all rights reserved -# -# -# Log (dd/mm/yyyy) -# 15/02/2021 this document was created -# -#-------------------------------------------------------------- - -#!/bin/sh -# This is a setup script for installing EASIFEM-base library. -# (c) 2021, Dr Vikas Sharma, all rights reserved -# -# -# Log (dd/mm/yyyy) -# 15/02/2021 this document was created -# -#-------------------------------------------------------------- - -SHELL_=${SHELL} -if [[ $SHELL_ =~ .*zsh.* ]] -then - BP=${HOME}/.zshrc -fi -if [[ $SHELL_ =~ .*bash.* ]] -then - BP=${HOME}/.bashrc -fi - -if [ -f "${BP}" ] -then - echo "${BP} found" -else - touch ${BP} - echo '#!/bin/sh' >> ${BP} -fi - -ERC=${HOME}/.easifemrc -if [ -f "$ERC" ] -then - echo "${ERC} found, removing it" - rm -rf ${ERC} - touch ${ERC} - echo '#!/bin/sh' >> ${ERC} -else - touch ${ERC} - echo '#!/bin/sh' >> ${ERC} -fi - -prefix=${HOME} -EASIFEM_BASE=${prefix}/.easifem/base -EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs -EASIFEM_CLASSES=${prefix}/.easifem/classes -EASIFEM_MATERIALS=${prefix}/.easifem/materials -EASIFEM_KERNELS=${prefix}/.easifem/kernels - -echo "export EASIFEM_BASE=${prefix}/.easifem/base" >> ${ERC} -echo "export EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs" >> ${ERC} -echo "export EASIFEM_CLASSES=${prefix}/.easifem/classes" >> ${ERC} -echo "export EASIFEM_MATERIALS=${prefix}/.easifem/materials" >> ${ERC} -echo "export EASIFEM_KERNELS=${prefix}/.easifem/kernels" >> ${ERC} - -echo "mkdir -p ${EASIFEM_EXTPKGS}" >> ${ERC} -echo "mkdir -p ${EASIFEM_BASE}" >> ${ERC} -echo "mkdir -p ${EASIFEM_CLASSES}" >> ${ERC} -echo "mkdir -p ${EASIFEM_KERNELS}" >> ${ERC} - -echo "source ${ERC}" >> ${BP} -source ${BP} diff --git a/src/modules/ARPACK/CMakeLists.txt b/src/modules/ARPACK/CMakeLists.txt deleted file mode 100644 index b9e42666e..000000000 --- a/src/modules/ARPACK/CMakeLists.txt +++ /dev/null @@ -1,24 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/EASIFEM_F77_ARPACK.F90 - ${src_path}/ARPACK_SAUPD.F90 - ${src_path}/EASIFEM_ARPACK.F90 -) \ No newline at end of file diff --git a/src/modules/ARPACK/src/ARPACK_SAUPD.F90 b/src/modules/ARPACK/src/ARPACK_SAUPD.F90 deleted file mode 100644 index 22340fb10..000000000 --- a/src/modules/ARPACK/src/ARPACK_SAUPD.F90 +++ /dev/null @@ -1,253 +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 ARPACK_SAUPD -USE GlobalData, ONLY: I4B, DFP, LGT -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! SAUPD_ErrorMsg -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION SAUPD_ErrorMsg(INFO) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: INFO - TYPE(String) :: ans - END FUNCTION SAUPD_ErrorMsg -END INTERFACE - -PUBLIC :: SAUPD_ErrorMsg - -!---------------------------------------------------------------------------- -! SAUPD_ErrorMsg -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION SEUPD_ErrorMsg(INFO) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: INFO - TYPE(String) :: ans - END FUNCTION SEUPD_ErrorMsg -END INTERFACE - -PUBLIC :: SEUPD_ErrorMsg - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the largest eigenvalue of a real sym dense matrix -! -!# Introduction -! -!- This routine calculates the largest eigenvalue of a real sym dense matrix. -!- It calls ARPACK SSAUPD or DSAUPD routine - -INTERFACE - MODULE FUNCTION SymLargestEigenVal1(mat, which, NCV, maxIter, tol) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(:, :) - !! dense matrix - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "LM"` ⇨ absolute largest eigenvalue - !! `which = "LA"` ⇨ algebraic largest eigenvalue - !! default is "LA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, 20)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans - !! maximum eigenvalue - END FUNCTION SymLargestEigenVal1 -END INTERFACE - -INTERFACE SymLargestEigenVal - MODULE PROCEDURE SymLargestEigenVal1 -END INTERFACE SymLargestEigenVal - -PUBLIC :: SymLargestEigenVal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the `nev` smallest eigenvalue of a real sym dense matrix -! -!# Introduction -! -!- This routine calculates the smallest eigenvalue of a real sym dense matrix. -!- It calls ARPACK SSAUPD or DSAUPD routine - -INTERFACE - MODULE FUNCTION SymLargestEigenVal2(mat, nev, which, NCV, maxIter, tol) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(:, :) - !! dense matrix - INTEGER(I4B), INTENT(IN) :: nev - !! number of eigenvalues requested - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "LM"` ⇨ absolute largest eigenvalue - !! `which = "LA"` ⇨ algebraic largest eigenvalue - !! default is "LA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, MAX(2*nev+1, 20))` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans(nev) - !! first k, largest eigenvalue - END FUNCTION SymLargestEigenVal2 -END INTERFACE - -INTERFACE SymLargestEigenVal - MODULE PROCEDURE SymLargestEigenVal2 -END INTERFACE SymLargestEigenVal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the smallest eigenvalue of a real sym dense matrix -! -!# Introduction -! -!- This routine calculates the smallest eigenvalue of a real sym dense matrix. -!- It calls ARPACK SSAUPD or DSAUPD routine with MODE=3 -! -! In this routine we use shift-inverted method to compute the -! smallest eigenvalue of a regular (standard) eigenvalue problem. This is -! because `ARPACK` is good at finding the largest eigenvalue. -! -! Internally this routine solves a system of linear equations: `mat * y = x` -! by using LU decomposition. -! -! In this routine we make a call to LUSolve and getLU routine. -! -!@note -! In this routine we make a copy of mat in mat0. Then, compute the LU -! decomposition of mat0. -!@endnote - -INTERFACE - MODULE FUNCTION SymSmallestEigenVal1(mat, sigma, which, NCV, maxIter, tol) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(:, :) - !! dense matrix - REAL(DFP), OPTIONAL, INTENT(IN) :: sigma - !! Default value is 0.0 - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "SM"` ⇨ absolute smallest eigenvalue - !! `which = "SA"` ⇨ algebraic smallest eigenvalue - !! default is "SA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, 20)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans - !! maximum eigenvalue - END FUNCTION SymSmallestEigenVal1 -END INTERFACE - -INTERFACE SymSmallestEigenVal - MODULE PROCEDURE SymSmallestEigenVal1 -END INTERFACE SymSmallestEigenVal - -PUBLIC :: SymSmallestEigenVal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the smallest eigenvalue of a real sym dense matrix -! -!# Introduction -! -! This routine is similar to SysSmallestEigenVal1() -! In this routine you can pass a factorized matrix `mat` and set `isLU=true` -! Then, this routine will not perform LU decomposition on mat. -! -! However, if `isLU=false`, then we will change mat, and on return -! it will contain the LU factorization of `mat` -! -!- [ ] TODO use Cholsky factorization instead of LU as mat is -! symmetric. -! - -INTERFACE - MODULE FUNCTION SymSmallestEigenVal2(mat, isFactor, ipiv, sigma, which, & - & NCV, maxIter, tol) & - & RESULT(ans) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! - !! Dense matrix - !! If isFactor is false, then this matrix will change on return - !! in this case, it will contain LU decomposition of `A-sigma*I` - !! If isFactor is true, then this matrix will not change - !! - LOGICAL(LGT), INTENT(INOUT) :: isFactor - !! if mat is already factorized, the set isFactor to true - !! if mat is not factorized, then set isFactor to false - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipiv(:) - !! When `isFactor` is true, then `mat` represents the - !! `LU` factorization of `A-sigma*I` obtained by `SymGetLU` routine. - !! In this case `ipiv` is returned by `SymGetLU`. - REAL(DFP), OPTIONAL, INTENT(IN) :: sigma - !! Default value is 0.0 - !! Sigma is ignored when isFactor=true. Because in this case - !! mat represents LU factorization of `A-sigma*I` - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "SM"` ⇨ absolute smallest eigenvalue - !! `which = "SA"` ⇨ algebraic smallest eigenvalue - !! default is "SA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, 20)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans - !! smallest eigenvalue - END FUNCTION SymSmallestEigenVal2 -END INTERFACE - -INTERFACE SymSmallestEigenVal - MODULE PROCEDURE SymSmallestEigenVal2 -END INTERFACE SymSmallestEigenVal - -END MODULE ARPACK_SAUPD diff --git a/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 b/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 deleted file mode 100644 index f75ac9037..000000000 --- a/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 +++ /dev/null @@ -1,25 +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: 2022-12-09 -! summary: This module contains interface to ARPACK lib. - -MODULE EASIFEM_ARPACK -USE EASIFEM_F77_ARPACK -USE ARPACK_SAUPD -END MODULE EASIFEM_ARPACK diff --git a/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 b/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 deleted file mode 100644 index 30da97cf1..000000000 --- a/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 +++ /dev/null @@ -1,158 +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 EASIFEM_F77_ARPACK -USE GlobalData, ONLY: I4B, Real32, Real64 -IMPLICIT NONE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE F77_SAUPD - - SUBROUTINE SSAUPD(ido, bmat, n, which, nev, tol, resid, ncv, & - & v, ldv, iparam, ipntr, workd, workl, lworkl, info) - !! - IMPORT :: I4B, Real32 - INTEGER(I4B), PARAMETER :: DFP = Real32 - INTEGER(I4B), INTENT(INOUT) :: ido - CHARACTER(LEN=1), INTENT(IN) :: bmat - INTEGER(I4B), INTENT(IN) :: n - CHARACTER(LEN=2), INTENT(IN) :: which - INTEGER(I4B), INTENT(IN) :: nev - REAL(DFP), INTENT(IN) :: tol - REAL(DFP), INTENT(INOUT) :: resid(:) - INTEGER(I4B), INTENT(IN) :: ncv - REAL(DFP), INTENT(INOUT) :: v(:, :) - INTEGER(I4B), INTENT(IN) :: ldv - INTEGER(I4B), INTENT(INOUT) :: iparam(11) - INTEGER(I4B), INTENT(INOUT) :: ipntr(11) - REAL(DFP), INTENT(INOUT) :: workd(:) - INTEGER(I4B), INTENT(IN) :: lworkl - REAL(DFP), INTENT(INOUT) :: workl(:) - INTEGER(I4B), INTENT(INOUT) :: info - END SUBROUTINE SSAUPD - - SUBROUTINE DSAUPD(ido, bmat, n, which, nev, tol, resid, ncv, & - & v, ldv, iparam, ipntr, workd, workl, lworkl, info) - !! - IMPORT :: I4B, Real64 - INTEGER(I4B), PARAMETER :: DFP = Real64 - INTEGER(I4B) :: ido - CHARACTER(LEN=1) :: bmat - INTEGER(I4B) :: n - CHARACTER(LEN=2) :: which - INTEGER(I4B) :: nev - REAL(DFP) :: tol - REAL(DFP) :: resid(n) - INTEGER(I4B) :: ncv - REAL(DFP) :: v(n, ncv) - INTEGER(I4B) :: ldv - INTEGER(I4B) :: iparam(11) - INTEGER(I4B) :: ipntr(11) - REAL(DFP) :: workd(3 * n) - INTEGER(I4B) :: lworkl - REAL(DFP) :: workl(lworkl) - INTEGER(I4B) :: info - END SUBROUTINE DSAUPD - -END INTERFACE F77_SAUPD - -PUBLIC :: F77_SAUPD - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE F77_SEUPD - - SUBROUTINE SSEUPD(rvec, howmny, select, d, & - & z, ldz, sigma, bmat,& - & n, which, nev, tol,& - & resid, ncv, v, ldv,& - & iparam, ipntr, workd, workl,& - & lworkl, info) - !! - USE GlobalData, ONLY: I4B, DFP => Real32, LGT - !! - LOGICAL(LGT) :: rvec - CHARACTER(LEN=*) :: howmny - INTEGER(I4B) :: ncv - LOGICAL(LGT) :: select(:) - INTEGER(I4B) :: nev - REAL(DFP) :: d(nev) - INTEGER(I4B) :: n - REAL(DFP) :: z(n, nev) - INTEGER(I4B) :: ldz - REAL(DFP) :: sigma - CHARACTER(LEN=*) :: bmat - CHARACTER(LEN=*) :: which - REAL(DFP) :: tol - REAL(DFP) :: resid(n) - REAL(DFP) :: v(n, ncv) - INTEGER(I4B) :: ldv - INTEGER(I4B) :: iparam(11) - INTEGER(I4B) :: ipntr(11) - REAL(DFP) :: workd(3 * n) - INTEGER(I4B) :: lworkl - REAL(DFP) :: workl(lworkl) - INTEGER(I4B) :: info - END SUBROUTINE SSEUPD - - SUBROUTINE DSEUPD(rvec, howmny, select, d, & - & z, ldz, sigma, bmat,& - & n, which, nev, tol,& - & resid, ncv, v, ldv,& - & iparam, ipntr, workd, workl,& - & lworkl, info) - !! - USE GlobalData, ONLY: I4B, DFP => Real64, LGT - !! - LOGICAL(LGT) :: rvec - CHARACTER(LEN=*) :: howmny - INTEGER(I4B) :: ncv - LOGICAL(LGT) :: select(:) - INTEGER(I4B) :: nev - REAL(DFP) :: d(nev) - INTEGER(I4B) :: n - REAL(DFP) :: z(n, nev) - INTEGER(I4B) :: ldz - REAL(DFP) :: sigma - CHARACTER(LEN=*) :: bmat - CHARACTER(LEN=*) :: which - REAL(DFP) :: tol - REAL(DFP) :: resid(n) - REAL(DFP) :: v(n, ncv) - INTEGER(I4B) :: ldv - INTEGER(I4B) :: iparam(11) - INTEGER(I4B) :: ipntr(11) - REAL(DFP) :: workd(3 * n) - INTEGER(I4B) :: lworkl - REAL(DFP) :: workl(lworkl) - INTEGER(I4B) :: info - END SUBROUTINE DSEUPD - -END INTERFACE F77_SEUPD - -PUBLIC :: F77_SEUPD - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE EASIFEM_F77_ARPACK diff --git a/src/modules/BLAS95/CMakeLists.txt b/src/modules/BLAS95/CMakeLists.txt deleted file mode 100644 index a9ad14950..000000000 --- a/src/modules/BLAS95/CMakeLists.txt +++ /dev/null @@ -1,26 +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 -# - -IF( USE_BLAS95 ) - LIST( APPEND TARGET_COMPILE_DEF "-DUSE_BLAS95" ) - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/F77_BLAS.F90 - ${src_path}/F95_BLAS.F90 - ) -ENDIF() diff --git a/src/modules/BLAS95/aux/blas95.lst b/src/modules/BLAS95/aux/blas95.lst deleted file mode 100755 index 5227182e0..000000000 --- a/src/modules/BLAS95/aux/blas95.lst +++ /dev/null @@ -1,219 +0,0 @@ -#=============================================================================== -# Copyright 2006-2020 Intel Corporation. -# -# This software and the related documents are Intel copyrighted materials, and -# your !USE of them is governed by the express license under which they were -# provided to you (License). Unless the License provides otherwise, you may not -# !USE, modify, copy, publish, distribute, disclose or transmit this software or -# the related documents without Intel's prior written permission. -# -# This software and the related documents are provided as is, with no express -# or implied warranties, other than those that are expressly stated in the -# License. -#=============================================================================== - -src_blas95 = \ -caxpby.F90 \ -caxpy.F90 \ -caxpyi.F90 \ -ccopy.F90 \ -cdotc.F90 \ -cdotci.F90 \ -cdotu.F90 \ -cdotui.F90 \ -cgbmv.F90 \ -cgem2vc.F90 \ -cgemm.F90 \ -cgemm_batch.F90 \ -cgemm3m.F90 \ -cgemm3m_batch.F90 \ -cgemmt.F90 \ -cgemv.F90 \ -cgerc.F90 \ -cgeru.F90 \ -cgthr.F90 \ -cgthrz.F90 \ -chbmv.F90 \ -chemm.F90 \ -chemv.F90 \ -cher.F90 \ -cher2.F90 \ -cher2k.F90 \ -cherk.F90 \ -chpmv.F90 \ -chpr.F90 \ -chpr2.F90 \ -crotg.F90 \ -cscal.F90 \ -csctr.F90 \ -csrot.F90 \ -csscal.F90 \ -cswap.F90 \ -csymm.F90 \ -csyr2k.F90 \ -csyrk.F90 \ -ctbmv.F90 \ -ctbsv.F90 \ -ctpmv.F90 \ -ctpsv.F90 \ -ctrmm.F90 \ -ctrmv.F90 \ -ctrsm.F90 \ -ctrsm_batch.F90 \ -ctrsv.F90 \ -dasum.F90 \ -daxpby.F90 \ -daxpy.F90 \ -daxpyi.F90 \ -dcabs1.F90 \ -dcopy.F90 \ -ddot.F90 \ -ddoti.F90 \ -dgbmv.F90 \ -dgem2vu.F90 \ -dgemm.F90 \ -dgemm_batch.F90 \ -dgemmt.F90 \ -dgemv.F90 \ -dger.F90 \ -dgthr.F90 \ -dgthrz.F90 \ -dnrm2.F90 \ -drot.F90 \ -droti.F90 \ -drotm.F90 \ -drotmg.F90 \ -drotg.F90 \ -dsbmv.F90 \ -dscal.F90 \ -dsctr.F90 \ -dsdot.F90 \ -dspmv.F90 \ -dspr.F90 \ -dspr2.F90 \ -dswap.F90 \ -dsymm.F90 \ -dsymv.F90 \ -dsyr.F90 \ -dsyr2.F90 \ -dsyr2k.F90 \ -dsyrk.F90 \ -dtbmv.F90 \ -dtbsv.F90 \ -dtpmv.F90 \ -dtpsv.F90 \ -dtrmm.F90 \ -dtrmv.F90 \ -dtrsm.F90 \ -dtrsm_batch.F90 \ -dtrsv.F90 \ -dzasum.F90 \ -dzgemm.F90 \ -dzgemv.F90 \ -dznrm2.F90 \ -icamax.F90 \ -icamin.F90 \ -idamax.F90 \ -idamin.F90 \ -isamax.F90 \ -isamin.F90 \ -izamax.F90 \ -izamin.F90 \ -sasum.F90 \ -saxpby.F90 \ -saxpy.F90 \ -saxpyi.F90 \ -scasum.F90 \ -scgemm.F90 \ -scgemv.F90 \ -scnrm2.F90 \ -scopy.F90 \ -scabs1.F90 \ -sdot.F90 \ -sdoti.F90 \ -sdsdot.F90 \ -sgbmv.F90 \ -sgem2vu.F90 \ -sgemm.F90 \ -sgemm_batch.F90 \ -sgemmt.F90 \ -sgemv.F90 \ -sger.F90 \ -sgthr.F90 \ -sgthrz.F90 \ -snrm2.F90 \ -srot.F90 \ -sroti.F90 \ -srotm.F90 \ -srotmg.F90 \ -srotg.F90 \ -ssbmv.F90 \ -sscal.F90 \ -ssctr.F90 \ -sspmv.F90 \ -sspr.F90 \ -sspr2.F90 \ -sswap.F90 \ -ssymm.F90 \ -ssymv.F90 \ -ssyr.F90 \ -ssyr2.F90 \ -ssyr2k.F90 \ -ssyrk.F90 \ -stbmv.F90 \ -stbsv.F90 \ -stpmv.F90 \ -stpsv.F90 \ -strmm.F90 \ -strmv.F90 \ -strsm.F90 \ -strsm_batch.F90 \ -strsv.F90 \ -zaxpby.F90 \ -zaxpy.F90 \ -zaxpyi.F90 \ -zcopy.F90 \ -zdotc.F90 \ -zdotci.F90 \ -zdotu.F90 \ -zdotui.F90 \ -zdrot.F90 \ -zdscal.F90 \ -zgbmv.F90 \ -zgem2vc.F90 \ -zgemm.F90 \ -zgemm_batch.F90 \ -zgemm3m.F90 \ -zgemm3m_batch.F90 \ -zgemmt.F90 \ -zgemv.F90 \ -zgerc.F90 \ -zgeru.F90 \ -zgthr.F90 \ -zgthrz.F90 \ -zhbmv.F90 \ -zhemm.F90 \ -zhemv.F90 \ -zher.F90 \ -zher2.F90 \ -zher2k.F90 \ -zherk.F90 \ -zhpmv.F90 \ -zhpr.F90 \ -zhpr2.F90 \ -zrotg.F90 \ -zscal.F90 \ -zsctr.F90 \ -zswap.F90 \ -zsymm.F90 \ -zsyr2k.F90 \ -zsyrk.F90 \ -ztbmv.F90 \ -ztbsv.F90 \ -ztpmv.F90 \ -ztpsv.F90 \ -ztrmm.F90 \ -ztrmv.F90 \ -ztrsm.F90 \ -ztrsm_batch.F90 \ -ztrsv.F90 \ \ No newline at end of file diff --git a/src/modules/BLAS95/aux/test.F90 b/src/modules/BLAS95/aux/test.F90 deleted file mode 100644 index b70ebaffe..000000000 --- a/src/modules/BLAS95/aux/test.F90 +++ /dev/null @@ -1,21 +0,0 @@ -program main -implicit none - -integer :: in, out, iostat, len -character( len = 1000 ) temp - -open( newunit = in, file = '../src/blas95.lst', status="old", & - & action="read" ) - -open( newunit = out, file = './EASIFEM_BLAS.F90', status="replace", & - & action="write" ) - -DO -read( in, *, IOSTAT=iostat) temp -len = LEN_TRIM(temp) -if(temp(1:1) .eq. '#') cycle -write( out, "(A)" ) '#include "./' // temp(1:len) // '"' -if( iostat .LT. 0 ) exit -END DO - -end program main \ No newline at end of file diff --git a/src/modules/BLAS95/src/F77_BLAS.F90 b/src/modules/BLAS95/src/F77_BLAS.F90 deleted file mode 100755 index e6a67a7cb..000000000 --- a/src/modules/BLAS95/src/F77_BLAS.F90 +++ /dev/null @@ -1,2590 +0,0 @@ -!============================================================================ -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, -! and your !USE of them is governed by the express license under which -! they were provided to you (License). Unless the License provides -! otherwise, you may not -! USE, modify, copy, publish, distribute, -! disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with -! no express -! or implied warranties, other than those that are expressly -! stated in the -! License. -!============================================================================ -! Content: -! Intel(R) MKL BLAS77 interface as prototypes for -! Intel(R) MKL BLAS95 interfaces -! - -MODULE F77_BLAS -IMPLICIT NONE - -INTERFACE F77_XERBLA - PURE SUBROUTINE XERBLA(NAME, INFO) - CHARACTER(LEN=*), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: INFO - END SUBROUTINE XERBLA -END INTERFACE F77_XERBLA - -! BLAS level 1 -INTERFACE F77_ASUM - PURE FUNCTION SASUM(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SASUM - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION SASUM - PURE FUNCTION SCASUM(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SCASUM - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION SCASUM - PURE FUNCTION DASUM(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DASUM - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION DASUM - PURE FUNCTION DZASUM(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DZASUM - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION DZASUM -END INTERFACE F77_ASUM - -INTERFACE F77_AXPY - PURE SUBROUTINE SAXPY(N, A, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SAXPY - PURE SUBROUTINE DAXPY(N, A, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DAXPY - PURE SUBROUTINE CAXPY(N, A, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CAXPY - PURE SUBROUTINE ZAXPY(N, A, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZAXPY -END INTERFACE F77_AXPY - -INTERFACE F77_COPY - PURE SUBROUTINE SCOPY(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SCOPY - PURE SUBROUTINE DCOPY(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DCOPY - PURE SUBROUTINE CCOPY(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CCOPY - PURE SUBROUTINE ZCOPY(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZCOPY -END INTERFACE F77_COPY - -INTERFACE F77_DOT - PURE FUNCTION SDOT(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SDOT - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION SDOT - PURE FUNCTION DDOT(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DDOT - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION DDOT -END INTERFACE F77_DOT - -INTERFACE F77_SDOT - PURE FUNCTION SDSDOT(N, SB, SX, INCX, SY, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SDSDOT - REAL(WP), INTENT(IN) :: SX(*) - REAL(WP), INTENT(IN) :: SY(*) - REAL(WP), INTENT(IN) :: SB - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION SDSDOT - PURE FUNCTION DSDOT(N, SX, INCX, SY, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, PARAMETER :: SP = KIND(1.0E0) - REAL(WP) :: DSDOT - REAL(SP), INTENT(IN) :: SX(*) - REAL(SP), INTENT(IN) :: SY(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION DSDOT -END INTERFACE F77_SDOT - -INTERFACE F77_DOTC - PURE FUNCTION CDOTC(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTC - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION CDOTC - PURE FUNCTION ZDOTC(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTC - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION ZDOTC -END INTERFACE F77_DOTC - -INTERFACE F77_DOTU - PURE FUNCTION CDOTU(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTU - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION CDOTU - PURE FUNCTION ZDOTU(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTU - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END FUNCTION ZDOTU -END INTERFACE F77_DOTU - -INTERFACE F77_NRM2 - PURE FUNCTION SNRM2(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SNRM2 - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION SNRM2 - PURE FUNCTION DNRM2(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DNRM2 - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION DNRM2 - PURE FUNCTION SCNRM2(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SCNRM2 - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION SCNRM2 - PURE FUNCTION DZNRM2(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DZNRM2 - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION DZNRM2 -END INTERFACE F77_NRM2 - -INTERFACE F77_ROT - PURE SUBROUTINE SROT(N, X, INCX, Y, INCY, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SROT - PURE SUBROUTINE DROT(N, X, INCX, Y, INCY, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DROT - PURE SUBROUTINE CSROT(N, X, INCX, Y, INCY, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CSROT - PURE SUBROUTINE ZDROT(N, X, INCX, Y, INCY, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZDROT -END INTERFACE F77_ROT - -INTERFACE F77_ROTG - PURE SUBROUTINE SROTG(A, B, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: A - REAL(WP), INTENT(INOUT) :: B - REAL(WP), INTENT(OUT) :: C - REAL(WP), INTENT(OUT) :: S - END SUBROUTINE SROTG - PURE SUBROUTINE DROTG(A, B, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: A - REAL(WP), INTENT(INOUT) :: B - REAL(WP), INTENT(OUT) :: C - REAL(WP), INTENT(OUT) :: S - END SUBROUTINE DROTG - PURE SUBROUTINE CROTG(A, B, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(INOUT) :: A - COMPLEX(WP), INTENT(INOUT) :: B - REAL(WP), INTENT(OUT) :: C - COMPLEX(WP), INTENT(OUT) :: S - END SUBROUTINE CROTG - PURE SUBROUTINE ZROTG(A, B, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(INOUT) :: A - COMPLEX(WP), INTENT(INOUT) :: B - REAL(WP), INTENT(OUT) :: C - COMPLEX(WP), INTENT(OUT) :: S - END SUBROUTINE ZROTG -END INTERFACE F77_ROTG - -INTERFACE F77_ROTM - PURE SUBROUTINE SROTM(N, X, INCX, Y, INCY, PARAM) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: PARAM(5) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SROTM - PURE SUBROUTINE DROTM(N, X, INCX, Y, INCY, PARAM) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: PARAM(5) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DROTM -END INTERFACE F77_ROTM - -INTERFACE F77_ROTMG - PURE SUBROUTINE SROTMG(D1, D2, X1, Y1, PARAM) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: D1 - REAL(WP), INTENT(INOUT) :: D2 - REAL(WP), INTENT(INOUT) :: X1 - REAL(WP), INTENT(IN) :: Y1 - REAL(WP), INTENT(OUT) :: PARAM(5) - END SUBROUTINE SROTMG - PURE SUBROUTINE DROTMG(D1, D2, X1, Y1, PARAM) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: D1 - REAL(WP), INTENT(INOUT) :: D2 - REAL(WP), INTENT(INOUT) :: X1 - REAL(WP), INTENT(IN) :: Y1 - REAL(WP), INTENT(OUT) :: PARAM(5) - END SUBROUTINE DROTMG -END INTERFACE F77_ROTMG - -INTERFACE F77_SCAL - PURE SUBROUTINE SSCAL(N, A, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSCAL - PURE SUBROUTINE DSCAL(N, A, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSCAL - PURE SUBROUTINE CSCAL(N, A, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - COMPLEX(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CSCAL - PURE SUBROUTINE ZSCAL(N, A, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - COMPLEX(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZSCAL - PURE SUBROUTINE CSSCAL(N, A, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CSSCAL - PURE SUBROUTINE ZDSCAL(N, A, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZDSCAL -END INTERFACE F77_SCAL - -INTERFACE F77_SWAP - PURE SUBROUTINE SSWAP(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSWAP - PURE SUBROUTINE DSWAP(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSWAP - PURE SUBROUTINE CSWAP(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CSWAP - PURE SUBROUTINE ZSWAP(N, X, INCX, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(INOUT) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZSWAP -END INTERFACE F77_SWAP - -INTERFACE F77_IAMAX - PURE FUNCTION ISAMAX(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ISAMAX - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION ISAMAX - PURE FUNCTION IDAMAX(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IDAMAX - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION IDAMAX - PURE FUNCTION ICAMAX(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ICAMAX - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION ICAMAX - PURE FUNCTION IZAMAX(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IZAMAX - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION IZAMAX -END INTERFACE F77_IAMAX - -INTERFACE F77_IAMIN - PURE FUNCTION ISAMIN(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ISAMIN - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION ISAMIN - PURE FUNCTION IDAMIN(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IDAMIN - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION IDAMIN - PURE FUNCTION ICAMIN(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ICAMIN - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION ICAMIN - PURE FUNCTION IZAMIN(N, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IZAMIN - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END FUNCTION IZAMIN -END INTERFACE F77_IAMIN - -INTERFACE F77_CABS1 - PURE FUNCTION SCABS1(C) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SCABS1 - COMPLEX(WP), INTENT(IN) :: C - END FUNCTION SCABS1 - PURE FUNCTION DCABS1(Z) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DCABS1 - COMPLEX(WP), INTENT(IN) :: Z - END FUNCTION DCABS1 -END INTERFACE F77_CABS1 - -INTERFACE F77_GBMV - PURE SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: KL - INTEGER, INTENT(IN) :: M - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KU - END SUBROUTINE SGBMV - PURE SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: KL - INTEGER, INTENT(IN) :: M - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KU - END SUBROUTINE DGBMV - PURE SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: KL - INTEGER, INTENT(IN) :: M - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KU - END SUBROUTINE CGBMV - PURE SUBROUTINE ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: KL - INTEGER, INTENT(IN) :: M - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KU - END SUBROUTINE ZGBMV -END INTERFACE F77_GBMV - -INTERFACE F77_GEMV - PURE SUBROUTINE SGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE SGEMV - PURE SUBROUTINE DGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE DGEMV - PURE SUBROUTINE CGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE CGEMV - PURE SUBROUTINE ZGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZGEMV - PURE SUBROUTINE SCGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE SCGEMV - PURE SUBROUTINE DZGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - CHARACTER(LEN=1), INTENT(IN) :: TRANS - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE DZGEMV -END INTERFACE F77_GEMV - -INTERFACE F77_GER - PURE SUBROUTINE SGER(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(INOUT) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE SGER - PURE SUBROUTINE DGER(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(INOUT) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE DGER -END INTERFACE F77_GER - -INTERFACE F77_GERC - PURE SUBROUTINE CGERC(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE CGERC - PURE SUBROUTINE ZGERC(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZGERC -END INTERFACE F77_GERC - -INTERFACE F77_GERU - PURE SUBROUTINE CGERU(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE CGERU - PURE SUBROUTINE ZGERU(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZGERU -END INTERFACE F77_GERU - -INTERFACE F77_HBMV - PURE SUBROUTINE CHBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CHBMV - PURE SUBROUTINE ZHBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZHBMV -END INTERFACE F77_HBMV - -INTERFACE F77_HEMV - PURE SUBROUTINE CHEMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CHEMV - PURE SUBROUTINE ZHEMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZHEMV -END INTERFACE F77_HEMV - -INTERFACE F77_HER - PURE SUBROUTINE CHER(UPLO, N, ALPHA, X, INCX, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CHER - PURE SUBROUTINE ZHER(UPLO, N, ALPHA, X, INCX, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZHER -END INTERFACE F77_HER - -INTERFACE F77_HER2 - PURE SUBROUTINE CHER2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CHER2 - PURE SUBROUTINE ZHER2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZHER2 -END INTERFACE F77_HER2 - -INTERFACE F77_HPMV - PURE SUBROUTINE CHPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: AP(*) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CHPMV - PURE SUBROUTINE ZHPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: AP(*) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZHPMV -END INTERFACE F77_HPMV - -INTERFACE F77_HPR - PURE SUBROUTINE CHPR(UPLO, N, ALPHA, X, INCX, AP) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(INOUT) :: AP(*) - COMPLEX(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CHPR - PURE SUBROUTINE ZHPR(UPLO, N, ALPHA, X, INCX, AP) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(INOUT) :: AP(*) - COMPLEX(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZHPR -END INTERFACE F77_HPR - -INTERFACE F77_HPR2 - PURE SUBROUTINE CHPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(INOUT) :: AP(*) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CHPR2 - PURE SUBROUTINE ZHPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(INOUT) :: AP(*) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZHPR2 -END INTERFACE F77_HPR2 - -INTERFACE F77_SBMV - PURE SUBROUTINE SSBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE SSBMV - PURE SUBROUTINE DSBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE DSBMV -END INTERFACE F77_SBMV - -INTERFACE F77_SPMV - PURE SUBROUTINE SSPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: AP(*) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSPMV - PURE SUBROUTINE DSPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: AP(*) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSPMV -END INTERFACE F77_SPMV - -INTERFACE F77_SPR - PURE SUBROUTINE SSPR(UPLO, N, ALPHA, X, INCX, AP) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: AP(*) - REAL(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSPR - PURE SUBROUTINE DSPR(UPLO, N, ALPHA, X, INCX, AP) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: AP(*) - REAL(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSPR -END INTERFACE F77_SPR - -INTERFACE F77_SPR2 - PURE SUBROUTINE SSPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: AP(*) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSPR2 - PURE SUBROUTINE DSPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: AP(*) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSPR2 -END INTERFACE F77_SPR2 - -INTERFACE F77_SYMV - PURE SUBROUTINE SSYMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSYMV - PURE SUBROUTINE DSYMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSYMV -END INTERFACE F77_SYMV - -INTERFACE F77_SYR - PURE SUBROUTINE SSYR(UPLO, N, ALPHA, X, INCX, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(INOUT) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSYR - PURE SUBROUTINE DSYR(UPLO, N, ALPHA, X, INCX, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(INOUT) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSYR -END INTERFACE F77_SYR - -INTERFACE F77_SYR2 - PURE SUBROUTINE SSYR2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(INOUT) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSYR2 - PURE SUBROUTINE DSYR2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(INOUT) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(IN) :: Y(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSYR2 -END INTERFACE F77_SYR2 - -INTERFACE F77_TBMV - PURE SUBROUTINE STBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE STBMV - PURE SUBROUTINE DTBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE DTBMV - PURE SUBROUTINE CTBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CTBMV - PURE SUBROUTINE ZTBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZTBMV -END INTERFACE F77_TBMV - -INTERFACE F77_TBSV - PURE SUBROUTINE STBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE STBSV - PURE SUBROUTINE DTBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE DTBSV - PURE SUBROUTINE CTBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CTBSV - PURE SUBROUTINE ZTBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZTBSV -END INTERFACE F77_TBSV - -INTERFACE F77_TPMV - PURE SUBROUTINE STPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: AP(*) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE STPMV - PURE SUBROUTINE DTPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: AP(*) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE DTPMV - PURE SUBROUTINE CTPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: AP(*) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CTPMV - PURE SUBROUTINE ZTPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: AP(*) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZTPMV -END INTERFACE F77_TPMV - -INTERFACE F77_TPSV - PURE SUBROUTINE STPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: AP(*) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE STPSV - PURE SUBROUTINE DTPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: AP(*) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE DTPSV - PURE SUBROUTINE CTPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: AP(*) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CTPSV - PURE SUBROUTINE ZTPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: AP(*) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZTPSV -END INTERFACE F77_TPSV - -INTERFACE F77_TRMV - PURE SUBROUTINE STRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE STRMV - PURE SUBROUTINE DTRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE DTRMV - PURE SUBROUTINE CTRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CTRMV - PURE SUBROUTINE ZTRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZTRMV -END INTERFACE F77_TRMV - -INTERFACE F77_TRSV - PURE SUBROUTINE STRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE STRSV - PURE SUBROUTINE DTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE DTRSV - PURE SUBROUTINE CTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE CTRSV - PURE SUBROUTINE ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: X(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - CHARACTER(LEN=1), INTENT(IN) :: DIAG - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZTRSV -END INTERFACE F77_TRSV - -INTERFACE F77_GEMM - PURE SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE SGEMM - PURE SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE DGEMM - PURE SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CGEMM - PURE SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZGEMM - PURE SUBROUTINE SCGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE SCGEMM - PURE SUBROUTINE DZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE DZGEMM -END INTERFACE F77_GEMM - -INTERFACE F77_HEMM - PURE SUBROUTINE CHEMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE CHEMM - PURE SUBROUTINE ZHEMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZHEMM -END INTERFACE F77_HEMM - -INTERFACE F77_HERK - PURE SUBROUTINE CHERK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CHERK - PURE SUBROUTINE ZHERK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZHERK -END INTERFACE F77_HERK - -INTERFACE F77_HER2K -PURE SUBROUTINE CHER2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - COMPLEX(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CHER2K -PURE SUBROUTINE ZHER2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - COMPLEX(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZHER2K -END INTERFACE F77_HER2K - -INTERFACE F77_SYMM - PURE SUBROUTINE SSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE SSYMM - PURE SUBROUTINE DSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE DSYMM - PURE SUBROUTINE CSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE CSYMM - PURE SUBROUTINE ZSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZSYMM -END INTERFACE F77_SYMM - -INTERFACE F77_SYRK - PURE SUBROUTINE SSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE SSYRK - PURE SUBROUTINE DSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDC - END SUBROUTINE DSYRK - PURE SUBROUTINE CSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDC - END SUBROUTINE CSYRK - PURE SUBROUTINE ZSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDC - END SUBROUTINE ZSYRK -END INTERFACE F77_SYRK - -INTERFACE F77_SYR2K -PURE SUBROUTINE SSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE SSYR2K -PURE SUBROUTINE DSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE DSYR2K -PURE SUBROUTINE CSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CSYR2K -PURE SUBROUTINE ZSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANS - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZSYR2K -END INTERFACE F77_SYR2K - -INTERFACE F77_TRMM - PURE SUBROUTINE STRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE STRMM - PURE SUBROUTINE DTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - END SUBROUTINE DTRMM - PURE SUBROUTINE CTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE CTRMM - PURE SUBROUTINE ZTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZTRMM -END INTERFACE F77_TRMM - -INTERFACE F77_TRSM - PURE SUBROUTINE STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - END SUBROUTINE STRSM - PURE SUBROUTINE DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - REAL(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - END SUBROUTINE DTRSM - PURE SUBROUTINE CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - END SUBROUTINE CTRSM - PURE SUBROUTINE ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) - CHARACTER(LEN=1), INTENT(IN) :: SIDE - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: DIAG - COMPLEX(WP), INTENT(IN) :: ALPHA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - END SUBROUTINE ZTRSM -END INTERFACE F77_TRSM - -INTERFACE F77_GEMM3M - PURE SUBROUTINE CGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE CGEMM3M - PURE SUBROUTINE ZGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & - & LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - END SUBROUTINE ZGEMM3M -END INTERFACE F77_GEMM3M - -INTERFACE F77_GEMMT - PURE SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & - & C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - ! INTEGER, INTENT(IN) :: LDC - END SUBROUTINE SGEMMT - PURE SUBROUTINE DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & - & C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: B(LDB, *) - REAL(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - ! INTEGER, INTENT(IN) :: LDC - END SUBROUTINE DGEMMT - PURE SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & - & C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - ! INTEGER, INTENT(IN) :: LDC - END SUBROUTINE CGEMMT - PURE SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & - & C, LDC) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - INTEGER, INTENT(IN) :: LDB - INTEGER, INTENT(IN) :: LDC - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: B(LDB, *) - COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) - CHARACTER(LEN=1), INTENT(IN) :: UPLO - CHARACTER(LEN=1), INTENT(IN) :: TRANSA - CHARACTER(LEN=1), INTENT(IN) :: TRANSB - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - ! INTEGER, INTENT(IN) :: LDA - ! INTEGER, INTENT(IN) :: LDB - ! INTEGER, INTENT(IN) :: LDC - END SUBROUTINE ZGEMMT -END INTERFACE F77_GEMMT - -INTERFACE F77_AXPBY - PURE SUBROUTINE SAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE SAXPBY - PURE SUBROUTINE DAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: X(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE DAXPBY - PURE SUBROUTINE CAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE CAXPBY - PURE SUBROUTINE ZAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: X(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX - INTEGER, INTENT(IN) :: INCY - INTEGER, INTENT(IN) :: N - END SUBROUTINE ZAXPBY -END INTERFACE F77_AXPBY - -! Intel mkl related -! #ifdef USE_INTEL_MKL -INTERFACE F77_ROTI - PURE SUBROUTINE SROTI(NZ, X, INDX, Y, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(INOUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(IN) :: Y(*) - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE SROTI - PURE SUBROUTINE DROTI(NZ, X, INDX, Y, C, S) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(INOUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(IN) :: Y(*) - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE DROTI -END INTERFACE F77_ROTI - -INTERFACE F77_GEM2V - PURE SUBROUTINE SGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & - & INCY1, Y2, INCY2) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X1(*) - REAL(WP), INTENT(IN) :: X2(*) - REAL(WP), INTENT(INOUT) :: Y1(*) - REAL(WP), INTENT(INOUT) :: Y2(*) - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX1 - INTEGER, INTENT(IN) :: INCX2 - INTEGER, INTENT(IN) :: INCY1 - INTEGER, INTENT(IN) :: INCY2 - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - END SUBROUTINE SGEM2VU - PURE SUBROUTINE DGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & - & INCY1, Y2, INCY2) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - REAL(WP), INTENT(IN) :: A(LDA, *) - REAL(WP), INTENT(IN) :: X1(*) - REAL(WP), INTENT(IN) :: X2(*) - REAL(WP), INTENT(INOUT) :: Y1(*) - REAL(WP), INTENT(INOUT) :: Y2(*) - REAL(WP), INTENT(IN) :: ALPHA - REAL(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX1 - INTEGER, INTENT(IN) :: INCX2 - INTEGER, INTENT(IN) :: INCY1 - INTEGER, INTENT(IN) :: INCY2 - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - END SUBROUTINE DGEM2VU - PURE SUBROUTINE CGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & - & INCY1, Y2, INCY2) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X1(*) - COMPLEX(WP), INTENT(IN) :: X2(*) - COMPLEX(WP), INTENT(INOUT) :: Y1(*) - COMPLEX(WP), INTENT(INOUT) :: Y2(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX1 - INTEGER, INTENT(IN) :: INCX2 - INTEGER, INTENT(IN) :: INCY1 - INTEGER, INTENT(IN) :: INCY2 - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - END SUBROUTINE CGEM2VC - PURE SUBROUTINE ZGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & - & INCY1, Y2, INCY2) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, INTENT(IN) :: LDA - COMPLEX(WP), INTENT(IN) :: A(LDA, *) - COMPLEX(WP), INTENT(IN) :: X1(*) - COMPLEX(WP), INTENT(IN) :: X2(*) - COMPLEX(WP), INTENT(INOUT) :: Y1(*) - COMPLEX(WP), INTENT(INOUT) :: Y2(*) - COMPLEX(WP), INTENT(IN) :: ALPHA - COMPLEX(WP), INTENT(IN) :: BETA - INTEGER, INTENT(IN) :: INCX1 - INTEGER, INTENT(IN) :: INCX2 - INTEGER, INTENT(IN) :: INCY1 - INTEGER, INTENT(IN) :: INCY2 - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - ! INTEGER, INTENT(IN) :: LDA - END SUBROUTINE ZGEM2VC -END INTERFACE F77_GEM2V - -INTERFACE F77_AXPYI - PURE SUBROUTINE SAXPYI(NZ, A, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE SAXPYI - PURE SUBROUTINE DAXPYI(NZ, A, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(INOUT) :: Y(*) - REAL(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE DAXPYI - PURE SUBROUTINE CAXPYI(NZ, A, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE CAXPYI - PURE SUBROUTINE ZAXPYI(NZ, A, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - COMPLEX(WP), INTENT(IN) :: A - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE ZAXPYI -END INTERFACE F77_AXPYI - -INTERFACE F77_DOTI - PURE FUNCTION SDOTI(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SDOTI - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END FUNCTION SDOTI - PURE FUNCTION DDOTI(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DDOTI - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END FUNCTION DDOTI -END INTERFACE F77_DOTI - -INTERFACE F77_DOTCI - PURE FUNCTION CDOTCI(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTCI - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END FUNCTION CDOTCI - PURE FUNCTION ZDOTCI(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTCI - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END FUNCTION ZDOTCI -END INTERFACE F77_DOTCI - -INTERFACE F77_DOTUI - PURE FUNCTION CDOTUI(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTUI - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END FUNCTION CDOTUI - PURE FUNCTION ZDOTUI(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTUI - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END FUNCTION ZDOTUI -END INTERFACE F77_DOTUI - -INTERFACE F77_GEMM_BATCH - PURE SUBROUTINE SGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& - & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & - & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & - & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) - REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) - REAL(WP), INTENT(IN) :: BETA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: K_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: LDC_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE SGEMM_BATCH - PURE SUBROUTINE DGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& - & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & - & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & - & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) - REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) - REAL(WP), INTENT(IN) :: BETA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: K_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: LDC_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE DGEMM_BATCH - - PURE SUBROUTINE CGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& - & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & - & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & - & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: K_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: LDC_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE CGEMM_BATCH - PURE SUBROUTINE ZGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& - & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & - & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & - & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: K_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: LDC_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE ZGEMM_BATCH -END INTERFACE F77_GEMM_BATCH - -INTERFACE F77_GEMM3M_BATCH - PURE SUBROUTINE CGEMM3M_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, & - & N_ARRAY, K_ARRAY, ALPHA_ARRAY, A_ARRAY, & - & LDA_ARRAY, B_ARRAY, LDB_ARRAY, BETA_ARRAY, & - & C_ARRAY, LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: K_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: LDC_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE CGEMM3M_BATCH - PURE SUBROUTINE ZGEMM3M_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, & - & N_ARRAY, K_ARRAY, ALPHA_ARRAY, A_ARRAY, & - & LDA_ARRAY, B_ARRAY, LDB_ARRAY, BETA_ARRAY, & - & C_ARRAY, LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: K_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: LDC_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE ZGEMM3M_BATCH -END INTERFACE F77_GEMM3M_BATCH - -INTERFACE F77_TRSM_BATCH -PURE SUBROUTINE STRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& - & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& - & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) - REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE STRSM_BATCH -PURE SUBROUTINE DTRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& - & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& - & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) - REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE DTRSM_BATCH -PURE SUBROUTINE CTRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& - & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& - & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE CTRSM_BATCH -PURE SUBROUTINE ZTRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& - & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& - & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) - USE, INTRINSIC :: ISO_C_BINDING - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) - CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) - COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) - INTEGER, INTENT(IN) :: M_ARRAY(*) - INTEGER, INTENT(IN) :: N_ARRAY(*) - INTEGER, INTENT(IN) :: LDA_ARRAY(*) - INTEGER, INTENT(IN) :: LDB_ARRAY(*) - INTEGER, INTENT(IN) :: GROUP_COUNT - INTEGER, INTENT(IN) :: GROUP_SIZE(*) - END SUBROUTINE ZTRSM_BATCH -END INTERFACE F77_TRSM_BATCH - -INTERFACE F77_GTHR - PURE SUBROUTINE SGTHR(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE SGTHR - PURE SUBROUTINE DGTHR(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE DGTHR - PURE SUBROUTINE CGTHR(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE CGTHR - PURE SUBROUTINE ZGTHR(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(IN) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE ZGTHR -END INTERFACE F77_GTHR - -INTERFACE F77_GTHRZ - PURE SUBROUTINE SGTHRZ(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE SGTHRZ - PURE SUBROUTINE DGTHRZ(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE DGTHRZ - PURE SUBROUTINE CGTHRZ(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE CGTHRZ - PURE SUBROUTINE ZGTHRZ(NZ, Y, X, INDX) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(OUT) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(INOUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE ZGTHRZ -END INTERFACE F77_GTHRZ - -INTERFACE F77_SCTR - PURE SUBROUTINE SSCTR(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(OUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE SSCTR - PURE SUBROUTINE DSCTR(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - REAL(WP), INTENT(OUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE DSCTR - PURE SUBROUTINE CSCTR(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(OUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE CSCTR - PURE SUBROUTINE ZSCTR(NZ, X, INDX, Y) - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP), INTENT(IN) :: X(*) - INTEGER, INTENT(IN) :: INDX(*) - COMPLEX(WP), INTENT(OUT) :: Y(*) - INTEGER, INTENT(IN) :: NZ - END SUBROUTINE ZSCTR -END INTERFACE F77_SCTR -! #endif -END MODULE F77_BLAS diff --git a/src/modules/BLAS95/src/F95_BLAS.F90 b/src/modules/BLAS95/src/F95_BLAS.F90 deleted file mode 100644 index 9f5b8bb01..000000000 --- a/src/modules/BLAS95/src/F95_BLAS.F90 +++ /dev/null @@ -1,422 +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: 26 Feb 2021 -! summary: - -MODULE F95_BLAS -USE F77_BLAS -IMPLICIT NONE -PRIVATE - -PUBLIC :: IAMAX -PUBLIC :: SWAP -PUBLIC :: SCAL -PUBLIC :: ROTMG -PUBLIC :: ROTM -PUBLIC :: ROTG -PUBLIC :: ROT -PUBLIC :: NRM2 -PUBLIC :: DOTU -PUBLIC :: DOT -PUBLIC :: DOTC -PUBLIC :: SDOT -PUBLIC :: COPY -PUBLIC :: AXPY -PUBLIC :: ASUM -PUBLIC :: GEMV - -#ifndef USE_NativeBLAS -PUBLIC :: IAMIN -#endif - -#ifndef USE_APPLE_NativeBLAS -PUBLIC :: CABS1 -#endif - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE ASUM - MODULE PROCEDURE SASUM_F95, SCASUM_F95, DASUM_F95, DZASUM_F95 -END INTERFACE ASUM - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE AXPY - MODULE PROCEDURE SAXPY_F95, DAXPY_F95, CAXPY_F95, ZAXPY_F95 -END INTERFACE AXPY - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE COPY - MODULE PROCEDURE SCOPY_F95, DCOPY_F95, CCOPY_F95, ZCOPY_F95 -END INTERFACE COPY - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE DOT - MODULE PROCEDURE SDOT_F95, DDOT_F95 -END INTERFACE DOT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE SDOT - MODULE PROCEDURE SDSDOT_F95, DSDOT_F95 -END INTERFACE SDOT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE DOTC - MODULE PROCEDURE CDOTC_F95, ZDOTC_F95 -END INTERFACE DOTC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE DOTU - MODULE PROCEDURE CDOTU_F95, ZDOTU_F95 -END INTERFACE DOTU - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE NRM2 - MODULE PROCEDURE SNRM2_F95, DNRM2_F95, SCNRM2_F95, DZNRM2_F95 -END INTERFACE NRM2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE ROT - MODULE PROCEDURE SROT_F95, DROT_F95, CSROT_F95, ZDROT_F95 -END INTERFACE ROT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE ROTG - MODULE PROCEDURE SROTG_F95, DROTG_F95, CROTG_F95, ZROTG_F95 -END INTERFACE ROTG - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE ROTM - MODULE PROCEDURE SROTM_F95, DROTM_F95 -END INTERFACE ROTM - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE ROTMG - MODULE PROCEDURE SROTMG_F95, DROTMG_F95 -END INTERFACE ROTMG - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE SCAL - MODULE PROCEDURE SSCAL_F95, DSCAL_F95, CSCAL_F95, ZSCAL_F95, CSSCAL_F95,& - & ZDSCAL_F95 -END INTERFACE SCAL - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE SWAP - MODULE PROCEDURE SSWAP_F95, DSWAP_F95, CSWAP_F95, ZSWAP_F95 -END INTERFACE SWAP - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE IAMAX - MODULE PROCEDURE ISAMAX_F95, IDAMAX_F95, ICAMAX_F95, IZAMAX_F95 -END INTERFACE IAMAX - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#ifndef USE_NativeBLAS -INTERFACE IAMIN - MODULE PROCEDURE ISAMIN_F95, IDAMIN_F95, ICAMIN_F95, IZAMIN_F95 -END INTERFACE IAMIN -#endif - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#ifndef USE_APPLE_NativeBLAS -INTERFACE CABS1 - MODULE PROCEDURE SCABS1_F95, DCABS1_F95 -END INTERFACE CABS1 -#endif - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE GEMV - MODULE PROCEDURE SGEMV_F95, DGEMV_F95, CGEMV_F95, ZGEMV_F95 -END INTERFACE GEMV - -#ifdef USE_INTEL_MKL -INTERFACE GEMV - MODULE PROCEDURE SCGEMV_F95, DZGEMV_F95 -END INTERFACE GEMV -#endif - -CONTAINS - -#ifndef USE_APPLE_NativeBLAS -#include "./blas95_src/dcabs1.F90" -#include "./blas95_src/scabs1.F90" -#include "./blas95_src/cgemm3m.F90" -#include "./blas95_src/saxpby.F90" -#include "./blas95_src/daxpby.F90" -#include "./blas95_src/caxpby.F90" -#include "./blas95_src/zaxpby.F90" -#include "./blas95_src/zgemm3m.F90" -#endif - -#include "./blas95_src/caxpy.F90" -#include "./blas95_src/ccopy.F90" -#include "./blas95_src/cdotc.F90" -#include "./blas95_src/cdotu.F90" -#include "./blas95_src/cgbmv.F90" -#include "./blas95_src/cgemm.F90" -#include "./blas95_src/cgemv.F90" -#include "./blas95_src/cgerc.F90" -#include "./blas95_src/cgeru.F90" -#include "./blas95_src/chbmv.F90" -#include "./blas95_src/chemm.F90" -#include "./blas95_src/chemv.F90" -#include "./blas95_src/cher.F90" -#include "./blas95_src/cher2.F90" -#include "./blas95_src/cher2k.F90" -#include "./blas95_src/cherk.F90" -#include "./blas95_src/chpmv.F90" -#include "./blas95_src/chpr.F90" -#include "./blas95_src/chpr2.F90" -#include "./blas95_src/crotg.F90" -#include "./blas95_src/cscal.F90" -#include "./blas95_src/csrot.F90" -#include "./blas95_src/csscal.F90" -#include "./blas95_src/cswap.F90" -#include "./blas95_src/zswap.F90" -#include "./blas95_src/csymm.F90" -#include "./blas95_src/csyr2k.F90" -#include "./blas95_src/csyrk.F90" -#include "./blas95_src/ctbmv.F90" -#include "./blas95_src/ctbsv.F90" -#include "./blas95_src/ctpmv.F90" -#include "./blas95_src/ctpsv.F90" -#include "./blas95_src/ctrmm.F90" -#include "./blas95_src/ctrmv.F90" -#include "./blas95_src/ctrsm.F90" -#include "./blas95_src/ctrsv.F90" -#include "./blas95_src/dasum.F90" -#include "./blas95_src/daxpy.F90" -#include "./blas95_src/dcopy.F90" -#include "./blas95_src/ddot.F90" -#include "./blas95_src/dgbmv.F90" -#include "./blas95_src/dgemm.F90" -#include "./blas95_src/dgemv.F90" -#include "./blas95_src/dger.F90" -#include "./blas95_src/dnrm2.F90" -#include "./blas95_src/drot.F90" -#include "./blas95_src/drotm.F90" -#include "./blas95_src/drotmg.F90" -#include "./blas95_src/drotg.F90" -#include "./blas95_src/dsbmv.F90" -#include "./blas95_src/dscal.F90" -#include "./blas95_src/dsdot.F90" -#include "./blas95_src/dspmv.F90" -#include "./blas95_src/dspr.F90" -#include "./blas95_src/dspr2.F90" -#include "./blas95_src/dswap.F90" -#include "./blas95_src/dsymm.F90" -#include "./blas95_src/dsymv.F90" -#include "./blas95_src/dsyr.F90" -#include "./blas95_src/dsyr2.F90" -#include "./blas95_src/dsyr2k.F90" -#include "./blas95_src/dsyrk.F90" -#include "./blas95_src/dtbmv.F90" -#include "./blas95_src/dtbsv.F90" -#include "./blas95_src/dtpmv.F90" -#include "./blas95_src/dtpsv.F90" -#include "./blas95_src/dtrmm.F90" -#include "./blas95_src/dtrmv.F90" -#include "./blas95_src/dtrsm.F90" -#include "./blas95_src/dtrsv.F90" -#include "./blas95_src/dzasum.F90" -#include "./blas95_src/dznrm2.F90" -#include "./blas95_src/icamax.F90" -#include "./blas95_src/idamax.F90" -#include "./blas95_src/isamax.F90" -#include "./blas95_src/izamax.F90" -#include "./blas95_src/sasum.F90" -#include "./blas95_src/saxpy.F90" -#include "./blas95_src/scasum.F90" -#include "./blas95_src/scnrm2.F90" -#include "./blas95_src/scopy.F90" -#include "./blas95_src/sdot.F90" -#include "./blas95_src/sdsdot.F90" -#include "./blas95_src/sgbmv.F90" -#include "./blas95_src/sgemm.F90" -#include "./blas95_src/sgemv.F90" -#include "./blas95_src/sger.F90" -#include "./blas95_src/snrm2.F90" -#include "./blas95_src/srot.F90" -#include "./blas95_src/srotm.F90" -#include "./blas95_src/srotmg.F90" -#include "./blas95_src/srotg.F90" -#include "./blas95_src/ssbmv.F90" -#include "./blas95_src/sscal.F90" -#include "./blas95_src/sspmv.F90" -#include "./blas95_src/sspr.F90" -#include "./blas95_src/sspr2.F90" -#include "./blas95_src/sswap.F90" -#include "./blas95_src/ssymm.F90" -#include "./blas95_src/ssymv.F90" -#include "./blas95_src/ssyr.F90" -#include "./blas95_src/ssyr2.F90" -#include "./blas95_src/ssyr2k.F90" -#include "./blas95_src/ssyrk.F90" -#include "./blas95_src/stbmv.F90" -#include "./blas95_src/stbsv.F90" -#include "./blas95_src/stpmv.F90" -#include "./blas95_src/stpsv.F90" -#include "./blas95_src/strmm.F90" -#include "./blas95_src/strmv.F90" -#include "./blas95_src/strsm.F90" -#include "./blas95_src/strsv.F90" -#include "./blas95_src/zaxpy.F90" -#include "./blas95_src/zcopy.F90" -#include "./blas95_src/zdotc.F90" -#include "./blas95_src/zdotu.F90" -#include "./blas95_src/zdrot.F90" -#include "./blas95_src/zdscal.F90" -#include "./blas95_src/zgbmv.F90" -#include "./blas95_src/zgemm.F90" -#include "./blas95_src/zgemv.F90" -#include "./blas95_src/zgerc.F90" -#include "./blas95_src/zgeru.F90" -#include "./blas95_src/zhbmv.F90" -#include "./blas95_src/zhemm.F90" -#include "./blas95_src/zhemv.F90" -#include "./blas95_src/zher.F90" -#include "./blas95_src/zher2.F90" -#include "./blas95_src/zher2k.F90" -#include "./blas95_src/zherk.F90" -#include "./blas95_src/zhpmv.F90" -#include "./blas95_src/zhpr.F90" -#include "./blas95_src/zhpr2.F90" -#include "./blas95_src/zrotg.F90" -#include "./blas95_src/zscal.F90" -#include "./blas95_src/zsymm.F90" -#include "./blas95_src/zsyr2k.F90" -#include "./blas95_src/zsyrk.F90" -#include "./blas95_src/ztbmv.F90" -#include "./blas95_src/ztbsv.F90" -#include "./blas95_src/ztpmv.F90" -#include "./blas95_src/ztpsv.F90" -#include "./blas95_src/ztrmm.F90" -#include "./blas95_src/ztrmv.F90" -#include "./blas95_src/ztrsm.F90" -#include "./blas95_src/ztrsv.F90" - -#ifndef USE_NativeBLAS -#include "./blas95_src/icamin.F90" -#include "./blas95_src/idamin.F90" -#include "./blas95_src/isamin.F90" -#include "./blas95_src/izamin.F90" -#endif - -#ifdef USE_INTEL_MKL -#include "./blas95_src/droti.F90" -#include "./blas95_src/sroti.F90" -#include "./blas95_src/zgem2vc.F90" -#include "./blas95_src/cgem2vc.F90" -#include "./blas95_src/dgem2vu.F90" -#include "./blas95_src/sgem2vu.F90" -#include "./blas95_src/caxpyi.F90" -#include "./blas95_src/daxpyi.F90" -#include "./blas95_src/saxpyi.F90" -#include "./blas95_src/zaxpyi.F90" -#include "./blas95_src/ddoti.F90" -#include "./blas95_src/sdoti.F90" -#include "./blas95_src/cdotci.F90" -#include "./blas95_src/zdotci.F90" -#include "./blas95_src/cdotui.F90" -#include "./blas95_src/zdotui.F90" -#include "./blas95_src/cgemm_batch.F90" -#include "./blas95_src/cgemm3m_batch.F90" -#include "./blas95_src/ctrsm_batch.F90" -#include "./blas95_src/dgemm_batch.F90" -#include "./blas95_src/dtrsm_batch.F90" -#include "./blas95_src/sgemm_batch.F90" -#include "./blas95_src/strsm_batch.F90" -#include "./blas95_src/zgemm_batch.F90" -#include "./blas95_src/zgemm3m_batch.F90" -#include "./blas95_src/ztrsm_batch.F90" -#include "./blas95_src/cgemmt.F90" -#include "./blas95_src/dgemmt.F90" -#include "./blas95_src/sgemmt.F90" -#include "./blas95_src/zgemmt.F90" -#include "./blas95_src/cgthr.F90" -#include "./blas95_src/cgthrz.F90" -#include "./blas95_src/dgthr.F90" -#include "./blas95_src/dgthrz.F90" -#include "./blas95_src/sgthr.F90" -#include "./blas95_src/sgthrz.F90" -#include "./blas95_src/zgthr.F90" -#include "./blas95_src/zgthrz.F90" -#include "./blas95_src/dsctr.F90" -#include "./blas95_src/ssctr.F90" -#include "./blas95_src/csctr.F90" -#include "./blas95_src/dzgemm.F90" -#include "./blas95_src/dzgemv.F90" -#include "./blas95_src/scgemm.F90" -#include "./blas95_src/scgemv.F90" -#endif - -END MODULE F95_BLAS diff --git a/src/modules/BLAS95/src/blas95_src/caxpby.F90 b/src/modules/BLAS95/src/blas95_src/caxpby.F90 deleted file mode 100755 index 17ea58a12..000000000 --- a/src/modules/BLAS95/src/blas95_src/caxpby.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! CAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - ! Default ALPHA=1 - ! Default BETA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPBY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE CAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/caxpy.F90 b/src/modules/BLAS95/src/blas95_src/caxpy.F90 deleted file mode 100755 index 456c791c5..000000000 --- a/src/modules/BLAS95/src/blas95_src/caxpy.F90 +++ /dev/null @@ -1,58 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CAXPY_F95(X,Y,A) - ! Fortran77 call: - ! CAXPY(N,A,X,INCX,Y,INCY) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_A - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) -END SUBROUTINE CAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/caxpyi.F90 b/src/modules/BLAS95/src/blas95_src/caxpyi.F90 deleted file mode 100755 index 2667221f4..000000000 --- a/src/modules/BLAS95/src/blas95_src/caxpyi.F90 +++ /dev/null @@ -1,55 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! CAXPYI(NZ,A,X,INDX,Y) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPYI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_A - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPYI(NZ,O_A,X,INDX,Y) -END SUBROUTINE CAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ccopy.F90 b/src/modules/BLAS95/src/blas95_src/ccopy.F90 deleted file mode 100755 index 78369f3ad..000000000 --- a/src/modules/BLAS95/src/blas95_src/ccopy.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CCOPY_F95(X,Y) - ! Fortran77 call: - ! CCOPY(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_COPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_COPY(N,X,INCX,Y,INCY) -END SUBROUTINE CCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotc.F90 b/src/modules/BLAS95/src/blas95_src/cdotc.F90 deleted file mode 100755 index 5dc6e5f3f..000000000 --- a/src/modules/BLAS95/src/blas95_src/cdotc.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION CDOTC_F95(X,Y) - ! Fortran77 call: - ! CDOTC(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTC - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTC_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTC' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CDOTC_F95 = F77_DOTC(N,X,INCX,Y,INCY) -END FUNCTION CDOTC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotci.F90 b/src/modules/BLAS95/src/blas95_src/cdotci.F90 deleted file mode 100755 index 014446af5..000000000 --- a/src/modules/BLAS95/src/blas95_src/cdotci.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION CDOTCI_F95(X,INDX,Y) - ! Fortran77 call: - ! CDOTCI(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTCI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTCI_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTCI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CDOTCI_F95 = F77_DOTCI(NZ,X,INDX,Y) -END FUNCTION CDOTCI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotu.F90 b/src/modules/BLAS95/src/blas95_src/cdotu.F90 deleted file mode 100755 index 62990cdd9..000000000 --- a/src/modules/BLAS95/src/blas95_src/cdotu.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION CDOTU_F95(X,Y) - ! Fortran77 call: - ! CDOTU(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTU - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTU_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTU' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CDOTU_F95 = F77_DOTU(N,X,INCX,Y,INCY) -END FUNCTION CDOTU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotui.F90 b/src/modules/BLAS95/src/blas95_src/cdotui.F90 deleted file mode 100755 index 62dffa908..000000000 --- a/src/modules/BLAS95/src/blas95_src/cdotui.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION CDOTUI_F95(X,INDX,Y) - ! Fortran77 call: - ! CDOTUI(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTUI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - COMPLEX(WP) :: CDOTUI_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTUI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CDOTUI_F95 = F77_DOTUI(NZ,X,INDX,Y) -END FUNCTION CDOTUI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgbmv.F90 b/src/modules/BLAS95/src/blas95_src/cgbmv.F90 deleted file mode 100755 index 25da63315..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgbmv.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' - ! <<< Local scalars >>> - INTEGER :: O_KL - INTEGER :: O_M - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: KU - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - IF(PRESENT(KL)) THEN - O_KL = KL - ELSE - O_KL = (LDA-1)/2 - ENDIF - IF(PRESENT(M)) THEN - O_M = M - ELSE - O_M = N - ENDIF - KU = LDA-O_KL-1 - ! <<< Call blas77 routine >>> - CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & - & INCY) -END SUBROUTINE CGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgem2vc.F90 b/src/modules/BLAS95/src/blas95_src/cgem2vc.F90 deleted file mode 100755 index 8380898fb..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgem2vc.F90 +++ /dev/null @@ -1,78 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! CGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEM2V - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X1(:) - COMPLEX(WP), INTENT(IN) :: X2(:) - COMPLEX(WP), INTENT(INOUT ) :: Y1(:) - COMPLEX(WP), INTENT(INOUT ) :: Y2(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX1 - INTEGER :: INCX2 - INTEGER :: INCY1 - INTEGER :: INCY2 - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - INCX1 = 1 - INCX2 = 1 - INCY1 = 1 - INCY2 = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & - & Y2,INCY2) -END SUBROUTINE CGEM2VC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm.F90 b/src/modules/BLAS95/src/blas95_src/cgemm.F90 deleted file mode 100755 index be0dc4db4..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgemm.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & - & LDC) -END SUBROUTINE CGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm3m.F90 b/src/modules/BLAS95/src/blas95_src/cgemm3m.F90 deleted file mode 100755 index 1c6d7770f..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgemm3m.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! CGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM3M - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=6), PARAMETER :: SRNAME = 'GEMM3M' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM3M(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA, & - & C,LDC) -END SUBROUTINE CGEMM3M_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 b/src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 deleted file mode 100755 index eee50d3a9..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 +++ /dev/null @@ -1,190 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE CGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,GROUP_SIZE,TRANSA_ARRAY,& - & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! CGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! BETA_ARRAY=Array of beta values; default: array where each element=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM3M_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=13), PARAMETER :: SRNAME = 'CGEMM3M_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) - COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) - COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - INTEGER, POINTER :: LDC_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(BETA_ARRAY)) THEN - O_BETA_ARRAY => BETA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_BETA_ARRAY(I) = 0 - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSB_ARRAY)) THEN - O_TRANSB_ARRAY => TRANSB_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSB_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & - & O_TRANSA_ARRAY(I).EQ.'n')) THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & - & O_TRANSB_ARRAY(I).EQ.'n')) THEN - LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) - ELSE - LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_GEMM3M_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & - & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(BETA_ARRAY)) THEN - IF (ASSOCIATED(O_BETA_ARRAY)) THEN - DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN - DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDC_ARRAY)) THEN - DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE CGEMM3M_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 deleted file mode 100755 index 96901c0b1..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 +++ /dev/null @@ -1,190 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE CGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& - & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & - & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! CGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! BETA_ARRAY=Array of beta values; default: array where each element=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'CGEMM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) - COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) - COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - INTEGER, POINTER :: LDC_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(BETA_ARRAY)) THEN - O_BETA_ARRAY => BETA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_BETA_ARRAY(I) = 0 - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSB_ARRAY)) THEN - O_TRANSB_ARRAY => TRANSB_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSB_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & - & O_TRANSA_ARRAY(I).EQ.'n')) THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & - & O_TRANSB_ARRAY(I).EQ.'n')) THEN - LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) - ELSE - LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & - & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(BETA_ARRAY)) THEN - IF (ASSOCIATED(O_BETA_ARRAY)) THEN - DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN - DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDC_ARRAY)) THEN - DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE CGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemmt.F90 b/src/modules/BLAS95/src/blas95_src/cgemmt.F90 deleted file mode 100755 index 799b5204b..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgemmt.F90 +++ /dev/null @@ -1,100 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMMT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & - & O_BETA,C,LDC) -END SUBROUTINE CGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemv.F90 b/src/modules/BLAS95/src/blas95_src/cgemv.F90 deleted file mode 100755 index 87077117f..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgemv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE CGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgerc.F90 b/src/modules/BLAS95/src/blas95_src/cgerc.F90 deleted file mode 100755 index aaaa26be0..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgerc.F90 +++ /dev/null @@ -1,63 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGERC_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GERC - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERC' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GERC(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE CGERC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgeru.F90 b/src/modules/BLAS95/src/blas95_src/cgeru.F90 deleted file mode 100755 index 1bea60d6f..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgeru.F90 +++ /dev/null @@ -1,63 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGERU_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GERU - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERU' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GERU(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE CGERU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgthr.F90 b/src/modules/BLAS95/src/blas95_src/cgthr.F90 deleted file mode 100755 index 9d7a3242c..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgthr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! CGTHR(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHR(NZ,Y,X,INDX) -END SUBROUTINE CGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgthrz.F90 b/src/modules/BLAS95/src/blas95_src/cgthrz.F90 deleted file mode 100755 index f330f11db..000000000 --- a/src/modules/BLAS95/src/blas95_src/cgthrz.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! CGTHRZ(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHRZ - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHRZ(NZ,Y,X,INDX) -END SUBROUTINE CGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chbmv.F90 b/src/modules/BLAS95/src/blas95_src/chbmv.F90 deleted file mode 100755 index a144bca40..000000000 --- a/src/modules/BLAS95/src/blas95_src/chbmv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE CHBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chemm.F90 b/src/modules/BLAS95/src/blas95_src/chemm.F90 deleted file mode 100755 index cf0df5b6d..000000000 --- a/src/modules/BLAS95/src/blas95_src/chemm.F90 +++ /dev/null @@ -1,87 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_HEMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE CHEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chemv.F90 b/src/modules/BLAS95/src/blas95_src/chemv.F90 deleted file mode 100755 index 15d05d47b..000000000 --- a/src/modules/BLAS95/src/blas95_src/chemv.F90 +++ /dev/null @@ -1,77 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HEMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE CHEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cher.F90 b/src/modules/BLAS95/src/blas95_src/cher.F90 deleted file mode 100755 index 3c210a5e1..000000000 --- a/src/modules/BLAS95/src/blas95_src/cher.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHER_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! CHER(UPLO,N,ALPHA,X,INCX,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HER - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HER' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HER(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) -END SUBROUTINE CHER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cher2.F90 b/src/modules/BLAS95/src/blas95_src/cher2.F90 deleted file mode 100755 index 843eb096d..000000000 --- a/src/modules/BLAS95/src/blas95_src/cher2.F90 +++ /dev/null @@ -1,69 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHER2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HER2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HER2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HER2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE CHER2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cher2k.F90 b/src/modules/BLAS95/src/blas95_src/cher2k.F90 deleted file mode 100755 index 979ad7d7c..000000000 --- a/src/modules/BLAS95/src/blas95_src/cher2k.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HER2K - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'HER2K' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - COMPLEX(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_HER2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE CHER2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cherk.F90 b/src/modules/BLAS95/src/blas95_src/cherk.F90 deleted file mode 100755 index 9f022d779..000000000 --- a/src/modules/BLAS95/src/blas95_src/cherk.F90 +++ /dev/null @@ -1,88 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HERK - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HERK' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_HERK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) -END SUBROUTINE CHERK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chpmv.F90 b/src/modules/BLAS95/src/blas95_src/chpmv.F90 deleted file mode 100755 index 4028fc6bd..000000000 --- a/src/modules/BLAS95/src/blas95_src/chpmv.F90 +++ /dev/null @@ -1,75 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_HPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE CHPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chpr.F90 b/src/modules/BLAS95/src/blas95_src/chpr.F90 deleted file mode 100755 index 3c4a0aa4c..000000000 --- a/src/modules/BLAS95/src/blas95_src/chpr.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! CHPR(UPLO,N,ALPHA,X,INCX,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HPR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HPR' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_HPR(O_UPLO,N,O_ALPHA,X,INCX,AP) -END SUBROUTINE CHPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chpr2.F90 b/src/modules/BLAS95/src/blas95_src/chpr2.F90 deleted file mode 100755 index 6923f3b33..000000000 --- a/src/modules/BLAS95/src/blas95_src/chpr2.F90 +++ /dev/null @@ -1,67 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CHPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HPR2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPR2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_HPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) -END SUBROUTINE CHPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/crotg.F90 b/src/modules/BLAS95/src/blas95_src/crotg.F90 deleted file mode 100755 index cc5f5c3c2..000000000 --- a/src/modules/BLAS95/src/blas95_src/crotg.F90 +++ /dev/null @@ -1,40 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE CROTG_F95(A,B,C,S) - ! Fortran77 call: - ! CROTG(A,B,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTG - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A - COMPLEX(WP), INTENT(INOUT ) :: B - REAL(WP), INTENT(OUT) :: C - COMPLEX(WP), INTENT(OUT) :: S - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' - ! <<< Local scalars >>> - ! <<< Executable statements >>> - ! <<< Call blas77 routine >>> - CALL F77_ROTG(A,B,C,S) -END SUBROUTINE CROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cscal.F90 b/src/modules/BLAS95/src/blas95_src/cscal.F90 deleted file mode 100755 index 24e06f0e8..000000000 --- a/src/modules/BLAS95/src/blas95_src/cscal.F90 +++ /dev/null @@ -1,48 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSCAL_F95(X,A) - ! Fortran77 call: - ! CSCAL(N,A,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCAL - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN) :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCAL(N,A,X,INCX) -END SUBROUTINE CSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csctr.F90 b/src/modules/BLAS95/src/blas95_src/csctr.F90 deleted file mode 100755 index 55f6a9296..000000000 --- a/src/modules/BLAS95/src/blas95_src/csctr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! CSCTR(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCTR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(OUT) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCTR(NZ,X,INDX,Y) -END SUBROUTINE CSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csrot.F90 b/src/modules/BLAS95/src/blas95_src/csrot.F90 deleted file mode 100755 index 18170df7d..000000000 --- a/src/modules/BLAS95/src/blas95_src/csrot.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSROT_F95(X,Y,C,S) - ! Fortran77 call: - ! CSROT(N,X,INCX,Y,INCY,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROT(N,X,INCX,Y,INCY,C,S) -END SUBROUTINE CSROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csscal.F90 b/src/modules/BLAS95/src/blas95_src/csscal.F90 deleted file mode 100755 index 189d0447b..000000000 --- a/src/modules/BLAS95/src/blas95_src/csscal.F90 +++ /dev/null @@ -1,48 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSSCAL_F95(X,A) - ! Fortran77 call: - ! CSSCAL(N,A,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCAL - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCAL(N,A,X,INCX) -END SUBROUTINE CSSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cswap.F90 b/src/modules/BLAS95/src/blas95_src/cswap.F90 deleted file mode 100755 index c53069dd8..000000000 --- a/src/modules/BLAS95/src/blas95_src/cswap.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSWAP_F95(X,Y) - ! Fortran77 call: - ! CSWAP(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SWAP - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SWAP(N,X,INCX,Y,INCY) -END SUBROUTINE CSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csymm.F90 b/src/modules/BLAS95/src/blas95_src/csymm.F90 deleted file mode 100755 index 7d1e59ef7..000000000 --- a/src/modules/BLAS95/src/blas95_src/csymm.F90 +++ /dev/null @@ -1,87 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE CSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csyr2k.F90 b/src/modules/BLAS95/src/blas95_src/csyr2k.F90 deleted file mode 100755 index ae2c0c5e0..000000000 --- a/src/modules/BLAS95/src/blas95_src/csyr2k.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR2K - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE CSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csyrk.F90 b/src/modules/BLAS95/src/blas95_src/csyrk.F90 deleted file mode 100755 index c67cc6657..000000000 --- a/src/modules/BLAS95/src/blas95_src/csyrk.F90 +++ /dev/null @@ -1,88 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYRK - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) -END SUBROUTINE CSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctbmv.F90 b/src/modules/BLAS95/src/blas95_src/ctbmv.F90 deleted file mode 100755 index 3c9dc65db..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctbmv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE CTBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctbsv.F90 b/src/modules/BLAS95/src/blas95_src/ctbsv.F90 deleted file mode 100755 index 956c8e068..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctbsv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE CTBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctpmv.F90 b/src/modules/BLAS95/src/blas95_src/ctpmv.F90 deleted file mode 100755 index e074ff8d7..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctpmv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE CTPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctpsv.F90 b/src/modules/BLAS95/src/blas95_src/ctpsv.F90 deleted file mode 100755 index 8618999cb..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctpsv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE CTPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrmm.F90 b/src/modules/BLAS95/src/blas95_src/ctrmm.F90 deleted file mode 100755 index 65480605c..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctrmm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - COMPLEX(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE CTRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrmv.F90 b/src/modules/BLAS95/src/blas95_src/ctrmv.F90 deleted file mode 100755 index 38f872cc0..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctrmv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE CTRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrsm.F90 b/src/modules/BLAS95/src/blas95_src/ctrsm.F90 deleted file mode 100755 index 67e399762..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctrsm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - COMPLEX(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE CTRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 deleted file mode 100755 index 76cd1c7c4..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 +++ /dev/null @@ -1,191 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE CTRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & - & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & - & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) - ! Fortran77 call: - ! CTRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! GROUP_COUNT,GROUP_SIZE) - ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' - ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! SIDE_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) - ! UPLO_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! DIAG_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'CTRSM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) - COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(SIDE_ARRAY)) THEN - O_SIDE_ARRAY => SIDE_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_SIDE_ARRAY(I) = 'L' - END DO - ENDIF - ENDIF - IF(PRESENT(UPLO_ARRAY)) THEN - O_UPLO_ARRAY => UPLO_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_UPLO_ARRAY(I) = 'U' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(DIAG_ARRAY)) THEN - O_DIAG_ARRAY => DIAG_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_DIAG_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF(O_SIDE_ARRAY(I).EQ.'L') THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & - & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & - & O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & - & GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(SIDE_ARRAY)) THEN - IF (ASSOCIATED(O_SIDE_ARRAY)) THEN - DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(UPLO_ARRAY)) THEN - IF (ASSOCIATED(O_UPLO_ARRAY)) THEN - DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(DIAG_ARRAY)) THEN - IF (ASSOCIATED(O_DIAG_ARRAY)) THEN - DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE CTRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrsv.F90 b/src/modules/BLAS95/src/blas95_src/ctrsv.F90 deleted file mode 100755 index 72518dbea..000000000 --- a/src/modules/BLAS95/src/blas95_src/ctrsv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE CTRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE CTRSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dasum.F90 b/src/modules/BLAS95/src/blas95_src/dasum.F90 deleted file mode 100755 index 00a7602ff..000000000 --- a/src/modules/BLAS95/src/blas95_src/dasum.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION DASUM_F95(X) - ! Fortran77 call: - ! DASUM(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ASUM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DASUM_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - DASUM_F95 = F77_ASUM(N,X,INCX) -END FUNCTION DASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/daxpby.F90 b/src/modules/BLAS95/src/blas95_src/daxpby.F90 deleted file mode 100755 index 24f25c173..000000000 --- a/src/modules/BLAS95/src/blas95_src/daxpby.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! DAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - ! Default ALPHA=1 - ! Default BETA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPBY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE DAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/daxpy.F90 b/src/modules/BLAS95/src/blas95_src/daxpy.F90 deleted file mode 100755 index d4d6b51ec..000000000 --- a/src/modules/BLAS95/src/blas95_src/daxpy.F90 +++ /dev/null @@ -1,58 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DAXPY_F95(X,Y,A) - ! Fortran77 call: - ! DAXPY(N,A,X,INCX,Y,INCY) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' - ! <<< Local scalars >>> - REAL(WP) :: O_A - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) -END SUBROUTINE DAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/daxpyi.F90 b/src/modules/BLAS95/src/blas95_src/daxpyi.F90 deleted file mode 100755 index 8e124ba24..000000000 --- a/src/modules/BLAS95/src/blas95_src/daxpyi.F90 +++ /dev/null @@ -1,55 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! DAXPYI(NZ,A,X,INDX,Y) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPYI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' - ! <<< Local scalars >>> - REAL(WP) :: O_A - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPYI(NZ,O_A,X,INDX,Y) -END SUBROUTINE DAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dcabs1.F90 b/src/modules/BLAS95/src/blas95_src/dcabs1.F90 deleted file mode 100755 index 6d0974ec6..000000000 --- a/src/modules/BLAS95/src/blas95_src/dcabs1.F90 +++ /dev/null @@ -1,37 +0,0 @@ -!=============================================================================== -! Copyright 2015-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE FUNCTION DCABS1_F95(Z) - ! Fortran77 call: - ! DCABS(Z) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_CABS1 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DCABS1_F95 - ! <<< Arguments >>> - COMPLEX(WP), INTENT(IN) :: Z - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'CABS1' - ! <<< Executable statements >>> - ! <<< Call blas77 routine >>> - DCABS1_F95 = F77_CABS1(Z) -END FUNCTION DCABS1_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dcopy.F90 b/src/modules/BLAS95/src/blas95_src/dcopy.F90 deleted file mode 100755 index e4b3a49d4..000000000 --- a/src/modules/BLAS95/src/blas95_src/dcopy.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DCOPY_F95(X,Y) - ! Fortran77 call: - ! DCOPY(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_COPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_COPY(N,X,INCX,Y,INCY) -END SUBROUTINE DCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ddot.F90 b/src/modules/BLAS95/src/blas95_src/ddot.F90 deleted file mode 100755 index 84e1147c9..000000000 --- a/src/modules/BLAS95/src/blas95_src/ddot.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION DDOT_F95(X,Y) - ! Fortran77 call: - ! DDOT(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DDOT_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'DOT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - DDOT_F95 = F77_DOT(N,X,INCX,Y,INCY) -END FUNCTION DDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ddoti.F90 b/src/modules/BLAS95/src/blas95_src/ddoti.F90 deleted file mode 100755 index a910d9d77..000000000 --- a/src/modules/BLAS95/src/blas95_src/ddoti.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION DDOTI_F95(X,INDX,Y) - ! Fortran77 call: - ! DDOTI(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DDOTI_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - DDOTI_F95 = F77_DOTI(NZ,X,INDX,Y) -END FUNCTION DDOTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgbmv.F90 b/src/modules/BLAS95/src/blas95_src/dgbmv.F90 deleted file mode 100755 index 57ae73720..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgbmv.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' - ! <<< Local scalars >>> - INTEGER :: O_KL - INTEGER :: O_M - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: KU - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - IF(PRESENT(KL)) THEN - O_KL = KL - ELSE - O_KL = (LDA-1)/2 - ENDIF - IF(PRESENT(M)) THEN - O_M = M - ELSE - O_M = N - ENDIF - KU = LDA-O_KL-1 - ! <<< Call blas77 routine >>> - CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & - & INCY) -END SUBROUTINE DGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgem2vu.F90 b/src/modules/BLAS95/src/blas95_src/dgem2vu.F90 deleted file mode 100755 index bc32df5ad..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgem2vu.F90 +++ /dev/null @@ -1,78 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! DGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEM2V - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X1(:) - REAL(WP), INTENT(IN) :: X2(:) - REAL(WP), INTENT(INOUT ) :: Y1(:) - REAL(WP), INTENT(INOUT ) :: Y2(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX1 - INTEGER :: INCX2 - INTEGER :: INCY1 - INTEGER :: INCY2 - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - INCX1 = 1 - INCX2 = 1 - INCY1 = 1 - INCY2 = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & - & Y2,INCY2) -END SUBROUTINE DGEM2VU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemm.F90 b/src/modules/BLAS95/src/blas95_src/dgemm.F90 deleted file mode 100755 index 163162ec8..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgemm.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & - & LDC) -END SUBROUTINE DGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 deleted file mode 100755 index c342d12e5..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 +++ /dev/null @@ -1,190 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE DGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& - & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & - & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! DGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! BETA_ARRAY=Array of beta values; default: array where each element=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'DGEMM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) - REAL(WP), POINTER :: O_ALPHA_ARRAY(:) - REAL(WP), POINTER :: O_BETA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - INTEGER, POINTER :: LDC_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(BETA_ARRAY)) THEN - O_BETA_ARRAY => BETA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_BETA_ARRAY(I) = 0 - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSB_ARRAY)) THEN - O_TRANSB_ARRAY => TRANSB_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSB_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & - & O_TRANSA_ARRAY(I).EQ.'n')) THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & - & O_TRANSB_ARRAY(I).EQ.'n')) THEN - LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) - ELSE - LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & - & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(BETA_ARRAY)) THEN - IF (ASSOCIATED(O_BETA_ARRAY)) THEN - DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN - DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDC_ARRAY)) THEN - DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE DGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemmt.F90 b/src/modules/BLAS95/src/blas95_src/dgemmt.F90 deleted file mode 100755 index 365fd419d..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgemmt.F90 +++ /dev/null @@ -1,100 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMMT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & - & O_BETA,C,LDC) -END SUBROUTINE DGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemv.F90 b/src/modules/BLAS95/src/blas95_src/dgemv.F90 deleted file mode 100755 index ec4deb720..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgemv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE DGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dger.F90 b/src/modules/BLAS95/src/blas95_src/dger.F90 deleted file mode 100755 index ad23ef5a4..000000000 --- a/src/modules/BLAS95/src/blas95_src/dger.F90 +++ /dev/null @@ -1,63 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGER_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GER - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'GER' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GER(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE DGER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgthr.F90 b/src/modules/BLAS95/src/blas95_src/dgthr.F90 deleted file mode 100755 index 43400c968..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgthr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! DGTHR(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHR(NZ,Y,X,INDX) -END SUBROUTINE DGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgthrz.F90 b/src/modules/BLAS95/src/blas95_src/dgthrz.F90 deleted file mode 100755 index 951baebdc..000000000 --- a/src/modules/BLAS95/src/blas95_src/dgthrz.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! DGTHRZ(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHRZ - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHRZ(NZ,Y,X,INDX) -END SUBROUTINE DGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dnrm2.F90 b/src/modules/BLAS95/src/blas95_src/dnrm2.F90 deleted file mode 100755 index bd2cbedb9..000000000 --- a/src/modules/BLAS95/src/blas95_src/dnrm2.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION DNRM2_F95(X) - ! Fortran77 call: - ! DNRM2(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_NRM2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DNRM2_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - DNRM2_F95 = F77_NRM2(N,X,INCX) -END FUNCTION DNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drot.F90 b/src/modules/BLAS95/src/blas95_src/drot.F90 deleted file mode 100755 index 0688293f9..000000000 --- a/src/modules/BLAS95/src/blas95_src/drot.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DROT_F95(X,Y,C,S) - ! Fortran77 call: - ! DROT(N,X,INCX,Y,INCY,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROT(N,X,INCX,Y,INCY,C,S) -END SUBROUTINE DROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drotg.F90 b/src/modules/BLAS95/src/blas95_src/drotg.F90 deleted file mode 100755 index 5ad503350..000000000 --- a/src/modules/BLAS95/src/blas95_src/drotg.F90 +++ /dev/null @@ -1,40 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE DROTG_F95(A,B,C,S) - ! Fortran77 call: - ! DROTG(A,B,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTG - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(INOUT ) :: A - REAL(WP), INTENT(INOUT ) :: B - REAL(WP), INTENT(OUT) :: C - REAL(WP), INTENT(OUT) :: S - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' - ! <<< Local scalars >>> - ! <<< Executable statements >>> - ! <<< Call blas77 routine >>> - CALL F77_ROTG(A,B,C,S) -END SUBROUTINE DROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/droti.F90 b/src/modules/BLAS95/src/blas95_src/droti.F90 deleted file mode 100755 index 4e47910ab..000000000 --- a/src/modules/BLAS95/src/blas95_src/droti.F90 +++ /dev/null @@ -1,51 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DROTI_F95(X,INDX,Y,C,S) - ! Fortran77 call: - ! DROTI(NZ,X,INDX,Y,C,S) - ! Default C=1 - ! Default S=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROTI(NZ,X,INDX,Y,C,S) -END SUBROUTINE DROTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drotm.F90 b/src/modules/BLAS95/src/blas95_src/drotm.F90 deleted file mode 100755 index 03a1034fa..000000000 --- a/src/modules/BLAS95/src/blas95_src/drotm.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DROTM_F95(X,Y,PARAM) - ! Fortran77 call: - ! DROTM(N,X,INCX,Y,INCY,PARAM) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - REAL(WP), INTENT(IN) :: PARAM(5) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTM' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROTM(N,X,INCX,Y,INCY,PARAM) -END SUBROUTINE DROTM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drotmg.F90 b/src/modules/BLAS95/src/blas95_src/drotmg.F90 deleted file mode 100755 index d23635e49..000000000 --- a/src/modules/BLAS95/src/blas95_src/drotmg.F90 +++ /dev/null @@ -1,45 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DROTMG_F95(D1,D2,X1,Y1,PARAM) - ! Fortran77 call: - ! DROTMG(D1,D2,X1,Y1,PARAM) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTMG - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(INOUT ) :: D1 - REAL(WP), INTENT(INOUT ) :: D2 - REAL(WP), INTENT(INOUT ) :: X1 - REAL(WP), INTENT(IN) :: Y1 - ! <<< Array arguments >>> - REAL(WP), INTENT(OUT) :: PARAM(5) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'ROTMG' - ! <<< Local scalars >>> - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - ! <<< Call blas77 routine >>> - CALL F77_ROTMG(D1,D2,X1,Y1,PARAM) -END SUBROUTINE DROTMG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsbmv.F90 b/src/modules/BLAS95/src/blas95_src/dsbmv.F90 deleted file mode 100755 index 89aacd433..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsbmv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE DSBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dscal.F90 b/src/modules/BLAS95/src/blas95_src/dscal.F90 deleted file mode 100755 index 88d0c333a..000000000 --- a/src/modules/BLAS95/src/blas95_src/dscal.F90 +++ /dev/null @@ -1,48 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSCAL_F95(X,A) - ! Fortran77 call: - ! DSCAL(N,A,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCAL - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: A - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCAL(N,A,X,INCX) -END SUBROUTINE DSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsctr.F90 b/src/modules/BLAS95/src/blas95_src/dsctr.F90 deleted file mode 100755 index 7152b0e7d..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsctr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! DSCTR(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCTR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(OUT) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCTR(NZ,X,INDX,Y) -END SUBROUTINE DSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsdot.F90 b/src/modules/BLAS95/src/blas95_src/dsdot.F90 deleted file mode 100755 index c97267bf7..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsdot.F90 +++ /dev/null @@ -1,51 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION DSDOT_F95(SX,SY) - ! Fortran77 call: - ! DSDOT(N,SX,INCX,SY,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SDOT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER, PARAMETER :: SP = KIND(1.0E0) - REAL(WP) :: DSDOT_F95 - ! <<< Array arguments >>> - REAL(SP), INTENT(IN) :: SX(:) - REAL(SP), INTENT(IN) :: SY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SDOT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(SX) - ! <<< Call blas77 routine >>> - DSDOT_F95 = F77_SDOT(N,SX,INCX,SY,INCY) -END FUNCTION DSDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dspmv.F90 b/src/modules/BLAS95/src/blas95_src/dspmv.F90 deleted file mode 100755 index eb7991b84..000000000 --- a/src/modules/BLAS95/src/blas95_src/dspmv.F90 +++ /dev/null @@ -1,75 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE DSPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dspr.F90 b/src/modules/BLAS95/src/blas95_src/dspr.F90 deleted file mode 100755 index ee7efbca4..000000000 --- a/src/modules/BLAS95/src/blas95_src/dspr.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! DSPR(UPLO,N,ALPHA,X,INCX,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SPR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SPR' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SPR(O_UPLO,N,O_ALPHA,X,INCX,AP) -END SUBROUTINE DSPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dspr2.F90 b/src/modules/BLAS95/src/blas95_src/dspr2.F90 deleted file mode 100755 index 426968482..000000000 --- a/src/modules/BLAS95/src/blas95_src/dspr2.F90 +++ /dev/null @@ -1,67 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SPR2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPR2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) -END SUBROUTINE DSPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dswap.F90 b/src/modules/BLAS95/src/blas95_src/dswap.F90 deleted file mode 100755 index a87adf606..000000000 --- a/src/modules/BLAS95/src/blas95_src/dswap.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSWAP_F95(X,Y) - ! Fortran77 call: - ! DSWAP(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SWAP - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SWAP(N,X,INCX,Y,INCY) -END SUBROUTINE DSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsymm.F90 b/src/modules/BLAS95/src/blas95_src/dsymm.F90 deleted file mode 100755 index a568a18b4..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsymm.F90 +++ /dev/null @@ -1,87 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE DSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsymv.F90 b/src/modules/BLAS95/src/blas95_src/dsymv.F90 deleted file mode 100755 index 94ab9b413..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsymv.F90 +++ /dev/null @@ -1,77 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_SYMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE DSYMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyr.F90 b/src/modules/BLAS95/src/blas95_src/dsyr.F90 deleted file mode 100755 index 693010a75..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsyr.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSYR_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SYR' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) -END SUBROUTINE DSYR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyr2.F90 b/src/modules/BLAS95/src/blas95_src/dsyr2.F90 deleted file mode 100755 index 8c34bb3b5..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsyr2.F90 +++ /dev/null @@ -1,69 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSYR2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYR2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE DSYR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyr2k.F90 b/src/modules/BLAS95/src/blas95_src/dsyr2k.F90 deleted file mode 100755 index 8089ba316..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsyr2k.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR2K - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE DSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyrk.F90 b/src/modules/BLAS95/src/blas95_src/dsyrk.F90 deleted file mode 100755 index b4320c22e..000000000 --- a/src/modules/BLAS95/src/blas95_src/dsyrk.F90 +++ /dev/null @@ -1,88 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYRK - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) -END SUBROUTINE DSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtbmv.F90 b/src/modules/BLAS95/src/blas95_src/dtbmv.F90 deleted file mode 100755 index cd5f05270..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtbmv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE DTBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtbsv.F90 b/src/modules/BLAS95/src/blas95_src/dtbsv.F90 deleted file mode 100755 index 34a706679..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtbsv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE DTBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtpmv.F90 b/src/modules/BLAS95/src/blas95_src/dtpmv.F90 deleted file mode 100755 index dc8ad0775..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtpmv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE DTPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtpsv.F90 b/src/modules/BLAS95/src/blas95_src/dtpsv.F90 deleted file mode 100755 index 2ae69a85d..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtpsv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE DTPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrmm.F90 b/src/modules/BLAS95/src/blas95_src/dtrmm.F90 deleted file mode 100755 index 72237d63d..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtrmm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - REAL(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE DTRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrmv.F90 b/src/modules/BLAS95/src/blas95_src/dtrmv.F90 deleted file mode 100755 index 1f50d20bf..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtrmv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE DTRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrsm.F90 b/src/modules/BLAS95/src/blas95_src/dtrsm.F90 deleted file mode 100755 index 2dfb9406d..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtrsm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - REAL(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE DTRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 deleted file mode 100755 index 32c03b120..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 +++ /dev/null @@ -1,191 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE DTRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & - & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & - & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) - ! Fortran77 call: - ! DTRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! GROUP_COUNT,GROUP_SIZE) - ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' - ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! SIDE_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) - ! UPLO_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! DIAG_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'DTRSM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) - REAL(WP), POINTER :: O_ALPHA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(SIDE_ARRAY)) THEN - O_SIDE_ARRAY => SIDE_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_SIDE_ARRAY(I) = 'L' - END DO - ENDIF - ENDIF - IF(PRESENT(UPLO_ARRAY)) THEN - O_UPLO_ARRAY => UPLO_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_UPLO_ARRAY(I) = 'U' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(DIAG_ARRAY)) THEN - O_DIAG_ARRAY => DIAG_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_DIAG_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF(O_SIDE_ARRAY(I).EQ.'L') THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & - & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & - & O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & - & GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(SIDE_ARRAY)) THEN - IF (ASSOCIATED(O_SIDE_ARRAY)) THEN - DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(UPLO_ARRAY)) THEN - IF (ASSOCIATED(O_UPLO_ARRAY)) THEN - DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(DIAG_ARRAY)) THEN - IF (ASSOCIATED(O_DIAG_ARRAY)) THEN - DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE DTRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrsv.F90 b/src/modules/BLAS95/src/blas95_src/dtrsv.F90 deleted file mode 100755 index aa8396132..000000000 --- a/src/modules/BLAS95/src/blas95_src/dtrsv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DTRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE DTRSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dzasum.F90 b/src/modules/BLAS95/src/blas95_src/dzasum.F90 deleted file mode 100755 index ded9b3c0e..000000000 --- a/src/modules/BLAS95/src/blas95_src/dzasum.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION DZASUM_F95(X) - ! Fortran77 call: - ! DZASUM(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ASUM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DZASUM_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - DZASUM_F95 = F77_ASUM(N,X,INCX) -END FUNCTION DZASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dzgemm.F90 b/src/modules/BLAS95/src/blas95_src/dzgemm.F90 deleted file mode 100755 index 7eef1fede..000000000 --- a/src/modules/BLAS95/src/blas95_src/dzgemm.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! DZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & - & LDC) -END SUBROUTINE DZGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dzgemv.F90 b/src/modules/BLAS95/src/blas95_src/dzgemv.F90 deleted file mode 100755 index 41a1de187..000000000 --- a/src/modules/BLAS95/src/blas95_src/dzgemv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE DZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! DZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE DZGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dznrm2.F90 b/src/modules/BLAS95/src/blas95_src/dznrm2.F90 deleted file mode 100755 index 37fa0f4dc..000000000 --- a/src/modules/BLAS95/src/blas95_src/dznrm2.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION DZNRM2_F95(X) - ! Fortran77 call: - ! DZNRM2(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_NRM2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - REAL(WP) :: DZNRM2_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - DZNRM2_F95 = F77_NRM2(N,X,INCX) -END FUNCTION DZNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/icamax.F90 b/src/modules/BLAS95/src/blas95_src/icamax.F90 deleted file mode 100755 index 7897bdfdd..000000000 --- a/src/modules/BLAS95/src/blas95_src/icamax.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ICAMAX_F95(X) - ! Fortran77 call: - ! ICAMAX(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMAX - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ICAMAX_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - ICAMAX_F95 = F77_IAMAX(N,X,INCX) -END FUNCTION ICAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/icamin.F90 b/src/modules/BLAS95/src/blas95_src/icamin.F90 deleted file mode 100755 index d5e29da81..000000000 --- a/src/modules/BLAS95/src/blas95_src/icamin.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ICAMIN_F95(X) - ! Fortran77 call: - ! ICAMIN(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMIN - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ICAMIN_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - ICAMIN_F95 = F77_IAMIN(N,X,INCX) -END FUNCTION ICAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/idamax.F90 b/src/modules/BLAS95/src/blas95_src/idamax.F90 deleted file mode 100755 index f19045683..000000000 --- a/src/modules/BLAS95/src/blas95_src/idamax.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION IDAMAX_F95(X) - ! Fortran77 call: - ! IDAMAX(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMAX - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IDAMAX_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - IDAMAX_F95 = F77_IAMAX(N,X,INCX) -END FUNCTION IDAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/idamin.F90 b/src/modules/BLAS95/src/blas95_src/idamin.F90 deleted file mode 100755 index ee903a516..000000000 --- a/src/modules/BLAS95/src/blas95_src/idamin.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION IDAMIN_F95(X) - ! Fortran77 call: - ! IDAMIN(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMIN - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IDAMIN_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - IDAMIN_F95 = F77_IAMIN(N,X,INCX) -END FUNCTION IDAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/isamax.F90 b/src/modules/BLAS95/src/blas95_src/isamax.F90 deleted file mode 100755 index 8e6e62d8b..000000000 --- a/src/modules/BLAS95/src/blas95_src/isamax.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ISAMAX_F95(X) - ! Fortran77 call: - ! ISAMAX(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMAX - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ISAMAX_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - ISAMAX_F95 = F77_IAMAX(N,X,INCX) -END FUNCTION ISAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/isamin.F90 b/src/modules/BLAS95/src/blas95_src/isamin.F90 deleted file mode 100755 index 72c17d539..000000000 --- a/src/modules/BLAS95/src/blas95_src/isamin.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ISAMIN_F95(X) - ! Fortran77 call: - ! ISAMIN(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMIN - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - INTEGER :: ISAMIN_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - ISAMIN_F95 = F77_IAMIN(N,X,INCX) -END FUNCTION ISAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/izamax.F90 b/src/modules/BLAS95/src/blas95_src/izamax.F90 deleted file mode 100755 index 225099639..000000000 --- a/src/modules/BLAS95/src/blas95_src/izamax.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION IZAMAX_F95(X) - ! Fortran77 call: - ! IZAMAX(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMAX - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IZAMAX_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - IZAMAX_F95 = F77_IAMAX(N,X,INCX) -END FUNCTION IZAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/izamin.F90 b/src/modules/BLAS95/src/blas95_src/izamin.F90 deleted file mode 100755 index d6ddcf1c7..000000000 --- a/src/modules/BLAS95/src/blas95_src/izamin.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION IZAMIN_F95(X) - ! Fortran77 call: - ! IZAMIN(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_IAMIN - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - INTEGER :: IZAMIN_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - IZAMIN_F95 = F77_IAMIN(N,X,INCX) -END FUNCTION IZAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sasum.F90 b/src/modules/BLAS95/src/blas95_src/sasum.F90 deleted file mode 100755 index 7e22c3c74..000000000 --- a/src/modules/BLAS95/src/blas95_src/sasum.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION SASUM_F95(X) - ! Fortran77 call: - ! SASUM(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ASUM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SASUM_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - SASUM_F95 = F77_ASUM(N,X,INCX) -END FUNCTION SASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/saxpby.F90 b/src/modules/BLAS95/src/blas95_src/saxpby.F90 deleted file mode 100755 index 9b58d7c31..000000000 --- a/src/modules/BLAS95/src/blas95_src/saxpby.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! SAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - ! Default ALPHA=1 - ! Default BETA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPBY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE SAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/saxpy.F90 b/src/modules/BLAS95/src/blas95_src/saxpy.F90 deleted file mode 100755 index b9c740284..000000000 --- a/src/modules/BLAS95/src/blas95_src/saxpy.F90 +++ /dev/null @@ -1,58 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SAXPY_F95(X,Y,A) - ! Fortran77 call: - ! SAXPY(N,A,X,INCX,Y,INCY) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' - ! <<< Local scalars >>> - REAL(WP) :: O_A - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) -END SUBROUTINE SAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/saxpyi.F90 b/src/modules/BLAS95/src/blas95_src/saxpyi.F90 deleted file mode 100755 index 23845d822..000000000 --- a/src/modules/BLAS95/src/blas95_src/saxpyi.F90 +++ /dev/null @@ -1,55 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! SAXPYI(NZ,A,X,INDX,Y) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPYI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' - ! <<< Local scalars >>> - REAL(WP) :: O_A - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPYI(NZ,O_A,X,INDX,Y) -END SUBROUTINE SAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scabs1.F90 b/src/modules/BLAS95/src/blas95_src/scabs1.F90 deleted file mode 100755 index 2cc362070..000000000 --- a/src/modules/BLAS95/src/blas95_src/scabs1.F90 +++ /dev/null @@ -1,37 +0,0 @@ -!=============================================================================== -! Copyright 2015-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE FUNCTION SCABS1_F95(Z) - ! Fortran77 call: - ! SCABS(Z) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_CABS1 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SCABS1_F95 - ! <<< Arguments >>> - COMPLEX(WP), INTENT(IN) :: Z - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'CABS1' - ! <<< Executable statements >>> - ! <<< Call blas77 routine >>> - SCABS1_F95 = F77_CABS1(Z) -END FUNCTION SCABS1_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scasum.F90 b/src/modules/BLAS95/src/blas95_src/scasum.F90 deleted file mode 100755 index f0bcebad9..000000000 --- a/src/modules/BLAS95/src/blas95_src/scasum.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION SCASUM_F95(X) - ! Fortran77 call: - ! SCASUM(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ASUM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SCASUM_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - SCASUM_F95 = F77_ASUM(N,X,INCX) -END FUNCTION SCASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scgemm.F90 b/src/modules/BLAS95/src/blas95_src/scgemm.F90 deleted file mode 100755 index d67e69b77..000000000 --- a/src/modules/BLAS95/src/blas95_src/scgemm.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SCGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! SCGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & - & LDC) -END SUBROUTINE SCGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scgemv.F90 b/src/modules/BLAS95/src/blas95_src/scgemv.F90 deleted file mode 100755 index 75f8c48e5..000000000 --- a/src/modules/BLAS95/src/blas95_src/scgemv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SCGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! SCGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE SCGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scnrm2.F90 b/src/modules/BLAS95/src/blas95_src/scnrm2.F90 deleted file mode 100755 index 5a868feae..000000000 --- a/src/modules/BLAS95/src/blas95_src/scnrm2.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION SCNRM2_F95(X) - ! Fortran77 call: - ! SCNRM2(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_NRM2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SCNRM2_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - SCNRM2_F95 = F77_NRM2(N,X,INCX) -END FUNCTION SCNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scopy.F90 b/src/modules/BLAS95/src/blas95_src/scopy.F90 deleted file mode 100755 index 658826f8b..000000000 --- a/src/modules/BLAS95/src/blas95_src/scopy.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SCOPY_F95(X,Y) - ! Fortran77 call: - ! SCOPY(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_COPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_COPY(N,X,INCX,Y,INCY) -END SUBROUTINE SCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sdot.F90 b/src/modules/BLAS95/src/blas95_src/sdot.F90 deleted file mode 100755 index c7dcd1694..000000000 --- a/src/modules/BLAS95/src/blas95_src/sdot.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION SDOT_F95(X,Y) - ! Fortran77 call: - ! SDOT(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SDOT_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'DOT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - SDOT_F95 = F77_DOT(N,X,INCX,Y,INCY) -END FUNCTION SDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sdoti.F90 b/src/modules/BLAS95/src/blas95_src/sdoti.F90 deleted file mode 100755 index 8ddf6f3fc..000000000 --- a/src/modules/BLAS95/src/blas95_src/sdoti.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION SDOTI_F95(X,INDX,Y) - ! Fortran77 call: - ! SDOTI(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SDOTI_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - SDOTI_F95 = F77_DOTI(NZ,X,INDX,Y) -END FUNCTION SDOTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sdsdot.F90 b/src/modules/BLAS95/src/blas95_src/sdsdot.F90 deleted file mode 100755 index 75f1108f2..000000000 --- a/src/modules/BLAS95/src/blas95_src/sdsdot.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION SDSDOT_F95(SX,SY,SB) - ! Fortran77 call: - ! SDSDOT(N,SB,SX,INCX,SY,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SDOT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SDSDOT_F95 - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: SB - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: SX(:) - REAL(WP), INTENT(IN) :: SY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SDOT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(SX) - ! <<< Call blas77 routine >>> - SDSDOT_F95 = F77_SDOT(N,SB,SX,INCX,SY,INCY) -END FUNCTION SDSDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgbmv.F90 b/src/modules/BLAS95/src/blas95_src/sgbmv.F90 deleted file mode 100755 index 743af1520..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgbmv.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' - ! <<< Local scalars >>> - INTEGER :: O_KL - INTEGER :: O_M - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: KU - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - IF(PRESENT(KL)) THEN - O_KL = KL - ELSE - O_KL = (LDA-1)/2 - ENDIF - IF(PRESENT(M)) THEN - O_M = M - ELSE - O_M = N - ENDIF - KU = LDA-O_KL-1 - ! <<< Call blas77 routine >>> - CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & - & INCY) -END SUBROUTINE SGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgem2vu.F90 b/src/modules/BLAS95/src/blas95_src/sgem2vu.F90 deleted file mode 100755 index a1464079c..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgem2vu.F90 +++ /dev/null @@ -1,78 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! SGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEM2V - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X1(:) - REAL(WP), INTENT(IN) :: X2(:) - REAL(WP), INTENT(INOUT ) :: Y1(:) - REAL(WP), INTENT(INOUT ) :: Y2(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX1 - INTEGER :: INCX2 - INTEGER :: INCY1 - INTEGER :: INCY2 - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - INCX1 = 1 - INCX2 = 1 - INCY1 = 1 - INCY2 = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & - & Y2,INCY2) -END SUBROUTINE SGEM2VU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemm.F90 b/src/modules/BLAS95/src/blas95_src/sgemm.F90 deleted file mode 100755 index e532f434d..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgemm.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & - & LDC) -END SUBROUTINE SGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 deleted file mode 100755 index 08fb37bcb..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 +++ /dev/null @@ -1,190 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE SGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& - & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & - & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! SGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! BETA_ARRAY=Array of beta values; default: array where each element=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'SGEMM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) - REAL(WP), POINTER :: O_ALPHA_ARRAY(:) - REAL(WP), POINTER :: O_BETA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - INTEGER, POINTER :: LDC_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(BETA_ARRAY)) THEN - O_BETA_ARRAY => BETA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_BETA_ARRAY(I) = 0 - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSB_ARRAY)) THEN - O_TRANSB_ARRAY => TRANSB_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSB_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & - & O_TRANSA_ARRAY(I).EQ.'n')) THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & - & O_TRANSB_ARRAY(I).EQ.'n')) THEN - LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) - ELSE - LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & - & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(BETA_ARRAY)) THEN - IF (ASSOCIATED(O_BETA_ARRAY)) THEN - DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN - DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDC_ARRAY)) THEN - DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE SGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemmt.F90 b/src/modules/BLAS95/src/blas95_src/sgemmt.F90 deleted file mode 100755 index 3e71e98fb..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgemmt.F90 +++ /dev/null @@ -1,100 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMMT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & - & O_BETA,C,LDC) -END SUBROUTINE SGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemv.F90 b/src/modules/BLAS95/src/blas95_src/sgemv.F90 deleted file mode 100755 index 9dd56a189..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgemv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE SGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sger.F90 b/src/modules/BLAS95/src/blas95_src/sger.F90 deleted file mode 100755 index b429e874f..000000000 --- a/src/modules/BLAS95/src/blas95_src/sger.F90 +++ /dev/null @@ -1,63 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGER_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GER - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'GER' - ! <<< Local scalars >>> - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GER(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE SGER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgthr.F90 b/src/modules/BLAS95/src/blas95_src/sgthr.F90 deleted file mode 100755 index bf960fdb7..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgthr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! SGTHR(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHR(NZ,Y,X,INDX) -END SUBROUTINE SGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgthrz.F90 b/src/modules/BLAS95/src/blas95_src/sgthrz.F90 deleted file mode 100755 index d640925e5..000000000 --- a/src/modules/BLAS95/src/blas95_src/sgthrz.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! SGTHRZ(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHRZ - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHRZ(NZ,Y,X,INDX) -END SUBROUTINE SGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/snrm2.F90 b/src/modules/BLAS95/src/blas95_src/snrm2.F90 deleted file mode 100755 index 0290f354c..000000000 --- a/src/modules/BLAS95/src/blas95_src/snrm2.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION SNRM2_F95(X) - ! Fortran77 call: - ! SNRM2(N,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_NRM2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - REAL(WP) :: SNRM2_F95 - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - SNRM2_F95 = F77_NRM2(N,X,INCX) -END FUNCTION SNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srot.F90 b/src/modules/BLAS95/src/blas95_src/srot.F90 deleted file mode 100755 index a2dde608a..000000000 --- a/src/modules/BLAS95/src/blas95_src/srot.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SROT_F95(X,Y,C,S) - ! Fortran77 call: - ! SROT(N,X,INCX,Y,INCY,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROT(N,X,INCX,Y,INCY,C,S) -END SUBROUTINE SROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srotg.F90 b/src/modules/BLAS95/src/blas95_src/srotg.F90 deleted file mode 100755 index 763ebaf4b..000000000 --- a/src/modules/BLAS95/src/blas95_src/srotg.F90 +++ /dev/null @@ -1,40 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE SROTG_F95(A,B,C,S) - ! Fortran77 call: - ! SROTG(A,B,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTG - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(INOUT ) :: A - REAL(WP), INTENT(INOUT ) :: B - REAL(WP), INTENT(OUT) :: C - REAL(WP), INTENT(OUT) :: S - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' - ! <<< Local scalars >>> - ! <<< Executable statements >>> - ! <<< Call blas77 routine >>> - CALL F77_ROTG(A,B,C,S) -END SUBROUTINE SROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sroti.F90 b/src/modules/BLAS95/src/blas95_src/sroti.F90 deleted file mode 100755 index 3d5dfa2d4..000000000 --- a/src/modules/BLAS95/src/blas95_src/sroti.F90 +++ /dev/null @@ -1,51 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SROTI_F95(X,INDX,Y,C,S) - ! Fortran77 call: - ! SROTI(NZ,X,INDX,Y,C,S) - ! Default C=1 - ! Default S=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROTI(NZ,X,INDX,Y,C,S) -END SUBROUTINE SROTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srotm.F90 b/src/modules/BLAS95/src/blas95_src/srotm.F90 deleted file mode 100755 index 1ff97a845..000000000 --- a/src/modules/BLAS95/src/blas95_src/srotm.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SROTM_F95(X,Y,PARAM) - ! Fortran77 call: - ! SROTM(N,X,INCX,Y,INCY,PARAM) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - REAL(WP), INTENT(IN) :: PARAM(5) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTM' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROTM(N,X,INCX,Y,INCY,PARAM) -END SUBROUTINE SROTM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srotmg.F90 b/src/modules/BLAS95/src/blas95_src/srotmg.F90 deleted file mode 100755 index b326e6a2a..000000000 --- a/src/modules/BLAS95/src/blas95_src/srotmg.F90 +++ /dev/null @@ -1,45 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SROTMG_F95(D1,D2,X1,Y1,PARAM) - ! Fortran77 call: - ! SROTMG(D1,D2,X1,Y1,PARAM) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTMG - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(INOUT ) :: D1 - REAL(WP), INTENT(INOUT ) :: D2 - REAL(WP), INTENT(INOUT ) :: X1 - REAL(WP), INTENT(IN) :: Y1 - ! <<< Array arguments >>> - REAL(WP), INTENT(OUT) :: PARAM(5) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'ROTMG' - ! <<< Local scalars >>> - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - ! <<< Call blas77 routine >>> - CALL F77_ROTMG(D1,D2,X1,Y1,PARAM) -END SUBROUTINE SROTMG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssbmv.F90 b/src/modules/BLAS95/src/blas95_src/ssbmv.F90 deleted file mode 100755 index b350f2a2e..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssbmv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE SSBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sscal.F90 b/src/modules/BLAS95/src/blas95_src/sscal.F90 deleted file mode 100755 index 5efbcc568..000000000 --- a/src/modules/BLAS95/src/blas95_src/sscal.F90 +++ /dev/null @@ -1,48 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSCAL_F95(X,A) - ! Fortran77 call: - ! SSCAL(N,A,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCAL - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: A - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCAL(N,A,X,INCX) -END SUBROUTINE SSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssctr.F90 b/src/modules/BLAS95/src/blas95_src/ssctr.F90 deleted file mode 100755 index 0bd1409e6..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssctr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! SSCTR(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCTR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(OUT) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCTR(NZ,X,INDX,Y) -END SUBROUTINE SSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sspmv.F90 b/src/modules/BLAS95/src/blas95_src/sspmv.F90 deleted file mode 100755 index 7690e62d2..000000000 --- a/src/modules/BLAS95/src/blas95_src/sspmv.F90 +++ /dev/null @@ -1,75 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE SSPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sspr.F90 b/src/modules/BLAS95/src/blas95_src/sspr.F90 deleted file mode 100755 index 102b8a9de..000000000 --- a/src/modules/BLAS95/src/blas95_src/sspr.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! SSPR(UPLO,N,ALPHA,X,INCX,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SPR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SPR' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SPR(O_UPLO,N,O_ALPHA,X,INCX,AP) -END SUBROUTINE SSPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sspr2.F90 b/src/modules/BLAS95/src/blas95_src/sspr2.F90 deleted file mode 100755 index 80ab84103..000000000 --- a/src/modules/BLAS95/src/blas95_src/sspr2.F90 +++ /dev/null @@ -1,67 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SPR2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPR2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) -END SUBROUTINE SSPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sswap.F90 b/src/modules/BLAS95/src/blas95_src/sswap.F90 deleted file mode 100755 index 84e69ee20..000000000 --- a/src/modules/BLAS95/src/blas95_src/sswap.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSWAP_F95(X,Y) - ! Fortran77 call: - ! SSWAP(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SWAP - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SWAP(N,X,INCX,Y,INCY) -END SUBROUTINE SSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssymm.F90 b/src/modules/BLAS95/src/blas95_src/ssymm.F90 deleted file mode 100755 index 417091a79..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssymm.F90 +++ /dev/null @@ -1,87 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE SSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssymv.F90 b/src/modules/BLAS95/src/blas95_src/ssymv.F90 deleted file mode 100755 index 3309c297e..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssymv.F90 +++ /dev/null @@ -1,77 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_SYMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE SSYMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyr.F90 b/src/modules/BLAS95/src/blas95_src/ssyr.F90 deleted file mode 100755 index 0cffcb6b8..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssyr.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSYR_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SYR' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) -END SUBROUTINE SSYR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyr2.F90 b/src/modules/BLAS95/src/blas95_src/ssyr2.F90 deleted file mode 100755 index d00fa770c..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssyr2.F90 +++ /dev/null @@ -1,69 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSYR2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYR2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE SSYR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyr2k.F90 b/src/modules/BLAS95/src/blas95_src/ssyr2k.F90 deleted file mode 100755 index aaaa71417..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssyr2k.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR2K - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE SSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyrk.F90 b/src/modules/BLAS95/src/blas95_src/ssyrk.F90 deleted file mode 100755 index 5f63cfda8..000000000 --- a/src/modules/BLAS95/src/blas95_src/ssyrk.F90 +++ /dev/null @@ -1,88 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE SSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYRK - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) -END SUBROUTINE SSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stbmv.F90 b/src/modules/BLAS95/src/blas95_src/stbmv.F90 deleted file mode 100755 index 199831df5..000000000 --- a/src/modules/BLAS95/src/blas95_src/stbmv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE STBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stbsv.F90 b/src/modules/BLAS95/src/blas95_src/stbsv.F90 deleted file mode 100755 index 0efa9364b..000000000 --- a/src/modules/BLAS95/src/blas95_src/stbsv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE STBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stpmv.F90 b/src/modules/BLAS95/src/blas95_src/stpmv.F90 deleted file mode 100755 index 94d22d53c..000000000 --- a/src/modules/BLAS95/src/blas95_src/stpmv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE STPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stpsv.F90 b/src/modules/BLAS95/src/blas95_src/stpsv.F90 deleted file mode 100755 index 8ffe34c94..000000000 --- a/src/modules/BLAS95/src/blas95_src/stpsv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE STPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strmm.F90 b/src/modules/BLAS95/src/blas95_src/strmm.F90 deleted file mode 100755 index dbb95c0b8..000000000 --- a/src/modules/BLAS95/src/blas95_src/strmm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - REAL(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE STRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strmv.F90 b/src/modules/BLAS95/src/blas95_src/strmv.F90 deleted file mode 100755 index d34f52fbf..000000000 --- a/src/modules/BLAS95/src/blas95_src/strmv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE STRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strsm.F90 b/src/modules/BLAS95/src/blas95_src/strsm.F90 deleted file mode 100755 index 9d4cf4cd3..000000000 --- a/src/modules/BLAS95/src/blas95_src/strsm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - REAL(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE STRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/strsm_batch.F90 deleted file mode 100755 index df85eefcf..000000000 --- a/src/modules/BLAS95/src/blas95_src/strsm_batch.F90 +++ /dev/null @@ -1,191 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE STRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & - & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & - & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) - ! Fortran77 call: - ! STRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! GROUP_COUNT,GROUP_SIZE) - ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' - ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! SIDE_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) - ! UPLO_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! DIAG_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'STRSM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) - REAL(WP), POINTER :: O_ALPHA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(SIDE_ARRAY)) THEN - O_SIDE_ARRAY => SIDE_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_SIDE_ARRAY(I) = 'L' - END DO - ENDIF - ENDIF - IF(PRESENT(UPLO_ARRAY)) THEN - O_UPLO_ARRAY => UPLO_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_UPLO_ARRAY(I) = 'U' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(DIAG_ARRAY)) THEN - O_DIAG_ARRAY => DIAG_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_DIAG_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF(O_SIDE_ARRAY(I).EQ.'L') THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & - & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & - & O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & - & GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(SIDE_ARRAY)) THEN - IF (ASSOCIATED(O_SIDE_ARRAY)) THEN - DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(UPLO_ARRAY)) THEN - IF (ASSOCIATED(O_UPLO_ARRAY)) THEN - DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(DIAG_ARRAY)) THEN - IF (ASSOCIATED(O_DIAG_ARRAY)) THEN - DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE STRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strsv.F90 b/src/modules/BLAS95/src/blas95_src/strsv.F90 deleted file mode 100755 index a4ba0ccb3..000000000 --- a/src/modules/BLAS95/src/blas95_src/strsv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE STRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0E0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE STRSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zaxpby.F90 b/src/modules/BLAS95/src/blas95_src/zaxpby.F90 deleted file mode 100755 index eda018f30..000000000 --- a/src/modules/BLAS95/src/blas95_src/zaxpby.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! ZAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - ! Default ALPHA=1 - ! Default BETA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPBY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE ZAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zaxpy.F90 b/src/modules/BLAS95/src/blas95_src/zaxpy.F90 deleted file mode 100755 index 80d2c0a87..000000000 --- a/src/modules/BLAS95/src/blas95_src/zaxpy.F90 +++ /dev/null @@ -1,58 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZAXPY_F95(X,Y,A) - ! Fortran77 call: - ! ZAXPY(N,A,X,INCX,Y,INCY) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_A - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) -END SUBROUTINE ZAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zaxpyi.F90 b/src/modules/BLAS95/src/blas95_src/zaxpyi.F90 deleted file mode 100755 index 46ea99efe..000000000 --- a/src/modules/BLAS95/src/blas95_src/zaxpyi.F90 +++ /dev/null @@ -1,55 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! ZAXPYI(NZ,A,X,INDX,Y) - ! Default A=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_AXPYI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_A - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(A)) THEN - O_A = A - ELSE - O_A = 1 - ENDIF - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_AXPYI(NZ,O_A,X,INDX,Y) -END SUBROUTINE ZAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zcopy.F90 b/src/modules/BLAS95/src/blas95_src/zcopy.F90 deleted file mode 100755 index 6686d8f9c..000000000 --- a/src/modules/BLAS95/src/blas95_src/zcopy.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZCOPY_F95(X,Y) - ! Fortran77 call: - ! ZCOPY(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_COPY - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_COPY(N,X,INCX,Y,INCY) -END SUBROUTINE ZCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotc.F90 b/src/modules/BLAS95/src/blas95_src/zdotc.F90 deleted file mode 100755 index f350aa532..000000000 --- a/src/modules/BLAS95/src/blas95_src/zdotc.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ZDOTC_F95(X,Y) - ! Fortran77 call: - ! ZDOTC(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTC - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTC_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTC' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - ZDOTC_F95 = F77_DOTC(N,X,INCX,Y,INCY) -END FUNCTION ZDOTC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotci.F90 b/src/modules/BLAS95/src/blas95_src/zdotci.F90 deleted file mode 100755 index 46f6ed65f..000000000 --- a/src/modules/BLAS95/src/blas95_src/zdotci.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ZDOTCI_F95(X,INDX,Y) - ! Fortran77 call: - ! ZDOTCI(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTCI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTCI_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTCI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - ZDOTCI_F95 = F77_DOTCI(NZ,X,INDX,Y) -END FUNCTION ZDOTCI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotu.F90 b/src/modules/BLAS95/src/blas95_src/zdotu.F90 deleted file mode 100755 index 7a374d749..000000000 --- a/src/modules/BLAS95/src/blas95_src/zdotu.F90 +++ /dev/null @@ -1,50 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ZDOTU_F95(X,Y) - ! Fortran77 call: - ! ZDOTU(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTU - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTU_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTU' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - ZDOTU_F95 = F77_DOTU(N,X,INCX,Y,INCY) -END FUNCTION ZDOTU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotui.F90 b/src/modules/BLAS95/src/blas95_src/zdotui.F90 deleted file mode 100755 index 66661113a..000000000 --- a/src/modules/BLAS95/src/blas95_src/zdotui.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE FUNCTION ZDOTUI_F95(X,INDX,Y) - ! Fortran77 call: - ! ZDOTUI(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_DOTUI - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - COMPLEX(WP) :: ZDOTUI_F95 - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTUI' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - ZDOTUI_F95 = F77_DOTUI(NZ,X,INDX,Y) -END FUNCTION ZDOTUI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdrot.F90 b/src/modules/BLAS95/src/blas95_src/zdrot.F90 deleted file mode 100755 index c302cb600..000000000 --- a/src/modules/BLAS95/src/blas95_src/zdrot.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZDROT_F95(X,Y,C,S) - ! Fortran77 call: - ! ZDROT(N,X,INCX,Y,INCY,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_ROT(N,X,INCX,Y,INCY,C,S) -END SUBROUTINE ZDROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdscal.F90 b/src/modules/BLAS95/src/blas95_src/zdscal.F90 deleted file mode 100755 index 240b6d58c..000000000 --- a/src/modules/BLAS95/src/blas95_src/zdscal.F90 +++ /dev/null @@ -1,48 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZDSCAL_F95(X,A) - ! Fortran77 call: - ! ZDSCAL(N,A,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCAL - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - REAL(WP), INTENT(IN) :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCAL(N,A,X,INCX) -END SUBROUTINE ZDSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgbmv.F90 b/src/modules/BLAS95/src/blas95_src/zgbmv.F90 deleted file mode 100755 index aec39a04d..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgbmv.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' - ! <<< Local scalars >>> - INTEGER :: O_KL - INTEGER :: O_M - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: KU - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - IF(PRESENT(KL)) THEN - O_KL = KL - ELSE - O_KL = (LDA-1)/2 - ENDIF - IF(PRESENT(M)) THEN - O_M = M - ELSE - O_M = N - ENDIF - KU = LDA-O_KL-1 - ! <<< Call blas77 routine >>> - CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & - & INCY) -END SUBROUTINE ZGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgem2vc.F90 b/src/modules/BLAS95/src/blas95_src/zgem2vc.F90 deleted file mode 100755 index 7ae6d29fc..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgem2vc.F90 +++ /dev/null @@ -1,78 +0,0 @@ -!=============================================================================== -! Copyright 2010-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! ZGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEM2V - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X1(:) - COMPLEX(WP), INTENT(IN) :: X2(:) - COMPLEX(WP), INTENT(INOUT ) :: Y1(:) - COMPLEX(WP), INTENT(INOUT ) :: Y2(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX1 - INTEGER :: INCX2 - INTEGER :: INCY1 - INTEGER :: INCY2 - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - INCX1 = 1 - INCX2 = 1 - INCY1 = 1 - INCY2 = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & - & Y2,INCY2) -END SUBROUTINE ZGEM2VC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm.F90 b/src/modules/BLAS95/src/blas95_src/zgemm.F90 deleted file mode 100755 index 1cba4d2d7..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgemm.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & - & LDC) -END SUBROUTINE ZGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm3m.F90 b/src/modules/BLAS95/src/blas95_src/zgemm3m.F90 deleted file mode 100755 index 505ab5499..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgemm3m.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! ZGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM3M - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=6), PARAMETER :: SRNAME = 'GEMM3M' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMM3M(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA, & - & C,LDC) -END SUBROUTINE ZGEMM3M_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 b/src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 deleted file mode 100755 index b21b5c5fc..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 +++ /dev/null @@ -1,190 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE ZGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,GROUP_SIZE,TRANSA_ARRAY,& - & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! ZGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! BETA_ARRAY=Array of beta values; default: array where each element=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM3M_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=13), PARAMETER :: SRNAME = 'ZGEMM3M_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) - COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) - COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - INTEGER, POINTER :: LDC_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(BETA_ARRAY)) THEN - O_BETA_ARRAY => BETA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_BETA_ARRAY(I) = 0 - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSB_ARRAY)) THEN - O_TRANSB_ARRAY => TRANSB_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSB_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & - & O_TRANSA_ARRAY(I).EQ.'n')) THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & - & O_TRANSB_ARRAY(I).EQ.'n')) THEN - LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) - ELSE - LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_GEMM3M_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & - & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(BETA_ARRAY)) THEN - IF (ASSOCIATED(O_BETA_ARRAY)) THEN - DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN - DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDC_ARRAY)) THEN - DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE ZGEMM3M_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 deleted file mode 100755 index 15e30f69d..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 +++ /dev/null @@ -1,190 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE ZGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& - & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & - & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! ZGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! BETA_ARRAY=Array of beta values; default: array where each element=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'ZGEMM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) - COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) - COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - INTEGER, POINTER :: LDC_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(BETA_ARRAY)) THEN - O_BETA_ARRAY => BETA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_BETA_ARRAY(I) = 0 - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSB_ARRAY)) THEN - O_TRANSB_ARRAY => TRANSB_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSB_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & - & O_TRANSA_ARRAY(I).EQ.'n')) THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & - & O_TRANSB_ARRAY(I).EQ.'n')) THEN - LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) - ELSE - LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & - & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & - & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(BETA_ARRAY)) THEN - IF (ASSOCIATED(O_BETA_ARRAY)) THEN - DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN - DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDC_ARRAY)) THEN - DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE ZGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemmt.F90 b/src/modules/BLAS95/src/blas95_src/zgemmt.F90 deleted file mode 100755 index 6ccd57b8e..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgemmt.F90 +++ /dev/null @@ -1,100 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMMT - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_TRANSB - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(TRANSB)) THEN - O_TRANSB = TRANSB - ELSE - O_TRANSB = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & - & O_BETA,C,LDC) -END SUBROUTINE ZGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemv.F90 b/src/modules/BLAS95/src/blas95_src/zgemv.F90 deleted file mode 100755 index 6bfcbd509..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgemv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - CHARACTER(LEN=1) :: O_TRANS - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE ZGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgerc.F90 b/src/modules/BLAS95/src/blas95_src/zgerc.F90 deleted file mode 100755 index a8d2f7b03..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgerc.F90 +++ /dev/null @@ -1,63 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGERC_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GERC - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERC' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GERC(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE ZGERC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgeru.F90 b/src/modules/BLAS95/src/blas95_src/zgeru.F90 deleted file mode 100755 index eaa558846..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgeru.F90 +++ /dev/null @@ -1,63 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGERU_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GERU - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERU' - ! <<< Local scalars >>> - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - M = SIZE(A,1) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_GERU(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE ZGERU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgthr.F90 b/src/modules/BLAS95/src/blas95_src/zgthr.F90 deleted file mode 100755 index 076ef5d2d..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgthr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! ZGTHR(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHR(NZ,Y,X,INDX) -END SUBROUTINE ZGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgthrz.F90 b/src/modules/BLAS95/src/blas95_src/zgthrz.F90 deleted file mode 100755 index f30fa8b77..000000000 --- a/src/modules/BLAS95/src/blas95_src/zgthrz.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! ZGTHRZ(NZ,Y,X,INDX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_GTHRZ - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_GTHRZ(NZ,Y,X,INDX) -END SUBROUTINE ZGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhbmv.F90 b/src/modules/BLAS95/src/blas95_src/zhbmv.F90 deleted file mode 100755 index a68b28960..000000000 --- a/src/modules/BLAS95/src/blas95_src/zhbmv.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE ZHBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhemm.F90 b/src/modules/BLAS95/src/blas95_src/zhemm.F90 deleted file mode 100755 index d863e01be..000000000 --- a/src/modules/BLAS95/src/blas95_src/zhemm.F90 +++ /dev/null @@ -1,87 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HEMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_HEMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE ZHEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhemv.F90 b/src/modules/BLAS95/src/blas95_src/zhemv.F90 deleted file mode 100755 index 2dd97fef2..000000000 --- a/src/modules/BLAS95/src/blas95_src/zhemv.F90 +++ /dev/null @@ -1,77 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HEMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HEMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE ZHEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zher.F90 b/src/modules/BLAS95/src/blas95_src/zher.F90 deleted file mode 100755 index 3711fcab6..000000000 --- a/src/modules/BLAS95/src/blas95_src/zher.F90 +++ /dev/null @@ -1,66 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHER_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HER - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HER' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HER(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) -END SUBROUTINE ZHER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zher2.F90 b/src/modules/BLAS95/src/blas95_src/zher2.F90 deleted file mode 100755 index 48ed47b85..000000000 --- a/src/modules/BLAS95/src/blas95_src/zher2.F90 +++ /dev/null @@ -1,69 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHER2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HER2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HER2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_HER2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) -END SUBROUTINE ZHER2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zher2k.F90 b/src/modules/BLAS95/src/blas95_src/zher2k.F90 deleted file mode 100755 index 250312c48..000000000 --- a/src/modules/BLAS95/src/blas95_src/zher2k.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HER2K - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'HER2K' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - COMPLEX(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_HER2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE ZHER2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zherk.F90 b/src/modules/BLAS95/src/blas95_src/zherk.F90 deleted file mode 100755 index 1930e5f61..000000000 --- a/src/modules/BLAS95/src/blas95_src/zherk.F90 +++ /dev/null @@ -1,88 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HERK - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HERK' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - REAL(WP) :: O_ALPHA - REAL(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_HERK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) -END SUBROUTINE ZHERK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhpmv.F90 b/src/modules/BLAS95/src/blas95_src/zhpmv.F90 deleted file mode 100755 index 37c6e8221..000000000 --- a/src/modules/BLAS95/src/blas95_src/zhpmv.F90 +++ /dev/null @@ -1,75 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_HPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) -END SUBROUTINE ZHPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhpr.F90 b/src/modules/BLAS95/src/blas95_src/zhpr.F90 deleted file mode 100755 index 21c5696a3..000000000 --- a/src/modules/BLAS95/src/blas95_src/zhpr.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! ZHPR(UPLO,N,ALPHA,X,INCX,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HPR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HPR' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - REAL(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_HPR(O_UPLO,N,O_ALPHA,X,INCX,AP) -END SUBROUTINE ZHPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhpr2.F90 b/src/modules/BLAS95/src/blas95_src/zhpr2.F90 deleted file mode 100755 index e4f298cea..000000000 --- a/src/modules/BLAS95/src/blas95_src/zhpr2.F90 +++ /dev/null @@ -1,67 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZHPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_HPR2 - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPR2' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_HPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) -END SUBROUTINE ZHPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zrotg.F90 b/src/modules/BLAS95/src/blas95_src/zrotg.F90 deleted file mode 100755 index 8f9b0f290..000000000 --- a/src/modules/BLAS95/src/blas95_src/zrotg.F90 +++ /dev/null @@ -1,40 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE ZROTG_F95(A,B,C,S) - ! Fortran77 call: - ! ZROTG(A,B,C,S) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_ROTG - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: A - COMPLEX(WP), INTENT(INOUT ) :: B - REAL(WP), INTENT(OUT) :: C - COMPLEX(WP), INTENT(OUT) :: S - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' - ! <<< Local scalars >>> - ! <<< Executable statements >>> - ! <<< Call blas77 routine >>> - CALL F77_ROTG(A,B,C,S) -END SUBROUTINE ZROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zscal.F90 b/src/modules/BLAS95/src/blas95_src/zscal.F90 deleted file mode 100755 index ce16ad85a..000000000 --- a/src/modules/BLAS95/src/blas95_src/zscal.F90 +++ /dev/null @@ -1,48 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZSCAL_F95(X,A) - ! Fortran77 call: - ! ZSCAL(N,A,X,INCX) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCAL - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - COMPLEX(WP), INTENT(IN) :: A - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCAL(N,A,X,INCX) -END SUBROUTINE ZSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsctr.F90 b/src/modules/BLAS95/src/blas95_src/zsctr.F90 deleted file mode 100755 index 258d4d25f..000000000 --- a/src/modules/BLAS95/src/blas95_src/zsctr.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! ZSCTR(NZ,X,INDX,Y) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SCTR - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(OUT) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' - ! <<< Local scalars >>> - INTEGER :: NZ - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - NZ = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SCTR(NZ,X,INDX,Y) -END SUBROUTINE ZSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zswap.F90 b/src/modules/BLAS95/src/blas95_src/zswap.F90 deleted file mode 100755 index 0de384da9..000000000 --- a/src/modules/BLAS95/src/blas95_src/zswap.F90 +++ /dev/null @@ -1,49 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZSWAP_F95(X,Y) - ! Fortran77 call: - ! ZSWAP(N,X,INCX,Y,INCY) - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SWAP - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(INOUT ) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' - ! <<< Local scalars >>> - INTEGER :: INCX - INTEGER :: INCY - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - INCX = 1 - INCY = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_SWAP(N,X,INCX,Y,INCY) -END SUBROUTINE ZSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsymm.F90 b/src/modules/BLAS95/src/blas95_src/zsymm.F90 deleted file mode 100755 index c9c85bb75..000000000 --- a/src/modules/BLAS95/src/blas95_src/zsymm.F90 +++ /dev/null @@ -1,87 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - M = SIZE(C,1) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE ZSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsyr2k.F90 b/src/modules/BLAS95/src/blas95_src/zsyr2k.F90 deleted file mode 100755 index c1d41cefb..000000000 --- a/src/modules/BLAS95/src/blas95_src/zsyr2k.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYR2K - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDB - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) -END SUBROUTINE ZSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsyrk.F90 b/src/modules/BLAS95/src/blas95_src/zsyrk.F90 deleted file mode 100755 index 3e1edf7b7..000000000 --- a/src/modules/BLAS95/src/blas95_src/zsyrk.F90 +++ /dev/null @@ -1,88 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_SYRK - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - COMPLEX(WP) :: O_ALPHA - COMPLEX(WP) :: O_BETA - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - INTEGER :: LDC - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(BETA)) THEN - O_BETA = BETA - ELSE - O_BETA = 0 - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN - K = SIZE(A,2) - ELSE - K = SIZE(A,1) - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDC = MAX(1,SIZE(C,1)) - N = SIZE(C,2) - ! <<< Call blas77 routine >>> - CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) -END SUBROUTINE ZSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztbmv.F90 b/src/modules/BLAS95/src/blas95_src/ztbmv.F90 deleted file mode 100755 index 3c68c3970..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztbmv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE ZTBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztbsv.F90 b/src/modules/BLAS95/src/blas95_src/ztbsv.F90 deleted file mode 100755 index 829b65521..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztbsv.F90 +++ /dev/null @@ -1,76 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TBSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: K - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - K = SIZE(A,1)-1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) -END SUBROUTINE ZTBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztpmv.F90 b/src/modules/BLAS95/src/blas95_src/ztpmv.F90 deleted file mode 100755 index 41d659a14..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztpmv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE ZTPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztpsv.F90 b/src/modules/BLAS95/src/blas95_src/ztpsv.F90 deleted file mode 100755 index 8bb30bbc3..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztpsv.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TPSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - ! <<< Intrinsic functions >>> - INTRINSIC PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - N = SIZE(X) - ! <<< Call blas77 routine >>> - CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) -END SUBROUTINE ZTPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrmm.F90 b/src/modules/BLAS95/src/blas95_src/ztrmm.F90 deleted file mode 100755 index 2f5e8dfe1..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztrmm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - COMPLEX(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE ZTRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrmv.F90 b/src/modules/BLAS95/src/blas95_src/ztrmv.F90 deleted file mode 100755 index 1512c786d..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztrmv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRMV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE ZTRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrsm.F90 b/src/modules/BLAS95/src/blas95_src/ztrsm.F90 deleted file mode 100755 index d22fa141e..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztrsm.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_SIDE - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANSA - CHARACTER(LEN=1) :: O_DIAG - COMPLEX(WP) :: O_ALPHA - INTEGER :: M - INTEGER :: N - INTEGER :: LDA - INTEGER :: LDB - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(ALPHA)) THEN - O_ALPHA = ALPHA - ELSE - O_ALPHA = 1 - ENDIF - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(SIDE)) THEN - O_SIDE = SIDE - ELSE - O_SIDE = 'L' - ENDIF - IF(PRESENT(TRANSA)) THEN - O_TRANSA = TRANSA - ELSE - O_TRANSA = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - LDA = MAX(1,SIZE(A,1)) - LDB = MAX(1,SIZE(B,1)) - M = SIZE(B,1) - N = SIZE(B,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) -END SUBROUTINE ZTRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 deleted file mode 100755 index 5990b07a3..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 +++ /dev/null @@ -1,191 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* - -PURE SUBROUTINE ZTRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & - & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & - & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) - ! Fortran77 call: - ! ZTRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, - ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, - ! GROUP_COUNT,GROUP_SIZE) - ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' - ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA - USE, INTRINSIC :: ISO_C_BINDING - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Array arguments >>> - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - ! SIDE_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) - ! UPLO_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) - ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) - ! DIAG_ARRAY - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=11), PARAMETER :: SRNAME = 'ZTRSM_BATCH' - ! <<< Local scalars >>> - INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC - INTEGER :: GROUP_COUNT - INTEGER :: I - ! <<< Local arrays >>> - CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) - CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) - COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) - INTEGER, POINTER :: LDA_ARRAY(:) - INTEGER, POINTER :: LDB_ARRAY(:) - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init skipped scalars >>> - GROUP_COUNT = SIZE(GROUP_SIZE) - ! <<< Init allocate status >>> - L_STAT_ALLOC = 0 - ! <<< Init optional and skipped arrays >>> - IF(PRESENT(ALPHA_ARRAY)) THEN - O_ALPHA_ARRAY => ALPHA_ARRAY - ELSE - ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_ALPHA_ARRAY(I) = 1 - END DO - ENDIF - ENDIF - IF(PRESENT(SIDE_ARRAY)) THEN - O_SIDE_ARRAY => SIDE_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_SIDE_ARRAY(I) = 'L' - END DO - ENDIF - ENDIF - IF(PRESENT(UPLO_ARRAY)) THEN - O_UPLO_ARRAY => UPLO_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_UPLO_ARRAY(I) = 'U' - END DO - ENDIF - ENDIF - IF(PRESENT(TRANSA_ARRAY)) THEN - O_TRANSA_ARRAY => TRANSA_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_TRANSA_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(PRESENT(DIAG_ARRAY)) THEN - O_DIAG_ARRAY => DIAG_ARRAY - ELSEIF(L_STAT_ALLOC==0) THEN - ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - O_DIAG_ARRAY(I) = 'N' - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - IF(O_SIDE_ARRAY(I).EQ.'L') THEN - LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) - ELSE - LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) - ENDIF - END DO - ENDIF - ENDIF - IF(L_STAT_ALLOC==0) THEN - ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) - IF(L_STAT_ALLOC==0) THEN - DO I=1, GROUP_COUNT - LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) - END DO - ENDIF - ENDIF - - ! <<< Call blas77 routine >>> - IF(L_STAT_ALLOC==0) THEN - CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & - & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & - & O_ALPHA_ARRAY,A_ARRAY, & - & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & - & GROUP_COUNT,GROUP_SIZE) - ENDIF - ! <<< Deallocate local arrays >>> - IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN - IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN - DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(SIDE_ARRAY)) THEN - IF (ASSOCIATED(O_SIDE_ARRAY)) THEN - DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(UPLO_ARRAY)) THEN - IF (ASSOCIATED(O_UPLO_ARRAY)) THEN - DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN - IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN - DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF(.NOT. PRESENT(DIAG_ARRAY)) THEN - IF (ASSOCIATED(O_DIAG_ARRAY)) THEN - DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - ENDIF - IF (ASSOCIATED(LDA_ARRAY)) THEN - DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF (ASSOCIATED(LDB_ARRAY)) THEN - DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) - ENDIF - IF(L_STAT_ALLOC .NE. 0) THEN - CALL F77_XERBLA(SRNAME,1000) - ENDIF -END SUBROUTINE ZTRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrsv.F90 b/src/modules/BLAS95/src/blas95_src/ztrsv.F90 deleted file mode 100755 index 829bca3ce..000000000 --- a/src/modules/BLAS95/src/blas95_src/ztrsv.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!=============================================================================== -! Copyright 2005-2020 Intel Corporation. -! -! This software and the related documents are Intel copyrighted materials, and -! your !USE of them is governed by the express license under which they were -! provided to you (License). Unless the License provides otherwise, you may not -! !USE, modify, copy, publish, distribute, disclose or transmit this software or -! the related documents without Intel's prior written permission. -! -! This software and the related documents are provided as is, with no express -! or implied warranties, other than those that are expressly stated in the -! License. -!=============================================================================== - -! Content: -! F95 interface for BLAS routines -!******************************************************************************* -! This file was generated automatically! -!******************************************************************************* - -PURE SUBROUTINE ZTRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! <<< !USE statements >>> - !USE F77_BLAS, ONLY: F77_TRSV - ! <<< Implicit statement >>> - !IMPLICIT NONE - ! <<< Kind parameter >>> - INTEGER, PARAMETER :: WP = KIND(1.0D0) - ! <<< Scalar arguments >>> - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - ! <<< Array arguments >>> - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - ! <<< Local declarations >>> - ! <<< Parameters >>> - CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' - ! <<< Local scalars >>> - CHARACTER(LEN=1) :: O_UPLO - CHARACTER(LEN=1) :: O_TRANS - CHARACTER(LEN=1) :: O_DIAG - INTEGER :: INCX - INTEGER :: N - INTEGER :: LDA - ! <<< Intrinsic functions >>> - INTRINSIC MAX, PRESENT, SIZE - ! <<< Executable statements >>> - ! <<< Init optional and skipped scalars >>> - IF(PRESENT(DIAG)) THEN - O_DIAG = DIAG - ELSE - O_DIAG = 'N' - ENDIF - IF(PRESENT(TRANS)) THEN - O_TRANS = TRANS - ELSE - O_TRANS = 'N' - ENDIF - IF(PRESENT(UPLO)) THEN - O_UPLO = UPLO - ELSE - O_UPLO = 'U' - ENDIF - INCX = 1 - LDA = MAX(1,SIZE(A,1)) - N = SIZE(A,2) - ! <<< Call blas77 routine >>> - CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) -END SUBROUTINE ZTRSV_F95 diff --git a/src/modules/BLAS95/src/easifem_blas_interface.inc b/src/modules/BLAS95/src/easifem_blas_interface.inc deleted file mode 100644 index 0adb9c51b..000000000 --- a/src/modules/BLAS95/src/easifem_blas_interface.inc +++ /dev/null @@ -1,1870 +0,0 @@ -INTERFACE GBMV - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SGBMV_F95 - PURE SUBROUTINE DGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DGBMV_F95 - PURE SUBROUTINE CGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CGBMV_F95 - PURE SUBROUTINE ZGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - INTEGER, INTENT(IN), OPTIONAL :: KL - INTEGER, INTENT(IN), OPTIONAL :: M - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZGBMV_F95 -END INTERFACE GBMV - -INTERFACE GEMV - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SGEMV_F95 - PURE SUBROUTINE DGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DGEMV_F95 - PURE SUBROUTINE CGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CGEMV_F95 - PURE SUBROUTINE ZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZGEMV_F95 - PURE SUBROUTINE SCGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! SCGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SCGEMV_F95 - PURE SUBROUTINE DZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) - ! Fortran77 call: - ! DZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DZGEMV_F95 -END INTERFACE GEMV - -INTERFACE GER - ! Default ALPHA=1 - PURE SUBROUTINE SGER_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE SGER_F95 - PURE SUBROUTINE DGER_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE DGER_F95 -END INTERFACE GER - -INTERFACE GERC - ! Default ALPHA=1 - PURE SUBROUTINE CGERC_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE CGERC_F95 - PURE SUBROUTINE ZGERC_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE ZGERC_F95 -END INTERFACE GERC - -INTERFACE GERU - ! Default ALPHA=1 - PURE SUBROUTINE CGERU_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE CGERU_F95 - PURE SUBROUTINE ZGERU_F95(A,X,Y,ALPHA) - ! Fortran77 call: - ! ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE ZGERU_F95 -END INTERFACE GERU - -INTERFACE HBMV - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE CHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CHBMV_F95 - PURE SUBROUTINE ZHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZHBMV_F95 -END INTERFACE HBMV - -INTERFACE HEMV - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE CHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CHEMV_F95 - PURE SUBROUTINE ZHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZHEMV_F95 -END INTERFACE HEMV - -INTERFACE HER - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE CHER_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! CHER(UPLO,N,ALPHA,X,INCX,A,LDA) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - END SUBROUTINE CHER_F95 - PURE SUBROUTINE ZHER_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - END SUBROUTINE ZHER_F95 -END INTERFACE HER - -INTERFACE HER2 - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE CHER2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE CHER2_F95 - PURE SUBROUTINE ZHER2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE ZHER2_F95 -END INTERFACE HER2 - -INTERFACE HPMV - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE CHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CHPMV_F95 - PURE SUBROUTINE ZHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZHPMV_F95 -END INTERFACE HPMV - -INTERFACE HPR - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE CHPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! CHPR(UPLO,N,ALPHA,X,INCX,AP) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - END SUBROUTINE CHPR_F95 - PURE SUBROUTINE ZHPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! ZHPR(UPLO,N,ALPHA,X,INCX,AP) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - END SUBROUTINE ZHPR_F95 -END INTERFACE HPR - -INTERFACE HPR2 - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE CHPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE CHPR2_F95 - PURE SUBROUTINE ZHPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(INOUT ) :: AP(:) - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE ZHPR2_F95 -END INTERFACE HPR2 - -INTERFACE SBMV - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SSBMV_F95 - PURE SUBROUTINE DSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DSBMV_F95 -END INTERFACE SBMV - -INTERFACE SPMV - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SSPMV_F95 - PURE SUBROUTINE DSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DSPMV_F95 -END INTERFACE SPMV - -INTERFACE SPR - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE SSPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! SSPR(UPLO,N,ALPHA,X,INCX,AP) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - END SUBROUTINE SSPR_F95 - PURE SUBROUTINE DSPR_F95(AP,X,UPLO,ALPHA) - ! Fortran77 call: - ! DSPR(UPLO,N,ALPHA,X,INCX,AP) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - END SUBROUTINE DSPR_F95 -END INTERFACE SPR - -INTERFACE SPR2 - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE SSPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE SSPR2_F95 - PURE SUBROUTINE DSPR2_F95(AP,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: AP(:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE DSPR2_F95 -END INTERFACE SPR2 - -INTERFACE SYMV - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SSYMV_F95 - PURE SUBROUTINE DSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DSYMV_F95 -END INTERFACE SYMV - -INTERFACE SYR - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE SSYR_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - END SUBROUTINE SSYR_F95 - PURE SUBROUTINE DSYR_F95(A,X,UPLO,ALPHA) - ! Fortran77 call: - ! DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - END SUBROUTINE DSYR_F95 -END INTERFACE SYR - -INTERFACE SYR2 - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - PURE SUBROUTINE SSYR2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE SSYR2_F95 - PURE SUBROUTINE DSYR2_F95(A,X,Y,UPLO,ALPHA) - ! Fortran77 call: - ! DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(INOUT ) :: A(:,:) - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE DSYR2_F95 -END INTERFACE SYR2 - -INTERFACE TBMV - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - PURE SUBROUTINE STBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE STBMV_F95 - PURE SUBROUTINE DTBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE DTBMV_F95 - PURE SUBROUTINE CTBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE CTBMV_F95 - PURE SUBROUTINE ZTBMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE ZTBMV_F95 -END INTERFACE TBMV - -INTERFACE TBSV - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - PURE SUBROUTINE STBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE STBSV_F95 - PURE SUBROUTINE DTBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE DTBSV_F95 - PURE SUBROUTINE CTBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE CTBSV_F95 - PURE SUBROUTINE ZTBSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE ZTBSV_F95 -END INTERFACE TBSV - -INTERFACE TPMV - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - PURE SUBROUTINE STPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE STPMV_F95 - PURE SUBROUTINE DTPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE DTPMV_F95 - PURE SUBROUTINE CTPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE CTPMV_F95 - PURE SUBROUTINE ZTPMV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE ZTPMV_F95 -END INTERFACE TPMV - -INTERFACE TPSV - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - PURE SUBROUTINE STPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE STPSV_F95 - PURE SUBROUTINE DTPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: AP(:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE DTPSV_F95 - PURE SUBROUTINE CTPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE CTPSV_F95 - PURE SUBROUTINE ZTPSV_F95(AP,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: AP(:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE ZTPSV_F95 -END INTERFACE TPSV - -INTERFACE TRMV - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - PURE SUBROUTINE STRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE STRMV_F95 - PURE SUBROUTINE DTRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE DTRMV_F95 - PURE SUBROUTINE CTRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE CTRMV_F95 - PURE SUBROUTINE ZTRMV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE ZTRMV_F95 -END INTERFACE TRMV - -INTERFACE TRSV - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - PURE SUBROUTINE STRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE STRSV_F95 - PURE SUBROUTINE DTRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE DTRSV_F95 - PURE SUBROUTINE CTRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE CTRSV_F95 - PURE SUBROUTINE ZTRSV_F95(A,X,UPLO,TRANS,DIAG) - ! Fortran77 call: - ! ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: X(:) - END SUBROUTINE ZTRSV_F95 -END INTERFACE TRSV - -INTERFACE GEMM - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE SGEMM_F95 - PURE SUBROUTINE DGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE DGEMM_F95 - PURE SUBROUTINE CGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CGEMM_F95 - PURE SUBROUTINE ZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZGEMM_F95 - PURE SUBROUTINE SCGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! SCGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE SCGEMM_F95 - PURE SUBROUTINE DZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! DZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE DZGEMM_F95 -END INTERFACE GEMM - -INTERFACE HEMM - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE CHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CHEMM_F95 - PURE SUBROUTINE ZHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZHEMM_F95 -END INTERFACE HEMM - -INTERFACE HERK - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE CHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CHERK_F95 - PURE SUBROUTINE ZHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZHERK_F95 -END INTERFACE HERK - -INTERFACE HER2K - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE CHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CHER2K_F95 - PURE SUBROUTINE ZHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZHER2K_F95 -END INTERFACE HER2K - -INTERFACE SYMM - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE SSYMM_F95 - PURE SUBROUTINE DSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE DSYMM_F95 - PURE SUBROUTINE CSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CSYMM_F95 - PURE SUBROUTINE ZSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) - ! Fortran77 call: - ! ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZSYMM_F95 -END INTERFACE SYMM - -INTERFACE SYRK - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE SSYRK_F95 - PURE SUBROUTINE DSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE DSYRK_F95 - PURE SUBROUTINE CSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CSYRK_F95 - PURE SUBROUTINE ZSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZSYRK_F95 -END INTERFACE SYRK - -INTERFACE SYR2K - ! UPLO='U','L'; default: 'U' - ! TRANS='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE SSYR2K_F95 - PURE SUBROUTINE DSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE DSYR2K_F95 - PURE SUBROUTINE CSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CSYR2K_F95 - PURE SUBROUTINE ZSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) - ! Fortran77 call: - ! ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZSYR2K_F95 -END INTERFACE SYR2K - -INTERFACE TRMM - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - PURE SUBROUTINE STRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE STRMM_F95 - PURE SUBROUTINE DTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE DTRMM_F95 - PURE SUBROUTINE CTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE CTRMM_F95 - PURE SUBROUTINE ZTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE ZTRMM_F95 -END INTERFACE TRMM - -INTERFACE TRSM - ! SIDE='L','R'; default: 'L' - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! DIAG='N','U'; default: 'N' - ! Default ALPHA=1 - PURE SUBROUTINE STRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE STRSM_F95 - PURE SUBROUTINE DTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE DTRSM_F95 - PURE SUBROUTINE CTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE CTRSM_F95 - PURE SUBROUTINE ZTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) - ! Fortran77 call: - ! ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(INOUT ) :: B(:,:) - END SUBROUTINE ZTRSM_F95 -END INTERFACE TRSM - -INTERFACE GEMMT - ! UPLO='U','L'; default: 'U' - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE SGEMMT_F95 - PURE SUBROUTINE DGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: B(:,:) - REAL(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE DGEMMT_F95 - PURE SUBROUTINE CGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CGEMMT_F95 - PURE SUBROUTINE ZGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZGEMMT_F95 -END INTERFACE GEMMT - -INTERFACE AXPYI - ! Default A=1 - PURE SUBROUTINE SAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! SAXPYI(NZ,A,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(IN), OPTIONAL :: A - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SAXPYI_F95 - PURE SUBROUTINE DAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! DAXPYI(NZ,A,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(IN), OPTIONAL :: A - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DAXPYI_F95 - PURE SUBROUTINE CAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! CAXPYI(NZ,A,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN), OPTIONAL :: A - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CAXPYI_F95 - PURE SUBROUTINE ZAXPYI_F95(X,INDX,Y,A) - ! Fortran77 call: - ! ZAXPYI(NZ,A,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN), OPTIONAL :: A - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZAXPYI_F95 -END INTERFACE AXPYI - -INTERFACE DOTI - PURE FUNCTION SDOTI_F95(X,INDX,Y) - ! Fortran77 call: - ! SDOTI(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP) :: SDOTI_F95 - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - END FUNCTION SDOTI_F95 - PURE FUNCTION DDOTI_F95(X,INDX,Y) - ! Fortran77 call: - ! DDOTI(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP) :: DDOTI_F95 - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - END FUNCTION DDOTI_F95 -END INTERFACE DOTI - -INTERFACE DOTCI - PURE FUNCTION CDOTCI_F95(X,INDX,Y) - ! Fortran77 call: - ! CDOTCI(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP) :: CDOTCI_F95 - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END FUNCTION CDOTCI_F95 - PURE FUNCTION ZDOTCI_F95(X,INDX,Y) - ! Fortran77 call: - ! ZDOTCI(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP) :: ZDOTCI_F95 - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END FUNCTION ZDOTCI_F95 -END INTERFACE DOTCI - -INTERFACE DOTUI - PURE FUNCTION CDOTUI_F95(X,INDX,Y) - ! Fortran77 call: - ! CDOTUI(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP) :: CDOTUI_F95 - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END FUNCTION CDOTUI_F95 - PURE FUNCTION ZDOTUI_F95(X,INDX,Y) - ! Fortran77 call: - ! ZDOTUI(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP) :: ZDOTUI_F95 - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END FUNCTION ZDOTUI_F95 -END INTERFACE DOTUI - -INTERFACE GTHR - PURE SUBROUTINE SGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! SGTHR(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE SGTHR_F95 - PURE SUBROUTINE DGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! DGTHR(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE DGTHR_F95 - PURE SUBROUTINE CGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! CGTHR(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE CGTHR_F95 - PURE SUBROUTINE ZGTHR_F95(X,INDX,Y) - ! Fortran77 call: - ! ZGTHR(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(IN) :: Y(:) - END SUBROUTINE ZGTHR_F95 -END INTERFACE GTHR - -INTERFACE GTHRZ - PURE SUBROUTINE SGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! SGTHRZ(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SGTHRZ_F95 - PURE SUBROUTINE DGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! DGTHRZ(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DGTHRZ_F95 - PURE SUBROUTINE CGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! CGTHRZ(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CGTHRZ_F95 - PURE SUBROUTINE ZGTHRZ_F95(X,INDX,Y) - ! Fortran77 call: - ! ZGTHRZ(NZ,Y,X,INDX) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(OUT) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZGTHRZ_F95 -END INTERFACE GTHRZ - -INTERFACE ROTI - ! Default C=1 - ! Default S=1 - PURE SUBROUTINE SROTI_F95(X,INDX,Y,C,S) - ! Fortran77 call: - ! SROTI(NZ,X,INDX,Y,C,S) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - REAL(WP), INTENT(INOUT ) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE SROTI_F95 - PURE SUBROUTINE DROTI_F95(X,INDX,Y,C,S) - ! Fortran77 call: - ! DROTI(NZ,X,INDX,Y,C,S) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(IN) :: C - REAL(WP), INTENT(IN) :: S - REAL(WP), INTENT(INOUT ) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(IN) :: Y(:) - END SUBROUTINE DROTI_F95 -END INTERFACE ROTI - -INTERFACE SCTR - PURE SUBROUTINE SSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! SSCTR(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(OUT) :: Y(:) - END SUBROUTINE SSCTR_F95 - PURE SUBROUTINE DSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! DSCTR(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - REAL(WP), INTENT(OUT) :: Y(:) - END SUBROUTINE DSCTR_F95 - PURE SUBROUTINE CSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! CSCTR(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(OUT) :: Y(:) - END SUBROUTINE CSCTR_F95 - PURE SUBROUTINE ZSCTR_F95(X,INDX,Y) - ! Fortran77 call: - ! ZSCTR(NZ,X,INDX,Y) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN) :: X(:) - INTEGER, INTENT(IN) :: INDX(:) - COMPLEX(WP), INTENT(OUT) :: Y(:) - END SUBROUTINE ZSCTR_F95 -END INTERFACE SCTR - -INTERFACE GEMM3M - ! TRANSA='N','C','T'; default: 'N' - ! TRANSB='N','C','T'; default: 'N' - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE CGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! CGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => SP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE CGEMM3M_F95 - PURE SUBROUTINE ZGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) - ! Fortran77 call: - ! ZGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) - USE F95_PRECISION, ONLY: WP => DP - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA - CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: B(:,:) - COMPLEX(WP), INTENT(INOUT ) :: C(:,:) - END SUBROUTINE ZGEMM3M_F95 -END INTERFACE GEMM3M - -INTERFACE AXPBY - ! Default ALPHA=1 - ! Default BETA=1 - PURE SUBROUTINE SAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! SAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE SAXPBY_F95 - PURE SUBROUTINE DAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! DAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: X(:) - REAL(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE DAXPBY_F95 - PURE SUBROUTINE CAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! CAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE CAXPBY_F95 - PURE SUBROUTINE ZAXPBY_F95(X,Y,ALPHA,BETA) - ! Fortran77 call: - ! ZAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: X(:) - COMPLEX(WP), INTENT(INOUT ) :: Y(:) - END SUBROUTINE ZAXPBY_F95 -END INTERFACE AXPBY - -INTERFACE GEM2V - ! Default ALPHA=1 - ! Default BETA=0 - PURE SUBROUTINE SGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! SGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, - ! INCY2) - USE F95_PRECISION, ONLY: WP => SP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X1(:) - REAL(WP), INTENT(IN) :: X2(:) - REAL(WP), INTENT(INOUT ) :: Y1(:) - REAL(WP), INTENT(INOUT ) :: Y2(:) - END SUBROUTINE SGEM2VU_F95 - PURE SUBROUTINE DGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! DGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, - ! INCY2) - USE F95_PRECISION, ONLY: WP => DP - REAL(WP), INTENT(IN), OPTIONAL :: ALPHA - REAL(WP), INTENT(IN), OPTIONAL :: BETA - REAL(WP), INTENT(IN) :: A(:,:) - REAL(WP), INTENT(IN) :: X1(:) - REAL(WP), INTENT(IN) :: X2(:) - REAL(WP), INTENT(INOUT ) :: Y1(:) - REAL(WP), INTENT(INOUT ) :: Y2(:) - END SUBROUTINE DGEM2VU_F95 - PURE SUBROUTINE CGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! CGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, - ! INCY2) - USE F95_PRECISION, ONLY: WP => SP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X1(:) - COMPLEX(WP), INTENT(IN) :: X2(:) - COMPLEX(WP), INTENT(INOUT ) :: Y1(:) - COMPLEX(WP), INTENT(INOUT ) :: Y2(:) - END SUBROUTINE CGEM2VC_F95 - PURE SUBROUTINE ZGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) - ! Fortran77 call: - ! ZGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, - ! INCY2) - USE F95_PRECISION, ONLY: WP => DP - COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA - COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA - COMPLEX(WP), INTENT(IN) :: A(:,:) - COMPLEX(WP), INTENT(IN) :: X1(:) - COMPLEX(WP), INTENT(IN) :: X2(:) - COMPLEX(WP), INTENT(INOUT ) :: Y1(:) - COMPLEX(WP), INTENT(INOUT ) :: Y2(:) - END SUBROUTINE ZGEM2VC_F95 -END INTERFACE GEM2V - -INTERFACE SGEMM_BATCH - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: 1 - ! BETA_ARRAY=Array of beta values; default: 0 - PURE SUBROUTINE SGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & - GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! SGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - USE F95_PRECISION, ONLY: WP => SP - USE, INTRINSIC :: ISO_C_BINDING - ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN because PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) - END SUBROUTINE SGEMM_BATCH_F95 -END INTERFACE SGEMM_BATCH - -INTERFACE DGEMM_BATCH - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: 1 - ! BETA_ARRAY=Array of beta values; default: 0 - PURE SUBROUTINE DGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & - GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! DGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - USE F95_PRECISION, ONLY: WP => DP - USE, INTRINSIC :: ISO_C_BINDING - ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN because PURE. - REAL(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) - END SUBROUTINE DGEMM_BATCH_F95 -END INTERFACE DGEMM_BATCH - -INTERFACE CGEMM_BATCH - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: 1 - ! BETA_ARRAY=Array of beta values; default: 0 - PURE SUBROUTINE CGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & - GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! CGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - USE F95_PRECISION, ONLY: WP => SP - USE, INTRINSIC :: ISO_C_BINDING - ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) - END SUBROUTINE CGEMM_BATCH_F95 -END INTERFACE CGEMM_BATCH - -INTERFACE ZGEMM_BATCH - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: 1 - ! BETA_ARRAY=Array of beta values; default: 0 - PURE SUBROUTINE ZGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & - GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! ZGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - USE F95_PRECISION, ONLY: WP => DP - USE, INTRINSIC :: ISO_C_BINDING - ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) - END SUBROUTINE ZGEMM_BATCH_F95 -END INTERFACE ZGEMM_BATCH - -INTERFACE CGEMM3M_BATCH - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: 1 - ! BETA_ARRAY=Array of beta values; default: 0 - PURE SUBROUTINE CGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & - GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! CGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - USE F95_PRECISION, ONLY: WP => SP - USE, INTRINSIC :: ISO_C_BINDING - ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) - END SUBROUTINE CGEMM3M_BATCH_F95 -END INTERFACE CGEMM3M_BATCH - -INTERFACE ZGEMM3M_BATCH - ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' - ! ALPHA_ARRAY=Array of alpha values; default: 1 - ! BETA_ARRAY=Array of beta values; default: 0 - PURE SUBROUTINE ZGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & - GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) - ! Fortran77 call: - ! ZGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) - USE F95_PRECISION, ONLY: WP => DP - USE, INTRINSIC :: ISO_C_BINDING - ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) - ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. - CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) - ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) - ! BETA_ARRAY: INOUT intent instead of IN because PURE. - COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) - INTEGER, INTENT(IN) :: M_ARRAY(:) - INTEGER, INTENT(IN) :: N_ARRAY(:) - INTEGER, INTENT(IN) :: K_ARRAY(:) - INTEGER, INTENT(IN) :: GROUP_SIZE(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) - INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) - END SUBROUTINE ZGEMM3M_BATCH_F95 -END INTERFACE ZGEMM3M_BATCH \ No newline at end of file diff --git a/src/modules/BaseContinuity/CMakeLists.txt b/src/modules/BaseContinuity/CMakeLists.txt deleted file mode 100644 index 1ce46813f..000000000 --- a/src/modules/BaseContinuity/CMakeLists.txt +++ /dev/null @@ -1,23 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/BaseContinuity_Method.F90 -) - diff --git a/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 b/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 deleted file mode 100644 index 703f34c6c..000000000 --- a/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 +++ /dev/null @@ -1,177 +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 BaseContinuity_Method -USE ErrorHandling, ONLY: Errormsg -USE GlobalData -USE String_Class, ONLY: String -USE BaseType -USE Utility, ONLY: UpperCase -IMPLICIT NONE -PRIVATE -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: BaseContinuity_ToString -PUBLIC :: BaseContinuity_FromString -PUBLIC :: BaseContinuityPointer_FromString - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE BaseContinuity_Copy -END INTERFACE - -CONTAINS - -!---------------------------------------------------------------------------- -! BaseContinuityPointer_FromString -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 30 Aug 2021 -! summary: This routine returns a pointer to a child of BaseContinuity_ - -FUNCTION BaseContinuityPointer_FromString(name) RESULT(ans) - CHARACTER(*), INTENT(IN) :: name - CLASS(BaseContinuity_), POINTER :: ans - !! - TYPE(String) :: astr - astr = TRIM(UpperCase(name)) - - SELECT CASE (astr%chars()) - CASE ("H1") - ALLOCATE (H1_ :: ans) - CASE ("HDIV") - ALLOCATE (HDiv_ :: ans) - CASE ("HCURL") - ALLOCATE (HCurl_ :: ans) - CASE ("DG") - ALLOCATE (DG_ :: ans) - CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for given name="//astr, & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuityPointer_FromString()", & - & file=__FILE__ & - & ) - END SELECT -END FUNCTION BaseContinuityPointer_FromString - -!---------------------------------------------------------------------------- -! BaseContinuity_Copy -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Copy BaseContinuity - -SUBROUTINE BaseContinuity_Copy(obj1, obj2) - CLASS(BaseContinuity_), ALLOCATABLE, INTENT(INOUT) :: obj1 - CLASS(BaseContinuity_), INTENT(IN) :: obj2 - - IF (ALLOCATED(obj1)) THEN - DEALLOCATE (obj1) - END IF - - SELECT TYPE (obj2) - CLASS IS (H1_) - ALLOCATE (H1_ :: obj1) - CLASS IS (HDiv_) - ALLOCATE (HDiv_ :: obj1) - CLASS IS (HCurl_) - ALLOCATE (HCurl_ :: obj1) - CLASS IS (DG_) - ALLOCATE (DG_ :: obj1) - CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuity_Copy()", & - & file=__FILE__ & - & ) - - END SELECT -END SUBROUTINE BaseContinuity_Copy - -!---------------------------------------------------------------------------- -! BaseContinuity_toString -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -FUNCTION BaseContinuity_ToString(obj) RESULT(ans) - CLASS(BaseContinuity_), INTENT(IN) :: obj - TYPE(String) :: ans - SELECT TYPE (obj) - CLASS IS (H1_) - ans = "H1" - CLASS IS (HCurl_) - ans = "HCurl" - CLASS IS (HDiv_) - ans = "HDiv" - CLASS IS (DG_) - ans = "DG" - CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuity_toString()", & - & file=__FILE__ & - & ) - END SELECT -END FUNCTION BaseContinuity_ToString - -!---------------------------------------------------------------------------- -! BaseContinuity_fromString -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -SUBROUTINE BaseContinuity_FromString(obj, name) - CLASS(BaseContinuity_), ALLOCATABLE, INTENT(OUT) :: obj - CHARACTER(*), INTENT(IN) :: name - TYPE(String) :: ans - - ans = UpperCase(name) - IF (ALLOCATED(obj)) DEALLOCATE (obj) - - SELECT CASE (ans%chars()) - CASE ("H1") - ALLOCATE (H1_ :: obj) - CASE ("HDIV") - ALLOCATE (HDiv_ :: obj) - CASE ("HCURL") - ALLOCATE (HCurl_ :: obj) - CASE ("DG") - ALLOCATE (DG_ :: obj) - CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for given name="//TRIM(name), & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuity_fromString()", & - & file=__FILE__ & - & ) - END SELECT -END SUBROUTINE BaseContinuity_FromString - -END MODULE BaseContinuity_Method diff --git a/src/modules/BaseInterpolation/CMakeLists.txt b/src/modules/BaseInterpolation/CMakeLists.txt deleted file mode 100644 index 0ed6e3a25..000000000 --- a/src/modules/BaseInterpolation/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/BaseInterpolation_Method.F90 -) diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 deleted file mode 100644 index cf3eb88a5..000000000 --- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 +++ /dev/null @@ -1,449 +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 BaseInterpolation_Method -USE ErrorHandling, ONLY: Errormsg -USE GlobalData -USE String_Class, ONLY: String -USE BaseType -USE Utility, ONLY: UpperCase -USE Display_Method, ONLY: Tostring -IMPLICIT NONE -PRIVATE -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: BaseInterpolation_ToInteger -PUBLIC :: BaseInterpolation_FromInteger -PUBLIC :: BaseInterpolation_ToString -PUBLIC :: BaseInterpolation_FromString -PUBLIC :: BaseInterpolationPointer_FromString - -INTERFACE BaseInterpolation_ToInteger - MODULE PROCEDURE BaseInterpolation_ToInteger1 - MODULE PROCEDURE BaseInterpolation_ToInteger2 -END INTERFACE BaseInterpolation_ToInteger - -INTERFACE BaseInterpolation_ToString - MODULE PROCEDURE BaseInterpolation_ToString1 - MODULE PROCEDURE BaseInterpolation_ToString2 -END INTERFACE BaseInterpolation_ToString - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE BaseInterpolation_Copy -END INTERFACE - -CONTAINS - -!---------------------------------------------------------------------------- -! BaseInterpolationPointer_FromString -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-18 -! summary: This routine returns a pointer to a child of BaseInterpolation_ - -FUNCTION BaseInterpolationPointer_FromString(name) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: name - CLASS(BaseInterpolation_), POINTER :: ans - !! - TYPE(String) :: astr - astr = TRIM(UpperCase(name)) - - SELECT CASE (astr%chars()) - CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") - ALLOCATE (LagrangeInterpolation_ :: ans) - CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") - ALLOCATE (SerendipityInterpolation_ :: ans) - CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") - ALLOCATE (HermitInterpolation_ :: ans) - CASE ( & - & "HIERARCHICALPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHICALPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION") - ALLOCATE (HierarchyInterpolation_ :: ans) - CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") - ALLOCATE (OrthogonalInterpolation_ :: ans) - CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of name="//astr, & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolationPointer_FromString()", & - & file=__FILE__ & - & ) - END SELECT -END FUNCTION BaseInterpolationPointer_FromString - -!---------------------------------------------------------------------------- -! BaseInterpolation_Copy -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Copy BaseInterpolation - -SUBROUTINE BaseInterpolation_Copy(obj1, obj2) - CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(INOUT) :: obj1 - CLASS(BaseInterpolation_), INTENT(IN) :: obj2 - - IF (ALLOCATED(obj1)) THEN - DEALLOCATE (obj1) - END IF - - SELECT TYPE (obj2) - CLASS IS (LagrangeInterpolation_) - ALLOCATE (LagrangeInterpolation_ :: obj1) - CLASS IS (SerendipityInterpolation_) - ALLOCATE (SerendipityInterpolation_ :: obj1) - CLASS IS (HermitInterpolation_) - ALLOCATE (HermitInterpolation_ :: obj1) - CLASS IS (HierarchyInterpolation_) - ALLOCATE (HierarchyInterpolation_ :: obj1) - CLASS IS (OrthogonalInterpolation_) - ALLOCATE (OrthogonalInterpolation_ :: obj1) - CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_Copy()", & - & file=__FILE__ & - & ) - - END SELECT -END SUBROUTINE BaseInterpolation_Copy - -!---------------------------------------------------------------------------- -! BaseInterpolation_toString -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -FUNCTION BaseInterpolation_ToString1(obj) RESULT(ans) - CLASS(BaseInterpolation_), INTENT(IN) :: obj - TYPE(String) :: ans - SELECT TYPE (obj) - CLASS IS (LagrangeInterpolation_) - ans = "LagrangeInterpolation" - CLASS IS (SerendipityInterpolation_) - ans = "SerendipityInterpolation" - CLASS IS (HermitInterpolation_) - ans = "HermitInterpolation" - CLASS IS (HierarchyInterpolation_) - ans = "HierarchyInterpolation" - CLASS IS (OrthogonalInterpolation_) - ans = "OrthogonalInterpolation" - CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_tostring()", & - & file=__FILE__ & - & ) - END SELECT -END FUNCTION BaseInterpolation_ToString1 - -!---------------------------------------------------------------------------- -! BaseInterpolation_toInteger -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) - CLASS(BaseInterpolation_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - SELECT TYPE (obj) - CLASS IS (LagrangeInterpolation_) - ans = LagrangePolynomial - CLASS IS (SerendipityInterpolation_) - ans = SerendipityPolynomial - CLASS IS (HermitInterpolation_) - ans = HermitPolynomial - CLASS IS (HierarchyInterpolation_) - ans = HeirarchicalPolynomial - CLASS IS (OrthogonalInterpolation_) - ans = OrthogonalPolynomial - CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_toInteger()", & - & file=__FILE__ & - & ) - END SELECT -END FUNCTION BaseInterpolation_ToInteger1 - -!---------------------------------------------------------------------------- -! BaseInterpolation_toInteger -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) - CHARACTER(*), INTENT(IN) :: name - INTEGER(I4B) :: ans - - SELECT CASE (TRIM(UpperCase(name))) - CASE ("EQUIDISTANCE") - ans = Equidistance - - CASE ("GAUSSLEGENDRE") - ans = GaussLegendre - - CASE ("GAUSSLEGENDRELOBATTO") - ans = GaussLegendreLobatto - - CASE ("GAUSSLEGENDRERADAU") - ans = GaussLegendreRadau - - CASE ("GAUSSLEGENDRERADAULEFT") - ans = GaussLegendreRadauLeft - - CASE ("GAUSSLEGENDRERADAURIGHT") - ans = GaussLegendreRadauRight - - CASE ("GAUSSCHEBYSHEV") - ans = GaussChebyshev - - CASE ("GAUSSCHEBYSHEVLOBATTO") - ans = GaussChebyshevLobatto - - CASE ("GAUSSCHEBYSHEVRADAU") - ans = GaussChebyshevRadau - - CASE ("GAUSSCHEBYSHEVRADAULEFT") - ans = GaussChebyshevRadauLeft - - CASE ("GAUSSCHEBYSHEVRADAURIGHT") - ans = GaussChebyshevRadauRight - - CASE ("GAUSSJACOBI") - ans = GaussJacobi - - CASE ("GAUSSJACOBILOBATTO") - ans = GaussJacobiLobatto - - CASE ("GAUSSJACOBIRADAU") - ans = GaussJacobiRadau - - CASE ("GAUSSJACOBIRADAULEFT") - ans = GaussJacobiRadauLeft - - CASE ("GAUSSJACOBIRADAURIGHT") - ans = GaussJacobiRadauRight - - CASE ("GAUSSULTRASPHERICAL") - ans = GaussUltraspherical - - CASE ("GAUSSULTRASPHERICALLOBATTO") - ans = GaussUltrasphericalLobatto - - CASE ("GAUSSULTRASPHERICALRADAU") - ans = GaussUltrasphericalRadau - - CASE ("GAUSSULTRASPHERICALRADAULEFT") - ans = GaussUltrasphericalRadauLeft - - CASE ("GAUSSULTRASPHERICALRADAURIGHT") - ans = GaussUltrasphericalRadauRight - - CASE DEFAULT - ans = -1_I4B - CALL Errormsg(& - & msg="No case found for given baseInterpolation name", & - & file=__FILE__, & - & line=__LINE__,& - & routine="BaseInterpolation_ToInteger2()", & - & unitno=stderr) - RETURN - END SELECT -END FUNCTION BaseInterpolation_ToInteger2 - -!---------------------------------------------------------------------------- -! BaseInterpolation_fromString -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -SUBROUTINE BaseInterpolation_FromString(obj, name) - CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj - CHARACTER(*), INTENT(IN) :: name - TYPE(String) :: ans - - ans = UpperCase(name) - IF (ALLOCATED(obj)) DEALLOCATE (obj) - - SELECT CASE (ans%chars()) - CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") - ALLOCATE (LagrangeInterpolation_ :: obj) - CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") - ALLOCATE (SerendipityInterpolation_ :: obj) - CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") - ALLOCATE (HermitInterpolation_ :: obj) - CASE ( & - & "HIERARCHICALPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHICALPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION") - ALLOCATE (HierarchyInterpolation_ :: obj) - CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") - ALLOCATE (OrthogonalInterpolation_ :: obj) - CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of name="//TRIM(name), & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_fromString()", & - & file=__FILE__ & - & ) - END SELECT -END SUBROUTINE BaseInterpolation_FromString - -!---------------------------------------------------------------------------- -! BaseInterpolation_fromInteger -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -SUBROUTINE BaseInterpolation_FromInteger(obj, name) - CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj - INTEGER(I4B), INTENT(IN) :: name - - SELECT CASE (name) - CASE (LagrangePolynomial) - ALLOCATE (LagrangeInterpolation_ :: obj) - CASE (SerendipityPolynomial) - ALLOCATE (SerendipityInterpolation_ :: obj) - CASE (HermitPolynomial) - ALLOCATE (HermitInterpolation_ :: obj) - CASE (OrthogonalPolynomial) - ALLOCATE (OrthogonalInterpolation_ :: obj) - CASE (HeirarchicalPolynomial) - ALLOCATE (HierarchyInterpolation_ :: obj) - CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for given name="//tostring(name), & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_fromInteger()", & - & file=__FILE__ & - & ) - END SELECT - -END SUBROUTINE BaseInterpolation_FromInteger - -!---------------------------------------------------------------------------- -! QuadraturePointIDToName -!---------------------------------------------------------------------------- - -FUNCTION BaseInterpolation_ToString2(name) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: name - TYPE(String) :: ans - - SELECT CASE (name) - CASE (Equidistance) - ans = "EQUIDISTANCE" - - CASE (GaussLegendre) - ans = "GAUSSLEGENDRE" - - CASE (GaussLegendreLobatto) - ans = "GAUSSLEGENDRELOBATTO" - - CASE (GaussLegendreRadau) - ans = "GAUSSLEGENDRERADAU" - - CASE (GaussLegendreRadauLeft) - ans = "GAUSSLEGENDRERADAULEFT" - - CASE (GaussLegendreRadauRight) - ans = "GAUSSLEGENDRERADAURIGHT" - - CASE (GaussChebyshev) - ans = "GAUSSCHEBYSHEV" - - CASE (GaussChebyshevLobatto) - ans = "GAUSSCHEBYSHEVLOBATTO" - - CASE (GaussChebyshevRadau) - ans = "GAUSSCHEBYSHEVRADAU" - - CASE (GaussChebyshevRadauLeft) - ans = "GAUSSCHEBYSHEVRADAULEFT" - - CASE (GaussChebyshevRadauRight) - ans = "GAUSSCHEBYSHEVRADAURIGHT" - - CASE (GaussJacobi) - ans = "GAUSSJACOBI" - - CASE (GaussJacobiLobatto) - ans = "GAUSSJACOBILOBATTO" - - CASE (GaussJacobiRadau) - ans = "GAUSSJACOBIRADAU" - - CASE (GaussJacobiRadauLeft) - ans = "GAUSSJACOBIRADAULEFT" - - CASE (GaussJacobiRadauRight) - ans = "GAUSSJACOBIRADAURIGHT" - - CASE (GaussUltraspherical) - ans = "GAUSSULTRASPHERICAL" - - CASE (GaussUltrasphericalLobatto) - ans = "GAUSSULTRASPHERICALLOBATTO" - - CASE (GaussUltrasphericalRadau) - ans = "GAUSSULTRASPHERICALRADAU" - - CASE (GaussUltrasphericalRadauLeft) - ans = "GAUSSULTRASPHERICALRADAULEFT" - - CASE (GaussUltrasphericalRadauRight) - ans = "GAUSSULTRASPHERICALRADAURIGHT" - - CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given quadratureType name", & - & file=__FILE__, & - & line=__LINE__,& - & routine="QuadraturePointIDToName()", & - & unitno=stderr) - RETURN - END SELECT -END FUNCTION BaseInterpolation_ToString2 - -END MODULE BaseInterpolation_Method diff --git a/src/modules/BaseMethod/CMakeLists.txt b/src/modules/BaseMethod/CMakeLists.txt deleted file mode 100644 index 6b7bbcad1..000000000 --- a/src/modules/BaseMethod/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/BaseMethod.F90 -) \ No newline at end of file diff --git a/src/modules/BaseMethod/src/BaseMethod.F90 b/src/modules/BaseMethod/src/BaseMethod.F90 deleted file mode 100644 index 04f1ed78f..000000000 --- a/src/modules/BaseMethod/src/BaseMethod.F90 +++ /dev/null @@ -1,120 +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: 23 Feb 2021 -! summary: Modules related to [[BaseType]] module. -! -!# Introduction -! This module contains the modules related to data types which are defined -! inside the [[BaseType]] module. This module should be compiled before -! compilation of any submodule because almost all the submodules of user -! defined data type methods uses [[BaseMethod]] module. Further, after adding -! a new user defined data type inside [[BaseType]] module, its method should -! be included here. - -MODULE BaseMethod -#ifdef USE_SuperLU -USE SuperLUInterface -#endif - -#ifdef USE_LIS -! USE LISInterface -#endif - -#ifdef USE_PLPLOT -USE PLPLOT -#endif - -#ifdef USE_OpenMP -USE OMP_LIB -#endif - -#ifdef USE_BLAS95 -USE F77_BLAS -USE F95_BLAS -#endif - -#ifdef USE_LAPACK95 -USE F77_LAPACK -USE F95_LAPACK -USE Lapack_Method -#endif - -#ifdef USE_ARPACK -USE EASIFEM_ARPACK -#endif - -#ifdef USE_FFTW -USE FFTW3 -#endif - -#ifdef USE_METIS -USE MetisInterface -#endif - -USE String_Class -USE String_Method -USE PENF, ONLY: endianL, endianB, endian, byte_size, str_ascii, & - & str_ucs4, str, strz, cton, bstr, bcton, check_endian, digit, & - & penf_Init, penf_print -USE BeFoR64 -USE FACE -USE FPL, ONLY: ParameterList_, & -& ParameterListIterator_, & -& FPL_Init, & -& FPL_Finalize -USE System_Method -USE CInterface -USE OpenMP_Method -USE GlobalData -USE Hashing32 -USE OGPF -USE Test_Method -USE MdEncode_Method -! USE DISPMODULE -USE Display_Method -USE ErrorHandling -USE BaseInterpolation_Method -USE BaseContinuity_Method -USE Utility -USE PolynomialUtility -USE BaseType -USE MultiIndices_Method -USE Random_Method -USE BoundingBox_Method -USE IntVector_Method -USE IndexValue_Method -USE KeyValue_Method -USE IterationData_Method -USE Vector3D_Method -USE RealVector_Method -USE DOF_Method -USE Geometry_Method -USE QuadraturePoint_Method -USE FEVariable_Method -USE Elemshapedata_Method -USE RealMatrix_Method -USE FEMatrix_Method -USE FEVector_Method -USE Rank2Tensor_Method -USE VoigtRank2Tensor_Method -USE CSRSparsity_Method -USE CSRMatrix_Method -USE LuaInterface - -END MODULE BaseMethod diff --git a/src/modules/BaseType/CMakeLists.txt b/src/modules/BaseType/CMakeLists.txt deleted file mode 100644 index a1e0d39ca..000000000 --- a/src/modules/BaseType/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/BaseType.F90 -) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 deleted file mode 100644 index 5385572b3..000000000 --- a/src/modules/BaseType/src/BaseType.F90 +++ /dev/null @@ -1,1748 +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 < https://www.gnu.org/licenses/> -! - -!> author: Dr. Vikas Sharma -! -! [[BaseType]] module contains several userful user defined data types. - -MODULE BaseType -USE GlobalData -USE String_Class, ONLY: String -#ifdef USE_SuperLU -USE SuperLUInterface -USE ISO_C_BINDING, ONLY: C_CHAR, C_PTR, C_SIZE_T -#endif -IMPLICIT NONE -PRIVATE - -PUBLIC :: Math -PUBLIC :: BoundingBox_ -PUBLIC :: TypeBoundingBox -PUBLIC :: BoundingBoxPointer_ -PUBLIC :: RealMatrix_ -PUBLIC :: TypeRealMatrix -PUBLIC :: RealMatrixPointer_ -PUBLIC :: IntVector_ -PUBLIC :: TypeIntVector -PUBLIC :: IntVectorPointer_ -PUBLIC :: RealVector_ -PUBLIC :: TypeRealVector -PUBLIC :: RealVectorPointer_ -PUBLIC :: Vector3D_ -PUBLIC :: TypeVector3D -PUBLIC :: Vector3DPointer_ -PUBLIC :: IndexValue_ -PUBLIC :: IndexValuePointer_ -PUBLIC :: DOF_ -PUBLIC :: TypeDOF -PUBLIC :: DOFPointer_ -PUBLIC :: SparseMatrixReOrdering_ -PUBLIC :: TypeSparseMatrixReOrdering -PUBLIC :: CSRSparsity_ -PUBLIC :: TypeCSRSparsity -PUBLIC :: CSRSparsityPointer_ -PUBLIC :: CSRMatrix_ -PUBLIC :: TypeCSRMatrix -PUBLIC :: CSRMatrixPointer_ -PUBLIC :: IterationData_ -PUBLIC :: TypeIterationData -PUBLIC :: IterationDataPointer_ -PUBLIC :: VoigtRank2Tensor_ -PUBLIC :: TypeVoigtRank2Tensor -PUBLIC :: VoigtRank2TensorPointer -PUBLIC :: Rank2Tensor_ -PUBLIC :: TypeRank2Tensor -PUBLIC :: Rank2TensorPointer_ -PUBLIC :: DeformationGradient_ -PUBLIC :: DeformationGradientPointer_ -PUBLIC :: TypeDeformationGradient -PUBLIC :: LeftCauchyGreen_ -PUBLIC :: TypeLeftCauchyGreen -PUBLIC :: LeftCauchyGreenPointer_ -PUBLIC :: RightCauchyGreen_ -PUBLIC :: TypeRightCauchyGreen -PUBLIC :: RightCauchyGreenPointer_ -PUBLIC :: Strain_ -PUBLIC :: TypeStrain -PUBLIC :: StrainPointer_ -PUBLIC :: AlmansiStrain_ -PUBLIC :: TypeAlmansiStrain -PUBLIC :: AlmansiStrainPointer_ -PUBLIC :: GreenStrain_ -PUBLIC :: TypeGreenStrain -PUBLIC :: GreenStrainPointer_ -PUBLIC :: SmallStrain_ -PUBLIC :: TypeSmallStrain -PUBLIC :: SmallStrainPointer_ -PUBLIC :: ReferenceTopology_ -! PUBLIC :: TypeReferenceTopology -PUBLIC :: ReferenceTopologyPointer_ -PUBLIC :: ReferenceElement_ -PUBLIC :: ReferenceElementPointer_ -PUBLIC :: ReferencePoint_ -PUBLIC :: TypeReferencePoint -PUBLIC :: ReferenceLine_ -PUBLIC :: TypeReferenceLine -PUBLIC :: ReferenceTriangle_ -PUBLIC :: TypeReferenceTriangle -PUBLIC :: ReferenceQuadrangle_ -PUBLIC :: TypeReferenceQuadrangle -PUBLIC :: ReferenceTetrahedron_ -PUBLIC :: TypeReferenceTetrahedron -PUBLIC :: ReferenceHexahedron_ -PUBLIC :: TypeReferenceHexahedron -PUBLIC :: ReferencePrism_ -PUBLIC :: TypeReferencePrism -PUBLIC :: ReferencePyramid_ -PUBLIC :: TypeReferencePyramid -PUBLIC :: KeyValue_ -PUBLIC :: TypeKeyValue -PUBLIC :: FEVariable_ -PUBLIC :: TypeFEVariable -PUBLIC :: FEVariableConstant_ -PUBLIC :: TypeFEVariableConstant -PUBLIC :: TypeVariableConstant -PUBLIC :: FEVariableSpace_ -PUBLIC :: TypeFEVariableSpace -PUBLIC :: TypeVariableSpace -PUBLIC :: FEVariableSpaceTime_ -PUBLIC :: TypeFEVariableSpaceTime -PUBLIC :: TypeVariableSpaceTime -PUBLIC :: FEVariableTime_ -PUBLIC :: TypeFEVariableTime -PUBLIC :: TypeVariableTime -PUBLIC :: FEVariableScalar_ -PUBLIC :: TypeFEVariableScalar -PUBLIC :: TypeVariableScalar -PUBLIC :: FEVariableVector_ -PUBLIC :: TypeFEVariableVector -PUBLIC :: TypeVariableVector -PUBLIC :: FEVariableMatrix_ -PUBLIC :: TypeFEVariableMatrix -PUBLIC :: TypeVariableMatrix -PUBLIC :: QuadraturePoint_ -PUBLIC :: TypeQuadraturePoint -PUBLIC :: QuadraturePointPointer_ -PUBLIC :: BaseInterpolation_ -PUBLIC :: LagrangeInterpolation_ -PUBLIC :: TypeLagrangeInterpolation -PUBLIC :: HermitInterpolation_ -PUBLIC :: TypeHermitInterpolation -PUBLIC :: SerendipityInterpolation_ -PUBLIC :: TypeSerendipityInterpolation -PUBLIC :: HierarchyInterpolation_ -PUBLIC :: TypeHierarchyInterpolation -PUBLIC :: OrthogonalInterpolation_ -PUBLIC :: TypeOrthogonalInterpolation -PUBLIC :: BaseContinuity_ -PUBLIC :: TypeBaseContinuity -PUBLIC :: H1_ -PUBLIC :: TypeH1 -PUBLIC :: HDIV_ -PUBLIC :: TypeHDIV -PUBLIC :: HCURL_ -PUBLIC :: TypeHCURL -PUBLIC :: DG_ -PUBLIC :: TypeDG -PUBLIC :: DEL_NONE, DEL_X, DEL_Y, DEL_Z, DEL_X_ALL, DEL_t -PUBLIC :: ElementData_ -PUBLIC :: TypeElementData -PUBLIC :: ElementDataPointer_ -PUBLIC :: ShapeData_ -PUBLIC :: TypeShapeData -PUBLIC :: ShapeDataPointer_ -PUBLIC :: STShapeData_ -PUBLIC :: STShapeDataPointer_ -PUBLIC :: ElemShapeData_ -PUBLIC :: TypeElemShapeData -PUBLIC :: ElemShapeDataPointer_ -PUBLIC :: STElemShapeData_ -PUBLIC :: TypeSTElemShapeData -PUBLIC :: QualityMeasure -PUBLIC :: Random_ -PUBLIC :: TypeRandom -PUBLIC :: OMP -PUBLIC :: TypeOpenMP -PUBLIC :: MultiIndices_ -PUBLIC :: iface_SpaceTimeFunction -PUBLIC :: iface_SpaceFunction -PUBLIC :: iface_TimeFunction -PUBLIC :: iface_1DFunction -PUBLIC :: iface_2DFunction -PUBLIC :: iface_3DFunction -PUBLIC :: iface_ScalarFunction -PUBLIC :: iface_VectorFunction -PUBLIC :: iface_MatrixFunction -PUBLIC :: Range_ -PUBLIC :: Interval1D_ - -INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 - -!---------------------------------------------------------------------------- -! Math_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2022 -! summary: Math class - -TYPE :: Math_ - REAL(DFP) :: PI = 3.14159265359_DFP - REAL(DFP) :: e = 2.718281828459045_DFP - 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_() - -!---------------------------------------------------------------------------- -! BoundingBox_ -!---------------------------------------------------------------------------- - -! date: 23 Feb 2021 -!> author: Vikas Sharma, Ph. D. -! summary: A data type to represent a bounding box; -! -!{!pages/BoundingBox_.md!} - -TYPE :: BoundingBox_ - INTEGER(I4B) :: nsd = 0 - !! Number of spatial dimension - !! NSD = 1, 2, 3 for 1D, 2D, 3D box - REAL(DFP) :: box(2, 3) = 0.0 - !! Box contains the xmin, ymin, ... - !! `Box(1:2, 1:3)` an array containing box coordinates. - !!- `Box(1:2, 1:3)` an array containing box coordinates. - !!- `Box(1, 1)` is x_min - !!- `Box(2, 1)` is x_max - !!- `Box(1, 2)` is y_min - !!- `Box(2, 2)` is y_max - !!- `Box(1, 3)` is z_min - !!- `Box(2, 3)` is z_max - REAL(DFP) :: l(3) = 0.0_DFP - !! l(1) length in x - !! l(2) length in y - !! l(3) length in z -END TYPE BoundingBox_ - -TYPE(BoundingBox_), PARAMETER :: TypeBoundingBox = BoundingBox_() -!! A Type Instance of Boundingbox - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Contains the pointer to the [[BoundingBox_]] data type. - -TYPE :: BoundingBoxPointer_ - CLASS(BoundingBoxPointer_), POINTER :: ptr => NULL() -END TYPE BoundingBoxPointer_ - -!---------------------------------------------------------------------------- -! Matrix_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: A data type for an Array of rank 2 of real numbers -! -!{!pages/docs-api/RealMatrix/RealMatrix_.md!} - -TYPE :: RealMatrix_ - INTEGER(I4B) :: tDimension = 0_I4B - CHARACTER(5) :: MatrixProp = 'UNSYM' - REAL(DFP), ALLOCATABLE :: Val(:, :) -END TYPE RealMatrix_ - -TYPE(RealMatrix_), PARAMETER :: TypeRealMatrix = RealMatrix_(Val=NULL()) - -TYPE :: RealMatrixPointer_ - CLASS(RealMatrix_), POINTER :: ptr => NULL() -END TYPE RealMatrixPointer_ - -!---------------------------------------------------------------------------- -! IntVector_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: A data type to contain fortran vector of integer numbers -! -!{!pages/IntVector_.md!} - -TYPE :: IntVector_ - INTEGER(I4B) :: tDimension = 1_I4B - INTEGER(I4B), ALLOCATABLE :: Val(:) -END TYPE IntVector_ - -TYPE(IntVector_), PARAMETER :: TypeIntVector = IntVector_(Val=NULL()) - -TYPE :: IntVectorPointer_ - CLASS(IntVector_), POINTER :: ptr => NULL() -END TYPE IntVectorPointer_ - -!---------------------------------------------------------------------------- -! RealVector_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: A data type to contain fortran vector of real numbers -! -!{!pages/RealVector_.md!} - -TYPE :: RealVector_ - INTEGER(I4B) :: tDimension = 1_I4B - REAL(DFP), ALLOCATABLE :: Val(:) -END TYPE RealVector_ - -TYPE(RealVector_), PARAMETER :: TypeRealVector = RealVector_(Val=NULL()) - -TYPE :: RealVectorPointer_ - CLASS(RealVector_), POINTER :: ptr => NULL() -END TYPE RealVectorPointer_ - -!---------------------------------------------------------------------------- -! Vector3D_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! summary: Data type for 3D vectors -! date: 24 Feb 2021 - -TYPE :: Vector3D_ - INTEGER(I4B) :: tDimension = 1_I4B - REAL(DFP) :: Val(3) = 0.0_DFP -END TYPE Vector3D_ - -TYPE(Vector3D_), PARAMETER :: TypeVector3D = Vector3D_() - -!---------------------------------------------------------------------------- -! Vector3DPointer_ -!---------------------------------------------------------------------------- - -TYPE :: Vector3DPointer_ - CLASS(Vector3D_), POINTER :: ptr => NULL() -END TYPE Vector3DPointer_ - -!---------------------------------------------------------------------------- -! IndexValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: Index value keymap; useful for defining nodal boundary conditions - -TYPE :: IndexValue_ - INTEGER(I4B) :: Indx - REAL(DFP) :: Val -END TYPE - -TYPE(IndexValue_), PUBLIC, PARAMETER :: TypeIndexValue = & - & IndexValue_(Indx=0, Val=0.0_DFP) - -TYPE :: IndexValuePointer_ - CLASS(IndexValue_), POINTER :: ptr => NULL() -END TYPE IndexValuePointer_ - -!---------------------------------------------------------------------------- -! DOF_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Degree of freedom object type - -TYPE :: DOF_ - INTEGER(I4B), ALLOCATABLE :: map(:, :) - !! Encapsulation of information of DOF - INTEGER(I4B), ALLOCATABLE :: valMap(:) - !! Val map - INTEGER(I4B) :: storageFMT = FMT_NODES - !! Storage format -END TYPE DOF_ - -TYPE(DOF_), PARAMETER :: TypeDOF = DOF_(MAP=NULL(), ValMap=NULL()) - -TYPE :: DOFPointer_ - CLASS(DOF_), POINTER :: ptr => NULL() -END TYPE DOFPointer_ - -!---------------------------------------------------------------------------- -! SparseOrdering -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: SparseMatrix reordering scheme - -TYPE :: SparseMatrixReOrdering_ - CHARACTER(10) :: name - INTEGER(I4B), ALLOCATABLE :: PERM(:) - INTEGER(I4B), ALLOCATABLE :: IPERM(:) -END TYPE SparseMatrixReOrdering_ - -TYPE(SparseMatrixReOrdering_), PARAMETER :: TypeSparseMatrixReOrdering = & - & SparseMatrixReOrdering_(name='', PERM=NULL(), IPERM=NULL()) - -!---------------------------------------------------------------------------- -! CSRSparsity_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 June 2021 -! summary: User data type for handling the sparsity pattern -! -!{!pages/CSRSparsity_.md!} - -TYPE :: CSRSparsity_ - INTEGER(I4B) :: nnz = 0 - INTEGER(I4B) :: ncol = 0 - INTEGER(I4B) :: nrow = 0 - LOGICAL(LGT) :: isSorted = .FALSE. - LOGICAL(LGT) :: isInitiated = .FALSE. - LOGICAL(LGT) :: isSparsityLock = .FALSE. - LOGICAL(LGT) :: isDiagStored = .FALSE. - INTEGER(I4B), ALLOCATABLE :: IA(:) - INTEGER(I4B), ALLOCATABLE :: JA(:) - INTEGER(I4B), ALLOCATABLE :: idiag(:) - TYPE(IntVector_), ALLOCATABLE :: row(:) - TYPE(DOF_) :: idof - !! DOF for row - TYPE(DOF_) :: jdof - !! DOF for columns -END TYPE CSRSparsity_ - -TYPE(CSRSparsity_), PARAMETER :: TypeCSRSparsity = & - & CSRSparsity_(IA=NULL(), JA=NULL(), Row=NULL()) - -TYPE :: CSRSparsityPointer_ - CLASS(CSRSparsity_), POINTER :: ptr => NULL() -END TYPE CSRSparsityPointer_ - -!---------------------------------------------------------------------------- -! SuperLU_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-25 -! summary: SuperLU data structure - -#ifdef USE_SuperLU -TYPE :: SuperLU_ - TYPE(SuperMatrix) :: A - TYPE(SuperMatrix) :: B - TYPE(SuperMatrix) :: X - TYPE(SuperMatrix) :: L - TYPE(SuperMatrix) :: U - TYPE(GlobalLU_t) :: Glu - TYPE(superlu_options_t) :: options - TYPE(SuperLUStat_t) :: stat - TYPE(mem_usage_t) :: mem_usage - TYPE(C_PTR) :: Work - ! TYPE(C_PTR), POINTER :: Work - !! work-space for superlu, the size is decided by superlu - INTEGER(I4B), ALLOCATABLE :: ia(:) - !! starting index of row, size(m+1) - INTEGER(I4B), ALLOCATABLE :: ja(:) - !! column indices, size(nnz) - INTEGER(I4B), ALLOCATABLE :: perm_c(:) - !! col permutation, size(n) - INTEGER(I4B), ALLOCATABLE :: perm_r(:) - !! row permutation, size(m) - INTEGER(I4B), ALLOCATABLE :: etree(:) - !! elimination tree, size(n) - REAL(DFP), ALLOCATABLE :: nzval(:) - !! nonzero values, size(nnz) - REAL(DFP), ALLOCATABLE :: sol(:, :) - !! solution, size(n, nrhs) - REAL(DFP), ALLOCATABLE :: rhs(:, :) - !! right hand side, size(m, nrhs) - REAL(DFP), ALLOCATABLE :: R(:) - !! row digonal scaling, size(m) - REAL(DFP), ALLOCATABLE :: C(:) - !! column diagonal scaling, size(n) - REAL(DFP), ALLOCATABLE :: ferr(:) - !! size(nrhs) - REAL(DFP), ALLOCATABLE :: berr(:) - !! size(nrhs) - CHARACTER(1, kind=C_CHAR) :: equed(2) - INTEGER(C_SIZE_T) :: lwork = 0 - INTEGER(C_SIZE_T) :: info = 0 - REAL(DFP) :: recip_pivot_growth = 0.0_DFP - REAL(DFP) :: rcond = 0.0_DFP - LOGICAL(LGT) :: isAInitiated = .FALSE. - LOGICAL(LGT) :: isBInitiated = .FALSE. - LOGICAL(LGT) :: isXInitiated = .FALSE. - LOGICAL(LGT) :: isLInitiated = .FALSE. - LOGICAL(LGT) :: isUInitiated = .FALSE. - LOGICAL(LGT) :: isGluInitiated = .FALSE. - LOGICAL(LGT) :: isStatInitiated = .FALSE. -END TYPE SuperLU_ -#endif - -!---------------------------------------------------------------------------- -! CSRMatrix_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: User data type for handling CSR matrices - -TYPE :: CSRMatrix_ - LOGICAL(LGT) :: csrOwnership = .TRUE. - !! This variable, if true, denotes that csr is allocated inside the obj - INTEGER(I4B) :: tDimension = 2_I4B - CHARACTER(20) :: matrixProp = 'UNSYM' - REAL(DFP), ALLOCATABLE :: A(:) - TYPE(CSRSparsity_) :: csr -#ifdef USE_SuperLU - TYPE(SuperLU_), POINTER :: slu => NULL() -#endif -END TYPE CSRMatrix_ - -TYPE(CSRMatrix_), PARAMETER :: TypeCSRMatrix = CSRMatrix_(& - & A=NULL(), slu=NULL()) - -TYPE :: CSRMatrixPointer_ - CLASS(CSRMatrix_), POINTER :: ptr => NULL() -END TYPE CSRMatrixPointer_ - -!---------------------------------------------------------------------------- -! IterationData_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: Iteration data - -TYPE :: IterationData_ - INTEGER(I4B) :: maxIter = 100 - !! Maximum number of iterations allowed - INTEGER(I4B) :: iterationNumber = 1 - !! Iteration number - REAL(DFP) :: residualError0 = 0.0 - !! Initial Residual error - REAL(DFP) :: residualError = 0.0 - !! Current residual error - REAL(DFP) :: residualTolerance = 1.0E-5 - !! Tolerance for checking convergence in residual - REAL(DFP) :: solutionError0 = 0.0 - !! Initial solution error - REAL(DFP) :: solutionError = 0.0 - !! Current solution error - REAL(DFP) :: solutionTolerance = 1.0E-5 - !! Tolerance for checking convergence in solution - INTEGER(I4B) :: convergenceType = RelativeConvergence - !! Type of convergence - INTEGER(I4B) :: convergenceIn = ConvergenceInRes - !! Check Convergence in solution and/or residual - INTEGER(I4B) :: normType = NormL2 - !! Error norm type - LOGICAL(LGT) :: converged = .FALSE. - !! Status of convergence - REAL(DFP) :: timeAtStart = 0.0 - !! Starting time - REAL(DFP) :: timeAtEnd = 0.0 - !! Present time - REAL(DFP), ALLOCATABLE :: convergenceData(:, :) - !! history of convergence data - !! each column corresponding to a iteration - TYPE(String), ALLOCATABLE :: header(:) - !! header for convergenceData -END TYPE IterationData_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE(IterationData_), PARAMETER :: TypeIterationData = & - & IterationData_(header=NULL()) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: IterationDataPointer_ - CLASS(IterationData_), POINTER :: ptr => NULL() -END TYPE IterationDataPointer_ - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: Voigt representation of rank2 tensor - -TYPE :: VoigtRank2Tensor_ - REAL(DFP) :: V(6) = 0.0_DFP - REAL(DFP) :: Scale = 1.0_DFP - INTEGER(I4B) :: VoigtType = StressTypeVoigt -END TYPE VoigtRank2Tensor_ - -TYPE(VoigtRank2Tensor_), PARAMETER :: TypeVoigtRank2Tensor & - & = VoigtRank2Tensor_() - -TYPE :: VoigtRank2TensorPointer - CLASS(VoigtRank2Tensor_), POINTER :: ptr => NULL() -END TYPE VoigtRank2TensorPointer - -!---------------------------------------------------------------------------- -! Tensor_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-05 -! summary: General type for Tensor - -TYPE :: Tensor_ -END TYPE Tensor_ - -!---------------------------------------------------------------------------- -! Rank2Tensor_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-05 -! summary: Rank 2 tensor - -TYPE, EXTENDS(Tensor_) :: Rank2Tensor_ - REAL(DFP) :: T(3, 3) = 0.0_DFP - LOGICAL(LGT) :: isSym = .FALSE. -END TYPE Rank2Tensor_ - -TYPE(Rank2Tensor_), PARAMETER :: TypeRank2Tensor = Rank2Tensor_() - -TYPE :: Rank2TensorPointer_ - CLASS(Rank2Tensor_), POINTER :: ptr => NULL() -END TYPE Rank2TensorPointer_ - -!---------------------------------------------------------------------------- -! DeformationGradient_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-05 -! summary: Deformation gradient tensor - -TYPE, EXTENDS(Rank2Tensor_) :: DeformationGradient_ -END TYPE DeformationGradient_ - -TYPE(DeformationGradient_), PARAMETER :: TypeDeformationGradient & - & = DeformationGradient_() - -TYPE :: DeformationGradientPointer_ - CLASS(DeformationGradient_), POINTER :: ptr => NULL() -END TYPE DeformationGradientPointer_ - -!---------------------------------------------------------------------------- -! LeftCauchyGreen_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Left Cauchy Green Deformation tensor -! -!# Introduction -! This data tyoe defines Left Cauchy Green Deformation tensor, which -! is an Eulerian tensor. It is symmetric and given by -! -! $$b = F F^{T}=V^2$$ -! -!{!pages/docs-api/LeftCauchyGreen/LeftCauchyGreen_.md!} - -TYPE, EXTENDS(Rank2Tensor_) :: LeftCauchyGreen_ -END TYPE LeftCauchyGreen_ - -TYPE(LeftCauchyGreen_), PARAMETER :: TypeLeftCauchyGreen & - & = LeftCauchyGreen_() - -TYPE :: LeftCauchyGreenPointer_ - CLASS(LeftCauchyGreen_), POINTER :: ptr => NULL() -END TYPE LeftCauchyGreenPointer_ - -!---------------------------------------------------------------------------- -! RightCauchyGreen_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Right Cauchy Green Deformation tensor -! -!# Introduction -! This data tyoe defines Right Cauchy Green Deformation tensor, which is an -! Eulerian tensor. It is symmetric and given by -! -! $$b = F F^{T}=V^2$$ -! -!{!pages/RightCauchyGreen.md} - -TYPE, EXTENDS(Rank2Tensor_) :: RightCauchyGreen_ -END TYPE RightCauchyGreen_ - -TYPE(RightCauchyGreen_), PARAMETER :: TypeRightCauchyGreen & - & = RightCauchyGreen_() - -TYPE :: RightCauchyGreenPointer_ - CLASS(RightCauchyGreen_), POINTER :: ptr => NULL() -END TYPE RightCauchyGreenPointer_ - -!---------------------------------------------------------------------------- -! Strain_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(Rank2Tensor_) :: Strain_ -END TYPE Strain_ - -TYPE(Strain_), PARAMETER :: TypeStrain = Strain_() - -TYPE :: StrainPointer_ - CLASS(Strain_), POINTER :: ptr => NULL() -END TYPE StrainPointer_ - -!---------------------------------------------------------------------------- -! AlmansiStrain_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(Strain_) :: AlmansiStrain_ -END TYPE AlmansiStrain_ - -TYPE(AlmansiStrain_), PARAMETER :: TypeAlmansiStrain = AlmansiStrain_() - -TYPE :: AlmansiStrainPointer_ - CLASS(AlmansiStrain_), POINTER :: ptr => NULL() -END TYPE AlmansiStrainPointer_ - -!---------------------------------------------------------------------------- -! GreenStrain_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(Strain_) :: GreenStrain_ -END TYPE GreenStrain_ - -TYPE(GreenStrain_), PARAMETER :: TypeGreenStrain = GreenStrain_() - -TYPE :: GreenStrainPointer_ - CLASS(GreenStrain_), POINTER :: ptr => NULL() -END TYPE GreenStrainPointer_ - -!---------------------------------------------------------------------------- -! SmallStrain_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(Strain_) :: SmallStrain_ -END TYPE SmallStrain_ - -TYPE(SmallStrain_), PARAMETER :: TypeSmallStrain = SmallStrain_() - -TYPE :: SmallStrainPointer_ - CLASS(SmallStrain_), POINTER :: ptr => NULL() -END TYPE SmallStrainPointer_ - -!---------------------------------------------------------------------------- -! ReferenceTopology_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This data type is defined to handle reference topology -! -!{!pages/ReferenceElement_.md} - -TYPE :: ReferenceTopology_ - INTEGER(I4B), ALLOCATABLE :: nptrs(:) - INTEGER(I4B) :: name = 0 - INTEGER(I4B) :: xiDimension = 0 -END TYPE ReferenceTopology_ - -TYPE :: ReferenceTopologyPointer_ - CLASS(ReferenceTopology_), POINTER :: ptr => NULL() -END TYPE ReferenceTopologyPointer_ - -!---------------------------------------------------------------------------- -! ReferenceElement_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 March 2021 -! summary: An abstract data type for Reference Element -! -!{!pages/docs-api/ReferenceElement/ReferenceElement_.md!} - -TYPE :: ReferenceElement_ - CHARACTER(10) :: domainName = "GENERAL" - !! UNIT, BIUNIT, GENERAL - INTEGER(I4B) :: entityCounts(4) = 0 - !! Number of 0D, 1D, 2D, 3D entities - !! entityCounts(1) = total number of points - !! entityCounts(2) = total number of edges - !! entityCounts(3) = total number of faces - !! entityCounts(4) = total number of cells - INTEGER(I4B) :: xiDimension = 0 - !! Xidimension - INTEGER(I4B) :: name = 0 - !! name of the element - INTEGER(I4B) :: order = 0 - !! Order of element - INTEGER(I4B) :: nsd = 0 - !! Number of spatial dimensions - INTEGER(I4B) :: interpolationPointType = Equidistance - !! Interpolation point - !! Equidistance - !! GaussLegendre - !! GaussLobatto - !! Chebyshev - TYPE(ReferenceTopology_), ALLOCATABLE :: topology(:) - !! Topology information of 0D, 1, 2, 3D entities - REAL(DFP), ALLOCATABLE :: xiJ(:, :) - !! Node coord - !! Rows represents the spatial components - !! Columns represents the node number - PROCEDURE(highorder_refelem), POINTER, PASS(obj) :: & - & highOrderElement => NULL() - !! Routine to generate hgher order LagrangeElement -END TYPE ReferenceElement_ - -TYPE :: ReferenceElementPointer_ - CLASS(ReferenceElement_), POINTER :: ptr => NULL() -END TYPE ReferenceElementPointer_ - -INTERFACE - SUBROUTINE highorder_refelem(obj, order, highOrderobj, ipType) - IMPORT :: ReferenceElement_, I4B - CLASS(ReferenceElement_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: order - CLASS(ReferenceElement_), INTENT(INOUT) :: highOrderobj - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE highorder_refelem -END INTERFACE - -!---------------------------------------------------------------------------- -! ReferencePoint_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference point element -! -!{!pages/docs-api/ReferencePoint/ReferencePoint_.md!} - -TYPE, EXTENDS(ReferenceElement_) :: ReferencePoint_ -END TYPE ReferencePoint_ - -TYPE(ReferencePoint_), PARAMETER :: & - & TypeReferencePoint = ReferencePoint_( & - & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & - & xiDimension=0, name=0, & - & Topology=NULL(), Order=0, NSD=0) - -!---------------------------------------------------------------------------- -! ReferenceLine_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference line -! -!{!pages/docs-api/ReferenceLine/ReferenceLine_.md!} - -TYPE, EXTENDS(ReferenceElement_) :: ReferenceLine_ -END TYPE ReferenceLine_ - -TYPE(ReferenceLine_), PARAMETER :: & - & TypeReferenceLine = ReferenceLine_( & - & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & - & xiDimension=0, name=0, & - & Topology=NULL(), Order=0, NSD=0) - -!---------------------------------------------------------------------------- -! ReferenceTriangle_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference triangle -! -!{!pages/ReferenceTriangle.md} -TYPE, EXTENDS(ReferenceElement_) :: ReferenceTriangle_ -END TYPE ReferenceTriangle_ - -TYPE(ReferenceTriangle_), PARAMETER :: & - & TypeReferenceTriangle = ReferenceTriangle_( & - & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & - & xiDimension=0, name=0, & - & Topology=NULL(), Order=0, NSD=0) - -!---------------------------------------------------------------------------- -! ReferenceQuadrangle_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference quadrangle -! -!{!pages/ReferenceQuadrangle/ReferenceQuadrangle_.md!} - -TYPE, EXTENDS(ReferenceElement_) :: ReferenceQuadrangle_ -END TYPE ReferenceQuadrangle_ - -TYPE(ReferenceQuadrangle_), PARAMETER :: & - & TypeReferenceQuadrangle & - & = ReferenceQuadrangle_( & - & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & - & xiDimension=0, name=0, & - & Topology=NULL(), Order=0, NSD=0) - -!---------------------------------------------------------------------------- -! ReferenceTetrahedron_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference tetrahedron -! -!{!pages/ReferenceTetrahedron/ReferenceTetrahedron_.md!} - -TYPE, EXTENDS(ReferenceElement_) :: ReferenceTetrahedron_ -END TYPE ReferenceTetrahedron_ - -TYPE(ReferenceTetrahedron_), PARAMETER :: & - & TypeReferenceTetrahedron & - & = ReferenceTetrahedron_( & - & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], xiDimension=0, name=0, & - & Topology=NULL(), Order=0, NSD=0) - -!---------------------------------------------------------------------------- -! ReferenceHexahedron_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference hexahedron -! -!{!pages/docs-api/ReferenceHexahedron/ReferenceHexahedron_.md} - -TYPE, EXTENDS(ReferenceElement_) :: ReferenceHexahedron_ -END TYPE ReferenceHexahedron_ - -TYPE(ReferenceHexahedron_), PARAMETER :: & - & TypeReferenceHexahedron & - & = ReferenceHexahedron_( & - & XiJ=NULL(), & - & EntityCounts=[0, 0, 0, 0], & - & xiDimension=0, & - & name=0, & - & Topology=NULL(), & - & Order=0, & - & NSD=0) - -!---------------------------------------------------------------------------- -! ReferencePrism_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference prism -! -!{!pages/ReferencePrism.md} - -TYPE, EXTENDS(ReferenceElement_) :: ReferencePrism_ -END TYPE ReferencePrism_ - -TYPE(ReferencePrism_), PARAMETER :: TypeReferencePrism & - & = ReferencePrism_( & - & XiJ=NULL(), & - & EntityCounts=[0, 0, 0, 0], & - & xiDimension=0, & - & name=0, & - & Topology=NULL(), & - & Order=0, & - & NSD=0) - -!---------------------------------------------------------------------------- -! ReferencePyramid_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This data type defines a reference pyramid -! -!{!pages/ReferencePyramid.md} - -TYPE, EXTENDS(ReferenceElement_) :: ReferencePyramid_ -END TYPE ReferencePyramid_ - -TYPE(ReferencePyramid_), PARAMETER :: TypeReferencePyramid & - & = ReferencePyramid_( & - & XiJ=NULL(), & - & EntityCounts=[0, 0, 0, 0], & - & xiDimension=0, & - & name=0, & - & Topology=NULL(), & - & Order=0, & - & NSD=0) - -!---------------------------------------------------------------------------- -! KeyValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: [[keyvalue_]] is a poor implementation of dict - -TYPE :: KeyValue_ - INTEGER(I4B) :: DataType = 0 - TYPE(String) :: Key - REAL(DFP), ALLOCATABLE :: VALUE(:, :) -END TYPE KeyValue_ - -TYPE(KeyValue_), PARAMETER :: TypeKeyValue = KeyValue_(VALUE=NULL()) - -!---------------------------------------------------------------------------- -! FEVariable_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: Finite element variable -! -! {!pages/FEVariable_.md!} - -TYPE :: FEVariable_ - REAL(DFP), ALLOCATABLE :: val(:) - !! values - 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 - INTEGER(I4B) :: rank = 0 - !! Scalar - !! Vector - !! Matrix - INTEGER(I4B) :: len = 0_I4B - !! current total size - INTEGER(I4B) :: capacity = 0_I4B - !! capacity of the val -END TYPE FEVariable_ - -TYPE(FEVariable_), PARAMETER :: TypeFEVariable = FEVariable_(val=NULL()) - -!---------------------------------------------------------------------------- -! FEVariableConstant_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: FEVariable Constant - -TYPE :: FEVariableConstant_ -!! INTEGER(I4B):: Val = 1 -END TYPE FEVariableConstant_ - -TYPE(FEVariableConstant_), PARAMETER :: TypeFEVariableConstant = & - & FEVariableConstant_() - -TYPE(FEVariableConstant_), PARAMETER :: TypeVariableConstant = & - & FEVariableConstant_() - -!---------------------------------------------------------------------------- -! FEVariableSpace_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: FEVariable Space -! -TYPE :: FEVariableSpace_ -!! INTEGER(I4B):: Val = 2 -END TYPE FEVariableSpace_ - -TYPE(FEVariableSpace_), PARAMETER :: TypeFEVariableSpace = & - & FEVariableSpace_() -TYPE(FEVariableSpace_), PARAMETER :: TypeVariableSpace = & - & FEVariableSpace_() - -!---------------------------------------------------------------------------- -! FEVariableSpaceTime_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: FEVariable Space time - -TYPE :: FEVariableSpaceTime_ -!! INTEGER(I4B):: Val = 3 -END TYPE FEVariableSpaceTime_ - -TYPE(FEVariableSpaceTime_), PARAMETER :: TypeFEVariableSpaceTime & - & = FEVariableSpaceTime_() -TYPE(FEVariableSpaceTime_), PARAMETER :: TypeVariableSpaceTime & - & = FEVariableSpaceTime_() - -!---------------------------------------------------------------------------- -! FEVariableTime_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: FEVariable time - -TYPE :: FEVariableTime_ -!! INTEGER(I4B):: Val = 4 -END TYPE FEVariableTime_ - -TYPE(FEVariableTime_), PARAMETER :: TypeFEVariableTime = FEVariableTime_() -TYPE(FEVariableTime_), PARAMETER :: TypeVariableTime = FEVariableTime_() - -!---------------------------------------------------------------------------- -! FEVariableScalar_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: FEVariable scalar - -TYPE :: FEVariableScalar_ -!! INTEGER(I4B):: Val = 0 -END TYPE FEVariableScalar_ - -TYPE(FEVariableScalar_), PARAMETER :: TypeFEVariableScalar & - & = FEVariableScalar_() - -TYPE(FEVariableScalar_), PARAMETER :: TypeVariableScalar & - & = FEVariableScalar_() - -!---------------------------------------------------------------------------- -! FEVariableVector_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: FEVariable vector - -TYPE :: FEVariableVector_ -!! INTEGER(I4B):: Val = 1 -END TYPE FEVariableVector_ - -TYPE(FEVariableVector_), PARAMETER :: TypeFEVariableVector & - & = FEVariableVector_() - -TYPE(FEVariableVector_), PARAMETER :: TypeVariableVector & - & = FEVariableVector_() - -!---------------------------------------------------------------------------- -! FEVariableMatrix_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: FEVariable matrix - -TYPE :: FEVariableMatrix_ -!! INTEGER(I4B):: Val = 2 -END TYPE FEVariableMatrix_ - -TYPE(FEVariableMatrix_), PARAMETER :: TypeFEVariableMatrix & - & = FEVariableMatrix_() -TYPE(FEVariableMatrix_), PARAMETER :: TypeVariableMatrix & - & = FEVariableMatrix_() - -!---------------------------------------------------------------------------- -! QuadraturePoint_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Quadrature points for numerical integration -! -!{!pages/docs-api/QuadraturePoint/QuadraturePoint_.md!} - -TYPE :: QuadraturePoint_ - REAL(DFP), ALLOCATABLE :: points(:, :) - INTEGER(I4B) :: txi = 0 -END TYPE QuadraturePoint_ - -TYPE(QuadraturePoint_), PARAMETER :: TypeQuadraturePoint & - & = QuadraturePoint_(points=NULL()) - -TYPE :: QuadraturePointPointer_ - CLASS(QuadraturePoint_), POINTER :: ptr => NULL() -END TYPE QuadraturePointPointer_ - -!---------------------------------------------------------------------------- -! BasisInterpolation_ -!---------------------------------------------------------------------------- - -TYPE :: BaseInterpolation_ -END TYPE BaseInterpolation_ - -!---------------------------------------------------------------------------- -! LagrangeInterpolation_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Lagrange basis functions - -TYPE, EXTENDS(BaseInterpolation_) :: LagrangeInterpolation_ -END TYPE LagrangeInterpolation_ - -TYPE(LagrangeInterpolation_), PARAMETER :: TypeLagrangeInterpolation & - & = LagrangeInterpolation_() - -!---------------------------------------------------------------------------- -! HermitInterpolation_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Hermit basis functions - -TYPE, EXTENDS(BaseInterpolation_) :: HermitInterpolation_ -END TYPE HermitInterpolation_ - -TYPE(HermitInterpolation_), PARAMETER :: TypeHermitInterpolation & - & = HermitInterpolation_() - -!---------------------------------------------------------------------------- -! SerendipityInterpolation_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Serendipity basis functions - -TYPE, EXTENDS(BaseInterpolation_) :: SerendipityInterpolation_ -END TYPE SerendipityInterpolation_ - -TYPE(SerendipityInterpolation_), PARAMETER :: TypeSerendipityInterpolation & - & = SerendipityInterpolation_() - -!---------------------------------------------------------------------------- -! HierarchyInterpolation_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Hierarchical basis functions - -TYPE, EXTENDS(BaseInterpolation_) :: HierarchyInterpolation_ -END TYPE HierarchyInterpolation_ - -TYPE(HierarchyInterpolation_), PARAMETER :: TypeHierarchyInterpolation & - & = HierarchyInterpolation_() - -!---------------------------------------------------------------------------- -! OrthogonalInterpolation_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Orthogonal basis functions - -TYPE, EXTENDS(BaseInterpolation_) :: OrthogonalInterpolation_ -END TYPE OrthogonalInterpolation_ - -TYPE(OrthogonalInterpolation_), PARAMETER :: TypeOrthogonalInterpolation & - & = OrthogonalInterpolation_() - -!---------------------------------------------------------------------------- -! BaseContinuity_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-03 -! summary: Continuity of basis functions -! -!# Introduction -! -! `BaseContinuity_` denotes the Continuity or conformity of basis functions. -! Following values are allowed: -! -! - H1_ -! - HDIV_ -! - HCURL_ -! - DG_ - -TYPE :: BaseContinuity_ -END TYPE BaseContinuity_ - -TYPE(BaseContinuity_), PARAMETER :: TypeBaseContinuity = BaseContinuity_() - -!---------------------------------------------------------------------------- -! H1_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(BaseContinuity_) :: H1_ -END TYPE H1_ - -TYPE(H1_), PARAMETER :: TypeH1 = H1_() - -!---------------------------------------------------------------------------- -! H1DIV_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(BaseContinuity_) :: HDIV_ -END TYPE HDIV_ - -TYPE(HDIV_), PARAMETER :: TypeHDIV = HDIV_() - -!---------------------------------------------------------------------------- -! HCURL_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(BaseContinuity_) :: HCURL_ -END TYPE HCURL_ - -TYPE(HCURL_), PARAMETER :: TypeHCURL = HCURL_() - -!---------------------------------------------------------------------------- -! DG_ -!---------------------------------------------------------------------------- - -TYPE, EXTENDS(BaseContinuity_) :: DG_ -END TYPE DG_ - -TYPE(DG_), PARAMETER :: TypeDG = DG_() - -!---------------------------------------------------------------------------- -! Derivative -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-06 -! update: 2021-11-06 -! summary: Derivative class contains symbols for derivatives - -INTEGER(I4B), PARAMETER :: DEL_NONE = 0 -INTEGER(I4B), PARAMETER :: DEL_X = 1 -INTEGER(I4B), PARAMETER :: DEL_Y = 2 -INTEGER(I4B), PARAMETER :: DEL_Z = 3 -INTEGER(I4B), PARAMETER :: DEL_X_ALL = 4 -INTEGER(I4B), PARAMETER :: DEL_t = -1 - -!---------------------------------------------------------------------------- -! ElementData_ -!---------------------------------------------------------------------------- - -TYPE :: ElementData_ - INTEGER(I4B) :: NSD = -1 - INTEGER(I4B) :: NNE = -1 - INTEGER(I4B) :: NNS = -1 - INTEGER(I4B) :: NNT = -1 - INTEGER(I4B) :: xiDimension = -1 - INTEGER(I4B) :: ElemTopology = -1 - INTEGER(I4B) :: SpaceElemTopo = -1 - INTEGER(I4B) :: TimeElemTopo = -1 - INTEGER(I4B) :: ElemType = -1 - INTEGER(I4B) :: MAT_Type = -1 -END TYPE ElementData_ - -TYPE(ElementData_), PARAMETER :: TypeElementData = ElementData_() - -TYPE :: ElementDataPointer_ - CLASS(ElementData_), POINTER :: ptr => NULL() -END TYPE ElementDataPointer_ - -!---------------------------------------------------------------------------- -! ShapeData_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: shape function data (deprecated) - -TYPE :: ShapeData_ - REAL(DFP) :: Ws = 0.0_DFP - REAL(DFP) :: Js = 0.0_DFP - REAL(DFP) :: Thickness = 1.0_DFP - REAL(DFP) :: Xi(3) = 0.0_DFP - REAL(DFP) :: XBar(3) = 0.0_DFP - REAL(DFP) :: Normal(3) = 0.0_DFP - INTEGER(I4B) :: ElemTopology = 0 - INTEGER(I4B) :: NSD = 0 - REAL(DFP), ALLOCATABLE :: N(:) - REAL(DFP), ALLOCATABLE :: dNdXi(:, :) - REAL(DFP), ALLOCATABLE :: dNdXt(:, :) - REAL(DFP), ALLOCATABLE :: Jacobian(:, :) -END TYPE ShapeData_ - -TYPE(ShapeData_), PARAMETER :: & - & TypeShapeData = ShapeData_( & - & N=NULL(), & - & dNdXi=NULL(), & - & dNdXt=NULL(), & - & Jacobian=NULL()) - -TYPE :: ShapeDataPointer_ - CLASS(ShapeDataPointer_), POINTER :: ptr => NULL() -END TYPE ShapeDataPointer_ - -!---------------------------------------------------------------------------- -! STShapeData_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 June 2022 -! summary: Datatype for space-time shape data - -TYPE, EXTENDS(ShapeData_) :: STShapeData_ - REAL(DFP) :: Theta = 0.0 - REAL(DFP) :: Wt = 0.0 - REAL(DFP) :: Jt = 0.0 - INTEGER(I4B) :: SpaceElemTopo = 0 - INTEGER(I4B) :: TimeElemTopo = 0 - REAL(DFP), ALLOCATABLE :: T(:) - !! values of shape function at different time nodes - REAL(DFP), ALLOCATABLE :: dTdTheta(:) - !! Value of local time derivative of T at time gauss point - REAL(DFP), ALLOCATABLE :: dNTdt(:, :) - !! Value of global time derivative of T at time gauss points - REAL(DFP), ALLOCATABLE :: dNTdXt(:, :, :) - !! Spatial gradient of the shape functions at space-time gauss points -END TYPE STShapeData_ - -TYPE :: STShapeDataPointer_ - CLASS(STShapeData_), POINTER :: ptr => NULL() -END TYPE STShapeDataPointer_ - -!---------------------------------------------------------------------------- -! ElemShapeData_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Datatype for data defined at all gauss points of an elements -! -!{!pages/docs-api/ElemShapeData/ElemshapeData_.md!} -! -TYPE :: ElemShapeData_ - REAL(DFP), ALLOCATABLE :: N(:, :) - !! Shape function value `N(I, ips)` - REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) - !! Local derivative of a shape function - REAL(DFP), ALLOCATABLE :: jacobian(:, :, :) - !! Jacobian of mapping `J(:,:,ips)` also $\mathbf{F}_{\Xi x}$ - REAL(DFP), ALLOCATABLE :: js(:) - !! Determinant of Jacobian at ips - REAL(DFP), ALLOCATABLE :: ws(:) - !! Weighting functions - REAL(DFP), ALLOCATABLE :: dNdXt(:, :, :) - !! Spatial derivative of shape function - REAL(DFP), ALLOCATABLE :: thickness(:) - !! Thickness of element - REAL(DFP), ALLOCATABLE :: coord(:, :) - !! Barycentric coordinate - REAL(DFP), ALLOCATABLE :: normal(:, :) - !! Normal in case of facet element - TYPE(ReferenceElement_) :: refelem - !! Refererece element - TYPE(QuadraturePoint_) :: quad - !! Quadrature points -END TYPE ElemShapeData_ - -TYPE(ElemShapeData_), PARAMETER :: & - & TypeElemShapeData = ElemShapeData_( & - & N=NULL(), & - & dNdXi=NULL(), & - & Jacobian=NULL(), & - & Js=NULL(), & - & Ws=NULL(), & - & dNdXt=NULL(), & - & Thickness=NULL(), & - & Coord=NULL(), & - & Normal=NULL()) - -TYPE :: ElemShapeDataPointer_ - CLASS(ShapeDataPointer_), POINTER :: ptr => NULL() -END TYPE ElemShapeDataPointer_ - -!---------------------------------------------------------------------------- -! STElemShapeData_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-08 -! update: 2021-12-08 -! summary: Space-time shape function data - -TYPE, EXTENDS(ElemShapeData_) :: STElemShapeData_ - REAL(DFP) :: wt = 0.0 - !! Weight of gauss point in time domain - REAL(DFP) :: theta = 0.0 - !! Gauss point in time domain - REAL(DFP) :: jt = 0.0 - !! Jacobian $\frac{dt}{d\theta}$ - REAL(DFP), ALLOCATABLE :: T(:) - !! Shape function in time domain - REAL(DFP), ALLOCATABLE :: dTdTheta(:) - !! Local shape function derivative in time domain - REAL(DFP), ALLOCATABLE :: dNTdt(:, :, :) - REAL(DFP), ALLOCATABLE :: dNTdXt(:, :, :, :) - !! (I, a, i, ips) -END TYPE STElemShapeData_ - -TYPE(STElemShapeData_), PARAMETER :: & - & TypeSTElemShapeData = STElemShapeData_( & - & N=NULL(), & - & dNdXi=NULL(), & - & Jacobian=NULL(), & - & Js=NULL(), & - & Ws=NULL(), & - & dNdXt=NULL(), & - & Thickness=NULL(), & - & Coord=NULL(), & - & Normal=NULL(), & - & T=NULL(), & - & dTdTheta=NULL(), & - & dNTdt=NULL(), & - & dNTdXt=NULL()) - -!---------------------------------------------------------------------------- -! Meshquality_ -!---------------------------------------------------------------------------- - -TYPE :: QualityMeasure_ - INTEGER(I4B), PUBLIC :: area = 100 - INTEGER(I4B), PUBLIC :: maxAngle = 101 - INTEGER(I4B), PUBLIC :: minAngle = 102 - INTEGER(I4B), PUBLIC :: AngleRatio = 103 - INTEGER(I4B), PUBLIC :: RadiusRatio = 104 - INTEGER(I4B), PUBLIC :: EdgeRatio = 105 - INTEGER(I4B), PUBLIC :: AspectRatio = 106 - INTEGER(I4B), PUBLIC :: ScaledJacobian = 107 - INTEGER(I4B), PUBLIC :: Default = 106 -END TYPE QualityMeasure_ - -TYPE(QualityMeasure_), PARAMETER :: QualityMeasure = QualityMeasure_() - -!---------------------------------------------------------------------------- -! Random_ -!---------------------------------------------------------------------------- - -TYPE :: Random_ - INTEGER(I4B) :: random_int = 100 - INTEGER(I4B), ALLOCATABLE :: random_int_seed(:) - INTEGER(I4B), ALLOCATABLE :: random_int_vec(:) - REAL(DFP) :: random_real = 0.0_DFP - REAL(DFP), ALLOCATABLE :: random_real_vec(:) -END TYPE - -TYPE(Random_), PARAMETER :: & - & TypeRandom = Random_(random_int_seed=NULL(), & - & random_int_vec=NULL(), & - & random_real_vec=NULL()) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 March 2021 -! summary: OpenMP and EASIFEM -TYPE :: OpenMP_ - INTEGER(I4B) :: Rank = 0 - INTEGER(I4B) :: NUM_THREADS = 1 - INTEGER(I4B) :: MAX_THREADS = 1 - INTEGER(I4B) :: STATE = OMP_THREADS_JOINED - LOGICAL(LGT) :: IS_INIT = .FALSE. - LOGICAL(LGT) :: DID_I_INIT = .FALSE. -END TYPE OpenMP_ - -TYPE(OpenMP_), PARAMETER :: TypeOpenMP = OpenMP_() -TYPE(OpenMP_) :: OMP -!$OMP THREADPRIVATE( OMP ) - -!---------------------------------------------------------------------------- -! MultiIndices_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Multi-indices object is defined - -TYPE :: MultiIndices_ - INTEGER(I4B) :: d - !! dimension of simplex - INTEGER(I4B) :: n - !! order -END TYPE MultiIndices_ - -!---------------------------------------------------------------------------- -! Range_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-09 -! summary: Range denotes the triplet index - -TYPE :: Range_ - INTEGER(I4B) :: is = 0_I4B - !! istart - INTEGER(I4B) :: ie = 0_I4B - !! iend - INTEGER(I4B) :: ic = 1_I4B - !! increment -END TYPE Range_ - -!---------------------------------------------------------------------------- -! Interval1D_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-09 -! summary: Interval1D_ denotes the 1d interval - -TYPE :: Interval1D_ - REAL(DFP) :: lower -!! lower limit - REAL(DFP) :: upper -!! upper limit -END TYPE Interval1D_ - -!---------------------------------------------------------------------------- -! SpaceTimeFunction -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_SpaceTimeFunction(x, t) RESULT(ans) - IMPORT :: DFP - ! CLASS( DirichletBC_ ), INTENT( IN ):: obj - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(IN) :: t - REAL(DFP) :: ans - END FUNCTION iface_SpaceTimeFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! SpaceFunction -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_SpaceFunction(x) RESULT(ans) - IMPORT :: DFP - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans - END FUNCTION iface_SpaceFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! TimeFunction -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_TimeFunction(t) RESULT(ans) - IMPORT :: DFP - REAL(DFP), INTENT(IN) :: t - REAL(DFP) :: ans - END FUNCTION iface_TimeFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! 1DFunction -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_1DFunction(x) RESULT(ans) - IMPORT :: DFP - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION iface_1DFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! 2DFunction -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_2DFunction(x, y) RESULT(ans) - IMPORT :: DFP - REAL(DFP), INTENT(IN) :: x, y - REAL(DFP) :: ans - END FUNCTION iface_2DFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! 3DFunction -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_3DFunction(x, y, z) RESULT(ans) - IMPORT :: DFP - REAL(DFP), INTENT(IN) :: x, y, z - REAL(DFP) :: ans - END FUNCTION iface_3DFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! ScalarFunction -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_ScalarFunction(x) RESULT(ans) - IMPORT :: DFP - REAL(DFP), OPTIONAL, INTENT(IN) :: x(:) - REAL(DFP) :: ans - END FUNCTION iface_ScalarFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_VectorFunction(x) RESULT(ans) - IMPORT :: DFP - REAL(DFP), OPTIONAL, INTENT(IN) :: x(:) - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION iface_VectorFunction -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE - PURE FUNCTION iface_MatrixFunction(x) RESULT(ans) - IMPORT :: DFP - REAL(DFP), OPTIONAL, INTENT(IN) :: x(:) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION iface_MatrixFunction -END INTERFACE - -END MODULE BaseType diff --git a/src/modules/BeFoR64/CMakeLists.txt b/src/modules/BeFoR64/CMakeLists.txt deleted file mode 100644 index c276252ab..000000000 --- a/src/modules/BeFoR64/CMakeLists.txt +++ /dev/null @@ -1,64 +0,0 @@ -# set type specific output defaults -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/befor64.F90 - ${src_path}/befor64_pack_data_m.F90 - ) - -# set variables used for compile definitions of targets after support check -include(CheckFortranSourceRuns) -check_fortran_source_runs( - "program r16p_support; - integer, parameter :: r16p = selected_real_kind(33, 4931); - if(r16p < 0) stop 1; - end program r16p_support" - R16P_SUPPORTED - SRC_EXT f90 - ) -IF(R16P_SUPPORTED) - SET(r16p_supported "-D_R16P") -ENDIF() - -check_fortran_source_runs( - "program ascii_support; - integer, parameter :: ascii = selected_char_kind('ascii'); - if(ascii < 0) stop 1; - end program ascii_support" - ASCII_SUPPORTED - SRC_EXT f90) -IF(ASCII_SUPPORTED) - SET(ascii_supported "-D_ASCII_SUPPORTED") -ENDIF() - -check_fortran_source_runs( - "program ascii_neq_default; - integer, parameter :: ascii = selected_char_kind('ascii'); - integer, parameter :: default = selected_char_kind('default'); - if(ascii == default) stop 1; - end program ascii_neq_default" - ASCII_NEQ_DEFAULT - SRC_EXT f90 - ) - -IF(ASCII_NEQ_DEFAULT) - SET(ascii_neq_default "-D_ASCII_NEQ_DEFAULT") -ENDIF() - -check_fortran_source_runs( - "program ucs4_support; - integer, parameter :: ucs4 = selected_char_kind('iso_10646'); - if(ucs4 < 0) stop 1; - end program ucs4_support" - UCS4_SUPPORTED - SRC_EXT f90 - ) - -IF(UCS4_SUPPORTED) - SET(ucs4_supported "-D_UCS4_SUPPORTED") -ENDIF() - -LIST( APPEND TARGET_COMPILE_DEF ${r16p_supported} ) -LIST( APPEND TARGET_COMPILE_DEF ${ascii_supported} ) -LIST( APPEND TARGET_COMPILE_DEF ${ascii_neq_default} ) -LIST( APPEND TARGET_COMPILE_DEF ${ucs4_supported} ) \ No newline at end of file diff --git a/src/modules/BeFoR64/src/befor64.F90 b/src/modules/BeFoR64/src/befor64.F90 deleted file mode 100644 index 1ed72dc2d..000000000 --- a/src/modules/BeFoR64/src/befor64.F90 +++ /dev/null @@ -1,1122 +0,0 @@ -!< BeFoR64, Base64 encoding/decoding library for FoRtran poor people. - -module befor64 -!< BeFoR64, Base64 encoding/decoding library for FoRtran poor people. -use penf -use befor64_pack_data_m - -implicit none -private -public :: is_b64_initialized, b64_init -public :: b64_encode, b64_encode_up -public :: b64_decode, b64_decode_up -public :: pack_data - -logical :: is_b64_initialized=.false. !< Flag for checking the initialization of the library. -character(64) :: base64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" !< Base64 alphabet. - -interface b64_encode - !< Encode numbers (integer and real) to base64. - !< - !< This is an interface for encoding integer and real numbers of any kinds into a base64 string. This interface can encode both - !< scalar and array. - !< - !< @warning The encoded string is returned as varying length character string, `character(len=:), allocatable:: string`, thus the - !< compiler must support such a Fortran (2003) feature. - !< - !< @note Before start to encode anything the library must be initialized. The procedure `b64_init` must be called at first. The - !< global variable `is_b64_initialized` can be used to check the status of the initialization. - !< - !<### Usage - !< For a practical example see the `autotest` procedure. - !< - !<#### Scalar encoding - !<```ortran - ! T <<< - - if (.not.is_initialized) call penf_init - is_b64_initialized = .true. - endsubroutine b64_init - - pure subroutine encode_bits(bits, padd, code) - !< Encode a bits stream (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4). - !< - !< The bits stream are encoded in chunks of 24 bits as the following example (in little endian order) - !<``` - !< +--first octet--+-second octet--+--third octet--+ - !< |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0| - !< +-----------+---+-------+-------+---+-----------+ - !< |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0| - !< +--1.index--+--2.index--+--3.index--+--4.index--+ - !<``` - !< @note The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used. - !< - !< @note The number of paddings must be computed outside this procedure, into the calling scope. - !< - !< @warning This procedure is the backend of encoding, thus it must be never called outside the module. - integer(I1P), intent(in) :: bits(1:) !< Bits to be encoded. - integer(I4P), intent(in) :: padd !< Number of padding characters ('='). - character(*), intent(out) :: code !< Characters code. - integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. - integer(I8P) :: c !< Counter. - integer(I8P) :: e !< Counter. - integer(I8P) :: Nb !< Length of bits array. - - Nb=size(bits,dim=1,kind=I8P) - c = 1_I8P - do e=1_I8P,Nb,3_I8P ! loop over array elements: 3 bytes (24 bits) scanning - sixb = 0_I1P - call mvbits(bits(e ),2,6,sixb(1),0) - call mvbits(bits(e ),0,2,sixb(2),4) - if (e+1<=Nb) then - call mvbits(bits(e+1),4,4,sixb(2),0) - call mvbits(bits(e+1),0,4,sixb(3),2) - endif - if (e+2<=Nb) then - call mvbits(bits(e+2),6,2,sixb(3),0) - call mvbits(bits(e+2),0,6,sixb(4),0) - endif - sixb = sixb + 1_I1P - code(c :c ) = base64(sixb(1):sixb(1)) - code(c+1:c+1) = base64(sixb(2):sixb(2)) - code(c+2:c+2) = base64(sixb(3):sixb(3)) - code(c+3:c+3) = base64(sixb(4):sixb(4)) - c = c + 4_I8P - enddo - if (padd>0) code(len(code)-padd+1:)=repeat('=',padd) - endsubroutine encode_bits - - pure subroutine decode_bits(code, bits) - !< Decode a base64 string into a sequence of bits stream. - !< - !< The base64 string must be parsed with a strike of 4 characters and converted into a 3 bytes stream. Considering the base64 code - !< `QUJD` the decoding process must do - !<``` - !< +-b64 char--+-b64 char--+-b64 char--+-b64 char--+ - !< | Q | U | J | D | - !< +-b64 index-+-b64 index-+-b64 index-+-b64 index-+ - !< ! 16 | 20 | 9 | 3 | - !< +-6 bits----+-6 bits----+-6 bits----+-6 bits----+ - !< |0 1 0 0 0 0|0 1 0 1 0 0|0 0 1 0 0 1|0 0 0 0 1 1| - !< +-----------+---+-------+-------+---+-----------+ - !< |0 1 0 0 0 0 0 1|0 1 0 0 0 0 1 0|0 1 0 0 0 0 1 1| - !< +-----8 bits----+-----8 bits----+-----8 bits----+ - !<``` - !< @note The bits pattern is returned as a 1-byte element array, the dimension of witch must be computed outside this procedure. - !< - !< @warning This procedure is the backend of decoding, thus it must be never called outside the module. - character(*), intent(in) :: code !< Characters code. - integer(I1P), intent(out) :: bits(1:) !< Bits decoded. - integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. - integer(I8P) :: c !< Counter. - integer(I8P) :: e !< Counter. - integer(I8P) :: Nb !< Length of bits array. - - Nb=size(bits,dim=1,kind=I8P) - e = 1_I8P - do c=1_I8P,len(code),4_I8P ! loop over code characters: 3 bytes (24 bits) scanning - sixb = 0_I1P - sixb(1) = index(base64,code(c :c )) - 1 - sixb(2) = index(base64,code(c+1:c+1)) - 1 - sixb(3) = index(base64,code(c+2:c+2)) - 1 - sixb(4) = index(base64,code(c+3:c+3)) - 1 - call mvbits(sixb(1),0,6,bits(e ),2) ; call mvbits(sixb(2),4,2,bits(e ),0) - if (e+1<=Nb) then - call mvbits(sixb(2),0,4,bits(e+1),4) ; call mvbits(sixb(3),2,4,bits(e+1),0) - endif - if (e+2<=Nb) then - call mvbits(sixb(3),0,2,bits(e+2),6) ; call mvbits(sixb(4),0,6,bits(e+2),0) - endif - e = e + 3_I8P - enddo - endsubroutine decode_bits - - subroutine b64_encode_up(up, code) - !< Encode an unlimited polymorphic scalar to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode_up(up=1._R8P, code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAAAA8D8= <<< - class(*), intent(in) :: up !< Unlimited polymorphic variable to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - - select type(up) - type is(real(R8P)) - call b64_encode_R8(n=up,code=code) - type is(real(R4P)) - call b64_encode_R4(n=up,code=code) - type is(integer(I8P)) - call b64_encode_I8(n=up,code=code) - type is(integer(I4P)) - call b64_encode_I4(n=up,code=code) - type is(integer(I2P)) - call b64_encode_I2(n=up,code=code) - type is(integer(I1P)) - call b64_encode_I1(n=up,code=code) - type is(character(*)) - call b64_encode_string(s=up,code=code) - endselect - endsubroutine b64_encode_up - - pure subroutine b64_encode_up_a(up, code) - !< Encode an unlimited polymorphic array to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode_up(up=[0._R4P,-32.12_R4P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAOF6AMI= <<< - class(*), intent(in) :: up(1:) !< Unlimited polymorphic variable to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - - select type(up) - type is(real(R8P)) - call b64_encode_R8_a(n=up,code=code) - type is(real(R4P)) - call b64_encode_R4_a(n=up,code=code) - type is(integer(I8P)) - call b64_encode_I8_a(n=up,code=code) - type is(integer(I4P)) - call b64_encode_I4_a(n=up,code=code) - type is(integer(I2P)) - call b64_encode_I2_a(n=up,code=code) - type is(integer(I1P)) - call b64_encode_I1_a(n=up,code=code) - type is(character(*)) - call b64_encode_string_a(s=up,code=code) - endselect - endsubroutine b64_encode_up_a - - subroutine b64_decode_up(code, up) - !< Decode an unlimited polymorphic scalar from base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: scalar_I4 - !< call b64_decode_up(code='5wcAAA==',up=scalar_I4) - !< print "(L1)", scalar_I4==2023_I4P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - class(*), intent(out) :: up !< Unlimited polymorphic variable to be decoded. - - select type(up) - type is(real(R8P)) - call b64_decode_R8(code=code,n=up) - type is(real(R4P)) - call b64_decode_R4(code=code,n=up) - type is(integer(I8P)) - call b64_decode_I8(code=code,n=up) - type is(integer(I4P)) - call b64_decode_I4(code=code,n=up) - type is(integer(I2P)) - call b64_decode_I2(code=code,n=up) - type is(integer(I1P)) - call b64_decode_I1(code=code,n=up) - type is(character(*)) - call b64_decode_string(code=code,s=up) - endselect - endsubroutine b64_decode_up - - subroutine b64_decode_up_a(code, up) - !< Decode an unlimited polymorphic array from base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: array_I8(1:4) - !< call b64_decode_up(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=', up=array_I8) - !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - class(*), intent(out) :: up(1:) !< Unlimited polymorphic variable to be decoded. - - select type(up) - type is(real(R8P)) - call b64_decode_R8_a(code=code,n=up) - type is(real(R4P)) - call b64_decode_R4_a(code=code,n=up) - type is(integer(I8P)) - call b64_decode_I8_a(code=code,n=up) - type is(integer(I4P)) - call b64_decode_I4_a(code=code,n=up) - type is(integer(I2P)) - call b64_decode_I2_a(code=code,n=up) - type is(integer(I1P)) - call b64_decode_I1_a(code=code,n=up) - type is(character(*)) - call b64_decode_string_a(code=code,s=up) - endselect - endsubroutine b64_decode_up_a - - pure subroutine b64_encode_R16(n, code) - !< Encode scalar number to base64 (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=134.231_R16P, code=code64) - !< print "(A)", code64 - !<``` - !=> CKwcWmTHYEA= <<< - real(R16P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYR16P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYR16P+2)/3)*4) - nI1P = transfer(n,nI1P) -#if defined _R16P - padd = mod((BYR16P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd -#else - padd = mod((BYR16P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd -#endif - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R16 - - pure subroutine b64_encode_R8(n, code) - !< Encode scalar number to base64 (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=1._R8P, code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAAAA8D8= <<< - real(R8P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYR8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYR8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYR8P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R8 - - pure subroutine b64_encode_R4(n, code) - !< Encode scalar number to base64 (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=0._R4P, code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAA== <<< - real(R4P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYR4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYR4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYR4P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R4 - - pure subroutine b64_encode_I8(n, code) - !< Encode scalar number to base64 (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=23_I8P, code=code64) - !< print "(A)", code64 - !<``` - !=> FwAAAAAAAAA= <<< - integer(I8P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I8 - - pure subroutine b64_encode_I4(n, code) - !< Encode scalar number to base64 (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=2023_I4P, code=code64) - !< print "(A)", code64 - !<``` - !=> 5wcAAA== <<< - integer(I4P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI4P),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I4 - - pure subroutine b64_encode_I2(n, code) - !< Encode scalar number to base64 (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=-203_I2P, code=code64) - !< print "(A)", code64 - !<``` - !=> Nf8= <<< - integer(I2P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI2P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI2P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI2P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I2 - - pure subroutine b64_encode_I1(n, code) - !< Encode scalar number to base64 (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=120_I1P, code=code64) - !< print "(A)", code64 - !<``` - !=> eA== <<< - integer(I1P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI1P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI1P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI1P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I1 - - pure subroutine b64_encode_string(s, code) - !< Encode scalar string to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(s='hello', code=code64) - !< print "(A)", code64 - !<``` - !=> aGVsbG8= <<< - character(*), intent(in) :: s !< String to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I4P) :: BYCHS !< Bytes of character string. - - BYCHS = byte_size(s) - allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYCHS+2)/3)*4) - nI1P = transfer(s,nI1P) - padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_string - - pure subroutine b64_encode_R16_a(n, code) - !< Encode array numbers to base64 (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[121._R16P,2.32_R16P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAABAXkCPwvUoXI8CQA== <<< - real(R16P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYR16P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYR16P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYR16P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R16_a - - pure subroutine b64_encode_R8_a(n, code) - !< Encode array numbers to base64 (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[1._R8P,2._R8P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAAAA8D8AAAAAAAAAQA== <<< - real(R8P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYR8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYR8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYR8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R8_a - - pure subroutine b64_encode_R4_a(n, code) - !< Encode array numbers to base64 (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[0._R4P,-32.12_R4P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAOF6AMI= <<< - real(R4P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYR4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYR4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYR4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R4_a - - pure subroutine b64_encode_I8_a(n, code) - !< Encode array numbers to base64 (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[23_I8P,324_I8P,25456656_I8P,2_I8P], code=code64) - !< print "(A)", code64 - !<``` - !=> FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA= <<< - integer(I8P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I8_a - - pure subroutine b64_encode_I4_a(n, code) - !< Encode array numbers to base64 (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[2023_I4P,-24_I4P], code=code64) - !< print "(A)", code64 - !<``` - !=> 5wcAAOj///8= <<< - integer(I4P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I4_a - - pure subroutine b64_encode_I2_a(n, code) - !< Encode array numbers to base64 (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[-203_I2P,-10_I2P], code=code64) - !< print "(A)", code64 - !<``` - !=> Nf/2/w== <<< - integer(I2P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI2P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI2P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI2P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I2_a - - pure subroutine b64_encode_I1_a(n, code) - !< Encode array numbers to base64 (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[120_I1P,-1_I1P], code=code64) - !< print "(A)", code64 - !<``` - !=> eP8= <<< - integer(I1P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI1P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI1P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI1P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I1_a - - pure subroutine b64_encode_string_a(s, code) - !< Encode array string to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(s=['hello','world'], code=code64) - !< print "(A)", code64 - !<``` - !=> aGVsbG93b3JsZA== <<< - character(*), intent(in) :: s(1:) !< String to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I4P) :: BYCHS !< Bytes of character string. - - BYCHS = byte_size(s(1))*size(s,dim=1) - allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYCHS+2)/3)*4) - nI1P = transfer(s,nI1P) - padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_string_a - - elemental subroutine b64_decode_R16(code, n) - !< Decode a base64 code into a scalar number (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R16P) :: scalar_R16 - !< call b64_decode(code='CKwcWmTHYEA=',n=scalar_R16) - !< print "(L1)", scalar_R16==134.231_R16P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - real(R16P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYR16P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R16 - - elemental subroutine b64_decode_R8(code, n) - !< Decode a base64 code into a scalar number (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: scalar_R8 - !< call b64_decode(code='AAAAAAAA8D8=',n=scalar_R8) - !< print "(L1)", scalar_R8==1._R8P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - real(R8P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYR8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R8 - - elemental subroutine b64_decode_R4(code, n) - !< Decode a base64 code into a scalar number (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: scalar_R4 - !< call b64_decode(code='AAAAAA==',n=scalar_R4) - !< print "(L1)", scalar_R4==0._R4P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - real(R4P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYR4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R4 - - elemental subroutine b64_decode_I8(code, n) - !< Decode a base64 code into a scalar number (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: scalar_I8 - !< call b64_decode(code='FwAAAAAAAAA=',n=scalar_I8) - !< print "(L1)", scalar_I8==23_I8P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I8P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I8 - - elemental subroutine b64_decode_I4(code, n) - !< Decode a base64 code into a scalar number (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: scalar_I4 - !< call b64_decode(code='5wcAAA==',n=scalar_I4) - !< print "(L1)", scalar_I4==2023_I4P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I4P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I4 - - elemental subroutine b64_decode_I2(code, n) - !< Decode a base64 code into a scalar number (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: scalar_I2 - !< call b64_decode(code='Nf8=',n=scalar_I2) - !< print "(L1)", scalar_I2==-203_I2P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I2P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI2P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I2 - - elemental subroutine b64_decode_I1(code, n) - !< Decode a base64 code into a scalar number (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: scalar_I1 - !< call b64_decode(code='eA==',n=scalar_I1) - !< print "(L1)", scalar_I1==120_I1P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I1P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI1P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I1 - - elemental subroutine b64_decode_string(code, s) - !< Decode a base64 code into a scalar string. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(:), allocatable :: code64 - !< code64 = repeat(' ',5) - !< call b64_decode(code='aGVsbG8=',s=code64) - !< print "(L1)", code64=='hello' - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - character(*), intent(out) :: s !< String to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:byte_size(s))) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - s = transfer(nI1P,s) - endsubroutine b64_decode_string - - pure subroutine b64_decode_R16_a(code, n) - !< Decode a base64 code into an array numbers (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R16P) :: array_R16(1:2) - !< call b64_decode(code='AAAAAABAXkCPwvUoXI8CQA==',n=array_R16) - !< print "(L1)", str(n=array_R16)==str(n=[121._R16P,2.32_R16P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - real(R16P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYR16P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R16_a - - pure subroutine b64_decode_R8_a(code, n) - !< Decode a base64 code into an array numbers (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: array_R8(1:2) - !< call b64_decode(code='AAAAAAAA8D8AAAAAAAAAQA==',n=array_R8) - !< print "(L1)", str(n=array_R8)==str(n=[1._R8P,2._R8P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - real(R8P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYR8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R8_a - - pure subroutine b64_decode_R4_a(code, n) - !< Decode a base64 code into an array numbers (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: array_R4(1:2) - !< call b64_decode(code='AAAAAOF6AMI=',n=array_R4) - !< print "(L1)", str(n=array_R4)==str(n=[0._R4P,-32.12_R4P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - real(R4P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYR4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R4_a - - pure subroutine b64_decode_I8_a(code, n) - !< Decode a base64 code into an array numbers (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: array_I8(1:4) - !< call b64_decode(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=',n=array_I8) - !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I8P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I8_a - - pure subroutine b64_decode_I4_a(code, n) - !< Decode a base64 code into an array numbers (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: array_I4(1:2) - !< call b64_decode(code='5wcAAOj///8=',n=array_I4) - !< print "(L1)", str(n=array_I4)==str(n=[2023_I4P,-24_I4P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I4P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I4_a - - pure subroutine b64_decode_I2_a(code, n) - !< Decode a base64 code into an array numbers (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: array_I2(1:2) - !< call b64_decode(code='Nf/2/w==',n=array_I2) - !< print "(L1)", str(n=array_I2)==str(n=[-203_I2P,-10_I2P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I2P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI2P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I2_a - - pure subroutine b64_decode_I1_a(code, n) - !< Decode a base64 code into an array numbers (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: array_I1(1:2) - !< call b64_decode(code='eP8=',n=array_I1) - !< print "(L1)", str(n=array_I1)==str(n=[120_I1P,-1_I1P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I1P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI1P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I1_a - - pure subroutine b64_decode_string_a(code, s) - !< Decode a base64 code into an array of strings. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(5) :: array_s(1:2) - !< call b64_decode(code='aGVsbG93b3JsZA==',s=array_s) - !< print "(L1)", array_s(1)//array_s(2)=='helloworld' - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - character(*), intent(out) :: s(1:) !< String to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:byte_size(s(1))*size(s,dim=1))) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - s = transfer(nI1P,s) - endsubroutine b64_decode_string_a -endmodule befor64 diff --git a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 deleted file mode 100644 index 29fddacf8..000000000 --- a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 +++ /dev/null @@ -1,848 +0,0 @@ -!< KISS library for packing heterogeneous data into single (homogeneous) packed one. -! -module befor64_pack_data_m -!< KISS library for packing heterogeneous data into single (homogeneous) packed one. -use penf - -implicit none -private -public :: pack_data - -interface pack_data - !< Pack different kinds of data into single I1P array. - !< - !< This is useful for encoding different (heterogeneous) kinds variables into a single (homogeneous) stream of bits. - !< @note This procedure exploits the `transfer` builtin function, that from the standard (2003+) is defined as - !< `TRANSFER(SOURCE, MOLD [, SIZE])`. Data object having a physical representation identical to that of `SOURCE` but with the type - !< and type parameters of `MOLD`. The result is of the same type and type parameters as `MOLD`. - !< If `MOLD` is an array and `SIZE` is absent, the result is an array and of rank one. Its size is as small as possible such - !< that its physical representation is not shorter than that of `SOURCE`. - !< - !< Presently, the following combinations are available: - !< - !<* [ ] Arrays-Arrays: - !< * [X] real(any)-real(any); - !< * [X] real(any)-integer(any); - !< * [X] integer(any)-integer(any); - !< * [X] integer(any)-real(any); - !< * [ ] real(any)-character; - !< * [ ] character-real(any); - !< * [ ] integer(any)-character; - !< * [ ] character-integer(any); - !<* [ ] Scalars-Scalars: - !< * [ ] real(any)-real(any); - !< * [ ] real(any)-integer(any); - !< * [ ] integer(any)-integer(any); - !< * [ ] integer(any)-real(any); - !< * [ ] real(any)-character; - !< * [ ] character-real(any); - !< * [ ] integer(any)-character; - !< * [ ] character-integer(any); - !< - !<### Examples of usage - !< - !<#### Packing two real arrays, one with kind R8P and one with R4P - !<```ortran - ! 63 <<< - real(R8P), intent(in) :: a1(1:) !< Firs data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_R4 - - pure subroutine pack_data_R8_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I8 - - pure subroutine pack_data_R8_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I4 - - pure subroutine pack_data_R8_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I2 - - pure subroutine pack_data_R8_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I1 - - pure subroutine pack_data_R4_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - real(R4P), intent(in) :: a1(1:) !< Firs data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_R8 - - pure subroutine pack_data_R4_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I8 - - pure subroutine pack_data_R4_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I4 - - pure subroutine pack_data_R4_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I2 - - pure subroutine pack_data_R4_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I1 - - pure subroutine pack_data_I8_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_R8 - - pure subroutine pack_data_I8_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_R4 - - pure subroutine pack_data_I8_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_I4 - - pure subroutine pack_data_I8_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_I2 - - pure subroutine pack_data_I8_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_I1 - - pure subroutine pack_data_I4_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_R8 - - pure subroutine pack_data_I4_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_R4 - - pure subroutine pack_data_I4_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_I8 - - pure subroutine pack_data_I4_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_I2 - - pure subroutine pack_data_I4_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_I1 - - pure subroutine pack_data_I2_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_R8 - - pure subroutine pack_data_I2_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_R4 - - pure subroutine pack_data_I2_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(3) - !<``` - !=> 1 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_I8 - - pure subroutine pack_data_I2_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(3) - !<``` - !=> 1 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_I4 - - pure subroutine pack_data_I2_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(3) - !<``` - !=> 1 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_I1 - - pure subroutine pack_data_I1_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_R8 - - pure subroutine pack_data_I1_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_R4 - - pure subroutine pack_data_I1_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(2) - !<``` - !=> 1 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_I8 - - pure subroutine pack_data_I1_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(2) - !<``` - !=> 1 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_I4 - - pure subroutine pack_data_I1_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(2) - !<``` - !=> 1 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_I2 -endmodule befor64_pack_data_m diff --git a/src/modules/BoundingBox/CMakeLists.txt b/src/modules/BoundingBox/CMakeLists.txt deleted file mode 100644 index d57a7c279..000000000 --- a/src/modules/BoundingBox/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/BoundingBox_Method.F90 -) \ No newline at end of file diff --git a/src/modules/BoundingBox/src/BoundingBox_Method.F90 b/src/modules/BoundingBox/src/BoundingBox_Method.F90 deleted file mode 100644 index 0df44a5c4..000000000 --- a/src/modules/BoundingBox/src/BoundingBox_Method.F90 +++ /dev/null @@ -1,934 +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: 23 Feb 2021 -! summary: [[BoundingBox_Method]] module consists method for[[BoundingBox_]] -! -!# Introduction -! This module consists method for data type [[BoundingBox_]]. These methods -! are included in following submoudles: -!- `BoundingBox_Method@Constructor` - -MODULE BoundingBox_Method -USE GlobalData, ONLY: DFP, I4B, LGT, stdout -USE BaseType, ONLY: BoundingBox_ -USE tomlf, ONLY: toml_table -IMPLICIT NONE - -PUBLIC :: OPERATOR(.Xmin.) -PUBLIC :: OPERATOR(.Xmax.) -PUBLIC :: OPERATOR(.Ymin.) -PUBLIC :: OPERATOR(.Ymax.) -PUBLIC :: OPERATOR(.Zmin.) -PUBLIC :: OPERATOR(.Zmax.) -PUBLIC :: OPERATOR(.isIntersect.) -PUBLIC :: OPERATOR(.Intersection.) -PUBLIC :: OPERATOR(.UNION.) -PUBLIC :: OPERATOR(.Center.) -PUBLIC :: OPERATOR(.isInside.) -PUBLIC :: OPERATOR(.Nptrs.) - -PUBLIC :: ASSIGNMENT(=) - -PUBLIC :: Initiate -PUBLIC :: BoundingBox -PUBLIC :: BoundingBox_Pointer -PUBLIC :: DEALLOCATE -PUBLIC :: Display - -PUBLIC :: isIntersectInX -PUBLIC :: isIntersectInY -PUBLIC :: isIntersectInZ -PUBLIC :: isIntersect -PUBLIC :: isEmpty -PUBLIC :: Intersection -PUBLIC :: Union -PUBLIC :: Center -PUBLIC :: isInside -PUBLIC :: GetDiameter -PUBLIC :: GetRadius -PUBLIC :: GetDiameterSqr -PUBLIC :: GetRadiusSqr -PUBLIC :: GetValue -PUBLIC :: Append - -PRIVATE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function Initiatea an instance of [[BoundingBox_]]. -! -!# Introduction -! This function Initiates an instance of [[BoundingBox_]]. -!- `NSD` is the spatial dimension -!- `lim` is vector of real numbers (length=6) -!- `lim(1)` => xmin -!- `lim(2)` => ymin -!- `lim(3)` => zmin -!- `lim(4)` => xmax -!- `lim(5)` => ymax -!- `lim(6)` => zmax -! -!### Usage -! -!```fortran -! subroutine test -! type(BoundingBox_) :: obj -! call Initiate( obj, nsd = 2, lim=[0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0. -! 0_DFP, 0.0_DFP] ) -! call display( obj, msg="test1" ) -! end subroutine test -!``` - -INTERFACE Initiate - MODULE PURE SUBROUTINE Initiate_1(obj, nsd, lim) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - !! Instance of bounding box - INTEGER(I4B), INTENT(IN) :: NSD - !! Spatial dimension - REAL(DFP), INTENT(IN) :: lim(6) - !! Extent of bounding box - END SUBROUTINE Initiate_1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Initiate the instance of [[BoundingBox_]] from the another box -! -!# Introduction -! -! This subroutine Initiate the instance of [[BoundingBox_]] from another -! instance. It is basically a copy command. -! -!### Usage -! -!```fortran -! subroutine test2 -! type(BoundingBox_) :: obj, obj2 -! call Initiate( obj, 2, [0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. -! 0_DFP] ) -! call Initiate(obj2, obj) -! call display( obj2, msg="test2") -! end subroutine test2 -!``` - -INTERFACE Initiate - MODULE PURE SUBROUTINE Initiate_2(obj, Anotherobj) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - TYPE(BoundingBox_), INTENT(IN) :: Anotherobj - END SUBROUTINE Initiate_2 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE Initiate_2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Initiate the instance of [[BoundingBox_]] from the another box - -INTERFACE Initiate - MODULE PURE SUBROUTINE Initiate_3(obj, Anotherobj) - TYPE(BoundingBox_), INTENT(INOUT) :: obj(:) - TYPE(BoundingBox_), INTENT(IN) :: Anotherobj(:) - END SUBROUTINE Initiate_3 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE Initiate_3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Append@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Initiate the instance of [[BoundingBox_]] from the another box - -INTERFACE Append - MODULE PURE SUBROUTINE Append_1(obj, VALUE) - TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - TYPE(BoundingBox_), INTENT(IN) :: VALUE(:) - END SUBROUTINE Append_1 -END INTERFACE Append - -!---------------------------------------------------------------------------- -! BoundingBox@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Function to create [[BoundingBox_]] instance -! -!# Introduction -! This function Initiates an instance of [[BoundingBox_]]. -!- `NSD` is the spatial dimension -!- `lim` is vector of real numbers (length=6) -!- `lim(1)` => xmin -!- `lim(2)` => ymin -!- `lim(3)` => zmin -!- `lim(4)` => xmax -!- `lim(5)` => ymax -!- `lim(6)` => zmax -! -!### Usage -!```fortran -! subroutine test3 -! type(BoundingBox_) :: obj -! obj = BoundingBox( nsd = 2, lim=[0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0. -! 0_DFP, 0.0_DFP] ) -! call display( obj, msg="test1" ) -! end subroutine test3 -!``` - -INTERFACE BoundingBox - MODULE PURE FUNCTION Constructor1(nsd, lim) RESULT(Ans) - TYPE(BoundingBox_) :: Ans - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN) :: lim(6) - END FUNCTION Constructor1 -END INTERFACE BoundingBox - -!---------------------------------------------------------------------------- -! BoundingBox@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function creates an instance of [[BoundingBox_]] -! -!# Introduction -!This function creates an intance of [[BoundingBox_]]. -! -!### Usage -!```fortran -! subroutine test4 -! type(BoundingBox_) :: obj, obj2 -! call Initiate( obj, 2, [0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. -! 0_DFP] ) -! obj2 = BoundingBox(obj) -! call display( obj2, msg="test2") -! end subroutine test4 -!``` - -INTERFACE BoundingBox - MODULE PURE FUNCTION Constructor2(Anotherobj) RESULT(Ans) - TYPE(BoundingBox_) :: Ans - TYPE(BoundingBox_), INTENT(IN) :: Anotherobj - END FUNCTION Constructor2 -END INTERFACE BoundingBox - -!---------------------------------------------------------------------------- -! BoundingBox -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function creates an instance of [[BoundingBox_]] -! -!# Introduction -! This function creates an instance of [[BoundingBox_]]. In this function NSD -! is determined from SIZE(xij, 1). -! -!### Usage -!```fortran -! subroutine test5 -! type(BoundingBox_) :: obj -! obj = boundingBox(RESHAPE([0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. -! 0_DFP], [2,3])) -! call display(obj, "test5") -! end subroutine test5 -!``` - -INTERFACE BoundingBox - MODULE PURE FUNCTION Constructor3(xij) RESULT(Ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! Nodal coordinates xij( 1:nsd, 1:tnodes ) - TYPE(BoundingBox_) :: Ans - !! - END FUNCTION Constructor3 -END INTERFACE BoundingBox - -!---------------------------------------------------------------------------- -! BoundingBox_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the pointer to [[BoundingBox_]] instance -! -!# Introduction -! -! This function returns the pointer to [[BoundingBox_]] instance. -!- `NSD` is the spatial dimension -!- `lim` is vector of real numbers (length=6) -!- `lim(1)` => xmin -!- `lim(2)` => ymin -!- `lim(3)` => zmin -!- `lim(4)` => xmax -!- `lim(5)` => ymax -!- `lim(6)` => zmax -! -!### Usage -! -!```fortran -! subroutine test6 -! type(BoundingBox_) :: obj -! type(BoundingBox_), pointer :: obj2 -! call Initiate( obj, 2, [0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. -! 0_DFP] ) -! obj2 => BoundingBox_Pointer(obj) -! call display( obj2, msg="test6") -! end subroutine test6 -!``` - -INTERFACE BoundingBox_Pointer - MODULE FUNCTION Constructor_1(nsd, lim) RESULT(Ans) - TYPE(BoundingBox_), POINTER :: Ans - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN) :: lim(6) - END FUNCTION Constructor_1 -END INTERFACE BoundingBox_Pointer - -!---------------------------------------------------------------------------- -! BoundingBox_Pointer@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the pointer to an instance of [[BoundingBox_]] -! -!# Introduction -! This function returns the pointer to an instance of [[BoundingBox_]] by -! copying contents from `Anotherobj` -! -!### Usage -!```fortran -! subroutine test7 -! type(BoundingBox_), pointer :: obj -! obj => BoundingBox_Pointer(nsd=3, lim=[0.0_DFP, 1.0_DFP, 0.0_DFP, 1. -! 0_DFP, 0.0_DFP, 0.0_DFP]) -! call display(obj, "test7") -! end subroutine test7 -!``` - -INTERFACE BoundingBox_Pointer - MODULE FUNCTION Constructor_2(Anotherobj) RESULT(Ans) - TYPE(BoundingBox_), POINTER :: Ans - TYPE(BoundingBox_), INTENT(IN) :: Anotherobj - END FUNCTION Constructor_2 -END INTERFACE BoundingBox_Pointer - -!---------------------------------------------------------------------------- -! Deallocate@Constructor -!---------------------------------------------------------------------------- - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE BB_Deallocate(obj) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - END SUBROUTINE BB_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Deallocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-11-15 -! summary: Deallocate vector of bounding box - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE BB_Deallocate2(obj) - TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE BB_Deallocate2 -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Display@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine displays the content of [[BoundingBox_]] - -INTERFACE Display - MODULE SUBROUTINE display_obj(obj, msg, unitno) - TYPE(BoundingBox_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitNo - END SUBROUTINE display_obj -END INTERFACE Display - -!---------------------------------------------------------------------------- -! setXmin@setMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the Xmin in bounding box - -INTERFACE - MODULE PURE SUBROUTINE setXmin(obj, Val) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - END SUBROUTINE setXmin -END INTERFACE - -!---------------------------------------------------------------------------- -! setXmax@setMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the Xmax in bounding box - -INTERFACE - MODULE PURE SUBROUTINE setXmax(obj, Val) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - END SUBROUTINE setXmax -END INTERFACE - -!---------------------------------------------------------------------------- -! setYmin@setMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the Ymin in bounding box - -INTERFACE - MODULE PURE SUBROUTINE setYmin(obj, Val) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - END SUBROUTINE setYmin -END INTERFACE - -!---------------------------------------------------------------------------- -! setYmax@setMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the Ymax of bounding box - -INTERFACE - MODULE PURE SUBROUTINE setYmax(obj, Val) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - END SUBROUTINE setYmax -END INTERFACE - -!---------------------------------------------------------------------------- -! setZmin@setMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the Zmin of bounding box - -INTERFACE - MODULE PURE SUBROUTINE setZmin(obj, Val) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - END SUBROUTINE setZmin -END INTERFACE - -!---------------------------------------------------------------------------- -! setZmax@setMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the Zmax of bounding box - -INTERFACE - MODULE PURE SUBROUTINE setZmax(obj, Val) - TYPE(BoundingBox_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - END SUBROUTINE setZmax -END INTERFACE - -!---------------------------------------------------------------------------- -! getXmin@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the xmin -! -!### Usage -! -!```fortran -! xmin = .xmin. obj -!``` - -INTERFACE OPERATOR(.Xmin.) - MODULE PURE FUNCTION getXmin(obj) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: Ans - END FUNCTION getXmin -END INTERFACE - -!---------------------------------------------------------------------------- -! getXmax@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the xmax -! -!### Usage -! -!```fortran -! xmax = .xmax. obj -!``` - -INTERFACE OPERATOR(.Xmax.) - MODULE PURE FUNCTION getXmax(obj) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: Ans - END FUNCTION getXmax -END INTERFACE - -!---------------------------------------------------------------------------- -! getYmin@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the ymin -! -!### Usage -! -!```fortran -! ymin = .ymin. obj -!``` - -INTERFACE OPERATOR(.Ymin.) - MODULE PURE FUNCTION getYmin(obj) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: Ans - END FUNCTION getYmin -END INTERFACE - -!---------------------------------------------------------------------------- -! getYmax@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the ymax -! -!### Usage -! -!```fortran -! ymax = .ymax. obj -!``` - -INTERFACE OPERATOR(.Ymax.) - MODULE PURE FUNCTION getYmax(obj) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: Ans - END FUNCTION getYmax -END INTERFACE - -!---------------------------------------------------------------------------- -! getZmin@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the zmin -! -!### Usage -! -!```fortran -! zmin = .zmin. obj -!``` - -INTERFACE OPERATOR(.Zmin.) - MODULE PURE FUNCTION getZmin(obj) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: Ans - END FUNCTION getZmin -END INTERFACE - -!---------------------------------------------------------------------------- -! getZmax@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the zmax -! -!### Usage -! -!```fortran -! zmax = .zmax. obj -!``` - -INTERFACE OPERATOR(.Zmax.) - MODULE PURE FUNCTION getZmax(obj) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: Ans - END FUNCTION getZmax -END INTERFACE - -!---------------------------------------------------------------------------- -! isIntersectInX@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function checks if two bounding boxes interesect in x direction -! -!@todo -!### Usage -!@endtodo - -INTERFACE isIntersectInX - MODULE PURE FUNCTION is_intersect_in_X(obj, obj2) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 - LOGICAL(LGT) :: Ans - END FUNCTION is_intersect_in_X -END INTERFACE isIntersectInX - -!---------------------------------------------------------------------------- -! isIntersectInY@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function checks if two bounding boxes interesect in y direction -! -!@todo -!### Usage -!@endtodo - -INTERFACE isIntersectInY - MODULE PURE FUNCTION is_intersect_in_Y(obj, obj2) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 - LOGICAL(LGT) :: Ans - END FUNCTION is_intersect_in_Y -END INTERFACE isIntersectInY - -!---------------------------------------------------------------------------- -! isIntersectInZ@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function checks if two bounding boxes interesect in z direction -! -!@todo -!### Usage -!@endtodo - -INTERFACE isIntersectInZ - MODULE PURE FUNCTION is_intersect_in_Z(obj, obj2) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 - LOGICAL(LGT) :: Ans - END FUNCTION is_intersect_in_Z -END INTERFACE isIntersectInZ - -!---------------------------------------------------------------------------- -! isIntersect@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-12 -! summary: This function checks if two bounding boxes interesect each other - -INTERFACE OPERATOR(.isIntersect.) - MODULE PURE FUNCTION is_intersect(obj, obj2) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 - LOGICAL(LGT) :: Ans - END FUNCTION is_intersect -END INTERFACE - -INTERFACE isIntersect - MODULE PROCEDURE is_intersect -END INTERFACE isIntersect - -!---------------------------------------------------------------------------- -! isEmpty@getMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-11 -! summary: Checks if bounding box is empty - -INTERFACE isEmpty - MODULE PURE FUNCTION bbox_isEmpty(obj) RESULT(ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION bbox_isEmpty -END INTERFACE isEmpty - -!---------------------------------------------------------------------------- -! getIntersection@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the intersection bounding -! box of two bounding box -! -!# Introduction -! This function returns the bounding box which is formed by the -! intersection of two bounding box -! -!@todo -![] add usage -!@endtodo - -INTERFACE OPERATOR(.Intersection.) - MODULE PURE FUNCTION get_intersection(obj, obj2) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 - TYPE(BoundingBox_) :: Ans - END FUNCTION get_intersection -END INTERFACE - -INTERFACE Intersection - MODULE PROCEDURE get_intersection -END INTERFACE Intersection - -!---------------------------------------------------------------------------- -! getUnion@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the union of two bounding box -! -!# Introduction -! This function returns the bounding box which is formed by the union -! of two bounding box. -! -!@todo -![] add usage -!@endtodo - -INTERFACE OPERATOR(.UNION.) - MODULE PURE FUNCTION get_Union(obj, obj2) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 - TYPE(BoundingBox_) :: Ans - END FUNCTION get_Union -END INTERFACE - -INTERFACE Union - MODULE PROCEDURE get_Union -END INTERFACE Union - -!---------------------------------------------------------------------------- -! getCenter@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function returns the center of bounding box -! -!# Introduction -! -!This function returns the centern of bounding box. -! -!@todo -![] add usage -!@endtodo - -INTERFACE OPERATOR(.Center.) - MODULE PURE FUNCTION get_Center(obj) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: Ans(3) - END FUNCTION get_Center -END INTERFACE - -INTERFACE Center - MODULE PROCEDURE get_Center -END INTERFACE Center - -!---------------------------------------------------------------------------- -! isInside@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This function checks if a point is inside the bounding box or not -! -!# Introduction -! -! This function checks if a point is inside a bounding box or not -! -!@todo -![] add usage -!@endtodo - -INTERFACE OPERATOR(.isInside.) - MODULE PURE FUNCTION is_Inside(obj, Val) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - LOGICAL(LGT) :: Ans - END FUNCTION is_Inside -END INTERFACE - -INTERFACE isInside - MODULE PROCEDURE is_Inside -END INTERFACE isInside - -!---------------------------------------------------------------------------- -! getNptrs@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-11 -! summary: This function returns the node numbers located inside -! the bounding box -! -!# Introduction -! -! This function returns the list of node numbers which are inside -! the bounding box - -INTERFACE OPERATOR(.Nptrs.) - MODULE PURE FUNCTION get_nptrs(obj, xij) RESULT(Ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: xij(:, :) - INTEGER(I4B), ALLOCATABLE :: Ans(:) - END FUNCTION get_nptrs -END INTERFACE - -!---------------------------------------------------------------------------- -! GetDiameter@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2022 -! summary: Returns the diameter of the box - -INTERFACE GetDiameter - MODULE PURE FUNCTION bbox_GetDiameter(obj) RESULT(ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION bbox_GetDiameter -END INTERFACE GetDiameter - -!---------------------------------------------------------------------------- -! GetRadius@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-10 -! summary: Returns the Radius of the box - -INTERFACE GetRadius - MODULE PURE FUNCTION bbox_GetRadius(obj) RESULT(ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION bbox_GetRadius -END INTERFACE GetRadius - -!---------------------------------------------------------------------------- -! GetDiameterSqr@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-10 -! summary: Returns the diameter of the box - -INTERFACE GetDiameterSqr - MODULE PURE FUNCTION bbox_GetDiameterSqr(obj) RESULT(ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION bbox_GetDiameterSqr -END INTERFACE GetDiameterSqr - -!---------------------------------------------------------------------------- -! GetRadiusSqr@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-10 -! summary: Returns the Radius of the box - -INTERFACE GetRadiusSqr - MODULE PURE FUNCTION bbox_GetRadiusSqr(obj) RESULT(ans) - TYPE(BoundingBox_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION bbox_GetRadiusSqr -END INTERFACE GetRadiusSqr - -!---------------------------------------------------------------------------- -! GetValue@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-11-15 -! summary: GetValue Integer Vectors - -INTERFACE GetValue - MODULE SUBROUTINE toml_get_bbox_r0(table, key, VALUE, origin, stat, & - & isFound) - TYPE(toml_table), INTENT(INOUT) :: table - CHARACTER(*), INTENT(IN) :: key - !! We dont need table here, so this argument is ignored. - TYPE(BoundingBox_), INTENT(INOUT) :: VALUE - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: origin - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: stat - LOGICAL(LGT), OPTIONAL, INTENT(INOUT) :: isFound - END SUBROUTINE toml_get_bbox_r0 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-11-15 -! summary: GetValue Integer Vectors - -INTERFACE GetValue - MODULE SUBROUTINE toml_get_bbox_r1(table, key, VALUE, origin, stat, & - & isFound) - TYPE(toml_table), INTENT(INOUT) :: table - CHARACTER(*), INTENT(IN) :: key - TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: origin - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: stat - LOGICAL(LGT), OPTIONAL, INTENT(INOUT) :: isFound - END SUBROUTINE toml_get_bbox_r1 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE BoundingBox_Method diff --git a/src/modules/CInterface/CMakeLists.txt b/src/modules/CInterface/CMakeLists.txt deleted file mode 100644 index ed2b030f2..000000000 --- a/src/modules/CInterface/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/CInterface.F90 -) \ No newline at end of file diff --git a/src/modules/CInterface/src/CInterface.F90 b/src/modules/CInterface/src/CInterface.F90 deleted file mode 100644 index ae30ad133..000000000 --- a/src/modules/CInterface/src/CInterface.F90 +++ /dev/null @@ -1,1214 +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 CInterface -USE GlobalData -USE String_Class, ONLY: String -USE, INTRINSIC :: ISO_C_BINDING, C_PTR => C_PTR, & - & C_CHAR_PTR => C_PTR, C_CONST_CHAR_PTR => C_PTR, & - & C_void_ptr => C_PTR, C_CONST_VOID_PTR => C_PTR -IMPLICIT NONE -PRIVATE - -PUBLIC :: C_CHAR_PTR, C_VOID_PTR, C_CONST_CHAR_PTR, C_CONST_VOID_PTR -PUBLIC :: CString - -INTEGER(I4B), PUBLIC, PARAMETER :: C_ENUM = C_INT - !! a C enum may not always be a standard C int -CHARACTER(1, KIND=C_CHAR), PUBLIC, PARAMETER :: NUL = C_NULL_CHAR - !! C string terminator alais using the 3-letter ASCII name. - !! The C_ prefix is not used because it is just an ASCII character. - !! In C, "char" is distinct from "signed char", unlike integers. - !! The plain "char" type is specific for text/string values, whereas - !! "signed char" should indicate 1-byte integer data. - !! Most ISO-C systems have wide chars "wchar_t", but Fortran compilers - !! have limited support for different character kinds. UTF encoding - !! adds more complexity. This should be updated as Fortran compilers - !! include support for more character types. -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED = C_INT -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_SHORT = C_SHORT -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG = C_LONG -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG_LONG = C_LONG_LONG -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_CHAR = C_SIGNED_CHAR -INTEGER(I4B), PUBLIC, PARAMETER :: C_SSIZE_T = C_SIZE_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT8_T = C_INT8_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT16_T = C_INT16_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT32_T = C_INT32_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT64_T = C_INT64_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST8_T = C_INT_LEAST8_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST16_T = C_INT_LEAST16_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST32_T = C_INT_LEAST32_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST64_T = C_INT_LEAST64_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST8_T = C_INT_FAST8_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST16_T = C_INT_FAST16_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST32_T = C_INT_FAST32_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST64_T = C_INT_FAST64_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_UINTMAX_T = C_INTMAX_T -INTEGER(I4B), PUBLIC, PARAMETER :: C_SHORT_INT = C_SHORT -INTEGER(I4B), PUBLIC, PARAMETER :: C_LONG_INT = C_LONG -INTEGER(I4B), PUBLIC, PARAMETER :: C_LONG_LONG_INT = C_LONG_LONG -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_INT = C_UNSIGNED -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_SHORT_INT = C_SHORT -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG_INT = C_LONG -INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG_LONG_INT = C_LONG_LONG - -PUBLIC :: C_MEMCPY -PUBLIC :: C_memmove -PUBLIC :: C_memset -PUBLIC :: C_memcmp -PUBLIC :: C_memchr -PUBLIC :: C_strcpy -PUBLIC :: C_strncpy -PUBLIC :: C_strcat -PUBLIC :: C_strncat -PUBLIC :: C_strcmp -PUBLIC :: C_strncmp -PUBLIC :: C_strlen -PUBLIC :: C_calloc -PUBLIC :: C_malloc -PUBLIC :: C_free -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: C_ASSOCIATED_PURE -PUBLIC :: C_F_STRING -PUBLIC :: FString -PUBLIC :: F_C_STRING -PUBLIC :: C_STRLEN_SAFE -PUBLIC :: F_C_STRING_DUP -PUBLIC :: C_STRING_VALUE -PUBLIC :: C_STRING_ALLOC -PUBLIC :: C_STRING_FREE -PUBLIC :: C_PTR_TO_INT_VEC -PUBLIC :: C_PTR_TO_Real_VEC -PUBLIC :: C2Fortran -PUBLIC :: optval_c_int -PUBLIC :: optval_c_size_t -PUBLIC :: optval_c_double -PUBLIC :: optval_c_bool - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE C_F_STRING - MODULE PROCEDURE F_string_assign_C_string - MODULE PROCEDURE C_F_STRING_CHARS -END INTERFACE C_F_STRING - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE F_string_assign_C_string -END INTERFACE ASSIGNMENT(=) - -INTERFACE FString - MODULE PROCEDURE Fstring1 -END INTERFACE FString - -INTERFACE F_C_STRING - MODULE PROCEDURE F_C_STRING_CHARS, F_C_STRING_PTR -END INTERFACE F_C_STRING - -INTERFACE C_PTR_TO_INT_VEC - MODULE PROCEDURE C_PTR_TO_Int8_VEC, C_PTR_TO_Int16_VEC, & - & C_PTR_TO_Int32_VEC, C_PTR_TO_Int64_VEC -END INTERFACE C_PTR_TO_INT_VEC - -INTERFACE C_PTR_TO_Real_VEC - MODULE PROCEDURE C_PTR_TO_Real32_VEC, C_PTR_TO_Real64_VEC -END INTERFACE C_PTR_TO_Real_VEC - -INTERFACE C2Fortran - MODULE PROCEDURE C_PTR_TO_Int8_VEC, C_PTR_TO_Int16_VEC, & - & C_PTR_TO_Int32_VEC, C_PTR_TO_Int64_VEC, C_PTR_TO_Real32_VEC, & - & C_PTR_TO_Real64_VEC, F_string_assign_C_string, & - & C_F_STRING_CHARS -END INTERFACE C2Fortran - -INTERFACE optval_c_int - MODULE PROCEDURE optval_c_int_1 -END INTERFACE optval_c_int - -INTERFACE optval_c_size_t - MODULE PROCEDURE optval_c_size_t_1, optval_c_size_t_2 -END INTERFACE optval_c_size_t - -INTERFACE optval_c_double - MODULE PROCEDURE optval_c_double_1, optval_c_double_2 -END INTERFACE optval_c_double - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. -! -!# Introduction -! -! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. -! -!### CInterface -! -!```c -! extern void *memcpy (void *dest, const void *src, size_t n); -!``` - -INTERFACE - FUNCTION C_MEMCPY(dest, src, n) RESULT(RESULT) BIND(C, name="memcpy") - IMPORT C_void_ptr, C_SIZE_T - TYPE(C_VOID_PTR) :: RESULT - TYPE(C_VOID_PTR), VALUE, INTENT(IN) :: dest - !! target=intent(out) - TYPE(C_VOID_PTR), VALUE, INTENT(IN) :: src - !! target=INTENT(IN) - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n - END FUNCTION C_MEMCPY -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Copy N bytes of SRC to DEST, guaranteeing correct behavior -! for overlapping strings. -! -!# Introduction -! Copy N bytes of SRC to DEST, guaranteeing correct behavior for -! overlapping strings. -! -!### CInterface -! -!```c -! extern void *memmove (void *dest, const void *src, size_t n) -!``` - -INTERFACE - FUNCTION C_memmove(dest, src, n) RESULT(RESULT) BIND(C, name="memmove") - IMPORT C_void_ptr, C_SIZE_T - TYPE(C_void_ptr) :: RESULT - TYPE(C_void_ptr), VALUE, INTENT(IN) :: dest ! target=intent(out) - TYPE(C_void_ptr), VALUE, INTENT(IN) :: src - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n - END FUNCTION C_memmove -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Set N bytes of S to C. -! -!# Introduction -! Set N bytes of S to C. -! -!### CInterface -! -!```c -!extern void *memset (void *s, int c, size_t n) -!``` - -INTERFACE - FUNCTION C_memset(s, c, n) RESULT(RESULT) BIND(C, name="memset") - IMPORT :: C_void_ptr, C_INT, C_SIZE_T - TYPE(C_void_ptr) :: RESULT - TYPE(C_void_ptr), VALUE, INTENT(in) :: s ! target=intent(out) - INTEGER(C_INT), VALUE, INTENT(in) :: c - INTEGER(C_SIZE_T), VALUE, INTENT(in) :: n - END FUNCTION C_memset -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Compare N bytes of S1 and S2. -! -!# Introduction -! Compare N bytes of S1 and S2. -! -!### CInterface -! -!```c -!extern int memcmp (const void *s1, const void *s2, size_t n) -!``` - -INTERFACE - PURE FUNCTION C_memcmp(s1, s2, n) RESULT(RESULT) BIND(C, name="memcmp") - IMPORT :: C_INT, C_void_ptr, C_SIZE_T - INTEGER(C_INT) :: RESULT - TYPE(C_void_ptr), VALUE, INTENT(IN) :: s1 - TYPE(C_void_ptr), VALUE, INTENT(IN) :: s2 - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n - END FUNCTION C_memcmp -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Search N bytes of S for C. -! -!# Introduction -! Search N bytes of S for C. -! -!### CInterface -! -!```c -!extern void *memchr (const void *s, int c, size_t n) -!``` - -INTERFACE - PURE FUNCTION C_memchr(s, c, n) RESULT(RESULT) BIND(C, name="memchr") - IMPORT :: C_void_ptr, C_INT, C_SIZE_T - TYPE(C_void_ptr) :: RESULT - TYPE(C_void_ptr), VALUE, INTENT(IN) :: s - INTEGER(C_INT), VALUE, INTENT(IN) :: c - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n - END FUNCTION C_memchr -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Copy SRC to DEST. -! -!# Introduction -! Copy SRC to DEST. -! -!### CInterface -! -!```c -!extern char *strcpy (char *dest, const char *src) -!``` - -INTERFACE - FUNCTION C_strcpy(dest, src) RESULT(RESULT) BIND(C, name="strcpy") - IMPORT :: C_CHAR_PTR, C_SIZE_T - TYPE(C_CHAR_PTR) :: RESULT - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: dest ! target=intent(out) - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: src - END FUNCTION C_strcpy -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Copy no more than N characters of SRC to DEST. -! -!# Introduction -! Copy no more than N characters of SRC to DEST. -! -! -!### CInterface -! -!```c -!extern char *strncpy (char *dest, const char *src, size_t n) -!``` - -INTERFACE - FUNCTION C_strncpy(dest, src, n) RESULT(RESULT) BIND(C, name="strncpy") - IMPORT C_CHAR_PTR, C_SIZE_T - TYPE(C_CHAR_PTR) :: RESULT - TYPE(C_CHAR_PTR), VALUE, INTENT(in) :: dest ! target=intent(out) - TYPE(C_CHAR_PTR), VALUE, INTENT(in) :: src - INTEGER(C_SIZE_T), VALUE, INTENT(in) :: n - END FUNCTION C_strncpy -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Append SRC onto DEST. -! -!# Introduction -! Append SRC onto DEST. -! -! -!### CInterface -! -!```c -!extern char *strcat (char *dest, const char *src) -!``` - -INTERFACE - FUNCTION C_strcat(dest, src) RESULT(RESULT) BIND(C, name="strcat") - IMPORT :: C_CHAR_PTR, C_SIZE_T - TYPE(C_CHAR_PTR) :: RESULT - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: dest - !! target=intent(out) - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: src - END FUNCTION C_strcat -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Append no more than N characters from SRC onto DEST. -! -!# Introduction -! Append no more than N characters from SRC onto DEST. -! -!### CInterface -! -!```c -!extern char *strncat (char *dest, const char *src, size_t n) -!``` - -INTERFACE - FUNCTION C_strncat(dest, src, n) RESULT(RESULT) BIND(C, name="strncat") - IMPORT :: C_CHAR_PTR, C_SIZE_T - TYPE(C_CHAR_PTR) :: RESULT - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: dest - !! target=intent(out) - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: src - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n - END FUNCTION C_strncat -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Compare S1 and S2. -! -!# Introduction -! Compare S1 and S2. -! -!### CInterface -! -!```c -!extern int strcmp (const char *s1, const char *s2) -!``` - -INTERFACE - PURE FUNCTION C_strcmp(s1, s2) RESULT(RESULT) BIND(C, name="strcmp") - IMPORT :: C_INT, C_CHAR_PTR, C_SIZE_T - INTEGER(C_INT) :: RESULT - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s1 - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s2 - END FUNCTION C_strcmp -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Compare N characters of S1 and S2. -! -!# Introduction -! Compare N characters of S1 and S2. -! -!### CInterface -! -!```c -!extern int strncmp (const char *s1, const char *s2, size_t n) -!``` - -INTERFACE - PURE FUNCTION C_strncmp(s1, s2, n) RESULT(RESULT) BIND(C, name="strncmp") - IMPORT :: C_INT, C_CHAR_PTR, C_SIZE_T - INTEGER(C_INT) :: RESULT - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s1 - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s2 - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n - END FUNCTION C_strncmp -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Return the length of S. -! -!# Introduction -! Return the length of S. -! -!### CInterface -! -!```c -!extern size_t strlen (const char *s) -!``` - -INTERFACE - PURE FUNCTION C_strlen(s) RESULT(RESULT) BIND(C, name="strlen") - IMPORT :: C_CHAR_PTR, C_SIZE_T - INTEGER(C_SIZE_T) :: RESULT - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s !character(len=*), intent(in) - END FUNCTION C_strlen -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: CAlloc function -! -!# Introduction -! CAlloc function. -! -!### CInterface -! -!```c -!void *calloc(size_t nmemb, size_t size); -!``` - -INTERFACE - TYPE(C_void_ptr) FUNCTION C_calloc(nmemb, size) BIND(C, name="calloc") - IMPORT :: C_void_ptr, C_SIZE_T - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: nmemb, size - END FUNCTION C_calloc -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: -! -!### CInterface -! -!```c -! void *malloc(size_t size); -!``` - -INTERFACE - TYPE(C_void_ptr) FUNCTION C_malloc(size) BIND(C, name="malloc") - IMPORT :: C_void_ptr, C_SIZE_T - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: size - END FUNCTION C_malloc -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: -! -!### Usage -! -!```fortran -! void free(void *ptr); -!``` - -INTERFACE - SUBROUTINE C_free(ptr) BIND(C, name="free") - IMPORT :: C_void_ptr - TYPE(C_void_ptr), VALUE, INTENT(IN) :: ptr - END SUBROUTINE C_free -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: -! -! -!### CInterface -! -!```c -! void *realloc(void *ptr, size_t size); -!``` - -INTERFACE - TYPE(C_void_ptr) FUNCTION C_realloc(ptr, size) BIND(C, name="realloc") - IMPORT :: C_void_ptr, C_SIZE_T - TYPE(C_void_ptr), VALUE, INTENT(IN) :: ptr - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: size - END FUNCTION C_realloc -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: - -PURE LOGICAL FUNCTION C_ASSOCIATED_PURE(ptr) RESULT(associated) - TYPE(C_PTR), INTENT(IN) :: ptr - INTEGER(C_INTPTR_T) :: iptr - iptr = TRANSFER(ptr, iptr) - ASSOCIATED = (iptr /= 0) -END FUNCTION C_ASSOCIATED_PURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Set a fixed-length Fortran string to the value of a C string. -! -!# Introduction -! Copy a C string, passed by pointer, to a Fortran string. -! If the C pointer is NULL, the Fortran string is blanked. -! C_string must be NUL terminated, or at least as long as F_string. -! If C_string is longer, it is truncated. Otherwise, F_string is -! blank-padded at the end. - -SUBROUTINE F_string_assign_C_string(F_string, C_string) - CHARACTER(*), INTENT(OUT) :: F_string - TYPE(C_CHAR_PTR), INTENT(IN) :: C_string - !> internal variables - CHARACTER(1, KIND=C_CHAR), POINTER :: p_chars(:) - INTEGER(I4B) :: i - !> main - IF (.NOT. C_ASSOCIATED(C_string)) THEN - F_string = '' - ELSE - CALL C_F_POINTER(C_string, p_chars, [HUGE(0)]) - i = 1 - DO WHILE (p_chars(i) .NE. NUL .AND. I .LE. LEN(F_string)) - F_string(i:i) = p_chars(i); i = i + 1 - END DO - IF (i .LT. LEN(F_string)) F_string(i:) = ' ' - END IF -END SUBROUTINE F_string_assign_C_string - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Copy a C string, passed as a char-array reference, to a Fortran string. -! -!# Introduction -! -! Copy a C string, passed by pointer, to a Fortran string. -! If the C pointer is NULL, the Fortran string is blanked. -! C_string must be NUL terminated, or at least as long as F_string. -! If C_string is longer, it is truncated. Otherwise, F_string is -! blank-padded at the end. - -SUBROUTINE C_F_string_chars(C_string, F_string) - CHARACTER(1, KIND=C_CHAR), INTENT(IN) :: C_string(*) - CHARACTER(*), INTENT(OUT) :: F_string - !! F_String is fortran string, it should be allocated - !! before calling the routine - ! - ! internal variable - ! - INTEGER(I4B) :: i - i = 1 - DO WHILE (C_string(i) .NE. NUL .AND. i .LE. LEN(F_string)) - F_string(i:i) = C_string(i) - i = i + 1 - END DO - IF (i .LT. LEN(F_string)) F_string(i:) = ' ' -END SUBROUTINE C_F_string_chars - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION Fstring1(C_string) RESULT(F_string) - CHARACTER(1, KIND=C_CHAR), INTENT(IN) :: C_string(:) - CHARACTER(:), ALLOCATABLE :: F_string - !! - INTEGER(I4B) :: i, n, m - n = SIZE(C_string) - m = 0 - DO i = 1, n - 1 - IF (C_string(i) .EQ. NUL) THEN - EXIT - ELSE - m = m + 1 - END IF - END DO - ALLOCATE (CHARACTER(m) :: F_string) - DO i = 1, m - F_string(i:i) = C_string(i) - END DO -END FUNCTION Fstring1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! FUNCTION Fstring2(C_string) RESULT(F_string) -! TYPE(C_CHAR_PTR), INTENT(IN) :: C_string -! !! C pointer -! CHARACTER(:), ALLOCATABLE :: F_string -! !! Fortran string -! -! ! ! internal variables -! ! CHARACTER(1, KIND=C_CHAR), POINTER :: p_chars(:) -! ! INTEGER(I4B) :: i, n, m -! ! -! ! !> main -! ! IF (.NOT. C_ASSOCIATED(C_string)) THEN -! ! F_string = '' -! ! RETURN -! ! ELSE -! ! CALL C_F_POINTER(C_string, p_chars, [HUGE(0)]) -! ! i = 1 -! ! DO WHILE (p_chars(i) .NE. NUL .AND. I .LE. LEN(F_string)) -! ! F_string(i:i) = p_chars(i); i = i + 1 -! ! END DO -! ! IF (i .LT. LEN(F_string)) F_string(i:) = ' ' -! ! END IF -! ! -! ! n = SIZE(C_string) -! ! m = 0 -! ! -! ! DO i = 1, n - 1 -! ! IF (C_string(i) .EQ. NUL) THEN -! ! EXIT -! ! ELSE -! ! m = m + 1 -! ! END IF -! ! END DO -! ! -! ! ALLOCATE (CHARACTER(m) :: F_string) -! ! -! ! DO i = 1, m -! ! F_string(i:i) = C_string(i) -! ! END DO -! END FUNCTION Fstring2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Copy a Fortran string to an allocated C string pointer. -! -!# Introduction -! -! Copy a Fortran string to an allocated C string pointer. -! If the C pointer is NULL, no action is taken. (Maybe auto allocate via libc call?) -! If the length is not passed, the C string must be at least: len(F_string)+1 -! If the length is passed and F_string is too long, it is truncated. - -SUBROUTINE F_C_STRING_PTR(F_string, C_string, C_string_len) - CHARACTER(*), INTENT(IN) :: F_string - TYPE(C_CHAR_PTR), INTENT(IN) :: C_string - !! target = intent(out) - INTEGER(I4B), INTENT(IN), OPTIONAL :: C_string_len - !! Max string length, - !! INCLUDING THE TERMINAL NUL - !> internal variables - CHARACTER(1, KIND=C_CHAR), DIMENSION(:), POINTER :: p_chars - INTEGER(I4B) :: i, strlen - !> main - strlen = LEN(F_string) - IF (PRESENT(C_string_len)) THEN - IF (C_string_len .LE. 0) RETURN - strlen = MIN(strlen, C_string_len - 1) - END IF - IF (.NOT. C_ASSOCIATED(C_string)) RETURN - CALL C_F_POINTER(C_string, p_chars, [strlen + 1]) - DO CONCURRENT(i=1:strlen) - p_chars(i) = F_string(i:i) - END DO - p_chars(strlen + 1) = NUL -END SUBROUTINE F_C_STRING_PTR - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Copy a Fortran string to a C string passed by char-array reference. -! -!# Introduction -! -! Copy a Fortran string to a C string passed by char-array reference. -! If the length is not passed, the C string must be at least: len(F_string)+1 -! If the length is passed and F_string is too long, it is truncated. - -SUBROUTINE F_C_STRING_CHARS(F_string, C_string, C_string_len) - CHARACTER(*), INTENT(IN) :: F_string - ! fortran string - CHARACTER(1, KIND=C_CHAR), INTENT(OUT) :: C_string(*) - ! c string - INTEGER(I4B), INTENT(IN), OPTIONAL :: C_string_len - ! max string length, optional - ! - ! main - ! - INTEGER(I4B) :: i, strlen - ! - strlen = LEN(F_string) - IF (PRESENT(C_string_len)) THEN - IF (C_string_len .LE. 0) RETURN - strlen = MIN(strlen, C_string_len - 1) - END IF - ! - DO CONCURRENT(i=1:strlen) - C_string(i) = F_string(i:i) - END DO - ! - C_string(strlen + 1) = NUL - ! -END SUBROUTINE F_C_STRING_CHARS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-21 -! summary: Convert a fortran string to cString - -FUNCTION CString(o) RESULT(v) - CHARACTER(*), INTENT(in) :: o - CHARACTER(:, kind=C_CHAR), ALLOCATABLE :: v - v = TRIM(o)//C_NULL_CHAR -END FUNCTION CString - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Convert Fortran string to C string - -FUNCTION F_C_STRING_DUP(F_string, length) RESULT(C_string) - CHARACTER(*), INTENT(IN) :: F_string - INTEGER, INTENT(IN), OPTIONAL :: length - TYPE(C_PTR) :: C_string - !> internal variables - CHARACTER(1, KIND=C_CHAR), POINTER :: C_string_ptr(:) - INTEGER(I4B) :: i - INTEGER(C_SIZE_T) :: strlen - !> main - IF (PRESENT(length)) THEN - strlen = length - ELSE - strlen = LEN(F_string) - END IF - IF (strlen .LE. 0) THEN - C_string = C_NULL_PTR - ELSE - C_string = C_MALLOC(strlen + 1) - IF (C_ASSOCIATED(C_string)) THEN - CALL C_F_POINTER(C_string, C_string_ptr, [strlen + 1]) - DO CONCURRENT(i=1:strlen) - C_string_ptr(i) = F_string(i:i) - END DO - C_string_ptr(strlen + 1) = NUL - END IF - END IF -END FUNCTION F_C_STRING_DUP - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: This function returns length of string - -PURE FUNCTION C_STRLEN_SAFE(s) RESULT(length) - INTEGER(C_SIZE_T) :: length - TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s - !> - IF (.NOT. C_ASSOCIATED_PURE(s)) THEN - length = 0 - ELSE - length = C_STRLEN(s) - END IF -END FUNCTION C_STRLEN_SAFE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Returns the value of target of C string - -FUNCTION C_STRING_VALUE(C_string) RESULT(F_string) - TYPE(C_CHAR_PTR), INTENT(IN) :: C_string - CHARACTER(LEN=C_STRLEN_SAFE(C_string)) :: F_string - !> internal variables - CHARACTER(1, kind=C_CHAR), DIMENSION(:), POINTER :: p_chars - INTEGER(I4B) :: i, length - !> main - length = LEN(F_string) - IF (length .NE. 0) THEN - CALL C_F_POINTER(C_string, p_chars, [length]) - DO CONCURRENT(i=1:length) - F_string(i:i) = p_chars(i) - END DO - END IF -END FUNCTION C_STRING_VALUE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Allocate memory space and return C string - -FUNCTION C_STRING_ALLOC(length) RESULT(C_string) - INTEGER(C_SIZE_T), INTENT(IN) :: length - TYPE(C_PTR) :: C_String - !> internal variables - CHARACTER(1, KIND=C_CHAR), POINTER :: C_CHARPTR - !> main - C_string = C_MALLOC(length + 1) - IF (C_ASSOCIATED(C_string)) THEN - CALL C_F_POINTER(C_string, C_charptr) - C_CHARPTR = NUL - END IF -END FUNCTION C_STRING_ALLOC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE C_STRING_FREE(string) - TYPE(C_PTR), INTENT(INOUT) :: string - IF (C_ASSOCIATED(string)) THEN - CALL C_FREE(string) - string = C_NULL_PTR - END IF -END SUBROUTINE C_STRING_FREE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Converts C pointer to integer vector - -SUBROUTINE C_PTR_TO_Int8_VEC(vec, cptr) - INTEGER(INT8), INTENT(OUT) :: vec(:) - TYPE(C_PTR), INTENT(IN) :: cptr - !> Internal variables - INTEGER(I4B) :: n, ii - INTEGER(INT8), POINTER :: p(:) - !> main - n = SIZE(vec); vec = 0 - IF (C_ASSOCIATED(cptr)) THEN - CALL C_F_POINTER(cptr, p, [n]) - DO ii = 1, n - vec(ii) = p(ii) - END DO - DEALLOCATE (p) - END IF -END SUBROUTINE C_PTR_TO_Int8_VEC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Converts C pointer to integer vector - -SUBROUTINE C_PTR_TO_Int16_VEC(vec, cptr) - INTEGER(INT16), INTENT(OUT) :: vec(:) - TYPE(C_PTR), INTENT(IN) :: cptr - !> Internal variables - INTEGER(I4B) :: n, ii - INTEGER(INT16), POINTER :: p(:) - !> main - n = SIZE(vec); vec = 0 - IF (C_ASSOCIATED(cptr)) THEN - CALL C_F_POINTER(cptr, p, [n]) - DO ii = 1, n - vec(ii) = p(ii) - END DO - DEALLOCATE (p) - END IF -END SUBROUTINE C_PTR_TO_Int16_VEC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Converts C pointer to integer vector - -SUBROUTINE C_PTR_TO_Int32_VEC(vec, cptr) - INTEGER(INT32), INTENT(OUT) :: vec(:) - TYPE(C_PTR), INTENT(IN) :: cptr - !> Internal variables - INTEGER(I4B) :: n, ii - INTEGER(INT32), POINTER :: p(:) - !> main - n = SIZE(vec); vec = 0 - IF (C_ASSOCIATED(cptr)) THEN - CALL C_F_POINTER(cptr, p, [n]) - DO ii = 1, n - vec(ii) = p(ii) - END DO - DEALLOCATE (p) - END IF -END SUBROUTINE C_PTR_TO_Int32_VEC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Converts C pointer to integer vector - -SUBROUTINE C_PTR_TO_Int64_VEC(vec, cptr) - INTEGER(INT64), INTENT(OUT) :: vec(:) - TYPE(C_PTR), INTENT(IN) :: cptr - !> Internal variables - INTEGER(I4B) :: n, ii - INTEGER(INT64), POINTER :: p(:) - !> main - n = SIZE(vec); vec = 0 - IF (C_ASSOCIATED(cptr)) THEN - CALL C_F_POINTER(cptr, p, [n]) - DO ii = 1, n - vec(ii) = p(ii) - END DO - DEALLOCATE (p) - END IF -END SUBROUTINE C_PTR_TO_Int64_VEC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Converts C pointer to real vector - -SUBROUTINE C_PTR_TO_Real32_VEC(vec, cptr) - REAL(REAL32), INTENT(OUT) :: vec(:) - TYPE(C_PTR), INTENT(IN) :: cptr - ! Internal variables - INTEGER :: n, ii - REAL(REAL32), POINTER :: p(:) - !> main - n = SIZE(vec); vec = 0 - IF (C_ASSOCIATED(cptr)) THEN - CALL C_F_POINTER(cptr, p, [n]) - DO ii = 1, n - vec(ii) = p(ii) - END DO - DEALLOCATE (p) - END IF -END SUBROUTINE C_PTR_TO_Real32_VEC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Sept 2021 -! summary: Converts C pointer to real vector - -SUBROUTINE C_PTR_TO_Real64_VEC(vec, cptr) - REAL(REAL64), INTENT(OUT) :: vec(:) - TYPE(C_PTR), INTENT(IN) :: cptr - ! Internal variables - INTEGER :: n, ii - REAL(REAL64), POINTER :: p(:) - !> main - n = SIZE(vec); vec = 0 - IF (C_ASSOCIATED(cptr)) THEN - CALL C_F_POINTER(cptr, p, [n]) - DO ii = 1, n - vec(ii) = p(ii) - END DO - DEALLOCATE (p) - END IF -END SUBROUTINE C_PTR_TO_Real64_VEC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Nov 2022 -! summary: optional value for `C_INT` -! -!# Introduction -! -! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 - -PURE FUNCTION optval_c_int_1(default, option) RESULT(res) - INTEGER(C_INT), INTENT(IN) :: default - INTEGER(C_INT), OPTIONAL, INTENT(IN) :: option - INTEGER(C_INT) :: res - !! - IF (PRESENT(option)) THEN - res = INT(option, KIND=C_INT) - ELSE - res = INT(default, KIND=C_INT) - END IF -END FUNCTION optval_c_int_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Nov 2022 -! summary: Optional value for `C_SIZE_T` -! -!# Introduction -! -! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 - -PURE FUNCTION optval_c_size_t_1(default, option) RESULT(res) - INTEGER(I4B), INTENT(IN) :: default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: option - INTEGER(C_SIZE_T) :: res - !! - IF (PRESENT(option)) THEN - res = INT(option, KIND=C_SIZE_T) - ELSE - res = INT(default, KIND=C_SIZE_T) - END IF -END FUNCTION optval_c_size_t_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Nov 2022 -! summary: Optional value for `C_SIZE_T` -! -!# Introduction -! -! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 - -PURE FUNCTION optval_c_size_t_2(default, option) RESULT(res) - INTEGER(C_SIZE_T), INTENT(IN) :: default - INTEGER(C_SIZE_T), OPTIONAL, INTENT(IN) :: option - INTEGER(C_SIZE_T) :: res - !! - IF (PRESENT(option)) THEN - res = INT(option, KIND=C_SIZE_T) - ELSE - res = INT(default, KIND=C_SIZE_T) - END IF -END FUNCTION optval_c_size_t_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Nov 2022 -! summary: Optional value for `C_DOUBLE` -! -!# Introduction -! -! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 - -PURE FUNCTION optval_c_double_1(default, option) RESULT(res) - REAL(C_DOUBLE), INTENT(in) :: default - REAL(C_DOUBLE), OPTIONAL, INTENT(in) :: option - REAL(C_DOUBLE) :: res - !! - res = REAL(default, kind=C_DOUBLE) - IF (PRESENT(option)) res = REAL(option, kind=C_DOUBLE) -END FUNCTION optval_c_double_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Nov 2022 -! summary: Optional value for `C_DOUBLE` -! -!# Introduction -! -! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 - -PURE FUNCTION optval_c_double_2(default, option) RESULT(res) - REAL, INTENT(in) :: default - REAL(C_DOUBLE), OPTIONAL, INTENT(in) :: option - REAL(C_DOUBLE) :: res - !! - res = REAL(default, kind=C_DOUBLE) - IF (PRESENT(option)) res = REAL(option, kind=C_DOUBLE) -END FUNCTION optval_c_double_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Nov 2022 -! summary: Optional value for boolean -! -!# Introduction -! -! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 - -PURE FUNCTION optval_c_bool(default, option) RESULT(res) - LOGICAL, INTENT(in) :: default - LOGICAL, OPTIONAL, INTENT(in) :: option - INTEGER(C_INT) :: res - !! - res = MERGE(1_C_INT, 0_C_INT, default) - IF (PRESENT(option)) res = MERGE(1_C_INT, 0_C_INT, option) -END FUNCTION optval_c_bool - -END MODULE CInterface diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt deleted file mode 100644 index 18beb64bf..000000000 --- a/src/modules/CMakeLists.txt +++ /dev/null @@ -1,211 +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 -# - -# FFTW -include(${CMAKE_CURRENT_LIST_DIR}/FFTW/CMakeLists.txt) - -# PENF -include(${CMAKE_CURRENT_LIST_DIR}/PENF/CMakeLists.txt) - -# BeFoR64 -include(${CMAKE_CURRENT_LIST_DIR}/BeFoR64/CMakeLists.txt) - -# String -include(${CMAKE_CURRENT_LIST_DIR}/String/CMakeLists.txt) - -# FACE -include(${CMAKE_CURRENT_LIST_DIR}/FACE/CMakeLists.txt) - -# FPL -include(${CMAKE_CURRENT_LIST_DIR}/FPL/CMakeLists.txt) - -# System -include(${CMAKE_CURRENT_LIST_DIR}/System/CMakeLists.txt) - -# TriangleInterface -include(${CMAKE_CURRENT_LIST_DIR}/TriangleInterface/CMakeLists.txt) - -# BLAS95 -include(${CMAKE_CURRENT_LIST_DIR}/BLAS95/CMakeLists.txt) - -# Test -include(${CMAKE_CURRENT_LIST_DIR}/Test/CMakeLists.txt) - -# GlobalData -include(${CMAKE_CURRENT_LIST_DIR}/GlobalData/CMakeLists.txt) - -# RaylibInterface -include(${CMAKE_CURRENT_LIST_DIR}/RaylibInterface/CMakeLists.txt) - -# Display -include(${CMAKE_CURRENT_LIST_DIR}/Display/CMakeLists.txt) - -# ARPACK -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) - -# CInterface -include(${CMAKE_CURRENT_LIST_DIR}/CInterface/CMakeLists.txt) - -# LuaInterface -include(${CMAKE_CURRENT_LIST_DIR}/LuaInterface/CMakeLists.txt) - -# SuperLUInterface -include(${CMAKE_CURRENT_LIST_DIR}/SuperLUInterface/CMakeLists.txt) - -# LISInterface -include(${CMAKE_CURRENT_LIST_DIR}/LISInterface/CMakeLists.txt) - -# MetisInterface -include(${CMAKE_CURRENT_LIST_DIR}/MetisInterface/CMakeLists.txt) - -# MdEncode -include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) - -# ErrorHandling -include(${CMAKE_CURRENT_LIST_DIR}/ErrorHandling/CMakeLists.txt) - -# Utility -include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) - -# Kdtree2 -include(${CMAKE_CURRENT_LIST_DIR}/Kdtree2/CMakeLists.txt) - -# BaseInterpolation -include(${CMAKE_CURRENT_LIST_DIR}/BaseInterpolation/CMakeLists.txt) - -# BaseContinuity -include(${CMAKE_CURRENT_LIST_DIR}/BaseContinuity/CMakeLists.txt) - -# Polynomial -include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) - -# BaseType -include(${CMAKE_CURRENT_LIST_DIR}/BaseType/CMakeLists.txt) - -# MultiIndices -include(${CMAKE_CURRENT_LIST_DIR}/MultiIndices/CMakeLists.txt) - -# OpenMP -include(${CMAKE_CURRENT_LIST_DIR}/OpenMP/CMakeLists.txt) - -# Random -include(${CMAKE_CURRENT_LIST_DIR}/Random/CMakeLists.txt) - -# BoundingBox -include(${CMAKE_CURRENT_LIST_DIR}/BoundingBox/CMakeLists.txt) - -# IntVector -include(${CMAKE_CURRENT_LIST_DIR}/IntVector/CMakeLists.txt) - -# IndexValue -include(${CMAKE_CURRENT_LIST_DIR}/IndexValue/CMakeLists.txt) - -# IndexValue -include(${CMAKE_CURRENT_LIST_DIR}/IterationData/CMakeLists.txt) - -# KeyValue -include(${CMAKE_CURRENT_LIST_DIR}/KeyValue/CMakeLists.txt) - -# Vector3D_ -include(${CMAKE_CURRENT_LIST_DIR}/Vector3D/CMakeLists.txt) - -# Lapack -include(${CMAKE_CURRENT_LIST_DIR}/Lapack/CMakeLists.txt) - -# RealVector -include(${CMAKE_CURRENT_LIST_DIR}/RealVector/CMakeLists.txt) - -# DOF -include(${CMAKE_CURRENT_LIST_DIR}/DOF/CMakeLists.txt) - -# Geometry -include(${CMAKE_CURRENT_LIST_DIR}/Geometry/CMakeLists.txt) - -# QuadraturePoint -include(${CMAKE_CURRENT_LIST_DIR}/QuadraturePoint/CMakeLists.txt) - -# FEVariable -include(${CMAKE_CURRENT_LIST_DIR}/FEVariable/CMakeLists.txt) - -# ElemshapeData -include(${CMAKE_CURRENT_LIST_DIR}/ElemshapeData/CMakeLists.txt) - -# RealMatrix -include(${CMAKE_CURRENT_LIST_DIR}/RealMatrix/CMakeLists.txt) - -# MassMatrix -include(${CMAKE_CURRENT_LIST_DIR}/MassMatrix/CMakeLists.txt) - -# STMassMatrix -include(${CMAKE_CURRENT_LIST_DIR}/STMassMatrix/CMakeLists.txt) - -# DiffusionMatrix -include(${CMAKE_CURRENT_LIST_DIR}/DiffusionMatrix/CMakeLists.txt) - -# STDiffusionMatrix -include(${CMAKE_CURRENT_LIST_DIR}/STDiffusionMatrix/CMakeLists.txt) - -# ConvectiveMatrix -include(${CMAKE_CURRENT_LIST_DIR}/ConvectiveMatrix/CMakeLists.txt) - -# STConvectiveMatrix -include(${CMAKE_CURRENT_LIST_DIR}/STConvectiveMatrix/CMakeLists.txt) - -# StiffnessMatrix -include(${CMAKE_CURRENT_LIST_DIR}/StiffnessMatrix/CMakeLists.txt) - -# ElasticNitscheMatrix -include(${CMAKE_CURRENT_LIST_DIR}/ElasticNitscheMatrix/CMakeLists.txt) - -# FacetMatrix -include(${CMAKE_CURRENT_LIST_DIR}/FacetMatrix/CMakeLists.txt) - -# FEMatrix -include(${CMAKE_CURRENT_LIST_DIR}/FEMatrix/CMakeLists.txt) - -# ForceVector -include(${CMAKE_CURRENT_LIST_DIR}/ForceVector/CMakeLists.txt) - -# STForceVector -include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt) - -# FEVector -include(${CMAKE_CURRENT_LIST_DIR}/FEVector/CMakeLists.txt) - -# VoigtRank2Tensor -include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt) - -# Rank2Tensor -include(${CMAKE_CURRENT_LIST_DIR}/Rank2Tensor/CMakeLists.txt) - -# CSRSparsity -include(${CMAKE_CURRENT_LIST_DIR}/CSRSparsity/CMakeLists.txt) - -# CSRMatrix -include(${CMAKE_CURRENT_LIST_DIR}/CSRMatrix/CMakeLists.txt) - -# BaseMethod -include(${CMAKE_CURRENT_LIST_DIR}/BaseMethod/CMakeLists.txt) - -# easifemBase -include(${CMAKE_CURRENT_LIST_DIR}/easifemBase/CMakeLists.txt) diff --git a/src/modules/CSRMatrix/CMakeLists.txt b/src/modules/CSRMatrix/CMakeLists.txt deleted file mode 100644 index d9f37d031..000000000 --- a/src/modules/CSRMatrix/CMakeLists.txt +++ /dev/null @@ -1,51 +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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/CSRMatrix_AddMethods.F90 - ${src_path}/CSRMatrix_ConstructorMethods.F90 - ${src_path}/CSRMatrix_DiagonalScalingMethods.F90 - ${src_path}/CSRMatrix_GetBlockColMethods.F90 - ${src_path}/CSRMatrix_GetBlockRowMethods.F90 - ${src_path}/CSRMatrix_GetColMethods.F90 - ${src_path}/CSRMatrix_GetMethods.F90 - ${src_path}/CSRMatrix_GetRowMethods.F90 - ${src_path}/CSRMatrix_GetSubMatrixMethods.F90 - ${src_path}/CSRMatrix_ILUMethods.F90 - ${src_path}/CSRMatrix_IOMethods.F90 - ${src_path}/CSRMatrix_LUSolveMethods.F90 - ${src_path}/CSRMatrix_SymMatmulMethods.F90 - ${src_path}/CSRMatrix_MatVecMethods.F90 - ${src_path}/CSRMatrix_ReorderingMethods.F90 - ${src_path}/CSRMatrix_SetBlockColMethods.F90 - ${src_path}/CSRMatrix_SetBlockRowMethods.F90 - ${src_path}/CSRMatrix_SetColMethods.F90 - ${src_path}/CSRMatrix_SetMethods.F90 - ${src_path}/CSRMatrix_SetRowMethods.F90 - ${src_path}/CSRMatrix_SparsityMethods.F90 - ${src_path}/CSRMatrix_UnaryMethods.F90 - ${src_path}/CSRMatrix_Method.F90 - ${src_path}/CSRMatrix_SpectralMethods.F90 - ${src_path}/CSRMatrix_MatrixMarketIO.F90 - ${src_path}/CSRMatrix_DBCMethods.F90 - ${src_path}/CSRMatrix_LinSolveMethods.F90) - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources(${PROJECT_NAME} PRIVATE ${src_path}/CSRMatrix_SuperLU.F90 - ${src_path}/CSRMatrix_SchurMethods.F90) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 deleted file mode 100644 index 90411faa2..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 +++ /dev/null @@ -1,505 +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 CSRMatrix_AddMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 Marach 2021 -! summary: This subroutine Add contribution - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add0(obj, nodenum, VALUE, scale) - 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 - END SUBROUTINE obj_Add0 -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 - 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 - END SUBROUTINE obj_Add1 -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 -! -!# Introduction -! This routine Adds all values of sparse matrix to given value. -! This routine signifies `obj=obj+scale*value`. - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add2(obj, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add2 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Adds a single entry of sparse matrix -! -!# Introduction -! -! This subroutine Adds a single entry of sparse matrix. -! Before using this subroutien the user should be aware of the storage -! pattern of degree of freedom. However, if total number of degrees of -! freedom is one then there is not need to worry. In my opinion, this routine -! should be avoided by general user. - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add3(obj, irow, icolumn, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B), INTENT(IN) :: icolumn - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add3 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Adds the specific row and column entry to a given value -! -!# Introduction -! -! This routine Adds the specific row and column entry to a given value. -! The row and column index is calculated by using (iNodeNum, idof) and -! (jNodeNum, jdof), respectively. -! After computing the irow and icolumn (internally) this routine calls, -! `obj_Add3`. - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add4(obj, iNodeNum, jNodeNum, idof, & - & jdof, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum - INTEGER(I4B), INTENT(IN) :: jNodeNum - INTEGER(I4B), INTENT(IN) :: idof - INTEGER(I4B), INTENT(IN) :: jdof - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add4 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! 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_Add5(obj, nodenum, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add5 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Add the value in sparse matrix -! -!# Introduction -! -! - This subroutine Adds the values in block sparse matrix. -! - The storage pattern of both sparse matrix and value -! (the element matrix) should be in `FMT_DOF`. -! -!$$ -! obj(Nptrs,Nptrs)=value(:,:) -!$$ -! - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, & - & ivar, jvar, VALUE, scale) - 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 - END SUBROUTINE obj_Add6 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Adds the specific row and column entry to a given value -! -!# Introduction -! -! - This routine Adds the specific row and column entry to a given value. -! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Add3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Add3]] -!@endnote -! -!@note -! idof, jdof are continuously numbered, so if there are two -! or more physical variables, then idof and jdof of the second -! or later physical variables will not start from 1. -!@endnote - -INTERFACE Add - 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 - 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 - END SUBROUTINE obj_Add7 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Adds the specific row and column entry to a given value - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum(:) - !! row node number - 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 - END SUBROUTINE obj_Add8 -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 -! -!# Introduction -! -! - This routine Adds the specific row and column entry to a given value. -! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Add3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Add3]] -!@endnote -! -!@note -! idof, jdof are continuously numbered, so if there are two -! or more physical variables, then idof and jdof of the second -! or later physical variables will not start from 1. -!@endnote - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum - !! row node number - 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 - END SUBROUTINE obj_Add9 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17/01/2022 -! summary: This subroutine Add the value in sparse matrix -! -!# Introduction -! -! - This subroutine Adds the values in block sparse matrix. -! - The storage pattern of both sparse matrix and value -! (the element matrix) should be in `FMT_DOF`. -! -!$$ -! obj(Nptrs,Nptrs)=value(:,:) -!$$ -! - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add10(obj, iNodeNum, jNodeNum, & - & ivar, jvar, VALUE, scale) - 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 - END SUBROUTINE obj_Add10 -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_Add11(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum(:) - !! row node number - INTEGER(I4B), INTENT(IN) :: jNodeNum(:) - !! column node number - INTEGER(I4B), INTENT(IN) :: ivar - !! - 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 - END SUBROUTINE obj_Add11 -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_Add12(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum(:) - !! row node number - 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 - END SUBROUTINE obj_Add12 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17/01/2022 -! summary: Adds the specific row and column entry to a given value - -INTERFACE Add - MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum(:) - !! row node number - INTEGER(I4B), INTENT(IN) :: jNodeNum(:) - !! column node number - INTEGER(I4B), INTENT(IN) :: ivar - !! - 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 - END SUBROUTINE obj_Add13 -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_Add14(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum(:) - !! row node number - INTEGER(I4B), INTENT(IN) :: jNodeNum(:) - !! column node number - INTEGER(I4B), INTENT(IN) :: ivar - !! - 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 - END SUBROUTINE obj_Add14 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: obj = obj + scale * value -! -!# Introduction -! -! Add a csrmatrix to another csrmatrix - -INTERFACE Add - MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, & - & isSorted) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - !! CSRMatrix_ - TYPE(CSRMatrix_), INTENT(IN) :: VALUE - !! CSRMatrix to add to obj - REAL(DFP), INTENT(IN) :: scale - !! scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSameStructure - !! If obj and value has same structure - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSorted - !! True if the matrix is sorted. - END SUBROUTINE obj_Add15 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE CSRMatrix_AddMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 deleted file mode 100644 index 9d67cb259..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 +++ /dev/null @@ -1,391 +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 CSRMatrix_ConstructorMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE Basetype, ONLY: CSRMatrix_, DOF_, CSRSparsity_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: Initiate -PUBLIC :: Shape -PUBLIC :: Size -PUBLIC :: TotalDimension -PUBLIC :: SetTotalDimension -PUBLIC :: GetNNZ -PUBLIC :: ALLOCATE -PUBLIC :: DEALLOCATE -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: CSRMatrixAPLSB -PUBLIC :: CSRMatrixAPLSBSorted - -!---------------------------------------------------------------------------- -! Shape@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This function returns the shape of sparse matrix - -INTERFACE Shape - MODULE PURE FUNCTION obj_Shape(obj) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B) :: ans(2) - END FUNCTION obj_Shape -END INTERFACE Shape - -!---------------------------------------------------------------------------- -! Size@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This function returns the size of sparse matrix -! -!# Introduction -! -! This function returns the size of sparse matrix -! If dims equal to 1 then total number of rows are returned -! If dims is equal to 2 then total number of columns are return -! If dims is absent then nrow*ncol are returned - -INTERFACE Size - MODULE PURE FUNCTION obj_Size(obj, dims) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), OPTIONAL, INTENT(IN) :: dims - INTEGER(I4B) :: ans - END FUNCTION obj_Size -END INTERFACE Size - -!---------------------------------------------------------------------------- -! TotalDimension@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Returns the total dimension of an array - -INTERFACE TotalDimension - MODULE PURE FUNCTION obj_TotalDimension(obj) RESULT(ans) - CLASS(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_TotalDimension -END INTERFACE TotalDimension - -!---------------------------------------------------------------------------- -! SetTotalDimension@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine Set the total dimension (rank) of an array - -INTERFACE SetTotalDimension - MODULE PURE SUBROUTINE obj_SetTotalDimension(obj, tDimension) - CLASS(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tDimension - END SUBROUTINE obj_SetTotalDimension -END INTERFACE SetTotalDimension - -!---------------------------------------------------------------------------- -! GetNNZ@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Return the total number of non zero entry in the matrix - -INTERFACE GetNNZ - MODULE PURE FUNCTION obj_GetNNZ(obj) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_GetNNZ -END INTERFACE GetNNZ - -!---------------------------------------------------------------------------- -! Allocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine creates memeory space for the sparse matrix object -! -!# Introduction -! -! This subroutine creates memory space for the sparse matrix -! -! dims(1) denotes total number of rows -! dims(2) denotes total number of columns -! tDOF is Set to 1 -! tNodes is Set to dims(1) -! nnz is Set to to 0 - -INTERFACE ALLOCATE - MODULE SUBROUTINE obj_Allocate(obj, dims, matrixProp) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: dims(2) - CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp - END SUBROUTINE obj_Allocate -END INTERFACE ALLOCATE - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine deallocates the data - -INTERFACE DEALLOCATE - MODULE SUBROUTINE obj_Deallocate(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE obj_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This subroutine construct the `CSRMatrix_` object - -INTERFACE Initiate - MODULE SUBROUTINE obj_Initiate1(obj, ncol, nrow, idof, jdof, matrixProp, nnz) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ncol - !! number of columns in sparse matrix - INTEGER(I4B), INTENT(IN) :: nrow - !! number of rows in sparse matrix - TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof, jdof - !! degree of freedom object; It contains information like - !! storage format (NODES_FMT, DOF_FMT), and names of physical variable - !! space-time component in each physical variables - !! Total number of nodes used for these physical variables - CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp - !! Matrix is `SYM`, `UNSYM` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnz - !! number of non zeros - END SUBROUTINE obj_Initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This subroutine construct the `CSRMatrix_` object -! -!# Introduction -! This subroutine Initiates an instance of [[CSRMatrix_]]. The object so -! created does not own the ownership of `obj%csr`. Instead it points to a -! [[CSRSparsity_]] object which is supplied by the user. -! -!@note -! The object `csr` should be Initiated by the user before sending it to -! CSR matrix via this routine. This is because this routine uses information -! such as ncol, nrow, nnz from the csr. -!@endnote - -INTERFACE Initiate - MODULE SUBROUTINE obj_Initiate2(obj, csr, matrixProp) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRSparsity_), INTENT(IN) :: csr - !! number of columns in sparse matrix - !! number of rows in sparse matrix - !! degree of freedom object; It contains information like - !! storage format (NODES_FMT, DOF_FMT), and names of physical variable - !! space-time component in each physical variables - !! Total number of nodes used for these physical variables - CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp - !! Matrix is `SYM`, `UNSYM` - END SUBROUTINE obj_Initiate2 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine constructs `sparsematrix_` object from IA, JA, A - -INTERFACE Initiate - MODULE SUBROUTINE obj_Initiate3(obj, A, IA, JA, matrixProp, ncol) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: IA(:), JA(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ncol - !! Number of columns in obj, default is number of rows - END SUBROUTINE obj_Initiate3 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 July 2021 -! summary: Initiate by copying -! -!# Introduction -! This routine Initiates obj by copying contents from obj2 -! This routine is used in defining the assignment operator. - -INTERFACE Initiate - MODULE SUBROUTINE obj_Initiate4(obj, obj2) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(IN) :: obj2 - END SUBROUTINE obj_Initiate4 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE obj_Initiate4 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: Initiates a submatrix - -INTERFACE Initiate - MODULE SUBROUTINE obj_Initiate5(obj, obj2, i1, i2, j1, j2) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - !! submatrix to be returned - TYPE(CSRMatrix_), INTENT(IN) :: obj2 - !! csr matrix - INTEGER(I4B), INTENT(IN) :: i1, i2 - !! start and end row indices - INTEGER(I4B), INTENT(IN) :: j1, j2 - !! start and end col indices - END SUBROUTINE obj_Initiate5 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This routine Initiates an instance of sparse matrix by copying -! the content of another object obj2 -! -!# Introduction -! -! This method has been deprecated as it is same as `Initiate4` - -INTERFACE Initiate - MODULE SUBROUTINE obj_Initiate6(obj, obj2, hardCopy) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(IN) :: obj2 - LOGICAL(LGT), INTENT(IN) :: hardCopy - END SUBROUTINE obj_Initiate6 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: Initiate an object by adding two csrmatrix - -INTERFACE Initiate - MODULE SUBROUTINE obj_Initiate7(obj, obj1, obj2, scale, isSorted) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(IN) :: obj1 - TYPE(CSRMatrix_), INTENT(IN) :: obj2 - REAL(DFP), INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSorted - END SUBROUTINE obj_Initiate7 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: Initiate an object by adding two csrmatrix - -INTERFACE CSRMatrixAPLSB - MODULE SUBROUTINE obj_aplsb(nrow, ncol, a, ja, ia, s, b, jb, ib, c, & - & jc, ic, nzmax, ierr) - INTEGER(I4B), INTENT(IN) :: nrow - INTEGER(I4B), INTENT(IN) :: ncol - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - !! nrow + 1 - REAL(DFP), INTENT(IN) :: s - REAL(DFP), INTENT(IN) :: b(:) - INTEGER(I4B), INTENT(IN) :: jb(:) - INTEGER(I4B), INTENT(IN) :: ib(:) - !! nrow + 1 - REAL(DFP), INTENT(INOUT) :: c(:) - !! The size of c should be less than or equalto nzmax - INTEGER(I4B), INTENT(INOUT) :: jc(:) - !! The size of jc should be less than or equalto nzmax - INTEGER(I4B), INTENT(INOUT) :: ic(:) - !! nrow + 1 - INTEGER(I4B), INTENT(IN) :: nzmax - !! max number of nonzero in c - INTEGER(I4B), INTENT(OUT) :: ierr - END SUBROUTINE obj_aplsb -END INTERFACE CSRMatrixAPLSB - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: Initiate an object by adding two csrmatrix - -INTERFACE CSRMatrixAPLSBSorted - MODULE SUBROUTINE obj_aplsb_sorted(nrow, ncol, a, ja, ia, s, b, jb, ib, & - & c, jc, ic, nzmax, ierr) - INTEGER(I4B), INTENT(IN) :: nrow - INTEGER(I4B), INTENT(IN) :: ncol - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - !! nrow + 1 - REAL(DFP), INTENT(IN) :: s - !! scale - REAL(DFP), INTENT(IN) :: b(:) - INTEGER(I4B), INTENT(IN) :: jb(:) - INTEGER(I4B), INTENT(IN) :: ib(:) - !! nrow + 1 - REAL(DFP), INTENT(INOUT) :: c(:) - !! The size of c should be less than or equalto nzmax - INTEGER(I4B), INTENT(INOUT) :: jc(:) - !! The size of jc should be less than or equalto nzmax - INTEGER(I4B), INTENT(INOUT) :: ic(:) - !! nrow + 1 - INTEGER(I4B), INTENT(IN) :: nzmax - !! max number of nonzero in c - INTEGER(I4B), INTENT(OUT) :: ierr - END SUBROUTINE obj_aplsb_sorted -END INTERFACE CSRMatrixAPLSBSorted - -END MODULE CSRMatrix_ConstructorMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 deleted file mode 100644 index ee8c251ca..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 +++ /dev/null @@ -1,36 +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 CSRMatrix_DBCMethods -USE BaseType, ONLY: CSRMatrix_ -USE GlobalData, ONLY: I4B -IMPLICIT NONE -PRIVATE -PUBLIC :: ApplyDBC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE ApplyDBC - MODULE SUBROUTINE csrMat_ApplyDBC(obj, dbcptrs) - CLASS(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: dbcptrs(:) - END SUBROUTINE csrMat_ApplyDBC -END INTERFACE ApplyDBC - -END MODULE CSRMatrix_DBCMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 deleted file mode 100644 index 531597018..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 +++ /dev/null @@ -1,75 +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 CSRMatrix_DiagonalScalingMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: DiagonalScaling - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE csrmat_DiagonalScaling_1(obj, side, OPERATOR) - CLASS(CSRMatrix_), INTENT(INOUT) :: obj - CHARACTER(*), INTENT(IN) :: side - !! LEFT - !! RIGHT - !! BOTH - CHARACTER(*), OPTIONAL, INTENT(IN) :: OPERATOR - !! - !! SQRT <-- default - !! NONE - !! - END SUBROUTINE csrmat_DiagonalScaling_1 -END INTERFACE - -INTERFACE DiagonalScaling - MODULE PROCEDURE csrmat_DiagonalScaling_1 -END INTERFACE DiagonalScaling - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE csrmat_DiagonalScaling_2(obj, side, diag, OPERATOR) - CLASS(CSRMatrix_), INTENT(INOUT) :: obj - CHARACTER(*), INTENT(IN) :: side - !! LEFT - !! RIGHT - !! BOTH - REAL(DFP), INTENT(IN) :: diag(:) - !! Use this diagonal if present - !! - CHARACTER(*), OPTIONAL, INTENT(IN) :: OPERATOR - !! - !! SQRT <-- default - !! NONE - !! - END SUBROUTINE csrmat_DiagonalScaling_2 -END INTERFACE - -INTERFACE DiagonalScaling - MODULE PROCEDURE csrmat_DiagonalScaling_2 -END INTERFACE DiagonalScaling - -END MODULE CSRMatrix_DiagonalScalingMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 deleted file mode 100644 index b25445049..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 +++ /dev/null @@ -1,380 +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 CSRMatrix_GetBlockColMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the col of a sparse matrix -! -!# Introduction -! -! - This routine returns the col of given block matrix -! - This routine is designed to handle block matrices, which -! means it only works when StorageFMT is DOF_FMT -! - ivar is the row number for the block matrix, whose col are to be -! extracting -! - the result is returned inside `value`. -! - `value` should be allocated -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn1(obj, ivar, iColumn, & - & VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: iColumn - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn1 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn1 -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the col of a sparse matrix -! -!# Introduction -! -! - This routine returns the col of given block matrix -! - This routine is designed to handle block matrices, which -! means it only works when StorageFMT is DOF_FMT -! - ivar is the row number for the block matrix, whose col are to be -! extracting -! - the result is returned inside `value`. -! - `value` should be allocated -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn1b(obj, ivar, iColumn, & - & VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: iColumn(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn1b -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn1b -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the col of a sparse matrix -! -!# Introduction -! -! - This routine returns the col of given block matrix -! - This routine is designed to handle block matrices, which -! means it only works when StorageFMT is DOF_FMT -! - ivar is the row number for the block matrix, whose col are to be -! extracting -! - the result is returned inside `value`. -! - `value` should be allocated -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn2(obj, ivar, nodenum, idof, & - & VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn2 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn2 -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, jvar, idof, and nodenum is used to calculate the index of -! physical variable jvar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn3(obj, ivar, jvar, nodenum, idof, & - & VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn3 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn3 -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, jvar, idof, and nodenum is used to calculate the index of -! physical variable jvar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn4(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn4 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn4 -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, jvar, idof, and nodenum is used to calculate the index of -! physical variable jvar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn5(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn5 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn5 -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, jvar, idof, and nodenum is used to calculate the index of -! physical variable jvar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn6(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn6 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn6 -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, jvar, idof, and nodenum is used to calculate the index of -! physical variable jvar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn7(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn7 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn7 -END INTERFACE getBlockColumn - -!---------------------------------------------------------------------------- -! getBlockColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, jvar, idof, and nodenum is used to calculate the index of -! physical variable jvar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockColumn8(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockColumn8 -END INTERFACE - -INTERFACE getBlockColumn - MODULE PROCEDURE csrMat_getBlockColumn8 -END INTERFACE getBlockColumn - -END MODULE CSRMatrix_GetBlockColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 deleted file mode 100644 index adb44c6a9..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 +++ /dev/null @@ -1,385 +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 CSRMatrix_GetBlockRowMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of given block matrix -! - This routine is designed to handle block matrices, which -! means it only works when StorageFMT is DOF_FMT -! - jvar is the column number for the block matrix, whose row we are -! extracting -! - the result is returned inside `value`. -! - `value` should be allocated -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow1(obj, jvar, irow, VALUE, scale, & - & addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: irow - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow1 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow1 -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of given block matrix -! - This routine is designed to handle block matrices, which -! means it only works when StorageFMT is DOF_FMT -! - jvar is the column number for the block matrix, whose row we are -! extracting -! - the result is returned inside `value`. -! - `value` should be allocated -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow1b(obj, jvar, irow, VALUE, scale, & - & addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: irow(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow1b -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow1b -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of given block matrix -! - This routine is designed to handle block matrices, which -! means it only works when StorageFMT is DOF_FMT -! - jvar is the column number for the block matrix, whose row we are -! extracting -! - the result is returned inside `value`. -! - `value` should be allocated -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow2(obj, jvar, nodenum, idof, VALUE, & - & scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow2 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow2 -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number of physical variable ivar -! - `idof` should be between 1 and the total number of dof in ivar -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, ivar, idof, and nodenum is used to calculate the index of -! physical variable ivar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow3(obj, ivar, jvar, nodenum, idof, & - & VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow3 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow3 -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number of physical variable ivar -! - `idof` should be between 1 and the total number of dof in ivar -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, ivar, idof, and nodenum is used to calculate the index of -! physical variable ivar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow4(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow4 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow4 -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number of physical variable ivar -! - `idof` should be between 1 and the total number of dof in ivar -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, ivar, idof, and nodenum is used to calculate the index of -! physical variable ivar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow5(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow5 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow5 -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number of physical variable ivar -! - `idof` should be between 1 and the total number of dof in ivar -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, ivar, idof, and nodenum is used to calculate the index of -! physical variable ivar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow6(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow6 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow6 -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number of physical variable ivar -! - `idof` should be between 1 and the total number of dof in ivar -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, ivar, idof, and nodenum is used to calculate the index of -! physical variable ivar and its degree of freedom -! - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow7(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow7 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow7 -END INTERFACE getBlockRow - -!---------------------------------------------------------------------------- -! getBlockRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number of physical variable ivar -! - `idof` should be between 1 and the total number of dof in ivar -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -! Here, ivar, idof, and nodenum is used to calculate the index of -! physical variable ivar and its degree of freedom - -INTERFACE - MODULE SUBROUTINE csrMat_getBlockRow8(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_getBlockRow8 -END INTERFACE - -INTERFACE getBlockRow - MODULE PROCEDURE csrMat_getBlockRow8 -END INTERFACE getBlockRow - -END MODULE CSRMatrix_GetBlockRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 deleted file mode 100644 index 9b46a92e5..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 +++ /dev/null @@ -1,394 +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 CSRMatrix_GetColMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the column of a sparse matrix -! - This rouine does not care about the storage pattern -! - Therefore, it should be used with care. -! - The result is returned inside the value -! - `value` should be allocated -! - the size of `value` should be atleast the number of rows in csrmatrix -! -! If addContribution is not present -! then the this routine performs the following action -! -!```fortran -! DO i = 1, obj%csr%nrow -! value( i ) = 0.0_DFP -! DO j = obj%csr%IA( i ), obj%csr%IA( i+1 ) - 1 -! IF( obj%csr%JA(j) .EQ. iColumn ) value( i ) = obj%A( j ) -! END DO -! END DO -!``` - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn1(obj, iColumn, VALUE, scale, & - & addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iColumn - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn1 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the column of a sparse matrix -! - This rouine does not care about the storage pattern -! - Therefore, it should be used with care. -! - The result is returned inside the value -! - `value` should be allocated -! - the size of `value` should be atleast the number of rows in csrmatrix -! -! If addContribution is not present -! then the this routine performs the following action -! -!```fortran -! DO i = 1, obj%csr%nrow -! value( i ) = 0.0_DFP -! DO j = obj%csr%IA( i ), obj%csr%IA( i+1 ) - 1 -! IF( obj%csr%JA(j) .EQ. iColumn ) value( i ) = obj%A( j ) -! END DO -! END DO -!``` - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn1b(obj, iColumn, VALUE, scale, & - & addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iColumn(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn1b -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the `nodenum` and `idof`. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the column index from nodenum and idof -!@endnote - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn2(obj, nodenum, idof, VALUE, scale, & - & addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn2 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the `nodenum` and `idof`. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the column index from nodenum and idof -!@endnote - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn3(obj, nodenum, ivar, idof, VALUE, & - & scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn3 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the `nodenum` and `idof`. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the column index from nodenum and idof -!@endnote - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn4(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn4 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the `nodenum` and `idof`. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the column index from nodenum and idof -!@endnote - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn5(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn5 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the `nodenum` and `idof`. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the column index from nodenum and idof -!@endnote - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn6(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn6 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the `nodenum` and `idof`. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the column index from nodenum and idof -!@endnote - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn7(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn7 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! GetColumn@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the Column of a sparse matrix -! -!# Introduction -! -! - This routine returns the Column of a sparse matrix. The Column index is -! calculated using the `nodenum` and `idof`. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the column index from nodenum and idof -!@endnote - -INTERFACE GetColumn - MODULE SUBROUTINE csrMat_GetColumn8(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE csrMat_GetColumn8 -END INTERFACE GetColumn - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE CSRMatrix_GetColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 deleted file mode 100644 index 1a66b9b33..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 +++ /dev/null @@ -1,680 +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 CSRMatrix_GetMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_, DOF_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetStorageFMT -PUBLIC :: OPERATOR(.storageFMT.) -PUBLIC :: OPERATOR(.MatrixProp.) -PUBLIC :: GetMatrixProp -PUBLIC :: GetDOFPointer -PUBLIC :: isSquare -PUBLIC :: isRectangle -PUBLIC :: GetColIndex -PUBLIC :: GetColNumber -PUBLIC :: OPERATOR(.startColumn.) -PUBLIC :: OPERATOR(.endColumn.) -PUBLIC :: GetSingleValue -PUBLIC :: Get -PUBLIC :: GetIA -PUBLIC :: GetJA -PUBLIC :: GetValue - -!---------------------------------------------------------------------------- -! GetIA -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get entry in IA - -INTERFACE GetIA - 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 GetIA - -!---------------------------------------------------------------------------- -! GetJA -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get entry in JA - -INTERFACE GetJA - 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 GetJA - -!---------------------------------------------------------------------------- -! GetSingleValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get single value - -INTERFACE GetSingleValue - 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 - -INTERFACE Get - MODULE PROCEDURE obj_GetSingleValue -END INTERFACE Get - -!---------------------------------------------------------------------------- -! GetSingleValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get single value - -INTERFACE GetSeveralValue - 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 - -INTERFACE Get - MODULE PROCEDURE obj_GetSeveralValue -END INTERFACE Get - -!---------------------------------------------------------------------------- -! GetStorageFMT -!---------------------------------------------------------------------------- - -INTERFACE GetStorageFMT - 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 GetStorageFMT - -INTERFACE OPERATOR(.storageFMT.) - MODULE PROCEDURE obj_GetStorageFMT -END INTERFACE OPERATOR(.storageFMT.) - -!---------------------------------------------------------------------------- -! GetMatrixProp -!---------------------------------------------------------------------------- - -INTERFACE GetMatrixProp - MODULE PURE FUNCTION obj_GetMatrixProp(obj) RESULT(ans) - TYPE(CSRMatrix_), TARGET, INTENT(IN) :: obj - CHARACTER(20) :: ans - END FUNCTION obj_GetMatrixProp -END INTERFACE GetMatrixProp - -INTERFACE OPERATOR(.MatrixProp.) - MODULE PROCEDURE obj_GetMatrixProp -END INTERFACE OPERATOR(.MatrixProp.) - -!---------------------------------------------------------------------------- -! GetDOFPointer -!---------------------------------------------------------------------------- - -INTERFACE GetDOFPointer - 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 GetDOFPointer - -!---------------------------------------------------------------------------- -! isSquare -!---------------------------------------------------------------------------- - -INTERFACE isSquare - MODULE PURE FUNCTION obj_isSquare(obj) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION obj_isSquare -END INTERFACE isSquare - -!---------------------------------------------------------------------------- -! isRectangle -!---------------------------------------------------------------------------- - -INTERFACE isRectangle - MODULE PURE FUNCTION obj_isRectangle(obj) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION obj_isRectangle -END INTERFACE isRectangle - -!---------------------------------------------------------------------------- -! GetColNumber -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the column number from JA. - -INTERFACE GetColNumber - 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 GetColNumber - -!---------------------------------------------------------------------------- -! GetColIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the starting and ending column index of irow - -INTERFACE GetColIndex - 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 GetColIndex - -!---------------------------------------------------------------------------- -! startColumn -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the starting column index of irow - -INTERFACE OPERATOR(.startColumn.) - MODULE PURE FUNCTION obj_startColumn(obj, irow) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B) :: ans - END FUNCTION obj_startColumn -END INTERFACE OPERATOR(.startColumn.) - -!---------------------------------------------------------------------------- -! endColumn -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the ending column index of irow - -INTERFACE OPERATOR(.endColumn.) - MODULE PURE FUNCTION obj_endColumn(obj, irow) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B) :: ans - END FUNCTION obj_endColumn -END INTERFACE OPERATOR(.endColumn.) - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: This subroutine Get the value in sparse matrix -! -!# Introduction -! -! - This subroutine Gets the value in [[CSRMatrix_]] -! - Shape( value ) = [SIZE(nodenum)*tdof, SIZE(nodenum)*tdof] -! - Usually `value` denotes the element matrix -! - Symbolic we are performing following task `obj(nodenum, nodenum)=value` - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE, nrow, ncol) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE obj_Get0 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Get the value in sparse matrix -! -!# Introduction -! -! This subroutine Gets the values in sparse matrix. -! -!$$ -! obj(Nptrs,Nptrs)=value(:,:) -!$$ -! -! - Usually `value(:,:)` represents the element finite element matrix -! - The shape of `value` should be the tdof*size(nodenum), tdof*size(nodenum) -! - `tdof` is the total degree of freedom in obj%csr%dof -! -! - `StorageFMT` denotes the storage format of `value` -! It can be `Nodes_FMT` or `DOF_FMT` -! -! - Usually, element matrix is stored with `DOF_FMT` - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: storageFMT - !! storage format of value (desired format of value) - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE obj_Get1 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Gets a single entry of sparse matrix -! -!# Introduction -! -! - This subroutine Gets a single entry of sparse matrix. -! - Before using this routine the user should be aware of the storage -! pattern of degree of freedom. -! - However, if total number of degrees of freedom is one then there is not -! need to worry. -! -!@warning -! This routine should be avoided by general user. -!@endwarning - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - !! row index - INTEGER(I4B), INTENT(IN) :: icolumn - !! column index - REAL(DFP), INTENT(INOUT) :: VALUE - !! value - END SUBROUTINE obj_Get2 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -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 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: Gets the specific row and column entry to a given value -! -!# Introduction -! -! - This routine Gets the specific row and column entry to a given value. -! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] -! method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Get3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Get2]] -!@endnote -! -!@note -! idof, jdof are continuously numbered, so if there are two -! or more physical variables, then idof and jdof of the second -! or later physical variables will not start from 1. -!@endnote - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, 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) :: iDOF - !! row degree of freedom - INTEGER(I4B), INTENT(IN) :: jDOF - !! col degree of freedom - REAL(DFP), INTENT(INOUT) :: VALUE - !! scalar value to be Get - END SUBROUTINE obj_Get3 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: This subroutine get the value from the sparse matrix -! -!# Introduction -! -! - This subroutine Gets the values from block sparse matrix. -! - The storage pattern of both sparse matrix and value -! (the element matrix) should be in `FMT_DOF`. -! -!$$ -! obj(Nptrs,Nptrs)=value(:,:) -!$$ - -INTERFACE GetValue - 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(:) - !! row node numbers - INTEGER(I4B), INTENT(IN) :: jNodeNum(:) - !! column node numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! row physical variables - INTEGER(I4B), INTENT(IN) :: jvar - !! column physical variables - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - !! value - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE obj_Get4 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: Gets the specific row and column entry to a given value -! -!# Introduction -! -! - This routine Gets the specific row and column entry to a given value. -! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do the above task, routine employs [[DOF_Method:getNodeLoc]] method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Get3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Get3]] -!@endnote -! -!@note -! rowdof, coldof are continuously numbered, so if there are two -! or more physical variables, then rowdof and coldof of the second -! 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) - 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 - !! - 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(INOUT) :: VALUE - !! scalar value to be Get - END SUBROUTINE obj_Get5 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: Gets the specific row and column entry from a given value - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & - jvar, iDOF, jDOF, VALUE, nrow, ncol) - TYPE(CSRMatrix_), INTENT(IN) :: obj - !! block matrix field - INTEGER(I4B), INTENT(IN) :: iNodeNum(:) - !! row node number - INTEGER(I4B), INTENT(IN) :: jNodeNum(:) - !! column node number - INTEGER(I4B), INTENT(IN) :: ivar - !! row physical variables - INTEGER(I4B), INTENT(IN) :: jvar - !! column physical variable - INTEGER(I4B), INTENT(IN) :: iDOF - !! row degree of freedom - INTEGER(I4B), INTENT(IN) :: jDOF - !! col degree of freedom - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - !! Matrix value - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE obj_Get6 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: Gets the specific row and column entry from the matrix -! -!# Introduction -! -! - This routine Gets the specific row and column entry from the matrix. -! - The irow and icolumn index in `CSRMatrix_` are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do above task, the routine employs [[DOF_Method:getNodeLoc]] method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Get3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Get3]] -!@endnote -! -!@note -! rowdof, coldof are continuously numbered, so if there are two -! or more physical variables, then rowdof and coldof of the second -! 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) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum - !! row node number - INTEGER(I4B), INTENT(IN) :: jNodeNum - !! column node number - INTEGER(I4B), INTENT(IN) :: ivar - !! row physical variable - INTEGER(I4B), INTENT(IN) :: jvar - !! col physical variable - INTEGER(I4B), INTENT(IN) :: ispacecompo - !! row space component - INTEGER(I4B), INTENT(IN) :: itimecompo - !! row time component - INTEGER(I4B), INTENT(IN) :: jspacecompo - !! col space component - INTEGER(I4B), INTENT(IN) :: jtimecompo - !! col time component - REAL(DFP), INTENT(INOUT) :: VALUE - !! scalar value to be Get - END SUBROUTINE obj_Get7 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -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 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: Gets the specific row and column entry from the matrix -! -!# Introduction -! -! - 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) - TYPE(CSRMatrix_), INTENT(IN) :: obj1 - !! master object - TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 - !! slave object - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ivar1 - !! row physical variable obj1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: jvar1 - !! col physical variable obj1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ispacecompo1 - !! row space component obj1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: itimecompo1 - !! row time component obj1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: jspacecompo1 - !! col space component obj1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: jtimecompo1 - !! col time component obj1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ivar2 - !! row physical variable obj2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: jvar2 - !! col physical variable obj2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ispacecompo2 - !! row space component obj2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: itimecompo2 - !! row time component obj2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: jspacecompo2 - !! col space component obj2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: jtimecompo2 - !! col time component obj2 - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: ierr - !! Error code, if 0 no error, else error - END SUBROUTINE obj_Get8 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: Gets the specific row and column entry from the matrix -! -!# Introduction -! -! - 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) - TYPE(CSRMatrix_), INTENT(IN) :: obj1 - !! master object - TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 - !! slave object - INTEGER(I4B), INTENT(IN) :: idof1 - !! row space component obj1 - INTEGER(I4B), INTENT(IN) :: jdof1 - !! row time component obj1 - INTEGER(I4B), INTENT(IN) :: idof2 - !! col space component obj1 - INTEGER(I4B), INTENT(IN) :: jdof2 - !! col time component obj1 - INTEGER(I4B), INTENT(IN) :: tNodes1 - INTEGER(I4B), INTENT(IN) :: tNodes2 - END SUBROUTINE CSR2CSR_Get_Master -END INTERFACE - -END MODULE CSRMatrix_GetMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 deleted file mode 100644 index a266d3b11..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 +++ /dev/null @@ -1,348 +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 CSRMatrix_GetRowMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix -! - This rouine does not care about the storage pattern -! - Therefore, it should be used with care. -! - The result is returned inside the value -! - `value` should be allocated -! - the size of `value` should be atleast the number of columns in csrmatrix -! -! If addContribution is not present -! then the this routine performs the following action -! -!```fortran -! value = 0.0_DFP -! value(obj%csr%JA(a:b)) = obj%A( a:b ) -!``` - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow1(obj, irow, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - !! index of row in csr matrix - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow1 -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix -! - This rouine does not care about the storage pattern -! - Therefore, it should be used with care. -! - The result is returned inside the value -! - `value` should be allocated -! - the size of `value` should be atleast the number of columns in csrmatrix -! -! If addContribution is not present -! then the this routine performs the following action -! -!```fortran -! value = 0.0_DFP -! value(obj%csr%JA(a:b)) = obj%A( a:b ) -!``` - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow1b(obj, irow, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow(:) - !! index of row in csr matrix - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow1b -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the row index from nodenum and idof -!@endnote - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow2(obj, nodenum, idof, VALUE, scale, & - & addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow2 -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the row index from nodenum and idof -!@endnote - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow3(obj, nodenum, ivar, idof, VALUE, scale, & - & addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow3 -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the row index from nodenum and idof -!@endnote - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow4(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow4 -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the row index from nodenum and idof -!@endnote - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow5(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow5 -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the row index from nodenum and idof -!@endnote - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow6(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow6 -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the row index from nodenum and idof -!@endnote - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow7(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow7 -END INTERFACE GetRow - -!---------------------------------------------------------------------------- -! GetRow@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the row of a sparse matrix -! -!# Introduction -! -! - This routine returns the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. -! -!@note -! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate -! the row index from nodenum and idof -!@endnote - -INTERFACE GetRow - MODULE SUBROUTINE obj_GetRow8(obj, nodenum, ivar, spacecompo, & - & timecompo, VALUE, scale, addContribution) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(INOUT) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - END SUBROUTINE obj_GetRow8 -END INTERFACE GetRow - -END MODULE CSRMatrix_GetRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 deleted file mode 100644 index 3ab0128e2..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.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 -! - -MODULE CSRMatrix_GetSubMatrixMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: GetSubMatrix - -!---------------------------------------------------------------------------- -! GetColumn@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the submatrix - -INTERFACE GetSubMatrix - 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 GetSubMatrix - -!---------------------------------------------------------------------------- -! GetColumn@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the submatrix - -INTERFACE GetSubMatrix - 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 GetSubMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE CSRMatrix_GetSubMatrixMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 deleted file mode 100644 index 8201feadc..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 +++ /dev/null @@ -1,513 +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 CSRMatrix_ILUMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_, RealMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: getILUT -PUBLIC :: getILUTP -PUBLIC :: getILUD -PUBLIC :: getILUDP -PUBLIC :: getILUK - -!---------------------------------------------------------------------------- -! getILUT@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUT precondition -! -!# Introduction -! -! This routine builds the ILUT precondition. Incomplete LU factorization with -! dual truncation mechanism. -! -! - `obj` matrix stored in Compressed Sparse Row format. -! - `lfil` = integer. The fill-in parameter. Each row of L and each row of U -! will have a maximum of lfil elements (excluding the diagonal element). lfil -! must be .ge. 0. -! - `droptol` = real*8. Sets the threshold for dropping small terms in the -! factorization. See below for details on dropping strategy. -! -! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing -! the L and U factors together. The diagonal (stored in ALU(1:n) ) is -! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L -! (excluding the diagonal entry=1) followed by the ith row of U. -! - JU = integer array of length n containing the pointers to the beginning -! of each row of U in the matrix ALU,JLU. -! -! The diagonal elements of the input matrix must be nonzero (at least -! 'structurally'). Dual drop strategy works as follows: -! -! - Theresholding in L and U as set by `droptol`. Any element whose -! MAGNITUDE is less than some tolerance (relative to the abs value of -! diagonal element in U) is dropped. -! - Keeping only the largest `lfil` elements in the ith row of L and the -! largest `lfil` elements in the ith row of `U` (excluding diagonal elements). -! - Flexibility: one can use `droptol=0` to get a strategy based on -! keeping the largest elements in each row of `L` and `U`. -! - Taking `droptol .ne. 0` but `lfil=n` will give the usual threshold -! strategy (however, fill-in is then mpredictible). - -INTERFACE - MODULE SUBROUTINE csrMat_getILUT1(obj, ALU, JLU, JU, lfil, droptol) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) - INTEGER(I4B), INTENT(IN) :: lfil - REAL(DFP), INTENT(IN) :: droptol - END SUBROUTINE csrMat_getILUT1 -END INTERFACE - -INTERFACE getILUT - MODULE PROCEDURE csrMat_getILUT1 -END INTERFACE getILUT - -!---------------------------------------------------------------------------- -! getILUT@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUT precondition -! -!# Introduction -! This routine builds the ILUT precondition. Incomplete LU factorization with -! dual truncation mechanism. -! -! This routine calls `csrMat_getILUT1`. The only difference between -! this routine and `csrMat_getILUT1` is that the present routine -! returns ILU data in `CSRMatrix_` format. However, the `csrMat_getILUT1` -! returns the ILU data in MSR format. -! -! This routine calls `MSRCSR` routine from Sparsekit lib. - -INTERFACE - MODULE SUBROUTINE csrMat_getILUT2(obj, Pmat, lfil, droptol) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat - INTEGER(I4B), INTENT(IN) :: lfil - REAL(DFP), INTENT(IN) :: droptol - END SUBROUTINE csrMat_getILUT2 -END INTERFACE - -INTERFACE getILUT - MODULE PROCEDURE csrMat_getILUT2 -END INTERFACE getILUT - -!---------------------------------------------------------------------------- -! getILUTP@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUT precondition -! -!# Introduction -! -! This routine builds the ILUTP precondition. ILUT with pivoting, incomplete -! LU factorization with dual truncation mechanism -! -! - `obj` matrix stored in Compressed Sparse Row format. -! - `lfil` denotes the fill-in parameter. Each row of L and each row of U -! will have a maximum of lfil elements (excluding the diagonal element). -! lfil -! must be .ge. 0. -! - `droptol` sets the threshold for dropping small terms in the -! factorization. See below for details on dropping strategy. -! - `permtol` = tolerance ratio used to determine whether or not to permute -! two columns. At step i columns i and j are permuted when -! -! `abs(a(i,j))*permtol .gt. abs(a(i,i))`. -! -! - permtol=0 implies never permute; good values 0.1 to 0.01 -! -! - `mbloc` = if desired, permuting can be done only within the diagonal -! blocks of size mbloc. Useful for PDE problems with several degrees of -! freedom.. If feature not wanted take mbloc=n. -! -! `iperm` = contains the permutation arrays. iperm(1:n) = old numbers of -! unknowns iperm(n+1:2*n) = reverse permutation = new unknowns. -! -! TO AVOID PERMUTING THE SOLUTION VECTORS ARRAYS FOR EACH LU-SOLVE, THE -! MATRIX A IS PERMUTED ON RETURN. All column indices are changed. SIMILARLY -! FOR THE U MATRIX. To permute the matrix back to its original state use the -! loop: -! -!```fortran -! do k=ia(1), ia(n+1)-1 -! ja(k) = iperm(ja(k)) -! enddo -!``` -! -! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing -! the L and U factors together. The diagonal (stored in ALU(1:n) ) is -! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L -! (excluding the diagonal entry=1) followed by the ith row of U. -! - JU = integer array of length n containing the pointers to the beginning -! of each row of U in the matrix ALU,JLU. -! -! - Theresholding in L and U as set by `droptol`. Any element whose -! MAGNITUDE is less than some tolerance (relative to the abs value of -! diagonal element in U) is dropped. -! - Keeping only the largest `lfil` elements in the ith row of L and the -! largest `lfil` elements in the ith row of `U` (excluding diagonal elements). -! - Flexibility: one can use `droptol=0` to get a strategy based on -! keeping the largest elements in each row of `L` and `U`. -! - Taking `droptol .ne. 0` but `lfil=n` will give the usual threshold -! strategy (however, fill-in is then mpredictible). - -INTERFACE - MODULE SUBROUTINE csrMat_getILUTP1(obj, ALU, JLU, JU, lfil, droptol, & - & permtol, mbloc, IPERM) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) - INTEGER(I4B), INTENT(IN) :: lfil - REAL(DFP), INTENT(IN) :: droptol - REAL(DFP), INTENT(IN) :: permtol - INTEGER(I4B), INTENT(IN) :: mbloc - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) - END SUBROUTINE csrMat_getILUTP1 -END INTERFACE - -INTERFACE getILUTP - MODULE PROCEDURE csrMat_getILUTP1 -END INTERFACE getILUTP - -!---------------------------------------------------------------------------- -! getILUTP@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUT precondition -! -!# Introduction -! This routine builds the ILUTP precondition. ILUT with pivoting, incomplete -! LU factorization with dual truncation mechanism -! -! This routine calls `csrMat_getILUTP1`. -! This routine calls `MSRCSR` from Sparsekit - -INTERFACE - MODULE SUBROUTINE csrMat_getILUTP2(obj, Pmat, lfil, droptol, permtol, & - & mbloc, IPERM) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat - INTEGER(I4B), INTENT(IN) :: lfil - REAL(DFP), INTENT(IN) :: droptol - REAL(DFP), INTENT(IN) :: permtol - INTEGER(I4B), INTENT(IN) :: mbloc - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) - END SUBROUTINE csrMat_getILUTP2 -END INTERFACE - -INTERFACE getILUTP - MODULE PROCEDURE csrMat_getILUTP2 -END INTERFACE getILUTP - -!---------------------------------------------------------------------------- -! getILUTD@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUT precondition -! -!# Introduction -! -! This routine computes the ILU factorization with standard threshold -! dropping: at ith step of elimination, an element a(i,j) in row i is dropped -! if it satisfies the criterion: -! -! - abs(a(i,j)) < tol, that is, average magnitude of elements in row i of A -! - There is no control on memory size required for the factors as is done in -! ILUT. -! - This routines computes also various diagonal compensation ILU's such -! MILU. These are defined through the parameter `alph` -! -! - alph = diagonal compensation parameter, alph*(sum of all dropped out -! elements in a given row) is added to the diagonal element of U of the -! factorization -! - alph = 0 means the scheme is ILU with threshold, -! - alph = 1 means the scheme is MILU with threshold. -! - droptol = Threshold parameter for dropping small terms in the -! factorization. During the elimination, a term a(i,j) is dropped whenever abs -! (a(i,j)) .lt. tol * [weighted norm of row i]. Here weighted norm = 1-norm / -! number of nnz elements in the row. -! - `obj` matrix stored in Compressed Sparse Row format. -! -! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing -! the L and U factors together. The diagonal (stored in ALU(1:n) ) is -! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L -! (excluding the diagonal entry=1) followed by the ith row of U. -! - JU = integer array of length n containing the pointers to the beginning -! of each row of U in the matrix ALU,JLU. -! -! - Theresholding in L and U as set by `droptol`. Any element whose -! MAGNITUDE is less than some tolerance (relative to the abs value of -! diagonal element in U) is dropped. - -INTERFACE - MODULE SUBROUTINE csrMat_getILUD1(obj, ALU, JLU, JU, alpha, droptol) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: droptol - END SUBROUTINE csrMat_getILUD1 -END INTERFACE - -INTERFACE getILUD - MODULE PROCEDURE csrMat_getILUD1 -END INTERFACE getILUD - -!---------------------------------------------------------------------------- -! ILUD@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUT precondition -! -!# Introduction -! -! This routine computes the ILU factorization with standard threshold -! dropping: at ith step of elimination, an element a(i,j) in row i is dropped -! if it satisfies the criterion: -! -! This routine is similar to csrMat_getILUD1, but in this case the -! matrix PMat is in CSRMatrix_ format, and it contains the ILU factorization -! - -INTERFACE - MODULE SUBROUTINE csrMat_getILUD2(obj, Pmat, alpha, droptol) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: droptol - END SUBROUTINE csrMat_getILUD2 -END INTERFACE - -INTERFACE getILUD - MODULE PROCEDURE csrMat_getILUD2 -END INTERFACE getILUD - -!---------------------------------------------------------------------------- -! getILUDP@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUDP precondition -! -! # Introduction -! -! This routine computes ILUDP preconditioner, incomplete LU factorization -! with standard droppoing strategy. -! -! - `droptol` = tolerance used for dropping elements in L and U. elements are -! dropped if they are .lt. norm(row) x droptol row = row being eliminated -! - `permtol` = tolerance ratio used for determning whether to permute two -! columns. Two columns are permuted only when abs(a(i,j))*permtol .gt. abs(a -! (i,i)) [0 --> never permute; good values 0.1 to 0.01] -! - `mbloc` = if desired, permuting can be done only within the diagonal -! blocks of size mbloc. Useful for PDE problems with several degrees of -! freedom.. If feature not wanted take mbloc=n. -! -! - iperm = contains the permutation arrays, iperm(1:n) = old numbers of -! unknowns, iperm(n+1:2*n) = reverse permutation = new unknowns. -! -! - abs(a(i,j)) < droptol, that is, average magnitude of elements in row i -! of A -! - alph = diagonal compensation parameter, alph*(sum of all dropped out -! elements in a given row) is added to the diagonal element of U of the -! factorization -! - alph = 0 means the scheme is ILU with threshold, -! - alph = 1 means the scheme is MILU with threshold. -! - droptol = Threshold parameter for dropping small terms in the -! factorization. During the elimination, a term a(i,j) is dropped whenever abs -! (a(i,j)) .lt. droptol * [weighted norm of row i]. Here weighted norm = -! 1-norm / number of nnz elements in the row. -! - `obj` matrix stored in Compressed Sparse Row format. -! -! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing -! the L and U factors together. The diagonal (stored in ALU(1:n) ) is -! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L -! (excluding the diagonal entry=1) followed by the ith row of U. -! - JU = integer array of length n containing the pointers to the beginning -! of each row of U in the matrix ALU,JLU. -! -! - Theresholding in L and U as set by `droptol`. Any element whose -! MAGNITUDE is less than some tolerance (relative to the abs value of -! diagonal element in U) is dropped. - -INTERFACE - MODULE SUBROUTINE csrMat_getILUDP1(obj, ALU, JLU, JU, alpha, droptol, & - & permtol, mbloc, IPERM) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: droptol - REAL(DFP), INTENT(IN) :: permtol - INTEGER(I4B), INTENT(IN) :: mbloc - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) - END SUBROUTINE csrMat_getILUDP1 -END INTERFACE - -INTERFACE getILUDP - MODULE PROCEDURE csrMat_getILUDP1 -END INTERFACE getILUDP - -!---------------------------------------------------------------------------- -! getILUTDP@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUDP precondition -! -!# Introduction -! -! This routine computes ILUDP preconditioner, incomplete LU factorization -! with standard droppoing strategy. -! -! This routine is like csrMat_getILUDP1, but in this case we ILU -! matrix is returned as an instance of `CSRMatrix_`. - -INTERFACE - MODULE SUBROUTINE csrMat_getILUDP2(obj, Pmat, alpha, droptol, & - & permtol, mbloc, IPERM) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: droptol - REAL(DFP), INTENT(IN) :: permtol - INTEGER(I4B), INTENT(IN) :: mbloc - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) - END SUBROUTINE csrMat_getILUDP2 -END INTERFACE - -INTERFACE getILUDP - MODULE PROCEDURE csrMat_getILUDP2 -END INTERFACE getILUDP - -!---------------------------------------------------------------------------- -! getILUK@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUK precondition -! -!# Introduction -! -! This routine returns the ILU WITH LEVEL OF FILL-IN OF K (ILU(k)) -! -! - `lfil` = integer. The fill-in parameter. Each element whose leve-of-fill -! exceeds lfil during the ILU process is dropped. lfil must be .ge. 0 -! - droptol = real*8. Sets the threshold for dropping small terms in the -! factorization. See below for details on dropping strategy. -! - `ALU,JLU` = matrix stored in Modified Sparse Row (MSR) format containing -! the L and U factors together. The diagonal (stored in alu(1:n) ) is -! inverted. Each i-th row of the `ALU,JLU` matrix contains the i-th row of L -! (excluding the diagonal entry=1) followed by the i-th row of `U`. -! - `JU` = integer array of length n containing the pointers to the beginning -! of each row of `U` in the matrix `ALU,JLU`. -! - `LEVS` = integer (work) array of size `IWK`, which contains the levels of -! each element in `ALU, JLU`. -! -! @note -! This is not implemented efficiently storage-wise. For example: Only the -! part of the array levs(*) associated with the U-matrix is needed in the -! routine.. So some storage can be saved if needed. The levels of fills in -! the LU matrix are output for information only -- they are not needed by -! LU-solve. -! @endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getILUK1(obj, ALU, JLU, JU, lfil, LEVS) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) - INTEGER(I4B), INTENT(IN) :: lfil - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: LEVS(:) - END SUBROUTINE csrMat_getILUK1 -END INTERFACE - -INTERFACE getILUK - MODULE PROCEDURE csrMat_getILUK1 -END INTERFACE getILUK - -!---------------------------------------------------------------------------- -! getILUK@ILUTMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 July 2021 -! summary: Returns the ILUK precondition -! -!# Introduction -! -! This routine returns the ILU WITH LEVEL OF FILL-IN OF K (ILU(k)) -! -! - `lfil` = integer. The fill-in parameter. Each element whose leve-of-fill -! exceeds lfil during the ILU process is dropped. lfil must be .ge. 0 -! - droptol = real*8. Sets the threshold for dropping small terms in the -! factorization. See below for details on dropping strategy. -! - `ALU,JLU` = matrix stored in Modified Sparse Row (MSR) format containing -! the L and U factors together. The diagonal (stored in alu(1:n) ) is -! inverted. Each i-th row of the `ALU,JLU` matrix contains the i-th row of L -! (excluding the diagonal entry=1) followed by the i-th row of `U`. -! - `JU` = integer array of length n containing the pointers to the beginning -! of each row of `U` in the matrix `ALU,JLU`. -! - `LEVS` = integer (work) array of size `IWK`, which contains the levels of -! each element in `ALU, JLU`. -! -! @note -! This is not implemented efficiently storage-wise. For example: Only the -! part of the array levs(*) associated with the U-matrix is needed in the -! routine.. So some storage can be saved if needed. The levels of fills in -! the LU matrix are output for information only -- they are not needed by -! LU-solve. -! @endnote - -INTERFACE - MODULE SUBROUTINE csrMat_getILUK2(obj, Pmat, lfil, LEVS) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat - INTEGER(I4B), INTENT(IN) :: lfil - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: LEVS(:) - END SUBROUTINE csrMat_getILUK2 -END INTERFACE - -INTERFACE getILUK - MODULE PROCEDURE csrMat_getILUK2 -END INTERFACE getILUK - -END MODULE CSRMatrix_ILUMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 deleted file mode 100644 index e6fb1030d..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 +++ /dev/null @@ -1,110 +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 CSRMatrix_IOMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: Display -PUBLIC :: SPY -PUBLIC :: IMPORT - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine display the content of sparse matrix -! -!# Introduction -! -! This subroutine display the content of sparse matrix -! - In this subroutine `dump` routine from sparsekit lib is called - -INTERFACE Display - MODULE SUBROUTINE obj_Display(obj, Msg, UnitNo) - TYPE(CSRMatrix_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: Msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - END SUBROUTINE obj_Display -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Spy@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Prints the structure of sparse matrix in pdf/svg/png format. - -INTERFACE SPY - MODULE SUBROUTINE obj_SPY(obj, filename, ext) - TYPE(CSRMatrix_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: filename - CHARACTER(*), INTENT(IN) :: ext - END SUBROUTINE obj_SPY -END INTERFACE SPY - -!---------------------------------------------------------------------------- -! IMPORT@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Jul 2021 -! summary: Import sparse matrix from a file -! -!# Introduction -! -! this routine will open the file and read the data and close the file -! Currently only matFormat="SPARSE_FMT_COO" is supported. -! - -INTERFACE IMPORT - MODULE SUBROUTINE obj_Import(obj, fileName, matFormat) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - CHARACTER(*), INTENT(IN) :: fileName - !! File from which data should be read. This file will - !! be opened by the this routine on entry. This file - !! will be closed on return. - INTEGER(I4B), INTENT(IN) :: matFormat - !! Currently only `SPARSE_FMT_COO` is supported - END SUBROUTINE obj_Import -END INTERFACE IMPORT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-19 -! summary: Deprecated version of obj_Import - -INTERFACE - MODULE SUBROUTINE deprecated_obj_Import(obj, fileName, matFormat) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - CHARACTER(*), INTENT(IN) :: fileName - !! File from which data should be read. This file will - !! be opened by the this routine on entry. This file - !! will be closed on return. - INTEGER(I4B), INTENT(IN) :: matFormat - !! Currently only `SPARSE_FMT_COO` is supported - END SUBROUTINE deprecated_obj_Import -END INTERFACE - -END MODULE CSRMatrix_IOMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 deleted file mode 100644 index d60de237f..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 +++ /dev/null @@ -1,140 +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 CSRMatrix_LUSolveMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: LUSOLVE -PUBLIC :: LUTSOLVE - -!---------------------------------------------------------------------------- -! LUSOLVE@LUsolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jul 2021 -! summary: This routine solves the LU x = y -! -! This routine solves the system `LU x = y`, given an LU decomposition of a -! matrix stored in (`ALU, JLU, JU`) modified sparse row format (MSR). -! This ALU, JLU, JU are created by calling ILUT methods described above - -INTERFACE - MODULE SUBROUTINE csrMat_LUSOLVE(sol, rhs, alu, jlu, ju, isTranspose) - REAL(DFP), INTENT(INOUT) :: sol(:) - REAL(DFP), INTENT(IN) :: rhs(:) - REAL(DFP), INTENT(IN) :: alu(:) - INTEGER(I4B), INTENT(IN) :: jlu(:) - INTEGER(I4B), INTENT(IN) :: ju(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! if transpose is present, and it is true then - !! LUTSolve is called. - !! default is isTranspose = .FALSE. - END SUBROUTINE csrMat_LUSOLVE -END INTERFACE - -INTERFACE LUSOLVE - MODULE PROCEDURE csrMat_LUSOLVE -END INTERFACE LUSOLVE - -!---------------------------------------------------------------------------- -! LUTSOLVE@ILUT -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jul 2021 -! summary: This routine solves the (LU)^T x = y -! -! This routine solves the system `(LU)^T x = y`, given an LU decomposition of -! a matrix stored in (`ALU, JLU, JU`) modified sparse row format (MSR). -! This ALU, JLU, JU are created by calling ILUT methods described above - -INTERFACE - MODULE SUBROUTINE csrMat_LUTSOLVE(sol, rhs, alu, jlu, ju) - REAL(DFP), INTENT(INOUT) :: sol(:) - REAL(DFP), INTENT(IN) :: rhs(:) - REAL(DFP), INTENT(IN) :: alu(:) - INTEGER(I4B), INTENT(IN) :: jlu(:) - INTEGER(I4B), INTENT(IN) :: ju(:) - END SUBROUTINE csrMat_LUTSOLVE -END INTERFACE - -INTERFACE LUTSOLVE - MODULE PROCEDURE csrMat_LUTSOLVE -END INTERFACE LUTSOLVE - -! !---------------------------------------------------------------------------- -! ! LSolve@LinAlg -! !---------------------------------------------------------------------------- - -! !> author: Vikas Sharma, Ph. D. -! ! date: 14 July 2021 -! ! summary: Solve Lx = y by forward elimination technique will be used -! ! -! !# Introduction -! ! This subroutine Solve Lx = y by forward elimination technique will be used -! ! Here L is lower triangular matrix with unit diag in CSR format -! -! INTERFACE -! MODULE SUBROUTINE csrMat_LSolve( obj, x, y ) -! TYPE( CSRMatrix_ ), INTENT( IN ) :: obj -! !! Sparse matrix -! REAL( DFP ), INTENT( IN ) :: y( : ) -! !! This contains RHS -! REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: x( : ) -! !! This contains solution -! END SUBROUTINE csrMat_LSolve -! END INTERFACE -! -! INTERFACE LSolve -! MODULE PROCEDURE csrMat_LSolve -! END INTERFACE LSolve -! -! PUBLIC :: LSolve - -!---------------------------------------------------------------------------- -! ! USolve@LinAlg -! !---------------------------------------------------------------------------- - -! !> author: Vikas Sharma, Ph. D. -! ! date: 14 July 2021 -! ! summary: Solve Ux = y by backward elimination technique will be used -! ! -! !# Introduction -! !- This subroutine solve Ux = y by backward elimination technique will be -! ! used -! ! - Here U is upper triangular matrix with unit diag in CSR format - -! INTERFACE -! MODULE SUBROUTINE csrMat_USolve( obj, x, y ) -! TYPE( CSRMatrix_ ), INTENT( IN ) :: obj -! !! Sparse matrix in upper triangle form -! REAL( DFP ), INTENT( IN ) :: y( : ) -! !! RHS -! REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: x( : ) -! !! Solution -! END SUBROUTINE csrMat_USolve -! END INTERFACE - -! INTERFACE USolve -! MODULE PROCEDURE csrMat_USolve -! END INTERFACE USolve - -! PUBLIC :: USolve -END MODULE CSRMatrix_LUSolveMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 deleted file mode 100644 index 9162e96f7..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 +++ /dev/null @@ -1,162 +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 CSRMatrix_LinSolveMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: CSRMatrixLinSolveInitiate -PUBLIC :: CSRMatrix_GMRES -PUBLIC :: CSRMatrix_CG -PUBLIC :: CSRMatrix_BiCGStab - -INTEGER(I4B), PARAMETER :: IPAR_LENGTH = 14 -INTEGER(I4B), PARAMETER :: FPAR_LENGTH = 14 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-03-14 -! summary: Return integer code of linear solver from character name - -INTERFACE - MODULE PURE FUNCTION GetLinSolverCodeFromName(name) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: name - INTEGER(I4B) :: ans - END FUNCTION GetLinSolverCodeFromName -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-03-14 -! summary: Return character name of linear solver from integer code - -INTERFACE - MODULE PURE FUNCTION GetLinSolverNameFromCode(name) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: name - CHARACTER(15) :: ans - END FUNCTION GetLinSolverNameFromCode -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE CSRMatrixLinSolveInitiate - MODULE SUBROUTINE CSRMatrix_LinSolve_Initiate(ipar, fpar, W, n, & - & solverName, preConditionOption, convergenceIn, convergenceType, & - & maxIter, KrylovSubspaceSize, rtol, atol, relativeToRHS) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: ipar(:) - !! Integer PARAMETER - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: fpar(:) - !! Read PARAMETER - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: W(:) - !! Workspace requirement - INTEGER(I4B), INTENT(IN) :: n - !! size of the problem - INTEGER(I4B), OPTIONAL, INTENT(in) :: solverName - !! solverName - INTEGER(I4B), OPTIONAL, INTENT(in) :: preconditionOption - !! preconditionOption - !! NO_PRECONDITION - !! LEFT_PRECONDITION - !! RIGHT_PRECONDITON - !! LEFT_RIGHT_PRECONDITION - INTEGER(I4B), OPTIONAL, INTENT(in) :: convergenceIn - !! convergenceInRes - !! convergenceInSol - INTEGER(I4B), OPTIONAL, INTENT(in) :: convergenceType - !! absoluteConvergence - !! relativeConvergence - INTEGER(I4B), OPTIONAL, INTENT(in) :: maxIter - !! maximum number of iterations - INTEGER(I4B), OPTIONAL, INTENT(in) :: KrylovSubspaceSize - !! Size of KrylovSubspace - REAL(DFP), OPTIONAL, INTENT(in) :: rtol - !! relative tolerance - REAL(DFP), OPTIONAL, INTENT(in) :: atol - !! absolute tolerance - LOGICAL(LGT), OPTIONAL, INTENT(in) :: relativeToRHS - !! true if convergence is checked relatative to RHS - END SUBROUTINE CSRMatrix_LinSolve_Initiate -END INTERFACE CSRMatrixLinSolveInitiate - -!---------------------------------------------------------------------------- -! LinSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-03-14 -! summary: Solver - -INTERFACE - MODULE SUBROUTINE CSRMatrix_GMRES(obj, sol, rhs, ipar, fpar, W) - CLASS(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(INOUT) :: sol(:) - REAL(DFP), INTENT(INOUT) :: rhs(:) - INTEGER(I4B), INTENT(INOUT) :: ipar(:) - REAL(DFP), INTENT(INOUT) :: fpar(:) - REAL(DFP), INTENT(INOUT) :: W(:) - END SUBROUTINE CSRMatrix_GMRES -END INTERFACE - -!---------------------------------------------------------------------------- -! LinSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-03-14 -! summary: Solver - -INTERFACE - MODULE SUBROUTINE CSRMatrix_CG(obj, sol, rhs, ipar, fpar, W) - CLASS(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(INOUT) :: sol(:) - REAL(DFP), INTENT(INOUT) :: rhs(:) - INTEGER(I4B), INTENT(INOUT) :: ipar(:) - REAL(DFP), INTENT(INOUT) :: fpar(:) - REAL(DFP), INTENT(INOUT) :: W(:) - END SUBROUTINE CSRMatrix_CG -END INTERFACE - -!---------------------------------------------------------------------------- -! LinSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-03-14 -! summary: Solver - -INTERFACE - MODULE SUBROUTINE CSRMatrix_BiCGStab(obj, sol, rhs, ipar, fpar, W) - CLASS(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(INOUT) :: sol(:) - REAL(DFP), INTENT(INOUT) :: rhs(:) - INTEGER(I4B), INTENT(INOUT) :: ipar(:) - REAL(DFP), INTENT(INOUT) :: fpar(:) - REAL(DFP), INTENT(INOUT) :: W(:) - END SUBROUTINE CSRMatrix_BiCGStab -END INTERFACE - -END MODULE CSRMatrix_LinSolveMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 deleted file mode 100644 index 674e73388..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 +++ /dev/null @@ -1,257 +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 CSRMatrix_MatVecMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: MatVec -PUBLIC :: AMatVec -PUBLIC :: AtMatvec -PUBLIC :: CSRMatrixAMUX -PUBLIC :: CSRMatrixAMUX_Add -PUBLIC :: CSRMatrixATMUX -PUBLIC :: CSRMatrixATMUX_Add - -!---------------------------------------------------------------------------- -! CSRMatrixAMUX -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: Mat vec - -! y = A *x -INTERFACE CSRMatrixAMUX - MODULE SUBROUTINE CSRMatrixAMUX1(n, x, y, a, ja, ia) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - END SUBROUTINE CSRMatrixAMUX1 -END INTERFACE CSRMatrixAMUX - -!---------------------------------------------------------------------------- -! CSRMatrixAMUX -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: y = s * A*x - -INTERFACE CSRMatrixAMUX - MODULE SUBROUTINE CSRMatrixAMUX2(n, x, y, a, ja, ia, s) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - REAL(DFP), INTENT(IN) :: s - END SUBROUTINE CSRMatrixAMUX2 -END INTERFACE CSRMatrixAMUX - -!---------------------------------------------------------------------------- -! CSRMatrixAMUX_Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: y = y+s * A*x - -INTERFACE CSRMatrixAMUX_Add - MODULE SUBROUTINE CSRMatrixAMUX_Add_1(n, x, y, a, ja, ia, s) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - REAL(DFP), INTENT(IN) :: s - END SUBROUTINE CSRMatrixAMUX_Add_1 -END INTERFACE CSRMatrixAMUX_Add - -!---------------------------------------------------------------------------- -! CSRMatrixATMUX -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: y = A^T *x - -INTERFACE CSRMatrixATMUX - MODULE SUBROUTINE CSRMatrixATMUX1(n, x, y, a, ja, ia) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - END SUBROUTINE CSRMatrixATMUX1 -END INTERFACE CSRMatrixATMUX - -!---------------------------------------------------------------------------- -! CSRMatrixATMUX -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: y = s * A^T*x - -INTERFACE CSRMatrixATMUX - MODULE SUBROUTINE CSRMatrixATMUX2(n, x, y, a, ja, ia, s) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - REAL(DFP), INTENT(IN) :: s - END SUBROUTINE CSRMatrixATMUX2 -END INTERFACE CSRMatrixATMUX - -!---------------------------------------------------------------------------- -! CSRMatrixATMUX_Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: y = y+s * A^T*x - -INTERFACE CSRMatrixATMUX_Add - MODULE SUBROUTINE CSRMatrixATMUX_Add_1(n, x, y, a, ja, ia, s) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - REAL(DFP), INTENT(IN) :: a(:) - INTEGER(I4B), INTENT(IN) :: ja(:) - INTEGER(I4B), INTENT(IN) :: ia(:) - REAL(DFP), INTENT(IN) :: s - END SUBROUTINE CSRMatrixATMUX_Add_1 -END INTERFACE CSRMatrixATMUX_Add - -!---------------------------------------------------------------------------- -! AMatVec1@MatvecMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 july 2021 -! summary: This routine computes y = A*x - -INTERFACE AMatVec - MODULE SUBROUTINE csrMat_AMatVec1(obj, x, y, addContribution, scale) - TYPE(CSRMatrix_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - END SUBROUTINE csrMat_AMatVec1 -END INTERFACE AMatVec - -!---------------------------------------------------------------------------- -! AMatVec2@MatvecMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 july 2021 -! summary: This routine computes y = A*x, A is in MSR format - -INTERFACE AMatVec - MODULE SUBROUTINE csrMat_AMatVec2(A, JA, x, y, addContribution, scale) - REAL(DFP), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: JA(:) - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - END SUBROUTINE csrMat_AMatVec2 -END INTERFACE AMatvec - -!---------------------------------------------------------------------------- -! AtMatvec@MatvecMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 july 2021 -! summary: This routine computes y = A*x - -INTERFACE AtMatvec - MODULE SUBROUTINE csrMat_AtMatvec(obj, x, y, addContribution, scale) - TYPE(CSRMatrix_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - END SUBROUTINE csrMat_AtMatvec -END INTERFACE AtMatvec - -!---------------------------------------------------------------------------- -! Matvec@MatVec -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This routine performs matrix-vector multiplication -! -!# Introduction -! y = A*x - -INTERFACE MatVec - MODULE SUBROUTINE csrMat_MatVec1(obj, x, y, isTranspose, addContribution, & - & scale) - TYPE(CSRMatrix_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - END SUBROUTINE csrMat_MatVec1 -END INTERFACE MatVec - -!---------------------------------------------------------------------------- -! Matvec@MatVec -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This routine performs matrix-vector multiplication -! -!# Introduction -! -! y = A*x - -INTERFACE MatVec - MODULE SUBROUTINE csrMat_MatVec2(A, JA, x, y, addContribution, & - & scale) - REAL(DFP), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: JA(:) - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - END SUBROUTINE csrMat_MatVec2 -END INTERFACE MatVec - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE CSRMatrix_MatVecMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 b/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 deleted file mode 100644 index 56ef274ed..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 +++ /dev/null @@ -1,97 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE CSRMatrix_MatrixMarketIO -USE GlobalData, ONLY: DFPC, I4B, DFP, LGT, stdout, stderr, stdin -IMPLICIT NONE -PRIVATE - -INTERFACE - MODULE SUBROUTINE ParseHeader(aline, h1, h2, h3, h4, h5, ierr, errmsg) - CHARACTER(*), INTENT(IN) :: aline - CHARACTER(*), INTENT(OUT) :: h1 - CHARACTER(*), INTENT(OUT) :: h2 - CHARACTER(*), INTENT(OUT) :: h3 - CHARACTER(*), INTENT(OUT) :: h4 - CHARACTER(*), INTENT(OUT) :: h5 - INTEGER(I4B), INTENT(OUT) :: ierr - CHARACTER(*), INTENT(OUT) :: errmsg - END SUBROUTINE ParseHeader -END INTERFACE - -!---------------------------------------------------------------------------- -! MMRead -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-19 -! summary: Read sparse matrix from matrix market format. -! -!# Introduction -! -! This routine reads the sparse matrix from matrix market format. -! -! The matrix market format is described here: -! https://math.nist.gov/MatrixMarket/formats.html -! -! - Matrix should contains real values -! - The forth argumnet of header should be real - -INTERFACE - MODULE SUBROUTINE MMRead(unitno, rep, field, symm, rows, cols, nnz, & - & indx, jndx, rval, ival, cval) - INTEGER(I4B), INTENT(IN) :: unitno - !! unit number of file - CHARACTER(*), INTENT(OUT) :: rep - !! coordinate <-- sparse array in COO format - !! array <-- dense array - CHARACTER(*), INTENT(OUT) :: field - !! real - !! integer - !! pattern - !! complex - CHARACTER(*), INTENT(OUT) :: symm - !! symmetric <-- if the matrix is symmetric - !! skew-symmetric <-- if the matrix is skew-symmetric - !! general <-- if the matrix is general - !! hermitian <-- if the matrix is complex and symmetric - INTEGER(I4B), INTENT(OUT) :: rows - !! number of rows in matrix - INTEGER(I4B), INTENT(OUT) :: cols - !! number of columns in matrix - INTEGER(I4B), INTENT(OUT) :: nnz - !! number of nonzero elements - INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: indx(:) - !! row number (index) - INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: jndx(:) - !! col number (index) - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: rval(:) - !! real value needed when field is `real` - INTEGER(I4B), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: ival(:) - !! integer value needed when field is `integer` - COMPLEX(DFPC), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: cval(:) - !! complex value needed when field is `complex` - END SUBROUTINE MMRead -END INTERFACE - -PUBLIC :: MMRead - -!---------------------------------------------------------------------------- -! MMRead -!---------------------------------------------------------------------------- - -END MODULE CSRMatrix_MatrixMarketIO diff --git a/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 b/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 deleted file mode 100644 index 41cf2828c..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 +++ /dev/null @@ -1,50 +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 CSRMatrix_Method -USE CSRMatrix_ConstructorMethods -USE CSRMatrix_IOMethods -USE CSRMatrix_SparsityMethods -USE CSRMatrix_SetMethods -USE CSRMatrix_AddMethods -USE CSRMatrix_SetRowMethods -USE CSRMatrix_SetColMethods -USE CSRMatrix_SetBlockRowMethods -USE CSRMatrix_SetBlockColMethods -USE CSRMatrix_GetMethods -USE CSRMatrix_GetRowMethods -USE CSRMatrix_GetColMethods -USE CSRMatrix_GetSubMatrixMethods -USE CSRMatrix_GetBlockRowMethods -USE CSRMatrix_GetBlockColMethods -USE CSRMatrix_UnaryMethods -USE CSRMatrix_ILUMethods -USE CSRMatrix_LUSolveMethods -USE CSRMatrix_MatVecMethods -USE CSRMatrix_SymMatmulMethods -USE CSRMatrix_ReorderingMethods -USE CSRMatrix_DiagonalScalingMethods -USE CSRMatrix_MatrixMarketIO -USE CSRMatrix_Superlu -USE CSRMatrix_SpectralMethods -USE CSRMatrix_SchurMethods -USE CSRMatrix_DBCMethods -USE CSRMatrix_LinSolveMethods -USE GlobalData, ONLY: I4B -INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_CSR = 0 -INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_COO = 1 -END MODULE CSRMatrix_Method diff --git a/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 deleted file mode 100644 index 6c766ed73..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 +++ /dev/null @@ -1,81 +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 CSRMatrix_ReorderingMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_, SparseMatrixReOrdering_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: NestedDissect - -!---------------------------------------------------------------------------- -! NestedDissect@ReoderingMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2021 -! summary: Nested dissection using Metis library - -INTERFACE - MODULE SUBROUTINE csrMat_NestedDissect(reorder, csrMat) - TYPE(SparseMatrixReOrdering_), INTENT(INOUT) :: reorder - TYPE(CSRMatrix_), INTENT(IN) :: csrMat - END SUBROUTINE csrMat_NestedDissect -END INTERFACE - -INTERFACE NestedDissect - MODULE PROCEDURE csrMat_NestedDissect -END INTERFACE NestedDissect - -!---------------------------------------------------------------------------- -! Display@ReorderingMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2021 -! summary: Display the content of SparseMatrixReordering - -INTERFACE - MODULE SUBROUTINE csrMat_reorderDisplay(obj, msg, unitNo) - TYPE(SparseMatrixReOrdering_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitNo - END SUBROUTINE csrMat_reorderDisplay -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE csrMat_reorderDisplay -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Permute@ReorderingMethod -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION csrMat_Permute2(obj, rowPERM, colPERM) RESULT(Ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - TYPE(SparseMatrixReOrdering_), INTENT(IN) :: rowPERM - TYPE(SparseMatrixReOrdering_), INTENT(IN) :: colPERM - TYPE(CSRMatrix_) :: ans - END FUNCTION csrMat_Permute2 -END INTERFACE - -INTERFACE Permute - MODULE PROCEDURE csrMat_Permute2 -END INTERFACE Permute -END MODULE CSRMatrix_ReorderingMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 deleted file mode 100644 index c00e3af73..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 +++ /dev/null @@ -1,187 +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 CSRMatrix_SchurMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: SchurMatVec -PUBLIC :: SymSchurLargestEigenval - -!---------------------------------------------------------------------------- -! AMatVec1@MatvecMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-30 -! summary: This routine computes y = (Transpose(B) * Inv(A) * B) -! -!# Introduction -! -!$$ -!y = S \cdot x -!$$ -! -!where, -! -!$$ -! {\bf S}=\left({\bf B}^{T}{\bf A}^{-1}{\bf B}\right), -!$$ - -INTERFACE - MODULE SUBROUTINE csrMat_AMatVec(A, B, x, y) - TYPE(CSRMatrix_), INTENT(INOUT) :: A - TYPE(CSRMatrix_), INTENT(INOUT) :: B - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - END SUBROUTINE csrMat_AMatVec -END INTERFACE - -!---------------------------------------------------------------------------- -! AtMatvec@MatvecMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-30 -! summary: This routine computes y = (Transpose(B) * Inv(A) * B) -! -!# Introduction -! -!$$ -!y = S^{T} \cdot x -!$$ -! -!where, -! -!$$ -! {\bf S}=\left({\bf B}^{T}{\bf A}^{-1}{\bf B}\right), -!$$ - -INTERFACE - MODULE SUBROUTINE csrMat_AtMatVec(A, B, x, y, isASym) - TYPE(CSRMatrix_), INTENT(INOUT) :: A - TYPE(CSRMatrix_), INTENT(INOUT) :: B - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isASym - !! True if A is symmetric - !! False if A is not symmetric - !! Default is False - END SUBROUTINE csrMat_AtMatVec -END INTERFACE - -!---------------------------------------------------------------------------- -! Matvec@MatVec -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-30 -! summary: This routine computes y = (Transpose(B) * Inv(A) * B) -! - -INTERFACE - MODULE SUBROUTINE csrMat_SchurMatVec(A, B, x, y, isTranspose, isASym) - TYPE(CSRMatrix_), INTENT(INOUT) :: A - TYPE(CSRMatrix_), INTENT(INOUT) :: B - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: y(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isASym - END SUBROUTINE csrMat_SchurMatVec -END INTERFACE - -INTERFACE SchurMatVec - MODULE PROCEDURE csrMat_SchurMatVec -END INTERFACE SchurMatVec - -!---------------------------------------------------------------------------- -! SymSchurLargestEigenval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: -! - -INTERFACE - MODULE FUNCTION SymSchurLargestEigenVal1(A, B, which, NCV, maxIter, tol) & - & RESULT(ans) - TYPE(CSRMatrix_), INTENT(INOUT) :: A - !! Symmetric matrix - TYPE(CSRMatrix_), INTENT(INOUT) :: B - !! B matrix, it can be rectangle - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "LM"` ⇨ absolute largest eigenvalue - !! `which = "LA"` ⇨ algebraic largest eigenvalue - !! default is "LA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, 20)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans - !! maximum eigenvalue - END FUNCTION SymSchurLargestEigenVal1 -END INTERFACE - -INTERFACE SymSchurLargestEigenVal - MODULE PROCEDURE SymSchurLargestEigenVal1 -END INTERFACE SymSchurLargestEigenVal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-30 -! summary: - -INTERFACE - MODULE FUNCTION SymSchurLargestEigenVal2(A, B, nev, which, NCV, & - & maxIter, tol) RESULT(ans) - TYPE(CSRMatrix_), INTENT(INOUT) :: A - !! CSRMatrix, symmetric - TYPE(CSRMatrix_), INTENT(INOUT) :: B - !! B matrix, possibly rectangle - INTEGER(I4B), INTENT(IN) :: nev - !! number of eigenvalues requested - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "LM"` ⇨ absolute largest eigenvalue - !! `which = "LA"` ⇨ algebraic largest eigenvalue - !! default is "LA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, MAX(2*nev+1, 20))` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans(nev) - !! first k, largest eigenvalue - END FUNCTION SymSchurLargestEigenVal2 -END INTERFACE - -INTERFACE SymSchurLargestEigenVal - MODULE PROCEDURE SymSchurLargestEigenVal2 -END INTERFACE SymSchurLargestEigenVal - -END MODULE CSRMatrix_SchurMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 deleted file mode 100644 index a70ec5eb7..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 +++ /dev/null @@ -1,166 +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 CSRMatrix_SetBlockColMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: SetBlockColumn - -!---------------------------------------------------------------------------- -! setBlockColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockColumn1(obj, ivar, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: icolumn - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setBlockColumn1 -END INTERFACE - -INTERFACE setBlockColumn - MODULE PROCEDURE csrMat_setBlockColumn1 -END INTERFACE setBlockColumn - -!---------------------------------------------------------------------------- -! setBlockColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockColumn2(obj, ivar, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: icolumn - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setBlockColumn2 -END INTERFACE - -INTERFACE setBlockColumn - MODULE PROCEDURE csrMat_setBlockColumn2 -END INTERFACE setBlockColumn - -!---------------------------------------------------------------------------- -! setBlockColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockColumn3(obj, ivar, jvar, nodenum, idof, & - & VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setBlockColumn3 -END INTERFACE - -INTERFACE setBlockColumn - MODULE PROCEDURE csrMat_setBlockColumn3 -END INTERFACE setBlockColumn - -!---------------------------------------------------------------------------- -! setBlockColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockColumn4(obj, ivar, jvar, nodenum, idof, & - & VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setBlockColumn4 -END INTERFACE - -INTERFACE setBlockColumn - MODULE PROCEDURE csrMat_setBlockColumn4 -END INTERFACE setBlockColumn - -!---------------------------------------------------------------------------- -! setBlockColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockColumn5(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setBlockColumn5 -END INTERFACE - -INTERFACE setBlockColumn - MODULE PROCEDURE csrMat_setBlockColumn5 -END INTERFACE setBlockColumn - -!---------------------------------------------------------------------------- -! setBlockColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockColumn6(obj, ivar, jvar, nodenum, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setBlockColumn6 -END INTERFACE - -INTERFACE setBlockColumn - MODULE PROCEDURE csrMat_setBlockColumn6 -END INTERFACE setBlockColumn - -END MODULE CSRMatrix_SetBlockColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 deleted file mode 100644 index b11792bd2..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 +++ /dev/null @@ -1,166 +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 CSRMatrix_SetBlockRowMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: SetBlockRow - -!---------------------------------------------------------------------------- -! setBlockRow@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockRow1(obj, jvar, irow, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: irow - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setBlockRow1 -END INTERFACE - -INTERFACE setBlockRow - MODULE PROCEDURE csrMat_setBlockRow1 -END INTERFACE setBlockRow - -!---------------------------------------------------------------------------- -! setBlockRow@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockRow2(obj, jvar, irow, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: irow - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setBlockRow2 -END INTERFACE - -INTERFACE setBlockRow - MODULE PROCEDURE csrMat_setBlockRow2 -END INTERFACE setBlockRow - -!---------------------------------------------------------------------------- -! setBlockRow@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockRow3(obj, ivar, jvar, nodenum, idof, & - & VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setBlockRow3 -END INTERFACE - -INTERFACE setBlockRow - MODULE PROCEDURE csrMat_setBlockRow3 -END INTERFACE setBlockRow - -!---------------------------------------------------------------------------- -! setBlockRow@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockRow4(obj, ivar, jvar, nodenum, idof, & - & VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setBlockRow4 -END INTERFACE - -INTERFACE setBlockRow - MODULE PROCEDURE csrMat_setBlockRow4 -END INTERFACE setBlockRow - -!---------------------------------------------------------------------------- -! setBlockRow@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockRow5(obj, ivar, jvar, nodenum, spacecompo,& - & timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setBlockRow5 -END INTERFACE - -INTERFACE setBlockRow - MODULE PROCEDURE csrMat_setBlockRow5 -END INTERFACE setBlockRow - -!---------------------------------------------------------------------------- -! setBlockRow@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE - MODULE SUBROUTINE csrMat_setBlockRow6(obj, ivar, jvar, nodenum, spacecompo,& - & timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setBlockRow6 -END INTERFACE - -INTERFACE setBlockRow - MODULE PROCEDURE csrMat_setBlockRow6 -END INTERFACE setBlockRow - -END MODULE CSRMatrix_SetBlockRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 deleted file mode 100644 index 4f250906a..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 +++ /dev/null @@ -1,485 +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 CSRMatrix_SetColMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn1(obj, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: icolumn - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn1 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn1b(obj, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: icolumn(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn1b -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn2(obj, nodenum, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn2 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn3(obj, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: icolumn - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn3 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn3b(obj, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: icolumn(:) - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn3b -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn4(obj, nodenum, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn4 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn5(obj, nodenum, ivar, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn5 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn6(obj, nodenum, ivar, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn6 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn7(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn7 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn8(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn8 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn9(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn9 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn10(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn10 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn11(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn11 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn12(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn12 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn13(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn13 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn14(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn14 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn15(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setColumn15 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! setColumn@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the Column of a sparse matrix -! -!# Introduction -! -! - This routine sets the Column of a sparse matrix. The Column index is -! calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - icolumn calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetColumn - MODULE SUBROUTINE csrMat_setColumn16(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setColumn16 -END INTERFACE SetColumn - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE CSRMatrix_SetColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 deleted file mode 100644 index 127461fde..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 +++ /dev/null @@ -1,580 +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 CSRMatrix_SetMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaSetype, ONLY: CSRMatrix_ -IMPLICIT NONE - -PRIVATE -PUBLIC :: Set -PUBLIC :: SetSingleValue -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: SetIA, SetJA - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: This subroutine sets the single value - -INTERFACE SetSingleValue - MODULE PURE SUBROUTINE obj_SetSingleValue(obj, indx, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: indx - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE obj_SetSingleValue -END INTERFACE SetSingleValue - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set the value in sparse matrix -! -!# Introduction -! -! - This subroutine Sets the value in [[CSRMatrix_]] -! - Shape( value ) = [SIZE(nodenum)*tdof, SIZE(nodenum)*tdof] -! - Usually `value` denotes the element matrix -! - Symbolic we are performing following task `obj(nodenum, nodenum)=value` - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set0(obj, nodenum, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:, :) - END SUBROUTINE obj_Set0 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set the value in sparse matrix -! -!# Introduction -! -! This subroutine Sets the values in sparse matrix. -! -!$$ -! obj(Nptrs,Nptrs)=value(:,:) -!$$ -! -! - Usually `value(:,:)` represents the element finite element matrix -! - The shape of `value` should be the tdof*size(nodenum), tdof*size(nodenum) -! - `tdof` is the total degree of freedom in obj%csr%dof -! -! - `StorageFMT` denotes the storage format of `value` -! It can be `Nodes_FMT` or `DOF_FMT` -! -! - Usually, element matrix is stored with `DOF_FMT` - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set1(obj, nodenum, VALUE, storageFMT) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:, :) - INTEGER(I4B), INTENT(IN) :: storageFMT - END SUBROUTINE obj_Set1 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets all values of sparse matrix to given scalar value -! -!# Introduction -! This routine Sets all values of sparse matrix to given value. -! This routine is used to define an assignment operator. Therefore, we can -! call this routine by `obj=value`. - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set2(obj, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE obj_Set2 -END INTERFACE Set - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE obj_Set2 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets a single entry of sparse matrix -! -!# Introduction -! -! - This subroutine Sets a single entry of sparse matrix. -! - Before using this routine the user should be aware of the storage -! pattern of degree of freedom. -! - However, if total number of degrees of freedom is one then there is not -! need to worry. -! -!@warning -! This routine should be avoided by general user. -!@endwarning - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set3(obj, irow, icolumn, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow - !! row index - INTEGER(I4B), INTENT(IN) :: icolumn - !! column index - REAL(DFP), INTENT(IN) :: VALUE - !! value - END SUBROUTINE obj_Set3 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets the specific row and column entry to a given value -! -!# Introduction -! -! - This routine Sets the specific row and column entry to a given value. -! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Set3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Set3]] -!@endnote -! -!@note -! rowdof, coldof are continuously numbered, so if there are two -! or more physical variables, then rowdof and coldof of the second -! or later physical variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set4(obj, iNodeNum, jNodeNum, iDOF, & - & jDOF, VALUE) - 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) :: iDOF - !! row degree of freedom - INTEGER(I4B), INTENT(IN) :: jDOF - !! col degree of freedom - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value to be Set - END SUBROUTINE obj_Set4 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Sets selected values in sparse matrix -! -!# Introduction -! -! This subroutine Sets selected values of the sparse matrix to the scalar -! value `value` -! -! This routine corresponds to `obj(nodenum) = value` - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set5(obj, nodenum, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE obj_Set5 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set the value in sparse matrix -! -!# Introduction -! -! - This subroutine Sets the values in block sparse matrix. -! - The storage pattern of both sparse matrix and value -! (the element matrix) should be in `FMT_DOF`. -! -!$$ -! obj(Nptrs,Nptrs)=value(:,:) -!$$ -! - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set6(obj, iNodeNum, jNodeNum, & - & ivar, jvar, VALUE) - 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(:, :) - END SUBROUTINE obj_Set6 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets the specific row and column entry to a given value -! -!# Introduction -! -! - This routine Sets the specific row and column entry to a given value. -! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Set3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Set3]] -!@endnote -! -!@note -! rowdof, coldof are continuously numbered, so if there are two -! or more physical variables, then rowdof and coldof of the second -! or later physical variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set7(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE) - 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 Set - END SUBROUTINE obj_Set7 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets the specific row and column entry to a given value - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set8(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE) - 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 Set - END SUBROUTINE obj_Set8 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets the specific row and column entry to a given value -! -!# Introduction -! -! - This routine Sets the specific row and column entry to a given value. -! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using -! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. -! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method -! - After computing the irow and icolumn (internally) this routine calls, -! `obj_Set3`. -! -!@note -! General user should prefer this routine over -! [[CSRMatrix_Method:obj_Set3]] -!@endnote -! -!@note -! rowdof, coldof are continuously numbered, so if there are two -! or more physical variables, then rowdof and coldof of the second -! or later physical variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set9(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) - 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 - !! col degree of freedom - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value to be Set - END SUBROUTINE obj_Set9 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set the value in sparse matrix -! -!# Introduction -! -! - This subroutine Sets the values in block sparse matrix. -! - The storage pattern of both sparse matrix and value -! (the element matrix) should be in `FMT_DOF`. -! -!$$ -! obj(Nptrs,Nptrs)=value(:,:) -!$$ -! - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set10(obj, iNodeNum, jNodeNum, & - & ivar, jvar, VALUE) - 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 - END SUBROUTINE obj_Set10 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets the specific row and column entry to a given value - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set11(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE) - 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 Set - END SUBROUTINE obj_Set11 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets the specific row and column entry to a given value - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set12(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) - 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 Set - END SUBROUTINE obj_Set12 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Sets the specific row and column entry to a given value - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set13(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) - 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 Set - END SUBROUTINE obj_Set13 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-25 -! summary: Sets the specific row and column entry to a given value - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set14(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) - 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 Set - END SUBROUTINE obj_Set14 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-17 -! summary: Scale the sparse matrix , obj = scale*Value - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set15(obj, VALUE, scale) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(IN) :: VALUE - REAL(DFP), OPTIONAL, INTENT(IN) :: scale - !! scale - END SUBROUTINE obj_Set15 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! SetIA@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Set entry in IA - -INTERFACE SetIA - MODULE PURE SUBROUTINE obj_SetIA(obj, irow, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B), INTENT(IN) :: VALUE - END SUBROUTINE obj_SetIA -END INTERFACE SetIA - -!---------------------------------------------------------------------------- -! SetJA@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Set entry in JA - -INTERFACE SetJA - MODULE PURE SUBROUTINE obj_SetJA(obj, indx, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(I4B), INTENT(IN) :: VALUE - END SUBROUTINE obj_SetJA -END INTERFACE SetJA - -END MODULE CSRMatrix_SetMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 deleted file mode 100644 index f8d4c1884..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 +++ /dev/null @@ -1,476 +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 CSRMatrix_SetRowMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the the row of a sparse matrix - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow1(obj, irow, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow1 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the the row of a sparse matrix - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow1b(obj, irow, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow1b -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is -! calculated using the nodenum and idof. -! - `nodenum` is the node number -! - `idof` is the degree of freedom number -! - `irow` calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow2(obj, nodenum, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow2 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the the row of a sparse matrix - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow3(obj, irow, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow3 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine sets the the row of a sparse matrix - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow3b(obj, irow, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow(:) - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow3b -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow4(obj, nodenum, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow4 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow5(obj, nodenum, ivar, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow5 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow6(obj, nodenum, ivar, idof, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow6 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow7(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow7 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow8(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow8 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow9(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow9 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow10(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow10 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow11(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow11 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow12(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow12 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow13(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow13 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow14(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow14 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow15(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE csrMat_setRow15 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! setRow@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine set the row of a sparse matrix -! -!# Introduction -! -! - This routine sets the row of a sparse matrix. The row index is calculated -! using the nodenum and idof. -! - nodenum is the node number -! - idof is the degree of freedom number -! - irow calculated from nodenum and idof depends upon the storageFMT. - -INTERFACE SetRow - MODULE SUBROUTINE csrMat_setRow16(obj, nodenum, ivar, & - & spacecompo, timecompo, VALUE) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE csrMat_setRow16 -END INTERFACE SetRow - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE CSRMatrix_SetRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 deleted file mode 100644 index 37a69a98d..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 +++ /dev/null @@ -1,153 +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 CSRMatrix_SparsityMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_, IntVector_ -IMPLICIT NONE -PRIVATE -PUBLIC :: SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@setMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine set the sparsity pattern of a given row -! -!# Introduction -! -! This subroutine sets the sparsity pattern of a given row -! - If `obj%tdof` is equal to 1, then `Col` is sorted in increasing order, -! and appended to `obj%Row(Row)` -! - If `obj%tdof` is not equal to 1, then based on the storage format and -! `Col` connectivity information is generated. - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_setSparsity1(obj, row, col) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: row - !! row number - INTEGER(I4B), INTENT(IN) :: col(:) - !! column indices (only node number is required) - END SUBROUTINE obj_setSparsity1 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine sets the sparsity pattern of a given row -! -!# Introduction -! -! This subroutine sets the sparsity pattern of many rows - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_setSparsity2(obj, row, col) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: row(:) - !! row indices - TYPE(IntVector_), INTENT(IN) :: col(:) - !! each intVector, col(i), contains col indices of row(i) - END SUBROUTINE obj_setSparsity2 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine set the sparsity pattern of a given row -! -!# Introduction -! -! This subroutine sets the sparsity pattern of a given row -! - If `obj%tdof` is equal to 1, then `Col` is sorted in increasing order, -! and appended to `obj%Row(Row)` -! - If `obj%tdof` is not equal to 1, then based on the storage format and -! `Col` connectivity information is generated. - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_setSparsity3(obj, row, col, ivar, jvar) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: row - !! row index - INTEGER(I4B), INTENT(IN) :: col(:) - !! col indices - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable i - INTEGER(I4B), INTENT(IN) :: jvar - !! physical variable j - END SUBROUTINE obj_setSparsity3 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine sets the sparsity pattern of a given row -! -!# Introduction -! -! This subroutine sets the sparsity pattern of a given row -! This subroutine calls `obj_setSparsity1` - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_setSparsity4(obj, row, col, ivar, jvar) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: row(:) - TYPE(IntVector_), INTENT(IN) :: col(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: jvar - END SUBROUTINE obj_setSparsity4 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine set sparsity pattern of `sparsematrix_` -! -!# Introduction -! -! authors: Dr. Vikas Sharma -! -! This subroutine set sparsity pattern of `sparsematrix_` -! This will finally set the data into -! -! - `obj%A(:)` -! - `obj%IA(:)` -! - `obj%JA(:)` -! in CSR format. This routine also set data inside `obj%ColSize(:)` and -! `obj%RowSize(:) `, and `obj%DiagIndx(:)` - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_setSparsity_final(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE obj_setSparsity_final -END INTERFACE SetSparsity - -END MODULE CSRMatrix_SparsityMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 deleted file mode 100644 index 0f54a94b5..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 +++ /dev/null @@ -1,209 +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 CSRMatrix_SpectralMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: SymLargestEigenval -PUBLIC :: SymSmallestEigenval - -!---------------------------------------------------------------------------- -! SymLargestEigenval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the largest eigenvalue of a real sym dense matrix -! -!# Introduction -! -!- This routine calculates the largest eigenvalue of a real sym dense matrix. -!- It calls ARPACK SSAUPD or DSAUPD routine - -INTERFACE - MODULE FUNCTION SymLargestEigenVal1(mat, which, NCV, maxIter, tol) & - & RESULT(ans) - TYPE(CSRMatrix_), INTENT(INOUT) :: mat - !! dense matrix - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "LM"` ⇨ absolute largest eigenvalue - !! `which = "LA"` ⇨ algebraic largest eigenvalue - !! default is "LA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, 20)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans - !! maximum eigenvalue - END FUNCTION SymLargestEigenVal1 -END INTERFACE - -INTERFACE SymLargestEigenVal - MODULE PROCEDURE SymLargestEigenVal1 -END INTERFACE SymLargestEigenVal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the `nev` smallest eigenvalue of a real sym dense matrix -! -!# Introduction -! -!- This routine calculates the smallest eigenvalue of a real sym dense matrix. -!- It calls ARPACK SSAUPD or DSAUPD routine - -INTERFACE - MODULE FUNCTION SymLargestEigenVal2(mat, nev, which, NCV, maxIter, tol) & - & RESULT(ans) - TYPE(CSRMatrix_), INTENT(INOUT) :: mat - !! dense matrix - INTEGER(I4B), INTENT(IN) :: nev - !! number of eigenvalues requested - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "LM"` ⇨ absolute largest eigenvalue - !! `which = "LA"` ⇨ algebraic largest eigenvalue - !! default is "LA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, MAX(2*nev+1, 20))` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans(nev) - !! first k, largest eigenvalue - END FUNCTION SymLargestEigenVal2 -END INTERFACE - -INTERFACE SymLargestEigenVal - MODULE PROCEDURE SymLargestEigenVal2 -END INTERFACE SymLargestEigenVal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the smallest eigenvalue of a real sym dense matrix -! -!# Introduction -! -!- This routine calculates the smallest eigenvalue of a real sym dense matrix. -!- It calls ARPACK SSAUPD or DSAUPD routine with MODE=3 -! -! In this routine we use shift-inverted method to compute the -! smallest eigenvalue of a regular (standard) eigenvalue problem. This is -! because `ARPACK` is good at finding the largest eigenvalue. -! -! Internally this routine solves a system of linear equations: `mat * y = x` -! by using LU decomposition. -! -! In this routine we make a call to LUSolve and getLU routine. -! -!@note -! In this routine we make a copy of mat in mat0. Then, compute the LU -! decomposition of mat0. -!@endnote - -INTERFACE - MODULE FUNCTION SymSmallestEigenVal1(mat, which, NCV, maxIter, tol) & - & RESULT(ans) - TYPE(CSRMatrix_), INTENT(INOUT) :: mat - !! dense matrix - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "SM"` ⇨ absolute smallest eigenvalue - !! `which = "SA"` ⇨ algebraic smallest eigenvalue - !! default is "SA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, 20)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans - !! maximum eigenvalue - END FUNCTION SymSmallestEigenVal1 -END INTERFACE - -INTERFACE SymSmallestEigenVal - MODULE PROCEDURE SymSmallestEigenVal1 -END INTERFACE SymSmallestEigenVal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-10 -! summary: Calculate the smallest eigenvalue of a real sym dense matrix -! -!# Introduction -! -! This routine is similar to SysSmallestEigenVal1() -! In this routine you can pass a factorized matrix `mat` and set `isLU=true` -! Then, this routine will not perform LU decomposition on mat. -! -! However, if `isLU=false`, then we will change mat, and on return -! it will contain the LU factorization of `mat` -! -!- [ ] TODO use Cholsky factorization instead of LU as mat is -! symmetric. -! - -INTERFACE - MODULE FUNCTION SymSmallestEigenVal2(mat, nev, which, & - & NCV, maxIter, tol) RESULT(ans) - TYPE(CSRMatrix_), INTENT(INOUT) :: mat - !! CSRMatrix - INTEGER(I4B), INTENT(IN) :: nev - !! number of eigenvalues - CHARACTER(*), OPTIONAL, INTENT(IN) :: which - !! `which = "SM"` ⇨ absolute smallest eigenvalue - !! `which = "SA"` ⇨ algebraic smallest eigenvalue - !! default is "SA" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV - !! Number of Lanczos vectors generated - !! It must be greater than 1 and smaller than `size(mat,1)` - !! Default is `NCV = MIN(n, 20)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! Maximum number of iteration default = `N*10` - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - !! tolerance, default = 0.0 - REAL(DFP) :: ans(nev) - !! smallest eigenvalue - END FUNCTION SymSmallestEigenVal2 -END INTERFACE - -INTERFACE SymSmallestEigenVal - MODULE PROCEDURE SymSmallestEigenVal2 -END INTERFACE SymSmallestEigenVal - -END MODULE CSRMatrix_SpectralMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 deleted file mode 100644 index 3b1701250..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 +++ /dev/null @@ -1,503 +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 CSRMatrix_Superlu -USE BaseType, ONLY: CSRMatrix_ -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE - -! PUBLIC :: GetLU -! PUBLIC :: LUSolve -! PUBLIC :: ! Solve -PUBLIC :: InitiateSuperluRHS -PUBLIC :: InitiateSuperluA -PUBLIC :: LinSolve -PUBLIC :: SuperluDeallocate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-26 -! summary: Initiate Superlu data structure inside csrmatrix - -INTERFACE - MODULE SUBROUTINE InitiateSuperluA(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE InitiateSuperluA -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-26 -! summary: Initiate Superlu data structure inside csrmatrix - -INTERFACE - MODULE SUBROUTINE SetSuperluA(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE SetSuperluA -END INTERFACE - -!---------------------------------------------------------------------------- -! InitiateSuperluRHS -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Set RHS - -INTERFACE InitiateSuperluRHS - MODULE SUBROUTINE InitiateSuperluRHS1(obj, rhs) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: rhs(:) - END SUBROUTINE InitiateSuperluRHS1 -END INTERFACE InitiateSuperluRHS - -!---------------------------------------------------------------------------- -! InitiateSuperluRHS -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Set RHS - -INTERFACE InitiateSuperluRHS - MODULE SUBROUTINE InitiateSuperluRHS2(obj, rhs) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: rhs(:, :) - END SUBROUTINE InitiateSuperluRHS2 -END INTERFACE InitiateSuperluRHS - -!---------------------------------------------------------------------------- -! SetSuperluRHS -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Set RHS - -INTERFACE SetSuperluRHS - MODULE SUBROUTINE SetSuperluRHS1(obj, rhs) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: rhs(:) - END SUBROUTINE SetSuperluRHS1 -END INTERFACE SetSuperluRHS - -!---------------------------------------------------------------------------- -! SetSuperluRHS -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Set RHS - -INTERFACE SetSuperluRHS - MODULE SUBROUTINE SetSuperluRHS2(obj, rhs) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: rhs(:, :) - END SUBROUTINE SetSuperluRHS2 -END INTERFACE SetSuperluRHS - -!---------------------------------------------------------------------------- -! GetSuperlux -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Get solutions - -INTERFACE GetSuperlux - MODULE SUBROUTINE GetSuperluX1(obj, x) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(INOUT) :: x(:) - END SUBROUTINE GetSuperluX1 -END INTERFACE GetSuperlux - -!---------------------------------------------------------------------------- -! GetSuperlux -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Get solutions - -INTERFACE GetSuperlux - MODULE SUBROUTINE GetSuperluX2(obj, x) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(INOUT) :: x(:, :) - END SUBROUTINE GetSuperluX2 -END INTERFACE GetSuperlux - -!---------------------------------------------------------------------------- -! InitiateSuperLuOptions -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Initiate Superlu Options - -INTERFACE - MODULE SUBROUTINE InitiateSuperLuOptions(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE InitiateSuperLuOptions -END INTERFACE - -!---------------------------------------------------------------------------- -! SetSuperluOptions -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Set options for superlu - -INTERFACE - MODULE SUBROUTINE SetSuperluOptions(obj, Fact, Equil, ColPerm, & - & Trans, IterRefine, DiagPivotThresh, SymmetricMode, & - & PivotGrowth, ConditionNumber, RowPerm, ILU_DropRule, & - & ILU_DropTol, ILU_FillFactor, ILU_MILU, PrintStat) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Fact - !! Fact_t - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil - !! yes_no_t%YES, yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm - !! Colperm_t%COLAMD - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Trans - !! Trans_t%TRANS, Trans_t% - INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine - !! IterRefine_t - REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh - !! From 0 to 1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode - !! - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth - !! yes_no_t%YES, yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber - !! yes_no_t%YES, yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: RowPerm - !! - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ILU_DropRule - !! - REAL(DFP), OPTIONAL, INTENT(IN) :: ILU_DropTol - !! - REAL(DFP), OPTIONAL, INTENT(IN) :: ILU_FillFactor - !! - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ILU_MILU - !! - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat - !! - END SUBROUTINE SetSuperluOptions -END INTERFACE - -!---------------------------------------------------------------------------- -! SuperluDGSSVX -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-27 -! summary: Call Superlu DGSSVX to solve Ax=b - -INTERFACE - MODULE SUBROUTINE SuperluDGSSVX(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE SuperluDGSSVX -END INTERFACE - -!---------------------------------------------------------------------------- -! InitiateSuperluDGSSVXParam -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-27 -! summary: Initiate Superlu DGSSVX variables - -INTERFACE - MODULE SUBROUTINE InitiateSuperluDGSSVXParam(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE InitiateSuperluDGSSVXParam -END INTERFACE - -!---------------------------------------------------------------------------- -! SuperluPrintStat -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-27 -! summary: Print statistics - -INTERFACE - MODULE SUBROUTINE SuperluDisplayStat(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE SuperluDisplayStat -END INTERFACE - -!---------------------------------------------------------------------------- -! SuperluDeallocate -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-27 -! summary: SuperluDeallocate - -INTERFACE - MODULE SUBROUTINE SuperluDeallocate(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE SuperluDeallocate -END INTERFACE - -!---------------------------------------------------------------------------- -! LinSolve1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Linear solver using LUSolve -! -!# Introduction -! -! This routine solves `A*X=B` - -INTERFACE LinSolve - MODULE SUBROUTINE LinSolve1(X, A, B, isTranspose, isFactored, & - & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & - & ConditionNumber, SymmetricMode, PrintStat, info) - REAL(DFP), INTENT(INOUT) :: X(:) - !! Solution - TYPE(CSRMatrix_), INTENT(INOUT) :: A - !! CSRMatrix - REAL(DFP), INTENT(IN) :: B(:) - !! RHS, it will not be modified, we will make a copy of it - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! Should we solve `A*X=B` or `transpose(A)*X=B` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored - !! is A already factored - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm - !! Colperm_t%NATURAL - !! Colperm_t%MMD_ATA - !! Colperm_t%MMD_AT_PLUS_A - !! Colperm_t%COLAMD - !! Colperm_t%MY_PERMC - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine - !! IterRefine_t%NO - !! IterRefine_t%SLU_SINGLE - !! IterRefine_t%SLU_DOUBLE - !! IterRefine_t%SLU_EXTRA - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth - !! yes_no_t%YES - !! yes_no_t%NO - REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh - !! between 0 and 1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! if info equal to zero then success, else failure - END SUBROUTINE LinSolve1 -END INTERFACE LinSolve - -!---------------------------------------------------------------------------- -! LinSolve2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Linear solver using LUSolve -! -!# Introduction -! -! This routine solves `A*X=B` - -INTERFACE LinSolve - MODULE SUBROUTINE LinSolve2(X, A, B, isTranspose, isFactored, & - & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & - & ConditionNumber, SymmetricMode, PrintStat, info) - REAL(DFP), INTENT(INOUT) :: X(:, :) - !! Solution - TYPE(CSRMatrix_), INTENT(INOUT) :: A - !! CSRMatrix - REAL(DFP), INTENT(IN) :: B(:, :) - !! RHS, it will not be modified, we will make a copy of it - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! Should we solve `A*X=B` or `transpose(A)*X=B` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored - !! is A already factored - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm - !! Colperm_t%NATURAL - !! Colperm_t%MMD_ATA - !! Colperm_t%MMD_AT_PLUS_A - !! Colperm_t%COLAMD - !! Colperm_t%MY_PERMC - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine - !! IterRefine_t%NO - !! IterRefine_t%SLU_SINGLE - !! IterRefine_t%SLU_DOUBLE - !! IterRefine_t%SLU_EXTRA - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth - !! yes_no_t%YES - !! yes_no_t%NO - REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh - !! between 0 and 1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! if info equal to zero then success, else failure - END SUBROUTINE LinSolve2 -END INTERFACE LinSolve - -!---------------------------------------------------------------------------- -! LinSolve1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Linear solver using LUSolve -! -!# Introduction -! -! This routine solves `A*X=B` -! Solution is returned in B - -INTERFACE LinSolve - MODULE SUBROUTINE LinSolve3(A, B, isTranspose, isFactored, & - & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & - & ConditionNumber, SymmetricMode, PrintStat, info) - TYPE(CSRMatrix_), INTENT(INOUT) :: A - !! CSRMatrix - REAL(DFP), INTENT(INOUT) :: B(:) - !! RHS, it will not be modified, we will make a copy of it - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! Should we solve `A*X=B` or `transpose(A)*X=B` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored - !! is A already factored - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm - !! Colperm_t%NATURAL - !! Colperm_t%MMD_ATA - !! Colperm_t%MMD_AT_PLUS_A - !! Colperm_t%COLAMD - !! Colperm_t%MY_PERMC - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine - !! IterRefine_t%NO - !! IterRefine_t%SLU_SINGLE - !! IterRefine_t%SLU_DOUBLE - !! IterRefine_t%SLU_EXTRA - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth - !! yes_no_t%YES - !! yes_no_t%NO - REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh - !! between 0 and 1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! if info equal to zero then success, else failure - END SUBROUTINE LinSolve3 -END INTERFACE LinSolve - -!---------------------------------------------------------------------------- -! LinSolve2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-26 -! summary: Linear solver using LUSolve -! -!# Introduction -! -! This routine solves `A*X=B` - -INTERFACE LinSolve - MODULE SUBROUTINE LinSolve4(A, B, isTranspose, isFactored, & - & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & - & ConditionNumber, SymmetricMode, PrintStat, info) - TYPE(CSRMatrix_), INTENT(INOUT) :: A - !! CSRMatrix - REAL(DFP), INTENT(INOUT) :: B(:, :) - !! RHS, it will be modified on return, solution is in B - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! Should we solve `A*X=B` or `transpose(A)*X=B` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored - !! is A already factored - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm - !! Colperm_t%NATURAL - !! Colperm_t%MMD_ATA - !! Colperm_t%MMD_AT_PLUS_A - !! Colperm_t%COLAMD - !! Colperm_t%MY_PERMC - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine - !! IterRefine_t%NO - !! IterRefine_t%SLU_SINGLE - !! IterRefine_t%SLU_DOUBLE - !! IterRefine_t%SLU_EXTRA - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth - !! yes_no_t%YES - !! yes_no_t%NO - REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh - !! between 0 and 1 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat - !! yes_no_t%YES - !! yes_no_t%NO - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! if info equal to zero then success, else failure - END SUBROUTINE LinSolve4 -END INTERFACE LinSolve - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -END MODULE CSRMatrix_Superlu diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 deleted file mode 100644 index 72f26cb0c..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 +++ /dev/null @@ -1,41 +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 CSRMatrix_SymMatmulMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: SymMatSquare - -!---------------------------------------------------------------------------- -! Matmul@MatVec -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-27 -! summary: Returns A^2 - -INTERFACE SymMatSquare - MODULE SUBROUTINE obj_SymMatSquare(obj, A) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - TYPE(CSRMatrix_), INTENT(IN) :: A - END SUBROUTINE obj_SymMatSquare -END INTERFACE SymMatSquare - -END MODULE CSRMatrix_SymMatmulMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 deleted file mode 100644 index 5321053a5..000000000 --- a/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 +++ /dev/null @@ -1,512 +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: 22 March 2021 -! summary: UnaryMethods operator for [[SparseMaatrix_]] -! -! Following subroutines are planned to include in this module -! -! | subroutine | description | -! |---|---| -! | `SUBMAT` | extracts a submatrix from a sparse matrix | -! | `FILTER` | filters elements from a matrix according to their magnitude | -! | `CSORT` | sorts the elements in increasing order of columns | -! | `CLNCSR` | clean up the CSR format matrix, remove duplicate entry, etc | -! | `TRANSP` | in-place transposition routine | -! | `COPMAT` | copy of a matrix into another matrix (both stored csr) | -! | `GETELM` | returns a(i,j) for any (i,j) from a CSR-stored matrix. | -! | `GETDIA` | extracts a specified diagonal from a matrix. | -! | `GETL` | extracts lower triangular part | -! | `GETU` | extracts upper triangular part | -! | `LEVELS` | gets the level scheduling structure for lower triangular matrices | -! | `AMASK` | extracts C = A mask M | -! | `RPERM` | permutes the rows of a matrix (B = P A) | -! | `CPERM` | permutes the columns of a matrix (B = A Q) | -! | `DPERM` | permutes both the rows and columns of a matrix (B = P A Q ) | -! | `DPERM1` | general extraction routine (extracts arbitrary rows) | -! | `DPERM2` | general submatrix permutation/extraction routine | -! | `DVPERM` | permutes a real vector (in-place) | -! | `IVPERM` | permutes an integer vector (in-place) | -! | `RETMX` | returns the max absolute value in each row of the matrix | -! | `DIAPOS` | returns the positions of the diagonal elements in A. | -! | `EXTBDG` | extracts the main diagonal blocks of a matrix. | -! | `GETBWD` | returns the bandwidth information on a matrix. | -! | `BLKFND` | finds the block-size of a matrix. | -! | `BLKCHK` | checks whether a given integer is the block size of A. | -! | `INFDIA` | obtains information on the diagonals of A. | -! | `AMUBDG` | gets number of nonzeros in each row of A*B (as well as NNZ) | -! | `APLBDG` | gets number of nonzeros in each row of A+B (as well as NNZ) | -! | `RNRMS` | computes the norms of the rows of A | -! | `CNRMS` | computes the norms of the columns of A | -! | `ROSCAL` | scales the rows of a matrix by their norms. | -! | `COSCAL` | scales the columns of a matrix by their norms. | -! | `ADDBLK` | Adds a matrix B into a block of A. | -! | `GET1UP` | Collects the first elements of each row of the upper triangular portion of the matrix | -! | `XTROWS` | extracts given rows from a matrix in CSR format. | -! | `CSRKVSTR`| Finds block row partitioning of matrix in CSR format | -! | `CSRKVSTC`| Finds block column partitioning of matrix in CSR format | -! | `KVSTMERGE`| Merges block partitionings, for conformal row/col pattern | - -MODULE CSRMatrix_UnaryMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_, RealMatrix_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: Convert -PUBLIC :: ColumnSORT -PUBLIC :: RemoveDuplicates -PUBLIC :: Clean -PUBLIC :: Copy -PUBLIC :: Get -PUBLIC :: DropEntry -PUBLIC :: GetTRANSPOSE -PUBLIC :: GetDiagonal -PUBLIC :: GetLowerTriangle -PUBLIC :: GetUpperTriangle -PUBLIC :: PermuteRow -PUBLIC :: PermuteColumn -PUBLIC :: Permute -PUBLIC :: GetSym -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: SCAL - -!---------------------------------------------------------------------------- -! Scal@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-17 -! summary: Scale the matrix - -INTERFACE Scal - MODULE SUBROUTINE obj_Scal(obj, a) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: a - END SUBROUTINE obj_Scal -END INTERFACE Scal - -!---------------------------------------------------------------------------- -! Convert@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine converts sparsematrix to dense storage -! -!# Introduction -! -! This subroutine converts sparsematrix into a dense storage format -! `A(:), IA(:), JA(:)` denotes CSR format. -! This subroutine can be used for debuggin purpose. - -INTERFACE Convert - MODULE PURE SUBROUTINE obj_Convert1(A, IA, JA, mat) - REAL(DFP), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: IA(:) - INTEGER(I4B), INTENT(IN) :: JA(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) - END SUBROUTINE obj_Convert1 -END INTERFACE Convert - -!---------------------------------------------------------------------------- -! Convert@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine converts sparsematrix to dense storage -! -!# Introduction -! -! This subroutine converts sparsematrix to dense storage format -! `A(:), IA(:), JA(:)` denotes CSR format. - -INTERFACE Convert - MODULE PURE SUBROUTINE obj_Convert2(To, From) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) - TYPE(CSRMatrix_), INTENT(IN) :: From - END SUBROUTINE obj_Convert2 -END INTERFACE Convert - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE obj_Convert2 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Convert@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine converts sparsematrix to dense storage -! -!# Introduction -! -! This subroutine converts sparsematrix to dense storage format -! `A(:), IA(:), JA(:)` denotes CSR format. - -INTERFACE Convert - MODULE PURE SUBROUTINE obj_Convert3(To, From) - TYPE(RealMatrix_), INTENT(INOUT) :: To - TYPE(CSRMatrix_), INTENT(IN) :: From - END SUBROUTINE obj_Convert3 -END INTERFACE Convert - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE obj_Convert3 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! ColumnSORT@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 March 2021 -! summary: Sort column of row -! -!# Introduction -! -! - This routine sorts the elements of a matrix (stored in Compressed -! Sparse Row Format) in increasing order of their column indices within -! each row. It uses insertion sort algorithm -! -! - `values`= logical indicating whether or not the real values a(*) must -! also be permuted. IF (.not. values) then the array a is not -! touched by csort and can be a dummy array. -! -! - Default value of `SortValue` is true. - -INTERFACE ColumnSORT - MODULE SUBROUTINE obj_ColumnSORT(obj, isValues) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - LOGICAL(LGT), INTENT(IN), OPTIONAL :: isValues - END SUBROUTINE obj_ColumnSORT -END INTERFACE ColumnSORT - -!---------------------------------------------------------------------------- -! RemoveDuplicates@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: Removes duplicate entries from the sparse matrix -! -!# Introduction -! -! This routine calls CLNCSR routine from Sparsekit - -INTERFACE RemoveDuplicates - MODULE SUBROUTINE obj_RemoveDuplicates(obj, isValues) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - LOGICAL(LGT), INTENT(IN), OPTIONAL :: isValues - END SUBROUTINE obj_RemoveDuplicates -END INTERFACE RemoveDuplicates - -!---------------------------------------------------------------------------- -! Clean@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: Performs different tasks related to cleaning of sparse matrix -! -!# Introduction -! This routine performs tasks related to the cleaning of sparse matrix. - -INTERFACE Clean - MODULE SUBROUTINE obj_Clean(obj, isValues, ExtraOption) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues - !! If .TRUE. then values will be touched, otherwise they remain - !! untouched by this subroutine - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ExtraOption - !! If it is 0, then do nothing - !! If 1, then remove duplicates and zeros, if any - !! If 2, then remove duplicates and perform partial ordering - !! If 3, then remove duplicates, sort entries in increasing order of col - END SUBROUTINE obj_Clean -END INTERFACE Clean - -!---------------------------------------------------------------------------- -! Copy@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 March 2021 -! summary: Copy sparse matrix into each other - -INTERFACE Copy - MODULE SUBROUTINE obj_Copy(From, To) - TYPE(CSRMatrix_), INTENT(IN) :: From - TYPE(CSRMatrix_), INTENT(INOUT) :: To - END SUBROUTINE obj_Copy -END INTERFACE Copy - -!---------------------------------------------------------------------------- -! get@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This returns a sigle value from the matrix - -INTERFACE Get - MODULE FUNCTION obj_Get1(obj, i, j) RESULT(Ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: i, j - REAL(DFP) :: Ans - END FUNCTION obj_Get1 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Filter@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July, 2021 -! summary: This routine removes any elements whose absolute value is small -! from an input matrix A and puts the resulting matrix in B. -! -!# Introduction -! -! - `option` = integer. used to determine strategy chosen by caller to drop -! elements from matrix A. -! - `option` = 1, Elements whose absolute value is less than the drop -! tolerance are removed. -! - `option` = 2, Elements whose absolute value is less than the product of -! the drop tolerance and the Euclidean norm of the row are removed. -! - `option` = 3, Elements whose absolute value is less that the product of -! the drop tolerance and the largest element in the row are removed. -! - `droptol` = real. drop tolerance used for dropping strategy. - -INTERFACE DropEntry - MODULE SUBROUTINE obj_DropEntry(objIn, objOut, droptol, option) - TYPE(CSRMatrix_), INTENT(IN) :: objIn - TYPE(CSRMatrix_), INTENT(INOUT) :: objOut - REAL(DFP), INTENT(IN) :: droptol - INTEGER(I4B), OPTIONAL, INTENT(IN) :: option - END SUBROUTINE obj_DropEntry -END INTERFACE DropEntry - -!---------------------------------------------------------------------------- -! Transpose@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July 2021 -! summary: Transpose of the sparse matrix -! -!# Introduction -! -! In-place transposition routine. This subroutine transposes a matrix stored -! in compressed sparse row format. the transposition is done in place in that -! the arrays a,ja,ia c of the transpose are overwritten onto the original -! arrays. - -INTERFACE GetTRANSPOSE - MODULE SUBROUTINE obj_Transpose(obj) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE obj_Transpose -END INTERFACE GetTRANSPOSE - -!---------------------------------------------------------------------------- -! getDiagonal@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July 2021 -! summary: Returns the diagonal of sparse matrix -! -!# Introduction -! -! This subroutine returns the diagonal entries of sparse matrix. -! -! - offset: containing the offset of the wanted diagonal the diagonal -! extracted is the one corresponding to the entries `a(i,j)` with `j-i = -! ioff`. thus `ioff = 0` means the main diagonal -! - `diag` : real*8 array of length nrow containing the wanted diagonal. diag -! contains the diagonal (`a(i,j),j-i = ioff`) as defined above. -! - `idiag` = integer array of length `len`, containing the poisitions in -! the original arrays `a` and `ja` of the diagonal elements collected in -! `diag`. A zero entry in `idiag(i)` means that there was no entry found in -! row i belonging to the diagonal. - -INTERFACE GetDiagonal - MODULE SUBROUTINE obj_getDiagonal1(obj, diag, idiag, offset) - TYPE(CSRMatrix_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: idiag(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: offset - END SUBROUTINE obj_getDiagonal1 -END INTERFACE GetDiagonal - -!---------------------------------------------------------------------------- -! getDiagonal@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July 2021 -! summary: Returns the diagonal of sparse matrix -! -!# Introduction -! -! This subroutine returns the diagonal entries of sparse matrix. -! -! - offset: containing the offset of the wanted diagonal the diagonal -! extracted is the one corresponding to the entries `a(i,j)` with `j-i = -! ioff`. thus `ioff = 0` means the main diagonal -! - `diag` : real*8 array of length nrow containing the wanted diagonal. diag -! contains the diagonal (`a(i,j),j-i = ioff`) as defined above. - -INTERFACE GetDiagonal - MODULE SUBROUTINE obj_getDiagonal2(obj, diag, offset) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: offset - END SUBROUTINE obj_getDiagonal2 -END INTERFACE GetDiagonal - -!---------------------------------------------------------------------------- -! getLowerTriangle@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July 2021 -! summary: Returns the lower part of the sparse matrix -! -!# Introduction -! -! This subroutine returns the lower part of the sparse matrix. - -INTERFACE GetLowerTriangle - MODULE SUBROUTINE obj_getLowerTriangle(obj, L) - TYPE(CSRMatrix_), INTENT(IN) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: L - END SUBROUTINE obj_getLowerTriangle -END INTERFACE GetLowerTriangle - -!---------------------------------------------------------------------------- -! getUpperTriangle@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July 2021 -! summary: Returns the Upper part of the sparse matrix -! -!# Introduction -! -! This subroutine returns the Upper part of the sparse matrix. - -INTERFACE GetUpperTriangle - MODULE SUBROUTINE obj_getUpperTriangle(obj, U) - TYPE(CSRMatrix_), INTENT(IN) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: U - END SUBROUTINE obj_getUpperTriangle -END INTERFACE GetUpperTriangle - -!---------------------------------------------------------------------------- -! PermuteRow@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2021 -! summary: Permute the rows of sparse matrix - -INTERFACE PermuteRow - MODULE FUNCTION obj_permuteRow(obj, PERM, isValues) & - & RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: PERM(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues - TYPE(CSRMatrix_) :: ans - END FUNCTION obj_permuteRow -END INTERFACE PermuteRow - -!---------------------------------------------------------------------------- -! PermuteColumn@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2021 -! summary: Permute the columns of sparse matrix - -INTERFACE PermuteColumn - MODULE FUNCTION obj_permuteColumn(obj, PERM, isValues) & - & RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: PERM(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues - TYPE(CSRMatrix_) :: ans - END FUNCTION obj_permuteColumn -END INTERFACE PermuteColumn - -!---------------------------------------------------------------------------- -! Permute@Unary -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2021 -! summary: Permute the columns of sparse matrix - -INTERFACE Permute - MODULE FUNCTION obj_permute(obj, rowPERM, colPERM, & - & isValues, symPERM) RESULT(ans) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), OPTIONAL, INTENT(IN) :: rowPERM(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: colPERM(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: symPERM - TYPE(CSRMatrix_) :: ans - END FUNCTION obj_permute -END INTERFACE Permute - -!---------------------------------------------------------------------------- -! GetSym -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-28 -! summary: Returns symmetric part of csrmatrix in symObj - -INTERFACE GetSym - MODULE SUBROUTINE obj_GetSym1(obj, symObj, from) - TYPE(CSRMatrix_), INTENT(IN) :: obj - TYPE(CSRMatrix_), INTENT(INOUT) :: symObj - CHARACTER(1), INTENT(IN) :: from - END SUBROUTINE obj_GetSym1 -END INTERFACE GetSym - -!---------------------------------------------------------------------------- -! GetSym -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-28 -! summary: Returns symmetric part of csrmatrix in symObj - -INTERFACE GetSym - MODULE SUBROUTINE obj_GetSym2(obj, from) - TYPE(CSRMatrix_), INTENT(INOUT) :: obj - CHARACTER(1), INTENT(IN) :: from - END SUBROUTINE obj_GetSym2 -END INTERFACE GetSym - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -END MODULE CSRMatrix_UnaryMethods diff --git a/src/modules/CSRSparsity/CMakeLists.txt b/src/modules/CSRSparsity/CMakeLists.txt deleted file mode 100644 index 7c10b33f3..000000000 --- a/src/modules/CSRSparsity/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/CSRSparsity_Method.F90 -) \ No newline at end of file diff --git a/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 b/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 deleted file mode 100644 index 479d0be9a..000000000 --- a/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 +++ /dev/null @@ -1,821 +0,0 @@ -! This program is a part of EASIFEM librarycsrsparsity -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General 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: 22 March 2021 -! summary: This module contains methods for [[CSRSparsity_]] - -MODULE CSRSparsity_Method -USE GlobalData -USE Basetype -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetSym -PUBLIC :: Initiate -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: SetSparsity -PUBLIC :: CSRSparsity -PUBLIC :: CSRSparsityPointer -PUBLIC :: DEALLOCATE -PUBLIC :: GetDiagonal -PUBLIC :: Display -PUBLIC :: Shape -PUBLIC :: Size -PUBLIC :: GetNNZ -PUBLIC :: GetColIndex -PUBLIC :: GetColNumber -PUBLIC :: OPERATOR(.startColumn.) -PUBLIC :: OPERATOR(.endColumn.) -PUBLIC :: SetIA -PUBLIC :: SetJA -PUBLIC :: GetIA -PUBLIC :: GetJA - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine constructs the CSR sparsity object -! -!# Introduction -! -! This subroutine initiate the instance of [[CSRSparsity_]] object -! -! - ncol is the number of columns -! - nrow is the number of rows -! - dof is the degrees of freedom object, if it is present then it used -! to initiate [[DOF_:dof]]. -! -!@note -! If dof object is not present, then this routine initiates -! [[CSRSparsity_:dof]] internally with following options. -! -! - tNodes = [nrow] -! - names= ["K"] -! - spacecompo= [1] -! - timecompo = [1] -! - storageFMT = FMT_NODES -!@endnote -! - -INTERFACE Initiate - MODULE SUBROUTINE obj_initiate1(obj, ncol, nrow, idof, jdof, nnz) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ncol, nrow - TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof - !! DOF for row - TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof - !! DOF for column - INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnz - !! number of nonzeros - END SUBROUTINE obj_initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine construct `CSRSparsity_` object from copying -! -!# Introduction -! -! This subroutine copies `obj2` into `obj`, and initiates the latter one. -! This routine is used to define the assignment operator. - -INTERFACE Initiate - MODULE SUBROUTINE obj_initiate2(obj, obj2) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - TYPE(CSRSparsity_), INTENT(IN) :: obj2 - END SUBROUTINE obj_initiate2 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE obj_initiate2 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine constructs `CSRSparsity_` object from IA, JA -! -!# Introduction -! -! - This routine constructs [[CSRSparsity_]] instance by using the -! indices `IA` and `JA` -! - This routine is helpful in reading data from files. -! - This routine calls [[CSRSparsity_Method:obj_initiate1]] method -! without `dof` argument. So this type of initiation does not contain -! useful information about the degree of freedoms. -! - -INTERFACE Initiate - MODULE SUBROUTINE obj_initiate3(obj, IA, JA, ncol) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: IA(:), JA(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ncol - !! number of columns, default is number of rows - END SUBROUTINE obj_initiate3 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! CSRSparsity@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct, 2021 -! summary: Returns an instance of [[CSRSparsity_]] -! -!# Introduction -! -! This function returns an instance of [[CSRSparsity_]] - -INTERFACE CSRSparsity - MODULE FUNCTION obj_constructor1(nrow, ncol, idof, jdof) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nrow - INTEGER(I4B), INTENT(IN) :: ncol - TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof - !! dof for row - TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof - !! dof for column - TYPE(CSRSparsity_) :: ans - END FUNCTION obj_constructor1 -END INTERFACE CSRSparsity - -!---------------------------------------------------------------------------- -! CSRSparsity@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct, 2021 -! summary: Returns an instance of [[CSRSparsity_]] -! -!# Introduction -! -! This function returns an instance of [[CSRSparsity_]] - -INTERFACE CSRSparsity - MODULE FUNCTION obj_constructor2(IA, JA) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: IA(:) - INTEGER(I4B), INTENT(IN) :: JA(:) - TYPE(CSRSparsity_) :: ans - END FUNCTION obj_constructor2 -END INTERFACE CSRSparsity - -!---------------------------------------------------------------------------- -! CSRSparsityPointer@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct, 2021 -! summary: Returns an instance of [[CSRSparsity_]] -! -!# Introduction -! -! This function returns an instance of [[CSRSparsity_]] - -INTERFACE CSRSparsityPointer - MODULE FUNCTION obj_constructor_1(nrow, ncol, idof, jdof) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nrow - INTEGER(I4B), INTENT(IN) :: ncol - TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof - !! dof for row - TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof - !! dof for column - TYPE(CSRSparsity_), POINTER :: ans - END FUNCTION obj_constructor_1 -END INTERFACE CSRSparsityPointer - -!---------------------------------------------------------------------------- -! CSRSparsityPointer@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct, 2021 -! summary: Returns an instance of [[CSRSparsity_]] -! -!# Introduction -! -! This function returns an instance of [[CSRSparsity_]] - -INTERFACE CSRSparsityPointer - MODULE FUNCTION obj_constructor_2(IA, JA) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: IA(:) - INTEGER(I4B), INTENT(IN) :: JA(:) - TYPE(CSRSparsity_), POINTER :: ans - END FUNCTION obj_constructor_2 -END INTERFACE CSRSparsityPointer - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine deallocates the data - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE obj_Deallocate(obj) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - END SUBROUTINE obj_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine display the content of sparsity - -INTERFACE Display - MODULE SUBROUTINE obj_Display(obj, Msg, UnitNo) - TYPE(CSRSparsity_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: Msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - END SUBROUTINE obj_Display -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Shape@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This function returns the shape of the sparse matrix -! -!# Introduction -! -! This function returns the shape of sparse matrix - -INTERFACE Shape - MODULE PURE FUNCTION obj_shape(obj) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B) :: ans(2) - END FUNCTION obj_shape -END INTERFACE Shape - -!---------------------------------------------------------------------------- -! Size@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This function returns the size of sparse matrix -! -!# Introduction -! -! This function returns the size of sparse matrix -! If Dims equal to 1 then total number of rows are returned -! If Dims is equal to 2 then total number of columns are return -! If Dims is absent then nrow*ncol are returned - -INTERFACE Size - MODULE PURE FUNCTION obj_size(obj, Dims) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B), OPTIONAL, INTENT(IN) :: Dims - INTEGER(I4B) :: ans - END FUNCTION obj_size -END INTERFACE Size - -!---------------------------------------------------------------------------- -! GetNNZ@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Return the total number of non zero entry - -INTERFACE GetNNZ - MODULE PURE FUNCTION obj_GetNNZ(obj) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_GetNNZ -END INTERFACE GetNNZ - -!---------------------------------------------------------------------------- -! GetNNZ@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Return the total number of non zero entry - -INTERFACE GetNNZ - MODULE PURE FUNCTION obj_GetNNZ_from_operation(obj1, obj2, op, isSorted) & - & RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj1 - !! CSRSparsity object - TYPE(CSRSparsity_), INTENT(IN) :: obj2 - !! CSRSparsity object - CHARACTER(1), INTENT(IN) :: op - !! "*", "+", "-" - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSorted - !! Set it to true if the columns are sorted in obj1 and obj2 - !! Default is .false. - INTEGER(I4B) :: ans - !! total number of non zero entries - END FUNCTION obj_GetNNZ_from_operation -END INTERFACE GetNNZ - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: Initiate an object by adding two csrmatrix - -INTERFACE - MODULE PURE FUNCTION GetNNZ_Add_Subtract(nrow, ncol, ja, ia, jb, ib) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nrow, ncol - !! number of rows in a and b matrix - INTEGER(I4B), INTENT(IN) :: ja(:) - !! sparsity of ja - INTEGER(I4B), INTENT(IN) :: ia(:) - !! nrow + 1 - INTEGER(I4B), INTENT(IN) :: jb(:) - !! sparsity of jb - INTEGER(I4B), INTENT(IN) :: ib(:) - !! nrow + 1 - INTEGER(I4B) :: ans - END FUNCTION GetNNZ_Add_Subtract -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-16 -! summary: Initiate an object by adding two csrmatrix - -INTERFACE - MODULE PURE FUNCTION GetNNZ_Add_Subtract_sorted(nrow, ncol, ja, ia, jb, & - & ib) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nrow, ncol - !! number of rows in a and b matrix - INTEGER(I4B), INTENT(IN) :: ja(:) - !! sparsity of ja - INTEGER(I4B), INTENT(IN) :: ia(:) - !! nrow + 1 - INTEGER(I4B), INTENT(IN) :: jb(:) - !! sparsity of jb - INTEGER(I4B), INTENT(IN) :: ib(:) - !! nrow + 1 - INTEGER(I4B) :: ans - END FUNCTION GetNNZ_Add_Subtract_sorted -END INTERFACE - -!---------------------------------------------------------------------------- -! GetNNZ@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-28 -! summary: Return the total number of non zero entry - -INTERFACE GetNNZ - MODULE PURE FUNCTION obj_GetNNZ1(obj, from) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - CHARACTER(1), INTENT(IN) :: from - !! "U" nnz in upper triangular part, j > i - !! "L" nnz in lower triangular part, i > j - !! "D" nnz in diagonal part, i=j - !! "A" nnz in whole matrix, L+U+D - INTEGER(I4B) :: ans - END FUNCTION obj_GetNNZ1 -END INTERFACE GetNNZ - -!---------------------------------------------------------------------------- -! GetNNZ@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-28 -! summary: Return the total number of non zero in U, L and D - -INTERFACE GetNNZ - MODULE PURE FUNCTION obj_GetNNZ2(obj, from) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - CHARACTER(1), INTENT(IN) :: from(1) - !! this argument is not referred, it is here - !! to create a unique interface only - INTEGER(I4B) :: ans(3) - !! [nnzU, nnzL, nnzD] - END FUNCTION obj_GetNNZ2 -END INTERFACE GetNNZ - -!---------------------------------------------------------------------------- -! GetDiagonal@GeMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July 2021 -! summary: Returns the diagonal of sparse matrix -! -!# Introduction -! -! This subroutine returns the diagonal entries of sparse matrix. This -! Routine calls the Saad's sparse library. -! -! `offSet`: containing the `offset` of the wanted diagonal. The diagonal -! extracted is the one corresponding to the entries `a(i,j)` with `j-i = -! offSet`. Therefore, `offset = 0` means the main diagonal -! -! `diag` : real array of length `nrow` containing the wanted diagonal. `diag` -! contains the diagonal (`a(i,j),j-i = offSet`) as defined above. -! -! `idiag` = integer array. It contains the poisitions of diagonal in the -! original arrays `A`. If `idiag(i)=0` then it means that there was no -! diagonal found in row=i. - -INTERFACE GetDiagonal - MODULE SUBROUTINE obj_GetDiagonal1(obj, A, diag, idiag, offSet) - TYPE(CSRSparsity_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) - !! Diagonal entries - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: idiag(:) - !! Position of diagonal entries in `A(:)` - INTEGER(I4B), OPTIONAL, INTENT(IN) :: offSet - !! offSet of the wanted diagonal - END SUBROUTINE obj_GetDiagonal1 -END INTERFACE GetDiagonal - -!---------------------------------------------------------------------------- -! GetDiagonal@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 July 2021 -! summary: Returns the diagonal of sparse matrix -! -!# Introduction -! -! This subroutine returns the diagonal entries of sparse matrix. -! -! This routine is similar to [[CSRSparsity_Method:obj_GetDiagonal1]]. -! However, this routine does not return the position of diagonal in `A` - -INTERFACE GetDiagonal - MODULE SUBROUTINE obj_GetDiagonal2(obj, A, diag, offSet) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: A(:) - !! Sparse matrix values - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) - !! Diagonal entries - INTEGER(I4B), OPTIONAL, INTENT(IN) :: offSet - !! offSet of diagonal - END SUBROUTINE obj_GetDiagonal2 -END INTERFACE GetDiagonal - -!---------------------------------------------------------------------------- -! GetColNumber@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the column number from JA. - -INTERFACE GetColNumber - MODULE PURE FUNCTION obj_GetColNumber1(obj, indx) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(I4B) :: ans - END FUNCTION obj_GetColNumber1 -END INTERFACE GetColNumber - -!---------------------------------------------------------------------------- -! GetColIndex@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the starting and ending column index of irow - -INTERFACE GetColIndex - MODULE PURE FUNCTION obj_GetColIndex1(obj, irow) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B) :: ans(2) - END FUNCTION obj_GetColIndex1 -END INTERFACE GetColIndex - -!---------------------------------------------------------------------------- -! startColumn@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the starting column index of irow - -INTERFACE OPERATOR(.startColumn.) - MODULE PURE FUNCTION obj_startColumn1(obj, irow) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B) :: ans - END FUNCTION obj_startColumn1 -END INTERFACE OPERATOR(.startColumn.) - -!---------------------------------------------------------------------------- -! endColumn@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get the ending column index of irow - -INTERFACE OPERATOR(.endColumn.) - MODULE PURE FUNCTION obj_endColumn1(obj, irow) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B) :: ans - END FUNCTION obj_endColumn1 -END INTERFACE OPERATOR(.endColumn.) - -!---------------------------------------------------------------------------- -! SetSparsity@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set the sparsity pattern of a given row -! -!# Introduction -! -! This subroutine Sets the sparsity pattern of a given row -! - If `obj%tdof` is equal to 1, then `Col` is sorted in increasing order, -! and appended to `obj%Row(Row)` -! - If `obj%tdof` is not equal to 1, then based on the storage format and -! `Col` connectivity information is generated. - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_SetSparsity1(obj, Row, Col) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Row - !! row number - INTEGER(I4B), INTENT(IN) :: Col(:) - !! column number - END SUBROUTINE obj_SetSparsity1 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Sets the sparsity pattern of several rows -! -!# Introduction -! This routine is similar to [[CSRSparsity_Method:obj_SetSparsity1]]. -! However, in this routine several rows can be given. - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_SetSparsity2(obj, Row, Col) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Row(:) - !! row number - TYPE(IntVector_), INTENT(IN) :: Col(:) - !! column number - END SUBROUTINE obj_SetSparsity2 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct 2021 -! summary: This subroutine Sets sparsity pattern for block `CSRSparsity_` - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_SetSparsity3(obj, row, col, ivar, jvar) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: row - !! row number - INTEGER(I4B), INTENT(IN) :: col(:) - !! sparsity of row, column numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! block address (row index) - INTEGER(I4B), INTENT(IN) :: jvar - !! block address (col index) - END SUBROUTINE obj_SetSparsity3 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Sets the sparsity pattern of a given row -! -!# Introduction -! This routine is similar to the [[CSRSparsity_Method:obj_SetSparsity3]], -! however, in this routine we can specify several rows and their -! column indices. - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_SetSparsity4(obj, Row, Col, iVar, jVar) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Row(:) - !! several row numbers - TYPE(IntVector_), INTENT(IN) :: Col(:) - !! column index for each row number - INTEGER(I4B), INTENT(IN) :: iVar - !! block address (row index) - INTEGER(I4B), INTENT(IN) :: jVar - !! block address (col index) - END SUBROUTINE obj_SetSparsity4 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set the sparsity pattern of a given row -! -!# Introduction -! -! This subroutine Sets the sparsity pattern by using the graph. -! graph( i, j ) is either 0 or 1, if zero then there is not connection -! between row-i and row-j - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_SetSparsity5(obj, graph) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: graph(:, :) - !! graph of sparsity - !! If graph( i, j ) .EQ. 0, then i and j are not connected - !! else they are connected. - END SUBROUTINE obj_SetSparsity5 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set the sparsity pattern of a given row -! -!# Introduction -! -! This subroutine Sets the sparsity pattern by using the graph. -! graph( i, j ) is either FALSE or TRUE, if FALSE then there is not connection -! between row-i and row-j - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_SetSparsity6(obj, graph) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - LOGICAL(LGT), INTENT(IN) :: graph(:, :) - !! graph of sparsity - !! If graph( i, j ) .EQ. FALSE, then i and j are not connected - !! else they are connected. - END SUBROUTINE obj_SetSparsity6 -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetSparsity@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This subroutine Set sparsity pattern of `CSRSparsity_` -! -!# Introduction -! This subroutine Set sparsity pattern of `CSRSparsity_` -! This will finally Set the data into -! - `obj%IA(:)`, -! - `obj%JA(:)` -! in CSR format. This routine also Set data inside `obj%ColSize(:)` and -! `obj%RowSize(:) `, and `obj%DiagIndx(:)` - -INTERFACE SetSparsity - MODULE SUBROUTINE obj_SetSparsity_final(obj) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - END SUBROUTINE obj_SetSparsity_final -END INTERFACE SetSparsity - -!---------------------------------------------------------------------------- -! SetIA@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Set entry in IA - -INTERFACE SetIA - MODULE PURE SUBROUTINE obj_SetIA(obj, irow, VALUE) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B), INTENT(IN) :: VALUE - END SUBROUTINE obj_SetIA -END INTERFACE SetIA - -!---------------------------------------------------------------------------- -! SetJA@SetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Set entry in JA - -INTERFACE SetJA - MODULE PURE SUBROUTINE obj_SetJA(obj, indx, VALUE) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(I4B), INTENT(IN) :: VALUE - END SUBROUTINE obj_SetJA -END INTERFACE SetJA - -!---------------------------------------------------------------------------- -! GetIA@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-23 -! summary: Get entry from IA - -INTERFACE GetIA - MODULE PURE FUNCTION obj_GetIA(obj, irow) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow - INTEGER(I4B) :: ans - END FUNCTION obj_GetIA -END INTERFACE GetIA - -!---------------------------------------------------------------------------- -! GetJA@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-14 -! summary: Get entry from JA - -INTERFACE GetJA - MODULE PURE FUNCTION obj_GetJA(obj, indx) RESULT(ans) - TYPE(CSRSparsity_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(I4B) :: ans - END FUNCTION obj_GetJA -END INTERFACE GetJA - -!---------------------------------------------------------------------------- -! GetSym@SymMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-28 -! summary: Get symmetric part - -INTERFACE GetSym - MODULE SUBROUTINE obj_GetSym1(obj, symObj, from) - TYPE(CSRSparsity_), INTENT(IN) :: obj - TYPE(CSRSparsity_), INTENT(INOUT) :: symObj - CHARACTER(1), INTENT(IN) :: from - END SUBROUTINE obj_GetSym1 -END INTERFACE GetSym - -!---------------------------------------------------------------------------- -! GetSym@SymMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-28 -! summary: Get symmetric part - -INTERFACE GetSym - MODULE SUBROUTINE obj_GetSym2(obj, from) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - CHARACTER(1), INTENT(IN) :: from - END SUBROUTINE obj_GetSym2 -END INTERFACE GetSym - -END MODULE CSRSparsity_Method diff --git a/src/modules/ConvectiveMatrix/CMakeLists.txt b/src/modules/ConvectiveMatrix/CMakeLists.txt deleted file mode 100644 index 42b66b648..000000000 --- a/src/modules/ConvectiveMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ConvectiveMatrix_Method.F90 -) diff --git a/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 b/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 deleted file mode 100644 index b38be47e3..000000000 --- a/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 +++ /dev/null @@ -1,125 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE ConvectiveMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@ConvectiveMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-21 -! update: 2021-11-21 -! summary: returns the convective matrix - -INTERFACE - MODULE PURE FUNCTION ConvectiveMatrix_1(test, trial, term1, & - & term2, opt) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z, del_x_all, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z, del_x_all, del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ConvectiveMatrix_1 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE ConvectiveMatrix_1 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@ConvectiveMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-21 -! update: 2021-11-21 -! summary: returns the convective matrix - -INTERFACE - MODULE PURE FUNCTION ConvectiveMatrix_2(test, trial, c, crank, term1, & - & term2, opt) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: c - !! scalar variable - TYPE(FEVariableScalar_), INTENT(IN) :: crank - !! scalar variable - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z, del_x_all, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z, del_x_all, del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! number of copies - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ConvectiveMatrix_2 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE ConvectiveMatrix_2 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@ConvectiveMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-21 -! update: 2021-11-21 -! summary: returns the convective matrix - -INTERFACE - MODULE PURE FUNCTION ConvectiveMatrix_3(test, trial, c, crank, term1, & - & term2, opt) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: c - !! It can be a scalar or vector variable - TYPE(FEVariableVector_), INTENT(IN) :: crank - !! It can be a scalar or vector variable - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z, del_x_all, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z, del_x_all, del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! number of copies - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ConvectiveMatrix_3 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE ConvectiveMatrix_3 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ConvectiveMatrix_Method diff --git a/src/modules/DOF/CMakeLists.txt b/src/modules/DOF/CMakeLists.txt deleted file mode 100644 index 35bb9361d..000000000 --- a/src/modules/DOF/CMakeLists.txt +++ /dev/null @@ -1,27 +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 -# -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/DOF_Method.F90 - ${src_path}/DOF_ConstructorMethods.F90 - ${src_path}/DOF_IOMethods.F90 - ${src_path}/DOF_GetMethods.F90 - ${src_path}/DOF_GetValueMethods.F90 - ${src_path}/DOF_SetMethods.F90 - ${src_path}/DOF_AddMethods.F90 -) diff --git a/src/modules/DOF/src/DOF_AddMethods.F90 b/src/modules/DOF/src/DOF_AddMethods.F90 deleted file mode 100644 index 14241de95..000000000 --- a/src/modules/DOF/src/DOF_AddMethods.F90 +++ /dev/null @@ -1,451 +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 DOF_AddMethods -USE GlobalData, ONLY: DFP, I4B, LGT -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of all dof defined inside `obj`. Once -! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. -! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF` -! or `NONE`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add1(vec, obj, nodenum, VALUE, scale, & - conversion) - REAL(DFP), INTENT(INOUT) :: vec(:) - !! Vector to set values in - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! Node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! Value - REAL(DFP), INTENT(IN) :: scale - !! scale - INTEGER(I4B), INTENT(IN) :: conversion(1) - !! conversion - END SUBROUTINE obj_Add1 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of all dof defined inside `obj`. Once -! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. -! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF` -! or `NONE`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add2(vec, obj, nodenum, VALUE, scale) - REAL(DFP), INTENT(INOUT) :: vec(:) - !! vector to set values in - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - REAL(DFP), INTENT(IN) :: scale - !! scale - END SUBROUTINE obj_Add2 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of dof `dofno`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add3(vec, obj, nodenum, VALUE, scale, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - !! vector to set values in - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vec = values, size of value should be equal to the size of nodenum - REAL(DFP), INTENT(IN) :: scale - !! scale - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - END SUBROUTINE obj_Add3 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -! This subroutine calls obj_Add3 - -INTERFACE Add - MODULE SUBROUTINE obj_Add4(vec, obj, nodenum, VALUE, scale, ivar, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - !! vector to set values in - TYPE(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - REAL(DFP), INTENT(IN) :: scale - !! scale - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add4 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!@note -! this routine calls obj_Add3 -!@endnote - -INTERFACE Add - MODULE SUBROUTINE obj_Add5(vec, obj, nodenum, VALUE, scale, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - !! the size of value should be same as nodenum - REAL(DFP), INTENT(IN) :: scale - !! scale - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space components - INTEGER(I4B), INTENT(IN) :: timecompo - !! time components - END SUBROUTINE obj_Add5 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers - -INTERFACE Add - MODULE SUBROUTINE obj_Add6(vec, obj, nodenum, VALUE, scale, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - REAL(DFP), INTENT(IN) :: scale - !! scale - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space components - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time components - END SUBROUTINE obj_Add6 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers - -INTERFACE Add - MODULE SUBROUTINE obj_Add7(vec, obj, nodenum, VALUE, scale, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - REAL(DFP), INTENT(IN) :: scale - !! scale - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! space components - INTEGER(I4B), INTENT(IN) :: timecompo - !! time components - END SUBROUTINE obj_Add7 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of all dof defined inside `obj`. Once -! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. -! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF` -! or `NONE`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add8(vec, obj, nodenum, VALUE, scale) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add8 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of dof `dofno`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add9(vec, obj, nodenum, VALUE, scale, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add9 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of dof `dofno`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add10(vec, obj, nodenum, VALUE, scale, ivar, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add10 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of dof `dofno`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add11(vec, obj, nodenum, VALUE, scale, & - ivar, spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add11 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of dof `dofno`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add12(vec, obj, nodenum, VALUE, scale, & - ivar, spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - END SUBROUTINE obj_Add12 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add@addMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Add values in a vector of real numbers -! -!# Introduction -! -! This subroutine is designed to Add values in a vector of real number -! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom -! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` -! - `value` denotes the nodal values of dof `dofno`. -! -! This subroutine effectivily performes -! `vec( nptrs ) = vec(nptrs) + scale * value` - -INTERFACE Add - MODULE SUBROUTINE obj_Add13(vec, obj, nodenum, VALUE, scale, & - ivar, spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add13 -END INTERFACE Add - -END MODULE DOF_AddMethods diff --git a/src/modules/DOF/src/DOF_ConstructorMethods.F90 b/src/modules/DOF/src/DOF_ConstructorMethods.F90 deleted file mode 100644 index f70e5bd71..000000000 --- a/src/modules/DOF/src/DOF_ConstructorMethods.F90 +++ /dev/null @@ -1,220 +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 DOF_ConstructorMethods -USE GlobalData, ONLY: DFP, I4B, LGT, FMT_DOF, FMT_NODES, DOF_FMT, & - NODES_FMT - -USE BaseType, ONLY: DOF_ - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: Initiate -PUBLIC :: DOF_Pointer -PUBLIC :: DEALLOCATE -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: DOF - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine initiate DOF_ object -! -!# Introduction -! -! This subroutine initiate DOF_ object -! -!- If the size of all physical variables are equal then set -! tNodes = [tNodes] otherwise we need to provide size of each dof -!- For a scalar physical variable such as pressure and temperature, -! `spacecompo` is set to -1. -!- For a time independent physical variable `timecompo` is set to 1. -!- The size of `Names`, `spacecompo`, `timecompo` should be same -! -!@note -! $\matbf{v}$ is a physical variable, however, -! its component $v_1, v_2, v_3$ all are degrees of freedom. -!@endnote - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate1(obj, tNodes, Names, spacecompo, & - & timecompo, StorageFMT) - CLASS(DOF_), INTENT(INOUT) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: tNodes(:) - !! number of nodes for each physical variable - CHARACTER(1), INTENT(IN) :: Names(:) - !! Names of each physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! Space component of each physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! Time component of each physical variable - INTEGER(I4B), INTENT(IN) :: StorageFMT - !! Storage format `FMT_DOF`, `FMT_Nodes` - END SUBROUTINE obj_initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Initiate a fortran vector using DOF_ object -! -!# Introduction -! -! This subroutine initiates a fortran vector (rank-1 fortran array ) of -! real using the information stored inside DOF_ object. This subroutine -! gets the size of array from the DOF_ object and then reallocates -! `val` and set its all values to zero. - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate2(val, obj) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: val(:) - !! This vector will be initiated by using obj - CLASS(DOF_), INTENT(IN) :: obj - !! DOF object - END SUBROUTINE obj_initiate2 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct, 2021 -! summary: Initiate two fortran vectors using obj_ object -! -!# Introduction -! -! This subroutine can initiate two fortran vectors (rank-1 fortran arrays) -! using the information stored inside the DOF_ object - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate3(Val1, Val2, obj) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Val1(:), Val2(:) - CLASS(DOF_), INTENT(IN) :: obj - END SUBROUTINE obj_initiate3 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 July 2021 -! summary: Initiate an instance of DOF_ by copying other object -! -!# Introduction -! -! This routine copy obj2 into obj1. It also define an assignment operator - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate4(obj1, obj2) - CLASS(DOF_), INTENT(INOUT) :: obj1 - CLASS(DOF_), INTENT(IN) :: obj2 - END SUBROUTINE obj_initiate4 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE obj_initiate4 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! DOF@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 oct 2021 -! summary: Constructor for dof_ object -! -!# Introduction -! -! This function return instance of DOF_ -! This function calls DOF_Method:DOF_Initiate1 method -! for more see dof_ - -INTERFACE DOF - MODULE PURE FUNCTION obj_Constructor1(tNodes, Names, spacecompo, timecompo, & - & StorageFMT) RESULT(obj) - TYPE(DOF_) :: obj - INTEGER(I4B), INTENT(IN) :: tNodes(:), spacecompo(:), & - & timecompo(:), StorageFMT - CHARACTER(1), INTENT(IN) :: Names(:) - END FUNCTION obj_Constructor1 -END INTERFACE DOF - -!---------------------------------------------------------------------------- -! DOF_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct, 2021 -! summary: Returns pointer to newly created dof_ object -! -!# Introduction -! -! This function returns the pointer to instance of dof_ object -! for more see dof_ - -INTERFACE DOF_Pointer - MODULE FUNCTION obj_Constructor_1(tNodes, Names, spacecompo, timecompo, & - & StorageFMT) RESULT(obj) - CLASS(DOF_), POINTER :: obj - !! dof_ object - INTEGER(I4B), INTENT(IN) :: tNodes(:) - !! total number of nodes for each dof - CHARACTER(1), INTENT(IN) :: Names(:) - !! name of each dof - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! space components for each dof - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time component for each dof - INTEGER(I4B), INTENT(IN) :: StorageFMT - !! storage format for dof - END FUNCTION obj_Constructor_1 -END INTERFACE DOF_Pointer - -!---------------------------------------------------------------------------- -! Deallocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: Oct 10, 2021 -! summary: Deallocate data in dof_ -! -!# Introduction -! -! This subroutine deallocates the data in DOF_ object - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE obj_Deallocate(obj) - CLASS(DOF_), INTENT(INOUT) :: obj - END SUBROUTINE obj_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE DOF_ConstructorMethods diff --git a/src/modules/DOF/src/DOF_GetMethods.F90 b/src/modules/DOF/src/DOF_GetMethods.F90 deleted file mode 100644 index a81bd982e..000000000 --- a/src/modules/DOF/src/DOF_GetMethods.F90 +++ /dev/null @@ -1,1595 +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 DOF_GetMethods -USE GlobalData, ONLY: DFP, I4B, LGT -USE BaseType, ONLY: DOF_ -IMPLICIT NONE -PRIVATE - -PUBLIC :: OPERATOR(.DOFStartIndex.) -PUBLIC :: OPERATOR(.DOFEndIndex.) -PUBLIC :: OPERATOR(.tNodes.) -PUBLIC :: OPERATOR(.tNames.) -PUBLIC :: OPERATOR(.tDOF.) -PUBLIC :: OPERATOR(.tspacecomponents.) -PUBLIC :: OPERATOR(.spacecomponents.) -PUBLIC :: OPERATOR(.timecomponents.) -PUBLIC :: OPERATOR(.ttimecomponents.) -PUBLIC :: OPERATOR(.EQ.) -PUBLIC :: OPERATOR(.NE.) -PUBLIC :: OPERATOR(.Names.) -PUBLIC :: GetIDOF -PUBLIC :: SIZE -PUBLIC :: GetNodeLoc -PUBLIC :: GetNodeLoc_ -PUBLIC :: GetIndex -PUBLIC :: GetIndex_ - -!---------------------------------------------------------------------------- -! DOFStartIndex@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: returns obj%map( ivar, 5 ) - -INTERFACE - MODULE PURE FUNCTION obj_DOFStartIndex(obj, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B) :: ans - END FUNCTION obj_DOFStartIndex -END INTERFACE - -INTERFACE OPERATOR(.DOFStartIndex.) - MODULE PROCEDURE obj_DOFStartIndex -END INTERFACE OPERATOR(.DOFStartIndex.) - -!---------------------------------------------------------------------------- -! DOFEndIndex@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: returns obj%map( ivar+1, 5 ) - 1 - -INTERFACE OPERATOR(.DOFEndIndex.) - MODULE PURE FUNCTION obj_DOFEndIndex(obj, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B) :: ans - END FUNCTION obj_DOFEndIndex -END INTERFACE - -!---------------------------------------------------------------------------- -! tNodes@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the total length of the vector - -INTERFACE Size - MODULE PURE FUNCTION obj_tNodes1(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_tNodes1 -END INTERFACE Size - -INTERFACE OPERATOR(.tNodes.) - MODULE PROCEDURE obj_tNodes1 -END INTERFACE - -!---------------------------------------------------------------------------- -! tNodes@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: This function returns the total number of nodes -! -!# Introduction -! -! This function returns the total number of nodes for a given degree of -! freedom number -! idof should be lesser than the total degree of freedom - -INTERFACE Size - MODULE PURE FUNCTION obj_tNodes2(obj, idof) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: idof - INTEGER(I4B) :: ans - END FUNCTION obj_tNodes2 -END INTERFACE Size - -INTERFACE OPERATOR(.tNodes.) - MODULE PROCEDURE obj_tNodes2 -END INTERFACE - -!---------------------------------------------------------------------------- -! tNodes@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: This function returns the total number of nodes -! -!# Introduction -! -! This function returns the total number of nodes for a given degree of -! freedom number -! idof should be lesser than the total degree of freedom - -INTERFACE Size - MODULE PURE FUNCTION obj_tNodes3(obj, varname) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: varname - INTEGER(I4B) :: ans - END FUNCTION obj_tNodes3 -END INTERFACE Size - -INTERFACE OPERATOR(.tNodes.) - MODULE PROCEDURE obj_tNodes3 -END INTERFACE - -!---------------------------------------------------------------------------- -! tNodes@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: This function returns the total number of nodes -! -!# Introduction -! -! This function returns the total number of nodes for a given degree of -! freedom number -! idof should be lesser than the total degree of freedom - -INTERFACE Size - MODULE PURE FUNCTION obj_tNodes4(obj, idof) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: idof(:) - INTEGER(I4B) :: ans - END FUNCTION obj_tNodes4 -END INTERFACE Size - -INTERFACE OPERATOR(.tNodes.) - MODULE PROCEDURE obj_tNodes4 -END INTERFACE - -!---------------------------------------------------------------------------- -! tDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: This function returns the total number of degree of freedom - -INTERFACE OPERATOR(.tDOF.) - MODULE PURE FUNCTION obj_tdof1(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_tdof1 -END INTERFACE - -!---------------------------------------------------------------------------- -! tDOF@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: This subroutine returns the total number of degrees of freedom -! -!# Introduction -! This function returns the total number of degrees of freedom in a -! physical variable. -! The physical variable is specified by using its name. - -INTERFACE OPERATOR(.tDOF.) - MODULE PURE FUNCTION obj_tdof2(obj, Name) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - CHARACTER(1), INTENT(IN) :: Name - INTEGER(I4B) :: ans - END FUNCTION obj_tdof2 -END INTERFACE - -!---------------------------------------------------------------------------- -! tDOF@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: This subroutine returns the total number of degrees of freedom -! -!# Introduction -! This function returns the total number of degrees of freedom in a -! physical variable. -! The physical variable is specified by using its name. - -INTERFACE OPERATOR(.tDOF.) - MODULE PURE FUNCTION obj_tdof3(obj, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B) :: ans - END FUNCTION obj_tdof3 -END INTERFACE - -!---------------------------------------------------------------------------- -! tDOF@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This subroutine returns the total number of degrees of freedom -! -!# Introduction -! This function returns the total number of degrees of freedom in a -! physical variable. -! The physical variable is specified by using its name. - -INTERFACE OPERATOR(.tDOF.) - MODULE PURE FUNCTION obj_tdof4(obj, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar(:) - INTEGER(I4B) :: ans - END FUNCTION obj_tdof4 -END INTERFACE - -!---------------------------------------------------------------------------- -! tNames@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the total number of names in dof object - -INTERFACE OPERATOR(.tNames.) - MODULE PURE FUNCTION obj_tNames(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_tNames -END INTERFACE - -!---------------------------------------------------------------------------- -! Names@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the name of all physical variables stored in obj - -INTERFACE OPERATOR(.Names.) - MODULE PURE FUNCTION obj_names1(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - CHARACTER(1), ALLOCATABLE :: ans(:) - END FUNCTION obj_names1 -END INTERFACE OPERATOR(.Names.) - -!---------------------------------------------------------------------------- -! Names@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: This function returns the name of a physical variable -! -!# Introduction -! -! This function returns the name of a physical variable -! The physical variable is given by its number ii, i.e., the first, second, -! third, and so on, physical variable. - -INTERFACE OPERATOR(.Names.) - MODULE PURE FUNCTION obj_names2(obj, ii) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ii - CHARACTER(1) :: ans - END FUNCTION obj_names2 -END INTERFACE OPERATOR(.Names.) - -!---------------------------------------------------------------------------- -! NameToIndex@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Return the index of a physical variable - -INTERFACE - MODULE PURE FUNCTION NameToIndex(obj, Name) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - CHARACTER(1), INTENT(IN) :: Name - INTEGER(I4B) :: ans - END FUNCTION NameToIndex -END INTERFACE - -!---------------------------------------------------------------------------- -! tspacecomponents@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: Returns the total physical variable which have space-compo - -INTERFACE OPERATOR(.tspacecomponents.) - MODULE PURE FUNCTION obj_tspacecomponents(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_tspacecomponents -END INTERFACE OPERATOR(.tspacecomponents.) - -!---------------------------------------------------------------------------- -! spacecomponents@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: Returns the space components of each physical vars - -INTERFACE OPERATOR(.spacecomponents.) - MODULE PURE FUNCTION obj_spacecomponents1(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION obj_spacecomponents1 -END INTERFACE OPERATOR(.spacecomponents.) - -!---------------------------------------------------------------------------- -! spacecomponents@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: Returns the space component of a given physical vars - -INTERFACE OPERATOR(.spacecomponents.) - MODULE PURE FUNCTION obj_spacecomponents2(obj, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B) :: ans - END FUNCTION obj_spacecomponents2 -END INTERFACE OPERATOR(.spacecomponents.) - -!---------------------------------------------------------------------------- -! ttimecomponents@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: Returns the total physical var which has time compo - -INTERFACE OPERATOR(.ttimecomponents.) - MODULE PURE FUNCTION obj_ttimecomponents(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_ttimecomponents -END INTERFACE OPERATOR(.ttimecomponents.) - -!---------------------------------------------------------------------------- -! timecomponents@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: Returns the timecompo - -INTERFACE OPERATOR(.timecomponents.) - MODULE PURE FUNCTION obj_timecomponents1(obj) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION obj_timecomponents1 -END INTERFACE OPERATOR(.timecomponents.) - -!---------------------------------------------------------------------------- -! timecomponents@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Oct 2021 -! summary: Returns the timecompo - -INTERFACE OPERATOR(.timecomponents.) - MODULE PURE FUNCTION obj_timecomponents2(obj, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B) :: ans - END FUNCTION obj_timecomponents2 -END INTERFACE OPERATOR(.timecomponents.) - -!---------------------------------------------------------------------------- -! EQ@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE OPERATOR(.EQ.) - MODULE PURE FUNCTION obj_isEqual(obj1, obj2) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj1 - TYPE(DOF_), INTENT(IN) :: obj2 - LOGICAL(LGT) :: ans - END FUNCTION obj_isEqual -END INTERFACE OPERATOR(.EQ.) - -!---------------------------------------------------------------------------- -! NE@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE OPERATOR(.NE.) - MODULE PURE FUNCTION obj_isNE(obj1, obj2) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj1 - TYPE(DOF_), INTENT(IN) :: obj2 - LOGICAL(LGT) :: ans - END FUNCTION obj_isNE -END INTERFACE OPERATOR(.NE.) - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get the idof from spacecompo, timecompo, tsapcecompo - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF1(spacecompo, timecompo, tspacecompo) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component - INTEGER(I4B), INTENT(IN) :: tspacecompo - !! total space component - INTEGER(I4B) :: ans - END FUNCTION obj_GetIDOF1 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get idof of a physical variable from space-time components - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF2(obj, ivar, spacecompo, timecompo) & - RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - INTEGER(I4B) :: ans - END FUNCTION obj_GetIDOF2 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get idof of physical variable from space and time components - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF3(obj, ivar, spacecompo, timecompo) & - RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time components of physical variable - INTEGER(I4B) :: ans(SIZE(timecompo)) - !! idof of each time component - END FUNCTION obj_GetIDOF3 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get idof of physical variable from space and time components - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF4(obj, ivar, spacecompo, timecompo) & - RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! several space components of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! a time component of a physical variable - INTEGER(I4B) :: ans(SIZE(spacecompo)) - !! idof of each space component - END FUNCTION obj_GetIDOF4 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get idof of from space and time components -! -!# Introduction -! -!@note -! This is an expert level routine and should be used with care. -!@endnote - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF5(spacecompo, timecompo, tspacecompo) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! several time components - INTEGER(I4B), INTENT(IN) :: tspacecompo - !! total time component - INTEGER(I4B) :: ans(SIZE(timecompo)) - !! idof of each time component - END FUNCTION obj_GetIDOF5 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get idof from space-time components -! -!# Introduction -! -!@note -! This is an expert level routine and should be used with care. -!@endnote - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF6(spacecompo, timecompo, tspacecompo) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! several space components - INTEGER(I4B), INTENT(IN) :: timecompo - !! a time component - INTEGER(I4B), INTENT(IN) :: tspacecompo - !! total space components - INTEGER(I4B) :: ans(SIZE(spacecompo)) - !! idof of each space component - END FUNCTION obj_GetIDOF6 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get idof of physical variable from its local idof -! -!# Introduction -! -! What is local idof and global idof? -! In this context, idof is local idof of a physical variable. -! ans is global idof of a physical variable's local idof. -! -! For example, consider velocity with 2 space-components and 1 time component. -! then Vx has local idof 1, Vy has local idof 2. -! But it may happen that Vx and Vy have different idof when they are stored in -! DOF object. - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF7(obj, ivar, idof) & - RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local idof of a physical variable - INTEGER(I4B) :: ans - !! global idof of a physical variable - END FUNCTION obj_GetIDOF7 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetIDOF@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get all idof of a physical variable - -INTERFACE GetIDOF - MODULE PURE FUNCTION obj_GetIDOF8(obj, ivar) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), ALLOCATABLE :: ans(:) - !! global idofs of all the dofs of a physical variable - END FUNCTION obj_GetIDOF8 -END INTERFACE GetIDOF - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node -! -!# Introduction -! -! - This routine is like [[DOF_Method:GetIndex]]. -! - It returns the location of degree of freedom number `idof` -! at node number `nodenum`. -! -!@note -! `nodenum` should be lesser than the total number of nodes -! defined for dof number `idof`. -!@endnote -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc1(obj, nodenum, idof) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof - INTEGER(I4B) :: ans - END FUNCTION obj_GetNodeLoc1 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node -! -!# Introduction -! -! - This routine is like [[DOF_Method:GetIndex]]. -! - It returns the location of degree of freedom number `idof` -! at node number `nodenum`. -! -!@note -! `nodenum` should be lesser than the total number of nodes -! defined for dof number `idof`. -!@endnote -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc2(obj, nodenum, idof) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - INTEGER(I4B) :: ans(SIZE(nodenum)) - !! location of nodenum - END FUNCTION obj_GetNodeLoc2 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get node location wihtout memory allocation - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_2(obj, nodenum, idof, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written in ans - END SUBROUTINE obj_GetNodeLoc_2 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node -! -!# Introduction -! -! - This routine is like [[DOF_Method:GetIndex]]. -! - It returns the location of degree of freedom number `idof` -! at node number `nodenum`. -! -!@note -! `nodenum` should be lesser than the total number of nodes -! defined for dof number `idof`. -!@endnote -! -!@note -! idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc3(obj, nodenum, idof) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: idof(:) - INTEGER(I4B) :: ans(SIZE(idof)) - END FUNCTION obj_GetNodeLoc3 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get node location wihtout memory allocation - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_3(obj, nodenum, idof, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: idof(:) - !! global degree of freedom number - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written in ans - END SUBROUTINE obj_GetNodeLoc_3 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of idof -! -!# Introduction -! -! This routine returns the location of degree of freedom number `idof` -! -! Note that in this routine we do not pass node number. -! -! ans(1) : istart -! ans(2) : iend -! ans(3) : stride -! -! In this way a given degree of freedom `idof` will be located in -! vec(istart:iend:stride). -! -!@note -! In DOF_ object, idofs are continuously numbered, so if there are two -! or more physical variables, then idof of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc4(obj, idof) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom in obj - INTEGER(I4B) :: ans(3) - !! ans(1) : istart - !! ans(2) : iend - !! ans(3) : stride - END FUNCTION obj_GetNodeLoc4 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node -! -!# Introduction -! -! In this routine we pass the physical variable number and -! the local degree of freedom number `idof` -! -! The `idof` will be converted to global degree of freedom number -! and then the location of the global degree of freedom number -! is returned - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc5(obj, nodenum, ivar, idof) & - RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom number of physical variable - INTEGER(I4B) :: ans - !! location of nodenum - END FUNCTION obj_GetNodeLoc5 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc6(obj, nodenum, ivar, idof) & - RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom number of physical variable - INTEGER(I4B) :: ans(SIZE(nodenum)) - !! returned location of nodenum - END FUNCTION obj_GetNodeLoc6 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_6(obj, nodenum, ivar, idof, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom number of physical variable - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! returned location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of data written in ans - END SUBROUTINE obj_GetNodeLoc_6 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc7(obj, nodenum, ivar, spacecompo, & - timecompo) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - INTEGER(I4B) :: ans - !! location of nodenum - END FUNCTION obj_GetNodeLoc7 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc8(obj, nodenum, ivar, spacecompo, & - timecompo) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - INTEGER(I4B) :: ans(SIZE(nodenum)) - !! location of nodenum - END FUNCTION obj_GetNodeLoc8 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_8(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE obj_GetNodeLoc_8 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc9(obj, nodenum, ivar, idof) & - RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof(:) - !! local degree of freedom number of physical variable - INTEGER(I4B) :: ans(SIZE(idof)) - !! location of nodenum - END FUNCTION obj_GetNodeLoc9 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_9(obj, nodenum, ivar, idof, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof(:) - !! local degree of freedom number of physical variable - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written in ans - END SUBROUTINE obj_GetNodeLoc_9 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc10(obj, nodenum, ivar, spacecompo, & - timecompo) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time components of physical variable - INTEGER(I4B) :: ans(SIZE(timecompo)) - !! location of nodenum - END FUNCTION obj_GetNodeLoc10 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_10(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time components of physical variable - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total data written in ans - END SUBROUTINE obj_GetNodeLoc_10 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc11(obj, nodenum, ivar, spacecompo, & - timecompo) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! several space components of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! a time component of a physical variable - INTEGER(I4B) :: ans(SIZE(spacecompo)) - !! returned location of nodenum - END FUNCTION obj_GetNodeLoc11 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_11(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! several space components of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! a time component of a physical variable - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! returned location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total data written in ans - END SUBROUTINE obj_GetNodeLoc_11 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc12(obj, nodenum, ivar, spacecompo, & - timecompo) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! a space component of a physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! several time components of a physical variable - INTEGER(I4B) :: ans(SIZE(timecompo) * SIZE(nodenum)) - !! returned location of nodenum - END FUNCTION obj_GetNodeLoc12 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_12(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! a space component of a physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! several time components of a physical variable - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! returned location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total data written in ans - END SUBROUTINE obj_GetNodeLoc_12 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 July 2021 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc - MODULE PURE FUNCTION obj_GetNodeLoc13(obj, nodenum, ivar, spacecompo, & - timecompo) RESULT(ans) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! several space components of a physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! a time component of a physical variable - INTEGER(I4B) :: ans(SIZE(spacecompo) * SIZE(nodenum)) - !! returned location of nodenum - END FUNCTION obj_GetNodeLoc13 -END INTERFACE GetNodeLoc - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_13(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! several space components of a physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! a time component of a physical variable - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! returned location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total data written in ans - END SUBROUTINE obj_GetNodeLoc_13 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-01 -! summary: This routine returns the location of node - -INTERFACE GetNodeLoc_ - MODULE PURE SUBROUTINE obj_GetNodeLoc_14(obj, nodenum, idof, ans, nrow, & - ncol, storageFMT) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(IN) :: idof(:) - !! physical variable number - INTEGER(I4B), INTENT(INOUT) :: ans(:, :) - !! returned location of nodenum - INTEGER(I4B), INTENT(OUT) :: nrow - !! number of rows written in ans - INTEGER(I4B), INTENT(OUT) :: ncol - !! number of cols written in ans - INTEGER(I4B), INTENT(IN) :: storageFMT - !! if storageFMT is NODES_FMT, then - !! nrow is size(idofs) and ncol is size(nodenum) - !! if storageFMT is DOF_FMT, then - !! nrow is size(nodenum) and ncol is size(idofs) - END SUBROUTINE obj_GetNodeLoc_14 -END INTERFACE GetNodeLoc_ - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! - This function returns indices, representing the location of all degrees -! of freedom define on a given node number. -! - The size of these indices is equal to the total number of DOF in obj -! - In this way, ans(ii) represents the location of ii dof at node number -! nodenum -! - It is user's responsibility to ensure that for every physical variable -! the `nodenumber` is lesser than the total number of -! nodes defined for that physical variable. -! - The returned indiced can be used to extract values from an instance of -! [[RealVector_]] or fortran vector of real numbers. -! -!@note -! The size of returned vector `ans` will be the total number of -! degrees of freedom in the [[DOF_]] object -!@endnote -! -!@note -! This routine calls GetNodeLoc -!@endnote - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex1(obj, nodenum) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), ALLOCATABLE :: ans(:) - !! location of nodenum - END FUNCTION obj_GetIndex1 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Get index without memory allocation - -INTERFACE GetIndex_ - MODULE PURE SUBROUTINE obj_GetIndex_1(obj, nodenum, ans, tsize) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written in ans - END SUBROUTINE obj_GetIndex_1 -END INTERFACE GetIndex_ - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! - This function returns indices, representing the locations of all the -! degrees of freedom of a given physical variable `ivar` at a given -! node number `nodenum` -! - The physical variable is defined by an `ivar` -! - The size of these indices is equal to the total number of DOF -! defined for the `ivar` physical variable. -! - It is user's responsibility to ensure that for the selected physical var -! the `nodenum` is lesser than the total number of -! nodes defined for that physical variable. -! -!@note -! This routine calls GetNodeLoc -!@endnote - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex2(obj, nodenum, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), ALLOCATABLE :: ans(:) - !! location of nodenum - END FUNCTION obj_GetIndex2 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! This method is same as obj_GetIndex2, -! but it does not allocate memory for ans. - -INTERFACE GetIndex_ - MODULE PURE SUBROUTINE obj_GetIndex_2(obj, nodenum, ivar, ans, tsize) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE obj_GetIndex_2 -END INTERFACE GetIndex_ - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! Same as obj_GetIndex2, but physical variable is selected by -! it name. - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex3(obj, nodenum, varname) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - CHARACTER(1), INTENT(IN) :: varname - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION obj_GetIndex3 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! - This function returns indices, representing the location of all the -! degrees of freedom defined at node numbers specified by nodenum. -! - The size of these indices is equal to the total number of DOF in obj -! times the size of nodenum(:) -! -!@note -! The returned indices has same storage pattern as the DOF object -!@endnote - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex4(obj, nodenum) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), ALLOCATABLE :: ans(:) - !! location of nodenum - END FUNCTION obj_GetIndex4 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Returns the indices for node number `nodenum` - -INTERFACE GetIndex_ - MODULE PURE SUBROUTINE obj_GetIndex_4(obj, nodenum, ans, tsize) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total data written in ans - END SUBROUTINE obj_GetIndex_4 -END INTERFACE GetIndex_ - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! - This function returns indices, representing the location of all the -! degrees of freedom of physical variable given by ivar, at nodes given in -! nodenum. -! - The physical variable is defined by an `ivar` -! - The size of these indices is equal to the total number of DOF -! defined for the `ivar` physical variable times the size of nodenum. - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex5(obj, nodenum, ivar) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), ALLOCATABLE :: ans(:) - !! location of nodenum - END FUNCTION obj_GetIndex5 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! This method is same as obj_GetIndex5, but it does not allocate memory -! for ans. - -INTERFACE GetIndex_ - MODULE PURE SUBROUTINE obj_GetIndex_5(obj, nodenum, ivar, ans, tsize) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(INOUT) :: ans(:) - !! location of nodenum - INTEGER(I4B), INTENT(OUT) :: tsize - !! total data written in ans - END SUBROUTINE obj_GetIndex_5 -END INTERFACE GetIndex_ - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the indices for node number `nodenum` -! -!# Introduction -! -! - This function returns a vector of integers (indices) for a -! a given node number and a given physical Variable. -! - The physical variable is defined by an `varname` -! - The size of these indices is equal to the total number of DOF -! defined for the `varname` physical variable. -! - The returned indices represents the degrees of freedom of -! physical variable `varname` defined on each node. -! - It is user's responsibility to ensure that for the selected physical var -! the `nodenumber` is lesser than the total number of -! nodes defined for that physical variable. -! - The returned indices can be used for Getting the dof (all dof) -! defined on the nodenum for the given physical variable. -! - The returned indices can be used to extract values from an instance of -! [[RealVector_]] or fortran vector of real numbers. - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex6(obj, nodenum, varname) RESULT(ans) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - CHARACTER(1), INTENT(IN) :: varname - !! variable name - INTEGER(I4B), ALLOCATABLE :: ans(:) - !! location of nodenum - END FUNCTION obj_GetIndex6 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PROCEDURE obj_GetNodeLoc5 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PROCEDURE obj_GetNodeLoc6 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PROCEDURE obj_GetNodeLoc7 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PROCEDURE obj_GetNodeLoc8 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -INTERFACE GetIndex_ - MODULE PROCEDURE obj_GetNodeLoc_6 -END INTERFACE GetIndex_ - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -INTERFACE GetIndex_ - MODULE PROCEDURE obj_GetNodeLoc_8 -END INTERFACE GetIndex_ - -END MODULE DOF_GetMethods diff --git a/src/modules/DOF/src/DOF_GetValueMethods.F90 b/src/modules/DOF/src/DOF_GetValueMethods.F90 deleted file mode 100644 index c017ca256..000000000 --- a/src/modules/DOF/src/DOF_GetValueMethods.F90 +++ /dev/null @@ -1,384 +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 DOF_GetValueMethods -USE GlobalData, ONLY: DFP, I4B, LGT -USE BaseType, ONLY: DOF_ -IMPLICIT NONE - -PRIVATE - -PUBLIC :: GetValue -PUBLIC :: GetValue_ -PUBLIC :: Get - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_GetValue1(v, val, obj, idof, storageFMT, & - nodenum) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: v(:) - !! values to return - REAL(DFP), INTENT(IN) :: val(:) - !! values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof(:) - !! degrees of freedom to extract - INTEGER(I4B), INTENT(IN) :: storageFMT - !! storage format of returned vector - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers to extract - END SUBROUTINE obj_GetValue1 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a 2D array -! -!# Introduction -! This subroutine extracts all the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V(:,:)` -! values in `v(:,:)` are stored in xiJ format. -! -! - Force3D will return a vector in 3D. if there are only two components -! then it will set the third component to 0 -! - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_GetValue2(v, val, obj, idof, force3D) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: v(:, :) - REAL(DFP), INTENT(IN) :: val(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: idof(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D - END SUBROUTINE obj_GetValue2 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values of from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_GetValue3(v, val, obj, idof, storageFMT) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: v(:) - REAL(DFP), INTENT(IN) :: val(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: idof(:) - INTEGER(I4B), INTENT(IN) :: storageFMT - END SUBROUTINE obj_GetValue3 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION obj_get1(val, obj, idof, StorageFMT, nodenum, & - Force3D) RESULT(ans) - REAL(DFP), INTENT(IN) :: val(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: idof(:) - INTEGER(I4B), INTENT(IN) :: StorageFMT - INTEGER(I4B), INTENT(IN) :: nodenum(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_get1 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION obj_get2(val, obj, idof, StorageFMT, & - Force3D) RESULT(ans) - REAL(DFP), INTENT(IN) :: val(:) - TYPE(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: idof(:) - INTEGER(I4B), INTENT(IN) :: StorageFMT - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_get2 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! -! This subroutine is same as GetValue1 -! but it does not allocate any extra memory - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_1(v, tsize, val, obj, idof, storageFMT, & - nodenum) - REAL(DFP), INTENT(INOUT) :: v(:) - !! values to return - INTEGER(I4B), INTENT(OUT) :: tsize - !! size of data written in v - REAL(DFP), INTENT(IN) :: val(:) - !! values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof(:) - !! degrees of freedom to extract - INTEGER(I4B), INTENT(IN) :: storageFMT - !! storage format of returned vector - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers to extract - END SUBROUTINE obj_GetValue_1 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a 2D array -! -!# Introduction -! -! This subroutine is same as GetValue2 but -! it does not allocate any extra memory - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_2(v, val, nrow, ncol, obj, idof, force3D) - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! Data to be returned - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written in v - REAL(DFP), INTENT(IN) :: val(:) - !! values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object for val - INTEGER(I4B), INTENT(IN) :: idof(:) - !! degrees of freedom to extract - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D - !! if true then return 3D vector - END SUBROUTINE obj_GetValue_2 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! -! This subroutine is same as GetValue3 but -! it does not allocate any extra memory - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_3(v, tsize, val, obj, idof, storageFMT) - REAL(DFP), INTENT(INOUT) :: v(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! size of data written in v - REAL(DFP), INTENT(IN) :: val(:) - !! values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof(:) - !! degrees of freedom to extract - INTEGER(I4B), INTENT(IN) :: storageFMT - !! stroage format of returned vector - END SUBROUTINE obj_GetValue_3 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Returns the values -! -!# Introduction -! -! This routine performs following operations without extra memory allocation -! index = obj_GetIndex1(obj, nodenum) -! v = val(index) - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_4(v, tsize, val, obj, nodenum) - REAL(DFP), INTENT(INOUT) :: v(:) - !! Values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! Size of data written in v - REAL(DFP), INTENT(IN) :: val(:) - !! Values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! Degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! Node number to extract - END SUBROUTINE obj_GetValue_4 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Returns the values -! -!# Introduction -! -! This routine performs following operations without extra memory allocation -! index = obj_GetIndex2(obj, nodenum, ivar) -! v = val(index) - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_5(v, tsize, val, obj, nodenum, ivar) - REAL(DFP), INTENT(INOUT) :: v(:) - !! Values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! Size of data written in v - REAL(DFP), INTENT(IN) :: val(:) - !! Values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! Degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! Node number to extract - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable numbers - END SUBROUTINE obj_GetValue_5 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-26 -! summary: Returns the values -! -!# Introduction -! -! This routine performs following operations without extra memory allocation -! index = obj_GetIndex4(obj, nodenum) -! v = val(index) - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_6(v, tsize, val, obj, nodenum) - REAL(DFP), INTENT(INOUT) :: v(:) - !! Values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! Size of data written in v - REAL(DFP), INTENT(IN) :: val(:) - !! Values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! Degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! Node number to extract - END SUBROUTINE obj_GetValue_6 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_7(v, tsize, val, obj, idof, nodenum) - REAL(DFP), INTENT(INOUT) :: v(:) - !! values to return - INTEGER(I4B), INTENT(OUT) :: tsize - !! size of data written in v - REAL(DFP), INTENT(IN) :: val(:) - !! values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof - !! global degrees of freedom to extract - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers to extract - END SUBROUTINE obj_GetValue_7 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector - -INTERFACE GetValue_ - MODULE PURE SUBROUTINE obj_GetValue_8(v, tsize, val, obj, idof, isidof) - REAL(DFP), INTENT(INOUT) :: v(:) - !! values to return - INTEGER(I4B), INTENT(OUT) :: tsize - !! size of data written in v - REAL(DFP), INTENT(IN) :: val(:) - !! values to extract from - TYPE(DOF_), INTENT(IN) :: obj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof - !! global degrees of freedom to extract - LOGICAL(LGT), INTENT(IN) :: isidof - !! This variable is not used, it here to create unique interface - !! otherwise it conflicts with obj_GetValue_4 - END SUBROUTINE obj_GetValue_8 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE DOF_GetValueMethods diff --git a/src/modules/DOF/src/DOF_IOMethods.F90 b/src/modules/DOF/src/DOF_IOMethods.F90 deleted file mode 100644 index fee5e0a80..000000000 --- a/src/modules/DOF/src/DOF_IOMethods.F90 +++ /dev/null @@ -1,111 +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 DOF_IOMethods -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 June 2021 -! summary: Display content of [[dof_]] - -INTERFACE - MODULE SUBROUTINE dof_Display1(obj, msg, UnitNo) - CLASS(DOF_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: UnitNo - END SUBROUTINE dof_Display1 -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE dof_Display1 -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 June 2021 -! summary: Display content of fortran vec with [[DOF_]] object info -! -! -!## Usage -! -!```fortran -! ! [[DOF_]] -! PROGRAM main -! USE easifemBase -! IMPLICIT NONE -! TYPE( DOF_ ) :: obj -! REAL( DFP ), ALLOCATABLE :: val( : ) -! ! main -! ! #DOF/Initiate -! CALL Initiate( obj, tNodes=[10], names=["U"], spacecompo=[3], & -! & timecompo=[1], storageFMT = FMT_DOF ) -! ! #DOF/Initiate -! CALL Initiate( Val=val, obj=obj ) -! val(1:10) = 1; val(11:20)=2; val(21:)=3 -! CALL Display( Val, obj, "CALL Initiate( Val=val, obj=obj ) : " ) -! ! #DOF/Deallocate -! CALL Deallocate( obj ) -! END PROGRAM main -!``` - -INTERFACE - MODULE SUBROUTINE dof_Display2(Vec, obj, msg, unitno) - REAL(DFP), INTENT(IN) :: Vec(:) - CLASS(DOF_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - END SUBROUTINE dof_Display2 -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE dof_Display2 -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 June 2021 -! summary: Display content of fortran vec with [[DOF_]] object info - -INTERFACE - MODULE SUBROUTINE dof_Display3(Vec, obj, msg, unitno) - CLASS(RealVector_), INTENT(IN) :: Vec - CLASS(DOF_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - END SUBROUTINE dof_Display3 -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE dof_Display3 -END INTERFACE Display - -END MODULE DOF_IOMethods diff --git a/src/modules/DOF/src/DOF_Method.F90 b/src/modules/DOF/src/DOF_Method.F90 deleted file mode 100644 index 8f22fab1c..000000000 --- a/src/modules/DOF/src/DOF_Method.F90 +++ /dev/null @@ -1,31 +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: 23 Feb 2021 -! summary: This module contains methods of [[DOF_]] object -! -!{!pages/docs-api/DOF/DOF_.md!} - -MODULE DOF_Method -USE DOF_ConstructorMethods -USE DOF_IOMethods -USE DOF_GetMethods -USE DOF_GetValueMethods -USE DOF_SetMethods -USE DOF_AddMethods -END MODULE DOF_Method diff --git a/src/modules/DOF/src/DOF_SetMethods.F90 b/src/modules/DOF/src/DOF_SetMethods.F90 deleted file mode 100644 index a5412556f..000000000 --- a/src/modules/DOF/src/DOF_SetMethods.F90 +++ /dev/null @@ -1,464 +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 DOF_SetMethods -USE GlobalData, ONLY: DFP, I4B, LGT -USE BaseType, ONLY: DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Set values in a vector of real numbers -! -!# Introduction -! -! - This subroutine is designed to Set the values in a vector of real number -! - This subroutine effectivily performes `vec( nptrs ) = value` -! - If `SIZE(value)==1` then all values are Set to `value(1)` -! - If `SIZE(value) .EQ. SIZE(nptrs)` then, each dof is Set to value -! - If `SIZE(value)=tDOF*Size(nptrs)` then each dof is Set to appropriate -! value from value - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set1(vec, obj, nodenum, VALUE, conversion) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set - INTEGER(I4B), INTENT(IN) :: conversion(1) - !! DOFToNodes - !! NodesTODOF - !! None - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of all dof defined inside `obj`. - !! The storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. - END SUBROUTINE obj_Set1 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Set values in a vector of real numbers - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set2(vec, obj, nodenum, VALUE) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - END SUBROUTINE obj_Set2 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers -! -!# Introduction -! -! - This subroutine is designed to Set the values in a array of real number. -! - This subroutine handles only those entries which belongs to the -! dofno. -! - This subroutine effectivily performes `vec( nptrs ) = value` -! - If the size of value is not equal to 1, then the size of nptrs should be -! same as the size of value -! -!@note -! In [[DOF_]], dofno are continuously numbered, so if there are two -! or more physical variables, then dofno of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set3(vec, obj, nodenum, VALUE, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom in obj - END SUBROUTINE obj_Set3 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set4(vec, obj, nodenum, VALUE, ivar, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Set4 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set5(vec, obj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - END SUBROUTINE obj_Set5 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set6(vec, obj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time components of physical variables - END SUBROUTINE obj_Set6 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set7(vec, obj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - REAL(DFP), INTENT(IN) :: VALUE(:) - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! space components of physical variables - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - END SUBROUTINE obj_Set7 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Set values in a vector of real numbers - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set8(vec, obj, nodenum, VALUE) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node to set - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - END SUBROUTINE obj_Set8 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers -! -!# Introduction -! -! - This subroutine is designed to Set the values in a array of real number. -! - This subroutine handles only those entries which belongs to the -! dofno. -! - This subroutine effectivily performes `vec( nptrs ) = value` -! - If the size of value is not equal to 1, then the size of nptrs should be -! same as the size of value -! -!@note -! In [[DOF_]], dofno are continuously numbered, so if there are two -! or more physical variables, then dofno of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set9(vec, obj, nodenum, VALUE, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! Object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - REAL(DFP), INTENT(IN) :: VALUE - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom in obj - END SUBROUTINE obj_Set9 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers -! -!# Introduction -! -! - This subroutine is designed to Set the values in a array of real number. -! - This subroutine handles only those entries which belongs to the -! dofno. -! - This subroutine effectivily performes `vec( nptrs ) = value` -! - If the size of value is not equal to 1, then the size of nptrs should be -! same as the size of value -! -!@note -! In [[DOF_]], dofno are continuously numbered, so if there are two -! or more physical variables, then dofno of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set10(vec, obj, nodenum, VALUE, ivar, idof) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - REAL(DFP), INTENT(IN) :: VALUE - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom in physical variable - END SUBROUTINE obj_Set10 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers -! -!# Introduction -! -! - This subroutine is designed to Set the values in a array of real number. -! - This subroutine handles only those entries which belongs to the -! dofno. -! - This subroutine effectivily performes `vec( nptrs ) = value` -! - If the size of value is not equal to 1, then the size of nptrs should be -! same as the size of value -! -!@note -! In [[DOF_]], dofno are continuously numbered, so if there are two -! or more physical variables, then dofno of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set11(vec, obj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - REAL(DFP), INTENT(IN) :: VALUE - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - END SUBROUTINE obj_Set11 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers -! -!# Introduction -! -! - This subroutine is designed to Set the values in a array of real number. -! - This subroutine handles only those entries which belongs to the -! dofno. -! - This subroutine effectivily performes `vec( nptrs ) = value` -! - If the size of value is not equal to 1, then the size of nptrs should be -! same as the size of value -! -!@note -! In [[DOF_]], dofno are continuously numbered, so if there are two -! or more physical variables, then dofno of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set12(vec, obj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - REAL(DFP), INTENT(IN) :: VALUE - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time components of physical variables - END SUBROUTINE obj_Set12 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: Set values in a vector of real numbers -! -!# Introduction -! -! - This subroutine is designed to Set the values in a array of real number. -! - This subroutine handles only those entries which belongs to the -! dofno. -! - This subroutine effectivily performes `vec( nptrs ) = value` -! - If the size of value is not equal to 1, then the size of nptrs should be -! same as the size of value -! -!@note -! In [[DOF_]], dofno are continuously numbered, so if there are two -! or more physical variables, then dofno of the second or later physical -! variables will not start from 1. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set13(vec, obj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - REAL(DFP), INTENT(INOUT) :: vec(:) - CLASS(DOF_), INTENT(IN) :: obj - !! object `obj` contains the storage pattern of degrees of freedom - !! inside `vec`. - !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - REAL(DFP), INTENT(IN) :: VALUE - !! `value` denotes the nodal values of dof `idof`. - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! space components of physical variables - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component of physical variable - END SUBROUTINE obj_Set13 -END INTERFACE Set - -END MODULE DOF_SetMethods diff --git a/src/modules/DiffusionMatrix/CMakeLists.txt b/src/modules/DiffusionMatrix/CMakeLists.txt deleted file mode 100644 index b13d43c1c..000000000 --- a/src/modules/DiffusionMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/DiffusionMatrix_Method.F90 -) diff --git a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 deleted file mode 100644 index dfa236fbd..000000000 --- a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 +++ /dev/null @@ -1,577 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE DiffusionMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! If opt is not present. -! -! $$ -! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}\frac{\partial N^{J}} -! {\partial x_{i}}d\Omega -! $$ -! -! If opt is present. -! -! $$ -! \left[M\right]_{IJ}^{ij}=\delta_{ij}\int\frac{\partial N^{I}} -! {\partial x_{k}}\frac{\partial N^{J}}{\partial x_{k}}d\Omega -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_1(test, trial, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_1 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_1 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! M(I,J)=\int\rho\frac{\partial N^{I}}{\partial x_{i}}\frac{\partial N^{J}} -! {\partial x_{i}}d\Omega -! $$ -! - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_2(test, trial, k, krank, opt) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! scalar - TYPE(FEVariableScalar_), INTENT(IN) :: krank - !! scalar fe variable - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_2 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_2 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}v_{i}v_{j} -! \frac{\partial N^{J}}{\partial x_{j}}d\Omega -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_3(test, trial, k, krank, opt) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! vector - TYPE(FEVariableVector_), INTENT(IN) :: krank - !! vector - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_3 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_3 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}k_{ij} -! \frac{\partial N^{J}}{\partial x_{j}}d\Omega -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_4(test, trial, k, krank, opt) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! matrix - TYPE(FEVariableMatrix_), INTENT(IN) :: krank - !! matrix - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_4 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_4 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}u_{i}v_{j} -! \frac{\partial N^{J}}{\partial x_{j}}d\Omega -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_5(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Scalar - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - !! Scalar - TYPE(FEVariableScalar_), INTENT(IN) :: c2rank - !! Scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_5 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_5 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! M(I,J)=\int\rho\frac{\partial N^{I}}{\partial x_{i}}k_{ij} -! \frac{\partial N^{J}}{\partial x_{j}}d\Omega -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_6(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - !! Scalar - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! Vector - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_6 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_6 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! M(I,J)=\int\rho_{1}\frac{\partial N^{I}}{\partial x_{i}}k_{ij} -! \frac{\partial N^{J}}{\partial x_{j}}d\Omega -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_7(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Matrix - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - !! Scalar - TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank - !! Matrix - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_7 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_7 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_8(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Vector - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Scalar - TYPE(FEVariableVector_), INTENT(IN) :: c1rank - !! Vector - TYPE(FEVariableScalar_), INTENT(IN) :: c2rank - !! Scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_8 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_8 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_9(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Vector - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector - TYPE(FEVariableVector_), INTENT(IN) :: c1rank - !! Vector - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! Vector - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_9 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_9 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_10(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Vector - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Matrix - TYPE(FEVariableVector_), INTENT(IN) :: c1rank - !! Vector - TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank - !! Matrix - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_10 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_10 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_11(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Matrix - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Scalar - TYPE(FEVariableMatrix_), INTENT(IN) :: c1rank - !! Matrix - TYPE(FEVariableScalar_), INTENT(IN) :: c2rank - !! Scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_11 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_11 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_12(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Matrix - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector - TYPE(FEVariableMatrix_), INTENT(IN) :: c1rank - !! Matrix - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! Vector - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_12 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_12 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_13(test, trial, c1, c2, c1rank, & - & c2rank, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Matrix - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Matrix - TYPE(FEVariableMatrix_), INTENT(IN) :: c1rank - !! Matrix - TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank - !! Matrix - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_13 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_13 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 May 2022 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! If opt is [1] then: -! -! $$ -! \left[M\right]_{IJ}^{ij}=\int\frac{\partial N^{I}}{\partial x_{i}} -! \frac{\partial N^{J}}{\partial x_{j}}d\Omega -! $$ -! -! If opt is [2] then: -! -! $$ -! \left[M\right]_{IJ}^{ij}=\int\frac{\partial N^{I}}{\partial x_{j}} -! \frac{\partial N^{J}}{\partial x_{i}}d\Omega -! $$ - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_14(test, trial, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - INTEGER(I4B), INTENT(IN) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_14 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_14 -END INTERFACE DiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine returns the diffusion matrix in space domain -! -!# Introduction -! -! $$ -! M(I,J)=\int\rho\frac{\partial N^{I}}{\partial x_{i}}\frac{\partial N^{J}} -! {\partial x_{i}}d\Omega -! $$ -! - -INTERFACE - MODULE PURE FUNCTION DiffusionMatrix_15(test, trial, k, krank, opt) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! scalar - TYPE(FEVariableScalar_), INTENT(IN) :: krank - !! scalar fe variable - INTEGER(I4B), INTENT(IN) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION DiffusionMatrix_15 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_15 -END INTERFACE DiffusionMatrix - -END MODULE DiffusionMatrix_Method diff --git a/src/modules/Display/CMakeLists.txt b/src/modules/Display/CMakeLists.txt deleted file mode 100644 index 31c9f7d76..000000000 --- a/src/modules/Display/CMakeLists.txt +++ /dev/null @@ -1,26 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/disp/disp_i1mod.F90 - ${src_path}/disp/disp_i2mod.F90 - ${src_path}/disp/disp_i4mod.F90 - ${src_path}/disp/disp_i8mod.F90 - ${src_path}/disp/disp_l1mod.F90 - ${src_path}/disp/disp_r4mod.F90 - ${src_path}/disp/disp_r8mod.F90 - ${src_path}/disp/disp_r16mod.F90 - ${src_path}/disp/disp_charmod.F90 - ${src_path}/disp/dispmodule_util.F90 - ${src_path}/disp/dispmodule.F90 - ${src_path}/disp/putstrmodule.F90 - ${src_path}/Display_Method.F90 -) \ No newline at end of file diff --git a/src/modules/Display/src/Display_Mat2.inc b/src/modules/Display/src/Display_Mat2.inc deleted file mode 100644 index a26013cde..000000000 --- a/src/modules/Display/src/Display_Mat2.inc +++ /dev/null @@ -1,68 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -INTEGER(I4B) :: I - -LOGICAL(LGT) :: full_ -INTEGER(I4B) :: ii, ff, mm, nn -CHARACTER(3) :: orient_ - -CALL setDefaultSettings -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 - -! 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" -! END IF -orient_ = "row" - -mm = SIZE(val, 1) -nn = SIZE(val, 2) -IF (full_ .OR. mm .LE. (minRow + minRow) .OR. (nn .LE. (minCol + minCol))) 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, advance=advance) -#else - CALL DISP(title=msg, x=val, unit=I, advance=advance) -#endif -ELSE - CALL Disp(title=msg, unit=I, advance="YES") - CALL DISP(title="", x=val(1:minRow, 1:minCol), unit=I, advance="NO") - CALL Display("...", unitNo=I, advance=.FALSE.) - CALL DISP(title="", x=val(1:minRow, nn-minCol+1:nn), unit=I, advance="YES") - CALL Display("."//CHAR_LF//"."//CHAR_LF//".", unitNo=I, advance=.TRUE.) -CALL DISP(title="", x=val(mm - minRow + 1:mm, 1:minCol), unit=I, advance="NO") - CALL Display("...", unitNo=I, advance=.FALSE.) - CALL DISP(title="", x=val(mm-minRow+1:mm, nn-minCol+1:nn), unit=I, advance=advance) -END IF diff --git a/src/modules/Display/src/Display_Mat3.inc b/src/modules/Display/src/Display_Mat3.inc deleted file mode 100644 index ed9459fb4..000000000 --- a/src/modules/Display/src/Display_Mat3.inc +++ /dev/null @@ -1,24 +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 internal variables -INTEGER(I4B) :: J -DO J = 1, SIZE(Val, 3) - CALL Display(val=Val(:, :, J), & - & msg=TRIM(msg)//"( :, :, "//TRIM(Int2Str(J))//" ) = ", & - & unitNo=unitNo, full=full, advance=advance) -END DO diff --git a/src/modules/Display/src/Display_Mat4.inc b/src/modules/Display/src/Display_Mat4.inc deleted file mode 100644 index 4ac83233e..000000000 --- a/src/modules/Display/src/Display_Mat4.inc +++ /dev/null @@ -1,31 +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 internal variables -INTEGER(I4B) :: J, K -DO K = 1, SIZE(Val, 4) - DO J = 1, SIZE(Val, 3) - CALL Display(Val=Val(:, :, J, K), & - & msg=TRIM(msg) & - & //"( :, :, " & - & //TRIM(Int2Str(J)) & - & //", " & - & //TRIM(Int2Str(K)) & - & //" ) = " & - & , unitNo=unitNo, full=full, advance=advance) - END DO -END DO diff --git a/src/modules/Display/src/Display_Method.F90 b/src/modules/Display/src/Display_Method.F90 deleted file mode 100755 index 2a7fd7d35..000000000 --- a/src/modules/Display/src/Display_Method.F90 +++ /dev/null @@ -1,1712 +0,0 @@ -! ploDataElem is a post-processing software for T+H (TOUGH HYDRATE) program. -! It reads plot_data_elem file generated by T+H simulations and converts them -! vtu format. Which can then be visualized by usign PARAVIEW and other -! softwares. -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General 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: Dr. Vikas Sharma -! -! [[Display_Method]] module consists small routines related -! to displaying the fortran variables on the screen - -MODULE Display_Method -USE GlobalData -USE DISPMODULE -USE FACE -IMPLICIT NONE -PRIVATE -INTEGER(I4B), PARAMETER :: minRow = 4, minCol = 4 -PUBLIC :: Display, BlankLines, DashLine -PUBLIC :: DotLine, EqualLine -PUBLIC :: TIMESTAMP -PUBLIC :: setDisplayProfile -PUBLIC :: ToString, DISP !! from DISPMODULE - -CHARACTER(*), PARAMETER :: equal = "==============================" -CHARACTER(*), PARAMETER :: dot = ".............................." -CHARACTER(*), PARAMETER :: dash = "------------------------------" -CHARACTER(*), PARAMETER :: COLOR_FG = "CYAN" -CHARACTER(*), PARAMETER :: COLOR_BG = "BLACK" -CHARACTER(*), PARAMETER :: COLOR_STYLE = "BOLD_ON" - -TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: & - & DisplayProfileTerminal = DISP_SETTINGS(& - & advance="YES", matsep=",", orient="COL", style="UNDERLINE", & - & trim="FALSE", ZEROAS=".") - -TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: & - & DisplayProfilePrint = DISP_SETTINGS(& - & advance="YES", matsep=",", orient="COL", style="UNDERLINE", & - & trim="FALSE", ZEROAS="") - -TYPE(DISP_SETTINGS), PARAMETER :: DisplayProfileOriginal = DISP_SETTINGS() -LOGICAL(LGT) :: defaultSettingSet = .FALSE. - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -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 -END INTERFACE - -CONTAINS - -!---------------------------------------------------------------------------- -! setDefaultSetting -!---------------------------------------------------------------------------- - -SUBROUTINE setDefaultSettings - IF (defaultSettingSet) THEN - RETURN - ELSE - CALL DISP_SET(DisplayProfileTerminal) - defaultSettingSet = .TRUE. - END IF -END SUBROUTINE setDefaultSettings - -!---------------------------------------------------------------------------- -! setDisplayProfile -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This routine sets the display profile - -SUBROUTINE setDisplayProfile(DispProfile, advance, digmax, & - & matsep, orient, sep, style, unit, zeroas) - TYPE(DISP_SETTINGS), INTENT(IN) :: DispProfile - !! An instance of Display settings - !! It can be DisplayProfileTerminal, DisplayProfilePrint - !! - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance - !! "NO", stay on the same line - !! "YES", advance to the next line, default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: digmax - !! Number of significant digits to show for X-element of largest - !! absolute magnitude - CHARACTER(*), OPTIONAL, INTENT(IN) :: matsep - !! - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - !! "ROW" display vector as row - !! "COL" display vector as column, default - CHARACTER(*), OPTIONAL, INTENT(IN) :: sep - !! String used to separate matrix column - CHARACTER(*), OPTIONAL, INTENT(IN) :: style - !! "LEFT", default - !! "ABOVE" - !! "PAD" - !! "UNDERLINE" - !! "NUMBER" - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unit - !! External file unit to send output to (stdout is default) - CHARACTER(*), OPTIONAL, INTENT(IN) :: zeroas - !! String to display instead of zeros - !> internal variables - CALL DISP_SET(DispProfile) - CALL DISP_SET(advance=advance, digmax=digmax, matsep=matsep, & - & orient=orient, sep=sep, style=style, unit=unit, zeroas=zeroas) -END SUBROUTINE setDisplayProfile - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine Displays the string -! -!# Introduction -! This routine displays a string -! -!## usage -!```fortran -! CALL Display( msg="hello world", unitno=stdout ) -!``` - -SUBROUTINE Display_Str(msg, unitno, advance) - ! Dummt arguments - CHARACTER(*), INTENT(IN) :: msg - !! input message - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - !! unit no - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: advance - ! Internal variables - INTEGER(I4B) :: i - CHARACTER(:), ALLOCATABLE :: advance0 - LOGICAL(LGT) :: bool1 - - CALL setDefaultSettings - - i = stdout; IF (PRESENT(unitno)) i = unitno - bool1 = .TRUE.; IF (PRESENT(advance)) bool1 = advance - - IF (bool1) THEN - advance0 = "YES" - ELSE - advance0 = "NO" - END IF - -#ifdef COLOR_DISP - CALL DISP(title="", & - & x=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, & - & style=COLOR_STYLE)), & - & FMT='a', unit=i, style="left", & - & advance=advance0) -#else - CALL DISP(title="", x=msg, FMT='a', unit=i, style="left", & - & advance=advance0) -#endif -END SUBROUTINE Display_Str - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This routine prints a string; msg=val -! -!# Introduction -! -! This routine prints a string; msg=val -! -!## Usage -!```fortran -! CALL Display( val=" world!", msg="hello", stdout) -!``` - -SUBROUTINE Display_Str2(val, msg, unitno, advance) - CHARACTER(*), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: advance - CALL Display(msg=TRIM(msg)//TRIM(val), unitNo=unitNo, advance=advance) -END SUBROUTINE Display_Str2 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar real number -! -!# Introduction -! -! This subroutine display a scalar real number -! -!## Usage -! -!```fortran -! call display( val=1.0_DFP, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Real64(val, msg, unitNo, advance) - ! Define intent of dummy variables - REAL(REAL64), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Real64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar real number -! -!# Introduction -! -! This subroutine display a scalar real number -! -!## Usage -! -!```fortran -! call display( val=1.0_DFP, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Real32(val, msg, unitNo, advance) - ! Define intent of dummy variables - REAL(REAL32), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Real32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine displays a scalar complex number -! -!## Usage -! -!```fortran -! call display( val=CMPLX(1.0_DFP, 1.0_DFP), msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Cmplx64(val, msg, unitNo, advance) - ! Define intent of dummy variables - COMPLEX(DPC), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Cmplx64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine displays a scalar complex number -! -!## Usage -! -!```fortran -! call display( val=CMPLX(1.0_DFP, 1.0_DFP), msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Cmplx32(val, msg, unitNo, advance) - ! Define intent of dummy variables - COMPLEX(SPC), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Cmplx32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar integer number -! -!# Introduction -! -! This subroutine display a scalar integer number -! -!## Usage -! -!```fortran -! call display( val=1.0_I4B, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Int64(val, msg, unitNo, advance) - ! Define intent of dummy variables - INTEGER(INT64), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Int64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar integer number -! -!# Introduction -! -! This subroutine display a scalar integer number -! -!## Usage -! -!```fortran -! call display( val=1.0_I4B, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Int32(val, msg, unitNo, advance) - ! Define intent of dummy variables - INTEGER(INT32), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Int32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar integer number -! -!# Introduction -! -! This subroutine display a scalar integer number -! -!## Usage -! -!```fortran -! call display( val=1.0_I4B, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Int16(val, msg, unitNo, advance) - ! Define intent of dummy variables - INTEGER(INT16), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Int16 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar integer number -! -!# Introduction -! -! This subroutine display a scalar integer number -! -!## Usage -! -!```fortran -! call display( val=1.0_I4B, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Int8(val, msg, unitNo, advance) - ! Define intent of dummy variables - INTEGER(INT8), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" -END SUBROUTINE Display_Int8 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar logical variable -! -!# Introduction -! -! This subroutine display a scalar logical variable -! -!## Usage -! -!```fortran -! call display( val=.TRUE., msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Logical(val, msg, unitNo, advance) - ! Define intent of dummy variables - LOGICAL(LGT), INTENT(IN) :: val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance - - ! Internal variables - CHARACTER(:), ALLOCATABLE :: advance0 - LOGICAL(LGT) :: bool1 - - advance0 = "YES"; IF (PRESENT(advance)) advance0 = TRIM(advance) - - SELECT CASE (TRIM(advance0)) - CASE ("YES") - bool1 = .TRUE. - CASE ("NO") - bool1 = .FALSE. - CASE default - bool1 = .TRUE. - END SELECT - - IF (val) THEN - CALL Display_Str(msg=TRIM(msg)//" TRUE", & - & unitNo=unitNo, advance=bool1) - ELSE - CALL Display_Str(msg=TRIM(msg)//" FALSE", & - & unitNo=unitNo, advance=bool1) - END IF -END SUBROUTINE Display_Logical - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a scalar logical variable -! -!# Introduction -! -! This subroutine display a scalar logical variable -! -!## Usage -! -!```fortran -! call display( val=.TRUE., msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Vector_Logical(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - LOGICAL(LGT), INTENT(IN) :: val(:) - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Logical - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a vector of real numbers -! -!# Introduction -! This subroutine display a vector of real numbers -! -! -!### Usage -! -!```fortran -! real( dfp ) :: vec(10) -! call RANDOM_NUMBER(vec) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Real64(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - REAL(REAL64), INTENT(IN) :: val(:) - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance - !! vector of real numbers -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Real64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a vector of real numbers -! -!# Introduction -! This subroutine display a vector of real numbers -! -! -!### Usage -! -!```fortran -! real( dfp ) :: vec(10) -! call RANDOM_NUMBER(vec) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Real32(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - REAL(REAL32), INTENT(IN) :: val(:) - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Real32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine displays a vector of complex numbers -! -! -!### Usage -! -!```fortran -! REAL(DFP) :: x(10), y(10) -! COMPLEX( DFPC ), INTENT(IN) :: vec(10) -! call random_number(x) -! call random_number(y) -! vec = cmplx(x, y, kind=DFP) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Cmplx64(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - COMPLEX(DPC), INTENT(IN) :: val(:) - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance - !! vector of real numbers -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Cmplx64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine displays a vector of complex numbers -! -! -!### Usage -! -!```fortran -! REAL(DFP) :: x(10), y(10) -! COMPLEX( DFPC ), INTENT(IN) :: vec(10) -! call random_number(x) -! call random_number(y) -! vec = cmplx(x, y, kind=DFP) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Cmplx32(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - COMPLEX(SPC), INTENT(IN) :: val(:) - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Cmplx32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a vector of integer numbers -! -!# Introduction -! -! This subroutine display a vector of integer numbers -! -!### Usage -! -!```fortran -! real( dfp ) :: vec(10) -! call RANDOM_NUMBER(vec) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Int32(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - INTEGER(INT32), INTENT(IN) :: val(:) - !! vector of real numbers - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Int32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a vector of integer numbers -! -!# Introduction -! -! This subroutine display a vector of integer numbers -! -!### Usage -! -!```fortran -! real( dfp ) :: vec(10) -! call RANDOM_NUMBER(vec) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Int64(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - INTEGER(INT64), INTENT(IN) :: val(:) - !! vector of real numbers - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Int64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a vector of integer numbers -! -!# Introduction -! -! This subroutine display a vector of integer numbers -! -!### Usage -! -!```fortran -! real( dfp ) :: vec(10) -! call RANDOM_NUMBER(vec) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Int16(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - INTEGER(INT16), INTENT(IN) :: val(:) - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Int16 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a vector of integer numbers -! -!# Introduction -! -! This subroutine display a vector of integer numbers -! -!### Usage -! -!```fortran -! real( dfp ) :: vec(10) -! call RANDOM_NUMBER(vec) -! call display( val=vec, msg="var=", unitno=stdout) -! call display( val=vec, msg="var=", unitno=stdout, orient="col") -!``` - -SUBROUTINE Display_Vector_Int8(val, msg, unitNo, orient, full, advance) - ! Define intent of dummy variables - INTEGER(INT8), INTENT(IN) :: val(:) - CHARACTER(*), INTENT(IN) :: msg - ! message - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - ! Unit number - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - ! orient=row => rowwise printing - ! orient=col => columnwise printing - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - ! logical variable to print the whole vector - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" -END SUBROUTINE Display_Vector_Int8 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a matrix of real numbers -! -!# Introduction -! -! ## Usage -! ```fortran -! real( dfp ) :: mat(10, 10) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Real64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - REAL(REAL64), DIMENSION(:, :), INTENT(IN) :: Val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Real64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine display a matrix of real numbers -! -!# Introduction -! -! ## Usage -! ```fortran -! real( dfp ) :: mat(10, 10) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Real32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - REAL(REAL32), DIMENSION(:, :), INTENT(IN) :: Val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Real32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine display a matrix of complex numbers -! -! ## Usage -! ```fortran -! REAL(DFP) :: x(10, 10), y(10, 10) -! COMPLEX(DFPC) :: mat(10, 10) -! call RANDOM_NUMBER(x) -! call RANDOM_NUMBER(y) -! mat = CMPLX(x, y, kind=DFP) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Cmplx64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - COMPLEX(DPC), INTENT(IN) :: Val(:, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Cmplx64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine display a matrix of complex numbers -! -! ## Usage -! ```fortran -! REAL(DFP) :: x(10, 10), y(10, 10) -! COMPLEX(DFPC) :: mat(10, 10) -! call RANDOM_NUMBER(x) -! call RANDOM_NUMBER(y) -! mat = CMPLX(x, y, kind=DFP) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Cmplx32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - COMPLEX(SPC), INTENT(IN) :: Val(:, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Cmplx32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine display a matrix of real numbers -! -! ## Usage -! ```fortran -! integer( i4b ) :: mat(10, 10) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Int64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT64), DIMENSION(:, :), INTENT(IN) :: Val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Int64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine display a matrix of real numbers -! -! ## Usage -! ```fortran -! integer( i4b ) :: mat(10, 10) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Int32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT32), DIMENSION(:, :), INTENT(IN) :: Val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Int32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine display a matrix of real numbers -! -! ## Usage -! ```fortran -! integer( i4b ) :: mat(10, 10) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Int16(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT16), DIMENSION(:, :), INTENT(IN) :: Val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Int16 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine display a matrix of real numbers -! -! ## Usage -! ```fortran -! integer( i4b ) :: mat(10, 10) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Int8(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT8), DIMENSION(:, :), INTENT(IN) :: Val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Int8 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine display a matrix of real numbers -! -! ## Usage -! ```fortran -! integer( i4b ) :: mat(10, 10) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat2_Bool(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - LOGICAL(LGT), DIMENSION(:, :), INTENT(IN) :: Val - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), INTENT(IN), OPTIONAL :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" -END SUBROUTINE Display_Mat2_Bool - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! This subroutine displays the contents of a rank 3 array. -! -! ## Usage -!```fortran -! real( dfp ) :: mat(5, 5, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat3_Real64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - REAL(REAL64), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Real64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! This subroutine displays the contents of a rank 3 array. -! -! ## Usage -!```fortran -! real( dfp ) :: mat(5, 5, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat3_Real32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - REAL(REAL32), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Real32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! #Usage -! ```fortran -! REAL(DFP) :: x(5, 5, 2), y(5, 5, 2) -! COMPLEX(DFPC) :: mat(5, 5, 2) -! call RANDOM_NUMBER(x) -! call RANDOM_NUMBER(y) -! mat = CMPLX(x, y, kind=DFP) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat3_Cmplx64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - COMPLEX(DPC), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Cmplx64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! #Usage -! ```fortran -! REAL(DFP) :: x(5, 5, 2), y(5, 5, 2) -! COMPLEX(DFPC) :: mat(5, 5, 2) -! call RANDOM_NUMBER(x) -! call RANDOM_NUMBER(y) -! mat = CMPLX(x, y, kind=DFP) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat3_Cmplx32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - COMPLEX(SPC), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Cmplx32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! This subroutine displays the contents of a rank 3 array. -! -! ## Usage -!```fortran -! real( dfp ) :: mat(5, 5, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat3_Int64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT64), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Int64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! This subroutine displays the contents of a rank 3 array. -! -! ## Usage -!```fortran -! real( dfp ) :: mat(5, 5, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat3_Int32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT32), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Int32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! This subroutine displays the contents of a rank 3 array. -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(5, 5, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat3_Int16(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT16), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Int16 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the contents of a rank 3 array. -! -!# Introduction -! -! This subroutine displays the contents of a rank 3 array. -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(5, 5, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat3_Int8(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT8), INTENT(IN) :: Val(:, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" -END SUBROUTINE Display_Mat3_Int8 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -! This subroutine displays the content of rank4 matrix -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(3, 3, 2, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat4_Real64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - REAL(REAL64), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Real64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -! This subroutine displays the content of rank4 matrix -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(3, 3, 2, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat4_Real32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - REAL(REAL32), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Real32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -!### Usage -! -! ```fortran -! REAL(DFP) :: x(3, 3, 3, 2), y(3, 3, 3, 2) -! COMPLEX(DFPC) :: mat(3, 3, 3, 2) -! call RANDOM_NUMBER(x) -! call RANDOM_NUMBER(y) -! mat = CMPLX(x, y, kind=DFP) -! call display( val=mat, msg="var=", unitno=stdout) -! ``` - -SUBROUTINE Display_Mat4_Cmplx64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - COMPLEX(DPC), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Cmplx64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -! This subroutine displays the content of rank4 matrix -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(3, 3, 2, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat4_Cmplx32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - COMPLEX(SPC), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Cmplx32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -! This subroutine displays the content of rank4 matrix -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(3, 3, 2, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat4_Int64(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT64), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Int64 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -! This subroutine displays the content of rank4 matrix -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(3, 3, 2, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat4_Int32(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT32), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Int32 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -! This subroutine displays the content of rank4 matrix -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(3, 3, 2, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat4_Int16(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT16), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Int16 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This subroutine displays the content of rank4 matrix -! -!# Introduction -! -! This subroutine displays the content of rank4 matrix -! -!### Usage -! -!```fortran -! real( dfp ) :: mat(3, 3, 2, 2) -! call RANDOM_NUMBER(mat) -! call display( val=mat, msg="var=", unitno=stdout) -!``` - -SUBROUTINE Display_Mat4_Int8(Val, msg, unitNo, full, advance) - ! Define intent of dummy variables - INTEGER(INT8), INTENT(IN) :: Val(:, :, :, :) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full - CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" -END SUBROUTINE Display_Mat4_Int8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Sept 2021 -! summary: This function converts integer to character - -FUNCTION Int2Str(I) - ! Define intent of dummy arguments - INTEGER(I4B), INTENT(IN) :: I - CHARACTER(15) :: Int2Str - ! Define internal variables - CHARACTER(15) :: Str - WRITE (Str, "(I15)") I - Int2Str = TRIM(ADJUSTL(Str)) -END FUNCTION Int2Str - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints blankline - -SUBROUTINE BlankLines(unitNo, NOL) - ! INTENT OF DUMMY VARIABLES - INTEGER(I4B), INTENT(IN), OPTIONAL :: NOL, unitNo - ! Define internal variables - INTEGER(I4B) :: M = 1, I - - IF (PRESENT(NOL)) M = NOL - - IF (PRESENT(unitNo)) THEN - DO I = 1, M - WRITE (unitNo, "(A)") "" - END DO - ELSE - DO I = 1, M - WRITE (stdout, *) "" - END DO - END IF -END SUBROUTINE BlankLines - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints dash line - -SUBROUTINE DashLine(unitNo) - ! INTENT OF DUMMY VARIABLES - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - - IF (PRESENT(unitNo)) THEN - WRITE (unitNo, "(A)") dash - ELSE - WRITE (stdout, "(A)") dash - END IF -END SUBROUTINE DashLine - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints dot line - -SUBROUTINE DotLine(unitNo) - ! INTENT OF DUMMY VARIABLES - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - - IF (PRESENT(unitNo)) THEN - WRITE (unitNo, "(A)") dot - ELSE - WRITE (stdout, "(A)") dot - END IF - -END SUBROUTINE DotLine - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints equal line - -SUBROUTINE EqualLine(unitNo) - ! INTENT OF DUMMY VARIABLES - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - - IF (PRESENT(unitNo)) THEN - WRITE (unitNo, "(A)") equal - ELSE - WRITE (stdout, "(A)") equal - END IF - -END SUBROUTINE EqualLine - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints the time stamp - -SUBROUTINE TIMESTAMP() - ! Define Intent of dummy Variable - CHARACTER(8) :: ampm - INTEGER(I4B) :: d - INTEGER(I4B) :: h - INTEGER(I4B) :: m - INTEGER(I4B) :: mm - CHARACTER(9), PARAMETER, DIMENSION(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December '/) - INTEGER(I4B) :: n - INTEGER(I4B) :: s - INTEGER(I4B) :: values(8) - INTEGER(I4B) :: y - - CALL DATE_AND_TIME(values=values) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - IF (h < 12) THEN - ampm = 'AM' - ELSE IF (h == 12) THEN - IF (n == 0 .AND. s == 0) THEN - ampm = 'Noon' - ELSE - ampm = 'PM' - END IF - ELSE - h = h - 12 - IF (h < 12) THEN - ampm = 'PM' - ELSE IF (h == 12) THEN - IF (n == 0 .AND. s == 0) THEN - ampm = 'Midnight' - ELSE - ampm = 'AM' - END IF - END IF - END IF - - WRITE (*, '(8x, i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)') & - 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_Scalar.inc b/src/modules/Display/src/Display_Scalar.inc deleted file mode 100644 index c7f0b7646..000000000 --- a/src/modules/Display/src/Display_Scalar.inc +++ /dev/null @@ -1,29 +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 internal variables -INTEGER(I4B) :: I -CALL setDefaultSettings -I = stdout; IF (PRESENT(unitNo)) I = unitNo -#ifdef COLOR_DISP -CALL DISP( & - & title=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, & - & style=COLOR_STYLE)), & - & x=val, unit=I, style='left', advance=advance) -#else -CALL DISP(title=msg, x=val, unit=I, style='left', advance=advance) -#endif diff --git a/src/modules/Display/src/Display_Vector.inc b/src/modules/Display/src/Display_Vector.inc deleted file mode 100644 index 897509be8..000000000 --- a/src/modules/Display/src/Display_Vector.inc +++ /dev/null @@ -1,73 +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 -! - -INTEGER(I4B) :: I -CHARACTER(3) :: orient_ -LOGICAL(LGT) :: full_ -INTEGER(I4B) :: ii, ff, ss - -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 - -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" -END IF - -ss = SIZE(val) -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) -#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 Display("...", unitNo=I, advance=.FALSE.) - 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 Display("."//CHAR_LF//"."//CHAR_LF//".", unitNo=I, advance=.TRUE.) - CALL DISP(title="", x=val(ss-minRow+1:ss), unit=I, orient=orient_, advance=advance) - END IF -END IF diff --git a/src/modules/Display/src/References/dispmodule-userman.pdf b/src/modules/Display/src/References/dispmodule-userman.pdf deleted file mode 100755 index d16ec1824f778ed05577d4aa91f5161e998103a6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 162230 zcma&tLy#^^urBK6YOJP~P zc5yN_w1xJ_I@Z-p++s@r-0Cahtt%yu$|AGZ&o9|>6n z{CtCu0Q*RiMVPdjU4=Cd8nXNyikI;5BtZVMTxAow*?6<3(&^!{bpJ*B@di9BO0Jf@ z$^U|;(Cc6Kc)C11x7v}5EM9CEnv>fecCTK~g{@(3YII+U9GZH(oGp(7+&!KK#{A5J3^f7iQv=GTf=qgzcJh~R7R@nTBx zbMgn7Ie54>GU4T$Z3{c0uYVc}&h5x$vJC9B&gw1qZHPgS2QNG<-Y@O{d5W@YNmC1b zi_6RP@LLbJ+eEQ!x}ktE-K>NzKo_FO?woYRGH;sP76jNoTSRB|6ukbcDIN z?Z@ALPo;&{q(#xz$3>Q0xKJP8KRbe~BObJ`_Hc$c3+{3^yD0~wfsli4a@W6Zkh)Nd z;dZ}FXxW!RyZp1gy%hA_)V;R{%7zaMDHB>%yq&q<3zW zo%uH!JseN6U~Ev`#TObr%m_mXts(1YbW#6`#uR#dAxT{ID!&&OZZ?+&B*d`I=2fsf zK(l$M{|2dkpte*m7Clr3LKeB0>0I5Pds7JC%EQMu7D0E4PB>N)@*BAC;))a&saW}H zmOM4+!_hltNaRk|IqYbh*9%2k_)d!qlIf-F|71ZzM)zC%P3_}m*o-}YJ`92*iN3<6 zbf#*ymAP~)6?$nyIe#1tbTG`k5D6V~m6yJ+sJkBaH=ZOP%lBl?8o%Lj1Q^;C#@Mni>ad zttrVH^q8LAF63aHo&^n2>J;Zz9!`P^c>k^B%RFGhls+!DXBOcNn?g*J zzqvhOr6G97cbv+;i1LddP6QuwJaqf|&_*=LCSy|2EV$4-&8)!|$qNHzEm4kdEc`Q9 zF{hxA6w=bMprY>p(5NYjGSH_QQ>E0=n&lr!0SzDQ_%=@~SQfm6{K6mEv|4YjzBT9L z`Kbjkhvj9QGaSAxg<$@&rrsPQSps!nXgdh4*K=n=H57ep-1QbAZP6>S8L#XZtvJ`Phce4loy!9VQ4Pu_Ntu@F;65!Aw=+8Er8<<3a?K&nR8>5D8Zpj@#= zG?fPeYNh5QNEXWBRJejei+-Pwn$D%=L#~^`Ou;z8fKcYuDGGoWK2`$2{tQi6K@F$P zJRg6{C*v6)>%)ba`Vc2e;`|VgO)Oo4(;wzCr~<>&J%AaQ^2_bcCm;k0xFNyYdqVfu zIW^w#!MUnfL9ks*qC^D{cpx9oba6qrR(Fj}1j8(ejGn3Urx9BDX0Tz}T2|P~L!@Ww zrVXX9o=OV%xu`L;7C}BGykSlf)aH+PQ}lABjRbq9F+|rD1hTO_Kw1gMjzWc+PB$S2 zRG50Mi%-v10``+(8vjNnFL8y!>ZBY<=$WgWxT&85X_>OSe{?6-5ig$Hg!vCVO~z!r2C{B$6tfX@_*!ZcdLe3!%y9v=)iYD(V@Jg6}r5MW563w>tXkq(Y%O zmNAg<_`oW7^b75e!sr|Nkx`Ty>R9H!)(TorvAK*6?*QS~Yc5-Doua%egZJV4#WFDi z;RXal>Cyd#0uHZ%JS*xkdvIpZeT3OP#q9eOMa~S5Gx0isTS?parz?2HIaA0W=x3OI zq3vX_Ody*Lu7*o^ww~mm=cHFEAshi_T&qH!felb0EpQ`N43kQ9on6rIr}^9AmfC^_lx~?x=T)t;=qAkWj3~uQO%Z?=vetxs>^HB0spZWR zTrO#Bst7b0=_yc_>h4@YMXI6aXA4duAuH!f1&ys(O$P5>pah|A=U$;0MUe_H<6Sv- z5AHa`hI8oW_U$*KuiG#d^T#M9f?YsoTf+tle0c0jur(OJ0LLgaPBAs>KqZ2ZMsouemm`%*im?UXRL>X5WA07Ux$C8GhWR?!d3Lhb)3`4ixhY~ z%fD2lnF}v7R`z5vLe|Rn&=~4px`a`_`;@NQppR>XG**ydV&zUR7*bB-;iI}zi7(LdWxR6D(|kynXM12};@Nw8qrY`4YLtHr@n>I_HR9P5nw z{m1h0N7?!HY?eH>=ZmjHX^^Pm48&6q2gTA-@HdB6S09xW-wBI;qhY|vQL@y`bVcN| zBLk;;1x3RwKeu3$g|g4&d7?nxN-6qk@k4!4!fsEWG;P?rpT zTs=FE971wNV@!D^p{szR8(>0EkZl_HNpFeDj6bo^Y{qarOP^EIyPAkzsn%j5881in z-Q8*cNcW*Ce;FSW1Yfi5o$4{|Ph+;X^w3g##F;Y7b-GV9*ZbmC=0z9j&+Gj^3=_w| zuBqEz>b;i(geGs>CgKZEKT*Q4RN%QkjAY5<8De8_!Q24ShjF41u!RC*cyZjGZ3 z+w;BEMwm|wsYES>0=`&#^j=UO&$y1wq3e^CgAX0Q4iztj%&6$)#0PuP)%FpydqNipQEhU-)>ZRg`m=O&RJWo1Klzp*e5n?F)+CyCQO65k>bEuZvZo0_< zMeo#Q!G2=l)X0J4(iRk85SXjGngC!P<&;+q7zA7+0e}}SC8Y96D^-;tY0??%WPLDU zxIGc$!_?w+_-n==c7`vJ(E%_&B79j`3;k!^J?+#e23p;FjNy@pnmC7knN-~UUU^6j zEzE|Q)u77d1>a$@OBb}`->B%3NX{(_jX{SbbiCGGsfkEAwip?9Ck=u!%c^gPtJWO* z+Q!`$400P9#o-s@So<+RdM5$r?@0tG0*=w}{kX7_XSGKB5IZ+wSRx~mDqFmFu;F-c zEA0MH1#0xg8D~#vD1Q5NasaKtzm*^WYce`G%67;WU-k9C0@zclB)=Xl_TS~7Uahd_ zs%C7Buorw&LZVD{Lf^l&w&Fh58+r++@mIASadk-uIBIijh#?6rdKheHMt1#25f^xH&7JnxN6&tK=BpqvZ zR_lVO7cwbQnjTgki|iB|6%H%*6@bm_u@b9nlZGi}Kpn)b=uUlTi#yAq`;zz~`hhs^ z9zo9X6j@u8r*}-(OgPg6(WPLl4`RGxG-1oh`LM5W(SsF)kl)nAmC|8?DxRb5Ez_2H zJenc$WjpdNiSe46ly~iG$+oFQ6`IsKmAdR`EO{X0D3MyVq8*3JRIIVKGjP7-gc*S~ z*1Od3Y*U@uQ^v`+_96Eh3dVP5K8ve*==>o{DqE-=&P>7;$9_oAu)nMK=@Kv-ttuAI6&6ExV)H$XEJyF9ael9eLCy{9-a1n`oOhER~wu780JZTbA> zinhbUB6?>-__~q`N0Y1qkVFbb)kxf@<||`GymDD*3yjp5oGJNUB&i3kdg+qgkKusH zj5C8C8vAPz@ zeElW2L3Ojib#tJp>1-rb(VZ9pCNSqvV?`-<1X0{a={Uj3sF|H?RMl#+s|WwW!De?( zC)=_n@|(IZOUDRhgNgl)N^K=pmh=;}HlR(nK4CQ1uDMlWcb)K{uZ>Pm@K z9(@2(7t;*<8olw!=IhaMlyn$BJ%Up#|J9DPT$6Ekq;;|iW2r1OzuXZN8d5+iH(x$G z1z%Fd+6>WW9&0V1DNQ_7bm~cMP*)O^=I%0UXtcgb(%H@=a^;{1ngHcYP5aj3T|1JxBUr|U`|Vz=7#S=1$pAxK_3St zM&>JM;Jdk=A|Zj>*UY%WUOIOQPQNs95=GhUbE>$T3TVYuJOZ4cF!fo!a8ccf0Zhn2 z4}11LG76Xv1#3O;PmOS9UP4^-HYKhTw@$L&S&D58TJNhD(_p`jjwI+9Hh_h|ny%A$ zZWN#7)a^~?pEisKX2Uc0nxQjbZ@DvArbtS39aluJLF$*zzIwU|dr71q#qDkUn!g2t zY^80GBl zVNttqAs_=EWh#D^x2 zXw(1F5c(p+-wJ0)NY97xE~?qU^Tk4O&AcGYir7agO`Ut7MM>nIJQv5x0jzBZj>nnOPS5F-da>q)|kpCll1CQ zU9w#)AzORZ4A70>H}L_kgfUfx5CGa^*2^Y-xqm#->2)*$^l;O}2HR$azDbXk4Pk8| zZja&!(|V!zXi(ijrpU_tFW*@j)kw2)qP@PbiG#{|v$>5`viaq*XNKMhJkh`tU;GO) zXr6~Uliff$Ld(KcMq|M@dkz=+p-0fFqxXf6abxOb533f;Cf0zZ_>+k0YfEAt;G)S2coi=WeW)p_b zLu1}JtR4^(RpU6ad_&0PG?DT3J9W)|Qvex;uFv_~zKluP5Faj?_g%6{|)1W&ghtCp2)nvXC<})5# z?I~Y*^WqyG;+%`bcyr^~1dc<1Q-9?u19v-lORfTB}BWodn4L!=inFN z4}jWQtW)OZ`}E!LC!OX^H|3_zC0DpI>g3sB|DR0-%w6Q5NNyt^&mp!hr&Vunc4jX# zzB7tlvAYL1os32&Ma2hpiRS?w8dUbfkyQ|v96+dy^VvE`D~~V1T0(N=S1h}5xGSp86?)LI3BnCW zvN!plm3jD<0cCeUq=Dp9FVU5wu7i1(WbZ+v1d4x-(~3~MzetlU9r54$W{y(knW^N& z$)CVeQ$9~#qYRgtO-aJlsD410Dl+Yqc9E8ytCGK5+@CcNfuEgr&1-zjD zF)&LBL%z1Ecy?u1wpFmCHo5FZ6=*U@s9ZVoK%JV*D{or?mo>Eubg70PR5>i`PJOSf z+^<#Ja4a^S{#r%*EaWoV)vt+pp}7EW(7Xp^P#_gNMIg1qQlftcD`BGF~n z`J~${kY-_MC2xE`t+?$+03-FDFSg{$c^Ty!?^Z=kq2prx9Epsh*Snf+B;zS?_IWe? zc}F9*A>`xIFqKw{P|U@=ZVjW3gPOj-CUd^|9$`rG5jxJEy? zE9xH&o!H8ufe0$71-`yiMlj@F_?w20?+@El-zOdZP3mFSc`Y7izJ%)%BkzrPbJ@q7 zPE>t}fcA*QMB;zduA&8GUA}ofV6mBgyiYW0QFKoC8c3O@?w)wmi`@ht>&e@PL~KII zp=T<3m9KCvoA9oGh=2ar7}nPlt9f@1w#TmLg}s7dUW^*b)9>>k^5 zPV+-96IIDw%&K~YPAFYC&2-GZ0(WzFCR<5WI4FT4(H(J}!O^mPhcs_I$^|4kCh!dS zDyEY7I-HX$yu#M!|6!dee%t!7Bvti;ea-~5IllZ0dtb%20I^e(Ozqj79E}%xkWj_c zd(!~(4IHB1x_0&CqOQ@!uom(o=#V3P%aD%~H|LnATx>1UhOhZGHTSd!fE3C$UAt%x zlh3zA#_bhq-890g*Pu0D`9VXg7-2wfWu5%nIa;{o+?T8o?3~%}Q2R#)WM{qu+e?kH~HLomAbJvQu0%U%J+Hs)J0J+V&u}U<9_CjF%EySfp&Xi zM}{!%D%p6>VSIgnUZAXONCz|J{9VRkWL{8!3hXS^#z+r!u_+B~OTk2>dFQvUwQVzGYMrQ!!` z6m8f*!&61DEDA4xRUB0rj&U=Fii6-Fma0M|XMX=pAeAOHxGS*J|8sJ%GDH90jFIDi`4}VT{|k@}>uM)%vpE5B^%-OAPuqA{91l&I zD@9t0t7S=(A8M35*Cqm4jHR_=S+ukpj=w&@B|yGe=LkGm8f=rL5#Z-6w)kAwJN$jK zTB8?EZQqcQ)#+z89{JyYb925AZ7gKo>_31P|I2!PTwaFtKb(s*R&w}1ZmMiY9Gk9X zM6x?;&ad9{G88}UWA(CdXJTW2055y<>+Cr-Ep{BY+?y`j4nGGn-15Xfk7hsStL1OA zap^zrS69BX`a9w5yc=d$7|vXb?De5vGXHH-bA(?wTHVcOn{16krFQ>4;)xaC{`({! z@a5*=(u0|{(5Z!=jX}399G!=Gxx2m}P_Gp$_Sr_ywzjzp8H^oO(A}l{`aW4>z2@Lh zJBvuDUA&!*MQ=I(+({p#U3x}ZC}(o@K;rxCvAEu&^d{5YwUoClU@W`8dz@#hz^@KR zg9Fqu~?@1dgGYahkiC=3AK*z1C=*mF=jsyFGG{!B{w_OI}63* z2MLvrt+3VE#V&#_$_r4hGCl#^e5S8Gykjl!Ug_cm%=UKN?V35^OA%7^1C{eikGX5%(&;LIR#cY6T1PKN^&$|Eu5uEuA(>SA_$H;)>Y(T0c)@DaU zrf0i8DM6#}Xbph^{|1$4;Pu_7L*mA@UiHQK8$es|%Hxan9XMNNr;ciFl3dLwp#x@!Ut>QBf**wu~Z%kNzV=#5BAS>Am0v6YMs*$P$NemT5U;QtBH)jb@UH%^6PGLO;qlXdj) z3XzHP9~%@G=o(G(Nw+|R@k(j_?N*f(8K=%8rG=&&_Gnvi@B7HWS2Y*#isZ4tb(hv( zhfN0YXp;&q^Qgat1r-*BqpT+rn7f@o)bW?~zsy|1?z>3rQqUk~Sf*}#t?!DcIZZFk zLSG)`cz%)j&~P?s#a&C%%qvNv5F!WpX2&5EB+#I6*e6mG<+zuLb1^s%i)s){9wsy& zFgZew=uPm|_ka+Bg0nY0^E=q2p-Td$}BX&m^5?=^AKYXJPacTj=7}~^pGR6 z2O<$@(qFhGxFKA3Mktp^fp8g|(&>(7!mB#eSHK1B0NO%?G$D;9E+SvKgxiM@2)Ct{ zmIKLcEw~eLzC`_o6M)Y8^8fJ8VbK2)J%5a^0`1VR0yW-rIqk;6V#kJ{OKva4X4Sf+ zOD;M3N4YNaFiCmt;=2xTwNI$8dbAYH?Uj=hOZNt}2_`Am_{nj)pk--xtMiT5bAl(S7j!?;Ztg zZ5ld6H(MYQxa?o>gvkU*>ilH#jwBwRj^&A1cCGh)sOqi6BsHW;W6ig11oR)M>1f=R zg&p{nP4DthSi4>EK>i8rF5~1(%@oMQugb#vK90zMCag$U#}DWRFq?P#2u&|ugsX)j3-4;nKwEU}5npr9~#g^S^N)^7DGoCz;K{Gz&XG0PeCqr3r*a83dp zfrn@la3VOr>(O>7Ul(h(Boce$TypNYatzF*a>IB_FD()}!r%xA$2m$?feU8b z`LktoampXwbJn8G0#O{0Vw+29sQ~=gX-7ZyczF|N%!I?aa_CHcYXO&p>GTM)i8&yKGmqDInUUmVk{SRt{o z#aAR!ih96$r~+YR1EZzqr|`w;U6f8i(S))T3*$kSU?6m+M_;w8&|O6DOAGP~qw;l> zoup(!SZSYgs;4T;p~n(o33vhMV?KvXPA<2pq2YhT>t6+Uj(DK3Wp(1v<8Ou=TEP!W z$L0`7nkiCAnCj8^V>@XPhVAj`ONhg+fH_oa}mm#+Cb-Ay9h;mK1>JI!c;CpS$9PR zr@V$FR+Zz!#7?(?T(wHTr8i)AeCyB7-@Sf9WmH;s7@hHSQdBB0hQ~(mE4q9qM~t-5 zFmFg&2L(q%638*$OeDRj87^B3#&)a}f=8{pzu+0%KAll;o|RciBigyCnD*eWY!*~; zy7zO@GANp8q1YFuTU-;$_W+Zmc|jY>-pN6$@yvG`=$f&y=&R5KPc53HUoREpDF*Vj z$|G-}KgYZ=Fn<-Zw?IenzHL%+!DFF7bv+zeMriQ#04zGQU$}jCLF7=Z;_G1sKE-l{ zTkaIYwjlT)g&uSEZgaMPp@|u!wgL?$^(-~|U%f|9oe}LSVmzbLnI2u!HG^555m7ne zB$H~4EG|MYE52fQNQVFX)3A>qZg!w}JDiV{*Gk_?-D%H1iH)#$u1FX$R!=|@@%0w; zxFCahnP~pg4Sya``pMxTO7Wa?WdXhhMidGIxyA2tAlS*F-L^>$WvW0sI@xtlv8$=RK?#UzhbmK_-l5mXo}f?M4s?iNOt3E2NLEfgYqH=vQ|Jh!xf1c5><0hMS{VurYa!0+Vgm zvTHe$8k&0Ixa3A~6cBlk)*qPv_2!4ks(e8jzbaIQosdaz1FC&t3AV+vB=rUEUUOOP z46IK7N|$3mojh?2Y{P?j(#TMnd|A2(R#^sjcVLieO)y~vv$7e=;h4Ig;RuVT4ffX; zrIc(~z|$LVQ%#9^ft5!6CI5C`QSQR6K;9PVqkxnjA|`f3aUGInTMh5TljfHknU(2` zqrydm2V%6NLIn)ek)gBzs)}ZwR!kSK#61glf%t*Jc>FYsH4#;FHdT~S@%9evZNCkE zyKrloNQIHihVc~p>B`IE{Iz$=-+=sf;RA33T3Rpmz68-biN)$X)rjmwMNbGFRDZ(< zkqPl)5l%nbwQ_~up>Fq0I`n$ku;-e;p^N8btZcZaP3JCpq`6}p5GA#7z+dFO1-0{z z#gFHPw?UYremz5DgnumGNxN5bX$;_iz=MdKKI`mw7)Jx+jpWc=#)_&)17Rjz!z*Ay zx=@+x*dQaS5uB#v#r)L(E(#iHR3Ku@hgy&cUDIfq&}C>h-U#T47MvC05HpGSx%61+ zK!@)ELwcnS;|ozL=YE0U8Kp%izjU`)MwKGi=_s&0M2R^_j@e#^HRK?gFkfaoy!>f; zShRyBJ`759Njz~#nWIViDWYK;vH1yCaIjpWkT+y*2{#gtQ5Q#Z%OdoEP*Io5GlO40 zYMO+~GOpJQwt&oYjEM}wV4x6hda^*nyrXu!&lLhKco8e9p~R#?q@G~cbhA1w($D!{ zoNg++?Xs_x3r&^^)e-8=`@`H4v9cQF{R!M$yK4Lz$$$bg3#-5b*)uO2p))w{mvb?A zehaQP-_qMINn}k{mTIfc23{|_sB;uu*t=cBJloZd8R>bE7wz3FJ`Ksz-n-P(e7_5y z*%2B3&_`SAFO6YIHph0D)>)2qu1~Sn>Jv@9phL#etuZG3(0FFCa?6I%BU#1USVJx= zIRw&i6YhHX311mJEd8fkRWr)|gC~#@Q2< z#r25`P8FsJp*y_JN&?c}P+GcV*m~o8>pM) z;k4swfx;T)8l#Q z_a2lil45}vQYXs^iFkSiu3$Q08wKi)c<%A+`@?NJUa`Q<8T;}V6@>CbJ7PocjWs+(6*H*PmJMY>~ z%*3x*NEd`AlGuG9)uSD6q%}!)m@UL>7YE9wwS=#dbkn(af48njD)w!f^jF=Aq$}V~ zL55`ib3ar_bJ-~bRYP{XFq4r4OV=1#{xQVF5$+LJWD%k!d44sdcm6K}mOO_$Tx zJr`yY_XJA&vqzTD9d>_QwVqB*K{w64Q^SDmr)`+pgwlYD4)JmE=gE;W-Qlw?61ABz zB1PC-MUhI5AQc&hOm`g+C@cn)$~29<&mDU^;jITUV(YE@skkfTYS>p5>}#~^pSpjt zQM=c&5Ta|inj{;*?5*PTQY?BIYX@Xowq8W+USsY1;*l#GysX|^Zrhfuvl-rXC^Q2? z!_3V@!fYh!s_Pe{2+o48HqOVXPkrqb9q*qx>t%Y)j~-bHy$_u!co?A8nX5GUH+w_y z&eq^^R7B-Wx(@#Y*#O+&aYP(1XTHg3*0UXJ2dMX|t)7LZnb21fG<^bh3#MYuy%DW# zZi}Wsk{83;=Y0Z5GslZByvkESh&-?;w%nqW#E&vZ=^{j>@^Kyk zTyku&v$5Db+M5s4MxZ@axBy(N1yn05CD=fsK zr(lSJchuTR<+u z9JXxH!{E}o#@VEFBZ6|p_CY5WA^J=Y@fn3@=Zk@$IM1y(UWGQstjt$^yJb1DuJ*^9uMRYu%QEv@u;DI*GYVU^$x*62hga5{^&6ex)dQ=_A zTWHu$T`#h5d^5_YkD9fZ>9aLAXldSjS&!e-n`5)UTQqIE+ZZZUdN?C->I zXPE6KWg<;}``L878Y?(EA{Yf4LzQ0<-1iM-tT*}0>HL4pgirCfm|Jm;&~?mc@2vtBQZ;ZnB@^KsQnVxWeTn#Mjp@+S#nj#n4m;c3$yLt?!3R}ih;V; z0LE=#6hw!wKx6eNkMa?))dCDYBOE~@k-Oi5+X%k1g)>1OoSG}U#uO3BDt11x{L=nx z$Im2JBM%k8ba1zHn?@!C@xeP|^3hHB$6sr7DG=gWS|)gbF>g7tl?lrUzQ9+{K!nGHcMI?zc@>_8KM1B~>4YnY0v^5-gBXdzF-r>Iq z9T3LnRHJ_PQ@(n=`>p{`A?X-9Ajg_p+dBVRlBlZ2N=pLjhWnWHuhR<;qG84g7OmIS z!vbbWJ71~iPk{+;(9d}x-*dnzJ7zSlNm*|o>rd5EJ*X&l())rKh!lEfsp5&@nGg)6 zA{E@;@0}$@P1p#3oQA5fb8nJ^S2CxdqPt6*o%|oym;x#J1lu+k5EzbE{Lpnod)kpw z6%sJ01YMIAf<3q4qR$f_%kDO&=v>9y)GE+;g*}ni4F9epMLFxnEE;DMHq}8sP01rs z!=WZ@Vy$iy>3h4yi$r&dp`QwEfpt_p&M+cP(#ko`(YbKjZZ11$k#$1?vfDB&*M%tO z<|ray!3fJD^%8(Xqaxr{P7E<0UY7fy_l?*oL`zC5+)(lQAgAOKy)C@SuNIfFck-ze z6*M()F_n$Nu;6X<-HRL8vfhHvhV{4aq*caq-tG7b`m;c24tdJ>;xU<3h|T09NVZkn zOUvhKbUc!s#;B8yGB%EtlE<2YsXjpRV*N~=iJzg}2atx^mdzQ)|F9@`&Xy8s6`a8A zExofz;t-Ug#0pmFB!HMGQbY_&E=0POKzSib(T7R>WK=aD zu&Cfa{wcnGo}GR{LR1i+0B=?p$FGR=8hm(s$*hzfNoH41#o25KTvFH>K8VC`BG}o4 z47$8^+fpDEV7wezPg-LiDY3|V0A7K@WKMK9o7CpFma$QZQd_cUOPAB$h19N(1I;3c z8W&Q1CMtbm+o6+5)Ds}^uRUR+6xn(#>>C>D+(9Pq9!%^#8t$6;-WtCGiaahe%hCs! zwHiT7r4hv4OXU4RM_MrqK4r0A-xptk(3oyzD@viGPiUWS0MV#AzN1yi1WQp_P&ds` zt^Q3_%sRfrFh*^E(3sxt=P&*T*Vwa30cn#BWcF!SES>bXH214TehB?N1?flXJ*G^W z^=ZF$xlH;Cuv#|xDSqs|)Qrp*3^}?|e3MP3Erhcxl%0=V%7;N{_pq#^0~aR}5a$SW zF%&mh8m9+{S)LYdS7~LRQF1kQLe3r-ca6iFpCZ+l4CVyzQLQ$`;CXI`I1e5~Ppa}@ z&k8(7`Hy;Db%cIxhO{s!_`ZdWH?+#nVUxdSNg*r`e&}Q^o zpBiPpV8`_baf`C+NBr`w=A`Ws#pUAbU~5^o%783J3Ik$>#8djJp>FqqddXPBFj+Lf zhREq9ra~d~j+OKaUxRV>n?HI;-n8=vR|a`5?a_%^Qk~si#|OLI`~9a(XKm*)9lj9( z^xRnb8Jk{D)ei|62yd+ui8x0!G(6rSw`Ft8xOaKsZ*jOhvP8V_q=-hdaN#1s5V{zo z=bS0AL1>?Lc^MJnGiralPnrAI4RVnNrt#2*TGyU_?g4f4u{Li1ba^}$qnib$Yl9=+ zxm}s79an|j78Xc^NiQiqej#|ewaOb?^%tELbea6|espc(pMp$0;5E|qg+=?^on2x7p60HLnsom!Eczb>`X4P~W8nP%wTOxN ze`ygD%m0fOUF&K)leD@5PHWSKQdkO+w4?vbMei7;9b6nVP=^yo((x8O)Jfmac1{+X zI8{&Avd=|Ny88v5<0Yi9$21pLn8DXTK;X~7milfrMW3-%f1=~j?cge{<&iM6tE+aUhkDc_fFNZ*cu^Vw8!ew&&b))qUJ>9xfEagH`i z4~`s5j|@2Z!@Dz!TYjGPmS`r_jeoB|l}s=l=TX*gy)C`l;ra808+^OCm0}jeQPV*g#NQr>LYAK3b>YAE3x|!_mSWsmt0}to zzkI*hq)ppQ#syC79#nscx9vcfa+?kro}GS1tg{^-%qr)8QNZBMMr=&k|hkYEVg9@&Q>9rht;4vGlG~AjqxG4R8I$aU*0>!73?3K+x6OIT-l+9LI zXpJ~VhXMXB>C;4;696iD1`La$usiFVS%P0_yCs{e2ow*((+5_A&ub^0doX5qi1C58 z3$6=}C%ozde3~V?p4%jiJe%|Q?t&B( z^eQ`C^iT6QtHFUIN2y^rKf)0-%s0voQA>CEzG4x49J3+i_HzAIC&Roo0PRQyUH~dl zU$VEHp6R&H;_l&(AZLu<7<_%TwO^bPL%JS%r=gd3q5+lbzlG>h1O=QWu zk-hv8N~7TzZ6M_3{%@Zz`W)q=MF|;|JJ~yueNgoL>-}dqmbm;H8{eDr@2B{{&kI@k zeGO0Ok_*GBIF34*<(1Dwq?=|}j|dT?Qjsupw_B(ityWA6O;fN2U?=0m(vOZ(GcQ1lB5A@7C`jIe=awdjPvi| z8`>3gDaR9+-1HRK-`BL-LrP|*M}AN7THrzHGA+ipXyRBsaYQG|q5kwwj?F2dqk`CF z^(`7$hbjO?JW-^866fLkbDAi^UV^+&l0WLqA^yGDqY5$#6wM2JO5qJRI0?Vyue}eQ zMx10oF02-iZDaL96!Z7wAee4{1mii6igR%;k>)3%+*P&w*-WrXn>L$I3c4>Nv6tPg zd75ADr!(iPd)@otwKGa#o${W7wcO9kd@CGmD4wBH<dpU5@xeEc*kO!T~M@AoP0<4XC?@%Vk^+mrnLdE?uY zrOyXgOn2?NoU$~w1#<)LVp-#3(r42G4@>hpyOPb*D#KT@8eknhnuz8fQ%B*6ajjd%D-?2E`K?M8^; zNqiTvkQI0+Z=5Se{p3LDjobksP!VVqGI`I*e^?pd;1dLSS2gU)GBZfU7K0RqN?Wf& z8)+78KkOb{WIcMcWVj4t;v#5`pW|tJxO6YG7IlqLFga_Fs+>R^|LCz4l5aAicudIamEEvir>-u#!(5dA6Kl^g+LyJ*f%<`JZ>x!}jI z2!p=M+?wuMuoePm3BdbE2DBN)$6Uuv$+E5D?5K)bkzOk+MFCZLT}Jwj2dot(9aSkW zw073*#zW5k{m;@dY);_l^MrpT#)O`iN=tz*7Ku9a@>j-Q_wZ~?dLc^_f9nlC^}NKC z?M?#vP<=IzdDc{cxOWzZE1coAZ`M9vZ@klggdNZXdM*RQ{!2dofu`}<=iJW{bOG-{ zRR!)rc?B0p$b!1zp;?t`7E6P+A2J*)9M=_P$AQ`Df}oBQnrdPq*yc4ubZm<;js0?_ z1sw1SKOY7vz81n*!bjy&qsf)ZArH0K^k+326_ZbwdWX7P=Si+#eE;q~u%2eOcq1S{ zewRzpxMFL%QzAO$tB25A#|2LE&^xW@e!4?4d}Y*ss@`g@+{T1n3>mJd)_s7k*RC{i zLvC$i1X-W+_LD;nI=ErLy^bu*zc+uVr}Zr zUcOuui%1JclIt+kmk(SDef1;l@;NpAT2=-2FaE8X&mlQM%eixj(zmaEC8dIW5~ije z&)T0i?7}RcrpZr`W;OZLJ!+9+qTBF935f%scdsQY3>i{U7P$&nH}{Z`OZxax1f1-| z^YukF1)O;hD8{iUVx*F1jz)}L@;4NI<_ny;HqruIqsc=6;!-F_$dW^tI);bM;vpb% zZJctUS?fAqf`D&Lw#H~|=Xi=WTN@o#2bszroHU(=Q4GT9$7_{`HLEM;1s1__b@=JI zL$SKVOnX9Ai*+LggdHkPEg=<;hJ23BA7mCqWg%PY1;TUF)BbI?NR!=WoyzF6<9LHs zcMmgz5$sYG?FdaJfJ!7-6K#$!AalnBGoIsTIv+Ph@h%}tJxSGkGjeNmw4}a7B*qvF zlR!=Q=-&inFA9|T4N;v82Cb%saW$kpLrpPdUmJWvpz(S@j9)ig&YX%;BxeqMXFaBNx&gIN{CO3QIV1`%DTs0qR9s-f zIW$1NL6r<~d`9*18_hZ6SGp&3+{t#7l7$G7Q~g{~JpxDhyQVS%N6-woJNH5}-(LqV z9lI?C1Z6}MWChhIOn)x?Pso!r&CC8PX5_O35Ys*Wlggh&FLyPIi-x{>9!S!QW)t%i zU``W=>C!yABLqhZri(rEAH3jQ{ z4dVhu(|3R{B;Gc4z^ts9PflUYK%9YpRxbma+FSRQ*!tmHKwl-p(~zS;>TfjZ|Hs%j zMa$AH=`P#0ZSQ5ieKm4^^-!4^GhzlQD?%le z9Y(4ZmE9FZNF>65kC**@9 z>pJf%unc;__Y?)kivt6ExM^dC*!} zZrPX63?S@XL>`>(s2?mqV4oCl4`OUWYa$HXmc4urRaX;w7U}-KNE_S?NXI`*CSc-<*Ho0r>fK3z%j= zy#(w&L6+nA0*5od=oUsk#0v-~8c$K4J-j7|>(5Jl1N?QjXjpDi+r0*^O`jxsm?xe2 zR|=u8Q<=zGtbBkp!`COOc(Ey?7<}w02Ma}+eoANqPQ6+wK^|iY;pt*RSJ&FNkSiuB zo>)~Iew6KmXc3gGI)esno$9kZM$(dU(S76&!Oshz{W8qoPQ53k6H2%WF_l+tK=zYT z#(|FAHiQ(hXXw%m&B$-^UxjsH=E`y2$2Pf=-VxJL;%^^y)oxpmiIHGdE^a_cF#;5@ zvfE-!Jkr|RN2&x&tG`$A^9;tgn&BVWzt9z#CUK4Df6@xfB z(6sOgl;$}R%v{k1Edh3}$G0(hy9w3yc7&dDeyF8Bsek%O2rGNnc-!l_pP-=X3B;-L zwlc1IA@)P2Di0^@#^-;IJ}+!Q7!|VA5hIb3q(he|e_DglM3$~BA_jDRBEs4dw@H*< zonV!>$jaCV0y5UUTsNQ=MIXJiRrSK}uEKzE(s9>)8sf}%Pm2DXNNzm_ zK>H>8&=0Z(7y|}Yz>kJwCpeTXvgs^WoijwtxryFcM#XJ0De z&y7I)=4Q>GhIJ(nF*qsPG5n6XU!#l5*^5FrE`vZP5O-dzS$SHj6V%6Z@(a9}f`ctU z);5Cmn~Epm>CM^WD}=K1drHh(Q=uW;z7og=swOAfZf^JRu1voRBi`Iq$PBIIRE-|d z*Po{~ckrTEexuW_6hjkTLT`p1M=cT=$3rbKeJ_8Le%sD-?0U6*O28N}Y_FSKkkxP# z39=*o6+ZwZgSg+A-h;qF{1bTHdfD&ixKq%|qB7zvXF^q)Au>LFx$;t4SgIMX^a>oe z+(Bgz_V9jScO4okGTqh=%F1>u0DOl>O||IBKNp0xH#+tp%A0!8DAVmy%Yo{O@0SSF zXsZl^+1$&$jW6q&Ah)d5AL=ekV01``P1g=MU{&sVP9dV`!YPy)C{GiQGf#^mcXekz zVN5=!tqhG(%xi>&l&@{O5i|H9%y<@X2hrDhhY%Kn2U=e%%yYq&#i3ThzD>uudJI~~ zd9H`o0TzS=U%s07!pMsb;MKA}huVo`KYzk3_Y6NyUq!R$k3-{?==QkoVmY#WC*p=w zz7jEIZfE&SH`whDVE(|gL}Xx?pZRdW0qu8!x}5>A&ZK!*rcpK{c!I%xDIJkYt2Sn& z4<%iwy%;&7>jJHpfLF@(tL4xaw1=A^T=-^U7%8j!fefDl)(oY^+7s}p(ufba40nRm zVA9)=?x0P1N+YNbe}U!`U*7CWnmyiyGa^9;dJAIA00l&4Kl~13j_C%dya|(cInLHb z82$K#ly-ZH9~c+5Ab@6kVq^gCXk8?N13mGmOtrqK6i25%nTVM4%)sA_awRZ5y6^hL zNfPJ{)m<6wSHCJ0b}74)E3*n^GDfy)}4nwbjPX+q~8|Z(ho3iD$PUx->>#8`BCb_Ljq`UOs1KB+aIU@^m zPEe1{Xn5^qHd&!+agZAXbhbfbFs5e@5$p&|iz;}czlHz=&ff>JSez;TOq~)e!R#e7 z@arxvT)MFcGCy)*^y-3Vc9rPSo3{{e@oz4<;HkZ3UKqqinz z)9MmTq!nzos=oeBE3(DfDc%engkviRmD-?s5~#r*;=o+Ov>u%5&W$qhx6H+15eS5A zbRSDF>u#UVA9#{+rLM;tJ6peng>rTFc=`p-WC3qeUhBrP3?aifZxV?SUzQx$hy}Uf zH%WI2d`DIqvfYM`B9xL8uS$n-mTe~IZl>K+hzE5Mm>^9{8^>a~%OsD9>;`KSK=ST?ngy%MNx(v%1uqK}A|26+ z&^}#e(Xc_Shx1Q*M!KBOdL$wyxrWW!AGCSrqedxrWhP~#XO$$C2W{Q;QSC4UWkq{N z8d#%;^=5-k5zs%7Tr~??>>?YyCgOKh2aqr_jO`#1Qusd65H$JhpnWWQ7}nUNFk>#u zweL|Khx0bpK|#SWqIh_O3b1}*h)AR50QIG~XoP@+kpeai5p}5O+&y$Aia(1i@7^>m zj4w84gbrF!GC2~f<}$Txb!!@!Fd?d>?a{El)VEy9j&=AC(dck62|?{w;$mUy4s&WD zc9+S8Ex$LzTB6waOOzs2C<>`gSwtf0s;j8-?qH-oQTa5USC-{S<8 z76%zpDB}eI*D;QHRgO!azGq^jBUHz(@m&{QD#hx(uSPa2W}2?szJhEl~`Dy)W4E_+Oyn#tsl|VkZQ0a{V$zOW9K4i+eZ2oED(;8tKH*HViC|jgk zs+__Z(q1v9OFie&L!au=jE7e4vKT8hp+g*nF$WH$1x+b$Iv)GgU7$L$%j`B0ZcLKS zbQnlzJ|Z+cNZBNxl1-~FwMzD6J!Tr|5^m1;j9zr52gTe6a^8*PFtaP_HH%KhQ6r^X zL6KI>+elW*pt1f?;d?Zi&&2;i_LZ%?gvWKr^15Nh-F9jFbgBE95DRc>P;@WwtD#}D zn6X*B$$h$@wLucnt1S9gP;d*?E< zpfmk__}D+z7iE<1>HaWP*M_O(NcLnsq6jz?%2yXifFX1S5>alV;B^SbYfJR^x4|Rw zAG%M(PW|iyF7#FxF`qEUDfe(?OW7D5T6ulx5VDOL)vLUB#qer~)M*NU4-E`qTnTJQ znljEv3pbGJ*hkO}E9w2NWygp$6hoKkHu;P?tCLI~(#3&8(8{WfX}fF;7hiAkFn;Pi zuC4dhCm{b5)qKm|y1nA43E-~^#pbv_p=Oe(IWUrw_s*HP*5J*!H%i+U_w==+hgrFUU zpFdzkA+4AMI$S-~e=UEU5(q^$3J1ICHqx(XU{zZpRG=soR#66Om-mHah`5G;6!-8} z|1(Cpp+ZQVae-d@*w(ckVpQ6_>b|lg#*`T0PXjdL*|6O&*XO?U<|XqvDIoXa^Vn=n3e2+eN1Kk2pIfV|i zmEbCw-P}?FmK;gH48(9Z#|zG9F!-w+wZ6vZi5b&W?;{AFZqt`#U)jOcPIXwSBvkg% ze-xWdhK8?31S8mDS-fu8907gWX7*ck_Y>~J`*}^aGc%hZK|2;Uk(O6Wr&Nk{ojuXq zm}8wimxWGiP9;pmPZ19ZC`5=(BH>DgxlEH}tDAQb*$X9^reD6m#>_a2==ZE%swZ3H zYihbRGb*b)VAy9OB0&D~kvQZNqB1yLk5qO$=2|QDBWI`daiL(&4c35!YV4oX%3bAFQc!^%0QQnJ4iJkjC1ePPOF2<+B!{c1ApNnHO z>p~E8)C}t90(f8LwxyDqg-lAO+}OZuPGmS8B#jp07S4b-d#QAUF~V@%S#nTMmmYb` zeoIB?EP=#bEl)1E2qAqRbaZH;Y8yfEy{;CdNxuRi5`WvFol|=BRY_IS%GBjnuHN@b ze6gO>QKxDIJT9c0?=C#9H=p}rDLiJsTErDta}lCPmDkyrFY@1gt|Luvztukvhk;))~Q^bOj@nSUIfOW$9Ub0uz!^<@wFp9w=z5tCc)YUL*{@(*HstCuKkA=5a zy}bauayy;>E3)*jh|#|zOaD`c#Pmf`>}PKo3cCep5EK-;b5oh6ZFf|<<|Cf!1zw?E5O(1!SHX$&lBH!-&Inkahu1> z!!~Edx!LhT_!{jOM<=v}ChHttPn&D~Cg0a(cP>xYE7zIYCh1jIW1^$M>p_lg9=wHa zX^CS*#+Y`d-tOn%&9R2jVr91KD$Gnu|M33({m?$`^&J{-mrK(r{Or`D@gU&(_f1eu zGUrZcSBEt$G2mug{z9^;cA8z#t-bSHS1J6yHvzNk*zkyIWwZ zf|UIJ!Mg7B;z4(NTRE^ty;`1v&%753{kM@bK zhe&11!I86*7?p9#X` zaF;#0mwlxy`KVZSheaHDJ=8aH3%bbKE4ph)fJv_YIogUlvG;Hz>~qDx+FTwFqCsIh zocMK`Mw|Wn*+G@%37LPR77!s*M>#jBUN+fH9tbMi94j#DY~j?grbOa9q>cnqJdiF$ z$9RSe69mvg>9dxeXy?{aU>&5IDRaK!MH(tk6I!=Kk_nyp()sG2#XO@GX7TK^ z6_9`Z5}=xLsSd3J6clZVI1&6CfbyKwShw3w2I0)!8Pr3&K0ZfPAdg(?*IZ%~h(}VN zxLhLEd8z)6P>gprkUA6c+`X}~2P7VQ71VukE{z|*?B_G@o((KI-z4^S^*lINB{@J$ zZUQ{mEL4c$3fSM4l0UzqtqCs@Kklo|A$P9~c(TMan^mb0Wr~Z?vY_AyqZHb2#RhnWp>}DT~xOOaYl{Ic&U@? z84V&v`hM5(YF3KJpV(LrXX?lmeg@{Sye$>d*P++)E64ba=1Y62&ClI>E#?JPX93_h zN7l@rd)8tvXX<}Z{VxiIcfaNXdpe{J?Q~AY^LUI*@w$!p^Kb|xNZ*3|UB6}e+`9#- zKWte#0(B;K@z1e35|0hQIbVm0dZNgP&oL&LJ2V#a$XFKV8_k+wJW5yTKl81^<}R-v zUP8oxs5X)Xi|(VZ{OP3`QF@V_op^2SpsHh(r5w~zu}P@RSeBGArkjS9ca8Fc zbG6b5f@Oe5xO3>rCdythEH$1(QCy z?%Ab(+#2(l?=)d$PUK;2yh_!_`RC#Nit7%B4EQ;xw4(mNL|^o$E|BlxOj1)3R^ieZ zdN0zzPS|t?hhU)eE7-e>$RPP;3*9AnvarQ(19hx=+M2$n|J$IplL0;Z+fE-9dj zMZqvvUwfsXF?PFP=c=M$n6(X@fYuq99`u|H=`AyVt3Q`O>l814YdnwOf8#I1+x*SG zoILFM*EwtB*g4up_&IBRxw&YPMWO%Z{Svq`2ZWf@7)?Y%;?anTj|o6IQ!qrr6(OE0 zgdyRSRm~gKfP7+(f(98t1L>q09{$c+2>FBeE2Kepxkxyw=81cA+($gIrwPvCH*Qfg z_aFJp%=9Os?C3{$?JIn`Kk~)tPtD@YtdVa>k1h*CUxP0NQ}5t(6TE)_atLVplpf*# ztY_6gZ~&P8sU?x?R~2%?vK@9BNKSGu`#BD8^UP6WpGC$GAisQ#Nk_fGy*` z00Py&0tWQ`4+Eh5K+c(Q8o{FmqsE_|392+(1W?a4eME;1$?bku-}f>zerZ2 zWocYiF2QuPnM;uhC|q>peXc1(lcEwk{?37ad5(Bb=3K09G>{I$XK<=mi0aTR#>`a7 zh<6wIeKPmk^Y2Hv#3OKstVqUh@=Gjgce?3+_Cuq;-EJr-oeT@U{>+7k%5sVbp>UpK zQ5z`H`iIIEw`-gg&Cm3N&W)dqx4|QDP7B7o-J){#58q;NQvQ0Jqx?nblz|((_>YW3 zXY)s7UI2*5N<;q0iOSO8jH!F??=Lml6vW>rRPn2BqiCXDTk5c+Tu`HK3?v33N|T4S ziUq_F$FE{s=SN!>@PuN}ZXsO_WA5&sC@yi}Jg$a~sPB&fmmS29j%5>NOz{e{5PL?M zGkqe=M_n-%5WeshV6G_%3tf2&GdGNeku}02PWR;yVI@f8|BEnwB_vE7<}KRDq9mNx z{{O!1GXK8qk7f5r*Fd0ZhL~Op{HGcjPlDqc|vJj;*vU zICCEA9?RXcGYvExnE#q7xOfFZZ#to&V15CFv88xcZZ)_&2mR{RLHZAO5dCv^;x6&; zGYv|Uw1?2tA!yECuY7FqE#W$*k@K9ZqIdd)dx;n~-+zmRzzgRqIny#k?84o-aEJD6 zKd-X_`RMw1-vZwTv5j2mh(thEddnTYt-mSI zJ!d4s;WbwEb=Tq;NrtU3WcRU!$1zKYYu^ld^>jGg&U;VRj;9gc&f7TlKbXDd*~VK(-X?p+qm92#tUY@Ltc|~htW7@t z^dFuM0@u_G7k$5TINp9NznB2j(@_NoXM|{;7^b*WRuzA2BhuL^Hyh{(d~8*<)6T3c z#>kT_r+M zO}c8|x=w+%fD?$SZhKneb>D)_evOTm7mNfLKX`)xF|R)4tyv+teox(tqvv=>8cTws zfZ@fRMt5tHEXtzXC_sN}*cn3CJB};WtlY_;PLRvnq+eC42M%(tlLPZ;I~F&HJ1MT39VVd`Ho zM3K0r#)7iKSb7jU`C}hY&lKW_c_gIs#O9-(NPzwE$hj64t3*HCF-%3pJ5mBy9;{qr zOTm)#-jA6DL2YNjLapvm6tycAWHwX3Dlq9w2IbW1FD20SPIPx z&nyPY{Y&v=xNOf+%r2X*%U_0s&l{>}FUMm|11;q|Ml^*hBh-2AlOKQTz zC|5BU_3#wK5k9rNb>Mwb=C(IBWIv(6v;?MY%IUK8I}sbTQ_$k0=vFA1AnBAmkNXp4Y=qafH;(-e#;9Uo z%bhX6fArH!I%GvVR3c-euu<74O+?|Phpg`h=gtD^oPjTONQ5gjoz7*ip00)~tpI4P zs)wE)NYh+;@3Fk9U}==Bbf`IKXF>jJ0SFt{byF}i?KR*yU|T@tHNs#TZ|B19BKY#> znX4|VO5j49@g;Xm>^aKBE)h*VT8^f}w{w_1S?vKdYhd6RaN4~HHHvN5BCPw8AGIG_ zdr2#U_xQ&0e)p|Ou#ArQuxHyQBQLz0%ZQZn*^!s#u7j8IHHiHO<*vFH@z)X;$zOKP zW3T4V&0hM?;jhNe6OBFo!=n%L-br5$o%t)-~KhGJkaA~%bd&x@sPIn)dsRNU=3^mCBlF6 z(5^5L5H0JBC66}$F$+-Y`OSRzEww#lh82Ua0l|Y?iC8o4;qvmJLO5{@s@U-z$1j=j z?I{3r3t~UQ91NG1mK+np!2k$P+%sfz6w?>9=BZCqN6bL@f|mwy1tAUP2`(-A@^1uj zL7px^*E9UpAf~TKvIvOmk2_6R|Jo<~kJxz@3}~nSKNTJOdVG#4>%#1~D1T97qX*rw z-EdxADE1!~5QV`_4M(dl!2O8>+)(Ov3AJTTOhTFF_EDLPzSex!}V7|V7UfJYFg`JKZFh( z<=*;PFr-~s^m8K9{8j3}Y<-v0%d^36CL;bsYSjxNuqxwZQtP$A)T%!vwJ;Fo22o(x z=U%FJ#)gi}e1l>8s=8@^?aovBD7|||X3M9dNz2dkQRt0R+LFzRFk3zdYm@t6<%`J} zF<)Zc<%nzU?tUN-zhf#sbyu3hAu!=b<*#+&5{PLQN(D9e$D7(8K)sJWT;}ekl@R)F zSf>N5bg9R$QMGHN)Er2`kz~d8yOc^qnjQ{R5*5YT1C2w*Ici)LJj(6v1X-Em)7KJ7 z+W9dOD~qTK47-~AVbv_-p}?9*se9!drG zN&wJ9lV|HoM~W2fbzeGE^>~n3hH0*O5mB-gmyRX3PYk5kS=zMZy?Q6P!yLF2373^) z8mR|Sv7`sXgYU6Jh&+_>miTflvpWS8G2p4+Jh9hT4RwO6qg0H;(K6$&gagmAWrBh7 zB2|Le?MgwJ>!A>?#<7Strual#@jRk!Lpx$^z@8Cy;oY%zVlNo`rZ0p8xNAy5QVHk8 z|01M&huMMF4@TXYoe(VpfteYipDFYJ@jy8gk%vS6-$zXH=Nd8;eXpP1Ki`P=ZP^!R zsZMn_fq(L9zghMS-SjgvQPyUtea{-%TA{2ei$?lZ_RUozaFVH}EiGnP>zu3HTl-ve zcp`CVBdt?VHHd=ws`9l=m$m`o;& zPqv+|&E{zon~CEaDLmo>#^iy?QwWsV#5_mRxp5 zOvck~$B&5j+vl;xLVjccg}1$!z9?c}q&S#baKA@p&P+QYdgM!)27Q6{z(3vpRty8bJrq$@0v1nNKZ)7 zd5xMb3Z7pye5OM48?zm`X66dG25+7CKS=h1rv`rosfO$sTPgMuR>}P7R|)uTCRNZ8DwSj6UA734(_FRYysxE1Q-yHtV>a;M)cF89qZP_hTJ%|6e+O7SE&Tzigiz>3M#+My&HwQ$#vshMHjzaY3=gXEu`c>rPyzI<=JFB|esOxfuR&^JA<*uep?E_p%D zaN3?$f)}?sESCCDtee}eDM;)xl4b7(VzFPR0+A$U8?hwe3t(~7RhVL!H$NpYS3%Oi zPGOQi&%ZH#d&rHc9-hKPKbE3cyhQ9D0*WENd<20@6Fl>G-qXbRWX7V{i)umjkk9r= z4087^39VTP+$7}_(zy`5eKNDNx=DVjIKD@Cq+It?B;QNInK!)zd0DD1d5|uV_Zex0 zWC>ga)4wkVhHY5J%}Eu(cMA_sED6+)=puFBij?Gl^W5RGrQz4VhfXXohG!@PyneD~ zP!uC@_yn_A`Kzm#oI#u*%@WZ8YP>HOdh5=ebeK ze)U%IjKhS3rj%WHWb{%Yd-o=FDHwOvSMt^6>!C@UdTroc+3<(f%xe5tSw+*k>2AtB}w+w5gYLEP`3RLYVUb-=tr1Ny@uJ^U8HXXKmD22|mbj3sTw1TPZBtM2Ivchb2D2L!qZsSZ9*z>^W+~ca zW6py!?#8+?2`u&0fH2%$iM^^o_xuvEISz6jzQjB|T>5j>0Vtnd?jJJ{z;|CQ1qr~6 zX_Y#8a;(wI%=L&;h{X~KI0;cY4Bq{a{oS%QTN@ndWN9Cyg{x*@V)!04qWM}BmFn3x z-(l{nR}Fu5`1Sj}>;xPxzgI(Pv~{FTipI;V`?NpQeV@pvBroEsM7F)=OsycRvN@`> zWNCG2jlYBbjcHDTpyr}3o9v`=M|QU*R6M;lcsox{9p-w4lB_hM%}FClV|Cc>>Ha|P zh4}u*YVx(hrx)eGJAV;cDg5#r8U_$qv)Kx%S{UgrI8c- zn(Vpaw=)*(ZyPDz0=lP7;F*#eKCB4=E$J$01u%f1??|6}_w(MJAMBGn$=hFpPxB?X zO-Z~x0xOG90t{V>=x#ba>Cc?htQj(F{zpVfgd(l?slFB7v??FG(g>9|4Cms*cP5oP z4exe~bkyie$TrkyUq`Aw@#biD#o?*X9vGv9feL%5oV7zC!7avhkYU@RnSN^9D3&hM z)gJHc*J^eQmHjIHa)fJ(SIE)F&L;XVOq1p-U!H9129d?Ozd@oNDZzg~c?a@9QwL&O z8TpVK1VJsN9q>*ND9Ukeq?XaGZuty+Z&v}S4RbDRr=OZ*%-Yqjven0<8{S8rcybz!s+I5Jr?MoE0$t( z4ui;O3zm@^&GiOd%G5U7r6{r0KyqP@*GrmvbpQt`)7;yE!=`wn2m?zGQZ&Axcd#Q0 z=*5K*C4;$(=1t$DTe%HuOKJ`p(I(YyUnT%1l<4Wx2>*FNXl1$%(zSE4w>Jb~La>nfo)c3IrmWeanGRvWn^r6q z%s4Ndc(L{23KIe=h2`gi_}ia5E}9ReUv=??)~Sfkw7p2S4vY z1mqu7z8-Oj)+!zS*94t`qRWBIL{gmf{VV+pApKS2fRoZWvA?Z>N6$S04~fT+?OX%z zB`Q0Y#9dZO6iX$SgEj96)Tu}MJl=qJrZl*d5S5Upy<;~RunRbdy4lBr_G^>11X67P ziH|==1{TkT%`b|r!eeI4pWhM`TZ-3sEtEjaY$z+OJ;`}zD>A1LR^44joKa%Z1ihBi zrjQ_Un9>u*G`>LEruQkg%edaYwIXuIx_3dB`?nHZ2jhOq1cNbs8A^1M05X7CwVuK? zzJEV2!#m$kswE8fah*|u+`^4&4&A-Yd58Pw3$O)s*whw7L}E7J#}w^h1v#Uvur_c* zF8YIQ>i+Nt5|#_~WNx-lfZb(*v&Lgo2xq`_6g^>%y(M=R<+6drdwk0_1jx{dM(A%$ z@jk1#rhR=!cJBk5>hy8|FPYdpJ6qu*Q8!ic}x*6g{6o(?9zesMQm1CbISn;B{ump*!;g>9~ucda1 zF@kDW#LuhkBL7VC-96T=`@)>3fn@aD3AW*&mOP$oCAnxC`v=HZSI<9Q)s{(1JP zbN+)*by^Bf#L^`7r*&7Z$CkR%QSt~N{QS4uSf6r2IpF3B3}H@VM_JevO1^4I z*o4ZWkMwi}V0Yt4Eg4I^2k_sKQc^m{2F@CW9#XVys@gqb-sMvCR8!wFC}95f=BC8v zFg=F)u+_Pqe4Kfo#)VU2sIQ??W9wr(bJ~Sss+Q&j>%OFA=<78($2wAwxJkp$3 zC^VzH0*~V3F&+#yac!s`!u1|7*zMFwgHq+*bSDcWT|Lq6gh7T-cd(dvjF$d&5jrwcup<$<28OSL;O1 zhf836urr&ydq0gD<9g-b?9f6$7A)^W`cQj>2Zj&d`n!kk!27%C&p+3Jz1(Tw$A6&t z_8ul*L+NvQ-VWdw1)>HUXcqU^Gyfhwn&DW7`q%m|25CY>Vjk|Uz5@^UpRRoIxxHWZ zUTe(Cr@hju@T#)mZ}G*MFP=`9KT4a4e$J@}b8qqfPLcTzpBoo}k0jko2hjyU5JCZ9 zLE#SsEV|nP_p`tO=TTd^ea&5KM{tM>{q10h(Bb3rwRk?z_T3Q4@$+sBrq+LP2>!<& z@7OBlRu+B18#U5JUmIez86`k9O-BOL+snH{K2X6FrR{>$%Nx|&T7)tdo!kKYI_237 zm`|^j^o5p5##mhYdj5SgN=g-Bb@?%-G zR>fR5!^0cVl%6DFCNMS7aoCq_ds45HO3#{CcRckS|x4B-9^@4WkIol zpX^a15rqd9J4NAM?BBDEzMcfjOkv}PD~)P!3OfSWAh?>yXXl$s$b2SEoW^1;Cw0@Q z40EyNa%FD;ppZUdhXnlkW1CB-s9#et@0`{Hm4-agL~lR0rO;eai)R~pCt9V$SE^HO zH{_kdXO#%bZI)H#3Yef8IKKyQUPY}g39KDJ%zz%=UK4${lo z#0`&~=f6ED&`gk`4kxN}%gR4jid_<%-stjlf)X3W%UA(%(&wmH_IrF?EdedZEYO}W zgsh40Yj9vV91GJuwSk134&?hC76aK3dibRUrrxpc@ZMvR|7{6w)bvG~sWh6)yJ&Tb~PoSIs@h{Uy?Tj#TjGE#i(*Ca|S> zcl_LDUU8Hkbf82!DG(0|mSm^s;0+a}Hw5a86XSEd90%7(T=ehkFy!ji@FIeJusgu% z3=tk*$KoD}-iy&}96TOb47qsvpP$jiVfHnXq<|C!)EuyUV8L0FH8EBNyih_#)NyLO zOf7DM6B>nil7Wc_Vh9RhnmK?nx8xBblsv)UbQ?aly^&Jy_M zQC@wk70&!KMg+klFfq&MPi@1Np$!oAR2R==xT9;mjBOXzAKm(5Jii`G+IYFW`2O}1 zsScHxLer5mgFI<*&tE2Kgl6cwa2wF`s2ee9c_Xeu6|8B6G@=M!!-|h=7pe<0@{TTp z^c)_zCm=eQkXsXwz=j`Y9XWTPJED`#``egDwZLt7IujWjz359n9Lpj`7E21*2D`U$ z3M6Am%SOSXZLddjG`q5KY;X2q(yqnu8nMS)W{(`d~n3v z@s|#ORd;Igs`tm{FP+K4ts0YA=qd0^if!)Nu0C`8bAk3qMLryIiin>|AA9cuy1=o* zW@L}Lfn+m1hwW1;3RViKd`@l8iSlHv`Pq7$71Jbbcw_4zalvB%!DBeOv1STY(@bLN z16;Cp@m}Z$l?-_E1b7B!1OlmJ`DBjT3o~FZVlvpT+aPFt6oMq!h%WVL*a$OtNOL=- zd|li1-}NA<(Gv^5bt{8S!)|lM?IBVT`3l&~nwl(wV}E-^4f{_-j@yHTKaaEUA4}V; zL7lA}uMehZ!aoO_))@w_An)Y6q7K=qkYhW=V-se(bst4Z2Li$3}!Sf8*8vuoexi>RKqU( z7Mc#2%=54_hsD{&_KMMjzOZfUzNAck`m$}w!Nw8J&Y4`u5h8~&3yF$rTm|t(LP?@~ zBfq3gh2hOY?!tJ}FbE6N&)Rziwp23u%|=L4-7GI^YOdQ2l324xSt!t_a!f3T9mH0{ z{koeyk?jb_Q^r{#Y-AlTTCW_gig=u1#Puf`L6m`q;hM5LmTOv5x>lVk=O%M(M<%h* zZ16XxDHjw`J}>l<>eRSPV?~Rkz0!=2vni3yPQw=%jd4HZr(>A%Xx{B~)E+jUAPCn= zO)#XI)pG=KNV^Y7p=sHoR?K(j{+qbPz`CeeIH_G$?*NcpTUDw+B*6$hpnx8a9g;2q zmY`a?ZGNdi0(hkf3CpgnH5Ga?GIQ4?=n`MkXx(9+M5Y>UY9{NCYOv@m#6)$69vd z6P0BLi`?cR#dWoA+4N-&wHIayUX}ZWGyXy{n*Em!I+z4HgK6D9WE7Rj`}^D7N4(ow4kT+2!v z?DALI>eWVh?OS!tVpB=gT(OTH-N*Z$WB1UCKq1QghLSodC#g|U&*X@@cOECn&SHYo zCbRgaO=l@Y1XvgvAjK8J^nFU;Ub};q;W%J;$L>NQ=9XZF8l?cL;&7UC)*zus0@V=g+AF% z9WZ+bgvI%lh8GY|*xdw?=YyjPt)J-FmaN$YTeB7PNGXh5 z8NU?RVz$K?eefJUx0CiD^QQcz}y2dhFRt$e6ck`jpVC{{e4; zi-Id9*EPnW(Fu`r-ky*AWubNgjs7gQBEa$ns;5bi6}nCS+t(D1~-m%b|qF5VR|V0kbf!f{U=KD{^Agp9cwPWP}nH%y(|V zXX*`hPtik{xOY$|A%9gnhnXPi9ib zj8Wa6dsA8_qD2xC>C8}m=kt3a#?=V3ho>u3`OVkz7 zv)D0bhgqe1I)@}{co{^6=h>8zqShhWLKp^M!W-EjWc%vvk{H=R&P{*6HZ7nQf|Ej@ zIu_H8;J_UMwPu~LNRz@5e0c!t3zUtLaB(!szBnsH^aKMq7EtjFIG?o@DzfbZSa_}s z$L7NH4N@bnLCY1|R0A2N2m{}`4tCIK#W77l!>EHQWPZ3#Jtp=9`#mdATzKP;pZBRz z>2(-T2_iJ43%1oTG6OnBFY*u~Gu$8Y)$*oB1=MpthJ#ayi-I$W8$-s__0JRIHuP6G zP^MsJ>(O!jJ=+BAq0FRGQ0S_dG1`!}7$Sd!BMw~_SONY8~0O!v`v>|Go(hlMF=agW!=sapd(ym}YFGAghr?}*=c`J{u%9aYRs)fug z{mfvFz^+_c*LM6X2R>P4EMBB-F@G>HkVKllgPUOD*fEHQm zPq_GPVNde+Pxn1cVWfMD`F>!Xi#>lE4!Jb6?HuCOm*o13s@un`=FU6T{~V^>v!7mL zQ(W_^7h{2E2V$k(t>V>STx=Y9H$C{Ql~qdPCt@rGBbL`en#P{-tXq}O7TJegs9{M@ z>#PI;OM%D0-t(J%(uyIP*Glt(U*!y|^T`*&9SojCzA3{|J5|WYtfql|N5gB|d?rd> zzHNJ}SE$@M@5v@v>{?kvKVq6+?;sbGA2uVSs#`u~?i>07JVdrsj@h4uyTmsPIGTi^ zH|iP?S&je;`|cw3M$&%c(6evXHQ{iYn+|pvP}liLht&#Icge3#IBIx=<;%Cxe3LCm zH`9QWtGK$bD=^!TZ5fY)w>TR502nSKOqGw7l=v}6^BP`%S+LlF8_a`?2c|ZRf~F0r z$HH|@CJ>M!54vA#CREQ_*1$R~O^K@4s}0@s9(o)&`Uy}lOUR`kvpx-BHlSudP%%xa8$JOKR$rYwQH?AFgmS)T7=4q>xU~d=ow*YT96I1M(-z=X`qac2xl^T5W>hCMM?=Ad4jGbeXB|w{Pi{0fe z+qP}nwolnzwr$&8)+u(`wr$(i?e|8^jkq&k<_~0KM1IJ~XRq9=i*gzziA4PdnM}cS zgIKXoG!=~~IY??HoY|42HCApdCLU?HZJGY5$xJQ-Kf+n!ED7pNBDN-bblMBwf3F7b zI2ILADdlL&rFfEWlyDDqW~km$?o|;VnKDjPR1jCc6xZ)qau^x&Guk^GFf*7U9&{}AO>W;D!4@Hu|cKdiO!2p|kO zj+u7aAIzZ!_K2JS4i8k$9e#K}v`m9JyA)%vv;Sd$?s>OLMfw&Cb=%=WgWJA~XgYXm z5}gzt#4WT86NZU1FNm1X#ngibt zUNr~rmK*i5nCJeWEyWSMq<@Z%3v<87}P@*I|glcFijQz&;{2c z)O~C%a_%|05!C{tLfR5=kvg3fMbKn%=KpYku_1H>zulQ3IN8=;KKmOE^?3&MEkiCm zO&}!k75~ybF_PPKNJ!}?T0Zk}*+$q^5hDW`cp9(3Qb=e-( znjC~q(=ZXuRH%hwdX?gOyQ-BdR7P$p_y_4)4W}=Q0&m4ST2>>SO;{Y7$++S6e&w6^ z01!saPs*DZYbyaR{Z_p~XGI-fHY6Fb(jP{dO0>;}Sc$%gUJ(N5s=zx}=)(z(%|G&} z{%fB1xsFz@?GTYLZ(HHJIBHs!jCx+XOuVavdHw88Ki5Xvt=_ zjj7BL zahwZ6I~9UJ1ywCRKib63;Dy}*&OTw;Bg<5Ge(AJ=TU?*_A_9U`1KvbY%7c5Z!PiQ` z&cL~6WArLc@d9G0v#7HuOm_F5tc@O#1}h?9OhWKh^=9k7(|j4OZ;<9u$Ty^ewEHlG z0x8O{-`rSXl;$U#&i4JyGbQ(u9=vsA$Hix&4&eEXHsV^n^(d0U6JiD=9afj>rG#Q!uL?EaAPJClSp?Kr_s~{u#$hf-Y2kHx z_;J4rj4uN9-LPd4A35{dpdo+6l^f)(T%r_}E*3KWIG9eg=hWwyaiLGHn0$lI!vzby zRDPwxQB{Ca*RL=vP9%OkUy6kHGNr;kuaxnOtam+UawDzm7K5m!%9lBvM^5U0D|ais zjYQu#cJ%7?aP6G@E%xUXSggTi30JcwuJ$6IIw)MNpY3({)AP|3{coDW&ia(u`zrp* zYRZMV_58#cO1sS#>;tprvXDko@~qNVb_L}=m=3=s+bhr8G{cx^O+y8cHm|^MGK~C6 zNpnbE2S(=0WqnUAJ@K6iBMAcU#P=>@h;YL(9XI z+v8;GpaQc2QCHZbbPFWU#e$E~1&xHF_OBb4wW<|1 zt&~7OwppIw50_she;{vN@TOHbJb-LW%y5eUO)LxoH?@H4npSG4xOT2Djs0d7L%}z` zI7ez>{GP&oYRVd>S9t>u6OZ33^mym$7zKpTd4?!Yq~Ii8H#OD^q;K`=kiIuCA>Igp z?EctdwzBETQ2Hu~vjy|3BSZBYEf6h`ymTkKIo1A|TJ9-LUjx&BJ; zh@-ME^XdJ*;)3f_DH&R~HVy1$x1C^{M-2o+b&K53EsY^XPiLGkOI!}E$!>clseL_m z@jM#kSfVGMYof=r%%r9q=eg>ue=7_`TW|f?t#Hh_)JNkH zzr&=jejbzz@h47t9H`c7-+D{nreHcuX^4pcnbho&+J|ptIzGd0^c^X;yb?MrCMw4W zN7V)cSYjQz?QhvrLS#4-{Y5)1yOPP$hbhE8LiNE1@B^dSmWFR99)xVwzZd5iF6)_D zGr$2s8z%;-9n%B(k|BAK9X|*nk-fj;eikz;P+L8~KzK&%H2kiG#r;O27~NI<{78cQ z4(0|7+m}!d`Y_GEMXStRD|dvM8oD2YmBrel)hBwkzfrF)h0B4Zze}5Omz=!=tn>K0 zEh~D?=NBR(#%;uaVM+kQR~mV}JCXbeNqc{uW-PAiyHf zIaZ4rjXOz78qoeu20g2wLOl7JKi*=R=QpjjNv7%8$xaOCy|w zJa^IX8EBe_7sTyj6kDzMg6mMktq8&}ZW3jzTxzJO6rU7`%i6GWt*bNN-@o+kw&ysD zQTsa`v}d4)Ts*zu-%)KE;$Gs->izMUA*=fF!?w#gdkhU%Oy9qd!wvP8nbsq@+*O;) z?(!ayt{ZcYbogvt>L^n3+co%vgo1shq-a}et$js6dFEe$Ju!zu>(*xyuJ!P1F3@8I zP$8i=&;iEg)&Ykqa&JWlTG+QB+GtUc2OUBETk*cei(sxbuPXYutMJHH;H(6UfKt`2 zf9x^oIZa)xHNu@AdWd$uB72;2e8%d_Z2^O?$MMfP64B{1F+%aQhz`v+J+HpL@FV-> z>GW3KoV~3BiE)|S5tH29s#xs2E_z5U)_vqI?Q*V1}UcG`YS}FLP0pS zcTVKiDJ_*O+XA7saxssdl8+sYjGDVAs*ogVl;->E=BTZs0_o(17{&$(Gk9qsB_FqR zzpzb6_4LH~IDz#giQDF_yQKkwiTxJUvem7fb#4Ait1>?Yu>L|?YmjB53cBS8VZ)b; z?SQj)?Z}4ED&i8De*%-e)zhP?=o+B09n7=t9X-veud|l7c+?PVJQn z$kt3C``nR&%W?y}a-%g+9v2yl070XeCI4x3p6*mjq!ESbj%_~rIW1m)JyB{!m2e_m z)>aXxShRUoH0NT4LTz&-Iv7sT@vp+2DKDq>bXrt}`u+~)7GJCo3oN!(h+RV=ELJP| z)m0+_gA%qNUAT3et}>@Z-}5@;2IOOV+5JLq88yHZ!)4{rrDiEwh*AC591R7*1ozK6 zA;o_R!1^1r;a~875chM)BpWeDXSGibb@i6SBP`5h7Qo7hqfQuBgCnO`TSp(-G7l}K zJoP5)JIH2ehhP;DZ#tBh7NRAMCMpT$NNUOlP=P|}-Y{Z`zWgT`sIz|es_;^F9jJj1 z%opuZHdC)Zf=Sn+6B{{~$S8Q{ENV5Iq(Ae)e#6#vUl;i_beqQfAUpA?_i@5@JXW=I z&RdYBuVGI5%6C=)Jh%!f50orsvPc$ z11Pj=#`B0Cym6{=5rflOhiD3kE+9^pJMk;I*S_E}b6F@A$)vWf?}ls%^^yGkS(lGh zc<;ZaVG?I-06?Jhj7VfO4-TysHEAmC_GECIy0j|qYHbiNlL@2Obv1+7J$~5~jQ_%{ z+#z#o(dfG3<%uTXkfNAFz%lsXD-si_G#K4@ORn}8mUzZI-6+(7lRm27nv)^5%v}Xn z(z-xhFO^4cUb{AlaYiFlAHZDxVcmA;~?y#TK4fll_JfF#9_(B2|I zpf!2mM#dD29>gm)Gk+p{uh`OHjA-SbuR?2n1)|YwmP%Y@oV35nBdzaA-!Fh{frjx- zk6#sV40T&k9Khu&;60QW>>n!-JI9vxc6AJtu9NOE0DXS8pjFn#74^I%uNr@7X$>JY zH&e^8=ye_#Ye-QlB{O(TLx@vy_m`6a=dG6~RlP)ut?o68Sk1?50}RJtwYw6gKeu+l z5i5^GLmRz9uP%#Yj7W)Aa!aKS*FEcgI8Je zt!v+72*YW?^^w7?k9D03#r;6a(@ZI4sk&ZPM@o~@D^vJpCY)V-W0y`hdlDUmf8SF|E z=aJLEv!ydp0oTR5nmBX1&rG_-8=llm#cI^qDLw)PJ&0`@N?5i?A`isVwnEP>y=u~A zbBsHY-5>=G0X>|4p`QJKlZ^W?)S$u^7+*~+p#`k3I;fQO_X2WQt2lrNO0a7E>wWE* zl`!eevZ^{ZMfp{0dJjF1-|NQf`T84Fh9%GXf8s0ur6A_yWMuv?e1-KtJs@4==>KVf$t?%JvYD<7wMIg|t3W zS!s^T*1WEVoH2iiC~DAH4QN;V)ua-`&J*%o8b(n&wQx0kbG^FSJ+(Hp=lA*R<8`!h zGbhYk;EV67(WbXtEN(a8e^dx=0^-skVz*k({(6A0voc)u>iXS>!RPy5Xf<_GsId=fs_ zhZB1|;r*D%C*jS4Ww&<;3~g_mWXlfQ@Aq8;B%1UFp)vC+Sxn&E5__nT%NO=>yDZtI zzqB{GV6h17fkn!3oZEBT>=usOmzf`9%u?HL5CMU%Z36Fk>iM^Ow-=}!UH@jfj^K#w z?&58~bpo6D*AqnF=onc1HZKs&<=#752Q!) z6DCChX3yYx&NBGhkNWS`e>&9*I5>d}ysxQHh2QlF-2g>`OOlR->K~aq#kLq+9})|9 zE}?#06APKC96rKw+lt_s-#VULi3VQ%O0Sf1@iAg$UE3tjSm)UL0rvR%U`33wtHlO0 zlHgx8bVtv*zJ9r3e$;`+;JoC;FUn*O`t#G#lw=FRAl2B8b9TRAEaDkv_VALbIme(0 zS0(?L!^sDC;O0!e>8{e&!%xL#|Vqb6J? z`eJhKpzGA#;j*BK0}k=4hob^-=?QWa76p$yegF`{>9q}E4eO$aW^tTZwyr3> z5P`fIch0(#^Du%-_wow;Xl~J2UI}V5+KAilX@jjAz=k73-dl%Eh?)Z3p>Temt=V?4 z-}PsAEg}L}ZpZd3W0XIsOd;_m#gjZ{p!mE$|EDa(P>dAP%o}emQT3uK4|$m^Ko1Sx z6GlR1FXtt#*OPqGAF2lx9;a!Bs$9UuvtP|@Zi?XK&`T+f`GrM)a2r}hT)No`jvD8@ zz7T)7fL_*%W`3{5#~-?}LZ;t!AMDp!T4Pq_8Y}(<*@C!Xa8nHj0YCXYk%JdFWulk6 zs_v{?4Bq2%WhZ=0>>3IF4??Q=xHzw6mlYR1GEeyIL5IJLo7MOcWCKRoJDhv%F72h@ zA#G7LgH+Gy7|fY~JnIBH(S-_Y-k%+#Kju5BCV>HfANc-Ea5~y0$$5a3!A6w#oM!f? zM9Xdo-A*#aKjPB+21nZ&^4^Jym_ZC@r)gx0nl!fcg&Br&4T;YL+A(IobV}`YhM7Lc z^}~ivUl44e4`tVL1Ea z17Wrf1q@>Su=$9&Sf~8(kF_&;aAPjsJZ`Xbduw5!uZS(Ge`v64uLQ7Fse^cgV-pPL zp~+Jy{K=DLLviAXJpGO47KFM%PezDohNmqw&)*kdBNa1;bna>82!&w?01nMTl0`2f z$CzvGMl!wqMgo28I;;0jvd7j5AN`BoESn&B$^brtvk_3e!pK>E?XAz2FChF{K%~E; zH_j|+$XBn{3YtD*Sxc)x&^P(7Z-memgbjUu^7Aj8K#d{SkLO>lJfF1kS7EXYgQV$Q=@?Z3I42tRB&Q|51e847@-)lmD)^aLEQ zSjIxJ`LJCeO%;0aba_d+*J1hK`Ys2lWrUiec;sP3KN7#}QwQGMeL>ojLYO&cGvc35 zyB~{?7xM-L4yt@h%r6QdQH5gDIx`}x%~5usRB!26zU1=Gv4eul_LO4>S1gE*j{YjL`5Sg)uS|_&a`Cz4sX)8v^mvPX*k|f z}GG-dsxNq7_kX1_{6};(akKOf_HZ>oh<8pB$?s zT`F5s?yBLr9tOc{D(ocOW`fovQf+1Q4*lWxkBQ^gLhdwu9(y1=eMy2vStl5+q+GkhxF=I@qlG<%xi9{=`Q`4;rfbn~C`JKAzI zL#c7HUYx6QZH2_kxuba0J_wI^hR*tpC^GSZqNI-hPgUVJt zdZMAsa7<;=A=R4|{|&W+HgtGHdhk*&l@L7xE1>CqWa6(AFLAcGnK}TNGcHBWv_%@C z{YuaFi^8&CI4tw2f>e^xTrE=bmt;!_U(S%34*d2eWDcRMcO8j1FEsfr;;$8G9H>Ll zLDmJ@_kdX+Y{iWTQSiAarO5T=Qd>0UIEI1{nO4*f9YN^`d!)#z0# zq~C@(%aFtyb|tthw0p|~wxo-{^c+$hB;UZiw68!L++}zgMO7g`g zcb>pm*^0VtSAn!$RW=OGGw9YE%x~dHc|{ndZ4sS0CgXTE4JMI*XAMnLXIO6u!q+Sk zzPolPq8(xUCUCTg9;cogM#Qdan)E$b%@d)D9$mDGwq~dFlNyprv(yT0=;gg5xd)Xg z{n9dXt|p^FsCVO2wvb@ZtLmj5^aT8>6(_Pd+m-$M)#+pY1W0XVk^RkExF^G*?NTK! z{pTbP{JF=(QkSD@Zl13ZzV1yBdt$_>X;g>y8+HpmrF_VPwl@fmzd1%@iMYKtUhHx? zbgg2hOmo3DL^si%7@Mj0flZxHo8bvtq>(@SyPg9H){K>c*rDH*_$elid`}UlLeDTk zua;$~%`zffldPN@&hL@RySnbgzNaG}`A00MlFpv3Ooz(j_6+BDE0%qCP7b2t3YE1L3BKrLBiC(0GXC}8+C3X(>4S~CPL?oJX3WC zy5fwA3jKJUi9+Mr)gNgKspJi}Kc)U@!Nes?>%#R4Xdz@uGZ#QW7*E{Ijz60769Ulv z32RA7A50-LeKBZ2Xr7uH|17ePL3E?DW=W`yZ$dxB7#*IeHm|YwD6h>!b((M9?Z^1w@8kE!Kl0dvh1)ufY z7+;W<{0Vcc53$6!83PI=!^X{VLoXqcUq z#-Ar7^xrG&p3x6J?9LL=zehIa5Mh0~F+4JXo}gFykbs}<)E6CUg^wlOYMH~xcXNHs z88`mJu$L!~;SFbZvUOteqOM@4+Idsh5mBXvG}u8($KMI4x^Gzjge%>8CkX!r$F&$VWj9?LoHx0B`h%AiaDU61evAq417U+U;SwBDf->OR&R4 z`t6s)_i<%TxP7D)L0DF8c0i%1EClw< zjHH~%`S>TBvx&!png@!yQB0mcTwic(L1H6}EEHEtuo~qEDYZ4|u|3&TE3gqNdi6!r zb^cJZk^fDlUcaR?E4q2u;At&@!k!YTB1#07*5kcwPu%>t)wN9Am0Lw6vOh9p`K}zE z$%_`Bu^dfOUcOUyTs62}h3nU?cBX#9B3f*HM>%JkG3Jtv^Uz9RfkLX*+RVP~X+lGu z=1CY4FlHPfVNDk#-!$6d-@NnW~RVD)8*AfPi`0K`>Dkgzq3u2n)BB zGt&bGb+lHZ)0s#G-Dgd{d@1ynPB!*AX|`yNp=y_+#iI7}xHJ<(Uc} zH}JJ8$6u1DI}qTo0Oa1snJUn^t4;5!rE_bVBUwf$?zfkerA7!pYbW77Z{ zY2hXuB1xULf(FSXoWjR6T#GDmu=j^Ji9V$_+N|Nyit4dGxPNG9B|CwNS`_7s&EpD9 ztdTZL1g(7jkhZz%ZPGlazr(lS^(u)CQR?}-0HoBG2~DIn0+Ls$ zHPPPS-OFPZN9q-ALToKsX;TKFl(MOz4zzRUm0{3Sf2PAv)U2^rT+ zga=o%tQh;KL(Te0!Fz6ga^uN-FlN%Ug(Ygqs| zl6}4uc=hu8xLOM`5$qswdSVe|X+!4@2ety8zOWo~doShlnDMNN*i^*$A7)DYAcuUv z4tnd~8F2M$f1Ll)i|hYPdGxFA&$+taaGzVH9=3Y^!?#(YrrVN&{`}Fma33Xt-ZD`Q zmy0P=ma4}%ahqH|MING?tE+PKN%y;24@i|BtJj_0`#9Cc^tROXNeOwqtwKkP};&B3nnqR_(2v> z#O@ASdrB#4WVC(BS$1PP9N${RwH45Ry^ZbHDN$N>OmwmvZK=)n8XC}B#~1_e%h3*5 zWNd94p%bu!*o}6TkeLLnT9jUhs8bgUgo*W@gB??Cu_hp>_}a((DIHoY9H_Z0Qj@v|9>2*)|edYlfYmF+WA78M!RmU>N} zuM@76k}6%ufhr912le%j zNll-AS10G+#AjqpW%{H79EFfh6EQn9WJB_n0MP|$q~)K1y3Z+hRV&tdvA1xh0eu*$ z`uQ+uqSd-G)WiBwMVEc~`*fIf7~bkR@$s3J!NmXml)C7xhBRjf=B-uA$cEqZWkSm> z6WHW17pzXN+`{Yhj(caDl6OWix%N+yGcV*YZSR$@_s58r7eRMnxy~R6amG$M) z*kSPB_+Au{+jYm~-#1jFotX@yv^PZu22g+0b)BHxgiUmEXP|0|9k`}$-k;7k^o0X^ zS<0kDVE}9ja8toMhPHkl{RQ7g3n2UKfVLIT&^@P2pl;-!VRDYS82D!0e0Fv^esIRp zo^}}TUJ~7HQm5~hz|<1h2GMi|&TaWCQUZaZ#C(i^$0mmfR)q|PF&sl%%8lYg5u&Od z&C8gDa`jfJ{pXF6+bYIN3~l3?KQcr`xd)Z=oWpux)OT8k;#t7c$1B*J+AAiFpwx6l z`f7(8h?ilFGQyf99!(6HCkkav{rK_7?^QrL35{x3(?f!4{|9$I=F79PRj_vTV2cl3 zF_3?ld8HSp`XpfxN2}tX7b(|NC)T;k`$+WX#MjN!`LMQgxO>X;6I0>UCLH_wq&(|* z+?N)AqgzG7Z)t42Bn5B$yGQjFDW;B+3u7X#@>9>u$iur-xujBBtezA>?1~-tUGlcV zBcm%FM#&W2Loea&6WdFPP%N>Nq7p=z4 z5A0l9-|lK$7E|-Y9&nC=zjZ+dy&Bj;{W*oQNu%X|h!t2l%9d3!9svKW0`SNNa?LM$ z>^c)h3ml^bRI7sP_ma9+8skn6`HJxEmwV%7cKhC3bCKF1a)=B_MwiQKEw??a!_m7u za2_|SEQ_Cc@2zKa{cOc0G`E=_^-#-_o3T{LAT5|2xP5KMn5Vvg^3bxs=78J4!(WMC zhB?&Fj?&uz$wR35xMw-E6k5o0s)AdS(L9rd`Kzmq>jX!O>+-4NX>Z&*4e@RFyq3_tilJjZ0jQs?{LoJVwcZAkHdc0VyC zLP)wI{9jjku1!$|s!&FANwRu2Rki@^t}>Q2$*ArwU{@Gm({EF+Z!bT)?XabOIC zQU20Bt3pg$Q8df`+Zt|ALRD=5l|G}>J;2%9aplpWtn}yB{5F8uP!-d>4})X*pzvyR zFR}`6Uz~cqCQ7$sm~DTL&Y`;bL#gqIoTB2Sj2OjpH{3}n&reQC|C=AmRjV+OMuZc( zWH#?nl*?DOFDvH??A381?yfOt`|v5wq2?nzt}Nr^1`Lj!l0u74xRpDlS*)cceGG#O z(h}HH`EQ_0zdsC|$0%C1^G&NIt}U^@3&1b%1ei41JMEeEAIpT0RPMnu%pG?PUh`Eg zlAzjc?*&{pjkkwf12I<@(Q3L{S~vQJ7~j)tt=F1A(rZ7A^wC$$G!~~sj>G_ra;|@f zMPT0T+o`<9IodI#GsjSH3lUOW!<(j`CAB)wk6z0?FB%cML|tY%CoEHl0(Y|1kE6fC z#Og=HXCu4$sq>oYtSHwDqcvJi5kW)$6$G~y13@{t`vi}P_>5XjeVrfNdH4duA{Dl> z9*_x?h+O3!swILPyuH3C$}K&e@w}pzEp1N?oHIM*K#I`^_c`soVZ6@J%F13-y}Qqx*6qpg)Q(ffU%>s)gsuRJ__$cw5*oe`A;ftpJd6C^>fcs zBB*W3)W!By1U{NW6W}OlIvP`(K%D83!k+`ga zPqB9wLzrcu&j8Cos{(eDL%PAiP7@~l7i+~ujO8ivPs!?*f!X;44+%X`;8wn)DJ9|} ze0=m1OFv5cN8VjJ2V}4QtP+QU&?wX00$IjU9@2)O|3cKf{gR*Fc1~4{x_L9q-vKA; zp_3DdCy@_jRTrIw>h$Yd~oEx?3XWHm6*6oC?3SO7aL$dR4&q_g9B9U7%)t zs{lCqa$j!U%ZKYx8kiCLNhaEB&B%o6rMD2t$2P2SWwk@LdfG*s+MOLwTP<4-td>B# zz~|e?X-m zG!%&JH{qiOs7hE^>a>B{t*M2z2-9rx=*VT z%hTsrdmv`|`FALuHTJ2mz{ml* zmXC13qb@|aVi>AFvj>6d6snUIlZiMNq~V%{4iAuP`)LH<7!1HEr2i2T|KITUKY1_* zJ2UJ53yJ@u8UJq~@qcO$lo`Y=ZJYs4gbd;~M$Q0HfQh{+fS(`cx3d$#$QH&udy~&P zX`?w|`&lD8XC*g+jdcq|k488w>l8fI;?uLSnO?@+H=4n*4jLHUxec#h-a}yA7ya$QwHT3b3>3 zioILg8qw8<@?$@G#zbJ*qAy**4LyHho``=v>5h1n%r05|rkC?Yg(2YM=kFN~dycIE zO1tCvxeBwXw|x8Drf~|;%8Q{Mzoy_ErAg1MK3^jgBFR$`9e!QzLIqO-&KJJOUOyLm z-)G`@gV-!Vz%<~xcyRUneQps5CcpL^lAC9TUO%IPY^xge`@JQ$-3yAhzrDj@VYeXG z&PRJ$1tavu82J=im@dEGH@?&QXW54;L1se9p==+%JUHU5f;PIRYPTOzqzEY8r|V8p zYA`I{5Qxa+{3hb#wO;iZ?#lY58yjb6=;E%wt?~0@Jwt-_-lV=kljJi$@p>ZbrL8bg z6GdYrX|N%&{G;Svaxh*RRO%Eg=2Uw@z86}d;pA^&TvDtEjp#^T9@2H}(5bcbwj z2UDimm#P+8+biON=H;xe5TB*Z(M68bg6MMjZJ~bZ=*N3NFbJ<CX4ej<>ZvbD=$q|~+JFLnQSY74`S|1*7~uIk1&`ebg!F)LcO0=o z2qx0|ce0Ui3hCsh3$-E<>G5uwzEDrStYb(SlSmEHBt1|#^V-zHXXfXz4mP;t1e{UTprI>yLcIRm z%G`8}U!dnPqP>r9nSpGU#2k~<7b_tOdd!dvNMR~2|162JnqVh6Mdbw;F5x+CAf;N@?_($0;`-)ksZg$Ik9L?6n~h7m zgK9?1qB%)kJriy|Ae&n^36ioR>^K}!4r(so`EVv_h=*2&UG03l(`B%`duK(%K3nn0 z#0b=w$ZkXWNk+m4ctGz0GQxya0S8aLz57I{QjLqjlmW?xJwd9K@DVJdrp}R$Z)$C}Bd)9`$D+FF7H7Pa zEJ%$Gs6-ThU6?sXEK>7vK(rus1~eu3h5gyWgVWFpqQaLP=~^zt&$c~FQ>6pyt2IPH zENix{rq=uQ34i%EYZUe?u$*-eu+2Hh%6+Vo6N=~audInwG4wCP6BSc|_)_VDWucS{Dm?o3NOIJh7oAIvZ3~G21zI6O=QP~kBo2rt6cy6Ar|=2t z>DEdAxU~jy|7vYVx1`e4w2kv?Zq91@g;s;~s9ceeR+wk>=#pkaxm(8jZU%%(NL5a| z0!;CyXXJ&Do1kDWUb4!zMHgF6+slO=v5TLOPU$#xJyUZ_bay;N+(db~mW44|tnmD# zh2NgmrDs(+2eKsCSK{#jR*%$ORdN(%vL4f})lOJ8$K24ReUV3t27tCM;;mf0bJUv(C{qhZ@E5FD2D6CSwv2@PI339Z+GlnuAPkrr1hqfIj1A;XI7<)e z1~109qw8&{y$A8TDZYk#EG3sOsp{fLw1^ty)kY(TH)M$!!=*fj<7}D0iILxV3d12E zn^_8SM)Yzcy^Vmytw(=&iRhH^<4@x3&SEFG#C@0?vPu2>k3Y{Lz<`9uS=|u&p>if# z?pGLVP3$i0x84cA$zFvN?5%hfF;eT{2$MkclVoCc`?-2S2y+&{Au&f(FvsE7M!V?b zi2KR(Fwg2Y$d(fdTB3qjk!< zPV@68q2#Oh*@d#^gCpsIgh@@P2yw9KtDl87!$!}rKC`zh2lCLAKGGJfPQ5s%+!}oT zm7nPlD-s($@VzYCA>3z5ipwT=#EG*H6Y?@04VXi@r=t zX1)!CKyoFtGaGf}@6Ug0JRGkr_8_#2YnFoT8nagqgORASmlzGeegP5$^E=(n9XHvw zqR%D$)J)eUd&4hs2{n#6Ce~_fS+$dFMWcAOCJ*`sMRbr9kq-r8nR64^FVyTPF@cJ+ z>--Yy9v0?NntDgR?`De>>aV% zo2Tiy-Y=y60RfCqj+ULd2_w6OlYD^Zzhixt4D9p4Uph2m(@wi$R zCs1I1`AooqmQ%dDwG^ifzGh+e&3$MXgFvy~j9F^^&Som!6HMrp&#%&2`wH${vt%$< z*;kkHtYvT1BFQ8Qye0rQ5M(eVpw8Me8I9AZvWsD-Lw*^uM5Qe6$nePug=RhKB3JqY zt+fvWJELMI&FWi+z5TBYUmjn$H={_GGDNR{yJSm5Qj`FYx1$%!El-yKJWh{~VS=?R z9v7lkg@*|VA)+7c5PJZla8~cb5C_HrRmyqDCASFjlYoVEDW?!$kv%xe?7~00#WIH6 zvG-P|2qU(xNcCD}ibj%Vxl@e~W&#KFuMQkjAykSji8+owr>QnhxGJMe!ugmElvs8} zL-?&g=L{=h_p^u23CLigj2>+yXM7qTR37t2HB3cp!^vM#RbUdr>Wm~0h7VcNv=Pjw z(hI-$3QTOgFK$SY3KD4>=ZFnV8JWur!i_7|+?D+x4l=Xuk8=wo<1Iz_Elp=iC%DD& zbBzk!23+Mf;a?v|2AP?6F{DI-ul%7@4}^y&0%^QPv>qy?_X|vzDx@K&fl4+qCR2tpSz>=^u&6T8_FyYA-5%(>shd;+EuB${ z4JM-ASXd@oi@%gpQadw_VTDon$wjCj&CeUiOPcZ2l}3T$X&U{uS9ezALs^4&9OPCN z{RIn}vqwxipW<6ik2u-9`g+9Nvk+xM1bZwSVqARqrSCv5@-N3O#2>giJ@6&3I#*9!4I9=ERu`fTP}O4=oNeC@rMqY63dj{f#hIzi0i zAz4_77*Lq4J#6-}@gpp*7r@;t*L_d-GqF~?ww*knJFIG7qki6^J#f^g zN#z~Oi?}VSIMc|1Cn2zC8HGK|H(3@hxj7!30(Ht`>*Y^&)2fRUrhog*S!(J-InRu5 zm@lKDvGz92Ml#{ulR0D9Ryv4rU#~=S&ch}GgERZ3@t0s>M`DnTjzMR8Qdt4Z_b_fJ zfy5)}q`+EAhpuFk&rH90}_$si6`K$JljZl0$CrDQRK=O zro$hr(txRzKns(|w5iJ-KN+#HRQXYYEfrX0;d#380?4f^`!b>O6V}f1W6bM8^)+GI z+HAzu*I@UAD;F>pz4=eC36mHZlEv*0Mnco~?!q#WO5_Qh+f{D(ZYO=OzA?_lqNs?R zB?&{4L@vinKD%-0r-fao&Vlx066CV`wB>b*bR8JmoyrPF04n_{-i%4ZuSih&|HIfj zHE9;8UAAf4HY;tr($<@{ZQDkrZQHhO+pM&GYWIn+`(j^o|AiH?R>Yd)8FLcz?Lh2| zQUQ_xjq@QDxwDi9kH(h?3@%T@+){O!Bk*W2R3<|Z!Mrx*zuqU)equ@R)Mv3RCWc_6 zD{_hyip*dQM;F_x^X8oTOO9NSYX(jVm~t3(y9+W-89Qcb=jRHkvD)x`mV{vaPB=@X z1R)V};3hdXg@&CT3e(6a8PvfS;l2WJsV*Ca=F_tuJ93G4n}#YbL8UNl-lAWmnJX+zL4_p)^Sf&7WoxJ2amrD(;LUyR zpZWn74BQmxeT3p&w&;whfnu!OeSQ^nKC~^SOrBr{)3_X9^5?8)M&V4hY;Mjqwq;x}||V+B%7M0JC6F59HSI6fUU8=I?7_Aa|vJ<(iY-Vktc@`X{>krMR0 zDX*S&DLOiPPz)y2@B_RJSkoi@IJ8F}4#M>!pAI14+!tgAm@hgobM&^o}i9dOK^~{V5V-a>^)t>4c*>TMlXLcMIUVO&gf! zBkK@*y0 ziY7X{k4!}Vy1CI8gEASzfKRj;) z^Hgx8Kfbbo489b-aXnT^1MKEoV9=$n-})iy2&bSKDrkKYGr%>${U7k7P-4>1l1wcG z?a*o~W>wW#2ERx&JV-eaTj$1dN4(gSl~?|b%RhZZujGi~V@Pe+(xR7!dY=h4>rc*I zF2%9KeU(b?Jb}*porV3SeJ`y+WNNOfP2D}kn%&hQ9*Unu{sTv&slyXEd-cu8^@dz{ zyv;c^lp;pY*&9QHar#eB$*tQ{dCnw=*X?Sgd;`mnK;6GWAk>)Si219v(LHf0}X9-8zj4{x*0XFC`9l8Ta4k*9bx_h#l#DH>dD8n0E(C26w!MyS?RQXU1# zRR6bK*ftBJYZ5!`2N!;V-V*aze1*WZvh+zZIV50M_u;=~<5pM;?VOAcC&6Rz@-1`y z4f6A4|GbD`PSlsw4dfc!si?_==E<2j(ky#gh*WK3{E1K+oqW?AD*(N?=IZA19H&!- zN$dg?81!>Bsp0P&;-?Gm2g9e*dWL%{z>$mqER?9y7+<~;`Zr3B>QG6k?eBq};4|=4 z&;mhGtX8$4Tf#4bku)=XlQUKbc$j1mVue0%#NUe{@B{&P0h+XMXz0jRylTeAqR?$8k~$@< zV40bG1YJj4=iOp`#9!4geh^(M=c8^%ZCO;>+xcdhGK+slxubn`=Dl{!#1BZ2Ow z8x93LKZhZT5GtUv?~t2gnV(qKl*lRfDSd-QZTjLOm{kIDzj_@ss72YZC*v=-pV+<+ z>v#O+jlgX_&+lJUt!anaOahTYsC-AwZBoTIp(smu(A#tZNzYzwv^y}vcb#}c;t)|E z7gad+D4MKiH*D(dS3BU77EPRo9m{QxTbi2Q2G;m~R=H{-KCGh&eb_0!ei72!#i+Do z8F2lgxujHi<1w1Dy?BzhDz@~nIyfaAz{7lucoS|y-3#B zQJROeZ4x1@Y0{>WEvpVa*CG#wf7qoRaob?`!FX8eb86v$*a(oOi~dvTv|)AHw9ANL zPP*YhDW*i|G~g?`65|PbH5*QzdtV|~zEcfSQ{4KtiCaDi_Y4t?z2tt?5aKNLFY%8= zTej#p#uhW7ulm3}+HPy)@rD^Gzz5mr?$2gnu`C7jz_9N&3b-G?GzhM}*MuVHQzs%? z%J%*eavOs{R_K1R^AuqW>X|$C>W`;$S2@`M3N?e>dW`v7lE@u{@MQCR3$NU`$0RaW zKu+o%U%r{qx8D2%2Gy!IcB>QTH{zUg-MdQ0j;jiW;BKT7xiN@Udrx^2ed_QV4Miy` zA(aCGn#YBVDb5*qBlyMoEaa7W{Zp}g6oW4|NjL>mX3)Byc<<2=tU7>Va4+lrkf)qH z=1g8;${n~mzqoY)1T$fFJ=$sINBw;iW#P^6Rr?!C4?BP^({I=o{g>-%mOxrf1ZQLV z4X(=012)?^-$!=E>J&F@uj7R*zK_h;4ILp1#V)lz`=42RiHIKnSLpAx*P}bv;y5C^ zwHk{gUTllsf!bX<1@#4(sB)ud-FwnC=>6c<@t;ll`<%(7EB%60Fm7Hr$d{=YyLgr8 zgW$Gn?+!@)XEfs+CxkQwP~LS-2lOR0j7;<A7EEJX%;8J6STq^IAFLfUP>I zt0Ihb7->|R$N{vsKWh_&_3#q>BcayNn7y1rMCJQwon#t~&v==1iC!GVfyaWR6j7&Q z;K^&=3$p8AIB01tzYhjMTj`33$luo76?=@E#hZWry}VAJZ+FDP2Yx`%SSs-UP0RkL z{F|MV{eL%tvvU47E&I>F`v0Al>HMb=+~teE_kgQm@C8l2G(gO5DjY#A6>l^$NwWP{ zg-Ya+ed0K_CZ5zmFUK7G9s#QygPlZsQh0Gij%^j@3&9q=yWe(l$U^7B7c8RuZdOv~ z?&gnP*5^|Z&99f;Tj1Q>p7m`Wfwxn;jqG1hx*XHjpKlR97hXo8AeL$zqDHRS4Y|_Y zJbq3MyZAG`JRa`8_surynH`(WG1M6)o84UVE*1y5wW9)=Vj%)L25%3?nwY%3h z1S*QHE*e)q5B8RS%_lq7a|z{a>U&z^5RdON)gLDZ%YQXpf3PnpRc!xk=F?d!zf6Do zjRLQ@sQsf^WhT)(Kh*p}K4+GY%HD8v+ESR9_ia3nqH1nZZ?2akf_i>Qru$5UYQ>&q z05s}rSM0Ldh{2{c zH%+^%n5wr0xe%s}NokFSkbrb+ID>(3Kt|G#w@y#%V3mvx`QwO6;KiCgc;nC?!fOIR8J`zEU!Izljq)MxFV}jT_73^c25J3Z3wI? z7e$MIT(tP+O!%qUc2)|VP?g$_aC}p9XNPk6`32$bc<}X}wMT_-ML>0eM4ZogC8?vV z(pS|yW<|Li{N86D%2-Mn+HCbp!{bKI#KJ@c9`0>(EdEl3rI~tyK40_AU$$18n0&!5 zn}4nkaKBXHxVcq-6j93t6jnM>u9IKTW*v#Df&1iE)99l#;j;Zo4jyuIjJT^>2( zE{A7kCvzofm^-ty&2u!bY^T(edh=4e;(9@?!$l4;a&&gIK7?BPOV+zQ*!{Zsez8{5 zpU0x_T5e)yofY8_BpsNsOQN+zT4=@%oQjm{j*P$C^!AfApl>c-5SI3^4PLcG>IJ#a zQUKl@bzVRQ%Ktp0pWxbhpJgfHE9?Av2IxK6=YyU7$GwA61yIpwan>+u0c6WRm`%dI z_rgC(*U^i*JCRkt>Y!XVMxHs)m^B6QtpEDSYs*?E#iG>~&%f7M^&F-xcRD{gU_G%M zYlV#fY7X3k4k9nsvukwgg1O<@guj?sG8eJLbcfB>p{)EYx~au@u~h_dkGN4K>Xsb; z{v@Gq^6spLK;war-lnF6()Tyy%+d<2MJkcyS<@!6M%r~5I10^B(fb4Hxfj>Aa-nbZ z8h4_go~>CQBK96Y$>6-1Kh|r!<{;TTFL<_^zH&f>kWngyycAfV1_mnB0Zw^lW`2g_ zqOOoK{*o%gn}24SZBzX=+Lx(dp;~I?Ny*vf`s1mOGwM^4kmpLt{Kc@)7c^FCOZ&~^ z!L9t#D(!6&*^+M5Y783@?A{f6iuPVkoP5n;)Jj)X__N~zokx~u%mLNe=d-nR`D=a2 zJ8lmFY2L?ZsO28}J_OubM8 z2wVkj-nH$(aa_i=K3V!6E&5;7*61vD6YfI+maQhzZBLsqy@a7RM^D+{vF}peaYh3V z;c9LnwkVU{x4w%t8L_aCLvbZ{%EE@nU&S5a2)K-uPL6G@h z?QfWwkcEvqKb)RHSM03G(dWJo2{QPWEXC+4_kr;cC2tuT^FRw-PMdAzbV6k$?d(of=Lk-N{VM^(rR`UEETrq7n?tNWqNxz8V#r``CWWKd zywE2uFeo;sd2?Z*B4atq?LU3}f*w_FCDnSU46A0?Wx?y>H6fR(y)1=n&>+F4@Uq#hobb!F@>f1JHSOeeTx!Rw!%qy>W z9NHH)`=5AB+D1~Y@%N&r@U>a15H%JR8D_lRzN)%N@zSVS>C*!x_rPTn2fDR zE`kH{z{a8?EBp=%fiDkr-4lM*rLXTP33C7f5$CA}S<}o`^=_5%n=SXOh_uoXxVZk} z*r4tVCNIppColvGf{HL?w5LYo-p@mU9(w@b84Gh(kyv{PYl0pm2I8ePP;uAne)95T z@84R$VEwXvPJ%CC8hXsn{)4YeKQcwvFzMRogV`>$b{C+XFq@vUuYcKWzYNiu?MTff z5h~wtx~j@|wq5VhDR{c8!Dz$7Q%%oQ)(%4PMxECaC>gEKQIDfD4i+{3LMA}rP3fzq zO8mD6GaeP&xUF5^MXstZ*?$Q3A_>2vd{Uzoqkor>2#l*4PANMGkn2ELQ<1VF!PHrT zkYE1?K4n?d=nq`7}Dh7E5J~R2!U1dW_fDX#q^w|Ln#TXSiCfmQY_JfznzrD%P zJz|$-HnS#=>GEmwFNBbtc>tbEpU6zm8d;ROjM{GXsoWwOAEb zGM_6deCC%LqxIH%$Ilv_d8>^S)!dGOklSp^0rpB9p5Ig-3B?e?wKv9Fv$T25rr~gK zj|AKn7l05ssqN6({MrdO69`HN_j@`W!`+3A&NMlwLw7@u3X7OWKX9EUi=GX;84YWxh)f@Ht|rkiT~yqvv&6e?-!zlw6+aj%~7^p7`$kR zg5X*EcF#!bE~+Y&3Hvby`LSjNV4w_-IL-ScUnzy-2t#a5NkrT2EDnH6sGV4#A^jcO zPp=}m!05+M$pl%_y>Tpn7%@C_r=)%}KG7<=W{8*SR?A$q-@?6P318zTflYiRS=_t+ znN!4AsK-TRxiQB=_;(62UH+0!_T&_3{C=`1#X|j*BlY8J|EayQ9h@3&gxe!vFeP|+ z8lbO=>(2G`iwv1D)E^{sAsIG+?u5!Tr$~}ykd>Z!eaN+oj z@I2J)A1EAZ7TMp*DJ<17EYe6n9(-4Wh;MgEm3SoDEa#s&%v60-dMLnHnP$YVLr<|; z>;Mn$tNEfd`oW^P_=%ADU|13=@;By5iU_y4{|Un_{w zZ8E1i+uuH*eH`34%<6NTDn#orjmEf|9k;aA=zElnX4*FDI0RhMgFtVAbtDJG8?9)uzaE5}Y+z&Bcd=qRld_ zxZ=yfN`xAp7|4&(8#J|Rsv@mf7JLok;?wosfdBJ+QiOV5MY)E4WXH`vvaU`B)psS- zKR*-~8lXJ1z9$}3M?a35W!ZE1nr0g) z5f{Eh{|Pmjqdyzu(lalsTI3B{s5hG_o9Zsf6blB79)r!$AmOAlvOJZ%*DmV+*r)KA z#`;?r5gP?QWIX;AAbBbz!bbB4Zz5SOT6Z%Y^g@AT6>`t4g{2VQ!`ff0F)f85d8){<2RGcJR{UCSU<)k9WPEEc6` zua%Xq09Fw>)(0bm1zT-9OI1oW1Ai-lFro|1gvVEMhQCKx>%5y>YI_hZlL#rt;CE}ZWd<&s)#om*u0E6U%~@JY5(sGE+` zrlc4w{0W zUPJ1@>-SjPT)q5cI=7_M8YO^)@&3bf*5z~x2-w{DG$NH#$vXz+H(aZT^VQK(PYv+N z>Y^gi(;^0`PRX;w0^3FYacBmSTzfu_O-K~%76Gz1ej`h75wDh2{$V7_xMIaA>hcZNT zrFE~9y+fZfd1$sNbO+W}&nT=tKfT$zoKBw%G@poZ$2H2qJt{%r$XB7X*I(EA)i-&n za^ONw(somzy+d~)UENx%j`ybfDV z*hO1w)vl}Hdc0_Yy?i#bPqJ|_Pc*(>+T~+zvaNv{Rz;Y<%MoOvi@icQ>CL!Q7QpHN z7U%4z;TOU4&%HsE)Yw|G>S6s=O>ejaof-%X)A1wUITOL_+JzzXXk)T2OwMBtXrfSusPC)Fn!c z703lNH_fd@MGawP(|>kq)1DeTfXDfX+;M6}{+yC<4rZ%d6EF>nF4-oH$cWU6XQyG0 zMQE|-4vdaIWt-p*Ul*!8!tZPG?SOE1`*1bOpWg*17b3`yy@j|Vg31d9XmjB_=S7@b ztqR+4>SIKj#?H)ZW^3ylTnDTlu&~N43*P78J4X2X@C0IC{DY@vU@fS~Nd8Hk`#|R; zPU>XqzIQ?zMYPOrP{By9&qo4$Jiyd?`yWP{uv-C-BdV@dcNv~w=FDGKCqPG~*y}R+ z#e{&!1yWQNrs%$W4n8>fSk^ff==3m)ZwWAhK`eQJ$B;i=_8Z-=?llX2_mA&1WkKKN zx9z4m-T(S0bntxwi5-GuGX-@tzuU7$Pp&?OcTbKrwtFy04azwi^13JAEozR z$hH_f+n%$_QyRsLyQS&9Y7x<`?jP$D(_NLo!+*rH3oMUT^l>zcTK}G6lPtK4kVH+U zI?Q)!m=Ft2#qzOVE@Z`M@Uv_A4Hz{#s$)}3 zpzrP=G2mM)1PX%bUv06@ZYO%~4~N(jB9!mGg}n;3+( zQGz@Qr|83X`Ui*dC75l;Ok?RnG6T3#?I1FGZOx1R4Ho0H3)p?QbY_t`2^9o@sydoV zT+2}Z!IxNp8vc-V&T&pJi(4F`F`+V>)-h)&9hPAC{FEDG^vVQll8?I`*r>_=lv=Sc zMpaI0lN7Q?OW35qmB_(k*12Uax{{Bgcvow?M_K-5B&kV`yqE_fbP!qb{OF#9FQMAG zeg|qv=GNEpXbN;xW2+V39eSghNrWK{t=WBS%jdR)=y@{pr_baOVUBE^B$pS2fi{() zEdbO<5_p_e@KK9Iq88we0m(ZeRlR^8a1|-@cc(8Dz}5GWh+W=;;;%{n zx(nHP445GC4V0WjBg~NsvHBcqQEuIcZQ)%y-XK?)I9@tyc*Jl}iJKCZ(p~My0xfeE zx{j|WTU3n@a5@@=G|Qw<^NiceAPi0Bt0H3kd~naHS(-kut-CX$zgW?^AbR+0;$Uvi zOnoo%n84uO4S;@897}V;B2axAy=Iynl9QS~Ig+H&kCt-8r?QirkbKSAK90A9Ef2Wl znaBtHd#;+Q;khus}yF6q<}ZH5QGg0*C0Lv`hV zJrOCpQS2~lqZoB4KX|zwWv_-{nVZv{ZpGzfT|U)^KvFroPaTmIO?a?nqw*W`Bas zC#)YzBEoy4AMyK!g;raVx?~jjP&dIov?OM6-e|)(6>TY$K-^@_s z7Yemj$tQPjPN`Z2ZW_~TJn{b?9Y{Rlq#iTz>1&|x=_|;bRbm~qd+R@oKU{H$Nt#OW z-lv$UldsVmf<^+;#_H(ZpFyeEwVs4;&Mk7}B0=t~VMk1OtrQTJR>7CXAa2#IY@n-Z z>FxI{Hk4$ezm4f8n!xPlCR-I+;9(s!;;j)F|J?TWW|572_W6zw^=a$wG9{b+6b7ge zvY!$ijtFS#1CV$11GuD>Z)jWa4E!}f^UUjJV*b`fIQ^68Tde(TSOFAFD&JZiikF#+ z%Aams{gG!7wGL-@ifAS4mCGzX8CzyO$7`UfWuWj3Sd}%{hFIa#PqWy=CZf~uHJd#V z1hFPDsoVc(+ZdffTWO56v<`=^7)nX&iQ6Gbp2er}$+I!vC+C`jql#K`Cy1A7{MPJz zu)*IEtwf&IF9O`m?Pt)I33Z-d^Y|34v}3dFk~wj!_@N2+(k+N&*iya^hhh~$3qIWJ zxA>(jh^tk8f|Q(5KvTFJTJ(KdJQTv!t4B(nj^noz%d>5P&|2jUG#j=k=h9{8ypm$T zSc$vK8c%%jbu$XjYts-uXr#&wSX}z515d5475aDkk+x*Irui>4JK&aFlhazA7&w0OMv3NGzm zgH$j8(wW2_w`nd@!S5JNa!0|4POZNy(~}bt*~gXXsm4!}Hzwt!lTXFk#R`o?$(X+= zkn3H&2@RzZ77!Llm`NN_i%sOjs5qtscA9o#G6bo*(d95`Cn0<>9^p~AwP`aOORG+5 zO*wrt`vfoP*V7_oxI4*R->pM%sfo9wN!Z{5PN`z zzCUnxFzyik8;tx1c>Kp0VrOCb-(8bz%>M;O*jWBwz{oMamD5(sU8nCbTei$i23`QTC02<|NBa9k-6sa*2Uu;a?^hlq9E=6 zC`2&-QHZ#Ge4BJ_fIUfZ1pi1sO&%_BN36Ut{qn8m(3%J0*0fuZwU$2g zsa%QW)w9tL`QiNnIe{N+VrCVFflSQFfv@`$cOk~J9{PRta#_pXP`?Ay-9y&cvsFd` zMKkER*}8%_w)yziu#v5f-(dUQvoX2;>iGRltYSoJvxe~brugxaki8?|55v13z?f-p zXeE@_0M9;DcH?8+v=Zk$kK^joz40jqMYwscpQ9hDdav6ii{qAy*<3v>5t@YiZ59j- zW`!%Z_nN2yE0X*}1Cdx(0qb^zOG11dQnhmPpY#QP#7 zxKy4)YZI%sC^XJa$4C{I?CJw5SJ!a&G!w`Quv1-oyU&vKkIo5L%NSYXazq9lm%if6 zq{O(NnZkI;ZFEdkx9x9W87y$4S!2qH$knoj4iPf(ATmUdh-@xZ$Q5B zd4vxlU!P`H+a>|;9dO|jJYOQ}iuQ?2T9=|ScH5%rgK;4uy}fof!Xcc$!6`cY*+uNE zHStD_2QS4>hss6%eP6nF%1a4+&KuWDQ8``fcahOAsZ39uALJKTNvh0u-LiF|P?Pv} zrr`_aWQp6E(Ct2*A4~g9%|U+7jg(@$`odk%j35WIOIA3hU3(7+rLzy+fB4OO_^dGs zoD_LzmbK1antw`Zu-_d)>no7Y_;Gkb3(|l4gbxh!S z%hsPulmJ7mWx3j}YQD01DF*869fer<6f+5l@`#9S-F(?^stUY^TsCGJk@Vw9(elqe zxE7wN;fzzO(W5imAR&_QEKwuhU9> zkCiuo_6d?emntXgQ!Nur#O zQeN{Cc>yGPkxSO^-~6m8;SO)85m9xeN=_JXk zg~`22Gg_c>2HtLc_R!(G!>WUZTEv<*$-`fV9>Bvi9JK248V#qkz`W{RpJcFtSK(a@ zYfhys&~=;6rgq>8aDcPxDaRL}LVsv0%Q`nI0QFVj1K1S{h((K3>Qx0w{?k9YR zw$T39M@Ch~uk-pFf)OaA^e_YIn3tgx_t30Yyv*TPG1o#*8qL<~QW=i45^!3TwCgCQ z(ggB(3|=PIiIEkQpF#hV{u+)JG<=UaHvHUI*lS?}ldF7W3H$>~J_RYq3hzE@d-vOw zo8y-X6S>3pxVNpITrIz0E_r*o7}=0%)Qv5vbs(ikhl6K2x#6U>uBgK!8w4>j)U(O> zc}Uz(#;{-s9S$Pa~c%A+WGFJFE=NT?42jg$_Zf-xd5R5VzeSo?fxgHd8(MKUWM%f--?yrZJh{~lpC01|?3>olVJ^N(p(ma_%2JA+# zY~I*=FRb9%c#COLj1QEOA%qXCFjXv~LE6(I!6Q$PX1{zX$VEI?ivXuxF4T3=QOfY& zURmZM%E(mI)QFq5Q_eN6rl}6b}jH8ut({ z2TsDBVfVEhoMQYV7~u@RuZRpWRimgx zRl!0B8_T!r93|RPGGpjZ`b==8{(kLpx`YJPd{FZ^D>Xi=(25Ci*`B_+na92!JR~Y~ zIw5m=^|D1L#3fn=`NpMau~GMHMUDZpsItjuhdgU~9|f~ikO8{D;)mF*&HZ=C9W(Y< zsH|02`hLIDgEl>0@WDkJCvC&`tJc@8n@|WBhsJv|Wo{o*?j90J=JPDae+&cg8z{fi zx%SYpZ^hr&n41$+As1`?6Uj6lgOys1%`{UX5vGVen;hQ%<`;pjE62t zi5%YQQ*K_5IB{O~98F~eHD_6-0V9=>R-i$j+Kid4{je+4BI>r-P5Gz zJ!d(u(9%T|2+B;F5qFHasHk&0tc!$|+>~iV-6*_9mTX5zf2ImY{s+6W8e*H4LY5AS zYf5NKyb30K9_1T|nEh?vbxtXp&UtTh61y{&f=WkeUr1F-bQ=iFGr=naG+E;V`w+ro zgjqOR%zhlj_?cYW;>>fTP6maB#9r4)t{gd&fa3UzQVs9LR|pIQIur?cxXo^?bd8D- z`v=yu!B2l(B0>6X~Py z{LULR94RuUR6`w`Zx=I62vg+~$}OjgTnq=Vq;$-n&R5L=$xRTNWUE^rD@D%kVIi`O zcRth)Nvnr{p7T$NJ0E@(TH%p{@&mAKod=d2K;z>rFI|)oN+xIHT3a^r>RUcpY&mZS z&Y-+7m`JgBjG863isZ0LYL~Q+iuEUFBQABXxpaveW@aQ9keZasMo z943fuv5~XiI7a60r;#nU$x#VtPp$d8Xe0+5+NjErdX7u+ve&jvfvxj^J-HtoL!mDs z@BV;vUc{hZ1r`-~BxcN3MG&B|hneUmZ&?V>F#eN{sE(qqM{f{$cwowC?z82_L9j6x zA$=v$RK#5c_%9(JkQ`8g#2n@>^0){**wyW;pDju3pD_cpmN0HcL zxOZ5+0mGODg`tcTO8o~`ar%*u>C`@dK(Xi>84M)yz<~dS&tbBLJUC#t><|RseIXMQ zM56B-+GFftHY=m;E`%cSSj)&{mZuu(?KhZrDC}}H4!Ffet$+SPp34YJ|9s$cr3B0D zI!hm!HgF-QMUTj{E4Qsg4qj#2jRzv_)jCTfNRW-2F@I$)y!p4iXiOQ z`l%sEQK1X#yWNgVbC4&W%h85Q^e)m7L%Tb5HqNFPBlWe6ODs*LbT{Ku>s*FYlF0uy zq4bMU`jLk;Hjn+lGBBqK-T^<)V<6LVCViUzyH=_<`iz&<=rfW4ZSX|(CmiBsd~+W7 zxxejpjZ9A55R|CY_TQB->!i@`so>1PC)WHPHWpX2wGBeJ1G+D!xi8CA3yI)>AuDS0 z?GN@OOT|12YtOpFNKzLU@5e42I`LYc*5m>}SR@}Lcu2W`Fc7aJt@c1lP+2wmOLgqz54(7h{a z`4t3j*@soYG zQ%HKP5P;JNO*4A@bfJkr{6Xwt*c^9HhNLFQI1@%h%Ut@bp>D`o|5>YPQV zt87K#Xu*c|%Eo#D3K*@UxT5vSmqg0;o>jcN=o{iyNmK#JfrVt5gB&7w=LxsBQfkfy z6I3fpJV&?aw9fZ7vci9G)1`Y(sl7H0NVju&_DG+_OG6SwLVwS+n5B?!lG4p&Hrn=> zy^SG?*&-=X=c!aDo%O;$oz>0pkFaKFe9|%Lv_(i?n%YB=KScf~bfc1a3tTx}_&IA6 z*&fY;uFVF;8WDN5h`S^=qblOA*g(vKR}zs5*>tNTwP}qoz%X!ei9S&pI;9=ucL;@b zcNI8l=ZKS>`cBQq{&H7}G{vNGjt}y$EY*f?8<62cE#-!JGFgaOcJ)44b2Y8ys}f?N8VWBoXia{vC~z#4&! z&K@0UA`>Q;ToD`|J8bb5yff!Z3YL>NcV}UfE#{`omBkfSLk;aQRzv3`7iPjh_Q1X7x^2 zKj8GMK^^g=y=fu967UyVL!iA|v6^;!@FRZ`LZ*~UN*N03Jcc=)O->`Cmv!0g16n1C@LM^c;8sprkcK2+E0 z1s<8l2?M$P*5`GSm-ln|psGr)t}%&N71~p>xX*ba0p{f{l-Bt?0Q)1CCutVS;W-}Q zPJN?fXs%yFV~Nn2`nwRR$lm>nb0{+G=@6;iXcE8?j9<5d-aKm613BX3K5j4GA_l2w z5h0zitd2Vp!}lfxiC>0DCZtV8*LgiY48H7utvbZDP{6&BmL>HAeMx@`Yrh9ix>C#S z=kChI1+7*-RKW~Cua_+`Oc_0|44%{-G^3Y49c{aFJeB;um(HUW5C^?O2O}_y^VR9v z{3vq>khKhn!{VtJ=O~Y7Hpx#|A>b`f(#1y~^N;I2;OBSo4wE8-)JX)7lBpNIYB0j4 zQA;$e{We|XLkgXfWP=+YAk|e=*x+|4#@=Pu@a58eM^(# z6-y*Sz)qV8h&b)4L?a=?m!N>bET-WaHCMoWPPB;lv`Bjl9OTrC&$oOnGH6y#>8nf*I~UW~FUfE$ z7mfFnXS2f%96&Sln9e6$u7EueRJsWaGb{F$z1Y4(mx>7e%q`MyT=;4FX(zX%Rr9O` z4W{Pezg$pP@zGEQhl_a5c<6HMH4GI{2lQ!mOYs*yU)8jWrLE<(-fO^mx2D(ig3nl( zNCpK4oDWTZv#t;zFQ?^#6{x@@UOIO@MUra{I!@Rf9F$7gSN|oL#NvE;l;MWG-x7BY zOW%z*m=wA5^%#l93YT5|6)3-;>(xK=d$qmTqKHQ&0_~+vEjBcF=99tGmWcYlqQCzY z>HR1AV`F6gKhfX+Y|rrWGRTfJ8R1hJ0$2g6T`>M;Q$v-h{ZXM~xP zZlH3{4arbjaa!|#Wh%2DH*1)5US=CVNUK1bpmu<&YxAF=Y~Vk=`~fZ%$0*IN;`$xKp&ZhUN_7BC|6Y<$g>JexS{TrOMNB?NAv zB`y5?&Dqv5_sH$Q6?G=-&vgbCs4BuC_@pYEnA38vE7)|cy{r>2hiG2$6is$9)hBDL zJgcoM>H*V)8QHeYa~rmL>?LdioXtK9aGB@bYy7qYR)^VJ{D?uCtCIUI^0>>ts(E4% z4dxge6eziaX!wd=-pbDnzRg0w@=q%p7DR%}S@ptR7PL$p-W(MASm_@pZ+Eov4dyDL zdX}Zq>JmS18-VVW`=Ml$>57x^j?IZ1F-|uGE znN_Bknn3v`k5^28sF>T#yw8BVQS|r$QGn z##wDQT8|?#-v$N#-1u9dn?R2OM9PVb+XHW@NR?x*KV?T{x4@muNNdk4WROuRz~Dq7 zj5-rU>#Ly~6z(}zEjQ{FYnDMYQ8rHi{q7wa%;>!up7)c4XD+=4*aSMUvyeN!_fpOF zWup!%ZV?n_+{Te7EsM;6TeQOZ(vzD;LhrFA$sZ#U&W;2O2$CdA%$DV^d$fE<&*(2k z!|-6G6AcFDCnYs61z{J6CUFE|lPpQbclt1v#D)}|(ABI9J+QOgWc>|XCv9?=_oj}M zw}@Qu_^?nW$Qh{9!b55jt3&4^^2z{inct=v{Qf<7ExemkGDkUA$a=GvLMj$?77O+9 ze)gBak9DG8_{A@xQ2<62A2jrZ*}Gnb9 z@o>GN`Rny*9-pu&iT1$k!+|32tY0RVj+sz=m62NZ37I3(%orzbD=ON_u1Bzm1rY*+ z=rer%IVQ-Ux;0r4Uc3RZoMQ)~d{cf0en!5;o}h1Y;rFQZ-W8-VjUMr2Y!L^WncIfg z1pAu7@~D*V1M|}_)Nzb_Zox(Sg&Wpk2Lz~rH7b<~w!v$e$L)__1Rx3F!ZfN#q0sLB zW$B03XbRC90 zOMc3BFp@~PC~V+sFw2T!;b>KfM zh$o5{3W1mB9IohRguV1fK$)>|eLo`o#>amw3_SleRL4O&h+`q&MjoK0F_={7Mls3+ zbIMAYnq-Wb3;8*oh`r98h;elv$g+VPk{;l`|B@n;ZTge!2v+rQYkkB$->L&?`ii4P zwJmRcVWSFrW3MaHT&BLJn8;!C!*x&(gLu9I{^HKXlg<+_>jw@~`dG9Wlup28Hk*Lj z=NtlXnAUN~2IZ}Vy9>OVb&-X2ueCgg5{&cxZ7byZr?i`hyMRxkCIlw)mbnCfG%`*? zeLeghhOSk^Swsd*-dE=sq<^Clkteoi3WK0KyWD{P9%;{j6p>cC{0B76ml z=K8e`3|X)QQKW@v7SRh_C0Q_c(NrqWZ3ZBdNuGwV?L0?~g=dg(5jYiB2YpYfx9|~F zTxORo6L*6e7MhMQs{~hXwg`U8&84QtI-HPXtn$m!(lR4aa#sjli;)eV4?>`Bg7YZt z&0!EudT%Jj`h=nnkh)sRiq{aBVYrfXJ5*zR!7RjP{ddJVEhj7VZ{JFYur1EvR{F{bFpt5cCCEg!89$q@0 zq{TrgAp134@-F5x*k@MS&8oJ%sX30uW{S*gLGzC#mfJ5J`ujBK=9HZH{u~BpS(Qhc zvc6yOL5M7mE>TAvGHtz+8X(Pp2NrRSSFV0unEZu$eSD?hhzpxs4#Ht>NF{$?ennMf zpk!pLV{Bf~uO3dw5>Oza@Y=sHjBool7ms^7-NpRxb#J6_8;zA%*DviT@GfNxUK97Q zj%Q4h`IVW_6M%kplPi5&QIV0M$H0jF?iS?y#>=G^xzeNZ(9p|M?Bp$>W?jfAX01fT zz+b2k!o`JA;|ZP5yRW(bkFj%V7A#uQ?KW!Lwr$(CZQHhO ztF~?1wr$&1SNDzEFXyG#Pnc^)M$9iW$KX=$+{DYQL8(~uX*y!GH(PtP6T%e+@md!| zLw94%TL&%wU5;12=Ui)mn{d<{Fdjti-+Fqfi%wY}T&)#OZor_r$7NED#}E8clH`WD z$yww$W~O$R?cV8f8K}Ur^}tS-jbwQuB)RXgFpMvVlAx?RB6xqq3Pvh{w9Idlthj43 z&ZrOs8e1Oib|<>{Q;PCRRXbBE&@OO9Eiei!SU4y-bFZchJNwhS?>(s@t_)d~Wjgn_ z;)#PjZ&kdc{u#4MkJmkqQyg09Xt?=?*Oj?vJ8{7!}v}DmsQIOQ1{)E0fL~2 zGR1(2i-Wn5uNh8Cbv*QbBV=Yg)YGxYJSfbUhI>GDT7RZan3p27&k+$p$%UE2x~AOI z1ea137OkSz#2kx3BSee|_)ic*fS5*Xl?cL~>qwi)ss(hp;26uY4f*tV58`X|p@+aD z1O(}9ldv3%GlR7x!%R1*jF7lF&mF={jf*SlTe_!2QrK>CnE9-WG2OP_-O}mH3NQq6 ze5suUw@P`Vl8ORwqhhJfGUvyE^IXSKm-p6`el@pdj_CzjAdMTl`ul_93OtWDcoIIO zZ9t=5B@g`z)jMHc&@Zcf71V?t3Dv#Wnql3t<7KTj!`XfSjlU5EvHjl&LK>AwrUFP> zKFEqZ8@OjsCLO(I=y<(GkP+r(6MX-s3ufmL5764+|lsV*%` zLGfvYB<-|Zmu~ihn!$fpv~`a&j19|{QlX*gED;kRN)+WL zSklQ@Lr7-q+prJAb!0eqaK0)yf@2)Tb>zSw0V-^gh5OhlKWhDz;LNbj8=^xULt{mR zfJ4lH25z)sKDb7wBg$3R0YlhE00;O~0VE6L8|)5(tA-JgsUc8(gA&yqh#iT%+#@cK zYv*HXRpblu6g#kQ6WS#~_QGTwMuY8T5y1P08_sh8!b99`)lKYj0zeG~VG7!&`g2+O z-Yi~Fk47Du)q#%cDSQvFX<$RQ6K)wn`)1au@icC7k zc2rEPu_q&E?es-||6Wk{v;$suJw41Z zl~<|G81@#(}b2gy$4DvfNEDzk?EDLctEw zK;^8mLdFRMR#5+HH0q+z@GPvm+STrhJyBp>g_rSxbGX~Ei!VvSV?1>BVG8%XBpFIo zg$rYw&!PDrC*?t(OuvnK61mp0Jb8GM8@7k%_6xEb$ZmTKApCQ5W6bLn!26xTRI46!LdHf>Jw%1c7sC`KlfGw8lo=^pj zUJ7){3xEYY>+WMo4pQG)Lsz}34*oVeoYHaiSW%MKeHe7-r1uM@l>C{t{fRe#%*;R=}2oDlAc#0 z@}8OWfCVn&UX+8i2Aj3J3!8$jg9o2fjBCf{4LXj(!0sU+*MBm^=x=9@TqPQBtVEol z9bxl`YOz5=pZhyM0iNTU|I9xAJJa~@?1Pz+<$w3VS^rb9%ldy(>@MrP$B~FQ{&fFF zt`KV7YIJQ(bVlNg1pYH_SQ)L*R8t#kI5DQ@o@=BB4EueXs;Za@EBm^1<$_tm7j#g@ zjS=-kQyqRkH`pZiSTFXz?~hMLy*xC&?Xscyb)R7-{b2Ckos!Yf@%41Pedi4pTW0Bc z`FT8l5%NBFHwyu}oO>T$o0J}$s_N->cd={Z*8ZFxELKL<8V+t?x?yzLbluYG>6(`c zy+3+>EqbN=N{5`!qM`YPbZg(aiBLqKtN-)-%1D3L?z;=HTYc z^*(goEgys%G(xi;oooQQx_*2^53{rJbJt4!QStC}Y>J7IIUmeYrf<>=8EhSGgU@06 zu^+5x8=ckLhrN6Ccba<`zP`joVa5y{~myTQPg0s^A6a&Sb+swu7 z+*Yb`F@FPt7h-?5$;9(}J9n4-oK@E<>5fuTFg=Exw)?RK%CpR@!V4RB?8nYkDE>E) zMn7?1VkULI;TXB{PM2iF-~r<+beK5 zs+H10_>3X-L3<#%hjqsxgXiU~`a+kb%ki~^jJ>18>SKXtfz&@hqTcR_$u>c%bW|!9 z5^Gg4aPs3(WkYBco#(Tajgy!4Ptfv_+QVnsRNV8qa)0sk0Mq@|KIM(nsx)MtwEkqg zIoHZaA&}PF)ue`Vp*li8nouZsp0BQhcb z=Ou>`y;xrYT98gGcF7^GiNJ|idk{-BCp|NPLU(Z1!?Y~pBOHf-IO)BXsI{$T^wKqE z<(VOjWjwpj!9qrBj zj46K-X7B)7QL%8$r7W*pR@vQDOqTWoNB|KzNP{HY$Qt+T$#54^u6ELFy({WjsFod@ zj|(W^5sP@Zhd*glHi#`Ly(~-iczRk^n$TlM&TP1xP&s}J4o9x)s3f?aBuzv>Kfb|S z@7FXl{k)?DrRZ)y>JiCd)6HZ_acGumW@mvm%yT(4vL90i-iYzCE>)Ka7dTipPRA_$ zs)zFERej8iQ*d~o+(ncd;o+;y+9-OV$w>BocEk!#1t=*sq>`JmWw6MP!-Xb~ zCf%5RET6DOTX9wOU1zgKK|wR>Be$iu{Pxqiij*zWj93__mTA`Ea^BmAD}_7%wJO z;XMR}M4-G7G0*lEE>UXNC1|b3DzJt%ygugg)1ux60xFYS0%)x4!B?RW;=XG6{wP5- zo+tbtd>=ysy`V}R$D5;Pv9oJ3X;8suENN_24jx#+8+Rw3h#X$2O8!L_K-xF#e zd^*xHuuY|>;-vT+EC-SZ7gZCk{5wb{Rzd7MuX$@4;~SpxMbe$RQP5DRiwVf6q59+O z@GPfihQa}JnPjLiZ%(UxZya$CC|Q#FGT%hsr*(cU2s%3r#wZhG317Got(tF`IPULMpg}G@IXPq z>-5Xh{^9Yj%_z;QxT*P*q04({lR9d3GdiA?9A zO-T@Pp~cw4pcyb`k0DB3R91t`OKxnr;&N7-iB^u z0+6`tLW&(4mtG5a424Qv`#78h<~ouj$zW-Y+H9rPF|f;<%b8yDi9CXkVC>r&gAw9C(EOoEAY-vv z8a@xfm1u&)PHoc77cDPcy(}2v{&F_`7-EoFKy0@{;-V()HkISxjdOXTF=S|~$4ikp z;NnVpAPvje8@X53gVs)BcG4h_<>fk*6EkuaY#x8w9#JBP2=EV>O+Ci~)=5CzAw&nZ zb&G^jG6vM$YT}xCKN^VU$B{eJlWf}ZnJNV^5{P_)HkFPbOLatu@Lr3QF?M=DdLR?5 zq(&CaPkuJN*+-TUj3+*%S9ynpGqgH(UY#zvY=x2vw_ff3xX+H>&u1YEUhh1qUV zGi+*YlBsIDOXs1D|xO#e1zx^jN zb74B|(~qrPS{m|TXjOV++!cmennx&>*PQuK(BcPLVguHVRwSS36?1&P?MHEJ;f?2t z%%uNEusdEjnXKu>{64tX=a9Z-k=xvz1o?0>MFH! zdGk4 z=!NvHv7vs?D7i$vSOqUtjc^-1t7`RJV}x?aJt!+YK@3=o;tzNgO4EABc}imGR+eDV zcrHR8;W8@!qjQ^Vf33e}+=`aXs=?AXZl|Y`I^cX}!Y&C4JWx4hL80=DIWAXe21?N7QUVu@v1hn+bT{Si9!v;_@Q)$F} zL|#N*P|`3H*n7v_ER&zi!|lr-#+f>_HCOxsAb3#GlWw?a)>7><=(`chGSsS)tm84Z zpHK=k7buY2bMC>nSpz9w-hrZ<CNf+RBjjZ+0)k*t6UEH<6}9hyY+I>})3y*r0e zu;S?80cS1A8z;q03MH}CWQN}J%!;$Da3|=?sL(rRSysdL%OWiMY}+-57s>888@awR zx<-X}V6Y>jcXKVPKTJ5!S=vKd$beML9{6F5`O(z(DmKL1gvXT;Z~Y8^(V)pfXU|(8 zmKu5S=#tWPI|SkH-)eY9T8^<^NcRvL31mcHkWIy6rB@bN9_Xh8m~q~$v46Ezpo9)# zGVe&XVaYe#2c^kzws7!K-*H>vsal;oWoS2M!?RlhoTaulmYF7;suoeEsSU2M)Xz;h zV^kIsm`aY!^Z}9crFKvVb{M?j0br5WY_Oqu3${%pC+Q_8xa{k&ik}pZFCm_Q$t>yO zf}NhvFr*va7||hH(xbtMmCDa6lHlb#opWL=9{z56;79udQ@velL#Kn3Z*f0OHe5qv zI4K-VRX=nF0-#bU87m@T5^K{A1qLiZR=HhG=@^tE=SofUe&r{8i5d6uGq{)xxh6H6BlQ8$w=qD)13otrHM8v+tvH~$@Lb0O z`RXiugT8DhoKX1W2TP=EDjqo*1mYmuw0NVN=b*(&uOClQCd46JU9{7Ry*^`bH=I+d z1dVS!Nd$fQA@h|7N!73ye9{l+WF)^*YphD8sGcg#7jdDFgfT9yY|BBMM$1I3wrt;B z|2?WhRsHrW%#il{FcsjGLQtj;FWI0J_$$6lCQUtp@RnWO8As^L{^wMiW1PxA^&A~u z;>&(xYqrLYSt}nWF;3P4Vz_{D!cF*K26>2t0o6;N9M?PLvX~_ZmiVkaC~wvgV0zG2 zsCAy3Es;sOAjN1JO6s2?1L(r4-><)H@S@55Q?QZivj&y=P6O~tS^=OnZgDDcdwT3!(YL_4YOoK4JM*cV{QZiLd zQztjEP$$l*9=}DulfyY~DWmgc$9uibbpvoUY|`^^BPQ+H7cw%0wB1*vSbLiWOqeQX ze5f)o;PtTn0$iP?V)BH=J0`kjMi#QixJa%C;#`!+)AIuyH?T>|u})}=yHH$m@>%3E zCa2rwAK9e0FlD@rZdrm8ZG{E{x{^o4$wqQwizO{asWPoiSBGU-9#z{S&m zXba~c+sVt$gTcdpwgkD>M=ok#A`}9tsTIK#!}z;xxA)l!9ND zgLQ&fv}txD)eh}5MO!tjNvlY$tLfx(@KjFI%^Uh|QnQ86BHAP03&>T({hUHp{MuAO z2-Qd(xFIhpH)o~9qI#C8cg6zO;>yH% zjtu;ImU@}~`J)|{NBF)AIVvca18QcQ2J*5P$!(*0iNf-E)=Vmu{^Q$(h3M#xjJ5fJ z#$*P)rG!l_S*bENo+YbHjguCl93x?!L14p6lsI?Ua8PO+@}D_vcLe^ab*ho4zMOtk zqkh3ui470cbbJL$xffUEJ71-$r~&O@iEHi*L$n&YD-`Q&+!}g?q{5V^WPh(Qvwmnu zsr7+Ala$d$i7b)kfyEOaF%%MtBKgWE?Qsygsqej!t&)Z3&!+gu%q=r#7`JD6+uX(@xp6 z{6n0By`2=SB0h|k^ef0oWB=9(DB|G$wPBe0ikgFtM4b=MbI9J$v`D3L6?rFSxCmaW z^n}sKK}4|89h=~Ihck=Q(l22(DTjGVbzUnC{Y92-$-CV9p28sz zTGx~U)S$_iGGRF(;3E~c&pIyLLSf_lE4RtE^LN**j3k6ImpJK{?2qAJys{4JUVWf3 zv{>hYA6rG_dlU;`?S$uaZp@)xx$>P(?Ae?ppO30Zq+brCmcYgwZrT2ebCBz_ISm!s z_)4e81ZXg$?%cScFUfcDg*mBGKKX;VR^>Ye9$&td{RpugMMi}5qF@rz3{T^3?MP*k ze=D|DTl)|RB2T~I-Y{*0B})rnQm z#UhC)qMnkchCw=oT~M|K+}&Ly$6a@WMv--w~9+e{LSa6d5}h&D~&CGP6|@Kf*?N=3>zMWR-}BKhU4W4nsGJ z;YPCcc4|uew)ZI}GhbY4J&5(`d%1hL+QLa@{)}s zI&s5F?O8aI zX}tU+YX=CS<;mEzZ)e_=rlOJ~T;rknf?cx4?j6aVQ|IYHdV2`Cy(#@A!Oo67b7QQ- z5;@7Azz3$ATcHimD457F<@wE*bRG`^m3@EmihD@SB&y2CXnaaMkC!_kvoyEyX`AL| zp5nh_YE6;jVHl5#u#FC?gs*A0W4yG3LNi}qsQIxbgkIWnpvM4n;v)^GuIKa*y*Rh@0&k<(DqE+vSOyU7ADH8l(3wUl813B!qRR z(p$`rMe?-yMx?sjyXpFDtPE88R3Wy6%}MXE`;KRVJY8M%IVd~(Jizy7Sa{BEm3)+S zGs!QPDc8sc;HVx>?>%DV3ukDz@s0PK+1ch(l!NRkZ%ZGsko=sQSwpmH6dK0E;1je> zSYEUHL;Zc$$C?ZM1G{2vg7o!taZveoy9?--SXKHTY5o7C@c%QZ$id3-|6PZy|LHnp z{Xe-5uXQeywwW7#dHsgRVS=3+I7S+t>kQIqfC3IydiG?OecPJx5~X$1j2W>QH5&ZB zQ>-Pn8~hr)O&|0t{R{4}wW?JscM~;#x0X`OS(`uExVgO@l18Y*|a`Vq3Dd&wp{Yxp+S2 zfozQ{Sw$x$FKr(W$`oQE{CM$xmo$U6FzsV*REAaWEO3* zaw;zUvVUH~Fa2r6?D|@y>aW>bC?0MBHd|~fNyR4d)cS0PMZ+snK{{-?trt~MWsHhK zc;FAz$B;CdC7U1GR-Vky6tb^eiZeHwMxVEl#L7jULe8k`HPANgT)nsodf2vKEQmk9 zw*i`OhhCO#?WkYH*B|xpZj4D(%rdX7UU!ya=r_gg#a7IX_NiX`U(jAVP@4~Ibgwrm zQW{b>&7KZDgpbB$RV2w58QI|=W76&iAKwUoXW)HJKP@=7Ey27^;+l7Ihgahujt&7` zmJ!>p#^?^yW{u*Yi7-Kdol!fzTedL_!sDN2g`k-+((#natqbgUs5cZjkoh|UIbx~3`3~(!6gPu2W1S5M5&ul z3}>>hMxBUTh+dyn*H}A6VJMyPN?hqSDsD#Jr|nr2-=&1z3MNToKV`n?1;|_4g?((P zX{tL=%~xWs%+d3HjjN61DyA*nYd1Ne`Z0hNTox{8y~t!pJgq=uvv_$|c1OhK1K?WN z-1aSy@@%gSv%JVUY$=ytL|itTLid?8BUwoQrZ_;jJo-ulxZMA9%bZ4AWdXpE837F_ z83F+bLfZc|NcGZAL@HI8a2!CE-g_DXi&q(71;7Wg=`#kxb_Cx9m{+T|9R~yXr;XDe ziqQgKo0r)PW5ArRgM+f)DF?ly-E|PPF;L*BsfW`v|2gzs zZHZ9=EJV0->O^~Cb1VIW*2sq0V)P!*R3Ubymi zKc7#3A($DL6AW`kc8}{->1n_; zF(h!xaRY(2o{b2LHC!ltjq7&Ug(Io_-jBc^=IO4UuPn0kY^`1O4`R(Ze7mEUZ7gZ<6 z6hx$QU*EP@m6wbIA{Zph<8f!N*Sag_kh#3((f(DgyUdFo#FZLWoIkltrk!G$zwqD_ z7qThN6JX6F>10!<776ty`_H{Z<&u9Wkl4Dx;r3>-i5`Da9L3GZDmoLDOfvfuXl8|0 z5@HyfA{6n#wDVupG50$n?QER=SQ=XcC$nE!mB?io7+i|B9^5h)go2FQNH7#H`7Lam zXAA&nd99v!SPXkjRoVI*6fz_MO=%a=_|j?kF~@l@?T~|)6tb}$+Sx_qS7EI&iE=v0 zkfW_IJ-;w{aq(kVLBu%?2h~ZUCw%okSS+I;js7lrey4L<`yV6T0Ic(IbIm3k?JFS6 z>fzsvK%8W!0r-6*!fpiA5e`9xXLJ4zR5&d^BQ== zCrfPpqYm46B)k#adJd4#LaJy=w&|z3IdI%OFHt=i-tH%NXS}DeyB-)Kq@oc{x!zE8 zC@5yJiHI!~I>cu_+pJ7zShalS#M|yFzy&sIgge!d9ROQxDlBKEI`%7hdNM>N>*=zF z{v&%SHkqbQdPuV!LsP`XHKVd5<{MKNm4nkwS9m8gp37D(Rj9Uxt%0teOFG3j9*ya? zxGXOjHn#r4`3k8=EG4joxm*~`BrXTg_oXW|*yG735t|_R#pronK&^YBm{?-0%QS_F z5Dj=1I2J-{jaMpw3^Yn#0fVZ3C!&XT9ev;ejSOaB`cQ!|e_xO5LR4C(jN?zqBYpVG zkOj@oo(U|X@&K_h$RjY|nqvM?tV-kp=MoxZ9GQ&JS@eQNrr9rqGQ&dRNDoahnhrQa zWn9+F1txE@?(up1lkon7^-yw9S|4)IXJ@Y9)s;| zfJ64VgZbX@+FzQW@NaHdeU(jOR1U4TP%2kGXUGZX8?y$E$dg5*Al)p@rS4RI7m-V& zqhE)qr9SlPb1e;jO7y7i3=Nn#trL}(jq~^!JE})2cvlGc)-37Ag`C1F{xbk~5y>?; z(%o`XNGrZSHJ?*fOUJGdm4U}`#lNo@Afx(y{h_YJW*bJ*zvatvV?I@L;}S%2kT_mN zXfs&VYg%%r>%mZbZPf~uH@PmLQNPnxoCiV&TGi~7kshLZ?HSRNcv()2#j>b(>$po< zdUZj7evT?zE2+O8K@rey=b{5t*-^c){yPy7x*TwwS*<78wj~|9v%39Wyg`7Jq(}<_ zQE8K*j0}k^ol?C2X58YphBAM-f$ST=*17W@56Srofg^L~Jz7nzF$0Y16te%lw})`s zPdNf^bK3F&SYZ0?C#U@SG;R9~-z51-0k5VGx6Q0{k;t!2!FB7}zX}N+pyIF}NNP!? zc!Gq?RI$BdxuN@Fy4I$tH5GlHRc+kc2zkb>Zr}jlj0>~5V&@f?qv=&5f;YWW4kfgq zOVRyZIjDTG!TU2Ce`~o-^to4>QZK z`aF|iP8D@pOEfbQMOM+$^71}B6T7N;Y(STGsTkc;Tio5U8@kd9{oU+RNQe?e zc4I7;b@hAWy;V^ok|(;tw1c}eWIV|73Q;=mkiMDb02n{KGh6nZ1n zHt^juULnPc?hv!{P-SMXyK2+SXC8Ooe=gWMjb!R1FBw~acXCxfDh5^LKyZPR7r(4( zHYAf`U&*tPE8s5QfJ@e>M%L?oHLSEPg>|;;KlXEaycSf77!|wGwlsEhhFOlISS4X= z)~!~$oynGFk-jM7`q402cb#T#dFn%sYc?eUes!WqS9yQMF~lv&PC3-*|j6Qp}y0*5?@6ZTG=-9Rhs zXTzDw?n~X}OZyzZiE9LKLNBVe!YOet_L5s{1I^<)-@5fupV5Z3&5EP*qS=U7c(yuK z+7Ts4{wF*Ab=C#k3%5|!O0hCj1b!(V@ROK#J2#JfYe!!}9(wA0l9>D5Gdvc@Zj<6; zasK=oj(_Da6M~p%1!geQbZ_?l8_n9ADYEU1kGYg?Uz#`%=-@#ZD0{rOCR4&nFsE?T z>>o7^Lk2!`NiLimX5((COi-wOoIHbABvt(a456Cn!#*3kuxVgqxC8QM*hW}+1xXCE zFwha&elD7v4VB#kkABN5m-iDsl8`xzp3NfCMv5KyM3z4TNqp(;@ue5Qk4)Pq%8A@~ z^X@RM^L_Dp8&KM340>0PI#jEjE;TFVBLrUkgVN-U!_Mp>Lj66S+qVPwdl%%}iJ%8K z_-(~5b{wOV)RQ6cY_y%CK*%-aD(qfAG`)~9{X-o zuPG<*GSK_2MDyibkYqS*N#yt0Zz*gggsJI*S4Q+4d$Ie$BOPfvBn&Ye;6#p%t9b}u zdC0*RP$PYPmhyl0ToL9jq;+%w!m6}4J2_%_&pw=q76U8qWxYcPHCE~0d7<}=jxT&a zwc*GDl@|OtG@=Wx_*ANYn2t^LKQ=N!i`AHX#)H4fB4fz<7tOf6^=X+2xv&on7N@~-IFNcR)0zZ^B6c7$^`7X_Mdw)2cUkV_>m6>Tnl_aIbNla&!e&Rx#@-X{j1={n16e z=Z@J_dr?zZ2vGmNfS{(Q?x$OOf^7pjDq=5`J#~pALr!s{bANQq>x0J z_nrw$&A1eEh85iemBNFB1dDNNwO;s?*)^$FKd$cYV;Od&V5!PROuVZ(c&^SFWth(u z!z;#V%G}e{2>SZfd+C4A3MURE&RDV);Y?;thn2uZUgkm$vTxBQuB_B7`!ae~$#-ji zi_FBP`W=Pgzt-Ia`3V=RD>{y)5&8mAhy;m}bHsJ|Amzvzh(&;kH^Iv8et0dCGvdQ= zKPgKIP`ifLfG%K3Gr}Bz#*D>ZgJ~ixtbBf8wq2NT7NF@=70AJIy;xKc6|iX!W66X= z$Av&s5jl7)Qu$*zR0(}mxTWfC$bU0X5zpU1l`Zx?)h@*^n_MeSh5BQ0G-3`o3i3Ux zIFp5|rHw*PygvNDIjMNkaXq|oCSgcU@r`N=B^m$8BK5``z2PQp`Xp7+=kl~Jy< znH9?$_;8*L|D^3dL7;eYWHmT=8aCL&I)a*&lABC6Jp2hN6k6Ko1-8T4MIoyenUNf6 z0lT^oQ;7SK$7dAA_3V!OTOk0t<;Vg!x{5vPrQCFDUE!o$J?RFh6A&cML*NI_#j#i^ zD0&wm0~z}@3!07UV)$_$9XqiK^l*zOy}Vm=us^6iQKqB-Ebx`S@M&^dw&@~sfYJW1 zno4@Ys2~c#Y74A{W(|jC%@m9f#tcI9Ms1lsn+4al-*^eiZUB~6r#YOknK7P+v6ZDr zF@D4*E*`w@Z~2W*nt;bl*5zunLzX!eg=VoME5bi56_CcwpPzqbcL2so)h1<1isgVv zS<`5*?s0t+xN??<^Rlslrf}vdl>Wj(I``S|M?lQzWMteyulF%uQd>lM@+sSHoL zAIfukL&}Zl)s=eOt^>V#cZgm;Fz@7VIL~{?*35^K72Qs`_$6bNp7F{F@+(7yQ14y| zf9pzGadq-Wyzs_x+F)wFPm1yELKi11=%-zf?S`ZH1hZx80;QnyBA4@FWd2obzq=Sq zoX*`HrtG-ZBVX{JN>t|0PSwHb{&0_@Nm8=6_B%+QzMT)rVAV@ex&Q0%d_1-;S=IPy z;v=vps*z=;zF@&vt&_=>wDC}s6YS=RXG#nsgs}}RJ%L^!q7G>UY9V-gMhoB$$8@fy zNYHMW(F19bE>)ri=D559M%dcx9L1Q3=m}*v=YLPV9Byj6wmF7VGS8nt<77~PQ0{c; zA(2r*L2~70aqfxQPQMz}4p>xj(vW&l0+OsIbZ6_R9-JCr{D;bk#~l7>iQr)`>iB3d zOj=ME=+9y@Ur{iJ>|1<~Fq$G6r~S?HK4Bda+>jIuwbH;9_G4@s35Ik@ga+8Wijhi; zeI1DL8_Z+AR0*b85<7!l`*83&$z6tL-n*oDIfc3d zl5zUs6iK-BAOMQr90?C@>7ZpH+!}}JpET50XA6fFhnE;euqiZ@X=FIJ5a8)Le5PI< zotByTZMqWEkMoNen+Gad0^)~b^U|eXJsg^6y&FLE*2bjW{L0sWxM{x zVBLO>znJe-k00{oZ)n~l55M)<5; zcOMV&(ResDGn8>{VBTdrRbf_+fwq!e^afe04akHa!Nm#1QnJF6-X%quzXc6%v`3BciG zL)Z)0hA{2*9?kG~xQ&pc?7dVnbI(+}7uTZQh`RxvHQ$QE9aF$Tb{$-f=Ca|iT96uL z9u89BNaRv7>7td@!1V_rAoo*kfnUAEq_6MmMO>m!lY=`7+~y&H8`k8_lB0Yl2RZRK zODtAhyW3f?LUO1Q=+q3*gizs~*HrcR(yYEwZBqH}@$gjEE|xcUKKbv*sID&tmXGb` z*pyj$jwtO5LX|46F(WCFuyq@-;a7wuqSYyLq|>)xrq zey@)3$a>W7{T6|}zu(?Z2EoaGf7DtLg!m+_*x-8jAk_}bo}U8O&^NWZ?+Lkak52j@ zldem=?)b>^xY^%Ho&O&#!LE9jn=j!XE#dV2tF)Q$7egs)};E3ESBI5H? z)tPJ2itJm}#T5PLvp>&FlgyIA1F1Pz@sgoA`Av<#8dI50tLy8;zbE7$E&&d+1K0Rs z^L@uQd$Buj{Z6DcsarvJ^IC+=lLWlDmCvO!KkX3R){bue`Op^49I+67GfW46m;JIu zZCmzrz^7%4zQ--R#bd^cjL0XQCu2shlRpZpd4pG?iBoXj zCA$#4dbcO|6z!PQ(pl5i_CPtu+4GZ#9_snM;qlwN3j6V^dekS^~L^Yv2d3|yk z!tP(nKZ(APu91EF$4%~q@X4&DWm4_mIdg6Gs?pMDXL@z^ndDcm|CDQW!GnC={M}#Z zFP58*-i+00|CI10cxKtg&PQ>k;thsvb8BVX-RjvsX1k5_0N}FyZEQlw<1fXNNt?J} z-yHiOuM9ZX%jI_ey^XRkgH>tFrDf6PY4qk&_a@GVXsG)JyAfhM=N=6kvj-CmMGhuauztJ2i(aw&t!ZWfpV5YP#MC(ZxvqTYnTY%a+%GCDBlz~ zQT$5;UUJ++9V_%vxcs(Je{to*0UG+*73XoduVAY8%j0O)j!!Q3Oksz+U~f@U!jL#7 zxeB2S4d~5b)f)7^Q_tkh@P28cxQ}^irtG>JlgW8iV4Ak~Uel+Uje0^r^()n21_-!m zz6Q@5Seautx7TpH$OtHjXPYe;y_Kw67B|4Y`<^ihB}2)=r4IsS{p^AU8T=#DtV%)7 z`1|n?b}GzmF8N{E>nqYBaO%$#7jzclAh2jdHeXjBi35T1=n#SasNllX#q|jMU#(KL zW_`LsasMrN@*XADAl86Fw(q|xC>5=pX3UXfnQA$h4XtkIAwz+ELn{#%t59oJUB~v9 zw58~`jEHIy(eMMHD!hV*FNdTZ9;fyNKgZG6E+ZQ=knC#*yk6_jLJK{j(PO%cJtJ5r zkzFOhREckD33fVCc~u_dV(t)=!WJoxJTsg6hMbmR3ToP4;Nmm;Y+ScN55+7q@z*_C zfU#ao0Hx3YLyCKQJ|r&>(QgEyK`HKW!%x3@SlmmU9?$kk3&itc6Iw>p&9jrGuz=(R0AWCN47@(uwq6$1}*%g+0XGjM3x$7ss8 z&B(OCYeDMEtmfxo23x*?zi%yAp7}%g$Uf&$;!zKppVxjal=7C%8@{Y4qmX3DG0P?q z!V5Q#w5Tr@VqyVly?=7X=Rf}%E9tqSo9LV2?sqyqlL$57I_u9!Kl~L-XgP!{yIopA zVFmXLIZtWXEGOodj?Wj$a-iQtyZbWm_-Wf*-wEajzlO^>kE!G2rg@!t z=q9s=bIAyWUWmi`X4mm7AYnRoxVe67{}J)#g3XEEz;;VCZ0m`P9+%?l^-)vFoKE$?2aLK@=44K6MK`Es1sP za2p;+H~IKpl88ySs*=H2fK-og=8d~F4#!y57v%^yAHWV)|aBd%>W|`EKH*y3y$O7#KKE8lMQTwS`-N2GIXQsD04P?d1jxW z_YBBCbWJU>IrB(pO;;n~7?|d{34|2@b{>Oqda6!|I2Up`2+hWGU;1ub*}mj-Cm}Q1 zpC62ttXA|zRr2dbs;w*7EeWJuVkH>*juNOqE|Pfgis~pbeC{wr&gPG$Axj~8+Rhf8 z@*OV1+ZM=*iOya^M@oj!E58Yn`C`^3dz3y&GvJpXr)YeWE%1Vvm$cM->lSUQ7vU#*5TMZq>qRkXt$Raq$G|H z2S@sd9AO?BaHihiS??Vfg`4mcqaZ*1-7#r1a~Rc?#EXgCqj zrDro-YGF_QPXt;T8m@OpDYgtY@?D#jRJu!4idOhqu;NsD)r(_Purglf7PiFr9qi0X zs9XMzg-rbi6D}dc9l5r^ojq)tOj1VE1>-2K$G}8>sRWX8c%EH8WaIht4{oWqHF~@b zBEt!$HOIS@QjIrFkx&wegD!+u5C+kfWd9$Z*fyX3=Q!PN{liX=nB;$J^Hi;7h5k^) zPaLTo2h`Y@J^?P}UhXNpcwu9BQb82DsgIR$ZKwDXRpEUoBVXRP(d8XjNjhaIFp$KZoKL*>cts3ANS`k_qr$p1!*&w4t+3OvjY#bZ2l!ZV zP`;5JONg?v)UKm_Ct^1UaKUj_<61^4a5*_O6feE329q20C~0PWuR5z_)Q6;VOiZ)Q z;TnvRRfwgk_Wp~z_l~#e+8Txlf{n;gquagjwR`WqpWW-(z4xw$h)xhCY7m|1JtRa# z7m<)eixypok|2oiZAXaY-sisezVGk3e|&!&)?91NvBw;Jj5*hwhi^SND~aJo2vM_0 zGmwYnot2k5!fr0Tw5REuWzFaPAV0^M+cA27>gcaN@K`UvNA5fCD{k&`r>kYAZvSn{ zhsA-E!Q|WRJAF7E`^C(?tJZ$i@Eto@jPL*cgOj%&2WIQ8wF#p>YqXZIxfSm4dG*zf z*B%Vr{;jKcXK$AgU6Rx8NgA(PG`#Q|ag~0@m|L3Py~$(OHRd^A0nG>_q7mX9sQhZ8 zckh~evNyb6-2b5X)wWp86E^3Iz1wH++SRJxQke9$Ui;PL_xj8p@0@mbj@$Ir@Q<{v z>3&;~5P#DTLOeE03KHJr9H4_CKR8@skNX6gs)5?42j?DtwHEpbuA zynL>?B1oHNe95*S7>61(qxFGtx*aHLDmvNX&3%=djc0aYjMOolS_*pAu&(z<7I{4W}qTSLsw00K?+w8%T8yZR zfZV^DhFyNxed6VL;||D=F4}vZ*skx+$DK~J5iRkB)Em00Z{BW4+4kD4uMQgq30kuh z`AqK%uR)hit!p!Va)%4n?cMjz`28&NEy;)5mt%uFzCLtf{>sU%8%)34b@;vGt-f0` z1>3yY(0#48ZM;72h`Zg_9Wn_o^!rmD`v5QNkKh(Ve-QKqS0}uq^^+@%ue$T++j_X(CovxkxVt{KrrP76a zVo`hdrqcU5nouIH>7Yh(@Wg(~pqO@ZP`L zyf^Z*8CR(DPYmSVT~U$#HtWj5G4dPVZ=Tg`?XOes%TUX{WKRAeo_XcwwsFv*?)joG zw_WS?Y3t;|#khXcL~net8#D7k8~NCio2B2@edfO`e7Ndrs~=9?J3Fx(tz{(8`GIFf z@aC+RcV&=b%Of!jE;=nTz>7Y;O$zvQCXYdUNnk zr|ft#Xz>1)!+9aq!sb`0>;-)jgf)oQPF-wtD>|IU;6Qe;k$p1bF;2JQ!jyTZov|s% zkGH-{**3c6T?)Z0cCFZTe*cxz!2;6y4zy!-($d|Jx*iP9{qfe}W&bHR7~=%Q5!xTSa;ER zi0;1Azt2PW^ur%N8Gcr;q&I#*+NJO}s_S*_MnCYzQkUJW6+0QdzO@A~DF5phdXCyW z@!pL=2S1!MpMGo9;D-Bu=`RGmXCE4Rh0|vof9~z8+xyBQdz$ophrDrs@^f4J@pq$* zfauoEKaN!FmF@lf^W62H8ZOwhc6IUH?PmXurKy7x*XEBE)yH5>8v!kj9QdrCH#mxI zpS!m8Ci7el&o!~>gHGzU6B_M_<=ul!US{MBToR67RGbA3?|bxO1L=~xt&iLv-L~aQ zFL7*J!NvV|va%iPxFOgOy!x|Yt0;<@dp`U4waaz)CYNR|ZP)9=w!xEYW`4RsGO7Y} z+>P3OU_C7K<6ctNQP7%k-&*y*IZTUnKO0(}!0v%EW}r`pfca~8m%qC$CyS~(s)~Od zq+5Fui;go_gZ!t?-uigQ_G@bof43R&<+?fdd!lyDc)Z>+TXvitZ+yGKyves_!&rmo z6NY7PP{1GD=u8}XT;mKLJ?!n#jy@(}D?&3W-v!BoZw@{g5xM-1tqeQy{4=Np|l@ydb~vo5goo9=zzr2OmD z{f+gBnGbQzKL2S3w#8dh+Fc?;TF63!ZtoxSji^W0jUP>{>^-{oA}pr8cN=+0+Vj+q zFIK3Gg2s0rkZv1)an3sOcwp8tj9z|s+>wTtx{+5-J6ot`O=L?~*%nVa_shD8eH;Je zdGGaUeLj~=_5@(aAN;$b4QT2`|^F8 z3or0%9@QNG>Z{G)Ei_Fzvs}FhwdrSbuyv<-m&g8$LR|Z7w)R5P-&vEH*XDF@vds0{ z;gLw~bi|JvPW-%h0&N*5{c5Ybo4p3t>~#w_geQ$T4t)RCg3hdNip<3A=ML-EF8TP% zZLea_I~xWslRfs|iyIbRP`668AK1lZ>T7K|W3^0q-?Y9>bIzgu8psdx8pglSqq;VO z&Z+K*{@&vQ*Y@A^&Lj_Pw_XG+^0XV#qsQ4Pix|02PQCNy>SOaeUGMi^U+&~DKi~Lc z`Sq#qAKbV*Fu&LRhEpCAr%c=F@B2oJ70o}{^eD>z_3c)O_hIdr`@YLM){B}pzG>R6 zZp3O?-EDk+`oq(`Y9%|rdZ)j(N3gMq_qJorE;HkuuavMY#}>ZR_e&2No!+(O!*L+k zwWhE172>t|G-xw&n7yhr+0CUu*!>c*NLTh3gpTR#7Cq>=mJ zVkPz7+AYS%YkczT@87kN?;Ll+sa#SVhY!7WZSKC-C#ieKeOv4wpR>3|Ne~U~{_22{ zXTMyiC8^$cTs?l2(DlsVoAJpv{qTmP?XP%;hU%PymhXFI{rw9^YDRo=ZdD_fxXY;T z4}Ey1yfJmEaG-Nv;S_A;Nher?O*a+7sUI9ve70eCd`I_zXIo$K5C`0-IURp8>DKPS zLnQ(c`DXgU;2-7%{Br~QWXwSbl%3oY)y zG%`Q(xPg1o@9%e&_CH|`zKzx7gRX*ZQrFX)_$b&`Ae;!JKt=))p&Imu|=27XNGfEzBcwZ^q5!YuIRDr z?68!1=rzHyRl$`j-H$t*P3}tNCnHRk&V2Ocr|s3>59;^xt`)bo=-mv?eP%w1}CD)r~IOKK#7-&fV9W{&WL}cRd<=rqQR+-tT{% z-UVmBPQ1OC@pG=I>~wm>8?$~N+6>(_Jh6F~k*B5&kyCeVIdG0fX?Nj^RwIthVEOtj zZ=I*aCN+O=yKB$*;ORbH-=%A|hr0ecec`$7b8jwqc=77*jcZolZ8iQu?1qKV?*`}K zqO&)ry|QF<=YgtbJAS}!9DfVDd*6u@HPaiX+tE^|Rp-njUBAzE`{=gES9oZ+GZPZqx~0_U z_@Hh_GeZ!gUZHeDt?zSiZ+ue;tqHGkct{o(q;)9WDP^o@CgFWGJ$JU#Pz?-A>s%zkw7`h_kHmaiy$ayD~*z{#zwL;4X9FJJqi z_NMg#rLtS#oBie|pFE~sC@=1!oA6t9)oY5Q$L5?r-M#Mn$G=_wqT$i*?$O?NGZ&7@ zN8=Tb?VlZ4zvxhD{iA53^uk`NKWV=*=x#T-$)-j%kA65t|9G8e^>2s)*e>G5zs`8{ zDJOn((&f|NOxwQn*!rb+8{E0xclTIrvh#Us#}P+v-t%>}oFAO}^6{noP}=(&f4Y}@ zP0i46&OW)9U%z_jkq5tD+hJtv=XCsaYSV8%JNZ%5Q#+4L7W8hs>zyAKPu-DU_)3}m zP~Lyg^zT32v(et{VduBDcAj$8(y~E+$9c>pCpDUi|pzl^>3hKO~or{q(hc z$1A@q*#C|5VyD?hf4S9lYLUA{iXD6H+SRGs+VngoUq!nf8#`i28@s7y z%+C|WU83VZ=`d*G?EB}jLw#2k;BGk}Ls|?!So_&qOMVJ-5B9abzi;NIgB?H1>}I#6 zv`#F0|MfS2c(SVXp7PAG8_MeY?Ul>M7KiO!G#~X=yKd6!z6CwD>L_b^1@?Wkx=pvO zx9{vZKHx`JgA}i+LD0$7Wcd~$dB=nB+HX5HB!<%=cdPKE7<}7ljOHhhF`< zdCxc7uxIrc9zM%%jA=cvYp+v-KU*?ym~xy)_Dg&9l#a}(VoFUHLt$wf>fJX-wIz+7 zyfV^h>Fl=OxFE38>ZZ0StpxWLf3b1O*`d;zKWkP`=vkaSt?|HbE9-yUdwr-nqP{ZP zRC`?|l=snHkM}UP`{C-YzJ^8LCG?dMn;3V}lfQg)wBe%lD}TE5?(Lzg zj~?E)u$zW5Vb(G3p;hY!jhB~#k|y`Z4ZqSrpMJgJkw!hXUHxflvzF7|9$d42(HmqQ zWYCi>zNXX2o(-kXY}dZt*|2S|)rEap<5TyiZtUR#d$L~42(r=SzF6j|%`ChM@*E_$?m~`ol4`&sfc*ODUpDg+5 zq;1;4p|;NUaSM^+kB3;n?~in9e*Gl8U32rZd%^YHmd`uZhq~bd`}fyoOXaVvKl`TY zqk+qs($1?OyGHWXXxCPT%zK3DKft^!y?V??t5tg*Z96kg_w`U8$T%%akp2)j%Io8e zGin;m-i;c~x%8&J&xOjG_vf8`6}e;dt?yUQyHk<$+T1Topko@}I;m~M9r?A$Af-Sl z4#VC-XV<;`asMIit}g86C_<|{GU}Rq=KO{Or#5LdriR;n|7Q!P-wH;**4K>x?#b$K zWz3wZpLg)-hoxtJykgWcuc7rC+>m@T@mt_?kMyHo1HaW~PGssU6>wJec-zF+F3x;n zKKnteyTzY6@%fPO_)UQcvc*5Y`xRy%e|gW*Uh~fzhAVBzPh9X5R}WODQy0{NVQ$`S zW)tzYDLa?EajT{Y`E4qc6q#Utbp>+^-ZaStDy(@t(ss3ZK!)s@TN}du*3-e z4*Q-Z{4MGhYyAiFuP81tyN@}v@7(^wYR1PD+`&7bh2QO5ew)gcqzT}8jo)0bdPl4+ zf8D;@j^sw%m054qof&zO1lpDn;KDWY25y@?ue)a6XD-QDAhGrPpb~m}*LVHlrkWmK zP}`g%!dws2enFFm2U3er9TzQndwm=H)XhHbt!2hl{L?X9$0@L-xHque4g>6bQ}6Th z7m#-isQ)kaTq7OZ^pF2q7TsC9Qi9_U(Je5y&LU%XBP|G?6=oG{r*YMuB%ES zd3k~7K%@|y@?g&h!gS>%{8*b|ExOm%ewTja;zoNvTX*3i>ItQ$(&X^N+gRSsv($a8 zZ672ToZQm}-Qxj zW$L-|?z*dAd~);Ztiw~4i`TMnL+hjhG)$JAaMpH@jIIOy|Wu#^9D)W?^)iyZ0wGdekA^<%pcpqfgSU)1BCq8wOD5 z;fJ2?#|Y@vnAy^)owhw*H%Gb&i%{2=Q+v7R=6=4l{V%1Z;pyX=JehCX0ebA+JZUJb z%`7&vIs3qp=;1&~rycj!g@9OjtZ|#BQ^sD8UHjO!=a{2yY*{PNEA#FS*UFez8%;hG z*%Ti6ZgIna+HJp|+=uvW%NcXWwWp-tFMntF+UX5u8oQlnk91R~dCf+XV8Wb}go7<6 zF7G9-oq2`5IMi?4CyU%QP!BtD%h_6w(9#m)O}fn(T~Q4{yCQXFsf!>hZG zOD_0r7h+r3zcg_4A#J-ZgdE#cnuXcSn=xWbt=V=~!aT22=O*9|9qM;x37vTUal3DV zb1!{$T{bD>btJl4T@X>_?<-<4xa`Vlu z-FvV`_VEMo8y%^RoA=uPWL#u7Zd5KlvA^;0Yctn$`{f+n@x$iJqlsq;8#9B+b@$H+lCv5n&q`mtsjnyB0u!!?huubJmH$J3MQv3eW!Ta7D zy5(B~nEvL9le3(!zD{m9pLnyygYO5Nd=n@9ZE-unFy+D<7;*P2`{iAB?ol;fpxm!Y z;xflRZno^(mb1QschXPqop~Eg4Mfpd!QgZIM&(;VDEnXU-MN3wmNM5tx$GWyzj_Mt zf=d&moj~JPekfkZ|7=c(xTXkiC!BGRI(pRO%{{+3As_Ul!`t6*=iL0I;l0*NXIxq2 z8oFVA=i^KJ6mPN-E)Xth)XwPeEsCV$%XHB)W!w;qhr7|>F|-A%o+oxrPB?GpDF zt+-fjbqM!9ZhP>2_=j3CzWDZSO?1UYqdWOa@hB$@S-h==*(G)5a@%j4jJM3_d%5$& za8t5i`QRrVHZ5v+e*V}l&Dh~-+Vh@P=g5+EcV^P4zbqKs_duI?Z$e}J&xv-MzcQbi zKT6v7@mjb8bjvmeAoW3hbFI3~#pF@mg`OjG}WFTb?qkD;fH-$7aj#JzIjUdQ~aZq?U%fMn-rP{I;_wxy#0oL-^7FL z3!T2X+y;e%JI2zoxV@Ju2m9U__6bx@L%aw5^+P#jcc-PSo=1{t;*5*y7??3iDqfT}EDRJf!u7{tpmy-%(xftt%TZLb#`1+4Zn(yN9pqej3rcXYcSuU$=*!bdeA~ zzV~HE@Yc?AkDXa;**dO)#m^eoa0mM5R{MW#S$kbcgtwUK-P?6<)c@_kUxul=3|Mh~ zcZ*5EZZq;dM)d8p?uQ>f+^5F;qO{M%e9%7f`?t;2ptEnv5pAYh&$hLk(LB_Q`*fVC z8@jc|PdLpz;TjRcEi=rN{$5NjUcbuv25!a!u5kUO0aw2^eag)An7ik3lYy8=Z*JLY z;qL0t>F5O7#4_a2Xw!u-C&R~c)O++O`^#$W02q@RA(Pj&r%9<*{qdsYY68i)eS z7wy;m_(s*NO!z^o|^mU=#FEMM#?-JaA)LGRqMF=%m^7eNKd)vsd*_wW1l;jvGQM`MQzAJ0tl zp|HvOQ*D-vIsW>bDO$Wn*UlffzY=@|`?lhAjdyw5bH&p=lDlVh66~hCDl-~4C!eMb zpAc*Wo6;9Oti`_KD#XyY&kxx) zXq>t$f2~$tVXbU&l#}v$uYssS-~bJ7OtN%LjOz8&B__W_ZAf&I=A45 zwVilqUCqgpkF(S_7yM+ZoywlJYmWC!2|ncX=cCRzyL{dJ&AOi+hAOXGu$zZmun#*e z9x{LL*t?28y6J-kjO;c${nhpzhiSX|4qrQOQ;;!h|C~{0zj*iBd%Ye^#C=Fu`axELwLMI&L+ z+zuMSzB!RIS;ZN*1QxsV3WCbmPU<@1?f<@aB}2rq73Zhb})nBGSV8v30Kha^p{5 zKeeJgXF76yi|ku%d)R*K%ZlwjQw*&-I(GKAHLD=+e(3lSa`~HyLo!WPe!Ss8({B#Z z4^|E|g;qZehRrNb3;(*@VN+)DM~O|>bg^~9e`$wte!b!+ndjM)#b-aYb->(QNd%N7i6nq7T*^v+3F z*U>LnJIRv2b)U$_wCTTc{(`f=Xgk?{H=e)sE^bF>!JS4NM~{b_IkJ;2W$z6=sU;4a z&~tH{p7Mq4nJc&6XzF3_zB_{UAlu(2oVNCSmvyG@BPMaeHD=DE(iYMOTYBIoteNt2 zPn4$rNYt_!p!oo^$=ZH1zg5nEJgEOKP5Qp^W8rj7F+H)bNj_}!wGXb`ztg<9;_K_v zy8ia*MAb6O*qP_QS!X$60Xub<&COpw-l%s|=n2ODA={43eIMajY$rwXpKC{N+<&q4 zV7B|?rPJqpRreike-qK@-d|rBKk=A#edDhWcIuM-dEwx&suro<{Z4uM%sw3eIC*4y z&yvL>du_kerC~_Sy4vQ`H-4P|?pvT4k9FTI!^;m|3~%dGxxst&-qjAvho(Ck+wf+# zsDXFBgr72C(<#j7D-~bbCBf1+9{~)3SOm~T z!ij)5*QclZ>6XVd7Of|fO7?&NQ?48+M|u*gZxtiia?ko2RrPkHl&cg&ky7CsUp5T6eMB-M7cf2n8vh73<{Rgry)8R_}H%T-AK z%jl5nw{HF`I;5w|HtSLR10V8Bg}MK2eCm(U`YS%TAA{1f$} zK4s5e@cHlQ7wrWt{^S?+1rPtwFWOTj{O{0*_JS6F;zN7E!{_)s6{!CbJ}+qT5UX?-~GFC!k4$OFiA7XE5r$t_f7{?5h7g8&th%H-YLc zstHtY$g2N6b5iwcYXZ@pnP1v7uTU==CQv;~OrUy7m_VMMRqQHHy+8HO@ZnE?_BV1> zUk;Q5>0InNp3i(xH6AGk!qq1|nJOCrmR8IuJ#01q3{7>ZSBZTL$$wUyjUIPB#K)xieCNd2~{sYT@ zANoIFS?{NxWBKn7oI(Oo>gn?5c0V6n!ambCzWF6c>)zZ>XaZJv@NvM7XI3LmAKzy2o z0}~=hIW0RxM9b4)GurErr|mRW4xvmUm^P!0N@ioUNs~7k(3|OG1Dsk)CKFrrO4A15YQORN^vdLlE_3#`bck6E)&SsCx_BVDO614 z%ei7ta=nQMEIDg7@syA~>q%{TmJU9JQl)I7SSm~6fnrY*pbfmZv?s#lc*)(9L?jZc zNvAAZ?ViZSdNQBcZF419ewyK0ij~MyU-+k%*T3)wuJu{f^RB>C%wII@iL5AFO1x-G z6VYg-ng>@CUpI&Z1d7F6?_werFMIw3{gRlxpn}D2u#0S1Tcj8cWCMR6Kj|5^^?3ZN z;WB{d<7HB+IeOI+GOAq}Rd>LuhS|)jb8hfR`p&r zbYWB-V)gIov%iq*nY;WK+oscyTTrR#gLsMCfHPc`<@2vq^ulq&_nEI~;T0OfZ-JH+t6x z0e|mZ4RMNzNb%q3ULTA6z5Abocp1WTIqS)M7PR~i!>NDz2gJV$?_cGU1Y{D~O6etn z)(1m>$3<(mD>OQ+wh~H&1Li=s^b}@Qtg9C8A0)LtI(r%Af2x>F$_q)Q6RQ&VfAk6(dzuwp5KYAOa*+-8KPEAOt7?eO1TvPs@hsNVNRys@_-vpc>vROjCbAJAA1NksVGvM`7b6iMQm6#dK)H7gC`EcjvOvE`F$Y8wy&^!gs(U~w z(Fe#?J4K$FUqB4x)0I-ys^|a*U;_aeAP=O0K0vf;RzkUSE(@f97!dE9k5?g8{YUke zN+}@x)bwP-fl?eOrJw$52La(+Ivpqi8o&kg1$qO$fIy~-S1FJU1N{IcP<=C!sd}lW zAcNKSg2g~66)D$`u<*R~Y?Srm3kTC6Akrt44rG8>H3)dBRLPe#@}=zHPjB(mS>m6$ z%9otNa}HK3v(<>k1iWDWUyWV;(|_MOfJhVy5J{&K`BI`(&5Y>J`102wJR9CqepSa) z|EQX6k$_0%DebByTt+?l>#a>Sr=$UaK&VoVfXGw|kgLCZX~gw8$lq;{LT7Q9t^bw{ zqCB&WFA?US+8{FZzh#5|qL$oJlNVB~jHG)-%85{* z-dDfuGhR^VuYy}22EI(1r?JqVVPd^6(g!k;|2d`f3*eN z1~bI1(4yH&C)JfOFbHZ3&4**jLU4T=%aWr52Aj%5HzfoGLK&iWNG*6O;J^``IXIEy zv%#@K6W%TZsiD=Gn*vQ~Pnh@|WGx~G@dq512s9k2)kK&)joFhVL;;ypmLp>TSkfC& z#qAM3*%1o^G(t(?$g5;|uhJ~Y*J410WFdt{WT_0k&6o36>>(L54%T|09C?-TlAu0i z#pRMYdKyj*I${>7Nv+nEiE@9sE<_NZ6g0OcBq^!5d4NlFg6t?rM#Zy3YGXzYUx`NH zN|7Rk3lHFFES)TaK&KHUY#m1$O4gzIQg^m2F?*bt0>q9l$B9gZRmrgFIIcn*S0)ER zoLT`S6^naqehc5~NNVgZmdnTt#XVuV%S2^GWSYE^mBXjWMHx$=EbCe6eA?|7M{ChM z6_e-J>JtzOpd!(jPluV4zSq@QOH&BT%FZn zbGgMTo<56Ai=AP)%8x)I5fT|0FXFMVR;Lrp2eAcEnpzxp3Y}>v1X7k7Ofei846o&Q zDkUD2ZL~phhP;Vi1}6c0%QMNcu~e7U$?O4;UZP_%QnpyMqGzfQwLF#u z&A}8hOt2MNK?Tt;eq7^^SlA4ll9Y-`4MvgH?_u!@=!7AYXNZ|3jyPe^XC1nfIRFY} zFphvgMARg3RAwv~FR+a)Wdav*N-fE(8||qiDQLgXnh&AM#2`H@)M}KpVufPxx)6F{ zJ`#)Yxa?XTJ0TXjL1?E_5r`%LIEhd|ncON)D640P3dB5~k1C|=bU=wB@#4j56f19q zg3UC&L6npFDvH{)NhN|rVk*DHL&S1L!RmK@9B+}Hs{{15h+oF=C=haa3>+_nb6AW# zN-~ozC1fQoC(v>QOr1Wf@Dbq9Ou0fY8N?{C#9AlHfGzYak4#BtNJNmSBIeV>0X z^A?RtJtoKYz})s~S)y1<7;p&<7l{h8)l@gpX7>tRBnXf-Ix#Yl-6$1P{C0L-UPBMy zr6sZ*0E5+y8GZ7NEk=ENvSESy!ls!6*H8BiAJQ7VI&D%Db= zHoQif#f5w@t3U56Cb&Ko9b(agFb1+oL97de#bQEU15W2sNFGFuD+m)ZoHZ{{T2&Do zfHkBv1r=MAEo!~cFoghk(dMXB>IT!o6$aCxfq@bDWEo`fYOobaNlbOS2tt=r&WsDm zI1bf|@YD&=84bNGiWdAOyT}tV19ZJC$hT_s96O-!vI9D08k;sj7$##XYsPRXAeBjy z0#xc8R%R1Bky;ZUXHW^{UPe?zb`nK!q1%;$5E%FrgkG%F@)>-RL*gV7bs1&UmX~V$ zAsDnGdH1y34`QOV%aDBlv*ft5Lnii!jn85#|X(@JhII;+Zp&?o2w7t5e90x@Vb z2&2FRc0W>t(-pAAJO`V0SoBymw9anfbCfE7imu9$yOnXS!hfb;n?kDK`8;vGICUS%wJ$BfUL->(Pd4LxF4cIA+y#Z z&jeD%%drBGR8a_;1k1>QIlXbD#D|93ETRHL0zs;D9;6_^fcr^`yw^%sXCzn?B@m<~ zG9)jKmBG;op|FDnFAK6z5Rj8uOLPRpf>uDR7Mj4sfxAo*z1OJ-Svffbl%Px$;1X#@ zLbs~8QEt!;E#d2k@r1`tfQ#`?i6;oH6Qaa^bUqIig0JzU0Z;vD8%XoCk~H# z(jF|7!c(e1KDjnuXW=6RMw=X-XJCqXBp+^o;CKO@%0LepMQM-USz(3>6+n%laVe>c zjiQ0joUSZb=q^E+4!fA05DKY*vI<0H0v@3=NfYJ04t^4RQoP>~I>#i&sxv}y@*s3=UX zK$sK^h{mMQQuXO@q0T9Qkz@dxgw%ux5DJ#=lYs-VSgObpaKa>~8bk1FabXhK0|P+p zJd$aV2@@f9v?9zGy>bIf%P;3@C0I8R3?zGvx%4o zEEZH!2BckMGbCVD{|J!9ShzHA4MuTHk}Dnnr+IOsN=&M*F^wQ_j7X3YHrHAKq~C!L z%SBNUGlBQ;vLb(-F`EsAWn7fbOmR@)EVwcYQm_RAsm-r)kW0DNhi)R3eG9}BZE;Ofe!UnOOoKk8XDiYGn@UYcnpM|CfluHz&JLLu;hzdiB4|Nxa z44+e9#DwWln2=R~U~LK`^N(TJNgi3@I(6eeC z9^lDk91y+^!I7gN0&S2`Fc5WSq|ijrNZbh`pNOeV2;DrgAt)CFy%+`B1BSC<0g+#B zb!9Y3A=sh9BZX=qitd2P9SV3BBw;G^?tF|wm$6kaI}=ypmAM(K6;?2o5CV^n$t;S= zGLym%6}dBPm4KnPQImBU5>IP2f=w1H+Y%H7k#%)?mq`mEtEEAiIIKpKqX3ZvmQ}bu zvONIy+4xR5J|{L)M2x7A03pVdDXmai)W(@~KvcliRp<~W2_XP<(pnXopY{sHevmy^ zF^SxGsLSpqE9(3vR7?}JSL{@@2c-}xBnm7|hs)AT7Oew;lqJ-Ke8eLUabqTYJdjbA z^lpJzTwqi~vs_LGBGCD$YT4ITK-o~WIV^yJ;%opxi7rEt9%eLc;MG~OQXN{IgcQh@ zx`Z)_BNgxwt0ij-o3#{7uA=uR5;Qo8Wzm8J=wOK_cUgo{UqP#vVBmUAj0ivpv9OyX zBk==*WUT-pArvveh>;2RiM)1*2a!qy>v&$K-ok*;gmh^bsZqGIb`UJUcFS`PJujv; zD`YUO&H>~xQAAdfPeB9P7{({A<0!J+JWrsrl$ZcNjNm)zNj9;{(EtyOR6y|}4?y7UI;pbaHQ2 z>>ws39tFiiZ2Sdx4sKwa43kh$ z>3BpEu!YP@I#Hb$NkkO5RlrK{sGbA_lmt-TGCQs{gvcXpx;@;3+Eh0*io$Nw^>mUg7}<+`%Bt#uh3P zDTz$P(WIR+4VbBw;XE-WR%fyMOiGuLRzPJ7mLdv~s#+*5D&n+wS)Q0%2BksZS#Z?p z1LY+KhKa+VhKq4~N^6AaqkuSWL~>IBTez5K2f;3pR?2c3JuX%lE2rj*Y`er7a@v(K zIg}$pX@XQY21!HLI-(ko-9zP-S?n~csBl?jhH%wXn}P(Yfh5WEDqcK4XO6277Bt@@ zMQbuNr%$M36G>{mk6yN@$@wTJsLu&uD6&jf=K|&BB5lAc!Vs;+RNNU2;&mzEr{Li$ zQbqt~wQ;dz7(p1IO3+4E1aFahKwdnuR_7#9aal2#Xiz%wUR5O~@udUMv{{RlO8s_~ zNyqWP1elCp>y{CLfDq{=RUF6!L&#yVY*P@IwuCQs_fQD`L= zONKElQPxFIDyfbIEb&R#1XXA?@SA_QMHM0_0c%^kjxqk7ePJ> zlb7VBoMA+at4;8a6`o8;};L+y$USDhl3_b*eycvVo@}Q1DQXkcY99!!U$2Lno*VIwLh_ zrWs`gVKpB2Ndf>JfCy~t1dwy7Dh56hA}~Utl{lFf%!mjTjWWxvfNE74l*NwHWbE8z zt}bkL!86s86*G*2<2Z~YLMA9N1wc4!1dL{z*HS8*jbOKn&+_`1xEK^hb>_81ml;-D z!WhgTlAlG)7?C9s303yQ?Yy!>Cvv;2%%Tm(%z|SWG1Z8W8r(QB)g}huv>4T^Ao0^a zN}5P;(`$*f!GrVRwag5zW?RS7PlfSix+Mp3YmfR+QvSqxDq6dK|>lQETA zlfemW{umcy1zRB^bT!X1IsHmEEoHYEtX#c00tR?75Z$jf2B~2YEJMXx3#ovpjt6(; zZPhw+!bWl^ifJD=MU~jiW(vAQj9^_31W635By2~|#6B^(K)MDwr+ z2wsta!$J-VghbWYy7i^?r91)v8Wm5(OaVd)@ z;^lb>t^p~<`HgCoQAe)x6eaw$Ii<*g)K%Yww&=i2DOJFA&_g~fOi0qxj21*t0MGjo z<$%l?;6<`tD%;_qS?y9xB1p=s#dK^?qp%c6(vX1f(PG2wU=9@4JJJzIm=nSl}-%^3j4#d2$D0i3WTvWDykILxYx zgCI1$)f9(lP`W%jTMfBLwO$|&(NdJ6IwF>&sAYu-Of^>&Lnbv?C|(7IDky9~=+3B& zDUnPnNrlX2U*2M_t(e%LV9Xv?b+R^)0dngI7_eh(wqrdG9;8UsWugd2@;_gIGzfH z(b2GYCnT9Ghg3#5LS_rAz-&SpUFK`NF)5O$fy#w>2Topz8KO$Fx*Yb(J#oHQM2L~? ze1*g#XORdXS49F92ZoLF6>9VHa@L89UTz;IyEak`$@jyekxCub;wxgIuXKe_QRua1;tjuQ`A8&&zVRIS!DnO zNr%w57|kIHAh=3anv>P}eT;%K#^Ny?L6^D0#G!~Of*DyCcjrx5H<^-k@cbgS+v10S zf?{stY2j2ZNTFQl3U{3W1Z>Xe?akHO85B9wHA*59+Ju zmBC9Wf)pCew>S;(}E`G$sUS zU(gZ(^ihs4&0sTgL3r312kUbAx=lmw6xCB*W13>hjPjZsw!UR0vOcvu!ACM2#Vu@a3Z6+jabBE1P(_LC*mZ6t+Z zXRZ)1Iz=KnDIE4np+rlyNMNqIPEa&KcJp%Tyb}%BiHwLQ42jB&5V8gEdG+2rp;B9b zi=nxIP%IE=0!FspET8HGxGANWhi2elH3Rit#)VmduETqxd;ZNMDpmxfP?gBn`M=NT8t0lIa$O#zYh(#Z~=r zs2q7(3hEc3nHh-A%PPvs61v>a(R$1gzzRxYeAS$a5;uwTxkSDYoM*8elBE z8iIiHq+p8@ia~}6Qb3N>gQ{h<3Q7ouh?HhHGz6y*4J@5orbg(^DGiK<)-d!2vLZ&a zYal)a8_TR7zhhXz7&O!t^clP?BC~3P@1Cj}tj)a$Og=#GrE!4^3I-Q}MRjEkk)U_lj z#+&wsFv&7o;>wu>Xqumj@r$CVELF@-La1V%2nb0{a+_SEjcK?by4A(>9K(;;5?&EB;AT7M zMFxnNrJ&R-MG_(8CfOLI8$tx@xdx0$rSx0aNo63HH`J8_+z{LgR^aNAo(f+GD?vy! zegF)Fd3A6_kpoEcd~G@h1;w!PVGU0;IIAl177!G*gxQj-pb=saBD6fD2a3^{Vh# zV!$nT8LBfy46i5wh%u(>#J?lsWQl84L6HD}DqteI3oOwTSkw}YQ9`iFT9A(ad6&y4HDx)t9{3i?S>eq?=I}@b;WVu=W)F`nhzPc2OS)HC_&{+RCH(I^< z^4w^B^ZDFpwd4OZJ6c@~`q$afr>pV)GCf+qzVD^!(U+F+{zucJOd5^;e0G$^AhZ5l zSQ&&6JmL)3VmIoT*hHRRET;?*71ig-O9iH+16;&lodCwc)K*`_v!Nm-ldm>L>6BVl zH331%tI?-diAX?X892z`VYrJ0OxBylIix0JfxwAX%*Zgg&W#V!fjWXG$^$aVs3=8{ z2O|)NnT$(CzBaNEEH8H$H&U7I=|P01JP;Ll#Kz`;Nfz=St#{r9cmkx!B8U% zh&ZO=xP1i>D@{#Ts2L8G zTrDVJan%Syoq;F$f*91Vk|Kn7A-RI^<{?@dp(4S?XciltsgtX7Iwc`nkcs_#3|+>8 z5LqD|SO>xcpuin`GSQeA+Qp)6kA>;0>wQ{8yaxNtJ#6tuj2afUMvwzG!~30b(m~5yFG$n zq7~q0}%zPuBi0swEC;yv3uF@59{H|AX+YrS- z5Q}(Q4dp_AW`Muj$~tU~H!|DIw?L}CAu5yZEL(QMyC}MJaZfVuptnx`ZVA~gLQ%_* z@j|;$TC5LWwK#tCP6qwtyHrr<{8_y8M%7ibOe>s521&ahpF^?GHyGA$oJ0d9@bz{j zRB>(}HfNBbkNC^Rf+wd)iu?Aki(Es$I9F8k0B%tsqYZ{&M{*z?ReUfL^+L_JTlDIY z=|i~GLZLUD`ovZ2N7jTT(kKp%J zvo<*ZX}KcS?k}*@mYIPe!js(EdG9RQ4KzAB`uD@6+n-vw&3bIZ_`Eb4Jgb*b1PVrx z=^@tn)7>8~y(axB)9>CFpPI3=qZO8TiuXTrJE4l_wDn&2hg@>`l~@* ze=Vr`P5Y5iton!PRlc;Wo_k+?4(HBbf86}dsAB)((zW?%e7^Ot*b2qk!6yFn&5S-S z>&0|@g8cTT4u;}{$}TlK9NzX~dUh_0bmuyJn|HE9)YR}Xi`mieSyrPJ5Oh<0rT_=8 zNAJBb?Y?)KoxSj|h(K`5!18HDEFzZ?^_M6-!N66F*zZ$QR{!v+MYkO^q66SYM#*83 zZ(3^Ngv?gEDDWjXB%4d6lgZ8A^!5jtr*-dRV}HDF($AkxBxdwkk5^yO`NL=}+;;Gy zsGWx*|L*L9Yp>d#X~jZj_L*Bgt*$z1xAeH`H)DyvHjunsszdfq_lydDkH&L$YqRZl zbcRcBtT|pMhqAwqSlRZ+d`oNfyk$9IF|H+Kl`CwK1%c^F1*eU!XZ{L$KbG0>D$`iY zKlqllE!$x_!24Db@cC(%T?1RvRJMrw^X!$a?_Y0pXdE!Hm&1dEQr|AMvv1&i=2Nr> zY2)|(S%{vSPCY3#JN2)im<|NI zuVTOZ)nj2dNO=f8>k>z=lS-K<;DQDe^72lIK3qTS#`F&|Jat&f*0Wvr-Bynut#Td!sviTU zLerS6WU!bGCib zbI%2I6Pgm>w2BSHUGgcx2WXSLkD{JV7)?E@a=YS8j~ehWy;*e zU-%U6ru%bqX*UO-#(weuXoIRI{o&o^G;27f1nBA1H6t+XA=4FW#<&2^jBa&3Ct#&i z%^#Wh>9h6FX5Zikp`CS)#o0Bj46}kbBr0`(UTYqy_fNU$ao&eMg&j*LxAN%vAY}Kv zuhqX|t6Jqsr^&F;-bO9L_luW%f9G5Zb|+6~$i{5U4#pAKhdKPdjcPx=9g&@KD(n3evVrq8+o}|S40bU)??rpTmua#4rmfLG?_>>pDZ&vbF z#P@14k7Kz7ox)RT&WzgYR;!*}UML9*U6&h6i9D{1QHI50d&-2((n7=+U-P*E#sS$+ ztD|_lzs1*Ie3dAdt&~o$5Hlvzt;I>Kb?m@wfJMOk_gL| zyVLU{RKE_%Dv(i$Bzfxx;zY}PHE$x5v9RV}<2GPNQU@A#P(tm@b1bkv=B;?1RUQ_8Y%m7P>0|$LyQqv|Opowm#D$0o zMhJ%+KUYcel8L$P8RP-%RHK)V*w-S|Bh&6n5bu^~qp~2kiwv$G zq=T77o9tbdEk|VGCOixE!*CW$Is3ro<>KKgN>e)QH1Esfvi49@vK2w|%`Q4`zu$TT z8$RYsq!uP6TnX9i97nZ|F~~`C0T1@==GI?*8E-saJ!d`Zy|r=a6n5$hr%W?+XYp9h zQAk#V*kl`bo1l@j2G)dIa!Ie`Vz^@l-|KXneqSxV?rx|{Nj*mO!Vx`id%R_qt9vyp zpRLb{`8I5c+*=7$LY3-cac8Ru*)5A)LHN>(JzxWs%b$EZfzxL*i=KhRQ84aJ*Wy$4 z*HY2&u4^H?H!pe{tQLWOxGp!i40X#F*k5kVzA#@;j>))nPTWS@hzU}kSdU4xRKodE zwoj$OF}`o8f$vJfJD(zp(GiRb-+nOO(%so^Pm~oXC~ZP<=l99}ILCTr8@bbV*S)AJ&W1^QsQDHVLWk^P+5}eI7qaZu zlkx#I_=6LYufp$gd1;r$b(a{tx`lqdFg#hM^nPB#%(Q0%n6goA|J>3I2z4j)Zm3V- z_G!bkOo$2yOQqt3N)|h^_xWB->5i6qAY*grns`&2Zf_@>)2-jia}QIkhX+?) zYcsAT^NJE|S*TrpjS^q*ynS;VzJ%@!tZSYZm94OJeB{ZlwKJ>tXYGqiW%ub5XT_0@ zy6x@v(wKTk!$spFwVEep0{@*My*+2X_q-o93(1II8{T*KyI5jN>0eT~H$v`QZmDv%2 z{kxnJ*H8Vrw!fS`WZA~+6#>h2o z>=?{{r(n|l!c29QQGjR@$%Pm+L-dzCl1^s}HsSlboJ(wtKTbb>rRn}6p{cyqVAi9l zVJ5~l-!3VTm8w~*#O856%PivMxX*h`RZz9+l>=sVxwY~$d|q-p={%WxlK*qW4Whb0 zZy9#cisg@$+T(GdT6|e(L-2Asn8(X8|0yHwE( zdo@n?eq9rvJs1C^w?wq^$=P~bK67VX2A&t>HPz(Qrj+X=#^SV*D_wOLH!H!`8r;S= zp;x=W0=uq$1;-p0Eq2)j#+QDHl_xW_n40}En3j+IdAp8!0Tjh@IW_7Z0x5lJtrYn? zxzFVQXql0v!?hw+e_y=rE3EW9zp7o*rTx(_N}Xm$xs73Gp>gu3BO)Ol6kuLJ)1C;+}W~GPg_s&~F&- zd*5$(fZB~Ifz-FaV=8qSBs34vxG6tgyBI6@{-;*MBlx)LWB0H#U4DXnVwsjiCuXv^ zUT*4_U$xF?5QmG%;o4B^?GRiUjGI4EcrNu1w3xt?|74CiF_83o+F z{t*oZI~Jp?m4w3I#~9__w;sW*iY|u-aS&zI^$%FA@E;V7xkaHI_V`pz80M3|hWq z`j;nrCGF)HxtBM!Xsqy)?(~daXHG~uK?vQ@{pzaIPfb@~Zg zC-8rv`z`Lt(+4LY@M)>T14CfCmtxSB*Hqs+#ee8<0auJ!0H65ZZXlbg!mUsRAlj9lQPq1&giI24lVV zXG?!!uRrUDD=8eqjjk$>ow$Dqf+aEq^bcLcRGHH*<3;}#Ti)Fb%8{73M6p)(BTiIH-apz5pouzaz{>;hg%z+PZT_C z-{)MNT4?w5;!zwV8NFn7TpMRfvm8!tHK^uG_zdR$AfFY0?7e#Kh9NK}(GOQSH7{RO z46&YH}|+KbOp;iQ{qi;Sg(iZoL;9 zG+t-vqt*1DShbhBw>t;~k$&UW!YvtK8|JK9)m%V_mbKmE)-1KE!a#qggOg2Jot zvb|+zol#z7@YjkOgo#v{^(&@+$*drDnYxnTC$%G`?)~6 zRC|Z2+R!atO~Y$69ZmqV)%dw_8Tl2H!e{;2AKx;U?n z5J{8Wvm|xT4&zO)^D+nWBnJ-aWn|~BBz$jJSV?*66lUZK%m!+ee*qBv6Q0V?=FC8i z)pquAx0Tqb>hAIC&Wdnv*RRFiU^IE|9M<4w7l`D|7+FQar+DBOKGAJNt#O}Q#{#pf zB&H+ogg+afJD1DwojuFg&ZepHk-3LAd8p{f4p`4wfyVw|d zh2~v-m3W^-`1`yo*uwVYGsy3<)UEYh2x#BOtYk4mI`=VShI^t*$;Aa}>So$xpcR_| zIDopzwP`IBK|DcRl7+|JEZo`uQjGtP0n7g`t@J;|YyVZ52WNqQ;z<9e+2Z~SX}$#_ zNdGUk1pW;~|C=-qe)GT4=7s+hT;l(KW&Z#6ef&FR{@=wB|5wU9%L>B3N%L%tYk>6i zzm^`H3es0A+~oDO;w8L3Y5Zz$JrCWUfYbxH#;(rM{A0=!`EeJI5?jiPiq&fQ)Qemf zg{&k|?^rH6qhC~p;L37!-|&{K%<|TJvwB(B-JK4@oM{}^uX;p2*!;)q%Y#BKcaQz@ z=Q{>j^|L;8$dwLy=({`Myn#c}ybiG&H{u`ew-cO7-#l#+z9ddZ&+5_Z4*%>$4apnB zR`jb39X$3|ymfO8&AUqb@c<;Q{+1|psmp*)J>^UnvbDz4ALh^Pl>~Ax3nEDo6?i9o zE-(X~d=sa7;9C0W_ZU29=P$9SBc0E&Yw>j}(eyi8N;c%Vl04^IWCS5B(*CpNyWW?} z-eWiBTesrs5@MHc5oBV{qbn^w&C;YlEBhlG`SbbSLZ8T)==`d$rWl<&Jm%mpt-5zhD){+Sjm_RBxjf!nMOxQ0mt@T8HcE$69MdynSd>?HmU0bOqGZq3?P ztFpUI>UZ}~Mm9mBN+&B`mi)chsg)-^{+gCsQqy(pa0-Yh;GylcM$68t`ZYn}v0FvY zLBoW%vtU!syvlIgw>r$n zT-0Ie+3VXf)f8A02TIDF{*I;>5#%J4bO<0QaSd@VuDKfmEpihzk?Ku9F1W3kT$Jxq zrfB(9-z;Qp@##ES>vX8BPpRqx8C006YLQsXOtm3V^^V)#*ag;yXoUy-(CW(#u{K(- zGf4R| zn{4?Q9K0%%|X|QkL6V%0~E29f7sZQ?>X?4GL6De(;4V|0;dtmgj%A=QA zyX=if%M_yR+=!J|sj#(H97|AtrvJs+W|(;odR;La3Ts;Y9_+)VAMmTYtH!#0zGT&7 z?=rHJ7yew`fnMiD&+_XJo`emuLvj40X9&q0gItc8CjQdBRU(Z8tfhL(Yn%SBuK?e? zUNZ+MUS)1R@m&zDPQ0tGo>ed`Z=bh5w>VK%kWFJ*yyZrl1=tsQ{_{-`N4W9fN*!iV zZ|D6`@T&UT9d{LaX}O&fZ;-=kri+VCbdE>nFeoe1@al!N%_BCzt0KNnA*^5;RI@sv zaPlyn)i7kd<;!)Ato*j64!jjY$|~jZR5;TV;B*!k%?rRW(f8>e8y8B7^US#EpL2Qt zW!1b$Nl?(ea|lf zVPPmzl{`Py2tItiV->BZi9;(#pMdzD`nx}S7$>I?V`;falW2_ar zS=Lkg>mRXkHRlT_-9Cc;dNsr>A7@@xfHmUtQFqPX;&CA++?7*U(avS>|}IdMNi+|*b!y6wusjjOu5Gu zw|O}V2Wz=lV@9j`zT6#5#n%9gWAXJU{DC~%vq@U>Pr9a^3A zw%LF;t{<6jbLZjZWgR6MxvE*|AuuahuXtQsSZjGwzojC>PS$zJoRAP}@ML3>&s})+ z)lgecZ_VowB=QjP8q89o+kJh2QQ%%q*17-Cl1zNi)>x@ppBG2L?aAzlTII^$A?qOa-+@8wv# zaa+39pg-|Sz}&?5ac)Stc)PJZh%(%fK)qaRoB4c)!$f}cZTuXCz@4lDe4|2w;3`u(|y+~THL z^YI<1NUz{w4`;{2%y@nG!Kc&emW#8fu$q)An^$8)(gWmX;u|9hd8p8EyrBnHrO+L5}b9Z z@ws1o6^!IL+CdV`?8qaL2nXVF+~ZrHW?AwuSw=xnjCCv9{e9 zzfFZ|o@Y8j{DFv$tUCUpGWdJ`l9)4CcG#rFyh+?&5z+Y3k~ zk~gm84jaKu5Hnyc>_%n4K<|%yFHwfkt1z-k#|Zqg%B|Mm`y3%BVq)Ce&xEN=b4TfC z);m3nX0t!847sOh@rM?M+f@T5IafJ*)ZoJH&st}7cSJo$)%M_WTXwa%ix%29M+5Jd zdz+RDLS~ob@#YeozV2XBu4V@?8@Bz=o5Z)C=8E0h+1^CE_K-ggCOL_>ckc`kxvlzr zonp^%1&q(3dLH4p47z4R{7S82e(nZGmi-xa{0T-<38FZzDqei;uHh zDT1q0+K<0N`L~;wc|C}u-yPD6oLpIW0eY(#JF|q+S@Y6Qr&LoaCxD6U9Tr^wWmPJ| zX+OD5=l$sp$b6qj@m}u)?flYH(>dzjhzsEp)a2KXiHNZ40Gr;y!XR@jw~{mUp@@$9q{|-`-N^- zE52PuJ-a?nw!7f~p8RQj`siQ#e-G~S=TqIXtrE0rd)zkKcUC6@%M8xDlZg?1fI{W77z7TCU`2aF`ZlA3kGdy6%#dnvK(>)FK>mpZY#u1f73D=KP3B8 zTx~qrN-q@#K7B+^$SYQKwU#wG^T2e=Sd;$YbB#NT&w%j*$UYBu3#R7ancto6OIoK@ zAz$lIf3hp8Ie&=1Q8HgonLhC4z*(td+k5b`x3t$JxfW*!%V7(@#|9~(ztafnCf36> zHe~XN8;@fe(ReNH6092pD=c`qs5e7Q$JE%HHc83>;^*4GH2j}zXwSr9vwHw zzuv6^bmh%aMK)LJBIx#Un>RG-rQKG48}r-*PIy;kR%M?@ZMHjhzYAnElP5^inOEn2 zf^yJk+-kz>zI13?y@IxGp0qMqw6J&dULTnXXlG-X{M{Ti;ZUEI8vUBY!6QRNHYhqF zZ>iXn2bRPiQ`|VNAZ=969k|S!)%oh%X!oacua7VlOiuWv|H=v_rVJjiD2!XHYmInx zul%Pgazh_%c#Gr0t78{5-dvi_=Q9OK=+3TKFN-$J@C&6kN3BmLDsPyz0zTOIpfW;u zP-1l+wi|`j{n0~6z>2k(RjvBhhi}p0+kceN+OWF?DLW6}0yM2C{EFgcjf|bA_Bwy+ zj8yFE`fY^{O73(@(XH|&ez}Voco^IB)UE$URZ|EW{d)5-kcI{~57b10R&{Sr`Oi%* zH>QX0ucmZHgxKqPU8#}|zrD%zc&r{pYj4}9bbG`272a-|w?WNPXZ0?~B=)Q;+a8;J zxkW>(w@H7J@gW*GWAaZe@|wKZ9#4k3_vfVn^NG&vxYAIS;-|5qc-=2g9>aP`7o>Vm z94Fi6lS+y4d3#s+48o9hk&w$-nK>A8Exfrr@wrKMqmokzyPzMM+z-(P#}neN@{0;b z%u~%fIju@ayxqUp&gvQbsl@Wg9yREG9gEXsePuIU$=V~H0ExIb15qsespb!%^kyYT z9ShTC{CZU;MmRe5u4=hK?TaIN~b~q`Iv?^_Vo%V+TE--e>ztW79Q!(FUlx;K=oJ$kX}fDsy%veb{*#jvhS)Z9(dQ5cAy*BUw0a zRCf(uNQ9^TNMAQ*j?>6%wz~UB^N&=oU7}iV!iQ@iFVOaB3Luq^+sEzELHWD@VET+9 z!l{vpwtL+%%mPuct5VDgD1N5trN$x3`{^gOEuTi0T zxv`D;C;q%AP~=(T>e6viYkDZ_mR0NB+kW(lT`6Xl z?>w>$2D!`>a#$PmAALQ_0t|Xehbg$`9u`UyxJjCzUFB3k+x?uXch?qexb2G2y_Z_5 z5yzu`&zcBGfDPaHt2u>>cym)e=5fWP($TxaL&e6T`>~{eCfn+jz7+bz?lUN*K_`Ev z4Wu(>lbip*vtM-r5S3-8M)hz8grH`_UMhkpfzfFF_~?E*)~Fhk5r5OLGrZPt!W>Z4 zi7H%&$ALoCkQgftj#59_g2?9U+|OIytU}k{h7o?Vj9!HJ0Wc)PV@3JpDLAD44$yUE zTo2mTOa14-7T!DLTYOS)lrF-uay*p2{wSVQ*lB5)B5Y7SS!v_2MDaKIf)jhDbd>GF z!}@Vh)a8s~ zSgNqpWyBy2u2iWJb?Wf$b5JO$#9^#qOUW6|emZ+2ui;-SqBu z36qUrKK9Cg@TZyjbeS6J<<2L?miyJ zJnkpw9c=dSTXLYUgOAmd@%D4tuQl$@T4)L-zKh;FaGV^WW{)oy$Cq2G7rKiFV@PAs zLb`S9$mxB!@#t%CTsTc5UAwsnRi&xMjp6M#(!d0!z<+YLU&V9jx~Q}lN9eRpE=YXF zg{Gsg<45?qm3AwH8`F4q_Pj~2aQ1d?SZ~NYo)!BVRk#>$pXV{!x&D@uC;si!yUhEz zkU=*SBs@>-c6e>Qgr+o4^%7ECPOx5l`FqPTh;^(rTVD4+n>PO?RN!UIj(P{DU9Q{m z*P~sf;s^%}FIkzSk_6<2Tv<_R@{Eid^Is!MTUlqaTIH)TO^t_3R?2L;A@m;hvHo{Q zIGxTLTlkMq(bDd3nRP2_X@CrqPC?BA2;)3*(SS!uLi)9w71(oe;HEaWz@kE zzgU-=0SOEj>Qg#`NDrgPPvGK@3*83SIQ)*YO#K%187N?(eeaKJHU``es=W|SIGg-r zR2Y}X(rmXKD)sR*Opxuntge`_GF_jlvP}Rt$EgtjPC&mspdrX`e+hCs#(2qSUXDj8 zNC_WKh2o#Li8`eVovmMvRyZ@`SxDJu7OJrx!_`k*{1!R@hk7^`>sCtKe9MFL{+h7^J4n z#MY$7kMKdMaAE5dP@{Iav&brBx`B{>IuuF{dJ|T27>slIXus;z*WFB>&(&^fZuhn^ z3`Rd@{tFLY>!p5ME4whh{p}*mc@9{R7rw$5#^2XZ(7SYJna^rL8hJ!|y|^}*Vb|Q; zk6v@Zw%1@`Gj1suAf|`frgm1~!o#;0w~4|Jt3X*i*V>mF^+yhx?Boa?>k5V^k4o9V zN{Rk>em#*BdteyF$H!`Zr`&*oMe@yEVCrs0`ubA>{Zt|dZ zDa}jxGFS0s;WUKsT&se}AUo_o{9$alvSv-sb!<8nWo9vo;Bf&dInrCSi`8eb1}6Ad z+3kP$S$=+P_5b{t2c7G^ONm)b_6tyd&dVQA3ItxFIF(ns%CKban?O(+ zrHkXSRPR@;q6QGLZ#XV;tD9FZcRycm2Qa$jfCm%+w3!A?v`93=-sHHZdnc*5CW7;5 z`zd@og*kJTQG_UJXgp(P^MTU;-4O-rdZWUk&S9_*;G69=+-}_@0_(l9swK!$Wc$6G z5IJIJ5?vB(B+)3k?1(=xxM?uiGcUzLgDUTd`ggJ6L6=l%fGQeSwO{&Q%5VEY*&aUc z5cdm%Q9U4M2nTzhu%dFzCE*h#DULC%{;_b9N0n;(Tg;yCT3I#nEO_b02dj-gyG7yz zWFMq!f9Jv3C{&@h(PK4ajlMAO7?V@b10{XjO^~m1u)XffKjbe6`h zyfW{>t4-5oZq2oU8(a~vlDuNaYm@~Pq2I^sNBp^U3L%{-*RD;Cy2}Vn+_b3MBu{ z5=_=h-~{;le+vu5O>5doN32QG?3Qcj{k=pW?hVhbzITe?XSI9im)ZM%&L$WiPs(kE65~ zw?H-Mcn#afC_;$ww&pCW$#KP@uhC)AsuesJYVK;q^bGH?2mwKU+nDv+PWu98fU;0b z1(q_S?VA{elM)UK1F&U`wnlqo6uZEo*nyPgxPCEvL9E@ieGM9X0sFh28rwp^kLsSU z>(vu$c;0v!0$`;_SnJF3+;;W-dxI{-8V)`iEwvtI#RrGjE1})r{d@S;@&)~b;u|>W zh{08_#8mIHGG0bwi1BdNyl#0ZFn;4UMdIR~n;uH@iQoF8fG=Y;K9^rRDfC)|Jfix) zqwg9KH-unVZ2fM7rqb^<@1^YGme^%A{9`jId~Vk|hW+}bQPQNU7;qKa`6|9=-=Ruf z@2@nO!ySdY{bof#ZC7m*8urfbpR)kn8!|0=zxO00tNV~A+*+qB-I7MXAZFrtnvZK{ z+@V=qh>kCmeO1h9cg^fg@xJ_lQm+|Et!yD8`Aa~{C3?0wd9-h^9nyAstI_z=ULgp5 zpX}D-?Q;7Zo~FOAb2dTq(m21~%gUcr-c0!8dN#PPVsE*}K0dStV4zz$pDPG#v4c^? z7({cLxj#A&FC4TAZqn9PU+h+%2;tvTY!~Lh6xl3F)}IYFnsCdYQD0EK&qGyUNNgV| zym{VK6~GyL7Z8a=+QKzfvXg7n8|rHNw>k)8>D!-tTtL}G77i-=HqH*5>HegRgK^_I z1KJ77*)4x5&(x@cC^bYCpHU=Jl0d)*}?I8s+LB{|4~;5irkr`)?O( z<0KKz?eXo)K6;6_%$H$qLdA{C9uT`x4^Ik6B8`J?jqh5GdAe-;Wq3TBp5JMFs$Ay$ zi6vR=mxMzERNyS?cI7L~H5#|8z@Yc~$(Molzh8=|J_?GGdR`s$hK*#VIKiiX_5Q{g z(Tau3qdxp1v){oS4(clru!CvvcP`G4RdQXfmuwJxh84~Kz`)Bin3|rOhe7WJk~1X& z*5o@#Il&5r9%kb``ozFD*v=*Uk z%cQS8H5!7~Znc)|TbKEi=$oG5H%BeTK7D=V)3A?2MZq<=0ywLExTA+E{%eMyCT!;D z@g=RY(pwlaO!+m3X9`n}4R~7iOVw+qb#qB>-~o5%lO@y;z|2Sl454(T2F_<+Pw=)gI2C}g2#l~FF~H69k(jjy0l96ec=80_?%2T+-gqM z)J>y!uBBj-f-$FmlBg2#1a-+lH+oR%1Ul`?B-35JEisU}SEM(172dgWr;pR{=G&(cH{#C5f%NevW#`WuzhdLa-zT+& zU&xr+!nq?}@y~f)Li@QI7EJVTT|(ze-1?I7RtMnJW6Hc6QLqP<>+niCoa>{Q!%0h0@N{byq-b4SeHm1XBX>nZ6%O_uTV{l#t7t^3!j7LE` z+rvr(7Jqj#oKTYiI(*JR=l|gVr1$K1E}^GHFV)oFyyoHzU8q_#sO!KsU8MU4_tiY^ zpy}H z`e#o(%Ah+c$41&5nmsClJ^h)ba}Rx`+ah_x&?(fh7Y}L)jQUaOM6YFE=Wml=V}9qM{c>G zIm;zq($Dc^6m%bu0Ow^`-yEMs?K7~l`IW-j%!!uGq(4OSS%KYQPZx%>VQeXr2Tw)*>{tG^x*(i>zT zzq~^a5g*H6j^y+Mlsm2yDo?(B`q}9zr*&mB4vdT7fDv`SJk0H-X^LJqVHM{tzuf5q}J9q2t`}L6wYQrsL zVp4-%=;!iM@4lUVOU}%h5U_uW3{1(wZdT>@o#rUsTOc}Q?E9eAcM24X1|oznH5ISI z1AS}(BGZT_H3)gnC#YFAXTQ)et^pr8L>ce=9r0EB7#FjZ+#T$+x8mfB?%xGHk?u3n z+h@S(1S5bRfd&Zub^MD|61x+S^eT3u4QTLUgytuGUaNIGM_TQq{Z9J*_h^3v>Z$n} zQlp>9>sJ}{3r#N7OL=Tf3pTL@BhP-468#AUU_}VrxgM_%1AtA`KUFDvDp*3>YTb*s z>fmP*J?Avtuv&943&D+XC#R5j)ah|Pq-$_$@nuIBtVw)j9xY-2f)*&)spr5^iaO?6 zj@9nwc&&V#S4d0SukEj|BfPfsZgf1vK0PXS~vo3{ChHq%E8#}j`t|V1eV{bs4 zU|{@>xY-lbzf08s*d5;KayYp1=rit;1@{e7Y&{{lIN#+{bQ>j+%5t&w%pI5Zip8lx z&MnaBG-=lN8;EpEWLM<(8?E#l8(5{CUgbA$l$9{O{_*^!^&I>9a`4^IeDzlO6_2Og z;i7O6k9HcV`$I>@c_1v`^rXi@U8FXvfmVX!3lYz&+Niiyy~Z9j7GnKHt81@zQ??rm zjq9t~xBf0QWl)uh7N_Ux8`gcRw%dl58q_=FbfrT5+ID!8ozZv!RMY#NOXDVbPf}DW zH2FJxMoBC>4VDJ`xn~YbXiq4Thso}Q7k)DkVYC6 z8x&hqumiC{Q4z2K0lUcD`_$@39a5b_jk(@8bLZZb@x}fsvSzGBFzvwUBk+uI-`8z$ z>3L5*p9XnkvT~GeD#mKHaq5JA#$ZOg6bnOg4E5M{Z;ON0pwcXGQkq83c!?tSis~fy z$~Jh^{OW~w`kw#!?mMyG?;_|zt|g>88-#~+ZWO^>At0;?^IiXYPs-O z^0!VoYbes#+0D((fbUi3K6t{yIIiwL7tNVVWcri2tIM5R`wU-NRtGpvwV9j0FGXZtp3YnJQCa4P-cWFx zGpi%OSD*)Ymt1EO-JKK2I_uX1OYoK3_H%GB{R9B9#G|Smy3R*w9l`If9y%+LLh}8J zBaqDWSqadRcTBG8_+!W`muqo!>`rWy)chTcW$1-0TiL2{_F8Z#s7@P2vYXbLuX`(( z?#MJTNugb2*c>I=q*IX}r)r+uJs)31C?$*2?gPrB<$Ph17G`0O!9XcsT z>{K7qRg|PF)WJ>FU8%c{js8q#j@1pgiaVj4jgcB>h~Nn>m4pEROsrZ=)_OxMnO#Uw zoADnHp}^vxvV#^z`CK385AICIU0q5Zzm|XMkrz5;^TR&tbiY1w!y92^j%H8GhJcly zS!1912KD)4u8nJwTVLGsvjNpDcfxr=JFh=mXyX;LuSELNvPs&2*5&?DHxt-7J-;HZ z#{wc1O=o7J)vH2rXGG@~^vhZf8@rYt_I3qp6-s__xvL)-+%WM2luqYxTAEe# zR{5~T2OQb03n@^f%CZK`AvP0mhD*CA?aEkCL4OW+QC!elWb4tf_?2iLxPk5 zv69RkYFC_GK+H!n^F2u4V>&I#1bo|-)3{L4mKoJ!m~*MSadGgKmb1^!3pR``~>@g)ruNzm*+q3L}TQtqZlU-8Lo?B7I}m=@T7!-ou~op1i@A<+wWd z9{8R=psOn9?6AwcoGIbnMAF@G)os~}=5{h**6Fgu1gU3GE}bI0^xYugGlR_o_B(DA zctJOog+Y6QzP#>44NGqFH9eHkVVleLTPHc^62iU|$)Mej&+9H=4glIw$Q;kQy^B?u zM}&3Pj1o%mexF#AO+TXM*uFxuGcKJgwK~%!QTePMR>LpK3SFD`pL!#VDpO+-W?b!7 zYpkHK&aW463T?EIum=PZf09Zct8QJn3BonEYD_D+$>0bA18<2v>Z9y_>Wqpk$y~=Y zj)Hl=xz(u#xzNXp=Eo{*@>lv3EMVR-@b=ZkQZ+QOF0=W2gmcI1^T-!ghu5L8$&S7o z-gP$Wet0n(gI2)xq=wShg!oO@Zwgxp^FY{3 zI}H_2Bo}gjXHZ8=yCVspcI&~g42*apo)d?#Q2eYG*UfjaD$mz5j3Kv~hA5BqR+tCFHxmzNZlu;#R-s{SVEjik3;FMu%g?1I2GLtmakdpISJZkic zTcFAzclQo+5lo`B4s*#NG2MjZFXwA@<3euD33n%{7M|bT zN9WOGcJuO`1*U|>r;Zdnmt+U=k#oZR*JE=D!05(Icx)bn{PTlWB%2p=5Z$p~UbRg+ z7o`@-eUVHIxDLgR%EB$NnP^>l_x^y7A|rca0s@_=CulG(sabzA98JUY3u{(f+a(r? zMy0Yj^uz#`H6y^Bxt4T#m(IDt_q`dKNSetTeY47e)H`p=IgXZ6QClSf{SL!xO< zt8l7IJY4oDe*0_lB1{`sxI*F?E6S;X6AZfi;I#;g?-8N2UN?&s_Qz}!xF~j6&n4mb zDFWghS(1t2X9|4kN!gs>v0ohyTQe-(o(+0g#oV%#?Buv(wWc&KW2`AT6#=V1^1DSU zr*=uf^i}m!e57vNo5~|Dk)BqVn=wLFW2!wCpTK;h(ac_NL@08pOFjLG+E&?VjM}6t zVV_=P+r4C^`^_9KgUg%SXGv(5=5H-XlhK0LcAwXT9f&;$ozSaH0pL^NwtqZKu5?eM zH?%#K&;jd(Zf4t8M}y?p&kV@P>*C{HrgRw1n;9y5O?m+`3QEsykK>?3-!)v>>Yh{aP^wYQ0?AtDLj+b(@72TNjag*4D*MrI*X5AAI1M&bM8}!u@m=Bcr!nARvjhxT^QL}H-#YvNGf{m`71xJuNkmrtYe{)4j+A`G8iVJ z4gZ*%pm%c*rQ_q$hP25zrxw^)m zJ=WS@q5afHOKN7edcGO=nUeEiw5LU5w0yRGD&bayHsmt~2~@kCH?cM?wk&hMoxb=- z?VRKy+d{5S^K{~tsOTx-8h zM~T?D%H(vh(08wYgR(2>AnANJ-xLeo?2b!k?4uzS3%#r_JUiPVw6RX?;Azhj=ag9$ z8$8#l9TIixVx>#vT0zeTm+y1Oouve6no{b9P}joMZaf}EP%35!gUI>AYJPFAV zy4@it)P_P6bcL(U&Y)s&+ayq1X`FoVu78JqTmJ~~prZ@q1SGZ~G&WwZuyf=fZT^DH!!P2Kg1_ z{slQWnU;|+Zz zv~OF|;G|d~H{7`QFtL-}+C7P8+U#v|i%>#nRk(#0X^!l z@tWoG)O7or*;c!hb|3VC<;G9HFC6gNq#)8n>w&gY`3iu@ebk6Sw!66u3d=>9nAE7| zFhy-)tm-hsQ>kQ0xH*f@8i%=$K+dp-++4NEPkl~YWV~}4S%qLkK_~75pe2sC( zK;Hq(7ffLJb-a&#o~4M+_*>ZAe`4fF> z4Zg-|gk+@>zHmpVSzfBsLV44zw{{l~?>%2kT+`c;4SCzF3yNo8d6h3i8sf6%djJv> zZRj47jI~hM{H;o_q{au4cct<<8KLQG0&smhy1Y!*)4fLR)1Kuv=Sy)u)Th{7`6%1U zCU@wnt7vy=yI@5kM~ic9zHa2I>DDsozCa(HHfNdhLKY_qSDngbvJPbp@M`6x?x+5u z7vp=O&$W_+Eu`nF3GpXlBdc5p(`>KPU528geen+b?{#WbyE4i5etgAgxemFnO|d>i#FM=*$fV#~>5=pOgr_+kHSCUI99ryUMpL!cfY^c{`b;9A`{^vErwu5c{SM7DAiP zw)8=QHSRh*eWl4YYQmcj#Ptocd#GGA8yNkjL+#F^a%8&dBP`r9=pwFXl#nPvTpof?dn<<`wbhfQI)UsIRk6%LR;D!+P1S>FKZ)5B#K5tDFRK#c zq5NDW67%FWRT_v<@3CeYtsa(Y;{C9yc~y3-8eqdIG<)?AB7Wo2qre91*|j5<$H8$u z*A+*vTS~XGDNJYk=5#w8Y%Z30Mz2Y63YUl%bNyZ1x}VQI=q(AflZ4#L?W_DkR&UIP zln)7rbwY)_r@YGClfs-|$`$l2vmf^DR`FEX=b1e>e3!HPBzGCbM_`26O$!1QK2maB z;GvBi4)7G&_fMzG<1gm#e#S z+p&*}$tZ0q)A=@@MFx0zyR3X}Pix;?uOeu~j2mq9jgc5;yAjgrfkBDb&r=nZ`|RGr z;5P4N@ivpI=wz)?&X_aNXBs-uPKbRan- zsC(Nw3=ng5xODf@irYx->MONB3gZirkGo)b zhv%hzBj6%mJRjX}y_I*B`?f*m2Ia)mq_+dGr{Bw9B32A62?RJ`p^cnAcQrM(tiBE< zTB;1=W*kV(Cd&8Oa=x%48lDBSyb6csJIbJ-^2%X+`jpgScuBGP;SY5Je9T{Zw z^fbWphhSEXYAvC{of~p;6D6w*zG6$_{CGVj3xOa7CUuYIw*|z@f%-*yFLxt+;3Nlp_MudbMqAlHLiuZv zx0xVMWG(KtTEFs^ed&CK6o)LN$FsGZ_#JDO+n0QLlF$YE6uC*v4cQ86b<^*Av)4mw zmLEm4V~)NbC?^+Br~J_%3Kj2L-EP|+v72t%2o{f{J$YDN$^`Du>O{gDlH~gK8VcRu zohh2)Zd;kwV!Ttq4i*nNa|Hf6(JS<_tSsb0M(0A+PVn~`aH5cE<-+M{3ryR?x|93% zJ40Th63t7(Zhfn1M(W_be0EgnJMURlcP}qSe(h-JB@FC4A!o7k} zAB`5f?H1LWI~?Cw4;U3JwTE;>GHj}#10b8o-IOQ+WqP!zcxdwjaj%4nx35(v94bmk z%|Dl8RQKE(0Rf+S7BUvvuT7xJ3C%61;&v>G>)WXQ4Oe=7g>AR=zjJ@yLw=%f?*#&%~{phrgS$;Bh!Ru*Eo7E|gw2wKk ztx+rsq3&^=T98{5-}JOqHk$(etr<)wj9YiXt}x3y3w^V(@roZ40QAkC*iPkQzG9bm z2dg|&$S!ht)xQOKI!*772P+?@X0>+dF=T-(e(5jXg8e@36|wc2t)hOuR;iQtB`+H7K`2+_}5sia4*PGX|fst6n;kYyh!(tpRBf7 z?WgbhJhk9Ekx-0ZXqumj@8DHi?iw9aU9Z-c1+Sa~MSN9Hg-s6`>8zR+1Nu8t)ybL| znQi<&0m6zR3mVoy(bME8LI6+P=t80R)+PoxS5ZN*ygBiKKG9m2xOmS|nOJR-$bfe{ zyCK1Un-Ewtrrssig_xWJIu!^Aeb`;9v-WapWnP0NTnIXg_0(0Q-Mwws*~{Zt8}3Z+ z*cq(ieCv@%x-aMI`klyD+JS!1=aWl5qrVq}!uf%==;jEBpV<)e`jZ#r33R2^b?XJ3 z?Rp^f-@EC>gsxSIt2q0nRvpAI=1LRE5b}P<=*PL)VH1B%u%!>Si$*5^@zIUd2L{FxwKlJ z(sRM-%9m$(i`A}dnYAmdr8CFdtB@$-aCzE>m?uTn)feC%$hn$k_3$O>DQD`I9Q9%r%pWIOblwVel6PxV|_jkB** zTJ4*M*SoyoL4nu5MyncD>m`tSQym=6flVq*G2XGMGUEhSM&O3MxnwrTPrI8z>(2w9 zA{c41N;AjOB9$I9+tYC2I@ePzNe^3=qOZ}1gA{z!8^r7NVoPoKaNNUgd}RfC!O>n@ zOW6Hn=IY%Oj?=^Xrb>6TnRmOF#Jao88?Ede%U%jUOfVLdTsI7AqL241g@?lQaCmOo z<^4r$KBa~6ExRpK&hi%a;hzoh*mpxdK6Zm4{i+Sq7q7a%ta~5vUWaU%(x<~Y0 zQp&Ny16qgyf4rO=dramv$sPEpUESQzd7Oms>&D&mVLEQf6@75|0UU08w`DC|ls+88 zTHhjNGo^$G%_fDyz&|_3=C_iVy92Ul?u&7mDnKj+s@MBBA%9|*q?Xw-xkBBT*@qsu z&HLWl$)_qcV*5<}Gln6{{GxyTcLIf=(z4c;xbi*UoRfA6-}=AB?q6QFkNcv2xQBmZ z7#8Wu9}Gi|{wEAW4%mbLz%cyz_3sQrc;^2t!>|HxV(||Q!=K;(d{h6w7=}f<1PSZP z4_*KIt5PXf{sCbK;C(sKud8zf@^nP0!8G(?m7J|^UpQ*D-H$dkh3u@(^h6rJ7+s_%liFEW{)I>U%!@w@ch z#@uZji;qSK;diYjM)kmD&lm|K0YbElN5X}VI@>mniR$g?WZaHYM>I+(%yYngSa%o! zysU>|{gip4<8x+fPKkuR+I0JRLxVCgT}Ey34cPPT`x@w*))$~a`t}soui(R?Vddz6lr+6jdN+;Y8~d4w(#ws5NpzH+ccJyoEeno?(F(IyoXOG z1ncDdgApV|03yj8{Tat^&|b%*R_%QgUiaObR~EG0d^|O(onM_cnINH`GQopNZR9Ov zewB^;YG{30$!0qI%C~J7yY>@H87bXosr(?gIzbSd-*>n8_6{6>)ritQ*()$}W35Tl zr09YY`?6m;e3~l9Gt9ZY1Y>h}sCZzz2|z`rghCTZ5rF(py(9f9LpY0^ZiWtUw20cR ziGplobz1Bf_)&hZPulHuPbc;>K)WCD zs@qCJd(Vrr%jEeTgVbCsJaMtD_ckb&_vU=9Ar<2~+2y9S`U&!2vRw#}$DldlrLuUz zLTZ{QYRBx=pgKou?1YZrhH1&2)Ytn3_!|JbIo(DMo0$&s7kW_MtenRrpazq*y_^Ch zQ|9g}4#|J@8gy$}>0NowKg zZE22jeXwNRQp~!ii`y7A)BH(9YVXZwsa{&$_VtCeu?i7i7VBzXgNQDuX%D9d-tb{^D@aNv@si{F{gy*=?jU+pRC~R~()yz?-CU!7BDz=|p>fK8c?|IyJ{s z3Ar!oD~N@Vztv19JTI%|S7NiA#Ze_6P5CXMwp;Ot^mmt8eUs5Fo!2hK(K8ld9Jdj(08WeV)@E07CBmXV92c=M` zfD`)r(Vywv!*MVV%M6scn{FodWkv zi`2F9-B6iT^|)6B^H#zlJtgk>wB?taDJP8O_Th9uPERb^7KYzdrLpRu=waEy7c;;y z^4kNh7CRPS?>?%j5U^P0UCTmK=1HygiNZ7YsjRr*h6^?2*lqS(_Rc~IljYD;1Uq+` zf&9G}`nz|hTnUr64CJalha{B`S}cy4#p+<0AIzu1x&^lKb0wPz+F22=D|)|rXz);O z(~yb+1iq1PxwQqvD-I2aQ89(>P<;4!Hw|X>v2*9YV`&qP$=3V6+T|pX_moQMIUU`G zpXBs%uT1E|*r6|%&Z%$_?Av_epxMqIMoEUtuovc-UfPW-mj`?70@RHk`A&N4D)uj zZsfF8FC&W;CQ4~6Q!4xT0*!{RiTaYTVq0UB!eS#co1Mju1jQM ziWv7&uMlZF`zR1>rZJO?rRU{~TgS;Eqs1+lAxqTkGHvFiFDjr!e3n`319=+*Y6xsi zthn4+AQagebYY3C4jns$q&=eC=jmPC#0D!NtQX?DAT5}5lVzgizItgzm%tjIW}?Go z*X#IojlP?YFl)$lix$ukOhMG%3P}z`>c!Nwu;MALY>{@%6r~Ps<4x8XeKfYxT&xQ_ zjhjxLNy<&E0N|ItOhL_E;h<>t!IA44pjFnrw z+UW3n5D9K9)CUczN{&{zq?xlDa*jNSr^mf!BF%Ns)lcz4j@#V=6L_n>223==sZezb zYi5c`UV?agrQZsAm;B-yR`OpaxfD)@9zsjy(LoM*L)xVs0WI0t?%XsJZTo&c0xEp7 zA7@V(%!;qOD#op^T5T7a@o0OM#*knt#=$(Tm%^QN7Hs^&`O{7fxh2Ng>{!DzKo{j| zR4$#Wp_O(|*`3wEcuo{Lm4G}%%qB12VbTWJdHq2CsaB~dgI1D-u34n?avY5k6?T@z=v6e zV59?Cqp0E$0cR@|+j$kEJl1E7TJ3`Ogd{$HSoL{q--F@Lrj(ioX8~&4f zUev)7<(KH>O;X)$(>9;E-UxXUX8XVgCAl*@;FSJZ zes5-j;&GuIf$Sv{+v{ta%6XK1Z7wWD0Id+aL%p zXO|w@OcK+zRl1n02a;lsP_Nl4r6nj-REAy1{sHyUHcT4Z_Q=Y(EM*O)qRmj)2^rC$ z?`{C%LyNa5rMt#{+Y@L*0oz81pw{(5h`(Q@h72*g(s(#O)RvTbr0Ye4A|b*Qu&McfHvTaMvBWFI>aRok}XU zmq-ulBisjrCzwn`{wGtgx(}kHN?r1 z=nSADK8kAMLbeNW1{w%A#u&~)ukv__fb6cQ$XUDPkNr#JJsMQ|%sMB3fN|c&pRJYL zXVonMxudbGg&${Sl7}wR) zy!YAP@zO9yxAN*PnHb;sOnL;#%X-kv(15o-ctSUAr3Ye~n;%mk3Ld*YmPjThAUO$+ zqgJ)!eIHtJAm@R)76-x!(_7+t#1{I*aQtj;-=LJtuJxDMo-S59`3(}#_Rxel*IpM~ zo*AR-Wd}}BM#f7r|6<5d;-X;YSxexMDEL)G+FTR%Wn1EEO;fYU;&@p+kl6JAqJ&%dKoH)E~dBp2;-sY7P^dgK-%(F zR7WQ77UXhuOI!MKjkfeD7%jv5bt6>MPos&?@aHRWo2TPb(1w`6+r@-0+;h=57y3_R zy21h`v)aYZlRzV}zTebpo2}GzDKo!#XjuLB zRbKZJzo(u)mL-tRst9SbdajB4v^ecI7HonF^_r0BT?ytct=~?14IrcOZk_5UvB|8G zn803@j=e-n&7TSR0ZCpOx`YTi0?xIQB~bC`b+4@-^7}k{?1utf!kcwePxUwVT`L&M z!l-6vUw$x?fw-bl!vm(dh08K%*4_HrY5Lkq%|>kmUAQiE$r2Q5nvGY2M5jS2xfbu0 z&SG{69=Gj7C|>(ht~klxMXEJ#uuDv&aT(B>C2FoLfOiI$=ls@S8VI2b%lH22%Z7G& zQ={l>ehSkvt)HHbS08ulNjo)2;op?4TRr2-bDw3I%eSEYw=W4$Z*V(wqmOY~WxdAYv|MzKf<^R^D|%lW|;lhJr*C#S$iPXn4<_ZQb^Fj+ILVdOU( zM|*IGd170`)_sJy_2ff!8L@)!RCbM=AVg&mY80u7?SR7&o2DXeg%A9SJdVg?pl+?? zp+26MTc96V;)k`gGRq3Ol@vCK%#Y(iC=b~EbxlKFuJ6kAdf=5op)&05U+YA5WHkIj z?cFfuV1^SGGmBulW=>T!V352AkH!8{eeY*VDg)L4O4(eGohe}Lgmdv8@5I<5>PZbH z1BTlaa8CE=XChWt<|vU+O#kLox1uVlw>%XOyxj6R;5%6MRvflHM72i{?dE((??%wS zd&aWz%GFv;e58~b-(^N_E0TYR6y>_(*L;w~ws@QhQeF=$`5VvpVD^hw5gr935))k2Fmr*hMHS(%rn%3;`| zr&(^7J0`@-IoOu?!@Iuh`8*)%^hx+eynPP#{CS5bXqEhT@lO*oPI*+Paq32 ztS#l*>vMc2>36M6h`Swd1)*+ztUk+7a02QQo=DA#{4TTf{ZmbGl|0zYOJ4HUa$nCC z5*CQy(`zlW?I4lFKTY#cs2Rr&Gf(C(rXSF8<1^}o@Bws#uhZmzl|QX?q1W$H9USQ12=mrol{s7qwZ}6+JFq*B!6JEYcCN*BoBo+`6!7ta@zl)-gMuVt=- z)&T6)l!j9<6hc zkw|yB=?<<^HAV_KY{s^(12jE%lBn)A+xTTh4-T7rQmcDtOVGg_N#BU|6ZZ36dh-(mA~imSzf4`^Ji-TQDc?-p(&O!;=krw>8Qn== ztkPS248rYK^;)`4-}>@)fNt10*qM=5@iCkkTxh$6;zUfmu1cHaw8%q5PrH{dS8<(Z zeF${d+c&kVVpy(naruH<0LHd}?cRm-$hu~7D8}y%@DOw2f@C`W1u&^Zp(h=3_ALqM zbX}N~s#?5XejdGamUX{{Cd0PoVyVTKGbwUP43aQ?bEI7B!+v^R`!zpp7t4mWG%GM2 ze=NGD!@R#^$Qdsp@iWpU-JWskirh{^y_$+MEVioNQ^jqzw(1n9TL&{{Wb>f!4&~?! zuJw%{75d9$el_Z)rm7m9dA4;pnG>X?P8YkX?d0U4Rtt|AaT=mcrz(KoNvJjY4QRwRZQ~_~wCl%o)6+h-7!h$#Om6U6=w37BMb1xh*(R5Th+L(4; ztVa7v$K4K}?=m|#Vsl9^R)y8WZI=A;nvg6Iy&cHpW<({udb3=r&YT6+{E-WQ7(6G7 z_m@`H!ax}YEeOX#OvSmIjiK0vNba=wsw}sX#umEs(7F}|yJ_5Q0s>|FS|ue&dY~Ur zu?jT>PS(Baan8nr&BSldtj0Z^45mmwRh*C$b%!i4f4!GH6 zHxEn=iqut&+$BV_O+LdC)@6JBWx~mtc$V21HA(#(I#89~R6F_Lu*Y)>k`Wc_sy%3w zACO=tnF=Hj!*DmJ^rAcuSHTx;w$`^(JD}Ub^yU~&|b=M^8Eb%61jd|7I;pffl zA&=PI1L7^CEIqquWu#<^od}4186ZoXayn)olRj3+y8)AE!llr6d5>hYz_n)+s?FPC zIvnJ@Waqudm;8M_&s(?C29*xUbp0$LW6tgXxNWBvd&#)*K9rJ938c7M(dhAc5dON zfCDa$&2v) zu2#yusqUtTMSX)+x&?)t0&H{w+=t8hS>1ljQEFs=ztzDi+gPNF+)KnON@7kuD^XHz zeosCER-%uz5tI+aK6a>18DFG$<%&*2C=m1)>FnjJvDcabvGKj-q|s^T9}q&Kw1#eF z?-x3mRm*(#b87CZH^KVLE&B_4>zPmp#aU`SWA!>RVMk>_s7WTpkIEX`J64zV+QJ135_*F>H=-e$!b zPnD#4EJx&kkV!?_) z^-EAeAY;Q5I>zhG>5OMJG;u30H>XAkkl~uiwuqF7mKSA`}Hd6Rbxz_MbYYaiG zGt578kC%@rTe&(AY9j=EyemdHr;dOrSaX|WC)IgCK)u%?R+{kuE>)!}LY{${VWs(4 zonbXdweCEXjd0Kw3kczZF;In$N5!p*NSGY~yc{L7{;kzj>8v;KZYiTZrfz9Nipj$) zb*awH9<{G=*aK&`lXGUL=&74*Nwa!((b8d~TUwXPXp&PZ+*;iAYdc4ky=HL7w$HMl<49ZOO8h8d z7Nga^_^OQ8cHyvT+bT{^8&PvC(aStU>SaI$HonSm=)y%F>LjEb<@AzXo>=o~x7a*o z+m|ej+(P-B>_UvrY1H)5>gm->io@fyGpKK0ul;l~k@ZykrEA8Nfg~K$G12NHg*WUD zHo&P6-Mm^nnWHCID$F6T!Q6N~ORL=gPLJK!I3A*1AgEwPviv%Y>&oX@QrxA%=O8^j zh1n`9J$7J3iLePTpw0PYf6RT}+jD06@Q?%H5(T*qK5{uOLykMWPC&GGja1$85tDT4 z$(%5JcuiaVt>c6)+Rr>P(e_h1v|@2yn#kO(#hI_67Ci@A*N2D(~F;VY}Wsnsd|2W4v-m z-oD|zhv2%EN@7%G6sAJ%w5zAA_SS9jOlZx*Md9*}RE`M=u+^$k5g65iyJj+KwJtW9 zPggFra;HW?e#eze7(~!3&ymd$ruQdZ_C_4ATw-%f&6VA!vgOn6wHu_Q`C9pI7N2*L zt_dNAZOl>!OkjsrUI!H7@L(Uc4FpwpMhF{2@1t}wX!-E1)G-x;>f=ME+?XHRogPqf zFXZj1Edu)$7MX-3cRc;MB4>aJNuGp%rt_(k{zDS;r@p1gm4v_RTk6ff#;3FIety~R zR%u6!~L9o{q+%q@9JM0+22p8!urq6RQA{JhkX1-cCF5S zeWECUfXQDBDUd~?$QFKiuhYZ*OZ4)870FT-Uh?I5)kU}e=L^DbjqLUFi2)@0m%sdl z{0mD)uM1TafHXie6vGhk2;%*3;pg;MB7CP{d%t(&2KD4WpBBE!-}^+KBf!Y5sUk^J zf7{THI_Y(bKes6S^|RrV9ep8C%i~~tj#iHX7H2e@na3nHizASj2@V70+ z|FDPuX;W|qY>S0I0jyPLugLkH-B%+!m?^&o*XaHEW7EGXB+q53Ki~PkV29w-`seQ* z?)c-)|AMuu8aX%b-@2!d+sHCBT_I?mU`p_=;J(hwh1>s+`^5U+?~GnLe3arpdoRCc z@aX{u7luon`max@Q$K&^e|VSw()X>Z|KIQY@%R~#r&v|1-RS&%xFJA({+l27zwi@s z&VS#{`1=Zek7(yixq1=;{@aJ6vx5seEJ!t6bz=UScf}5w@=`T zzrQb1@cCmUxc!X(YH$jHdi__zalO+w_+-T$VBO(=c?YA|`B~h47Vn=${IhucETW&q z?|Z*LYr)UL{aJuVmZpE-_WK#XZv$n`pHDmetc8Dku)$6IW99cAQU9@*uy+0#RMG2? z9o5|D-}d-F?cDw6#eVNd__Ox=wSRB)_u`K`{>!F*ztqpB{=R{KGRA)21cwzEZq(lo zS|al6U-a{@d!he0QoA7>p8xW59EP<&qn2UqNBH;;s?NV1S91UCtC$Bl=FeXp#?8-{ zIoGZJeA8(trWJwHLzi)y&cZ)<7#t1$=_BAS{b!uz{@;(FzwK=F`cE4Jb0AH3e-{0p zMdxSnd+_}phQ9~M=jXQHW8?Q7zkYs&Ou#=!@9*1w51-$I{yzrS@5j+Uk0XB;!r#|e z*cIvfx&D_u`R|NPc;?vsH#na;?;NaaU;FN!Ke@ap{`t}U_2qg9{i{+&V3U9T{3`K0 z%m4Cz{c)QBb^GG4-}n6r|G2FP7yV^8$N%s4t~{)!?fq9Wl#qLqsmn%1hSS;S?0wGJ zC>l=5RH%Dm!9YM zPdyK^#&^AIy?edy`h3>jzKLkCE1HI7F2o8sZ(bKqW zwoDq%#AtO2-0OE1SkeX=xxak4Kk};IcR}CzuyC1jP?x@jm|QrOl9i9el+gi;BV*@KmqqWF$K=R9>!28YZ4fM;jQv7g8C~(< zJ8m*{F}95E2^PVnj|1w;$^xpA(LH=io<0tO%VE;`MVUC0{+vYNhpsEIOE4t*d|((s zU%LcG;Pg3%C!Nf5hyXK}nGX(l1N1&PT&B#}xG3FbP?&M5{z8LYef&IwRmYD<^lf|= zdBXmN=+6iY3`IaVWCo%SuVM>CKmcS0TmmsgoW`@va5Fx~2(}H3&1Lc6VPXU`%rP=% znHm|RJf`9IOE{~-osf`F*WggWrV4u`7bR46boiD)3X#OaAdqkqMn>o%qHP@+;Tss> z8WIv107(M>1{vYu6A}ccS7CmhW5Pl_!S5#XsNR$6Ke|td*nL6-ML??MAT&H$%Js2bUMV&95TY+)!ouYl8-VO@WFRBGJAw^n2(Lq{VWU37&8=E*Z8 zFf16p&yA4NN8a{9P*?-xw1GhGHgIa-1iwO5r*8{=AkNSZ{0bL@Al20i{+H4cn~7GS9%IDsQPa2}k=n!yn4An>q*a#F!iut0f|kvrng zNk-b~4~fR2E-IsdfIt`~xyh1^QMK{UW0uvlDofOW98I^vC1fv}yxP!L_; z)Cd`&KgrWC+%pu8Z=qAfb{@5W+ zTBM&C>@Rpyqf`%))C4*8k}k+%s`|of+EB@l#1%ZqkQs==^Dr5@6_ureQRl2 z(SLAI&R%0eV?~mK^_Wjp3yKHU?&@68Ww)Ew+7C}!4o=&)(|h9nemP^*$_zW}*!^!u z?2(40U9$$gn0rO9pgj8UsPx2xk#oN(dercPWRGeIv9+OGrg+&3lq6QMNuXa~ zunnMdo`S_{5`rS+$&zTf@*_jdZAj-@kZDe43Lk3ZT5i3E!pusY7eNzb7vQ;Dn3x#5 zhIo1)gwV1jHYNDKSPnR`_Y4jodxAUr;Xdx3Gt7+<@nv~9FlHh8)4^MBb1Fd?$yB9n zim&ba2nLp9$~n3X!|L9Nb>ZH;UixQ0>=nK)*m!p;6m$>u4)f}*VjVQe9tdLi= z?fsxtesk8BJW?CpeQiU7Ux;G*e8#A!+@|!Hz{_V=5g)f)dDS#?-0r>;qK8@ZVSDoH zcJJ9e#q{b`wVo+u9?c)sTWZe|KL5K^JbGLD*}iXAKDD!cx=|%I&O3kQ_-Ole@KVOu zWw&aU_2Ufh+J9-%4kDgCmpYv`Yx^X zPF09P?D9$Koi=r1Oj7chsC>l8@Q#A25qd{4e1&h2LPhkV>&nw(I6+-zE6+OHBdELD za`TC*tBR&D6|16sy2ZRv@3X^b-#X2my|x(NRv+ltZJ~*g6;Gqnd6T$x>gy+dzOK8s z-^dmFGEA%tJ`4*TaH^a0iZ6e5y^dgAniZpBdv8`MckOXU;n?!KhsJ4jGe39bFVo0A z+q(8Wd%tG#2~ESE$Itbx8TdwF^h%d=8@f%r*saqIGy84>-xXSiCQx7{W)Z*6wpJacN_C!Bfe?C8%i zyWDOa-fchpz=UuWPVcP=V@hVuO`Pj=DCKacJFX4mw0f4F?f*zCXz7W5vsnT7LFMDU zD&zB)zbNieqx&}U^vEiW*D<|{Lf*J78B(aaOl#So>cqhp&J16t;;1}7rq_^7h_;`$ zt@?m&_1&6dd!NIsqxV{d4qc_buw=HI-r+y)7@fAz(w)9R!(x?o-x=C^Tk@i9EqsSM z>l)}54B2pLtcQ7UKZl8PEDvg@BQ83<)=#k7I6_y$alInoWV*9e(H{7x8L1T-QwIzrO6z5e(wmRS>@9lEKr zYsdiO@?8sWp2(Y)H};T)m7=yHxZ z_Y-?Y|6TDL;`8GZ-(ycsmerQs=j8azX*sQz{CQ-+$R)``ljkKXCMWKjY8QA*<5t=} z|9zGfOkZ7JSKqt7O}7~P6Uz3KMQkribHQ33e_j3j(5bjZC%*XpUHshO`Gx_h0}2Q9 zA7D2i1-pRvPYp=Dlv{#bme{>ErdCRM-w)1py*Af}o2Vd?PbHi}w z!~F)??t63Xy)vigUi;N~J;RA>bbR)4n+RjeDf;&ME;-h(GYqZMv(tB;F+bz9?DE;` z$i2C1jkXr;%~+Fh#&x@EW{vx>eM$RojLdY*9Cv}|er&;-w}!P&x`*P@EY@2jT$*Nc zr=rSs?y0i8GPU_nymhhtcz)@QLk}Dr4w&8klPDg4aY^RFt)EAAH&|=GHcj)PrpxG; zqix2#7(LiQ&!Mxuf8O&$UyARQq|SGCk1Ac|TkD>CZTG_`N3*lWREM8=88t4|`Orhn z{OS2+jXfKOHt9B@T@6-8t}f{L@lI&?i2T^7TfJXAtvPY+ZG3Il;fseKF1OfIo#t>& z?^=&*ncda;zUf;rreE-l1vMwMf|D2?jChyGpo|K;`^mMAFTPxzR+&&AUgBT!@Q%UV z<`Ye$dQIt-WWKg^*$8fA+oMD3DuZ7`-`=j(f zxi%{`hktqazVc1|m&ztfWuEc@m8YsZmCclAb~WtIQu(EGm~wHEVo`p~VEvme+OsP( zm5jfdgs&X0f~z_A`4ZBPF&aCd+pzG2UF6cp2<0(w(axkKe^TPbn-|U3CTLF4j4-=o zex85Jd>Vf-KZQRf#eTFy?qjof$9QD7f#%?WeHLqn2WNe}`EbhW+J;A}wXYcL*_(13 z?gbyM%eqo_aGgt$!-A261`htMTD>Li*K=8QQxAS{IT=x>T)82Cb<_I#3!~~2-a3Es z{Fa1|+p6h$0 z%FEm{{j&Ad-cLR}PJJA3<+n@kFEuU2=iw1yUWMV`R(&nPU(N5Cz4G?K+4oOQk8mzJ zRr7b@i$s6Kf70DISIn*?cn+)%SW{JD{ipSz!nxkLub*5nK51-SQ!wV5Q%}G1etrC2 zKAe}E?R!6E=$spWyIpy-=8>h&gY_?}9inD^et5Mp_GQ7Y#$8Pje}#98c<}JqsrU9< z+#KfIy?*d7=j^(x?{>U9ouZP zJYRhLW!k;c`;}*^{g;(1CUiRA)o_r8*6C#zKU&StHu693`k>}OaoLL<&rhB4TIRCM z^yQ?tNoD3M&3BcaOANa;uA-8=m%EX3E@AzJ!?g=a1DpT)+hp;t`=42{Gf#d}<_#g< zJ}Uh*`1N+R@pl)liQ4yUcyoH=vFna&95Ze|xE*(FC&y>;)Wy}$mY1jfcI~$@6SlT2 z`4Hc@B{lc5*OaoPYkjtDCDJ37zB9hC^6lEVzN^R13N<{H_xNVo!9xeDu0*Hg%z1k< zIO~2v(^tEc{ay#*Hd9nuRKd$t%?Y;$W>F|54aEs{V^} zlYUj>si?X?TG9q~THEEzD@NhsmN^d$o<&tP-{_jvYtDqLi+Ii6&F&4gJBF)Tj@-U) zLU!}5PnGks3O+RaSvj{X_jj+vRVPgJTarKLSQd9K%PJdXmS^_dJlni1{&W1pMTb9} ze{&^1rM!0K8NF}EJ|^GTpT0DrsldzaQpub7H(qR+Fu7`PA@SvQqkp}})5qlzKCgH0 zSyQ#Ya6)5rb4HWL@ZJH`Yuw}f8LYokFoEY+Hji1$04NODe;;~ z$5-sF8c&1Z45%$WL4FIxp^4O2ruf0)INS*#F+*xZ3DJgZL@6jF?nF*RiIT`k>yVNF z5+=~nI0zZc@BnB;P&l+F;SE(b2Iu=cb{i2To5jQ_7{PZUN^s4MRNE(_gr39#OT-h) z3nLK9D=r~BBxy>U@g(JhSEwnmN+kg$gcHJZzV8H-0%+_9B1#q;<^Z5_4g=6<98QV^ zsD&g-nU;9CXECB?8d3PDaQWPE%eRaRy;jj{qJK)>jLR)k!tTYIs@>UBp8q~ZrF)El zW=^Ju_F$b-?N1LNpe)|i+t=g`e}%@envXdvOc}#6?9?jFUimP7uixp=U*E}Wa0n}L zVfm_rId+)Gx|DUpR8Gw(@_QCn5#~Q|jPC13d-veto;D6ha0P_D!}gnAOIxs9L_C2{3{j4I*P zXp&q>SP6g>fIif)QrHOD3pK6;_J^RdB(M}Fh=u8hEIT60j>xhjvh0W~J0i=D$g(4{ z?1(HoBFq1;$Px&6BHx)BS_-{ivA_CnV@na08*P)x%|e9fD28!RaF59!lDUmZ(+Mi; z4|q@F3OKyiU0MNHN0JN{l{*c*Nl6Bq2jQr=3*gj9GJwuZ$snW|Tq-pY_#~1Vt$5s+ zR4NV=rAP%_3ULh%AY0Nt$go$S5V(KFrqX$VM7)(hLLbHEsaOgtmtVZ z6Ni>Y$dKdV<4|yK8sKA2oB$b z$2Q@iMmWkdB#%<4{89nwl)U-?pr~g!BIJTnX{RLkPbG`OT>^~N23b^md*esgqEe!1 z>w7ms5{6^E1rs@rCCwc_2$VT#f?rBcDA#aycwQ^jsT{7T z-02o^NZWC`MVwNKXjCH7f3Oh|hqN6<6LCtVqRHWk%GDZqtx9xU*iPmv;*?TE6Cci# zyz~E{H4%rjJ+(#}0hNX>hbt;qYa$M5JBlXaluETGhbt;yH1QbQ?|Cd5Jj9+MG|unv3z2IB?;0J!ZDEurEpB* zQR3vFMBGhP{kG_#f@^{je}M+!Nzgs;INIiiqU23vm?Lo~!gBwDAPR5okPGLH>sicH zGx@kJX1LYpQQy2@T_6fBpU2RW#LjA4V0P2D(|bK%a{xE&eui#B2@!cFd&BpVb3UZyx#Vv%j&c7jHP)*|JD z!o@>DWvRgk62!iK+qj*81S*2mb}&N!DsNLyFJ=Gm-lKBDMr1gZFh%U*;l3=x`2)yvr-@T#C@)@P;0WR8oWvhCzjp zqzD}jco?;Yv~zgNA*Bx~LWgrPHl>CXp~Ja2^_?hEgbwF&;Vz^^T!`95&>hYNNJpAM z2JajpbO-NOq;^8qMR6Xy+(TMgl*XaIcLvIF>F>HC(_|n%z+}loC-R4c{eA$VGBGhT y!B|W_kIyycVMYMm@%hF;{blownJ8*z{0|TnfNCO$N`OGggQz$F%W*^y)&BvWMitQj diff --git a/src/modules/Display/src/disp/disp_charmod.F90 b/src/modules/Display/src/disp/disp_charmod.F90 deleted file mode 100755 index cd12e191e..000000000 --- a/src/modules/Display/src/disp/disp_charmod.F90 +++ /dev/null @@ -1,178 +0,0 @@ -! Add-on module to DISPMODULE to display selected_real_kind(25) reals -! (these are probably 16 bytes and possibly snglruple precision) -! -! This module is obtained by copying the section SINGLE PRECSION PROCEDURES from -! dispmodule.F90, replacing sngl with sngl, single withe snglruple (only appears -! in comments) and cplx with cplx, adding a DECLARATIONS section, and defining -! the constant sngl as selected_real_kind(25). -! -! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of -! Iceland (jonasson@hi.is). This software is free. For details see the file README. - -MODULE DISP_CHARMOD -USE DISPMODULE_UTIL -USE GlobalData, ONLY: Real32 -PRIVATE -PUBLIC DISP - -INTERFACE DISP - MODULE PROCEDURE disp_ts_dchr, disp_v_dchr, disp_tv_dchr, disp_m_dchr, disp_tm_dchr -END INTERFACE DISP - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine disp_v_dchr(x, fmt, advance, lbound, sep, style, trim, unit, orient) - ! Default character vector without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - character(*), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tv_dchr('', x, fmt, advance, lbound, sep, style, trim, unit, orient) -end subroutine disp_v_dchr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine disp_m_dchr(x, fmt, advance, lbound, sep, style, trim, unit) - ! Default character matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim - character(*), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_dchr('', x, fmt, advance, lbound, sep, style, trim, unit) -end subroutine disp_m_dchr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine disp_ts_dchr(title, x, fmt, advance, sep, style, trim, unit) - ! Default character scalar with title - character(*), intent(in), optional :: title, x, fmt, advance, sep, style, trim - character(0) empty(1,0) - integer, intent(in), optional :: unit - empty = '' - if (present(title).and.present(x)) then - call disp_nonopt_dchr(title, x, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) - elseif (present(x)) then - call disp_nonopt_dchr('', x, fmt, advance, sep=sep, style='left', trim=trim, unit=unit) - elseif (present(title)) then - call disp_nonopt_dchr('', title, fmt, advance, sep=sep, style='left', trim=trim, unit=unit) - else - call disp_tm_dchr('', empty, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) - end if -end subroutine disp_ts_dchr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine disp_nonopt_dchr(title, x, fmt, advance, sep, style, trim, unit) - ! This routine exists to circumvent bug in gfortran, that made it not possible to change scalar strings - ! to matrices with reshape in calls of disp_tm_dchr. This intermediate routine provides work-around. - character(*), intent(in) :: title, x, fmt, advance, sep, style, trim - optional fmt, advance, sep, style, trim - integer, intent(in), optional :: unit - character(len(x)) :: xm(1,1) - xm(1,1) = x - call disp_tm_dchr(title, xm, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) -end subroutine disp_nonopt_dchr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine disp_tv_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit, orient) - ! Default character vector with title - character(*), intent(in) :: title, x(:) - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient) - if (SE%row) then - call disp_dchr(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_dchr(title, reshape(x, (/size(x), 1/)), SE) - end if -end subroutine disp_tv_dchr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine disp_tm_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit) - ! Default character matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - character(*), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'A4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): see NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - ! - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit) - call disp_dchr(title, x, SE) -end subroutine disp_tm_dchr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine disp_dchr(title, x, SE) - ! Default character item to box - character(*), intent(in) :: title, x(:,:) - type(settings), intent(INOUT ) :: SE - character(13) :: edesc - character, pointer :: boxp(:,:) - integer :: m, n, j, lin1, wleft, lx, w - integer, dimension(size(x,2)) :: wid, nbl, n1, n2, widp - m = size(x,1) - n = size(x,2) - lx = len(x) - w = SE%w - if (w <= 0) then - w = lx - if (w < 0) then - edesc = '(A__________)' - write(edesc(3:12), '(SS,I10)') w - SE%ed = edesc - end if - end if - if (SE%trm .and. size(x) > 0) then - n1 = minval(mod(verify(x, ' ') - w - 1, w + 1), 1) + w + 1 - n2 = maxval(verify(x, ' ', back = .true.), 1) - wid = n2 - n1 + 1 - nbl = w - wid - else - n1 = 1 - n2 = w - wid = w - nbl = 0 - end if - if (all(wid == 0)) n = 0 - SE%w = w - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (SE%trm) then - call copytobox(x(:,j)(n1(j):n2(j)), lin1, wid(j), widp(j), nbl(j), boxp, wleft) - else - if (widp(j) > lx) call copyseptobox(repeat(' ', widp(j)-lx), m, lin1, boxp, wleft) - call copytobox(x(:,j), lin1, lx, lx, 0, boxp, wleft) - end if - if (j 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byte - - ! ********* 1-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byte(x) result(st) - ! Scalar to string - integer(byte), intent(in) :: x - character(len_f_byte((/x/), tosset0%ifmt)) :: st - st = tostring_f_byte((/x/), tosset0%ifmt) - end function tostring_s_byte - - function tostring_sf_byte(x, fmt) result(st) - ! Scalar with specified format to string - integer(byte),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byte((/x/), fmt)) :: st - st = tostring_f_byte((/x/), fmt) - end function tostring_sf_byte - - function tostring_byte(x) result(st) - ! Vector to string - integer(byte), intent(in) :: x(:) - character(len_f_byte(x, tosset0%ifmt)) :: st - st = tostring_f_byte(x, tosset0%ifmt) - end function tostring_byte - - function tostring_f_byte(x, fmt) result(st) - ! Vector with specified format to string - integer(byte), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byte(x, fmt)) :: st - character(widthmax_byte(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byte - - pure function len_f_byte(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byte), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byte(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byte - - pure function widthmax_byte(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byte), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byte - -END MODULE DISP_I1MOD diff --git a/src/modules/Display/src/disp/disp_i2mod.F90 b/src/modules/Display/src/disp/disp_i2mod.F90 deleted file mode 100755 index 3fa00b9b5..000000000 --- a/src/modules/Display/src/disp/disp_i2mod.F90 +++ /dev/null @@ -1,276 +0,0 @@ -MODULE DISP_I2MOD - - ! Add-on module to DISPMODULE to display 2-byte integers - ! (assuming that these are obtained with selected_int_kind(4)) - ! - ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from - ! from dispmodule.F90, replacing dint with byt2 and default integer' with 2-byte - ! integer (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. - - ! ******************************** DECLARATIONS ******************************************** - USE DISPMODULE_UTIL - USE GlobalData, ONLY: Int16 - IMPLICIT NONE - PRIVATE - - PUBLIC DISP - PUBLIC TOSTRING - - interface Display - module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2 - end interface - - interface disp - module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2 - end interface - - interface tostring - module procedure tostring_byt2, tostring_f_byt2, tostring_s_byt2, tostring_sf_byt2 - end interface - - ! integer, parameter :: byt2 = selected_int_kind(4) - integer, parameter :: byt2 = Int16 - -CONTAINS - - ! ******************************** 2-BYTE INTEGER PROCEDURES ******************************* - subroutine disp_s_byt2(x, fmt, advance, sep, trim, unit, zeroas) - ! 2-byte integer scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - integer(byt2), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_byt2('', x, fmt, advance, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_byt2 - - subroutine disp_v_byt2(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 2-byte integer vector without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt2), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tv_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_byt2 - - subroutine disp_m_byt2(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 2-byte integer matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt2), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_byt2 - - subroutine disp_ts_byt2(title, x, fmt, advance, sep, style, trim, unit, zeroas) - ! 2-byte integer scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt2), intent(in) :: x - integer, intent(in), optional :: unit - call disp_tm_byt2(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & - zeroas=zeroas) - end subroutine disp_ts_byt2 - - subroutine disp_tv_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 2-byte integer vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt2), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - if (SE%row) then - call disp_byt2(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_byt2(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_byt2 - - subroutine disp_tm_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 2-byte integer matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - integer(byt2),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) - call disp_byt2(title, x, SE) - end subroutine disp_tm_byt2 - - subroutine disp_byt2(title, x, SE) - ! 2-byte integer item - character(*), intent(in) :: title - integer(byt2), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_byt2(x, SE, wid, nbl) ! determine also SE%w - call tobox_byt2(title, x, SE, wid, nbl) - end subroutine disp_byt2 - - subroutine tobox_byt2(title, x, SE, wid, nbl) - ! Write 2-byte integer matrix to box - character(*), intent(in) :: title - integer(byt2), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byt2 - - ! ********* 2-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byt2(x) result(st) - ! Scalar to string - integer(byt2), intent(in) :: x - character(len_f_byt2((/x/), tosset0%ifmt)) :: st - st = tostring_f_byt2((/x/), tosset0%ifmt) - end function tostring_s_byt2 - - function tostring_sf_byt2(x, fmt) result(st) - ! Scalar with specified format to string - integer(byt2),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byt2((/x/), fmt)) :: st - st = tostring_f_byt2((/x/), fmt) - end function tostring_sf_byt2 - - function tostring_byt2(x) result(st) - ! Vector to string - integer(byt2), intent(in) :: x(:) - character(len_f_byt2(x, tosset0%ifmt)) :: st - st = tostring_f_byt2(x, tosset0%ifmt) - end function tostring_byt2 - - function tostring_f_byt2(x, fmt) result(st) - ! Vector with specified format to string - integer(byt2), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byt2(x, fmt)) :: st - character(widthmax_byt2(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byt2 - - pure function len_f_byt2(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byt2), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byt2(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byt2 - - pure function widthmax_byt2(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byt2), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byt2 - ! ************************************* END OF 2-BYTE INTEGER PROCEDURES ****************************************** - -END MODULE DISP_I2MOD diff --git a/src/modules/Display/src/disp/disp_i4mod.F90 b/src/modules/Display/src/disp/disp_i4mod.F90 deleted file mode 100755 index 497fe3d7d..000000000 --- a/src/modules/Display/src/disp/disp_i4mod.F90 +++ /dev/null @@ -1,270 +0,0 @@ -MODULE DISP_I4MOD - - ! Add-on module to DISPMODULE to display 4-byte integers - ! (assuming that these are obtained with selected_int_kind(18)) - ! - ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from - ! from dispmodule.F90, replacing dint with byt4 and 'default integer' with 4-byte - ! integer (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. - - ! ******************************** DECLARATIONS ******************************************** - USE dispmodule_util - USE GlobalData, ONLY: Int32 - IMPLICIT NONE - PRIVATE - PUBLIC DISP - PUBLIC TOSTRING - - interface disp - module procedure disp_s_byt4, disp_ts_byt4, disp_v_byt4, disp_tv_byt4, disp_m_byt4, disp_tm_byt4 - end interface - - interface tostring - module procedure tostring_byt4, tostring_f_byt4, tostring_s_byt4, tostring_sf_byt4 - end interface - - integer, parameter :: byt4 = Int32 - -CONTAINS - - ! ******************************** 4-BYTE INTEGER PROCEDURES ******************************* - subroutine disp_s_byt4(x, fmt, advance, sep, trim, unit, zeroas) - ! 4-byte integer scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - integer(byt4), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_byt4('', x, fmt, advance, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_byt4 - - subroutine disp_v_byt4(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 4-byte integer vector without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt4), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tv_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_byt4 - - subroutine disp_m_byt4(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 4-byte integer matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt4), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_byt4 - - subroutine disp_ts_byt4(title, x, fmt, advance, sep, style, trim, unit, zeroas) - ! 4-byte integer scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt4), intent(in) :: x - integer, intent(in), optional :: unit - call disp_tm_byt4(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & - zeroas=zeroas) - end subroutine disp_ts_byt4 - - subroutine disp_tv_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 4-byte integer vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt4), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - if (SE%row) then - call disp_byt4(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_byt4(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_byt4 - - subroutine disp_tm_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 4-byte integer matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - integer(byt4),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) - call disp_byt4(title, x, SE) - end subroutine disp_tm_byt4 - - subroutine disp_byt4(title, x, SE) - ! 4-byte integer item - character(*), intent(in) :: title - integer(byt4), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_byt4(x, SE, wid, nbl) ! determine also SE%w - call tobox_byt4(title, x, SE, wid, nbl) - end subroutine disp_byt4 - - subroutine tobox_byt4(title, x, SE, wid, nbl) - ! Write 4-byte integer matrix to box - character(*), intent(in) :: title - integer(byt4), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byt4 - - ! ********* 4-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byt4(x) result(st) - ! Scalar to string - integer(byt4), intent(in) :: x - character(len_f_byt4((/x/), tosset0%ifmt)) :: st - st = tostring_f_byt4((/x/), tosset0%ifmt) - end function tostring_s_byt4 - - function tostring_sf_byt4(x, fmt) result(st) - ! Scalar with specified format to string - integer(byt4),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byt4((/x/), fmt)) :: st - st = tostring_f_byt4((/x/), fmt) - end function tostring_sf_byt4 - - function tostring_byt4(x) result(st) - ! Vector to string - integer(byt4), intent(in) :: x(:) - character(len_f_byt4(x, tosset0%ifmt)) :: st - st = tostring_f_byt4(x, tosset0%ifmt) - end function tostring_byt4 - - function tostring_f_byt4(x, fmt) result(st) - ! Vector with specified format to string - integer(byt4), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byt4(x, fmt)) :: st - character(widthmax_byt4(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byt4 - - pure function len_f_byt4(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byt4), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byt4(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byt4 - - pure function widthmax_byt4(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byt4), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byt4 - ! ************************************* END OF 4-BYTE INTEGER PROCEDURES ****************************************** - -END MODULE DISP_I4MOD diff --git a/src/modules/Display/src/disp/disp_i8mod.F90 b/src/modules/Display/src/disp/disp_i8mod.F90 deleted file mode 100755 index 54794d25c..000000000 --- a/src/modules/Display/src/disp/disp_i8mod.F90 +++ /dev/null @@ -1,270 +0,0 @@ -MODULE DISP_I8MOD - - ! Add-on module to DISPMODULE to display 8-byte integers - ! (assuming that these are obtained with selected_int_kind(18)) - ! - ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from - ! from dispmodule.F90, replacing dint with byt8 and 'default integer' with 8-byte - ! integer (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. - - USE DISPMODULE_UTIL - use GlobalData, ONLY: Int64 - - PUBLIC DISP - PUBLIC TOSTRING - - PRIVATE - - interface disp - module procedure disp_s_byt8, disp_ts_byt8, disp_v_byt8, disp_tv_byt8, disp_m_byt8, disp_tm_byt8 - end interface - - interface tostring - module procedure tostring_byt8, tostring_f_byt8, tostring_s_byt8, tostring_sf_byt8 - end interface - - integer, parameter :: byt8 = Int64 - -CONTAINS - - ! ******************************** 8-BYTE INTEGER PROCEDURES ******************************* - subroutine disp_s_byt8(x, fmt, advance, sep, trim, unit, zeroas) - ! 8-byte integer scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - integer(byt8), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_byt8('', x, fmt, advance, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_byt8 - - subroutine disp_v_byt8(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 8-byte integer vector without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt8), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tv_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_byt8 - - subroutine disp_m_byt8(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 8-byte integer matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt8), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_byt8 - - subroutine disp_ts_byt8(title, x, fmt, advance, sep, style, trim, unit, zeroas) - ! 8-byte integer scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt8), intent(in) :: x - integer, intent(in), optional :: unit - call disp_tm_byt8(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & - zeroas=zeroas) - end subroutine disp_ts_byt8 - - subroutine disp_tv_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 8-byte integer vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt8), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - if (SE%row) then - call disp_byt8(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_byt8(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_byt8 - - subroutine disp_tm_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 8-byte integer matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - integer(byt8),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) - call disp_byt8(title, x, SE) - end subroutine disp_tm_byt8 - - subroutine disp_byt8(title, x, SE) - ! 8-byte integer item - character(*), intent(in) :: title - integer(byt8), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_byt8(x, SE, wid, nbl) ! determine also SE%w - call tobox_byt8(title, x, SE, wid, nbl) - end subroutine disp_byt8 - - subroutine tobox_byt8(title, x, SE, wid, nbl) - ! Write 8-byte integer matrix to box - character(*), intent(in) :: title - integer(byt8), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byt8 - - ! ********* 8-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byt8(x) result(st) - ! Scalar to string - integer(byt8), intent(in) :: x - character(len_f_byt8((/x/), tosset0%ifmt)) :: st - st = tostring_f_byt8((/x/), tosset0%ifmt) - end function tostring_s_byt8 - - function tostring_sf_byt8(x, fmt) result(st) - ! Scalar with specified format to string - integer(byt8),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byt8((/x/), fmt)) :: st - st = tostring_f_byt8((/x/), fmt) - end function tostring_sf_byt8 - - function tostring_byt8(x) result(st) - ! Vector to string - integer(byt8), intent(in) :: x(:) - character(len_f_byt8(x, tosset0%ifmt)) :: st - st = tostring_f_byt8(x, tosset0%ifmt) - end function tostring_byt8 - - function tostring_f_byt8(x, fmt) result(st) - ! Vector with specified format to string - integer(byt8), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byt8(x, fmt)) :: st - character(widthmax_byt8(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byt8 - - pure function len_f_byt8(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byt8), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byt8(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byt8 - - pure function widthmax_byt8(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byt8), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byt8 - ! ************************************* END OF 8-BYTE INTEGER PROCEDURES ****************************************** - -END MODULE DISP_I8MOD diff --git a/src/modules/Display/src/disp/disp_l1mod.F90 b/src/modules/Display/src/disp/disp_l1mod.F90 deleted file mode 100755 index ae1012cac..000000000 --- a/src/modules/Display/src/disp/disp_l1mod.F90 +++ /dev/null @@ -1,202 +0,0 @@ -MODULE DISP_L1MOD - - ! Add-on module to DISPMODULE to display 1-byte logical items - ! (assuming that these have kind = 1) - ! - ! This module is obtained by copying the section DEFAULT LOGICAL PROCEDURES from - ! dispmodule.F90, replacing dlog with log1 and 'default logical' with '1-byte - ! logical' (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. - - use dispmodule_util - USE GlobalData, ONLY: LGT - PUBLIC DISP - PUBLIC TOSTRING - - PRIVATE - - interface Display - module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1 - end interface - - interface disp - module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1 - end interface - - interface tostring - module procedure tostring_log1, tostring_f_log1, tostring_s_log1, tostring_sf_log1 - end interface - - integer, parameter :: log1 = LGT ! hopefully logical(1) is byte - -CONTAINS - - ! ********************************************** 1-BYTE LOGICAL PROCEDURES ************************************************* - subroutine disp_s_log1(x, fmt, advance, sep, trim, unit) - ! 1-byte logical scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim - logical(log1), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_log1('', x, fmt, advance, sep, 'left', trim, unit) - end subroutine disp_s_log1 - - subroutine disp_v_log1(x, fmt, advance, lbound, sep, style, trim, unit, orient) - ! 1-byte logical vector without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - logical(log1), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tv_log1('', x, fmt, advance, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_log1 - - subroutine disp_m_log1(x, fmt, advance, lbound, sep, style, trim, unit) - ! 1-byte logical matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim - logical(log1), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_log1('', x, fmt, advance, lbound, sep, style, trim, unit) - end subroutine disp_m_log1 - - subroutine disp_ts_log1(title, x, fmt, advance, sep, style, trim, unit) - ! 1-byte logical scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim - logical(log1), intent(in) :: x - integer, intent(in), optional :: unit - call disp_tm_log1(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit) - end subroutine disp_ts_log1 - - subroutine disp_tv_log1(title, x, fmt, advance, lbound, sep, style, trim, unit, orient) - ! 1-byte logical vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - logical(log1), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient) - if (SE%row) then - call disp_log1(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_log1(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_log1 - - subroutine disp_tm_log1(title, x, fmt, advance, lbound, sep, style, trim, unit) - ! 1-byte logical matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - logical(log1),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g. 'L1') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - ! - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit) - call disp_log1(title, x, SE) - end subroutine disp_tm_log1 - - subroutine disp_log1(title, x, SE) - ! Write 1-byte logical to box or unit - character(*), intent(in) :: title - logical(log1), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - if (SE%w <= 0 .or. SE%trm) then - SE%ed = '(L1)' - if (size(x) == 0) then - wid = 0 - else - wid = 1 - endif - SE%w = 1 - nbl = SE%w - wid - else - wid = SE%w - nbl = 0 - endif - call tobox_log1(title, x, SE, wid, nbl) - end subroutine disp_log1 - - subroutine tobox_log1(title, x, SE, wid, nbl) - character(*), intent(in) :: title - logical(log1), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: m, n, lin1, i, j, wleft, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (x(i,j), i=1,m) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) write(s, SE%ed) xj - call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (.not. any(xfinite)) then - w = 4 - else - xmax = maxval(x, mask=xfinite) - xmin = minval(x, mask=xfinite) - f1 = '(SS,ES9.0E4)' - write(s,f1) xmax, xmin - read(s(:)(5:9),'(I5)') expmax, expmin - w = max(0, expmax, expmin) + d + 4 - end if - if (.not. all(xfinite)) w = max(w, 4) - end function maxw_quad - - subroutine find_editdesc_quad(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid. - ! The if-block (*) is for safety: make f wider in case xm is written ok with the - ! ES format in fmt but overflows with F format (the feature has been tested through - ! manual changes to the program). - real(quad), intent(in) :: x(:,:) ! Item to be written - type(settings), intent(INOUT ) :: SE ! Settings - integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns - integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns - integer :: expmax, expmin, ww, dd, dmx - real(quad) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h - character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 - character(99) s - logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) - ! - dmx = SE%dmx - h = huge(h) - xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (SE%w == 0) then ! Edit descriptor 'F0.d' specified - ww = maxw_quad(reshape(x, (/size(x)/)), SE%d) - if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas) - call replace_w(SE%ed, ww) - SE%w = ww - elseif (SE%w < 0) then ! No edit descriptor specified - if (size(x) == 0) then - SE%w = 0 - wid = 0 - nbl = 0 - return - endif - if (any(xfinite)) then - xp = maxval(x, mask=xfinite) - xm = minval(x, mask=xfinite) - write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 - write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax - write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin - call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) - if (.not. all(xfinite)) ww = max(ww, 4) - if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas) - if (SE%ed(5:5)=='F') then ! (*) - write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 - write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 - write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd - endif - else - ww = 4 - SE%ed = '(F4.0)' - endif - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1, mask=xfinite) ! max in each column - xminv = minval(x, 1, mask=xfinite) ! min - xzero = any(x == 0._quad, 1) ! true where column has some zeros - xallz = all(x == 0._quad, 1) ! true where column has only zeros - xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) - xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) - call getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - else - wid = SE%w - nbl = 0 - endif - end subroutine find_editdesc_quad - - subroutine getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - ! determine length of the strings that result when writing with edit descriptor SE%ed a - ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output - real(quad), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column - logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros - logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals - type(settings), intent(in) :: SE ! settings - integer, intent(out) :: wid(:) ! widths of columns - integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmin, SE%ed) xminv - write(stmax, SE%ed) xmaxv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - if (SE%gedit) then - wid = w - else - wid = len_trim(adjustl(stmin)) - wid = max(wid, len_trim(adjustl(stmax))) - endif - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - endif - wid = merge(4, wid, xalln) - wid = max(wid, merge(4, 0, xnonn)) - nbl = w - wid - end subroutine getwid_quad - - ! ******** TOSTRING QUADRUPLE PRECISION PROCEDURES *********** - function tostring_s_quad(x) result(st) - ! Scalar to string - real(quad), intent(in) :: x - character(len_f_quad((/x/), tosset0%rfmt)) :: st - st = tostring_f_quad((/x/), tosset0%rfmt) - end function tostring_s_quad - - function tostring_sf_quad(x, fmt) result(st) - ! Scalar with specified format to string - real(quad), intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_quad((/x/), fmt)) :: st - st = tostring_f_quad((/x/), fmt) - end function tostring_sf_quad - - function tostring_quad(x) result(st) - ! Vector to string - real(quad), intent(in) :: x(:) - character(len_f_quad(x, tosset0%rfmt)) :: st - st = tostring_f_quad(x, tosset0%rfmt) - end function tostring_quad - - function tostring_f_quad(x, fmt) result(st) - ! Vector with specified format to string - real(quad) , intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_quad(x, fmt)) :: st - character(widthmax_quad(x, fmt)) :: sa(size(x)) - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - integer :: w, d, ww - logical :: gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then - st = errormsg - return - elseif (w == 0) then - ww = maxw_quad(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - call tostring_get(sa, st) - end function tostring_f_quad - - pure function len_f_quad(x, fmt) result(wtot) - ! Total length of returned string, vector s - real(quad), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_quad(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d, ww - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - if (w == 0) then - ww = maxw_quad(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_quad - - pure function widthmax_quad(x, fmt) result(w) - ! Maximum width of an element of x - real(quad), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(nnblk(fmt)+5) :: fmt1 - integer w, d - logical gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then ! illegal format, use 1 - w = 1 - elseif (w == 0) then - w = maxw_quad(x, d) - endif - end function widthmax_quad - - ! *************************************** END OF QUADRUPLE PRECISION PROCEDURES *************************************** - - ! *************************************** QUADRUPLE PRECISION COMPLEX PROCEDURES ************************************** - subroutine disp_s_cplq(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) - ! quadruple precision complex scalar without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim - complex(quad), intent(in) :: x - integer, intent(in), optional :: unit, digmax - call disp_ts_cplq('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) - end subroutine disp_s_cplq - - subroutine disp_v_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! quadruple precision complex vector without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(quad), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - call disp_tv_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_cplq - - subroutine disp_m_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! quadruple precision complex matrix without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(quad), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) - call disp_tm_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - end subroutine disp_m_cplq - - subroutine disp_ts_cplq(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) - ! quadruple precision complex scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(quad), intent(in) :: x - integer, intent(in), optional :: unit, digmax - call disp_tm_cplq(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, & - trim=trim, unit=unit) - end subroutine disp_ts_cplq - - subroutine disp_tv_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! quadruple precision complex vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(quad), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) SE, SEim - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - if (SE%row) then - call disp_cplq(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) - else - call disp_cplq(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) - end if - end subroutine disp_tv_cplq - - subroutine disp_tm_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! quadruple precision complex matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - complex(quad), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & - ! ! is present) - character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & - ! ! and aimag(x) - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - ! - type(settings) :: SE, SEim - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - call disp_cplq(title, x, SE, SEim, n = size(x,2)) - end subroutine disp_tm_cplq - - subroutine disp_cplq(title, x, SE, SEim, n) - ! quadruple precision item - character(*), intent(in) :: title - complex(quad), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE, SEim - integer, intent(in) :: n - integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) - call find_editdesc_quad(real(x), SE, widre, nblre) ! determine also SE%w - call find_editdesc_quad(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w - call tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) - end subroutine disp_cplq - - subroutine tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) - ! Write quadruple precision complex matrix to box - character(*), intent(in) :: title - complex(quad), intent(in) :: x(:,:) - integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) - type(settings), intent(INOUT ) :: SE, SEim - character(SE%w) :: s(m) - character(SEim%w) :: sim(m) - character(3) :: sgn(m) - integer :: lin1, i, j, wleft, wid(n), widp(n) - character, pointer :: boxp(:,:) - SE%zas = '' - SEim%zas = '' - wid = widre + widim + 4 - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) - call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) - do i=1,m - if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif - enddo - call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) - if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) - call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) - call copyseptobox('i', m, lin1, boxp, wleft) - if (j 0) write(s, SE%ed) xj - call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (.not. any(xfinite)) then - w = 4 - else - xmax = maxval(x, mask=xfinite) - xmin = minval(x, mask=xfinite) - f1 = '(SS,ES9.0E4)' - write(s,f1) xmax, xmin - read(s(:)(5:9),'(I5)') expmax, expmin - w = max(0, expmax, expmin) + d + 4 - end if - if (.not. all(xfinite)) w = max(w, 4) - end function maxw_sngl - - subroutine find_editdesc_sngl(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid. - ! The if-block (*) is for safety: make f wider in case xm is written ok with the - ! ES format in fmt but overflows with F format (the feature has been tested through - ! manual changes to the program). - real(sngl), intent(in) :: x(:,:) ! Item to be written - type(settings), intent(INOUT ) :: SE ! Settings - integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns - integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns - integer :: expmax, expmin, ww, dd, dmx - real(sngl) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h - character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 - character(99) s - logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) - ! - dmx = SE%dmx - h = huge(h) - xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (SE%w == 0) then ! Edit descriptor 'F0.d' specified - ww = maxw_sngl(reshape(x, (/size(x)/)), SE%d) - if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas) - call replace_w(SE%ed, ww) - SE%w = ww - elseif (SE%w < 0) then ! No edit descriptor specified - if (size(x) == 0) then - SE%w = 0 - wid = 0 - nbl = 0 - return - endif - if (any(xfinite)) then - xp = maxval(x, mask=xfinite) - xm = minval(x, mask=xfinite) - write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 - write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax - write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin - call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) - if (.not. all(xfinite)) ww = max(ww, 4) - if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas) - if (SE%ed(5:5)=='F') then ! (*) - write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 - write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 - write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd - endif - else - ww = 4 - SE%ed = '(F4.0)' - endif - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1, mask=xfinite) ! max in each column - xminv = minval(x, 1, mask=xfinite) ! min - xzero = any(x == 0._sngl, 1) ! true where column has some zeros - xallz = all(x == 0._sngl, 1) ! true where column has only zeros - xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) - xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) - call getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - else - wid = SE%w - nbl = 0 - endif - end subroutine find_editdesc_sngl - - subroutine getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - ! determine length of the strings that result when writing with edit descriptor SE%ed a - ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output - real(sngl), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column - logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros - logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals - type(settings), intent(in) :: SE ! settings - integer, intent(out) :: wid(:) ! widths of columns - integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmin, SE%ed) xminv - write(stmax, SE%ed) xmaxv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - if (SE%gedit) then - wid = w - else - wid = len_trim(adjustl(stmin)) - wid = max(wid, len_trim(adjustl(stmax))) - endif - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - endif - wid = merge(4, wid, xalln) - wid = max(wid, merge(4, 0, xnonn)) - nbl = w - wid - end subroutine getwid_sngl - - ! ******** TOSTRING snglRUPLE PRECISION PROCEDURES *********** - function tostring_s_sngl(x) result(st) - ! Scalar to string - real(sngl), intent(in) :: x - character(len_f_sngl((/x/), tosset0%rfmt)) :: st - st = tostring_f_sngl((/x/), tosset0%rfmt) - end function tostring_s_sngl - - function tostring_sf_sngl(x, fmt) result(st) - ! Scalar with specified format to string - real(sngl), intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_sngl((/x/), fmt)) :: st - st = tostring_f_sngl((/x/), fmt) - end function tostring_sf_sngl - - function tostring_sngl(x) result(st) - ! Vector to string - real(sngl), intent(in) :: x(:) - character(len_f_sngl(x, tosset0%rfmt)) :: st - st = tostring_f_sngl(x, tosset0%rfmt) - end function tostring_sngl - - function tostring_f_sngl(x, fmt) result(st) - ! Vector with specified format to string - real(sngl) , intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_sngl(x, fmt)) :: st - character(widthmax_sngl(x, fmt)) :: sa(size(x)) - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - integer :: w, d, ww - logical :: gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then - st = errormsg - return - elseif (w == 0) then - ww = maxw_sngl(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - call tostring_get(sa, st) - end function tostring_f_sngl - - pure function len_f_sngl(x, fmt) result(wtot) - ! Total length of returned string, vector s - real(sngl), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_sngl(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d, ww - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - if (w == 0) then - ww = maxw_sngl(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_sngl - - pure function widthmax_sngl(x, fmt) result(w) - ! Maximum width of an element of x - real(sngl), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(nnblk(fmt)+5) :: fmt1 - integer w, d - logical gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then ! illegal format, use 1 - w = 1 - elseif (w == 0) then - w = maxw_sngl(x, d) - endif - end function widthmax_sngl - - ! *************************************** END OF snglRUPLE PRECISION PROCEDURES *************************************** - - ! *************************************** snglRUPLE PRECISION COMPLEX PROCEDURES ************************************** - subroutine disp_s_cplx(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) - ! snglruple precision complex scalar without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim - complex(sngl), intent(in) :: x - integer, intent(in), optional :: unit, digmax - call disp_ts_cplx('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) - end subroutine disp_s_cplx - - subroutine disp_v_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! snglruple precision complex vector without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(sngl), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - call disp_tv_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_cplx - - subroutine disp_m_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! snglruple precision complex matrix without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(sngl), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) - call disp_tm_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - end subroutine disp_m_cplx - - subroutine disp_ts_cplx(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) - ! snglruple precision complex scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(sngl), intent(in) :: x - integer, intent(in), optional :: unit, digmax - call disp_tm_cplx(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, & - trim=trim, unit=unit) - end subroutine disp_ts_cplx - - subroutine disp_tv_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! snglruple precision complex vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(sngl), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) SE, SEim - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - if (SE%row) then - call disp_cplx(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) - else - call disp_cplx(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) - end if - end subroutine disp_tv_cplx - - subroutine disp_tm_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! snglruple precision complex matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - complex(sngl), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & - ! ! is present) - character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & - ! ! and aimag(x) - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - ! - type(settings) :: SE, SEim - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - call disp_cplx(title, x, SE, SEim, n = size(x,2)) - end subroutine disp_tm_cplx - - subroutine disp_cplx(title, x, SE, SEim, n) - ! snglruple precision item - character(*), intent(in) :: title - complex(sngl), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE, SEim - integer, intent(in) :: n - integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) - call find_editdesc_sngl(real(x), SE, widre, nblre) ! determine also SE%w - call find_editdesc_sngl(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w - call tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) - end subroutine disp_cplx - - subroutine tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) - ! Write snglruple precision complex matrix to box - character(*), intent(in) :: title - complex(sngl), intent(in) :: x(:,:) - integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) - type(settings), intent(INOUT ) :: SE, SEim - character(SE%w) :: s(m) - character(SEim%w) :: sim(m) - character(3) :: sgn(m) - integer :: lin1, i, j, wleft, wid(n), widp(n) - character, pointer :: boxp(:,:) - SE%zas = '' - SEim%zas = '' - wid = widre + widim + 4 - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) - call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) - do i=1,m - if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif - enddo - call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) - if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) - call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) - call copyseptobox('i', m, lin1, boxp, wleft) - if (j 0) write(s, SE%ed) xj - call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (.not. any(xfinite)) then - w = 4 - else - xmax = maxval(x, mask=xfinite) - xmin = minval(x, mask=xfinite) - f1 = '(SS,ES9.0E4)' - write(s,f1) xmax, xmin - read(s(:)(5:9),'(I5)') expmax, expmin - w = max(0, expmax, expmin) + d + 4 - end if - if (.not. all(xfinite)) w = max(w, 4) - end function maxw_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine find_editdesc_dble(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid. - ! The if-block (*) is for safety: make f wider in case xm is written ok with the - ! ES format in fmt but overflows with F format (the feature has been tested through - ! manual changes to the program). - real(dble), intent(in) :: x(:,:) ! Item to be written - type(settings), intent(INOUT ) :: SE ! Settings - integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns - integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns - integer :: expmax, expmin, ww, dd, dmx - real(dble) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h - character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 - character(99) s - logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) - ! - dmx = SE%dmx - h = huge(h) - xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (SE%w == 0) then ! Edit descriptor 'F0.d' specified - ww = maxw_dble(reshape(x, (/size(x)/)), SE%d) - if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas) - call replace_w(SE%ed, ww) - SE%w = ww - elseif (SE%w < 0) then ! No edit descriptor specified - if (size(x) == 0) then - SE%w = 0 - wid = 0 - nbl = 0 - return - endif - if (any(xfinite)) then - xp = maxval(x, mask=xfinite) - xm = minval(x, mask=xfinite) - write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 - write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax - write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin - call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) - if (.not. all(xfinite)) ww = max(ww, 4) - if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas) - if (SE%ed(5:5)=='F') then ! (*) - write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 - write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 - write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd - endif - else - ww = 4 - SE%ed = '(F4.0)' - endif - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1, mask=xfinite) ! max in each column - xminv = minval(x, 1, mask=xfinite) ! min - xzero = any(x == 0._dble, 1) ! true where column has some zeros - xallz = all(x == 0._dble, 1) ! true where column has only zeros - xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) - xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) - call getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - else - wid = SE%w - nbl = 0 - endif - end subroutine find_editdesc_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - ! determine length of the strings that result when writing with edit descriptor SE%ed a - ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output - real(dble), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column - logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros - logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals - type(settings), intent(in) :: SE ! settings - integer, intent(out) :: wid(:) ! widths of columns - integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmin, SE%ed) xminv - write(stmax, SE%ed) xmaxv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - if (SE%gedit) then - wid = w - else - wid = len_trim(adjustl(stmin)) - wid = max(wid, len_trim(adjustl(stmax))) - endif - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - endif - wid = merge(4, wid, xalln) - wid = max(wid, merge(4, 0, xnonn)) - nbl = w - wid - end subroutine getwid_dble - - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - function tostring_s_dble(x) result(st) - ! Scalar to string - real(dble), intent(in) :: x - character(len_f_dble((/x/), tosset0%rfmt)) :: st - st = tostring_f_dble((/x/), tosset0%rfmt) - end function tostring_s_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - function tostring_sf_dble(x, fmt) result(st) - ! Scalar with specified format to string - real(dble), intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_dble((/x/), fmt)) :: st - st = tostring_f_dble((/x/), fmt) - end function tostring_sf_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - function tostring_dble(x) result(st) - ! Vector to string - real(dble), intent(in) :: x(:) - character(len_f_dble(x, tosset0%rfmt)) :: st - st = tostring_f_dble(x, tosset0%rfmt) - end function tostring_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - function tostring_f_dble(x, fmt) result(st) - ! Vector with specified format to string - real(dble) , intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_dble(x, fmt)) :: st - character(widthmax_dble(x, fmt)) :: sa(size(x)) - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - integer :: w, d, ww - logical :: gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then - st = errormsg - return - elseif (w == 0) then - ww = maxw_dble(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - call tostring_get(sa, st) - end function tostring_f_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - pure function len_f_dble(x, fmt) result(wtot) - ! Total length of returned string, vector s - real(dble), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_dble(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d, ww - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - if (w == 0) then - ww = maxw_dble(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - pure function widthmax_dble(x, fmt) result(w) - ! Maximum width of an element of x - real(dble), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(nnblk(fmt)+5) :: fmt1 - integer w, d - logical gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then ! illegal format, use 1 - w = 1 - elseif (w == 0) then - w = maxw_dble(x, d) - endif - end function widthmax_dble - - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_s_cpld(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) - ! dbleruple precision complex scalar without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim - complex(dble), intent(in) :: x - integer, intent(in), optional :: unit, digmax - call disp_ts_cpld('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) - end subroutine disp_s_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_v_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! dbleruple precision complex vector without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(dble), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - call disp_tv_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_m_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! dbleruple precision complex matrix without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(dble), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) - call disp_tm_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - end subroutine disp_m_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_ts_cpld(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) - ! dbleruple precision complex scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(dble), intent(in) :: x - integer, intent(in), optional :: unit, digmax - call disp_tm_cpld(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, & - & advance, digmax, sep=sep, style=style, trim=trim, unit=unit) - end subroutine disp_ts_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_tv_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! dbleruple precision complex vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(dble), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) SE, SEim - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - if (SE%row) then - call disp_cpld(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) - else - call disp_cpld(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) - end if - end subroutine disp_tv_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_tm_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! dbleruple precision complex matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - complex(dble), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & - ! ! is present) - character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & - ! ! and aimag(x) - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - ! - type(settings) :: SE, SEim - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - call disp_cpld(title, x, SE, SEim, n = size(x,2)) - end subroutine disp_tm_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_cpld(title, x, SE, SEim, n) - ! dbleruple precision item - character(*), intent(in) :: title - complex(dble), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE, SEim - integer, intent(in) :: n - integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) - call find_editdesc_dble(real(x), SE, widre, nblre) ! determine also SE%w - call find_editdesc_dble(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w - call tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) - end subroutine disp_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) - ! Write dbleruple precision complex matrix to box - character(*), intent(in) :: title - complex(dble), intent(in) :: x(:,:) - integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) - type(settings), intent(INOUT ) :: SE, SEim - character(SE%w) :: s(m) - character(SEim%w) :: sim(m) - character(3) :: sgn(m) - integer :: lin1, i, j, wleft, wid(n), widp(n) - character, pointer :: boxp(:,:) - SE%zas = '' - SEim%zas = '' - wid = widre + widim + 4 - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) - call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) - do i=1,m - if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif - enddo - call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) - if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) - call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) - call copyseptobox('i', m, lin1, boxp, wleft) - if (j NULL(), boxl_dummy2 => NULL() - TYPE(boxnode), POINTER :: boxn_dummy1 => NULL(), boxn_dummy2 => NULL() - TYPE(tostring_settings), POINTER :: ts1 => NULL(), ts2 => NULL() - ts1 => ts2 - ts2 => ts1 - boxl_dummy2 => boxl_dummy1 - boxl_dummy1 => boxl_dummy2 - boxn_dummy2 => boxn_dummy1 - boxn_dummy1 => boxn_dummy2 -END SUBROUTINE avoid_compiler_warnings - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE tostring_set(sep, rfmt, ifmt, trimb, trimz) - CHARACTER(*), OPTIONAL, INTENT(in) :: sep, rfmt, ifmt, trimb, trimz - IF (PRESENT(sep)) tosset0%sep = upper(sep) - IF (PRESENT(sep)) tosset0%seplen = MIN(9, LEN(sep)) - IF (PRESENT(rfmt)) tosset0%rfmt = upper(rfmt) - IF (PRESENT(ifmt)) tosset0%ifmt = upper(ifmt) - IF (PRESENT(trimb)) tosset0%trimb = upper(trimb) - IF (PRESENT(trimz)) tosset0%trimz = upper(trimz) - CALL tostring_check_settings -END SUBROUTINE tostring_set - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE tostring_set_factory() - LOGICAL dummy - dummy = .FALSE. - IF (dummy) CALL avoid_compiler_warnings - tosset0 = tosfac -END SUBROUTINE tostring_set_factory - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE disp_set_ds(settings) - ! Change display settings according to the structure "settings" - TYPE(disp_settings), INTENT(in) :: settings - DEFSET = settings - CALL check_settings -END SUBROUTINE disp_set_ds - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION disp_get() RESULT(defs) - ! Return current display settings - TYPE(disp_settings) :: defs - defs = DEFSET -END FUNCTION disp_get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE DISPMODULE diff --git a/src/modules/Display/src/disp/dispmodule_util.F90 b/src/modules/Display/src/disp/dispmodule_util.F90 deleted file mode 100644 index 6fddd0658..000000000 --- a/src/modules/Display/src/disp/dispmodule_util.F90 +++ /dev/null @@ -1,955 +0,0 @@ -! DISPMODULE, A FORTRAN 95 MODULE FOR PRETTY-PRINTING MATRICES. -! Version number 1.03 16-February-2009. This version published as Algorithm 892 in ACM TOMS. -! -! NOTE: THE MAIN MODULE, DISPMODULE, IS LATER IN THIS FILE. -! -! The usage documentation for DISPMODULE is in a separate document, that exists -! in several formats: -! -! dispmodule_userman.doc Word 2003 doc file -! dispmodule_userman.pdf PDF file -! dispmodule_userman.html HTML file -! dispmodule_userman.txt Text file - -MODULE DISPMODULE_UTIL -! Dispmodule_util contains utilities that are used by Dispmodule, and the add-on modules -! disp_i1mod, disp_i2mod,..., disp_l1mod and disp_r16mod. Note that the entities that are -! declared public below are not exported to the user. The private statements in dispmodule and -! the add-on modules prevent that from happening. - -USE putstrmodule -IMPLICIT NONE - -! ***************** PUBLIC ENTITIES (ONLY PUBLIC TO DISPMODULE, NOT TO USER PROGRAMS) ***************** -PRIVATE - -PUBLIC :: disp_settings, defset, factory_settings, tosset0, tosfac, errormsg, tostring_settings -PUBLIC :: nnblk, upper, readfmt, replace_w, trim_real, get_SE, preparebox, copytobox, boxlist, boxnode -PUBLIC :: copyseptobox, finishbox, tostring_get_complex, disp_errmsg, tostring_get, find_editdesc_real -PUBLIC :: check_settings, tostring_check_settings, replace_zeronaninf, settings, trim_s_real - -! *********************************** GENERAL DECLARATIONS ******************************************** -TYPE disp_settings - ! Settings used by subroutine disp and the utility procedures. - CHARACTER(6) :: advance = 'YES' - CHARACTER(9) :: matsep = ' ' - CHARACTER(3) :: orient = 'COL' - CHARACTER(9) :: sep = ' ' - CHARACTER(9) :: style = 'LEFT' - CHARACTER(4) :: trim = 'AUTO' - CHARACTER(9) :: zeroas = '' - INTEGER :: digmax = 6 - INTEGER :: matseplen = 3 - INTEGER :: seplen = 2 - INTEGER :: unit = DEFAULT_UNIT - INTEGER :: zaslen = 0 -END TYPE disp_settings - -TYPE tostring_settings - ! Settings used by function tostring. - CHARACTER(10) :: ifmt = 'I0' - CHARACTER(16) :: rfmt = '1PG12.5' ! 'SP,1P,G20.11E3' has length 14 and is about max - CHARACTER(9) :: sep = ', ' - INTEGER :: seplen = 2 - CHARACTER(3) :: trimb = 'YES' - CHARACTER(4) :: trimz = 'G' -END TYPE tostring_settings - -TYPE settings - ! Settings used (privately) by disp and the utility procedures, in the variable SE. - CHARACTER(22) ed - CHARACTER(9) sep, tsty, zas - CHARACTER(1) tch - INTEGER lun, dmx, w, d, lsep, lzas, m1, n1, adv - LOGICAL trm, number, vec, row, gedit -END TYPE settings - -TYPE(disp_settings) :: DEFSET -!$OMP THREADPRIVATE(DEFSET) -!! Current default settings for disp -TYPE(disp_settings) :: FACTORY_SETTINGS -!$OMP THREADPRIVATE(FACTORY_SETTINGS) -!! Original (factory) settings for disp -TYPE(tostring_settings), SAVE :: tosset0 -!$OMP THREADPRIVATE(tosset0) -!! Current settings for tostring -TYPE(tostring_settings) :: tosfac -!$OMP THREADPRIVATE(tosfac) -!! Factory settings for tostring - -CHARACTER(*), PARAMETER :: errormsg = 'Illegal format' - -! ********************* BOX-PACKAGE DECLARATIONS (SEE EXPLANATION ABOUT BOX-PACKAGE BELOW) ***************** -TYPE boxnode - ! A box is the character representation of a printed item - CHARACTER, POINTER :: box(:, :) - TYPE(boxnode), POINTER :: nextbox => NULL() -END TYPE boxnode -! -TYPE boxlist - ! There is one list of boxes associated with each logical unit - INTEGER :: unit = 1 - TYPE(boxnode), POINTER :: firstbox => NULL() - TYPE(boxnode), POINTER :: lastbox => NULL() - TYPE(boxlist), POINTER :: nextboxlist => NULL() -END TYPE boxlist -! -TYPE(boxlist), POINTER :: firstboxlist => NULL() -! ************************ END OF BOX-PACKAGE DECLARATIONS ****************************** - -CONTAINS - -! ***************************** GENERAL PROCEDURES ************************************** -SUBROUTINE check_settings() - ! Sanity check of display settings - CHARACTER(9) :: tsty - CHARACTER tch - LOGICAL number, ok, dmxerr, orierr, styerr, adverr - CHARACTER(6), PARAMETER :: ADVOK(3) = (/'NO ', 'YES ', 'DOUBLE'/) - TYPE(disp_settings) ds - ds = DEFSET - CALL getstyles(ds%style, tsty, tch, number, ok) - styerr = .NOT. ok - dmxerr = ds%digmax < 1 .OR. ds%digmax > 89 - orierr = ALL(ds%orient /= (/'ROW', 'COL'/)) - adverr = ALL(ds%advance /= ADVOK) - IF (dmxerr) DEFSET%digmax = 6 - IF (orierr) DEFSET%orient = 'COL' - IF (styerr) DEFSET%style = 'LEFT' - IF (adverr) DEFSET%advance = 'YES' - ! - if (dmxerr) call disp_errmsg('DISP_SET: error, illegal digmax (must be 1-89), set to 6') - if (orierr) call disp_errmsg('DISP_SET: error, illegal orient: ' // trim(ds%orient) // ', set to "COL"') - if (styerr) call disp_errmsg('DISP_SET: error, illegal style: ' // trim(ds%style) // ', set to "LEFT"') - if (adverr) call disp_errmsg('DISP_SET: error, illegal advance: ' // trim(ds%advance) // ', set to "YES"') -END SUBROUTINE check_settings - -FUNCTION number_rows(SE) RESULT(nbr) - ! Should rows be numbered? - TYPE(settings), INTENT(in) :: SE - LOGICAL nbr - nbr = .FALSE. - IF (.NOT. SE%number) RETURN - IF (SE%vec .AND. SE%row) RETURN - nbr = .TRUE. -END FUNCTION number_rows - -FUNCTION number_cols(SE) RESULT(nbr) - ! Should columns be numbered? - TYPE(settings), INTENT(in) :: SE - LOGICAL nbr - nbr = .FALSE. - IF (.NOT. SE%number) RETURN - IF (SE%vec .AND. .NOT. SE%row) RETURN - nbr = .TRUE. -END FUNCTION number_cols - -SUBROUTINE preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - ! Determine format to use to write matrix to box and row where matrix begins, copy - CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix - TYPE(settings), INTENT(in) :: SE ! Settings - INTEGER, INTENT(in) :: m ! Row count of matrix - INTEGER, INTENT(in) :: n ! Column count of matrix - INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns in matrix - INTEGER, INTENT(out) :: widp(:) ! widths of columns in box (max(wid, width of col nums)) - INTEGER, INTENT(out) :: lin1 ! Row number where matrix begins (tsty='left' 0, 'pad' 1, 'underline' 2) - INTEGER, INTENT(out) :: wleft ! Number of spaces on left of matrix (when tsty is left or title long) - CHARACTER, POINTER :: boxp(:, :) ! The box - - INTEGER wt, wa ! Char count of title, idth of matrix in characters (wbox = lm + wa + rm) - INTEGER wbox, wrow ! Width of box in characters, width of row numbers in characters - INTEGER lm ! Left margin - INTEGER h, ws ! Height of box in characters, length of column separator - INTEGER m1, n1, i ! lower bounds (for numbering), index - CHARACTER(RANGE(0) + 2) sn(2), row_nums(m), col_nums(n) - CHARACTER(10) fmt - - ! ----------wbox--------- -----------wbox---------- -----wbox------ - ! ---lm--- --wleft- --wt- - ! ----wleft--- lm wrow wa rm wrow wa - ! wt wrow wa ----====-----------====== ----=========== - ! --------====----------- THIS-IS-A-VERY-LONG-TITLE TITLE - ! 1 2 1 2 1 2 - ! MATRIX = 1 4.50 6.80 1 4.50 6.80 1 4.50 6.80 - ! 2 6.88 9.22 2 6.88 9.22 2 6.88 9.22 - ! 3 19.44 0.08 3 19.44 0.08 3 19.44 0.08 - ! ... ... ... - ! 10 6.18 4.22 10 6.18 4.22 10 6.18 4.22 - ! rm = 0 wt = wbox lm = rm = 0, wleft = wrow - m1 = SE%m1 - n1 = SE%n1 - ws = SE%lsep - wt = LEN(title) - wrow = 0 - widp = wid - IF (SE%number) THEN - fmt = '(SS,I0)' - IF (number_cols(SE)) THEN - WRITE (col_nums, fmt) (/(i, i=n1, n1 + n - 1)/) - widp = MAX(wid, LEN_TRIM(col_nums)) - END IF - IF (number_rows(SE)) THEN - WRITE (sn, fmt) m1, m1 + m - 1 - wrow = MAXVAL(LEN_TRIM(sn)) + ws ! determine max width of row numbers - CALL replace_w(fmt, wrow - ws) ! to create e.g. 'I5' from 'I0' - WRITE (row_nums, fmt) (/(i, i=m1, m1 + m - 1)/) - END IF - END IF - wa = MAX(0, n - 1) * ws + SUM(widp) - SELECT CASE (upper(SE%tsty)) - CASE ('LEFT'); lin1 = 1; wbox = wt + wrow + wa; h = MAX(1, m); lm = wt - CASE ('PAD'); lin1 = 2; wbox = MAX(wt, wa + wrow); h = m + 1; lm = MAX(0, (wt - wa - wrow) / 2) - CASE ('UNDERLINE'); lin1 = 3; wbox = MAX(wt, wa + wrow); h = m + 2; lm = MAX(0, (wt - wa - wrow) / 2) - CASE default; lin1 = 1; wbox = 0; h = 0; lm = 0 ! should not happen - END SELECT - wleft = lm - IF (number_cols(SE)) h = h + 1 - CALL newbox(SE%lun, h, wbox, boxp) - IF (number_cols(SE)) THEN -CALL copycolumnnumberstobox(col_nums, wleft + wrow, wid, widp, ws, boxp, lin1) - END IF - IF (number_rows(SE)) THEN - call copytobox(row_nums, lin1, wrow - ws, wrow - ws, nblj = 0, boxp = boxp, wleft = wleft) - CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) - END IF -END SUBROUTINE preparebox - -SUBROUTINE copytobox(s, lin1, widj, widpj, nblj, boxp, wleft) - ! Copy strings to column in boxp; update wleft to current char column in boxp - CHARACTER(*), INTENT(in) :: s(:) ! the strings to copy - INTEGER, INTENT(in) :: lin1, widj ! first line in box to copy to, width of column - INTEGER, INTENT(in) :: nblj, widpj ! number of blank characters to trim from left of s, offset to next col - CHARACTER, INTENT(INOUT) :: boxp(:, :) ! the box to accept the column - INTEGER, INTENT(INOUT) :: wleft ! number of char-columns in box already written to - INTEGER i, j - wleft = wleft + widpj - widj - ! forall(i = 1:widj, j=1:size(s)) boxp(wleft+i, j+lin1-1) = s(j)(i+nblj:i+nblj) - DO CONCURRENT(i=1:widj, j=1:SIZE(s)) - boxp(wleft + i, j + lin1 - 1) = s(j) (i + nblj:i + nblj) - END DO - wleft = wleft + widj -END SUBROUTINE copytobox - -SUBROUTINE copyseptobox(sep, m, lin1, boxp, wleft) - ! Copy column separator to boxp; update wleft - CHARACTER(*), INTENT(in) :: sep - INTEGER, INTENT(in) :: m, lin1 - CHARACTER, INTENT(INOUT) :: boxp(:, :) - INTEGER, INTENT(INOUT) :: wleft - INTEGER i, j - ! forall(i = 1:len(sep), j=1:m) boxp(wleft+i, j+lin1-1) = sep(i:i) - DO CONCURRENT(i=1:LEN(sep), j=1:m) - boxp(wleft + i, j + lin1 - 1) = sep(i:i) - END DO - wleft = wleft + LEN(sep) -END SUBROUTINE copyseptobox - -SUBROUTINE copycolumnnumberstobox(s, wleft, wid, widp, lsep, boxp, lin1) - CHARACTER(*), INTENT(in) :: s(:) ! strings with left-adjusted column numbers - INTEGER, INTENT(in) :: wleft ! char positions on left of 1st col - INTEGER, INTENT(in) :: wid(:) ! widths of columns in matrix - INTEGER, INTENT(in) :: widp(:) ! widths of columns in box (max(wid, width of col nums)) - INTEGER, INTENT(in) :: lsep ! width of column separator - CHARACTER, INTENT(INOUT) :: boxp(:, :) ! receives the numbers - INTEGER, INTENT(INOUT) :: lin1 ! line number in box to copy to - INTEGER ls(SIZE(s)), rmargmax, k, i, lmargin, j - ! - ls = LEN_TRIM(s) - rmargmax = (MAX(0, MINVAL(wid) - MAXVAL(ls))) / 2 ! locate according to narrowest column, widest number - k = wleft - DO i = 1, SIZE(wid) - lmargin = MAX(0, widp(i) - ls(i) - rmargmax) - k = k + lmargin - DO CONCURRENT(j=1:ls(i)) - boxp(k + j, lin1) = s(i) (j:j) - END DO - k = k + widp(i) - lmargin + lsep - END DO - lin1 = lin1 + 1 -END SUBROUTINE copycolumnnumberstobox - -SUBROUTINE finishbox(title, SE, boxp) - ! Finish creating a box and display it if advancing is turned on - CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix - TYPE(settings), INTENT(in) :: SE ! Settings - CHARACTER, INTENT(INOUT) :: boxp(:, :) ! The box - ! - INTEGER i, wt, w, wpadright, wpadleft ! index, width of title, width of box and spacing on either side of it - INTEGER lin1 ! line to put left title - ! - wt = LEN(title) - w = SIZE(boxp, 1) - IF (upper(SE%tsty) == 'LEFT') THEN - lin1 = 1 - IF (number_cols(SE)) lin1 = MIN(2, SIZE(boxp, 2)) - ! forall(i=1:wt) boxp(i,lin1) = title(i:i) - DO CONCURRENT(i=1:wt) - boxp(i, lin1) = title(i:i) - END DO - ELSE - wpadright = (w - wt) / 2 - wpadleft = w - wpadright - wt - ! forall(i=1:wt) boxp(wpadleft+i, 1) = title(i:i) - DO CONCURRENT(i=1:wt) - boxp(wpadleft + i, 1) = title(i:i) - END DO - IF (upper(SE%tsty) == 'PAD') THEN - boxp(1:wpadleft, 1) = SE%tch - boxp(w - wpadright + 1:w, 1) = SE%tch - ELSE ! tsty == 'UNDERLINE' - boxp(:, 2) = SE%tch - END IF - END IF - IF (SE%adv >= 1) CALL dispboxlist(SE%lun, DEFSET%matsep(1:DEFSET%matseplen)) - IF (SE%adv >= 2) CALL dispnewline(SE%lun) -END SUBROUTINE finishbox - -SUBROUTINE find_editdesc_real(exp, expm, dmx, edesc, flen, ndec, posit) - ! Subroutine of find_editdesc_sngl and find_editdesc_dble - INTEGER, INTENT(in) :: expm, dmx - INTEGER, INTENT(INOUT) :: exp - CHARACTER(14), INTENT(out) :: edesc - INTEGER, INTENT(out) :: flen, ndec - LOGICAL, INTENT(in) :: posit - INTEGER :: neg, nxp - exp = MAX(exp, expm) - neg = 1 - IF (exp < dmx .AND. exp >= -1) THEN - IF (posit .OR. exp > MAX(0, expm)) neg = 0 - edesc = '(SS,Fxx.yy)' - ndec = MAX(0, dmx - exp - 1) - flen = neg + 2 + ndec + MAX(0, exp) ! -X.YYYYY (2 covers X and .) - WRITE (edesc(6:10), '(SS,I2,".",I2)') flen, ndec - ELSE - IF (posit) neg = 0 - IF (ABS(exp) > 999) THEN; nxp = 4 - ELSEIF (ABS(exp) > 99) THEN; nxp = 3 - ELSEIF (ABS(exp) > 9) THEN; nxp = 2 - ELSE; nxp = 1 - END IF - flen = neg + 3 + dmx + nxp - edesc = '(SS,ESxx.yyEz)' - WRITE (edesc(7:13), '(SS,I2,".",I2,"E",I1)') flen, dmx - 1, nxp - ndec = dmx - 1 - END IF -END SUBROUTINE find_editdesc_real - -PURE SUBROUTINE readfmt(fmt, fmt1, w, d, gedit) - ! Returns w and d when fmt is (Xw.d) or (Xw) (then d = 0), X = edit descriptor letter - ! (I, F, etc). X can also be ES, DS, 1PG or 1PF. Returns w = -1 for illegal fmt. - ! Returns gedit = .true. if fmt is Gw.d. How about SS,1PES4.3? - CHARACTER(*), INTENT(in) :: fmt ! e.g. fmt = F 8.2 - CHARACTER(*), INTENT(out) :: fmt1 ! returns '(SS,F8.2)' - CHARACTER ch - INTEGER, INTENT(out) :: w, d - LOGICAL, INTENT(out) :: gedit - INTEGER :: k0, k1, k2, k3, k4 - CALL sszipfmt(fmt, fmt1) - w = -1; d = 0; gedit = .FALSE. - k1 = VERIFY(fmt1(2:), '0123456789') + 1 - IF (k1 == 0) RETURN ! only digits - k2 = VERIFY(fmt1(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 ! , for "1P,G12.3" - IF (k2 <= k1) RETURN ! no letter or only letters - ch = upper(fmt1(k2 - 1:k2 - 1)) - IF (ch == ',') THEN ! deal with SS,1PG13.5 - k0 = k2 - k1 = VERIFY(fmt1(k0:), '0123456789') + k0 - 1 - IF (k1 == 0) RETURN - k2 = VERIFY(fmt1(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 - IF (k2 <= k1) RETURN - ch = upper(fmt1(k2 - 1:k2 - 1)) - END IF - gedit = ch == 'G' .OR. ch == 'g' - k3 = VERIFY(fmt1(k2:), '0123456789') + k2 - 1 - IF (k3 == k2) RETURN ! no digits - READ (fmt1(k2:k3 - 1), *) w - IF (k3 > LEN(fmt1)) RETURN - IF (fmt1(k3:k3) /= '.') RETURN ! not . after w - k4 = VERIFY(fmt1(k3 + 1:), '0123456789') + k3 - IF (k4 == k3 + 1) RETURN ! no digits - READ (fmt1(k3 + 1:k4 - 1), *) d -END SUBROUTINE readfmt - -PURE SUBROUTINE replace_w(fmt, wnew) - ! Change e.g. '(F0.3)' to '(F5.3)'. Works also for '(SS,I0)' to '(SS,I5)'. If wnew > 999, set it to 999 - CHARACTER(*), INTENT(INOUT) :: fmt - INTEGER, INTENT(in) :: wnew - INTEGER :: k0, k1, k2, k3 - CHARACTER(3) rw - k1 = VERIFY(fmt(2:), '0123456789') + 1 - k2 = VERIFY(fmt(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 - IF (k2 == k1) RETURN ! no letter - IF (fmt(k2 - 1:k2 - 1) == ',') THEN ! Handle (SS,1PF10.3) - k0 = k2 - k1 = VERIFY(fmt(k0:), '0123456789') + 1 - IF (k1 == 0) RETURN - k2 = VERIFY(fmt(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 - IF (k2 <= k1) RETURN - END IF - k3 = VERIFY(fmt(k2:), '0123456789') + k2 - 1 - IF (k3 == k2) RETURN ! no digits - WRITE (rw, '(SS,I0)') MIN(999, wnew) - fmt = fmt(1:k2 - 1)//TRIM(rw)//fmt(k3:) -END SUBROUTINE replace_w - - subroutine get_SE(SE, title, shapex, fmt, advance, lbound, seperator, style, trim, unit, orient, zeroas, digmax) - ! Get the settings from the optional parameters fmt...zeroas in to the structure SE. - ! Replace absent arguments with corresponding values from the structure DEFSET. - TYPE(settings), INTENT(out) :: SE - CHARACTER(*), INTENT(in) :: title - INTEGER, INTENT(in) :: shapex(:) - CHARACTER(*), INTENT(in), OPTIONAL :: fmt - INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) - character(*), intent(in), optional :: advance, seperator, style, zeroas, trim, orient - LOGICAL ok - ! - CHARACTER(22) ed - CHARACTER(9) sep, tsty, zas - CHARACTER(1) tch - CHARACTER(6) advchr - INTEGER lun, dmx, w, d, lsep, lzas, m1, n1, adv - LOGICAL trm, number, vec, row, is_scalar, gedit - ! - vec = (SIZE(shapex) == 1) - is_scalar = SIZE(shapex) == 0 - IF (vec .AND. PRESENT(orient)) THEN - SELECT CASE (upper(orient)) - CASE ('ROW'); row = .TRUE. - CASE ('COL'); row = .FALSE. - CASE default; - call disp_errmsg('DISP: error, wrong value of orient: '//orient(1:len_trim(orient))//', using "COL"') - row = .FALSE. - END SELECT - ELSEIF (vec) THEN - row = DEFSET%orient == 'ROW' - ELSE - row = .FALSE. - END IF - IF (PRESENT(fmt)) THEN - CALL readfmt(fmt, ed, w, d, gedit) - ELSE - ed = '()' - w = -1; d = 0; gedit = .FALSE. - END IF - IF (PRESENT(unit)) THEN - lun = unit - ELSE - lun = DEFSET%unit - END IF - IF (.NOT. PRESENT(digmax)) THEN - dmx = DEFSET%digmax - ELSEIF (PRESENT(fmt)) THEN - CALL disp_errmsg('DISP: error, both FMT and DIGMAX present, ignoring DIGMAX') - dmx = 1 - ELSEIF (digmax < 1 .OR. digmax > 89) THEN - CALL disp_errmsg('DISP: error, digmax must be >= 1 and < 90, using 6') - dmx = 6 - ELSE - dmx = digmax - END IF - IF (PRESENT(advance)) THEN - advchr = upper(advance) - ELSE - advchr = DEFSET%advance - END IF - SELECT CASE (trims(advchr)) - CASE ('NO'); adv = 0 - CASE ('YES'); adv = 1 - CASE ('DOUBLE'); adv = 2 - CASE default - call disp_errmsg('DISP: error, illegal advance: ' // trims(advance) // ', using "YES"') - adv = 1 - END SELECT - IF (PRESENT(trim)) THEN - if (upper(trim) /= 'YES' .and. upper(trim) /= 'NO' .and. upper(trim) /= 'AUTO') then - CALL disp_errmsg('DISP: error, illegal trim: '//trims(trim)//', using "YES"') - trm = .TRUE. - ELSE -trm = upper(trim) == 'YES' .OR. upper(trim) == 'AUTO' .AND. .NOT. PRESENT(FMT) - END IF - ELSEIF (w == 0) THEN - trm = .TRUE. - ELSE -trm = DEFSET%trim == 'YES' .OR. DEFSET%trim == 'AUTO' .AND. .NOT. PRESENT(FMT) - END IF - IF (PRESENT(seperator)) THEN - sep = seperator - lsep = LEN(seperator) - ELSE - sep = DEFSET%sep - lsep = DEFSET%seplen - END IF - IF (PRESENT(style)) THEN - CALL getstyles(style, tsty, tch, number, ok) - if (.not. ok) call disp_errmsg('DISP: error, illegal style: '//style//'. Using default instead') - ELSE - CALL getstyles(DEFSET%style, tsty, tch, number, ok) - END IF - IF (title == '') tsty = 'LEFT' - IF (is_scalar) number = .FALSE. - IF (PRESENT(zeroas)) THEN - zas = zeroas - lzas = LEN(zeroas) - ELSE - zas = DEFSET%zeroas - lzas = DEFSET%zaslen - END IF - IF (w > 0) lzas = MIN(w, lzas) - zas = zas(1:lzas) - m1 = 1 - n1 = 1 - IF (PRESENT(lbound)) THEN - number = .TRUE. - IF (SIZE(lbound) == 1) THEN - IF (vec .AND. row) THEN - n1 = LBOUND(1) - ELSE - m1 = LBOUND(1) - END IF - ELSEIF (SIZE(lbound) >= 2) THEN - m1 = LBOUND(1) - n1 = LBOUND(2) - END IF - END IF - SE = settings(ed, sep, tsty, zas, tch, lun, dmx, w, d, lsep, lzas, m1, n1, adv, trm, number, vec, row, gedit) -CONTAINS - FUNCTION trims(s) RESULT(t) - CHARACTER(*), INTENT(in) :: s - CHARACTER(LEN_TRIM(s)) :: t - INTRINSIC trim - t = TRIM(s) - END FUNCTION trims -END SUBROUTINE get_SE - -SUBROUTINE getstyles(style, tsty, tch, number, ok) - ! Return tsty = 'LEFT', 'PAD', or 'UNDERLINE', tch = x from xPAD or xUNDERLINE, number = .true. if style includes - ! NUMBER. If style has ABOVE, return tsty = 'PAD' and tch = ' '. Return tsty = 'LEFT' if error. See NOTE 1 below. - CHARACTER(*), INTENT(in) :: style - CHARACTER(9), INTENT(out) :: tsty - CHARACTER(1), INTENT(out) :: tch - LOGICAL, INTENT(out) :: number, ok - INTEGER kamp, i, nsty - CHARACTER(LEN(style)) :: sty(2) - character(9), parameter :: LPUA(4) = (/'LEFT ', 'PAD ', 'UNDERLINE', 'ABOVE '/) - CHARACTER(9), PARAMETER :: PU(2) = (/'PAD ', 'UNDERLINE'/) - kamp = SCAN(upper(style), '&') - ok = .TRUE. - IF (kamp > 0) THEN - sty(1) = ADJUSTL(upper(style(1:kamp - 1))) - sty(2) = ADJUSTL(upper(style(kamp + 1:))) - nsty = 2 - ELSE - sty(1) = ADJUSTL(upper(style)) - nsty = 1 - END IF - number = .FALSE. - tsty = 'LEFT' - tch = '-' - DO i = 1, nsty - IF (sty(i) == 'NUMBER') THEN - number = .TRUE. - ELSEIF (sty(i) == 'ABOVE') THEN - tsty = 'PAD' - tch = ' ' - ELSEIF (ANY(sty(i) == LPUA)) THEN - tsty = sty(i) - ELSEIF (ANY(sty(i) (2:) == PU)) THEN - tsty = sty(i) (2:) - tch = sty(i) (1:1) - ELSE - ok = .FALSE. - RETURN - END IF - END DO - ok = .TRUE. -END SUBROUTINE getstyles - -SUBROUTINE replace_zeronaninf(s, zas, maskz, masknan, maskminf, maskinf) - ! replace zeros in s (where maskz is true) with zas (i.e. zero-as string) also replace nans with 'NaN', - ! infinities with '+Inf' and minus infinities with '-Inf'. Zeros are aligned with . if zas contains . - ! otherwise right-adjusted. Nans, and infs are right adjusted. - ! NOTE: There are compiler bugs in current versions of both the Absoft and the Pathscale compilers - ! so the merge calls (commented out below) had to be replaced with do loops. - CHARACTER(*), INTENT(INOUT) :: s(:) - LOGICAL, INTENT(in) :: maskz(:), masknan(:), maskinf(:), maskminf(:) - CHARACTER(*), INTENT(in) :: zas - OPTIONAL :: masknan, maskminf, maskinf - CHARACTER(LEN(s)) z, nan, minf, inf - INTEGER w, wz, n, i, k, zasdot - w = LEN(s) - wz = LEN(zas) - n = SIZE(maskz) - IF (wz /= 0 .AND. wz <= w) THEN ! zas not empty and not too wide - zasdot = INDEX(zas, '.') - z = '' - IF (zasdot > 0) THEN - DO i = 1, n - IF (maskz(i)) EXIT - END DO - IF (i <= n) THEN ! some zeros - k = INDEX(s(i), '.') - IF (k == 0 .OR. zasdot > k .OR. wz - zasdot > w - k) THEN ! cannot align .'s - z(w - wz + 1:) = zas ! align right - ELSE - z(k - zasdot + 1:k - zasdot + wz) = zas - END IF - END IF - ELSE - z(w - wz + 1:) = zas - END IF - ! s = merge(z, s, maskz) - DO i = 1, n - IF (maskz(i)) s(i) = z - END DO - END IF - IF (PRESENT(masknan)) THEN - IF (w >= 4) THEN - nan = REPEAT(' ', w - 4)//' NaN' - minf = REPEAT(' ', w - 4)//'-Inf' - inf = REPEAT(' ', w - 4)//'+Inf' - ELSEIF (w == 3) THEN - nan = 'NaN' - minf = '***' - inf = 'Inf' - ELSE - nan = REPEAT('*', w) - minf = nan - inf = nan - END IF - ! s = merge(nan, s, masknan) - ! s = merge(minf, s, maskminf) - ! s = merge(inf, s, maskinf) - DO i = 1, n - IF (masknan(i)) s(i) = nan - IF (maskminf(i)) s(i) = minf - IF (maskinf(i)) s(i) = inf - END DO - END IF -END SUBROUTINE replace_zeronaninf - -PURE FUNCTION upper(s) RESULT(su) ! Change string to upper case - CHARACTER(*), INTENT(in) :: s - CHARACTER(LEN(s)) su - CHARACTER(26), PARAMETER :: ll = 'abcdefghijklmnopqrstuvwxyz', & - ul = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - INTEGER i, k - su = s - DO i = 1, LEN(s) - k = INDEX(ll, s(i:i)) - IF (k > 0) su(i:i) = ul(k:k) - END DO -END FUNCTION upper - -PURE SUBROUTINE sszipfmt(fmt, fmt1) - ! Set fmt1 to '(SS,'//removeblanks(fmt)//')'. Caller is responsible that - ! fmt1 has sufficient length. - CHARACTER(*), INTENT(in) :: fmt - CHARACTER(*), INTENT(out) :: fmt1 - INTEGER i, j - fmt1 = '(SS,' - j = 5 - DO i = 1, LEN(fmt) - IF (fmt(i:i) /= ' ') THEN - fmt1(j:j) = fmt(i:i) - j = j + 1 - END IF - END DO - fmt1(j:j) = ')' -END SUBROUTINE sszipfmt - -PURE FUNCTION nnblk(s) RESULT(n) ! count nonblanks in s - CHARACTER(*), INTENT(in) :: s - INTEGER i, n - n = 0 - DO i = 1, LEN(s) - IF (s(i:i) /= ' ') n = n + 1 - END DO -END FUNCTION nnblk - -SUBROUTINE disp_errmsg(s) - CHARACTER(*), INTENT(in) :: s - INTEGER wleft - CHARACTER(1), POINTER :: boxp(:, :) - wleft = 0 - CALL newbox(DEFAULT_UNIT, 1, LEN(s), boxp) - call copytobox((/s/), lin1 = 1, widj = len(s), widpj = len(s), nblj = 0, boxp = boxp, wleft = wleft) - CALL dispboxlist(DEFAULT_UNIT, sep='') -END SUBROUTINE disp_errmsg -! *********************************** END OF GENERAL PROCEDURES ********************************* - -! ************************************* TOSTRING PROCEDURES ************************************* -SUBROUTINE tostring_check_settings - ! Sanity check of tostring settings - TYPE(tostring_settings) ts - INTEGER wi, wr, d - CHARACTER(MAX(LEN(tosset0%rfmt), LEN(tosset0%ifmt)) + 5) fmt1 - LOGICAL gedit - ts = tosset0 - IF (ALL(ts%trimb /= (/'YES', 'NO '/))) tosset0%trimb = tosfac%trimb - IF (ALL(ts%trimz /= (/'NONE', 'ALL ', 'G '/))) tosset0%trimz = tosfac%trimz - CALL readfmt(tosset0%rfmt, fmt1, wr, d, gedit) - CALL readfmt(tosset0%ifmt, fmt1, wi, d, gedit) - IF (wr < 0) tosset0%rfmt = tosfac%rfmt - IF (wi < 0) tosset0%ifmt = tosfac%ifmt - IF (ALL(ts%trimb /= (/'YES ', 'NO ', 'AUTO'/))) CALL disp_errmsg( & - 'TOSTRING_SET: error, illegal trimb: '//trim(ts%trimb)//', set to ' // trim(tosfac%trimb)) - IF (ALL(ts%trimz /= (/'NONE', 'ALL ', 'G '/))) CALL disp_errmsg( & - 'TOSTRING_SET: error, illegal trimz: '//trim(ts%trimz)//', set to '//trim(tosfac%trimz)) - IF (wr < 0) CALL disp_errmsg( & - 'TOSTRING_SET: error, illegal rfmt: '//trim(ts%rfmt)//', set to '//trim(tosfac%rfmt)) - IF (wi < 0) CALL disp_errmsg( & - 'TOSTRING_SET: error, illegal ifmt: '//trim(ts%ifmt)//', set to '//trim(tosfac%ifmt)) -END SUBROUTINE tostring_check_settings - -PURE SUBROUTINE trim_s_real(sa, gedit, w) - ! Trim trailing zeros and possibly decimal point from fractional part. - ! If sa = '52.2000E12' on entry then it is returned as '52.2E12 '. - ! Whether trimming is actually done depends on tosset0, gedit and w. - CHARACTER(*), INTENT(INOUT) :: sa - LOGICAL, INTENT(in) :: gedit - INTEGER, INTENT(in) :: w - INTEGER k, k2, k3 - IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) - IF (tosset0%trimz == 'ALL' .OR. tosset0%trimz == 'G' .AND. gedit) THEN - k = SCAN(sa, '.') - IF (k > 0) THEN - k2 = VERIFY(sa(k + 1:), '0123456789') + k - IF (k2 == k) k2 = LEN(sa) + 1 - k3 = VERIFY(sa(k:k2 - 1), '0.', back=.TRUE.) + k - 1 - sa(k3 + 1:) = sa(k2:) - END IF - END IF -END SUBROUTINE trim_s_real - -PURE SUBROUTINE trim_real(sa, gedit, w) - ! Trim trailing zeros and possibly decimal point from fractional part. - ! If sa = '52.2000E12' on entry then it is returned as '52.2E12 '. - ! Whether trimming is actually done depends on tosset0, gedit and w. - CHARACTER(*), INTENT(INOUT) :: sa(:) - LOGICAL, INTENT(in) :: gedit - INTEGER, INTENT(in) :: w - INTEGER i - IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) - IF (tosset0%trimz == 'ALL' .OR. tosset0%trimz == 'G' .AND. gedit) THEN - DO i = 1, SIZE(sa) ! trim trailing zeros from fractional part - CALL trim_s_real(sa(i), gedit, w) - END DO - END IF -END SUBROUTINE trim_real - -PURE SUBROUTINE tostring_get(sa, st) - ! Copy trimmed elements of sa (containing individual elements as strings) to the final - ! tostring result st, separated by tosset0%sep strings. - CHARACTER(*), INTENT(in) :: sa(:) - CHARACTER(*), INTENT(out) :: st - INTEGER :: i, k, n, sepl - sepl = tosset0%seplen - k = 0 - DO i = 1, SIZE(sa) - IF (k > 0) st(k + 1:k + sepl) = tosset0%sep(1:sepl) - IF (k > 0) k = k + sepl - n = LEN_TRIM(sa(i)) - st(k + 1:k + n) = TRIM(sa(i)) - k = k + n - END DO -END SUBROUTINE tostring_get - -PURE SUBROUTINE tostring_get_complex(sar, sgn, sai, st) - ! Version of tostring_get for complex numbers - CHARACTER(*), INTENT(in) :: sar(:), sai(:), sgn(*) - CHARACTER(*), INTENT(out) :: st - INTEGER :: i, k, n, sepl - sepl = tosset0%seplen - k = 0 - DO i = 1, SIZE(sar) - IF (k > 0) st(k + 1:k + sepl) = tosset0%sep(1:sepl) - IF (k > 0) k = k + sepl - n = LEN_TRIM(sar(i)) - st(k + 1:k + n) = TRIM(sar(i)) - st(k + n + 1:k + n + 3) = ' '//sgn(i)//' ' - k = k + n + 3 - n = LEN_TRIM(sai(i)) - st(k + 1:k + n) = TRIM(sai(i)) - st(k + n + 1:k + n + 1) = 'i' - k = k + n + 1 - END DO -END SUBROUTINE tostring_get_complex - -! ********************************* END OF TOSTRING PROCEDURES ********************************* - -! *********************************** BOX-PACKAGE ********************************************** -! -! A "box" is a variable dimension character matrix that can be created dynamically. There are -! linked lists of boxes, one for each logical unit. When disp is called the item to be displayed -! is written to a box. If advance = 'no' is in effect, the writing out of the items is delayed -! until disp is called on the same unit with advance = 'yes' in effect; then all the boxes in -! the relevant list are written to the unit. There are two subroutines that are meant to be -! called from outside the Box-package: NEWBOX and DISPBOXLIST: -! -! CALL NEWBOX(UNIT, M, N, BOXP) creates a box on unit UNIT. BOXP returns a pointer to the -! created box which is of type CHARACTER and DIMENSION (M,N). -! -! CALL DISPBOXLIST(UNIT, SEP) writes all the boxes in the list associated with UNIT to the file -! on UNIT, separated with the string SEP. The following example makes this clear: let SEP = ' : ' -! and let the first box contain XXX and the second have two rows, both equal to YYYY. Then the -! text written will be: XXX : YYYY : YYYY -! -! To obtain tab-separated boxes when using ASCII, let SEP = char(9). After writing the boxes, -! the complete list is deallocated. If UNIT = -3 the asterisk unit (usually command window) is -! written to. If UNIT = -2 the routine putstr from the disp_where unit is used for writing. If -! UNIT = -1 all output will be discarded. With the iso_fortran_env module of Fortran 2003, unit -! may also equal OUTPUT_UNIT, unless the compiler sets that to -2. - -FUNCTION getboxlist(unit) RESULT(p) - ! Return boxlist associated with specified unit. If this list does not exist a new list is started. - INTEGER, INTENT(in) :: unit - TYPE(boxlist), POINTER :: p - p => firstboxlist - DO WHILE (ASSOCIATED(p)) - IF (p%unit == unit) RETURN - p => p%nextboxlist - END DO - ALLOCATE (p) - p%nextboxlist => firstboxlist ! put at head of list - p%unit = unit - firstboxlist => p -END FUNCTION getboxlist - -SUBROUTINE clearboxlist(unit) - ! Deallocate all boxes associated with unit - INTEGER, INTENT(in) :: unit - TYPE(boxnode), POINTER :: p, q - TYPE(boxlist), POINTER :: blp - blp => firstboxlist - DO WHILE (ASSOCIATED(blp)) - IF (blp%unit == unit) EXIT - blp => blp%nextboxlist - END DO - IF (.NOT. ASSOCIATED(blp)) RETURN - p => blp%firstbox - DO WHILE (ASSOCIATED(p)) - q => p - p => p%nextbox - DEALLOCATE (q%box) - DEALLOCATE (q) - END DO - IF (ASSOCIATED(firstboxlist, blp)) THEN - firstboxlist => blp%nextboxlist - END IF - DEALLOCATE (blp) -END SUBROUTINE clearboxlist - -SUBROUTINE newbox(unit, m, n, boxp) - ! Create a new box - CHARACTER, POINTER :: boxp(:, :) - INTEGER, INTENT(in) :: unit, m, n - TYPE(boxnode), POINTER :: p - TYPE(boxlist), POINTER :: blp - ALLOCATE (p) - ALLOCATE (p%box(n, m)) - blp => getboxlist(unit) - IF (.NOT. ASSOCIATED(blp%firstbox)) THEN - blp%firstbox => p - ELSE - blp%lastbox%nextbox => p - END IF - blp%lastbox => p - boxp => p%box - boxp = ' ' -END SUBROUTINE newbox - -FUNCTION tostr(a) RESULT(s) - ! Copy char array to string - CHARACTER, INTENT(in) :: a(:) - CHARACTER(SIZE(a)) s - INTEGER i - DO i = 1, SIZE(a) - s(i:i) = a(i) - END DO -END FUNCTION tostr - -SUBROUTINE dispboxlist(unit, sep) - ! Display the list of boxes associated with unit - INTEGER, INTENT(in) :: unit - TYPE(boxnode), POINTER :: pfirst, p - TYPE(boxlist), POINTER :: blp - INTEGER k, nlines, h, w, ns - CHARACTER(*), INTENT(in) :: sep - blp => getboxlist(unit) - pfirst => blp%firstbox - nlines = 0 - p => pfirst - DO WHILE (ASSOCIATED(p)) - nlines = MAX(nlines, SIZE(p%box, 2)) - p => p%nextbox - END DO - DO k = 1, nlines - p => pfirst - ns = 0 - DO WHILE (ASSOCIATED(p)) - h = SIZE(p%box, 2) - w = SIZE(p%box, 1) - IF (k <= h) THEN - SELECT CASE (unit) - CASE (-1) - CONTINUE - CASE (-2) - CALL putstr(sep(1:ns)//tostr(p%box(:, k))) - CASE (-3) - WRITE (*, '(2A)', advance='no') sep(1:ns), tostr(p%box(:, k)) - CASE default - WRITE (unit, '(2A)', advance='no') sep(1:ns), tostr(p%box(:, k)) - END SELECT - ELSE - SELECT CASE (unit) - CASE (-1) - CONTINUE - CASE (-2) - CALL putstr(sep(1:ns)//REPEAT(' ', w)) - CASE (-3) - WRITE (*, '(2A)', advance='no') sep(1:ns), REPEAT(' ', w) - CASE default - WRITE (unit, '(2A)', advance='no') sep(1:ns), REPEAT(' ', w) - END SELECT - END IF - p => p%nextbox - ns = LEN(sep) - END DO - CALL dispnewline(unit) - END DO - CALL clearboxlist(unit) -END SUBROUTINE dispboxlist - -SUBROUTINE dispnewline(unit) - INTEGER, INTENT(in) :: unit - SELECT CASE (unit) - CASE (-1); CONTINUE - CASE (-2); CALL putnl - CASE (-3); WRITE (*, *) - CASE default; WRITE (unit, *) - END SELECT -END SUBROUTINE dispnewline - -! subroutine print_boxes -! ! Print info on all boxes (used for debug purposes) -! integer :: k -! type(boxlist), pointer :: bl -! type(boxnode), pointer :: p -! bl => firstboxlist -! write(*,'("BOXES:")') -! do while (associated(bl)) -! write(*,'("UNIT=",SS,I0,":")') bl%unit -! p => bl%firstbox -! k = 1 -! do while(associated(p)) -! write(*,'(" box ",SS,I0,", size=(",I0,",",I0,")")') k, shape(p%box) -! k = k+1 -! p => p%nextbox -! enddo -! bl => bl%nextboxlist -! enddo -! end subroutine print_boxes - -! ******************************** END OF BOX-PACKAGE ******************************* - -END MODULE DISPMODULE_UTIL diff --git a/src/modules/Display/src/disp/putstrmodule.F90 b/src/modules/Display/src/disp/putstrmodule.F90 deleted file mode 100644 index 62823a946..000000000 --- a/src/modules/Display/src/disp/putstrmodule.F90 +++ /dev/null @@ -1,25 +0,0 @@ -MODULE PUTSTRMODULE ! DUMMY VERSION - ! An auxilliary module that accompanies DISPMODULE. This module contains dummy versions of the - ! subroutines putstr and putnl that do nothing. It is needed to avoid an "undefined symbol" link - ! error for these. In addition it defines the named constant (or parameter) DEFAULT_UNIT = -3, - ! which makes the asterisk unit (usually the screen) the default to display on. - ! - ! The purpose of having this module is to make displaying possible in situations where ordinary - ! print- and write-statements do not work. Then this module should be replaced by one defining - ! functional versions of putstr and putnl. An example is given by the commented out PUTSTRMODULE - ! for Matlab mex files below. - ! - integer, parameter :: DEFAULT_UNIT = -3 - ! -CONTAINS - subroutine putstr(s) - character(*), intent(in) :: s - integer ldummy, ldummy1 ! these variables exist to avoid unused variable warnings - ldummy = len(s) - ldummy1 = ldummy - ldummy = ldummy1 - end subroutine putstr - - subroutine putnl() - end subroutine putnl -END MODULE PUTSTRMODULE diff --git a/src/modules/ElasticNitscheMatrix/CMakeLists.txt b/src/modules/ElasticNitscheMatrix/CMakeLists.txt deleted file mode 100644 index 93a59d460..000000000 --- a/src/modules/ElasticNitscheMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ElasticNitscheMatrix_Method.F90 -) diff --git a/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 b/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 deleted file mode 100644 index 124148100..000000000 --- a/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 +++ /dev/null @@ -1,552 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE ElasticNitscheMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: ElasticNitscheMatrix -PUBLIC :: ElasticNitscheMatrixNormal -PUBLIC :: ElasticNitscheMatrixTangent - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1a(test, trial, lambda, mu, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - CLASS(FEVariable_), INTENT(IN) :: lambda - CLASS(FEVariable_), INTENT(IN) :: mu - CLASS(FEVariable_), INTENT(IN) :: evec - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1a -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1a -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1b(test, trial, lambda, mu, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - CLASS(FEVariable_), INTENT(IN) :: evec - REAL(DFP), INTENT(IN) :: lambda, mu - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1b -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1b -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1c(test, trial, lambda, mu, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - CLASS(FEVariable_), INTENT(IN) :: evec - REAL(DFP), INTENT(IN) :: lambda(:) - !! quadrature values - REAL(DFP), INTENT(IN) :: mu(:) - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1c -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1c -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1d(test, trial, lambda, mu, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: evec(:, :) - !! vector at quadrature value - REAL(DFP), INTENT(IN) :: lambda(:) - !! quadrature values - REAL(DFP), INTENT(IN) :: mu(:) - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1d -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1d -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1e(test, trial, lambda, mu, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: evec(:, :) - !! vector at quadrature value - REAL(DFP), INTENT(IN) :: lambda, mu - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1e -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1e -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1f(test, trial, lambda, mu, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: evec(:) - !! constant vector - REAL(DFP), INTENT(IN) :: lambda, mu - !! constant lambda and mu - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1f -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1f -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1g(test, trial, lambda, mu, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: evec(:) - !! vector at quadrature value - REAL(DFP), INTENT(IN) :: lambda(:) - !! quadrature values - REAL(DFP), INTENT(IN) :: mu(:) - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1g -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1g -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1h(test, trial, lambda, mu, dim) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - INTEGER(I4B), INTENT(IN) :: dim - !! evec represent e1 , e2, e3 (1,2,3) - REAL(DFP), INTENT(IN) :: lambda(:) - !! quadrature values - REAL(DFP), INTENT(IN) :: mu(:) - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1h -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1h -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1i(test, trial, lambda, mu, dim) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - INTEGER(I4B), INTENT(IN) :: dim - !! evec represent e1 , e2, e3 (1,2,3) - REAL(DFP), INTENT(IN) :: lambda - !! quadrature values - REAL(DFP), INTENT(IN) :: mu - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1i -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1i -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix1j(test, trial, lambda, mu, dim) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - INTEGER(I4B), INTENT(IN) :: dim - !! evec represent e1 , e2, e3 (1,2,3) - !! dim=4 normal direction - !! dim=5 tangent direction - TYPE(FEVariable_), INTENT(IN) :: lambda - !! quadrature values - TYPE(FEVariable_), INTENT(IN) :: mu - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix1j -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix1j -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ElasticNitscheMatrix2a(test, trial, lambda, mu, isNoSlip)& - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: lambda, mu - LOGICAL(LGT), INTENT(IN) :: isNoSlip - !! this is a dummy variable, It is used only to create distinct interface - !! It is not used in the routine - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix2a -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix2a -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix2b(test, trial, lambda, mu, isNoSlip)& - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - CLASS(FEVariable_), INTENT(IN) :: lambda, mu - LOGICAL(LGT), INTENT(IN) :: isNoSlip - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix2b -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix2b -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3a(test, trial, alpha, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - CLASS(FEVariable_), INTENT(IN) :: alpha - CLASS(FEVariable_), INTENT(IN) :: evec - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3a -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3a -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3b(test, trial, alpha, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - CLASS(FEVariable_), INTENT(IN) :: evec - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3b -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3b -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3c(test, trial, alpha, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: alpha(:) - REAL(DFP), INTENT(IN) :: evec(:, :) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3c -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3c -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3d(test, trial, alpha, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: evec(:, :) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3d -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3d -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3e(test, trial, alpha, evec) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: evec(:) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3e -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3e -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3f(test, trial, alpha, dim) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - CLASS(FEVariable_), INTENT(IN) :: alpha - INTEGER(I4B), INTENT(IN) :: dim - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3f -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3f -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3g(test, trial, alpha, dim) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: alpha - INTEGER(I4B), INTENT(IN) :: dim - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3g -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3g -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrix3h(test, trial, alpha, dim) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: alpha(:) - INTEGER(I4B), INTENT(IN) :: dim - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrix3h -END INTERFACE - -INTERFACE ElasticNitscheMatrix - MODULE PROCEDURE ElasticNitscheMatrix3h -END INTERFACE ElasticNitscheMatrix - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrixNormal@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrixNormal1a(test, trial, lambda, mu) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL(DFP), INTENT(IN) :: lambda(:) - !! quadrature values - REAL(DFP), INTENT(IN) :: mu(:) - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrixNormal1a -END INTERFACE - -INTERFACE ElasticNitscheMatrixNormal - MODULE PROCEDURE ElasticNitscheMatrixNormal1a -END INTERFACE ElasticNitscheMatrixNormal - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrixNormal@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrixNormal1b(test, trial, lambda, mu) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL(DFP), INTENT(IN) :: lambda - !! quadrature values - REAL(DFP), INTENT(IN) :: mu - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrixNormal1b -END INTERFACE - -INTERFACE ElasticNitscheMatrixNormal - MODULE PROCEDURE ElasticNitscheMatrixNormal1b -END INTERFACE ElasticNitscheMatrixNormal - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrixNormal@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrixNormal1c(test, trial, lambda, mu) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: lambda - !! quadrature values - TYPE(FEVariable_), INTENT(IN) :: mu - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrixNormal1c -END INTERFACE - -INTERFACE ElasticNitscheMatrixNormal - MODULE PROCEDURE ElasticNitscheMatrixNormal1c -END INTERFACE ElasticNitscheMatrixNormal - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrixTangent@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrixTangent1a(test, trial, mu, & - & jacobian) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL(DFP), INTENT(IN) :: mu(:) - !! quadrature values - REAL(DFP), INTENT(IN) :: jacobian(:, :, :) - !! jacobian - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrixTangent1a -END INTERFACE - -INTERFACE ElasticNitscheMatrixTangent - MODULE PROCEDURE ElasticNitscheMatrixTangent1a -END INTERFACE ElasticNitscheMatrixTangent - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrixTangent@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrixTangent1b(test, trial, mu) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL(DFP), INTENT(IN) :: mu - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrixTangent1b -END INTERFACE - -INTERFACE ElasticNitscheMatrixTangent - MODULE PROCEDURE ElasticNitscheMatrixTangent1b -END INTERFACE ElasticNitscheMatrixTangent - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrixTangent@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ElasticNitscheMatrixTangent1c(test, trial, mu) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: mu - !! quadrature values - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ElasticNitscheMatrixTangent1c -END INTERFACE - -INTERFACE ElasticNitscheMatrixTangent - MODULE PROCEDURE ElasticNitscheMatrixTangent1c -END INTERFACE ElasticNitscheMatrixTangent - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ElasticNitscheMatrix_Method diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt deleted file mode 100644 index 39fa1ba47..000000000 --- a/src/modules/ElemshapeData/CMakeLists.txt +++ /dev/null @@ -1,43 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ElemshapeData_Method.F90 - ${src_path}/ElemshapeData_ConstructorMethods.F90 - ${src_path}/ElemshapeData_DivergenceMethods.F90 - ${src_path}/ElemshapeData_GradientMethods.F90 - ${src_path}/ElemshapeData_GetMethods.F90 - - ${src_path}/ElemshapeData_H1Methods.F90 - ${src_path}/ElemshapeData_DGMethods.F90 - ${src_path}/ElemshapeData_HDivMethods.F90 - ${src_path}/ElemshapeData_HCurlMethods.F90 - - ${src_path}/ElemshapeData_HminHmaxMethods.F90 - ${src_path}/ElemshapeData_HRGNParamMethods.F90 - ${src_path}/ElemshapeData_HRQIParamMethods.F90 - ${src_path}/ElemshapeData_InterpolMethods.F90 - ${src_path}/ElemshapeData_IOMethods.F90 - ${src_path}/ElemshapeData_LocalDivergenceMethods.F90 - ${src_path}/ElemshapeData_LocalGradientMethods.F90 - ${src_path}/ElemshapeData_ProjectionMethods.F90 - ${src_path}/ElemshapeData_SetMethods.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods.F90 - ${src_path}/ElemshapeData_UnitNormalMethods.F90 -) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 deleted file mode 100644 index e740cd001..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 +++ /dev/null @@ -1,224 +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 ElemshapeData_ConstructorMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Initiate -PUBLIC :: DEALLOCATE -PUBLIC :: ALLOCATE -PUBLIC :: ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Allocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Allocates the memory for various matrices in elemsd -! -!# Introduction -! -!- This subroutine allocates the memory for various matrices in the obj. -!- This subroutine belongs to the generic interface called `Allocate()`. - -INTERFACE ALLOCATE - MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! object to be returned - INTEGER(I4B), INTENT(IN) :: nsd - !! spatial dimension - INTEGER(I4B), INTENT(IN) :: xidim - !! xidimension - INTEGER(I4B), INTENT(IN) :: nns - !! number of nodes in element - INTEGER(I4B), INTENT(IN) :: nips - !! number of integration points - END SUBROUTINE elemsd_Allocate -END INTERFACE ALLOCATE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the element shapefunction data - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate1(obj, quad, refelem, continuityType, & - & interpolType) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! ElemshapeData to be formed - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! Quadrature points - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! reference element - CHARACTER(*), INTENT(IN) :: continuityType - !! - continuity/ conformity of shape function (basis functions) - CHARACTER(*), INTENT(IN) :: interpolType - !! interpolation/polynomial family for basis functions - END SUBROUTINE elemsd_initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Copy data from an instance of elemshapedata to another instance - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate2(obj1, obj2) - TYPE(ElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(ElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate2 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Initiate an instance of ElemshapeData from STElemshapeData -! -!# Introduction -! -! This subroutine initiates an instance of ElemshapeData by copying data -! from an instance of STElemshapeData. - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate3(obj1, obj2) - TYPE(ElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(STElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate3 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: This routine initiates an instance of STElemshapeData -! -!# Introduction -! -! This routine initiate an instance of STElemshapeData by copying data -! from the instance of ElemshapeData - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate4(obj1, obj2) - TYPE(STElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(ElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate4 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate4 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Initiate an instance of STElemshapeData from instance of same class -! -!# Introduction -! This routine initiates an instance of STElemshapeData by copying data -! from the instance of STElemshapeData. - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate5(obj1, obj2) - TYPE(STElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(STElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate5 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate5 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Initiate time shape function data in [[stelemshapedata_]] -! -!# Introduction -! -! - This subroutine initiates the shape-function data related to time -! domain in the instance of [[stelemshapedata_]]. -! - User should provide an instance of [[Elemshapedata_]] elemsd, -! - The `elemsd`, actually contains the information of -! the shape-function in the time domain -! - The shape-function data in the time domain is -! - $T$ -! - $\frac{dT}{d\theta}$ -! - ... -!@note -! This routine uses `elemsd` to set `obj%T`, `obj%dTdTheta`, `obj%Jt`, -! `obj%Wt`, `obj%Theta`. -!@endnote -! - -INTERFACE Initiate - MODULE PURE SUBROUTINE stsd_initiate(obj, elemsd) - TYPE(STElemshapeData_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - TYPE(ElemshapeData_), INTENT(IN) :: elemsd - !! It has information about location shape function for time element - END SUBROUTINE stsd_initiate -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Deallocates the data stored inside [[elemshapedata_]] -! -!# Introduction -! -! This routine deallocates the data stored inside [[elemshapedata_]]. This -! routine belongs to `Allocate()` -! - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE elemsd_Deallocate(obj) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - END SUBROUTINE elemsd_Deallocate -END INTERFACE DEALLOCATE - -END MODULE ElemshapeData_ConstructorMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 deleted file mode 100644 index f212f608a..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.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 -! -module ElemshapeData_DGHermitMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -public :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGHermit -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. -! - -INTERFACE - MODULE PURE SUBROUTINE DG_Hermit(obj, quad, refElem, & - & continuityType, interpolType) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refElem - CLASS(DG_), INTENT(IN) :: continuityType - CLASS(HermitInterpolation_), INTENT(IN) :: interpolType - END SUBROUTINE DG_Hermit -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE DG_Hermit -END INTERFACE Initiate - -end module ElemshapeData_DGHermitMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 deleted file mode 100644 index 8dcbc4c20..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.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 -! -module ElemshapeData_DGHierarchyMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -public :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGHierarchy -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. -! - -INTERFACE - MODULE PURE SUBROUTINE DG_Hierarchy(obj, quad, refElem, & - & continuityType, interpolType) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refElem - CLASS(DG_), INTENT(IN) :: continuityType - CLASS(HierarchyInterpolation_), INTENT(IN) :: interpolType - END SUBROUTINE DG_Hierarchy -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE DG_Hierarchy -END INTERFACE Initiate - -end module ElemshapeData_DGHierarchyMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 deleted file mode 100644 index 0d05a4908..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.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 -! -module ElemshapeData_DGLagrangeMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -public :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGLagrange -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. -! - -INTERFACE - MODULE PURE SUBROUTINE DG_Lagrange(obj, quad, refElem, & - & continuityType, interpolType) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refElem - CLASS(DG_), INTENT(IN) :: continuityType - CLASS(LagrangeInterpolation_), INTENT(IN) :: interpolType - END SUBROUTINE DG_Lagrange -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE DG_Lagrange -END INTERFACE Initiate - -end module ElemshapeData_DGLagrangeMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 deleted file mode 100644 index 58e4a52ee..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 +++ /dev/null @@ -1,252 +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 ElemshapeData_DGMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-16 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE DG_Lagrange1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & coeff, & - & firstCall, & - & alpha, & - & beta, & - & lambda) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refelem - CLASS(DG_), INTENT(IN) :: baseContinuity - CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation point type - !! Default value is Equidistance - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function types - !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - END SUBROUTINE DG_Lagrange1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGHierarchy -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE DG_Hierarchy1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(DG_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - !! This argument is not needed - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - !! This argument is not needed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - !! This argument is not needed - END SUBROUTINE DG_Hierarchy1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGOrthogonal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE DG_Orthogonal1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(DG_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE DG_Orthogonal1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGHermit -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE DG_Hermit1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(DG_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE DG_Hermit1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGSerendipity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE DG_Serendipity1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(DG_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE DG_Serendipity1 -END INTERFACE Initiate - -END MODULE ElemshapeData_DGMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 deleted file mode 100644 index 30b833a50..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 +++ /dev/null @@ -1,54 +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 ElemshapeData_DGSerendipityMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -public :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@DGSerendipity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. -! - -INTERFACE - MODULE PURE SUBROUTINE DG_Serendipity(obj, quad, refElem, & - & continuityType, interpolType) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refElem - CLASS(DG_), INTENT(IN) :: continuityType - CLASS(SerendipityInterpolation_), INTENT(IN) :: interpolType - END SUBROUTINE DG_Serendipity -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE DG_Serendipity -END INTERFACE Initiate - -end module ElemshapeData_DGSerendipityMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 deleted file mode 100644 index a22cb4207..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 +++ /dev/null @@ -1,245 +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 ElemshapeData_DivergenceMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: getDivergence -PUBLIC :: Divergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_1(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :) - !! space nodal values of vector in `xiJ` format - !! row index: space component - !! col index: node number - END SUBROUTINE elemsd_getDivergence_1 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_1 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence of a vector -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_2(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE elemsd_getDivergence_2 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_2 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence of a vector -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_3(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! Divergence of vector at integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! vector finite-element variable - END SUBROUTINE elemsd_getDivergence_3 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_3 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence of a matrix - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_4(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getDivergence_4 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_4 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_5(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal values of matrix in (i,j,I,a) format - END SUBROUTINE elemsd_getDivergence_5 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_5 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_6(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Divergence at integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space/space-time nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getDivergence_6 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_6 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_7(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! Divergence of scalar/vector/matrix at space integration points - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE elemsd_getDivergence_7 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_7 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Divergence - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_8(obj, lg, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! Divergence of scalar/vector/matrix at space-time - !! integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space time nodal values of scalar/vector/matrix - END SUBROUTINE elemsd_getDivergence_8 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_8 -END INTERFACE getDivergence - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_Divergence_1(obj, val) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_Divergence_1 -END INTERFACE - -INTERFACE Divergence - MODULE PROCEDURE elemsd_Divergence_1 -END INTERFACE Divergence - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_Divergence_2(obj, val) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_Divergence_2 -END INTERFACE - -INTERFACE Divergence - MODULE PROCEDURE elemsd_Divergence_2 -END INTERFACE Divergence - -end module ElemshapeData_DivergenceMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 deleted file mode 100644 index 084e82e6a..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 +++ /dev/null @@ -1,94 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -module ElemshapeData_GetMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: getNormal - -!---------------------------------------------------------------------------- -! GetNormal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Jan 2022 -! update: 28 Jan 2022 -! summary: This routine returns the normal vector stored in [[ElemShapeData_]] - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getNormal_1(obj, normal, nsd) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: normal(:, :) - !! normal(1:3, 1:nip) = obj%normal - INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd - END SUBROUTINE elemsd_getNormal_1 -END INTERFACE - -INTERFACE getNormal - MODULE PROCEDURE elemsd_getNormal_1 -END INTERFACE getNormal - -!---------------------------------------------------------------------------- -! GetNormal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Jan 2022 -! update: 28 Jan 2022 -! summary: This routine returns the normal vector stored in [[ElemShapeData_]] - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getNormal_2(obj, normal, nsd) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: normal - !! normal(1:3, 1:nip) = obj%normal - !! Quadrature, Vector, Space - INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd - END SUBROUTINE elemsd_getNormal_2 -END INTERFACE - -INTERFACE getNormal - MODULE PROCEDURE elemsd_getNormal_2 -END INTERFACE getNormal - -!---------------------------------------------------------------------------- -! GetNormal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Jan 2022 -! update: 28 Jan 2022 -! summary: This routine returns the normal vector stored in [[ElemShapeData_]] - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getNormal_3(obj, normal, nsd) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(INOUT) :: normal - !! normal(1:3, 1:nip) = obj%normal - !! Quadrature, Vector, SpaceTime - INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd - END SUBROUTINE elemsd_getNormal_3 -END INTERFACE - -INTERFACE getNormal - MODULE PROCEDURE elemsd_getNormal_3 -END INTERFACE getNormal - -end module ElemshapeData_GetMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 deleted file mode 100644 index dce3a5ba4..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 +++ /dev/null @@ -1,323 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -module ElemshapeData_GradientMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: getSpatialGradient -PUBLIC :: SpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of scalar - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_1(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Spatial gradient of scalar - REAL(DFP), INTENT(IN) :: val(:) - !! Nodal values of scalar - END SUBROUTINE elemsd_getSpatialGradient_1 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_1 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_2(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) - !! spatial gradient of vector at integration points - REAL(DFP), INTENT(IN) :: val(:, :) - !! nodal values of vector in `xiJ` format - END SUBROUTINE elemsd_getSpatialGradient_2 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_2 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of scalar - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_3(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Spatial gradient of scalar - REAL(DFP), INTENT(IN) :: val(:, :) - !! space-time Nodal values of scalar - END SUBROUTINE elemsd_getSpatialGradient_3 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_3 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of scalar -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_4(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) - !! spatial gradient of vector at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE elemsd_getSpatialGradient_4 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_4 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of scalar - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_5(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Spatial gradient of scalar - TYPE(FEVariable_), INTENT(IN) :: val - !! Nodal values of scalar - END SUBROUTINE elemsd_getSpatialGradient_5 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_5 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of scalar -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_6(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) - !! spatial gradient of vector at integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE elemsd_getSpatialGradient_6 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_6 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of a matrix - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_7(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) - !! spatial gradient at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getSpatialGradient_7 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_7 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of a matrix - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_8(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) - !! spatial gradient at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal values of matrix in (i,j,I,a) format - END SUBROUTINE elemsd_getSpatialGradient_8 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_8 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_9(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) - !! spatial gradient at integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getSpatialGradient_9 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_9 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient -! -!# Introduction -! -! - This routine returns spatial gradient in [[FEVariable_]] -! the input is also a [[FEVariable_]]. -! - This routine can be considered as a master routine - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_10(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! spatial gradient of scalar/vector/matrix at space integration points - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE elemsd_getSpatialGradient_10 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_10 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! getSpatialGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the spatial gradient -! -!# Introduction -! -! - This routine returns spatial gradient in [[FEVariable_]] -! the input is also a [[FEVariable_]]. -! - This routine can be considered as a master routine - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getSpatialGradient_11(obj, lg, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! spatial gradient of scalar/vector/matrix at space-time - !! integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space time nodal values of scalar/vector/matrix - END SUBROUTINE elemsd_getSpatialGradient_11 -END INTERFACE - -INTERFACE getSpatialGradient - MODULE PROCEDURE elemsd_getSpatialGradient_11 -END INTERFACE getSpatialGradient - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_SpatialGradient_1(obj, val) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_SpatialGradient_1 -END INTERFACE - -INTERFACE SpatialGradient - MODULE PROCEDURE elemsd_SpatialGradient_1 -END INTERFACE SpatialGradient - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_SpatialGradient_2(obj, val) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_SpatialGradient_2 -END INTERFACE - -INTERFACE SpatialGradient - MODULE PROCEDURE elemsd_SpatialGradient_2 -END INTERFACE SpatialGradient - -end module ElemshapeData_GradientMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 deleted file mode 100644 index 2af6c22b6..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 +++ /dev/null @@ -1,252 +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 ElemshapeData_H1Methods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-16 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE H1_Lagrange1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & coeff, & - & firstCall, & - & alpha, & - & beta, & - & lambda) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refelem - CLASS(H1_), INTENT(IN) :: baseContinuity - CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation point type - !! Default value is Equidistance - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function types - !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - END SUBROUTINE H1_Lagrange1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@H1Hierarchy -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE H1_Hierarchy1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(H1_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - !! This argument is not needed - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - !! This argument is not needed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - !! This argument is not needed - END SUBROUTINE H1_Hierarchy1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@H1Orthogonal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE H1_Orthogonal1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(H1_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE H1_Orthogonal1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@H1Hermit -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE H1_Hermit1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(H1_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE H1_Hermit1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@H1Serendipity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE H1_Serendipity1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(H1_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE H1_Serendipity1 -END INTERFACE Initiate - -END MODULE ElemshapeData_H1Methods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 deleted file mode 100644 index dadbfeeaa..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 +++ /dev/null @@ -1,253 +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 ElemshapeData_HCurlMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-16 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE HCurl_Lagrange1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & coeff, & - & firstCall, & - & alpha, & - & beta, & - & lambda) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refelem - CLASS(HCurl_), INTENT(IN) :: baseContinuity - CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation point type - !! Default value is Equidistance - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function types - !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - END SUBROUTINE HCurl_Lagrange1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@HCurlHierarchy -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE HCurl_Hierarchy1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HCurl_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - !! This argument is not needed - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - !! This argument is not needed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - !! This argument is not needed - END SUBROUTINE HCurl_Hierarchy1 -END INTERFACE Initiate - - -!---------------------------------------------------------------------------- -! Initiate@HCurlOrthogonal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE HCurl_Orthogonal1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HCurl_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE HCurl_Orthogonal1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@HCurlHermit -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE HCurl_Hermit1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HCurl_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE HCurl_Hermit1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@HCurlSerendipity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE HCurl_Serendipity1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HCurl_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE HCurl_Serendipity1 -END INTERFACE Initiate - -END MODULE ElemshapeData_HCurlMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 deleted file mode 100644 index 5aaa909c9..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 +++ /dev/null @@ -1,253 +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 ElemshapeData_HDivMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-16 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE HDiv_Lagrange1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & coeff, & - & firstCall, & - & alpha, & - & beta, & - & lambda) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refelem - CLASS(HDiv_), INTENT(IN) :: baseContinuity - CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation point type - !! Default value is Equidistance - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function types - !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - END SUBROUTINE HDiv_Lagrange1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@HDivHierarchy -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE HDiv_Hierarchy1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HDiv_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - !! This argument is not needed - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - !! This argument is not needed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - !! This argument is not needed - END SUBROUTINE HDiv_Hierarchy1 -END INTERFACE Initiate - - -!---------------------------------------------------------------------------- -! Initiate@HDivOrthogonal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-09-02 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE HDiv_Orthogonal1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HDiv_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE HDiv_Orthogonal1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@HDivHermit -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data -! -!# Introduction -! -! This routine initiates the shape function related data inside the element. - -INTERFACE Initiate - MODULE SUBROUTINE HDiv_Hermit1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HDiv_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE HDiv_Hermit1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@HDivSerendipity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate the shape data - -INTERFACE Initiate - MODULE SUBROUTINE HDiv_Serendipity1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - !! Element shape data - CLASS(QuadraturePoint_), INTENT(IN) :: quad - !! quadrature point type - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Reference element type - CLASS(HDiv_), INTENT(IN) :: baseContinuity - !! Base continuity type - CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation - !! Base Interpolation type - INTEGER(I4B), INTENT(IN) :: order - !! Order of polynomials - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation type - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function type - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! alpha and beta are Jacobi polynomial param - !! lambda is Ultraspherical polynomial param - END SUBROUTINE HDiv_Serendipity1 -END INTERFACE Initiate - -END MODULE ElemshapeData_HDivMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 deleted file mode 100644 index 55e093c20..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 +++ /dev/null @@ -1,141 +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 ElemshapeData_HRGNParamMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetHRGNParam - -!---------------------------------------------------------------------------- -! GetHRGNParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRGN param -! -!# Introduction -! -! In this method `h` is oneD real-vector defined at quadrature points - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRGNParam1(obj, h, val, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) - !! h is a scalar field and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetHRGNParam1 -END INTERFACE - -INTERFACE GetHRGNParam - MODULE PROCEDURE elemsd_GetHRGNParam1 -END INTERFACE GetHRGNParam - -!---------------------------------------------------------------------------- -! GetHRGNParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRGN param -! -!# Introduction -! -!- This routine is same as `elemsd_GetHRGNParam1` -!- Here, `h` is an [[FEVariable_]] (scalar and quadVariable) -!- This routine calls `elemsd_GetHRGNParam1` and then convert -!- the result in to [[FEVariable_]]. - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRGNParam2(obj, h, val, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: h - !! h is a scalar, and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetHRGNParam2 -END INTERFACE - -INTERFACE GetHRGNParam - MODULE PROCEDURE elemsd_GetHRGNParam2 -END INTERFACE GetHRGNParam - -!---------------------------------------------------------------------------- -! GetHRGNParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRGN param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRGNParam3(obj, h, val, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:, :) - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! it can be a scalar, defined on space or space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - END SUBROUTINE elemsd_GetHRGNParam3 -END INTERFACE - -INTERFACE GetHRGNParam - MODULE PROCEDURE elemsd_GetHRGNParam3 -END INTERFACE GetHRGNParam - -!---------------------------------------------------------------------------- -! GetHRGNParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRGN param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRGNParam4(obj, h, val, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - TYPE(FEVariable_), INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! it can be a scalar, defined on space or space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - END SUBROUTINE elemsd_GetHRGNParam4 -END INTERFACE - -INTERFACE GetHRGNParam - MODULE PROCEDURE elemsd_GetHRGNParam4 -END INTERFACE GetHRGNParam - -end module ElemshapeData_HRGNParamMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 deleted file mode 100644 index c3a494971..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 +++ /dev/null @@ -1,147 +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 ElemshapeData_HRQIParamMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetHRQIParam - -!---------------------------------------------------------------------------- -! GetHRQIParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRQIParam1(obj, h, val, hmax, hmin, & - & r, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) - !! h is a scalar, and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmax(:) - !! maximum directional length, size(hmax) = nips - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmin(:) - !! minimum directional length, size(hmin) = nips - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: r(:, :) - !! unit normal, shape(r) = (nsd, nips) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetHRQIParam1 -END INTERFACE - -INTERFACE GetHRQIParam - MODULE PROCEDURE elemsd_GetHRQIParam1 -END INTERFACE GetHRQIParam - -!---------------------------------------------------------------------------- -! GetHRQIParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRQIParam2(obj, h, val, hmax, & - & hmin, r, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: h - !! h is a scalar, and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax, hmin, r - !! h is a scalar, and defined on quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetHRQIParam2 -END INTERFACE - -INTERFACE GetHRQIParam - MODULE PROCEDURE elemsd_GetHRQIParam2 -END INTERFACE GetHRQIParam - -!---------------------------------------------------------------------------- -! GetHRQIParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRQIParam3(obj, h, val, hmax, & - & hmin, r, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:, :) - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! it can be a scalar, defined on space or space-time quadrature points - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmax(:, :) - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmin(:, :) - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: r(:, :, :) - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - END SUBROUTINE elemsd_GetHRQIParam3 -END INTERFACE - -INTERFACE GetHRQIParam - MODULE PROCEDURE elemsd_GetHRQIParam3 -END INTERFACE GetHRQIParam - -!---------------------------------------------------------------------------- -! GetHRQIParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHRQIParam4(obj, h, val, hmax, & - & hmin, r, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - TYPE(FEVariable_), INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! it can be a scalar, defined on space or space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax, hmin, r - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - END SUBROUTINE elemsd_GetHRQIParam4 -END INTERFACE - -INTERFACE GetHRQIParam - MODULE PROCEDURE elemsd_GetHRQIParam4 -END INTERFACE GetHRQIParam - -end module ElemshapeData_HRQIParamMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 deleted file mode 100644 index a786e31b2..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 +++ /dev/null @@ -1,228 +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 ElemshapeData_HminHmaxMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns Hmin and Hmax - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHminHmax1(obj, hmax, hmin) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:) - !! maximum directional length, size(hmax) = nips - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:) - !! minimum directional length, size(hmin) = nips - END SUBROUTINE elemsd_GetHminHmax1 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax1 -END INTERFACE GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns Hmin and Hmax - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHminHmax2(obj, hmax, hmin, G) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:) - !! maximum directional length, size(hmax) = nips - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:) - !! minimum directional length, size(hmin) = nips - REAL(DFP), INTENT(IN) :: G(:, :, :) - !! shape(G) = [nsd, nsd, nips] - END SUBROUTINE elemsd_GetHminHmax2 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax2 -END INTERFACE GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns Hmin and Hmax - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHminHmax3(obj, hmax, hmin) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: hmax - !! maximum directional length, size(hmax) = nips - TYPE(FEVariable_), INTENT(INOUT) :: hmin - !! minimum directional length, size(hmin) = nips - END SUBROUTINE elemsd_GetHminHmax3 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax3 -END INTERFACE GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns Hmin and Hmax - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetHminHmax6(obj, hmax, hmin, G) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: hmax - !! maximum directional length, size(hmax) = nips - TYPE(FEVariable_), INTENT(INOUT) :: hmin - !! minimum directional length, size(hmin) = nips - REAL(DFP), INTENT(IN) :: G(:, :, :) - !! shape=[nsd, nsd, nips] - END SUBROUTINE elemsd_GetHminHmax6 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax6 -END INTERFACE GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE SUBROUTINE elemsd_GetHminHmax4(obj, hmax, hmin) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:, :) - !! shape(hmax) = [nips, nipt] - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:, :) - !! shape(hmin) = [nips, nipt] - END SUBROUTINE elemsd_GetHminHmax4 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax4 -END INTERFACE GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE SUBROUTINE elemsd_GetHminHmax7(obj, hmax, hmin, G) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:, :) - !! shape(hmax) = [nips, nipt] - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:, :) - !! shape(hmin) = [nips, nipt] - REAL(DFP), INTENT(IN) :: G(:, :, :, :) - !! shape = [nsd, nsd, nips, nipt] - END SUBROUTINE elemsd_GetHminHmax7 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax7 -END INTERFACE GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE SUBROUTINE elemsd_GetHminHmax5(obj, hmax, hmin) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - !! it can be a scalar, defined on space or space-time quadrature points - TYPE(FEVariable_), INTENT(INOUT) :: hmax, hmin - !! SpaceTime, Quadrature - END SUBROUTINE elemsd_GetHminHmax5 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax5 -END INTERFACE GetHminHmax - -!---------------------------------------------------------------------------- -! GetHminHmax@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the HRQI param - -INTERFACE - MODULE SUBROUTINE elemsd_GetHminHmax8(obj, hmax, hmin, G) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! Spacetime shape function data, obj(ipt) denotes data at - !! ipt quadrature point in time domain - !! it can be a scalar, defined on space or space-time quadrature points - TYPE(FEVariable_), INTENT(INOUT) :: hmax, hmin - !! SpaceTime, Quadrature - REAL(DFP), INTENT(IN) :: G(:, :, :, :) - !! shape = [nsd, nsd, nips, nipt] - END SUBROUTINE elemsd_GetHminHmax8 -END INTERFACE - -INTERFACE GetHminHmax - MODULE PROCEDURE elemsd_GetHminHmax8 -END INTERFACE GetHminHmax - -end module ElemshapeData_HminHmaxMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 deleted file mode 100644 index 3ddeaf0f5..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 +++ /dev/null @@ -1,92 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE ElemshapeData_IOMethods -USE BaseType -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE - -PUBLIC :: Display -PUBLIC :: ElemshapeData_MdEncode -PUBLIC :: MdEncode -PUBLIC :: ElemshapeData_ReactEncode - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] - -INTERFACE Display - MODULE SUBROUTINE elemsd_display_1(obj, msg, unitNo) - CLASS(ElemshapeData_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - END SUBROUTINE elemsd_display_1 -END INTERFACE Display - -!---------------------------------------------------------------------------- -! ElemshapeData_MdEncode@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] - -INTERFACE MdEncode - MODULE FUNCTION ElemshapeData_MdEncode(obj) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(String) :: ans - END FUNCTION ElemshapeData_MdEncode -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! ElemshapeData_ReactEncode@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] - -INTERFACE - MODULE FUNCTION ElemshapeData_ReactEncode(obj) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(String) :: ans - END FUNCTION ElemshapeData_ReactEncode -END INTERFACE - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] - -INTERFACE Display - MODULE SUBROUTINE elemsd_display_2(obj, msg, unitNo) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo - END SUBROUTINE elemsd_display_2 -END INTERFACE Display - -END MODULE ElemshapeData_IOMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 deleted file mode 100644 index 1074afee6..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ /dev/null @@ -1,695 +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 -! -! -! This file contains the interpolation methods interfaces\ - -module ElemshapeData_InterpolMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -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 - MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) - !! Interpolation value of of scalar - REAL(DFP), INTENT(IN) :: val(:) - !! spatial nodal values of scalar - END SUBROUTINE scalar_getInterpolation_1 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_1 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolations of scalar nodal values -! -!# Introduction -! -! This subroutine performs interpolation of a scalar from its space-time nodal -! values. -! -! $$u=u^{a}_{I}N^{I}T_{a}$$ -! -! The resultant represents the interpolation value of `val` at -! spatial-quadrature points - -INTERFACE - MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:) - !! Interpolation of scalar - REAL(DFP), INTENT(IN) :: val(:, :) - !! space-time nodal values of scalar - END SUBROUTINE scalar_getInterpolation_2 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_2 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolations of scalar nodal values -! -!# 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 - MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) - !! space-time Interpolation of scalar - REAL(DFP), INTENT(IN) :: val(:, :) - !! space-time nodal values of scalar - END SUBROUTINE scalar_getInterpolation_3 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_3 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: returns the interpolation of scalar FEVariable -! -!# Introduction -! -! Returns the interpolation of scalar variable -! The scalar variable can be+ -! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values -! -!@note -!This routine calls [[Interpolation]] function from the same module. -!@endnote - -INTERFACE - 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 - -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_4 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolations of scalar FEVariable -! -!# Introduction -! -! This subroutine performs interpolation of a scalar [[FEVariable_]] -! The FE Variable can be a -! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values -! -! $$u=u^{a}_{I}N^{I}T_{a}$$ -! -! The resultant represents the interpolation value of `val` at -! spatial-quadrature points - -INTERFACE - MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) - !! space-time interpolation of scalar - TYPE(FEVariable_), INTENT(IN) :: val - !! scalar FE variable - END SUBROUTINE scalar_getInterpolation_5 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_5 -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 - MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) - !! interpolation of vector - REAL(DFP), INTENT(IN) :: val(:, :) - !! nodal values of vector in `xiJ` format - END SUBROUTINE vector_getInterpolation_1 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_1 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of a vector -! -!# Introduction -! -! This subroutine performs interpolation of a vector from its space-time -! nodal values -! -! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ - -INTERFACE - MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) - !! - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE vector_getInterpolation_2 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_2 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of a vector -! -!# Introduction -! -! This subroutine performs interpolation of a vector from its space-time -! nodal values -! -! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ - -INTERFACE - MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) - !! - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE vector_getInterpolation_3 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_3 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: returns the interpolation of vector FEVariable -! -!# Introduction -! -! Returns the interpolation of vector variable -! The vector variable can be+ -! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values -! -! NOTE This routine calls [[Interpolation]] function from the same module. -! -INTERFACE - MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val) - 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 - -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_4 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: returns the interpolation of vector FEVariable -! -!# Introduction -! -! Returns the interpolation of vector variable -! The vector variable can be+ -! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values -! -! NOTE This routine calls [[Interpolation]] function from the same module. -! -INTERFACE - MODULE PURE SUBROUTINE vector_getInterpolation_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 - -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_5 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine performs interpolation of matrix - -INTERFACE - MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) - !! interpolation of matrix - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! nodal value of matrix - END SUBROUTINE matrix_getInterpolation_1 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_1 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of matrix -! -!# Introduction -! -! This subroutine performs interpolation of matrix from its space-time -! nodal values - -INTERFACE - MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal value of matrix - END SUBROUTINE matrix_getInterpolation_2 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_2 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of matrix -! -!# Introduction -! -! This subroutine performs interpolation of matrix from its space-time -! nodal values - -INTERFACE - MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :, :) - !! space-time interpolation - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal value of matrix - END SUBROUTINE matrix_getInterpolation_3 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_3 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine performs interpolation of matrix FEVariable -! -INTERFACE - MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) - !! interpolation of matrix - TYPE(FEVariable_), INTENT(IN) :: val - !! matrix fe variable - END SUBROUTINE matrix_getInterpolation_4 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_4 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -INTERFACE - 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 - -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_5 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 - MODULE PURE SUBROUTINE master_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: interpol - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE master_getInterpolation_1 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE master_getInterpolation_1 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 - MODULE PURE SUBROUTINE master_getInterpolation_2(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(INOUT) :: interpol - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE master_getInterpolation_2 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE master_getInterpolation_2 -END INTERFACE getInterpolation - -!---------------------------------------------------------------------------- -! Interpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This function returns the interpolation of a scalar - -INTERFACE - MODULE PURE FUNCTION scalar_interpolation_1(obj, val) RESULT(interpol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:) - REAL(DFP), ALLOCATABLE :: interpol(:) - END FUNCTION scalar_interpolation_1 -END INTERFACE - -INTERFACE Interpolation - MODULE PROCEDURE scalar_interpolation_1 -END INTERFACE Interpolation - -!---------------------------------------------------------------------------- -! Interpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This function returns the interpolation of vector - -INTERFACE - MODULE PURE FUNCTION vector_interpolation_1(obj, val) RESULT(interpol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:, :) - REAL(DFP), ALLOCATABLE :: interpol(:, :) - END FUNCTION vector_interpolation_1 -END INTERFACE - -INTERFACE Interpolation - MODULE PROCEDURE vector_interpolation_1 -END INTERFACE Interpolation - -!---------------------------------------------------------------------------- -! Interpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This function returns the interpolation of matrix - -INTERFACE - MODULE PURE FUNCTION matrix_interpolation_1(obj, val) RESULT(interpol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :) - REAL(DFP), ALLOCATABLE :: interpol(:, :, :) - END FUNCTION matrix_interpolation_1 -END INTERFACE - -INTERFACE Interpolation - MODULE PROCEDURE matrix_interpolation_1 -END INTERFACE Interpolation - -!---------------------------------------------------------------------------- -! Interpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-13 -! update: 2021-12-13 -! summary: Interpolation of FEVariable - -INTERFACE - MODULE PURE FUNCTION master_interpolation_1(obj, val) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION master_interpolation_1 -END INTERFACE - -INTERFACE Interpolation - 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_LocalDivergenceMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 deleted file mode 100644 index 52e2195e9..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 +++ /dev/null @@ -1,264 +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 ElemshapeData_LocalDivergenceMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: getLocalDivergence -PUBLIC :: LocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local Divergence of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_1(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! local Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :) - !! space nodal values of vector in `xiJ` format - !! row index: space component - !! col index: node number - END SUBROUTINE elemsd_getLocalDivergence_1 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_1 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local Divergence of a vector -! -! $$ -! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac -! {\partial N^{I}}{\partial \xi_{j} } -! $$ -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_2(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! local Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - !! first index: space compo - !! second index: space node - !! third index: time node - END SUBROUTINE elemsd_getLocalDivergence_2 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_2 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local Divergence of a vector -! -! $$ -! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac -! {\partial N^{I}}{\partial \xi_{j} } -! $$ -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_3(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! local Divergence of vector at integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! vector finite-element variable - END SUBROUTINE elemsd_getLocalDivergence_3 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_3 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local Divergence of a matrix - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_4(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! local Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getLocalDivergence_4 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_4 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local Divergence of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_5(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! local Divergence at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal values of matrix in (i,j,I,a) format - END SUBROUTINE elemsd_getLocalDivergence_5 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_5 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local Divergence of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_6(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! local Divergence at integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space/space-time nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getLocalDivergence_6 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_6 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local Divergence -! -!# Introduction -! -! - This routine returns local Divergence in [[FEVariable_]] -! the input is also a [[FEVariable_]]. -! - This routine can be considered as a master routine -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_7(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! local Divergence of scalar/vector/matrix at space integration points - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE elemsd_getLocalDivergence_7 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_7 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! getLocalDivergence@DivergenceMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Local Divergence - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalDivergence_8(obj, lg, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! Local Divergence of scalar/vector/matrix at space-time - !! integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space time nodal values of scalar/vector/matrix - END SUBROUTINE elemsd_getLocalDivergence_8 -END INTERFACE - -INTERFACE getLocalDivergence - MODULE PROCEDURE elemsd_getLocalDivergence_8 -END INTERFACE getLocalDivergence - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_LocalDivergence_1(obj, val) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_LocalDivergence_1 -END INTERFACE - -INTERFACE localDivergence - MODULE PROCEDURE elemsd_LocalDivergence_1 -END INTERFACE localDivergence - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_LocalDivergence_2(obj, val) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_LocalDivergence_2 -END INTERFACE - -INTERFACE localDivergence - MODULE PROCEDURE elemsd_LocalDivergence_2 -END INTERFACE localDivergence - -end module ElemshapeData_LocalDivergenceMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 deleted file mode 100644 index c5104e760..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 +++ /dev/null @@ -1,367 +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 ElemshapeData_LocalGradientMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: getLocalGradient -PUBLIC :: LocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a scalar -! -! $$ -! \frac{\partial \phi }{\partial \xi_{i} } =\phi_{I} \frac{\partial N^{I}} -! {\partial \xi_{i} } -! $$ -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_1(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! local gradients of scalar - REAL(DFP), INTENT(IN) :: val(:) - !! Space nodal values of scalar - END SUBROUTINE elemsd_getLocalGradient_1 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_1 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_2(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) - !! local gradient at integration points - !! first index: space component of V - !! second index: space component of x - !! third index: integration point - REAL(DFP), INTENT(IN) :: val(:, :) - !! space nodal values of vector in `xiJ` format - !! row index: space component - !! col index: node number - END SUBROUTINE elemsd_getLocalGradient_2 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_2 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a scalar -! -! $$ -! \frac{\partial \phi }{\partial \xi_{i} } =\phi^{a}_{I} T_{a}\frac -! {\partial N^{I}}{\partial \xi_{i} } -! $$ -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_3(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! local gradient of scalar (space-time nodal) - !! first index = space component of xi - !! second index= integration point in space - REAL(DFP), INTENT(IN) :: val(:, :) - !! space-time nodal values of scalar - !! first index = space node - !! second index = time node - END SUBROUTINE elemsd_getLocalGradient_3 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_3 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a vector -! -! $$ -! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac -! {\partial N^{I}}{\partial \xi_{j} } -! $$ -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_4(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) - !! local gradient at integration points - !! first index : space compo of V - !! second index: space compo of Xi - !! third index: integration point in space - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - !! first index: space compo - !! second index: space node - !! third index: time node - END SUBROUTINE elemsd_getLocalGradient_4 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_4 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a scalar -! -! $$ -! \frac{\partial \phi }{\partial \xi_{i} } =\phi_{I} \frac{\partial N^{I}} -! {\partial \xi_{i} } -! $$ -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_5(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! local gradient of scalar - TYPE(FEVariable_), INTENT(IN) :: val - !! Scalar finite elememt variable - END SUBROUTINE elemsd_getLocalGradient_5 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_5 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a vector -! -! $$ -! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac -! {\partial N^{I}}{\partial \xi_{j} } -! $$ -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_6(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) - !! local gradient of vector at integration points - !! first index : space compo of V - !! second index: space compo of Xi - !! third index: integration point in space - TYPE(FEVariable_), INTENT(IN) :: val - !! vector fe variable - END SUBROUTINE elemsd_getLocalGradient_6 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_6 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_7(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) - !! local gradient at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getLocalGradient_7 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_7 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_8(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) - !! local gradient at integration points - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal values of matrix in (i,j,I,a) format - END SUBROUTINE elemsd_getLocalGradient_8 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_8 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient of a vector - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_9(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) - !! local gradient at integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getLocalGradient_9 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_9 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the local gradient -! -!# Introduction -! -! - This routine returns local gradient in [[FEVariable_]] -! the input is also a [[FEVariable_]]. -! - This routine can be considered as a master routine -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_10(obj, lg, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! local gradient of scalar/vector/matrix at space integration points - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE elemsd_getLocalGradient_10 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_10 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! getLocalGradient@GradientMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine returns the Local gradient -! -!# Introduction -! -! - This routine returns Local gradient in [[FEVariable_]] -! the input is also a [[FEVariable_]]. -! - This routine can be considered as a master routine - -INTERFACE - MODULE PURE SUBROUTINE elemsd_getLocalGradient_11(obj, lg, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! Local gradient of scalar/vector/matrix at space-time - !! integration points - TYPE(FEVariable_), INTENT(IN) :: val - !! space time nodal values of scalar/vector/matrix - END SUBROUTINE elemsd_getLocalGradient_11 -END INTERFACE - -INTERFACE getLocalGradient - MODULE PROCEDURE elemsd_getLocalGradient_11 -END INTERFACE getLocalGradient - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_LocalGradient_1(obj, val) RESULT(Ans) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_LocalGradient_1 -END INTERFACE - -INTERFACE localGradient - MODULE PROCEDURE elemsd_LocalGradient_1 -END INTERFACE localGradient - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION elemsd_LocalGradient_2(obj, val) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION elemsd_LocalGradient_2 -END INTERFACE - -INTERFACE LocalGradient - MODULE PROCEDURE elemsd_LocalGradient_2 -END INTERFACE LocalGradient - -end module ElemshapeData_LocalGradientMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 deleted file mode 100644 index 1df4c3ff0..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ /dev/null @@ -1,37 +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 ElemshapeData_Method -USE ElemshapeData_ConstructorMethods -USE ElemshapeData_DGMethods -USE ElemshapeData_DivergenceMethods -USE ElemshapeData_GetMethods -USE ElemshapeData_GradientMethods -USE ElemshapeData_H1Methods -USE ElemshapeData_HCurlMethods -USE ElemshapeData_HDivMethods -USE ElemshapeData_HRGNParamMethods -USE ElemshapeData_HRQIParamMethods -USE ElemshapeData_HminHmaxMethods -USE ElemshapeData_IOMethods -USE ElemshapeData_InterpolMethods -USE ElemshapeData_LocalDivergenceMethods -USE ElemshapeData_LocalGradientMethods -USE ElemshapeData_ProjectionMethods -USE ElemshapeData_SetMethods -USE ElemshapeData_StabilizationParamMethods -USE ElemshapeData_UnitNormalMethods -END MODULE ElemshapeData_Method diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 deleted file mode 100644 index 4d78a673c..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ /dev/null @@ -1,214 +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 ElemshapeData_ProjectionMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: getProjectionOfdNdXt -PUBLIC :: getProjectionOfdNTdXt - -!---------------------------------------------------------------------------- -! getProjectionOfdNdXt@ProjectionMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-21 -! update: 2021-11-21 -! summary: Computes $\frac{dN}{dx_k}c_k$ -! -!# Introduction -! -! This subroutine computes the projcetion cdNdXt on the vector `val` -! Here the vector `val` is constant in space and time -! -! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ - -INTERFACE - MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val) - 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 -END INTERFACE - -INTERFACE getProjectionOfdNdXt - MODULE PROCEDURE getProjectionOfdNdXt_1 -END INTERFACE getProjectionOfdNdXt - -!---------------------------------------------------------------------------- -! getProjectionOfdNdXt@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-21 -! update: 2021-11-21 -! summary: computes the projection of dNdXt on a vector -! -!# Introduction -! -! This subroutine computes the projcetion cdNdXt on the vector `val` -! Here the vector `val` is a finite element variable -! -! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ - -INTERFACE - MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val) - 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 - !! FEVariable vector - END SUBROUTINE getProjectionOfdNdXt_2 -END INTERFACE - -INTERFACE getProjectionOfdNdXt - MODULE PROCEDURE getProjectionOfdNdXt_2 -END INTERFACE getProjectionOfdNdXt - -!---------------------------------------------------------------------------- -! getProjectionOfdNdXt@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-21 -! update: 2021-11-21 -! summary: computes the projection of dNdXt on a vector -! -!# Introduction -! -! This subroutine computes the projcetion cdNdXt on the vector `val` -! Here the vector `val` is constant in space and time -! -! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ - -INTERFACE - MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val) - 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(:, :) - !! a vector, defined over quadrature points - END SUBROUTINE getProjectionOfdNdXt_3 -END INTERFACE - -INTERFACE getProjectionOfdNdXt - MODULE PROCEDURE getProjectionOfdNdXt_3 -END INTERFACE getProjectionOfdNdXt - -!---------------------------------------------------------------------------- -! getProjectionOfdNTdXt@getMethod -!---------------------------------------------------------------------------- - -!> 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 getProjectionOfdNTdXt_1(obj, cdNTdXt, val) - 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(:) - !! constant value of vector - END SUBROUTINE getProjectionOfdNTdXt_1 -END INTERFACE - -INTERFACE getProjectionOfdNTdXt - MODULE PROCEDURE getProjectionOfdNTdXt_1 -END INTERFACE getProjectionOfdNTdXt - -!---------------------------------------------------------------------------- -! getProjectionOfdNTdXt@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-07 -! update: 2021-12-07 -! summary: returns the projection of dNTdXt on a vector -! -!# Introduction -! -! This subroutine computes the projcetion cdNTdXt on the vector `val` -! Here the vector `val` is a vector variable -! -! - It can be constant in space and time -! - It can be vary in space but contant in time -! - It can vary in space and time domain -! -! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ -! -INTERFACE - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val) - 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 - !! constant value of vector - END SUBROUTINE getProjectionOfdNTdXt_2 -END INTERFACE - -INTERFACE getProjectionOfdNTdXt - MODULE PROCEDURE getProjectionOfdNTdXt_2 -END INTERFACE getProjectionOfdNTdXt - -!---------------------------------------------------------------------------- -! getProjectionOfdNTdXt@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-07 -! update: 2021-12-07 -! summary: returns the projection of dNTdXt on a vector -! -!# Introduction -! -! -! This subroutine computes the projcetion cdNTdXt on the vector `val` -! Here the vector `val` is a vector variable -! -! - It can be constant in space and time -! - It can be vary in space but contant in time -! - It can vary in space and time domain -! -! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ -! -INTERFACE - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_3(obj, cdNTdXt, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :, :) - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE getProjectionOfdNTdXt_3 -END INTERFACE - -INTERFACE getProjectionOfdNTdXt - MODULE PROCEDURE getProjectionOfdNTdXt_3 -END INTERFACE getProjectionOfdNTdXt - -end module ElemshapeData_ProjectionMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 deleted file mode 100644 index 74069ca7f..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 +++ /dev/null @@ -1,482 +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 ElemshapeData_SetMethods -USE BaSetype -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Set -PUBLIC :: SetBarycentricCoord -PUBLIC :: SetJacobian -PUBLIC :: SetJs -PUBLIC :: SetNormal -PUBLIC :: SetThickness -PUBLIC :: SetdNTdXt -PUBLIC :: SetdNTdt -PUBLIC :: SetdNdXt - -!---------------------------------------------------------------------------- -! SetNormal@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Sets the normal vector - -INTERFACE SetNormal - MODULE PURE SUBROUTINE elemsd_SetNormal(obj) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - END SUBROUTINE elemsd_SetNormal -END INTERFACE SetNormal - -!---------------------------------------------------------------------------- -! SetThickness@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March -! summary: This subroutine Set the thickness field -! -!# Introduction -! -! This subroutine Set the `thickness` field -! Here `val` denotes the nodal value of thickeness -! -! $$d = d_{I} N^{I}$$ - -INTERFACE SetThickness - MODULE PURE SUBROUTINE elemsd_SetThickness(obj, val, N) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:) - !! Nodal values of thickness - REAL(DFP), INTENT(IN) :: N(:, :) - !! Shape function values at quadrature points - END SUBROUTINE elemsd_SetThickness -END INTERFACE SetThickness - -!---------------------------------------------------------------------------- -! SetThickness@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set the thickness field -! -!# Introduction -! -! This subroutine Set the `thickness` field -! Here `val` denotes the space-time nodal value of thickeness -! -! $$d = d_{I}^{a} N^{I} T_{a}$$ - -INTERFACE SetThickness - MODULE PURE SUBROUTINE stsd_SetThickness(obj, val, N, T) - CLASS(STElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :) - !! Space-time nodal values of thickness - REAL(DFP), INTENT(IN) :: N(:, :) - !! Shape function at spatial quadrature - REAL(DFP), INTENT(IN) :: T(:) - !! Shape function at temporal quadrature - END SUBROUTINE stsd_SetThickness -END INTERFACE SetThickness - -!---------------------------------------------------------------------------- -! SetBarycentricCoord@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set the Barycentric coordinates -! -!# Introduction -! -! This subroutine Set the barycentric coordinates -! -! $$x_i = x_{iI} N^{I}$$ -! - -INTERFACE SetBarycentricCoord - MODULE PURE SUBROUTINE elemsd_SetBarycentricCoord(obj, val, N) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :) - !! Nodal coordinates in `xiJ` format - REAL(DFP), INTENT(IN) :: N(:, :) - !! When element is not an isoparametric we can supply N. - END SUBROUTINE elemsd_SetBarycentricCoord -END INTERFACE SetBarycentricCoord - -!---------------------------------------------------------------------------- -! SetBarycentricCoord@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set the Barycentric coordinates -! -!# Introduction -! -! This subroutine Set the barycentric coordinates by using -! space-time nodal coordinates -! -! $$x=x_{I}^{a} N^I T_a$$ - -INTERFACE SetBarycentricCoord - MODULE PURE SUBROUTINE stsd_SetBarycentricCoord(obj, val, N, T) - CLASS(STElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time Nodal coordinates in `xiJ` format - REAL(DFP), INTENT(IN) :: N(:, :), T(:) - !! N and T are required to handle non isoparametric elements - END SUBROUTINE stsd_SetBarycentricCoord -END INTERFACE SetBarycentricCoord - -!---------------------------------------------------------------------------- -! SetJs@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set the determinent of jacobian - -INTERFACE SetJs - MODULE PURE SUBROUTINE elemsd_SetJs(obj) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - END SUBROUTINE elemsd_SetJs -END INTERFACE SetJs - -!---------------------------------------------------------------------------- -! SetdNdXt@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set $\frac{d N}{d X_t}$ internally -! -!# Introduction -! -! This subroutine will internally Set `dNdXt`. -! It use the inverse of jacobian stored internally, so make sure jacobian is -! Set before calling this subroutine. - -INTERFACE SetdNdXt - MODULE PURE SUBROUTINE elemsd_SetdNdXt(obj) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - END SUBROUTINE elemsd_SetdNdXt -END INTERFACE SetdNdXt - -!---------------------------------------------------------------------------- -! SetJacobian@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set the jacobian -! -!# Introduction -! -! This subroutine Set the jacobian by using the nodal coordinates -! -! $$\frac{d x_i}{d \xi_j} = x_{iI}\frac{d N^I}{d \xi_j}$$ - -INTERFACE SetJacobian - MODULE PURE SUBROUTINE elemsd_SetJacobian(obj, val, dNdXi) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :) - !! nodal coordinates in `xiJ` format - REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) - END SUBROUTINE elemsd_SetJacobian -END INTERFACE SetJacobian - -!---------------------------------------------------------------------------- -! SetJacobian@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set the jacobian using space-time nodal coords -! -!# Introduction -! -! This subroutine Set the jacobian by using space-time nodal coords, `dNdXi` -! `T` are used to handle non-isoparameteric elements. -! -! $$\frac{d x_i}{d \xi_j} = x_{iI}^{a}T_a\frac{d N^I}{d \xi_j}$$ -! - -INTERFACE SetJacobian - MODULE PURE SUBROUTINE stsd_SetJacobian(obj, val, dNdXi, T) - CLASS(STElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! Space time nodal values of coordinates - REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) - !! Local derivative of shape function for geometry - REAL(DFP), INTENT(IN) :: T(:) - !! Shape function for time element - END SUBROUTINE stsd_SetJacobian -END INTERFACE SetJacobian - -!---------------------------------------------------------------------------- -! SetdNTdt@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set `dNTdt` by using the space-time nodal values -! -!# Introduction -! -! - This subroutine Set `dNTdt` by using space-time nodal values -! - It is important to note that `dNTdXt` should be allocated before calling -! - This subroutine uses following formula -! -! $$ -! \frac{\partial N^{I\ }T_{a}}{\partial t} =N^{I}\frac{\partial T_{a}} -! {\partial \theta } J^{-1}_{t}-\frac{\partial N^{I}T_{a}}{\partial x_{k}} -! \hat{v}_{k} -! $$ - -INTERFACE SetdNTdt - MODULE PURE SUBROUTINE stsd_SetdNTdt(obj, val) - CLASS(STElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! Space-time nodal values - END SUBROUTINE stsd_SetdNTdt -END INTERFACE SetdNTdt - -!---------------------------------------------------------------------------- -! SetdNTdXt@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set `dNTdXt` by using internal data -! -!# Introduction -! -! * This subroutine Set `dNTdXt` by using internal data -! * This subroutine uses inverse of Jacobian, therefore, before calling -! * this subroutine make sure to Set jacobian -! -! $$\frac{\partial N^{I\ }T_{a}}{\partial x_{i\ }} -! =\frac{\partial N^{I}T_{a}}{\partial \xi_{j} } \frac{\partial \xi_{j} } -! {\partial x_{i}} $$ - -INTERFACE SetdNTdXt - MODULE PURE SUBROUTINE stsd_SetdNTdXt(obj) - CLASS(STElemshapeData_), INTENT(INOUT) :: obj - !! Space-time nodal values - END SUBROUTINE stsd_SetdNTdXt -END INTERFACE SetdNTdXt - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Sets parameters defined on physical element -! -!# Introduction -! -!This subroutine sets parameters defined on physical element -! -!- `val` denotes nodal coordinates of element in `xiJ` format -!- This subroutine will call -! - `SetJacobian` -! - `SetJs` -! - `SetdNdXt` -! - `SetBarycentricCoord` -!- By using `N` and `dNdXi` we can handle non-isoparametric -! elements -! -!@note -! In case `obj` is instance of [[stelemshapedata_]] then `val` will denotes -! coordinates of spatial nodes at some time in [tn, tn+1] -!@endnote -! -! The number of cols in val should be same as the number of rows -! in N and size of first index of dNdXi. - -INTERFACE Set - MODULE PURE SUBROUTINE elemsd_Set1(obj, val, N, dNdXi) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :) - !! Spatial nodal coordinates - REAL(DFP), INTENT(IN) :: N(:, :) - !! Shape function for geometry - REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) - !! Local derivative of shape functions for geometry - END SUBROUTINE elemsd_Set1 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set parameters defined on physical element -! -!# Introduction -! -! This routine performs following tasks -! -!- Set Jacobian for cellobj -!- Set Js for cellobj -!- Set dNdXt for cellobj -!- Set SetBarycentricCoord for cellobj -! -! Then it get connectivity of facet element by using refelem stored -! inside facetobj. This conectivity is necessary for getting -! the coordinates of facet element. Then, it performs following tasks -! for facetobj -! -!- SetJacobian -!- SetJs -!- SetBarycentricCoord -!- SetNormal -! -! It is important to note that `dNdXt` in facetobj cannot be computed -! as facet elements are n-1 dimensional manifold in n dimensional space. -! Therefore, we extend (copy from) dNdXt from cellobj to facetobj. -! -! We also make normal, Js, Ws by in **cellObj** by copying from **facetObj** -! -!@note -! Both facetObj and cellObj should be defined at same quadrature -! points. These quadrature points corresponds points in facetObj. -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & - & celldNdXi, facetN, facetdNdXi) - CLASS(ElemshapeData_), INTENT(INOUT) :: facetobj - CLASS(ElemshapeData_), INTENT(INOUT) :: cellobj - REAL(DFP), INTENT(IN) :: cellval(:, :) - !! Spatial nodal coordinates of cell - REAL(DFP), INTENT(IN) :: cellN(:, :) - !! shape function for cell - REAL(DFP), INTENT(IN) :: facetN(:, :) - !! Shape function for geometry - REAL(DFP), INTENT(IN) :: celldNdXi(:, :, :) - REAL(DFP), INTENT(IN) :: facetdNdXi(:, :, :) - !! Local derivative of shape functions for geometry - END SUBROUTINE elemsd_Set2 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine Set parameters defined on physical element -! -!# Introduction -! -!TODO: Add documentation of elemsd_Set3 - -INTERFACE Set - MODULE PURE SUBROUTINE elemsd_Set3( & - & masterFacetobj, & - & masterCellobj, & - & masterCellval, & - & masterCellN, & - & masterCelldNdXi, & - & masterFacetN, & - & masterFacetdNdXi, & - & slaveFacetobj, & - & slaveCellobj, & - & slaveCellval, & - & slaveCellN, & - & slaveCelldNdXi, & - & slaveFacetN, & - & slaveFacetdNdXi) - CLASS(ElemshapeData_), INTENT(INOUT) :: masterFacetobj - CLASS(ElemshapeData_), INTENT(INOUT) :: masterCellobj - REAL(DFP), INTENT(IN) :: masterCellval(:, :) - !! Spatial nodal coordinates of master cell - REAL(DFP), INTENT(IN) :: masterCellN(:, :) - !! local shape function for geometry of master cell - REAL(DFP), INTENT(IN) :: masterFacetN(:, :) - !! Shape function for geometry of master facet element - REAL(DFP), INTENT(IN) :: masterCelldNdXi(:, :, :) - !! Local gradient of shape functions for geometry of master cell - REAL(DFP), INTENT(IN) :: masterFacetdNdXi(:, :, :) - !! Local gradient of shape functions for geometry of - !! facet element of master cell - CLASS(ElemshapeData_), INTENT(INOUT) :: slaveFacetobj - !! Shape function data for facet element of slave cell - CLASS(ElemshapeData_), INTENT(INOUT) :: slaveCellobj - !! Shape function data for cell element of slave cell - REAL(DFP), INTENT(IN) :: slaveCellval(:, :) - !! Spatial nodal coordinates of cell element of slave cell - REAL(DFP), INTENT(IN) :: slaveCellN(:, :) - !! Local shape function for geometry of cell element of slave - REAL(DFP), INTENT(IN) :: slaveFacetN(:, :) - !! Local shape function for geometry of facet element of slave - REAL(DFP), INTENT(IN) :: slaveCelldNdXi(:, :, :) - !! Local derivative of shape function for geometry of cell element - !! of slave - REAL(DFP), INTENT(IN) :: slaveFacetdNdXi(:, :, :) - !! Local derivative of shape function for geometry of facet element - !! of slave - END SUBROUTINE elemsd_Set3 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine sets the parameters defined on physical element -! -!# Introduction -! -! This subroutine Set parameters defined on physical element -! -! * `val` denotes coordinates of the space-time element in `xiJa` format -! * The facility of supplying `N`, `T`, and `dNdXi` allows us to handle -! non-isoparametric element -! * This subroutine will call -! - `SetJacobian` uses `dNdXi` -! - `SetJs` -! - `SetdNdXt` -! - `SetBarycentricCoord` uses `N` and `T` -! - `SetdNTdXt` -! - `SetdNTdt` -! -!@note -! In case of [[stelemshapedata_]] `val` denotes nodal coordinate at -! some intermediate space-time slab -!@endnote - -INTERFACE Set - MODULE PURE SUBROUTINE stelemsd_Set1(obj, val, N, T, dNdXi) - CLASS(STElemshapeData_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! Spatial nodal coordinates - REAL(DFP), INTENT(IN) :: N(:, :) - REAL(DFP), INTENT(IN) :: T(:) - REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) - END SUBROUTINE stelemsd_Set1 -END INTERFACE Set - -END MODULE ElemshapeData_SetMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 deleted file mode 100644 index 17d2c83ca..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 +++ /dev/null @@ -1,481 +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 ElemshapeData_StabilizationParamMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: GetSUPGParam -PUBLIC :: getSUGN3Param -PUBLIC :: getSUGN3Param_Takizawa2018 - -!---------------------------------------------------------------------------- -! getSUGN3Param@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_1(obj, tau, val, nu, h, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - TYPE(FEVariable_), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_1 -END INTERFACE - -INTERFACE getSUGN3Param - MODULE PROCEDURE elemsd_GetSUGN3Param_1 -END INTERFACE getSUGN3Param - -!---------------------------------------------------------------------------- -! getSUGN3Param@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 May 2022 -! update: 3 May 2022 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_2(obj, tau, val, nu, h, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - TYPE(FEVariable_), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_2 -END INTERFACE - -INTERFACE getSUGN3Param - MODULE PROCEDURE elemsd_GetSUGN3Param_2 -END INTERFACE getSUGN3Param - -!---------------------------------------------------------------------------- -! getSUGN3Param@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_3(obj, tau, val, nu, h, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - REAL(DFP), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_3 -END INTERFACE - -INTERFACE getSUGN3Param - MODULE PROCEDURE elemsd_GetSUGN3Param_3 -END INTERFACE getSUGN3Param - -!---------------------------------------------------------------------------- -! getSUGN3Param@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 May 2022 -! update: 3 May 2022 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_4(obj, tau, val, nu, h, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - REAL(DFP), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_4 -END INTERFACE - -INTERFACE getSUGN3Param - MODULE PROCEDURE elemsd_GetSUGN3Param_4 -END INTERFACE getSUGN3Param - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_1(obj, & - & tau, val, nu, h, hmax, hmin, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - TYPE(FEVariable_), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_1 -END INTERFACE - -INTERFACE getSUGN3Param_Takizawa2018 - MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_1 -END INTERFACE getSUGN3Param_Takizawa2018 - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 May 2022 -! update: 3 May 2022 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_2(obj, tau, val, & - & nu, h, hmax, hmin, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - TYPE(FEVariable_), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_2 -END INTERFACE - -INTERFACE getSUGN3Param_Takizawa2018 - MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_2 -END INTERFACE getSUGN3Param_Takizawa2018 - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_3(obj, tau, val, & - & nu, h, hmax, hmin, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - REAL(DFP), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_3 -END INTERFACE - -INTERFACE getSUGN3Param_Takizawa2018 - MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_3 -END INTERFACE getSUGN3Param_Takizawa2018 - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 May 2022 -! update: 3 May 2022 -! summary: Returns the SUGN3 param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_4(obj, tau, val, & - & nu, h, hmax, hmin, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! obj can be an instance of [[STElemshapeData_]] - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! tau-sugn3 is a scalar and defined on quadrature points - TYPE(FEVariable_), INTENT(IN) :: val - !! val can be a vector or a scalar - REAL(DFP), INTENT(IN) :: nu - !! kinematic viscosity or diffusivity - !! scalar and defined on quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax - !! scalar variable, defined on space-time quadrature points - TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin - !! scalar variable, defined on space-time quadrature points - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! currently, opt is not used, but it may be used in future - END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_4 -END INTERFACE - -INTERFACE getSUGN3Param_Takizawa2018 - MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_4 -END INTERFACE getSUGN3Param_Takizawa2018 - -!---------------------------------------------------------------------------- -! GetSUPGParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUPG param -! -!# Introduction -! -!- `tau` stabilization parameter, instance of [[FEVariable_]], -!- defined on quadrature, changes in space -!- `c` convective velocity, instance of [[FEVariable_]], vector, defined on -!- nodes or quadrature points -!- `val` instance of [[FEVariable_]], can be vector or scalar, defined on -!- nodes or quadrature points -!- `nu` instance of [[FEVariable_]], scalar, defined on nodes or quadrature -!- `k` instance of [[FEVariable_]], scalar, optional, defined on nodes/ -!- quadrature points -!- `phi`, porosity, [[FEVariable_]], scalar, optional, defined on nodes/quads -!- - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUPGParam1(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! It can be an instance of ElemshapeData_ or STElemshapeData_ - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! Stabilization parameter, [[FEVariable_]], Defined on Quadrature points - TYPE(FEVariable_), INTENT(IN) :: c - !! Convective velocity => Vector variable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution, it can be scalar or vector variable - TYPE(FEVariable_), INTENT(IN) :: nu - !! diffusivity - !! In case of NSE it should be mu/rho - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k - !! permeability - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi - !! porosity - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time step size - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default=1 - !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` - !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` - END SUBROUTINE elemsd_GetSUPGParam1 -END INTERFACE - -INTERFACE GetSUPGParam - MODULE PROCEDURE elemsd_GetSUPGParam1 -END INTERFACE GetSUPGParam - -!---------------------------------------------------------------------------- -! GetSUPGParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUPG param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUPGParam2(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! space-time shape data - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! Stabilization parameter - !! Quadrature type - !! SpaceTime - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - !! vector FEVariable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution - !! scalar or vector FEVariable - TYPE(FEVariable_), INTENT(IN) :: nu - !! kinematic diffusivity - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k - !! permeability - !! Scalar FEVariable - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi - !! porosity - !! Scalar FEVariable - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time step size - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default=1 - !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` - !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` - END SUBROUTINE elemsd_GetSUPGParam2 -END INTERFACE - -INTERFACE GetSUPGParam - MODULE PROCEDURE elemsd_GetSUPGParam2 -END INTERFACE GetSUPGParam - -!---------------------------------------------------------------------------- -! GetSUPGParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUPG param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUPGParam3(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! It can be an instance of ElemshapeData_ or STElemshapeData_ - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! Stabilization parameter - !! Quadrature FEVariable - !! varType=Space - TYPE(FEVariable_), INTENT(IN) :: c - !! Convective velocity => Vector variable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution, it can be scalar or vector variable - REAL(DFP), INTENT(IN) :: nu - !! In case of NSE it should be mu/rho - !! diffusivity - REAL(DFP), OPTIONAL, INTENT(IN) :: k - !! permeability - REAL(DFP), OPTIONAL, INTENT(IN) :: phi - !! porosity - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time step size - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default=1 - !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` - !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` - END SUBROUTINE elemsd_GetSUPGParam3 -END INTERFACE - -INTERFACE GetSUPGParam - MODULE PROCEDURE elemsd_GetSUPGParam3 -END INTERFACE GetSUPGParam - -!---------------------------------------------------------------------------- -! GetSUPGParam@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-27 -! update: 2021-11-27 -! summary: Returns the SUPG param - -INTERFACE - MODULE PURE SUBROUTINE elemsd_GetSUPGParam4(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - !! space-time shape data - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! Stabilization parameter - !! Quadrature type - !! SpaceTime - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - !! vector FEVariable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution - !! scalar or vector FEVariable - REAL(DFP), INTENT(IN) :: nu - !! kinematic diffusivity - REAL(DFP), OPTIONAL, INTENT(IN) :: k - !! permeability - !! Scalar FEVariable - REAL(DFP), OPTIONAL, INTENT(IN) :: phi - !! porosity - !! Scalar FEVariable - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time step size - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default=1 - !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` - !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` - END SUBROUTINE elemsd_GetSUPGParam4 -END INTERFACE - -INTERFACE GetSUPGParam - MODULE PROCEDURE elemsd_GetSUPGParam4 -END INTERFACE GetSUPGParam - -end module ElemshapeData_StabilizationParamMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 deleted file mode 100644 index 6ede5911e..000000000 --- a/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 +++ /dev/null @@ -1,129 +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 ElemshapeData_UnitNormalMethods -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetUnitNormal - -!---------------------------------------------------------------------------- -! GetUnitNormal@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine can be used in SUPG formulation -! -!# Introduction -! -! This routine can be used in the SUPG formulation: -! -! $$ -! \frac{\nabla \vert \phi \vert}{\Vert \nabla \vert \phi \vert \Vert} -! $$ - -INTERFACE - MODULE PURE SUBROUTINE GetUnitNormal_1(obj, R, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: R(:, :) - !! unit vector defined over quadrature points, in xiJ format - REAL(DFP), INTENT(IN) :: val(:) - !! spatial nodal values of scalar - END SUBROUTINE GetUnitNormal_1 -END INTERFACE - -INTERFACE GetUnitNormal - MODULE PROCEDURE GetUnitNormal_1 -END INTERFACE GetUnitNormal - -!---------------------------------------------------------------------------- -! GetUnitNormal@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine can be used in SUPG formulation -! -!# Introduction -! -! This routine can be used in the SUPG formulation, here -! val is spatial nodal values of a vector. -! -! $$ -! {\bf r}=\frac{\nabla\Vert{\bf v}\Vert}{\left|\nabla\Vert{\bf v}\Vert\right|} -! $$ - -INTERFACE - MODULE PURE SUBROUTINE GetUnitNormal_2(obj, R, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: R(:, :) - !! unit vector defined over quadrature points, in xiJ format - REAL(DFP), INTENT(IN) :: val(:, :) - !! spatial nodal values of velocity (vector field) - END SUBROUTINE GetUnitNormal_2 -END INTERFACE - -INTERFACE GetUnitNormal - MODULE PROCEDURE GetUnitNormal_2 -END INTERFACE GetUnitNormal - -!---------------------------------------------------------------------------- -! GetUnitNormal@getMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-26 -! update: 2021-11-26 -! summary: This subroutine can be used in SUPG formulation -! -!# Introduction -! -! - This routine can be used in the SUPG formulation. -! - `val` is the [[FEVariable_]], it can be vector or scalar -! -! $$ -! \frac{\nabla \vert \phi \vert}{\Vert \nabla \vert \phi \vert \Vert} -! $$ -! -! $$ -! {\bf r}=\frac{\nabla\Vert{\bf v}\Vert}{\left|\nabla\Vert{\bf v}\Vert\right|} -! $$ -! -! TODO: Make implementation simple: -! extract scalar or vector values from fevariable val, -! and call above routines - -INTERFACE - MODULE PURE SUBROUTINE GetUnitNormal_3(obj, R, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: R(:, :) - !! unit vector defined over quadrature points, in xiJ format - TYPE(FEVariable_), INTENT(IN) :: val - !! it can be scalar or vector fe variable - END SUBROUTINE GetUnitNormal_3 -END INTERFACE - -INTERFACE GetUnitNormal - MODULE PROCEDURE GetUnitNormal_3 -END INTERFACE GetUnitNormal - -end module ElemshapeData_UnitNormalMethods diff --git a/src/modules/ErrorHandling/CMakeLists.txt b/src/modules/ErrorHandling/CMakeLists.txt deleted file mode 100644 index 5581df053..000000000 --- a/src/modules/ErrorHandling/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ErrorHandling.F90 -) \ No newline at end of file diff --git a/src/modules/ErrorHandling/src/ErrorHandling.F90 b/src/modules/ErrorHandling/src/ErrorHandling.F90 deleted file mode 100644 index 206db18e2..000000000 --- a/src/modules/ErrorHandling/src/ErrorHandling.F90 +++ /dev/null @@ -1,195 +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 -! - -!> [[ErrorHandling]] module contains error handling routines. - -MODULE ErrorHandling -USE GlobalData, ONLY: I4B, OPT_ALLOC, OPT_DEALLOC, OPT_OPEN, & - & OPT_READ, OPT_WRITE, OPT_CLOSE -USE Display_Method, ONLY: Display, DashLine -IMPLICIT NONE -PRIVATE - -PUBLIC :: Errormsg, Warningmsg, fileError, AllocationErr - -CONTAINS - -!---------------------------------------------------------------------------- -! Errormsg -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints the error message -! -! #Usage -! ```fortran -! call Errormsg( & -! & msg="Some Error Message", & -! & file= "test_ErrorHandling", & -! & routine = "test1", & -! & line = 29 & -! ) -! ``` - -SUBROUTINE Errormsg(msg, file, routine, line, unitno) - CHARACTER(*), INTENT(IN) :: msg - !! Message - CHARACTER(*), INTENT(IN) :: file - !! Name of the file - CHARACTER(*), INTENT(IN) :: routine - !! Name of the routine where error has occured - INTEGER(I4B), INTENT(IN) :: line - !! line number where error has occured - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - !! Unit number - !! - CALL Display(file, "ERROR :: In file :: ", unitno=unitno) - CALL Display(LINE, "at line number :: ", unitno=unitno) - CALL Display(" ", "in routine named :: "//TRIM(routine)// & - & " with following message :: ", unitno=unitno) - CALL Dashline(unitno=unitno) - CALL Display(msg, unitno=unitno) - CALL Dashline(unitno=unitno) -END SUBROUTINE Errormsg - -!---------------------------------------------------------------------------- -! Warningmsg -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints the warning message - -SUBROUTINE Warningmsg(msg, file, routine, line, unitno) - !! This subroutine prints the warning message - CHARACTER(*), INTENT(IN) :: msg - !! Message - CHARACTER(*), INTENT(IN) :: file - !! Name of the file - CHARACTER(*), INTENT(IN) :: routine - !! Name of the routine where error has occured - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - !! file id to write the message to - INTEGER(I4B), INTENT(IN) :: line - !! line number - !! - CALL Display(file, "WARNING :: In file ::", unitno=unitno) - CALL Display(LINE, "line number ::", unitno=unitno) - CALL Display(" ", "in routine named :: "//TRIM(routine)// & - & " with following message :: ", unitno=unitno) - CALL Dashline(unitno=unitno) - CALL Display(msg, unitno=unitno) - CALL Dashline(unitno=unitno) -END SUBROUTINE Warningmsg - -!---------------------------------------------------------------------------- -! fileError -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints error while handling a file - -SUBROUTINE fileError(istat, filename, flg, unitno, file, routine, line) - ! Dummy argumnet - INTEGER(I4B), INTENT(IN) :: istat - !! Result of iostat=istat for open,read,write,close - CHARACTER(*), INTENT(IN) :: filename - !! Name of the file (IO related) - INTEGER(I4B), INTENT(IN) :: flg - !! IO_OPEN=Open, IO_READ=Read, IO_WRITE=Write, IO_CLOSE=Close - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - !! file id to write the error to - CHARACTER(*), INTENT(IN) :: file, routine - !! Name of the source code file and routine name - INTEGER(I4B), INTENT(IN) :: line - !! line number - !! - ! Define internal variables - CHARACTER(:), ALLOCATABLE :: Amsg - !! - ! Return if no error - IF (istat == 0) THEN - RETURN - END IF - !! - Amsg = "" - !! - SELECT CASE (flg) - CASE (OPT_OPEN) - Amsg = 'Opening file: '//TRIM(filename) - CASE (OPT_READ) - Amsg = 'Reading from: '//TRIM(filename) - CASE (OPT_WRITE) - Amsg = 'Writing to file: '//TRIM(filename) - CASE (OPT_CLOSE) - Amsg = 'Closing file: '//TRIM(filename) - CASE DEFAULT - Amsg = 'Error:Invalid error flag [1-4]' - END SELECT - !! - CALL Errormsg(msg=Amsg, unitno=unitno, file=file, line=line, & - & routine=routine) - !! -END SUBROUTINE fileError - -!---------------------------------------------------------------------------- -! AllocationErr -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This subroutine prints the error which occurs while allocating/ -! deallocating an array -! -! Use this after an allocate/deallocate statement -! allocate(x(nz,ny,nx), stat=istat); call AllocationErr(istat,'x',1) -! deallocate(x, stat=istat); call AllocationErr(istat,'x',2) - -SUBROUTINE AllocationErr(istat, amsg, alloc, unitno, file, routine, line) - INTEGER(I4B), INTENT(IN) :: istat - !! results of stat=istat in (de)allocate - CHARACTER(*), INTENT(IN) :: amsg - !! Message associated with the (de)allocate - INTEGER(I4B), INTENT(IN) :: alloc - !! For OPT_ALLOC = allocate, for OPT_DEALLOC = deallocate - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - !! Optional file id to write the message to - CHARACTER(*), INTENT(IN) :: file, routine - !! filename and routine name - INTEGER(I4B), INTENT(IN) :: line - !! - ! Define internal variables - CHARACTER(:), ALLOCATABLE :: tmp - !! - IF (istat == 0) RETURN - !! - tmp = "" - SELECT CASE (alloc) - CASE (OPT_ALLOC) - tmp = 'Allocating Memory: '//TRIM(amsg) - CASE (OPT_DEALLOC) - tmp = 'Deallocating Memory: '//TRIM(amsg) - END SELECT - !! - CALL Errormsg(msg=tmp, unitno=unitno, file=file, line=line, & - & routine=routine) - !! -END SUBROUTINE AllocationErr - -END MODULE ErrorHandling diff --git a/src/modules/FACE/CMakeLists.txt b/src/modules/FACE/CMakeLists.txt deleted file mode 100644 index 0a603073f..000000000 --- a/src/modules/FACE/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/face.F90 -) - -INCLUDE(CheckFortranSourceRuns) - -check_fortran_source_runs( - "program ascii_support; - integer, parameter :: ascii = selected_char_kind('ascii'); - if(ascii < 0) stop 1; - end program ascii_support" - ASCII_SUPPORTED - SRC_EXT f90 -) - -IF(ASCII_SUPPORTED) - SET(ascii_supported "-DASCII_SUPPORTED") -ENDIF() - -check_fortran_source_runs( - "program ascii_neq_default; - integer, parameter :: ascii = selected_char_kind('ascii'); - integer, parameter :: default = selected_char_kind('default'); - if(ascii == default) stop 1; - end program ascii_neq_default" - ASCII_NEQ_DEFAULT - SRC_EXT f90 -) - -IF(ASCII_NEQ_DEFAULT) - SET(ascii_neq_default "-DASCII_NEQ_DEFAULT") -ENDIF() - -check_fortran_source_runs( - "program ucs4_support; - integer, parameter :: ucs4 = selected_char_kind('iso_10646'); - if(ucs4 < 0) stop 1; - end program ucs4_support" - UCS4_SUPPORTED - SRC_EXT f90 -) - -IF(UCS4_SUPPORTED) - SET(ucs4_supported "-DUCS4_SUPPORTED") -ENDIF() - -LIST( APPEND TARGET_COMPILE_DEF ${ascii_supported} ) -LIST( APPEND TARGET_COMPILE_DEF ${ascii_neq_default} ) -LIST( APPEND TARGET_COMPILE_DEF ${ucs4_supported} ) diff --git a/src/modules/FACE/src/face.F90 b/src/modules/FACE/src/face.F90 deleted file mode 100644 index 385355136..000000000 --- a/src/modules/FACE/src/face.F90 +++ /dev/null @@ -1,287 +0,0 @@ -!< FACE, Fortran Ansi Colors Environment. -module face -!< FACE, Fortran Ansi Colors Environment. -use, intrinsic :: iso_fortran_env, only: int32 - -implicit none -private -public :: colorize -public :: colors_samples -public :: styles_samples -public :: ASCII -public :: UCS4 - -interface colorize -#if defined ASCII_SUPPORTED && defined ASCII_NEQ_DEFAULT - module procedure colorize_ascii - module procedure colorize_default -#else - module procedure colorize_default -#endif -#ifdef UCS4_SUPPORTED - module procedure colorize_ucs4 -#endif -endinterface - -! kind parameters -#ifdef ASCII_SUPPORTED -integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind. -#else -integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind. -#endif -#ifdef UCS4_SUPPORTED -integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind. -#else -integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind. -#endif -! parameters -character(26), parameter :: UPPER_ALPHABET='ABCDEFGHIJKLMNOPQRSTUVWXYZ' !< Upper case alphabet. -character(26), parameter :: LOWER_ALPHABET='abcdefghijklmnopqrstuvwxyz' !< Lower case alphabet. -character(1), parameter :: NL=new_line('a') !< New line character. -character(1), parameter :: ESCAPE=achar(27) !< "\" character. -! codes -character(2), parameter :: CODE_START=ESCAPE//'[' !< Start ansi code, "\[". -character(1), parameter :: CODE_END='m' !< End ansi code, "m". -character(4), parameter :: CODE_CLEAR=CODE_START//'0'//CODE_END !< Clear all styles, "\[0m". -! styles codes -character(17), parameter :: STYLES(1:2,1:16)=reshape([& - 'BOLD_ON ','1 ', & ! Bold on. - 'ITALICS_ON ','3 ', & ! Italics on. - 'UNDERLINE_ON ','4 ', & ! Underline on. - 'INVERSE_ON ','7 ', & ! Inverse on: reverse foreground and background colors. - 'STRIKETHROUGH_ON ','9 ', & ! Strikethrough on. - 'BOLD_OFF ','22 ', & ! Bold off. - 'ITALICS_OFF ','23 ', & ! Italics off. - 'UNDERLINE_OFF ','24 ', & ! Underline off. - 'INVERSE_OFF ','27 ', & ! Inverse off: reverse foreground and background colors. - 'STRIKETHROUGH_OFF','29 ', & ! Strikethrough off. - 'FRAMED_ON ','51 ', & ! Framed on. - 'ENCIRCLED_ON ','52 ', & ! Encircled on. - 'OVERLINED_ON ','53 ', & ! Overlined on. - 'FRAMED_OFF ','54 ', & ! Framed off. - 'ENCIRCLED_OFF ','54 ', & ! Encircled off. - 'OVERLINED_OFF ','55 ' & ! Overlined off. - ], [2,16]) !< Styles. -! colors codes -character(15), parameter :: COLORS_FG(1:2,1:17)=reshape([& - 'BLACK ','30 ', & ! Black. - 'RED ','31 ', & ! Red. - 'GREEN ','32 ', & ! Green. - 'YELLOW ','33 ', & ! Yellow. - 'BLUE ','34 ', & ! Blue. - 'MAGENTA ','35 ', & ! Magenta. - 'CYAN ','36 ', & ! Cyan. - 'WHITE ','37 ', & ! White. - 'DEFAULT ','39 ', & ! Default (white). - 'BLACK_INTENSE ','90 ', & ! Black intense. - 'RED_INTENSE ','91 ', & ! Red intense. - 'GREEN_INTENSE ','92 ', & ! Green intense. - 'YELLOW_INTENSE ','93 ', & ! Yellow intense. - 'BLUE_INTENSE ','94 ', & ! Blue intense. - 'MAGENTA_INTENSE','95 ', & ! Magenta intense. - 'CYAN_INTENSE ','96 ', & ! Cyan intense. - 'WHITE_INTENSE ','97 ' & ! White intense. - ], [2,17]) !< Foreground colors. -character(15), parameter :: COLORS_BG(1:2,1:17)=reshape([& - 'BLACK ','40 ', & ! Black. - 'RED ','41 ', & ! Red. - 'GREEN ','42 ', & ! Green. - 'YELLOW ','43 ', & ! Yellow. - 'BLUE ','44 ', & ! Blue. - 'MAGENTA ','45 ', & ! Magenta. - 'CYAN ','46 ', & ! Cyan. - 'WHITE ','47 ', & ! White. - 'DEFAULT ','49 ', & ! Default (black). - 'BLACK_INTENSE ','100 ', & ! Black intense. - 'RED_INTENSE ','101 ', & ! Red intense. - 'GREEN_INTENSE ','102 ', & ! Green intense. - 'YELLOW_INTENSE ','103 ', & ! Yellow intense. - 'BLUE_INTENSE ','104 ', & ! Blue intense. - 'MAGENTA_INTENSE','105 ', & ! Magenta intense. - 'CYAN_INTENSE ','106 ', & ! Cyan intense. - 'WHITE_INTENSE ','107 ' & ! White intense. - ], [2,17]) !< Background colors. -contains - ! public procedures - subroutine colors_samples() - !< Print to standard output all colors samples. - integer(int32) :: c !< Counter. - - print '(A)', colorize('Foreground colors samples', color_fg='red_intense') - do c=1, size(COLORS_FG, dim=2) - print '(A)', ' colorize("'//COLORS_FG(1, c)//'", color_fg="'//COLORS_FG(1, c)//'") => '//& - colorize(COLORS_FG(1, c), color_fg=COLORS_FG(1, c))//& - ' code: '//colorize(trim(COLORS_FG(2, c)), color_fg=COLORS_FG(1, c), style='inverse_on') - enddo - print '(A)', colorize('Background colors samples', color_fg='red_intense') - do c=1, size(COLORS_BG, dim=2) - print '(A)', ' colorize("'//COLORS_BG(1, c)//'", color_bg="'//COLORS_BG(1, c)//'") => '//& - colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))//& - ' code: '//colorize(trim(COLORS_BG(2, c)), color_bg=COLORS_BG(1, c), style='inverse_on') - enddo - endsubroutine colors_samples - - subroutine styles_samples() - !< Print to standard output all styles samples. - integer(int32) :: s !< Counter. - - print '(A)', colorize('Styles samples', color_fg='red_intense') - do s=1, size(STYLES, dim=2) - print '(A)', ' colorize("'//STYLES(1, s)//'", style="'//STYLES(1, s)//'") => '//& - colorize(STYLES(1, s), style=STYLES(1, s))//& - ' code: '//colorize(trim(STYLES(2, s)), color_fg='magenta', style='inverse_on') - enddo - endsubroutine styles_samples - - ! private procedures - pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized) - !< Colorize and stylize strings, ASCII kind. - character(len=*, kind=ASCII), intent(in) :: string !< Input string. - character(len=*), intent(in), optional :: color_fg !< Foreground color definition. - character(len=*), intent(in), optional :: color_bg !< Background color definition. - character(len=*), intent(in), optional :: style !< Style definition. - character(len=:, kind=ASCII), allocatable :: colorized !< Colorized string. - character(len=:, kind=ASCII), allocatable :: buffer !< Temporary buffer. - integer(int32) :: i !< Counter. - - colorized = string - if (present(color_fg)) then - i = color_index(upper(color_fg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(color_bg)) then - i = color_index(upper(color_bg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(style)) then - i = style_index(upper(style)) - if (i>0) then - buffer = CODE_START//trim(STYLES(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - endfunction colorize_ascii - - pure function colorize_default(string, color_fg, color_bg, style) result(colorized) - !< Colorize and stylize strings, DEFAULT kind. - character(len=*), intent(in) :: string !< Input string. - character(len=*), intent(in), optional :: color_fg !< Foreground color definition. - character(len=*), intent(in), optional :: color_bg !< Background color definition. - character(len=*), intent(in), optional :: style !< Style definition. - character(len=:), allocatable :: colorized !< Colorized string. - integer(int32) :: i !< Counter. - - colorized = string - if (present(color_fg)) then - i = color_index(upper(color_fg)) - if (i>0) colorized = CODE_START//trim(COLORS_FG(2, i))//CODE_END//colorized//CODE_CLEAR - endif - if (present(color_bg)) then - i = color_index(upper(color_bg)) - if (i>0) colorized = CODE_START//trim(COLORS_BG(2, i))//CODE_END//colorized//CODE_CLEAR - endif - if (present(style)) then - i = style_index(upper(style)) - if (i>0) colorized = CODE_START//trim(STYLES(2, i))//CODE_END//colorized//CODE_CLEAR - endif - endfunction colorize_default - - pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized) - !< Colorize and stylize strings, UCS4 kind. - character(len=*, kind=UCS4), intent(in) :: string !< Input string. - character(len=*), intent(in), optional :: color_fg !< Foreground color definition. - character(len=*), intent(in), optional :: color_bg !< Background color definition. - character(len=*), intent(in), optional :: style !< Style definition. - character(len=:, kind=UCS4), allocatable :: colorized !< Colorized string. - character(len=:, kind=UCS4), allocatable :: buffer !< Temporary buffer. - integer(int32) :: i !< Counter. - - colorized = string - if (present(color_fg)) then - i = color_index(upper(color_fg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(color_bg)) then - i = color_index(upper(color_bg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(style)) then - i = style_index(upper(style)) - if (i>0) then - buffer = CODE_START//trim(STYLES(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - endfunction colorize_ucs4 - - elemental function color_index(color) - !< Return the array-index corresponding to the queried color. - !< - !< @note Because Foreground and backround colors lists share the same name, no matter what array is used to find the color index. - !< Thus, the foreground array is used. - character(len=*), intent(in) :: color !< Color definition. - integer(int32) :: color_index !< Index into the colors arrays. - integer(int32) :: c !< Counter. - - color_index = 0 - do c=1, size(COLORS_FG, dim=2) - if (trim(COLORS_FG(1, c))==trim(adjustl(color))) then - color_index = c - exit - endif - enddo - endfunction color_index - - elemental function style_index(style) - !< Return the array-index corresponding to the queried style. - character(len=*), intent(in) :: style !< Style definition. - integer(int32) :: style_index !< Index into the styles array. - integer(int32) :: s !< Counter. - - style_index = 0 - do s=1, size(STYLES, dim=2) - if (trim(STYLES(1, s))==trim(adjustl(style))) then - style_index = s - exit - endif - enddo - endfunction style_index - - elemental function upper(string) - !< Return a string with all uppercase characters. - character(len=*), intent(in) :: string !< Input string. - character(len=len(string)) :: upper !< Upper case string. - integer :: n1 !< Characters counter. - integer :: n2 !< Characters counter. - - upper = string - do n1=1, len(string) - n2 = index(LOWER_ALPHABET, string(n1:n1)) - if (n2>0) upper(n1:n1) = UPPER_ALPHABET(n2:n2) - enddo - endfunction upper -endmodule face diff --git a/src/modules/FEMatrix/CMakeLists.txt b/src/modules/FEMatrix/CMakeLists.txt deleted file mode 100644 index a7b089be6..000000000 --- a/src/modules/FEMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FEMatrix_Method.F90 -) diff --git a/src/modules/FEMatrix/src/FEMatrix_Method.F90 b/src/modules/FEMatrix/src/FEMatrix_Method.F90 deleted file mode 100644 index 07d9985ac..000000000 --- a/src/modules/FEMatrix/src/FEMatrix_Method.F90 +++ /dev/null @@ -1,28 +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 FEMatrix_Method -USE MassMatrix_Method -USE STMassMatrix_Method -USE DiffusionMatrix_Method -USE STDiffusionMatrix_Method -USE ConvectiveMatrix_Method -USE STConvectiveMatrix_Method -USE StiffnessMatrix_Method -USE ElasticNitscheMatrix_Method -USE FacetMatrix_Method -END MODULE FEMatrix_Method diff --git a/src/modules/FEVariable/CMakeLists.txt b/src/modules/FEVariable/CMakeLists.txt deleted file mode 100644 index 2bf970d1a..000000000 --- a/src/modules/FEVariable/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FEVariable_Method.F90 -) \ No newline at end of file diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 deleted file mode 100644 index 965542d7e..000000000 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ /dev/null @@ -1,1626 +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 FEVariable_Method -USE BaseType, ONLY: FEVariable_, & - FEVariableScalar_, & - FEVariableVector_, & - FEVariableMatrix_, & - FEVariableConstant_, & - FEVariableSpace_, & - FEVariableTime_, & - FEVariableSpaceTime_ - -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 :: 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(=) - -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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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: 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: 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: 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: 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: 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: 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: 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: 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 - -!---------------------------------------------------------------------------- -! 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 - -END MODULE FEVariable_Method diff --git a/src/modules/FEVector/CMakeLists.txt b/src/modules/FEVector/CMakeLists.txt deleted file mode 100644 index 96973b09c..000000000 --- a/src/modules/FEVector/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FEVector_Method.F90 -) diff --git a/src/modules/FEVector/src/FEVector_Method.F90 b/src/modules/FEVector/src/FEVector_Method.F90 deleted file mode 100644 index 11c77e074..000000000 --- a/src/modules/FEVector/src/FEVector_Method.F90 +++ /dev/null @@ -1,21 +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 FEVector_Method - USE ForceVector_Method - USE STForceVector_Method -END MODULE FEVector_Method \ No newline at end of file diff --git a/src/modules/FFTW/CMakeLists.txt b/src/modules/FFTW/CMakeLists.txt deleted file mode 100644 index 225b83f30..000000000 --- a/src/modules/FFTW/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FFTW3.F90 -) diff --git a/src/modules/FFTW/src/FFTW3.F90 b/src/modules/FFTW/src/FFTW3.F90 deleted file mode 100644 index ad2c82000..000000000 --- a/src/modules/FFTW/src/FFTW3.F90 +++ /dev/null @@ -1,2231 +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 - -#ifdef USE_FFTW -MODULE FFTW3 -USE, INTRINSIC :: ISO_C_BINDING -INTEGER, PARAMETER :: C_FFTW_R2R_KIND = C_INT32_T -INTEGER(C_INT), PARAMETER :: FFTW_R2HC = 0 -INTEGER(C_INT), PARAMETER :: FFTW_HC2R = 1 -INTEGER(C_INT), PARAMETER :: FFTW_DHT = 2 -INTEGER(C_INT), PARAMETER :: FFTW_REDFT00 = 3 -INTEGER(C_INT), PARAMETER :: FFTW_REDFT01 = 4 -INTEGER(C_INT), PARAMETER :: FFTW_REDFT10 = 5 -INTEGER(C_INT), PARAMETER :: FFTW_REDFT11 = 6 -INTEGER(C_INT), PARAMETER :: FFTW_RODFT00 = 7 -INTEGER(C_INT), PARAMETER :: FFTW_RODFT01 = 8 -INTEGER(C_INT), PARAMETER :: FFTW_RODFT10 = 9 -INTEGER(C_INT), PARAMETER :: FFTW_RODFT11 = 10 -INTEGER(C_INT), PARAMETER :: FFTW_FORWARD = -1 -INTEGER(C_INT), PARAMETER :: FFTW_BACKWARD = +1 -INTEGER(C_INT), PARAMETER :: FFTW_MEASURE = 0 -INTEGER(C_INT), PARAMETER :: FFTW_DESTROY_INPUT = 1 -INTEGER(C_INT), PARAMETER :: FFTW_UNALIGNED = 2 -INTEGER(C_INT), PARAMETER :: FFTW_CONSERVE_MEMORY = 4 -INTEGER(C_INT), PARAMETER :: FFTW_EXHAUSTIVE = 8 -INTEGER(C_INT), PARAMETER :: FFTW_PRESERVE_INPUT = 16 -INTEGER(C_INT), PARAMETER :: FFTW_PATIENT = 32 -INTEGER(C_INT), PARAMETER :: FFTW_ESTIMATE = 64 -INTEGER(C_INT), PARAMETER :: FFTW_WISDOM_ONLY = 2097152 -INTEGER(C_INT), PARAMETER :: FFTW_ESTIMATE_PATIENT = 128 -INTEGER(C_INT), PARAMETER :: FFTW_BELIEVE_PCOST = 256 -INTEGER(C_INT), PARAMETER :: FFTW_NO_DFT_R2HC = 512 -INTEGER(C_INT), PARAMETER :: FFTW_NO_NONTHREADED = 1024 -INTEGER(C_INT), PARAMETER :: FFTW_NO_BUFFERING = 2048 -INTEGER(C_INT), PARAMETER :: FFTW_NO_INDIRECT_OP = 4096 -INTEGER(C_INT), PARAMETER :: FFTW_ALLOW_LARGE_GENERIC = 8192 -INTEGER(C_INT), PARAMETER :: FFTW_NO_RANK_SPLITS = 16384 -INTEGER(C_INT), PARAMETER :: FFTW_NO_VRANK_SPLITS = 32768 -INTEGER(C_INT), PARAMETER :: FFTW_NO_VRECURSE = 65536 -INTEGER(C_INT), PARAMETER :: FFTW_NO_SIMD = 131072 -INTEGER(C_INT), PARAMETER :: FFTW_NO_SLOW = 262144 -INTEGER(C_INT), PARAMETER :: FFTW_NO_FIXED_RADIX_LARGE_N = 524288 -INTEGER(C_INT), PARAMETER :: FFTW_ALLOW_PRUNING = 1048576 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: fftw_iodim - INTEGER(C_INT) :: n, is, os -END TYPE fftw_iodim - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: fftw_iodim64 - INTEGER(C_INTPTR_T) n, is, os -END TYPE fftw_iodim64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: fftwf_iodim - INTEGER(C_INT) n, is, os -END TYPE fftwf_iodim - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: fftwf_iodim64 - INTEGER(C_INTPTR_T) n, is, os -END TYPE fftwf_iodim64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft(rank,n,in,out,sign,flags) & - & BIND(C, name='fftw_plan_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_1d(n,in,out,sign,flags) & - & BIND(C, name='fftw_plan_dft_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_2d(n0,n1,in,out,sign,flags) & - & BIND(C, name='fftw_plan_dft_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_3d(n0,n1,n2,in,out,sign,flags) & - & BIND(C, name='fftw_plan_dft_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_many_dft(rank,n,howmany,in,inembed, & - & istride,idist,out,onembed,ostride,odist,sign,flags) & - & BIND(C, name='fftw_plan_many_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_many_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru_dft(rank,dims,howmany_rank,& - & howmany_dims,in,out,sign,flags) & - & BIND(C, name='fftw_plan_guru_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru_split_dft(rank,dims,howmany_rank,& - & howmany_dims,ri,ii,ro,io,flags) & - & BIND(C, name='fftw_plan_guru_split_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru_split_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru64_dft(rank,dims,howmany_rank,& - & howmany_dims,in,out,sign,flags) & - & BIND(C, name='fftw_plan_guru64_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru64_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru64_split_dft(rank,dims,howmany_rank,& - & howmany_dims,ri,ii,ro,io,flags) & - & BIND(C, name='fftw_plan_guru64_split_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru64_split_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_execute_dft(p,in,out) BIND(C, name='fftw_execute_dft') - IMPORT - TYPE(C_PTR), VALUE :: p - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftw_execute_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_execute_split_dft(p,ri,ii,ro,io) & - & BIND(C, name='fftw_execute_split_dft') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ri - REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ii - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io - END SUBROUTINE fftw_execute_split_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_many_dft_r2c(rank,n,howmany,in,inembed,& - & istride,idist,out,onembed,ostride,odist,flags) & - & BIND(C, name='fftw_plan_many_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_many_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c(rank,n,in,out,flags) & - & BIND(C, name='fftw_plan_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c_1d(n,in,out,flags) & - & BIND(C, name='fftw_plan_dft_r2c_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_r2c_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c_2d(n0,n1,in,out,flags) & - & BIND(C, name='fftw_plan_dft_r2c_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_r2c_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c_3d(n0,n1,n2,in,out,flags) & - & BIND(C, name='fftw_plan_dft_r2c_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_r2c_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_many_dft_c2r(rank,n,howmany,in,inembed,& - & istride,idist,out,onembed,ostride,odist,flags) & - & BIND(C, name='fftw_plan_many_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_many_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r(rank,n,in,out,flags) & - & BIND(C, name='fftw_plan_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r_1d(n,in,out,flags) & - & BIND(C, name='fftw_plan_dft_c2r_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_c2r_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r_2d(n0,n1,in,out,flags) & - & BIND(C, name='fftw_plan_dft_c2r_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_c2r_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r_3d(n0,n1,n2,in,out,flags) & - & BIND(C, name='fftw_plan_dft_c2r_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_dft_c2r_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru_dft_r2c(rank,dims,howmany_rank, & - & howmany_dims,in,out,flags) & - & BIND(C, name='fftw_plan_guru_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru_dft_c2r(rank,dims,howmany_rank, & - & howmany_dims,in,out,flags) & - & BIND(C, name='fftw_plan_guru_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru_split_dft_r2c(rank,dims,howmany_rank, & - & howmany_dims,in,ro,io,flags) & - & BIND(C, name='fftw_plan_guru_split_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru_split_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru_split_dft_c2r(rank,dims,howmany_rank, & - & howmany_dims,ri,ii,out,flags) & - & BIND(C, name='fftw_plan_guru_split_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru_split_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru64_dft_r2c(rank,dims,howmany_rank,& - & howmany_dims,in,out,flags) & - & BIND(C, name='fftw_plan_guru64_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru64_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru64_dft_c2r(rank,dims,howmany_rank,& - & howmany_dims,in,out,flags) & - & BIND(C, name='fftw_plan_guru64_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru64_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru64_split_dft_r2c(rank,dims,howmany_rank,& - & howmany_dims,in,ro,io,flags) & - & BIND(C, name='fftw_plan_guru64_split_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru64_split_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru64_split_dft_c2r(rank,dims,howmany_rank,& - & howmany_dims,ri,ii,out,flags) & - & BIND(C, name='fftw_plan_guru64_split_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru64_split_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_execute_dft_r2c(p,in,out) & - & BIND(C, name='fftw_execute_dft_r2c') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: in - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftw_execute_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_execute_dft_c2r(p,in,out) & - & BIND(C, name='fftw_execute_dft_c2r') - IMPORT - TYPE(C_PTR), VALUE :: p - COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftw_execute_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_execute_split_dft_r2c(p,in,ro,io) & - & BIND(C, name='fftw_execute_split_dft_r2c') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io - END SUBROUTINE fftw_execute_split_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_execute_split_dft_c2r(p,ri,ii,out) & - & BIND(C, name='fftw_execute_split_dft_c2r') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ri - REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ii - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftw_execute_split_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_many_r2r(rank,n,howmany,in,inembed,& - & istride, idist,out,onembed,ostride,odist,kind,flags) & - & BIND(C, name='fftw_plan_many_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_many_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_r2r(rank,n,in,out,kind,flags) & - & BIND(C, name='fftw_plan_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_r2r_1d(n,in,out,kind,flags) & - & BIND(C, name='fftw_plan_r2r_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_r2r_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_r2r_2d(n0,n1,in,out,kind0,kind1,flags) & - & BIND(C, name='fftw_plan_r2r_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_r2r_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_r2r_3d(n0,n1,n2,in,out,kind0,kind1,kind2, & - & flags) BIND(C, name='fftw_plan_r2r_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind2 - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_r2r_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru_r2r(rank,dims,howmany_rank, & - & howmany_dims,in,out,kind,flags) & - & BIND(C, name='fftw_plan_guru_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_plan_guru64_r2r(rank,dims,howmany_rank,& - & howmany_dims,in,out,kind,flags) & - & BIND(C, name='fftw_plan_guru64_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftw_plan_guru64_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_execute_r2r(p,in,out) BIND(C, name='fftw_execute_r2r') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: in - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftw_execute_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_destroy_plan(p) BIND(C, name='fftw_destroy_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - END SUBROUTINE fftw_destroy_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_forget_wisdom() BIND(C, name='fftw_forget_wisdom') - IMPORT - END SUBROUTINE fftw_forget_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_cleanup() BIND(C, name='fftw_cleanup') - IMPORT - END SUBROUTINE fftw_cleanup -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_set_timelimit(t) BIND(C, name='fftw_set_timelimit') - IMPORT - REAL(C_DOUBLE), VALUE :: t - END SUBROUTINE fftw_set_timelimit -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_plan_with_nthreads(nthreads) & - & BIND(C, name='fftw_plan_with_nthreads') - IMPORT - INTEGER(C_INT), VALUE :: nthreads - END SUBROUTINE fftw_plan_with_nthreads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_planner_nthreads() & - & BIND(C, name='fftw_planner_nthreads') - IMPORT - END FUNCTION fftw_planner_nthreads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_init_threads() & - & BIND(C, name='fftw_init_threads') - IMPORT - END FUNCTION fftw_init_threads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_cleanup_threads() BIND(C, name='fftw_cleanup_threads') - IMPORT - END SUBROUTINE fftw_cleanup_threads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE -! Unable to generate Fortran interface for fftw_threads_set_callback - SUBROUTINE fftw_make_planner_thread_safe() & - & BIND(C, name='fftw_make_planner_thread_safe') - IMPORT - END SUBROUTINE fftw_make_planner_thread_safe -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_export_wisdom_to_filename(filename) & - & BIND(C, name='fftw_export_wisdom_to_filename') - IMPORT - CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename - END FUNCTION fftw_export_wisdom_to_filename -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_export_wisdom_to_file(output_file) & - & BIND(C, name='fftw_export_wisdom_to_file') - IMPORT - TYPE(C_PTR), VALUE :: output_file - END SUBROUTINE fftw_export_wisdom_to_file -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_export_wisdom_to_string() & - & BIND(C, name='fftw_export_wisdom_to_string') - IMPORT - END FUNCTION fftw_export_wisdom_to_string -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_export_wisdom(write_char,data) & - & BIND(C, name='fftw_export_wisdom') - IMPORT - TYPE(C_FUNPTR), VALUE :: write_char - TYPE(C_PTR), VALUE :: data - END SUBROUTINE fftw_export_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_IMPORT_system_wisdom() & - & BIND(C, name='fftw_IMPORT_system_wisdom') - IMPORT - END FUNCTION fftw_IMPORT_system_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom_from_filename(filename) & - & BIND(C, name='fftw_IMPORT_wisdom_from_filename') - IMPORT - CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename - END FUNCTION fftw_IMPORT_wisdom_from_filename -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom_from_file(input_file) & - & BIND(C, name='fftw_IMPORT_wisdom_from_file') - IMPORT - TYPE(C_PTR), VALUE :: input_file - END FUNCTION fftw_IMPORT_wisdom_from_file -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom_from_string(input_string) & - & BIND(C, name='fftw_IMPORT_wisdom_from_string') - IMPORT - CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: input_string - END FUNCTION fftw_IMPORT_wisdom_from_string -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom(read_char,data) & - & BIND(C, name='fftw_IMPORT_wisdom') - IMPORT - TYPE(C_FUNPTR), VALUE :: read_char - TYPE(C_PTR), VALUE :: data - END FUNCTION fftw_IMPORT_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_fprint_plan(p,output_file) BIND(C, name='fftw_fprint_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - TYPE(C_PTR), VALUE :: output_file - END SUBROUTINE fftw_fprint_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_print_plan(p) BIND(C, name='fftw_print_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - END SUBROUTINE fftw_print_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_sprint_plan(p) BIND(C, name='fftw_sprint_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - END FUNCTION fftw_sprint_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_malloc(n) BIND(C, name='fftw_malloc') - IMPORT - INTEGER(C_SIZE_T), VALUE :: n - END FUNCTION fftw_malloc -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_alloc_real(n) BIND(C, name='fftw_alloc_real') - IMPORT - INTEGER(C_SIZE_T), VALUE :: n - END FUNCTION fftw_alloc_real -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftw_alloc_complex(n) & - & BIND(C, name='fftw_alloc_complex') - IMPORT - INTEGER(C_SIZE_T), VALUE :: n - END FUNCTION fftw_alloc_complex -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_free(p) BIND(C, name='fftw_free') - IMPORT - TYPE(C_PTR), VALUE :: p - END SUBROUTINE fftw_free -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftw_flops(p,add,mul,fmas) BIND(C, name='fftw_flops') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_DOUBLE), INTENT(OUT) :: add - REAL(C_DOUBLE), INTENT(OUT) :: mul - REAL(C_DOUBLE), INTENT(OUT) :: fmas - END SUBROUTINE fftw_flops -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - REAL(C_DOUBLE) FUNCTION fftw_estimate_cost(p) & - & BIND(C, name='fftw_estimate_cost') - IMPORT - TYPE(C_PTR), VALUE :: p - END FUNCTION fftw_estimate_cost -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - REAL(C_DOUBLE) FUNCTION fftw_cost(p) BIND(C, name='fftw_cost') - IMPORT - TYPE(C_PTR), VALUE :: p - END FUNCTION fftw_cost -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftw_alignment_of(p) & - & BIND(C, name='fftw_alignment_of') - IMPORT - REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: p - END FUNCTION fftw_alignment_of -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft(rank,n,in,out,sign,flags) & - & BIND(C, name='fftwf_plan_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_1d(n,in,out,sign,flags) & - & BIND(C, name='fftwf_plan_dft_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_2d(n0,n1,in,out,sign,flags) & - & BIND(C, name='fftwf_plan_dft_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_3d(n0,n1,n2,in,out,sign,flags) & - & BIND(C, name='fftwf_plan_dft_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_many_dft(rank,n,howmany,in,inembed,istride,& - & idist,out,onembed,ostride,odist,sign,flags) & - & BIND(C, name='fftwf_plan_many_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_many_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru_dft(rank,dims,howmany_rank,& - & howmany_dims,in,out,sign,flags) & - & BIND(C, name='fftwf_plan_guru_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru_split_dft(rank,dims,howmany_rank,& - & howmany_dims,ri,ii,ro,io,flags) & - & BIND(C, name='fftwf_plan_guru_split_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru_split_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru64_dft(rank,dims,howmany_rank,& - & howmany_dims,in,out,sign,flags) & - & BIND(C, name='fftwf_plan_guru64_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: sign - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru64_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru64_split_dft(rank,dims,howmany_rank,& - & howmany_dims,ri,ii,ro,io,flags) & - & BIND(C, name='fftwf_plan_guru64_split_dft') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru64_split_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_execute_dft(p,in,out) BIND(C, name='fftwf_execute_dft') - IMPORT - TYPE(C_PTR), VALUE :: p - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftwf_execute_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_execute_split_dft(p,ri,ii,ro,io) & - & BIND(C, name='fftwf_execute_split_dft') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ri - REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ii - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io - END SUBROUTINE fftwf_execute_split_dft -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_many_dft_r2c(rank,n,howmany,in,& - & inembed,istride,idist,out,onembed,ostride,odist,flags) & - & BIND(C, name='fftwf_plan_many_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_many_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c(rank,n,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c_1d(n,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_r2c_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_r2c_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c_2d(n0,n1,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_r2c_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_r2c_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c_3d(n0,n1,n2,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_r2c_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_r2c_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_many_dft_c2r(rank,n,howmany,in,inembed,& - & istride,idist,out,onembed,ostride,odist,flags) & - & BIND(C, name='fftwf_plan_many_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_many_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r(rank,n,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r_1d(n,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_c2r_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_c2r_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r_2d(n0,n1,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_c2r_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_c2r_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r_3d(n0,n1,n2,in,out,flags) & - & BIND(C, name='fftwf_plan_dft_c2r_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_dft_c2r_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru_dft_r2c(rank,dims,howmany_rank,& - & howmany_dims,in,out,flags) & - & BIND(C, name='fftwf_plan_guru_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru_dft_c2r(rank,dims,howmany_rank, & - & howmany_dims,in,out,flags) & - & BIND(C, name='fftwf_plan_guru_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru_split_dft_r2c(rank,dims,howmany_rank,& - & howmany_dims,in,ro,io,flags) & - & BIND(C, name='fftwf_plan_guru_split_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru_split_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru_split_dft_c2r(rank,dims,& - & howmany_rank,howmany_dims,ri,ii,out,flags) & - & BIND(C, name='fftwf_plan_guru_split_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru_split_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru64_dft_r2c(rank,dims,howmany_rank,& - & howmany_dims,in,out,flags) & - & BIND(C, name='fftwf_plan_guru64_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru64_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru64_dft_c2r(rank,dims,howmany_rank,& - & howmany_dims,in,out,flags) & - & BIND(C, name='fftwf_plan_guru64_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru64_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru64_split_dft_r2c(rank,dims, & - & howmany_rank,howmany_dims,in,ro,io,flags) & - & BIND(C, name='fftwf_plan_guru64_split_dft_r2c') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru64_split_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru64_split_dft_c2r(rank,dims,& - & howmany_rank,howmany_dims,ri,ii,out,flags) & - & BIND(C, name='fftwf_plan_guru64_split_dft_c2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru64_split_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_execute_dft_r2c(p,in,out) & - & BIND(C, name='fftwf_execute_dft_r2c') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: in - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftwf_execute_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_execute_dft_c2r(p,in,out) & - & BIND(C, name='fftwf_execute_dft_c2r') - IMPORT - TYPE(C_PTR), VALUE :: p - COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftwf_execute_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_execute_split_dft_r2c(p,in,ro,io) & - & BIND(C, name='fftwf_execute_split_dft_r2c') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io - END SUBROUTINE fftwf_execute_split_dft_r2c -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_execute_split_dft_c2r(p,ri,ii,out) & - & BIND(C, name='fftwf_execute_split_dft_c2r') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ri - REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ii - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftwf_execute_split_dft_c2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_many_r2r(rank,n,howmany,in,inembed,& - & istride,idist,out,onembed,ostride,odist,kind,flags) & - & BIND(C, name='fftwf_plan_many_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - INTEGER(C_INT), VALUE :: howmany - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed - INTEGER(C_INT), VALUE :: istride - INTEGER(C_INT), VALUE :: idist - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed - INTEGER(C_INT), VALUE :: ostride - INTEGER(C_INT), VALUE :: odist - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_many_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_r2r(rank,n,in,out,kind,flags) & - & BIND(C, name='fftwf_plan_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_r2r_1d(n,in,out,kind,flags) & - & BIND(C, name='fftwf_plan_r2r_1d') - IMPORT - INTEGER(C_INT), VALUE :: n - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_r2r_1d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_r2r_2d(n0,n1,in,out,kind0,kind1,flags) & - & BIND(C, name='fftwf_plan_r2r_2d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_r2r_2d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_r2r_3d(n0,n1,n2,in,out,kind0, & - & kind1,kind2,flags) BIND(C, name='fftwf_plan_r2r_3d') - IMPORT - INTEGER(C_INT), VALUE :: n0 - INTEGER(C_INT), VALUE :: n1 - INTEGER(C_INT), VALUE :: n2 - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 - INTEGER(C_FFTW_R2R_KIND), VALUE :: kind2 - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_r2r_3d -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & - BIND(C, name='fftwf_plan_guru_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_plan_guru64_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & - BIND(C, name='fftwf_plan_guru64_r2r') - IMPORT - INTEGER(C_INT), VALUE :: rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims - INTEGER(C_INT), VALUE :: howmany_rank - TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind - INTEGER(C_INT), VALUE :: flags - END FUNCTION fftwf_plan_guru64_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_execute_r2r(p,in,out) BIND(C, name='fftwf_execute_r2r') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: in - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out - END SUBROUTINE fftwf_execute_r2r -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_destroy_plan(p) BIND(C, name='fftwf_destroy_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - END SUBROUTINE fftwf_destroy_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_forget_wisdom() BIND(C, name='fftwf_forget_wisdom') - IMPORT - END SUBROUTINE fftwf_forget_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_cleanup() BIND(C, name='fftwf_cleanup') - IMPORT - END SUBROUTINE fftwf_cleanup -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_set_timelimit(t) BIND(C, name='fftwf_set_timelimit') - IMPORT - REAL(C_DOUBLE), VALUE :: t - END SUBROUTINE fftwf_set_timelimit -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_plan_with_nthreads(nthreads) BIND(C, name='fftwf_plan_with_nthreads') - IMPORT - INTEGER(C_INT), VALUE :: nthreads - END SUBROUTINE fftwf_plan_with_nthreads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_planner_nthreads() BIND(C, name='fftwf_planner_nthreads') - IMPORT - END FUNCTION fftwf_planner_nthreads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_init_threads() BIND(C, name='fftwf_init_threads') - IMPORT - END FUNCTION fftwf_init_threads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_cleanup_threads() BIND(C, name='fftwf_cleanup_threads') - IMPORT - END SUBROUTINE fftwf_cleanup_threads -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - ! Unable to generate Fortran interface for fftwf_threads_set_callback - SUBROUTINE fftwf_make_planner_thread_safe() BIND(C, name='fftwf_make_planner_thread_safe') - IMPORT - END SUBROUTINE fftwf_make_planner_thread_safe -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_export_wisdom_to_filename(filename) BIND(C, name='fftwf_export_wisdom_to_filename') - IMPORT - CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename - END FUNCTION fftwf_export_wisdom_to_filename -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_export_wisdom_to_file(output_file) BIND(C, name='fftwf_export_wisdom_to_file') - IMPORT - TYPE(C_PTR), VALUE :: output_file - END SUBROUTINE fftwf_export_wisdom_to_file -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_export_wisdom_to_string() BIND(C, name='fftwf_export_wisdom_to_string') - IMPORT - END FUNCTION fftwf_export_wisdom_to_string -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_export_wisdom(write_char,data) BIND(C, name='fftwf_export_wisdom') - IMPORT - TYPE(C_FUNPTR), VALUE :: write_char - TYPE(C_PTR), VALUE :: data - END SUBROUTINE fftwf_export_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_IMPORT_system_wisdom() BIND(C, name='fftwf_IMPORT_system_wisdom') - IMPORT - END FUNCTION fftwf_IMPORT_system_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom_from_filename(filename) BIND(C, name='fftwf_IMPORT_wisdom_from_filename') - IMPORT - CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename - END FUNCTION fftwf_IMPORT_wisdom_from_filename -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom_from_file(input_file) BIND(C, name='fftwf_IMPORT_wisdom_from_file') - IMPORT - TYPE(C_PTR), VALUE :: input_file - END FUNCTION fftwf_IMPORT_wisdom_from_file -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom_from_string(input_string) BIND(C, name='fftwf_IMPORT_wisdom_from_string') - IMPORT - CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: input_string - END FUNCTION fftwf_IMPORT_wisdom_from_string -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom(read_char,data) BIND(C, name='fftwf_IMPORT_wisdom') - IMPORT - TYPE(C_FUNPTR), VALUE :: read_char - TYPE(C_PTR), VALUE :: data - END FUNCTION fftwf_IMPORT_wisdom -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_fprint_plan(p,output_file) BIND(C, name='fftwf_fprint_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - TYPE(C_PTR), VALUE :: output_file - END SUBROUTINE fftwf_fprint_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_print_plan(p) BIND(C, name='fftwf_print_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - END SUBROUTINE fftwf_print_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_sprint_plan(p) BIND(C, name='fftwf_sprint_plan') - IMPORT - TYPE(C_PTR), VALUE :: p - END FUNCTION fftwf_sprint_plan -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_malloc(n) BIND(C, name='fftwf_malloc') - IMPORT - INTEGER(C_SIZE_T), VALUE :: n - END FUNCTION fftwf_malloc -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_alloc_real(n) BIND(C, name='fftwf_alloc_real') - IMPORT - INTEGER(C_SIZE_T), VALUE :: n - END FUNCTION fftwf_alloc_real -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - TYPE(C_PTR) FUNCTION fftwf_alloc_complex(n) BIND(C, name='fftwf_alloc_complex') - IMPORT - INTEGER(C_SIZE_T), VALUE :: n - END FUNCTION fftwf_alloc_complex -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_free(p) BIND(C, name='fftwf_free') - IMPORT - TYPE(C_PTR), VALUE :: p - END SUBROUTINE fftwf_free -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE fftwf_flops(p,add,mul,fmas) BIND(C, name='fftwf_flops') - IMPORT - TYPE(C_PTR), VALUE :: p - REAL(C_DOUBLE), INTENT(OUT) :: add - REAL(C_DOUBLE), INTENT(OUT) :: mul - REAL(C_DOUBLE), INTENT(OUT) :: fmas - END SUBROUTINE fftwf_flops -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - REAL(C_DOUBLE) FUNCTION fftwf_estimate_cost(p) BIND(C, name='fftwf_estimate_cost') - IMPORT - TYPE(C_PTR), VALUE :: p - END FUNCTION fftwf_estimate_cost -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - REAL(C_DOUBLE) FUNCTION fftwf_cost(p) BIND(C, name='fftwf_cost') - IMPORT - TYPE(C_PTR), VALUE :: p - END FUNCTION fftwf_cost -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - INTEGER(C_INT) FUNCTION fftwf_alignment_of(p) BIND(C, name='fftwf_alignment_of') - IMPORT - REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: p - END FUNCTION fftwf_alignment_of -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE FFTW3 -#endif \ No newline at end of file diff --git a/src/modules/FPL/CMakeLists.txt b/src/modules/FPL/CMakeLists.txt deleted file mode 100644 index 2c7dc8619..000000000 --- a/src/modules/FPL/CMakeLists.txt +++ /dev/null @@ -1,17 +0,0 @@ -################################################################# -# Search F90 files recursively in all subdirs -################################################################# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -FILE(GLOB_RECURSE WRAPPER_LIB_SRC ${src_path}/Wrapper/*.F90) -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${WRAPPER_LIB_SRC} - ${src_path}/ErrorMessages.F90 - ${src_path}/FPL_utils.F90 - ${src_path}/FPL.F90 - ${src_path}/ParameterEntry.F90 - ${src_path}/ParameterEntryDictionary.F90 - ${src_path}/ParameterList.F90 - ${src_path}/ParameterRootEntry.F90 - ) \ No newline at end of file diff --git a/src/modules/FPL/LICENSE b/src/modules/FPL/LICENSE deleted file mode 100644 index 02bbb60bc..000000000 --- a/src/modules/FPL/LICENSE +++ /dev/null @@ -1,165 +0,0 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser General Public License from time to time. Such new -versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. \ No newline at end of file diff --git a/src/modules/FPL/src/ErrorMessages.F90 b/src/modules/FPL/src/ErrorMessages.F90 deleted file mode 100644 index b01db881a..000000000 --- a/src/modules/FPL/src/ErrorMessages.F90 +++ /dev/null @@ -1,123 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -MODULE ErrorMessages -USE ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT, ERROR_UNIT -USE PENF, ONLY: I4P, str - -IMPLICIT NONE -PRIVATE - -INTEGER(I4P), PUBLIC, PARAMETER :: FPLSuccess = 0 -INTEGER(I4P), PUBLIC, PARAMETER :: FPLWrapperFactoryError = -1 -INTEGER(I4P), PUBLIC, PARAMETER :: FPLWrapperError = -2 -INTEGER(I4P), PUBLIC, PARAMETER :: FPLSublistError = -3 -INTEGER(I4P), PUBLIC, PARAMETER :: FPLParameterListIteratorError = -4 - -TYPE :: MessageHandler_t - PRIVATE - CHARACTER(5) :: prefix = '[FPL]' -CONTAINS - PROCEDURE, NON_OVERRIDABLE :: PRINT => MessageHandler_Print - PROCEDURE, NON_OVERRIDABLE :: Warn => MessageHandler_Warn - PROCEDURE, NON_OVERRIDABLE :: Error => MessageHandler_Error -END TYPE - -TYPE(MessageHandler_t), SAVE :: msg -!$OMP THREADPRIVATE(msg) - -PUBLIC :: msg - -CONTAINS - -SUBROUTINE MessageHandler_Print(this, txt, unit, iostat, iomsg) - !----------------------------------------------------------------- - !< Print a txt message preceding for prefix - !----------------------------------------------------------------- - CLASS(MessageHandler_t), INTENT(IN) :: this !< Message handler - CHARACTER(*), INTENT(IN) :: txt !< Text to print - INTEGER(I4P), OPTIONAL, INTENT(IN) :: unit !< Unit where to print - INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. - CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. - INTEGER(I4P) :: iostatd !< Real IO error. - INTEGER(I4P) :: u !< Real unit - CHARACTER(500) :: iomsgd !< Real IO error message. - !----------------------------------------------------------------- - u = OUTPUT_UNIT; IF (PRESENT(unit)) u = unit; iostatd = 0; - iomsgd = '' - WRITE (unit=u, fmt='(A)', iostat=iostatd, iomsg=iomsgd) & - & this%Prefix//' '//txt - IF (PRESENT(iostat)) iostat = iostatd - IF (PRESENT(iomsg)) iomsg = iomsgd -END SUBROUTINE - -SUBROUTINE MessageHandler_Warn(this, txt, unit, file, line, iostat, iomsg) - !----------------------------------------------------------------- - !< Warn a with txt message preceding for WARNING! - !----------------------------------------------------------------- - CLASS(MessageHandler_t), INTENT(IN) :: this !< Message handler - CHARACTER(*), INTENT(IN) :: txt !< Text to print - INTEGER(I4P), OPTIONAL, INTENT(IN) :: unit !< Unit where to print - CHARACTER(*), OPTIONAL, INTENT(IN) :: file !< Source file - INTEGER(I4P), OPTIONAL, INTENT(IN) :: line !< Number of line in source file - INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. - CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. - CHARACTER(:), ALLOCATABLE :: loc !< Warning location string - INTEGER(I4P) :: iostatd !< Real IO error. - INTEGER(I4P) :: u !< Real unit - CHARACTER(500) :: iomsgd !< Real IO error message. - !----------------------------------------------------------------- - u = ERROR_UNIT; IF (PRESENT(unit)) u = unit; iostatd = 0; - iomsgd = ''; loc = '' - IF (PRESENT(file) .AND. PRESENT(line)) & - & loc = '('//file//':'//TRIM(str(no_sign=.TRUE., n=line))//') ' - call this%Print('WARNING! '//trim(adjustl(loc//txt)), & - & unit=u, iostat=iostatd, iomsg=iomsgd) - IF (PRESENT(iostat)) iostat = iostatd - IF (PRESENT(iomsg)) iomsg = iomsgd -END SUBROUTINE - -SUBROUTINE MessageHandler_Error(this, txt, unit, file, line, iostat, iomsg) - !----------------------------------------------------------------- - !< Print a txt message preceding for ERROR! - !----------------------------------------------------------------- - CLASS(MessageHandler_t), INTENT(IN) :: this !< Message handler - CHARACTER(*), INTENT(IN) :: txt !< Text to print - INTEGER(I4P), OPTIONAL, INTENT(IN) :: unit !< Unit where to print - CHARACTER(*), OPTIONAL, INTENT(IN) :: file !< Source file - INTEGER(I4P), OPTIONAL, INTENT(IN) :: line !< Number of line in source file - INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. - CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. - CHARACTER(:), ALLOCATABLE :: loc !< Error location string - INTEGER(I4P) :: iostatd !< Real IO error. - INTEGER(I4P) :: u !< Real unit - CHARACTER(500) :: iomsgd !< Real IO error message. - !----------------------------------------------------------------- - u = ERROR_UNIT; IF (PRESENT(unit)) u = unit; iostatd = 0; iomsgd = '' - loc = '' - IF (PRESENT(file) .AND. PRESENT(line)) & - & loc = '('//file//':'//TRIM(str(no_sign=.TRUE., n=line))//') ' - call this%Print('ERROR! '//trim(adjustl(loc//txt)), & - & unit=u, iostat=iostatd, iomsg=iomsgd) - IF (PRESENT(iostat)) iostat = iostatd - IF (PRESENT(iomsg)) iomsg = iomsgd -END SUBROUTINE - -END MODULE diff --git a/src/modules/FPL/src/FPL.F90 b/src/modules/FPL/src/FPL.F90 deleted file mode 100644 index 9011c95c9..000000000 --- a/src/modules/FPL/src/FPL.F90 +++ /dev/null @@ -1,54 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -#define ParameterList_t ParameterList_ -#define ParameterListIterator_t ParameterListIterator_ - -MODULE FPL -USE ParameterList -USE WrapperFactoryListSingleton -PRIVATE -PUBLIC :: ParameterList_t, ParameterListIterator_t -PUBLIC :: FPL_Init -PUBLIC :: FPL_Finalize - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-02 -! summary: Initialize FPL - -SUBROUTINE FPL_Init() - CALL TheWrapperFactoryList_Init() -END SUBROUTINE FPL_Init - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE FPL_Finalize() - CALL TheWrapperFactoryList%Free() -END SUBROUTINE FPL_Finalize - -END MODULE FPL diff --git a/src/modules/FPL/src/FPL_utils.F90 b/src/modules/FPL/src/FPL_utils.F90 deleted file mode 100644 index 978416506..000000000 --- a/src/modules/FPL/src/FPL_utils.F90 +++ /dev/null @@ -1,45 +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 FPL_Utils -USE PENF, only: I1P, I4P -contains - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! 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 - !! Character variable whose number of bits must be computed. - integer(I4P) :: bytes - !! Number of bits of l. - 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -end module FPL_Utils diff --git a/src/modules/FPL/src/ParameterEntry.F90 b/src/modules/FPL/src/ParameterEntry.F90 deleted file mode 100644 index d3e82886a..000000000 --- a/src/modules/FPL/src/ParameterEntry.F90 +++ /dev/null @@ -1,381 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter Entry) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module ParameterEntry - -USE PENF -USE DimensionsWrapper - -implicit none -private - -type :: EntryListIterator_t - private - type(ParameterEntry_t), pointer :: CurrentEntry => NULL() -contains - private - procedure, non_overridable :: EntryListIterator_Assignment - procedure, public, non_overridable :: Init => EntryListIterator_Init - procedure, public, non_overridable :: Next => EntryListIterator_Next - procedure, public, non_overridable :: HasFinished => & - & EntryListIterator_HasFinished - procedure, public, non_overridable :: GetEntry => EntryListIterator_GetEntry - procedure, public, non_overridable :: GetKey => EntryListIterator_GetKey - procedure, public, non_overridable :: PointToValue => & - & EntryListIterator_PointToValue - procedure, public, non_overridable :: Free => EntryListIterator_Free - generic, public :: Assignment(=) => EntryListIterator_Assignment - final :: EntryListIterator_Final -end type - -type :: ParameterEntry_t - private - character(len=:), allocatable :: Key - class(*), pointer :: Value => NULL() - class(ParameterEntry_t), pointer :: Next => NULL() -contains - private - procedure, non_overridable, public :: Free => ParameterEntry_Free - procedure, non_overridable, public :: Print => ParameterEntry_Print - procedure, non_overridable, public :: HasNext => ParameterEntry_HasNext - procedure, non_overridable, public :: SetNext => ParameterEntry_SetNext - procedure, non_overridable, public :: GetNext => ParameterEntry_GetNext - procedure, non_overridable, public :: NullifyNext => & - & ParameterEntry_NullifyNext - procedure, non_overridable, public :: HasKey => ParameterEntry_HasKey - procedure, non_overridable, public :: SetKey => ParameterEntry_SetKey - procedure, non_overridable, public :: GetKey => ParameterEntry_GetKey - procedure, non_overridable, public :: DeallocateKey => & - & ParameterEntry_DeallocateKey - procedure, non_overridable, public :: HasValue => ParameterEntry_HasValue - procedure, non_overridable, public :: SetValue => ParameterEntry_SetValue - procedure, non_overridable, public :: GetValue => ParameterEntry_GetValue - procedure, non_overridable, public :: DeallocateValue => & - & ParameterEntry_DeallocateValue - procedure, non_overridable, public :: PointToValue => & - & ParameterEntry_PointToValue - procedure, non_overridable, public :: GetIterator => & - & ParameterEntry_GetIterator - final :: ParameterEntry_Finalize -end type ParameterEntry_t - -public :: ParameterEntry_t -public :: EntryListIterator_t - -contains - -function ParameterEntry_HasNext(this) result(hasNext) - - !< Check if Next is associated for the current Node - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - logical :: hasNext !< Check if Next is associated - - hasNext = associated(this%Next) -end function ParameterEntry_HasNext - -subroutine ParameterEntry_SetNext(this, Next) - - !< Set the pointer to the Next node - - class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - class(ParameterEntry_t), pointer, intent(IN) :: Next !< Pointer to Next - - this%Next => Next -end subroutine ParameterEntry_SetNext - -function ParameterEntry_GetNext(this) result(Next) - - !< Return a pointer to the Next node - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - class(ParameterEntry_t), pointer :: Next !< Pointer to Next - - nullify (Next) - if (this%HasNext()) Next => this%Next -end function ParameterEntry_GetNext - -subroutine ParameterEntry_NullifyNext(this) - - !< Nullify Next - - class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - - nullify (this%Next) -end subroutine ParameterEntry_NullifyNext - -function ParameterEntry_HasKey(this) result(hasKey) - - !< Check if Key is allocated for the current Node - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - logical :: hasKey !< Check if Key is associated - - hasKey = allocated(this%Key) -end function ParameterEntry_HasKey - -subroutine ParameterEntry_SetKey(this, Key) - - !< Check if Next is associated for the current Node - - class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - character(len=*), intent(IN) :: Key !< Key - - this%Key = Key -end subroutine ParameterEntry_SetKey - -subroutine ParameterEntry_GetKey(this, Key) - - !< Return entry key - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - character(len=:), allocatable, intent(INOUT) :: Key !< Key - - Key = this%Key -end subroutine ParameterEntry_GetKey - -subroutine ParameterEntry_DeallocateKey(this) - - !< Deallocate Key if allocated - - class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - - if (this%HasKey()) deallocate (this%Key) -end subroutine ParameterEntry_DeallocateKey - -subroutine ParameterEntry_Free(this) - - !< Free the Entry - - class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - - call this%DeallocateKey() - call this%DeallocateValue() - call this%NullifyNext() -end subroutine ParameterEntry_Free - -function ParameterEntry_HasValue(this) result(hasValue) - - !< Check if Value is allocated for the current Node - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - logical :: hasValue !< Check if Value is allocated - - hasValue = associated(this%Value) -end function ParameterEntry_HasValue - -subroutine ParameterEntry_SetValue(this, Value) - - !< Set a concrete Wrapper - - class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - class(*), pointer, intent(IN) :: Value !< Concrete Wrapper - - if (this%HasValue()) deallocate (this%Value) - this%Value => Value -end subroutine ParameterEntry_SetValue - -subroutine ParameterEntry_GetValue(this, Value) - - !< Return a concrete WrapperFactory - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - class(*), allocatable, intent(OUT) :: Value !< Concrete Wrapper - - if (this%HasValue()) allocate (Value, source=this%Value) -end subroutine ParameterEntry_GetValue - -function ParameterEntry_PointToValue(this) result(Value) - - !< Return a pointer to a concrete WrapperFactory - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - class(*), pointer :: Value !< Concrete Wrapper - - Value => this%Value -end function ParameterEntry_PointToValue - -subroutine ParameterEntry_DeallocateValue(this) - - !< Deallocate Key if allocated - - class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - - if (this%HasValue()) deallocate (this%Value) -end subroutine ParameterEntry_DeallocateValue - -subroutine ParameterEntry_Finalize(this) - - !< Finalize procedure - - type(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry - - call this%Free() -end subroutine ParameterEntry_Finalize - -function ParameterEntry_GetIterator(this) result(Iterator) - - !< Free the list - - class(ParameterEntry_t), target, intent(INOUT) :: this !< Parameter Entry - type(EntryListIterator_t) :: Iterator !< List iterator - - call Iterator%Init(Entry=this) -end function ParameterEntry_GetIterator - -subroutine ParameterEntry_Print(this, unit, prefix, iostat, iomsg) - - !< Print the keys/value pair contained in the Parameter Entry - - class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry - 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 :: Key !< Entry Key - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - - iostatd = 0; iomsgd = ''; prefd = ''; if (present(prefix)) prefd = prefix - if (this%HasKey()) then - call this%GetKey(Key) - write (unit=unit, fmt='(A)', advance="NO", iostat=iostatd, & - & iomsg=iomsgd) prefd//' Key = "'//Key//'", ' - !! - select type (Wrapper => this%Value) - class is (DimensionsWrapper_t) - call Wrapper%Print(unit=unit) - class Default - write (unit=unit, fmt='(A)', iostat=iostatd, iomsg=iomsgd) & - & ' is a Parameter SubList' - end select - end if - - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd -end subroutine ParameterEntry_Print - -!--------------------------------------------------------------------- -!< Entry List Iterator Procedures -!--------------------------------------------------------------------- - -subroutine EntryListIterator_Assignment(this, ListIterator) - - !< Assignment operator - - class(EntryListIterator_t), intent(INOUT) :: this ! Output List iterator - type(EntryListIterator_t), intent(IN) :: ListIterator ! Input List iterator - - this%CurrentEntry => ListIterator%CurrentEntry -end subroutine EntryListIterator_Assignment - -subroutine EntryListIterator_Free(this) - - !< Free the List iterator - - class(EntryListIterator_t), intent(INOUT) :: this ! List iterator - - nullify (this%CurrentEntry) -end subroutine EntryListIterator_Free - -subroutine EntryListIterator_Final(this) - - !< Free the List iterator - - type(EntryListIterator_t), intent(INOUT) :: this ! List iterator - - call this%Free() -end subroutine EntryListIterator_Final - -subroutine EntryListIterator_Init(this, Entry) - - !< Associate the iterator with an entry - - class(EntryListIterator_t), intent(INOUT) :: this ! List iterator - type(ParameterEntry_t), target, intent(IN) :: Entry ! List entry - - call this%Free() - this%CurrentEntry => Entry -end subroutine EntryListIterator_Init - -subroutine EntryListIterator_Next(this) - - !< The iterator points to the next associated entry - - class(EntryListIterator_t), intent(INOUT) :: this ! List iterator - -if (.not. this%HasFinished()) this%CurrentEntry => this%CurrentEntry%GetNext() -end subroutine EntryListIterator_Next - -function EntryListIterator_GetEntry(this) result(CurrentEntry) - - !< Return the current Entry - - class(EntryListIterator_t), intent(IN) :: this ! List iterator - type(ParameterEntry_t), pointer :: CurrentEntry ! Current entry - - nullify (CurrentEntry) - CurrentEntry => this%CurrentEntry -end function EntryListIterator_GetEntry - -subroutine EntryListIterator_GetKey(this, Key) - - !< Return the current Key - - class(EntryListIterator_t), intent(IN) :: this ! List iterator - character(len=:), allocatable, intent(INOUT) :: Key ! Entry Key - type(ParameterEntry_t), pointer :: CurrentEntry ! Current entry - - if (associated(this%CurrentEntry)) then - if (this%CurrentEntry%HasKey()) call this%CurrentEntry%GetKey(Key) - end if -end subroutine EntryListIterator_GetKey - -function EntryListIterator_PointToValue(this) result(Value) - - !< Return the current Value - - class(EntryListIterator_t), intent(IN) :: this ! List iterator - type(ParameterEntry_t), pointer :: CurrentEntry ! Current entry - class(*), pointer :: Value ! Entry Value - - nullify (Value) - if (associated(this%CurrentEntry)) then - if (this%CurrentEntry%HasValue()) Value => this%CurrentEntry%PointToValue() - end if -end function EntryListIterator_PointToValue - -function EntryListIterator_HasFinished(this) result(HasFinished) - - !< Check if Iterator has reached the end of the dictionary - - class(EntryListIterator_t), intent(IN) :: this ! List iterator - logical :: HasFinished ! Check if has reached the end of the list - - HasFinished = .false. - if (.not. associated(this%CurrentEntry)) then - HasFinished = .true. - elseif (.not. this%CurrentEntry%HasNext()) then - HasFinished = .true. - end if -end function EntryListIterator_HasFinished - -end module ParameterEntry diff --git a/src/modules/FPL/src/ParameterEntryDictionary.F90 b/src/modules/FPL/src/ParameterEntryDictionary.F90 deleted file mode 100644 index fbf85a0f0..000000000 --- a/src/modules/FPL/src/ParameterEntryDictionary.F90 +++ /dev/null @@ -1,336 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -!----------------------------------------------------------------- -! ParameterEntryDictionary is a datatype containing a Database -! array of ParameterListEntries made to store diferent Entries -! depending on the hash of its Key. -! -! This work takes as a starting point the previou work of -! Stefano Zaghi (@szaghi, https://github.com/szaghi). -! -! You can find the original source at: -! https://github.com/szaghi/OFF/blob/ -!95691ca15e6d68128ba016e40df74e42123f1c54/ -!src/Data_Type_Hash_Table.f90 -!----------------------------------------------------------------- - -MODULE ParameterEntryDictionary - -USE ParameterEntry -USE ParameterRootEntry -USE PENF, ONLY: I4P, str - -IMPLICIT NONE -PRIVATE - -INTEGER(I4P), PARAMETER :: DefaultDataBaseSize = 100_I4P - -TYPE :: ParameterEntryDictionary_t - PRIVATE - TYPE(ParameterRootEntry_t), ALLOCATABLE :: DataBase(:) - INTEGER(I4P) :: Size = 0_I4P -CONTAINS - PRIVATE - PROCEDURE, NON_OVERRIDABLE :: Hash => & - & ParameterEntryDictionary_Hash - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Init => & - & ParameterEntryDictionary_Init - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Set => & - & ParameterEntryDictionary_Set - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Get => & - & ParameterEntryDictionary_Get - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetPointer => & - & ParameterEntryDictionary_GetPointer - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetDatabase => & - & ParameterEntryDictionary_GetDataBase - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Del => & - & ParameterEntryDictionary_Delete - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: IsPresent => & - & ParameterEntryDictionary_IsPresent - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Length => & - & ParameterEntryDictionary_Length - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: PRINT => & - & ParameterEntryDictionary_Print - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Free => & - & ParameterEntryDictionary_Free - FINAL :: ParameterEntryDictionary_Finalize -END TYPE - -PUBLIC :: ParameterEntryDictionary_t - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterEntryDictionary_Hash(this, Key) RESULT(Hash) - - !< String hash function - - CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this - !< Parameter Entry Dictionary - CHARACTER(*), INTENT(IN) :: Key - !< String Key - INTEGER(I4P) :: Hash - !< Hash code - CHARACTER, DIMENSION(LEN(Key)) :: CharArray - !< Character array containing the Key - INTEGER(I4P) :: CharIterator - !< Char iterator index - - DO CONCURRENT(CharIterator=1:LEN(Key)) - CharArray(CharIterator) = Key(CharIterator:CharIterator) - END DO - Hash = MOD(SUM(ICHAR(CharArray)), this%Size) -END FUNCTION ParameterEntryDictionary_Hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterEntryDictionary_Init(this, Size) - - !< Allocate the database with a given Szie of DefaultDataBaseSize - - CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this - !< Parameter Entry Dictionary - INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size - !< DataBase Size - - CALL this%Free() - IF (PRESENT(Size)) THEN - this%Size = Size - ELSE - this%Size = DefaultDataBaseSize - END IF - ALLOCATE (this%DataBase(0:this%Size - 1)) -END SUBROUTINE ParameterEntryDictionary_Init - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterEntryDictionary_isPresent(this, Key) RESULT(isPresent) - - !< Check if a Key is present in the DataBase - - CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this - !< Parameter Entry Dictionary - CHARACTER(*), INTENT(IN) :: Key - !< String Key - LOGICAL :: isPresent - !< Boolean flag to check if a Key is present - - isPresent = this%DataBase(this%Hash(Key=Key))%isPresent(Key=Key) -END FUNCTION ParameterEntryDictionary_isPresent - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterEntryDictionary_Set(this, Key, VALUE) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this - !< Parameter Entry Dictionary - CHARACTER(*), INTENT(IN) :: Key - !< String Key - CLASS(*), POINTER, INTENT(IN) :: VALUE - !< Value - - CALL this%DataBase(this%Hash(Key=Key))%AddEntry(Key=Key, VALUE=VALUE) -END SUBROUTINE ParameterEntryDictionary_Set - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterEntryDictionary_Get(this, Key, VALUE) - - !< Return a Value given the Key - - CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this - !< Parameter Entry Dictionary - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), ALLOCATABLE, INTENT(INOUT) :: VALUE - !< Returned value - CLASS(ParameterEntry_t), POINTER :: ENTRY - !< Pointer to a Parameter List - - ENTRY => this%DataBase(this%Hash(Key=Key))%GetEntry(Key=Key) - IF (ASSOCIATED(ENTRY)) CALL ENTRY%GetValue(VALUE=VALUE) -END SUBROUTINE ParameterEntryDictionary_Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterEntryDictionary_GetPointer(this, Key, VALUE) - - !< Return a Value given the Key - - CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this !< Parameter Entry Dictionary - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE !< Returned value - CLASS(ParameterEntry_t), POINTER :: ENTRY !< Pointer to a Parameter List - INTEGER(I4P) :: Hash !< Hash code corresponding to Key - - ENTRY => this%DataBase(this%Hash(Key=Key))%GetEntry(Key=Key) - IF (ASSOCIATED(ENTRY)) VALUE => ENTRY%PointToValue() -END SUBROUTINE ParameterEntryDictionary_GetPointer - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterEntryDictionary_GetDataBase(this) RESULT(Database) - - !< Return a pointer to a Dictionary Database - - CLASS(ParameterEntryDictionary_t), TARGET, INTENT(IN) :: this - !< Parameter Entry Dictionary - TYPE(ParameterRootEntry_t), POINTER :: Database(:) - !< Dictionary Database - - DataBase => this%Database -END FUNCTION ParameterEntryDictionary_GetDataBase - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterEntryDictionary_Delete(this, Key) - - !< Remove an Entry given a Key - - CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this - !< Parameter Entry Dictionary - CHARACTER(*), INTENT(IN) :: Key - !< String Key - - CALL this%DataBase(this%Hash(Key=Key))%RemoveEntry(Key=Key) -END SUBROUTINE ParameterEntryDictionary_Delete - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterEntryDictionary_Length(this) RESULT(Length) - - !< Return the number of ParameterListEntries contained in the DataBase - - CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this - !< Parameter Entry Dictionary - INTEGER(I4P) :: Length - !< Number of parameters in database - INTEGER(I4P) :: DBIterator - !< Database Iterator index - - Length = 0 - IF (ALLOCATED(this%DataBase)) THEN - DO DBIterator = LBOUND(this%DataBase, dim=1), UBOUND(this%DataBase, dim=1) - Length = Length + this%DataBase(DBIterator)%Length() - END DO - END IF -END FUNCTION ParameterEntryDictionary_Length - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterentryDictionary_Free(this) - - !< Free ParameterListEntries and the DataBase - - CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this - !< Parameter Entry Dictionary - INTEGER(I4P) :: DBIterator - !< Database Iterator index - - IF (ALLOCATED(this%DataBase)) THEN - DO DBIterator = LBOUND(this%DataBase, dim=1), UBOUND(this%DataBase, dim=1) - CALL this%DataBase(DBIterator)%Free() - END DO - DEALLOCATE (this%DataBase) - END IF - this%Size = 0_I4P -END SUBROUTINE ParameterEntryDictionary_Free - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterEntryDictionary_Finalize(this) - - !< Destructor procedure - - TYPE(ParameterEntryDictionary_t), INTENT(INOUT) :: this - !< Parameter Entry Dictionary - - CALL this%Free() -END SUBROUTINE ParameterEntryDictionary_Finalize - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterEntryDictionary_Print(this, unit, prefix, iostat, iomsg) - - !< Print the content of the DataBase - - CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this - !< Linked List - 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(:), ALLOCATABLE :: prefd - !< Prefixing string. - INTEGER(I4P) :: iostatd - !< IO error. - CHARACTER(500) :: iomsgd - !< Temporary variable for IO error message. - INTEGER(I4P) :: DBIter - !< Database iterator - - prefd = ''; IF (PRESENT(prefix)) prefd = prefix - IF (ALLOCATED(this%DataBase)) THEN - DO DBIter = LBOUND(this%DataBase, dim=1), UBOUND(this%DataBase, dim=1) - CALL this%DataBase(DBIter)%PRINT(unit=unit, & - prefix=prefd//' ['//TRIM(str(no_sign=.TRUE., n=DBIter))//'] ', & - iostat=iostatd, iomsg=iomsgd) - END DO - END IF - IF (PRESENT(iostat)) iostat = iostatd - IF (PRESENT(iomsg)) iomsg = iomsgd -END SUBROUTINE ParameterEntryDictionary_Print - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ParameterEntryDictionary diff --git a/src/modules/FPL/src/ParameterList.F90 b/src/modules/FPL/src/ParameterList.F90 deleted file mode 100644 index aec8a6919..000000000 --- a/src/modules/FPL/src/ParameterList.F90 +++ /dev/null @@ -1,2742 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -#define ParameterList_t ParameterList_ -#define ParameterListIterator_t ParameterListIterator_ - -MODULE ParameterList - -USE ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT -USE ErrorMessages -USE PENF -USE ParameterEntryDictionary -USE ParameterRootEntry -USE ParameterEntry -USE WrapperFactoryListSingleton -USE WrapperFactory -USE DimensionsWrapper -USE DimensionsWrapper0D -USE DimensionsWrapper1D -USE DimensionsWrapper2D -USE DimensionsWrapper3D -USE DimensionsWrapper4D -USE DimensionsWrapper5D -USE DimensionsWrapper6D -USE DimensionsWrapper7D - -IMPLICIT NONE -PRIVATE -PUBLIC :: ParameterList_t -PUBLIC :: ParameterListIterator_t - -!---------------------------------------------------------------------------- -! ParameterList_t -!---------------------------------------------------------------------------- - -TYPE :: ParameterList_t - PRIVATE - TYPE(ParameterEntryDictionary_t) :: Dictionary -CONTAINS - PRIVATE - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set0D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set1D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set2D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set3D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set4D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set5D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set6D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set7D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get0D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get1D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get2D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get3D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get4D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get5D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get6D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get7D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer0D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer1D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer2D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer3D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer4D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer5D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer6D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer7D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType0D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType1D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType2D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType3D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType4D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType5D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType6D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType7D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable0D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable1D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable2D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable3D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable4D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable5D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable6D - PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable7D - GENERIC, PUBLIC :: Set => ParameterList_Set0D, & - ParameterList_Set1D, & - ParameterList_Set2D, & - ParameterList_Set3D, & - ParameterList_Set4D, & - ParameterList_Set5D, & - ParameterList_Set6D, & - ParameterList_Set7D - GENERIC, PUBLIC :: Get => ParameterList_Get0D, & - ParameterList_Get1D, & - ParameterList_Get2D, & - ParameterList_Get3D, & - ParameterList_Get4D, & - ParameterList_Get5D, & - ParameterList_Get6D, & - ParameterList_Get7D - GENERIC, PUBLIC :: GetPointer => ParameterList_GetPointer0D, & - ParameterList_GetPointer1D, & - ParameterList_GetPointer2D, & - ParameterList_GetPointer3D, & - ParameterList_GetPointer4D, & - ParameterList_GetPointer5D, & - ParameterList_GetPointer6D, & - ParameterList_GetPointer7D - GENERIC, PUBLIC :: isOfDataType => ParameterList_IsOfDataType0D, & - ParameterList_IsOfDataType1D, & - ParameterList_IsOfDataType2D, & - ParameterList_IsOfDataType3D, & - ParameterList_IsOfDataType4D, & - ParameterList_IsOfDataType5D, & - ParameterList_IsOfDataType6D, & - ParameterList_IsOfDataType7D - GENERIC, PUBLIC :: isAssignable => ParameterList_isAssignable0D, & - ParameterList_isAssignable1D, & - ParameterList_isAssignable2D, & - ParameterList_isAssignable3D, & - ParameterList_isAssignable4D, & - ParameterList_isAssignable5D, & - ParameterList_isAssignable6D, & - ParameterList_isAssignable7D - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: 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 - 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 - 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 - FINAL :: ParameterList_Finalize -END TYPE ParameterList_t - -!---------------------------------------------------------------------------- -! ParameterListIterator_t -!---------------------------------------------------------------------------- - -TYPE :: ParameterListIterator_t - PRIVATE - TYPE(ParameterRootEntry_t), POINTER :: DataBase(:) => NULL() - TYPE(EntryListIterator_t) :: EntryListIterator - INTEGER(I4P) :: Index = 0 - INTEGER(I4P) :: UpperBound = 0 -CONTAINS - PRIVATE - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Assignment - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get0D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get1D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get2D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get3D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get4D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get5D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get6D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get7D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType0D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType1D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType2D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType3D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType4D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType5D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType6D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType7D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable0D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable1D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable2D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable3D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable4D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable5D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable6D - PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable7D - PROCEDURE, NON_OVERRIDABLE :: GetEntry => ParameterListIterator_GetEntry - PROCEDURE, NON_OVERRIDABLE :: GetIndex => ParameterListIterator_GetIndex - PROCEDURE, NON_OVERRIDABLE :: PointToValue => & - & ParameterListIterator_PointToValue - PROCEDURE, NON_OVERRIDABLE :: 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 - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetShape => & - & ParameterListIterator_GetShape - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetDimensions => & - & ParameterListIterator_GetDimensions - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: DataSizeInBytes => & - & ParameterListIterator_DataSizeInBytes - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetAsString => & - & ParameterListIterator_GetAsString - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetSubList => & - & ParameterListIterator_GetSubList - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: isSubList => & - & ParameterListIterator_isSubList - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: toString => & - & ParameterListIterator_toString - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: PRINT => ParameterListIterator_Print - PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Free => ParameterListIterator_Free - GENERIC, PUBLIC :: Get => ParameterListIterator_Get0D, & - ParameterListIterator_Get1D, & - ParameterListIterator_Get2D, & - ParameterListIterator_Get3D, & - ParameterListIterator_Get4D, & - ParameterListIterator_Get5D, & - ParameterListIterator_Get6D, & - ParameterListIterator_Get7D - GENERIC, PUBLIC :: isOfDataType => ParameterListIterator_IsOfDataType0D, & - ParameterListIterator_IsOfDataType1D, & - ParameterListIterator_IsOfDataType2D, & - ParameterListIterator_IsOfDataType3D, & - ParameterListIterator_IsOfDataType4D, & - ParameterListIterator_IsOfDataType5D, & - ParameterListIterator_IsOfDataType6D, & - ParameterListIterator_IsOfDataType7D - GENERIC, PUBLIC :: isAssignable => ParameterListIterator_isAssignable0D, & - ParameterListIterator_isAssignable1D, & - ParameterListIterator_isAssignable2D, & - ParameterListIterator_isAssignable3D, & - ParameterListIterator_isAssignable4D, & - ParameterListIterator_isAssignable5D, & - ParameterListIterator_isAssignable6D, & - ParameterListIterator_isAssignable7D - GENERIC, PUBLIC :: ASSIGNMENT(=) => ParameterListIterator_Assignment - FINAL :: ParameterListIterator_Final -END TYPE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -!--------------------------------------------------------------------- -!< Parameter List Procedures -!--------------------------------------------------------------------- - -SUBROUTINE ParameterList_Init(this, Size) - - !< Initialize the dictionary - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size !< Dictionary Size - - CALL this%Free() - IF (PRESENT(Size)) THEN - CALL this%Dictionary%Init(Size=Size) - ELSE - CALL this%Dictionary%Init() - END IF -END SUBROUTINE ParameterList_Init - -!---------------------------------------------------------------------------- -! ParameterList_GetShape -!---------------------------------------------------------------------------- - -FUNCTION ParameterList_GetShape(this, Key, Shape) RESULT(FPLError) - - !< Return an allocatable array with the shape of the contained value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: SHAPE(:) !< Shape of the stored value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - CALL Wrapper%GetShape(Shape) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Unknown Wrapper. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetShape - -FUNCTION ParameterList_GetDimensions(this, Key) RESULT(Dimensions) - - !< Return an integer with the dimensions of the contained value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - INTEGER(I4P) :: Dimensions !< Dimensions of the stored value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - Dimensions = 0 - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - Dimensions = Wrapper%GetDimensions() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Unknown Wrapper. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetDimensions - -SUBROUTINE ParameterList_Free(this) - - !< Free the dictionary - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - - CALL this%Dictionary%Free() -END SUBROUTINE ParameterList_Free - -SUBROUTINE ParameterList_Finalize(this) - - !< Destructor procedure - - TYPE(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - - CALL this%Free() -END SUBROUTINE ParameterList_Finalize - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - -!> author: Vikas Sharma, Ph. D. -! 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 - !! Parameter List - CHARACTER(*), INTENT(IN) :: Key - !! String Key - INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size - !! Sublist Size - TYPE(ParameterList_t), POINTER :: SublistPointer - !! New Sublist pointer - - ! Internal variables - CLASS(*), POINTER :: Sublist !< New Sublist - - ALLOCATE (ParameterList_t :: SubList) - CALL this%Dictionary%Set(Key=Key, VALUE=Sublist) - SELECT TYPE (SubList) - CLASS is (ParameterList_t) - SublistPointer => SubList - IF (PRESENT(Size)) THEN - CALL Sublist%Init(Size=Size) - ELSE - CALL Sublist%Init(Size=Size) - END IF - END SELECT -END FUNCTION ParameterList_NewSubList - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterList_GetSublist(this, Key, Sublist) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - TYPE(ParameterList_t), POINTER, INTENT(INOUT) :: Sublist !< Wrapper - CLASS(*), POINTER :: VALUE !< Returned pointer to value - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (VALUE) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=VALUE) - IF (ASSOCIATED(VALUE)) THEN - SELECT TYPE (VALUE) - CLASS IS (ParameterList_t) - SubList => VALUE - CLASS DEFAULT - FPLerror = FPLSublistError - CALL msg%Error(txt='Getting [Key="'//Key//'"]: Is not a sublist.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLSublistError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetSubList - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterList_Set0D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the Dictionary - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE !< Unlimited polymorphic Value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set0D - -FUNCTION ParameterList_Set1D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(:) !< Unlimited polymorphic 1D array Value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set1D - -FUNCTION ParameterList_Set2D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(:, :) !< Unlimited polymorphic 2D array value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set2D - -FUNCTION ParameterList_Set3D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(:, :, :) !< Unlimited Polimorphic 3D array Value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set3D - -FUNCTION ParameterList_Set4D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(:, :, :, :) !< Unlimited Polymorphic 4D array Value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set4D - -FUNCTION ParameterList_Set5D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) !< Unlimited Polymorphic 5D array Value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set5D - -FUNCTION ParameterList_Set6D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) !< Unlimited Polymorphic 5D array Value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set6D - -FUNCTION ParameterList_Set7D(this, Key, VALUE) RESULT(FPLerror) - - !< Set a Key/Value pair into the DataBase - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) !< Unlimited Polymorphic 7D array Value - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (WrapperFactory) - NULLIFY (Wrapper) - WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) - IF (ASSOCIATED(WrapperFactory)) THEN - Wrapper => WrapperFactory%Wrap(VALUE=VALUE) - IF (ASSOCIATED(Wrapper)) THEN - CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) - ELSE - FPLerror = FPLWrapperError - call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Set7D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-13 -! summary: Return a scalar Value given the Key - -FUNCTION ParameterList_Get0D(this, Key, VALUE) RESULT(FPLerror) - CLASS(ParameterList_t), INTENT(IN) :: this - !! Parameter List - CHARACTER(*), INTENT(IN) :: Key - !! String Key - CLASS(*), INTENT(INOUT) :: VALUE - !! Returned value - CLASS(*), POINTER :: Wrapper - !! Wrapper - INTEGER(I4P) :: FPLerror - !! Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper0D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get0D - -FUNCTION ParameterList_Get1D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a vector Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(INOUT) :: VALUE(:) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper1D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get1D - -FUNCTION ParameterList_Get2D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a 2D array Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(INOUT) :: VALUE(:, :) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper2D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get2D - -FUNCTION ParameterList_Get3D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a 3D array Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper3D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get3D - -FUNCTION ParameterList_Get4D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a 4D array Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper4D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get4D - -FUNCTION ParameterList_Get5D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a 5D array Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) !< Returned value - CLASS(*), POINTER :: Node !< Pointer to a Parameter List - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper5D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get5D - -FUNCTION ParameterList_Get6D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a 6D array Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper6D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get6D - -FUNCTION ParameterList_Get7D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a 7D array Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper7D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_Get7D - -FUNCTION ParameterList_GetPointer0D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper0D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer0D - -FUNCTION ParameterList_GetPointer1D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:) !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper1D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer1D - -FUNCTION ParameterList_GetPointer2D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :) !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper2D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer2D - -FUNCTION ParameterList_GetPointer3D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :) !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper3D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer3D - -FUNCTION ParameterList_GetPointer4D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :) !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper4D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer4D - -FUNCTION ParameterList_GetPointer5D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :, :) !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper5D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer5D - -FUNCTION ParameterList_GetPointer6D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :, :, :) !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper6D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer6D - -FUNCTION ParameterList_GetPointer7D(this, Key, VALUE) RESULT(FPLerror) - - !< Return a Unlimited polymorphic pointer to a Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) !< Returned pointer to value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper7D_t) - VALUE => Wrapper%GetPointer() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetPointer7D - -FUNCTION ParameterList_isPresent(this, Key) RESULT(isPresent) - - !< Check if a Key is present at the DataBase - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - LOGICAL :: isPresent !< Boolean flag to check if a Key is present - - isPresent = this%Dictionary%IsPresent(Key=Key) -END FUNCTION ParameterList_isPresent - -FUNCTION ParameterList_isSubList(this, Key) RESULT(isSubList) - - !< Check if a Key is a SubList - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER :: SubListPointer !< Pointer to a SubList - LOGICAL :: isSubList !< Check if is a SubList - - isSubList = .FALSE. - NULLIFY (SubListPointer) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=SubListPointer) - IF (ASSOCIATED(SubListPointer)) THEN - SELECT TYPE (SubListPointer) - CLASS is (ParameterList_t) - isSubList = .TRUE. - END SELECT - END IF -END FUNCTION ParameterList_isSubList - -FUNCTION ParameterList_DataSizeInBytes(this, Key) RESULT(DataSizeInBytes) - - !< Return the data size in bytes of the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: DataSizeInBytes !< Size in bytes - - DataSizeInBytes = 0 - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - DataSizeInBytes = Wrapper%DataSizeInBytes() - END SELECT - END IF -END FUNCTION ParameterList_DataSizeInBytes - -FUNCTION ParameterList_isOfDataType0D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold) - CLASS is (ParameterList_t) - SELECT TYPE (Mold) - CLASS is (ParameterList_t) - isOfDataType = .TRUE. - END SELECT - END SELECT - END IF -END FUNCTION ParameterList_isOfDataType0D - -FUNCTION ParameterList_isOfDataType1D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold(1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE.; NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1)) - END SELECT - END IF -END FUNCTION ParameterList_isOfDataType1D - -FUNCTION ParameterList_isOfDataType2D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold(1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE.; NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1)) - END SELECT - END IF -END FUNCTION ParameterList_isOfDataType2D - -FUNCTION ParameterList_isOfDataType3D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE.; NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1)) - END SELECT -END FUNCTION ParameterList_isOfDataType3D - -FUNCTION ParameterList_isOfDataType4D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE.; NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterList_isOfDataType4D - -FUNCTION ParameterList_isOfDataType5D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE.; NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterList_isOfDataType5D - -FUNCTION ParameterList_isOfDataType6D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE.; NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterList_isOfDataType6D - -FUNCTION ParameterList_isOfDataType7D(this, Key, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the value associated with Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE.; NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterList_isOfDataType7D - -FUNCTION ParameterList_isAssignable0D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE !< Value to compare with the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper0D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE)) Assignable = .TRUE. - END SELECT - END IF -END FUNCTION ParameterList_isAssignable0D - -FUNCTION ParameterList_isAssignable1D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(1:) !< Value to check against with the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper1D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterList_isAssignable1D - -FUNCTION ParameterList_isAssignable2D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(1:, 1:) !< Value to check against with the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper2D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterList_isAssignable2D - -FUNCTION ParameterList_isAssignable3D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) !< Value to check against with the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper3D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterList_isAssignable3D - -FUNCTION ParameterList_isAssignable4D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) !< Value to check against the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper4D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterList_isAssignable4D - -FUNCTION ParameterList_isAssignable5D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) !< Value to check against the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper5D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterList_isAssignable5D - -FUNCTION ParameterList_isAssignable6D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) !< Value to check against the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper6D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterList_isAssignable6D - -FUNCTION ParameterList_isAssignable7D(this, Key, VALUE) RESULT(Assignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Value to check against the stored variable - LOGICAL :: Assignable !< Boolean flag to check compatibility - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - Assignable = .FALSE. - NULLIFY (Wrapper) - ! Check if present - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper7D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterList_isAssignable7D - -SUBROUTINE ParameterList_RemoveEntry(this, Key) - - !< Remove an Entry given a Key - - CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - - CALL this%Dictionary%Del(Key=Key) -END SUBROUTINE ParameterList_RemoveEntry - -FUNCTION ParameterList_Length(this) RESULT(Length) - - !< Return the number of ParameterListEntries contained in the DataBase - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - INTEGER(I4P) :: Length !< Number of parameters in database - - Length = this%Dictionary%Length() -END FUNCTION ParameterList_Length - -FUNCTION ParameterList_GetIterator(this) RESULT(Iterator) - - !< Return a pointer to a Parameters Iterator - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List Entry Container Type - TYPE(ParameterListIterator_t) :: Iterator !< Parameter List iterator - - CALL Iterator%Init(DataBase=this%Dictionary%GetDataBase()) -END FUNCTION ParameterList_GetIterator - -function ParameterList_GetAsString(this,Key,String,Separator) result(FPLerror) - - !< Return a scalar Value given the Key - - CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List - CHARACTER(*), INTENT(IN) :: Key !< String Key - CHARACTER(:), ALLOCATABLE, INTENT(INOUT) :: String !< Returned value as string - CHARACTER(1), OPTIONAL, INTENT(IN) :: Separator !< Array values separator - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - CALL Wrapper%toString(String=String, Separator=Separator) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//Key//'"]: Unknown Wrapper. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterList_GetAsString - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ParameterList_Display(this, msg, unitno) - - !< Print the content of the DataBase - - 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 - -!---------------------------------------------------------------------------- -! Print -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-02 -! summary: Print the content of the DataBase - -RECURSIVE SUBROUTINE ParameterList_Print(this, unit, prefix, iostat, iomsg) - CLASS(ParameterList_t), INTENT(IN) :: this - !! Linked List - INTEGER(I4P), OPTIONAL, 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(:), ALLOCATABLE :: prefd - !! Prefixing string. - INTEGER(I4P) :: unitd - !! Logic unit. - INTEGER(I4P) :: iostatd - !! IO error. - CHARACTER(500) :: iomsgd - !! Temporary variable for IO error message. - TYPE(ParameterListIterator_t) :: Iterator - !! Dictionary Iterator - ! - ! Internal variables - ! - CLASS(*), POINTER :: VALUE - ! - ! - ! - prefd = ''; IF (PRESENT(prefix)) prefd = prefix - unitd = OUTPUT_UNIT; IF (PRESENT(unit)) unitd = unit - Iterator = this%GetIterator() - ! - DO WHILE (.NOT. Iterator%HasFinished()) - !! - NULLIFY (VALUE) - !! - VALUE => Iterator%PointToValue() - !! - IF (ASSOCIATED(VALUE)) THEN - !! - SELECT TYPE (VALUE) - !! - CLASS is (DimensionsWrapper_t) - !! - CALL VALUE%PRINT(unit=unitd, & - & prefix=prefd// & - & '['//TRIM(str(no_sign=.TRUE., n=Iterator%GetIndex()))//']'// & - & ' Key = '//Iterator%GetKey()//',', & - & iostat=iostatd, & - & iomsg=iomsgd) - !! - TYPE is (ParameterList_t) - !! - WRITE (unit=unitd, fmt='(A)') prefd// & - & '['//TRIM(str(no_sign=.TRUE., n=Iterator%GetIndex()))//']'// & - & ' Key = '//Iterator%GetKey()//', Data Type = ParameterList' - !! - CALL VALUE%PRINT( & - & unit=unitd, & - & prefix=prefd//'['//TRIM(str(no_sign=.TRUE., & - & n=Iterator%GetIndex()))//'] ', & - & iostat=iostatd, & - & iomsg=iomsgd) - !! - CLASS default - !! - WRITE (unit=unitd, fmt='(A)') prefd// & - & '['//TRIM(str(no_sign=.TRUE., n=Iterator%GetIndex()))//']'// & - & ' Key = '//Iterator%GetKey()//', Data Type = Unknown Data Type!' - !! - END SELECT - END IF - CALL Iterator%Next() - END DO - IF (PRESENT(iostat)) iostat = iostatd - IF (PRESENT(iomsg)) iomsg = iomsgd -END SUBROUTINE ParameterList_Print - -!--------------------------------------------------------------------- -!< Parameter List Iterator Procedures -!--------------------------------------------------------------------- - -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 - - this%DataBase(0:) => ParameterListIterator%DataBase - this%EntryListIterator = ParameterListIterator%EntryListIterator - this%Index = ParameterListIterator%Index - this%UpperBound = ParameterListIterator%UpperBound -END SUBROUTINE ParameterListIterator_Assignment - -SUBROUTINE ParameterListIterator_Free(this) - - !< Free the dictionary iterator - - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - - this%Index = 0 - this%UpperBound = 0 - NULLIFY (this%DataBase) - CALL this%EntryListIterator%Free() -END SUBROUTINE ParameterListIterator_Free - -SUBROUTINE ParameterListIterator_Final(this) - - !< Free the dictionary iterator - - TYPE(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - - CALL this%Free() -END SUBROUTINE ParameterListIterator_Final - -SUBROUTINE ParameterListIterator_Init(this, DataBase) - - !< Associate the iterator with a dictionary and rewind - !< to the first position - - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - TYPE(ParameterRootEntry_t), TARGET, INTENT(IN) :: DataBase(:) ! Entries database - - CALL this%Free() - this%DataBase(0:) => DataBase(:) - this%Index = -1 - this%UpperBound = SIZE(this%DataBase) - CALL this%Next() -END SUBROUTINE ParameterListIterator_Init - -SUBROUTINE ParameterListIterator_Begin(this) - - !< Rewind the iterator to the first dictionary position - - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - TYPE(ParameterRootEntry_t), POINTER :: DataBase(:) ! Entries database - - DataBase => this%DataBase - CALL this%Init(DataBase) -END SUBROUTINE ParameterListIterator_Begin - -SUBROUTINE ParameterListIterator_End(this) - - !< Fast forward to the last dictionary position (HasFinished = .true.) - - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - - this%Index = this%UpperBound - CALL this%EntryListIterator%Free() -END SUBROUTINE ParameterListIterator_End - -SUBROUTINE ParameterListIterator_NextNotEmptyListIterator(this) - - !< The iterator points to the next associated entry - - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - - CALL this%EntryListIterator%Free() - this%Index = this%Index + 1 - DO WHILE (this%Index < this%UpperBound) - IF (this%DataBase(this%Index)%HasRoot()) THEN - this%EntryListIterator = this%Database(this%Index)%GetIterator() - EXIT - END IF - this%Index = this%Index + 1 - END DO -END SUBROUTINE ParameterListIterator_NextNotEmptyListIterator - -SUBROUTINE ParameterListIterator_Next(this) - - !< The iterator points to the next associated entry - - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - - IF (.NOT. this%HasFinished()) THEN - IF (.NOT. this%EntryListIterator%HasFinished()) THEN - CALL this%EntryListIterator%Next() - ELSE - CALL this%NextNotEmptyListIterator() - END IF - END IF -END SUBROUTINE ParameterListIterator_Next - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterListIterator_GetEntry(this) RESULT(CurrentEntry) - - !< Return the current Entry - - CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator - TYPE(ParameterEntry_t), POINTER :: CurrentEntry ! Current entry - INTEGER(I4P) :: FPLerror !< Error flag - - NULLIFY (CurrentEntry) - CurrentEntry => this%EntryListIterator%GetEntry() - IF (.NOT. ASSOCIATED(CurrentEntry)) THEN - FPLerror = FPLParameterListIteratorError - CALL msg%Error(txt='Current entry not associated. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_GetEntry - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION ParameterListIterator_PointToValue(this) RESULT(VALUE) - - !< Return a pointer to the value stored in the current Entry - - CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator - CLASS(*), POINTER :: VALUE ! Unlimited polymorphic pointer - TYPE(ParameterEntry_t), POINTER :: CurrentEntry ! Current entry - - NULLIFY (CurrentEntry) - NULLIFY (VALUE) - CurrentEntry => this%GetEntry() - IF (ASSOCIATED(CurrentEntry)) VALUE => CurrentEntry%PointToValue() -END FUNCTION ParameterListIterator_PointToValue - -FUNCTION ParameterListIterator_GetKey(this) RESULT(Key) - - !< Return the Key of the current Entry - - CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator - CHARACTER(:), ALLOCATABLE :: Key ! Key - TYPE(ParameterEntry_t), POINTER :: CurrentEntry ! Current entry - - NULLIFY (CurrentEntry) - CurrentEntry => this%GetEntry() - IF (ASSOCIATED(CurrentEntry)) CALL CurrentEntry%GetKey(Key) -END FUNCTION ParameterListIterator_GetKey - -FUNCTION ParameterListIterator_GetIndex(this) RESULT(CurrentIndex) - - !< Return the current Index - - CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator - INTEGER(I4P) :: CurrentIndex ! Current index - - CurrentIndex = this%Index -END FUNCTION ParameterListIterator_GetIndex - -FUNCTION ParameterListIterator_GetShape(this, Shape) RESULT(FPLError) - - !< Return an allocatable array with the shape of the contained value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: SHAPE(:) !< Shape of the stored value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - CALL Wrapper%GetShape(Shape) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_GetShape - -FUNCTION ParameterListIterator_GetDimensions(this) RESULT(Dimensions) - - !< Return an allocatable array with the shape of the contained value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - INTEGER(I4P) :: Dimensions !< Dimensions of the stored value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - Dimensions = 0 - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - Dimensions = Wrapper%GetDimensions() - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Shape was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_GetDimensions - - function ParameterListIterator_GetAsString(this,String,Separator) result(FPLerror) - - !< Return the current value converted into a string - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CHARACTER(:), ALLOCATABLE, INTENT(INOUT) :: String !< Returned string - CHARACTER(1), OPTIONAL, INTENT(IN) :: Separator !< Array values separator - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - CALL Wrapper%ToString(String=String, Separator=Separator) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_GetAsString - -FUNCTION ParameterListIterator_Get0D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper0D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get0D - -FUNCTION ParameterListIterator_Get1D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE(:) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper1D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get1D - -FUNCTION ParameterListIterator_Get2D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE(:, :) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper2D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get2D - -FUNCTION ParameterListIterator_Get3D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) !< Returned value - TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper3D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get3D - -FUNCTION ParameterListIterator_Get4D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) !< Returned value - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper4D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get4D - -FUNCTION ParameterListIterator_Get5D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) !< Returned value - TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper5D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get5D - -FUNCTION ParameterListIterator_Get6D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) !< Returned value - TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper6D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get6D - -FUNCTION ParameterListIterator_Get7D(this, VALUE) RESULT(FPLerror) - - !< Return the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) !< Returned value - TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper7D_t) - CALL Wrapper%Get(VALUE=VALUE) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_Get7D - -FUNCTION ParameterListIterator_GetSublist(this, Sublist) RESULT(FPLerror) - - !< Return a pointer to the current sublist - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List - TYPE(ParameterList_t), POINTER, INTENT(INOUT) :: Sublist !< Wrapper - CLASS(*), POINTER :: VALUE !< Returned pointer to value - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (VALUE) - NULLIFY (Sublist) - VALUE => this%PointToValue() - IF (ASSOCIATED(VALUE)) THEN - SELECT TYPE (VALUE) - CLASS is (ParameterList_t) - SubList => VALUE - CLASS Default - FPLerror = FPLSublistError -CALL msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Is not a sublist.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLSublistError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Sublist was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_GetSubList - -FUNCTION ParameterListIterator_isSubList(this) RESULT(isSubList) - - !< Check if a Key is a SubList - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), POINTER :: SubList !< Sublist pointer - LOGICAL :: isSubList !< Check if is a SubList - - isSubList = .FALSE. - NULLIFY (Sublist) - SubList => this%PointToValue() - IF (ASSOCIATED(Sublist)) THEN - SELECT TYPE (Sublist) - CLASS is (ParameterList_t) - isSubList = .TRUE. - END SELECT - END IF -END FUNCTION ParameterListIterator_isSubList - -FUNCTION ParameterListIterator_DataSizeInBytes(this) RESULT(DataSizeInBytes) - - !< Return the data size in bytes of the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: DataSizeInBytes !< Size in bytes - - DataSizeInBytes = 0 - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - DataSizeInBytes = Wrapper%DataSizeInBytes() - END SELECT - END IF -END FUNCTION ParameterListIterator_DataSizeInBytes - -FUNCTION ParameterListIterator_isOfDataType0D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType0D - -FUNCTION ParameterListIterator_isOfDataType1D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold(1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1)) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType1D - -FUNCTION ParameterListIterator_isOfDataType2D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold(1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1)) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType2D - -FUNCTION ParameterListIterator_isOfDataType3D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType3D - -FUNCTION ParameterListIterator_isOfDataType4D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType4D - -FUNCTION ParameterListIterator_isOfDataType5D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType5D - -FUNCTION ParameterListIterator_isOfDataType6D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType6D - -FUNCTION ParameterListIterator_isOfDataType7D(this, Mold) RESULT(IsOfDataType) - - !< Check if the data type of Mold agrees with the current value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Mold - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isOfDataType !< Check if has the same type - - isOfDataType = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1, 1)) - END SELECT - END IF -END FUNCTION ParameterListIterator_isOfDataType7D - -function ParameterListIterator_isAssignable0D(this,Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper0D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE)) isAssignable = .TRUE. - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable0D - -function ParameterListIterator_isAssignable1D(this,Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE(1:) !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper1D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable1D - -function ParameterListIterator_isAssignable2D(this,Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE(1:, 1:) !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper2D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable2D - - function ParameterListIterator_isAssignable3D(this, Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper3D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable3D - - function ParameterListIterator_isAssignable4D(this, Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper4D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable4D - - function ParameterListIterator_isAssignable5D(this, Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper5D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable5D - - function ParameterListIterator_isAssignable6D(this, Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper6D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable6D - - function ParameterListIterator_isAssignable7D(this, Value) result(isAssignable) - - !< Check if a stored variable is Assignable to Value - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Value - CLASS(*), POINTER :: Wrapper !< Wrapper - LOGICAL :: isAssignable !< Check if is assignable - INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value - - isAssignable = .FALSE. - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper7D_t) - ! Check same data type - IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1, 1))) THEN - CALL Wrapper%GetShape(ValueShape) - ! Check right shape - IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. - END IF - END SELECT - END IF -END FUNCTION ParameterListIterator_isAssignable7D - -FUNCTION ParameterListIterator_toString(this, Separator) RESULT(String) - - !< Return a scalar Value given the Key - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator - CHARACTER(1), OPTIONAL, INTENT(IN) :: Separator !< Array values separator - CHARACTER(:), ALLOCATABLE :: String !< Returned value as string - CLASS(*), POINTER :: Wrapper !< Wrapper - INTEGER(I4P) :: FPLerror !< Error flag - - FPLerror = FPLSuccess - NULLIFY (Wrapper) - Wrapper => this%PointToValue() - IF (ASSOCIATED(Wrapper)) THEN - SELECT TYPE (Wrapper) - CLASS is (DimensionsWrapper_t) - CALL Wrapper%toString(String, Separator) - CLASS Default - FPLerror = FPLWrapperError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Value was not modified.', & - file=__FILE__, line=__LINE__) - END SELECT - ELSE - FPLerror = FPLWrapperFactoryError - call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & - file=__FILE__, line=__LINE__) - END IF -END FUNCTION ParameterListIterator_toString - - recursive subroutine ParameterListIterator_Print(this, unit, prefix, iostat, iomsg) - - !< Print the content of the DataBase - - CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter Iterator - INTEGER(I4P), OPTIONAL, 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(:), ALLOCATABLE :: prefd !< Prefixing string. - INTEGER(I4P) :: unitd !< Logic unit. - INTEGER(I4P) :: iostatd !< IO error. - CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. - CLASS(*), POINTER :: VALUE !< Unlimited polymorphic value - - prefd = ''; IF (PRESENT(prefix)) prefd = prefix - unitd = OUTPUT_UNIT; IF (PRESENT(unit)) unitd = unit - NULLIFY (VALUE) - VALUE => this%PointToValue() - IF (ASSOCIATED(VALUE)) THEN - SELECT TYPE (VALUE) - CLASS is (DimensionsWrapper_t) - CALL VALUE%PRINT(unit=unitd, & - prefix=prefd// & - '['//TRIM(str(no_sign=.TRUE., n=this%GetIndex()))//']'// & - ' Key = '//this%GetKey()//',', & - iostat=iostatd, & - iomsg=iomsgd) - END SELECT - END IF - IF (PRESENT(iostat)) iostat = iostatd - IF (PRESENT(iomsg)) iomsg = iomsgd -END SUBROUTINE ParameterListIterator_Print - -FUNCTION ParameterListIterator_HasFinished(this) RESULT(HasFinished) - - !< Check if Iterator has reached the end of the dictionary - - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator - LOGICAL :: HasFinished - - HasFinished = .FALSE. - IF (this%Index == this%UpperBound) HasFinished = .TRUE. -END FUNCTION ParameterListIterator_HasFinished - -END MODULE ParameterList diff --git a/src/modules/FPL/src/ParameterRootEntry.F90 b/src/modules/FPL/src/ParameterRootEntry.F90 deleted file mode 100644 index 11f5cba92..000000000 --- a/src/modules/FPL/src/ParameterRootEntry.F90 +++ /dev/null @@ -1,350 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module ParameterRootEntry - -USE ParameterEntry -USE PENF, only: I4P, str - -implicit none -private - - type :: ParameterRootEntry_t - private - type(ParameterEntry_t), pointer :: Root => null() - contains - private - procedure, non_overridable :: Init => ParameterRootEntry_Init - procedure, non_overridable, public :: HasRoot => ParameterRootEntry_HasRoot - procedure, non_overridable :: SetRoot => ParameterRootEntry_SetRoot - procedure, non_overridable, public :: GetRoot => ParameterRootEntry_GetRoot - procedure, non_overridable :: NullifyRoot => ParameterRootEntry_NullifyRoot - procedure, non_overridable :: DeallocateRoot => ParameterRootEntry_DeallocateRoot - procedure, non_overridable, public :: GetEntry => ParameterRootEntry_GetEntry - procedure, non_overridable, public :: GetPreviousEntry => ParameterRootEntry_GetPreviousEntry - procedure, non_overridable, public :: Print => ParameterRootEntry_Print - procedure, non_overridable, public :: isPresent => ParameterRootEntry_isPresent - procedure, non_overridable, public :: Length => ParameterRootEntry_Length - procedure, non_overridable, public :: RemoveEntry => ParameterRootEntry_RemoveEntry - procedure, non_overridable, public :: AddEntry => ParameterRootEntry_AddEntry - procedure, non_overridable, public :: GetIterator => ParameterRootEntry_GetIterator - procedure, non_overridable, public :: Free => ParameterRootEntry_Free - final :: ParameterRootEntry_Finalize - end type - - -public :: ParameterRootEntry_T - -contains - - - subroutine ParameterRootEntry_SetRoot(this, Root) - - !< Set the Root of the list - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - class(ParameterEntry_t), pointer, intent(IN) :: Root !< Parameter Entry correspoing to the head of the list - - this%Root => Root - end subroutine ParameterRootEntry_SetRoot - - - function ParameterRootEntry_GetRoot(this) result(Root) - - !< Return a pointer to the Root of the list - - class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry - class(ParameterEntry_t), pointer :: Root !< Parameter Entry correspoing to the head of the list - - Root => this%Root - end function ParameterRootEntry_GetRoot - - - function ParameterRootEntry_HasRoot(this) result(HasRoot) - - !< Return a pointer to the Root of the list - - class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry - logical :: hasRoot !< Check if Root is associated - - hasRoot = associated(this%GetRoot()) - end function ParameterRootEntry_HasRoot - - - subroutine ParameterRootEntry_NullifyRoot(this) - - !< Set the Root of the list - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - - nullify(this%Root) - end subroutine ParameterRootEntry_NullifyRoot - - - subroutine ParameterRootEntry_DeallocateRoot(this) - - !< Set the Root of the list - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - - if(this%HasRoot()) then - call this%Root%Free() - deallocate(this%Root) - endif - end subroutine ParameterRootEntry_DeallocateRoot - - - subroutine ParameterRootEntry_Init(this, Key, Value) - - !< Initialize the Root of the list - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - character(len=*), intent(IN) :: Key !< Key (unique) of the current node. - class(*), pointer, intent(IN) :: Value !< Parameter Entry Value - - if(.not. this%HasRoot()) allocate(ParameterEntry_t::this%Root) - call this%Root%SetKey(Key=Key) - call this%Root%SetValue(Value=Value) - end subroutine ParameterRootEntry_Init - - - function ParameterRootEntry_IsPresent(this, Key) result(isPresent) - - !< Check if a Key is present in the List - - class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry - character(len=*), intent(IN) :: Key !< String Key - logical :: isPresent !< Boolean flag to check if a Key is present - - isPresent = associated(this%GetEntry(Key)) - end function ParameterRootEntry_IsPresent - - - subroutine ParameterRootEntry_AddEntry(this,Key, Value) - - !< Add a new Node if key does not Exist - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - character(len=*), intent(IN) :: Key !< Key (unique) of the current node. - class(*), pointer, intent(IN) :: Value !< Parameter Entry Value - class(ParameterEntry_t), pointer :: NextEntry !< Parameter Entry - class(ParameterEntry_t), pointer :: NewEntry !< New Parameter Entry - character(len=:), allocatable :: NextEntryKey !< Key of the NextEntry - - if(.not. this%HasRoot()) then - call this%Init(Key=Key, Value=Value) - else - NextEntry => this%GetRoot() - do while(associated(NextEntry)) - call NextEntry%GetKey(NExtEntryKey) - if (NextEntryKey/=Key) then - if (.not. NextEntry%hasNext()) then - ! I reached the end of the list - allocate(ParameterEntry_t::NewEntry) - call NewEntry%SetKey(Key=Key) - call NewEntry%SetValue(Value=Value) - call NextEntry%SetNext(NExt=NewEntry) - exit - else - NextEntry => NextEntry%GetNext() - endif - else - call NextEntry%SetValue(Value=Value) - exit - endif - enddo - if(allocated(NextEntryKey)) deallocate(NextEntryKey) - endif - end subroutine ParameterRootEntry_AddEntry - - - subroutine ParameterRootEntry_RemoveEntry(this, Key) - - !< Remove an Entry given a Key - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - character(len=*), intent(IN) :: Key !< String Key - character(len=:), allocatable :: CurrentEntryKey !< Current Entry Key - class(ParameterEntry_t), pointer :: PreviousEntry !< The Previous Entry of a given key - class(ParameterEntry_t), pointer :: CurrentEntry !< Entry of a given key - class(ParameterEntry_t), pointer :: NextEntry !< The Next Entry of a given key - - if(this%HasRoot()) then - CurrentEntry => this%GetRoot() - call CurrentEntry%GetKey(CurrentEntryKey) - if(CurrentEntryKey == Key) then - NextEntry => CurrentEntry%GetNext() - call CurrentEntry%DeallocateKey() - call CurrentEntry%DeallocateValue() - call CurrentEntry%NullifyNext() - deallocate(CurrentEntry) - call this%NullifyRoot() - if(allocated(CurrentEntryKey)) deallocate(CurrentEntryKey) - else - PreviousEntry => this%GetPreviousEntry(Key=Key) - if(associated(PreviousEntry)) then - CurrentEntry => PreviousEntry%GetNext() - NextEntry => CurrentEntry%GetNext() - call CurrentEntry%DeallocateKey() - call CurrentEntry%DeallocateValue() - call CurrentEntry%NullifyNext() - deallocate(CurrentEntry) - call PreviousEntry%NullifyNext() - if(associated(NextEntry)) call PreviousEntry%SetNext(Next=NextEntry) - endif - endif - if(associated(NextEntry)) call this%SetRoot(Root = NextEntry) - endif - end subroutine ParameterRootEntry_RemoveEntry - - - - function ParameterRootEntry_GetEntry(this,Key) result(Entry) - - !< Return a pointer to a ParameterEntry given a Key - - class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry - character(len=*), intent(IN) :: Key !< String Key - class(ParameterEntry_t), pointer :: Entry !< Parameter Entry - character(len=:), allocatable :: EntryKey !< Entry Key - - Entry => this%GetRoot() - do while(associated(Entry)) - call Entry%GetKey(EntryKey) - if (EntryKey==Key) exit - Entry => Entry%GetNext() - enddo - if(allocated(EntryKey)) deallocate(EntryKey) - end function ParameterrootEntry_GetEntry - - - function ParameterRootEntry_GetPreviousEntry(this,Key) result(PreviousEntry) - - !< Return a pointer to the provious node of a Parameter List given a Key - - class(ParameterRootEntry_t), intent(IN) :: this !< Parameter List - character(len=*), intent(IN) :: Key !< String Key - class(ParameterEntry_t), pointer :: PreviousEntry !< Parameter List Entry - class(ParameterEntry_t), pointer :: NextEntry !< Parameter List Next Entry - character(len=:), allocatable :: NExtEntryKey !< NextEntry Key - - PreviousEntry => this%GetRoot() - do while(associated(PreviousEntry)) - if (PreviousEntry%HasNext()) then - NextEntry => PreviousEntry%GetNext() - call NextEntry%GetKey(NextEntryKey) - if (NextEntryKey==Key) then - exit - else - PreviousEntry => NextEntry - endif - else - nullify(PreviousEntry) - exit - endif - enddo - if(allocated(NextEntryKey)) deallocate(NextEntryKey) - end function ParameterRootEntry_GetPreviousEntry - - - function ParameterRootEntry_Length(this) result(Length) - - !< Return the length of the list - - class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry - integer(I4P) :: Length !< Length of the list - type(ParameterEntry_t), pointer :: NextEntry !< Next Parameter Entry - - Length = 0 - NextEntry => this%GetRoot() - do while (associated(NextEntry)) - Length = Length + 1 - NextEntry => NextEntry%GetNext() - enddo - nullify(NextEntry) - end function ParameterRootEntry_Length - - - subroutine ParameterRootEntry_Free(this) - - !< Free the list - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - class(ParameterEntry_t), pointer :: Current !< Current Parameter List Node - class(ParameterEntry_t), pointer :: Next !< Next Parameter List Node - - do while(this%HasRoot()) - Next => this%Root%GetNext() - call this%Root%Free() - call this%DeallocateRoot() - call this%SetRoot(Root=Next) - enddo - end subroutine ParameterRootEntry_Free - - - function ParameterRootEntry_GetIterator(this) result(Iterator) - - !< Free the list - - class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry - type(EntryListIterator_t) :: Iterator !< List iterator - - call Iterator%Init(Entry=this%Root) - end function ParameterRootEntry_GetIterator - - - subroutine ParameterRootEntry_Print(this, unit, prefix, iostat, iomsg) - - !< Print the keys/value pair contained in the parameter list - - class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry - 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. - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - class(ParameterEntry_t), pointer :: NextEntry !< Pointer for scanning the list. - - iostatd = 0 ; iomsgd = ''; prefd = '';if (present(prefix)) prefd = prefix - if(this%HasRoot()) then - NextEntry => this%GetRoot() - do while(associated(NextEntry)) - call NextEntry%Print(unit=unit, prefix=prefix, iostat=iostatd, iomsg=iomsgd ) - NextEntry => NextEntry%GetNext() - enddo - endif - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine ParameterRootEntry_Print - - - subroutine ParameterRootEntry_Finalize(this) - - !< Finalize procedure - - type(ParameterRootEntry_t), intent(INOUT):: this !< Parameter List - - call this%Free() - end subroutine ParameterRootEntry_Finalize - - -end module ParameterRootEntry diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 deleted file mode 100644 index 4e0a6e5ff..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 +++ /dev/null @@ -1,126 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper - -USE PENF, only: I1P, I4P, str - -implicit none -private - - type, abstract :: DimensionsWrapper_t - private - integer(I1P) :: Dimensions = -1 - contains - private - procedure, public :: SetDimensions => DimensionsWrapper_SetDimensions - procedure, public :: GetDimensions => DimensionsWrapper_GetDimensions - procedure, public :: Print => DimensionsWrapper_Print - procedure(DimensionsWrapper_isOfDataType), public, deferred :: isOfDataType - procedure(DimensionsWrapper_DataSizeInBytes), public, deferred :: DataSizeInBytes - procedure(DimensionsWrapper_Free), public, deferred :: Free - procedure(DimensionsWrapper_GetShape), public, deferred :: GetShape - procedure(DimensionsWrapper_toString), public, deferred :: toString - end type - - abstract interface - subroutine DimensionsWrapper_Free(this) - import DimensionsWrapper_t - class(DimensionsWrapper_t), intent(INOUT) :: this - end subroutine - - function DimensionsWrapper_isOfDataType(this, Mold) result(isOfDataType) - import DimensionsWrapper_t - class(DimensionsWrapper_t), intent(IN) :: this - class(*), intent(IN) :: Mold - logical :: isOfDataType - end function - - function DimensionsWrapper_DataSizeInBytes(this) result(DataSizeInBytes) - import DimensionsWrapper_t - import I4P - class(DimensionsWrapper_t), intent(IN) :: this - integer(I4P) :: DataSizeInBytes - end function - - subroutine DimensionsWrapper_GetShape(this, ValueShape) - import DimensionsWrapper_t - import I4P - class(DimensionsWrapper_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - end subroutine - - subroutine DimensionsWrapper_toString(this, String, Separator) - import DimensionsWrapper_t - import I4P - class(DimensionsWrapper_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - end subroutine - end interface - -public :: DimensionsWrapper_t - - -contains - - subroutine DimensionsWrapper_SetDimensions(this, Dimensions) - !----------------------------------------------------------------- - !< Set the dimensions of the Value contained in the wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper_t), intent(INOUT) :: this - integer(I1P), intent(IN) :: Dimensions - !----------------------------------------------------------------- - this%Dimensions = Dimensions - end subroutine - - - function DimensionsWrapper_GetDimensions(this) result(Dimensions) - !----------------------------------------------------------------- - !< Get the dimensions of the Value contained in the wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper_t), intent(IN) :: this - !----------------------------------------------------------------- - integer(I1P) :: Dimensions - Dimensions = this%Dimensions - end function - - - subroutine DimensionsWrapper_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Generic Wrapper Print - !----------------------------------------------------------------- - class(DimensionsWrapper_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. - 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)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = -, '//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions())) - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper_Print - -end module DimensionsWrapper diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 deleted file mode 100644 index de115949c..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D - -USE DimensionsWrapper - -implicit none -private - - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper0D_t - private - contains - procedure(DimensionsWrapper0D_Set), deferred :: Set - procedure(DimensionsWrapper0D_Get), deferred :: Get - procedure(DimensionsWrapper0D_GetPointer), deferred :: GetPointer - end type - - abstract interface - subroutine DimensionsWrapper0D_Set(this, Value) - import DimensionsWrapper0D_t - class(DimensionsWrapper0D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - end subroutine - - subroutine DimensionsWrapper0D_Get(this, Value) - import DimensionsWrapper0D_t - class(DimensionsWrapper0D_t), intent(IN) :: this - class(*), intent(OUT) :: Value - end subroutine - - function DimensionsWrapper0D_GetPointer(this) result(Value) - import DimensionsWrapper0D_t - class(DimensionsWrapper0D_t), target, intent(IN) :: this - class(*), pointer :: Value - end function - - subroutine DimensionsWrapper0D_GetPolymorphic(this, Value) - import DimensionsWrapper0D_t - class(DimensionsWrapper0D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - end subroutine - end interface - -public :: DimensionsWrapper0D_t - -end module DimensionsWrapper0D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 deleted file mode 100644 index 7b327415a..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 +++ /dev/null @@ -1,219 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_DLCA - -USE DimensionsWrapper0D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_DLCA_t - character(len=:), allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_DLCA_Set - procedure, public :: Get => DimensionsWrapper0D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper0D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_DLCA_toString - procedure, public :: Free => DimensionsWrapper0D_DLCA_Free - procedure, public :: Print => DimensionsWrapper0D_DLCA_Print - final :: DimensionsWrapper0D_DLCA_Final - end type - -public :: DimensionsWrapper0D_DLCA_t - -contains - - - subroutine DimensionsWrapper0D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - this%Value = Value - class Default - call msg%Warn(txt='Setting value: Expected data type (character(*))',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (character(*))',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_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 - - - subroutine DimensionsWrapper0D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_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 = DLCA'//& - ', 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_DLCA_Print - - - function DimensionsWrapper0D_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_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_DLCA_DataSizeInBytes - - - subroutine DimensionsWrapper0D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' - if(allocated(this%Value)) String = trim(this%Value) - end subroutine - - - function DimensionsWrapper0D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_DLCA_isOfDataType - -end module DimensionsWrapper0D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 deleted file mode 100644 index adb405985..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 +++ /dev/null @@ -1,218 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_I1P - -USE DimensionsWrapper0D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I1P_t - integer(I1P), allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_I1P_Set - procedure, public :: Get => DimensionsWrapper0D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper0D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_I1P_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_I1P_toString - procedure, public :: Free => DimensionsWrapper0D_I1P_Free - procedure, public :: Print => DimensionsWrapper0D_I1P_Print - final :: DimensionsWrapper0D_I1P_Final - end type - -public :: DimensionsWrapper0D_I1P_t - -contains - - - subroutine DimensionsWrapper0D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - Value = this%Value - class Default - call msg%Warn(txt='Getting value: Expected data type (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_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_I1P_DataSizeInBytes - - - function DimensionsWrapper0D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_I1P_isOfDataType - - - subroutine DimensionsWrapper0D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I1P_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 = I1P'//& - ', 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_I1P_Print - - -end module DimensionsWrapper0D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 deleted file mode 100644 index e7a02b1f4..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 +++ /dev/null @@ -1,217 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_I2P - -USE DimensionsWrapper0D -USE PENF, only: I2P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I2P_t - integer(I2P), allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_I2P_Set - procedure, public :: Get => DimensionsWrapper0D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper0D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_I2P_toString - procedure, public :: Free => DimensionsWrapper0D_I2P_Free - procedure, public :: Print => DimensionsWrapper0D_I2P_Print - final :: DimensionsWrapper0D_I2P_Final - end type - -public :: DimensionsWrapper0D_I2P_t - -contains - - - subroutine DimensionsWrapper0D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I2P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - 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 (I2P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I2P_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - Value = this%Value - class Default - call msg%Warn(txt='Getting value: Expected data type (I2P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_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 DimensionsWrapper0D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I2P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_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 DimensionsWrapper0D_I2P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I2P_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_I2P_DataSizeInBytes - - - function DimensionsWrapper0D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I2P_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(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_I2P_isOfDataType - - - subroutine DimensionsWrapper0D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I2P_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_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_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 - call this%toString(strvalue) - write(unit=unit,fmt='(A)',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 = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper0D_I2P_Print - - -end module DimensionsWrapper0D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 deleted file mode 100644 index 0220fa6c8..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 +++ /dev/null @@ -1,216 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_I4P - -USE DimensionsWrapper0D -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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 deleted file mode 100644 index bbc8b0a38..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 +++ /dev/null @@ -1,217 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_I8P - -USE DimensionsWrapper0D -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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 deleted file mode 100644 index 1ba2b3c05..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 +++ /dev/null @@ -1,218 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_L - -USE DimensionsWrapper0D -USE FPL_Utils -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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 deleted file mode 100644 index ed9329027..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 +++ /dev/null @@ -1,216 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_R4P - -USE DimensionsWrapper0D -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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 deleted file mode 100644 index b93c5d148..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 +++ /dev/null @@ -1,217 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper0D_R8P - -USE DimensionsWrapper0D -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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 deleted file mode 100644 index 6b209c52d..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D - -USE DimensionsWrapper - -implicit none -private - - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper1D_t - private - contains - procedure(DimensionsWrapper1D_Set), deferred :: Set - procedure(DimensionsWrapper1D_Get), deferred :: Get - procedure(DimensionsWrapper1D_GetPointer), deferred :: GetPointer - end type - - abstract interface - subroutine DimensionsWrapper1D_Set(this, Value) - import DimensionsWrapper1D_t - class(DimensionsWrapper1D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:) - end subroutine - - subroutine DimensionsWrapper1D_Get(this, Value) - import DimensionsWrapper1D_t - class(DimensionsWrapper1D_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:) - end subroutine - - function DimensionsWrapper1D_GetPointer(this) result(Value) - import DimensionsWrapper1D_t - class(DimensionsWrapper1D_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - end function - - subroutine DimensionsWrapper1D_GetPolymorphic(this, Value) - import DimensionsWrapper1D_t - class(DimensionsWrapper1D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - end subroutine - end interface - -public :: DimensionsWrapper1D_t - -end module DimensionsWrapper1D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 deleted file mode 100644 index e4924683f..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 +++ /dev/null @@ -1,251 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_DLCA - -USE DimensionsWrapper1D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_DLCA_t - character(len=:), allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_DLCA_Set - procedure, public :: Get => DimensionsWrapper1D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper1D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper1D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper1D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper1D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper1D_DLCA_toString - procedure, public :: Free => DimensionsWrapper1D_DLCA_Free - procedure, public :: Print => DimensionsWrapper1D_DLCA_Print - final :: DimensionsWrapper1D_DLCA_Final - end type - -public :: DimensionsWrapper1D_DLCA_t - -contains - - - subroutine DimensionsWrapper1D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:) - integer :: err - !----------------------------------------------------------------- -#ifdef __GFORTRAN__ - call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& - file=__FILE__, line=__LINE__ ) -#else - select type (Value) - type is (character(len=*)) - - - allocate(character(len=len(Value))::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 (character(*))',& - file=__FILE__, line=__LINE__ ) - end select -#endif - end subroutine - - - subroutine DimensionsWrapper1D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - 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 (character(*))',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- -! allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 1D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = 0 - if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1))*size(this%value) - end function DimensionsWrapper1D_DLCA_DataSizeInBytes - - - function DimensionsWrapper1D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_DLCA_isOfDataType - - - subroutine DimensionsWrapper1D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_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(this%Value(idx)) // Sep - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper1D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_DLCA_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)', advance="no", iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = DLCA'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper1D_DLCA_Print - -end module DimensionsWrapper1D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 deleted file mode 100644 index 8f52360b3..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 +++ /dev/null @@ -1,227 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_I1P - -USE DimensionsWrapper1D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I1P_t - integer(I1P), allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_I1P_Set - procedure, public :: Get => DimensionsWrapper1D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper1D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper1D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper1D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper1D_I1P_isOfDataType - procedure, public :: toString => DimensionsWrapper1D_I1P_toString - procedure, public :: Free => DimensionsWrapper1D_I1P_Free - procedure, public :: Print => DimensionsWrapper1D_I1P_Print - final :: DimensionsWrapper1D_I1P_Final - end type - -public :: DimensionsWrapper1D_I1P_t - -contains - - - subroutine DimensionsWrapper1D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_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_I1P_DataSizeInBytes - - - function DimensionsWrapper1D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_I1P_isOfDataType - - - subroutine DimensionsWrapper1D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I1P_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 = I1P'//& - ', 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_I1P_Print - -end module DimensionsWrapper1D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 deleted file mode 100644 index ebb27ae12..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 +++ /dev/null @@ -1,225 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_I2P - -USE DimensionsWrapper1D -USE PENF, only: I2P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I2P_t - integer(I2P), allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_I2P_Set - procedure, public :: Get => DimensionsWrapper1D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper1D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper1D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper1D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper1D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper1D_I2P_toString - procedure, public :: Free => DimensionsWrapper1D_I2P_Free - procedure, public :: Print => DimensionsWrapper1D_I2P_Print - final :: DimensionsWrapper1D_I2P_Final - end type - -public :: DimensionsWrapper1D_I2P_t - -contains - - - subroutine DimensionsWrapper1D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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)), 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 DimensionsWrapper1D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 DimensionsWrapper1D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 DimensionsWrapper1D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic W2apper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I2P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 DimensionsWrapper1D_I2P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I2P_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_I2P_DataSizeInBytes - - - function DimensionsWrapper1D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I2P_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(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_I2P_isOfDataType - - - subroutine DimensionsWrapper1D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I2P_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_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 - call this%toString(strvalue) - write(unit=unit,fmt='(A)',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 = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper1D_I2P_Print - -end module DimensionsWrapper1D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 deleted file mode 100644 index e011507fc..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 +++ /dev/null @@ -1,226 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_I4P - -USE DimensionsWrapper1D -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 = '' - 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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 deleted file mode 100644 index 40c8eb64b..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 +++ /dev/null @@ -1,225 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_I8P - -USE DimensionsWrapper1D -USE PENF, only: i4P, I8P , str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I8P_t - integer(I8P), allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_I8P_Set - procedure, public :: Get => DimensionsWrapper1D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper1D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper1D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper1D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper1D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper1D_I8P_toString - procedure, public :: Print => DimensionsWrapper1D_I8P_Print - procedure, public :: Free => DimensionsWrapper1D_I8P_Free - final :: DimensionsWrapper1D_I8P_Final - end type - -public :: DimensionsWrapper1D_I8P_t - -contains - - - subroutine DimensionsWrapper1D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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)), 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 DimensionsWrapper1D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic W2apper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I8P_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_I8P_DataSizeInBytes - - - function DimensionsWrapper1D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I8P_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(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_I8P_isOfDataType - - - subroutine DimensionsWrapper1D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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, separator=Separator)) - end subroutine - - - subroutine DimensionsWrapper1D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_Print - -end module DimensionsWrapper1D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 deleted file mode 100644 index b6fa86fa3..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 +++ /dev/null @@ -1,235 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_L - -USE DimensionsWrapper1D -USE FPL_Utils -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 deleted file mode 100644 index 05f3d5c20..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 +++ /dev/null @@ -1,225 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_R4P - -USE DimensionsWrapper1D -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 = '' - 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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 deleted file mode 100644 index fa590fca8..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 +++ /dev/null @@ -1,225 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper1D_R8P - -USE DimensionsWrapper1D -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 = '' - 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) - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 deleted file mode 100644 index c5efef7e8..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D - -USE DimensionsWrapper - -implicit none -private - - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper2D_t - private - contains - procedure(DimensionsWrapper2D_Set), deferred :: Set - procedure(DimensionsWrapper2D_Get), deferred :: Get - procedure(DimensionsWrapper2D_GetPointer), deferred :: GetPointer - end type - - abstract interface - subroutine DimensionsWrapper2D_Set(this, Value) - import DimensionsWrapper2D_t - class(DimensionsWrapper2D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - end subroutine - - subroutine DimensionsWrapper2D_Get(this, Value) - import DimensionsWrapper2D_t - class(DimensionsWrapper2D_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - end subroutine - - function DimensionsWrapper2D_GetPointer(this) result(Value) - import DimensionsWrapper2D_t - class(DimensionsWrapper2D_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - end function - - subroutine DimensionsWrapper2D_GetPolymorphic(this, Value) - import DimensionsWrapper2D_t - class(DimensionsWrapper2D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:) - end subroutine - end interface - -public :: DimensionsWrapper2D_t - -end module DimensionsWrapper2D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 deleted file mode 100644 index 1dee149de..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_DLCA - -USE DimensionsWrapper2D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_DLCA_t - character(len=:), allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_DLCA_Set - procedure, public :: Get => DimensionsWrapper2D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper2D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper2D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper2D_DLCA_toString - procedure, public :: Free => DimensionsWrapper2D_DLCA_Free - procedure, public :: Print => DimensionsWrapper2D_DLCA_Print - final :: DimensionsWrapper2D_DLCA_Final - end type - -public :: DimensionsWrapper2D_DLCA_t - -contains - - - subroutine DimensionsWrapper2D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - integer :: err - !----------------------------------------------------------------- -#ifdef __GFORTRAN__ - call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& - file=__FILE__, line=__LINE__ ) -#else - select type (Value) - type is (character(len=*)) - allocate(character(len=len(Value)):: & - 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 (character(*))', & - file=__FILE__, line=__LINE__ ) - end select -#endif - end subroutine - - - subroutine DimensionsWrapper2D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - 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 (character(*))',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_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_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 2D - integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = 0 - if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1))*size(this%value) - end function DimensionsWrapper2D_DLCA_DataSizeInBytes - - - function DimensionsWrapper2D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_DLCA_isOfDataType - - - subroutine DimensionsWrapper2D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_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(this%Value(idx1,idx2)) // Sep - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper2D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_DLCA_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 = DLCA'//& - ', 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_DLCA_Print - -end module DimensionsWrapper2D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 deleted file mode 100644 index c1ff48b82..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 +++ /dev/null @@ -1,241 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_I1P - -USE DimensionsWrapper2D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I1P_t - integer(I1P), allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_I1P_Set - procedure, public :: Get => DimensionsWrapper2D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper2D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper2D_I1P_isOfDataType - procedure, public :: toString => DimensionsWrapper2D_I1P_toString - procedure, public :: Free => DimensionsWrapper2D_I1P_Free - procedure, public :: Print => DimensionsWrapper2D_I1P_Print - final :: DimensionsWrapper2D_I1P_Final - end type - -public :: DimensionsWrapper2D_I1P_t - -contains - - - subroutine DimensionsWrapper2D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_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_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_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_I1P_DataSizeInBytes - - - function DimensionsWrapper2D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_I1P_isOfDataType - - - subroutine DimensionsWrapper2D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I1P_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 = I1P'//& - ', 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_I1P_Print - -end module DimensionsWrapper2D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 deleted file mode 100644 index ab56d2de1..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 +++ /dev/null @@ -1,241 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_I2P - -USE DimensionsWrapper2D -USE PENF, only: I2P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I2P_t - integer(I2P), allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_I2P_Set - procedure, public :: Get => DimensionsWrapper2D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper2D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper2D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper2D_I2P_toString - procedure, public :: Free => DimensionsWrapper2D_I2P_Free - procedure, public :: Print => DimensionsWrapper2D_I2P_Print - final :: DimensionsWrapper2D_I2P_Final - end type - -public :: DimensionsWrapper2D_I2P_t - -contains - - - subroutine DimensionsWrapper2D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_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)), & - 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 DimensionsWrapper2D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_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 DimensionsWrapper2D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_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 DimensionsWrapper2D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I2P_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 - - - function DimensionsWrapper2D_I2P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I2P_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_I2P_DataSizeInBytes - - - function DimensionsWrapper2D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I2P_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(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_I2P_isOfDataType - - - subroutine DimensionsWrapper2D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_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 - - - subroutine DimensionsWrapper2D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I2P_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_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_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 DimensionsWrapper2D_I2P_Print - -end module DimensionsWrapper2D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 deleted file mode 100644 index a2259c9f2..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 +++ /dev/null @@ -1,240 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_I4P - -USE DimensionsWrapper2D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 deleted file mode 100644 index dec2da4ae..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 +++ /dev/null @@ -1,241 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_I8P - -USE DimensionsWrapper2D -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 - 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 DimensionsWrapper2D_I8P_Print - -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 deleted file mode 100644 index 65389e615..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 +++ /dev/null @@ -1,243 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_L - -USE DimensionsWrapper2D -USE FPL_Utils -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 deleted file mode 100644 index 6b9f749f5..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 +++ /dev/null @@ -1,241 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_R4P - -USE DimensionsWrapper2D -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 - 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 DimensionsWrapper2D_R4P_Print - -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 deleted file mode 100644 index 9d8fbd362..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 +++ /dev/null @@ -1,241 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper2D_R8P - -USE DimensionsWrapper2D -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 - 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 DimensionsWrapper2D_R8P_Print - -end module DimensionsWrapper2D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 deleted file mode 100644 index 1d6ebf4a1..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D - -USE DimensionsWrapper - -implicit none -private - - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper3D_t - private - contains - procedure(DimensionsWrapper3D_Set), deferred :: Set - procedure(DimensionsWrapper3D_Get), deferred :: Get - procedure(DimensionsWrapper3D_GetPointer), deferred :: GetPointer - end type - - abstract interface - subroutine DimensionsWrapper3D_Set(this, Value) - import DimensionsWrapper3D_t - class(DimensionsWrapper3D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - end subroutine - - subroutine DimensionsWrapper3D_Get(this, Value) - import DimensionsWrapper3D_t - class(DimensionsWrapper3D_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - end subroutine - - function DimensionsWrapper3D_GetPointer(this) result(Value) - import DimensionsWrapper3D_t - class(DimensionsWrapper3D_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - end function - - subroutine DimensionsWrapper3D_GetPolymorphic(this, Value) - import DimensionsWrapper3D_t - class(DimensionsWrapper3D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:) - end subroutine - end interface - -public :: DimensionsWrapper3D_t - -end module DimensionsWrapper3D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 deleted file mode 100644 index 734281267..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 +++ /dev/null @@ -1,261 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_DLCA - -USE DimensionsWrapper3D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_DLCA_t - character(len=:), allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_DLCA_Set - procedure, public :: Get => DimensionsWrapper3D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper3D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper3D_DLCA_toString - procedure, public :: Free => DimensionsWrapper3D_DLCA_Free - procedure, public :: Print => DimensionsWrapper3D_DLCA_Print - final :: DimensionsWrapper3D_DLCA_Final - end type - -public :: DimensionsWrapper3D_DLCA_t - -contains - - - subroutine DimensionsWrapper3D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - integer :: err - !----------------------------------------------------------------- -#ifdef __GFORTRAN__ - call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& - file=__FILE__, line=__LINE__ ) -#else - select type (Value) - type is (character(len=*)) - allocate(character(len=len(Value)):: & - 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 (character(*))', & - file=__FILE__, line=__LINE__ ) - end select -#endif - end subroutine - - - subroutine DimensionsWrapper3D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - 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 (character(*))',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_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_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 3D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = 0 - if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) - end function DimensionsWrapper3D_DLCA_DataSizeInBytes - - - function DimensionsWrapper3D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_DLCA_isOfDataType - - - subroutine DimensionsWrapper3D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_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(this%Value(idx1,idx2,idx3)) // Sep - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper3D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_DLCA_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 = DLCA'//& - ', 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_DLCA_Print - -end module DimensionsWrapper3D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 deleted file mode 100644 index 988baecee..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 +++ /dev/null @@ -1,246 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_I1P - -USE DimensionsWrapper3D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I1P_t - integer(I1P), allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_I1P_Set - procedure, public :: Get => DimensionsWrapper3D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper3D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_I1P_isOfDataType - procedure, public :: Free => DimensionsWrapper3D_I1P_Free - procedure, public :: toString => DimensionsWrapper3D_I1P_toString - procedure, public :: Print => DimensionsWrapper3D_I1P_Print - final :: DimensionsWrapper3D_I1P_Final - end type - -public :: DimensionsWrapper3D_I1P_t - -contains - - - subroutine DimensionsWrapper3D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_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_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_t), intent(IN) :: this !< Dimensions wrapper 3D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !---------------------------------s-------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) - end function DimensionsWrapper3D_I1P_DataSizeInBytes - - - function DimensionsWrapper3D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_I1P_isOfDataType - - - subroutine DimensionsWrapper3D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I1P_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 = I1P'//& - ', 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_I1P_Print - -end module DimensionsWrapper3D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 deleted file mode 100644 index 56ae614fb..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 +++ /dev/null @@ -1,245 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_I2P - -USE DimensionsWrapper3D -USE PENF, only: I2P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I2P_t - integer(I2P), allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_I2P_Set - procedure, public :: Get => DimensionsWrapper3D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper3D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper3D_I2P_toString - procedure, public :: Free => DimensionsWrapper3D_I2P_Free - procedure, public :: Print => DimensionsWrapper3D_I2P_Print - final :: DimensionsWrapper3D_I2P_Final - end type - -public :: DimensionsWrapper3D_I2P_t - -contains - - - subroutine DimensionsWrapper3D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_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)), & - 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 DimensionsWrapper3D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_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 DimensionsWrapper3D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_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 DimensionsWrapper3D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_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)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper3D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I2P_t), intent(INOUT) :: this - integer :: err = FPLSuccess - !----------------------------------------------------------------- - 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_I2P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I2P_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_I2P_DataSizeInBytes - - - function DimensionsWrapper3D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I2P_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(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_I2P_isOfDataType - - - subroutine DimensionsWrapper3D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_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 - !----------------------------------------------------------------- - 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_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_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 DimensionsWrapper3D_I2P_Print - -end module DimensionsWrapper3D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 deleted file mode 100644 index 880940708..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 +++ /dev/null @@ -1,245 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_I4P - -USE DimensionsWrapper3D -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 - 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 DimensionsWrapper3D_I4P_Print - -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 deleted file mode 100644 index 385d0299e..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 +++ /dev/null @@ -1,245 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_I8P - -USE DimensionsWrapper3D -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 - 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 DimensionsWrapper3D_I8P_Print - -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 deleted file mode 100644 index dad4c1c13..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 +++ /dev/null @@ -1,247 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_L - -USE DimensionsWrapper3D -USE FPL_Utils -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 deleted file mode 100644 index 134fc66ab..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 +++ /dev/null @@ -1,244 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_R4P - -USE DimensionsWrapper3D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 deleted file mode 100644 index c349fdf60..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 +++ /dev/null @@ -1,245 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper3D_R8P - -USE DimensionsWrapper3D -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 - 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 DimensionsWrapper3D_R8P_Print - -end module DimensionsWrapper3D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 deleted file mode 100644 index 8b62522ff..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D - -USE DimensionsWrapper - -implicit none -private - - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper4D_t - private - contains - procedure(DimensionsWrapper4D_Set), deferred :: Set - procedure(DimensionsWrapper4D_Get), deferred :: Get - procedure(DimensionsWrapper4D_GetPointer), deferred :: GetPointer - end type - - abstract interface - subroutine DimensionsWrapper4D_Set(this, Value) - import DimensionsWrapper4D_t - class(DimensionsWrapper4D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - end subroutine - - subroutine DimensionsWrapper4D_Get(this, Value) - import DimensionsWrapper4D_t - class(DimensionsWrapper4D_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - end subroutine - - function DimensionsWrapper4D_GetPointer(this) result(Value) - import DimensionsWrapper4D_t - class(DimensionsWrapper4D_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - end function - - subroutine DimensionsWrapper4D_GetPolymorphic(this, Value) - import DimensionsWrapper4D_t - class(DimensionsWrapper4D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:) - end subroutine - end interface - -public :: DimensionsWrapper4D_t - -end module DimensionsWrapper4D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 deleted file mode 100644 index fc3f526b9..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 +++ /dev/null @@ -1,265 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_DLCA - -USE DimensionsWrapper4D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_DLCA_t - character(len=:), allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_DLCA_Set - procedure, public :: Get => DimensionsWrapper4D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper4D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_DLCA_toString - procedure, public :: Print => DimensionsWrapper4D_DLCA_Print - procedure, public :: Free => DimensionsWrapper4D_DLCA_Free - final :: DimensionsWrapper4D_DLCA_Final - end type - -public :: DimensionsWrapper4D_DLCA_t - -contains - - - subroutine DimensionsWrapper4D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - integer :: err - !----------------------------------------------------------------- -#ifdef __GFORTRAN__ - call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& - file=__FILE__, line=__LINE__ ) -#else - select type (Value) - type is (character(len=*)) - allocate(character(len=len(Value)):: & - 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 (character(*))', & - file=__FILE__, line=__LINE__ ) - end select -#endif - end subroutine - - - subroutine DimensionsWrapper4D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - 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 (character(*))',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper4D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_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_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_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_DLCA_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 4D - integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = 0 - if(allocated(this%value)) DAtaSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value) - end function DimensionsWrapper4D_DLCA_DataSizeInBytes - - - function DimensionsWrapper4D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_DLCA_isOfDataType - - - subroutine DimensionsWrapper4D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_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(this%Value(idx1,idx2,idx3,idx4)) // Sep - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper4D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_DLCA_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 = DLCA'//& - ', 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_DLCA_Print - -end module DimensionsWrapper4D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 deleted file mode 100644 index f0f5a64ed..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 +++ /dev/null @@ -1,249 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_I1P - -USE DimensionsWrapper4D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I1P_t - integer(I1P), allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_I1P_Set - procedure, public :: Get => DimensionsWrapper4D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper4D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_I1P_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_I1P_toString - procedure, public :: Print => DimensionsWrapper4D_I1P_Print - procedure, public :: Free => DimensionsWrapper4D_I1P_Free - final :: DimensionsWrapper4D_I1P_Final - end type - -public :: DimensionsWrapper4D_I1P_t - -contains - - - subroutine DimensionsWrapper4D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper4D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_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_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_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_I1P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_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_I1P_DataSizeInBytes - - - function DimensionsWrapper4D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_I1P_isOfDataType - - - subroutine DimensionsWrapper4D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I1P_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 = I1P'//& - ', 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_I1P_Print - -end module DimensionsWrapper4D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 deleted file mode 100644 index 12d20c0eb..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 +++ /dev/null @@ -1,249 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_I2P - -USE DimensionsWrapper4D -USE PENF, only: I2P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I2P_t - integer(I2P), allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_I2P_Set - procedure, public :: Get => DimensionsWrapper4D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper4D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_I2P_toString - procedure, public :: Print => DimensionsWrapper4D_I2P_Print - procedure, public :: Free => DimensionsWrapper4D_I2P_Free - final :: DimensionsWrapper4D_I2P_Final - end type - -public :: DimensionsWrapper4D_I2P_t - -contains - - - subroutine DimensionsWrapper4D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_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)), & - 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 DimensionsWrapper4D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper4D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_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)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper4D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I2P_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_I2P_DataSizeInBytes - - - function DimensionsWrapper4D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I2P_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(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_I2P_isOfDataType - - - subroutine DimensionsWrapper4D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_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 - !----------------------------------------------------------------- - 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_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_Print - -end module DimensionsWrapper4D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 deleted file mode 100644 index 9b3ff11dd..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 +++ /dev/null @@ -1,249 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_I4P - -USE DimensionsWrapper4D -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 - 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 DimensionsWrapper4D_I4P_Print - -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 deleted file mode 100644 index a14b3381d..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 +++ /dev/null @@ -1,250 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_I8P - -USE DimensionsWrapper4D -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 - 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 DimensionsWrapper4D_I8P_Print - -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 deleted file mode 100644 index 9699fd431..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 +++ /dev/null @@ -1,252 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_L - -USE DimensionsWrapper4D -USE FPL_Utils -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 - 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 DimensionsWrapper4D_L_Print - -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 deleted file mode 100644 index 09e494310..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 +++ /dev/null @@ -1,249 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_R4P - -USE DimensionsWrapper4D -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 - 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 DimensionsWrapper4D_R4P_Print - -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 deleted file mode 100644 index 400397aed..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 +++ /dev/null @@ -1,249 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper4D_R8P - -USE DimensionsWrapper4D -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 - 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 DimensionsWrapper4D_R8P_Print - -end module DimensionsWrapper4D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 deleted file mode 100644 index 7f8c09350..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D - -USE DimensionsWrapper - -implicit none -private - - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper5D_t - private - contains - procedure(DimensionsWrapper5D_Set), deferred :: Set - procedure(DimensionsWrapper5D_Get), deferred :: Get - procedure(DimensionsWrapper5D_GetPointer), deferred :: GetPointer - end type - - abstract interface - subroutine DimensionsWrapper5D_Set(this, Value) - import DimensionsWrapper5D_t - class(DimensionsWrapper5D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - end subroutine - - subroutine DimensionsWrapper5D_Get(this, Value) - import DimensionsWrapper5D_t - class(DimensionsWrapper5D_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - end subroutine - - function DimensionsWrapper5D_GetPointer(this) result(Value) - import DimensionsWrapper5D_t - class(DimensionsWrapper5D_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - end function - - subroutine DimensionsWrapper5D_GetPolymorphic(this, Value) - import DimensionsWrapper5D_t - class(DimensionsWrapper5D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) - end subroutine - end interface - -public :: DimensionsWrapper5D_t - -end module DimensionsWrapper5D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 deleted file mode 100644 index fe6869e80..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 +++ /dev/null @@ -1,269 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_DLCA - -USE DimensionsWrapper5D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_DLCA_t - character(len=:), allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_DLCA_Set - procedure, public :: Get => DimensionsWrapper5D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper5D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_DLCA_toString - procedure, public :: Print => DimensionsWrapper5D_DLCA_Print - procedure, public :: Free => DimensionsWrapper5D_DLCA_Free - final :: DimensionsWrapper5D_DLCA_Final - end type - -public :: DimensionsWrapper5D_DLCA_t - -contains - - - subroutine DimensionsWrapper5D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- -#ifdef __GFORTRAN__ - call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& - file=__FILE__, line=__LINE__ ) -#else - select type (Value) - type is (character(len=*)) - allocate(character(len=len(Value)):: & - 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 (character(*))', & - file=__FILE__, line=__LINE__ ) - - end select -#endif - end subroutine - - - subroutine DimensionsWrapper5D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - 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 (DLCA)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper5D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_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_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 5D - integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = 0 - if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value) - end function DimensionsWrapper5D_DLCA_DataSizeInBytes - - - function DimensionsWrapper5D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_DLCA_isOfDataType - - - subroutine DimensionsWrapper5D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_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(this%Value(idx1,idx2,idx3,idx4,idx5)) // Sep - enddo - enddo - enddo - enddo - enddo - String = String(:len(String)-1) - endif - end subroutine - - - subroutine DimensionsWrapper5D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_DLCA_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 = DLCA'//& - ', 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_DLCA_Print - -end module DimensionsWrapper5D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 deleted file mode 100644 index 68109a225..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 +++ /dev/null @@ -1,254 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_I1P - -USE DimensionsWrapper5D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I1P_t - integer(I1P), allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_I1P_Set - procedure, public :: Get => DimensionsWrapper5D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper5D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_I1P_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_I1P_toString - procedure, public :: Print => DimensionsWrapper5D_I1P_Print - procedure, public :: Free => DimensionsWrapper5D_I1P_Free - final :: DimensionsWrapper5D_I1P_Final - end type - -public :: DimensionsWrapper5D_I1P_t - -contains - - - subroutine DimensionsWrapper5D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper5D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper5D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_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_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_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_I1P_DataSizeInBytes - - - function DimensionsWrapper5D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_I1P_isOfDataType - - - subroutine DimensionsWrapper5D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I1P_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 = I1P'//& - ', 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_I1P_Print - -end module DimensionsWrapper5D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 deleted file mode 100644 index e78e2ed6e..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 +++ /dev/null @@ -1,253 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_I2P - -USE DimensionsWrapper5D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 deleted file mode 100644 index 3fbd5a841..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 +++ /dev/null @@ -1,252 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_I4P - -USE DimensionsWrapper5D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 deleted file mode 100644 index af5fc8610..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 +++ /dev/null @@ -1,252 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_I8P - -USE DimensionsWrapper5D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 deleted file mode 100644 index ec5e237e9..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 +++ /dev/null @@ -1,256 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_L - -USE DimensionsWrapper5D -USE FPL_Utils -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 deleted file mode 100644 index b340628f6..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 +++ /dev/null @@ -1,253 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_R4P - -USE DimensionsWrapper5D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 deleted file mode 100644 index 3521ff661..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 +++ /dev/null @@ -1,253 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper5D_R8P - -USE DimensionsWrapper5D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 deleted file mode 100644 index a5a10a6f1..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D - -USE DimensionsWrapper - -implicit none -private - - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper6D_t - private - contains - procedure(DimensionsWrapper6D_Set), deferred :: Set - procedure(DimensionsWrapper6D_Get), deferred :: Get - procedure(DimensionsWrapper6D_GetPointer), deferred :: GetPointer - end type - - abstract interface - subroutine DimensionsWrapper6D_Set(this, Value) - import DimensionsWrapper6D_t - class(DimensionsWrapper6D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - end subroutine - - subroutine DimensionsWrapper6D_Get(this, Value) - import DimensionsWrapper6D_t - class(DimensionsWrapper6D_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - end subroutine - - function DimensionsWrapper6D_GetPointer(this) result(Value) - import DimensionsWrapper6D_t - class(DimensionsWrapper6D_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - end function - - subroutine DimensionsWrapper6D_GetPolymorphic(this, Value) - import DimensionsWrapper6D_t - class(DimensionsWrapper6D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) - end subroutine - end interface - -public :: DimensionsWrapper6D_t - -end module DimensionsWrapper6D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 deleted file mode 100644 index dff63c7dc..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 +++ /dev/null @@ -1,273 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_DLCA - -USE DimensionsWrapper6D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_DLCA_t - character(len=:), allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_DLCA_Set - procedure, public :: Get => DimensionsWrapper6D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper6D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_DLCA_toString - procedure, public :: Print => DimensionsWrapper6D_DLCA_Print - procedure, public :: Free => DimensionsWrapper6D_DLCA_Free - final :: DimensionsWrapper6D_DLCA_Final - end type - -public :: DimensionsWrapper6D_DLCA_t - -contains - - - subroutine DimensionsWrapper6D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- -#ifdef __GFORTRAN__ - call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& - file=__FILE__, line=__LINE__ ) -#else - select type (Value) - type is (character(len=*)) - allocate(character(len=len(Value)):: & - 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 (character(*))', & - file=__FILE__, line=__LINE__ ) - - end select -#endif - end subroutine - - - subroutine DimensionsWrapper6D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - 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 (DLCA)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_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_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_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_DLCA_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 6D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = 0 - if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper6D_DLCA_DataSizeInBytes - - - function DimensionsWrapper6D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_DLCA_isOfDataType - - - subroutine DimensionsWrapper6D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_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(this%Value(idx1,idx2,idx3,idx4,idx5,idx6)) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - String = String(:len(String)-1) - endif - end subroutine - - - subroutine DimensionsWrapper6D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_DLCA_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 = DLCA'//& - ', 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_DLCA_Print - -end module DimensionsWrapper6D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 deleted file mode 100644 index a7abfd629..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_I1P - -USE DimensionsWrapper6D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I1P_t - integer(I1P), allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_I1P_Set - procedure, public :: Get => DimensionsWrapper6D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper6D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_I1P_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_I1P_toString - procedure, public :: Print => DimensionsWrapper6D_I1P_Print - procedure, public :: Free => DimensionsWrapper6D_I1P_Free - final :: DimensionsWrapper6D_I1P_Final - end type - -public :: DimensionsWrapper6D_I1P_t - -contains - - - subroutine DimensionsWrapper6D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper6D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_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_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_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_I1P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_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_I1P_DataSizeInBytes - - - function DimensionsWrapper6D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_I1P_isOfDataType - - - subroutine DimensionsWrapper6D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I1P_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 = I1P'//& - ', 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_I1P_Print - -end module DimensionsWrapper6D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 deleted file mode 100644 index 7d1841fdc..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_I2P - -USE DimensionsWrapper6D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 deleted file mode 100644 index c91f3141b..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_I4P - -USE DimensionsWrapper6D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 deleted file mode 100644 index 754a73cdc..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 +++ /dev/null @@ -1,258 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_I8P - -USE DimensionsWrapper6D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 deleted file mode 100644 index 657218d52..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 +++ /dev/null @@ -1,260 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_L - -USE DimensionsWrapper6D -USE FPL_Utils -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) - 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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 deleted file mode 100644 index c5f84b200..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_R4P - -USE DimensionsWrapper6D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 deleted file mode 100644 index a9864c4a6..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper6D_R8P - -USE DimensionsWrapper6D -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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 deleted file mode 100644 index 1f1bf25f4..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 +++ /dev/null @@ -1,64 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D - -USE DimensionsWrapper - -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 - - 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 - - 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 - -public :: DimensionsWrapper7D_t - -end module DimensionsWrapper7D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 deleted file mode 100644 index 5403abece..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 +++ /dev/null @@ -1,276 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_DLCA - -USE DimensionsWrapper7D -USE PENF, only: I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_DLCA_t - character(len=:), allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_DLCA_Set - procedure, public :: Get => DimensionsWrapper7D_DLCA_Get - procedure, public :: GetShape => DimensionsWrapper7D_DLCA_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_DLCA_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_DLCA_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_DLCA_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_DLCA_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_DLCA_toString - procedure, public :: Print => DimensionsWrapper7D_DLCA_Print - procedure, public :: Free => DimensionsWrapper7D_DLCA_Free - final :: DimensionsWrapper7D_DLCA_Final - end type - -public :: DimensionsWrapper7D_DLCA_t - -contains - - - subroutine DimensionsWrapper7D_DLCA_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_DLCA_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_DLCA_Set(this, Value) - !----------------------------------------------------------------- - !< Set DLCA Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- -#ifdef __GFORTRAN__ - call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& - file=__FILE__, line=__LINE__ ) -#else - select type (Value) - type is (character(len=*)) - allocate(character(len=len(Value)):: & - 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 (character(*))', & - file=__FILE__, line=__LINE__ ) - end select -#endif - end subroutine - - - subroutine DimensionsWrapper7D_DLCA_Get(this, Value) - !----------------------------------------------------------------- - !< Get deferred length character array Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (character(len=*)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - if(len(Value) >= len(this%Value)) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Not enought length ('// & - trim(str(no_sign=.true.,n=len(Value)))//'<'// & - trim(str(no_sign=.true.,n=len(this%Value)))//')',& - file=__FILE__, line=__LINE__ ) - endif - 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 (character(*))',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_DLCA_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_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_DLCA_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_DLCA_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_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_DLCA_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 7D - integer(I4P) :: dAtaSizeInBytes !< Data size in bytes - !----------------------------------------------------------------- - DataSizeInBytes = 0 - if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper7D_DLCA_DataSizeInBytes - - - function DimensionsWrapper7D_DLCA_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_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 (character(len=*)) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_DLCA_isOfDataType - - - subroutine DimensionsWrapper7D_DLCA_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_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(this%Value(idx1,idx2,idx3,idx4,idx5,idx6,idx7)) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - enddo - String = String(:len(String)-1) - endif - end subroutine - - - subroutine DimensionsWrapper7D_DLCA_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_DLCA_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 = DLCA'//& - ', 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_DLCA_Print - -end module DimensionsWrapper7D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 deleted file mode 100644 index 898342d08..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 +++ /dev/null @@ -1,260 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_I1P - -USE DimensionsWrapper7D -USE PENF, only: I1P, I4P, str, byte_size -USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I1P_t - integer(I1P), allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_I1P_Set - procedure, public :: Get => DimensionsWrapper7D_I1P_Get - procedure, public :: GetShape => DimensionsWrapper7D_I1P_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_I1P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_I1P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I1P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_I1P_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_I1P_toString - procedure, public :: Print => DimensionsWrapper7D_I1P_Print - procedure, public :: Free => DimensionsWrapper7D_I1P_Free - final :: DimensionsWrapper7D_I1P_Final - end type - -public :: DimensionsWrapper7D_I1P_t - -contains - - - subroutine DimensionsWrapper7D_I1P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_I1P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_I1P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I1P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I1P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I1P)) - 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 (I1P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I1P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_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_I1P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_I1P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_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_I1P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_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_I1P_DataSizeInBytes - - - function DimensionsWrapper7D_I1P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_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(I1P)) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_I1P_isOfDataType - - - subroutine DimensionsWrapper7D_I1P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I1P_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 = I1P'//& - ', 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_I1P_Print - -end module DimensionsWrapper7D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 deleted file mode 100644 index b86dc8c82..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 +++ /dev/null @@ -1,260 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_I2P - -USE DimensionsWrapper7D -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) - 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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 deleted file mode 100644 index 32f371693..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 +++ /dev/null @@ -1,260 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_I4P - -USE DimensionsWrapper7D -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) - 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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 deleted file mode 100644 index a6cbcaa18..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 +++ /dev/null @@ -1,260 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_I8P - -USE DimensionsWrapper7D -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) - 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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 deleted file mode 100644 index 08dc231a5..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 +++ /dev/null @@ -1,262 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_L - -USE DimensionsWrapper7D -USE FPL_Utils -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 - !----------------------------------------------------------------- - 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) - 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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 deleted file mode 100644 index cbd5cc5a9..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 +++ /dev/null @@ -1,260 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_R4P - -USE DimensionsWrapper7D -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) - 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 - 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 deleted file mode 100644 index 90c0581ad..000000000 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 +++ /dev/null @@ -1,259 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DimensionsWrapper7D_R8P - -USE DimensionsWrapper7D -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) - 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 - 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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 deleted file mode 100644 index c146d848f..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 +++ /dev/null @@ -1,354 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module DLCAWrapperFactory - -USE PENF, only: I1P -USE WrapperFactory -USE DimensionsWrapper -USE DimensionsWrapper0D_DLCA -USE DimensionsWrapper1D_DLCA -USE DimensionsWrapper2D_DLCA -USE DimensionsWrapper3D_DLCA -USE DimensionsWrapper4D_DLCA -USE DimensionsWrapper5D_DLCA -USE DimensionsWrapper6D_DLCA -USE DimensionsWrapper7D_DLCA - -implicit none -private - - type, extends(WrapperFactory_t) :: DLCAWrapperFactory_t - private - - contains - procedure :: Wrap0D => DLCAWrapperFactory_Wrap0D - procedure :: Wrap1D => DLCAWrapperFactory_Wrap1D - procedure :: Wrap2D => DLCAWrapperFactory_Wrap2D - procedure :: Wrap3D => DLCAWrapperFactory_Wrap3D - procedure :: Wrap4D => DLCAWrapperFactory_Wrap4D - procedure :: Wrap5D => DLCAWrapperFactory_Wrap5D - procedure :: Wrap6D => DLCAWrapperFactory_Wrap6D - procedure :: Wrap7D => DLCAWrapperFactory_Wrap7D - procedure :: UnWrap0D => DLCAWrapperFactory_UnWrap0D - procedure :: UnWrap1D => DLCAWrapperFactory_UnWrap1D - procedure :: UnWrap2D => DLCAWrapperFactory_UnWrap2D - procedure :: UnWrap3D => DLCAWrapperFactory_UnWrap3D - procedure :: UnWrap4D => DLCAWrapperFactory_UnWrap4D - procedure :: UnWrap5D => DLCAWrapperFactory_UnWrap5D - procedure :: UnWrap6D => DLCAWrapperFactory_UnWrap6D - procedure :: UnWrap7D => DLCAWrapperFactory_UnWrap7D - procedure, public :: hasSameType => DLCAWrapperFactory_hasSameType - end type - - type(DLCAWrapperFactory_t), public, save :: WrapperFactoryDLCA - !$OMP THREADPRIVATE(WrapperFactoryDLCA) - -contains - - function DLCAWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (character(len=*)) - hasSameType = .true. - end select - end function DLCAWrapperFactory_hasSameType - - - function DLCAWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 0D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap0D - - - function DLCAWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 1D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap1D - - - function DLCAWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 2D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap2D - - - function DLCAWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 3D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_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_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap3D - - - function DLCAWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 4D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_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_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap4D - - - function DLCAWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 5D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_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_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap5D - - - function DLCAWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 6D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_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_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap6D - - - function DLCAWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create DLCA 7D Wrapper - !----------------------------------------------------------------- - class(DLCAWrapperFactory_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_DLCA_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_DLCA_t) - call Wrapper%Set(Value=Value) - end select - endif - end function DLCAWrapperFactory_Wrap7D - - - subroutine DLCAWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 0D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine DLCAWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 1D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine DLCAWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 2D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine DLCAWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 3D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine DLCAWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 4D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine DLCAWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 5D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine DLCAWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 6D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine DLCAWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the DLCA 7D Wrapped Value - !----------------------------------------------------------------- - class(DLCAWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_DLCA_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - -end module DLCAWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 deleted file mode 100644 index 303f2b216..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 +++ /dev/null @@ -1,354 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module I1PWrapperFactory - -USE WrapperFactory -USE PENF, only: I1P -USE DimensionsWrapper -USE DimensionsWrapper0D_I1P -USE DimensionsWrapper1D_I1P -USE DimensionsWrapper2D_I1P -USE DimensionsWrapper3D_I1P -USE DimensionsWrapper4D_I1P -USE DimensionsWrapper5D_I1P -USE DimensionsWrapper6D_I1P -USE DimensionsWrapper7D_I1P - -implicit none -private - - type, extends(WrapperFactory_t) :: I1PWrapperFactory_t - private - - contains - procedure :: Wrap0D => I1PWrapperFactory_Wrap0D - procedure :: Wrap1D => I1PWrapperFactory_Wrap1D - procedure :: Wrap2D => I1PWrapperFactory_Wrap2D - procedure :: Wrap3D => I1PWrapperFactory_Wrap3D - procedure :: Wrap4D => I1PWrapperFactory_Wrap4D - procedure :: Wrap5D => I1PWrapperFactory_Wrap5D - procedure :: Wrap6D => I1PWrapperFactory_Wrap6D - procedure :: Wrap7D => I1PWrapperFactory_Wrap7D - procedure :: UnWrap0D => I1PWrapperFactory_UnWrap0D - procedure :: UnWrap1D => I1PWrapperFactory_UnWrap1D - procedure :: UnWrap2D => I1PWrapperFactory_UnWrap2D - procedure :: UnWrap3D => I1PWrapperFactory_UnWrap3D - procedure :: UnWrap4D => I1PWrapperFactory_UnWrap4D - procedure :: UnWrap5D => I1PWrapperFactory_UnWrap5D - procedure :: UnWrap6D => I1PWrapperFactory_UnWrap6D - procedure :: UnWrap7D => I1PWrapperFactory_UnWrap7D - procedure, public :: hasSameType => I1PWrapperFactory_hasSameType - end type - - type(I1PWrapperFactory_t), save, public :: WrapperFactoryI1P - !$OMP THREADPRIVATE(WrapperFactoryI1P) - -contains - - function I1PWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (integer(I1P)) - hasSameType = .true. - end select - end function I1PWrapperFactory_hasSameType - - - function I1PWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 0D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap0D - - - function I1PWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 1D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap1D - - - function I1PWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 2D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap2D - - - function I1PWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 3D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_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_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap3D - - - function I1PWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 4D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_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_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap4D - - - function I1PWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 5D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_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_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap5D - - - function I1PWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 6D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_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_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap6D - - - function I1PWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I1P 7D Wrapper - !----------------------------------------------------------------- - class(I1PWrapperFactory_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_I1P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_I1P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I1PWrapperFactory_Wrap7D - - - subroutine I1PWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 0D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I1PWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 1D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I1PWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 2D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I1PWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 3D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I1PWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 4D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I1PWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 5D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I1PWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 6D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I1PWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I1P 7D Wrapped Value - !----------------------------------------------------------------- - class(I1PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_I1P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - -end module I1PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 deleted file mode 100644 index cebb80c3f..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 +++ /dev/null @@ -1,353 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module I2PWrapperFactory - -USE WrapperFactory -USE PENF, only: I1P, I2P -USE DimensionsWrapper -USE DimensionsWrapper0D_I2P -USE DimensionsWrapper1D_I2P -USE DimensionsWrapper2D_I2P -USE DimensionsWrapper3D_I2P -USE DimensionsWrapper4D_I2P -USE DimensionsWrapper5D_I2P -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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 deleted file mode 100644 index be2999f64..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 +++ /dev/null @@ -1,353 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module I4PWrapperFactory - -USE WrapperFactory -USE PENF, only: I1P, I4P -USE DimensionsWrapper -USE DimensionsWrapper0D_I4P -USE DimensionsWrapper1D_I4P -USE DimensionsWrapper2D_I4P -USE DimensionsWrapper3D_I4P -USE DimensionsWrapper4D_I4P -USE DimensionsWrapper5D_I4P -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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 deleted file mode 100644 index a63dfe521..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 +++ /dev/null @@ -1,353 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module I8PWrapperFactory - -USE WrapperFactory -USE PENF, only: I1P, I8P -USE DimensionsWrapper -USE DimensionsWrapper0D_I8P -USE DimensionsWrapper1D_I8P -USE DimensionsWrapper2D_I8P -USE DimensionsWrapper3D_I8P -USE DimensionsWrapper4D_I8P -USE DimensionsWrapper5D_I8P -USE DimensionsWrapper6D_I8P -USE DimensionsWrapper7D_I8P - -implicit none -private - - type, extends(WrapperFactory_t) :: I8PWrapperFactory_t - private - - contains - procedure :: Wrap0D => I8PWrapperFactory_Wrap0D - procedure :: Wrap1D => I8PWrapperFactory_Wrap1D - procedure :: Wrap2D => I8PWrapperFactory_Wrap2D - procedure :: Wrap3D => I8PWrapperFactory_Wrap3D - procedure :: Wrap4D => I8PWrapperFactory_Wrap4D - procedure :: Wrap5D => I8PWrapperFactory_Wrap5D - procedure :: Wrap6D => I8PWrapperFactory_Wrap6D - procedure :: Wrap7D => I8PWrapperFactory_Wrap7D - procedure :: UnWrap0D => I8PWrapperFactory_UnWrap0D - procedure :: UnWrap1D => I8PWrapperFactory_UnWrap1D - procedure :: UnWrap2D => I8PWrapperFactory_UnWrap2D - procedure :: UnWrap3D => I8PWrapperFactory_UnWrap3D - procedure :: UnWrap4D => I8PWrapperFactory_UnWrap4D - procedure :: UnWrap5D => I8PWrapperFactory_UnWrap5D - procedure :: UnWrap6D => I8PWrapperFactory_UnWrap6D - procedure :: UnWrap7D => I8PWrapperFactory_UnWrap7D - procedure, public :: hasSameType => I8PWrapperFactory_hasSameType - end type - - type(I8PWrapperFactory_t), save, public :: WrapperFactoryI8P - !$OMP THREADPRIVATE(WrapperFactoryI8P) - -contains - - function I8PWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (integer(I8P)) - hasSameType = .true. - end select - end function I8PWrapperFactory_hasSameType - - - function I8PWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 0D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap0D - - - function I8PWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 1D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap1D - - - function I8PWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 2D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap2D - - - function I8PWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 3D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_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_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap3D - - - function I8PWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 4D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_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_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap4D - - - function I8PWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 5D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_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_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap5D - - - function I8PWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 6D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_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_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap6D - - - function I8PWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I8P 7D Wrapper - !----------------------------------------------------------------- - class(I8PWrapperFactory_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_I8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_I8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I8PWrapperFactory_Wrap7D - - - subroutine I8PWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 0D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I8PWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 1D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I8PWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 2D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I8PWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 3D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I8PWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 4D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I8PWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 5D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I8PWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 6D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I8PWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I8P 7D Wrapped Value - !----------------------------------------------------------------- - class(I8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_I8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - -end module I8PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 deleted file mode 100644 index d21dd42c1..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 +++ /dev/null @@ -1,353 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module LWrapperFactory - -USE PENF, only: I1P -USE WrapperFactory -USE DimensionsWrapper -USE DimensionsWrapper0D_L -USE DimensionsWrapper1D_L -USE DimensionsWrapper2D_L -USE DimensionsWrapper3D_L -USE DimensionsWrapper4D_L -USE DimensionsWrapper5D_L -USE DimensionsWrapper6D_L -USE DimensionsWrapper7D_L - -implicit none -private - - type, extends(WrapperFactory_t) :: LWrapperFactory_t - private - - contains - procedure :: Wrap0D => LWrapperFactory_Wrap0D - procedure :: Wrap1D => LWrapperFactory_Wrap1D - procedure :: Wrap2D => LWrapperFactory_Wrap2D - procedure :: Wrap3D => LWrapperFactory_Wrap3D - procedure :: Wrap4D => LWrapperFactory_Wrap4D - procedure :: Wrap5D => LWrapperFactory_Wrap5D - procedure :: Wrap6D => LWrapperFactory_Wrap6D - procedure :: Wrap7D => LWrapperFactory_Wrap7D - procedure :: UnWrap0D => LWrapperFactory_UnWrap0D - procedure :: UnWrap1D => LWrapperFactory_UnWrap1D - procedure :: UnWrap2D => LWrapperFactory_UnWrap2D - procedure :: UnWrap3D => LWrapperFactory_UnWrap3D - procedure :: UnWrap4D => LWrapperFactory_UnWrap4D - procedure :: UnWrap5D => LWrapperFactory_UnWrap5D - procedure :: UnWrap6D => LWrapperFactory_UnWrap6D - procedure :: UnWrap7D => LWrapperFactory_UnWrap7D - procedure, public :: hasSameType => LWrapperFactory_hasSameType - end type - - type(LWrapperFactory_t), save, public :: WrapperFactoryL - !$OMP THREADPRIVATE(WrapperFactoryL) - -contains - - function LWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (logical) - hasSameType = .true. - end select - end function LWrapperFactory_hasSameType - - - function LWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 0D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap0D - - - function LWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 1D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap1D - - - function LWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 2D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap2D - - - function LWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 3D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_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_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap3D - - - function LWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 4D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_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_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap4D - - - function LWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 5D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_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_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap5D - - - function LWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 6D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_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_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap6D - - - function LWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create L 7D Wrapper - !----------------------------------------------------------------- - class(LWrapperFactory_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_L_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_L_t) - call Wrapper%Set(Value=Value) - end select - endif - end function LWrapperFactory_Wrap7D - - - subroutine LWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 0D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine LWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 1D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine LWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 2D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine LWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 3D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine LWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 4D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine LWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 5D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine LWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 6D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine LWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the L 7D Wrapped Value - !----------------------------------------------------------------- - class(LWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_L_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - -end module LWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 deleted file mode 100644 index f58934d4d..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 +++ /dev/null @@ -1,353 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module R4PWrapperFactory - -USE WrapperFactory -USE PENF, only: I1P, R4P -USE DimensionsWrapper -USE DimensionsWrapper0D_R4P -USE DimensionsWrapper1D_R4P -USE DimensionsWrapper2D_R4P -USE DimensionsWrapper3D_R4P -USE DimensionsWrapper4D_R4P -USE DimensionsWrapper5D_R4P -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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 deleted file mode 100644 index 92bcab984..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 +++ /dev/null @@ -1,353 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module R8PWrapperFactory - -USE WrapperFactory -USE PENF, only: I1P, R8P -USE DimensionsWrapper -USE DimensionsWrapper0D_R8P -USE DimensionsWrapper1D_R8P -USE DimensionsWrapper2D_R8P -USE DimensionsWrapper3D_R8P -USE DimensionsWrapper4D_R8P -USE DimensionsWrapper5D_R8P -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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 deleted file mode 100644 index 113c4c7c1..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 +++ /dev/null @@ -1,172 +0,0 @@ -module WrapperFactory - -USE DimensionsWrapper - -implicit none -private - - type, abstract :: WrapperFactory_t - private - - contains - private - procedure(WrapperFactory_Wrap0D), public, deferred :: Wrap0D - procedure(WrapperFactory_Wrap1D), public, deferred :: Wrap1D - procedure(WrapperFactory_Wrap2D), public, deferred :: Wrap2D - procedure(WrapperFactory_Wrap3D), public, deferred :: Wrap3D - procedure(WrapperFactory_Wrap4D), public, deferred :: Wrap4D - procedure(WrapperFactory_Wrap5D), public, deferred :: Wrap5D - procedure(WrapperFactory_Wrap6D), public, deferred :: Wrap6D - procedure(WrapperFactory_Wrap7D), public, deferred :: Wrap7D - procedure(WrapperFactory_hasSameType), public, deferred :: hasSameType - generic, public :: Wrap => Wrap0D, & - Wrap1D, & - Wrap2D, & - Wrap3D, & - Wrap4D, & - Wrap5D, & - Wrap6D, & - Wrap7D - end type - - abstract interface - function WrapperFactory_hasSameType(this, Value) result(hasSameType) - import WrapperFactory_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - end function - - function WrapperFactory_Wrap0D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - function WrapperFactory_Wrap1D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(:) - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - function WrapperFactory_Wrap2D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(:,:) - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - function WrapperFactory_Wrap3D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(:,:,:) - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - function WrapperFactory_Wrap4D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(:,:,:,:) - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - function WrapperFactory_Wrap5D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - function WrapperFactory_Wrap6D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - function WrapperFactory_Wrap7D(this, Value) result(Wrapper) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - class(DimensionsWrapper_t), pointer :: Wrapper - end function - - subroutine WrapperFactory_UnWrap0D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - end subroutine - - subroutine WrapperFactory_UnWrap1D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - end subroutine - - subroutine WrapperFactory_UnWrap2D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - end subroutine - - subroutine WrapperFactory_UnWrap3D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - end subroutine - - subroutine WrapperFactory_UnWrap4D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - end subroutine - - subroutine WrapperFactory_UnWrap5D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - end subroutine - - subroutine WrapperFactory_UnWrap6D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - end subroutine - - subroutine WrapperFactory_UnWrap7D(this, Wrapper, Value) - import WrapperFactory_t - import DimensionsWrapper_t - class(WrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - end subroutine - - end interface - -public :: WrapperFactory_t - -end module WrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 b/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 deleted file mode 100644 index 724c1f9f7..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 +++ /dev/null @@ -1,418 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -MODULE WrapperFactoryList - -USE PENF, ONLY: I4P -USE WrapperFactory - -IMPLICIT NONE -PRIVATE - -TYPE, PUBLIC :: WrapperFactoryList_t - PRIVATE - CHARACTER(:), ALLOCATABLE :: Key - CLASS(WrapperFactory_t), POINTER :: VALUE => NULL() - TYPE(WrapperFactoryList_t), POINTER :: Next => NULL() -CONTAINS - PRIVATE - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Init => WrapperFactoryList_Init - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: HasNext => WrapperFactoryList_HasNext - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: SetNext => WrapperFactoryList_SetNext - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetNext => WrapperFactoryList_GetNext - procedure, non_overridable, public :: NullifyNext => WrapperFactoryList_NullifyNext - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: HasKey => WrapperFactoryList_HasKey - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: SetKey => WrapperFactoryList_SetKey - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetKey => WrapperFactoryList_GetKey - procedure, non_overridable, public :: DeallocateKey => WrapperFactoryList_DeallocateKey - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: HasValue => WrapperFactoryList_HasValue - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: SetValue => WrapperFactoryList_SetValue - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetValue => WrapperFactoryList_GetValue - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Free => WrapperFactoryList_Free - procedure, non_overridable, public :: AddWrapperFactory => WrapperFactoryList_AddWrapperFactory - PROCEDURE, NON_OVERRIDABLE, PUBLIC :: PRINT => WrapperFactoryList_Print - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory0D - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory1D - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory2D - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory3D - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory4D - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory5D - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory6D - PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory7D - GENERIC, PUBLIC :: GetFactory => WrapperFactoryList_GetFactory0D, & - WrapperFactoryList_GetFactory1D, & - WrapperFactoryList_GetFactory2D, & - WrapperFactoryList_GetFactory3D, & - WrapperFactoryList_GetFactory4D, & - WrapperFactoryList_GetFactory5D, & - WrapperFactoryList_GetFactory6D, & - WrapperFactoryList_GetFactory7D - FINAL :: WrapperFactoryList_Finalize -END TYPE WrapperFactoryList_t - -CONTAINS - -SUBROUTINE WrapperFactoryList_Init(this) - !----------------------------------------------------------------- - !< Initialize the node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - !----------------------------------------------------------------- - IF (ALLOCATED(this%Key)) DEALLOCATE (this%Key) - NULLIFY (this%VALUE) - NULLIFY (this%Next) -END SUBROUTINE WrapperFactoryList_Init - -FUNCTION WrapperFactoryList_HasNext(this) RESULT(hasNext) - !----------------------------------------------------------------- - !< Check if Next is associated for the current Node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - LOGICAL :: hasNext !< Check if Next is associated - !----------------------------------------------------------------- - hasNext = ASSOCIATED(this%Next) -END FUNCTION WrapperFactoryList_HasNext - -SUBROUTINE WrapperFactoryList_SetNext(this, Next) - !----------------------------------------------------------------- - !< Set the pointer to the Next node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - CLASS(WrapperFactoryList_t), TARGET, INTENT(IN) :: Next !< Pointer to Next - !----------------------------------------------------------------- - this%Next => Next -END SUBROUTINE WrapperFactoryList_SetNext - -FUNCTION WrapperFactoryList_GetNext(this) RESULT(Next) - !----------------------------------------------------------------- - !< Return a pointer to the Next node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(WrapperFactoryList_t), POINTER :: Next !< Pointer to Next - !----------------------------------------------------------------- - NULLIFY (Next) - IF (this%HasNext()) Next => this%Next -END FUNCTION WrapperFactoryList_GetNext - -SUBROUTINE WrapperFactoryList_NullifyNext(this) - !----------------------------------------------------------------- - !< Nullify Next - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - !----------------------------------------------------------------- - NULLIFY (this%Next) -END SUBROUTINE WrapperFactoryList_NullifyNext - -FUNCTION WrapperFactoryList_HasKey(this) RESULT(hasKey) - !----------------------------------------------------------------- - !< Check if Key is allocated for the current Node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - LOGICAL :: hasKey !< Check if Key is associated - !----------------------------------------------------------------- - hasKey = ALLOCATED(this%Key) -END FUNCTION WrapperFactoryList_HasKey - -SUBROUTINE WrapperFactoryList_SetKey(this, Key) - !----------------------------------------------------------------- - !< Check if Next is associated for the current Node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - CHARACTER(len=*), INTENT(IN) :: Key !< Key - !----------------------------------------------------------------- - this%Key = Key -END SUBROUTINE WrapperFactoryList_SetKey - -FUNCTION WrapperFactoryList_GetKey(this) RESULT(Key) - !----------------------------------------------------------------- - !< Check if Next is associated for the current Node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CHARACTER(len=:), ALLOCATABLE :: Key !< Key - !----------------------------------------------------------------- - IF (this%HasKey()) Key = this%Key -END FUNCTION WrapperFactoryList_GetKey - -SUBROUTINE WrapperFactoryList_DeallocateKey(this) - !----------------------------------------------------------------- - !< Deallocate Key if allocated - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - !----------------------------------------------------------------- - IF (this%HasKey()) DEALLOCATE (this%Key) -END SUBROUTINE WrapperFactoryList_DeallocateKey - -FUNCTION WrapperFactoryList_HasValue(this) RESULT(hasValue) - !----------------------------------------------------------------- - !< Check if Value is allocated for the current Node - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - LOGICAL :: hasValue !< Check if Value is allocated - !----------------------------------------------------------------- - hasValue = ASSOCIATED(this%VALUE) -END FUNCTION WrapperFactoryList_HasValue - -SUBROUTINE WrapperFactoryList_SetValue(this, VALUE) - !----------------------------------------------------------------- - !< Return a concrete WrapperFactory - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - CLASS(WrapperFactory_t), TARGET, INTENT(IN) :: VALUE !< Concrete WrapperFactory - !----------------------------------------------------------------- - this%VALUE => VALUE -END SUBROUTINE WrapperFactoryList_SetValue - -SUBROUTINE WrapperFactoryList_GetValue(this, VALUE) - !----------------------------------------------------------------- - !< Return a concrete WrapperFactory - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(WrapperFactory_t), POINTER, INTENT(OUT) :: VALUE !< Concrete WrapperFactory pointer - !----------------------------------------------------------------- - NULLIFY (VALUE) - IF (this%HasValue()) VALUE => this%VALUE -END SUBROUTINE WrapperFactoryList_GetValue - -RECURSIVE SUBROUTINE WrapperFactoryList_Free(this) - !----------------------------------------------------------------- - !< Free the list - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - CLASS(WrapperFactoryList_t), POINTER :: Next !< Wrapper Factory List Node - !----------------------------------------------------------------- - IF (this%HasNext()) THEN - Next => this%GetNext() - CALL Next%Free() - DEALLOCATE (Next) - NULLIFY (Next) - END IF - IF (this%HasKey()) DEALLOCATE (this%Key) - NULLIFY (this%Next) - NULLIFY (this%VALUE) -END SUBROUTINE WrapperFactoryList_Free - -RECURSIVE SUBROUTINE WrapperFactoryList_Finalize(this) - !----------------------------------------------------------------- - !< Finalize procedure - !----------------------------------------------------------------- - TYPE(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List - !----------------------------------------------------------------- - CALL this%Free() -END SUBROUTINE WrapperFactoryList_Finalize - - recursive subroutine WrapperFactoryList_AddWrapperFactory(this,Key, WrapperFactory) - !----------------------------------------------------------------- - !< Add a new Node if key does not Exist - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_T), INTENT(INOUT) :: this !< Wrapper Factory List - CHARACTER(len=*), INTENT(IN) :: Key !< Key (unique) of the current node. - CLASS(WrapperFactory_t), TARGET, INTENT(IN) :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - IF (this%HasKey()) THEN - IF (this%GetKey() /= Key) THEN - IF (.NOT. this%hasNext()) THEN - ALLOCATE (WrapperFactoryList_t :: this%Next) - CALL this%Next%AddWrapperFactory(Key=Key, WrapperFactory=WrapperFactory) - ELSE - CALL this%Next%AddWrapperFactory(Key=Key, WrapperFactory=WrapperFactory) - END IF - ELSE - CALL this%SetValue(VALUE=WrapperFactory) - END IF - ELSE - CALL this%SetKey(Key=Key) - CALL this%SetValue(VALUE=WrapperFactory) - END IF -END SUBROUTINE WrapperFactoryList_AddWrapperFactory - - recursive function WrapperFactoryList_GetFactory0D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE)) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory0D - - recursive function WrapperFactoryList_GetFactory1D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE(1:) !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE(1))) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory1D - - recursive function WrapperFactoryList_GetFactory2D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE(1:, 1:) !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1))) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory2D - - recursive function WrapperFactoryList_GetFactory3D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1))) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory3D - - recursive function WrapperFactoryList_GetFactory4D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1))) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory4D - - recursive function WrapperFactoryList_GetFactory5D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1, 1))) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory5D - - recursive function WrapperFactoryList_GetFactory6D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1, 1, 1))) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory6D - - recursive function WrapperFactoryList_GetFactory7D(this, Value) result(WrapperFactory) - !----------------------------------------------------------------- - !< Return a WrapperFactory given a value - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List - CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Polymorphic Mold - CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory - !----------------------------------------------------------------- - NULLIFY (WrapperFactory) - IF (this%HasKey() .AND. this%HasValue()) THEN - IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1, 1, 1, 1))) THEN - WrapperFactory => this%VALUE - ELSEIF (this%HasNext()) THEN - WrapperFactory => this%Next%GetFactory(VALUE=VALUE) - END IF - END IF -END FUNCTION WrapperFactoryList_GetFactory7D - -SUBROUTINE WrapperFactoryList_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print the keys contained in the list - !----------------------------------------------------------------- - CLASS(WrapperFactoryList_t), TARGET, INTENT(IN) :: this !< Wrapper Factory List - 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. - INTEGER(I4P) :: iostatd !< IO error. - CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. - CLASS(WrapperFactoryList_T), POINTER :: Node !< Pointer for scanning the list. - !----------------------------------------------------------------- - prefd = ''; IF (PRESENT(prefix)) prefd = prefix - Node => this - WRITE (*, fmt='(A)') prefd//' WRAPPER FACTORY LIST KEYS:' - DO WHILE (Node%HasKey()) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//' Key = '//Node%GetKey() - IF (Node%HasNExt()) THEN - Node => Node%GetNext() - ELSE - EXIT - END IF - END DO - IF (PRESENT(iostat)) iostat = iostatd - IF (PRESENT(iomsg)) iomsg = iomsgd -END SUBROUTINE WrapperFactoryList_Print - -END MODULE WrapperFactoryList diff --git a/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 b/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 deleted file mode 100644 index 23cf3a4c6..000000000 --- a/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 +++ /dev/null @@ -1,60 +0,0 @@ -!----------------------------------------------------------------- -! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, -! Javier Principe and Víctor Sande. -! All rights reserved. -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 3.0 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library. -!----------------------------------------------------------------- - -module WrapperFactoryListSingleton - -USE WrapperFactoryList -USE DLCAWrapperFactory -USE I1PWrapperFactory -USE I2PWrapperFactory -USE I4PWrapperFactory -USE I8PWrapperFactory -USE LWrapperFactory -USE R4PWrapperFactory -USE R8PWrapperFactory - -implicit none -private - - type(WrapperFactoryList_t), save :: TheWrapperFactoryList - !$OMP THREADPRIVATE(TheWrapperFactoryList) - -public :: TheWrapperFactoryList -public :: TheWrapperFactoryList_Init - -contains - - 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) - call TheWrapperFactoryList%AddWrapperFactory(key='I8P', WrapperFactory=WrapperFactoryI8P) - call TheWrapperFactoryList%AddWrapperFactory(key='R4P', WrapperFactory=WrapperFactoryR4P) - 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 module WrapperFactoryListSingleton diff --git a/src/modules/FacetMatrix/CMakeLists.txt b/src/modules/FacetMatrix/CMakeLists.txt deleted file mode 100644 index fed11a933..000000000 --- a/src/modules/FacetMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FacetMatrix_Method.F90 -) diff --git a/src/modules/FacetMatrix/src/FacetMatrix1.inc b/src/modules/FacetMatrix/src/FacetMatrix1.inc deleted file mode 100644 index afcfc045c..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix1.inc +++ /dev/null @@ -1,175 +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 -! - -PUBLIC :: FacetMatrix1 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau\left[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot -! {\bf n}\right]\cdot\left[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} -! \right]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix1_1( masterElemSD, slaveElemSD, & - & quadMap ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix1_1 -END INTERFACE - -INTERFACE FacetMatrix1 - MODULE PROCEDURE FacetMatrix1_1 -END INTERFACE FacetMatrix1 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau\left[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot -! {\bf n}\right]\cdot\left[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} -! \right]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix1_2( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix1_2 -END INTERFACE - -INTERFACE FacetMatrix1 - MODULE PROCEDURE FacetMatrix1_2 -END INTERFACE FacetMatrix1 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix1_3( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauvar, quadMap ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix1_3 -END INTERFACE - -INTERFACE FacetMatrix1 - MODULE PROCEDURE FacetMatrix1_3 -END INTERFACE FacetMatrix1 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix1_4( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix1_4 -END INTERFACE - -INTERFACE FacetMatrix1 - MODULE PROCEDURE FacetMatrix1_4 -END INTERFACE FacetMatrix1 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix1_5( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauvar, quadMap ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix1_5 -END INTERFACE - -INTERFACE FacetMatrix1 - MODULE PROCEDURE FacetMatrix1_5 -END INTERFACE FacetMatrix1 diff --git a/src/modules/FacetMatrix/src/FacetMatrix11.inc b/src/modules/FacetMatrix/src/FacetMatrix11.inc deleted file mode 100644 index c00d50d16..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix11.inc +++ /dev/null @@ -1,178 +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 -! - -PUBLIC :: FacetMatrix11 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix11_1( masterElemSD, slaveElemSD, quadMap, & - & nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix11_1 -END INTERFACE - -INTERFACE FacetMatrix11 - MODULE PROCEDURE FacetMatrix11_1 -END INTERFACE FacetMatrix11 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix11_2( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap, nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix11_2 -END INTERFACE - -INTERFACE FacetMatrix11 - MODULE PROCEDURE FacetMatrix11_2 -END INTERFACE FacetMatrix11 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix11_3( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauvar, quadMap, nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix11_3 -END INTERFACE - -INTERFACE FacetMatrix11 - MODULE PROCEDURE FacetMatrix11_3 -END INTERFACE FacetMatrix11 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix11_4( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap, nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix11_4 -END INTERFACE - -INTERFACE FacetMatrix11 - MODULE PROCEDURE FacetMatrix11_4 -END INTERFACE FacetMatrix11 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix11_5( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauvar, quadMap, nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix11_5 -END INTERFACE - -INTERFACE FacetMatrix11 - MODULE PROCEDURE FacetMatrix11_5 -END INTERFACE FacetMatrix11 diff --git a/src/modules/FacetMatrix/src/FacetMatrix12.inc b/src/modules/FacetMatrix/src/FacetMatrix12.inc deleted file mode 100644 index 7e35f04f0..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix12.inc +++ /dev/null @@ -1,166 +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 -! - -PUBLIC :: FacetMatrix12 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot -! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} -! dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix12_1( elemsd, nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix12_1 -END INTERFACE - -INTERFACE FacetMatrix12 - MODULE PROCEDURE FacetMatrix12_1 -END INTERFACE FacetMatrix12 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot -! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} -! dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix12_2( elemsd, mu, nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix12_2 -END INTERFACE - -INTERFACE FacetMatrix12 - MODULE PROCEDURE FacetMatrix12_2 -END INTERFACE FacetMatrix12 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot -! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} -! dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix12_3( elemsd, mu, tauvar, nCopy ) & - & RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix12_3 -END INTERFACE - -INTERFACE FacetMatrix12 - MODULE PROCEDURE FacetMatrix12_3 -END INTERFACE FacetMatrix12 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot -! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} -! dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix12_4( elemsd, mu, nCopy ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix12_4 -END INTERFACE - -INTERFACE FacetMatrix12 - MODULE PROCEDURE FacetMatrix12_4 -END INTERFACE FacetMatrix12 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot -! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} -! dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix12_5( elemsd, mu, tauvar, nCopy ) & - & RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix12_5 -END INTERFACE - -INTERFACE FacetMatrix12 - MODULE PROCEDURE FacetMatrix12_5 -END INTERFACE FacetMatrix12 diff --git a/src/modules/FacetMatrix/src/FacetMatrix13.inc b/src/modules/FacetMatrix/src/FacetMatrix13.inc deleted file mode 100644 index 2465a2125..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix13.inc +++ /dev/null @@ -1,187 +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 -! - -PUBLIC :: FacetMatrix13 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix13_1( elemsd, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix13_1 -END INTERFACE - -INTERFACE FacetMatrix13 - MODULE PROCEDURE FacetMatrix13_1 -END INTERFACE FacetMatrix13 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix13_2( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix13_2 -END INTERFACE - -INTERFACE FacetMatrix13 - MODULE PROCEDURE FacetMatrix13_2 -END INTERFACE FacetMatrix13 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix13_3( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix13_3 -END INTERFACE - -INTERFACE FacetMatrix13 - MODULE PROCEDURE FacetMatrix13_3 -END INTERFACE FacetMatrix13 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix13_4( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix13_4 -END INTERFACE - -INTERFACE FacetMatrix13 - MODULE PROCEDURE FacetMatrix13_4 -END INTERFACE FacetMatrix13 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix13_5( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix13_5 -END INTERFACE - -INTERFACE FacetMatrix13 - MODULE PROCEDURE FacetMatrix13_5 -END INTERFACE FacetMatrix13 diff --git a/src/modules/FacetMatrix/src/FacetMatrix14.inc b/src/modules/FacetMatrix/src/FacetMatrix14.inc deleted file mode 100644 index c2e39bd4e..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix14.inc +++ /dev/null @@ -1,187 +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 -! - -PUBLIC :: FacetMatrix14 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix14_1( elemsd, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix14_1 -END INTERFACE - -INTERFACE FacetMatrix14 - MODULE PROCEDURE FacetMatrix14_1 -END INTERFACE FacetMatrix14 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix14_2( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix14_2 -END INTERFACE - -INTERFACE FacetMatrix14 - MODULE PROCEDURE FacetMatrix14_2 -END INTERFACE FacetMatrix14 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix14_3( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix14_3 -END INTERFACE - -INTERFACE FacetMatrix14 - MODULE PROCEDURE FacetMatrix14_3 -END INTERFACE FacetMatrix14 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix14_4( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix14_4 -END INTERFACE - -INTERFACE FacetMatrix14 - MODULE PROCEDURE FacetMatrix14_4 -END INTERFACE FacetMatrix14 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} -! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac -! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ -! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar -! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac -! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end -! {aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix14_5( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix14_5 -END INTERFACE - -INTERFACE FacetMatrix14 - MODULE PROCEDURE FacetMatrix14_5 -END INTERFACE FacetMatrix14 diff --git a/src/modules/FacetMatrix/src/FacetMatrix15.inc b/src/modules/FacetMatrix/src/FacetMatrix15.inc deleted file mode 100644 index 11adb0e51..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix15.inc +++ /dev/null @@ -1,214 +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 -! - -PUBLIC :: FacetMatrix15 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix15_1( masterElemSD, slaveElemSD, & - & quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix15_1 -END INTERFACE - -INTERFACE FacetMatrix15 - MODULE PROCEDURE FacetMatrix15_1 -END INTERFACE FacetMatrix15 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix15_2( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix15_2 -END INTERFACE - -INTERFACE FacetMatrix15 - MODULE PROCEDURE FacetMatrix15_2 -END INTERFACE FacetMatrix15 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix15_3( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - REAL( DFP ), INTENT( IN ) :: tauMaster - REAL( DFP ), INTENT( IN ) :: tauSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix15_3 -END INTERFACE - -INTERFACE FacetMatrix15 - MODULE PROCEDURE FacetMatrix15_3 -END INTERFACE FacetMatrix15 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix15_4( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix15_4 -END INTERFACE - -INTERFACE FacetMatrix15 - MODULE PROCEDURE FacetMatrix15_4 -END INTERFACE FacetMatrix15 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix15_5( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster - TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix15_5 -END INTERFACE - -INTERFACE FacetMatrix15 - MODULE PROCEDURE FacetMatrix15_5 -END INTERFACE FacetMatrix15 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix15_6( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster - TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix15_6 -END INTERFACE - -INTERFACE FacetMatrix15 - MODULE PROCEDURE FacetMatrix15_6 -END INTERFACE FacetMatrix15 diff --git a/src/modules/FacetMatrix/src/FacetMatrix2.inc b/src/modules/FacetMatrix/src/FacetMatrix2.inc deleted file mode 100644 index b3294f35c..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix2.inc +++ /dev/null @@ -1,159 +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 -! - -PUBLIC :: FacetMatrix2 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot -! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} -! \right)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix2_1( elemsd ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix2_1 -END INTERFACE - -INTERFACE FacetMatrix2 - MODULE PROCEDURE FacetMatrix2_1 -END INTERFACE FacetMatrix2 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot -! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} -! \right)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix2_2( elemsd, mu ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix2_2 -END INTERFACE - -INTERFACE FacetMatrix2 - MODULE PROCEDURE FacetMatrix2_2 -END INTERFACE FacetMatrix2 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot -! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} -! \right)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix2_3( elemsd, mu, tauvar ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix2_3 -END INTERFACE - -INTERFACE FacetMatrix2 - MODULE PROCEDURE FacetMatrix2_3 -END INTERFACE FacetMatrix2 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot -! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} -! \right)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix2_4( elemsd, mu ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix2_4 -END INTERFACE - -INTERFACE FacetMatrix2 - MODULE PROCEDURE FacetMatrix2_4 -END INTERFACE FacetMatrix2 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot -! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} -! \right)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix2_5( elemsd, mu, tauvar ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix2_5 -END INTERFACE - -INTERFACE FacetMatrix2 - MODULE PROCEDURE FacetMatrix2_5 -END INTERFACE FacetMatrix2 diff --git a/src/modules/FacetMatrix/src/FacetMatrix21.inc b/src/modules/FacetMatrix/src/FacetMatrix21.inc deleted file mode 100644 index d26991dac..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix21.inc +++ /dev/null @@ -1,103 +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 -! - -PUBLIC :: FacetMatrix21 - -!---------------------------------------------------------------------------- -! FacetMatrix21 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\delta p{\bf n}\cdot\nabla pdS & -! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau N^{I}{\bf n}\cdot\nabla N^{J} -! dS\right)p_{J}\end{aligned} -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix21_1( elemsd ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix21_1 -END INTERFACE - -INTERFACE FacetMatrix21 - MODULE PROCEDURE FacetMatrix21_1 -END INTERFACE FacetMatrix21 - -!---------------------------------------------------------------------------- -! FacetMatrix21 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\delta p{\bf n}\cdot\nabla pdS & -! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau N^{I}{\bf n}\cdot\nabla N^{J} -! dS\right)p_{J}\end{aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix21_2( elemsd, tauvar ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix21_2 -END INTERFACE - -INTERFACE FacetMatrix21 - MODULE PROCEDURE FacetMatrix21_2 -END INTERFACE FacetMatrix21 - -!---------------------------------------------------------------------------- -! FacetMatrix21 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}\tau\delta p{\bf n}\cdot\nabla pdS & -! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau N^{I}{\bf n}\cdot\nabla N^{J} -! dS\right)p_{J}\end{aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix21_3( elemsd, tauvar ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix21_3 -END INTERFACE - -INTERFACE FacetMatrix21 - MODULE PROCEDURE FacetMatrix21_3 -END INTERFACE FacetMatrix21 diff --git a/src/modules/FacetMatrix/src/FacetMatrix22.inc b/src/modules/FacetMatrix/src/FacetMatrix22.inc deleted file mode 100644 index 3dee21d1b..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix22.inc +++ /dev/null @@ -1,103 +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 -! - -PUBLIC :: FacetMatrix22 - -!---------------------------------------------------------------------------- -! FacetMatrix22 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}{\bf n}\cdot\nabla\delta p\tau pdS & -! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau{\bf n}\cdot\nabla N^{I}N^{J} -! dS\right)p_{J}\end{aligned} -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix22_1( elemsd ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix22_1 -END INTERFACE - -INTERFACE FacetMatrix22 - MODULE PROCEDURE FacetMatrix22_1 -END INTERFACE FacetMatrix22 - -!---------------------------------------------------------------------------- -! FacetMatrix22 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}{\bf n}\cdot\nabla\delta p\tau pdS & -! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau{\bf n}\cdot\nabla N^{I}N^{J} -! dS\right)p_{J}\end{aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix22_2( elemsd, tauvar ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix22_2 -END INTERFACE - -INTERFACE FacetMatrix22 - MODULE PROCEDURE FacetMatrix22_2 -END INTERFACE FacetMatrix22 - -!---------------------------------------------------------------------------- -! FacetMatrix22 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \begin{aligned}\int_{\Gamma_{e}}{\bf n}\cdot\nabla\delta p\tau pdS & -! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau{\bf n}\cdot\nabla N^{I}N^{J} -! dS\right)p_{J}\end{aligned} -! $$ - - -INTERFACE -MODULE PURE FUNCTION FacetMatrix22_3( elemsd, tauvar ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix22_3 -END INTERFACE - -INTERFACE FacetMatrix22 - MODULE PROCEDURE FacetMatrix22_3 -END INTERFACE FacetMatrix22 diff --git a/src/modules/FacetMatrix/src/FacetMatrix3.inc b/src/modules/FacetMatrix/src/FacetMatrix3.inc deleted file mode 100644 index 6a96fb65e..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix3.inc +++ /dev/null @@ -1,154 +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 -! - -PUBLIC :: FacetMatrix3 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix3_1( elemsd, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix3_1 -END INTERFACE - -INTERFACE FacetMatrix3 - MODULE PROCEDURE FacetMatrix3_1 -END INTERFACE FacetMatrix3 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix3_2( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix3_2 -END INTERFACE - -INTERFACE FacetMatrix3 - MODULE PROCEDURE FacetMatrix3_2 -END INTERFACE FacetMatrix3 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix3_3( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix3_3 -END INTERFACE - -INTERFACE FacetMatrix3 - MODULE PROCEDURE FacetMatrix3_3 -END INTERFACE FacetMatrix3 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix3_4( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix3_4 -END INTERFACE - -INTERFACE FacetMatrix3 - MODULE PROCEDURE FacetMatrix3_4 -END INTERFACE FacetMatrix3 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix3_5( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix3_5 -END INTERFACE - -INTERFACE FacetMatrix3 - MODULE PROCEDURE FacetMatrix3_5 -END INTERFACE FacetMatrix3 diff --git a/src/modules/FacetMatrix/src/FacetMatrix4.inc b/src/modules/FacetMatrix/src/FacetMatrix4.inc deleted file mode 100644 index 6557b7bab..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix4.inc +++ /dev/null @@ -1,154 +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 -! - -PUBLIC :: FacetMatrix4 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix4_1( elemsd, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix4_1 -END INTERFACE - -INTERFACE FacetMatrix4 - MODULE PROCEDURE FacetMatrix4_1 -END INTERFACE FacetMatrix4 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix4_2( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix4_2 -END INTERFACE - -INTERFACE FacetMatrix4 - MODULE PROCEDURE FacetMatrix4_2 -END INTERFACE FacetMatrix4 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix4_3( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - REAL( DFP ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - REAL( DFP ), ALLOCATABLE :: ans( :, : ) - INTEGER( I4B ), INTENT( IN ) :: opt -END FUNCTION FacetMatrix4_3 -END INTERFACE - -INTERFACE FacetMatrix4 - MODULE PROCEDURE FacetMatrix4_3 -END INTERFACE FacetMatrix4 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix4_4( elemsd, mu, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix4_4 -END INTERFACE - -INTERFACE FacetMatrix4 - MODULE PROCEDURE FacetMatrix4_4 -END INTERFACE FacetMatrix4 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix4_5( elemsd, mu, tauvar, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd - TYPE( FEVariable_ ), INTENT( IN ) :: mu - TYPE( FEVariable_ ), INTENT( IN ) :: tauvar - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix4_5 -END INTERFACE - -INTERFACE FacetMatrix4 - MODULE PROCEDURE FacetMatrix4_5 -END INTERFACE FacetMatrix4 diff --git a/src/modules/FacetMatrix/src/FacetMatrix5.inc b/src/modules/FacetMatrix/src/FacetMatrix5.inc deleted file mode 100644 index 26b666efc..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix5.inc +++ /dev/null @@ -1,214 +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 -! - -PUBLIC :: FacetMatrix5 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix5_1( masterElemSD, slaveElemSD, & - & quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix5_1 -END INTERFACE - -INTERFACE FacetMatrix5 - MODULE PROCEDURE FacetMatrix5_1 -END INTERFACE FacetMatrix5 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix5_2( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix5_2 -END INTERFACE - -INTERFACE FacetMatrix5 - MODULE PROCEDURE FacetMatrix5_2 -END INTERFACE FacetMatrix5 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix5_3( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - REAL( DFP ), INTENT( IN ) :: tauMaster - REAL( DFP ), INTENT( IN ) :: tauSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix5_3 -END INTERFACE - -INTERFACE FacetMatrix5 - MODULE PROCEDURE FacetMatrix5_3 -END INTERFACE FacetMatrix5 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix5_4( masterElemSD, slaveElemSD, & - & muMaster, muSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix5_4 -END INTERFACE - -INTERFACE FacetMatrix5 - MODULE PROCEDURE FacetMatrix5_4 -END INTERFACE FacetMatrix5 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix5_5( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - REAL( DFP ), INTENT( IN ) :: muMaster - REAL( DFP ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster - TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix5_5 -END INTERFACE - -INTERFACE FacetMatrix5 - MODULE PROCEDURE FacetMatrix5_5 -END INTERFACE FacetMatrix5 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 May 2022 -! summary: FacetMatrix for VMS-FEM for CFD -! -!# Introduction -! -! $$ -! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) -! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS -! $$ - -INTERFACE -MODULE PURE FUNCTION FacetMatrix5_6( masterElemSD, slaveElemSD, & - & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) - CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD - CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD - TYPE( FEVariable_ ), INTENT( IN ) :: muMaster - TYPE( FEVariable_ ), INTENT( IN ) :: muSlave - TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster - TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave - INTEGER( I4B ), INTENT( IN ) :: quadMap(:) - INTEGER( I4B ), INTENT( IN ) :: opt - REAL( DFP ), ALLOCATABLE :: ans( :, : ) -END FUNCTION FacetMatrix5_6 -END INTERFACE - -INTERFACE FacetMatrix5 - MODULE PROCEDURE FacetMatrix5_6 -END INTERFACE FacetMatrix5 diff --git a/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 b/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 deleted file mode 100644 index f49e682ff..000000000 --- a/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 +++ /dev/null @@ -1,37 +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 FacetMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -#include "./FacetMatrix1.inc" -#include "./FacetMatrix2.inc" -#include "./FacetMatrix3.inc" -#include "./FacetMatrix4.inc" -#include "./FacetMatrix5.inc" -#include "./FacetMatrix11.inc" -#include "./FacetMatrix12.inc" -#include "./FacetMatrix13.inc" -#include "./FacetMatrix14.inc" -#include "./FacetMatrix15.inc" -#include "./FacetMatrix21.inc" -#include "./FacetMatrix22.inc" - -END MODULE FacetMatrix_Method \ No newline at end of file diff --git a/src/modules/ForceVector/CMakeLists.txt b/src/modules/ForceVector/CMakeLists.txt deleted file mode 100644 index a3ca4027f..000000000 --- a/src/modules/ForceVector/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ForceVector_Method.F90 -) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 deleted file mode 100644 index 3e4deb1af..000000000 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ /dev/null @@ -1,229 +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 ForceVector_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: 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 FUNCTION ForceVector_1(test) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_1 -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_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) - CLASS(ElemshapeData_), INTENT(IN) :: test - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableScalar_), INTENT(IN) :: crank - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_2 -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 FUNCTION ForceVector_3(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 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 FUNCTION ForceVector_4(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 INTERFACE ForceVector - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: Force vector -! -!# Introduction -! -! This routine computes the following integral -! -! $$ -! F_{I}=\int_{\Omega}\rho_{1}\rho_{2}N^{I}d\Omega -! $$ - -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_5(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) - 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 INTERFACE ForceVector - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: Force vector -! -!# Introduction -! -! This routine computes the following integral. -! -! $$ -! -! $$ - -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_6(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 INTERFACE ForceVector - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: Force vector -! -!# Introduction -! -! This routine computes the following. -! -! $$ -! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega -! $$ - -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_7(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 INTERFACE ForceVector - -END MODULE ForceVector_Method diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt deleted file mode 100644 index 8c398fbc6..000000000 --- a/src/modules/Geometry/CMakeLists.txt +++ /dev/null @@ -1,34 +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 -# - -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 diff --git a/src/modules/Geometry/src/Geometry_Method.F90 b/src/modules/Geometry/src/Geometry_Method.F90 deleted file mode 100644 index 2c87d5278..000000000 --- a/src/modules/Geometry/src/Geometry_Method.F90 +++ /dev/null @@ -1,31 +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 Geometry_Method -USE ReferenceElement_Method -USE ReferencePoint_Method -USE ReferenceLine_Method -USE ReferenceTriangle_Method -USE ReferenceQuadrangle_Method -USE ReferenceTetrahedron_Method -USE ReferenceHexahedron_Method -USE ReferencePrism_Method -USE ReferencePyramid_Method -USE Line_Method -USE Triangle_Method -USE Plane_Method -END MODULE Geometry_Method diff --git a/src/modules/Geometry/src/Line_Method.F90 b/src/modules/Geometry/src/Line_Method.F90 deleted file mode 100644 index 2c1757412..000000000 --- a/src/modules/Geometry/src/Line_Method.F90 +++ /dev/null @@ -1,431 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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/Plane_Method.F90 b/src/modules/Geometry/src/Plane_Method.F90 deleted file mode 100644 index 2be4626c7..000000000 --- a/src/modules/Geometry/src/Plane_Method.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 -! - -MODULE Plane_Method -USE GlobalData -IMPLICIT NONE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: intersection of plane and line in 3D. -! -!# Introduction -! -! The normal form of a plane in 3D is: -! -! PP is a point on the plane, -! N is a normal vector to the plane. -! -! The explicit form of a line in 3D is: -! -! P1, P2 are two points on the line. -! -!# Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. -! -! Input, real ( kind = 8 ) P1(3), P2(3), two distinct points on the line. -! -! Output, integer ( kind = 4 ) IVAL, the kind of intersection; -! 0, the line and plane seem to be parallel and separate; -! 1, the line and plane intersect at a single point; -! 2, the line and plane seem to be parallel and joined. -! -! 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 - -END MODULE Plane_Method diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 deleted file mode 100644 index 58a0500c0..000000000 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ /dev/null @@ -1,1347 +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: 1 March 2021 -! summary: This submodule contains method for [[ReferenceElement_]] - -MODULE ReferenceElement_Method -USE BaseType -USE String_Class, ONLY: String -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Display -PUBLIC :: MdEncode -PUBLIC :: ReactEncode -PUBLIC :: ReferenceTopology -PUBLIC :: DEALLOCATE -PUBLIC :: OPERATOR(.NNE.) -PUBLIC :: Initiate -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: ReferenceElement_Pointer -PUBLIC :: GetConnectivity -PUBLIC :: ElementType -PUBLIC :: Elementname -PUBLIC :: TotalNodesInElement -PUBLIC :: ElementOrder -PUBLIC :: OPERATOR(.order.) -PUBLIC :: XiDimension -PUBLIC :: IsVolume -PUBLIC :: IsSurface -PUBLIC :: IsLine -PUBLIC :: IsPoint -PUBLIC :: IsTriangle -PUBLIC :: IsQuadrangle -PUBLIC :: IsTetrahedron -PUBLIC :: IsHexahedron -PUBLIC :: IsPrism -PUBLIC :: IsPyramid -PUBLIC :: IsSerendipityElement -PUBLIC :: ElementTopology -PUBLIC :: OPERATOR(.topology.) -PUBLIC :: FacetMatrix -PUBLIC :: GetFacetElements -PUBLIC :: LocalNodeCoord -PUBLIC :: MeasureSimplex -PUBLIC :: ElementQuality -PUBLIC :: ContainsPoint -PUBLIC :: TotalEntities -PUBLIC :: GetFacetTopology -PUBLIC :: GetVTKelementType -PUBLIC :: GetEdgeConnectivity -PUBLIC :: GetFaceConnectivity -PUBLIC :: GetTotalNodes -PUBLIC :: GetTotalEdges -PUBLIC :: GetTotalFaces -PUBLIC :: GetTotalCells -PUBLIC :: ReferenceElementInfo -PUBLIC :: RefElemGetGeoParam -PUBLIC :: GetFaceElemType -PUBLIC :: GetElementIndex -PUBLIC :: Reallocate -PUBLIC :: RefTopoReallocate - -INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_FACES = 6 -INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_EDGES = 12 -INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_POINTS = 8 - -!---------------------------------------------------------------------------- -! ReferenceElementInfo_ -!---------------------------------------------------------------------------- - -TYPE :: ReferenceElementInfo_ - INTEGER(I4B) :: point = 1 - INTEGER(I4B) :: line = 2 - INTEGER(I4B) :: triangle = 3 - INTEGER(I4B) :: quadrangle = 4 - INTEGER(I4B) :: tetrahedron = 5 - INTEGER(I4B) :: hexahedron = 6 - INTEGER(I4B) :: prism = 7 - INTEGER(I4B) :: pyramid = 8 - INTEGER(I4B) :: tElemTopologyType_0D = 1 - INTEGER(I4B) :: tElemTopologyType_1D = 1 - INTEGER(I4B) :: tElemTopologyType_2D = 2 - INTEGER(I4B) :: tElemTopologyType_3D = 4 - INTEGER(I4B) :: tElemTopologyType = 8 - INTEGER(I4B) :: elemTopologyname(8) = [ & - & Point, & - & Line, & - & Triangle, & - & Quadrangle, & - & Tetrahedron, Hexahedron, Prism, Pyramid] - INTEGER(I4B) :: maxFaces = PARAM_REFELEM_MAX_FACES - INTEGER(I4B) :: maxEdges = PARAM_REFELEM_MAX_EDGES - INTEGER(I4B) :: maxPoints = PARAM_REFELEM_MAX_POINTS - INTEGER(I4B) :: tCells(8) = [0, 0, 0, 0, 1, 1, 1, 1] - !! Here cell is a topology for which xidim = 3 - INTEGER(I4B) :: tFaces(8) = [0, 0, 1, 1, 4, 6, 5, 5] - !! Here facet is topology entity for which xidim = 2 - INTEGER(I4B) :: tEdges(8) = [0, 0, 3, 4, 6, 12, 9, 8] - !! Here edge is topology entity for which xidim = 1 - INTEGER(I4B) :: tPoints(8) = [1, 2, 3, 4, 4, 8, 6, 5] - !! A point is topology entity for which xidim = 0 - INTEGER(I4B) :: nne_in_face_triangle(1) = [3] - !! number of nodes in each face of triangle - INTEGER(I4B) :: nne_in_face_quadrangle(1) = [4] - !! number of nodes in each face of quadrangle - INTEGER(I4B) :: nne_in_face_tetrahedron(4) = [3, 3, 3, 3] - !! number of nodes in each face of tetrahedron - INTEGER(I4B) :: nne_in_face_hexahedron(6) = [4, 4, 4, 4, 4, 4] - !! number of nodes in each face of tetrahedron - INTEGER(I4B) :: nne_in_face_prism(5) = [3, 4, 4, 4, 3] - !! number of nodes in each face of tetrahedron - INTEGER(I4B) :: nne_in_face_pyramid(5) = [4, 3, 3, 3, 3] - !! number of nodes in each face of tetrahedron -END TYPE ReferenceElementInfo_ - -TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = & - & ReferenceElementInfo_() - -!---------------------------------------------------------------------------- -! GetElementIndex@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-19 -! summary: Returns the index of an element based on its topology -! -!# Introduction -! -! Point 1 -! Line 2 -! Triangle 3 -! Quadrangle 4 -! Tetrahedron 5 -! Hexahedron 6 -! Prism 7 -! Pyramid 8 - -INTERFACE - MODULE PURE FUNCTION GetElementIndex(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION GetElementIndex -END INTERFACE - -!---------------------------------------------------------------------------- -! RefElemGetGeoParam@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-09 -! summary: Returns the geometry parameters - -INTERFACE RefElemGetGeoParam - MODULE PURE SUBROUTINE RefElemGetGeoParam1(elemType, tNodes, tEdges, & - & tFaces, tCells, edgeCon, faceCon, edgeOpt, faceOpt, faceElemType, & - & tFaceNodes, order) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tNodes - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tEdges - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaces - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tCells - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: edgeCon(:, :) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceCon(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOpt - INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOpt - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! Order of element - END SUBROUTINE RefElemGetGeoParam1 -END INTERFACE RefElemGetGeoParam - -!---------------------------------------------------------------------------- -! GetTotalEdges@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-14 -! summary: Returns number of edges in the element - -INTERFACE GetTotalEdges - MODULE PURE FUNCTION GetTotalEdges1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION GetTotalEdges1 -END INTERFACE GetTotalEdges - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-07 -! summary: Returns number of edges in the element - -INTERFACE GetEdgeConnectivity - MODULE PURE SUBROUTINE GetEdgeConnectivity1(elemType, con, opt, order, & - nrow, ncol) - INTEGER(I4B), INTENT(IN) :: elemType - !! name of element - INTEGER(I4B), INTENT(INOUT) :: con(:, :) - !! Connectivity - !! The columns represents the edge number - !! The row represents the connectivity of edge - !! con should be allocated by the user - 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 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! Order of element - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow - !! Number of rows written to con - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol - !! number of columns written to con - END SUBROUTINE GetEdgeConnectivity1 -END INTERFACE GetEdgeConnectivity - -!---------------------------------------------------------------------------- -! GetFaceConnectivity@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-07 -! summary: Returns number of edges in the element - -INTERFACE GetFaceConnectivity - MODULE PURE SUBROUTINE GetFaceConnectivity1(elemType, con, opt, order, & - nrow, ncol) - INTEGER(I4B), INTENT(IN) :: elemType - !! name of element - 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 - !! 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) :: order - !! order of element - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow - !! Number of rows written to con - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol - !! number of columns written to con - END SUBROUTINE GetFaceConnectivity1 -END INTERFACE GetFaceConnectivity - -!---------------------------------------------------------------------------- -! GetFaceElemType@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-11 -! summary: Returns the element type of each face - -INTERFACE GetFaceElemType - MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, & - tFaceNodes) - INTEGER(I4B), INTENT(IN) :: elemType - !! name of element - INTEGER(I4B), 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 GetFaceElemType1 -END INTERFACE GetFaceElemType - -!---------------------------------------------------------------------------- -! GetTotalNodes@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-14 -! summary: Returns number of nodes (vertices) in the element - -INTERFACE GetTotalNodes - MODULE PURE FUNCTION GetTotalNodes1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION GetTotalNodes1 -END INTERFACE GetTotalNodes - -!---------------------------------------------------------------------------- -! GetTotalFaces@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-14 -! summary: Returns number of faces in the element - -INTERFACE GetTotalFaces - MODULE PURE FUNCTION GetTotalFaces1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION GetTotalFaces1 -END INTERFACE GetTotalFaces - -!---------------------------------------------------------------------------- -! GetTotalCells@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-14 -! summary: Returns number of faces in the element - -INTERFACE GetTotalCells - MODULE PURE FUNCTION GetTotalCells1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION GetTotalCells1 -END INTERFACE GetTotalCells - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Display the ReferenceElement - -INTERFACE Display - MODULE SUBROUTINE refelem_Display(obj, msg, unitno) - CLASS(ReferenceElement_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno - END SUBROUTINE refelem_Display -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Markdown encoding of reference element - -INTERFACE MdEncode - MODULE FUNCTION refelem_MdEncode(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - TYPE(String) :: ans - END FUNCTION refelem_MdEncode -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Returns react element for reference element - -INTERFACE ReactEncode - MODULE FUNCTION refelem_ReactEncode(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - TYPE(String) :: ans - END FUNCTION refelem_ReactEncode -END INTERFACE ReactEncode - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Display reference topology - -INTERFACE Display - MODULE SUBROUTINE reftopo_Display(obj, msg, unitno) - CLASS(ReferenceTopology_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno - END SUBROUTINE reftopo_Display -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Display reference topology - -INTERFACE MdEncode - MODULE FUNCTION reftopo_MdEncode(obj) RESULT(ans) - CLASS(ReferenceTopology_), INTENT(IN) :: obj - TYPE(String) :: ans - END FUNCTION reftopo_MdEncode -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! ReferenceTopology@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This function returns the instance of [[ReferenceTopology_]] -! -!# Introduction -! -! This function returns the instance of [[ReferenceTopology_]]. -! -! The possible valaues of name can be -! -! - `Line, Line2, Line3, Line4, Line5, Line6` -! - `Triangle, Triangle3, Triangle6, Triangle9, Triangle10, Triangle12, -! Triangl15a, Triangl15b, Triangl15, Triangl21` -! - `Quadrangle, Quadrangle4, Quadrangle9, Quadrangle8` -! - `Tetrahedron, Tetrahedron4, Tetrahedron10, Tetrahedron20, Tetrahedron35, -! Tetrahedron56` -! - `Hexahedron, Hexahedron8, Hexahedron27, Hexahedron20, Hexahedron64, -! Hexahedron125` -! - `Prism, Prism6, Prism15, Prism18` -! - `Pyramid, Pyramid5, Pyramid14, Pyramid13` -! - `Point, Point1` -! -!### Usage -! -!```fortran -! type( ReferenceTopology_ ) :: obj -! obj = ReferenceTopology( nptrs = [1,2,3], name=Triangle3 ) -! call display( obj, "obj=") -!``` - -INTERFACE ReferenceTopology - MODULE PURE FUNCTION refelem_ReferenceTopology(nptrs, name) RESULT(obj) - TYPE(ReferenceTopology_) :: obj - INTEGER(I4B), INTENT(IN) :: nptrs(:) - INTEGER(I4B), INTENT(IN) :: name - END FUNCTION refelem_ReferenceTopology -END INTERFACE ReferenceTopology - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This subroutine reset the instance of [[ReferenceTopology_]] -! -!### Usage -! -!```fortran -! type( ReferenceTopology_ ) :: obj -! obj = ReferenceTopology( nptrs = [1,2,3], name=Triangle3 ) -! call display( obj, "obj=") -! call Deallocate( obj ) -!``` - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE refelem_Deallocate1(obj) - CLASS(ReferenceTopology_), INTENT(INOUT) :: obj - END SUBROUTINE refelem_Deallocate1 -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-24 -! summary: Deallocate topology vector - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE RefTopoDeallocate(obj) - TYPE(ReferenceTopology_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RefTopoDeallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-24 -! summary: Reallocate topology vector - -INTERFACE Reallocate - MODULE PURE SUBROUTINE RefTopoReallocate(obj, n) - TYPE(ReferenceTopology_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: n - END SUBROUTINE RefTopoReallocate -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: Deallocates the data stored inside the [[ReferenceElement_]] - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE refelem_Deallocate2(obj) - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - END SUBROUTINE refelem_Deallocate2 -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! NNE@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This function returns the totat nodes inside the referenc topology -! -!### Usage -! -!```fortran -! type( ReferenceTopology_ ) :: obj -! obj = ReferenceTopology( nptrs = [1,2,3], name=Triangle3 ) -! call display( obj, "obj=") -! call display( .NNE. obj, "nne =") -!``` - -INTERFACE OPERATOR(.NNE.) - MODULE PURE FUNCTION refelem_NNE1(obj) RESULT(ans) - CLASS(ReferenceTopology_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION refelem_NNE1 -END INTERFACE OPERATOR(.NNE.) - -INTERFACE TotalNodesInElement - MODULE PROCEDURE refelem_NNE1 -END INTERFACE TotalNodesInElement - -!---------------------------------------------------------------------------- -! NNE@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: Returns the total number of nodes in the reference element -! - -INTERFACE OPERATOR(.NNE.) - MODULE PURE FUNCTION refelem_NNE2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION refelem_NNE2 -END INTERFACE OPERATOR(.NNE.) - -INTERFACE TotalNodesInElement - MODULE PROCEDURE refelem_NNE2 -END INTERFACE TotalNodesInElement - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 March 2021 -! summary: This subroutine copies one reference element into other -! -!# Introduction -! -! This subroutine copies one reference element into other -! This subroutine also defines an assignment operator for `obj1=obj2` -! type opertions - -INTERFACE Initiate - MODULE PURE SUBROUTINE refelem_Initiate1(obj, anotherobj) - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - CLASS(ReferenceElement_), INTENT(IN) :: anotherobj - END SUBROUTINE refelem_Initiate1 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE refelem_Initiate1 -END INTERFACE - -!---------------------------------------------------------------------------- -! ReferenceElement_Pointer@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns a pointer to an instance of ReferenceElement - -INTERFACE ReferenceElement_Pointer - MODULE FUNCTION refelem_Constructor_1(xidim, nsd, elemType, & - & ipType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: xidim - !! xidimension - INTEGER(I4B), INTENT(IN) :: nsd - !! spatial dimenstion - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolationType - CLASS(ReferenceElement_), POINTER :: ans - !! reference element - END FUNCTION refelem_Constructor_1 -END INTERFACE ReferenceElement_Pointer - -!---------------------------------------------------------------------------- -! ReferenceElementPointer@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns a pointer to an instance of ReferenceElement - -INTERFACE ReferenceElement_Pointer - MODULE FUNCTION refelem_Constructor_2(refelem) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - CLASS(ReferenceElement_), POINTER :: ans - END FUNCTION refelem_Constructor_2 -END INTERFACE ReferenceElement_Pointer - -!---------------------------------------------------------------------------- -! GetConnectivity@ConstrucorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 June 2021 -! summary: Returns the node numbers of reference element - -INTERFACE GetConnectivity - MODULE PURE FUNCTION refelem_Getnptrs(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION refelem_Getnptrs -END INTERFACE GetConnectivity - -!---------------------------------------------------------------------------- -! ElementType@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns element name in integer from element name - -INTERFACE ElementType - MODULE PURE FUNCTION Element_Type(Elemname) RESULT(ans) - CHARACTER(*), INTENT(IN) :: Elemname - INTEGER(I4B) :: ans - END FUNCTION Element_Type -END INTERFACE ElementType - -!---------------------------------------------------------------------------- -! ElementType@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-11-22 -! summary: Return name of element - -INTERFACE ElementType - MODULE PURE FUNCTION Element_Type_obj(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION Element_Type_obj -END INTERFACE ElementType - -!---------------------------------------------------------------------------- -! Elementname@ElementNameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns element name in character from element number/type - -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 - -!---------------------------------------------------------------------------- -! Elementname@ElementNameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns element name in character from ReferenceElement - -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 - -!---------------------------------------------------------------------------- -! TotalNodesInElement@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns total numbers of nodes present in a given element - -INTERFACE TotalNodesInElement - MODULE PURE FUNCTION Total_Nodes_In_Element(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION Total_Nodes_In_Element -END INTERFACE TotalNodesInElement - -!---------------------------------------------------------------------------- -! ElementOrder@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns the order of an element - -INTERFACE ElementOrder - MODULE PURE FUNCTION Element_Order(elemType) RESULT(ans) - INTEGER(I4B) :: ans - INTEGER(I4B), INTENT(IN) :: elemType - END FUNCTION Element_Order -END INTERFACE ElementOrder - -!---------------------------------------------------------------------------- -! ElementOrder@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns the order of an element - -INTERFACE ElementOrder - MODULE PURE FUNCTION Element_Order_refelem(refelem) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - INTEGER(I4B) :: ans - END FUNCTION Element_Order_refelem -END INTERFACE ElementOrder - -INTERFACE OPERATOR(.order.) - MODULE PROCEDURE Element_Order_refelem, Element_Order -END INTERFACE OPERATOR(.order.) - -!---------------------------------------------------------------------------- -! XiDimension@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-13 -! update: 2021-11-13 -! summary: Returns the xidimension of an element - -INTERFACE XiDimension - MODULE PURE FUNCTION Elem_XiDimension1(elemType) RESULT(ans) - INTEGER(I4B) :: ans - INTEGER(I4B), INTENT(IN) :: elemType - END FUNCTION Elem_XiDimension1 -END INTERFACE Xidimension - -!---------------------------------------------------------------------------- -! Xidimension@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-13 -! update: 2021-11-13 -! summary: Returns xidimension of the reference element - -INTERFACE Xidimension - MODULE PURE FUNCTION Elem_Xidimension2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION Elem_Xidimension2 -END INTERFACE XiDimension - -!---------------------------------------------------------------------------- -! isVolume@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a volume element - -INTERFACE isVolume - MODULE PURE FUNCTION isVolume1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isVolume1 -END INTERFACE isVolume - -!---------------------------------------------------------------------------- -! isVolume@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a volume element - -INTERFACE isVolume - MODULE PURE FUNCTION isVolume2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isVolume2 -END INTERFACE isVolume - -!---------------------------------------------------------------------------- -! isSurface@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Surface element - -INTERFACE isSurface - MODULE PURE FUNCTION isSurface1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isSurface1 -END INTERFACE isSurface - -!---------------------------------------------------------------------------- -! isSurface@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Surface element - -INTERFACE isSurface - MODULE PURE FUNCTION isSurface2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isSurface2 -END INTERFACE isSurface - -!---------------------------------------------------------------------------- -! isLine@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Line element - -INTERFACE isLine - MODULE PURE FUNCTION isLine1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isLine1 -END INTERFACE isLine - -!---------------------------------------------------------------------------- -! isLine@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Line element - -INTERFACE isLine - MODULE PURE FUNCTION isLine2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isLine2 -END INTERFACE isLine - -!---------------------------------------------------------------------------- -! isPoint@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Point element - -INTERFACE isPoint - MODULE PURE FUNCTION isPoint1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isPoint1 -END INTERFACE isPoint - -!---------------------------------------------------------------------------- -! isPoint@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Point element - -INTERFACE isPoint - MODULE PURE FUNCTION isPoint2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isPoint2 -END INTERFACE isPoint - -!---------------------------------------------------------------------------- -! isTriangle@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Triangle element - -INTERFACE isTriangle - MODULE PURE FUNCTION isTriangle1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isTriangle1 -END INTERFACE isTriangle - -!---------------------------------------------------------------------------- -! isTriangle@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Triangle element - -INTERFACE isTriangle - MODULE PURE FUNCTION isTriangle2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isTriangle2 -END INTERFACE isTriangle - -!---------------------------------------------------------------------------- -! isQuadrangle@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Quadrangle element - -INTERFACE isQuadrangle - MODULE PURE FUNCTION isQuadrangle1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isQuadrangle1 -END INTERFACE isQuadrangle - -!---------------------------------------------------------------------------- -! isQuadrangle@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Quadrangle element - -INTERFACE isQuadrangle - MODULE PURE FUNCTION isQuadrangle2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isQuadrangle2 -END INTERFACE isQuadrangle - -!---------------------------------------------------------------------------- -! isTetrahedron@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Tetrahedron element - -INTERFACE isTetrahedron - MODULE PURE FUNCTION isTetrahedron1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isTetrahedron1 -END INTERFACE isTetrahedron - -!---------------------------------------------------------------------------- -! isTetrahedron@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Tetrahedron element - -INTERFACE isTetrahedron - MODULE PURE FUNCTION isTetrahedron2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isTetrahedron2 -END INTERFACE isTetrahedron - -!---------------------------------------------------------------------------- -! isHexahedron@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Hexahedron element - -INTERFACE isHexahedron - MODULE PURE FUNCTION isHexahedron1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isHexahedron1 -END INTERFACE isHexahedron - -!---------------------------------------------------------------------------- -! isHexahedron@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Hexahedron element - -INTERFACE isHexahedron - MODULE PURE FUNCTION isHexahedron2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isHexahedron2 -END INTERFACE isHexahedron - -!---------------------------------------------------------------------------- -! isPrism@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Prism element - -INTERFACE isPrism - MODULE PURE FUNCTION isPrism1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isPrism1 -END INTERFACE isPrism - -!---------------------------------------------------------------------------- -! isPrism@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Prism element - -INTERFACE isPrism - MODULE PURE FUNCTION isPrism2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isPrism2 -END INTERFACE isPrism - -!---------------------------------------------------------------------------- -! isPyramid@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Pyramid element - -INTERFACE isPyramid - MODULE PURE FUNCTION isPyramid1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isPyramid1 -END INTERFACE isPyramid - -!---------------------------------------------------------------------------- -! isPyramid@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a Pyramid element - -INTERFACE isPyramid - MODULE PURE FUNCTION isPyramid2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isPyramid2 -END INTERFACE isPyramid - -!---------------------------------------------------------------------------- -! isSerendipityElement@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a SerendipityElement element - -INTERFACE isSerendipityElement - MODULE PURE FUNCTION isSerendipityElement1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - LOGICAL(LGT) :: ans - END FUNCTION isSerendipityElement1 -END INTERFACE isSerendipityElement - -!---------------------------------------------------------------------------- -! isSerendipityElement@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 May 2022 -! summary: Returns true if element is a SerendipityElement element - -INTERFACE isSerendipityElement - MODULE PURE FUNCTION isSerendipityElement2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION isSerendipityElement2 -END INTERFACE isSerendipityElement - -!---------------------------------------------------------------------------- -! ElementTopology@ElementnameMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-10 -! update: 2021-11-10 -! summary: Return the element topology -! -!# Introduction -! -! This routine returns the topology of the reference element -! - Line -! - Triangle -! - Quadrangle -! - Tetrahedron - -INTERFACE ElementTopology - MODULE PURE FUNCTION refelem_ElementTopology1(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION refelem_ElementTopology1 -END INTERFACE ElementTopology - -INTERFACE OPERATOR(.topology.) - MODULE PROCEDURE refelem_ElementTopology1 -END INTERFACE OPERATOR(.topology.) - -!---------------------------------------------------------------------------- -! ElementTopology@ElementnameMethods -!---------------------------------------------------------------------------- - -INTERFACE ElementTopology - MODULE PURE FUNCTION refelem_ElementTopology2(obj) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION refelem_ElementTopology2 -END INTERFACE ElementTopology - -INTERFACE OPERATOR(.topology.) - MODULE PROCEDURE refelem_ElementTopology2 -END INTERFACE OPERATOR(.topology.) - -!---------------------------------------------------------------------------- -! FacetMatrix@FacetElementMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 11 April 2022 -! summary: Returns the facet matrix -! -!# Introduction -! -! Returns the facet matrix of a reference element. -! -! - Number of rows are equal to the number of facet in an element -! - Number of columns = MAX( NNS ) -! - First column => ElementTopology -! - Second Column => XiDimension -! - Third column => NNS -! - 4 to NNS + 3 => Local nptrs - -INTERFACE FacetMatrix - MODULE PURE FUNCTION Facet_Matrix_refelem(refelem) RESULT(FM) - INTEGER(I4B), ALLOCATABLE :: FM(:, :) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - END FUNCTION Facet_Matrix_refelem -END INTERFACE FacetMatrix - -!---------------------------------------------------------------------------- -! FacetElements@FacetElementMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-25 -! summary: This routine returns the facet elements - -INTERFACE GetFacetElements - MODULE SUBROUTINE refelem_GetFacetElements1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE refelem_GetFacetElements1 -END INTERFACE GetFacetElements - -!---------------------------------------------------------------------------- -! FacetElements@FacetElementMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-25 -! summary: This routine returns the facet elements - -INTERFACE GetFacetElements - MODULE SUBROUTINE refelem_GetFacetElements2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE refelem_GetFacetElements2 -END INTERFACE GetFacetElements - -!---------------------------------------------------------------------------- -! FacetTopology@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 June 2021 -! summary: Returns the facet topology of the given element type - -INTERFACE GetFacetTopology - MODULE PURE SUBROUTINE refelem_GetFacetTopology(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE refelem_GetFacetTopology -END INTERFACE GetFacetTopology - -!---------------------------------------------------------------------------- -! LocalNodeCoord@LocalNodeCoordMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 11 April 2022 -! summary: Deprecated -! -!# Introduction -! -! This routine will be removed in near future -! This routine is not included in generic LocalNodeCoord routine - -INTERFACE - MODULE PURE SUBROUTINE Local_NodeCoord(NodeCoord, elemType) - ! Define intent of dummy variables - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: NodeCoord(:, :) - INTEGER(I4B), INTENT(IN) :: elemType - END SUBROUTINE Local_NodeCoord -END INTERFACE - -!---------------------------------------------------------------------------- -! LocalNodeCoord@LocalNodeCoordMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 11 April 2022 -! summary: Returns the local NodeCoord of an element - -INTERFACE LocalNodeCoord - MODULE PURE FUNCTION Local_NodeCoord_refelem(refelem) RESULT(nodecoord) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), ALLOCATABLE :: nodecoord(:, :) - END FUNCTION Local_NodeCoord_refelem -END INTERFACE LocalNodeCoord - -!---------------------------------------------------------------------------- -! MeasureSimplex@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 11 April 2022 -! summary: Returns measures for simplex - -INTERFACE MeasureSimplex - MODULE PURE FUNCTION Measure_Simplex(refelem, XiJ) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: XiJ(:, :) - REAL(DFP) :: ans - END FUNCTION Measure_Simplex -END INTERFACE MeasureSimplex - -!---------------------------------------------------------------------------- -! ElementQuality@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 11 April 2022 -! summary: Measure the quality of the element - -INTERFACE ElementQuality - MODULE FUNCTION Element_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 Element_Quality -END INTERFACE ElementQuality - -!---------------------------------------------------------------------------- -! ContainsPoint@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 11 April 2022 -! summary: Returns true if the given point is inside the element - -INTERFACE ContainsPoint - MODULE FUNCTION contains_point(refelem, xij, x) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP), INTENT(IN) :: x(:) - LOGICAL(LGT) :: ans - END FUNCTION contains_point -END INTERFACE ContainsPoint - -!---------------------------------------------------------------------------- -! TotalEntities@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 June 2021 -! summary: Total entities present in an element - -INTERFACE TotalEntities - MODULE PURE FUNCTION refelem_TotalEntities(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION refelem_TotalEntities -END INTERFACE TotalEntities - -!---------------------------------------------------------------------------- -! getVTKelementType@VTKMethods -!---------------------------------------------------------------------------- - -INTERFACE GetVTKelementType - MODULE PURE SUBROUTINE get_vtk_elemType(elemType, vtk_type, nptrs) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(INT8), INTENT(OUT) :: vtk_type - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: nptrs(:) - END SUBROUTINE get_vtk_elemType -END INTERFACE GetVTKelementType - -END MODULE ReferenceElement_Method diff --git a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 b/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 deleted file mode 100644 index af249edaa..000000000 --- a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 +++ /dev/null @@ -1,375 +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 module contains methods for [[ReferenceHexahedron_]] - -MODULE ReferenceHexahedron_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -PUBLIC :: ReferenceHexahedron -PUBLIC :: ReferenceHexahedron_Pointer -PUBLIC :: HighorderElement_Hexahedron -PUBLIC :: Measure_Simplex_Hexahedron -PUBLIC :: Hexahedron_Quality -PUBLIC :: Quality_Hexahedron -PUBLIC :: HexahedronVolume3D -PUBLIC :: GetEdgeConnectivity_Hexahedron -PUBLIC :: GetFaceConnectivity_Hexahedron -PUBLIC :: RefCoord_Hexahedron -PUBLIC :: RefHexahedronCoord -PUBLIC :: GetFaceElemType_Hexahedron -PUBLIC :: FacetElements_Hexahedron -PUBLIC :: ElementOrder_Hexahedron -PUBLIC :: ElementType_Hexahedron -PUBLIC :: TotalNodesInElement_Hexahedron -PUBLIC :: TotalEntities_Hexahedron -PUBLIC :: FacetTopology_Hexahedron -PUBLIC :: ElementName_Hexahedron -PUBLIC :: MaxOrder_Hexahedron - -#ifdef MAX_HEXAHEDRON_ORDER -INTEGER(I4B), PARAMETER :: MaxOrder_Hexahedron = MAX_HEXAHEDRON_ORDER -#else -INTEGER(I4B), PARAMETER :: MaxOrder_Hexahedron = 2_I4B -#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_Hexahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION ElementName_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetTopology_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-23 -! summary: Returns the topology of tetrahedron - -INTERFACE - MODULE PURE SUBROUTINE FacetTopology_Hexahedron(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetTopology_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalEntities_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total entities in Hexahedron - -INTERFACE - MODULE PURE FUNCTION TotalEntities_Hexahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION TotalEntities_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total nodes in element - -INTERFACE - MODULE PURE FUNCTION TotalNodesInElement_Hexahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION TotalNodesInElement_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementType_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the type of element from char name - -INTERFACE - MODULE PURE FUNCTION ElementType_Hexahedron(elemName) RESULT(ans) - CHARACTER(*), INTENT(IN) :: elemName - INTEGER(I4B) :: ans - END FUNCTION ElementType_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementOrder_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the order of element - -INTERFACE - MODULE PURE FUNCTION ElementOrder_Hexahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION ElementOrder_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetElements_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Hexahedron - MODULE SUBROUTINE FacetElements_Hexahedron1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Hexahedron1 -END INTERFACE FacetElements_Hexahedron - -!---------------------------------------------------------------------------- -! FacetElements_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Hexahedron - MODULE SUBROUTINE FacetElements_Hexahedron2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Hexahedron2 -END INTERFACE FacetElements_Hexahedron - -!---------------------------------------------------------------------------- -! Initiate@Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This subroutine for constructing the object - -INTERFACE Initiate - MODULE PURE SUBROUTINE Initiate_Ref_Hexahedron(obj, nsd, xij, domainName) - CLASS(ReferenceHexahedron_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - END SUBROUTINE Initiate_Ref_Hexahedron -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! ReferenceHexahedron@Hexahedron -!---------------------------------------------------------------------------- - -INTERFACE ReferenceHexahedron - MODULE PURE FUNCTION Reference_Hexahedron(nsd, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: NSD - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - TYPE(ReferenceHexahedron_) :: obj - END FUNCTION Reference_Hexahedron -END INTERFACE ReferenceHexahedron - -!---------------------------------------------------------------------------- -! ReferenceHexahedron_Pointer@Hexahedron -!---------------------------------------------------------------------------- - -INTERFACE ReferenceHexahedron_Pointer - MODULE FUNCTION Reference_Hexahedron_Pointer(nsd, xij, domainName) & - & RESULT(obj) - INTEGER(I4B), INTENT(IN) :: NSD - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - CLASS(ReferenceHexahedron_), POINTER :: obj - END FUNCTION Reference_Hexahedron_Pointer -END INTERFACE ReferenceHexahedron_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement@Hexahedron -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE HighorderElement_Hexahedron(refelem, order, obj, & - & ipType) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - INTEGER(I4B), INTENT(IN) :: order - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE HighorderElement_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! MeasureSimplex@Geometry -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Measure_Simplex_Hexahedron(refelem, xij) RESULT(Ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: Ans - END FUNCTION Measure_Simplex_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! Hexahedron_quality -!---------------------------------------------------------------------------- - -INTERFACE Quality_Hexahedron - MODULE FUNCTION Hexahedron_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 Hexahedron_Quality -END INTERFACE Quality_Hexahedron - -!---------------------------------------------------------------------------- -! HexahedronVolume3D -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE HexahedronVolume3D(xij, ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP), INTENT(OUT) :: ans - END SUBROUTINE HexahedronVolume3D -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -!> author: Shion Shimizu -! update: 2024-03-22 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetEdgeConnectivity_Hexahedron(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 - !! If opt =2, then edge connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! order default is 1 - 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_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -!> author: Shion Shimizu -! update : 2024-03-22 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetFaceConnectivity_Hexahedron(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 - !! If opt = 1, then face connectivity for hierarchial approximation - !! If opt =2, then face connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! order default is 1 - 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_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! RefHexahedronCoord -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-07 -! summary: Returns coordinates of reference Hexahedron - -INTERFACE RefCoord_Hexahedron - MODULE PURE FUNCTION RefHexahedronCoord(refHexahedron) RESULT(ans) - CHARACTER(*), INTENT(IN) :: refHexahedron - !! UNIT - !! BIUNIT - REAL(DFP) :: ans(3, 8) - END FUNCTION RefHexahedronCoord -END INTERFACE RefCoord_Hexahedron - -!---------------------------------------------------------------------------- -! GetFaceElemType@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-11 -! summary: Returns the element type of each face - -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron(faceElemType, opt, & - & tFaceNodes, elemType) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) - !! Face element type - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! This denotes the element type of Hexahedron - !! Default value is Hexahedron6 - END SUBROUTINE GetFaceElemType_Hexahedron -END INTERFACE - -END MODULE ReferenceHexahedron_Method diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Geometry/src/ReferenceLine_Method.F90 deleted file mode 100644 index 4a9e9b0e9..000000000 --- a/src/modules/Geometry/src/ReferenceLine_Method.F90 +++ /dev/null @@ -1,518 +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 -USE GlobalData -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 - MODULE PURE SUBROUTINE GetFaceElemType_Line(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_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ReferenceLine_Method diff --git a/src/modules/Geometry/src/ReferencePrism_Method.F90 b/src/modules/Geometry/src/ReferencePrism_Method.F90 deleted file mode 100644 index 486e6237e..000000000 --- a/src/modules/Geometry/src/ReferencePrism_Method.F90 +++ /dev/null @@ -1,407 +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 module contains methods for [[ReferencePrism_]] - -MODULE ReferencePrism_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -PUBLIC :: PolyhedronVolume3D -PUBLIC :: Initiate -PUBLIC :: ReferencePrism -PUBLIC :: ReferencePrism_Pointer -PUBLIC :: HighOrderElement_Prism -PUBLIC :: Measure_Simplex_Prism -PUBLIC :: Prism_Quality -PUBLIC :: Quality_Prism -PUBLIC :: GetEdgeConnectivity_Prism -PUBLIC :: GetFaceConnectivity_Prism -PUBLIC :: RefCoord_Prism -PUBLIC :: GetFaceElemType_Prism -PUBLIC :: FacetElements_Prism -PUBLIC :: ElementOrder_Prism -PUBLIC :: ElementType_Prism -PUBLIC :: TotalNodesInElement_Prism -PUBLIC :: TotalEntities_Prism -PUBLIC :: FacetTopology_Prism -PUBLIC :: ElementName_Prism -PUBLIC :: MaxOrder_Prism - -#ifdef MAX_PRISM_ORDER -INTEGER(I4B), PARAMETER :: MaxOrder_Prism = MAX_PRISM_ORDER -#else -INTEGER(I4B), PARAMETER :: MaxOrder_Prism = 2_I4B -#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_Prism(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION ElementName_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetTopology_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-23 -! summary: Returns the topology of tetrahedron - -INTERFACE - MODULE PURE SUBROUTINE FacetTopology_Prism(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetTopology_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalEntities_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total entities in Prism - -INTERFACE - MODULE PURE FUNCTION TotalEntities_Prism(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION TotalEntities_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total nodes in element - -INTERFACE - MODULE PURE FUNCTION TotalNodesInElement_Prism(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION TotalNodesInElement_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementType_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the type of element from char name - -INTERFACE - MODULE PURE FUNCTION ElementType_Prism(elemName) RESULT(ans) - CHARACTER(*), INTENT(IN) :: elemName - INTEGER(I4B) :: ans - END FUNCTION ElementType_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementOrder_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the order of element - -INTERFACE - MODULE PURE FUNCTION ElementOrder_Prism(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION ElementOrder_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetElements_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Prism - MODULE SUBROUTINE FacetElements_Prism1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Prism1 -END INTERFACE FacetElements_Prism - -!---------------------------------------------------------------------------- -! FacetElements_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Prism - MODULE SUBROUTINE FacetElements_Prism2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Prism2 -END INTERFACE FacetElements_Prism - -!---------------------------------------------------------------------------- -! Initiate@Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This subroutine for constructing the object - -INTERFACE Initiate - MODULE SUBROUTINE Initiate_Ref_Prism(obj, nsd, xij, domainName) - CLASS(ReferencePrism_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - END SUBROUTINE Initiate_Ref_Prism -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! ReferencePrism@Prism -!---------------------------------------------------------------------------- - -INTERFACE ReferencePrism - MODULE FUNCTION Reference_Prism(nsd, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - TYPE(ReferencePrism_) :: obj - END FUNCTION Reference_Prism -END INTERFACE ReferencePrism - -!---------------------------------------------------------------------------- -! ReferencePrism_Pointer@Prism -!---------------------------------------------------------------------------- - -INTERFACE ReferencePrism_Pointer - MODULE FUNCTION Reference_Prism_Pointer(nsd, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - CLASS(ReferencePrism_), POINTER :: obj - END FUNCTION Reference_Prism_Pointer -END INTERFACE ReferencePrism_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement@Prism -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE highOrderElement_Prism(RefElem, Order, obj, ipType) - CLASS(ReferenceElement_), INTENT(IN) :: RefElem - INTEGER(I4B), INTENT(IN) :: Order - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE highOrderElement_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! MeasureSimplex@Geometry -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Measure_Simplex_Prism(RefElem, XiJ) RESULT(Ans) - CLASS(ReferenceElement_), INTENT(IN) :: RefElem - REAL(DFP), INTENT(IN) :: XiJ(:, :) - REAL(DFP) :: Ans - END FUNCTION Measure_Simplex_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! Prism_Quality -!---------------------------------------------------------------------------- - -INTERFACE Quality_Prism - MODULE FUNCTION Prism_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 Prism_Quality -END INTERFACE Quality_Prism - -!---------------------------------------------------------------------------- -! POLYHEDRONVOLUME3D -!---------------------------------------------------------------------------- - -!> author: John Burkardt, Vikas Sharma -! date: 2023-08-08 -! summary: computes the volume of a polyhedron in 3D. -! -! Licensing: -! This code is distributed under the GNU LGPL license. -! Modified: -! 19 August 2003 -! Author: -! John Burkardt -! Parameters: -! -! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of -! the vertices. The vertices may be listed in any order. -! -! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices -! that make up a face of the polyhedron. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the -! polyhedron. -! -! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is -! defined by -! the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices -! are listed in neighboring order. -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in -! COORD. -! -! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices -! making -! up each face. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. - -INTERFACE - MODULE PURE SUBROUTINE PolyhedronVolume3D( & - & coord, order_max, face_num, node, & - & node_num, order, ans) - INTEGER(I4B), INTENT(IN) :: order_max - INTEGER(I4B), INTENT(IN) :: face_num - INTEGER(I4B), INTENT(IN) :: node(face_num, order_max) - INTEGER(I4B), INTENT(IN) :: node_num - REAL(DFP), INTENT(IN) :: coord(3, node_num) - INTEGER(I4B), INTENT(IN) :: order(face_num) - REAL(DFP), INTENT(OUT) :: ans - END SUBROUTINE PolyhedronVolume3D -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetEdgeConnectivity_Prism(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 - !! If opt =2, then edge connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - 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_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetFaceConnectivity_Prism(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 - !! If opt = 1, then face connectivity for hierarchial approximation - !! If opt =2, then face connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - 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_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! RefCoord_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Reference Coordinates of prism - -INTERFACE - MODULE PURE FUNCTION RefCoord_Prism(refPrism) RESULT(ans) - CHARACTER(*), INTENT(IN) :: refPrism - REAL(DFP) :: ans(3, 6) - END FUNCTION RefCoord_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceElemType@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-11 -! summary: Returns the element type of each face - -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Prism(faceElemType, opt, & - & tFaceNodes, elemType) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) - !! Face element type - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! elemType for prism - !! default is Prism - END SUBROUTINE GetFaceElemType_Prism -END INTERFACE - -END MODULE ReferencePrism_Method diff --git a/src/modules/Geometry/src/ReferencePyramid_Method.F90 b/src/modules/Geometry/src/ReferencePyramid_Method.F90 deleted file mode 100644 index 64e15d10c..000000000 --- a/src/modules/Geometry/src/ReferencePyramid_Method.F90 +++ /dev/null @@ -1,354 +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 module contains methods for [[ReferencePyramid_]] - -MODULE ReferencePyramid_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -PUBLIC :: ReferencePyramid -PUBLIC :: ReferencePyramid_Pointer -PUBLIC :: HighOrderElement_Pyramid -PUBLIC :: Measure_Simplex_Pyramid -PUBLIC :: Pyramid_Quality -PUBLIC :: Quality_Pyramid -PUBLIC :: GetEdgeConnectivity_Pyramid -PUBLIC :: GetFaceConnectivity_Pyramid -PUBLIC :: RefCoord_Pyramid -PUBLIC :: GetFaceElemType_Pyramid -PUBLIC :: FacetElements_Pyramid -PUBLIC :: ElementOrder_Pyramid -PUBLIC :: ElementType_Pyramid -PUBLIC :: TotalNodesInElement_Pyramid -PUBLIC :: TotalEntities_Pyramid -PUBLIC :: FacetTopology_Pyramid -PUBLIC :: ElementName_Pyramid -PUBLIC :: MaxOrder_Pyramid - -#ifdef MAX_PYRAMID_ORDER -INTEGER(I4B), PARAMETER :: MaxOrder_Pyramid = MAX_PYRAMID_ORDER -#else -INTEGER(I4B), PARAMETER :: MaxOrder_Pyramid = 2_I4B -#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_Pyramid(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION ElementName_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetTopology_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-23 -! summary: Returns the topology of tetrahedron - -INTERFACE - MODULE PURE SUBROUTINE FacetTopology_Pyramid(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetTopology_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalEntities_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total entities in Pyramid - -INTERFACE - MODULE PURE FUNCTION TotalEntities_Pyramid(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION TotalEntities_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total nodes in element - -INTERFACE - MODULE PURE FUNCTION TotalNodesInElement_Pyramid(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION TotalNodesInElement_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementType_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the type of element from char name - -INTERFACE - MODULE PURE FUNCTION ElementType_Pyramid(elemName) RESULT(ans) - CHARACTER(*), INTENT(IN) :: elemName - INTEGER(I4B) :: ans - END FUNCTION ElementType_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementOrder_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the order of element - -INTERFACE - MODULE PURE FUNCTION ElementOrder_Pyramid(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION ElementOrder_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetElements_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Pyramid - MODULE SUBROUTINE FacetElements_Pyramid1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Pyramid1 -END INTERFACE FacetElements_Pyramid - -!---------------------------------------------------------------------------- -! FacetElements_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Pyramid - MODULE SUBROUTINE FacetElements_Pyramid2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Pyramid2 -END INTERFACE FacetElements_Pyramid - -!---------------------------------------------------------------------------- -! Initiate@Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This subroutine for constructing the object - -INTERFACE Initiate - MODULE SUBROUTINE Initiate_Ref_Pyramid(obj, nsd, xij, domainName) - CLASS(ReferencePyramid_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - END SUBROUTINE Initiate_Ref_Pyramid -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! ReferencePyramid@Pyramid -!---------------------------------------------------------------------------- - -INTERFACE ReferencePyramid - MODULE FUNCTION Reference_Pyramid(nsd, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - TYPE(ReferencePyramid_) :: obj - END FUNCTION Reference_Pyramid -END INTERFACE ReferencePyramid - -!---------------------------------------------------------------------------- -! ReferencePyramid_Pointer@Pyramid -!---------------------------------------------------------------------------- - -INTERFACE ReferencePyramid_Pointer - MODULE FUNCTION Reference_Pyramid_Pointer(nsd, xij, domainName) & - & RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - CLASS(ReferencePyramid_), POINTER :: obj - END FUNCTION Reference_Pyramid_Pointer -END INTERFACE ReferencePyramid_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement@Pyramid -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE HighOrderElement_Pyramid(RefElem, Order, obj, ipType) - CLASS(ReferenceElement_), INTENT(IN) :: RefElem - INTEGER(I4B), INTENT(IN) :: Order - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE HighOrderElement_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! MeasureSimplex@Geometry -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Measure_Simplex_Pyramid(RefElem, XiJ) RESULT(Ans) - CLASS(ReferenceElement_), INTENT(IN) :: RefElem - REAL(DFP), INTENT(IN) :: XiJ(:, :) - REAL(DFP) :: Ans - END FUNCTION Measure_Simplex_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! Pyramid_Quality -!---------------------------------------------------------------------------- - -INTERFACE Quality_Pyramid - MODULE FUNCTION Pyramid_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 Pyramid_Quality -END INTERFACE Quality_Pyramid - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetEdgeConnectivity_Pyramid(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 - !! If opt =2, then edge connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! Order of element - 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_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetFaceConnectivity_Pyramid(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 - !! If opt = 1, then face connectivity for hierarchial approximation - !! If opt =2, then face connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! Order of element - 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_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! RefCoord_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-09 -! summary: Reference Coordinates of pyramid - -INTERFACE - MODULE PURE FUNCTION RefCoord_Pyramid(refPyramid) RESULT(ans) - CHARACTER(*), INTENT(IN) :: refPyramid - REAL(DFP) :: ans(3, 5) - END FUNCTION RefCoord_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceElemType@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-11 -! summary: Returns the element type of each face - -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Pyramid(faceElemType, opt, & - & tFaceNodes, elemType) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) - !! Face element type - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! Element type - END SUBROUTINE GetFaceElemType_Pyramid -END INTERFACE - -END MODULE ReferencePyramid_Method diff --git a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 deleted file mode 100644 index 09f3e2cd3..000000000 --- a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 +++ /dev/null @@ -1,484 +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 module contains methods for [[ReferenceQuadrangle_]] - -MODULE ReferenceQuadrangle_Method -USE GlobalData -USE BaseType, ONLY: ReferenceQuadrangle_, ReferenceElement_, & - ReferenceTopology_ -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -PUBLIC :: ReferenceQuadrangle -PUBLIC :: ReferenceQuadrangle_Pointer -PUBLIC :: HighorderElement_Quadrangle -PUBLIC :: Measure_Simplex_Quadrangle -PUBLIC :: Quadrangle_Quality -PUBLIC :: Quality_Quadrangle -PUBLIC :: QuadArea3D, QuadrangleArea3D -PUBLIC :: QuadArea2D, QuadrangleArea2D -PUBLIC :: QuadrangleName -PUBLIC :: GetEdgeConnectivity_Quadrangle -PUBLIC :: GetFaceConnectivity_Quadrangle -PUBLIC :: RefQuadrangleCoord -PUBLIC :: RefCoord_Quadrangle -PUBLIC :: FaceShapeMetaData_Quadrangle -PUBLIC :: FacetElements_Quadrangle -PUBLIC :: DEFAULT_OPT_QUADRANGLE_EDGE_CON -PUBLIC :: ElementOrder_Quadrangle -PUBLIC :: ElementType_Quadrangle -PUBLIC :: TotalNodesInElement_Quadrangle -PUBLIC :: TotalEntities_Quadrangle -PUBLIC :: FacetTopology_Quadrangle -PUBLIC :: ElementName_Quadrangle -PUBLIC :: MaxOrder_Quadrangle -PUBLIC :: GetFaceElemType_Quadrangle - -#ifdef MAX_QUADRANGLE_ORDER -INTEGER(I4B), PARAMETER :: MaxOrder_Quadrangle = MAX_QUADRANGLE_ORDER -#else -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]) - -#ifdef QUADRANGLE_EDGE_CON_DEFAULT_OPT_1 -INTEGER(I4B), PARAMETER :: DEFAULT_OPT_QUADRANGLE_EDGE_CON = 1_I4B -!! This means edges are [1,2], [4,3], [1,4], [2, 3] -#else -INTEGER(I4B), PARAMETER :: DEFAULT_OPT_QUADRANGLE_EDGE_CON = 2_I4B -!! This means edges are [1,2], [2,3], [3,4], [4,1] -!! This is default option -#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_Quadrangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION ElementName_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetTopology@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the facet topology of the given element type - -INTERFACE - MODULE PURE SUBROUTINE FacetTopology_Quadrangle(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetTopology_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalEntities_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total entities - -INTERFACE - MODULE PURE FUNCTION TotalEntities_Quadrangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION TotalEntities_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total nodes in element - -INTERFACE - MODULE PURE FUNCTION TotalNodesInElement_Quadrangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION TotalNodesInElement_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementType_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the type of element from char name - -INTERFACE - MODULE PURE FUNCTION ElementType_Quadrangle(elemName) RESULT(ans) - CHARACTER(*), INTENT(IN) :: elemName - INTEGER(I4B) :: ans - END FUNCTION ElementType_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementOrder_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the order of element - -INTERFACE - MODULE PURE FUNCTION ElementOrder_Quadrangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION ElementOrder_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetElements_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Quadrangle - MODULE SUBROUTINE FacetElements_Quadrangle1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Quadrangle1 -END INTERFACE FacetElements_Quadrangle - -!---------------------------------------------------------------------------- -! FacetElements_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Quadrangle - MODULE SUBROUTINE FacetElements_Quadrangle2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Quadrangle2 -END INTERFACE FacetElements_Quadrangle - -!---------------------------------------------------------------------------- -! QuadrangleName -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Returns integer name of quadragle from order - -INTERFACE QuadrangleName - MODULE PURE FUNCTION QuadrangleName1(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION QuadrangleName1 -END INTERFACE QuadrangleName - -!---------------------------------------------------------------------------- -! Initiate@Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: Returns linear quadrangle element - -INTERFACE Initiate - MODULE PURE SUBROUTINE initiate_ref_Quadrangle(obj, NSD, xij, domainName) - CLASS(ReferenceQuadrangle_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: NSD - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - END SUBROUTINE initiate_ref_Quadrangle -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! ReferenceQuadrangle@Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: Returns Lienar Quadrangle element - -INTERFACE ReferenceQuadrangle - MODULE PURE FUNCTION reference_Quadrangle(NSD, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: NSD - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - TYPE(ReferenceQuadrangle_) :: obj - END FUNCTION reference_Quadrangle -END INTERFACE ReferenceQuadrangle - -!---------------------------------------------------------------------------- -! ReferenceQuadrangle_Pointer@Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: Returns linear Quadrangle element - -INTERFACE ReferenceQuadrangle_Pointer - MODULE FUNCTION reference_Quadrangle_Pointer(NSD, xij, domainName) & - & RESULT(obj) - INTEGER(I4B), INTENT(IN) :: NSD - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - CLASS(ReferenceQuadrangle_), POINTER :: obj - END FUNCTION reference_Quadrangle_Pointer -END INTERFACE ReferenceQuadrangle_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement@Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: Higher order lagrange elements -! -!### Usage -! -!```fortran -! subroutine test4 -! class( ReferenceElement_ ), pointer :: obj_ptr => null() -! type( ReferenceQuadrangle_ ) :: obj -! obj_ptr => referenceQuadrangle_pointer( nsd = 2 ) -! call obj_ptr%LagrangeElement( order = 2, Highorderobj = obj ) -! call display( obj, "higher order obj : ") -! call obj_ptr%LagrangeElement( order = 3, Highorderobj = obj ) -! call display( obj, "3rd order obj : ") -! end -!``` - -INTERFACE - MODULE SUBROUTINE HighorderElement_Quadrangle(refelem, order, obj, & - & ipType) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - INTEGER(I4B), INTENT(IN) :: order - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE HighorderElement_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! MeasureSimplex@Geometry -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Measure_Simplex_Quadrangle(refelem, xij) RESULT(Ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: Ans - END FUNCTION Measure_Simplex_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! Quadrangle_quality -!---------------------------------------------------------------------------- - -INTERFACE Quality_Quadrangle - MODULE FUNCTION Quadrangle_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 Quadrangle_Quality -END INTERFACE Quality_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Aug 2022 -! summary: Area of quadrangle in 3D -! -!# Introduction -! -!- QUADAREA3D computes the area of a quadrilateral in 3D. -!- A quadrilateral is a polygon defined by 4 vertices. -! It is assumed that the four vertices of the quadrilateral -! are coplanar. -!- This algorithm computes the area of the related Varignon parallelogram -! first. - -INTERFACE QuadrangleArea3D - MODULE PURE SUBROUTINE QuadArea3D(q, ans) - REAL(DFP), INTENT(IN) :: q(3, 4) - REAL(DFP), INTENT(OUT) :: ans - END SUBROUTINE QuadArea3D -END INTERFACE QuadrangleArea3D - -!---------------------------------------------------------------------------- -! QuadrangleArea2D -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Aug 2022 -! summary: QuadArea2D -! -!# Introduction -! -!- QUADAREA2D computes the area of a quadrilateral in 2D. -!- A quadrilateral is a polygon defined by 4 vertices. -! This algorithm should be able to handle nonconvex quadrilaterals. -! The vertices of the quadrilateral should be listed in counter clockwise -! order, so that the area is positive. - -INTERFACE QuadrangleArea2D - MODULE PURE SUBROUTINE QuadArea2D(q, ans) - REAL(DFP), INTENT(IN) :: q(2, 4) - REAL(DFP), INTENT(OUT) :: ans - END SUBROUTINE QuadArea2D -END INTERFACE QuadrangleArea2D - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetEdgeConnectivity_Quadrangle(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 - !! If opt =2, then edge connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! Order of the element - 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_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-19 -! summary: Returns face connectivity -! -!# Introduction -! -! this routine calls [[GetEdgeConnectivity_Quadrangle]] -! with opt=2 - -INTERFACE - MODULE PURE SUBROUTINE GetFaceConnectivity_Quadrangle(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 not used - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! Order of the element - 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_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! RefQuadrangleCoord -!---------------------------------------------------------------------------- - -INTERFACE RefCoord_Quadrangle - MODULE PURE FUNCTION RefQuadrangleCoord(refQuadrangle) RESULT(ans) - CHARACTER(*), INTENT(IN) :: refQuadrangle - REAL(DFP) :: ans(2, 4) - END FUNCTION RefQuadrangleCoord -END INTERFACE RefCoord_Quadrangle - -!---------------------------------------------------------------------------- -! FaceShapeMetaData_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-13 -! summary: Returns meta data for global orientation of face - -INTERFACE - MODULE SUBROUTINE FaceShapeMetaData_Quadrangle(face, sorted_face, & - & faceOrient, localFaces) - INTEGER(I4B), INTENT(INOUT) :: face(:) - INTEGER(I4B), INTENT(INOUT) :: sorted_face(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceOrient(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: localFaces(:) - END SUBROUTINE FaceShapeMetaData_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceElemType_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-19 -! summary: Returns the element type of each face - -INTERFACE -MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(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_Quadrangle -END INTERFACE - -END MODULE ReferenceQuadrangle_Method diff --git a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 b/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 deleted file mode 100644 index 6dd64c981..000000000 --- a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 +++ /dev/null @@ -1,368 +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 module contains methods for [[ReferenceTetrahedron_]] - -MODULE ReferenceTetrahedron_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -PUBLIC :: ReferenceTetrahedron -PUBLIC :: ReferenceTetrahedron_Pointer -PUBLIC :: HighOrderElement_Tetrahedron -PUBLIC :: Measure_Simplex_Tetrahedron -PUBLIC :: Tetrahedron_Quality -PUBLIC :: TetrahedronVolume3D -PUBLIC :: Quality_Tetrahedron -PUBLIC :: GetEdgeConnectivity_Tetrahedron -PUBLIC :: GetFaceConnectivity_Tetrahedron -PUBLIC :: RefCoord_Tetrahedron -PUBLIC :: GetFaceElemType_Tetrahedron -PUBLIC :: FacetElements_Tetrahedron -PUBLIC :: ElementOrder_Tetrahedron -PUBLIC :: ElementType_Tetrahedron -PUBLIC :: TotalNodesInElement_Tetrahedron -PUBLIC :: TotalEntities_Tetrahedron -PUBLIC :: FacetTopology_Tetrahedron -PUBLIC :: ElementName_Tetrahedron -PUBLIC :: MaxOrder_Tetrahedron - -#ifdef MAX_TETRAHEDRON_ORDER -INTEGER(I4B), PARAMETER :: MaxOrder_Tetrahedron = MAX_TETRAHEDRON_ORDER -#else -INTEGER(I4B), PARAMETER :: MaxOrder_Tetrahedron = 2_I4B -#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_Tetrahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION ElementName_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetTopology_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-23 -! summary: Returns the topology of tetrahedron - -INTERFACE - MODULE PURE SUBROUTINE FacetTopology_Tetrahedron(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetTopology_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalEntities_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total entities in Tetrahedron - -INTERFACE - MODULE PURE FUNCTION TotalEntities_Tetrahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION TotalEntities_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total nodes in element - -INTERFACE - MODULE PURE FUNCTION TotalNodesInElement_Tetrahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION TotalNodesInElement_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementType_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the type of element from char name - -INTERFACE - MODULE PURE FUNCTION ElementType_Tetrahedron(elemName) RESULT(ans) - CHARACTER(*), INTENT(IN) :: elemName - INTEGER(I4B) :: ans - END FUNCTION ElementType_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementOrder_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the order of element - -INTERFACE - MODULE PURE FUNCTION ElementOrder_Tetrahedron(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION ElementOrder_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetElements_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Tetrahedron - MODULE SUBROUTINE FacetElements_Tetrahedron1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Tetrahedron1 -END INTERFACE FacetElements_Tetrahedron - -!---------------------------------------------------------------------------- -! FacetElements_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Tetrahedron - MODULE SUBROUTINE FacetElements_Tetrahedron2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Tetrahedron2 -END INTERFACE FacetElements_Tetrahedron - -!---------------------------------------------------------------------------- -! Initiate@Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This subroutine for constructing the object - -INTERFACE Initiate - MODULE PURE SUBROUTINE Initiate_Ref_Tetrahedron(obj, nsd, xij, domainName) - CLASS(ReferenceTetrahedron_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - END SUBROUTINE Initiate_Ref_Tetrahedron -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! ReferenceTetrahedron@Tetrahedron -!---------------------------------------------------------------------------- - -INTERFACE ReferenceTetrahedron - MODULE PURE FUNCTION reference_Tetrahedron(nsd, xij, domainName) & - & RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - TYPE(ReferenceTetrahedron_) :: obj - END FUNCTION reference_Tetrahedron -END INTERFACE ReferenceTetrahedron - -!---------------------------------------------------------------------------- -! ReferenceTetrahedron_Pointer@Tetrahedron -!---------------------------------------------------------------------------- - -INTERFACE ReferenceTetrahedron_Pointer - MODULE FUNCTION reference_Tetrahedron_Pointer(nsd, xij, domainName) & - & RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - CLASS(ReferenceTetrahedron_), POINTER :: obj - END FUNCTION reference_Tetrahedron_Pointer -END INTERFACE ReferenceTetrahedron_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement@Tetrahedron -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE HighOrderElement_Tetrahedron(refelem, order, obj, ipType) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - INTEGER(I4B), INTENT(IN) :: order - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE HighOrderElement_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! MeasureSimplex@Geometry -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Measure_Simplex_Tetrahedron(RefElem, XiJ) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: RefElem - REAL(DFP), INTENT(IN) :: XiJ(:, :) - REAL(DFP) :: ans - END FUNCTION Measure_Simplex_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! Tetrahedron_Quality -!---------------------------------------------------------------------------- - -INTERFACE Quality_Tetrahedron - MODULE FUNCTION Tetrahedron_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 Tetrahedron_Quality -END INTERFACE Quality_Tetrahedron - -!---------------------------------------------------------------------------- -! TetrahedronVolume3D -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE TetrahedronVolume3D(xij, ans) - REAL(DFP), INTENT(IN) :: xij(3, 4) - REAL(DFP), INTENT(OUT) :: ans - END SUBROUTINE TetrahedronVolume3D -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetEdgeConnectivity_Tetrahedron(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 - !! If opt =2, then edge connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! Order of the edge - 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_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetFaceConnectivity_Tetrahedron(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 - !! If opt = 1, then face connectivity for hierarchial approximation - !! If opt =2, then face connectivity for Lagrangian approximation - !! opt=1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! order - 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_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! RefCoord_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference Tetrahedron - -INTERFACE - MODULE PURE FUNCTION RefCoord_Tetrahedron(refTetrahedron) RESULT(ans) - CHARACTER(*), INTENT(IN) :: refTetrahedron - REAL(DFP) :: ans(3, 4) - END FUNCTION RefCoord_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! 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) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) - !! Face element type - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! element type for Tetrahedron - !! default is Tetrahedron4 - END SUBROUTINE GetFaceElemType_Tetrahedron -END INTERFACE - -END MODULE ReferenceTetrahedron_Method diff --git a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 b/src/modules/Geometry/src/ReferenceTriangle_Method.F90 deleted file mode 100644 index 2e71a0e39..000000000 --- a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 +++ /dev/null @@ -1,825 +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 module contains method for [[ReferenceTriangle_]] data type. - -MODULE ReferenceTriangle_Method -USE GlobalData -USE BaseType, ONLY: ReferenceElement_, ReferenceTopology_, ReferenceTriangle_ -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -PUBLIC :: ReferenceTriangle -PUBLIC :: ReferenceTriangle_Pointer -PUBLIC :: HighorderElement_Triangle -PUBLIC :: Measure_Simplex_Triangle -PUBLIC :: Triangle_Contains_Point -PUBLIC :: Contains_Point_Triangle -PUBLIC :: Angles -PUBLIC :: Area -PUBLIC :: ArealVector -PUBLIC :: Barycentric -PUBLIC :: Centroid -PUBLIC :: CircumCenter -PUBLIC :: CircumCircle -PUBLIC :: CircumRadius -PUBLIC :: ContainsLine -PUBLIC :: Diameter -PUBLIC :: EdgeLength -PUBLIC :: Incenter -PUBLIC :: Incircle -PUBLIC :: Inradius -PUBLIC :: Orthocenter -PUBLIC :: DistanceFromPoint -PUBLIC :: NearestPoint -PUBLIC :: RandomPoint -PUBLIC :: Triangle_Quality -PUBLIC :: Quality_Triangle -PUBLIC :: TriangleArea3D -PUBLIC :: TriangleArea2D -PUBLIC :: GetEdgeConnectivity_Triangle -PUBLIC :: GetFaceConnectivity_Triangle -PUBLIC :: RefTriangleCoord -PUBLIC :: RefCoord_Triangle -PUBLIC :: FacetElements_Triangle -PUBLIC :: DEFAULT_OPT_TRIANGLE_EDGE_CON -PUBLIC :: ElementOrder_Triangle -PUBLIC :: ElementType_Triangle -PUBLIC :: TotalNodesInElement_Triangle -PUBLIC :: TotalEntities_Triangle -PUBLIC :: FacetTopology_Triangle -PUBLIC :: ElementName_Triangle -PUBLIC :: MaxOrder_Triangle -PUBLIC :: FaceShapeMetaData_Triangle -PUBLIC :: GetFaceElemType_Triangle - -#ifdef MAX_TRIANGLE_ORDER -INTEGER(I4B), PARAMETER :: MaxOrder_Triangle = MAX_TRIANGLE_ORDER -#else -INTEGER(I4B), PARAMETER :: MaxOrder_Triangle = 2_I4B -#endif - -#ifdef TRIANGLE_EDGE_CON_DEFAULT_OPT_1 -INTEGER(I4B), PARAMETER :: DEFAULT_OPT_TRIANGLE_EDGE_CON = 1_I4B -!! This means edges are [1,2], [1,3], [2,3] -#else -INTEGER(I4B), PARAMETER :: DEFAULT_OPT_TRIANGLE_EDGE_CON = 2_I4B -!! This means edges are [1,2], [2,3], [3,1] -!! This is default option -#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_Triangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION ElementName_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetTopology@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the facet topology of the given element type - -INTERFACE - MODULE PURE SUBROUTINE FacetTopology_Triangle(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetTopology_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalEntities_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total entities - -INTERFACE - MODULE PURE FUNCTION TotalEntities_Triangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION TotalEntities_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total nodes in element - -INTERFACE - MODULE PURE FUNCTION TotalNodesInElement_Triangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION TotalNodesInElement_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementType_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the type of element from char name - -INTERFACE - MODULE PURE FUNCTION ElementType_Triangle(elemName) RESULT(ans) - CHARACTER(*), INTENT(IN) :: elemName - INTEGER(I4B) :: ans - END FUNCTION ElementType_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementOrder_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the order of element - -INTERFACE - MODULE PURE FUNCTION ElementOrder_Triangle(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION ElementOrder_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetElements_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Triangle - MODULE SUBROUTINE FacetElements_Triangle1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Triangle1 -END INTERFACE FacetElements_Triangle - -!---------------------------------------------------------------------------- -! FacetElements_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Triangle - MODULE SUBROUTINE FacetElements_Triangle2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Triangle2 -END INTERFACE FacetElements_Triangle - -!---------------------------------------------------------------------------- -! Initiate@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This routine constructs an instance of [[ReferenceTriangle_]] -! -!# Introduction -! -! - This routine contructs an instance of [[ReferenceTriangle_]] -! - User can specify the coordinates of the trinagle -! -!@note -! This routine will contruct a three node triangle. -! Also, SHAPE(xij) = [3,3] -!@endnote -! -!### Usage -! -!```fortran -! subroutine test1 -! type( ReferenceTriangle_ ) :: obj -! real( dfp ) :: xij( 3, 3 ) -! xij( 1, 1:3 ) = [1.0, 2.0, 1.0] -! xij( 2, 1:3 ) = [0.0, 0.0, 1.0] -! xij( 3, : ) = 0.0 -! call initiate( obj, nsd = 2, xij = xij ) -! call display( obj, "obj : " ) -! end -!``` - -INTERFACE Initiate - MODULE PURE SUBROUTINE Initiate_Ref_Triangle(obj, nsd, xij, domainName) - CLASS(ReferenceTriangle_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - END SUBROUTINE Initiate_Ref_Triangle -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! ReferenceTriangle@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This function returns an instance of [[ReferenceTriangle_]] -! -!# Introduction -! * This routine contructs an instance of [[ReferenceTriangle_]] -! * User can specify the coordinates of the trinagle -!@note -! This routine will contruct a three node triangle. Also, SHAPE(xij) = [3,3] -!@endnote -! -!### Usage -! -!```fortran -! subroutine test2 -! type( ReferenceTriangle_ ) :: obj -! obj = referenceTriangle( nsd = 2 ) -! call display( obj, "obj : " ) -! end -!``` - -INTERFACE ReferenceTriangle - MODULE PURE FUNCTION Reference_Triangle(nsd, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - TYPE(ReferenceTriangle_) :: obj - END FUNCTION Reference_Triangle -END INTERFACE ReferenceTriangle - -!---------------------------------------------------------------------------- -! ReferenceTriangle_Pointer@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This function returns an instance of [[ReferenceTriangle_]] -! -!# Introduction -! * This routine contructs an instance of [[ReferenceTriangle_]] -! * User can specify the coordinates of the trinagle -!@note -!This routine will contruct a three node triangle. Also, SHAPE(xij) = [3,3] -!@endnote -! -!### Usage -! -!```fortran -! subroutine test3 -! class( ReferenceElement_ ), pointer :: obj => null() -! obj => referenceTriangle_pointer( nsd = 2 ) -! call display( obj, "obj : " ) -! end -!``` - -INTERFACE ReferenceTriangle_Pointer - MODULE FUNCTION Reference_Triangle_Pointer(nsd, xij, domainName) & - & RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName - CLASS(ReferenceTriangle_), POINTER :: obj - END FUNCTION Reference_Triangle_Pointer -END INTERFACE ReferenceTriangle_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: Returns lagrange Triangle element of higher order -! -!# Introduction -! This routine retuns the lagrance element of higher order -! This routine will be called by [[ReferenceTriangle_:LagrangeElement]] -! Currently upto 3rd order triangle elements are supported. -! -!### Usage -! -!```fortran -! subroutine test4 -! class( ReferenceElement_ ), pointer :: obj_ptr => null() -! type( ReferenceTriangle_ ) :: obj -! obj_ptr => referenceTriangle_pointer( nsd = 2 ) -! call obj_ptr%highorderElement( order = 2, Highorderobj = obj ) -! call display( obj, "higher order obj : ") -! call obj_ptr%highorderElement( order = 3, Highorderobj = obj ) -! call display( obj, "3rd order obj : ") -! end -!``` - -INTERFACE - MODULE SUBROUTINE HighorderElement_Triangle(refelem, order, obj, ipType) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - INTEGER(I4B), INTENT(IN) :: order - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE HighorderElement_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! MeasureSimplex@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns the measure of linear triangle -! -!# Introduction -! -! This function returns the measure of linear triangle. This function belongs -! to the generic function [[ReferenceElement_Method:MeasureSimplex]]. - -INTERFACE - MODULE PURE FUNCTION Measure_Simplex_Triangle(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans - END FUNCTION Measure_Simplex_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! Angles@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns three angles of a triangle - -INTERFACE Angles - MODULE PURE FUNCTION Triangle_angles(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(3) - END FUNCTION Triangle_angles -END INTERFACE Angles - -!---------------------------------------------------------------------------- -! Area@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns the area of triangle - -INTERFACE Area - MODULE PURE FUNCTION Triangle_area(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans - END FUNCTION Triangle_area -END INTERFACE Area - -!---------------------------------------------------------------------------- -! ArealVector@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns the area vector - -INTERFACE ArealVector - MODULE PURE FUNCTION Triangle_arealVector(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(3) - END FUNCTION Triangle_arealVector -END INTERFACE ArealVector - -!---------------------------------------------------------------------------- -! Barycentric@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns the barycentric coordinates of triangle - -INTERFACE Barycentric - MODULE PURE FUNCTION Triangle_barycentric(refelem, xij, x) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(3) - END FUNCTION Triangle_barycentric -END INTERFACE Barycentric - -!---------------------------------------------------------------------------- -! Centroid@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns the centroid of a triangle - -INTERFACE Centroid - MODULE PURE FUNCTION Triangle_centroid(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(3) - END FUNCTION Triangle_centroid -END INTERFACE Centroid - -!---------------------------------------------------------------------------- -! CircumCenter@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns the circum center of the triangle - -INTERFACE CircumCenter - MODULE PURE FUNCTION Triangle_circumcentre(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(3) - END FUNCTION Triangle_circumcentre -END INTERFACE CircumCenter - -!---------------------------------------------------------------------------- -! CircumCircle@Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: Returns circum circle of triangle - -INTERFACE CircumCircle - MODULE PURE FUNCTION Triangle_circumcircle(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(4) - !! ans(1) = radius and ans(2:4) center - END FUNCTION Triangle_circumcircle -END INTERFACE CircumCircle - -!---------------------------------------------------------------------------- -! CircumRadius@Triangle -!---------------------------------------------------------------------------- - -INTERFACE CircumRadius - MODULE PURE FUNCTION Triangle_circumradius(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans - END FUNCTION Triangle_circumradius -END INTERFACE CircumRadius - -!---------------------------------------------------------------------------- -! ContainsLine@Triangle -!---------------------------------------------------------------------------- - -INTERFACE ContainsLine - MODULE PURE SUBROUTINE Triangle_contains_line(refelem, xij, x1, x2, & - & parametricLine, inside, xint) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :), x1(3), x2(3) - LOGICAL(LGT), INTENT(IN) :: parametricLine - LOGICAL(LGT), INTENT(OUT) :: inside - REAL(DFP), INTENT(OUT) :: xint(3) - END SUBROUTINE Triangle_contains_line -END INTERFACE ContainsLine - -!---------------------------------------------------------------------------- -! ContainsPoint@Triangle -!---------------------------------------------------------------------------- - -INTERFACE Contains_Point_Triangle - MODULE PURE FUNCTION Triangle_Contains_Point(refelem, xij, x) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :), x(:) - LOGICAL(LGT) :: ans - END FUNCTION Triangle_Contains_Point -END INTERFACE Contains_Point_Triangle - -!---------------------------------------------------------------------------- -! Diameter@Triangle -!---------------------------------------------------------------------------- - -INTERFACE Diameter - MODULE PURE FUNCTION triangle_diameter(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans - END FUNCTION triangle_diameter -END INTERFACE Diameter - -!---------------------------------------------------------------------------- -! EdgeLength@Triangle -!---------------------------------------------------------------------------- - -INTERFACE EdgeLength - MODULE PURE FUNCTION triangle_edge_length(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(3) - END FUNCTION triangle_edge_length -END INTERFACE EdgeLength - -!---------------------------------------------------------------------------- -! Incenter@Triangle -!---------------------------------------------------------------------------- - -INTERFACE Incenter - MODULE PURE FUNCTION triangle_incenter(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(3) - END FUNCTION triangle_incenter -END INTERFACE Incenter - -!---------------------------------------------------------------------------- -! Incircle@Triangle -!---------------------------------------------------------------------------- - -INTERFACE Incircle - MODULE PURE FUNCTION triangle_incircle(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(4) - END FUNCTION triangle_incircle -END INTERFACE Incircle - -!---------------------------------------------------------------------------- -! Inradius@Triangle -!---------------------------------------------------------------------------- - -INTERFACE Inradius - MODULE PURE FUNCTION triangle_inradius(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans - END FUNCTION triangle_inradius -END INTERFACE Inradius - -!---------------------------------------------------------------------------- -! Orthocenter@Triangle -!---------------------------------------------------------------------------- - -INTERFACE Orthocenter - MODULE PURE FUNCTION triangle_orthocenter(refelem, xij) RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: ans(3) - END FUNCTION triangle_orthocenter -END INTERFACE Orthocenter - -!---------------------------------------------------------------------------- -! DistanceFromPoint@Triangle -!---------------------------------------------------------------------------- - -INTERFACE DistanceFromPoint - MODULE PURE FUNCTION triangle_point_dist(refelem, xij, x) & - & RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :), x(:) - REAL(DFP) :: ans - END FUNCTION triangle_point_dist -END INTERFACE DistanceFromPoint - -!---------------------------------------------------------------------------- -! NearestPoint@Triangle -!---------------------------------------------------------------------------- - -INTERFACE NearestPoint - MODULE PURE SUBROUTINE triangle_get_nearest_point(refelem, xij, x, xn, & - & dist) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :), x(:) - REAL(DFP), INTENT(INOUT) :: xn(:) - REAL(DFP), INTENT(OUT) :: dist - END SUBROUTINE triangle_get_nearest_point -END INTERFACE NearestPoint - -!---------------------------------------------------------------------------- -! RandomPoint@Triangle -!---------------------------------------------------------------------------- - -INTERFACE RandomPoint - MODULE PURE FUNCTION triangle_random_point(refelem, xij, n, seed) & - & RESULT(ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed - REAL(DFP) :: ans(3, n) - END FUNCTION triangle_random_point -END INTERFACE RandomPoint - -!---------------------------------------------------------------------------- -! Quality@Triangle -!---------------------------------------------------------------------------- - -INTERFACE Quality_Triangle - MODULE PURE FUNCTION Triangle_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 Triangle_Quality -END INTERFACE Quality_Triangle - -!---------------------------------------------------------------------------- -! TriangleArea3D -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Aug 2022 -! summary: Area of triangle in 3D -! -!# Introduction -! -!- TRIANGLEAREA3D computes the area of a triangle in 3D. -!- This routine uses the fact that the norm of the cross product -! of two vectors is the area of the parallelogram they form. -! Therefore, the area of the triangle is half of that value. - -INTERFACE - MODULE PURE SUBROUTINE TriangleArea3D(t, ans) - REAL(DFP), INTENT(IN) :: t(3, 3) - REAL(DFP), INTENT(OUT) :: ans - END SUBROUTINE TriangleArea3D -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Aug 2022 -! summary: Return are of triangle in 2D -! -!# Introduction -! -!- TRIANGLEAREA2D computes the area of a triangle in 2D. -!- If the triangle's vertices are given in counter clockwise order, -! the area will be positive. If the triangle's vertices are given -! in clockwise order, the area will be negative! - -INTERFACE - MODULE PURE SUBROUTINE TriangleArea2D(t, ans) - REAL(DFP), INTENT(IN) :: t(2, 3) - REAL(DFP), INTENT(OUT) :: ans - END SUBROUTINE TriangleArea2D -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-08 -! summary: Returns number of edges in the element - -INTERFACE - MODULE PURE SUBROUTINE GetEdgeConnectivity_Triangle(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_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-19 -! summary: Get the face connectivity of triangle -! -!# Introduction -! -! This routine calls [[GetEdgeConnectivity_Triangle]] with opt=2 - -INTERFACE - MODULE PURE SUBROUTINE GetFaceConnectivity_Triangle(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_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! RefTriangleCoord -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference triangle - -INTERFACE RefCoord_Triangle - MODULE PURE FUNCTION RefTriangleCoord(refTriangle) RESULT(ans) - CHARACTER(*), INTENT(IN) :: refTriangle - REAL(DFP) :: ans(2, 3) - END FUNCTION RefTriangleCoord -END INTERFACE RefCoord_Triangle - -!---------------------------------------------------------------------------- -! FaceShapeMetaData_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-13 -! summary: Returns meta data for global orientation of face - -INTERFACE - MODULE SUBROUTINE FaceShapeMetaData_Triangle(face, sorted_face, & - faceOrient, localFaces) - INTEGER(I4B), INTENT(INOUT) :: face(:) - INTEGER(I4B), INTENT(INOUT) :: sorted_face(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceOrient(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: localFaces(:) - END SUBROUTINE FaceShapeMetaData_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! GetFaceElemType@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-19 -! summary: Returns the element type of each face - -INTERFACE -MODULE PURE SUBROUTINE GetFaceElemType_Triangle(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_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ReferenceTriangle_Method diff --git a/src/modules/Geometry/src/Triangle_Method.F90 b/src/modules/Geometry/src/Triangle_Method.F90 deleted file mode 100644 index 62db70829..000000000 --- a/src/modules/Geometry/src/Triangle_Method.F90 +++ /dev/null @@ -1,1505 +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: 28 Aug 2022 -! summary: Triangle geometry MODULE -! -!# Introduction -! -! This MODULE is just a carbon copy of the MODULE written by -! professor John Burkardt. The original code is kept in the directory -! named "./assets/geometry_burkardt_triangle.inc". -! -! I have just restructured the code according to the code style of -! easifem. - -MODULE Triangle_Method -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: triangle_angles_2d -PUBLIC :: triangle_angles_3d -PUBLIC :: triangle_area_2d -PUBLIC :: triangle_area_3d -PUBLIC :: triangle_area_3d_2 -PUBLIC :: triangle_area_3d_3 -PUBLIC :: triangle_area_heron -PUBLIC :: triangle_area_vector_3d -PUBLIC :: triangle_barycentric_2d -PUBLIC :: triangle_centroid_2d -PUBLIC :: triangle_centroid_3d -PUBLIC :: triangle_circumcenter_2d -PUBLIC :: triangle_circumcenter_2d_2 -PUBLIC :: triangle_circumcenter -PUBLIC :: triangle_circumcircle_2d -PUBLIC :: triangle_circumcircle_2d_2 -PUBLIC :: triangle_circumradius_2d -PUBLIC :: triangle_contains_line_exp_3d -PUBLIC :: triangle_contains_line_par_3d -PUBLIC :: triangle_contains_point_2d_1 -PUBLIC :: triangle_contains_point_2d_2 -PUBLIC :: triangle_contains_point_2d_3 -PUBLIC :: triangle_diameter_2d -PUBLIC :: triangle_edge_length_2d -PUBLIC :: triangle_incenter_2d -PUBLIC :: triangle_incircle_2d -PUBLIC :: triangle_inradius_2d -PUBLIC :: triangle_orthocenter_2d -PUBLIC :: triangle_point_dist_2d -PUBLIC :: triangle_point_dist_3d -PUBLIC :: triangle_point_dist_signed_2d -PUBLIC :: triangle_point_near_2d -PUBLIC :: triangle_quality_2d -PUBLIC :: triangle_sample - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Computes the angles of a triangle in 2D. -! -!# Introduction -! -! The law of cosines is used: -! -!$$ -! C^2 = A^2 + B^2 - 2 * A * B * COS ( GAMMA ) -!$$ -! -! where GAMMA is the angle opposite side C. - -INTERFACE - MODULE PURE FUNCTION triangle_angles_2d(t) RESULT(angle) - REAL(DFP), INTENT(IN) :: t(:, :) - !! vertex in xij format - REAL(DFP) :: angle(3) - !! The angles opposite sides P1-P2, P2-P3 and P3-P1, in radians. - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Computes the angles of a triangle in 3D. -! -!# Introduction -! -! The law of cosines is used: -! -!$$ -! C * C = A * A + B * B - 2 * A * B * COS ( GAMMA ) -!$$ -! -! where GAMMA is the angle opposite side C. - -INTERFACE - MODULE PURE FUNCTION triangle_angles_3d(t) RESULT(angle) - REAL(DFP), INTENT(IN) :: t(:, :) - !! vertices in xij format - REAL(DFP) :: angle(3) - !! angle - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: compute area of the triangle -! -!# Introduction -! -! If the triangle's vertices are given in counter clockwise order, -! the area will be positive. If the triangle's vertices are given -! in clockwise order, the area will be negative! -! -! An earlier version of this routine always returned the absolute -! value of the computed area. I am convinced now that that is -! a less useful RESULT! For instance, by returning the signed -! area of a triangle, it is possible to easily compute the area -! of a nonconvex polygon as the sum of the (possibly negative) -! areas of triangles formed by node 1 and successive pairs of vertices. -! - -INTERFACE - MODULE PURE FUNCTION triangle_area_2d(t) RESULT(area) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: area - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: compute area of triangle in 3D -! -!# Introduction -! -! This routine uses the fact that the norm of the cross product -! of two vectors is the area of the parallelogram they form. -! -! Therefore, the area of the triangle is half of that value. - -INTERFACE - MODULE PURE FUNCTION triangle_area_3d(t) RESULT(area) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: area - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: area of triangle in 3D -! -!# Introduction -! -! This routine computes the area "the hard way". - -INTERFACE - MODULE PURE FUNCTION triangle_area_3d_2(t) RESULT(area) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: area - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: area of triangle using Heron's formula - -INTERFACE - MODULE PURE FUNCTION triangle_area_3d_3(t) RESULT(area) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: area - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Area of triangle using Herons formula -! -!# Introduction -! -! The formula is valid for any spatial dimension, depENDing only -! on the lengths of the sides, and not the coordinates of the vertices. - -INTERFACE - MODULE PURE FUNCTION triangle_area_heron(s) RESULT(area) - REAL(DFP), INTENT(IN) :: s(3) - REAL(DFP) :: area - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: compute the area vector of a tri in 3D -! -!# Introduction -! -! The "area vector" of a triangle is simply a cross product of, -! for instance, the vectors (V2-V1) and (V3-V1), where V1, V2 -! and V3 are the vertices of the triangle. -! -! The norm of the cross product vector of two vectors is the area -! of the parallelogram they form. -! -! Therefore, the area of the triangle is half of the norm of the -! area vector: -! -! area = 0.5 * sqrt ( sum ( area_vector(1:3)^2 ) ) -! -! The reason for looking at the area vector rather than the area -! is that this makes it possible to compute the area of a flat -! polygon in 3D by summing the areas of the triangles that form -! a decomposition of the polygon, while allowing for both positive -! and negative areas. (Sum the vectors, THEN take the norm and -! multiply by 1/2). - -INTERFACE - MODULE PURE FUNCTION triangle_area_vector_3d(t) RESULT(area_vector) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: area_vector(3) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Find the barycentric coordinates of a point in 2D -! -!# Introduction -! -! The barycentric coordinate of point P related to vertex A can be -! interpreted as the ratio of the area of the triangle with -! vertex A replaced by vertex P to the area of the original -! triangle. -! -! This routine assumes that the triangle vertices are given in -! counter clockwise order. - -INTERFACE - MODULE PURE FUNCTION triangle_barycentric_2d(t, p) RESULT(xsi) - REAL(DFP), INTENT(IN) :: t(:, :) - !! vertex - REAL(DFP), INTENT(IN) :: p(2) - !! point - REAL(DFP) :: xsi(3) - !! barycentric points - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: compute the centroid of a triangle in 2D -! -!# Introduction -! -! The centroid of a triangle can also be considered the -! center of gravity, or center of mass, assuming that the triangle -! is made of a thin uniform sheet of massy material. -! -! The centroid of a triangle is the intersection of the medians. -! -! A median of a triangle is a line connecting a vertex to the -! midpoint of the opposite side. -! -! In barycentric coordinates, in which the vertices of the triangle -! have the coordinates (1,0,0), (0,1,0) and (0,0,1), the centroid -! has coordinates (1/3,1/3,1/3). -! -! In geometry, the centroid of a triangle is often symbolized by "G". - -INTERFACE - MODULE PURE FUNCTION triangle_centroid_2d(t) RESULT(centroid) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: centroid(2) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: computes the centroid of a triangle in 3D -! -!# Introduction -! -! The centroid of a triangle can also be considered the -! center of gravity or center of mass, assuming that the triangle -! is made of a thin uniform sheet of massy material. -! -! The centroid of a triangle is the intersection of the medians. -! A median of a triangle is a line connecting any vertex to the -! midpoint of the opposite side. - -INTERFACE - MODULE PURE FUNCTION triangle_centroid_3d(t) RESULT(centroid) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: centroid(3) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: cirumcenter of a triangle in 2D -! -!# Introduction -! -! The circumcenter of a triangle is the center of the circumcircle, the -! circle that passes through the three vertices of the triangle. -! -! The circumcircle contains the triangle, but it is not necessarily the -! smallest triangle to do so. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. -! -! The circumcenter is the intersection of the perpENDicular bisectors -! of the sides of the triangle. -! -! In geometry, the circumcenter of a triangle is often symbolized by "O". - -INTERFACE - MODULE PURE FUNCTION triangle_circumcenter_2d(t) RESULT(pc) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: pc(2) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: circum center in 2d -! -!# Introduction -! -! The circumcenter of a triangle is the center of the circumcircle, the -! circle that passes through the three vertices of the triangle. -! -! The circumcircle contains the triangle, but it is not necessarily the -! smallest triangle to do so. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. -! -! The circumcenter is the intersection of the perpENDicular bisectors -! of the sides of the triangle. -! -! Surprisingly, the diameter of the circle can be found by solving -! a 2 by 2 linear system. If we label the vertices of the triangle -! P1, P2 and P3, then the vectors P2 - P1 and P3 - P1 are secants of -! the circle, and each forms a right triangle with the diameter -! vector through P1. -! -! Hence, the dot product of P2 - P1 with the diameter vector is equal -! to the square of the length of P2 - P1, and similarly for P3 - P1. -! This determines the diameter vector originating at P1. -! -! In geometry, the circumcenter of a triangle is often symbolized by "O". -! - -INTERFACE - MODULE PURE FUNCTION triangle_circumcenter_2d_2(t) RESULT(pc) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: pc(2) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: computes the circumcenter of a triangle in ND. -! -!# Introduction -! -! Three ND points A, B and C lie on a circle. -! -! The circumcenter P has the formula -! -! P = ( Area ( PBC ) * A + Area ( APC) * B + Area ( ABP ) * C ) -! / ( Area ( PBC ) + Area ( APC ) + Area ( ABP ) ) -! -! The details of the formula rely on information supplied -! by Oscar Lanzi III. - -INTERFACE - MODULE PURE FUNCTION triangle_circumcenter(n, t) RESULT(p) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: t(:, :) - !! shape (n,3) - REAL(DFP) :: p(n) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: computes the circumcircle of a triangle in 2D -! -!# Introduction -! -! The circumcenter of a triangle is the center of the circumcircle, the -! circle that passes through the three vertices of the triangle. -! -! The circumcircle contains the triangle, but it is not necessarily the -! smallest triangle to do so. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. -! -! The circumcenter is the intersection of the perpENDicular bisectors -! of the sides of the triangle. -! -! In geometry, the circumcenter of a triangle is often symbolized by "O". - -INTERFACE - MODULE PURE SUBROUTINE triangle_circumcircle_2d(t, r, pc) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(OUT) :: pc(2) - !! circum center - REAL(DFP), INTENT(OUT) :: r - !! circum radius - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: circumcircle -! -!# Introduction -! -! The circumscribed circle of a triangle is the circle that passes through -! the three vertices of the triangle. The circumscribed circle contains -! the triangle, but it is not necessarily the smallest triangle to do so. -! -! Surprisingly, the diameter of the circle can be found by solving -! a 2 by 2 linear system. This is because the vectors P2 - P1 -! and P3 - P1 are secants of the circle, and each forms a right -! triangle with the diameter. Hence, the dot product of -! P2 - P1 with the diameter is equal to the square of the length -! of P2 - P1, and similarly for P3 - P1. This determines the -! diameter vector originating at P1. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. - -INTERFACE - MODULE PURE SUBROUTINE triangle_circumcircle_2d_2(t, r, pc) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(OUT) :: pc(2) - !! circum center - REAL(DFP), INTENT(OUT) :: r - !! circum radius - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: triangle circumradius in 2d -! -!# Introduction -! -! The circumscribed circle of a triangle is the circle that passes through -! the three vertices of the triangle. The circumscribed circle contains -! the triangle, but it is not necessarily the smallest triangle to do so. -! -! The circumradius of a triangle is the radius of the circumscribed -! circle. - -INTERFACE - MODULE PURE FUNCTION triangle_circumradius_2d(t) RESULT(r) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: r - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: is a line inside the triangle in 3D -! -!# Introduction -! -! A line will "intersect" the plane of a triangle in 3D if -! * the line does not lie in the plane of the triangle -! (there would be infinitely many intersections), AND -! * the line does not lie parallel to the plane of the triangle -! (there are no intersections at all). -! -! Therefore, if a line intersects the plane of a triangle, it does so -! at a single point. We say the line is "inside" the triangle if, -! regarded as 2D objects, the intersection point of the line and the plane -! is inside the triangle. -! -! A triangle in 3D is determined by three points: -! -! T(1:3,1), T(1:3,2) and T(1:3,3). -! -! The explicit form of a line in 3D is: -! -! the line through the points P1(1:3), P2(1:3). -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(3,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) P1(3), P2(3), two points on the line. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if -! (the intersection point of) -! the line is inside the triangle. -! -! Output, REAL ( kind = 8 ) PINT(3), the point where the line -! intersects the plane of the triangle. - -INTERFACE - MODULE PURE SUBROUTINE triangle_contains_line_exp_3d(t, p1, p2, & - & inside, pint) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p1(3) - REAL(DFP), INTENT(IN) :: p2(3) - LOGICAL(LGT), INTENT(OUT) :: inside - REAL(DFP), INTENT(OUT) :: pint(3) - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: finds if a line is inside a triangle in 3D. -! -!# Introduction -! -! A line will "intersect" the plane of a triangle in 3D if -! * the line does not lie in the plane of the triangle -! (there would be infinitely many intersections), AND -! * the line does not lie parallel to the plane of the triangle -! (there are no intersections at all). -! -! Therefore, if a line intersects the plane of a triangle, it does so -! at a single point. We say the line is "inside" the triangle if, -! regarded as 2D objects, the intersection point of the line and the plane -! is inside the triangle. -! -! A triangle in 3D is determined by three points: -! -! T(1:3,1), T(1:3,2) and T(1:3,3). -! -! The parametric form of a line in 3D is: -! -! P(1:3) = P0(1:3) + PD(1:3) * T -! -! We can normalize by requiring PD to have euclidean norm 1, -! and the first nonzero entry positive. -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(3,3), the three points that define -! the triangle. -! -! Input, REAL ( kind = 8 ) P0(3), PD(3), parameters that define the -! parametric line. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if -! (the intersection point of) -! the line is inside the triangle. -! -! Output, REAL ( kind = 8 ) P(3), is the point of intersection of the line -! and the plane of the triangle, unless they are parallel. - -INTERFACE - MODULE PURE SUBROUTINE triangle_contains_line_par_3d(t, p0, pd, inside, p) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p0(3) - REAL(DFP), INTENT(IN) :: pd(3) - REAL(DFP), INTENT(OUT) :: p(3) - LOGICAL(LGT), INTENT(OUT) :: inside - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: finds if a point is inside the triangle in 2D -! -!# Introduction -! -! It is conventional to list the triangle vertices in counter clockwise -! order. However, this routine does not require a particular order -! for the vertices. -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside -! the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_contains_point_2d_1(t, p) RESULT(inside) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(2) - LOGICAL(LGT) :: inside - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: finds if a poiint is inside a triangle in 2D -! -!# Introduction -! -! The routine assumes that the vertices are given in counter clockwise -! order. If the triangle vertices are actually given in clockwise -! order, this routine will behave as though the triangle contains -! no points whatsoever! -! -! The routine determines if a point P is "to the right of" each of the -! lines -! that bound the triangle. It does this by computing the cross product -! of vectors from a vertex to its next vertex, and to P. -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! The vertices should be given in counter clockwise order. -! -! Input, REAL ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is -! inside the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_contains_point_2d_2(t, p) RESULT(inside) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(2) - LOGICAL(LGT) :: inside - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: returns true if the point is contained inside the triangle -! -!# Introduction -! -! This routine is the same as TRIANGLE_CONTAINS_POINT_2D_2, except -! that it does not assume an ordering of the points. It should -! work correctly whether the vertices of the triangle are listed -! in clockwise or counter clockwise order. -! -! The routine determines if a point P is "to the right of" each of the -! lines -! that bound the triangle. It does this by computing the cross product -! of vectors from a vertex to its next vertex, and to P. -! -! The point is inside the triangle if it is to the right of all -! the lines, or to the left of all the lines. -! -! This version was suggested by Paulo Ernesto of Maptek Brasil. -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is -! inside the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_contains_point_2d_3(t, p) RESULT(inside) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(2) - LOGICAL(LGT) :: inside - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: returns the triangle diameter in 2d -! -!# Introduction -! -! The diameter of a triangle is the diameter of the smallest circle -! that can be drawn around the triangle. At least two of the vertices -! of the triangle will intersect the circle, but not necessarily -! all three! -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, REAL ( kind = 8 ) DIAMETER, the diameter of the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_diameter_2d(t) RESULT(diameter) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: diameter - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: returns edge lengths of a triangle in 2D -! -!# Introduction -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, REAL ( kind = 8 ) EDGE_LENGTH(3), the length of the edges. - -INTERFACE - MODULE PURE FUNCTION triangle_edge_length_2d(t) RESULT(edge_length) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: edge_length(3) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Returns grid points within a triangle in 2D -! -!# Introduction -! -! The gridpoints are computed by repeated halving of the triangle. -! The 0-th set of grid points is the vertices themselves. -! The first set of grid points is the midpoints of the sides. -! These points can be used to draw 4 triangles that make up the original -! triangle. The second set of grid points is the side midpoints and -! centers -! of these four triangles. -! -! SUB_NUM GRID_NUM -! ----- ----- -! 0 1 = 1 (centroid) -! 1 1 + 2 = 3 (vertices) -! 2 1 + 2 + 3 = 6 -! 3 1 + 2 + 3 + 4 = 10 -! 4 1 + 2 + 3 + 4 + 5 = 15 -! -! GRID_NUM is the sum of the integers from 1 to SUB_NUM+1 or -! -! GRID_NUM = (SUB_NUM+1) * (SUB_NUM+2) / 2 -! -!# Parameters: -! -!- Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -!- Input, integer ( kind = 4 ) SUB_NUM, the number of subdivisions. -!- Input, integer ( kind = 4 ) GRID_MAX, the maximum number of grid points. -!- Output, integer ( kind = 4 ) GRID_NUM, the number of grid points -! returned. -!- Output, REAL ( kind = 8 ) G(2,GRID_MAX), the grid points. -! - -INTERFACE - MODULE PURE SUBROUTINE triangle_gridpoints_2d(t, sub_num, grid_max, & - & grid_num, g) - REAL(DFP), INTENT(IN) :: t(:, :) - INTEGER(I4B), INTENT(IN) :: sub_num - INTEGER(I4B), INTENT(IN) :: grid_max - INTEGER(I4B), INTENT(OUT) :: grid_num - REAL(DFP), INTENT(OUT) :: g(2, grid_max) - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: computes the incenter of a triangle in 2D. -! -!# Introduction -! -! The incenter of a triangle is the center of the inscribed circle. -! -! The inscribed circle of a triangle is the largest circle that can -! be drawn inside the triangle. -! -! The inscribed circle is tangent to all three sides of the triangle. -! -! The angle bisectors of the triangle intersect at the center of the -! inscribed circle. -! -! In geometry, the incenter is often represented by "I". -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, REAL ( kind = 8 ) PC(2), the incenter. - -INTERFACE - MODULE PURE FUNCTION triangle_incenter_2d(t) RESULT(pc) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: pc(2) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: computes the inscribed circle of a triangle in 2D. -! -!# Introduction -! -! The inscribed circle of a triangle is the largest circle that can -! be drawn inside the triangle. It is tangent to all three sides, -! and the lines from its center to the vertices bisect the angles -! made by each vertex. -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, REAL ( kind = 8 ) R, PC(2), the radius and center of the -! inscribed circle. - -INTERFACE - MODULE PURE SUBROUTINE triangle_incircle_2d(t, r, pc) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(OUT) :: pc(2) - REAL(DFP), INTENT(OUT) :: r - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Radius of the inscribed circle of a triangle in 2D -! -!# Introduction -! -! The inscribed circle of a triangle is the largest circle that can -! be drawn inside the triangle. It is tangent to all three sides, -! and the lines from its center to the vertices bisect the angles -! made by each vertex. -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! Output, REAL ( kind = 8 ) R, the radius of the inscribed circle. - -INTERFACE - MODULE PURE FUNCTION triangle_inradius_2d(t) RESULT(r) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: r - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: finds if a triangle is degenerate in ND. -! -!# Introduction -! -! A triangle in ND is described by the coordinates of its 3 vertices. -! A triangle in ND is degenerate if any two vertices are equal. -! -!# Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! Input, REAL ( kind = 8 ) T(DIM_NUM,3), the triangle vertices. -! Output, logical ( kind = 4 ) TRIANGLE_IS_DEGENERATE_ND, is TRUE if the -! triangle is degenerate. - -INTERFACE - MODULE PURE FUNCTION triangle_is_degenerate_nd(dim_num, t) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: dim_num - REAL(DFP), INTENT(IN) :: t(dim_num, 3) - LOGICAL(LGT) :: ans - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: next triangle lattice layer point. -! -!# Introduction -! -! The triangle lattice layer L is bounded by the lines -! -! 0 <= X, -! 0 <= Y, -! L - 1 < X / C(1) + Y / C(2) <= L. -! -! In particular, layer L = 0 always contains the single point (0,0). -! -! This FUNCTION returns, one at a time, the points that lie within -! a given triangle lattice layer. -! -! Thus, if we set C(1) = 2, C(2) = 3, then we get the following layers: -! -! L = 0: (0,0) -! L = 1: (1,0), (2,0), (0,1), (1,1), (0,2), (0,3) -! L = 2: (3,0), (4,0), (2,1), (3,1), (1,2), (2,2), (1,3), (2,3), -! (0,4), (1,4), (0,5), (0,6). -! -!# Parameters: -! -!- Input, integer ( kind = 4 ) C(3), coefficients defining the -! lattice layer. Entry C(3) contains the layer index. C(1) and C(2) should -! be positive, and C(3) must be nonnegative. -!- Input/output, integer ( kind = 4 ) V(2). On first call for a given layer, -! the input value of V is not important. On a repeated call for the same -! layer, the input value of V should be the output value from the previous -! call. On output, V contains the next lattice layer point. -!- Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to -! indicate that this is the first call for a given layer. Thereafter, the -! input value should be the output value from the previous call. -! On output, MORE is TRUE if the returned value V is a new point. -! If the output value is FALSE, then no more points were found, -! and V was reset to 0, and the lattice layer has been exhausted. - -INTERFACE - MODULE PURE SUBROUTINE triangle_lattice_layer_point_next(c, v, more) - INTEGER(I4B), INTENT(IN) :: c(3) - INTEGER(I4B), INTENT(INOUT) :: v(2) - LOGICAL(LGT), INTENT(INOUT) :: more - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: returns the next triangle lattice point -! -!# Introduction -! -! The lattice triangle is defined by the vertices: -! -! (0,0), (C(3)/C(1), 0) and (0,C(3)/C(2)) -! -! The lattice triangle is bounded by the lines -! -! 0 <= X, -! 0 <= Y -! X / C(1) + Y / C(2) <= C(3) -! -! Lattice points are listed one at a time, starting at the origin, -! with X increasing first. -! -!# Parameters: -! -! Input, integer ( kind = 4 ) C(3), coefficients defining the -! lattice triangle. These should be positive. -! -! Input/output, integer ( kind = 4 ) V(2). On first call, the input -! value is not important. On a repeated call, the input value should -! be the output value from the previous call. On output, V contains -! the next lattice point. -! -! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to -! indicate that this is the first call for a given triangle. Thereafter, -! the input value should be the output value from the previous call. On -! output, MORE is TRUE if the returned value V is a new lattice point. -! If the output value is FALSE, then no more lattice points were found, -! and V was reset to 0, and the routine should not be called further -! for this triangle. - -INTERFACE - MODULE PURE SUBROUTINE triangle_lattice_point_next(c, v, more) - INTEGER(I4B), INTENT(IN) :: c(3) - INTEGER(I4B), INTENT(INOUT) :: v(2) - LOGICAL(LGT), INTENT(INOUT) :: more - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: implicit line intersects a triangle in 2D. -! -!# Introduction -! -! An implicit line is the set of points ( X, Y ) satisfying -! -! A * X + B * Y + C = 0 -! -! where at least one of A and B is not zero. -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) A, B, C, determine the equation of the line: -! A*X + B*Y + C = 0. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of points of -! intersection -! of the line with the triangle. INT_NUM may be 0, 1, 2 or 3. -! -! Output, REAL ( kind = 8 ) PINT(2,3), contains the intersection points. - -INTERFACE - MODULE PURE SUBROUTINE triangle_line_imp_int_2d(t, a, b, c, int_num, pint) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: a, b, c - INTEGER(I4B), INTENT(OUT) :: int_num - INTEGER(I4B), INTENT(OUT) :: pint(2, 3) - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: determines the orientation of a triangle in 2D. -! -!# Introduction -! -! Three distinct non-colinear points in the plane define a circle. -! If the points are visited in the order P1, P2, and then -! P3, this motion defines a clockwise or counter clockwise -! rotation along the circle. -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, integer ( kind = 4 ) TRIANGLE_ORIENTATION_2D, reports if the -! three points lie clockwise on the circle that passes through them. -! The possible return values are: -! 0, the points are distinct, noncolinear, and lie counter clockwise -! on their circle. -! 1, the points are distinct, noncolinear, and lie clockwise -! on their circle. -! 2, the points are distinct and colinear. -! 3, at least two of the points are identical. - -INTERFACE - MODULE PURE FUNCTION triangle_orientation_2d(t) RESULT(ans) - REAL(DFP), INTENT(IN) :: t(:, :) - INTEGER(I4B) :: ans - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: computes the orthocenter of a triangle in 2D. -! -!# Introduction -! -! The orthocenter is defined as the intersection of the three altitudes -! of a triangle. -! -! An altitude of a triangle is the line through a vertex of the triangle -! and perpENDicular to the opposite side. -! -! In geometry, the orthocenter of a triangle is often symbolized by "H". -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, REAL ( kind = 8 ) PC(2), the orthocenter of the triangle. -! -! Output, logical ( kind = 4 ) FLAG, is TRUE if the value could not -! be computed. - -INTERFACE - MODULE PURE FUNCTION triangle_orthocenter_2d(t) RESULT(pc) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: pc(2) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: distance ( triangle, point ) in 2D -! -!# Introduction -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) P(2), the point to be checked. -! -! Output, REAL ( kind = 8 ) DIST, the distance from the point to the -! triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_point_dist_2d(t, p) RESULT(dist) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(:) - REAL(DFP) :: dist - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: distance ( triangle, point ) in 3D. -! -!# Introduction -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(3,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) P(3), the point which is to be checked. -! -! Output, REAL ( kind = 8 ) DIST, the distance from the point to the -! triangle. DIST is zero if the point lies exactly on the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_point_dist_3d(t, p) RESULT(dist) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(:) - REAL(DFP) :: dist - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: signed distance in 2D -! -!# Introduction -! -! If the signed distance is: -! 0, the point is on the boundary of the triangle; -! negative, the point is in the triangle; -! positive, the point is outside the triangle. -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! These should be given in counter clockwise order. -! -! Input, REAL ( kind = 8 ) P(2), the point which is to be checked. -! -! Output, REAL ( kind = 8 ) DIST_SIGNED, the signed distance from the -! point to the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_point_dist_signed_2d(t, p) RESULT(dist_signed) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(2) - REAL(DFP) :: dist_signed - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: computes the nearest point on a triangle in 2D. -! -!# Introduction -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) P(2), the point whose nearest triangle point -! is to be determined. -! -! Output, REAL ( kind = 8 ) PN(2), the nearest point to P. -! -! Output, REAL ( kind = 8 ) DIST, the distance from the point to the -! triangle. - -INTERFACE - MODULE PURE SUBROUTINE triangle_point_near_2d(t, p, pn, dist) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(2) - REAL(DFP), INTENT(OUT) :: pn(2) - REAL(DFP), INTENT(OUT) :: dist - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: "quality" of a triangle in 2D. -! -!# Introduction -! -! The quality of a triangle is 2.0 times the ratio of the radius of -! the inscribed circle divided by that of the circumscribed circle. -! An equilateral triangle achieves the maximum possible quality of 1. -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! Output, REAL ( kind = 8 ) QUALITY, the quality of the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_quality_2d(t) RESULT(quality) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP) :: quality - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: count lattice points. -! -!# Introduction -! -! The triangle is assumed to be a right triangle which, without loss -! of generality, has the coordinates: -! -! ( (0,0), (a,0), (0,b) ) -! -! The routine returns the number of integer lattice points that appear -! inside the triangle or on its edges or vertices. -! -! The formula for this FUNCTION occurred to me (JVB) after some thought, -! on 06 July 2009. -! -! Parameters: -! -! Input, integer ( kind = 4 ) A, B, define the vertices. -! -! Output, integer ( kind = 4 ) N, the number of lattice points. - -INTERFACE - MODULE PURE FUNCTION triangle_right_lattice_point_num_2d(a, b) RESULT(n) - INTEGER(I4B), INTENT(IN) :: a - INTEGER(I4B), INTENT(IN) :: b - INTEGER(I4B) :: n - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: returns random points in a triangle. -! -!# Introduction -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, integer ( kind = 4 ) N, the number of points to generate. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, REAL ( kind = 8 ) P(2,N), random points in the triangle. - -INTERFACE - MODULE PURE FUNCTION triangle_sample(t, n, seed) RESULT(p) - REAL(DFP), INTENT(IN) :: t(:, :) - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), INTENT(IN) :: seed - REAL(DFP) :: p(2, n) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: count lattice points. -! -!# Introduction -! -! The triangle is assumed to be the unit triangle: -! -!$$ -! ( (0,0), (1,0), (0,1) ) -!$$ -! -! or a copy of this triangle scaled by an integer S: -! -!$$ -! ( (0,0), (S,0), (0,S) ). -!$$ -! -! The routine returns the number of integer lattice points that appear -! inside the triangle or on its edges or vertices. -! -! Parameters: -! -! Input, integer ( kind = 4 ) S, the scale factor. -! -! Output, integer ( kind = 4 ) N, the number of lattice points. -! - -INTERFACE - MODULE PURE FUNCTION triangle01_lattice_point_num_2d(s) RESULT(n) - INTEGER(I4B), INTENT(IN) :: s - INTEGER(I4B) :: n - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: converts from barycentric to XY coordinates in 2D. -! -!# Introduction -! -! Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) XSI(3), the barycentric coordinates of a point. -! XSI(1) + XSI(2) + XSI(3) should equal 1, but this is not checked. -! -! Output, REAL ( kind = 8 ) P(2), the XY coordinates of the point. -! - -INTERFACE - MODULE PURE FUNCTION triangle_xsi_to_xy_2d(t, xsi) RESULT(p) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: xsi(3) - REAL(DFP) :: p(2) - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: converts from XY to barycentric in 2D. -! -!# Introduction -! -!# Parameters: -! -! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, REAL ( kind = 8 ) P(2), the XY coordinates of a point. -! -! Output, REAL ( kind = 8 ) XSI(3), the barycentric coordinates of the -! point. -! XSI1 + XSI2 + XSI3 should equal 1. -! - -INTERFACE - MODULE PURE FUNCTION triangle_xy_to_xsi_2d(t, p) RESULT(xsi) - REAL(DFP), INTENT(IN) :: t(:, :) - REAL(DFP), INTENT(IN) :: p(2) - REAL(DFP) :: xsi(3) - END FUNCTION -END INTERFACE - -END MODULE Triangle_Method diff --git a/src/modules/Geometry/src/assets/geometry_burkardt_line.inc b/src/modules/Geometry/src/assets/geometry_burkardt_line.inc deleted file mode 100644 index 8bb9bb53a..000000000 --- a/src/modules/Geometry/src/assets/geometry_burkardt_line.inc +++ /dev/null @@ -1,2991 +0,0 @@ -function line_exp_is_degenerate_nd(dim_num, p1, p2) - -!*****************************************************************************80 -! -!! LINE_EXP_IS_DEGENERATE_ND finds if an explicit line is degenerate in ND. -! -! Discussion: -! -! 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. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4) dim_num - - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - line_exp_is_degenerate_nd = (all(p1(1:dim_num) == p2(1:dim_num))) - - return -end -subroutine line_exp_normal_2d(p1, p2, normal) - -!*****************************************************************************80 -! -!! LINE_EXP_NORMAL_2D computes a unit normal vector to a line in 2D. -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The sign of the normal vector N is chosen so that the normal vector -! points "to the left" of the direction of the line. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two distinct points on the line. -! -! Output, real ( kind = 8 ) NORMAL(2), a unit normal vector to the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) norm - real(kind=8) normal(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - normal(1:dim_num) = sqrt(2.0D+00) - return - end if - - norm = sqrt((p2(1) - p1(1))**2 + (p2(2) - p1(2))**2) - - normal(1) = -(p2(2) - p1(2)) / norm - normal(2) = (p2(1) - p1(1)) / norm - - return -end -subroutine line_exp_perp_2d(p1, p2, p3, p4, flag) - -!*****************************************************************************80 -! -!! LINE_EXP_PERP_2D computes a line perpendicular to a line and through a point. -! -! Discussion: -! -! 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. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 31 July 2009 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) bot - logical(kind=4) flag - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - real(kind=8) r8_huge - 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)) - - return -end -subroutine line_exp_point_dist_2d(p1, p2, p, dist) - -!*****************************************************************************80 -! -!! LINE_EXP_POINT_DIST_2D: distance ( explicit line, point ) in 2D. -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! -! Input, real ( kind = 8 ) P(2), the point whose distance from the line is -! to be measured. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) bot - real(kind=8) dist - real(kind=8) dot - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) t - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - - pn(1:dim_num) = p1(1:dim_num) -! -! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). -! -! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T -! of the projection of (P-P1) onto (P2-P1). -! - else - - dot = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) - - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - - t = dot / bot - - pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) - - end if - - dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - - return -end -subroutine line_exp_point_dist_3d(p1, p2, p, dist) - -!*****************************************************************************80 -! -!! LINE_EXP_POINT_DIST_3D: distance ( explicit line, point ) in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. -! -! Input, real ( kind = 8 ) P(3), the point whose distance from the line is -! to be measured. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) bot - real(kind=8) dist - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) t - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - - pn(1:dim_num) = p1(1:dim_num) -! -! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). -! -! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T -! of the projection of (P-P1) onto (P2-P1). -! - 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 - - pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) - - end if -! -! Now compute the distance between the projection point and P. -! - dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - - return -end -subroutine line_exp_point_dist_signed_2d(p1, p2, p, dist_signed) - -!*****************************************************************************80 -! -!! LINE_EXP_POINT_DIST_SIGNED_2D: signed distance ( exp line, point ) in 2D. -! -! 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). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) dist_signed - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) -! -! 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 - - return -end -subroutine line_exp_point_near_2d(p1, p2, p, pn, dist, t) - -!*****************************************************************************80 -! -!! LINE_EXP_POINT_NEAR_2D: point on an explicit line nearest a point in 2D. -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The nearest point PN = (XN,YN) has the form: -! -! PN = (1-T) * P1 + T * P2. -! -! If T is less than 0, PN is furthest from P2. -! If T is between 0 and 1, PN is between P1 and P2. -! If T is greater than 1, PN is furthest from P1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! -! Input, real ( kind = 8 ) P(2), the point whose nearest neighbor on the -! line is to be determined. -! -! Output, real ( kind = 8 ) PN(2), the nearest point on the line to P. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the line. -! -! Output, real ( kind = 8 ) T, the relative position of the point -! PN to the points P1 and P2. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) bot - real(kind=8) dist - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) t - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_POINT_NEAR_2D - Fatal error!' - write (*, '(a)') ' The line is degenerate.' - stop 1 - end if -! -! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). -! -! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T -! of the projection of (P-P1) onto (P2-P1). -! - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - - t = sum((p1(1:dim_num) - p(1:dim_num)) & - * (p1(1:dim_num) - p2(1:dim_num))) / bot - - pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) - - dist = sqrt(sum((pn(1:dim_num) - p(1:dim_num))**2)) - - return -end -subroutine line_exp_point_near_3d(p1, p2, p, pn, dist, t) - -!*****************************************************************************80 -! -!! LINE_EXP_POINT_NEAR_3D: nearest point on explicit line to point in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! The nearest point PN has the form: -! -! PN = ( 1 - T ) * P1 + T * P2. -! -! If T is less than 0, PN is furthest away from P2. -! If T is between 0 and 1, PN is between P1 and P2. -! If T is greater than 1, PN is furthest away from P1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. -! -! Input, real ( kind = 8 ) P(3), the point whose nearest neighbor on -! the line is to be determined. -! -! Output, real ( kind = 8 ) PN(3), the point which is the nearest -! point on the line to P. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! nearest point on the line. -! -! Output, real ( kind = 8 ) T, the relative position of the point -! PN to P1 and P2. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) bot - real(kind=8) dist - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) t - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_EXP_POINT_NEAR_3D - Fatal error!' - write (*, '(a)') ' The line is degenerate.' - stop 1 - end if -! -! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). -! -! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T -! of the projection of (P-P1) onto (P2-P1). -! - 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 -! -! Now compute the location of the projection point. -! - pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -! -! Now compute the distance between the projection point and P. -! - dist = sqrt(sum((pn(1:dim_num) - p(1:dim_num))**2)) - - return -end -subroutine line_exp2imp_2d(p1, p2, a, b, c) - -!*****************************************************************************80 -! -!! LINE_EXP2IMP_2D converts an explicit line to implicit form in 2D. -! -! Discussion: -! -! 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 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) norm - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) -! -! Take care of degenerate cases. -! - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_EXP2IMP_2D - Warning!' - write (*, '(a)') ' The line is degenerate.' - 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 - - return -end -subroutine line_exp2par_2d(p1, p2, f, g, x0, y0) - -!*****************************************************************************80 -! -!! LINE_EXP2PAR_2D converts a line from explicit to parametric form in 2D. -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F^2 + G^2 = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! -! Output, real ( kind = 8 ) F, G, X0, Y0, the parametric parameters -! of the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) f - real(kind=8) g - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) norm - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) x0 - real(kind=8) y0 - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_EXP2PAR_2D - Warning!' - write (*, '(a)') ' The line is degenerate.' - end if - - x0 = p1(1) - y0 = p1(2) - - f = p2(1) - p1(1) - g = p2(2) - p1(2) - - norm = sqrt(f * f + g * g) - - if (norm /= 0.0D+00) then - f = f / norm - g = g / norm - end if - - if (f < 0.0D+00) then - f = -f - g = -g - end if - - return -end -subroutine line_exp2par_3d(p1, p2, f, g, h, x0, y0, z0) - -!*****************************************************************************80 -! -!! LINE_EXP2PAR_3D converts a line from explicit to parametric form in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! The parametric form of a line in 3D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! Z = Z0 + H * T -! -! We normalize by always choosing F^2 + G^2 + H^2 = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. -! -! Output, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric parameters -! of the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) f - real(kind=8) g - real(kind=8) h - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) norm - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) x0 - real(kind=8) y0 - real(kind=8) z0 - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_EXP2PAR_3D - Warning!' - write (*, '(a)') ' The line is degenerate.' - end if - - x0 = p1(1) - y0 = p1(2) - z0 = p1(3) - - f = p2(1) - p1(1) - g = p2(2) - p1(2) - h = p2(3) - p1(3) - - norm = sqrt(f * f + g * g + h * h) - - if (norm /= 0.0D+00) then - f = f / norm - g = g / norm - h = h / norm - end if - - if (f < 0.0D+00) then - f = -f - g = -g - h = -h - end if - - return -end -function line_imp_is_degenerate_2d(a, b, c) - -!*****************************************************************************80 -! -!! LINE_IMP_IS_DEGENERATE_2D finds if an implicit point is degenerate in 2D. -! -! Discussion: -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - logical(kind=4) line_imp_is_degenerate_2d - - line_imp_is_degenerate_2d = (a * a + b * b == 0.0D+00) - - return -end -subroutine line_imp_point_dist_2d(a, b, c, p, dist) - -!*****************************************************************************80 -! -!! LINE_IMP_POINT_DIST_2D: distance ( implicit line, point ) in 2D. -! -! Discussion: -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. -! -! Input, real ( kind = 8 ) P(2), the point whose distance from the line is -! to be measured. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) dist - logical(kind=4) line_imp_is_degenerate_2d - real(kind=8) p(dim_num) - - if (line_imp_is_degenerate_2d(a, b, c)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_IMP_POINT_DIST_2D - Fatal error!' - write (*, '(a)') ' The line is degenerate.' - stop 1 - end if - - dist = abs(a * p(1) + b * p(2) + c) / sqrt(a * a + b * b) - - return -end -subroutine line_imp_point_dist_signed_2d(a, b, c, p, dist_signed) - -!*****************************************************************************80 -! -!! LINE_IMP_POINT_DIST_SIGNED_2D: signed distance ( imp line, point ) in 2D. -! -! Discussion: -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. -! -! Input, real ( kind = 8 ) P(2), the coordinates of the point. -! -! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the -! point to the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) dist_signed - logical(kind=4) line_imp_is_degenerate_2d - real(kind=8) p(dim_num) - - if (line_imp_is_degenerate_2d(a, b, c)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_IMP_POINT_DIST_SIGNED_2D - Fatal error!' - write (*, '(a)') ' The line is degenerate.' - stop 1 - end if - - dist_signed = -sign(1.0D+00, c) * (a * p(1) + b * p(2) + c) / & - sqrt(a * a + b * b) - - return -end -subroutine line_imp2exp_2d(a, b, c, p1, p2) - -!*****************************************************************************80 -! -!! LINE_IMP2EXP_2D converts an implicit line to explicit form in 2D. -! -! Discussion: -! -! The implicit form of line in 2D is: -! -! A * X + B * Y + C = 0 -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. -! -! Output, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - logical(kind=4) line_imp_is_degenerate_2d - real(kind=8) normsq - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - if (line_imp_is_degenerate_2d(a, b, c)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_IMP2EXP_2D - Fatal error!' - write (*, '(a)') ' The line is degenerate.' - stop 1 - end if - - normsq = a * a + b * b - - p1(1) = -a * c / normsq - p1(2) = -b * c / normsq - - if (abs(b) < abs(a)) then - p2(1) = -(a - b / a) * c / normsq - p2(2) = -(b + 1.0D+00) * c / normsq - else - p2(1) = -(a + 1.0D+00) * c / normsq - p2(2) = -(b - a / b) * c / normsq - end if - - return -end -subroutine line_imp2par_2d(a, b, c, f, g, x0, y0) - -!*****************************************************************************80 -! -!! LINE_IMP2PAR_2D converts an implicit line to parametric form in 2D. -! -! Discussion: -! -! The implicit form of line in 2D is: -! -! A * X + B * Y + C = 0 -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We may normalize by choosing F*F + G*G = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 January 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. -! -! Output, real ( kind = 8 ) F, G, X0, Y0, the parametric parameters of -! the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) f - logical(kind=4) line_imp_is_degenerate_2d - real(kind=8) g - real(kind=8) x0 - real(kind=8) y0 - - if (line_imp_is_degenerate_2d(a, b, c)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINE_IMP2PAR_2D - Fatal error!' - write (*, '(a)') ' The line is degenerate.' - stop 1 - end if - - x0 = -a * c / (a * a + b * b) - y0 = -b * c / (a * a + b * b) - - f = b / sqrt(a * a + b * b) - g = -a / sqrt(a * a + b * b) - - if (f < 0.0D+00) then - f = -f - g = -g - end if - - return -end -subroutine line_par_point_dist_2d(f, g, x0, y0, p, dist) - -!*****************************************************************************80 -! -!! LINE_PAR_POINT_DIST_2D: distance ( parametric line, point ) in 2D. -! -! Discussion: -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F*F + G*G = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. -! -! Input, real ( kind = 8 ) P(2), the point whose distance from the line is -! to be measured. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) dx - real(kind=8) dy - real(kind=8) f - real(kind=8) g - real(kind=8) p(dim_num) - real(kind=8) x0 - real(kind=8) y0 - - dx = g * g * (p(1) - x0) - f * g * (p(2) - y0) - dy = -f * g * (p(1) - x0) + f * f * (p(2) - y0) - - dist = sqrt(dx * dx + dy * dy) / (f * f + g * g) - - return -end -subroutine line_par_point_dist_3d(f, g, h, x0, y0, z0, p, dist) - -!*****************************************************************************80 -! -!! LINE_PAR_POINT_DIST_3D: distance ( parametric line, point ) in 3D. -! -! Discussion: -! -! The parametric form of a line in 3D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! Z = Z0 + H * T -! -! We normalize by always choosing F*F + G*G + H*H = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric line -! parameters. -! -! Input, real ( kind = 8 ) P(3), the point whose distance from the line is -! to be measured. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dist - real(kind=8) dx - real(kind=8) dy - real(kind=8) dz - real(kind=8) f - real(kind=8) g - real(kind=8) h - real(kind=8) p(dim_num) - real(kind=8) x0 - real(kind=8) y0 - real(kind=8) z0 - - dx = g * (f * (p(2) - y0) - g * (p(1) - x0)) & - + h * (f * (p(3) - z0) - h * (p(1) - x0)) - - dy = h * (g * (p(3) - z0) - h * (p(2) - y0)) & - - f * (f * (p(2) - y0) - g * (p(1) - x0)) - - dz = -f * (f * (p(3) - z0) - h * (p(1) - x0)) & - - g * (g * (p(3) - z0) - h * (p(2) - y0)) - - dist = sqrt(dx * dx + dy * dy + dz * dz) & - / (f * f + g * g + h * h) - - return -end -subroutine line_par_point_near_2d(f, g, x0, y0, p, pn) - -!*****************************************************************************80 -! -!! LINE_PAR_POINT_NEAR_2D: nearest point on parametric line to given point, 2D. -! -! Discussion: -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We may normalize by choosing F*F + G*G = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 April 2013 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. -! -! Input, real ( kind = 8 ) P(2), the point whose distance from the line is -! to be measured. -! -! Output, real ( kind = 8 ) PN(2), the point on the parametric line which -! is nearest to P. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) f - real(kind=8) g - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) t - real(kind=8) x0 - real(kind=8) y0 - - t = (f * (p(1) - x0) + g * (p(2) - y0)) / (f * f + g * g) - - pn(1) = x0 + t * f - pn(2) = y0 + t * g - - return -end -subroutine line_par_point_near_3d(f, g, h, x0, y0, z0, p, pn) - -!*****************************************************************************80 -! -!! LINE_PAR_POINT_NEAR_3D: nearest point on parametric line to given point, 3D. -! -! Discussion: -! -! The parametric form of a line in 3D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! Z = Z0 + H * T -! -! We may normalize by choosing F*F + G*G + H*H = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 April 2013 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric -! line parameters. -! -! Input, real ( kind = 8 ) P(3), the point whose distance from the line is -! to be measured. -! -! Output, real ( kind = 8 ) PN(3), the point on the parametric line which -! is nearest to P. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) f - real(kind=8) g - real(kind=8) h - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) t - real(kind=8) x0 - real(kind=8) y0 - real(kind=8) z0 - - t = (f * (p(1) - x0) + g * (p(2) - y0) + h * (p(3) - z0)) & - / (f * f + g * g + h * h) - - pn(1) = x0 + t * f - pn(2) = y0 + t * g - pn(3) = z0 + t * h - - return -end -subroutine line_par2exp_2d(f, g, x0, y0, p1, p2) - -!*****************************************************************************80 -! -!! LINE_PAR2EXP_2D converts a parametric line to explicit form in 2D. -! -! Discussion: -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F*F + G*G = 1, and F nonnegative. -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. -! -! Output, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) f - real(kind=8) g - real(kind=8) x0 - real(kind=8) y0 - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - p1(1) = x0 - p1(2) = y0 - - p2(1) = p1(1) + f - p2(2) = p1(2) + g - - return -end -subroutine line_par2exp_3d(f, g, h, x0, y0, z0, p1, p2) - -!*****************************************************************************80 -! -!! LINE_PAR2EXP_3D converts a parametric line to explicit form in 3D. -! -! Discussion: -! -! The parametric form of a line in 3D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! Z = Z0 + H * T -! -! We may normalize by choosing F*F + G*G + H*H = 1, and F nonnegative. -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 13 April 2013 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric -! line parameters. -! -! Output, real ( kind = 8 ) P1(3), P2(3), two points on the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) f - real(kind=8) g - real(kind=8) h - real(kind=8) x0 - real(kind=8) y0 - real(kind=8) z0 - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - p1(1) = x0 - p1(2) = y0 - p1(3) = z0 - - p2(1) = p1(1) + f - p2(2) = p1(2) + g - p2(3) = p1(3) + h - - return -end -subroutine line_par2imp_2d(f, g, x0, y0, a, b, c) - -!*****************************************************************************80 -! -!! LINE_PAR2IMP_2D converts a parametric line to implicit form in 2D. -! -! Discussion: -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F*F + G*G = 1, and F nonnegative. -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 January 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. -! -! Output, real ( kind = 8 ) A, B, C, the implicit line parameters. -! - implicit none - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) f - real(kind=8) g - real(kind=8) x0 - real(kind=8) y0 - - a = -g - b = f - c = g * x0 - f * y0 - - return -end -subroutine lines_exp_angle_3d(p1, p2, q1, q2, angle) - -!*****************************************************************************80 -! -!! LINES_EXP_ANGLE_3D finds the angle between two explicit lines in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. -! -! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. -! -! Output, real ( kind = 8 ) ANGLE, the angle in radians between the two -! lines. The angle is computed using the ACOS function, and so lies between -! 0 and PI. But if one of the lines is degenerate, the angle is -! returned as -1.0. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) angle - real(kind=8) ctheta - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pdotq - real(kind=8) pnorm - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) qnorm - real(kind=8) r8_acos - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then -! write ( *, '(a)' ) ' ' -! write ( *, '(a)' ) 'LINES_EXP_ANGLE_3D - Fatal error!' -! write ( *, '(a)' ) ' The line (P1,P2) is degenerate!' - angle = -1.0D+00 - return - end if - - if (line_exp_is_degenerate_nd(dim_num, q1, q2)) then -! write ( *, '(a)' ) ' ' -! write ( *, '(a)' ) 'LINES_EXP_ANGLE_3D - Warning!' -! write ( *, '(a)' ) ' The line (Q1,Q2) is degenerate!' - angle = -1.0D+00 - return - end if - - pnorm = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) - - qnorm = sqrt(sum((q2(1:dim_num) - q1(1:dim_num))**2)) - - pdotq = sum((p2(1:dim_num) - p1(1:dim_num)) & - * (q2(1:dim_num) - q1(1:dim_num))) - - ctheta = pdotq / (pnorm * qnorm) - - angle = r8_acos(ctheta) - - return -end -subroutine lines_exp_angle_nd(dim_num, p1, p2, q1, q2, angle) - -!*****************************************************************************80 -! -!! LINES_EXP_ANGLE_ND returns the angle between two explicit lines in ND. -! -! Discussion: -! -! The explicit form of a line in ND is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), two points -! on the first line. -! -! Input, real ( kind = 8 ) Q1(DIM_NUM), Q2(DIM_NUM), two points -! on the second line. -! -! Output, real ( kind = 8 ) ANGLE, the angle in radians between the two -! lines. The angle is computed using the ACOS function, and so lies -! between 0 and PI. But if one of the lines is degenerate, the angle -! is returned as -1.0. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) angle - real(kind=8) ctheta - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pdotq - real(kind=8) pnorm - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) qnorm - real(kind=8) r8_acos - - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINES_EXP_ANGLE_3D - Fatal error!' - write (*, '(a)') ' The line (P1,P2) is degenerate!' - angle = -1.0D+00 - stop 1 - end if - - if (line_exp_is_degenerate_nd(dim_num, q1, q2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINES_EXP_ANGLE_3D - Fatal error!' - write (*, '(a)') ' The line (Q1,Q2) is degenerate!' - angle = -1.0D+00 - stop 1 - end if - - pnorm = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) - qnorm = sqrt(sum((q2(1:dim_num) - q1(1:dim_num))**2)) - - pdotq = sum((p2(1:dim_num) - p1(1:dim_num)) & - * (q2(1:dim_num) - q1(1:dim_num))) - - ctheta = pdotq / (pnorm * qnorm) - angle = r8_acos(ctheta) - - return -end -subroutine lines_exp_dist_3d(p1, p2, q1, q2, dist) - -!*****************************************************************************80 -! -!! LINES_EXP_DIST_3D computes the distance between two explicit lines in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. -! -! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. -! -! Output, real ( kind = 8 ) DIST, the distance between the lines. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a11 - real(kind=8) a12 - real(kind=8) a13 - real(kind=8) a21 - real(kind=8) a22 - real(kind=8) a23 - real(kind=8) a31 - real(kind=8) a32 - real(kind=8) a33 - real(kind=8) bot - real(kind=8) cr1 - real(kind=8) cr2 - real(kind=8) cr3 - real(kind=8) dist - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) top -! -! The distance is found by computing the volume of a parallelipiped, -! and dividing by the area of its base. -! -! But if the lines are parallel, we compute the distance by -! finding the distance between the first line and any point -! on the second line. -! - a11 = q1(1) - p1(1) - a12 = q1(2) - p1(2) - a13 = q1(3) - p1(3) - - a21 = p2(1) - p1(1) - a22 = p2(2) - p1(2) - a23 = p2(3) - p1(3) - - a31 = q2(1) - q1(1) - a32 = q2(2) - q1(2) - a33 = q2(3) - q1(3) -! -! Compute the cross product. -! - cr1 = a22 * a33 - a23 * a32 - cr2 = a23 * a31 - a21 * a33 - cr3 = a21 * a32 - a22 * a31 - - bot = sqrt(cr1 * cr1 + cr2 * cr2 + cr3 * cr3) - - if (bot == 0.0D+00) then - - call line_exp_point_dist_3d(p1, p2, q1, dist) - - else - - top = abs(a11 * (a22 * a33 - a23 * a32) & - - a12 * (a21 * a33 - a23 * a31) & - + a13 * (a21 * a32 - a22 * a31)) - - dist = top / bot - - end if - - return -end -subroutine lines_exp_dist_3d_2(p1, p2, q1, q2, dist) - -!*****************************************************************************80 -! -!! LINES_EXP_DIST_3D_2 computes the distance between two explicit lines in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! This routine uses a method that is essentially independent of dimension. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 August 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. -! -! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. -! -! Output, real ( kind = 8 ) DIST, the distance between the lines. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) det - real(kind=8) dist - real(kind=8) e - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) qn(dim_num) - real(kind=8) sn - real(kind=8) tn - real(kind=8) u(dim_num) - real(kind=8) v(dim_num) - real(kind=8) w0(dim_num) -! -! Let U = (P2-P1) and V = (Q2-Q1) be the direction vectors on -! the two lines. -! - u(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - v(1:dim_num) = q2(1:dim_num) - q1(1:dim_num) -! -! Let SN be the unknown coordinate of the nearest point PN on line 1, -! so that PN = P(SN) = P1 + SN * (P2-P1). -! -! Let TN be the unknown coordinate of the nearest point QN on line 2, -! so that QN = Q(TN) = Q1 + TN * (Q2-Q1). -! -! Let W0 = (P1-Q1). -! - w0(1:dim_num) = p1(1:dim_num) - q1(1:dim_num) -! -! The vector direction WC = P(SN) - Q(TC) is unique (among directions) -! perpendicular to both U and V, so -! -! U dot WC = 0 -! V dot WC = 0 -! -! or, equivalently: -! -! U dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 -! V dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 -! -! or, equivalently: -! -! (u dot u ) * sn - (u dot v ) tc = -u * w0 -! (v dot u ) * sn - (v dot v ) tc = -v * w0 -! -! or, equivalently: -! -! ( a -b ) * ( sn ) = ( -d ) -! ( b -c ) ( tc ) ( -e ) -! - a = dot_product(u, u) - b = dot_product(u, v) - c = dot_product(v, v) - d = dot_product(u, w0) - e = dot_product(v, w0) -! -! Check the determinant. -! - det = -a * c + b * b - - if (det == 0.0D+00) then - sn = 0.0D+00 - if (abs(b) < abs(c)) then - tn = e / c - else - tn = d / b - end if - else - sn = (c * d - b * e) / det - tn = (b * d - a * e) / det - end if - - pn(1:dim_num) = p1(1:dim_num) + sn * (p2(1:dim_num) - p1(1:dim_num)) - qn(1:dim_num) = q1(1:dim_num) + tn * (q2(1:dim_num) - q1(1:dim_num)) - - dist = sqrt(sum((pn(1:dim_num) - qn(1:dim_num))**2)) - - return -end -function lines_exp_equal_2d(p1, p2, q1, q2) - -!*****************************************************************************80 -! -!! LINES_EXP_EQUAL_2D determines if two explicit lines are equal in 2D. -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! It is essentially impossible to accurately determine whether two -! explicit lines are equal in 2D. However, for form's sake, and -! because occasionally the correct result can be determined, we -! provide this routine. Since divisions are avoided, if the -! input data is exactly representable, the result should be -! correct. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 July 2006 -! -! Author: -! -! John Burkardt -! -! 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, logical ( kind = 4 ) LINES_EXP_EQUAL_2D, is TRUE if the two lines -! are determined to be identical. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) lines_exp_equal_2d - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) q1(2) - real(kind=8) q2(2) - real(kind=8) test1 - real(kind=8) test2 - real(kind=8) test3 - real(kind=8) test4 -! -! Slope (P1,P2) = Slope (P2,Q1). -! - test1 = (p2(2) - p1(2)) * (q1(1) - p2(1)) & - - (p2(1) - p1(1)) * (q1(2) - p2(2)) - - if (test1 /= 0.0D+00) then - lines_exp_equal_2d = .false. - return - end if -! -! Slope (Q1,Q2) = Slope (P2,Q1). -! - test2 = (q2(2) - q1(2)) * (q1(1) - p2(1)) & - - (q2(1) - q1(1)) * (q1(2) - p2(2)) - - if (test2 /= 0.0D+00) then - lines_exp_equal_2d = .false. - return - end if -! -! Slope (P1,P2) = Slope (P1,Q2). -! - test3 = (p2(2) - p1(2)) * (q2(1) - p1(1)) & - - (p2(1) - p1(1)) * (q2(2) - p1(2)) - - if (test3 /= 0.0D+00) then - lines_exp_equal_2d = .false. - return - end if -! -! Slope (Q1,Q2) = Slope (P1,Q2). -! - test4 = (q2(2) - q1(2)) * (q2(1) - p1(1)) & - - (q2(1) - q1(1)) * (q2(2) - p1(2)) - - if (test4 /= 0.0D+00) then - lines_exp_equal_2d = .false. - return - end if - - lines_exp_equal_2d = .true. - - return -end -subroutine lines_exp_int_2d(p1, p2, q1, q2, ival, p) - -!*****************************************************************************80 -! -!! LINES_EXP_INT_2D determines where two explicit lines intersect in 2D. -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - 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 - integer(kind=4) ival - logical(kind=4) point_1 - logical(kind=4) point_2 - real(kind=8) p(2) - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) q1(2) - real(kind=8) q2(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 - - return -end -subroutine lines_exp_near_3d(p1, p2, q1, q2, pn, qn) - -!*****************************************************************************80 -! -!! LINES_EXP_NEAR_3D computes the nearest points on two explicit lines in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! This routine uses a method that is essentially independent of dimension. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 August 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. -! -! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. -! -! Output, real ( kind = 8 ) PN(3), QN(3), the points on the first and -! second lines that are nearest. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) det - real(kind=8) e - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) qn(dim_num) - real(kind=8) sn - real(kind=8) tn - real(kind=8) u(dim_num) - real(kind=8) v(dim_num) - real(kind=8) w0(dim_num) -! -! Let U = (P2-P1) and V = (Q2-Q1) be the direction vectors on -! the two lines. -! - u(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - v(1:dim_num) = q2(1:dim_num) - q1(1:dim_num) -! -! Let SN be the unknown coordinate of the nearest point PN on line 1, -! so that PN = P(SN) = P1 + SN * (P2-P1). -! -! Let TN be the unknown coordinate of the nearest point QN on line 2, -! so that QN = Q(TN) = Q1 + TN * (Q2-Q1). -! -! Let W0 = (P1-Q1). -! - w0(1:dim_num) = p1(1:dim_num) - q1(1:dim_num) -! -! The vector direction WC = P(SN) - Q(TC) is unique (among directions) -! perpendicular to both U and V, so -! -! U dot WC = 0 -! V dot WC = 0 -! -! or, equivalently: -! -! U dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 -! V dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 -! -! or, equivalently: -! -! (u dot u ) * sn - (u dot v ) tc = -u * w0 -! (v dot u ) * sn - (v dot v ) tc = -v * w0 -! -! or, equivalently: -! -! ( a -b ) * ( sn ) = ( -d ) -! ( b -c ) ( tc ) ( -e ) -! - a = dot_product(u, u) - b = dot_product(u, v) - c = dot_product(v, v) - d = dot_product(u, w0) - e = dot_product(v, w0) -! -! Check the determinant. -! - det = -a * c + b * b - - if (det == 0.0D+00) then - sn = 0.0D+00 - if (abs(b) < abs(c)) then - tn = e / c - else - tn = d / b - end if - else - sn = (c * d - b * e) / det - tn = (b * d - a * e) / det - end if - - pn(1:dim_num) = p1(1:dim_num) + sn * (p2(1:dim_num) - p1(1:dim_num)) - qn(1:dim_num) = q1(1:dim_num) + tn * (q2(1:dim_num) - q1(1:dim_num)) - - return -end -function lines_exp_parallel_2d(p1, p2, q1, q2) - -!*****************************************************************************80 -! -!! LINES_EXP_PARALLEL_2D determines if two lines are parallel in 2D. -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The test is essentially a comparison of slopes, but should be -! more accurate than an explicit slope comparison, and unfazed -! by degenerate cases. -! -! On the other hand, there is NO tolerance for error. If the -! slopes differ by a single digit in the last place, then the -! lines are judged to be nonparallel. A more robust test would -! be to compute the angle between the lines, because then it makes -! sense to say the lines are "almost" parallel: the angle is small. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! 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, logical ( kind = 4 ) LINES_EXP_PARALLEL_2D is TRUE if the -! lines are parallel. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) lines_exp_parallel_2d - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - - lines_exp_parallel_2d = (p2(1) - p1(1)) * (q2(2) - q1(2)) == & - (q2(1) - q1(1)) * (p2(2) - p1(2)) - - return -end -function lines_exp_parallel_3d(p1, p2, q1, q2) - -!*****************************************************************************80 -! -!! LINES_EXP_PARALLEL_3D determines if two lines are parallel in 3D. -! -! Discussion: -! -! The explicit form of a line in 3D is: -! -! the line through the points P1 and P2. -! -! The points P1, P2 define a direction (P2-P1). Similarly, the -! points (Q1,Q2) define a direction (Q2-Q1). The quantity -! -! (P2-P1) dot (Q2-Q1) = norm(P2-P1) * norm(Q2-Q1) * cos ( angle ) -! -! Therefore, the following value is between 0 and 1; -! -! abs ( (P2-P1) dot (Q2-Q1) / ( norm(P2-P1) * norm(Q2-Q1) ) ) -! -! and the lines are parallel if -! -! abs ( (P2-P1) dot (Q2-Q1) / ( norm(P2-P1) * norm(Q2-Q1) ) ) = 1 -! -! We can rephrase this as requiring: -! -! ( (P2-P1)dot(Q2-Q1) )^2 = (P2-P1)dot(P2-P1) * (Q2-Q1)dot(Q2-Q1) -! -! which avoids division and square roots. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 August 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. -! -! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. -! -! Output, logical ( kind = 4 ) LINES_EXP_PARALLEL_3D is TRUE if the lines -! are parallel. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - logical(kind=4) lines_exp_parallel_3d - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pdotp - real(kind=8) pdotq - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) qdotq - - pdotq = dot_product(p2(1:dim_num) - p1(1:dim_num), & - q2(1:dim_num) - q1(1:dim_num)) - - pdotp = dot_product(p2(1:dim_num) - p1(1:dim_num), & - p2(1:dim_num) - p1(1:dim_num)) - - qdotq = dot_product(q2(1:dim_num) - q1(1:dim_num), & - q2(1:dim_num) - q1(1:dim_num)) - - lines_exp_parallel_3d = (pdotq * pdotq == pdotp * qdotq) - - return -end -subroutine lines_imp_angle_2d(a1, b1, c1, a2, b2, c2, theta) - -!*****************************************************************************80 -! -!! LINES_IMP_ANGLE_2D finds the angle between two implicit lines in 2D. -! -! Discussion: -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 January 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) A1, B1, C1, the implicit parameters of the -! first line. -! -! Input, real ( kind = 8 ) A2, B2, C2, the implicit parameters of the -! second line. -! -! Output, real ( kind = 8 ) THETA, the angle between the two lines. -! - implicit none - - 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 - real(kind=8) pdotq - real(kind=8) pnorm - real(kind=8) qnorm - real(kind=8) r8_acos - real(kind=8) theta - - pdotq = a1 * a2 + b1 * b2 - pnorm = sqrt(a1 * a1 + b1 * b1) - qnorm = sqrt(a2 * a2 + b2 * b2) - - theta = r8_acos(pdotq / (pnorm * qnorm)) - - return -end -subroutine lines_imp_dist_2d(a1, b1, c1, a2, b2, c2, dist) - -!*****************************************************************************80 -! -!! LINES_IMP_DIST_2D determines the distance between two implicit lines in 2D. -! -! Discussion: -! -! If the lines intersect, then their distance is zero. -! If the two lines are parallel, then they have a nonzero distance. -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 January 2001 -! -! Author: -! -! John Burkardt -! -! 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, real ( kind = 8 ) DIST, the distance between the two lines. -! - implicit none - - 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 - real(kind=8) dist - logical(kind=4) line_imp_is_degenerate_2d -! -! Refuse to handle degenerate lines. -! - if (line_imp_is_degenerate_2d(a1, b1, c1)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINES_IMP_DIST_2D - Fatal error!' - write (*, '(a)') ' Line 1 is degenerate.' - stop 1 - end if - - if (line_imp_is_degenerate_2d(a2, b2, c2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'LINES_IMP_DIST_2D - Fatal error!' - write (*, '(a)') ' Line 2 is degenerate.' - stop 1 - end if -! -! Determine if the lines intersect. -! - if (a1 * b2 /= a2 * b1) then - dist = 0.0D+00 - return - end if -! -! Determine the distance between the parallel lines. -! - dist = abs(c2 / sqrt(a2 * a2 + b2 * b2) & - - c1 / sqrt(a1 * a1 + b1 * b1)) - - return -end -subroutine lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) - -!*****************************************************************************80 -! -!! LINES_IMP_INT_2D determines where two implicit lines intersect in 2D. -! -! Discussion: -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 February 2005 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a(dim_num, dim_num + 1) - real(kind=8) a1 - real(kind=8) a2 - real(kind=8) b1 - real(kind=8) b2 - real(kind=8) c1 - real(kind=8) c2 - integer(kind=4) info - integer(kind=4) ival - logical(kind=4) line_imp_is_degenerate_2d - real(kind=8) p(dim_num) - - 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 - - return -end -subroutine lines_par_angle_2d(f1, g1, x01, y01, f2, g2, x02, y02, theta) - -!*****************************************************************************80 -! -!! LINES_PAR_ANGLE_2D finds the angle between two parametric lines in 2D. -! -! Discussion: -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F*F + G*G = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 January 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F1, G1, X01, Y01, the parametric parameters of the -! first line. -! -! Input, real ( kind = 8 ) F2, G2, X02, Y02, the parametric parameters of the -! second line. -! -! Output, real ( kind = 8 ) THETA, the angle between the two lines. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) f1 - real(kind=8) f2 - real(kind=8) g1 - real(kind=8) g2 - real(kind=8) pdotq - real(kind=8) pnorm - real(kind=8) qnorm - real(kind=8) r8_acos - real(kind=8) theta - real(kind=8) x01 - real(kind=8) x02 - real(kind=8) y01 - real(kind=8) y02 - - pdotq = f1 * f2 + g1 * g2 - pnorm = sqrt(f1 * f1 + g1 * g1) - qnorm = sqrt(f2 * f2 + g2 * g2) - - theta = r8_acos(pdotq / (pnorm * qnorm)) - - return -end -subroutine lines_par_angle_3d(f1, g1, h1, x01, y01, z01, f2, g2, h2, & - x02, y02, z02, theta) - -!*****************************************************************************80 -! -!! LINES_PAR_ANGLE_3D finds the angle between two parametric lines in 3D. -! -! Discussion: -! -! The parametric form of a line in 3D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! Z = Z0 + H * T -! -! We normalize by always choosing F*F + G*G + H*H = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F1, G1, H1, X01, Y01, Z01, the parametric -! parameters of the first line. -! -! Input, real ( kind = 8 ) F2, G2, H2, X02, Y02, Z02, the parametric -! parameters of the second line. -! -! Output, real ( kind = 8 ) THETA, the angle between the two lines. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) f1 - real(kind=8) f2 - real(kind=8) g1 - real(kind=8) g2 - real(kind=8) h1 - real(kind=8) h2 - real(kind=8) pdotq - real(kind=8) pnorm - real(kind=8) qnorm - real(kind=8) r8_acos - real(kind=8) theta - real(kind=8) x01 - real(kind=8) x02 - real(kind=8) y01 - real(kind=8) y02 - real(kind=8) z01 - real(kind=8) z02 - - pdotq = f1 * f2 + g1 * g2 + h1 * h2 - pnorm = sqrt(f1 * f1 + g1 * g1 + h1 * h1) - qnorm = sqrt(f2 * f2 + g2 * g2 + h2 * h2) - - theta = r8_acos(pdotq / (pnorm * qnorm)) - - return -end -subroutine lines_par_dist_3d(f1, g1, h1, x01, y01, z01, f2, g2, h2, & - x02, y02, z02, dist) - -!*****************************************************************************80 -! -!! LINES_PAR_DIST_3D finds the distance between two parametric lines in 3D. -! -! Discussion: -! -! The parametric form of a line in 3D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! Z = Z0 + H * T -! -! We normalize by always choosing F*F + G*G + H*H = 1, and F nonnegative. -! -! This code does not work for parallel or near parallel lines. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F1, G1, H1, X01, Y01, Z01, the parametric -! parameters of the first line. -! -! Input, real ( kind = 8 ) F2, G2, H2, X02, Y02, Z02, the parametric -! parameters of the second line. -! -! Output, real ( kind = 8 ) DIST, the distance between the two lines. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dist - real(kind=8) f1 - real(kind=8) f2 - real(kind=8) g1 - real(kind=8) g2 - real(kind=8) h1 - real(kind=8) h2 - real(kind=8) x01 - real(kind=8) x02 - real(kind=8) y01 - real(kind=8) y02 - real(kind=8) z01 - real(kind=8) z02 - - dist = abs((x02 - x01) * (g1 * h2 - g2 * h1) & - + (y02 - y01) * (h1 * f2 - h2 * f1) & - + (z02 - z01) * (f1 * g2 - f2 * g1)) / & - ((f1 * g2 - f2 * g1)**2 & - + (g1 * h2 - g2 * h1)**2 & - + (h1 * f2 - h2 * f1)**2) - - return -end -subroutine lines_par_int_2d(f1, g1, x1, y1, f2, g2, x2, y2, t1, t2, pint) - -!*****************************************************************************80 -! -!! LINES_PAR_INT_2D determines where two parametric lines intersect in 2D. -! -! Discussion: -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F*F + G*G = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 January 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) F1, G1, X1, Y1, define the first parametric line. -! -! Input, real ( kind = 8 ) F2, G2, X2, Y2, define the second parametric line. -! -! Output, real ( kind = 8 ) T1, T2, the T parameters on the first and second -! lines of the intersection point. -! -! Output, real ( kind = 8 ) PINT(2), the intersection point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) det - real(kind=8) f1 - real(kind=8) f2 - real(kind=8) g1 - real(kind=8) g2 - real(kind=8) pint(dim_num) - real(kind=8) t1 - real(kind=8) t2 - real(kind=8) x1 - real(kind=8) x2 - real(kind=8) y1 - real(kind=8) y2 - - det = f2 * g1 - f1 * g2 - - if (det == 0.0D+00) then - t1 = 0.0D+00 - t2 = 0.0D+00 - pint(1:dim_num) = 0.0D+00 - else - t1 = (f2 * (y2 - y1) - g2 * (x2 - x1)) / det - t2 = (f1 * (y2 - y1) - g1 * (x2 - x1)) / det - pint(1) = x1 + f1 * t1 - pint(2) = y1 + g1 * t1 - end if - - return -end diff --git a/src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc b/src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc deleted file mode 100644 index f198ba526..000000000 --- a/src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc +++ /dev/null @@ -1,3469 +0,0 @@ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_angles_2d(t, angle) - -!***************************************************************************80 -! -!! TRIANGLE_ANGLES_2D computes the angles of a triangle in 2D. -! -! Discussion: -! -! The law of cosines is used: -! -! C^2 = A^2 + B^2 - 2 * A * B * COS ( GAMMA ) -! -! where GAMMA is the angle opposite side C. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) ANGLE(3), the angles opposite -! sides P1-P2, P2-P3 and P3-P1, in radians. -! - implicit none - - real(kind=8) t(dim_num, 3) - real(kind=8) angle(3) - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r8_acos -! -! Compute the length of each side. -! - a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) - b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) - c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) -! -! Take care of ridiculous special cases. -! - if (a == 0.0D+00 .and. b == 0.0D+00 .and. c == 0.0D+00) then - angle(1:3) = 2.0D+00 * r8_pi / 3.0D+00 - return - end if - - if (c == 0.0D+00 .or. a == 0.0D+00) then - angle(1) = r8_pi - else - angle(1) = r8_acos((c * c + a * a - b * b) / (2.0D+00 * c * a)) - end if - - if (a == 0.0D+00 .or. b == 0.0D+00) then - angle(2) = r8_pi - else - angle(2) = r8_acos((a * a + b * b - c * c) / (2.0D+00 * a * b)) - end if - - if (b == 0.0D+00 .or. c == 0.0D+00) then - angle(3) = r8_pi - else - angle(3) = r8_acos((b * b + c * c - a * a) / (2.0D+00 * b * c)) - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_angles_3d(t, angle) - -!***************************************************************************80 -! -!! TRIANGLE_ANGLES_3D computes the angles of a triangle in 3D. -! -! Discussion: -! -! The law of cosines is used: -! -! C * C = A * A + B * B - 2 * A * B * COS ( GAMMA ) -! -! where GAMMA is the angle opposite side C. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Output, real ( kind = 8 ) ANGLE(3), the angles opposite -! sides P1-P2, P2-P3 and P3-P1, in radians. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) angle(3) - real(kind=8) b - real(kind=8) c - real(kind=8) r8_acos - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) t(dim_num, 3) -! -! Compute the length of each side. -! - a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) - b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) - c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) -! -! Take care of a ridiculous special case. -! - if (a == 0.0D+00 .and. b == 0.0D+00 .and. c == 0.0D+00) then - angle(1:3) = 2.0D+00 * r8_pi / 3.0D+00 - return - end if - - if (c == 0.0D+00 .or. a == 0.0D+00) then - angle(1) = r8_pi - else - angle(1) = r8_acos((c * c + a * a - b * b) / (2.0D+00 * c * a)) - end if - - if (a == 0.0D+00 .or. b == 0.0D+00) then - angle(2) = r8_pi - else - angle(2) = r8_acos((a * a + b * b - c * c) / (2.0D+00 * a * b)) - end if - - if (b == 0.0D+00 .or. c == 0.0D+00) then - angle(3) = r8_pi - else - angle(3) = r8_acos((b * b + c * c - a * a) / (2.0D+00 * b * c)) - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_area_2d(t, area) - -!***************************************************************************80 -! -!! TRIANGLE_AREA_2D computes the area of a triangle in 2D. -! -! Discussion: -! -! If the triangle's vertices are given in counter clockwise order, -! the area will be positive. If the triangle's vertices are given -! in clockwise order, the area will be negative! -! -! An earlier version of this routine always returned the absolute -! value of the computed area. I am convinced now that that is -! a less useful result! For instance, by returning the signed -! area of a triangle, it is possible to easily compute the area -! of a nonconvex polygon as the sum of the (possibly negative) -! areas of triangles formed by node 1 and successive pairs of vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 October 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) AREA, the area of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) t(dim_num, 3) - - area = 0.5D+00 * ( & - t(1, 1) * (t(2, 2) - t(2, 3)) & - + t(1, 2) * (t(2, 3) - t(2, 1)) & - + t(1, 3) * (t(2, 1) - t(2, 2))) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_area_3d(t, area) - -!*****************************************************************************80 -! -!! TRIANGLE_AREA_3D computes the area of a triangle in 3D. -! -! Discussion: -! -! This routine uses the fact that the norm of the cross product -! of two vectors is the area of the parallelogram they form. -! -! Therefore, the area of the triangle is half of that value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 December 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Output, real ( kind = 8 ) AREA, the area of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) area - real(kind=8) cross(dim_num) - real(kind=8) t(dim_num, 3) -! -! Compute the cross product vector. -! - cross(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & - - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) - - cross(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & - - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) - - cross(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) - - area = 0.5D+00 * sqrt(sum(cross(1:3)**2)) - - return -end -subroutine triangle_area_3d_2(t, area) - -!*****************************************************************************80 -! -!! TRIANGLE_AREA_3D_2 computes the area of a triangle in 3D. -! -! Discussion: -! -! This routine computes the area "the hard way". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Output, real ( kind = 8 ) AREA, the area of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) alpha - real(kind=8) area - real(kind=8) base - real(kind=8) dot - real(kind=8) height - real(kind=8) t(dim_num, 3) -! -! Find the projection of (P3-P1) onto (P2-P1). -! - dot = (t(1, 2) - t(1, 1)) * (t(1, 3) - t(1, 1)) & - + (t(2, 2) - t(2, 1)) * (t(2, 3) - t(2, 1)) & - + (t(3, 2) - t(3, 1)) * (t(3, 3) - t(3, 1)) -! -! Find the length of (P2-P1). -! - base = sqrt((t(1, 2) - t(1, 1))**2 & - + (t(2, 2) - t(2, 1))**2 & - + (t(3, 2) - t(3, 1))**2) -! -! The height of the triangle is the length of (P3-P1) after its -! projection onto (P2-P1) has been subtracted. -! - if (base == 0.0D+00) then - - height = 0.0D+00 - - else - - alpha = dot / (base * base) - - height = sqrt( & - (t(1, 1) + alpha * (t(1, 2) - t(1, 1)) - t(1, 3))**2 & - + (t(2, 1) + alpha * (t(2, 2) - t(2, 1)) - t(2, 3))**2 & - + (t(3, 1) + alpha * (t(3, 2) - t(3, 1)) - t(3, 3))**2) - - end if - - area = 0.5D+00 * base * height - - return -end -subroutine triangle_area_3d_3(t, area) - -!*****************************************************************************80 -! -!! TRIANGLE_AREA_3D_3 computes the area of a triangle in 3D. -! -! Discussion: -! -! This routine uses Heron's formula -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 December 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Output, real ( kind = 8 ) AREA, the area of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) area - integer(kind=4) i - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) s(3) - real(kind=8) t(dim_num, 3) - - do j = 1, 3 - jp1 = mod(j, 3) + 1 - s(j) = 0.0D+00 - do i = 1, dim_num - s(j) = s(j) + (t(i, j) - t(i, jp1))**2 - end do - s(j) = sqrt(s(j)) - end do - - area = (s(1) + s(2) + s(3)) & - * (-s(1) + s(2) + s(3)) & - * (s(1) - s(2) + s(3)) & - * (s(1) + s(2) - s(3)) - - if (area < 0.0D+00) then - area = -1.0D+00 - return - end if - - area = 0.25D+00 * sqrt(area) - - return -end -subroutine triangle_area_heron(s, area) - -!*****************************************************************************80 -! -!! TRIANGLE_AREA_HERON computes the area of a triangle using Heron's formula. -! -! Discussion: -! -! The formula is valid for any spatial dimension, depending only -! on the lengths of the sides, and not the coordinates of the vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) S(3), the lengths of the three sides. -! -! Output, real ( kind = 8 ) AREA, the area of the triangle, or -1.0 if the -! sides cannot constitute a triangle. -! - implicit none - - real(kind=8) area - real(kind=8) s(3) - - area = (s(1) + s(2) + s(3)) & - * (-s(1) + s(2) + s(3)) & - * (s(1) - s(2) + s(3)) & - * (s(1) + s(2) - s(3)) - - if (area < 0.0D+00) then - area = -1.0D+00 - return - end if - - area = 0.25D+00 * sqrt(area) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_area_vector_3d(t, area_vector) -! -!! TRIANGLE_AREA_VECTOR_3D computes the area vector of a triangle in 3D. -! -! Discussion: -! -! The "area vector" of a triangle is simply a cross product of, -! for instance, the vectors (V2-V1) and (V3-V1), where V1, V2 -! and V3 are the vertices of the triangle. -! -! The norm of the cross product vector of two vectors is the area -! of the parallelogram they form. -! -! Therefore, the area of the triangle is half of the norm of the -! area vector: -! -! area = 0.5 * sqrt ( sum ( area_vector(1:3)^2 ) ) -! -! The reason for looking at the area vector rather than the area -! is that this makes it possible to compute the area of a flat -! polygon in 3D by summing the areas of the triangles that form -! a decomposition of the polygon, while allowing for both positive -! and negative areas. (Sum the vectors, THEN take the norm and -! multiply by 1/2). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 October 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Output, real ( kind = 8 ) AREA_VECTOR(3), the area vector of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) area_vector(dim_num) - real(kind=8) t(dim_num, 3) - - area_vector(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & - - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) - - area_vector(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & - - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) - - area_vector(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_barycentric_2d(t, p, xsi) - -! -!! TRIANGLE_BARYCENTRIC_2D finds the barycentric coordinates of a point in 2D. -! -! Discussion: -! -! The barycentric coordinate of point P related to vertex A can be -! interpreted as the ratio of the area of the triangle with -! vertex A replaced by vertex P to the area of the original -! triangle. -! -! This routine assumes that the triangle vertices are given in -! counter clockwise order. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! The vertices should be given in counter clockwise order. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) XSI(3), the barycentric coordinates of P -! with respect to the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4), parameter :: rhs_num = 1 - - real(kind=8) a(dim_num, dim_num + rhs_num) - integer(kind=4) info - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) - real(kind=8) xsi(dim_num + 1) -! -! Set up the linear system -! -! ( X2-X1 X3-X1 ) XSI(1) = X-X1 -! ( Y2-Y1 Y3-Y1 ) XSI(2) Y-Y1 -! -! which is satisfied by the barycentric coordinates of P. -! - a(1, 1) = t(1, 2) - t(1, 1) - a(1, 2) = t(1, 3) - t(1, 1) - a(1, 3) = p(1) - t(1, 1) - - a(2, 1) = t(2, 2) - t(2, 1) - a(2, 2) = t(2, 3) - t(2, 1) - a(2, 3) = p(2) - t(2, 1) -! -! Solve the linear system. -! - call r8mat_solve(dim_num, rhs_num, a, info) - - if (info /= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'TRIANGLE_BARYCENTRIC_2D - Fatal error!' - write (*, '(a)') ' The linear system is singular.' - write (*, '(a)') ' The input data does not form a proper triangle.' - stop 1 - end if - - xsi(1) = a(1, 3) - xsi(2) = a(2, 3) - xsi(3) = 1.0D+00 - xsi(1) - xsi(2) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_centroid_2d(t, centroid) - -! -!! TRIANGLE_CENTROID_2D computes the centroid of a triangle in 2D. -! -! Discussion: -! -! The centroid of a triangle can also be considered the -! center of gravity, or center of mass, assuming that the triangle -! is made of a thin uniform sheet of massy material. -! -! The centroid of a triangle is the intersection of the medians. -! -! A median of a triangle is a line connecting a vertex to the -! midpoint of the opposite side. -! -! In barycentric coordinates, in which the vertices of the triangle -! have the coordinates (1,0,0), (0,1,0) and (0,0,1), the centroid -! has coordinates (1/3,1/3,1/3). -! -! In geometry, the centroid of a triangle is often symbolized by "G". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) centroid(dim_num) - integer(kind=4) i - real(kind=8) t(dim_num, 3) - - do i = 1, dim_num - centroid(i) = sum(t(i, 1:3)) / 3.0D+00 - end do - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_centroid_3d(t, centroid) - -! -!! TRIANGLE_CENTROID_3D computes the centroid of a triangle in 3D. -! -! Discussion: -! -! The centroid of a triangle can also be considered the -! center of gravity or center of mass, assuming that the triangle -! is made of a thin uniform sheet of massy material. -! -! The centroid of a triangle is the intersection of the medians. -! A median of a triangle is a line connecting any vertex to the -! midpoint of the opposite side. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) centroid(dim_num) - integer(kind=4) i - real(kind=8) t(dim_num, 3) - - do i = 1, dim_num - centroid(i) = sum(t(i, 1:3)) / 3.0D+00 - end do - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_circumcenter_2d(t, pc) -! -!! TRIANGLE_CIRCUMCENTER_2D computes the circumcenter of a triangle in 2D. -! -! Discussion: -! -! The circumcenter of a triangle is the center of the circumcircle, the -! circle that passes through the three vertices of the triangle. -! -! The circumcircle contains the triangle, but it is not necessarily the -! smallest triangle to do so. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. -! -! The circumcenter is the intersection of the perpendicular bisectors -! of the sides of the triangle. -! -! In geometry, the circumcenter of a triangle is often symbolized by "O". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) PC(2), the circumcenter of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) det - real(kind=8) f(2) - real(kind=8) pc(dim_num) - real(kind=8) t(dim_num, 3) - real(kind=8) top(dim_num) - - f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 - f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 - - top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) - top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) - - det = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) - - pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / det - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_circumcenter_2d_2(t, pc) - -!*****************************************************************************80 -! -!! TRIANGLE_CIRCUMCENTER_2D_2 computes the circumcenter of a triangle in 2D. -! -! Discussion: -! -! The circumcenter of a triangle is the center of the circumcircle, the -! circle that passes through the three vertices of the triangle. -! -! The circumcircle contains the triangle, but it is not necessarily the -! smallest triangle to do so. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. -! -! The circumcenter is the intersection of the perpendicular bisectors -! of the sides of the triangle. -! -! Surprisingly, the diameter of the circle can be found by solving -! a 2 by 2 linear system. If we label the vertices of the triangle -! P1, P2 and P3, then the vectors P2 - P1 and P3 - P1 are secants of -! the circle, and each forms a right triangle with the diameter -! vector through P1. -! -! Hence, the dot product of P2 - P1 with the diameter vector is equal -! to the square of the length of P2 - P1, and similarly for P3 - P1. -! This determines the diameter vector originating at P1. -! -! In geometry, the circumcenter of a triangle is often symbolized by "O". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) PC(2), the circumcenter of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4), parameter :: rhs_num = 1 - - real(kind=8) a(dim_num, dim_num + rhs_num) - integer(kind=4) info - real(kind=8) pc(dim_num) - real(kind=8) t(dim_num, 3) -! -! Set up the linear system. -! - a(1, 1) = t(1, 2) - t(1, 1) - a(1, 2) = t(2, 2) - t(2, 1) - a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 - - a(2, 1) = t(1, 3) - t(1, 1) - a(2, 2) = t(2, 3) - t(2, 1) - a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 -! -! Solve the linear system. -! - call r8mat_solve(dim_num, rhs_num, a, info) -! -! Compute the center -! - if (info /= 0) then - pc(1:dim_num) = 0.0D+00 - else - pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_circumcenter(n, t, p) - -!*****************************************************************************80 -! -!! TRIANGLE_CIRCUMCENTER computes the circumcenter of a triangle in ND. -! -! Discussion: -! -! Three ND points A, B and C lie on a circle. -! -! The circumcenter P has the formula -! -! P = ( Area ( PBC ) * A + Area ( APC) * B + Area ( ABP ) * C ) -! / ( Area ( PBC ) + Area ( APC ) + Area ( ABP ) ) -! -! The details of the formula rely on information supplied -! by Oscar Lanzi III. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 October 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the spatial dimension. -! -! Input, real ( kind = 8 ) T(N,3), the triangle vertices. -! -! Output, real ( kind = 8 ) P(N), the circumcenter of the triangle. -! - implicit none - - integer(kind=4) n - - real(kind=8) a - real(kind=8) abp - real(kind=8) apc - real(kind=8) b - real(kind=8) c - real(kind=8) p(n) - real(kind=8) pbc - real(kind=8) r8vec_normsq_affine - real(kind=8) t(n, 3) - - a = r8vec_normsq_affine(n, t(1:n, 2), t(1:n, 3)) - b = r8vec_normsq_affine(n, t(1:n, 3), t(1:n, 1)) - c = r8vec_normsq_affine(n, t(1:n, 1), t(1:n, 2)) - - pbc = a * (-a + b + c) - apc = b * (a - b + c) - abp = c * (a + b - c) - - p(1:n) = (pbc * t(1:n, 1) + apc * t(1:n, 2) + abp * t(1:n, 3)) & - / (pbc + apc + abp) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_circumcircle_2d(t, r, pc) - -!*****************************************************************************80 -! -!! TRIANGLE_CIRCUMCIRCLE_2D computes the circumcircle of a triangle in 2D. -! -! Discussion: -! -! The circumcenter of a triangle is the center of the circumcircle, the -! circle that passes through the three vertices of the triangle. -! -! The circumcircle contains the triangle, but it is not necessarily the -! smallest triangle to do so. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. -! -! The circumcenter is the intersection of the perpendicular bisectors -! of the sides of the triangle. -! -! In geometry, the circumcenter of a triangle is often symbolized by "O". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) R, PC(2), the circumradius and circumcenter -! of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) bot - real(kind=8) c - real(kind=8) det - real(kind=8) f(2) - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) top(dim_num) - real(kind=8) t(dim_num, 3) -! -! Circumradius. -! - a = sqrt((t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2) - b = sqrt((t(1, 3) - t(1, 2))**2 + (t(2, 3) - t(2, 2))**2) - c = sqrt((t(1, 1) - t(1, 3))**2 + (t(2, 1) - t(2, 3))**2) - - bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) - - if (bot <= 0.0D+00) then - r = -1.0D+00 - pc(1:2) = 0.0D+00 - return - end if - - r = a * b * c / sqrt(bot) -! -! Circumcenter. -! - f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 - f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 - - top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) - top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) - - det = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) - - pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / det - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_circumcircle_2d_2(t, r, pc) -! -!! TRIANGLE_CIRCUMCIRCLE_2D_2 computes the circumcircle of a triangle in 2D. -! -! Discussion: -! -! The circumscribed circle of a triangle is the circle that passes through -! the three vertices of the triangle. The circumscribed circle contains -! the triangle, but it is not necessarily the smallest triangle to do so. -! -! Surprisingly, the diameter of the circle can be found by solving -! a 2 by 2 linear system. This is because the vectors P2 - P1 -! and P3 - P1 are secants of the circle, and each forms a right -! triangle with the diameter. Hence, the dot product of -! P2 - P1 with the diameter is equal to the square of the length -! of P2 - P1, and similarly for P3 - P1. This determines the -! diameter vector originating at P1. -! -! If all angles of the triangle are no greater than 90 degrees, then -! the center of the circumscribed circle will lie inside the triangle. -! Otherwise, the center will lie outside the triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) R, PC(2), the circumradius and circumcenter. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4), parameter :: rhs_num = 1 - - real(kind=8) a(dim_num, dim_num + rhs_num) - integer(kind=4) info - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) t(dim_num, 3) -! -! Set up the linear system. -! - a(1, 1) = t(1, 2) - t(1, 1) - a(1, 2) = t(2, 2) - t(2, 1) - a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 - - a(2, 1) = t(1, 3) - t(1, 1) - a(2, 2) = t(2, 3) - t(2, 1) - a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 -! -! Solve the linear system. -! - call r8mat_solve(dim_num, rhs_num, a, info) - - if (info /= 0) then - r = -1.0D+00 - pc(1:dim_num) = 0.0D+00 - end if - - r = 0.5D+00 * sqrt(a(1, dim_num + 1) * a(1, dim_num + 1) & - + a(2, dim_num + 1) * a(2, dim_num + 1)) - pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_circumradius_2d(t, r) - -! -!! TRIANGLE_CIRCUMRADIUS_2D computes the circumradius of a triangle in 2D. -! -! Discussion: -! -! The circumscribed circle of a triangle is the circle that passes through -! the three vertices of the triangle. The circumscribed circle contains -! the triangle, but it is not necessarily the smallest triangle to do so. -! -! The circumradius of a triangle is the radius of the circumscribed -! circle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) R, the circumradius of the circumscribed circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) bot - real(kind=8) c - real(kind=8) r - real(kind=8) t(dim_num, 3) -! -! Compute the length of each side. -! - a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) - b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) - c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - - bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) - - if (bot <= 0.0D+00) then - r = -1.0D+00 - return - end if - - r = a * b * c / sqrt(bot) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_contains_line_exp_3d(t, p1, p2, inside, pint) - -! -!! TRIANGLE_CONTAINS_LINE_EXP_3D finds if a line is inside a triangle in 3D. -! -! Discussion: -! -! A line will "intersect" the plane of a triangle in 3D if -! * the line does not lie in the plane of the triangle -! (there would be infinitely many intersections), AND -! * the line does not lie parallel to the plane of the triangle -! (there are no intersections at all). -! -! Therefore, if a line intersects the plane of a triangle, it does so -! at a single point. We say the line is "inside" the triangle if, -! regarded as 2D objects, the intersection point of the line and the plane -! is inside the triangle. -! -! A triangle in 3D is determined by three points: -! -! T(1:3,1), T(1:3,2) and T(1:3,3). -! -! The explicit form of a line in 3D is: -! -! the line through the points P1(1:3), P2(1:3). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Steve Marschner, Cornell University, -! CS465 Notes: Simple Ray-Triangle Intersection. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if (the intersection point of) -! the line is inside the triangle. -! -! Output, real ( kind = 8 ) PINT(3), the point where the line -! intersects the plane of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - logical(kind=4) inside - integer(kind=4) ival - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) normal(dim_num) - real(kind=8) normal2(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pint(dim_num) - real(kind=8) t(dim_num, 3) - real(kind=8) temp - logical(kind=4) triangle_is_degenerate_nd - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) -! -! Make sure the line is not degenerate. -! - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'TRIANGLE_CONTAINS_LINE_EXP_3D - Fatal error!' - write (*, '(a)') ' The explicit line is degenerate.' - stop 1 - end if -! -! Make sure the triangle is not degenerate. -! - if (triangle_is_degenerate_nd(dim_num, t)) then - write (*, '(a)') ' ' - write (*, '(a)') 'TRIANGLE_CONTAINS_LINE_EXP_3D - Fatal error!' - write (*, '(a)') ' The triangle is degenerate.' - stop 1 - end if -! -! Determine a unit normal vector associated with the plane of -! the triangle. -! - v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) - v2(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 1) - - normal(1) = v1(2) * v2(3) - v1(3) * v2(2) - normal(2) = v1(3) * v2(1) - v1(1) * v2(3) - normal(3) = v1(1) * v2(2) - v1(2) * v2(1) - - temp = sqrt(sum(normal(1:dim_num)**2)) - normal(1:dim_num) = normal(1:dim_num) / temp -! -! 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) - - if (ival == 0) then - inside = .false. - pint(1:dim_num) = huge(temp) - return - else if (ival == 2) then - inside = .false. - pint(1:dim_num) = p1(1:dim_num) - return - end if -! -! Now, check that all three triangles made by two vertices and -! the intersection point have the same "clock sense" as the -! triangle's normal vector. -! - v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) - v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 1) - - normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) - normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) - normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) - - if (dot_product(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) then - inside = .false. - return - end if - - v1(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 2) - v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 2) - - normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) - normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) - normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) - - if (dot_product(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) then - inside = .false. - return - end if - - v1(1:dim_num) = t(1:dim_num, 1) - t(1:dim_num, 3) - v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 3) - - normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) - normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) - normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) - - if (dot_product(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) then - inside = .false. - return - end if - - inside = .true. - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_contains_line_par_3d(t, p0, pd, inside, p) - -! -!! TRIANGLE_CONTAINS_LINE_PAR_3D: finds if a line is inside a triangle in 3D. -! -! Discussion: -! -! A line will "intersect" the plane of a triangle in 3D if -! * the line does not lie in the plane of the triangle -! (there would be infinitely many intersections), AND -! * the line does not lie parallel to the plane of the triangle -! (there are no intersections at all). -! -! Therefore, if a line intersects the plane of a triangle, it does so -! at a single point. We say the line is "inside" the triangle if, -! regarded as 2D objects, the intersection point of the line and the plane -! is inside the triangle. -! -! A triangle in 3D is determined by three points: -! -! T(1:3,1), T(1:3,2) and T(1:3,3). -! -! The parametric form of a line in 3D is: -! -! P(1:3) = P0(1:3) + PD(1:3) * T -! -! We can normalize by requiring PD to have euclidean norm 1, -! and the first nonzero entry positive. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2007 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420, -! page 111. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the three points that define -! the triangle. -! -! Input, real ( kind = 8 ) P0(3), PD(3), parameters that define the -! parametric line. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if (the intersection point of) -! the line is inside the triangle. -! -! Output, real ( kind = 8 ) P(3), is the point of intersection of the line -! and the plane of the triangle, unless they are parallel. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) angle_sum - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) denom - logical(kind=4) inside - logical(kind=4) intersect - real(kind=8) norm - real(kind=8) norm1 - real(kind=8) norm2 - real(kind=8) p(dim_num) - real(kind=8) p0(dim_num) - real(kind=8) pd(dim_num) - real(kind=8) r8_acos - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) t(dim_num, 3) - real(kind=8) t_int - real(kind=8), parameter :: tol = 0.00001D+00 - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) - real(kind=8) v3(dim_num) -! -! Determine the implicit form (A,B,C,D) of the plane containing the -! triangle. -! - a = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & - - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) - - b = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & - - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) - - c = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) - - d = -t(1, 2) * a - t(2, 2) * b - t(3, 2) * c -! -! Make sure the plane is well-defined. -! - norm1 = sqrt(a * a + b * b + c * c) - - if (norm1 == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'TRIANGLE_LINE_PAR_INT_3D - Fatal error!' - write (*, '(a)') ' The plane normal vector is null.' - inside = .false. - p(1:dim_num) = 0.0D+00 - stop 1 - end if -! -! Make sure the implicit line is well defined. -! - norm2 = sqrt(sum(pd(1:dim_num)**2)) - - if (norm2 == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'TRIANGLE_LINE_PAR_INT_3D - Fatal error!' - write (*, '(a)') ' The line direction vector is null.' - inside = .false. - p(1:dim_num) = 0.0D+00 - stop 1 - end if -! -! Determine the denominator of the parameter in the -! implicit line definition that determines the intersection -! point. -! - denom = a * pd(1) + b * pd(2) + c * pd(3) -! -! If DENOM is zero, or very small, the line and the plane may be -! parallel or almost so. -! - if (abs(denom) < tol * norm1 * norm2) then -! -! The line may actually lie in the plane. We're not going -! to try to address this possibility. -! - if (a * p0(1) + b * p0(2) + c * p0(3) + d == 0.0D+00) then - - intersect = .true. - inside = .false. - p(1:dim_num) = p0(1:dim_num) -! -! The line and plane are parallel and disjoint. -! - else - - intersect = .false. - inside = .false. - p(1:dim_num) = 0.0D+00 - - end if -! -! The line and plane intersect at a single point P. -! - else - - intersect = .true. - t_int = -(a * p0(1) + b * p0(2) + c * p0(3) + d) / denom - p(1:dim_num) = p0(1:dim_num) + t_int * pd(1:dim_num) -! -! To see if P is included in the triangle, sum the angles -! formed by P and pairs of the vertices. If the point is in the -! triangle, we get a total 360 degree view. Otherwise, we -! get less than 180 degrees. -! - v1(1:dim_num) = t(1:dim_num, 1) - p(1:dim_num) - v2(1:dim_num) = t(1:dim_num, 2) - p(1:dim_num) - v3(1:dim_num) = t(1:dim_num, 3) - p(1:dim_num) - - norm = sqrt(sum(v1(1:dim_num)**2)) - - if (norm == 0.0D+00) then - inside = .true. - return - end if - - v1(1:dim_num) = v1(1:dim_num) / norm - - norm = sqrt(sum(v2(1:dim_num)**2)) - - if (norm == 0.0D+00) then - inside = .true. - return - end if - - v2(1:dim_num) = v2(1:dim_num) / norm - - norm = sqrt(sum(v3(1:dim_num)**2)) - - if (norm == 0.0D+00) then - inside = .true. - return - end if - - v3(1:dim_num) = v3(1:dim_num) / norm - - angle_sum = r8_acos(dot_product(v1(1:3), v2(1:3))) & - + r8_acos(dot_product(v2(1:3), v3(1:3))) & - + r8_acos(dot_product(v3(1:3), v1(1:3))) - - if (nint(angle_sum / r8_pi) == 2) then - inside = .true. - else - inside = .false. - end if - - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_contains_point_2d_1(t, p, inside) - -! -!! TRIANGLE_CONTAINS_POINT_2D_1 finds if a point is inside a triangle in 2D. -! -! Discussion: -! -! It is conventional to list the triangle vertices in counter clockwise -! order. However, this routine does not require a particular order -! for the vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 June 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside -! the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) - real(kind=8) xsi(dim_num + 1) - - call triangle_barycentric_2d(t, p, xsi) - - if (any(xsi(1:3) < 0.0D+00)) then - inside = .false. - else - inside = .true. - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_contains_point_2d_2(t, p, inside) - -! -!! TRIANGLE_CONTAINS_POINT_2D_2 finds if a point is inside a triangle in 2D. -! -! Discussion: -! -! The routine assumes that the vertices are given in counter clockwise -! order. If the triangle vertices are actually given in clockwise -! order, this routine will behave as though the triangle contains -! no points whatsoever! -! -! The routine determines if a point P is "to the right of" each of the lines -! that bound the triangle. It does this by computing the cross product -! of vectors from a vertex to its next vertex, and to P. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 June 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! The vertices should be given in counter clockwise order. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is -! inside the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) inside - integer(kind=4) j - integer(kind=4) k - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) - - do j = 1, 3 - - k = mod(j, 3) + 1 - - if (0.0D+00 < (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & - - (p(2) - t(2, j)) * (t(1, k) - t(1, j))) then - inside = .false. - return - end if - - end do - - inside = .true. - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_contains_point_2d_3(t, p, inside) - -! -!! TRIANGLE_CONTAINS_POINT_2D_3 finds if a point is inside a triangle in 2D. -! -! Discussion: -! -! This routine is the same as TRIANGLE_CONTAINS_POINT_2D_2, except -! that it does not assume an ordering of the points. It should -! work correctly whether the vertices of the triangle are listed -! in clockwise or counter clockwise order. -! -! The routine determines if a point P is "to the right of" each of the lines -! that bound the triangle. It does this by computing the cross product -! of vectors from a vertex to its next vertex, and to P. -! -! The point is inside the triangle if it is to the right of all -! the lines, or to the left of all the lines. -! -! This version was suggested by Paulo Ernesto of Maptek Brasil. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 June 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is -! inside the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dir_new - real(kind=8) dir_old - logical(kind=4) inside - integer(kind=4) j - integer(kind=4) k - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) - - dir_old = 0.0D+00 - - do j = 1, 3 - - k = mod(j, 3) + 1 - - dir_new = (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & - - (p(2) - t(2, j)) * (t(1, k) - t(1, j)) - - if (dir_new * dir_old < 0.0D+00) then - inside = .false. - return - end if - - if (dir_new /= 0.0D+00) then - dir_old = dir_new - end if - - end do - - inside = .true. - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_diameter_2d(t, diameter) - -! -!! TRIANGLE_DIAMETER_2D computes the diameter of a triangle in 2D. -! -! Discussion: -! -! The diameter of a triangle is the diameter of the smallest circle -! that can be drawn around the triangle. At least two of the vertices -! of the triangle will intersect the circle, but not necessarily -! all three! -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) DIAMETER, the diameter of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) asq - real(kind=8) b - real(kind=8) bsq - real(kind=8) c - real(kind=8) csq - real(kind=8) diameter - real(kind=8) t(dim_num, 3) -! -! Compute the squared length of each side. -! - asq = sum(t(1:dim_num, 1) - t(1:dim_num, 2))**2 - bsq = sum(t(1:dim_num, 2) - t(1:dim_num, 3))**2 - csq = sum(t(1:dim_num, 3) - t(1:dim_num, 1))**2 -! -! Take care of a zero side. -! - if (asq == 0.0D+00) then - diameter = sqrt(bsq) - return - else if (bsq == 0.0D+00) then - diameter = sqrt(csq) - return - else if (csq == 0.0D+00) then - diameter = sqrt(asq) - return - end if -! -! Make ASQ the largest. -! - if (asq < bsq) then - call r8_swap(asq, bsq) - end if - - if (asq < csq) then - call r8_swap(asq, csq) - end if -! -! If ASQ is very large... -! - if (bsq + csq < asq) then - - diameter = sqrt(asq) - - else - - a = sqrt(asq) - b = sqrt(bsq) - c = sqrt(csq) - - diameter = 2.0D+00 * a * b * c / sqrt((a + b + c) * (-a + b + c) & - * (a - b + c) * (a + b - c)) - - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_edge_length_2d(t, edge_length) - -! -!! TRIANGLE_EDGE_LENGTH_2D returns edge lengths of a triangle in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 August 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) EDGE_LENGTH(3), the length of the edges. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) edge_length(3) - integer(kind=4) i4_wrap - integer(kind=4) j1 - integer(kind=4) j2 - real(kind=8) r8vec_norm - real(kind=8) t(dim_num, 3) - - do j1 = 1, 3 - j2 = i4_wrap(j1 + 1, 1, 3) - edge_length(j1) = & - r8vec_norm(dim_num, t(1:dim_num, j2) - t(1:dim_num, j1)) - end do - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_gridpoints_2d(t, sub_num, grid_max, grid_num, g) - -! -!! TRIANGLE_GRIDPOINTS_2D computes gridpoints within a triangle in 2D. -! -! Discussion: -! -! The gridpoints are computed by repeated halving of the triangle. -! The 0-th set of grid points is the vertices themselves. -! The first set of grid points is the midpoints of the sides. -! These points can be used to draw 4 triangles that make up the original -! triangle. The second set of grid points is the side midpoints and -! centers -! of these four triangles. -! -! SUB_NUM GRID_NUM -! ----- ----- -! 0 1 = 1 (centroid) -! 1 1 + 2 = 3 (vertices) -! 2 1 + 2 + 3 = 6 -! 3 1 + 2 + 3 + 4 = 10 -! 4 1 + 2 + 3 + 4 + 5 = 15 -! -! GRID_NUM is the sum of the integers from 1 to SUB_NUM+1 or -! -! GRID_NUM = (SUB_NUM+1) * (SUB_NUM+2) / 2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, integer ( kind = 4 ) SUB_NUM, the number of subdivisions. -! -! Input, integer ( kind = 4 ) GRID_MAX, the maximum number of grid points. -! -! Output, integer ( kind = 4 ) GRID_NUM, the number of grid points returned. -! -! Output, real ( kind = 8 ) G(2,GRID_MAX), the grid points. -! - implicit none - - integer(kind=4) grid_max - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) g(dim_num, grid_max) - integer(kind=4) i - integer(kind=4) j - integer(kind=4) grid_num - integer(kind=4) sub_num - real(kind=8) t(dim_num, 3) - - grid_num = 0 -! -! Special case, SUB_NUM = 0. -! - if (sub_num == 0) then - if (1 <= grid_max) then - grid_num = 1 - g(1, 1) = (t(1, 1) + t(1, 2) + t(1, 3)) / 3.0D+00 - g(2, 1) = (t(2, 1) + t(2, 2) + t(2, 3)) / 3.0D+00 - end if - return - end if - - do i = 0, sub_num - - do j = 0, sub_num - i - - if (grid_num < grid_max) then - - grid_num = grid_num + 1 - - g(1, grid_num) = (real(i, kind=8) * t(1, 1) & - + real(j, kind=8) * t(1, 2) & - + real(sub_num - i - j, kind=8) * t(1, 3)) & - / real(sub_num, kind=8) - - g(2, grid_num) = (real(i, kind=8) * t(2, 1) & - + real(j, kind=8) * t(2, 2) & - + real(sub_num - i - j, kind=8) * t(2, 3)) & - / real(sub_num, kind=8) - end if - - end do - end do - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_incenter_2d(t, pc) - -! -!! TRIANGLE_INCENTER_2D computes the incenter of a triangle in 2D. -! -! Discussion: -! -! The incenter of a triangle is the center of the inscribed circle. -! -! The inscribed circle of a triangle is the largest circle that can -! be drawn inside the triangle. -! -! The inscribed circle is tangent to all three sides of the triangle. -! -! The angle bisectors of the triangle intersect at the center of the -! inscribed circle. -! -! In geometry, the incenter is often represented by "I". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 August 2003 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) PC(2), the incenter. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) pc(dim_num) - real(kind=8) perimeter - real(kind=8) t(dim_num, 3) -! -! Compute the length of each side. -! - a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) - b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) - c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - - perimeter = a + b + c - - if (perimeter == 0.0D+00) then - pc(1:dim_num) = t(1:dim_num, 1) - else - pc(1:dim_num) = (b * t(1:dim_num, 1) & - + c * t(1:dim_num, 2) & - + a * t(1:dim_num, 3)) / perimeter - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_incircle_2d(t, r, pc) - -! -!! TRIANGLE_INCIRCLE_2D computes the inscribed circle of a triangle in 2D. -! -! Discussion: -! -! The inscribed circle of a triangle is the largest circle that can -! be drawn inside the triangle. It is tangent to all three sides, -! and the lines from its center to the vertices bisect the angles -! made by each vertex. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 December 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) R, PC(2), the radius and center of the -! inscribed circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) pc(dim_num) - real(kind=8) perimeter - real(kind=8) r - real(kind=8) t(dim_num, 3) -! -! Compute the length of each side. -! - a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) - b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) - c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - - perimeter = a + b + c - - if (perimeter == 0.0D+00) then - pc(1:dim_num) = t(1:dim_num, 1) - r = 0.0D+00 - return - end if - - pc(1:dim_num) = ( & - b * t(1:dim_num, 1) & - + c * t(1:dim_num, 2) & - + a * t(1:dim_num, 3)) / perimeter - - r = 0.5D+00 * sqrt( & - (-a + b + c) & - * (+a - b + c) & - * (+a + b - c) / perimeter) - - return -end - -!---------------------------------------------------------------------------- -! - -!---------------------------------------------------------------------------- -subroutine triangle_inradius_2d(t, r) - -! -!! TRIANGLE_INRADIUS_2D: radius of the inscribed circle of a triangle in 2D. -! -! Discussion: -! -! The inscribed circle of a triangle is the largest circle that can -! be drawn inside the triangle. It is tangent to all three sides, -! and the lines from its center to the vertices bisect the angles -! made by each vertex. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 13 April 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) R, the radius of the inscribed circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) perimeter - real(kind=8) r - real(kind=8) t(dim_num, 3) -! -! Compute the length of each side. -! - a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) - b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) - c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - - perimeter = a + b + c - - if (perimeter == 0.0D+00) then - r = 0.0D+00 - return - end if - - r = 0.5D+00 * sqrt( & - (-a + b + c) & - * (+a - b + c) & - * (+a + b - c) / perimeter) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function triangle_is_degenerate_nd(dim_num, t) - -! -!! TRIANGLE_IS_DEGENERATE_ND finds if a triangle is degenerate in ND. -! -! Discussion: -! -! A triangle in ND is described by the coordinates of its 3 vertices. -! -! A triangle in ND is degenerate if any two vertices are equal. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) T(DIM_NUM,3), the triangle vertices. -! -! Output, logical ( kind = 4 ) TRIANGLE_IS_DEGENERATE_ND, is TRUE if the -! triangle is degenerate. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) t(dim_num, 3) - logical(kind=4) triangle_is_degenerate_nd - - triangle_is_degenerate_nd = & - (all(t(1:dim_num, 1) == t(1:dim_num, 2)) .or. & - all(t(1:dim_num, 2) == t(1:dim_num, 3)) .or. & - all(t(1:dim_num, 3) == t(1:dim_num, 1))) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_lattice_layer_point_next(c, v, more) - -!*****************************************************************************80 -! -!! TRIANGLE_LATTICE_LAYER_POINT_NEXT: next triangle lattice layer point. -! -! Discussion: -! -! The triangle lattice layer L is bounded by the lines -! -! 0 <= X, -! 0 <= Y, -! L - 1 < X / C(1) + Y / C(2) <= L. -! -! In particular, layer L = 0 always contains the single point (0,0). -! -! This function returns, one at a time, the points that lie within -! a given triangle lattice layer. -! -! Thus, if we set C(1) = 2, C(2) = 3, then we get the following layers: -! -! L = 0: (0,0) -! L = 1: (1,0), (2,0), (0,1), (1,1), (0,2), (0,3) -! L = 2: (3,0), (4,0), (2,1), (3,1), (1,2), (2,2), (1,3), (2,3), -! (0,4), (1,4), (0,5), (0,6). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) C(3), coefficients defining the -! lattice layer. Entry C(3) contains the layer index. -! C(1) and C(2) should be positive, and C(3) must be nonnegative. -! -! Input/output, integer ( kind = 4 ) V(2). On first call for a given layer, -! the input value of V is not important. On a repeated call for the same -! layer, the input value of V should be the output value from the previous -! call. On output, V contains the next lattice layer point. -! -! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to -! indicate that this is the first call for a given layer. Thereafter, the -! input value should be the output value from the previous call. On output, -! MORE is TRUE if the returned value V is a new point. -! If the output value is FALSE, then no more points were found, -! and V was reset to 0, and the lattice layer has been exhausted. -! - implicit none - - integer(kind=4) c(3) - integer(kind=4) c1n - integer(kind=4) i4vec_lcm - logical(kind=4) more - integer(kind=4), parameter :: n = 2 - integer(kind=4) rhs1 - integer(kind=4) rhs2 - integer(kind=4) v(2) -! -! Treat layer C(N+1) = 0 specially. -! - if (c(n + 1) == 0) then - if (.not. more) then - v(1:n) = 0 - more = .true. - else - more = .false. - end if - return - end if -! -! Compute first point. -! - if (.not. more) then - - v(1) = (c(n + 1) - 1) * c(1) + 1 - v(2) = 0 - more = .true. - - else - - c1n = i4vec_lcm(n, c) - - rhs1 = c1n * (c(n + 1) - 1) - rhs2 = c1n * c(n + 1) - - if (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs2) then - v(1) = v(1) + 1 - else - v(1) = (rhs1 - c(1) * (v(2) + 1)) / c(2) - v(1) = max(v(1), 0) - v(2) = v(2) + 1 - if (c(2) * v(1) + c(1) * v(2) <= rhs1) then - v(1) = v(1) + 1 - end if - if (c(2) * v(1) + c(1) * v(2) <= rhs2) then - - else - v(1:n) = 0 - more = .false. - end if - end if - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_lattice_point_next(c, v, more) - -!! TRIANGLE_LATTICE_POINT_NEXT returns the next triangle lattice point. -! -! Discussion: -! -! The lattice triangle is defined by the vertices: -! -! (0,0), (C(3)/C(1), 0) and (0,C(3)/C(2)) -! -! The lattice triangle is bounded by the lines -! -! 0 <= X, -! 0 <= Y -! X / C(1) + Y / C(2) <= C(3) -! -! Lattice points are listed one at a time, starting at the origin, -! with X increasing first. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) C(3), coefficients defining the -! lattice triangle. These should be positive. -! -! Input/output, integer ( kind = 4 ) V(2). On first call, the input -! value is not important. On a repeated call, the input value should -! be the output value from the previous call. On output, V contains -! the next lattice point. -! -! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to -! indicate that this is the first call for a given triangle. Thereafter, -! the input value should be the output value from the previous call. On -! output, MORE is TRUE if the returned value V is a new lattice point. -! If the output value is FALSE, then no more lattice points were found, -! and V was reset to 0, and the routine should not be called further -! for this triangle. -! - implicit none - - integer(kind=4) c(3) - integer(kind=4) c1n - integer(kind=4) i4vec_lcm - logical(kind=4) more - integer(kind=4), parameter :: n = 2 - integer(kind=4) rhs - integer(kind=4) v(2) - - if (.not. more) then - - v(1:n) = 0 - more = .true. - - else - - c1n = i4vec_lcm(n, c) - - rhs = c1n * c(n + 1) - - if (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs) then - v(1) = v(1) + 1 - else - v(1) = 0 - if (c(2) * v(1) + c(1) * (v(2) + 1) <= rhs) then - v(2) = v(2) + 1 - else - v(2) = 0 - more = .false. - end if - end if - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_line_imp_int_2d(t, a, b, c, int_num, pint) - -!*****************************************************************************80 -! -!! TRIANGLE_LINE_IMP_INT_2D: implicit line intersects a triangle in 2D. -! -! Discussion: -! -! An implicit line is the set of points ( X, Y ) satisfying -! -! A * X + B * Y + C = 0 -! -! where at least one of A and B is not zero. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, real ( kind = 8 ) A, B, C, determine the equation of the line: -! A*X + B*Y + C = 0. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of points of intersection -! of the line with the triangle. INT_NUM may be 0, 1, 2 or 3. -! -! Output, real ( kind = 8 ) PINT(2,3), contains the intersection points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) a1 - real(kind=8) b - real(kind=8) b1 - real(kind=8) c - real(kind=8) c1 - integer(kind=4) i - integer(kind=4) i4_wrap - integer(kind=4) int_num - integer(kind=4) ival - integer(kind=4) j - real(kind=8) p(dim_num) - real(kind=8) pint(dim_num, 3) - real(kind=8) t(dim_num, 3) - real(kind=8) test1 - real(kind=8) test2 - - int_num = 0 - - do i = 1, 3 - - j = i4_wrap(i + 1, 1, 3) -! -! Get the implicit form of the line through vertices I and I+1. -! - call line_exp2imp_2d(t(1:2, i), t(1:2, j), a1, b1, c1) -! -! Seek an intersection with the original line. -! - call lines_imp_int_2d(a, b, c, a1, b1, c1, ival, p) -! -! If there is an intersection, determine if it lies between the two vertices. -! - if (ival == 1) then - - test1 = sum((p(1:dim_num) - t(1:dim_num, i)) & - * (t(1:dim_num, j) - t(1:dim_num, i))) - test2 = sum((t(1:dim_num, j) - t(1:dim_num, i)) & - * (t(1:dim_num, j) - t(1:dim_num, i))) - - if (0 <= test1 .and. test1 <= test2) then - int_num = int_num + 1 - pint(1:dim_num, int_num) = p(1:dim_num) - end if - - end if - - end do - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function triangle_orientation_2d(t) - -! -!! TRIANGLE_ORIENTATION_2D determines the orientation of a triangle in 2D. -! -! Discussion: -! -! Three distinct non-colinear points in the plane define a circle. -! If the points are visited in the order P1, P2, and then -! P3, this motion defines a clockwise or counter clockwise -! rotation along the circle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, integer ( kind = 4 ) TRIANGLE_ORIENTATION_2D, reports if the -! three points lie clockwise on the circle that passes through them. -! The possible return values are: -! 0, the points are distinct, noncolinear, and lie counter clockwise -! on their circle. -! 1, the points are distinct, noncolinear, and lie clockwise -! on their circle. -! 2, the points are distinct and colinear. -! 3, at least two of the points are identical. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) det - integer(kind=4) triangle_orientation_2d - real(kind=8) t(dim_num, 3) - - if (all(t(1:dim_num, 1) == t(1:dim_num, 2)) .or. & - all(t(1:dim_num, 2) == t(1:dim_num, 3)) .or. & - all(t(1:dim_num, 3) == t(1:dim_num, 1))) then - triangle_orientation_2d = 3 - return - end if - - det = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & - - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) - - if (det == 0.0D+00) then - triangle_orientation_2d = 2 - else if (det < 0.0D+00) then - triangle_orientation_2d = 1 - else if (0.0D+00 < det) then - triangle_orientation_2d = 0 - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_orthocenter_2d(t, pc) - -! -!! TRIANGLE_ORTHOCENTER_2D computes the orthocenter of a triangle in 2D. -! -! Discussion: -! -! The orthocenter is defined as the intersection of the three altitudes -! of a triangle. -! -! An altitude of a triangle is the line through a vertex of the triangle -! and perpendicular to the opposite side. -! -! In geometry, the orthocenter of a triangle is often symbolized by "H". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 31 July 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) PC(2), the orthocenter of the triangle. -! -! Output, logical ( kind = 4 ) FLAG, is TRUE if the value could not -! be computed. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) flag - integer(kind=4) ival - real(kind=8) p23(dim_num) - real(kind=8) p31(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r8_huge - real(kind=8) t(dim_num, 3) -! -! Determine a point P23 common to the line (P2,P3) and -! its perpendicular through P1. -! - call line_exp_perp_2d(t(1:2, 2), t(1:2, 3), t(1:2, 1), p23, flag) - - if (flag) then - pc(1:2) = r8_huge() - return - end if -! -! Determine a point P31 common to the line (P3,P1) and -! its perpendicular through P2. -! - call line_exp_perp_2d(t(1:2, 3), t(1:2, 1), t(1:2, 2), p31, flag) - - if (flag) then - pc(1:2) = r8_huge() - return - end if -! -! Determine PC, the intersection of the lines (P1,P23) and (P2,P31). -! - call lines_exp_int_2d(t(1:2, 1), p23(1:2), t(1:2, 2), p31(1:2), ival, pc) - - if (ival /= 1) then - pc(1:2) = r8_huge() - flag = .true. - return - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_point_dist_2d(t, p, dist) - -! -!! TRIANGLE_POINT_DIST_2D: distance ( triangle, point ) in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4), parameter :: side_num = 3 - - real(kind=8) dist - real(kind=8) dist2 - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, side_num) -! -! Find the distance to each of the line segments. -! - dist = huge(dist) - - do j = 1, side_num - - jp1 = i4_wrap(j + 1, 1, side_num) - - call segment_point_dist_2d(t(1:dim_num, j), t(1:dim_num, jp1), p, dist2) - - if (dist2 < dist) then - dist = dist2 - end if - - end do - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_point_dist_3d(t, p, dist) - -! -!! TRIANGLE_POINT_DIST_3D: distance ( triangle, point ) in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the triangle vertices. -! -! Input, real ( kind = 8 ) P(3), the point which is to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! triangle. DIST is zero if the point lies exactly on the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dist - real(kind=8) dist2 - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) -! -! Compute the distances from the point to each of the sides. -! - call segment_point_dist_3d(t(1:dim_num, 1), t(1:dim_num, 2), p, dist2) - - dist = dist2 - - call segment_point_dist_3d(t(1:dim_num, 2), t(1:dim_num, 3), p, dist2) - - dist = min(dist, dist2) - - call segment_point_dist_3d(t(1:dim_num, 3), t(1:dim_num, 1), p, dist2) - - dist = min(dist, dist2) - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_point_dist_signed_2d(t, p, dist_signed) - -! -!! TRIANGLE_POINT_DIST_SIGNED_2D: signed distance ( triangle, point ) in 2D. -! -! Discussion: -! -! If the signed distance is: -! 0, the point is on the boundary of the triangle; -! negative, the point is in the triangle; -! positive, the point is outside the triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! These should be given in counter clockwise order. -! -! Input, real ( kind = 8 ) P(2), the point which is to be checked. -! -! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the -! point to the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dis12 - real(kind=8) dis23 - real(kind=8) dis31 - real(kind=8) dist_signed - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) -! -! Compute the signed line distances to the point. -! - call line_exp_point_dist_signed_2d(t(1:2, 1), t(1:2, 2), p, dis12) - - call line_exp_point_dist_signed_2d(t(1:2, 2), t(1:2, 3), p, dis23) - - call line_exp_point_dist_signed_2d(t(1:2, 3), t(1:2, 1), p, dis31) -! -! If the point is inside the triangle, all the line distances are negative. -! The largest (negative) line distance has the smallest magnitude, -! and is the signed triangle distance. -! - if (dis12 <= 0.0D+00 .and. dis23 <= 0.0D+00 .and. dis31 <= 0.0D+00) then - dist_signed = max(dis12, dis23, dis31) -! -! If the point is outside the triangle, then we have to compute -! the (positive) line segment distances and take the minimum. -! - else - - call segment_point_dist_2d(t(1:2, 1), t(1:2, 2), p, dis12) - call segment_point_dist_2d(t(1:2, 2), t(1:2, 3), p, dis23) - call segment_point_dist_2d(t(1:2, 3), t(1:2, 1), p, dis31) - - dist_signed = min(dis12, dis23, dis31) - - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_point_near_2d(t, p, pn, dist) - -! -!! TRIANGLE_POINT_NEAR_2D computes the nearest point on a triangle in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, real ( kind = 8 ) P(2), the point whose nearest triangle point -! is to be determined. -! -! Output, real ( kind = 8 ) PN(2), the nearest point to P. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4), parameter :: side_num = 3 - - real(kind=8) dist - real(kind=8) dist2 - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) pn2(dim_num) - real(kind=8) t(dim_num, side_num) - real(kind=8) tval -! -! Find the distance to each of the line segments that make up the edges -! of the triangle. -! - dist = huge(dist) - pn(1:dim_num) = 0.0D+00 - - 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) - - if (dist2 < dist) then - dist = dist2 - pn(1:dim_num) = pn2(1:dim_num) - end if - - end do - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_quality_2d(t, quality) - -! -!! TRIANGLE_QUALITY_2D: "quality" of a triangle in 2D. -! -! Discussion: -! -! The quality of a triangle is 2.0 times the ratio of the radius of -! the inscribed circle divided by that of the circumscribed circle. -! An equilateral triangle achieves the maximum possible quality of 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 31 July 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Output, real ( kind = 8 ) QUALITY, the quality of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) quality - real(kind=8) t(dim_num, 3) -! -! Compute the length of each side. -! - a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) - b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) - c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - - if (a * b * c == 0.0D+00) then - quality = 0.0D+00 - else - quality = (-a + b + c) * (a - b + c) * (a + b - c) & - / (a * b * c) - end if - - return -end - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -subroutine triangle_right_lattice_point_num_2d(a, b, n) - -! -!! TRIANGLE_RIGHT_LATTICE_POINT_NUM_2D: count lattice points. -! -! Discussion: -! -! The triangle is assumed to be a right triangle which, without loss -! of generality, has the coordinates: -! -! ( (0,0), (a,0), (0,b) ) -! -! The routine returns the number of integer lattice points that appear -! inside the triangle or on its edges or vertices. -! -! The formula for this function occurred to me (JVB) after some thought, -! on 06 July 2009. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) A, B, define the vertices. -! -! Output, integer ( kind = 4 ) N, the number of lattice points. -! - implicit none - - integer(kind=4) a - integer(kind=4) b - integer(kind=4) i4_gcd - integer(kind=4) n - - n = ((a + 1) * (b + 1) + i4_gcd(a, b) + 1) / 2 - - return -end -subroutine triangle_sample(t, n, seed, p) - -!*****************************************************************************80 -! -!! TRIANGLE_SAMPLE returns random points in a triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 April 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, integer ( kind = 4 ) N, the number of points to generate. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, real ( kind = 8 ) P(2,N), random points in the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4) n - - real(kind=8) alpha(n) - integer(kind=4) dim - real(kind=8) p(dim_num, n) - real(kind=8) p12(dim_num, n) - real(kind=8) p13(dim_num, n) - integer(kind=4) seed - real(kind=8) t(dim_num, 3) -! -! For comparison between F90, C++ and MATLAB codes, call R8VEC_UNIFORM_01. -! For faster execution, call RANDOM_NUMBER. -! - if (.true.) then - - call r8vec_uniform_01(n, seed, alpha) - - else - - call random_number(harvest=alpha(1:n)) - - end if -! -! Interpret R as a percentage of the triangle's area. -! -! Imagine a line L, parallel to side 1, so that the area between -! vertex 1 and line L is R percent of the full triangle's area. -! -! The line L will intersect sides 2 and 3 at a fraction -! ALPHA = SQRT ( R ) of the distance from vertex 1 to vertices 2 and 3. -! - alpha(1:n) = sqrt(alpha(1:n)) -! -! Determine the coordinates of the points on sides 2 and 3 intersected -! by line L. -! - do dim = 1, dim_num - - p12(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & - + alpha(1:n) * t(dim, 2) - - p13(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & - + alpha(1:n) * t(dim, 3) - - end do -! -! Now choose, uniformly at random, a point on the line L. -! -! For comparison between F90, C++ and MATLAB codes, call R8VEC_UNIFORM_01. -! For faster execution, call RANDOM_NUMBER. -! - if (.true.) then - - call r8vec_uniform_01(n, seed, alpha) - - else - - call random_number(harvest=alpha(1:n)) - - end if - - do dim = 1, dim_num - - p(dim, 1:n) = (1.0D+00 - alpha(1:n)) * p12(dim, 1:n) & - + alpha(1:n) * p13(dim, 1:n) - - end do - - return -end -subroutine triangle01_lattice_point_num_2d(s, n) - -!*****************************************************************************80 -! -!! TRIANGLE01_LATTICE_POINT_NUM_2D: count lattice points. -! -! Discussion: -! -! The triangle is assumed to be the unit triangle: -! -! ( (0,0), (1,0), (0,1) ) -! -! or a copy of this triangle scaled by an integer S: -! -! ( (0,0), (S,0), (0,S) ). -! -! The routine returns the number of integer lattice points that appear -! inside the triangle or on its edges or vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 July 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Matthias Beck, Sinai Robins, -! Computing the Continuous Discretely, -! Springer, 2006, -! ISBN13: 978-0387291390, -! LC: QA640.7.B43. -! -! Parameters: -! -! Input, integer ( kind = 4 ) S, the scale factor. -! -! Output, integer ( kind = 4 ) N, the number of lattice points. -! - implicit none - - integer(kind=4) n - integer(kind=4) s - - n = ((s + 2) * (s + 1)) / 2 - - return -end -subroutine triangle_xsi_to_xy_2d(t, xsi, p) - -!*****************************************************************************80 -! -!! TRIANGLE_XSI_TO_XY_2D converts from barycentric to XY coordinates in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, real ( kind = 8 ) XSI(3), the barycentric coordinates of a point. -! XSI(1) + XSI(2) + XSI(3) should equal 1, but this is not checked. -! -! Output, real ( kind = 8 ) P(2), the XY coordinates of the point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) - real(kind=8) xsi(dim_num + 1) - - p(1:dim_num) = matmul(t(1:dim_num, 1:3), xsi(1:dim_num + 1)) - - return -end -subroutine triangle_xy_to_xsi_2d(t, p, xsi) - -!*****************************************************************************80 -! -!! TRIANGLE_XY_TO_XSI_2D converts from XY to barycentric in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(2,3), the triangle vertices. -! -! Input, real ( kind = 8 ) P(2), the XY coordinates of a point. -! -! Output, real ( kind = 8 ) XSI(3), the barycentric coordinates of the point. -! XSI1 + XSI2 + XSI3 should equal 1. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) det - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) - real(kind=8) xsi(3) - - det = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & - - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) - - xsi(1) = ((t(2, 2) - t(2, 3)) * (p(1) - t(1, 3)) & - - (t(1, 2) - t(1, 3)) * (p(2) - t(2, 3))) / det - - xsi(2) = (-(t(2, 1) - t(2, 3)) * (p(1) - t(1, 3)) & - + (t(1, 1) - t(1, 3)) * (p(2) - t(2, 3))) / det - - xsi(3) = 1.0D+00 - xsi(1) - xsi(2) - - return -end diff --git a/src/modules/Geometry/src/assets/geometry_by_burkardt.inc b/src/modules/Geometry/src/assets/geometry_by_burkardt.inc deleted file mode 100644 index 8cba7d6f7..000000000 --- a/src/modules/Geometry/src/assets/geometry_by_burkardt.inc +++ /dev/null @@ -1,34798 +0,0 @@ -subroutine angle_box_2d(dist, p1, p2, p3, p4, p5) - -!*****************************************************************************80 -! -!! ANGLE_BOX_2D "boxes" an angle defined by three points in 2D. -! -! Discussion: -! -! The routine is given points P1, P2 and P3, determining the two lines: -! P1 to P2 -! and -! P2 to P3 -! and a nonnegative distance -! DIST. -! -! The routine returns a pair of "corner" points -! P4 and P5 -! both of which are a distance DIST from both lines, and in fact, -! both of which are a distance DIST from P2. -! -! / P3 -! / / / -! - - - - - - - - -P4 - / -P6 - - - -! / / / -! P1---------------/--P2----------------- -! / / / -! - - - - - - -P7 - / -P5 - - - - - -! / / / -! -! In the illustration, P1, P2 and P3 are the points defining the lines. -! -! P4 and P5 represent the desired "corner points", which -! are on the positive or negative sides of both lines. -! -! P6 and P7 represent the undesired points, which -! are on the positive side of one line and the negative of the other. -! -! Special cases: -! -! if P1 = P2, this is the same as extending the line from -! P3 through P2 without a bend. -! -! if P3 = P2, this is the same as extending the line from -! P1 through P2 without a bend. -! -! if P1 = P2 = P3 this is an error. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DIST, the nonnegative distance from P1 -! to the computed points P4 and P5. -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2). -! P1 and P2 are distinct points that define a line. -! P2 and P3 are distinct points that define a line. -! -! Output, real ( kind = 8 ) P4(2), P5(2), points which lie DIST units from -! the line between P1 and P2, and from the line between P2 and P3. -! - implicit none - - real(kind=8) dist - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) p3(2) - real(kind=8) p4(2) - real(kind=8) p5(2) - real(kind=8) stheta - real(kind=8) temp1 - real(kind=8) temp2 - real(kind=8) u(2) - real(kind=8) u1(2) - real(kind=8) u2(2) -! -! If DIST = 0, assume the user knows best. -! - if (dist == 0.0D+00) then - p4(1:2) = p2(1:2) - p5(1:2) = p2(1:2) - return - end if -! -! Fail if all three points are equal. -! - if (all(p1(1:2) == p2(1:2)) .and. & - all(p2(1:2) == p3(1:2))) then - write (*, '(a)') ' ' - write (*, '(a)') 'ANGLE_BOX_2D - Fatal error!' - write (*, '(a)') ' Input points P1 = P2 = P3.' - write (*, '(a,2g14.6)') ' P1 = ', p1(1:2) - stop 1 - end if -! -! If P1 = P2, extend the line through the doubled point. -! - if (all(p1(1:2) == p2(1:2))) then - u2(1) = p3(2) - p2(2) - u2(2) = p2(1) - p3(1) - temp1 = sqrt(sum(u2(1:2)**2)) - u2(1:2) = u2(1:2) / temp1 - p4(1:2) = p2(1:2) + dist * u2(1:2) - p5(1:2) = p2(1:2) - dist * u2(1:2) - return - end if -! -! If P2 = P3, extend the line through the doubled point. -! - if (all(p2(1:2) == p3(1:2))) then - u1(1) = p1(2) - p2(2) - u1(2) = p2(1) - p1(1) - temp1 = sqrt(sum(u1(1:2)**2)) - u1(1:2) = u1(1:2) / temp1 - p4(1:2) = p2(1:2) + dist * u1(1:2) - p5(1:2) = p2(1:2) - dist * u1(1:2) - return - end if -! -! Compute the unit normal vectors to each line. -! We choose the sign so that the unit normal to line 1 has -! a positive dot product with line 2. -! - u1(1) = p1(2) - p2(2) - u1(2) = p2(1) - p1(1) - temp1 = sqrt(sum(u1(1:2)**2)) - u1(1:2) = u1(1:2) / temp1 - - temp1 = dot_product(u1(1:2), p3(1:2) - p2(1:2)) - - if (temp1 < 0.0D+00) then - u1(1:2) = -u1(1:2) - end if - - u2(1) = p3(2) - p2(2) - u2(2) = p2(1) - p3(1) - temp1 = sqrt(sum(u2(1:2)**2)) - u2(1:2) = u2(1:2) / temp1 - - temp1 = dot_product(u2(1:2), p1(1:2) - p2(1:2)) - if (temp1 < 0.0D+00) then - u2(1:2) = -u2(1:2) - end if -! -! Try to catch the case where we can't determine the -! sign of U1, because both U1 and -U1 are perpendicular -! to (P3-P2)...and similarly for U2 and (P1-P2). -! - temp1 = dot_product(u1(1:2), p3(1:2) - p2(1:2)) - temp2 = dot_product(u2(1:2), p1(1:2) - p2(1:2)) - - if (temp1 == 0.0D+00 .or. temp2 == 0.0D+00) then - - if (dot_product(u1(1:2), u2(1:2)) < 0.0D+00) then - u1(1:2) = -u1(1:2) - end if - - end if -! -! Try to catch a line turning back on itself, evidenced by -! Cos(theta) = (P3-P2) dot (P2-P1) / ( norm(P3-P2) * norm(P2-P1) ) -! being -1, or very close to -1. -! - temp1 = dot_product(p3(1:2) - p2(1:2), p2(1:2) - p1(1:2)) - - temp1 = temp1 / & - (sqrt(sum((p3(1:2) - p2(1:2))**2)) & - * sqrt(sum((p2(1:2) - p1(1:2))**2))) - - if (temp1 < -0.99D+00) then - temp1 = sqrt(sum((p2(1:2) - p1(1:2))**2)) - p4(1:2) = p2(1:2) + dist * (p2(1:2) - p1(1:2)) & - / temp1 + dist * u1(1:2) - p5(1:2) = p2(1:2) + dist * (p2(1:2) - p1(1:2)) & - / temp1 - dist * u1(1:2) - return - end if -! -! Compute the "average" unit normal vector. -! -! The average of the unit normals could be zero, but only when -! the second line has the same direction and opposite sense -! of the first, and we've already checked for that case. -! -! Well, check again! This problem "bit" me in the case where -! P1 = P2, which I now treat specially just to guarantee I -! avoid this problem! -! - if (dot_product(u1(1:2), u2(1:2)) < 0.0D+00) then - u2(1:2) = -u2(1:2) - end if - - u(1:2) = 0.5D+00 * (u1(1:2) + u2(1:2)) - temp1 = sqrt(sum(u(1:2)**2)) - u(1:2) = u(1:2) / temp1 -! -! You must go DIST/STHETA units along this unit normal to -! result in a distance DIST from line1 (and line2). -! - stheta = dot_product(u(1:2), u1(1:2)) - - p4(1:2) = p2(1:2) + dist * u(1:2) / stheta - p5(1:2) = p2(1:2) - dist * u(1:2) / stheta - - return -end -subroutine angle_contains_point_2d(p1, p2, p3, p, inside) - -!*****************************************************************************80 -! -!! ANGLE_CONTAINS_POINT_2D determines if an angle contains a point, in 2D. -! -! Discussion: -! -! The angle is defined by the sequence of points P1, P2 and P3. -! -! The point is "contained" by the angle if the ray P - P2 -! is between (in a counter clockwise sense) the rays P1 - P2 -! and P3 - P2. -! -! P1 -! / -! / P -! / . -! / . -! P2--------->P3 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the coordinates of -! three points that define the angle. The order of these points matters! -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside -! the angle. -! - implicit none - - real(kind=8) angle_rad_2d - logical(kind=4) inside - real(kind=8) p(2) - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) p3(2) - - if (angle_rad_2d(p1, p2, p) <= angle_rad_2d(p1, p2, p3)) then - inside = .true. - else - inside = .false. - end if - - return -end -function angle_deg_2d(p1, p2, p3) - -!*****************************************************************************80 -! -!! ANGLE_DEG_2D returns the angle swept out between two rays in 2D. -! -! Discussion: -! -! Except for the zero angle case, it should be true that -! -! ANGLE_DEG_2D ( P1, P2, P3 ) + ANGLE_DEG_2D ( P3, P2, P1 ) = 360.0 -! -! P1 -! / -! / -! / -! / -! P2--------->P3 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), define the rays -! P1 - P2 and P3 - P2 which define the angle. -! -! Output, real ( kind = 8 ) ANGLE_DEG_2D, the angle swept out by the -! rays, measured in degrees. 0 <= ANGLE_DEG_2D < 360. If either ray -! has zero length, then ANGLE_DEG_2D is set to 0. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle_deg_2d - real(kind=8) angle_rad_2d - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radians_to_degrees - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - - p(1) = (p3(1) - p2(1)) * (p1(1) - p2(1)) & - + (p3(2) - p2(2)) * (p1(2) - p2(2)) - - p(2) = (p3(1) - p2(1)) * (p1(2) - p2(2)) & - - (p3(2) - p2(2)) * (p1(1) - p2(1)) - - if (p(1) == 0.0D+00 .and. p(2) == 0.0D+00) then - angle_deg_2d = 0.0D+00 - return - end if - - angle_rad_2d = atan2(p(2), p(1)) - - if (angle_rad_2d < 0.0D+00) then - angle_rad_2d = angle_rad_2d + 2.0D+00 * r8_pi - end if - - angle_deg_2d = radians_to_degrees(angle_rad_2d) - - return -end -subroutine angle_half_2d(p1, p2, p3, p4) - -!*****************************************************************************80 -! -!! ANGLE_HALF_2D finds half an angle in 2D. -! -! Discussion: -! -! The original angle is defined by the sequence of points P1, P2 and P3. -! -! The point P4 is calculated so that: -! -! (P1,P2,P4) = (P1,P2,P3) / 2 -! -! P1 -! / -! / P4 -! / . -! / . -! P2--------->P3 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), points defining the angle. -! -! Input, real ( kind = 8 ) P4(2), a point defining the half angle. -! The vector P4 - P2 will have unit norm. -! - implicit none - - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) p3(2) - real(kind=8) p4(2) - - p4(1:2) = 0.5D+00 * ( & - (p1(1:2) - p2(1:2)) / sqrt(sum((p1(1:2) - p2(1:2))**2)) & - + (p3(1:2) - p2(1:2)) / sqrt(sum((p3(1:2) - p2(1:2))**2))) - - p4(1:2) = p2(1:2) + p4(1:2) / sqrt(sum(p4(1:2)**2)) - - return -end -function angle_rad_2d(p1, p2, p3) - -!*****************************************************************************80 -! -!! ANGLE_RAD_2D returns the angle in radians swept out between two rays in 2D. -! -! Discussion: -! -! Except for the zero angle case, it should be true that -! -! ANGLE_RAD_2D ( P1, P2, P3 ) + ANGLE_RAD_2D ( P3, P2, P1 ) = 2 * PI -! -! P1 -! / -! / -! / -! / -! P2--------->P3 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), define the rays -! P1 - P2 and P3 - P2 which define the angle. -! -! Output, real ( kind = 8 ) ANGLE_RAD_2D, the angle swept out by the rays, -! in radians. 0 <= ANGLE_RAD_2D < 2 * PI. If either ray has zero -! length, then ANGLE_RAD_2D is set to 0. -! - implicit none - - real(kind=8) angle_rad_2d - real(kind=8) p(2) - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) p3(2) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - p(1) = (p3(1) - p2(1)) * (p1(1) - p2(1)) & - + (p3(2) - p2(2)) * (p1(2) - p2(2)) - - p(2) = (p3(1) - p2(1)) * (p1(2) - p2(2)) & - - (p3(2) - p2(2)) * (p1(1) - p2(1)) - - if (all(p(1:2) == 0.0D+00)) then - angle_rad_2d = 0.0D+00 - return - end if - - angle_rad_2d = atan2(p(2), p(1)) - - if (angle_rad_2d < 0.0D+00) then - angle_rad_2d = angle_rad_2d + 2.0D+00 * r8_pi - end if - - return -end -function angle_rad_3d(p1, p2, p3) - -!*****************************************************************************80 -! -!! ANGLE_RAD_3D returns the angle in radians between two rays in 3D. -! -! Discussion: -! -! The routine always computes the SMALLER of the two angles between -! two rays. Thus, if the rays make an (exterior) angle of -! 1.5 pi radians, the (interior) angle of 0.5 pi radians will be reported. -! -! X dot Y = Norm(X) * Norm(Y) * Cos ( Angle(X,Y) ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), points defining an angle. -! The rays are P1 - P2 and P3 - P2. -! -! Output, real ( kind = 8 ) ANGLE_RAD_3D, the angle between the two rays, -! in radians. This value will always be between 0 and PI. If either ray has -! zero length, then the angle is returned as zero. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) angle_rad_3d - real(kind=8) dot - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) r8_acos - real(kind=8) v1norm - real(kind=8) v2norm - - v1norm = sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) - - if (v1norm == 0.0D+00) then - angle_rad_3d = 0.0D+00 - return - end if - - v2norm = sqrt(sum((p3(1:dim_num) - p2(1:dim_num))**2)) - - if (v2norm == 0.0D+00) then - angle_rad_3d = 0.0D+00 - return - end if - - dot = sum((p1(1:dim_num) - p2(1:dim_num)) & - * (p3(1:dim_num) - p2(1:dim_num))) - - angle_rad_3d = r8_acos(dot / (v1norm * v2norm)) - - return -end -function angle_rad_nd(dim_num, v1, v2) - -!*****************************************************************************80 -! -!! ANGLE_RAD_ND returns the angle in radians between two rays in ND. -! -! Discussion: -! -! This routine always computes the SMALLER of the two angles between -! two rays. Thus, if the rays make an (exterior) angle of 1.5 PI, -! then the (interior) angle of 0.5 PI is reported. -! -! X dot Y = Norm(X) * Norm(Y) * Cos( Angle(X,Y) ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the two rays. -! -! Output, real ( kind = 8 ) ANGLE_RAD_ND, the angle between the rays, -! in radians. This value will always be between 0 and PI. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) angle_rad_nd - real(kind=8) dot - real(kind=8) r8_acos - real(kind=8) v1(dim_num) - real(kind=8) v1norm - real(kind=8) v2(dim_num) - real(kind=8) v2norm - - dot = dot_product(v1(1:dim_num), v2(1:dim_num)) - - v1norm = sqrt(sum(v1(1:dim_num)**2)) - - if (v1norm == 0.0D+00) then - angle_rad_nd = 0.0D+00 - return - end if - - v2norm = sqrt(sum(v2(1:dim_num)**2)) - - if (v2norm == 0.0D+00) then - angle_rad_nd = 0.0D+00 - return - end if - - angle_rad_nd = r8_acos(dot / (v1norm * v2norm)) - - return -end -subroutine angle_turn_2d(p1, p2, p3, turn) - -!*****************************************************************************80 -! -!! ANGLE_TURN_2D computes a turning angle in 2D. -! -! Discussion: -! -! This routine is most useful when considering the vertices of a -! polygonal shape. We wish to distinguish between angles that "turn -! in" to the shape, (between 0 and 180 degrees) and angles that -! "turn out" (between 180 and 360 degrees), as we traverse the boundary. -! -! If we compute the interior angle and subtract 180 degrees, we get the -! supplementary angle, which has the nice property that it is -! negative for "in" angles and positive for "out" angles, and is zero if -! the three points actually lie along a line. -! -! Assuming P1, P2 and P3 define an angle, the TURN can be -! defined to be either: -! -! * the supplementary angle to the angle formed by P1=P2=P3, or -! -! * the angle between the vector ( P3-P2) and the vector -(P1-P2), -! where -(P1-P2) can be understood as the vector that continues -! through P2 from the direction P1. -! -! The turning will be zero if P1, P2 and P3 lie along a straight line. -! -! It will be a positive angle if the turn from the previous direction -! is counter clockwise, and negative if it is clockwise. -! -! The turn is given in radians, and will lie between -PI and PI. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 13 August 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the points that form -! the angle. -! -! Output, real ( kind = 8 ) TURN, the turn angle, between -PI and PI. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) r8_atan - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) turn - - p(1) = (p3(1) - p2(1)) * (p1(1) - p2(1)) & - + (p3(2) - p2(2)) * (p1(2) - p2(2)) - - p(2) = (p3(1) - p2(1)) * (p1(2) - p2(2)) & - - (p3(2) - p2(2)) * (p1(1) - p2(1)) - - if (p(1) == 0.0D+00 .and. p(2) == 0.0D+00) then - turn = 0.0D+00 - else - turn = r8_pi - r8_atan(p(2), p(1)) - end if - - return -end -subroutine annulus_area_2d(r1, r2, area) - -!*****************************************************************************80 -! -!! ANNULUS_AREA_2D computes the area of a circular annulus in 2D. -! -! Discussion: -! -! A circular annulus with center (XC,YC), inner radius R1 and -! outer radius R2, is the set of points (X,Y) so that -! -! R1^2 <= (X-XC)^2 + (Y-YC)^2 <= R2^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the inner and outer radii. -! -! Output, real ( kind = 8 ) AREA, the area. -! - implicit none - - real(kind=8) area - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - area = r8_pi * (r2 + r1) * (r2 - r1) - - return -end -subroutine annulus_sector_area_2d(r1, r2, theta1, theta2, area) - -!*****************************************************************************80 -! -!! ANNULUS_SECTOR_AREA_2D computes the area of an annular sector in 2D. -! -! Discussion: -! -! An annular sector with center PC, inner radius R1 and -! outer radius R2, and angles THETA1, THETA2, is the set of points -! P so that -! -! R1^2 <= (P(1)-PC(1))^2 + (P(2)-PC(2))^2 <= R2^2 -! -! and -! -! THETA1 <= THETA ( P - PC ) <= THETA2 -! -! Modified: -! -! 02 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the inner and outer radii. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles. -! -! Output, real ( kind = 8 ) AREA, the area. -! - implicit none - - real(kind=8) area - real(kind=8) r1 - real(kind=8) r2 - real(kind=8) theta1 - real(kind=8) theta2 - - area = 0.5D+00 * (theta2 - theta1) * (r2 + r1) * (r2 - r1) - - return -end -subroutine annulus_sector_centroid_2d(pc, r1, r2, theta1, theta2, centroid) - -!*****************************************************************************80 -! -!! ANNULUS_SECTOR_CENTROID_2D computes the centroid of an annular sector in 2D. -! -! Discussion: -! -! An annular sector with center PC, inner radius R1 and -! outer radius R2, and angles THETA1, THETA2, is the set of points -! P so that -! -! R1^2 <= (P(1)-PC(1))^2 + (P(2)-PC(2))^2 <= R2^2 -! -! and -! -! THETA1 <= THETA ( P - PC ) <= THETA2 -! -! Thanks to Ed Segall for pointing out a mistake in the computation -! of the angle THETA associated with the centroid. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 December 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! John Harris, Horst Stocker, -! Handbook of Mathematics and Computational Science, -! Springer, 1998, QA40.S76 -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(2), the center. -! -! Input, real ( kind = 8 ) R1, R2, the inner and outer radii. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles. -! -! Output, real ( kind = 8 ) CENTROID(2), the centroid. -! - implicit none - - real(kind=8) centroid(2) - real(kind=8) pc(2) - real(kind=8) r - real(kind=8) r1 - real(kind=8) r2 - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - - theta = theta2 - theta1 - - r = 4.0D+00 * sin(theta / 2.0D+00) / (3.0D+00 * theta) & - * (r1 * r1 + r1 * r2 + r2 * r2) / (r1 + r2) - - centroid(1) = pc(1) + r * cos(theta1 + theta / 2.0D+00) - centroid(2) = pc(2) + r * sin(theta1 + theta / 2.0D+00) - - return -end -subroutine ball01_sample_2d(seed, p) - -!*****************************************************************************80 -! -!! BALL01_SAMPLE_2D picks a random point in the unit ball in 2D. -! -! Discussion: -! -! The unit ball is the set of points P such that -! -! P(1) * P(1) + P(2) * P(2) <= 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 August 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, real ( kind = 8 ) P(2), a random point in the unit ball. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) p(dim_num) - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seed - real(kind=8) theta - real(kind=8) u(dim_num) - - call r8vec_uniform_01(dim_num, seed, u) - - r = sqrt(u(1)) - theta = 2.0D+00 * r8_pi * u(2) - - p(1) = r * cos(theta) - p(2) = r * sin(theta) - - return -end -subroutine ball01_sample_3d(seed, p) - -!*****************************************************************************80 -! -!! BALL01_SAMPLE_3D picks a random point in the unit ball in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 August 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, real ( kind = 8 ) P(3), the sample point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) p(dim_num) - real(kind=8) phi - real(kind=8) r - real(kind=8) r8_acos - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seed - real(kind=8) theta - real(kind=8) u(dim_num) - real(kind=8) vdot - - call r8vec_uniform_01(dim_num, seed, u) -! -! Pick a uniformly random VDOT, which must be between -1 and 1. -! This represents the dot product of the random vector with the Z unit vector. -! -! Note: this works because the surface area of the sphere between -! Z and Z + dZ is independent of Z. So choosing Z uniformly chooses -! a patch of area uniformly. -! - vdot = 2.0D+00 * u(1) - 1.0D+00 - - phi = r8_acos(vdot) -! -! Pick a uniformly random rotation between 0 and 2 Pi around the -! axis of the Z vector. -! - theta = 2.0D+00 * r8_pi * u(2) -! -! Pick a random radius R. -! - r = u(3)**(1.0D+00 / 3.0D+00) - - p(1) = r * cos(theta) * sin(phi) - p(2) = r * sin(theta) * sin(phi) - p(3) = r * cos(phi) - - return -end -subroutine ball01_sample_nd(dim_num, seed, p) - -!*****************************************************************************80 -! -!! BALL01_SAMPLE_ND picks a random point in the unit ball in ND. -! -! Discussion: -! -! N-1 random Givens rotations are applied to the point ( 1, 0, 0, ..., 0 ). -! -! The I-th Givens rotation is in the plane of coordinate axes I and I+1, -! and has the form: -! -! [ cos ( theta ) - sin ( theta ) ] * x(i) = x'(i) -! [ sin ( theta ) cos ( theta ) ] x(i+1) x'(i+1) -! -! Finally, a scaling is applied to set the point at a distance R -! from the origin, in a way that results in a uniform distribution. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 August 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, real ( kind = 8 ) P(N), the random point. -! - implicit none - - integer(kind=4) dim_num - - integer(kind=4) i - real(kind=8) p(dim_num) - real(kind=8) pi - real(kind=8) r - real(kind=8) r8_uniform_01 - real(kind=8) random_cosine - real(kind=8) random_sign - real(kind=8) random_sine - integer(kind=4) seed - - p(1) = 1.0D+00 - p(2:dim_num) = 0.0D+00 - - do i = 1, dim_num - 1 - - r = r8_uniform_01(seed) - random_cosine = 2.0D+00 * r - 1.0D+00 - r = r8_uniform_01(seed) - random_sign = real(2 * int(2.0D+00 * r) - 1, kind=8) - r = r8_uniform_01(seed) - random_sine = random_sign * sqrt(1.0D+00 - random_cosine * random_cosine) - - pi = p(i) - p(i) = random_cosine * pi - p(i + 1) = random_sine * pi - - end do - - r = r8_uniform_01(seed) - - r = r**(1.0D+00 / real(dim_num, kind=8)) - - p(1:dim_num) = r * p(1:dim_num) - - return -end -function ball01_volume() - -!*****************************************************************************80 -! -!! BALL01_VOLUME returns the volume of the unit ball in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) BALL01_VOLUME_3D, the volume. -! - implicit none - - real(kind=8) ball01_volume - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - r = 1.0D+00 - ball01_volume = 4.0D+00 * r8_pi * r**3 / 3.0D+00 - - return -end -subroutine basis_map_3d(u, v, a, ierror) - -!*****************************************************************************80 -! -!! BASIS_MAP_3D computes the matrix which maps one basis to another in 3D. -! -! Discussion: -! -! As long as the column vectors U1, U2 and U3 are linearly independent, -! a matrix A will be computed that maps U1 to V1, U2 to V2, and -! U3 to V3, where V1, V2 and V3 are the columns of V. -! -! Depending on the values of the vectors, A may represent a -! rotation, reflection, dilation, projection, or a combination of these -! basic linear transformations. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) U(3,3), the columns of U are the three -! "domain" or "preimage" vectors, which should be linearly independent. -! -! Input, real ( kind = 8 ) V(3,3), the columns of V are the three -! "range" or "image" vectors. -! -! Output, real ( kind = 8 ) A(3,3), a matrix with the property that -! A * U1 = V1, A * U2 = V2 and A * U3 = V3. -! -! Output, integer ( kind = 4 ) IERROR, error flag. -! 0, no error occurred. -! nonzero, the matrix [ U1 | U2 | U3 ] is exactly singular. -! - implicit none - - real(kind=8) a(3, 3) - real(kind=8) b(3, 3) - real(kind=8) c(3, 3) - real(kind=8) det - integer(kind=4) ierror - real(kind=8) u(3, 3) - real(kind=8) v(3, 3) - - ierror = 0 -! -! Compute C = the inverse of [ U1 | U2 | U3 ]. -! - b(1:3, 1:3) = u(1:3, 1:3) - - call r8mat_inverse_3d(b, c, det) - - if (det == 0.0D+00) then - ierror = 1 - return - end if -! -! A = [ V1 | V2 | V3 ] * inverse [ U1 | U2 | U3 ]. -! - a(1:3, 1:3) = matmul(v(1:3, 1:3), c(1:3, 1:3)) - - return -end -function box_contains_point_2d(p1, p2, p) - -!*****************************************************************************80 -! -!! BOX_CONTAINS_POINT_2D determines if a point is inside a box in 2D. -! -! Discussion: -! -! A box in 2D is a rectangle with sides aligned on coordinate -! axes. It can be described by its low and high corners, P1 and P2 -! as the set of points P satisfying: -! -! P1(1:2) <= P(1:2) <= P2(1:2). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 June 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the low and high -! corners of the box. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) BOX_CONTAINS_POINT_2D, is TRUE if the point -! is inside the box. -! - implicit none - - logical(kind=4) box_contains_point_2d - real(kind=8) p(2) - real(kind=8) p1(2) - real(kind=8) p2(2) - - if (p(1) < p1(1) .or. & - p2(1) < p(1) .or. & - p(2) < p1(2) .or. & - p2(2) < p(2)) then - box_contains_point_2d = .false. - else - box_contains_point_2d = .true. - end if - - return -end -function box_contains_point_nd(dim_num, p1, p2, p) - -!*****************************************************************************80 -! -!! BOX_CONTAINS_POINT_ND determines if a point is inside a box in ND. -! -! Discussion: -! -! A box is a rectangle with sides aligned on coordinate -! axes. It can be described by its low and high corners, P1 and P2 -! as the set of points P satisfying: -! -! P1(1:DIM_NUM) <= P(1:DIM_NUM) <= P2(1:DIM_NUM). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), the low and high -! corners of the box. -! -! Input, real ( kind = 8 ) P(DIM_NUM), the point to be checked. -! -! Output, logical ( kind = 4 ) BOX_CONTAINS_POINT_ND, is TRUE if the point -! is inside the box. -! - implicit none - - integer(kind=4) dim_num - - logical(kind=4) box_contains_point_nd - integer(kind=4) i - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - box_contains_point_nd = .false. - - do i = 1, dim_num - if (p(i) < p1(i) .or. p2(i) < p(i)) then - return - end if - end do - - box_contains_point_nd = .true. - - return -end -function box_contains_segment_nd(dim_num, p1, p2, pa, pb) - -!*****************************************************************************80 -! -!! BOX_CONTAINS_SEGMENT_ND reports if a box contains a line segment in ND. -! -! Discussion: -! -! A box is assumed to be a rectangle with sides aligned on coordinate -! axes. It can be described by its low and high corners, P1 and P2 -! as the set of points P satisfying: -! -! P1(1:DIM_NUM) <= P(1:DIM_NUM) <= P2(1:DIM_NUM). -! -! A line segment is the finite portion of a line that lies between -! two points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), the low and high corners -! of the box. -! -! Input, real ( kind = 8 ) PA(DIM_NUM), PB(DIM_NUM), the endpoints of the -! line segment. -! -! Output, logical ( kind = 4 ) BOX_CONTAINS_SEGMENT_ND, is TRUE if the box -! contains the line segment. -! - implicit none - - integer(kind=4) dim_num - - logical(kind=4) box_contains_segment_nd - logical(kind=4) box_contains_point_nd - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pa(dim_num) - real(kind=8) pb(dim_num) - - box_contains_segment_nd = .false. - - if (.not. box_contains_point_nd(dim_num, p1, p2, pa)) then - return - end if - - if (.not. box_contains_point_nd(dim_num, p1, p2, pb)) then - return - end if - - box_contains_segment_nd = .true. - - return -end -subroutine box_ray_int_2d(p1, p2, pa, pb, pint) - -!*****************************************************************************80 -! -!! BOX_RAY_INT_2D: intersection ( box, ray ) in 2D. -! -! Discussion: -! -! A box in 2D is a rectangle with sides aligned on coordinate -! axes. It can be described by its low and high corners, P1 and P2 -! as the set of points P satisfying: -! -! P1(1:2) <= P(1:2) <= P2(1:2). -! -! The origin of the ray is assumed to be inside the box. This -! guarantees that the ray will intersect the box in exactly one point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the low and high corners of the box. -! -! Input, real ( kind = 8 ) PA(2), the origin of the ray, which should be -! inside the box. -! -! Input, real ( kind = 8 ) PB(2), a second point on the ray. -! -! Output, real ( kind = 8 ) PINT(2), the point on the box intersected -! by the ray. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) inside - integer(kind=4) ival - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) pa(2) - real(kind=8) pb(2) - real(kind=8) pc(2) - real(kind=8) pd(2) - real(kind=8) pint(2) - integer(kind=4) side - - do side = 1, 4 - - if (side == 1) then - pd(1:2) = (/p1(1), p1(2)/) - pc(1:2) = (/p2(1), p1(2)/) - else if (side == 2) then - pd(1:2) = (/p2(1), p1(2)/) - pc(1:2) = (/p2(1), p2(2)/) - else if (side == 3) then - pd(1:2) = (/p2(1), p2(2)/) - pc(1:2) = (/p1(1), p2(2)/) - else if (side == 4) then - pd(1:2) = (/p1(1), p2(2)/) - pc(1:2) = (/p1(1), p1(2)/) - end if - - call angle_contains_point_2d(pc, pa, pd, pb, inside) - - if (inside) then - exit - end if - - if (side == 4) then - write (*, '(a)') ' ' - write (*, '(a)') 'BOX_RAY_INT_2D - Fatal error!' - write (*, '(a)') ' No intersection could be found.' - stop 1 - end if - - end do - - call lines_exp_int_2d(pa, pb, pc, pd, ival, pint) - - return -end -subroutine box_segment_clip_2d(p1, p2, pa, pb, ival) - -!*****************************************************************************80 -! -!! BOX_SEGMENT_CLIP_2D uses a box to clip a line segment in 2D. -! -! Discussion: -! -! A box in 2D is a rectangle with sides aligned on coordinate -! axes. It can be described by its low and high corners, P1 and P2 -! as the set of points P satisfying: -! -! P1(1:2) <= P(1:2) <= P2(1:2). -! -! A line segment is the finite portion of a line that lies between -! two points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 March 2011 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the low and high corners of the box. -! -! Input/output, real ( kind = 8 ) PA(2), PB(2); on input, the endpoints -! of a line segment. On output, the endpoints of the portion of the -! line segment that lies inside the box. However, if no part of the -! initial line segment lies inside the box, the output value is the -! same as the input value. -! -! Output, integer ( kind = 4 ) IVAL: -! -1, no part of the line segment is within the box. -! 0, no clipping was necessary. -! 1, PA was clipped. -! 2, PB was clipped. -! 3, PA and PB were clipped. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) clip_a - logical(kind=4) clip_b - integer(kind=4) ival - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pa(dim_num) - real(kind=8) pb(dim_num) - real(kind=8) q(dim_num) - - clip_a = .false. - clip_b = .false. -! -! Require that XMIN <= X. -! - if (pa(1) < p1(1) .and. pb(1) < p1(1)) then - ival = -1 - return - end if - - if (pa(1) < p1(1) .and. p1(1) <= pb(1)) then - q(1) = p1(1) - q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) - pa(1:2) = q(1:2) - clip_a = .true. - else if (p1(1) <= pa(1) .and. pb(1) < p1(1)) then - q(1) = p1(1) - q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) - pb(1:2) = q(1:2) - clip_b = .true. - end if -! -! Require that X <= XMAX. -! - if (p2(1) < pa(1) .and. p2(1) < pb(1)) then - ival = -1 - return - end if - - if (p2(1) < pa(1) .and. pb(1) <= p2(1)) then - q(1) = p2(1) - q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) - pa(1:2) = q(1:2) - clip_a = .true. - else if (pa(1) <= p2(1) .and. p2(1) < pb(1)) then - q(1) = p2(1) - q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) - pb(1:2) = q(1:2) - clip_b = .true. - end if -! -! Require that YMIN <= Y. -! - if (pa(2) < p1(2) .and. pb(2) < p1(2)) then - ival = -1 - return - end if - - if (pa(2) < p1(2) .and. p1(2) <= pb(2)) then - q(2) = p1(2) - q(1) = pa(1) + (pb(1) - pa(1)) * (q(2) - pa(2)) / (pb(2) - pa(2)) - pa(1:2) = q(1:2) - clip_a = .true. - else if (p1(2) <= pa(2) .and. pb(2) < p1(2)) then - q(2) = p1(2) - q(1) = pa(1) + (pb(1) - pa(1)) * (q(2) - pa(2)) / (pb(2) - pa(2)) - pb(1:2) = q(1:2) - clip_b = .true. - end if -! -! Require that Y <= YMAX. -! - if (p2(2) < pa(2) .and. p2(2) < pb(2)) then - ival = -1 - return - end if - - if (p2(2) < pa(2) .and. pb(2) <= p2(2)) then - q(2) = p2(2) - q(1) = pa(1) + (pb(1) - pa(1)) * (q(2) - pa(2)) / (pb(2) - pa(2)) - pa(1:2) = q(1:2) - clip_a = .true. - else if (pa(2) <= p2(2) .and. p2(2) < pb(2)) then - q(2) = p2(2) - q(1) = pa(1) + (pb(1) - pa(1)) * (p2(2) - pa(2)) / (pb(2) - pa(2)) - pb(1:2) = q(1:2) - clip_b = .true. - end if - - ival = 0 - - if (clip_a) then - ival = ival + 1 - end if - - if (clip_b) then - ival = ival + 2 - end if - - return -end -function box01_contains_point_2d(p) - -!*****************************************************************************80 -! -!! BOX01_CONTAINS_POINT_2D determines if a point is inside the unit box in 2D. -! -! Discussion: -! -! A unit box is assumed to be a rectangle with sides aligned on coordinate -! axes. It can be described as the set of points P satisfying: -! -! 0.0 <= P(1:DIM_NUM) <= 1.0 -! -! 0.0 <= P(1:2) <= 1.0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) BOX01_CONTAINS_POINT_2D, is TRUE if the -! point is inside the box. -! - implicit none - - logical(kind=4) box01_contains_point_2d - real(kind=8) p(2) - - box01_contains_point_2d = & - all(0.0D+00 <= p(1:2)) .and. all(p(1:2) <= 1.0D+00) - - return -end -function box01_contains_point_nd(dim_num, p) - -!*****************************************************************************80 -! -!! BOX01_CONTAINS_POINT_ND determines if a point is inside the unit box in ND. -! -! Discussion: -! -! A unit box is assumed to be a rectangle with sides aligned on coordinate -! axes. It can be described as the set of points P satisfying: -! -! 0.0 <= P(1:DIM_NUM) <= 1.0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 June 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) P(DIM_NUM), the point to be checked. -! -! Output, logical ( kind = 4 ) BOX_01_CONTAINS_POINT_ND, is TRUE -! if the point is inside the box. -! - implicit none - - integer(kind=4) dim_num - - logical(kind=4) box01_contains_point_nd - real(kind=8) p(dim_num) - - box01_contains_point_nd = & - all(0.0D+00 <= p(1:dim_num)) .and. all(p(1:dim_num) <= 1.0D+00) - - return -end -subroutine circle_arc_point_near_2d(r, pc, theta1, theta2, p, pn, & - dist) - -!*****************************************************************************80 -! -!! CIRCLE_ARC_POINT_NEAR_2D : nearest point on a circular arc. -! -! Discussion: -! -! A circular arc is defined by the portion of a circle (R,C) -! between two angles (THETA1,THETA2). -! -! Thus, a point P on a circular arc satisfies -! -! ( P(1) - PC(1) ) * ( P(1) - PC(1) ) -! + ( P(2) - PC(2) ) * ( P(2) - PC(2) ) = R * R -! -! and -! -! Theta1 <= Theta <= Theta2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, -! in radians. Normally, THETA1 < THETA2. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) PN(2), a point on the circular arc which is -! nearest to the point. -! -! Output, real ( kind = 8 ) DIST, the distance to the nearest point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) r - real(kind=8) r2 - real(kind=8) r8_atan - real(kind=8) r8_modp - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 -! -! Special case, the zero circle. -! - if (r == 0.0D+00) then - pn(1:dim_num) = pc(1:dim_num) - dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - return - end if -! -! Determine the angle made by the point. -! - theta = r8_atan(p(2) - pc(2), p(1) - pc(1)) -! -! If the angle is between THETA1 and THETA2, then you can -! simply project the point onto the arc. -! - if (r8_modp(theta - theta1, 2.0D+00 * r8_pi) <= & - r8_modp(theta2 - theta1, 2.0D+00 * r8_pi)) then - - r2 = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) - - pn(1:dim_num) = pc(1:dim_num) + (p(1:dim_num) - pc(1:dim_num)) * r / r2 -! -! Otherwise, if the angle is less than the negative of the -! average of THETA1 and THETA2, it's on the side of the arc -! where the endpoint associated with THETA2 is closest. -! - else if (r8_modp(theta - 0.5D+00 * (theta1 + theta2), 2.0D+00 * r8_pi) & - <= r8_pi) then - - pn(1:dim_num) = pc(1:dim_num) + r * (/cos(theta2), sin(theta2)/) -! -! Otherwise, the endpoint associated with THETA1 is closest. -! - else - - pn(1:dim_num) = pc(1:dim_num) + r * (/cos(theta1), sin(theta1)/) - - end if - - dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - - return -end -subroutine circle_area_2d(r, area) - -!*****************************************************************************80 -! -!! CIRCLE_AREA_2D computes the area of a circle in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 December 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Output, real ( kind = 8 ) AREA, the area of the circle. -! - implicit none - - real(kind=8) area - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - area = r8_pi * r * r - - return -end -subroutine circle_dia2imp_2d(p1, p2, r, pc) - -!*****************************************************************************80 -! -!! CIRCLE_DIA2IMP_2D converts a diameter to an implicit circle in 2D. -! -! Discussion: -! -! The diameter form of a circle is: -! -! P1 and P2 are the endpoints of a diameter. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points that are the -! endpoints of a diameter of the circle. -! -! Output, real ( kind = 8 ) R, the radius of the circle. -! -! Output, real ( kind = 8 ) PC(2), the center of the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - - r = 0.5D+00 * sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) - - pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) - - return -end -subroutine circle_exp_contains_point_2d(p1, p2, p3, p, inside) - -!*****************************************************************************80 -! -!! CIRCLE_EXP_CONTAINS_POINT_2D: explicit circle contains a point in 2D. -! -! Discussion: -! -! The explicit form of a circle in 2D is: -! -! The circle passing through points P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 January 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), three points on a circle. -! -! Input, real ( kind = 8 ) P(2), the point to test. -! -! Output, integer ( kind = 4 ) INSIDE, reports the result: -! -1, the three points are distinct and noncolinear, -! and P lies inside the circle. -! 0, the three points are distinct and noncolinear, -! and P lies on the circle. -! 1, the three points are distinct and noncolinear, -! and P lies outside the circle. -! 2, the three points are distinct and colinear, -! and P lies on the line. -! 3, the three points are distinct and colinear, -! and P does not lie on the line. -! 4, two points are distinct, and P lies on the line. -! 5, two points are distinct, and P does not lie on the line. -! 6, all three points are equal, and P is equal to them, -! 7, all three points are equal, and P is not equal to them. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a(4, 4) - real(kind=8) det - real(kind=8) r8mat_det_4d - integer(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) -! -! P1 = P2? -! - if (all(p1(1:dim_num) == p2(1:dim_num))) then - - if (all(p1(1:dim_num) == p3(1:dim_num))) then - - if (all(p1(1:dim_num) == p(1:dim_num))) then - inside = 6 - else - inside = 7 - end if - - else - - det = (p1(1) - p3(1)) * (p(2) - p3(2)) & - - (p(1) - p3(1)) * (p1(2) - p3(2)) - - if (det == 0.0D+00) then - inside = 4 - else - inside = 5 - end if - end if - - return - - end if -! -! P1 does not equal P2. Does P1 = P3? -! - if (all(p1(1:dim_num) == p3(1:dim_num))) then - - det = (p1(1) - p2(1)) * (p(2) - p2(2)) & - - (p(1) - p2(1)) * (p1(2) - p2(2)) - - if (det == 0.0D+00) then - inside = 4 - else - inside = 5 - end if - - return - - end if -! -! The points are distinct. Are they colinear? -! - det = (p1(1) - p2(1)) * (p3(2) - p2(2)) & - - (p3(1) - p2(1)) * (p1(2) - p2(2)) - - if (det == 0.0D+00) then - - det = (p1(1) - p2(1)) * (p(2) - p2(2)) & - - (p(1) - p2(1)) * (p1(2) - p2(2)) - - if (det == 0.0D+00) then - inside = 2 - else - inside = 3 - end if - - return - - end if -! -! The points are distinct and non-colinear. -! -! Compute the determinant -! - a(1, 1) = p1(1) - a(1, 2) = p1(2) - a(1, 3) = p1(1) * p1(1) + p1(2) * p1(2) - a(1, 4) = 1.0D+00 - - a(2, 1) = p2(1) - a(2, 2) = p2(2) - a(2, 3) = p2(1) * p2(1) + p2(2) * p2(2) - a(2, 4) = 1.0D+00 - - a(3, 1) = p3(1) - a(3, 2) = p3(2) - a(3, 3) = p3(1) * p3(1) + p3(2) * p3(2) - a(3, 4) = 1.0D+00 - - a(4, 1) = p(1) - a(4, 2) = p(2) - a(4, 3) = p(1) * p(1) + p(2) * p(2) - a(4, 4) = 1.0D+00 - - det = r8mat_det_4d(a) - - if (det < 0.0D+00) then - inside = 1 - else if (det == 0.0D+00) then - inside = 0 - else - inside = -1 - end if - - return -end -subroutine circle_exp2imp_2d(p1, p2, p3, r, pc) - -!*****************************************************************************80 -! -!! CIRCLE_EXP2IMP_2D converts a circle from explicit to implicit form in 2D. -! -! Discussion: -! -! The explicit form of a circle in 2D is: -! -! The circle passing through points P1, P2 and P3. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Any three distinct points define a circle, as long as they don't lie -! on a straight line. (If the points do lie on a straight line, we -! could stretch the definition of a circle to allow an infinite radius -! and a center at some infinite point.) -! -! The diameter of the circle can be found by solving a 2 by 2 linear system. -! This is because the vectors P2 - P1 and P3 - P1 are secants of the circle, -! and each forms a right triangle with the diameter. Hence, the dot product -! of P2 - P1 with the diameter is equal to the square of the length -! of P2 - P1, and similarly for P3 - P1. These two equations determine the -! diameter vector originating at P1. -! -! If all three points are equal, return a circle of radius 0 and -! the obvious center. -! -! If two points are equal, return a circle of radius half the distance -! between the two distinct points, and center their average. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 March 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Joseph ORourke, -! Computational Geometry, -! Second Edition, -! Cambridge, 1998, -! ISBN: 0521649765, -! LC: QA448.D38. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), three points on the circle. -! -! Output, real ( kind = 8 ) R, the radius of the circle. Normally, R will -! be positive. R will be (meaningfully) zero if all three points are -! equal. If two points are equal, R is returned as the distance between -! two nonequal points. R is returned as -1 in the unlikely event that -! the points are numerically collinear; philosophically speaking, R -! should actually be "infinity" in this case. -! -! Output, real ( kind = 8 ) PC(2), the center of the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) e - real(kind=8) f - real(kind=8) g - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r -! -! If all three points are equal, then the -! circle of radius 0 and center P1 passes through the points. -! - if (all(p1(1:dim_num) == p2(1:dim_num)) .and. & - all(p1(1:dim_num) == p3(1:dim_num))) then - r = 0.0D+00 - pc(1:dim_num) = p1(1:dim_num) - return - end if -! -! If exactly two points are equal, then the circle is defined as -! having the obvious radius and center. -! - if (all(p1(1:dim_num) == p2(1:dim_num))) then - - r = 0.5D+00 * sqrt(sum((p1(1:dim_num) - p3(1:dim_num))**2)) - pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p3(1:dim_num)) - return - - else if (all(p1(1:dim_num) == p3(1:dim_num))) then - - r = 0.5D+00 * sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) - pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) - return - - else if (all(p2(1:dim_num) == p3(1:dim_num))) then - - r = 0.5D+00 * sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) - pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) - return - - end if -! -! We check for collinearity. A more useful check would compare the -! absolute value of G to a small quantity. -! - e = (p2(1) - p1(1)) * (p1(1) + p2(1)) & - + (p2(2) - p1(2)) * (p1(2) + p2(2)) - - f = (p3(1) - p1(1)) * (p1(1) + p3(1)) & - + (p3(2) - p1(2)) * (p1(2) + p3(2)) - - g = (p2(1) - p1(1)) * (p3(2) - p2(2)) & - - (p2(2) - p1(2)) * (p3(1) - p2(1)) - - if (g == 0.0D+00) then - pc(1:2) = (/0.0D+00, 0.0D+00/) - r = -1.0D+00 - return - end if -! -! The center is halfway along the diameter vector from P1. -! - pc(1) = 0.5D+00 * ((p3(2) - p1(2)) * e - (p2(2) - p1(2)) * f) / g - pc(2) = 0.5D+00 * ((p2(1) - p1(1)) * f - (p3(1) - p1(1)) * e) / g -! -! Knowing the center, the radius is now easy to compute. -! - r = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) - - return -end -subroutine circle_imp_contains_point_2d(r, pc, p, inside) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_CONTAINS_POINT_2D: implicit circle contains a point in 2D? -! -! Discussion: -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside or -! on the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - - if ((p(1) - pc(1)) * (p(1) - pc(1)) & - + (p(2) - pc(2)) * (p(2) - pc(2)) <= r * r) then - inside = .true. - else - inside = .false. - end if - - return -end -subroutine circle_imp_line_exp_dist_2d(r, pc, p1, p2, dist) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_LINE_EXP_DIST_2D: distance ( impl circle, explicit line ) in 2D. -! -! Discussion: -! -! The distance is zero if the line intersects the circle. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The distance between the circle and the line is zero if -! and only if they intersect. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 November 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! -! Output, real ( kind = 8 ) DIST, the distance of the line to the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - - call line_exp_point_dist_2d(p1, p2, pc, dist) - - dist = dist - r - - if (dist < 0.0D+00) then - dist = 0.0D+00 - end if - - return -end -subroutine circle_imp_line_par_int_2d(r, pc, x0, y0, f, g, int_num, p) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_LINE_PAR_INT_2D: ( imp circle, param line ) intersection in 2D. -! -! Discussion: -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F^2 + G^2 = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric parameters of -! the line. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersecting -! points found. INT_NUM will be 0, 1 or 2. -! -! Output, real ( kind = 8 ) P(2,INT_NUM), the intersecting points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) f - real(kind=8) g - integer(kind=4) int_num - real(kind=8) p(dim_num, 2) - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) root - real(kind=8) t - real(kind=8) x0 - real(kind=8) y0 - - root = r * r * (f * f + g * g) - (f * (pc(2) - y0) & - - g * (pc(1) - x0))**2 - - if (root < 0.0D+00) then - - int_num = 0 - - else if (root == 0.0D+00) then - - int_num = 1 - - t = (f * (pc(1) - x0) + g * (pc(2) - y0)) / (f * f + g * g) - p(1, 1) = x0 + f * t - p(2, 1) = y0 + g * t - - else if (0.0D+00 < root) then - - int_num = 2 - - t = ((f * (pc(1) - x0) + g * (pc(2) - y0)) & - - sqrt(root)) / (f * f + g * g) - - p(1, 1) = x0 + f * t - p(2, 1) = y0 + g * t - - t = ((f * (pc(1) - x0) + g * (pc(2) - y0)) & - + sqrt(root)) / (f * f + g * g) - - p(1, 2) = x0 + f * t - p(2, 2) = y0 + g * t - - end if - - return -end -subroutine circle_imp_point_dist_2d(r, pc, p, dist) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_POINT_DIST_2D: distance ( implicit circle, point ) in 2D. -! -! Discussion: -! -! The distance is zero if the point is on the circle. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance of the point to the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) r2 - - r2 = sqrt(sum((p(1:2) - pc(1:2))**2)) - - dist = abs(r2 - r) - - return -end -subroutine circle_imp_point_dist_signed_2d(r, pc, p, dist) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_POINT_DIST_SIGNED_2D: signed distance ( imp circle, point ) in 2D. -! -! Discussion: -! -! The signed distance is zero if the point is on the circle. -! The signed distance is negative if the point is inside the circle. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) DIST, the signed distance of the point -! to the circle. If the point is inside the circle, the signed distance -! is negative. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) r2 - - r2 = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) - - dist = r2 - r - - return -end -subroutine circle_imp_point_near_2d(r, pc, p, pn, dist) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_POINT_NEAR_2D: nearest ( implicit circle, point ) in 2D. -! -! Discussion: -! -! This routine finds the distance from a point to an implicitly -! defined circle, and returns the point on the circle that is -! nearest to the given point. -! -! If the given point is the center of the circle, than any point -! on the circle is "the" nearest. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) PN(2), the nearest point on the circle. -! -! Output, real ( kind = 8 ) DIST, the distance of the point to the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) r - real(kind=8) r2 - - if (all(p(1:dim_num) == pc(1:dim_num))) then - dist = r - pn(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) - return - end if - - r2 = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) - - dist = abs(r2 - r) - - pn(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / r2 - - return -end -subroutine circle_imp_points_2d(r, pc, n, p) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_POINTS_2D returns points on an implicit circle in 2D. -! -! Discussion: -! -! The first point is always ( PC(1) + R, PC(2) ), and subsequent -! points proceed counter clockwise around the circle. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, integer ( kind = 4 ) N, the number of points desired. -! N must be at least 1. -! -! Output, real ( kind = 8 ) P(2,N), the coordinates of points -! on the circle. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) j - real(kind=8) p(2, n) - real(kind=8) pc(2) - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - - do j = 1, n - theta = 2.0D+00 * r8_pi * real(j - 1, kind=8) / real(n, kind=8) - p(1:dim_num, j) = pc(1:dim_num) + r * (/cos(theta), sin(theta)/) - end do - - return -end -subroutine circle_imp_points_3d(r, pc, nc, n, p) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_POINTS_3D returns points on an implicit circle in 3D. -! -! Discussion: -! -! Points P on an implicit circle in 3D satisfy the equations: -! -! ( P(1) - PC(1) )^2 -! + ( P(2) - PC(2) )^2 -! + ( P(3) - PC(3) )^2 = R^2 -! -! and -! -! ( P(1) - PC(1) ) * NC(1) -! + ( P(2) - PC(2) ) * NC(2) -! + ( P(3) - PC(3) ) * NC(3) = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 March 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(3), the center of the circle. -! -! Input, real ( kind = 8 ) NC(3), a nonzero vector that is normal to -! the plane of the circle. It is customary, but not necessary, -! that this vector have unit norm. -! -! Input, integer ( kind = 4 ) N, the number of points desired. -! N must be at least 1. -! -! Output, real ( kind = 8 ) P(3,N), the coordinates of points -! on the circle. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - integer(kind=4) j - real(kind=8) n1(dim_num) - real(kind=8) n2(dim_num) - real(kind=8) nc(dim_num) - real(kind=8) p(dim_num, n) - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta -! -! Get two unit vectors N1 and N2 which are orthogonal to each other, -! and to NC. -! - call plane_normal_basis_3d(pc, nc, n1, n2) -! -! Rotate R units away from PC in the plane of N1 and N2. -! - do j = 1, n - - theta = (2.0D+00 * r8_pi * real(j - 1, kind=8)) & - / real(n, kind=8) - - p(1:dim_num, j) = pc(1:dim_num) & - + r * (cos(theta) * n1(1:dim_num) & - + sin(theta) * n2(1:dim_num)) - - end do - - return -end -subroutine circle_imp_points_arc_2d(r, pc, theta1, theta2, n, p) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_POINTS_ARC_2D: N points on an arc of an implicit circle in 2D. -! -! Discussion: -! -! The first point is -! ( PC(1) + R * COS ( THETA1 ), PC(2) + R * SIN ( THETA1 ) ); -! The last point is -! ( PC(1) + R * COS ( THETA2 ), PC(2) + R * SIN ( THETA2 ) ); -! and the intermediate points are evenly spaced in angle between these, -! and in counter clockwise order. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angular coordinates of -! the first and last points to be drawn, in radians. -! -! Input, integer ( kind = 4 ) N, the number of points desired. -! N must be at least 1. -! -! Output, real ( kind = 8 ) P(2,N), the points on the circle. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) pc(dim_num) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r - real(kind=8) r8_modp - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - real(kind=8) theta3 -! -! THETA3 is the smallest angle, no less than THETA1, which -! coincides with THETA2. -! - theta3 = theta1 + r8_modp(theta2 - theta1, 2.0D+00 * r8_pi) - - do i = 1, n - - if (1 < n) then - theta = (real(n - i, kind=8) * theta1 & - + real(i - 1, kind=8) * theta3) & - / real(n - 1, kind=8) - else - theta = 0.5D+00 * (theta1 + theta3) - end if - - p(1:dim_num, i) = pc(1:dim_num) + r * (/cos(theta), sin(theta)/) - - end do - - return -end -subroutine circle_imp_print_2d(r, pc, title) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_PRINT_2D prints an implicit circle in 2D. -! -! Discussion: -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, character ( length = * ) TITLE, a title. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) pc(dim_num) - real(kind=8) r - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - write (*, '(a)') ' ' - write (*, '(a,g14.6)') ' Radius = ', r - write (*, '(a,2g14.6)') ' Center = ', pc(1:dim_num) - - return -end -subroutine circle_imp_print_3d(r, pc, nc, title) - -!*****************************************************************************80 -! -!! CIRCLE_IMP_PRINT_3D prints an implicit circle in 3D. -! -! Discussion: -! -! Points P on an implicit circle in 3D satisfy the equations: -! -! ( P(1) - PC(1) )^2 -! + ( P(2) - PC(2) )^2 -! + ( P(3) - PC(3) )^2 = R^2 -! -! and -! -! ( P(1) - PC(1) ) * NC(1) -! + ( P(2) - PC(2) ) * NC(2) -! + ( P(3) - PC(3) ) * NC(3) = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 March 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(3), the center of the circle. -! -! Input, real ( kind = 8 ) NC(3), the normal vector to the circle. -! -! Input, character ( length = * ) TITLE, a title. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) nc(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - write (*, '(a)') ' ' - write (*, '(a,g14.6)') ' Radius = ', r - write (*, '(a,3g14.6)') ' Center = ', pc(1:dim_num) - write (*, '(a,3g14.6)') ' Normal = ', nc(1:dim_num) - - return -end -subroutine circle_imp2exp_2d(r, pc, p1, p2, p3) - -!*****************************************************************************80 -! -!! CIRCLE_IMP2EXP_2D converts a circle from implicit to explicit form in 2D. -! -! Discussion: -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! The explicit form of a circle in 2D is: -! -! The circle passing through points P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 May 2007 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Joseph ORourke, -! Computational Geometry, -! Second Edition, -! Cambridge, 1998, -! ISBN: 0521649765, -! LC: QA448.D38. -! -! Parameters: -! -! Input, real ( kind = 8 ) R, PC(2), the radius and center of the circle. -! -! Output, real ( kind = 8 ) P1(2), P2(2), P3(2), three points on the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pc(dim_num) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r - real(kind=8) theta - - theta = 0.0D+00 - p1(1) = pc(1) + r * cos(theta) - p1(2) = pc(2) + r * sin(theta) - - theta = 2.0D+00 * r8_pi / 3.0D+00 - p2(1) = pc(1) + r * cos(theta) - p2(2) = pc(2) + r * sin(theta) - - theta = 4.0D+00 * r8_pi / 3.0D+00 - p3(1) = pc(1) + r * cos(theta) - p3(2) = pc(2) + r * sin(theta) - - return -end -subroutine circle_llr2imp_2d(p1, p2, q1, q2, r, pc) - -!*****************************************************************************80 -! -!! CIRCLE_LLR2IMP_2D converts a circle from LLR to implicit form in 2D. -! -! Discussion: -! -! The LLR form of a circle in 2D is: -! -! The circle of radius R tangent to the lines L1 and L2. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Let S be the scaled distance of a point on L1 from P1 to P2, -! and let N1 be a unit normal vector to L1. Then a point P that is -! R units from L1 satisfies: -! -! P = P1 + s * ( P2 - P1 ) + R * N1. -! -! Let t be the scaled distance of a point on L2 from Q1 to Q2, -! and let N2 be a unit normal vector to L2. Then a point Q that is -! R units from L2 satisfies: -! -! Q = Q1 + t * ( Q2 - Q1 ) + R * N2. -! -! For the center of the circle, then, we have P = Q, that is -! -! ( P2 - P1 ) * s - ( Q2 - Q1 ) * t = - P1 + Q1 - R * N1 + R * N2 ) -! -! This is a linear system for ( s and t ) from which we can compute -! the points of tangency, and the center. -! -! Note that we have four choices for the circle based on the use -! of plus or minus N1 and plus or minus N2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 November 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on line 1. -! -! Input, real ( kind = 8 ) Q1(2), Q2(2), two points on line 2. -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Output, real ( kind = 8 ) PC(2,4), the centers of the circles. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a(2, 2) - real(kind=8) b(2) - real(kind=8) det - real(kind=8) n1(dim_num) - real(kind=8) n2(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pc(dim_num, 4) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) r - real(kind=8) x(dim_num) -! -! Compute the normals N1 and N2. -! - call line_exp_normal_2d(p1, p2, n1) - - call line_exp_normal_2d(q1, q2, n2) -! -! Set the linear system. -! - a(1:2, 1) = p2(1:2) - p1(1:2) - a(1:2, 2) = -q2(1:2) + q1(1:2) -! -! Solve the 4 linear systems, using every combination of -! signs on the normal vectors. -! - b(1:2) = -p1(1:2) + q1(1:2) + r * n1(1:2) + r * n2(1:2) - - call r8mat_solve_2d(a, b, det, x) - - pc(1:2, 1) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) - r * n1(1:2) - - b(1:2) = -p1(1:2) + q1(1:2) + r * n1(1:2) - r * n2(1:2) - - call r8mat_solve_2d(a, b, det, x) - - pc(1:2, 2) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) - r * n1(1:2) - - b(1:2) = -p1(1:2) + q1(1:2) - r * n1(1:2) + r * n2(1:2) - - call r8mat_solve_2d(a, b, det, x) - - pc(1:2, 3) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) + r * n1(1:2) - - b(1:2) = -p1(1:2) + q1(1:2) - r * n1(1:2) - r * n2(1:2) - - call r8mat_solve_2d(a, b, det, x) - - pc(1:2, 4) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) + r * n1(1:2) - - return -end -subroutine circle_lune_angle_by_height_2d(r, h, angle) - -!*****************************************************************************80 -! -!! CIRCLE_LUNE_ANGLE_BY_HEIGHT_2D computes the angle of a circular lune. -! -! Discussion: -! -! Draw the chord connecting two points on the circumference of a circle. -! The region between the chord and the circumference is a "lune". -! We wish to know the angle subtended by the lune. -! -! The distance from the center of the circle to the midpoint of the chord -! is the "height" H of the lune. It is natural to expect 0 <= H <= R. -! However, if we allow -R <= H < 0 as well, this allows us to include -! lunes which involve more than half the circle's area. -! -! If H < -R or R < H, then no lune is formed, and we return a zero angle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) H, the height of the lune. -! -! Output, real ( kind = 8 ) ANGLE, the angle of the lune. -! - implicit none - - real(kind=8) angle - real(kind=8) h - real(kind=8) r - - if (-r <= h .and. h <= r) then - angle = 2.0D+00 * acos(h / r); - else - angle = 0.0D+00 - end if - - return -end -subroutine circle_lune_area_by_angle_2d(r, pc, theta1, theta2, area) - -!*****************************************************************************80 -! -!! CIRCLE_LUNE_AREA_BY_ANGLE_2D returns the area of a circular lune in 2D. -! -! Discussion: -! -! A lune is formed by drawing a circular arc, and joining its endpoints. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, -! in radians. Normally, THETA1 < THETA2. -! -! Output, real ( kind = 8 ) AREA, the area of the lune. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) area_sector - real(kind=8) area_triangle - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) theta1 - real(kind=8) theta2 - - call circle_sector_area_2d(r, pc, theta1, theta2, area_sector) - call circle_triangle_area_2d(r, pc, theta1, theta2, area_triangle) - - area = area_sector - area_triangle - - return -end -subroutine circle_lune_area_by_height_2d(r, h) - -!*****************************************************************************80 -! -!! CIRCLE_LUNE_AREA_BY_ANGLE_2D returns the area of a circular lune in 2D. -! -! Discussion: -! -! Draw the chord connecting two points on the circumference of a circle. -! The region between the chord and the circumference is a "lune". -! We wish to know the area of this region. -! -! The distance from the center of the circle to the midpoint of the chord -! is the "height" H of the lune. It is natural to expect 0 <= H <= R. -! However, if we allow -R <= H < 0 as well, this allows us to include -! lunes which involve more than half the circle's area. -! -! If H < -R or R < H, then no lune is formed and we have zero area. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) H, the height of the lune. -! -! Output, real ( kind = 8 ) AREA, the area of the lune. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) h - real(kind=8) r - - if (-r <= h .and. h <= r) then - area = r**2 * acos(h / r) - h * sqrt(r**2 - h**2) - else - area = 0.0D+00 - end if - - return -end -subroutine circle_lune_centroid_2d(r, pc, theta1, theta2, centroid) - -!*****************************************************************************80 -! -!! CIRCLE_LUNE_CENTROID_2D returns the centroid of a circular lune in 2D. -! -! Discussion: -! -! A lune is formed by drawing a circular arc, and joining its endpoints. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, -! in radians. Normally, THETA1 < THETA2. -! -! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid -! of the lune. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) centroid(dim_num) - real(kind=8) d - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - - theta = theta2 - theta1 - - if (theta == 0.0D+00) then - d = r - else - d = 4.0D+00 * r * (sin(0.5D+00 * theta))**3 / & - (3.0D+00 * (theta - sin(theta))) - end if - - centroid(1:2) = (/pc(1) + d * cos(theta), & - pc(2) + d * sin(theta)/) - - return -end -subroutine circle_lune_height_by_angle_2d(r, angle, height) - -!*****************************************************************************80 -! -!! CIRCLE_LUNE_HEIGHT_BY_ANGLE_2D computes the height of a circular lune. -! -! Discussion: -! -! Draw the chord connecting two points on the circumference of a circle. -! The region between the chord and the circumference is a "lune". -! The lune subtends a given angle between 0 and 2 pi. -! -! The distance from the center of the circle to the midpoint of the chord -! is the "height" H of the lune and we wish to determine this value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) ANGLE, the angle subtended by the lune. -! -! Output, real ( kind = 8 ) HEIGHT, the height of the lune -! - implicit none - - real(kind=8) angle - real(kind=8) height - real(kind=8) r - - height = r * cos(angle / 2.0D+00) - - return -end -subroutine circle_pppr2imp_3d(p1, p2, p3, r, pc, normal) - -!*****************************************************************************80 -! -!! CIRCLE_PPPR2IMP_3D converts a circle from PPPR to implicit form in 3D. -! -! Discussion: -! -! The PPPR form of a circle in 3D is: -! -! The circle of radius R passing through points P1 and P2, -! and lying in the plane of P1, P2 and P3. -! -! Points P on an implicit circle in 2D satisfy the equations: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 + ( P(3) - PC(3) )^2 = R^2 -! and -! ( P - PC ) dot NORMAL = 0. -! -! There may be zero, one, or two circles that satisfy the -! requirements of the PPPR form. -! -! If there is no such circle, then PC(1:2,1) and PC(1:2,2) -! are set to the midpoint of (P1,P2). -! -! If there is one circle, PC(1:2,1) and PC(1:2,2) will be equal. -! -! If there are two circles, then PC(1:2,1) is the first center, -! and PC(1:2,2) is the second. -! -! This calculation is equivalent to finding the intersections of -! spheres of radius R at points P1 and P2, which lie in the plane -! defined by P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), two points on the circle. -! -! Input, real ( kind = 8 ) P3(3), a third point. -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Output, real ( kind = 8 ) PC(3,2), the centers of the two circles. -! -! Output, real ( kind = 8 ) NORMAL(3), the normal to the circles. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dist - real(kind=8) dot - real(kind=8) h - integer(kind=4) j - real(kind=8) length - real(kind=8) normal(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pc(dim_num, 2) - real(kind=8) r - real(kind=8) v(dim_num) -! -! Compute the distance from P1 to P2. -! - dist = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) -! -! If R is smaller than DIST, we don't have a circle. -! - if (2.0D+00 * r < dist) then - do j = 1, 2 - pc(1:dim_num, j) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) - end do - return - end if -! -! H is the distance from the midpoint of (P1,P2) to the center. -! - h = sqrt((r + 0.5D+00 * dist) * (r - 0.5D+00 * dist)) -! -! Define a unit direction V that is normal to P2-P1, and lying -! in the plane (P1,P2,P3). -! -! To do this, subtract from P3-P1 the component in the direction P2-P1. -! - v(1:dim_num) = p3(1:dim_num) - p1(1:dim_num) - dot = dot_product(v(1:dim_num), p2(1:dim_num) - p1(1:dim_num)) - dot = dot / dist - - v(1:dim_num) = v(1:dim_num) - dot * (p2(1:dim_num) - p1(1:dim_num)) / dist - - length = sqrt(sum(v(1:dim_num)**2)) - - v(1:dim_num) = v(1:dim_num) / length -! -! We can go with or against the given normal direction. -! - pc(1:dim_num, 1) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & - + h * v(1:dim_num) - - pc(1:dim_num, 2) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & - - h * v(1:dim_num) - - call plane_exp_normal_3d(p1, p2, p3, normal) - - return -end -subroutine circle_ppr2imp_2d(p1, p2, r, pc) - -!*****************************************************************************80 -! -!! CIRCLE_PPR2IMP_2D converts a circle from PPR to implicit form in 2D. -! -! Discussion: -! -! The PPR form of a circle in 2D is: -! -! The circle of radius R passing through points P1 and P2. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! There may be zero, one, or two circles that satisfy the -! requirements of the PPR form. -! -! If there is no such circle, then PC(1:2,1) and PC(1:2,2) -! are set to the midpoint of (P1,P2). -! -! If there is one circle, PC(1:2,1) and PC(1:2,2) will be equal. -! -! If there are two circles, then PC(1:2,1) is the first center, -! and PC(1:2,2) is the second. -! -! This calculation is equivalent to finding the intersections of -! circles of radius R at points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 November 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the circle. -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Output, real ( kind = 8 ) PC(2,2), the centers of the two circles. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) h - integer(kind=4) j - real(kind=8) normal(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pc(dim_num, 2) - real(kind=8) r -! -! Compute the distance from P1 to P2. -! - dist = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) -! -! If R is smaller than DIST, we don't have a circle. -! - if (2.0D+00 * r < dist) then - do j = 1, 2 - pc(1:dim_num, j) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) - end do - return - end if -! -! H is the distance from the midpoint of (P1,P2) to the center. -! - h = sqrt((r + 0.5D+00 * dist) * (r - 0.5D+00 * dist)) -! -! Determine the unit normal direction. -! - normal(1) = (p2(2) - p1(2)) / dist - normal(2) = -(p2(1) - p1(1)) / dist -! -! We can go with or against the given normal direction. -! - pc(1:dim_num, 1) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & - + h * normal(1:dim_num) - - pc(1:dim_num, 2) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & - - h * normal(1:dim_num) - - return -end -subroutine circle_sector_area_2d(r, pc, theta1, theta2, area) - -!*****************************************************************************80 -! -!! CIRCLE_SECTOR_AREA_2D computes the area of a circular sector in 2D. -! -! Discussion: -! -! A circular sector is formed by a circular arc, and the two straight line -! segments that join its ends to the center of the circle. -! -! A circular sector is defined by the two conditions -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! and -! -! Theta1 <= Theta <= Theta2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the two angles defining the -! sector, in radians. Normally, THETA1 < THETA2. -! -! Output, real ( kind = 8 ) AREA, the area of the circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) theta1 - real(kind=8) theta2 - - area = 0.5D+00 * r * r * (theta2 - theta1) - - return -end -subroutine circle_sector_centroid_2d(r, pc, theta1, theta2, centroid) - -!*****************************************************************************80 -! -!! CIRCLE_SECTOR_CENTROID_2D returns the centroid of a circular sector in 2D. -! -! Discussion: -! -! A circular sector is formed by a circular arc, and the two straight line -! segments that join its ends to the center of the circle. -! -! A circular sector is defined by -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! and -! -! Theta1 <= Theta <= Theta2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, -! in radians. Normally, THETA1 < THETA2. -! -! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid -! of the sector. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) centroid(dim_num) - real(kind=8) d - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - - theta = theta2 - theta1 - - if (theta == 0.0D+00) then - d = 2.0D+00 * r / 3.0D+00 - else - d = 4.0D+00 * r * sin(0.5D+00 * theta) / & - (3.0D+00 * theta) - end if - - centroid(1:2) = (/pc(1) + d * cos(theta), & - pc(2) + d * sin(theta)/) - - return -end -subroutine circle_sector_contains_point_2d(r, pc, theta1, theta2, & - p, inside) - -!*****************************************************************************80 -! -!! CIRCLE_SECTOR_CONTAINS_POINT_2D : is a point inside a circular sector? -! -! Discussion: -! -! A circular sector is formed by a circular arc, and the two straight line -! segments that join its ends to the center of the circle. -! -! A circular sector is defined by -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! and -! -! Theta1 <= Theta <= Theta2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, -! in radians. Normally, THETA1 < THETA2. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside or -! on the circular sector. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) r8_atan - real(kind=8) r8_modp - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - - inside = .false. -! -! Is the point inside the (full) circle? -! - if ((p(1) - pc(1)) * (p(1) - pc(1)) & - + (p(2) - pc(2)) * (p(2) - pc(2)) <= r * r) then -! -! Is the point's angle within the arc's range? -! Try to force the angles to lie between 0 and 2 * PI. -! - theta = r8_atan(p(2) - pc(2), p(1) - pc(1)) - - if (r8_modp(theta - theta1, 2.0D+00 * r8_pi) <= & - r8_modp(theta2 - theta1, 2.0D+00 * r8_pi)) then - - inside = .true. - - end if - - end if - - return -end -subroutine circle_sector_print_2d(r, pc, theta1, theta2) - -!*****************************************************************************80 -! -!! CIRCLE_SECTOR_PRINT_2D prints a circular sector in 2D. -! -! Discussion: -! -! A circular sector is formed by a circular arc, and the two straight line -! segments that join its ends to the center of the circle. -! -! A circular sector is defined by -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! and -! -! Theta1 <= Theta <= Theta2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, -! in radians. Normally, THETA1 < THETA2. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) theta1 - real(kind=8) theta2 - - write (*, '(a)') ' ' - write (*, '(a)') ' Circular sector definition:' - write (*, '(a)') ' ' - write (*, '(a,g14.6)') ' Radius = ', r - write (*, '(a,2g14.6)') ' Center = ', pc(1:2) - write (*, '(a,2g14.6)') ' Theta = ', theta1, theta2 - - return -end -subroutine circle_triangle_area_2d(r, pc, theta1, theta2, area) - -!*****************************************************************************80 -! -!! CIRCLE_TRIANGLE_AREA_2D returns the area of a circle triangle in 2D. -! -! Discussion: -! -! A circle triangle is formed by drawing a circular arc, and considering -! the triangle formed by the endpoints of the arc plus the center of -! the circle. -! -! Note that for angles greater than PI, the triangle will actually -! have NEGATIVE area. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle. -! -! Input, real ( kind = 8 ) PC(2), the center of the circle. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, -! in radians. Normally, THETA1 < THETA2. -! -! Output, real ( kind = 8 ) AREA, the (signed) area of the triangle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) theta1 - real(kind=8) theta2 - - area = 0.5D+00 * r * r * sin(theta2 - theta1) - - return -end -subroutine circle_triple_angles_2d(r1, r2, r3, angle1, angle2, angle3) - -!*****************************************************************************80 -! -!! CIRCLE_TRIPLE_ANGLE_2D returns an angle formed by three circles in 2D. -! -! Discussion: -! -! A circle triple is a set of three tangent circles. We assume -! that no circle is contained in another. -! -! We consider the triangle formed by joining the centers of the circles. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 June 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Kenneth Stephenson, -! Circle Packing, The Theory of Discrete Analytic Functions, -! Cambridge, 2005. -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, R3, the radii of the circles. -! -! Input, real ( kind = 8 ) ANGLE1, ANGLE2, ANGLE3, the angles -! in the triangle. -! - implicit none - - real(kind=8) angle1 - real(kind=8) angle2 - real(kind=8) angle3 - real(kind=8) r1 - real(kind=8) r2 - real(kind=8) r3 - real(kind=8) r8_acos - - angle1 = r8_acos( & - (r1 + r2)**2 + (r1 + r3)**2 - (r2 + r3)**2) / & - (2.0D+00 * (r1 + r2) * (r1 + r3)) - - angle2 = r8_acos( & - (r2 + r3)**2 + (r2 + r1)**2 - (r3 + r1)**2) / & - (2.0D+00 * (r2 + r3) * (r2 + r1)) - - angle3 = r8_acos( & - (r3 + r1)**2 + (r3 + r2)**2 - (r1 + r2)**2) / & - (2.0D+00 * (r3 + r1) * (r3 + r2)) - - return -end -subroutine circles_intersect_points_2d(r1, pc1, r2, pc2, int_num, p) - -!*****************************************************************************80 -! -!! CIRCLES_INTERSECT_POINTS_2D: intersection points of two circles in 2D. -! -! Discussion: -! -! Two circles can intersect in 0, 1, 2 or infinitely many points. -! -! The 0 and 2 intersection cases are numerically robust; the 1 and -! infinite intersection cases are numerically fragile. The routine -! uses a tolerance to try to detect the 1 and infinite cases. -! -! Points P on an implicit circle in 2D satisfy the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, the radius of the first circle. -! -! Input, real ( kind = 8 ) PC1(2), the center of the first circle. -! -! Input, real ( kind = 8 ) R2, the radius of the second circle. -! -! Input, real ( kind = 8 ) PC2(2), the center of the second circle. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersecting points -! found. INT_NUM will be 0, 1, 2 or 3. 3 indicates that there are an -! infinite number of intersection points. -! -! Output, real ( kind = 8 ) P(2,2), if INT_NUM is 1 or 2, -! the coordinates of the intersecting points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) distsq - integer(kind=4) int_num - real(kind=8) p(dim_num, 2) - real(kind=8) pc1(dim_num) - real(kind=8) pc2(dim_num) - real(kind=8) r1 - real(kind=8) r2 - real(kind=8) root - real(kind=8) sc1 - real(kind=8) sc2 - real(kind=8) t1 - real(kind=8) t2 - real(kind=8) tol - - tol = epsilon(tol) - - p(1:dim_num, 1:2) = 0.0D+00 -! -! Take care of the case in which the circles have the same center. -! - t1 = (abs(pc1(1) - pc2(1)) & - + abs(pc1(2) - pc2(2))) / 2.0D+00 - - t2 = (abs(pc1(1)) + abs(pc2(1)) & - + abs(pc1(2)) + abs(pc2(2)) + 1.0D+00) / 5.0D+00 - - if (t1 <= tol * t2) then - - t1 = abs(r1 - r2) - t2 = (abs(r1) + abs(r2) + 1.0D+00) / 3.0D+00 - - if (t1 <= tol * t2) then - int_num = 3 - else - int_num = 0 - end if - - return - - end if - - distsq = (pc1(1) - pc2(1))**2 + (pc1(2) - pc2(2))**2 - - root = 2.0D+00 * (r1**2 + r2**2) * distsq - distsq**2 & - - (r1 - r2)**2 * (r1 + r2)**2 - - if (root < -tol) then - int_num = 0 - return - end if - - sc1 = (distsq - (r2**2 - r1**2)) / distsq - - if (root < tol) then - int_num = 1 - p(1:dim_num, 1) = pc1(1:dim_num) & - + 0.5D+00 * sc1 * (pc2(1:dim_num) - pc1(1:dim_num)) - return - end if - - sc2 = sqrt(root) / distsq - - int_num = 2 - - p(1, 1) = pc1(1) + 0.5D+00 * sc1 * (pc2(1) - pc1(1)) & - - 0.5D+00 * sc2 * (pc2(2) - pc1(2)) - p(2, 1) = pc1(2) + 0.5D+00 * sc1 * (pc2(2) - pc1(2)) & - + 0.5D+00 * sc2 * (pc2(1) - pc1(1)) - - p(1, 2) = pc1(1) + 0.5D+00 * sc1 * (pc2(1) - pc1(1)) & - + 0.5D+00 * sc2 * (pc2(2) - pc1(2)) - p(2, 2) = pc1(2) + 0.5D+00 * sc1 * (pc2(2) - pc1(2)) & - - 0.5D+00 * sc2 * (pc2(1) - pc1(1)) - - return -end -subroutine combin2(n, k, icnk) - -!*****************************************************************************80 -! -!! COMBIN2 computes the binomial coefficient C(N,K). -! -! Discussion: -! -! The value is calculated in such a way as to avoid overflow and -! roundoff. The calculation is done in integer arithmetic. -! -! The formula used is: -! -! C(N,K) = N! / ( K! * (N-K)! ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! ML Wolfson, HV Wright, -! Algorithm 160: -! Combinatorial of M Things Taken N at a Time, -! Communications of the ACM, -! April, 1963. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, K, are the values of N and K. -! -! Output, integer ( kind = 4 ) ICNK, the number of combinations of N -! things taken K at a time. -! - implicit none - - integer(kind=4) i - integer(kind=4) icnk - integer(kind=4) k - integer(kind=4) mn - integer(kind=4) mx - integer(kind=4) n - - mn = min(k, n - k) - - if (mn < 0) then - - icnk = 0 - - else if (mn == 0) then - - icnk = 1 - - else - - mx = max(k, n - k) - icnk = mx + 1 - - do i = 2, mn - icnk = (icnk * (mx + i)) / i - end do - - end if - - return -end -subroutine cone_area_3d(h, r, area) - -!*****************************************************************************80 -! -!! CONE_AREA_3D computes the surface area of a right circular cone in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) H, R, the height of the cone, and the radius -! of the circle that forms the base of the cone. -! -! Output, real ( kind = 8 ) AREA, the surface area of the cone. -! - implicit none - - real(kind=8) area - real(kind=8) h - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - area = r8_pi * r * sqrt(h * h + r * r) - - return -end -subroutine cone_centroid_3d(r, pc, pt, centroid) - -!*****************************************************************************80 -! -!! CONE_CENTROID_3D returns the centroid of a cone in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the circle at the base of -! the cone. -! -! Input, real ( kind = 8 ) PC(3), the center of the circle. -! -! Input, real ( kind = 8 ) PT(3), the coordinates of the tip of the cone. -! -! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid -! of the cone. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) centroid(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pt(dim_num) - real(kind=8) r - - centroid(1:dim_num) = 0.75D+00 * pc(1:dim_num) + 0.25D+00 * pt(1:dim_num) - - return -end -subroutine cone_volume_3d(h, r, volume) - -!*****************************************************************************80 -! -!! CONE_VOLUME_3D computes the volume of a right circular cone in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 December 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) H, R, the height of the cone, and the radius -! of the circle that forms the base of the cone. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the cone. -! - implicit none - - real(kind=8) h - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) volume - - volume = r8_pi * r * r * h / 3.0D+00 - - return -end -subroutine conv3d(axis, theta, n, cor3, cor2) - -!*****************************************************************************80 -! -!! CONV3D converts 3D data to a 2D projection. -! -! Discussion: -! -! A "presentation angle" THETA is used to project the 3D point -! (X3D, Y3D, Z3D) to the 2D projection (XVAL,YVAL). -! -! If AXIS = 'X': -! -! X2D = Y3D - sin ( THETA ) * X3D -! Y2D = Z3D - sin ( THETA ) * X3D -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, character AXIS, the coordinate axis to be projected. -! AXIS should be 'X', 'Y', or 'Z'. -! -! Input, real ( kind = 8 ) THETA, the presentation angle in degrees. -! -! Input, integer ( kind = 4 ) N, the number of points. -! -! Input, real ( kind = 8 ) COR3(3,N), the 3D points. -! -! Output, real ( kind = 8 ) COR2(2,N), the 2D projections. -! - implicit none - - integer(kind=4) n - - character axis - real(kind=8) cor2(2, n) - real(kind=8) cor3(3, n) - real(kind=8) degrees_to_radians - real(kind=8) stheta - real(kind=8) theta - - stheta = sin(degrees_to_radians(theta)) - - if (axis == 'X' .or. axis == 'x') then - - cor2(1, 1:n) = cor3(2, 1:n) - stheta * cor3(1, 1:n) - cor2(2, 1:n) = cor3(3, 1:n) - stheta * cor3(1, 1:n) - - else if (axis == 'Y' .or. axis == 'y') then - - cor2(1, 1:n) = cor3(1, 1:n) - stheta * cor3(2, 1:n) - cor2(2, 1:n) = cor3(3, 1:n) - stheta * cor3(2, 1:n) - - else if (axis == 'Z' .or. axis == 'z') then - - cor2(1, 1:n) = cor3(1, 1:n) - stheta * cor3(3, 1:n) - cor2(2, 1:n) = cor3(2, 1:n) - stheta * cor3(3, 1:n) - - else - - write (*, '(a)') ' ' - write (*, '(a)') 'CONV3D - Fatal error!' - write (*, '(a)') ' Illegal coordinate index = "'//axis//'".' - stop 1 - - end if - - return -end -function cot_rad(angle_rad) - -!*****************************************************************************80 -! -!! COT_RAD returns the cotangent of an angle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 July 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) ANGLE_RAD, the angle, in radians. -! -! Output, real ( kind = 8 ) COT_RAD, the cotangent of the angle. -! - implicit none - - real(kind=8) angle_rad - real(kind=8) cot_rad - - cot_rad = cos(angle_rad) / sin(angle_rad) - - return -end -subroutine cube_shape_3d(point_num, face_num, face_order_max, & - point_coord, face_order, face_point) - -!*****************************************************************************80 -! -!! CUBE_SHAPE_3D describes a cube in 3D. -! -! Discussion: -! -! The vertices lie on the unit sphere. -! -! The dual of the cube is the octahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 October 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices -! in a face. -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), -! the vertices. -! -! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices -! per face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. The -! points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) point_num - - real(kind=8) a - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) point_coord(dim_num, point_num) -! -! Set point coordinates. -! - a = sqrt(1.0D+00 / 3.0D+00) - - point_coord(1:dim_num, 1:point_num) = reshape((/ & - -a, -a, -a, & - a, -a, -a, & - a, a, -a, & - -a, a, -a, & - -a, -a, a, & - a, -a, a, & - a, a, a, & - -a, a, a/), (/dim_num, point_num/)) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 4, 4, 4, 4, 4, 4/) -! -! Set the faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 1, 4, 3, 2, & - 1, 2, 6, 5, & - 2, 3, 7, 6, & - 3, 4, 8, 7, & - 1, 5, 8, 4, & - 5, 6, 7, 8/), (/face_order_max, face_num/)) - - return -end -subroutine cube_size_3d(point_num, edge_num, face_num, face_order_max) - -!*****************************************************************************80 -! -!! CUBE_SIZE_3D gives "sizes" for a cube in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 8 - edge_num = 12 - face_num = 6 - face_order_max = 4 - - return -end -function cube01_volume() - -!*****************************************************************************80 -! -!! CUBE01_VOLUME returns the volume of the unit cube in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) CUBE01_VOLUME, the volume. -! - implicit none - - real(kind=8) cube01_volume - - cube01_volume = 1.0D+00 - - return -end -subroutine cylinder_point_dist_3d(p1, p2, r, p, distance) - -!*****************************************************************************80 -! -!! CYLINDER_POINT_DIST_3D: distance from a cylinder to a point in 3D. -! -! Discussion: -! -! We are computing the distance to the SURFACE of the cylinder. -! -! The surface of a (right) (finite) cylinder in 3D is defined by an axis, -! which is the line segment from point P1 to P2, and a radius R. The points -! on the surface of the cylinder are: -! * points at a distance R from the line through P1 and P2, and whose nearest -! point on the line through P1 and P2 is strictly between P1 and P2, -! PLUS -! * points at a distance less than or equal to R from the line through P1 -! and P2, whose nearest point on the line through P1 and P2 is either -! P1 or P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 23 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points -! on the axis line of the cylinder. -! -! Input, real ( kind = 8 ) R, the radius of the cylinder. -! -! Input, real ( kind = 8 ) P(3), the point. -! -! Output, real ( kind = 8 ) DISTANCE, the distance from the point -! to the cylinder. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) axis(dim_num) - real(kind=8) axis_length - real(kind=8) distance - real(kind=8) r8vec_norm - real(kind=8) off_axis_component - real(kind=8) p(3) - real(kind=8) p_dot_axis - real(kind=8) p_length - real(kind=8) p1(3) - real(kind=8) p2(3) - real(kind=8) r - - axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - axis_length = r8vec_norm(dim_num, axis) - - if (axis_length == 0.0D+00) then - distance = -huge(distance) - return - end if - - axis(1:dim_num) = axis(1:dim_num) / axis_length - - p_dot_axis = dot_product(p(1:dim_num) - p1(1:dim_num), axis) -! -! Case 1: Below bottom cap. -! - if (p_dot_axis <= 0.0D+00) then - - call disk_point_dist_3d(p1, r, axis, p, distance) -! -! Case 2: between cylinder planes. -! - else if (p_dot_axis <= axis_length) then - - p_length = r8vec_norm(dim_num, p(1:dim_num) - p1(1:dim_num)) - off_axis_component = sqrt(p_length**2 - p_dot_axis**2) - - distance = abs(off_axis_component - r) - - if (off_axis_component < r) then - distance = min(distance, axis_length - p_dot_axis) - distance = min(distance, p_dot_axis) - end if -! -! Case 3: Above the top cap. -! - else if (axis_length < p_dot_axis) then - - call disk_point_dist_3d(p2, r, axis, p, distance) - - end if - - return -end -subroutine cylinder_point_dist_signed_3d(p1, p2, r, p, distance) - -!*****************************************************************************80 -! -!! CYLINDER_POINT_DIST_SIGNED_3D: signed distance from cylinder to point in 3D. -! -! Discussion: -! -! We are computing the signed distance to the SURFACE of the cylinder. -! -! The surface of a (right) (finite) cylinder in 3D is defined by an axis, -! which is the line segment from point P1 to P2, and a radius R. The points -! on the surface of the cylinder are: -! * points at a distance R from the line through P1 and P2, and whose nearest -! point on the line through P1 and P2 is strictly between P1 and P2, -! PLUS -! * points at a distance less than or equal to R from the line through P1 -! and P2, whose nearest point on the line through P1 and P2 is either -! P1 or P2. -! -! Points inside the surface have a negative distance. -! Points on the surface have a zero distance. -! Points outside the surface have a positive distance. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points -! on the axis line of the cylinder. -! -! Input, real ( kind = 8 ) R, the radius of the cylinder. -! -! Input, real ( kind = 8 ) P(3), the point. -! -! Output, real ( kind = 8 ) DISTANCE, the signed distance from the point -! to the cylinder. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) axis(dim_num) - real(kind=8) axis_length - real(kind=8) distance - real(kind=8) r8vec_norm - real(kind=8) off_axis_component - real(kind=8) p(dim_num) - real(kind=8) p_dot_axis - real(kind=8) p_length - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) r - - axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - axis_length = r8vec_norm(dim_num, axis) - - if (axis_length == 0.0D+00) then - distance = -huge(distance) - return - end if - - axis(1:dim_num) = axis(1:dim_num) / axis_length - - p_dot_axis = dot_product(p(1:dim_num) - p1(1:dim_num), axis) -! -! Case 1: Below bottom cap. -! - if (p_dot_axis <= 0.0D+00) then - - call disk_point_dist_3d(p1, r, axis, p, distance) -! -! Case 2: between cylinder planes. -! - else if (p_dot_axis <= axis_length) then - - p_length = r8vec_norm(dim_num, p(1:dim_num) - p1(1:dim_num)) - off_axis_component = sqrt(p_length**2 - p_dot_axis**2) - - distance = off_axis_component - r - - if (distance < 0.0D+00) then - distance = max(distance, p_dot_axis - axis_length) - distance = max(distance, -p_dot_axis) - end if -! -! Case 3: Above the top cap. -! - else if (axis_length < p_dot_axis) then - - call disk_point_dist_3d(p2, r, axis, p, distance) - - end if - - return -end -subroutine cylinder_point_inside_3d(p1, p2, r, p, inside) - -!*****************************************************************************80 -! -!! CYLINDER_POINT_INSIDE_3D determines if a cylinder contains a point in 3D. -! -! Discussion: -! -! The surface and interior of a (right) (finite) cylinder in 3D is defined -! by an axis, which is the line segment from point P1 to P2, and a -! radius R. The points contained in the volume include: -! * points at a distance less than or equal to R from the line through P1 -! and P2, whose nearest point on the line through P1 and P2 is, in fact, -! P1, P2, or any point between them. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 23 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points -! on the axis line of the cylinder. -! -! Input, real ( kind = 8 ) R, the radius of the cylinder. -! -! Input, real ( kind = 8 ) P(3), the point. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is -! inside the cylinder. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) axis(dim_num) - real(kind=8) axis_length - logical(kind=4) inside - real(kind=8) off_axis_component - real(kind=8) p(dim_num) - real(kind=8) p_dot_axis - real(kind=8) p_length - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) r - real(kind=8) r8vec_norm - - axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - axis_length = r8vec_norm(dim_num, axis) - - if (axis_length == 0.0D+00) then - inside = .false. - return - end if - - axis(1:dim_num) = axis(1:dim_num) / axis_length - - p_dot_axis = dot_product(p(1:dim_num) - p1(1:dim_num), axis) -! -! If the point lies below or above the "caps" of the cylinder, we're done. -! - if (p_dot_axis < 0.0D+00 .or. axis_length < p_dot_axis) then - - inside = .false. -! -! Otherwise, determine the distance from P to the axis. -! - else - - p_length = r8vec_norm(dim_num, p(1:dim_num) - p1(1:dim_num)) - - off_axis_component = sqrt(p_length**2 - p_dot_axis**2) - - if (off_axis_component <= r) then - inside = .true. - else - inside = .false. - end if - - end if - - return -end -subroutine cylinder_point_near_3d(p1, p2, r, p, pn) - -!*****************************************************************************80 -! -!! CYLINDER_POINT_NEAR_3D: nearest point on a cylinder to a point in 3D. -! -! Discussion: -! -! We are computing the nearest point on the SURFACE of the cylinder. -! -! The surface of a (right) (finite) cylinder in 3D is defined by an axis, -! which is the line segment from point P1 to P2, and a radius R. The points -! on the surface of the cylinder are: -! * points at a distance R from the line through P1 and P2, and whose nearest -! point on the line through P1 and P2 is strictly between P1 and P2, -! PLUS -! * points at a distance less than or equal to R from the line through P1 -! and P2, whose nearest point on the line through P1 and P2 is either -! P1 or P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points -! on the axis line of the cylinder. -! -! Input, real ( kind = 8 ) R, the radius of the cylinder. -! -! Input, real ( kind = 8 ) P(3), the point. -! -! Output, real ( kind = 8 ) PN(3), the nearest point on the cylinder. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) axial_component - real(kind=8) axis(dim_num) - real(kind=8) axis_length - real(kind=8) distance - real(kind=8) r8vec_norm - real(kind=8) off_axis(dim_num) - real(kind=8) off_axis_component - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) r - - axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - axis_length = r8vec_norm(dim_num, axis) - axis(1:dim_num) = axis(1:dim_num) / axis_length - - axial_component = dot_product(p(1:dim_num) - p1(1:dim_num), axis) - - off_axis(1:dim_num) = p(1:dim_num) - p1(1:dim_num) & - - axial_component * axis(1:dim_num) - - off_axis_component = r8vec_norm(dim_num, off_axis) -! -! Case 1: Below bottom cap. -! - if (axial_component <= 0.0D+00) then - - if (off_axis_component <= r) then - pn(1:dim_num) = p1(1:dim_num) + off_axis(1:dim_num) - else - pn(1:dim_num) = p1(1:dim_num) & - + (r / off_axis_component) * off_axis(1:dim_num) - end if -! -! Case 2: between cylinder planes. -! - else if (axial_component <= axis_length) then - - if (off_axis_component == 0.0D+00) then - - call r8vec_any_normal(dim_num, axis, off_axis) - - pn(1:dim_num) = p(1:dim_num) + r * off_axis(1:dim_num) - - else - - distance = abs(off_axis_component - r) - - pn(1:dim_num) = p1(1:dim_num) + axial_component * axis(1:dim_num) & - + (r / off_axis_component) * off_axis(1:dim_num) - - if (off_axis_component < r) then - - if (axis_length - axial_component < distance) then - distance = axis_length - axial_component - pn(1:dim_num) = p2(1:dim_num) + off_axis(1:dim_num) - end if - - if (axial_component < distance) then - distance = axial_component - pn(1:dim_num) = p1(1:dim_num) + off_axis(1:dim_num) - end if - - end if - - end if -! -! Case 3: Above the top cap. -! - else if (axis_length < axial_component) then - - if (off_axis_component <= r) then - pn(1:dim_num) = p2(1:dim_num) + off_axis(1:dim_num) - else - pn(1:dim_num) = p2(1:dim_num) & - + (r / off_axis_component) * off_axis(1:dim_num) - end if - - end if - - return -end -subroutine cylinder_sample_3d(p1, p2, r, n, seed, p) - -!*****************************************************************************80 -! -!! CYLINDER_SAMPLE_3D samples a cylinder in 3D. -! -! Discussion: -! -! We are sampling the interior of a right finite cylinder in 3D. -! -! The interior of a (right) (finite) cylinder in 3D is defined by an axis, -! which is the line segment from point P1 to P2, and a radius R. The points -! on or inside the cylinder are: -! * points whose distance from the line through P1 and P2 is less than -! or equal to R, and whose nearest point on the line through P1 and P2 -! lies (nonstrictly) between P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points -! on the axis line of the cylinder. -! -! Input, real ( kind = 8 ) R, the radius of the cylinder. -! -! Input, integer ( kind = 4 ) N, the number of sample points to compute. -! -! Input/output, integer ( kind = 4 ) SEED, the random number seed. -! -! Input, real ( kind = 8 ) P(3,N), the sample points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) n - - real(kind=8) axis(dim_num) - real(kind=8) axis_length - real(kind=8) r8vec_norm - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radius(n) - integer(kind=4) seed - real(kind=8) theta(n) - real(kind=8) v2(dim_num) - real(kind=8) v3(dim_num) - real(kind=8) z(n) -! -! Compute the axis vector. -! - axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - axis_length = r8vec_norm(dim_num, axis) - axis(1:dim_num) = axis(1:dim_num) / axis_length -! -! Compute vectors V2 and V3 that form an orthogonal triple with AXIS. -! - call plane_normal_basis_3d(p1, axis, v2, v3) -! -! Assemble the randomized information. -! - call random_number(harvest=radius(1:n)) - radius(1:n) = r * sqrt(radius(1:n)) - - call random_number(harvest=theta(1:n)) - theta(1:n) = 2.0D+00 * r8_pi * theta(1:n) - - call random_number(harvest=z(1:n)) - z(1:n) = axis_length * z(1:n) - - do i = 1, dim_num - - p(i, 1:n) = p1(i) & - + z(1:n) * axis(i) & - + radius(1:n) * cos(theta(1:n)) * v2(i) & - + radius(1:n) * sin(theta(1:n)) * v3(i) - - end do - - return -end -subroutine cylinder_volume_3d(p1, p2, r, volume) - -!*****************************************************************************80 -! -!! CYLINDER_VOLUME_3D determines the volume of a cylinder in 3D. -! -! Discussion: -! -! The surface and interior of a (right) (finite) cylinder in 3D is defined -! by an axis, which is the line segment from point P1 to P2, and a radius R. -! The points contained in the volume include: -! * points at a distance less than or equal to R from the line through P1 -! and P2, whose nearest point on the line through P1 and P2 is, in fact, -! P1, P2, or any point between them. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points -! on the axis line of the cylinder. -! -! Input, real ( kind = 8 ) R, the radius of the cylinder. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the cylinder. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) h - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) volume - - h = sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) - - volume = r8_pi * r * r * h - - return -end -function degrees_to_radians(angle_deg) - -!*****************************************************************************80 -! -!! DEGREES_TO_RADIANS converts an angle from degrees to radians. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 July 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) ANGLE_DEG, an angle in degrees. -! -! Output, real ( kind = 8 ) DEGREES_TO_RADIANS, the equivalent angle -! in radians. -! - implicit none - - real(kind=8) angle_deg - real(kind=8) degrees_to_radians - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - degrees_to_radians = (angle_deg / 180.0D+00) * r8_pi - - return -end -subroutine direction_pert_3d(sigma, vbase, seed, vran) - -!*****************************************************************************80 -! -!! DIRECTION_PERT_3D randomly perturbs a direction vector in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 August 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) SIGMA, determines the strength of the -! perturbation. -! SIGMA <= 0 results in a completely random direction. -! 1 <= SIGMA results in VBASE. -! 0 < SIGMA < 1 results in a perturbation from VBASE, which is -! large when SIGMA is near 0, and small when SIGMA is near 1. -! -! Input, real ( kind = 8 ) VBASE(3), the base direction vector, which -! should have unit norm. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) VRAN(3), the perturbed vector, which will -! have unit norm. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) r8_uniform_01 - real(kind=8) dphi - real(kind=8) phi - real(kind=8) psi - real(kind=8) r - real(kind=8) r8_acos - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seed - real(kind=8) sigma - real(kind=8) theta - real(kind=8) v(dim_num) - real(kind=8) vbase(dim_num) - real(kind=8) vdot - real(kind=8) vran(dim_num) - real(kind=8) x -! -! 1 <= SIGMA, just use the base vector. -! - if (1.0D+00 <= sigma) then - - vran(1:dim_num) = vbase(1:dim_num) - - else if (sigma <= 0.0D+00) then - - vdot = r8_uniform_01(seed) - vdot = 2.0D+00 * vdot - 1.0D+00 - - phi = r8_acos(vdot) - - theta = r8_uniform_01(seed) - theta = 2.0D+00 * r8_pi * theta - - vran(1) = cos(theta) * sin(phi) - vran(2) = sin(theta) * sin(phi) - vran(3) = cos(phi) - - else - - phi = r8_acos(vbase(3)) - theta = atan2(vbase(2), vbase(1)) -! -! Pick VDOT, which must be between -1 and 1. This represents -! the dot product of the perturbed vector with the base vector. -! -! R8_UNIFORM_01 returns a uniformly random value between 0 and 1. -! The operations we perform on this quantity tend to bias it -! out towards 1, as SIGMA grows from 0 to 1. -! -! VDOT, in turn, is a value between -1 and 1, which, for large -! SIGMA, we want biased towards 1. -! - r = r8_uniform_01(seed) - x = exp((1.0D+00 - sigma) * log(r)) - dphi = r8_acos(2.0D+00 * x - 1.0D+00) -! -! Now we know enough to write down a vector that is rotated DPHI -! from the base vector. -! - v(1) = cos(theta) * sin(phi + dphi) - v(2) = sin(theta) * sin(phi + dphi) - v(3) = cos(phi + dphi) -! -! Pick a uniformly random rotation between 0 and 2 Pi around the -! axis of the base vector. -! - psi = r8_uniform_01(seed) - psi = 2.0D+00 * r8_pi * psi -! -! Carry out the rotation. -! - call rotation_axis_vector_3d(vbase, psi, v, vran) - - end if - - return -end -subroutine direction_uniform_2d(seed, vran) - -!*****************************************************************************80 -! -!! DIRECTION_UNIFORM_2D picks a random direction vector in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) VRAN(2), the random direction vector, with -! unit norm. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r8_uniform_01 - integer(kind=4) seed - real(kind=8) theta - real(kind=8) vran(dim_num) - - theta = r8_uniform_01(seed) - theta = 2.0D+00 * r8_pi * theta - - vran(1) = cos(theta) - vran(2) = sin(theta) - - return -end -subroutine direction_uniform_3d(seed, vran) - -!*****************************************************************************80 -! -!! DIRECTION_UNIFORM_3D picks a random direction vector in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 December 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) VRAN(3), the random direction vector, -! with unit norm. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) r8_uniform_01 - real(kind=8) phi - real(kind=8) r8_acos - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seed - real(kind=8) theta - real(kind=8) vdot - real(kind=8) vran(dim_num) -! -! Pick a uniformly random VDOT, which must be between -1 and 1. -! This represents the dot product of the random vector with the Z unit vector. -! -! Note: this works because the surface area of the sphere between -! Z and Z + dZ is independent of Z. So choosing Z uniformly chooses -! a patch of area uniformly. -! - vdot = r8_uniform_01(seed) - vdot = 2.0D+00 * vdot - 1.0D+00 - - phi = r8_acos(vdot) -! -! Pick a uniformly random rotation between 0 and 2 Pi around the -! axis of the Z vector. -! - theta = r8_uniform_01(seed) - theta = 2.0D+00 * r8_pi * theta - - vran(1) = cos(theta) * sin(phi) - vran(2) = sin(theta) * sin(phi) - vran(3) = cos(phi) - - return -end -subroutine direction_uniform_nd(dim_num, seed, w) - -!*****************************************************************************80 -! -!! DIRECTION_UNIFORM_ND generates a random direction vector in ND. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 13 February 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) W(DIM_NUM), a random direction vector, -! with unit norm. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) norm - integer(kind=4) seed - real(kind=8) w(dim_num) -! -! Get N values from a standard normal distribution. -! - call r8vec_normal_01(dim_num, seed, w) -! -! Compute the length of the vector. -! - norm = sqrt(sum(w(1:dim_num)**2)) -! -! Normalize the vector. -! - w(1:dim_num) = w(1:dim_num) / norm - - return -end -subroutine disk_point_dist_3d(pc, r, axis, p, dist) - -!*****************************************************************************80 -! -!! DISK_POINT_DIST_3D determines the distance from a disk to a point in 3D. -! -! Discussion: -! -! A disk in 3D satisfies the equations: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 + ( P(3) - PC(3) <= R^2 -! -! and -! -! P(1) * AXIS(1) + P(2) * AXIS(2) + P(3) * AXIS(3) = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(3), the center of the disk. -! -! Input, real ( kind = 8 ) R, the radius of the disk. -! -! Input, real ( kind = 8 ) AXIS(3), the axis vector. -! -! Input, real ( kind = 8 ) P(3), the point to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance of the point to the disk. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) axial_component - real(kind=8) axis(dim_num) - real(kind=8) axis_length - real(kind=8) dist - real(kind=8) r8vec_norm - real(kind=8) off_axis_component - real(kind=8) off_axis(dim_num) - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r -! -! Special case: the point is the center. -! - if (all(p(1:dim_num) == pc(1:dim_num))) then - dist = 0.0D+00 - return - end if - - axis_length = r8vec_norm(dim_num, axis(1:dim_num)) - - if (axis_length == 0.0D+00) then - dist = -huge(dist) - return - end if - - axial_component = dot_product(p(1:dim_num) - pc(1:dim_num), & - axis(1:dim_num)) / axis_length -! -! Special case: the point satisfies the disk equation exactly. -! - if (sum(p(1:dim_num) - pc(1:dim_num))**2 <= r * r .and. & - axial_component == 0.0D+00) then - dist = 0.0D+00 - return - end if -! -! Decompose P-PC into axis component and off-axis component. -! - off_axis(1:dim_num) = p(1:dim_num) - pc(1:dim_num) & - - axial_component * axis(1:dim_num) / axis_length - - off_axis_component = r8vec_norm(dim_num, off_axis) -! -! If the off-axis component has norm less than R, the nearest point is -! the projection to the disk along the axial direction, and the distance -! is just the dot product of P-PC with unit AXIS. -! - if (off_axis_component <= r) then - dist = abs(axial_component) - return - end if -! -! Otherwise, the nearest point is along the perimeter of the disk. -! - dist = sqrt(axial_component**2 + (off_axis_component - r)**2) - - return -end -subroutine dms_to_radians(degrees, minutes, seconds, radians) - -!*****************************************************************************80 -! -!! DMS_TO_RADIANS converts an angle from degrees/minutes/seconds to radians. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 June 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DEGREES, MINUTES, SECONDS, an angle in -! degrees, minutes, and seconds. -! -! Output, real ( kind = 8 ) RADIANS, the equivalent angle in radians. -! - implicit none - - real(kind=8) angle - integer(kind=4) degrees - integer(kind=4) minutes - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radians - integer(kind=4) seconds - - angle = real(degrees, kind=8) & - + (real(minutes, kind=8) & - + (real(seconds, kind=8) / 60.0D+00)) / 60.0D+00 - - radians = (angle / 180.0D+00) * r8_pi - - return -end -subroutine dodec_shape_3d(point_num, face_num, face_order_max, & - point_coord, face_order, face_point) - -!*****************************************************************************80 -! -!! DODEC_SHAPE_3D describes a dodecahedron in 3D. -! -! Discussion: -! -! The vertices lie on the unit sphere. -! -! The dual of a dodecahedron is an icosahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 October 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices -! per face. -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. -! -! Output, integer ( kind = 4 ) FACE_ORDER[FACE_NUM], the number of vertices -! per face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,POINT_NUM); -! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. -! The points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - real(kind=8) a - real(kind=8) b - real(kind=8) c - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) phi - real(kind=8) point_coord(dim_num, point_num) - real(kind=8) z -! -! Set point coordinates. -! - phi = 0.5D+00 * (sqrt(5.0D+00) + 1.0D+00) - - a = 1.0D+00 / sqrt(3.0D+00) - b = phi / sqrt(3.0D+00) - c = (phi - 1.0D+00) / sqrt(3.0D+00) - z = 0.0D+00 - - point_coord(1:dim_num, 1:point_num) = reshape((/ & - a, a, a, & - a, a, -a, & - a, -a, a, & - a, -a, -a, & - -a, a, a, & - -a, a, -a, & - -a, -a, a, & - -a, -a, -a, & - c, b, z, & - -c, b, z, & - c, -b, z, & - -c, -b, z, & - b, z, c, & - b, z, -c, & - -b, z, c, & - -b, z, -c, & - z, c, b, & - z, -c, b, & - z, c, -b, & - z, -c, -b/), (/dim_num, point_num/)) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5/) -! -! Set the faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 2, 9, 1, 13, 14, & - 5, 10, 6, 16, 15, & - 3, 11, 4, 14, 13, & - 8, 12, 7, 15, 16, & - 3, 13, 1, 17, 18, & - 2, 14, 4, 20, 19, & - 5, 15, 7, 18, 17, & - 8, 16, 6, 19, 20, & - 5, 17, 1, 9, 10, & - 3, 18, 7, 12, 11, & - 2, 19, 6, 10, 9, & - 8, 20, 4, 11, 12/), (/face_order_max, face_num/)) - - return -end -subroutine dodec_size_3d(point_num, edge_num, face_num, face_order_max) - -!*****************************************************************************80 -! -!! DODEC_SIZE_3D gives "sizes" for a dodecahedron in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 20 - edge_num = 30 - face_num = 12 - face_order_max = 5 - - return -end -subroutine dual_shape_3d(point_num, face_num, face_order_max, & - point_coord, face_order, face_point, point_num2, face_num2, & - face_order_max2, point_coord2, face_order2, face_point2) - -!*****************************************************************************80 -! -!! DUAL_SHAPE_3D constructs the dual of a shape in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 23 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices -! per face. -! -! Input, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. -! -! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices -! per face. -! -! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The -! points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! -! Input, integer ( kind = 4 ) POINT_NUM2, the number of points in the dual. -! -! Input, integer ( kind = 4 ) FACE_NUM2, the number of faces in the dual. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX2, the maximum number of -! vertices per face in the dual. -! -! Output, real ( kind = 8 ) POINT_COORD2(3,POINT_NUM2), the point -! coordinates of the dual. -! -! Output, integer ( kind = 4 ) FACE_ORDER2(FACE_NUM2), the number of -! vertices per face. -! -! Output, integer ( kind = 4 ) FACE_POINT2(FACE_ORDER_MAX2,FACE_NUM2), -! the vertices of each face in the dual. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) face_num2 - integer(kind=4) face_order_max - integer(kind=4) face_order_max2 - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) point_num - integer(kind=4) point_num2 - - integer(kind=4) col - integer(kind=4) face - integer(kind=4) face_order(face_num) - integer(kind=4) face_order2(face_num2) - integer(kind=4) face_point(face_order_max, face_num) - integer(kind=4) face_point2(face_order_max2, face_num2) - integer(kind=4) i - integer(kind=4) inext - integer(kind=4) iprev - integer(kind=4) istop - integer(kind=4) j - integer(kind=4) k - real(kind=8) norm - real(kind=8) p(dim_num) - real(kind=8) point_coord(dim_num, point_num) - real(kind=8) point_coord2(dim_num, point_num2) - integer(kind=4) row -! -! This computation should really compute the center of gravity -! of the face, in the general case. -! -! We'll also assume the vertices of the original and the dual -! are to lie on the unit sphere, so we can normalize the -! position vector of the vertex. -! - do face = 1, face_num - - p(1:dim_num) = 0.0D+00 - - do j = 1, face_order(face) - k = face_point(j, face) - p(1:dim_num) = p(1:dim_num) + point_coord(1:dim_num, k) - end do - - norm = sqrt(sum(p(1:dim_num)**2)) - - point_coord2(1:dim_num, face) = p(1:dim_num) / norm - - end do -! -! Now build the face in the dual associated with each node FACE. -! - do face = 1, face_num2 -! -! Initialize the order. -! - face_order2(face) = 0 -! -! Find the first occurrence of FACE in an edge of polyhedron. -! - call i4col_find_item(face_order_max, face_num, face_point, & - face, row, col) - - if (row <= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'DUAL_SHAPE_3D - Fatal error!' - write (*, '(a,i8)') ' Could not find an edge using node ', face - stop 1 - end if -! -! Save the following node as ISTOP. -! When we encounter ISTOP again, this will mark the end of our search. -! - i = row + 1 - if (face_order(col) < i) then - i = 1 - end if - - istop = face_point(i, col) -! -! Save the previous node as INEXT. -! - do - - i = row - 1 - if (i < 1) then - i = i + face_order(col) - end if - - inext = face_point(i, col) - - face_order2(face) = face_order2(face) + 1 - - face_point2(face_order2(face), face) = col -! -! If INEXT =/= ISTOP, continue. -! - if (inext == istop) then - exit - end if -! -! Set IPREV:= INEXT. -! - iprev = inext -! -! Search for the occurrence of the edge FACE-IPREV. -! - call i4col_find_pair_wrap(face_order_max, face_num, face_point, & - face, iprev, row, col) - - if (row <= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'DUAL_SHAPE_3D - Fatal error!' - write (*, '(a,i8)') ' No edge from node ', iprev - write (*, '(a,i8)') ' to node ', face - stop 1 - end if - - end do - - end do - - return -end -subroutine dual_size_3d(point_num, edge_num, face_num, face_order_max, & - point_coord, face_order, face_point, point_num2, edge_num2, face_num2, & - face_order_max2) - -!*****************************************************************************80 -! -!! DUAL_SIZE_3D determines sizes for a dual of a shape in 3D. -! -! Discussion: -! -! We don't actually need FACE_POINT as input here. But since the -! three arrays occur together everywhere else, it seems unnecessarily -! user-confusing to vary the usage here! -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices -! per face. -! -! Input, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. -! -! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices -! per face. -! -! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The -! points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! -! Output, integer ( kind = 4 ) POINT_NUM2, the number of points in the dual. -! -! Output, integer ( kind = 4 ) EDGE_NUM2, the number of edges in the dual. -! -! Output, integer ( kind = 4 ) FACE_NUM2, the number of faces in the dual. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX2, the maximum number of -! vertices per face in the dual. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - integer(kind=4) edge_num - integer(kind=4) edge_num2 - integer(kind=4) face - integer(kind=4) face_num2 - integer(kind=4) face_order(face_num) - integer(kind=4) face_order2(point_num) - integer(kind=4) face_order_max2 - integer(kind=4) face_point(face_order_max, face_num) - integer(kind=4) face2 - integer(kind=4) i - integer(kind=4) point_num2 - real(kind=8) point_coord(dim_num, point_num) -! -! These values are easy to compute: -! - point_num2 = face_num - edge_num2 = edge_num - face_num2 = point_num -! -! To determine FACE_ORDER_MAX2 is not so easy. -! You have to construct the FACE_ORDER array for the dual shape. -! The order of a dual face is the number of edges that the vertex occurs in. -! But then all we have to do is count how many times each item shows up -! in the FACE_POINT array. -! - face_order_max2 = 0 - face_order2(1:face_num2) = 0 - - do face = 1, face_num - do i = 1, face_order(face) - face2 = face_point(i, face) - face_order2(face2) = face_order2(face2) + 1 - end do - end do - - face_order_max2 = maxval(face_order2(1:face_num2)) - - return -end -function ellipse_area1(a, r) - -!*****************************************************************************80 -! -!! ELLIPSE_AREA1 returns the area of an ellipse defined by a matrix. -! -! Discussion: -! -! The points X in the ellipse are described by a 2 by 2 -! positive definite symmetric matrix A, and a "radius" R, such that -! X' * A * X <= R * R -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 April 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(2,2), the matrix that describes -! the ellipse. A must be symmetric and positive definite. -! -! Input, real ( kind = 8 ) R, the "radius" of the ellipse. -! -! Output, real ( kind = 8 ) ELLIPSE_AREA1, the area of the ellipse. -! - implicit none - - real(kind=8) a(2, 2) - real(kind=8) ellipse_area1 - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - ellipse_area1 = r**2 * r8_pi / sqrt(a(1, 1) * a(2, 2) - a(2, 1) * a(1, 2)) - - return -end -function ellipse_area2(a, b, c, d) - -!*****************************************************************************80 -! -!! ELLIPSE_AREA2 returns the area of an ellipse defined by an equation. -! -! Discussion: -! -! The ellipse is described by the formula -! a x^2 + b xy + c y^2 = d -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 November 2016 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, coefficients on the left hand side. -! -! Input, real ( kind = 8 ) D, the right hand side. -! -! Output, real ( kind = 8 ) ELLIPSE_AREA2, the area of the ellipse. -! - implicit none - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) ellipse_area2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - ellipse_area2 = 2.0D+00 * d * d * r8_pi / sqrt(4.0D+00 * a * c - b * b) - - return -end -function ellipse_area3(r1, r2) - -!*****************************************************************************80 -! -!! ELLIPSE_AREA3 returns the area of an ellipse in 2D. -! -! Discussion: -! -! An ellipse in standard position has a center at the origin, and -! axes aligned with the coordinate axes. Any point P on the ellipse -! satisfies -! -! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the "radius" of the ellipse in the major -! and minor axis directions. A circle has these values equal. -! -! Output, real ( kind = 8 ) ELLIPSE_AREA3, the area of the ellipse. -! - implicit none - - real(kind=8) ellipse_area3 - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - ellipse_area3 = r8_pi * r1 * r2 - - return -end -subroutine ellipse_point_dist_2d(r1, r2, p, dist) - -!*****************************************************************************80 -! -!! ELLIPSE_POINT_DIST_2D finds the distance from a point to an ellipse in 2D. -! -! Discussion: -! -! An ellipse in standard position has a center at the origin, and -! axes aligned with the coordinate axes. Any point P on the ellipse -! satisfies -! -! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Dianne O'Leary, -! Elastoplastic Torsion: Twist and Stress, -! Computing in Science and Engineering, -! July/August 2004, pages 74-76. -! September/October 2004, pages 63-65. -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the ellipse parameters. Normally, -! these are both positive quantities. Generally, they are also -! distinct. -! -! Input, real ( kind = 8 ) P(2), the point. -! -! Output, real ( kind = 8 ) DIST, the distance to the ellipse. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) r1 - real(kind=8) r2 - - call ellipse_point_near_2d(r1, r1, p, pn) - - dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - - return -end -subroutine ellipse_point_near_2d(r1, r2, p, pn) - -!*****************************************************************************80 -! -!! ELLIPSE_POINT_NEAR_2D finds the nearest point on an ellipse in 2D. -! -! Discussion: -! -! An ellipse in standard position has a center at the origin, and -! axes aligned with the coordinate axes. Any point P on the ellipse -! satisfies -! -! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 -! -! The nearest point PN on the ellipse has the property that the -! line from PN to P is normal to the ellipse. Points on the ellipse -! can be parameterized by T, to have the form -! -! ( R1 * cos ( T ), R2 * sin ( T ) ). -! -! The tangent vector to the ellipse has the form -! -! ( -R1 * sin ( T ), R2 * cos ( T ) ) -! -! At PN, the dot product of this vector with ( P - PN ) must be -! zero: -! -! - R1 * sin ( T ) * ( X - R1 * cos ( T ) ) -! + R2 * cos ( T ) * ( Y - R2 * sin ( T ) ) = 0 -! -! This nonlinear equation for T can be solved by Newton's method. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the ellipse parameters. Normally, -! these are both positive quantities. Generally, they are also -! distinct. -! -! Input, real ( kind = 8 ) P(2), the point. -! -! Output, real ( kind = 8 ) PN(2), the point on the ellipse which -! is closest to P. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) ct - real(kind=8) f - real(kind=8) fp - integer(kind=4) iteration - integer(kind=4), parameter :: iteration_max = 100 - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) st - real(kind=8) t - real(kind=8) x - real(kind=8) y - - x = abs(p(1)) - y = abs(p(2)) - - if (y == 0.0D+00 .and. r1 * r1 - r2 * r2 <= r1 * x) then - - t = 0.0D+00 - - else if (x == 0.0D+00 .and. r2 * r2 - r1 * r1 <= r2 * y) then - - t = r8_pi / 2.0D+00 - - else - - if (y == 0.0D+00) then - y = sqrt(epsilon(y)) * abs(r2) - end if - - if (x == 0.0D+00) then - x = sqrt(epsilon(x)) * abs(r1) - end if -! -! Initial parameter T: -! - t = atan2(y, x) - - iteration = 0 - - do - - ct = cos(t) - st = sin(t) - - f = (x - abs(r1) * ct) * abs(r1) * st & - - (y - abs(r2) * st) * abs(r2) * ct - - if (abs(f) <= 100.0D+00 * epsilon(f)) then - exit - end if - - if (iteration_max <= iteration) then - write (*, '(a)') ' ' - write (*, '(a)') 'ELLIPSE_POINT_NEAR_2D - Warning!' - write (*, '(a)') ' Reached iteration limit.' - write (*, '(a,f8.6)') ' T = ', t - write (*, '(a,g14.6)') ' F = ', f - exit - end if - - iteration = iteration + 1 - - fp = r1 * r1 * st * st + r2 * r2 * ct * ct & - + (x - abs(r1) * ct) * abs(r1) * ct & - + (y - abs(r2) * st) * abs(r2) * st - - t = t - f / fp - - end do - - end if -! -! From the T value, we get the nearest point. -! - pn(1) = abs(r1) * cos(t) - pn(2) = abs(r2) * sin(t) -! -! Take care of case where the point was in another quadrant. -! - pn(1) = sign(1.0D+00, p(1)) * pn(1) - pn(2) = sign(1.0D+00, p(2)) * pn(2) - - return -end -subroutine ellipse_points_2d(pc, r1, r2, psi, n, p) - -!*****************************************************************************80 -! -!! ELLIPSE_POINTS_2D returns N points on an tilted ellipse in 2D. -! -! Discussion: -! -! An ellipse in standard position has a center at the origin, and -! axes aligned with the coordinate axes. Any point P on the ellipse -! satisfies -! -! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 -! -! The points are "equally spaced" in the angular sense. They are -! not equally spaced along the perimeter of the ellipse. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(2), the center of the ellipse. -! -! Input, real ( kind = 8 ) R1, R2, the "radius" of the ellipse in the major -! and minor axis directions. A circle has these values equal. -! -! Input, real ( kind = 8 ) PSI, the angle that the major axis of the ellipse -! makes with the X axis. A value of 0.0 means that the major and -! minor axes of the ellipse will be the X and Y coordinate axes. -! -! Input, integer ( kind = 4 ) N, the number of points desired. N must -! be at least 1. -! -! Output, real ( kind = 8 ) P(2,N), points on the ellipse. -! - implicit none - - integer(kind=4) n - - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) pc(dim_num) - real(kind=8) psi - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - - do i = 1, n - - theta = (2.0D+00 * r8_pi * real(i - 1, kind=8)) & - / real(n, kind=8) - - p(1, i) = pc(1) + r1 * cos(psi) * cos(theta) & - - r2 * sin(psi) * sin(theta) - - p(2, i) = pc(2) + r1 * sin(psi) * cos(theta) & - + r2 * cos(psi) * sin(theta) - - end do - - return -end -subroutine ellipse_points_arc_2d(pc, r1, r2, psi, theta1, theta2, n, p) - -!*****************************************************************************80 -! -!! ELLIPSE_POINTS_ARC_2D returns N points on a tilted elliptical arc in 2D. -! -! Discussion: -! -! An ellipse in standard position has a center at the origin, and -! axes aligned with the coordinate axes. Any point P on the ellipse -! satisfies -! -! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 -! -! The points are "equally spaced" in the angular sense. They are -! not equally spaced along the perimeter of the ellipse. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(2), the coordinates of the center of -! the ellipse. -! -! Input, real ( kind = 8 ) R1, R2, the "radius" of the ellipse in the major -! and minor axis directions. A circle has these values equal. -! -! Input, real ( kind = 8 ) PSI, the angle that the major axis of the ellipse -! makes with the X axis. A value of 0.0 means that the major and -! minor axes of the ellipse will be the X and Y coordinate axes. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the angular coordinates of -! the first and last points to be drawn, in radians. This angle is measured -! with respect to the (possibly tilted) major axis. -! -! Input, integer ( kind = 4 ) N, the number of points desired. N must -! be at least 1. -! -! Output, real ( kind = 8 ) P(2,N), points on the ellipse. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) r8_modp - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) pc(dim_num) - real(kind=8) psi - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - real(kind=8) theta3 -! -! THETA3 is the smallest angle, no less than THETA1, which -! coincides with THETA2. -! - theta3 = theta1 + r8_modp(theta2 - theta1, 2.0D+00 * r8_pi) - - do i = 1, n - - if (1 < n) then - theta = (real(n - i, kind=8) * theta1 & - + real(i - 1, kind=8) * theta3) & - / real(n - 1, kind=8) - else - theta = 0.5D+00 * (theta1 + theta3) - end if - - p(1, i) = pc(1) + r1 * cos(psi) * cos(theta) & - - r2 * sin(psi) * sin(theta) - - p(2, i) = pc(2) + r1 * sin(psi) * cos(theta) & - + r2 * cos(psi) * sin(theta) - - end do - - return -end -subroutine get_seed(seed) - -!*****************************************************************************80 -! -!! GET_SEED returns a seed for the random number generator. -! -! Discussion: -! -! The seed depends on the current time, and ought to be (slightly) -! different every millisecond. Once the seed is obtained, a random -! number generator should be called a few times to further process -! the seed. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 November 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) SEED, a pseudorandom seed value. -! - implicit none - - integer(kind=4) seed - real(kind=8) temp - character(len=10) time - character(len=8) today - integer(kind=4) values(8) - character(len=5) zone - - call date_and_time(today, time, zone, values) - - temp = 0.0D+00 - - temp = temp + real(values(2) - 1, kind=8) / 11.0D+00 - temp = temp + real(values(3) - 1, kind=8) / 30.0D+00 - temp = temp + real(values(5), kind=8) / 23.0D+00 - temp = temp + real(values(6), kind=8) / 59.0D+00 - temp = temp + real(values(7), kind=8) / 59.0D+00 - temp = temp + real(values(8), kind=8) / 999.0D+00 - temp = temp / 6.0D+00 -! -! Force 0 < TEMP <= 1. -! - do while (temp <= 0.0D+00) - temp = temp + 1.0D+00 - end do - - do while (1.0D+00 < temp) - temp = temp - 1.0D+00 - end do - - seed = int(real(huge(1), kind=8) * temp) -! -! Never use a seed of 0 or maximum integer. -! - if (seed == 0) then - seed = 1 - end if - - if (seed == huge(1)) then - seed = seed - 1 - end if - - return -end -subroutine get_unit(iunit) - -!*****************************************************************************80 -! -!! GET_UNIT returns a free FORTRAN unit number. -! -! Discussion: -! -! A "free" FORTRAN unit number is a value between 1 and 99 which -! is not currently associated with an I/O device. A free FORTRAN unit -! number is needed in order to open a file with the OPEN command. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 March 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) IUNIT. -! -! If IUNIT = 0, then no free FORTRAN unit could be found, although -! all 99 units were checked (except for units 5 and 6). -! -! Otherwise, IUNIT is a value between 1 and 99, representing a -! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 -! are special, and will never return those values. -! - implicit none - - integer(kind=4) i - integer(kind=4) ios - integer(kind=4) iunit - logical(kind=4) lopen - - iunit = 0 - - do i = 1, 99 - - if (i /= 5 .and. i /= 6) then - - inquire (unit=i, opened=lopen, iostat=ios) - - if (ios == 0) then - if (.not. lopen) then - iunit = i - return - end if - end if - - end if - - end do - - return -end -subroutine glob2loc_3d(cospitch, cosroll, cosyaw, sinpitch, sinroll, sinyaw, & - globas, glopts, locpts) - -!*****************************************************************************80 -! -!! GLOB2LOC_3D converts from a global to a local coordinate system in 3D. -! -! Discussion: -! -! A global coordinate system is given. -! -! A local coordinate system has been translated to the point with -! global coordinates GLOBAS, and rotated through a yaw, a pitch, and -! a roll. -! -! A point has global coordinates GLOPTS, and it is desired to know -! the point's local coordinates LOCPTS. -! -! The transformation may be written as -! -! LOC = M_ROLL * M_PITCH * M_YAW * ( GLOB - GLOBAS ) -! -! where -! -! ( 1 0 0 ) -! M_ROLL = ( 0 cos(Roll) sin(Roll) ) -! ( 0 - sin(Roll) cos(Roll) ) -! -! ( cos(Pitch) 0 - sin(Pitch) ) -! M_PITCH = ( 0 1 0 ) -! ( sin(Pitch) 0 cos(Pitch) ) -! -! ( cos(Yaw) sin(Yaw) 0 ) -! M_YAW = ( - sin(Yaw) cos(Yaw) 0 ) -! ( 0 0 1 ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) COSPITCH, COSROLL, COSYAW, the cosines of -! the pitch, roll and yaw angles. -! -! Input, real ( kind = 8 ) SINPITCH, SINROLL, SINYAW, the sines of the pitch, -! roll and yaw angles. -! -! Input, real ( kind = 8 ) GLOBAS(3), the global base vector. -! -! Input, real ( kind = 8 ) GLOPTS(3), the global coordinates -! of the point whose coordinates are to be transformed. -! -! Output, real ( kind = 8 ) LOCPTS(3), the local coordinates of the point -! whose global coordinates were given in GLOPTS. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) cospitch - real(kind=8) cosroll - real(kind=8) cosyaw - real(kind=8) globas(dim_num) - real(kind=8) glopts(dim_num) - real(kind=8) locpts(dim_num) - real(kind=8) sinpitch - real(kind=8) sinroll - real(kind=8) sinyaw - - locpts(1) = (cosyaw * cospitch) * (glopts(1) - globas(1)) & - + (sinyaw * cospitch) * (glopts(2) - globas(2)) & - - sinpitch * (glopts(3) - globas(3)) - - locpts(2) = (cosyaw * sinpitch * sinroll - sinyaw * cosroll) & - * (glopts(1) - globas(1)) & - + (sinyaw * sinpitch * sinroll + cosyaw * cosroll) & - * (glopts(2) - globas(2)) & - + cospitch * sinroll * (glopts(3) - globas(3)) - - locpts(3) = (cosyaw * sinpitch * cosroll + sinyaw * sinroll) & - * (glopts(1) - globas(1)) & - + (sinyaw * sinpitch * cosroll - cosyaw * sinroll) & - * (glopts(2) - globas(2)) & - + (cospitch * cosroll) * (glopts(3) - globas(3)) - - return -end -function halfplane_contains_point_2d(p1, p2, p) - -!*****************************************************************************80 -! -!! HALFPLANE_CONTAINS_POINT_2D reports if a half-plane contains a point in 2d. -! -! Discussion: -! -! The halfplane is assumed to be all the points "to the left" of the -! line that passes from P1 through P2. Thus, one way to -! understand where the point P is, is to compute the signed -! area of the triangle ( P1, P2, P ). -! -! If this area is -! positive, the point is strictly inside the halfplane, -! zero, the point is on the boundary of the halfplane, -! negative, the point is strictly outside the halfplane. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two distinct points -! on the line defining the half plane. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) HALFPLANE_CONTAINS_POINT_2D, is TRUE if -! the halfplane contains the point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area_signed - logical(kind=4) halfplane_contains_point_2d - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - area_signed = 0.5D+00 * & - (p1(1) * (p2(2) - p(2)) & - + p2(1) * (p(2) - p1(2)) & - + p(1) * (p1(2) - p2(2))) - - halfplane_contains_point_2d = (0.0D+00 <= area_signed) - - return -end -subroutine halfspace_imp_triangle_int_3d(a, b, c, d, t, int_num, pint) - -!*****************************************************************************80 -! -!! HALFSPACE_IMP_TRIANGLE_INT_3D: intersection ( imp halfspace, triangle ). -! -! Discussion: -! -! The implicit form of a half-space in 3D may be described as the set -! of points P on or "above" an implicit plane: -! -! 0 <= A * P(1) + B * P(2) + C * P(3) + D -! -! The triangle is specified by listing its three vertices. -! -! The intersection may be described by the number of vertices of the -! triangle that are included in the halfspace, and by the location of -! points between vertices that separate a side of the triangle into -! an included part and an unincluded part. -! -! 0 vertices, 0 separators (no intersection) -! 1 vertex, 0 separators (point intersection) -! 2 vertices, 0 separators (line intersection) -! 3 vertices, 0 separators (triangle intersection) -! -! 1 vertex, 2 separators, (intersection is a triangle) -! 2 vertices, 2 separators, (intersection is a quadrilateral). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the parameters that define the -! implicit plane, which in turn define the implicit halfspace. -! -! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points -! returned, which will always be between 0 and 4. -! -! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the INT_NUM -! intersection points. The points will lie in sequence on the triangle. -! Some points will be vertices, and some may be separators. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) dist1 - real(kind=8) dist2 - real(kind=8) dist3 - integer(kind=4) int_num - real(kind=8) pint(dim_num, 4) - real(kind=8) t(dim_num, 3) -! -! Compute the signed distances between the vertices and the plane. -! - dist1 = a * t(1, 1) + b * t(2, 1) + c * t(3, 1) + d - dist2 = a * t(1, 2) + b * t(2, 2) + c * t(3, 2) + d - dist3 = a * t(1, 3) + b * t(2, 2) + c * t(3, 3) + d -! -! Now we can find the intersections. -! - call halfspace_triangle_int_3d(dist1, dist2, dist3, t, int_num, pint) - - return -end -subroutine halfspace_normal_triangle_int_3d(pp, normal, t, int_num, pint) - -!*****************************************************************************80 -! -!! HALFSPACE_NORMAL_TRIANGLE_INT_3D: intersection ( norm halfspace, triangle ). -! -! Discussion: -! -! The normal form of a halfspace in 3D may be described as the set -! of points P on or "above" a plane described in normal form: -! -! PP is a point on the plane, -! NORMAL is the unit normal vector, pointing "out" of the -! halfspace. -! -! The triangle is specified by listing its three vertices. -! -! The intersection may be described by the number of vertices of the -! triangle that are included in the halfspace, and by the location of -! points between vertices that separate a side of the triangle into -! an included part and an unincluded part. -! -! 0 vertices, 0 separators (no intersection) -! 1 vertex, 0 separators (point intersection) -! 2 vertices, 0 separators (line intersection) -! 3 vertices, 0 separators (triangle intersection) -! -! 1 vertex, 2 separators, (intersection is a triangle) -! 2 vertices, 2 separators, (intersection is a quadrilateral). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the bounding plane -! that defines the halfspace. -! -! Input, real ( kind = 8 ) NORMAL(3), the components of the normal vector -! to the bounding plane that defines the halfspace. By convention, the -! normal vector points "outwards" from the halfspace. -! -! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points -! returned, which will always be between 0 and 4. -! -! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the INT_NUM -! intersection points. The points will lie in sequence on the triangle. -! Some points will be vertices, and some may be separators. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) d - real(kind=8) dist1 - real(kind=8) dist2 - real(kind=8) dist3 - real(kind=8) normal(dim_num) - integer(kind=4) int_num - real(kind=8) pp(dim_num) - real(kind=8) pint(dim_num, 4) - real(kind=8) t(dim_num, 3) -! -! Compute the signed distances between the vertices and the plane. -! - d = -dot_product(normal(1:dim_num), pp(1:dim_num)) -! -! Compute the signed distances between the vertices and the plane. -! - dist1 = d + dot_product(normal(1:dim_num), t(1:dim_num, 1)) - dist2 = d + dot_product(normal(1:dim_num), t(1:dim_num, 2)) - dist3 = d + dot_product(normal(1:dim_num), t(1:dim_num, 3)) -! -! Now we can find the intersections. -! - call halfspace_triangle_int_3d(dist1, dist2, dist3, t, int_num, pint) - - return -end -subroutine halfspace_triangle_int_3d(dist1, dist2, dist3, t, int_num, pint) - -!*****************************************************************************80 -! -!! HALFSPACE_TRIANGLE_INT_3D: intersection ( halfspace, triangle ) in 3D. -! -! Discussion: -! -! The triangle is specified by listing its three vertices. -! -! The halfspace is not described in the input data. Rather, the -! distances from the triangle vertices to the halfspace are given. -! -! The intersection may be described by the number of vertices of the -! triangle that are included in the halfspace, and by the location of -! points between vertices that separate a side of the triangle into -! an included part and an unincluded part. -! -! 0 vertices, 0 separators (no intersection) -! 1 vertex, 0 separators (point intersection) -! 2 vertices, 0 separators (line intersection) -! 3 vertices, 0 separators (triangle intersection) -! -! 1 vertex, 2 separators, (intersection is a triangle) -! 2 vertices, 2 separators, (intersection is a quadrilateral). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DIST1, DIST2, DIST3, the distances from each of -! the three vertices of the triangle to the halfspace. The distance is -! zero if a vertex lies within the halfspace, or on the plane that -! defines the boundary of the halfspace. Otherwise, it is the -! distance from that vertex to the bounding plane. -! -! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points -! returned, which will always be between 0 and 4. -! -! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the INT_NUM -! intersection points. The points will lie in sequence on the triangle. -! Some points will be vertices, and some may be separators. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dist1 - real(kind=8) dist2 - real(kind=8) dist3 - integer(kind=4) int_num - real(kind=8) pint(dim_num, 4) - real(kind=8) t(dim_num, 3) -! -! Walk around the triangle, looking for vertices that are included, -! and points of separation. -! - int_num = 0 - - if (dist1 <= 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 1) - - end if - - if (dist1 * dist2 < 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = & - (dist1 * t(1:dim_num, 2) - dist2 * t(1:dim_num, 1)) & - / (dist1 - dist2) - - end if - - if (dist2 <= 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 2) - - end if - - if (dist2 * dist3 < 0.0D+00) then - - int_num = int_num + 1 - - pint(1:dim_num, int_num) = & - (dist2 * t(1:dim_num, 3) - dist3 * t(1:dim_num, 2)) & - / (dist2 - dist3) - - end if - - if (dist3 <= 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 3) - - end if - - if (dist3 * dist1 < 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = & - (dist3 * t(1:dim_num, 1) - dist1 * t(1:dim_num, 3)) & - / (dist3 - dist1) - - end if - - return -end -function haversine(a) - -!*****************************************************************************80 -! -!! HAVERSINE computes the haversine of an angle. -! -! Discussion: -! -! haversine(A) = ( 1 - cos ( A ) ) / 2 -! -! The haversine is useful in spherical trigonometry. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 July 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, the angle. -! -! Output, real ( kind = 8 ) HAVERSINE, the haversine of the angle. -! - implicit none - - real(kind=8) a - real(kind=8) haversine - - haversine = (1.0D+00 - cos(a)) / 2.0D+00 - - return -end -subroutine helix_shape_3d(a, n, r, theta1, theta2, p) - -!*****************************************************************************80 -! -!! HELIX_SHAPE_3D computes points on a helix in 3D. -! -! Discussion: -! -! The user specifies the parameters A and R, the first and last -! THETA values, and the number of equally spaced THETA values -! at which point values are to be computed. -! -! X = R * COS ( THETA ) -! Y = R * SIN ( THETA ) -! Z = A * THETA -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, the rate at which Z advances with THETA. -! -! Input, integer ( kind = 4 ) N, the number of points to compute on -! the helix. -! -! Input, real ( kind = 8 ) R, the radius of the helix. -! -! Input, real ( kind = 8 ) THETA1, THETA2, the first and last THETA values at -! which to compute points on the helix. THETA is measured in -! radians. -! -! Output, real ( kind = 8 ) P(3,N), the coordinates of points on the helix. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) r - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - - do i = 1, n - - if (n == 1) then - theta = 0.5D+00 * (theta1 + theta2) - else - theta = (real(n - i, kind=8) * theta1 & - + real(i - 1, kind=8) * theta2) & - / real(n - 1, kind=8) - end if - - p(1, i) = r * cos(theta) - p(2, i) = r * sin(theta) - p(3, i) = a * theta - - end do - - return -end -function hexagon_area_2d(r) - -!*****************************************************************************80 -! -!! HEXAGON_AREA_2D returns the area of a regular hexagon in 2D. -! -! Discussion: -! -! The radius of a regular hexagon is the distance from the center -! of the hexagon to any vertex. This happens also to equal the -! length of any side. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the hexagon. -! -! Output, real ( kind = 8 ) HEXAGON_AREA_2D, the area of the hexagon. -! - implicit none - - real(kind=8) hexagon_area_2d - real(kind=8) hexagon01_area_2d - real(kind=8) r - - hexagon_area_2d = r * r * hexagon01_area_2d() - - return -end -function hexagon_contains_point_2d(v, p) - -!*****************************************************************************80 -! -!! HEXAGON_CONTAINS_POINT_2D finds if a point is inside a hexagon in 2D. -! -! Discussion: -! -! This test is only valid if the hexagon is convex. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 June 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V(2,6), the vertices, in counter clockwise order. -! -! Input, real ( kind = 8 ) P(2), the point to be tested. -! -! Output, logical ( kind = 4 ) HEXAGON_CONTAINS_POINT_2D, is TRUE -! if X is in the hexagon. -! - implicit none - - integer(kind=4), parameter :: n = 6 - integer(kind=4), parameter :: dim_num = 2 - - logical(kind=4) hexagon_contains_point_2d - integer(kind=4) i - integer(kind=4) j - real(kind=8) p(dim_num) - real(kind=8) v(dim_num, n) -! -! A point is inside a convex hexagon if and only if it is "inside" -! each of the 6 halfplanes defined by lines through consecutive -! vertices. -! - do i = 1, n - - j = mod(i, n) + 1 - - if (v(1, i) * (v(2, j) - p(2)) & - + v(1, j) * (p(2) - v(2, i)) & - + p(1) * (v(2, i) - v(2, j)) < 0.0D+00) then - - hexagon_contains_point_2d = .false. - return - - end if - - end do - - hexagon_contains_point_2d = .true. - - return -end -subroutine hexagon_shape_2d(angle_deg, p) - -!*****************************************************************************80 -! -!! HEXAGON_SHAPE_2D returns points on the unit regular hexagon in 2D. -! -! Diagram: -! -! 120_____60 -! / \ -! 180/ \0 -! \ / -! \_____/ -! 240 300 -! -! Discussion: -! -! The unit regular hexagon has radius 1. The radius is the distance from -! the center to any vertex, and it is also the length of any side. -! An example of a unit hexagon is the convex hull of the points: -! -! ( 1, 0 ), -! ( 0.5, sqrt (3)/2 ), -! ( - 0.5, sqrt (3)/2 ), -! ( - 1, 0 ), -! ( - 0.5, - sqrt (3)/2 ), -! ( 0.5, - sqrt (3)/2 ). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 July 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) ANGLE_DEG, the angle, in degrees, of the point. -! -! Output, real ( kind = 8 ) P(2), the coordinates of the point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle_deg - real(kind=8) angle2 - real(kind=8) p(dim_num) - real(kind=8) r8_cotd - real(kind=8) r8_modp - real(kind=8) r8_tand -! -! Ensure that 0 <= ANGLE < 360. -! - angle2 = r8_modp(angle_deg, 360.0D+00) -! -! y = - sqrt(3) * x + sqrt(3) -! - if (0.0D+00 <= angle2 .and. angle2 <= 60.0D+00) then - - p(1) = sqrt(3.0D+00) / (r8_tand(angle2) + sqrt(3.0D+00)) - p(2) = r8_tand(angle2) * p(1) -! -! y = sqrt(3) / 2 -! - else if (angle2 <= 120.0D+00) then - - p(2) = sqrt(3.0D+00) / 2.0D+00 - p(1) = r8_cotd(angle2) * p(2) -! -! y = sqrt(3) * x + sqrt(3) -! - else if (angle2 <= 180.0D+00) then - - p(1) = sqrt(3.0D+00) / (r8_tand(angle2) - sqrt(3.0D+00)) - p(2) = r8_tand(angle2) * p(1) -! -! y = - sqrt(3) * x - sqrt(3) -! - else if (angle2 <= 240.0D+00) then - - p(1) = -sqrt(3.0D+00) / (r8_tand(angle2) + sqrt(3.0D+00)) - p(2) = r8_tand(angle2) * p(1) -! -! y = - sqrt(3) / 2 -! - else if (angle2 <= 300.0D+00) then - - p(2) = -sqrt(3.0D+00) / 2.0D+00 - p(1) = r8_cotd(angle2) * p(2) -! -! y = sqrt(3) * x - sqrt(3) -! - else if (angle2 <= 360.0D+00) then - - p(1) = -sqrt(3.0D+00) / (r8_tand(angle2) - sqrt(3.0D+00)) - p(2) = r8_tand(angle2) * p(1) - - end if - - return -end -subroutine hexagon_vertices_2d(p) - -!*****************************************************************************80 -! -!! HEXAGON_VERTICES_2D returns the vertices of the unit hexagon in 2D. -! -! Discussion: -! -! The unit hexagon has maximum radius 1, and is the hull of the points -! -! ( 1, 0 ), -! ( 0.5, sqrt (3)/2 ), -! ( - 0.5, sqrt (3)/2 ), -! ( - 1, 0 ), -! ( - 0.5, - sqrt (3)/2 ), -! ( 0.5, - sqrt (3)/2 ). -! -! Diagram: -! -! 120_____60 -! / \ -! 180/ \0 -! \ / -! \_____/ -! 240 300 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) P(2,6), the coordinates of the vertices. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8), parameter :: a = 0.8660254037844386D+00 - real(kind=8) p(dim_num, 6) - - p(1:2, 1:6) = reshape((/ & - 1.0D+00, 0.0D+00, & - 0.5D+00, a, & - -0.5D+00, a, & - -1.0D+00, 0.0D+00, & - -0.5D+00, -a, & - 0.5D+00, -a/), (/dim_num, 6/)) - - return -end -function hexagon01_area_2d() - -!*****************************************************************************80 -! -!! HEXAGON01_AREA_2D returns the area of a unit regular hexagon in 2D. -! -! Discussion: -! -! A "unit" regular hexagon has both a "radius" of 1 (distance -! from the center to any vertex), and a side length of 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) HEXAGON01_AREA_2D, the area of the hexagon. -! - implicit none - - real(kind=8) hexagon01_area_2d - - hexagon01_area_2d = 3.0D+00 * sqrt(3.0D+00) / 2.0D+00 - - return -end -function hyperball01_volume(m) - -!*****************************************************************************80 -! -!! HYPERBALL01_VOLUME returns the volume of the unit hyperball in M dimensions. -! -! Discussion: -! -! M Volume -! -! 1 2 -! 2 1 * PI -! 3 ( 4 / 3) * PI -! 4 ( 1 / 2) * PI^2 -! 5 ( 8 / 15) * PI^2 -! 6 ( 1 / 6) * PI^3 -! 7 (16 / 105) * PI^3 -! 8 ( 1 / 24) * PI^4 -! 9 (32 / 945) * PI^4 -! 10 ( 1 / 120) * PI^5 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the spatial dimension. -! -! Output, real ( kind = 8 ) HYPERBALL01_VOLUME, the volume of the unit ball. -! - implicit none - - real(kind=8) hyperball01_volume - integer(kind=4) i - integer(kind=4) m - integer(kind=4) m_half - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) volume - - if (mod(m, 2) == 0) then - m_half = (m / 2) - volume = r8_pi**m_half - do i = 1, m_half - volume = volume / real(i, kind=8) - end do - else - m_half = ((m - 1) / 2) - volume = r8_pi**m_half * 2.0D+00**m - do i = m_half + 1, 2 * m_half + 1 - volume = volume / real(i, kind=8) - end do - end if - - hyperball01_volume = volume - - return -end -function i4_dedekind_factor(p, q) - -!*****************************************************************************80 -! -!! I4_DEDEKIND_FACTOR computes a function needed for a Dedekind sum. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 July 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Hans Rademacher, Emil Grosswald, -! Dedekind Sums, -! Mathematics Association of America, 1972, -! LC: QA241.R2. -! -! Parameters: -! -! Input, integer ( kind = 4 ) P, Q, two positive integers. -! -! Input, real ( kind = 8 ) I4_DEDEKIND_FACTOR, the Dedekind factor of P / Q. -! - implicit none - - real(kind=8) i4_dedekind_factor - integer(kind=4) p - integer(kind=4) q - - if (mod(p, q) == 0) then - i4_dedekind_factor = 0.0D+00 - else - i4_dedekind_factor = real(p, kind=8) / real(q, kind=8) & - - real((p / q), kind=8) - 0.5D+00 - end if - - return -end -subroutine i4_dedekind_sum(p, q, s) - -!*****************************************************************************80 -! -!! I4_DEDEKIND_SUM computes the Dedekind sum of two I4's. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 July 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Hans Rademacher, Emil Grosswald, -! Dedekind Sums, -! Mathematics Association of America, 1972, -! LC: QA241.R2. -! -! Parameters: -! -! Input, integer ( kind = 4 ) P, Q, two positive integers. -! -! Output, real ( kind = 8 ) S, the Dedekind sum of P and Q. -! - implicit none - - integer(kind=4) i - real(kind=8) i4_dedekind_factor - integer(kind=4) p - integer(kind=4) q - real(kind=8) s - - s = 0.0D+00 - - do i = 1, q - s = s + i4_dedekind_factor(i, q) * i4_dedekind_factor(p * i, q) - end do - - return -end -function i4_factorial2(n) - -!*****************************************************************************80 -! -!! I4_FACTORIAL2 computes the double factorial function. -! -! Discussion: -! -! FACTORIAL2( N ) = Product ( N * (N-2) * (N-4) * ... * 2 ) (N even) -! = Product ( N * (N-2) * (N-4) * ... * 1 ) (N odd) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 December 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the argument of the double factorial -! function. If N is less than 1, I4_FACTORIAL2 is returned as 1. -! -! Output, integer ( kind = 4 ) I4_FACTORIAL2, the value of N!!. -! - implicit none - - integer(kind=4) i4_factorial2 - integer(kind=4) n - integer(kind=4) n_copy - - if (n < 1) then - i4_factorial2 = 1 - return - end if - - n_copy = n - i4_factorial2 = 1 - - do while (1 < n_copy) - i4_factorial2 = i4_factorial2 * n_copy - n_copy = n_copy - 2 - end do - - return -end -function i4_gcd(i, j) - -!*****************************************************************************80 -! -!! I4_GCD finds the greatest common divisor of two I4's. -! -! Discussion: -! -! Note that only the absolute values of I and J are -! considered, so that the result is always nonnegative. -! -! If I or J is 0, I4_GCD is returned as max ( 1, abs ( I ), abs ( J ) ). -! -! If I and J have no common factor, I4_GCD is returned as 1. -! -! Otherwise, using the Euclidean algorithm, I4_GCD is the -! greatest common divisor of I and J. -! -! An I4 is an integer ( kind = 4 ) value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 March 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) I, J, two numbers whose GCD is desired. -! -! Output, integer ( kind = 4 ) I4_GCD, the greatest common divisor -! of I and J. -! - implicit none - - integer(kind=4) i - integer(kind=4) i4_gcd - integer(kind=4) j - 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 - - return -end -function i4_huge() - -!*****************************************************************************80 -! -!! I4_HUGE returns a "huge" I4. -! -! Discussion: -! -! On an IEEE 32 bit machine, I4_HUGE should be 2**31 - 1, and its -! bit pattern should be -! -! 01111111111111111111111111111111 -! -! In this case, its numerical value is 2147483647. -! -! Using the Dec/Compaq/HP Alpha FORTRAN compiler FORT, I could -! use I4_HUGE() and HUGE interchangeably. -! -! However, when using the G95, the values returned by HUGE were -! not equal to 2147483647, apparently, and were causing severe -! and obscure errors in my random number generator, which needs to -! add I4_HUGE to the seed whenever the seed is negative. So I -! am backing away from invoking HUGE, whereas I4_HUGE is under -! my control. -! -! Explanation: because under G95 the default integer type is 64 bits! -! So HUGE ( 1 ) = a very very huge integer indeed, whereas -! I4_HUGE ( ) = the same old 32 bit big value. -! -! An I4 is an integer ( kind = 4 ) value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 January 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) I4_HUGE, a "huge" I4. -! - implicit none - - integer(kind=4) i4_huge - - i4_huge = 2147483647 - - return -end -function i4_lcm(i, j) - -!*****************************************************************************80 -! -!! I4_LCM computes the least common multiple of two I4's. -! -! Discussion: -! -! The least common multiple may be defined as -! -! LCM(I,J) = ABS( I * J ) / GCD(I,J) -! -! where GCD(I,J) is the greatest common divisor of I and J. -! -! An I4 is an integer ( kind = 4 ) value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 March 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) I, J, the integers whose I4_LCM is desired. -! -! Output, integer ( kind = 4 ) I4_LCM, the least common multiple of I and J. -! I4_LCM is never negative. I4_LCM is 0 if either I or J is zero. -! - implicit none - - integer(kind=4) i - integer(kind=4) i4_gcd - integer(kind=4) j - integer(kind=4) i4_lcm - - i4_lcm = abs(i * (j / i4_gcd(i, j))) - - return -end -function i4_modp(i, j) - -!*****************************************************************************80 -! -!! I4_MODP returns the nonnegative remainder of integer division. -! -! Discussion: -! -! If -! NREM = I4_MODP ( I, J ) -! NMULT = ( I - NREM ) / J -! then -! I = J * NMULT + NREM -! where NREM is always nonnegative. -! -! The MOD function computes a result with the same sign as the -! quantity being divided. Thus, suppose you had an angle A, -! and you wanted to ensure that it was between 0 and 360. -! Then mod(A,360) would do, if A was positive, but if A -! was negative, your result would be between -360 and 0. -! -! On the other hand, I4_MODP(A,360) is between 0 and 360, always. -! -! Example: -! -! I J MOD I4_MODP Factorization -! -! 107 50 7 7 107 = 2 * 50 + 7 -! 107 -50 7 7 107 = -2 * -50 + 7 -! -107 50 -7 43 -107 = -3 * 50 + 43 -! -107 -50 -7 43 -107 = 3 * -50 + 43 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 March 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) I, the number to be divided. -! -! Input, integer ( kind = 4 ) J, the number that divides I. -! -! Output, integer ( kind = 4 ) I4_MODP, the nonnegative remainder when I is -! divided by J. -! - implicit none - - integer(kind=4) i - integer(kind=4) i4_modp - integer(kind=4) j - - if (j == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4_MODP - Fatal error!' - write (*, '(a,i8)') ' I4_MODP ( I, J ) called with J = ', j - stop 1 - end if - - i4_modp = mod(i, j) - - if (i4_modp < 0) then - i4_modp = i4_modp + abs(j) - end if - - return -end -subroutine i4_swap(i, j) - -!*****************************************************************************80 -! -!! I4_SWAP switches two I4's. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 November 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) I, J. On output, the values of I and -! J have been interchanged. -! - implicit none - - integer(kind=4) i - integer(kind=4) j - integer(kind=4) k - - k = i - i = j - j = k - - return -end -function i4_uniform(a, b, seed) - -!*****************************************************************************80 -! -!! I4_UNIFORM returns a scaled pseudorandom I4. -! -! Discussion: -! -! An I4 is an integer ( kind = 4 ) value. -! -! The pseudorandom number will be scaled to be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, -! which should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 4 ) I4_UNIFORM, a number between -! A and B. -! - implicit none - - integer(kind=4) a - integer(kind=4) b - integer(kind=4) i4_uniform - integer(kind=4) k - real(kind=4) r - integer(kind=4) seed - integer(kind=4) value - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4_UNIFORM - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if - - r = real(seed, kind=4) * 4.656612875E-10 -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = (1.0E+00 - r) * (real(min(a, b), kind=4) - 0.5E+00) & - + r * (real(max(a, b), kind=4) + 0.5E+00) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint(r, kind=4) - - value = max(value, min(a, b)) - value = min(value, max(a, b)) - - i4_uniform = value - - return -end -function i4_wrap(ival, ilo, ihi) - -!*****************************************************************************80 -! -!! I4_WRAP forces an I4 to lie between given limits by wrapping. -! -! Example: -! -! ILO = 4, IHI = 8 -! -! I I4_WRAP -! -! -2 8 -! -1 4 -! 0 5 -! 1 6 -! 2 7 -! 3 8 -! 4 4 -! 5 5 -! 6 6 -! 7 7 -! 8 8 -! 9 4 -! 10 5 -! 11 6 -! 12 7 -! 13 8 -! 14 4 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 August 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) IVAL, an integer value. -! -! Input, integer ( kind = 4 ) ILO, IHI, the desired bounds for the integer -! value. -! -! Output, integer ( kind = 4 ) I4_WRAP, a "wrapped" version of IVAL. -! - implicit none - - integer(kind=4) i4_modp - integer(kind=4) i4_wrap - integer(kind=4) ihi - integer(kind=4) ilo - integer(kind=4) ival - integer(kind=4) jhi - integer(kind=4) jlo - integer(kind=4) wide - - jlo = min(ilo, ihi) - jhi = max(ilo, ihi) - - wide = jhi - jlo + 1 - - if (wide == 1) then - i4_wrap = jlo - else - i4_wrap = jlo + i4_modp(ival - jlo, wide) - end if - - return -end -subroutine i4col_compare(m, n, a, i, j, isgn) - -!*****************************************************************************80 -! -!! I4COL_COMPARE compares columns I and J of an I4COL. -! -! Example: -! -! Input: -! -! M = 3, N = 4, I = 2, J = 4 -! -! A = ( -! 1 2 3 4 -! 5 6 7 8 -! 9 10 11 12 ) -! -! Output: -! -! ISGN = -1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 June 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, integer ( kind = 4 ) A(M,N), an array of N columns of vectors -! of length M. -! -! Input, integer ( kind = 4 ) I, J, the columns to be compared. -! I and J must be between 1 and N. -! -! Output, integer ( kind = 4 ) ISGN, the results of the comparison: -! -1, column I < column J, -! 0, column I = column J, -! +1, column J < column I. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) i - integer(kind=4) isgn - integer(kind=4) j - integer(kind=4) k -! -! Check. -! - if (i < 1 .or. n < i) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4COL_COMPARE - Fatal error!' - write (*, '(a)') ' Column index I is out of bounds.' - stop 1 - end if - - if (j < 1 .or. n < j) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4COL_COMPARE - Fatal error!' - write (*, '(a)') ' Column index J is out of bounds.' - stop 1 - end if - - isgn = 0 - - if (i == j) then - return - end if - - k = 1 - - do while (k <= m) - - if (a(k, i) < a(k, j)) then - isgn = -1 - return - else if (a(k, j) < a(k, i)) then - isgn = +1 - return - end if - - k = k + 1 - - end do - - return -end -subroutine i4col_find_item(m, n, a, item, row, col) - -!*****************************************************************************80 -! -!! I4COL_FIND_ITEM searches a table by columns for a given scalar value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns in -! the table. -! -! Input, integer ( kind = 4 ) A(M,N), an array of N columns of vectors -! of length M. -! -! Input, integer ( kind = 4 ) ITEM, the value to search for. -! -! Output, integer ( kind = 4 ) ROW, COL, the row and column indices -! of the first occurrence of the value ITEM. The search -! is conducted by columns. If the item is not found, then -! ROW = COL = -1. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) col - integer(kind=4) i - integer(kind=4) item - integer(kind=4) j - integer(kind=4) row - - do j = 1, n - do i = 1, m - if (a(i, j) == item) then - row = i - col = j - return - end if - end do - end do - - row = -1 - col = -1 - - return -end -subroutine i4col_find_pair_wrap(m, n, a, item1, item2, row, col) - -!*****************************************************************************80 -! -!! I4COL_FIND_PAIR_WRAP searches a table by columns for a pair of items. -! -! Discussion: -! -! The items (ITEM1, ITEM2) must occur consecutively. -! However, wrapping is allowed, that is, if ITEM1 occurs -! in the last row, and ITEM2 "follows" it in the first row -! of the same column, a match is declared. -! -! If the pair of items is not found, then ROW = COL = -1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 23 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns in -! the array. -! -! Input, integer ( kind = 4 ) A(M,N), the array to search. -! -! Input, integer ( kind = 4 ) ITEM1, ITEM2, the values to search for. -! -! Output, integer ( kind = 4 ) ROW, COL, the row and column indices -! of the first occurrence of the value ITEM1 followed immediately -! by ITEM2. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) col - integer(kind=4) i - integer(kind=4) i2 - integer(kind=4) item1 - integer(kind=4) item2 - integer(kind=4) j - integer(kind=4) row - - do j = 1, n - do i = 1, m - - if (a(i, j) == item1) then - - i2 = i + 1 - - if (m < i2) then - i2 = 1 - end if - - if (a(i2, j) == item2) then - row = i - col = j - return - end if - - end if - - end do - end do - - row = -1 - col = -1 - - return -end -subroutine i4col_sort_a(m, n, a) - -!*****************************************************************************80 -! -!! I4COL_SORT_A ascending sorts an integer array of columns. -! -! Discussion: -! -! In lexicographic order, the statement "X < Y", applied to two real -! vectors X and Y of length M, means that there is some index I, with -! 1 <= I <= M, with the property that -! -! X(J) = Y(J) for J < I, -! and -! X(I) < Y(I). -! -! In other words, the first time they differ, X is smaller. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 September 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the number of rows of A, and the length of -! a vector of data. -! -! Input, integer ( kind = 4 ) N, the number of columns of A. -! -! Input/output, integer ( kind = 4 ) A(M,N). -! On input, the array of N columns of M-vectors. -! On output, the columns of A have been sorted in ascending -! lexicographic order. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) i - integer(kind=4) indx - integer(kind=4) isgn - integer(kind=4) j - - if (m <= 0) then - return - end if - - if (n <= 1) then - return - end if -! -! Initialize. -! - i = 0 - indx = 0 - isgn = 0 - j = 0 -! -! Call the external heap sorter. -! - do - - call sort_heap_external(n, indx, i, j, isgn) -! -! Interchange the I and J objects. -! - if (0 < indx) then - - call i4col_swap(m, n, a, i, j) -! -! Compare the I and J objects. -! - else if (indx < 0) then - - call i4col_compare(m, n, a, i, j, isgn) - - else if (indx == 0) then - - exit - - end if - - end do - - return -end -subroutine i4col_sorted_unique_count(m, n, a, unique_num) - -!*****************************************************************************80 -! -!! I4COL_SORTED_UNIQUE_COUNT counts unique elements in an I4COL. -! -! Discussion: -! -! The columns of the array may be ascending or descending sorted. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, integer ( kind = 4 ) A(M,N), a sorted array, containing -! N columns of data. -! -! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) j1 - integer(kind=4) j2 - integer(kind=4) unique_num - - if (n <= 0) then - unique_num = 0 - return - end if - - unique_num = 1 - j1 = 1 - - do j2 = 2, n - - if (any(a(1:m, j1) /= a(1:m, j2))) then - unique_num = unique_num + 1 - j1 = j2 - end if - - end do - - return -end -subroutine i4col_swap(m, n, a, i, j) - -!*****************************************************************************80 -! -!! I4COL_SWAP swaps columns I and J of a integer array of column data. -! -! Example: -! -! Input: -! -! M = 3, N = 4, I = 2, J = 4 -! -! A = ( -! 1 2 3 4 -! 5 6 7 8 -! 9 10 11 12 ) -! -! Output: -! -! A = ( -! 1 4 3 2 -! 5 8 7 6 -! 9 12 11 10 ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns in -! the array. -! -! Input/output, integer ( kind = 4 ) A(M,N), an array of N columns of -! length M. -! -! Input, integer ( kind = 4 ) I, J, the columns to be swapped. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) col(m) - integer(kind=4) i - integer(kind=4) j - - if (i < 1 .or. n < i .or. j < 1 .or. n < j) then - - write (*, '(a)') ' ' - write (*, '(a)') 'I4COL_SWAP - Fatal error!' - write (*, '(a)') ' I or J is out of bounds.' - write (*, '(a,i8)') ' I = ', i - write (*, '(a,i8)') ' J = ', j - write (*, '(a,i8)') ' N = ', n - stop 1 - - end if - - if (i == j) then - return - end if - - col(1:m) = a(1:m, i) - a(1:m, i) = a(1:m, j) - a(1:m, j) = col(1:m) - - return -end -subroutine i4mat_print(m, n, a, title) - -!*****************************************************************************80 -! -!! I4MAT_PRINT prints an integer matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 June 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the number of rows in A. -! -! Input, integer ( kind = 4 ) N, the number of columns in A. -! -! Input, integer ( kind = 4 ) A(M,N), the matrix to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) ihi - integer(kind=4) ilo - integer(kind=4) jhi - integer(kind=4) jlo - character(len=*) title - - ilo = 1 - ihi = m - jlo = 1 - jhi = n - - call i4mat_print_some(m, n, a, ilo, jlo, ihi, jhi, title) - - return -end -subroutine i4mat_print_some(m, n, a, ilo, jlo, ihi, jhi, title) - -!*****************************************************************************80 -! -!! I4MAT_PRINT_SOME prints some of an I4MAT. -! -! Discussion: -! -! An I4MAT is a rectangular array of I4 values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 September 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. -! -! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. -! -! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4), parameter :: incx = 10 - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - character(len=8) ctemp(incx) - integer(kind=4) i - integer(kind=4) i2hi - integer(kind=4) i2lo - integer(kind=4) ihi - integer(kind=4) ilo - integer(kind=4) inc - integer(kind=4) j - integer(kind=4) j2 - integer(kind=4) j2hi - integer(kind=4) j2lo - integer(kind=4) jhi - integer(kind=4) jlo - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - - do j2lo = max(jlo, 1), min(jhi, n), incx - - j2hi = j2lo + incx - 1 - j2hi = min(j2hi, n) - j2hi = min(j2hi, jhi) - - inc = j2hi + 1 - j2lo - - write (*, '(a)') ' ' - - do j = j2lo, j2hi - j2 = j + 1 - j2lo - write (ctemp(j2), '(i8)') j - end do - - write (*, '('' Col '',10a8)') ctemp(1:inc) - write (*, '(a)') ' Row' - write (*, '(a)') ' ' - - i2lo = max(ilo, 1) - i2hi = min(ihi, m) - - do i = i2lo, i2hi - - do j2 = 1, inc - - j = j2lo - 1 + j2 - - write (ctemp(j2), '(i8)') a(i, j) - - end do - - write (*, '(i5,a,10a8)') i, ':', (ctemp(j), j=1, inc) - - end do - - end do - - return -end -subroutine i4mat_transpose_print(m, n, a, title) - -!*****************************************************************************80 -! -!! I4MAT_TRANSPOSE_PRINT prints an I4MAT, transposed. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - character(len=*) title - - call i4mat_transpose_print_some(m, n, a, 1, 1, m, n, title) - - return -end -subroutine i4mat_transpose_print_some(m, n, a, ilo, jlo, ihi, jhi, title) - -!*****************************************************************************80 -! -!! I4MAT_TRANSPOSE_PRINT_SOME prints some of the transpose of an I4MAT. -! -! Discussion: -! -! An I4MAT is a rectangular array of I4 values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 September 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. -! -! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. -! -! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4), parameter :: incx = 10 - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - character(len=8) ctemp(incx) - integer(kind=4) i - integer(kind=4) i2 - integer(kind=4) i2hi - integer(kind=4) i2lo - integer(kind=4) ihi - integer(kind=4) ilo - integer(kind=4) inc - integer(kind=4) j - integer(kind=4) j2hi - integer(kind=4) j2lo - integer(kind=4) jhi - integer(kind=4) jlo - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - - do i2lo = max(ilo, 1), min(ihi, m), incx - - i2hi = i2lo + incx - 1 - i2hi = min(i2hi, m) - i2hi = min(i2hi, ihi) - - inc = i2hi + 1 - i2lo - - write (*, '(a)') ' ' - - do i = i2lo, i2hi - i2 = i + 1 - i2lo - write (ctemp(i2), '(i8)') i - end do - - write (*, '('' Row '',10a8)') ctemp(1:inc) - write (*, '(a)') ' Col' - write (*, '(a)') ' ' - - j2lo = max(jlo, 1) - j2hi = min(jhi, n) - - do j = j2lo, j2hi - - do i2 = 1, inc - - i = i2lo - 1 + i2 - - write (ctemp(i2), '(i8)') a(i, j) - - end do - - write (*, '(i5,a,10a8)') j, ':', (ctemp(i), i=1, inc) - - end do - - end do - - return -end -subroutine i4row_compare(m, n, a, i, j, isgn) - -!*****************************************************************************80 -! -!! I4ROW_COMPARE compares two rows of a integer array. -! -! Example: -! -! Input: -! -! M = 3, N = 4, I = 2, J = 3 -! -! A = ( -! 1 2 3 4 -! 5 6 7 8 -! 9 10 11 12 ) -! -! Output: -! -! ISGN = -1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 July 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, integer ( kind = 4 ) A(M,N), an array of M rows of vectors of -! length N. -! -! Input, integer ( kind = 4 ) I, J, the rows to be compared. -! I and J must be between 1 and M. -! -! Output, integer ( kind = 4 ) ISGN, the results of the comparison: -! -1, row I < row J, -! 0, row I = row J, -! +1, row J < row I. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) i - integer(kind=4) isgn - integer(kind=4) j - integer(kind=4) k -! -! Check that I and J are legal. -! - if (i < 1) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' - write (*, '(a)') ' Row index I is less than 1.' - write (*, '(a,i8)') ' I = ', i - stop 1 - else if (m < i) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' - write (*, '(a)') ' Row index I is out of bounds.' - write (*, '(a,i8)') ' I = ', i - write (*, '(a,i8)') ' Maximum legal value is M = ', m - stop 1 - end if - - if (j < 1) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' - write (*, '(a)') ' Row index J is less than 1.' - write (*, '(a,i8)') ' J = ', j - stop 1 - else if (m < j) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' - write (*, '(a)') ' Row index J is out of bounds.' - write (*, '(a,i8)') ' J = ', j - write (*, '(a,i8)') ' Maximum legal value is M = ', m - stop 1 - end if - - isgn = 0 - - if (i == j) then - return - end if - - k = 1 - - do while (k <= n) - - if (a(i, k) < a(j, k)) then - isgn = -1 - return - else if (a(j, k) < a(i, k)) then - isgn = +1 - return - end if - - k = k + 1 - - end do - - return -end -subroutine i4row_sort_a(m, n, a) - -!*****************************************************************************80 -! -!! I4ROW_SORT_A ascending sorts the rows of an integer array. -! -! Discussion: -! -! In lexicographic order, the statement "X < Y", applied to two -! vectors X and Y of length M, means that there is some index I, with -! 1 <= I <= M, with the property that -! -! X(J) = Y(J) for J < I, -! and -! X(I) < Y(I). -! -! In other words, X is less than Y if, at the first index where they -! differ, the X value is less than the Y value. -! -! Example: -! -! Input: -! -! M = 5, N = 3 -! -! A = -! 3 2 1 -! 2 4 3 -! 3 1 8 -! 2 4 2 -! 1 9 9 -! -! Output: -! -! A = -! 1 9 9 -! 2 4 2 -! 2 4 3 -! 3 1 8 -! 3 2 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 July 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the number of rows of A. -! -! Input, integer ( kind = 4 ) N, the number of columns of A. -! -! Input/output, integer ( kind = 4 ) A(M,N). -! On input, the array of M rows of N-vectors. -! On output, the rows of A have been sorted in ascending -! lexicographic order. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) i - integer(kind=4) indx - integer(kind=4) isgn - integer(kind=4) j -! -! Initialize. -! - i = 0 - indx = 0 - isgn = 0 - j = 0 -! -! Call the external heap sorter. -! - do - - call sort_heap_external(m, indx, i, j, isgn) -! -! Interchange the I and J objects. -! - if (0 < indx) then - - call i4row_swap(m, n, a, i, j) -! -! Compare the I and J objects. -! - else if (indx < 0) then - - call i4row_compare(m, n, a, i, j, isgn) - - else if (indx == 0) then - - exit - - end if - - end do - - return -end -subroutine i4row_sorted_unique_count(m, n, a, unique_num) - -!*****************************************************************************80 -! -!! I4ROW_SORTED_UNIQUE_COUNT counts unique elements in an IROW array. -! -! Discussion: -! -! The rows of the array may be ascending or descending sorted. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, integer ( kind = 4 ) A(M,N), a sorted array, containing -! M rows of data. -! -! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique rows. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) i1 - integer(kind=4) i2 - integer(kind=4) unique_num - - if (n <= 0) then - unique_num = 0 - return - end if - - unique_num = 1 - i1 = 1 - - do i2 = 2, m - - if (any(a(i1, 1:n) /= a(i2, 1:n))) then - unique_num = unique_num + 1 - i1 = i2 - end if - - end do - - return -end -subroutine i4row_swap(m, n, a, irow1, irow2) - -!*****************************************************************************80 -! -!! I4ROW_SWAP swaps two rows of an integer array. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input/output, integer ( kind = 4 ) A(M,N), an array of data. -! -! Input, integer ( kind = 4 ) IROW1, IROW2, the two rows to swap. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) a(m, n) - integer(kind=4) irow1 - integer(kind=4) irow2 - integer(kind=4) row(n) -! -! Check. -! - if (irow1 < 1 .or. m < irow1) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4ROW_SWAP - Fatal error!' - write (*, '(a)') ' IROW1 is out of range.' - stop 1 - end if - - if (irow2 < 1 .or. m < irow2) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4ROW_SWAP - Fatal error!' - write (*, '(a)') ' IROW2 is out of range.' - stop 1 - end if - - if (irow1 == irow2) then - return - end if - - row(1:n) = a(irow1, 1:n) - a(irow1, 1:n) = a(irow2, 1:n) - a(irow2, 1:n) = row(1:n) - - return -end -subroutine i4vec_heap_d(n, a) - -!*****************************************************************************80 -! -!! I4VEC_HEAP_D reorders an array of integers into a descending heap. -! -! Discussion: -! -! A descending heap is an array A with the property that, for every index J, -! A(2*J) <= A(J) and A(2*J+1) <= A(J), (as long as the indices -! 2*J and 2*J+1 are legal). -! -! Diagram: -! -! A(1) -! / \ -! A(2) A(3) -! / \ / \ -! A(4) A(5) A(6) A(7) -! / \ / \ -! A(8) A(9) A(10) A(11) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Albert Nijenhuis, Herbert Wilf, -! Combinatorial Algorithms, -! Academic Press, 1978, second edition, -! ISBN 0-12-519260-6. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the size of the input array. -! -! Input/output, integer ( kind = 4 ) A(N). -! On input, an unsorted array. -! On output, the array has been reordered into a heap. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a(n) - integer(kind=4) i - integer(kind=4) ifree - integer(kind=4) key - integer(kind=4) m -! -! Only nodes N/2 down to 1 can be "parent" nodes. -! - do i = n / 2, 1, -1 -! -! Copy the value out of the parent node. -! Position IFREE is now "open". -! - key = a(i) - ifree = i - - do -! -! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position -! IFREE. (One or both may not exist because they exceed N.) -! - m = 2 * ifree -! -! Does the first position exist? -! - if (n < m) then - exit - end if -! -! Does the second position exist? -! - if (m + 1 <= n) then -! -! If both positions exist, take the larger of the two values, -! and update M if necessary. -! - if (a(m) < a(m + 1)) then - m = m + 1 - end if - - end if -! -! If the large descendant is larger than KEY, move it up, -! and update IFREE, the location of the free position, and -! consider the descendants of THIS position. -! - if (a(m) <= key) then - exit - end if - - a(ifree) = a(m) - ifree = m - - end do -! -! Once there is no more shifting to do, KEY moves into the free spot IFREE. -! - a(ifree) = key - - end do - - return -end -subroutine i4vec_indicator(n, a) - -!*****************************************************************************80 -! -!! I4VEC_INDICATOR sets an integer vector to the indicator vector. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 November 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of elements of A. -! -! Output, integer ( kind = 4 ) A(N), the array to be initialized. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a(n) - integer(kind=4) i - - do i = 1, n - a(i) = i - end do - - return -end -function i4vec_lcm(n, v) - -!*****************************************************************************80 -! -!! I4VEC_LCM returns the least common multiple of an I4VEC. -! -! Discussion: -! -! An I4VEC is a vector of I4's. -! -! The value LCM returned has the property that it is the smallest integer -! which is evenly divisible by every element of V. -! -! The entries in V may be negative. -! -! If any entry of V is 0, then LCM is 0. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of V. -! -! Input, integer ( kind = 4 ) V(N), the vector. -! -! Output, integer ( kind = 4 ) I4VEC_LCM, the least common multiple of V. -! - implicit none - - integer(kind=4) n - - integer(kind=4) i - integer(kind=4) i4_lcm - integer(kind=4) i4vec_lcm - integer(kind=4) lcm - integer(kind=4) v(n) - - 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 - - return -end -subroutine i4vec_print(n, a, title) - -!*****************************************************************************80 -! -!! I4VEC_PRINT prints an I4VEC. -! -! Discussion: -! -! An I4VEC is a vector of I4's. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 May 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of components of the vector. -! -! Input, integer ( kind = 4 ) A(N), the vector to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a(n) - integer(kind=4) i - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - write (*, '(a)') ' ' - do i = 1, n - write (*, '(2x,i8,a,2x,i12)') i, ':', a(i) - end do - - return -end -subroutine i4vec_sort_heap_a(n, a) - -!*****************************************************************************80 -! -!! I4VEC_SORT_HEAP_A ascending sorts an integer array using heap sort. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Albert Nijenhuis, Herbert Wilf, -! Combinatorial Algorithms, -! Academic Press, 1978, second edition, -! ISBN 0-12-519260-6. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the array. -! -! Input/output, integer ( kind = 4 ) A(N). -! On input, the array to be sorted; -! On output, the array has been sorted. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a(n) - integer(kind=4) n1 - - if (n <= 1) then - return - end if -! -! 1: Put A into descending heap form. -! - call i4vec_heap_d(n, a) -! -! 2: Sort A. -! -! The largest object in the heap is in A(1). -! Move it to position A(N). -! - call i4_swap(a(1), a(n)) -! -! Consider the diminished heap of size N1. -! - do n1 = n - 1, 2, -1 -! -! Restore the heap structure of A(1) through A(N1). -! - call i4vec_heap_d(n1, a) -! -! Take the largest object from A(1) and move it to A(N1). -! - call i4_swap(a(1), a(n1)) - - end do - - return -end -subroutine i4vec_sorted_unique(n, a, unique_num) - -!*****************************************************************************80 -! -!! I4VEC_SORTED_UNIQUE gets the unique elements in a sorted integer array. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 July 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of elements in A. -! -! Input/output, integer ( kind = 4 ) A(N). On input, the sorted -! integer array. On output, the unique elements in A. -! -! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique elements -! in A. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a(n) - integer(kind=4) itest - integer(kind=4) unique_num - - unique_num = 0 - - if (n <= 0) then - return - end if - - unique_num = 1 - - do itest = 2, n - - if (a(itest) /= a(unique_num)) then - unique_num = unique_num + 1 - a(unique_num) = a(itest) - end if - - end do - - return -end -subroutine i4vec_uniform(n, a, b, seed, x) - -!*****************************************************************************80 -! -!! I4VEC_UNIFORM returns a scaled pseudorandom I4VEC. -! -! Discussion: -! -! An I4VEC is a vector of integer ( kind = 4 ) values. -! -! The pseudorandom numbers should be scaled to be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 November 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the dimension of the vector. -! -! Input, integer ( kind = 4 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 4 ) X(N), a vector of numbers between A and B. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a - integer(kind=4) b - integer(kind=4) i - integer(kind=4) k - real(kind=4) r - integer(kind=4) seed - integer(kind=4) value - integer(kind=4) x(n) - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'I4VEC_UNIFORM - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - do i = 1, n - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if - - r = real(seed, kind=4) * 4.656612875E-10 -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = (1.0E+00 - r) * (real(min(a, b), kind=4) - 0.5E+00) & - + r * (real(max(a, b), kind=4) + 0.5E+00) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint(r, kind=4) - - value = max(value, min(a, b)) - value = min(value, max(a, b)) - - x(i) = value - - end do - - return -end -subroutine i4vec2_compare(n, a1, a2, i, j, isgn) - -!*****************************************************************************80 -! -!! I4VEC2_COMPARE compares pairs of integers stored in two vectors. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 October 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of data items. -! -! Input, integer ( kind = 4 ) A1(N), A2(N), contain the two components -! of each item. -! -! Input, integer ( kind = 4 ) I, J, the items to be compared. -! -! Output, integer ( kind = 4 ) ISGN, the results of the comparison: -! -1, item I < item J, -! 0, item I = item J, -! +1, item J < item I. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a1(n) - integer(kind=4) a2(n) - integer(kind=4) i - integer(kind=4) isgn - integer(kind=4) j - - isgn = 0 - - if (a1(i) < a1(j)) then - - isgn = -1 - - else if (a1(i) == a1(j)) then - - if (a2(i) < a2(j)) then - isgn = -1 - else if (a2(i) < a2(j)) then - isgn = 0 - else if (a2(j) < a2(i)) then - isgn = +1 - end if - - else if (a1(j) < a1(i)) then - - isgn = +1 - - end if - - return -end -subroutine i4vec2_sort_a(n, a1, a2) - -!*****************************************************************************80 -! -!! I4VEC2_SORT_A ascending sorts a vector of pairs of integers. -! -! Discussion: -! -! Each item to be sorted is a pair of integers (I,J), with the I -! and J values stored in separate vectors A1 and A2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 June 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of items of data. -! -! Input/output, integer ( kind = 4 ) A1(N), A2(N), the data to be sorted.. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a1(n) - integer(kind=4) a2(n) - integer(kind=4) i - integer(kind=4) indx - integer(kind=4) isgn - integer(kind=4) j -! -! Initialize. -! - i = 0 - indx = 0 - isgn = 0 - j = 0 -! -! Call the external heap sorter. -! - do - - call sort_heap_external(n, indx, i, j, isgn) -! -! Interchange the I and J objects. -! - if (0 < indx) then - - call i4_swap(a1(i), a1(j)) - call i4_swap(a2(i), a2(j)) -! -! Compare the I and J objects. -! - else if (indx < 0) then - - call i4vec2_compare(n, a1, a2, i, j, isgn) - - else if (indx == 0) then - - exit - - end if - - end do - - return -end -subroutine i4vec2_sorted_unique(n, a1, a2, unique_num) - -!*****************************************************************************80 -! -!! I4VEC2_SORTED_UNIQUE gets the unique elements in a sorted I4VEC2. -! -! Discussion: -! -! Item I is stored as the pair A1(I), A2(I). -! -! The items must have been sorted, or at least it must be the -! case that equal items are stored in adjacent vector locations. -! -! If the items were not sorted, then this routine will only -! replace a string of equal values by a single representative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 July 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of items. -! -! Input/output, integer ( kind = 4 ) A1(N), A2(N). -! On input, the array of N items. -! On output, an array of unique items. -! -! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique items. -! - implicit none - - integer(kind=4) n - - integer(kind=4) a1(n) - integer(kind=4) a2(n) - integer(kind=4) itest - integer(kind=4) unique_num - - unique_num = 0 - - if (n <= 0) then - return - end if - - unique_num = 1 - - do itest = 2, n - - if (a1(itest) /= a1(unique_num) .or. a2(itest) /= a2(unique_num)) then - - unique_num = unique_num + 1 - - a1(unique_num) = a1(itest) - a2(unique_num) = a2(itest) - - end if - - end do - - return -end -subroutine icos_shape(point_num, edge_num, face_num, face_order_max, & - point_coord, edge_point, face_order, face_point) - -!*****************************************************************************80 -! -!! ICOS_SHAPE describes an icosahedron. -! -! Discussion: -! -! The input data required for this routine can be retrieved from -! ICOS_SIZE. -! -! The vertices lie on the unit sphere. -! -! The dual of an icosahedron is a dodecahedron. -! -! The data has been rearranged from a previous assignment. -! The STRIPACK program refuses to triangulate data if the first -! three nodes are "collinear" on the sphere. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points (12). -! -! Input, integer ( kind = 4 ) EDGE_NUM, the number of edges (30). -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces (20). -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of -! vertices per face (3). -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. -! -! Output, integer ( kind = 4 ) EDGE_POINT(2,EDGE_NUM), the points that -! make up each edge, listed in ascending order of their indexes. -! -! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices -! per face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The -! points are listed in the counter clockwise direction defined -! by the outward normal at the face. The nodes of each face are ordered -! so that the lowest index occurs first. The faces are then sorted by -! nodes. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4), parameter :: edge_order = 2 - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) point_num - - real(kind=8) a - real(kind=8) b - integer(kind=4) edge_point(edge_order, edge_num) - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) phi - real(kind=8) point_coord(dim_num, point_num) - real(kind=8) z -! -! Set the point coordinates. -! - phi = 0.5D+00 * (sqrt(5.0D+00) + 1.0D+00) - - a = phi / sqrt(1.0D+00 + phi * phi) - b = 1.0D+00 / sqrt(1.0D+00 + phi * phi) - z = 0.0D+00 -! -! A*A + B*B + Z*Z = 1. -! - point_coord(1:dim_num, 1:point_num) = reshape((/ & - a, b, z, & - a, -b, z, & - b, z, a, & - b, z, -a, & - z, a, b, & - z, a, -b, & - z, -a, b, & - z, -a, -b, & - -b, z, a, & - -b, z, -a, & - -a, b, z, & - -a, -b, z/), (/dim_num, point_num/)) -! -! Set the edges. -! - edge_point(1:edge_order, 1:edge_num) = reshape((/ & - 1, 2, & - 1, 3, & - 1, 4, & - 1, 5, & - 1, 6, & - 2, 3, & - 2, 4, & - 2, 7, & - 2, 8, & - 3, 5, & - 3, 7, & - 3, 9, & - 4, 6, & - 4, 8, & - 4, 10, & - 5, 6, & - 5, 9, & - 5, 11, & - 6, 10, & - 6, 11, & - 7, 8, & - 7, 9, & - 7, 12, & - 8, 10, & - 8, 12, & - 9, 11, & - 9, 12, & - 10, 11, & - 10, 12, & - 11, 12/), (/edge_order, edge_num/)) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3/) -! -! Set the faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 1, 2, 4, & - 1, 3, 2, & - 1, 4, 6, & - 1, 5, 3, & - 1, 6, 5, & - 2, 3, 7, & - 2, 7, 8, & - 2, 8, 4, & - 3, 5, 9, & - 3, 9, 7, & - 4, 8, 10, & - 4, 10, 6, & - 5, 6, 11, & - 5, 11, 9, & - 6, 10, 11, & - 7, 9, 12, & - 7, 12, 8, & - 8, 12, 10, & - 9, 11, 12, & - 10, 12, 11/), (/face_order_max, face_num/)) - - return -end -subroutine icos_size(point_num, edge_num, face_num, face_order_max) - -!*****************************************************************************80 -! -!! ICOS_SIZE gives "sizes" for an icosahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 12 - edge_num = 30 - face_num = 20 - face_order_max = 3 - - return -end - -subroutine loc2glob_3d(cospitch, cosroll, cosyaw, sinpitch, sinroll, sinyaw, & - globas, locpts, glopts) - -!*****************************************************************************80 -! -!! LOC2GLOB_3D converts from a local to global coordinate system in 3D. -! -! Discussion: -! -! A global coordinate system is given. -! -! A local coordinate system has been translated to the point with -! global coordinates GLOBAS, and rotated through a yaw, a pitch, and -! a roll. -! -! A point has local coordinates LOCPTS, and it is desired to know -! the point's global coordinates GLOPTS. -! -! The transformation may be written as -! -! GLOB = GLOBAS + N_YAW * N_PITCH * N_ROLL * LOC -! -! where -! -! ( cos(Yaw) -sin(Yaw) 0 ) -! N_YAW = ( sin(Yaw) cos(Yaw) 0 ) -! ( 0 0 1 ) -! -! ( cos(Pitch) 0 sin(Pitch) ) -! N_PITCH = ( 0 1 0 ) -! ( -sin(Pitch) 0 cos(Pitch) ) -! -! ( 1 0 0 ) -! N_ROLL = ( 0 cos(Roll) -sin(Roll) ) -! ( 0 sin(Roll) cos(Roll) ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) COSPITCH, COSROLL, COSYAW, the cosines of the -! pitch, roll and yaw angles. -! -! Input, real ( kind = 8 ) SINPITCH, SINROLL, SINYAW, the sines of the pitch, -! roll and yaw angles. -! -! Input, real ( kind = 8 ) GLOBAS(3), the global coordinates of the base -! vector. -! -! Input, real ( kind = 8 ) LOCPTS(3), the local coordinates of the point. -! -! Output, real ( kind = 8 ) GLOPTS(3), the global coordinates of the point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) cospitch - real(kind=8) cosroll - real(kind=8) cosyaw - real(kind=8) globas(dim_num) - real(kind=8) glopts(dim_num) - real(kind=8) locpts(dim_num) - real(kind=8) sinpitch - real(kind=8) sinroll - real(kind=8) sinyaw - - glopts(1) = globas(1) + (cosyaw * cospitch) * locpts(1) & - + (cosyaw * sinpitch * sinroll - sinyaw * cosroll) * locpts(2) & - + (cosyaw * sinpitch * cosroll + sinyaw * sinroll) * locpts(3) - - glopts(2) = globas(2) + (sinyaw * cospitch) * locpts(1) & - + (sinyaw * sinpitch * sinroll + cosyaw * cosroll) * locpts(2) & - + (sinyaw * sinpitch * cosroll - cosyaw * sinroll) * locpts(3) - - glopts(3) = globas(3) + (-sinpitch) * locpts(1) & - + (cospitch * sinroll) * locpts(2) & - + (cospitch * cosroll) * locpts(3) - - return -end -subroutine l4vec_print(n, a, title) - -!*****************************************************************************80 -! -!! L4VEC_PRINT prints an L4VEC. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of components of the vector. -! -! Input, logical ( kind = 4 ) A(N), the vector to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4) n - - logical(kind=4) a(n) - integer(kind=4) i - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - write (*, '(a)') ' ' - - do i = 1, n - write (*, '(2x,i8,a,1x,l1)') i, ':', a(i) - end do - - return -end -subroutine minabs(x1, y1, x2, y2, x3, y3, xmin, ymin) - -!*****************************************************************************80 -! -!! MINABS finds a local minimum of F(X) = A * abs ( X ) + B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 October 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, are three sets of -! data of the form ( X, F(X) ). The three X values must be distinct. -! On output, the data has been sorted so that X1 < X2 < X3, -! and the Y values have been rearranged accordingly. -! -! Output, real ( kind = 8 ) XMIN, YMIN. XMIN is a point within the interval -! spanned by X1, X2 and X3, at which F takes its local minimum -! value YMIN. -! - implicit none - - real(kind=8) slope - real(kind=8) slope12 - real(kind=8) slope13 - real(kind=8) slope23 - real(kind=8) x1 - real(kind=8) x2 - real(kind=8) x3 - real(kind=8) xmin - real(kind=8) y1 - real(kind=8) y2 - real(kind=8) y3 - real(kind=8) ymin -! -! Refuse to deal with coincident data. -! - if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then - write (*, '(a)') ' ' - write (*, '(a)') 'MINABS - Fatal error!' - write (*, '(a)') ' X values are equal.' - stop 1 - end if -! -! Sort the data. -! - if (x2 < x1) then - call r8_swap(x1, x2) - call r8_swap(y1, y2) - end if - - if (x3 < x1) then - call r8_swap(x1, x3) - call r8_swap(y1, y3) - end if - - if (x3 < x2) then - call r8_swap(x2, x3) - call r8_swap(y2, y3) - end if -! -! Now determine the slopes. -! - slope12 = (y2 - y1) / (x2 - x1) - slope23 = (y3 - y2) / (x3 - x2) - slope13 = (y3 - y1) / (x3 - x1) -! -! Case 1: Minimum must be at an endpoint. -! - if (slope13 <= slope12 .or. 0.0D+00 <= slope12) then - - if (y1 < y3) then - xmin = x1 - ymin = y1 - else - xmin = x3 - ymin = y3 - end if -! -! Case 2: The curve decreases, and decreases faster than the line -! joining the endpoints. -! -! Whichever of SLOPE12 and SLOPE23 is the greater in magnitude -! represents the actual slope of the underlying function. -! Find where two lines of that slope, passing through the -! endpoint data, intersect. -! - else - - slope = max(abs(slope12), slope23) - - xmin = 0.5D+00 * (x1 + x3 + (y1 - y3) / slope) - ymin = y1 - slope * (xmin - x1) - - end if - - return -end -subroutine minquad(x1, y1, x2, y2, x3, y3, xmin, ymin) - -!*****************************************************************************80 -! -!! MINQUAD finds a local minimum of F(X) = A * X * X + B * X + C. -! -! Discussion: -! -! MINQUAD is primarily intended as a utility routine. -! The square of the distance function between a point -! and a line segment has the form of F(X). Hence, we can seek -! the line on the second segment which minimizes the square of -! the distance to the other line segment. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 November 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, three sets of data -! of the form ( X, F(X) ). The three X values must be distinct. -! On output, the data has been sorted so that X1 < X2 < X3, -! and the Y values have been rearranged accordingly. -! -! Output, real ( kind = 8 ) XMIN, YMIN. XMIN is a point within the interval -! spanned by X1, X2 and X3, at which F takes its local minimum value YMIN. -! - implicit none - - integer(kind=4) ierror - real(kind=8) x - real(kind=8) x1 - real(kind=8) x2 - real(kind=8) x3 - real(kind=8) xleft - real(kind=8) xmin - real(kind=8) xrite - real(kind=8) y - real(kind=8) y1 - real(kind=8) y2 - real(kind=8) y3 - real(kind=8) ymin -! -! Refuse to deal with coincident data. -! - if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then - write (*, '(a)') ' ' - write (*, '(a)') 'MINQUAD - Fatal error!' - write (*, '(a)') ' X values are equal.' - stop 1 - end if -! -! Find the interval endpoints. -! - xleft = min(x1, x2, x3) - xrite = max(x1, x2, x3) -! -! Find the minimizer and its function value, over the three input points. -! - if (y1 <= y2 .and. y1 <= y3) then - xmin = x1 - ymin = y1 - else if (y2 <= y1 .and. y2 <= y3) then - xmin = x2 - ymin = y2 - else - xmin = x3 - ymin = y3 - end if -! -! Find the minimizer and its function value over the real line. -! - call parabola_ex(x1, y1, x2, y2, x3, y3, x, y, ierror) -! -! If F is linear, then take the already computed min. -! - if (ierror == 2) then -! -! If F has a maximum, then take the already computed min. -! - else if (ymin < y) then -! -! If the minimizer is to the left, take the already computed min. -! - else if (x < xleft) then -! -! If the minimizer is to the right, take the already computed min. -! - else if (xrite < x) then - - else - - xmin = x - ymin = y - - end if - - return -end -subroutine octahedron_shape_3d(point_num, face_num, face_order_max, & - point_coord, face_order, face_point) - -!*****************************************************************************80 -! -!! OCTAHEDRON_SHAPE_3D describes an octahedron in 3D. -! -! Discussion: -! -! The vertices lie on the unit sphere. -! -! The dual of the octahedron is the cube. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 October 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices -! per face. -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. -! -! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of -! vertices per face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The -! points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) point_num - - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) point_coord(dim_num, point_num) -! -! Set point coordinates. -! - point_coord(1:dim_num, 1:point_num) = reshape((/ & - 0.0D+00, 0.0D+00, -1.0D+00, & - 0.0D+00, -1.0D+00, 0.0D+00, & - 1.0D+00, 0.0D+00, 0.0D+00, & - 0.0D+00, 1.0D+00, 0.0D+00, & - -1.0D+00, 0.0D+00, 0.0D+00, & - 0.0D+00, 0.0D+00, 1.0D+00/), (/dim_num, point_num/)) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 3, 3, 3, 3, 3, 3, 3, 3/) -! -! Set the faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 1, 3, 2, & - 1, 4, 3, & - 1, 5, 4, & - 1, 2, 5, & - 2, 3, 6, & - 3, 4, 6, & - 4, 5, 6, & - 5, 2, 6/), (/face_order_max, face_num/)) - - return -end -subroutine octahedron_size_3d(point_num, edge_num, face_num, face_order_max) - -!*****************************************************************************80 -! -!! OCTAHEDRON_SIZE_3D returns size information for an octahedron in 3D. -! -! Discussion: -! -! This routine can be called before calling OCTAHEDRON_SHAPE_3D, -! so that space can be allocated for the arrays. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of -! vertices per face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 6 - edge_num = 12 - face_num = 8 - face_order_max = 3 - - return -end -subroutine parallelogram_area_2d(p, area) - -!*****************************************************************************80 -! -!! PARALLELOGRAM_AREA_2D computes the area of a parallelogram in 2D. -! -! Discussion: -! -! A parallelogram is a polygon having four sides, with the property -! that each pair of opposite sides is paralell. -! -! Given the first three vertices of the parallelogram, -! P1, P2, and P3, the fourth vertex must satisfy -! -! P4 = P1 + ( P3 - P2 ) -! -! This routine uses the fact that the norm of the cross product -! of two vectors is the area of the parallelogram they form: -! -! Area = ( P3 - P2 ) x ( P1 - P2 ). -! -! P4<-----P3 -! / / -! / / -! P1----->P2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 May 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P(2,4), the parallelogram vertices, -! given in counterclockwise order. The fourth vertex is ignored. -! -! Output, real ( kind = 8 ) AREA, the (signed) area. -! - implicit none - - real(kind=8) area - real(kind=8) p(2, 4) -! -! Compute the cross product vector, which only has a single -! nonzero component. -! - area = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & - - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) - - return -end -subroutine parallelogram_area_3d(p, area) - -!*****************************************************************************80 -! -!! PARALLELOGRAM_AREA_3D computes the area of a parallelogram in 3D. -! -! Discussion: -! -! A parallelogram is a polygon having four sides, with the property -! that each pair of opposite sides is paralell. -! -! A parallelogram in 3D must have the property that it is "really" -! a 2D object, that is, that the four vertices that define it lie -! in some plane. -! -! Given the first three vertices of the parallelogram (in 2D or 3D), -! P1, P2, and P3, the fourth vertex must satisfy -! -! P4 = P1 + ( P3 - P2 ) -! -! This routine uses the fact that the norm of the cross product -! of two vectors is the area of the parallelogram they form: -! -! Area = ( P3 - P2 ) x ( P1 - P2 ). -! -! P4<-----P3 -! / / -! / / -! P1----->P2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 May 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P(3,4), the parallelogram vertices, -! given in counterclockwise order. The fourth vertex is ignored. -! -! Output, real ( kind = 8 ) AREA, the area -! - implicit none - - real(kind=8) area - real(kind=8) cross(3) - real(kind=8) p(3, 4) -! -! Compute the cross product vector. -! - cross(1) = (p(2, 2) - p(2, 1)) * (p(3, 3) - p(3, 1)) & - - (p(3, 2) - p(3, 1)) * (p(2, 3) - p(2, 1)) - - cross(2) = (p(3, 2) - p(3, 1)) * (p(1, 3) - p(1, 1)) & - - (p(1, 2) - p(1, 1)) * (p(3, 3) - p(3, 1)) - - cross(3) = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & - - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) - - area = sqrt(sum(cross(1:3)**2)) - - return -end -function parallelogram_contains_point_2d(p1, p2, p3, p) - -!*****************************************************************************80 -! -!! PARALLELOGRAM_CONTAINS_POINT_2D: is point inside a parallelogram in 2D. -! -! Discussion: -! -! P2.............. -! / . -! / . -! / . -! P1----------->P3 -! -! The algorithm used here essentially computes the barycentric -! coordinates of the point P, and accepts it if both coordinates -! are between 0 and 1. ( For a triangle, they must be positive, -! and sum to no more than 1.) The same trick works for a parallelepiped. -! -! 05 August 2005: Thanks to Gernot Grabmair for pointing out that a previous -! version of this routine was incorrect. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), three corners of the -! parallelogram, with P1 between P2 and P3. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) PARALLELOGRAM_CONTAINS_POINT_2D, -! is TRUE if P is inside the parallelogram. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a(dim_num, dim_num + 1) - integer(kind=4) info - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - logical(kind=4) parallelogram_contains_point_2d -! -! Set up the linear system -! -! ( X2-X1 X3-X1 ) XSI(1) = X-X1 -! ( Y2-Y1 Y3-Y1 ) XSI(2) Y-Y1 -! -! which is satisfied by the barycentric coordinates of P. -! - a(1, 1) = p2(1) - p1(1) - a(1, 2) = p3(1) - p1(1) - a(1, 3) = p(1) - p1(1) - - a(2, 1) = p2(2) - p1(2) - a(2, 2) = p3(2) - p1(2) - a(2, 3) = p(2) - p1(2) -! -! Solve the linear system. -! - call r8mat_solve(dim_num, 1, a, info) - - if (info /= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'PARALLELOGRAM_CONTAINS_CONTAIN_2D - Fatal error!' - write (*, '(a)') ' The linear system is singular.' - write (*, '(a)') ' The input data does not form a proper triangle.' - stop 1 - end if - - if (a(1, 3) < 0.0D+00 .or. 1.0D+00 < a(1, 3)) then - parallelogram_contains_point_2d = .false. - else if (a(2, 3) < 0.0D+00 .or. 1.0D+00 < a(2, 3)) then - parallelogram_contains_point_2d = .false. - else - parallelogram_contains_point_2d = .true. - end if - - return -end -function parallelogram_contains_point_3d(p1, p2, p3, p) - -!*****************************************************************************80 -! -!! PARALLELOGRAM_CONTAINS_POINT_3D: point "inside" parallelogram in 3D. -! -! Discussion: -! -! The parallelogram is a 2-dimensional object in a 3D space. -! For a point to be "inside" the parallelogram, it should -! lie in the plane defined by the sides of the parallelogram, -! and, within that plane, lie inside the parallelogram. -! -! The algorithm constructs an auxilliary point P4, such that -! P4-P1 is normal to P2-P1 and P3-P1. The barycentric coordinates -! of the point P can be used to determine if the point lies in -! the plane, and within the parallelogram. -! -! P2.............. -! / . -! / . -! / . -! P1----------->P3 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three corners of the -! parallelogram, with P1 between P2 and P3. -! -! Input, real ( kind = 8 ) P(3), the point to be checked. -! -! Output, logical ( kind = 4 ) PARALLELOGRAM_CONTAINS_POINT_3D, -! is TRUE if P is inside the parallelogram, or on its boundary. -! A slight amount of leeway is allowed for error, since a three -! dimensional point may lie exactly in the plane of the parallelogram, -! and yet be computationally slightly outside it. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a(dim_num, dim_num + 1) - real(kind=8) r8vec_norm - integer(kind=4) info - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - logical(kind=4) parallelogram_contains_point_3d - real(kind=8), parameter :: tol = 0.0001D+00 -! -! Turn the triangle into a tetrahedron by computing the normal to -! P2-P1 and P3-P1. -! - call r8vec_cross_product_3d(p2(1:dim_num) - p1(1:dim_num), & - p3(1:dim_num) - p1(1:dim_num), p4) - - p4(1:dim_num) = p4(1:dim_num) / r8vec_norm(dim_num, p4) -! -! Set up the linear system -! -! ( X2-X1 X3-X1 X4-X1 ) XSI(1) = X-X1 -! ( Y2-Y1 Y3-Y1 Y4-Y1 ) XSI(2) Y-Y1 -! ( Z2-Z1 Z3-Z1 Z4-Z1 ) XSI(3) Z-Z1 -! -! which is satisfied by the barycentric coordinates of P. -! - a(1, 1) = p2(1) - p1(1) - a(1, 2) = p3(1) - p1(1) - a(1, 3) = p4(1) - p1(1) - a(1, 4) = p(1) - p1(1) - - a(2, 1) = p2(2) - p1(2) - a(2, 2) = p3(2) - p1(2) - a(2, 3) = p4(2) - p1(2) - a(2, 4) = p(2) - p1(2) - - a(3, 1) = p2(3) - p1(3) - a(3, 2) = p3(3) - p1(3) - a(3, 3) = p4(3) - p1(3) - a(3, 4) = p(3) - p1(3) -! -! Solve the linear system. -! - call r8mat_solve(dim_num, 1, a, info) - - if (info /= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'PARALLELOGRAM_CONTAINS_CONTAIN_3D - Fatal error!' - write (*, '(a)') ' The linear system is singular.' - write (*, '(a)') ' The input data does not form a proper triangle.' - stop 1 - end if - - if (a(1, 4) < 0.0D+00 .or. 1.0D+00 < a(1, 4)) then - parallelogram_contains_point_3d = .false. - else if (a(2, 4) < 0.0D+00 .or. 1.0D+00 < a(2, 4)) then - parallelogram_contains_point_3d = .false. - else if (tol < abs(a(3, 4))) then - parallelogram_contains_point_3d = .false. - else - parallelogram_contains_point_3d = .true. - end if - - return -end -subroutine parallelogram_point_dist_3d(p1, p2, p3, p, dist) - -!*****************************************************************************80 -! -!! PARALLELOGRAM_POINT_DIST_3D: distance ( parallelogram, point ) in 3D. -! -! Discussion: -! -! P2.............. -! / . -! / . -! / . -! P1----------->P3 -! -! Note that we are asking for the distance, in 3D, to a parallelogram, -! which is a 2D object. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three corners of the -! parallelogram, with P1 between P2 and P3. -! -! Input, real ( kind = 8 ) P(3), the point which is to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! parallelogram. DIST is zero if the point lies exactly on the -! parallelogram. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dis13 - real(kind=8) dis21 - real(kind=8) dis34 - real(kind=8) dis42 - real(kind=8) dist - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - logical(kind=4) parallelogram_contains_point_3d - real(kind=8) pn(dim_num) - real(kind=8) pp(dim_num) - real(kind=8) t - real(kind=8) temp -! -! Compute PP, the unit normal to X2-X1 and X3-X1: -! - pp(1) = (p2(2) - p1(2)) * (p3(3) - p1(3)) & - - (p2(3) - p1(3)) * (p3(2) - p1(2)) - pp(2) = (p2(3) - p1(3)) * (p3(1) - p1(1)) & - - (p2(1) - p1(1)) * (p3(3) - p1(3)) - pp(3) = (p2(1) - p1(1)) * (p3(2) - p1(2)) & - - (p2(2) - p1(2)) * (p3(1) - p1(1)) - - temp = sqrt(sum(pp(1:dim_num)**2)) - - if (temp == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PARALLELOGRAM_POINT_DIST_3D - Fatal error!' - write (*, '(a)') ' The normal vector is zero.' - stop 1 - end if - - pp(1:dim_num) = pp(1:dim_num) / temp -! -! Find PN, the nearest point to P in the plane. -! - t = dot_product(pp(1:dim_num), p(1:dim_num) - p1(1:dim_num)) - - pn(1:dim_num) = p(1:dim_num) - pp(1:dim_num) * t -! -! If P lies WITHIN the parallelogram, we're done. -! - inside = parallelogram_contains_point_3d(p1, p2, p3, p) - - if (inside) then - dist = sqrt(sum((pn(1:dim_num) - p(1:dim_num))**2)) - return - end if -! -! Otherwise, find the distance between P and each of the -! four line segments that make up the boundary of the parallelogram. -! - p4(1:dim_num) = p2(1:dim_num) + p3(1:dim_num) - p1(1:dim_num) - - call segment_point_dist_3d(p1, p3, p, dis13) - call segment_point_dist_3d(p3, p4, p, dis34) - call segment_point_dist_3d(p4, p2, p, dis42) - call segment_point_dist_3d(p2, p1, p, dis21) - - dist = min(dis13, dis34, dis42, dis21) - - return -end -subroutine parabola_ex(x1, y1, x2, y2, x3, y3, x, y, ierror) - -!*****************************************************************************80 -! -!! PARABOLA_EX: extremal point of a parabola determined by three points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 November 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, the coordinates of -! three points on the parabola. X1, X2 and X3 must be distinct. -! -! Output, real ( kind = 8 ) X, Y, the X coordinate of the extremal point -! of the parabola, and the value of the parabola at that point. -! -! Output, integer ( kind = 4 ) IERROR, error flag. -! 0, no error. -! 1, two of the X values are equal. -! 2, the data lies on a straight line; there is no finite extremal point. -! - implicit none - - real(kind=8) bot - integer(kind=4) ierror - real(kind=8) x - real(kind=8) x1 - real(kind=8) x2 - real(kind=8) x3 - real(kind=8) y - real(kind=8) y1 - real(kind=8) y2 - real(kind=8) y3 - - ierror = 0 - - if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then - ierror = 1 - return - end if - - if (y1 == y2 .and. y2 == y3 .and. y3 == y1) then - x = x1 - y = y1 - return - end if - - bot = (x2 - x3) * y1 - (x1 - x3) * y2 + (x1 - x2) * y3 - - if (bot == 0.0D+00) then - ierror = 2 - return - end if - - x = 0.5D+00 * (x1 * x1 * (y3 - y2) & - + x2 * x2 * (y1 - y3) & - + x3 * x3 * (y2 - y1)) / bot - - y = ((x - x2) * (x - x3) * (x2 - x3) * y1 & - - (x - x1) * (x - x3) * (x1 - x3) * y2 & - + (x - x1) * (x - x2) * (x1 - x2) * y3) / & - ((x1 - x2) * (x2 - x3) * (x1 - x3)) - - return -end -subroutine parabola_ex2(x1, y1, x2, y2, x3, y3, x, y, a, b, c, ierror) - -!*****************************************************************************80 -! -!! PARABOLA_EX2: extremal point of a parabola determined by three points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 October 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, the coordinates of -! three points on the parabola. X1, X2 and X3 must be distinct. -! -! Output, real ( kind = 8 ) X, Y, the X coordinate of the extremal point -! of the parabola, and the value of the parabola at that point. -! -! Output, real ( kind = 8 ) A, B, C, the coefficients that define the -! parabola: P(X) = A * X * X + B * X + C. -! -! Output, integer ( kind = 4 ) IERROR, error flag. -! 0, no error. -! 1, two of the X values are equal. -! 2, the data lies on a straight line; there is no finite extremal -! point. -! - implicit none - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) det - integer(kind=4) ierror - real(kind=8) v(3, 3) - real(kind=8) w(3, 3) - real(kind=8) x - real(kind=8) x1 - real(kind=8) x2 - real(kind=8) x3 - real(kind=8) y - real(kind=8) y1 - real(kind=8) y2 - real(kind=8) y3 - - ierror = 0 - - if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then - ierror = 1 - return - end if - - if (y1 == y2 .and. y2 == y3 .and. y3 == y1) then - x = x1 - y = y1 - return - end if -! -! Set up the Vandermonde matrix. -! - v(1, 1) = 1.0D+00 - v(1, 2) = x1 - v(1, 3) = x1 * x1 - - v(2, 1) = 1.0D+00 - v(2, 2) = x2 - v(2, 3) = x2 * x2 - - v(3, 1) = 1.0D+00 - v(3, 2) = x3 - v(3, 3) = x3 * x3 -! -! Get the inverse. -! - call r8mat_inverse_3d(v, w, det) -! -! Compute the parabolic coefficients. -! - c = w(1, 1) * y1 + w(1, 2) * y2 + w(1, 3) * y3 - b = w(2, 1) * y1 + w(2, 2) * y2 + w(2, 3) * y3 - a = w(3, 1) * y1 + w(3, 2) * y2 + w(3, 3) * y3 -! -! Determine the extremal point. -! - if (a == 0.0D+00) then - ierror = 2 - return - end if - - x = -b / (2.0D+00 * a) - y = a * x * x + b * x + c - - return -end -function parallelepiped_contains_point_3d(p1, p2, p3, p4, p) - -!*****************************************************************************80 -! -!! PARALLELEPIPED_CONTAINS_POINT_3D: point inside parallelepiped in 3D. -! -! Discussion: -! -! A parallelepiped is a "slanted box", that is, opposite -! sides are parallel planes. -! -! *------------------* -! / . / \ -! / . / \ -! / . / \ -! P4------------------* \ -! \ . \ \ -! \ . \ \ -! \ . \ \ -! \ P2.........\.......\ -! \ . \ / -! \ . \ / -! \ . \ / -! P1-----------------P3 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), four corners -! of the parallelepiped. It is assumed that P2, P3 and P4 are -! immediate neighbors of P1. -! -! Input, real ( kind = 8 ) P(3), the point to be checked. -! -! Output, logical ( kind = 4 ) PARALLELEPIPED_CONTAINS_POINT_3D, -! is true if P is inside the parallelepiped, or on its boundary. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dot - logical(kind=4) parallelepiped_contains_point_3d - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - - parallelepiped_contains_point_3d = .false. - - dot = dot_product(p(1:dim_num) - p1(1:dim_num), & - p2(1:dim_num) - p1(1:dim_num)) - - if (dot < 0.0D+00) then - return - end if - - if (sum((p2(1:dim_num) - p1(1:dim_num))**2) < dot) then - return - end if - - dot = dot_product(p(1:dim_num) - p1(1:dim_num), & - p3(1:dim_num) - p1(1:dim_num)) - - if (dot < 0.0D+00) then - return - end if - - if (sum((p3(1:dim_num) - p1(1:dim_num))**2) < dot) then - return - end if - - dot = dot_product(p(1:dim_num) - p1(1:dim_num), & - p4(1:dim_num) - p1(1:dim_num)) - - if (dot < 0.0D+00) then - return - end if - - if (sum((p4(1:dim_num) - p1(1:dim_num))**2) < dot) then - return - end if - - parallelepiped_contains_point_3d = .true. - - return -end -subroutine parallelepiped_point_dist_3d(p1, p2, p3, p4, p, dist) - -!*****************************************************************************80 -! -!! PARALLELEPIPED_POINT_DIST_3D: distance ( parallelepiped, point ) in 3D. -! -! Discussion: -! -! A parallelepiped is a "slanted box", that is, opposite -! sides are parallel planes. -! -! *------------------* -! / . / \ -! / . / \ -! / . / \ -! P4------------------* \ -! \ . \ \ -! \ . \ \ -! \ . \ \ -! \ P2.........\.......\ -! \ . \ / -! \ . \ / -! \ . \ / -! P1-----------------P3 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), -! half of the corners of the box, from which the other corners can be -! deduced. The corners should be chosen so that the first corner -! is directly connected to the other three. The locations of -! corners 5, 6, 7 and 8 will be computed by the parallelogram -! relation. -! -! Input, real ( kind = 8 ) P(3), the point which is to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the box. -! DIST is zero if the point lies exactly on the box. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dis - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - real(kind=8) p5(dim_num) - real(kind=8) p6(dim_num) - real(kind=8) p7(dim_num) - real(kind=8) p8(dim_num) -! -! Fill in the other corners -! - p5(1:dim_num) = p2(1:dim_num) + p3(1:dim_num) - p1(1:dim_num) - p6(1:dim_num) = p2(1:dim_num) + p4(1:dim_num) - p1(1:dim_num) - p7(1:dim_num) = p3(1:dim_num) + p4(1:dim_num) - p1(1:dim_num) - p8(1:dim_num) = p2(1:dim_num) + p3(1:dim_num) + p4(1:dim_num) & - - 2.0D+00 * p1(1:dim_num) -! -! Compute the distance from the point P to each of the six -! parallelogram faces. -! - call parallelogram_point_dist_3d(p1, p2, p3, p, dis) - - dist = dis - - call parallelogram_point_dist_3d(p1, p2, p4, p, dis) - - dist = min(dist, dis) - - call parallelogram_point_dist_3d(p1, p3, p4, p, dis) - - dist = min(dist, dis) - - call parallelogram_point_dist_3d(p8, p5, p6, p, dis) - - dist = min(dist, dis) - - call parallelogram_point_dist_3d(p8, p5, p7, p, dis) - - dist = min(dist, dis) - - call parallelogram_point_dist_3d(p8, p6, p7, p, dis) - - dist = min(dist, dis) - - return -end -subroutine perm_inverse(n, p) - -!*****************************************************************************80 -! -!! PERM_INVERSE inverts a permutation "in place". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 July 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of objects being permuted. -! -! Input/output, integer ( kind = 4 ) P(N), the permutation, in standard -! index form. On output, P describes the inverse permutation -! - implicit none - - integer(kind=4) n - - integer(kind=4) i - integer(kind=4) i0 - integer(kind=4) i1 - integer(kind=4) i2 - integer(kind=4) is - integer(kind=4) p(n) - - if (n <= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'PERM_INVERSE - Fatal error!' - write (*, '(a,i8)') ' Input value of N = ', n - stop 1 - end if - - is = 1 - - do i = 1, n - - i1 = p(i) - - do while (i < i1) - i2 = p(i1) - p(i1) = -i2 - i1 = i2 - end do - - is = -sign(1, p(i)) - p(i) = sign(p(i), is) - - end do - - do i = 1, n - - i1 = -p(i) - - if (0 <= i1) then - - i0 = i - - do - - i2 = p(i1) - p(i1) = i0 - - if (i2 < 0) then - exit - end if - - i0 = i1 - i1 = i2 - - end do - - end if - - end do - - return -end -subroutine plane_exp_grid_3d(p1, p2, p3, ncor3, line_num, cor3, lines, & - maxcor3, line_max, ierror) - -!*****************************************************************************80 -! -!! PLANE_EXP_GRID_3D computes points and lines making up a planar grid in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is: -! -! the plane through P1, P2 and P3. -! -! The data format used is that of SGI Inventor. -! -! On input, if NCOR3 is zero (or negative), then the data computed by -! this routine will be stored normally in COR3. But if NCOR3 is -! positive, it is assumed that COR3 already contains NCOR3 items -! of useful data. The new data is appended to COR3. On output, NCOR3 -! is increased by the number of points computed by this routine. -! -! On input, if LINE_NUM is zero (or negative), then the data computed by -! this routine will be stored normally in LINES. But if LINE_NUM is -! positive, it is assumed that LINES already contains some useful data. The -! new data is appended to LINES. On output, LINE_NUM is increased by the -! number of lines computed by this routine. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 October 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Input/output, integer ( kind = 4 ) NCOR3, the number of points stored -! in COR3. -! -! Input/output, integer ( kind = 4 ) LINE_NUM, the number of line data items. -! -! Input/output, real ( kind = 8 ) COR3(3,MAXCOR3), the grid points. -! -! Input/output, integer ( kind = 4 ) LINES(LINE_MAX), the indices of -! points used in the lines of the grid. Successive entries of LINES are -! joined by a line, unless an entry equals -1. Note that indices begin -! with 0. -! -! Input, integer ( kind = 4 ) MAXCOR3, the maximum number of points. -! -! Input, integer ( kind = 4 ) LINE_MAX, the maximum number of lines. -! -! Output, integer ( kind = 4 ) IERROR, error indicator. -! 0, no error. -! 1, more space for point coordinates is needed. -! 2, more space for line data is needed. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) maxcor3 - integer(kind=4) line_max - - real(kind=8) a - real(kind=8) amax - real(kind=8) amin - real(kind=8) b - real(kind=8) bmax - real(kind=8) bmin - real(kind=8) cor3(dim_num, maxcor3) - real(kind=8) dot - integer(kind=4) i - integer(kind=4) ierror - integer(kind=4) j - integer(kind=4) line_num - integer(kind=4) lines(line_max) - integer(kind=4) nbase - integer(kind=4) ncor3 - integer(kind=4), parameter :: nx = 5 - integer(kind=4), parameter :: ny = 5 - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) - - ierror = 0 - - if (ncor3 <= 0) then - ncor3 = 0 - end if - - if (line_num <= 0) then - line_num = 0 - end if - - nbase = ncor3 -! -! Compute the two basis vectors for the affine plane. -! - v1(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - - call vector_unit_nd(dim_num, v1) - - v2(1:dim_num) = p3(1:dim_num) - p1(1:dim_num) - - dot = dot_product(v1(1:dim_num), v2(1:dim_num)) -! -! Remove the component of V1 from V2, and give the -! resulting vector unit norm. V1 and V2 are now orthogonal -! and of unit length, and represent the two direction vectors -! of our plane. -! - v2(1:dim_num) = v2(1:dim_num) - dot * v1(1:dim_num) - - call vector_unit_nd(dim_num, v2) -! -! Compute the (V1,V2) coordinate range of the input data, if any. -! - if (ncor3 == 0) then - - amin = 0.0D+00 - amax = 1.0D+00 - bmin = 0.0D+00 - bmax = 1.0D+00 - - else - - do i = 1, ncor3 - - a = dot_product(v1(1:dim_num), cor3(1:dim_num, i)) - b = dot_product(v2(1:dim_num), cor3(1:dim_num, i)) - - if (i == 1) then - amin = a - amax = a - bmin = b - bmax = b - else - amin = min(amin, a) - amax = max(amax, a) - bmin = min(bmin, b) - bmax = max(bmax, b) - end if - - end do - - end if -! -! Generate the points we will use. -! - if (maxcor3 < ncor3 + nx * ny) then - ierror = 1 - return - end if - - do j = 1, ny - - b = (real(ny - j, kind=8) * bmin & - + real(j - 1, kind=8) * bmax) & - / real(ny - 1, kind=8) - - do i = 1, nx - - a = (real(nx - i, kind=8) * amin & - + real(i - 1, kind=8) * amax) & - / real(nx - 1, kind=8) - - ncor3 = ncor3 + 1 - cor3(1:dim_num, ncor3) = a * v1(1:dim_num) + b * v2(1:dim_num) - - end do - - end do -! -! Do the "horizontals". -! - do i = 1, nx - - do j = 1, ny - - if (line_max <= line_num) then - ierror = 2 - return - end if - - line_num = line_num + 1 - lines(line_num) = nbase + (j - 1) * nx + i - - end do - - if (line_max <= line_num) then - ierror = 2 - return - end if - - line_num = line_num + 1 - lines(line_num) = 0 - - end do -! -! Do the "verticals". -! - do j = 1, ny - - do i = 1, nx - - if (line_max <= line_num) then - ierror = 2 - return - end if - - line_num = line_num + 1 - lines(line_num) = nbase + (j - 1) * nx + i - - end do - - if (line_max <= line_num) then - ierror = 2 - return - end if - - line_num = line_num + 1 - lines(line_num) = 0 - - end do - - return -end -subroutine plane_exp_normal_3d(p1, p2, p3, normal) - -!*****************************************************************************80 -! -!! PLANE_EXP_NORMAL_3D finds the normal to an explicit plane in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is -! -! the plane through P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Output, real ( kind = 8 ) NORMAL(3), the coordinates of the unit normal -! vector to the plane containing the three points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) normal(dim_num) - real(kind=8) normal_norm - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) -! -! The cross product (P2-P1) x (P3-P1) is normal to (P2-P1) and (P3-P1). -! - normal(1) = (p2(2) - p1(2)) * (p3(3) - p1(3)) & - - (p2(3) - p1(3)) * (p3(2) - p1(2)) - - normal(2) = (p2(3) - p1(3)) * (p3(1) - p1(1)) & - - (p2(1) - p1(1)) * (p3(3) - p1(3)) - - normal(3) = (p2(1) - p1(1)) * (p3(2) - p1(2)) & - - (p2(2) - p1(2)) * (p3(1) - p1(1)) - - normal_norm = sqrt(sum(normal(1:dim_num)**2)) - - if (normal_norm == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_EXP_NORMAL_3D - Fatal error!' - write (*, '(a)') ' The plane is poorly defined.' - stop 1 - end if - - normal(1:dim_num) = normal(1:dim_num) / normal_norm - - return -end -subroutine plane_exp_point_dist_3d(p1, p2, p3, p, dist) - -!*****************************************************************************80 -! -!! PLANE_EXP_POINT_DIST_3D: distance ( explicit plane, point ) in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is -! -! the plane through P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Input, real ( kind = 8 ) P(3), the coordinates of the point. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - - call plane_exp2imp_3d(p1, p2, p3, a, b, c, d) - - call plane_imp_point_dist_3d(a, b, c, d, p, dist) - - return -end -subroutine plane_exp_pro2(p1, p2, p3, n, p, pp) - -!*****************************************************************************80 -! -!! PLANE_EXP_PRO2 produces 2D coordinates of points that lie in a plane, in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is: -! -! the plane through P1, P2 and P3. -! -! The first thing to do is to compute two orthonormal vectors V1 and -! V2, so that any point P that lies in the plane may be written as -! -! P = P1 + alpha * V1 + beta * V2 -! -! The vector V1 lies in the direction P2-P1, and V2 lies in -! the plane, is orthonormal to V1, and has a positive component -! in the direction of P3-P1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Input, integer ( kind = 4 ) N, the number of points to project. -! -! Input, real ( kind = 8 ) P(3,N), are the Cartesian -! coordinates of points which lie on the plane spanned by the -! three points. These points are not checked to ensure that -! they lie on the plane. -! -! Output, real ( kind = 8 ) PP(2,N), the "in-plane" -! coordinates of the points. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dot - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pp(2, dim_num) - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) -! -! Compute the two basis vectors for the affine plane. -! - v1(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - - call vector_unit_nd(dim_num, v1) - - v2(1:dim_num) = p3(1:dim_num) - p1(1:dim_num) - - dot = dot_product(v1(1:dim_num), v2(1:dim_num)) - - v2(1:dim_num) = v2(1:dim_num) - dot * v1(1:dim_num) - - call vector_unit_nd(dim_num, v2) -! -! Now decompose each point. -! - do i = 1, n - pp(1, i) = dot_product(p(1:dim_num, i) - p1(1:dim_num), v1(1:dim_num)) - pp(2, i) = dot_product(p(1:dim_num, i) - p2(1:dim_num), v2(1:dim_num)) - end do - - return -end -subroutine plane_exp_pro3(p1, p2, p3, n, p, pp) - -!*****************************************************************************80 -! -!! PLANE_EXP_PRO3 projects points orthographically onto a plane, in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is: -! -! the plane through P1, P2 and P3. -! -! PP may share the same memory as PO, in -! which case the projections will overwrite the original data. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Input, integer ( kind = 4 ) N, the number of points to project. -! -! Input, real ( kind = 8 ) P(3,N), the points. -! -! Output, real ( kind = 8 ) PP(3,N), the projections of the points through -! the focus point onto the plane. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pp(dim_num, n) -! -! Put the plane into ABCD form. -! - call plane_exp2imp_3d(p1, p2, p3, a, b, c, d) -! -! For each point, its image in the plane is the nearest point -! in the plane. -! - do i = 1, n - - call plane_imp_point_near_3d(a, b, c, d, p(1:dim_num, i), pp(1:dim_num, i)) - - end do - - return -end -subroutine plane_exp_project_3d(p1, p2, p3, pf, n, po, pp, ivis) - -!*****************************************************************************80 -! -!! PLANE_EXP_PROJECT_3D projects points through a point onto a plane in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is -! -! the plane through P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Input, real ( kind = 8 ) PF(3), the focus point. -! -! Input, integer ( kind = 4 ) N, the number of points to project. -! -! Input, real ( kind = 8 ) PO(3,N), the object points. -! -! Output, real ( kind = 8 ) PP(3,N), are the -! coordinates of the projections of the object points through the focus -! point onto the plane. PP may share the same memory as PO, -! in which case the projections will overwrite the original data. -! -! Output, integer ( kind = 4 ) IVIS(N), visibility indicator: -! 3, the object was behind the plane; -! 2, the object was already on the plane; -! 1, the object was between the focus and the plane; -! 0, the line from the object to the focus is parallel to the plane, -! so the object is "invisible". -! -1, the focus is between the object and the plane. The object -! might be considered invisible. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) alpha - real(kind=8) angle_rad_3d - real(kind=8) b - real(kind=8) beta - real(kind=8) c - real(kind=8) d - real(kind=8) disfo - real(kind=8) disfn - integer(kind=4) i - integer(kind=4) ivis(n) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pf(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) po(dim_num, n) - real(kind=8) pp(dim_num, n) -! -! Put the plane into ABCD form. -! - call plane_exp2imp_3d(p1, p2, p3, a, b, c, d) -! -! Get the nearest point on the plane to the focus. -! - call plane_imp_point_near_3d(a, b, c, d, pf, pn) -! -! Get the distance from the focus to the plane. -! - disfn = sqrt(sum((pf(1:dim_num) - pn(1:dim_num))**2)) -! -! If the focus lies in the plane, this is bad. We could still -! project points that actually lie in the plane, but we'll -! just bail out. -! - if (disfn == 0.0D+00) then - ivis(1:n) = 0 - do i = 1, dim_num - pp(i, 1:n) = pf(i) - end do - return - end if -! -! Process the points. -! - do i = 1, n -! -! Get the distance from the focus to the object. -! - disfo = sqrt(sum((po(1:dim_num, i) - pf(1:dim_num))**2)) - - if (disfo == 0.0D+00) then - - ivis(i) = 0 - pp(1:dim_num, i) = pn(1:dim_num) - - else -! -! Compute ALPHA, the angle between (objECT-FOCUS) and (NEAREST-FOCUS). -! - alpha = angle_rad_3d(po(1:3, i), pf(1:3), pn(1:3)) - - if (cos(alpha) == 0.0D+00) then - - ivis(i) = 0 - pp(1:dim_num, i) = pn(1:dim_num) - - else -! -! BETA is Dist(NEAREST-FOCUS) / ( Cos(ALPHA)*Dist(objECT-FOCUS) ) -! - beta = disfn / (cos(alpha) * disfo) - - if (1.0D+00 < beta) then - ivis(i) = 1 - else if (beta == 1.0D+00) then - ivis(i) = 2 - else if (0.0D+00 < beta) then - ivis(i) = 3 - else - ivis(i) = -1 - end if -! -! Set the projected point. -! - pp(1:dim_num, i) = pf(1:dim_num) & - + beta * (po(1:dim_num, i) - pf(1:dim_num)) - - end if - - end if - - end do - - return -end -subroutine plane_exp2imp_3d(p1, p2, p3, a, b, c, d) - -!*****************************************************************************80 -! -!! PLANE_EXP2IMP_3D converts an explicit plane to implicit form in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is -! -! the plane through P1, P2 and P3. -! -! The implicit form of a plane in 3D is -! -! A * X + B * Y + C * Z + D = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 February 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Output, real ( kind = 8 ) A, B, C, D, coefficients which describe -! the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - - a = (p2(2) - p1(2)) * (p3(3) - p1(3)) & - - (p2(3) - p1(3)) * (p3(2) - p1(2)) - - b = (p2(3) - p1(3)) * (p3(1) - p1(1)) & - - (p2(1) - p1(1)) * (p3(3) - p1(3)) - - c = (p2(1) - p1(1)) * (p3(2) - p1(2)) & - - (p2(2) - p1(2)) * (p3(1) - p1(1)) - - d = -p2(1) * a - p2(2) * b - p2(3) * c - - return -end -subroutine plane_exp2normal_3d(p1, p2, p3, pp, normal) - -!*****************************************************************************80 -! -!! PLANE_EXP2NORMAL_3D converts an explicit plane to normal form in 3D. -! -! Discussion: -! -! The explicit form of a plane in 3D is -! -! the plane through P1, P2 and P3. -! -! The normal form of a plane in 3D is -! -! PP, a point on the plane, and -! N, the unit normal to the plane. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! -! Output, real ( kind = 8 ) PP(3), a point on the plane. -! -! Output, real ( kind = 8 ) NORMAL(3), a unit normal vector to the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) norm - real(kind=8) normal(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pp(dim_num) - - pp(1:dim_num) = p1(1:dim_num) - - normal(1) = (p2(2) - p1(2)) * (p3(3) - p1(3)) & - - (p2(3) - p1(3)) * (p3(2) - p1(2)) - - normal(2) = (p2(3) - p1(3)) * (p3(1) - p1(1)) & - - (p2(1) - p1(1)) * (p3(3) - p1(3)) - - normal(3) = (p2(1) - p1(1)) * (p3(2) - p1(2)) & - - (p2(2) - p1(2)) * (p3(1) - p1(1)) - - norm = sqrt(sum(normal(1:dim_num)**2)) - - if (norm == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_EXP2NORMAL_3D - Fatal error!' - write (*, '(a)') ' The normal vector is null.' - write (*, '(a)') ' Two points coincide, or nearly so.' - stop 1 - end if - - normal(1:dim_num) = normal(1:dim_num) / norm - - return -end -function plane_imp_is_degenerate_3d(a, b, c) - -!*****************************************************************************80 -! -!! PLANE_IMP_IS_DEGENERATE_3D is TRUE if an implicit plane is degenerate. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! The implicit plane is degenerate if A = B = C = 0. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, the implicit plane parameters. -! -! Output, logical ( kind = 4 ) PLANE_IMP_IS_DEGENERATE_3D, -! is TRUE if the plane is degenerate. -! - implicit none - - real(kind=8) a - real(kind=8) b - real(kind=8) c - logical(kind=4) plane_imp_is_degenerate_3d - - if (a == 0.0D+00 .and. b == 0.0D+00 .and. c == 0.0D+00) then - plane_imp_is_degenerate_3d = .true. - else - plane_imp_is_degenerate_3d = .false. - end if - - return -end -subroutine plane_imp_line_par_int_3d(a, b, c, d, x0, y0, z0, f, g, h, & - intersect, p) - -!*****************************************************************************80 -! -!! PLANE_IMP_LINE_PAR_INT_3D: intersection ( impl plane, param line ) in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! The parametric form of a line in 3D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! Z = Z0 + H * T -! -! We normalize by always choosing F*F + G*G + H*H = 1, -! and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420, -! page 111. -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Input, real ( kind = 8 ) X0, Y0, Z0, F, G, H, parameters that define the -! parametric line. -! -! Output, logical ( kind = 4 ) INTERSECT, is TRUE if the line and the plane -! intersect. -! -! Output, real ( kind = 8 ) P(3), is a point of intersection of the line -! and the plane, if INTERSECT is TRUE. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) denom - real(kind=8) f - real(kind=8) g - real(kind=8) h - logical(kind=4) intersect - real(kind=8) norm1 - real(kind=8) norm2 - real(kind=8) p(dim_num) - real(kind=8) t - real(kind=8), parameter :: tol = 0.00001D+00 - real(kind=8) x0 - real(kind=8) y0 - real(kind=8) z0 -! -! Check. -! - norm1 = sqrt(a * a + b * b + c * c) - - if (norm1 == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP_LINE_PAR_INT_3D - Fatal error!' - write (*, '(a)') ' The plane normal vector is null.' - stop 1 - end if - - norm2 = sqrt(f * f + g * g + h * h) - - if (norm2 == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP_LINE_PAR_INT_3D - Fatal error!' - write (*, '(a)') ' The line direction vector is null.' - stop 1 - end if - - denom = a * f + b * g + c * h -! -! The line and the plane may be parallel. -! - if (abs(denom) < tol * norm1 * norm2) then - - if (a * x0 + b * y0 + c * z0 + d == 0.0D+00) then - intersect = .true. - p(1) = x0 - p(2) = y0 - p(3) = z0 - else - intersect = .false. - p(1:dim_num) = 0.0D+00 - end if -! -! If they are not parallel, they must intersect. -! - else - - intersect = .true. - t = -(a * x0 + b * y0 + c * z0 + d) / denom - p(1) = x0 + t * f - p(2) = y0 + t * g - p(3) = z0 + t * h - - end if - - return -end -subroutine plane_imp_point_dist_3d(a, b, c, d, p, dist) - -!*****************************************************************************80 -! -!! PLANE_IMP_POINT_DIST_3D: distance ( implicit plane, point ) in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Input, real ( kind = 8 ) P(3), the coordinates of the point. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) dist - real(kind=8) norm - real(kind=8) p(dim_num) - - norm = sqrt(a * a + b * b + c * c) - - if (norm == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP_POINT_DIST_3D - Fatal error!' - write (*, '(a)') ' The plane normal vector is null.' - stop 1 - end if - - dist = abs(a * p(1) + b * p(2) + c * p(3) + d) / norm - - return -end -subroutine plane_imp_point_dist_signed_3d(a, b, c, d, p, dist_signed) - -!*****************************************************************************80 -! -!! PLANE_IMP_POINT_DIST_SIGNED_3D: signed distance ( imp plane, point) in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Priamos Georgiades, -! Signed Distance From Point To Plane, -! in Graphics Gems III, -! edited by David Kirk, -! Academic Press, 1992, pages 233-235, T385.G6973. -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Input, real ( kind = 8 ) P(3), the coordinates of the point. -! -! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from -! the point to the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) dist_signed - real(kind=8) norm - real(kind=8) p(dim_num) - - norm = sqrt(a * a + b * b + c * c) - - if (norm == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP_POINT_DIST_SIGNED_3D - Fatal error!' - write (*, '(a)') ' The plane normal vector is null.' - stop 1 - end if - - dist_signed = -sign(1.0D+00, d) & - * (a * p(1) + b * p(2) + c * p(3) + d) / norm - - return -end -subroutine plane_imp_point_near_3d(a, b, c, d, p, pn) - -!*****************************************************************************80 -! -!! PLANE_IMP_POINT_NEAR_3D: nearest point on a implicit plane to a point in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! A normal vector to the plane is (A,B,C). -! -! The line defined by (XN-P(1))/A = (YN-P(2))/B = (ZN-P(3))/C = T -! goes through P and is parallel to N. -! -! Solving for the point (XN,YN,ZN) we get -! -! XN = A*T+P(1) -! YN = B*T+P(2) -! ZN = C*T+P(3) -! -! Now place these values in the equation for the plane: -! -! A*(A*T+P(1)) + B*(B*T+P(2)) + C*(C*T+P(3)) + D = 0 -! -! and solve for T: -! -! T = (-A*P(1)-B*P(2)-C*P(3)-D) / (A * A + B * B + C * C ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Input, real ( kind = 8 ) P(3), the coordinates of the point. -! -! Output, real ( kind = 8 ) PN(3), the nearest point on the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) p(dim_num) - logical(kind=4) plane_imp_is_degenerate_3d - real(kind=8) pn(dim_num) - real(kind=8) t - - if (plane_imp_is_degenerate_3d(a, b, c)) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP_POINT_NEAR_3D - Fatal error!' - write (*, '(a)') ' A = B = C = 0.' - stop 1 - end if - - t = -(a * p(1) + b * p(2) + c * p(3) + d) / (a * a + b * b + c * c) - - pn(1) = p(1) + a * t - pn(2) = p(2) + b * t - pn(3) = p(3) + c * t - - return -end -subroutine plane_imp_segment_near_3d(p1, p2, a, b, c, d, dist, p, pn) - -!*****************************************************************************80 -! -!! PLANE_IMP_SEGMENT_NEAR_3D: nearest ( implicit plane, line segment ) in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! A line segment is the finite portion of a line that lies between -! two points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the line -! segment. -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Output, real ( kind = 8 ) DIST, the distance between the line segment and -! the plane. -! -! Output, real ( kind = 8 ) P(3), the nearest point on the plane. -! -! Output, real ( kind = 8 ) PN(3), the nearest point on the line -! segment to the plane. If DIST is zero, the PN is a point of -! intersection of the plane and the line segment. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) alpha - real(kind=8) an - real(kind=8) b - real(kind=8) bn - real(kind=8) c - real(kind=8) cn - real(kind=8) d - real(kind=8) dist - real(kind=8) dn - real(kind=8) dot1 - real(kind=8) dot2 - real(kind=8) norm - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - - pn(1:dim_num) = 0.0D+00 - p(1:dim_num) = 0.0D+00 - - norm = sqrt(a * a + b * b + c * c) - - if (norm == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP_SEGMENT_NEAR_3D - Fatal error!' - write (*, '(a)') ' Plane normal vector is null.' - stop 1 - end if -! -! The normalized coefficients allow us to compute the (signed) distance. -! - an = a / norm - bn = b / norm - cn = c / norm - dn = d / norm -! -! If the line segment is actually a point, then the answer is easy. -! - if (all(p1(1:dim_num) == p2(1:dim_num))) then - - dot1 = an * p1(1) + bn * p1(2) + cn * p1(3) + dn - dist = abs(dot1) - pn(1:dim_num) = p1(1:dim_num) - p(1) = pn(1) - an * dot1 - p(2) = pn(2) - bn * dot1 - p(3) = pn(3) - cn * dot1 - return - - end if -! -! Compute the projections of the two points onto the normal vector. -! - dot1 = an * p1(1) + bn * p1(2) + cn * p1(3) + dn - dot2 = an * p2(1) + bn * p2(2) + cn * p2(3) + dn -! -! If these have the same sign, then the line segment does not -! cross the plane, and one endpoint is the nearest point. -! - if ((0.0D+00 < dot1 .and. 0.0D+00 < dot2) .or. & - (dot1 < 0.0D+00 .and. dot2 < 0.0D+00)) then - - dot1 = abs(dot1) - dot2 = abs(dot2) - - if (dot1 < dot2) then - pn(1:dim_num) = p1(1:dim_num) - p(1) = pn(1) - an * dot1 - p(2) = pn(2) - bn * dot1 - p(3) = pn(3) - cn * dot1 - dist = dot1 - else - pn(1:dim_num) = p2(1:dim_num) - dist = dot2 - p(1) = pn(1) - an * dot2 - p(2) = pn(2) - bn * dot2 - p(3) = pn(3) - cn * dot2 - end if -! -! If the projections differ in sign, the line segment crosses the plane. -! - else - - if (dot1 == 0.0D+00) then - alpha = 0.0D+00 - else if (dot2 == 0.0D+00) then - alpha = 1.0D+00 - else - alpha = dot2 / (dot2 - dot1) - end if - - pn(1:dim_num) = alpha * p1(1:dim_num) & - + (1.0D+00 - alpha) * p2(1:dim_num) - - p(1:dim_num) = pn(1:dim_num) - - dist = 0.0D+00 - - end if - - return -end -subroutine plane_imp_triangle_int_3d(a, b, c, d, t, int_num, pint) - -!*****************************************************************************80 -! -!! PLANE_IMP_TRIANGLE_INT_3D: intersection ( implicit plane, triangle ) in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! There may be 0, 1, 2 or 3 points of intersection returned. -! -! If two intersection points are returned, then the entire line -! between them comprises points of intersection. -! -! If three intersection points are returned, then all points of -! the triangle intersect the plane. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points -! returned. -! -! Output, real ( kind = 8 ) PINT(3,3), the intersection points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) dist1 - real(kind=8) dist2 - real(kind=8) dist3 - integer(kind=4) int_num - real(kind=8) pint(dim_num, 3) - real(kind=8) t(dim_num, 3) - - int_num = 0 -! -! Compute the signed distances between the vertices and the plane. -! - dist1 = a * t(1, 1) + b * t(2, 1) + c * t(3, 1) + d - dist2 = a * t(1, 2) + b * t(2, 2) + c * t(3, 2) + d - dist3 = a * t(1, 3) + b * t(2, 3) + c * t(3, 3) + d -! -! Consider any zero distances. -! - if (dist1 == 0.0D+00) then - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 1) - end if - - if (dist2 == 0.0D+00) then - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 2) - end if - - if (dist3 == 0.0D+00) then - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 3) - end if -! -! If 2 or 3 of the nodes intersect, we're already done. -! - if (2 <= int_num) then - return - end if -! -! If one node intersects, then we're done unless the other two -! are of opposite signs. -! - if (int_num == 1) then - - if (dist1 == 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & - dist2, dist3, int_num, pint) - - else if (dist2 == 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & - dist1, dist3, int_num, pint) - - else if (dist3 == 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & - dist1, dist2, int_num, pint) - - end if - - return - - end if -! -! All nodal distances are nonzero, and there is at least one -! positive and one negative. -! - if (dist1 * dist2 < 0.0D+00 .and. dist1 * dist3 < 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & - dist1, dist2, int_num, pint) - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & - dist1, dist3, int_num, pint) - - else if (dist2 * dist1 < 0.0D+00 .and. dist2 * dist3 < 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 1), & - dist2, dist1, int_num, pint) - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & - dist2, dist3, int_num, pint) - - else if (dist3 * dist1 < 0.0D+00 .and. dist3 * dist2 < 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 1), & - dist3, dist1, int_num, pint) - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 2), & - dist3, dist2, int_num, pint) - - end if - - return -end -subroutine plane_imp_triangle_int_add_3d(p1, p2, dist1, dist2, int_num, pint) - -!*****************************************************************************80 -! -!! PLANE_IMP_TRIANGLE_INT_ADD_3D is a utility for plane/triangle intersections. -! -! Discussion: -! -! This routine is called to consider the value of the signed distance -! from a plane of two nodes of a triangle. If the two values -! have opposite signs, then there is a point of intersection between -! them. The routine computes this point and adds it to the list. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the coordinates of two vertices -! of a triangle. -! -! Input, real ( kind = 8 ) DIST1, DIST2, the signed distances of the -! two vertices from a plane. -! -! Input/output, integer ( kind = 4 ) INT_NUM, the number of intersection -! points. -! -! Input/output, real ( kind = 8 ) PINT(3,INT_NUM), the intersection points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) alpha - real(kind=8) dist1 - real(kind=8) dist2 - integer(kind=4) int_num - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pint(dim_num, 3) - - if (dist1 == 0.0D+00) then - int_num = int_num + 1 - pint(1:dim_num, int_num) = p1(1:dim_num) - else if (dist2 == 0.0D+00) then - int_num = int_num + 1 - pint(1:dim_num, int_num) = p2(1:dim_num) - else if (dist1 * dist2 < 0.0D+00) then - alpha = dist2 / (dist2 - dist1) - int_num = int_num + 1 - pint(1:dim_num, int_num) = alpha * p1(1:dim_num) & - + (1.0D+00 - alpha) * p2(1:dim_num) - end if - - return -end -subroutine plane_imp_triangle_near_3d(t, a, b, c, d, dist, near_num, pn) - -!*****************************************************************************80 -! -!! PLANE_IMP_TRIANGLE_NEAR_3D: nearest ( implicit plane, triangle ) in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! If DIST = 0, then each point is a point of intersection, and there -! will be at most 3 such points returned. -! -! If 0 < DIST, then the points are listed in pairs, with the first -! being on the triangle, and the second on the plane. Two points will -! be listed in the most common case, but possibly 4 or 6. -! -! I should see to it that the underlying distance routine always returns -! one of the endpoints if the entire line segment is at zero distance. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Output, real ( kind = 8 ) DIST, the distance between the triangle -! and the plane. -! -! Output, integer ( kind = 4 ) NEAR_NUM, the number of nearest points -! returned. -! -! Output, real ( kind = 8 ) PN(3,6), a collection of nearest points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) dist - real(kind=8) dist12 - real(kind=8) dist23 - real(kind=8) dist31 - integer(kind=4) near_num - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num, 6) - real(kind=8) pt(dim_num) - real(kind=8) t(dim_num, 3) - - near_num = 0 -! -! Consider the line segment P1 - P2. -! - call plane_imp_segment_near_3d(t(1:dim_num, 1), t(1:dim_num, 2), & - a, b, c, d, dist12, p, pt) - - dist = dist12 - - near_num = near_num + 1 - pn(1:dim_num, near_num) = pt(1:dim_num) - - if (0.0D+00 < dist12) then - near_num = near_num + 1 - pn(1:dim_num, near_num) = p(1:dim_num) - end if -! -! Consider the line segment P2 - P3. -! - call plane_imp_segment_near_3d(t(1:dim_num, 2), t(1:dim_num, 3), & - a, b, c, d, dist23, p, pt) - - if (dist23 < dist) then - - near_num = 0 - dist = dist23 - - near_num = near_num + 1 - pn(1:dim_num, near_num) = pt(1:dim_num) - - if (0.0D+00 < dist23) then - near_num = near_num + 1 - pn(1:dim_num, near_num) = p(1:dim_num) - end if - - else if (dist23 == dist) then - - near_num = near_num + 1 - pn(1:dim_num, near_num) = pt(1:dim_num) - - if (0.0D+00 < dist23) then - near_num = near_num + 1 - pn(1:dim_num, near_num) = p(1:dim_num) - end if - - end if -! -! Consider the line segment P3 - P1. -! - call plane_imp_segment_near_3d(t(1:dim_num, 3), t(1:dim_num, 1), & - a, b, c, d, dist31, p, pt) - - if (dist31 < dist) then - - near_num = 0 - dist = dist31 - - near_num = near_num + 1 - pn(1:dim_num, near_num) = pt(1:dim_num) - - if (0.0D+00 < dist31) then - near_num = near_num + 1 - pn(1:dim_num, near_num) = p(1:dim_num) - end if - - else if (dist31 == dist) then - - near_num = near_num + 1 - pn(1:dim_num, near_num) = pt(1:dim_num) - - if (0.0D+00 < dist31) then - near_num = near_num + 1 - pn(1:dim_num, near_num) = p(1:dim_num) - end if - - end if - - return -end -subroutine plane_imp2exp_3d(a, b, c, d, p1, p2, p3) - -!*****************************************************************************80 -! -!! PLANE_IMP2EXP_3D converts an implicit plane to explicit form in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is -! -! A * X + B * Y + C * Z + D = 0. -! -! The explicit form of a plane in 3D is -! -! the plane through P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Output, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) normal(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pp(dim_num) - - call plane_imp2normal_3d(a, b, c, d, pp, normal) - - call plane_normal2exp_3d(pp, normal, p1, p2, p3) - - return -end -subroutine plane_imp2normal_3d(a, b, c, d, pp, normal) - -!*****************************************************************************80 -! -!! PLANE_IMP2NORMAL_3D converts an implicit plane to normal form in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is -! -! A * X + B * Y + C * Z + D = 0. -! -! The normal form of a plane in 3D is -! -! PP, a point on the plane, and -! N, the unit normal to the plane. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! -! Output, real ( kind = 8 ) PP(3), a point on the plane. -! -! Output, real ( kind = 8 ) NORMAL(3), the unit normal vector to the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) norm - real(kind=8) normal(dim_num) - real(kind=8) pp(dim_num) - - norm = sqrt(a * a + b * b + c * c) - - if (norm == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP2NORMAL_3D - Fatal error!' - write (*, '(a)') ' The plane (A,B,C) has zero norm.' - stop 1 - end if - - normal(1) = a / norm - normal(2) = b / norm - normal(3) = c / norm - - if (a /= 0.0D+00) then - pp(1) = -d / a - pp(2) = 0.0D+00 - pp(3) = 0.0D+00 - else if (b /= 0.0D+00) then - pp(1) = 0.0D+00 - pp(2) = -d / b - pp(3) = 0.0D+00 - else if (c /= 0.0D+00) then - pp(1) = 0.0D+00 - pp(2) = 0.0D+00 - pp(3) = -d / c - else - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_IMP2NORMAL_3D - Fatal error!' - write (*, '(a)') ' The (A,B,C) vector is null.' - stop 1 - end if - - return -end -subroutine plane_normal_basis_3d(pp, normal, pq, pr) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_BASIS_3D finds two perpendicular vectors in a plane in 3D. -! -! Discussion: -! -! The normal form of a plane in 3D is: -! -! PP is a point on the plane, -! N is a normal vector to the plane. -! -! The two vectors to be computed, PQ and PR, can be regarded as -! the basis of a Cartesian coordinate system for points in the plane. -! Any point in the plane can be described in terms of the "origin" -! point PP plus a weighted sum of the two vectors PQ and PR: -! -! P = PP + a * PQ + b * PR. -! -! The vectors PQ and PR have unit length, and are perpendicular to N -! and to each other. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. (Actually, -! we never need to know these values to do the calculation!) -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The -! vector must not have zero length, but it is not necessary for N -! to have unit length. -! -! Output, real ( kind = 8 ) PQ(3), a vector of unit length, -! perpendicular to the vector N and the vector PR. -! -! Output, real ( kind = 8 ) PR(3), a vector of unit length, -! perpendicular to the vector N and the vector PQ. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) r8vec_norm - real(kind=8) normal(dim_num) - real(kind=8) normal_norm - real(kind=8) pp(dim_num) - real(kind=8) pq(dim_num) - real(kind=8) pr(dim_num) - real(kind=8) pr_norm -! -! Compute the length of NORMAL. -! - normal_norm = r8vec_norm(dim_num, normal) - - if (normal_norm == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_NORMAL_BASIS_3D - Fatal error!' - write (*, '(a)') ' The normal vector is 0.' - stop 1 - end if -! -! Find a vector PQ that is normal to NORMAL and has unit length. -! - call r8vec_any_normal(dim_num, normal, pq) -! -! Now just take the cross product NORMAL x PQ to get the PR vector. -! - call r8vec_cross_product_3d(normal, pq, pr) - - pr_norm = r8vec_norm(dim_num, pr) - - pr(1:dim_num) = pr(1:dim_num) / pr_norm - - return -end - -subroutine plane_normal_line_exp_int_3d(pp, normal, p1, p2, ival, pint) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_LINE_EXP_INT_3D: intersection of plane and line in 3D. -! -! Discussion: -! -! The normal form of a plane in 3D is: -! -! PP is a point on the plane, -! N is a normal vector to the plane. -! -! The explicit form of a line in 3D is: -! -! P1, P2 are two points on the line. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. -! -! Input, real ( kind = 8 ) P1(3), P2(3), two distinct points on the line. -! -! Output, integer ( kind = 4 ) IVAL, the kind of intersection; -! 0, the line and plane seem to be parallel and separate; -! 1, the line and plane intersect at a single point; -! 2, the line and plane seem to be parallel and joined. -! -! Output, real ( kind = 8 ) PINT(3), the coordinates of a -! common point of the plane and line, when IVAL is 1 or 2. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) direction(dim_num) - integer(kind=4) ival - logical(kind=4) line_exp_is_degenerate_nd - real(kind=8) normal(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pint(dim_num) - real(kind=8) pp(dim_num) - real(kind=8) temp -! -! Make sure the line is not degenerate. -! - if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_NORMAL_LINE_EXP_INT_3D - Fatal error!' - write (*, '(a)') ' The line is degenerate.' - stop 1 - end if -! -! Make sure the plane normal vector is a unit vector. -! - temp = sqrt(sum(normal(1:dim_num)**2)) - - if (temp == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'PLANE_NORMAL_LINE_EXP_INT_3D - Fatal error!' - write (*, '(a)') ' The normal vector of the plane is degenerate.' - stop 1 - end if - - normal(1:dim_num) = normal(1:dim_num) / temp -! -! Determine the unit direction vector of the line. -! - direction(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - temp = sqrt(sum(direction(1:dim_num)**2)) - direction(1:dim_num) = direction(1:dim_num) / temp -! -! If the normal and direction vectors are orthogonal, then -! we have a special case to deal with. -! - if (dot_product(normal(1:dim_num), direction(1:dim_num)) == 0.0D+00) then - - temp = dot_product(normal(1:dim_num), p1(1:dim_num) - pp(1:dim_num)) - - if (temp == 0.0D+00) then - ival = 2 - pint(1:dim_num) = p1(1:dim_num) - else - ival = 0 - pint(1:dim_num) = huge(temp) - end if - - return - end if -! -! Determine the distance along the direction vector to the intersection point. -! - temp = dot_product(pp(1:dim_num) - p1(1:dim_num), normal(1:dim_num)) & - / dot_product(direction(1:dim_num), normal(1:dim_num)) - - ival = 1 - pint(1:dim_num) = p1(1:dim_num) + temp * direction(1:dim_num) - - return -end -subroutine plane_normal_qr_to_xyz(pp, normal, pq, pr, n, qr, xyz) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_QR_TO_XYZ: QR_TO_XYZ coordinates for a normal form plane. -! -! Discussion: -! -! The normal form of a plane in 3D is: -! -! PP is a point on the plane, -! NORMAL is a normal vector to the plane. -! -! Two vectors PQ and PR can be computed with the properties that -! * NORMAL, PQ and PR are pairwise orthogonal; -! * PQ and PR have unit length; -! * every point P in the plane has a "QR" representation -! as P = PP + q * PQ + r * PR. -! -! This function is given the QR coordinates of a set of points on the -! plane, and returns the XYZ coordinates. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The -! vector must not have zero length, but it is not necessary for N -! to have unit length. -! -! Input, real ( kind = 8 ) PQ(3), a vector of unit length, -! perpendicular to the vector N and the vector PR. -! -! Input, real ( kind = 8 ) PR(3), a vector of unit length, -! perpendicular to the vector N and the vector PQ. -! -! Input, integer ( kind = 4 ) N, the number of points on the plane. -! -! Input, real ( kind = 8 ) QR(2,N), the QR coordinates of the points. -! -! Output, real ( kind = 8 ) XYZ(3,N), the XYZ coordinates of the points. -! - implicit none - - integer(kind=4) n - - real(kind=8) normal(3) - real(kind=8) pp(3) - real(kind=8) pq(3) - real(kind=8) pqpr(3, 2) - real(kind=8) pr(3) - real(kind=8) qr(2, n) - real(kind=8) xyz(3, n) - - xyz(1, 1:n) = pp(1) - xyz(2, 1:n) = pp(2) - xyz(3, 1:n) = pp(3) - - pqpr(1:3, 1) = pq(1:3) - pqpr(1:3, 2) = pr(1:3) - - xyz(1:3, 1:n) = xyz(1:3, 1:n) + matmul(pqpr(1:3, 1:2), qr(1:2, 1:n)) - - return -end -subroutine plane_normal_tetrahedron_intersect(pp, normal, t, int_num, pint) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_TETRAHEDRON_INTERSECT intersects a plane and a tetrahedron. -! -! Discussion: -! -! The intersection of a plane and a tetrahedron is one of: -! 0) empty -! 1) a single point -! 2) a single line segment -! 3) a triangle -! 4) a quadrilateral. -! -! In each case, the region of intersection can be described by the -! corresponding number of points. In particular, cases 2, 3 and 4 -! are described by the vertices that bound the line segment, triangle, -! or quadrilateral. -! -! The normal form of a plane is: -! -! PP is a point on the plane, -! N is a normal vector to the plane. -! -! The form of a tetrahedron is -! -! T(1:3,1:4) contains the coordinates of the vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 June 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. -! -! Input, real ( kind = 8 ) T(3,4), the tetrahedron vertices. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersection -! points returned. This will be 0, 1, 2, 3 or 4. -! -! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the -! intersection points. -! - implicit none - - real(kind=8) area1 - real(kind=8) area2 - real(kind=8) d(4) - real(kind=8) dn - real(kind=8) dpp - integer(kind=4) int_num - integer(kind=4) j1 - integer(kind=4) j2 - real(kind=8) normal(3) - real(kind=8) pint(3, 4) - real(kind=8) pp(3) - logical(kind=4) r8_sign_opposite_strict - real(kind=8) t(3, 4) - real(kind=8) temp(3) - - int_num = 0 - pint(1:3, 1:4) = 0.0D+00 -! -! DN is the length of the normal vector. -! - dn = dot_product(normal(1:3), normal(1:3)) -! -! DPP is the distance between the origin and the projection of the -! point PP onto the normal vector. -! - dpp = dn - dot_product(normal(1:3), pp(1:3)) -! -! D(I) is positive, zero, or negative if vertex I is above, -! on, or below the plane. -! - d(1:4) = dn - matmul(normal(1:3), t(1:3, 1:4)) - dpp -! -! If all D are positive or negative, no intersection. -! - if (all(d(1:4) < 0.0D+00) .or. all(0.0D+00 < d(1:4))) then - int_num = 0 - return - end if -! -! Points with zero distance are automatically added to the list. -! -! For each point with nonzero distance, seek another point -! with opposite sign and higher index, and compute the intersection -! of the line between those points and the plane. -! - do j1 = 1, 4 - - if (d(j1) == 0.0D+00) then - int_num = int_num + 1 - pint(1:3, int_num) = t(1:3, j1) - else - do j2 = j1 + 1, 4 - if (r8_sign_opposite_strict(d(j1), d(j2))) then - int_num = int_num + 1 - pint(1:3, int_num) = (d(j1) * t(1:3, j2) & - - d(j2) * t(1:3, j1)) & - / (d(j1) - d(j2)) - end if - end do - end if - end do -! -! If four points were found, try to order them properly. -! - if (int_num == 4) then - call quad_area_3d(pint, area1) - temp(1:3) = pint(1:3, 3) - pint(1:3, 3) = pint(1:3, 4) - pint(1:3, 4) = temp(1:3) - call quad_area_3d(pint, area2) - if (area2 < area1) then - temp(1:3) = pint(1:3, 3) - pint(1:3, 3) = pint(1:3, 4) - pint(1:3, 4) = temp(1:3) - end if - end if - - return -end -subroutine plane_normal_triangle_int_3d(pp, normal, t, int_num, pint) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_TRIANGLE_INT_3D: intersection ( normal plane, triangle ) in 3D. -! -! Discussion: -! -! The normal form of a plane in 3D is: -! -! PP is a point on the plane, -! N is a normal vector to the plane. -! -! There may be 0, 1, 2 or 3 points of intersection returned. -! -! If two intersection points are returned, then the entire line -! between them comprises points of intersection. -! -! If three intersection points are returned, then all points of -! the triangle intersect the plane. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 May 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. -! -! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. -! -! Output, integer ( kind = 4 ) INT_NUM, the number of intersection -! points returned. -! -! Output, real ( kind = 8 ) PINT(3,3), the coordinates of the -! intersection points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) d - real(kind=8) dist1 - real(kind=8) dist2 - real(kind=8) dist3 - real(kind=8) normal(dim_num) - integer(kind=4) int_num - real(kind=8) pint(dim_num, 3) - real(kind=8) pp(dim_num) - real(kind=8) t(dim_num, 3) - - int_num = 0 -! -! Compute the signed distances between the vertices and the plane. -! - d = -dot_product(normal(1:dim_num), pp(1:dim_num)) - - dist1 = dot_product(normal(1:dim_num), t(1:dim_num, 1)) + d - dist2 = dot_product(normal(1:dim_num), t(1:dim_num, 2)) + d - dist3 = dot_product(normal(1:dim_num), t(1:dim_num, 3)) + d -! -! Consider any zero distances. -! - if (dist1 == 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 1) - - end if - - if (dist2 == 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 2) - - end if - - if (dist3 == 0.0D+00) then - - int_num = int_num + 1 - pint(1:dim_num, int_num) = t(1:dim_num, 3) - - end if -! -! If 2 or 3 of the nodes intersect, we're already done. -! - if (2 <= int_num) then - return - end if -! -! If one node intersects, then we're done unless the other two -! are of opposite signs. -! - if (int_num == 1) then - - if (dist1 == 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & - dist2, dist3, int_num, pint) - - else if (dist2 == 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & - dist1, dist3, int_num, pint) - - else if (dist3 == 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & - dist1, dist2, int_num, pint) - - end if - - return - - end if -! -! All nodal distances are nonzero, and there is at least one -! positive and one negative. -! - if (dist1 * dist2 < 0.0D+00 .and. dist1 * dist3 < 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & - dist1, dist2, int_num, pint) - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & - dist1, dist3, int_num, pint) - - else if (dist2 * dist1 < 0.0D+00 .and. dist2 * dist3 < 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 1), & - dist2, dist1, int_num, pint) - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & - dist2, dist3, int_num, pint) - - else if (dist3 * dist1 < 0.0D+00 .and. dist3 * dist2 < 0.0D+00) then - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 1), & - dist3, dist1, int_num, pint) - - call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 2), & - dist3, dist2, int_num, pint) - - end if - - return -end -subroutine plane_normal_uniform_3d(seed, pp, normal) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_UNIFORM_3D generates a random normal plane in 3D. -! -! Discussion: -! -! The normal form of a plane is: -! -! PP is a point on the plane, -! N is a normal vector to the plane. -! -! The point PP will be chosen at random inside the unit sphere. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 November 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, real ( kind = 8 ) PP(3), a point on the plane. -! -! Output, real ( kind = 8 ) NORMAL(3), the unit normal vector. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) norm - real(kind=8) normal(dim_num) - real(kind=8) pp(dim_num) - integer(kind=4) seed -! -! Pick PP as a random point inside the unit sphere in ND. -! - call ball01_sample_3d(seed, pp) -! -! Get values from a standard normal distribution. -! - call r8vec_normal_01(dim_num, seed, normal) -! -! Compute the length of the vector. -! - norm = sqrt(sum(normal(1:dim_num)**2)) -! -! Normalize the vector. -! - normal(1:dim_num) = normal(1:dim_num) / norm - - return -end -subroutine plane_normal_uniform_nd(dim_num, seed, pp, normal) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_UNIFORM_ND generates a random normal plane in ND. -! -! Discussion: -! -! The normal form of a plane is: -! -! PP is a point on the plane, -! N is a normal vector to the plane. -! -! The point PP will be chosen at random inside the unit sphere. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 November 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, real ( kind = 8 ) PP(DIM_NUM), a point on the plane. -! -! Output, real ( kind = 8 ) NORMAL(DIM_NUM), the unit normal vector. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) norm - real(kind=8) normal(dim_num) - real(kind=8) pp(dim_num) - integer(kind=4) seed -! -! Pick PP as a random point inside the unit sphere in ND. -! - call ball01_sample_nd(dim_num, seed, pp) -! -! Get values from a standard normal distribution. -! - call r8vec_normal_01(dim_num, seed, normal) -! -! Compute the length of the vector. -! - norm = sqrt(sum(normal(1:dim_num)**2)) -! -! Normalize the vector. -! - normal(1:dim_num) = normal(1:dim_num) / norm - - return -end -subroutine plane_normal_xyz_to_qr(pp, normal, pq, pr, n, xyz, qr) - -!*****************************************************************************80 -! -!! PLANE_NORMAL_XYZ_TO_QR: XYZ to QR coordinates for a normal form plane. -! -! Discussion: -! -! The normal form of a plane in 3D is: -! -! PP is a point on the plane, -! NORMAL is a normal vector to the plane. -! -! Two vectors PQ and PR can be computed with the properties that -! * NORMAL, PQ and PR are pairwise orthogonal; -! * PQ and PR have unit length; -! * every point P in the plane has a "QR" representation -! as P = PP + q * PQ + r * PR. -! -! This function is given the XYZ coordinates of a set of points on the -! plane, and returns the QR coordinates. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2015 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The -! vector must not have zero length, but it is not necessary for N -! to have unit length. -! -! Input, real ( kind = 8 ) PQ(3), a vector of unit length, -! perpendicular to the vector N and the vector PR. -! -! Input, real ( kind = 8 ) PR(3), a vector of unit length, -! perpendicular to the vector N and the vector PQ. -! -! Input, integer ( kind = 4 ) N, the number of points on the plane. -! -! Input, real ( kind = 8 ) XYZ(3,N), the XYZ coordinates of the points. -! -! Output, real ( kind = 8 ) QR(2,N), the QR coordinates of the points. -! - implicit none - - integer(kind=4) n - - real(kind=8) normal(3) - real(kind=8) pp(3) - real(kind=8) pq(3) - real(kind=8) pr(3) - real(kind=8) qr(2, n) - real(kind=8) rpqp(2, 3) - real(kind=8) xyz(3, n) - - rpqp(1, 1:3) = pq(1:3) - rpqp(2, 1:3) = pr(1:3) - - qr(1:2, 1:n) = matmul(rpqp(1:2, 1:3), xyz(1:3, 1:n)) - - qr(1, 1:n) = qr(1, 1:n) - dot_product(pq(1:3), pp(1:3)) - qr(2, 1:n) = qr(2, 1:n) - dot_product(pr(1:3), pp(1:3)) - - return -end -subroutine plane_normal2exp_3d(pp, normal, p1, p2, p3) - -!*****************************************************************************80 -! -!! PLANE_NORMAL2EXP_3D converts a normal plane to explicit form in 3D. -! -! Discussion: -! -! The normal form of a plane in 3D is -! -! PP, a point on the plane, and -! N, the unit normal to the plane. -! -! The explicit form of a plane in 3D is -! -! the plane through P1, P2 and P3. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The -! vector must not have zero length, but it is not necessary for N -! to have unit length. -! -! Output, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) normal(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pp(dim_num) - real(kind=8) pq(dim_num) - real(kind=8) pr(dim_num) - - call plane_normal_basis_3d(pp, normal, pq, pr) - - p1(1:dim_num) = pp(1:dim_num) - p2(1:dim_num) = pp(1:dim_num) + pq(1:dim_num) - p3(1:dim_num) = pp(1:dim_num) + pr(1:dim_num) - - return -end -subroutine plane_normal2imp_3d(pp, normal, a, b, c, d) - -!*****************************************************************************80 -! -!! PLANE_NORMAL2IMP_3D converts a normal form plane to implicit form in 3D. -! -! Discussion: -! -! The normal form of a plane in 3D is -! -! PP, a point on the plane, and -! N, the unit normal to the plane. -! -! The implicit form of a plane in 3D is -! -! A * X + B * Y + C * Z + D = 0. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PP(3), a point on the plane. -! -! Input, real ( kind = 8 ) NORMAL(3), the unit normal vector to the plane. -! -! Output, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) normal(dim_num) - real(kind=8) pp(dim_num) - - a = normal(1) - b = normal(2) - c = normal(3) - d = -a * pp(1) - b * pp(2) - c * pp(3) - - return -end -subroutine planes_imp_angle_3d(a1, b1, c1, d1, a2, b2, c2, d2, angle) - -!*****************************************************************************80 -! -!! PLANES_IMP_ANGLE_3D: dihedral angle between implicit planes in 3D. -! -! Discussion: -! -! The implicit form of a plane in 3D is: -! -! A * X + B * Y + C * Z + D = 0 -! -! If two planes P1 and P2 intersect in a nondegenerate way, then there is a -! line of intersection L0. Consider any plane perpendicular to L0. The -! dihedral angle of P1 and P2 is the angle between the lines L1 and L2, where -! L1 is the intersection of P1 and P0, and L2 is the intersection of P2 -! and P0. -! -! The dihedral angle may also be calculated as the angle between the normal -! vectors of the two planes. Note that if the planes are parallel or -! coincide, the normal vectors are identical, and the dihedral angle is 0. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 September 2003 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Daniel Zwillinger, editor, -! CRC Standard Math Tables and Formulae, 30th edition, -! Section 4.13, "Planes", -! CRC Press, 1996, pages 305-306. -! -! Parameters: -! -! Input, real ( kind = 8 ) A1, B1, C1, D1, coefficients that define the -! first plane. -! -! Input, real ( kind = 8 ) A2, B2, C2, D2, coefficients that define -! the second plane. -! -! Output, real ( kind = 8 ) ANGLE, the dihedral angle, in radians, -! defined by the two planes. If either plane is degenerate, or they -! do not intersect, or they coincide, then the angle is set to HUGE(1.0). -! Otherwise, the angle is between 0 and PI. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a1 - real(kind=8) a2 - real(kind=8) angle - real(kind=8) b1 - real(kind=8) b2 - real(kind=8) c1 - real(kind=8) c2 - real(kind=8) cosine - real(kind=8) d1 - real(kind=8) d2 - real(kind=8) norm1 - real(kind=8) norm2 - real(kind=8) r8_acos - - norm1 = sqrt(a1 * a1 + b1 * b1 + c1 * c1) - - if (norm1 == 0.0D+00) then - angle = huge(angle) - return - end if - - norm2 = sqrt(a2 * a2 + b2 * b2 + c2 * c2) - - if (norm2 == 0.0D+00) then - angle = huge(angle) - return - end if - - cosine = (a1 * a2 + b1 * b2 + c1 * c2) / (norm1 * norm2) - - angle = r8_acos(cosine) - - return -end -function points_avoid_point_naive_2d(n, p_set, p) - -!*****************************************************************************80 -! -!! POINTS_AVOID_POINT_NAIVE_2D: is a point "far" from a set of points in 2D? -! -! Discussion: -! -! The routine discards points that are too close to other points. -! The method used to check this is quadratic in the number of points, -! and may take an inordinate amount of time if there are a large -! number of points. But in that case, what do you want? If you want -! lots of points, you don't want to delete any because it won't matter. -! -! The test point is "far enough" from an accepted point if -! the Euclidean distance is at least 100 times EPSILON. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 February 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of accepted points. -! -! Input, real ( kind = 8 ) P_SET(2,N), the accepted points. -! -! Input, real ( kind = 8 ) P(2), a point to be tested. -! -! Output, logical ( kind = 4 ) POINTS_AVOID_POINT_NAIVE_2D, is TRUE if -! XY_TEST is "far enough" from all the accepted points. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) j - real(kind=8) p(dim_num) - real(kind=8) p_set(dim_num, n) - logical(kind=4) points_avoid_point_naive_2d - real(kind=8) tol - - tol = 100.0D+00 * epsilon(tol) - - points_avoid_point_naive_2d = .true. - - do j = 1, n - - if (sqrt(sum((p_set(1:dim_num, j) - p(1:dim_num))**2)) < tol) then - points_avoid_point_naive_2d = .false. - return - end if - - end do - - return -end -subroutine points_bisect_line_imp_2d(p1, p2, a, b, c) - -!*****************************************************************************80 -! -!! POINTS_BISECT_LINE_IMP_2D: implicit bisector line between two points in 2D. -! -! Discussion: -! -! This routine finds, in implicit form, the equation of the line -! that is equidistant from two points. -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 January 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the coordinates of two points. -! -! Output, real ( kind = 8 ) A, B, C, the parameters of the implicit line -! equidistant from both points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - a = p1(1) - p2(1) - b = p1(2) - p2(2) - c = -0.5D+00 * ((p1(1) * p1(1) + p1(2) * p1(2)) & - - (p2(1) * p2(1) + p2(2) * p2(2))) - - return -end -subroutine points_bisect_line_par_2d(p1, p2, f, g, x, y) - -!*****************************************************************************80 -! -!! POINTS_BISECT_LINE_PAR_2D: parametric bisector line between points in 2D. -! -! Discussion: -! -! This routine finds, in parametric form, the equation of the line -! that is equidistant from two points. -! -! The parametric form of a line in 2D is: -! -! X = X0 + F * T -! Y = Y0 + G * T -! -! We normalize by always choosing F*F + G*G = 1, and F nonnegative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points. -! -! Output, real ( kind = 8 ) F, G, X, Y, the parameters of the parametric line -! equidistant from both points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) f - real(kind=8) g - real(kind=8) norm - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) x - real(kind=8) y - - f = 0.5D+00 * (p1(1) + p2(1)) - g = 0.5D+00 * (p1(2) + p2(2)) - - norm = f * f + g * g - - if (norm /= 0.0D+00) then - f = f / norm - g = g / norm - end if - - if (f < 0.0D+00) then - f = -f - g = -g - end if - - x = -(p2(2) - p1(2)) - y = +(p2(1) - p1(1)) - - return -end -subroutine points_centroid_2d(n, p, centroid_index) - -!*****************************************************************************80 -! -!! POINTS_CENTROID_2D computes the discrete centroid of a point set in 2D. -! -! Discussion: -! -! Given a discrete set of points S, the discrete centroid z is defined by -! -! sum ( x in S ) ( x - z )^2 -! = min ( y in S ) { sum ( x in S ) ( x - y )^2 -! -! In other words, the discrete centroid is a point in the set whose distance -! to the other points is minimized. The discrete centroid of a point set -! need not be unique. Consider a point set that comprises the -! vertices of an equilateral triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of points. -! -! Input, real ( kind = 8 ) P(2,N), the points. -! -! Output, integer ( kind = 4 ) CENTROID_INDEX, the index of a discrete -! centroid of the set, between 1 and N. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) centroid_index - real(kind=8) dist - real(kind=8) dist_min - integer(kind=4) i - integer(kind=4) j - real(kind=8) p(dim_num, n) - - dist_min = 0.0D+00 - centroid_index = -1 - - do i = 1, n - - dist = 0.0D+00 - do j = 1, n - dist = dist + sum((p(1:dim_num, i) - p(1:dim_num, j))**2) - end do - - if (i == 1) then - dist_min = dist - centroid_index = i - else if (dist < dist_min) then - dist_min = dist - centroid_index = i - end if - - end do - - return -end -subroutine points_colin_2d(p1, p2, p3, colin) - -!*****************************************************************************80 -! -!! POINTS_COLIN_2D estimates the colinearity of 3 points in 2D. -! -! Discussion: -! -! The estimate of colinearity that is returned is the ratio -! of the area of the triangle spanned by the points to the area -! of the equilateral triangle with the same perimeter. -! -! This estimate is 1 if the points are maximally noncolinear, 0 if the -! points are exactly colinear, and otherwise is closer to 1 or 0 depending -! on whether the points are far or close to colinearity. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 October 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the points. -! -! Output, real ( kind = 8 ) COLIN, the colinearity estimate. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area_triangle - real(kind=8) area2 - real(kind=8) colin - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) perim - real(kind=8) side - real(kind=8) t(dim_num, 3) - - t(1:dim_num, 1:3) = reshape((/ & - p1(1:dim_num), p2(1:dim_num), p3(1:dim_num)/), (/dim_num, 3/)) - - call triangle_area_2d(t, area_triangle) - - if (area_triangle == 0.0D+00) then - - colin = 0.0D+00 - - else - - perim = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) & - + sqrt(sum((p3(1:dim_num) - p2(1:dim_num))**2)) & - + sqrt(sum((p1(1:dim_num) - p3(1:dim_num))**2)) - - side = perim / 3.0D+00 - - area2 = 0.25D+00 * sqrt(3.0D+00) * side * side - - colin = abs(area_triangle) / area2 - - end if - - return -end -subroutine points_colin_3d(p1, p2, p3, colin) - -!*****************************************************************************80 -! -!! POINTS_COLIN_3D estimates the colinearity of 3 points in 3D. -! -! Discussion: -! -! The estimate of colinearity that is returned is the ratio -! of the area of the triangle spanned by the points to the area -! of the equilateral triangle with the same perimeter. -! -! This estimate is 1 if the points are maximally noncolinear, 0 if the -! points are exactly colinear, and otherwise is closer to 1 or 0 depending -! on whether the points are far or close to colinearity. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), the points. -! -! Output, real ( kind = 8 ) COLIN, the colinearity estimate. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) area_triangle - real(kind=8) area2 - real(kind=8) colin - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) perim - real(kind=8) side - real(kind=8) t(dim_num, 3) - - t(1:dim_num, 1:3) = reshape((/ & - p1(1:dim_num), p2(1:dim_num), p3(1:dim_num)/), (/dim_num, 3/)) - - call triangle_area_3d(t, area_triangle) - - if (area_triangle == 0.0D+00) then - - colin = 0.0D+00 - - else - - perim = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) & - + sqrt(sum((p3(1:dim_num) - p2(1:dim_num))**2)) & - + sqrt(sum((p1(1:dim_num) - p3(1:dim_num))**2)) - - side = perim / 3.0D+00 - - area2 = 0.25D+00 * sqrt(3.0D+00) * side * side - - colin = abs(area_triangle) / area2 - - end if - - return -end -subroutine points_dist_nd(dim_num, p1, p2, dist) - -!*****************************************************************************80 -! -!! POINTS_DIST_ND finds the distance between two points in ND. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), the coordinates -! of two points. -! -! Output, real ( kind = 8 ) DIST, the distance between the points. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) dist - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - - dist = sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) - - return -end -subroutine points_hull_2d(node_num, node_xy, hull_num, hull) - -!*****************************************************************************80 -! -!! POINTS_HULL_2D computes the convex hull of 2D points. -! -! Discussion: -! -! The work involved is N*log(H), where N is the number of points, and H is -! the number of points that are on the hull. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 June 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of nodes. -! -! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of the nodes. -! -! Output, integer ( kind = 4 ) HULL_NUM, the number of nodes that lie on -! the convex hull. -! -! Output, integer ( kind = 4 ) HULL(NODE_NUM). Entries 1 through HULL_NUM -! contain the indices of the nodes that form the convex hull, in order. -! - implicit none - - integer(kind=4) node_num - - real(kind=8) angle - real(kind=8) angle_max - real(kind=8) angle_rad_2d - real(kind=8) di - real(kind=8) dr - integer(kind=4) first - integer(kind=4) hull(node_num) - integer(kind=4) hull_num - integer(kind=4) i - real(kind=8) node_xy(2, node_num) - real(kind=8) p_xy(2) - integer(kind=4) q - real(kind=8) q_xy(2) - integer(kind=4) r - real(kind=8) r_xy(2) - - if (node_num < 1) then - hull_num = 0 - return - end if -! -! If NODE_NUM = 1, the hull is the point. -! - if (node_num == 1) then - hull_num = 1 - hull(1) = 1 - return - end if -! -! If NODE_NUM = 2, then the convex hull is either the two distinct points, -! or possibly a single (repeated) point. -! - if (node_num == 2) then - - if (node_xy(1, 1) /= node_xy(1, 2) .or. node_xy(2, 1) /= node_xy(2, 2)) then - hull_num = 2 - hull(1) = 1 - hull(2) = 2 - else - hull_num = 1 - hull(1) = 1 - end if - - return - - end if -! -! Find the leftmost point and call it "Q". -! In case of ties, take the bottom-most. -! - q = 1 - do i = 2, node_num - if (node_xy(1, i) < node_xy(1, q) .or. & - (node_xy(1, i) == node_xy(1, q) .and. node_xy(2, i) < node_xy(2, q))) then - q = i - end if - end do - - q_xy(1:2) = node_xy(1:2, q) -! -! Remember the starting point, so we know when to stop! -! - first = q - hull_num = 1 - hull(1) = q -! -! For the first point, make a dummy previous point, 1 unit south, -! and call it "P". -! - p_xy(1) = q_xy(1) - p_xy(2) = q_xy(2) - 1.0D+00 -! -! Now, having old point P, and current point Q, find the new point R -! so the angle PQR is maximal. -! -! Watch out for the possibility that the two nodes are identical. -! - do - - r = 0 - angle_max = 0.0D+00 - - do i = 1, node_num - - if (i /= q .and. & - (node_xy(1, i) /= q_xy(1) .or. node_xy(2, i) /= q_xy(2))) then - - angle = angle_rad_2d(p_xy, q_xy, node_xy(1:2, i)) - - if (r == 0 .or. angle_max < angle) then - - r = i - r_xy(1:2) = node_xy(1:2, r) - angle_max = angle -! -! In case of ties, choose the nearer point. -! - else if (r /= 0 .and. angle == angle_max) then - - di = (node_xy(1, i) - q_xy(1))**2 + (node_xy(2, i) - q_xy(2))**2 - dr = (r_xy(1) - q_xy(1))**2 + (r_xy(2) - q_xy(2))**2 - - if (di < dr) then - r = i - r_xy(1:2) = node_xy(1:2, r) - angle_max = angle - end if - - end if - - end if - - end do -! -! We are done when we have returned to the first point on the convex hull. -! - if (r == first) then - exit - end if - - hull_num = hull_num + 1 - - if (node_num < hull_num) then - write (*, '(a)') ' ' - write (*, '(a)') 'POINTS_HULL_2D - Fatal error!' - write (*, '(a)') ' The algorithm has failed.' - stop 1 - end if -! -! Add point R to convex hull. -! - hull(hull_num) = r -! -! Set P := Q, Q := R, and prepare to search for next point R. -! - q = r - - p_xy(1:2) = q_xy(1:2) - q_xy(1:2) = r_xy(1:2) - - end do - - return -end -subroutine points_plot(file_name, node_num, node_xy, node_label) - -!*****************************************************************************80 -! -!! POINTS_PLOT plots a pointset. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, character ( len = * ) FILE_NAME, the name of the output file. -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of points. -! -! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the nodes. -! -! Input, logical ( kind = 4 ) NODE_LABEL, is TRUE if the nodes should -! be labeled. -! -! Local parameters: -! -! Local, integer CIRCLE_SIZE, controls the size of the circles depicting -! the nodes, measured in PostScript points (1/72 of an inch). -! Currently set to 5. 3 is pretty small, and 1 is barely visible. -! - implicit none - - integer(kind=4) node_num - - integer(kind=4), parameter :: circle_size = 5 - integer(kind=4) delta - character(len=*) file_name - integer(kind=4) file_unit - integer(kind=4) ios - integer(kind=4) node - logical(kind=4) node_label - real(kind=8) node_xy(2, node_num) - character(len=40) string - real(kind=8) x_max - real(kind=8) x_min - integer(kind=4) x_ps - integer(kind=4) :: x_ps_max = 576 - integer(kind=4) :: x_ps_max_clip = 594 - integer(kind=4) :: x_ps_min = 36 - integer(kind=4) :: x_ps_min_clip = 18 - real(kind=8) x_scale - real(kind=8) y_max - real(kind=8) y_min - integer(kind=4) y_ps - integer(kind=4) :: y_ps_max = 666 - integer(kind=4) :: y_ps_max_clip = 684 - integer(kind=4) :: y_ps_min = 126 - integer(kind=4) :: y_ps_min_clip = 108 - real(kind=8) y_scale -! -! We need to do some figuring here, so that we can determine -! the range of the data, and hence the height and width -! of the piece of paper. -! - x_max = maxval(node_xy(1, 1:node_num)) - x_min = minval(node_xy(1, 1:node_num)) - x_scale = x_max - x_min - - x_max = x_max + 0.05D+00 * x_scale - x_min = x_min - 0.05D+00 * x_scale - x_scale = x_max - x_min - - y_max = maxval(node_xy(2, 1:node_num)) - y_min = minval(node_xy(2, 1:node_num)) - y_scale = y_max - y_min - - y_max = y_max + 0.05D+00 * y_scale - y_min = y_min - 0.05D+00 * y_scale - y_scale = y_max - y_min - - if (x_scale < y_scale) then - - delta = nint(real(x_ps_max - x_ps_min, kind=8) & - * (y_scale - x_scale) / (2.0D+00 * y_scale)) - - x_ps_max = x_ps_max - delta - x_ps_min = x_ps_min + delta - - x_ps_max_clip = x_ps_max_clip - delta - x_ps_min_clip = x_ps_min_clip + delta - - x_scale = y_scale - - else if (y_scale < x_scale) then - - delta = nint(real(y_ps_max - y_ps_min, kind=8) & - * (x_scale - y_scale) / (2.0D+00 * x_scale)) - - y_ps_max = y_ps_max - delta - y_ps_min = y_ps_min + delta - - y_ps_max_clip = y_ps_max_clip - delta - y_ps_min_clip = y_ps_min_clip + delta - - y_scale = x_scale - - end if - - call get_unit(file_unit) - - open (unit=file_unit, file=file_name, status='replace', & - iostat=ios) - - if (ios /= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'POINTS_PLOT - Fatal error!' - write (*, '(a)') ' Can not open output file.' - stop 1 - end if - - write (file_unit, '(a)') '%!PS-Adobe-3.0 EPSF-3.0' - write (file_unit, '(a)') '%%Creator: points_plot.F90' - write (file_unit, '(a)') '%%Title: '//trim(file_name) - write (file_unit, '(a)') '%%Pages: 1' - write (file_unit, '(a,i3,2x,i3,2x,i3,2x,i3)') '%%BoundingBox: ', & - x_ps_min, y_ps_min, x_ps_max, y_ps_max - write (file_unit, '(a)') '%%Document-Fonts: Times-Roman' - write (file_unit, '(a)') '%%LanguageLevel: 1' - write (file_unit, '(a)') '%%EndComments' - write (file_unit, '(a)') '%%BeginProlog' - write (file_unit, '(a)') '/inch {72 mul} def' - write (file_unit, '(a)') '%%EndProlog' - write (file_unit, '(a)') '%%Page: 1 1' - write (file_unit, '(a)') 'save' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Set the RGB line color to very light gray.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '0.900 0.900 0.900 setrgbcolor' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Draw a gray border around the page.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') 'newpath' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_min, y_ps_min, ' moveto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_max, y_ps_min, ' lineto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_max, y_ps_max, ' lineto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_min, y_ps_max, ' lineto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_min, y_ps_min, ' lineto' - write (file_unit, '(a)') 'stroke' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Set the RGB line color to black.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '0.000 0.000 0.000 setrgbcolor' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Set the font and its size.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '/Times-Roman findfont' - write (file_unit, '(a)') '0.50 inch scalefont' - write (file_unit, '(a)') 'setfont' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Print a title.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% 210 702 moveto' - write (file_unit, '(a)') '% (Pointset) show' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Define a clipping polygon.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') 'newpath' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & - x_ps_min_clip, y_ps_min_clip, ' moveto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & - x_ps_max_clip, y_ps_min_clip, ' lineto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & - x_ps_max_clip, y_ps_max_clip, ' lineto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & - x_ps_min_clip, y_ps_max_clip, ' lineto' - write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & - x_ps_min_clip, y_ps_min_clip, ' lineto' - write (file_unit, '(a)') 'clip newpath' -! -! Draw the nodes. -! - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Draw filled dots at each node.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Set the RGB color to blue.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '0.000 0.150 0.750 setrgbcolor' - write (file_unit, '(a)') '%' - - do node = 1, node_num - - x_ps = int( & - ((x_max - node_xy(1, node)) * real(x_ps_min, kind=8) & - + (node_xy(1, node) - x_min) * real(x_ps_max, kind=8)) & - / (x_max - x_min)) - - y_ps = int( & - ((y_max - node_xy(2, node)) * real(y_ps_min, kind=8) & - + (node_xy(2, node) - y_min) * real(y_ps_max, kind=8)) & - / (y_max - y_min)) - - write (file_unit, '(a,i4,2x,i4,2x,i4,2x,a)') 'newpath ', x_ps, y_ps, & - circle_size, '0 360 arc closepath fill' - - end do -! -! Label the nodes. -! - if (node_label) then - - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Label the nodes:' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% Set the RGB color to darker blue.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '0.000 0.250 0.850 setrgbcolor' - write (file_unit, '(a)') '/Times-Roman findfont' - write (file_unit, '(a)') '0.20 inch scalefont' - write (file_unit, '(a)') 'setfont' - - do node = 1, node_num - - x_ps = int( & - ((x_max - node_xy(1, node)) * real(x_ps_min, kind=8) & - + (+node_xy(1, node) - x_min) * real(x_ps_max, kind=8)) & - / (x_max - x_min)) - - y_ps = int( & - ((y_max - node_xy(2, node)) * real(y_ps_min, kind=8) & - + (node_xy(2, node) - y_min) * real(y_ps_max, kind=8)) & - / (y_max - y_min)) - - write (string, '(i4)') node - string = adjustl(string) - - write (file_unit, '(i4,2x,i4,a)') x_ps, y_ps + 5, & - ' moveto ('//trim(string)//') show' - - end do - - end if - - write (file_unit, '(a)') '%' - write (file_unit, '(a)') 'restore showpage' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '% End of page.' - write (file_unit, '(a)') '%' - write (file_unit, '(a)') '%%Trailer' - write (file_unit, '(a)') '%%EOF' - close (unit=file_unit) - - return -end -subroutine points_point_near_naive_nd(dim_num, set_num, pset, p, i_min, & - dist_min) - -!*****************************************************************************80 -! -!! POINTS_POINT_NEAR_NAIVE_ND finds the nearest point to a given point in ND. -! -! Discussion: -! -! A naive algorithm is used. The distance to every point is calculated, -! in order to determine the smallest. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) SET_NUM, the number of points in the set. -! -! Input, real ( kind = 8 ) PSET(DIM_NUM,SET_NUM), the points in the set. -! -! Input, real ( kind = 8 ) P(DIM_NUM), the point whose nearest neighbor -! is sought. -! -! Output, integer ( kind = 4 ) I_MIN, the index of the nearest point in -! PSET to P. -! -! Output, real ( kind = 8 ) DIST_MIN, the distance between P(*) -! and PSET(*,I_MIN). -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) set_num - - real(kind=8) d - real(kind=8) dist_min - integer(kind=4) i - integer(kind=4) i_min - real(kind=8) p(dim_num) - real(kind=8) pset(dim_num, set_num) - - dist_min = huge(dist_min) - i_min = -1 - - do i = 1, set_num - d = sum((p(1:dim_num) - pset(1:dim_num, i))**2) - if (d < dist_min) then - dist_min = d - i_min = i - end if - end do - - dist_min = sqrt(dist_min) - - return -end -subroutine polar_to_xy(r, t, xy) - -!*****************************************************************************80 -! -!! POLAR_TO_XY converts polar coordinates to XY coordinates. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 January 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, T, the radius and angle (in radians). -! -! Output, real ( kind = 8 ) XY(2), the Cartesian coordinates. -! - implicit none - - real(kind=8) r - real(kind=8) t - real(kind=8) xy(2) - - xy(1) = r * cos(t) - xy(2) = r * sin(t) - - return -end -subroutine polygon_1_2d(n, v, result) - -!*****************************************************************************80 -! -!! POLYGON_1_2D integrates the function 1 over a polygon in 2D. -! -! Discussion: -! -! The polygon is bounded by the points (X(1:N), Y(1:N)). -! -! INTEGRAL = 0.5 * sum ( 1 <= I <= N ) -! ( X(I) + X(I-1) ) * ( Y(I) - Y(I-1) ) -! -! where X(0) and Y(0) should be replaced by X(N) and Y(N). -! -! The integral of 1 over a polygon is the area of the polygon. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 February 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! SF Bockman, -! Generalizing the Formula for Areas of Polygons to Moments, -! American Mathematical Society Monthly, -! 1989, pages 131-132. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! N should be at least 3 for a nonzero result. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices -! of the polygon. These vertices should be given in counter clockwise order. -! -! Output, real ( kind = 8 ) RESULT, the value of the integral. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - integer(kind=4) im1 - real(kind=8) result - real(kind=8) v(2, n) - - result = 0.0D+00 - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_1_2D - Fatal error!' - write (*, '(a)') ' The number of vertices must be at least 3.' - write (*, '(a,i8)') ' The input value of N = ', n - stop 1 - end if - - do i = 1, n - - if (i == 1) then - im1 = n - else - im1 = i - 1 - end if - - result = result + 0.5D+00 * (v(1, i) + v(1, im1)) * (v(2, i) - v(2, im1)) - - end do - - return -end -subroutine polygon_angles_2d(n, v, angle) - -!*****************************************************************************80 -! -!! POLYGON_ANGLES_2D computes the interior angles of a polygon in 2D. -! -! Discussion: -! -! The vertices should be listed in counter clockwise order. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 March 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! -! Input, real ( kind = 8 ) V(2,N), the vertices. -! -! Output, real ( kind = 8 ) ANGLE(N), the angles of the polygon, -! in radians. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle(n) - real(kind=8) angle_rad_2d - integer(kind=4) i - integer(kind=4) i4_wrap - integer(kind=4) im1 - integer(kind=4) ip1 - real(kind=8) v(dim_num, n) - - if (n <= 2) then - angle(1:n) = 0.0D+00 - return - end if - - do i = 1, n - - im1 = i4_wrap(i - 1, 1, n) - ip1 = i4_wrap(i + 1, 1, n) - - angle(i) = angle_rad_2d(v(1:dim_num, im1), v(1:dim_num, i), & - v(1:dim_num, ip1)) - - end do - - return -end -subroutine polygon_area_2d(n, v, area) - -!*****************************************************************************80 -! -!! POLYGON_AREA_2D computes the area of a polygon in 2D. -! -! Discussion: -! -! AREA = 1/2 * abs ( sum ( 1 <= I <= N ) X(I) * ( Y(I+1) - Y(I-1) ) ) -! where Y(0) should be replaced by Y(N), and Y(N+1) by Y(1). -! -! If the vertices are given in counter clockwise order, the area -! will be positive. If the vertices are given in clockwise order, -! the area will be negative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 October 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! -! Input, real ( kind = 8 ) V(2,N), the vertices. -! -! Output, real ( kind = 8 ) AREA, the absolute area of the polygon. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - integer(kind=4) i - integer(kind=4) i4_wrap - integer(kind=4) im1 - integer(kind=4) ip1 - real(kind=8) v(dim_num, n) - - area = 0.0D+00 - - do i = 1, n - - im1 = i4_wrap(i - 1, 1, n) - ip1 = i4_wrap(i + 1, 1, n) - - area = area + v(1, i) * (v(2, ip1) - v(2, im1)) - - end do - - area = 0.5D+00 * area - - return -end -subroutine polygon_area_2d_2(n, v, area) - -!*****************************************************************************80 -! -!! POLYGON_AREA_2D_2 computes the area of a polygon in 2D. -! -! Discussion: -! -! The area is the sum of the areas of the triangles formed by -! node N with consecutive pairs of nodes. -! -! If the vertices are given in counter clockwise order, the area -! will be positive. If the vertices are given in clockwise order, -! the area will be negative. -! -! Thanks to Martin Pineault for noticing that an earlier version -! of this routine would not correctly compute the area of a nonconvex -! polygon. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 October 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! -! Input, real ( kind = 8 ) V(2,N), the vertices. -! -! Output, real ( kind = 8 ) AREA, the absolute area of the polygon. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) area_triangle - integer(kind=4) i - real(kind=8) t(dim_num, 3) - real(kind=8) v(dim_num, n) - - area = 0.0D+00 - - do i = 1, n - 2 - - t(1:dim_num, 1:3) = reshape((/ & - v(1:dim_num, i), v(1:dim_num, i + 1), v(1:dim_num, n)/), & - (/dim_num, 3/)) - - call triangle_area_2d(t, area_triangle) - - area = area + area_triangle - - end do - - return -end -subroutine polygon_area_3d(n, v, area, normal) - -!*****************************************************************************80 -! -!! POLYGON_AREA_3D computes the area of a polygon in 3D. -! -! Discussion: -! -! The computation is not valid unless the vertices of the polygon -! lie in a plane, so that the polygon that is defined is "flat". -! -! The polygon does not have to be "regular", that is, neither its -! sides nor its angles need to be equal. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Allen Van Gelder, -! Efficient Computation of Polygon Area and Polyhedron Volume, -! Graphics Gems V, -! edited by Alan Paeth, -! AP Professional, 1995, T385.G6975. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices. -! -! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. -! The vertices should be listed in neighboring order. -! -! Output, real ( kind = 8 ) AREA, the area of the polygon. -! -! Output, real ( kind = 8 ) NORMAL(3), the unit normal vector to the polygon. -! - implicit none - - integer(kind=4) n - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) area - real(kind=8) cross(dim_num) - integer(kind=4) i - integer(kind=4) ip1 - real(kind=8) normal(dim_num) - real(kind=8) v(dim_num, n) - - normal(1:dim_num) = 0.0D+00 - - do i = 1, n - - if (i < n) then - ip1 = i + 1 - else - ip1 = 1 - end if -! -! Compute the cross product vector. -! - cross(1) = v(2, i) * v(3, ip1) - v(3, i) * v(2, ip1) - cross(2) = v(3, i) * v(1, ip1) - v(1, i) * v(3, ip1) - cross(3) = v(1, i) * v(2, ip1) - v(2, i) * v(1, ip1) - - normal(1:dim_num) = normal(1:dim_num) + cross(1:dim_num) - - end do - - area = sqrt(sum(normal(1:dim_num)**2)) - - if (area /= 0.0D+00) then - normal(1:dim_num) = normal(1:dim_num) / area - else - normal(1:dim_num) = 1.0D+00 / sqrt(real(dim_num, kind=8)) - end if - - area = 0.5D+00 * area - - return -end -subroutine polygon_area_3d_2(n, v, area) - -!*****************************************************************************80 -! -!! POLYGON_AREA_3D_2 computes the area of a polygon in 3D. -! -! Discussion: -! -! The computation is not valid unless the vertices of the polygon -! lie in a plane, so that the polygon that is defined is "flat". -! -! The polygon does not have to be "regular", that is, neither its -! sides nor its angles need to be equal. -! -! The area is computed as the sum of the areas of the triangles -! formed by the last node with consecutive pairs of nodes (1,2), -! (2,3), ..., and (N-2,N-1). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 October 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! -! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. -! -! Output, real ( kind = 8 ) AREA, the area of the polygon. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) area - real(kind=8) area_vector(dim_num) - real(kind=8) area_vector_triangle(dim_num) - integer(kind=4) j - real(kind=8) t(dim_num, 3) - real(kind=8) v(dim_num, n) - - area_vector(1:dim_num) = 0.0D+00 - - do j = 1, n - 2 - - t(1:dim_num, 1:3) = reshape((/ & - v(1:dim_num, j), v(1:dim_num, j + 1), v(1:dim_num, n)/), & - (/dim_num, 3/)) - - call triangle_area_vector_3d(t, area_vector_triangle) - - area_vector(1:dim_num) = area_vector(1:dim_num) & - + area_vector_triangle(1:dim_num) - - end do - - area = 0.5D+00 * sqrt(sum(area_vector(1:dim_num)**2)) - - return -end -subroutine polygon_centroid_2d(n, v, centroid) - -!*****************************************************************************80 -! -!! POLYGON_CENTROID_2D computes the centroid of a polygon in 2D. -! -! Discussion: -! -! Denoting the centroid coordinates by CENTROID, then -! -! CENTROID(1) = Integral ( Polygon interior ) x dx dy / Area ( Polygon ) -! CENTROID(2) = Integral ( Polygon interior ) y dx dy / Area ( Polygon ). -! -! Green's theorem states that for continuously differentiable functions -! M(x,y) and N(x,y), -! -! Integral ( Polygon boundary ) ( M dx + N dy ) = -! Integral ( Polygon interior ) ( dN/dx - dM/dy ) dx dy. -! -! Using M(x,y) = 0 and N(x,y) = x*x/2, we get: -! -! CENTROID(1) = 0.5 * Integral ( Polygon boundary ) x*x dy -! / Area ( Polygon ), -! -! which becomes -! -! CENTROID(1) = 1/6 sum ( 1 <= I <= N ) -! ( X(I+1) + X(I) ) * ( X(I) * Y(I+1) - X(I+1) * Y(I)) -! / Area ( Polygon ) -! -! where, when I = N, the index "I+1" is replaced by 1. -! -! A similar calculation gives us a formula for CENTROID(2). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 July 2003 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Gerard Bashein, Paul Detmer, -! Centroid of a Polygon, -! in Graphics Gems IV, -! edited by Paul Heckbert, -! AP Professional, 1994, -! T385.G6974. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of sides of the polygon. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices. -! -! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) centroid(dim_num) - integer(kind=4) i - integer(kind=4) ip1 - real(kind=8) temp - real(kind=8) v(dim_num, n) - - area = 0.0D+00 - centroid(1:dim_num) = 0.0D+00 - - do i = 1, n - - if (i < n) then - ip1 = i + 1 - else - ip1 = 1 - end if - - temp = (v(1, i) * v(2, ip1) - v(1, ip1) * v(2, i)) - - area = area + temp - - centroid(1:dim_num) = centroid(1:dim_num) & - + (v(1:dim_num, ip1) + v(1:dim_num, i)) * temp - - end do - - area = area / 2.0D+00 - - if (area == 0.0D+00) then - centroid(1:dim_num) = v(1:dim_num, 1) - else - centroid(1:dim_num) = centroid(1:dim_num) / (6.0D+00 * area) - end if - - return -end -subroutine polygon_centroid_2d_2(n, v, centroid) - -!*****************************************************************************80 -! -!! POLYGON_CENTROID_2D_2 computes the centroid of a polygon in 2D. -! -! Discussion: -! -! The centroid is the area-weighted sum of the centroids of -! disjoint triangles that make up the polygon. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 July 2003 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices. -! -! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area_polygon - real(kind=8) area_triangle - real(kind=8) centroid(dim_num) - integer(kind=4) i - real(kind=8) t(dim_num, 3) - real(kind=8) v(dim_num, n) - - area_polygon = 0.0D+00 - centroid(1:dim_num) = 0.0D+00 - - do i = 1, n - 2 - - t(1:dim_num, 1:3) = reshape((/ & - v(1:dim_num, i), v(1:dim_num, i + 1), v(1:dim_num, n)/), & - (/dim_num, 3/)) - - call triangle_area_2d(t, area_triangle) - - area_polygon = area_polygon + area_triangle - - centroid(1:dim_num) = centroid(1:dim_num) + area_triangle & - * (v(1:dim_num, i) + v(1:dim_num, i + 1) + v(1:dim_num, n)) / 3.0D+00 - - end do - - if (area_polygon == 0.0D+00) then - centroid(1:dim_num) = v(1:dim_num, 1) - else - centroid(1:dim_num) = centroid(1:dim_num) / area_polygon - end if - - return -end -subroutine polygon_centroid_3d(n, v, centroid) - -!*****************************************************************************80 -! -!! POLYGON_CENTROID_3D computes the centroid of a polygon in 3D. -! -! Discussion: -! -! The polygon is described by its vertices. In many applications, -! these vertices will lie in a common plane, and the polygon will -! be "flat". However, that is not required for this formula. -! -! This formula triangulates the polygon, computes the area of -! each triangle and its centroid, and then computes the centroid -! of the polygon as the weight-averaged sum of the triangle centroids. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 February 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! -! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. -! -! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) area_polygon - real(kind=8) area_triangle - real(kind=8) centroid(dim_num) - integer(kind=4) i - real(kind=8) t(dim_num, 3) - real(kind=8) v(dim_num, n) - - area_polygon = 0.0D+00 - centroid(1:dim_num) = 0.0D+00 - - do i = 1, n - 2 - - t(1:dim_num, 1:3) = reshape((/ & - v(1:dim_num, i), v(1:dim_num, i + 1), v(1:dim_num, n)/), & - (/dim_num, 3/)) - - call triangle_area_3d(t, area_triangle) - - area_polygon = area_polygon + area_triangle - - centroid(1:dim_num) = centroid(1:dim_num) + area_triangle & - * (v(1:dim_num, i) + v(1:dim_num, i + 1) + v(1:dim_num, n)) / 3.0D+00 - - end do - - if (area_polygon == 0.0D+00) then - centroid(1:dim_num) = v(1:dim_num, 1) - else - centroid(1:dim_num) = centroid(1:dim_num) / area_polygon - end if - - return -end -subroutine polygon_contains_point_2d(n, v, p, inside) - -!*****************************************************************************80 -! -!! POLYGON_CONTAINS_POINT_2D finds if a point is inside a polygon. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 November 2016 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of nodes or vertices in -! the polygon. N must be at least 3. -! -! Input, real ( kind = 8 ) V(2,N), the vertices of the polygon. -! -! Input, real ( kind = 8 ) P(2), the coordinates of the point to be tested. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside -! the polygon. -! - implicit none - - integer(kind=4) n - - integer(kind=4) i - logical(kind=4) inside - integer(kind=4) ip1 - real(kind=8) p(2) - real(kind=8) px1 - real(kind=8) px2 - real(kind=8) py1 - real(kind=8) py2 - real(kind=8) v(2, n) - real(kind=8) xints - - inside = .false. - - px1 = v(1, 1) - py1 = v(2, 1) - xints = p(1) - 1.0D+00 - - do i = 1, n - - px2 = v(1, mod(i, n) + 1) - py2 = v(2, mod(i, n) + 1) - - if (min(py1, py2) < p(2)) then - if (p(2) <= max(py1, py2)) then - if (p(1) <= max(px1, px2)) then - if (py1 /= py2) then - xints = (p(2) - py1) * (px2 - px1) / (py2 - py1) + px1 - end if - if (px1 == px2 .or. p(1) <= xints) then - inside = .not. inside - end if - end if - end if - end if - - px1 = px2 - py1 = py2 - - end do - - return -end -subroutine polygon_contains_point_2d_2(n, v, p, inside) - -!*****************************************************************************80 -! -!! POLYGON_CONTAINS_POINT_2D_2: is a point inside a convex polygon in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of nodes or vertices in the -! polygon. N must be at least 3. -! -! Input, real ( kind = 8 ) V(2,N), the vertices of the polygon. -! -! Input, real ( kind = 8 ) P(2), the coordinates of the point to be tested. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside -! the polygon or on its boundary. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) t(dim_num, 3) - real(kind=8) v(dim_num, n) - - inside = .false. -! -! A point is inside a convex polygon if and only if it is inside -! one of the triangles formed by X(1),Y(1) and any two consecutive -! points on the polygon's circumference. -! - t(1:dim_num, 1) = v(1:dim_num, 1) - - do i = 2, n - 1 - - t(1:dim_num, 2) = v(1:dim_num, i) - t(1:dim_num, 3) = v(1:dim_num, i + 1) - - call triangle_contains_point_2d_1(t, p, inside) - - if (inside) then - return - end if - - end do - - return -end -subroutine polygon_contains_point_2d_3(n, v, p, inside) - -!*****************************************************************************80 -! -!! POLYGON_CONTAINS_POINT_2D_3: a point is inside a simple polygon in 2D. -! -! Discussion: -! -! A simple polygon is one whose boundary never crosses itself. -! The polygon does not need to be convex. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 May 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Moshe Shimrat, -! ACM Algorithm 112, -! Position of Point Relative to Polygon, -! Communications of the ACM, -! Volume 5, Number 8, page 434, August 1962. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of nodes or vertices in -! the polygon. N must be at least 3. -! -! Input, real ( kind = 8 ) V(2,N), the vertices of the polygon. -! -! Input, real ( kind = 8 ) P(2), the coordinates of the point to be tested. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside -! the polygon. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - logical(kind=4) inside - integer(kind=4) ip1 - real(kind=8) p(dim_num) - real(kind=8) v(dim_num, n) - - inside = .false. - - do i = 1, n - - if (i < n) then - ip1 = i + 1 - else - ip1 = 1 - end if - - if ((v(2, i) < p(2) .and. p(2) <= v(2, ip1)) .or. & - (p(2) <= v(2, i) .and. v(2, ip1) < p(2))) then - if ((p(1) - v(1, i)) - (p(2) - v(2, i)) & - * (v(1, ip1) - v(1, i)) / (v(2, ip1) - v(2, i)) < 0.0D+00) then - inside = .not. inside - end if - end if - - end do - - return -end -subroutine polygon_diameter_2d(n, v, diameter) - -!*****************************************************************************80 -! -!! POLYGON_DIAMETER_2D computes the diameter of a polygon in 2D. -! -! Discussion: -! -! The diameter of a polygon is the maximum distance between any -! two points on the polygon. It is guaranteed that this maximum -! distance occurs between two vertices of the polygon. It is -! sufficient to check the distance between all pairs of vertices. -! This is an N^2 algorithm. There is an algorithm by Shamos which -! can compute this quantity in order N time instead. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! -! Input, real ( kind = 8 ) V(2,N), the vertices. -! -! Output, real ( kind = 8 ) DIAMETER, the diameter of the polygon. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) diameter - integer(kind=4) i - integer(kind=4) j - real(kind=8) v(dim_num, n) - - diameter = 0.0D+00 - - do i = 1, n - - do j = i + 1, n - diameter = max(diameter, & - sqrt((v(1, i) - v(1, j))**2 + (v(2, i) - v(2, j))**2)) - end do - - end do - - return -end -subroutine polygon_expand_2d(n, v, h, w) - -!*****************************************************************************80 -! -!! POLYGON_EXPAND_2D expands a polygon in 2D. -! -! Discussion: -! -! This routine simple moves each vertex of the polygon outwards -! in such a way that the sides of the polygon advance by H. -! -! This approach should always work if the polygon is convex, or -! star-shaped. But for general polygons, it is possible -! that this procedure, for large enough H, will create a polygon -! whose sides intersect. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of sides of the polygon. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices. -! -! Input, real ( kind = 8 ) H, the expansion amount. -! -! Output, real ( kind = 8 ) W(2,N), the "expanded" coordinates. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle - real(kind=8) angle_rad_2d - real(kind=8) h - real(kind=8) h2 - integer(kind=4) i - integer(kind=4) i4_wrap - integer(kind=4) im1 - integer(kind=4) ip1 - real(kind=8) p4(dim_num) - real(kind=8) v(dim_num, n) - real(kind=8) w(dim_num, n) -! -! Consider each angle, formed by the nodes P(I-1), P(I), P(I+1). -! - do i = 1, n - - im1 = i4_wrap(i - 1, 1, n) - ip1 = i4_wrap(i + 1, 1, n) -! -! P1 -! / -! / P4 -! / . -! / . -! P2--------->P3 -! - call angle_half_2d(v(1:dim_num, im1), v(1:dim_num, i), v(1:dim_num, ip1), & - p4) -! -! Compute the value of the half angle. -! - angle = angle_rad_2d(v(1:dim_num, im1), v(1:dim_num, i), p4(1:dim_num)) -! -! The stepsize along the ray must be adjusted so that the sides -! move out by H. -! - h2 = h / sin(angle) - - w(1:dim_num, i) = v(1:dim_num, i) - h2 * (p4(1:dim_num) - v(1:dim_num, i)) - - end do - - return -end -subroutine polygon_inrad_data_2d(n, radin, area, radout, side) - -!*****************************************************************************80 -! -!! POLYGON_INRAD_DATA_2D determines polygonal data from its inner radius in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of sides of the polygon. -! N must be at least 3. -! -! Input, real ( kind = 8 ) RADIN, the inner radius of the polygon, that is, -! the radius of the largest circle that can be inscribed within -! the polygon. -! -! Output, real ( kind = 8 ) AREA, the area of the regular polygon. -! -! Output, real ( kind = 8 ) RADOUT, the outer radius of the polygon, that is, -! the radius of the smallest circle that can be described about -! the polygon. -! -! Output, real ( kind = 8 ) SIDE, the length of one side of the polygon. -! - implicit none - - real(kind=8) angle - real(kind=8) area - integer(kind=4) n - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radin - real(kind=8) radout - real(kind=8) side - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_INRAD_DATA_2D - Fatal error!' - write (*, '(a)') ' Input value of N must be at least 3' - write (*, '(a,i8)') ' but your input value was N = ', n - stop 1 - end if - - angle = r8_pi / real(n, kind=8) - area = real(n, kind=8) * radin * radin * tan(angle) - side = 2.0D+00 * radin * tan(angle) - radout = 0.5D+00 * side / sin(angle) - - return -end -function polygon_is_convex_2d(n, v) - -!*****************************************************************************80 -! -!! POLYGON_IS_CONVEX_2D determines whether a polygon is convex in 2D. -! -! Discussion: -! -! If the polygon has less than 3 distinct vertices, it is -! classified as convex degenerate. -! -! If the polygon "goes around" more than once, it is classified -! as NOT convex. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 May 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Peter Schorn, Frederick Fisher, -! Testing the Convexity of a Polygon, -! in Graphics Gems IV, -! edited by Paul Heckbert, -! AP Professional, 1994, -! T385.G6974. -! -! Parameters -! -! Input, integer ( kind = 4 ) N, the number of vertices. -! -! Input/output, real ( kind = 8 ) V(2,N), the coordinates of the vertices -! of the polygon. On output, duplicate consecutive points have been -! deleted, and the vertices have been reordered so that the -! lexicographically least point comes first. -! -! Output, integer ( kind = 4 ) POLYGON_IS_CONVEX_2D: -! -1, the polygon is not convex; -! 0, the polygon has less than 3 vertices; it is "degenerately" convex; -! 1, the polygon is convex and counter clockwise; -! 2, the polygon is convex and clockwise. -! - implicit none - - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8), parameter :: RAD_TO_DEG = 180.0D+00 / r8_pi - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle - integer(kind=4), parameter :: CONVEX_CCW = 1 - integer(kind=4), parameter :: CONVEX_CW = 2 - real(kind=8) cross - integer(kind=4), parameter :: DEGENERATE_CONVEX = 0 - real(kind=8) dot - real(kind=8) exterior_total - integer(kind=4) i - integer(kind=4) ip1 - integer(kind=4) ip2 - integer(kind=4), parameter :: NOT_CONVEX = -1 - integer(kind=4) polygon_is_convex_2d - real(kind=8) sense - real(kind=8), parameter :: tol = 1.0D+00 - real(kind=8) v(dim_num, n) - - exterior_total = 0.0D+00 -! -! If there are not at least 3 distinct vertices, we are done. -! - if (n < 3) then - polygon_is_convex_2d = DEGENERATE_CONVEX - return - end if - - sense = 0.0D+00 -! -! Consider each polygonal vertex I. -! - do i = 1, n - - ip1 = i + 1 - if (n < ip1) then - ip1 = ip1 - n - end if - - ip2 = i + 2 - if (n < ip2) then - ip2 = ip2 - n - end if - - dot = (v(1, ip2) - v(1, ip1)) * (v(1, i) - v(1, ip1)) & - + (v(2, ip2) - v(2, ip1)) * (v(2, i) - v(2, ip1)) - - cross = (v(1, ip2) - v(1, ip1)) * (v(2, i) - v(2, ip1)) & - - (v(1, i) - v(1, ip1)) * (v(2, ip2) - v(2, ip1)) - - angle = atan2(cross, dot) -! -! See if the turn defined by this vertex is our first indication of -! the "sense" of the polygon, or if it disagrees with the previously -! defined sense. -! - if (sense == 0.0D+00) then - - if (angle < 0.0D+00) then - sense = -1.0D+00 - else if (0.0D+00 < angle) then - sense = +1.0D+00 - end if - - else if (sense == 1.0D+00) then - - if (angle < 0.0D+00) then - polygon_is_convex_2d = NOT_CONVEX - return - end if - - else if (sense == -1.0D+00) then - - if (0.0D+00 < angle) then - polygon_is_convex_2d = NOT_CONVEX - return - end if - - end if -! -! If the exterior total is greater than 360, then the polygon is -! going around again. -! - angle = atan2(-cross, -dot) - - exterior_total = exterior_total + angle - - if (360.0D+00 + tol < abs(exterior_total) * RAD_TO_DEG) then - polygon_is_convex_2d = NOT_CONVEX - return - end if - - end do - - if (sense == +1.0D+00) then - polygon_is_convex_2d = CONVEX_CCW - else if (sense == -1.0D+00) then - polygon_is_convex_2d = CONVEX_CW - end if - - return -end -subroutine polygon_lattice_area_2d(i, b, area) - -!*****************************************************************************80 -! -!! POLYGON_LATTICE_AREA_2D computes the area of a lattice polygon in 2D. -! -! Discussion: -! -! We define a lattice to be the 2D plane, in which the points -! whose (X,Y) coordinates are both integers are given a special -! status as "lattice points". -! -! A lattice polygon is a polygon whose vertices are lattice points. -! -! The area of a lattice polygon can be computed by Pick's Theorem: -! -! Area = I + B / 2 - 1 -! -! where -! -! I = the number of lattice points contained strictly inside the polygon; -! -! B = the number of lattice points that lie exactly on the boundary. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 June 2002 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Branko Gruenbaum, Geoffrey Shephard, -! Pick's Theorem, -! The American Mathematical Monthly, -! Volume 100, Number 2, February 1993, pages 150-161. -! -! Parameters: -! -! Input, integer ( kind = 4 ) I, the number of interior lattice points. -! -! Input, integer ( kind = 4 ) B, the number of boundary lattice points. -! -! Output, real ( kind = 8 ) AREA, the area of the lattice polygon. -! - implicit none - - real(kind=8) area - integer(kind=4) b - integer(kind=4) i - - area = real(i, kind=8) + real(b, kind=8) / 2.0D+00 - 1.0D+00 - - return -end -subroutine polygon_normal_3d(n, v, normal) - -!*****************************************************************************80 -! -!! POLYGON_NORMAL_3D computes the normal vector to a polygon in 3D. -! -! Discussion: -! -! If the polygon is planar, then this calculation is correct. -! -! Otherwise, the normal vector calculated is the simple average -! of the normals defined by the planes of successive triples -! of vertices. -! -! If the polygon is "almost" planar, this is still acceptable. -! But as the polygon is less and less planar, so this averaged normal -! vector becomes more and more meaningless. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 August 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, -! Point in Polyhedron Testing Using Spherical Polygons, -! in Graphics Gems V, -! edited by Alan Paeth, -! Academic Press, 1995, -! ISBN: 0125434553, -! LC: T385.G6975. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices. -! -! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. -! -! Output, real ( kind = 8 ) NORMAL(3), the averaged normal vector -! to the polygon. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) n - - real(kind=8) r8vec_norm - integer(kind=4) j - real(kind=8) normal(dim_num) - real(kind=8) normal_norm - real(kind=8) p(dim_num) - real(kind=8) v(dim_num, n) - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) - - normal(1:dim_num) = 0.0D+00 - - v1(1:dim_num) = v(1:dim_num, 2) - v(1:dim_num, 1) - - do j = 3, n - - v2(1:dim_num) = v(1:dim_num, j) - v(1:dim_num, 1) - - call r8vec_cross_product_3d(v1, v2, p) - - normal(1:dim_num) = normal(1:dim_num) + p(1:dim_num) - - v1(1:dim_num) = v2(1:dim_num) - - end do -! -! Normalize. -! - normal_norm = r8vec_norm(dim_num, normal) - - if (normal_norm == 0.0D+00) then - return - end if - - normal(1:dim_num) = normal(1:dim_num) / normal_norm - - return -end -subroutine polygon_outrad_data_2d(n, radout, area, radin, side) - -!*****************************************************************************80 -! -!! POLYGON_OUTRAD_DATA_2D determines polygonal data from its outer radius in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of sides of the polygon. -! N must be at least 3. -! -! Input, real ( kind = 8 ) RADOUT, the outer radius of the polygon, that is, -! the radius of the smallest circle that can be described -! around the polygon. -! -! Output, real ( kind = 8 ) AREA, the area of the regular polygon. -! -! Output, real ( kind = 8 ) RADIN, the inner radius of the polygon, that is, -! the radius of the largest circle that can be inscribed -! within the polygon. -! -! Output, real ( kind = 8 ) SIDE, the length of one side of the polygon. -! - implicit none - - real(kind=8) angle - real(kind=8) area - integer(kind=4) n - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radin - real(kind=8) radout - real(kind=8) side - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_OUTRAD_DATA_2D - Fatal error!' - write (*, '(a)') ' Input value of N must be at least 3' - write (*, '(a,i8)') ' but your input value was N = ', n - stop 1 - end if - - angle = r8_pi / real(n, kind=8) - area = 0.5D+00 * real(n, kind=8) * radout * radout & - * sin(2.0D+00 * angle) - side = 2.0D+00 * radout * sin(angle) - radin = 0.5D+00 * side / tan(angle) - - return -end -subroutine polygon_point_dist_2d(n, v, p, dist) - -!*****************************************************************************80 -! -!! POLYGON_POINT_DIST_2D: distance ( polygon, point ) in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices. -! -! Input, real ( kind = 8 ) V(2,N), the triangle vertices. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! polygon. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) dist2 - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) p(dim_num) - real(kind=8) v(dim_num, n) -! -! Find the distance to each of the line segments. -! - dist = huge(dist) - - do j = 1, n - - jp1 = i4_wrap(j + 1, 1, n) - - call segment_point_dist_2d(v(1:dim_num, j), v(1:dim_num, jp1), p, dist2) - - if (dist2 < dist) then - dist = dist2 - end if - - end do - - return -end -subroutine polygon_point_near_2d(n, v, p, pn, dist) - -!*****************************************************************************80 -! -!! POLYGON_POINT_NEAR_2D computes the nearest point on a polygon in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V(2,N), the polygon vertices. -! -! Input, real ( kind = 8 ) P(2), the point whose nearest polygon point -! is to be determined. -! -! Output, real ( kind = 8 ) PN(2), the nearest point to P. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! polygon. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) dist2 - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) pn2(dim_num) - real(kind=8) tval - real(kind=8) v(dim_num, n) -! -! Find the distance to each of the line segments that make up the edges -! of the polygon. -! - dist = huge(dist) - pn(1:dim_num) = 0.0D+00 - - do j = 1, n - - jp1 = i4_wrap(j + 1, 1, n) - - call segment_point_near_2d(v(1:dim_num, j), v(1:dim_num, jp1), p, & - pn2, dist2, tval) - - if (dist2 < dist) then - dist = dist2 - pn(1:dim_num) = pn2(1:dim_num) - end if - - end do - - return -end -subroutine polygon_side_data_2d(n, side, area, radin, radout) - -!*****************************************************************************80 -! -!! POLYGON_SIDE_DATA_2D determines polygonal data from its side length in 2D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 June 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of sides of the polygon. -! N must be at least 3. -! -! Input, real ( kind = 8 ) SIDE, the length of one side of the polygon. -! -! Output, real ( kind = 8 ) AREA, the area of the regular polygon. -! -! Output, real ( kind = 8 ) RADIN, the inner radius of the polygon, that is, -! the radius of the largest circle that can be inscribed within -! the polygon. -! -! Output, real ( kind = 8 ) RADOUT, the outer radius of the polygon, that is, -! the radius of the smallest circle that can be described about -! the polygon. -! - implicit none - - real(kind=8) angle - real(kind=8) area - integer(kind=4) n - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radin - real(kind=8) radout - real(kind=8) side - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_SIDE_DATA_2D - Fatal error!' - write (*, '(a)') ' Input value of N must be at least 3' - write (*, '(a,i8)') ' but your input value was N = ', n - stop 1 - end if - - angle = r8_pi / real(n, kind=8) - area = 0.25D+00 * real(n, kind=8) * side * side / tan(angle) - radin = 0.5D+00 * side / tan(angle) - radout = 0.5D+00 * side / sin(angle) - - return -end -subroutine polygon_solid_angle_3d(n, v, p, solid_angle) - -!*****************************************************************************80 -! -!! POLYGON_SOLID_ANGLE_3D: projected solid angle of a 3D plane polygon. -! -! Discussion: -! -! A point P is at the center of a unit sphere. A planar polygon -! is to be projected onto the surface of this sphere, by drawing -! the ray from P to each polygonal vertex, and noting where this ray -! intersects the sphere. -! -! We compute the area on the sphere of the projected polygon. -! -! Since we are projecting the polygon onto a unit sphere, the area -! of the projected polygon is equal to the solid angle subtended by -! the polygon. -! -! The value returned by this routine will include a sign. The -! angle subtended will be NEGATIVE if the normal vector defined by -! the polygon points AWAY from the viewing point, and will be -! POSITIVE if the normal vector points towards the viewing point. -! -! If the orientation of the polygon is of no interest to you, -! then you can probably simply take the absolute value of the -! solid angle as the information you want. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 October 2007 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, -! Point in Polyhedron Testing Using Spherical Polygons, -! in Graphics Gems V, -! edited by Alan Paeth, -! Academic Press, 1995, -! ISBN: 0125434553, -! LC: T385.G6975. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices. -! -! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. -! -! Input, real ( kind = 8 ) P(3), the point at the center of the unit sphere. -! -! Output, double SOLID_ANGLE, the solid angle subtended -! by the polygon, as projected onto the unit sphere around the point P. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) n - - real(kind=8) a(dim_num) - real(kind=8) angle - real(kind=8) area - real(kind=8) b(dim_num) - real(kind=8) r8vec_norm - real(kind=8) r8vec_scalar_triple_product - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) normal1(dim_num) - real(kind=8) normal1_norm - real(kind=8) normal2(dim_num) - real(kind=8) normal2_norm - real(kind=8) p(dim_num) - real(kind=8) plane(dim_num) - real(kind=8) r1(dim_num) - real(kind=8) r8_acos - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) s - real(kind=8) solid_angle - real(kind=8) v(dim_num, n) - - if (n < 3) then - solid_angle = 0.0D+00 - return - end if - - call polygon_normal_3d(n, v, plane) - - a(1:dim_num) = v(1:dim_num, n) - v(1:dim_num, 1) - - area = 0.0D+00 - - do j = 1, n - - r1(1:dim_num) = v(1:dim_num, j) - p(1:dim_num) - - jp1 = i4_wrap(j + 1, 1, n) - - b(1:dim_num) = v(1:dim_num, jp1) - v(1:dim_num, j) - - call r8vec_cross_product_3d(a, r1, normal1) - - normal1_norm = r8vec_norm(dim_num, normal1) - - call r8vec_cross_product_3d(r1, b, normal2) - - normal2_norm = r8vec_norm(dim_num, normal2) - - s = dot_product(normal1(1:dim_num), normal2(1:dim_num)) & - / (normal1_norm * normal2_norm) - - angle = r8_acos(s) - - s = r8vec_scalar_triple_product(b, a, plane) - - if (0.0D+00 < s) then - area = area + r8_pi - angle - else - area = area + r8_pi + angle - end if - - a(1:dim_num) = -b(1:dim_num) - - end do - - area = area - r8_pi * real(n - 2, kind=8) - - if (0.0D+00 < dot_product(plane(1:dim_num), r1(1:dim_num))) then - solid_angle = -area - else - solid_angle = area - end if - - return -end -subroutine polygon_x_2d(n, v, result) - -!*****************************************************************************80 -! -!! POLYGON_X_2D integrates the function X over a polygon in 2D. -! -! Discussion: -! -! The polygon is bounded by the points (X(1:N), Y(1:N)). -! -! INTEGRAL = (1/6) * sum ( 1 <= I <= N ) -! ( X(I)*X(I) + X(I) * X(I-1) + X(I-1)*X(I-1) ) * ( Y(I) - Y(I-1) ) -! -! where X(0) and Y(0) should be replaced by X(N) and Y(N). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 July 2001 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! SF Bockman, -! Generalizing the Formula for Areas of Polygons to Moments, -! American Mathematical Society Monthly, -! 1989, pages 131-132. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! N should be at least 3 for a nonzero result. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices -! of the polygon. These vertices should be given in counter clockwise order. -! -! Output, real ( kind = 8 ) RESULT, the value of the integral. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - integer(kind=4) im1 - real(kind=8) result - real(kind=8) v(2, n) - - result = 0.0D+00 - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_X_2D - Fatal error!' - write (*, '(a)') ' The number of vertices must be at least 3.' - write (*, '(a,i8)') ' The input value of N = ', n - stop 1 - end if - - do i = 1, n - - if (i == 1) then - im1 = n - else - im1 = i - 1 - end if - - result = result + (v(1, i)**2 + v(1, i) * v(1, im1) + v(1, im1)**2) & - * (v(2, i) - v(2, im1)) - - end do - - result = result / 6.0D+00 - - return -end -subroutine polygon_xx_2d(n, v, result) - -!*****************************************************************************80 -! -!! POLYGON_XX_2D integrates the function X*X over a polygon in 2D. -! -! Discussion: -! -! The polygon is bounded by the points (X(1:N), Y(1:N)). -! -! INTEGRAL = (1/12) * sum ( 1 <= I <= N ) -! ( X(I)^3 + X(I)^2 * X(I-1) + X(I) * X(I-1)^2 + X(I-1)^3 ) -! * ( Y(I) - Y(I-1) ) -! -! where X(0) and Y(0) should be replaced by X(N) and Y(N). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 July 2001 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! SF Bockman, -! Generalizing the Formula for Areas of Polygons to Moments, -! American Mathematical Society Monthly, -! 1989, pages 131-132. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! N should be at least 3 for a nonzero result. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices -! of the polygon. These vertices should be given in -! counter clockwise order. -! -! Output, real ( kind = 8 ) RESULT, the value of the integral. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - integer(kind=4) im1 - real(kind=8) result - real(kind=8) v(2, n) - - result = 0.0D+00 - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_XX_2D - Fatal error!' - write (*, '(a)') ' The number of vertices must be at least 3.' - write (*, '(a,i8)') ' The input value of N = ', n - stop 1 - end if - - do i = 1, n - - if (i == 1) then - im1 = n - else - im1 = i - 1 - end if - - result = result + (v(1, i)**3 + v(1, i)**2 * v(1, im1) & - + v(1, i) * v(1, im1)**2 + v(1, im1)**3) * (v(2, i) - v(2, im1)) - - end do - - result = result / 12.0D+00 - - return -end -subroutine polygon_xy_2d(n, v, result) - -!*****************************************************************************80 -! -!! POLYGON_XY_2D integrates the function X*Y over a polygon in 2D. -! -! Discussion: -! -! The polygon is bounded by the points (X(1:N), Y(1:N)). -! -! INTEGRAL = (1/24) * sum ( 1 <= I <= N ) -! ( Y(I) * ( 3 * X(I)^2 + 2 * X(I) * X(I-1) + X(I-1)^2 ) -! + Y(I-1) * ( X(I)^2 + 2 * X(I) * X(I-1) + 3 * X(I-1)^2 ) ) -! * ( Y(I) - Y(I-1) ) -! -! where X(0) and Y(0) should be replaced by X(N) and Y(N). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 July 2001 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! SF Bockman, -! Generalizing the Formula for Areas of Polygons to Moments, -! American Mathematical Society Monthly, -! 1989, pages 131-132. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! N should be at least 3 for a nonzero result. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices -! of the polygon. These vertices should be given in -! counter clockwise order. -! -! Output, real ( kind = 8 ) RESULT, the value of the integral. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - integer(kind=4) im1 - real(kind=8) result - real(kind=8) v(dim_num, n) - - result = 0.0D+00 - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_XY_2D - Fatal error!' - write (*, '(a)') ' The number of vertices must be at least 3.' - write (*, '(a,i8)') ' The input value of N = ', n - stop 1 - end if - - do i = 1, n - - if (i == 1) then - im1 = n - else - im1 = i - 1 - end if - - result = result + ( & - v(2, i) * (3.0D+00 * v(1, i)**2 + 2.0D+00 * v(1, i) * v(1, im1) & - + v(1, im1)**2) + v(2, im1) * (v(1, i)**2 + 2.0D+00 * v(1, i) * v(1, im1) & - + 3.0D+00 * v(1, im1)**2)) * (v(2, i) - v(2, im1)) - - end do - - result = result / 24.0D+00 - - return -end -subroutine polygon_y_2d(n, v, result) - -!*****************************************************************************80 -! -!! POLYGON_Y_2D integrates the function Y over a polygon in 2D. -! -! Discussion: -! -! The polygon is bounded by the points (X(1:N), Y(1:N)). -! -! INTEGRAL = (1/6) * sum ( 1 <= I <= N ) -! - ( Y(I)^2 + Y(I) * Y(I-1) + Y(I-1)^2 ) * ( X(I) - X(I-1) ) -! -! where X(0) and Y(0) should be replaced by X(N) and Y(N). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 July 2001 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! SF Bockman, -! Generalizing the Formula for Areas of Polygons to Moments, -! American Mathematical Society Monthly, -! 1989, pages 131-132. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! N should be at least 3 for a nonzero result. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices -! of the polygon. These vertices should be given in -! counter clockwise order. -! -! Output, real ( kind = 8 ) RESULT, the value of the integral. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - integer(kind=4) im1 - real(kind=8) result - real(kind=8) v(dim_num, n) - - result = 0.0D+00 - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_Y_2D - Fatal error!' - write (*, '(a)') ' The number of vertices must be at least 3.' - write (*, '(a,i8)') ' The input value of N = ', n - stop 1 - end if - - do i = 1, n - - if (i == 1) then - im1 = n - else - im1 = i - 1 - end if - - result = result - (v(2, i)**2 + v(2, i) * v(2, im1) + v(2, im1)**2) & - * (v(1, i) - v(1, im1)) - - end do - - result = result / 6.0D+00 - - return -end -subroutine polygon_yy_2d(n, v, result) - -!*****************************************************************************80 -! -!! POLYGON_YY_2D integrates the function Y*Y over a polygon in 2D. -! -! Discussion: -! -! The polygon is bounded by the points (X(1:N), Y(1:N)). -! -! INTEGRAL = (1/12) * sum ( 1 <= I <= N ) -! - ( Y(I)^3 + Y(I)^2 * Y(I-1) + Y(I) * Y(I-1)^2 + Y(I-1)^3 ) -! * ( X(I) - X(I-1) ) -! -! where X(0) and Y(0) should be replaced by X(N) and Y(N). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 July 2001 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! SF Bockman, -! Generalizing the Formula for Areas of Polygons to Moments, -! American Mathematical Society Monthly, -! 1989, pages 131-132. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. -! N should be at least 3 for a nonzero result. -! -! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices -! of the polygon. These vertices should be given in -! counter clockwise order. -! -! Output, real ( kind = 8 ) RESULT, the value of the integral. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) i - integer(kind=4) im1 - real(kind=8) result - real(kind=8) v(dim_num, n) - - result = 0.0D+00 - - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYGON_YY_2D - Fatal error!' - write (*, '(a)') ' The number of polygonal vertices must be ' - write (*, '(a,i8)') ' at least 3, but the input polygon has N = ', n - stop 1 - end if - - do i = 1, n - - if (i == 1) then - im1 = n - else - im1 = i - 1 - end if - - result = result - (v(2, i)**3 + v(2, i)**2 * v(2, im1) & - + v(2, i) * v(2, im1)**2 + v(2, im1)**3) * (v(1, i) - v(1, im1)) - - end do - - result = result / 12.0D+00 - - return -end -subroutine polyhedron_area_3d(coord, order_max, face_num, node, & - node_num, order, area) - -!*****************************************************************************80 -! -!! POLYHEDRON_AREA_3D computes the surface area of a polyhedron in 3D. -! -! Discussion: -! -! The computation is not valid unless the faces of the polyhedron -! are planar polygons. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 April 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Allen Van Gelder, -! Efficient Computation of Polygon Area and Polyhedron Volume, -! in Graphics Gems V, -! edited by Alan Paeth, -! AP Professional, 1995, T385.G6975 -! -! Parameters: -! -! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of the -! vertices. The vertices may be listed in any order. -! -! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices -! that make up a face of the polyhedron. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the -! polyhedron. -! -! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined -! by the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices -! are listed in neighboring order. -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. -! -! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices -! making up each face. -! -! Output, real ( kind = 8 ) AREA, the total surface area of the polyhedron. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) node_num - - real(kind=8) ainc - real(kind=8) area - real(kind=8) coord(dim_num, node_num) - integer(kind=4) face - integer(kind=4) j - integer(kind=4) k1 - integer(kind=4) k2 - integer(kind=4) node(face_num, order_max) - integer(kind=4) order(face_num) - real(kind=8) v(dim_num) - - area = 0.0D+00 -! -! For each face -! - do face = 1, face_num - - v(1:dim_num) = 0.0D+00 -! -! For each triangle in the face, compute the normal vector. -! - do j = 1, order(face) - - k1 = node(face, j) - - if (j < order(face)) then - k2 = node(face, j + 1) - else - k2 = node(face, 1) - end if -! -! Compute the cross product. -! - v(1) = v(1) + coord(2, k1) * coord(3, k2) - coord(3, k1) * coord(2, k2) - v(2) = v(2) + coord(3, k1) * coord(1, k2) - coord(1, k1) * coord(3, k2) - v(3) = v(3) + coord(1, k1) * coord(2, k2) - coord(2, k1) * coord(1, k2) - - end do -! -! Add the magnitude of the normal vector to the sum. -! - ainc = sqrt(sum(v(1:dim_num)**2)) - area = area + ainc - - end do - - area = 0.5D+00 * area - - return -end -subroutine polyhedron_centroid_3d(coord, order_max, face_num, node, & - node_num, order, centroid) - -!*****************************************************************************80 -! -!! POLYHEDRON_CENTROID_3D computes the centroid of a polyhedron in 3D. -! -! Discussion: -! -! The centroid can be computed as the volume-weighted average of -! the centroids of the tetrahedra defined by choosing a point in -! the interior of the polyhedron, and using as a base every triangle -! created by triangulating the faces of the polyhedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the vertices. -! The vertices may be listed in any order. -! -! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices -! that make up a face of the polyhedron. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the -! polyhedron. -! -! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined -! by the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices -! are listed in neighboring order. -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. -! -! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices making -! up each face. -! -! Output, real ( kind = 8 ) CENTROID(3), the centroid of the polyhedron. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) node_num - - real(kind=8) area - real(kind=8) centroid(dim_num) - real(kind=8) coord(dim_num, node_num) - integer(kind=4) face - integer(kind=4) n1 - integer(kind=4) n2 - integer(kind=4) n3 - integer(kind=4) node(face_num, order_max) - real(kind=8) normal(dim_num) - integer(kind=4) order(face_num) - real(kind=8) point(dim_num) - real(kind=8) polygon_area - real(kind=8) polygon_centroid(dim_num) - real(kind=8) tetra(dim_num, 4) - real(kind=8) tetra_centroid(dim_num) - real(kind=8) tetra_volume - integer(kind=4) vert - integer(kind=4) vert_num - real(kind=8) volume - real(kind=8) v(dim_num, order_max) -! -! Compute a point in the interior. -! We take the area-weighted centroid of each face. -! - point(1:dim_num) = 0.0D+00 - area = 0.0D+00 - - do face = 1, face_num - - vert_num = order(face) - - v(1:dim_num, 1:vert_num) = coord(1:dim_num, node(face, 1:vert_num)) - - call polygon_area_3d(vert_num, v, polygon_area, normal) - - call polygon_centroid_3d(vert_num, v, polygon_centroid) - - point(1:dim_num) = point(1:dim_num) & - + polygon_area * polygon_centroid(1:dim_num) - - area = area + polygon_area - - end do - - point(1:dim_num) = point(1:dim_num) / area -! -! Now triangulate each face. -! For each triangle, consider the tetrahedron created by including POINT. -! - centroid(1:dim_num) = 0.0D+00 - volume = 0.0D+00 - - do face = 1, face_num - - n3 = node(face, order(face)) - - do vert = 1, order(face) - 2 - - n1 = node(face, vert) - n2 = node(face, vert + 1) - - tetra(1:dim_num, 1:4) = reshape((/ & - coord(1:dim_num, n1), coord(1:dim_num, n2), coord(1:dim_num, n3), & - point(1:dim_num)/), (/dim_num, 4/)) - - call tetrahedron_volume_3d(tetra, tetra_volume) - - call tetrahedron_centroid_3d(tetra, tetra_centroid) - - centroid(1:dim_num) = centroid(1:dim_num) & - + tetra_volume * tetra_centroid(1:dim_num) - - volume = volume + tetra_volume - - end do - end do - - centroid(1:dim_num) = centroid(1:dim_num) / volume - - return -end -subroutine polyhedron_contains_point_3d(node_num, face_num, & - face_order_max, v, face_order, face_point, p, inside) - -!*****************************************************************************80 -! -!! POLYHEDRON_CONTAINS_POINT_3D determines if a point is inside a polyhedron. -! -! Discussion: -! -! The reference states that the polyhedron should be simple (that -! is, the faces should form a single connected surface), and that -! the individual faces should be consistently oriented. -! -! However, the polyhedron does not, apparently, need to be convex. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 August 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, -! Point in Polyhedron Testing Using Spherical Polygons, -! in Graphics Gems V, -! edited by Alan Paeth, -! Academic Press, 1995, -! ISBN: 0125434553, -! LC: T385.G6975. -! -! Parameters: -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of vertices. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! -! Input, real ( kind = 8 ) V(3,NODE_NUM), the coordinates of the vertices. -! -! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the order of each face. -! -! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM), the -! indices of the nodes that make up each face. -! -! Input, real ( kind = 8 ) P(3), the point to be tested. -! -! Output, logical ( kind = 4 ) INSIDE, is true if the point -! is inside the polyhedron. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) node_num - - real(kind=8) area - integer(kind=4) face - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - logical(kind=4) inside - integer(kind=4) k - integer(kind=4) node - integer(kind=4) node_num_face - real(kind=8) p(dim_num) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) solid_angle - real(kind=8) v(dim_num, node_num) - real(kind=8) v_face(dim_num, face_order_max) - - area = 0.0D+00 - - do face = 1, face_num - - node_num_face = face_order(face) - - do k = 1, node_num_face - - node = face_point(k, face) - - v_face(1:dim_num, k) = v(1:dim_num, node) - - end do - - call polygon_solid_angle_3d(node_num_face, v_face, p, solid_angle) - - area = area + solid_angle - - end do -! -! AREA should be -4*PI, 0, or 4*PI. -! So this test should be quite safe! -! - if (area < -2.0D+00 * r8_pi .or. 2.0D+00 * r8_pi < area) then - inside = .true. - else - inside = .false. - end if - - return -end -subroutine polyhedron_volume_3d(coord, order_max, face_num, node, & - node_num, order, volume) - -!*****************************************************************************80 -! -!! POLYHEDRON_VOLUME_3D computes the volume of a polyhedron in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 August 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of -! the vertices. The vertices may be listed in any order. -! -! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices -! that make up a face of the polyhedron. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the -! polyhedron. -! -! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined by -! the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices -! are listed in neighboring order. -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. -! -! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices making -! up each face. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) node_num - - real(kind=8) coord(dim_num, node_num) - integer(kind=4) face - integer(kind=4) n1 - integer(kind=4) n2 - integer(kind=4) n3 - integer(kind=4) node(face_num, order_max) - integer(kind=4) order(face_num) - integer(kind=4) v - real(kind=8) volume - - volume = 0.0D+00 -! -! Triangulate each face. -! - do face = 1, face_num - - n3 = node(face, order(face)) - - do v = 1, order(face) - 2 - - n1 = node(face, v) - n2 = node(face, v + 1) - - volume = volume & - + coord(1, n1) & - * (coord(2, n2) * coord(3, n3) - coord(2, n3) * coord(3, n2)) & - + coord(1, n2) & - * (coord(2, n3) * coord(3, n1) - coord(2, n1) * coord(3, n3)) & - + coord(1, n3) & - * (coord(2, n1) * coord(3, n2) - coord(2, n2) * coord(3, n1)) - - end do - - end do - - volume = volume / 6.0D+00 - - return -end -subroutine polyhedron_volume_3d_2(coord, order_max, face_num, node, & - node_num, order, volume) - -!*****************************************************************************80 -! -!! POLYHEDRON_VOLUME_3D_2 computes the volume of a polyhedron in 3D. -! -! Discussion: -! -! The computation is not valid unless the faces of the polyhedron -! are planar polygons. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 August 2003 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Allen Van Gelder, -! Efficient Computation of Polygon Area and Polyhedron Volume, -! in Graphics Gems V, -! edited by Alan Paeth, -! AP Professional, 1995, T385.G6975. -! -! Parameters: -! -! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the vertices. -! The vertices may be listed in any order. -! -! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices -! that make up a face of the polyhedron. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the -! polyhedron. -! -! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined -! by the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices -! are listed in neighboring order. -! -! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. -! -! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices making -! up each face. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) node_num - - real(kind=8) coord(dim_num, node_num) - integer(kind=4) face - integer(kind=4) j - integer(kind=4) k - integer(kind=4) k1 - integer(kind=4) k2 - integer(kind=4) node(face_num, order_max) - real(kind=8) normal(dim_num) - integer(kind=4) order(face_num) - real(kind=8) v(dim_num) - real(kind=8) volume - - volume = 0.0D+00 - - do face = 1, face_num - - v(1:dim_num) = 0.0D+00 -! -! Compute the area vector for this face. -! - do j = 1, order(face) - - k1 = node(face, j) - - if (j < order(face)) then - k2 = node(face, j + 1) - else - k2 = node(face, 1) - end if -! -! Compute the cross product. -! - normal(1) = coord(2, k1) * coord(3, k2) - coord(3, k1) * coord(2, k2) - normal(2) = coord(3, k1) * coord(1, k2) - coord(1, k1) * coord(3, k2) - normal(3) = coord(1, k1) * coord(2, k2) - coord(2, k1) * coord(1, k2) - - v(1:dim_num) = v(1:dim_num) + normal(1:dim_num) - - end do -! -! Area vector dot any vertex. -! - k = node(face, 1) - volume = volume + dot_product(v(1:dim_num), coord(1:dim_num, k)) - - end do - - volume = volume / 6.0D+00 - - return -end -subroutine polyline_arclength_nd(dim_num, n, p, s) - -!*****************************************************************************80 -! -!! POLYLINE_ARCLENGTH_ND computes the arclength of points on a polyline in ND. -! -! Discussion: -! -! A polyline of order N is the geometric structure consisting of -! the N-1 line segments that lie between successive elements of a list -! of N points. -! -! An ordinary line segment is a polyline of order 2. -! The letter "V" is a polyline of order 3. -! The letter "N" is a polyline of order 4, and so on. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) N, the number of points defining the polyline. -! -! Input, real ( kind = 8 ) P(DIM_NUM,N), the points defining the polyline. -! -! Output, real ( kind = 8 ) S(N), the arclength coordinates -! of each point. The first point has S(1) = 0 and the -! last point has S(N) = arclength of the entire polyline. -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) n - - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) s(n) - - s(1) = 0.0D+00 - - do i = 2, n - - s(i) = s(i - 1) + sqrt(sum((p(1:dim_num, i) - p(1:dim_num, i - 1))**2)) - - end do - - return -end -subroutine polyline_index_point_nd(dim_num, n, p, t, pt) - -!*****************************************************************************80 -! -!! POLYLINE_INDEX_POINT_ND evaluates a polyline at a given arclength in ND. -! -! Discussion: -! -! The polyline is defined as the set of N-1 line segments lying -! between a sequence of N points. The arclength of a point lying -! on the polyline is simply the length of the broken line from the -! initial point. Any point on the polyline can be found by -! specifying its arclength. -! -! If the given arclength coordinate is less than 0, or greater -! than the arclength coordinate of the last given point, then -! extrapolation is used, that is, the first and last line segments -! are extended as necessary. -! -! The arclength coordinate system measures the distance between -! any two points on the polyline as the length of the segment of the -! line that joins them. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) N, the number of points defining the polyline. -! -! Input, real ( kind = 8 ) P(DIM_NUM,N), the points defining the polyline. -! -! Input, real ( kind = 8 ) T, the desired arclength coordinate. -! -! Output, real ( kind = 8 ) PT(DIM_NUM), the point corresponding to the -! arclength. -! - implicit none - - integer(kind=4) n - integer(kind=4) dim_num - - integer(kind=4) i - real(kind=8) p(dim_num, n) - real(kind=8) pt(dim_num) - real(kind=8) t - real(kind=8) t1 - real(kind=8) t2 - - if (n <= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'POLYLINE_INDEX_POINT_ND - Fatal error!' - write (*, '(a)') ' The input quantity N is nonpositive.' - write (*, '(a,i8)') ' N = ', n - stop 1 - end if - - if (n == 1) then - - pt(1:dim_num) = p(1:dim_num, 1) - - else - - t2 = 0.0D+00 - - do i = 1, n - 1 -! -! Find the distance between points I and I+1. -! - t1 = t2 - t2 = t1 + sqrt(sum((p(1:dim_num, i + 1) - p(1:dim_num, i))**2)) -! -! Interpolate or extrapolate in an interval. -! - if (t <= t2 .or. i == n - 1) then - - pt(1:dim_num) = ((t2 - t) * p(1:dim_num, i) & - + (t - t1) * p(1:dim_num, i + 1)) & - / (t2 - t1) - - return - end if - end do - end if - - return -end -subroutine polyline_length_nd(dim_num, nk, pk, length) - -!*****************************************************************************80 -! -!! POLYLINE_LENGTH_ND computes the length of a polyline in ND. -! -! Discussion: -! -! A polyline of order NK is the geometric structure consisting of -! the NK-1 line segments that lie between successive elements of a list -! of NK points. -! -! An ordinary line segment is a polyline of order 2. -! The letter "V" is a polyline of order 3. -! The letter "N" is a polyline of order 4, and so on. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) NK, the number of points defining the polyline. -! -! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyline. -! -! Output, real ( kind = 8 ) LENGTH, the length of the polyline. -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) nk - - integer(kind=4) i - real(kind=8) length - real(kind=8) pk(dim_num, nk) - - length = 0.0D+00 - - do i = 2, nk - - length = length & - + sqrt(sum((pk(1:dim_num, i) - pk(1:dim_num, i - 1))**2)) - - end do - - return -end -subroutine polyline_points_nd(dim_num, n, p, nt, pt) - -!*****************************************************************************80 -! -!! POLYLINE_POINTS_ND computes equally spaced points on a polyline in ND. -! -! Discussion: -! -! A polyline of order N is the geometric structure consisting of -! the N-1 line segments that lie between successive elements of a list -! of N points. -! -! An ordinary line segment is a polyline of order 2. -! The letter "V" is a polyline of order 3. -! The letter "N" is a polyline of order 4, and so on. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) N, the number of points defining the polyline. -! -! Input, real ( kind = 8 ) P(DIM_NUM,N), the points defining the polyline. -! -! Input, integer ( kind = 4 ) NT, the number of points to be sampled. -! -! Output, real ( kind = 8 ) PT(DIM_NUM,NT), equally spaced points -! on the polyline. -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) n - integer(kind=4) nt - - integer(kind=4) it - integer(kind=4) j - real(kind=8) p(dim_num, n) - real(kind=8) pt(dim_num, nt) - real(kind=8) s(n) - real(kind=8) st - - call polyline_arclength_nd(dim_num, n, p, s) - - j = 1 - - do it = 1, nt - - st = (real(nt - it, kind=8) * 0.0D+00 + & - real(it - 1, kind=8) * s(n)) & - / real(nt - 1, kind=8) - - do - - if (s(j) <= st .and. st <= s(j + 1)) then - exit - end if - - if (n - 1 <= j) then - exit - end if - - j = j + 1 - - end do - - pt(1:dim_num, it) = ((s(j + 1) - st) * p(1:dim_num, j) & - + (st - s(j)) * p(1:dim_num, j + 1)) & - / (s(j + 1) - s(j)) - - end do - - return -end -subroutine polyloop_arclength_nd(dim_num, nk, pk, sk) - -!*****************************************************************************80 -! -!! POLYLOOP_ARCLENGTH_ND computes the arclength of points on a polyloop in ND. -! -! Discussion: -! -! A polyloop of order NK is the geometric structure consisting of -! the NK line segments that lie between successive elements of a list -! of NK points, with the last point joined to the first. -! -! Warning: I just made up the word "polyloop", so don't go repeating it! -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) NK, the number of points defining the polyloop. -! -! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyloop. -! -! Output, real ( kind = 8 ) SK(NK+1), the arclength coordinates -! of each point. The first point has two arc length values, -! namely SK(1) = 0 and SK(NK+1) = LENGTH. -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) nk - - integer(kind=4) i - integer(kind=4) j - real(kind=8) pk(dim_num, nk) - real(kind=8) sk(nk + 1) - - sk(1) = 0.0D+00 - - do i = 2, nk + 1 - - if (i <= nk) then - j = i - else - j = 1 - end if - - sk(i) = sk(i - 1) & - + sqrt(sum((pk(1:dim_num, j) - pk(1:dim_num, i - 1))**2)) - - end do - - return -end -subroutine polyloop_length_nd(dim_num, nk, pk, length) - -!*****************************************************************************80 -! -!! POLYLOOP_LENGTH_ND computes the length of a polyloop in ND. -! -! Discussion: -! -! A polyloop of order NK is the geometric structure consisting of -! the NK line segments that lie between successive elements of a list -! of NK points, with the last point joined to the first. -! -! Warning: I just made up the word "polyloop", so don't go repeating it! -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) NK, the number of points defining the polyloop. -! -! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyloop. -! -! Output, real ( kind = 8 ) LENGTH, the length of the polyloop. -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) nk - - integer(kind=4) i - integer(kind=4) j - real(kind=8) length - real(kind=8) pk(dim_num, nk) - - length = 0.0D+00 - - do i = 2, nk + 1 - - if (i <= nk) then - j = i - else - j = 1 - end if - - length = length & - + sqrt(sum((pk(1:dim_num, j) - pk(1:dim_num, i - 1))**2)) - - end do - - return -end -subroutine polyloop_points_nd(dim_num, nk, pk, nt, pt) - -!*****************************************************************************80 -! -!! POLYLOOP_POINTS_ND computes equally spaced points on a polyloop in ND. -! -! Discussion: -! -! A polyloop of order NK is the geometric structure consisting of -! the NK line segments that lie between successive elements of a list -! of NK points, including a segment from the last point to the first. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) NK, the number of points defining the polyloop. -! -! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyloop. -! -! Input, integer ( kind = 4 ) NT, the number of points to be sampled. -! -! Input, real ( kind = 8 ) PT(DIM_NUM,NT), equally spaced points -! on the polyloop. -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) nk - integer(kind=4) nt - - integer(kind=4) it - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) pk(dim_num, nk) - real(kind=8) pt(dim_num, nt) - real(kind=8) sk(nk + 1) - real(kind=8) st - - call polyloop_arclength_nd(dim_num, nk, pk, sk) - - j = 1 - - do it = 1, nt - - st = (real(nt - it, kind=8) * 0.0D+00 + & - real(it - 1, kind=8) * sk(nk + 1)) & - / real(nt - 1, kind=8) - - do - - if (sk(j) <= st .and. st <= sk(j + 1)) then - exit - end if - - if (nk <= j) then - exit - end if - - j = j + 1 - - end do - - jp1 = i4_wrap(j + 1, 1, nk) - - pt(1:dim_num, it) = ((sk(j + 1) - st) * pk(1:dim_num, j) & - + (st - sk(j)) * pk(1:dim_num, jp1)) & - / (sk(j + 1) - sk(j)) - - end do - - return -end -subroutine provec(m, n, base, vecm, vecn, vecnm) - -!*****************************************************************************80 -! -!! PROVEC projects a vector from M space into N space. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the dimension of the higher order space. -! -! Input, integer ( kind = 4 ) N, the dimension of the lower order space. -! -! Input, real ( kind = 8 ) BASE(M,N). The columns of BASE contain -! N vectors, each of length M, which form the basis for -! a space of dimension N. -! -! Input, real ( kind = 8 ) VECM(M), is an M dimensional vector. -! -! Output, real ( kind = 8 ) VECN(N), the projection of VECM into the -! lower dimensional space. These values represent -! coordinates in the lower order space. -! -! Output, real ( kind = 8 ) VECNM(M), the projection of VECM into the -! lower dimensional space, but using coordinates in -! the higher dimensional space. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - real(kind=8) base(m, n) - integer(kind=4) i - integer(kind=4) j - real(kind=8) temp - real(kind=8) vecm(m) - real(kind=8) vecn(n) - real(kind=8) vecnm(m) -! -! For each vector, remove all projections onto previous vectors, -! and then normalize. This should result in a matrix BASE -! whose columns are orthonormal. -! - do j = 1, n - - do i = 1, j - 1 - - temp = dot_product(base(1:m, i), base(1:m, j)) - - base(1:m, j) = base(1:m, j) - temp * base(1:m, i) - - end do - - temp = sqrt(sum(base(1:m, j)**2)) - - if (0.0D+00 < temp) then - base(1:m, j) = base(1:m, j) / temp - end if - - end do -! -! Compute the coordinates of the projection of the vector -! simply by taking dot products. -! - do j = 1, n - vecn(j) = dot_product(vecm(1:m), base(1:m, j)) - end do -! -! Compute the coordinates of the projection in terms of -! the original space. -! - do i = 1, m - vecnm(i) = dot_product(base(i, 1:n), vecn(1:n)) - end do - - return -end -subroutine pyramid_volume_3d(h, s, volume) - -!*****************************************************************************80 -! -!! PYRAMID_VOLUME_3D computes the volume of a pyramid with square base in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 November 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) H, S, the height of the pyramid, and the -! length of one side of the square base. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the pyramid. -! - implicit none - - real(kind=8) h - real(kind=8) s - real(kind=8) volume - - volume = s * s * h / 3.0D+00 - - return -end -function pyramid01_volume() - -!*****************************************************************************80 -! -!! PYRAMID01_VOLUME returns the volume of a unit pyramid. -! -! Discussion: -! -! A pyramid with square base can be regarded as the upper half of a -! 3D octahedron. -! -! The integration region: -! -! - ( 1 - Z ) <= X <= 1 - Z -! - ( 1 - Z ) <= Y <= 1 - Z -! 0 <= Z <= 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) VALUE, the volume of the pyramid. -! - implicit none - - real(kind=8) pyramid01_volume - real(kind=8) volume - - volume = 4.0D+00 / 3.0D+00 - - pyramid01_volume = volume - - return -end -subroutine quad_area_2d(q, area) - -!*****************************************************************************80 -! -!! QUAD_AREA_2D computes the area of a quadrilateral in 2D. -! -! Discussion: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! This algorithm should be able to handle nonconvex quadrilaterals. -! -! The vertices of the quadrilateral should be listed in counter clockwise -! order, so that the area is positive. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Q(2,4), the vertices, specified in -! counter clockwise order. -! -! Output, real ( kind = 8 ) AREA, the area of the quadrilateral. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) area - real(kind=8) area_triangle - real(kind=8) q(dim_num, 4) - real(kind=8) t(dim_num, 3) - - area = 0.0D+00 - - t(1:dim_num, 1:3) = reshape((/ & - q(1:2, 1), q(1:2, 2), q(1:2, 3)/), (/dim_num, 3/)) - - call triangle_area_2d(t, area_triangle) - - area = area + area_triangle - - t(1:dim_num, 1:3) = reshape((/ & - q(1:2, 3), q(1:2, 4), q(1:2, 1)/), (/dim_num, 3/)) - - call triangle_area_2d(t, area_triangle) - - area = area + area_triangle - - return -end -subroutine quad_area2_2d(q, area) - -!*****************************************************************************80 -! -!! QUAD_AREA2_2D computes the area of a quadrilateral in 2D. -! -! Discussion: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! This algorithm computes the area of the related -! Varignon parallelogram first. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 May 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Q(2,4), the vertices, specified in -! counter clockwise order. -! -! Output, real ( kind = 8 ) AREA, the area of the quadrilateral. -! - implicit none - - real(kind=8) area - real(kind=8) p(2, 4) - real(kind=8) q(2, 4) -! -! Define a parallelogram by averaging consecutive vertices. -! - p(1:2, 1:3) = (q(1:2, 1:3) + q(1:2, 2:4)) / 2.0D+00 - p(1:2, 4) = (q(1:2, 4) + q(1:2, 1)) / 2.0D+00 -! -! Compute the area. -! - call parallelogram_area_2d(p, area) -! -! The quadrilateral's area is twice that of the parallelogram. -! - area = 2.0D+00 * area - - return -end -subroutine quad_area_3d(q, area) - -!*****************************************************************************80 -! -!! QUAD_AREA_3D computes the area of a quadrilateral in 3D. -! -! Discussion: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! It is assumed that the four vertices of the quadrilateral -! are coplanar. -! -! This algorithm computes the area of the related -! Varignon parallelogram first. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 May 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Q(3,4), the vertices, specified in -! counter clockwise order. -! -! Output, real ( kind = 8 ) AREA, the area of the quadrilateral. -! - implicit none - - real(kind=8) area - real(kind=8) p(3, 4) - real(kind=8) q(3, 4) -! -! Define a parallelogram by averaging consecutive vertices. -! - p(1:3, 1:3) = (q(1:3, 1:3) + q(1:3, 2:4)) / 2.0D+00 - p(1:3, 4) = (q(1:3, 4) + q(1:3, 1)) / 2.0D+00 -! -! Compute the area. -! - call parallelogram_area_3d(p, area) -! -! The quadrilateral's area is twice that of the parallelogram. -! - area = 2.0D+00 * area - - return -end -subroutine quad_contains_point_2d(q, p, inside) - -!*****************************************************************************80 -! -!! QUAD_CONTAINS_POINT_2D: is point inside a convex quadrilateral in 2D. -! -! Discussion: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Q(2,4), the vertices of the quadrilateral. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is in the -! quadrilateral. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle_1 - real(kind=8) angle_2 - real(kind=8) angle_rad_2d - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) q(dim_num, 4) -! -! This will only handle convex quadrilaterals. -! - inside = .false. - - angle_1 = angle_rad_2d(q(1:2, 1), q(1:2, 2), q(1:2, 3)) - angle_2 = angle_rad_2d(q(1:2, 1), q(1:2, 2), p(1:2)) - - if (angle_1 < angle_2) then - return - end if - - angle_1 = angle_rad_2d(q(1:2, 2), q(1:2, 3), q(1:2, 4)) - angle_2 = angle_rad_2d(q(1:2, 2), q(1:2, 3), p(1:2)) - - if (angle_1 < angle_2) then - return - end if - - angle_1 = angle_rad_2d(q(1:2, 3), q(1:2, 4), q(1:2, 1)) - angle_2 = angle_rad_2d(q(1:2, 3), q(1:2, 4), p(1:2)) - - if (angle_1 < angle_2) then - return - end if - - angle_1 = angle_rad_2d(q(1:2, 4), q(1:2, 1), q(1:2, 2)) - angle_2 = angle_rad_2d(q(1:2, 4), q(1:2, 1), p(1:2)) - - if (angle_1 < angle_2) then - return - end if - - inside = .true. - - return -end -subroutine quad_convex_random(seed, xy) - -!*****************************************************************************80 -! -!! QUAD_CONVEX_RANDOM returns a random convex quadrilateral. -! -! Description: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! The quadrilateral is constrained in that the vertices must all lie -! with the unit square. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 June 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) XY(2,NODE_NUM), the coordinates of the -! nodes of the quadrilateral, given in counterclockwise order. -! - implicit none - - integer(kind=4), parameter :: node_num = 4 - - integer(kind=4) hull(node_num) - integer(kind=4) hull_num - integer(kind=4) j - integer(kind=4) seed - real(kind=8) xy(2, node_num) - real(kind=8) xy_random(2, node_num) - - do -! -! Generate 4 random points. -! - call r8mat_uniform_01(2, node_num, seed, xy_random) -! -! Determine the convex hull. -! - call points_hull_2d(node_num, xy_random, hull_num, hull) -! -! If HULL_NUM < NODE_NUM, then our convex hull is a triangle. -! Try again. -! - if (hull_num == node_num) then - exit - end if - - end do -! -! Make an ordered copy of the random points. -! - do j = 1, node_num - xy(1:2, j) = xy_random(1:2, hull(j)) - end do - - return -end -subroutine quad_point_dist_2d(q, p, dist) - -!*****************************************************************************80 -! -!! QUAD_POINT_DIST_2D: distance ( quadrilateral, point ) in 2D. -! -! Discussion: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Q(2,4), the quadrilateral vertices. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! quadrilateral. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4), parameter :: side_num = 4 - - real(kind=8) dist - real(kind=8) dist2 - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) p(dim_num) - real(kind=8) q(dim_num, side_num) -! -! Find the distance to each of the line segments. -! - dist = huge(dist) - - do j = 1, side_num - - jp1 = i4_wrap(j + 1, 1, side_num) - - call segment_point_dist_2d(q(1:dim_num, j), q(1:dim_num, jp1), p, dist2) - - if (dist2 < dist) then - dist = dist2 - end if - - end do - - return -end -subroutine quad_point_dist_signed_2d(q, p, dist_signed) - -!*****************************************************************************80 -! -!! QUAD_POINT_DIST_SIGNED_2D: signed distance ( quadrilateral, point ) in 2D. -! -! Discussion: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! The quadrilateral must be convex. DIST_SIGNED is actually the maximum -! of the signed distances from the point to each of the four lines that -! make up the quadrilateral. -! -! Essentially, if the point is outside the convex quadrilateral, -! only one of the signed distances can be positive, or two can -! be positive and equal. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Q(2,4), the vertices of the quadrilateral. -! -! Input, real ( kind = 8 ) P(2), the point which is to be checked. -! -! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the -! point to the convex quadrilateral. If DIST_SIGNED is -! 0.0, the point is on the boundary; -! negative, the point is in the interior; -! positive, the point is in the exterior. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dis - real(kind=8) dis12 - real(kind=8) dis23 - real(kind=8) dis34 - real(kind=8) dis41 - real(kind=8) dist_signed - real(kind=8) p(dim_num) - real(kind=8) pm(dim_num) - real(kind=8) q(dim_num, 4) -! -! Compare the signed distance from each line segment to the point, -! with the signed distance to the midpoint of the opposite line. -! -! The signed distances should all be negative if the point is inside. -! -! Side 12 -! - call line_exp_point_dist_signed_2d(q(1:2, 1), q(1:2, 2), p, dis12) - - pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 3) + q(1:dim_num, 4)) - - call line_exp_point_dist_signed_2d(q(1:2, 1), q(1:2, 2), pm, dis) - - if (0.0D+00 < dis) then - dis = -dis - dis12 = -dis12 - end if -! -! Side 23 -! - call line_exp_point_dist_signed_2d(q(1:2, 2), q(1:2, 3), p, dis23) - - pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 4) + q(1:dim_num, 1)) - - call line_exp_point_dist_signed_2d(q(1:2, 2), q(1:2, 3), pm, dis) - - if (0.0D+00 < dis) then - dis = -dis - dis23 = -dis23 - end if -! -! Side 34 -! - call line_exp_point_dist_signed_2d(q(1:2, 3), q(1:2, 4), p, dis34) - - pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 1) + q(1:dim_num, 2)) - - call line_exp_point_dist_signed_2d(q(1:2, 3), q(1:2, 4), pm, dis) - - if (0.0D+00 < dis) then - dis = -dis - dis34 = -dis34 - end if -! -! Side 41 -! - call line_exp_point_dist_signed_2d(q(1:2, 4), q(1:2, 1), p, dis41) - - pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 2) + q(1:dim_num, 3)) - - call line_exp_point_dist_signed_2d(q(1:2, 4), q(1:2, 1), pm, dis) - - if (0.0D+00 < dis) then - dis = -dis - dis41 = -dis41 - end if - - dist_signed = max(dis12, dis23, dis34, dis41) - - return -end -subroutine quad_point_near_2d(q, p, pn, dist) - -!*****************************************************************************80 -! -!! QUAD_POINT_NEAR_2D computes the nearest point on a quadrilateral in 2D. -! -! Discussion: -! -! A quadrilateral is a polygon defined by 4 vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Q(2,4), the quadrilateral vertices. -! -! Input, real ( kind = 8 ) P(2), the point whose nearest quadrilateral point -! is to be determined. -! -! Output, real ( kind = 8 ) PN(2), the nearest point to P. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! quadrilateral. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4), parameter :: side_num = 4 - - real(kind=8) dist - real(kind=8) dist2 - integer(kind=4) i4_wrap - integer(kind=4) j - integer(kind=4) jp1 - real(kind=8) p(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) pn2(dim_num) - real(kind=8) q(dim_num, side_num) - real(kind=8) tval -! -! Find the distance to each of the line segments that make up the edges -! of the quadrilateral. -! - dist = huge(dist) - pn(1:dim_num) = 0.0D+00 - - do j = 1, side_num - - jp1 = i4_wrap(j + 1, 1, side_num) - - call segment_point_near_2d(q(1:dim_num, j), q(1:dim_num, jp1), p, & - pn2, dist2, tval) - - if (dist2 < dist) then - dist = dist2 - pn(1:dim_num) = pn2(1:dim_num) - end if - - end do - - return -end -function r8_acos(c) - -!*****************************************************************************80 -! -!! R8_ACOS computes the arc cosine function, with argument truncation. -! -! Discussion: -! -! If you call your system ACOS routine with an input argument that is -! even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant -! surprise (I did). -! -! This routine simply truncates arguments outside the range. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 2012 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) C, the argument. -! -! Output, real ( kind = 8 ) R8_ACOS, an angle whose cosine is C. -! - implicit none - - real(kind=8) c - real(kind=8) c2 - real(kind=8) r8_acos - - c2 = c - c2 = max(c2, -1.0D+00) - c2 = min(c2, +1.0D+00) - - r8_acos = acos(c2) - - return -end -function r8_asin(s) - -!*****************************************************************************80 -! -!! R8_ASIN computes the arc sine function, with argument truncation. -! -! Discussion: -! -! If you call your system ASIN routine with an input argument that is -! even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant -! surprise (I did). -! -! This routine simply truncates arguments outside the range. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) S, the argument. -! -! Output, real ( kind = 8 ) R8_ASIN, an angle whose sine is S. -! - implicit none - - real(kind=8) r8_asin - real(kind=8) s - real(kind=8) s2 - - s2 = s - s2 = max(s2, -1.0D+00) - s2 = min(s2, +1.0D+00) - - r8_asin = asin(s2) - - return -end -function r8_atan(y, x) - -!*****************************************************************************80 -! -!! R8_ATAN computes the inverse tangent of the ratio Y / X. -! -! Discussion: -! -! R8_ATAN returns an angle whose tangent is ( Y / X ), a job which -! the built in functions ATAN and ATAN2 already do. -! -! However: -! -! * R8_ATAN always returns a positive angle, between 0 and 2 PI, -! while ATAN and ATAN2 return angles in the interval [-PI/2,+PI/2] -! and [-PI,+PI] respectively; -! -! * R8_ATAN accounts for the signs of X and Y, (as does ATAN2). The ATAN -! function by contrast always returns an angle in the first or fourth -! quadrants. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) Y, X, two quantities which represent the -! tangent of an angle. If Y is not zero, then the tangent is (Y/X). -! -! Output, real ( kind = 8 ) R8_ATAN, an angle between 0 and 2 * PI, whose -! tangent is (Y/X), and which lies in the appropriate quadrant so that -! the signs of its cosine and sine match those of X and Y. -! - implicit none - - real(kind=8) abs_x - real(kind=8) abs_y - real(kind=8) r8_atan - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - real(kind=8) theta_0 - real(kind=8) x - real(kind=8) y -! -! Special cases: -! - if (x == 0.0D+00) then - - if (0.0D+00 < y) then - theta = r8_pi / 2.0D+00 - else if (y < 0.0D+00) then - theta = 3.0D+00 * r8_pi / 2.0D+00 - else if (y == 0.0D+00) then - theta = 0.0D+00 - end if - - else if (y == 0.0D+00) then - - if (0.0D+00 < x) then - theta = 0.0D+00 - else if (x < 0.0D+00) then - theta = r8_pi - end if -! -! We assume that ATAN2 is correct when both arguments are positive. -! - else - - abs_y = abs(y) - abs_x = abs(x) - - theta_0 = atan2(abs_y, abs_x) - - if (0.0D+00 < x .and. 0.0D+00 < y) then - theta = theta_0 - else if (x < 0.0D+00 .and. 0.0D+00 < y) then - theta = r8_pi - theta_0 - else if (x < 0.0D+00 .and. y < 0.0D+00) then - theta = r8_pi + theta_0 - else if (0.0D+00 < x .and. y < 0.0D+00) then - theta = 2.0D+00 * r8_pi - theta_0 - end if - - end if - - r8_atan = theta - - return -end -function r8_cosd(degrees) - -!*****************************************************************************80 -! -!! R8_COSD returns the cosine of an angle given in degrees. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 July 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DEGREES, the angle in degrees. -! -! Output, real ( kind = 8 ) R8_COSD, the cosine of the angle. -! - implicit none - - real(kind=8) degrees - real(kind=8) r8_cosd - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radians - - radians = r8_pi * (degrees / 180.0D+00) - r8_cosd = cos(radians) - - return -end -function r8_cotd(degrees) - -!*****************************************************************************80 -! -!! R8_COTD returns the cotangent of an angle given in degrees. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 July 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DEGREES, the angle in degrees. -! -! Output, real ( kind = 8 ) R8_COTD, the cotangent of the angle. -! - implicit none - - real(kind=8) degrees - real(kind=8) r8_cotd - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radians - - radians = r8_pi * (degrees / 180.0D+00) - r8_cotd = cos(radians) / sin(radians) - - return -end -function r8_cscd(degrees) - -!*****************************************************************************80 -! -!! R8_CSCD returns the cosecant of an angle given in degrees. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 July 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DEGREES, the angle in degrees. -! -! Output, real ( kind = 8 ) R8_CSCD, the cosecant of the angle. -! - implicit none - - real(kind=8) degrees - real(kind=8) r8_cscd - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radians - - radians = r8_pi * (degrees / 180.0D+00) - r8_cscd = 1.0D+00 / sin(radians) - - return -end -function r8_huge() - -!*****************************************************************************80 -! -!! R8_HUGE returns a very large R8. -! -! Discussion: -! -! The value returned by this function is NOT required to be the -! maximum representable R8. This value varies from machine to machine, -! from compiler to compiler, and may cause problems when being printed. -! We simply want a "very large" but non-infinite number. -! -! FORTRAN90 provides a built-in routine HUGE ( X ) that -! can return the maximum representable number of the same datatype -! as X, if that is what is really desired. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 October 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) R8_HUGE, a "huge" value. -! - implicit none - - real(kind=8) r8_huge - - r8_huge = 1.0D+30 - - return -end -function r8_is_int(r) - -!*****************************************************************************80 -! -!! R8_IS_INT determines if a real number represents an integer value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 March 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the number to be checked. -! -! Output, logical ( kind = 4 ) R8_IS_INT, is TRUE if R is an integer value. -! - implicit none - - integer(kind=4) i - real(kind=8) r - logical(kind=4) r8_is_int - - if (real(huge(i), kind=8) < r) then - r8_is_int = .false. - else if (r < -real(huge(i), kind=8)) then - r8_is_int = .false. - else if (r == real(int(r), kind=8)) then - r8_is_int = .true. - else - r8_is_int = .false. - end if - - return -end -function r8_modp(x, y) - -!*****************************************************************************80 -! -!! R8_MODP returns the nonnegative remainder of real division. -! -! Discussion: -! -! If -! REM = R8_MODP ( X, Y ) -! RMULT = ( X - REM ) / Y -! then -! X = Y * RMULT + REM -! where REM is always nonnegative. -! -! The MOD function computes a result with the same sign as the -! quantity being divided. Thus, suppose you had an angle A, -! and you wanted to ensure that it was between 0 and 360. -! Then mod(A,360.0) would do, if A was positive, but if A -! was negative, your result would be between -360 and 0. -! -! On the other hand, R8_MODP(A,360.0) is between 0 and 360, always. -! -! Example: -! -! I J MOD R8_MODP R8_MODP Factorization -! -! 107 50 7 7 107 = 2 * 50 + 7 -! 107 -50 7 7 107 = -2 * -50 + 7 -! -107 50 -7 43 -107 = -3 * 50 + 43 -! -107 -50 -7 43 -107 = 3 * -50 + 43 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 July 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) X, the number to be divided. -! -! Input, real ( kind = 8 ) Y, the number that divides X. -! -! Output, real ( kind = 8 ) R8_MODP, the nonnegative remainder -! when X is divided by Y. -! - implicit none - - real(kind=8) r8_modp - real(kind=8) x - real(kind=8) y - - if (y == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8_MODP - Fatal error!' - write (*, '(a,g14.6)') ' R8_MODP ( X, Y ) called with Y = ', y - stop 1 - end if - - r8_modp = mod(x, y) - - if (r8_modp < 0.0D+00) then - r8_modp = r8_modp + abs(y) - end if - - return -end -function r8_normal_01(seed) - -!*****************************************************************************80 -! -!! R8_NORMAL_01 returns a unit pseudonormal R8. -! -! Discussion: -! -! The standard normal probability distribution function (PDF) has -! mean 0 and standard deviation 1. -! -! Because this routine uses the Box Muller method, it requires pairs -! of uniform random values to generate a pair of normal random values. -! This means that on every other call, essentially, the input value of -! SEED is ignored, since the code saves the second normal random value. -! -! If you didn't know this, you might be confused since, usually, the -! output of a random number generator can be completely controlled by -! the input value of the SEED. If I were more careful, I could rewrite -! this routine so that it would distinguish between cases where the input -! value of SEED is the output value from the previous call (all is well) -! and those cases where it is not (the user has decided to do something -! new. Restart the uniform random number sequence.) But I'll leave -! that for later. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 July 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) R8_NORMAL_01, a sample of the standard -! normal PDF. -! - implicit none - - real(kind=8) r1 - real(kind=8) r2 - real(kind=8) r8_normal_01 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r8_uniform_01 - integer(kind=4) seed - integer(kind=4), save :: seed2 = 0 - integer(kind=4), save :: used = 0 - real(kind=8) x - real(kind=8), save :: y = 0.0D+00 -! -! On odd numbered calls, generate two uniforms, create two normals, -! return the first normal and its corresponding seed. -! - if (mod(used, 2) == 0) then - - r1 = r8_uniform_01(seed) - - if (r1 == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8_NORMAL_01 - Fatal error!' - write (*, '(a)') ' R8_UNIFORM_01 returned a value of 0.' - stop 1 - end if - - seed2 = seed - r2 = r8_uniform_01(seed2) - - x = sqrt(-2.0D+00 * log(r1)) * cos(2.0D+00 * r8_pi * r2) - y = sqrt(-2.0D+00 * log(r1)) * sin(2.0D+00 * r8_pi * r2) -! -! On odd calls, return the second normal and its corresponding seed. -! - else - - seed = seed2 - x = y - - end if - - used = used + 1 - - r8_normal_01 = x - - return -end -function r8_pi() - -!*****************************************************************************80 -! -!! R8_PI returns the value of pi. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 December 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) R8_PI, the value of pi. -! - implicit none - - real(kind=8) r8_pi - - r8_pi = 3.141592653589793D+00 - - return -end -function r8_sign_opposite_strict(r1, r2) - -!*****************************************************************************80 -! -!! R8_SIGN_OPPOSITE_STRICT is TRUE if two R8's are strictly of opposite sign. -! -! Discussion: -! -! This test could be coded numerically as -! -! if ( r1 * r2 < 0.0 ) then ... -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 23 June 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the values to check. -! -! Output, logical ( kind = 4 ) R8_SIGN_OPPOSITE_STRICT, is TRUE -! if ( R1 < 0 and 0 < R2 ) or ( R2 < 0 and 0 < R1 ). -! - implicit none - - real(kind=8) r1 - real(kind=8) r2 - logical(kind=4) r8_sign_opposite_strict - - r8_sign_opposite_strict = (r1 < 0.0D+00 .and. 0.0D+00 < r2) .or. & - (r2 < 0.0D+00 .and. 0.0D+00 < r1) - - return -end -function r8_sind(degrees) - -!*****************************************************************************80 -! -!! R8_SIND returns the sine of an angle given in degrees. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 July 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DEGREES, the angle in degrees. -! -! Output, real ( kind = 8 ) R8_SIND, the sine of the angle. -! - implicit none - - real(kind=8) degrees - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r8_sind - real(kind=8) radians - - radians = r8_pi * (degrees / 180.0D+00) - r8_sind = sin(radians) - - return -end -function r8_secd(degrees) - -!*****************************************************************************80 -! -!! R8_SECD returns the secant of an angle given in degrees. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 July 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DEGREES, the angle in degrees. -! -! Output, real ( kind = 8 ) R8_SECD, the secant of the angle. -! - implicit none - - real(kind=8) degrees - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r8_secd - real(kind=8) radians - - radians = r8_pi * (degrees / 180.0D+00) - r8_secd = 1.0D+00 / cos(radians) - - return -end -subroutine r8_swap(x, y) - -!*****************************************************************************80 -! -!! R8_SWAP switches two R8's. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 May 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, real ( kind = 8 ) X, Y. On output, the values of X and -! Y have been interchanged. -! - implicit none - - real(kind=8) x - real(kind=8) y - real(kind=8) z - - z = x - x = y - y = z - - return -end -function r8_tand(degrees) - -!*****************************************************************************80 -! -!! R8_TAND returns the tangent of an angle given in degrees. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 July 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DEGREES, the angle in degrees. -! -! Output, real ( kind = 8 ) R8_TAND, the tangent of the angle. -! - implicit none - - real(kind=8) degrees - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r8_tand - real(kind=8) radians - - radians = r8_pi * (degrees / 180.0D+00) - r8_tand = tan(radians) - - return -end -function r8_uniform(a, b, seed) - -!*****************************************************************************80 -! -!! R8_UNIFORM returns a scaled pseudorandom R8. -! -! Discussion: -! -! An R8 is a real ( kind = 8 ) value. -! -! For now, the input quantity SEED is an integer ( kind = 4 ) variable. -! -! The pseudorandom number should be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 July 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should -! NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R8_UNIFORM, a number strictly between A and B. -! - implicit none - - real(kind=8) a - real(kind=8) b - integer(kind=4) k - real(kind=8) r8_uniform - integer(kind=4) seed - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8_UNIFORM - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if - - r8_uniform = a + (b - a) * real(seed, kind=8) * 4.656612875D-10 - - return -end -function r8_uniform_01(seed) - -!*****************************************************************************80 -! -!! R8_UNIFORM_01 returns a unit pseudorandom R8. -! -! Discussion: -! -! An R8 is a real ( kind = 8 ) value. -! -! For now, the input quantity SEED is an integer ( kind = 4 ) variable. -! -! This routine implements the recursion -! -! seed = 16807 * seed mod ( 2^31 - 1 ) -! r8_uniform_01 = seed / ( 2^31 - 1 ) -! -! The integer arithmetic never requires more than 32 bits, -! including a sign bit. -! -! If the initial seed is 12345, then the first three computations are -! -! Input Output R8_UNIFORM_01 -! SEED SEED -! -! 12345 207482415 0.096616 -! 207482415 1790989824 0.833995 -! 1790989824 2035175616 0.947702 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 July 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should -! NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate, -! strictly between 0 and 1. -! - implicit none - - integer(kind=4) k - real(kind=8) r8_uniform_01 - integer(kind=4) seed - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8_UNIFORM_01 - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if -! -! Although SEED can be represented exactly as a 32 bit integer, -! it generally cannot be represented exactly as a 32 bit real number! -! - r8_uniform_01 = real(seed, kind=8) * 4.656612875D-10 - - return -end -subroutine r82vec_permute(n, p, a) - -!*****************************************************************************80 -! -!! R82VEC_PERMUTE permutes a R82 vector in place. -! -! Discussion: -! -! This routine permutes an array of real "objects", but the same -! logic can be used to permute an array of objects of any arithmetic -! type, or an array of objects of any complexity. The only temporary -! storage required is enough to store a single object. The number -! of data movements made is N + the number of cycles of order 2 or more, -! which is never more than N + N/2. -! -! Example: -! -! Input: -! -! N = 5 -! P = ( 2, 4, 5, 1, 3 ) -! A = ( 1.0, 2.0, 3.0, 4.0, 5.0 ) -! (11.0, 22.0, 33.0, 44.0, 55.0 ) -! -! Output: -! -! A = ( 2.0, 4.0, 5.0, 1.0, 3.0 ) -! ( 22.0, 44.0, 55.0, 11.0, 33.0 ). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 March 2011 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of objects. -! -! Input, integer ( kind = 4 ) P(N), the permutation. P(I) = J means -! that the I-th element of the output array should be the J-th -! element of the input array. P must be a legal permutation -! of the integers from 1 to N, otherwise the algorithm will -! fail catastrophically. -! -! Input/output, real ( kind = 8 ) A(2,N), the array to be permuted. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(2, n) - real(kind=8) a_temp(2) - integer(kind=4) iget - integer(kind=4) iput - integer(kind=4) istart - integer(kind=4) p(n) -! -! Search for the next element of the permutation that has not been used. -! - do istart = 1, n - - if (p(istart) < 0) then - - cycle - - else if (p(istart) == istart) then - - p(istart) = -p(istart) - cycle - - else - - a_temp(1:2) = a(1:2, istart) - iget = istart -! -! Copy the new value into the vacated entry. -! - do - - iput = iget - iget = p(iget) - - p(iput) = -p(iput) - - if (iget < 1 .or. n < iget) then - write (*, '(a)') ' ' - write (*, '(a)') 'R82VEC_PERMUTE - Fatal error!' - stop 1 - end if - - if (iget == istart) then - a(1:2, iput) = a_temp(1:2) - exit - end if - - a(1:2, iput) = a(1:2, iget) - - end do - - end if - - end do -! -! Restore the signs of the entries. -! - p(1:n) = -p(1:n) - - return -end -subroutine r82vec_sort_heap_index_a(n, a, indx) - -!*****************************************************************************80 -! -!! R82VEC_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R82VEC. -! -! Discussion: -! -! The sorting is not actually carried out. Rather an index array is -! created which defines the sorting. This array may be used to sort -! or index the array, or to sort or index related arrays keyed on the -! original array. -! -! Once the index array is computed, the sorting can be carried out -! "implicitly: -! -! A(1:2,INDX(I)), I = 1 to N is sorted, -! -! or explicitly, by the call -! -! call R82VEC_PERMUTE ( N, A, INDX ) -! -! after which A(1:2,I), I = 1 to N is sorted. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 January 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the array. -! -! Input, real ( kind = 8 ) A(2,N), an array to be index-sorted. -! -! Output, integer ( kind = 4 ) INDX(N), the sort index. The -! I-th element of the sorted array is A(1:2,INDX(I)). -! - implicit none - - integer(kind=4) n - - real(kind=8) a(2, n) - real(kind=8) aval(2) - integer(kind=4) i - integer(kind=4) indx(n) - integer(kind=4) indxt - integer(kind=4) ir - integer(kind=4) j - integer(kind=4) l - - if (n < 1) then - return - end if - - if (n == 1) then - indx(1) = 1 - return - end if - - call i4vec_indicator(n, indx) - - l = n / 2 + 1 - ir = n - - do - - if (1 < l) then - - l = l - 1 - indxt = indx(l) - aval(1:2) = a(1:2, indxt) - - else - - indxt = indx(ir) - aval(1:2) = a(1:2, indxt) - indx(ir) = indx(1) - ir = ir - 1 - - if (ir == 1) then - indx(1) = indxt - exit - end if - - end if - - i = l - j = l + l - - do while (j <= ir) - - if (j < ir) then - if (a(1, indx(j)) < a(1, indx(j + 1)) .or. & - (a(1, indx(j)) == a(1, indx(j + 1)) .and. & - a(2, indx(j)) < a(2, indx(j + 1)))) then - j = j + 1 - end if - end if - - if (aval(1) < a(1, indx(j)) .or. & - (aval(1) == a(1, indx(j)) .and. & - aval(2) < a(2, indx(j)))) then - indx(i) = indx(j) - i = j - j = j + j - else - j = ir + 1 - end if - - end do - - indx(i) = indxt - - end do - - return -end -subroutine r8ge_det(n, a, pivot, det) - -!*****************************************************************************80 -! -!! R8GE_DET computes the determinant of a matrix factored by R8GE_FA. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 March 2003 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Jack Dongarra, James Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979 -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the matrix. -! N must be positive. -! -! Input, real ( kind = 8 ) A(N,N), the LU factors computed by R8GE_FA. -! -! Input, integer ( kind = 4 ) PIVOT(N), as computed by R8GE_FA. -! -! Output, real ( kind = 8 ) DET, the determinant of the matrix. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(n, n) - real(kind=8) det - integer(kind=4) i - integer(kind=4) pivot(n) - - det = 1.0D+00 - - do i = 1, n - det = det * a(i, i) - if (pivot(i) /= i) then - det = -det - end if - end do - - return -end -subroutine r8ge_fa(n, a, pivot, info) - -!*****************************************************************************80 -! -!! R8GE_FA factors a general matrix. -! -! Discussion: -! -! R8GE_FA is a simplified version of the LINPACK routine DGEFA. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 February 2001 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Jack Dongarra, James Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979 -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the matrix. -! N must be positive. -! -! Input/output, real ( kind = 8 ) A(N,N), the matrix to be factored. -! On output, A contains an upper triangular matrix and the multipliers -! which were used to obtain it. The factorization can be written -! A = L * U, where L is a product of permutation and unit lower -! triangular matrices and U is upper triangular. -! -! Output, integer ( kind = 4 ) PIVOT(N), a vector of pivot indices. -! -! Output, integer ( kind = 4 ) INFO, singularity flag. -! 0, no singularity detected. -! nonzero, the factorization failed on the INFO-th step. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(n, n) - integer(kind=4) i - integer(kind=4) info - integer(kind=4) pivot(n) - integer(kind=4) j - integer(kind=4) k - integer(kind=4) l - real(kind=8) t - - info = 0 - - do k = 1, n - 1 -! -! Find L, the index of the pivot row. -! - l = k - do i = k + 1, n - if (abs(a(l, k)) < abs(a(i, k))) then - l = i - end if - end do - - pivot(k) = l -! -! If the pivot index is zero, the algorithm has failed. -! - if (a(l, k) == 0.0D+00) then - info = k - write (*, '(a)') ' ' - write (*, '(a)') 'R8GE_FA - Warning!' - write (*, '(a,i8)') ' Zero pivot on step ', info - return - end if -! -! Interchange rows L and K if necessary. -! - if (l /= k) then - t = a(l, k) - a(l, k) = a(k, k) - a(k, k) = t - end if -! -! Normalize the values that lie below the pivot entry A(K,K). -! - a(k + 1:n, k) = -a(k + 1:n, k) / a(k, k) -! -! Row elimination with column indexing. -! - do j = k + 1, n - - if (l /= k) then - t = a(l, j) - a(l, j) = a(k, j) - a(k, j) = t - end if - - a(k + 1:n, j) = a(k + 1:n, j) + a(k + 1:n, k) * a(k, j) - - end do - - end do - - pivot(n) = n - - if (a(n, n) == 0.0D+00) then - info = n - write (*, '(a)') ' ' - write (*, '(a)') 'R8GE_FA - Warning!' - write (*, '(a,i8)') ' Zero pivot on step ', info - end if - - return -end -subroutine r8ge_sl(n, a, pivot, b, job) - -!*****************************************************************************80 -! -!! R8GE_SL solves a system factored by R8GE_FA. -! -! Discussion: -! -! R8GE_SL is a simplified version of the LINPACK routine DGESL. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 March 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the matrix. -! N must be positive. -! -! Input, real ( kind = 8 ) A(N,N), the LU factors from R8GE_FA. -! -! Input, integer ( kind = 4 ) PIVOT(N), the pivot vector from R8GE_FA. -! -! Input/output, real ( kind = 8 ) B(N). -! On input, the right hand side vector. -! On output, the solution vector. -! -! Input, integer ( kind = 4 ) JOB, specifies the operation. -! 0, solve A * x = b. -! nonzero, solve A' * x = b. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(n, n) - real(kind=8) b(n) - integer(kind=4) pivot(n) - integer(kind=4) job - integer(kind=4) k - integer(kind=4) l -! -! Solve A * x = b. -! - if (job == 0) then -! -! Solve PL * Y = B. -! - do k = 1, n - 1 - - l = pivot(k) - - if (l /= k) then - call r8_swap(b(l), b(k)) - end if - - b(k + 1:n) = b(k + 1:n) + a(k + 1:n, k) * b(k) - - end do -! -! Solve U * X = Y. -! - do k = n, 1, -1 - b(k) = b(k) / a(k, k) - b(1:k - 1) = b(1:k - 1) - a(1:k - 1, k) * b(k) - end do -! -! Solve A' * X = B. -! - else -! -! Solve U' * Y = B. -! - do k = 1, n - b(k) = (b(k) - sum(b(1:k - 1) * a(1:k - 1, k))) / a(k, k) - end do -! -! Solve ( PL )' * X = Y. -! - do k = n - 1, 1, -1 - - b(k) = b(k) + sum(b(k + 1:n) * a(k + 1:n, k)) - - l = pivot(k) - - if (l /= k) then - call r8_swap(b(l), b(k)) - end if - - end do - - end if - - return -end -function r8mat_det_2d(a) - -!*****************************************************************************80 -! -!! R8MAT_DET_2D computes the determinant of a 2 by 2 matrix. -! -! Discussion: -! -! The determinant is the area spanned by the vectors making up the rows -! or columns of the matrix. -! -! R8MAT_DET_2D = A(1,1) * A(2,2) - A(1,2) * A(2,1). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(2,2), the matrix whose determinant is desired. -! -! Output, real ( kind = 8 ) R8MAT_DET_2D, the determinant of the matrix. -! - implicit none - - real(kind=8) a(2, 2) - real(kind=8) r8mat_det_2d - - r8mat_det_2d = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1) - - return -end -function r8mat_det_3d(a) - -!*****************************************************************************80 -! -!! R8MAT_DET_3D computes the determinant of a 3 by 3 matrix. -! -! Discussion: -! -! The determinant is the volume of the shape spanned by the vectors -! making up the rows or columns of the matrix. -! -! det = a11 * a22 * a33 - a11 * a23 * a32 -! + a12 * a23 * a31 - a12 * a21 * a33 -! + a13 * a21 * a32 - a13 * a22 * a31 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(3,3), the matrix whose determinant is desired. -! -! Output, real ( kind = 8 ) R8MAT_DET_3D, the determinant of the matrix. -! - implicit none - - real(kind=8) a(3, 3) - real(kind=8) r8mat_det_3d - - r8mat_det_3d = a(1, 1) * (a(2, 2) * a(3, 3) - a(2, 3) * a(3, 2)) & - + a(1, 2) * (a(2, 3) * a(3, 1) - a(2, 1) * a(3, 3)) & - + a(1, 3) * (a(2, 1) * a(3, 2) - a(2, 2) * a(3, 1)) - - return -end -function r8mat_det_4d(a) - -!*****************************************************************************80 -! -!! R8MAT_DET_4D computes the determinant of a 4 by 4 matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the matrix whose determinant is desired. -! -! Output, real ( kind = 8 ) R8MAT_DET_4D, the determinant of the matrix. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) r8mat_det_4d - - r8mat_det_4d = & - a(1, 1) * ( & - a(2, 2) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & - - a(2, 3) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & - + a(2, 4) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2))) & - - a(1, 2) * ( & - a(2, 1) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & - - a(2, 3) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & - + a(2, 4) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1))) & - + a(1, 3) * ( & - a(2, 1) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & - - a(2, 2) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & - + a(2, 4) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) & - - a(1, 4) * ( & - a(2, 1) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2)) & - - a(2, 2) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1)) & - + a(2, 3) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) - - return -end -function r8mat_det_5d(a) - -!*****************************************************************************80 -! -!! R8MAT_DET_5D computes the determinant of a 5 by 5 matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(5,5), the matrix whose determinant is desired. -! -! Output, real ( kind = 8 ) R8MAT_DET_5D, the determinant of the matrix. -! - implicit none - - real(kind=8) a(5, 5) - real(kind=8) b(4, 4) - real(kind=8) r8mat_det_4d - real(kind=8) r8mat_det_5d - integer(kind=4) i - integer(kind=4) inc - integer(kind=4) j - integer(kind=4) k -! -! Expand the determinant into the sum of the determinants of the -! five 4 by 4 matrices created by dropping row 1, and column k. -! - r8mat_det_5d = 0.0D+00 - - do k = 1, 5 - - do i = 1, 4 - do j = 1, 4 - - if (j < k) then - inc = 0 - else - inc = 1 - end if - - b(i, j) = a(i + 1, j + inc) - - end do - end do - - r8mat_det_5d = r8mat_det_5d + (-1)**(k + 1) * a(1, k) * r8mat_det_4d(b) - - end do - - return -end -subroutine r8mat_inverse_2d(a, b, det) - -!*****************************************************************************80 -! -!! R8MAT_INVERSE_2D inverts a 2 by 2 real matrix using Cramer's rule. -! -! Discussion: -! -! If DET is zero, then A is singular, and does not have an -! inverse. In that case, B is simply set to zero, and a -! message is printed. -! -! If DET is nonzero, then its value is roughly an estimate -! of how nonsingular the matrix A is. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(2,2), the matrix to be inverted. -! -! Output, real ( kind = 8 ) B(2,2), the inverse of the matrix A. -! -! Output, real ( kind = 8 ) DET, the determinant of the matrix A. -! - implicit none - - real(kind=8) a(2, 2) - real(kind=8) b(2, 2) - real(kind=8) det -! -! Compute the determinant. -! - det = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1) -! -! If the determinant is zero, bail out. -! - if (det == 0.0D+00) then - - b(1:2, 1:2) = 0.0D+00 - - return - end if -! -! Compute the entries of the inverse matrix using an explicit formula. -! - b(1, 1) = +a(2, 2) / det - b(1, 2) = -a(1, 2) / det - b(2, 1) = -a(2, 1) / det - b(2, 2) = +a(1, 1) / det - - return -end -subroutine r8mat_inverse_3d(a, b, det) - -!*****************************************************************************80 -! -!! R8MAT_INVERSE_3D inverts a 3 by 3 real matrix using Cramer's rule. -! -! Discussion: -! -! If DET is zero, then A is singular, and does not have an -! inverse. In that case, B is simply set to zero, and a -! message is printed. -! -! If DET is nonzero, then its value is roughly an estimate -! of how nonsingular the matrix A is. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(3,3), the matrix to be inverted. -! -! Output, real ( kind = 8 ) B(3,3), the inverse of the matrix A. -! -! Output, real ( kind = 8 ) DET, the determinant of the matrix A. -! - implicit none - - real(kind=8) a(3, 3) - real(kind=8) b(3, 3) - real(kind=8) det -! -! Compute the determinant of A -! - det = a(1, 1) * (a(2, 2) * a(3, 3) - a(2, 3) * a(3, 2)) & - + a(1, 2) * (a(2, 3) * a(3, 1) - a(2, 1) * a(3, 3)) & - + a(1, 3) * (a(2, 1) * a(3, 2) - a(2, 2) * a(3, 1)) -! -! If the determinant is zero, bail out. -! - if (det == 0.0D+00) then - - b(1:3, 1:3) = 0.0D+00 - - return - end if -! -! Compute the entries of the inverse matrix using an explicit -! formula. -! - b(1, 1) = +(a(2, 2) * a(3, 3) - a(2, 3) * a(3, 2)) / det - b(1, 2) = -(a(1, 2) * a(3, 3) - a(1, 3) * a(3, 2)) / det - b(1, 3) = +(a(1, 2) * a(2, 3) - a(1, 3) * a(2, 2)) / det - - b(2, 1) = -(a(2, 1) * a(3, 3) - a(2, 3) * a(3, 1)) / det - b(2, 2) = +(a(1, 1) * a(3, 3) - a(1, 3) * a(3, 1)) / det - b(2, 3) = -(a(1, 1) * a(2, 3) - a(1, 3) * a(2, 1)) / det - - b(3, 1) = +(a(2, 1) * a(3, 2) - a(2, 2) * a(3, 1)) / det - b(3, 2) = -(a(1, 1) * a(3, 2) - a(1, 2) * a(3, 1)) / det - b(3, 3) = +(a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1)) / det - - return -end -subroutine r8mat_print(m, n, a, title) - -!*****************************************************************************80 -! -!! R8MAT_PRINT prints a real matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the number of rows in A. -! -! Input, integer ( kind = 4 ) N, the number of columns in A. -! -! Input, real ( kind = 8 ) A(M,N), the matrix. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - real(kind=8) a(m, n) - character(len=*) title - - call r8mat_print_some(m, n, a, 1, 1, m, n, title) - - return -end -subroutine r8mat_print_some(m, n, a, ilo, jlo, ihi, jhi, title) - -!*****************************************************************************80 -! -!! R8MAT_PRINT_SOME prints some of an R8MAT. -! -! Discussion: -! -! An R8MAT is an array of R8 values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 September 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. -! -! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. -! -! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4), parameter :: incx = 5 - integer(kind=4) m - integer(kind=4) n - - real(kind=8) a(m, n) - character(len=14) ctemp(incx) - integer(kind=4) i - integer(kind=4) i2hi - integer(kind=4) i2lo - integer(kind=4) ihi - integer(kind=4) ilo - integer(kind=4) inc - integer(kind=4) j - integer(kind=4) j2 - integer(kind=4) j2hi - integer(kind=4) j2lo - integer(kind=4) jhi - integer(kind=4) jlo - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - - do j2lo = max(jlo, 1), min(jhi, n), incx - - j2hi = j2lo + incx - 1 - j2hi = min(j2hi, n) - j2hi = min(j2hi, jhi) - - inc = j2hi + 1 - j2lo - - write (*, '(a)') ' ' - - do j = j2lo, j2hi - j2 = j + 1 - j2lo - write (ctemp(j2), '(i8,6x)') j - end do - - write (*, '('' Col '',5a14)') ctemp(1:inc) - write (*, '(a)') ' Row' - write (*, '(a)') ' ' - - i2lo = max(ilo, 1) - i2hi = min(ihi, m) - - do i = i2lo, i2hi - - do j2 = 1, inc - - j = j2lo - 1 + j2 - - if (a(i, j) == real(int(a(i, j)), kind=8)) then - write (ctemp(j2), '(f8.0,6x)') a(i, j) - else - write (ctemp(j2), '(g14.6)') a(i, j) - end if - - end do - - write (*, '(i5,a,5a14)') i, ':', (ctemp(j), j=1, inc) - - end do - - end do - - return -end -subroutine r8mat_solve(n, rhs_num, a, info) - -!*****************************************************************************80 -! -!! R8MAT_SOLVE uses Gauss-Jordan elimination to solve an N by N linear system. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 August 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! 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. -! - implicit none - - integer(kind=4) n - integer(kind=4) rhs_num - - real(kind=8) a(n, n + rhs_num) - real(kind=8) apivot - real(kind=8) factor - integer(kind=4) i - integer(kind=4) info - integer(kind=4) ipivot - integer(kind=4) 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 r8_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 - - return -end -subroutine r8mat_solve_2d(a, b, det, x) - -!*****************************************************************************80 -! -!! R8MAT_SOLVE_2D solves a 2 by 2 linear system using Cramer's rule. -! -! Discussion: -! -! If DET is zero, then A is singular, and does not have an -! inverse. In that case, X is simply set to zero, and a -! message is printed. -! -! If DET is nonzero, then its value is roughly an estimate -! of how nonsingular the matrix A is. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 November 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(2,2), the matrix. -! -! Input, real ( kind = 8 ) B(2), the right hand side. -! -! Output, real ( kind = 8 ) DET, the determinant of the matrix A. -! -! Output, real ( kind = 8 ) X(2), the solution of the system, -! if DET is nonzero. -! - implicit none - - real(kind=8) a(2, 2) - real(kind=8) b(2) - real(kind=8) det - real(kind=8) x(2) -! -! Compute the determinant. -! - det = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1) -! -! If the determinant is zero, bail out. -! - if (det == 0.0D+00) then - x(1:2) = 0.0D+00 - return - end if -! -! Compute the solution. -! - x(1) = (a(2, 2) * b(1) - a(1, 2) * b(2)) / det - x(2) = (-a(2, 1) * b(1) + a(1, 1) * b(2)) / det - - return -end -subroutine r8mat_transpose_print(m, n, a, title) - -!*****************************************************************************80 -! -!! R8MAT_TRANSPOSE_PRINT prints a R8MAT, transposed. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 June 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - real(kind=8) a(m, n) - character(len=*) title - - call r8mat_transpose_print_some(m, n, a, 1, 1, m, n, title) - - return -end -subroutine r8mat_transpose_print_some(m, n, a, ilo, jlo, ihi, jhi, title) - -!*****************************************************************************80 -! -!! R8MAT_TRANSPOSE_PRINT_SOME prints some of an R8MAT, transposed. -! -! Discussion: -! -! An R8MAT is an array of R8 values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 September 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns. -! -! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. -! -! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. -! -! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4), parameter :: incx = 5 - integer(kind=4) m - integer(kind=4) n - - real(kind=8) a(m, n) - character(len=14) ctemp(incx) - integer(kind=4) i - integer(kind=4) i2 - integer(kind=4) i2hi - integer(kind=4) i2lo - integer(kind=4) ihi - integer(kind=4) ilo - integer(kind=4) inc - integer(kind=4) j - integer(kind=4) j2hi - integer(kind=4) j2lo - integer(kind=4) jhi - integer(kind=4) jlo - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - - do i2lo = max(ilo, 1), min(ihi, m), incx - - i2hi = i2lo + incx - 1 - i2hi = min(i2hi, m) - i2hi = min(i2hi, ihi) - - inc = i2hi + 1 - i2lo - - write (*, '(a)') ' ' - - do i = i2lo, i2hi - i2 = i + 1 - i2lo - write (ctemp(i2), '(i8,6x)') i - end do - - write (*, '('' Row '',5a14)') ctemp(1:inc) - write (*, '(a)') ' Col' - write (*, '(a)') ' ' - - j2lo = max(jlo, 1) - j2hi = min(jhi, n) - - do j = j2lo, j2hi - - do i2 = 1, inc - i = i2lo - 1 + i2 - write (ctemp(i2), '(g14.6)') a(i, j) - end do - - write (*, '(i5,a,5a14)') j, ':', (ctemp(i), i=1, inc) - - end do - - end do - - return -end -subroutine r8mat_uniform(m, n, a, b, seed, r) - -!*****************************************************************************80 -! -!! R8MAT_UNIFORM fills scaled pseudorandom R8MAT. -! -! Discussion: -! -! An R8MAT is an array of real ( kind = 8 ) values. -! -! For now, the input quantity SEED is an integer ( kind = 4 ) variable. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 July 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns -! in the array. -! -! Input, real ( kind = 8 ) A, B, the lower and upper limits. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - real(kind=8) a - real(kind=8) b - integer(kind=4) i - integer(kind=4) j - integer(kind=4) k - integer(kind=4) seed - real(kind=8) r(m, n) - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8MAT_UNIFORM - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - do j = 1, n - - do i = 1, m - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if - - r(i, j) = a + (b - a) * real(seed, kind=8) * 4.656612875D-10 - - end do - end do - - return -end -subroutine r8mat_uniform_01(m, n, seed, r) - -!*****************************************************************************80 -! -!! R8MAT_UNIFORM_01 returns a unit pseudorandom R8MAT. -! -! Discussion: -! -! An R8MAT is an array of real ( kind = 8 ) values. -! -! For now, the input quantity SEED is an integer ( kind = 4 ) variable. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 July 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, N, the number of rows and columns -! in the array. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values. -! - implicit none - - integer(kind=4) m - integer(kind=4) n - - integer(kind=4) i - integer(kind=4) j - integer(kind=4) k - integer(kind=4) seed - real(kind=8) r(m, n) - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8MAT_UNIFORM_01 - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - do j = 1, n - - do i = 1, m - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if - - r(i, j) = real(seed, kind=8) * 4.656612875D-10 - - end do - end do - - return -end -subroutine r8vec_angle_3d(u, v, angle) - -!*****************************************************************************80 -! -!! R8VEC_ANGLE_3D computes the angle between two vectors in 3D. -! -! Modified: -! -! 07 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) U(3), V(3), the vectors. -! -! Output, real ( kind = 8 ) ANGLE, the angle between the two vectors. -! - implicit none - - real(kind=8) angle - real(kind=8) angle_cos - real(kind=8) r8_acos - real(kind=8) u(3) - real(kind=8) u_norm - real(kind=8) uv_dot - real(kind=8) v(3) - real(kind=8) v_norm - - uv_dot = dot_product(u(1:3), v(1:3)) - - u_norm = sqrt(dot_product(u(1:3), u(1:3))) - - v_norm = sqrt(dot_product(v(1:3), v(1:3))) - - angle_cos = uv_dot / u_norm / v_norm - - angle = r8_acos(angle_cos) - - return -end -subroutine r8vec_any_normal(dim_num, v1, v2) - -!*****************************************************************************80 -! -!! R8VEC_ANY_NORMAL returns some normal vector to V1. -! -! Discussion: -! -! If DIM_NUM < 2, then no normal vector can be returned. -! -! If V1 is the zero vector, then any unit vector will do. -! -! No doubt, there are better, more robust algorithms. But I will take -! just about ANY reasonable unit vector that is normal to V1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 23 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) V1(DIM_NUM), the vector. -! -! Output, real ( kind = 8 ) V2(DIM_NUM), a vector that is -! normal to V2, and has unit Euclidean length. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) r8vec_norm - integer(kind=4) i - integer(kind=4) j - integer(kind=4) k - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) - real(kind=8) vj - real(kind=8) vk - - if (dim_num < 2) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8VEC_ANY_NORMAL - Fatal error!' - write (*, '(a)') ' Called with DIM_NUM < 2.' - stop 1 - end if - - if (r8vec_norm(dim_num, v1) == 0.0D+00) then - v2(1) = 1.0D+00 - v2(2:dim_num) = 0.0D+00 - return - end if -! -! Seek the largest entry in V1, VJ = V1(J), and the -! second largest, VK = V1(K). -! -! Since V1 does not have zero norm, we are guaranteed that -! VJ, at least, is not zero. -! - j = -1 - vj = 0.0D+00 - - k = -1 - vk = 0.0D+00 - - do i = 1, dim_num - - if (abs(vk) < abs(v1(i)) .or. k < 1) then - - if (abs(vj) < abs(v1(i)) .or. j < 1) then - k = j - vk = vj - j = i - vj = v1(i) - else - k = i - vk = v1(i) - end if - - end if - - end do -! -! Setting V2 to zero, except that V2(J) = -VK, and V2(K) = VJ, -! will just about do the trick. -! - v2(1:dim_num) = 0.0D+00 - - v2(j) = -vk / sqrt(vk * vk + vj * vj) - v2(k) = vj / sqrt(vk * vk + vj * vj) - - return -end -subroutine r8vec_bracket(n, x, xval, left, right) - -!*****************************************************************************80 -! -!! R8VEC_BRACKET searches a sorted array for successive brackets of a value. -! -! Discussion: -! -! If the values in the vector are thought of as defining intervals -! on the real line, then this routine searches for the interval -! nearest to or containing the given value. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, length of input array. -! -! Input, real ( kind = 8 ) X(N), an array that has been sorted into -! ascending order. -! -! Input, real ( kind = 8 ) XVAL, a value to be bracketed. -! -! Output, integer ( kind = 4 ) LEFT, RIGHT, the results of the search. -! Either: -! XVAL < X(1), when LEFT = 1, RIGHT = 2; -! X(N) < XVAL, when LEFT = N-1, RIGHT = N; -! or -! X(LEFT) <= XVAL <= X(RIGHT). -! - implicit none - - integer(kind=4) n - - integer(kind=4) i - integer(kind=4) left - integer(kind=4) right - real(kind=8) x(n) - real(kind=8) xval - - do i = 2, n - 1 - - if (xval < x(i)) then - left = i - 1 - right = i - return - end if - - end do - - left = n - 1 - right = n - - return -end -function r8vec_cross_product_2d(v1, v2) - -!*****************************************************************************80 -! -!! R8VEC_CROSS_PRODUCT_2D finds the cross product of a pair of vectors in 2D. -! -! Discussion: -! -! Strictly speaking, the vectors V1 and V2 should be considered -! to lie in a 3D space, both having Z coordinate zero. The cross -! product value V3 then represents the standard cross product vector -! (0,0,V3). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(2), V2(2), the vectors. -! -! Output, real ( kind = 8 ) R8VEC_CROSS_PRODUCT_2D, the cross product. -! - implicit none - - real(kind=8) r8vec_cross_product_2d - real(kind=8) v1(2) - real(kind=8) v2(2) - - r8vec_cross_product_2d = v1(1) * v2(2) - v1(2) * v2(1) - - return -end -function r8vec_cross_product_affine_2d(v0, v1, v2) - -!*****************************************************************************80 -! -!! R8VEC_CROSS_PRODUCT_AFFINE_2D finds the affine cross product in 2D. -! -! Discussion: -! -! Strictly speaking, the vectors V1 and V2 should be considered -! to lie in a 3D space, both having Z coordinate zero. The cross -! product value V3 then represents the standard cross product vector -! (0,0,V3). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 October 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V0(2), the base vector. -! -! Input, real ( kind = 8 ) V1(2), V2(2), the vectors. -! -! Output, real ( kind = 8 ) R8VEC_CROSS_PRODUCT_AFFINE_2D, -! the cross product (V1-V0) x (V2-V0). -! - implicit none - - real(kind=8) r8vec_cross_product_affine_2d - real(kind=8) v0(2) - real(kind=8) v1(2) - real(kind=8) v2(2) - - r8vec_cross_product_affine_2d = & - (v1(1) - v0(1)) * (v2(2) - v0(2)) & - - (v2(1) - v0(1)) * (v1(2) - v0(2)) - - return -end -subroutine r8vec_cross_product_3d(v1, v2, v3) - -!*****************************************************************************80 -! -!! R8VEC_CROSS_PRODUCT_3D computes the cross product of two vectors in 3D. -! -! Discussion: -! -! The cross product in 3D can be regarded as the determinant of the -! symbolic matrix: -! -! | i j k | -! det | x1 y1 z1 | -! | x2 y2 z2 | -! -! = ( y1 * z2 - z1 * y2 ) * i -! + ( z1 * x2 - x1 * z2 ) * j -! + ( x1 * y2 - y1 * x2 ) * k -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), V2(3), the two vectors. -! -! Output, real ( kind = 8 ) V3(3), the cross product vector. -! - implicit none - - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - - v3(1) = v1(2) * v2(3) - v1(3) * v2(2) - v3(2) = v1(3) * v2(1) - v1(1) * v2(3) - v3(3) = v1(1) * v2(2) - v1(2) * v2(1) - - return -end -subroutine r8vec_cross_product_affine_3d(v0, v1, v2, v3) - -!*****************************************************************************80 -! -!! R8VEC_CROSS_PRODUCT_AFFINE_3D computes the affine cross product in 3D. -! -! Discussion: -! -! The cross product in 3D can be regarded as the determinant of the -! symbolic matrix: -! -! | i j k | -! det | x1 y1 z1 | -! | x2 y2 z2 | -! -! = ( y1 * z2 - z1 * y2 ) * i -! + ( z1 * x2 - x1 * z2 ) * j -! + ( x1 * y2 - y1 * x2 ) * k -! -! Here, we use V0 as the base of an affine system so we compute -! the cross product of (V1-V0) and (V2-V0). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 October 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V0(3), the base vector. -! -! Input, real ( kind = 8 ) V1(3), V2(3), the two vectors. -! -! Output, real ( kind = 8 ) V3(3), the cross product vector -! ( V1-V0) x (V2-V0). -! - implicit none - - real(kind=8) v0(3) - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - - v3(1) = (v1(2) - v0(2)) * (v2(3) - v0(3)) & - - (v2(2) - v0(2)) * (v1(3) - v0(3)) - - v3(2) = (v1(3) - v0(3)) * (v2(1) - v0(1)) & - - (v2(3) - v0(3)) * (v1(1) - v0(1)) - - v3(3) = (v1(1) - v0(1)) * (v2(2) - v0(2)) & - - (v2(1) - v0(1)) * (v1(2) - v0(2)) - - return -end -function r8vec_distance(dim_num, v1, v2) - -!*****************************************************************************80 -! -!! R8VEC_DISTANCE returns the Euclidean distance between two vectors. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the vectors. -! -! Output, real ( kind = 8 ) R8VEC_DISTANCE, the Euclidean distance -! between the vectors. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) r8vec_distance - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) - - r8vec_distance = sqrt(sum((v1(1:dim_num) - v2(1:dim_num))**2)) - - return -end -function r8vec_dot_product(dim_num, v1, v2) - -!*****************************************************************************80 -! -!! R8VEC_DOT_PRODUCT finds the dot product of a pair of vectors in ND. -! -! Discussion: -! -! In FORTRAN, the system routine DOT_PRODUCT should be called -! directly. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the vectors. -! -! Output, real ( kind = 8 ) R8VEC_DOT_PRODUCT, the dot product. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) r8vec_dot_product - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) - - r8vec_dot_product = dot_product(v1(1:dim_num), v2(1:dim_num)) - - return -end -function r8vec_dot_product_affine(n, v0, v1, v2) - -!*****************************************************************************80 -! -!! R8VEC_DOT_PRODUCT_AFFINE computes the affine dot product V1-V0 * V2-V0. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 October 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the spatial dimension. -! -! Input, real ( kind = 8 ) V0(N), the base vector. -! -! Input, real ( kind = 8 ) V1(N), V2(N), the vectors. -! -! Output, real ( kind = 8 ) R8VEC_DOT_PRODUCT_AFFINE, the dot product. -! - implicit none - - integer(kind=4) n - - real(kind=8) r8vec_dot_product_affine - real(kind=8) v0(n) - real(kind=8) v1(n) - real(kind=8) v2(n) - - r8vec_dot_product_affine = dot_product( & - v1(1:n) - v0(1:n), & - v2(1:n) - v0(1:n)) - - return -end -function r8vec_eq(n, a1, a2) - -!*****************************************************************************80 -! -!! R8VEC_EQ is true if every pair of entries in two vectors is equal. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 March 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the vectors. -! -! Input, real ( kind = 8 ) A1(N), A2(N), two vectors to compare. -! -! Output, logical ( kind = 4 ) R8VEC_EQ. -! R8VEC_EQ is TRUE if every pair of elements A1(I) and A2(I) are equal. -! - implicit none - - integer(kind=4) n - - real(kind=8) a1(n) - real(kind=8) a2(n) - logical(kind=4) r8vec_eq - - r8vec_eq = (all(a1(1:n) == a2(1:n))) - - return -end -function r8vec_gt(n, a1, a2) - -!*****************************************************************************80 -! -!! R8VEC_GT == ( A1 > A2 ) for real vectors. -! -! Discussion: -! -! The comparison is lexicographic. -! -! A1 > A2 <=> A1(1) > A2(1) or -! ( A1(1) == A2(1) and A1(2) > A2(2) ) or -! ... -! ( A1(1:N-1) == A2(1:N-1) and A1(N) > A2(N) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the dimension of the vectors. -! -! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared. -! -! Output, logical ( kind = 4 ) R8VEC_GT, is TRUE if and only if A1 > A2. -! - implicit none - - integer(kind=4) n - - real(kind=8) a1(n) - real(kind=8) a2(n) - integer(kind=4) i - logical(kind=4) r8vec_gt - - r8vec_gt = .false. - - do i = 1, n - - if (a2(i) < a1(i)) then - r8vec_gt = .true. - exit - else if (a1(i) < a2(i)) then - r8vec_gt = .false. - exit - end if - - end do - - return -end -function r8vec_lt(n, a1, a2) - -!*****************************************************************************80 -! -!! R8VEC_LT == ( A1 < A2 ) for real vectors. -! -! Discussion: -! -! The comparison is lexicographic. -! -! A1 < A2 <=> A1(1) < A2(1) or -! ( A1(1) == A2(1) and A1(2) < A2(2) ) or -! ... -! ( A1(1:N-1) == A2(1:N-1) and A1(N) < A2(N) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the dimension of the vectors. -! -! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared. -! -! Output, logical ( kind = 4 ) R8VEC_LT, is TRUE if and only if A1 < A2. -! - implicit none - - integer(kind=4) n - - real(kind=8) a1(n) - real(kind=8) a2(n) - integer(kind=4) i - logical(kind=4) r8vec_lt - - r8vec_lt = .false. - - do i = 1, n - - if (a1(i) < a2(i)) then - r8vec_lt = .true. - exit - else if (a2(i) < a1(i)) then - r8vec_lt = .false. - exit - end if - - end do - - return -end -function r8vec_norm(n, a) - -!*****************************************************************************80 -! -!! R8VEC_NORM returns the L2 norm of an R8VEC. -! -! Discussion: -! -! An R8VEC is a vector of R8's. -! -! The vector L2 norm is defined as: -! -! R8VEC_NORM = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 August 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in A. -! -! Input, real ( kind = 8 ) A(N), the vector whose L2 norm is desired. -! -! Output, real ( kind = 8 ) R8VEC_NORM, the L2 norm of A. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(n) - real(kind=8) r8vec_norm - - r8vec_norm = sqrt(sum(a(1:n)**2)) - - return -end -function r8vec_norm_affine(n, v0, v1) - -!*****************************************************************************80 -! -!! R8VEC_NORM_AFFINE returns the affine norm of an R8VEC. -! -! Discussion: -! -! An R8VEC is a vector of R8's. -! -! The affine vector L2 norm is defined as: -! -! R8VEC_NORM_AFFINE(V0,V1) -! = sqrt ( sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2 ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 27 October 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the order of the vectors. -! -! Input, real ( kind = 8 ) V0(N), the base vector. -! -! Input, real ( kind = 8 ) V1(N), the vector whose affine norm is desired. -! -! Output, real ( kind = 8 ) R8VEC_NORM_AFFINE, the L2 norm of V1-V0. -! - implicit none - - integer(kind=4) n - - real(kind=8) r8vec_norm_affine - real(kind=8) v0(n) - real(kind=8) v1(n) - - r8vec_norm_affine = sqrt(sum((v0(1:n) - v1(1:n))**2)) - - return -end -subroutine r8vec_normal_01(n, seed, x) - -!*****************************************************************************80 -! -!! R8VEC_NORMAL_01 samples the unit normal probability distribution. -! -! Discussion: -! -! The standard normal probability distribution function (PDF) has -! mean 0 and standard deviation 1. -! -! This routine can generate a vector of values on one call. It -! has the feature that it should provide the same results -! in the same order no matter how we break up the task. -! -! The Box-Muller method is used, which is efficient, but -! generates an even number of values each time. On any call -! to this routine, an even number of new values are generated. -! Depending on the situation, one value may be left over. -! In that case, it is saved for the next call. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 January 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of values desired. If N is -! negative, then the code will flush its internal memory; in particular, -! if there is a saved value to be used on the next call, it is -! instead discarded. This is useful if the user has reset the -! random number seed, for instance. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. -! -! Local parameters: -! -! Local, integer MADE, records the number of values that have -! been computed. On input with negative N, this value overwrites -! the return value of N, so the user can get an accounting of -! how much work has been done. -! -! Local, real ( kind = 8 ) R(N+1), is used to store some uniform -! random values. Its dimension is N+1, but really it is only needed -! to be the smallest even number greater than or equal to N. -! -! Local, integer SAVED, is 0 or 1 depending on whether there is a -! single saved value left over from the previous call. -! -! Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of -! X that we need to compute. This starts off as 1:N, but is adjusted -! if we have a saved value that can be immediately stored in X(1), -! and so on. -! -! Local, real ( kind = 8 ) Y, the value saved from the previous call, if -! SAVED is 1. -! - implicit none - - integer(kind=4) n - - integer(kind=4) m - integer(kind=4), save :: made = 0 - real(kind=8) r(n + 1) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) r8_uniform_01 - integer(kind=4), save :: saved = 0 - integer(kind=4) seed - real(kind=8) x(n) - integer(kind=4) x_hi_index - integer(kind=4) x_lo_index - real(kind=8), save :: y = 0.0D+00 -! -! I'd like to allow the user to reset the internal data. -! But this won't work properly if we have a saved value Y. -! I'm making a crock option that allows the user to signal -! explicitly that any internal memory should be flushed, -! by passing in a negative value for N. -! - if (n < 0) then - n = made - made = 0 - saved = 0 - y = 0.0D+00 - return - else if (n == 0) then - return - end if -! -! Record the range of X we need to fill in. -! - x_lo_index = 1 - x_hi_index = n -! -! Use up the old value, if we have it. -! - if (saved == 1) then - x(1) = y - saved = 0 - x_lo_index = 2 - end if -! -! Maybe we don't need any more values. -! - if (x_hi_index - x_lo_index + 1 == 0) then -! -! If we need just one new value, do that here to avoid null arrays. -! - else if (x_hi_index - x_lo_index + 1 == 1) then - - r(1) = r8_uniform_01(seed) - - if (r(1) == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8VEC_NORMAL_01 - Fatal error!' - write (*, '(a)') ' R8_UNIFORM_01 returned a value of 0.' - stop 1 - end if - - r(2) = r8_uniform_01(seed) - - x(x_hi_index) = & - sqrt(-2.0D+00 * log(r(1))) * cos(2.0D+00 * r8_pi * r(2)) - y = sqrt(-2.0D+00 * log(r(1))) * sin(2.0D+00 * r8_pi * r(2)) - - saved = 1 - - made = made + 2 -! -! If we require an even number of values, that's easy. -! - else if (mod(x_hi_index - x_lo_index + 1, 2) == 0) then - - m = (x_hi_index - x_lo_index + 1) / 2 - - call r8vec_uniform_01(2 * m, seed, r) - - x(x_lo_index:x_hi_index - 1:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & - * cos(2.0D+00 * r8_pi * r(2:2 * m:2)) - - x(x_lo_index + 1:x_hi_index:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & - * sin(2.0D+00 * r8_pi * r(2:2 * m:2)) - - made = made + x_hi_index - x_lo_index + 1 -! -! If we require an odd number of values, we generate an even number, -! and handle the last pair specially, storing one in X(N), and -! saving the other for later. -! - else - - x_hi_index = x_hi_index - 1 - - m = (x_hi_index - x_lo_index + 1) / 2 + 1 - - call r8vec_uniform_01(2 * m, seed, r) - - x(x_lo_index:x_hi_index - 1:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & - * cos(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) - - x(x_lo_index + 1:x_hi_index:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & - * sin(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) - - x(n) = sqrt(-2.0E+00 * log(r(2 * m - 1))) & - * cos(2.0D+00 * r8_pi * r(2 * m)) - - y = sqrt(-2.0D+00 * log(r(2 * m - 1))) & - * sin(2.0D+00 * r8_pi * r(2 * m)) - - saved = 1 - - made = made + x_hi_index - x_lo_index + 2 - - end if - - return -end -function r8vec_normsq(n, v) - -!*****************************************************************************80 -! -!! R8VEC_NORMSQ returns the square of the L2 norm of an R8VEC. -! -! Discussion: -! -! An R8VEC is a vector of R8's. -! -! The square of the vector L2 norm is defined as: -! -! R8VEC_NORMSQ = sum ( 1 <= I <= N ) V(I)^2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 October 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the vector dimension. -! -! Input, real ( kind = 8 ) V(N), the vector. -! -! Output, real ( kind = 8 ) R8VEC_NORMSQ, the squared L2 norm. -! - implicit none - - integer(kind=4) n - - real(kind=8) r8vec_normsq - real(kind=8) v(n) - - r8vec_normsq = sum(v(1:n)**2) - - return -end - -function r8vec_normsq_affine(n, v0, v1) - -!*****************************************************************************80 -! -!! R8VEC_NORMSQ_AFFINE returns the affine squared norm of an R8VEC. -! -! Discussion: -! -! An R8VEC is a vector of R8's. -! -! The affine squared vector L2 norm is defined as: -! -! R8VEC_NORMSQ_AFFINE(V0,V1) -! = sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 October 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the vector dimension. -! -! Input, real ( kind = 8 ) V0(N), the base vector. -! -! Input, real ( kind = 8 ) V1(N), the vector. -! -! Output, real ( kind = 8 ) R8VEC_NORMSQ_AFFINE, the affine squared L2 norm. -! - implicit none - - integer(kind=4) n - - real(kind=8) r8vec_normsq_affine - real(kind=8) v0(n) - real(kind=8) v1(n) - - r8vec_normsq_affine = sum((v0(1:n) - v1(1:n))**2) - - return -end -subroutine r8vec_polarize(n, a, p, a_normal, a_parallel) - -!*****************************************************************************80 -! -!! R8VEC_POLARIZE decomposes an R8VEC into normal and parallel components. -! -! Discussion: -! -! An R8VEC is a vector of R8's. -! -! The (nonzero) vector P defines a direction. -! -! The vector A can be written as the sum -! -! A = A_normal + A_parallel -! -! where A_parallel is a linear multiple of P, and A_normal -! is perpendicular to P. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 November 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the array. -! -! Input, real ( kind = 8 ) A(N), the vector to be polarized. -! -! Input, real ( kind = 8 ) P(N), the polarizing direction. -! -! Output, real ( kind = 8 ) A_NORMAL(N), A_PARALLEL(N), the normal -! and parallel components of A. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(n) - real(kind=8) a_dot_p - real(kind=8) a_normal(n) - real(kind=8) a_parallel(n) - real(kind=8) p(n) - real(kind=8) p_norm - - p_norm = sqrt(sum(p(1:n)**2)) - - if (p_norm == 0.0D+00) then - a_normal(1:n) = a(1:n) - a_parallel(1:n) = 0.0D+00 - return - end if - - a_dot_p = dot_product(a(1:n), p(1:n)) / p_norm - - a_parallel(1:n) = a_dot_p * p(1:n) / p_norm - - a_normal(1:n) = a(1:n) - a_parallel(1:n) - - return -end -subroutine r8vec_print(n, a, title) - -!*****************************************************************************80 -! -!! R8VEC_PRINT prints an R8VEC. -! -! Discussion: -! -! An R8VEC is a vector of R8's. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 August 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of components of the vector. -! -! Input, real ( kind = 8 ) A(N), the vector to be printed. -! -! Input, character ( len = * ) TITLE, a title. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(n) - integer(kind=4) i - character(len=*) title - - write (*, '(a)') ' ' - write (*, '(a)') trim(title) - write (*, '(a)') ' ' - - do i = 1, n - write (*, '(2x,i8,a,1x,g16.8)') i, ':', a(i) - end do - - return -end -function r8vec_scalar_triple_product(v1, v2, v3) - -!*****************************************************************************80 -! -!! R8VEC_SCALAR_TRIPLE_PRODUCT finds the scalar triple product in 3D. -! -! Discussion: -! -! [A,B,C] = A dot ( B cross C ) -! = B dot ( C cross A ) -! = C dot ( A cross B ) -! -! The volume of a parallelepiped, whose sides are given by -! vectors A, B, and C, is abs ( A dot ( B cross C ) ). -! -! Three vectors are coplanar if and only if their scalr triple -! product vanishes. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 August 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Eric Weisstein, -! "Scalar Triple Product", -! CRC Concise Encyclopedia of Mathematics, -! CRC, 1999 -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vectors. -! -! Output, real ( kind = 8 ) R8VEC_SCALAR_TRIPLE_PRODUCT, the scalar -! triple product. -! - implicit none - - real(kind=8) r8vec_scalar_triple_product - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - real(kind=8) v4(3) - - call r8vec_cross_product_3d(v2, v3, v4) - - r8vec_scalar_triple_product = dot_product(v1(1:3), v4(1:3)) - - return -end -subroutine r8vec_swap(n, a1, a2) - -!*****************************************************************************80 -! -!! R8VEC_SWAP swaps the entries of two real vectors. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the arrays. -! -! Input/output, real ( kind = 8 ) A1(N), A2(N), the vectors to swap. -! - implicit none - - integer(kind=4) n - - real(kind=8) a1(n) - real(kind=8) a2(n) - real(kind=8) a3(n) - - a3(1:n) = a1(1:n) - a1(1:n) = a2(1:n) - a2(1:n) = a3(1:n) - - return -end -subroutine r8vec_uniform_01(n, seed, r) - -!*****************************************************************************80 -! -!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. -! -! Discussion: -! -! An R8VEC is a vector of real ( kind = 8 ) values. -! -! For now, the input quantity SEED is an integer ( kind = 4 ) variable. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 July 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the vector. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. -! - implicit none - - integer(kind=4) n - - integer(kind=4) i - integer(kind=4) k - integer(kind=4) seed - real(kind=8) r(n) - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8VEC_UNIFORM_01 - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - do i = 1, n - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if - - r(i) = real(seed, kind=8) * 4.656612875D-10 - - end do - - return -end -subroutine r8vec_uniform_ab(n, a, b, seed, r) - -!*****************************************************************************80 -! -!! R8VEC_UNIFORM_AB returns a scaled pseudorandom R8VEC. -! -! Discussion: -! -! An R8VEC is a vector of real ( kind = 8 ) values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 July 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the number of entries in the vector. -! -! Input, real ( kind = 8 ) A, B, the lower and upper limits. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. -! - implicit none - - integer(kind=4) n - - real(kind=8) a - real(kind=8) b - integer(kind=4) i - integer(kind=4) k - integer(kind=4) seed - real(kind=8) r(n) - - if (seed == 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'R8VEC_UNIFORM_AB - Fatal error!' - write (*, '(a)') ' Input value of SEED = 0.' - stop 1 - end if - - do i = 1, n - - k = seed / 127773 - - seed = 16807 * (seed - k * 127773) - k * 2836 - - if (seed < 0) then - seed = seed + 2147483647 - end if - - r(i) = a + (b - a) * real(seed, kind=8) * 4.656612875D-10 - - end do - - return -end -subroutine r8vec_uniform_unit(m, seed, w) - -!*****************************************************************************80 -! -!! R8VEC_UNIFORM_UNIT generates a uniformly random unit vector. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 October 2012 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the spatial dimension. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) W(M), a random direction vector, -! with unit norm. -! - implicit none - - integer(kind=4) m - - real(kind=8) norm - integer(kind=4) seed - real(kind=8) w(m) -! -! Get M values from a standard normal distribution. -! - call r8vec_normal_01(m, seed, w) -! -! Compute the length of the vector. -! - norm = sqrt(sum(w(1:m)**2)) -! -! Normalize the vector. -! - w(1:m) = w(1:m) / norm - - return -end -subroutine radec_distance_3d(ra1, dec1, ra2, dec2, theta) - -!*****************************************************************************80 -! -!! RADEC_DISTANCE_3D - angular distance, astronomical units, sphere in 3D. -! -! Discussion: -! -! Right ascension is measured in hours, between 0 and 24, and -! essentially measures longitude. -! -! Declination measures the angle from the equator towards the north pole, -! and ranges from -90 (South Pole) to 90 (North Pole). -! -! On the unit sphere, the angular separation between two points is -! equal to their geodesic or great circle distance. On any other -! sphere, multiply the angular separation by the radius of the -! sphere to get the geodesic or great circle distance. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 December 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) RA1, DEC1, RA2, DEC2, the right ascension and -! declination of the two points. -! -! Output, real ( kind = 8 ) THETA, the angular separation between the points, -! in radians. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) cos_theta - real(kind=8) dec1 - real(kind=8) dec2 - real(kind=8) degrees_to_radians - real(kind=8) norm_v1 - real(kind=8) norm_v2 - real(kind=8) phi1 - real(kind=8) phi2 - real(kind=8) r8_acos - real(kind=8) ra1 - real(kind=8) ra2 - real(kind=8) theta - real(kind=8) theta1 - real(kind=8) theta2 - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) - - theta1 = degrees_to_radians(15.0D+00 * ra1) - phi1 = degrees_to_radians(dec1) - - v1(1:dim_num) = (/cos(theta1) * cos(phi1), & - sin(theta1) * cos(phi1), & - sin(phi1)/) - - norm_v1 = sqrt(sum(v1(1:dim_num)**2)) - - theta2 = degrees_to_radians(15.0D+00 * ra2) - phi2 = degrees_to_radians(dec2) - - v2(1:dim_num) = (/cos(theta2) * cos(phi2), & - sin(theta2) * cos(phi2), & - sin(phi2)/) - - norm_v2 = sqrt(sum(v2(1:dim_num)**2)) - - cos_theta = dot_product(v1(1:dim_num), v2(1:dim_num)) & - / (norm_v1 * norm_v2) - - theta = r8_acos(cos_theta) - - return -end -subroutine radec_to_xyz(ra, dec, p) - -!*****************************************************************************80 -! -!! RADEC_TO_XYZ converts right ascension/declination to (X,Y,Z) coordinates. -! -! Discussion: -! -! Right ascension is measured in hours, between 0 and 24, and -! essentially measures longitude. -! -! Declination measures the angle from the equator towards the north pole, -! and ranges from -90 (South Pole) to 90 (North Pole). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) RA, DEC, the right ascension and declination -! of a point. -! -! Output, real ( kind = 8 ) P(3), the corresponding coordinates of -! a point with radius 1. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dec - real(kind=8) degrees_to_radians - real(kind=8) p(dim_num) - real(kind=8) phi - real(kind=8) ra - real(kind=8) theta - - theta = degrees_to_radians(15.0D+00 * ra) - phi = degrees_to_radians(dec) - - p(1) = cos(theta) * cos(phi) - p(2) = sin(theta) * cos(phi) - p(3) = sin(phi) - - return -end -function radians_to_degrees(angle_rad) - -!*****************************************************************************80 -! -!! RADIANS_TO_DEGREES converts an angle from radians to degrees. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 July 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) ANGLE_RAD, an angle in radians. -! -! Output, real ( kind = 8 ) RADIANS_TO_DEGREES, the equivalent angle -! in degrees. -! - implicit none - - real(kind=8) angle_rad - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radians_to_degrees - - radians_to_degrees = (angle_rad / r8_pi) * 180.0D+00 - - return -end -subroutine radians_to_dms(angle_rad, degrees, minutes, seconds) - -!*****************************************************************************80 -! -!! RADIANS_TO_DMS converts an angle from radians to degrees/minutes/seconds. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) ANGLE_RAD, the angle in radians. -! -! Output, integer ( kind = 4 ) DEGREES, MINUTES, SECONDS, the equivalent -! angle in degrees, minutes, and seconds. -! - implicit none - - real(kind=8) angle_deg - real(kind=8) angle_rad - integer(kind=4) degrees - integer(kind=4) minutes - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seconds - - angle_deg = 180.0D+00 * abs(angle_rad) / r8_pi - - degrees = int(angle_deg) - angle_deg = (angle_deg - real(degrees, kind=8)) * 60.0D+00 - minutes = int(angle_deg) - angle_deg = (angle_deg - real(minutes, kind=8)) * 60.0D+00 - seconds = nint(angle_deg) - - if (angle_rad < 0.0D+00) then - degrees = -degrees - minutes = -minutes - seconds = -seconds - end if - - return -end -subroutine random_initialize(seed) - -!*****************************************************************************80 -! -!! RANDOM_INITIALIZE initializes the FORTRAN90 random number seed. -! -! Discussion: -! -! If you don't initialize the random number generator, its behavior -! is not specified. If you initialize it simply by: -! -! call random_seed ( ) -! -! its behavior is not specified. On the DEC ALPHA, if that's all you -! do, the same random number sequence is returned. In order to actually -! try to scramble up the random number generator a bit, this routine -! goes through the tedious process of getting the size of the random -! number seed, making up values based on the current time, and setting -! the random number seed. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED. -! If SEED is zero on input, then you're asking this routine to come up -! with a seed value, which is returned as output. -! If SEED is nonzero on input, then you're asking this routine to -! use the input value of SEED to initialize the random number generator. -! - implicit none - - integer(kind=4) count - integer(kind=4) count_max - integer(kind=4) count_rate - integer(kind=4) i - integer(kind=4) seed - integer(kind=4), allocatable :: seed_vector(:) - integer(kind=4) seed_size - real(kind=8) t -! -! Initialize the random number seed. -! - call random_seed() -! -! Determine the size of the random number seed. -! - call random_seed(size=seed_size) -! -! Allocate a seed of the right size. -! - allocate (seed_vector(seed_size)) - - if (seed /= 0) then - - write (*, '(a)') ' ' - write (*, '(a)') 'RANDOM_INITIALIZE' - write (*, '(a,i12)') ' Initialize RANDOM_NUMBER with user SEED = ', seed - - else - - call system_clock(count, count_rate, count_max) - - seed = count - - write (*, '(a)') ' ' - write (*, '(a)') 'RANDOM_INITIALIZE' - write (*, '(a,i12)') & - ' Initialize RANDOM_NUMBER with arbitrary SEED = ', seed - - end if -! -! Now set the seed. -! - seed_vector(1:seed_size) = seed - - call random_seed(put=seed_vector(1:seed_size)) -! -! Free up the seed space. -! - deallocate (seed_vector) -! -! Call the random number routine a bunch of times. -! - do i = 1, 100 - call random_number(harvest=t) - end do - - return -end -subroutine rotation_axis_vector_3d(axis, angle, v, w) - -!*****************************************************************************80 -! -!! ROTATION_AXIS_VECTOR_3D rotates a vector around an axis vector in 3D. -! -! Discussion: -! -! Thanks to Cody Farnell for correcting some mistakes in an earlier -! version of this routine. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 May 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) AXIS(3), the axis vector for the rotation. -! -! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation. -! -! Input, real ( kind = 8 ) V(3), the vector to be rotated. -! -! Output, real ( kind = 8 ) W(3), the rotated vector. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) angle - real(kind=8) axis(dim_num) - real(kind=8) axis_norm - real(kind=8) dot - real(kind=8) norm - real(kind=8) normal(dim_num) - real(kind=8) normal_component - real(kind=8) normal2(dim_num) - real(kind=8) parallel(dim_num) - real(kind=8) rot(dim_num) - real(kind=8) u(dim_num) - real(kind=8) v(dim_num) - real(kind=8) w(dim_num) -! -! Compute the length of the rotation axis. -! - u(1:dim_num) = axis(1:dim_num) - - axis_norm = sqrt(sum(u(1:dim_num)**2)) - - if (axis_norm == 0.0D+00) then - w(1:dim_num) = 0.0D+00 - return - end if - - u(1:dim_num) = u(1:dim_num) / axis_norm -! -! Compute the dot product of the vector and the unit rotation axis. -! - dot = dot_product(u(1:dim_num), v(1:dim_num)) -! -! Compute the parallel component of the vector. -! - parallel(1:dim_num) = dot * u(1:dim_num) -! -! Compute the normal component of the vector. -! - normal(1:dim_num) = v(1:dim_num) - parallel(1:dim_num) - - normal_component = sqrt(sum(normal(1:dim_num)**2)) - - if (normal_component == 0.0D+00) then - w(1:dim_num) = parallel(1:dim_num) - return - end if - - normal(1:dim_num) = normal(1:dim_num) / normal_component -! -! Compute a second vector, lying in the plane, perpendicular -! to V, and forming a right-handed system, as the cross product -! of the first two vectors. -! - normal2(1) = u(2) * normal(3) - u(3) * normal(2) - normal2(2) = u(3) * normal(1) - u(1) * normal(3) - normal2(3) = u(1) * normal(2) - u(2) * normal(1) - - norm = sqrt(sum(normal2(1:dim_num)**2)) - - normal2(1:dim_num) = normal2(1:dim_num) / norm -! -! Rotate the normal component by the angle. -! - rot(1:dim_num) = normal_component * ( & - cos(angle) * normal(1:dim_num) & - + sin(angle) * normal2(1:dim_num)) -! -! The rotated vector is the parallel component plus the rotated component. -! - w(1:dim_num) = parallel(1:dim_num) + rot(1:dim_num) - - return -end -subroutine rtp_to_xyz(r, theta, phi, xyz) - -!*****************************************************************************80 -! -!! RTP_TO_XYZ converts (R,Theta,Phi) to (X,Y,Z) coordinates. -! -! Discussion: -! -! R measures the distance of the point to the origin. -! -! Theta measures the "longitude" of the point, between 0 and 2 PI. -! -! PHI measures the angle from the "north pole", between 0 and PI. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 January 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, THETA, PHI, the radius, longitude, and -! declination of a point. -! -! Output, real ( kind = 8 ) XYZ(3), the corresponding Cartesian coordinates. -! - implicit none - - real(kind=8) phi - real(kind=8) r - real(kind=8) theta - real(kind=8) xyz(3) - - xyz(1) = r * cos(theta) * sin(phi) - xyz(2) = r * sin(theta) * sin(phi) - xyz(3) = r * cos(phi) - - return -end -subroutine segment_contains_point_1d(p1, p2, p, t) - -!*****************************************************************************80 -! -!! SEGMENT_CONTAINS_POINT_1D reports if a line segment contains a point in 1D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 September 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1, P2, two points defining a line segment. -! The line segment has T = 0 at P1, and T = 1 at P2. -! -! Input, real ( kind = 8 ) P, a point to be tested. -! -! Output, real ( kind = 8 ) T, the coordinate of P3 in units of (P2-P1). -! The point P3 is contained in the line segment if 0 <= T <= 1. -! - implicit none - - real(kind=8) p - real(kind=8) p1 - real(kind=8) p2 - real(kind=8) t - real(kind=8) unit - - unit = p2 - p1 - - if (unit == 0.0D+00) then - - if (p == p1) then - t = 0.5D+00 - else if (p < p1) then - t = -huge(t) - else if (p1 < p) then - t = huge(t) - end if - - else - - t = (p - p1) / unit - - end if - - return -end -subroutine segment_contains_point_2d(p1, p2, p, u) - -!*****************************************************************************80 -! -!! SEGMENT_CONTAINS_POINT_2D reports if a line segment contains a point in 2D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! In exact arithmetic, point P is on the line segment between -! P1 and P2 if and only if 0 <= U <= 1 and V = 0. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. -! -! Input, real ( kind = 8 ) P(2), a point to be tested. -! -! Output, real ( kind = 8 ) U(2), the components of P, with the first -! component measured along the axis with origin at P1 and unit at P2, -! and second component the magnitude of the off-axis portion of the -! vector P-P1, measured in units of (P2-P1). -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) normsq - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) u(dim_num) - - normsq = sum((p2(1:dim_num) - p1(1:dim_num))**2) - - if (normsq == 0.0D+00) then - - if (all(p(1:dim_num) == p1(1:dim_num))) then - u(1) = 0.5D+00 - u(2) = 0.0D+00 - else - u(1) = 0.5D+00 - u(2) = huge(u(2)) - end if - - else - - u(1) = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) / normsq - - u(2) = sqrt(((u(1) - 1.0D+00) * p1(1) - u(1) * p2(1) + p(1))**2 & - + ((u(1) - 1.0D+00) * p1(2) - u(1) * p2(2) + p(2))**2) & - / sqrt(normsq) - - end if - - return -end -subroutine segment_point_coords_2d(p1, p2, p, s, t) - -!*****************************************************************************80 -! -!! SEGMENT_POINT_COORDS_2D: coordinates of a point on a line segment in 2D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! By the coordinates of a point P with respect to a line segment [P1,P2] -! we mean numbers S and T such that S gives us the distance from the -! point P to the nearest point PN on the line (not the line segment!), -! and T gives us the position of PN relative to P1 and P2. -! -! If S is zero, then P lies on the line. -! -! If 0 <= T <= 1, then PN lies on the line segment. -! -! If both conditions hold, then P lies on the line segment. -! -! If E is the length of the line segment, then the distance of the -! point to the line segment is: -! -! sqrt ( S^2 + T^2 * E^2 ) if T <= 0; -! S if 0 <= T <= 1 -! sqrt ( S^2 + (T-1)^2 * E^2 ) if 1 <= T -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 July 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. -! -! Input, real ( kind = 8 ) P(2), the point to be considered. -! -! Output, real ( kind = 8 ) S, the distance of P to the nearest point PN -! on the line through P1 and P2. (S will always be nonnegative.) -! -! Output, real ( kind = 8 ) T, the relative position of the point PN -! to the points P1 and P2. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) bot - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) s - 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 - - end if - - pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) - - s = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - - return -end -subroutine segment_point_coords_3d(p1, p2, p, s, t) - -!*****************************************************************************80 -! -!! SEGMENT_POINT_COORDS_3D: coordinates of a point on a line segment in 3D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! By the coordinates of a point P with respect to a line segment [P1,P2] -! we mean numbers S and T such that S gives us the distance from the -! point P to the nearest point PN on the line (not the line segment!), -! and T gives us the position of PN relative to P1 and P2. -! -! If S is zero, then P lies on the line. -! -! If 0 <= T <= 1, then PN lies on the line segment. -! -! If both conditions hold, then P lies on the line segment. -! -! If E is the length of the line segment, then the distance of the -! point to the line segment is: -! -! sqrt ( S^2 + T^2 * E^2 ) if T <= 0; -! S if 0 <= T <= 1 -! sqrt ( S^2 + (T-1)^2 * E^2 ) if 1 <= T -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 August 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the line segment. -! -! Input, real ( kind = 8 ) P(3), the point to be considered. -! -! Output, real ( kind = 8 ) S, the distance of P to the nearest point PN -! on the line through P1 and P2. (S will always be nonnegative.) -! -! Output, real ( kind = 8 ) T, the relative position of the point PN -! to the points P1 and P2. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) bot - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) s - 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 - - end if - - pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) - - s = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - - return -end -subroutine segment_point_dist_2d(p1, p2, p, dist) - -!*****************************************************************************80 -! -!! SEGMENT_POINT_DIST_2D: distance ( line segment, point ) in 2D. -! -! 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. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 May 2006 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) bot - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - 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)) - - return -end -subroutine segment_point_dist_3d(p1, p2, p, dist) - -!*****************************************************************************80 -! -!! SEGMENT_POINT_DIST_3D: distance ( line segment, point ) in 3D. -! -! 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. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 May 2006 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) bot - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - 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)) - - return -end -subroutine segment_point_near_2d(p1, p2, p, pn, dist, t) - -!*****************************************************************************80 -! -!! SEGMENT_POINT_NEAR_2D: nearest point on line segment to point in 2D. -! -! 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. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 May 2006 -! -! Author: -! -! John Burkardt -! -! 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. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) bot - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - 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)) - - return -end -subroutine segment_point_near_3d(p1, p2, p, pn, dist, t) - -!*****************************************************************************80 -! -!! SEGMENT_POINT_NEAR_3D: nearest point on line segment to point in 3D. -! -! 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. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 May 2006 -! -! Author: -! -! John Burkardt -! -! 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 ) PN(3), the point on the line segment -! nearest to 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 nearest point -! P to P1 and P2, that is PN = (1-T)*P1 + T*P2. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) bot - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - 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)) - - return -end -subroutine segments_curvature_2d(p1, p2, p3, curvature) - -!*****************************************************************************80 -! -!! SEGMENTS_CURVATURE_2D computes the curvature of two line segments in 2D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! We assume that the segments are [P1,P2] and [P2,P3]. -! -! We compute the circle that passes through P1, P2 and P3. -! -! The inverse of the radius of this circle is the local "curvature" -! associated with the three points. -! -! If curvature is 0, the two line segments have the same slope, -! and the three points are collinear. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 March 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the points. -! -! Output, real ( kind = 8 ) CURVATURE, the local curvature. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) curvature - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - - call circle_exp2imp_2d(p1, p2, p3, r, pc) - - if (0.0D+00 < r) then - curvature = 1.0D+00 / r - else - curvature = 0.0D+00 - end if - - return -end -subroutine segments_dist_2d(p1, p2, q1, q2, dist) - -!*****************************************************************************80 -! -!! SEGMENTS_DIST_2D computes the distance between two line segments in 2D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! If the lines through [P1,P2] and [Q1,Q2] intersect, and both -! line segments include the point of intersection, then the distance -! is zero and we are done. -! -! Therefore, we compute the intersection of the two lines, and -! find the coordinates of that intersection point on each line. -! This will tell us if the zero distance case has occurred. -! -! Otherwise, let PN and QN be points in [P1,P2] and [Q1,Q2] for which -! the distance is minimal. If the lines do not intersect, then it -! cannot be the case that both PN and QN are strictly interior to their -! line segments, aside from the exceptional singular case when -! the line segments overlap or are parallel. Even then, one of PN -! and QN may be taken to be a segment endpoint. -! -! Therefore, our second computation finds the minimum of: -! -! Distance ( P1, [Q1,Q2] ); -! Distance ( P2, [Q1,Q2] ); -! Distance ( Q1, [P1,P2] ); -! Distance ( Q2, [P1,P2] ); -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 August 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the first -! segment. -! -! Input, real ( kind = 8 ) Q1(2), Q2(2), the endpoints of the second -! segment. -! -! Output, real ( kind = 8 ) DIST, the distance between the line segments. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) dist - real(kind=8) dist2 - integer(kind=4) ival - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) r(dim_num) - real(kind=8) rps - real(kind=8) rpt - real(kind=8) rqs - real(kind=8) rqt -! -! Determine whether and where the underlying lines intersect. -! - call lines_exp_int_2d(p1, p2, q1, q2, ival, r) -! -! If there is exactly one intersection point part of both lines, -! check that it is part of both line segments. -! - if (ival == 1) then - - call segment_point_coords_2d(p1, p2, r, rps, rpt) - call segment_point_coords_2d(q1, q2, r, rqs, rqt) - - if (0.0D+00 <= rpt .and. rpt <= 1.0D+00 .and. & - 0.0D+00 <= rqt .and. rqt <= 1.0D+00) then - dist = 0.0D+00 - return - end if - - end if -! -! If there is no intersection, or the intersection point is -! not part of both line segments, then an endpoint of one -! line segment achieves the minimum distance. -! - call segment_point_dist_2d(q1, q2, p1, dist2) - dist = dist2 - call segment_point_dist_2d(q1, q2, p2, dist2) - dist = min(dist, dist2) - call segment_point_dist_2d(p1, p2, q1, dist2) - dist = min(dist, dist2) - call segment_point_dist_2d(p1, p2, q2, dist2) - dist = min(dist, dist2) - - return -end -subroutine segments_dist_3d(p1, p2, q1, q2, dist) - -!*****************************************************************************80 -! -!! SEGMENTS_DIST_3D computes the distance between two line segments in 3D. -! -! Discussion: -! -! -! NOTE: The special cases for identical and parallel lines have not been -! worked out yet; those cases are exceptional, and so this code -! is made available in a slightly unfinished form! -! -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! Given two line segments, consider the underlying lines on which -! they lie. -! -! A) If the lines are identical, then the distance between the line segments -! is 0, if the segments overlap, or otherwise is attained by the -! minimum of the distances between each endpoint and the opposing -! line segment. -! -! B) If the lines are parallel, then the distance is either the distance -! between the lines, if the projection of one line segment onto -! the other overlaps, or otherwise is attained by the -! minimum of the distances between each endpoint and the opposing -! line segment. -! -! C) If the lines are not identical, and not parallel, then there are -! unique points PN and QN which are the closest pair of points on the lines. -! If PN is interior to [P1,P2] and QN is interior to [Q1,Q2], -! then the distance between the two line segments is the distance -! between PN and QN. Otherwise, the nearest distance can be computed -! by taking the minimum of the distance from each endpoing to the -! opposing line segment. -! -! Therefore, our computation first checks whether the lines are -! identical, parallel, or other, and checks for the special case -! where the minimum occurs in the interior. -! -! If that case is ruled out, it computes and returns the minimum of: -! -! Distance ( P1, [Q1,Q2] ); -! Distance ( P2, [Q1,Q2] ); -! Distance ( Q1, [P1,P2] ); -! Distance ( Q2, [P1,P2] ); -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 August 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the first -! segment. -! -! Input, real ( kind = 8 ) Q1(3), Q2(3), the endpoints of the second -! segment. -! -! Output, real ( kind = 8 ) DIST, the distance between the line segments. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - real(kind=8) det - real(kind=8) dist - real(kind=8) dist2 - real(kind=8) e - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) qn(dim_num) - real(kind=8) sn - real(kind=8) tn - real(kind=8) u(dim_num) - real(kind=8) v(dim_num) - real(kind=8) w0(dim_num) -! -! The lines are identical. -! THIS CASE NOT SET UP YET -! -! if ( lines_exp_equal_3d ( p1, p2, q1, q2 ) ) then -! end if -! -! The lines are not identical, but parallel -! THIS CASE NOT SET UP YET. -! -! if ( lines_exp_parallel_3d ( p1, p2, q1, q2 ) ) then -! end if -! -! C: The lines are not identical, not parallel. -! - -! -! Let U = (P2-P1) and V = (Q2-Q1) be the direction vectors on -! the two lines. -! - u(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) - v(1:dim_num) = q2(1:dim_num) - q1(1:dim_num) -! -! Let SN be the unknown coordinate of the nearest point PN on line 1, -! so that PN = P(SN) = P1 + SN * (P2-P1). -! -! Let TN be the unknown coordinate of the nearest point QN on line 2, -! so that QN = Q(TN) = Q1 + TN * (Q2-Q1). -! -! Let W0 = (P1-Q1). -! - w0(1:dim_num) = p1(1:dim_num) - q1(1:dim_num) -! -! The vector direction WC = P(SN) - Q(TC) is unique (among directions) -! perpendicular to both U and V, so -! -! U dot WC = 0 -! V dot WC = 0 -! -! or, equivalently: -! -! U dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 -! V dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 -! -! or, equivalently: -! -! (u dot u ) * sn - (u dot v ) tc = -u * w0 -! (v dot u ) * sn - (v dot v ) tc = -v * w0 -! -! or, equivalently: -! -! ( a -b ) * ( sn ) = ( -d ) -! ( b -c ) ( tc ) ( -e ) -! - a = dot_product(u, u) - b = dot_product(u, v) - c = dot_product(v, v) - d = dot_product(u, w0) - e = dot_product(v, w0) -! -! Check the determinant. -! - det = -a * c + b * b - - if (det == 0.0D+00) then - sn = 0.0D+00 - if (abs(b) < abs(c)) then - tn = e / c - else - tn = d / b - end if - else - sn = (c * d - b * e) / det - tn = (b * d - a * e) / det - end if -! -! Now if both nearest points on the lines -! also happen to lie inside their line segments, -! then we have found the nearest points on the line segments. -! - if (0.0D+00 <= sn .and. sn <= 1.0D+00 .and. & - 0.0D+00 <= tn .and. tn <= 1.0D+00) then - pn(1:dim_num) = p1(1:dim_num) + sn * (p2(1:dim_num) - p1(1:dim_num)) - qn(1:dim_num) = q1(1:dim_num) + tn * (q2(1:dim_num) - q1(1:dim_num)) - dist = sqrt(sum((pn(1:dim_num) - qn(1:dim_num))**2)) - return - end if -! -! The nearest point did not occur in the interior. -! Therefore it must be achieved at an endpoint. -! - call segment_point_dist_3d(q1, q2, p1, dist2) - dist = dist2 - call segment_point_dist_3d(q1, q2, p2, dist2) - dist = min(dist, dist2) - call segment_point_dist_3d(p1, p2, q1, dist2) - dist = min(dist, dist2) - call segment_point_dist_3d(p1, p2, q2, dist2) - dist = min(dist, dist2) - - return -end -subroutine segments_dist_3d_old(p1, p2, q1, q2, dist) - -!*****************************************************************************80 -! -!! SEGMENTS_DIST_3D_OLD computes the distance between two line segments in 3D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the -! first segment. -! -! Input, real ( kind = 8 ) Q1(3), Q2(3), the endpoints of the -! second segment. -! -! Output, real ( kind = 8 ) DIST, the distance between the line segments. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) d1 - real(kind=8) d2 - real(kind=8) dist - real(kind=8) dl - real(kind=8) dm - real(kind=8) dr - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pm(dim_num) - real(kind=8) pn1(dim_num) - real(kind=8) pn2(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) t1 - real(kind=8) t2 - real(kind=8) tl - real(kind=8) tm - real(kind=8) tmin - real(kind=8) tr -! -! Find the nearest points on line 2 to the endpoints of line 1. -! - call segment_point_near_3d(q1, q2, p1, pn1, d1, t1) - call segment_point_near_3d(q1, q2, p2, pn2, d2, t2) - - if (t1 == t2) then - call segment_point_dist_3d(p1, p2, pn1, dist) - return - end if - - pm(1:dim_num) = 0.5D+00 * (pn1(1:dim_num) + pn2(1:dim_num)) -! -! On line 2, over the interval between the points nearest to line 1, -! the square of the distance of any point to line 1 is a quadratic function. -! Evaluate it at three points, and seek its local minimum. -! - call segment_point_dist_3d(p1, p2, pn1, dl) - call segment_point_dist_3d(p1, p2, pm, dm) - call segment_point_dist_3d(p1, p2, pn2, dr) - - tl = 0.0D+00 - tm = 0.5D+00 - tr = 1.0D+00 - - dl = dl * dl - dm = dm * dm - dr = dr * dr - - call minquad(tl, dl, tm, dm, tr, dr, tmin, dist) - - dist = sqrt(dist) - - return -end -subroutine segments_int_1d(p1, p2, q1, q2, dist, r1, r2) - -!*****************************************************************************80 -! -!! SEGMENTS_INT_1D computes the intersection of two line segments in 1D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! In 1D, two line segments "intersect" if they overlap. -! -! Using a real number DIST to report overlap is preferable to -! returning a TRUE/FALSE flag, since DIST is better able to -! handle cases where the segments "almost" interlap. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 July 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1, P2, the endpoints of the first segment. -! -! Input, real ( kind = 8 ) Q1, Q2, the endpoints of the second segment. -! -! Output, real ( kind = 8 ) DIST, the "distance" between the segments. -! < 0, the segments overlap, and the overlap is DIST units long; -! = 0, the segments overlap at a single point; -! > 0, the segments do not overlap. The distance between the nearest -! points is DIST units. -! -! Output, real ( kind = 8 ) R1, R2, the endpoints of the intersection -! segment. -! If DIST < 0, then the interval [R1,R2] is the common intersection -! of the two segments. -! If DIST = 0, then R1 = R2 is the single common point of the two segments. -! If DIST > 0, then (R1,R2) is an open interval separating the two -! segments, which do not overlap at all. -! - implicit none - - real(kind=8) dist - real(kind=8) p1 - real(kind=8) p2 - real(kind=8) q1 - real(kind=8) q2 - real(kind=8) r1 - real(kind=8) r2 - - r1 = max(min(p1, p2), & - min(q1, q2)) - - r2 = min(max(p1, p2), & - max(q1, q2)) - - dist = r1 - r2 - - return -end -subroutine segments_int_2d(p1, p2, q1, q2, flag, r) - -!*****************************************************************************80 -! -!! SEGMENTS_INT_2D computes the intersection of two line segments in 2D. -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! In 2D, two line segments might not intersect, even though the -! lines, of which they are portions, intersect. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the first -! segment. -! -! Input, real ( kind = 8 ) Q1(2), Q2(2), the endpoints of the second -! segment. -! -! Output, integer ( kind = 4 ) FLAG, records the results. -! 0, the line segments do not intersect. -! 1, the line segments intersect. -! -! Output, real ( kind = 8 ) R(2), an intersection point, if there is one. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - integer(kind=4) flag - integer(kind=4) ival - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) q1(dim_num) - real(kind=8) q2(dim_num) - real(kind=8) r(dim_num) - real(kind=8), parameter :: tol = 0.001D+00 - real(kind=8) u(dim_num) -! -! Find the intersection of the two lines. -! - r(1:dim_num) = (/0.0D+00, 0.0D+00/) - - call lines_exp_int_2d(p1, p2, q1, q2, ival, r) - - if (ival == 0) then - flag = 0 - return - end if -! -! Is the intersection point part of the first line segment? -! - call segment_contains_point_2d(p1, p2, r, u) - - if (u(1) < 0.0D+00 .or. 1.0D+00 < u(1) .or. tol < u(2)) then - flag = 0 - return - end if -! -! Is the intersection point part of the second line segment? -! - call segment_contains_point_2d(q1, q2, r, u) - - if (u(1) < 0.0D+00 .or. 1.0D+00 < u(1) .or. tol < u(2)) then - flag = 0 - return - end if - - flag = 1 - - return -end -subroutine shape_point_dist_2d(pc, p1, side_num, p, dist) - -!*****************************************************************************80 -! -!! SHAPE_POINT_DIST_2D: distance ( regular shape, point ) in 2D. -! -! Discussion: -! -! The "regular shape" is assumed to be an equilateral and equiangular -! polygon, such as the standard square, pentagon, hexagon, and so on. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(2), the center of the shape. -! -! Input, real ( kind = 8 ) P1(2), the first vertex of the shape. -! -! Input, integer ( kind = 4 ) SIDE_NUM, the number of sides. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the shape. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle - real(kind=8) angle_deg_2d - real(kind=8) angle2 - real(kind=8) degrees_to_radians - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) pa(dim_num) - real(kind=8) pb(dim_num) - real(kind=8) pc(dim_num) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radius - real(kind=8) sector_angle - integer(kind=4) sector_index - integer(kind=4) side_num -! -! Determine the angle subtended by a single side. -! - sector_angle = 360.0D+00 / real(side_num, kind=8) -! -! How long is the half-diagonal? -! - radius = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) -! -! If the radius is zero, then the shape is a point and the computation is easy. -! - if (radius == 0.0D+00) then - dist = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) - return - end if -! -! If the test point is at the pc, then the computation is easy. -! The angle subtended by any side is ( 2 * PI / SIDE_NUM ) and the -! nearest distance is the midpoint of any such side. -! - if (all(p(1:dim_num) == pc(1:dim_num))) then - dist = radius * cos(r8_pi / real(side_num, kind=8)) - return - end if -! -! Determine the angle between the ray to the first corner, -! and the ray to the test point. -! - angle = angle_deg_2d(p1(1:2), pc(1:2), p(1:2)) -! -! Determine the sector of the point. -! - sector_index = int(angle / sector_angle) + 1 -! -! Generate the two corner points that terminate the SECTOR-th side. -! - angle2 = real(sector_index - 1, kind=8) * sector_angle - angle2 = degrees_to_radians(angle2) - - call vector_rotate_base_2d(p1, pc, angle2, pa) - - angle2 = real(sector_index, kind=8) * sector_angle - angle2 = degrees_to_radians(angle2) - - call vector_rotate_base_2d(p1, pc, angle2, pb) -! -! Determine the distance from the test point to the line segment that -! is the SECTOR-th side. -! - call segment_point_dist_2d(pa, pb, p, dist) - - return -end -subroutine shape_point_near_2d(pc, p1, side_num, p, pn, dist) - -!*****************************************************************************80 -! -!! SHAPE_POINT_NEAR_2D: nearest point ( regular shape, point ) in 2D. -! -! Discussion: -! -! The "regular shape" is assumed to be an equilateral and equiangular -! polygon, such as the standard square, pentagon, hexagon, and so on. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(2), the center of the shape. -! -! Input, real ( kind = 8 ) P1(2), the first vertex of the shape. -! -! Input, integer ( kind = 4 ) SIDE_NUM, the number of sides. -! -! Input, real ( kind = 8 ) P(2), the point to be checked. -! -! Output, real ( kind = 8 ) PN(2), the point on the shape that is nearest -! to the given point. -! -! Output, real ( kind = 8 ) DIST, the distance between the points. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle - real(kind=8) angle_deg_2d - real(kind=8) angle2 - real(kind=8) degrees_to_radians - real(kind=8) dist - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) pa(dim_num) - real(kind=8) pb(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pd(dim_num) - real(kind=8) pn(dim_num) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) radius - real(kind=8) sector_angle - integer(kind=4) sector_index - integer(kind=4) side_num - real(kind=8) t -! -! Determine the angle subtended by a single side. -! - sector_angle = 360.0D+00 / real(side_num, kind=8) -! -! How long is the half-diagonal? -! - radius = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) -! -! If the radius is zero, then the shape is a point and the computation is easy. -! - if (radius == 0.0D+00) then - pn(1:dim_num) = pc(1:dim_num) - dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) - return - end if -! -! If the test point is at the pc, then the computation is easy. -! The angle subtended by any side is ( 2 * PI / SIDE_NUM ) and the -! nearest distance is the midpoint of any such side. -! - if (all(p(1:dim_num) == pc(1:dim_num))) then - angle = r8_pi / real(side_num, kind=8) - pd(1) = (p(1) - pc(1)) * cos(angle) & - + (p(2) - pc(2)) * sin(angle) - pd(2) = -(p(1) - pc(1)) * sin(angle) & - + (p(2) - pc(2)) * cos(angle) - pn(1) = pc(1) + pd(1) * cos(angle) - pn(2) = pc(2) + pd(2) * sin(angle) - dist = radius * cos(angle) - return - end if -! -! Determine the angle between the ray to the first corner, -! and the ray to the test point. -! - angle = angle_deg_2d(p1(1:2), pc(1:2), p(1:2)) -! -! Determine the sector of the point. -! - sector_index = int(angle / sector_angle) + 1 -! -! Generate the two corner points that terminate the SECTOR-th side. -! - angle2 = real(sector_index - 1, kind=8) * sector_angle - angle2 = degrees_to_radians(angle2) - - call vector_rotate_base_2d(p1, pc, angle2, pa) - - angle2 = real(sector_index, kind=8) * sector_angle - angle2 = degrees_to_radians(angle2) - - call vector_rotate_base_2d(p1, pc, angle2, pb) -! -! Determine the point on the SECTOR-th side of the shape which is -! nearest. -! - call segment_point_near_2d(pa, pb, p, pn, dist, t) - - return -end -subroutine shape_print_3d(point_num, face_num, face_order_max, & - point_coord, face_order, face_point) - -!*****************************************************************************80 -! -!! SHAPE_PRINT_3D prints information about a polyhedron in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the number of vertices -! per face. -! -! Input, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. -! -! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices -! per face. -! -! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. -! The points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) point_num - - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - integer(kind=4) i - real(kind=8) point_coord(dim_num, point_num) - - write (*, '(a)') ' ' - write (*, '(a)') 'SHAPE_PRINT_3D' - write (*, '(a)') ' Information about a polytope.' - write (*, '(a)') ' ' - write (*, '(a,i8)') ' The number of vertices is ', point_num - write (*, '(a)') ' ' - write (*, '(a)') ' Vertices:' - write (*, '(a)') ' ' - write (*, '(a)') ' Index X Y Z' - write (*, '(a)') ' ' - - do i = 1, point_num - write (*, '(2x,i8,2x,3f16.8)') i, point_coord(1:dim_num, i) - end do - - write (*, '(a)') ' ' - write (*, '(a,i8)') ' The number of faces is ', face_num - write (*, '(a,i8)') ' The maximum order of any face is ', face_order_max - write (*, '(a)') ' ' - write (*, '(a)') ' Index Order Indices of Nodes in Face' - write (*, '(22x,10i8)') (i, i=1, face_order_max) - write (*, '(a)') ' ' - - do i = 1, face_num - write (*, '(2x,i8,2x,i8,2x,10i8)') i, face_order(i), & - face_point(1:face_order(i), i) - end do - - return -end -subroutine shape_ray_int_2d(pc, p1, side_num, pa, pb, pint) - -!*****************************************************************************80 -! -!! SHAPE_RAY_INT_2D: intersection ( regular shape, ray ) in 2D. -! -! Discussion: -! -! The "regular shape" is assumed to be an equilateral and equiangular -! polygon, such as the standard square, pentagon, hexagon, and so on. -! -! The origin of the ray is assumed to be inside the shape. This -! guarantees that the ray will intersect the shape in exactly one point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(2), the center of the shape. -! -! Input, real ( kind = 8 ) P1(2), the first vertex of the shape. -! -! Input, integer ( kind = 4 ) SIDE_NUM, the number of sides. -! -! Input, real ( kind = 8 ) PA(2), the origin of the ray. -! -! Input, real ( kind = 8 ) PB(2), a second point on the ray. -! -! Output, real ( kind = 8 ) PINT(2), the point on the shape intersected -! by the ray. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle2 - real(kind=8) degrees_to_radians - logical(kind=4) inside - integer(kind=4) ival - real(kind=8) p1(dim_num) - real(kind=8) pa(dim_num) - real(kind=8) pb(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pint(dim_num) - real(kind=8) radius - real(kind=8) sector_angle - integer(kind=4) sector_index - integer(kind=4) side_num - real(kind=8) v1(dim_num) - real(kind=8) v2(dim_num) -! -! Warning! -! No check is made to ensure that the ray origin is inside the shape. -! These calculations are not valid if that is not true! -! -! Determine the angle subtended by a single side. -! - sector_angle = 360.0D+00 / real(side_num, kind=8) -! -! How long is the half-diagonal? -! - radius = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) -! -! If the radius is zero, refuse to continue. -! - if (radius == 0.0D+00) then - write (*, '(a)') ' ' - write (*, '(a)') 'SHAPE_RAY_INT_2D - Fatal error!' - write (*, '(a)') ' The shape has radius zero.' - stop 1 - end if -! -! Determine which sector side intersects the ray. -! - v2(1:dim_num) = (/0.0D+00, 0.0D+00/) - - do sector_index = 1, side_num -! -! Determine the two vertices that define this sector. -! - if (sector_index == 1) then - - angle2 = real(sector_index - 1, kind=8) * sector_angle - angle2 = degrees_to_radians(angle2) - - call vector_rotate_base_2d(p1, pc, angle2, v1) - - else - - v1(1:dim_num) = v2(1:dim_num) - - end if - - angle2 = real(sector_index, kind=8) * sector_angle - angle2 = degrees_to_radians(angle2) - - call vector_rotate_base_2d(p1, pc, angle2, v2) -! -! Draw the angle from one vertex to the ray origin to the next vertex, -! and see if that angle contains the ray. If so, then the ray -! must intersect the shape side of that sector. -! - call angle_contains_point_2d(v1, pa, v2, pb, inside) -! -! Determine the intersection of the lines defined by the ray and the -! sector side. (We're already convinced that the ray and sector line -! segment intersect, so we can use the simpler code that treats them -! as full lines). -! - if (inside) then - - call lines_exp_int_2d(pa, pb, v1, v2, ival, pint) - - return - - end if - - end do -! -! If the calculation fell through the loop, then something's wrong. -! - write (*, '(a)') ' ' - write (*, '(a)') 'SHAPE_RAY_INT_2D - Fatal error!' - write (*, '(a)') ' Cannot find intersection of ray and shape.' - stop 1 -end -subroutine simplex_lattice_layer_point_next(n, c, v, more) - -!*****************************************************************************80 -! -!! SIMPLEX_LATTICE_LAYER_POINT_NEXT: next simplex lattice layer point. -! -! Discussion: -! -! The simplex lattice layer L is bounded by the lines -! -! 0 <= X(1:N), -! L - 1 < sum X(1:N) / C(1:N) <= L. -! -! In particular, layer L = 0 always contains just the origin. -! -! This function returns, one at a time, the points that lie within -! a given simplex lattice layer. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the spatial dimension. -! -! Input, integer ( kind = 4 ) C(N+1), coefficients defining the -! lattice layer in entries 1 to N, and the laver index in C(N+1). -! The coefficients should be positive, and C(N+1) must be nonnegative. -! -! Input/output, integer ( kind = 4 ) V(N). On first call for a given layer, -! the input value of V is not important. On a repeated call for the same -! layer, the input value of V should be the output value from the previous -! call. On output, V contains the next lattice layer point. -! -! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE -! to indicate that this is the first call for a given layer. Thereafter, -! the input value should be the output value from the previous call. On -! output, MORE is TRUE if the returned value V is a new point. -! If the output value is FALSE, then no more points were found, -! and V was reset to 0, and the lattice layer has been exhausted. -! - implicit none - - integer(kind=4) n - - integer(kind=4) c(n + 1) - integer(kind=4) c1n - integer(kind=4) i - integer(kind=4) i4vec_lcm - integer(kind=4) j - integer(kind=4) lhs - logical(kind=4) more - integer(kind=4) rhs1 - integer(kind=4) rhs2 - integer(kind=4) v(n) -! -! Treat layer C(N+1) = 0 specially. -! - if (c(n + 1) == 0) then - if (.not. more) then - v(1:n) = 0 - more = .true. - else - more = .false. - end if - return - end if -! -! Compute the first point. -! - if (.not. more) then - - v(1) = (c(n + 1) - 1) * c(1) + 1 - v(2:n) = 0 - more = .true. - - else - - c1n = i4vec_lcm(n, c) - - rhs1 = c1n * (c(n + 1) - 1) - rhs2 = c1n * c(n + 1) -! -! Try to increment component I. -! - do i = 1, n - - v(i) = v(i) + 1 - - v(1:i - 1) = 0 - - if (1 < i) then - v(1) = rhs1 - do j = 2, n - v(1) = v(1) - (c1n / c(j)) * v(j) - end do - v(1) = (c(1) * v(1)) / c1n - v(1) = max(v(1), 0) - end if - - lhs = 0 - do j = 1, n - lhs = lhs + (c1n / c(j)) * v(j) - end do - - if (lhs <= rhs1) then - v(1) = v(1) + 1 - lhs = lhs + c1n / c(1) - end if - - if (lhs <= rhs2) then - return - end if - - end do - - v(1:n) = 0 - more = .false. - - end if - - return -end -subroutine simplex_lattice_point_next(n, c, v, more) - -!*****************************************************************************80 -! -!! SIMPLEX_LATTICE_POINT_NEXT returns the next simplex lattice point. -! -! Discussion: -! -! The lattice simplex is defined by the vertices: -! -! (0,0,...,0), (C(N+1)/C(1),0,...,0), (0,C(N+1)/C(2),...,0) ... -! (0,0,...C(N+1)/C(N)) -! -! The lattice simplex is bounded by the lines -! -! 0 <= V(1:N), -! V(1) / C(1) + V(2) / C(2) + ... + V(N) / C(N) <= C(N+1) -! -! Lattice points are listed one at a time, starting at the origin, -! with V(1) increasing first. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the spatial dimension. -! -! Input, integer ( kind = 4 ) C(N+1), coefficients defining the -! lattice simplex. These should be positive. -! -! Input/output, integer ( kind = 4 ) V(N). On first call, the input -! value is not important. On a repeated call, the input value should -! be the output value from the previous call. On output, V contains -! the next lattice point. -! -! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to -! indicate that this is the first call for a given simplex. Thereafter, -! the input value should be the output value from the previous call. On -! output, MORE is TRUE if not only is the returned value V a lattice point, -! but the routine can be called again for another lattice point. -! If the output value is FALSE, then no more lattice points were found, -! and V was reset to 0, and the routine should not be called further -! for this simplex. -! - implicit none - - integer(kind=4) n - - integer(kind=4) c(n + 1) - integer(kind=4) c1n - integer(kind=4) i - integer(kind=4) i4vec_lcm - integer(kind=4) j - integer(kind=4) lhs - logical(kind=4) more - integer(kind=4) rhs - integer(kind=4) term - integer(kind=4) v(n) - - if (.not. more) then - - v(1:n) = 0 - more = .true. - - else - - c1n = i4vec_lcm(n, c) - rhs = c1n * c(n + 1) - - lhs = 0 - do i = 1, n - term = 1 - do j = 1, n - if (i == j) then - term = term * v(j) - else - term = term * c(j) - end if - end do - lhs = lhs + term - end do - - do i = 1, n - if (lhs + c1n / c(i) <= rhs) then - v(i) = v(i) + 1 - more = .true. - return - end if - lhs = lhs - c1n * v(i) / c(i) - v(i) = 0 - end do - - more = .false. - - end if - - return -end -subroutine simplex01_lattice_point_num_nd(d, s, n) - -!*****************************************************************************80 -! -!! SIMPLEX01_LATTICE_POINT_NUM_ND: count lattice points. -! -! Discussion: -! -! The simplex is assumed to be the unit D-dimensional simplex: -! -! ( (0,0,...,0), (1,0,...,0), (0,1,...,0), ... (0,,0,...,1) ) -! -! or a copy of this simplex scaled by an integer S: -! -! ( (0,0,...,0), (S,0,...,0), (0,S,...,0), ... (0,,0,...,S) ) -! -! The routine returns the number of integer lattice points that appear -! inside the simplex or on its boundary. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 July 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Matthias Beck, Sinai Robins, -! Computing the Continuous Discretely, -! Springer, 2006, -! ISBN13: 978-0387291390, -! LC: QA640.7.B43. -! -! Parameters: -! -! Input, integer ( kind = 4 ) D, the spatial dimension. -! -! Input, integer ( kind = 4 ) S, the scale factor. -! -! Output, integer ( kind = 4 ) N, the number of lattice points. -! - implicit none - - integer(kind=4) d - integer(kind=4) i - integer(kind=4) n - integer(kind=4) s - - n = 1 - do i = 1, d - n = (n * (s + i)) / i - end do - - return -end -subroutine simplex01_volume_nd(dim_num, volume) - -!*****************************************************************************80 -! -!! SIMPLEX01_VOLUME_ND computes the volume of the unit simplex in ND. -! -! Discussion: -! -! The formula is simple: volume = 1/N!. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 March 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Output, real ( kind = 8 ) VOLUME, the volume. -! - implicit none - - integer(kind=4) i - integer(kind=4) dim_num - real(kind=8) volume - - volume = 1.0D+00 - do i = 1, dim_num - volume = volume / real(i, kind=8) - end do - - return -end -subroutine simplex_volume_nd(dim_num, a, volume) - -!*****************************************************************************80 -! -!! SIMPLEX_VOLUME_ND computes the volume of a simplex in ND. -! -! Discussion: -! -! The formula is: -! -! volume = 1/N! * det ( A ) -! -! where A is the N by N matrix obtained by subtracting one -! vector from all the others. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 March 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. -! -! Input, real ( kind = 8 ) A(DIM_NUM,DIM_NUM+1), the vertices. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the simplex. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) a(dim_num, dim_num + 1) - real(kind=8) b(dim_num, dim_num) - real(kind=8) det - integer(kind=4) i - integer(kind=4) info - integer(kind=4) j - integer(kind=4) pivot(dim_num) - real(kind=8) volume - - b(1:dim_num, 1:dim_num) = a(1:dim_num, 1:dim_num) - do j = 1, dim_num - b(1:dim_num, j) = b(1:dim_num, j) - a(1:dim_num, dim_num + 1) - end do - - call r8ge_fa(dim_num, b, pivot, info) - - if (info /= 0) then - - volume = -1.0D+00 - - else - - call r8ge_det(dim_num, b, pivot, det) - - volume = abs(det) - do i = 1, dim_num - volume = volume / real(i, kind=8) - end do - - end if - - return -end -function sin_power_int(a, b, n) - -!*****************************************************************************80 -! -!! SIN_POWER_INT evaluates the sine power integral. -! -! Discussion: -! -! The function is defined by -! -! SIN_POWER_INT(A,B,N) = Integral ( A <= T <= B ) ( sin ( t ))^n dt -! -! The algorithm uses the following fact: -! -! Integral sin^n ( t ) = (1/n) * ( -! sin^(n-1)(t) * cos(t) + ( n-1 ) * Integral sin^(n-2) ( t ) dt ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 September 2004 -! -! Author: -! -! John Burkardt -! -! Parameters -! -! Input, real ( kind = 8 ) A, B, the limits of integration. -! -! Input, integer ( kind = 4 ) N, the power of the sine function. -! -! Output, real ( kind = 8 ) SIN_POWER_INT, the value of the integral. -! - implicit none - - real(kind=8) a - real(kind=8) b - real(kind=8) ca - real(kind=8) cb - integer(kind=4) m - integer(kind=4) mlo - integer(kind=4) n - real(kind=8) sa - real(kind=8) sb - real(kind=8) sin_power_int - real(kind=8) value - - if (n < 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'SIN_POWER_INT - Fatal error!' - write (*, '(a)') ' Power N < 0.' - value = 0.0D+00 - stop 1 - end if - - sa = sin(a) - sb = sin(b) - ca = cos(a) - cb = cos(b) - - if (mod(n, 2) == 0) then - - value = b - a - mlo = 2 - else - value = ca - cb - mlo = 3 - end if - - do m = mlo, n, 2 - value = (real(m - 1, kind=8) * value & - + sa**(m - 1) * ca - sb**(m - 1) * cb) & - / real(m, kind=8) - end do - - sin_power_int = value - - return -end -subroutine soccer_shape_3d(point_num, face_num, face_order_max, point_coord, & - face_order, face_point) - -!*****************************************************************************80 -! -!! SOCCER_SHAPE_3D describes a truncated icosahedron in 3D. -! -! Discussion: -! -! The shape is a truncated icosahedron, which is the design used -! on a soccer ball. There are 12 pentagons and 20 hexagons. -! -! Call SOCCER_SIZE_3D to get the values of POINT_NUM, FACE_NUM, and -! FACE_ORDER_MAX, so you can allocate space for the arrays. -! -! For each face, the face list must be of length FACE_ORDER_MAX. -! In cases where a face is of lower than maximum order (the -! 12 pentagons, in this case), the extra entries are listed as -! "-1". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 August 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! http://mathworld.wolfram.com/TruncatedIcosahedron.html -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points (60). -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces (32). -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any -! face (6). -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. -! -! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of -! vertices per face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. -! The points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) point_num - - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) point_coord(dim_num, point_num) -! -! Set the point coordinates. -! - point_coord(1:dim_num, 1:point_num) = reshape((/ & - -0.100714D+01, 0.153552D+00, 0.067258D+00, & - -0.960284D+00, 0.0848813D+00, -0.336290D+00, & - -0.951720D+00, -0.153552D+00, 0.336290D+00, & - -0.860021D+00, 0.529326D+00, 0.150394D+00, & - -0.858000D+00, -0.290893D+00, -0.470806D+00, & - -0.849436D+00, -0.529326D+00, 0.201774D+00, & - -0.802576D+00, -0.597996D+00, -0.201774D+00, & - -0.784200D+00, 0.418215D+00, -0.502561D+00, & - -0.749174D+00, -0.0848813D+00, 0.688458D+00, & - -0.722234D+00, 0.692896D+00, -0.201774D+00, & - -0.657475D+00, 0.597996D+00, 0.502561D+00, & - -0.602051D+00, 0.290893D+00, 0.771593D+00, & - -0.583675D+00, -0.692896D+00, 0.470806D+00, & - -0.579632D+00, -0.333333D+00, -0.771593D+00, & - -0.521710D+00, -0.418215D+00, 0.771593D+00, & - -0.505832D+00, 0.375774D+00, -0.803348D+00, & - -0.489955D+00, -0.830237D+00, -0.336290D+00, & - -0.403548D+00, 0.000000D+00, -0.937864D+00, & - -0.381901D+00, 0.925138D+00, -0.201774D+00, & - -0.352168D+00, -0.666667D+00, -0.688458D+00, & - -0.317142D+00, 0.830237D+00, 0.502561D+00, & - -0.271054D+00, -0.925138D+00, 0.336290D+00, & - -0.227464D+00, 0.333333D+00, 0.937864D+00, & - -0.224193D+00, -0.993808D+00, -0.067258D+00, & - -0.179355D+00, 0.993808D+00, 0.150394D+00, & - -0.165499D+00, 0.608015D+00, -0.803348D+00, & - -0.147123D+00, -0.375774D+00, 0.937864D+00, & - -0.103533D+00, 0.882697D+00, -0.502561D+00, & - -0.513806D-01, 0.666667D+00, 0.771593D+00, & - 0.000000D+00, 0.000000D+00, 1.021000D+00, & - 0.000000D+00, 0.000000D+00, -1.021000D+00, & - 0.513806D-01, -0.666667D+00, -0.771593D+00, & - 0.103533D+00, -0.882697D+00, 0.502561D+00, & - 0.147123D+00, 0.375774D+00, -0.937864D+00, & - 0.165499D+00, -0.608015D+00, 0.803348D+00, & - 0.179355D+00, -0.993808D+00, -0.150394D+00, & - 0.224193D+00, 0.993808D+00, 0.067258D+00, & - 0.227464D+00, -0.333333D+00, -0.937864D+00, & - 0.271054D+00, 0.925138D+00, -0.336290D+00, & - 0.317142D+00, -0.830237D+00, -0.502561D+00, & - 0.352168D+00, 0.666667D+00, 0.688458D+00, & - 0.381901D+00, -0.925138D+00, 0.201774D+00, & - 0.403548D+00, 0.000000D+00, 0.937864D+00, & - 0.489955D+00, 0.830237D+00, 0.336290D+00, & - 0.505832D+00, -0.375774D+00, 0.803348D+00, & - 0.521710D+00, 0.418215D+00, -0.771593D+00, & - 0.579632D+00, 0.333333D+00, 0.771593D+00, & - 0.583675D+00, 0.692896D+00, -0.470806D+00, & - 0.602051D+00, -0.290893D+00, -0.771593D+00, & - 0.657475D+00, -0.597996D+00, -0.502561D+00, & - 0.722234D+00, -0.692896D+00, 0.201774D+00, & - 0.749174D+00, 0.0848813D+00, -0.688458D+00, & - 0.784200D+00, -0.418215D+00, 0.502561D+00, & - 0.802576D+00, 0.597996D+00, 0.201774D+00, & - 0.849436D+00, 0.529326D+00, -0.201774D+00, & - 0.858000D+00, 0.290893D+00, 0.470806D+00, & - 0.860021D+00, -0.529326D+00, -0.150394D+00, & - 0.951720D+00, 0.153552D+00, -0.336290D+00, & - 0.960284D+00, -0.0848813D+00, 0.336290D+00, & - 1.007140D+00, -0.153552D+00, -0.067258D+00/), & - (/dim_num, point_num/)) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 6, 6, 5, 6, 5, 6, 5, 6, 6, 6, & - 5, 6, 5, 6, 5, 6, 6, 6, 5, 6, & - 5, 5, 6, 6, 6, 5, 6, 5, 6, 6, & - 5, 6/) -! -! Set faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 30, 43, 47, 41, 29, 23, & - 30, 23, 12, 9, 15, 27, & - 30, 27, 35, 45, 43, -1, & - 43, 45, 53, 59, 56, 47, & - 23, 29, 21, 11, 12, -1, & - 27, 15, 13, 22, 33, 35, & - 47, 56, 54, 44, 41, -1, & - 45, 35, 33, 42, 51, 53, & - 12, 11, 4, 1, 3, 9, & - 29, 41, 44, 37, 25, 21, & - 15, 9, 3, 6, 13, -1, & - 56, 59, 60, 58, 55, 54, & - 53, 51, 57, 60, 59, -1, & - 11, 21, 25, 19, 10, 4, & - 33, 22, 24, 36, 42, -1, & - 13, 6, 7, 17, 24, 22, & - 54, 55, 48, 39, 37, 44, & - 51, 42, 36, 40, 50, 57, & - 4, 10, 8, 2, 1, -1, & - 3, 1, 2, 5, 7, 6, & - 25, 37, 39, 28, 19, -1, & - 55, 58, 52, 46, 48, -1, & - 60, 57, 50, 49, 52, 58, & - 10, 19, 28, 26, 16, 8, & - 36, 24, 17, 20, 32, 40, & - 7, 5, 14, 20, 17, -1, & - 48, 46, 34, 26, 28, 39, & - 50, 40, 32, 38, 49, -1, & - 8, 16, 18, 14, 5, 2, & - 46, 52, 49, 38, 31, 34, & - 16, 26, 34, 31, 18, -1, & - 32, 20, 14, 18, 31, 38/), (/face_order_max, face_num/)) - - return -end -subroutine soccer_size_3d(point_num, edge_num, face_num, face_order_max) - -!*****************************************************************************80 -! -!! SOCCER_SIZE_3D gives "sizes" for a truncated icosahedron in 3D. -! -! Discussion: -! -! The shape is a truncated icosahedron, which is the design used -! on a soccer ball. There are 12 pentagons and 20 hexagons. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2007 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! http://mathworld.wolfram.com/TruncatedIcosahedron.html -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 60 - edge_num = 90 - face_num = 32 - face_order_max = 6 - - return -end -subroutine sort_heap_external(n, indx, i, j, isgn) - -!*****************************************************************************80 -! -!! SORT_HEAP_EXTERNAL externally sorts a list of items into ascending order. -! -! Discussion: -! -! The actual list of data is not passed to the routine. Hence this -! routine may be used to sort integers, real ( kind = 8 )s, numbers, names, -! dates, shoe sizes, and so on. After each call, the routine asks -! the user to compare or interchange two items, until a special -! return value signals that the sorting is completed. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 February 2004 -! -! Author: -! -! Original FORTRAN77 version by Albert Nijenhuis and Herbert Wilf -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Albert Nijenhuis, Herbert Wilf, -! Combinatorial Algorithms, -! Academic Press, 1978, second edition, -! ISBN 0-12-519260-6. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of items to be sorted. -! -! Input/output, integer ( kind = 4 ) INDX, the main communication signal. -! -! The user must set INDX to 0 before the first call. -! Thereafter, the user should not change the value of INDX until -! the sorting is done. -! -! On return, if INDX is -! -! greater than 0, -! * interchange items I and J; -! * call again. -! -! less than 0, -! * compare items I and J; -! * set ISGN = -1 if I < J, ISGN = +1 if J < I; -! * call again. -! -! equal to 0, the sorting is done. -! -! Output, integer ( kind = 4 ) I, J, the indices of two items. -! On return with INDX positive, elements I and J should be interchanged. -! On return with INDX negative, elements I and J should be compared, and -! the result reported in ISGN on the next call. -! -! Input, integer ( kind = 4 ) ISGN, results of comparison of elements I -! and J. (Used only when the previous call returned INDX less than 0). -! ISGN <= 0 means I is less than or equal to J; -! 0 <= ISGN means I is greater than or equal to J. -! - implicit none - - integer(kind=4) i - integer(kind=4), save :: i_save = 0 - integer(kind=4) indx - integer(kind=4) isgn - integer(kind=4) j - integer(kind=4), save :: j_save = 0 - integer(kind=4), save :: k = 0 - integer(kind=4), save :: k1 = 0 - integer(kind=4) n - integer(kind=4), save :: n1 = 0 -! -! INDX = 0: This is the first call. -! - if (indx == 0) then - - i_save = 0 - j_save = 0 - k = n / 2 - k1 = k - n1 = n -! -! INDX < 0: The user is returning the results of a comparison. -! - else if (indx < 0) then - - if (indx == -2) then - - if (isgn < 0) then - i_save = i_save + 1 - end if - - j_save = k1 - k1 = i_save - indx = -1 - i = i_save - j = j_save - return - - end if - - if (0 < isgn) then - indx = 2 - i = i_save - j = j_save - return - end if - - if (k <= 1) then - - if (n1 == 1) then - i_save = 0 - j_save = 0 - indx = 0 - else - i_save = n1 - n1 = n1 - 1 - j_save = 1 - indx = 1 - end if - - i = i_save - j = j_save - return - - end if - - k = k - 1 - k1 = k -! -! 0 < INDX, the user was asked to make an interchange. -! - else if (indx == 1) then - - k1 = k - - end if - - do - - i_save = 2 * k1 - - if (i_save == n1) then - j_save = k1 - k1 = i_save - indx = -1 - i = i_save - j = j_save - return - else if (i_save <= n1) then - j_save = i_save + 1 - indx = -2 - i = i_save - j = j_save - return - end if - - if (k <= 1) then - exit - end if - - k = k - 1 - k1 = k - - end do - - if (n1 == 1) then - i_save = 0 - j_save = 0 - indx = 0 - i = i_save - j = j_save - else - i_save = n1 - n1 = n1 - 1 - j_save = 1 - indx = 1 - i = i_save - j = j_save - end if - - return -end -subroutine sphere_cap_area_2d(r, h, area) - -!*****************************************************************************80 -! -!! SPHERE_CAP_AREA_2D computes the surface area of a spherical cap in 2D. -! -! Discussion: -! -! Draw any radius of the sphere and note the point P where the radius -! intersects the sphere. Consider the point on the radius line which is -! H units from P. Draw the circle that lies in the plane perpendicular to -! the radius, and which intersects the sphere. The circle divides the sphere -! into two pieces, and the corresponding disk divides the solid sphere into -! two pieces. The spherical cap is the part of the solid sphere that -! includes the point P. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H, the "height" of the spherical cap. -! H must be between 0 and 2 * R. -! -! Output, real ( kind = 8 ) AREA, the area of the spherical cap. -! - implicit none - - real(kind=8) area - real(kind=8) h - real(kind=8) r - real(kind=8) r8_asin - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - - if (h <= 0.0D+00) then - area = 0.0D+00 - else if (2.0D+00 * r <= h) then - area = 2.0D+00 * r8_pi * r - else - - theta = 2.0D+00 * r8_asin(sqrt(r * r - (r - h)**2) / r) - area = r * theta - - if (r <= h) then - area = 2.0D+00 * r8_pi * r - area - end if - - end if - - return -end -subroutine sphere_cap_area_3d(r, h, area) - -!*****************************************************************************80 -! -!! SPHERE_CAP_AREA_3D computes the surface area of a spherical cap in 3D. -! -! Discussion: -! -! Draw any radius of the sphere and note the point P where the radius -! intersects the sphere. Consider the point on the radius line which is -! H units from P. Draw the circle that lies in the plane perpendicular to -! the radius, and which intersects the sphere. The circle divides the sphere -! into two pieces, and the corresponding disk divides the solid sphere into -! two pieces. The spherical cap is the part of the solid sphere that -! includes the point P. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H, the "height" of the spherical cap. -! H must be between 0 and 2 * R. -! -! Output, real ( kind = 8 ) AREA, the area of the spherical cap. -! - implicit none - - real(kind=8) area - real(kind=8) h - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - if (h <= 0.0D+00) then - area = 0.0D+00 - else if (2.0D+00 * r <= h) then - area = 4.0D+00 * r8_pi * r * r - else - area = 2.0D+00 * r8_pi * r * h - end if - - return -end -subroutine sphere_cap_area_nd(dim_num, r, h, area) - -!*****************************************************************************80 -! -!! SPHERE_CAP_AREA_ND computes the area of a spherical cap in ND. -! -! Discussion: -! -! The spherical cap is a portion of the surface of the sphere: -! -! sum ( X(1:N)^2 ) = R^2 -! -! which is no more than H units from the uppermost point on the sphere. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 June 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Thomas Ericson, Victor Zinoviev, -! Codes on Euclidean Spheres, -! Elsevier, 2001, pages 439-441. -! QA166.7 E75 -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H, the "thickness" of the spherical cap, -! which is normally between 0 and 2 * R. -! -! Output, real ( kind = 8 ) AREA, the area of the spherical cap. -! - implicit none - - real(kind=8) area - real(kind=8) area2 - real(kind=8) h - real(kind=8) haver_sine - integer(kind=4) i - integer(kind=4) dim_num - real(kind=8) r - real(kind=8) r8_asin - real(kind=8) sphere_k - real(kind=8) theta - real(kind=8) ti - real(kind=8) tj - real(kind=8) tk - - if (h <= 0.0D+00) then - area = 0.0D+00 - return - end if - - if (2.0D+00 * r <= h) then - call sphere_imp_area_nd(dim_num, r, area) - return - end if -! -! For cases where R < H < 2 * R, work with the complementary region. -! - haver_sine = sqrt((2.0D+00 * r - h) * h) - - theta = r8_asin(haver_sine / r) - - if (dim_num < 1) then - - area = -1.0D+00 - return - - else if (dim_num == 1) then - - area = 0.0D+00 - - else if (dim_num == 2) then - - area = 2.0D+00 * theta * r - - else - - ti = theta - - tj = ti - ti = 1.0D+00 - cos(theta) - - do i = 2, dim_num - 2 - tk = tj - tj = ti - ti = (real(i - 1, kind=8) * tk & - - cos(theta) * sin(theta)**(i - 1)) & - / real(i, kind=8) - end do - - area = sphere_k(dim_num - 1) * ti * r**(dim_num - 1) - - end if -! -! Adjust for cases where R < H < 2R. -! - if (r < h) then - call sphere_imp_area_nd(dim_num, r, area2) - area = area2 - area - end if - - return -end -subroutine sphere_cap_volume_2d(r, h, volume) - -!*****************************************************************************80 -! -!! SPHERE_CAP_VOLUME_2D computes the volume of a spherical cap in 2D. -! -! Discussion: -! -! Draw any radius R of the circle and denote as P the point where the -! radius intersects the circle. Now consider the point Q which lies -! on the radius and which is H units from P. The line which is -! perpendicular to the radius R and passes through Q divides the -! circle into two pieces. The piece including the point P is the -! spherical (circular) cap of height (or thickness) H. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H, the "height" of the spherical cap. H must -! be between 0 and 2 * R. -! -! Output, real ( kind = 8 ) VOLUME, the volume (area) of the spherical cap. -! - implicit none - - real(kind=8) h - real(kind=8) r - real(kind=8) r8_asin - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - real(kind=8) volume - - if (h <= 0.0D+00) then - - volume = 0.0D+00 - - else if (2.0D+00 * r <= h) then - - volume = r8_pi * r * r - - else - - theta = 2.0D+00 * r8_asin(sqrt(r * r - (r - h)**2) / r) - volume = r * r * (theta - sin(theta)) / 2.0D+00 - - if (r < h) then - volume = r8_pi * r * r - volume - end if - - end if - - return -end -subroutine sphere_cap_volume_3d(r, h, volume) - -!*****************************************************************************80 -! -!! SPHERE_CAP_VOLUME_3D computes the volume of a spherical cap in 3D. -! -! Discussion: -! -! Draw any radius of the sphere and note the point P where the radius -! intersects the sphere. Consider the point on the radius line which is -! H units from P. Draw the circle that lies in the plane perpendicular to -! the radius, and which intersects the sphere. The circle divides the sphere -! into two pieces, and the corresponding disk divides the solid sphere into -! two pieces. The part of the solid sphere that includes the point P -! is the spherical cap of height (or thickness) H. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H, the "height" of the spherical cap. H must -! be between 0 and 2 * R. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the spherical cap. -! - implicit none - - real(kind=8) h - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) volume - - if (h <= 0.0D+00) then - volume = 0.0D+00 - else if (2.0D+00 * r <= h) then - volume = (4.0D+00 / 3.0D+00) * r8_pi * r * r * r - else - volume = (1.0D+00 / 3.0D+00) * r8_pi * h * h * (3.0D+00 * r - h) - end if - - return -end -subroutine sphere_cap_volume_nd(dim_num, r, h, volume) - -!*****************************************************************************80 -! -!! SPHERE_CAP_VOLUME_ND computes the volume of a spherical cap in ND. -! -! Discussion: -! -! The spherical cap is a portion of the surface and interior of the sphere: -! -! sum ( X(1:N)^2 ) <= R^2 -! -! which is no more than H units from some point P on the sphere. -! -! -! The algorithm proceeds from the observation that the N-dimensional -! sphere can be parameterized by a quantity RC that runs along the -! radius from the center to the point P. The value of RC at the -! base of the spherical cap is (R-H) and at P it is R. We intend to -! use RC as our integration parameeter. -! -! The volume of the spherical cap is then the integral, as RC goes -! from (R-H) to R, of the N-1 dimensional volume of the sphere -! of radius RS, where RC^2 + RS^2 = R^2. -! -! The volume of the N-1 dimensional sphere of radius RS is simply -! some constants times RS^(N-1). -! -! After factoring out the constant terms, and writing RC = R * cos ( T ), -! and RS = R * sin ( T ), and letting -! T_MAX = arc_sine ( sqrt ( ( 2.0D+00 * r - h ) * h / r ) ), -! the "interesting part" of our integral becomes -! -! constants * R^N * Integral ( T = 0 to T_MAX ) sin^N ( T ) dT -! -! The integral of sin^N ( T ) dT can be handled by recursion. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H, the "thickness" of the spherical cap, -! which is normally between 0 and 2 * R. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the spherical cap. -! - implicit none - - real(kind=8) angle - real(kind=8) factor1 - real(kind=8) factor2 - real(kind=8) h - integer(kind=4) dim_num - real(kind=8) r - real(kind=8) r8_asin - real(kind=8) sin_power_int - real(kind=8) sphere01_volume_nd - real(kind=8) volume - real(kind=8) volume2 - - if (h <= 0.0D+00) then - volume = 0.0D+00 - return - end if - - if (2.0D+00 * r <= h) then - call sphere_imp_volume_nd(dim_num, r, volume) - return - end if - - if (dim_num < 1) then - - volume = -1.0D+00 - - else if (dim_num == 1) then - - volume = h - - else - - factor1 = sphere01_volume_nd(dim_num - 1) - - angle = r8_asin(sqrt((2.0D+00 * r - h) * h / r)) - - factor2 = sin_power_int(0.0D+00, angle, dim_num) - - volume = factor1 * factor2 * r**dim_num - - if (r < h) then - call sphere_imp_volume_nd(dim_num, r, volume2) - volume = volume2 - volume - end if - - end if - - return -end -subroutine sphere_dia2imp_3d(p1, p2, r, pc) - -!*****************************************************************************80 -! -!! SPHERE_DIA2IMP_3D converts a diameter to an implicit sphere in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 + ( P(3) - PC(3) )^2 = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), are two points which form a -! diameter of the sphere. -! -! Output, real ( kind = 8 ) R, the computed radius of the sphere. -! -! Output, real ( kind = 8 ) PC(3), the computed center of the sphere. -! - implicit none - - real(kind=8) p1(3) - real(kind=8) p2(3) - real(kind=8) pc(3) - real(kind=8) r - real(kind=8) r8vec_norm_affine - - r = 0.5D+00 * r8vec_norm_affine(3, p1, p2) - - pc(1:3) = 0.5D+00 * (p1(1:3) + p2(1:3)) - - return -end -subroutine sphere_distance_xyz(xyz1, xyz2, dist) - -!*****************************************************************************80 -! -!! SPHERE_DISTANCE_XYZ computes great circle distances on a sphere. -! -! Discussion: -! -! XYZ coordinates are used. -! -! We assume the points XYZ1 and XYZ2 lie on the same sphere. -! -! This computation is a special form of the Vincenty formula. -! It should be less sensitive to errors associated with very small -! or very large angular separations. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 August 2010 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! "Great-circle distance", -! Wikipedia. -! -! Parameters: -! -! Input, real ( kind = 8 ) XYZ1(3), the coordinates of the first point. -! -! Input, real ( kind = 8 ) XYZ2(3), the coordinates of the second point. -! -! Output, real ( kind = 8 ) DIST, the great circle distance between -! the points. -! - implicit none - - real(kind=8) bot - real(kind=8) dist - real(kind=8) lat1 - real(kind=8) lat2 - real(kind=8) lon1 - real(kind=8) lon2 - real(kind=8) r - real(kind=8) r8_asin - real(kind=8) r8_atan - real(kind=8) r8vec_norm - real(kind=8) top - real(kind=8) xyz1(3) - real(kind=8) xyz2(3) - - r = r8vec_norm(3, xyz1) - - lat1 = r8_asin(xyz1(3)) - lon1 = r8_atan(xyz1(2), xyz1(1)) - - lat2 = r8_asin(xyz2(3)) - lon2 = r8_atan(xyz2(2), xyz2(1)) - - top = (cos(lat2) * sin(lon1 - lon2))**2 & - + (cos(lat1) * sin(lat2) & - - sin(lat1) * cos(lat2) * cos(lon1 - lon2))**2 - - top = sqrt(top) - - bot = sin(lat1) * sin(lat2) & - + cos(lat1) * cos(lat2) * cos(lon1 - lon2) - - dist = r * atan2(top, bot) - - return -end -subroutine sphere_distance1(lat1, lon1, lat2, lon2, r, dist) - -!*****************************************************************************80 -! -!! SPHERE_DISTANCE1 computes great circle distances on a sphere. -! -! Discussion: -! -! This computation is based on the law of cosines for spheres. -! This formula can suffer from rounding errors when the angular -! distances are small. -! -! Here we assume that latitude is measured in radians, and goes -! from -PI at the south pole to +PI at the north pole. -! -! Similarly, longitude is measured in radians, and goes from 0 to 2 PI. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 February 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! "Great-circle distance", -! Wikipedia. -! -! Parameters: -! -! Input, real ( kind = 8 ) LAT1, LON1, the latitude and longitude of -! the first point. -! -! Input, real ( kind = 8 ) LAT2, LON2, the latitude and longitude of -! the second point. -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Output, real ( kind = 8 ) DIST, the great circle distance between -! the points, measured in the same units as R. -! - implicit none - - real(kind=8) c - real(kind=8) dist - real(kind=8) lat1 - real(kind=8) lat2 - real(kind=8) lon1 - real(kind=8) lon2 - real(kind=8) r - - c = cos(lat1) * cos(lat2) * cos(lon1 - lon2) & - + sin(lat1) * sin(lat2) - - dist = r * acos(c) - - return -end -subroutine sphere_distance2(lat1, lon1, lat2, lon2, r, dist) - -!*****************************************************************************80 -! -!! SPHERE_DISTANCE2 computes great circle distances on a sphere. -! -! Discussion: -! -! This computation is written in terms of haversines, and can be more -! accurate when measuring small angular distances. It can be somewhat -! inaccurate when the two points are antipodal. -! -! Here we assume that latitude is measured in radians, and goes -! from -PI at the south pole to +PI at the north pole. -! -! Similarly, longitude is measured in radians, and goes from 0 to 2 PI. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 February 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! "Great-circle distance", -! Wikipedia. -! -! Parameters: -! -! Input, real ( kind = 8 ) LAT1, LON1, the latitude and longitude of -! the first point. -! -! Input, real ( kind = 8 ) LAT2, LON2, the latitude and longitude of -! the second point. -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Output, real ( kind = 8 ) DIST, the great circle distance between -! the points, measured in the same units as R. -! - implicit none - - real(kind=8) dist - real(kind=8) lat1 - real(kind=8) lat2 - real(kind=8) lon1 - real(kind=8) lon2 - real(kind=8) r - real(kind=8) s - - s = (sin((lat1 - lat2) / 2.0D+00))**2 & - + cos(lat1) * cos(lat2) * (sin((lon1 - lon2) / 2.0D+00))**2 - s = sqrt(s) - - dist = 2.0D+00 * r * asin(s) - - return -end -subroutine sphere_distance3(lat1, lon1, lat2, lon2, r, dist) - -!*****************************************************************************80 -! -!! SPHERE_DISTANCE3 computes great circle distances on a sphere. -! -! Discussion: -! -! This computation is a special form of the Vincenty formula. -! It should be less sensitive to errors associated with very small -! or very large angular separations. -! -! Here we assume that latitude is measured in radians, and goes -! from -PI at the south pole to +PI at the north pole. -! -! Similarly, longitude is measured in radians, and goes from 0 to 2 PI. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 February 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! "Great-circle distance", -! Wikipedia. -! -! Parameters: -! -! Input, real ( kind = 8 ) LAT1, LON1, the latitude and longitude of -! the first point. -! -! Input, real ( kind = 8 ) LAT2, LON2, the latitude and longitude of -! the second point. -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Output, real ( kind = 8 ) DIST, the great circle distance between -! the points, measured in the same units as R. -! - implicit none - - real(kind=8) bot - real(kind=8) dist - real(kind=8) lat1 - real(kind=8) lat2 - real(kind=8) lon1 - real(kind=8) lon2 - real(kind=8) r - real(kind=8) top - - top = (cos(lat2) * sin(lon1 - lon2))**2 & - + (cos(lat1) * sin(lat2) & - - sin(lat1) * cos(lat2) * cos(lon1 - lon2))**2 - - top = sqrt(top) - - bot = sin(lat1) * sin(lat2) & - + cos(lat1) * cos(lat2) * cos(lon1 - lon2) - - dist = r * atan2(top, bot) - - return -end -subroutine sphere_exp_contains_point_3d(p1, p2, p3, p4, p, inside) - -!*****************************************************************************80 -! -!! SPHERE_EXP_CONTAINS_POINT_3D: does an explicit sphere contain a point in 3D. -! -! Discussion: -! -! An explicit sphere in 3D is determined by four points, -! which should be distinct, and not coplanar. -! -! The computation checks the determinant of the 5 by 5 matrix: -! -! x1 y1 z1 x1^2+y1^2+z1^2 1 -! x2 y2 z2 x2^2+y2^2+z2^2 1 -! x3 y3 z3 x3^2+y3^2+z3^2 1 -! x4 y4 z4 x4^2+y4^2+z4^2 1 -! x y z x^2 +y^2 +z^2 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), -! four distinct noncoplanar points on the sphere. -! -! Input, real ( kind = 8 ) P(3), the coordinates of a point, whose -! position relative to the sphere is desired. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is in the sphere. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a(5, 5) - real(kind=8) det - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - real(kind=8) r8mat_det_5d -! -! Compute the determinant. -! - a(1, 1:dim_num) = p1(1:dim_num) - a(1, 4) = sum(p1(1:dim_num)**2) - a(1, 5) = 1.0D+00 - - a(2, 1:dim_num) = p2(1:dim_num) - a(2, 4) = sum(p2(1:dim_num)**2) - a(2, 5) = 1.0D+00 - - a(3, 1:dim_num) = p3(1:dim_num) - a(3, 4) = sum(p3(1:dim_num)**2) - a(3, 5) = 1.0D+00 - - a(4, 1:dim_num) = p4(1:dim_num) - a(4, 4) = sum(p4(1:dim_num)**2) - a(4, 5) = 1.0D+00 - - a(5, 1:dim_num) = p(1:dim_num) - a(5, 4) = sum(p(1:dim_num)**2) - a(5, 5) = 1.0D+00 - - det = r8mat_det_5d(a) - - if (det < 0.0D+00) then - inside = .false. - else if (0.0D+00 <= det) then - inside = .true. - end if - - return -end -subroutine sphere_exp_point_near_3d(p1, p2, p3, p4, p, pn) - -!*****************************************************************************80 -! -!! SPHERE_EXP_POINT_NEAR_3D: nearest point on explicit sphere to a point in 3D. -! -! Discussion: -! -! An explicit sphere in 3D is determined by four points, -! which should be distinct, and not coplanar. -! -! If the center of the sphere is PC, and the point is P, then -! the desired point lies at a positive distance R along the vector -! P-PC unless P = PC in which case any point on the sphere is "nearest". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), -! four distinct noncoplanar points on the sphere. -! -! Input, real ( kind = 8 ) P(3), a point whose nearest point on the -! sphere is desired. -! -! Output, real ( kind = 8 ) PN(3), the nearest point on the sphere. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) norm - real(kind=8) p(dim_num) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pn(dim_num) - real(kind=8) r -! -! Find the center. -! - call sphere_exp2imp_3d(p1, p2, p3, p4, r, pc) -! -! If P = PC, bail out now. -! - norm = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) - - if (norm == 0.0D+00) then - pn(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) - return - end if -! -! Compute the nearest point. -! - pn(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / norm - - return -end -subroutine sphere_exp2imp_3d(p1, p2, p3, p4, r, pc) - -!*****************************************************************************80 -! -!! SPHERE_EXP2IMP_3D converts a sphere from explicit to implicit form in 3D. -! -! Discussion: -! -! An explicit sphere in 3D is determined by four points, -! which should be distinct, and not coplanar. -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), -! four distinct noncoplanar points on the sphere. -! -! Output, real ( kind = 8 ) R, PC(3), the radius and the center -! of the sphere. If the linear system is -! singular, then R = -1, PC(1:3) = 0. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) tetra(dim_num, 4) - - tetra(1:dim_num, 1:4) = reshape((/ & - p1(1:dim_num), p2(1:dim_num), p3(1:dim_num), p4(1:dim_num)/), & - (/dim_num, 4/)) - - call tetrahedron_circumsphere_3d(tetra, r, pc) - - return -end -subroutine sphere_exp2imp_nd(n, p, r, pc) - -!*****************************************************************************80 -! -!! SPHERE_EXP2IMP_ND finds an N-dimensional sphere through N+1 points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 July 2011 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the spatial dimension. -! -! Input, real ( kind = 4 ) P(N,N+1), the points. -! -! Output, real ( kind = 8 ) R, PC(N), the radius and center of the -! sphere. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(n, n + 1) - integer(kind=4) i - integer(kind=4) info - integer(kind=4) j - real(kind=8) pc(n) - real(kind=8) r - real(kind=8) p(n, n + 1) -! -! Set up the linear system. -! - a(1:n, 1:n) = transpose(p(1:n, 2:n + 1)) - - do j = 1, n - a(1:n, j) = a(1:n, j) - p(j, 1) - end do - - do i = 1, n - a(i, n + 1) = sum(a(i, 1:n)**2) - end do -! -! Solve the linear system. -! - call r8mat_solve(n, 1, a, info) -! -! If the system was singular, return a consolation prize. -! - if (info /= 0) then - r = -1.0D+00 - pc(1:n) = 0.0D+00 - return - end if -! -! Compute the radius and center. -! - r = 0.5D+00 * sqrt(sum(a(1:n, n + 1)**2)) - - pc(1:n) = p(1:n, 1) + 0.5D+00 * a(1:n, n + 1) - - return -end -subroutine sphere_imp_area_3d(r, area) - -!*****************************************************************************80 -! -!! SPHERE_IMP_AREA_3D computes the surface area of an implicit sphere in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 13 August 2014 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Output, real ( kind = 8 ) AREA, the area of the sphere. -! - implicit none - - real(kind=8) area - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - area = 4.0D+00 * r8_pi * r * r - - return -end -subroutine sphere_imp_area_nd(dim_num, r, area) - -!*****************************************************************************80 -! -!! SPHERE_IMP_AREA_ND computes the surface area of an implicit sphere in ND. -! -! Discussion: -! -! An implicit sphere in ND satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - pc(1:DIM_NUM) )^2 ) = R^2 -! -! DIM_NUM Area -! -! 2 2 * PI * R -! 3 4 * PI * R^2 -! 4 2 * PI^2 * R^3 -! 5 (8/3) * PI^2 * R^4 -! 6 PI^3 * R^5 -! 7 (16/15) * PI^3 * R^6 -! -! Sphere_Area ( DIM_NUM, R ) = -! 2 * PI^(DIM_NUM/2) * R^(DIM_NUM-1) / Gamma ( DIM_NUM / 2 ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Output, real ( kind = 8 ) AREA, the area of the sphere. -! - implicit none - - real(kind=8) area - integer(kind=4) dim_num - real(kind=8) r - real(kind=8) sphere01_area_nd - - area = r**(dim_num - 1) * sphere01_area_nd(dim_num) - - return -end -subroutine sphere_imp_contains_point_3d(r, pc, p, inside) - -!*****************************************************************************80 -! -!! SPHERE_IMP_CONTAINS_POINT_3D: point in implicit sphere in 3D? -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 February 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) PC(3), the center of the sphere. -! -! Input, real ( kind = 8 ) P(3), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is -! inside the sphere. -! - implicit none - - logical(kind=4) inside - real(kind=8) p(3) - real(kind=8) pc(3) - real(kind=8) r - - if (sum((p(1:3) - pc(1:3))**2) <= r * r) then - inside = .true. - else - inside = .false. - end if - - return -end -subroutine sphere_imp_line_project_3d(r, pc, n, p, maxpnt2, n2, pp, & - theta_min, theta_max) - -!*****************************************************************************80 -! -!! SPHERE_IMP_LINE_PROJECT_3D projects a line onto an implicit sphere in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! The line to be projected is specified as a sequence of points. -! If two successive points subtend a small angle, then the second -! point is essentially dropped. If two successive points subtend -! a large angle, then intermediate points are inserted, so that -! the projected line stays closer to the sphere. -! -! Note that if any P coincides with the center of the sphere, then -! its projection is mathematically undefined. PP will -! be returned as the center. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. If R is -! zero, PP will be returned as the pc, and if R is -! negative, points will end up diametrically opposite from where -! you would expect them for a positive R. -! -! Input, real ( kind = 8 ) PC(3), the center of the sphere. -! -! Input, integer ( kind = 4 ) N, the number of points on the line that is -! to be projected. -! -! Input, real ( kind = 8 ) P(3,N), the coordinates of -! the points on the line that is to be projected. -! -! Input, integer ( kind = 4 ) MAXPNT2, the maximum number of points on the -! projected line. Even if the routine thinks that more points are needed, -! no more than MAXPNT2 will be generated. -! -! Output, integer ( kind = 4 ) N2, the number of points on the projected -! line. N2 can be zero, if the line has an angular projection of less -! than THETA_MIN radians. -! -! Output, real ( kind = 8 ) PP(3,N2), the coordinates -! of the points representing the projected line. These points lie on the -! sphere. Successive points are separated by at least THETA_MIN -! radians, and by no more than THETA_MAX radians. -! -! Input, real ( kind = 8 ) THETA_MIN, THETA_MAX, the minimum and maximum -! angular projections allowed between successive projected points. -! If two successive points on the original line have projections -! separated by more than THETA_MAX radians, then intermediate points -! will be inserted, in an attempt to keep the line closer to the -! sphere. If two successive points are separated by less than -! THETA_MIN radians, then the second point is dropped, and the -! line from the first point to the next point is considered. -! - implicit none - - integer(kind=4) maxpnt2 - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) n - - real(kind=8) alpha - real(kind=8) ang3d - real(kind=8) dot - integer(kind=4) i - integer(kind=4) j - integer(kind=4) nfill - integer(kind=4) n2 - real(kind=8) p(dim_num, n) - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pd(dim_num) - real(kind=8) pp(dim_num, maxpnt2) - real(kind=8) r - real(kind=8) r8_acos - real(kind=8) theta_max - real(kind=8) theta_min - real(kind=8) tnorm -! -! Check the input. -! - if (r == 0.0D+00) then - n2 = 0 - return - end if - - p1(1:dim_num) = pc(1:dim_num) - p2(1:dim_num) = pc(1:dim_num) - - n2 = 0 - - do i = 1, n - - if (all(p(1:dim_num, i) == pc(1:dim_num))) then - - else - - p1(1:dim_num) = p2(1:dim_num) - - alpha = sqrt(sum((p(1:dim_num, i) - pc(1:dim_num))**2)) - - p2(1:dim_num) = pc(1:dim_num) & - + r * (p(1:dim_num, i) - pc(1:dim_num)) / alpha -! -! If we haven't gotten any points yet, take this point as our start. -! - if (n2 == 0) then - - n2 = n2 + 1 - pp(1:dim_num, n2) = p2(1:dim_num) -! -! Compute the angular projection of P1 to P2. -! - else if (1 <= n2) then - - dot = sum((p1(1:dim_num) - pc(1:dim_num)) & - * (p2(1:dim_num) - pc(1:dim_num))) - - ang3d = r8_acos(dot / (r * r)) -! -! If the angle is at least THETA_MIN, (or it's the last point), -! then we will draw a line segment. -! - if (theta_min < abs(ang3d) .or. i == n) then -! -! Now we check to see if the line segment is too long. -! - if (theta_max < abs(ang3d)) then - - nfill = int(abs(ang3d) / theta_max) - - do j = 1, nfill - 1 - - pd(1:dim_num) = & - (real(nfill - j, kind=8) & - * (p1(1:dim_num) - pc(1:dim_num)) & - + real(j, kind=8) & - * (p2(1:dim_num) - pc(1:dim_num))) - - tnorm = sqrt(sum(pd(1:dim_num)**2)) - - if (tnorm /= 0.0D+00) then - pd(1:dim_num) = pc(1:dim_num) + r * pd(1:dim_num) / tnorm - n2 = n2 + 1 - pp(1:dim_num, n2) = pd(1:dim_num) - end if - - end do - - end if -! -! Now tack on the projection of point 2. -! - n2 = n2 + 1 - pp(1:dim_num, n2) = p2(1:dim_num) - - end if - - end if - - end if - - end do - - return -end -subroutine sphere_imp_local2xyz_3d(r, pc, theta, phi, p) - -!*****************************************************************************80 -! -!! SPHERE_IMP_LOCAL2XYZ_3D: local to XYZ coordinates on implicit sphere in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! The "local" spherical coordinates of a point are two angles, THETA and PHI. -! PHI measures the angle that the vector from the origin to the point -! makes with the positive Z axis. THETA measures the angle that the -! projection of the vector onto the XY plane makes with the positive X axis. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 July 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) PC(3), the center of the sphere. -! -! Input, real ( kind = 8 ) THETA, PHI, the local (THETA,PHI) spherical -! coordinates of a point on the sphere. THETA and PHI are angles, -! measured in radians. Usually, 0 <= THETA < 2 * PI, and 0 <= PHI <= PI. -! -! Output, real ( kind = 8 ) P(3), the XYZ coordinates of the point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) phi - real(kind=8) r - real(kind=8) theta - - p(1) = pc(1) + r * sin(phi) * cos(theta) - p(2) = pc(2) + r * sin(phi) * sin(theta) - p(3) = pc(3) + r * cos(phi) - - return -end -subroutine sphere_imp_point_near_3d(r, pc, p, pn) - -!*****************************************************************************80 -! -!! SPHERE_IMP_POINT_NEAR_3D: nearest point on implicit sphere to a point in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! If the center of the sphere is PC, and the point is P, then -! the desired point lies at a positive distance R along the vector -! P-PC unless P = PC, in which case any point on the sphere is "nearest". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 14 July 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) PC(3), the center of the sphere. -! -! Input, real ( kind = 8 ) P(3), a point whose -! nearest point on the sphere is desired. -! -! Output, real ( kind = 8 ) PN(3), the nearest point on the sphere. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) norm - real(kind=8) p(3) - real(kind=8) pc(3) - real(kind=8) pn(3) - real(kind=8) r -! -! If P = PC, bail out now. -! - norm = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) - - if (norm == 0.0D+00) then - pn(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) - return - end if -! -! Compute the nearest point. -! - pn(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / norm - - return -end -subroutine sphere_imp_point_project_3d(r, pc, p, pp) - -!*****************************************************************************80 -! -!! SPHERE_IMP_POINT_PROJECT_3D projects a point onto an implicit sphere in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) PC(3), the center of the sphere. -! -! Input, real ( kind = 8 ) P(3), a point. -! -! Output, real ( kind = 8 ) PP(3), the projected point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) norm - real(kind=8) p(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) pp(dim_num) - real(kind=8) r - - if (r == 0.0D+00) then - - pp(1:dim_num) = pc(1:dim_num) - - else if (all(p(1:dim_num) == pc(1:dim_num))) then - - pp(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) - - else - - norm = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) - - pp(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / norm - - end if - - return -end -subroutine sphere_imp_volume_3d(r, volume) - -!*****************************************************************************80 -! -!! SPHERE_IMP_VOLUME_3D computes the volume of an implicit sphere in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - pc(1:DIM_NUM) )^2 ) = R^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 January 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the sphere. -! - implicit none - - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) volume - - volume = (4.0D+00 / 3.0D+00) * r8_pi * r * r * r - - return -end -subroutine sphere_imp_volume_nd(dim_num, r, volume) - -!*****************************************************************************80 -! -!! SPHERE_IMP_VOLUME_ND computes the volume of an implicit sphere in ND. -! -! Discussion: -! -! An implicit sphere in ND satisfies the equation: -! -! sum ( ( X(1:N) - PC(1:N) )^2 ) = R^2 -! -! where R is the radius and PC is the center. -! -! Results for the first few values of N are: -! -! DIM_NUM Volume -! - ----------------------- -! 2 PI * R^2 -! 3 (4/3) * PI * R^3 -! 4 (1/2) * PI^2 * R^4 -! 5 (8/15) * PI^2 * R^5 -! 6 (1/6) * PI^3 * R^6 -! 7 (16/105) * PI^3 * R^7 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the sphere. -! - implicit none - - integer(kind=4) dim_num - real(kind=8) r - real(kind=8) sphere01_volume_nd - real(kind=8) volume - - volume = r**dim_num * sphere01_volume_nd(dim_num) - - return -end -subroutine sphere_imp_zone_area_3d(r, h1, h2, area) - -!*****************************************************************************80 -! -!! SPHERE_IMP_ZONE_AREA_3D computes the surface area of a spherical zone in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! Draw any radius of the sphere and note the point P where the radius -! intersects the sphere. Now choose two points on the radius line, a -! distance H1 and H2 from the point P. Consider all the points on or within -! the sphere whose projection onto the radius lies between these two points. -! These points constitute the spherical zone, which can also be considered -! the difference of two spherical caps. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H1, H2, the distances that define the -! thickness of the zone. H1 and H2 must be between 0 and 2 * R. -! -! Output, real ( kind = 8 ) AREA, the area of the spherical zone. -! - implicit none - - real(kind=8) area - real(kind=8) h - real(kind=8) h1 - real(kind=8) h2 - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - - h = abs(h1 - h2) - - if (h <= 0.0D+00) then - area = 0.0D+00 - else if (2.0D+00 * r <= h) then - area = 4.0D+00 * r8_pi * r * r - else - area = 2.0D+00 * r8_pi * r * h - end if - - return -end -subroutine sphere_imp_zone_volume_3d(r, h1, h2, volume) - -!*****************************************************************************80 -! -!! SPHERE_IMP_ZONE_VOLUME_3D computes the volume of a spherical zone in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - pc(1:DIM_NUM) )^2 ) = R^2 -! -! Draw any radius of the sphere and note the point P where the radius -! intersects the sphere. Now choose two points on the radius line, a -! distance H1 and H2 from the point P. Consider all the points on or within -! the sphere whose projection onto the radius lies between these two points. -! These points constitute the spherical zone, which can also be considered -! the difference of two spherical caps. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 April 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) H1, H2, the distances that define the -! thickness of the zone. H1 and H2 must be between 0 and 2 * R. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the spherical zone -! - implicit none - - real(kind=8) h1 - real(kind=8) h11 - real(kind=8) h2 - real(kind=8) h22 - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) volume - - h11 = min(h1, h2) - h11 = max(h11, 0.0D+00) - - if (2.0D+00 * r <= h11) then - volume = 0.0D+00 - return - end if - - h22 = max(h1, h2) - h22 = min(h22, 2.0D+00 * r) - - if (h22 <= 0.0D+00) then - volume = 0.0D+00 - return - end if - - volume = (1.0D+00 / 3.0D+00) * r8_pi * ( & - h22 * h22 * (3.0D+00 * r - h22) & - - h11 * h11 * (3.0D+00 * r - h11)) - - return -end -subroutine sphere_imp2exp_3d(r, pc, p1, p2, p3, p4) - -!*****************************************************************************80 -! -!! SPHERE_IMP2EXP_3D converts a sphere from implicit to explicit form in 3D. -! -! Discussion: -! -! An implicit sphere in 3D satisfies the equation: -! -! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 -! -! An explicit sphere in 3D is determined by four points, -! which should be distinct, and not coplanar. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 February 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) R, PC(3), the radius and center of the sphere. -! -! Output, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), -! four distinct noncoplanar points on the sphere. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) p1(dim_num) - real(kind=8) p2(dim_num) - real(kind=8) p3(dim_num) - real(kind=8) p4(dim_num) - real(kind=8) pc(dim_num) - real(kind=8) phi - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) theta - - theta = 0.0D+00 - phi = 0.0D+00 - - p1(1) = pc(1) + r * cos(theta) * sin(phi) - p1(2) = pc(2) + r * sin(theta) * sin(phi) - p1(3) = pc(3) + r * cos(phi) - - theta = 0.0D+00 - phi = 2.0D+00 * r8_pi / 3.0D+00 - - p2(1) = pc(1) + r * cos(theta) * sin(phi) - p2(2) = pc(2) + r * sin(theta) * sin(phi) - p2(3) = pc(3) + r * cos(phi) - - theta = 2.0D+00 * r8_pi / 3.0D+00 - phi = 2.0D+00 * r8_pi / 3.0D+00 - - p3(1) = pc(1) + r * cos(theta) * sin(phi) - p3(2) = pc(2) + r * sin(theta) * sin(phi) - p3(3) = pc(3) + r * cos(phi) - - theta = 4.0D+00 * r8_pi / 3.0D+00 - phi = 2.0D+00 * r8_pi / 3.0D+00 - - p4(1) = pc(1) + r * cos(theta) * sin(phi) - p4(2) = pc(2) + r * sin(theta) * sin(phi) - p4(3) = pc(3) + r * cos(phi) - - return -end -function sphere_k(dim_num) - -!*****************************************************************************80 -! -!! SPHERE_K computes a factor useful for spherical computations. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 December 2001 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Thomas Ericson, Victor Zinoviev, -! Codes on Euclidean Spheres, -! Elsevier, 2001, pages 439-441. -! QA166.7 E75 -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. -! -! Output, real ( kind = 8 ) SPHERE_K, the factor. -! - implicit none - - integer(kind=4) i4_factorial2 - integer(kind=4) dim_num - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) sphere_k - - if (mod(dim_num, 2) == 0) then - sphere_k = (2.0D+00 * r8_pi)**(dim_num / 2) - else - sphere_k = 2.0D+00 * (2.0D+00 * r8_pi)**((dim_num - 1) / 2) - end if - - sphere_k = sphere_k / real(i4_factorial2(dim_num - 2), kind=8) - - return -end -subroutine sphere_triangle_angles_to_area(r, a, b, c, area) - -!*****************************************************************************80 -! -!! SPHERE_TRIANGLE_ANGLES_TO_AREA computes the area of a spherical triangle. -! -! Discussion: -! -! A sphere centered at 0 in 3D satisfies the equation: -! -! X*X + Y*Y + Z*Z = R*R -! -! A spherical triangle is specified by three points on the surface -! of the sphere. -! -! The area formula is known as Girard's formula. -! -! The area of a spherical triangle is: -! -! AREA = ( A + B + C - PI ) * R*R -! -! where A, B and C are the (surface) angles of the triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) A, B, C, the angles of the triangle. -! -! Output, real ( kind = 8 ) AREA, the area of the spherical triangle. -! - implicit none - - real(kind=8) a - real(kind=8) area - real(kind=8) b - real(kind=8) c - real(kind=8) r - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 -! -! Apply Girard's formula. -! - area = r * r * (a + b + c - r8_pi) - - return -end -subroutine sphere_triangle_sides_to_angles(r, as, bs, cs, a, b, c) - -!*****************************************************************************80 -! -!! SPHERE_TRIANGLE_SIDES_TO_ANGLES computes spherical triangle angles. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the -! sides of the triangle. -! -! Output, real ( kind = 8 ) A, B, C, the spherical angles of the triangle. -! Angle A is opposite the side of length AS, and so on. -! - implicit none - - real(kind=8) a - real(kind=8) as - real(kind=8) asu - real(kind=8) b - real(kind=8) bs - real(kind=8) bsu - real(kind=8) c - real(kind=8) cs - real(kind=8) csu - real(kind=8) r - real(kind=8) ssu - real(kind=8) tan_a2 - real(kind=8) tan_b2 - real(kind=8) tan_c2 - - asu = as / r - bsu = bs / r - csu = cs / r - ssu = (asu + bsu + csu) / 2.0D+00 - - tan_a2 = sqrt((sin(ssu - bsu) * sin(ssu - csu)) / & - (sin(ssu) * sin(ssu - asu))) - - a = 2.0D+00 * atan(tan_a2) - - tan_b2 = sqrt((sin(ssu - asu) * sin(ssu - csu)) / & - (sin(ssu) * sin(ssu - bsu))) - - b = 2.0D+00 * atan(tan_b2) - - tan_c2 = sqrt((sin(ssu - asu) * sin(ssu - bsu)) / & - (sin(ssu) * sin(ssu - csu))) - - c = 2.0D+00 * atan(tan_c2) - - return -end -subroutine sphere_triangle_vertices_to_angles(r, v1, v2, v3, a, b, c) - -!*****************************************************************************80 -! -!! SPHERE_TRIANGLE_VERTICES_TO_ANGLES: spherical triangle angles from vertices. -! -! Discussion: -! -! A sphere centered at 0 in 3D satisfies the equation: -! -! X * X + Y * Y + Z * Z = R * R -! -! A spherical triangle is specified by three points on the surface -! of the sphere. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 24 August 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. -! -! Output, real ( kind = 8 ) A, B, C, the angles of the spherical triangle. -! - implicit none - - real(kind=8) a - real(kind=8) as - real(kind=8) b - real(kind=8) bs - real(kind=8) c - real(kind=8) cs - real(kind=8) r - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) -! -! Compute the lengths of the sides of the spherical triangle. -! - call sphere_triangle_vertices_to_sides(r, v1, v2, v3, as, bs, cs) -! -! Get the spherical angles. -! - call sphere_triangle_sides_to_angles(r, as, bs, cs, a, b, c) - - return -end -subroutine sphere_triangle_vertices_to_area(r, v1, v2, v3, area) - -!*****************************************************************************80 -! -!! SPHERE_TRIANGLE_VERTICES_TO_AREA computes the area of a spherical triangle. -! -! Discussion: -! -! A sphere centered at 0 in 3D satisfies the equation: -! -! X * X + Y * Y + Z * Z = R * R -! -! A spherical triangle is specified by three points on the surface -! of the sphere. -! -! The area formula is known as Girard's formula. -! -! The area of a spherical triangle is: -! -! AREA = ( A + B + C - PI ) * R*R -! -! where A, B and C are the (surface) angles of the triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. -! -! Output, real ( kind = 8 ) AREA, the area of the spherical triangle. -! - implicit none - - real(kind=8) a - real(kind=8) area - real(kind=8) as - real(kind=8) b - real(kind=8) bs - real(kind=8) c - real(kind=8) cs - real(kind=8) r - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) -! -! Compute the lengths of the sides of the spherical triangle. -! - call sphere_triangle_vertices_to_sides(r, v1, v2, v3, as, bs, cs) -! -! Get the spherical angles. -! - call sphere_triangle_sides_to_angles(r, as, bs, cs, a, b, c) -! -! Get the area. -! - call sphere_triangle_angles_to_area(r, a, b, c, area) - - return -end -subroutine sphere_triangle_vertices_to_centroid(r, v1, v2, v3, vs) - -!*****************************************************************************80 -! -!! SPHERE_TRIANGLE_VERTICES_TO_CENTROID gets a spherical triangle centroid. -! -! Discussion: -! -! A sphere centered at 0 in 3D satisfies the equation: -! -! X*X + Y*Y + Z*Z = R*R -! -! A spherical triangle is specified by three points on the sphere. -! -! The (true) centroid of a spherical triangle is the point -! -! VT = (XT,YT,ZT) = Integral ( X, Y, Z ) dArea / Integral 1 dArea -! -! Note that the true centroid does NOT, in general, lie on the sphere. -! -! The "flat" centroid VF is the centroid of the planar triangle defined by -! the vertices of the spherical triangle. -! -! The "spherical" centroid VS of a spherical triangle is computed by -! the intersection of the geodesic bisectors of the triangle angles. -! The spherical centroid lies on the sphere. -! -! VF, VT and VS lie on a line through the center of the sphere. We can -! easily calculate VF by averaging the vertices, and from this determine -! VS by normalizing. -! -! Of course, we still will not have actually computed VT, which lies -! somewhere between VF and VS! -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. -! -! Output, real ( kind = 8 ) VS(3), the coordinates of the "spherical -! centroid" of the spherical triangle. -! - implicit none - - real(kind=8) norm - real(kind=8) r - real(kind=8) r8vec_norm - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - real(kind=8) vs(3) - - vs(1:3) = (v1(1:3) + v2(1:3) + v3(1:3)) / 3.0D+00 - - norm = r8vec_norm(3, vs) - - vs(1:3) = r * vs(1:3) / norm - - return -end -subroutine sphere_triangle_vertices_to_orientation(a, b, c, o) - -!*****************************************************************************80 -! -!! SPHERE_TRIANGLE_VERTICES_TO_ORIENTATION: orientation of a spherical triangle. -! -! Discussion: -! -! Three points on a sphere actually compute two triangles; typically -! we are interested in the smaller of the two. -! -! As long as our triangle is "small", we can define an orientation -! by comparing the direction of the centroid against the normal -! vector (C-B) x (A-B). If the dot product of these vectors -! is positive, we say the triangle has positive orientation. -! -! By using information from the triangle orientation, we can correctly -! determine the area of a Voronoi polygon by summing up the pieces -! of Delaunay triangles, even in the case when the Voronoi vertex -! lies outside the Delaunay triangle. In that case, the areas of -! some of the Delaunay triangle pieces must be formally negative. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 May 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A(3), B(3), C(3), three points on a sphere. -! -! Output, integer ( kind = 4 ) O, is +1 if the spherical triangle is -! judged to have positive orientation, and -1 otherwise. -! - implicit none - - real(kind=8) a(3) - real(kind=8) b(3) - real(kind=8) c(3) - real(kind=8) cd(3) - real(kind=8) cp(3) - integer(kind=4) o - real(kind=8) v1(3) - real(kind=8) v2(3) -! -! Centroid. -! - cd(1:3) = (a(1:3) + b(1:3) + c(1:3)) / 3.0D+00 -! -! Cross product ( C - B ) x ( A - B ); -! - v1(1:3) = c(1:3) - b(1:3) - v2(1:3) = a(1:3) - b(1:3) - - cp(1) = v1(2) * v2(3) - v1(3) * v2(2) - cp(2) = v1(3) * v2(1) - v1(1) * v2(3) - cp(3) = v1(1) * v2(2) - v1(2) * v2(1) -! -! Compare the directions. -! - if (dot_product(cp, cd) < 0.0D+00) then - o = -1 - else - o = +1 - end if - - return -end -subroutine sphere_triangle_vertices_to_sides(r, v1, v2, v3, as, bs, cs) - -!*****************************************************************************80 -! -!! SPHERE_TRIANGLE_VERTICES_TO_SIDES computes spherical triangle sides. -! -! Discussion: -! -! We can use the ACOS system call here, but the ARC_COSINE routine -! will automatically take care of cases where the input argument is -! (usually slightly) out of bounds. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R, the radius of the sphere. -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the spherical -! triangle. -! -! Output, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the sides -! of the triangle. -! - implicit none - - real(kind=8) as - real(kind=8) bs - real(kind=8) cs - real(kind=8) r - real(kind=8) r8_acos - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - - as = r * r8_acos(dot_product(v2(1:3), v3(1:3)) / r**2) - bs = r * r8_acos(dot_product(v3(1:3), v1(1:3)) / r**2) - cs = r * r8_acos(dot_product(v1(1:3), v2(1:3)) / r**2) - - return -end -function sphere01_area_nd(dim_num) - -!*****************************************************************************80 -! -!! SPHERE01_AREA_ND computes the surface area of a unit sphere in ND. -! -! Discussion: -! -! The unit sphere in ND satisfies: -! -! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 -! -! Results for the first few values of N are: -! -! DIM_NUM Area -! -! 2 2 * PI -! 3 4 * PI -! 4 ( 2 / 1) * PI^2 -! 5 ( 8 / 3) * PI^2 -! 6 ( 1 / 1) * PI^3 -! 7 (16 / 15) * PI^3 -! 8 ( 1 / 3) * PI^4 -! 9 (32 / 105) * PI^4 -! 10 ( 1 / 12) * PI^5 -! -! For the unit sphere, Area(DIM_NUM) = DIM_NUM * Volume(DIM_NUM) -! -! Sphere_Unit_Area ( DIM_NUM ) = 2 * PI^(DIM_NUM/2) / Gamma ( DIM_NUM / 2 ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. -! -! Output, real ( kind = 8 ) SPHERE01_AREA_ND, the area of the sphere. -! - implicit none - - real(kind=8) area - integer(kind=4) dim_num - integer(kind=4) i - integer(kind=4) m - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) sphere01_area_nd - - if (mod(dim_num, 2) == 0) then - m = dim_num / 2 - area = 2.0D+00 * (r8_pi)**m - do i = 1, m - 1 - area = area / real(i, kind=8) - end do - else - m = (dim_num - 1) / 2 - area = (r8_pi)**m * 2.0D+00**dim_num - do i = m + 1, 2 * m - area = area / real(i, kind=8) - end do - end if - - sphere01_area_nd = area - - return -end -subroutine sphere01_area_values(n_data, n, area) - -!*****************************************************************************80 -! -!! SPHERE01_AREA_VALUES returns some areas of the unit sphere in ND. -! -! Discussion: -! -! The formula for the surface area of the unit sphere in N dimensions is: -! -! Sphere_Unit_Area ( N ) = 2 * pi^(N/2) / Gamma ( N / 2 ) -! -! Some values of the function include: -! -! N Area -! -! 2 2 * PI -! 3 ( 4 / ) * PI -! 4 ( 2 / 1) * PI^2 -! 5 ( 8 / 3) * PI^2 -! 6 ( 1 / 1) * PI^3 -! 7 (16 / 15) * PI^3 -! 8 ( 1 / 3) * PI^4 -! 9 (32 / 105) * PI^4 -! 10 ( 1 / 12) * PI^5 -! -! For the unit sphere, Area(N) = N * Volume(N) -! -! In Mathematica, the function can be evaluated by: -! -! 2 * Pi^(n/2) / Gamma[n/2] -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 August 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Stephen Wolfram, -! The Mathematica Book, -! Fourth Edition, -! Cambridge University Press, 1999, -! ISBN: 0-521-64314-7, -! LC: QA76.95.W65. -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 -! before the first call. On each call, the routine increments N_DATA by 1, -! and returns the corresponding data; when there is no more data, the -! output value of N_DATA will be 0 again. -! -! Output, integer ( kind = 4 ) N, the spatial dimension. -! -! Output, real ( kind = 8 ) AREA, the area of the unit sphere -! in that dimension. -! - implicit none - - integer(kind=4), parameter :: n_max = 20 - - real(kind=8) area - real(kind=8), save, dimension(n_max) :: area_vec = (/ & - 0.2000000000000000D+01, & - 0.6283185307179586D+01, & - 0.1256637061435917D+02, & - 0.1973920880217872D+02, & - 0.2631894506957162D+02, & - 0.3100627668029982D+02, & - 0.3307336179231981D+02, & - 0.3246969701133415D+02, & - 0.2968658012464836D+02, & - 0.2550164039877345D+02, & - 0.2072514267328890D+02, & - 0.1602315322625507D+02, & - 0.1183817381218268D+02, & - 0.8389703410491089D+01, & - 0.5721649212349567D+01, & - 0.3765290085742291D+01, & - 0.2396678817591364D+01, & - 0.1478625959000308D+01, & - 0.8858104195716824D+00, & - 0.5161378278002812D+00/) - integer(kind=4) n_data - integer(kind=4) n - integer(kind=4), save, dimension(n_max) :: n_vec = (/ & - 1, & - 2, & - 3, & - 4, & - 5, & - 6, & - 7, & - 8, & - 9, & - 10, & - 11, & - 12, & - 13, & - 14, & - 15, & - 16, & - 17, & - 18, & - 19, & - 20/) - - if (n_data < 0) then - n_data = 0 - end if - - n_data = n_data + 1 - - if (n_max < n_data) then - n_data = 0 - n = 0 - area = 0.0D+00 - else - n = n_vec(n_data) - area = area_vec(n_data) - end if - - return -end -subroutine sphere01_sample_2d(seed, x) - -!*****************************************************************************80 -! -!! SPHERE01_SAMPLE_2D picks a random point on the unit sphere (circle) in 2D. -! -! Discussion: -! -! The unit sphere in 2D satisfies: -! -! X * X + Y * Y = 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(2), a random point on the unit circle. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) r8_uniform_01 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seed - real(kind=8) u - real(kind=8) x(dim_num) - - u = r8_uniform_01(seed) - - x(1) = cos(2.0D+00 * r8_pi * u) - x(2) = sin(2.0D+00 * r8_pi * u) - - return -end -subroutine sphere01_sample_3d(seed, x) - -!*****************************************************************************80 -! -!! SPHERE01_SAMPLE_3D picks a random point on the unit sphere in 3D. -! -! Discussion: -! -! The unit sphere in 3D satisfies: -! -! X * X + Y * Y + Z * Z = 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(3), the sample point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) r8_acos - real(kind=8) r8_uniform_01 - real(kind=8) phi - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seed - real(kind=8) theta - real(kind=8) vdot - real(kind=8) x(dim_num) -! -! Pick a uniformly random VDOT, which must be between -1 and 1. -! This represents the dot product of the random vector with the Z unit vector. -! -! Note: this works because the surface area of the sphere between -! Z and Z + dZ is independent of Z. So choosing Z uniformly chooses -! a patch of area uniformly. -! - vdot = r8_uniform_01(seed) - vdot = 2.0D+00 * vdot - 1.0D+00 - - phi = r8_acos(vdot) -! -! Pick a uniformly random rotation between 0 and 2 Pi around the -! axis of the Z vector. -! - theta = r8_uniform_01(seed) - theta = 2.0D+00 * r8_pi * theta - - x(1) = cos(theta) * sin(phi) - x(2) = sin(theta) * sin(phi) - x(3) = cos(phi) - - return -end -subroutine sphere01_sample_3d_2(seed, x) - -!*****************************************************************************80 -! -!! SPHERE01_SAMPLE_3D_2 is a BAD method for sampling the unit sphere in 3D. -! -! Discussion: -! -! The unit sphere in 3D satisfies: -! -! X * X + Y * Y + Z * Z = 1 -! -! Points on the unit sphere have coordinates ( PHI, THETA ) where -! PHI varies from 0 to PI, and THETA from 0 to 2 PI, so that: -! -! x = cos ( theta ) * sin ( phi ) -! y = sin ( theta ) * sin ( phi ) -! z = cos ( phi ) -! -! This routine implements a sampling of the sphere that simply -! picks PHI and THETA uniformly at random from their ranges. -! This is a uniform sampling on the cylinder, but it is NOT -! a uniform sampling on the sphere. I implement it here just -! so I can run some tests against the code in SPHERE_UNIT_SAMPLE_3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(3), the sample point. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) r8_uniform_01 - real(kind=8) phi - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - integer(kind=4) seed - real(kind=8) theta - real(kind=8) x(dim_num) - - phi = r8_uniform_01(seed) - phi = r8_pi * phi - - theta = r8_uniform_01(seed) - theta = 2.0D+00 * r8_pi * theta - - x(1) = cos(theta) * sin(phi) - x(2) = sin(theta) * sin(phi) - x(3) = cos(phi) - - return -end -subroutine sphere01_sample_nd(dim_num, seed, x) - -!*****************************************************************************80 -! -!! SPHERE01_SAMPLE_ND picks a random point on the unit sphere in ND. -! -! Discussion: -! -! The unit sphere in ND satisfies: -! -! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 -! -! DIM_NUM-1 random Givens rotations are applied to the point -! ( 1, 0, 0, ..., 0 ). -! -! The I-th Givens rotation is in the plane of coordinate axes I and I+1, -! and has the form: -! -! [ cos ( theta ) - sin ( theta ) ] * x(i) = x'(i) -! [ sin ( theta ) cos ( theta ) ] x(i+1) x'(i+1) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(DIM_NUM), the random point. -! - implicit none - - integer(kind=4) dim_num - - integer(kind=4) i - real(kind=8) r8_uniform_01 - real(kind=8) random_cosine - real(kind=8) random_sign - real(kind=8) random_sine - integer(kind=4) seed - real(kind=8) x(dim_num) - real(kind=8) xi - - x(1) = 1.0D+00 - x(2:dim_num) = 0.0D+00 - - do i = 1, dim_num - 1 - random_cosine = r8_uniform_01(seed) - random_cosine = 2.0D+00 * random_cosine - 1.0D+00 - random_sign = r8_uniform_01(seed) - random_sign = real(2 * int(2.0D+00 * random_sign) - 1, kind=8) - random_sine = random_sign * sqrt(1.0D+00 - random_cosine**2) - xi = x(i) - x(i) = random_cosine * xi - x(i + 1) = random_sine * xi - end do - - return -end -subroutine sphere01_sample_nd_2(dim_num, seed, x) - -!*****************************************************************************80 -! -!! SPHERE01_SAMPLE_ND_2 picks a random point on the unit sphere in ND. -! -! Discussion: -! -! The unit sphere in ND satisfies: -! -! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 -! -! DIM_NUM independent normally distributed random numbers are generated, -! and then scaled to have unit norm. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(DIM_NUM), the random point. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) norm - integer(kind=4) seed - real(kind=8) x(dim_num) - - call r8vec_normal_01(dim_num, seed, x) - - norm = sqrt(sum(x(1:dim_num)**2)) - - x(1:dim_num) = x(1:dim_num) / norm - - return -end -subroutine sphere01_sample_nd_3(dim_num, seed, x) - -!*****************************************************************************80 -! -!! SPHERE01_SAMPLE_ND_3 picks a random point on the unit sphere in ND. -! -! Discussion: -! -! The unit sphere in ND satisfies: -! -! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 -! -! Points in the [-1,1] cube are generated. Points lying outside -! the sphere are rejected. Points inside the unit sphere are normalized -! to lie on the sphere. -! -! Because the volume of the unit sphere -! relative to the unit cube decreases drastically in higher dimensions, -! this routine becomes increasingly inefficient at higher DIM_NUM. -! Above DIM_NUM = 5, this problem will become significant. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(DIM_NUM), the random point. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) norm - integer(kind=4) seed - real(kind=8) x(dim_num) - - do - - call r8vec_uniform_01(dim_num, seed, x) - - x(1:dim_num) = 2.0D+00 * x(1:dim_num) - 1.0D+00 - - norm = sqrt(sum(x(1:dim_num)**2)) - - if (norm <= 1.0E00) then - x(1:dim_num) = x(1:dim_num) / norm - exit - end if - - end do - - return -end -function sphere01_volume_nd(dim_num) - -!*****************************************************************************80 -! -!! SPHERE01_VOLUME_ND computes the volume of a unit sphere in ND. -! -! Discussion: -! -! The unit sphere in ND satisfies: -! -! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 -! -! Results for the first few values of DIM_NUM are: -! -! DIM_NUM Volume -! -! 1 2 -! 2 1 * PI -! 3 ( 4 / 3) * PI -! 4 ( 1 / 2) * PI^2 -! 5 ( 8 / 15) * PI^2 -! 6 ( 1 / 6) * PI^3 -! 7 (16 / 105) * PI^3 -! 8 ( 1 / 24) * PI^4 -! 9 (32 / 945) * PI^4 -! 10 ( 1 / 120) * PI^5 -! -! For the unit sphere, Volume(DIM_NUM) = 2 * PI * Volume(DIM_NUM-2)/ DIM_NUM -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Output, real ( kind = 8 ) SPHERE_UNIT_VOLUME_ND, the volume of the sphere. -! - implicit none - - integer(kind=4) dim_num - integer(kind=4) i - integer(kind=4) m - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) sphere01_volume_nd - real(kind=8) volume - - if (mod(dim_num, 2) == 0) then - m = dim_num / 2 - volume = r8_pi**m - do i = 1, m - volume = volume / real(i, kind=8) - end do - else - m = (dim_num - 1) / 2 - volume = r8_pi**m * 2.0D+00**dim_num - do i = m + 1, 2 * m + 1 - volume = volume / real(i, kind=8) - end do - end if - - sphere01_volume_nd = volume - - return -end -subroutine sphere01_volume_values(n_data, n, volume) - -!*****************************************************************************80 -! -!! SPHERE01_VOLUME_VALUES returns some volumes of the unit sphere in ND. -! -! Discussion: -! -! The formula for the volume of the unit sphere in N dimensions is -! -! Volume(N) = 2 * pi^(N/2) / ( N * Gamma ( N / 2 ) ) -! -! This function satisfies the relationships: -! -! Volume(N) = 2 * pi * Volume(N-2) / N -! Volume(N) = Area(N) / N -! -! Some values of the function include: -! -! N Volume -! -! 1 1 -! 2 1 * PI -! 3 ( 4 / 3) * PI -! 4 ( 1 / 2) * PI^2 -! 5 ( 8 / 15) * PI^2 -! 6 ( 1 / 6) * PI^3 -! 7 (16 / 105) * PI^3 -! 8 ( 1 / 24) * PI^4 -! 9 (32 / 945) * PI^4 -! 10 ( 1 / 120) * PI^5 -! -! In Mathematica, the function can be evaluated by: -! -! 2 * Pi^(n/2) / ( n * Gamma[n/2] ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 21 August 2004 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Stephen Wolfram, -! The Mathematica Book, -! Fourth Edition, -! Cambridge University Press, 1999, -! ISBN: 0-521-64314-7, -! LC: QA76.95.W65. -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 -! before the first call. On each call, the routine increments N_DATA by 1, -! and returns the corresponding data; when there is no more data, the -! output value of N_DATA will be 0 again. -! -! Output, integer ( kind = 4 ) N, the spatial dimension. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the unit -! sphere in that dimension. -! - implicit none - - integer(kind=4), parameter :: n_max = 20 - - integer(kind=4) n_data - integer(kind=4) n - integer(kind=4), save, dimension(n_max) :: n_vec = (/ & - 1, 2, & - 3, 4, & - 5, 6, & - 7, 8, & - 9, 10, & - 11, 12, & - 13, 14, & - 15, 16, & - 17, 18, & - 19, 20/) - real(kind=8) volume - real(kind=8), save, dimension(n_max) :: volume_vec = (/ & - 0.2000000000000000D+01, & - 0.3141592653589793D+01, & - 0.4188790204786391D+01, & - 0.4934802200544679D+01, & - 0.5263789013914325D+01, & - 0.5167712780049970D+01, & - 0.4724765970331401D+01, & - 0.4058712126416768D+01, & - 0.3298508902738707D+01, & - 0.2550164039877345D+01, & - 0.1884103879389900D+01, & - 0.1335262768854589D+01, & - 0.9106287547832831D+00, & - 0.5992645293207921D+00, & - 0.3814432808233045D+00, & - 0.2353306303588932D+00, & - 0.1409811069171390D+00, & - 0.8214588661112823D-01, & - 0.4662160103008855D-01, & - 0.2580689139001406D-01/) - - if (n_data < 0) then - n_data = 0 - end if - - n_data = n_data + 1 - - if (n_max < n_data) then - n_data = 0 - n = 0 - volume = 0.0D+00 - else - n = n_vec(n_data) - volume = volume_vec(n_data) - end if - - return -end -subroutine sphere01_distance_xyz(xyz1, xyz2, dist) - -!*****************************************************************************80 -! -!! SPHERE01_DISTANCE_XYZ computes great circle distances on a unit sphere. -! -! Discussion: -! -! XYZ coordinates are used. -! -! We assume the points XYZ1 and XYZ2 lie on the unit sphere. -! -! This computation is a special form of the Vincenty formula. -! It should be less sensitive to errors associated with very small -! or very large angular separations. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 August 2010 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! "Great-circle distance", -! Wikipedia. -! -! Parameters: -! -! Input, real ( kind = 8 ) XYZ1(3), the coordinates of the first point. -! -! Input, real ( kind = 8 ) XYZ2(3), the coordinates of the second point. -! -! Output, real ( kind = 8 ) DIST, the great circle distance between -! the points. -! - implicit none - - real(kind=8) bot - real(kind=8) dist - real(kind=8) lat1 - real(kind=8) lat2 - real(kind=8) lon1 - real(kind=8) lon2 - real(kind=8) r8_asin - real(kind=8) r8_atan - real(kind=8) top - real(kind=8) xyz1(3) - real(kind=8) xyz2(3) - - lat1 = r8_asin(xyz1(3)) - lon1 = r8_atan(xyz1(2), xyz1(1)) - - lat2 = r8_asin(xyz2(3)) - lon2 = r8_atan(xyz2(2), xyz2(1)) - - top = (cos(lat2) * sin(lon1 - lon2))**2 & - + (cos(lat1) * sin(lat2) & - - sin(lat1) * cos(lat2) * cos(lon1 - lon2))**2 - - top = sqrt(top) - - bot = sin(lat1) * sin(lat2) & - + cos(lat1) * cos(lat2) * cos(lon1 - lon2) - - dist = atan2(top, bot) - - return -end -function sphere01_polygon_area(n, lat, lon) - -!*****************************************************************************80 -! -!! SPHERE01_POLYGON_AREA returns the area of a spherical polygon. -! -! Discussion: -! -! On a unit sphere, the area of a spherical polygon with N sides -! is equal to the spherical excess: -! -! E = sum ( interior angles ) - ( N - 2 ) * pi. -! -! On a sphere with radius R, the area is the spherical excess multiplied -! by R * R. -! -! The code was revised in accordance with suggestions in Carvalho and -! Cavalcanti. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 August 2005 -! -! Author: -! -! Original C version by Robert Miller. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, -! Point in Polyhedron Testing Using Spherical Polygons, -! in Graphics Gems V, -! edited by Alan Paeth, -! Academic Press, 1995, -! ISBN: 0125434553, -! LC: T385.G6975. -! -! Robert Miller, -! Computing the Area of a Spherical Polygon, -! Graphics Gems, Volume IV, pages 132-138, -! Edited by Paul Heckbert, -! Academic Press, 1994, T385.G6974. -! -! Eric Weisstein, -! "Spherical Polygon", -! CRC Concise Encyclopedia of Mathematics, -! CRC Press, 1999. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of vertices. -! -! Input, real ( kind = 8 ) LAT[N], LON[N], the latitudes and longitudes -! of the vertices of the spherical polygon. -! -! Output, real ( kind = 8 ) SPHERE01_POLYGON_AREA, the area of the -! spherical polygon, measured in spherical radians. -! - implicit none - - integer(kind=4) n - - real(kind=8) a - real(kind=8) area - real(kind=8) b - real(kind=8) beta1 - real(kind=8) beta2 - real(kind=8) c - real(kind=8) cos_b1 - real(kind=8) cos_b2 - real(kind=8) excess - real(kind=8) hav_a - real(kind=8) haversine - integer(kind=4) j - integer(kind=4) k - real(kind=8) lam - real(kind=8) lam1 - real(kind=8) lam2 - real(kind=8) lat(n) - real(kind=8) lon(n) - real(kind=8), parameter :: r8_pi_half = 1.5707963267948966192313D+00 - real(kind=8) s - real(kind=8) sphere01_polygon_area - real(kind=8) t - - area = 0.0D+00 - - do j = 1, n + 1 - - if (j == 1) then - lam1 = lon(j) - beta1 = lat(j) - lam2 = lon(j + 1) - beta2 = lat(j + 1) - cos_b1 = cos(beta1) - cos_b2 = cos(beta2) - else - k = mod(j + 1, n + 1) - lam1 = lam2 - beta1 = beta2 - lam2 = lon(k) - beta2 = lat(k) - cos_b1 = cos_b2 - cos_b2 = cos(beta2) - end if - - if (lam1 /= lam2) then - - hav_a = haversine(beta2 - beta1) & - + cos_b1 * cos_b2 * haversine(lam2 - lam1) - a = 2.0D+00 * asin(sqrt(hav_a)) - - b = r8_pi_half - beta2 - c = r8_pi_half - beta1 - s = 0.5D+00 * (a + b + c) -! -! Given the three sides of a spherical triangle, we can use a formula -! to find the spherical excess. -! - t = tan(s / 2.0D+00) * tan((s - a) / 2.0D+00) & - * tan((s - b) / 2.0D+00) * tan((s - c) / 2.0D+00) - - excess = abs(4.0D+00 * atan(sqrt(abs(t)))) - - if (lam1 < lam2) then - lam = lam2 - lam1 - else - lam = lam2 - lam1 + 4.0D+00 * r8_pi_half - end if - - if (2.0D+00 * r8_pi_half < lam) then - excess = -excess - end if - - area = area + excess - - end if - - end do - - sphere01_polygon_area = abs(area) - - return -end -subroutine sphere01_triangle_angles_to_area(a, b, c, area) - -!*****************************************************************************80 -! -!! SPHERE01_TRIANGLE_ANGLES_TO_AREA computes the area of a spherical triangle. -! -! Discussion: -! -! A unit sphere in 3D satisfies the equation: -! -! X^2 + Y^2 + Z^2 = 1 -! -! A spherical triangle is specified by three points on the surface -! of the sphere. -! -! The area formula is known as Girard's formula. -! -! The area of a spherical triangle on a unit sphere is: -! -! AREA = ( A + B + C - PI ) -! -! where A, B and C are the (surface) angles of the triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, the angles of the triangle. -! -! Output, real ( kind = 8 ) AREA, the area of the sphere. -! - implicit none - - real(kind=8) area - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 -! -! Apply Girard's formula. -! - area = a + b + c - r8_pi - - return -end -subroutine sphere01_triangle_sides_to_angles(as, bs, cs, a, b, c) - -!*****************************************************************************80 -! -!! SPHERE01_TRIANGLE_SIDES_TO_ANGLES computes spherical triangle angles. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the -! sides of the triangle. -! -! Output, real ( kind = 8 ) A, B, C, the spherical angles of the triangle. -! Angle A is opposite the side of length AS, and so on. -! - implicit none - - real(kind=8) a - real(kind=8) as - real(kind=8) asu - real(kind=8) b - real(kind=8) bs - real(kind=8) bsu - real(kind=8) c - real(kind=8) cs - real(kind=8) csu - real(kind=8) ssu - real(kind=8) tan_a2 - real(kind=8) tan_b2 - real(kind=8) tan_c2 - - asu = as - bsu = bs - csu = cs - ssu = (asu + bsu + csu) / 2.0D+00 - - tan_a2 = sqrt((sin(ssu - bsu) * sin(ssu - csu)) / & - (sin(ssu) * sin(ssu - asu))) - - a = 2.0D+00 * atan(tan_a2) - - tan_b2 = sqrt((sin(ssu - asu) * sin(ssu - csu)) / & - (sin(ssu) * sin(ssu - bsu))) - - b = 2.0D+00 * atan(tan_b2) - - tan_c2 = sqrt((sin(ssu - asu) * sin(ssu - bsu)) / & - (sin(ssu) * sin(ssu - csu))) - - c = 2.0D+00 * atan(tan_c2) - - return -end -subroutine sphere01_triangle_vertices_to_angles(v1, v2, v3, a, b, c) - -!*****************************************************************************80 -! -!! SPHERE01_TRIANGLE_VERTICES_TO_ANGLES: spherical triangle angles by vertices. -! -! Discussion: -! -! A unit sphere centered at 0 in 3D satisfies the equation: -! -! X * X + Y * Y + Z * Z = 1 -! -! A spherical triangle is specified by three points on the surface -! of the sphere. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 September 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. -! -! Output, real ( kind = 8 ) A, B, C, the angles of the spherical triangle. -! - implicit none - - real(kind=8) a - real(kind=8) as - real(kind=8) b - real(kind=8) bs - real(kind=8) c - real(kind=8) cs - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) -! -! Compute the lengths of the sides of the spherical triangle. -! - call sphere01_triangle_vertices_to_sides(v1, v2, v3, as, bs, cs) -! -! Get the spherical angles. -! - call sphere01_triangle_sides_to_angles(as, bs, cs, a, b, c) - - return -end -subroutine sphere01_triangle_vertices_to_area(v1, v2, v3, area) - -!*****************************************************************************80 -! -!! SPHERE01_TRIANGLE_VERTICES_TO_AREA computes the area of a spherical triangle. -! -! Discussion: -! -! A unit sphere in 3D satisfies the equation: -! -! X^2 + Y^2 + Z^2 = 1 -! -! A spherical triangle is specified by three points on the surface -! of the sphere. -! -! The area formula is known as Girard's formula. -! -! The area of a spherical triangle on a unit sphere is: -! -! AREA = ( A + B + C - PI ) -! -! where A, B and C are the (surface) angles of the triangle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. -! -! Output, real ( kind = 8 ) AREA, the area of the sphere. -! - implicit none - - real(kind=8) area - real(kind=8) a - real(kind=8) as - real(kind=8) b - real(kind=8) bs - real(kind=8) c - real(kind=8) cs - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) -! -! Compute the lengths of the sides of the spherical triangle. -! - call sphere01_triangle_vertices_to_sides(v1, v2, v3, as, bs, cs) -! -! Get the spherical angles. -! - call sphere01_triangle_sides_to_angles(as, bs, cs, a, b, c) -! -! Get the area. -! - call sphere01_triangle_angles_to_area(a, b, c, area) - - return -end -subroutine sphere01_triangle_vertices_to_centroid(v1, v2, v3, vs) - -!*****************************************************************************80 -! -!! SPHERE01_TRIANGLE_VERTICES_TO_CENTROID gets a spherical triangle "centroid". -! -! Discussion: -! -! A unit sphere in 3D satisfies the equation: -! -! X^2 + Y^2 + Z^2 = 1 -! -! A spherical triangle is specified by three points on the sphere. -! -! The (true) centroid of a spherical triangle is the point -! -! VT = (XT,YT,ZT) = Integral ( X, Y, Z ) dArea / Integral 1 dArea -! -! Note that the true centroid does NOT, in general, lie on the sphere. -! -! The "flat" centroid VF is the centroid of the planar triangle defined by -! the vertices of the spherical triangle. -! -! The "spherical" centroid VS of a spherical triangle is computed by -! the intersection of the geodesic bisectors of the triangle angles. -! The spherical centroid lies on the sphere. -! -! VF, VT and VS lie on a line through the center of the sphere. We can -! easily calculate VF by averaging the vertices, and from this determine -! VS by normalizing. -! -! (Of course, we still will not have actually computed VT, which lies -! somewhere between VF and VS!) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. -! -! Output, real ( kind = 8 ) VS(3), the coordinates of the "spherical -! centroid" of the spherical triangle. -! - implicit none - - real(kind=8) norm - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - real(kind=8) vs(3) - - vs(1:3) = (v1(1:3) + v2(1:3) + v3(1:3)) / 3.0D+00 - - norm = sqrt(sum(vs(1:3)**2)) - - vs(1:3) = vs(1:3) / norm - - return -end -subroutine sphere01_triangle_vertices_to_midpoints(v1, v2, v3, m1, m2, m3) - -!*****************************************************************************80 -! -!! SPHERE01_TRIANGLE_VERTICES_TO_MIDPOINTS: midsides of a spherical triangle. -! -! Discussion: -! -! The points are assumed to lie on the unit sphere. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. -! -! Output, real ( kind = 8 ) M1(3), M2(3), M3(3), the coordinates of -! the midpoints of the sides of the spherical triangle. -! - implicit none - - real(kind=8) m1(3) - real(kind=8) m2(3) - real(kind=8) m3(3) - real(kind=8) norm - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - - m1(1:3) = (v1(1:3) + v2(1:3)) / 2.0D+00 - norm = sqrt(sum(m1(1:3)**2)) - m1(1:3) = m1(1:3) / norm - - m2(1:3) = (v2(1:3) + v3(1:3)) / 2.0D+00 - norm = sqrt(sum(m2(1:3)**2)) - m2(1:3) = m2(1:3) / norm - - m3(1:3) = (v3(1:3) + v1(1:3)) / 2.0D+00 - norm = sqrt(sum(m3(1:3)**2)) - m3(1:3) = m3(1:3) / norm - - return -end -subroutine sphere01_triangle_vertices_to_sides(v1, v2, v3, as, bs, cs) - -!*****************************************************************************80 -! -!! SPHERE01_TRIANGLE_VERTICES_TO_SIDES computes spherical triangle sides. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 June 2002 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the spherical -! triangle. -! -! Output, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the -! sides of the triangle. -! - implicit none - - real(kind=8) as - real(kind=8) bs - real(kind=8) cs - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) v3(3) - - as = acos(dot_product(v2(1:3), v3(1:3))) - bs = acos(dot_product(v3(1:3), v1(1:3))) - cs = acos(dot_product(v1(1:3), v2(1:3))) - - return -end -subroutine string_2d(nvec, p1, p2, string_num, order, string) - -!*****************************************************************************80 -! -!! STRING_2D groups line segments into connected lines in 2D. -! -! Discussion: -! -! The routine receives an unordered set of line segments, described by -! pairs of coordinates P1 and P2, and tries to group them -! into ordered lists that constitute connected jagged lines. -! -! This routine will not match two endpoints unless they are exactly equal. -! -! On input, line segment I has endpoints P1(I), P2(I). -! -! On output, the order of the components may have been switched. -! That is, for some I, P1(I) and P2(I) may have been swapped. -! -! More importantly, both points P1(I) and P2(I) may have been swapped -! with another pair P1(J), P2(J). -! -! The resulting coordinates will have been sorted in order -! of the string to which they belong, and then by the order -! of their traversal within that string. -! -! The array STRING(I) identifies the string to which segment I belongs. -! -! If two segments I and J have the same value of STRING, then -! ORDER(I) and ORDER(J) give the relative order of the two segments -! in the string. Thus if ORDER(I) = -3 and ORDER(J) = 2, then when -! the string is traversed, segment I is traversed first, then four other -! segments are traversed, and then segment J is traversed. -! -! For each string, the segment with ORDER(I) = 0 is the initial segment -! from which the entire string was "grown" (with growth possible to both the -! left and the right). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 23 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) NVEC, the number of line segments to be -! analyzed. -! -! Input/output, real ( kind = 8 ) P1(2,NVEC), P2VEC(2,NVEC), the -! line segments. -! -! Output, integer ( kind = 4 ) ORDER(NVEC), the order vector. -! -! Output, integer ( kind = 4 ) STRING(NVEC), the string to which each -! segment belongs. -! -! Output, integer ( kind = 4 ) STRING_NUM, the number of strings created. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - integer(kind=4) nvec - - integer(kind=4) i - integer(kind=4) indx - integer(kind=4) isgn - integer(kind=4) j - integer(kind=4) jval - integer(kind=4) kval - integer(kind=4) match - integer(kind=4) order(nvec) - real(kind=8) p1(dim_num, nvec) - real(kind=8) p2(dim_num, nvec) - integer(kind=4) seed - integer(kind=4) string(nvec) - integer(kind=4) string_num - real(kind=8) x1val - real(kind=8) x2val - real(kind=8) y1val - real(kind=8) y2val -! -! Mark STRING so that each segment is alone. -! - order(1:nvec) = 0 - string(1:nvec) = nvec + i -! -! Starting with the lowest numbered group of line segments, -! see if any higher numbered groups belong. -! - seed = 1 - string_num = 1 - string(seed) = string_num - - do - - x1val = p1(1, seed) - y1val = p1(2, seed) - - x2val = p2(1, seed) - y2val = p2(2, seed) - - jval = order(seed) - kval = order(seed) - - do - - match = 0 - - do j = 1, nvec - - if (string_num < string(j)) then - - if (x1val == p1(1, j) .and. y1val == p1(2, j)) then - - jval = jval - 1 - order(j) = jval - string(j) = string_num - x1val = p2(1, j) - y1val = p2(2, j) - match = match + 1 - - call r8_swap(p1(1, j), p2(1, j)) - call r8_swap(p1(2, j), p2(2, j)) - - else if (x1val == p2(1, j) .and. y1val == p2(2, j)) then - - jval = jval - 1 - order(j) = jval - string(j) = string_num - x1val = p1(1, j) - y1val = p1(2, j) - match = match + 1 - - else if (x2val == p1(1, j) .and. y2val == p1(2, j)) then - - kval = kval + 1 - order(j) = kval - string(j) = string_num - x2val = p2(1, j) - y2val = p2(2, j) - match = match + 1 - - else if (x2val == p2(1, j) .and. y2val == p2(2, j)) then - - kval = kval + 1 - order(j) = kval - string(j) = string_num - x2val = p1(1, j) - y2val = p1(2, j) - match = match + 1 - - call r8_swap(p1(1, j), p2(1, j)) - call r8_swap(p1(2, j), p2(2, j)) - - end if - - end if - - end do -! -! If the string has closed on itself, then we don't want to -! look for any more matches for this string. -! - if (x1val == x2val .and. y1val == y2val) then - exit - end if -! -! If we made no matches this pass, we're done. -! - if (match <= 0) then - exit - end if - - end do -! -! This string is "exhausted". Are there any line segments we -! haven't looked at yet? -! - seed = 0 - - do i = 1, nvec - if (string_num < string(i)) then - seed = i - string_num = string_num + 1 - string(i) = string_num - exit - end if - end do - - if (seed == 0) then - exit - end if - - end do -! -! There are no more line segments to look at. Renumber the -! isolated segments. -! -! Question: Can this ever happen? -! - do i = 1, nvec - if (nvec < string(i)) then - string_num = string_num + 1 - string(i) = string_num - end if - end do -! -! Now sort the line segments by string and by order of traversal. -! - i = 0 - isgn = 0 - j = 0 - - indx = 0 - - do - - call sort_heap_external(nvec, indx, i, j, isgn) - - if (0 < indx) then - - call i4_swap(order(i), order(j)) - call i4_swap(string(i), string(j)) - call r8_swap(p1(1, i), p1(1, j)) - call r8_swap(p1(2, i), p1(2, j)) - call r8_swap(p2(1, i), p2(1, j)) - call r8_swap(p2(2, i), p2(2, j)) - - else if (indx < 0) then - - if ((string(i) < string(j)) .or. & - (string(i) == string(j) .and. order(i) < order(j))) then - - isgn = -1 - - else - - isgn = +1 - - end if - - else if (indx == 0) then - - exit - - end if - - end do - - return -end -subroutine super_ellipse_points_2d(pc, r1, r2, expo, psi, n, p) - -!*****************************************************************************80 -! -!! SUPER_ELLIPSE_POINTS_2D returns N points on a tilted superellipse in 2D. -! -! Discussion: -! -! The points are "equally spaced" in the angular sense. They are -! not equally spaced along the perimeter. -! -! The parametric formula of the (untilted) superellipse is: -! -! X = R1 * cos^EXPO ( THETA ) -! Y = R2 * sin^EXPO ( THETA ) -! -! An implicit form of the (untilted) superellipse is: -! -! (X/R1)^(2/EXPO) + (Y/R2)^(2/EXPO) = 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 January 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Martin Gardner, -! The Mathematical Carnival, -! Knopf, 1975, pages 240-254. -! -! Parameters: -! -! Input, real ( kind = 8 ) PC(2), the center of the superellipse. -! -! Input, real ( kind = 8 ) R1, R2, the "radius" of the superellipse -! in the major and minor axis directions. A circle has these values equal. -! -! Input, real ( kind = 8 ) EXPO, the exponent of the superellipse. -! 0 = a rectangle; -! between 0 and 1, a "rounded" rectangle; -! 1.0 = an ellipse; -! 2.0 = a diamond; -! > 2.0 a pinched shape. -! -! Input, real ( kind = 8 ) PSI, the angle that the major axis of the -! superellipse makes with the X axis. A value of 0.0 means that the -! major and minor axes of the superellipse will be the X and Y -! coordinate axes. -! -! Input, integer ( kind = 4 ) N, the number of points desired. N must -! be at least 1. -! -! Output, real ( kind = 8 ) P(2,N), the coordinates of points -! on the superellipse. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) act - real(kind=8) ast - integer(kind=4) i - real(kind=8) expo - real(kind=8) p(dim_num, n) - real(kind=8) pc(dim_num) - real(kind=8) psi - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) sct - real(kind=8) sst - real(kind=8) theta - - do i = 1, n - - theta = (2.0D+00 * r8_pi * real(i - 1, kind=8)) & - / real(n, kind=8) - - act = abs(cos(theta)) - sct = sign(1.0D+00, cos(theta)) - ast = abs(sin(theta)) - sst = sign(1.0D+00, sin(theta)) - - p(1, i) = pc(1) + r1 * cos(psi) * sct * (act)**expo & - - r2 * sin(psi) * sst * (ast)**expo - - p(2, i) = pc(2) + r1 * sin(psi) * sct * (act)**expo & - + r2 * cos(psi) * sst * (ast)**expo - - end do - - return -end -subroutine tetrahedron_barycentric_3d(tetra, p, c) - -!*****************************************************************************80 -! -!! TETRAHEDRON_BARYCENTRIC_3D: barycentric coordinates of a point in 3D. -! -! Discussion: -! -! The barycentric coordinates of a point P with respect to -! a tetrahedron are a set of four values C(1:4), each associated -! with a vertex of the tetrahedron. The values must sum to 1. -! If all the values are between 0 and 1, the point is contained -! within the tetrahedron. -! -! The barycentric coordinate of point P related to vertex A can be -! interpreted as the ratio of the volume of the tetrahedron with -! vertex A replaced by vertex P to the volume of the original -! tetrahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. -! -! Input, real ( kind = 8 ) P(3), the point to be checked. -! -! Output, real ( kind = 8 ) C(4), the barycentric coordinates of P with -! respect to the tetrahedron. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4), parameter :: rhs_num = 1 - - real(kind=8) a(dim_num, dim_num + rhs_num) - real(kind=8) c(dim_num + 1) - integer(kind=4) i - integer(kind=4) info - real(kind=8) p(dim_num) - real(kind=8) tetra(dim_num, 4) -! -! Set up the linear system -! -! ( X2-X1 X3-X1 X4-X1 ) C2 X - X1 -! ( Y2-Y1 Y3-Y1 Y4-Y1 ) C3 = Y - Y1 -! ( Z2-Z1 Z3-Z1 Z4-Z1 ) C4 Z - Z1 -! -! which is satisfied by the barycentric coordinates of P. -! - a(1:dim_num, 1:3) = tetra(1:dim_num, 2:4) - a(1:dim_num, 4) = p(1:dim_num) - - do i = 1, dim_num - a(i, 1:4) = a(i, 1:4) - tetra(i, 1) - end do -! -! Solve the linear system. -! - call r8mat_solve(dim_num, rhs_num, a, info) - - if (info /= 0) then - write (*, '(a)') ' ' - write (*, '(a)') 'TETRAHEDRON_BARYCENTRIC_3D - Fatal error!' - write (*, '(a)') ' The linear system is singular.' - write (*, '(a)') ' The input data does not form a proper tetrahedron.' - stop 1 - end if - - c(2:4) = a(1:dim_num, 4) - - c(1) = 1.0D+00 - sum(c(2:4)) - - return -end -subroutine tetrahedron_centroid_3d(tetra, centroid) - -!*****************************************************************************80 -! -!! TETRAHEDRON_CENTROID_3D computes the centroid of a tetrahedron in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. -! -! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) centroid(dim_num) - integer(kind=4) i - real(kind=8) tetra(dim_num, 4) - - do i = 1, dim_num - centroid(i) = sum(tetra(i, 1:4)) / 4.0D+00 - end do - - return -end -subroutine tetrahedron_circumsphere_3d(tetra, r, pc) - -!*****************************************************************************80 -! -!! TETRAHEDRON_CIRCUMSPHERE_3D computes the circumsphere of a tetrahedron in 3D. -! -! Discussion: -! -! The circumsphere, or circumscribed sphere, of a tetrahedron is the -! sphere that passes through the four vertices. The circumsphere is -! not necessarily the smallest sphere that contains the tetrahedron. -! -! Surprisingly, the diameter of the sphere can be found by solving -! a 3 by 3 linear system. This is because the vectors P2 - P1, -! P3 - P1 and P4 - P1 are secants of the sphere, and each forms a -! right triangle with the diameter through P1. Hence, the dot product of -! P2 - P1 with that diameter is equal to the square of the length -! of P2 - P1, and similarly for P3 - P1 and P4 - P1. This determines -! the diameter vector originating at P1, and hence the radius and -! center. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 August 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Adrian Bowyer, John Woodwark, -! A Programmer's Geometry, -! Butterworths, 1983, -! ISBN: 0408012420. -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. -! -! Output, real ( kind = 8 ) R, PC(3), the center of the -! circumscribed sphere, and its radius. If the linear system is -! singular, then R = -1, PC(1:3) = 0. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4), parameter :: rhs_num = 1 - - real(kind=8) a(dim_num, dim_num + rhs_num) - integer(kind=4) i - integer(kind=4) info - integer(kind=4) j - real(kind=8) pc(dim_num) - real(kind=8) r - real(kind=8) tetra(dim_num, 4) -! -! Set up the linear system. -! - a(1:dim_num, 1:3) = transpose(tetra(1:dim_num, 2:4)) - - do j = 1, dim_num - a(1:dim_num, j) = a(1:dim_num, j) - tetra(j, 1) - end do - - do i = 1, 3 - a(i, 4) = sum(a(i, 1:3)**2) - end do -! -! Solve the linear system. -! - call r8mat_solve(dim_num, rhs_num, a, info) -! -! If the system was singular, return a consolation prize. -! - if (info /= 0) then - r = -1.0D+00 - pc(1:dim_num) = 0.0D+00 - return - end if -! -! Compute the radius and center. -! - r = 0.5D+00 * sqrt(sum(a(1:dim_num, 4)**2)) - - pc(1:dim_num) = tetra(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, 4) - - return -end -subroutine tetrahedron_contains_point_3d(tetra, p, inside) - -!*****************************************************************************80 -! -!! TETRAHEDRON_CONTAINS_POINT_3D finds if a point is inside a tetrahedron in 3D. -! -! Discussion: -! -! We compute the barycentric coordinates C(1:4) of the point, with respect -! to the tetrahedron. The point is inside the tetrahedron if and only -! if each coordinate is nonnegative, and their sum is no greater than 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. -! -! Input, real ( kind = 8 ) P(3), the point to be checked. -! -! Output, logical ( kind = 4 ) INSIDE, is TRUE if P is inside the -! tetrahedron. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) c(dim_num + 1) - logical(kind=4) inside - real(kind=8) p(dim_num) - real(kind=8) tetra(dim_num, 4) - - call tetrahedron_barycentric_3d(tetra, p, c) -! -! If the point is in the tetrahedron, its barycentric coordinates -! must be nonnegative. -! - if (any(c(1:dim_num + 1) < 0.0D+00)) then - inside = .false. - else - inside = .true. - end if - - return -end -subroutine tetrahedron_dihedral_angles_3d(tetra, angle) - -!*****************************************************************************80 -! -!! TETRAHEDRON_DIHEDRAL_ANGLES_3D computes dihedral angles of a tetrahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron, -! which can be labeled as A, B, C and D. -! -! Output, real ( kind = 8 ) ANGLE(6), the dihedral angles along the -! axes AB, AC, AD, BC, BD and CD, respectively. -! - implicit none - - real(kind=8) ab(3) - real(kind=8) abc_normal(3) - real(kind=8) abd_normal(3) - real(kind=8) ac(3) - real(kind=8) acd_normal(3) - real(kind=8) ad(3) - real(kind=8) angle(6) - real(kind=8) bc(3) - real(kind=8) bcd_normal(3) - real(kind=8) bd(3) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) tetra(3, 4) - - ab(1:3) = tetra(1:3, 2) - tetra(1:3, 1) - ac(1:3) = tetra(1:3, 3) - tetra(1:3, 1) - ad(1:3) = tetra(1:3, 4) - tetra(1:3, 1) - bc(1:3) = tetra(1:3, 3) - tetra(1:3, 2) - bd(1:3) = tetra(1:3, 4) - tetra(1:3, 2) - - call r8vec_cross_product_3d(ac, ab, abc_normal) - call r8vec_cross_product_3d(ab, ad, abd_normal) - call r8vec_cross_product_3d(ad, ac, acd_normal) - call r8vec_cross_product_3d(bc, bd, bcd_normal) - - call r8vec_angle_3d(abc_normal, abd_normal, angle(1)) - call r8vec_angle_3d(abc_normal, acd_normal, angle(2)) - call r8vec_angle_3d(abd_normal, acd_normal, angle(3)) - call r8vec_angle_3d(abc_normal, bcd_normal, angle(4)) - call r8vec_angle_3d(abd_normal, bcd_normal, angle(5)) - call r8vec_angle_3d(acd_normal, bcd_normal, angle(6)) - - angle(1:6) = r8_pi - angle(1:6) - - return -end -subroutine tetrahedron_edge_length_3d(tetra, edge_length) - -!*****************************************************************************80 -! -!! TETRAHEDRON_EDGE_LENGTH_3D returns edge lengths of a tetrahedron in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. -! -! Output, real ( kind = 8 ) EDGE_LENGTH(6), the length of the edges. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) r8vec_norm - real(kind=8) edge_length(6) - integer(kind=4) j1 - integer(kind=4) j2 - integer(kind=4) k - real(kind=8) tetra(dim_num, 4) - - k = 0 - do j1 = 1, 3 - do j2 = j1 + 1, 4 - k = k + 1 - edge_length(k) = r8vec_norm(dim_num, & - tetra(1:dim_num, j2) - tetra(1:dim_num, j1)) - end do - end do - - return -end -subroutine tetrahedron_face_angles_3d(tetra, angles) - -!*****************************************************************************80 -! -!! TETRAHEDRON_FACE_ANGLES_3D returns the 12 face angles of a tetrahedron 3D. -! -! Discussion: -! -! The tetrahedron has 4 triangular faces. This routine computes the -! 3 planar angles associated with each face. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. -! -! Output, real ( kind = 8 ) ANGLES(3,4), the face angles. -! - implicit none - - real(kind=8) angles(3, 4) - real(kind=8) tri(3, 3) - real(kind=8) tetra(3, 4) -! -! Face 123 -! - tri(1:3, 1:3) = tetra(1:3, 1:3) - call triangle_angles_3d(tri, angles(1:3, 1)) -! -! Face 124 -! - tri(1:3, 1:2) = tetra(1:3, 1:2) - tri(1:3, 3) = tetra(1:3, 4) - call triangle_angles_3d(tri, angles(1:3, 2)) -! -! Face 134 -! - tri(1:3, 1) = tetra(1:3, 1) - tri(1:3, 2:3) = tetra(1:3, 3:4) - call triangle_angles_3d(tri, angles(1:3, 3)) -! -! Face 234 -! - tri(1:3, 1:3) = tetra(1:3, 2:4) - call triangle_angles_3d(tri, angles(1:3, 4)) - - return -end -subroutine tetrahedron_face_areas_3d(tetra, areas) - -!*****************************************************************************80 -! -!! TETRAHEDRON_FACE_AREAS_3D returns the 4 face areas of a tetrahedron 3D. -! -! Discussion: -! -! The tetrahedron has 4 triangular faces. This routine computes the -! area of each face. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. -! -! Output, real ( kind = 8 ) AREAS(4), the face areas. -! - implicit none - - real(kind=8) areas(4) - real(kind=8) tri(3, 3) - real(kind=8) tetra(3, 4) -! -! Face 123 -! - tri(1:3, 1:3) = tetra(1:3, 1:3) - call triangle_area_3d(tri, areas(1)) -! -! Face 124 -! - tri(1:3, 1:2) = tetra(1:3, 1:2) - tri(1:3, 3) = tetra(1:3, 4) - call triangle_area_3d(tri, areas(2)) -! -! Face 134 -! - tri(1:3, 1) = tetra(1:3, 1) - tri(1:3, 2:3) = tetra(1:3, 3:4) - call triangle_area_3d(tri, areas(3)) -! -! Face 234 -! - tri(1:3, 1:3) = tetra(1:3, 2:4) - call triangle_area_3d(tri, areas(4)) - - return -end -subroutine tetrahedron_insphere_3d(tetra, r, pc) - -!*****************************************************************************80 -! -!! TETRAHEDRON_INSPHERE_3D finds the insphere of a tetrahedron in 3D. -! -! Discussion: -! -! The insphere of a tetrahedron is the inscribed sphere, which touches -! each face of the tetrahedron at a single point. -! -! The points of contact are the centroids of the triangular faces -! of the tetrahedron. Therefore, the point of contact for a face -! can be computed as the average of the vertices of that face. -! -! The sphere can then be determined as the unique sphere through -! the four given centroids. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 August 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Philip Schneider, David Eberly, -! Geometric Tools for Computer Graphics, -! Elsevier, 2002, -! ISBN: 1558605940, -! LC: T385.G6974. -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. -! -! Output, real ( kind = 8 ) R, PC(3), the radius and the center -! of the sphere. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) b(4, 4) - real(kind=8) r8mat_det_4d - real(kind=8) r8vec_norm - real(kind=8) gamma - real(kind=8) l123 - real(kind=8) l124 - real(kind=8) l134 - real(kind=8) l234 - real(kind=8) n123(1:dim_num) - real(kind=8) n124(1:dim_num) - real(kind=8) n134(1:dim_num) - real(kind=8) n234(1:dim_num) - real(kind=8) pc(1:dim_num) - real(kind=8) r - real(kind=8) tetra(1:dim_num, 4) - real(kind=8) v21(1:dim_num) - real(kind=8) v31(1:dim_num) - real(kind=8) v41(1:dim_num) - real(kind=8) v32(1:dim_num) - real(kind=8) v42(1:dim_num) - real(kind=8) v43(1:dim_num) - - v21(1:dim_num) = tetra(1:dim_num, 2) - tetra(1:dim_num, 1) - v31(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 1) - v41(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 1) - v32(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 2) - v42(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 2) - v43(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 3) - - call r8vec_cross_product_3d(v21, v31, n123) - call r8vec_cross_product_3d(v41, v21, n124) - call r8vec_cross_product_3d(v31, v41, n134) - call r8vec_cross_product_3d(v42, v32, n234) - - l123 = r8vec_norm(dim_num, n123) - l124 = r8vec_norm(dim_num, n124) - l134 = r8vec_norm(dim_num, n134) - l234 = r8vec_norm(dim_num, n234) - - pc(1:dim_num) = (l234 * tetra(1:dim_num, 1) & - + l134 * tetra(1:dim_num, 2) & - + l124 * tetra(1:dim_num, 3) & - + l123 * tetra(1:dim_num, 4)) & - / (l234 + l134 + l124 + l123) - - b(1:dim_num, 1:4) = tetra(1:dim_num, 1:4) - b(4, 1:4) = 1.0D+00 - - gamma = abs(r8mat_det_4d(b)) - -! gamma = abs ( & -! ( tetra(1,2) * tetra(2,3) * tetra(3,4) & -! - tetra(1,3) * tetra(2,4) * tetra(3,2) & -! + tetra(1,4) * tetra(2,2) * tetra(3,3) ) & -! - ( tetra(1,1) * tetra(2,3) * tetra(3,4) & -! - tetra(1,3) * tetra(2,4) * tetra(3,1) & -! + tetra(1,4) * tetra(2,1) * tetra(3,3) ) & -! + ( tetra(1,1) * tetra(2,2) * tetra(3,4) & -! - tetra(1,2) * tetra(2,4) * tetra(3,1) & -! + tetra(1,4) * tetra(2,1) * tetra(3,2) ) & -! - ( tetra(1,1) * tetra(2,2) * tetra(3,3) & -! - tetra(1,2) * tetra(2,3) * tetra(3,1) & -! + tetra(1,3) * tetra(2,1) * tetra(3,2) ) ) - - r = gamma / (l234 + l134 + l124 + l123) - - return -end -subroutine tetrahedron_lattice_layer_point_next(c, v, more) - -!*****************************************************************************80 -! -!! TETRAHEDRON_LATTICE_LAYER_POINT_NEXT: next tetrahedron lattice layer point. -! -! Discussion: -! -! The tetrahedron lattice layer L is bounded by the lines -! -! 0 <= X, -! 0 <= Y, -! 0 <= Z, -! L - 1 < X / C(1) + Y / C(2) + Z/C(3) <= L. -! -! In particular, layer L = 0 always contains the single point (0,0). -! -! This function returns, one at a time, the points that lie within -! a given tetrahedron lattice layer. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) C(4), coefficients defining the -! lattice layer in entries 1 to 3, and the laver index in C(4). -! The coefficients should be positive, and C(4) must be nonnegative. -! -! Input/output, integer ( kind = 4 ) V(3). On first call for a given layer, -! the input value of V is not important. On a repeated call for the same -! layer, the input value of V should be the output value from the previous -! call. On output, V contains the next lattice layer point. -! -! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to -! indicate that this is the first call for a given layer. Thereafter, the -! input value should be the output value from the previous call. On output, -! MORE is TRUE if the returned value V is a new point. -! If the output value is FALSE, then no more points were found, -! and V was reset to 0, and the lattice layer has been exhausted. -! - implicit none - - integer(kind=4) c(4) - integer(kind=4) c1n - integer(kind=4) i4vec_lcm - integer(kind=4) lhs - logical(kind=4) more - integer(kind=4), parameter :: n = 3 - integer(kind=4) rhs1 - integer(kind=4) rhs2 - integer(kind=4) v(3) -! -! Treat layer C(N+1) = 0 specially. -! - if (c(n + 1) == 0) then - if (.not. more) then - v(1:n) = 0 - more = .true. - else - more = .false. - end if - return - end if -! -! Compute the first point. -! - if (.not. more) then - - v(1) = (c(n + 1) - 1) * c(1) + 1 - v(2:n) = 0 - more = .true. - - else - - c1n = i4vec_lcm(n, c) - - rhs1 = c1n * (c(n + 1) - 1) - rhs2 = c1n * c(n + 1) -! -! Can we simply increase X? -! - v(1) = v(1) + 1 - - lhs = (c1n / c(1)) * v(1) & - + (c1n / c(2)) * v(2) & - + (c1n / c(3)) * v(3) - - if (lhs <= rhs2) then -! -! No. Increase Y, and set X so we just exceed RHS1...if possible. -! - else - - v(2) = v(2) + 1 - - v(1) = (c(1) * (rhs1 - (c1n / c(2)) * v(2) & - - (c1n / c(3)) * v(3))) / c1n - v(1) = max(v(1), 0) - - lhs = (c1n / c(1)) * v(1) & - + (c1n / c(2)) * v(2) & - + (c1n / c(3)) * v(3) - - if (lhs <= rhs1) then - v(1) = v(1) + 1 - lhs = lhs + c1n / c(1) - end if -! -! We have increased Y by 1. Have we stayed below the upper bound? -! - if (lhs <= rhs2) then - - else -! -! No. Increase Z, and set X so we just exceed RHS1...if possible. -! - v(3) = v(3) + 1 - v(2) = 0 - v(1) = (c(1) * (rhs1 - (c1n / c(2)) * v(2) & - - (c1n / c(3)) * v(3))) / c1n - v(1) = max(v(1), 0) - - lhs = (c1n / c(1)) * v(1) & - + (c1n / c(2)) * v(2) & - + (c1n / c(3)) * v(3) - - if (lhs <= rhs1) then - v(1) = v(1) + 1 - lhs = lhs + c1n / c(1) - end if - - if (lhs <= rhs2) then - - else - more = .false. - v(1:n) = 0 - end if - - end if - end if - end if - - return -end -subroutine tetrahedron_lattice_point_next(c, v, more) - -!*****************************************************************************80 -! -!! TETRAHEDRON_LATTICE_POINT_NEXT returns the next tetrahedron lattice point. -! -! Discussion: -! -! The lattice tetrahedron is defined by the vertices: -! -! (0,0,0), (C(4)/C(1),0,0), (0,C(4)/C(2),0) and (0,0,C(4)/C(3)) -! -! The lattice tetrahedron is bounded by the lines -! -! 0 <= X, -! 0 <= Y -! 0 <= Z, -! X / C(1) + Y / C(2) + Z / C(3) <= C(4) -! -! Lattice points are listed one at a time, starting at the origin, -! with X increasing first. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 08 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) C(4), coefficients defining the -! lattice tetrahedron. These should be positive. -! -! Input/output, integer ( kind = 4 ) V(3). On first call, the input -! value is not important. On a repeated call, the input value should -! be the output value from the previous call. On output, V contains -! the next lattice point. -! -! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to -! indicate that this is the first call for a given tetrahedron. Thereafter, -! the input value should be the output value from the previous call. On -! output, MORE is TRUE if not only is the returned value V a lattice point, -! but the routine can be called again for another lattice point. -! If the output value is FALSE, then no more lattice points were found, -! and V was reset to 0, and the routine should not be called further -! for this tetrahedron. -! - implicit none - - integer(kind=4) c(4) - integer(kind=4) c1n - integer(kind=4) i4vec_lcm - integer(kind=4) lhs - logical(kind=4) more - integer(kind=4), parameter :: n = 3 - integer(kind=4) rhs - integer(kind=4) v(3) - - if (.not. more) then - - v(1:n) = 0 - more = .true. - - else - - c1n = i4vec_lcm(n, c) - - rhs = c1n * c(n + 1) - - lhs = c(2) * c(3) * v(1) & - + c(1) * c(3) * v(2) & - + c(1) * c(2) * v(3) - - if (lhs + c1n / c(1) <= rhs) then - - v(1) = v(1) + 1 - - else - - lhs = lhs - c1n * v(1) / c(1) - v(1) = 0 - - if (lhs + c1n / c(2) <= rhs) then - - v(2) = v(2) + 1 - - else - - lhs = lhs - c1n * v(2) / c(2) - v(2) = 0 - - if (lhs + c1n / c(3) <= rhs) then - - v(3) = v(3) + 1 - - else - - v(3) = 0 - more = .false. - - end if - - end if - - end if - - end if - - return -end -subroutine tetrahedron_quality1_3d(tetra, quality) - -!*****************************************************************************80 -! -!! TETRAHEDRON_QUALITY1_3D: "quality" of a tetrahedron in 3D. -! -! Discussion: -! -! The quality of a tetrahedron is 3 times the ratio of the radius of -! the inscribed sphere divided by that of the circumscribed sphere. -! -! An equilateral tetrahredron achieves the maximum possible quality of 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 09 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. -! -! Output, real ( kind = 8 ) QUALITY, the quality of the tetrahedron. -! - implicit none - - real(kind=8) pc(3) - real(kind=8) quality - real(kind=8) r_in - real(kind=8) r_out - real(kind=8) tetra(3, 4) - - call tetrahedron_circumsphere_3d(tetra, r_out, pc) - - call tetrahedron_insphere_3d(tetra, r_in, pc) - - quality = 3.0D+00 * r_in / r_out - - return -end -subroutine tetrahedron_quality2_3d(tetra, quality2) - -!*****************************************************************************80 -! -!! TETRAHEDRON_QUALITY2_3D: "quality" of a tetrahedron in 3D. -! -! Discussion: -! -! The quality measure #2 of a tetrahedron is: -! -! QUALITY2 = 2 * sqrt ( 6 ) * RIN / LMAX -! -! where -! -! RIN = radius of the inscribed sphere; -! LMAX = length of longest side of the tetrahedron. -! -! An equilateral tetrahredron achieves the maximum possible quality of 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 August 2005 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Qiang Du, Desheng Wang, -! The Optimal Centroidal Voronoi Tesselations and the Gersho's -! Conjecture in the Three-Dimensional Space, -! Computers and Mathematics with Applications, -! Volume 49, 2005, pages 1355-1373. -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. -! -! Output, real ( kind = 8 ) QUALITY2, the quality of the tetrahedron. -! - implicit none - - real(kind=8) edge_length(6) - real(kind=8) l_max - real(kind=8) pc(3) - real(kind=8) quality2 - real(kind=8) r_in - real(kind=8) tetra(3, 4) - - call tetrahedron_edge_length_3d(tetra, edge_length) - - l_max = maxval(edge_length(1:6)) - - call tetrahedron_insphere_3d(tetra, r_in, pc) - - quality2 = 2.0D+00 * sqrt(6.0D+00) * r_in / l_max - - return -end -subroutine tetrahedron_quality3_3d(tetra, quality3) - -!*****************************************************************************80 -! -!! TETRAHEDRON_QUALITY3_3D computes the mean ratio of a tetrahedron. -! -! Discussion: -! -! This routine computes QUALITY3, the eigenvalue or mean ratio of -! a tetrahedron. -! -! QUALITY3 = 12 * ( 3 * volume )**(2/3) / (sum of squares of edge lengths). -! -! This value may be used as a shape quality measure for the tetrahedron. -! -! For an equilateral tetrahedron, the value of this quality measure -! will be 1. For any other tetrahedron, the value will be between -! 0 and 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 August 2005 -! -! Author: -! -! Original FORTRAN77 version by Barry Joe. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Barry Joe, -! GEOMPACK - a software package for the generation of meshes -! using geometric algorithms, -! Advances in Engineering Software, -! Volume 13, pages 325-331, 1991. -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. -! -! Output, real ( kind = 8 ) QUALITY3, the mean ratio of the tetrahedron. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) ab(dim_num) - real(kind=8) ac(dim_num) - real(kind=8) ad(dim_num) - real(kind=8) bc(dim_num) - real(kind=8) bd(dim_num) - real(kind=8) cd(dim_num) - real(kind=8) denom - real(kind=8) lab - real(kind=8) lac - real(kind=8) lad - real(kind=8) lbc - real(kind=8) lbd - real(kind=8) lcd - real(kind=8) quality3 - real(kind=8) tetra(dim_num, 4) - real(kind=8) volume -! -! Compute the vectors representing the sides of the tetrahedron. -! - ab(1:3) = tetra(1:dim_num, 2) - tetra(1:dim_num, 1) - ac(1:3) = tetra(1:dim_num, 3) - tetra(1:dim_num, 1) - ad(1:3) = tetra(1:dim_num, 4) - tetra(1:dim_num, 1) - bc(1:3) = tetra(1:dim_num, 3) - tetra(1:dim_num, 2) - bd(1:3) = tetra(1:dim_num, 4) - tetra(1:dim_num, 2) - cd(1:3) = tetra(1:dim_num, 4) - tetra(1:dim_num, 3) -! -! Compute the squares of the lengths of the sides. -! - lab = sum(ab(1:dim_num)**2) - lac = sum(ac(1:dim_num)**2) - lad = sum(ad(1:dim_num)**2) - lbc = sum(bc(1:dim_num)**2) - lbd = sum(bd(1:dim_num)**2) - lcd = sum(cd(1:dim_num)**2) -! -! Compute the volume. -! - volume = abs( & - ab(1) * (ac(2) * ad(3) - ac(3) * ad(2)) & - + ab(2) * (ac(3) * ad(1) - ac(1) * ad(3)) & - + ab(3) * (ac(1) * ad(2) - ac(2) * ad(1))) / 6.0D+00 - - denom = lab + lac + lad + lbc + lbd + lcd - - if (denom == 0.0D+00) then - quality3 = 0.0D+00 - else - quality3 = 12.0D+00 * (3.0D+00 * volume)**(2.0D+00 / 3.0D+00) / denom - end if - - return -end -subroutine tetrahedron_quality4_3d(tetra, quality4) - -!*****************************************************************************80 -! -!! TETRAHEDRON_QUALITY4_3D computes the minimum solid angle of a tetrahedron. -! -! Discussion: -! -! This routine computes a quality measure for a tetrahedron, based -! on the sine of half the minimum of the four solid angles. -! -! The quality measure for an equilateral tetrahedron should be 1, -! since the solid angles of such a tetrahedron are each equal to pi. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 August 2005 -! -! Author: -! -! Original FORTRAN77 version by Barry Joe. -! FORTRAN90 version by John Burkardt. -! -! Reference: -! -! Barry Joe, -! GEOMPACK - a software package for the generation of meshes -! using geometric algorithms, -! Advances in Engineering Software, -! Volume 13, pages 325-331, 1991. -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. -! -! Output, real ( kind = 8 ) QUALITY4, the value of the quality measure. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) ab(dim_num) - real(kind=8) ac(dim_num) - real(kind=8) ad(dim_num) - real(kind=8) bc(dim_num) - real(kind=8) bd(dim_num) - real(kind=8) cd(dim_num) - real(kind=8) denom - real(kind=8) l1 - real(kind=8) l2 - real(kind=8) l3 - real(kind=8) lab - real(kind=8) lac - real(kind=8) lad - real(kind=8) lbc - real(kind=8) lbd - real(kind=8) lcd - real(kind=8) quality4 - real(kind=8) tetra(dim_num, 4) - real(kind=8) volume -! -! Compute the vectors that represent the sides. -! - ab(1:dim_num) = tetra(1:dim_num, 2) - tetra(1:dim_num, 1) - ac(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 1) - ad(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 1) - bc(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 2) - bd(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 2) - cd(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 3) -! -! Compute the lengths of the sides. -! - lab = sqrt(sum(ab(1:dim_num)**2)) - lac = sqrt(sum(ac(1:dim_num)**2)) - lad = sqrt(sum(ad(1:dim_num)**2)) - lbc = sqrt(sum(bc(1:dim_num)**2)) - lbd = sqrt(sum(bd(1:dim_num)**2)) - lcd = sqrt(sum(cd(1:dim_num)**2)) -! -! Compute the volume -! - volume = abs( & - ab(1) * (ac(2) * ad(3) - ac(3) * ad(2)) & - + ab(2) * (ac(3) * ad(1) - ac(1) * ad(3)) & - + ab(3) * (ac(1) * ad(2) - ac(2) * ad(1))) / 6.0D+00 - - quality4 = 1.0D+00 - - l1 = lab + lac - l2 = lab + lad - l3 = lac + lad - - denom = (l1 + lbc) * (l1 - lbc) & - * (l2 + lbd) * (l2 - lbd) & - * (l3 + lcd) * (l3 - lcd) - - if (denom <= 0.0D+00) then - quality4 = 0.0D+00 - else - quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) - end if - - l1 = lab + lbc - l2 = lab + lbd - l3 = lbc + lbd - - denom = (l1 + lac) * (l1 - lac) & - * (l2 + lad) * (l2 - lad) & - * (l3 + lcd) * (l3 - lcd) - - if (denom <= 0.0D+00) then - quality4 = 0.0D+00 - else - quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) - end if - - l1 = lac + lbc - l2 = lac + lcd - l3 = lbc + lcd - - denom = (l1 + lab) * (l1 - lab) & - * (l2 + lad) * (l2 - lad) & - * (l3 + lbd) * (l3 - lbd) - - if (denom <= 0.0D+00) then - quality4 = 0.0D+00 - else - quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) - end if - - l1 = lad + lbd - l2 = lad + lcd - l3 = lbd + lcd - - denom = (l1 + lab) * (l1 - lab) & - * (l2 + lac) * (l2 - lac) & - * (l3 + lbc) * (l3 - lbc) - - if (denom <= 0.0D+00) then - quality4 = 0.0D+00 - else - quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) - end if - - quality4 = quality4 * 1.5D+00 * sqrt(6.0D+00) - - return -end -subroutine tetrahedron_rhombic_shape_3d(point_num, face_num, & - face_order_max, point_coord, face_order, face_point) - -!*****************************************************************************80 -! -!! TETRAHEDRON_RHOMBIC_SHAPE_3D describes a rhombic tetrahedron in 3D. -! -! Discussion: -! -! Call TETRAHEDRON_RHOMBIC_SIZE_3D first, to get dimension information. -! -! The tetrahedron is described using 10 nodes. If we label the vertices -! P0, P1, P2 and P3, then the extra nodes lie halfway between vertices, -! and have the labels P01, P02, P03, P12, P13 and P23. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2007 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Anwei Liu, Barry Joe, -! Quality Local Refinement of Tetrahedral Meshes Based -! on 8-Subtetrahedron Subdivision, -! Mathematics of Computation, -! Volume 65, Number 215, July 1996, pages 1183-1200. -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of -! vertices per face. -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. -! -! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices -! for each face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. -! The points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) d - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) point_coord(dim_num, point_num) - real(kind=8), parameter :: z = 0.0D+00 - - a = 1.0D+00 / sqrt(3.0D+00) - b = sqrt(2.0D+00) / sqrt(3.0D+00) - c = sqrt(3.0D+00) / 6.0D+00 - d = 1.0D+00 / sqrt(6.0D+00) -! -! Set the point coordinates. -! - point_coord(1:dim_num, 1) = (/-b, z, z/) - point_coord(1:dim_num, 2) = (/z, -a, z/) - point_coord(1:dim_num, 3) = (/z, a, z/) - point_coord(1:dim_num, 4) = (/z, z, b/) - point_coord(1:dim_num, 5) = (/-d, -c, z/) - point_coord(1:dim_num, 6) = (/-d, c, z/) - point_coord(1:dim_num, 7) = (/-d, z, d/) - point_coord(1:dim_num, 8) = (/z, z, z/) - point_coord(1:dim_num, 9) = (/z, -c, d/) - point_coord(1:dim_num, 10) = (/z, c, d/) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 6, 6, 6, 6/) -! -! Set faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 1, 5, 2, 9, 4, 7, & - 2, 8, 3, 10, 4, 9, & - 3, 6, 1, 7, 4, 10, & - 1, 6, 3, 8, 2, 5/), (/face_order_max, face_num/)) - - return -end -subroutine tetrahedron_rhombic_size_3d(point_num, edge_num, face_num, & - face_order_max) - -!*****************************************************************************80 -! -!! TETRAHEDRON_RHOMBIC_SIZE_3D gives "sizes" for a rhombic tetrahedron in 3D. -! -! Discussion: -! -! Call this routine first, in order to learn the required dimensions -! of arrays to be set up by TETRAHEDRON_RHOMBIC_SHAPE_3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of vertices. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 10 - edge_num = 6 - face_num = 4 - face_order_max = 6 - - return -end -subroutine tetrahedron_sample_3d(t, n, seed, p) - -!*****************************************************************************80 -! -!! TETRAHEDRON_SAMPLE_3D returns random points in a tetrahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 05 December 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) T(3,4), the tetrahedron vertices. -! -! Input, integer ( kind = 4 ) N, the number of points to sample. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random -! number generator. -! -! Output, real ( kind = 8 ) P(3,N), random points in the tetrahedron. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) n - - real(kind=8) alpha - real(kind=8) beta - real(kind=8) gamma - integer(kind=4) j - real(kind=8) p(dim_num, n) - real(kind=8) p12(dim_num) - real(kind=8) p13(dim_num) - real(kind=8) r - real(kind=8) r8_uniform_01 - integer(kind=4) seed - real(kind=8) t(dim_num, dim_num + 1) - real(kind=8) tr(dim_num, 3) - - do j = 1, n - - r = r8_uniform_01(seed) -! -! Interpret R as a percentage of the tetrahedron's volume. -! -! Imagine a plane, parallel to face 1, so that the volume between -! vertex 1 and the plane is R percent of the full tetrahedron volume. -! -! The plane will intersect sides 12, 13, and 14 at a fraction -! ALPHA = R^1/3 of the distance from vertex 1 to vertices 2, 3, and 4. -! - alpha = r**(1.0D+00 / 3.0D+00) -! -! Determine the coordinates of the points on sides 12, 13 and 14 intersected -! by the plane, which form a triangle TR. -! - tr(1:dim_num, 1) = (1.0D+00 - alpha) * t(1:dim_num, 1) & - + alpha * t(1:dim_num, 2) - tr(1:dim_num, 2) = (1.0D+00 - alpha) * t(1:dim_num, 1) & - + alpha * t(1:dim_num, 3) - tr(1:dim_num, 3) = (1.0D+00 - alpha) * t(1:dim_num, 1) & - + alpha * t(1:dim_num, 4) -! -! Now choose, uniformly at random, a point in this triangle. -! - r = r8_uniform_01(seed) -! -! Interpret R as a percentage of the triangle's area. -! -! Imagine a line L, parallel to side 1, so that the area between -! vertex 1 and line L is R percent of the full triangle's area. -! -! The line L will intersect sides 2 and 3 at a fraction -! ALPHA = SQRT ( R ) of the distance from vertex 1 to vertices 2 and 3. -! - beta = sqrt(r) -! -! Determine the coordinates of the points on sides 2 and 3 intersected -! by line L. -! - p12(1:dim_num) = (1.0D+00 - beta) * tr(1:dim_num, 1) & - + beta * tr(1:dim_num, 2) - p13(1:dim_num) = (1.0D+00 - beta) * tr(1:dim_num, 1) & - + beta * tr(1:dim_num, 3) -! -! Now choose, uniformly at random, a point on the line L. -! - gamma = r8_uniform_01(seed) - - p(1:dim_num, j) = (1.0D+00 - gamma) * p12(1:dim_num) & - + gamma * p13(1:dim_num) - - end do - - return -end -subroutine tetrahedron_shape_3d(point_num, face_num, face_order_max, & - point_coord, face_order, face_point) - -!*****************************************************************************80 -! -!! TETRAHEDRON_SHAPE_3D describes a tetrahedron in 3D. -! -! Discussion: -! -! Call TETRAHEDRON_SIZE_3D first, to get dimension information. -! -! The vertices lie on the unit sphere. -! -! The dual of the tetrahedron is the tetrahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 October 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of -! vertices per face. -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. -! -! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices -! for each face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. -! The points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) point_coord(dim_num, point_num) -! -! Set the point coordinates. -! - point_coord(1:dim_num, 1:point_num) = reshape((/ & - 0.942809D+00, 0.000000D+00, -0.333333D+00, & - -0.471405D+00, 0.816497D+00, -0.333333D+00, & - -0.471405D+00, -0.816497D+00, -0.333333D+00, & - 0.000000D+00, 0.000000D+00, 1.000000D+00/), & - (/dim_num, point_num/)) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 3, 3, 3, 3/) -! -! Set faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 1, 3, 2, & - 1, 2, 4, & - 1, 4, 3, & - 2, 3, 4/), (/face_order_max, face_num/)) - - return -end -subroutine tetrahedron_size_3d(point_num, edge_num, face_num, & - face_order_max) - -!*****************************************************************************80 -! -!! TETRAHEDRON_SIZE_3D gives "sizes" for a tetrahedron in 3D. -! -! Discussion: -! -! Call this routine first, in order to learn the required dimensions -! of arrays to be set up by TETRAHEDRON_SHAPE_3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of vertices. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 4 - edge_num = 6 - face_num = 4 - face_order_max = 3 - - return -end -subroutine tetrahedron_solid_angles_3d(tetra, angle) - -!*****************************************************************************80 -! -!! TETRAHEDRON_SOLID_ANGLES_3D computes solid angles of a tetrahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 July 2009 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. -! -! Output, real ( kind = 8 ) ANGLE(4), the solid angles. -! - implicit none - - real(kind=8) angle(6) - real(kind=8) dihedral_angle(6) - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) tetra(3, 4) - - call tetrahedron_dihedral_angles_3d(tetra, dihedral_angle) - - angle(1) = dihedral_angle(1) + dihedral_angle(2) + dihedral_angle(3) - r8_pi - angle(2) = dihedral_angle(1) + dihedral_angle(4) + dihedral_angle(5) - r8_pi - angle(3) = dihedral_angle(2) + dihedral_angle(4) + dihedral_angle(6) - r8_pi - angle(4) = dihedral_angle(3) + dihedral_angle(5) + dihedral_angle(6) - r8_pi - - return -end -subroutine tetrahedron_volume_3d(tetra, volume) - -!*****************************************************************************80 -! -!! TETRAHEDRON_VOLUME_3D computes the volume of a tetrahedron in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 30 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the tetrahedron. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) a(4, 4) - real(kind=8) r8mat_det_4d - real(kind=8) tetra(dim_num, 4) - real(kind=8) volume - - a(1:dim_num, 1:4) = tetra(1:dim_num, 1:4) - a(4, 1:4) = 1.0D+00 - - volume = abs(r8mat_det_4d(a)) / 6.0D+00 - - return -end -subroutine tetrahedron01_lattice_point_num_3d(s, n) - -!*****************************************************************************80 -! -!! TETRAHEDRON01_LATTICE_POINT_NUM_3D: count lattice points. -! -! Discussion: -! -! The tetrahedron is assumed to be the unit tetrahedron: -! -! ( (0,0,0), (1,0,0), (0,1,0), (0,0,1) ) -! -! or a copy of this tetrahedron scaled by an integer S: -! -! ( (0,0,0), (S,0,0), (0,S,0), (0,0,S) ). -! -! The routine returns the number of integer lattice points that appear -! inside the tetrahedron, or on its faces, edges or vertices. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 July 2009 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Matthias Beck, Sinai Robins, -! Computing the Continuous Discretely, -! Springer, 2006, -! ISBN13: 978-0387291390, -! LC: QA640.7.B43. -! -! Parameters: -! -! Input, integer ( kind = 4 ) S, the scale factor. -! -! Output, integer ( kind = 4 ) N, the number of lattice points. -! - implicit none - - integer(kind=4) n - integer(kind=4) s - - n = ((s + 3) * (s + 2) * (s + 1)) / 6 - - return -end -function tetrahedron01_volume() - -!*****************************************************************************80 -! -!! TETRAHEDRON01_VOLUME returns the volume of the unit tetrahedron. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) TETRAHEDRON01_VOLUME, the volume. -! - implicit none - - real(kind=8) tetrahedron01_volume - - tetrahedron01_volume = 1.0D+00 / 6.0D+00 - - return -end -subroutine timestamp() - -!*****************************************************************************80 -! -!! TIMESTAMP prints the current YMDHMS date as a time stamp. -! -! Example: -! -! 31 May 2001 9:45:54.872 AM -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! None -! - implicit none - - character(len=8) ampm - integer(kind=4) d - integer(kind=4) h - integer(kind=4) m - integer(kind=4) mm - character(len=9), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December '/) - integer(kind=4) n - integer(kind=4) s - integer(kind=4) values(8) - integer(kind=4) y - - call date_and_time(values=values) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if (h < 12) then - ampm = 'AM' - else if (h == 12) then - if (n == 0 .and. s == 0) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if (h < 12) then - ampm = 'PM' - else if (h == 12) then - if (n == 0 .and. s == 0) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write (*, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)') & - d, trim(month(m)), y, h, ':', n, ':', s, '.', mm, trim(ampm) - - return -end -subroutine tmat_init(a) - -!*****************************************************************************80 -! -!! TMAT_INIT initializes the geometric transformation matrix. -! -! Discussion: -! -! The geometric transformation matrix can be thought of as a 4 by 4 -! matrix "A" having components: -! -! r11 r12 r13 t1 -! r21 r22 r23 t2 -! r31 r32 r33 t3 -! 0 0 0 1 -! -! This matrix encodes the rotations, scalings and translations that -! are applied to graphical objects. -! -! A point P = (x,y,z) is rewritten in "homogeneous coordinates" as -! PH = (x,y,z,1). Then to apply the transformations encoded in A to -! the point P, we simply compute A * PH. -! -! Individual transformations, such as a scaling, can be represented -! by simple versions of the transformation matrix. If the matrix -! A represents the current set of transformations, and we wish to -! apply a new transformation B, then the original points are -! transformed twice: B * ( A * PH ). The new transformation B can -! be combined with the original one A, to give a single matrix C that -! encodes both transformations: C = B * A. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 1998 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. -! - implicit none - - real(kind=8) a(4, 4) - integer(kind=4) i - integer(kind=4) j - - do i = 1, 4 - do j = 1, 4 - if (i == j) then - a(i, j) = 1.0D+00 - else - a(i, j) = 0.0D+00 - end if - end do - end do - - return -end -subroutine tmat_mxm(a, b, c) - -!*****************************************************************************80 -! -!! TMAT_MXM multiplies two geometric transformation matrices. -! -! Discussion: -! -! The product is accumulated in a temporary array, and then assigned -! to the result. Therefore, it is legal for any two, or all three, -! of the arguments to share memory. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 December 2000 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the first geometric transformation matrix. -! -! Input, real ( kind = 8 ) B(4,4), the second geometric transformation -! matrix. -! -! Output, real ( kind = 8 ) C(4,4), the product A * B. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) b(4, 4) - real(kind=8) c(4, 4) - - c(1:4, 1:4) = matmul(a(1:4, 1:4), b(1:4, 1:4)) - - return -end -subroutine tmat_mxp(a, x, y) - -!*****************************************************************************80 -! -!! TMAT_MXP multiplies a geometric transformation matrix times a point. -! -! Discussion: -! -! The matrix will normally have the form -! -! xx xy xz tx -! yx yy yz ty -! zx zy zz tz -! 0 0 0 1 -! -! where the 3x3 initial block controls rotations and scalings, -! and the values [ tx, ty, tz ] implement a translation. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 December 2000 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. -! -! Input, real ( kind = 8 ) X(3), the point to be multiplied. The fourth -! component of X is implicitly assigned the value of 1. -! -! Output, real ( kind = 8 ) Y(3), the result of A*X. The product is -! accumulated in a temporary vector, and then assigned to the result. -! Therefore, it is legal for X and Y to share memory. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) x(3) - real(kind=8) y(3) - - y(1:3) = a(1:3, 4) + matmul(a(1:3, 1:3), x(1:3)) - - return -end -subroutine tmat_mxp2(a, n, x, y) - -!*****************************************************************************80 -! -!! TMAT_MXP2 multiplies a geometric transformation matrix times N points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 March 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. -! -! Input, integer ( kind = 4 ) N, the number of points to be multiplied. -! -! Input, real ( kind = 8 ) X(3,N), the points to be multiplied. -! -! Output, real ( kind = 8 ) Y(3,N), the transformed points. Each product is -! accumulated in a temporary vector, and then assigned to the -! result. Therefore, it is legal for X and Y to share memory. -! - implicit none - - integer(kind=4) n - - real(kind=8) a(4, 4) - integer(kind=4) i - real(kind=8) x(3, n) - real(kind=8) y(3, n) - - do i = 1, 3 - y(i, 1:n) = a(i, 4) - end do - - y(1:3, 1:n) = y(1:3, 1:n) + matmul(a(1:3, 1:3), x(1:3, 1:n)) - - return -end -subroutine tmat_mxv(a, x, y) - -!*****************************************************************************80 -! -!! TMAT_MXV multiplies a geometric transformation matrix times a vector. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 August 1999 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. -! -! Input, real ( kind = 8 ) X(3), the vector to be multiplied. The fourth -! component of X is implicitly assigned the value of 1. -! -! Output, real ( kind = 8 ) Y(3), the result of A*X. The product is -! accumulated in a temporary vector, and then assigned to the result. -! Therefore, it is legal for X and Y to share memory. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) x(3) - real(kind=8) y(3) - - y(1:3) = a(1:3, 4) + matmul(a(1:3, 1:3), x(1:3)) - - return -end -subroutine tmat_rot_axis(a, angle, axis, b) - -!*****************************************************************************80 -! -!! TMAT_ROT_AXIS: coordinate axis rotation to geometric transformation matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 December 1998 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the current geometric transformation -! matrix. -! -! Input, real ( kind = 8 ) ANGLE, the angle, in degrees, of the rotation. -! -! Input, character AXIS, is 'X', 'Y' or 'Z', specifying the coordinate -! axis about which the rotation occurs. -! -! Output, real ( kind = 8 ) B(4,4), the modified geometric -! transformation matrix. -! A and B may share the same memory. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) angle - real(kind=8) angle_rad - character axis - real(kind=8) b(4, 4) - real(kind=8) c(4, 4) - real(kind=8) degrees_to_radians - - angle_rad = degrees_to_radians(angle) - - call tmat_init(c) - - if (axis == 'X' .or. axis == 'x') then - c(2, 2) = cos(angle_rad) - c(2, 3) = -sin(angle_rad) - c(3, 2) = sin(angle_rad) - c(3, 3) = cos(angle_rad) - else if (axis == 'Y' .or. axis == 'y') then - c(1, 1) = cos(angle_rad) - c(1, 3) = sin(angle_rad) - c(3, 1) = -sin(angle_rad) - c(3, 3) = cos(angle_rad) - else if (axis == 'Z' .or. axis == 'z') then - c(1, 1) = cos(angle_rad) - c(1, 2) = -sin(angle_rad) - c(2, 1) = sin(angle_rad) - c(2, 2) = cos(angle_rad) - else - write (*, '(a)') ' ' - write (*, '(a)') 'TMAT_ROT_AXIS - Fatal error!' - write (*, '(a)') ' Illegal rotation axis: '//axis - write (*, '(a)') ' Legal choices are ''X'', ''Y'', or ''Z''.' - stop 1 - end if - - b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) - - return -end -subroutine tmat_rot_vector(a, angle, axis, b) - -!*****************************************************************************80 -! -!! TMAT_ROT_VECTOR: arbitrary axis rotation to geometric transformation matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 December 1998 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the current geometric transformation -! matrix. -! -! Input, real ( kind = 8 ) ANGLE, the angle, in degrees, of the rotation. -! -! Input, real ( kind = 8 ) AXIS(3), the axis vector about which -! rotation occurs. AXIS may not be the zero vector. -! -! Output, real ( kind = 8 ) B(4,4), the modified geometric -! transformation matrix. -! A and B may share the same memory. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) angle - real(kind=8) angle_rad - real(kind=8) axis(3) - real(kind=8) b(4, 4) - real(kind=8) c(4, 4) - real(kind=8) ca - real(kind=8) degrees_to_radians - real(kind=8) norm - real(kind=8) sa - real(kind=8) v1 - real(kind=8) v2 - real(kind=8) v3 - - v1 = axis(1) - v2 = axis(2) - v3 = axis(3) - - norm = sqrt(v1 * v1 + v2 * v2 + v3 * v3) - - if (norm == 0.0D+00) then - return - end if - - v1 = v1 / norm - v2 = v2 / norm - v3 = v3 / norm - - angle_rad = degrees_to_radians(angle) - ca = cos(angle_rad) - sa = sin(angle_rad) - - call tmat_init(c) - - c(1, 1) = v1 * v1 + ca * (1.0D+00 - v1 * v1) - c(1, 2) = (1.0D+00 - ca) * v1 * v2 - sa * v3 - c(1, 3) = (1.0D+00 - ca) * v1 * v3 + sa * v2 - - c(2, 1) = (1.0D+00 - ca) * v2 * v1 + sa * v3 - c(2, 2) = v2 * v2 + ca * (1.0D+00 - v2 * v2) - c(2, 3) = (1.0D+00 - ca) * v2 * v3 - sa * v1 - - c(3, 1) = (1.0D+00 - ca) * v3 * v1 - sa * v2 - c(3, 2) = (1.0D+00 - ca) * v3 * v2 + sa * v1 - c(3, 3) = v3 * v3 + ca * (1.0D+00 - v3 * v3) - - b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) - - return -end -subroutine tmat_scale(a, s, b) - -!*****************************************************************************80 -! -!! TMAT_SCALE applies a scaling to the geometric transformation matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 1998 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the current geometric transformation -! matrix. -! -! Input, real ( kind = 8 ) S(3), the scalings to be applied to the -! X, Y and Z coordinates. -! -! Output, real ( kind = 8 ) B(4,4), the modified geometric transformation -! matrix. A and B may share the same memory. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) b(4, 4) - real(kind=8) c(4, 4) - real(kind=8) s(3) - - call tmat_init(c) - - c(1, 1) = s(1) - c(2, 2) = s(2) - c(3, 3) = s(3) - - b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) - - return -end -subroutine tmat_shear(a, axis, s, b) - -!*****************************************************************************80 -! -!! TMAT_SHEAR applies a shear to the geometric transformation matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 October 1998 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the current geometric transformation -! matrix. -! -! Input, character ( len = 2 ) AXIS, is 'XY', 'XZ', 'YX', 'YZ', 'ZX' or 'ZY', -! specifying the shear equation: -! -! XY: x' = x + s * y; -! XZ: x' = x + s * z; -! YX: y' = y + s * x; -! YZ: y' = y + s * z; -! ZX: z' = z + s * x; -! ZY: z' = z + s * y. -! -! Input, real ( kind = 8 ) S, the shear coefficient. -! -! Output, real ( kind = 8 ) B(4,4), the modified geometric transformation -! matrix. A and B may share the same memory. -! - implicit none - - real(kind=8) a(4, 4) - character(len=2) axis - real(kind=8) b(4, 4) - real(kind=8) c(4, 4) - real(kind=8) s - - call tmat_init(c) - - if (axis == 'XY' .or. axis == 'xy') then - c(1, 2) = s - else if (axis == 'XZ' .or. axis == 'xz') then - c(1, 3) = s - else if (axis == 'YX' .or. axis == 'yx') then - c(2, 1) = s - else if (axis == 'YZ' .or. axis == 'yz') then - c(2, 3) = s - else if (axis == 'ZX' .or. axis == 'zx') then - c(3, 1) = s - else if (axis == 'ZY' .or. axis == 'zy') then - c(3, 2) = s - else - write (*, '(a)') ' ' - write (*, '(a)') 'TMAT_SHEAR - Fatal error!' - write (*, '(a)') ' Illegal shear axis: "'//axis//'".' - write (*, '(a)') ' Legal choices are XY, XZ, YX, YZ, ZX, or ZY.' - stop 1 - end if - - b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) - - return -end -subroutine tmat_trans(a, t, b) - -!*****************************************************************************80 -! -!! TMAT_TRANS applies a translation to the geometric transformation matrix. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 December 2000 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! James Foley, Andries van Dam, Steven Feiner, John Hughes, -! Computer Graphics, Principles and Practice, -! Second Edition, -! Addison Wesley, 1990. -! -! Parameters: -! -! Input, real ( kind = 8 ) A(4,4), the current geometric transformation -! matrix. -! -! Input, real ( kind = 8 ) T(3), the translation. This may be thought -! of as the point that the origin moves to under the translation. -! -! Output, real ( kind = 8 ) B(4,4), the modified transformation matrix. -! A and B may share the same memory. -! - implicit none - - real(kind=8) a(4, 4) - real(kind=8) b(4, 4) - real(kind=8) t(3) - - b(1:4, 1:4) = a(1:4, 1:4) - - b(1:3, 4) = b(1:3, 4) + t(1:3) - - return -end -function torus_area_3d(r1, r2) - -!*****************************************************************************80 -! -!! TORUS_AREA_3D returns the area of a torus in 3D. -! -! Discussion: -! -! A torus with radii R1 and R2 is the set of points P satisfying: -! -! ( sqrt ( P(1)^2 + P(2)^2 ) - R1 )^2 + P(3)^2 <= R2^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 November 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the two radii that define the torus. -! -! Output, real ( kind = 8 ) TORUS_AREA_3D, the area of the torus. -! - implicit none - - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) torus_area_3d - - torus_area_3d = 4.0D+00 * r8_pi * r8_pi * r1 * r2 - - return -end -subroutine torus_volume_3d(r1, r2, volume) - -!*****************************************************************************80 -! -!! TORUS_VOLUME_3D computes the volume of a torus in 3D. -! -! Discussion: -! -! A torus with radii R1 and R2 is the set of points P satisfying: -! -! ( sqrt ( P(1)*^ + P(2)^2 ) - R1 )^2 + P(3)^2 <= R2^2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 11 December 1998 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) R1, R2, the "inner" and "outer" radii of the -! torus. -! -! Output, real ( kind = 8 ) VOLUME, the volume of the torus. -! - implicit none - - real(kind=8) r1 - real(kind=8) r2 - real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 - real(kind=8) volume - - volume = 2.0D+00 * r8_pi * r8_pi * r1 * r2 * r2 - - return -end -subroutine tp_to_xyz(theta, phi, v) - -!*****************************************************************************80 -! -!! TP_TO_XYZ converts unit spherical TP coordinates to XYZ coordinates. -! -! Discussion: -! -! The point is assume to lie on the unit sphere centered at the origin. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 September 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) THETA, PHI, the angular coordinates of a point -! on the unit sphere. -! -! Output, real ( kind = 8 ) V(3), the XYZ coordinates. -! - implicit none - - real(kind=8) phi - real(kind=8) theta - real(kind=8) v(3) - - v(1) = cos(theta) * sin(phi) - v(2) = sin(theta) * sin(phi) - v(3) = cos(phi) - - return -end - -subroutine truncated_octahedron_shape_3d(point_num, face_num, & - face_order_max, point_coord, face_order, face_point) - -!*****************************************************************************80 -! -!! TRUNCATED_OCTAHEDRON_SHAPE_3D describes a truncated octahedron in 3D. -! -! Discussion: -! -! The shape is a truncated octahedron. There are 8 hexagons and 6 -! squares. -! -! The truncated octahedron is an interesting shape because it -! is "space filling". In other words, all of 3D space can be -! filled by a regular lattice of these shapes. -! -! Call TRUNCATED_OCTAHEDRON_SIZE_3D to get the values of POINT_NUM, -! FACE_NUM, and FACE_ORDER_MAX, so you can allocate space for the arrays. -! -! For each face, the face list must be of length FACE_ORDER_MAX. -! In cases where a face is of lower than maximum order (the -! squares, in this case), the extra entries are listed as "-1". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 August 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) POINT_NUM, the number of points (24). -! -! Input, integer ( kind = 4 ) FACE_NUM, the number of faces (14). -! -! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any -! face (6). -! -! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. -! -! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of -! vertices per face. -! -! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); -! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. -! The points are listed in the counter clockwise direction defined -! by the outward normal at the face. -! - implicit none - - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4), parameter :: dim_num = 3 - integer(kind=4) point_num - - integer(kind=4) face_order(face_num) - integer(kind=4) face_point(face_order_max, face_num) - real(kind=8) point_coord(dim_num, point_num) -! -! Set the point coordinates. -! - point_coord(1:dim_num, 1:point_num) = reshape((/ & - -1.5D+00, -0.5D+00, 0.0D+00, & - -1.5D+00, 0.5D+00, 0.0D+00, & - -1.0D+00, -1.0D+00, -0.70710677D+00, & - -1.0D+00, -1.0D+00, 0.70710677D+00, & - -1.0D+00, 1.0D+00, -0.70710677D+00, & - -1.0D+00, 1.0D+00, 0.70710677D+00, & - -0.5D+00, -1.5D+00, 0.0D+00, & - -0.5D+00, -0.5D+00, -1.4142135D+00, & - -0.5D+00, -0.5D+00, 1.4142135D+00, & - -0.5D+00, 0.5D+00, -1.4142135D+00, & - -0.5D+00, 0.5D+00, 1.4142135D+00, & - -0.5D+00, 1.5D+00, 0.0D+00, & - 0.5D+00, -1.5D+00, 0.0D+00, & - 0.5D+00, -0.5D+00, -1.4142135D+00, & - 0.5D+00, -0.5D+00, 1.4142135D+00, & - 0.5D+00, 0.5D+00, -1.4142135D+00, & - 0.5D+00, 0.5D+00, 1.4142135D+00, & - 0.5D+00, 1.5D+00, 0.0D+00, & - 1.0D+00, -1.0D+00, -0.70710677D+00, & - 1.0D+00, -1.0D+00, 0.70710677D+00, & - 1.0D+00, 1.0D+00, -0.70710677D+00, & - 1.0D+00, 1.0D+00, 0.70710677D+00, & - 1.5D+00, -0.5D+00, 0.0D+00, & - 1.5D+00, 0.5D+00, 0.0D+00/), (/dim_num, point_num/)) -! -! Set the face orders. -! - face_order(1:face_num) = (/ & - 4, 4, 4, 4, 4, 4, 6, 6, 6, 6, & - 6, 6, 6, 6/) -! -! Set faces. -! - face_point(1:face_order_max, 1:face_num) = reshape((/ & - 17, 11, 9, 15, -1, -1, & - 14, 8, 10, 16, -1, -1, & - 22, 24, 21, 18, -1, -1, & - 12, 5, 2, 6, -1, -1, & - 13, 19, 23, 20, -1, -1, & - 4, 1, 3, 7, -1, -1, & - 19, 13, 7, 3, 8, 14, & - 15, 9, 4, 7, 13, 20, & - 16, 10, 5, 12, 18, 21, & - 22, 18, 12, 6, 11, 17, & - 20, 23, 24, 22, 17, 15, & - 14, 16, 21, 24, 23, 19, & - 9, 11, 6, 2, 1, 4, & - 3, 1, 2, 5, 10, 8/), (/face_order_max, face_num/)) - - return -end -subroutine truncated_octahedron_size_3d(point_num, edge_num, face_num, & - face_order_max) - -!*****************************************************************************80 -! -!! TRUNCATED_OCTAHEDRON_SIZE_3D gives "sizes" for a truncated octahedron in 3D. -! -! Discussion: -! -! The truncated octahedron is "space-filling". -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 July 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer ( kind = 4 ) POINT_NUM, the number of points. -! -! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. -! -! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. -! -! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. -! - implicit none - - integer(kind=4) edge_num - integer(kind=4) face_num - integer(kind=4) face_order_max - integer(kind=4) point_num - - point_num = 24 - edge_num = 36 - face_num = 14 - face_order_max = 6 - - return -end -subroutine tube_2d(dist, n, p, p1, p2) - -!*****************************************************************************80 -! -!! TUBE_2D constructs a "tube" of given width around a path in 2D. -! -! Discussion: -! -! The routine is given a sequence of N points, and a distance DIST. -! -! It returns the coordinates of the corners of the top and bottom -! of a tube of width 2*DIST, which envelopes the line connecting -! the points. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) DIST, the radius of the tube. -! -! Input, integer ( kind = 4 ) N, the number of points defining the line. -! N must be at least 2. -! -! Input, real ( kind = 8 ) P(2,N), the points which comprise the broken -! line which is to be surrounded by the tube. Points should -! not be immediately repeated, that is, it should never be -! the case that -! P(1,I) = P(1,I+1) and P(2,I) = P(2,I+1). -! -! Output, real ( kind = 8 ) P1(2,N), P2(2,N), the points P1 form -! one side of the tube, and P2 the other. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) a - real(kind=8) b - real(kind=8) c - real(kind=8) dis1 - real(kind=8) dis2 - real(kind=8) dist - integer(kind=4) i - integer(kind=4) i4_wrap - integer(kind=4) im1 - integer(kind=4) ip1 - real(kind=8) p(dim_num, n) - real(kind=8) p1(dim_num, n) - real(kind=8) p2(dim_num, n) - real(kind=8) temp -! -! Check that N is at least 3. -! - if (n < 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'TUBE_2D - Fatal error!' - write (*, '(a)') ' N must be at least 3' - write (*, '(a,i8)') ' but your input value was N = ', n - stop 1 - end if -! -! Check that consecutive points are distinct. -! - do i = 1, n - 1 - if (all(p(1:2, i) == p(1:2, i + 1))) then - write (*, '(a)') ' ' - write (*, '(a)') 'TUBE_2D - Fatal error!' - write (*, '(a,i8)') ' P(1:2,I) = P(1:2,I+1) for I = ', i - write (*, '(a,2g14.6)') ' P(1:2,I) = ', p(1:2, i) - stop 1 - end if - end do - - do i = 1, n - - im1 = i4_wrap(i - 1, 1, n) - ip1 = i4_wrap(i + 1, 1, n) - - call angle_box_2d(dist, p(1:2, im1), p(1:2, i), & - p(1:2, ip1), p1(1:2, i), p2(1:2, i)) -! -! On the first and last steps, translate the corner points DIST units -! along the line, to make an extra buffer. -! - if (i == 1) then - - temp = sqrt((p(1, 2) - p(1, 1))**2 + (p(2, 2) - p(2, 1))**2) - p1(1:2, 1) = p1(1:2, 1) - dist * (p(1:2, 2) - p(1:2, 1)) / temp - p2(1:2, 1) = p2(1:2, 1) - dist * (p(1:2, 2) - p(1:2, 1)) / temp - - else if (i == n) then - - temp = sqrt((p(1, n) - p(1, n - 1))**2 + (p(2, n) - p(2, n - 1))**2) - p1(1:2, n) = p1(1:2, n) + dist * (p(1:2, n) - p(1:2, n - 1)) / temp - p2(1:2, n) = p2(1:2, n) + dist * (p(1:2, n) - p(1:2, n - 1)) / temp - - end if -! -! The new points P1 and P2 may need to be swapped. -! -! Compute the signed distance from the points to the line. -! - if (1 < i) then - - a = p(2, i - 1) - p(2, i) - b = p(1, i) - p(1, i - 1) - c = p(1, i - 1) * p(2, i) - p(1, i) * p(2, i - 1) - - dis1 = (a * p1(1, i - 1) + b * p1(2, i - 1) + c) / sqrt(a * a + b * b) - - dis2 = (a * p1(1, i) + b * p1(2, i) + c) / sqrt(a * a + b * b) - - if (sign(1.0D+00, dis1) /= sign(1.0D+00, dis2)) then - - call r8_swap(p1(1, i), p2(1, i)) - call r8_swap(p1(2, i), p2(2, i)) - - end if - - end if - - end do - - return -end -subroutine vector_directions_nd(dim_num, v, angle) - -!*****************************************************************************80 -! -!! VECTOR_DIRECTIONS_ND returns the direction angles of a vector in ND. -! -! Discussion: -! -! Let V be the vector, and let E(I) be the I-th unit coordinate axis vector. -! The I-th direction angle is the angle between V and E(I), which is -! the angle whose cosine is equal to the direction cosine: -! -! Direction_Cosine(I) = V dot E(I) / |V|. -! -! If V is the null or zero vector, then the direction cosines and -! direction angles are undefined, and this routine simply returns -! zeroes. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) V(DIM_NUM), the vector. -! -! Output, real ( kind = 8 ) ANGLE(DIM_NUM), the direction angles, in radians, -! that the vector V makes with the coordinate axes. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) angle(dim_num) - real(kind=8) v(dim_num) - real(kind=8) vnorm -! -! Get the norm of the vector. -! - vnorm = sqrt(sum(v(1:dim_num)**2)) - - if (vnorm == 0.0D+00) then - angle(1:dim_num) = 0.0D+00 - return - end if - - angle(1:dim_num) = acos(v(1:dim_num) / vnorm) - - return -end -subroutine vector_rotate_2d(v, angle, w) - -!*****************************************************************************80 -! -!! VECTOR_ROTATE_2D rotates a vector around the origin in 2D. -! -! Discussion: -! -! To see why this formula is so, consider that the original point -! has the form ( R cos Theta, R sin Theta ), and the rotated point -! has the form ( R cos ( Theta + Angle ), R sin ( Theta + Angle ) ). -! Now use the addition formulas for cosine and sine to relate -! the new point to the old one: -! -! ( W1 ) = ( cos Angle - sin Angle ) * ( V1 ) -! ( W2 ) ( sin Angle cos Angle ) ( V2 ) -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 19 April 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V(2), the components of the vector to be -! rotated. -! -! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation -! to be carried out. A positive angle rotates the vector in the -! counter clockwise direction. -! -! Output, real ( kind = 8 ) W(2), the rotated vector. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle - real(kind=8) v(dim_num) - real(kind=8) w(dim_num) - - w(1) = cos(angle) * v(1) - sin(angle) * v(2) - w(2) = sin(angle) * v(1) + cos(angle) * v(2) - - return -end -subroutine vector_rotate_3d(v1, axis, angle, v2) - -!*****************************************************************************80 -! -!! VECTOR_ROTATE_3D rotates a vector around an axis vector in 3D. -! -! Discussion: -! -! Thanks to Cody Farnell for correcting some errors in a previous -! version of this routine! -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 August 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) V1(3), the vector to be rotated. -! -! Input, real ( kind = 8 ) AXIS(3), the vector about which the -! rotation is to be carried out. -! -! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation -! to be carried out. -! -! Output, real ( kind = 8 ) V2(3), the rotated vector. -! - implicit none - - real(kind=8) angle - real(kind=8) axis(3) - real(kind=8) dot - real(kind=8) norm - real(kind=8) norm_vn - real(kind=8) normal2(3) - real(kind=8) r8vec_norm - real(kind=8) v1(3) - real(kind=8) v2(3) - real(kind=8) vn(3) - real(kind=8) vp(3) - real(kind=8) vr(3) -! -! Compute the length of the rotation axis. -! - norm = r8vec_norm(3, axis) - - if (norm == 0.0D+00) then - v2(1:3) = v1(1:3) - return - end if -! -! Compute the dot product of the vector and the (unit) rotation axis. -! - dot = dot_product(v1(1:3), axis(1:3)) / norm -! -! Compute the parallel component of the vector. -! - vp(1:3) = dot * axis(1:3) / norm -! -! Compute the normal component of the vector. -! - vn(1:3) = v1(1:3) - vp(1:3) - - norm_vn = r8vec_norm(3, vn) - - if (norm_vn == 0.0D+00) then - v2(1:3) = vp(1:3) - return - end if - - vn(1:3) = vn(1:3) / norm_vn -! -! Compute a second vector, lying in the plane, perpendicular -! to V1 and VN, and forming a right-handed system. -! - normal2(1) = axis(2) * vn(3) - axis(3) * vn(2) - normal2(2) = axis(3) * vn(1) - axis(1) * vn(3) - normal2(3) = axis(1) * vn(2) - axis(2) * vn(1) - - norm = r8vec_norm(3, normal2) - if (norm /= 0.0D+00) then - normal2(1:3) = normal2(1:3) / norm - end if -! -! Rotate the normal component by the angle. -! - vr(1:3) = norm_vn * (cos(angle) * vn(1:3) + sin(angle) * normal2(1:3)) -! -! The rotated vector is the parallel component plus the rotated component. -! - v2(1:3) = vp(1:3) + vr(1:3) - - return -end -subroutine vector_rotate_base_2d(p1, pb, angle, p2) - -!*****************************************************************************80 -! -!! VECTOR_ROTATE_BASE_2D rotates a vector around a base point in 2D. -! -! Discussion: -! -! The original vector is assumed to be ( X1-XB, Y1-YB ), and the -! rotated vector is ( X2-XB, Y2-YB ). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 29 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), the endpoint of the original vector. -! -! Input, real ( kind = 8 ) PB(2), the location of the base point. -! -! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation -! to be carried out. A positive angle rotates the vector in the -! counter clockwise direction. -! -! Output, real ( kind = 8 ) P2(2), the endpoint of the rotated vector. -! - implicit none - - integer(kind=4), parameter :: dim_num = 2 - - real(kind=8) angle - real(kind=8) p1(2) - real(kind=8) p2(2) - real(kind=8) pb(2) - - p2(1) = pb(1) + cos(angle) * (p1(1) - pb(1)) & - - sin(angle) * (p1(2) - pb(2)) - - p2(2) = pb(2) + sin(angle) * (p1(1) - pb(1)) & - + cos(angle) * (p1(2) - pb(2)) - - return -end -subroutine vector_separation_nd(dim_num, v1, v2, theta) - -!*****************************************************************************80 -! -!! VECTOR_SEPARATION_ND finds the angular separation between vectors in ND. -! -! Discussion: -! -! Any two vectors lie in a plane, and are separated by a plane angle. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 December 2000 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the two vectors. -! -! Output, real ( kind = 8 ) THETA, the angle between the two vectors. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) cos_theta - real(kind=8) r8_acos - real(kind=8) theta - real(kind=8) v1(dim_num) - real(kind=8) v1_norm - real(kind=8) v2(dim_num) - real(kind=8) v2_norm - - v1_norm = sqrt(sum(v1(1:dim_num)**2)) - - v2_norm = sqrt(sum(v2(1:dim_num)**2)) - - cos_theta = dot_product(v1(1:dim_num), v2(1:dim_num)) & - / (v1_norm * v2_norm) - - theta = r8_acos(cos_theta) - - return -end -subroutine vector_unit_nd(dim_num, v) - -!*****************************************************************************80 -! -!! VECTOR_UNIT_ND normalizes a vector in ND. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 07 February 1999 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input/output, real ( kind = 8 ) V(DIM_NUM), the vector to be normalized. -! On output, V should have unit Euclidean norm. However, if the input vector -! has zero Euclidean norm, it is not altered. -! - implicit none - - integer(kind=4) dim_num - - real(kind=8) norm - real(kind=8) v(dim_num) - - norm = sqrt(sum(v(1:dim_num)**2)) - - if (norm /= 0.0D+00) then - v(1:dim_num) = v(1:dim_num) / norm - end if - - return -end -function voxels_dist_l1_nd(dim_num, v1, v2) - -!*****************************************************************************80 -! -!! VOXELS_DIST_L1_ND computes the L1 distance between voxels in ND. -! -! Discussion: -! -! A voxel is generally a point in 3D space with integer coordinates. -! There's no reason to stick with 3D, so this routine will handle -! any dimension. -! -! We can imagine that, in traveling from V1 to V2, we are allowed to -! increment or decrement just one coordinate at a time. The minimum number -! of such changes required is the L1 distance. -! -! More formally, -! -! DIST_L1 ( V1, V2 ) = sum ( 1 <= I <= N ) | V1(I) - V2(I) | -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 March 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, integer ( kind = 4 ) V1(DIM_NUM), the voxel that begins the line. -! -! Input, integer ( kind = 4 ) V2(DIM_NUM), the voxel that ends the line. -! -! Output, integer ( kind = 4 ) VOXELS_DIST_L1_ND, the L1 distance -! between the voxels. -! - implicit none - - integer(kind=4) dim_num - - integer(kind=4) v1(dim_num) - integer(kind=4) v2(dim_num) - integer(kind=4) voxels_dist_l1_nd - - voxels_dist_l1_nd = sum(abs(v1(1:dim_num) - v2(1:dim_num))) - - return -end -subroutine voxels_line_3d(v1, v2, n, v) - -!*****************************************************************************80 -! -!! VOXELS_LINE_3D computes voxels along a line in 3D. -! -! Discussion: -! -! The line itself is defined by two voxels. The line will begin -! at the first voxel, and move towards the second. If the value of -! N is equal to the L1 distance between the two voxels, then the -! line will "almost" reach the second voxel. Depending on the -! direction, 1, 2 or 3 more steps may be needed. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 06 March 2005 -! -! Author: -! -! Daniel Cohen -! -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! Daniel Cohen, -! Voxel Traversal along a 3D Line, -! in Graphics Gems IV, -! edited by Paul Heckbert, -! AP Professional, 1994, -! T385.G6974. -! -! Parameters: -! -! Input, integer ( kind = 4 ) V1(3), the voxel that begins the line. -! -! Input, integer ( kind = 4 ) V2(3), the voxel that ends the line. -! -! Input, integer ( kind = 4 ) N, the number of voxels to compute. -! -! Output, integer ( kind = 4 ) V(3,N), a sequence of voxels, whose -! first value is V1 and which proceeds towards V2. -! - implicit none - - integer(kind=4) n - integer(kind=4), parameter :: dim_num = 3 - - integer(kind=4) a(3) - integer(kind=4) exy - integer(kind=4) exz - integer(kind=4) ezy - integer(kind=4) i - integer(kind=4) s(3) - integer(kind=4) v(3, n) - integer(kind=4) v1(3) - integer(kind=4) v2(3) - - if (n <= 0) then - return - end if -! -! Determine the number of voxels on the line. -! - s(1:dim_num) = sign(1, v2(1:dim_num) - v1(1:dim_num)) - a(1:dim_num) = abs(v2(1:dim_num) - v1(1:dim_num)) - - exy = a(2) - a(1) - exz = a(3) - a(1) - ezy = a(2) - a(3) -! -! We start at the starting point. -! - v(1:dim_num, 1) = v1(1:dim_num) - - do i = 2, n - - v(1:dim_num, i) = v(1:dim_num, i - 1) - - if (exy < 0) then - - if (exz < 0) then - v(1, i) = v(1, i) + s(1) - exy = exy + 2 * a(2) - exz = exz + 2 * a(3) - else - v(3, i) = v(3, i) + s(3) - exz = exz - 2 * a(1) - ezy = ezy + 2 * a(2) - end if - - else if (ezy < 0) then - - v(3, i) = v(3, i) + s(3) - exz = exz - 2 * a(1) - ezy = ezy + 2 * a(2) - - else - - v(2, i) = v(2, i) + s(2) - exy = exy - 2 * a(1) - ezy = ezy - 2 * a(3) - - end if - - end do - - return -end -subroutine voxels_region_3d(list_max, nx, ny, nz, ishow, list_num, list, & - region_num) - -!*****************************************************************************80 -! -!! VOXELS_REGION_3D arranges contiguous voxels into regions in 3D. -! -! Discussion: -! -! On input, the ISHOW array contains zero and nonzero values. The nonzero -! values are taken to be active voxels. On output, the zero voxels remain -! zero, and all the active voxels have been assigned a value which now -! indicates membership in a region, or group of contiguous voxels. -! -! On output, the array LIST contains information about the regions. -! The last used element of LIST is LIST_NUM. -! -! The number of elements in region REGION_NUM is NELEM = LIST(LIST_NUM). -! The (I,J,K) indices of the last element in this region are in -! LIST(LIST_NUM-3) through LIST(LIST_NUM-1), and the first element is -! listed in LIST(LIST_NUM-3*NELEM), LIST(LIST_NUM-3*NELEM+1), -! LIST(LIST_NUM-3*NELEM+2). -! -! The number of elements in REGION_NUM-1 is listed in -! LIST(LIST_NUM-3*NELEM-1), -! and the (I,J,K) indices of the these elements are listed there. -! -! Thanks to Emre Evren for pointing out a hard-to-spot error involving -! a DO loop that mistakenly read "DO 1 = 1, N". -! -! Picture: -! -! Input: -! -! 0 2 0 0 17 0 3 -! 0 0 3 0 1 0 4 -! 1 0 4 8 8 0 7 -! 3 0 6 45 0 0 0 -! 3 17 0 5 9 2 5 -! -! Output: -! -! 0 1 0 0 2 0 3 -! 0 0 2 0 2 0 3 -! 4 0 2 2 2 0 3 -! 4 0 2 2 0 0 0 -! 4 4 0 2 2 2 2 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 March 2006 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) LIST_MAX, the maximum length of the array -! used to list the elements of the regions. -! -! Input, integer ( kind = 4 ) NX, NY, NZ, the number of voxels in the X, Y -! and Z directions. -! -! Input/output, integer ( kind = 4 ) ISHOW(NX,NY,NZ). On input, the only -! significance to the entries is whether they are zero or nonzero. On -! output, the nonzero entries have now been revalued so that contiguous -! entries have the same value, indicating a grouping into a region. -! -! Output, integer ( kind = 4 ) LIST_NUM, the number of entries of LIST that -! were used. However, if LIST_MAX < LIST_NUM, then there was not enough -! space in LIST to store the data properly, and LIST should not be used, -! although the data in ISHOW should be correct. -! -! Output, integer ( kind = 4 ) LIST(LIST_MAX), contains, in stack form, a -! list of the indices of the elements in each region. -! -! Output, integer ( kind = 4 ) REGION_NUM, the number of regions discovered. -! - implicit none - - integer(kind=4), parameter :: maxstack = 100 - - integer(kind=4) list_max - integer(kind=4) nx - integer(kind=4) ny - integer(kind=4) nz - - integer(kind=4) i - integer(kind=4) i2 - integer(kind=4) ibase - integer(kind=4) ihi - integer(kind=4) ilo - integer(kind=4) ishow(nx, ny, nz) - integer(kind=4) j - integer(kind=4) j2 - integer(kind=4) jbase - integer(kind=4) jhi - integer(kind=4) jlo - integer(kind=4) k - integer(kind=4) k2 - integer(kind=4) kbase - integer(kind=4) khi - integer(kind=4) klo - integer(kind=4) list(list_max) - integer(kind=4) list_num - integer(kind=4) nabes - integer(kind=4) ncan - integer(kind=4) nelements - integer(kind=4) nstack - integer(kind=4) region_num - integer(kind=4) stack(maxstack) -! -! Reset all nonzero entries of ISHOW to -1. -! - do k = 1, nz - do j = 1, ny - do i = 1, nx - - if (ishow(i, j, k) /= 0) then - ishow(i, j, k) = -1 - end if - - end do - end do - end do -! -! Start the number of items in the region list at 0. -! - list_num = 0 -! -! Start the number of regions at 0. -! - region_num = 0 -! -! The stack begins empty. -! - nstack = 0 -! -! Search for an unused "ON" voxel from which we can "grow" a new region. -! - do k = 1, nz - do j = 1, ny - do i = 1, nx -! -! We found a voxel that is "ON", and does not belong to any region. -! - if (ishow(i, j, k) == -1) then -! -! Increase the number of regions. -! - region_num = region_num + 1 -! -! Add this voxel to the region. -! - ishow(i, j, k) = region_num -! -! Add this voxel to the stack. -! - if (maxstack < nstack + 4) then - write (*, '(a)') ' ' - write (*, '(a)') 'VOXELS_REGION - Fatal error!' - write (*, '(a)') ' The internal stack overflowed.' - write (*, '(a)') ' The algorithm has failed.' - stop 1 - end if - - stack(nstack + 1) = i - stack(nstack + 2) = j - stack(nstack + 3) = k - stack(nstack + 4) = 1 - - nstack = nstack + 4 -! -! Add this voxel to the description of the region. -! - nelements = 1 - - if (list_num + 3 <= list_max) then - list(list_num + 1) = i - list(list_num + 2) = j - list(list_num + 3) = k - end if - - list_num = list_num + 3 - - do -! -! Find all neighbors of BASE that are "ON" but unused. -! Mark them as belonging to this region, and stack their indices. -! - ibase = stack(nstack - 3) - jbase = stack(nstack - 2) - kbase = stack(nstack - 1) - - ilo = max(ibase - 1, 1) - ihi = min(ibase + 1, nx) - jlo = max(jbase - 1, 1) - jhi = min(jbase + 1, ny) - klo = max(kbase - 1, 1) - khi = min(kbase + 1, nz) - - nabes = 0 - - do i2 = ilo, ihi - do j2 = jlo, jhi - do k2 = klo, khi -! -! We found a neighbor to our current search point, which is "ON" and unused. -! - if (ishow(i2, j2, k2) == -1) then -! -! Increase the number of neighbors. -! - nabes = nabes + 1 -! -! Mark the neighbor as belonging to the region. -! - ishow(i2, j2, k2) = region_num -! -! Add the neighbor to the stack. -! - if (maxstack < nstack + 3) then - write (*, '(a)') ' ' - write (*, '(a)') 'VOXELS_REGION - Fatal error!' - write (*, '(a)') ' The internal stack overflowed.' - write (*, '(a)') ' The algorithm has failed.' - stop 1 - end if - - stack(nstack + 1) = i2 - stack(nstack + 2) = j2 - stack(nstack + 3) = k2 - - nstack = nstack + 3 -! -! Add the neighbor to the description of the region. -! - nelements = nelements + 1 - - if (list_num + 3 <= list_max) then - list(list_num + 1) = i2 - list(list_num + 2) = j2 - list(list_num + 3) = k2 - end if - - list_num = list_num + 3 - - end if - - end do - end do - end do -! -! If any new neighbors were found, take the last one as the basis -! for a deeper search. -! - if (0 < nabes) then - - if (maxstack < nstack + 1) then - write (*, '(a)') ' ' - write (*, '(a)') 'VOXELS_REGION - Fatal error!' - write (*, '(a)') ' The internal stack overflowed.' - write (*, '(a)') ' The algorithm has failed.' - stop 1 - end if - - stack(nstack + 1) = nabes - nstack = nstack + 1 - cycle - - end if -! -! If the current search point had no new neighbors, drop it from the stack. -! - ncan = stack(nstack) - 1 - nstack = nstack - 3 - stack(nstack) = ncan -! -! If there are still any unused candidates at this level, take the -! last one as the basis for a deeper search. -! - if (0 < stack(nstack)) then - cycle - end if -! -! If there are no more unused candidates at this level, then we need -! to back up a level in the stack. If there are any candidates at -! that earlier level, then we can still do more searching. -! - nstack = nstack - 1 - - if (nstack <= 0) then - exit - end if - - end do -! -! If we have exhausted the stack, we have completed this region. -! Tag the number of elements to the end of the region description list. -! - list_num = list_num + 1 - if (list_num <= list_max) then - list(list_num) = nelements - end if - - end if - - end do - end do - end do -! -! Print some warnings. -! - if (list_max < list_num) then - write (*, '(a)') ' ' - write (*, '(a)') 'VOXELS_REGION - Warning!' - write (*, '(a)') ' LIST_MAX was too small to list the regions.' - write (*, '(a)') ' Do not try to use the LIST array!' - write (*, '(a)') ' The ISHOW data is OK, however.' - end if - - return -end -subroutine voxels_step_3d(v1, v2, inc, jnc, knc, v3) - -!*****************************************************************************80 -! -!! VOXELS_STEP_3D computes voxels along a line from a given point in 3D. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 September 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) V1(3), the coordinates of the base voxel from -! which the line begins. -! -! Input, integer ( kind = 4 ) V2(3), the coordinates of the current voxel -! on the line. For the first call, these might be equal to V1. -! -! Input, integer ( kind = 4 ) INC, JNC, KNC, the increments to the voxels. -! These values define the direction along which the line proceeds. -! However, the voxels on the line will typically be incremented -! by a fractional value of the vector (INC,JNC,KNC), and the -! result is essentially rounded. -! -! Output, integer ( kind = 4 ) V3(3), the coordinates of the next voxel along -! the line. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) alpha - real(kind=8) alphai - real(kind=8) alphaj - real(kind=8) alphak - integer(kind=4) inc - integer(kind=4) jnc - integer(kind=4) knc - integer(kind=4) v1(3) - integer(kind=4) v2(3) - integer(kind=4) v3(3) - - v3(1:dim_num) = v2(1:dim_num) -! -! Assuming for the moment that (I,J,K) can take on real values, -! points on the line have the form: -! -! I = V1(2) + alpha * inc -! J = V1(2) + alpha * jnc -! K = V1(3) + alpha * knc -! - if (inc == 0 .and. jnc == 0 .and. knc == 0) then - return - end if - - alpha = 0.0D+00 -! -! Compute the smallest ALPHA that will change one of V2(1:3) by +-0.5. -! - if (0 < inc) then - alphai = (real(v2(1) - v1(1), kind=8) + 0.5D+00) & - / real(inc, kind=8) - else if (inc < 0) then - alphai = (real(v2(1) - v1(1), kind=8) - 0.5D+00) & - / real(inc, kind=8) - else - alphai = huge(alphai) - end if - - if (0 < jnc) then - alphaj = (real(v2(2) - v1(2), kind=8) + 0.5D+00) & - / real(jnc, kind=8) - else if (jnc < 0) then - alphaj = (real(v2(2) - v1(2), kind=8) - 0.5D+00) & - / real(jnc, kind=8) - else - alphaj = huge(alphaj) - end if - - if (0 < knc) then - alphak = (real(v2(3) - v1(3), kind=8) + 0.5D+00) & - / real(knc, kind=8) - else if (knc < 0) then - alphak = (real(v2(3) - v1(3), kind=8) - 0.5D+00) & - / real(knc, kind=8) - else - alphaj = huge(alphaj) - end if -! -! The ALPHA of smallest positive magnitude represents the closest next voxel. -! - alpha = huge(alpha) - - if (0.0D+00 < alphai) then - alpha = min(alpha, alphai) - end if - - if (0.0D+00 < alphaj) then - alpha = min(alpha, alphaj) - end if - - if (0.0D+00 < alphak) then - alpha = min(alpha, alphak) - end if -! -! Move to the new voxel. Whichever index just made the half -! step must be forced to take a whole step. -! - if (alpha == alphai) then - v3(1) = v2(1) + sign(1, inc) - v3(2) = v1(2) + nint(alpha * real(jnc, kind=8)) - v3(3) = v1(3) + nint(alpha * real(knc, kind=8)) - else if (alpha == alphaj) then - v3(1) = v1(1) + nint(alpha * real(inc, kind=8)) - v3(2) = v2(2) + sign(1, jnc) - v3(3) = v1(3) + nint(alpha * real(knc, kind=8)) - else if (alpha == alphak) then - v3(1) = v1(1) + nint(alpha * real(inc, kind=8)) - v3(2) = v1(2) + nint(alpha * real(jnc, kind=8)) - v3(3) = v2(3) + sign(1, knc) - end if - - return -end -function wedge01_volume() - -!*****************************************************************************80 -! -!! WEDGE01_VOLUME: volume of the unit wedge in 3D. -! -! Discussion: -! -! The integration region is defined as: -! -! 0 <= X -! 0 <= Y -! X + Y <= 1 -! -1 <= Z <= 1. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 January 2018 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, real ( kind = 8 ) WEDGE01_VOLUME, the volume. -! - implicit none - - real(kind=8) wedge01_volume - - wedge01_volume = 1.0D+00 - - return -end -subroutine xy_to_polar(xy, r, t) - -!*****************************************************************************80 -! -!! XY_TO_POLAR converts XY coordinates to polar coordinates. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 January 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) XY(2), the Cartesian coordinates. -! -! Output, real ( kind = 8 ) R, T, the radius and angle (in radians). -! - implicit none - - real(kind=8) r - real(kind=8) r8_atan - real(kind=8) t - real(kind=8) xy(2) - - r = sqrt(xy(1) * xy(1) + xy(2) * xy(2)) - - if (r == 0.0D+00) then - t = 0.0D+00 - else - t = r8_atan(xy(2), xy(1)) - end if - - return -end -subroutine xyz_to_radec(p, ra, dec) - -!*****************************************************************************80 -! -!! XYZ_TO_RADEC converts (X,Y,Z) to right ascension/declination coordinates. -! -! Discussion: -! -! Given an XYZ point, compute its distance R from the origin, and -! regard it as lying on a sphere of radius R, whose axis is the Z -! axis. -! -! The right ascension of the point is the "longitude", measured in hours, -! between 0 and 24, with the X axis having right ascension 0, and the -! Y axis having right ascension 6. -! -! Declination measures the angle from the equator towards the north pole, -! and ranges from -90 (South Pole) to 90 (North Pole). -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 December 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) P(3), the coordinates of a point in 3D. -! -! Output, real ( kind = 8 ) RA, DEC, the corresponding right ascension -! and declination. -! - implicit none - - integer(kind=4), parameter :: dim_num = 3 - - real(kind=8) dec - real(kind=8) p(dim_num) - real(kind=8) p_norm - real(kind=8) phi - real(kind=8) r8_asin - real(kind=8) r8_atan - real(kind=8) ra - real(kind=8) radians_to_degrees - real(kind=8) theta - - p_norm = sqrt(sum(p(1:dim_num)**2)) - - if (p_norm == 0.0D+00) then - dec = 0.0D+00 - ra = 0.0D+00 - return - end if - - phi = r8_asin(p(3) / p_norm) - - if (cos(phi) == 0.0D+00) then - theta = 0.0D+00 - else - theta = r8_atan(p(2), p(1)) - end if - - dec = radians_to_degrees(phi) - ra = radians_to_degrees(theta) / 15.0D+00 - - return -end -subroutine xyz_to_rtp(xyz, r, theta, phi) - -!*****************************************************************************80 -! -!! XYZ_TO_RTP converts (X,Y,Z) to (R,Theta,Phi) coordinates. -! -! Discussion: -! -! Given an XYZ point, compute its distance R from the origin, and -! regard it as lying on a sphere of radius R, whose axis is the Z -! axis. -! -! Theta measures the "longitude" of the point, between 0 and 2 PI. -! -! PHI measures the angle from the "north pole", between 0 and PI. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 10 January 2007 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) XYZ(3), the coordinates of a point in 3D. -! -! Output, real ( kind = 8 ) R, THETA, PHI, the radius, longitude and -! declination of the point. -! - implicit none - - real(kind=8) r - real(kind=8) r8_acos - real(kind=8) r8_atan - real(kind=8) phi - real(kind=8) theta - real(kind=8) xyz(3) - - r = sqrt(sum(xyz(1:3)**2)) - - if (r == 0.0D+00) then - theta = 0.0D+00 - phi = 0.0D+00 - return - end if - - phi = r8_acos(xyz(3) / r) - - theta = r8_atan(xyz(2), xyz(1)) - - return -end -subroutine xyz_to_tp(xyz, theta, phi) - -!*****************************************************************************80 -! -!! XYZ_TO_TP converts (X,Y,Z) to (Theta,Phi) coordinates. -! -! Discussion: -! -! Given an XYZ point, regard it as lying on a sphere of radius R, -! centered at the origin, whose axis is the Z axis. -! -! We assume that the actual value of R is of no interest, and do -! not report it. This is especially appropriate if the point is -! expected to lie on the unit sphere, for instance. -! -! THETA measures the "longitude" of the point, between 0 and 2 PI. -! -! PHI measures the angle from the "north pole", between 0 and PI. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 22 September 2010 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, real ( kind = 8 ) XYZ(3), the coordinates of a point in 3D. -! -! Output, real ( kind = 8 ) THETA, PHI, the longitude and declination -! of the point. -! - implicit none - - real(kind=8) r - real(kind=8) r8_acos - real(kind=8) r8_atan - real(kind=8) phi - real(kind=8) theta - real(kind=8) xyz(3) - - r = sqrt(sum(xyz(1:3)**2)) - - if (r == 0.0D+00) then - theta = 0.0D+00 - phi = 0.0D+00 - return - end if - - phi = r8_acos(xyz(3) / r) - - theta = r8_atan(xyz(2), xyz(1)) - - return -end diff --git a/src/modules/GlobalData/CMakeLists.txt b/src/modules/GlobalData/CMakeLists.txt deleted file mode 100644 index 4c192ea45..000000000 --- a/src/modules/GlobalData/CMakeLists.txt +++ /dev/null @@ -1,23 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - "${src_path}/GlobalData.F90" -) \ No newline at end of file diff --git a/src/modules/GlobalData/src/ElementNames.txt b/src/modules/GlobalData/src/ElementNames.txt deleted file mode 100644 index dab0f7895..000000000 --- a/src/modules/GlobalData/src/ElementNames.txt +++ /dev/null @@ -1,138 +0,0 @@ -#define MSH_LIN_2 1 -#define MSH_TRI_3 2 -#define MSH_QUA_4 3 -#define MSH_TET_4 4 -#define MSH_HEX_8 5 -#define MSH_PRI_6 6 -#define MSH_PYR_5 7 -#define MSH_LIN_3 8 -#define MSH_TRI_6 9 -#define MSH_QUA_9 10 -#define MSH_TET_10 11 -#define MSH_HEX_27 12 -#define MSH_PRI_18 13 -#define MSH_PYR_14 14 -#define MSH_PNT 15 -#define MSH_QUA_8 16 -#define MSH_HEX_20 17 -#define MSH_PRI_15 18 -#define MSH_PYR_13 19 -#define MSH_TRI_9 20 -#define MSH_TRI_10 21 -#define MSH_TRI_12 22 -#define MSH_TRI_15 23 -#define MSH_TRI_15I 24 -#define MSH_TRI_21 25 -#define MSH_LIN_4 26 -#define MSH_LIN_5 27 -#define MSH_LIN_6 28 -#define MSH_TET_20 29 -#define MSH_TET_35 30 -#define MSH_TET_56 31 -#define MSH_TET_22 32 -#define MSH_TET_28 33 -#define MSH_POLYG_ 34 -#define MSH_POLYH_ 35 -#define MSH_QUA_16 36 -#define MSH_QUA_25 37 -#define MSH_QUA_36 38 -#define MSH_QUA_12 39 -#define MSH_QUA_16I 40 -#define MSH_QUA_20 41 -#define MSH_TRI_28 42 -#define MSH_TRI_36 43 -#define MSH_TRI_45 44 -#define MSH_TRI_55 45 -#define MSH_TRI_66 46 -#define MSH_QUA_49 47 -#define MSH_QUA_64 48 -#define MSH_QUA_81 49 -#define MSH_QUA_100 50 -#define MSH_QUA_121 51 -#define MSH_TRI_18 52 -#define MSH_TRI_21I 53 -#define MSH_TRI_24 54 -#define MSH_TRI_27 55 -#define MSH_TRI_30 56 -#define MSH_QUA_24 57 -#define MSH_QUA_28 58 -#define MSH_QUA_32 59 -#define MSH_QUA_36I 60 -#define MSH_QUA_40 61 -#define MSH_LIN_7 62 -#define MSH_LIN_8 63 -#define MSH_LIN_9 64 -#define MSH_LIN_10 65 -#define MSH_LIN_11 66 -#define MSH_LIN_B 67 -#define MSH_TRI_B 68 -#define MSH_POLYG_B 69 -#define MSH_LIN_C 70 -!! TETS COMPLETE (6->10) -#define MSH_TET_84 71 -#define MSH_TET_120 72 -#define MSH_TET_165 73 -#define MSH_TET_220 74 -#define MSH_TET_286 75 -!! TETS INCOMPLETE (6->10) -#define MSH_TET_34 79 -#define MSH_TET_40 80 -#define MSH_TET_46 81 -#define MSH_TET_52 82 -#define MSH_TET_58 83 -!! -#define MSH_LIN_1 84 -#define MSH_TRI_1 85 -#define MSH_QUA_1 86 -#define MSH_TET_1 87 -#define MSH_HEX_1 88 -#define MSH_PRI_1 89 -#define MSH_PRI_40 90 -#define MSH_PRI_75 91 -!! HEXES COMPLETE (3->9) -#define MSH_HEX_64 92 -#define MSH_HEX_125 93 -#define MSH_HEX_216 94 -#define MSH_HEX_343 95 -#define MSH_HEX_512 96 -#define MSH_HEX_729 97 -#define MSH_HEX_1000 98 -!! HEXES INCOMPLETE (3->9) -#define MSH_HEX_32 99 -#define MSH_HEX_44 100 -#define MSH_HEX_56 101 -#define MSH_HEX_68 102 -#define MSH_HEX_80 103 -#define MSH_HEX_92 104 -#define MSH_HEX_104 105 -!! PRISMS COMPLETE (5->9) -#define MSH_PRI_126 106 -#define MSH_PRI_196 107 -#define MSH_PRI_288 108 -#define MSH_PRI_405 109 -#define MSH_PRI_550 110 -!! PRISMS INCOMPLETE (3->9) -#define MSH_PRI_24 111 -#define MSH_PRI_33 112 -#define MSH_PRI_42 113 -#define MSH_PRI_51 114 -#define MSH_PRI_60 115 -#define MSH_PRI_69 116 -#define MSH_PRI_78 117 -!! PYRAMIDS COMPLETE (3->9) -#define MSH_PYR_30 118 -#define MSH_PYR_55 119 -#define MSH_PYR_91 120 -#define MSH_PYR_140 121 -#define MSH_PYR_204 122 -#define MSH_PYR_285 123 -#define MSH_PYR_385 124 - -!! PYRAMIDS INCOMPLETE (3->9) -#define MSH_PYR_21 125 -#define MSH_PYR_29 126 -#define MSH_PYR_37 127 -#define MSH_PYR_45 128 -#define MSH_PYR_53 129 -#define MSH_PYR_61 130 -#define MSH_PYR_69 131 diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 deleted file mode 100755 index caf86f440..000000000 --- a/src/modules/GlobalData/src/GlobalData.F90 +++ /dev/null @@ -1,617 +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 GlobalData -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INPUT_UNIT, & - & OUTPUT_UNIT, ERROR_UNIT -IMPLICIT NONE -PUBLIC - -#include "./ElementNames.txt" - -SAVE -INTEGER, PARAMETER :: stdin = INPUT_UNIT -INTEGER, PARAMETER :: stdout = OUTPUT_UNIT -INTEGER, PARAMETER :: stderr = OUTPUT_UNIT -INTEGER, PARAMETER :: endianL = 1 -INTEGER, PARAMETER :: endianB = 0 -INTEGER :: endian = endianL -#ifdef USE_Real128 -INTEGER, PARAMETER :: REAL128 = SELECTED_REAL_KIND(33, 4931) -#else -INTEGER, PARAMETER :: REAL128 = SELECTED_REAL_KIND(15, 307) -#endif -INTEGER, PARAMETER :: REAL64 = SELECTED_REAL_KIND(15, 307) -INTEGER, PARAMETER :: REAL32 = SELECTED_REAL_KIND(6, 37) -#ifdef USE_Real64 -INTEGER, PARAMETER :: Float = REAL64 ! Default -#else -INTEGER, PARAMETER :: Float = REAL32 ! Default -#endif -#ifdef USE_Real64 -INTEGER, PARAMETER :: DFP = REAL64 -#else -INTEGER, PARAMETER :: DFP = REAL32 -#endif -INTEGER, PARAMETER :: INT64 = SELECTED_INT_KIND(18) -INTEGER, PARAMETER :: INT32 = SELECTED_INT_KIND(9) -INTEGER, PARAMETER :: INT16 = SELECTED_INT_KIND(4) -INTEGER, PARAMETER :: INT8 = SELECTED_INT_KIND(2) -#ifdef USE_Int64 -INTEGER, PARAMETER :: I4B = INT64 -INTEGER, PARAMETER :: DIP = INT64 -#else -INTEGER, PARAMETER :: I4B = INT32 -INTEGER, PARAMETER :: DIP = INT32 -#endif -INTEGER, PARAMETER :: SP = REAL32 -INTEGER, PARAMETER :: DP = REAL64 -INTEGER, PARAMETER :: SPC = KIND((1.0_REAL32, 1.0_REAL32)) -INTEGER, PARAMETER :: DPC = KIND((1.0_REAL64, 1.0_REAL64)) -#ifdef USE_Real64 -INTEGER, PARAMETER :: DFPC = KIND((1.0_REAL64, 1.0_REAL64)) -#else -INTEGER, PARAMETER :: DFPC = KIND((1.0_REAL32, 1.0_REAL32)) -#endif -INTEGER, PARAMETER :: LGT = KIND(.TRUE.) -! Logical -! -!Format parameters -#ifdef USE_Real128 -CHARACTER(*), PARAMETER :: FReal128 = '(E42.33E4)' -#else -CHARACTER(*), PARAMETER :: FReal128 = '(E23.15E3)' -#endif -CHARACTER(*), PARAMETER :: FReal64 = '(E23.15E3)' -CHARACTER(*), PARAMETER :: FReal32 = '(E13.6E2)' -#ifdef USE_Real64 -CHARACTER(*), PARAMETER :: FReal = FReal64 -CHARACTER(*), PARAMETER :: FFloat = FReal64 -#else -CHARACTER(*), PARAMETER :: FReal = FReal32 -CHARACTER(*), PARAMETER :: FFloat = FReal32 -#endif -#ifdef USE_Real64 -CHARACTER(*), PARAMETER :: FDFP = FReal64 ! Default -#else -CHARACTER(*), PARAMETER :: FDFP = FReal32 ! Default -#endif -CHARACTER(*), PARAMETER :: FInt64 = '(I20)' -CHARACTER(*), PARAMETER :: FInt64ZP = '(I20.19)' -CHARACTER(*), PARAMETER :: FInt32 = '(I11)' -CHARACTER(*), PARAMETER :: FInt32ZP = '(I11.10)' -CHARACTER(*), PARAMETER :: FInt16 = '(I6)' -CHARACTER(*), PARAMETER :: FInt16ZP = '(I6.5)' -CHARACTER(*), PARAMETER :: FInt8 = '(I4)' -CHARACTER(*), PARAMETER :: FInt8ZP = '(I4.3)' -#ifdef USE_Int64 -CHARACTER(*), PARAMETER :: FInt = FInt64 -CHARACTER(*), PARAMETER :: FI4B = FInt64 -CHARACTER(*), PARAMETER :: FI4BZP = FInt64ZP -CHARACTER(*), PARAMETER :: FIntZP = FInt64ZP -#else -CHARACTER(*), PARAMETER :: FInt = FInt32 !Default -CHARACTER(*), PARAMETER :: FI4B = FInt32 !Default -CHARACTER(*), PARAMETER :: FI4BZP = FInt32ZP -CHARACTER(*), PARAMETER :: FIntZP = FInt32ZP -#endif -! Length (number of digits) of formatted numbers -#ifdef USE_Real128 -INTEGER, PARAMETER :: DReal128 = 42 -#else -INTEGER, PARAMETER :: DReal128 = 23 -#endif -INTEGER, PARAMETER :: DReal64 = 23 -INTEGER, PARAMETER :: DReal32 = 13 -#ifdef USE_Real64 -INTEGER, PARAMETER :: DReal = DReal64 -INTEGER, PARAMETER :: DFloat = DReal64 -INTEGER, PARAMETER :: DDFP = DReal64 -#else -INTEGER, PARAMETER :: DReal = DReal32 -INTEGER, PARAMETER :: DFloat = DReal32 -INTEGER, PARAMETER :: DDFP = DReal32 -#endif -INTEGER, PARAMETER :: DInt64 = 20 -INTEGER, PARAMETER :: DInt32 = 11 -INTEGER, PARAMETER :: DInt16 = 6 -INTEGER, PARAMETER :: DInt8 = 4 -#ifdef USE_Int64 -INTEGER, PARAMETER :: DInt = DInt64 -INTEGER, PARAMETER :: DI4B = DInt64 -#else -INTEGER, PARAMETER :: DInt = DInt32 -INTEGER, PARAMETER :: DI4B = DInt32 -#endif -! Minimum and maximum (representable) values -REAL(REAL128), PARAMETER :: TypeReal128 = 1.0 -REAL(REAL128), PARAMETER :: MinReal128 = -HUGE(1._REAL128) -REAL(REAL128), PARAMETER :: MaxReal128 = HUGE(1._REAL128) -REAL(REAL64), PARAMETER :: TypeReal64 = 1.0 -REAL(REAL64), PARAMETER :: MinReal64 = -HUGE(1._REAL64) -REAL(REAL64), PARAMETER :: MaxReal64 = HUGE(1._REAL64) -REAL(REAL32), PARAMETER :: TypeReal32 = 1.0 -REAL(REAL32), PARAMETER :: MinReal32 = -HUGE(1._REAL32) -REAL(REAL32), PARAMETER :: MaxReal32 = HUGE(1._REAL32) -#ifdef USE_Real64 -REAL(Float), PARAMETER :: MinFloat = MinReal64 -REAL(Float), PARAMETER :: MinReal = MinReal64 -REAL(Float), PARAMETER :: MaxFloat = MaxReal64 -REAL(Float), PARAMETER :: MaxReal = MaxReal64 -REAL(Float), PARAMETER :: MinDFP = MinReal64 -REAL(Float), PARAMETER :: MaxDFP = MaxReal64 -#else -REAL(Float), PARAMETER :: MinFloat = MinReal32 -REAL(Float), PARAMETER :: MinReal = MinReal32 -REAL(Float), PARAMETER :: MaxFloat = MaxReal32 -REAL(Float), PARAMETER :: MaxReal = MaxReal32 -REAL(Float), PARAMETER :: MinDFP = MinReal32 -REAL(Float), PARAMETER :: MaxDFP = MaxReal32 -#endif -REAL(DFP), PARAMETER :: TypeReal = 1.0_DFP -REAL(DFP), PARAMETER :: TypeDFP = 1.0_DFP -REAL(Float), PARAMETER :: TypeFloat = 1.0_FLOAT -INTEGER(INT64), PARAMETER :: MinInt64 = -HUGE(1_INT64), TypeInt64 = 1_INT64 -INTEGER(INT32), PARAMETER :: MinInt32 = -HUGE(1_INT32), TypeInt32 = 1_INT32 -INTEGER(INT16), PARAMETER :: MinInt16 = -HUGE(1_INT16), TypeInt16 = 1_INT16 -INTEGER(INT8), PARAMETER :: MinInt8 = -HUGE(1_INT8), TypeInt8 = 1_INT8 -#ifdef USE_Int64 -INTEGER(DIP), PARAMETER :: MinInt = MinInt64 -INTEGER(I4B), PARAMETER :: MinI4B = MinInt64 -#else -INTEGER(DIP), PARAMETER :: MinInt = MinInt32 -INTEGER(I4B), PARAMETER :: MinI4B = MinInt32 -#endif -INTEGER(DIP), PARAMETER :: TypeInt = 1 -INTEGER(DIP), PARAMETER :: TypeIntI4B = 1 -INTEGER(INT64), PARAMETER :: MaxInt64 = HUGE(1_INT64) -INTEGER(INT32), PARAMETER :: MaxInt32 = HUGE(1_INT32) -INTEGER(INT16), PARAMETER :: MaxInt16 = HUGE(1_INT16) -INTEGER(INT8), PARAMETER :: MaxInt8 = HUGE(1_INT8) -#ifdef USE_Int64 -INTEGER(DIP), PARAMETER :: MaxI4B = MaxInt64 !default -INTEGER(DIP), PARAMETER :: MaxInt = MaxInt64 !default -#else -INTEGER(DIP), PARAMETER :: MaxI4B = MaxInt32 !default -INTEGER(DIP), PARAMETER :: MaxInt = MaxInt32 !default -#endif -! Real smallest (representable) values -REAL(REAL128), PARAMETER :: smallReal128 = TINY(1._REAL128) -REAL(REAL64), PARAMETER :: smallReal64 = TINY(1._REAL64) -REAL(REAL32), PARAMETER :: smallReal32 = TINY(1._REAL32) -#ifdef USE_Real64 -REAL(Float), PARAMETER :: smallFloat = smallReal64 -REAL(Float), PARAMETER :: smallReal = smallReal64 -REAL(Float), PARAMETER :: smallDFP = smallReal64 -#else -REAL(Float), PARAMETER :: smallFloat = smallReal32 -REAL(Float), PARAMETER :: smallReal = smallReal32 -REAL(Float), PARAMETER :: smallDFP = smallReal32 -#endif -! Smallest REAL representable difference by the running calculator -REAL(REAL128), PARAMETER :: ZeroReal128 = & - & NEAREST(1._REAL128, 1._REAL128) - NEAREST(1._REAL128, -1._REAL128) -REAL(REAL64), PARAMETER :: ZeroReal64 = & - & NEAREST(1._REAL64, 1._REAL64) - NEAREST(1._REAL64, -1._REAL64) -REAL(REAL32), PARAMETER :: ZeroReal32 = & - & NEAREST(1._REAL32, 1._REAL32) - NEAREST(1._REAL32, -1._REAL32) -#ifdef USE_Real64 -REAL(Float), PARAMETER :: Zero = ZeroReal64 -#else -REAL(Float), PARAMETER :: Zero = ZeroReal32 -#endif -! Bits/bytes memory requirements -#ifdef USE_Real128 -INTEGER(INT16), PARAMETER :: BIReal128 = int(STORAGE_SIZE(MaxReal128), kind=int16) -#else -INTEGER(INT16), PARAMETER :: BIReal128 = int(STORAGE_SIZE(MaxReal64), kind=int16) -#endif -INTEGER(INT8), PARAMETER :: BIReal64 = INT(STORAGE_SIZE(MaxReal64), kind=INT8) -INTEGER(INT8), PARAMETER :: BIReal32 = INT(STORAGE_SIZE(MaxReal32), kind=INT8) -#ifdef USE_Real64 -INTEGER(INT8), PARAMETER :: BIFloat = BIReal64 !default in bits -INTEGER(INT8), PARAMETER :: BIReal = BIReal64 !default in bits -INTEGER(INT8), PARAMETER :: BIDFP = BIReal64 !default in bytes -#else -INTEGER(INT8), PARAMETER :: BIFloat = BIReal32 !default in bits -INTEGER(INT8), PARAMETER :: BIReal = BIReal32 !default in bits -INTEGER(INT8), PARAMETER :: BIDFP = BIReal32 !default in bytes -#endif -INTEGER(INT16), PARAMETER :: BYReal128 = INT(BIReal128 / 8_INT16, kind=INT16) -INTEGER(INT8), PARAMETER :: BYReal64 = INT(BIReal64 / 8_INT16, kind=INT8) -INTEGER(INT8), PARAMETER :: BYReal32 = INT(BIReal32 / 8_INT16, kind=INT8) -#ifdef USE_Real64 -INTEGER(INT8), PARAMETER :: BYFloat = INT(BYReal64, kind=INT8) -INTEGER(INT8), PARAMETER :: BYReal = INT(BYReal64, kind=INT8) -INTEGER(INT8), PARAMETER :: BYDFP = INT(BYReal64, kind=INT8) -#else -INTEGER(INT8), PARAMETER :: BYFloat = INT(BYReal32, kind=INT8) -INTEGER(INT8), PARAMETER :: BYReal = INT(BYReal32, kind=INT8) -INTEGER(INT8), PARAMETER :: BYDFP = INT(BYReal32, kind=INT8) -#endif -INTEGER(INT64), PARAMETER :: BIInt64 = INT(BIT_SIZE(MaxInt64), kind=INT64) -INTEGER(INT32), PARAMETER :: BIInt32 = INT(BIT_SIZE(MaxInt32), kind=INT32) -INTEGER(INT16), PARAMETER :: BIInt16 = INT(BIT_SIZE(MaxInt16), kind=INT16) -INTEGER(INT8), PARAMETER :: BIInt8 = INT(BIT_SIZE(MaxInt8), kind=INT8) -INTEGER(DIP), PARAMETER :: BIInt = INT(BIT_SIZE(MaxInt), kind=DIP) -INTEGER(DIP), PARAMETER :: BII4B = INT(BIT_SIZE(MaxInt), kind=DIP) -INTEGER(INT64), PARAMETER :: BYInt64 = int(BIT_SIZE(MaxInt64) / 8_INT64, kind=int64) -INTEGER(INT32), PARAMETER :: BYInt32 = int(BIT_SIZE(MaxInt32) / 8_INT32, kind=int32) -INTEGER(INT16), PARAMETER :: BYInt16 = int(BIT_SIZE(MaxInt16) / 8_INT16, kind=int16) -INTEGER(INT8), PARAMETER :: BYInt8 = int(BIT_SIZE(MaxInt8) / 8_INT8, kind=int8) -INTEGER(DIP), PARAMETER :: BYInt = INT(BIT_SIZE(MaxInt) / 8_DIP, kind=DIP) -INTEGER(DIP), PARAMETER :: BYI4B = INT(BIT_SIZE(MaxInt) / 8_DIP, kind=DIP) -REAL(DFP), PARAMETER :: Pi = 3.14159265359_DFP -REAL(DFP), PARAMETER :: Eye3(3, 3) = RESHAPE( & - & [1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.0_DFP, 0.0_DFP, 1.0_DFP], [3, 3]) -REAL(DFP), PARAMETER :: Eye2(2, 2) = RESHAPE( & - & [1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP], [2, 2]) -! Parameters for iteration data -INTEGER(I4B), PARAMETER :: RelativeConvergence = 1 -INTEGER(I4B), PARAMETER :: AbsoluteConvergence = 2 -INTEGER(I4B), PARAMETER :: ConvergenceInRes = 1 -INTEGER(I4B), PARAMETER :: ConvergenceInSol = 2 -INTEGER(I4B), PARAMETER :: ConvergenceInResSol = 3 -INTEGER(I4B), PARAMETER :: ConvergenceInSolRes = 3 -INTEGER(I4B), PARAMETER :: NormL1 = 1 -INTEGER(I4B), PARAMETER :: NormL2 = 2 -INTEGER(I4B), PARAMETER :: NormInfinity = 3 -!! -!! Type of polynomial for scale interpolation -!! -INTEGER(I4B), PARAMETER :: Monomial = 0 -INTEGER(I4B), PARAMETER :: LagrangePolynomial = 1 -INTEGER(I4B), PARAMETER :: Lagrange = LagrangePolynomial -INTEGER(I4B), PARAMETER :: SerendipityPolynomial = 2 -INTEGER(I4B), PARAMETER :: Serendipity = SerendipityPolynomial -INTEGER(I4B), PARAMETER :: HeirarchicalPolynomial = 3 -INTEGER(I4B), PARAMETER :: Heirarchical = HeirarchicalPolynomial -INTEGER(I4B), PARAMETER :: HierarchicalPolynomial = 3 -INTEGER(I4B), PARAMETER :: Hierarchical = HierarchicalPolynomial -INTEGER(I4B), PARAMETER :: HeirarchyPolynomial = 3 -INTEGER(I4B), PARAMETER :: Heirarchy = HeirarchyPolynomial -INTEGER(I4B), PARAMETER :: HierarchyPolynomial = 3 -INTEGER(I4B), PARAMETER :: Hierarchy = HierarchyPolynomial -INTEGER(I4B), PARAMETER :: Jacobi = 4 -INTEGER(I4B), PARAMETER :: Ultraspherical = 5 -INTEGER(I4B), PARAMETER :: Legendre = 6 -INTEGER(I4B), PARAMETER :: Chebyshev = 7 -INTEGER(I4B), PARAMETER :: Lobatto = 8 -INTEGER(I4B), PARAMETER :: Orthogonal = 9 -INTEGER(I4B), PARAMETER :: OrthogonalPolynomial = Orthogonal -INTEGER(I4B), PARAMETER :: UnscaledLobatto = 10 -INTEGER(I4B), PARAMETER :: HermitPolynomial = 11 -!! -!! Quadrature types -!! -INTEGER(I4B), PARAMETER :: Equidistance = 1 -INTEGER(I4B), PARAMETER :: Gauss = 2 -INTEGER(I4B), PARAMETER :: GaussRadau = 3 -INTEGER(I4B), PARAMETER :: GaussRadauLeft = 4 -INTEGER(I4B), PARAMETER :: GaussRadauRight = 5 -INTEGER(I4B), PARAMETER :: GaussLobatto = 6 -!! -INTEGER(I4B), PARAMETER :: GaussLegendre = 7 -INTEGER(I4B), PARAMETER :: GaussLegendreLobatto = 8 -INTEGER(I4B), PARAMETER :: GaussLegendreRadau = 9 -INTEGER(I4B), PARAMETER :: GaussLegendreRadauLeft = 10 -INTEGER(I4B), PARAMETER :: GaussLegendreRadauRight = 11 -!! -INTEGER(I4B), PARAMETER :: GaussChebyshev = 12 -INTEGER(I4B), PARAMETER :: GaussChebyshevRadau = 13 -INTEGER(I4B), PARAMETER :: GaussChebyshevRadauLeft = 14 -INTEGER(I4B), PARAMETER :: GaussChebyshevRadauRight = 15 -INTEGER(I4B), PARAMETER :: GaussChebyshevLobatto = 16 -!! -INTEGER(I4B), PARAMETER :: GaussJacobi = 17 -INTEGER(I4B), PARAMETER :: GaussJacobiRadau = 18 -INTEGER(I4B), PARAMETER :: GaussJacobiRadauLeft = 19 -INTEGER(I4B), PARAMETER :: GaussJacobiRadauRight = 20 -INTEGER(I4B), PARAMETER :: GaussJacobiLobatto = 21 -!! -INTEGER(I4B), PARAMETER :: GaussUltraspherical = 22 -INTEGER(I4B), PARAMETER :: GaussUltrasphericalRadau = 23 -INTEGER(I4B), PARAMETER :: GaussUltrasphericalRadauLeft = 24 -INTEGER(I4B), PARAMETER :: GaussUltrasphericalRadauRight = 25 -INTEGER(I4B), PARAMETER :: GaussUltrasphericalLobatto = 26 -!! -!! Type of quadrature points -!! -INTEGER(I4B), PARAMETER :: GaussQP = Gauss -INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre -INTEGER(I4B), PARAMETER :: GaussRadauQP = GaussRadau -INTEGER(I4B), PARAMETER :: GaussRadauLeftQP = GaussRadauLeft -INTEGER(I4B), PARAMETER :: GaussRadauRightQP = GaussRadauRight -INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto -INTEGER(I4B), PARAMETER :: GaussChebyshevQP = GaussChebyshev -!! -INTEGER(I4B), PARAMETER :: ChenBabuska = 22 !! for triangle nodes -INTEGER(I4B), PARAMETER :: Hesthaven = 23 !! for triangle nodes -INTEGER(I4B), PARAMETER :: Feket = 24 !! for triangle nodes -!! -INTEGER(I4B), PARAMETER :: BlythPozLegendre = 25 !! for triangle -INTEGER(I4B), PARAMETER :: BlythPozChebyshev = 26 !! for triangle -!! -INTEGER(I4B), PARAMETER :: IsaacLegendre = 27 !! for triangle -INTEGER(I4B), PARAMETER :: IsaacChebyshev = 28 !! for triangle -!! -!! Type of Lagrange Interpolation Points -!! -INTEGER(I4B), PARAMETER :: EquidistanceLIP = Equidistance -INTEGER(I4B), PARAMETER :: GaussLobattoLIP = GaussLobatto -INTEGER(I4B), PARAMETER :: GaussLegendreLIP = GaussLegendre -INTEGER(I4B), PARAMETER :: ChebyshevLIP = Chebyshev - -!! Types of Element domain -INTEGER(I4B), PARAMETER :: Line = MSH_LIN_2 -INTEGER(I4B), PARAMETER :: Line2 = Line -INTEGER(I4B), PARAMETER :: Line3 = MSH_LIN_3 -INTEGER(I4B), PARAMETER :: Line4 = MSH_LIN_4 -INTEGER(I4B), PARAMETER :: Line5 = MSH_LIN_5 -INTEGER(I4B), PARAMETER :: Line6 = MSH_LIN_6 -INTEGER(I4B), PARAMETER :: Line7 = MSH_LIN_7 -INTEGER(I4B), PARAMETER :: Line8 = MSH_LIN_8 -INTEGER(I4B), PARAMETER :: Line9 = MSH_LIN_9 -INTEGER(I4B), PARAMETER :: Line10 = MSH_LIN_10 -INTEGER(I4B), PARAMETER :: Line11 = MSH_LIN_11 - -INTEGER(I4B), PARAMETER :: Triangle = MSH_TRI_3 -INTEGER(I4B), PARAMETER :: Triangle3 = MSH_TRI_3 -INTEGER(I4B), PARAMETER :: Triangle6 = MSH_TRI_6 -INTEGER(I4B), PARAMETER :: Triangle9 = MSH_TRI_9 -INTEGER(I4B), PARAMETER :: Triangle10 = MSH_TRI_10 -INTEGER(I4B), PARAMETER :: Triangle12 = MSH_TRI_12 -INTEGER(I4B), PARAMETER :: Triangle15a = MSH_TRI_15 -INTEGER(I4B), PARAMETER :: Triangle15b = MSH_TRI_15I -INTEGER(I4B), PARAMETER :: Triangle15 = MSH_TRI_15 -INTEGER(I4B), PARAMETER :: Triangle18 = MSH_TRI_18 -INTEGER(I4B), PARAMETER :: Triangle21 = MSH_TRI_21 -INTEGER(I4B), PARAMETER :: Triangle21a = MSH_TRI_21 -INTEGER(I4B), PARAMETER :: Triangle21b = MSH_TRI_21I -INTEGER(I4B), PARAMETER :: Triangle24 = MSH_TRI_24 -INTEGER(I4B), PARAMETER :: Triangle27 = MSH_TRI_27 -INTEGER(I4B), PARAMETER :: Triangle28 = MSH_TRI_28 -INTEGER(I4B), PARAMETER :: Triangle30 = MSH_TRI_30 -INTEGER(I4B), PARAMETER :: Triangle36 = MSH_TRI_36 -INTEGER(I4B), PARAMETER :: Triangle45 = MSH_TRI_45 -INTEGER(I4B), PARAMETER :: Triangle55 = MSH_TRI_55 -INTEGER(I4B), PARAMETER :: Triangle66 = MSH_TRI_66 - -INTEGER(I4B), PARAMETER :: Quadrangle = MSH_QUA_4 -INTEGER(I4B), PARAMETER :: Quadrangle16 = MSH_QUA_16 -INTEGER(I4B), PARAMETER :: Quadrangle16a = MSH_QUA_16 -INTEGER(I4B), PARAMETER :: Quadrangle16b = MSH_QUA_16I -INTEGER(I4B), PARAMETER :: Quadrangle20 = MSH_QUA_20 -INTEGER(I4B), PARAMETER :: Quadrangle24 = MSH_QUA_24 -INTEGER(I4B), PARAMETER :: Quadrangle25 = MSH_QUA_25 -INTEGER(I4B), PARAMETER :: Quadrangle28 = MSH_QUA_28 -INTEGER(I4B), PARAMETER :: Quadrangle32 = MSH_QUA_32 -INTEGER(I4B), PARAMETER :: Quadrangle36 = MSH_QUA_36 -INTEGER(I4B), PARAMETER :: Quadrangle36a = MSH_QUA_36 -INTEGER(I4B), PARAMETER :: Quadrangle36b = MSH_QUA_36I -INTEGER(I4B), PARAMETER :: Quadrangle40 = MSH_QUA_40 -INTEGER(I4B), PARAMETER :: Quadrangle49 = MSH_QUA_49 -INTEGER(I4B), PARAMETER :: Quadrangle64 = MSH_QUA_64 -INTEGER(I4B), PARAMETER :: Quadrangle81 = MSH_QUA_81 -INTEGER(I4B), PARAMETER :: Quadrangle4 = MSH_QUA_4 -INTEGER(I4B), PARAMETER :: Quadrangle8 = MSH_QUA_8 -INTEGER(I4B), PARAMETER :: Quadrangle9 = MSH_QUA_9 -INTEGER(I4B), PARAMETER :: Quadrangle100 = MSH_QUA_100 -INTEGER(I4B), PARAMETER :: Quadrangle121 = MSH_QUA_121 - -!! Forder order 4, 5, and so on, we use 1601, 1602, 1603, etc. -INTEGER(I4B), PARAMETER :: Tetrahedron = 4 -INTEGER(I4B), PARAMETER :: Tetrahedron4 = 4 -INTEGER(I4B), PARAMETER :: Tetrahedron10 = 11 -INTEGER(I4B), PARAMETER :: Tetrahedron20 = 29 -INTEGER(I4B), PARAMETER :: Tetrahedron35 = 30 -INTEGER(I4B), PARAMETER :: Tetrahedron56 = 31 -INTEGER(I4B), PARAMETER :: Hexahedron = 5 -INTEGER(I4B), PARAMETER :: Hexahedron8 = 5 -INTEGER(I4B), PARAMETER :: Hexahedron27 = 12 -INTEGER(I4B), PARAMETER :: Hexahedron20 = 17 -INTEGER(I4B), PARAMETER :: Hexahedron64 = 92 -INTEGER(I4B), PARAMETER :: Hexahedron125 = 93 -INTEGER(I4B), PARAMETER :: Prism = 6 -INTEGER(I4B), PARAMETER :: Prism6 = 6 -INTEGER(I4B), PARAMETER :: Prism18 = 13 -INTEGER(I4B), PARAMETER :: Prism15 = 18 -INTEGER(I4B), PARAMETER :: Pyramid = 7 -INTEGER(I4B), PARAMETER :: Pyramid5 = 7 -INTEGER(I4B), PARAMETER :: Pyramid14 = 14 -INTEGER(I4B), PARAMETER :: Pyramid13 = 19 -INTEGER(I4B), PARAMETER :: Point = 15 -INTEGER(I4B), PARAMETER :: Point1 = 15 -INTEGER(I4B), PARAMETER :: Line1 = 15 -! Read material data from ? -INTEGER(I4B), PARAMETER :: PhysicalTag = 1 -INTEGER(I4B), PARAMETER :: GeometryTag = 2 -! ScalarDOF -INTEGER(I4B), PARAMETER :: ScalarDOF = -1 - !! Following are used in ErrorHandling.F90 -INTEGER(I4B), PARAMETER, PUBLIC :: OPT_OPEN = 1 - !! Constant for file open used by fErr -INTEGER(I4B), PARAMETER, PUBLIC :: OPT_READ = 2 - !! Constant for file read used by fErr -INTEGER(I4B), PARAMETER, PUBLIC :: OPT_WRITE = 3 - !! Constant for file write used by fErr -INTEGER(I4B), PARAMETER, PUBLIC :: OPT_CLOSE = 4 - !! Constant for file close used by fErr -INTEGER(I4B), PARAMETER, PUBLIC :: OPT_ALLOC = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: OPT_DEALLOC = 2 -! for matrix conversion ( dense to dense ) -! element matrix storage may differ from global matrix storage format -INTEGER(I4B), PARAMETER, PUBLIC :: DofToNodes = 0 - !! It is used in [[RealVector_]] and [[RealMatrix_]] -INTEGER(I4B), PARAMETER, PUBLIC :: NONE = -1 - !! It is used in [[RealVector_]] and [[RealMatrix_]] -INTEGER(I4B), PARAMETER, PUBLIC :: NodesToDOF = 1 - !! It is used in [[RealVector_]] and [[RealMatrix_]] -INTEGER(I4B), PARAMETER, PUBLIC :: DOF_FMT = 0 -INTEGER(I4B), PARAMETER, PUBLIC :: NODES_FMT = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: FMT_DOF = 0 -INTEGER(I4B), PARAMETER, PUBLIC :: FMT_NODES = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: Matrix_ROW = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: Matrix_COLUMN = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: Matrix_DIAGONAL = 0 -INTEGER(I4B), PARAMETER, PUBLIC :: SMALL_MATRIX_ROW = 10 - !! Lenght of small matrix in row dimension -INTEGER(I4B), PARAMETER, PUBLIC :: SMALL_MATRIX_LEN_COL = 10 - !! Length of small matrix in column dimension -INTEGER(I4B), PARAMETER, PUBLIC :: SMALL_VECTOR_LEN = 100 - !! Length of small vector -INTEGER(I4B), PARAMETER, PUBLIC :: OMP_THREADS_FORKED = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: OMP_THREADS_JOINED = 2 -! Related to tensors -INTEGER(I4B), PARAMETER, PUBLIC :: SymTensor = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: SkewSymTensor = -1 -INTEGER(I4B), PARAMETER, PUBLIC :: GeneralTensor = 0 -INTEGER(I4B), PARAMETER, PUBLIC :: StressTypeVoigt = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: StrainTypeVoigt = -1 -INTEGER(I4B), PARAMETER, PUBLIC :: WithSpectral = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: WithoutSpectral = -1 -INTEGER(I4B), PARAMETER, PUBLIC :: SineLode = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: CosineLode = 0 -! Related to vectors, matrices, and linear solver -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CG = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BCG = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICG = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CGS = 3 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BCGSTAB = 4 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICGSTAB = 4 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BCGSTABL = 5 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICGSTABL = 5 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GPBICG = 6 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_TFQMR = 7 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_OMN = 8 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_FOM = 8 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_ORTHOMIN = 8 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GMRES = 9 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GMR = 9 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_JACOBI = 10 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GS = 11 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_SOR = 12 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICGSAFE = 13 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CR = 14 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICR = 15 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CRS = 16 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICRSTAB = 17 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GPBICR = 18 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICRSAFE = 19 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_FGMRES = 20 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_IDRS = 21 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_IDR1 = 22 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_MINRES = 23 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_COCG = 24 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_COCR = 25 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CGNR = 26 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CGN = 26 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_DBCG = 27 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_DBICG = 27 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_DQGMRES = 28 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_SUPERLU = 29 -! Precondition sides -INTEGER(I4B), PARAMETER :: NoPrecond = 0 -INTEGER(I4B), PARAMETER :: PrecondLeft = 1 -INTEGER(I4B), PARAMETER :: PrecondRight = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: NO_PRECONDITION = NoPrecond -INTEGER(I4B), PARAMETER, PUBLIC :: LEFT_PRECONDITION = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: RIGHT_PRECONDITION = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: LEFT_RIGHT_PRECONDITION = 3 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_NONE = NoPrecond -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_JACOBI = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILU = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_SSOR = 3 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_HYBRID = 4 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_IS = 5 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_SAINV = 6 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_SAAMG = 7 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUC = 8 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ADDS = 9 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUTP = 10 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUD = 11 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUDP = 12 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILU0 = 13 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUK = 14 -INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUT = 15 -! Linear solver/ linear algebra engines -INTEGER(I4B), PARAMETER, PUBLIC :: NATIVE_SERIAL = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: NATIVE_OMP = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: NATIVE_MPI = 3 -INTEGER(I4B), PARAMETER, PUBLIC :: PETSC = 4 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_SERIAL = 5 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_OMP = 6 -INTEGER(I4B), PARAMETER, PUBLIC :: LIS_MPI = 7 -! Constraint type -INTEGER(I4B), PARAMETER :: StrongBC = 1 -INTEGER(I4B), PARAMETER :: NitscheBC = 2 -INTEGER(I4B), PARAMETER :: LagrangeMultiplierBC = 3 -INTEGER(I4B), PARAMETER :: PenaltyBC = 4 -INTEGER(I4B), PARAMETER :: AugmentedBC = 5 -! Symmetric and Skewsymmertic Nitsche Formulation -INTEGER(I4B), PARAMETER :: SkewSymNitsch = 1, SymNitsche = 2 -CHARACTER(*), PARAMETER :: CHAR_BLANK = " " - !! Character representing a space symbol -CHARACTER(*), PARAMETER :: CHAR_BANG = "!" - !! Character representing a comment symbol -CHARACTER(*), PARAMETER :: CHAR_DOT = "." - !! Character representing a period -CHARACTER(*), PARAMETER :: CHAR_FSLASH = "/" - !! Character representing a forward slash -CHARACTER(*), PARAMETER :: CHAR_BSLASH = ACHAR(92) - !! Character representing a backward slash -CHARACTER(*), PARAMETER :: CHAR_COLON = ":" - !! Character representing a colon -#ifdef WIN32 -CHARACTER(*), PARAMETER :: CHAR_SLASH = CHAR_BSLASH - !! This is needed for doxygen to parse correctly - !! The slash symbol used by the file system - !! (BLASH for Windows, FSLASH for everything else) -#else -CHARACTER(*), PARAMETER :: CHAR_SLASH = CHAR_FSLASH - !! The slash symbol used by the file system - !! (BLASH for Windows, FSLASH for everything else) -#endif -CHARACTER(1), PUBLIC, PARAMETER :: CHAR_SPACE = ' ' - !! Character constant for a single space -CHARACTER(1), PUBLIC, PARAMETER :: CHAR_CR = CHAR(13) - !! Character constant for a carraige return -CHARACTER(1), PUBLIC, PARAMETER :: CHAR_LF = CHAR(10) - !! Character constant for a line feed -CHARACTER(2), PUBLIC, PARAMETER :: CHAR_LF2 = char_lf//char_lf - !! Character constant for a line feed -CHARACTER(3), PUBLIC, PARAMETER :: CHAR_LF3 = char_lf2//char_lf - !! Character constant for a line feed -CHARACTER(1), PUBLIC, PARAMETER :: CHAR_TAB = CHAR(9) - -INTEGER(I4B), PARAMETER, PUBLIC :: Constant = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: Space = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: Time = 3 -INTEGER(I4B), PARAMETER, PUBLIC :: SpaceTime = 4 -INTEGER(I4B), PARAMETER, PUBLIC :: SolutionDependent = 5 -INTEGER(I4B), PARAMETER, PUBLIC :: RandomSpace = 6 -!> -INTEGER(I4B), PARAMETER, PUBLIC :: Scalar = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: Vector = 2 -INTEGER(I4B), PARAMETER, PUBLIC :: Matrix = 3 -INTEGER(I4B), PARAMETER, PUBLIC :: Nodal = 1 -INTEGER(I4B), PARAMETER, PUBLIC :: Quadrature = 2 - -INTEGER(I4B), PARAMETER, PUBLIC :: MAX_CHUNK_SIZE = 1024 - -END MODULE GlobalData diff --git a/src/modules/Gnuplot/CMakeLists.txt b/src/modules/Gnuplot/CMakeLists.txt deleted file mode 100644 index 78b80f677..000000000 --- a/src/modules/Gnuplot/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ogpf.F90 -) \ No newline at end of file diff --git a/src/modules/Gnuplot/src/ogpf.F90 b/src/modules/Gnuplot/src/ogpf.F90 deleted file mode 100644 index ff86405a8..000000000 --- a/src/modules/Gnuplot/src/ogpf.F90 +++ /dev/null @@ -1,2662 +0,0 @@ -!------------------------------------------------------------------------------- -! GnuPlot Interface -!------------------------------------------------------------------------------- -! Purpose: Object Based Interface to GnuPlot from Fortran (ogpf) -! Platform: Windows XP/Vista/7/10 -! (It should work on other platforms, see the finalize_plot subroutine below) -! Language: Fortran 2003 and 2008 -! Requires: 1. Fortran 2003 compiler (e.g gfortran 5, IVF 12.1, ...) -! There is only two more features needs Fortran 2008 standard -! execute_command_line and passing internal function as argument. -! 2. gnuplot 5 and higher (other previous version can be used -! Author: Mohammad Rahmani -! Chem Eng Dep., Amirkabir Uni. of Tech -! Tehran, Ir -! url: aut.ac.ir/m.rahmani -! github: github.com/kookma -! email: m[dot]rahmani[at]aut[dot]ac[dot]ir -! -! -! Acknowledgement: -! Special thanks to Hagen Wierstorf (http://www.gnuplotting.org) -! For vluable codes and examples on using gnuplot -! Some examples and color palletes are provided by gnuplotting. -! - - -! Revision History - -! Revision 0.22 -! Date: Mar 9th, 2018 -! - a new procedure called use_extra_configuration is used to set general gnuplot settings -! - new type for labels (xlabel, ylabel, zlabel, title,...) -! - all lables now accept text color, font name, font size, rorate by degree -! - Secondary axes can use different scale (linear or logarithmic) -! - subroutine plot2d_matrix_vs_matrix(xmat,ymat) -! now plots a matrix columns ymat aganist another matrix column xmat -! - added more examples - -! Revision 0.21 -! Date: Mar 8th, 2018 -! - new axes to plot command to use secondary axes added! - - -! Revision: 0.20 -! Date: Feb 20th, 2018 -! - ogpf now supports animation for 2D and 3D plots -! - rewrite contour and surface plot -! - select_precision has been merged into ogpf -! - new add_script procedure replaced old script -! - new run_script procedure -! - writestring procedure removed -! - linespec for plor2d_matrix_vs_plot now is a single dynamic string -! - splot now uses datablok instead of inline data -! - meshgrid now support full grid vector -! - arange a numpy similar function to create a range in the form of [xa, xa+dx, xa+2*dx, ...] -! - new num2str routines - - - -! Revision: 0.19 -! Date: Jan 15th, 2018 -! - new contour plot procedure - - -! Revision: 0.18 -! Date: Dec 22th, 2017 -! Major revision -! - The dynamic string allocation of Fortran 2003 is used (some old compilers -! does not support this capability) -! - Multiple windows plot now supported -! - Multiplot now supported -! - Gnuplot script file extension is changed from .plt to .gp -! - Default window size (canvas) changed to 640x480 -! - Persist set to on (true) by default -! - A separate subroutine is used now to create the output file for gnuplot commands -! - A separate subroutine is used now to finalize the output - -! - - -! Revision: 0.17 -! Date: Dec 18th, 2017 -! Minor corrections -! - Correct the meshgrid for wrong dy calculation when ygv is sent by two elements. -! - Remove the subroutine ErrHandler (development postponed to future release) - - -! Revision: 0.16 -! Date: Feb 11th, 2016 -! Minor corrections -! Correct the lspec processing in plot2D_matrix_vs_vector -! Now, it is possible to send less line specification and gpf will cycle through lspec - -! Revision: 0.15 -! Date: Apr 20th, 2012 -! Minor corrections -! Use of select_precision module and working precision: wp - -! Revision: 0.14 -! Date: Mar 28th, 2012 -! Minor corrections -! Use of import keyboard and removing the Precision module -! Length of Title string increased by 80 chars - - -! Revision: 0.13 -! Date: Feb 12th, 2012 -! Minor corrections -! Added axis method which sets the axis limits for x-axis, y-axis and z-axis -! Added Precision module - - - -! Version: 0.12 -! Date: Feb 9th, 2012 -! Minor corrections -! New semilogx, semilogy, loglog methods -! New options method, allow to be called several times to set the gnuplot options - - - -! Version: 0.11 -! Date: Feb 9th, 2012 -! Minor corrections -! Use of NEWUINT specifier from Fortran 2008 -! Added configuration parameters -! Extra procedures have been removed -! Temporary file is now deleted using close(...,status='delete') - -! -! Version: 0.1 -! Date: Jan 5th, 2012 -! First object-based version - -MODULE OGPF -USE GlobalData, ONLY: wp=>DFP, sp=>Real32, dp=>Real64 -IMPLICIT NONE -PRIVATE -! Library information -CHARACTER(LEN=*), PARAMETER :: md_name = 'ogpf libray' -CHARACTER(LEN=*), PARAMETER :: md_rev = 'Rev. 0.22 of March 9th, 2018' -CHARACTER(LEN=*), PARAMETER :: md_lic = 'Licence: MIT' - -! ogpf Configuration parameters -! The terminal and font have been set for Windows operating system -! Correct to meet the requirements on other OS like Linux and Mac. -CHARACTER(LEN=*), PARAMETER :: gnuplot_term_type = 'wxt' -!! Output terminal -CHARACTER(LEN=*), PARAMETER :: gnuplot_term_font = 'verdana,10' -!! font -CHARACTER(LEN=*), PARAMETER :: gnuplot_term_size = '640,480' -!! '960,840' ! plot window size -CHARACTER(LEN=*), PARAMETER :: gnuplot_output_filename='ogpf_temp_script.gp' !! temporary file for output -!! extra configuration can be set using ogpf object - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! module procedure -! convert integer, real, double precision into string -INTERFACE num2str - MODULE PROCEDURE num2str_i4, num2str_r4, num2str_r8 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 0.22 -! tplabel is a structure for gnuplot labels including -! title, xlabel, x2label, ylabel, ... -INTEGER, PARAMETER, PRIVATE :: NOT_INITIALIZED = -32000 -TYPE TPLABEL - LOGICAL :: has_label = .false. - CHARACTER(LEN=:), ALLOCATABLE :: lbltext - CHARACTER(LEN=:), ALLOCATABLE :: lblcolor - CHARACTER(LEN=:), ALLOCATABLE :: lblfontname - INTEGER :: lblfontsize = NOT_INITIALIZED - INTEGER :: lblrotate = NOT_INITIALIZED -END TYPE TPLABEL - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! the gpf class implement the object for using gnuplot from fortran in a semi-interactive mode! -! the fortran actually do the job and write out the commands and data in a single file and then -! calls the gnuplot by shell command to plot the data - -TYPE, PUBLIC :: GPF - PRIVATE - !> 0.22 - TYPE(TPLABEL) :: tpplottitle - TYPE(TPLABEL) :: tpxlabel - TYPE(TPLABEL) :: tpx2label - TYPE(TPLABEL) :: tpylabel - TYPE(TPLABEL) :: tpy2label - TYPE(TPLABEL) :: tpzlabel - CHARACTER(LEN=:), ALLOCATABLE :: txtoptions - !! a long string to store all type of gnuplot options - CHARACTER(LEN=:), ALLOCATABLE :: txtscript - !! a long string to store gnuplot script - CHARACTER(LEN=:), ALLOCATABLE :: txtdatastyle - !! lines, points, linepoints - LOGICAL :: hasxrange = .false. - LOGICAL :: hasx2range = .false. - LOGICAL :: hasyrange = .false. - LOGICAL :: hasy2range = .false. - LOGICAL :: haszrange = .false. - LOGICAL :: hasoptions = .false. - LOGICAL :: hasanimation = .false. - LOGICAL :: hasfilename = .false. - LOGICAL :: hasfileopen = .false. - REAL(wp) :: xrange(2), yrange(2), zrange(2) - REAL(wp) :: x2range(2), y2range(2) - CHARACTER(len=8) :: plotscale - ! multiplot parameters - LOGICAL :: hasmultiplot = .false. - INTEGER :: multiplot_rows - INTEGER :: multiplot_cols - INTEGER :: multiplot_total_plots - ! animation - INTEGER :: pause_seconds = 0 - !! keep plot on screen for this value in seconds - INTEGER :: frame_number - !! frame number in animation - ! use for debugging and error handling - CHARACTER(LEN=:), ALLOCATABLE :: msg - !! Message from plot procedures - INTEGER :: status=0 - !!Status from plot procedures - INTEGER :: file_unit - !! file unit identifier - CHARACTER(LEN=:), ALLOCATABLE :: txtfilename - !! the name of physical file to write the gnuplot script - ! ogpf preset configuration (kind of gnuplot initialization) - LOGICAL :: preset_configuration = .true. - CONTAINS - PRIVATE - ! local private procedures - PROCEDURE, PASS, PRIVATE :: preset_gnuplot_config - PROCEDURE, PASS, PRIVATE :: plot2d_vector_vs_vector - PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_vector - PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_matrix - PROCEDURE, PASS, PRIVATE :: semilogxv - PROCEDURE, PASS, PRIVATE :: semilogxm - PROCEDURE, PASS, PRIVATE :: semilogyv - PROCEDURE, PASS, PRIVATE :: semilogym - PROCEDURE, PASS, PRIVATE :: loglogv - PROCEDURE, PASS, PRIVATE :: loglogm - !> 0.22 - PROCEDURE, PASS, PRIVATE :: set_label - ! public procedures - PROCEDURE, PASS, PUBLIC :: options => set_options - PROCEDURE, PASS, PUBLIC :: title => set_plottitle - PROCEDURE, PASS, PUBLIC :: xlabel => set_xlabel - PROCEDURE, PASS, PUBLIC :: x2label => set_x2label - PROCEDURE, PASS, PUBLIC :: ylabel => set_ylabel - PROCEDURE, PASS, PUBLIC :: y2label => set_y2label - PROCEDURE, PASS, PUBLIC :: zlabel => set_zlabel - PROCEDURE, PASS, PUBLIC :: axis => set_axis - PROCEDURE, PASS, PUBLIC :: axis_sc => set_secondary_axis - PROCEDURE, PASS, PUBLIC :: filename => set_filename - PROCEDURE, PASS, PUBLIC :: reset => reset_to_defaults - PROCEDURE, PASS, PUBLIC :: preset => use_preset_configuration - PROCEDURE, PASS, PUBLIC :: multiplot => sub_multiplot - GENERIC, PUBLIC :: plot => & - & plot2d_vector_vs_vector, & - & plot2d_matrix_vs_vector, & - & plot2d_matrix_vs_matrix - GENERIC, PUBLIC :: semilogx => semilogxv, semilogxm - GENERIC, PUBLIC :: semilogy => semilogyv, semilogym - GENERIC, PUBLIC :: loglog => loglogv, loglogm - PROCEDURE, PASS, PUBLIC :: surf => splot ! 3D surface plot - PROCEDURE, PASS, PUBLIC :: lplot => lplot3d ! 3D line plot - PROCEDURE, PASS, PUBLIC :: contour => cplot ! contour plot - PROCEDURE, PASS, PUBLIC :: fplot => function_plot - PROCEDURE, PASS, PUBLIC :: add_script => addscript - PROCEDURE, PASS, PUBLIC :: run_script => runscript - PROCEDURE, PASS, PUBLIC :: animation_start => sub_animation_start - PROCEDURE, PASS, PUBLIC :: animation_show => sub_animation_show -END TYPE GPF - -CONTAINS - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section One: Set/Get Methods for ogpf object - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine use_preset_configuration(this,flag) - !.............................................................................. - !Set a flag to tell ogpf if the customized gnuplot configuration should - !be used - !.............................................................................. - - class(gpf):: this - logical, intent(in) :: flag - - ! default is true - this%preset_configuration = flag - - end subroutine use_preset_configuration - - - - subroutine set_filename(this,string) - !.............................................................................. - !Set a file name for plot command output - !This file can be used later by gnuplot as an script file to reproduce the plot - !.............................................................................. - - class(gpf):: this - character(len=*), intent(in) :: string - - this%txtfilename = trim(string) - this%hasfilename = .true. - - end subroutine set_filename - - - subroutine set_options(this,stropt) - !.............................................................................. - ! Set the plot options. This is a very powerfull procedure accepts many types - ! of gnuplot command and customization - !.............................................................................. - - class(gpf):: this - character(len=*), intent(in) :: stropt - - if(.not.allocated(this%txtoptions))this%txtoptions='' - if (len_trim(this%txtoptions) == 0 ) then - this%txtoptions = '' ! initialize string - end if - if ( len_trim(stropt)>0 ) then - this%txtoptions = this%txtoptions // splitstr(stropt) - end if - - this%hasoptions=.true. - - end subroutine set_options - - - - - subroutine set_axis(this,rng) - !.............................................................................. - !Set the axes limits in form of [xmin, xmax, ymin, ymax, zmin, zmax] - !.............................................................................. - - class(gpf):: this - real(wp), intent(in) :: rng(:) - integer :: n - n=size(rng,dim=1) - select case(n) - case(2) !Only the range for x-axis has been sent - this%hasxrange=.true. - this%xrange=rng(1:2) - case(4) - this%hasxrange=.true. - this%hasyrange=.true. - this%xrange=rng(1:2) - this%yrange=rng(3:4) - case(6) - this%hasxrange=.true. - this%hasyrange=.true. - this%haszrange=.true. - this%xrange=rng(1:2) - this%yrange=rng(3:4) - this%zrange=rng(5:6) - case default - print*, 'gpf error: wrong axis range setting!' - return - end select - - end subroutine set_axis - - - subroutine set_secondary_axis(this,rng) - !.............................................................................. - !Set the secondary axes limits in form of [x2min, x2max, y2min, y2max] - !.............................................................................. - - class(gpf):: this - real(wp), intent(in) :: rng(:) - integer :: n - n=size(rng,dim=1) - select case(n) - case(2) !Only the range for x2-axis has been sent - this%hasx2range=.true. - this%x2range=rng(1:2) - case(4) - this%hasx2range=.true. - this%hasy2range=.true. - this%x2range=rng(1:2) - this%y2range=rng(3:4) - case default - print*, 'gpf error: wrong axis range setting!' - return - end select - - end subroutine set_secondary_axis - - - subroutine set_plottitle(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the plot title - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('plot_title', string, textcolor, font_size, font_name, rotate) - - end subroutine set_plottitle - - - subroutine set_xlabel(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the xlabel - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('xlabel', string, textcolor, font_size, font_name, rotate) - - end subroutine set_xlabel - - - subroutine set_x2label(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the x2label - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('x2label', string, textcolor, font_size, font_name, rotate) - - end subroutine set_x2label - - - subroutine set_ylabel(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the ylabel - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('ylabel', string, textcolor, font_size, font_name, rotate) - - end subroutine set_ylabel - - - - subroutine set_y2label(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the y2label - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('y2label', string, textcolor, font_size, font_name, rotate) - - end subroutine set_y2label - - - subroutine set_zlabel(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the zlabel - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('zlabel', string, textcolor, font_size, font_name, rotate) - - end subroutine set_zlabel - - - !> 0.22 - - subroutine set_label(this, lblname, lbltext, lblcolor, font_size, font_name, rotate) - !.............................................................................. - ! Set the text, color, font, size and rotation for labels including - ! title, xlabel, x2label, ylabel, .... - !.............................................................................. - - class(gpf):: this - character(len=*), intent(in) :: lblname - character(len=*), intent(in) :: lbltext - character(len=*), intent(in), optional :: lblcolor - character(len=*), intent(in), optional :: font_name - integer, optional :: font_size - integer, optional :: rotate - - ! local variable - type(tplabel) :: label - - label%has_label = .true. - label%lbltext = trim(lbltext) - - if (present(lblcolor)) then - label%lblcolor = lblcolor - end if - - if (present(font_name)) then - label%lblfontname = font_name - else - if(.not.allocated(label%lblfontname))then - label%lblfontname = '' - endif - end if - - if (present(font_size)) then - label%lblfontsize = font_size - end if - - if (present(rotate)) then - label%lblrotate = rotate - end if - - select case (lblname) - case ('xlabel') - this%tpxlabel = label - case ('x2label') - this%tpx2label = label - case ('ylabel') - this%tpylabel = label - case ('y2label') - this%tpy2label = label - case ('zlabel') - this%tpzlabel = label - case ('plot_title') - this%tpplottitle = label - end select - - - end subroutine set_label - - - - subroutine reset_to_defaults(this) - !.............................................................................. - !Reset all ogpf properties (params to their default values - !............................................................................... - class(gpf):: this - - this%preset_configuration = .true. - this%txtfilename = gnuplot_output_filename - - if (allocated(this%txtoptions)) deallocate(this%txtoptions) - if (allocated(this%txtscript)) deallocate(this%txtscript) - if (allocated(this%txtdatastyle)) deallocate(this%txtdatastyle) - if (allocated(this%msg)) deallocate(this%msg) - - this%hasoptions = .false. - - this%hasxrange = .false. - this%hasx2range = .false. - this%hasyrange = .false. - this%hasy2range = .false. - this%haszrange = .false. - - this%pause_seconds = 0 - this%status = 0 - this%hasanimation = .false. - this%hasfileopen = .false. - this%hasmultiplot = .false. - - this%plotscale = '' - this%tpplottitle%has_label =.false. - this%tpxlabel%has_label =.false. - this%tpx2label%has_label =.false. - this%tpylabel%has_label =.false. - this%tpy2label%has_label =.false. - this%tpzlabel%has_label =.false. - - - end subroutine reset_to_defaults - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Two: Main Plotting Routines - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine sub_multiplot(this, rows, cols) - !.............................................................................. - ! This subroutine sets flag and number of rows and columns in case - ! of multiplot layout - !.............................................................................. - - class(gpf):: this - integer, intent(in) :: rows - integer, intent(in) :: cols - - ! ogpf does not support multiplot in animation mode - if (this%hasanimation) then - print*, md_name // ': ogpf does not support animation in multiplot mode' - stop - end if - - ! set multiplot cols and rows - if (rows> 0 ) then - this%multiplot_rows = rows - else - - end if - if (cols > 0 ) then - this%multiplot_cols = cols - else - - end if - - ! set the multiplot layout flag and plot numbers - this%hasmultiplot = .true. - this%multiplot_total_plots = 0 - - ! create the ouput file for writting gnuplot script - call create_outputfile(this) - - - end subroutine sub_multiplot - - - subroutine plot2d_vector_vs_vector(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - !.............................................................................. - ! This procedure plots: - ! 1. A vector against another vector (xy plot) - ! 2. A vector versus its element indices (yi plot). - ! 3. Can accept up to 4 data sets as x,y pairs! - ! Arguments - ! xi, yi vectors of data series, - ! lsi a string maximum 80 characters containing the line specification, - ! legends, ... - ! axesi is the axes for plotting: secondary axes are x2, and y2 - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - - ! Local variables - !---------------------------------------------------------------------- - - integer:: nx1 - integer:: ny1 - integer:: nx2 - integer:: ny2 - integer:: nx3 - integer:: ny3 - integer:: nx4 - integer:: ny4 - integer:: number_of_plots - character(len=3):: plottype - integer:: i - character(len=80) :: pltstring(4) ! Four 80 characters string - - !Initialize variables - plottype = '' - pltstring = '' - - ! Check the input - nx1=size(x1) - if ((present(y1) )) then - ny1=size(y1) - if (checkdim(nx1,ny1)) then - plottype='xy1' - number_of_plots=1 - else - print*, md_name // ':plot2d_vector_vs_vector:' // 'length of x1 and y1 does not match' - return - end if - else !plot only x againest its element indices - plottype='xi' - number_of_plots=1 - end if - - !Process line spec and axes set for first data set if present - call process_linespec(1, pltstring(1), ls1, axes1) - - - if (present(x2) .and. present (y2)) then - nx2=size(x2) - ny2=size(y2) - if (checkdim(nx2,ny2)) then - plottype='xy2' - number_of_plots=2 - else - return - end if - !Process line spec for 2nd data set if present - call process_linespec(2, pltstring(2), ls2, axes2) - end if - - if (present(x3) .and. present (y3)) then - nx3=size(x3) - ny3=size(y3) - if (checkdim(nx3,ny3)) then - plottype='xy3' - number_of_plots=3 - else - return - end if - !Process line spec for 3rd data set if present - call process_linespec(3, pltstring(3), ls3, axes3) - end if - - if (present(x4) .and. present (y4)) then - nx4=size(x4) - ny4=size(y4) - if (checkdim(nx4,ny4)) then - plottype='xy4' - number_of_plots=4 - else - return - end if - !Process line spec for 4th data set if present - call process_linespec(4, pltstring(4), ls4, axes4) - end if - - - call create_outputfile(this) - - ! Write plot title, axis labels and other annotations - call processcmd(this) - - ! Write plot command and line styles and legend if any - if (number_of_plots ==1) then - write ( this%file_unit, '(a)' ) trim(pltstring(1)) - else - write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_plots-1) - write ( this%file_unit, '(a)' ) trim(pltstring(number_of_plots)) - end if - ! Write xy data into file - select case (plottype) - case ('xi') - call write_xydata(this%file_unit,nx1,x1) - case ('xy1') - call write_xydata(this%file_unit,nx1,x1,y1) - case ('xy2') - call write_xydata(this%file_unit,nx1,x1,y1) - call write_xydata(this%file_unit,nx2,x2,y2) - case ('xy3') - call write_xydata(this%file_unit,nx1,x1,y1) - call write_xydata(this%file_unit,nx2,x2,y2) - call write_xydata(this%file_unit,nx3,x3,y3) - case ('xy4') - call write_xydata(this%file_unit,nx1,x1,y1) - call write_xydata(this%file_unit,nx2,x2,y2) - call write_xydata(this%file_unit,nx3,x3,y3) - call write_xydata(this%file_unit,nx4,x4,y4) - end select - - !> Rev 0.2 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - - !: End of plot2D_vector_vs_vector - end subroutine plot2d_vector_vs_vector - - - - subroutine plot2d_matrix_vs_vector(this, xv,ymat, lspec) - !.............................................................................. - ! plot2D_matrix_vs_vector accepts a vector xv and a matrix ymat and plots - ! columns of ymat against xv. lspec is an optional array defines the line - ! specification for each data series. If a single element array is sent for - ! lspec then all series are plotted using the same linespec - !.............................................................................. - - implicit none - class(gpf):: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - !---------------------------------------------------------------------- - ! Local variables - integer:: nx - integer:: ny - integer:: ns - integer:: number_of_curves - integer:: i - integer:: j - integer:: ierr - character(len=80), allocatable :: pltstring(:), lst(:) - ! - - !******************************************************************************* - ! Check the input - nx=size(xv) - ny=size(ymat,dim=1) - if (.not. checkdim(nx,ny)) then - print*, md_name // ':plot2d_matrix_vs_vector:' // 'The length of arrays does not match' - return - end if - ! create the outfile to write the gnuplot script - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write plot command and line styles and legend if any - number_of_curves=size(ymat,dim=2) - allocate(pltstring(number_of_curves), stat=ierr) - if (ierr /=0) then - print*, 'allocation error' - return - end if - - ! assume no linespec is available - pltstring(1:number_of_curves) = '' - - if ( present(lspec) ) then - - call splitstring2array(lspec,lst,';') - ns = size(lst, dim=1) - - if (ns == number_of_curves) then - ! there is a linespec for each curve - pltstring = lst - elseif (ns < number_of_curves) then - ! not enough linespec - do i=1, ns - pltstring(i) = lst(i) - end do - else ! ns > number_of curves - print*, 'ogpf: plot2d_matrix_vs_vector: wrong number of linespec' - print*, 'semicolon ";" acts as delimiter, check the linespec' - end if - end if - - if ( present(lspec) ) then - - call process_linespec(1,pltstring(1),lst(1)) - ns=size(lst) - ! gpf will cylce through line specification, if number of specification passed - ! is less than number of plots - do i=1, number_of_curves - j=mod(i-1, ns) + 1 - call process_linespec(i, pltstring(i), lst(j)) - end do - else !No lspec is available - pltstring(1)=' plot "-" notitle,' - pltstring(2:number_of_curves-1)='"-" notitle,' - pltstring(number_of_curves)='"-" notitle' - end if - - ! Write plot command and line styles and legend if any - write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1) - write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves)) - - ! Write data into script file - do j=1, number_of_curves - do i = 1, nx - write ( this%file_unit, * ) xv(i),ymat(i,j) - end do - write ( this%file_unit, '(a)' ) 'e' !end of jth set of data - end do - - - !> Rev 0.2 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !Release memory - if (allocated(pltstring)) then - deallocate(pltstring) - end if - !: End of plot2D_matrix_vs_vector - end subroutine plot2d_matrix_vs_vector - - - - subroutine plot2d_matrix_vs_matrix(this, xmat,ymat, lspec) - !.............................................................................. - ! plot2D_matrix_vs_matrix accepts a matrix xmat and a matrix ymat and plots - ! columns of ymat against columns of xmat. lspec is an optional array defines - ! the line specification for each data series. If a single element array is - ! sent for lspec then all series are plotted using the same linespec - !.............................................................................. - - implicit none - class(gpf):: this - ! Input arrays - real(wp), intent(in) :: xmat(:,:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - !---------------------------------------------------------------------- - ! Local variables - integer:: mx, nx - integer:: my, ny - integer:: ns - integer:: number_of_curves - integer:: i - integer:: j - integer:: ierr - character(len=80), allocatable :: pltstring(:), lst(:) - ! - - !******************************************************************************* - ! Check the input - ! check number of rows - mx=size(xmat,dim=1) - my=size(ymat,dim=1) - if (.not. checkdim(mx,my)) then - print*, md_name // ':plot2d_matrix_vs_matrix:' // 'The length of arrays does not match' - return - end if - ! check number of rows - nx=size(xmat,dim=2) - ny=size(ymat,dim=2) - if (.not. checkdim(nx,ny)) then - print*, 'gpf error: The number of columns are different, check xmat, ymat' - return - end if - - - ! create the outfile to write the gnuplot script - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write plot command and line styles and legend if any - number_of_curves=size(ymat,dim=2) - allocate(pltstring(number_of_curves), stat=ierr) - if (ierr /=0) then - print*, 'allocation error' - return - end if - - ! assume no linespec is available - pltstring(1:number_of_curves) = '' - - if ( present(lspec) ) then - - call splitstring2array(lspec,lst,';') - ns = size(lst, dim=1) - - if (ns == number_of_curves) then - ! there is a linespec for each curve - pltstring = lst - elseif (ns < number_of_curves) then - ! not enough linespec - do i=1, ns - pltstring(i) = lst(i) - end do - else ! ns > number_of curves - print*, md_name // ': plot2d_matrix_vs_matrix:'//' wrong number of linespec' - print*, 'semicolon ";" acts as delimiter, check the linespec' - end if - end if - - if ( present(lspec) ) then - - call process_linespec(1,pltstring(1),lst(1)) - ns=size(lst) - ! gpf will cylce through line specification, if number of specification passed - ! is less than number of plots - do i=1, number_of_curves - j=mod(i-1, ns) + 1 - call process_linespec(i, pltstring(i), lst(j)) - end do - else !No lspec is available - pltstring(1)=' plot "-" notitle,' - pltstring(2:number_of_curves-1)='"-" notitle,' - pltstring(number_of_curves)='"-" notitle' - end if - - ! Write plot command and line styles and legend if any - write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1) - write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves)) - - ! Write data into script file - do j=1, number_of_curves - do i = 1, mx - write ( this%file_unit, * ) xmat(i,j),ymat(i,j) - end do - write ( this%file_unit, '(a)' ) 'e' !end of jth set of data - end do - - !> Rev 0.2 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !Release memory - if (allocated(pltstring)) then - deallocate(pltstring) - end if - !: End of plot2D_matrix_vs_vector - end subroutine plot2d_matrix_vs_matrix - - - subroutine splot(this, x, y, z, lspec, palette) - !.............................................................................. - ! splot create a surface plot - ! datablock is used instead of gnuplot inline file "-" - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x(:,:) - real(wp), intent(in), optional :: y(:,:) - real(wp), intent(in), optional :: z(:,:) - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: palette - - ! Local variables - !---------------------------------------------------------------------- - integer:: ncx - integer:: nrx - integer:: i - integer:: j - logical:: xyz_data - character(len=80):: pltstring - character(len=*), parameter :: datablock = '$xyz' - - pltstring='' - ! Check the input data - ncx=size(x,dim=2) - nrx=size(x,dim=1) - if (present(y) .and. present(z)) then - xyz_data=.true. - elseif (present(y)) then - print*, "gpf error: Z matrix was not sent to 3D plot routine" - return - else - xyz_data=.false. - end if - - ! set default line style for 3D plot, can be overwritten - this%txtdatastyle = 'lines' - ! create the script file for writting gnuplot commands and data - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write xy data into file - write ( this%file_unit, '(a)' ) '#data x y z' - ! Rev 0.20 - ! write the $xyz datablocks - write( this%file_unit, '(a)' ) datablock // ' << EOD' - if (xyz_data) then - do j=1,ncx - do i=1, nrx - write ( this%file_unit, * ) x(i,j), y(i,j), z(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - else !only Z has been sent (i.e. single matrix data) - do j=1,ncx - do i=1, nrx - write ( this%file_unit, * ) i, j, x(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - end if - - - !write the color palette into gnuplot script file - if (present(palette)) then - write ( this%file_unit, '(a)' ) color_palettes(palette) - write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec - end if - - - if ( present(lspec) ) then - if (hastitle(lspec)) then - pltstring='splot ' // datablock // ' ' // trim(lspec) - else - pltstring='splot ' // datablock // ' notitle '//trim(lspec) - end if - else - pltstring='splot ' // datablock // ' notitle ' - end if - - write ( this%file_unit, '(a)' ) trim(pltstring) - - - !> Rev 0.2: animation - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !: End of splot - end subroutine splot - - - subroutine cplot(this, x, y, z, lspec, palette) - !.............................................................................. - ! Rev 0.19 - ! cplot creates a contour plot based on the three dimensional data - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x(:,:) - real(wp), intent(in), optional :: y(:,:) - real(wp), intent(in), optional :: z(:,:) - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: palette - - ! Local variables - !---------------------------------------------------------------------- - - integer:: ncx - integer:: nrx - integer:: i - integer:: j - logical:: xyz_data - character(len=80):: pltstring - character(len=*), parameter :: datablock = '$xyz' - ! character(len=*), parameter :: cntr_table = '$xyz_contour' - - pltstring='' - ! Check the input data - ncx=size(x,dim=2) - nrx=size(x,dim=1) - if (present(y) .and. present(z)) then - xyz_data=.true. - elseif (present(y)) then - print*, "gpf error: Z matrix was not sent to 3D plot routine" - return - else - xyz_data=.false. - end if - - ! set default line style for 3D plot, can be overwritten - this%txtdatastyle = 'lines' - ! create the script file for writting gnuplot commands and data - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write xy data into file - write ( this%file_unit, '(a)' ) '#data x y z' - ! write the $xyz datablocks - write( this%file_unit, '(a)' ) datablock // ' << EOD' - if (xyz_data) then - do j=1,ncx - do i=1, nrx - write ( this%file_unit, fmt=* ) x(i,j), y(i,j), z(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - else !only Z has been sent (i.e. single matrix data) - do j=1,ncx - do i=1, nrx - write ( this%file_unit, fmt=* ) i, j, x(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - end if - - - ! create the contour lines - write ( this%file_unit, '(a)' ) ! empty line - write ( this%file_unit, '(a)' ) '# create the contour' - write ( this%file_unit, '(a)' ) 'set contour base' - write ( this%file_unit, '(a)' ) 'set cntrparam levels 14' - write ( this%file_unit, '(a)' ) 'unset surface' - write ( this%file_unit, '(a)' ) 'set view map' - - - !write the color palette into gnuplot script file - if (present(palette)) then - write ( this%file_unit, '(a)' ) color_palettes(palette) - write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec - end if - - - write ( this%file_unit, '(a)' ) ! empty line - - if ( present(lspec) ) then - if (hastitle(lspec)) then - pltstring='splot ' // datablock // ' ' // trim(lspec) - else - pltstring='splot ' // datablock // ' notitle '//trim(lspec) - end if - else - pltstring='splot ' // datablock // ' notitle ' - end if - - write ( this%file_unit, '(a)' ) trim(pltstring) - - !> Rev 0.20 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !: End of cplot - end subroutine cplot - - subroutine lplot3d(this, x, y, z, lspec, palette) - !.............................................................................. - ! lplot3d create a line plot in 3d - ! datablock is used instead of gnuplot inline file "-" - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x(:) - real(wp), intent(in), optional :: y(:) - real(wp), intent(in), optional :: z(:) - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: palette - - ! Local variables - !---------------------------------------------------------------------- - integer:: ncx - integer:: nrx - integer:: i - integer:: j - logical:: xyz_data - character(len=80):: pltstring - character(len=*), parameter :: datablock = '$xyz' - - pltstring='' - ! Check the input data - nrx=size(x) - if (present(y) .and. present(z)) then - xyz_data=.true. - elseif (present(y)) then - print*, "gpf error: Z matrix was not sent to 3D plot routine" - return - else - xyz_data=.false. - end if - - ! set default line style for 3D plot, can be overwritten - this%txtdatastyle = 'lines' - ! create the script file for writing gnuplot commands and data - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write xy data into file - write ( this%file_unit, '(a)' ) '#data x y z' - ! Rev 0.20 - ! write the $xyz datablocks - write( this%file_unit, '(a)' ) datablock // ' << EOD' - if (xyz_data) then - do i=1, nrx - write ( this%file_unit, * ) x(i), y(i), z(i) - enddo - write( this%file_unit, '(a)' ) !put an empty line - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - else !only Z has been sent (i.e. single matrix data) - do i=1, nrx - write ( this%file_unit, * ) i, x(i) - enddo - write( this%file_unit, '(a)' ) !put an empty line - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - end if - - - !write the color palette into gnuplot script file - if (present(palette)) then - write ( this%file_unit, '(a)' ) color_palettes(palette) - write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec - end if - - - if ( present(lspec) ) then - if (hastitle(lspec)) then - pltstring='splot ' // datablock // ' ' // trim(lspec) // 'with lines' - else - pltstring='splot ' // datablock // ' notitle '//trim(lspec) // 'with lines' - end if - else - pltstring='splot ' // datablock // ' notitle with lines' - end if - - write ( this%file_unit, '(a)' ) trim(pltstring) - - - !> Rev 0.2: animation - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !: End of lplot3d - end subroutine lplot3d - - subroutine function_plot(this, func,xrange,np) - !.............................................................................. - ! fplot, plot a function in the range xrange=[xmin, xamx] with np points - ! if np is not sent, then np=50 is assumed! - ! func is the name of function to be plotted - !.............................................................................. - - class(gpf):: this - interface - function func(x) - import :: wp - real(wp), intent(in) :: x - real(wp) :: func - end function func - end interface - real(wp), intent(in) :: xrange(2) - integer, optional, intent(in):: np - - integer:: n - integer:: i - integer:: alloc_err - real(wp), allocatable :: x(:) - real(wp), allocatable :: y(:) - - if (present(np)) then - n=np - else - n=50 - end if - allocate(x(1:n), y(1:n), stat=alloc_err) - if (alloc_err /=0) then - stop "Allocation error in fplot procedure..." - end if - !Create set of xy data - x=linspace(xrange(1),xrange(2), n) - y=[ (func(x(i)), i=1, n) ] - - call plot2d_vector_vs_vector(this,x,y) - - ! cleanup memory - if (allocated(x)) deallocate(x) - if (allocated(y)) deallocate(y) - - - end subroutine function_plot - - - subroutine semilogxv(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - !.............................................................................. - ! This procedure is the same as plotXY with logarithmic x1 and x2 axes - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - this%plotscale='semilogx' - call plot2d_vector_vs_vector(this, & - x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - end subroutine semilogxv - - - !.............................................................................. - subroutine semilogyv(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4,axes4 ) - !.............................................................................. - ! This procedure is the same as plotXY with logarithmic y1 and y2 axes - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - - this%plotscale='semilogy' - call plot2d_vector_vs_vector(this, & - x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine semilogyv - - - - subroutine loglogv(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - !.............................................................................. - ! This procedure is the same as plotXY with logarithmic x1, y1, x2, y2 axes - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - - - this%plotscale='loglog' - call plot2d_vector_vs_vector(this, & - x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - end subroutine loglogv - - - - subroutine semilogxm(this, xv, ymat, lspec) - !.............................................................................. - !Plots a matrix against a vector with logarithmic x-axis - !For more information see plot2D_matrix_vs_vector procedure - !Everything is the same except the x-axis scale - !.............................................................................. - - implicit none - class(gpf) :: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - - this%plotscale='semilogx' - call plot2d_matrix_vs_vector(this, xv,ymat, lspec) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine semilogxm - - - - subroutine semilogym(this, xv,ymat, lspec) - !.............................................................................. - !Plots a matrix against a vector with logarithmic y-axis - !For more information see plot2D_matrix_vs_vector procedure - !Everything is the same except the x-axis scale - !.............................................................................. - - implicit none - class(gpf) :: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - - this%plotscale='semilogy' - call plot2d_matrix_vs_vector(this, xv,ymat, lspec) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine semilogym - - - subroutine loglogm(this, xv,ymat, lspec) - !.............................................................................. - !Plots a matrix against a vector with logarithmic x-axis and y-axis - !For more information see plot2D_matrix_vs_vector procedure - !Everything is the same except the axes scale - !.............................................................................. - - implicit none - class(gpf) :: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - - this%plotscale='loglog' - call plot2d_matrix_vs_vector(this, xv,ymat, lspec) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine loglogm - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Three: Animation Routines - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine sub_animation_start(this, pause_seconds) - !------------------------------------------------------------------------------- - ! sub_animation_start: set the setting to start an animation - ! it simply set flags and open a script file to write data - !------------------------------------------------------------------------------- - class(gpf) :: this - integer, intent(in), optional :: pause_seconds - - - ! ogpf does not support multiplot with animation at the same time - if (this%hasmultiplot) then - print*, md_name // ': does not support animation in multiplot mode!' - stop - end if - - - if (present(pause_seconds)) then - this%pause_seconds = pause_seconds - else - this%pause_seconds = 2 ! delay in second - end if - - this%frame_number = 0 - - ! create the ouput file for writting gnuplot script - call create_outputfile(this) - this%hasfileopen = .true. - this%hasanimation = .true. - - end subroutine sub_animation_start - - - subroutine sub_animation_show(this) - !------------------------------------------------------------------------------- - ! sub_animation_show: simply resets the animation flags - ! and finalize the plotting. - !------------------------------------------------------------------------------- - - class(gpf) :: this - - this%frame_number = 0 - this%hasanimation = .false. - - call finalize_plot(this) - - end subroutine sub_animation_show - - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Four: Gnuplot direct scriptting - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine addscript(this,strcmd) - !.............................................................................. - ! addscript: accepts all type of gnuplot command as a string and store it - ! in global txtscript to be later sent to gnuplot - !.............................................................................. - - class(gpf) :: this - character(len=*), intent(in) :: strcmd - - if (.not.allocated(this%txtscript)) this%txtscript='' - if (len_trim(this%txtscript) == 0 ) then - this%txtscript = '' ! initialize string - end if - if ( len_trim(strcmd)>0 ) then - this%txtscript = this%txtscript // splitstr(strcmd) - end if - - end subroutine addscript - - - - subroutine runscript(this) - !.............................................................................. - ! runscript sends the the script string (txtstring) into a script - ! file to be run by gnuplot - !.............................................................................. - - class(gpf):: this - - !REV 0.18: a dedicated subroutine is used to create the output file - call create_outputfile(this) - - !write the script - call processcmd(this) - write(unit=this%file_unit, fmt='(a)') this%txtscript - - ! close the file and call gnuplot - call finalize_plot(this) - - end subroutine runscript - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Five: gnuplot command processing and data writing to script file - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - subroutine process_axes_set(axes_set, axes) - !.............................................................................. - ! process_axesspec accepts the axes set and interpret it into - ! a format to be sent to gnuplot. - ! the axes set can be one of the following set - ! x1y1, x1y2, x2y1, x2y2 - !.............................................................................. - - character(len=*), intent(in) :: axes_set - character(len=4), intent(out) :: axes - - - if (len_trim (adjustl(axes_set)) == 0) then - axes='' - return - end if - - select case ( lcase(trim (adjustl (axes_set) ) ) ) - case ('x1y1') - axes='x1y1' - case ('x1y2') - axes='x1y2' - case ('x2y1') - axes='x2y1' - case ('x2y2') - axes='x2y2' - case default ! wrong strings - print*, md_name // ':process_axes_set:' // ' wrong axes set is sent.'// new_line(' ') & - // 'axes set can be on of: x1y1, x1y2, x2y1, x2y2' - axes='' - return - end select - - end subroutine process_axes_set - - - - subroutine process_linespec(order, lsstring, lspec, axes_set) - !.............................................................................. - ! process_linespec accepts the line specification and interpret it into - ! a format to be sent to gnuplot - !.............................................................................. - - integer, intent(in) :: order !1 for the first data series - character(len=*), intent(out) :: lsstring - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: axes_set - - !local variables - character(len=4) :: axes - character(len=10) :: axes_setting - - !check the axes set - axes_setting = '' - if ( present (axes_set)) then - call process_axes_set(axes_set, axes) - if (len(trim(axes))> 0 ) then - axes_setting = ' axes ' // axes - end if - end if - - select case(order) - case(1) - if ( present(lspec) ) then - if (hastitle(lspec)) then - lsstring='plot "-" '//trim(lspec) // axes_setting - else - lsstring='plot "-" notitle '//trim(lspec) // axes_setting - end if - else - lsstring='plot "-" notitle' // axes_setting - end if - case default !e.g. 2, 3, 4, ... - if (present(lspec)) then - if (hastitle(lspec)) then - lsstring=', "-" '// trim(lspec) // axes_setting - else - lsstring=', "-" notitle '// trim(lspec) // axes_setting - end if - else - lsstring=', "-" notitle' // axes_setting - end if - end select - end subroutine process_linespec - - - - subroutine processcmd(this) - !.............................................................................. - ! This subroutine writes all the data into plot file - ! to be read by gnuplot - !.............................................................................. - - class(gpf) :: this - - ! write the plot style for data - ! this is used only when 3D plots (splot, cplot) is used - if (allocated(this%txtdatastyle)) then - write ( this%file_unit, '("set style data ", a)' ) this%txtdatastyle - write ( this%file_unit, '(a)' ) - end if - - - ! Write options - if ( this%hasoptions ) then - write ( this%file_unit, '(" ")' ) - write ( this%file_unit, '("# options")' ) - write ( this%file_unit, '(a)' ) this%txtoptions - write ( this%file_unit, '(a)' ) - end if - - ! Check with plot scale: i.e linear, logx, logy, or log xy - write( this%file_unit, '(" ")' ) - write( this%file_unit, '("# plot scale")' ) - select case (this%plotscale) - case ('semilogx') - write ( this%file_unit, '("set logscale x")' ) - case ('semilogy') - write ( this%file_unit, '("set logscale y")' ) - case ('loglog') - write ( this%file_unit, '("set logscale xy")' ) - case default !for no setting - !pass - end select - - !!>0.22 - ! write annotation - write ( this%file_unit, '(" ")' ) - write ( this%file_unit, '("# Annotation: title and labels")' ) - call write_label(this, 'plot_title') - call write_label(this, 'xlabel' ) - call write_label(this, 'x2label' ) - call write_label(this, 'ylabel' ) - call write_label(this, 'y2label' ) - call write_label(this, 'zlabel' ) - - ! axes range - write ( this%file_unit, '(" ")') - write ( this%file_unit, '("# axes setting")') - if (this%hasxrange) then - write ( this%file_unit, '("set xrange [",G0,":",G0,"]")' ) this%xrange - end if - if (this%hasyrange) then - write ( this%file_unit, '("set yrange [",G0,":",G0,"]")' ) this%yrange - end if - if (this%haszrange) then - write ( this%file_unit, '("set zrange [",G0,":",G0,"]")' ) this%zrange - end if - - ! secondary axes range - if (this%hasx2range) then - write ( this%file_unit, '("set x2range [",G0,":",G0,"]")' ) this%x2range - end if - if (this%hasy2range) then - write ( this%file_unit, '("set y2range [",G0,":",G0,"]")' ) this%y2range - end if - ! finish by new line - write ( this%file_unit, '(a)' ) ! emptyline - - end subroutine processcmd - - - - subroutine write_label(this, lblname) - !.............................................................................. - ! This subroutine writes the labels into plot file - ! to be read by gnuplot - !.............................................................................. - - - ! write_label - class(gpf) :: this - character(len=*) :: lblname - - ! local var - character(len=:), allocatable :: lblstring - character(len=:), allocatable :: lblset - type(tplabel) :: label - - select case (lblname) - case ('xlabel') - if (.not. (this%tpxlabel%has_label) ) then - return ! there is no label - end if - lblset = 'set xlabel "' - label = this%tpxlabel - case ('x2label') - if (.not. (this%tpx2label%has_label) ) then - return ! there is no label - end if - lblset = 'set x2label "' - label = this%tpx2label - case ('ylabel') - if (.not. (this%tpylabel%has_label) ) then - return ! there is no label - end if - lblset = 'set ylabel "' - label = this%tpylabel - case ('y2label') - if (.not. (this%tpy2label%has_label) ) then - return ! there is no label - end if - lblset = 'set y2label "' - label = this%tpy2label - case ('zlabel') - if (.not. (this%tpzlabel%has_label) ) then - return ! there is no label - end if - lblset = 'set zlabel "' - label = this%tpzlabel - case ('plot_title') - if (.not. (this%tpplottitle%has_label) ) then - return ! there is no label - end if - lblset = 'set title "' - label = this%tpplottitle - end select - - lblstring = '' - ! if there is a label continue to set it - lblstring = lblstring // lblset // trim(label%lbltext)//'"' - if (allocated(label%lblcolor)) then - lblstring = lblstring // ' tc "' //trim(label%lblcolor) // '"' - end if - ! set font and size - if (allocated(this%tpxlabel%lblfontname)) then - lblstring = lblstring // ' font "'// trim(label%lblfontname) // ',' - if (label%lblfontsize /= NOT_INITIALIZED) then - lblstring = lblstring // num2str(label%lblfontsize) //'"' - else - lblstring = lblstring //'"' - end if - else ! check if only font size has been given - if (label%lblfontsize /= NOT_INITIALIZED ) then - lblstring = lblstring // ' font ",' // num2str(label%lblfontsize) //'"' - end if - end if - ! set rotation - if (label%lblrotate /= NOT_INITIALIZED ) then - lblstring = lblstring // ' rotate by ' // num2str(label%lblrotate ) - end if - - - ! write to ogpf script file - write ( this%file_unit, '(a)' ) lblstring - - - end subroutine write_label - - - - function color_palettes(palette_name) result(str) - !............................................................................... - ! color_palettes create color palette as a - ! string to be written into gnuplot script file - ! the palettes credit goes to: Anna Schnider (https://github.com/aschn) and - ! Hagen Wierstorf (https://github.com/hagenw) - !............................................................................... - character(len=*), intent(in) :: palette_name - character(len=:), allocatable :: str - - ! local variables - character(len=1) :: strnumber - character(len=11) :: strblank - integer :: j - integer :: maxcolors - - ! define the color palettes - character(len=:), allocatable :: pltname - character(len=7) :: palette(9) ! palettes with maximum 9 colors - - maxcolors = 8 ! default number of discrete colors - palette='' - select case ( lcase(trim(adjustl(palette_name))) ) - case ('set1') - pltname='set1' - palette(1:maxcolors)=[& - "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", & - "#FF7F00", "#FFFF33", "#A65628", "#F781BF" ] - case ('set2') - pltname='set2' - palette(1:maxcolors)=[& - "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", & - "#A6D854", "#FFD92F", "#E5C494", "#B3B3B3" ] - case ('set3') - pltname='set3' - palette(1:maxcolors)=[& - "#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072", & - "#80B1D3", "#FDB462", "#B3DE69", "#FCCDE5" ] - case ('palette1') - pltname='palette1' - palette(1:maxcolors)=[& - "#FBB4AE", "#B3CDE3", "#CCEBC5", "#DECBE4", & - "#FED9A6", "#FFFFCC", "#E5D8BD", "#FDDAEC" ] - case ('palette2') - pltname='palette2' - palette(1:maxcolors)=[& - "#B3E2CD", "#FDCDAC", "#CDB5E8", "#F4CAE4", & - "#D6F5C9", "#FFF2AE", "#F1E2CC", "#CCCCCC" ] - case ('paired') - pltname='paired' - palette(1:maxcolors)=[& - "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", & - "#FB9A99", "#E31A1C", "#FDBF6F", "#FF7F00" ] - case ('dark2') - pltname='dark2' - palette(1:maxcolors)=[& - "#1B9E77", "#D95F02", "#7570B3", "#E7298A", & - "#66A61E", "#E6AB02", "#A6761D", "#666666" ] - case ('accent') - pltname='accent' - palette(1:maxcolors)=[& - "#7FC97F", "#BEAED4", "#FDC086", "#FFFF99", & - "#386CB0", "#F0027F", "#BF5B17", "#666666" ] - case ('jet') - ! Matlab jet palette - maxcolors = 9 - pltname='jet' - palette(1:maxcolors)=[& - '#000090', '#000fff', '#0090ff', '#0fffee', & - '#90ff70', '#ffee00', '#ff7000', '#ee0000', '#7f0000' ] - case default - print*, md_name // ": color_palettes: wrong palette name" - print*, 'gnuplot default palette will be used!' - str=' ' ! empty palette is returned! - return - end select - - ! generate the gnuplot palette as a single multiline string - str = '# Define the ' // pltname // ' pallete' // new_line(' ') - str = str // 'set palette defined ( \' // new_line(' ') - strblank = ' ' ! pad certain number of paces - do j=1, maxcolors - 1 - write(unit =strnumber, fmt='(I1)' ) j-1 - str = str // strblank // strnumber // ' "' // palette(j) // '",\' // new_line(' ') - end do - - j =maxcolors - write(strnumber, fmt='(I1)') j - str = str // strblank // strnumber // ' "' // palette(j) // '" )' // new_line(' ') - - end function color_palettes - - - - subroutine write_xydata(file_unit,ndata,x,y) - !.............................................................................. - ! Writes set of xy data into a file - !.............................................................................. - - integer, intent(in) :: file_unit - integer, intent(in) :: ndata - real(wp), intent(in) :: x(:) - real(wp), intent(in), optional :: y(:) - - integer:: i - - ! TODO (Mohammad#1#12/22/17): The format string shall be modified to write the - ! number in more suitable form - ! Rev 0.18 - if (present(y) ) then !both x and y are present, data are xy set - do i = 1, ndata - write ( file_unit, * ) x(i), y(i) - end do - else !only x is passed, data are index-x set - do i = 1, ndata - write ( file_unit, * ) x(i) - end do - end if - write ( file_unit, '(a)' ) 'e' !end of set of data - - end subroutine write_xydata - - - - subroutine create_outputfile(this) - !.............................................................................. - ! Create an output file, assign a file_unit - ! for writing the gnuplot commands - !.............................................................................. - - ! Rev 0.18 - class(gpf), intent(INOUT ) :: this - - if (this%hasfileopen) then - ! there is nothing to do, file has been already open! - return - end if - - !> Rev 0.2 animation - - ! animation handling - if (this%hasanimation ) then - this%frame_number = this%frame_number + 1 ! for future use - end if - - ! Open the output file - - if (.not. (this%hasfilename)) then ! check if no file has been set by user - this%txtfilename=gnuplot_output_filename - end if - - open ( newunit = this%file_unit, file = this%txtfilename, status = 'replace', iostat = this%status ) - - - if (this%status /= 0 ) then - print*, "md_helperproc, create_outputfile: cannot open file for output" - stop - end if - - - ! Set the gnuplot terminal, write ogpf configuration (customized setting) - ! Can be overwritten by options - - ! write signature - write ( this%file_unit, '(a)' ) '# ' // md_name - write ( this%file_unit, '(a)' ) '# ' // md_rev - write ( this%file_unit, '(a)' ) '# ' // md_lic - write ( this%file_unit, '(a)' ) ! emptyline - - ! write the global settings - write ( this%file_unit, '(a)' ) '# gnuplot global setting' - write(unit=this%file_unit, fmt='(a)') 'set term ' // gnuplot_term_type // & - ' size ' // gnuplot_term_size // ' enhanced font "' // & - gnuplot_term_font // '"' // & - ' title "' // md_name // ': ' // md_rev //'"' ! library name and version - - ! write the preset configuration for gnuplot (ogpf customized settings) - if (this%preset_configuration) then - call this%preset_gnuplot_config() - end if - ! write multiplot setting - if (this%hasmultiplot) then - write(this%file_unit, fmt='(a, I2, a, I2)') 'set multiplot layout ', & - this%multiplot_rows, ',', this%multiplot_cols - end if - ! set flag true for file is opened - this%hasfileopen = .true. - - end subroutine create_outputfile - - - subroutine preset_gnuplot_config(this) - !.............................................................................. - ! To write the preset configuration for gnuplot (ogpf customized settings) - !.............................................................................. - class(gpf) :: this - - write(this%file_unit, fmt='(a)') - write(this%file_unit, fmt='(a)') '# ogpf extra configuration' - write(this%file_unit, fmt='(a)') '# -------------------------------------------' - - - ! color definition - write(this%file_unit, fmt='(a)') '# color definitions' - write(this%file_unit, fmt='(a)') 'set style line 1 lc rgb "#800000" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 2 lc rgb "#ff0000" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 3 lc rgb "#ff4500" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 4 lc rgb "#ffa500" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 5 lc rgb "#006400" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 6 lc rgb "#0000ff" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 7 lc rgb "#9400d3" lt 1 lw 2' - write(this%file_unit, fmt='(a)') - ! axes setting - write(this%file_unit, fmt='(a)') '# Axes' - write(this%file_unit, fmt='(a)') 'set border linewidth 1.15' - write(this%file_unit, fmt='(a)') 'set tics nomirror' - write(this%file_unit, fmt='(a)') - - write(this%file_unit, fmt='(a)') '# grid' - write(this%file_unit, fmt='(a)') '# Add light grid to plot' - write(this%file_unit, fmt='(a)') 'set style line 102 lc rgb "#d6d7d9" lt 0 lw 1' - write(this%file_unit, fmt='(a)') 'set grid back ls 102' - write(this%file_unit, fmt='(a)') - ! set the plot style - write(this%file_unit, fmt='(a)') '# plot style' - write(this%file_unit, fmt='(a)') 'set style data linespoints' - write(this%file_unit, fmt='(a)') - - write(this%file_unit, fmt='(a)') '# -------------------------------------------' - write(this%file_unit, fmt='(a)') '' - - - end subroutine preset_gnuplot_config - - - - subroutine finalize_plot(this) - !.............................................................................. - ! To finalize the writing of gnuplot commands/data and close the output file. - !.............................................................................. - class(gpf) :: this - - ! check for multiplots - if (this%hasmultiplot) then - if (this%multiplot_total_plots < this%multiplot_rows * this%multiplot_cols - 1 ) then - ! increment the number of plots - this%multiplot_total_plots = this%multiplot_total_plots + 1 - return ! do not finalize plot, still there is places in multiplot - else - ! close multiplot - write(this%file_unit, fmt='(a)') 'unset multiplot' - ! reset multiplot flag - this%hasmultiplot = .false. - - end if - end if - - close ( unit = this%file_unit ) ! close the script file - this%hasfileopen = .false. ! reset file open flag - this%hasanimation = .false. - ! Use shell command to run gnuplot - if (get_os_type() == 1) then - call execute_command_line ('wgnuplot -persist ' // this%txtfilename) ! Now plot the results - else - call execute_command_line ('gnuplot -persist ' // this%txtfilename) ! Now plot the results - end if - contains - integer function get_os_type() result(r) - !! Returns one of OS_WINDOWS, others - !! At first, the environment variable `OS` is checked, which is usually - !! found on Windows. - !! Copy from fpm/fpm_environment: https://github.com/fortran-lang/fpm/blob/master/src/fpm_environment.F90 - character(len=32) :: val - integer :: length, rc - - integer, parameter :: OS_OTHERS = 0 - integer, parameter :: OS_WINDOWS = 1 - - r = OS_OTHERS - ! Check environment variable `OS`. - call get_environment_variable('OS', val, length, rc) - - if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then - r = OS_WINDOWS - return - end if - - end function - - end subroutine finalize_plot - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Six: Utility and helper procedures - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - function hastitle(string) - !.............................................................................. - ! check to see if the plot title (used as legend = key) - !.............................................................................. - - character(len=*), intent(in) :: string - logical:: hastitle - integer:: idx1 - integer:: idx2 - - idx1=index( lcase(string),'title') !Check if title is passed - idx2=index(' ' // lcase(string),' t ') !Check if the abbreviated title 't' is passed. Extra space is added - ! at the beginning of string to find starting 't' - if (idx1 /=0 .or. idx2 /=0 ) then - hastitle=.true. - else - hastitle=.false. - end if - - end function hastitle - - - function checkdim(nx,ny) - !.............................................................................. - ! checkdim checks the equality of dimensions of two vector - !.............................................................................. - - integer, intent(in):: nx - integer, intent(in):: ny - logical:: checkdim - if (nx/=ny) then - checkdim=.false. - else - checkdim=.true. - end if - - end function checkdim - - - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !> Section Seven: String utility Routines - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - - pure function splitstr(str) result(spstr) - !.............................................................................. - !splitstr, separate a string using ";" delimiters - !.............................................................................. - - character(len=*), intent(in) :: str - - ! local variables - character, parameter :: delimiter=';' - character(len=:), allocatable :: spstr - integer :: n - integer :: m - integer :: k - - - k=len_trim(str) !length with removed trailing blanks - n=scan(str,delimiter) - if (n==0) then ! This is a single statement - spstr = adjustl(str) // new_line(' ') - return - end if - - ! for two or more statements separated by ; - spstr = '' - m=1 - do while (n/=0 .and. m=65 .and. n <= 90) then - lcase(i:i)=char(n+32) - else - lcase(i:i)=chr - end if - end do - end function lcase - - - function num2str_i4(number_in) - !.............................................................................. - ! num2str_int: converts integer number to string - !.............................................................................. - - integer(kind=kind(1)), intent(in) :: number_in - character(len=:), allocatable :: num2str_i4 - - ! local variable - character(len=range(number_in)) :: strnm - write(unit=strnm, fmt='(I0)') number_in - num2str_i4 = trim(strnm) - - end function num2str_i4 - - function num2str_r4(number_in, strfmt) - !.............................................................................. - ! num2str_r4: converts single precision real number to string - ! strfmt is the optional format string - !.............................................................................. - - real(kind=sp), intent(in) :: number_in - character(len=*), intent(in), optional :: strfmt - character(len=:), allocatable :: num2str_r4 - - ! local variable - character(len=range(number_in)) :: strnm - - - if (present(strfmt)) then - write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in - else - write(unit=strnm, fmt='(G0)') number_in - end if - - num2str_r4 = trim(strnm) - - end function num2str_r4 - - - function num2str_r8(number_in, strfmt) - !.............................................................................. - ! num2str_real: converts double precision real number to string - ! strfmt is the optional format string - !.............................................................................. - - real(kind=dp), intent(in) :: number_in - character(len=*), intent(in), optional :: strfmt - character(len=:), allocatable :: num2str_r8 - - ! local variable - character(len=range(number_in)) :: strnm - - if (present(strfmt)) then - write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in - else - write(unit=strnm, fmt='(G0)') number_in - end if - - num2str_r8 = trim(strnm) - - end function num2str_r8 - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Eight: Math helper function - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - function arange(xa, xb, dx) - !.............................................................................. - ! returns a vector in the form of [xa, xa+dx, xa+2*dx, ...] - ! the number of elements is calculated as m = n+ 1, - ! where n= int ( (xa-xb)/dx) ). - ! arange is similar to colon in Matlab and arange in Python! - ! - ! NOTE: - ! - If n calculated as zero, result is [xa] - ! - If n calculated as Inf (dx=0), a fatal error will be raised - ! - If n calculated as negative value (e.g xa 0.0 " - stop - end if - else - dxl = 1.0_wp - end if - - if ( (xa < xb) .and. (dx < 0.0_wp) ) then - print*, "arange procedure: Fatal Error: wrong dx, use a dx > 0.0 " - stop - end if - - n = int( (xb-xa)/ dxl) ! n+1 is the number of elements - - allocate(arange(n), stat=ierr) - - if (ierr /= 0) then - print*, "arange procedure: Fatal Error, allocation failed in arange function" - stop - end if - - arange = [(xa + i*dxl, i=0, n)] - - end function arange - - - function linspace(a,b,n_elements) - !.............................................................................. - ! returns a linearly spaced vector with n points in [a, b] - ! if n is omitted, 100 points will be considered - !.............................................................................. - - real(wp), intent(in) :: a - real(wp), intent(in) :: b - integer, intent(in), optional :: n_elements - real(wp), allocatable :: linspace(:) - - ! Local vars - real(wp) :: dx - integer :: i - integer :: n - integer :: ierr - - if (present(n_elements)) then - if (n_elements <=1 ) then - print*, "linspace procedure: Error: wrong value of n_elements, use an n_elements > 1" - stop - end if - n=n_elements - else - n=100 - end if - - allocate(linspace(n), stat=ierr) - if (ierr /= 0) then - print*, "linspace procedure: Fatal Error, Allocation failed in linspace function" - stop - end if - - dx=(b-a)/real((n-1),wp) - linspace=[(i*dx+a, i=0,n-1)] - - end function linspace - - - - subroutine meshgrid(x,y,xgv,ygv, ierr) - !.............................................................................. - !meshgrid generate mesh grid over a rectangular domain of [xmin xmax, ymin, ymax] - ! Inputs: - ! xgv, ygv are grid vectors in form of full grid data - ! Outputs: - ! X and Y are matrix each of size [ny by nx] contains the grid data. - ! The coordinates of point (i,j) is [X(i,j), Y(i,j)] - ! ierr: The error flag - ! """ - ! # Example - ! # call meshgrid(X, Y, [0.,1.,2.,3.],[5.,6.,7.,8.]) - ! # X - ! # [0.0, 1.0, 2.0, 3.0, - ! # 0.0, 1.0, 2.0, 3.0, - ! # 0.0, 1.0, 2.0, 3.0, - ! # 0.0, 1.0, 2.0, 3.0] - ! # - ! #Y - ! #[ 5.0, 5.0, 5.0, 5.0, - ! # 6.0, 6.0, 6.0, 6.0, - ! # 7.0, 7.0, 7.0, 7.0, - ! # 8.0, 8.0, 8.0, 8.0] - !.............................................................................. - ! Rev 0.2, Feb 2018 - ! New feature added: xgv and ygv as full grid vector are accepted now - - ! Arguments - real(wp), intent(out), allocatable :: x(:,:) - real(wp), intent(out), allocatable :: y(:,:) - real(wp), intent(in) :: xgv(:) ! x grid vector [start, stop, step] or [start, stop] - real(wp), intent(in), optional :: ygv(:) ! y grid vector [start, stop, step] or [start, stop] - integer, intent(out), optional :: ierr ! the error value - - ! Local variables - integer:: sv - integer:: nx - integer:: ny - logical:: only_xgv_available - - ! Initial setting - only_xgv_available = .false. - sv=0 !Assume no error - - nx=size(xgv, dim=1) - - if (present(ygv)) then - ny = size(ygv, dim=1) - else - only_xgv_available=.true. - ny=nx - end if - - allocate(x(ny,nx),y(ny,nx),stat=sv) - if (sv /=0) then - print*, "allocataion erro in meshgrid" - stop - end if - - x(1,:) = xgv - x(2:ny,:) = spread(xgv, dim=1, ncopies=ny-1) - - if (only_xgv_available) then - y=transpose(x) - else - y(:,1) = ygv - y(:,2:nx) = spread(ygv,dim=2,ncopies=nx-1) - end if - - if (present(ierr)) then - ierr=sv - end if - - end subroutine meshgrid - - - !End of ogpf -end module ogpf diff --git a/src/modules/Hashing/CMakeLists.txt b/src/modules/Hashing/CMakeLists.txt deleted file mode 100644 index 0d99ecce7..000000000 --- a/src/modules/Hashing/CMakeLists.txt +++ /dev/null @@ -1,23 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - "${src_path}/Hashing32.F90" -) \ No newline at end of file diff --git a/src/modules/Hashing/src/Hashing32.F90 b/src/modules/Hashing/src/Hashing32.F90 deleted file mode 100644 index 4af97335c..000000000 --- a/src/modules/Hashing/src/Hashing32.F90 +++ /dev/null @@ -1,315 +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 -! -! -! This code is taken from -! -! https://github.com/fortran-lang/stdlib/blob/master/src/stdlib_hash_32bit.fypp -! -! `FNV_1_HASH` and `FNV_1A_Hash` are translations to Fortran 2008 of the `FNV-1` -! and `FNV-1a` hash functions of Glenn Fowler, Landon Curt Noll, and Phong Vo, that -! has been released into the public domain. - -MODULE Hashing32 - -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: CHARACTER_STORAGE_SIZE -USE GlobalData, ONLY: I4B, LGT, dp, INT8, INT16, INT32, INT64 -USE GlobalData, ONLY: BITS_INT8 => BIInt8, BITS_INT16 => BIInt16, & - & BITS_INT32 => BIInt32, BITS_INT64 => BIInt64, & - & BYTES_INT8 => BYInt8, & - & BYTES_INT16 => BYInt16, & - & BYTES_INT32 => BYInt32, & - & BYTES_INT64 => BYInt64 -IMPLICIT NONE -PRIVATE - -INTEGER(I4B), PARAMETER, PUBLIC :: INT_HASH = INT32 -!! The number of bits in the output hash -INTEGER(I4B), PARAMETER :: POW32_OVER_PHI = INT(z'9E3779B9', INT32) -!! pow32_over_phi is the odd integer that most closely approximates -!! 2**32/phi, where phi is the golden ratio 1.618... -INTEGER(I4B), PARAMETER :: BITS_CHAR = CHARACTER_STORAGE_SIZE -INTEGER(I4B), PARAMETER :: BYTES_CHAR = BITS_CHAR / BITS_INT8 - -! Dealing with different endians -LOGICAL(LGT), PARAMETER, PUBLIC :: little_endian = & - & (1 == TRANSFER([1_INT8, 0_INT8], 0_INT16)) - -PUBLIC :: fibonacci_hash, odd_random_integer, universal_mult_hash -PUBLIC :: fnv_1_hash -PUBLIC :: fnv_1a_hash -PUBLIC :: nmhash32 -PUBLIC :: nmhash32x -PUBLIC :: new_water_hash_seed -PUBLIC :: water_hash -PUBLIC :: new_nmhash32_seed -PUBLIC :: new_nmhash32x_seed - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 July 2022 -! summary: FNV_1 hash function for rank 1 array keys of integers - -INTERFACE fnv_1_hash - MODULE PURE FUNCTION Int8_fnv_1(key) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int8_fnv_1 - - MODULE PURE FUNCTION Int16_fnv_1(key) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int16_fnv_1 - - MODULE PURE FUNCTION Int32_fnv_1(key) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int32_fnv_1 - - MODULE PURE FUNCTION Int64_fnv_1(key) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int64_fnv_1 - - MODULE PURE FUNCTION Char_fnv_1(key) RESULT(ans) - CHARACTER(*), INTENT(IN) :: key - INTEGER(INT_HASH) :: ans - END FUNCTION Char_fnv_1 -END INTERFACE fnv_1_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE fnv_1a_hash - MODULE PURE FUNCTION Int8_fnv_1a(key) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int8_fnv_1a - - MODULE PURE FUNCTION Int16_fnv_1a(key) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int16_fnv_1a - - MODULE PURE FUNCTION Int32_fnv_1a(key) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int32_fnv_1a - - MODULE PURE FUNCTION Int64_fnv_1a(key) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: key(:) - INTEGER(INT_HASH) :: ans - END FUNCTION Int64_fnv_1a - - MODULE PURE FUNCTION Char_fnv_1a(key) RESULT(ans) - CHARACTER(*), INTENT(IN) :: key - INTEGER(INT_HASH) :: ans - END FUNCTION Char_fnv_1a -END INTERFACE fnv_1a_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE nmhash32 - MODULE PURE FUNCTION Int8_nmhash32(key, seed) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int8_nmhash32 - MODULE PURE FUNCTION Int16_nmhash32(key, seed) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int16_nmhash32 - MODULE PURE FUNCTION Int32_nmhash32(key, seed) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int32_nmhash32 - MODULE PURE FUNCTION Int64_nmhash32(key, seed) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int64_nmhash32 - MODULE PURE FUNCTION Char_nmhash32(key, seed) RESULT(ans) - CHARACTER(*), INTENT(IN) :: key - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Char_nmhash32 -END INTERFACE nmhash32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE nmhash32x - MODULE PURE FUNCTION Int8_nmhash32x(key, seed) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int8_nmhash32x - MODULE PURE FUNCTION Int16_nmhash32x(key, seed) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int16_nmhash32x - MODULE PURE FUNCTION Int32_nmhash32x(key, seed) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int32_nmhash32x - MODULE PURE FUNCTION Int64_nmhash32x(key, seed) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: key(0:) - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int64_nmhash32x - MODULE PURE FUNCTION Char_nmhash32x(key, seed) RESULT(ans) - CHARACTER(*), INTENT(IN) :: key - INTEGER(INT32), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Char_nmhash32x -END INTERFACE nmhash32x - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE water_hash - MODULE PURE FUNCTION Int8_water_hash(key, seed) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: key(0:) - INTEGER(INT64), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int8_water_hash - MODULE PURE FUNCTION Int16_water_hash(key, seed) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: key(0:) - INTEGER(INT64), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int16_water_hash - MODULE PURE FUNCTION Int32_water_hash(key, seed) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: key(0:) - INTEGER(INT64), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int32_water_hash - MODULE PURE FUNCTION Int64_water_hash(key, seed) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: key(0:) - INTEGER(INT64), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Int64_water_hash - MODULE PURE FUNCTION Char_water_hash(key, seed) RESULT(ans) - CHARACTER(*), INTENT(IN) :: key - INTEGER(INT64), INTENT(IN) :: seed - INTEGER(INT_HASH) :: ans - END FUNCTION Char_water_hash -END INTERFACE water_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE new_water_hash_seed(seed) - INTEGER(INT64), INTENT(INOUT) :: seed - END SUBROUTINE new_water_hash_seed -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE new_nmhash32_seed(seed) - INTEGER(INT_HASH), INTENT(INOUT) :: seed - END SUBROUTINE new_nmhash32_seed -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE new_nmhash32x_seed(seed) - INTEGER(INT_HASH), INTENT(INOUT) :: seed - END SUBROUTINE new_nmhash32x_seed -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -!> author: Vikas Sharma, Ph. D. -! date: 25 July 2023 -! summary: Maps the 32 bit integer `key` to an unsigned integer value with -! only `nbits` bits where `nbits` is less than 32 - -ELEMENTAL FUNCTION fibonacci_hash(key, nbits) RESULT(sample) - INTEGER(INT32), INTENT(IN) :: key - INTEGER, INTENT(IN) :: nbits - INTEGER(INT32) :: sample - sample = ISHFT(key * pow32_over_phi, -32 + nbits) -END FUNCTION fibonacci_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 July 2022 -! summary: Universal mult hash -! -!# Introduction -! -! Uses the "random" odd 32 bit integer `seed` to map the 32 bit integer -! `key` to an unsigned integer value with only `nbits` bits where `nbits` is -! less than 32 - -ELEMENTAL FUNCTION universal_mult_hash(key, seed, nbits) RESULT(sample) - INTEGER(INT32), INTENT(IN) :: key - INTEGER(INT32), INTENT(IN) :: seed - INTEGER, INTENT(IN) :: nbits - INTEGER(INT32) :: sample - sample = ISHFT(key * seed, -32 + nbits) -END FUNCTION universal_mult_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 July 2022 -! summary: -! -!# Introduction -! -! Returns a 32 bit pseudo random integer, `harvest`, distributed uniformly -! over the odd integers of the `Int32` kind. - -SUBROUTINE odd_random_integer(harvest) - INTEGER(INT32), INTENT(OUT) :: harvest - REAL(dp) :: sample - CALL RANDOM_NUMBER(sample) - harvest = INT(FLOOR(sample * 2_INT64**32, INT64) - 2_INT64**31, & - & INT32) - harvest = ISHFT(harvest, 1) + 1_INT32 -END SUBROUTINE odd_random_integer - -END MODULE Hashing32 diff --git a/src/modules/IndexValue/CMakeLists.txt b/src/modules/IndexValue/CMakeLists.txt deleted file mode 100644 index 13c7b7c88..000000000 --- a/src/modules/IndexValue/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/IndexValue_Method.F90 -) \ No newline at end of file diff --git a/src/modules/IndexValue/src/IndexValue_Method.F90 b/src/modules/IndexValue/src/IndexValue_Method.F90 deleted file mode 100644 index 705fc04ae..000000000 --- a/src/modules/IndexValue/src/IndexValue_Method.F90 +++ /dev/null @@ -1,70 +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 IndexValue_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! IndexValue@Constructor -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Constructor1( Indx, Val ) RESULT( obj ) - INTEGER( I4B ), INTENT( IN ) :: Indx - REAL( DFP ), INTENT( IN ) :: Val - TYPE(IndexValue_) :: obj - END FUNCTION Constructor1 -END INTERFACE - -!---------------------------------------------------------------------------- -! IndexValue@Constructor -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Constructor2( Indx, Val ) RESULT( obj ) - INTEGER( I4B ), INTENT( IN ) :: Indx( : ) - REAL( DFP ), INTENT( IN ) :: Val( : ) - TYPE(IndexValue_), ALLOCATABLE :: obj( : ) - END FUNCTION Constructor2 -END INTERFACE - -!---------------------------------------------------------------------------- -! IndexValue@Constructor -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Constructor3( Indx, Val ) RESULT( obj ) - INTEGER( I4B ), INTENT( IN ) :: Indx( : ) - REAL( DFP ), INTENT( IN ) :: Val - TYPE(IndexValue_), ALLOCATABLE :: obj( : ) - END FUNCTION Constructor3 -END INTERFACE - -!---------------------------------------------------------------------------- -! IndexValue@Constructor -!---------------------------------------------------------------------------- - -INTERFACE IndexValue - MODULE PROCEDURE Constructor1, Constructor2, Constructor3 -END INTERFACE IndexValue - -PUBLIC :: IndexValue - -END MODULE IndexValue_Method \ No newline at end of file diff --git a/src/modules/IntVector/CMakeLists.txt b/src/modules/IntVector/CMakeLists.txt deleted file mode 100644 index c07368964..000000000 --- a/src/modules/IntVector/CMakeLists.txt +++ /dev/null @@ -1,29 +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 -# - - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/IntVector_ConstructorMethod.F90 - ${src_path}/IntVector_IOMethod.F90 - ${src_path}/IntVector_GetMethod.F90 - ${src_path}/IntVector_SetMethod.F90 - ${src_path}/IntVector_AppendMethod.F90 - ${src_path}/IntVector_EnquireMethod.F90 - ${src_path}/IntVector_Method.F90 -) diff --git a/src/modules/IntVector/src/IntVector_AppendMethod.F90 b/src/modules/IntVector/src/IntVector_AppendMethod.F90 deleted file mode 100644 index 60c9d7760..000000000 --- a/src/modules/IntVector/src/IntVector_AppendMethod.F90 +++ /dev/null @@ -1,124 +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 IntVector_AppendMethod -USE BaseType, ONLY: IntVector_ -USE GlobalData, ONLY: DFP, I4B, LGT -PRIVATE - -PUBLIC :: Append -PUBLIC :: H_CONCAT - -!---------------------------------------------------------------------------- -! Append@setMethods -!---------------------------------------------------------------------------- - -INTERFACE Append - MODULE PURE SUBROUTINE IntVec_Append_1(obj, VALUE) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: VALUE - END SUBROUTINE IntVec_Append_1 -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@setMethods -!---------------------------------------------------------------------------- - -INTERFACE Append - MODULE PURE SUBROUTINE IntVec_Append_2(obj, VALUE) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: VALUE(:) - END SUBROUTINE IntVec_Append_2 -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@setMethods -!---------------------------------------------------------------------------- - -INTERFACE Append - MODULE PURE SUBROUTINE IntVec_Append_3(obj, Anotherobj) - CLASS(IntVector_), INTENT(INOUT) :: obj - CLASS(IntVector_), INTENT(IN) :: Anotherobj - END SUBROUTINE IntVec_Append_3 -END INTERFACE Append - -!---------------------------------------------------------------------------- -! H_CONCAT@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 June 2021 -! summary: Horizontally concat two integer vectors - -INTERFACE H_CONCAT - MODULE PURE FUNCTION IntVec_H_CONCAT_1(vec1, vec2) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: vec1(:) - INTEGER(I4B), INTENT(IN) :: vec2(:) - INTEGER(I4B) :: ans(SIZE(vec1) + SIZE(vec2)) - END FUNCTION IntVec_H_CONCAT_1 -END INTERFACE H_CONCAT - -!---------------------------------------------------------------------------- -! H_CONCAT@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 June 2021 -! summary: Horizontally concat two [[IntVector_]] - -INTERFACE H_CONCAT - MODULE PURE FUNCTION IntVec_H_CONCAT_2(obj1, obj2) RESULT(Ans) - TYPE(IntVector_), INTENT(IN) :: obj1 - TYPE(IntVector_), INTENT(IN) :: obj2 - TYPE(IntVector_) :: ans - END FUNCTION IntVec_H_CONCAT_2 -END INTERFACE H_CONCAT - -!---------------------------------------------------------------------------- -! H_CONCAT@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 June 2021 -! summary: Horizontally concat a integer vector to a IntVec datatype. - -INTERFACE H_CONCAT - MODULE PURE FUNCTION IntVec_H_CONCAT_3(vec1, obj2) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: vec1(:) - TYPE(IntVector_), INTENT(IN) :: obj2 - TYPE(IntVector_) :: ans - END FUNCTION IntVec_H_CONCAT_3 -END INTERFACE H_CONCAT - -!---------------------------------------------------------------------------- -! H_CONCAT@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 June 2021 -! summary: Horizontally concat a integer vector to a IntVec datatype. - -INTERFACE H_CONCAT - MODULE PURE FUNCTION IntVec_H_CONCAT_4(obj1, vec2) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: vec2(:) - TYPE(IntVector_), INTENT(IN) :: obj1 - TYPE(IntVector_) :: ans - END FUNCTION IntVec_H_CONCAT_4 -END INTERFACE H_CONCAT - -END MODULE IntVector_AppendMethod - - diff --git a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 deleted file mode 100644 index 37c0ded01..000000000 --- a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 +++ /dev/null @@ -1,374 +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 IntVector_ConstructorMethod -USE BaseType, ONLY: IntVector_ -USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, & -& REAL64, REAL32 -PRIVATE - -PUBLIC :: Shape -PUBLIC :: SIZE -PUBLIC :: getTotalDimension -PUBLIC :: ALLOCATE -PUBLIC :: DEALLOCATE -PUBLIC :: Reallocate -PUBLIC :: Initiate -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: IntVector -PUBLIC :: IntVector_Pointer -PUBLIC :: Convert - -!---------------------------------------------------------------------------- -! Shape@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! 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 -END INTERFACE Shape - -!---------------------------------------------------------------------------- -! SIZE@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Returns size of the vector - -INTERFACE Size - MODULE PURE FUNCTION intVec_Size(obj, Dims) RESULT(Ans) - TYPE(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims - INTEGER(I4B) :: Ans - END FUNCTION intVec_Size -END INTERFACE Size - -!---------------------------------------------------------------------------- -! TotalDimension@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Returns the total dimension of an array -! -!# Introduction -! -! This function returns the total dimension (or rank) of an array, - -INTERFACE GetTotalDimension - MODULE PURE FUNCTION IntVec_getTotalDimension(obj) RESULT(Ans) - TYPE(IntVector_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION IntVec_getTotalDimension -END INTERFACE GetTotalDimension - -!---------------------------------------------------------------------------- -! Allocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! 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 -END INTERFACE ALLOCATE - -!---------------------------------------------------------------------------- -! Reallocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Allocate memory for the vector - -INTERFACE Reallocate - MODULE PURE SUBROUTINE intVec_Reallocate(obj, row) - TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE intVec_Reallocate -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Deallocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Deallocate memory occupied by IntVector - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE intVec_Deallocate(obj) - CLASS(IntVector_), INTENT(INOUT) :: obj - END SUBROUTINE intVec_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine initiates the [[IntVector_]] -! -!# Introduction -! -! This routine initiates an instance of IntVector -! Only the size of intvector is set. - -INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate1(obj, tSize) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tSize - END SUBROUTINE intVec_initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine initiates the vector of [[IntVector_]] - -INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate2(obj, tSize) - TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: tSize(:) - END SUBROUTINE intVec_initiate2 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! 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 - INTEGER(I4B), INTENT(IN) :: a, b - END SUBROUTINE intVec_initiate3 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Initiates an instance by using a vector of integers -! -!# Introduction -! This routine initiates an instance of intvector by coping data -! from integer vector. -! -! This routine also define an assignment operator, obj=val - -INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate4a(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(INT8), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4a - !! - MODULE PURE SUBROUTINE intVec_initiate4b(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(INT16), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4b - !! - MODULE PURE SUBROUTINE intVec_initiate4c(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(INT32), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4c - !! - MODULE PURE SUBROUTINE intVec_initiate4d(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(INT64), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4d -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE intVec_initiate4a, intVec_initiate4b, & - & intVec_initiate4c, intVec_initiate4d -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Initiates an instance by using a vector of real numbers -! -!# Introduction -! -! This routine initiates an instance of IntVector by copying data -! from a vector of reals. This routien also defines assignment operator, -! obj=val - -INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate5a(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj - REAL(REAL32), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate5a - !! - MODULE PURE SUBROUTINE intVec_initiate5b(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj - REAL(REAL64), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate5b -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE intVec_initiate5a, intVec_initiate5b -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! IntVector@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: IntVector returns an instance of [[IntVector_]] of given size - -INTERFACE IntVector - MODULE PURE FUNCTION intVec_Constructor1(tSize) RESULT(obj) - TYPE(IntVector_) :: obj - INTEGER(I4B), INTENT(IN) :: tSize - END FUNCTION intVec_Constructor1 -END INTERFACE IntVector - -!---------------------------------------------------------------------------- -! IntVector@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Convert a integer vector into [[IntVector_]] - -INTERFACE IntVector - MODULE PURE FUNCTION intVec_Constructor2(Val) RESULT(obj) - TYPE(IntVector_) :: obj - INTEGER(I4B), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor2 -END INTERFACE IntVector - -!---------------------------------------------------------------------------- -! IntVector@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Converts a real vector into [[IntVector_]] -! -! TODO Implement IntVector method for Int4, Int8, Int16, Int32 -! Real32, Real64 -! -INTERFACE IntVector - MODULE PURE FUNCTION intVec_Constructor3(Val) RESULT(obj) - TYPE(IntVector_) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor3 -END INTERFACE IntVector - -!---------------------------------------------------------------------------- -! Vector_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! 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 - INTEGER(I4B), INTENT(IN) :: tSize - END FUNCTION intVec_Constructor_1 -END INTERFACE IntVector_Pointer - -!---------------------------------------------------------------------------- -! Vector_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! 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 - INTEGER(I4B), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor_2 -END INTERFACE IntVector_Pointer - -!---------------------------------------------------------------------------- -! Vector_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! 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 - REAL(DFP), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor_3 -END INTERFACE IntVector_Pointer - -!---------------------------------------------------------------------------- -! assign@ConstructorMethods -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE IntVec_assign_a(Val, obj) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Val(:) - CLASS(IntVector_), INTENT(IN) :: obj - END SUBROUTINE IntVec_assign_a -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Convert@ConstructorMethods -!---------------------------------------------------------------------------- - -INTERFACE Convert - MODULE PURE SUBROUTINE obj_convert_int(From, To) - CLASS(IntVector_), INTENT(IN) :: From - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: To(:) - END SUBROUTINE obj_convert_int -END INTERFACE Convert - -END MODULE IntVector_ConstructorMethod diff --git a/src/modules/IntVector/src/IntVector_EnquireMethod.F90 b/src/modules/IntVector/src/IntVector_EnquireMethod.F90 deleted file mode 100644 index 6a93ce373..000000000 --- a/src/modules/IntVector/src/IntVector_EnquireMethod.F90 +++ /dev/null @@ -1,127 +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 IntVector_EnquireMethod -USE Basetype, ONLY: IntVector_ -USE GlobalData, ONLY: DFP, I4B, LGT, INT8, INT16, INT32, INT64 -PRIVATE - -PUBLIC :: OPERATOR(.in.) -PUBLIC :: isPresent -PUBLIC :: isAllocated -PUBLIC :: isInitiated - -!---------------------------------------------------------------------------- -! isAllocated@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if the instance is allocated - -INTERFACE isAllocated - MODULE PURE FUNCTION intVec_isAllocated(obj) RESULT(Ans) - CLASS(IntVector_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION intVec_isAllocated -END INTERFACE isAllocated - -INTERFACE Allocated - MODULE PROCEDURE intVec_isAllocated -END INTERFACE Allocated - -INTERFACE isInitiated - MODULE PROCEDURE intVec_isAllocated -END INTERFACE isInitiated - -!---------------------------------------------------------------------------- -! Operator(.in.)@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another - -INTERFACE OPERATOR(.in.) - MODULE PURE FUNCTION intVec_in1(obj1, obj2) RESULT(Ans) - CLASS(IntVector_), INTENT(IN) :: obj1 - CLASS(IntVector_), INTENT(IN) :: obj2 - LOGICAL(LGT) :: ans - END FUNCTION intVec_in1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Operator(.in.)@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another - -INTERFACE OPERATOR(.in.) - MODULE PURE FUNCTION intVec_in2a(a, obj) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a - CLASS(IntVector_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION intVec_in2a - - MODULE PURE FUNCTION intVec_in2b(a, obj) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a - CLASS(IntVector_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION intVec_in2b - - MODULE PURE FUNCTION intVec_in2c(a, obj) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a - CLASS(IntVector_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION intVec_in2c - - MODULE PURE FUNCTION intVec_in2d(a, obj) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a - CLASS(IntVector_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION intVec_in2d -END INTERFACE OPERATOR(.in.) - -!---------------------------------------------------------------------------- -! isPresent@EnquireMethods -!---------------------------------------------------------------------------- - -INTERFACE isPresent - MODULE PURE FUNCTION intVec_isPresent1(obj, VALUE) RESULT(Ans) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: VALUE - LOGICAL(LGT) :: Ans - END FUNCTION intVec_isPresent1 -END INTERFACE isPresent - -!---------------------------------------------------------------------------- -! isPresent@getMethod -!---------------------------------------------------------------------------- - -INTERFACE isPresent - MODULE PURE FUNCTION intVec_isPresent2(obj, VALUE) RESULT(Ans) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: VALUE(:) - LOGICAL(LGT), ALLOCATABLE :: Ans(:) - END FUNCTION intVec_isPresent2 -END INTERFACE isPresent - -END MODULE IntVector_EnquireMethod diff --git a/src/modules/IntVector/src/IntVector_GetMethod.F90 b/src/modules/IntVector/src/IntVector_GetMethod.F90 deleted file mode 100644 index f04c4768c..000000000 --- a/src/modules/IntVector/src/IntVector_GetMethod.F90 +++ /dev/null @@ -1,421 +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 IntVector_GetMethod -USE GlobalData, ONLY: DFP, I4B, LGT, INT8, INT16, INT32, INT64 -USE BaseType, ONLY: IntVector_ -PRIVATE - -PUBLIC :: GET -PUBLIC :: GetPointer -PUBLIC :: GetIndex - -!---------------------------------------------------------------------------- -! get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns IntVector instance - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_1(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_) :: Val - END FUNCTION intVec_get_1 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns an instance of [[intvector_]], obj(indx) - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_2(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - TYPE(IntVector_), INTENT(IN) :: DataType - INTEGER(I4B), INTENT(IN) :: Indx(:) - TYPE(IntVector_) :: Val - END FUNCTION intVec_get_2 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns the value using triplets. - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_3(obj, istart, iend, & - & stride, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - TYPE(IntVector_), INTENT(IN) :: DataType - !! an instance of [[IntVector_]] - INTEGER(I4B), INTENT(IN) :: istart - !! starting index value - INTEGER(I4B), OPTIONAL, INTENT(IN) :: iend, stride - !! iend is optional, default value is size(obj) - !! stride is optional, default value is 1. - TYPE(IntVector_) :: Val - !! returned value - END FUNCTION intVec_get_3 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: converts a vector of [[intvector_]] into a scalar instance. -! -! -!# Introduction -! -! Converts a vector of [[intvector_]] into a scalar instance. -! something like following is done. -! -! obj = obj(1) // obj(2) // obj(3) ... -! -! The size of val is size(obj(1)) + size(obj(2)) + ... - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_4(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_) :: Val - END FUNCTION intVec_get_4 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Serialized the vector of [[IntVector_]], select values by indx - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_5(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - TYPE(IntVector_), INTENT(IN) :: DataType - INTEGER(I4B), INTENT(IN) :: Indx(:) - TYPE(IntVector_) :: Val - END FUNCTION intVec_get_5 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_6(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_) :: Val - END FUNCTION intVec_get_6 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_7a(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_7a - MODULE PURE FUNCTION intVec_get_7b(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_7b - MODULE PURE FUNCTION intVec_get_7c(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_7c - MODULE PURE FUNCTION intVec_get_7d(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_7d -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_8a(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_8a - MODULE PURE FUNCTION intVec_get_8b(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_8b - MODULE PURE FUNCTION intVec_get_8c(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_8c - MODULE PURE FUNCTION intVec_get_8d(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_8d -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_9a(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_9a - MODULE PURE FUNCTION intVec_get_9b(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_9b - MODULE PURE FUNCTION intVec_get_9c(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_9c - MODULE PURE FUNCTION intVec_get_9d(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_9d -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_10a(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_10a - MODULE PURE FUNCTION intVec_get_10b(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_10b - MODULE PURE FUNCTION intVec_get_10c(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_10c - MODULE PURE FUNCTION intVec_get_10d(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_10d -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_11a(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT8), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_11a - MODULE PURE FUNCTION intVec_get_11b(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT16), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_11b - MODULE PURE FUNCTION intVec_get_11c(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT32), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_11c - MODULE PURE FUNCTION intVec_get_11d(obj, Indx, DataType) & - & RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT64), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_11d -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_12a(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_12a - MODULE PURE FUNCTION intVec_get_12b(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_12b - MODULE PURE FUNCTION intVec_get_12c(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_12c - MODULE PURE FUNCTION intVec_get_12d(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) - END FUNCTION intVec_get_12d -END INTERFACE Get - -!---------------------------------------------------------------------------- -! get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION intVec_get_13a(obj, indx, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8) :: val - END FUNCTION intVec_get_13a - MODULE PURE FUNCTION intVec_get_13b(obj, indx, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16) :: val - END FUNCTION intVec_get_13b - MODULE PURE FUNCTION intVec_get_13c(obj, indx, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32) :: val - END FUNCTION intVec_get_13c - MODULE PURE FUNCTION intVec_get_13d(obj, indx, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64) :: val - END FUNCTION intVec_get_13d -END INTERFACE Get - -!---------------------------------------------------------------------------- -! getPointers@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetPointer - MODULE FUNCTION intVec_getPointer_1(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN), TARGET :: obj - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_), POINTER :: Val - END FUNCTION intVec_getPointer_1 -END INTERFACE GetPointer - -!---------------------------------------------------------------------------- -! getPointers@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetPointer - MODULE FUNCTION intVec_getPointer_2(obj, DataType) RESULT(Val) - CLASS(IntVector_), INTENT(IN), TARGET :: obj - INTEGER(I4B), INTENT(IN) :: DataType - INTEGER(I4B), POINTER :: Val(:) - END FUNCTION intVec_getPointer_2 -END INTERFACE GetPointer - -!---------------------------------------------------------------------------- -! getIndex@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PURE FUNCTION intVec_getIndex1(obj, Val) RESULT(Ans) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Val - INTEGER(I4B) :: Ans - END FUNCTION intVec_getIndex1 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! getIndex@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PURE FUNCTION intVec_getIndex2(obj, Val) RESULT(Ans) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Val(:) - INTEGER(I4B), ALLOCATABLE :: Ans(:) - END FUNCTION intVec_getIndex2 -END INTERFACE GetIndex - -END MODULE IntVector_GetMethod diff --git a/src/modules/IntVector/src/IntVector_IOMethod.F90 b/src/modules/IntVector/src/IntVector_IOMethod.F90 deleted file mode 100644 index e4b514f8b..000000000 --- a/src/modules/IntVector/src/IntVector_IOMethod.F90 +++ /dev/null @@ -1,57 +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 IntVector_IOMethod -USE GlobalData, ONLY: DFP, I4B, LGT -USE BaseType, ONLY: IntVector_ -PRIVATE -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Display the content of [[IntVector_]] - -INTERFACE Display - MODULE SUBROUTINE intVec_Display1(obj, msg, UnitNo, orient) - CLASS(IntVector_), INTENT(IN) :: obj(:) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - END SUBROUTINE intVec_Display1 -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Display the content of [[IntVector_]] - -INTERFACE Display - MODULE SUBROUTINE intVec_Display2(obj, msg, UnitNo, orient) - CLASS(IntVector_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - CHARACTER(*), OPTIONAL, INTENT(IN) :: orient - END SUBROUTINE intVec_Display2 -END INTERFACE Display - -END MODULE IntVector_IOMethod diff --git a/src/modules/IntVector/src/IntVector_Method.F90 b/src/modules/IntVector/src/IntVector_Method.F90 deleted file mode 100644 index e181f3b44..000000000 --- a/src/modules/IntVector/src/IntVector_Method.F90 +++ /dev/null @@ -1,38 +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: 24 Feb 2021 -! summary: This module contains methods of [[IntVector_]] data type. -! -!###Introduction -! -! This module contains methods of [[IntVector_]] data type. -! This module only contains the definition of the interfaces of these -! methods. The actual implementation is given inside the submodules. This -! modules has following submodules: -! - -MODULE IntVector_Method -USE IntVector_ConstructorMethod -USE IntVector_IOMethod -USE IntVector_EnquireMethod -USE IntVector_GetMethod -USE IntVector_SetMethod -USE IntVector_AppendMethod -END MODULE IntVector_Method diff --git a/src/modules/IntVector/src/IntVector_SetMethod.F90 b/src/modules/IntVector/src/IntVector_SetMethod.F90 deleted file mode 100644 index a1545ba0c..000000000 --- a/src/modules/IntVector/src/IntVector_SetMethod.F90 +++ /dev/null @@ -1,101 +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 IntVector_SetMethod -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: IntVector_ -PRIVATE - -PUBLIC :: setTotalDimension -PUBLIC :: set -PUBLIC :: RemoveDuplicates -PUBLIC :: Repeat - -!---------------------------------------------------------------------------- -! setTotalDimension@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the total dimension (rank) of an array -! -!# Introduction -! -! This subroutine sets the rank(total dimension) of an array - -INTERFACE setTotalDimension - MODULE PURE SUBROUTINE IntVec_setTotalDimension(obj, tDimension) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tDimension - END SUBROUTINE IntVec_setTotalDimension -END INTERFACE setTotalDimension - -!---------------------------------------------------------------------------- -! setValue@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 June 2021 -! summary: set the value in IntVector - -INTERFACE set - MODULE PURE SUBROUTINE intVec_set1(obj, Indx, VALUE) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(I4B), INTENT(IN) :: VALUE(:) - END SUBROUTINE intVec_set1 -END INTERFACE set - -!---------------------------------------------------------------------------- -! setValue@SetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 June 2021 -! summary: set the value in IntVector - -INTERFACE set - MODULE PURE SUBROUTINE intVec_set2(obj, Indx, VALUE) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Indx - INTEGER(I4B), INTENT(IN) :: VALUE - END SUBROUTINE intVec_set2 -END INTERFACE set - -!---------------------------------------------------------------------------- -! RemoveDuplicates@setMethod -!---------------------------------------------------------------------------- - -INTERFACE RemoveDuplicates - MODULE PURE SUBROUTINE IntVec_RemoveDuplicates_1(obj) - CLASS(IntVector_), INTENT(INOUT) :: obj - END SUBROUTINE IntVec_RemoveDuplicates_1 -END INTERFACE RemoveDuplicates - -!---------------------------------------------------------------------------- -! Repeat@setMethod -!---------------------------------------------------------------------------- - -INTERFACE Repeat - MODULE PURE FUNCTION IntVec_Repeat_1(obj, rtimes) RESULT(Ans) - TYPE(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(I4B) :: Ans(SIZE(obj%Val) * rtimes) - END FUNCTION IntVec_Repeat_1 -END INTERFACE Repeat - -END MODULE IntVector_SetMethod diff --git a/src/modules/IterationData/CMakeLists.txt b/src/modules/IterationData/CMakeLists.txt deleted file mode 100644 index e58ecfa3b..000000000 --- a/src/modules/IterationData/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/IterationData_Method.F90 -) \ No newline at end of file diff --git a/src/modules/IterationData/src/IterationData_Method.F90 b/src/modules/IterationData/src/IterationData_Method.F90 deleted file mode 100644 index 34eda0561..000000000 --- a/src/modules/IterationData/src/IterationData_Method.F90 +++ /dev/null @@ -1,108 +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 IterationData_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE SUBROUTINE iterdata_Initiate( obj, maxIter, iterationNumber, & - & residualError0, residualError, residualTolerance, solutionError0, & - & solutionError, solutionTolerance, convergenceType, & - & convergenceIn, normType, converged, timeAtStart, timeAtEnd ) - TYPE( IterationData_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: maxIter - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: iterationNumber - REAL( DFP ), OPTIONAL, INTENT( IN ) :: residualError0 - REAL( DFP ), OPTIONAL, INTENT( IN ) :: residualError - REAL( DFP ), OPTIONAL, INTENT( IN ) :: residualTolerance - REAL( DFP ), OPTIONAL, INTENT( IN ) :: solutionError0 - REAL( DFP ), OPTIONAL, INTENT( IN ) :: solutionError - REAL( DFP ), OPTIONAL, INTENT( IN ) :: solutionTolerance - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: convergenceType - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: convergenceIn - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: normType - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: converged - REAL( DFP ), OPTIONAL, INTENT( IN ) :: timeAtStart - REAL( DFP ), OPTIONAL, INTENT( IN ) :: timeAtEnd -END SUBROUTINE iterdata_Initiate -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE iterdata_Initiate -END INTERFACE Initiate - -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -INTERFACE -MODULE SUBROUTINE iterdata_Deallocate( obj ) - TYPE( IterationData_ ), INTENT( INOUT ) :: obj -END SUBROUTINE iterdata_Deallocate -END INTERFACE - -INTERFACE Deallocate - MODULE PROCEDURE iterdata_Deallocate -END INTERFACE Deallocate - -PUBLIC :: Deallocate - -!---------------------------------------------------------------------------- -! isConverged@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION iterdata_isConverged( obj ) RESULT( Ans ) - TYPE( IterationData_ ), INTENT( IN ) :: obj - LOGICAL( LGT ) :: Ans -END FUNCTION iterdata_isConverged -END INTERFACE - -INTERFACE isConverged - MODULE PROCEDURE iterdata_isConverged -END INTERFACE isConverged - -PUBLIC :: isConverged - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -INTERFACE -MODULE SUBROUTINE iterdata_Display( obj, msg, UnitNo ) - TYPE( IterationData_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: msg - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: UnitNo -END SUBROUTINE iterdata_Display -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE iterdata_Display -END INTERFACE Display - -PUBLIC :: Display - -END MODULE IterationData_Method \ No newline at end of file diff --git a/src/modules/Kdtree2/CMakeLists.txt b/src/modules/Kdtree2/CMakeLists.txt deleted file mode 100644 index 5aaa38efe..000000000 --- a/src/modules/Kdtree2/CMakeLists.txt +++ /dev/null @@ -1,23 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/Kdtree2_Module.F90 - PRIVATE ${src_path}/Kd2PQueue_Module.F90) diff --git a/src/modules/Kdtree2/src/Kd2PQueue_Module.F90 b/src/modules/Kdtree2/src/Kd2PQueue_Module.F90 deleted file mode 100644 index ac8d1299b..000000000 --- a/src/modules/Kdtree2/src/Kd2PQueue_Module.F90 +++ /dev/null @@ -1,448 +0,0 @@ -! -!(c) Matthew Kennel, Institute for Nonlinear Science (2004) -! -! Licensed under the Academic Free License version 1.1 found in file LICENSE -! with additional provisions found in that same file. -! - -! There are two modules in this file -! -! kdtree2_priority_queue_module -! kdtree2_module - -MODULE Kd2PQueue_Module -USE GlobalData, ONLY: kdkind => DFP, I4B, LGT -IMPLICIT NONE -PRIVATE - -PUBLIC :: Kdtree2Result_ -PUBLIC :: pq -PUBLIC :: pq_create -PUBLIC :: pq_delete, pq_insert -PUBLIC :: pq_extract_max, pq_max, pq_replace_max, pq_maxpri - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! maintain a priority queue (PQ) of data, pairs of 'priority/payload', -! implemented with a binary heap. This is the type, and the 'dis' field -! is the priority. -! -! a pair of distances, indexes - -TYPE Kdtree2Result_ - REAL(kdkind) :: dis !=0.0 - INTEGER :: idx !=-1 Initializers cause some bugs in compilers. -END TYPE Kdtree2Result_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! A heap-based priority queue lets one efficiently implement the following -! operations, each in log(N) time, as opposed to linear time. -! -! 1) add a datum (push a datum onto the queue, increasing its length) -! 2) return the priority value of the maximum priority element -! 3) pop-off (and delete) the element with the maximum priority, decreasing -! the size of the queue. -! 4) replace the datum with the maximum priority with a supplied datum -! (of either higher or lower priority), maintaining the size of the -! queue. -! -! -! In the k-d tree case, the 'priority' is the square distance of a point in -! the data set to a reference point. The goal is to keep the smallest M -! distances to a reference point. The tree algorithm searches terminal -! nodes to decide whether to add points under consideration. -! -! A priority queue is useful here because it lets one quickly return the -! largest distance currently existing in the list. If a new candidate -! distance is smaller than this, then the new candidate ought to replace -! the old candidate. In priority queue terms, this means removing the -! highest priority element, and inserting the new one. -! -! Algorithms based on Cormen, Leiserson, Rivest, _Introduction -! to Algorithms_, 1990, with further optimization by the author. -! -! Originally informed by a C implementation by Sriranga Veeraraghavan. -! -! This module is not written in the most clear way, but is implemented such -! for speed, as it its operations will be called many times during searches -! of large numbers of neighbors. -! -TYPE pq - ! - ! The priority queue consists of elements - ! priority(1:heap_size), with associated payload(:). - ! - ! There are heap_size active elements. - ! Assumes the allocation is always sufficient. Will NOT increase it - ! to match. - INTEGER :: heap_size = 0 - TYPE(Kdtree2Result_), POINTER :: elems(:) -END TYPE pq - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -FUNCTION pq_create(results_in) RESULT(res) - ! - ! Create a priority queue from ALREADY allocated - ! array pointers for storage. NOTE! It will NOT - ! add any alements to the heap, i.e. any existing - ! data in the input arrays will NOT be used and may - ! be overwritten. - ! - ! usage: - ! real(kdkind), pointer :: x(:) - ! integer, pointer :: k(:) - ! allocate(x(1000),k(1000)) - ! pq => pq_create(x,k) - ! - TYPE(Kdtree2Result_), TARGET :: results_in(:) - TYPE(pq) :: res - ! - ! - INTEGER :: nalloc - - nalloc = SIZE(results_in, 1) - IF (nalloc .LT. 1) THEN - WRITE (*, *) 'PQ_CREATE: error, input arrays must be allocated.' - END IF - res%elems => results_in - res%heap_size = 0 - RETURN -END FUNCTION pq_create - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! -! operations for getting parents and left + right children -! of elements in a binary heap. -! - -! -! These are written inline for speed. -! -! integer function parent(i) -! integer, intent(in) :: i -! parent = (i/2) -! return -! end function parent - -! integer function left(i) -! integer, intent(in) ::i -! left = (2*i) -! return -! end function left - -! integer function right(i) -! integer, intent(in) :: i -! right = (2*i)+1 -! return -! end function right - -! logical function compare_priority(p1,p2) -! real(kdkind), intent(in) :: p1, p2 -! -! compare_priority = (p1 .gt. p2) -! return -! end function compare_priority - -SUBROUTINE heapify(a, i_in) - ! - ! take a heap rooted at 'i' and force it to be in the - ! heap canonical form. This is performance critical - ! and has been tweaked a little to reflect this. - ! - TYPE(pq), POINTER :: a - INTEGER, INTENT(in) :: i_in - ! - INTEGER :: i, l, r, largest - - REAL(kdkind) :: pri_i, pri_l, pri_r, pri_largest - - TYPE(Kdtree2Result_) :: temp - - i = i_in - - bigloop: DO - l = 2 * i ! left(i) - r = l + 1 ! right(i) - ! - ! set 'largest' to the index of either i, l, r - ! depending on whose priority is largest. - ! - ! note that l or r can be larger than the heap size - ! in which case they do not count. - - ! does left child have higher priority? - IF (l .GT. a%heap_size) THEN - ! we know that i is the largest as both l and r are invalid. - EXIT - ELSE - pri_i = a%elems(i)%dis - pri_l = a%elems(l)%dis - IF (pri_l .GT. pri_i) THEN - largest = l - pri_largest = pri_l - ELSE - largest = i - pri_largest = pri_i - END IF - - ! - ! between i and l we have a winner - ! now choose between that and r. - ! - IF (r .LE. a%heap_size) THEN - pri_r = a%elems(r)%dis - IF (pri_r .GT. pri_largest) THEN - largest = r - END IF - END IF - END IF - - IF (largest .NE. i) THEN - ! swap data in nodes largest and i, then heapify - - temp = a%elems(i) - a%elems(i) = a%elems(largest) - a%elems(largest) = temp - ! - ! Canonical heapify() algorithm has tail-ecursive call: - ! - ! call heapify(a,largest) - ! we will simulate with cycle - ! - i = largest - CYCLE bigloop ! continue the loop - ELSE - RETURN ! break from the loop - END IF - END DO bigloop - RETURN -END SUBROUTINE heapify - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE pq_max(a, e) - ! - ! return the priority and its payload of the maximum priority element - ! on the queue, which should be the first one, if it is - ! in heapified form. - ! - TYPE(pq), POINTER :: a - TYPE(Kdtree2Result_), INTENT(out) :: e - - IF (a%heap_size .GT. 0) THEN - e = a%elems(1) - ELSE - WRITE (*, *) 'PQ_MAX: ERROR, heap_size < 1' - STOP - END IF - RETURN -END SUBROUTINE pq_max - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(kdkind) FUNCTION pq_maxpri(a) - TYPE(pq), POINTER :: a - - IF (a%heap_size .GT. 0) THEN - pq_maxpri = a%elems(1)%dis - ELSE - WRITE (*, *) 'PQ_MAX_PRI: ERROR, heapsize < 1' - STOP - END IF - RETURN -END FUNCTION pq_maxpri - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE pq_extract_max(a, e) - ! - ! return the priority and payload of maximum priority - ! element, and remove it from the queue. - ! (equivalent to 'pop()' on a stack) - ! - TYPE(pq), POINTER :: a - TYPE(Kdtree2Result_), INTENT(out) :: e - - IF (a%heap_size .GE. 1) THEN - ! - ! return max as first element - ! - e = a%elems(1) - - ! - ! move last element to first - ! - a%elems(1) = a%elems(a%heap_size) - a%heap_size = a%heap_size - 1 - CALL heapify(a, 1) - RETURN - ELSE - WRITE (*, *) 'PQ_EXTRACT_MAX: error, attempted to pop non-positive PQ' - STOP - END IF - -END SUBROUTINE pq_extract_max - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(kdkind) FUNCTION pq_insert(a, dis, idx) - ! - ! Insert a new element and return the new maximum priority, - ! which may or may not be the same as the old maximum priority. - ! - TYPE(pq), POINTER :: a - REAL(kdkind), INTENT(in) :: dis - INTEGER, INTENT(in) :: idx - ! Type(Kdtree2Result_), intent(in) :: e - ! - INTEGER :: i, isparent - REAL(kdkind) :: parentdis - - a%heap_size = a%heap_size + 1 - i = a%heap_size - - DO WHILE (i .GT. 1) - isparent = INT(i / 2) - parentdis = a%elems(isparent)%dis - IF (dis .GT. parentdis) THEN - ! move what was in i's parent into i. - a%elems(i)%dis = parentdis - a%elems(i)%idx = a%elems(isparent)%idx - i = isparent - ELSE - EXIT - END IF - END DO - - ! insert the element at the determined position - a%elems(i)%dis = dis - a%elems(i)%idx = idx - - pq_insert = a%elems(1)%dis - RETURN - ! end if - -END FUNCTION pq_insert - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(kdkind) FUNCTION pq_replace_max(a, dis, idx) - ! - ! Replace the extant maximum priority element - ! in the PQ with (dis,idx). Return - ! the new maximum priority, which may be larger - ! or smaller than the old one. - ! - TYPE(pq), POINTER :: a - REAL(kdkind), INTENT(in) :: dis - INTEGER, INTENT(in) :: idx -! Type(Kdtree2Result_), intent(in) :: e - ! not tested as well! - - INTEGER :: parent, child, N - REAL(kdkind) :: prichild, prichildp1 - - TYPE(Kdtree2Result_) :: etmp - - IF (.TRUE.) THEN - N = a%heap_size - IF (N .GE. 1) THEN - parent = 1 - child = 2 - - loop: DO WHILE (child .LE. N) - prichild = a%elems(child)%dis - - ! - ! posibly child+1 has higher priority, and if - ! so, get it, and increment child. - ! - - IF (child .LT. N) THEN - prichildp1 = a%elems(child + 1)%dis - IF (prichild .LT. prichildp1) THEN - child = child + 1 - prichild = prichildp1 - END IF - END IF - - IF (dis .GE. prichild) THEN - EXIT loop - ! we have a proper place for our new element, - ! bigger than either children's priority. - ELSE - ! move child into parent. - a%elems(parent) = a%elems(child) - parent = child - child = 2 * parent - END IF - END DO loop - a%elems(parent)%dis = dis - a%elems(parent)%idx = idx - pq_replace_max = a%elems(1)%dis - ELSE - a%elems(1)%dis = dis - a%elems(1)%idx = idx - pq_replace_max = dis - END IF - ELSE - ! - ! slower version using elementary pop and push operations. - ! - CALL pq_extract_max(a, etmp) - etmp%dis = dis - etmp%idx = idx - pq_replace_max = pq_insert(a, dis, idx) - END IF - RETURN -END FUNCTION pq_replace_max - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE pq_delete(a, i) - ! - ! delete item with index 'i' - ! - TYPE(pq), POINTER :: a - INTEGER :: i - - IF ((i .LT. 1) .OR. (i .GT. a%heap_size)) THEN - WRITE (*, *) 'PQ_DELETE: error, attempt to remove out of bounds element.' - STOP - END IF - - ! swap the item to be deleted with the last element - ! and shorten heap by one. - a%elems(i) = a%elems(a%heap_size) - a%heap_size = a%heap_size - 1 - - CALL heapify(a, i) - -END SUBROUTINE pq_delete - -END MODULE Kd2PQueue_Module diff --git a/src/modules/Kdtree2/src/Kdtree2_Module.F90 b/src/modules/Kdtree2/src/Kdtree2_Module.F90 deleted file mode 100644 index b2bff37cf..000000000 --- a/src/modules/Kdtree2/src/Kdtree2_Module.F90 +++ /dev/null @@ -1,1329 +0,0 @@ -!(c) Matthew Kennel, INstitute for Nonlinear Science (2004) -! -! Licensed under the Academic Free License version 1.1 found in file LICENSE -! with additional provisions found in that same file. -! - -! There are two modules in this file -! -! Kdtree2_priority_queue_module -! Kdtree2_module - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! K-D tree routines in Fortran 90 by Matt Kennel. -! Original program was written in Sather by Steve Omohundro and -! Matt Kennel. Only the Euclidean metric is supported. -! -! -! This module is identical to 'kd_tree', except that the order -! of subscripts is reversed in the data file. -! IN otherwords for an embedding of N D-dimensional vectors, the -! data file is here, in natural Fortran order data(1:D, 1:N) -! because Fortran lays out columns first, -! -! whereas conventionally (C-style) it is data(1:N,1:D) -! as in the original kd_tree module. - -MODULE Kdtree2_Module -USE GlobalData, ONLY: kdkind => DFP, I4B, LGT, stdout, stderr, CHAR_LF -USE ErrorHandling, ONLY: Errormsg -USE Display_Method, ONLY: Display -USE Kd2PQueue_Module -USE INputUtility -IMPLICIT NONE -PRIVATE - -PUBLIC :: Kdtree2_, Kdtree2Result_, Kdtree2Node_ -PUBLIC :: Kdtree2_create, Kdtree2_Destroy -PUBLIC :: Kdtree2_n_nearest, Kdtree2_n_nearest_around_point -PUBLIC :: Kdtree2_r_nearest, Kdtree2_r_nearest_around_point -PUBLIC :: Kdtree2_r_count, Kdtree2_r_count_around_point -PUBLIC :: Kdtree2_sort_results -PUBLIC :: Kdtree2_n_nearest_brute_force, Kdtree2_r_nearest_brute_force - -INTEGER, PARAMETER :: bucket_size = 12 -! The maximum number of points to keep in a terminal node. - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE interval - REAL(kdkind) :: lower, upper -END TYPE interval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! an internal tree node -TYPE :: Kdtree2Node_ - PRIVATE - INTEGER :: cut_dim - ! the dimension to cut - REAL(kdkind) :: cut_val - ! where to cut the dimension - REAL(kdkind) :: cut_val_left, cut_val_right - ! improved cutoffs knowing the spread in child boxes. - INTEGER :: l, u - TYPE(Kdtree2Node_), POINTER :: left, right - TYPE(interval), ALLOCATABLE :: box(:) - ! child pointers - ! Points included in this node are indexes[k] with k \in [l,u] -END TYPE Kdtree2Node_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: Kdtree2_ - ! Global information about the tree, one per tree - INTEGER :: dimen = 0, n = 0 - ! dimensionality and total # of points - LOGICAL :: sort = .FALSE. - ! do we always sort output results? - LOGICAL :: rearrange = .FALSE. - REAL(kdkind), POINTER :: the_data(:, :) => NULL() - ! pointer to the actual data array - ! - ! IMPORTANT NOTE: IT IS DIMENSIONED the_data(1:d,1:N) - ! which may be opposite of what may be conventional. - ! This is, because in Fortran, the memory layout is such that - ! the first dimension is in sequential order. Hence, with - ! (1:d,1:N), all components of the vector will be in consecutive - ! memory locations. The search time is dominated by the - ! evaluation of distances in the terminal nodes. Putting all - ! vector components in consecutive memory location improves - ! memory cache locality, and hence search speed, and may enable - ! vectorization on some processors and compilers. - - INTEGER, ALLOCATABLE :: ind(:) - ! permuted index into the data, so that indexes[l..u] of some - ! bucket represent the indexes of the actual points in that - ! bucket. - REAL(kdkind), ALLOCATABLE :: rearranged_data(:, :) - ! if (rearrange .eqv. .true.) then rearranged_data has been - ! created so that rearranged_data(:,i) = the_data(:,ind(i)), - ! permitting search to use more cache-friendly rearranged_data, at - ! some initial computation and storage cost. - TYPE(Kdtree2Node_), POINTER :: root => NULL() - ! root pointer of the tree -END TYPE Kdtree2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! One of these is created for each search. -! -! Many fields are copied from the tree structure, in order to -! speed up the search. -! -TYPE :: tree_search_record - PRIVATE - INTEGER :: dimen - INTEGER :: nn, nfound - REAL(kdkind) :: ballsize - INTEGER :: centeridx = 999, correltime = 9999 - ! exclude points within 'correltime' of 'centeridx', iff centeridx >= 0 - INTEGER :: nalloc ! how much allocated for results(:)? - LOGICAL :: rearrange ! are the data rearranged or original? - ! did the # of points found overflow the storage provided? - LOGICAL :: overflow - REAL(kdkind), POINTER :: qv(:) ! query vector - TYPE(Kdtree2Result_), POINTER :: results(:) ! results - TYPE(pq) :: pq - REAL(kdkind), POINTER :: DATA(:, :) ! temp pointer to data - INTEGER, POINTER :: ind(:) ! temp pointer to indexes -END TYPE tree_search_record - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE(tree_search_record), SAVE, TARGET :: sr ! A GLOBAL VARIABLE for search - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -! create the actual tree structure, given an input array of data. -! -! Note, input data is input_data(1:d,1:N), NOT the other way around. -! THIS IS THE REVERSE OF THE PREVIOUS VERSION OF THIS MODULE. -! The reason for it is cache friendliness, improving performance. -! -! Optional arguments: If 'dim' is specified, then the tree -! will only search the first 'dim' components -! of input_data, otherwise, dim is inferred -! from SIZE(input_data,1). -! -! if sort .eqv. .true. then output results -! will be sorted by increasing distance. -! default=.false., as it is faster to not sort. -! -! if rearrange .eqv. .true. then an internal -! copy of the data, rearranged by terminal node, -! will be made for cache friendliness. -! default=.true., as it speeds searches, but -! building takes longer, and extra memory is used. - -FUNCTION Kdtree2_create(input_data, dim, sort, rearrange) RESULT(mr) - TYPE(Kdtree2_), POINTER :: mr - INTEGER, INTENT(IN), OPTIONAL :: dim - LOGICAL, INTENT(IN), OPTIONAL :: sort - LOGICAL, INTENT(IN), OPTIONAL :: rearrange - REAL(kdkind), TARGET :: input_data(:, :) - - ! internal variables - INTEGER :: i - - ALLOCATE (mr) - mr%the_data => input_data - ! pointer assignment - - mr%dimen = INput(default=SIZE(input_data, 1), option=dim) - mr%n = SIZE(input_data, 2) - -#ifdef DEBUG_VER - - IF (mr%dimen > mr%n) THEN - ! unlikely to be correct - WRITE (*, *) 'KD_TREE_TRANS: likely user error.' - WRITE (*, *) 'KD_TREE_TRANS: You passed in matrix with D=', mr%dimen - WRITE (*, *) 'KD_TREE_TRANS: and N=', mr%n - WRITE (*, *) 'KD_TREE_TRANS: note, that new format is data(1:D,1:N)' - write (*,*) 'KD_TREE_TRANS: with usually N >> D. If N =approx= D, then a k-d tree' - WRITE (*, *) 'KD_TREE_TRANS: is not an appropriate data structure.' - STOP - END IF - -#endif - - CALL build_tree(mr) - - mr%sort = INput(default=.FALSE., option=sort) - mr%rearrange = INput(default=.TRUE., option=rearrange) - - IF (.NOT. mr%rearrange) THEN - IF (ALLOCATED(mr%rearranged_data)) DEALLOCATE (mr%rearranged_data) - RETURN - END IF - - ALLOCATE (mr%rearranged_data(mr%dimen, mr%n)) - DO i = 1, mr%n - mr%rearranged_data(:, i) = mr%the_data(:, mr%ind(i)) - END DO - -END FUNCTION Kdtree2_create - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE build_tree(tp) - TYPE(Kdtree2_), INTENT(INOUT) :: tp - INTEGER :: j - TYPE(Kdtree2Node_), POINTER :: dummy => NULL() - ALLOCATE (tp%ind(tp%n)) - DO CONCURRENT(j=1:tp%n) - tp%ind(j) = j - END DO - tp%root => build_tree_for_range(tp, 1, tp%n, dummy) -END SUBROUTINE build_tree - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -RECURSIVE FUNCTION build_tree_for_range(tp, l, u, parent) RESULT(res) - TYPE(Kdtree2Node_), POINTER :: res - TYPE(Kdtree2_), INTENT(INOUT) :: tp - TYPE(Kdtree2Node_), POINTER :: parent - INTEGER, INTENT(IN) :: l, u - - ! internal variables - INTEGER :: i, c, m, dimen - LOGICAL :: recompute, isok - REAL(kdkind) :: average - - ! first compute min and max - dimen = tp%dimen - ALLOCATE (res) - ALLOCATE (res%box(dimen)) - - ! First, compute an APPROXIMATE bounding box of all points - ! associated with this node. - IF (u < l) THEN - ! no points in this box - NULLIFY (res) - RETURN - END IF - - isok = (u - l) <= bucket_size - IF (isok) THEN - ! always compute true bounding box for terminal nodes. - DO i = 1, dimen - CALL spread_in_coordinate(tp, i, l, u, res%box(i)) - END DO - res%cut_dim = 0 - res%cut_val = 0.0 - res%l = l - res%u = u - res%left => NULL() - res%right => NULL() - RETURN - END IF - - ! modify approximate bounding box. This will be an - ! overestimate of the true bounding box, as we are only recomputing - ! the bounding box for the dimension that the parent split on. - ! - ! Going to a true bounding box computation would significantly - ! increase the time necessary to build the tree, and usually - ! has only a very small difference. This box is not used - ! for searching but only for deciding which coordinate to split on. - DO i = 1, dimen - - recompute = .TRUE. - IF (ASSOCIATED(parent)) THEN - IF (i .NE. parent%cut_dim) THEN - recompute = .FALSE. - END IF - END IF - - IF (recompute) THEN - CALL spread_in_coordinate(tp, i, l, u, res%box(i)) - ELSE - res%box(i) = parent%box(i) - END IF - - END DO - - c = MAXLOC(res%box(1:dimen)%upper - res%box(1:dimen)%lower, 1) - ! c is the identity of which coordinate has the greatest spread. - - ! select point halfway between min and max, as per A. Moore, - ! who says this helps in some degenerate cases, or - ! actual arithmetic average. - ! actually compute average - average = SUM(tp%the_data(c, tp%ind(l:u))) / REAL(u - l + 1, kdkind) - - res%cut_val = average - m = select_on_coordinate_value(tp%the_data, tp%ind, c, average, l, u) - - ! moves indexes around - res%cut_dim = c - res%l = l - res%u = u - ! res%cut_val = tp%the_data(c,tp%ind(m)) - - res%left => build_tree_for_range(tp, l, m, res) - res%right => build_tree_for_range(tp, m + 1, u, res) - - IF (ASSOCIATED(res%right) .EQV. .FALSE.) THEN - res%box = res%left%box - res%cut_val_left = res%left%box(c)%upper - res%cut_val = res%cut_val_left - ELSEIF (ASSOCIATED(res%left) .EQV. .FALSE.) THEN - res%box = res%right%box - res%cut_val_right = res%right%box(c)%lower - res%cut_val = res%cut_val_right - ELSE - res%cut_val_right = res%right%box(c)%lower - res%cut_val_left = res%left%box(c)%upper - res%cut_val = (res%cut_val_left + res%cut_val_right) / 2 - - ! now remake the true bounding box for self. - ! Since we are taking unions (in effect) of a tree structure, - ! this is much faster than doing an exhaustive - ! search over all points - res%box%upper = MAX(res%left%box%upper, res%right%box%upper) - res%box%lower = MIN(res%left%box%lower, res%right%box%lower) - END IF -END FUNCTION build_tree_for_range - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Move elts of ind around between l and u, so that all points -! <= than alpha (in c cooordinate) are first, and then -! all points > alpha are second. -! -! Algorithm (matt kennel). -! -! Consider the list as having three parts: on the left, -! the points known to be <= alpha. On the right, the points -! known to be > alpha, and in the middle, the currently unknown -! points. The algorithm is to scan the unknown points, starting -! from the left, and swapping them so that they are added to -! the left stack or the right stack, as appropriate. -! -! The algorithm finishes when the unknown stack is empty. -INTEGER FUNCTION select_on_coordinate_value(v, ind, c, alpha, li, ui) & - RESULT(res) - INTEGER, INTENT(IN) :: c, li, ui - REAL(kdkind), INTENT(IN) :: alpha - REAL(kdkind) :: v(1:, 1:) - INTEGER :: ind(1:) - INTEGER :: tmp - INTEGER :: lb, rb - - ! The points known to be <= alpha are in - ! [l,lb-1] - ! - ! The points known to be > alpha are in - ! [rb+1,u]. - ! - ! Therefore we add new points into lb or - ! rb as appropriate. When lb=rb - ! we are done. We return the location of the last point <= alpha. - lb = li; rb = ui - - DO WHILE (lb < rb) - IF (v(c, ind(lb)) <= alpha) THEN - ! it is good where it is. - lb = lb + 1 - ELSE - ! swap it with rb. - tmp = ind(lb); ind(lb) = ind(rb); ind(rb) = tmp - rb = rb - 1 - END IF - END DO - - ! now lb .eq. ub - IF (v(c, ind(lb)) <= alpha) THEN - res = lb - ELSE - res = lb - 1 - END IF - -END FUNCTION select_on_coordinate_value - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE spread_in_coordinate(tp, c, l, u, interv) - TYPE(Kdtree2_), INTENT(INOUT) :: tp - TYPE(interval), INTENT(out) :: interv - INTEGER, INTENT(IN) :: c, l, u - ! internal variables - REAL(kdkind) :: last, lmax, lmin, t, smin, smax - INTEGER :: i, ulocal - ! REAL(kdkind), POINTER :: v(:, :) - ! INTEGER, POINTER :: ind(:) - - ASSOCIATE (v => tp%the_data(1:, 1:), ind => tp%ind(1:)) - smin = v(c, ind(l)) - smax = smin - ulocal = u - - DO i = l + 2, ulocal, 2 - lmin = v(c, ind(i - 1)) - lmax = v(c, ind(i)) - IF (lmin > lmax) THEN - t = lmin - lmin = lmax - lmax = t - END IF - IF (smin > lmin) smin = lmin - IF (smax < lmax) smax = lmax - END DO - - IF (i == ulocal + 1) THEN - last = v(c, ind(ulocal)) - IF (smin > last) smin = last - IF (smax < last) smax = last - END IF - - interv%lower = smin - interv%upper = smax - END ASSOCIATE - -END SUBROUTINE spread_in_coordinate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Deallocates all memory for the tree, except input data matrix -SUBROUTINE Kdtree2_Destroy(tp) - TYPE(Kdtree2_), INTENT(INOUT) :: tp - - CALL destroy_node(tp%root) - - tp%dimen = 0 - tp%sort = .FALSE. - tp%rearrange = .FALSE. - tp%the_data => NULL() - IF (ALLOCATED(tp%ind)) DEALLOCATE (tp%ind) - IF (ALLOCATED(tp%rearranged_data)) DEALLOCATE (tp%rearranged_data) - -CONTAINS - RECURSIVE SUBROUTINE destroy_node(np) - TYPE(Kdtree2Node_), POINTER :: np - - IF (ASSOCIATED(np%left)) THEN - CALL destroy_node(np%left) - NULLIFY (np%left) - END IF - - IF (ASSOCIATED(np%right)) THEN - CALL destroy_node(np%right) - NULLIFY (np%right) - END IF - - IF (ALLOCATED(np%box)) DEALLOCATE (np%box) - DEALLOCATE (np) - - END SUBROUTINE destroy_node - -END SUBROUTINE Kdtree2_Destroy - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Find the 'nn' vectors in the tree nearest to 'qv' in euclidean norm -! returning their indexes and distances in 'indexes' and 'distances' -! arrays already allocated passed to this subroutine. -SUBROUTINE Kdtree2_n_nearest(tp, qv, nn, results) - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - REAL(kdkind), TARGET, INTENT(IN) :: qv(:) - INTEGER, INTENT(IN) :: nn - TYPE(Kdtree2Result_), TARGET :: results(:) - - sr%ballsize = HUGE(1.0) - sr%qv => qv - sr%nn = nn - sr%nfound = 0 - sr%centeridx = -1 - sr%correltime = 0 - sr%overflow = .FALSE. - - sr%results => results - - sr%nalloc = nn ! will be checked - - sr%ind => tp%ind - sr%rearrange = tp%rearrange - IF (tp%rearrange) THEN - sr%DATA => tp%rearranged_data - ELSE - sr%DATA => tp%the_data - END IF - sr%dimen = tp%dimen - - CALL validate_query_storage(nn) - sr%pq = pq_create(results) - - CALL search(tp%root) - - IF (tp%sort) THEN - CALL Kdtree2_sort_results(nn, results) - END IF -! deallocate(sr%pqp) - RETURN -END SUBROUTINE Kdtree2_n_nearest - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Matthew Kennel -! date: 2024-04-10 -! summary: Find nn vectors in the tree. -! -! Find the 'nn' vectors in the tree nearest to point 'idxin', -! with correlation window 'correltime', returing results in -! results(:), which must be pre-allocated upon entry. - -SUBROUTINE Kdtree2_n_nearest_around_point(tp, idxin, correltime, nn, results) - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - INTEGER, INTENT(IN) :: idxin - INTEGER, INTENT(IN) :: correltime - !! correlation window - INTEGER, INTENT(IN) :: nn - TYPE(Kdtree2Result_), TARGET :: results(:) - - ALLOCATE (sr%qv(tp%dimen)) - sr%qv = tp%the_data(:, idxin) - ! copy the vector - sr%ballsize = HUGE(1.0) - ! the largest real(kdkind) number - sr%centeridx = idxin - sr%correltime = correltime - - sr%nn = nn - sr%nfound = 0 - - sr%dimen = tp%dimen - sr%nalloc = nn - - sr%results => results - - sr%ind => tp%ind - sr%rearrange = tp%rearrange - - IF (sr%rearrange) THEN - sr%DATA => tp%rearranged_data - ELSE - sr%DATA => tp%the_data - END IF - - CALL validate_query_storage(nn) - sr%pq = pq_create(results) - - CALL search(tp%root) - - IF (tp%sort) THEN - CALL Kdtree2_sort_results(nn, results) - END IF - DEALLOCATE (sr%qv) - RETURN -END SUBROUTINE Kdtree2_n_nearest_around_point - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! find the nearest neighbors to point 'idxin', within SQUARED -! Euclidean distance 'r2'. Upon ENTRY, nalloc must be the -! size of memory allocated for results(1:nalloc). Upon -! EXIT, nfound is the number actually found within the ball. -! -! Note that if nfound .gt. nalloc then more neighbors were found -! than there were storage to store. The resulting list is NOT -! the smallest ball inside norm r^2 -! -! Results are NOT sorted unless tree was created with sort option. - -SUBROUTINE Kdtree2_r_nearest(tp, qv, r2, nfound, nalloc, results) - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - REAL(kdkind), TARGET, INTENT(IN) :: qv(:) - REAL(kdkind), INTENT(IN) :: r2 - INTEGER, INTENT(out) :: nfound - INTEGER, INTENT(IN) :: nalloc - TYPE(Kdtree2Result_), TARGET :: results(:) - -#ifdef DEBUG_VER - CHARACTER(*), PARAMETER :: msg = & - '[Warning] :: return from Kdtree2_r_nearest found more neighbors' & - //CHAR_LF// & - 'than storage was provided for. Answer is NOT smallest ball' & - //CHAR_LF// & - 'KD_TREE_TRANS: with that number of neighbors! I.e. it is wrong.' -#endif - - ! - sr%qv => qv - sr%ballsize = r2 - sr%nn = 0 ! flag for fixed ball search - sr%nfound = 0 - sr%centeridx = -1 - sr%correltime = 0 - - sr%results => results - - CALL validate_query_storage(nalloc) - sr%nalloc = nalloc - sr%overflow = .FALSE. - sr%ind => tp%ind - sr%rearrange = tp%rearrange - - IF (tp%rearrange) THEN - sr%DATA => tp%rearranged_data - ELSE - sr%DATA => tp%the_data - END IF - sr%dimen = tp%dimen - - CALL search(tp%root) - nfound = sr%nfound - IF (tp%sort) THEN - CALL Kdtree2_sort_results(nfound, results) - END IF - -#ifdef DEBUG_VER - - IF (sr%overflow) THEN - CALL Errormsg( & - msg=msg, & - file=__FILE__, & - line=__LINE__, & - routine="Kdtree2_n_nearest()") - END IF - -#endif - -END SUBROUTINE Kdtree2_r_nearest - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Like Kdtree2_r_nearest, but around a point 'idxin' already existing -! in the data set. -! -! Results are NOT sorted unless tree was created with sort option. -SUBROUTINE Kdtree2_r_nearest_around_point(tp, idxin, correltime, r2, & - nfound, nalloc, results) - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - INTEGER, INTENT(IN) :: idxin, correltime, nalloc - REAL(kdkind), INTENT(IN) :: r2 - INTEGER, INTENT(out) :: nfound - TYPE(Kdtree2Result_), TARGET :: results(:) - -#ifdef DEBUG_VER - CHARACTER(*), PARAMETER :: msg = & - 'warning! return from Kdtree2_r_nearest found more neighbors' & - //CHAR_LF// & - 'than storage was provided for. Answer is NOT smallest ball' & - //CHAR_LF// & - 'with that number of neighbors! I.e. it is wrong.' -#endif - - ALLOCATE (sr%qv(tp%dimen)) - sr%qv = tp%the_data(:, idxin) ! copy the vector - sr%ballsize = r2 - sr%nn = 0 ! flag for fixed r search - sr%nfound = 0 - sr%centeridx = idxin - sr%correltime = correltime - - sr%results => results - - sr%nalloc = nalloc - sr%overflow = .FALSE. - - CALL validate_query_storage(nalloc) - - ! sr%dsl = HUGE(sr%dsl) ! set to huge positive values - ! sr%il = -1 ! set to invalid indexes - - sr%ind => tp%ind - sr%rearrange = tp%rearrange - - IF (tp%rearrange) THEN - sr%DATA => tp%rearranged_data - ELSE - sr%DATA => tp%the_data - END IF - sr%rearrange = tp%rearrange - sr%dimen = tp%dimen - - ! - !sr%dsl = Huge(sr%dsl) ! set to huge positive values - !sr%il = -1 ! set to invalid indexes - ! - - CALL search(tp%root) - nfound = sr%nfound - IF (tp%sort) THEN - CALL Kdtree2_sort_results(nfound, results) - END IF - -#ifdef DEBUG_VER - - IF (sr%overflow) THEN - CALL Errormsg(msg=msg, file=__FILE__, line=__LINE__, & - routine="Kdtree2_r_nearest_around_point()", unitno=stderr) - END IF - -#endif - - DEALLOCATE (sr%qv) -END SUBROUTINE Kdtree2_r_nearest_around_point - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Count the number of neighbors within square distance 'r2'. -FUNCTION Kdtree2_r_count(tp, qv, r2) RESULT(nfound) - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - REAL(kdkind), TARGET, INTENT(IN) :: qv(:) - REAL(kdkind), INTENT(IN) :: r2 - INTEGER :: nfound - - INTRINSIC HUGE - - sr%qv => qv - sr%ballsize = r2 - - sr%nn = 0 ! flag for fixed r search - sr%nfound = 0 - sr%centeridx = -1 - sr%correltime = 0 - - NULLIFY (sr%results) ! for some reason, FTN 95 chokes on '=> null()' - - sr%nalloc = 0 ! we do not allocate any storage but that's OK - ! for counting. - sr%ind => tp%ind - sr%rearrange = tp%rearrange - IF (tp%rearrange) THEN - sr%DATA => tp%rearranged_data - ELSE - sr%DATA => tp%the_data - END IF - sr%dimen = tp%dimen - - sr%overflow = .FALSE. - - CALL search(tp%root) - - nfound = sr%nfound - -END FUNCTION Kdtree2_r_count - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Count the number of neighbors within square distance 'r2' around -! point 'idxin' with decorrelation time 'correltime'. - -FUNCTION Kdtree2_r_count_around_point(tp, idxin, correltime, r2) & - RESULT(nfound) - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - INTEGER, INTENT(IN) :: correltime, idxin - REAL(kdkind), INTENT(IN) :: r2 - INTEGER :: nfound - - ALLOCATE (sr%qv(tp%dimen)) - sr%qv = tp%the_data(:, idxin) - sr%ballsize = r2 - - sr%nn = 0 ! flag for fixed r search - sr%nfound = 0 - sr%centeridx = idxin - sr%correltime = correltime - NULLIFY (sr%results) - - sr%nalloc = 0 ! we do not allocate any storage but that's OK - ! for counting. - - sr%ind => tp%ind - sr%rearrange = tp%rearrange - - IF (sr%rearrange) THEN - sr%DATA => tp%rearranged_data - ELSE - sr%DATA => tp%the_data - END IF - sr%dimen = tp%dimen - - sr%overflow = .FALSE. - - CALL search(tp%root) - - nfound = sr%nfound - -END FUNCTION Kdtree2_r_count_around_point - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-10 -! summary: check storage when run in debug mode - -SUBROUTINE validate_query_storage(n) - INTEGER, INTENT(IN) :: n - -#ifdef DEBUG_VER - - CHARACTER(*), PARAMETER :: msg = "Not enough storage for results" - LOGICAL(LGT) :: problem - - problem = SIZE(sr%results, 1) .LT. n - IF (problem) THEN - CALL ErrorMsg( & - msg=msg, & - line=__LINE__, & - unitno=stderr, & - file=__FILE__, & - routine="validate_query_storage()") - STOP - END IF - -#endif - -END SUBROUTINE validate_query_storage - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! distance between iv[1:n] and qv[1:n] -! .. Function Return Value .. -! re-implemented to improve vectorization. -FUNCTION square_distance(d, iv, qv) RESULT(res) - REAL(kdkind) :: res - INTEGER :: d - REAL(kdkind) :: iv(:), qv(:) - res = SUM((iv(1:d) - qv(1:d))**2) -END FUNCTION square_distance - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! This is the innermost core routine of the kd-tree search. Along -! with "process_terminal_node", it is the performance bottleneck. -! -! This version uses a logically complete secondary search of -! "box in bounds", whether the sear -RECURSIVE SUBROUTINE search(node) - TYPE(Kdtree2Node_), POINTER :: node - - ! internal variables - TYPE(Kdtree2Node_), POINTER :: ncloser, nfarther - INTEGER :: cut_dim, i - REAL(kdkind) :: qval, dis - REAL(kdkind) :: ballsize - REAL(kdkind), POINTER :: qv(:) - TYPE(interval), POINTER :: box(:) - LOGICAL(LGT) :: isok - - isok = (ASSOCIATED(node%left) .AND. ASSOCIATED(node%right)) .EQV. .FALSE. - - IF (isok) THEN - - ! we are on a terminal node - IF (sr%nn .EQ. 0) THEN - CALL process_terminal_node_fixedball(node) - ELSE - CALL process_terminal_node(node) - END IF - RETURN - - END IF - - ! we are not on a terminal node - qv => sr%qv(1:) - cut_dim = node%cut_dim - qval = qv(cut_dim) - - IF (qval < node%cut_val) THEN - ncloser => node%left - nfarther => node%right - dis = (node%cut_val_right - qval)**2 - ! extra = node%cut_val - qval - ELSE - ncloser => node%right - nfarther => node%left - dis = (node%cut_val_left - qval)**2 - ! extra = qval- node%cut_val_left - END IF - - IF (ASSOCIATED(ncloser)) CALL search(ncloser) - - ! we may need to search the second node. - isok = ASSOCIATED(nfarther) - IF (.NOT. isok) RETURN - - ballsize = sr%ballsize - ! dis=extra**2 - - isok = dis <= ballsize - IF (.NOT. isok) RETURN - - ! we do this separately as going on the first cut dimen is often - ! a good idea. - ! note that if extra**2 < sr%ballsize, then the next - ! check will also be false. - box => node%box(1:) - DO i = 1, sr%dimen - IF (i .NE. cut_dim) THEN - dis = dis + dis2_from_bnd(qv(i), box(i)%lower, box(i)%upper) - IF (dis > ballsize) RETURN - END IF - END DO - - ! if we are still here then we need to search mroe. - CALL search(nfarther) - -END SUBROUTINE search - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(kdkind) FUNCTION dis2_from_bnd(x, amin, amax) RESULT(res) - REAL(kdkind), INTENT(IN) :: x, amin, amax - LOGICAL(LGT) :: isok - - res = 0.0 - - isok = x > amax - IF (isok) THEN - res = (x - amax)**2 - RETURN - END IF - - isok = x < amin - IF (isok) res = (amin - x)**2 -END FUNCTION dis2_from_bnd - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Look for actual near neighbors in 'node', and update -! the search results on the sr data structure. -SUBROUTINE process_terminal_node(node) - TYPE(Kdtree2Node_), POINTER :: node - ! - REAL(kdkind), POINTER :: qv(:) - INTEGER, POINTER :: ind(:) - REAL(kdkind), POINTER :: DATA(:, :) - ! - INTEGER :: dimen, i, indexofi, k, centeridx, correltime - REAL(kdkind) :: ballsize, sd, newpri - LOGICAL :: rearrange - TYPE(pq), POINTER :: pqp - ! - ! copy values from sr to local variables - ! - ! - ! Notice, making local pointers with an EXPLICIT lower bound - ! seems to generate faster code. - ! why? I don't know. - qv => sr%qv(1:) - pqp => sr%pq - dimen = sr%dimen - ballsize = sr%ballsize - rearrange = sr%rearrange - ind => sr%ind(1:) - DATA => sr%DATA(1:, 1:) - centeridx = sr%centeridx - correltime = sr%correltime - - ! doing_correl = (centeridx >= 0) ! Do we have a decorrelation window? - ! include_point = .true. ! by default include all points - ! search through terminal bucket. - - mainloop: DO i = node%l, node%u - IF (rearrange) THEN - sd = 0.0 - DO k = 1, dimen - sd = sd + (DATA(k, i) - qv(k))**2 - IF (sd > ballsize) CYCLE mainloop - END DO - indexofi = ind(i) ! only read it if we have not broken out - ELSE - indexofi = ind(i) - sd = 0.0 - DO k = 1, dimen - sd = sd + (DATA(k, indexofi) - qv(k))**2 - IF (sd > ballsize) CYCLE mainloop - END DO - END IF - - IF (centeridx > 0) THEN ! doing correlation interval? - IF (ABS(indexofi - centeridx) < correltime) CYCLE mainloop - END IF - - ! - ! two choices for any point. The list so far is either undersized, - ! or it is not. - ! - ! If it is undersized, then add the point and its distance - ! unconditionally. If the point added fills up the working - ! list then set the sr%ballsize, maximum distance bound (largest distance on - ! list) to be that distance, instead of the initialized +infinity. - ! - ! If the running list is full size, then compute the - ! distance but break out immediately if it is larger - ! than sr%ballsize, "best squared distance" (of the largest element), - ! as it cannot be a good neighbor. - ! - ! Once computed, compare to best_square distance. - ! if it is smaller, then delete the previous largest - ! element and add the new one. - - IF (sr%nfound .LT. sr%nn) THEN - ! - ! add this point unconditionally to fill list. - ! - sr%nfound = sr%nfound + 1 - newpri = pq_insert(pqp, sd, indexofi) - IF (sr%nfound .EQ. sr%nn) ballsize = newpri - ! we have just filled the working list. - ! put the best square distance to the maximum value - ! on the list, which is extractable from the PQ. - - ELSE - ! - ! now, if we get here, - ! we know that the current node has a squared - ! distance smaller than the largest one on the list, and - ! belongs on the list. - ! Hence we replace that with the current one. - ! - ballsize = pq_replace_max(pqp, sd, indexofi) - END IF - END DO mainloop - ! - ! Reset sr variables which may have changed during loop - ! - sr%ballsize = ballsize - -END SUBROUTINE process_terminal_node - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Look for actual near neighbors in 'node', and update -! the search results on the sr data structure, i.e. -! save all within a fixed ball. -SUBROUTINE process_terminal_node_fixedball(node) - TYPE(Kdtree2Node_), POINTER :: node - ! - REAL(kdkind), POINTER :: qv(:) - INTEGER, POINTER :: ind(:) - REAL(kdkind), POINTER :: DATA(:, :) - ! - INTEGER :: nfound - INTEGER :: dimen, i, indexofi, k - INTEGER :: centeridx, correltime, nn - REAL(kdkind) :: ballsize, sd - LOGICAL :: rearrange - - ! copy values from sr to local variables - qv => sr%qv(1:) - dimen = sr%dimen - ballsize = sr%ballsize - rearrange = sr%rearrange - ind => sr%ind(1:) - DATA => sr%DATA(1:, 1:) - centeridx = sr%centeridx - correltime = sr%correltime - nn = sr%nn ! number to search for - nfound = sr%nfound - - ! search through terminal bucket. - mainloop: DO i = node%l, node%u - - ! - ! two choices for any point. The list so far is either undersized, - ! or it is not. - ! - ! If it is undersized, then add the point and its distance - ! unconditionally. If the point added fills up the working - ! list then set the sr%ballsize, maximum distance bound - ! (largest distance on list) to be that distance, - ! instead of the initialized +infinity. - ! - ! If the running list is full size, then compute the - ! distance but break out immediately if it is larger - ! than sr%ballsize, "best squared distance" (of the largest element), - ! as it cannot be a good neighbor. - ! - ! Once computed, compare to best_square distance. - ! if it is smaller, then delete the previous largest - ! element and add the new one. - - ! which index to the point do we use? - - IF (rearrange) THEN - sd = 0.0 - DO k = 1, dimen - sd = sd + (DATA(k, i) - qv(k))**2 - IF (sd > ballsize) CYCLE mainloop - END DO - indexofi = ind(i) ! only read it if we have not broken out - ELSE - indexofi = ind(i) - sd = 0.0 - DO k = 1, dimen - sd = sd + (DATA(k, indexofi) - qv(k))**2 - IF (sd > ballsize) CYCLE mainloop - END DO - END IF - - IF (centeridx > 0) THEN ! doing correlation interval? - IF (ABS(indexofi - centeridx) < correltime) CYCLE mainloop - END IF - - nfound = nfound + 1 - IF (nfound .GT. sr%nalloc) THEN - ! oh nuts, we have to add another one to the tree but - ! there isn't enough room. - sr%overflow = .TRUE. - ELSE - sr%results(nfound)%dis = sd - sr%results(nfound)%idx = indexofi - END IF - END DO mainloop - - ! Reset sr variables which may have changed during loop - sr%nfound = nfound -END SUBROUTINE process_terminal_node_fixedball - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Matthew Kennel -! date: 2024-04-10 -! summary: Used for benchmarking only -! -! find the 'n' nearest neighbors to 'qv' by exhaustive search. -! only use this subroutine for testing, as it is SLOW! The -! whole point of a k-d tree is to avoid doing what this subroutine -! does. - -SUBROUTINE Kdtree2_n_nearest_brute_force(tp, qv, nn, results) - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - REAL(kdkind), INTENT(IN) :: qv(:) - INTEGER, INTENT(IN) :: nn - TYPE(Kdtree2Result_) :: results(:) - - INTEGER :: i, j, k - REAL(kdkind), ALLOCATABLE :: all_distances(:) - ! .. - ALLOCATE (all_distances(tp%n)) - DO i = 1, tp%n - all_distances(i) = square_distance(tp%dimen, qv, tp%the_data(:, i)) - END DO - ! now find 'n' smallest distances - DO i = 1, nn - results(i)%dis = HUGE(1.0) - results(i)%idx = -1 - END DO - DO i = 1, tp%n - IF (all_distances(i) < results(nn)%dis) THEN - ! insert it somewhere on the list - DO j = 1, nn - IF (all_distances(i) < results(j)%dis) EXIT - END DO - ! now we know 'j' - DO k = nn - 1, j, -1 - results(k + 1) = results(k) - END DO - results(j)%dis = all_distances(i) - results(j)%idx = i - END IF - END DO - DEALLOCATE (all_distances) -END SUBROUTINE Kdtree2_n_nearest_brute_force - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE Kdtree2_r_nearest_brute_force(tp, qv, r2, nfound, results) - ! find the nearest neighbors to 'qv' with distance**2 <= r2 by exhaustive - ! search. - ! only use this subroutine for testing, as it is SLOW! The - ! whole point of a k-d tree is to avoid doing what this subroutine - ! does. - TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp - REAL(kdkind), INTENT(IN) :: qv(:) - REAL(kdkind), INTENT(IN) :: r2 - INTEGER, INTENT(out) :: nfound - TYPE(Kdtree2Result_) :: results(:) - - INTEGER :: i, nalloc - REAL(kdkind), ALLOCATABLE :: all_distances(:) - ! .. - ALLOCATE (all_distances(tp%n)) - DO i = 1, tp%n - all_distances(i) = square_distance(tp%dimen, qv, tp%the_data(:, i)) - END DO - - nfound = 0 - nalloc = SIZE(results, 1) - - DO i = 1, tp%n - IF (all_distances(i) < r2) THEN - ! insert it somewhere on the list - IF (nfound .LT. nalloc) THEN - nfound = nfound + 1 - results(nfound)%dis = all_distances(i) - results(nfound)%idx = i - END IF - END IF - END DO - DEALLOCATE (all_distances) - - CALL Kdtree2_sort_results(nfound, results) - -END SUBROUTINE Kdtree2_r_nearest_brute_force - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Use after search to sort results(1:nfound) in order of increasing -! distance. -SUBROUTINE Kdtree2_sort_results(nfound, results) - INTEGER, INTENT(IN) :: nfound - TYPE(Kdtree2Result_), TARGET :: results(:) - IF (nfound .GT. 1) CALL heapsort_struct(results, nfound) -END SUBROUTINE Kdtree2_sort_results - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Sort a(1:n) in ascending order -SUBROUTINE heapsort_struct(a, n) - INTEGER, INTENT(IN) :: n - TYPE(Kdtree2Result_), INTENT(INOUT) :: a(:) - - TYPE(Kdtree2Result_) :: VALUE ! temporary value - INTEGER :: i, j - INTEGER :: ileft, iright - - ileft = n / 2 + 1 - iright = n - - IF (n .EQ. 1) RETURN - - DO - IF (ileft > 1) THEN - ileft = ileft - 1 - VALUE = a(ileft) - ELSE - VALUE = a(iright) - a(iright) = a(1) - iright = iright - 1 - IF (iright == 1) THEN - a(1) = VALUE - RETURN - END IF - END IF - - i = ileft - j = 2 * ileft - DO WHILE (j <= iright) - IF (j < iright) THEN - IF (a(j)%dis < a(j + 1)%dis) j = j + 1 - END IF - IF (VALUE%dis < a(j)%dis) THEN - a(i) = a(j); - i = j - j = j + j - ELSE - j = iright + 1 - END IF - END DO - a(i) = VALUE - - END DO -END SUBROUTINE heapsort_struct - -END MODULE Kdtree2_Module diff --git a/src/modules/KeyValue/CMakeLists.txt b/src/modules/KeyValue/CMakeLists.txt deleted file mode 100644 index 5decd65fb..000000000 --- a/src/modules/KeyValue/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/KeyValue_Method.F90 -) diff --git a/src/modules/KeyValue/src/KeyValue_Method.F90 b/src/modules/KeyValue/src/KeyValue_Method.F90 deleted file mode 100644 index 6c4c7cd9c..000000000 --- a/src/modules/KeyValue/src/KeyValue_Method.F90 +++ /dev/null @@ -1,1227 +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: 4 March 2021 -! summary: This module contains interfaces of methods related to [[keyvalue_]] -! -!### Usage -! -! ```fortran -! program main -! use easifem -! implicit none -! type( keyvalue_ ) :: obj -! real( dfp ) :: vec( 3 ), mat( 3, 3 ) -! call random_number( vec ) -! call random_number( mat ) -! obj = keyvalue( 'real-rank-0', 1.0_dfp ) -! obj = 1.0_dfp -! call display( obj, 'obj' ) -! obj = keyvalue( 'real-rank-1', vec ) -! obj = [1.0_dfp, 1.0_dfp, 1.0_dfp] -! call display( obj, 'obj' ) -! obj = keyvalue( 'real-rank-2', mat ) -! call display( obj, 'obj' ) -! end program main -! ``` - -MODULE KeyValue_Method -USE BaseType -USE GlobalData -USE String_Class, ONLY:String -IMPLICIT NONE -PRIVATE -INTEGER, PARAMETER :: REAL_RANK_0 = 0 -INTEGER, PARAMETER :: REAL_RANK_1 = 1 -INTEGER, PARAMETER :: REAL_RANK_2 = 2 -INTEGER, PARAMETER :: INT_RANK_0 = 3 -INTEGER, PARAMETER :: INT_RANK_1 = 4 -INTEGER, PARAMETER :: INT_RANK_2 = 5 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = char` -! - `Value = Real Rank 0` -! -!### Usage -! -! ```fortran -! call initiate( obj, Key = 'E', Value = 1.0_dfp ) -! ``` - -MODULE PURE SUBROUTINE Initiate1( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value -END SUBROUTINE Initiate1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = string` -! - `Value = Real Rank 0` -! -!### Usage -! -! ```fortran -! call initiate( obj, Key = string('E'), Value = 1.0_dfp ) -! ``` - -MODULE PURE SUBROUTINE Initiate2( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value -END SUBROUTINE Initiate2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = char` -! - `Value = Real Rank 1` - -MODULE PURE SUBROUTINE Initiate3( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( : ) -END SUBROUTINE Initiate3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = String` -! - `Value = Real Rank 1` - -MODULE PURE SUBROUTINE Initiate4( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( : ) -END SUBROUTINE Initiate4 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = char` -! - `Value = Real Rank 2` - -MODULE PURE SUBROUTINE Initiate5( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( :, : ) -END SUBROUTINE Initiate5 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = String` -! - `Value = Real Rank 2` - -MODULE PURE SUBROUTINE Initiate6( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( :, : ) -END SUBROUTINE Initiate6 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = char` -! - `Value = Int Rank 0` - -MODULE PURE SUBROUTINE Initiate7( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value -END SUBROUTINE Initiate7 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = String` -! - `Value = Int Rank 0` - -MODULE PURE SUBROUTINE Initiate8( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value -END SUBROUTINE Initiate8 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = char` -! - `Value = Int Rank 1` - -MODULE PURE SUBROUTINE Initiate9( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( : ) -END SUBROUTINE Initiate9 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = string` -! - `Value = Int Rank 1` - -MODULE PURE SUBROUTINE Initiate10( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( : ) -END SUBROUTINE Initiate10 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = char` -! - `Value = Int Rank 2` - -MODULE PURE SUBROUTINE Initiate11( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) -END SUBROUTINE Initiate11 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object -! - `Key = string` -! - `Value = Int Rank 2` - -MODULE PURE SUBROUTINE Initiate12( obj, Key, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) -END SUBROUTINE Initiate12 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that initiate instance of [[KeyValue_]] - -!> author: Dr. Vikas Sharma -! -! This suborutine constructs [[keyvalue_]] object - -MODULE PURE SUBROUTINE Initiate13( obj, obj2 ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - CLASS( keyValue_ ), INTENT( IN ) :: obj2 -END SUBROUTINE Initiate13 -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE Initiate1, Initiate2, Initiate3, Initiate4, & - & Initiate5, Initiate6, Initiate7, Initiate8, Initiate9, & - & Initiate10, Initiate11, Initiate12, Initiate13 -END INTERFACE Initiate - -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Constructor1( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value -END FUNCTION Constructor1 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Constructor2( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value -END FUNCTION Constructor2 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor3( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor3 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor4( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor4 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor5( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor5 -end INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor6( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor6 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Constructor7( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value -END FUNCTION Constructor7 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Constructor8( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value -END FUNCTION Constructor8 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor9( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor9 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor10( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor10 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor11( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor11 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Function that constructs [[keyvalue_]] - -MODULE PURE FUNCTION Constructor12( Key, Value ) RESULT( Ans ) - TYPE( keyValue_ ) :: Ans - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor12 -END INTERFACE - -INTERFACE KeyValue - MODULE PROCEDURE Constructor1, Constructor2, Constructor3, & - & Constructor4, Constructor5, Constructor6, Constructor7, & - & Constructor8, Constructor9, Constructor10, Constructor11, & - & Constructor12 -END INTERFACE KeyValue - -PUBLIC :: KeyValue - - -INTERFACE -MODULE PURE FUNCTION Contains2( obj, Key ) RESULT( Ans ) - TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) - TYPE( String ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Contains2 -END INTERFACE - -INTERFACE OPERATOR( .CONTAINS. ) - MODULE PROCEDURE Present1, Present2, Contains1, Contains2 -END INTERFACE OPERATOR( .CONTAINS. ) - -PUBLIC :: OPERATOR( .CONTAINS. ) - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_1( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value -END FUNCTION Constructor_1 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_2( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value -END FUNCTION Constructor_2 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_3( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor_3 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_4( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor_4 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_5( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor_5 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_6( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - TYPE( String ), INTENT( IN ) :: Key - REAL( DFP ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor_6 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_7( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value -END FUNCTION Constructor_7 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_8( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value -END FUNCTION Constructor_8 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_9( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor_9 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_10( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( : ) -END FUNCTION Constructor_10 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_11( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor_11 -END INTERFACE - -!---------------------------------------------------------------------------- -! KeyValue_Pointer@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE FUNCTION Constructor_12( Key, Value ) RESULT( Ans ) - CLASS( keyValue_ ), POINTER :: Ans - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) -END FUNCTION Constructor_12 -END INTERFACE - -INTERFACE KeyValue_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3, & - & Constructor_4, Constructor_5, Constructor_6, Constructor_7, & - & Constructor_8, Constructor_9, Constructor_10, Constructor_11, & - & Constructor_12 -END INTERFACE KeyValue_Pointer - -PUBLIC :: KeyValue_Pointer - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -INTERFACE -!! This subroutine display contents of [[keyvalue_]] - -MODULE SUBROUTINE keyvalue_display( obj, msg, UnitNo ) - CLASS( keyValue_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: msg - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo -END SUBROUTINE keyvalue_display -END INTERFACE - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -INTERFACE -!! Display content of vector of [[keyvalue_]] - -MODULE SUBROUTINE mp_display( obj, msg, unitno ) - TYPE( keyvalue_ ), INTENT( IN ) :: obj( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: msg - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo -END SUBROUTINE mp_display -END INTERFACE - -!> Generic subroutine to display content of [[keyvalue_]] -INTERFACE Display - MODULE PROCEDURE keyvalue_display, mp_display -END INTERFACE Display - -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -INTERFACE -!! Function to check equality in [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Equal1( obj, Key ) RESULT( Ans ) - CLASS( KeyValue_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Equal1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -INTERFACE -!! Function to check equality in [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Equal2( Key, obj ) RESULT( Ans ) - CLASS( KeyValue_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Equal2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -INTERFACE -!! Function to check equality in [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Equal3( obj, Key ) RESULT( Ans ) - CLASS( KeyValue_ ), INTENT( IN ) :: obj - TYPE( String ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Equal3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -INTERFACE -!! Function to check equality in [[keyvalue_]] - -MODULE ELEMENTAL FUNCTION Equal4( Key, obj ) RESULT( Ans ) - CLASS( KeyValue_ ), INTENT( IN ) :: obj - TYPE( String ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Equal4 -END INTERFACE - -INTERFACE OPERATOR( .EQ. ) - MODULE PROCEDURE Equal1, Equal2, Equal3, Equal4 -END INTERFACE OPERATOR( .EQ. ) - -PUBLIC :: OPERATOR( .EQ. ) - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE SUBROUTINE keyvalue_deallocate( obj ) - CLASS( KeyValue_ ), INTENT( INOUT ) :: obj -END SUBROUTINE keyvalue_deallocate -END INTERFACE - -INTERFACE Deallocate - MODULE PROCEDURE keyvalue_deallocate -END INTERFACE Deallocate - -PUBLIC :: Deallocate - - - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set value in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set real scalar value in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = 1.0_dfp -! ``` - -MODULE PURE SUBROUTINE SetValue1( obj, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Value -END SUBROUTINE SetValue1 -END INTERFACE - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set value in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set real vector value in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = vec1 -! ``` - -MODULE PURE SUBROUTINE SetValue2( obj, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Value( : ) -END SUBROUTINE SetValue2 -END INTERFACE - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set value in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set real matrix value in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = mat -! ``` - -MODULE PURE SUBROUTINE SetValue3( obj, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Value( :, : ) -END SUBROUTINE SetValue3 -END INTERFACE - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set value in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set integer scalar value in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = intval -! ``` - -MODULE PURE SUBROUTINE SetValue4( obj, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Value -END SUBROUTINE SetValue4 -END INTERFACE - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set value in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set integer vector value in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = intvec -! ``` - -MODULE PURE SUBROUTINE SetValue5( obj, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Value( : ) -END SUBROUTINE SetValue5 -END INTERFACE - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set value in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set integer matrix value in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = intmat -! ``` - -MODULE PURE SUBROUTINE SetValue6( obj, Value ) - CLASS( keyValue_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) -END SUBROUTINE SetValue6 -END INTERFACE - -!> Generic subroutine to set values in [[keyvalue_]] -INTERFACE setValue - MODULE PROCEDURE SetValue1, SetValue2, SetValue3, SetValue4, & - & SetValue5, SetValue6 -END INTERFACE setValue - -PUBLIC :: setValue - -INTERFACE ASSIGNMENT( = ) - MODULE PROCEDURE SetValue1, SetValue2, SetValue3, SetValue4, & - & SetValue5, SetValue6 -END INTERFACE ASSIGNMENT( = ) - -PUBLIC :: ASSIGNMENT( = ) - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set key in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set key in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = "hello" -! ``` - -MODULE PURE SUBROUTINE setKey1( obj, Key ) - CLASS( KeyValue_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Key -END SUBROUTINE setKey1 -END INTERFACE - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -INTERFACE -!! Set key in [[keyvalue_]] object - -!> author: Dr. Vikas Sharma -! -! This subroutine set key in [[keyvalue_]] -! -!### Usage -! -! ```fortran -! obj = string( "hello" ) -! ``` - -MODULE PURE SUBROUTINE setKey2( obj, Key ) - CLASS( KeyValue_ ), INTENT( INOUT ) :: obj - TYPE( String ), INTENT( IN ) :: Key -END SUBROUTINE setKey2 -END INTERFACE - -!> Generic subroutine to set key in [[keyvalue_]] -INTERFACE setKey - MODULE PROCEDURE setKey1, setKey2 -END INTERFACE setKey - -PUBLIC :: setKey - -INTERFACE ASSIGNMENT( = ) - MODULE PROCEDURE setKey1, setKey2 -END INTERFACE ASSIGNMENT( = ) - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -INTERFACE -!! Subroutine that append `keyvalue_` instance to an array of [[keyvalue_]] -!! type - -MODULE PURE SUBROUTINE keyvalue_append( obj, KeyValobj ) - TYPE( KeyValue_ ), ALLOCATABLE, INTENT( INOUT ) :: obj( : ) - TYPE( KeyValue_), INTENT( IN ) :: KeyValobj -END SUBROUTINE keyvalue_append -END INTERFACE - -INTERFACE Append - MODULE PROCEDURE keyvalue_append -END INTERFACE Append - -PUBLIC :: Append - - -!---------------------------------------------------------------------------- -! getKey -!---------------------------------------------------------------------------- - -INTERFACE -!! get key from [[keyvalue_]] - -MODULE PURE SUBROUTINE getKey1( Key, obj ) - CLASS( KeyValue_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( INOUT ) :: Key -END SUBROUTINE getKey1 -END INTERFACE - -!---------------------------------------------------------------------------- -! getKey -!---------------------------------------------------------------------------- - -INTERFACE -!! get key from [[keyvalue_]] - -MODULE PURE SUBROUTINE getKey2( Key, obj ) - CLASS( KeyValue_ ), INTENT( IN ) :: obj - TYPE( String ), INTENT( INOUT ) :: Key -END SUBROUTINE getKey2 -END INTERFACE - -!> Generic subroutine to get key from [[keyvalue_]] -INTERFACE getKey - MODULE PROCEDURE getKey1, getKey2 -END INTERFACE getKey - -PUBLIC :: getKey - -INTERFACE ASSIGNMENT( = ) - MODULE PROCEDURE getKey1, getKey2 -END INTERFACE ASSIGNMENT( = ) - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -INTERFACE -!! getValue from [[keyvalue_]] - -MODULE PURE SUBROUTINE getValue1( Value, obj ) - CLASS( keyValue_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( INOUT ) :: Value -END SUBROUTINE getValue1 -END INTERFACE - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -INTERFACE -!! getValue from [[keyvalue_]] - -MODULE PURE SUBROUTINE getValue2( Value, obj ) - CLASS( keyValue_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: Value( : ) -END SUBROUTINE getValue2 -END INTERFACE - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -INTERFACE -!! getValue from [[keyvalue_]] - -MODULE PURE SUBROUTINE getValue3( Value, obj ) - CLASS( keyValue_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: Value( :, : ) -END SUBROUTINE getValue3 -END INTERFACE - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -INTERFACE -!! getValue from [[keyvalue_]] - -MODULE PURE SUBROUTINE getValue4( Value, obj ) - CLASS( keyValue_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( INOUT ) :: Value -END SUBROUTINE getValue4 -END INTERFACE - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -INTERFACE -!! getValue from [[keyvalue_]] - -MODULE PURE SUBROUTINE getValue5( Value, obj ) - CLASS( keyValue_ ), INTENT( IN ) :: obj - INTEGER( I4B ), ALLOCATABLE, INTENT( INOUT ) :: Value( : ) -END SUBROUTINE getValue5 -END INTERFACE - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -INTERFACE -!! getValue from [[keyvalue_]] - -MODULE PURE SUBROUTINE getValue6( Value, obj ) - CLASS( keyValue_ ), INTENT( IN ) :: obj - INTEGER( I4B ), ALLOCATABLE, INTENT( INOUT ) :: Value( :, : ) -END SUBROUTINE getValue6 -END INTERFACE - -!> Generic subroutine to get value from [[keyvalue_]] -INTERFACE getValue - MODULE PROCEDURE getValue1, getValue2, getValue3, getValue4, & - & getValue5, getValue6 -END INTERFACE getValue - -PUBLIC :: getValue - -INTERFACE ASSIGNMENT( = ) - MODULE PROCEDURE getValue1, getValue2, getValue3, getValue4, & - & getValue5, getValue6 -END INTERFACE ASSIGNMENT( = ) - -!---------------------------------------------------------------------------- -! Index -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION Index1( obj, Key ) RESULT( Ans ) - TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: Key - INTEGER( I4B ) :: Ans -END FUNCTION Index1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Index -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION Index2( obj, Key ) RESULT( Ans ) - TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) - TYPE( String ), INTENT( IN ) :: Key - INTEGER( I4B ) :: Ans -END FUNCTION Index2 -END INTERFACE - -INTERFACE IndexOf - MODULE PROCEDURE Index1, Index2 -END INTERFACE IndexOf - -PUBLIC :: IndexOf - -INTERFACE OPERATOR( .INDEX. ) - MODULE PROCEDURE Index1, Index2 -END INTERFACE OPERATOR( .INDEX. ) - -PUBLIC :: OPERATOR( .INDEX. ) - -!---------------------------------------------------------------------------- -! Present -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION Present1( Key, obj ) RESULT( Ans ) - TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Present1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Present -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION Present2( Key, obj ) RESULT( Ans ) - TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) - TYPE( String ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Present2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Contains -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION Contains1( obj, Key ) RESULT( Ans ) - TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: Key - LOGICAL( LGT ) :: Ans -END FUNCTION Contains1 -END INTERFACE - -!------------------------------------------------------------------------------ -! Contains2 -!------------------------------------------------------------------------------ -END MODULE KeyValue_Method \ No newline at end of file diff --git a/src/modules/LISInterface/CMakeLists.txt b/src/modules/LISInterface/CMakeLists.txt deleted file mode 100644 index e1fa3539b..000000000 --- a/src/modules/LISInterface/CMakeLists.txt +++ /dev/null @@ -1,27 +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 -# - -# IF( USE_LIS ) -# SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -# TARGET_SOURCES( -# ${PROJECT_NAME} PRIVATE -# ${src_path}/LISParam.F90 -# ${src_path}/LISBasic.F90 -# ${src_path}/LISVector.F90 -# ${src_path}/LISInterface.F90 -# ) -# ENDIF( ) diff --git a/src/modules/LISInterface/src/LISBasic.F90 b/src/modules/LISInterface/src/LISBasic.F90 deleted file mode 100644 index bc86b4d62..000000000 --- a/src/modules/LISInterface/src/LISBasic.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 -! - -MODULE LISBasic -USE GlobalData, ONLY: I4B -IMPLICIT NONE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - - SUBROUTINE lis_init_f(ierr) - IMPORT :: I4B - INTEGER(I4B), INTENT(IN) :: ierr - END SUBROUTINE lis_init_f -END INTERFACE - -PUBLIC :: lis_initialize - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_finalize(void); - -INTERFACE - FUNCTION lis_finalize() & - & BIND(C, name="lis_finalize") - IMPORT :: I4B - INTEGER(I4B) :: lis_finalize - END FUNCTION lis_finalize -END INTERFACE - -PUBLIC :: lis_finalize - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -FUNCTION lis_initialize() - INTEGER(I4B) :: lis_initialize - CALL lis_init_f(lis_initialize) -END FUNCTION lis_initialize - -END MODULE LISBasic diff --git a/src/modules/LISInterface/src/LISInterface.F90 b/src/modules/LISInterface/src/LISInterface.F90 deleted file mode 100644 index 4aceb516e..000000000 --- a/src/modules/LISInterface/src/LISInterface.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 -! - -MODULE LISInterface -! USE LISParam -! USE LISBasic -! USE LISVector -END MODULE LISInterface diff --git a/src/modules/LISInterface/src/LISParam.F90 b/src/modules/LISInterface/src/LISParam.F90 deleted file mode 100644 index 6f8edeb7c..000000000 --- a/src/modules/LISInterface/src/LISParam.F90 +++ /dev/null @@ -1,128 +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 -! - -! #ifdef LONG__LONG -! #define LIS_INTEGER integer*8 -! #else -! #define LIS_INTEGER integer -! #endif -! -! #ifdef LONG__DOUBLE -! #ifdef COMPLEX -! #define LIS_SCALAR complex*32 -! #else -! #define LIS_SCALAR real*16 -! #endif -! #define LIS_COMPLEX complex*32 -! #define LIS_REAL real*16 -! #else -! #ifdef COMPLEX -! #define LIS_SCALAR complex*16 -! #else -! #define LIS_SCALAR real*8 -! #endif -! #define LIS_COMPLEX complex*16 -! #define LIS_REAL real*8 -! #endif -! -! #define LIS_Comm LIS_INTEGER -! -! #ifdef USE_MPI -! #ifndef WIN32 -! INCLUDE 'mpif.h' -! #else -! #include 'mpif.h' -! #endif -! -! #ifdef LONG__LONG -! #define LIS_MPI_INTEGER MPI_INTEGER -! #else -! #define LIS_MPI_INTEGER MPI_INTEGER -! #endif -! -! #define LIS_COMM_WORLD MPI_COMM_WORLD -! #else -! #define LIS_COMM_WORLD 1 -! #endif - -MODULE LISParam -USE GlobalData, ONLY: I4B, DFP, LGT, INT32, INT64 -IMPLICIT NONE -PRIVATE - -INTEGER(I4B), PUBLIC, PARAMETER :: LIS_TRUE = 1 -INTEGER(I4B), PUBLIC, PARAMETER :: LIS_FALSE = 0 -INTEGER(I4B), PUBLIC, PARAMETER :: LIS_INS_VALUE = 0 -INTEGER(I4B), PUBLIC, PARAMETER :: LIS_ADD_VALUE = 1 -INTEGER(I4B), PUBLIC, PARAMETER :: LIS_SUB_VALUE = 2 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_ASSEMBLING = 0 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CSR = 1 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CSC = 2 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_MSR = 3 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DIA = 4 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CDS = 4 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_ELL = 5 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_JAD = 6 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BSR = 7 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BSC = 8 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_VBR = 9 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_COO = 10 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DENSE = 11 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DNS = 11 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_RCO = 255 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_TJAD = 12 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BJAD = 13 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BCR = 14 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CJAD = 15 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_PCSR = 16 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_LCSR = 17 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_LJAD = 18 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_LBSR = 19 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CDIA = 20 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_MSC = 21 -INTEGER(i4b), public, PARAMETER :: LIS_MATRIX_DECIDING_SIZE = -(LIS_MATRIX_RCO + 1) -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_NULL = -(LIS_MATRIX_RCO + 2) -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DEFAULT = LIS_MATRIX_CSR -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_POINT = LIS_MATRIX_CSR -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BLOCK = LIS_MATRIX_BSR -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SCALE_NONE = 0 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SCALE_JACOBI = 1 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SCALE_SYMM_DIAG = 2 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_AUTO = 0 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_PLAIN = 1 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_MM = 2 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_LIS = 3 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_LIS_ASCII = 3 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_LIS_BINARY = 4 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_FREE = 5 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_ITBL = 6 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_HB = 7 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_MMB = 8 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_BINARY_BIG = 0 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_BINARY_LITTLE = 1 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FAILS = -1 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SUCCESS = 0 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ILL_OPTION = 1 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_ILL_ARG = 1 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_BREAKDOWN = 2 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_OUT_OF_MEMORY = 3 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_OUT_OF_MEMORY = 3 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MAXITER = 4 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_NOT_IMPLEMENTED = 5 -INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_FILE_IO = 6 - -END MODULE LISParam diff --git a/src/modules/LISInterface/src/LISVector.F90 b/src/modules/LISInterface/src/LISVector.F90 deleted file mode 100644 index 394785de7..000000000 --- a/src/modules/LISInterface/src/LISVector.F90 +++ /dev/null @@ -1,434 +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 LISVector -USE ISO_C_BINDING -USE GlobalData, ONLY: I4B, DFP, LGT -USE Display_Method, ONLY: Display -IMPLICIT NONE -PRIVATE - -! struct LIS_VECTOR_STRUCT -! { -! LIS_INT label; -! LIS_INT status; -! LIS_INT precision; -! LIS_INT gn; -! LIS_INT n; -! LIS_INT np; -! LIS_INT pad; -! LIS_INT origin; -! LIS_INT is_copy; -! LIS_INT is_destroy; -! LIS_INT is_scaled; -! LIS_INT my_rank; -! LIS_INT nprocs; -! LIS_Comm comm; -! LIS_INT is; -! LIS_INT ie; -! LIS_INT *ranges; -! LIS_SCALAR *value; -! LIS_SCALAR *value_lo; -! LIS_SCALAR *work; -! LIS_INT intvalue; -! }; -! typedef struct LIS_VECTOR_STRUCT *LIS_VECTOR; - -TYPE, BIND(C) :: LIS_VECTOR - INTEGER(I4B) :: label; - INTEGER(I4B) :: status; - INTEGER(I4B) :: PRECISION; - INTEGER(I4B) :: gn; - INTEGER(I4B) :: n; - INTEGER(I4B) :: np; - INTEGER(I4B) :: pad; - INTEGER(I4B) :: origin; - INTEGER(I4B) :: is_copy; - INTEGER(I4B) :: is_destroy; - INTEGER(I4B) :: is_scaled; - INTEGER(I4B) :: my_rank; - INTEGER(I4B) :: nprocs; - INTEGER(I4B) :: comm; - INTEGER(I4B) :: is; - INTEGER(I4B) :: ie; - TYPE(C_PTR) :: ranges; - TYPE(C_PTR) :: VALUE; - TYPE(C_PTR) :: value_lo; - TYPE(C_PTR) :: work; - INTEGER(I4B) :: intvalue; -END TYPE LIS_VECTOR - -PUBLIC :: LIS_VECTOR - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE Display - MODULE PROCEDURE display_lisvector -END INTERFACE Display - -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_create(LIS_Comm comm, LIS_VECTOR *vec); - -INTERFACE - FUNCTION lis_vector_create(comm, vec) BIND(C, name="lis_vector_create") - IMPORT :: LIS_VECTOR, I4B - INTEGER(I4B), VALUE, INTENT(in) :: comm - TYPE(LIS_VECTOR), INTENT(INOUT) :: vec - INTEGER(I4B) :: lis_vector_create - END FUNCTION lis_vector_create -END INTERFACE - -PUBLIC :: lis_vector_create - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_set_size(LIS_VECTOR vec, LIS_INT local_n, & -! LIS_INT global_n); - -INTERFACE - FUNCTION lis_vector_set_size(vec, local_n, global_n) & - & BIND(C, name="lis_vector_set_size") - IMPORT :: LIS_VECTOR, I4B, C_PTR - TYPE(LIS_VECTOR), INTENT(INOUT) :: vec - INTEGER(I4B), VALUE, INTENT(IN) :: local_n - INTEGER(I4B), VALUE, INTENT(IN) :: global_n - INTEGER(I4B) :: lis_vector_set_size - END FUNCTION lis_vector_set_size -END INTERFACE - -PUBLIC :: lis_vector_set_size - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_psd_reset_scale(LIS_VECTOR vec); - -INTERFACE - FUNCTION lis_vector_psd_reset_scale(vec) & - & BIND(C, name="lis_vector_psd_reset_scale") - IMPORT :: LIS_VECTOR, I4B - TYPE(LIS_VECTOR), INTENT(INOUT) :: vec - INTEGER(I4B) :: lis_vector_psd_reset_scale - END FUNCTION lis_vector_psd_reset_scale -END INTERFACE - -PUBLIC :: lis_vector_psd_reset_scale - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_destroy(LIS_VECTOR vec); - -INTERFACE - FUNCTION lis_vector_destroy(vec) & - & BIND(C, name="lis_vector_destroy") - IMPORT :: LIS_VECTOR, I4B - TYPE(LIS_VECTOR), INTENT(INOUT) :: vec - INTEGER(I4B) :: lis_vector_destroy - END FUNCTION lis_vector_destroy -END INTERFACE - -PUBLIC :: lis_vector_destroy - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_duplicate(void *vin, LIS_VECTOR *vout); - -INTERFACE - FUNCTION lis_vector_duplicate(vin, vout) BIND(C, name="lis_vector_duplicate") - IMPORT :: LIS_VECTOR, C_PTR, I4B - TYPE(C_PTR), INTENT(IN) :: vin - TYPE(LIS_VECTOR), INTENT(INOUT) :: vout - INTEGER(I4B) :: lis_vector_duplicate - END FUNCTION lis_vector_duplicate -END INTERFACE - -PUBLIC :: lis_vector_duplicate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_get_size(LIS_VECTOR v, LIS_INT *local_n, LIS_INT *global_n); - -INTERFACE - FUNCTION lis_vector_get_size(v, local_n, global_n) & - & BIND(C, name="lis_vector_get_size") - IMPORT :: LIS_VECTOR, I4B - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B), INTENT(INOUT) :: local_n - INTEGER(I4B), INTENT(INOUT) :: global_n - INTEGER(I4B) :: lis_vector_get_size - END FUNCTION lis_vector_get_size -END INTERFACE - -PUBLIC :: lis_vector_get_size - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_get_range(LIS_VECTOR v, LIS_INT *is, LIS_INT *ie); - -INTERFACE - FUNCTION lis_vector_get_range(v, is, ie) & - & BIND(C, name="lis_vector_get_range") - IMPORT :: LIS_VECTOR, I4B - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B), INTENT(INOUT) :: is - INTEGER(I4B), INTENT(INOUT) :: ie - INTEGER(I4B) :: lis_vector_get_range - END FUNCTION lis_vector_get_range -END INTERFACE - -PUBLIC :: lis_vector_get_range - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_get_value(LIS_VECTOR v, LIS_INT i, LIS_SCALAR *value); - -INTERFACE - FUNCTION lis_vector_get_value(v, i, VALUE) & - & BIND(C, name="lis_vector_get_value") - IMPORT :: LIS_VECTOR, I4B, DFP - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B), VALUE, INTENT(IN) :: i - REAL(DFP), INTENT(INOUT) :: VALUE - INTEGER(I4B) :: lis_vector_get_value - END FUNCTION lis_vector_get_value -END INTERFACE - -PUBLIC :: lis_vector_get_value - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_get_values(LIS_VECTOR v, LIS_INT start, LIS_INT count, LIS_SCALAR value[]); - -INTERFACE - FUNCTION lis_vector_get_values(v, start, count, VALUE) & - & BIND(C, name="lis_vector_get_values") - IMPORT :: LIS_VECTOR, I4B, DFP - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B), VALUE, INTENT(IN) :: start - INTEGER(I4B), VALUE, INTENT(IN) :: count - REAL(DFP), INTENT(INOUT) :: VALUE(*) - INTEGER(I4B) :: lis_vector_get_values - END FUNCTION lis_vector_get_values -END INTERFACE - -PUBLIC :: lis_vector_get_values - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_set_value(LIS_INT flag, LIS_INT i, LIS_SCALAR value, LIS_VECTOR v); - -INTERFACE - FUNCTION lis_vector_set_value(flag, i, VALUE, v) & - & BIND(C, name="lis_vector_set_value") - IMPORT :: LIS_VECTOR, I4B, DFP - INTEGER(I4B), VALUE, INTENT(IN) :: flag - INTEGER(I4B), VALUE, INTENT(IN) :: i - REAL(DFP), VALUE, INTENT(IN) :: VALUE - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B) :: lis_vector_set_value - END FUNCTION lis_vector_set_value -END INTERFACE - -PUBLIC :: lis_vector_set_value - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_set_values(LIS_INT flag, LIS_INT count, LIS_INT index[], LIS_SCALAR value[], LIS_VECTOR v); - -INTERFACE - FUNCTION lis_vector_set_values(flag, count, index, VALUE, v) & - & BIND(C, name="lis_vector_set_values") - IMPORT :: LIS_VECTOR, I4B, DFP - INTEGER(I4B), VALUE, INTENT(IN) :: flag - INTEGER(I4B), VALUE, INTENT(IN) :: count - INTEGER(I4B), INTENT(IN) :: INDEX(count) - REAL(DFP), INTENT(IN) :: VALUE(count) - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B) :: lis_vector_set_values - END FUNCTION lis_vector_set_values -END INTERFACE - -PUBLIC :: lis_vector_set_values - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_set_values2(LIS_INT flag, LIS_INT start, LIS_INT count, LIS_SCALAR value[], LIS_VECTOR v); - -INTERFACE - FUNCTION lis_vector_set_values2(flag, start, count, VALUE, v) & - & BIND(C, name="lis_vector_set_values2") - IMPORT :: LIS_VECTOR, I4B, DFP - INTEGER(I4B), VALUE, INTENT(IN) :: flag - INTEGER(I4B), VALUE, INTENT(IN) :: start - INTEGER(I4B), VALUE, INTENT(IN) :: count - REAL(DFP), INTENT(IN) :: VALUE(count) - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B) :: lis_vector_set_values2 - END FUNCTION lis_vector_set_values2 -END INTERFACE - -PUBLIC :: lis_vector_set_values2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_print(LIS_VECTOR x); - -INTERFACE - FUNCTION lis_vector_print(x) & - & BIND(C, name="lis_vector_print") - IMPORT :: LIS_VECTOR, I4B - TYPE(LIS_VECTOR), VALUE, INTENT(IN) :: x - INTEGER(I4B) :: lis_vector_print - END FUNCTION lis_vector_print -END INTERFACE -! -PUBLIC :: lis_vector_print - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern LIS_INT lis_vector_scatter(LIS_SCALAR value[], LIS_VECTOR v); - -INTERFACE - FUNCTION lis_vector_scatter(VALUE, v) & - & BIND(C, name="lis_vector_scatter") - IMPORT :: LIS_VECTOR, I4B, DFP - REAL(DFP), INTENT(IN) :: VALUE(*) - TYPE(LIS_VECTOR), INTENT(INOUT) :: v - INTEGER(I4B) :: lis_vector_scatter - END FUNCTION lis_vector_scatter -END INTERFACE - -PUBLIC :: lis_vector_scatter - -! extern LIS_INT lis_vector_gather(LIS_VECTOR v, LIS_SCALAR value[]); -! extern LIS_INT lis_vector_is_null(LIS_VECTOR v); -! extern LIS_INT lis_vector_swap(LIS_VECTOR vsrc, LIS_VECTOR vdst); -! extern LIS_INT lis_vector_copy(LIS_VECTOR vsrc, LIS_VECTOR vdst); -! extern LIS_INT lis_vector_axpy(LIS_SCALAR alpha, LIS_VECTOR vx, LIS_VECTOR vy); -! extern LIS_INT lis_vector_xpay(LIS_VECTOR vx, LIS_SCALAR alpha, LIS_VECTOR vy); -! extern LIS_INT lis_vector_axpyz(LIS_SCALAR alpha, LIS_VECTOR vx, LIS_VECTOR vy, LIS_VECTOR vz); -! extern LIS_INT lis_vector_scale(LIS_SCALAR alpha, LIS_VECTOR vx); -! extern LIS_INT lis_vector_pmul(LIS_VECTOR vx,LIS_VECTOR vy,LIS_VECTOR vz); -! extern LIS_INT lis_vector_pdiv(LIS_VECTOR vx,LIS_VECTOR vy,LIS_VECTOR vz); -! extern LIS_INT lis_vector_set_all(LIS_SCALAR alpha, LIS_VECTOR vx); -! extern LIS_INT lis_vector_abs(LIS_VECTOR vx); -! extern LIS_INT lis_vector_reciprocal(LIS_VECTOR vx); -! extern LIS_INT lis_vector_conjugate(LIS_VECTOR vx); -! extern LIS_INT lis_vector_shift(LIS_SCALAR sigma, LIS_VECTOR vx); -! extern LIS_INT lis_vector_dot(LIS_VECTOR vx, LIS_VECTOR vy, LIS_SCALAR *value); -! extern LIS_INT lis_vector_nhdot(LIS_VECTOR vx, LIS_VECTOR vy, LIS_SCALAR *value); -! extern LIS_INT lis_vector_nrm1(LIS_VECTOR vx, LIS_REAL *value); -! extern LIS_INT lis_vector_nrm2(LIS_VECTOR vx, LIS_REAL *value); -! extern LIS_INT lis_vector_nrmi(LIS_VECTOR vx, LIS_REAL *value); -! extern LIS_INT lis_vector_sum(LIS_VECTOR vx, LIS_SCALAR *value); - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE display_lisvector(obj, msg, unitno) - TYPE(LIS_VECTOR), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - REAL(DFP), POINTER :: VALUE(:) - - CALL Display(obj%label, "label = ", unitno) - CALL Display(obj%status, "status = ", unitno) - CALL Display(obj%PRECISION, "PRECISION = ", unitno) - CALL Display(obj%gn, "gn = ", unitno) - CALL Display(obj%n, "n = ", unitno) - CALL Display(obj%np, "np = ", unitno) - CALL Display(obj%pad, "pad= ", unitno) - CALL Display(obj%origin, "origin= ", unitno) - CALL Display(obj%is_copy, "is_copy= ", unitno) - CALL Display(obj%is_destroy, "is_destroy= ", unitno) - CALL Display(obj%is_scaled, "is_scaled= ", unitno) - CALL Display(obj%my_rank, "my_rank= ", unitno) - CALL Display(obj%nprocs, "nprocs= ", unitno) - CALL Display(obj%comm, "comm= ", unitno) - CALL Display(obj%is, "is= ", unitno) - CALL Display(obj%ie, "ie= ", unitno) - CALL Display(obj%intvalue, "intvalue= ", unitno) - - IF (C_ASSOCIATED(obj%ranges)) THEN - CALL Display("ranges is associated", unitno) - ELSE - CALL Display("ranges is NOT associated", unitno) - END IF - - IF (C_ASSOCIATED(obj%VALUE)) THEN - CALL Display("VALUE is associated", unitno) - CALL C_F_POINTER(obj%VALUE, VALUE, [obj%n]) - IF (obj%n .LE. 10) THEN - CALL Display(VALUE, "value = ", unitno) - ELSE - CALL Display(VALUE(1:10), "value(1:10) = ", unitno) - END IF - NULLIFY (VALUE) - ELSE - CALL Display("VALUE is NOT associated", unitno) - END IF - - IF (C_ASSOCIATED(obj%value_lo)) THEN - CALL Display("value_lo is associated", unitno) - ELSE - CALL Display("value_lo is NOT associated", unitno) - END IF - - IF (C_ASSOCIATED(obj%work)) THEN - CALL Display("work is associated", unitno) - ELSE - CALL Display("work is NOT associated", unitno) - END IF - -END SUBROUTINE display_lisvector - -END MODULE LISVector diff --git a/src/modules/Lapack/CMakeLists.txt b/src/modules/Lapack/CMakeLists.txt deleted file mode 100644 index 1f9c2bd9c..000000000 --- a/src/modules/Lapack/CMakeLists.txt +++ /dev/null @@ -1,37 +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 -# - -IF( USE_LAPACK95 ) - LIST( APPEND TARGET_COMPILE_DEF "-DUSE_LAPACK95" ) - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/GE_CompRoutineMethods.F90 - ${src_path}/GE_EigenValueMethods.F90 - ${src_path}/GE_LUMethods.F90 - ${src_path}/GE_LinearSolveMethods.F90 - ${src_path}/GE_SingularValueMethods.F90 - ${src_path}/GE_Lapack_Method.F90 - ${src_path}/Sym_CompRoutineMethods.F90 - ${src_path}/Sym_EigenValueMethods.F90 - ${src_path}/Sym_LUMethods.F90 - ${src_path}/Sym_LinearSolveMethods.F90 - ${src_path}/Sym_SingularValueMethods.F90 - ${src_path}/Sym_Lapack_Method.F90 - ${src_path}/Lapack_Method.F90 - ) -ENDIF( ) diff --git a/src/modules/Lapack/src/GE_CompRoutineMethods.F90 b/src/modules/Lapack/src/GE_CompRoutineMethods.F90 deleted file mode 100644 index 870b57bb6..000000000 --- a/src/modules/Lapack/src/GE_CompRoutineMethods.F90 +++ /dev/null @@ -1,158 +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 GE_CompRoutineMethods -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE - -PUBLIC :: ConditionNo -PUBLIC :: GetInvMat - -!---------------------------------------------------------------------------- -! ConditionNo -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION ge_ConditionNo_1(A, NORM) RESULT(ans) - REAL(DFP), INTENT(IN) :: A(:, :) - !! General matrix - CHARACTER(1), INTENT(IN) :: NORM - !! "1", "0" - REAL(DFP) :: ans - !! - END FUNCTION ge_ConditionNo_1 -END INTERFACE - -INTERFACE ConditionNo - MODULE PROCEDURE ge_ConditionNo_1 -END INTERFACE ConditionNo - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Inverse of matrix -! -!# Introduction -! -! This routine calls `DGETRI` routine from Lapack. -! A copy of matrix A is made into invA, then LU decomposition is performed and -! `DGETRI` is called from lapack - -INTERFACE - MODULE SUBROUTINE ge_GetInvMat1(A, invA) - REAL(DFP), INTENT(IN) :: A(:, :) - !! General matrix - REAL(DFP), INTENT(INOUT) :: invA(:, :) - !! - END SUBROUTINE ge_GetInvMat1 -END INTERFACE - -INTERFACE GetInvMat - MODULE PROCEDURE ge_GetInvMat1 -END INTERFACE GetInvMat - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Inverse of matrix -! -!# Introduction -! -!- This routine calls `DGETRI` routine from Lapack. -!- A and IPIV are obtained from LU decomposition -!- A contains the LU decomposition of matrix A -!- A copy of matrix A is made into invA, then -! `DGETRI` is called from lapack - -INTERFACE - MODULE SUBROUTINE ge_GetInvMat2(A, IPIV, invA) - REAL(DFP), INTENT(IN) :: A(:, :) - !! General matrix - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! General matrix - REAL(DFP), INTENT(INOUT) :: invA(:, :) - !! - END SUBROUTINE ge_GetInvMat2 -END INTERFACE - -INTERFACE GetInvMat - MODULE PROCEDURE ge_GetInvMat2 -END INTERFACE GetInvMat - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Inverse of matrix -! -!# Introduction -! -!- This routine calls `DGETRI` routine from Lapack. -!- A and IPIV are obtained from LU decomposition -!- A contains the LU decomposition of matrix A at input -!- At output invese of A is stored inside A -!- No copy is made. - -INTERFACE - MODULE SUBROUTINE ge_GetInvMat3(A, IPIV) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LU Decompose at input - !! inverse at output - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! - END SUBROUTINE ge_GetInvMat3 -END INTERFACE - -INTERFACE GetInvMat - MODULE PROCEDURE ge_GetInvMat3 -END INTERFACE GetInvMat - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Inverse of matrix -! -!# Introduction -! -!- This routine calls `DGETRI` routine from Lapack. -!- First LU decomposition is performed -!- Then `DGETRI` is called from lapack -!- At output A contains the inverse. - -INTERFACE - MODULE SUBROUTINE ge_GetInvMat4(A) - REAL(DFP), INTENT(INOUT) :: A(:, :) - END SUBROUTINE ge_GetInvMat4 -END INTERFACE - -INTERFACE GetInvMat - MODULE PROCEDURE ge_GetInvMat4 -END INTERFACE GetInvMat - -END MODULE GE_CompRoutineMethods diff --git a/src/modules/Lapack/src/GE_EigenValueMethods.F90 b/src/modules/Lapack/src/GE_EigenValueMethods.F90 deleted file mode 100644 index ee78f7adf..000000000 --- a/src/modules/Lapack/src/GE_EigenValueMethods.F90 +++ /dev/null @@ -1,188 +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 GE_EigenValueMethods -USE GlobalData, ONLY: DFP, DFPC, I4B, LGT -IMPLICIT NONE -CHARACTER(*), PARAMETER :: modName = "GE_EigenValueMethods" -PRIVATE - -PUBLIC :: GetEigVals -PUBLIC :: GetEig - -!---------------------------------------------------------------------------- -! getEigVals -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: calculate eigenvalues for real matrix -! -! if destroy is false matrix A is preserved -! - -INTERFACE GetEigVals - MODULE SUBROUTINE deigvals(A, lam, destroy) - REAL(DFP), INTENT(INOUT) :: A(:, :) - COMPLEX(DFPC), INTENT(INOUT) :: lam(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy - ! default is true - END SUBROUTINE deigvals -END INTERFACE GetEigVals - -!---------------------------------------------------------------------------- -! getEigVals -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: calculate eigenvalues for complex matrix -! -! if destroy is false matrix A is preserved -! - -INTERFACE GetEigVals - MODULE SUBROUTINE zeigvals(A, lam, destroy) - COMPLEX(DFPC), INTENT(INOUT) :: A(:, :) - COMPLEX(DFPC), INTENT(INOUT) :: lam(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy - ! default is true - END SUBROUTINE zeigvals -END INTERFACE GetEigVals - -!---------------------------------------------------------------------------- -! getEig -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: calculate eigenvalues and eigenvectors for real matrix -! -! if destroy is false matrix A is preserved -! - -INTERFACE GetEig - MODULE SUBROUTINE deig(A, lam, c, destroy) - REAL(DFP), INTENT(INOUT) :: A(:, :) - COMPLEX(DFPC), INTENT(INOUT) :: lam(:) - ! eigenvalues - ! should be allocated - COMPLEX(DFPC), INTENT(INOUT) :: c(:, :) - ! eigenvectors - ! c(i,j) = ith component of jth eigenvec. - ! should be allocated - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy - ! default is true - END SUBROUTINE deig -END INTERFACE GetEig - -!---------------------------------------------------------------------------- -! getEig -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-05-17 -! summary: calculate eigenvalues and eigenvectors for complex matrix -! -! if destroy is false matrix A is preserved -! - -INTERFACE GetEig - MODULE SUBROUTINE zeig(A, lam, c, destroy) - COMPLEX(DFPC), INTENT(INOUT) :: A(:, :) - COMPLEX(DFPC), INTENT(INOUT) :: lam(:) - ! eigenvalues - ! should be allocated - COMPLEX(DFPC), INTENT(INOUT) :: c(:, :) - ! eigenvectors - ! c(i,j) = ith component of jth eigenvec. - ! should be allocated - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy - ! default is true - END SUBROUTINE zeig -END INTERFACE GetEig - -!---------------------------------------------------------------------------- -! DGEES@EigenValue -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! DGEES computes for an N-by-N real nonsymmetric matrix A, the -! eigenvalues, the real Schur form T, and, optionally, the matrix of -! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). -! -! Optionally, it also orders the eigenvalues on the diagonal of the -! real Schur form so that selected eigenvalues are at the top left. -! The leading columns of Z then form an orthonormal basis for the -! invariant subspace corresponding to the selected eigenvalues. -! -! A matrix is in real Schur form if it is upper quasi-triangular with -! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the -! form -! [ a b ] -! [ c a ] -! -! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). -! -! JOBVS : JOBVS is CHARACTER*1 -! = 'N': Schur vectors are not computed; -! = 'V': Schur vectors are computed. -! -! SORT : SORT is CHARACTER*1 -! Specifies whether or not to order the eigenvalues on the -! diagonal of the Schur form. -! = 'N': Eigenvalues are not ordered; -! = 'S': Eigenvalues are ordered (see SELECT). -! -! SELECT: SELECT is a LOGICAL FUNCTION of two DOUBLE PRECISION arguments -! SELECT must be declared EXTERNAL in the calling subroutine. -! If SORT = 'S', SELECT is used to select eigenvalues to sort -! to the top left of the Schur form. -! If SORT = 'N', SELECT is not referenced. -! An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if -! SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex -! conjugate pair of eigenvalues is selected, then both complex -! eigenvalues are selected. -! Note that a selected complex eigenvalue may no longer -! satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since -! ordering may change the value of complex eigenvalues -! (especially if the eigenvalue is ill-conditioned); in this -! case INFO is set to N+2 (see INFO below). -! -! N is INTEGER: The order of the matrix A. N >= 0. -! -! A: A is DOUBLE PRECISION array, dimension (LDA,N) -! On entry, the N-by-N matrix A. -! On exit, A has been overwritten by its real Schur form T -! -! LDA: Leading dimension of A -! -! SDIM: - -! INTERFACE -! MODULE SUBROUTINE dgees_1(A, WR, WI, SchurForm) -! REAL(DFP), INTENT(IN) :: A(:, :) -! REAL(DFP), INTENT(INOUT) :: WR(:) -! !! Real part of the eigenvalue -! REAL(DFP), INTENT(INOUT) :: WI(:) -! !! Imaginary part of the eigenvalue -! REAL(DFP), INTENT(INOUT) :: SchurForm(:, :) -! END SUBROUTINE dgees_1 -! END INTERFACE - -END MODULE GE_EigenValueMethods diff --git a/src/modules/Lapack/src/GE_LUMethods.F90 b/src/modules/Lapack/src/GE_LUMethods.F90 deleted file mode 100644 index bd59251bb..000000000 --- a/src/modules/Lapack/src/GE_LUMethods.F90 +++ /dev/null @@ -1,251 +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 GE_LUMethods -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetLU -PUBLIC :: LUSolve -PUBLIC :: Inv - -!---------------------------------------------------------------------------- -! GetLU@LU -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-07-07 -! summary: DGetF2 computes an LU factorization of a general m-by-n matrix A -! -!# Introduction -! -! Using partial pivoting with row interchanges. -! -! DGetF2 computes an LU factorization of a general m-by-n matrix A -! using partial pivoting with row interchanges. -! -! The factorization has the form -! A = P * L * U -! where P is a permutation matrix, L is lower triangular with unit -! diagonal elements (lower trapezoidal if m > n), and U is upper -! triangular (upper trapezoidal if m < n). -! -! This is the right-looking Level 2 BLAS version of the algorithm. -! -! ## GetRF -! -! DGetRF computes an LU factorization of a general M-by-N matrix A -! using partial pivoting with row interchanges -! -! - iterative version of Sivan Toledo's recursive LU algorithm -! - left-looking Level 3 BLAS version of the algorithm. -! -! The factorization has the form -! A = P * L * U -! where P is a permutation matrix, L is lower triangular with unit -! diagonal elements (lower trapezoidal if m > n), and U is upper -! triangular (upper trapezoidal if m < n). -! - -INTERFACE GetLU - MODULE SUBROUTINE GetLU_1(A, LU, IPIV, RCOND, NORM, info) - REAL(DFP), INTENT(IN) :: A(:, :) - !! Matrix to be factored - REAL(DFP), INTENT(OUT) :: LU(:, :) - !! LU factorization, the unit diagonal elements of L are not stored. - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! IPIV is INTEGER array,row i of the matrix was interchanged with row - !! IPIV(i). - !! IPIV is INTEGER array, dimension (min(M,N)) - !! The pivot indices; for 1 <= i <= min(M,N), row i of the - !! matrix was interchanged with row IPIV(i). - REAL(DFP), OPTIONAL, INTENT(OUT) :: RCOND - !! Inverse of Condition number - CHARACTER(1), OPTIONAL, INTENT(IN) :: NORM - !! NORM "1", "0" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE GetLU_1 -END INTERFACE GetLU - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Compute LU factorization -! -!# Introduction -! -! This routine is same as `GetLU_1` however in this routine LU -! factorization is computed in A matrix on return. - -INTERFACE GetLU - MODULE SUBROUTINE GetLU_2(A, IPIV, RCOND, NORM, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! Matrix to be factored, on return it contains LU factorization, - !! the unit diagonal elements of L are not stored. - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! IPIV is INTEGER array,row i of the matrix was interchanged with row - !! IPIV(i). - !! IPIV is INTEGER array, dimension (min(M,N)) - !! The pivot indices; for 1 <= i <= min(M,N), row i of the - !! matrix was interchanged with row IPIV(i). - REAL(DFP), OPTIONAL, INTENT(OUT) :: RCOND - !! If present then inverse of condition number is returned - CHARACTER(1), OPTIONAL, INTENT(IN) :: NORM - !! "1", "0" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE GetLU_2 -END INTERFACE GetLU - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y - -INTERFACE LUSolve - MODULE SUBROUTINE LUSolve_1(A, B, IPIV, isTranspose, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LU decomposition of matrix A, see GetLU - REAL(DFP), INTENT(INOUT) :: B(:) - !! at entry RHS - !! on return solution will be in B - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! IPIV returned from GetLU - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! IF isTranspose true then we solve A^Tx=y - !! Default is `.false.` - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info - END SUBROUTINE LUSolve_1 -END INTERFACE LUSolve - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y - -INTERFACE LUSolve - MODULE SUBROUTINE LUSolve_2(A, B, IPIV, isTranspose, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LU Decomposition of A returned from GetLU - REAL(DFP), INTENT(INOUT) :: B(:, :) - !! Several rhs, on return solution will be in B - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! pivoting returned from GetLU - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! if true we solve A^Tx = y - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE LUSolve_2 -END INTERFACE LUSolve - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y - -INTERFACE LUSolve - MODULE SUBROUTINE LUSolve_3(X, A, B, IPIV, isTranspose, info) - REAL(DFP), INTENT(OUT) :: X(:) - !! RHS, on return solution will be in B - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LU decomposition of matrix A, see GetLU - REAL(DFP), INTENT(IN) :: B(:) - !! RHS - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! IPIV returned from GetLU - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! if isTranspose true then we solve A^Tx=y - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info - END SUBROUTINE LUSolve_3 -END INTERFACE LUSolve - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y - -INTERFACE LUSolve - MODULE SUBROUTINE LUSolve_4(X, A, B, IPIV, isTranspose, info) - REAL(DFP), INTENT(OUT) :: X(:, :) - !! solution - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LU Decomposition of A returned from GetLU - REAL(DFP), INTENT(IN) :: B(:, :) - !! several RHS - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! pivoting returned from GetLU - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! if true we solve A^Tx = y - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE LUSolve_4 -END INTERFACE LUSolve - -!---------------------------------------------------------------------------- -! GetInv -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Get inverse of square matrix from LU decomposition - -INTERFACE Inv - MODULE SUBROUTINE Inv_1(A, invA, IPIV, info) - REAL(DFP), INTENT(IN) :: A(:, :) - !! LU Decomposition - REAL(DFP), INTENT(INOUT) :: invA(:, :) - !! inverse of A - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! returned from GetLU - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE Inv_1 -END INTERFACE Inv - -!---------------------------------------------------------------------------- -! GetInv -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Get inverse of square matrix from LU decomposition - -INTERFACE Inv - MODULE SUBROUTINE Inv_2(A, IPIV, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LU Decomposition, inverse will be returned in A - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! returned from GetLU - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE Inv_2 -END INTERFACE Inv - -END MODULE GE_LUMethods diff --git a/src/modules/Lapack/src/GE_Lapack_Method.F90 b/src/modules/Lapack/src/GE_Lapack_Method.F90 deleted file mode 100644 index 61ce378ee..000000000 --- a/src/modules/Lapack/src/GE_Lapack_Method.F90 +++ /dev/null @@ -1,39 +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: 7 July 2022 -! summary: Lapack methods -! -!# Introduction -! -! This module contains linear algebra packages for fortran matrix (2D array) -! The matrix is GE -! This module contains following submoduls -! - @LinearSolveMethods PARTIAL/STABLE -! - @EigenValueMethods TODO -! - @SingularValueMethods TODO -! - @CompRoutineMethods PARTIAL/STABLE -! - @AuxRoutinesMethods TODO - -MODULE GE_Lapack_Method -USE GE_CompRoutineMethods -USE GE_EigenValueMethods -USE GE_LUMethods -USE GE_LinearSolveMethods -USE GE_SingularValueMethods -END MODULE GE_Lapack_Method diff --git a/src/modules/Lapack/src/GE_LinearSolveMethods.F90 b/src/modules/Lapack/src/GE_LinearSolveMethods.F90 deleted file mode 100644 index 82eba0dd4..000000000 --- a/src/modules/Lapack/src/GE_LinearSolveMethods.F90 +++ /dev/null @@ -1,488 +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 -! -! Linear Solver name -! - GESV -! - GESVX -! - GESVXX -! - GELS -! - GELSD -! - GELSS -! - GELSY -! - GETSLS - -MODULE GE_LinearSolveMethods -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE -PUBLIC :: Solve -PUBLIC :: LinSolve - -!---------------------------------------------------------------------------- -! Solve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 7 July 2022 -! summary: This function solves Ax=b using lapack, A can be square or rect -! -!# Introduction -! -! This function solves Ax=b using LAPACK. A can be a square matrix or -! rectangular matrix. -! -! This routine creates a copy of A and B. So do not use it for large -! systems. -! -! When A is a square matrix, then this routine calls GESV routine. -! -!## GESV -! -! GESV computes the solution to a real system of linear equations -! -!$$ -! Ax = y, -!$$ -! -! The LU decomposition with partial pivoting and row interchanges is -! used to factor A as -! -!$$ -! A = P * L * U, -!$$ -! -! where P is a permutation matrix, L is unit lower triangular, and U is -! upper triangular. The factored form of A is then used to solve the -! system of equations A * X = B. -! -! When A is not a square matrix, then this routine calls can call following -! routines depending upon the value of SolverName. -! -! - GELS <-- Default QR or LQ, (A should have full rank) -! - GELSD <-- When A is rank defincient, SVD -! - GELSS -! -!## GELS -! -! GELS solves overdetermined or underdetermined systems for GE matrices using -! QR or LQ factorization. -! -!@note -! Note that matrix A should have full rank. -!@endnote -! -! If `isTranspose` is false then we solve $Ax=y$. -! -! In this case, if -! the number of rows are greater than number of columns (more equations) -! then we solve a least square problem (by using GEQRF) of -! -!$$ -! min \Vert y-Ax \Vert -!$$ -! -! When number of rows are lesser than the number of columns we have an -! underdetermined system. And we obtain the minimum norm solution -! of an underdetermined system $Ax=y$ (by using GELQF). -! -! When isTranspose is true then we solve $A^T x = y$. Here if number of rows -! are greater than the number of cols, then we have underdetermined system -! If number of rows of A is lesser than the number of columns of A, then -! we solve a least square system. -! -!## GELSD -! -! DGELSD computes the minimum-norm solution to a real linear least -! squares problem: -! -!$$ -! min \Vert b - A*x \Vert_{2} -!$$ -! -! by using the singular value decomposition (SVD) of A. -! A is an M-by-N matrix which may be rank-deficient. -! -! -! The problem is solved in three steps: -! (1) Reduce the coefficient matrix A to bidiagonal form with -! Householder transformations, reducing the original problem -! into a "bidiagonal least squares problem" (BLS) -! (2) Solve the BLS using a divide and conquer approach. -! (3) Apply back all the Householder transformations to solve -! the original least squares problem. -! -! The effective rank of A is determined by treating as zero those -! singular values which are less than RCOND times the largest singular -! value. -! -! The divide and conquer algorithm makes very mild assumptions about -! floating point arithmetic. It will work on machines with a guard -! digit in add/subtract, or on those binary machines without guard -! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or -! Cray-2. It could conceivably fail on hexadecimal or decimal machines -! without guard digits, but we know of none. -! -!## GELSS -! -! GELSS solves overdetermined or underdetermined systems for GE matrices -! -!DGELSS computes the minimum norm solution to a real linear least -! squares problem: -! -!$$ -! min \Vert b - A*x \Vert_{2} -!$$ -! -! using the singular value decomposition (SVD) of A. A is an M-by-N -! matrix which may be rank-deficient. -! -! The effective rank of A is determined by treating as zero those -! singular values which are less than RCOND times the largest singular -! value. -! -!@note -! Note that this routine creates a copy of A and b and then find x. -! This is because DGESV modifies the entries of A and b. -! Therefore, when A is large this routine should be avoided. -!@endnote - -INTERFACE Solve - MODULE SUBROUTINE ge_solve_1(X, A, B, IPIV, SolverName, isTranspose, RANK, & - & RCOND, S, info) - REAL(DFP), INTENT(INOUT) :: X(:) - !! Unknown vector - REAL(DFP), INTENT(IN) :: A(:, :) - !! General square matrix - REAL(DFP), INTENT(IN) :: B(:) - !! RHS of Ax=B - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! Used for GESV - ! IPIV is INTEGER array, dimension (N) - ! The pivot indices that define the permutation matrix P; - ! row i of the matrix was interchanged with row IPIV(i). - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! If true then we solve $A^{T} x = y$ - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK - !! Used in case of GELSD and GELSS - !! The effective rank of A, i.e., the number of singular values - !! which are greater than RCOND*S(1). - REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND - !! RCOND is used to determine the effective rank of A. - !! Singular values S(i) <= RCOND*S(1) are treated as zero. - !! If RCOND < 0, machine precision is used instead. - REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) - !! Used in case of GELSD and GELSS - !! S is DOUBLE PRECISION array, dimension (min(M,N)) - !! The singular values of A in decreasing order. - !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE ge_solve_1 -END INTERFACE Solve - -!---------------------------------------------------------------------------- -! Solve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 7 July 2022 -! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays -! -!# Introduction -! -! -! This function solves Ax=b using LAPACK. A can be a square or rectangle -! matrix. In this case we have several RHS denoted by B matrix. -! -! All other things are same as `ge_solve_1`. - -INTERFACE Solve - MODULE SUBROUTINE ge_solve_2(X, A, B, IPIV, SolverName, isTranspose, RANK, & - & RCOND, S, info) - REAL(DFP), INTENT(INOUT) :: X(:, :) - !! Unknown vector - REAL(DFP), INTENT(IN) :: A(:, :) - !! General square matrix - REAL(DFP), INTENT(IN) :: B(:, :) - !! RHS of Ax=B - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! inverse of permuation - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! If true then we solve A^T x = y. - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK - REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND - REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE ge_solve_2 -END INTERFACE Solve - -!---------------------------------------------------------------------------- -! GELSY@LinearSolve -!---------------------------------------------------------------------------- - -!# Introduction -! -! DGELSY computes the minimum-norm solution to a real linear least -! squares problem: -! minimize || A * X - B || -! using a complete orthogonal factorization of A. A is an M-by-N -! matrix which may be rank-deficient. -! -! Several right hand side vectors b and solution vectors x can be -! handled in a single call; they are stored as the columns of the -! M-by-NRHS right hand side matrix B and the N-by-NRHS solution -! matrix X. -! -! The routine first computes a QR factorization with column pivoting: -! A * P = Q * [ R11 R12 ] -! [ 0 R22 ] -! with R11 defined as the largest leading submatrix whose estimated -! condition number is less than 1/RCOND. The order of R11, RANK, -! is the effective rank of A. -! -! Then, R22 is considered to be negligible, and R12 is annihilated -! by orthogonal transformations from the right, arriving at the -! complete orthogonal factorization: -! A * P = Q * [ T11 0 ] * Z -! [ 0 0 ] -! The minimum-norm solution is then -! X = P * Z**T [ inv(T11)*Q1**T*B ] -! [ 0 ] -! where Q1 consists of the first RANK columns of Q. -! -! This routine is basically identical to the original xGELSX except -! three differences: -! - The call to the subroutine xGEQPF has been substituted by the -! the call to the subroutine xGEQP3. This subroutine is a Blas-3 -! version of the QR factorization with column pivoting. -! - Matrix B (the right hand side) is updated with Blas-3. -! - The permutation of matrix B (the right hand side) is faster and -! more simple. - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve Ax=Y -! -!# Introduction -! -! This routine is same as `ge_solve_1` with following difference. -! -! In this subroutine we do not make copy of A. Therefore A will be -! modified on return. Note that B will not be modified as we still -! make a copy of B. -! -! -!## GESV -! -! On entry, the N-by-N coefficient matrix A. -! On exit, the factors L and U from the factorization -! A = P*L*U; the unit diagonal elements of L are not stored. -! -!## GELS -! -! On entry, the M-by-N matrix A. -! On exit, -! if M >= N, A is overwritten by details of its QR -! factorization as returned by DGEQRF; -! if M < N, A is overwritten by details of its LQ -! factorization as returned by DGELQF. -! -!## GELSD -! -! On entry, the M-by-N matrix A. -! On exit, A has been destroyed. -! -!## GELSS -! -! On entry, the M-by-N matrix A. -! On exit, the first min(m,n) rows of A are overwritten with -! its right singular vectors, stored rowwise. - -INTERFACE LinSolve - MODULE SUBROUTINE ge_linsolve_1(X, A, B, IPIV, SolverName, & - & isTranspose, RANK, RCOND, S, info) - REAL(DFP), INTENT(INOUT) :: X(:) - !! Unknown vector solution - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square/rectangle matrix, it will be modified on return - REAL(DFP), INTENT(IN) :: B(:) - !! RHS of Ax=B - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! Used for GESV - !! IPIV is INTEGER array, dimension (N) - !! The pivot indices that define the permutation matrix P; - !! row i of the matrix was interchanged with row IPIV(i). - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! If true then we solve $A^{T} x = y$ - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK - !! Used in case of GELSD and GELSS - !! The effective rank of A, i.e., the number of singular values - !! which are greater than RCOND*S(1). - REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND - !! RCOND is used to determine the effective rank of A. - !! Singular values S(i) <= RCOND*S(1) are treated as zero. - !! If RCOND < 0, machine precision is used instead. - REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) - !! Used in case of GELSD and GELSS - !! S is DOUBLE PRECISION array, dimension (min(M,N)) - !! The singular values of A in decreasing order. - !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE ge_linsolve_1 -END INTERFACE LinSolve - -!---------------------------------------------------------------------------- -! LinSolve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 7 July 2022 -! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays -! -!# Introduction -! -! -! This function solves Ax=b using LAPACK. A can be a square or rectangle -! matrix. In this case we have several RHS denoted by B matrix. -! -! All other things are same as `ge_solve_1`. - -INTERFACE LinSolve - MODULE SUBROUTINE ge_linsolve_2(X, A, B, IPIV, SolverName, isTranspose, & - & RANK, RCOND, S, info) - REAL(DFP), INTENT(INOUT) :: X(:, :) - !! Unknown vector or solution - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square/ rectangle matrix, its content will be destroyed - REAL(DFP), INTENT(IN) :: B(:, :) - !! RHS of Ax=B - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! inverse of permuation - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! If true then we solve A^T x = y. - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK - REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND - REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE ge_linsolve_2 -END INTERFACE LinSolve - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary:Solve Ax=b -! -!# Introduction -! -! This routine is same as `ge_linsolve_1` with following changes -! -! We do not make any copy of B. The solution is returned in B. This -! means B will be destroyed on return. - -INTERFACE LinSolve - MODULE SUBROUTINE ge_linsolve_3(A, B, IPIV, SolverName, & - & isTranspose, RANK, RCOND, S, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square/ rectangle matrix, its content will be modified on - !! return - REAL(DFP), INTENT(INOUT) :: B(:) - !! RHS of Ax=B, it will contain the solution on return - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! Used for GESV - ! IPIV is INTEGER array, dimension (N) - ! The pivot indices that define the permutation matrix P; - ! row i of the matrix was interchanged with row IPIV(i). - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! If true then we solve $A^{T} x = y$ - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK - !! Used in case of GELSD and GELSS - !! The effective rank of A, i.e., the number of singular values - !! which are greater than RCOND*S(1). - REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND - !! RCOND is used to determine the effective rank of A. - !! Singular values S(i) <= RCOND*S(1) are treated as zero. - !! If RCOND < 0, machine precision is used instead. - REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) - !! Used in case of GELSD and GELSS - !! S is DOUBLE PRECISION array, dimension (min(M,N)) - !! The singular values of A in decreasing order. - !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE ge_linsolve_3 -END INTERFACE LinSolve - -INTERFACE Solve - MODULE PROCEDURE ge_linsolve_3 -END INTERFACE Solve - -!---------------------------------------------------------------------------- -! LinSolve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve Ax=y -! -!# Introduction -! -! This routien is same as `ge_linsolve_2` with following difference -! -! In this routine we do not create copy of B, ans sol is returned in B. -! This means B will be changed on return. - -INTERFACE LinSolve - MODULE SUBROUTINE ge_linsolve_4(A, B, IPIV, SolverName, isTranspose, & - & RANK, RCOND, S, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square/rectangle matrix, its content will be modifie - !! on return - REAL(DFP), INTENT(INOUT) :: B(:, :) - !! RHS of Ax=B, it will be modified such that it contains solution on - !! return - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! inverse of permuation - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose - !! If true then we solve A^T x = y. - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK - REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND - REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE ge_linsolve_4 -END INTERFACE LinSolve - -INTERFACE Solve - MODULE PROCEDURE ge_linsolve_4 -END INTERFACE Solve - -END MODULE GE_LinearSolveMethods diff --git a/src/modules/Lapack/src/GE_SingularValueMethods.F90 b/src/modules/Lapack/src/GE_SingularValueMethods.F90 deleted file mode 100644 index d63b20091..000000000 --- a/src/modules/Lapack/src/GE_SingularValueMethods.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 -! - -MODULE GE_SingularValueMethods -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE -END MODULE GE_SingularValueMethods diff --git a/src/modules/Lapack/src/Lapack_Method.F90 b/src/modules/Lapack/src/Lapack_Method.F90 deleted file mode 100644 index bb0647fb4..000000000 --- a/src/modules/Lapack/src/Lapack_Method.F90 +++ /dev/null @@ -1,21 +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 Lapack_Method -USE GE_Lapack_Method -USE Sym_Lapack_Method -END MODULE Lapack_Method \ No newline at end of file diff --git a/src/modules/Lapack/src/Sym_CompRoutineMethods.F90 b/src/modules/Lapack/src/Sym_CompRoutineMethods.F90 deleted file mode 100644 index a5e47cd41..000000000 --- a/src/modules/Lapack/src/Sym_CompRoutineMethods.F90 +++ /dev/null @@ -1,20 +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 Sym_CompRoutineMethods - -END MODULE Sym_CompRoutineMethods diff --git a/src/modules/Lapack/src/Sym_EigenValueMethods.F90 b/src/modules/Lapack/src/Sym_EigenValueMethods.F90 deleted file mode 100644 index 112006cae..000000000 --- a/src/modules/Lapack/src/Sym_EigenValueMethods.F90 +++ /dev/null @@ -1,20 +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 Sym_EigenValueMethods - -END MODULE Sym_EigenValueMethods diff --git a/src/modules/Lapack/src/Sym_LUMethods.F90 b/src/modules/Lapack/src/Sym_LUMethods.F90 deleted file mode 100644 index da1cb88ba..000000000 --- a/src/modules/Lapack/src/Sym_LUMethods.F90 +++ /dev/null @@ -1,488 +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 Sym_LUMethods -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE -PUBLIC :: SymGetLU -PUBLIC :: SymGetLDL -PUBLIC :: SymGetCholesky -PUBLIC :: SymLUSolve -PUBLIC :: SymGetInv - -! PUBLIC :: CholeskySolve - -!---------------------------------------------------------------------------- -! SymGetLU -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-15 -! summary: Computes an LU (LL' or U'U) factorization of a sym matrix A - -INTERFACE - MODULE SUBROUTINE SymGetLU_1(A, LU, IPIV, UPLO, info) - REAL(DFP), INTENT(IN) :: A(:, :) - !! Matrix to be factored - REAL(DFP), INTENT(OUT) :: LU(:, :) - !! L or U factorization - !! SHAPE(LU) = [N,N] - INTEGER(I4B), INTENT(OUT) :: IPIV(:) - !! reverse permulation - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info=0 => success - !! info \ne 0 => error - END SUBROUTINE SymGetLU_1 -END INTERFACE - -INTERFACE SymGetLU - MODULE PROCEDURE SymGetLU_1 -END INTERFACE SymGetLU - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Compute LU factorization - -INTERFACE - MODULE SUBROUTINE SymGetLU_2(A, IPIV, UPLO, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! Matrix to be factored, on return it contains L or U factorization, - INTEGER(I4B), INTENT(OUT) :: IPIV(:) - !! permutation - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info = 0 ➡️ success - !! info .ne. 0 ➡️ error - END SUBROUTINE SymGetLU_2 -END INTERFACE - -INTERFACE SymGetLU - MODULE PROCEDURE SymGetLU_2 -END INTERFACE SymGetLU - -!---------------------------------------------------------------------------- -! SymGetLDL -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-15 -! summary: Computes an LU (LL' or U'U) factorization of a sym matrix A -! -!# Introduction -! -!- Computes the LDLt or Bunch-Kaufman factorization of a symmetric/ hermitian -! matrix. -!- This function returns a block diagonal matrix D consisting blocks of -! size at most 2x2 and also a possibly permuted unit lower triangular -! matrix L such that the factorization `A = L D L^H` or -! `A = L D L^T` holds. -! If `uplo=U` (again possibly permuted) upper triangular matrices -! are returned as outer factors. -! -! The permutation array can be used to triangularize the outer factors -! simply by a row shuffle, i.e., `lu[perm, :]` is an upper/lower triangular -! matrix. This is also equivalent to multiplication with a -! permutation matrix MATMUL(P, lu), where P is a column-permuted -! identity matrix I[:, perm]. -! -! Depending on the value of the "uplo", only upper or lower triangular -! part of the input array is referenced. -! Hence, a triangular matrix on entry would give the same result -! as if the full matrix is supplied. -! -! This routine calls following routines -! -!- LACPY: Copy two matrices -!- SYTRF: Perform factorization -!- SYCONV: Convert data from SYTRF to standard form. At this point, the -! LU matrix has undergone both row and column interchange (possibly) -!- LAPMR: At this point we undo the row interchange. -! -! Finally, LU is permuted such that -! -! `MATMUL( MATMUL( LU, Diag(D) ), TRANSPOSE(LU))` returns the A matrix. -! -! ## ?SYTRF -! -! DSYTRF computes the factorization of a real symmetric matrix A using -! the Bunch-Kaufman diagonal pivoting method. -! The form of the factorization is -! -!```fortran -! A = U**T*D*U or A = L*D*L**T -!``` -! -! where, -! -!- U (or L) is a product of permutation and unit upper (or lower) -! triangular matrices -!- D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. -!- This is the blocked version of the algorithm, calling Level 3 BLAS. -! -! Also see, SYTRF from Lapack95 - -INTERFACE - MODULE SUBROUTINE SymGetLDL_1(A, LU, D, E, UPLO, IPIV, info) - REAL(DFP), INTENT(IN) :: A(:, :) - !! Matrix to be factored - REAL(DFP), INTENT(OUT) :: LU(:, :) - !! L or U factorization - !! SHAPE(LU) = [N,N] - REAL(DFP), INTENT(OUT) :: D(:) - !! Diagonal entries - !! Size(D) = N - REAL(DFP), INTENT(OUT) :: E(:) - !! Subdiagonal and superdiagonal entries - !! Size(E) = N - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! reverse permulation - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info=0 => success - !! info \ne 0 => error - END SUBROUTINE SymGetLDL_1 -END INTERFACE - -INTERFACE SymGetLDL - MODULE PROCEDURE SymGetLDL_1 -END INTERFACE SymGetLDL - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Compute LU factorization -! -!# Introduction -! -! This routine is same as `getLU_1` however in this routine LU -! factorization is computed in A matrix on return. - -INTERFACE - MODULE SUBROUTINE SymGetLDL_2(A, D, E, UPLO, IPIV, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! Matrix to be factored, on return it contains L or U factorization, - REAL(DFP), INTENT(OUT) :: D(:) - !! Diagonal entries - REAL(DFP), INTENT(OUT) :: E(:) - !! Sub and super Diagonal entries - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! permutation - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info = 0 ➡️ success - !! info .ne. 0 ➡️ error - END SUBROUTINE SymGetLDL_2 -END INTERFACE - -INTERFACE SymGetLDL - MODULE PROCEDURE SymGetLDL_2 -END INTERFACE SymGetLDL - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-20 -! summary: Cholesky factorization of symmetric matrix -! -!# Introduction -! -! Compute the Cholesky decomposition of a matrix. -! -! Returns the Cholesky decomposition, $A=L \cdot L^{T}$, and $A=U^{T} \cdot U$ -! or of a Hermitian positive-definite matrix A. -! -! This routine call following routines from Lapack95 - -INTERFACE - MODULE SUBROUTINE SymGetCholesky_1(A, LU, UPLO, info) - REAL(DFP), INTENT(IN) :: A(:, :) - !! Matrix to be factored - REAL(DFP), INTENT(OUT) :: LU(:, :) - !! L or U factorization - !! SHAPE(LU) = [N,N] - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info=0 => success - !! info \ne 0 => error - END SUBROUTINE SymGetCholesky_1 -END INTERFACE - -INTERFACE SymGetCholesky - MODULE PROCEDURE SymGetCholesky_1 -END INTERFACE SymGetCholesky - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-20 -! summary: Cholesky factorization of symmetric matrix -! -!# Introduction -! -! Compute the Cholesky decomposition of a matrix. -! -! Returns the Cholesky decomposition, $A=L \cdot L^{T}$, and $A=U^{T} \cdot U$ -! or of a Hermitian positive-definite matrix A. -! -! This routine call following routines from Lapack95 - -INTERFACE - MODULE SUBROUTINE SymGetCholesky_2(A, UPLO, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! On entry Matrix to be factored - !! On exit: L or U factorization - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info=0 => success - !! info \ne 0 => error - END SUBROUTINE SymGetCholesky_2 -END INTERFACE - -INTERFACE SymGetCholesky - MODULE PROCEDURE SymGetCholesky_2 -END INTERFACE SymGetCholesky - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y -! -!# Introduction -! -! A and IPIV are returned from -! SymGetLU or SYTRF routine of Lapack95. - -INTERFACE - MODULE SUBROUTINE SymLUSolve_1(A, B, IPIV, UPLO, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LDLt decomposition of matrix A, see SymGetLU - REAL(DFP), INTENT(INOUT) :: B(:) - !! at entry RHS - !! on return solution will be in B - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! IPIV returned from SymGetLU - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info - END SUBROUTINE SymLUSolve_1 -END INTERFACE - -INTERFACE SymLUSolve - MODULE PROCEDURE SymLUSolve_1 -END INTERFACE SymLUSolve - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y -! -!# Introduction -! -! It calls `SYTRS` - -INTERFACE - MODULE SUBROUTINE SymLUSolve_2(A, B, IPIV, UPLO, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LDLt decomposition of matrix A, see SymGetLU - REAL(DFP), INTENT(INOUT) :: B(:, :) - !! at entry RHS - !! on return solution will be in B - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! IPIV returned from SymGetLU - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info - END SUBROUTINE SymLUSolve_2 -END INTERFACE - -INTERFACE SymLUSolve - MODULE PROCEDURE SymLUSolve_2 -END INTERFACE SymLUSolve - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y -! -!# Introduction -! -! A and IPIV are returned from -! SymGetLU or SYTRF routine of Lapack95. - -INTERFACE - MODULE SUBROUTINE SymLUSolve_3(X, A, B, IPIV, UPLO, info) - REAL(DFP), INTENT(OUT) :: X(:) - !! Solution - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LDLt decomposition of matrix A, see SymGetLU - REAL(DFP), INTENT(IN) :: B(:) - !! RHS - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! IPIV returned from SymGetLU - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info - END SUBROUTINE SymLUSolve_3 -END INTERFACE - -INTERFACE SymLUSolve - MODULE PROCEDURE SymLUSolve_3 -END INTERFACE SymLUSolve - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve LUx=y -! -!# Introduction -! -! It calls `SYTRS` - -INTERFACE - MODULE SUBROUTINE SymLUSolve_4(X, A, B, IPIV, UPLO, info) - REAL(DFP), INTENT(OUT) :: X(:, :) - !! Solution - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! LDLt decomposition of matrix A, see SymGetLU - REAL(DFP), INTENT(IN) :: B(:, :) - !! at entry RHS - !! on return solution will be in B - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! IPIV returned from SymGetLU - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! If UPLO="U", then upper triangular part of A is used - !! If UPLO="L", then lower triangular part of A is used - !! Default = "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - !! info - END SUBROUTINE SymLUSolve_4 -END INTERFACE - -INTERFACE SymLUSolve - MODULE PROCEDURE SymLUSolve_4 -END INTERFACE SymLUSolve - -!---------------------------------------------------------------------------- -! SymGetInv -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-20 -! summary: get inverse of square matrix from LU decomposition -! -!# Introduction -! -! It calls `SYTRI` - -INTERFACE - MODULE SUBROUTINE SymGetInv_1(A, invA, IPIV, UPLO, INFO) - REAL(DFP), INTENT(IN) :: A(:, :) - !! LU Decomposition from SymGetLU - REAL(DFP), INTENT(INOUT) :: invA(:, :) - !! Inverse of A - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! Returned from SymGetLU - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE SymGetInv_1 -END INTERFACE - -INTERFACE SymGetInv - MODULE PROCEDURE SymGetInv_1 -END INTERFACE SymGetInv - -!---------------------------------------------------------------------------- -! SymGetInv -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-20 -! summary: get inverse of square matrix from LU decomposition -! -!# Introduction -! -! It calls `SYTRI` - -INTERFACE - MODULE SUBROUTINE SymGetInv_2(A, IPIV, UPLO, INFO) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! On entry: LU Decomposition from SymGetLU - !! On Exit: Inverse of A - INTEGER(I4B), INTENT(IN) :: IPIV(:) - !! Returned from SymGetLU - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info - END SUBROUTINE SymGetInv_2 -END INTERFACE - -INTERFACE SymGetInv - MODULE PROCEDURE SymGetInv_2 -END INTERFACE SymGetInv - -END MODULE Sym_LUMethods diff --git a/src/modules/Lapack/src/Sym_Lapack_Method.F90 b/src/modules/Lapack/src/Sym_Lapack_Method.F90 deleted file mode 100644 index de9a80a22..000000000 --- a/src/modules/Lapack/src/Sym_Lapack_Method.F90 +++ /dev/null @@ -1,40 +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: 20 December 2022 -! summary: Lapack methods -! -!# Introduction -! -! This module contains linear algebra packages for fortran matrix (2D array) -! The matrix is symmetric and dense -! -! This module contains following submoduls -! - @LinearSolveMethods TODO -! - @EigenValueMethods TODO -! - @SingularValueMethods TODO -! - @CompRoutineMethods TODO -! - @AuxRoutinesMethods TODO - -MODULE Sym_Lapack_Method -USE Sym_CompRoutineMethods -USE Sym_EigenValueMethods -USE Sym_LUMethods -USE Sym_LinearSolveMethods -USE Sym_SingularValueMethods -END MODULE Sym_Lapack_Method diff --git a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 deleted file mode 100644 index 923cbdd6b..000000000 --- a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 +++ /dev/null @@ -1,290 +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 -! -! Linear Solver name -!- SYSV - -MODULE Sym_LinearSolveMethods -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE - -PUBLIC :: SymSolve -PUBLIC :: SymLinSolve - -!---------------------------------------------------------------------------- -! Solve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 7 July 2022 -! summary: This function solves Ax=b using lapack, A can be square or rect -! -!# Introduction -! -! This function solves Ax=b using LAPACK. -! -! This routine creates a copy of A and B. So do not use it for large -! systems. -! -! When A is a square matrix, then this routine calls GESV routine. -! -!## SYSV -! -! SYSV computes the solution to a real system of linear equations -! -!$$ -! Ax = y, -!$$ -! -! The LDLt decomposition with partial pivoting and row interchanges is -! used to factor A as (See SYTRF) -! -!@note -! Note that this routine creates a copy of A and b and then find x. -! This is because DGESV modifies the entries of A and b. -! Therefore, when A is large this routine should be avoided. -!@endnote - -INTERFACE - MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & - & UPLO, INFO) - REAL(DFP), INTENT(INOUT) :: X(:) - !! Unknown vector to be found - REAL(DFP), INTENT(IN) :: A(:, :) - !! Symmetric square matrix - REAL(DFP), INTENT(IN) :: B(:) - !! RHS of Ax=B - LOGICAL(LGT), INTENT(IN) :: preserveA - !! This flag is only for getting a unique interface - !! it is always set to true - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! Used for SYSV - !! IPIV is INTEGER array, dimension (N) - !! It is returned by SYTRF - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, default is SYSV - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! "U" or "L", Default is "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO - END SUBROUTINE SymLinSolve_1 -END INTERFACE - -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_1 -END INTERFACE SymSolve - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_1 -END INTERFACE SymLinSolve - -!---------------------------------------------------------------------------- -! Solve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 7 July 2022 -! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays -! -!# Introduction -! -! -! This function solves Ax=b using LAPACK. A is square and symmetric -! matrix. In this case we have several RHS denoted by B matrix. -! -! All other things are same as `ge_solve_1`. - -INTERFACE - MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & - & UPLO, INFO) - REAL(DFP), INTENT(INOUT) :: X(:, :) - !! Unknown vector - REAL(DFP), INTENT(IN) :: A(:, :) - !! General square matrix - REAL(DFP), INTENT(IN) :: B(:, :) - !! RHS of Ax=B - LOGICAL(LGT), INTENT(IN) :: preserveA - !! This flag is only for getting a unique interface - !! it is always set to true - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! inverse of permuation - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! "U" or "L", default is "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO - END SUBROUTINE SymLinSolve_2 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_2 -END INTERFACE SymLinSolve - -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_2 -END INTERFACE SymSolve - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve Ax=Y -! -!# Introduction -! -! This routine is same as `ge_solve_1` with following difference. -! -! In this subroutine we do not make copy of A. Therefore A will be -! modified on return. Note that B will not be modified as we still -! make a copy of B. - -INTERFACE - MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) - REAL(DFP), INTENT(INOUT) :: X(:) - !! Unknown vector solution - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square sym matrix, it will be modified on return - REAL(DFP), INTENT(IN) :: B(:) - !! RHS of Ax=B - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! PERMUTATION - CHARACTER(1), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is SYSV - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! "U" or "L", default is "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO - END SUBROUTINE SymLinSolve_3 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_3 -END INTERFACE SymLinSolve - -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_3 -END INTERFACE SymSolve - -!---------------------------------------------------------------------------- -! LinSolve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 7 July 2022 -! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays - -INTERFACE - MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) - REAL(DFP), INTENT(INOUT) :: X(:, :) - !! Unknown vector or solution - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square sym matrix, its content will be destroyed - REAL(DFP), INTENT(IN) :: B(:, :) - !! RHS of Ax=B - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! inverse of permuation - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, default is SYSV - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! "U" or "L", default is "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO - END SUBROUTINE SymLinSolve_4 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_4 -END INTERFACE SymLinSolve - -INTERFACE Solve - MODULE PROCEDURE SymLinSolve_4 -END INTERFACE Solve - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary:Solve Ax=b -! -!# Introduction -! -! This routine is same as `ge_linsolve_1` with following changes -! -! We do not make any copy of B. The solution is returned in B. This -! means B will be destroyed on return. - -INTERFACE - MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square symmetric matrix, its content will be modified on - !! return - REAL(DFP), INTENT(INOUT) :: B(:) - !! RHS of Ax=B, it will contain the solution on return - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - ! IPIV is INTEGER array, dimension (N) - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! "L" or "U", default is "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO - END SUBROUTINE SymLinSolve_5 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_5 -END INTERFACE SymLinSolve - -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_5 -END INTERFACE SymSolve - -!---------------------------------------------------------------------------- -! LinSolve@LinearSolveMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2022 -! summary: Solve Ax=y - -INTERFACE - MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) - REAL(DFP), INTENT(INOUT) :: A(:, :) - !! General square/rectangle matrix, its content will be modifie - !! on return - REAL(DFP), INTENT(INOUT) :: B(:, :) - !! RHS of Ax=B, it will be modified such that it contains solution on - !! return - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) - !! inverse of permuation - CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName - !! Name of the solver, when A is not square, default is GELS - CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO - !! "U" or "L", default is "U" - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO - END SUBROUTINE SymLinSolve_6 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_6 -END INTERFACE SymLinSolve - -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_6 -END INTERFACE SymSolve - -END MODULE Sym_LinearSolveMethods diff --git a/src/modules/Lapack/src/Sym_SingularValueMethods.F90 b/src/modules/Lapack/src/Sym_SingularValueMethods.F90 deleted file mode 100644 index da67af637..000000000 --- a/src/modules/Lapack/src/Sym_SingularValueMethods.F90 +++ /dev/null @@ -1,20 +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 Sym_SingularValueMethods - -END MODULE Sym_SingularValueMethods diff --git a/src/modules/LuaInterface/CMakeLists.txt b/src/modules/LuaInterface/CMakeLists.txt deleted file mode 100644 index 0431e2dda..000000000 --- a/src/modules/LuaInterface/CMakeLists.txt +++ /dev/null @@ -1,30 +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 -# - -IF(USE_LUA) - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/LuaInterface.F90 - ) -ELSE() - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/No_LuaInterface.F90 - ) -ENDIF() diff --git a/src/modules/LuaInterface/src/LuaInterface.F90 b/src/modules/LuaInterface/src/LuaInterface.F90 deleted file mode 100644 index 68917c52d..000000000 --- a/src/modules/LuaInterface/src/LuaInterface.F90 +++ /dev/null @@ -1,1499 +0,0 @@ -! This module is taken from -! https://github.com/interkosmos/fortran-lua54 -! -! lua.f90 -! -! A collection of ISO C binding interfaces to Lua 5.4 for Fortran 2008. -! -! Author: Philipp Engel -! Licence: ISC -! -! I have modified it slighly according to the EASIFEM requirement. -! - -MODULE LuaInterface -USE, INTRINSIC :: ISO_C_BINDING -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: i8 => INT64 -USE GlobalData, ONLY: I4B -USE Display_Method, ONLY: Display -IMPLICIT NONE -PRIVATE - -! The integer and float types used by Lua are platform-specific. -! Select the types according to your local Lua library. -INTEGER, PARAMETER, PUBLIC :: lua_integer = C_LONG_LONG -! The other options for lua_integer are -! c_int, c_long, c_long_long, c_int64_t -INTEGER, PARAMETER, PUBLIC :: lua_number = C_DOUBLE -! The other options for lua_number are -! c_float, c_double, c_long_double -INTEGER, PARAMETER, PUBLIC :: lua_kcontext = C_INTPTR_T -! The other options for lua_kcontext are -! c_intptr_t, c_ptrdiff_t - -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_VERSION_NUM = 504 - -! Option for multiple returns in `lua_pcall()` and `lua_call()`. -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_MULTRET = -1 - -! Basic types. -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TNONE = -1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TNIL = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TBOOLEAN = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TLIGHTUSERDATA = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TNUMBER = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TSTRING = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TTABLE = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TFUNCTION = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TUSERDATA = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TTHREAD = 8 - -! Comparison and arithmetic options. -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPADD = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPSUB = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPMUL = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPMOD = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPPOW = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPDIV = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPIDIV = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBAND = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBOR = 8 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBXOR = 9 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPSHL = 10 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPSHR = 11 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPUNM = 12 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBNOT = 13 - -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPEQ = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPLT = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPLE = 2 - -! Garbage-collection options. -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSTOP = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCRESTART = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCCOLLECT = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCCOUNT = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCCOUNTB = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSTEP = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSETPAUSE = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSETSTEPMUL = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCISRUNNING = 9 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCGEN = 10 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCINC = 11 - -! Error codes. -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OK = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_YIELD = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRRUN = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRSYNTAX = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRMEM = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRERR = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRFILE = LUA_ERRERR + 1 - -PUBLIC :: lua_checkerror -PUBLIC :: lua_arith -PUBLIC :: lua_call -PUBLIC :: lua_callk -PUBLIC :: lua_checkstack -PUBLIC :: lua_close -PUBLIC :: lua_compare -PUBLIC :: lua_concat -PUBLIC :: lua_copy -PUBLIC :: lua_createtable -PUBLIC :: lua_gc -PUBLIC :: lua_getfield -PUBLIC :: lua_getglobal -PUBLIC :: lua_gettable -PUBLIC :: lua_gettop -PUBLIC :: lua_isboolean -PUBLIC :: lua_iscfunction -PUBLIC :: lua_isfunction -PUBLIC :: lua_isinteger -PUBLIC :: lua_isnil -PUBLIC :: lua_isnone -PUBLIC :: lua_isnoneornil -PUBLIC :: lua_isnumber -PUBLIC :: lua_isstring -PUBLIC :: lua_istable -PUBLIC :: lua_isthread -PUBLIC :: lua_isuserdata -PUBLIC :: lua_isyieldable -PUBLIC :: lua_load -PUBLIC :: lua_newtable -PUBLIC :: lua_pcall -PUBLIC :: lua_pcallk -PUBLIC :: lua_pop -PUBLIC :: lua_pushboolean -PUBLIC :: lua_pushcclosure -PUBLIC :: lua_pushinteger -PUBLIC :: lua_pushlightuserdata -PUBLIC :: lua_pushlstring -PUBLIC :: lua_pushnil -PUBLIC :: lua_pushnumber -PUBLIC :: lua_pushstring -PUBLIC :: lua_pushthread -PUBLIC :: lua_pushvalue -PUBLIC :: lua_rawget -PUBLIC :: lua_rawgeti -PUBLIC :: lua_rawlen -PUBLIC :: lua_rawset -PUBLIC :: lua_rawseti -PUBLIC :: lua_register -PUBLIC :: lua_setfield -PUBLIC :: lua_setglobal -PUBLIC :: lua_seti -PUBLIC :: lua_settable -PUBLIC :: lua_settop -PUBLIC :: lua_status -PUBLIC :: lua_toboolean -PUBLIC :: lua_tointeger -PUBLIC :: lua_tointegerx -PUBLIC :: lua_tonumber -PUBLIC :: lua_tonumberx -PUBLIC :: lua_tostring -PUBLIC :: lua_type -PUBLIC :: lua_typename -PUBLIC :: lua_version -PUBLIC :: lual_checkversion_ -PUBLIC :: lual_dofile -PUBLIC :: lual_dostring -PUBLIC :: lual_len -PUBLIC :: lual_loadfile -PUBLIC :: lual_loadfilex -PUBLIC :: lual_loadstring -PUBLIC :: lual_newstate -PUBLIC :: lual_openlibs - -PRIVATE :: c_f_str_ptr - -!---------------------------------------------------------------------------- -! Strlen -!---------------------------------------------------------------------------- - -! Interfaces to libc. -INTERFACE - FUNCTION c_strlen(str) BIND(c, name='strlen') - IMPORT :: C_PTR, C_SIZE_T - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: str - INTEGER(kind=C_SIZE_T) :: c_strlen - END FUNCTION c_strlen -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_checkstack -!---------------------------------------------------------------------------- - -! Interfaces to Lua 5.4. -INTERFACE - ! int lua_checkstack(lua_State *L, int n) - FUNCTION lua_checkstack(l, n) BIND(c, name='lua_checkstack') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: n - INTEGER(kind=C_INT) :: lua_checkstack - END FUNCTION lua_checkstack -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_compare -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_compare(lua_State *L, int index1, int index2, int op) - FUNCTION lua_compare(l, index1, index2, op) BIND(c, name='lua_compare') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: index1 - INTEGER(kind=C_INT), INTENT(in), VALUE :: index2 - INTEGER(kind=C_INT), INTENT(in), VALUE :: op - INTEGER(kind=C_INT) :: lua_compare - END FUNCTION lua_compare -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_gc -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_gc(lua_State *L, int what, int data) - FUNCTION lua_gc(l, what, DATA) BIND(c, name='lua_gc') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: what - INTEGER(kind=C_INT), INTENT(in), VALUE :: DATA - INTEGER(kind=C_INT) :: lua_gc - END FUNCTION lua_gc -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_getfield -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_getfield(lua_State *L, int idx, const char *k) - FUNCTION lua_getfield_(l, idx, k) BIND(c, name='lua_getfield') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - CHARACTER(kind=C_CHAR), INTENT(in) :: k - INTEGER(kind=C_INT) :: lua_getfield_ - END FUNCTION lua_getfield_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_getglobal -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_getglobal(lua_State *L, const char *name) - FUNCTION lua_getglobal_(l, name) BIND(c, name='lua_getglobal') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - CHARACTER(kind=C_CHAR), INTENT(in) :: name - INTEGER(kind=C_INT) :: lua_getglobal_ - END FUNCTION lua_getglobal_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_gettable -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_gettable (lua_State *L, int idx) - FUNCTION lua_gettable(l, idx) BIND(c, name='lua_gettable') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_gettable - END FUNCTION lua_gettable -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_gettop -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_gettop(lua_State *L) - FUNCTION lua_gettop(l) BIND(c, name='lua_gettop') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT) :: lua_gettop - END FUNCTION lua_gettop -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_iscfunction -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_iscfunction(lua_State *L, int idx) - FUNCTION lua_iscfunction(l, idx) BIND(c, name='lua_iscfunction') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_iscfunction - END FUNCTION lua_iscfunction -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_isinteger -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_isinteger(lua_State *L, int idx) - FUNCTION lua_isinteger(l, idx) BIND(c, name='lua_isinteger') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_isinteger - END FUNCTION lua_isinteger -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_isnumber -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_isnumber(lua_State *L, int idx) - FUNCTION lua_isnumber(l, idx) BIND(c, name='lua_isnumber') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_isnumber - END FUNCTION lua_isnumber - -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_isstring -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_isstring(lua_State *L, int idx) - FUNCTION lua_isstring(l, idx) BIND(c, name='lua_isstring') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_isstring - END FUNCTION lua_isstring -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_isuserdata -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_isuserdata(lua_State *L, int idx) - FUNCTION lua_isuserdata(l, idx) BIND(c, name='lua_isuserdata') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_isuserdata - END FUNCTION lua_isuserdata -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_isyieldable -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_isyieldable(lua_State *L) - FUNCTION lua_isyieldable(l) BIND(c, name='lua_isyielable') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT) :: lua_isyieldable - END FUNCTION lua_isyieldable -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_load -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_load(lua_State *L, lua_Reader reader, void *data, const char *chunkname, const char *mode) - FUNCTION lua_load(l, reader, DATA, chunkname, mode) BIND(c, name='lua_load') - IMPORT :: C_CHAR, C_FUNPTR, C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - TYPE(C_FUNPTR), INTENT(in), VALUE :: reader - TYPE(C_PTR), INTENT(in), VALUE :: DATA - CHARACTER(kind=C_CHAR), INTENT(in) :: chunkname - CHARACTER(kind=C_CHAR), INTENT(in) :: mode - INTEGER(kind=C_INT) :: lua_load - END FUNCTION lua_load -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_rawget -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_rawget(lua_State *L, int idx) - FUNCTION lua_rawget(l, idx) BIND(c, name='lua_rawget') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_rawget - END FUNCTION lua_rawget -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_rawgeti -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_rawgeti(lua_State *L, int idx, lua_Integer n) - FUNCTION lua_rawgeti(l, idx, n) BIND(c, name='lua_rawgeti') - IMPORT :: C_INT, C_PTR, lua_integer - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=lua_integer), INTENT(in), VALUE :: n - INTEGER(kind=C_INT) :: lua_rawgeti - END FUNCTION lua_rawgeti -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_rawlen -!---------------------------------------------------------------------------- - -INTERFACE - ! size_t lua_rawlen(lua_State *L, int idx) - FUNCTION lua_rawlen(l, idx) BIND(c, name='lua_rawlen') - IMPORT :: C_INT, C_PTR, C_SIZE_T - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_SIZE_T) :: lua_rawlen - END FUNCTION lua_rawlen -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_status -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_status(lua_State *L) - FUNCTION lua_status(l) BIND(c, name='lua_status') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT) :: lua_status - END FUNCTION lua_status -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_toboolean -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_toboolean(lua_State *L, int idx) - FUNCTION lua_toboolean_(l, idx) BIND(c, name='lua_toboolean') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_toboolean_ - END FUNCTION lua_toboolean_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_tonumberx -!---------------------------------------------------------------------------- - -INTERFACE - ! float lua_tonumberx(lua_State *L, int idx, int *isnum) - FUNCTION lua_tonumberx(l, idx, isnum) BIND(c, name='lua_tonumberx') - IMPORT :: C_INT, C_PTR, lua_number - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - TYPE(C_PTR), INTENT(in), VALUE :: isnum - REAL(kind=lua_number) :: lua_tonumberx - END FUNCTION lua_tonumberx -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_tointegerx -!---------------------------------------------------------------------------- - -INTERFACE - ! lua_Integer lua_tointegerx(lua_State *L, int idx, int *isnum) - FUNCTION lua_tointegerx(l, idx, isnum) BIND(c, name='lua_tointegerx') - IMPORT :: C_INT, C_PTR, lua_integer - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - TYPE(C_PTR), INTENT(in), VALUE :: isnum - INTEGER(kind=lua_integer) :: lua_tointegerx - END FUNCTION lua_tointegerx - -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_tolstring -!---------------------------------------------------------------------------- - -INTERFACE - ! const char *lua_tolstring(lua_State *L, int idx, size_t *len) - FUNCTION lua_tolstring(l, idx, len) BIND(c, name='lua_tolstring') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - TYPE(C_PTR), INTENT(in), VALUE :: len - TYPE(C_PTR) :: lua_tolstring - END FUNCTION lua_tolstring -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_type -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_type(lua_State *L, int idx) - FUNCTION lua_type(l, idx) BIND(c, name='lua_type') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lua_type - END FUNCTION lua_type -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_typename -!---------------------------------------------------------------------------- - -INTERFACE - ! const char *lua_typename(lua_State *L, int tp) - FUNCTION lua_typename_(l, tp) BIND(c, name='lua_typename') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: tp - TYPE(C_PTR) :: lua_typename_ - END FUNCTION lua_typename_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pcallk -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_pcallk(lua_State *L, int nargs, int nresults, int errfunc, lua_KContext ctx, lua_KFunction k) - function lua_pcallk(l, nargs, nresults, errfunc, ctx, k) bind(c, name='lua_pcallk') - IMPORT :: C_FUNPTR, C_INT, C_PTR, lua_kcontext - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: nargs - INTEGER(kind=C_INT), INTENT(in), VALUE :: nresults - INTEGER(kind=C_INT), INTENT(in), VALUE :: errfunc - INTEGER(kind=lua_kcontext), INTENT(in), VALUE :: ctx - TYPE(C_FUNPTR), INTENT(in), VALUE :: k - INTEGER(kind=C_INT) :: lua_pcallk - END FUNCTION lua_pcallk -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushlstring -!---------------------------------------------------------------------------- - -INTERFACE - ! const char *lua_pushlstring(lua_State *L, const char *s, size_t len) - FUNCTION lua_pushlstring_(l, s, len) BIND(c, name='lua_pushlstring') - IMPORT :: C_CHAR, C_PTR, C_SIZE_T - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - CHARACTER(kind=C_CHAR), INTENT(in) :: s - INTEGER(kind=C_SIZE_T), INTENT(in), VALUE :: len - TYPE(C_PTR) :: lua_pushlstring_ - END FUNCTION lua_pushlstring_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushstring -!---------------------------------------------------------------------------- - -INTERFACE - ! const char *lua_pushstring(lua_State *L, const char *s) - FUNCTION lua_pushstring_(l, s) BIND(c, name='lua_pushstring') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - CHARACTER(kind=C_CHAR), INTENT(in) :: s - TYPE(C_PTR) :: lua_pushstring_ - END FUNCTION lua_pushstring_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushthread -!---------------------------------------------------------------------------- - -INTERFACE - ! int lua_pushthread(lua_State *L) - FUNCTION lua_pushthread(l) BIND(c, name='lua_pushthread') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT) :: lua_pushthread - END FUNCTION lua_pushthread -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_version -!---------------------------------------------------------------------------- - -INTERFACE - ! lua_Number lua_version(lua_State *L) - FUNCTION lua_version(l) BIND(c, name='lua_version') - IMPORT :: C_PTR, lua_number - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - REAL(kind=lua_number) :: lua_version - END FUNCTION lua_version -END INTERFACE - -!---------------------------------------------------------------------------- -! luaL_len -!---------------------------------------------------------------------------- - -INTERFACE - ! int luaL_len(lua_State *L, int idx) - FUNCTION lual_len(l, idx) BIND(c, name='luaL_len') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=C_INT) :: lual_len - END FUNCTION lual_len -END INTERFACE - -!---------------------------------------------------------------------------- -! lual_loadfilex -!---------------------------------------------------------------------------- - -INTERFACE - ! int luaL_loadfilex(lua_State *L, const char *filename, const char *mode) - FUNCTION lual_loadfilex(l, filename, mode) BIND(c, name='luaL_loadfilex') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - CHARACTER(kind=C_CHAR), INTENT(in) :: filename - TYPE(C_PTR), INTENT(in), VALUE :: mode - INTEGER(kind=C_INT) :: lual_loadfilex - END FUNCTION lual_loadfilex -END INTERFACE - -!---------------------------------------------------------------------------- -! lual_loadstring -!---------------------------------------------------------------------------- - -INTERFACE - ! int luaL_loadstring(lua_State *L, const char *s) - FUNCTION lual_loadstring_(l, s) BIND(c, name='luaL_loadstring') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - CHARACTER(kind=C_CHAR), INTENT(in) :: s - INTEGER(kind=C_INT) :: lual_loadstring_ - END FUNCTION lual_loadstring_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lual_newstate -!---------------------------------------------------------------------------- - -INTERFACE - ! lua_State *luaL_newstate(void) - FUNCTION lual_newstate() BIND(c, name='luaL_newstate') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR) :: lual_newstate - END FUNCTION lual_newstate -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_arith -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_arith(lua_State *L, int op) - SUBROUTINE lua_arith(l, op) BIND(c, name='lua_arith') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: op - END SUBROUTINE lua_arith -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_callk -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_callk(lua_State *L, int nargs, int nresults, lua_KContext ctx, lua_CFunction k) - SUBROUTINE lua_callk(l, nargs, nresults, ctx, k) BIND(c, name='lua_callk') - IMPORT :: C_FUNPTR, C_INT, C_PTR, lua_kcontext - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: nargs - INTEGER(kind=C_INT), INTENT(in), VALUE :: nresults - INTEGER(kind=lua_kcontext), INTENT(in), VALUE :: ctx - TYPE(C_FUNPTR), INTENT(in), VALUE :: k - END SUBROUTINE lua_callk -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_close -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_close(lua_State *L) - SUBROUTINE lua_close(l) BIND(c, name='lua_close') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - END SUBROUTINE lua_close - -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_concat -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_concat(lua_State *L, int n) - SUBROUTINE lua_concat(l, n) BIND(c, name='lua_concat') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: n - END SUBROUTINE lua_concat -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_copy(lua_State *L, int fromidx, int toidx) - SUBROUTINE lua_copy(l, fromidx, toidx) BIND(c, name='lua_copy') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: fromidx - INTEGER(kind=C_INT), INTENT(in), VALUE :: toidx - END SUBROUTINE lua_copy -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_createtable -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_createtable(lua_State *L, int narr, int nrec) - SUBROUTINE lua_createtable(l, narr, nrec) BIND(c, name='lua_createtable') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: narr - INTEGER(kind=C_INT), INTENT(in), VALUE :: nrec - END SUBROUTINE lua_createtable -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushboolean -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_pushboolean(lua_State *L, int b) - SUBROUTINE lua_pushboolean(l, b) BIND(c, name='lua_pushboolean') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: b - END SUBROUTINE lua_pushboolean -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushcclosure -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_pushcclosure(lua_State *L, lua_CFunction fn, int n) - SUBROUTINE lua_pushcclosure(l, fn, n) BIND(c, name='lua_pushcclosure') - IMPORT :: C_FUNPTR, C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - TYPE(C_FUNPTR), INTENT(in), VALUE :: fn - INTEGER(kind=C_INT), INTENT(in), VALUE :: n - END SUBROUTINE lua_pushcclosure -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushinteger -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_pushinteger(lua_State *L, lua_Integer n) - SUBROUTINE lua_pushinteger(l, n) BIND(c, name='lua_pushinteger') - IMPORT :: C_PTR, lua_integer - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=lua_integer), INTENT(in), VALUE :: n - END SUBROUTINE lua_pushinteger - -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushlightuserdata -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_pushlightuserdata(lua_State *L, void *p) - SUBROUTINE lua_pushlightuserdata(l, p) BIND(c, name='lua_pushlightuserdata') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - TYPE(C_PTR), INTENT(in), VALUE :: p - END SUBROUTINE lua_pushlightuserdata -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushnil -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_pushnil(lua_State *L) - SUBROUTINE lua_pushnil(l) BIND(c, name='lua_pushnil') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - END SUBROUTINE lua_pushnil -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushnumber -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_pushnumber(lua_State *L, lua_Number n) - SUBROUTINE lua_pushnumber(l, n) BIND(c, name='lua_pushnumber') - IMPORT :: C_PTR, lua_number - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - REAL(kind=lua_number), INTENT(in), VALUE :: n - END SUBROUTINE lua_pushnumber -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_pushvalue -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_pushvalue(lua_State *L, int idx) - SUBROUTINE lua_pushvalue(l, idx) BIND(c, name='lua_pushvalue') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - END SUBROUTINE lua_pushvalue -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_rawset -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_rawset(lua_State *L, int idx) - SUBROUTINE lua_rawset(l, idx) BIND(c, name='lua_rawset') - IMPORT :: C_INT, C_PTR, lua_integer - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - END SUBROUTINE lua_rawset -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_rawseti -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_rawseti(lua_State *L, int idx, lua_Integer n) - SUBROUTINE lua_rawseti(l, idx, n) BIND(c, name='lua_rawseti') - IMPORT :: C_INT, C_PTR, lua_integer - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=lua_integer), INTENT(in), VALUE :: n - END SUBROUTINE lua_rawseti -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_setfield -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_setfield(lua_State *L, int idx, const char *k) - SUBROUTINE lua_setfield_(l, idx, k) BIND(c, name='lua_setfield') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - CHARACTER(kind=C_CHAR), INTENT(in) :: k - END SUBROUTINE lua_setfield_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_setglobal -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_setglobal(lua_State *L, const char *name) - SUBROUTINE lua_setglobal_(l, name) BIND(c, name='lua_setglobal') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - CHARACTER(kind=C_CHAR), INTENT(in) :: name - END SUBROUTINE lua_setglobal_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_seti -!---------------------------------------------------------------------------- -INTERFACE - ! void lua_seti(lua_State *L, int idx, lua_Integer n) - SUBROUTINE lua_seti(l, idx, n) BIND(c, name='lua_seti') - IMPORT :: C_INT, C_PTR, lua_integer - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - INTEGER(kind=lua_integer), INTENT(in), VALUE :: n - END SUBROUTINE lua_seti -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_settable -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_settable(lua_State *L, int idx) - SUBROUTINE lua_settable(l, idx) BIND(c, name='lua_settable') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - END SUBROUTINE lua_settable -END INTERFACE - -!---------------------------------------------------------------------------- -! lua_settop -!---------------------------------------------------------------------------- - -INTERFACE - ! void lua_settop(lua_State *L, int idx) - SUBROUTINE lua_settop(l, idx) BIND(c, name='lua_settop') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - INTEGER(kind=C_INT), INTENT(in), VALUE :: idx - END SUBROUTINE lua_settop -END INTERFACE - -!---------------------------------------------------------------------------- -! lual_checkversion_ -!---------------------------------------------------------------------------- - -INTERFACE - ! void luaL_checkversion_(lua_State *L, lua_Number ver, size_t sz) - SUBROUTINE lual_checkversion_(l, ver, sz) BIND(c, name='luaL_checkversion_') - IMPORT :: C_PTR, C_SIZE_T, lua_number - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - REAL(kind=lua_number), INTENT(in), VALUE :: ver - INTEGER(kind=C_SIZE_T), INTENT(in), VALUE :: sz - END SUBROUTINE lual_checkversion_ -END INTERFACE - -!---------------------------------------------------------------------------- -! lual_openlibs -!---------------------------------------------------------------------------- - -INTERFACE - ! void luaL_openlibs(lua_State *L) - SUBROUTINE lual_openlibs(l) BIND(c, name='luaL_openlibs') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: l - END SUBROUTINE lual_openlibs -END INTERFACE - -!---------------------------------------------------------------------------- -! Constains -!---------------------------------------------------------------------------- - -CONTAINS - -!---------------------------------------------------------------------------- -! lua_checkerror -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-11-19 -! summary: Check error - -SUBROUTINE lua_checkerror(ierr, file, routine, lineNo, unitNo) - INTEGER(I4B), INTENT(IN) :: ierr - CHARACTER(*), INTENT(IN) :: file - CHARACTER(*), INTENT(IN) :: routine - INTEGER(I4B), INTENT(IN) :: lineNo - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitNo - - IF (ierr .NE. LUA_OK) THEN - CALL Display("ERROR while running lua code :", unitNo=unitNo) - CALL Display(file, "file :", unitNo=unitNo) - CALL Display(routine, "routine :", unitNo=unitNo) - CALL Display(lineNo, "line :", unitNo=unitNo) - END IF - ! SELECT CASE (ierr) - ! ! CASE (LUA_OK) - ! ! case(LUA_YIELD) - ! ! case(LUA_ERRRUN) - ! ! case(LUA_ERRSYNTAX) - ! ! case(LUA_ERRMEM) - ! ! case(LUA_ERRERR) - ! ! case(LUA_ERRFILE) - ! END SELECT -END SUBROUTINE lua_checkerror - -!---------------------------------------------------------------------------- -! lua_getfield -!---------------------------------------------------------------------------- - -! int lua_getfield(lua_State *L, int idx, const char *k) -FUNCTION lua_getfield(l, idx, k) - !! Wrapper for `lua_getfield_()` that null-terminates string `k`. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - CHARACTER(*), INTENT(in) :: k - INTEGER :: lua_getfield - - lua_getfield = lua_getfield_(l, idx, k//C_NULL_CHAR) -END FUNCTION lua_getfield - -!---------------------------------------------------------------------------- -! lua_getglobal -!---------------------------------------------------------------------------- - -! int lua_getglobal(lua_State *L, const char *name) -FUNCTION lua_getglobal(l, name) - !! Wrapper for `lua_getglobal_()` that null-terminates string `name`. - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: name - INTEGER :: lua_getglobal - - lua_getglobal = lua_getglobal_(l, name//C_NULL_CHAR) -END FUNCTION lua_getglobal - -!---------------------------------------------------------------------------- -! lua_isboolean -!---------------------------------------------------------------------------- - -! int lua_isboolean(lua_State *L, int index) -FUNCTION lua_isboolean(l, idx) - !! Macro replacement that returns whether the stack variable is - !! boolean. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_isboolean - - lua_isboolean = 0 - IF (lua_type(l, idx) == LUA_TBOOLEAN) lua_isboolean = 1 -END FUNCTION lua_isboolean - -!---------------------------------------------------------------------------- -! lua_isfunction -!---------------------------------------------------------------------------- - -! int lua_isfunction(lua_State *L, int index) -FUNCTION lua_isfunction(l, idx) - !! Macro replacement that returns whether the stack variable is a - !! function. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_isfunction - - lua_isfunction = 0 - IF (lua_type(l, idx) == LUA_TFUNCTION) lua_isfunction = 1 -END FUNCTION lua_isfunction - -!---------------------------------------------------------------------------- -! lua_islightuserdata -!---------------------------------------------------------------------------- - -! int lua_islightuserdata(lua_State *L, int index) -FUNCTION lua_islightuserdata(l, idx) - !! Macro replacement that returns whether the stack variable is - !! light user data. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_islightuserdata - - lua_islightuserdata = 0 - IF (lua_type(l, idx) == LUA_TLIGHTUSERDATA) lua_islightuserdata = 1 -END FUNCTION lua_islightuserdata - -!---------------------------------------------------------------------------- -! lua_islightuserdata -!---------------------------------------------------------------------------- - -! int lua_isnil(lua_State *L, int index) -FUNCTION lua_isnil(l, idx) - !! Macro replacement that returns whether the stack variable is - !! nil. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_isnil - - lua_isnil = 0 - IF (lua_type(l, idx) == LUA_TNIL) lua_isnil = 1 -END FUNCTION lua_isnil - -!---------------------------------------------------------------------------- -! lua_isnone -!---------------------------------------------------------------------------- - -! int lua_isnone(lua_State *L, int index) -FUNCTION lua_isnone(l, idx) - !! Macro replacement that returns whether the stack variable is - !! none. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_isnone - - lua_isnone = 0 - IF (lua_type(l, idx) == LUA_TNONE) lua_isnone = 1 -END FUNCTION lua_isnone - -!---------------------------------------------------------------------------- -! lua_isnoneornil -!---------------------------------------------------------------------------- - -! int lua_isnoneornil(lua_State *L, int index) -FUNCTION lua_isnoneornil(l, idx) - !! Macro replacement that returns whether the stack variable is - !! none or nil. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_isnoneornil - - lua_isnoneornil = 0 - IF (lua_type(l, idx) <= 0) lua_isnoneornil = 1 -END FUNCTION lua_isnoneornil - -!---------------------------------------------------------------------------- -! lua_istable -!---------------------------------------------------------------------------- - -! int lua_istable(lua_State *L, int index) -FUNCTION lua_istable(l, idx) - !! Macro replacement that returns whether the stack variable is a - !! table. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_istable - - lua_istable = 0 - IF (lua_type(l, idx) == LUA_TTABLE) lua_istable = 1 -END FUNCTION lua_istable - -!---------------------------------------------------------------------------- -! lua_isthread -!---------------------------------------------------------------------------- - -! int lua_isthread(lua_State *L, int index) -FUNCTION lua_isthread(l, idx) - !! Macro replacement that returns whether the stack variable is a - !! thread. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER :: lua_isthread - - lua_isthread = 0 - IF (lua_type(l, idx) == LUA_TTHREAD) lua_isthread = 1 -END FUNCTION lua_isthread - -!---------------------------------------------------------------------------- -! lua_pcall -!---------------------------------------------------------------------------- - -! int lua_pcall(lua_State *L, int nargs, int nresults, int msgh) -FUNCTION lua_pcall(l, nargs, nresults, errfunc) - !! Macro replacement that calls `lua_pcallk()`. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: nargs - INTEGER, INTENT(in) :: nresults - INTEGER, INTENT(in) :: errfunc - INTEGER :: lua_pcall - - lua_pcall = lua_pcallk(l, nargs, nresults, errfunc, & - & INT(0, kind=lua_kcontext), C_NULL_FUNPTR) -END FUNCTION lua_pcall - -!---------------------------------------------------------------------------- -! lua_tointeger -!---------------------------------------------------------------------------- - -! lua_Integer lua_tointeger(lua_State *l, int idx) -FUNCTION lua_tointeger(l, idx) - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - INTEGER(kind=lua_integer) :: lua_tointeger - - lua_tointeger = lua_tointegerx(l, idx, C_NULL_PTR) -END FUNCTION lua_tointeger - -!---------------------------------------------------------------------------- -! lua_toboolean -!---------------------------------------------------------------------------- - -! logical lua_toboolean(lua_State *L, int index) -FUNCTION lua_toboolean(l, idx) - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - LOGICAL :: lua_toboolean - - lua_toboolean = (lua_toboolean_(l, idx) /= 0) -END FUNCTION lua_toboolean - -!---------------------------------------------------------------------------- -! lua_tonumber -!---------------------------------------------------------------------------- - -! lua_Number lua_tonumber(lua_State *l, int idx) -FUNCTION lua_tonumber(l, idx) - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - REAL(kind=lua_number) :: lua_tonumber - - lua_tonumber = lua_tonumberx(l, idx, C_NULL_PTR) -END FUNCTION lua_tonumber - -!---------------------------------------------------------------------------- -! lua_tostring -!---------------------------------------------------------------------------- - -! const char *lua_tostring(lua_State *L, int index) -FUNCTION lua_tostring(l, i) - !! Wrapper that calls `lua_tolstring()` and converts the returned C - !! pointer to Fortran string. Returns an unallocated character on error. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: i - CHARACTER(:), ALLOCATABLE :: lua_tostring - TYPE(C_PTR) :: ptr - - ptr = lua_tolstring(l, i, C_NULL_PTR) - IF (.NOT. C_ASSOCIATED(ptr)) RETURN - CALL c_f_str_ptr(ptr, lua_tostring) -END FUNCTION lua_tostring - -!---------------------------------------------------------------------------- -! lua_typename -!---------------------------------------------------------------------------- - -! const char *lua_typename(lua_State *L, int tp) -FUNCTION lua_typename(l, tp) - !! Wrapper that calls `lua_typename_()` and converts the returned C - !! pointer to Fortran string. Returns an unallocated character on error. - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: tp - CHARACTER(:), ALLOCATABLE :: lua_typename - TYPE(C_PTR) :: ptr - - ptr = lua_typename_(l, tp) - IF (.NOT. C_ASSOCIATED(ptr)) RETURN - CALL c_f_str_ptr(ptr, lua_typename) -END FUNCTION lua_typename - -!---------------------------------------------------------------------------- -! lual_dofile -!---------------------------------------------------------------------------- - -! int luaL_dofile(lua_State *L, const char *filename) -FUNCTION lual_dofile(l, fn) - !! Macro replacement that calls `lual_loadfile()` and `lua_pcall()`. - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: fn - INTEGER :: lual_dofile - - lual_dofile = lual_loadfile(l, fn) - IF (lual_dofile == 0) lual_dofile = lua_pcall(l, 0, LUA_MULTRET, 0) -END FUNCTION lual_dofile - -!---------------------------------------------------------------------------- -! lual_dostring -!---------------------------------------------------------------------------- - -! int luaL_dostring(lua_State *L, const char *str) -FUNCTION lual_dostring(l, str) - !! Macro replacement that calls `lual_loadstring()` and `lua_pcall()`. - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: str - INTEGER :: lual_dostring - - lual_dostring = lual_loadstring(l, str) - IF (lual_dostring == 0) lual_dostring = lua_pcall(l, 0, LUA_MULTRET, 0) -END FUNCTION lual_dostring - -!---------------------------------------------------------------------------- -! luaL_loadfile -!---------------------------------------------------------------------------- - -! int luaL_loadfile(lua_State *L, const char *filename) -FUNCTION lual_loadfile(l, fn) - !! Macro replacement that calls `lual_loadfilex()`. - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: fn - INTEGER :: lual_loadfile - - lual_loadfile = lual_loadfilex(l, fn//C_NULL_CHAR, C_NULL_PTR) -END FUNCTION lual_loadfile - -!---------------------------------------------------------------------------- -! luaL_loadstring -!---------------------------------------------------------------------------- - -! int luaL_loadstring(lua_State *L, const char *s) -FUNCTION lual_loadstring(l, s) - !! Wrapper for `lual_loadstring()` that null-terminates the given - !! string. - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: s - INTEGER :: lual_loadstring - - lual_loadstring = lual_loadstring_(l, s//C_NULL_CHAR) -END FUNCTION lual_loadstring - -!---------------------------------------------------------------------------- -! lua_pushlstring -!---------------------------------------------------------------------------- - -! const char *lua_pushlstring(lua_State *L, const char *s, size_t len) -FUNCTION lua_pushlstring(l, s, len) - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: s - INTEGER(kind=C_SIZE_T), INTENT(in) :: len - TYPE(C_PTR) :: lua_pushlstring - - lua_pushlstring = lua_pushlstring_(l, s//C_NULL_CHAR, len) -END FUNCTION lua_pushlstring - -!---------------------------------------------------------------------------- -! lua_pushstring -!---------------------------------------------------------------------------- - -! const char *lua_pushstring(lua_State *L, const char *s) -FUNCTION lua_pushstring(l, s) - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: s - TYPE(C_PTR) :: lua_pushstring - - lua_pushstring = lua_pushstring_(l, s//C_NULL_CHAR) -END FUNCTION lua_pushstring - -!---------------------------------------------------------------------------- -! lua_call -!---------------------------------------------------------------------------- - -! void lua_call(lua_State *L, int nargs, int nresults) -SUBROUTINE lua_call(l, nargs, nresults) - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: nargs - INTEGER, INTENT(in) :: nresults - - CALL lua_callk(l, nargs, nresults, INT(0, kind=C_SIZE_T), C_NULL_FUNPTR) -END SUBROUTINE lua_call - -!---------------------------------------------------------------------------- -! lua_newtable -!---------------------------------------------------------------------------- -! void lua_newtable(lua_State *L) -SUBROUTINE lua_newtable(l) - TYPE(C_PTR), INTENT(in) :: l - - CALL lua_createtable(l, 0, 0) -END SUBROUTINE lua_newtable - -!---------------------------------------------------------------------------- -! lua_pop -!---------------------------------------------------------------------------- - -! void lua_pop(lua_State *l, int n) -SUBROUTINE lua_pop(l, n) - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: n - - CALL lua_settop(l, -n - 1) -END SUBROUTINE lua_pop - -!---------------------------------------------------------------------------- -! lua_pushcfunction -!---------------------------------------------------------------------------- - -! void lua_pushcfunction(lua_State *L, lua_CFunction f) -SUBROUTINE lua_pushcfunction(l, f) - TYPE(C_PTR), INTENT(in) :: l - TYPE(C_FUNPTR), INTENT(in) :: f - - CALL lua_pushcclosure(l, f, 0) -END SUBROUTINE lua_pushcfunction - -!---------------------------------------------------------------------------- -! lua_register -!---------------------------------------------------------------------------- - -! void lua_register(lua_State *L, const char *name, lua_CFunction f) -SUBROUTINE lua_register(l, n, f) - !! Macro replacement. - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(*), INTENT(in) :: n - TYPE(C_FUNPTR), INTENT(in) :: f - - CALL lua_pushcfunction(l, f) - CALL lua_setglobal_(l, n//C_NULL_CHAR) -END SUBROUTINE lua_register - -!---------------------------------------------------------------------------- -! lua_setfield -!---------------------------------------------------------------------------- - -! void lua_setfield(lua_State *L, int idx, const char *k) -SUBROUTINE lua_setfield(l, idx, k) - TYPE(C_PTR), INTENT(in) :: l - INTEGER, INTENT(in) :: idx - CHARACTER(*), INTENT(in) :: k - - CALL lua_setfield_(l, idx, k//C_NULL_CHAR) -END SUBROUTINE lua_setfield - -!---------------------------------------------------------------------------- -! lua_setglobal -!---------------------------------------------------------------------------- - -! int lua_getglobal(lua_State *L, const char *name) -SUBROUTINE lua_setglobal(l, name) - TYPE(C_PTR), INTENT(in) :: l - CHARACTER(kind=C_CHAR), INTENT(in) :: name - - CALL lua_setglobal_(l, name//C_NULL_CHAR) -END SUBROUTINE lua_setglobal - -!---------------------------------------------------------------------------- -! c_f_str_ptr -!---------------------------------------------------------------------------- - -SUBROUTINE c_f_str_ptr(c_str, f_str) - !! Copies a C string, passed as a C pointer, to a Fortran string. - TYPE(C_PTR), INTENT(in) :: c_str - CHARACTER(:), ALLOCATABLE, INTENT(out) :: f_str - - CHARACTER(kind=C_CHAR), POINTER :: ptrs(:) - INTEGER(kind=C_SIZE_T) :: i, sz - - copy_block: BLOCK - IF (.NOT. C_ASSOCIATED(c_str)) EXIT copy_block - sz = c_strlen(c_str) - IF (sz < 0) EXIT copy_block - CALL C_F_POINTER(c_str, ptrs, [sz]) - ALLOCATE (CHARACTER(sz) :: f_str) - - DO i = 1, sz - f_str(i:i) = ptrs(i) - END DO - - RETURN - END BLOCK copy_block - - IF (.NOT. ALLOCATED(f_str)) f_str = '' -END SUBROUTINE c_f_str_ptr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -END MODULE LuaInterface diff --git a/src/modules/LuaInterface/src/No_LuaInterface.F90 b/src/modules/LuaInterface/src/No_LuaInterface.F90 deleted file mode 100644 index 0daa661db..000000000 --- a/src/modules/LuaInterface/src/No_LuaInterface.F90 +++ /dev/null @@ -1,21 +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 -! - -! This module is used when we are not using Lua - -MODULE LuaInterface -END MODULE LuaInterface diff --git a/src/modules/Macro/vectorclass.inc b/src/modules/Macro/vectorclass.inc deleted file mode 100644 index 667ad99a3..000000000 --- a/src/modules/Macro/vectorclass.inc +++ /dev/null @@ -1,46 +0,0 @@ -#define _AXB_( a, x, b ) _AXB1_( a, x, b ) -#define _AXB1_( a, x, b ) a ## x ## b -#define _AX_( a, x ) _AX1_( a, x ) -#define _AX1_( a, x ) a ## x - -TYPE, EXTENDS( AbstractVector_ ) :: _AX_( _KIND_, Vector_ ) - _TYPE_ ( _KIND_ ), ALLOCATABLE :: Val( : ) -END TYPE - -PUBLIC :: _AX_( _KIND_, Vector_ ) - -TYPE( _AX_( _KIND_, Vector_ ) ), PUBLIC, PARAMETER :: _AXB_( Type, _KIND_, Vector ) = & - & _AX_( _KIND_, Vector_ )( tDimension = 1_I4B, Val = NULL( ) ) - -TYPE :: _AX_( _KIND_, VectorPointer ) - CLASS( _AX_( _KIND_, Vector_ ) ), POINTER :: Ptr => NULL( ) -END TYPE - -PUBLIC :: _AX_( _KIND_, VectorPointer ) - - -#undef _TYPE_ -#undef _KIND_ -#undef _AXB_ -#undef _AXB1_ -#undef _AX_ -#undef _AX1_ - - -!<-- example --->| -! to use this macro define _TYPE_ INTEGER -! define _KIND_ Int8 -! -! TYPE, EXTENDS( AbstractVector_ ) :: Int8Vector_ -! INTEGER( Int8 ), ALLOCATABLE :: Val( : ) -! END TYPE Int8Vector_ - -! PUBLIC :: Int8Vector_ - -! TYPE(Int8Vector_), PUBLIC, PARAMETER :: TypeInt8Vector = Int8Vector_( & -! tDimension = 1_I4B, Val = NULL( ) ) - -! TYPE :: Int8VectorPointer -! CLASS( Int8Vector_ ), POINTER :: Ptr => NULL( ) -! END TYPE Int8VectorPointer -!<-- example --->| \ No newline at end of file diff --git a/src/modules/MassMatrix/CMakeLists.txt b/src/modules/MassMatrix/CMakeLists.txt deleted file mode 100644 index b4d7c4fd9..000000000 --- a/src/modules/MassMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/MassMatrix_Method.F90 -) diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 deleted file mode 100644 index c2b6ab317..000000000 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ /dev/null @@ -1,158 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE MassMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: MassMatrix -PUBLIC :: ViscousBoundaryMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> 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$$ -! - -INTERFACE MassMatrix - MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION MassMatrix_1 -END INTERFACE MassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE MassMatrix - MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) & - & 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 - TYPE(FEVariableScalar_), INTENT(IN) :: rhorank - !! Scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION MassMatrix_2 -END INTERFACE MassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE MassMatrix - MODULE PURE FUNCTION MassMatrix_3(test, trial, rho, rhorank, opt) & - & 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 - TYPE(FEVariableVector_), INTENT(IN) :: rhorank - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION MassMatrix_3 -END INTERFACE MassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE MassMatrix - MODULE PURE FUNCTION MassMatrix_4(test, trial, rho, rhorank) & - & 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 - TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank - !! Matrix - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION MassMatrix_4 -END INTERFACE MassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-01-15 -! summary: This subroutine makes mass matrix used for viscous boundary - -INTERFACE ViscousBoundaryMassMatrix - MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) & - & RESULT(ans) - 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION MassMatrix_5 -END INTERFACE ViscousBoundaryMassMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE MassMatrix_Method diff --git a/src/modules/MdEncode/CMakeLists.txt b/src/modules/MdEncode/CMakeLists.txt deleted file mode 100644 index 7ecdcfff8..000000000 --- a/src/modules/MdEncode/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/MdEncode_Method.F90 -) diff --git a/src/modules/MdEncode/src/MdEncode_Method.F90 b/src/modules/MdEncode/src/MdEncode_Method.F90 deleted file mode 100644 index 8fb9f57eb..000000000 --- a/src/modules/MdEncode/src/MdEncode_Method.F90 +++ /dev/null @@ -1,427 +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 MdEncode_Method -USE String_Class, ONLY: String -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: MdEncode -PUBLIC :: React_StartTabs -PUBLIC :: React_StartTabItem -PUBLIC :: React_EndTabs -PUBLIC :: React_EndTabItem - -CHARACTER(3), PARAMETER :: avert = " | " -CHARACTER(2), PARAMETER :: ivert = "| " -CHARACTER(2), PARAMETER :: evert = " |" -CHARACTER(1), PARAMETER :: abr = CHAR_LF -CHARACTER(1), PARAMETER :: ablank = CHAR_BLANK -CHARACTER(5), PARAMETER :: adash = " --- " - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -INTERFACE MdEncode - MODULE FUNCTION MdEncode_Int8(val) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_Int8 - - MODULE FUNCTION MdEncode_Int16(val) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_Int16 - - MODULE FUNCTION MdEncode_Int32(val) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_Int32 - - MODULE FUNCTION MdEncode_Int64(val) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_Int64 - - MODULE FUNCTION MdEncode_Real32(val) RESULT(ans) - REAL(REAL32), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_Real32 - - MODULE FUNCTION MdEncode_Real64(val) RESULT(ans) - REAL(REAL64), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_Real64 - - MODULE FUNCTION MdEncode_Char(val) RESULT(ans) - CHARACTER(*), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_Char - - MODULE FUNCTION MdEncode_String(val) RESULT(ans) - TYPE(String), INTENT(IN) :: val - TYPE(String) :: ans - END FUNCTION MdEncode_String -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -INTERFACE MdEncode - MODULE FUNCTION MdEncode2_Int8(val) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - TYPE(String) :: ans - END FUNCTION MdEncode2_Int8 - - MODULE FUNCTION MdEncode2_Int16(val) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - TYPE(String) :: ans - END FUNCTION MdEncode2_Int16 - - MODULE FUNCTION MdEncode2_Int32(val) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - TYPE(String) :: ans - END FUNCTION MdEncode2_Int32 - - MODULE FUNCTION MdEncode2_Int64(val) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - TYPE(String) :: ans - END FUNCTION MdEncode2_Int64 - - MODULE FUNCTION MdEncode2_Real32(val) RESULT(ans) - REAL(REAL32), INTENT(IN) :: val(:) - TYPE(String) :: ans - END FUNCTION MdEncode2_Real32 - - MODULE FUNCTION MdEncode2_Real64(val) RESULT(ans) - REAL(REAL64), INTENT(IN) :: val(:) - TYPE(String) :: ans - END FUNCTION MdEncode2_Real64 - - MODULE FUNCTION MdEncode2_String(val) RESULT(ans) - TYPE(String), INTENT(IN) :: val(:) - TYPE(String) :: ans - END FUNCTION MdEncode2_String -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -INTERFACE MdEncode - MODULE FUNCTION MdEncode3_Int8(val) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:, :) - TYPE(String) :: ans - END FUNCTION MdEncode3_Int8 - - MODULE FUNCTION MdEncode3_Int16(val) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:, :) - TYPE(String) :: ans - END FUNCTION MdEncode3_Int16 - - MODULE FUNCTION MdEncode3_Int32(val) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:, :) - TYPE(String) :: ans - END FUNCTION MdEncode3_Int32 - - MODULE FUNCTION MdEncode3_Int64(val) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:, :) - TYPE(String) :: ans - END FUNCTION MdEncode3_Int64 - - MODULE FUNCTION MdEncode3_Real32(val) RESULT(ans) - REAL(REAL32), INTENT(IN) :: val(:, :) - TYPE(String) :: ans - END FUNCTION MdEncode3_Real32 - - MODULE FUNCTION MdEncode3_Real64(val) RESULT(ans) - REAL(REAL64), INTENT(IN) :: val(:, :) - TYPE(String) :: ans - END FUNCTION MdEncode3_Real64 - - MODULE FUNCTION MdEncode3_String(val) RESULT(ans) - TYPE(String), INTENT(IN) :: val(:, :) - TYPE(String) :: ans - END FUNCTION MdEncode3_String -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -INTERFACE MdEncode - MODULE FUNCTION MdEncode4_Int8(val) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode4_Int8 - - MODULE FUNCTION MdEncode4_Int16(val) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode4_Int16 - - MODULE FUNCTION MdEncode4_Int32(val) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode4_Int32 - - MODULE FUNCTION MdEncode4_Int64(val) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode4_Int64 - - MODULE FUNCTION MdEncode4_Real32(val) RESULT(ans) - REAL(REAL32), INTENT(IN) :: val(:, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode4_Real32 - - MODULE FUNCTION MdEncode4_Real64(val) RESULT(ans) - REAL(REAL64), INTENT(IN) :: val(:, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode4_Real64 - - MODULE FUNCTION MdEncode4_String(val) RESULT(ans) - TYPE(String), INTENT(IN) :: val(:, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode4_String -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -INTERFACE MdEncode - MODULE FUNCTION MdEncode5_Int8(val) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:, :, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode5_Int8 - - MODULE FUNCTION MdEncode5_Int16(val) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:, :, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode5_Int16 - - MODULE FUNCTION MdEncode5_Int32(val) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:, :, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode5_Int32 - - MODULE FUNCTION MdEncode5_Int64(val) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:, :, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode5_Int64 - - MODULE FUNCTION MdEncode5_Real32(val) RESULT(ans) - REAL(REAL32), INTENT(IN) :: val(:, :, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode5_Real32 - - MODULE FUNCTION MdEncode5_Real64(val) RESULT(ans) - REAL(REAL64), INTENT(IN) :: val(:, :, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode5_Real64 - - MODULE FUNCTION MdEncode5_String(val) RESULT(ans) - TYPE(String), INTENT(IN) :: val(:, :, :, :) - TYPE(String) :: ans - END FUNCTION MdEncode5_String -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -INTERFACE MdEncode - MODULE FUNCTION MdEncode6_Int8(val, rh, ch) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode6_Int8 - - MODULE FUNCTION MdEncode6_Int16(val, rh, ch) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode6_Int16 - - MODULE FUNCTION MdEncode6_Int32(val, rh, ch) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode6_Int32 - - MODULE FUNCTION MdEncode6_Int64(val, rh, ch) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode6_Int64 - - MODULE FUNCTION MdEncode6_Real32(val, rh, ch) RESULT(ans) - REAL(REAL32), INTENT(IN) :: val(:) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode6_Real32 - - MODULE FUNCTION MdEncode6_Real64(val, rh, ch) RESULT(ans) - REAL(REAL64), INTENT(IN) :: val(:) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode6_Real64 - - MODULE FUNCTION MdEncode6_String(val, rh, ch) RESULT(ans) - TYPE(String), INTENT(IN) :: val(:) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode6_String -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -INTERFACE MdEncode - MODULE FUNCTION MdEncode7_Int8(val, rh, ch) RESULT(ans) - INTEGER(Int8), INTENT(IN) :: val(:, :) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode7_Int8 - - MODULE FUNCTION MdEncode7_Int16(val, rh, ch) RESULT(ans) - INTEGER(Int16), INTENT(IN) :: val(:, :) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode7_Int16 - - MODULE FUNCTION MdEncode7_Int32(val, rh, ch) RESULT(ans) - INTEGER(Int32), INTENT(IN) :: val(:, :) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode7_Int32 - - MODULE FUNCTION MdEncode7_Int64(val, rh, ch) RESULT(ans) - INTEGER(Int64), INTENT(IN) :: val(:, :) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode7_Int64 - - MODULE FUNCTION MdEncode7_Real32(val, rh, ch) RESULT(ans) - REAL(Real32) , INTENT(IN) :: val(:, :) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode7_Real32 - - MODULE FUNCTION MdEncode7_Real64(val, rh, ch) RESULT(ans) - REAL(Real64) , INTENT(IN) :: val(:, :) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode7_Real64 - - MODULE FUNCTION MdEncode7_String(val, rh, ch) RESULT(ans) - TYPE(String) , INTENT(IN) :: val(:, :) - TYPE(String), INTENT(IN) :: rh(:) - !! Row header - TYPE(String), INTENT(IN) :: ch(:) - !! Col header - TYPE(String) :: ans - END FUNCTION MdEncode7_String - -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! StartTabs -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION React_StartTabs() RESULT(ans) - TYPE(String) :: ans - END FUNCTION React_StartTabs -END INTERFACE - -!---------------------------------------------------------------------------- -! EndTabs -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION React_EndTabs() RESULT(ans) - TYPE(String) :: ans - END FUNCTION React_EndTabs -END INTERFACE - -!---------------------------------------------------------------------------- -! StartTabItem -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION React_StartTabItem(VALUE, label) RESULT(ans) - CHARACTER(*), INTENT(IN) :: VALUE - CHARACTER(*), INTENT(IN) :: label - TYPE(String) :: ans - END FUNCTION React_StartTabItem -END INTERFACE - -!---------------------------------------------------------------------------- -! EndTabItem -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION React_EndTabItem() RESULT(ans) - TYPE(String) :: ans - END FUNCTION React_EndTabItem -END INTERFACE - -END MODULE MdEncode_Method diff --git a/src/modules/MetisInterface/CMakeLists.txt b/src/modules/MetisInterface/CMakeLists.txt deleted file mode 100644 index d5783acce..000000000 --- a/src/modules/MetisInterface/CMakeLists.txt +++ /dev/null @@ -1,25 +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 -# - - -IF(USE_METIS) - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/MetisInterface.F90 - ) -ENDIF() diff --git a/src/modules/MetisInterface/src/MetisInterface.F90 b/src/modules/MetisInterface/src/MetisInterface.F90 deleted file mode 100644 index a30096b06..000000000 --- a/src/modules/MetisInterface/src/MetisInterface.F90 +++ /dev/null @@ -1,650 +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 MetisInterface -USE GlobalData -USE ISO_C_BINDING -USE CInterface -USE ErrorHandling -IMPLICIT NONE -PRIVATE -PUBLIC :: MetisSetDefaultOptions -PUBLIC :: MetisNodeND -PUBLIC :: METISPartGraphRecursive -PUBLIC :: METISPartGraphKway -PUBLIC :: METISPartMeshDual -PUBLIC :: METISPartMeshNodal -PUBLIC :: METISMeshToDual -PUBLIC :: METISMeshToNodal -#include "./MetisInterface.inc" -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE MetisSetDefaultOptions(Options) - INTEGER(I4B), INTENT(OUT) :: Options(:) - INTEGER(I4B) :: IERR - IERR = METIS_SetDefaultOptions(Options) - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error while setting default options", & - & File="MetisInterface.F90", & - & Routine="MetisSetDefaultOptions()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF -END SUBROUTINE MetisSetDefaultOptions - -!---------------------------------------------------------------------------- -! MetisNodeND -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Jul 2021 -! summary: This function computes fill reducing orderings of sparse matrices using the multilevel nested dissection algorithm. -! -!# Introduction -! -! This function computes fill reducing orderings of sparse matrices using the multilevel nested dissection algorithm. -! -! - Let $A$ be the original matrix and $A*$ be the permuted matrix. -! - The arrays `perm` and `iperm` are defined as follows. -! - Row (column) `i` of $A*$ is the `perm(i)` row (column) of $A$ -! - Row (column) `i` of $A$ is the `iperm(i)` row (column) of $A*$. -! - The numbering of this vector starts from either 0 or 1, depending on the value of `options(METIS_OPTION_NUMBERING)`. -! -! If the graph is weighted, meaning `vgwt` was provided, the nested dissection ordering computes vertex separators that minimize the sum of the weights of the vertices on the separators. -! -! GRAPH DATA STRUCTURE -! -! The adjacency structure of the graph is stored using the compressed storage format (CSR). The CSR format is a widely used scheme for storing sparse graphs. In this format the adjacency structure of a graph with n vertices and m edges is represented using two arrays xadj and adjncy. The xadj array is of size n + 1 whereas the adjncy array is of size 2m (this is because for each edge between vertices v and u we actually store both (v; u) and (u; v)) -! -! The adjacency structure of the graph is stored as follows. Assuming that vertex numbering starts from 0 (C style), then the adjacency list of vertex i is stored in array adjncy starting at index xadj[i] and ending at (but not including) index xadj[i + 1] (i.e., adjncy[xadj[i]] through and including adjncy[xadj[i + 1]-1]). That is, for each vertex i, its adjacency list is stored in consecutive locations in the array adjncy, and the array xadj is used to point to where it begins and where it ends. Figure 3(b) illustrates the CSR format for the 15-vertex graph shown in Figure 3(a) -! -! The weights of the vertices (if any) are stored in an additional array called vwgt. If ncon is the number of weights associated with each vertex, the array vwgt contains n ∗ ncon elements (recall that n is the number of vertices). The weights of the ith vertex are stored in ncon consecutive entries starting at location vwgt[i ∗ ncon]. Note that if each vertex has only a single weight, then vwgt will contain n elements, and vwgt[i] will store the weight of the ith vertex. The vertex-weights must be integers greater or equal to zero. If all the vertices of the graph have the same weight (i.e., the graph is unweighted), then the vwgt can be set to NULL. -! -! -!### Usage -! -!```fortran -! INTEGER( I4B ), PARAMETER :: n = 15 -! !! number of vertices -! INTEGER( I4B ), PARAMETER :: m = 22 -! !! number of edges -! INTEGER( I4B ) :: XADJ(n+1), ADJNCY(2*m) -! !! graph adjacency structure -! !! XADJ, ADJNCY -! INTEGER( I4B ) :: PERM(n), IPERM(n) -! !! fill-reducing permutation andinverse permutatio -! CALL Display( "TESTING METISNodeND" ) -! XADJ = [1,3,6,9,12,14,17,21,25,29,32,34,37,40,43,45] -! ADJNCY = [2,6,1,3,7,2,4,8,3,5,9,4,10,1,7,11,2,6, & -! & 8,12,3,7,9,13,4,8,10,14,5,9,15,6,12,7,11,13, & -! & 8,12,14,9,13,15,10,14] -! CALL METISNodeND(XADJ=XADJ, ADJNCY=ADJNCY, PERM=PERM, IPERM=IPERM ) -! CALL DISP( x=PERM, title= " PERM = " ) -! CALL DISP( x=IPERM, title= " IPERM = " ) -!``` - -SUBROUTINE MetisNodeND(XADJ, ADJNCY, PERM, IPERM, OPTIONS, VWGT) - INTEGER(I4B), INTENT(IN) :: XADJ(:) - INTEGER(I4B), INTENT(IN) :: ADJNCY(:) - INTEGER(I4B), INTENT(OUT) :: PERM(:) - INTEGER(I4B), INTENT(OUT) :: IPERM(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) - ! Internal variables - INTEGER(I4B) :: NVTXS, IERR - INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) - TYPE(C_PTR) :: C_OPTIONS, C_VWGT - ! - NVTXS = SIZE(PERM) - IF (PRESENT(OPTIONS)) THEN - C_OPTIONS = C_LOC(OPTIONS) - ELSE - IERR = METIS_SetDefaultOptions(OPT) - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error while setting default options", & - & File="MetisInterface.F90", & - & Routine="MetisNodeND()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT - C_OPTIONS = C_LOC(OPT) - END IF - - IF (PRESENT(VWGT)) THEN - C_VWGT = C_LOC(VWGT) - ELSE - C_VWGT = C_NULL_PTR - END IF - - IERR = METIS_NodeND(nvtxs=NVTXS, xadj=XADJ, adjncy=ADJNCY,& - & perm=PERM, iperm=IPERM, options=C_OPTIONS, vwgt=C_VWGT) - IF (ierr .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error in METIS_NodeND()", & - & File="MetisInterface.F90", & - & Routine="MetisNodeND()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - C_OPTIONS = C_NULL_PTR - C_VWGT = C_NULL_PTR -END SUBROUTINE MetisNodeND - -!---------------------------------------------------------------------------- -! METISPartGraphRecursive -!---------------------------------------------------------------------------- - -SUBROUTINE METISPartGraphRecursive(NCON, NPARTS, OBJVAL, PART, XADJ, & - & ADJNCY, OPTIONS, VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC) - INTEGER(I4B), INTENT(IN) :: NCON - INTEGER(I4B), INTENT(IN) :: NPARTS - INTEGER(I4B), INTENT(OUT) :: OBJVAL - INTEGER(I4B), INTENT(OUT) :: PART(:) - INTEGER(I4B), INTENT(IN) :: XADJ(:) - INTEGER(I4B), INTENT(IN) :: ADJNCY(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: ADJWGT(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: UBVEC(:) - ! Internal variables - INTEGER(I4B) :: NVTXS, IERR - INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) - TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_ADJWGT, C_TPWGTS, C_UBVEC - ! - NVTXS = SIZE(PART) - - IF (PRESENT(OPTIONS)) THEN - C_OPTIONS = C_LOC(OPTIONS) - ELSE - IERR = METIS_SetDefaultOptions(OPT) - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error while setting default options", & - & File="MetisInterface.F90", & - & Routine="METISPartGraphRecursive()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT - C_OPTIONS = C_LOC(OPT) - END IF - - IF (PRESENT(VWGT)) THEN - C_VWGT = C_LOC(VWGT) - ELSE - C_VWGT = C_NULL_PTR - END IF - - IF (PRESENT(VSIZE)) THEN - C_VSIZE = C_LOC(VSIZE) - ELSE - C_VSIZE = C_NULL_PTR - END IF - - IF (PRESENT(ADJWGT)) THEN - C_ADJWGT = C_LOC(ADJWGT) - ELSE - C_ADJWGT = C_NULL_PTR - END IF - - IF (PRESENT(TPWGTS)) THEN - C_TPWGTS = C_LOC(TPWGTS) - ELSE - C_TPWGTS = C_NULL_PTR - END IF - - IF (PRESENT(UBVEC)) THEN - C_UBVEC = C_LOC(UBVEC) - ELSE - C_UBVEC = C_NULL_PTR - END IF - - IERR = METIS_PartGraphRecursive(NCON=NCON, NVTXS=NVTXS, XADJ=XADJ,& - & ADJNCY=ADJNCY, NPARTS=NPARTS, OBJVAL=OBJVAL, PART=PART, & - & VWGT=C_VWGT, VSIZE=C_VSIZE, ADJWGT=C_ADJWGT, & - & TPWGTS=C_TPWGTS, UBVEC=C_UBVEC, OPTIONS=C_OPTIONS) - - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error in METIS_PartGraphRecursive()", & - & File="MetisInterface.F90", & - & Routine="METISPartGraphRecursive()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - C_VWGT = C_NULL_PTR - C_VSIZE = C_NULL_PTR - C_ADJWGT = C_NULL_PTR - C_TPWGTS = C_NULL_PTR - C_UBVEC = C_NULL_PTR - C_OPTIONS = C_NULL_PTR -END SUBROUTINE METISPartGraphRecursive - -!---------------------------------------------------------------------------- -! METISPartGraphKway -!---------------------------------------------------------------------------- - -SUBROUTINE METISPartGraphKway(NCON, NPARTS, OBJVAL, PART, XADJ, & - & ADJNCY, OPTIONS, VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC) - INTEGER(I4B), INTENT(IN) :: NCON - INTEGER(I4B), INTENT(IN) :: NPARTS - INTEGER(I4B), INTENT(OUT) :: OBJVAL - INTEGER(I4B), INTENT(OUT) :: PART(:) - INTEGER(I4B), INTENT(IN) :: XADJ(:) - INTEGER(I4B), INTENT(IN) :: ADJNCY(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: ADJWGT(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: UBVEC(:) - ! Internal variables - INTEGER(I4B) :: NVTXS, IERR - INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) - TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_ADJWGT, C_TPWGTS, C_UBVEC - ! - NVTXS = SIZE(PART) - - IF (PRESENT(OPTIONS)) THEN - C_OPTIONS = C_LOC(OPTIONS) - ELSE - IERR = METIS_SetDefaultOptions(OPT) - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error while setting default options", & - & File="MetisInterface.F90", & - & Routine="METISPartGraphKway()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT - C_OPTIONS = C_LOC(OPT) - END IF - - IF (PRESENT(VWGT)) THEN - C_VWGT = C_LOC(VWGT) - ELSE - C_VWGT = C_NULL_PTR - END IF - - IF (PRESENT(VSIZE)) THEN - C_VSIZE = C_LOC(VSIZE) - ELSE - C_VSIZE = C_NULL_PTR - END IF - - IF (PRESENT(ADJWGT)) THEN - C_ADJWGT = C_LOC(ADJWGT) - ELSE - C_ADJWGT = C_NULL_PTR - END IF - - IF (PRESENT(TPWGTS)) THEN - C_TPWGTS = C_LOC(TPWGTS) - ELSE - C_TPWGTS = C_NULL_PTR - END IF - - IF (PRESENT(UBVEC)) THEN - C_UBVEC = C_LOC(UBVEC) - ELSE - C_UBVEC = C_NULL_PTR - END IF - - IERR = METIS_PartGraphKway(NCON=NCON, NVTXS=NVTXS, XADJ=XADJ,& - & ADJNCY=ADJNCY, NPARTS=NPARTS, OBJVAL=OBJVAL, PART=PART, & - & VWGT=C_VWGT, VSIZE=C_VSIZE, ADJWGT=C_ADJWGT, & - & TPWGTS=C_TPWGTS, UBVEC=C_UBVEC, OPTIONS=C_OPTIONS) - - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error in METIS_PartGraphKway()", & - & File="MetisInterface.F90", & - & Routine="METISPartGraphKway()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - C_VWGT = C_NULL_PTR - C_VSIZE = C_NULL_PTR - C_ADJWGT = C_NULL_PTR - C_TPWGTS = C_NULL_PTR - C_UBVEC = C_NULL_PTR - C_OPTIONS = C_NULL_PTR -END SUBROUTINE METISPartGraphKway - -!---------------------------------------------------------------------------- -! METISPartMeshDual -!---------------------------------------------------------------------------- - -SUBROUTINE METISPartMeshDual(NCOMMON, NPARTS, OBJVAL, EPART, NPART, & - & EPTR, EIND, OPTIONS, VWGT, VSIZE, TPWGTS) - INTEGER(I4B), INTENT(IN) :: NCOMMON - INTEGER(I4B), INTENT(IN) :: NPARTS - INTEGER(I4B), INTENT(OUT) :: OBJVAL - INTEGER(I4B), INTENT(OUT) :: EPART(:) - INTEGER(I4B), INTENT(OUT) :: NPART(:) - INTEGER(I4B), INTENT(IN) :: EPTR(:) - INTEGER(I4B), INTENT(IN) :: EIND(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) - ! Internal variables - INTEGER(I4B) :: NE, NN, IERR - INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) - TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_TPWGTS - ! - NE = SIZE(EPART) - NN = SIZE(NPART) - - IF (PRESENT(OPTIONS)) THEN - C_OPTIONS = C_LOC(OPTIONS) - ELSE - IERR = METIS_SetDefaultOptions(OPT) - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error while setting default options", & - & File="MetisInterface.F90", & - & Routine="METISPartMeshDual()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT - C_OPTIONS = C_LOC(OPT) - END IF - - IF (PRESENT(VWGT)) THEN - C_VWGT = C_LOC(VWGT) - ELSE - C_VWGT = C_NULL_PTR - END IF - - IF (PRESENT(VSIZE)) THEN - C_VSIZE = C_LOC(VSIZE) - ELSE - C_VSIZE = C_NULL_PTR - END IF - - IF (PRESENT(TPWGTS)) THEN - C_TPWGTS = C_LOC(TPWGTS) - ELSE - C_TPWGTS = C_NULL_PTR - END IF - - IERR = METIS_PartMeshDual(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & - & VWGT=C_VWGT, VSIZE=C_VSIZE, NCOMMON=NCOMMON, NPARTS=NPARTS, & - & TPWGTS=C_TPWGTS, OPTIONS=C_OPTIONS, OBJVAL=OBJVAL, EPART=EPART, & - & NPART=NPART) - - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error in METIS_PartMeshDual()", & - & File="MetisInterface.F90", & - & Routine="METISPartMeshDual()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - C_VWGT = C_NULL_PTR - C_VSIZE = C_NULL_PTR - C_TPWGTS = C_NULL_PTR - C_OPTIONS = C_NULL_PTR -END SUBROUTINE METISPartMeshDual - -!---------------------------------------------------------------------------- -! METISPartMeshNodal -!---------------------------------------------------------------------------- - -SUBROUTINE METISPartMeshNodal(NPARTS, OBJVAL, EPART, NPART, & - & EPTR, EIND, OPTIONS, VWGT, VSIZE, TPWGTS) - INTEGER(I4B), INTENT(IN) :: NPARTS - INTEGER(I4B), INTENT(OUT) :: OBJVAL - INTEGER(I4B), INTENT(OUT) :: EPART(:) - INTEGER(I4B), INTENT(OUT) :: NPART(:) - INTEGER(I4B), INTENT(IN) :: EPTR(:) - INTEGER(I4B), INTENT(IN) :: EIND(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) - ! Internal variables - INTEGER(I4B) :: NE, NN, IERR - INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) - TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_TPWGTS - ! - NE = SIZE(EPART) - NN = SIZE(NPART) - - IF (PRESENT(OPTIONS)) THEN - C_OPTIONS = C_LOC(OPTIONS) - ELSE - IERR = METIS_SetDefaultOptions(OPT) - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error while setting default options", & - & File="MetisInterface.F90", & - & Routine="METISPartMeshNodal()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT - C_OPTIONS = C_LOC(OPT) - END IF - - IF (PRESENT(VWGT)) THEN - C_VWGT = C_LOC(VWGT) - ELSE - C_VWGT = C_NULL_PTR - END IF - - IF (PRESENT(VSIZE)) THEN - C_VSIZE = C_LOC(VSIZE) - ELSE - C_VSIZE = C_NULL_PTR - END IF - - IF (PRESENT(TPWGTS)) THEN - C_TPWGTS = C_LOC(TPWGTS) - ELSE - C_TPWGTS = C_NULL_PTR - END IF - - IERR = METIS_PartMeshNodal(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & - & VWGT=C_VWGT, VSIZE=C_VSIZE, NPARTS=NPARTS, & - & TPWGTS=C_TPWGTS, OPTIONS=C_OPTIONS, OBJVAL=OBJVAL, EPART=EPART, & - & NPART=NPART) - - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error in METIS_PartMeshNodal()", & - & File="MetisInterface.F90", & - & Routine="METISPartMeshNodal()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - C_VWGT = C_NULL_PTR - C_VSIZE = C_NULL_PTR - C_TPWGTS = C_NULL_PTR - C_OPTIONS = C_NULL_PTR -END SUBROUTINE METISPartMeshNodal - -!---------------------------------------------------------------------------- -! METISMeshToDual -!---------------------------------------------------------------------------- - -SUBROUTINE METISMeshToDual(NE, NN, NCOMMON, EPTR, EIND, XADJ, ADJNCY, & - & NUMFLAG) - INTEGER(I4B), INTENT(IN) :: NE - INTEGER(I4B), INTENT(IN) :: NN - INTEGER(I4B), INTENT(IN) :: NCOMMON - INTEGER(I4B), INTENT(IN) :: EPTR(:) - INTEGER(I4B), INTENT(IN) :: EIND(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: XADJ(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: ADJNCY(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NUMFLAG - ! - INTEGER(I4B) :: NUM_FLAG, IERR - TYPE(C_PTR) :: C_XADJ, C_ADJNCY - INTEGER(I4B), POINTER :: F_XADJ(:), F_ADJNCY(:) - - IF (PRESENT(NUMFLAG)) THEN - NUM_FLAG = NUMFLAG - ELSE - NUM_FLAG = METIS_NUMBERING_FORTRAN - END IF - - IERR = METIS_MeshToDual(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & - & NCOMMON=NCOMMON, NUMFLAG=NUM_FLAG, XADJ=C_XADJ, ADJNCY=C_ADJNCY) - - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error in METIS_MeshToDual()", & - & File="MetisInterface.F90", & - & Routine="METISMeshToDual()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - IF (C_ASSOCIATED(C_XADJ)) THEN - CALL C_F_POINTER(CPTR=C_XADJ, FPTR=F_XADJ, shape=[NN + 1]) - XADJ = F_XADJ(1:NN + 1) - ELSE - CALL ErrorMSG( & - & Msg="XADJ IS NOT ASSOCIATED", & - & File="MetisInterface.F90", & - & Routine="METISMeshToDual()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - IF (C_ASSOCIATED(C_ADJNCY)) THEN - CALL C_F_POINTER(CPTR=C_ADJNCY, FPTR=F_ADJNCY, shape=[F_XADJ(nn + 1) - 1]) - ADJNCY = F_ADJNCY(1:F_XADJ(nn + 1) - 1) - ELSE - CALL ErrorMSG( & - & Msg="ADJNCY IS NOT ASSOCIATED", & - & File="MetisInterface.F90", & - & Routine="METISMeshToDual()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - ierr = METIS_FREE(C_ADJNCY) - ierr = METIS_FREE(C_XADJ) - NULLIFY (F_ADJNCY, F_XADJ) - -END SUBROUTINE METISMeshToDual - -!---------------------------------------------------------------------------- -! METISMeshToDual -!---------------------------------------------------------------------------- - -SUBROUTINE METISMeshToNodal(NE, NN, EPTR, EIND, XADJ, ADJNCY, & - & NUMFLAG) - INTEGER(I4B), INTENT(IN) :: NE - INTEGER(I4B), INTENT(IN) :: NN - INTEGER(I4B), INTENT(IN) :: EPTR(:) - INTEGER(I4B), INTENT(IN) :: EIND(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: XADJ(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: ADJNCY(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: NUMFLAG - ! - INTEGER(I4B) :: NUM_FLAG, IERR - TYPE(C_PTR) :: C_XADJ, C_ADJNCY - INTEGER(I4B), POINTER :: F_XADJ(:), F_ADJNCY(:) - - IF (PRESENT(NUMFLAG)) THEN - NUM_FLAG = NUMFLAG - ELSE - NUM_FLAG = METIS_NUMBERING_FORTRAN - END IF - - IERR = METIS_MeshToNodal(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & - & NUMFLAG=NUM_FLAG, XADJ=C_XADJ, ADJNCY=C_ADJNCY) - - IF (IERR .NE. METIS_OK) THEN - CALL ErrorMSG( & - & Msg="Error in METIS_MeshToNodal()", & - & File="MetisInterface.F90", & - & Routine="METISMeshToNodal()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - IF (C_ASSOCIATED(C_XADJ)) THEN - CALL C_F_POINTER(CPTR=C_XADJ, FPTR=F_XADJ, shape=[NN + 1]) - XADJ = F_XADJ(1:NN + 1) - ELSE - CALL ErrorMSG( & - & Msg="XADJ IS NOT ASSOCIATED", & - & File="MetisInterface.F90", & - & Routine="METISMeshToNodal()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - IF (C_ASSOCIATED(C_ADJNCY)) THEN - CALL C_F_POINTER(CPTR=C_ADJNCY, FPTR=F_ADJNCY, shape=[F_XADJ(nn + 1) - 1]) - ADJNCY = F_ADJNCY(1:F_XADJ(nn + 1) - 1) - ELSE - CALL ErrorMSG( & - & Msg="ADJNCY IS NOT ASSOCIATED", & - & File="MetisInterface.F90", & - & Routine="METISMeshToNodal()", & - & Line=__LINE__, & - & UnitNo=stdout) - STOP - END IF - - ierr = METIS_FREE(C_ADJNCY) - ierr = METIS_FREE(C_XADJ) - NULLIFY (F_ADJNCY, F_XADJ) -END SUBROUTINE METISMeshToNodal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE MetisInterface diff --git a/src/modules/MetisInterface/src/MetisInterface.inc b/src/modules/MetisInterface/src/MetisInterface.inc deleted file mode 100644 index c980aabe2..000000000 --- a/src/modules/MetisInterface/src/MetisInterface.inc +++ /dev/null @@ -1,881 +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 _I_OUT_ INTEGER( C_INT ), INTENT( OUT ) -#define _I_IN_ INTEGER( C_INT ), INTENT( IN ) -#define _I_V_IN_ INTEGER( C_INT ), VALUE, INTENT( IN ) -#define _ST_V_IN_ INTEGER( C_SIZE_T ), VALUE, INTENT( IN ) -#define _ST_OUT_ INTEGER( C_SIZE_T ), INTENT( OUT ) -#define _ST_IN_ INTEGER( C_SIZE_T ), INTENT( IN ) -#define _R_V_IN_ REAL( C_DOUBLE ), VALUE, INTENT( IN ) -#define _R_IN_ REAL( C_DOUBLE ), INTENT( IN ) -#define _R_OUT_ REAL( C_DOUBLE ), INTENT( OUT ) -#define _CPTR_V_IN_ TYPE(C_PTR), VALUE, INTENT( IN ) -#define _CPTR_IN_ TYPE(C_PTR), INTENT( IN ) - - -INTEGER( I4B ), PARAMETER, PUBLIC :: MAX_METIS_OPTIONS = 40 - !! Maximum number of METSI OPTIONS - -! Return codes -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OK = 1 - !! Flag to indicate that there is no error -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_ERROR_INPUT = -2 - !! Flag to indicate that there is erro during input output -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_ERROR_MEMORY = -3 - !! Flag to indicate error due to the insufficient memory. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_ERROR = -4 - !! Flag to indicate undocumented error - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_PTYPE = 0 - !! It specifies the type of partitioning method; The possible values are - !! given below. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PTYPE_RB = 0 - !! Multilevel recursive bisectioning. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PTYPE_KWAY = 1 - !! Multilevel k-way partitioning. DEFAULT -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PTYPE_DEFAULT = METIS_PTYPE_KWAY - !! Default value of METIS_OPTION_PTYPE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_OBJTYPE = 1 - !! Specifies the objective type, two values are possible: Edge-cut, which - !! minimizes the communication time, and Total communication volume -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_CUT = 0 - !! Edge-cut minimization. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_VOL = 1 - !! Total communication volume minimization. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_NODE = 2 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_DEFAULT = METIS_OBJTYPE_CUT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_CTYPE = 2 - !! Specifies the matching scheme to be used during coarsening. Possible - !! values are as follows: -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CTYPE_RM = 0 - !! Random matching. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CTYPE_SHEM = 1 - !! Sorted heavy-edge matching. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CTYPE_DEFAULT=METIS_CTYPE_RM - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_IPTYPE = 3 - !! Specify the algorithm used during the initial partitioning of the mesh -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_GROW = 0 - !! grows bisection using a greedy strategy. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_RANDOM = 1 - !! computes bisection at random followed by a refinement. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_EDGE = 2 - !! derives separator form an edge cut. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_NODE = 3 - !! grows bisection using a greedy node-based strategy. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_METISRB = 4 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_DEFAULT=METIS_IPTYPE_GROW - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_RTYPE = 4 - !! Specify the algorithm used for refinement. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_FM = 0 - !! FM-basecut refinement. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_GREEDY = 1 - !!Greedy-based cut and volume refinement. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_SEP2SIDED = 2 - !! Two-sidenode FM refinement. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_SEP1SIDED = 3 - !! One-sidenode FM refinement. - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_DBGLVL = 5 - !! Specifies the amount of progress/debugging information will be printed during the execution of the algorithms. The default value is 0 (no debugging/progress information). A non-zero value can be supplied that is obtained by a bit-wise OR of the following values -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_INFO = 1 - !! Shows various diagnostic messages. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_TIME = 2 - !! Perform timing analysis. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_COARSEN = 4 - !! Shothe coarsening progress. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_REFINE = 8 - !! Shothe refinement progress. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_IPART = 16 - !! Shoinfo on initial partitioning. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_MOVEINFO = 32 - !! Shoinfo on vertex moves during refinement. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_SEPINFO = 64 - !! Shoinfo on vertex moves during sep refinement. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_CONNINFO = 128 - !! Shoinfo on minimization of subdomain connectivity. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_CONTIGINFO = 256 - !! Shoinfo on elimination of connected components. -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_MEMORY = 2048 - !! Shoinfo related to wspace allocation. - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NITER = 6 - !! Specifies the number of iterations for the refinement algorithm. - !! Default value is 10 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NITER_DEFAULT = 10 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NCUTS = 7 - !! Specifies the number of different partitionings that it will compute. The final partitioning is the one that achieves the best edgecut or communication volume. Default is 1 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NCUTS_DEFAULT=1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_SEED = 8 - !! Specifies the seed for the random number generator. - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NO2HOP = 9 - !! Specifies that the coarsening will not perform any 2–hop matchings when the standard matching approach fails to sufficiently coarsen the graph. The 2–hop matching is very effective for graphs with power-law degree distributions. - !! - 0 means perform 2-hop matching - !! - 1 means do not perform 2-hop matching - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_MINCONN = 10 - !! Specifies that the partitioning routines should try to minimize the maximum degree of the subdomain graph, i.e., the graph in which each partition is a node, and edges connect subdomains with a shared interface. - !! 0 Does not explicitly minimize the maximum connectivity - !! 1 explicitly minimize the maximum connectivity -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_MINCONN_DEFAULT = 0 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_CONTIG = 11 - !! Specifies that the partitioning routines should try to produce partitionsthat are contigous. If the input graph is not connected then this option is ignored - !! - 0 does not force contiguous partition - !! - 1 does force contingous partition -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CONTIG_DEFAULT = 0 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_COMPRESS = 12 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_COMPRESS_DEFAULT = 0 - !! Specifies that the graph should be compressed by combining togethervertices that have identical adjacency lists. - !! O- does not compress - !! 1 compress - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_CCORDER = 13 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CCORDER_DEFAULT = 0 - !! Specifies if the connected components of the graph should first be identifies and ordered separately. - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_PFACTOR = 14 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PFACTOR_DEFAULT = 0 - !! Specifies the minimum degree of the vertices that will be ordered last. - !! If the specified value is x > 0, then - !! any vertices with a degree greater than 0.1*x*(average degree) are removed from the graph, an ordering of - !! the rest of the vertices is computed, and an overall ordering is computed by ordering the removed vertices - !! at the end of the overall ordering. For example if x = 40, and the average degree is 5, then the algorithm - !! will remove all vertices with degree greater than 20. The vertices that are removed are ordered last (i.e., - !! they are automatically placed in the top-level separator). Good values are often in the range of 60 to 200 - !! (i.e., 6 to 20 times more than the average). Default value is 0, indicating that no vertices are removed. - !! Used to control whether or not the ordering algorithm should remove any vertices with high degree (i.e., - !! dense columns). This is particularly helpful for certain classes of LP matrices, in which there a few vertices - !! that are connected to many other vertices. By removing these vertices prior to ordering, the quality and the - !! amount of time required to do the ordering improves - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NSEPS = 15 - !! Specifies the number of different separators that it will compute at each level of nested dissection. The final separator that is used is the smallest one. Default is 1 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NSEPS_DEFAULT = 1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_UFACTOR = 16 - !! Specifies the maximum allowed load imbalance among the partitions. A - !! value of x indicates that the allowed load imbalance is (1 + x)=1000. - !! The load imbalance for the jth constraint is defined to be maxi(w[j; i]) - !! =t[j; i]), where w[j; i] is the fraction of the overall weight of the - !! jth constraint that is assigned to the ith partition and t[j; i] is the - !! desired target weight of the jth constraint for the ith partition (i.e., - !! that specified via -tpwgts). For -ptype=rb, the default value is 1 (i.e. - !! , load imbalance of 1.001) and for -ptype=kway, the default value is 30 - !! (i.e., load imbalance of 1.03). - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NUMBERING = 17 - !! Used to indicate which numbering scheme is used for the adjacency structure of a graph or the element-node structure of a mesh. - !! The possible values are 0 for C-style, and 1 for Fortran style -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NUMBERING_DEFAULT = 1 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NUMBERING_FORTRAN = 1 -INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NUMBERING_C = 0 - -!---------------------------------------------------------------------------- -! METIS_SetDefaultOptions -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2021 -! summary: Initializes the options array into its default values. -! -!# Introduction -! Initializes the options array into its default values. -! -!@note -! The passed array `options` must have the size `MAX_METIS_OPTIONS` (40). -! To be able to use the option parameters specified in the [[metis_interface]] module -! it is recommended to use zero-based indexing for the options array: -!```Fortran -!INTEGER( I4B ) :: opts(0:39) -!``` -!@endnote -! -! Other options can also be changed using parameters specified in the [[metis_interface]] module. - -INTERFACE -FUNCTION METIS_SetDefaultOptions(options) RESULT(ans) BIND(C,name="METIS_SetDefaultOptions") - IMPORT - INTEGER( I4B ), INTENT(OUT) :: options(MAX_METIS_OPTIONS) - !! The array of options that will be initialized. - INTEGER( I4B ) :: ans - !! `METIS_OK` - Indicates that the function returned normally. -END FUNCTION METIS_SetDefaultOptions -END INTERFACE - -PUBLIC :: METIS_SetDefaultOptions - -!---------------------------------------------------------------------------- -! METIS_NodeND -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2021 -! summary: This function computes fill reducing orderings of sparse matrices using the multilevel nested dissection algorithm. -! -!# Introduction -! This function computes fill reducing orderings of sparse matrices using the -! multilevel nested dissection algorithm. -! -! Let $A$ be the original matrix and $A*$ be the permuted matrix. -! The arrays `perm` and `iperm` are defined as follows. Row (column) `i` of $A*$ is the `perm(i)` row (column) of $A$, and row (column) `i` of $A$ is the `iperm(i)` row (column) of $A*$. -! The numbering of this vector starts from either 0 or 1, depending on the value of `options(METIS_OPTION_NUMBERING)`. -! -! If the graph is weighted, meaning `vgwt` was provided, the nested dissection ordering computes vertex separators that minimize the sum of the weights of the vertices on the separators. -! -! THE FOLLOWING OPTIONS ARE VALID: -! -! - `METIS_OPTION_CTYPE` -! - `METIS_OPTION_RTYPE` -! - `METIS_OPTION_NO2HOP` -! - `METIS_OPTION_NSEPS` -! - `METIS_OPTION_NITER` -! - `METIS_OPTION_UFACTOR` -! - `METIS_OPTION_COMPRESS` -! - `METIS_OPTION_CCORDER` -! - `METIS_OPTION_SEED` -! - `METIS_OPTION_PFACTOR` -! - `METIS_OPTION_NUMBERING` -! - `METIS_OPTION_DBGLVL` -! -! CInterface -! int METIS_NodeND(idx_t *nvtxs, idx_t *xadj, idx_t *adjncy, idx_t *vwgt, idx_t *options, idx_t *perm, idx_t *iperm) -! -! Optional argument : vwgt, options - -INTERFACE -FUNCTION METIS_NodeND( nvtxs, xadj, adjncy, vwgt, options, perm, iperm ) & - & RESULT( Ans ) BIND( C, NAME="METIS_NodeND" ) - IMPORT - INTEGER( I4B ), INTENT( IN ) :: nvtxs - !! The number of vertices in the graph. - INTEGER( I4B ), INTENT(IN) :: xadj(*), adjncy(*) - !! The adjacency structure of the graph as described in Section 5.5 of - !! the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE(C_PTR), VALUE, INTENT( IN ) :: vwgt - !! An array of size `nvtxs` specifying the weights of the vertices. - TYPE(C_PTR), VALUE, INTENT(IN) :: options !( MAX_METIS_OPTIONS ) - !! This is the array of options as described in Section 5.4 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). See description for valid options. - INTEGER( I4B ), INTENT( OUT ) :: perm(nvtxs), iperm(nvtxs) - !! These are vectors, each of size nvtxs. Upon successful completion, - !! they store the fill-reducing permutation and inverse-permutation. Let - !! A be the original matrix and $A*$ be the permuted matrix. - !! The arrays `perm` and `iperm` are defined as follows. - !! Row (or, column) $i$ of $A*$ is the `perm[i]` row (column) of A, - !! and row (column) $i$ of $A$ is the `iperm[i]` row (column) of A0. - !! The numbering of this vector starts from either 0 or 1, - !! depending on the value of options[METIS OPTION NUMBERING] - INTEGER( I4B ) :: ans - !! `METIS_OK` - Indicates that the function returned normally.
- !! `METIS_ERROR_INPUT` - Indicates an input error.
- !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory.
- !! `METIS_ERROR` - Indicates some other type of error. -END FUNCTION METIS_NodeND -END INTERFACE - -PUBLIC :: METIS_NodeND - -!---------------------------------------------------------------------------- -! METIS_PartGraphRecursive -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2021 -! summary: this function is used to partition a graph into `nparts` -! parts using recursive bisection. -! -!# Introduction -! This function is used to partition a graph into `nparts` parts using -! recursive bisection. -! -! THE FOLLOWING OPTIONS ARE VALID: -! -! - `METIS_OPTION_CTYPE` -! - `METIS_OPTION_IPTYPE` -! - `METIS_OPTION_RTYPE` -! - `METIS_OPTION_NO2HOP` -! - `METIS_OPTION_NCUTS` -! - `METIS_OPTION_NITER` -! - `METIS_OPTION_SEED` -! - `METIS_OPTION_UFACTOR` -! - `METIS_OPTION_NUMBERING` -! - `METIS_OPTION_DBGLVL` -! -! OPTIONAL :: VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC, OPTIONS -! -! int_METIS_PartGraphRecursive(idx_t *nvtxs, idx_t *ncon, idx_t *xadj, idx_t ! *adjncy, idx_t *vwgt, idx_t *vsize, idx_t *adjwgt, idx_t *nparts, real_t *tpwgts, real_t *ubvec, idx_t *options, idx_t *objval, idx_t *part) - -INTERFACE -FUNCTION METIS_PartGraphRecursive( nvtxs, ncon, xadj, adjncy, & - & vwgt, vsize, adjwgt, nparts, tpwgts, ubvec, options, objval, part ) & - & RESULT( ans ) BIND(C, name="METIS_PartGraphRecursive") - IMPORT - INTEGER( I4B ), INTENT( IN ) :: nvtxs - !! The number of vertices in the graph. - INTEGER( I4B ), INTENT( IN ) :: ncon - !! The number of balancing constraints on each node. - !! It should be atleast 1. - INTEGER( I4B ), INTENT( IN ) :: xadj(*), adjncy(*) - !! The adjacency structure of the graph as described in - !! section 5.5 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE(C_PTR), VALUE, INTENT( IN ) :: vwgt - !! The weights of the vertices as described in Section 5.5 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE(C_PTR), VALUE, INTENT( IN ) :: vsize - !! The size of the vertices for computing the total communication volume - !! as described in section 5.7 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE(C_PTR), VALUE, INTENT( IN ) :: adjwgt - !! The weights of the edges as describe in Section 5.5 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - INTEGER( I4B ), INTENT(IN) :: nparts - !! The number of parts to partition the graph. - TYPE(C_PTR), VALUE, INTENT( IN ) :: tpwgts - !! This is an array pf size`nparts*ncon` that specifies the desired - !! weight for each partition and constraint. - !! The target partition weight for the ith partition and - !! jth constraint is specified at `tpwgts[i*ncon+j]`. - !! The numbering for both partition and constraints starts from 0. - !! For each constraint, the sum of the `tpwgts[]` entries must be 1.0. - !! If not present, the graph is divided equally among the partitions. - !! More in the description. - TYPE(C_PTR), VALUE, INTENT( IN ) :: ubvec - !! An array of size `ncon` that specifies the allowed load imbalance - !! for each constraint. - !! For the `i`-th partition and `j`-th constraint the allowed - !! weight is the `ubvec(j)*tpwgts(i*ncon+j)` - !! fraction of the `j`-th's constraint total weight. - !! If not present, the load imbalance - !! tolerance is 1.001 (for `ncon = 1`) or 1.01 (for `ncon > 1`). - TYPE(C_PTR), VALUE, INTENT( IN ) :: options - !! An array of options as described in Section 5.4 of the METIS manual. - !! See description for valid options. - INTEGER( I4B ), INTENT(OUT) :: objval - !! Upon successful completion, this variable stores the edge-cut or the - !! total communication volume of the partitioning - !! solution. The value returned depends on the partitioning's objective - !! function. - INTEGER( I4B ), INTENT(OUT) :: part(nvtxs) - !! This is a vector of size `nvtxs` that upon successful completion - !! stores the partition vector of the graph. - !! The numbering of this vector starts from either 0 or 1, - !! depending on the value of `options(METIS_OPTION_NUMBERING)`. - INTEGER( I4B ) :: ans - !! Error code - !! `METIS_OK` - Indicates that the function returned normally. - !! `METIS_ERROR_INPUT` - Indicates an input error. - !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. - !! `METIS_ERROR` - Indicates some other type of error. -END FUNCTION METIS_PartGraphRecursive -END INTERFACE - -PUBLIC :: METIS_PartGraphRecursive - -!---------------------------------------------------------------------------- -! METIS_PartGraphKway -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2021 -! summary: This function is used to partition a graph into `nparts` parts using multilevel k-way partitioning. -! -!# Introduction -! -! This function is used to partition a graph into `nparts` parts using multilevel k-way partitioning. -! -! THE FOLLOWING OPTIONS ARE VALID: -! - `METIS_OPTION_OBJTYPE` -! - `METIS_OPTION_CTYPE` -! - `METIS_OPTION_IPTYPE` -! - `METIS_OPTION_RTYPE` -! - `METIS_OPTION_NO2HOP` -! - `METIS_OPTION_NCUTS` -! - `METIS_OPTION_NITER` -! - `METIS_OPTION_UFACTOR` -! - `METIS_OPTION_MINCONN` -! - `METIS_OPTION_CONTIG` -! - `METIS_OPTION_SEED` -! - `METIS_OPTION_NUMBERING` -! - `METIS_OPTION_DBGLVL` -! -! OPTIONAL :: VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC, OPTIONS -! -! int_METIS_PartGraphRecursive(idx_t *nvtxs, idx_t *ncon, idx_t *xadj, idx_t ! *adjncy, idx_t *vwgt, idx_t *vsize, idx_t *adjwgt, idx_t *nparts, real_t *tpwgts, real_t *ubvec, idx_t *options, idx_t *objval, idx_t *part) - -INTERFACE -FUNCTION METIS_PartGraphKway( nvtxs, ncon, xadj, adjncy, & - & vwgt, vsize, adjwgt, nparts, tpwgts, ubvec, options, objval, part ) & - & RESULT( Ans ) BIND( C, NAME="METIS_PartGraphKway" ) - IMPORT - - INTEGER( I4B ), INTENT(IN) :: nvtxs - !! The number of vertices in the graph. - INTEGER( I4B ), INTENT(IN) :: ncon - !! The number of balancing constraints on each node. - !! It should be atleast 1. - INTEGER( I4B ), INTENT(IN) :: xadj(*), adjncy(*) - !! The adjacency structure of the graph as described in - !! section 5.5 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE(C_PTR), VALUE, INTENT( IN ) :: vwgt - !! The weights of the vertices as described in Section 5.5 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE(C_PTR), VALUE, INTENT( IN ) :: vsize - !! The size of the vertices for computing the total communication volume - !! as described in section 5.7 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE(C_PTR), VALUE, INTENT( IN ) :: adjwgt - !! The weights of the edges as describe in Section 5.5 of the - !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - INTEGER( I4B ), INTENT(IN) :: nparts - !! The number of parts to partition the graph. - TYPE(C_PTR), VALUE, INTENT( IN ) :: tpwgts - !! This is an array pf size`nparts*ncon` that specifies the desired - !! weight for each partition and constraint. - !! The target partition weight for the ith partition and - !! jth constraint is specified at `tpwgts[i*ncon+j]`. - !! The numbering for both partition and constraints starts from 0. - !! For each constraint, the sum of the `tpwgts[]` entries must be 1.0. - !! If not present, the graph is divided equally among the partitions. - !! More in the description. - TYPE(C_PTR), VALUE, INTENT( IN ) :: ubvec - !! An array of size `ncon` that specifies the allowed load imbalance - !! for each constraint. - !! For the `i`-th partition and `j`-th constraint the allowed - !! weight is the `ubvec(j)*tpwgts(i*ncon+j)` - !! fraction of the `j`-th's constraint total weight. - !! If not present, the load imbalance - !! tolerance is 1.001 (for `ncon = 1`) or 1.01 (for `ncon > 1`). - TYPE(C_PTR), VALUE, INTENT( IN ) :: options - !! An array of options as described in Section 5.4 of the METIS manual. - !! See description for valid options. - INTEGER( I4B ), INTENT(OUT) :: objval - !! Upon successful completion, this variable stores the edge-cut or the - !! total communication volume of the partitioning - !! solution. The value returned depends on the partitioning's objective - !! function. - INTEGER( I4B ), INTENT(OUT) :: part(nvtxs) - !! This is a vector of size `nvtxs` that upon successful completion - !! stores the partition vector of the graph. - !! The numbering of this vector starts from either 0 or 1, - !! depending on the value of `options(METIS_OPTION_NUMBERING)`. - INTEGER( I4B ) :: ans - !! Error code - !! `METIS_OK` - Indicates that the function returned normally. - !! `METIS_ERROR_INPUT` - Indicates an input error. - !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. - !! `METIS_ERROR` - Indicates some other type of error. -END FUNCTION METIS_PartGraphKway -END INTERFACE - -PUBLIC :: METIS_PartGraphKway - -!---------------------------------------------------------------------------- -! METIS_PartMeshDual -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2021 -! summary: This function is used to partition a mesh into `nparts` parts based on a partitioning of the mesh's dual graph. -! -!# Introduction -! This function is used to partition a mesh into `nparts` parts based on a partitioning of the mesh's dual graph. -! -! This program first converts the mesh into either a dual graph (i.e., each element becomes a graph vertex) or a nodal graph (i.e., each node becomes a graph vertex), and then uses the graph partitioning API routines to partition this graph. METIS utilizes a flexible approach for creating a graph for a finite element mesh, which allows it to handle meshes with different and possibly mixed element types (e.g., triangles, tetrahedra, hexahedra, etc.). The functionality provided by mpmetis is achieved by the METIS PartMeshNodal and METIS PartMeshDual API routines -! -! THE FOLLOWING OPTIONS ARE VALID -! -! - `METIS_OPTION_PTYPE` -! - `METIS_OPTION_OBJTYPE` -! - `METIS_OPTION_CTYPE`, -! - `METIS_OPTION_IPTYPE` -! - `METIS_OPTION_RTYPE` -! - `METIS_OPTION_NCUTS`, -! - `METIS_OPTION_NITER` -! - `METIS_OPTION_SEED` -! - `METIS_OPTION_UFACTOR`, -! - `METIS_OPTION_NUMBERING` -! - `METIS_OPTION_DBGLVL` -! -! OPTIONAL : VWGT, VSIZE, TPWGTS, OPTIONS -! -! MESH DATA STRUCTURE -! -! All of the mesh partitioning and mesh conversion routines in METIS take as input the element node array of a mesh. This element node array is stored using a pair of arrays called eptr and eind, which are similar to the xadj and adjncy arrays used for storing the adjacency structure of a graph. The size of the eptr array is n+ 1, where n is the number of elements in the mesh. The size of the eind array is of size equal to the sum of the number of nodes in all the elements of the mesh. The list of nodes belonging to the ith element of the mesh are stored in consecutive locations of eind starting at position eptr[i] up to (but not including) position eptr[i+1]. This format makes it easy to specify meshes of any type of elements, including meshes with mixed element types that have different number of nodes per element. As it was the case with the format of the mesh file described in Section 4.1.2, the ordering of the nodes in each element is not important - -INTERFACE -FUNCTION METIS_PartMeshDual ( ne,nn,eptr,eind,vwgt,vsize,ncommon, & - & nparts,tpwgts,options,objval,epart,npart ) & - & RESULT( Ans ) BIND(C, NAME="METIS_PartMeshDual") - IMPORT - - INTEGER( I4B ), INTENT(IN) :: ne - !! The number of elements in the mesh. - INTEGER( I4B ), INTENT(IN) :: nn - !! The number of nodes in the mesh. - INTEGER( I4B ), INTENT(IN) :: eptr( * ), eind( * ) - !! The pair of arrays storing the mesh as described in Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE( C_PTR ), VALUE, INTENT(IN) :: vwgt - !! An array of size `ne` specifying the weights of the elements. If not present, all elements have an equal weight. - TYPE( C_PTR ), VALUE, INTENT(IN) :: vsize - !! An array of size `ne` specifying the size of the elements that is used - !! for computing the total comunication volume as described in Section 5.7 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - !! If not present, the objective is cut or all elements have an equal size. - INTEGER( I4B ), INTENT(IN) :: ncommon - !! Specifies the number of common nodes that two elements must have in order to put an edge between them in the dual graph. Given two elements e1 and e2, containing n1 and n2 nodes, respectively, then an edge will connect the vertices in the dual graph corresponding to e1 and e2 if the number of common nodes between them is greater than or equal to min(ncommon; n1 − 1; n2 − 1). The default value is 1, indicating that two elements will be connected via an edge as long as they share one node. However, this will tend to create too many edges (increasing the memory and time requirements of the partitioning). The user should select higher values that are better suited for the element types of the mesh that wants to partition. For example, for tetrahedron meshes, ncommon should be 3, which creates an edge between two tets when they share a triangular face (i.e., 3 nodes) - INTEGER( I4B ), INTENT(IN) :: nparts - !! The number of parts to partition the mesh. - TYPE( C_PTR ), VALUE, INTENT(IN) :: tpwgts - !! An array of size `nparts` that specifies the desired weight for each partition. The *target partition weight* for the `i`-th partition is specified at `tpwgts(i)` (the numbering for the - !! partitions starts from 0). The sum of the `tpwgts` entries must be 1.0. - !! If not present, the graph is divided equally among the partitions. - TYPE( C_PTR ), VALUE, INTENT(IN) :: options - !! An array of options as described in Section 5.4 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). See description for valid options. - INTEGER( I4B ), INTENT(OUT) :: objval - !! Upon successful completion, this variable stores either the edgecut or the total communication - !! volume of the dual graph's partitioning. - INTEGER( I4B ), INTENT(OUT) :: epart(ne) - !! A vector of size `ne` that upon successful completion stores the partition vector for the elements - !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of - !! `options(METIS_OPTION_NUMBERING)`. - INTEGER( I4B ), INTENT(OUT) :: npart(nn) - !! A vector of size `nn` that upon successful completion stores the partition vector for the nodes - !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of - !! `options(METIS_OPTION_NUMBERING)`. - INTEGER( I4B ) :: ans - !! `METIS_OK` - Indicates that the function returned normally.
- !! `METIS_ERROR_INPUT` - Indicates an input error.
- !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory.
- !! `METIS_ERROR` - Indicates some other type of error. -END FUNCTION METIS_PartMeshDual -END INTERFACE - -PUBLIC :: METIS_PartMeshDual - -!---------------------------------------------------------------------------- -! METIS_PartMeshNodal -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 July 2021 -! summary: This function us used to partition a mesh into `nparts` parts based on a partitioning of the mesh's nodal graph. -! -!# Introduction -! This function us used to partition a mesh into `nparts` parts based on a -! partitioning of the mesh's nodal graph. -! -! THE FOLLOWING OPTIONS ARE VALID: -! - `METIS_OPTION_PTYPE` -! - `METIS_OPTION_OBJTYPE` -! - `METIS_OPTION_CTYPE` -! - `METIS_OPTION_IPTYPE` -! - `METIS_OPTION_RTYPE` -! - `METIS_OPTION_NCUTS`, -! - `METIS_OPTION_NITER` -! - `METIS_OPTION_SEED` -! - `METIS_OPTION_UFACTOR`, -! - `METIS_OPTION_NUMBERING` -! - `METIS_OPTION_DBGLVL` -! -! -! MESH DATA STRUCTURE -! -! All of the mesh partitioning and mesh conversion routines in METIS take as input the element node array of a mesh. This element node array is stored using a pair of arrays called eptr and eind, which are similar to the xadj and adjncy arrays used for storing the adjacency structure of a graph. The size of the eptr array is n+ 1, where n is the number of elements in the mesh. The size of the eind array is of size equal to the sum of the number of nodes in all the elements of the mesh. The list of nodes belonging to the ith element of the mesh are stored in consecutive locations of eind starting at position eptr[i] up to (but not including) position eptr[i+1]. This format makes it easy to specify meshes of any type of elements, including meshes with mixed element types that have different number of nodes per element. As it was the case with the format of the mesh file described in Section 4.1.2, the ordering of the nodes in each element is not important - -INTERFACE -FUNCTION METIS_PartMeshNodal( ne, nn, eptr, eind, vwgt, vsize, & - & nparts, tpwgts, options, objval, epart, npart ) & - & RESULT( Ans ) BIND( C, NAME="METIS_PartMeshNodal" ) - IMPORT - - INTEGER( I4B ), INTENT(IN) :: ne - !! The number of elements in the mesh. - INTEGER( I4B ), INTENT(IN) :: nn - !! The number of nodes in the mesh. - INTEGER( I4B ), INTENT(IN) :: eptr( * ), eind( * ) - !! The pair of arrays storing the mesh as described in Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - TYPE( C_PTR ), VALUE, INTENT( IN ) :: vwgt - !! An array of size `nn` specifying weights of the nodes. If not passed, all nodes have an equal weight. - TYPE( C_PTR ), VALUE, INTENT( IN ) :: vsize - !! An array of size `nn` specifying the size of the nodes that is used for computing the - !! total comunication volume as described in Section 5.7 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). If not passed, - !! the objective is cut or all nodes have an equal size. - INTEGER( I4B ), INTENT(IN) :: nparts - !! The number of parts to partition the mesh. - TYPE( C_PTR ), VALUE, INTENT( IN ) :: tpwgts - !! An array of size `nparts` that specifies the desired weight for each partition. The *target - !! partition weight* for the `i`-th partition is specified at `tpwgts(i)` (the numbering for the - !! partitions starts from 0). The sum of the `tpwgts` entries must be 1.0. If not passed, the graph - !! is divided equally among the partitions. - TYPE( C_PTR ), VALUE, INTENT( IN ) :: options - !! An array of options as described in Section 5.4 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). See description for valid options. - INTEGER( I4B ), INTENT(OUT) :: objval - !! Upon successful completion, this variable stores either the edgecut or the total communication - !! volume of the nodal graph's partitioning. - INTEGER( I4B ), INTENT(OUT) :: epart(ne) - !! A vector of size `ne` that upon successful completion stores the partition vector for the elements - !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of - !! `options(METIS_OPTION_NUMBERING)`. - INTEGER( I4B ), INTENT(OUT) :: npart(nn) - !! A vector of size `nn` that upon successful completion stores the partition vector for the nodes - !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of - !! `options(METIS_OPTION_NUMBERING)`. - INTEGER( I4B ) :: ans - !! `METIS_OK` - Indicates that the function returned normally. - !! `METIS_ERROR_INPUT` - Indicates an input error. - !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. - !! `METIS_ERROR` - Indicates some other type of error. -END FUNCTION METIS_PartMeshNodal -END INTERFACE - -PUBLIC :: METIS_PartMeshNodal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2021 -! summary: This function is used to generate the dual graph of a mesh. -! -!# Introduction -! This function is used to generate the dual graph of a mesh. -! -!@note -! To use the returned arrays `xadj` and `adjncy`, these must be first converted from -! a C pointer to a Fortran pointer using the subroutine `c_f_pointer(cptr,fptr,shape)` -! that assigns the target of the C pointer `cptr` to the Fortran pointer `fptr` and -! specifies its shape. The `shape` is an integer rank-one array, storing the size `ne+1` -! in case of the dual graph. The size of the new `adjncy` array is stored in the -! last element of `xadj` when using C-style numbering. An example is shown below. -!@endnote -! -!@warning -! Memory for the returned arrays `xadj` and `adjncy` is allocated by METIS' API in C -! using the standard `malloc` function. It is the responsibility of the application to free -! this memory by calling `free`. Therefore, METIS provides the [[METIS_Free]] function that is a wrapper to -! C's `free`function. -!@endwarning -! -! int METIS MeshToDual(idx t *ne, idx t *nn, idx t *eptr, idx t *eind, idx t *ncommon, idx t *numflag, idx t **xadj, idx t **adjncy) -! - - -INTERFACE -FUNCTION METIS_MeshToDual( ne, nn, eptr, eind, ncommon, numflag, xadj, & - & adjncy) RESULT(Ans) BIND(C,NAME="METIS_MeshToDual") - IMPORT - - INTEGER( I4B ), INTENT(IN) :: ne - !! The number of elements in the mesh. - INTEGER( I4B ), INTENT(IN) :: nn - !! The number of nodes in the mesh. - INTEGER( I4B ), INTENT(IN) :: eptr( * ), eind( * ) - !! The pair of arrays storing the mesh as described in - !! Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - INTEGER( I4B ), INTENT(IN) :: ncommon - !! Specifies the number of common nodes that two elements must have in order to put an edge between them in the dual graph. Given two elements e1 and e2, containing n1 and n2 nodes, respectively, then an edge will connect the vertices in the dual graph corresponding to e1 and e2 if the number of common nodes between them is greater than or equal to min(ncommon; n1 − 1; n2 − 1). The default value is 1, indicating that two elements will be connected via an edge as long as they share one node. However, this will tend to create too many edges (increasing the memory and time requirements of the partitioning). The user should select higher values that are better suited for the element types of the mesh that wants to partition. For example, for tetrahedron meshes, ncommon should be 3, which creates an edge between two tets when they share a triangular face (i.e., 3 nodes) - INTEGER( I4B ), INTENT(IN) :: numflag - !! Used to indicate which numbering scheme is used for `eptr` and `eind`. - !! The possible values are:
- !! 0 - C-style numbering is assumed that starts from 0
- !! 1 - Fortran-style numbering is assumed that starts from 1 - TYPE(C_PTR), INTENT(OUT) :: xadj, adjncy - !! These arrays store the adjacency structure of the generated dual graph. The format of the adjacency structure is described in Section 5.5 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). Memory for these arrays is allocated by METIS’ API using the standard malloc function. It is the responsibility of the application to free this memory by calling free. METIS provides the METIS Free that is a wrapper to C’s free function. - INTEGER( I4B ) :: Ans - !! `METIS_OK` - Indicates that the function returned normally.
- !! `METIS_ERROR_INPUT` - Indicates an input error.
- !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory.
- !! `METIS_ERROR` - Indicates some other type of error. -END FUNCTION METIS_MeshToDual -END INTERFACE - -PUBLIC :: METIS_MeshToDual - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2021 -! summary: This function is used to generate the nodal graph of a mesh. -! -!# Introduction -! This function is used to generate the nodal graph of a mesh. -! -!@note -! To use the returned arrays `xadj` and `adjncy`, these must be first converted from -! a C pointer to a Fortran pointer using the subroutine `c_f_pointer(cptr,fptr,shape)` -! that assigns the target of the C pointer `cptr` to the Fortran pointer `fptr` and -! specifies its shape. The `shape` is an integer rank-one array, storing the size `nn+1` -! in case of the nodal graph. The size of the new `adjncy` array is stored in the -! last element of `xadj` when using C-style numbering. An example is shown below. -!@endnote -! -!@warning -! Memory for the returned arrays `xadj` and `adjncy` is allocated by METIS' API in C -! using the standard `malloc` function. It is the responsibility of the application to free -! this memory by calling `free`. Therefore, METIS provides the [[METIS_Free]] function that is a wrapper to -! C's `free`function. -!@endwarning - -INTERFACE -FUNCTION METIS_MeshToNodal(ne,nn,eptr,eind,numflag,xadj,adjncy) & - & RESULT(Ans) BIND(C,name="METIS_MeshToNodal") - IMPORT - - INTEGER( I4B ), INTENT(IN) :: ne - !! The number of elements in the mesh. - INTEGER( I4B ), INTENT(IN) :: nn - !! The number of nodes in the mesh. - INTEGER( I4B ), INTENT(IN) :: eptr(*), eind(*) - !! The pair of arrays storing the mesh as described in Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). - INTEGER( I4B ), INTENT(IN) :: numflag - !! Used to indicate which numbering scheme is used for `eptr` and `eind`. - !! The possible values are: - !! 0 - C-style numbering is assumed that starts from 0 - !! 1 - Fortran-style numbering is assumed that starts from 1 - TYPE( C_PTR ), INTENT(OUT) :: xadj, adjncy - !! These arrays store the adjacency structure of the generated dual graph. The format of the adjacency structure is described in Section 5.5 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). Memory for these arrays is allocated by METIS’ API using the standard malloc function. It is the responsibility of the application to free this memory by calling free. METIS provides the METIS Free that is a wrapper to C’s free function. - INTEGER( I4B ) :: ans - !! `METIS_OK` - Indicates that the function returned normally. - !! `METIS_ERROR_INPUT` - Indicates an input error. - !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. - !! `METIS_ERROR` - Indicates some other type of error. -END FUNCTION METIS_MeshToNodal -END INTERFACE - -PUBLIC :: METIS_MeshToNodal - -!---------------------------------------------------------------------------- -! METIS_Free -!---------------------------------------------------------------------------- - -!> Frees the memory that was allocated by either the [[METIS_MeshToDual]] or the -! [[METIS_MeshToNodal]] routines for returning the dual or nodal graph of a mesh. -! -!@warning Memory deallocation should always happen on the same side it was allocated! -! Also check the descriptions of the above-mentioned routines. -! -!# Example -! -!```Fortran -! type(c_ptr) :: xadj(:),adjncy(:) -! -! call METIS_MeshToNodal(...,xadj,adjncy) -! -! ! xadj and adjncy should be deallocated on the C side! ;) -! call METIS_Free(xadj) -! call METIS_Free(adjncy) -!``` - -INTERFACE -FUNCTION METIS_Free(ptr) RESULT( ans ) BIND(C,NAME="METIS_Free") - IMPORT - TYPE( C_PTR ), VALUE :: ptr - !! The pointer to be freed. This pointer should be one of the `xadj` or `adjncy`, arrays returned by METIS' API routines - INTEGER( I4B ) :: ans - !! `METIS_OK` Indicates that the function returned normally. -END FUNCTION METIS_Free -END INTERFACE - -PUBLIC :: METIS_FREE - - - - - diff --git a/src/modules/MultiIndices/CMakeLists.txt b/src/modules/MultiIndices/CMakeLists.txt deleted file mode 100644 index 75e364bf1..000000000 --- a/src/modules/MultiIndices/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/MultiIndices_Method.F90 -) diff --git a/src/modules/MultiIndices/src/MultiIndices_Method.F90 b/src/modules/MultiIndices/src/MultiIndices_Method.F90 deleted file mode 100644 index 7745808c0..000000000 --- a/src/modules/MultiIndices/src/MultiIndices_Method.F90 +++ /dev/null @@ -1,154 +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 MultiIndices_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -PUBLIC :: MultiIndices -PUBLIC :: DEALLOCATE -PUBLIC :: Display -PUBLIC :: Size -PUBLIC :: GetMultiIndices - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Initiate the multi indices - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_Initiate1(obj, n, d) - TYPE(MultiIndices_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), INTENT(IN) :: d - END SUBROUTINE obj_Initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! MultiIndices@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Function to construct the multi-index - -INTERFACE MultiIndices - MODULE PURE FUNCTION obj_MultiIndices(n, d) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), INTENT(IN) :: d - TYPE(MultiIndices_) :: ans - END FUNCTION obj_MultiIndices -END INTERFACE MultiIndices - -!---------------------------------------------------------------------------- -! Deallocate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Deallocate the object - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE obj_Deallocate(obj) - TYPE(MultiIndices_), INTENT(INOUT) :: obj - END SUBROUTINE obj_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Display@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Display the content - -INTERFACE Display - MODULE SUBROUTINE obj_Display(obj, msg, unitno) - TYPE(MultiIndices_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - END SUBROUTINE obj_Display -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Size@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get the number of touples - -INTERFACE Size - MODULE PURE FUNCTION obj_Size1(obj) RESULT(ans) - TYPE(MultiIndices_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION obj_Size1 -END INTERFACE Size - -!---------------------------------------------------------------------------- -! Size@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get the number of touples - -INTERFACE Size - MODULE PURE FUNCTION obj_Size2(obj, upto) RESULT(ans) - TYPE(MultiIndices_), INTENT(IN) :: obj - LOGICAL(LGT), INTENT(IN) :: upto - INTEGER(I4B) :: ans - END FUNCTION obj_Size2 -END INTERFACE Size - -!---------------------------------------------------------------------------- -! GetIndices@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get Indices - -INTERFACE GetMultiIndices - MODULE PURE FUNCTION obj_GetMultiIndices1(obj) RESULT(ans) - TYPE(MultiIndices_), INTENT(IN) :: obj - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_GetMultiIndices1 -END INTERFACE GetMultiIndices - -!---------------------------------------------------------------------------- -! GetIndices@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get Indices - -INTERFACE GetMultiIndices - MODULE PURE FUNCTION obj_GetMultiIndices2(obj, upto) RESULT(ans) - TYPE(MultiIndices_), INTENT(IN) :: obj - LOGICAL(LGT), INTENT(IN) :: upto - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_GetMultiIndices2 -END INTERFACE GetMultiIndices - -END MODULE MultiIndices_Method diff --git a/src/modules/OpenMP/CMakeLists.txt b/src/modules/OpenMP/CMakeLists.txt deleted file mode 100644 index e4086ee3f..000000000 --- a/src/modules/OpenMP/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 7/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/OpenMP_Method.F90 -) \ No newline at end of file diff --git a/src/modules/OpenMP/src/OpenMP_Method.F90 b/src/modules/OpenMP/src/OpenMP_Method.F90 deleted file mode 100644 index 5a36cf92a..000000000 --- a/src/modules/OpenMP/src/OpenMP_Method.F90 +++ /dev/null @@ -1,82 +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: 9 March 2021 -! summary: This module contains openmp methods - -MODULE OpenMP_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE -PUBLIC :: OMP_Initiate -PUBLIC :: OMP_Finalize -PUBLIC :: OMP_Partition - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -INTERFACE OMP_Initiate - MODULE SUBROUTINE obj_initiate - END SUBROUTINE obj_initiate -END INTERFACE OMP_Initiate - -!---------------------------------------------------------------------------- -! Finalize@Constructor -!---------------------------------------------------------------------------- - -INTERFACE OMP_Finalize - MODULE SUBROUTINE obj_finalize - END SUBROUTINE obj_finalize -END INTERFACE OMP_Finalize - -!---------------------------------------------------------------------------- -! Partition@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 March 2021 -! summary: This function partition a vector for omp -! -!# Introduction -! -! This function partition a vector for [[OpenMP_]], -! and returns a vector of length 4 (i.e., Ans) -! -! * Ans( 1 ) = istart -! * Ans( 2 ) = iend -! * Ans( 3 ) = stride -! * Ans( 4 ) = Length -! -! -!### Usage -! -!```fortran -! to do -!``` - -INTERFACE OMP_Partition - MODULE FUNCTION obj_partition_vec(N, OMP_NUM_THREADS) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: N - INTEGER(I4B), INTENT(IN) :: OMP_NUM_THREADS - INTEGER(I4B) :: Ans(4) - END FUNCTION obj_partition_vec -END INTERFACE OMP_Partition - -END MODULE OpenMP_Method diff --git a/src/modules/PENF/CMakeLists.txt b/src/modules/PENF/CMakeLists.txt deleted file mode 100644 index a71c52eff..000000000 --- a/src/modules/PENF/CMakeLists.txt +++ /dev/null @@ -1,85 +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 -# - -# set type specific output defaults -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/penf.F90 - ${src_path}/penf_b_size.F90 - ${src_path}/penf_global_parameters_variables.F90 - ${src_path}/penf_stringify.F90 -) - -INCLUDE(CheckFortranSourceRuns) - -check_fortran_source_runs( - "program r16p_support; - integer, parameter :: r16p = selected_real_kind(33, 4931); - if(r16p < 0) stop 1; - end program r16p_support" - R16P_SUPPORTED - SRC_EXT f90 - ) -IF(R16P_SUPPORTED) -SET(r16p_supported "-D_R16P") -ENDIF() - -check_fortran_source_runs( - "program ascii_support; - integer, parameter :: ascii = selected_char_kind('ascii'); - if(ascii < 0) stop 1; - end program ascii_support" - ASCII_SUPPORTED - SRC_EXT f90 - ) - -IF(ASCII_SUPPORTED) -SET(ascii_supported "-D_ASCII_SUPPORTED") -ENDIF() - -check_fortran_source_runs( -"program ascii_neq_default; -integer, parameter :: ascii = selected_char_kind('ascii'); -integer, parameter :: default = selected_char_kind('default'); -if(ascii == default) stop 1; -end program ascii_neq_default" -ASCII_NEQ_DEFAULT -SRC_EXT f90 -) - -IF(ASCII_NEQ_DEFAULT) -SET(ascii_neq_default "-D_ASCII_NEQ_DEFAULT") -ENDIF() - -check_fortran_source_runs( -"program ucs4_support; -integer, parameter :: ucs4 = selected_char_kind('iso_10646'); -if(ucs4 < 0) stop 1; -end program ucs4_support" -UCS4_SUPPORTED -SRC_EXT f90 -) - -IF(UCS4_SUPPORTED) -SET(ucs4_supported "-D_UCS4_SUPPORTED") -ENDIF() - -LIST( APPEND TARGET_COMPILE_DEF ${ascii_supported} ) -LIST( APPEND TARGET_COMPILE_DEF ${ascii_neq_default} ) -LIST( APPEND TARGET_COMPILE_DEF ${ucs4_supported} ) -LIST( APPEND TARGET_COMPILE_DEF ${r16p_supported} ) \ No newline at end of file diff --git a/src/modules/PENF/LICENSE.gpl3.md b/src/modules/PENF/LICENSE.gpl3.md deleted file mode 100644 index 16d89e0a3..000000000 --- a/src/modules/PENF/LICENSE.gpl3.md +++ /dev/null @@ -1,596 +0,0 @@ -GNU GENERAL PUBLIC LICENSE -========================== - -Version 3, 29 June 2007 - -Copyright © 2007 Free Software Foundation, Inc. <> - -Everyone is permitted to copy and distribute verbatim copies of this license -document, but changing it is not allowed. - -## Preamble - -The GNU General Public License is a free, copyleft license for software and other -kinds of works. - -The licenses for most software and other practical works are designed to take away -your freedom to share and change the works. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change all versions of a -program--to make sure it remains free software for all its users. We, the Free -Software Foundation, use the GNU General Public License for most of our software; it -applies also to any other work released this way by its authors. You can apply it to -your programs, too. - -When we speak of free software, we are referring to freedom, not price. Our General -Public Licenses are designed to make sure that you have the freedom to distribute -copies of free software (and charge for them if you wish), that you receive source -code or can get it if you want it, that you can change the software or use pieces of -it in new free programs, and that you know you can do these things. - -To protect your rights, we need to prevent others from denying you these rights or -asking you to surrender the rights. Therefore, you have certain responsibilities if -you distribute copies of the software, or if you modify it: responsibilities to -respect the freedom of others. - -For example, if you distribute copies of such a program, whether gratis or for a fee, -you must pass on to the recipients the same freedoms that you received. You must make -sure that they, too, receive or can get the source code. And you must show them these -terms so they know their rights. - -Developers that use the GNU GPL protect your rights with two steps: (1) assert -copyright on the software, and (2) offer you this License giving you legal permission -to copy, distribute and/or modify it. - -For the developers' and authors' protection, the GPL clearly explains that there is -no warranty for this free software. For both users' and authors' sake, the GPL -requires that modified versions be marked as changed, so that their problems will not -be attributed erroneously to authors of previous versions. - -Some devices are designed to deny users access to install or run modified versions of -the software inside them, although the manufacturer can do so. This is fundamentally -incompatible with the aim of protecting users' freedom to change the software. The -systematic pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we have designed -this version of the GPL to prohibit the practice for those products. If such problems -arise substantially in other domains, we stand ready to extend this provision to -those domains in future versions of the GPL, as needed to protect the freedom of -users. - -Finally, every program is threatened constantly by software patents. States should -not allow patents to restrict development and use of software on general-purpose -computers, but in those that do, we wish to avoid the special danger that patents -applied to a free program could make it effectively proprietary. To prevent this, the -GPL assures that patents cannot be used to render the program non-free. - -The precise terms and conditions for copying, distribution and modification follow. - -## TERMS AND CONDITIONS - -### 0. Definitions. - -“This License” refers to version 3 of the GNU General Public License. - -“Copyright” also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - -“The Program” refers to any copyrightable work licensed under this -License. Each licensee is addressed as “you”. “Licensees” and -“recipients” may be individuals or organizations. - -To “modify” a work means to copy from or adapt all or part of the work in -a fashion requiring copyright permission, other than the making of an exact copy. The -resulting work is called a “modified version” of the earlier work or a -work “based on” the earlier work. - -A “covered work” means either the unmodified Program or a work based on -the Program. - -To “propagate” a work means to do anything with it that, without -permission, would make you directly or secondarily liable for infringement under -applicable copyright law, except executing it on a computer or modifying a private -copy. Propagation includes copying, distribution (with or without modification), -making available to the public, and in some countries other activities as well. - -To “convey” a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through a computer -network, with no transfer of a copy, is not conveying. - -An interactive user interface displays “Appropriate Legal Notices” to the -extent that it includes a convenient and prominently visible feature that (1) -displays an appropriate copyright notice, and (2) tells the user that there is no -warranty for the work (except to the extent that warranties are provided), that -licensees may convey the work under this License, and how to view a copy of this -License. If the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - -### 1. Source Code. - -The “source code” for a work means the preferred form of the work for -making modifications to it. “Object code” means any non-source form of a -work. - -A “Standard Interface” means an interface that either is an official -standard defined by a recognized standards body, or, in the case of interfaces -specified for a particular programming language, one that is widely used among -developers working in that language. - -The “System Libraries” of an executable work include anything, other than -the work as a whole, that (a) is included in the normal form of packaging a Major -Component, but which is not part of that Major Component, and (b) serves only to -enable use of the work with that Major Component, or to implement a Standard -Interface for which an implementation is available to the public in source code form. -A “Major Component”, in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system (if any) on which -the executable work runs, or a compiler used to produce the work, or an object code -interpreter used to run it. - -The “Corresponding Source” for a work in object code form means all the -source code needed to generate, install, and (for an executable work) run the object -code and to modify the work, including scripts to control those activities. However, -it does not include the work's System Libraries, or general-purpose tools or -generally available free programs which are used unmodified in performing those -activities but which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for the work, and -the source code for shared libraries and dynamically linked subprograms that the work -is specifically designed to require, such as by intimate data communication or -control flow between those subprograms and other parts of the work. - -The Corresponding Source need not include anything that users can regenerate -automatically from other parts of the Corresponding Source. - -The Corresponding Source for a work in source code form is that same work. - -### 2. Basic Permissions. - -All rights granted under this License are granted for the term of copyright on the -Program, and are irrevocable provided the stated conditions are met. This License -explicitly affirms your unlimited permission to run the unmodified Program. The -output from running a covered work is covered by this License only if the output, -given its content, constitutes a covered work. This License acknowledges your rights -of fair use or other equivalent, as provided by copyright law. - -You may make, run and propagate covered works that you do not convey, without -conditions so long as your license otherwise remains in force. You may convey covered -works to others for the sole purpose of having them make modifications exclusively -for you, or provide you with facilities for running those works, provided that you -comply with the terms of this License in conveying all material for which you do not -control copyright. Those thus making or running the covered works for you must do so -exclusively on your behalf, under your direction and control, on terms that prohibit -them from making any copies of your copyrighted material outside their relationship -with you. - -Conveying under any other circumstances is permitted solely under the conditions -stated below. Sublicensing is not allowed; section 10 makes it unnecessary. - -### 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - -No covered work shall be deemed part of an effective technological measure under any -applicable law fulfilling obligations under article 11 of the WIPO copyright treaty -adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention -of such measures. - -When you convey a covered work, you waive any legal power to forbid circumvention of -technological measures to the extent such circumvention is effected by exercising -rights under this License with respect to the covered work, and you disclaim any -intention to limit operation or modification of the work as a means of enforcing, -against the work's users, your or third parties' legal rights to forbid circumvention -of technological measures. - -### 4. Conveying Verbatim Copies. - -You may convey verbatim copies of the Program's source code as you receive it, in any -medium, provided that you conspicuously and appropriately publish on each copy an -appropriate copyright notice; keep intact all notices stating that this License and -any non-permissive terms added in accord with section 7 apply to the code; keep -intact all notices of the absence of any warranty; and give all recipients a copy of -this License along with the Program. - -You may charge any price or no price for each copy that you convey, and you may offer -support or warranty protection for a fee. - -### 5. Conveying Modified Source Versions. - -You may convey a work based on the Program, or the modifications to produce it from -the Program, in the form of source code under the terms of section 4, provided that -you also meet all of these conditions: - -* **a)** The work must carry prominent notices stating that you modified it, and giving a -relevant date. -* **b)** The work must carry prominent notices stating that it is released under this -License and any conditions added under section 7. This requirement modifies the -requirement in section 4 to “keep intact all notices”. -* **c)** You must license the entire work, as a whole, under this License to anyone who -comes into possession of a copy. This License will therefore apply, along with any -applicable section 7 additional terms, to the whole of the work, and all its parts, -regardless of how they are packaged. This License gives no permission to license the -work in any other way, but it does not invalidate such permission if you have -separately received it. -* **d)** If the work has interactive user interfaces, each must display Appropriate Legal -Notices; however, if the Program has interactive interfaces that do not display -Appropriate Legal Notices, your work need not make them do so. - -A compilation of a covered work with other separate and independent works, which are -not by their nature extensions of the covered work, and which are not combined with -it such as to form a larger program, in or on a volume of a storage or distribution -medium, is called an “aggregate” if the compilation and its resulting -copyright are not used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work in an aggregate -does not cause this License to apply to the other parts of the aggregate. - -### 6. Conveying Non-Source Forms. - -You may convey a covered work in object code form under the terms of sections 4 and -5, provided that you also convey the machine-readable Corresponding Source under the -terms of this License, in one of these ways: - -* **a)** Convey the object code in, or embodied in, a physical product (including a -physical distribution medium), accompanied by the Corresponding Source fixed on a -durable physical medium customarily used for software interchange. -* **b)** Convey the object code in, or embodied in, a physical product (including a -physical distribution medium), accompanied by a written offer, valid for at least -three years and valid for as long as you offer spare parts or customer support for -that product model, to give anyone who possesses the object code either (1) a copy of -the Corresponding Source for all the software in the product that is covered by this -License, on a durable physical medium customarily used for software interchange, for -a price no more than your reasonable cost of physically performing this conveying of -source, or (2) access to copy the Corresponding Source from a network server at no -charge. -* **c)** Convey individual copies of the object code with a copy of the written offer to -provide the Corresponding Source. This alternative is allowed only occasionally and -noncommercially, and only if you received the object code with such an offer, in -accord with subsection 6b. -* **d)** Convey the object code by offering access from a designated place (gratis or for -a charge), and offer equivalent access to the Corresponding Source in the same way -through the same place at no further charge. You need not require recipients to copy -the Corresponding Source along with the object code. If the place to copy the object -code is a network server, the Corresponding Source may be on a different server -(operated by you or a third party) that supports equivalent copying facilities, -provided you maintain clear directions next to the object code saying where to find -the Corresponding Source. Regardless of what server hosts the Corresponding Source, -you remain obligated to ensure that it is available for as long as needed to satisfy -these requirements. -* **e)** Convey the object code using peer-to-peer transmission, provided you inform -other peers where the object code and Corresponding Source of the work are being -offered to the general public at no charge under subsection 6d. - -A separable portion of the object code, whose source code is excluded from the -Corresponding Source as a System Library, need not be included in conveying the -object code work. - -A “User Product” is either (1) a “consumer product”, which -means any tangible personal property which is normally used for personal, family, or -household purposes, or (2) anything designed or sold for incorporation into a -dwelling. In determining whether a product is a consumer product, doubtful cases -shall be resolved in favor of coverage. For a particular product received by a -particular user, “normally used” refers to a typical or common use of -that class of product, regardless of the status of the particular user or of the way -in which the particular user actually uses, or expects or is expected to use, the -product. A product is a consumer product regardless of whether the product has -substantial commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - -“Installation Information” for a User Product means any methods, -procedures, authorization keys, or other information required to install and execute -modified versions of a covered work in that User Product from a modified version of -its Corresponding Source. The information must suffice to ensure that the continued -functioning of the modified object code is in no case prevented or interfered with -solely because modification has been made. - -If you convey an object code work under this section in, or with, or specifically for -use in, a User Product, and the conveying occurs as part of a transaction in which -the right of possession and use of the User Product is transferred to the recipient -in perpetuity or for a fixed term (regardless of how the transaction is -characterized), the Corresponding Source conveyed under this section must be -accompanied by the Installation Information. But this requirement does not apply if -neither you nor any third party retains the ability to install modified object code -on the User Product (for example, the work has been installed in ROM). - -The requirement to provide Installation Information does not include a requirement to -continue to provide support service, warranty, or updates for a work that has been -modified or installed by the recipient, or for the User Product in which it has been -modified or installed. Access to a network may be denied when the modification itself -materially and adversely affects the operation of the network or violates the rules -and protocols for communication across the network. - -Corresponding Source conveyed, and Installation Information provided, in accord with -this section must be in a format that is publicly documented (and with an -implementation available to the public in source code form), and must require no -special password or key for unpacking, reading or copying. - -### 7. Additional Terms. - -“Additional permissions” are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. Additional -permissions that are applicable to the entire Program shall be treated as though they -were included in this License, to the extent that they are valid under applicable -law. If additional permissions apply only to part of the Program, that part may be -used separately under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - -When you convey a copy of a covered work, you may at your option remove any -additional permissions from that copy, or from any part of it. (Additional -permissions may be written to require their own removal in certain cases when you -modify the work.) You may place additional permissions on material, added by you to a -covered work, for which you have or can give appropriate copyright permission. - -Notwithstanding any other provision of this License, for material you add to a -covered work, you may (if authorized by the copyright holders of that material) -supplement the terms of this License with terms: - -* **a)** Disclaiming warranty or limiting liability differently from the terms of -sections 15 and 16 of this License; or -* **b)** Requiring preservation of specified reasonable legal notices or author -attributions in that material or in the Appropriate Legal Notices displayed by works -containing it; or -* **c)** Prohibiting misrepresentation of the origin of that material, or requiring that -modified versions of such material be marked in reasonable ways as different from the -original version; or -* **d)** Limiting the use for publicity purposes of names of licensors or authors of the -material; or -* **e)** Declining to grant rights under trademark law for use of some trade names, -trademarks, or service marks; or -* **f)** Requiring indemnification of licensors and authors of that material by anyone -who conveys the material (or modified versions of it) with contractual assumptions of -liability to the recipient, for any liability that these contractual assumptions -directly impose on those licensors and authors. - -All other non-permissive additional terms are considered “further -restrictions” within the meaning of section 10. If the Program as you received -it, or any part of it, contains a notice stating that it is governed by this License -along with a term that is a further restriction, you may remove that term. If a -license document contains a further restriction but permits relicensing or conveying -under this License, you may add to a covered work material governed by the terms of -that license document, provided that the further restriction does not survive such -relicensing or conveying. - -If you add terms to a covered work in accord with this section, you must place, in -the relevant source files, a statement of the additional terms that apply to those -files, or a notice indicating where to find the applicable terms. - -Additional terms, permissive or non-permissive, may be stated in the form of a -separately written license, or stated as exceptions; the above requirements apply -either way. - -### 8. Termination. - -You may not propagate or modify a covered work except as expressly provided under -this License. Any attempt otherwise to propagate or modify it is void, and will -automatically terminate your rights under this License (including any patent licenses -granted under the third paragraph of section 11). - -However, if you cease all violation of this License, then your license from a -particular copyright holder is reinstated (a) provisionally, unless and until the -copyright holder explicitly and finally terminates your license, and (b) permanently, -if the copyright holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - -Moreover, your license from a particular copyright holder is reinstated permanently -if the copyright holder notifies you of the violation by some reasonable means, this -is the first time you have received notice of violation of this License (for any -work) from that copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - -Termination of your rights under this section does not terminate the licenses of -parties who have received copies or rights from you under this License. If your -rights have been terminated and not permanently reinstated, you do not qualify to -receive new licenses for the same material under section 10. - -### 9. Acceptance Not Required for Having Copies. - -You are not required to accept this License in order to receive or run a copy of the -Program. Ancillary propagation of a covered work occurring solely as a consequence of -using peer-to-peer transmission to receive a copy likewise does not require -acceptance. However, nothing other than this License grants you permission to -propagate or modify any covered work. These actions infringe copyright if you do not -accept this License. Therefore, by modifying or propagating a covered work, you -indicate your acceptance of this License to do so. - -### 10. Automatic Licensing of Downstream Recipients. - -Each time you convey a covered work, the recipient automatically receives a license -from the original licensors, to run, modify and propagate that work, subject to this -License. You are not responsible for enforcing compliance by third parties with this -License. - -An “entity transaction” is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an organization, or -merging organizations. If propagation of a covered work results from an entity -transaction, each party to that transaction who receives a copy of the work also -receives whatever licenses to the work the party's predecessor in interest had or -could give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if the predecessor -has it or can get it with reasonable efforts. - -You may not impose any further restrictions on the exercise of the rights granted or -affirmed under this License. For example, you may not impose a license fee, royalty, -or other charge for exercise of rights granted under this License, and you may not -initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging -that any patent claim is infringed by making, using, selling, offering for sale, or -importing the Program or any portion of it. - -### 11. Patents. - -A “contributor” is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The work thus -licensed is called the contributor's “contributor version”. - -A contributor's “essential patent claims” are all patent claims owned or -controlled by the contributor, whether already acquired or hereafter acquired, that -would be infringed by some manner, permitted by this License, of making, using, or -selling its contributor version, but do not include claims that would be infringed -only as a consequence of further modification of the contributor version. For -purposes of this definition, “control” includes the right to grant patent -sublicenses in a manner consistent with the requirements of this License. - -Each contributor grants you a non-exclusive, worldwide, royalty-free patent license -under the contributor's essential patent claims, to make, use, sell, offer for sale, -import and otherwise run, modify and propagate the contents of its contributor -version. - -In the following three paragraphs, a “patent license” is any express -agreement or commitment, however denominated, not to enforce a patent (such as an -express permission to practice a patent or covenant not to sue for patent -infringement). To “grant” such a patent license to a party means to make -such an agreement or commitment not to enforce a patent against the party. - -If you convey a covered work, knowingly relying on a patent license, and the -Corresponding Source of the work is not available for anyone to copy, free of charge -and under the terms of this License, through a publicly available network server or -other readily accessible means, then you must either (1) cause the Corresponding -Source to be so available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner consistent with -the requirements of this License, to extend the patent license to downstream -recipients. “Knowingly relying” means you have actual knowledge that, but -for the patent license, your conveying the covered work in a country, or your -recipient's use of the covered work in a country, would infringe one or more -identifiable patents in that country that you have reason to believe are valid. - -If, pursuant to or in connection with a single transaction or arrangement, you -convey, or propagate by procuring conveyance of, a covered work, and grant a patent -license to some of the parties receiving the covered work authorizing them to use, -propagate, modify or convey a specific copy of the covered work, then the patent -license you grant is automatically extended to all recipients of the covered work and -works based on it. - -A patent license is “discriminatory” if it does not include within the -scope of its coverage, prohibits the exercise of, or is conditioned on the -non-exercise of one or more of the rights that are specifically granted under this -License. You may not convey a covered work if you are a party to an arrangement with -a third party that is in the business of distributing software, under which you make -payment to the third party based on the extent of your activity of conveying the -work, and under which the third party grants, to any of the parties who would receive -the covered work from you, a discriminatory patent license (a) in connection with -copies of the covered work conveyed by you (or copies made from those copies), or (b) -primarily for and in connection with specific products or compilations that contain -the covered work, unless you entered into that arrangement, or that patent license -was granted, prior to 28 March 2007. - -Nothing in this License shall be construed as excluding or limiting any implied -license or other defenses to infringement that may otherwise be available to you -under applicable patent law. - -### 12. No Surrender of Others' Freedom. - -If conditions are imposed on you (whether by court order, agreement or otherwise) -that contradict the conditions of this License, they do not excuse you from the -conditions of this License. If you cannot convey a covered work so as to satisfy -simultaneously your obligations under this License and any other pertinent -obligations, then as a consequence you may not convey it at all. For example, if you -agree to terms that obligate you to collect a royalty for further conveying from -those to whom you convey the Program, the only way you could satisfy both those terms -and this License would be to refrain entirely from conveying the Program. - -### 13. Use with the GNU Affero General Public License. - -Notwithstanding any other provision of this License, you have permission to link or -combine any covered work with a work licensed under version 3 of the GNU Affero -General Public License into a single combined work, and to convey the resulting work. -The terms of this License will continue to apply to the part which is the covered -work, but the special requirements of the GNU Affero General Public License, section -13, concerning interaction through a network will apply to the combination as such. - -### 14. Revised Versions of this License. - -The Free Software Foundation may publish revised and/or new versions of the GNU -General Public License from time to time. Such new versions will be similar in spirit -to the present version, but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Program specifies that -a certain numbered version of the GNU General Public License “or any later -version” applies to it, you have the option of following the terms and -conditions either of that numbered version or of any later version published by the -Free Software Foundation. If the Program does not specify a version number of the GNU -General Public License, you may choose any version ever published by the Free -Software Foundation. - -If the Program specifies that a proxy can decide which future versions of the GNU -General Public License can be used, that proxy's public statement of acceptance of a -version permanently authorizes you to choose that version for the Program. - -Later license versions may give you additional or different permissions. However, no -additional obligations are imposed on any author or copyright holder as a result of -your choosing to follow a later version. - -### 15. Disclaimer of Warranty. - -THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM “AS IS” WITHOUT WARRANTY OF ANY KIND, EITHER -EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE -QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE -DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - -### 16. Limitation of Liability. - -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY -COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS -PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, -INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE -OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE -WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - -### 17. Interpretation of Sections 15 and 16. - -If the disclaimer of warranty and limitation of liability provided above cannot be -given local legal effect according to their terms, reviewing courts shall apply local -law that most closely approximates an absolute waiver of all civil liability in -connection with the Program, unless a warranty or assumption of liability accompanies -a copy of the Program in return for a fee. - -END OF TERMS AND CONDITIONS - -## How to Apply These Terms to Your New Programs - -If you develop a new program, and you want it to be of the greatest possible use to -the public, the best way to achieve this is to make it free software which everyone -can redistribute and change under these terms. - -To do so, attach the following notices to the program. It is safest to attach them -to the start of each source file to most effectively state the exclusion of warranty; -and each file should have at least the “copyright” line and a pointer to -where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - -If the program does terminal interaction, make it output a short notice like this -when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type 'show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type 'show c' for details. - -The hypothetical commands 'show w' and 'show c' should show the appropriate parts of -the General Public License. Of course, your program's commands might be different; -for a GUI interface, you would use an “about box”. - -You should also get your employer (if you work as a programmer) or school, if any, to -sign a “copyright disclaimer” for the program, if necessary. For more -information on this, and how to apply and follow the GNU GPL, see -<>. - -The GNU General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may consider it -more useful to permit linking proprietary applications with the library. If this is -what you want to do, use the GNU Lesser General Public License instead of this -License. But first, please read -<>. \ No newline at end of file diff --git a/src/modules/PENF/src/BCTON.inc b/src/modules/PENF/src/BCTON.inc deleted file mode 100644 index 0a8fdda6a..000000000 --- a/src/modules/PENF/src/BCTON.inc +++ /dev/null @@ -1,128 +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 -! - -elemental function bctor_R16P(bstr, knd) result(n) - !< Convert bit-string to real. - !< - !<```fortran - !< use penf - !< print FR16P, bcton('00000000000000000000000000000000000000000000000000000000000000000000000000000'//& - !< '000000000000000000000000000000000001111111100111111', knd=1._R16P) - !<``` - !=> 0.100000000000000000000000000000000E+0001 <<< - character(*), intent(in) :: bstr !< String containing input number. - real(R16P), intent(in) :: knd !< Number kind. - real(R16P) :: n !< Number returned. - integer(I1P) :: buffer(16) !< Transfer buffer. - - read (bstr, '(16B8.8)') buffer - n = transfer(buffer, n) -end function bctor_R16P - -elemental function bctor_R8P(bstr, knd) result(n) - !< Convert bit-string to real. - !< - !<```fortran - !< use penf - !< print FR8P, bcton('0000000000000000000000000000000000000000000000001111000000111111', knd=1._R8P) - !<``` - !=> 0.100000000000000E+001 <<< - character(*), intent(in) :: bstr !< String containing input number. - real(R8P), intent(in) :: knd !< Number kind. - real(R8P) :: n !< Number returned. - integer(I1P) :: buffer(8) !< Transfer buffer. - - read (bstr, '(8B8.8)') buffer - n = transfer(buffer, n) -end function bctor_R8P - -elemental function bctor_R4P(bstr, knd) result(n) - !< Convert bit-string to real. - !< - !<```fortran - !< use penf - !< print FR4P, bcton('00000000000000001000000000111111', knd=1._R4P) - !<``` - !=> 0.100000E+01 <<< - character(*), intent(in) :: bstr !< String containing input number. - real(R4P), intent(in) :: knd !< Number kind. - real(R4P) :: n !< Number returned. - integer(I1P) :: buffer(4) !< Transfer buffer. - - read (bstr, '(4B8.8)') buffer - n = transfer(buffer, n) -end function bctor_R4P - -elemental function bctoi_I8P(bstr, knd) result(n) - !< Convert bit-string to integer. - !< - !<```fortran - !< use penf - !< print FI8P, bcton('0000000000000000000000000000000000000000000000000000000000000001', knd=1_I8P) - !<``` - !=> 1 <<< - character(*), intent(in) :: bstr !< String containing input number. - integer(I8P), intent(in) :: knd !< Number kind. - integer(I8P) :: n !< Number returned. - -read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n -end function bctoi_I8P - -elemental function bctoi_I4P(bstr, knd) result(n) - !< Convert bit-string to integer. - !< - !<```fortran - !< use penf - !< print FI4P, bcton('00000000000000000000000000000001', knd=1_I4P) - !<``` - !=> 1 <<< - character(*), intent(in) :: bstr !< String containing input number. - integer(I4P), intent(in) :: knd !< Number kind. - integer(I4P) :: n !< Number returned. - -read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n -end function bctoi_I4P - -elemental function bctoi_I2P(bstr, knd) result(n) - !< Convert bit-string to integer. - !< - !<```fortran - !< use penf - !< print FI2P, bcton('0000000000000001', knd=1_I2P) - !<``` - !=> 1 <<< - character(*), intent(in) :: bstr !< String containing input number. - integer(I2P), intent(in) :: knd !< Number kind. - integer(I2P) :: n !< Number returned. - -read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n -end function bctoi_I2P - -elemental function bctoi_I1P(bstr, knd) result(n) - !< Convert bit-string to integer. - !< - !<```fortran - !< use penf - !< print FI1P, bcton('00000001', knd=1_I1P) - !<``` - !=> 1 <<< - character(*), intent(in) :: bstr !< String containing input number. - integer(I1P), intent(in) :: knd !< Number kind. - integer(I1P) :: n !< Number returned. - -read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n -end function bctoi_I1P diff --git a/src/modules/PENF/src/BSTR.inc b/src/modules/PENF/src/BSTR.inc deleted file mode 100644 index eddcf6370..000000000 --- a/src/modules/PENF/src/BSTR.inc +++ /dev/null @@ -1,136 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -elemental function bstr_R16P(n) result(bstr) - !< Convert real to string of bits. - !< - !< @note It is assumed that R16P is represented by means of 128 bits, but this is not ensured in all architectures. - !< - !<```fortran - !< use penf - !< character(128) :: b - !< b = bstr(n=1._R16P) - !< print "(A)", b(17:) - !<``` - !=> 0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001111111100111111 <<< - real(R16P), intent(in) :: n !< Real to be converted. - character(128) :: bstr !< Returned bit-string containing input number. - integer(I1P) :: buffer(16) !< Transfer buffer. - - buffer = transfer(n, buffer) - write (bstr, '(16B8.8)') buffer -end function bstr_R16P - -elemental function bstr_R8P(n) result(bstr) - !< Convert real to string of bits. - !< - !< @note It is assumed that R8P is represented by means of 64 bits, but this is not ensured in all architectures. - !< - !<```fortran - !< use penf - !< print "(A)", bstr(n=1._R8P) - !<``` - !=> 0000000000000000000000000000000000000000000000001111000000111111 <<< - real(R8P), intent(in) :: n !< Real to be converted. - character(64) :: bstr !< Returned bit-string containing input number. - integer(I1P) :: buffer(8) !< Transfer buffer. - - buffer = transfer(n, buffer) - write (bstr, '(8B8.8)') buffer -end function bstr_R8P - -elemental function bstr_R4P(n) result(bstr) - !< Convert real to string of bits. - !< - !< @note It is assumed that R4P is represented by means of 32 bits, but this is not ensured in all architectures. - !< - !<```fortran - !< use penf - !< print "(A)", bstr(n=1._R4P) - !<``` - !=> 00000000000000001000000000111111 <<< - real(R4P), intent(in) :: n !< Real to be converted. - character(32) :: bstr !< Returned bit-string containing input number. - integer(I1P) :: buffer(4) !< Transfer buffer. - - buffer = transfer(n, buffer) - write (bstr, '(4B8.8)') buffer -end function bstr_R4P - -elemental function bstr_I8P(n) result(bstr) - !< Convert integer to string of bits. - !< - !< @note It is assumed that I8P is represented by means of 64 bits, but this is not ensured in all architectures. - !< - !<```fortran - !< use penf - !< print "(A)", bstr(n=1_I8P) - !<``` - !=> 0000000000000000000000000000000000000000000000000000000000000001 <<< - integer(I8P), intent(in) :: n !< Real to be converted. - character(64) :: bstr !< Returned bit-string containing input number. - - write (bstr, '(B64.64)') n -end function bstr_I8P - -elemental function bstr_I4P(n) result(bstr) - !< Convert integer to string of bits. - !< - !< @note It is assumed that I4P is represented by means of 32 bits, but this is not ensured in all architectures. - !< - !<```fortran - !< use penf - !< print "(A)", bstr(n=1_I4P) - !<``` - !=> 00000000000000000000000000000001 <<< - integer(I4P), intent(in) :: n !< Real to be converted. - character(32) :: bstr !< Returned bit-string containing input number. - - write (bstr, '(B32.32)') n -end function bstr_I4P - -elemental function bstr_I2P(n) result(bstr) - !< Convert integer to string of bits. - !< - !< @note It is assumed that I2P is represented by means of 16 bits, but this is not ensured in all architectures. - !< - !<```fortran - !< use penf - !< print "(A)", bstr(n=1_I2P) - !<``` - !=> 0000000000000001 <<< - integer(I2P), intent(in) :: n !< Real to be converted. - character(16) :: bstr !< Returned bit-string containing input number. - - write (bstr, '(B16.16)') n -end function bstr_I2P - -elemental function bstr_I1P(n) result(bstr) - !< Convert integer to string of bits. - !< - !< @note It is assumed that I1P is represented by means of 8 bits, but this is not ensured in all architectures. - !< - !<```fortran - !< use penf - !< print "(A)", bstr(n=1_I1P) - !<``` - !=> 00000001 <<< - integer(I1P), intent(in) :: n !< Real to be converted. - character(8) :: bstr !< Returned bit-string containing input number. - - write (bstr, '(B8.8)') n -end function bstr_I1P diff --git a/src/modules/PENF/src/COMPACT_REAL_STRING.inc b/src/modules/PENF/src/COMPACT_REAL_STRING.inc deleted file mode 100644 index 5a1ac9718..000000000 --- a/src/modules/PENF/src/COMPACT_REAL_STRING.inc +++ /dev/null @@ -1,84 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -pure subroutine compact_real_string(string) - !< author: Izaak Beekman - !< date: 02/24/2015 - !< - !< Compact a string representing a real number, so that the same value is displayed with fewer characters. - !< - !< @note No need to add doctest: this is tested by a lot of doctests of other TBPs. - character(len=*), intent(inout) :: string !< string representation of a real number. - character(len=len(string)) :: significand !< Significand characters. - character(len=len(string)) :: expnt !< Exponent characters. - character(len=2) :: separator !< Separator characters. - integer(I4P) :: exp_start !< Start position of exponent. - integer(I4P) :: decimal_pos !< Decimal positions. - integer(I4P) :: sig_trim !< Signature trim. - integer(I4P) :: exp_trim !< Exponent trim. - integer(I4P) :: i !< counter - - string = adjustl(string) - exp_start = scan(string, 'eEdD') - if (exp_start == 0) exp_start = scan(string, '-+', back=.true.) - decimal_pos = scan(string, '.') - if (exp_start /= 0) separator = string(exp_start:exp_start) - if (exp_start < decimal_pos) then ! possibly signed, exponent-less float - significand = string - sig_trim = len(trim(significand)) - do i = len(trim(significand)), decimal_pos + 2, -1 ! look from right to left at 0s, but save one after the decimal place - if (significand(i:i) == '0') then - sig_trim = i - 1 - else - exit - end if - end do - string = trim(significand(1:sig_trim)) - elseif (exp_start > decimal_pos) then ! float has exponent - significand = string(1:exp_start - 1) - sig_trim = len(trim(significand)) - do i = len(trim(significand)), decimal_pos + 2, -1 ! look from right to left at 0s - if (significand(i:i) == '0') then - sig_trim = i - 1 - else - exit - end if - end do - expnt = adjustl(string(exp_start + 1:)) - if (expnt(1:1) == '+' .or. expnt(1:1) == '-') then - separator = trim(adjustl(separator))//expnt(1:1) - exp_start = exp_start + 1 - expnt = adjustl(string(exp_start + 1:)) - end if - exp_trim = 1 - do i = 1, (len(trim(expnt)) - 1) ! look at exponent leading zeros saving last - if (expnt(i:i) == '0') then - exp_trim = i + 1 - else - exit - end if - end do - string = trim(adjustl(significand(1:sig_trim)))// & - trim(adjustl(separator))// & - trim(adjustl(expnt(exp_trim:))) - !else ! mal-formed real, BUT this code should be unreachable - end if -end subroutine compact_real_string diff --git a/src/modules/PENF/src/CTOA.inc b/src/modules/PENF/src/CTOA.inc deleted file mode 100644 index ca4810777..000000000 --- a/src/modules/PENF/src/CTOA.inc +++ /dev/null @@ -1,212 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function ctor_R16P(str, knd, pref, error) result(n) - !< Convert string to real. - !< - !<```fortran - !< use penf - !< print FR16P, cton(str='-1.0', knd=1._R16P) - !<``` - !=> -0.100000000000000000000000000000000E+0001 <<< - character(*), intent(in) :: str !< String containing input number. - real(R16P), intent(in) :: knd !< Number kind. - character(*), optional, intent(in) :: pref !< Prefixing string. - integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. - real(R16P) :: n !< Number returned. - integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. - character(len=:), allocatable :: prefd !< Prefixing string. - - read (str, *, iostat=err) n ! Casting of str to n. - if (err /= 0) then - prefd = ''; if (present(pref)) prefd = pref - write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to real failed! real(', kind(knd), ')' - end if - if (present(error)) error = err -end function ctor_R16P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function ctor_R8P(str, knd, pref, error) result(n) - !< Convert string to real. - !< - !<```fortran - !< use penf - !< print FR8P, cton(str='-1.0', knd=1._R8P) - !<``` - !=> -0.100000000000000E+001 <<< - character(*), intent(in) :: str !< String containing input number. - real(R8P), intent(in) :: knd !< Number kind. - character(*), optional, intent(in) :: pref !< Prefixing string. - integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. - real(R8P) :: n !< Number returned. - integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. - character(len=:), allocatable :: prefd !< Prefixing string. - - read (str, *, iostat=err) n ! Casting of str to n. - if (err /= 0) then - prefd = ''; if (present(pref)) prefd = pref - write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to real failed! real(', kind(knd), ')' - end if - if (present(error)) error = err -end function ctor_R8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function ctor_R4P(str, knd, pref, error) result(n) - !< Convert string to real. - !< - !<```fortran - !< use penf - !< print FR4P, cton(str='-1.0', knd=1._R4P) - !<``` - !=> -0.100000E+01 <<< - character(*), intent(in) :: str !< String containing input number. - real(R4P), intent(in) :: knd !< Number kind. - character(*), optional, intent(in) :: pref !< Prefixing string. - integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. - real(R4P) :: n !< Number returned. - integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. - character(len=:), allocatable :: prefd !< Prefixing string. - - read (str, *, iostat=err) n ! Casting of str to n. - if (err /= 0) then - prefd = ''; if (present(pref)) prefd = pref - write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to real failed! real(', kind(knd), ')' - end if - if (present(error)) error = err -end function ctor_R4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function ctoi_I8P(str, knd, pref, error) result(n) - !< Convert string to integer. - !< - !<```fortran - !< use penf - !< print FI8P, cton(str='-1', knd=1_I8P) - !<``` - !=> -1 <<< - character(*), intent(in) :: str !< String containing input number. - integer(I8P), intent(in) :: knd !< Number kind. - character(*), optional, intent(in) :: pref !< Prefixing string. - integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. - integer(I8P) :: n !< Number returned. - integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. - character(len=:), allocatable :: prefd !< Prefixing string. - - read (str, *, iostat=err) n ! Casting of str to n. - if (err /= 0) then - prefd = ''; if (present(pref)) prefd = pref - write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' - end if - if (present(error)) error = err -end function ctoi_I8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function ctoi_I4P(str, knd, pref, error) result(n) - !< Convert string to integer. - !< - !<```fortran - !< use penf - !< print FI4P, cton(str='-1', knd=1_I4P) - !<``` - !=> -1 <<< - character(*), intent(in) :: str !< String containing input number. - integer(I4P), intent(in) :: knd !< Number kind. - character(*), optional, intent(in) :: pref !< Prefixing string. - integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. - integer(I4P) :: n !< Number returned. - integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. - character(len=:), allocatable :: prefd !< Prefixing string. - - read (str, *, iostat=err) n ! Casting of str to n. - if (err /= 0) then - prefd = ''; if (present(pref)) prefd = pref - write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' - end if - if (present(error)) error = err -end function ctoi_I4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function ctoi_I2P(str, knd, pref, error) result(n) - !< Convert string to integer. - !< - !<```fortran - !< use penf - !< print FI2P, cton(str='-1', knd=1_I2P) - !<``` - !=> -1 <<< - character(*), intent(in) :: str !< String containing input number. - integer(I2P), intent(in) :: knd !< Number kind. - character(*), optional, intent(in) :: pref !< Prefixing string. - integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. - integer(I2P) :: n !< Number returned. - integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. - character(len=:), allocatable :: prefd !< Prefixing string. - - read (str, *, iostat=err) n ! Casting of str to n. - if (err /= 0) then - prefd = ''; if (present(pref)) prefd = pref - write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' - end if - if (present(error)) error = err -end function ctoi_I2P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -function ctoi_I1P(str, knd, pref, error) result(n) - !< Convert string to integer. - !< - !<```fortran - !< use penf - !< print FI1P, cton(str='-1', knd=1_I1P) - !<``` - !=> -1 <<< - character(*), intent(in) :: str !< String containing input number. - integer(I1P), intent(in) :: knd !< Number kind. - character(*), optional, intent(in) :: pref !< Prefixing string. - integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. - integer(I1P) :: n !< Number returned. - integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. - character(len=:), allocatable :: prefd !< Prefixing string. - - read (str, *, iostat=err) n ! Casting of str to n. - if (err /= 0) then - prefd = ''; if (present(pref)) prefd = pref - write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' - end if - if (present(error)) error = err -end function ctoi_I1P diff --git a/src/modules/PENF/src/STR.inc b/src/modules/PENF/src/STR.inc deleted file mode 100644 index 894fff6f3..000000000 --- a/src/modules/PENF/src/STR.inc +++ /dev/null @@ -1,1039 +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: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(fm=FR16P, n=1._R16P) -!``` - -elemental function strf_R16P(fm, n) result(str) - character(*), intent(in) :: fm - !! Format different from the standard for the kind. - real(R16P), intent(in) :: n - !! Real to be converted. - character(DR16P) :: str - !! Returned string containing input number. - - write (str, trim(fm)) n -end function strf_R16P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(fm=FR8P, n=1._R8P) -!``` - -elemental function strf_R8P(fm, n) result(str) - character(*), intent(in) :: fm - !! Format different from the standard for the kind. - real(R8P), intent(in) :: n - !! Real to be converted. - character(DR8P) :: str - !! Returned string containing input number. - write (str, trim(fm)) n -end function strf_R8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(fm=FR4P, n=1._R4P) -!``` - -elemental function strf_R4P(fm, n) result(str) - character(*), intent(in) :: fm - !! Format different from the standard for the kind. - real(R4P), intent(in) :: n - !! Real to be converted. - character(DR4P) :: str - !! Returned string containing input number. - write (str, trim(fm)) n -end function strf_R4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(fm=FI8P, n=1_I8P) -!``` - -elemental function strf_I8P(fm, n) result(str) - character(*), intent(in) :: fm - !! Format different from the standard for the kind. - integer(I8P), intent(in) :: n - !! Integer to be converted. - character(DI8P) :: str - !! Returned string containing input number. - write (str, trim(fm)) n -end function strf_I8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(fm=FI4P, n=1_I4P) -!``` - -elemental function strf_I4P(fm, n) result(str) - character(*), intent(in) :: fm - !! Format different from the standard for the kind. - integer(I4P), intent(in) :: n - !! Integer to be converted. - character(DI4P) :: str - !! Returned string containing input number. - write (str, trim(fm)) n -end function strf_I4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(fm=FI2P, n=1_I2P) -!``` - -elemental function strf_I2P(fm, n) result(str) - character(*), intent(in) :: fm - !! Format different from the standard for the kind. - integer(I2P), intent(in) :: n - !! Integer to be converted. - character(DI2P) :: str - !! Returned string containing input number. - write (str, trim(fm)) n -end function strf_I2P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(fm=FI1P, n=1_I1P) -!``` - -elemental function strf_I1P(fm, n) result(str) - character(*), intent(in) :: fm - !! Format different from the standard for the kind. - integer(I1P), intent(in) :: n - !! Integer to be converted. - character(DI1P) :: str - !! Returned string containing input number. - - write (str, trim(fm)) n -end function strf_I1P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(n=-1._R16P) -!``` -!=> -0.100000000000000000000000000000000E+0001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1._R16P, no_sign=.true.) -!``` -!=> 0.100000000000000000000000000000000E+0001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1._R16P, compact=.true.) -!``` - -elemental function str_R16P(n, no_sign, compact) result(str) - real(R16P), intent(in) :: n - !! Real to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - logical, intent(in), optional :: compact - !! Flag for *compacting* string encoding. - character(DR16P) :: str - !! Returned string containing input number. - !! - write (str, FR16P) n ! Casting of n to string. - !! - if (present(no_sign)) then - if (.not. no_sign) then - if (n > 0._R16P) str(1:1) = '+' ! Prefixing plus if n>0. - end if - end if - !! - if (present(compact)) then - if (compact) call compact_real_string(string=str) - end if - !! -end function str_R16P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=-1._R8P) -!``` -!=> -0.100000000000000E+001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1._R8P, no_sign=.true.) -!``` -!=> 0.100000000000000E+001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1._R8P, compact=.true.) -!``` - -elemental function str_R8P(n, no_sign, compact) result(str) - real(R8P), intent(in) :: n - !! Real to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - logical, intent(in), optional :: compact - !! Flag for *compacting* string encoding. - character(DR8P) :: str - !! Returned string containing input number. - !! - write (str, FR8P) n ! Casting of n to string. - !! - if (present(no_sign)) then - if (.not. no_sign) then - if (n > 0._R8P) str(1:1) = '+' ! Prefixing plus if n>0. - end if - end if - !! - if (present(compact)) then - if (compact) call compact_real_string(string=str) - end if -end function str_R8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=-1._R4P) -!``` -!=> -0.100000E+01 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1._R4P, no_sign=.true.) -!``` -!=> 0.100000E+01 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1._R4P, compact=.true.) -!``` - -elemental function str_R4P(n, no_sign, compact) result(str) - real(R4P), intent(in) :: n - !! Real to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - logical, intent(in), optional :: compact - !! Flag for *compacting* string encoding. - character(DR4P) :: str - !! Returned string containing input number. - !! - write (str, FR4P) n ! Casting of n to string. - !! - if (present(no_sign)) then - if (.not. no_sign) then - if (n > 0._R4P) str(1:1) = '+' ! Prefixing plus if n>0. - end if - end if - !! - if (present(compact)) then - if (compact) call compact_real_string(string=str) - end if -end function str_R4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=-1_I8P) -!``` -!=> -1 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1_I8P, no_sign=.true.) -!``` - -elemental function str_I8P(n, no_sign) result(str) - integer(I8P), intent(in) :: n - !! Integer to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(DI8P) :: str - !! Returned string containing input number plus padding zeros. - - write (str, FI8P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - !! - if (present(no_sign)) then - if (.not. no_sign) then - if (n >= 0_I8P) str = '+'//trim(str) ! Prefixing plus if n>0. - end if - end if - !! -end function str_I8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Converting integer to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(n=-1_I4P) -!``` -!=> -1 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1_I4P, no_sign=.true.) -!``` -!=> 1 <<< - -elemental function str_I4P(n, no_sign) result(str) - integer(I4P), intent(in) :: n - !! Integer to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(DI4P) :: str - !! Returned string containing input number plus padding zeros. - !! - write (str, FI4P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - !! - if (present(no_sign)) then - if (.not. no_sign) then - if (n >= 0_I4P) str = '+'//trim(str) ! Prefixing plus if n>0. - end if - end if - !! -end function str_I4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=-1_I2P) -!``` -!=> -1 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1_I2P, no_sign=.true.) -!``` -!=> 1 <<< - -elemental function str_I2P(n, no_sign) result(str) - integer(I2P), intent(in) :: n - !! Integer to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(DI2P) :: str - !! Returned string containing input number plus padding zeros. - - write (str, FI2P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - !! - if (present(no_sign)) then - if (.not. no_sign) then - if (n >= 0_I2P) str = '+'//trim(str) ! Prefixing plus if n>0. - end if - end if - !! -end function str_I2P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(n=-1_I1P) -!``` -!=> -1 <<< -! -!```fortran -! use penf -! print "(A)", str(n=-1_I1P, no_sign=.true.) -!``` -!=> 1 <<< - -elemental function str_I1P(n, no_sign) result(str) - integer(I1P), intent(in) :: n - !! Integer to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(DI1P) :: str - !! Returned string containing input number plus padding zeros. - - write (str, FI1P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - !! - if (present(no_sign)) then - if (.not. no_sign) then - if (n >= 0_I1P) str = '+'//trim(str) ! Prefixing plus if n>0. - end if - end if - !! -end function str_I1P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert logical to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(n=.true.) -!``` -!=> T <<< - -elemental function str_bol(n) result(str) - logical, intent(in) :: n - !! Logical to be converted. - character(1) :: str - !! Returned string containing input number plus padding zeros. - - write (str, '(L1)') n -end function str_bol - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Converting real array to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=[1._R16P, -2._R16P]) -!``` -!=> +0.100000000000000000000000000000000E+0001, -! -0.200000000000000000000000000000000E+0001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R16P, 2._R16P], no_sign=.true.) -!``` -!=> 0.100000000000000000000000000000000E+0001, -! 0.200000000000000000000000000000000E+0001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R16P, -2._R16P], separator='|') -!``` -!=> +0.100000000000000000000000000000000E+0001| -! -0.200000000000000000000000000000000E+0001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R16P, -2._R16P], delimiters=['(', ')']) -!``` -!=> (+0.100000000000000000000000000000000E+0001, -! -0.200000000000000000000000000000000E+0001) <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R16P, -2._R16P], compact=.true.) -!``` -!=> +0.1E+1,-0.2E+1 <<< - -pure function str_a_R16P(n, no_sign, separator, delimiters, compact) & - & result(str) - real(R16P), intent(in) :: n(:) - !! Real array to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(1), intent(in), optional :: separator - !! Eventual separator of array values. - character(*), intent(in), optional :: delimiters(1:2) - !! Eventual delimiters of array values. - logical, intent(in), optional :: compact - !! Flag for *compacting* string encoding. - character(len=:), allocatable :: str - !! Returned string containing input number. - character(DR16P) :: strn - !! String containing of element of input array number. - character(len=1) :: sep - !! Array values separator - integer :: i - !! Counter. - !! - str = '' - sep = ',' - if (present(separator)) sep = separator - do i = 1, size(n) - strn = str_R16P(no_sign=no_sign, compact=compact, n=n(i)) - str = str//sep//trim(strn) - end do - str = trim(str(2:)) - if (present(delimiters)) str = delimiters(1)//str//delimiters(2) -end function str_a_R16P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real array to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(n=[1._R8P, -2._R8P]) -!``` -!=> +0.100000000000000E+001,-0.200000000000000E+001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R8P, 2._R8P], no_sign=.true.) -!``` -!=> 0.100000000000000E+001,0.200000000000000E+001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R8P, -2._R8P], separator='|') -!``` -!=> +0.100000000000000E+001|-0.200000000000000E+001 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R8P, -2._R8P], delimiters=['(', ')']) -!``` -!=> (+0.100000000000000E+001,-0.200000000000000E+001) <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R8P, -2._R8P], compact=.true.) -!``` -!=> +0.1E+1,-0.2E+1 <<< - -pure function str_a_R8P(n, no_sign, separator, delimiters, compact) & - & result(str) - real(R8P), intent(in) :: n(:) - !! Real array to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(1), intent(in), optional :: separator - !! Eventual separator of array values. - character(*), intent(in), optional :: delimiters(1:2) - !! Eventual delimiters of array values. - logical, intent(in), optional :: compact - !! Flag for *compacting* string encoding. - character(len=:), allocatable :: str - !! Returned string containing input number. - character(DR8P) :: strn - !! String containing of element of input array number. - character(len=1) :: sep - !! Array values separator - integer :: i - !! Counter. - str = '' - sep = ',' - if (present(separator)) sep = separator - do i = 1, size(n) - strn = str_R8P(no_sign=no_sign, compact=compact, n=n(i)) - str = str//sep//trim(strn) - end do - str = trim(str(2:)) - if (present(delimiters)) str = delimiters(1)//str//delimiters(2) -end function str_a_R8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert real array to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(n=[1._R4P, -2._R4P]) -!``` -!=> +0.100000E+01,-0.200000E+01 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R4P, 2._R4P], no_sign=.true.) -!``` -!=> 0.100000E+01,0.200000E+01 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R4P, -2._R4P], separator='|') -!``` -!=> +0.100000E+01|-0.200000E+01 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R4P, -2._R4P], delimiters=['(', ')']) -!``` -!=> (+0.100000E+01,-0.200000E+01) <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1._R4P, -2._R4P], compact=.true.) -!``` -!=> +0.1E+1,-0.2E+1 <<< - -pure function str_a_R4P(n, no_sign, separator, delimiters, compact) & - & result(str) - real(R4P), intent(in) :: n(:) - !! Real array to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(1), intent(in), optional :: separator - !! Eventual separator of array values. - character(*), intent(in), optional :: delimiters(1:2) - !! Eventual delimiters of array values. - logical, intent(in), optional :: compact - !! Flag for *compacting* string encoding. - character(len=:), allocatable :: str - !! Returned string containing input number. - character(DR4P) :: strn - !! String containing of element of input array number. - character(len=1) :: sep - !! Array values separator - integer :: i - !! Counter. - - str = '' - sep = ',' - if (present(separator)) sep = separator - do i = 1, size(n) - strn = str_R4P(no_sign=no_sign, compact=compact, n=n(i)) - str = str//sep//trim(strn) - end do - str = trim(str(2:)) - if (present(delimiters)) str = delimiters(1)//str//delimiters(2) -end function str_a_R4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer array to string. -! -!# Introduction -! -! -!```fortran -! use penf -! print "(A)", str(n=[1_I8P, -2_I8P]) -!``` -!=> +1,-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I8P, 2_I8P], no_sign=.true.) -!``` -!=> 1,2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I8P, -2_I8P], separator='|') -!``` -!=> +1|-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I8P, -2_I8P], delimiters=['(', ')']) -!``` -!=> (+1,-2) <<< - -pure function str_a_I8P(n, no_sign, separator, delimiters) result(str) - integer(I8P), intent(in) :: n(:) - !! Integer array to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(1), intent(in), optional :: separator - !! Eventual separator of array values. - character(*), intent(in), optional :: delimiters(1:2) - !! Eventual delimiters of array values. - character(len=:), allocatable :: str - !! Returned string containing input number. - character(DI8P) :: strn - !! String containing of element of input array number. - character(len=1) :: sep - !! Array values separator - integer :: i - !! Counter. - str = '' - sep = ',' - if (present(separator)) sep = separator - if (present(no_sign)) then - do i = 1, size(n) - strn = str_I8P(no_sign=no_sign, n=n(i)) - str = str//sep//trim(strn) - end do - else - do i = 1, size(n) - strn = str_I8P(n=n(i)) - str = str//sep//trim(strn) - end do - end if - str = trim(str(2:)) - if (present(delimiters)) str = delimiters(1)//str//delimiters(2) -end function str_a_I8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer array to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=[1_I4P, -2_I4P]) -!``` -!=> +1,-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I4P, 2_I4P], no_sign=.true.) -!``` -!=> 1,2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I4P, -2_I4P], separator='|') -!``` -!=> +1|-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I4P, -2_I4P], delimiters=['(', ')']) -!``` -!=> (+1,-2) <<< - -pure function str_a_I4P(n, no_sign, separator, delimiters) result(str) - integer(I4P), intent(in) :: n(:) - !! Integer array to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(1), intent(in), optional :: separator - !! Eventual separator of array values. - character(*), intent(in), optional :: delimiters(1:2) - !! Eventual delimiters of array values. - character(len=:), allocatable :: str - !! Returned string containing input number. - character(DI4P) :: strn - !! String containing of element of input array number. - character(len=1) :: sep - !! Array values separator - integer :: i - !! Counter. - !! - str = '' - sep = ',' - if (present(separator)) sep = separator - if (present(no_sign)) then - do i = 1, size(n) - strn = str_I4P(no_sign=no_sign, n=n(i)) - str = str//sep//trim(strn) - end do - else - do i = 1, size(n) - strn = str_I4P(n=n(i)) - str = str//sep//trim(strn) - end do - end if - str = trim(str(2:)) - if (present(delimiters)) str = delimiters(1)//str//delimiters(2) -end function str_a_I4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer array to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=[1_I2P, -2_I2P]) -!``` -!=> +1,-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I2P, 2_I2P], no_sign=.true.) -!``` -!=> 1,2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I2P, -2_I2P], separator='|') -!``` -!=> +1|-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I2P, -2_I2P], delimiters=['(', ')']) -!``` -!=> (+1,-2) <<< - -pure function str_a_I2P(n, no_sign, separator, delimiters) result(str) - integer(I2P), intent(in) :: n(:) - !! Integer array to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(1), intent(in), optional :: separator - !! Eventual separator of array values. - character(*), intent(in), optional :: delimiters(1:2) - !! Eventual delimiters of array values. - character(len=:), allocatable :: str - !! Returned string containing input number. - character(DI2P) :: strn - !! String containing of element of input array number. - character(len=1) :: sep - !! Array values separator - integer :: i - !! Counter. - !! - str = '' - sep = ',' - if (present(separator)) sep = separator - if (present(no_sign)) then - do i = 1, size(n) - strn = str_I2P(no_sign=no_sign, n=n(i)) - str = str//sep//trim(strn) - end do - else - do i = 1, size(n) - strn = str_I2P(n=n(i)) - str = str//sep//trim(strn) - end do - end if - str = trim(str(2:)) - if (present(delimiters)) str = delimiters(1)//str//delimiters(2) -end function str_a_I2P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: -! summary: Convert integer array to string. -! -!# Introduction -! -!```fortran -! use penf -! print "(A)", str(n=[1_I1P, -2_I1P]) -!``` -!=> +1,-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I1P, 2_I1P], no_sign=.true.) -!``` -!=> 1,2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I1P, -2_I1P], separator='|') -!``` -!=> +1|-2 <<< -! -!```fortran -! use penf -! print "(A)", str(n=[1_I1P, -2_I1P], delimiters=['(', ')']) -!``` -!=> (+1,-2) <<< - -pure function str_a_I1P(n, no_sign, separator, delimiters) result(str) - integer(I1P), intent(in) :: n(:) - !! Integer array to be converted. - logical, intent(in), optional :: no_sign - !! Flag for leaving out the sign. - character(1), intent(in), optional :: separator - !! Eventual separator of array values. - character(*), intent(in), optional :: delimiters(1:2) - !! Eventual delimiters of array values. - character(len=:), allocatable :: str - !! Returned string containing input number. - character(DI1P) :: strn - !! String containing of element of input array number. - character(len=1) :: sep - !! Array values separator - integer :: i - !! Counter. - - str = '' - sep = ',' - if (present(separator)) sep = separator - if (present(no_sign)) then - do i = 1, size(n) - strn = str_I1P(no_sign=no_sign, n=n(i)) - str = str//sep//trim(strn) - end do - else - do i = 1, size(n) - strn = str_I1P(n=n(i)) - str = str//sep//trim(strn) - end do - end if - str = trim(str(2:)) - if (present(delimiters)) str = delimiters(1)//str//delimiters(2) -end function str_a_I1P diff --git a/src/modules/PENF/src/STRZ.inc b/src/modules/PENF/src/STRZ.inc deleted file mode 100644 index c96591a15..000000000 --- a/src/modules/PENF/src/STRZ.inc +++ /dev/null @@ -1,108 +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 -! - -elemental function strz_I8P(n, nz_pad) result(str) - !< Converting integer to string, prefixing with the right number of zeros. - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I8P) - !<``` - !=> 0000000000000000001 <<< - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I8P, nz_pad=5) - !<``` - !=> 00001 <<< - integer(I8P), intent(in) :: n !< Integer to be converted. - integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. - character(DI8P) :: str !< Returned string containing input number plus padding zeros. - - write (str, FI8PZP) n ! Casting of n to string. - str = str(2:) ! Leaving out the sign. - if (present(nz_pad)) str = str(DI8P - nz_pad:DI8P - 1) ! Leaving out the extra zeros padding -end function strz_I8P - -elemental function strz_I4P(n, nz_pad) result(str) - !< Convert integer to string, prefixing with the right number of zeros. - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I4P) - !<``` - !=> 0000000001 <<< - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I4P, nz_pad=5) - !<``` - !=> 00001 <<< - integer(I4P), intent(in) :: n !< Integer to be converted. - integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. - character(DI4P) :: str !< Returned string containing input number plus padding zeros. - - write (str, FI4PZP) n ! Casting of n to string. - str = str(2:) ! Leaving out the sign. - if (present(nz_pad)) str = str(DI4P - nz_pad:DI4P - 1) ! Leaving out the extra zeros padding -end function strz_I4P - -elemental function strz_I2P(n, nz_pad) result(str) - !< Convert integer to string, prefixing with the right number of zeros. - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I2P) - !<``` - !=> 00001 <<< - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I2P, nz_pad=3) - !<``` - !=> 001 <<< - integer(I2P), intent(in) :: n !< Integer to be converted. - integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. - character(DI2P) :: str !< Returned string containing input number plus padding zeros. - - write (str, FI2PZP) n ! Casting of n to string. - str = str(2:) ! Leaving out the sign. - if (present(nz_pad)) str = str(DI2P - nz_pad:DI2P - 1) ! Leaving out the extra zeros padding -end function strz_I2P - -elemental function strz_I1P(n, nz_pad) result(str) - !< Convert integer to string, prefixing with the right number of zeros. - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I1P) - !<``` - !=> 001 <<< - !< - !<```fortran - !< use penf - !< print "(A)", strz(n=1_I1P, nz_pad=3) - !<``` - !=> 001 <<< - integer(I1P), intent(in) :: n !< Integer to be converted. - integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. - character(DI1P) :: str !< Returned string containing input number plus padding zeros. - - write (str, FI1PZP) n ! Casting of n to string. - str = str(2:) ! Leaving out the sign. - if (present(nz_pad)) str = str(DI1P - nz_pad:DI1P - 1) ! Leaving out the extra zeros padding -end function strz_I1P diff --git a/src/modules/PENF/src/STR_ASCII.inc b/src/modules/PENF/src/STR_ASCII.inc deleted file mode 100644 index bafc58c87..000000000 --- a/src/modules/PENF/src/STR_ASCII.inc +++ /dev/null @@ -1,68 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -pure function str_ascii_default(input) result(output) - !< Convert string of default kind to ASCII string. - !< - !<```fortran - !< use penf - !< character(len=:, kind=ASCII), allocatable :: string - !< string = str_ascii('I was DEFAULT kind, but now I am ASCII') - !< print "(A)", string - !<``` - !=> I was DEFAULT kind, but now I am ASCII <<< - character(len=*), intent(in) :: input !< Input string of default kind. - character(len=:, kind=ASCII), allocatable :: output !< Output string of ASCII kind. - - output = input -end function str_ascii_default - -pure function str_ascii_ascii(input) result(output) - !< Convert string of ASCII kind to ASCII string, just for convenience in sanitize strings. - !< - !<```fortran - !< use penf - !< character(len=:, kind=ASCII), allocatable :: string - !< string = str_ascii('I was ASCII kind and I am still ASCII') - !< print "(A)", string - !<``` - !=> I was ASCII kind and I am still ASCII <<< - character(len=*, kind=ASCII), intent(in) :: input !< Input string of ASCII kind. - character(len=:, kind=ASCII), allocatable :: output !< Output string of ASCII kind. - - output = input -end function str_ascii_ascii - -pure function str_ascii_ucs4(input) result(output) - !< Convert string of UCS4 kind to ASCII string. - !< - !<```fortran - !< use penf - !< character(len=:, kind=ASCII), allocatable :: string - !< string = str_ascii(UCS4_'I was UCS4 kind, but now I am ASCII') - !< print "(A)", string - !<``` - !=> I was UCS4 kind, but now I am ASCII <<< - character(len=*, kind=UCS4), intent(in) :: input !< Input string of UCS4 kind. - character(len=:, kind=ASCII), allocatable :: output !< Output string of ASCII kind. - - output = input -end function str_ascii_ucs4 diff --git a/src/modules/PENF/src/STR_UCS4.inc b/src/modules/PENF/src/STR_UCS4.inc deleted file mode 100644 index de028abf0..000000000 --- a/src/modules/PENF/src/STR_UCS4.inc +++ /dev/null @@ -1,68 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -pure function str_ucs4_default(input) result(output) - !< Convert string of default kind to UCS4 string. - !< - !<```fortran - !< use penf - !< character(len=:, kind=UCS4), allocatable :: string - !< string = str_ascii('I was DEFAULT kind, but now I am UCS4') - !< print "(A)", string - !<``` - !=> I was DEFAULT kind, but now I am UCS4 <<< - character(len=*), intent(in) :: input !< Input string of default kind. - character(len=:, kind=UCS4), allocatable :: output !< Output string of UCS4 kind. - - output = input -end function str_ucs4_default - -pure function str_ucs4_ascii(input) result(output) - !< Convert string of ASCII kind to UCS4 string. - !< - !<```fortran - !< use penf - !< character(len=:, kind=UCS4), allocatable :: string - !< string = str_ascii(ASCII_'I was ASCII kind, but now I am UCS4') - !< print "(A)", string - !<``` - !=> I was ASCII kind, but now I am UCS4 <<< - character(len=*, kind=ASCII), intent(in) :: input !< Input string of ASCII kind. - character(len=:, kind=UCS4), allocatable :: output !< Output string of UCS4 kind. - - output = input -end function str_ucs4_ascii - -pure function str_ucs4_ucs4(input) result(output) - !< Convert string of UCS4 kind to UCS4 string, just for convenience in sanitize strings. - !< - !<```fortran - !< use penf - !< character(len=:, kind=UCS4), allocatable :: string - !< string = str_ascii(UCS4_'I was UCS4 kind and I am still UCS4') - !< print "(A)", string - !<``` - !=> I was UCS4 kind and I am still UCS4 <<< - character(len=*, kind=UCS4), intent(in) :: input !< Input string of UCS4 kind. - character(len=:, kind=UCS4), allocatable :: output !< Output string of UCS4 kind. - - output = input -end function str_ucs4_ucs4 diff --git a/src/modules/PENF/src/penf.F90 b/src/modules/PENF/src/penf.F90 deleted file mode 100644 index 720764b20..000000000 --- a/src/modules/PENF/src/penf.F90 +++ /dev/null @@ -1,239 +0,0 @@ -!< Portability Environment for Fortran poor people. - -module penf -!< Portability Environment for Fortran poor people. -use penf_global_parameters_variables -#ifdef __INTEL_COMPILER -use penf_b_size -#else -use penf_b_size, only : bit_size, byte_size -#endif -use penf_stringify, only : str_ascii, str_ucs4, str, strz, cton, bstr, bcton - -implicit none -private -save -! global parameters and variables -public :: endianL, endianB, endian, is_initialized -public :: ASCII, UCS4, CK -public :: R16P, FR16P, DR16P, MinR16P, MaxR16P, BIR16P, BYR16P, smallR16P, ZeroR16P -public :: R8P, FR8P, DR8P, MinR8P, MaxR8P, BIR8P, BYR8P, smallR8P, ZeroR8P -public :: R4P, FR4P, DR4P, MinR4P, MaxR4P, BIR4P, BYR4P, smallR4P, ZeroR4P -public :: R_P, FR_P, DR_P, MinR_P, MaxR_P, BIR_P, BYR_P, smallR_P, ZeroR_P -public :: I8P, FI8P, DI8P, MinI8P, MaxI8P, BII8P, BYI8P -public :: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P -public :: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P -public :: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P -public :: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P -public :: CHARACTER_KINDS_LIST, REAL_KINDS_LIST, REAL_FORMATS_LIST -public :: INTEGER_KINDS_LIST, INTEGER_FORMATS_LIST -! bit/byte size functions -public :: bit_size, byte_size -! stringify facility -public :: str_ascii, str_ucs4 -public :: str, strz, cton -public :: bstr, bcton -! miscellanea facility -public :: check_endian -public :: digit -public :: penf_Init -public :: penf_print - -integer, protected :: endian = endianL !< Bit ordering: Little endian (endianL), or Big endian (endianB). -logical, protected :: is_initialized = .false. !< Check the initialization of some variables that must be initialized. - -#ifdef __GFORTRAN__ -! work-around for strange gfortran bug... -interface bit_size - !< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables. -endinterface -#endif - -interface digit - !< Compute the number of digits in decimal base of the input integer. - module procedure digit_I8, digit_I4, digit_I2, digit_I1 -endinterface - -contains - ! public procedures - subroutine check_endian() - !< Check the type of bit ordering (big or little endian) of the running architecture. - !< - !> @note The result is stored into the *endian* global variable. - !< - !<```fortran - !< use penf - !< call check_endian - !< print *, endian - !<``` - !=> 1 <<< - if (is_little_endian()) then - endian = endianL - else - endian = endianB - endif - contains - pure function is_little_endian() result(is_little) - !< Check if the type of the bit ordering of the running architecture is little endian. - logical :: is_little !< Logical output: true is the running architecture uses little endian ordering, false otherwise. - integer(I1P) :: int1(1:4) !< One byte integer array for casting 4 bytes integer. - - int1 = transfer(1_I4P, int1) - is_little = (int1(1)==1_I1P) - endfunction is_little_endian - endsubroutine check_endian - - subroutine penf_init() - !< Initialize PENF's variables that are not initialized into the definition specification. - !< - !<```fortran - !< use penf - !< call penf_init - !< print FI1P, BYR4P - !<``` - !=> 4 <<< - - call check_endian - is_initialized = .true. - endsubroutine penf_init - - subroutine penf_print(unit, pref, iostat, iomsg) - !< Print to the specified unit the PENF's environment data. - !< - !<```fortran - !< use penf - !< integer :: u - !< open(newunit=u, status='scratch') - !< call penf_print(u) - !< close(u) - !< print "(A)", 'done' - !<``` - !=> done <<< - integer(I4P), intent(in) :: unit !< Logic unit. - character(*), intent(in), optional :: pref !< Prefixing string. - integer(I4P), intent(out), optional :: iostat !< IO error. - character(*), intent(out), optional :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - - if (.not.is_initialized) call penf_init - prefd = '' ; if (present(pref)) prefd = pref - if (endian==endianL) then - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has LITTLE Endian bit ordering' - else - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has BIG Endian bit ordering' - endif - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Character kind:' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ASCII: '//str(n=ASCII) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' UCS4: '//str(n=UCS4) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' CK: '//str(n=CK) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Reals kind, format and characters number:' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R16P: '//str(n=R16P)//','//FR16P//','//str(n=DR16P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R8P: '//str(n=R8P )//','//FR8P //','//str(n=DR8P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R4P: '//str(n=R4P )//','//FR4P //','//str(n=DR4P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R_P: '//str(n=R_P )//','//FR_P //','//str(n=DR_P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Integers kind, format and characters number:' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I8P: '//str(n=I8P)//','//FI8P //','//str(n=DI8P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I4P: '//str(n=I4P)//','//FI4P //','//str(n=DI4P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I2P: '//str(n=I2P)//','//FI2P //','//str(n=DI2P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I1P: '//str(n=I1P)//','//FI1P //','//str(n=DI1P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Reals minimum and maximum values:' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R16P: '//str(n=MinR16P)//','//str(n=MaxR16P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R8P: '//str(n=MinR8P )//','//str(n=MaxR8P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R4P: '//str(n=MinR4P )//','//str(n=MaxR4P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R_P: '//str(n=MinR_P )//','//str(n=MaxR_P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Integergs minimum and maximum values:' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I8P: '//str(n=MinI8P )//','//str(n=MaxI8P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I4P: '//str(n=MinI4P )//','//str(n=MaxI4P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I2P: '//str(n=MinI2P )//','//str(n=MaxI2P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I1P: '//str(n=MinI1P )//','//str(n=MaxI1P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Reals bits/bytes sizes:' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R16P: '//str(n=BIR16P)//'/'//str(n=BYR16P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R8P: '//str(n=BIR8P )//'/'//str(n=BYR8P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R4P: '//str(n=BIR4P )//'/'//str(n=BYR4P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R_P: '//str(n=BIR_P )//'/'//str(n=BYR_P ) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Integers bits/bytes sizes:' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I8P: '//str(n=BII8P)//'/'//str(n=BYI8P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I4P: '//str(n=BII4P)//'/'//str(n=BYI4P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I2P: '//str(n=BII2P)//'/'//str(n=BYI2P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I1P: '//str(n=BII1P)//'/'//str(n=BYI1P) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Smallest reals' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR16P: '//str(smallR16P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR8P: '//str(smallR8P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR4P: '//str(smallR4P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR_P: '//str(smallR_P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Machine zero' - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR16P: '//str(ZeroR16P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR8P: '//str(ZeroR8P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR4P: '//str(ZeroR4P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR_P: '//str(ZeroR_P, .true.) - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - endsubroutine penf_print - - ! private procedures - elemental function digit_I8(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I8P) - !<``` - !=> 3 <<< - integer(I8P), intent(in) :: n !< Input integer. - character(DI8P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI8P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I8 - - elemental function digit_I4(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I4P) - !<``` - !=> 3 <<< - integer(I4P), intent(in) :: n !< Input integer. - character(DI4P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI4P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I4 - - elemental function digit_I2(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I2P) - !<``` - !=> 3 <<< - integer(I2P), intent(in) :: n !< Input integer. - character(DI2P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI2P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I2 - - elemental function digit_I1(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I1P) - !<``` - !=> 3 <<< - integer(I1P), intent(in) :: n !< Input integer. - character(DI1P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI1P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I1 -endmodule penf diff --git a/src/modules/PENF/src/penf_b_size.F90 b/src/modules/PENF/src/penf_b_size.F90 deleted file mode 100644 index 13054b874..000000000 --- a/src/modules/PENF/src/penf_b_size.F90 +++ /dev/null @@ -1,227 +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 -! - -!< PENF bit/byte size functions. - -module penf_b_size -!< PENF bit/byte size functions. -use penf_global_parameters_variables - -implicit none -private -save -public :: bit_size, byte_size - -interface bit_size - !< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables. - module procedure & -#if defined _R16P - bit_size_R16P, & -#endif - bit_size_R8P, & - bit_size_R4P, & - bit_size_chr -end interface - -interface byte_size - !< Compute the number of bytes of a variable. - module procedure & - byte_size_I8P, & - byte_size_I4P, & - byte_size_I2P, & - byte_size_I1P, & -#if defined _R16P - byte_size_R16P, & -#endif - byte_size_R8P, & - byte_size_R4P, & - byte_size_chr -end interface - -contains -elemental function bit_size_R16P(i) result(bits) - !< Compute the number of bits of a real variable. - !< - !<```fortran - !< use penf - !< print FI2P, bit_size(1._R16P) - !<``` - !=> 128 <<< - real(R16P), intent(in) :: i !< Real variable whose number of bits must be computed. - integer(I2P) :: bits !< Number of bits of r. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - - bits = size(transfer(i, mold), dim=1, kind=I2P) * 8_I2P -end function bit_size_R16P - -elemental function bit_size_R8P(i) result(bits) - !< Compute the number of bits of a real variable. - !< - !<```fortran - !< use penf - !< print FI1P, bit_size(1._R8P) - !<``` - !=> 64 <<< - real(R8P), intent(in) :: i !< Real variable whose number of bits must be computed. - integer(I1P) :: bits !< Number of bits of r. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - - bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P -end function bit_size_R8P - -elemental function bit_size_R4P(i) result(bits) - !< Compute the number of bits of a real variable. - !< - !<```fortran - !< use penf - !< print FI1P, bit_size(1._R4P) - !<``` - !=> 32 <<< - real(R4P), intent(in) :: i !< Real variable whose number of bits must be computed. - integer(I1P) :: bits !< Number of bits of r. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - - bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P -end function bit_size_R4P - -elemental function bit_size_chr(i) result(bits) - !< Compute the number of bits of a character variable. - !< - !<```fortran - !< use penf - !< print FI4P, bit_size('ab') - !<``` - !=> 16 <<< - character(*), intent(IN) :: i !< Character variable whose number of bits must be computed. - integer(I4P) :: bits !< Number of bits of c. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - - bits = size(transfer(i, mold), dim=1, kind=I4P) * 8_I4P -end function bit_size_chr - -elemental function byte_size_R16P(i) result(bytes) - !< Compute the number of bytes of a real variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size(1._R16P) - !<``` - !=> 16 <<< - real(R16P), intent(in) :: i !< Real variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of r. - - bytes = bit_size(i) / 8_I1P -end function byte_size_R16P - -elemental function byte_size_R8P(i) result(bytes) - !< Compute the number of bytes of a real variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size(1._R8P) - !<``` - !=> 8 <<< - real(R8P), intent(in) :: i !< Real variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of r. - - bytes = bit_size(i) / 8_I1P -end function byte_size_R8P - -elemental function byte_size_R4P(i) result(bytes) - !< Compute the number of bytes of a real variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size(1._R4P) - !<``` - !=> 4 <<< - real(R4P), intent(in) :: i !< Real variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of r. - - bytes = bit_size(i) / 8_I1P -end function byte_size_R4P - -elemental function byte_size_chr(i) result(bytes) - !< Compute the number of bytes of a character variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size('ab') - !<``` - !=> 2 <<< - character(*), intent(in) :: i !< Character variable whose number of bytes must be computed. - integer(I4P) :: bytes !< Number of bytes of c. - - bytes = bit_size(i) / 8_I4P -end function byte_size_chr - -elemental function byte_size_I8P(i) result(bytes) - !< Compute the number of bytes of an integer variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size(1_I8P) - !<``` - !=> 8 <<< - integer(I8P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. - - bytes = bit_size(i) / 8_I1P -end function byte_size_I8P - -elemental function byte_size_I4P(i) result(bytes) - !< Compute the number of bytes of an integer variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size(1_I4P) - !<``` - !=> 4 <<< - integer(I4P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. - - bytes = bit_size(i) / 8_I1P -end function byte_size_I4P - -elemental function byte_size_I2P(i) result(bytes) - !< Compute the number of bytes of an integer variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size(1_I2P) - !<``` - !=> 2 <<< - integer(I2P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. - - bytes = bit_size(i) / 8_I1P -end function byte_size_I2P - -elemental function byte_size_I1P(i) result(bytes) - !< Compute the number of bytes of an integer variable. - !< - !<```fortran - !< use penf - !< print FI1P, byte_size(1_I1P) - !<``` - !=> 1 <<< - integer(I1P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. - - bytes = bit_size(i) / 8_I1P -end function byte_size_I1P -endmodule penf_b_size diff --git a/src/modules/PENF/src/penf_global_parameters_variables.F90 b/src/modules/PENF/src/penf_global_parameters_variables.F90 deleted file mode 100644 index 356764dc9..000000000 --- a/src/modules/PENF/src/penf_global_parameters_variables.F90 +++ /dev/null @@ -1,213 +0,0 @@ -!< PENF global parameters and variables. - -module penf_global_parameters_variables -!< PENF global parameters and variables. -!< -!< @note All module defined entities are public. - -implicit none -public -save - -integer, parameter :: endianL = 1 !< Little endian parameter. -integer, parameter :: endianB = 0 !< Big endian parameter. - -! portable kind parameters -#ifdef _ASCII_SUPPORTED -integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind. -#else -integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind defined as default set. -#endif -#ifdef _UCS4_SUPPORTED -integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind. -#else -integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind defined as default set. -#endif -#if defined _CK_IS_DEFAULT -integer, parameter :: CK = selected_char_kind('default') !< Default kind character. -#elif defined _CK_IS_ASCII -integer, parameter :: CK = ASCII !< Default kind character. -#elif defined _CK_IS_UCS4 -integer, parameter :: CK = UCS4 !< Default kind character. -#else -integer, parameter :: CK = selected_char_kind('default') !< Default kind character. -#endif - -#if defined _R16P -integer, parameter :: R16P = selected_real_kind(33,4931) !< 33 digits, range \([10^{-4931}, 10^{+4931} - 1]\); 128 bits. -#else -integer, parameter :: R16P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. -#endif -integer, parameter :: R8P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. -integer, parameter :: R4P = selected_real_kind(6,37) !< 6 digits, range \([10^{-37} , 10^{+37} - 1]\); 32 bits. -#if defined _R16P -#if defined _R_P_IS_R16P -integer, parameter :: R_P = R16P !< Default real precision. -#endif -#endif -#if defined _R_P_IS_R8P -integer, parameter :: R_P = R8P !< Default real precision. -#elif defined _R_P_IS_R4P -integer, parameter :: R_P = R4P !< Default real precision. -#else -integer, parameter :: R_P = R8P !< Default real precision. -#endif - -integer, parameter :: I8P = selected_int_kind(18) !< Range \([-2^{63},+2^{63} - 1]\), 19 digits plus sign; 64 bits. -integer, parameter :: I4P = selected_int_kind(9) !< Range \([-2^{31},+2^{31} - 1]\), 10 digits plus sign; 32 bits. -integer, parameter :: I2P = selected_int_kind(4) !< Range \([-2^{15},+2^{15} - 1]\), 5 digits plus sign; 16 bits. -integer, parameter :: I1P = selected_int_kind(2) !< Range \([-2^{7} ,+2^{7} - 1]\), 3 digits plus sign; 8 bits. -integer, parameter :: I_P = I4P !< Default integer precision. - -! format parameters -#if defined _R16P -character(*), parameter :: FR16P = '(E42.33E4)' !< Output format for kind=R16P real. -#else -character(*), parameter :: FR16P = '(E23.15E3)' !< Output format for kind=R8P real. -#endif -character(*), parameter :: FR8P = '(E23.15E3)' !< Output format for kind=R8P real. -character(*), parameter :: FR4P = '(E13.6E2)' !< Output format for kind=R4P real. -#if defined _R16P -#if defined _R_P_IS_R16P -character(*), parameter :: FR_P = FR16P !< Output format for kind=R_P real. -#endif -#endif -#if defined _R_P_IS_R8P -character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real. -#elif defined _R_P_IS_R4P -character(*), parameter :: FR_P = FR4P !< Output format for kind=R_P real. -#else -character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real. -#endif - -character(*), parameter :: FI8P = '(I20)' !< Output format for kind=I8P integer. -character(*), parameter :: FI8PZP = '(I20.19)' !< Output format for kind=I8P integer with zero prefixing. -character(*), parameter :: FI4P = '(I11)' !< Output format for kind=I4P integer. -character(*), parameter :: FI4PZP = '(I11.10)' !< Output format for kind=I4P integer with zero prefixing. -character(*), parameter :: FI2P = '(I6)' !< Output format for kind=I2P integer. -character(*), parameter :: FI2PZP = '(I6.5)' !< Output format for kind=I2P integer with zero prefixing. -character(*), parameter :: FI1P = '(I4)' !< Output format for kind=I1P integer. -character(*), parameter :: FI1PZP = '(I4.3)' !< Output format for kind=I1P integer with zero prefixing. -character(*), parameter :: FI_P = FI4P !< Output format for kind=I_P integer. -character(*), parameter :: FI_PZP = FI4PZP !< Output format for kind=I_P integer with zero prefixing. - -! length (number of digits) of formatted numbers -#if defined _R16P -integer, parameter :: DR16P = 42 !< Number of digits of output format FR16P. -#else -integer, parameter :: DR16P = 23 !< Number of digits of output format FR8P. -#endif -integer, parameter :: DR8P = 23 !< Number of digits of output format FR8P. -integer, parameter :: DR4P = 13 !< Number of digits of output format FR4P. -#if defined _R16P -#if defined _R_P_IS_R16P -integer, parameter :: DR_P = DR16P !< Number of digits of output format FR_P. -#endif -#endif -#if defined _R_P_IS_R8P -integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P. -#elif defined _R_P_IS_R4P -integer, parameter :: DR_P = DR4P !< Number of digits of output format FR_P. -#else -integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P. -#endif - -integer, parameter :: DI8P = 20 !< Number of digits of output format I8P. -integer, parameter :: DI4P = 11 !< Number of digits of output format I4P. -integer, parameter :: DI2P = 6 !< Number of digits of output format I2P. -integer, parameter :: DI1P = 4 !< Number of digits of output format I1P. -integer, parameter :: DI_P = DI4P !< Number of digits of output format I_P. - -! list of kinds -integer, parameter :: CHARACTER_KINDS_LIST(1:3) = [ASCII, UCS4, CK] !< List of character kinds. -#if defined _R16P -integer, parameter :: REAL_KINDS_LIST(1:4) = [R16P, R8P, R4P, R_P] !< List of real kinds. -#else -integer, parameter :: REAL_KINDS_LIST(1:3) = [R8P, R4P, R_P] !< List of real kinds. -#endif -#if defined _R16P -character(*), parameter :: REAL_FORMATS_LIST(1:4) = [FR16P, FR8P, FR4P//' ', FR_P] !< List of real formats. -#else -character(*), parameter :: REAL_FORMATS_LIST(1:3) = [FR8P, FR4P//' ', FR_P] !< List of real formats. -#endif -integer, parameter :: INTEGER_KINDS_LIST(1:5) = [I8P, I4P, I2P, I1P,I_P] !< List of integer kinds. -character(*), parameter :: INTEGER_FORMATS_LIST(1:5) = [FI8P, FI4P, FI2P//' ', FI1P//' ', FI_P] !< List of integer formats. - -! minimum and maximum (representable) values -#if defined _R16P -real(R16P), parameter :: MinR16P = -huge(1._R16P) !< Minimum value of kind=R16P real. -real(R16P), parameter :: MaxR16P = huge(1._R16P) !< Maximum value of kind=R16P real. -#else -real(R8P), parameter :: MinR16P = -huge(1._R8P ) !< Minimum value of kind=R8P real. -real(R8P), parameter :: MaxR16P = huge(1._R8P ) !< Maximum value of kind=R8P real. -#endif -real(R8P), parameter :: MinR8P = -huge(1._R8P ) !< Minimum value of kind=R8P real. -real(R8P), parameter :: MaxR8P = huge(1._R8P ) !< Maximum value of kind=R8P real. -real(R4P), parameter :: MinR4P = -huge(1._R4P ) !< Minimum value of kind=R4P real. -real(R4P), parameter :: MaxR4P = huge(1._R4P ) !< Maximum value of kind=R4P real. -real(R_P), parameter :: MinR_P = -huge(1._R_P ) !< Minimum value of kind=R_P real. -real(R_P), parameter :: MaxR_P = huge(1._R_P ) !< Maximum value of kind=R_P real. -integer(I8P), parameter :: MinI8P = -huge(1_I8P) !< Minimum value of kind=I8P integer. -integer(I4P), parameter :: MinI4P = -huge(1_I4P) !< Minimum value of kind=I4P integer. -integer(I2P), parameter :: MinI2P = -huge(1_I2P) !< Minimum value of kind=I2P integer. -integer(I1P), parameter :: MinI1P = -huge(1_I1P) !< Minimum value of kind=I1P integer. -integer(I_P), parameter :: MinI_P = -huge(1_I_P) !< Minimum value of kind=I_P integer. -integer(I8P), parameter :: MaxI8P = huge(1_I8P) !< Maximum value of kind=I8P integer. -integer(I4P), parameter :: MaxI4P = huge(1_I4P) !< Maximum value of kind=I4P integer. -integer(I2P), parameter :: MaxI2P = huge(1_I2P) !< Maximum value of kind=I2P integer. -integer(I1P), parameter :: MaxI1P = huge(1_I1P) !< Maximum value of kind=I1P integer. -integer(I_P), parameter :: MaxI_P = huge(1_I_P) !< Maximum value of kind=I_P integer. - -! real smallest (representable) values -#if defined _R16P -real(R16P), parameter :: smallR16P = tiny(1._R16P) !< Smallest representable value of kind=R16P real. -#else -real(R8P), parameter :: smallR16P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real. -#endif -real(R8P), parameter :: smallR8P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real. -real(R4P), parameter :: smallR4P = tiny(1._R4P ) !< Smallest representable value of kind=R4P real. -real(R_P), parameter :: smallR_P = tiny(1._R_P ) !< Smallest representable value of kind=R_P real. - -! smallest real representable difference by the running calculator -#if defined _R16P -real(R16P), parameter :: ZeroR16P = nearest(1._R16P, 1._R16P) - & - nearest(1._R16P,-1._R16P) !< Smallest representable difference of kind=R16P real. -#else -real(R8P), parameter :: ZeroR16P = 0._R8P !nearest(1._R8P, 1._R8P) - & - !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. -#endif -real(R8P), parameter :: ZeroR8P = 0._R8P !nearest(1._R8P, 1._R8P) - & - !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. -real(R4P), parameter :: ZeroR4P = 0._R4P !nearest(1._R4P, 1._R4P) - & - !nearest(1._R4P,-1._R4P) !< Smallest representable difference of kind=R4P real. -real(R_P), parameter :: ZeroR_P = 0._R_P !nearest(1._R_P, 1._R_P) - & - !nearest(1._R_P,-1._R_P) !< Smallest representable difference of kind=R_P real. - -! bits/bytes memory requirements -#if defined _R16P -integer(I2P), parameter :: BIR16P = storage_size(MaxR16P) !< Number of bits of kind=R16P real. -#else -integer(I1P), parameter :: BIR16P = storage_size(MaxR8P) !< Number of bits of kind=R8P real. -#endif -integer(I1P), parameter :: BIR8P = storage_size(MaxR8P) !< Number of bits of kind=R8P real. -integer(I1P), parameter :: BIR4P = storage_size(MaxR4P) !< Number of bits of kind=R4P real. -integer(I1P), parameter :: BIR_P = storage_size(MaxR_P) !< Number of bits of kind=R_P real. -#if defined _R16P -integer(I2P), parameter :: BYR16P = BIR16P/8_I2P !< Number of bytes of kind=R16P real. -#else -integer(I1P), parameter :: BYR16P = BIR8P/8_I1P !< Number of bytes of kind=R8P real. -#endif -integer(I1P), parameter :: BYR8P = BIR8P/8_I1P !< Number of bytes of kind=R8P real. -integer(I1P), parameter :: BYR4P = BIR4P/8_I1P !< Number of bytes of kind=R4P real. -integer(I1P), parameter :: BYR_P = BIR_P/8_I1P !< Number of bytes of kind=R_P real. -integer(I8P), parameter :: BII8P = storage_size(MaxI8P) !< Number of bits of kind=I8P integer. -integer(I4P), parameter :: BII4P = storage_size(MaxI4P) !< Number of bits of kind=I4P integer. -integer(I2P), parameter :: BII2P = storage_size(MaxI2P) !< Number of bits of kind=I2P integer. -integer(I1P), parameter :: BII1P = storage_size(MaxI1P) !< Number of bits of kind=I1P integer. -integer(I_P), parameter :: BII_P = storage_size(MaxI_P) !< Number of bits of kind=I_P integer. -integer(I8P), parameter :: BYI8P = BII8P/8_I8P !< Number of bytes of kind=I8P integer. -integer(I4P), parameter :: BYI4P = BII4P/8_I4P !< Number of bytes of kind=I4P integer. -integer(I2P), parameter :: BYI2P = BII2P/8_I2P !< Number of bytes of kind=I2P integer. -integer(I1P), parameter :: BYI1P = BII1P/8_I1P !< Number of bytes of kind=I1P integer. -integer(I_P), parameter :: BYI_P = BII_P/8_I_P !< Number of bytes of kind=I_P integer. -endmodule penf_global_parameters_variables diff --git a/src/modules/PENF/src/penf_stringify.F90 b/src/modules/PENF/src/penf_stringify.F90 deleted file mode 100644 index 979db78d1..000000000 --- a/src/modules/PENF/src/penf_stringify.F90 +++ /dev/null @@ -1,193 +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: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: PENF string-to-number (and viceversa) facility. - -MODULE PENF_STRINGIFY -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: stderr => error_unit -USE PENF_B_SIZE -USE PENF_GLOBAL_PARAMETERS_VARIABLES -IMPLICIT NONE -PRIVATE -SAVE -PUBLIC :: STR_ASCII, STR_UCS4 -PUBLIC :: STR, STRZ, CTON -PUBLIC :: BSTR, BCTON - -!---------------------------------------------------------------------------- -! STR_ASCII -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: Convert string of any kind to ASCII string. - -INTERFACE STR_ASCII - MODULE PROCEDURE str_ascii_default -#if defined _ASCII_SUPPORTED && defined _ASCII_NEQ_DEFAULT - MODULE PROCEDURE str_ascii_ascii -#endif -#ifdef _UCS4_SUPPORTED - MODULE PROCEDURE STR_ASCII_UCS4 -#endif -END INTERFACE STR_ASCII - -!---------------------------------------------------------------------------- -! STR_UCS4 -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: Convert string of any kind to UCS4 string. - -INTERFACE STR_UCS4 - MODULE PROCEDURE str_ucs4_default -#if defined _ASCII_SUPPORTED && defined _ASCII_NEQ_DEFAULT - MODULE PROCEDURE str_ucs4_ascii -#endif -#ifdef _UCS4_SUPPORTED - MODULE PROCEDURE str_ucs4_ucs4 -#endif -END INTERFACE - -!---------------------------------------------------------------------------- -! STR -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: Convert number (real and integer) to string (number to string type -! casting). - -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 -#ifdef _R16P - MODULE PROCEDURE strf_R16P, str_R16P, str_a_R16P -#endif -END INTERFACE STR - -!---------------------------------------------------------------------------- -! STRZ -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: Convert integer, to string, prefixing with the right number of -! zeros (integer to string type casting with zero padding). - -INTERFACE STRZ - MODULE PROCEDURE strz_I8P, strz_I4P, strz_I2P, strz_I1P -END INTERFACE - -!---------------------------------------------------------------------------- -! CTON -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: Convert string to number (real and integer, string to number type -! casting). - -INTERFACE CTON - MODULE PROCEDURE & - ctor_R8P, & - ctor_R4P, & - ctoi_I8P, & - ctoi_I4P, & - ctoi_I2P, & - ctoi_I1P -#if defined _R16P - MODULE PROCEDURE ctor_R16P -#endif -END INTERFACE - -!---------------------------------------------------------------------------- -! BSTR -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: Convert number (real and integer) to bit-string (number to -! bit-string type casting). - -INTERFACE BSTR - MODULE PROCEDURE & - & bstr_R8P, & - & bstr_R4P, & - & bstr_I8P, & - & bstr_I4P, & - & bstr_I2P, & - & bstr_I1P - -#if defined _R16P - MODULE PROCEDURE bstr_R16P -#endif -END INTERFACE - -!---------------------------------------------------------------------------- -! BCTON -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 22 July 2022 -! summary: Convert bit-string to number (real and integer, bit-string to -! number type casting). -INTERFACE BCTON - MODULE PROCEDURE & - & bctor_R8P, & - & bctor_R4P, & - & bctoi_I8P, & - & bctoi_I4P, & - & bctoi_I2P, & - & bctoi_I1P -#if defined _R16P - MODULE PROCEDURE bctor_R16P -#endif - -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -#include "./STR_ASCII.inc" -#include "./STR_UCS4.inc" -#include "./STR.inc" -#include "./COMPACT_REAL_STRING.inc" -#include "./STRZ.inc" -#include "./CTOA.inc" -#include "./BSTR.inc" -#include "./BCTON.inc" - -ENDMODULE PENF_STRINGIFY diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt deleted file mode 100644 index 86560150e..000000000 --- a/src/modules/Polynomial/CMakeLists.txt +++ /dev/null @@ -1,39 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/InterpolationUtility.F90 - ${src_path}/LagrangePolynomialUtility.F90 - ${src_path}/OrthogonalPolynomialUtility.F90 - ${src_path}/JacobiPolynomialUtility.F90 - ${src_path}/UltrasphericalPolynomialUtility.F90 - ${src_path}/LegendrePolynomialUtility.F90 - ${src_path}/LobattoPolynomialUtility.F90 - ${src_path}/UnscaledLobattoPolynomialUtility.F90 - ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/LineInterpolationUtility.F90 - ${src_path}/TriangleInterpolationUtility.F90 - ${src_path}/QuadrangleInterpolationUtility.F90 - ${src_path}/TetrahedronInterpolationUtility.F90 - ${src_path}/HexahedronInterpolationUtility.F90 - ${src_path}/PrismInterpolationUtility.F90 - ${src_path}/PyramidInterpolationUtility.F90 - ${src_path}/RecursiveNodesUtility.F90 - ${src_path}/PolynomialUtility.F90 -) \ No newline at end of file diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 deleted file mode 100644 index 10bfc0a0c..000000000 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ /dev/null @@ -1,1098 +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 Chebyshev1PolynomialUtility -USE GlobalData -USE BaseType, ONLY: iface_1DFunction -IMPLICIT NONE -PUBLIC :: Chebyshev1Alpha -PUBLIC :: Chebyshev1Beta -PUBLIC :: GetChebyshev1RecurrenceCoeff -PUBLIC :: GetChebyshev1RecurrenceCoeff2 -PUBLIC :: Chebyshev1LeadingCoeff -PUBLIC :: Chebyshev1LeadingCoeffRatio -PUBLIC :: Chebyshev1NormSQR -PUBLIC :: Chebyshev1NormSQR2 -PUBLIC :: Chebyshev1NormSQRRatio -PUBLIC :: Chebyshev1JacobiMatrix -PUBLIC :: Chebyshev1GaussQuadrature -PUBLIC :: Chebyshev1JacobiRadauMatrix -PUBLIC :: Chebyshev1GaussRadauQuadrature -PUBLIC :: Chebyshev1JacobiLobattoMatrix -PUBLIC :: Chebyshev1GaussLobattoQuadrature -PUBLIC :: Chebyshev1Zeros -PUBLIC :: Chebyshev1Quadrature -PUBLIC :: Chebyshev1Eval -PUBLIC :: Chebyshev1EvalAll -PUBLIC :: Chebyshev1MonomialExpansionAll -PUBLIC :: Chebyshev1MonomialExpansion -PUBLIC :: Chebyshev1GradientEvalAll -PUBLIC :: Chebyshev1GradientEval -PUBLIC :: Chebyshev1EvalSum -PUBLIC :: Chebyshev1GradientEvalSum -PUBLIC :: Chebyshev1Transform -PUBLIC :: Chebyshev1InvTransform -PUBLIC :: Chebyshev1GradientCoeff -PUBLIC :: Chebyshev1DMatrix -PUBLIC :: Chebyshev1DMatEvenOdd - -!---------------------------------------------------------------------------- -! Chebyshev1Alpha -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Recurrence coefficient, beta, of Chebyshev1 polynomial - -INTERFACE - MODULE PURE FUNCTION Chebyshev1Alpha(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev1 polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION Chebyshev1Alpha -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1Beta -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Recurrence coefficient, beta, of Chebyshev1 polynomial - -INTERFACE - MODULE PURE FUNCTION Chebyshev1Beta(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev1 polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION Chebyshev1Beta -END INTERFACE - -!---------------------------------------------------------------------------- -! GetChebyshev1RecurrenceCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Return the recurrence coefficient for nth order Chebyshev1 -! polynomial -! -! -!# Introduction -! -! These recurrence coefficients are for monic jacobi polynomials. - -INTERFACE - MODULE PURE SUBROUTINE GetChebyshev1RecurrenceCoeff(n, alphaCoeff, & - & betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) - REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) - END SUBROUTINE GetChebyshev1RecurrenceCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! GetChebyshev1RecurrenceCoeff2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Return the recurrence coefficient for nth order Chebyshev1 -! polynomial -! -! -!# Introduction -! -! These recurrence coefficients are for monic jacobi polynomials. - -INTERFACE - MODULE PURE SUBROUTINE GetChebyshev1RecurrenceCoeff2(n, A, B, C) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(OUT) :: A(0:n - 1) - !! size is n - REAL(DFP), INTENT(OUT) :: B(0:n - 1) - !! this coefficient is zero - REAL(DFP), INTENT(OUT) :: C(0:n - 1) - !! size is n - END SUBROUTINE GetChebyshev1RecurrenceCoeff2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1LeadingCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Leading coefficient of Chebyshev1 polynomial - -INTERFACE - MODULE PURE FUNCTION Chebyshev1LeadingCoeff(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev1 polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION Chebyshev1LeadingCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1LeadingCoeffRatio -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct 2022 -! summary: Ratio of leading coefficients, kn+1/kn - -INTERFACE - MODULE PURE FUNCTION Chebyshev1LeadingCoeffRatio(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev1 polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION Chebyshev1LeadingCoeffRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1NormSQR -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Square norm of Chebyshev1 polynomial - -INTERFACE - MODULE PURE FUNCTION Chebyshev1NormSQR(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans - END FUNCTION Chebyshev1NormSQR -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1NormSQR2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Square norm of Chebyshev1 polynomial - -INTERFACE - MODULE PURE FUNCTION Chebyshev1NormSQR2(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(0:n) - END FUNCTION Chebyshev1NormSQR2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1NormSQRRatio -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Ratio of Square norm of Chebyshev1 polynomial, n+1/n - -INTERFACE - MODULE PURE FUNCTION Chebyshev1NormSQRRatio(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans - END FUNCTION Chebyshev1NormSQRRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1JacobiMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct 2022 -! summary: Return the Jacobi matrix for Chebyshev polynomial - -INTERFACE - MODULE PURE SUBROUTINE Chebyshev1JacobiMatrix(n, D, E, & - & alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n-1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - !! recurrence coefficient of monic Chebyshev polynomial, from 0 to n-1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - !! recurrence coefficient of monic Chebyshev polynomial, from 0 to n-1 - END SUBROUTINE Chebyshev1JacobiMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1GaussQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct 2022 -! summary: Return the Jacobi matrix for Chebyshev polynomial - -INTERFACE - MODULE SUBROUTINE Chebyshev1GaussQuadrature(n, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev polynomial. - REAL(DFP), INTENT(OUT) :: pt(:) - !! the size is 1 to n - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! the size is 1 to n - END SUBROUTINE Chebyshev1GaussQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1JacobiRadauMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct 2022 -! summary: Return the Jacobi-Radau matrix for Chebyshev polynomial - -INTERFACE - MODULE PURE SUBROUTINE Chebyshev1JacobiRadauMatrix(a, n, D, E, alphaCoeff, & - & betaCoeff) - REAL(DFP), INTENT(IN) :: a - !! one of the end of the domain - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial. - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+1 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE Chebyshev1JacobiRadauMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1GaussRadauQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the GaussRadau quadrature points for Chebyshev1 Polynomial - -INTERFACE - MODULE SUBROUTINE Chebyshev1GaussRadauQuadrature(a, n, pt, wt) - REAL(DFP), INTENT(IN) :: a - !! +1.0 or -1.0 - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev polynomial - REAL(DFP), INTENT(OUT) :: pt(:) - !! the size is 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! the size is 1 to n+1 - END SUBROUTINE Chebyshev1GaussRadauQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1JacobiLobattoMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct 2022 -! summary: Return the Jacobi-Lobatto matrix for Chebyshev polynomial - -INTERFACE - MODULE PURE SUBROUTINE Chebyshev1JacobiLobattoMatrix(n, D, E, alphaCoeff, & - & betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+2 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE Chebyshev1JacobiLobattoMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1GaussLobattoQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary:Returns the GaussLobatto quadrature points for Chebyshev1 Polynomial - -INTERFACE - MODULE SUBROUTINE Chebyshev1GaussLobattoQuadrature(n, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(OUT) :: pt(:) - !! the size is 1 to n+2 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! the size is 1 to n+2 - END SUBROUTINE Chebyshev1GaussLobattoQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1Zeros -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION Chebyshev1Zeros(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev polynomial - REAL(DFP) :: ans(n) - END FUNCTION Chebyshev1Zeros -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1Quadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: This routine can return Chebyshev-Gauss, Chebyshev-Radau, -! Chebyshev-Lobatto -! -!# Introduction -! -! This routine returns the Quadrature point of Chebyshev polynomial -! -!@note -! Here n is the number of quadrature points. Please note it is not -! the order of Chebyshev polynomial. The order is decided internally -! depending upon the quadType -!@endnote -! -!@note -! pt and wt should be allocated outside, and length should be n. -!@endnote -! - -INTERFACE - MODULE SUBROUTINE Chebyshev1Quadrature(n, pt, wt, quadType, onlyInside) - INTEGER(I4B), INTENT(IN) :: n - !! number of quadrature points, the order will be computed as follows - !! for quadType = Gauss, n is same as order of Chebyshev polynomial - !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 - !! for quadType = GaussLobatto, n = order+2 - REAL(DFP), INTENT(OUT) :: pt(n) - !! n+1 quadrature points from 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) - !! n+1 weights from 1 to n+1 - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss - !! GaussRadauLeft - !! GaussRadauRight - !! GaussLobatto - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside - !! only inside - END SUBROUTINE Chebyshev1Quadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1Eval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Chebyshev1 polynomials of order = n at single x - -INTERFACE - MODULE PURE FUNCTION Chebyshev1Eval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point of evaluation - REAL(DFP) :: ans - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1Eval1 -END INTERFACE - -INTERFACE Chebyshev1Eval - MODULE PROCEDURE Chebyshev1Eval1 -END INTERFACE Chebyshev1Eval - -!---------------------------------------------------------------------------- -! Chebyshev1Eval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Chebyshev1 polynomials of order n at several points - -INTERFACE - MODULE PURE FUNCTION Chebyshev1Eval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! several points of evaluation - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1Eval2 -END INTERFACE - -INTERFACE Chebyshev1Eval - MODULE PROCEDURE Chebyshev1Eval2 -END INTERFACE Chebyshev1Eval - -!---------------------------------------------------------------------------- -! Chebyshev1EvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Chebyshev1 polynomials from order = 0 to n at single point -! -!# Introduction -! -! Evaluate Chebyshev1 polynomials from order = 0 to n at single point -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- x: the point at which the polynomials are to be evaluated. -!- ans(1:N+1), the values of the first N+1 Chebyshev1 polynomials at the -! point - -INTERFACE - MODULE PURE FUNCTION Chebyshev1EvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point of evaluation - REAL(DFP) :: ans(n + 1) - !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION Chebyshev1EvalAll1 -END INTERFACE - -INTERFACE Chebyshev1EvalAll - MODULE PROCEDURE Chebyshev1EvalAll1 -END INTERFACE Chebyshev1EvalAll - -!---------------------------------------------------------------------------- -! Chebyshev1EvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Chebyshev1 polynomials from order = 0 to n at several -! points -! -!# Introduction -! -! Evaluate Chebyshev1 polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- x: the points at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Chebyshev1 polynomials at the -! points x(1:m) - -INTERFACE - MODULE PURE FUNCTION Chebyshev1EvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! several points of evaluation - REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) - !! at points x - END FUNCTION Chebyshev1EvalAll2 -END INTERFACE - -INTERFACE Chebyshev1EvalAll - MODULE PROCEDURE Chebyshev1EvalAll2 -END INTERFACE Chebyshev1EvalAll - -!---------------------------------------------------------------------------- -! Chebyshev1MonomialExpansionAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Returns the monomial expansion of all Chebyshev1 polynomials -! -!# Introduction -! -! Returns all the monomial expansion of all Chebyshev1 polynomials -! -!- n : is the order of the polynomial -!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 -! -! for example, n=5, we have following structure of ans -! -! | P0 | P1 | P2 | P3 | P4 | P5 | -! |----|----|----|----|----|-----| -! | 1 | 0 | -1 | -0 | 1 | 0 | -! | 0 | 1 | 0 | -3 | -0 | 5 | -! | 0 | 0 | 2 | 0 | -8 | -0 | -! | 0 | 0 | 0 | 4 | 0 | -20 | -! | 0 | 0 | 0 | 0 | 8 | 0 | -! | 0 | 0 | 0 | 0 | 0 | 16 | - -INTERFACE - MODULE PURE FUNCTION Chebyshev1MonomialExpansionAll(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1, 1:n + 1) - END FUNCTION Chebyshev1MonomialExpansionAll -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1MonomialExpansion -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Returns the monomial expansion of a Chebyshev1 polynomials -! -!# Introduction -! -! Returns all the monomial expansion of a Chebyshev1 polynomials -! -!- n : is the order of the polynomial -!- ans(:) contains the coefficient of monomials for polynomial order=n -! - -INTERFACE - MODULE PURE FUNCTION Chebyshev1MonomialExpansion(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1) - END FUNCTION Chebyshev1MonomialExpansion -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Chebyshev1 polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(1:n + 1) - END FUNCTION Chebyshev1GradientEvalAll1 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalAll - MODULE PROCEDURE Chebyshev1GradientEvalAll1 -END INTERFACE Chebyshev1GradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Chebyshev1 polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) - END FUNCTION Chebyshev1GradientEvalAll2 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalAll - MODULE PROCEDURE Chebyshev1GradientEvalAll2 -END INTERFACE Chebyshev1GradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Chebyshev1 polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Chebyshev1GradientEval1 -END INTERFACE -!! - -INTERFACE Chebyshev1GradientEval - MODULE PROCEDURE Chebyshev1GradientEval1 -END INTERFACE Chebyshev1GradientEval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Chebyshev1 polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x)) - END FUNCTION Chebyshev1GradientEval2 -END INTERFACE - -INTERFACE Chebyshev1GradientEval - MODULE PROCEDURE Chebyshev1GradientEval2 -END INTERFACE Chebyshev1GradientEval - -!---------------------------------------------------------------------------- -! Chebyshev1EvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Chebyshev1 polynomials at point x - -INTERFACE - MODULE PURE FUNCTION Chebyshev1EvalSum1(n, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1EvalSum1 -END INTERFACE - -INTERFACE Chebyshev1EvalSum - MODULE PROCEDURE Chebyshev1EvalSum1 -END INTERFACE Chebyshev1EvalSum - -!---------------------------------------------------------------------------- -! Chebyshev1EvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Chebyshev1 polynomials at several x - -INTERFACE - MODULE PURE FUNCTION Chebyshev1EvalSum2(n, x, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1EvalSum2 -END INTERFACE - -INTERFACE Chebyshev1EvalSum - MODULE PROCEDURE Chebyshev1EvalSum2 -END INTERFACE Chebyshev1EvalSum - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials -! at point x - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEvalSum1(n, x, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1GradientEvalSum1 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum1 -END INTERFACE Chebyshev1GradientEvalSum - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials -! at several x - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEvalSum2(n, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1GradientEvalSum2 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum2 -END INTERFACE Chebyshev1GradientEvalSum - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth derivative of finite sum of Chebyshev1 -! polynomials at point x - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEvalSum3(n, x, coeff, k) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! order of derivative - REAL(DFP) :: ans - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1GradientEvalSum3 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum3 -END INTERFACE Chebyshev1GradientEvalSum - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth gradient of finite sum of Chebyshev1 -! polynomials at several x - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientEvalSum4(n, x, coeff, k) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! kth order derivative - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Chebyshev1 polynomial of order n at point x - END FUNCTION Chebyshev1GradientEvalSum4 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum4 -END INTERFACE Chebyshev1GradientEvalSum - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Chebyshev1 Transform - -INTERFACE - MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION Chebyshev1Transform1 -END INTERFACE - -INTERFACE Chebyshev1Transform - MODULE PROCEDURE Chebyshev1Transform1 -END INTERFACE Chebyshev1Transform - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Chebyshev1 Transform - -INTERFACE - MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION Chebyshev1Transform2 -END INTERFACE - -INTERFACE Chebyshev1Transform - MODULE PROCEDURE Chebyshev1Transform2 -END INTERFACE Chebyshev1Transform - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Chebyshev1 Transform of a function on [-1,1] -! -!# Introduction -! -! This function performs the Chebyshev1 transformation of f defined -! on -1 to 1. The interface of the function is give below: -! -!```fortran -! ABSTRACT INTERFACE -! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) -! IMPORT :: DFP -! REAL(DFP), INTENT(IN) :: x -! REAL(DFP) :: ans -! END FUNCTION iface_1DFunction -! END INTERFACE -!``` -! -!@note -! This routine is not pure, because this subroutine calls -! `Chebyshev1Quadrature` which is not pure due to Lapack call. -!@endnote - -INTERFACE - MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f - !! 1D space function - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION Chebyshev1Transform3 -END INTERFACE - -INTERFACE Chebyshev1Transform - MODULE PROCEDURE Chebyshev1Transform3 -END INTERFACE Chebyshev1Transform - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Chebyshev1 Transform -! -!# Introduction -! Discrete Chebyshev transform. We calculate weights and quadrature points -! internally. - -INTERFACE - MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! nodal value (at quad points) - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION Chebyshev1Transform4 -END INTERFACE - -!---------------------------------------------------------------------------- -! Chebyshev1InvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Inverse Chebyshev1 Transform - -INTERFACE - MODULE PURE FUNCTION Chebyshev1InvTransform1(n, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x - !! x point in physical space - REAL(DFP) :: ans - !! value in physical space - END FUNCTION Chebyshev1InvTransform1 -END INTERFACE - -INTERFACE Chebyshev1InvTransform - MODULE PROCEDURE Chebyshev1InvTransform1 -END INTERFACE Chebyshev1InvTransform - -!---------------------------------------------------------------------------- -! Chebyshev1InvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Inverse Chebyshev1 Transform - -INTERFACE - MODULE PURE FUNCTION Chebyshev1InvTransform2(n, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x(:) - !! x point in physical space - REAL(DFP) :: ans(SIZE(x)) - !! value in physical space - END FUNCTION Chebyshev1InvTransform2 -END INTERFACE - -INTERFACE Chebyshev1InvTransform - MODULE PROCEDURE Chebyshev1InvTransform2 -END INTERFACE Chebyshev1InvTransform - -!---------------------------------------------------------------------------- -! Chebyshev1GradientCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Returns coefficients for gradient of Chebyshev1 expansion -! -!# Introduction -! -!- This routine returns the coefficients of gradient of Jacobi expansion. -!- Input is coefficient of Chebyshev1 expansion (modal values) -!- Output is coefficient of derivative of Chebyshev1 expansion (modal values) - -INTERFACE - MODULE PURE FUNCTION Chebyshev1GradientCoeff1(n, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! coefficients $\tilde{u}_{n}$ obtained from Chebyshev1Transform - REAL(DFP) :: ans(0:n) - !! coefficient of gradient - END FUNCTION Chebyshev1GradientCoeff1 -END INTERFACE - -INTERFACE Chebyshev1GradientCoeff - MODULE PROCEDURE Chebyshev1GradientCoeff1 -END INTERFACE Chebyshev1GradientCoeff - -!---------------------------------------------------------------------------- -! Chebyshev1DMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 Oct 2022 -! summary: Returns differentiation matrix for Chebyshev1 expansion - -INTERFACE - MODULE PURE FUNCTION Chebyshev1DMatrix1(n, x, quadType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev1 polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss and GaussLobatto - REAL(DFP) :: ans(0:n, 0:n) - !! D matrix - END FUNCTION Chebyshev1DMatrix1 -END INTERFACE - -INTERFACE Chebyshev1DMatrix - MODULE PROCEDURE Chebyshev1DMatrix1 -END INTERFACE Chebyshev1DMatrix - -!---------------------------------------------------------------------------- -! Chebyshev1DMatEvenOdd -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 Oct 2022 -! summary: Performs even and odd decomposition of Differential matrix - -INTERFACE - MODULE PURE SUBROUTINE Chebyshev1DMatEvenOdd1(n, D, e, o) - INTEGER(I4B), INTENT(IN) :: n - !! order of Chebyshev1 polynomial - REAL(DFP), INTENT(IN) :: D(0:n, 0:n) - !! n+1 by n+1 - REAL(DFP), INTENT(OUT) :: e(0:, 0:) - !! even Decomposition, 0:n/2, 0:n/2 - REAL(DFP), INTENT(OUT) :: o(0:, 0:) - !! odd decomposition, 0:n/2, 0:n/2 - END SUBROUTINE Chebyshev1DMatEvenOdd1 -END INTERFACE - -INTERFACE Chebyshev1DMatEvenOdd - MODULE PROCEDURE Chebyshev1DMatEvenOdd1 -END INTERFACE Chebyshev1DMatEvenOdd - -END MODULE Chebyshev1PolynomialUtility diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 deleted file mode 100644 index fef9276e3..000000000 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ /dev/null @@ -1,2636 +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 HexahedronInterpolationUtility -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE -PUBLIC :: LagrangeDegree_Hexahedron -PUBLIC :: LagrangeDOF_Hexahedron -PUBLIC :: LagrangeInDOF_Hexahedron -PUBLIC :: EquidistancePoint_Hexahedron -PUBLIC :: EquidistanceInPoint_Hexahedron -PUBLIC :: InterpolationPoint_Hexahedron -PUBLIC :: LagrangeCoeff_Hexahedron -PUBLIC :: EdgeConnectivity_Hexahedron -PUBLIC :: FacetConnectivity_Hexahedron -PUBLIC :: QuadratureNumber_Hexahedron -PUBLIC :: TensorProdBasis_Hexahedron -PUBLIC :: OrthogonalBasis_Hexahedron -PUBLIC :: VertexBasis_Hexahedron -PUBLIC :: xEdgeBasis_Hexahedron -PUBLIC :: yEdgeBasis_Hexahedron -PUBLIC :: zEdgeBasis_Hexahedron -PUBLIC :: EdgeBasis_Hexahedron -PUBLIC :: xyFacetBasis_Hexahedron -PUBLIC :: yzFacetBasis_Hexahedron -PUBLIC :: xzFacetBasis_Hexahedron -PUBLIC :: FacetBasis_Hexahedron -PUBLIC :: CellBasis_Hexahedron -PUBLIC :: HeirarchicalBasis_Hexahedron -PUBLIC :: QuadraturePoint_Hexahedron -PUBLIC :: LagrangeEvalAll_Hexahedron -PUBLIC :: GetVertexDOF_Hexahedron -PUBLIC :: GetEdgeDOF_Hexahedron -PUBLIC :: GetFacetDOF_Hexahedron -PUBLIC :: GetCellDOF_Hexahedron -PUBLIC :: RefElemDomain_Hexahedron -PUBLIC :: LagrangeGradientEvalAll_Hexahedron -PUBLIC :: OrthogonalBasisGradient_Hexahedron -PUBLIC :: TensorProdBasisGradient_Hexahedron -PUBLIC :: HeirarchicalBasisGradient_Hexahedron -PUBLIC :: GetTotalDOF_Hexahedron -PUBLIC :: GetTotalInDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetTotalDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Hexahedron - -INTERFACE - MODULE PURE FUNCTION GetTotalDOF_Hexahedron(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalDOF_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Hexahedron -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Hexahedron -!- These dof are strictly inside the Hexahedron - -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Hexahedron(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! RefElemDomain_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain_Hexahedron(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_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! GetVertexDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: returns total number of vertex degrees of freedom - -INTERFACE - MODULE PURE FUNCTION GetVertexDOF_Hexahedron() RESULT(ans) - INTEGER(I4B) :: ans - END FUNCTION GetVertexDOF_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: returns total number of degrees of freedom on edges parallel to -! some axis - -INTERFACE GetEdgeDOF_Hexahedron - MODULE PURE FUNCTION GetEdgeDOF_Hexahedron1(pe1, pe2, pe3, pe4) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1, pe2, pe3, pe4 - !! Order of interpolation in x or y or z direction - INTEGER(I4B) :: ans - END FUNCTION GetEdgeDOF_Hexahedron1 -END INTERFACE GetEdgeDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total number of degrees of freedom on all edges - -INTERFACE GetEdgeDOF_Hexahedron - MODULE PURE FUNCTION GetEdgeDOF_Hexahedron2(p, q, r) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - !! Order of approximation in x,y and z direction - INTEGER(I4B) :: ans - END FUNCTION GetEdgeDOF_Hexahedron2 -END INTERFACE GetEdgeDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total number of degrees of freedom on all edges - -INTERFACE GetEdgeDOF_Hexahedron - MODULE PURE FUNCTION GetEdgeDOF_Hexahedron3(p) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B) :: ans - END FUNCTION GetEdgeDOF_Hexahedron3 -END INTERFACE GetEdgeDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total number of degrees of freedom on all edges - -INTERFACE GetEdgeDOF_Hexahedron - MODULE PURE FUNCTION GetEdgeDOF_Hexahedron4( & - & px1, px2, px3, px4, & - & py1, py2, py3, py4, & - & pz1, pz2, pz3, pz4) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 - !! orders alongs edges parallel to x axis - INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 - !! orders along edges parallel to y axis - INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 - !! orders along edges parallel to z axis - INTEGER(I4B) :: ans - END FUNCTION GetEdgeDOF_Hexahedron4 -END INTERFACE GetEdgeDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns dof on all facets - -INTERFACE GetFacetDOF_Hexahedron - MODULE PURE FUNCTION GetFacetDOF_Hexahedron1( & - & pxy1, pxy2, & - & pxz1, pxz2, & - & pyz1, pyz2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 - !! orders alongs facets parallel to xy plane - INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 - !! orders along facets parallel to xz plane - INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 - !! orders along facets parallel to yx plane - INTEGER(I4B) :: ans - END FUNCTION GetFacetDOF_Hexahedron1 -END INTERFACE GetFacetDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total degrees of freedom on all facets - -INTERFACE GetFacetDOF_Hexahedron - MODULE PURE FUNCTION GetFacetDOF_Hexahedron2(p, q, r) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - !! orders in x, y and z direction - INTEGER(I4B) :: ans - END FUNCTION GetFacetDOF_Hexahedron2 -END INTERFACE GetFacetDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total degree of freedom on a single facet - -INTERFACE GetFacetDOF_Hexahedron - MODULE PURE FUNCTION GetFacetDOF_Hexahedron3(p, q) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q - !! orders alongs facets parallel to xy or xz or yz planes - INTEGER(I4B) :: ans - END FUNCTION GetFacetDOF_Hexahedron3 -END INTERFACE GetFacetDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total degrees of freedom on all facets - -INTERFACE GetFacetDOF_Hexahedron - MODULE PURE FUNCTION GetFacetDOF_Hexahedron4(p) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! orders alongs facets parallel to xy or xz or yz planes - INTEGER(I4B) :: ans - END FUNCTION GetFacetDOF_Hexahedron4 -END INTERFACE GetFacetDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: - -INTERFACE GetCellDOF_Hexahedron - MODULE PURE FUNCTION GetCellDOF_Hexahedron1(p, q, r) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - !! orders alongs to x, y, and z directions - INTEGER(I4B) :: ans - END FUNCTION GetCellDOF_Hexahedron1 -END INTERFACE GetCellDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: - -INTERFACE GetCellDOF_Hexahedron - MODULE PURE FUNCTION GetCellDOF_Hexahedron2(p) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! orders alongs to x, y, and z directions - INTEGER(I4B) :: ans - END FUNCTION GetCellDOF_Hexahedron2 -END INTERFACE GetCellDOF_Hexahedron - -!---------------------------------------------------------------------------- -! QuadratureNumber_Hexahedron -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION QuadratureNumber_Hexahedron( & - & p, & - & q, & - & r, & - & quadType1, & - & quadType2, & - & quadType3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 - INTEGER(I4B) :: ans(3) - END FUNCTION QuadratureNumber_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetConnectivity_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-28 -! summary: This function returns the edge connectivity of Hexahedron - -INTERFACE - MODULE PURE FUNCTION FacetConnectivity_Hexahedron( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(4, 6) - END FUNCTION FacetConnectivity_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-07 -! summary: This function returns the edge connectivity of Hexahedron - -INTERFACE - MODULE PURE FUNCTION EdgeConnectivity_Hexahedron( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(2, 12) - END FUNCTION EdgeConnectivity_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE LagrangeDegree_Hexahedron - MODULE PURE FUNCTION LagrangeDegree_Hexahedron1(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Hexahedron1 -END INTERFACE LagrangeDegree_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeDegree_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE LagrangeDegree_Hexahedron - MODULE PURE FUNCTION LagrangeDegree_Hexahedron2(p, q, r) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), INTENT(IN) :: r - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Hexahedron2 -END INTERFACE LagrangeDegree_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Hexahedron - -INTERFACE LagrangeDOF_Hexahedron - MODULE PURE FUNCTION LagrangeDOF_Hexahedron1(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Hexahedron1 -END INTERFACE LagrangeDOF_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Hexahedron - -INTERFACE LagrangeDOF_Hexahedron - MODULE PURE FUNCTION LagrangeDOF_Hexahedron2(p, q, r) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Hexahedron2 -END INTERFACE LagrangeDOF_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Hexahedron -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Hexahedron -!- These dof are strictly inside the Hexahedron - -INTERFACE LagrangeInDOF_Hexahedron - MODULE PURE FUNCTION LagrangeInDOF_Hexahedron1(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Hexahedron1 -END INTERFACE LagrangeInDOF_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Hexahedron -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Hexahedron -!- These dof are strictly inside the Hexahedron - -INTERFACE LagrangeInDOF_Hexahedron - MODULE PURE FUNCTION LagrangeInDOF_Hexahedron2(p, q, r) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Hexahedron2 -END INTERFACE LagrangeInDOF_Hexahedron - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in Hexahedron -! -!# Introduction -! -!- This function returns the equidistance points in Hexahedron -!- All points are inside the Hexahedron - -INTERFACE EquidistanceInPoint_Hexahedron - MODULE PURE FUNCTION EquidistanceInPoint_Hexahedron1(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! number of rows = 3 - !! number of cols = 8 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistanceInPoint_Hexahedron1 -END INTERFACE EquidistanceInPoint_Hexahedron - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in Hexahedron -! -!# Introduction -! -!- This function returns the equidistance points in Hexahedron -!- All points are inside the Hexahedron - -INTERFACE EquidistanceInPoint_Hexahedron - MODULE PURE FUNCTION EquidistanceInPoint_Hexahedron2(p, q, r, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - !! order in x, y, and z direction - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! number of rows = 3 - !! number of cols = 8 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistanceInPoint_Hexahedron2 -END INTERFACE EquidistanceInPoint_Hexahedron - -!---------------------------------------------------------------------------- -! EquidistancePoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Hexahedron element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Hexahedron 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, VEFC. - -INTERFACE EquidistancePoint_Hexahedron - MODULE PURE FUNCTION EquidistancePoint_Hexahedron1(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! number of rows = 3 - !! number of cols = 8 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistancePoint_Hexahedron1 -END INTERFACE EquidistancePoint_Hexahedron - -!---------------------------------------------------------------------------- -! EquidistancePoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Hexahedron element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Hexahedron 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, VEFC. - -INTERFACE EquidistancePoint_Hexahedron - MODULE PURE FUNCTION EquidistancePoint_Hexahedron2(p, q, r, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order in y direction - INTEGER(I4B), INTENT(IN) :: r - !! order in z direction - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! number of rows = 3 - !! number of cols = 8 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistancePoint_Hexahedron2 -END INTERFACE EquidistancePoint_Hexahedron - -!---------------------------------------------------------------------------- -! InterpolationPoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point - -INTERFACE InterpolationPoint_Hexahedron - MODULE FUNCTION InterpolationPoint_Hexahedron1(order, ipType, & - & layout, xij, alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in x, y and z direction - INTEGER(I4B), INTENT(IN) :: ipType - !! Interpolation type in x, y, and z direction - !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, - !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto - CHARACTER(*), INTENT(IN) :: layout - !! layout can be VEFC or INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordiantes of reference hexahedron - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - !! rows of ans denotes x, y, z components - !! cols of ans denotes x, y, z components - END FUNCTION InterpolationPoint_Hexahedron1 -END INTERFACE InterpolationPoint_Hexahedron - -!---------------------------------------------------------------------------- -! InterpolationPoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Interpolation points - -INTERFACE InterpolationPoint_Hexahedron - MODULE FUNCTION InterpolationPoint_Hexahedron2( & - & p, & - & q, & - & r, & - & ipType1, & - & ipType2, & - & ipType3, & - & layout, & - & xij, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order in y direction - INTEGER(I4B), INTENT(IN) :: r - !! order in z direction - INTEGER(I4B), INTENT(IN) :: ipType1 - !! interpolation type in x direction - INTEGER(I4B), INTENT(IN) :: ipType2 - !! interpolation type in y direction - INTEGER(I4B), INTENT(IN) :: ipType3 - !! interpolation type in z direction - CHARACTER(*), INTENT(IN) :: layout - !! layout can be VEFC or INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinate of reference Hexahedron - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - !! rows of ans denotes x, y, z components - !! cols of ans denotes x, y, z components - END FUNCTION InterpolationPoint_Hexahedron2 -END INTERFACE InterpolationPoint_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Convert IJK to VEFC format - -INTERFACE - MODULE RECURSIVE PURE SUBROUTINE IJK2VEFC_Hexahedron( & - & xi, & - & eta, & - & zeta, & - & temp, & - & p, q, r) - REAL(DFP), INTENT(IN) :: xi(:, :, :) - REAL(DFP), INTENT(IN) :: eta(:, :, :) - REAL(DFP), INTENT(IN) :: zeta(:, :, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), INTENT(IN) :: r - END SUBROUTINE IJK2VEFC_Hexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Returns coefficients of monomials for ith lagrange polynomial - -INTERFACE LagrangeCoeff_Hexahedron - MODULE FUNCTION LagrangeCoeff_Hexahedron1(order, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! interpolation points in xij format - !! number of rows in xij is 3 - !! number of columns should be equal to the number degree of freedom - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Hexahedron1 -END INTERFACE LagrangeCoeff_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Returns coefficients of monomials for ith lagrange polynomial - -INTERFACE LagrangeCoeff_Hexahedron - MODULE FUNCTION LagrangeCoeff_Hexahedron2(order, i, v, isVandermonde) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Hexahedron2 -END INTERFACE LagrangeCoeff_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Returns coefficients of monomials for ith lagrange polynomial - -INTERFACE LagrangeCoeff_Hexahedron - MODULE FUNCTION LagrangeCoeff_Hexahedron3(order, i, v, ipiv) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Hexahedron3 -END INTERFACE LagrangeCoeff_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Returns the coefficients of monomials for all lagrange polynomial - -INTERFACE LagrangeCoeff_Hexahedron - MODULE FUNCTION LagrangeCoeff_Hexahedron4(order, xij, basisType, & - & refHexahedron, 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 - CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron - !! UNIT - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! This parameter is needed when basisType is Ultraspherical - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Hexahedron4 -END INTERFACE LagrangeCoeff_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Returns the coefficients of monomials for all lagrange polynomial - -INTERFACE LagrangeCoeff_Hexahedron - MODULE FUNCTION LagrangeCoeff_Hexahedron5(& - & p, & - & q, & - & r, & - & xij, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3, & - & refHexahedron & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order of polynomial in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order of polynomial in y direction - INTEGER(I4B), INTENT(IN) :: r - !! order of polynomial in z direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! These are interpolation points in xij format, size(xij,2) - INTEGER(I4B), INTENT(IN) :: basisType1 - !! basis type in x direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType2 - !! basis type in y direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType3 - !! basis type in z direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! This parameter is needed when basisType1 is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! This parameter is needed when basisType1 is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! This parameter is needed when basisType1 is Ultraspherical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! This parameter is needed when basisType2 is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! This parameter is needed when basisType2 is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! This parameter is needed when basisType2 is Ultraspherical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 - !! This parameter is needed when basisType3 is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 - !! This parameter is needed when basisType3 is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 - !! This parameter is needed when basisType3 is Ultraspherical - CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron - !! UNIT - !! BIUNIT - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Hexahedron5 -END INTERFACE LagrangeCoeff_Hexahedron - -!---------------------------------------------------------------------------- -! TensorProdBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron - -INTERFACE TensorProdBasis_Hexahedron - MODULE FUNCTION TensorProdBasis_Hexahedron1( & - & p, & - & q, & - & r, & - & xij, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! highest order in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - INTEGER(I4B), INTENT(IN) :: r - !! highest order in x3 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 - !! basis type in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! alpha1 needed when basisType1 "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 - !! alpha3 needed when basisType3 "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 - !! beta3 is needed when basisType3 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 - !! lambda3 is needed when basisType3 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1) * (r + 1)) - !! - END FUNCTION TensorProdBasis_Hexahedron1 -END INTERFACE TensorProdBasis_Hexahedron - -INTERFACE OrthogonalBasis_Hexahedron - MODULE PROCEDURE TensorProdBasis_Hexahedron1 -END INTERFACE OrthogonalBasis_Hexahedron - -!---------------------------------------------------------------------------- -! TensorProdBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle -! -!# Introduction -! -! This function returns the tensor product expansion of orthogonal -! polynomial on biunit quadrangle. Here xij is obtained by -! outer product of x and y - -INTERFACE TensorProdBasis_Hexahedron - MODULE FUNCTION TensorProdBasis_Hexahedron2( & - & p, & - & q, & - & r, & - & x, & - & y, & - & z, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! highest order in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - INTEGER(I4B), INTENT(IN) :: r - !! highest order in x3 direction - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! points of evaluation in xij format - INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 - !! orthogonal polynomial family in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 - REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1) * (r + 1)) - !! Tensor basis - !! The number of rows corresponds to the - !! total number of points - END FUNCTION TensorProdBasis_Hexahedron2 -END INTERFACE TensorProdBasis_Hexahedron - -INTERFACE OrthogonalBasis_Hexahedron - MODULE PROCEDURE TensorProdBasis_Hexahedron2 -END INTERFACE OrthogonalBasis_Hexahedron - -!---------------------------------------------------------------------------- -! VertexBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit hexahedron - -INTERFACE VertexBasis_Hexahedron - MODULE PURE FUNCTION VertexBasis_Hexahedron1(x, y, z) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(x), 8) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Hexahedron1 -END INTERFACE VertexBasis_Hexahedron - -!---------------------------------------------------------------------------- -! VertexBasis_Hexahedron2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE - MODULE PURE FUNCTION VertexBasis_Hexahedron2(L1, L2, L3) RESULT(ans) - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - !! L2 is Lobatto polynomial evaluated at y coordinates - !! L3 is Lobatto polynomial evaluated at z coordinates - REAL(DFP) :: ans(SIZE(L1, 1), 8) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Hexahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! VertexBasis_Hexahedron2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE - MODULE PURE FUNCTION VertexBasisGradient_Hexahedron2( & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - !! L2 is Lobatto polynomial evaluated at y coordinates - !! L3 is Lobatto polynomial evaluated at z coordinates - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - !! L2 is Lobatto polynomial evaluated at y coordinates - !! L3 is Lobatto polynomial evaluated at z coordinates - REAL(DFP) :: ans(SIZE(L1, 1), 8, 3) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasisGradient_Hexahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! VertexBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE VertexBasis_Hexahedron - MODULE PURE FUNCTION VertexBasis_Hexahedron3(xij) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - REAL(DFP) :: ans(SIZE(xij, 2), 8) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Hexahedron3 -END INTERFACE VertexBasis_Hexahedron - -!---------------------------------------------------------------------------- -! xEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on edges parallel to x axis - -INTERFACE xEdgeBasis_Hexahedron - MODULE PURE FUNCTION xEdgeBasis_Hexahedron1( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & x, & - & y, & - & z) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION xEdgeBasis_Hexahedron1 -END INTERFACE xEdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE xEdgeBasis_Hexahedron - MODULE PURE FUNCTION xEdgeBasis_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION xEdgeBasis_Hexahedron2 -END INTERFACE xEdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE xEdgeBasisGradient_Hexahedron - MODULE PURE FUNCTION xEdgeBasisGradient_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) - END FUNCTION xEdgeBasisGradient_Hexahedron2 -END INTERFACE xEdgeBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! yEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on edges parallel to y axis - -INTERFACE yEdgeBasis_Hexahedron - MODULE PURE FUNCTION yEdgeBasis_Hexahedron1( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & x, & - & y, & - & z) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION yEdgeBasis_Hexahedron1 -END INTERFACE yEdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE yEdgeBasis_Hexahedron - MODULE PURE FUNCTION yEdgeBasis_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION yEdgeBasis_Hexahedron2 -END INTERFACE yEdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE yEdgeBasisGradient_Hexahedron - MODULE PURE FUNCTION yEdgeBasisGradient_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) - END FUNCTION yEdgeBasisGradient_Hexahedron2 -END INTERFACE yEdgeBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! zEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on edges parallel to y axis - -INTERFACE zEdgeBasis_Hexahedron - MODULE PURE FUNCTION zEdgeBasis_Hexahedron1( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & x, & - & y, & - & z) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION zEdgeBasis_Hexahedron1 -END INTERFACE zEdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE zEdgeBasis_Hexahedron - MODULE PURE FUNCTION zEdgeBasis_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION zEdgeBasis_Hexahedron2 -END INTERFACE zEdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE zEdgeBasisGradient_Hexahedron - MODULE PURE FUNCTION zEdgeBasisGradient_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) - END FUNCTION zEdgeBasisGradient_Hexahedron2 -END INTERFACE zEdgeBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! EdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on edges parallel to y axis - -INTERFACE EdgeBasis_Hexahedron - MODULE PURE FUNCTION EdgeBasis_Hexahedron1( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & x, & - & y, & - & z, & - & dim) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - INTEGER(I4B), INTENT(IN) :: dim - !! dim specifies the axis orientation, it can be - !! dim = 1, means x axis - !! dim = 2, means y axis - !! dim = 3, means z axis - REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION EdgeBasis_Hexahedron1 -END INTERFACE EdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE EdgeBasis_Hexahedron - MODULE PURE FUNCTION EdgeBasis_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3, & - & dim) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - INTEGER(I4B), INTENT(IN) :: dim - !! dim specifies the axis orientation, it can be - !! dim = 1, means x axis - !! dim = 2, means y axis - !! dim = 3, means z axis - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) - END FUNCTION EdgeBasis_Hexahedron2 -END INTERFACE EdgeBasis_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE EdgeBasisGradient_Hexahedron - MODULE PURE FUNCTION EdgeBasisGradient_Hexahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3, & - & dim) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge e1, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge e2, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge e3, it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge e4, it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - INTEGER(I4B), INTENT(IN) :: dim - !! dim specifies the axis orientation, it can be - !! dim = 1, means x axis - !! dim = 2, means y axis - !! dim = 3, means z axis - REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) - END FUNCTION EdgeBasisGradient_Hexahedron2 -END INTERFACE EdgeBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! xyFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xyFacet - -INTERFACE xyFacetBasis_Hexahedron - MODULE PURE FUNCTION xyFacetBasis_Hexahedron1( & - & n1, & - & n2, & - & x, & - & y, & - & z) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xy face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xy face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans( & - & SIZE(x), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION xyFacetBasis_Hexahedron1 -END INTERFACE xyFacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! xyFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xyFacet - -INTERFACE xyFacetBasis_Hexahedron - MODULE PURE FUNCTION xyFacetBasis_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xy face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xy face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION xyFacetBasis_Hexahedron2 -END INTERFACE xyFacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! xyFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xyFacet - -INTERFACE xyFacetBasisGradient_Hexahedron - MODULE PURE FUNCTION xyFacetBasisGradient_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xy face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xy face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3) - END FUNCTION xyFacetBasisGradient_Hexahedron2 -END INTERFACE xyFacetBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! yzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on yzFacet - -INTERFACE yzFacetBasis_Hexahedron - MODULE PURE FUNCTION yzFacetBasis_Hexahedron1( & - & n1, & - & n2, & - & x, & - & y, & - & z) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of yz face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of yz face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans( & - & SIZE(x), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION yzFacetBasis_Hexahedron1 -END INTERFACE yzFacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! yzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on yzFacet - -INTERFACE yzFacetBasis_Hexahedron - MODULE PURE FUNCTION yzFacetBasis_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of yz face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of yz face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION yzFacetBasis_Hexahedron2 -END INTERFACE yzFacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! yzFacetBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on yzFacet - -INTERFACE yzFacetBasisGradient_Hexahedron - MODULE PURE FUNCTION yzFacetBasisGradient_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of yz face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of yz face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3) - END FUNCTION yzFacetBasisGradient_Hexahedron2 -END INTERFACE yzFacetBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! xzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzFacet - -INTERFACE xzFacetBasis_Hexahedron - MODULE PURE FUNCTION xzFacetBasis_Hexahedron1( & - & n1, & - & n2, & - & x, & - & y, & - & z) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xz face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xz face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans( & - & SIZE(x), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION xzFacetBasis_Hexahedron1 -END INTERFACE xzFacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! xzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzFacet - -INTERFACE xzFacetBasis_Hexahedron - MODULE PURE FUNCTION xzFacetBasis_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xz face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xz face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION xzFacetBasis_Hexahedron2 -END INTERFACE xzFacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! xzFacetBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzFacet - -INTERFACE xzFacetBasisGradient_Hexahedron - MODULE PURE FUNCTION xzFacetBasisGradient_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xz face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xz face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3_I4B) - END FUNCTION xzFacetBasisGradient_Hexahedron2 -END INTERFACE xzFacetBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! xzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzFacet - -INTERFACE FacetBasis_Hexahedron - MODULE PURE FUNCTION FacetBasis_Hexahedron1( & - & n1, & - & n2, & - & x, & - & y, & - & z, & - & dim1, & - & dim2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of the face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of the face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - INTEGER(I4B), INTENT(IN) :: dim1 - !! direction in n1 direction - INTEGER(I4B), INTENT(IN) :: dim2 - !! direction in n2 direction - REAL(DFP) :: ans( & - & SIZE(x), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION FacetBasis_Hexahedron1 -END INTERFACE FacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! FacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzFacet - -INTERFACE FacetBasis_Hexahedron - MODULE PURE FUNCTION FacetBasis_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3, & - & dim1, & - & dim2) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xy face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xy face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - INTEGER(I4B), INTENT(IN) :: dim1 - !! direction in n1 direction - INTEGER(I4B), INTENT(IN) :: dim2 - !! direction in n2 direction - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) - END FUNCTION FacetBasis_Hexahedron2 -END INTERFACE FacetBasis_Hexahedron - -!---------------------------------------------------------------------------- -! FacetBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzFacet - -INTERFACE FacetBasisGradient_Hexahedron - MODULE PURE FUNCTION FacetBasisGradient_Hexahedron2( & - & n1, & - & n2, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3, & - & dim1, & - & dim2) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 of xy face - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 of xy face - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - !! Gradient of Lobatto polynomials in x, y, and z direction. - INTEGER(I4B), INTENT(IN) :: dim1 - !! direction in n1 direction - INTEGER(I4B), INTENT(IN) :: dim2 - !! direction in n2 direction - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3) - END FUNCTION FacetBasisGradient_Hexahedron2 -END INTERFACE FacetBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! CellBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on Cell - -INTERFACE CellBasis_Hexahedron - MODULE PURE FUNCTION CellBasis_Hexahedron1( & - & n1, & - & n2, & - & n3, & - & x, & - & y, & - & z) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n3 - !! order along axis 3 - !! it should be greater than 1 - REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans( & - & SIZE(x), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * (n3 - 1_I4B)) - END FUNCTION CellBasis_Hexahedron1 -END INTERFACE CellBasis_Hexahedron - -!---------------------------------------------------------------------------- -! CellBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzCell - -INTERFACE CellBasis_Hexahedron - MODULE PURE FUNCTION CellBasis_Hexahedron2( & - & n1, & - & n2, & - & n3, & - & L1, & - & L2, & - & L3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 - !! it should be greater than 3 - INTEGER(I4B), INTENT(IN) :: n3 - !! order along axis 3 - !! it should be greater than 3 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * (n3 - 1_I4B)) - END FUNCTION CellBasis_Hexahedron2 -END INTERFACE CellBasis_Hexahedron - -!---------------------------------------------------------------------------- -! CellBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on xzCell - -INTERFACE CellBasisGradient_Hexahedron - MODULE PURE FUNCTION CellBasisGradient_Hexahedron2( & - & n1, & - & n2, & - & n3, & - & L1, & - & L2, & - & L3, & - & dL1, & - & dL2, & - & dL3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n1 - !! order along axis 1 - !! it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: n2 - !! order along axis 2 - !! it should be greater than 3 - INTEGER(I4B), INTENT(IN) :: n3 - !! order along axis 3 - !! it should be greater than 3 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) - !! Lobatto polynomials in x, y, and z direction. - REAL(DFP) :: ans( & - & SIZE(L1, 1), & - & (n1 - 1_I4B) * (n2 - 1_I4B) * (n3 - 1_I4B), 3) - END FUNCTION CellBasisGradient_Hexahedron2 -END INTERFACE CellBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Returns the HeirarchicalBasis on Hexahedron - -INTERFACE HeirarchicalBasis_Hexahedron - MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1( & - & pb1, pb2, pb3, & - & pxy1, pxy2, & - & pxz1, pxz2, & - & pyz1, pyz2, & - & px1, px2, px3, px4, & - & py1, py2, py3, py4, & - & pz1, pz2, pz3, pz4, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3 - !! order of interpolation inside the element in x, y, and z dirs - INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 - !! order of interpolation on facets parallel to xy plane - INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 - !! order of interpolation on facets parallel to xz plane - INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 - !! order of interpolation on facets parallel to yz plane - INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 - !! order of interpolation on edges parallel to x-axis - INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 - !! order of interpolation on edges parallel to y-axis - INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 - !! order of interpolation on edges parallel to z-axis - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & 8_I4B & - & + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & - & + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & - & + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & - & + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & - & + (px1 + px2 + px3 + px4 - 4_I4B) & - & + (py1 + py2 + py3 + py4 - 4_I4B) & - & + (pz1 + pz2 + pz3 + pz4 - 4_I4B) & - & ) - !! - END FUNCTION HeirarchicalBasis_Hexahedron1 -END INTERFACE HeirarchicalBasis_Hexahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Returns the HeirarchicalBasis on Hexahedron - -INTERFACE HeirarchicalBasis_Hexahedron - MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2( & - & p, q, r, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - !! order of interpolation in x, y, and z dirs - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & 8_I4B & - & + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) & - & + (p - 1_I4B) * (q - 1_I4B) * 2_I4B & - & + (p - 1_I4B) * (r - 1_I4B) * 2_I4B & - & + (q - 1_I4B) * (r - 1_I4B) * 2_I4B & - & + (4_I4B * p - 4_I4B) & - & + (4_I4B * q - 4_I4B) & - & + (4_I4B * r - 4_I4B) & - & ) - !! - END FUNCTION HeirarchicalBasis_Hexahedron2 -END INTERFACE HeirarchicalBasis_Hexahedron - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points on reference hexahedron - -INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron1( & - & order, & - & quadType, & - & refHexahedron, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand in x, y, and z direction - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: refHexahedron - !! Reference hexahedron - !! UNIT - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordiantes of hexahedron in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! quadrature points in xij format - END FUNCTION QuadraturePoint_Hexahedron1 -END INTERFACE QuadraturePoint_Hexahedron - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron2( & - & p, q, r, & - & quadType1, quadType2, quadType3, & - & refHexahedron, & - & xij, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order of integrand in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order of integrand in y direction - INTEGER(I4B), INTENT(IN) :: r - !! order of integrand in z direction - INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 - !! quadrature point type in x direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: refHexahedron - !! Reference hexahedron - !! UNIT - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 - !! Jacobi parameter and Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 - !! Jacobi parameter and Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 - !! Jacobi parameter and Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION QuadraturePoint_Hexahedron2 -END INTERFACE QuadraturePoint_Hexahedron - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points on reference quadrangle - -INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron3( & - & nips, & - & quadType, & - & refHexahedron, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nips(1) - !! number of integration points in x, y, and z direction - INTEGER(I4B), INTENT(IN) :: quadType - !! interpolation point type - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: refHexahedron - !! Reference hexahedron - !! UNIT - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: 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_Hexahedron3 -END INTERFACE QuadraturePoint_Hexahedron - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron4( & - & nipsx, nipsy, nipsz, & - & quadType1, quadType2, quadType3, & - & refHexahedron, & - & xij, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3 & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nipsx(1) - !! order of integrand in x direction - INTEGER(I4B), INTENT(IN) :: nipsy(1) - !! order of integrand in y direction - INTEGER(I4B), INTENT(IN) :: nipsz(1) - !! order of integrand in z direction - INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 - !! quadrature point type in x, y, and z direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: refHexahedron - !! Reference hexahedron - !! UNIT - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 - !! Jacobi and Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 - !! Jacobi and Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 - !! Jacobi and Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION QuadraturePoint_Hexahedron4 -END INTERFACE QuadraturePoint_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Hexahedron - MODULE FUNCTION LagrangeEvalAll_Hexahedron1( & - & 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(3) - !! point of evaluation - !! x(1) is x coord - !! x(2) is y coord - !! x(3) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - !! The number of rows in xij is 3 - !! The number of columns in xij should be equal to total - !! degree of freedom - REAL(DFP), 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_Hexahedron1 -END INTERFACE LagrangeEvalAll_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Hexahedron - MODULE FUNCTION LagrangeEvalAll_Hexahedron2( & - & 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 - !! x(3, :) is z 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 - !! 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(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Hexahedron2 -END INTERFACE LagrangeEvalAll_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Gradient of Lagrange polynomials - -INTERFACE LagrangeGradientEvalAll_Hexahedron - MODULE FUNCTION LagrangeGradientEvalAll_Hexahedron1( & - & 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 - 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), 3) - !! 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_Hexahedron1 -END INTERFACE LagrangeGradientEvalAll_Hexahedron - -!---------------------------------------------------------------------------- -! TensorProdBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron - -INTERFACE TensorProdBasisGradient_Hexahedron - MODULE FUNCTION TensorProdBasisGradient_Hexahedron1( & - & p, & - & q, & - & r, & - & xij, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! highest order in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - INTEGER(I4B), INTENT(IN) :: r - !! highest order in x3 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 - !! basis type in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! alpha1 needed when basisType1 "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 - !! alpha3 needed when basisType3 "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 - !! beta3 is needed when basisType3 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 - !! lambda3 is needed when basisType3 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1) * (r + 1), 3) - END FUNCTION TensorProdBasisGradient_Hexahedron1 -END INTERFACE TensorProdBasisGradient_Hexahedron - -INTERFACE OrthogonalBasisGradient_Hexahedron - MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1 -END INTERFACE OrthogonalBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Returns the HeirarchicalBasisGradient on Hexahedron - -INTERFACE HeirarchicalBasisGradient_Hexahedron - MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron1( & - & pb1, pb2, pb3, & - & pxy1, pxy2, & - & pxz1, pxz2, & - & pyz1, pyz2, & - & px1, px2, px3, px4, & - & py1, py2, py3, py4, & - & pz1, pz2, pz3, pz4, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3 - !! order of interpolation inside the element in x, y, and z dirs - INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 - !! order of interpolation on facets parallel to xy plane - INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 - !! order of interpolation on facets parallel to xz plane - INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 - !! order of interpolation on facets parallel to yz plane - INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 - !! order of interpolation on edges parallel to x-axis - INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 - !! order of interpolation on edges parallel to y-axis - INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 - !! order of interpolation on edges parallel to z-axis - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & 8_I4B & - & + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & - & + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & - & + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & - & + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & - & + (px1 + px2 + px3 + px4 - 4_I4B) & - & + (py1 + py2 + py3 + py4 - 4_I4B) & - & + (pz1 + pz2 + pz3 + pz4 - 4_I4B), & - & 3_I4B) - END FUNCTION HeirarchicalBasisGradient_Hexahedron1 -END INTERFACE HeirarchicalBasisGradient_Hexahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Returns the HeirarchicalBasisGradient on Hexahedron - -INTERFACE HeirarchicalBasisGradient_Hexahedron - MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron2( & - & p, q, r, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q, r - !! order of interpolation in x, y, and z dirs - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & 8_I4B & - & + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) & - & + (p - 1_I4B) * (q - 1_I4B) * 2_I4B & - & + (p - 1_I4B) * (r - 1_I4B) * 2_I4B & - & + (q - 1_I4B) * (r - 1_I4B) * 2_I4B & - & + (4_I4B * p - 4_I4B) & - & + (4_I4B * q - 4_I4B) & - & + (4_I4B * r - 4_I4B), & - & 3_I4B) - END FUNCTION HeirarchicalBasisGradient_Hexahedron2 -END INTERFACE HeirarchicalBasisGradient_Hexahedron - -END MODULE HexahedronInterpolationUtility diff --git a/src/modules/Polynomial/src/InterpolationUtility.F90 b/src/modules/Polynomial/src/InterpolationUtility.F90 deleted file mode 100644 index fc76c2f07..000000000 --- a/src/modules/Polynomial/src/InterpolationUtility.F90 +++ /dev/null @@ -1,96 +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 InterpolationUtility -USE GlobalData, ONLY: I4B, DFP, REAL32, REAL64 -IMPLICIT NONE -PRIVATE -PUBLIC :: VandermondeMatrix -PUBLIC :: GetTotalInDOF -PUBLIC :: GetTotalDOF - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 July 2022 -! summary: Returns vandermonde matrix - -INTERFACE VandermondeMatrix - MODULE PURE FUNCTION VandermondeMatrix_Real32(order, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - REAL(REAL32), INTENT(IN) :: x(:) - REAL(REAL32) :: ans(SIZE(x), order + 1) - END FUNCTION VandermondeMatrix_Real32 - - MODULE PURE FUNCTION VandermondeMatrix_Real64(order, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - REAL(REAL64), INTENT(IN) :: x(:) - REAL(REAL64) :: ans(SIZE(x), order + 1) - END FUNCTION VandermondeMatrix_Real64 -END INTERFACE VandermondeMatrix - -!---------------------------------------------------------------------------- -! GetTotalDOF -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-20 -! summary: Get total number of degrees of freedom - -INTERFACE GetTotalDOF - MODULE PURE FUNCTION GetTotalDOF1(elemType, order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - !! element type, Point, Line, Triangle - INTEGER(I4B), INTENT(IN) :: order - !! order of interpolation - CHARACTER(LEN=*), INTENT(IN) :: baseContinuity - !! continuity of basis, H1, HDiv, HCurl - CHARACTER(LEN=*), INTENT(IN) :: baseInterpolation - !! interpolation of basis, Lagrange, Heirarchical - INTEGER(I4B) :: ans - !! total number of degrees of freedom - END FUNCTION GetTotalDOF1 -END INTERFACE GetTotalDOF - -!---------------------------------------------------------------------------- -! GetTotalInDOF -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-20 -! summary: Get total number of degrees of freedom internal to the element - -INTERFACE GetTotalInDOF - MODULE PURE FUNCTION GetTotalInDOF1(elemType, order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - !! element type, Point, Line, Triangle - INTEGER(I4B), INTENT(IN) :: order - !! order of interpolation - CHARACTER(LEN=*), INTENT(IN) :: baseContinuity - !! continuity of basis, H1, HDiv, HCurl - CHARACTER(LEN=*), INTENT(IN) :: baseInterpolation - !! interpolation of basis, Lagrange, Heirarchical - INTEGER(I4B) :: ans - !! total number of degrees of freedom - END FUNCTION GetTotalInDOF1 -END INTERFACE GetTotalInDOF - -END MODULE InterpolationUtility diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 deleted file mode 100644 index c8357a7e4..000000000 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ /dev/null @@ -1,1089 +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: 3 Aug 2022 -! summary: Utility related to Jacobi Polynomials is defined. -! -!{!pages/JacobiPolynomialUtility.md!} - -MODULE JacobiPolynomialUtility -USE GlobalData -USE BaseType, ONLY: iface_1DFunction -IMPLICIT NONE -PRIVATE -PUBLIC :: GetJacobiRecurrenceCoeff -PUBLIC :: GetJacobiRecurrenceCoeff2 -PUBLIC :: JacobiAlpha -PUBLIC :: JacobiBeta -PUBLIC :: JacobiLeadingCoeff -PUBLIC :: JacobiLeadingCoeffRatio -PUBLIC :: JacobiNormSQR -PUBLIC :: JacobiNormSQR2 -PUBLIC :: JacobiNormSQRRatio -PUBLIC :: JacobiJacobiMatrix -PUBLIC :: JacobiGaussQuadrature -PUBLIC :: JacobiJacobiRadauMatrix -PUBLIC :: JacobiGaussRadauQuadrature -PUBLIC :: JacobiJacobiLobattoMatrix -PUBLIC :: JacobiGaussLobattoQuadrature -PUBLIC :: JacobiZeros -PUBLIC :: JacobiQuadrature -PUBLIC :: JacobiEvalAll -PUBLIC :: JacobiEval -PUBLIC :: JacobiEvalSum -PUBLIC :: JacobiGradientEval -PUBLIC :: JacobiGradientEvalAll -PUBLIC :: JacobiGradientEvalSum -PUBLIC :: JacobiTransform -PUBLIC :: JacobiInvTransform -PUBLIC :: JacobiGradientCoeff -PUBLIC :: JacobiDMatrix - -!---------------------------------------------------------------------------- -! GetJacobiRecurrenceCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Return the recurrence coefficient for nth order monic polynomial -! -!# Introduction -! -! These recurrence coefficients are for monic jacobi polynomials. - -INTERFACE - MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff(n, alpha, beta, & - & alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial, it should be greater than 1 - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) - REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) - END SUBROUTINE GetJacobiRecurrenceCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! GetJacobiRecurrenceCoeff2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Return the recurrence coefficient for nth order polynomial -! -!# Introduction -! -! These recurrence coefficients are for non-monic jacobi polynomials. -! -!$$ -! P_{n+1}^{(\alpha,\beta)}=\left(a_{n}x+b_{n}\right)P_{n}^{(\alpha,\beta)} -! -c_{n}P_{n-1}^{(\alpha,\beta)},\quad n=1,2,\cdots -!$$ - -INTERFACE - MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff2(n, alpha, beta, & - & A, B, C) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial, it should be greater than 1 - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(OUT) :: A(0:n - 1) - REAL(DFP), INTENT(OUT) :: B(0:n - 1) - REAL(DFP), INTENT(OUT) :: C(0:n - 1) - END SUBROUTINE GetJacobiRecurrenceCoeff2 -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiAlpha -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Returns reccurence coeff alpha - -INTERFACE - MODULE ELEMENTAL PURE FUNCTION JacobiAlpha(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha in Jacobi poly - REAL(DFP), INTENT(IN) :: beta - !! beta in Jacobi poly - REAL(DFP) :: ans - !! answer - END FUNCTION JacobiAlpha -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiBeta -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Returns reccurence coeff beta - -INTERFACE - MODULE ELEMENTAL PURE FUNCTION JacobiBeta(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha in Jacobi poly - REAL(DFP), INTENT(IN) :: beta - !! beta in Jacobi poly - REAL(DFP) :: ans - !! answer - END FUNCTION JacobiBeta -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiLeadingCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Leading coefficient of Jacobi polynomial - -INTERFACE - MODULE PURE FUNCTION JacobiLeadingCoeff(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha in Jacobi poly - REAL(DFP), INTENT(IN) :: beta - !! beta in Jacobi poly - REAL(DFP) :: ans - !! answer - END FUNCTION JacobiLeadingCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiLeadingCoeffRatio -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Leading coefficient ratio of Jacobi polynomial, n+1/n - -INTERFACE - MODULE PURE FUNCTION JacobiLeadingCoeffRatio(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha in Jacobi poly - REAL(DFP), INTENT(IN) :: beta - !! beta in Jacobi poly - REAL(DFP) :: ans - !! answer - END FUNCTION JacobiLeadingCoeffRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiNormSQR -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Square norm of Jacobi polynomial -! -!# Introduction -! -! This function returns the following -! -!$$ -!\Vert P_{n}^{\alpha,\beta}\Vert_{d\lambda}^{2}=\int_{-1}^{+1}P_{n}^ -!{\alpha,\beta}P_{n}^{\alpha,\beta}(1-x)^{\alpha}(1+x)^{\beta}dx -!$$ - -INTERFACE - MODULE PURE FUNCTION JacobiNormSQR(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP) :: ans - END FUNCTION JacobiNormSQR -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiNormSQR2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Square norm of Jacobi polynomial -! -!# Introduction -! -! This function returns the following -! -!$$ -!\Vert P_{n}^{\alpha,\beta}\Vert_{d\lambda}^{2}=\int_{-1}^{+1}P_{n}^ -!{\alpha,\beta}P_{n}^{\alpha,\beta}(1-x)^{\alpha}(1+x)^{\beta}dx -!$$ - -INTERFACE - MODULE PURE FUNCTION JacobiNormSQR2(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP) :: ans(0:n) - END FUNCTION JacobiNormSQR2 -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiNormSQRRatio -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Ratio of Square norm of Jacobi polynomial n+1/n - -INTERFACE - MODULE PURE FUNCTION JacobiNormSQRRatio(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP) :: ans - END FUNCTION JacobiNormSQRRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiJacobiMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE JacobiJacobiMatrix(n, alpha, beta, D, E, & - & alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of jacobu poly - REAL(DFP), INTENT(IN) :: beta - !! beta of jacobi poly - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n-1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE JacobiJacobiMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiGaussQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss quadrature points for Jacobi Polynomial -! -!# Introduction -! -! This routine computes the n Gauss-Quadrature points. Which, -! are n zeros of a jacobi polynomial defined with respect to the -! weight $(1-x)^{\alpha} (1+x)^{\beta}$. -! -! All Gauss-Quadrature points are inside $(-1, 1)$ - -INTERFACE - MODULE SUBROUTINE JacobiGaussQuadrature(n, alpha, beta, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! It represents the order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(OUT) :: pt(:) - !! the size is 1 to n - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! the size is 1 to n - END SUBROUTINE JacobiGaussQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiJacobiRadauMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE JacobiJacobiRadauMatrix(a, n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff) - REAL(DFP), INTENT(IN) :: a - !! one of the end of the domain - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of jacobu poly - REAL(DFP), INTENT(IN) :: beta - !! beta of jacobi poly - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+1 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE JacobiJacobiRadauMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiGaussRadauQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss-Radau quadrature points for Jacobi Polynomial -! -!# Introduction -! -! This routine returns the $n+1$ Quadrature points and weights. -! -! The Gauss-Radau quadrature points consists one of the end points denoted -! by $a$. So $a$ can be $\pm 1$. The remaining $n$ points are internal to -! to $(-1, +1)$, and they are n-zeros of Jacobi polynomial of order n with -! respect to the following weight. -! -!- $(1-x)^{\alpha} (1+x)^{\beta} (x+1)$ if $a=-1$. -!- $(1-x)^{\alpha} (1+x)^{\beta} (1-x)$ if $a=+1$. -! -! Here n is the order of Jacobi polynomial. -! -! If $a=1$ then n+1 quadrature point will be +1 -! If $a=-1$ then 1st quadrature point will be -1 - -INTERFACE - MODULE SUBROUTINE JacobiGaussRadauQuadrature(a, n, alpha, beta, pt, wt) - REAL(DFP), INTENT(IN) :: a - !! the value of one of the end points - !! it should be either -1 or +1 - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial - REAL(DFP), INTENT(OUT) :: pt(:) - !! n+1 quadrature points from 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! n+1 weights from 1 to n+1 - END SUBROUTINE JacobiGaussRadauQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiJacobiLobattoMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE JacobiJacobiLobattoMatrix(n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of jacobu poly - REAL(DFP), INTENT(IN) :: beta - !! beta of jacobi poly - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+2 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE JacobiJacobiLobattoMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiGaussLobattoQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss-Lobatto quadrature points for Jacobi Polynomial -! -!# Introduction -! -! This routine returns the $n+2$ Quadrature points and weights. -! -! The Gauss-Lobatto quadrature points consists both $\pm 1$ as -! quadrature points. -! -!- The first quadrature point is $-1$ -!- The second quadrature point is $+1$ -! -! The remaining $n$ points are internal to -! to $(-1, +1)$, and they are n-zeros of Jacobi polynomial of order n with -! respect to the following weight. -! -!$$(1-x)^{\alpha} (1+x)^{\beta} (x+1)(1-x)$$ -! -! Here n is the order of Jacobi polynomial. - -INTERFACE - MODULE SUBROUTINE JacobiGaussLobattoQuadrature(n, alpha, beta, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomials - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(OUT) :: pt(:) - !! n+2 quad points indexed from 1 to n+2 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! n+2 weights, index from 1 to n+2 - END SUBROUTINE JacobiGaussLobattoQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiZeros -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Returns zeros of Jacobi polynomials - -INTERFACE - MODULE FUNCTION JacobiZeros(n, alpha, beta) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP) :: ans(n) - END FUNCTION JacobiZeros -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: This routine can return Jacobi-Gauss, Jacobi-Radau, Jacobi-Lobatto -! -!# Introduction -! -! This routine returns the Quadrature point of Jacobi polynomial -! -!@note -! Here n is the number of quadrature points. Please note it is not -! the order of jacobi polynomial. The order is decided internally -! depending upon the quadType -!@endnote -! -!@note -! pt and wt should be allocated outside, and length should be n. -!@endnote -! - -INTERFACE - MODULE SUBROUTINE JacobiQuadrature(n, alpha, beta, pt, wt, quadType) - INTEGER(I4B), INTENT(IN) :: n - !! number of quadrature points, the order will be computed as follows - !! for quadType = Gauss, n is same as order of Jacobi polynomial - !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 - !! for quadType = GaussLobatto, n = order+2 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial - REAL(DFP), INTENT(OUT) :: pt(n) - !! n+1 quadrature points from 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) - !! n+1 weights from 1 to n+1 - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss - !! GaussRadauLeft - !! GaussRadauRight - !! GaussLobatto - END SUBROUTINE JacobiQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobiEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Jacobi polynomials from order = 0 to n at single points -! -!# Introduction -! -! Evaluate Jacobi polynomials from order = 0 to n at single points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(1:N+1), the values of the first N+1 Jacobi polynomials at x - -INTERFACE JacobiEvalAll - MODULE PURE FUNCTION JacobiEvalAll1(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(n + 1) - !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION JacobiEvalAll1 -END INTERFACE JacobiEvalAll - -!---------------------------------------------------------------------------- -! JacobiEvalUpto -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Jacobi polynomial of order = 0 to n at several points -! -!# Introduction -! -! Evaluate Jacobi polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Jacobi polynomials at the point -! X. - -INTERFACE JacobiEvalAll - MODULE PURE FUNCTION JacobiEvalAll2(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION JacobiEvalAll2 -END INTERFACE JacobiEvalAll - -!---------------------------------------------------------------------------- -! JacobiEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Jacobi polynomials of order n at single points. -! -!# Introduction -! -! Evaluate Jacobi polynomials of order n at single points. -! -!- N, the order of polynomial to compute. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. - -INTERFACE JacobiEval - MODULE PURE FUNCTION JacobiEval1(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiEval1 -END INTERFACE JacobiEval - -!---------------------------------------------------------------------------- -! JacobiEvalUpto -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Jacobi polynomials of order n at several points -! -!# Introduction -! -! Evaluate Jacobi polynomials of order n at several points -! -!- N, the order of polynomial to compute. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. - -INTERFACE JacobiEval - MODULE PURE FUNCTION JacobiEval2(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiEval2 -END INTERFACE JacobiEval - -!---------------------------------------------------------------------------- -! JacobiEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Jacobi polynomials at point x - -INTERFACE JacobiEvalSum - MODULE PURE FUNCTION JacobiEvalSum1(n, alpha, beta, x, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi Polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiEvalSum1 -END INTERFACE JacobiEvalSum - -!---------------------------------------------------------------------------- -! JacobiEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Jacobi polynomials at several x - -INTERFACE JacobiEvalSum - MODULE PURE FUNCTION JacobiEvalSum2(n, alpha, beta, x, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi Polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiEvalSum2 -END INTERFACE JacobiEvalSum - -!---------------------------------------------------------------------------- -! JacobiGradientEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Oct 2022 -! summary: Evaluate Gradient of Jacobi polynomial - -INTERFACE JacobiGradientEval - MODULE PURE FUNCTION JacobiGradientEval1(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha > -1.0 - REAL(DFP), INTENT(IN) :: beta - !! beta > -1.0 - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP) :: ans - !! Derivative of Jacobi polynomial of order n at point x - END FUNCTION JacobiGradientEval1 -END INTERFACE JacobiGradientEval - -!---------------------------------------------------------------------------- -! JacobiGradientEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Oct 2022 -! summary: Evaluate Gradient of Jacobi polynomial - -INTERFACE JacobiGradientEval - MODULE PURE FUNCTION JacobiGradientEval2(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x)) - !! Derivative of Jacobi polynomial of order n at x - END FUNCTION JacobiGradientEval2 -END INTERFACE JacobiGradientEval - -!---------------------------------------------------------------------------- -! JacobiGradientEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Oct 2022 -! summary: Evaluate Gradient of Jacobi polynomial - -INTERFACE JacobiGradientEvalAll - MODULE PURE FUNCTION JacobiGradientEvalAll1(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha > -1.0 - REAL(DFP), INTENT(IN) :: beta - !! beta > -1.0 - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP) :: ans(n + 1) - !! Derivative of Jacobi polynomial of order n at point x - END FUNCTION JacobiGradientEvalAll1 -END INTERFACE JacobiGradientEvalAll - -!---------------------------------------------------------------------------- -! JacobiGradientEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Oct 2022 -! summary: Evaluate Gradient of Jacobi polynomial - -INTERFACE JacobiGradientEvalAll - MODULE PURE FUNCTION JacobiGradientEvalAll2(n, alpha, beta, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x), n + 1) - !! Derivative of Jacobi polynomial of order n at x - END FUNCTION JacobiGradientEvalAll2 -END INTERFACE JacobiGradientEvalAll - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Jacobi polynomials at -! point x - -INTERFACE JacobiGradientEvalSum - MODULE PURE FUNCTION JacobiGradientEvalSum1(n, alpha, beta, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi Polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiGradientEvalSum1 -END INTERFACE JacobiGradientEvalSum - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Jacobi polynomials at -! several x - -INTERFACE JacobiGradientEvalSum - MODULE PURE FUNCTION JacobiGradientEvalSum2(n, alpha, beta, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi Polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiGradientEvalSum2 -END INTERFACE JacobiGradientEvalSum - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth derivative of finite sum of Jacobi polynomials at -! point x - -INTERFACE JacobiGradientEvalSum - MODULE PURE FUNCTION JacobiGradientEvalSum3(n, alpha, beta, x, coeff, k) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi Polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! order of derivative - REAL(DFP) :: ans - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiGradientEvalSum3 -END INTERFACE JacobiGradientEvalSum - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth gradient of finite sum of Jacobi polynomials at -! several x - -INTERFACE JacobiGradientEvalSum - MODULE PURE FUNCTION JacobiGradientEvalSum4(n, alpha, beta, x, coeff, k) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi Polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! kth order derivative - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Jacobi polynomial of order n at point x - END FUNCTION JacobiGradientEvalSum4 -END INTERFACE JacobiGradientEvalSum - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Jacobi Transform - -INTERFACE JacobiTransform - MODULE PURE FUNCTION JacobiTransform1(n, alpha, beta, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION JacobiTransform1 -END INTERFACE JacobiTransform - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Jacobi Transform - -INTERFACE JacobiTransform - MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION JacobiTransform2 -END INTERFACE JacobiTransform - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Jacobi Transform of a function on [-1,1] -! -!# Introduction -! -! This function performs the jacobi transformation of a function defined -! on -1 to 1. The interface of the function is give below: -! -!```fortran -! ABSTRACT INTERFACE -! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) -! IMPORT :: DFP -! REAL(DFP), INTENT(IN) :: x -! REAL(DFP) :: ans -! END FUNCTION iface_1DFunction -! END INTERFACE -!``` -! -!@note -! This routine is not pure, because this subroutine calls `JacobiQuadrature` -! which is not pure due to Lapack call. -!@endnote - -INTERFACE JacobiTransform - MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial > -1.0_DFP - PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f - !! 1D space function - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION JacobiTransform3 -END INTERFACE JacobiTransform - -!---------------------------------------------------------------------------- -! JacobiInvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Jacobi Transform - -INTERFACE JacobiInvTransform - MODULE PURE FUNCTION JacobiInvTransform1(n, alpha, beta, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x - !! x point in physical space - REAL(DFP) :: ans - !! value in physical space - END FUNCTION JacobiInvTransform1 -END INTERFACE JacobiInvTransform - -!---------------------------------------------------------------------------- -! JacobiInvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Jacobi Transform - -INTERFACE JacobiInvTransform - MODULE PURE FUNCTION JacobiInvTransform2(n, alpha, beta, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x(:) - !! x point in physical space - REAL(DFP) :: ans(SIZE(x)) - !! value in physical space - END FUNCTION JacobiInvTransform2 -END INTERFACE JacobiInvTransform - -!---------------------------------------------------------------------------- -! JacobiGradientCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Returns coefficient for gradient of Jacobi expansion -! -!# Introduction -! -! This routine returns the coefficients of gradient of Jacobi expansion. -! Input is cofficients of Jacobipolynomials (modal values). -! - -INTERFACE JacobiGradientCoeff - MODULE PURE FUNCTION JacobiGradientCoeff1(n, alpha, beta, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha > -1.0 - REAL(DFP), INTENT(IN) :: beta - !! beta > -1.0 - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! coefficients $\tilde{u}_{n}$ obtained from JacobiTransform - REAL(DFP) :: ans(0:n) - !! coefficient of gradient - END FUNCTION JacobiGradientCoeff1 -END INTERFACE JacobiGradientCoeff - -!---------------------------------------------------------------------------- -! JacobiDMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Returns coefficient for gradient of Jacobi expansion -! -!# Introduction -! -! This routine returns the coefficients of gradient of Jacobi expansion. -! Input is cofficients of Jacobipolynomials (modal values). -! - -INTERFACE JacobiDMatrix - MODULE PURE FUNCTION JacobiDMatrix1(n, alpha, beta, x, quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha > -1.0 - REAL(DFP), INTENT(IN) :: beta - !! beta > -1.0 - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss and GaussLobatto - REAL(DFP) :: ans(0:n, 0:n) - !! D matrix - END FUNCTION JacobiDMatrix1 -END INTERFACE JacobiDMatrix - -END MODULE JacobiPolynomialUtility diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 deleted file mode 100644 index a5c151d8c..000000000 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ /dev/null @@ -1,456 +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: 18 Oct 2022 -! summary: Methods for Lagrange polynomials are defined -! -!{!pages/LagrangePolynomialUtility.md!} - -MODULE LagrangePolynomialUtility -USE GlobalData, ONLY: DFP, I4B, LGT -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE -PUBLIC :: LagrangeDOF -PUBLIC :: LagrangeInDOF -PUBLIC :: LagrangeDegree -PUBLIC :: LagrangeVandermonde -PUBLIC :: LagrangeVandermonde_ -PUBLIC :: EquidistancePoint -PUBLIC :: InterpolationPoint -PUBLIC :: LagrangeCoeff -PUBLIC :: RefCoord -PUBLIC :: RefElemDomain -PUBLIC :: LagrangeEvalAll -PUBLIC :: LagrangeGradientEvalAll - -!---------------------------------------------------------------------------- -! RefElemDomain -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain(elemType, baseContinuity, baseInterpol) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - !! Element type - CHARACTER(*), INTENT(IN) :: baseContinuity - !! Cointinuity (conformity) of basis functions - !! "H1", "HDiv", "HCurl", "DG" - CHARACTER(*), INTENT(IN) :: baseInterpol - !! Basis function family for Interpolation - !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal - TYPE(String) :: ans - END FUNCTION RefElemDomain -END INTERFACE - -!---------------------------------------------------------------------------- -! RefCoord -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE PURE FUNCTION RefCoord(elemType, refElem) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - !! Element type - CHARACTER(*), INTENT(IN) :: refElem - !! "UNIT" - !! "BIUNIT" - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION RefCoord -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDOF@BasisMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the number of dof for lagrange polynomial - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF(order, elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - !! number of degree of freedom - END FUNCTION LagrangeDOF -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF@BasisMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the number of internal dof for lagrange polynomial - -INTERFACE - MODULE PURE FUNCTION LagrangeInDOF(order, elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - !! number of degree of freedom - END FUNCTION LagrangeInDOF -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the degrees of monomials for lagrange polynomial - -INTERFACE - MODULE PURE FUNCTION LagrangeDegree(order, elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: elemType - !! Element type: Line, Triangle, Quadrangle, Tetrahedron, ... - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeVandermonde -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the Vandermonde matrix - -INTERFACE - MODULE PURE FUNCTION LagrangeVandermonde(xij, order, elemType) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in $x_{iJ}$ format - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! vandermonde matrix - !! nrows := number of points - !! ncols := number of dof - END FUNCTION LagrangeVandermonde -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeVandermonde -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the Vandermonde matrix - -INTERFACE - MODULE PURE SUBROUTINE LagrangeVandermonde_(xij, order, elemType, ans, & - nrow, ncol) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in $x_{iJ}$ format - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! vandermonde matrix - !! nrows := number of points - !! ncols := number of dof - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeVandermonde_ -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistancePoint -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Equidistance points on 1D/2D/3D elements - -INTERFACE - MODULE FUNCTION EquidistancePoint( & - & order, & - & elemType, & - & xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of element - INTEGER(I4B), INTENT(IN) :: elemType - !! Element type - !! Point, Line, Triangle, Quadrangle, Tetrahedron - !! Hexahedron, Prism, Pyramid - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of linear elements - !! Default values: - !! Biunit line - !! Unit triangle - !! Biunit Quadrangle - !! Unit Tetrahedron - !! Biunit Hexahedron - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Equidistance points in xij format - !! Number of rows = nsd - !! Number of columns = Number of points - !! The number of points depend upon the order and elemType - END FUNCTION EquidistancePoint -END INTERFACE - -!---------------------------------------------------------------------------- -! InterpolationPoint -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Get the interpolation point - -INTERFACE - MODULE FUNCTION InterpolationPoint( & - & order, & - & elemType, & - & ipType, & - & xij, & - & layout, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of interpolation - INTEGER(I4B), INTENT(IN) :: elemType - !! element type, following values are allowed. - !! Point, Line, Triangle, Quadrangle, Tetrahedron - !! Hexahedron, Prism, Pyramid - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, - !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto, - !! GaussUltraspherical, GaussUltrasphericalLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of linear elements. - !! Domain of interpolation, default values are given by: - !! Biunit line - !! Unit triangle - !! Biunit Quadrangle - !! Unit Tetrahedron - !! Biunit Hexahedron - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" Vertex, Edge, Face, Cell - !! "INCREASING" incresing order - !! "DECREASING" decreasing order - !! "XYZ" First X, then Y, then Z - !! "YXZ" First Y, then X, then Z - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! Jacobi and Ultraspherical parameters - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION InterpolationPoint -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Returns the coefficient of ith lagrange poly - -INTERFACE LagrangeCoeff - MODULE FUNCTION LagrangeCoeff1(order, elemType, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff1 -END INTERFACE LagrangeCoeff - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Returns the coefficient of all lagrange poly - -INTERFACE LagrangeCoeff - MODULE FUNCTION LagrangeCoeff2(order, elemType, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff2 -END INTERFACE LagrangeCoeff - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff - MODULE FUNCTION LagrangeCoeff3(order, elemType, i, v, & - & isVandermonde) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff3 -END INTERFACE LagrangeCoeff - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff - MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff4 -END INTERFACE LagrangeCoeff - -!---------------------------------------------------------------------------- -! LagrangeEvalAll -!---------------------------------------------------------------------------- - -INTERFACE LagrangeEvalAll - MODULE FUNCTION LagrangeEvalAll1( & - & order, & - & elemType, & - & x, & - & xij, & - & domainName, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Lagrange polynomials - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - REAL(DFP), INTENT(IN) :: x(:, :) - !! Point of evaluation - !! x(1, :) is x coord - !! x(2, :) is y coord - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), INTENT(IN) :: domainName - !! domain of reference element - !! UNIT - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Jacobi=Dubiner - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll1 -END INTERFACE LagrangeEvalAll - -!---------------------------------------------------------------------------- -! LagrangeEvalAll -!---------------------------------------------------------------------------- - -INTERFACE LagrangeGradientEvalAll - MODULE FUNCTION LagrangeGradientEvalAll1( & - & order, & - & elemType, & - & x, & - & xij, & - & domainName, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Lagrange polynomials - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - REAL(DFP), INTENT(IN) :: x(:, :) - !! Point of evaluation - !! x(1, :) is x coord - !! x(2, :) is y coord - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), INTENT(IN) :: domainName - !! domain of reference element - !! UNIT - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Jacobi=Dubiner - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), SIZE(x, 1)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeGradientEvalAll1 -END INTERFACE LagrangeGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE LagrangePolynomialUtility diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 deleted file mode 100644 index 9c7ff28b6..000000000 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ /dev/null @@ -1,1150 +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: 3 Aug 2022 -! summary: Utility related to Legendre Polynomials is defined. -! -!{!pages/LegendrePolynomialUtility.md!} - -MODULE LegendrePolynomialUtility -USE GlobalData -USE BaseType, ONLY: iface_1DFunction -IMPLICIT NONE -PRIVATE -PUBLIC :: LegendreAlpha -PUBLIC :: LegendreBeta -PUBLIC :: GetLegendreRecurrenceCoeff -PUBLIC :: GetLegendreRecurrenceCoeff2 -PUBLIC :: LegendreLeadingCoeff -PUBLIC :: LegendreLeadingCoeffRatio -PUBLIC :: LegendreNormSQR -PUBLIC :: LegendreNormSQR2 -PUBLIC :: LegendreNormSqrRatio -PUBLIC :: LegendreJacobiMatrix -PUBLIC :: LegendreGaussQuadrature -PUBLIC :: LegendreJacobiRadauMatrix -PUBLIC :: LegendreGaussRadauQuadrature -PUBLIC :: LegendreJacobiLobattoMatrix -PUBLIC :: LegendreGaussLobattoQuadrature -PUBLIC :: LegendreZeros -PUBLIC :: LegendreQuadrature -PUBLIC :: LegendreEval -PUBLIC :: LegendreEvalAll -PUBLIC :: LegendreMonomialExpansionAll -PUBLIC :: LegendreMonomialExpansion -PUBLIC :: LegendreGradientEvalAll -PUBLIC :: LegendreGradientEval -PUBLIC :: LegendreEvalSum -PUBLIC :: LegendreGradientEvalSum -PUBLIC :: LegendreTransform -PUBLIC :: LegendreInvTransform -PUBLIC :: LegendreGradientCoeff -PUBLIC :: LegendreDMatrix -PUBLIC :: LegendreDMatEvenOdd - -!---------------------------------------------------------------------------- -! LegendreAlpha -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Recurrence coefficient, alpha, of Legendre polynomial - -INTERFACE - MODULE PURE FUNCTION LegendreAlpha(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION LegendreAlpha -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreBeta -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Recurrence coefficient, beta, of Legendre polynomial - -INTERFACE - MODULE PURE FUNCTION LegendreBeta(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION LegendreBeta -END INTERFACE - -!---------------------------------------------------------------------------- -! GetLegendreRecurrenceCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Return the recurrence coefficient for monic Legendre polynomial -! -!# Introduction -! -! These recurrence coefficients are for monic Legendre polynomials. -! -!$$ -! \pi_{n+1}=\left(x-\alpha_{n}\right)\pi_{n}-\beta_{n}\pi_{n-1},\quad n=0,1,2 -!$$ -! -!$$ -! \alpha_{n}=0,n\ge0 -!$$ -! -!$$ -! \beta_{0}=2 -!$$ -! -!$$ -! \beta_{n\ge1}=\frac{n^{2}}{4n^{2}-1} -!$$ - -INTERFACE - MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff(n, alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial, it should be greater than 1 - REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) - REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) - END SUBROUTINE GetLegendreRecurrenceCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! GetLegendreRecurrenceCoeff2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Return the recurrence coefficient for Legendre polynomial - -INTERFACE - MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff2(n, A, B, C) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial, it should be greater than 1 - REAL(DFP), INTENT(OUT) :: A(0:n - 1) - !! size is n - REAL(DFP), INTENT(OUT) :: B(0:n - 1) - !! this coefficient is zero - REAL(DFP), INTENT(OUT) :: C(0:n - 1) - !! size is n - END SUBROUTINE GetLegendreRecurrenceCoeff2 -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreLeadingCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Leading coefficient of Legendre polynomial -! -!# Introduction -! -! Leading coefficient of legendre polynomial -! -!$$ -! k_{n}=\frac{\left(2n\right)!}{2^{n}\left(n!\right)^{2}} -!$$ -! - -INTERFACE - MODULE PURE FUNCTION LegendreLeadingCoeff(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION LegendreLeadingCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreLeadingCoeffRatio -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Ration of Leading coefficient of Legendre polynomial n+1/n - -INTERFACE - MODULE PURE FUNCTION LegendreLeadingCoeffRatio(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION LegendreLeadingCoeffRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreNormSQR -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Square norm of Legendre polynomial -! -!# Introduction -! -! This function returns the square norm of legendre polynomial -! -!$$ -! \Vert P_{n}\Vert^{2}=:h_{n}=\frac{2}{2n+1} -!$$ - -INTERFACE - MODULE PURE FUNCTION LegendreNormSQR(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans - END FUNCTION LegendreNormSQR -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreNormSQR2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Square norm of Legendre polynomial -! -!# Introduction -! -! This function returns the square norm of legendre polynomial -! -!$$ -! \Vert P_{n}\Vert^{2}=:h_{n}=\frac{2}{2n+1} -!$$ - -INTERFACE - MODULE PURE FUNCTION LegendreNormSQR2(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(0:n) - END FUNCTION LegendreNormSQR2 -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreNormSQRRatio -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Ratio of Square norm of Legendre polynomial n+1/n - -INTERFACE - MODULE PURE FUNCTION LegendreNormSQRRatio(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans - END FUNCTION LegendreNormSQRRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreJacobiMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Return the Jacobi matrix for Legendre polynomial - -INTERFACE - MODULE PURE SUBROUTINE LegendreJacobiMatrix(n, D, E, alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n-1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - !! recurrence coefficient of monic legendre polynomial, from 0 to n-1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - !! recurrence coefficient of monic legendre polynomial, from 0 to n-1 - END SUBROUTINE LegendreJacobiMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreGaussQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss quadrature points for Legendre Polynomial -! -!# Introduction -! -! This routine computes the n Gauss-Quadrature points. Which, -! are n zeros of a Legendre polynomial defined with respect to the -! weight $(1-x)^{\alpha} (1+x)^{\beta}$. -! -! All Gauss-Quadrature points are inside $(-1, 1)$ - -INTERFACE - MODULE SUBROUTINE LegendreGaussQuadrature(n, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! It represents the order of Legendre polynomial - REAL(DFP), INTENT(OUT) :: pt(:) - !! the size is 1 to n - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! the size is 1 to n - END SUBROUTINE LegendreGaussQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreJacobiRadauMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE LegendreJacobiRadauMatrix(a, n, D, E, alphaCoeff, & - & betaCoeff) - REAL(DFP), INTENT(IN) :: a - !! one of the end of the domain - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+1 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE LegendreJacobiRadauMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreGaussRadauQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss-Radau quadrature points for Legendre Polynomial -! -!# Introduction -! -! This routine returns the $n+1$ Quadrature points and weights. -! -! The Gauss-Radau quadrature points consists one of the end points denoted -! by $a$. So $a$ can be $\pm 1$. The remaining $n$ points are internal to -! to $(-1, +1)$, and they are n-zeros of Legendre polynomial of order n with -! respect to the following weight. -! -!- $(1-x)^{\alpha} (1+x)^{\beta} (x+1)$ if $a=-1$. -!- $(1-x)^{\alpha} (1+x)^{\beta} (1-x)$ if $a=+1$. -! -! Here n is the order of Legendre polynomial. -! -! If $a=1$ then n+1 quadrature point will be +1 -! If $a=-1$ then 1st quadrature point will be -1 - -INTERFACE - MODULE SUBROUTINE LegendreGaussRadauQuadrature(a, n, pt, wt) - REAL(DFP), INTENT(IN) :: a - !! the value of one of the end points - !! it should be either -1 or +1 - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP), INTENT(OUT) :: pt(:) - !! n+1 quadrature points from 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! n+1 weights from 1 to n+1 - END SUBROUTINE LegendreGaussRadauQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreLegendreLobattoMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE LegendreJacobiLobattoMatrix(n, D, E, alphaCoeff, & - & betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+2 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE LegendreJacobiLobattoMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreGaussLobattoQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss-Lobatto quadrature points for Legendre Polynomial -! -!# Introduction -! -! This routine returns the $n+2$ Quadrature points and weights. -! -! The Gauss-Lobatto quadrature points consists both $\pm 1$ as -! quadrature points. -! -!- The first quadrature point is $-1$ -!- The second quadrature point is $+1$ -! -! The remaining $n$ points are internal to -! to $(-1, +1)$, and they are n-zeros of Legendre polynomial of order n with -! respect to the following weight. -! -!$$(1-x)^{\alpha} (1+x)^{\beta} (x+1)(1-x)$$ -! -! Here n is the order of Legendre polynomial. - -INTERFACE - MODULE SUBROUTINE LegendreGaussLobattoQuadrature(n, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomials - REAL(DFP), INTENT(OUT) :: pt(:) - !! n+2 quad points indexed from 1 to n+2 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! n+2 weights, index from 1 to n+2 - END SUBROUTINE LegendreGaussLobattoQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreZeros -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Returns zeros of Legendre polynomials - -INTERFACE - MODULE FUNCTION LegendreZeros(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP) :: ans(n) - END FUNCTION LegendreZeros -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: This routine can return Legendre-Gauss, Legendre-Radau, -! Legendre-Lobatto -! -!# Introduction -! -! This routine returns the Quadrature point of Legendre polynomial -! -!@note -! Here n is the number of quadrature points. Please note it is not -! the order of Legendre polynomial. The order is decided internally -! depending upon the quadType -!@endnote -! -!@note -! pt and wt should be allocated outside, and length should be n. -!@endnote -! - -INTERFACE - MODULE SUBROUTINE LegendreQuadrature(n, pt, wt, quadType, onlyInside) - INTEGER(I4B), INTENT(IN) :: n - !! number of quadrature points, the order will be computed as follows - !! for quadType = Gauss, n is same as order of Legendre polynomial - !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 - !! for quadType = GaussLobatto, n = order+2 - REAL(DFP), INTENT(OUT) :: pt(n) - !! n+1 quadrature points from 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) - !! n+1 weights from 1 to n+1 - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss - !! GaussRadauLeft - !! GaussRadauRight - !! GaussLobatto - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside - !! only inside - END SUBROUTINE LegendreQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Legendre polynomial of order n at single points -! -!# Introduction -! -! Evaluate Legendre polynomial of order n at single points - -INTERFACE - MODULE PURE FUNCTION LegendreEval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point of evaluation, it should be between -1 and 1 - REAL(DFP) :: ans - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreEval1 -END INTERFACE - -INTERFACE LegendreEval - MODULE PROCEDURE LegendreEval1 -END INTERFACE LegendreEval - -!---------------------------------------------------------------------------- -! LegendreEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Legendre polynomials of order n at several points -! -!# Introduction -! -! Evaluate Legendre polynomials of order n at several points - -INTERFACE - MODULE PURE FUNCTION LegendreEval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! several points of evaluation - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Legendre polynomial of order n at points x - END FUNCTION LegendreEval2 -END INTERFACE - -INTERFACE LegendreEval - MODULE PROCEDURE LegendreEval2 -END INTERFACE LegendreEval - -!---------------------------------------------------------------------------- -! LegendreEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Legendre polynomials from order = 0 to n at single point -! -!# Introduction -! -! Evaluate Legendre polynomials from order = 0 to n at single points -! -!- x: the point at which the polynomials are to be evaluated. - -INTERFACE - MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! Highest order of polynomial. - !! Polynomials from 0 to n will be computed. - REAL(DFP), INTENT(IN) :: x - !! Point of evaluation, $x \in [-1, 1]$ - REAL(DFP) :: ans(n + 1) - !! Evaluate Legendre polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION LegendreEvalAll1 -END INTERFACE - -INTERFACE LegendreEvalAll - MODULE PROCEDURE LegendreEvalAll1 -END INTERFACE LegendreEvalAll - -!---------------------------------------------------------------------------- -! LegendreEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Legendre polynomials from order = 0 to n at several points -! -!# Introduction -! -! Evaluate Legendre polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point -! X. -! -!- the ith row of ans denotes the values of all polynomials at -! ith point. In this case shape of ans is (M,1:N+1), where M is number of -! points, N+1 number of polynomials. So ans(j, :) denotes value of all -! polynomials at jth point, and ans(:, n) denotes value of Pn at all nodes - -INTERFACE - MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! Highest order of polynomial. - !! Polynomials from 0 to n will be computed. - REAL(DFP), INTENT(IN) :: x(:) - !! number of points, SIZE(x)=M - REAL(DFP) :: ans(SIZE(x), n + 1) - !! shape (M,N+1) - END FUNCTION LegendreEvalAll2 -END INTERFACE - -INTERFACE LegendreEvalAll - MODULE PROCEDURE LegendreEvalAll2 -END INTERFACE LegendreEvalAll - -!---------------------------------------------------------------------------- -! LegendreMonomialExpansionAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Returns the monomial expansion of all legendre polynomials -! -!# Introduction -! -! Returns all the monomial expansion of all legendre polynomials -! -!- n : is the order of the polynomial -!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 -! -! for example, n=5, we have following structure of ans -! -! | P0 | P1 | P2 | P3 | P4 | P5 | -! |----|----|------|------|-------|-------| -! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | -! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | -! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | -! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | -! | 0 | 0 | 0 | 0 | 4.375 | 0 | -! | 0 | 0 | 0 | 0 | 0 | 7.875 | - -INTERFACE - MODULE PURE FUNCTION LegendreMonomialExpansionAll(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1, 1:n + 1) - END FUNCTION LegendreMonomialExpansionAll -END INTERFACE - -!---------------------------------------------------------------------------- -! LegendreMonomialExpansion -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Returns the monomial expansion of a legendre polynomials -! -!# Introduction -! -! Returns all the monomial expansion of a legendre polynomials -! -!- n : is the order of the polynomial -!- ans(:) contains the coefficient of monomials for polynomial order=n -! - -INTERFACE - MODULE PURE FUNCTION LegendreMonomialExpansion(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1) - END FUNCTION LegendreMonomialExpansion -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of legendre polynomial of order upto n - -INTERFACE LegendreGradientEvalAll - MODULE PURE FUNCTION LegendreGradientEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(1:n + 1) - END FUNCTION LegendreGradientEvalAll1 -END INTERFACE LegendreGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of legendre polynomial of order upto n - -INTERFACE LegendreGradientEvalAll - MODULE PURE FUNCTION LegendreGradientEvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) - END FUNCTION LegendreGradientEvalAll2 -END INTERFACE LegendreGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of legendre polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of legendre polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION LegendreGradientEval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION LegendreGradientEval1 -END INTERFACE -!! - -INTERFACE LegendreGradientEval - MODULE PROCEDURE LegendreGradientEval1 -END INTERFACE LegendreGradientEval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of legendre polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of legendre polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION LegendreGradientEval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x)) - END FUNCTION LegendreGradientEval2 -END INTERFACE -!! - -INTERFACE LegendreGradientEval - MODULE PROCEDURE LegendreGradientEval2 -END INTERFACE LegendreGradientEval - -!---------------------------------------------------------------------------- -! LegendreEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Legendre polynomials at point x - -INTERFACE - MODULE PURE FUNCTION LegendreEvalSum1(n, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreEvalSum1 -END INTERFACE - -INTERFACE LegendreEvalSum - MODULE PROCEDURE LegendreEvalSum1 -END INTERFACE LegendreEvalSum - -!---------------------------------------------------------------------------- -! LegendreEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Legendre polynomials at several x - -INTERFACE - MODULE PURE FUNCTION LegendreEvalSum2(n, x, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreEvalSum2 -END INTERFACE - -INTERFACE LegendreEvalSum - MODULE PROCEDURE LegendreEvalSum2 -END INTERFACE LegendreEvalSum - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Legendre polynomials -! at point x - -INTERFACE - MODULE PURE FUNCTION LegendreGradientEvalSum1(n, x, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreGradientEvalSum1 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum1 -END INTERFACE LegendreGradientEvalSum - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Legendre polynomials -! at several x - -INTERFACE - MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreGradientEvalSum2 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum2 -END INTERFACE LegendreGradientEvalSum - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth derivative of finite sum of Legendre -! polynomials at point x - -INTERFACE - MODULE PURE FUNCTION LegendreGradientEvalSum3(n, x, coeff, k) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! order of derivative - REAL(DFP) :: ans - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreGradientEvalSum3 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum3 -END INTERFACE LegendreGradientEvalSum - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth gradient of finite sum of Legendre -! polynomials at several x - -INTERFACE - MODULE PURE FUNCTION LegendreGradientEvalSum4(n, x, coeff, k) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! kth order derivative - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreGradientEvalSum4 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum4 -END INTERFACE LegendreGradientEvalSum - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Legendre Transform - -INTERFACE - MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomials - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION LegendreTransform1 -END INTERFACE - -INTERFACE LegendreTransform - MODULE PROCEDURE LegendreTransform1 -END INTERFACE LegendreTransform - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Legendre Transform - -INTERFACE - MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION LegendreTransform2 -END INTERFACE - -INTERFACE LegendreTransform - MODULE PROCEDURE LegendreTransform2 -END INTERFACE LegendreTransform - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Legendre Transform of a function on [-1,1] -! -!# Introduction -! -! This function performs the Legendre transformation of f defined -! on -1 to 1. The interface of the function is give below: -! -!```fortran -! ABSTRACT INTERFACE -! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) -! IMPORT :: DFP -! REAL(DFP), INTENT(IN) :: x -! REAL(DFP) :: ans -! END FUNCTION iface_1DFunction -! END INTERFACE -!``` -! -!@note -! This routine is not pure, because this subroutine calls -! `LegendreQuadrature` which is not pure due to Lapack call. -!@endnote - -INTERFACE - MODULE FUNCTION LegendreTransform3(n, f, quadType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f - !! 1D space function - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION LegendreTransform3 -END INTERFACE - -INTERFACE LegendreTransform - MODULE PROCEDURE LegendreTransform3 -END INTERFACE LegendreTransform - -!---------------------------------------------------------------------------- -! LegendreInvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Inverse Legendre Transform - -INTERFACE - MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x - !! x point in physical space - REAL(DFP) :: ans - !! value in physical space - END FUNCTION LegendreInvTransform1 -END INTERFACE - -INTERFACE LegendreInvTransform - MODULE PROCEDURE LegendreInvTransform1 -END INTERFACE LegendreInvTransform - -!---------------------------------------------------------------------------- -! LegendreInvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Inverse Legendre Transform - -INTERFACE - MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x(:) - !! x point in physical space - REAL(DFP) :: ans(SIZE(x)) - !! value in physical space - END FUNCTION LegendreInvTransform2 -END INTERFACE - -INTERFACE LegendreInvTransform - MODULE PROCEDURE LegendreInvTransform2 -END INTERFACE LegendreInvTransform - -!---------------------------------------------------------------------------- -! LegendreGradientCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Returns coefficients for gradient of Legendre expansion -! -!# Introduction -! -!- This routine returns the coefficients of gradient of Jacobi expansion. -!- Input is coefficient of Legendre expansion (modal values) -!- Output is coefficient of derivative of legendre expansion (modal values) - -INTERFACE - MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! coefficients $\tilde{u}_{n}$ obtained from LegendreTransform - REAL(DFP) :: ans(0:n) - !! coefficient of gradient - END FUNCTION LegendreGradientCoeff1 -END INTERFACE - -INTERFACE LegendreGradientCoeff - MODULE PROCEDURE LegendreGradientCoeff1 -END INTERFACE LegendreGradientCoeff - -!---------------------------------------------------------------------------- -! LegendreDMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 Oct 2022 -! summary: Returns differentiation matrix for Legendre expansion - -INTERFACE - MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss and GaussLobatto - REAL(DFP) :: ans(0:n, 0:n) - !! D matrix - END FUNCTION LegendreDMatrix1 -END INTERFACE - -INTERFACE LegendreDMatrix - MODULE PROCEDURE LegendreDMatrix1 -END INTERFACE LegendreDMatrix - -!---------------------------------------------------------------------------- -! LegendreDMatEvenOdd -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 15 Oct 2022 -! summary: Performs even and odd decomposition of Differential matrix - -INTERFACE - MODULE PURE SUBROUTINE LegendreDMatEvenOdd1(n, D, e, o) - INTEGER(I4B), INTENT(IN) :: n - !! order of Legendre polynomial - REAL(DFP), INTENT(IN) :: D(0:n, 0:n) - !! n+1 by n+1 - REAL(DFP), INTENT(OUT) :: e(0:, 0:) - !! even Decomposition, 0:n/2, 0:n/2 - REAL(DFP), INTENT(OUT) :: o(0:, 0:) - !! odd decomposition, 0:n/2, 0:n/2 - END SUBROUTINE LegendreDMatEvenOdd1 -END INTERFACE - -INTERFACE LegendreDMatEvenOdd - MODULE PROCEDURE LegendreDMatEvenOdd1 -END INTERFACE LegendreDMatEvenOdd - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE LegendrePolynomialUtility diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 deleted file mode 100644 index dda86c81d..000000000 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ /dev/null @@ -1,1179 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE LineInterpolationUtility -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE - -PUBLIC :: LagrangeDegree_Line -PUBLIC :: LagrangeDOF_Point -PUBLIC :: LagrangeDOF_Line -PUBLIC :: LagrangeInDOF_Line -PUBLIC :: GetTotalDOF_Line -PUBLIC :: GetTotalInDOF_Line -PUBLIC :: EquidistanceInPoint_Line -PUBLIC :: EquidistancePoint_Line -PUBLIC :: InterpolationPoint_Line -PUBLIC :: LagrangeCoeff_Line -PUBLIC :: LagrangeEvalAll_Line -PUBLIC :: LagrangeGradientEvalAll_Line -PUBLIC :: BasisEvalAll_Line -PUBLIC :: BasisGradientEvalAll_Line -PUBLIC :: QuadraturePoint_Line -PUBLIC :: ToVEFC_Line -PUBLIC :: QuadratureNumber_Line -PUBLIC :: RefElemDomain_Line -PUBLIC :: HeirarchicalBasis_Line -PUBLIC :: HeirarchicalGradientBasis_Line -PUBLIC :: OrthogonalBasis_Line -PUBLIC :: OrthogonalBasisGradient_Line - -!---------------------------------------------------------------------------- -! RefElemDomain_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain_Line(baseContinuity, baseInterpol) & - & RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseContinuity - !! Cointinuity (conformity) of basis functions - !! "H1", "HDiv", "HCurl", "DG" - CHARACTER(*), INTENT(IN) :: baseInterpol - !! Basis function family for Interpolation - !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal - TYPE(String) :: ans - END FUNCTION RefElemDomain_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! QuadratureNumber_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: REturns the number of quadrature points necessary for given order - -INTERFACE - MODULE PURE FUNCTION QuadratureNumber_Line(order, quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: quadType - INTEGER(I4B) :: ans - END FUNCTION QuadratureNumber_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! ToVEFC_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Change layour of points on line - -INTERFACE - MODULE PURE SUBROUTINE ToVEFC_Line(pt) - REAL(DFP), INTENT(INOUT) :: pt(:) - END SUBROUTINE ToVEFC_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE - MODULE PURE FUNCTION LagrangeDegree_Line(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDOF_Point -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on a point of Line - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF_Point(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Point -END INTERFACE - -!---------------------------------------------------------------------------- -! GetDOF_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Line - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF_Line(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Line -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Line -!- These dof are strictly inside the line - -INTERFACE - MODULE PURE FUNCTION LagrangeInDOF_Line(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! GetTotalDOF_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Line - -INTERFACE - MODULE PURE FUNCTION GetTotalDOF_Line(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalDOF_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Line -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Line -!- These dof are strictly inside the line - -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Line(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance internal points on edge -! -!# Introduction -! -!- This function returns the equidistance points on edge in 1D -!- All points are inside the interval -!- Points are in increasing order - -INTERFACE EquidistanceInPoint_Line - MODULE PURE FUNCTION EquidistanceInPoint_Line1(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), INTENT(IN) :: xij(2) - !! coordinates of point 1 and point 2 - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION EquidistanceInPoint_Line1 -END INTERFACE EquidistanceInPoint_Line - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points on edge -! -!# Introduction -! -!- This function returns the equidistance points on edge in 1D, 2D, 3D -!- The end points are specified by `xij(1:nsd, 1)` and `xij(1:nsd, 2)` -! -!- All points are inside the interval -!- The number of space components in `ans` is nsd if xij present -!- Otherwise, the number of space components in `ans` is 1. - -INTERFACE EquidistanceInPoint_Line - MODULE PURE FUNCTION EquidistanceInPoint_Line2(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 2 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Equidistnace points in $x_{iJ}$ format - !! The number of rows is equal to the number of rows in xij - !! (if xij present), otherwise, it is 1. - END FUNCTION EquidistanceInPoint_Line2 -END INTERFACE EquidistanceInPoint_Line - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points on edge -! -!# Introduction -! -!- This function returns the equidistance points on edge -!- Points are in "VEFC" format, which means `xij(1,1:2)` are end points - -INTERFACE EquidistancePoint_Line - MODULE PURE FUNCTION EquidistancePoint_Line1(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), INTENT(IN) :: xij(2) - !! coorindates of point 1 and point 2 - REAL(DFP), ALLOCATABLE :: ans(:) - !! equidistance points - END FUNCTION EquidistancePoint_Line1 -END INTERFACE EquidistancePoint_Line - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points on line -! -!# Introduction -! -!- This function returns the equidistance points on line -!- All points are inside the interval - -INTERFACE EquidistancePoint_Line - MODULE PURE FUNCTION EquidistancePoint_Line2(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 2 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! equidistance points in $x_{iJ}$ format - !! If xij is not present, then number of rows in ans - !! is 1. If `xij` is present then the number of rows in - !! ans is same as xij. - END FUNCTION EquidistancePoint_Line2 -END INTERFACE EquidistancePoint_Line - -!---------------------------------------------------------------------------- -! InterpolationPoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Aug 2022 -! summary: Returns the interpolation point -! -!# Introduction -! -!- This routine returns the interplation points on line -!- `xij` contains nodal coordinates of line in xij format. -!- SIZE(xij,1) = nsd, and SIZE(xij,2)=2 -!- If xij is absent then [-1,1] is used -!- `ipType` is interpolation point type, it can take following values -!- `Equidistance`, uniformly/evenly distributed points -!- `GaussLegendre`, Zeros of Legendre polynomials, all nodes are strictly -! inside the domain. -!- `GaussLegendreLobatto` or `GaussLobatto` are zeros of Lobatto polynomials -! they always contains boundary points -!- `GaussChebyshev` Zeros of Chebyshev polynomials of first kind, all -! nodes are internal -!- `GaussChebyshevLobatto` they contains boundary points -!- `GaussJacobi` and `GaussJacobiLobatto` -! -!- `layout` specifies the arrangement of points. Following options are -! possible: -! -!- `layout=VEFC` vertex, edge, face, cell, in this case first two points are -! boundary points, remaining (from 3 to n) are internal points in -! increasing order. -! -!- `layout=INCREASING` points are arranged in increasing order - -INTERFACE InterpolationPoint_Line - MODULE FUNCTION InterpolationPoint_Line1(order, ipType, & - & layout, xij, alpha, beta, lambda) RESULT(ans) - !! - INTEGER(I4B), INTENT(IN) :: order - !! Order of interpolation - INTEGER(I4B), INTENT(IN) :: ipType - !! Interpolation point type - !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, - !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! domain of interpolation - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - !! size(ans,1) = 1 - !! size(ans,2) = order+1 - END FUNCTION InterpolationPoint_Line1 -END INTERFACE InterpolationPoint_Line - -!---------------------------------------------------------------------------- -! InterpolationPoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Aug 2022 -! summary: Returns the interpolation point - -INTERFACE InterpolationPoint_Line - MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, & - & layout, alpha, beta, lambda) RESULT(ans) - !! - INTEGER(I4B), INTENT(IN) :: order - !! order of interpolation - INTEGER(I4B), INTENT(IN) :: ipType - !! Interpolation point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto - REAL(DFP), INTENT(IN) :: xij(2) - !! end points - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - !! "DECREASING" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:) - !! one dimensional interpolation point - END FUNCTION InterpolationPoint_Line2 -END INTERFACE InterpolationPoint_Line - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Line - MODULE FUNCTION LagrangeCoeff_Line1(order, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(xij,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) = order+1 - REAL(DFP) :: ans(order + 1) - !! coefficients - END FUNCTION LagrangeCoeff_Line1 -END INTERFACE LagrangeCoeff_Line - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Line - MODULE FUNCTION LagrangeCoeff_Line2(order, i, v, isVandermonde) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(order + 1) - !! coefficients - END FUNCTION LagrangeCoeff_Line2 -END INTERFACE LagrangeCoeff_Line - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Line - MODULE FUNCTION LagrangeCoeff_Line3(order, i, v, ipiv) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(order + 1) - !! coefficients - END FUNCTION LagrangeCoeff_Line3 -END INTERFACE LagrangeCoeff_Line - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Line - MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(xij,2)-1 - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) = order+1 - REAL(DFP) :: ans(order + 1, order + 1) - !! coefficients - !! jth column of ans corresponds to the coeff of lagrange polynomial - !! at the jth point - END FUNCTION LagrangeCoeff_Line4 -END INTERFACE LagrangeCoeff_Line - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Line - MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, & - & beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(xij,2)-1 - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) = order+1 - INTEGER(I4B), INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - !! jth column of ans corresponds to the coeff of lagrange polynomial - !! at the jth point - END FUNCTION LagrangeCoeff_Line5 -END INTERFACE LagrangeCoeff_Line - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Lagrange polynomials of order n at single points - -INTERFACE LagrangeEvalAll_Line - MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, & - & basisType, alpha, beta, lambda) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! interpolation points - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Line1 -END INTERFACE LagrangeEvalAll_Line - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Lagrange polynomials of n at several points - -INTERFACE LagrangeEvalAll_Line - MODULE FUNCTION LagrangeEvalAll_Line2( & - & order, x, xij, coeff, firstCall, & - & basisType, alpha, beta, lambda) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! point of evaluation in xij format - !! size(xij, 1) = nsd - !! size(xij, 2) = number of points - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! interpolation points - !! xij should be present when firstCall is true. - !! It is used for computing the coeff - !! If coeff is absent then xij should be present - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - !! ans(:, j) is the value of jth polynomial at x points - !! ans(i, :) is the value of all polynomials at x(i) point - END FUNCTION LagrangeEvalAll_Line2 -END INTERFACE LagrangeEvalAll_Line - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Lagrange polynomials of n at several points - -INTERFACE LagrangeGradientEvalAll_Line - MODULE FUNCTION LagrangeGradientEvalAll_Line1( & - & order, & - & x, & - & xij, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! point of evaluation in xij format - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! interpolation points - !! xij should be present when firstCall is true. - !! It is used for computing the coeff - !! If coeff is absent then xij should be present - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 1) - !! Value of gradient of nth order Lagrange polynomials at point x - !! The first index denotes point of evaluation - !! the second index denotes Lagrange polynomial number - !! The third index denotes the spatial dimension in which gradient is - !! computed - END FUNCTION LagrangeGradientEvalAll_Line1 -END INTERFACE LagrangeGradientEvalAll_Line - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate basis functions of order upto n - -INTERFACE BasisEvalAll_Line - MODULE FUNCTION BasisEvalAll_Line1( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomials - REAL(DFP), INTENT(IN) :: x - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refLine - !! Refline should be BIUNIT - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(order + 1) - !! Value of n+1 polynomials at point x - END FUNCTION BasisEvalAll_Line1 -END INTERFACE BasisEvalAll_Line - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate basis functions of order upto n - -INTERFACE BasisEvalAll_Line - MODULE FUNCTION BasisEvalAll_Line2( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomials - REAL(DFP), INTENT(IN) :: x(:) - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x), order + 1) - !! Value of n+1 polynomials at point x - !! ans(:, j) is the value of jth polynomial at x points - !! ans(i, :) is the value of all polynomials at x(i) point - END FUNCTION BasisEvalAll_Line2 -END INTERFACE BasisEvalAll_Line - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate basis functions of order upto n - -INTERFACE OrthogonalBasis_Line - MODULE FUNCTION OrthogonalBasis_Line1( & - & order, & - & xij, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomials - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - !! Number of rows in xij is 1 - CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT - INTEGER(I4B), INTENT(IN) :: basisType - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2), order + 1) - !! Value of n+1 polynomials at point x - !! ans(:, j) is the value of jth polynomial at x points - !! ans(i, :) is the value of all polynomials at x(i) point - END FUNCTION OrthogonalBasis_Line1 -END INTERFACE OrthogonalBasis_Line - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate basis functions of order upto n - -INTERFACE OrthogonalBasisGradient_Line - MODULE FUNCTION OrthogonalBasisGradient_Line1( & - & order, & - & xij, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomials - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - !! Number of rows in xij is 1 - CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT - INTEGER(I4B), INTENT(IN) :: basisType - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2), order + 1, 1) - !! Value of n+1 polynomials at point x - !! ans(:, j) is the value of jth polynomial at x points - !! ans(i, :) is the value of all polynomials at x(i) point - END FUNCTION OrthogonalBasisGradient_Line1 -END INTERFACE OrthogonalBasisGradient_Line - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Line - -INTERFACE HeirarchicalBasis_Line - MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Polynomial order of interpolation - REAL(DFP), INTENT(IN) :: xij(:, :) - !! Points of evaluation in xij format - CHARACTER(*), INTENT(IN) :: refLine - !! This parameter denotes the type of reference line. - !! It can take following values: - !! UNIT: in this case xij is in unit Line. - !! BIUNIT: in this case xij is in biunit Line. - REAL(DFP) :: ans(SIZE(xij, 2), order + 1) - !! Hierarchical basis - END FUNCTION HeirarchicalBasis_Line1 -END INTERFACE HeirarchicalBasis_Line - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line - -INTERFACE HeirarchicalGradientBasis_Line - MODULE FUNCTION HeirarchicalGradientBasis_Line1( & - & order, & - & xij, & - & refLine) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Polynomial order of interpolation - REAL(DFP), INTENT(IN) :: xij(:, :) - !! Points of evaluation in xij format - !! size(xij, 1) should be 1 - CHARACTER(*), INTENT(IN) :: refLine - !! This parameter denotes the type of reference line. - !! It can take following values: - !! UNIT: in this case xij is in unit Line. - !! BIUNIT: in this case xij is in biunit Line. - REAL(DFP) :: ans(SIZE(xij, 2), order + 1, 1) - !! Gradient of Hierarchical basis - END FUNCTION HeirarchicalGradientBasis_Line1 -END INTERFACE HeirarchicalGradientBasis_Line - -!---------------------------------------------------------------------------- -! BasisGradientEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate the gradient of basis functions of order upto n - -INTERFACE BasisGradientEvalAll_Line - MODULE FUNCTION BasisGradientEvalAll_Line1( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomials - REAL(DFP), INTENT(IN) :: x - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refLine - !! Refline should be BIUNIT - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(order + 1) - !! Value of n+1 polynomials at point x - END FUNCTION BasisGradientEvalAll_Line1 -END INTERFACE BasisGradientEvalAll_Line - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate gradient of basis functions of order upto n - -INTERFACE BasisGradientEvalAll_Line - MODULE FUNCTION BasisGradientEvalAll_Line2( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomials - REAL(DFP), INTENT(IN) :: x(:) - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x), order + 1) - !! Value of n+1 polynomials at point x - !! ans(:, j) is the value of jth polynomial at x points - !! ans(i, :) is the value of all polynomials at x(i) point - END FUNCTION BasisGradientEvalAll_Line2 -END INTERFACE BasisGradientEvalAll_Line - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points - -INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line1( & - & order, & - & quadType, & - & layout, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - !! - INTEGER(I4B), INTENT(IN) :: order - !! Order of interpolation - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature point type - !! Equidistance, - !! GaussLegendre, - !! GaussLegendreLobatto, - !! GaussChebyshev, - !! GaussChebyshevLobatto, - !! GaussJacobi, - !! GaussJacobiLobatto - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! domain of interpolation - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! quadrature points - !! If xij is present then the number of rows in ans - !! is same as size(xij,1) + 1. - !! If xij is not present then the number of rows in - !! ans is 2 - !! The last row of ans contains the weights - !! The first few rows contains the quadrature points - END FUNCTION QuadraturePoint_Line1 -END INTERFACE QuadraturePoint_Line - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Aug 2022 -! summary: Returns the interpolation point - -INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line2( & - & order, & - & quadType, & - & xij, & - & layout, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of interpolation - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto - REAL(DFP), INTENT(IN) :: xij(2) - !! end points - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! one dimensional interpolation point - END FUNCTION QuadraturePoint_Line2 -END INTERFACE QuadraturePoint_Line - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points - -INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line3( & - & nips, & - & quadType, & - & layout, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - !! - INTEGER(I4B), INTENT(IN) :: nips(1) - !! Order of interpolation - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature point type - !! Equidistance, - !! GaussLegendre, - !! GaussLegendreLobatto, - !! GaussChebyshev, - !! GaussChebyshevLobatto, - !! GaussJacobi, - !! GaussJacobiLobatto - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! domain of interpolation - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! quadrature points - !! If xij is present then the number of rows in ans - !! is same as size(xij,1) + 1. - !! If xij is not present then the number of rows in - !! ans is 2 - !! The last row of ans contains the weights - !! The first few rows contains the quadrature points - END FUNCTION QuadraturePoint_Line3 -END INTERFACE QuadraturePoint_Line - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Aug 2022 -! summary: Returns the interpolation point - -INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line4( & - & nips, & - & quadType, & - & xij, & - & layout, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nips(1) - !! order of interpolation - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto - REAL(DFP), INTENT(IN) :: xij(2) - !! end points - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! one dimensional interpolation point - END FUNCTION QuadraturePoint_Line4 -END INTERFACE QuadraturePoint_Line - -END MODULE LineInterpolationUtility diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 deleted file mode 100644 index 9d7e15c4e..000000000 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ /dev/null @@ -1,495 +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: 3 Aug 2022 -! summary: Utility related to Lobatto Polynomials is defined. -! -!{!pages/LobattoPolynomialUtility.md!} - -MODULE LobattoPolynomialUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: LobattoLeadingCoeff -PUBLIC :: LobattoZeros -PUBLIC :: LobattoEval -PUBLIC :: LobattoEvalAll -PUBLIC :: LobattoKernelEvalAll -PUBLIC :: LobattoKernelEvalAll_ -PUBLIC :: LobattoKernelGradientEvalAll -PUBLIC :: LobattoKernelGradientEvalAll_ -PUBLIC :: LobattoMonomialExpansionAll -PUBLIC :: LobattoMonomialExpansion -PUBLIC :: LobattoGradientEvalAll -PUBLIC :: LobattoGradientEval -PUBLIC :: LobattoMassMatrix -PUBLIC :: LobattoStiffnessMatrix - -!---------------------------------------------------------------------------- -! LobattoLeadingCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Leading coefficient of Lobatto polynomial - -INTERFACE - MODULE PURE FUNCTION LobattoLeadingCoeff(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Lobatto polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION LobattoLeadingCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Square norm of Lobatto polynomial -! - -INTERFACE - MODULE PURE FUNCTION LobattoNormSQR(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans - END FUNCTION LobattoNormSQR -END INTERFACE - -!---------------------------------------------------------------------------- -! LobattoZeros -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Returns zeros of Lobatto polynomials - -INTERFACE - MODULE FUNCTION LobattoZeros(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Lobatto polynomial, should be greater than equal to 2 - REAL(DFP) :: ans(n) - !! - END FUNCTION LobattoZeros -END INTERFACE - -!---------------------------------------------------------------------------- -! LobattoEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Lobatto polynomials from order = 0 to n at several points -! -!# Introduction -! -! Evaluate Lobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point -! X. - -INTERFACE - MODULE PURE FUNCTION LobattoEval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - !! Evaluate Lobatto polynomial of order n at point x - END FUNCTION LobattoEval1 -END INTERFACE - -INTERFACE LobattoEval - MODULE PROCEDURE LobattoEval1 -END INTERFACE LobattoEval - -!---------------------------------------------------------------------------- -! LobattoEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Lobatto polynomials from order = 0 to n at several points -! -!# Introduction -! -! Evaluate Lobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point -! X. - -INTERFACE - MODULE PURE FUNCTION LobattoEval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Lobatto polynomial of order n at point x - END FUNCTION LobattoEval2 -END INTERFACE - -INTERFACE LobattoEval - MODULE PROCEDURE LobattoEval2 -END INTERFACE LobattoEval - -!---------------------------------------------------------------------------- -! LobattoEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Lobatto polynomials from order = 0 to n at several points -! -!# Introduction -! -! Evaluate Lobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point -! X. - -INTERFACE - MODULE PURE FUNCTION LobattoEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(n + 1) - !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION LobattoEvalAll1 -END INTERFACE - -INTERFACE LobattoEvalAll - MODULE PROCEDURE LobattoEvalAll1 -END INTERFACE LobattoEvalAll - -!---------------------------------------------------------------------------- -! LobattoEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Lobatto polynomials from order = 0 to n at several points -! -!# Introduction -! -! Evaluate Lobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point -! X. - -INTERFACE - MODULE PURE FUNCTION LobattoEvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION LobattoEvalAll2 -END INTERFACE - -INTERFACE LobattoEvalAll - MODULE PROCEDURE LobattoEvalAll2 -END INTERFACE LobattoEvalAll - -!---------------------------------------------------------------------------- -! LobattoKernelEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Lobatto bubble functions order = 0 to n at several points -! -!# Introduction -! -! Evaluate Lobatto bubble polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. -!- x: the point at which the polynomials are to be evaluated. - -INTERFACE LobattoKernelEvalAll - MODULE PURE FUNCTION LobattoKernelEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x), 0:n) - !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION LobattoKernelEvalAll1 -END INTERFACE LobattoKernelEvalAll - -!---------------------------------------------------------------------------- -! LobattoKernelEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Lobatto bubble functions order = 0 to n at several points -! -!# Introduction -! -! Evaluate Lobatto bubble polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. -!- x: the point at which the polynomials are to be evaluated. - -INTERFACE LobattoKernelEvalAll_ - MODULE PURE SUBROUTINE LobattoKernelEvalAll1_(n, x, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: n - !! n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: ans(1:, 0:) - !! ans(1:SIZE(x), 0:n) - !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) - !! at point x - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LobattoKernelEvalAll1_ -END INTERFACE LobattoKernelEvalAll_ - -!---------------------------------------------------------------------------- -! LobattoKernelGradientEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Gradient of Lobatto bubbles of order = 0 to n - -INTERFACE LobattoKernelGradientEvalAll - MODULE PURE FUNCTION LobattoKernelGradientEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x), 0:n) - !! Gradient of Lobatto bubbles of order 0 to n - END FUNCTION LobattoKernelGradientEvalAll1 -END INTERFACE LobattoKernelGradientEvalAll - -!---------------------------------------------------------------------------- -! LobattoKernelGradientEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Gradient of Lobatto bubbles of order = 0 to n - -INTERFACE LobattoKernelGradientEvalAll_ - MODULE PURE SUBROUTINE LobattoKernelGradientEvalAll1_(n, x, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: n - !! n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: ans(1:, 0:) - ! ans(1:SIZE(x), 0:n) - !! Gradient of Lobatto bubbles of order 0 to n - INTEGER(I4B), INTENT(OUT) :: nrow - INTEGER(I4B), INTENT(OUT) :: ncol - END SUBROUTINE LobattoKernelGradientEvalAll1_ -END INTERFACE LobattoKernelGradientEvalAll_ - -!---------------------------------------------------------------------------- -! LobattoMonomialExpansionAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Returns the monomial expansion of all Lobatto polynomials -! -!# Introduction -! -! Returns all the monomial expansion of all Lobatto polynomials -! -!- n : is the order of the polynomial -!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 -! -! for example, n=5, we have following structure of ans -! -! | P0 | P1 | P2 | P3 | P4 | P5 | -! |----|----|------|------|-------|-------| -! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | -! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | -! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | -! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | -! | 0 | 0 | 0 | 0 | 4.375 | 0 | -! | 0 | 0 | 0 | 0 | 0 | 7.875 | - -INTERFACE - MODULE PURE FUNCTION LobattoMonomialExpansionAll(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1, 1:n + 1) - END FUNCTION LobattoMonomialExpansionAll -END INTERFACE - -!---------------------------------------------------------------------------- -! LobattoMonomialExpansion -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Returns the monomial expansion of a Lobatto polynomials -! -!# Introduction -! -! Returns all the monomial expansion of a Lobatto polynomials -! -!- n : is the order of the polynomial -!- ans(:) contains the coefficient of monomials for polynomial order=n -! - -INTERFACE - MODULE PURE FUNCTION LobattoMonomialExpansion(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1) - END FUNCTION LobattoMonomialExpansion -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Lobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Lobatto polynomial of order upto n. - -INTERFACE LobattoGradientEvalAll - MODULE PURE FUNCTION LobattoGradientEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(1:n + 1) - END FUNCTION LobattoGradientEvalAll1 -END INTERFACE LobattoGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Lobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Lobatto polynomial of order upto n. - -INTERFACE LobattoGradientEvalAll - MODULE PURE FUNCTION LobattoGradientEvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) - END FUNCTION LobattoGradientEvalAll2 -END INTERFACE LobattoGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Lobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Lobatto polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION LobattoGradientEval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION LobattoGradientEval1 -END INTERFACE -!! - -INTERFACE LobattoGradientEval - MODULE PROCEDURE LobattoGradientEval1 -END INTERFACE LobattoGradientEval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Lobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Lobatto polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION LobattoGradientEval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x)) - END FUNCTION LobattoGradientEval2 -END INTERFACE - -INTERFACE LobattoGradientEval - MODULE PROCEDURE LobattoGradientEval2 -END INTERFACE LobattoGradientEval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Lobatto mass matrix - -INTERFACE - MODULE PURE FUNCTION LobattoMassMatrix(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(n + 1, n + 1) - END FUNCTION LobattoMassMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Lobatto mass matrix - -INTERFACE - MODULE PURE FUNCTION LobattoStiffnessMatrix(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(n + 1, n + 1) - END FUNCTION LobattoStiffnessMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE LobattoPolynomialUtility diff --git a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 deleted file mode 100644 index 5e4783126..000000000 --- a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 +++ /dev/null @@ -1,226 +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 OrthogonalPolynomialUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Clenshaw -PUBLIC :: ChebClenshaw -PUBLIC :: JacobiMatrix -PUBLIC :: EvalAllOrthopol -PUBLIC :: GradientEvalAllOrthopol - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Clenshaw_1(x, alpha, beta, y0, ym1, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP), INTENT(IN) :: alpha(0:) - REAL(DFP), INTENT(IN) :: beta(0:) - REAL(DFP), OPTIONAL, INTENT(IN) :: y0 - !! if y0 is absent then y0 = 1.0 - REAL(DFP), OPTIONAL, INTENT(IN) :: ym1 - !! if ym1 is absent then ym1 = 0.0 - REAL(DFP), INTENT(IN) :: c(0:) - REAL(DFP) :: ans - END FUNCTION Clenshaw_1 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE Clenshaw_1 -END INTERFACE Clenshaw - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Clenshaw_2(x, alpha, beta, y0, ym1, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(IN) :: alpha(0:) - REAL(DFP), INTENT(IN) :: beta(0:) - REAL(DFP), OPTIONAL, INTENT(IN) :: y0 - !! if y0 is absent then y0 = 1.0 - REAL(DFP), OPTIONAL, INTENT(IN) :: ym1 - !! if ym1 is absent then ym1 = 0.0 - REAL(DFP), INTENT(IN) :: c(0:) - REAL(DFP) :: ans(SIZE(x)) - END FUNCTION Clenshaw_2 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE Clenshaw_2 -END INTERFACE Clenshaw - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2021 -! summary: CleanShaw for Chebyshev -! -!# Introduction -! -! ClenShaw for Chebyshev polynomial expansion. It returns : -! -!$$ -! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x) -!$$ - -INTERFACE - MODULE PURE FUNCTION ChebClenshaw_1(x, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP), INTENT(IN) :: c(0:) - REAL(DFP) :: ans - END FUNCTION ChebClenshaw_1 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE ChebClenshaw_1 -END INTERFACE Clenshaw - -INTERFACE ChebClenshaw - MODULE PROCEDURE ChebClenshaw_1 -END INTERFACE ChebClenshaw - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2021 -! summary: CleanShaw for Chebyshev -! -!# Introduction -! -! ClenShaw for Chebyshev polynomial expansion. It returns : -! -!$$ -! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x) -!$$ - -INTERFACE - MODULE PURE FUNCTION ChebClenshaw_2(x, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(IN) :: c(0:) - REAL(DFP) :: ans(SIZE(x)) - END FUNCTION ChebClenshaw_2 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE ChebClenshaw_2 -END INTERFACE Clenshaw - -INTERFACE ChebClenshaw - MODULE PROCEDURE ChebClenshaw_2 -END INTERFACE ChebClenshaw - -!---------------------------------------------------------------------------- -! JacobiMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE JacobiMatrix_1(alphaCoeff, betaCoeff, D, E) - REAL(DFP), INTENT(IN) :: alphaCoeff(0:) - !! size n, from 0 to n-1 - REAL(DFP), INTENT(IN) :: betaCoeff(0:) - !! size n, from 0 to n-1 - REAL(DFP), INTENT(OUT) :: D(:) - !! entry from 1 to n are filled - REAL(DFP), INTENT(OUT) :: E(:) - !! entry from 1 to n-1 are filled - END SUBROUTINE JacobiMatrix_1 -END INTERFACE - -INTERFACE JacobiMatrix - MODULE PROCEDURE JacobiMatrix_1 -END INTERFACE JacobiMatrix - -!---------------------------------------------------------------------------- -! EvalAllOrthopol -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION EvalAllOrthopol(n, x, orthopol, alpha, beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! points of evaluation - INTEGER(I4B), INTENT(IN) :: orthopol - !! orthogonal polynomial family - !! Legendre - !! Jacobi - !! Lobatto - !! Chebyshev - !! Ultraspherical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! alpha1 needed when orthopol1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! beta1 is needed when orthopol1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! lambda1 is needed when orthopol1 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(x), n + 1) - !! The number of rows in ans is equal to the number of points. - !! The number of columns are equal to the orthogonal - !! polynomials from order = 0 to n - !! Therefore, jth column is denotes the value of jth polynomial - !! at all the points. - END FUNCTION EvalAllOrthopol -END INTERFACE - -!---------------------------------------------------------------------------- -! EvalAllOrthopol -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION GradientEvalAllOrthopol( & - & n, & - & x, & - & orthopol, & - & alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! points of evaluation - INTEGER(I4B), INTENT(IN) :: orthopol - !! orthogonal polynomial family - !! Legendre - !! Jacobi - !! Lobatto - !! Chebyshev - !! Ultraspherical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! alpha1 needed when orthopol1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! beta1 is needed when orthopol1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! lambda1 is needed when orthopol1 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(x), n + 1) - !! The number of rows in ans is equal to the number of points. - !! The number of columns are equal to the orthogonal - !! polynomials from order = 0 to n - !! Therefore, jth column is denotes the value of jth polynomial - !! at all the points. - END FUNCTION GradientEvalAllOrthopol -END INTERFACE - -END MODULE OrthogonalPolynomialUtility diff --git a/src/modules/Polynomial/src/PolynomialUtility.F90 b/src/modules/Polynomial/src/PolynomialUtility.F90 deleted file mode 100644 index 362d8fcc0..000000000 --- a/src/modules/Polynomial/src/PolynomialUtility.F90 +++ /dev/null @@ -1,36 +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 PolynomialUtility -USE InterpolationUtility -USE LagrangePolynomialUtility -USE OrthogonalPolynomialUtility -USE JacobiPolynomialUtility -USE UltrasphericalPolynomialUtility -USE LegendrePolynomialUtility -USE LobattoPolynomialUtility -USE UnscaledLobattoPolynomialUtility -USE Chebyshev1PolynomialUtility -USE LineInterpolationUtility -USE TriangleInterpolationUtility -USE QuadrangleInterpolationUtility -USE TetrahedronInterpolationUtility -USE HexahedronInterpolationUtility -USE PrismInterpolationUtility -USE PyramidInterpolationUtility -USE RecursiveNodesUtility -END MODULE PolynomialUtility diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 deleted file mode 100644 index 40ced9a38..000000000 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ /dev/null @@ -1,690 +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 PrismInterpolationUtility -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE -PUBLIC :: LagrangeDegree_Prism -PUBLIC :: LagrangeDOF_Prism -PUBLIC :: LagrangeInDOF_Prism -PUBLIC :: EquidistanceInPoint_Prism -PUBLIC :: EquidistancePoint_Prism -PUBLIC :: InterpolationPoint_Prism -PUBLIC :: LagrangeCoeff_Prism -PUBLIC :: QuadraturePoint_Prism -PUBLIC :: TensorQuadraturePoint_Prism -PUBLIC :: RefElemDomain_Prism -PUBLIC :: LagrangeEvalAll_Prism -PUBLIC :: LagrangeGradientEvalAll_Prism -PUBLIC :: EdgeConnectivity_Prism -PUBLIC :: FacetConnectivity_Prism -PUBLIC :: GetTotalDOF_Prism -PUBLIC :: GetTotalInDOF_Prism - -INTEGER(I4B), PARAMETER :: CONST_tNODES = 6 -INTEGER(I4B), PARAMETER :: CONST_tFACES = 5 -INTEGER(I4B), PARAMETER :: CONST_tEDGES = 9 -INTEGER(I4B), PARAMETER :: CONST_XIDIM = 3 -INTEGER(I4B), PARAMETER :: CONST_MAX_NODES_FACE = 4 -INTEGER(I4B), PARAMETER :: CONST_MIN_NODES_FACE = 3 - -!---------------------------------------------------------------------------- -! GetTotalDOF_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Prism - -INTERFACE - MODULE PURE FUNCTION GetTotalDOF_Prism(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalDOF_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Prism -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Prism -!- These dof are strictly inside the Prism - -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Prism(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-07 -! summary: This function returns the edge connectivity of Prism - -INTERFACE - MODULE PURE FUNCTION EdgeConnectivity_Prism( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(2, CONST_tEDGES) - END FUNCTION EdgeConnectivity_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetConnectivity_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-10 -! summary: This function returns the facet-connectivity of Prism - -INTERFACE - MODULE PURE FUNCTION FacetConnectivity_Prism( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(2 + CONST_MAX_NODES_FACE, CONST_tFACES) - !! ans(1, iface) contains the total nodes in facet (iface) - !! ans(2, iface) contains the integer name of facet element - !! ans(3:2+ans(1,iface), iface ) contains the node numbers - END FUNCTION FacetConnectivity_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! RefElemDomain_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain_Prism(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_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE - MODULE PURE FUNCTION LagrangeDegree_Prism(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDOF_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Prism - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF_Prism(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Prism -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Prism -!- These dof are strictly inside the Prism - -INTERFACE - MODULE PURE FUNCTION LagrangeInDOF_Prism(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in Prism -! -!# Introduction -! -!- This function returns the equidistance points in Prism -!- All points are inside the Prism - -INTERFACE - MODULE PURE FUNCTION EquidistanceInPoint_Prism(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistanceInPoint_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistancePoint_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Prism element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Prism 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 - MODULE PURE FUNCTION EquidistancePoint_Prism(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistancePoint_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! InterpolationPoint_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point on Prism - -INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Prism( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, beta, lambda) & - & RESULT(nodecoord) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - CHARACTER(*), INTENT(IN) :: layout - !! - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coords of vertices in $x_{iJ}$ format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! Jacobi and Ultraspherical parameters - REAL(DFP), ALLOCATABLE :: nodecoord(:, :) - !! interpolation points in $x_{iJ}$ format - END FUNCTION InterpolationPoint_Prism -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Prism - MODULE FUNCTION LagrangeCoeff_Prism1(order, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Prism1 -END INTERFACE LagrangeCoeff_Prism - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Prism - MODULE FUNCTION LagrangeCoeff_Prism2(order, i, v, isVandermonde) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Prism2 -END INTERFACE LagrangeCoeff_Prism - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Prism - MODULE FUNCTION LagrangeCoeff_Prism3(order, i, v, ipiv) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Prism3 -END INTERFACE LagrangeCoeff_Prism - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Prism - MODULE FUNCTION LagrangeCoeff_Prism4(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Prism4 -END INTERFACE LagrangeCoeff_Prism - -!---------------------------------------------------------------------------- -! QuadraturePoints_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: quadrature points on Prism - -INTERFACE QuadraturePoint_Prism - MODULE FUNCTION QuadraturePoint_Prism1(& - & order, & - & quadType, & - & refPrism, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPrism - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3. - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Prism1 -END INTERFACE QuadraturePoint_Prism - -!---------------------------------------------------------------------------- -! QuadraturePoints_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: quadrature points on Prism - -INTERFACE QuadraturePoint_Prism - MODULE FUNCTION QuadraturePoint_Prism2(& - & nips, & - & quadType, & - & refPrism, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nips(1) - !! nips(1) .LE. 79, then we call - !! economical quadrature rules. - !! Otherwise, this routine will retport - !! error - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type, - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPrism - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3 - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Prism2 -END INTERFACE QuadraturePoint_Prism - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points on Prism - -INTERFACE TensorQuadraturePoint_Prism - MODULE FUNCTION TensorQuadraturePoint_Prism1(order, quadType, & - & refPrism, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPrism - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij can be 4. - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Prism1 -END INTERFACE TensorQuadraturePoint_Prism - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points - -INTERFACE TensorQuadraturePoint_Prism - MODULE FUNCTION TensorQuadraturePoint_Prism2( & - & nipsx, & - & nipsy, & - & nipsz, & - & quadType, & - & refPrism, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nipsx(1) - !! number of integration points in x direction - INTEGER(I4B), INTENT(IN) :: nipsy(1) - !! number of integration points in y direction - INTEGER(I4B), INTENT(IN) :: nipsz(1) - !! number of integration points in z direction - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPrism - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3 - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Prism2 -END INTERFACE TensorQuadraturePoint_Prism - -INTERFACE OrthogonalBasisGradient_Prism - MODULE PROCEDURE TensorQuadraturePoint_Prism2 -END INTERFACE OrthogonalBasisGradient_Prism - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Prism - MODULE FUNCTION LagrangeEvalAll_Prism1( & - & order, & - & x, & - & xij, & - & refPrism, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(3) - !! point of evaluation - !! x(1) is x coord - !! x(2) is y coord - !! x(3) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - !! The number of rows in xij is 3 - !! The number of columns in xij should be equal to total - !! degree of freedom - CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be computed and returned - !! by this routine. - !! If firstCall is False, then coeff should be given, which will be - !! used. - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Prism1 -END INTERFACE LagrangeEvalAll_Prism - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Prism - MODULE FUNCTION LagrangeEvalAll_Prism2( & - & order, & - & x, & - & xij, & - & refPrism, & - & 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 - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Prism2 -END INTERFACE LagrangeEvalAll_Prism - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Prism -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: GradientEvaluate all Lagrange polynomials at several points - -INTERFACE LagrangeGradientEvalAll_Prism - MODULE FUNCTION LagrangeGradientEvalAll_Prism1( & - & order, & - & x, & - & xij, & - & refPrism, & - & 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 - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 3) - !! 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_Prism1 -END INTERFACE LagrangeGradientEvalAll_Prism - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE PrismInterpolationUtility diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 deleted file mode 100644 index 12147960d..000000000 --- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 +++ /dev/null @@ -1,701 +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 PyramidInterpolationUtility -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE -PUBLIC :: LagrangeDegree_Pyramid -PUBLIC :: LagrangeDOF_Pyramid -PUBLIC :: LagrangeInDOF_Pyramid -PUBLIC :: EquidistanceInPoint_Pyramid -PUBLIC :: EquidistancePoint_Pyramid -PUBLIC :: InterpolationPoint_Pyramid -PUBLIC :: LagrangeCoeff_Pyramid -PUBLIC :: QuadraturePoint_Pyramid -PUBLIC :: TensorQuadraturePoint_Pyramid -PUBLIC :: RefElemDomain_Pyramid -PUBLIC :: LagrangeEvalAll_Pyramid -PUBLIC :: LagrangeGradientEvalAll_Pyramid -PUBLIC :: EdgeConnectivity_Pyramid -PUBLIC :: FacetConnectivity_Pyramid -PUBLIC :: GetTotalDOF_Pyramid -PUBLIC :: GetTotalInDOF_Pyramid - -INTEGER(I4B), PARAMETER :: CONST_tNODES = 5 -INTEGER(I4B), PARAMETER :: CONST_tFACES = 5 -INTEGER(I4B), PARAMETER :: CONST_tEDGES = 8 -INTEGER(I4B), PARAMETER :: CONST_XIDIM = 3 -INTEGER(I4B), PARAMETER :: CONST_MAX_NODES_FACE = 4 -INTEGER(I4B), PARAMETER :: CONST_MIN_NODES_FACE = 3 - -!---------------------------------------------------------------------------- -! GetTotalDOF_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Pyramid - -INTERFACE - MODULE PURE FUNCTION GetTotalDOF_Pyramid(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalDOF_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Pyramid -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Pyramid -!- These dof are strictly inside the Pyramid - -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Pyramid(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-07 -! summary: This function returns the edge connectivity of Pyramid - -INTERFACE - MODULE PURE FUNCTION EdgeConnectivity_Pyramid( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(2, CONST_tEDGES) - END FUNCTION EdgeConnectivity_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetConnectivity_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-10 -! summary: This function returns the facet-connectivity of Pyramid - -INTERFACE - MODULE PURE FUNCTION FacetConnectivity_Pyramid( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(2 + CONST_MAX_NODES_FACE, CONST_tFACES) - !! ans(1, iface) contains the total nodes in facet (iface) - !! ans(2, iface) contains the integer name of facet element - !! ans(3:2+ans(1,iface), iface ) contains the node numbers - END FUNCTION FacetConnectivity_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! RefElemDomain_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain_Pyramid(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_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE - MODULE PURE FUNCTION LagrangeDegree_Pyramid(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDOF_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Pyramid - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF_Pyramid(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Pyramid -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Pyramid -!- These dof are strictly inside the Pyramid - -INTERFACE - MODULE PURE FUNCTION LagrangeInDOF_Pyramid(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in Pyramid -! -!# Introduction -! -!- This function returns the equidistance points in Pyramid -!- All points are inside the Pyramid - -INTERFACE - MODULE PURE FUNCTION EquidistanceInPoint_Pyramid(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistanceInPoint_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistancePoint_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Pyramid element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Pyramid 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 - MODULE PURE FUNCTION EquidistancePoint_Pyramid(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistancePoint_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! InterpolationPoint_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point on Pyramid - -INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Pyramid( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, beta, lambda) RESULT(nodecoord) - INTEGER(I4B), INTENT(IN) :: order - !! order of element - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation points - CHARACTER(*), INTENT(IN) :: layout - !! layout - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coords of vertices in $x_{iJ}$ format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - !! Alpha, beta, and lambda - REAL(DFP), ALLOCATABLE :: nodecoord(:, :) - !! interpolation points in $x_{iJ}$ format - END FUNCTION InterpolationPoint_Pyramid -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION LagrangeCoeff_Pyramid1(order, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Pyramid1 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid1 -END INTERFACE LagrangeCoeff_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION LagrangeCoeff_Pyramid2(order, i, v, isVandermonde) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Pyramid2 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid2 -END INTERFACE LagrangeCoeff_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION LagrangeCoeff_Pyramid3(order, i, v, ipiv) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Pyramid3 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid3 -END INTERFACE LagrangeCoeff_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION LagrangeCoeff_Pyramid4(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Pyramid4 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid4 -END INTERFACE LagrangeCoeff_Pyramid - -!---------------------------------------------------------------------------- -! QuadraturePoints_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: quadrature points on Pyramid - -INTERFACE QuadraturePoint_Pyramid - MODULE FUNCTION QuadraturePoint_Pyramid1(& - & order, & - & quadType, & - & refPyramid, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPyramid - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3. - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Pyramid1 -END INTERFACE QuadraturePoint_Pyramid - -!---------------------------------------------------------------------------- -! QuadraturePoints_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: quadrature points on Pyramid - -INTERFACE QuadraturePoint_Pyramid - MODULE FUNCTION QuadraturePoint_Pyramid2(& - & nips, & - & quadType, & - & refPyramid, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nips(1) - !! nips(1) .LE. 79, then we call - !! economical quadrature rules. - !! Otherwise, this routine will retport - !! error - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type, - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPyramid - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3 - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Pyramid2 -END INTERFACE QuadraturePoint_Pyramid - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points on Pyramid - -INTERFACE TensorQuadraturePoint_Pyramid - MODULE FUNCTION TensorQuadraturePoint_Pyramid1(order, quadType, & - & refPyramid, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPyramid - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij can be 4. - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Pyramid1 -END INTERFACE TensorQuadraturePoint_Pyramid - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points - -INTERFACE TensorQuadraturePoint_Pyramid - MODULE FUNCTION TensorQuadraturePoint_Pyramid2( & - & nipsx, & - & nipsy, & - & nipsz, & - & quadType, & - & refPyramid, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nipsx(1) - !! number of integration points in x direction - INTEGER(I4B), INTENT(IN) :: nipsy(1) - !! number of integration points in y direction - INTEGER(I4B), INTENT(IN) :: nipsz(1) - !! number of integration points in z direction - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refPyramid - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3 - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Pyramid2 -END INTERFACE TensorQuadraturePoint_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Pyramid - MODULE FUNCTION LagrangeEvalAll_Pyramid1( & - & order, & - & x, & - & xij, & - & refPyramid, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(3) - !! point of evaluation - !! x(1) is x coord - !! x(2) is y coord - !! x(3) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - !! The number of rows in xij is 3 - !! The number of columns in xij should be equal to total - !! degree of freedom - CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be computed and returned - !! by this routine. - !! If firstCall is False, then coeff should be given, which will be - !! used. - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Pyramid1 -END INTERFACE LagrangeEvalAll_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Pyramid - MODULE FUNCTION LagrangeEvalAll_Pyramid2( & - & order, & - & x, & - & xij, & - & refPyramid, & - & 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 - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Pyramid2 -END INTERFACE LagrangeEvalAll_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Pyramid -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: GradientEvaluate all Lagrange polynomials at several points - -INTERFACE LagrangeGradientEvalAll_Pyramid - MODULE FUNCTION LagrangeGradientEvalAll_Pyramid1( & - & order, & - & x, & - & xij, & - & refPyramid, & - & 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 - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 3) - !! 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_Pyramid1 -END INTERFACE LagrangeGradientEvalAll_Pyramid - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE PyramidInterpolationUtility diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 deleted file mode 100644 index 20109601e..000000000 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ /dev/null @@ -1,2042 +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 -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General 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 QuadrangleInterpolationUtility -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE -PUBLIC :: LagrangeDegree_Quadrangle -PUBLIC :: LagrangeDOF_Quadrangle -PUBLIC :: LagrangeInDOF_Quadrangle -PUBLIC :: EquidistancePoint_Quadrangle -PUBLIC :: EquidistanceInPoint_Quadrangle -PUBLIC :: InterpolationPoint_Quadrangle -PUBLIC :: LagrangeCoeff_Quadrangle -PUBLIC :: Dubiner_Quadrangle -PUBLIC :: Dubiner_Quadrangle_ -PUBLIC :: TensorProdBasis_Quadrangle -PUBLIC :: OrthogonalBasis_Quadrangle -PUBLIC :: VertexBasis_Quadrangle -PUBLIC :: VerticalEdgeBasis_Quadrangle -PUBLIC :: HorizontalEdgeBasis_Quadrangle -PUBLIC :: CellBasis_Quadrangle -PUBLIC :: HeirarchicalBasis_Quadrangle -PUBLIC :: IJ2VEFC_Quadrangle_Clockwise -PUBLIC :: IJ2VEFC_Quadrangle_AntiClockwise -PUBLIC :: LagrangeEvalAll_Quadrangle -PUBLIC :: QuadraturePoint_Quadrangle -PUBLIC :: QuadratureNumber_Quadrangle -PUBLIC :: FacetConnectivity_Quadrangle -PUBLIC :: RefElemDomain_Quadrangle -PUBLIC :: LagrangeGradientEvalAll_Quadrangle -PUBLIC :: HeirarchicalBasisGradient_Quadrangle -PUBLIC :: TensorProdBasisGradient_Quadrangle -PUBLIC :: OrthogonalBasisGradient_Quadrangle -PUBLIC :: DubinerGradient_Quadrangle -PUBLIC :: DubinerGradient_Quadrangle_ -PUBLIC :: GetTotalDOF_Quadrangle -PUBLIC :: GetTotalInDOF_Quadrangle - -!---------------------------------------------------------------------------- -! GetTotalDOF_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Quadrangle - -INTERFACE - MODULE PURE FUNCTION GetTotalDOF_Quadrangle(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalDOF_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Quadrangle -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Quadrangle -!- These dof are strictly inside the Quadrangle - -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Quadrangle(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! RefElemDomain_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) & - & RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseContinuity - !! Cointinuity (conformity) of basis functions - !! "H1", "HDiv", "HCurl", "DG" - CHARACTER(*), INTENT(IN) :: baseInterpol - !! Basis function family for Interpolation - !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal - TYPE(String) :: ans - END FUNCTION RefElemDomain_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetConnectivity_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-10 -! summary: This function returns the edge connectivity of Quadrangle - -INTERFACE - MODULE FUNCTION FacetConnectivity_Quadrangle( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(2, 4) - !! rows represents the end points of an edges - !! columns denote the edge (facet) - END FUNCTION FacetConnectivity_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! 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 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 - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Quadrangle - -INTERFACE LagrangeDOF_Quadrangle - MODULE PURE FUNCTION LagrangeDOF_Quadrangle1(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Quadrangle1 -END INTERFACE LagrangeDOF_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Quadrangle - -INTERFACE LagrangeDOF_Quadrangle - MODULE PURE FUNCTION LagrangeDOF_Quadrangle2(p, q) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Quadrangle2 -END INTERFACE LagrangeDOF_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell/face of Quadrangle -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell/face of Quadrangle -!- These dof are strictly inside the Quadrangle - -INTERFACE LagrangeInDOF_Quadrangle - MODULE PURE FUNCTION LagrangeInDOF_Quadrangle1(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Quadrangle1 -END INTERFACE LagrangeInDOF_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell/face of Quadrangle -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell/face of Quadrangle -!- These dof are strictly inside the Quadrangle - -INTERFACE LagrangeInDOF_Quadrangle - MODULE PURE FUNCTION LagrangeInDOF_Quadrangle2(p, q) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p, q - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Quadrangle2 -END INTERFACE LagrangeInDOF_Quadrangle - -!---------------------------------------------------------------------------- -! EquidistancePoint_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 EquidistancePoint_Quadrangle - MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistancePoint_Quadrangle1 -END INTERFACE EquidistancePoint_Quadrangle - -!---------------------------------------------------------------------------- -! EquidistancePoint_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Quadrangle element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Quadrangle element -!- The coordinates are distributed uniformly -!- These coordinates can be used to construct lagrange polynomials -!- The returned coordinates are in $x_{iJ}$ format. -!- The node numbering is according to Gmsh convention. - -INTERFACE EquidistancePoint_Quadrangle - MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order in y direction - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 or 3 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistancePoint_Quadrangle2 -END INTERFACE EquidistancePoint_Quadrangle - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -!> 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 PURE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 or 3 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistanceInPoint_Quadrangle1 -END INTERFACE EquidistanceInPoint_Quadrangle - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -!> 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 PURE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order in y direction - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 or 3 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistanceInPoint_Quadrangle2 -END INTERFACE EquidistanceInPoint_Quadrangle - -!---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point -! -!# Introduction -! -! In this case order is same in both x1 and x2 direction. Therefore, -! (N+1)**2 grid points are returned. -! -! Also in both x1 and x2 same type of grid family will be used. -! -!- This routine returns the interplation points on quad -!- `xij` contains nodal coordinates of quad in xij format. -!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4 -!- If xij is absent then biunit quad is used -!- `ipType` is interpolation point type, it can take following values -!- `Equidistance`, uniformly/evenly distributed points -!- `GaussLegendreLobatto -!- `GaussChebyshevLobatto -! -!- `layout` specifies the arrangement of points. The nodes are always -! returned in VEFC format (vertex, edge, face, cell). 1:3 are are -! vertex points, then edge, and then internal nodes. The internal nodes -! also follow the same convention. Please read Gmsh manual on this topic. - -INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle1( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of element - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: layout - !! VEFC, INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION InterpolationPoint_Quadrangle1 -END INTERFACE InterpolationPoint_Quadrangle - -!---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point -! -!# Introduction -! -! In this case order is same in both x1 and x2 direction. Therefore, -! (N+1)**2 grid points are returned. -! -! Also in both x1 and x2 same type of grid family will be used. -! -!- This routine returns the interplation points on quad -!- `xij` contains nodal coordinates of quad in xij format. -!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4 -!- If xij is absent then biunit quad is used -!- `ipType` is interpolation point type, it can take following values -!- `Equidistance`, uniformly/evenly distributed points -!- `GaussLegendreLobatto -!- `GaussChebyshevLobatto -! -!- `layout` specifies the arrangement of points. The nodes are always -! returned in VEFC format (vertex, edge, face, cell). 1:3 are are -! vertex points, then edge, and then internal nodes. The internal nodes -! also follow the same convention. Please read Gmsh manual on this topic. - -INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle2( & - & p, q, ipType1, ipType2, layout, xij, alpha1, beta1, & - & lambda1, alpha2, beta2, lambda2) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order of element in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order of element in y direction - INTEGER(I4B), INTENT(IN) :: ipType1 - !! interpolation point type in x direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - INTEGER(I4B), INTENT(IN) :: ipType2 - !! interpolation point type in y direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: layout - !! VEFC, INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION InterpolationPoint_Quadrangle2 -END INTERFACE InterpolationPoint_Quadrangle - -!---------------------------------------------------------------------------- -! IJ2VEFC -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Convert format from IJ to VEFC - -INTERFACE - MODULE SUBROUTINE IJ2VEFC_Quadrangle(xi, eta, temp, p, q) - REAL(DFP), INTENT(IN) :: xi(:, :) - REAL(DFP), INTENT(IN) :: eta(:, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - END SUBROUTINE IJ2VEFC_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Convert format from IJ to VEFC - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_Clockwise( & - & xi, eta, temp, p, q, startNode) - REAL(DFP), INTENT(IN) :: xi(:, :) - REAL(DFP), INTENT(IN) :: eta(:, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), INTENT(IN) :: startNode - END SUBROUTINE IJ2VEFC_Quadrangle_Clockwise -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Convert format from IJ to VEFC - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise( & - & xi, eta, temp, p, q, startNode) - REAL(DFP), INTENT(IN) :: xi(:, :) - REAL(DFP), INTENT(IN) :: eta(:, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), INTENT(IN) :: startNode - END SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle1 -END INTERFACE LagrangeCoeff_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle2 -END INTERFACE LagrangeCoeff_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -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 polynomial in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order of polynomial in y direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - INTEGER(I4B), INTENT(IN) :: basisType1 - !! basisType in x direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType2 - !! basisType in y direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! This parameter is needed when basisType is Ultraspherical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! This parameter is needed when basisType is Ultraspherical - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle5 -END INTERFACE LagrangeCoeff_Quadrangle - -!---------------------------------------------------------------------------- -! DubinerPolynomial -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain -! -!# Introduction -! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is called while forming dubiner basis on triangle domain -! -! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) -! N = 0.5*(order+1)*(order+2). -! -! In this way, ans(j,:) denotes the values of all polynomial at jth point -! -! Polynomials are returned in following way: -! -!$$ -! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ -! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ -! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ -! \cdots -! P_{order,0} -!$$ -! -! For example for order=3, the polynomials are arranged as: -! -!$$ -! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ -! P_{1,0}, P_{1,1}, P_{1,2} \\ -! P_{2,0}, P_{2,1} \\ -! P_{3,0} -!$$ - -INTERFACE Dubiner_Quadrangle - MODULE PURE FUNCTION Dubiner_Quadrangle1(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in biunit quadrangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points - REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION Dubiner_Quadrangle1 -END INTERFACE Dubiner_Quadrangle - -!---------------------------------------------------------------------------- -! DubinerPolynomial -!---------------------------------------------------------------------------- - -!> 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 -!---------------------------------------------------------------------------- - -!> 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 -!---------------------------------------------------------------------------- - -!> 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 -!---------------------------------------------------------------------------- - -!> 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(:, :) - !! points in biunit quadrangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points - REAL(DFP) :: ans(SIZE(xij, 2), & - & (order + 1_I4B) * (order + 2_I4B) / 2_I4B, & - & 2_I4B) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION DubinerGradient_Quadrangle1 -END INTERFACE DubinerGradient_Quadrangle - -!---------------------------------------------------------------------------- -! DubinerGradient -!---------------------------------------------------------------------------- - -!> 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 SUBROUTINE DubinerGradient_Quadrangle1_(order, xij, ans, & - tsize1, tsize2, tsize3) - 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_I4B) * (order + 2_I4B) / 2_I4B, & - ! & 2_I4B) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 - END SUBROUTINE DubinerGradient_Quadrangle1_ -END INTERFACE DubinerGradient_Quadrangle_ - -!---------------------------------------------------------------------------- -! TensorProdBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle -! -!# Introduction -! -! This function returns the tensor product expansion of orthogonal -! polynomial on biunit quadrangle. - -INTERFACE TensorProdBasis_Quadrangle - MODULE FUNCTION TensorProdBasis_Quadrangle1( & - & p, & - & q, & - & xij, & - & basisType1, & - & basisType2, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! highest order in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - INTEGER(I4B), INTENT(IN) :: basisType1 - !! basis type in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType2 - !! basis type in x2 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! alpha1 needed when basisType1 "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) - !! - END FUNCTION TensorProdBasis_Quadrangle1 -END INTERFACE TensorProdBasis_Quadrangle - -INTERFACE OrthogonalBasis_Quadrangle - MODULE PROCEDURE TensorProdBasis_Quadrangle1 -END INTERFACE OrthogonalBasis_Quadrangle - -!---------------------------------------------------------------------------- -! TensorProdBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle -! -!# Introduction -! -! This function returns the tensor product expansion of orthogonal -! polynomial on biunit quadrangle. Here xij is obtained by -! outer product of x and y - -INTERFACE TensorProdBasis_Quadrangle - MODULE FUNCTION TensorProdBasis_Quadrangle2( & - & p, & - & q, & - & x, & - & y, & - & basisType1, & - & basisType2, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! highest order in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - REAL(DFP), INTENT(IN) :: x(:), y(:) - !! points of evaluation in xij format - INTEGER(I4B), INTENT(IN) :: basisType1 - !! orthogonal polynomial family in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType2 - !! orthogonal poly family in x2 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! alpha1 needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1)) - !! Tensor basis - !! The number of rows corresponds to the - !! total number of points - END FUNCTION TensorProdBasis_Quadrangle2 -END INTERFACE TensorProdBasis_Quadrangle - -INTERFACE OrthogonalBasis_Quadrangle - MODULE PROCEDURE TensorProdBasis_Quadrangle2 -END INTERFACE OrthogonalBasis_Quadrangle - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE VertexBasis_Quadrangle - MODULE PURE FUNCTION VertexBasis_Quadrangle1(x, y) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:), y(:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(x), 4) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Quadrangle1 -END INTERFACE VertexBasis_Quadrangle - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE VertexBasis_Quadrangle - MODULE PURE FUNCTION VertexBasis_Quadrangle3(xij) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - REAL(DFP) :: ans(SIZE(xij, 2), 4) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Quadrangle3 -END INTERFACE VertexBasis_Quadrangle - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE - MODULE PURE FUNCTION VertexBasis_Quadrangle2(L1, L2) RESULT(ans) - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP) :: ans(SIZE(L1, 1), 4) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE - MODULE PURE FUNCTION VertexBasisGradient_Quadrangle2( & - & L1, & - & L2, & - & dL1, & - & dL2) RESULT(ans) - REAL(DFP), INTENT(IN) :: L1(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - REAL(DFP), INTENT(IN) :: L2(1:, 0:) - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP), INTENT(IN) :: dL1(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - REAL(DFP), INTENT(IN) :: dL2(1:, 0:) - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP) :: ans(SIZE(L1, 1), 4, 2) - !! Gradient of vertex basis - END FUNCTION VertexBasisGradient_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on left, right edge of biunit quadrangle -! -!# Introduction -! -! Evaluate basis functions on left and right edge of biunit quadrangle -! -! qe1 and qe2 should be greater than or equal to 2 -! -! Note that both edge are aligned in positive y direction. - -INTERFACE - MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle(qe1, qe2, x, y) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - !! It should be greater than 2 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - !! It should be greater than 2 - REAL(DFP), INTENT(IN) :: x(:), y(:) - !! point of evaluation - !! these points should be between [-1, 1]. - REAL(DFP) :: ans(SIZE(x), qe1 + qe2 - 2) - END FUNCTION VerticalEdgeBasis_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle2(qe1, qe2, L1, L2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2) - END FUNCTION VerticalEdgeBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION VerticalEdgeBasisGradient_Quadrangle2( & - & qe1, & - & qe2, & - & L1, & - & L2, & - & dL1, & - & dL2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2, 2) - END FUNCTION VerticalEdgeBasisGradient_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on bottom and top edge of biunit quadrangle -! -!# Introduction -! -! Evaluate basis functions on bottom and top edge of biunit quadrangle -! -! pe3 and pe4 should be greater than or equal to 2 - -INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), 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) :: x(:), y(:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(x), pe3 + pe4 - 2) - END FUNCTION HorizontalEdgeBasis_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle2(pe3, pe4, L1, L2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2) - END FUNCTION HorizontalEdgeBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasisGradient_Quadrangle2( & - &pe3, & - & pe4, & - & L1, & - & L2, & - & dL1, & - & dL2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2, 2) - END FUNCTION HorizontalEdgeBasisGradient_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis in the cell of biunit quadrangle -! -!# Introduction -! -! Evaluate basis functions in the cell of biunit quadrangle - -INTERFACE - MODULE PURE FUNCTION CellBasis_Quadrangle(pb, qb, x, y) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), 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) :: x(:), y(:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(x), (pb - 1) * (qb - 1)) - END FUNCTION CellBasis_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION CellBasis_Quadrangle2(pb, qb, L1, L2) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) - END FUNCTION CellBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! CellBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION CellBasisGradient_Quadrangle2( & - & pb, & - & qb, & - & L1, & - & L2, & - & dL1, & - & dL2) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1), 2) - END FUNCTION CellBasisGradient_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle -! -!# Introduction -! -! This function returns the modal basis on orthogonal polynomial -! The modal function in 1D is given by scaled Lobatto polynomial. -! These modal functions are orthogonal with respect to H1 seminorm. -! However, these modal function are not orthogonal withrespect to L2 norm. -! -! Bubble function in 1D is proportional to Jacobi polynomial with -! alpha=beta=1. Equivalently, these bubble functions are proportional to -! Ultraspherical polynomials with lambda = 3/2. -! - -INTERFACE HeirarchicalBasis_Quadrangle - MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle1(pb, qb, pe3, pe4, & - & qe1, qe2, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order of interpolation inside the quadrangle in x1 direction - INTEGER(I4B), INTENT(IN) :: qb - !! order of interpolation inside the quadrangle in x2 direction - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge e3 (bottom) in x1 direction - INTEGER(I4B), INTENT(IN) :: pe4 - !! order of interpolation on edge e4 (top) in x1 direction - INTEGER(I4B), INTENT(IN) :: qe1 - !! order of interpolation on edge e1 (left) in y1 direction - INTEGER(I4B), INTENT(IN) :: qe2 - !! order of interpolation on edge e2 (right) in y1 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans(SIZE(xij, 2), & - & pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) - !! - END FUNCTION HeirarchicalBasis_Quadrangle1 -END INTERFACE HeirarchicalBasis_Quadrangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle -! -!# Introduction -! -! This function is identical to `HeirarchicalBasis_Quadrangle1` -! with qe1=qe2=qb=q, and pe3=pe4=pb=p. -! - -INTERFACE HeirarchicalBasis_Quadrangle - MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle2(p, q, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order of interpolation inside the quadrangle in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! order of interpolation inside the quadrangle in x2 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) - END FUNCTION HeirarchicalBasis_Quadrangle2 -END INTERFACE 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Lagrange polynomials of n at several points - -INTERFACE LagrangeGradientEvalAll_Quadrangle - MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( & - & order, & - & x, & - & xij, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! point of evaluation in xij format - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! interpolation points - !! xij should be present when firstCall is true. - !! It is used for computing the coeff - !! If coeff is absent then xij should be present - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 2) - !! Value of gradient of nth order Lagrange polynomials at point x - !! The first index denotes point of evaluation - !! the second index denotes Lagrange polynomial number - !! The third index denotes the spatial dimension in which gradient is - !! computed - END FUNCTION LagrangeGradientEvalAll_Quadrangle1 -END INTERFACE LagrangeGradientEvalAll_Quadrangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle -! -!# Introduction -! -! This function returns the modal basis on orthogonal polynomial -! The modal function in 1D is given by scaled Lobatto polynomial. -! These modal functions are orthogonal with respect to H1 seminorm. -! However, these modal function are not orthogonal withrespect to L2 norm. -! -! Bubble function in 1D is proportional to Jacobi polynomial with -! alpha=beta=1. Equivalently, these bubble functions are proportional to -! Ultraspherical polynomials with lambda = 3/2. - -INTERFACE HeirarchicalBasisGradient_Quadrangle - MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle1( & - & pb, & - & qb, & - & pe3, & - & pe4, & - & qe1, & - & qe2, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order of interpolation inside the quadrangle in x1 direction - INTEGER(I4B), INTENT(IN) :: qb - !! order of interpolation inside the quadrangle in x2 direction - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge e3 (bottom) in x1 direction - INTEGER(I4B), INTENT(IN) :: pe4 - !! order of interpolation on edge e4 (top) in x1 direction - INTEGER(I4B), INTENT(IN) :: qe1 - !! order of interpolation on edge e1 (left) in y1 direction - INTEGER(I4B), INTENT(IN) :: qe2 - !! order of interpolation on edge e2 (right) in y1 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans(SIZE(xij, 2), & - & pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1, 2) - END FUNCTION HeirarchicalBasisGradient_Quadrangle1 -END INTERFACE HeirarchicalBasisGradient_Quadrangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle - -INTERFACE HeirarchicalBasisGradient_Quadrangle - MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle2( & - & p, & - & q, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order of interpolation inside the quadrangle in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! order of interpolation inside the quadrangle in x2 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2) - END FUNCTION HeirarchicalBasisGradient_Quadrangle2 -END INTERFACE HeirarchicalBasisGradient_Quadrangle - -!---------------------------------------------------------------------------- -! TensorProdBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle - -INTERFACE TensorProdBasisGradient_Quadrangle - MODULE FUNCTION TensorProdBasisGradient_Quadrangle1( & - & p, & - & q, & - & xij, & - & basisType1, & - & basisType2, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! highest order in x1 direction - INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format - INTEGER(I4B), INTENT(IN) :: basisType1 - !! basis type in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType2 - !! basis type in x2 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! alpha1 needed when basisType1 "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2) - !! - END FUNCTION TensorProdBasisGradient_Quadrangle1 -END INTERFACE TensorProdBasisGradient_Quadrangle - -INTERFACE OrthogonalBasisGradient_Quadrangle - MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 -END INTERFACE OrthogonalBasisGradient_Quadrangle - -END MODULE QuadrangleInterpolationUtility diff --git a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 deleted file mode 100644 index e45d75fde..000000000 --- a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 +++ /dev/null @@ -1,215 +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 RecursiveNodesUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: RecursiveNode1D -PUBLIC :: RecursiveNode2D -PUBLIC :: RecursiveNode3D - -!---------------------------------------------------------------------------- -! RecursiveNode1D -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: RecursiveNodes in 1D - -INTERFACE - MODULE FUNCTION RecursiveNode1D(order, ipType, & - & domain, alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order >= 0 - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! LobattoGaussJacobi - !! LobattoGaussChebyshev - !! LobattoGaussGegenbauer - !! GaussJacobi - !! GaussChebyshev - !! GaussGegenbauer - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! barycentric coordinates, in xiJ format - !! size(ans,1) = 2 corresponding to b0 and b1 - !! size(ans,2) total number of points - CHARACTER(*), OPTIONAL, INTENT(IN) :: domain - !! unit (0,1) - !! biunit (-1, 1) - !! equilateral - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - END FUNCTION RecursiveNode1D -END INTERFACE - -!---------------------------------------------------------------------------- -! RecursiveNode2D -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: RecursiveNodes in 2D - -INTERFACE - MODULE FUNCTION RecursiveNode2D( & - & order, & - & ipType, & - & domain, & - & alpha, & - & beta, & - & lambda & - & ) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order >= 0 - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! LobattoGaussJacobi - !! LobattoGaussChebyshev - !! LobattoGaussGegenbauer - !! GaussJacobi - !! GaussChebyshev - !! GaussGegenbauer - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! barycentric coordinates, in xiJ format - !! size(ans,1) = 3 corresponding to b0, b1, b2 - !! size(ans,2) total number of points - CHARACTER(*), OPTIONAL, INTENT(IN) :: domain - !! unit - !! Biunit - !! Equilateral - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - END FUNCTION RecursiveNode2D -END INTERFACE - -!---------------------------------------------------------------------------- -! RecursiveNode3D -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Recursive nodes in 3D - -INTERFACE - MODULE FUNCTION RecursiveNode3D( & - & order, & - & ipType, & - & domain, & - & alpha, & - & beta, & - & lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order >= 0 - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! LobattoGaussJacobi - !! LobattoGaussChebyshev - !! LobattoGaussGegenbauer - !! GaussJacobi - !! GaussChebyshev - !! GaussGegenbauer - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! barycentric coordinates, in xiJ format - !! size(ans,1) = 4 corresponding to b0, b1, b2, b3 - !! size(ans,2) total number of points - CHARACTER(*), OPTIONAL, INTENT(IN) :: domain - !! unit - !! Biunit - !! Equilateral - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - END FUNCTION RecursiveNode3D -END INTERFACE - -!---------------------------------------------------------------------------- -! ToUnit -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ToUnit(x, domain) RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:, :) - CHARACTER(*), INTENT(IN) :: domain - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ToUnit -END INTERFACE - -!---------------------------------------------------------------------------- -! ToUnit -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION FromUnit(x, domain) RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:, :) - CHARACTER(*), INTENT(IN) :: domain - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION FromUnit -END INTERFACE - -!---------------------------------------------------------------------------- -! ToUnit -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE PURE SUBROUTINE Unit2Equilateral(d, x) - INTEGER(I4B), INTENT(IN) :: d - REAL(DFP), INTENT(INOUT) :: x(:, :) - END SUBROUTINE Unit2Equilateral -END INTERFACE - -!---------------------------------------------------------------------------- -! ToUnit -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE PURE SUBROUTINE Equilateral2Unit(d, x) - INTEGER(I4B), INTENT(IN) :: d - REAL(DFP), INTENT(INOUT) :: x(:, :) - END SUBROUTINE Equilateral2Unit -END INTERFACE - -!---------------------------------------------------------------------------- -! Coord_Map -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Coord_Map(x, from, to) RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:, :) - CHARACTER(*), INTENT(IN) :: from - CHARACTER(*), INTENT(IN) :: to - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION Coord_Map -END INTERFACE - -END MODULE RecursiveNodesUtility diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 deleted file mode 100644 index 1fba7da35..000000000 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ /dev/null @@ -1,1998 +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 TetrahedronInterpolationUtility -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE - -PUBLIC :: LagrangeDegree_Tetrahedron -PUBLIC :: LagrangeDOF_Tetrahedron -PUBLIC :: LagrangeInDOF_Tetrahedron -PUBLIC :: EquidistanceInPoint_Tetrahedron -PUBLIC :: EquidistancePoint_Tetrahedron -PUBLIC :: LagrangeCoeff_Tetrahedron -PUBLIC :: Isaac_Tetrahedron -PUBLIC :: BlythPozrikidis_Tetrahedron -PUBLIC :: InterpolationPoint_Tetrahedron -PUBLIC :: OrthogonalBasis_Tetrahedron -PUBLIC :: BarycentricVertexBasis_Tetrahedron -PUBLIC :: BarycentricEdgeBasis_Tetrahedron -PUBLIC :: BarycentricFacetBasis_Tetrahedron -PUBLIC :: BarycentricCellBasis_Tetrahedron -PUBLIC :: BarycentricHeirarchicalBasis_Tetrahedron -PUBLIC :: VertexBasis_Tetrahedron -PUBLIC :: EdgeBasis_Tetrahedron -PUBLIC :: FacetBasis_Tetrahedron -PUBLIC :: CellBasis_Tetrahedron -PUBLIC :: HeirarchicalBasis_Tetrahedron -PUBLIC :: FacetConnectivity_Tetrahedron -PUBLIC :: EdgeConnectivity_Tetrahedron -PUBLIC :: GetVertexDOF_Tetrahedron -PUBLIC :: GetEdgeDOF_Tetrahedron -PUBLIC :: GetFacetDOF_Tetrahedron -PUBLIC :: GetCellDOF_Tetrahedron -PUBLIC :: LagrangeEvalAll_Tetrahedron -PUBLIC :: QuadraturePoint_Tetrahedron -PUBLIC :: RefElemDomain_Tetrahedron -PUBLIC :: LagrangeGradientEvalAll_Tetrahedron -PUBLIC :: HeirarchicalBasisGradient_Tetrahedron -PUBLIC :: OrthogonalBasisGradient_Tetrahedron -PUBLIC :: GetTotalDOF_Tetrahedron -PUBLIC :: GetTotalInDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetTotalDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Tetrahedron - -INTERFACE - MODULE PURE FUNCTION GetTotalDOF_Tetrahedron(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalDOF_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Tetrahedron -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Tetrahedron -!- These dof are strictly inside the Tetrahedron - -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Tetrahedron(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! RefElemDomain_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain_Tetrahedron(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_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! GetVertexDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: returns total number of vertex degrees of freedom - -INTERFACE - MODULE PURE FUNCTION GetVertexDOF_Tetrahedron() RESULT(ans) - INTEGER(I4B) :: ans - END FUNCTION GetVertexDOF_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: returns total number of degrees of freedom on edges parallel to -! some axis - -INTERFACE GetEdgeDOF_Tetrahedron - MODULE PURE FUNCTION GetEdgeDOF_Tetrahedron1(pe1, pe2, pe3, & - & pe4, pe5, pe6) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1, pe2, pe3, pe4, pe5, pe6 - !! Order of interpolation in x or y or z direction - INTEGER(I4B) :: ans - END FUNCTION GetEdgeDOF_Tetrahedron1 -END INTERFACE GetEdgeDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total number of degrees of freedom on all edges - -INTERFACE GetEdgeDOF_Tetrahedron - MODULE PURE FUNCTION GetEdgeDOF_Tetrahedron2(p) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! Order of approximation on all edges - INTEGER(I4B) :: ans - END FUNCTION GetEdgeDOF_Tetrahedron2 -END INTERFACE GetEdgeDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns dof on all facets - -INTERFACE GetFacetDOF_Tetrahedron - MODULE PURE FUNCTION GetFacetDOF_Tetrahedron1( & - & ps1, ps2, & - & ps3, ps4) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: ps1 - !! orders alongs facets parallel to xy plane - INTEGER(I4B), INTENT(IN) :: ps2 - !! orders along facets parallel to xz plane - INTEGER(I4B), INTENT(IN) :: ps3 - !! orders along facets parallel to yz plane - INTEGER(I4B), INTENT(IN) :: ps4 - !! orders along facets parallel to xyz plane - INTEGER(I4B) :: ans - END FUNCTION GetFacetDOF_Tetrahedron1 -END INTERFACE GetFacetDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns total degrees of freedom on all facets - -INTERFACE GetFacetDOF_Tetrahedron - MODULE PURE FUNCTION GetFacetDOF_Tetrahedron2(p) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! orders alongs facets parallel to xy or xz or yz planes - INTEGER(I4B) :: ans - END FUNCTION GetFacetDOF_Tetrahedron2 -END INTERFACE GetFacetDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetFacetDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-24 -! summary: Returns the number of cell degree of freedom - -INTERFACE GetCellDOF_Tetrahedron - MODULE PURE FUNCTION GetCellDOF_Tetrahedron1(p) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! orders alongs to x, y, and z directions - INTEGER(I4B) :: ans - END FUNCTION GetCellDOF_Tetrahedron1 -END INTERFACE GetCellDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! FacetConnectivity_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-10 -! summary: This function returns the facet-connectivity of Tetrahedron - -INTERFACE - MODULE PURE FUNCTION FacetConnectivity_Tetrahedron( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(3, 4) - END FUNCTION FacetConnectivity_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-07 -! summary: This function returns the edge connectivity of Tetrahedron - -INTERFACE - MODULE PURE FUNCTION EdgeConnectivity_Tetrahedron( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity - INTEGER(I4B) :: ans(2, 6) - END FUNCTION EdgeConnectivity_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE - MODULE PURE FUNCTION LagrangeDegree_Tetrahedron(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Tetrahedron - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF_Tetrahedron(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Tetrahedron -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell of Tetrahedron -!- These dof are strictly inside the Tetrahedron - -INTERFACE - MODULE PURE FUNCTION LagrangeInDOF_Tetrahedron(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in Tetrahedron -! -!# Introduction -! -!- This function returns the equidistance points in Tetrahedron -!- All points are inside the Tetrahedron - -INTERFACE - MODULE FUNCTION EquidistanceInPoint_Tetrahedron_old(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistanceInPoint_Tetrahedron_old -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points strictly in Tetrahedron -! -!# Introduction -! -!- This function returns the equidistance points in Tetrahedron -!- All points are inside the Tetrahedron - -INTERFACE - MODULE FUNCTION EquidistanceInPoint_Tetrahedron(order, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistanceInPoint_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistancePoint_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Tetrahedron element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Tetrahedron 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 - MODULE FUNCTION EquidistancePoint_Tetrahedron(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistancePoint_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistancePoint_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Tetrahedron element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Tetrahedron 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 - MODULE RECURSIVE FUNCTION EquidistancePoint_Tetrahedron_old( & - & order, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistancePoint_Tetrahedron_old -END INTERFACE - -!---------------------------------------------------------------------------- -! InterpolationPoint_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point - -INTERFACE - MODULE FUNCTION InterpolationPoint_Tetrahedron( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of element - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto - CHARACTER(*), INTENT(IN) :: layout - !! "VEFC", "INCREASING" - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(3, 4) - !! coordinates of vertices in $x_{iJ}$ format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in $x_{iJ}$ format - END FUNCTION InterpolationPoint_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Tetrahedron - MODULE FUNCTION LagrangeCoeff_Tetrahedron1(order, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Tetrahedron1 -END INTERFACE LagrangeCoeff_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Tetrahedron - MODULE FUNCTION LagrangeCoeff_Tetrahedron2(order, i, v, isVandermonde) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Tetrahedron2 -END INTERFACE LagrangeCoeff_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Tetrahedron - MODULE FUNCTION LagrangeCoeff_Tetrahedron3(order, i, v, ipiv) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Tetrahedron3 -END INTERFACE LagrangeCoeff_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Tetrahedron - MODULE FUNCTION LagrangeCoeff_Tetrahedron4( & - & order, & - & xij, & - & basisType, & - & refTetrahedron, & - & alpha, beta, lambda) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials - !! Jacobi (Dubiner) - !! Heirarchical - CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron - !! UNIT * default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Tetrahedron4 -END INTERFACE LagrangeCoeff_Tetrahedron - -!---------------------------------------------------------------------------- -! Isaac_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Isaac points on triangle -! -!# Introduction -! -! https://tisaac.gitlab.io/recursivenodes/ - -INTERFACE - MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, & - & alpha, beta, lambda) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: ipType - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of Tetrahedron - CHARACTER(*), INTENT(IN) :: layout - !! local node numbering layout - !! only layout = "VEFC" is allowed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! xij coordinates - END FUNCTION Isaac_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BlythPozrikidis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Blyth Pozrikidis nodes on triangle -! -!# Introduction -! -! M. G. Blyth and C. Pozrikidis. -! A lobatto interpolation grid over the Tetrahedron. -! IMA Journal of Applied Mathematics, Feb 2006. - -INTERFACE - MODULE FUNCTION BlythPozrikidis_Tetrahedron(order, ipType, layout, xij, & - & alpha, beta, lambda) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: ipType - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! xij coordinates - CHARACTER(*), INTENT(IN) :: layout - !! local node numbering layout - !! only layout = "VEFC" is allowed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! xij coordinates - END FUNCTION BlythPozrikidis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! IJ2VEFC_Triangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE SUBROUTINE IJK2VEFC_Tetrahedron( & - & xi, & - & eta, & - & zeta, & - & temp, & - & order, & - & N) - REAL(DFP), INTENT(IN) :: xi(:, :, :) - REAL(DFP), INTENT(IN) :: eta(:, :, :) - REAL(DFP), INTENT(IN) :: zeta(:, :, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: N - END SUBROUTINE IJK2VEFC_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! OrthogonalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Orthogongal basis on Tetrahedron - -INTERFACE OrthogonalBasis_Tetrahedron - MODULE FUNCTION OrthogonalBasis_Tetrahedron1( & - & order, & - & xij, & - & refTetrahedron) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! Points of evaluation in reference Tetrahedron. - !! The shape functions will be evaluated - !! at these points. - !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! "UNIT" - !! "BIUNIT" - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION OrthogonalBasis_Tetrahedron1 -END INTERFACE OrthogonalBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! OrthogonalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Orthogongal basis on Tetrahedron - -INTERFACE OrthogonalBasis_Tetrahedron - MODULE FUNCTION OrthogonalBasis_Tetrahedron2( & - & order, & - & x, y, z, refTetrahedron) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: x(:) - !! x coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) - REAL(DFP), INTENT(IN) :: y(:) - !! y coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) - REAL(DFP), INTENT(IN) :: z(:) - !! z coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! "UNIT" - !! "BIUNIT" - REAL(DFP) :: ans( & - & SIZE(x) * SIZE(y) * SIZE(z), & - & (order + 1) * (order + 2) * (order + 3) / 6) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION OrthogonalBasis_Tetrahedron2 -END INTERFACE OrthogonalBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricVertexBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on reference Tetrahedron - -INTERFACE - MODULE PURE FUNCTION BarycentricVertexBasis_Tetrahedron(lambda) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentrix coords - !! number of rows = 4 - !! number of columns = number of points - REAL(DFP) :: ans(SIZE(lambda, 2), 4) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION BarycentricVertexBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricVertexBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Gradient of vertex basis in terms of barycentric coord - -INTERFACE - MODULE PURE FUNCTION BarycentricVertexBasisGradient_Tetrahedron(lambda) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentrix coords - !! number of rows = 4 - !! number of columns = number of points - REAL(DFP) :: ans(SIZE(lambda, 2), 4, 4) - !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ - !! - index1: point of evaluation - !! - index2: vertex basis number - !! - index3: gradient - END FUNCTION BarycentricVertexBasisGradient_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on edge of triangle -! -!# Introduction -! -! Evaluate basis functions on edges of triangle -! pe1, pe2, pe3 should be greater than or equal to 2 - -INTERFACE - MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order on edge parallel to yz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to 4 - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6) - END FUNCTION BarycentricEdgeBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 30 Oct 2022 -! summary: Evaluate the edge basis on Tetrahedron in terms of barycentric - -INTERFACE - MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & lambda, & - & phi) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order on edge parallel to yz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 4 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6) - END FUNCTION BarycentricEdgeBasis_Tetrahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 30 Oct 2022 -! summary: Eval grad of the basis in terms of barycentric coord - -INTERFACE - MODULE PURE FUNCTION BarycentricEdgeBasisGradient_Tetrahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & lambda, & - & phi, & - & dphi) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order on edge parallel to yz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 4 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 6*number of points - !! - (lambda2-lambda1) - !! - (lambda3-lambda1) - !! - (lambda4-lambda1) - !! - (lambda3-lambda2) - !! - (lambda4-lambda2) - !! - (lambda4-lambda3) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP), INTENT(IN) :: dphi(1:, 0:) - !! gradient of lobatto kernel - !! size(phi1, 1) = 3*number of points - !! - (lambda2-lambda1), - !! - (lambda3-lambda1), - !! - (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6, 4) - !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ - !! - index1: point of evaluation - !! - index2: vertex basis number - !! - index3: gradient - END FUNCTION BarycentricEdgeBasisGradient_Tetrahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricFacetBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on facet of triangle - -INTERFACE - MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron( & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: ps1 - !! order on facet parallel to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order on facet parallel to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order on facet parallel to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order on facet parallel to xyz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to 4 - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2) - END FUNCTION BarycentricFacetBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricFacetBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on facet of triangle - -INTERFACE - MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron2( & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & lambda, & - & phi & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: ps1 - !! order on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order on edge parallel to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order on edge parallel to xyz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to 4 - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2) - END FUNCTION BarycentricFacetBasis_Tetrahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricFacetBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval gradient of facet-basis in terms of barycentric - -INTERFACE - MODULE PURE FUNCTION BarycentricFacetBasisGradient_Tetrahedron2( & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & lambda, & - & phi, & - & dphi & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: ps1 - !! order on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order on edge parallel to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order on edge parallel to xyz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to 4 - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 6*number of points - !! - (lambda2-lambda1) - !! - (lambda3-lambda1) - !! - (lambda4-lambda1) - !! - (lambda3-lambda2) - !! - (lambda4-lambda2) - !! - (lambda4-lambda3) - REAL(DFP), INTENT(IN) :: dphi(1:, 0:) - !! gradient of lobatto kernel values - !! size(phi1, 1) = 6*number of points - !! - (lambda2-lambda1) - !! - (lambda3-lambda1) - !! - (lambda4-lambda1) - !! - (lambda3-lambda2) - !! - (lambda4-lambda2) - !! - (lambda4-lambda3) - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2, 4) - !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ - !! - index1: point of evaluation - !! - index2: vertex basis number - !! - index3: gradient - END FUNCTION BarycentricFacetBasisGradient_Tetrahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCellBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on cell of triangle - -INTERFACE - MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron( & - & pb, lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order on facet parallel to xy - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to 4 - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B) - END FUNCTION BarycentricCellBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCellBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Evaluate cellbasis function in terms of barycentric coord - -INTERFACE - MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron2( & - & pb, lambda, phi) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order on facet parallel to xy - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to 4 - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! Value of lobatto kernel values - !! size(phi1, 1) = 6*number of points - !! - (lambda2-lambda1) - !! - (lambda3-lambda1) - !! - (lambda4-lambda1) - !! - (lambda3-lambda2) - !! - (lambda4-lambda2) - !! - (lambda4-lambda3) - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B) - END FUNCTION BarycentricCellBasis_Tetrahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCellBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-25 -! summary: Gradient of cellbasis function in terms of barycentric coord - -INTERFACE - MODULE PURE FUNCTION BarycentricCellBasisGradient_Tetrahedron2( & - & pb, lambda, phi, dphi) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order on facet parallel to xy - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to 4 - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! Value of lobatto kernel values - !! size(phi1, 1) = 6*number of points - !! - (lambda2-lambda1) - !! - (lambda3-lambda1) - !! - (lambda4-lambda1) - !! - (lambda3-lambda2) - !! - (lambda4-lambda2) - !! - (lambda4-lambda3) - REAL(DFP), INTENT(IN) :: dphi(1:, 0:) - !! Gradient of lobatto kernel values - !! size(phi1, 1) = 6*number of points - !! - (lambda2-lambda1) - !! - (lambda3-lambda1) - !! - (lambda4-lambda1) - !! - (lambda3-lambda2) - !! - (lambda4-lambda2) - !! - (lambda4-lambda3) - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B, 4) - !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ - !! - index1: point of evaluation - !! - index2: vertex basis number - !! - index3: gradient - END FUNCTION BarycentricCellBasisGradient_Tetrahedron2 -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Tetrahedron - -INTERFACE BarycentricHeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order of interpolation on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order of interpolation on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order of interpolation on edge parallel to yz - INTEGER(I4B), INTENT(IN) :: ps1 - !! order of interpolation on facet parallel to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order of interpolation on facet parallel to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order of interpolation on facet parallel to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order of interpolation on facet parallel to xyz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 4 - !! number of cols = number of points - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & 4 & - & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & - & + (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2 & - & + (order - 1) * (order - 2) * (order - 3) / 6_I4B) - END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1 -END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Gradient of heirarchical basis in terms of barycentric coord - -INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron - MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order of interpolation on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order of interpolation on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order of interpolation on edge parallel to yz - INTEGER(I4B), INTENT(IN) :: ps1 - !! order of interpolation on facet parallel to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order of interpolation on facet parallel to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order of interpolation on facet parallel to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order of interpolation on facet parallel to xyz - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 4 - !! number of cols = number of points - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & 4 & - & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & - & + (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2 & - & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 4_I4B) - END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1 -END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-25 -! summary: Evaluate heirarchical basis in terms of barycentric coord - -INTERFACE BarycentricHeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2( & - & order, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 4 - !! number of cols = number of points - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6_I4B) - END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2 -END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-25 -! summary: Gradient of heirarchical basis in terms of barycentric coord - -INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron - MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron2( & - & order, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Point of evaluation in terms of barycentric coord - !! Barycenteric coordinates - !! number of rows = 4 - !! number of cols = number of points - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6_I4B, 4) - END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron2 -END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron - -!---------------------------------------------------------------------------- -! VertexBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on Tetrahedron - -INTERFACE - MODULE PURE FUNCTION VertexBasis_Tetrahedron(xij, refTetrahedron) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! Unit or biunit - REAL(DFP) :: ans(SIZE(xij, 2), 4) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! EdgeBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the edge basis functions on Tetrahedron - -INTERFACE - MODULE PURE FUNCTION EdgeBasis_Tetrahedron( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & xij, & - & refTetrahedron) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order on edge parallel to yz - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! UNIT or BIUNIT - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6) - END FUNCTION EdgeBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the edge basis functions on Tetrahedron - -INTERFACE - MODULE PURE FUNCTION FacetBasis_Tetrahedron( & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & xij, & - & refTetrahedron) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: ps1 - !! order on facet to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order on facet to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order on facet to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order on facet to xyz - REAL(DFP), INTENT(IN) :: xij(:, :) - !! order on xij - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! UNIT or BIUNIT - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2) - END FUNCTION FacetBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! CellBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the cell basis functions on Tetrahedron - -INTERFACE - MODULE PURE FUNCTION CellBasis_Tetrahedron( & - & pb, & - & xij, & - & refTetrahedron) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order in cell - REAL(DFP), INTENT(IN) :: xij(:, :) - !! order on xij - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! UNIT or BIUNIT - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B) - END FUNCTION CellBasis_Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the heirarchical basis functions on Tetrahedron - -INTERFACE HeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & xij, & - & refTetrahedron) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order of interpolation on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order of interpolation on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order of interpolation on edge parallel to yz - INTEGER(I4B), INTENT(IN) :: ps1 - !! order of interpolation on facet parallel to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order of interpolation on facet parallel to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order of interpolation on facet parallel to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order of interpolation on facet parallel to xyz - REAL(DFP), INTENT(IN) :: xij(:, :) - !! order on xij - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! UNIT or BIUNIT - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & 4 & - & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & - & + (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2 & - & + (order - 1) * (order - 2) * (order - 3) / 6_I4B) - END FUNCTION HeirarchicalBasis_Tetrahedron1 -END INTERFACE HeirarchicalBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the heirarchical basis functions on Tetrahedron - -INTERFACE HeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2( & - & order, & - & xij, & - & refTetrahedron) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - REAL(DFP), INTENT(IN) :: xij(:, :) - !! order on xij - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! UNIT or BIUNIT - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6_I4B) - END FUNCTION HeirarchicalBasis_Tetrahedron2 -END INTERFACE HeirarchicalBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Tetrahedron - MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( & - & order, & - & x, & - & xij, & - & refTetrahedron, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(3) - !! point of evaluation - !! x(1) is x coord - !! x(2) is y coord - !! x(3) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - !! The number of rows in xij is 3 - !! The number of columns in xij should be equal to total - !! degree of freedom - CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be computed and returned - !! by this routine. - !! If firstCall is False, then coeff should be given, which will be - !! used. - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Tetrahedron1 -END INTERFACE LagrangeEvalAll_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: Evaluate all Lagrange polynomials at several points - -INTERFACE LagrangeEvalAll_Tetrahedron - MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( & - & order, & - & x, & - & xij, & - & refTetrahedron, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, & - & beta, & - & lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! Point of evaluation - !! x(1, :) is x coord - !! x(2, :) is y coord - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Tetrahedron2 -END INTERFACE LagrangeEvalAll_Tetrahedron - -!---------------------------------------------------------------------------- -! QuadraturePoints_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: quadrature points on Tetrahedron - -INTERFACE QuadraturePoint_Tetrahedron - MODULE FUNCTION QuadraturePoint_Tetrahedron1(& - & order, & - & quadType, & - & refTetrahedron, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! Reference triangle - !! BIUNIT - !! UNIT - !! If xij is present then this argument is ignored - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3. - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Tetrahedron1 -END INTERFACE QuadraturePoint_Tetrahedron - -!---------------------------------------------------------------------------- -! QuadraturePoints_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: quadrature points on Tetrahedron - -INTERFACE QuadraturePoint_Tetrahedron - MODULE FUNCTION QuadraturePoint_Tetrahedron2(& - & nips, & - & quadType, & - & refTetrahedron, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nips(1) - !! nips(1) .LE. 79, then we call - !! economical quadrature rules. - !! Otherwise, this routine will retport - !! error - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type, - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! Reference triangle - !! BIUNIT - !! UNIT - !! If xij is present then this argument is ignored - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3 - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Tetrahedron2 -END INTERFACE QuadraturePoint_Tetrahedron - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points on Tetrahedron - -INTERFACE TensorQuadraturePoint_Tetrahedron - MODULE FUNCTION TensorQuadraturePoint_Tetrahedron1(order, quadType, & - & refTetrahedron, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij can be 4. - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Tetrahedron1 -END INTERFACE TensorQuadraturePoint_Tetrahedron - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points - -INTERFACE TensorQuadraturePoint_Tetrahedron - MODULE FUNCTION TensorQuadraturePoint_Tetrahedron2( & - & nipsx, & - & nipsy, & - & nipsz, & - & quadType, & - & refTetrahedron, & - & xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nipsx(1) - !! number of integration points in x direction - INTEGER(I4B), INTENT(IN) :: nipsy(1) - !! number of integration points in y direction - INTEGER(I4B), INTENT(IN) :: nipsz(1) - !! number of integration points in z direction - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! Reference triangle - !! BIUNIT - !! UNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij should be 3 - !! The number of columns in xij should be 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Tetrahedron2 -END INTERFACE TensorQuadraturePoint_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-23 -! summary: GradientEvaluate all Lagrange polynomials at several points - -INTERFACE LagrangeGradientEvalAll_Tetrahedron - MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( & - & order, & - & x, & - & xij, & - & refTetrahedron, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, & - & beta, & - & lambda & - & ) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! Point of evaluation - !! x(1, :) is x coord - !! x(2, :) is y coord - !! x(3, :) is z coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron - !! UNIT *default - !! BIUNIT - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 3) - !! 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_Tetrahedron1 -END INTERFACE LagrangeGradientEvalAll_Tetrahedron - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Orthogongal basis on Tetrahedron - -INTERFACE OrthogonalBasisGradient_Tetrahedron - MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1( & - & order, & - & xij, & - & refTetrahedron) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! Points of evaluation in reference Tetrahedron. - !! The shape functions will be evaluated - !! at these points. - !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! "UNIT" - !! "BIUNIT" - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6, 3) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION OrthogonalBasisGradient_Tetrahedron1 -END INTERFACE OrthogonalBasisGradient_Tetrahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the heirarchical basis functions on Tetrahedron - -INTERFACE HeirarchicalBasisGradient_Tetrahedron - MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & xij, & - & refTetrahedron) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge parallel to x - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge parallel to y - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge parallel to z - INTEGER(I4B), INTENT(IN) :: pe4 - !! order of interpolation on edge parallel to xy - INTEGER(I4B), INTENT(IN) :: pe5 - !! order of interpolation on edge parallel to xz - INTEGER(I4B), INTENT(IN) :: pe6 - !! order of interpolation on edge parallel to yz - INTEGER(I4B), INTENT(IN) :: ps1 - !! order of interpolation on facet parallel to xy - INTEGER(I4B), INTENT(IN) :: ps2 - !! order of interpolation on facet parallel to xz - INTEGER(I4B), INTENT(IN) :: ps3 - !! order of interpolation on facet parallel to yz - INTEGER(I4B), INTENT(IN) :: ps4 - !! order of interpolation on facet parallel to xyz - REAL(DFP), INTENT(IN) :: xij(:, :) - !! order on xij - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! UNIT or BIUNIT - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & 4 & - & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & - & + (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2 & - & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 3) - END FUNCTION HeirarchicalBasisGradient_Tetrahedron1 -END INTERFACE HeirarchicalBasisGradient_Tetrahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the heirarchical basis functions on Tetrahedron - -INTERFACE HeirarchicalBasisGradient_Tetrahedron - MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron2( & - & order, & - & xij, & - & refTetrahedron) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - REAL(DFP), INTENT(IN) :: xij(:, :) - !! order on xij - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! UNIT or BIUNIT - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6_I4B, 3) - END FUNCTION HeirarchicalBasisGradient_Tetrahedron2 -END INTERFACE HeirarchicalBasisGradient_Tetrahedron - -!---------------------------------------------------------------------------- -! Tetrahedron -!---------------------------------------------------------------------------- - -END MODULE TetrahedronInterpolationUtility diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 deleted file mode 100644 index 463931d91..000000000 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ /dev/null @@ -1,1633 +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 TriangleInterpolationUtility -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE -PUBLIC :: LagrangeDegree_Triangle -PUBLIC :: LagrangeDOF_Triangle -PUBLIC :: LagrangeInDOF_Triangle -PUBLIC :: EquidistanceInPoint_Triangle -PUBLIC :: EquidistancePoint_Triangle -PUBLIC :: InterpolationPoint_Triangle -PUBLIC :: LagrangeCoeff_Triangle - -PUBLIC :: Dubiner_Triangle -PUBLIC :: OrthogonalBasis_Triangle -PUBLIC :: OrthogonalBasisGradient_Triangle - -PUBLIC :: VertexBasis_Triangle -PUBLIC :: EdgeBasis_Triangle -PUBLIC :: CellBasis_Triangle -PUBLIC :: HeirarchicalBasis_Triangle -PUBLIC :: HeirarchicalBasisGradient_Triangle - -PUBLIC :: LagrangeEvalAll_Triangle -PUBLIC :: LagrangeGradientEvalAll_Triangle -PUBLIC :: QuadraturePoint_Triangle -PUBLIC :: IJ2VEFC_Triangle -PUBLIC :: FacetConnectivity_Triangle -PUBLIC :: RefElemDomain_Triangle - -PUBLIC :: GetTotalDOF_Triangle -PUBLIC :: GetTotalInDOF_Triangle - -! PUBLIC :: BarycentricVertexBasis_Triangle -! PUBLIC :: BarycentricEdgeBasis_Triangle -! PUBLIC :: BarycentricHeirarchicalBasis_Triangle -! PUBLIC :: BarycentricHeirarchicalBasisGradient_Triangle - -!---------------------------------------------------------------------------- -! GetTotalDOF_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on Triangle - -INTERFACE - MODULE PURE FUNCTION GetTotalDOF_Triangle(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalDOF_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Triangle -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial on an edge of a Triangle -!- These dof are strictly inside the Triangle - -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Triangle(order, baseContinuity, & - baseInterpolation) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation - INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! RefElemDomain_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the name of the reference element domain - -INTERFACE - MODULE FUNCTION RefElemDomain_Triangle(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 - !! UNIT or BIUNIT - END FUNCTION RefElemDomain_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetConnectivity_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-10 -! 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 - INTEGER(I4B) :: ans(2, 3) - !! rows represents the end points of an edges - !! columns denote the edge (facet) - END FUNCTION FacetConnectivity_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! IJ2VEFC_Triangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE IJ2VEFC_Triangle(xi, eta, temp, order, N) - REAL(DFP), INTENT(IN) :: xi(:, :) - REAL(DFP), INTENT(IN) :: eta(:, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: N - END SUBROUTINE IJ2VEFC_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE - MODULE PURE FUNCTION LagrangeDegree_Triangle(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - !! number of rows = LagrangeDOf_Triangle(order) - !! number of cols = 2 - END FUNCTION LagrangeDegree_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDegree_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE - MODULE PURE SUBROUTINE LagrangeDegree_Triangle_(order, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(INOUT) :: ans(:, :) - !! number of rows = LagrangeDOf_Triangle(order) - !! number of cols = 2 - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeDegree_Triangle_ -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeDOF_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial on triangle - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF_Triangle(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeDOF_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns the total number of degree of freedom for a -! lagrange polynomial in cell/face of triangle -! -!# Introduction -! -!- Returns the total number of degree of freedom for a -! lagrange polynomial in cell/face of triangle -!- These dof are strictly inside the triangle - -INTERFACE - MODULE PURE FUNCTION LagrangeInDOF_Triangle(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LagrangeInDOF_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in triangle -! -!# Introduction -! -!- This function returns the equidistance points in triangle -!- All points are inside the triangle - -INTERFACE - MODULE PURE FUNCTION EquidistanceInPoint_Triangle(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - !! If xij is present then number of rows in ans is same as xij - !! If xij is not present then number of rows in ans is 2. - END FUNCTION EquidistanceInPoint_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! EquidistancePoint_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order triangle element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! triangle element, the layout is always "VEFC" -!- The coordinates are distributed uniformly -!- These coordinates can be used to construct lagrange polynomials -!- The returned coordinates are in $x_{iJ}$ format. -!- The node numbering is according to Gmsh convention, VEFC. - -INTERFACE - MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Triangle(order, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format - END FUNCTION EquidistancePoint_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BlythPozrikidis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Blyth Pozrikidis nodes on triangle -! -!# Introduction -! -! M. G. Blyth and C. Pozrikidis. -! A lobatto interpolation grid over the triangle. -! IMA Journal of Applied Mathematics, 71(1):153–169, Feb 2006. -! URL: http://dx.doi.org/10.1093/imamat/hxh077, -! doi:10.1093/imamat/hxh077. - -INTERFACE - MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, & - & alpha, beta, lambda) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: ipType - !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, - !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! xij coordinates - CHARACTER(*), INTENT(IN) :: layout - !! local node numbering layout - !! only layout = "VEFC" is allowed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! xij coordinates - END FUNCTION BlythPozrikidis_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! Isaac_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Isaac points on triangle - -INTERFACE - MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, & - & alpha, beta, lambda) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: ipType - !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, - !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! xij coordinates - CHARACTER(*), INTENT(IN) :: layout - !! local node numbering layout - !! only layout = "VEFC" is allowed - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! xij coordinates - END FUNCTION Isaac_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! InterpolationPoint_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation points on triangle -! -!# Introduction -! -!- This routine returns the interplation points on triangle. -!- `xij` contains nodal coordinates of triangle in xij format. -!- SIZE(xij,1) = nsd, and SIZE(xij,2)=3 -!- If xij is absent then unit triangle is assumed -!- `ipType` is interpolation point type, it can take following values -!- `Equidistance`, uniformly/evenly distributed points -!- `GaussLegendreLobatto ---> IsaacLegendre -!- `GaussChebyshevLobatto ---> IsaacChebyshev -!- `ChenBabuska` -!- `Hesthaven` -!- `Feket` -!- `BlythPozChebyshev` -!- `BlythPozLegendre` -!- `IsaacChebyshev` -!- `IsaacLegendre` -! -!- `layout` specifies the arrangement of points. The nodes are always -! returned in VEFC format (vertex, edge, face, cell). 1:3 are are -! vertex points, then edge, and then internal nodes. The internal nodes -! also follow the same convention. Please read Gmsh manual on this topic. - -INTERFACE - MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, & - & layout, xij, alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Coord of domain in xij format - CHARACTER(*), INTENT(IN) :: layout - !! local node numbering layout, always VEFC - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! xij coordinates - END FUNCTION InterpolationPoint_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Returns the coefficients for ith lagrange polynomial - -INTERFACE LagrangeCoeff_Triangle - MODULE FUNCTION LagrangeCoeff_Triangle1(order, i, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Triangle1 -END INTERFACE 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 FUNCTION LagrangeCoeff_Triangle2(order, i, v, isVandermonde) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue, the value of isVandermonde - !! is not used in the function - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients of ith Lagrange polynomial - END FUNCTION LagrangeCoeff_Triangle2 -END INTERFACE LagrangeCoeff_Triangle - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Returns the coefficients for ith lagrange polynomial - -INTERFACE LagrangeCoeff_Triangle - MODULE FUNCTION LagrangeCoeff_Triangle3(order, i, v, ipiv) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Triangle3 -END INTERFACE 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 FUNCTION LagrangeCoeff_Triangle4(order, xij, basisType, & - refTriangle) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials - !! Jacobi (Dubiner) - !! Heirarchical - CHARACTER(*), OPTIONAL, INTENT(IN) :: refTriangle - !! UNIT - !! BIUNIT - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION 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_Triangle4_(order, xij, basisType, & - refTriangle, 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) - !! Heirarchical - CHARACTER(*), INTENT(IN) :: refTriangle - !! UNIT - !! BIUNIT - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeCoeff_Triangle4_ -END INTERFACE LagrangeCoeff_Triangle_ - -!---------------------------------------------------------------------------- -! DubinerPolynomial -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on triangle -! -!# Introduction -! -! Forms Dubiner basis on reference triangle domain. Reference triangle -! can be biunit or unit. -! -! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) -! N = 0.5*(order+1)*(order+2). -! -! In this way, ans(j,:) denotes the values of all polynomial at jth point -! -! Polynomials are returned in following way: -! -!$$ -! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ -! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ -! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ -! \cdots -! P_{order,0} -!$$ -! -! For example for order=3, the polynomials are arranged as: -! -!$$ -! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ -! P_{1,0}, P_{1,1}, P_{1,2} \\ -! P_{2,0}, P_{2,1} \\ -! P_{3,0} -!$$ - -INTERFACE Dubiner_Triangle - MODULE PURE FUNCTION Dubiner_Triangle1(order, xij, refTriangle) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! Points in reference triangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference domain of triangle where xij are defined - !! "UNIT" - !! "BIUNIT" - REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2) - !! Shape Functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION Dubiner_Triangle1 -END INTERFACE Dubiner_Triangle - -INTERFACE OrthogonalBasis_Triangle - MODULE PROCEDURE Dubiner_Triangle1 -END INTERFACE OrthogonalBasis_Triangle - -!---------------------------------------------------------------------------- -! DubinerPolynomial -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on triangle -! -!# Introduction -! -! Forms Dubiner basis on reference triangle domain. Reference triangle -! can be biunit or unit. -! -! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) -! N = 0.5*(order+1)*(order+2). -! -! In this way, ans(j,:) denotes the values of all polynomial at jth point -! -! Polynomials are returned in following way: -! -!$$ -! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ -! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ -! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ -! \cdots -! P_{order,0} -!$$ -! -! For example for order=3, the polynomials are arranged as: -! -!$$ -! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ -! P_{1,0}, P_{1,1}, P_{1,2} \\ -! P_{2,0}, P_{2,1} \\ -! P_{3,0} -!$$ - -INTERFACE Dubiner_Triangle_ - MODULE PURE SUBROUTINE Dubiner_Triangle1_(order, xij, refTriangle, ans, & - nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! Points in reference triangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference domain of triangle where xij are defined - !! "UNIT" - !! "BIUNIT" - 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_Triangle1_ -END INTERFACE Dubiner_Triangle_ - -!---------------------------------------------------------------------------- -! DubinerPolynomial -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on triangle -! -!# Introduction -! -! Forms Dubiner basis on reference triangle domain. Reference triangle -! can be biunit or unit. Here x and y are coordinate on line. -! xij is given by outerproduct of x and y. - -INTERFACE Dubiner_Triangle - MODULE PURE FUNCTION Dubiner_Triangle2(order, x, y, refTriangle) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: x(:), y(:) - !! x and y coordinates, total points = SIZE(x)*SIZE(y) - !! x denotes the coordinates along the x direction - !! y denotes the coordinates along the y direction - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference domain of triangle where xij are defined - !! "UNIT" - !! "BIUNIT" - REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION Dubiner_Triangle2 -END INTERFACE Dubiner_Triangle - -INTERFACE OrthogonalBasis_Triangle - MODULE PROCEDURE Dubiner_Triangle2 -END INTERFACE OrthogonalBasis_Triangle - -!---------------------------------------------------------------------------- -! DubinerPolynomial -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on triangle -! -!# Introduction -! -! Forms Dubiner basis on reference triangle domain. Reference triangle -! can be biunit or unit. Here x and y are coordinate on line. -! xij is given by outerproduct of x and y. - -INTERFACE Dubiner_Triangle_ - MODULE PURE SUBROUTINE Dubiner_Triangle2_(order, x, y, refTriangle, ans, & - nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: x(:), y(:) - !! x and y coordinates, total points = SIZE(x)*SIZE(y) - !! x denotes the coordinates along the x direction - !! y denotes the coordinates along the y direction - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference domain of triangle where xij are defined - !! "UNIT" - !! "BIUNIT" - 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_Triangle2_ -END INTERFACE Dubiner_Triangle_ - -!---------------------------------------------------------------------------- -! BarycentricVertexBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on reference Triangle - -INTERFACE - MODULE PURE SUBROUTINE BarycentricVertexBasis_Triangle(lambda, ans) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentrix coords - !! number of rows = 3 corresponding to three coordinates - !! number of columns = number of points - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), 3) - !! ans(:,v1) basis function of vertex v1 at all points - END SUBROUTINE BarycentricVertexBasis_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! VertexBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit Triangle - -INTERFACE - MODULE PURE FUNCTION VertexBasis_Triangle(xij, refTriangle) RESULT(ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation on the triangle - CHARACTER(*), INTENT(IN) :: refTriangle - !! UNIT or BIUNIT - REAL(DFP) :: ans(SIZE(xij, 2), 3) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on edge of triangle -! -!# Introduction -! -! Evaluate basis functions on edges of triangle -! pe1, pe2, pe3 should be greater than or equal to 2 - -INTERFACE - MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle(pe1, pe2, pe3, & - lambda, ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to three corresponding to - !! three coordinates - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) - END SUBROUTINE BarycentricEdgeBasis_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! EdgeBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on left, right edge of biunit Triangle -! -!# Introduction -! -! Evaluate basis functions on left and right edge of biunit Triangle -! -! qe1 and qe2 should be greater than or equal to 2 - -INTERFACE - MODULE PURE FUNCTION EdgeBasis_Triangle(pe1, pe2, pe3, xij, refTriangle) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on left vertical edge (e1), should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on right vertical edge(e2), should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on right vertical edge(e3), should be greater than 1 - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - REAL(DFP) :: ans(SIZE(xij, 2), pe1 + pe2 + pe3 - 3) - END FUNCTION EdgeBasis_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCellBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the Cell basis functions on reference Triangle - -INTERFACE - MODULE PURE SUBROUTINE BarycentricCellBasis_Triangle(order, lambda, ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in this cell, it should be greater than 2 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentrix coords - !! number of rows = 3 corresponding to three coordinates - !! number of columns = number of points - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) - END SUBROUTINE BarycentricCellBasis_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! CellBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis in the cell of biunit Triangle -! -!# Introduction -! -! Evaluate basis functions in the cell of biunit Triangle - -INTERFACE - MODULE PURE FUNCTION CellBasis_Triangle(order, xij, refTriangle) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of approximation inside the cell, order>2 - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - REAL(DFP) :: ans(SIZE(xij, 2), INT((order - 1) * (order - 2) / 2)) - END FUNCTION CellBasis_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE BarycentricHeirarchicalBasis_Triangle - MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle1(order, & - & pe1, pe2, pe3, lambda, refTriangle, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge e1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge e2 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge e3 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 3 - !! number of cols = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! reference triangle, "BIUNIT", "UNIT" - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans( & - ! & SIZE(lambda, 2), & - ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) - !! - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE BarycentricHeirarchicalBasis_Triangle1 -END INTERFACE BarycentricHeirarchicalBasis_Triangle - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE BarycentricHeirarchicalBasis_Triangle -MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle2(order, lambda, & - & refTriangle, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order of approximation on triangle - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 3 - !! number of cols = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! reference triangle, "BIUNIT", "UNIT" - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans( & - ! & SIZE(lambda, 2), & - ! & INT((order + 1) * (order + 2) / 2)) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE BarycentricHeirarchicalBasis_Triangle2 -END INTERFACE BarycentricHeirarchicalBasis_Triangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE HeirarchicalBasis_Triangle - MODULE PURE FUNCTION HeirarchicalBasis_Triangle1(order, pe1, pe2, pe3,& - & xij, refTriangle) RESULT(ans) - 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)) - !! - END FUNCTION HeirarchicalBasis_Triangle1 -END INTERFACE HeirarchicalBasis_Triangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-22 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE HeirarchicalBasis_Triangle - MODULE PURE FUNCTION HeirarchicalBasis_Triangle2(order, 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 - 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), & - 3 * order + INT((order - 1) * (order - 2) / 2)) - !! - END FUNCTION HeirarchicalBasis_Triangle2 -END INTERFACE HeirarchicalBasis_Triangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE HeirarchicalBasis_Triangle_ - MODULE PURE 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 - 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), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans( & - ! & SIZE(xij, 2), & - ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) - !! - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE HeirarchicalBasis_Triangle1_ -END INTERFACE HeirarchicalBasis_Triangle_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE HeirarchicalBasis_Triangle_ - MODULE PURE 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 - 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), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans( & - ! & SIZE(xij, 2), & - ! & order*3 + INT((order - 1) * (order - 2) / 2)) - !! - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE HeirarchicalBasis_Triangle2_ -END INTERFACE HeirarchicalBasis_Triangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-21 -! summary: Evaluate the gradient of the edge basis on triangle -! using barycentric coordinate - -INTERFACE - MODULE PURE SUBROUTINE BarycentricVertexBasisGradient_Triangle(lambda, ans) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! ans(SIZE(lambda, 2), 3, 3) - END SUBROUTINE BarycentricVertexBasisGradient_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-04-21 -! summary: Evaluate the gradient of the edge basis on triangle -! using barycentric coordinate - -INTERFACE - MODULE PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle(pe1, pe2, pe3, & - lambda, ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) - END SUBROUTINE BarycentricEdgeBasisGradient_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-04-21 -! summary: Evaluate the gradient of the edge basis on triangle -! using barycentric coordinate - -INTERFACE - MODULE PURE SUBROUTINE BarycentricCellBasisGradient_Triangle(order, lambda, & - ans) - INTEGER(I4B), INTENT(IN) :: order - !! order on Cell (e1) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), 3*order - 3, 3) - END SUBROUTINE BarycentricCellBasisGradient_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu and Vikas Sharma -! date: 2024-04-21 -! summary: Evaluate the gradient of the Hierarchical basis on triangle - -INTERFACE BarycentricHeirarchicalBasisGradient_Triangle -MODULE PURE SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1(order, & - & pe1, pe2, pe3, lambda, refTriangle, ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge e1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge e2 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge e3 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 3 - !! number of cols = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! reference triangle, "BIUNIT", "UNIT" - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans( & - ! & SIZE(lambda, 2), & - ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 3) - !! - END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1 -END INTERFACE BarycentricHeirarchicalBasisGradient_Triangle - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-04 -! 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) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(2) - !! point of evaluation - !! x(1) is x coord - !! x(2) is y coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! - CHARACTER(*), INTENT(IN) :: refTriangle - !! interpolation points - REAL(DFP), 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) :: ans(SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Triangle1 -END INTERFACE LagrangeEvalAll_Triangle - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-04 -! 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) - 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 - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - !! Biunit - !! Unit - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Jacobi=Dubiner - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Triangle2 -END INTERFACE LagrangeEvalAll_Triangle - -!---------------------------------------------------------------------------- -! QuadraturePoints_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: based quadrature points - -INTERFACE QuadraturePoint_Triangle - MODULE FUNCTION QuadraturePoint_Triangle1(order, quadType, refTriangle, & - xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - !! Biunit - !! Unit - !! If xij is present,then this parameter is not used - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij can be 2 or 3. - !! The number of columns in xij should be 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Triangle1 -END INTERFACE QuadraturePoint_Triangle - -!---------------------------------------------------------------------------- -! QuadraturePoints_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: based quadrature points - -INTERFACE QuadraturePoint_Triangle - MODULE FUNCTION QuadraturePoint_Triangle2(nips, quadType, refTriangle, & - xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nips(1) - !! nips(1) .LE. 79, then we call - !! economical quadrature rules. - !! Otherwise, this routine will retport - !! error - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type, - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - !! Biunit - !! Unit - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij can be 2 or 3. - !! The number of columns in xij should be 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION QuadraturePoint_Triangle2 -END INTERFACE QuadraturePoint_Triangle - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points - -INTERFACE TensorQuadraturePoint_Triangle - MODULE FUNCTION TensorQuadraturePoint_Triangle1(order, quadType, & - & refTriangle, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - !! Biunit - !! Unit - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij can be 2 or 3. - !! The number of columns in xij should be 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Triangle1 -END INTERFACE TensorQuadraturePoint_Triangle - -!---------------------------------------------------------------------------- -! TensorQuadraturePoints_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-20 -! summary: Tensor based quadrature points - -INTERFACE TensorQuadraturePoint_Triangle - MODULE FUNCTION TensorQuadraturePoint_Triangle2(nipsx, nipsy, quadType, & - & refTriangle, xij) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nipsx(1) - !! number of integration points in x direction - INTEGER(I4B), INTENT(IN) :: nipsy(1) - !! number of integration points in y direction - INTEGER(I4B), INTENT(IN) :: quadType - !! quadrature point type - !! currently this variable is not used - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - !! Biunit - !! Unit - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of triangle. - !! The number of rows in xij can be 2 or 3. - !! The number of columns in xij should be 3 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Quadrature points - END FUNCTION TensorQuadraturePoint_Triangle2 -END INTERFACE TensorQuadraturePoint_Triangle - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Lagrange polynomials of n at several points - -INTERFACE LagrangeGradientEvalAll_Triangle - MODULE FUNCTION LagrangeGradientEvalAll_Triangle1( & - & 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(:, :) - !! 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 - CHARACTER(*), INTENT(IN) :: refTriangle - !! Reference triangle - !! Biunit - !! Unit - 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_Triangle1 -END INTERFACE LagrangeGradientEvalAll_Triangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu and Vikas Sharma -! date: 2024-04-21 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE HeirarchicalBasisGradient_Triangle - 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 - 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) - END FUNCTION HeirarchicalBasisGradient_Triangle1 -END INTERFACE HeirarchicalBasisGradient_Triangle - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Triangle_ -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu and Vikas Sharma -! date: 2024-04-21 -! 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) - 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), INTENT(INOUT) :: ans(:, :, :) - !! ans( & - !! & SIZE(xij, 2), & - !! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 2) - INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 - END SUBROUTINE HeirarchicalBasisGradient_Triangle1_ -END INTERFACE HeirarchicalBasisGradient_Triangle_ - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on triangle -! -!# Introduction -! -! Forms Dubiner basis on reference triangle domain. Reference triangle -! can be biunit or unit. -! -! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) -! N = 0.5*(order+1)*(order+2). -! -! In this way, ans(j,:) denotes the values of all polynomial at jth point -! -! Polynomials are returned in following way: -! -!$$ -! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ -! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ -! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ -! \cdots -! P_{order,0} -!$$ -! -! For example for order=3, the polynomials are arranged as: -! -!$$ -! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ -! P_{1,0}, P_{1,1}, P_{1,2} \\ -! P_{2,0}, P_{2,1} \\ -! P_{3,0} -!$$ - -INTERFACE OrthogonalBasisGradient_Triangle - MODULE FUNCTION OrthogonalBasisGradient_Triangle1( & - & order, & - & xij, & - & refTriangle) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in reference triangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! "UNIT" - !! "BIUNIT" - REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2, 2) - !! Derivative of shape functions - !! ans(:, j, 1), derivative wrt x of jth shape functions at all points - !! ans(j, :, 1), derivative wrt x of all shape functions at jth point - END FUNCTION OrthogonalBasisGradient_Triangle1 -END INTERFACE OrthogonalBasisGradient_Triangle - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on triangle -! -!# Introduction -! -! Forms Dubiner basis on reference triangle domain. Reference triangle -! can be biunit or unit. -! -! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) -! N = 0.5*(order+1)*(order+2). -! -! In this way, ans(j,:) denotes the values of all polynomial at jth point -! -! Polynomials are returned in following way: -! -!$$ -! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ -! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ -! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ -! \cdots -! P_{order,0} -!$$ -! -! For example for order=3, the polynomials are arranged as: -! -!$$ -! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ -! P_{1,0}, P_{1,1}, P_{1,2} \\ -! P_{2,0}, P_{2,1} \\ -! P_{3,0} -!$$ - -INTERFACE OrthogonalBasisGradient_Triangle_ - MODULE SUBROUTINE OrthogonalBasisGradient_Triangle1_(order, xij, & - refTriangle, ans, tsize1, tsize2, tsize3) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in reference triangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! "UNIT" - !! "BIUNIT" - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2, 2) - !! Derivative of shape functions - !! ans(:, j, 1), derivative wrt x of jth shape functions at all points - !! ans(j, :, 1), derivative wrt x of all shape functions at jth point - INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 - END SUBROUTINE OrthogonalBasisGradient_Triangle1_ -END INTERFACE OrthogonalBasisGradient_Triangle_ - -!---------------------------------------------------------------------------- -! Triangle -!---------------------------------------------------------------------------- - -END MODULE TriangleInterpolationUtility diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 deleted file mode 100644 index b60a68710..000000000 --- a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 +++ /dev/null @@ -1,1251 +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: 3 Aug 2022 -! summary: Utility related to Ultraspherical Polynomials is defined. -! -!{!pages/UltrasphericalPolynomialUtility.md!} - -MODULE UltrasphericalPolynomialUtility -USE GlobalData -USE BaseType, ONLY: iface_1DFunction -IMPLICIT NONE -PRIVATE -PUBLIC :: UltrasphericalAlpha -PUBLIC :: UltrasphericalBeta -PUBLIC :: GetUltrasphericalRecurrenceCoeff -PUBLIC :: GetUltrasphericalRecurrenceCoeff2 -PUBLIC :: UltrasphericalLeadingCoeff -PUBLIC :: UltrasphericalLeadingCoeffRatio -PUBLIC :: UltrasphericalNormSQR -PUBLIC :: UltrasphericalNormSQR2 -PUBLIC :: UltrasphericalNormSQRRatio -PUBLIC :: UltrasphericalJacobiMatrix -PUBLIC :: UltrasphericalGaussQuadrature -PUBLIC :: UltrasphericalJacobiRadauMatrix -PUBLIC :: UltrasphericalGaussRadauQuadrature -PUBLIC :: UltrasphericalJacobiLobattoMatrix -PUBLIC :: UltrasphericalGaussLobattoQuadrature -PUBLIC :: UltrasphericalZeros -PUBLIC :: UltrasphericalQuadrature -PUBLIC :: UltrasphericalEval -PUBLIC :: UltrasphericalEvalAll -PUBLIC :: UltrasphericalEvalAll_ -PUBLIC :: UltrasphericalGradientEvalAll -PUBLIC :: UltrasphericalGradientEvalAll_ -PUBLIC :: UltrasphericalGradientEval -PUBLIC :: UltrasphericalEvalSum -PUBLIC :: UltrasphericalGradientEvalSum -PUBLIC :: UltrasphericalTransform -PUBLIC :: UltrasphericalInvTransform -PUBLIC :: UltrasphericalGradientCoeff -PUBLIC :: UltrasphericalDMatrix -PUBLIC :: UltrasphericalDMatEvenOdd - -!---------------------------------------------------------------------------- -! UltrasphericalAlpha -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Recurrence coefficient, alpha , of Ultraspherical polynomial - -INTERFACE - MODULE PURE FUNCTION UltrasphericalAlpha(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans - !! answer - END FUNCTION UltrasphericalAlpha -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalBeta -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Recurrence coefficient, beta, of Ultraspherical polynomial - -INTERFACE - MODULE PURE FUNCTION UltrasphericalBeta(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans - !! answer - END FUNCTION UltrasphericalBeta -END INTERFACE - -!---------------------------------------------------------------------------- -! GetUltrasphericalRecurrenceCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Return the recurrence coefficient for nth order polynomial (monic) - -INTERFACE - MODULE PURE SUBROUTINE GetUltrasphericalRecurrenceCoeff(n, & - & lambda, alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial, it should be greater than 1 - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - !! lambda should not be zero - REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) - REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) - END SUBROUTINE GetUltrasphericalRecurrenceCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! GetUltrasphericalRecurrenceCoeff2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Return the recurrence coefficient for nth order polynomial (monic) - -INTERFACE - MODULE PURE SUBROUTINE GetUltrasphericalRecurrenceCoeff2(n, lambda, & - & A, B, C) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial, it should be greater than 1 - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - !! lambda should not be 0.0 - REAL(DFP), INTENT(OUT) :: A(0:n - 1) - !! size is n - REAL(DFP), INTENT(OUT) :: B(0:n - 1) - !! this coefficient is zero - REAL(DFP), INTENT(OUT) :: C(0:n - 1) - !! size is n - END SUBROUTINE GetUltrasphericalRecurrenceCoeff2 -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalLeadingCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Leading coefficient of Ultraspherical polynomial - -INTERFACE - MODULE PURE FUNCTION UltrasphericalLeadingCoeff(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans - !! answer - END FUNCTION UltrasphericalLeadingCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalLeadingCoeffRatio -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct 2022 -! summary: Ratio of leading coefficients, kn+1/kn - -INTERFACE - MODULE PURE FUNCTION UltrasphericalLeadingCoeffRatio(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans - !! answer - END FUNCTION UltrasphericalLeadingCoeffRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalNormSQR -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Square norm of Ultraspherical polynomial - -INTERFACE - MODULE PURE FUNCTION UltrasphericalNormSQR(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans - END FUNCTION UltrasphericalNormSQR -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalNormSQR2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Square norm of Ultraspherical polynomial - -INTERFACE - MODULE PURE FUNCTION UltrasphericalNormSQR2(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans(0:n) - END FUNCTION UltrasphericalNormSQR2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Square norm ration of Ultraspherical polynomial, n+1/n - -INTERFACE - MODULE PURE FUNCTION UltrasphericalNormSQRRatio(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans - END FUNCTION UltrasphericalNormSQRRatio -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalJacobiMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Return the Jacobi matrix for Ultraspherical polynomial - -INTERFACE - MODULE PURE SUBROUTINE UltrasphericalJacobiMatrix(n, lambda, D, E, & - & alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n-1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - !! recurrence coefficient of monic Ultraspherical polynomial, from 0 to n-1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - !! recurrence coefficient of monic Ultraspherical polynomial, from 0 to n-1 - END SUBROUTINE UltrasphericalJacobiMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalGaussQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss quadrature points for Ultraspherical Polynomial - -INTERFACE - MODULE SUBROUTINE UltrasphericalGaussQuadrature(n, lambda, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! It represents the order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(OUT) :: pt(:) - !! the size is 1 to n - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! the size is 1 to n - END SUBROUTINE UltrasphericalGaussQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalJacobiRadauMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE UltrasphericalJacobiRadauMatrix(a, n, lambda, D, E, & - & alphaCoeff, betaCoeff) - REAL(DFP), INTENT(IN) :: a - !! one of the end of the domain - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+1 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE UltrasphericalJacobiRadauMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalGaussRadauQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss-Radau quadrature points for Ultraspherical -! Polynomial - -INTERFACE - MODULE SUBROUTINE UltrasphericalGaussRadauQuadrature(a, n, lambda, pt, wt) - REAL(DFP), INTENT(IN) :: a - !! the value of one of the end points - !! it should be either -1 or +1 - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(OUT) :: pt(:) - !! n+1 quadrature points from 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! n+1 weights from 1 to n+1 - END SUBROUTINE UltrasphericalGaussRadauQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalUltrasphericalLobattoMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE UltrasphericalJacobiLobattoMatrix(n, lambda, D, E, & - & alphaCoeff, betaCoeff) - INTEGER(I4B), INTENT(IN) :: n - !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(OUT) :: D(:) - !! the size should be 1:n+2 - REAL(DFP), INTENT(OUT) :: E(:) - !! the size should be 1:n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) - REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE UltrasphericalJacobiLobattoMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalGaussLobattoQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss-Lobatto quadrature points for Ultraspherical -! Polynomial - -INTERFACE - MODULE SUBROUTINE UltrasphericalGaussLobattoQuadrature(n, lambda, pt, wt) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomials - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(OUT) :: pt(:) - !! n+2 quad points indexed from 1 to n+2 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) - !! n+2 weights, index from 1 to n+2 - END SUBROUTINE UltrasphericalGaussLobattoQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalZeros -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Returns zeros of Ultraspherical polynomials - -INTERFACE - MODULE FUNCTION UltrasphericalZeros(n, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP) :: ans(n) - END FUNCTION UltrasphericalZeros -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalQuadrature -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: This routine can return Ultraspherical-Gauss, Ultraspherical-Radau, -! Ultraspherical-Lobatto -! -!# Introduction -! -! This routine returns the Quadrature point of Ultraspherical polynomial -! -!@note -! Here n is the number of quadrature points. Please note it is not -! the order of Ultraspherical polynomial. The order is decided internally -! depending upon the quadType -!@endnote -! -!@note -! pt and wt should be allocated outside, and length should be n. -!@endnote -! - -INTERFACE - MODULE SUBROUTINE UltrasphericalQuadrature(n, lambda, pt, wt, & - & quadType, onlyInside) - INTEGER(I4B), INTENT(IN) :: n - !! number of quadrature points, the order will be computed as follows - !! for quadType = Gauss, n is same as order of Ultraspherical polynomial - !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 - !! for quadType = GaussLobatto, n = order+2 - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(OUT) :: pt(n) - !! n+1 quadrature points from 1 to n+1 - REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) - !! n+1 weights from 1 to n+1 - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss - !! GaussRadauLeft - !! GaussRadauRight - !! GaussLobatto - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside - !! only inside - END SUBROUTINE UltrasphericalQuadrature -END INTERFACE - -!---------------------------------------------------------------------------- -! UltrasphericalEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several -! points -! -!# Introduction -! -! Evaluate Ultraspherical polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at -! the point -! X. - -INTERFACE - MODULE PURE FUNCTION UltrasphericalEval1(n, lambda, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalEval1 -END INTERFACE - -INTERFACE UltrasphericalEval - MODULE PROCEDURE UltrasphericalEval1 -END INTERFACE UltrasphericalEval - -!---------------------------------------------------------------------------- -! UltrasphericalEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several -! points -! -!# Introduction -! -! Evaluate Ultraspherical polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at -! the point -! X. - -INTERFACE - MODULE PURE FUNCTION UltrasphericalEval2(n, lambda, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalEval2 -END INTERFACE - -INTERFACE UltrasphericalEval - MODULE PROCEDURE UltrasphericalEval2 -END INTERFACE UltrasphericalEval - -!---------------------------------------------------------------------------- -! UltrasphericalEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several -! points -! -!# Introduction -! -! Evaluate Ultraspherical polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at -! the point -! X. - -INTERFACE UltrasphericalEvalAll - MODULE PURE FUNCTION UltrasphericalEvalAll1(n, lambda, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(n + 1) - !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION UltrasphericalEvalAll1 -END INTERFACE UltrasphericalEvalAll - -!---------------------------------------------------------------------------- -! UltrasphericalEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several -! points -! -!# Introduction -! -! Evaluate Ultraspherical polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at -! the point -! X. - -INTERFACE UltrasphericalEvalAll_ - MODULE PURE SUBROUTINE UltrasphericalEvalAll1_(n, lambda, x, ans, tsize) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x - REAL(DFP), INTENT(INOUT) :: ans(:) - ! REAL(DFP) :: ans(n + 1) - !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) - !! at point x - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE UltrasphericalEvalAll1_ -END INTERFACE UltrasphericalEvalAll_ - -!---------------------------------------------------------------------------- -! UltrasphericalEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several -! points -! -!# Introduction -! -! Evaluate Ultraspherical polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at -! the point -! X. - -INTERFACE UltrasphericalEvalAll - MODULE PURE FUNCTION UltrasphericalEvalAll2(n, lambda, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION UltrasphericalEvalAll2 -END INTERFACE UltrasphericalEvalAll - -!---------------------------------------------------------------------------- -! UltrasphericalEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several -! points -! -!# Introduction -! -! Evaluate Ultraspherical polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at -! the point -! X. - -INTERFACE UltrasphericalEvalAll_ - MODULE PURE SUBROUTINE UltrasphericalEvalAll2_(n, lambda, x, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) - !! at point x - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow, ncol - END SUBROUTINE UltrasphericalEvalAll2_ -END INTERFACE UltrasphericalEvalAll_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Ultraspherical polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Ultraspherical polynomial of order upto n. - -INTERFACE UltrasphericalGradientEvalAll - MODULE PURE FUNCTION UltrasphericalGradientEvalAll1(n, lambda, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(1:n + 1) - END FUNCTION UltrasphericalGradientEvalAll1 -END INTERFACE UltrasphericalGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Ultraspherical polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Ultraspherical polynomial of order upto n. - -INTERFACE UltrasphericalGradientEvalAll_ - MODULE PURE SUBROUTINE UltrasphericalGradientEvalAll1_(n, lambda, x, ans, & - tsize) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x - REAL(DFP), INTENT(INOUT) :: ans(:) - !! 1:n+1 - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE UltrasphericalGradientEvalAll1_ -END INTERFACE UltrasphericalGradientEvalAll_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Ultraspherical polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Ultraspherical polynomial of order upto n. - -INTERFACE UltrasphericalGradientEvalAll - MODULE PURE FUNCTION UltrasphericalGradientEvalAll2(n, lambda, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) - END FUNCTION UltrasphericalGradientEvalAll2 -END INTERFACE UltrasphericalGradientEvalAll - -!---------------------------------------------------------------------------- -! UltraSphericalGradientEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Ultraspherical polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Ultraspherical polynomial of order upto n. - -INTERFACE UltrasphericalGradientEvalAll_ - MODULE PURE SUBROUTINE UltrasphericalGradientEvalAll2_(n, lambda, x, ans, & - nrow, ncol) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! ans(1:SIZE(x), 1:n + 1) - INTEGER(I4B), INTENT(OUT) :: nrow - INTEGER(I4B), INTENT(OUT) :: ncol - END SUBROUTINE UltrasphericalGradientEvalAll2_ -END INTERFACE UltrasphericalGradientEvalAll_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Ultraspherical polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Ultraspherical polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION UltrasphericalGradientEval1(n, lambda, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION UltrasphericalGradientEval1 -END INTERFACE -!! - -INTERFACE UltrasphericalGradientEval - MODULE PROCEDURE UltrasphericalGradientEval1 -END INTERFACE UltrasphericalGradientEval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of Ultraspherical polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of Ultraspherical polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION UltrasphericalGradientEval2(n, lambda, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda should be greater than -0.5 - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x)) - END FUNCTION UltrasphericalGradientEval2 -END INTERFACE - -INTERFACE UltrasphericalGradientEval - MODULE PROCEDURE UltrasphericalGradientEval2 -END INTERFACE UltrasphericalGradientEval - -!---------------------------------------------------------------------------- -! UltrasphericalEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Ultraspherical polynomials at point x - -INTERFACE - MODULE PURE FUNCTION UltrasphericalEvalSum1(n, lambda, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! alpha of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalEvalSum1 -END INTERFACE - -INTERFACE UltrasphericalEvalSum - MODULE PROCEDURE UltrasphericalEvalSum1 -END INTERFACE UltrasphericalEvalSum - -!---------------------------------------------------------------------------- -! UltrasphericalEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate finite sum of Ultraspherical polynomials at several x - -INTERFACE - MODULE PURE FUNCTION UltrasphericalEvalSum2(n, lambda, x, coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! alpha of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalEvalSum2 -END INTERFACE - -INTERFACE UltrasphericalEvalSum - MODULE PROCEDURE UltrasphericalEvalSum2 -END INTERFACE UltrasphericalEvalSum - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials -! at point x - -INTERFACE - MODULE PURE FUNCTION UltrasphericalGradientEvalSum1(n, lambda, x, & - & coeff) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalGradientEvalSum1 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum1 -END INTERFACE UltrasphericalGradientEvalSum - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials -! at several x - -INTERFACE - MODULE PURE FUNCTION UltrasphericalGradientEvalSum2(n, lambda, x, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalGradientEvalSum2 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum2 -END INTERFACE UltrasphericalGradientEvalSum - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth derivative of finite sum of Ultraspherical -! polynomials at point x - -INTERFACE - MODULE PURE FUNCTION UltrasphericalGradientEvalSum3(n, lambda, x, & - & coeff, k) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: x - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! order of derivative - REAL(DFP) :: ans - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalGradientEvalSum3 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum3 -END INTERFACE UltrasphericalGradientEvalSum - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate the kth gradient of finite sum of Ultraspherical -! polynomials at several x - -INTERFACE - MODULE PURE FUNCTION UltrasphericalGradientEvalSum4(n, lambda, x, & - & coeff, k) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! lambda of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: x(:) - !! point - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! Coefficient of finite sum, size = n+1 - INTEGER(I4B), INTENT(IN) :: k - !! kth order derivative - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Ultraspherical polynomial of order n at point x - END FUNCTION UltrasphericalGradientEvalSum4 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum4 -END INTERFACE UltrasphericalGradientEvalSum - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Ultraspherical Transform - -INTERFACE - MODULE PURE FUNCTION UltrasphericalTransform1(n, lambda, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION UltrasphericalTransform1 -END INTERFACE - -INTERFACE UltrasphericalTransform - MODULE PROCEDURE UltrasphericalTransform1 -END INTERFACE UltrasphericalTransform - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Ultraspherical Transform - -INTERFACE - MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION UltrasphericalTransform2 -END INTERFACE - -INTERFACE UltrasphericalTransform - MODULE PROCEDURE UltrasphericalTransform2 -END INTERFACE UltrasphericalTransform - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Ultraspherical Transform of a function on [-1,1] -! -!# Introduction -! -! This function performs the Ultraspherical transformation of f defined -! on -1 to 1. The interface of the function is give below: -! -!```fortran -! ABSTRACT INTERFACE -! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) -! IMPORT :: DFP -! REAL(DFP), INTENT(IN) :: x -! REAL(DFP) :: ans -! END FUNCTION iface_1DFunction -! END INTERFACE -!``` -! -!@note -! This routine is not pure, because this subroutine calls -! `UltrasphericalQuadrature` which is not pure due to Lapack call. -!@endnote - -INTERFACE - MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f - !! 1D space function - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n) - !! modal values or coefficients - END FUNCTION UltrasphericalTransform3 -END INTERFACE - -INTERFACE UltrasphericalTransform - MODULE PROCEDURE UltrasphericalTransform3 -END INTERFACE UltrasphericalTransform - -!---------------------------------------------------------------------------- -! UltrasphericalInvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Ultraspherical Transform - -INTERFACE - MODULE PURE FUNCTION UltrasphericalInvTransform1(n, lambda, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x - !! x point in physical space - REAL(DFP) :: ans - !! value in physical space - END FUNCTION UltrasphericalInvTransform1 -END INTERFACE - -INTERFACE UltrasphericalInvTransform - MODULE PROCEDURE UltrasphericalInvTransform1 -END INTERFACE UltrasphericalInvTransform - -!---------------------------------------------------------------------------- -! UltrasphericalInvTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Discrete Ultraspherical Transform - -INTERFACE - MODULE PURE FUNCTION UltrasphericalInvTransform2(n, lambda, coeff, x) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: x(:) - !! x point in physical space - REAL(DFP) :: ans(SIZE(x)) - !! value in physical space - END FUNCTION UltrasphericalInvTransform2 -END INTERFACE - -INTERFACE UltrasphericalInvTransform - MODULE PROCEDURE UltrasphericalInvTransform2 -END INTERFACE UltrasphericalInvTransform - -!---------------------------------------------------------------------------- -! UltrasphericalGradientCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Returns coefficient for gradient of Ultraspherical expansion -! -!# Introduction -! -! This routine returns the coefficients of gradient of Jacobi expansion. -! Input is cofficients of Jacobipolynomials (modal values). - -INTERFACE - MODULE PURE FUNCTION UltrasphericalGradientCoeff1(n, lambda, coeff) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:n) - !! coefficients $\tilde{u}_{n}$ obtained from UltrasphericalTransform - REAL(DFP) :: ans(0:n) - !! coefficient of gradient - END FUNCTION UltrasphericalGradientCoeff1 -END INTERFACE - -INTERFACE UltrasphericalGradientCoeff - MODULE PROCEDURE UltrasphericalGradientCoeff1 -END INTERFACE UltrasphericalGradientCoeff - -!---------------------------------------------------------------------------- -! UltrasphericalDMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Returns coefficient for gradient of Ultraspherical expansion -! -!# Introduction -! -! This routine returns the coefficients of gradient of Ultraspherical -! expansion. -! Input is cofficients of Ultrasphericalpolynomials (modal values). - -INTERFACE - MODULE PURE FUNCTION UltrasphericalDMatrix1(n, lambda, x, quadType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss and GaussLobatto - REAL(DFP) :: ans(0:n, 0:n) - !! D matrix - END FUNCTION UltrasphericalDMatrix1 -END INTERFACE - -INTERFACE UltrasphericalDMatrix - MODULE PROCEDURE UltrasphericalDMatrix1 -END INTERFACE UltrasphericalDMatrix - -!---------------------------------------------------------------------------- -! UltrasphericalDMatEvenOdd -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Returns coefficient for gradient of Ultraspherical expansion -! -!# Introduction -! -! This routine returns the coefficients of gradient of Ultraspherical -! expansion. -! Input is cofficients of Ultrasphericalpolynomials (modal values). -! - -INTERFACE - MODULE PURE SUBROUTINE UltrasphericalDMatEvenOdd1(n, D, e, o) - INTEGER(I4B), INTENT(IN) :: n - !! order of Ultraspherical polynomial - REAL(DFP), INTENT(IN) :: D(0:n, 0:n) - !! n+1 by n+1 - REAL(DFP), INTENT(OUT) :: e(0:, 0:) - !! even Decomposition - REAL(DFP), INTENT(OUT) :: o(0:, 0:) - !! odd decomposition - END SUBROUTINE UltrasphericalDMatEvenOdd1 -END INTERFACE - -INTERFACE UltrasphericalDMatEvenOdd - MODULE PROCEDURE UltrasphericalDMatEvenOdd1 -END INTERFACE UltrasphericalDMatEvenOdd - -END MODULE UltrasphericalPolynomialUtility diff --git a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 deleted file mode 100644 index d766d0344..000000000 --- a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 +++ /dev/null @@ -1,411 +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: 3 Aug 2022 -! summary: Utility related to UnscaledLobatto Polynomials is defined. -! -!{!pages/UnscaledLobattoPolynomialUtility.md!} - -MODULE UnscaledLobattoPolynomialUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: UnscaledLobattoLeadingCoeff -PUBLIC :: UnscaledLobattoZeros -PUBLIC :: UnscaledLobattoEval -PUBLIC :: UnscaledLobattoEvalAll -PUBLIC :: UnscaledLobattoMonomialExpansionAll -PUBLIC :: UnscaledLobattoMonomialExpansion -PUBLIC :: UnscaledLobattoGradientEvalAll -PUBLIC :: UnscaledLobattoGradientEval -PUBLIC :: UnscaledLobattoMassMatrix -PUBLIC :: UnscaledLobattoStiffnessMatrix - -!---------------------------------------------------------------------------- -! UnscaledLobattoLeadingCoeff -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Leading coefficient of UnscaledLobatto polynomial - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoLeadingCoeff(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of UnscaledLobatto polynomial - REAL(DFP) :: ans - !! answer - END FUNCTION UnscaledLobattoLeadingCoeff -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Square norm of UnscaledLobatto polynomial -! - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoNormSQR(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans - END FUNCTION UnscaledLobattoNormSQR -END INTERFACE - -!---------------------------------------------------------------------------- -! UnscaledLobattoZeros -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Returns zeros of UnscaledLobatto polynomials - -INTERFACE - MODULE FUNCTION UnscaledLobattoZeros(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of UnscaledLobatto polynomial, should be greater than equal to 2 - REAL(DFP) :: ans(n) - !! - END FUNCTION UnscaledLobattoZeros -END INTERFACE - -!---------------------------------------------------------------------------- -! UnscaledLobattoEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at several points -! -!# Introduction -! -! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto -! polynomials at the point X. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoEval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - !! Evaluate UnscaledLobatto polynomial of order n at point x - END FUNCTION UnscaledLobattoEval1 -END INTERFACE - -INTERFACE UnscaledLobattoEval - MODULE PROCEDURE UnscaledLobattoEval1 -END INTERFACE UnscaledLobattoEval - -!---------------------------------------------------------------------------- -! UnscaledLobattoEval -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at -! several points -! -!# Introduction -! -! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at -! the point X. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoEval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate UnscaledLobatto polynomial of order n at point x - END FUNCTION UnscaledLobattoEval2 -END INTERFACE - -INTERFACE UnscaledLobattoEval - MODULE PROCEDURE UnscaledLobattoEval2 -END INTERFACE UnscaledLobattoEval - -!---------------------------------------------------------------------------- -! UnscaledLobattoEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at -! several points -! -!# Introduction -! -! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at -! the point X. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(n + 1) - !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION UnscaledLobattoEvalAll1 -END INTERFACE - -INTERFACE UnscaledLobattoEvalAll - MODULE PROCEDURE UnscaledLobattoEvalAll1 -END INTERFACE UnscaledLobattoEvalAll - -!---------------------------------------------------------------------------- -! UnscaledLobattoEvalAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 Sept 2022 -! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at -! several points -! -!# Introduction -! -! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points -! -!- N, the highest order polynomial to compute. Note that polynomials 0 -! through N will be computed. -!- alpha, beta are parameters -!- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at -! the point X. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoEvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION UnscaledLobattoEvalAll2 -END INTERFACE - -INTERFACE UnscaledLobattoEvalAll - MODULE PROCEDURE UnscaledLobattoEvalAll2 -END INTERFACE UnscaledLobattoEvalAll - -!---------------------------------------------------------------------------- -! UnscaledLobattoMonomialExpansionAll -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary:Returns the monomial expansion of all UnscaledLobatto polynomials -! -!# Introduction -! -! Returns all the monomial expansion of all UnscaledLobatto polynomials -! -!- n : is the order of the polynomial -!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 -! -! for example, n=5, we have following structure of ans -! -! | P0 | P1 | P2 | P3 | P4 | P5 | -! |----|----|------|------|-------|-------| -! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | -! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | -! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | -! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | -! | 0 | 0 | 0 | 0 | 4.375 | 0 | -! | 0 | 0 | 0 | 0 | 0 | 7.875 | - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoMonomialExpansionAll(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1, 1:n + 1) - END FUNCTION UnscaledLobattoMonomialExpansionAll -END INTERFACE - -!---------------------------------------------------------------------------- -! UnscaledLobattoMonomialExpansion -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Returns the monomial expansion of a UnscaledLobatto polynomials -! -!# Introduction -! -! Returns all the monomial expansion of a UnscaledLobatto polynomials -! -!- n : is the order of the polynomial -!- ans(:) contains the coefficient of monomials for polynomial order=n -! - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoMonomialExpansion(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(1:n + 1) - END FUNCTION UnscaledLobattoMonomialExpansion -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of UnscaledLobatto polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(1:n + 1) - END FUNCTION UnscaledLobattoGradientEvalAll1 -END INTERFACE -!! - -INTERFACE UnscaledLobattoGradientEvalAll - MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 -END INTERFACE UnscaledLobattoGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of UnscaledLobatto polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) - END FUNCTION UnscaledLobattoGradientEvalAll2 -END INTERFACE -!! - -INTERFACE UnscaledLobattoGradientEvalAll - MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 -END INTERFACE UnscaledLobattoGradientEvalAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of UnscaledLobatto polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoGradientEval1(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION UnscaledLobattoGradientEval1 -END INTERFACE -!! - -INTERFACE UnscaledLobattoGradientEval - MODULE PROCEDURE UnscaledLobattoGradientEval1 -END INTERFACE UnscaledLobattoGradientEval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n -! -!# Introduction -! -! Evaluate gradient of UnscaledLobatto polynomial of order upto n. - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoGradientEval2(n, x) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(1:SIZE(x)) - END FUNCTION UnscaledLobattoGradientEval2 -END INTERFACE - -INTERFACE UnscaledLobattoGradientEval - MODULE PROCEDURE UnscaledLobattoGradientEval2 -END INTERFACE UnscaledLobattoGradientEval - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: UnscaledLobatto mass matrix - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoMassMatrix(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(n + 1, n + 1) - END FUNCTION UnscaledLobattoMassMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 Sept 2022 -! summary: UnscaledLobatto mass matrix - -INTERFACE - MODULE PURE FUNCTION UnscaledLobattoStiffnessMatrix(n) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: ans(n + 1, n + 1) - END FUNCTION UnscaledLobattoStiffnessMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE UnscaledLobattoPolynomialUtility diff --git a/src/modules/QuadraturePoint/CMakeLists.txt b/src/modules/QuadraturePoint/CMakeLists.txt deleted file mode 100644 index 8a1514847..000000000 --- a/src/modules/QuadraturePoint/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/QuadraturePoint_Method.F90 -) \ No newline at end of file diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 deleted file mode 100755 index 8ba04ee10..000000000 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ /dev/null @@ -1,779 +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: 1 March 2021 -! summary: This module contains the methods for data type [[QuadraturePoint_]] - -MODULE QuadraturePoint_Method -USE BaseType -USE GlobalData -USE String_Class, ONLY: String -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -PUBLIC :: QuadraturePoint -PUBLIC :: QuadraturePoint_Pointer -PUBLIC :: DEALLOCATE -PUBLIC :: SIZE -PUBLIC :: GetTotalQuadraturepoints -PUBLIC :: GetQuadraturepoints -PUBLIC :: Outerprod -PUBLIC :: Display -PUBLIC :: QuadraturePoint_MdEncode -PUBLIC :: QuadraturePointIdToName -PUBLIC :: QuadraturePointNameToId -PUBLIC :: MdEncode - -!---------------------------------------------------------------------------- -! QuadratuePointNameToId@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-06 -! summary: Quadrature point name to quadrature point id - -INTERFACE - MODULE FUNCTION QuadraturePointNameToId(name) RESULT(ans) - CHARACTER(*), INTENT(IN) :: name - INTEGER(I4B) :: ans - END FUNCTION QuadraturePointNameToId -END INTERFACE - -!---------------------------------------------------------------------------- -! QuadratuePointIdToName@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-06 -! summary: Quadrature point name to quadrature point id - -INTERFACE - MODULE FUNCTION QuadraturePointIdToName(name) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: name - TYPE(String) :: ans - END FUNCTION QuadraturePointIdToName -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiates the quadrature points - -INTERFACE Initiate - MODULE PURE SUBROUTINE quad_initiate1(obj, points) - CLASS(QuadraturePoint_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: points(:, :) - !! points contains the quadrature points and weights - !! points( :, ipoint ) contains quadrature points and weights of ipoint - !! quadrature point. The last row contains the weight. The rest of the - !! rows contains the coordinates of quadrature. - END SUBROUTINE quad_initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiates the quadrature points - -INTERFACE Initiate - MODULE PURE SUBROUTINE quad_initiate2(obj, tXi, tpoints) - CLASS(QuadraturePoint_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tXi - !! Total number of xidimension - !! For line tXi=1 - !! For 2D element tXi=2 - !! For 3D element tXi=3 - INTEGER(I4B), INTENT(IN) :: tpoints - !! Total number quadrature points - END SUBROUTINE quad_initiate2 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiates the quadrature points - -INTERFACE Initiate - MODULE SUBROUTINE quad_initiate3(obj, refElem, order, quadratureType, & - & alpha, beta, lambda) - TYPE(QuadraturePoint_), INTENT(INOUT) :: obj - !! Total number of xidimension - CLASS(ReferenceElement_), INTENT(IN) :: refElem - !! Reference element - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - CHARACTER(*), 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 - END SUBROUTINE quad_initiate3 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiates the quadrature points - -INTERFACE Initiate - MODULE SUBROUTINE quad_initiate4(obj, refElem, nips, quadratureType, & - & alpha, beta, lambda) - TYPE(QuadraturePoint_), INTENT(INOUT) :: obj - !! Total number of xidimension - CLASS(ReferenceElement_), INTENT(IN) :: refElem - !! Reference element - INTEGER(I4B), INTENT(IN) :: nips(1) - !! order of integrand - CHARACTER(*), INTENT(IN) :: quadratureType - !! Total number quadrature points - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - END SUBROUTINE quad_initiate4 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine constructs the quadrature points - -INTERFACE Initiate - MODULE SUBROUTINE quad_initiate5( & - & obj, & - & refElem, & - & order, & - & quadratureType, & - & alpha, beta, lambda) - TYPE(QuadraturePoint_), INTENT(INOUT) :: obj - !! Total number of xidimension - CLASS(ReferenceElement_), INTENT(IN) :: refElem - !! Reference-element - INTEGER(I4B), INTENT(IN) :: order - !! order of integrand - INTEGER(I4B), INTENT(IN) :: quadratureType - !! Type of quadrature points - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadau - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev - !! GaussChebyshevLobatto - !! GaussChebyshevRadau - !! GaussChebyshevRadauLeft - !! GaussChebyshevRadauRight - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - END SUBROUTINE quad_initiate5 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiates the quadrature points - -INTERFACE Initiate - MODULE SUBROUTINE quad_initiate6( & - & obj, & - & refElem, & - & nips, & - & quadratureType, & - & alpha, & - & beta, & - & lambda) - TYPE(QuadraturePoint_), INTENT(INOUT) :: obj - !! Total number of xidimension - CLASS(ReferenceElement_), INTENT(IN) :: refElem - !! Reference element - INTEGER(I4B), INTENT(IN) :: nips(1) - !! order of integrand - 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 - END SUBROUTINE quad_initiate6 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiates the quadrature points - -INTERFACE Initiate - MODULE SUBROUTINE quad_initiate7( & - & obj, & - & refElem, & - & p, q, r, & - & quadratureType1, & - & quadratureType2, & - & quadratureType3, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3) - TYPE(QuadraturePoint_), INTENT(INOUT) :: obj - !! Total number of xidimension - CLASS(ReferenceElement_), INTENT(IN) :: refElem - !! 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 - 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 - END SUBROUTINE quad_initiate7 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiates the quadrature points - -INTERFACE Initiate - MODULE SUBROUTINE quad_initiate8( & - & obj, & - & refElem, & - & nipsx, & - & nipsy, & - & nipsz, & - & quadratureType1, & - & quadratureType2, & - & quadratureType3, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3) - TYPE(QuadraturePoint_), INTENT(INOUT) :: obj - !! Total number of xidimension - CLASS(ReferenceElement_), INTENT(IN) :: refElem - !! Reference element - 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 - END SUBROUTINE quad_initiate8 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! QuadraturePoint@ConstructureMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine initiate an instance of quadrature points - -INTERFACE QuadraturePoint - MODULE PURE FUNCTION quad_Constructor1(points) RESULT(obj) - TYPE(QuadraturePoint_) :: obj - REAL(DFP), INTENT(IN) :: points(:, :) - END FUNCTION quad_Constructor1 -END INTERFACE QuadraturePoint - -!---------------------------------------------------------------------------- -! QuadraturePoint_Pointer@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns a pointer to a newly created instance of quadrature points - -INTERFACE QuadraturePoint_Pointer - MODULE PURE FUNCTION quad_Constructor_1(points) RESULT(obj) - CLASS(QuadraturePoint_), POINTER :: obj - REAL(DFP), INTENT(IN) :: points(:, :) - END FUNCTION quad_Constructor_1 -END INTERFACE QuadraturePoint_Pointer - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Deallocates the data stored inside the quadrature point - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE quad_Deallocate(obj) - CLASS(QuadraturePoint_), INTENT(INOUT) :: obj - END SUBROUTINE quad_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! SIZE@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine returns the size of obj%points, - -INTERFACE SIZE - MODULE PURE FUNCTION quad_Size(obj, dims) RESULT(ans) - CLASS(QuadraturePoint_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: dims - INTEGER(I4B) :: ans - END FUNCTION quad_Size -END INTERFACE SIZE - -!---------------------------------------------------------------------------- -! getTotalQuadraturepoints@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine returns total number of quadrature points - -INTERFACE GetTotalQuadraturepoints - MODULE PURE FUNCTION quad_getTotalQuadraturepoints(obj, dims) RESULT(ans) - CLASS(QuadraturePoint_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: dims - INTEGER(I4B) :: ans - END FUNCTION quad_getTotalQuadraturepoints -END INTERFACE GetTotalQuadraturepoints - -!---------------------------------------------------------------------------- -! GetQuadraturePoint@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine returns quadrature points - -INTERFACE - MODULE PURE SUBROUTINE quad_GetQuadraturepoints1(obj, points, weights, num) - CLASS(QuadraturePoint_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: points(3) - !! [xi, eta, zeta] - REAL(DFP), INTENT(INOUT) :: weights - !! weights - INTEGER(I4B), INTENT(IN) :: num - !! quadrature number - END SUBROUTINE quad_GetQuadraturepoints1 -END INTERFACE - -INTERFACE GetQuadraturepoints - MODULE PROCEDURE quad_GetQuadraturepoints1 -END INTERFACE - -!---------------------------------------------------------------------------- -! GetQuadraturePoint@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: This routine returns total number of quadrature points - -INTERFACE - MODULE PURE SUBROUTINE quad_GetQuadraturepoints2(obj, points, weights) - CLASS(QuadraturePoint_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: points(:, :) - !! Point( :, j ) = [xi, eta, zeta] of jth quadrature point - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: weights(:) - !! Weight(j) weight of jth quadrature point - END SUBROUTINE quad_GetQuadraturepoints2 -END INTERFACE - -INTERFACE GetQuadraturepoints - MODULE PROCEDURE quad_GetQuadraturepoints2 -END INTERFACE - -!---------------------------------------------------------------------------- -! OuterProd@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2022 -! summary: Performs outerproduct of quadrature points - -INTERFACE Outerprod - MODULE PURE FUNCTION quad_Outerprod(obj1, obj2) RESULT(ans) - CLASS(QuadraturePoint_), INTENT(IN) :: obj1 - !! quadrature points in 1D - CLASS(QuadraturePoint_), INTENT(IN) :: obj2 - !! quadrature points in 1D - TYPE(QuadraturePoint_) :: ans - !! quadrature points in 2D - END FUNCTION quad_Outerprod -END INTERFACE Outerprod - -!---------------------------------------------------------------------------- -! Display@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Display the content of quadrature point - -INTERFACE Display - MODULE SUBROUTINE quad_Display(obj, msg, unitno) - CLASS(QuadraturePoint_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno - END SUBROUTINE quad_Display -END INTERFACE Display - -!---------------------------------------------------------------------------- -! MdEncode@IOMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Display the content of quadrature point - -INTERFACE MdEncode - MODULE FUNCTION QuadraturePoint_MdEncode(obj) RESULT(ans) - CLASS(QuadraturePoint_), INTENT(IN) :: obj - TYPE(String) :: ans - END FUNCTION QuadraturePoint_MdEncode -END INTERFACE MdEncode - -!---------------------------------------------------------------------------- -! GaussLegendreQuadrature@GaussLegendre -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss Legendre Quadrature points based on given order - -! INTERFACE GaussLegendreQuadrature -! MODULE FUNCTION getGaussLegendreQP1(refelem, order) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: order -! !! order of accuracy in each direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreQP1 -! END INTERFACE GaussLegendreQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreQuadrature@GaussLegendre -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss-Legendre Quadrature points - -! INTERFACE GaussLegendreQuadrature -! MODULE FUNCTION getGaussLegendreQP2(refelem, nips) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: nips(:) -! !! number of integration points -! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn -! !! IF size(nips) = 2, then in x1 direction nips(1) points and in -! !! x2 direction nips(2) points are used. -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreQP2 -! END INTERFACE GaussLegendreQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreQuadrature@GaussLegendre -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss Legendre Quadrature points based on given order - -! INTERFACE GaussLegendreQuadrature -! MODULE FUNCTION getGaussLegendreQP3(refelem, p, q, r) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: p -! !! order of accuracy in x1 direction -! INTEGER(I4B), INTENT(IN) :: q -! !! order of accuracy in x2 direction -! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r -! !! order of accuracy in x3 direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreQP3 -! END INTERFACE GaussLegendreQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreLobattoQuadrature@GaussLegendreLobatto -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss LegendreLobatto Quadrature points - -! INTERFACE GaussLegendreLobattoQuadrature -! MODULE FUNCTION getGaussLegendreLobattoQP1(refelem, order) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: order -! !! order of accuracy in each direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreLobattoQP1 -! END INTERFACE GaussLegendreLobattoQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreLobattoQuadrature@GaussLegendreLobatto -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss-LegendreLobatto Quadrature points - -! INTERFACE GaussLegendreLobattoQuadrature -! MODULE FUNCTION getGaussLegendreLobattoQP2(refelem, nips) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: nips(:) -! !! number of integration points -! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn -! !! IF size(nips) = 2, then in x1 direction nips(1) points and in -! !! x2 direction nips(2) points are used. -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreLobattoQP2 -! END INTERFACE GaussLegendreLobattoQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreLobattoQuadrature@GaussLegendreLobatto -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss LegendreLobatto Quadrature points - -! INTERFACE GaussLegendreLobattoQuadrature -! MODULE FUNCTION getGaussLegendreLobattoQP3(refelem, p, q, r) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: p -! !! order of accuracy in x1 direction -! INTEGER(I4B), INTENT(IN) :: q -! !! order of accuracy in x2 direction -! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r -! !! order of accuracy in x3 direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreLobattoQP3 -! END INTERFACE GaussLegendreLobattoQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreRadauLeftQuadrature@GaussLegendreRadauLeft -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the LegendreRadauLeft Quadrature points - -! INTERFACE GaussLegendreRadauLeftQuadrature -! MODULE FUNCTION getGaussLegendreRadauLeftQP1(refelem, order) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: order -! !! order of accuracy in each direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreRadauLeftQP1 -! END INTERFACE GaussLegendreRadauLeftQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreRadauLeftQuadrature@GaussLegendreRadauLeft -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss-LegendreRadauLeft Quadrature points - -! INTERFACE GaussLegendreRadauLeftQuadrature -! MODULE FUNCTION getGaussLegendreRadauLeftQP2(refelem, nips) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: nips(:) -! !! number of integration points -! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn -! !! IF size(nips) = 2, then in x1 direction nips(1) points and in -! !! x2 direction nips(2) points are used. -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreRadauLeftQP2 -! END INTERFACE GaussLegendreRadauLeftQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreRadauLeftQuadrature@GaussLegendreRadauLeft -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss LegendreRadauLeft Quadrature points - -! INTERFACE GaussLegendreRadauLeftQuadrature -! MODULE FUNCTION getGaussLegendreRadauLeftQP3(refelem, p, q, r) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: p -! !! order of accuracy in x1 direction -! INTEGER(I4B), INTENT(IN) :: q -! !! order of accuracy in x2 direction -! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r -! !! order of accuracy in x3 direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreRadauLeftQP3 -! END INTERFACE GaussLegendreRadauLeftQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreRadauRightQuadrature@GaussLegendreRadauRight -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the LegendreRadauRight Quadrature points - -! INTERFACE GaussLegendreRadauRightQuadrature -! MODULE FUNCTION getGaussLegendreRadauRightQP1(refelem, order) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: order -! !! order of accuracy in each direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreRadauRightQP1 -! END INTERFACE GaussLegendreRadauRightQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreRadauRightQuadrature@GaussLegendreRadauRight -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss-LegendreRadauRight Quadrature points - -! INTERFACE GaussLegendreRadauRightQuadrature -! MODULE FUNCTION getGaussLegendreRadauRightQP2(refelem, nips) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: nips(:) -! !! number of integration points -! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn -! !! IF size(nips) = 2, then in x1 direction nips(1) points and in -! !! x2 direction nips(2) points are used. -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreRadauRightQP2 -! END INTERFACE GaussLegendreRadauRightQuadrature - -!---------------------------------------------------------------------------- -! GaussLegendreRadauRightQuadrature@GaussLegendreRadauRight -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2021 -! summary: Returns the Gauss LegendreRadauRight Quadrature points - -! INTERFACE GaussLegendreRadauRightQuadrature -! MODULE FUNCTION getGaussLegendreRadauRightQP3(refelem, p, q, r) RESULT(obj) -! CLASS(ReferenceElement_), INTENT(IN) :: refelem -! INTEGER(I4B), INTENT(IN) :: p -! !! order of accuracy in x1 direction -! INTEGER(I4B), INTENT(IN) :: q -! !! order of accuracy in x2 direction -! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r -! !! order of accuracy in x3 direction -! TYPE(QuadraturePoint_) :: obj -! END FUNCTION getGaussLegendreRadauRightQP3 -! END INTERFACE GaussLegendreRadauRightQuadrature - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE QuadraturePoint_Method diff --git a/src/modules/Random/CMakeLists.txt b/src/modules/Random/CMakeLists.txt deleted file mode 100644 index 43b65ce44..000000000 --- a/src/modules/Random/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Random_Method.F90 -) \ No newline at end of file diff --git a/src/modules/Random/src/Random_Method.F90 b/src/modules/Random/src/Random_Method.F90 deleted file mode 100644 index c1bc307e0..000000000 --- a/src/modules/Random/src/Random_Method.F90 +++ /dev/null @@ -1,338 +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 Random_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE initRandom(obj) - CLASS(Random_), INTENT(INOUT) :: obj - END SUBROUTINE initRandom -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE initRandom -END INTERFACE Initiate - -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! getRandom -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION getRandom(obj, distribution) RESULT(Ans) - CLASS(Random_), INTENT(IN) :: obj - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: distribution - REAL(DFP) :: Ans - END FUNCTION getRandom -END INTERFACE - -INTERFACE RandomValue - MODULE PROCEDURE getRandom -END INTERFACE RandomValue - -PUBLIC :: RandomValue - -!---------------------------------------------------------------------------- -! SaveRandom -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE SaveRandom(obj) - CLASS(Random_), INTENT(INOUT) :: obj - END SUBROUTINE SaveRandom -END INTERFACE - -PUBLIC :: SaveRandom - -!---------------------------------------------------------------------------- -! UniformRandom -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION uniformRandom(obj, From, To) RESULT(Ans) - CLASS(Random_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: From, To - REAL(DFP) :: Ans - END FUNCTION uniformRandom -END INTERFACE - -PUBLIC :: uniformRandom - -INTERFACE RandomValue - MODULE PROCEDURE uniformRandom -END INTERFACE RandomValue - -!---------------------------------------------------------------------------- -! RandomInteger -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION getRandomInteger(obj, From, To) RESULT(Ans) - CLASS(Random_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: From, To - INTEGER(I4B) :: Ans - END FUNCTION getRandomInteger -END INTERFACE - -INTERFACE RandomValue - MODULE PROCEDURE getRandomInteger -END INTERFACE RandomValue - -!---------------------------------------------------------------------------- -! RandomValue -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION select_random_int_from_vec(obj, Val) RESULT(Ans) - CLASS(Random_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Val(:) - INTEGER(I4B) :: Ans - END FUNCTION select_random_int_from_vec -END INTERFACE - -INTERFACE - MODULE FUNCTION select_random_int_from_array(obj, Val) RESULT(Ans) - CLASS(Random_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Val(:, :) - INTEGER(I4B) :: Ans - END FUNCTION select_random_int_from_array -END INTERFACE - -INTERFACE - MODULE FUNCTION select_random_real_from_vec(obj, Val) RESULT(Ans) - CLASS(Random_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - REAL(DFP) :: Ans - END FUNCTION select_random_real_from_vec -END INTERFACE - -INTERFACE - MODULE FUNCTION select_random_real_from_array(obj, Val) RESULT(Ans) - CLASS(Random_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :) - REAL(DFP) :: Ans - END FUNCTION select_random_real_from_array -END INTERFACE - -INTERFACE RandomValue - MODULE PROCEDURE select_random_int_from_vec, select_random_int_from_array,& - & select_random_real_from_vec, select_random_real_from_array -END INTERFACE RandomValue - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: a unit pseudorandom real vector -! -!# Introduction -! -! This subroutine is taken from rvec_uniform_01 of John Burkardt -! -! An rvec is a vector of real ( kind = 8 ) values. -! -! For now, the input quantity SEED is an integer ( kind = 4 ) variable. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of entries in the vector. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. - -INTERFACE - MODULE PURE FUNCTION rvec_uniform_01(n, seed) RESULT(r) - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed - REAL(DFP) :: r(n) - END FUNCTION rvec_uniform_01 -END INTERFACE - -PUBLIC :: rvec_uniform_01 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: returns a scaled pseudorandom rvec - -INTERFACE - MODULE PURE FUNCTION rvec_uniform_ab(n, a, b, seed) RESULT(r) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: a - REAL(DFP), INTENT(IN) :: b - INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed - REAL(DFP) :: r(n) - END FUNCTION rvec_uniform_ab -END INTERFACE - -PUBLIC :: rvec_uniform_ab - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: returns a uniformly random unit vector - -INTERFACE - MODULE PURE FUNCTION rvec_uniform_unit(m, seed) RESULT(w) - INTEGER(I4B), INTENT(IN) :: m - INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed - REAL(DFP) :: w(m) - END FUNCTION rvec_uniform_unit -END INTERFACE - -PUBLIC :: rvec_uniform_unit - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary:Samples the unit normal probability distribution. -! -!# Introduction -! -! The standard normal probability distribution function (PDF) has -! mean 0 and standard deviation 1. -! -! This routine can generate a vector of values on one call. It -! has the feature that it should provide the same results -! in the same order no matter how we break up the task. -! -! The Box-Muller method is used, which is efficient, but -! generates an even number of values each time. On any call -! to this routine, an even number of new values are generated. -! Depending on the situation, one value may be left over. -! In that case, it is saved for the next call. - -! Parameters: -! -! Input, integer ( kind = 4 ) N, the number of values desired. If N is -! negative, then the code will flush its internal memory; in particular, -! if there is a saved value to be used on the next call, it is -! instead discarded. This is useful if the user has reset the -! random number seed, for instance. -! -! Input/output, integer ( kind = 4 ) SEED, a seed for the random number -! generator. -! -! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. -! -! Local parameters: -! -! Local, integer MADE, records the number of values that have -! been computed. On input with negative N, this value overwrites -! the return value of N, so the user can get an accounting of -! how much work has been done. -! -! Local, real ( kind = 8 ) R(N+1), is used to store some uniform -! random values. Its dimension is N+1, but really it is only needed -! to be the smallest even number greater than or equal to N. -! -! Local, integer SAVED, is 0 or 1 depending on whether there is a -! single saved value left over from the previous call. -! -! Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of -! X that we need to compute. This starts off as 1:N, but is adjusted -! if we have a saved value that can be immediately stored in X(1), -! and so on. -! -! Local, real ( kind = 8 ) Y, the value saved from the previous call, if -! SAVED is 1. - -INTERFACE - MODULE PURE FUNCTION rvec_normal_01(n, seed) RESULT(x) - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed - REAL(DFP) :: x(n) - END FUNCTION rvec_normal_01 -END INTERFACE - -PUBLIC :: rvec_normal_01 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: returns a unit pseudorandom -! -!# Introduction -! -! An R8 is a real ( kind = 8 ) value. -! -! For now, the input quantity SEED is an integer ( kind = 4 ) variable. -! -! This routine implements the recursion -! -! seed = 16807 * seed mod ( 2^31 - 1 ) -! r8_uniform_01 = seed / ( 2^31 - 1 ) -! -! The integer arithmetic never requires more than 32 bits, -! including a sign bit. -! -! If the initial seed is 12345, then the first three computations are -! -! Input Output R8_UNIFORM_01 -! SEED SEED -! -! 12345 207482415 0.096616 -! 207482415 1790989824 0.833995 -! 1790989824 2035175616 0.947702 -! -! Parameters: -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should -! NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate, -! strictly between 0 and 1. - -INTERFACE - MODULE PURE FUNCTION r8_uniform_01(seed) RESULT(ans) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed - REAL(DFP) :: ans - END FUNCTION r8_uniform_01 -END INTERFACE - -PUBLIC :: r8_uniform_01 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE Random_Method diff --git a/src/modules/Rank2Tensor/CMakeLists.txt b/src/modules/Rank2Tensor/CMakeLists.txt deleted file mode 100644 index f4482d3ae..000000000 --- a/src/modules/Rank2Tensor/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Rank2Tensor_Method.F90 -) \ No newline at end of file diff --git a/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 b/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 deleted file mode 100644 index 57d03e9da..000000000 --- a/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 +++ /dev/null @@ -1,1719 +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: 10 March 2021 -! summary: This module contains method for [[Rank2Tensor_]] - -MODULE Rank2Tensor_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! initiate@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: Initiates [[Rank2Tensor_]] from another [[Rank2Tensor_]] -! -!# Introduction -! Initiates [[Rank2Tensor_]] from another [[Rank2Tensor_]] -! -!@note -! This routine also used in assignment(=) operator -!@endnote - -INTERFACE -MODULE PURE SUBROUTINE init_by_rank2( obj, obj2 ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 -END SUBROUTINE init_by_rank2 -END INTERFACE - -!---------------------------------------------------------------------------- -! initiate@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: Initiates [[Rank2Tensor_]] from a matrix -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat(3,3) -! call random_number( mat ) -! call display( mat, "mat=") -! call initiate( obj, mat ) -! call display( obj, "test1: ") -! call initiate( obj, sym(mat), .true.) -! call display( obj, "test2: ") -!``` - -INTERFACE -MODULE PURE SUBROUTINE init_by_mat( obj, Mat, isSym ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isSym -END SUBROUTINE init_by_mat -END INTERFACE - -!---------------------------------------------------------------------------- -! initiate@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: Initiates [[Rank2Tensor_]] from a [[VoigtRank2Tensor_]]. -! -!@note -! This subroutine is part of Assignment(=) operator. -!@endnote -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: v( 6 ) -! call random_number(v) -! call display( v, "v: ", orient="row" ) -! call Initiate( obj, VoigtRank2Tensor( v, VoigtType=StressTypeVoigt ) ) -! call display( obj, "obj: ") -!``` - -INTERFACE -MODULE PURE SUBROUTINE init_by_voigt( obj, V ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: V -END SUBROUTINE init_by_voigt -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: Initiates [[VoigtRank2Tensor_]] from a [[Rank2Tensor_]] - -INTERFACE -MODULE PURE SUBROUTINE init_voigt_from_r2tensor( obj, T, VoigtType ) - CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: T - INTEGER( I4B ), INTENT( IN ) :: VoigtType -END SUBROUTINE init_voigt_from_r2tensor -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE init_by_rank2, init_by_mat, init_by_voigt, & - & init_voigt_from_r2tensor -END INTERFACE Initiate - -PUBLIC :: Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE init_by_rank2 -END INTERFACE ASSIGNMENT(=) - -PUBLIC :: ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Rank2Tensor@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: This function returns an instance of [[Rank2Tensor_]] -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat(3,3) -! call random_number( mat ) -! call display( mat, "test3: mat=") -! obj = Rank2Tensor( mat ) -! call display( obj, "test3: obj=") -! obj = Rank2Tensor( sym(mat), .true.) -! call display( obj, "test3: obj=") -!``` - -INTERFACE -MODULE PURE FUNCTION r2t_by_mat( Mat, isSym ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) - TYPE( Rank2Tensor_ ) :: Ans - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isSym -END FUNCTION r2t_by_mat -END INTERFACE - -!---------------------------------------------------------------------------- -! Rank2Tensor@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: This function returns an instance of [[Rank2Tensor_]] -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: v(6) -! call random_number( v ) -! call display( v, "test4 mat=") -! obj = Rank2Tensor( VoigtRank2Tensor(v, VoigtType=StressTypeVoigt) ) -! call display( obj, "test4 obj=") -!``` - -INTERFACE -MODULE PURE FUNCTION r2t_by_voigt( V ) RESULT( Ans ) - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: V - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION r2t_by_voigt -END INTERFACE - -INTERFACE Rank2Tensor - MODULE PROCEDURE r2t_by_mat, r2t_by_voigt -END INTERFACE Rank2Tensor - -PUBLIC :: Rank2Tensor - -!---------------------------------------------------------------------------- -! Rank2Tensor_Pointer@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: returns the pointer to an newly created instance of [[Rank2Tensor_]]. -! -!### Usage -! -!```fortran -! class( Rank2Tensor_ ), pointer :: obj -! real( dfp ) :: mat(3,3) -! call random_number( mat ) -! call display( mat, "test5: mat=") -! obj => Rank2Tensor_Pointer( mat ) -! call display( obj, "test5: obj=") -! obj => Rank2Tensor_Pointer( sym(mat), .true.) -! call display( obj, "test5: obj=") -!``` - -INTERFACE -MODULE PURE FUNCTION ptr_r2t_by_mat( Mat, isSym ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) - CLASS( Rank2Tensor_ ), POINTER :: Ans - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isSym -END FUNCTION ptr_r2t_by_mat -END INTERFACE - -!---------------------------------------------------------------------------- -! Rank2Tensor@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: returns a pointer to a newly created instance of [[Rank2Tensor_]] -! -!### Usage -! -!```fortran -! class( Rank2Tensor_ ), pointer :: obj -! real( dfp ) :: v(6) -! call random_number( v ) -! call display( v, "test6: mat=") -! obj => Rank2Tensor_Pointer( VoigtRank2Tensor(v, VoigtType=StressTypeVoigt)) -! call display( obj, "test6: obj=") -!``` - -INTERFACE -MODULE PURE FUNCTION ptr_r2t_by_voigt( V ) RESULT( Ans ) - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: V - CLASS( Rank2Tensor_ ), POINTER :: Ans -END FUNCTION ptr_r2t_by_voigt -END INTERFACE - -INTERFACE Rank2Tensor_Pointer - MODULE PROCEDURE ptr_r2t_by_mat, ptr_r2t_by_voigt -END INTERFACE Rank2Tensor_Pointer - -PUBLIC :: Rank2Tensor_Pointer - -!---------------------------------------------------------------------------- -! Assignment@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: [[Rank2Tensor_]] = Matrix(3,3) -! -!@note -! This SUBROUTINE will create an unsymmetric tensor -!@endnote -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number(mat) -! obj = mat -! call display( obj, "test7: obj=") -!``` - -INTERFACE -MODULE PURE SUBROUTINE r2tensor_eq_mat( obj, Mat ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) -END SUBROUTINE r2tensor_eq_mat -END INTERFACE - -!---------------------------------------------------------------------------- -! Assignment@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: Matrix(3,3) = [[Rank2Tensor_]] -! -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number(mat) -! obj = mat -! call display( obj, "test7: obj=") -! mat = 0.0; mat = obj -! call display( mat, "test7: mat=") -!``` - -INTERFACE -MODULE PURE SUBROUTINE mat_eq_r2tensor( Mat, obj ) - REAL( DFP ), INTENT( INOUT ) :: Mat( 3, 3 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj -END SUBROUTINE mat_eq_r2tensor -END INTERFACE - -!---------------------------------------------------------------------------- -! Assignment@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: This routine returns a [[VoigtRank2Tensor_]] from [[Rank2Tensor_2]] -! -!@note -! The `VoigtType` will be `StressTypeVoigt`. -!@endnote -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! type( VoigtRank2Tensor_ ) :: v -! real( dfp ) :: mat( 3, 3 ) -! call random_number(mat) -! obj = mat -! call display( obj, "test8: obj=") -! v = obj -! call display( v, "test8: v=") -!``` - -INTERFACE -MODULE PURE SUBROUTINE voigt_eq_r2tensor( V, obj ) - CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: V - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj -END SUBROUTINE voigt_eq_r2tensor -END INTERFACE - -INTERFACE ASSIGNMENT( = ) - MODULE PROCEDURE r2tensor_eq_mat, mat_eq_r2tensor, init_by_voigt, & - & voigt_eq_r2tensor -END INTERFACE - -!---------------------------------------------------------------------------- -! IdentityTensor@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the rank2 identity tensor -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! call IdentityTensor(obj) -! call display( obj, "test9: IdentityTensor=") -! call Ones(obj) -! call display( obj, "test9: Ones=") -! call Zeros(obj) -! call display( obj, "test9: Zeros=") -! call IsotropicTensor(obj, 2.0_DFP) -! call display( obj, "test9: Isotropic=") -!``` -INTERFACE -MODULE PURE SUBROUTINE identity_rank2( obj ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj -END SUBROUTINE identity_rank2 -END INTERFACE - -INTERFACE IdentityTensor - MODULE PROCEDURE identity_rank2 -END INTERFACE IdentityTensor - -PUBLIC :: IdentityTensor - -!---------------------------------------------------------------------------- -! getOnesTensor@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns a second order tensor with all entry one - -INTERFACE -MODULE PURE SUBROUTINE rank2_getOnes( obj ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj -END SUBROUTINE rank2_getOnes -END INTERFACE - -INTERFACE getOnes - MODULE PROCEDURE rank2_getOnes -END INTERFACE getOnes - -PUBLIC :: getOnes - -!---------------------------------------------------------------------------- -! ZerosTensor@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns a zero second order tensor -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! call IdentityTensor(obj) -! call display( obj, "test9: IdentityTensor=") -! call Ones(obj) -! call display( obj, "test9: Ones=") -! call Zeros(obj) -! call display( obj, "test9: Zeros=") -! call IsotropicTensor(obj, 2.0_DFP) -! call display( obj, "test9: Isotropic=") -!``` - -INTERFACE -MODULE PURE SUBROUTINE rank2_getZeros( obj ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj -END SUBROUTINE rank2_getZeros -END INTERFACE - -INTERFACE getZeros - MODULE PROCEDURE rank2_getZeros -END INTERFACE getZeros - -PUBLIC :: getZeros - -!---------------------------------------------------------------------------- -! IsotropicTensor@constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: returns a second order isotropic tensor -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! call IdentityTensor(obj) -! call display( obj, "test9: IdentityTensor=") -! call Ones(obj) -! call display( obj, "test9: Ones=") -! call Zeros(obj) -! call display( obj, "test9: Zeros=") -! call IsotropicTensor(obj, 2.0_DFP) -! call display( obj, "test9: Isotropic=") -!``` - -INTERFACE -MODULE PURE SUBROUTINE isotropic_rank2( obj, Lambda ) - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Lambda -END SUBROUTINE isotropic_rank2 -END INTERFACE - -INTERFACE IsotropicTensor - MODULE PROCEDURE isotropic_rank2 -END INTERFACE IsotropicTensor - -PUBLIC :: IsotropicTensor - -!---------------------------------------------------------------------------- -! isSym@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Returns true if symmetric - -INTERFACE -MODULE PURE FUNCTION isSym_rank2( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - LOGICAL( LGT ) :: Ans -END FUNCTION isSym_rank2 -END INTERFACE - -INTERFACE isSym - MODULE PROCEDURE isSym_rank2 -END INTERFACE isSym - -PUBLIC :: isSym - -!---------------------------------------------------------------------------- -! isDeviatoric@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Returns true of deviatoric tensor - -INTERFACE -MODULE PURE FUNCTION isDeviatoric_rank2( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - LOGICAL( LGT ) :: Ans -END FUNCTION isDeviatoric_rank2 -END INTERFACE - -INTERFACE isDeviatoric - MODULE PROCEDURE isDeviatoric_rank2 -END INTERFACE isDeviatoric - -PUBLIC :: isDeviatoric - -!---------------------------------------------------------------------------- -! DeformationGradient@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns pointer to a newly created instance of [[DeformationGradient_]] - -INTERFACE -MODULE PURE FUNCTION F_constructor1( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: obj - TYPE( DeformationGradient_ ) :: Ans -END FUNCTION F_constructor1 -END INTERFACE - -INTERFACE DeformationGradient - MODULE PROCEDURE F_constructor1 -END INTERFACE DeformationGradient - -PUBLIC :: DeformationGradient - -!---------------------------------------------------------------------------- -! DeformationGradient@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns pointer to a newly created instance of [[DeformationGradient_]] - -INTERFACE -MODULE PURE FUNCTION F_constructor_1( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: obj - CLASS( DeformationGradient_ ), POINTER :: Ans -END FUNCTION F_constructor_1 -END INTERFACE - -INTERFACE DeformationGradient_Pointer - MODULE PROCEDURE F_constructor_1 -END INTERFACE DeformationGradient_Pointer - -PUBLIC :: DeformationGradient_Pointer - -!---------------------------------------------------------------------------- -! LeftCauchyGreen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns pointer to a newly created instance of [[LeftCauchyGreen_]] - -INTERFACE -MODULE PURE FUNCTION b_constructor1( F, V ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: V - TYPE( LeftCauchyGreen_ ) :: Ans -END FUNCTION b_constructor1 -END INTERFACE - -INTERFACE LeftCauchyGreen - MODULE PROCEDURE b_constructor1 -END INTERFACE LeftCauchyGreen - -PUBLIC :: LeftCauchyGreen - -!---------------------------------------------------------------------------- -! LeftCauchyGreen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns pointer to a newly created instance of [[LeftCauchyGreen_]] - -INTERFACE -MODULE PURE FUNCTION b_constructor_1( F, V ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: V - CLASS( LeftCauchyGreen_ ), POINTER :: Ans -END FUNCTION b_constructor_1 -END INTERFACE - -INTERFACE LeftCauchyGreen_Pointer - MODULE PROCEDURE b_constructor_1 -END INTERFACE LeftCauchyGreen_Pointer - -PUBLIC :: LeftCauchyGreen_Pointer - -!---------------------------------------------------------------------------- -! RightCauchyGreen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns pointer to a newly created instance of [[RightCauchyGreen_]] - -INTERFACE -MODULE PURE FUNCTION C_constructor1( F, U ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: U - TYPE( RightCauchyGreen_ ) :: Ans -END FUNCTION C_constructor1 -END INTERFACE - -INTERFACE RightCauchyGreen - MODULE PROCEDURE C_constructor1 -END INTERFACE RightCauchyGreen - -PUBLIC :: RightCauchyGreen - -!---------------------------------------------------------------------------- -! RightCauchyGreen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns pointer to a newly created instance of [[RightCauchyGreen_]] - -INTERFACE -MODULE PURE FUNCTION C_constructor_1( F, U ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F - CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: U - CLASS( RightCauchyGreen_ ), POINTER :: Ans -END FUNCTION C_constructor_1 -END INTERFACE - -INTERFACE RightCauchyGreen_Pointer - MODULE PROCEDURE C_constructor_1 -END INTERFACE RightCauchyGreen_Pointer - -PUBLIC :: RightCauchyGreen_Pointer - -!---------------------------------------------------------------------------- -! INV@Operation -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE SUBROUTINE inv_rank2( obj, Invobj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: Invobj -END SUBROUTINE inv_rank2 -END INTERFACE - -INTERFACE INV - MODULE PROCEDURE inv_rank2 -END INTERFACE INV - -PUBLIC :: INV - -!---------------------------------------------------------------------------- -! Transpose@Operation -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Transpose of a tensor - -INTERFACE -MODULE PURE FUNCTION obj_transpose( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_transpose -END INTERFACE - -INTERFACE TRANSPOSE - MODULE PROCEDURE obj_transpose -END INTERFACE TRANSPOSE - -PUBLIC :: TRANSPOSE - -!---------------------------------------------------------------------------- -! Sym@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the symmetric part of a rank2 tensor -! -!# Introduction -! Returns the symmetric part of the tensor -! -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = mat -! obj = sym(obj) -!``` - -INTERFACE -MODULE PURE FUNCTION sym_r2t( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION sym_r2t -END INTERFACE - -INTERFACE Sym - MODULE PROCEDURE sym_r2t -END INTERFACE Sym - -PUBLIC :: Sym - -!---------------------------------------------------------------------------- -! SkewSym@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the skew symmetric part of the tensor -! -!# Introduction -! Returns the skew symmetric part of the tensor. -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = mat -! obj = SkewSym(obj) -!``` - -INTERFACE -MODULE PURE FUNCTION Skewsym_r2t( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION Skewsym_r2t -END INTERFACE - -INTERFACE SkewSym - MODULE PROCEDURE Skewsym_r2t -END INTERFACE SkewSym - -PUBLIC :: SkewSym - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Display the content of [[Rank2Tensor_]] - -INTERFACE -MODULE SUBROUTINE display_obj( obj, Msg, UnitNo ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Msg - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo -END SUBROUTINE display_obj -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE display_obj -END INTERFACE Display - -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! Trace@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns trace of a tensor -! -!# Introduction -! Trace of a tensor is given by -! $$Tr(A) = A_{ii}$$ -! Trace of $A^2$ is given by -! $$Tr(A^2) = A:A^T$$ -! Trace of A^3 is given by -! $$Tr(A^3) = A^2 : A^T$$ -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = sym(mat) -! call display( trace(obj), "test10: trace(obj)=" ) -!``` - -INTERFACE -MODULE PURE FUNCTION trace_obj( obj, Power ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: Power - REAL( DFP ) :: Ans -END FUNCTION trace_obj -END INTERFACE - -INTERFACE Trace - MODULE PROCEDURE trace_obj -END INTERFACE Trace - -PUBLIC :: Trace - -!---------------------------------------------------------------------------- -! J2@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns J2 invariant of tensor -! -!# Introduction -! $J_2$ is given by -! $$J_{2}\left( A\right) =\frac{1}{2} tr\left( dev^{2}\left( A\right) \right)$$ -! -!@note -! if `isDeviatoric` logical flag is false then the function calculates the $J_2$ using the components of the tensor $A$. -!@endnote -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = sym(mat) -! call display( J2(obj), "test10: trace(obj)=" ) -!``` - -INTERFACE -MODULE PURE FUNCTION j2_obj( obj, isDeviatoric ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric - REAL( DFP ) :: Ans -END FUNCTION j2_obj -END INTERFACE - -INTERFACE J2 - MODULE PROCEDURE j2_obj -END INTERFACE J2 - -PUBLIC :: J2 - -!---------------------------------------------------------------------------- -! J3@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns J3 invarinat of a tensor -! -!# Introduction -! $J_3$ is an invariant of a tensor, which is given by -! -! $$J_{3}\left( A\right) =Det\left( Dev\left( A\right) \right)$$ -! -!@note -! If the tensor is not a Deviatoric tensor the this function calculates the Deviatoric part of the tensor to determine $J_3$ -!@endnote -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = sym(mat) -! call display( J3(obj), "test10: trace(obj)=" ) -!``` - -INTERFACE -MODULE PURE FUNCTION j3_obj( obj, isDeviatoric ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric - REAL( DFP ) :: Ans -END FUNCTION j3_obj -END INTERFACE - -INTERFACE J3 - MODULE PROCEDURE j3_obj -END INTERFACE J3 - -PUBLIC :: J3 - -!---------------------------------------------------------------------------- -! Det@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the Determinant of a tensor -! -!# Introduction -! This function returns the Determinant of a tensor. -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = sym(mat) -! call display( Det(obj), "test10: trace(obj)=" ) -!``` - -INTERFACE -MODULE PURE FUNCTION det_obj( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ) :: Ans -END FUNCTION det_obj -END INTERFACE - -INTERFACE Det - MODULE PROCEDURE Det_obj -END INTERFACE Det - -PUBLIC :: Det - -!---------------------------------------------------------------------------- -! LodeAngle@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns lode angle -! -!# Introduction -! This function calculates the Lode angle $\theta$ from the invariants $J_2$ and $J_3$, which is given by: -! -!$$ cos3\theta =\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ -!$$ sin3\theta =-\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ -! -! As mentioned above, Lode angle can be described in two ways; Sine and Cosine. This can be specified by defining the input parameter `LodeType` which can be `SineLode` and `CosineLode` -! -!@note -! This subroutine is called by [[theta_obj]]. -!@endnote -! - -INTERFACE -MODULE PURE FUNCTION theta_obj_j2j3( LodeType, J2, J3 ) RESULT( Ans ) - INTEGER( I4B ), INTENT( IN ) :: LodeType - REAL( DFP ), INTENT( IN ) :: J2, J3 - REAL( DFP ) :: Ans -END FUNCTION theta_obj_j2j3 -END INTERFACE - -!---------------------------------------------------------------------------- -! LodeAngle@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the Lode angle -! -!# Introduction -! -! This function returns the lode angle. -! Lode angle can be described using two ways. Sin and Cosine. This can be selected by using the input parameter `LodeType` which can be `SineLode` and `CosineLode` -! -!$$ cos3\theta =\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ -!$$ sin3\theta =-\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = sym(mat) -! call display( LodeAngle(obj, LodeType=CosineLode, isDeviatoric=.FALSE.), "test10: trace(obj)=" ) -!``` - -INTERFACE -MODULE PURE FUNCTION theta_obj( obj, LodeType, isDeviatoric ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: LodeType - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric - REAL( DFP ) :: Ans -END FUNCTION theta_obj -END INTERFACE - -INTERFACE LodeAngle - MODULE PROCEDURE theta_obj, theta_obj_j2j3 -END INTERFACE LodeAngle - -PUBLIC :: LodeAngle - -!---------------------------------------------------------------------------- -! IsotropicPart@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the isotropic part of the tensor -! -!# Introduction -! This function returns the isotropic part of a tensor, which is given by -! $$Isotropic(obj) = \frac{1}{3} Trace(obj)$$ -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ) -! call random_number( mat ) -! obj = mat -! obj = Isotropic(obj) -!``` - -INTERFACE -MODULE PURE FUNCTION iso_part_obj( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION iso_part_obj -END INTERFACE - -INTERFACE Isotropic - MODULE PROCEDURE iso_part_obj -END INTERFACE Isotropic - -PUBLIC :: Isotropic - -INTERFACE Iso - MODULE PROCEDURE iso_part_obj -END INTERFACE Iso - -PUBLIC :: Iso - -!---------------------------------------------------------------------------- -! DeviatoricPart@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the Deviatoric part of the tensor -! -!# Introduction -!This function returns the Deviatoric part of the tensor, which is given by -! -! $$Dev(T) = T - Iso(T)$$ - -INTERFACE -MODULE PURE FUNCTION dev_part_obj( obj ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION dev_part_obj -END INTERFACE - -INTERFACE Deviatoric - MODULE PROCEDURE dev_part_obj -END INTERFACE Deviatoric - -PUBLIC :: Deviatoric - -INTERFACE Dev - MODULE PROCEDURE dev_part_obj -END INTERFACE Dev - -PUBLIC :: Dev - -!---------------------------------------------------------------------------- -! Invariants@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns invariant of [[Rank2Tensor_]] -! -!# Introduction -! -! This function returns the invariant of [[Rank2Tensor_]]. -! If the tensor is not a Deviatoric tensor then following invariants are returned: -! -! $$I_1 = Tr(T)$$ -! $$I_2 = \frac{1}{2}(Tr^2(T) - Tr(A^2))$$ -! $$I_3 = det(T)$$ -! -! If the tensor is a Deviatoric tensor then following invariants are returned -! $$I_1 = 0.0$$ -! $$I_2 = \frac{1}{2} Tr(A^2)$$ -! $$I_3 = det(T)$$ -! -!### Usage -! -!```fortran -! -!``` - -INTERFACE -MODULE PURE FUNCTION invariants_rank2( obj, isDeviatoric ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric - REAL( DFP ) :: Ans( 3 ) -END FUNCTION invariants_rank2 -END INTERFACE - -INTERFACE Invariants - MODULE PROCEDURE invariants_rank2 -END INTERFACE Invariants - -PUBLIC :: Invariants - -!---------------------------------------------------------------------------- -! Eigen@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the eigen vector and eigen value of the tensor. -! -!# Introduction -! This subroutine returns the eigen values and eigen vectors of a tensor. -! If the tensor is symmetric then the eigenvalues and eigenvectors are real -! and `QI` and `WI` are not required. However, if the tensor is not symmetric -! then `QI` and `WI` contain the imaginary part of the eigenvalues and -! eigenvectors. -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj -! real( dfp ) :: mat( 3, 3 ), QR( 3, 3 ), WR( 3 ), QI( 3, 3 ), WI( 3 ) -! mat = 0.0 -! mat(1,1) = 5.0 -! mat(2:3, 2) = [-6, -12] -! mat(2:3, 3) = [-12, 1] -! call initiate( obj, mat, isSym=.true.) -! call Eigen( obj, QR, WR ) -! call BlankLines(unitNo=stdout, NOL=2) -! call display( obj, 'test12: obj=') -! call display( Invariants(obj), "test12: Invariants=" ) -! call display( QR, "test12: QR=") -! call display( WR, "test12: WR=") -!``` - -INTERFACE -MODULE SUBROUTINE eigen_r2t( obj, QR, WR, QI, WI ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( INOUT ) :: QR( 3, 3 ), WR( 3 ) - REAL( DFP ), OPTIONAL, INTENT( INOUT ) :: QI( 3, 3 ), WI( 3 ) -END SUBROUTINE eigen_r2t -END INTERFACE - -INTERFACE Eigen - MODULE PROCEDURE eigen_r2t -END INTERFACE Eigen - -PUBLIC :: Eigen - -!---------------------------------------------------------------------------- -! PolarDecomp@InvarMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: This subroutine provides polar decomposition of a tensor. -! -!# Introduction -! This subroutine provides right polar decomposition of a tensor, which is -! given by -! -! $$T=RU$$ -! -!### Usage -! -!```fortran -! type( Rank2Tensor_ ) :: obj, R, U, V -! real( dfp ) :: mat( 3, 3 ) = reshape( [1.0, -0.333, 0.959, 0.495, 1.0, 0.0, 0.5, -0.247, 1.5], [3,3] ) -! call initiate( obj, mat, isSym=.false. ) -! call PolarDecomp( obj, R, U, V ) -!``` - -INTERFACE -MODULE SUBROUTINE pd_r2t( obj, R, U, V ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: R - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: U - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: V -END SUBROUTINE pd_r2t -END INTERFACE - -INTERFACE PolarDecomp - MODULE PROCEDURE pd_r2t -END INTERFACE PolarDecomp - -PUBLIC :: PolarDecomp - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the contraction of tensor - -INTERFACE -MODULE PURE FUNCTION r2_contract_r2( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1, obj2 - REAL( DFP ) :: Ans -END FUNCTION r2_contract_r2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns the contraction of a rank2 tensor and voigt rank2 tensor - -INTERFACE -MODULE PURE FUNCTION r2_contract_voigt_r2( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj2 - REAL( DFP ) :: Ans -END FUNCTION r2_contract_voigt_r2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns contraction of aa voigt rank2 tensor and rank2 tensor - -INTERFACE -MODULE PURE FUNCTION voigt_r2_contract_r2( obj1, obj2 ) RESULT( Ans ) - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - REAL( DFP ) :: Ans -END FUNCTION voigt_r2_contract_r2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 March 2021 -! summary: Returns contraction of two voigt rank tensor - -INTERFACE -MODULE PURE FUNCTION voigt_r2_contract_voigt_r2( obj1, obj2 ) RESULT( Ans ) - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj2 - REAL( DFP ) :: Ans -END FUNCTION voigt_r2_contract_voigt_r2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -INTERFACE Contraction - MODULE PROCEDURE & - & r2_contract_r2, & - & r2_contract_voigt_r2, & - & voigt_r2_contract_r2, & - & voigt_r2_contract_voigt_r2 -END INTERFACE Contraction - -PUBLIC :: Contraction - -!---------------------------------------------------------------------------- -! +@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Addition of two tensor -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a+b, "test14: a+b=") - ! call display( a+1.0_DFP, "test14: a+1=") - ! call display( 1.0_DFP + a, "test14: 1+a=") -!``` - -INTERFACE -MODULE PURE FUNCTION obj_add_obj( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_add_obj -END INTERFACE - -!---------------------------------------------------------------------------- -! +@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Addition of tensor and scalar -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a+b, "test14: a+b=") - ! call display( a+1.0_DFP, "test14: a+1=") - ! call display( 1.0_DFP + a, "test14: 1+a=") -!``` - -INTERFACE -MODULE PURE FUNCTION obj_add_scalar( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - REAL( DFP ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_add_scalar -END INTERFACE - -!---------------------------------------------------------------------------- -! +@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Addition of tensor and scalar -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a+b, "test14: a+b=") - ! call display( a+1.0_DFP, "test14: a+1=") - ! call display( 1.0_DFP + a, "test14: 1+a=") -!``` - -INTERFACE -MODULE PURE FUNCTION scalar_add_obj( obj1, obj2 ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION scalar_add_obj -END INTERFACE - -INTERFACE OPERATOR( + ) - MODULE PROCEDURE obj_add_obj, obj_add_scalar, scalar_add_obj -END INTERFACE - -PUBLIC :: OPERATOR( + ) - -!---------------------------------------------------------------------------- -! -@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Subtraction of tensor and tensor -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a-b, "test14: a+b=") - ! call display( a-1.0_DFP, "test14: a+1=") - ! call display( 1.0_DFP - a, "test14: 1+a=") -!``` - -INTERFACE -MODULE PURE FUNCTION obj_minus_obj( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_minus_obj -END INTERFACE - -!---------------------------------------------------------------------------- -! -@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Subtraction of tensor and scalar -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a-b, "test14: a-b=") - ! call display( a-1.0_DFP, "test14: a-1=") - ! call display( 1.0_DFP - a, "test14: 1-a=") -!``` - -INTERFACE -MODULE PURE FUNCTION obj_minus_scalar( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - REAL( DFP ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_minus_scalar -END INTERFACE - -!---------------------------------------------------------------------------- -! -@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Subtraction of tensor and scalar -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a-b, "test14: a-b=") - ! call display( a-1.0_DFP, "test14: a-1=") - ! call display( 1.0_DFP - a, "test14: 1-a=") -!``` - -INTERFACE -MODULE PURE FUNCTION scalar_minus_obj( obj1, obj2 ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION scalar_minus_obj -END INTERFACE - -INTERFACE OPERATOR( - ) - MODULE PROCEDURE obj_minus_obj, & - & obj_minus_scalar, scalar_minus_obj -END INTERFACE - -PUBLIC :: OPERATOR( - ) - -!---------------------------------------------------------------------------- -! *@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: rank2 tensor times rank 2 tensor -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a*b, "test14: a*b=") - ! call display( a*1.0_DFP, "test14: a*1=") - ! call display( 1.0_DFP * a, "test14: 1*a=") -!``` - -INTERFACE -MODULE PURE FUNCTION obj_times_obj( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_times_obj -END INTERFACE - -!---------------------------------------------------------------------------- -! *@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: rank2 tensor times scalar -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a*b, "test14: a*b=") - ! call display( a*1.0_DFP, "test14: a*1=") - ! call display( 1.0_DFP * a, "test14: 1*a=") -!``` - -INTERFACE -MODULE PURE FUNCTION obj_times_scalar( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - REAL( DFP ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_times_scalar -END INTERFACE - -!---------------------------------------------------------------------------- -! *@Operator -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: rank2 tensor times scalar -! -!### Usage -! -!```fortran - ! type( Rank2Tensor_ ) :: a, b - ! real( dfp ) :: mat( 3, 3 ) - ! call random_number( mat ) - ! a = mat - ! call random_number( mat ) - ! b = mat - ! call display( a*b, "test14: a*b=") - ! call display( a*1.0_DFP, "test14: a*1=") - ! call display( 1.0_DFP * a, "test14: 1*a=") -!``` - -INTERFACE -MODULE PURE FUNCTION scalar_times_obj( obj1, obj2 ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION scalar_times_obj -END INTERFACE - -INTERFACE OPERATOR( * ) - MODULE PROCEDURE obj_times_obj, obj_times_scalar, scalar_times_obj -END INTERFACE OPERATOR( * ) - -PUBLIC :: OPERATOR( * ) - -!---------------------------------------------------------------------------- -! /@Operator -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION obj_div_obj( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_div_obj -END INTERFACE - -!---------------------------------------------------------------------------- -! /@Operator -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION obj_div_scalar( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - REAL( DFP ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_div_scalar -END INTERFACE - -!---------------------------------------------------------------------------- -! /@Operator -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION scalar_div_obj( obj1, obj2 ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION scalar_div_obj -END INTERFACE - -INTERFACE OPERATOR( / ) - MODULE PROCEDURE obj_div_obj, obj_div_scalar, scalar_div_obj -END INTERFACE OPERATOR( / ) - -PUBLIC :: OPERATOR( / ) - -!---------------------------------------------------------------------------- -! MATMUL@Operator -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION obj_matmul_obj( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION obj_matmul_obj -END INTERFACE - -!---------------------------------------------------------------------------- -! MATMUL@Operator -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION obj_matmul_vec( obj1, obj2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 - REAL( DFP ), INTENT( IN ) :: obj2( 3 ) - REAL( DFP ) :: Ans( 3 ) -END FUNCTION obj_matmul_vec -END INTERFACE - -!---------------------------------------------------------------------------- -! MATMUL@Operator -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION vec_matmul_obj( obj1, obj2 ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: obj1( 3 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 - REAL( DFP ) :: Ans( 3 ) -END FUNCTION vec_matmul_obj -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE obj_matmul_obj, obj_matmul_vec, vec_matmul_obj -END INTERFACE MATMUL - -PUBLIC :: MATMUL - -!---------------------------------------------------------------------------- -! Pullback@Pullback -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION pullback_rank2( T, F, indx1, indx2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: T - CLASS( Rank2Tensor_ ), INTENT( IN ) :: F - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION pullback_rank2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Pullback@Pullback -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION pullback_vec( Vec, F, indx1 ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: Vec( 3 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: F - CHARACTER( LEN = * ), INTENT( IN ) :: indx1 - REAL( DFP ) :: Ans( 3 ) -END FUNCTION pullback_vec -END INTERFACE - -INTERFACE PULLBACK - MODULE PROCEDURE pullback_rank2, pullback_vec -END INTERFACE PULLBACK - -PUBLIC :: PULLBACK - -!---------------------------------------------------------------------------- -! PushForward@Pushforward -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION pushforward_rank2( T, F, indx1, indx2 ) RESULT( Ans ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: T - CLASS( Rank2Tensor_ ), INTENT( IN ) :: F - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - TYPE( Rank2Tensor_ ) :: Ans -END FUNCTION pushforward_rank2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Pushforward@Pushforward -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION pushforward_vec( Vec, F, indx1 ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: Vec( 3 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: F - CHARACTER( LEN = * ), INTENT( IN ) :: indx1 - REAL( DFP ) :: Ans( 3 ) -END FUNCTION pushforward_vec -END INTERFACE - -INTERFACE PushForward - MODULE PROCEDURE pushforward_rank2, pushforward_vec -END INTERFACE PushForward - -PUBLIC :: PushForward - -!---------------------------------------------------------------------------- -! D -!---------------------------------------------------------------------------- -END MODULE Rank2Tensor_Method diff --git a/src/modules/RaylibInterface/CMakeLists.txt b/src/modules/RaylibInterface/CMakeLists.txt deleted file mode 100644 index 8eac1981e..000000000 --- a/src/modules/RaylibInterface/CMakeLists.txt +++ /dev/null @@ -1,38 +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 -# - -if(USE_RAYLIB) - set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/RaylibTypes.F90 - ${src_path}/RaylibEnums.F90 - ${src_path}/RaylibDrawMethods.F90 - ${src_path}/RaylibGetMethods.F90 - ${src_path}/RaylibSetMethods.F90 - ${src_path}/RaylibImageMethods.F90 - ${src_path}/RaylibUnloadMethods.F90 - ${src_path}/RaylibLoadMethods.F90 - ${src_path}/RaylibIsMethods.F90 - ${src_path}/RaylibCheckMethods.F90 - ${src_path}/RaylibGenMethods.F90 - ${src_path}/RaylibMethods.F90 - ${src_path}/Raylib.F90 - ${src_path}/RaylibCamera.F90 - ${src_path}/RaylibMath.F90 - ${src_path}/RaylibUtil.F90) -endif() diff --git a/src/modules/RaylibInterface/src/Raylib.F90 b/src/modules/RaylibInterface/src/Raylib.F90 deleted file mode 100644 index d0af8a22a..000000000 --- a/src/modules/RaylibInterface/src/Raylib.F90 +++ /dev/null @@ -1,22 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE Raylib -USE RaylibTypes -USE RaylibEnums -USE RaylibDrawMethods -USE RaylibGetMethods -USE RaylibSetMethods -USE RaylibImageMethods -USE RaylibUnloadMethods -USE RaylibLoadMethods -USE RaylibGenMethods -USE RaylibIsMethods -USE RaylibCheckMethods -USE RaylibMethods -END MODULE Raylib diff --git a/src/modules/RaylibInterface/src/RaylibCamera.F90 b/src/modules/RaylibInterface/src/RaylibCamera.F90 deleted file mode 100644 index c2dc752aa..000000000 --- a/src/modules/RaylibInterface/src/RaylibCamera.F90 +++ /dev/null @@ -1,130 +0,0 @@ -! raylib_camera.f90 -! -! Additional camera routines for raylib 4.5, from `rcamera.h`. -! -! Author: Philipp Engel -! Licence: ISC -MODULE raylib_camera -USE, INTRINSIC :: ISO_C_BINDING -USE :: raylib -IMPLICIT NONE(TYPE, EXTERNAL) -PRIVATE - -PUBLIC :: camera_move_forward -PUBLIC :: camera_move_right -PUBLIC :: camera_move_to_target -PUBLIC :: camera_move_up -PUBLIC :: camera_pitch -PUBLIC :: camera_roll -PUBLIC :: camera_yaw -PUBLIC :: get_camera_forward -PUBLIC :: get_camera_projection_matrix -PUBLIC :: get_camera_right -PUBLIC :: get_camera_up -PUBLIC :: get_camera_view_matrix - -INTERFACE - ! void CameraMoveForward(Camera *camera, float distance, bool moveInWorldPlane) - subroutine camera_move_forward(camera, distance, move_in_world_plane) bind(c, name='CameraMoveForward') - IMPORT :: C_BOOL, C_FLOAT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: distance - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: move_in_world_plane - END SUBROUTINE camera_move_forward - - ! void CameraMoveRight(Camera *camera, float distance, bool moveInWorldPlane) - subroutine camera_move_right(camera, distance, move_in_world_plane) bind(c, name='CameraMoveRight') - IMPORT :: C_BOOL, C_FLOAT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: distance - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: move_in_world_plane - END SUBROUTINE camera_move_right - - ! void CameraMoveToTarget(Camera *camera, float delta) - subroutine camera_move_to_target(camera, delta) bind(c, name='CameraMoveToTarget') - IMPORT :: C_FLOAT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: delta - END SUBROUTINE camera_move_to_target - - ! void CameraMoveUp(Camera *camera, float distance) - SUBROUTINE camera_move_up(camera, distance) BIND(c, name='CameraMoveUp') - IMPORT :: C_FLOAT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: distance - END SUBROUTINE camera_move_up - - ! void CameraPitch(Camera *camera, float angle, bool lockView, bool rotateAroundTarget, bool rotateUp) - subroutine camera_pitch(camera, angle, lock_view, rotate_around_target, rotate_up) bind(c, name='CameraPitch') - IMPORT :: C_BOOL, C_FLOAT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: lock_view - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: rotate_around_target - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: rotate_up - END SUBROUTINE camera_pitch - - ! void CameraRoll(Camera *camera, float angle) - SUBROUTINE camera_roll(camera, angle) BIND(c, name='CameraRoll') - IMPORT :: C_FLOAT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - END SUBROUTINE camera_roll - - ! void CameraYaw(Camera *camera, float angle, bool rotateAroundTarget) - subroutine camera_yaw(camera, angle, rotate_around_target) bind(c, name='CameraYaw') - IMPORT :: C_BOOL, C_FLOAT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: rotate_around_target - END SUBROUTINE camera_yaw - - ! Vector3 GetCameraForward(Camera *camera) - FUNCTION get_camera_forward(camera) BIND(c, name='GetCameraForward') - IMPORT :: camera3d_, vector3_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - TYPE(vector3_) :: get_camera_forward - END FUNCTION get_camera_forward - - ! Matrix GetCameraProjectionMatrix(Camera* camera, float aspect) - function get_camera_projection_matrix(camera, aspect) bind(c, name='GetCameraProjectionMatrix') - IMPORT :: C_FLOAT, camera3d_, matrix_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - REAL(kind=C_FLOAT), INTENT(in), VALUE :: aspect - TYPE(matrix_) :: get_camera_projection_matrix - END FUNCTION get_camera_projection_matrix - - ! Vector3 GetCameraRight(Camera *camera) - FUNCTION get_camera_right(camera) BIND(c, name='GetCameraRight') - IMPORT :: camera3d_, vector3_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - TYPE(vector3_) :: get_camera_right - END FUNCTION get_camera_right - - ! Vector3 GetCameraUp(Camera *camera) - FUNCTION get_camera_up(camera) BIND(c, name='GetCameraUp') - IMPORT :: camera3d_, vector3_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - TYPE(vector3_) :: get_camera_up - END FUNCTION get_camera_up - - ! Matrix GetCameraViewMatrix(Camera *camera) - FUNCTION get_camera_view_matrix(camera) BIND(c, name='GetCameraViewMatrix') - IMPORT :: camera3d_, matrix_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - TYPE(matrix_) :: get_camera_view_matrix - END FUNCTION get_camera_view_matrix -END INTERFACE -END MODULE raylib_camera diff --git a/src/modules/RaylibInterface/src/RaylibCheckMethods.F90 b/src/modules/RaylibInterface/src/RaylibCheckMethods.F90 deleted file mode 100644 index fc3708a4c..000000000 --- a/src/modules/RaylibInterface/src/RaylibCheckMethods.F90 +++ /dev/null @@ -1,157 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibCheckMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: CheckCollisionSpheres -PUBLIC :: CheckCollisionRecs -PUBLIC :: CheckCollisionPointTriangle -PUBLIC :: CheckCollisionPointRec -PUBLIC :: CheckCollisionPointPoly -PUBLIC :: CheckCollisionPointLine -PUBLIC :: CheckCollisionPointCircle -PUBLIC :: CheckCollisionLines -PUBLIC :: CheckCollisionCircles -PUBLIC :: CheckCollisionCircleRec -PUBLIC :: CheckCollisionBoxes -PUBLIC :: CheckCollisionBoxSphere - -INTERFACE - ! bool CheckCollisionBoxSphere(BoundingBox box, Vector3 center, float radius) - FUNCTION CheckCollisionBoxSphere(box, center, radius) BIND(c, & - name='CheckCollisionBoxSphere') - IMPORT :: bounding_box_, C_BOOL, C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(bounding_box_), INTENT(in), VALUE :: box - TYPE(vector3_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - LOGICAL(kind=C_BOOL) :: CheckCollisionBoxSphere - END FUNCTION CheckCollisionBoxSphere - - ! bool CheckCollisionBoxes(BoundingBox box1, BoundingBox box2) - FUNCTION CheckCollisionBoxes(box1, box2) BIND(c, name='CheckCollisionBoxes') - IMPORT :: bounding_box_, C_BOOL - IMPLICIT NONE - TYPE(bounding_box_), INTENT(in), VALUE :: box1 - TYPE(bounding_box_), INTENT(in), VALUE :: box2 - LOGICAL(kind=C_BOOL) :: CheckCollisionBoxes - END FUNCTION CheckCollisionBoxes - - ! bool CheckCollisionCircleRec(Vector2 center, float radius, Rectangle rec) - FUNCTION CheckCollisionCircleRec(center, radius, rec) BIND(c, & - name='CheckCollisionCircleRec') - IMPORT :: C_BOOL, C_FLOAT, rectangle_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(rectangle_), INTENT(in), VALUE :: rec - LOGICAL(kind=C_BOOL) :: CheckCollisionCircleRec - END FUNCTION CheckCollisionCircleRec - - ! bool CheckCollisionCircles(Vector2 center1, float radius1, Vector2 center2, float radius2) - function CheckCollisionCircles(center1, radius1, center2, radius2) bind(c, name='CheckCollisionCircles') - IMPORT :: C_BOOL, C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center1 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius1 - TYPE(vector2_), INTENT(in), VALUE :: center2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius2 - LOGICAL(kind=C_BOOL) :: CheckCollisionCircles - END FUNCTION CheckCollisionCircles - - ! bool CheckCollisionLines(Vector2 startPos1, Vector2 endPos1, Vector2 startPos2, Vector2 endPos2, Vector2 *collisionPoint) - function CheckCollisionLines(start_pos1, end_pos1, start_pos2, end_pos2, collision_point) & - BIND(c, name='CheckCollisionLines') - IMPORT :: C_BOOL, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: start_pos1 - TYPE(vector2_), INTENT(in), VALUE :: end_pos1 - TYPE(vector2_), INTENT(in), VALUE :: start_pos2 - TYPE(vector2_), INTENT(in), VALUE :: end_pos2 - TYPE(vector2_), INTENT(out) :: collision_point - LOGICAL(kind=C_BOOL) :: CheckCollisionLines - END FUNCTION CheckCollisionLines - - ! bool CheckCollisionPointCircle(Vector2 point, Vector2 center, float radius) - function CheckCollisionPointCircle(point, center, radius) bind(c, name='CheckCollisionPointCircle') - IMPORT :: C_BOOL, C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: point - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - LOGICAL(kind=C_BOOL) :: CheckCollisionPointCircle - END FUNCTION CheckCollisionPointCircle - - ! bool CheckCollisionPointLine(Vector2 point, Vector2 p1, Vector2 p2, int threshold) - function CheckCollisionPointLine(point, p1, p2, threshold) bind(c, name='CheckCollisionPointLine') - IMPORT :: C_BOOL, C_INT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: point - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: p2 - INTEGER(kind=C_INT), INTENT(in), VALUE :: threshold - LOGICAL(kind=C_BOOL) :: CheckCollisionPointLine - END FUNCTION CheckCollisionPointLine - - ! bool CheckCollisionPointPoly(Vector2 point, Vector2 *points, int pointCount) - function CheckCollisionPointPoly(point, points, point_count) bind(c, name='CheckCollisionPointPoly') - IMPORT :: C_BOOL, C_INT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: point - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - LOGICAL(kind=C_BOOL) :: CheckCollisionPointPoly - END FUNCTION CheckCollisionPointPoly - - ! bool CheckCollisionPointRec(Vector2 point, Rectangle rec) - function CheckCollisionPointRec(point, rec) bind(c, name='CheckCollisionPointRec') - IMPORT :: C_BOOL, rectangle_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: point - TYPE(rectangle_), INTENT(in), VALUE :: rec - LOGICAL(kind=C_BOOL) :: CheckCollisionPointRec - END FUNCTION CheckCollisionPointRec - - ! bool CheckCollisionPointTriangle(Vector2 point, Vector2 p1, Vector2 p2, Vector2 p3) - function CheckCollisionPointTriangle(point, p1, p2, p3) bind(c, name='CheckCollisionPointTriangle') - IMPORT :: C_BOOL, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: point - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: p2 - TYPE(vector2_), INTENT(in), VALUE :: p3 - LOGICAL(kind=C_BOOL) :: CheckCollisionPointTriangle - END FUNCTION CheckCollisionPointTriangle - - ! bool CheckCollisionRecs(Rectangle rec1, Rectangle rec2) - FUNCTION CheckCollisionRecs(rec1, rec2) BIND(c, name='CheckCollisionRecs') - IMPORT :: C_BOOL, rectangle_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec1 - TYPE(rectangle_), INTENT(in), VALUE :: rec2 - LOGICAL(kind=C_BOOL) :: CheckCollisionRecs - END FUNCTION CheckCollisionRecs - - ! bool CheckCollisionSpheres(Vector3 center1, float radius1, Vector3 center2, float radius2) - function CheckCollisionSpheres(center1, radius1, center2, radius2) bind(c, name='CheckCollisionSpheres') - IMPORT :: C_BOOL, C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: center1 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius1 - TYPE(vector3_), INTENT(in), VALUE :: center2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius2 - LOGICAL(kind=C_BOOL) :: CheckCollisionSpheres - END FUNCTION CheckCollisionSpheres -END INTERFACE - -END MODULE RaylibCheckMethods diff --git a/src/modules/RaylibInterface/src/RaylibDrawMethods.F90 b/src/modules/RaylibInterface/src/RaylibDrawMethods.F90 deleted file mode 100644 index 083c74579..000000000 --- a/src/modules/RaylibInterface/src/RaylibDrawMethods.F90 +++ /dev/null @@ -1,1144 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibDrawMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: DrawBillboard -PUBLIC :: DrawBillboardPro -PUBLIC :: DrawBillboardRec -PUBLIC :: DrawBoundingBox -PUBLIC :: DrawCapsule -PUBLIC :: DrawCapsuleWires -PUBLIC :: DrawCircle3D -PUBLIC :: DrawCircleGradient -PUBLIC :: DrawCircleLinesV -PUBLIC :: DrawCircleLines -PUBLIC :: DrawCircleSectorLines -PUBLIC :: DrawCircleSector -PUBLIC :: DrawCircleV -PUBLIC :: DrawCircle - -PUBLIC :: DrawCubeWiresV -PUBLIC :: DrawCubeWires -PUBLIC :: DrawCubeV -PUBLIC :: DrawCube - -PUBLIC :: DrawCylinderWiresEx -PUBLIC :: DrawCylinderWires -PUBLIC :: DrawCylinderEx -PUBLIC :: DrawCylinder - -PUBLIC :: DrawEllipseLines -PUBLIC :: DrawEllipse - -PUBLIC :: DrawLineV -PUBLIC :: DrawLineStrip -PUBLIC :: DrawLineEx -PUBLIC :: DrawLineBezier -PUBLIC :: DrawLine3D -PUBLIC :: DrawLine -PUBLIC :: DrawGrid -PUBLIC :: DrawFPS - -PUBLIC :: DrawMeshInstanced -PUBLIC :: DrawMesh - -PUBLIC :: DrawModelWiresEx -PUBLIC :: DrawModelWires -PUBLIC :: DrawModelEx -PUBLIC :: DrawModel - -PUBLIC :: draw_pixel_v -PUBLIC :: draw_pixel - -PUBLIC :: DrawTriangleStrip -PUBLIC :: DrawTriangleLines -PUBLIC :: DrawTriangleFan -PUBLIC :: DrawTriangle3D -PUBLIC :: DrawTriangle - -PUBLIC :: DrawTextureV -PUBLIC :: DrawTextureRec -PUBLIC :: DrawTexturePro -PUBLIC :: DrawTextureNPatch -PUBLIC :: DrawTextureEx -PUBLIC :: DrawTexture - -PUBLIC :: DrawTextPro -PUBLIC :: DrawTextEx -PUBLIC :: DrawTextCodepoints -PUBLIC :: DrawTextCodepoint -PUBLIC :: DrawText -PUBLIC :: DrawSplineSegmentLinear -PUBLIC :: DrawSplineSegmentCatmullRom - -PUBLIC :: DrawSplineSegmentBezierQuadratic -PUBLIC :: DrawSplineSegmentBezierCubic -PUBLIC :: DrawSplineSegmentBasis -PUBLIC :: DrawSplineLinear -PUBLIC :: DrawSplineCatmullRom -PUBLIC :: DrawSplineBezierQuadratic -PUBLIC :: DrawSplineBezierCubic -PUBLIC :: DrawSplineBasis -PUBLIC :: DrawSphereWires -PUBLIC :: DrawSphereEx -PUBLIC :: DrawSphere -PUBLIC :: DrawRingLines -PUBLIC :: DrawRing - -PUBLIC :: DrawRectangleV -PUBLIC :: DrawRectangleRoundedLines -PUBLIC :: DrawRectangleRounded -PUBLIC :: DrawRectangleRec -PUBLIC :: DrawRectanglePro -PUBLIC :: DrawRectangleLinesEx -PUBLIC :: DrawRectangleLines -PUBLIC :: DrawRectangleGradientV -PUBLIC :: DrawRectangleGradientH -PUBLIC :: DrawRectangleGradientEx -PUBLIC :: DrawRectangle -PUBLIC :: DrawRay -PUBLIC :: DrawPolyLinesEx -PUBLIC :: DrawPolyLines -PUBLIC :: DrawPoly -PUBLIC :: DrawPoint3D -PUBLIC :: DrawPlane - -PUBLIC :: DrawTriangleStrip3D - -INTERFACE - -! void DrawBillboard(Camera camera, Texture2D texture, Vector3 position, float size, Color tint) - SUBROUTINE DrawBillboard(camera, texture, position, size, tint) & - BIND(c, name='DrawBillboard') - IMPORT :: C_FLOAT, camera3d_, color_, texture2d_, vector3_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(in), VALUE :: camera - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(vector3_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: size - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawBillboard - -! void DrawBillboardPro(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector3 up, Vector2 size, Vector2 origin, float rotation, Color tint) - SUBROUTINE DrawBillboardPro(camera, texture, source, position, up & - , size, origin, rotation, tint) & - BIND(c, name='DrawBillboardPro') - IMPORT :: C_FLOAT, camera3d_, color_, rectangle_, & - texture2d_, vector2_, vector3_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(in), VALUE :: camera - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(rectangle_), INTENT(in), VALUE :: source - TYPE(vector3_), INTENT(in), VALUE :: position - TYPE(vector3_), INTENT(in), VALUE :: up - TYPE(vector2_), INTENT(in), VALUE :: size - TYPE(vector2_), INTENT(in), VALUE :: origin - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawBillboardPro - -! void DrawBillboardRec(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector2 size, Color tint) - SUBROUTINE DrawBillboardRec(camera, texture, source, position, & - size, tint) BIND(c, name='DrawBillboardRec') - IMPORT :: camera3d_, color_, rectangle_, & - texture2d_, vector2_, vector3_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(in), VALUE :: camera - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(rectangle_), INTENT(in), VALUE :: source - TYPE(vector3_), INTENT(in), VALUE :: position - TYPE(vector2_), INTENT(in), VALUE :: size - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawBillboardRec - -! void DrawBoundingBox(BoundingBox box, Color color) - SUBROUTINE DrawBoundingBox(box, color) BIND(c, name='DrawBoundingBox') - IMPORT :: bounding_box_, color_ - IMPLICIT NONE - TYPE(bounding_box_), INTENT(in), VALUE :: box - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawBoundingBox - -! void DrawCapsule(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) - SUBROUTINE DrawCapsule(start_pos, end_pos, radius, slices, rings, & - color) BIND(c, name='DrawCapsule') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: start_pos - TYPE(vector3_), INTENT(in), VALUE :: end_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - INTEGER(kind=C_INT), INTENT(in), VALUE :: rings - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCapsule - -! void DrawCapsuleWires(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) - SUBROUTINE DrawCapsuleWires(start_pos, end_pos, radius, slices, & - rings, color) BIND(c, name='DrawCapsuleWires') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: start_pos - TYPE(vector3_), INTENT(in), VALUE :: end_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - INTEGER(kind=C_INT), INTENT(in), VALUE :: rings - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCapsuleWires - -! void DrawCircle(int centerX, int centerY, float radius, Color color) - subroutine DrawCircle(center_x, center_y, radius, color) bind(c, name='DrawCircle') - IMPORT :: C_FLOAT, C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCircle - -! void DrawCircle3D(Vector3 center, float radius, Vector3 rotationAxis, float rotationAngle, Color color) - SUBROUTINE DrawCircle3D(center, radius, rotation_axis, & - rotation_angle, color) BIND(c, name='DrawCircle3D') - IMPORT :: C_FLOAT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(vector3_), INTENT(in), VALUE :: rotation_axis - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation_angle - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCircle3D - -! void DrawCircleGradient(int centerX, int centerY, float radius, Color color1, Color color2) - SUBROUTINE DrawCircleGradient(center_x, center_y, radius, color1, & - color2) BIND(c, name='DrawCircleGradient') - IMPORT :: C_FLOAT, C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color1 - TYPE(color_), INTENT(in), VALUE :: color2 - END SUBROUTINE DrawCircleGradient - -! void DrawCircleLines(int centerX, int centerY, float radius, Color color) - SUBROUTINE DrawCircleLines(center_x, center_y, radius, color) BIND & - (c, name='DrawCircleLines') - IMPORT :: C_FLOAT, C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCircleLines - -! void DrawCircleLinesV(Vector2 center, float radius, Color color) - SUBROUTINE DrawCircleLinesV(center, radius, color) BIND(c, name='DrawCircleLinesV') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCircleLinesV - -! void DrawCircleSector(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) - SUBROUTINE DrawCircleSector(center, radius, start_angle, end_angle & - , segments, color) & - BIND(c, name='DrawCircleSector') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle - REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle - INTEGER(kind=C_INT), INTENT(in), VALUE :: segments - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCircleSector - -! void DrawCircleSectorLines(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) - SUBROUTINE DrawCircleSectorLines(center, radius, start_angle, & - end_angle, segments, color) & - BIND(c, name='DrawCircleSectorLines') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle - REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle - INTEGER(kind=C_INT), INTENT(in), VALUE :: segments - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCircleSectorLines - -! void DrawCircleV(Vector2 center, float radius, Color color) - SUBROUTINE DrawCircleV(center, radius, color) BIND(c, name='DrawCircleV') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCircleV - -! void DrawCube(Vector3 position, float width, float height, float length, Color color) - SUBROUTINE DrawCube(position, width, height, length, color) BIND(c & - , name='DrawCube') - IMPORT :: C_FLOAT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: width - REAL(kind=C_FLOAT), INTENT(in), VALUE :: height - REAL(kind=C_FLOAT), INTENT(in), VALUE :: length - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCube - -! void DrawCubeV(Vector3 position, Vector3 size, Color color) - SUBROUTINE DrawCubeV(position, size, color) BIND(c, name='DrawCubeV') - IMPORT :: color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: position - TYPE(vector3_), INTENT(in), VALUE :: size - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCubeV - -! void DrawCubeWires(Vector3 position, float width, float height, float length, Color color) - SUBROUTINE DrawCubeWires(position, width, height, length, color) & - BIND(c, name='DrawCubeWires') - IMPORT :: C_FLOAT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: width - REAL(kind=C_FLOAT), INTENT(in), VALUE :: height - REAL(kind=C_FLOAT), INTENT(in), VALUE :: length - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCubeWires - -! void DrawCubeWiresV(Vector3 position, Vector3 size, Color color) - SUBROUTINE DrawCubeWiresV(position, size, color) BIND(c, name='DrawCubeWiresV') - IMPORT :: color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: position - TYPE(vector3_), INTENT(in), VALUE :: size - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCubeWiresV - -! void DrawCylinder(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) - SUBROUTINE DrawCylinder(position, radius_top, radius_bottom, height & - , slices, color) BIND(c, name='DrawCylinder') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_top - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_bottom - REAL(kind=C_FLOAT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCylinder - -! void DrawCylinderEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) - SUBROUTINE DrawCylinderEx(start_pos, end_pos, start_radius, & - end_radius, sides, color) BIND(c, name='DrawCylinderEx') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: start_pos - TYPE(vector3_), INTENT(in), VALUE :: end_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCylinderEx - -! void DrawCylinderWires(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) - SUBROUTINE DrawCylinderWires(position, radius_top, radius_bottom, & - height, slices, color) & - BIND(c, name='DrawCylinderWires') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_top - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_bottom - REAL(kind=C_FLOAT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCylinderWires - -! void DrawCylinderWiresEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) - SUBROUTINE DrawCylinderWiresEx(start_pos, end_pos, start_radius, & - end_radius, sides, color) & - BIND(c, name='DrawCylinderWiresEx') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: start_pos - TYPE(vector3_), INTENT(in), VALUE :: end_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawCylinderWiresEx - -! void DrawEllipse(int centerX, int centerY, float radiusH, float radiusV, Color color) - SUBROUTINE DrawEllipse(center_x, center_y, radius_h, radius_v, & - color) BIND(c, name='DrawEllipse') - IMPORT :: C_FLOAT, C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_h - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_v - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawEllipse - -! void DrawEllipseLines(int centerX, int centerY, float radiusH, float radiusV, Color color) - SUBROUTINE DrawEllipseLines(center_x, center_y, radius_h, radius_v & - , color) BIND(c, name='DrawEllipseLines') - IMPORT :: C_FLOAT, C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_h - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_v - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawEllipseLines - -! void DrawFPS(int posX, int posY) - SUBROUTINE DrawFPS(pos_x, pos_y) BIND(c, name='DrawFPS') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - END SUBROUTINE DrawFPS - -! void DrawGrid(int slices, float spacing) - SUBROUTINE DrawGrid(slices, spacing) BIND(c, name='DrawGrid') - IMPORT :: C_FLOAT, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing - END SUBROUTINE DrawGrid - -! void DrawLine(int startPosX, int startPosY, int endPosX, int endPosY, Color color) - SUBROUTINE DrawLine(start_pos_x, start_pos_y, end_pos_x, end_pos_y & - , color) BIND(c, name='DrawLine') - IMPORT :: C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_y - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawLine - -! void DrawLine3D(Vector3 startPos, Vector3 endPos, Color color) - SUBROUTINE DrawLine3D(start_pos, end_pos, color) BIND(c, name='DrawLine3D') - IMPORT :: color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: start_pos - TYPE(vector3_), INTENT(in), VALUE :: end_pos - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawLine3D - -! void DrawLineBezier(Vector2 startPos, Vector2 endPos, float thick, Color color) - SUBROUTINE DrawLineBezier(start_pos, end_pos, thick, color) BIND(c & - , name='DrawLineBezier') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: start_pos - TYPE(vector2_), INTENT(in), VALUE :: end_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawLineBezier - -! void DrawLineEx(Vector2 startPos, Vector2 endPos, float thick, Color color) - SUBROUTINE DrawLineEx(start_pos, end_pos, thick, color) BIND(c, & - name='DrawLineEx') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: start_pos - TYPE(vector2_), INTENT(in), VALUE :: end_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawLineEx - -! void DrawLineStrip(Vector2 *points, int pointCount, Color color) - SUBROUTINE DrawLineStrip(points, point_count, color) BIND(c, name='DrawLineStrip') - IMPORT :: C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawLineStrip - -! void DrawLineV(Vector2 startPos, Vector2 endPos, Color color) - SUBROUTINE DrawLineV(start_pos, end_pos, color) BIND(c, name='DrawLineV') - IMPORT :: color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: start_pos - TYPE(vector2_), INTENT(in), VALUE :: end_pos - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawLineV - -! void DrawMesh(Mesh mesh, Material material, Matrix transform) - SUBROUTINE DrawMesh(mesh, material, transform) BIND(c, name='DrawMesh') - IMPORT :: material_, matrix_, mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in), VALUE :: mesh - TYPE(material_), INTENT(in), VALUE :: material - TYPE(matrix_), INTENT(in), VALUE :: transform - END SUBROUTINE DrawMesh - -! void DrawMeshInstanced(Mesh mesh, Material material, const Matrix *transforms, int instances) - SUBROUTINE DrawMeshInstanced(mesh, material, transforms, instances & - ) BIND(c, name='DrawMeshInstanced') - IMPORT :: C_INT, material_, matrix_, mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in), VALUE :: mesh - TYPE(material_), INTENT(in), VALUE :: material - TYPE(matrix_), INTENT(inout) :: transforms - INTEGER(kind=C_INT), INTENT(in), VALUE :: instances - END SUBROUTINE DrawMeshInstanced - -! void DrawModel(Model model, Vector3 position, float scale, Color tint) - SUBROUTINE DrawModel(model, position, scale, tint) BIND(c, name='DrawModel') - IMPORT :: C_FLOAT, color_, model_, vector3_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - TYPE(vector3_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawModel - -! void DrawModelEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) - SUBROUTINE DrawModelEx(model, position, rotation_axis, & - rotation_angle, scale, tint) & - BIND(c, name='DrawModelEx') - IMPORT :: C_FLOAT, color_, model_, vector3_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - TYPE(vector3_), INTENT(in), VALUE :: position - TYPE(vector3_), INTENT(in), VALUE :: rotation_axis - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation_angle - TYPE(vector3_), INTENT(in), VALUE :: scale - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawModelEx - -! void DrawModelWires(Model model, Vector3 position, float scale, Color tint) - SUBROUTINE DrawModelWires(model, position, scale, tint) BIND(c, & - name='DrawModelWires') - IMPORT :: C_FLOAT, color_, model_, vector3_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - TYPE(vector3_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawModelWires - -! void DrawModelWiresEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) - SUBROUTINE DrawModelWiresEx(model, position, rotation_axis, & - rotation_angle, scale, tint) & - BIND(c, name='DrawModelWiresEx') - IMPORT :: C_FLOAT, color_, model_, vector3_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - TYPE(vector3_), INTENT(in), VALUE :: position - TYPE(vector3_), INTENT(in), VALUE :: rotation_axis - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation_angle - TYPE(vector3_), INTENT(in), VALUE :: scale - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawModelWiresEx - -! void DrawPixel(int posX, int posY, Color color) - SUBROUTINE draw_pixel(pos_x, pos_y, color) BIND(c, name='DrawPixel') - IMPORT :: C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE draw_pixel - -! void DrawPixelV(Vector2 position, Color color) - SUBROUTINE draw_pixel_v(position, color) BIND(c, name='DrawPixelV') - IMPORT :: color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE draw_pixel_v - -! void DrawPlane(Vector3 centerPos, Vector2 size, Color color) - SUBROUTINE DrawPlane(center_pos, size, color) BIND(c, name='DrawPlane') - IMPORT :: color_, vector2_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: center_pos - TYPE(vector2_), INTENT(in), VALUE :: size - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawPlane - -! void DrawPoint3D(Vector3 position, Color color) - SUBROUTINE DrawPoint3D(position, color) BIND(c, name='DrawPoint3D') - IMPORT :: color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: position - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawPoint3D - -! void DrawPoly(Vector2 center, int sides, float radius, float rotation, Color color) - SUBROUTINE DrawPoly(center, sides, radius, rotation, color) BIND(c & - , name='DrawPoly') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawPoly - -! void DrawPolyLines(Vector2 center, int sides, float radius, float rotation, Color color) - SUBROUTINE DrawPolyLines(center, sides, radius, rotation, color) & - BIND(c, name='DrawPolyLines') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawPolyLines - -! void DrawPolyLinesEx(Vector2 center, int sides, float radius, float rotation, float lineThick, Color color) - SUBROUTINE DrawPolyLinesEx(center, sides, radius, rotation, & - line_thick, color) & - BIND(c, name='DrawPolyLinesEx') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - REAL(kind=C_FLOAT), INTENT(in), VALUE :: line_thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawPolyLinesEx - -! void DrawRay(Ray ray, Color color) - SUBROUTINE DrawRay(ray, color) BIND(c, name='DrawRay') - IMPORT :: color_, ray_ - IMPLICIT NONE - TYPE(ray_), INTENT(in), VALUE :: ray - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRay - -! void DrawRectangle(int posX, int posY, int width, int height, Color color) - SUBROUTINE DrawRectangle(pos_x, pos_y, width, height, color) BIND(c & - , name='DrawRectangle') - IMPORT :: C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectangle - -! void DrawRectangleGradientEx(Rectangle rec, Color col1, Color col2, Color col3, Color col4) - SUBROUTINE DrawRectangleGradientEx(rec, col1, col2, col3, col4) & - BIND(c, name='DrawRectangleGradientEx') - IMPORT :: color_, rectangle_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec - TYPE(color_), INTENT(in), VALUE :: col1 - TYPE(color_), INTENT(in), VALUE :: col2 - TYPE(color_), INTENT(in), VALUE :: col3 - TYPE(color_), INTENT(in), VALUE :: col4 - END SUBROUTINE DrawRectangleGradientEx - -! void DrawRectangleGradientH(int posX, int posY, int width, int height, Color color1, Color color2) - SUBROUTINE DrawRectangleGradientH(pos_x, pos_y, width, height, & - color1, color2) & - BIND(c, name='DrawRectangleGradientH') - IMPORT :: C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(color_), INTENT(in), VALUE :: color1 - TYPE(color_), INTENT(in), VALUE :: color2 - END SUBROUTINE DrawRectangleGradientH - -! void DrawRectangleGradientV(int posX, int posY, int width, int height, Color color1, Color color2) - SUBROUTINE DrawRectangleGradientV(pos_x, pos_y, width, height, & - color1, color2) & - BIND(c, name='DrawRectangleGradientV') - IMPORT :: C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(color_), INTENT(in), VALUE :: color1 - TYPE(color_), INTENT(in), VALUE :: color2 - END SUBROUTINE DrawRectangleGradientV - -! void DrawRectangleLines(int posX, int posY, int width, int height, Color color) - SUBROUTINE DrawRectangleLines(pos_x, pos_y, width, height, color) & - BIND(c, name='DrawRectangleLines') - IMPORT :: C_INT, color_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectangleLines - -! void DrawRectangleLinesEx(Rectangle rec, float lineThick, Color color) - SUBROUTINE DrawRectangleLinesEx(rec, line_thick, color) BIND(c, & - name='DrawRectangleLinesEx') - IMPORT :: C_FLOAT, color_, rectangle_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec - REAL(kind=C_FLOAT), INTENT(in), VALUE :: line_thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectangleLinesEx - -! void DrawRectanglePro(Rectangle rec, Vector2 origin, float rotation, Color color) - SUBROUTINE DrawRectanglePro(rec, origin, rotation, color) BIND(c, & - name='DrawRectanglePro') - IMPORT :: C_FLOAT, color_, rectangle_, vector2_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec - TYPE(vector2_), INTENT(in), VALUE :: origin - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectanglePro - -! void DrawRectangleRec(Rectangle rec, Color color) - SUBROUTINE DrawRectangleRec(rec, color) BIND(c, name='DrawRectangleRec') - IMPORT :: color_, rectangle_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectangleRec - -! void DrawRectangleRounded(Rectangle rec, float roundness, int segments, Color color) - SUBROUTINE DrawRectangleRounded(rec, roundness, segments, color) & - BIND(c, name='DrawRectangleRounded') - IMPORT :: C_FLOAT, C_INT, color_, rectangle_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec - REAL(kind=C_FLOAT), INTENT(in), VALUE :: roundness - INTEGER(kind=C_INT), INTENT(in), VALUE :: segments - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectangleRounded - -! void DrawRectangleRoundedLines(Rectangle rec, float roundness, int segments, float lineThick, Color color) - SUBROUTINE DrawRectangleRoundedLines(rec, roundness, segments, & - line_thick, color) & - BIND(c, name='DrawRectangleRoundedLines') - IMPORT :: C_FLOAT, C_INT, color_, rectangle_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec - REAL(kind=C_FLOAT), INTENT(in), VALUE :: roundness - INTEGER(kind=C_INT), INTENT(in), VALUE :: segments - REAL(kind=C_FLOAT), INTENT(in), VALUE :: line_thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectangleRoundedLines - -! void DrawRectangleV(Vector2 position, Vector2 size, Color color) - SUBROUTINE DrawRectangleV(position, size, color) BIND(c, & - name='DrawRectangleV') - IMPORT :: color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(vector2_), INTENT(in), VALUE :: size - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRectangleV - -! void DrawRing(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) - SUBROUTINE DrawRing(center, inner_radius, outer_radius, start_angle & - , end_angle, segments, color) & - BIND(c, name='DrawRing') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: inner_radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: outer_radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle - REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle - INTEGER(kind=C_INT), INTENT(in), VALUE :: segments - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRing - -! void DrawRingLines(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) - SUBROUTINE DrawRingLines(center, inner_radius, outer_radius, & - start_angle, end_angle, segments, color) & - BIND(c, name='DrawRingLines') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: inner_radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: outer_radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle - REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle - INTEGER(kind=C_INT), INTENT(in), VALUE :: segments - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawRingLines - -! void DrawSphere(Vector3 centerPos, float radius, Color color) - SUBROUTINE DrawSphere(center_pos, radius, color) BIND(c, name='DrawSphere') - IMPORT :: C_FLOAT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: center_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSphere - -! void DrawSphereEx(Vector3 centerPos, float radius, int rings, int slices, Color color) - SUBROUTINE DrawSphereEx(center_pos, radius, rings, slices, color) & - BIND(c, name='DrawSphereEx') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: center_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: rings - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSphereEx - -! void DrawSphereWires(Vector3 centerPos, float radius, int rings, int slices, Color color) - SUBROUTINE DrawSphereWires(center_pos, radius, rings, slices, & - color) BIND(c, name='DrawSphereWires') - IMPORT :: C_FLOAT, C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: center_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: rings - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSphereWires - -! void DrawSplineBasis(Vector2 *points, int pointCount, float thick, Color color) - SUBROUTINE DrawSplineBasis(points, point_count, thick, color) BIND & - (c, name='DrawSplineBasis') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineBasis - -! void DrawSplineBezierCubic(Vector2 *points, int pointCount, float thick, Color color) - SUBROUTINE DrawSplineBezierCubic(points, point_count, thick, & - color) BIND(c, name='DrawSplineBezierCubic') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineBezierCubic - -! void DrawSplineBezierQuadratic(Vector2 *points, int pointCount, float thick, Color color) - SUBROUTINE DrawSplineBezierQuadratic(points, point_count, thick, & - color) BIND(c, name='DrawSplineBezierQuadratic') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineBezierQuadratic - -! void DrawSplineCatmullRom(Vector2 *points, int pointCount, float thick, Color color) - SUBROUTINE DrawSplineCatmullRom(points, point_count, thick, color & - ) BIND(c, name='DrawSplineCatmullRom') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineCatmullRom - -! void DrawSplineLinear(Vector2 *points, int pointCount, float thick, Color color) - SUBROUTINE DrawSplineLinear(points, point_count, thick, color) & - BIND(c, name='DrawSplineLinear') - IMPORT :: C_FLOAT, C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineLinear - -! void DrawSplineSegmentBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) - SUBROUTINE DrawSplineSegmentBasis(p1, p2, p3, p4, thick, color) & - BIND(c, name='DrawSplineSegmentBasis') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: p2 - TYPE(vector2_), INTENT(in), VALUE :: p3 - TYPE(vector2_), INTENT(in), VALUE :: p4 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineSegmentBasis - -! void DrawSplineSegmentBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float thick, Color color) - SUBROUTINE DrawSplineSegmentBezierCubic(p1, c2, c3, p4, thick, & - color) BIND(c, name='DrawSplineSegmentBezierCubic') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: c2 - TYPE(vector2_), INTENT(in), VALUE :: c3 - TYPE(vector2_), INTENT(in), VALUE :: p4 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineSegmentBezierCubic - -! void DrawSplineSegmentBezierQuadratic(Vector2 p1, Vector2 c2, Vector2 p3, float thick, Color color) - SUBROUTINE DrawSplineSegmentBezierQuadratic(p1, c2, p3, thick, & - color) BIND(c, name='DrawSplineSegmentBezierQuadratic') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: c2 - TYPE(vector2_), INTENT(in), VALUE :: p3 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineSegmentBezierQuadratic - -! void DrawSplineSegmentCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) - SUBROUTINE DrawSplineSegmentCatmullRom(p1, p2, p3, p4, thick, & - color) BIND(c, name='DrawSplineSegmentCatmullRom') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: p2 - TYPE(vector2_), INTENT(in), VALUE :: p3 - TYPE(vector2_), INTENT(in), VALUE :: p4 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineSegmentCatmullRom - -! void DrawSplineSegmentLinear(Vector2 p1, Vector2 p2, float thick, Color color) - SUBROUTINE DrawSplineSegmentLinear(p1, p2, thick, color) BIND(c, & - name='DrawSplineSegmentLinear') - IMPORT :: C_FLOAT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: p2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawSplineSegmentLinear - -! void DrawTriangleStrip3D(Vector3 *points, int pointCount, Color color) - SUBROUTINE DrawTriangleStrip3D(points, point_count, color) BIND(c & - , name='DrawTriangleStrip3D') - IMPORT :: C_INT, color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawTriangleStrip3D - -! void DrawText(const char *text, int posX, int posY, int fontSize, Color color) - SUBROUTINE DrawText(text, pos_x, pos_y, font_size, color) BIND(c, & - name='DrawText') - IMPORT :: C_CHAR, C_INT, color_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawText - -! void DrawTextCodepoint(Font font, int codepoint, Vector2 position, float fontSize, Color tint) - SUBROUTINE DrawTextCodepoint(font, codepoint, position, font_size & - , tint) BIND(c, name='DrawTextCodepoint') - IMPORT :: C_FLOAT, C_INT, color_, font_, vector2_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint - TYPE(vector2_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextCodepoint - -! void DrawTextCodepoints(Font font, const int *codepoints, int codepointCount, Vector2 position, float fontSize, float spacing, Color tint) - SUBROUTINE DrawTextCodepoints(font, codepoints, codepointCount, & - position, font_size, spacing, tint) & - BIND(c, name='DrawTextCodepoints') - IMPORT :: C_FLOAT, C_INT, color_, font_, vector2_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepointCount - TYPE(vector2_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size - REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextCodepoints - -! void DrawTextEx(Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) - SUBROUTINE DrawTextEx(font, text, position, font_size, spacing, & - tint) BIND(c, name='DrawTextEx') - IMPORT :: C_CHAR, C_FLOAT, color_, font_, vector2_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - CHARACTER(kind=C_CHAR), INTENT(in) :: text - TYPE(vector2_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size - REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextEx - -! void DrawTextPro(Font font, const char *text, Vector2 position, Vector2 origin, float rotation, float fontSize, float spacing, Color tint) - SUBROUTINE DrawTextPro(font, text, position, origin, rotation, & - font_size, spacing, tint) & - BIND(c, name='DrawTextPro') - IMPORT :: C_CHAR, C_FLOAT, color_, font_, vector2_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - CHARACTER(kind=C_CHAR), INTENT(in) :: text - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(vector2_), INTENT(in), VALUE :: origin - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size - REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextPro - -! void DrawTexture(Texture2D texture, int posX, int posY, Color tint) - SUBROUTINE DrawTexture(texture, pos_x, pos_y, tint) BIND(c, name='DrawTexture') - IMPORT :: C_INT, color_, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTexture - -! void DrawTextureEx(Texture2D texture, Vector2 position, float rotation, float scale, Color tint) - SUBROUTINE DrawTextureEx(texture, position, rotation, scale, tint & - ) BIND(c, name='DrawTextureEx') - IMPORT :: C_FLOAT, color_, texture2d_, vector2_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(vector2_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextureEx - -! void DrawTextureNPatch(Texture2D texture, NPatchInfo nPatchInfo, Rectangle dest, Vector2 origin, float rotation, Color tint) - SUBROUTINE DrawTextureNPatch(texture, npatch_info, dest, origin, & - rotation, tint) & - BIND(c, name='DrawTextureNPatch') - IMPORT :: C_FLOAT, color_, npatch_info_, rectangle_, texture2d_, vector2_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(npatch_info_), INTENT(in), VALUE :: npatch_info - TYPE(rectangle_), INTENT(in), VALUE :: dest - TYPE(vector2_), INTENT(in), VALUE :: origin - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextureNPatch - -! void DrawTexturePro(Texture2D texture, Rectangle source, Rectangle dest, Vector2 origin, float rotation, Color tint) - SUBROUTINE DrawTexturePro(texture, source, dest, origin, rotation & - , tint) BIND(c, name='DrawTexturePro') - IMPORT :: C_FLOAT, color_, rectangle_, texture2d_, vector2_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(rectangle_), INTENT(in), VALUE :: source - TYPE(rectangle_), INTENT(in), VALUE :: dest - TYPE(vector2_), INTENT(in), VALUE :: origin - REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTexturePro - -! void DrawTextureRec(Texture2D texture, Rectangle source, Vector2 position, Color tint) - SUBROUTINE DrawTextureRec(texture, source, position, tint) BIND(c & - , name='DrawTextureRec') - IMPORT :: color_, rectangle_, texture2d_, vector2_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(rectangle_), INTENT(in), VALUE :: source - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextureRec - -! void DrawTextureV(Texture2D texture, Vector2 position, Color tint) - SUBROUTINE DrawTextureV(texture, position, tint) BIND(c, & - name='DrawTextureV') - IMPORT :: color_, texture2d_, vector2_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE DrawTextureV - -! void DrawTriangle(Vector2 v1, Vector2 v2, Vector2 v3, Color color) - SUBROUTINE DrawTriangle(v1, v2, v3, color) BIND(c, name='DrawTriangle') - IMPORT :: color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - TYPE(vector2_), INTENT(in), VALUE :: v3 - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawTriangle - -! void DrawTriangle3D(Vector3 v1, Vector3 v2, Vector3 v3, Color color) - SUBROUTINE DrawTriangle3D(v1, v2, v3, color) BIND(c, name='DrawTriangle3D') - IMPORT :: color_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_), INTENT(in), VALUE :: v3 - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawTriangle3D - -! void DrawTriangleFan(Vector2 *points, int pointCount, Color color) - SUBROUTINE DrawTriangleFan(points, point_count, color) BIND(c, & - name='DrawTriangleFan') - IMPORT :: C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawTriangleFan - -! void DrawTriangleLines(Vector2 v1, Vector2 v2, Vector2 v3, Color color) - SUBROUTINE DrawTriangleLines(v1, v2, v3, color) BIND(c, & - name='DrawTriangleLines') - IMPORT :: color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - TYPE(vector2_), INTENT(in), VALUE :: v3 - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawTriangleLines - -! void DrawTriangleStrip(Vector2 *points, int pointCount, Color color) - SUBROUTINE DrawTriangleStrip(points, point_count, color) BIND(c, & - name='DrawTriangleStrip') - IMPORT :: C_INT, color_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in) :: points(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE DrawTriangleStrip - -END INTERFACE - -END MODULE RaylibDrawMethods diff --git a/src/modules/RaylibInterface/src/RaylibEnums.F90 b/src/modules/RaylibInterface/src/RaylibEnums.F90 deleted file mode 100644 index b3998211c..000000000 --- a/src/modules/RaylibInterface/src/RaylibEnums.F90 +++ /dev/null @@ -1,403 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC -! -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-02 -! summary: I have subdivided the big raylib module into smaller modules - -MODULE RaylibEnums -USE, INTRINSIC :: ISO_C_BINDING -IMPLICIT NONE -PRIVATE - -! ConfigFlags -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_VSYNC_HINT = INT(z'00000040') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_FULLSCREEN_MODE & - = INT(z'00000002') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_RESIZABLE & - = INT(z'00000004') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_UNDECORATED & - = INT(z'00000008') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_HIDDEN & - = INT(z'00000080') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_MINIMIZED & - = INT(z'00000200') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_MAXIMIZED & - = INT(z'00000400') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_UNFOCUSED & - = INT(z'00000800') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_TOPMOST & - = INT(z'00001000') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_ALWAYS_RUN & - = INT(z'00000100') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_TRANSPARENT & - = INT(z'00000010') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_HIGHDPI & - = INT(z'00002000') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_MOUSE_PASSTHROUGH & - = INT(z'00004000') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_BORDERLESS_WINDOWED_MODE & - = INT(z'00008000') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_MSAA_4X_HINT & - = INT(z'00000020') -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_INTERLACED_HINT & - = INT(z'00010000') - -! TraceLogLevel -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_ALL = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_TRACE = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_DEBUG = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_INFO = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_WARNING = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_ERROR = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_FATAL = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_NONE = 7 - -! KeyboardKey -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_NULL = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_APOSTROPHE = 39 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_COMMA = 44 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_MINUS = 45 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PERIOD = 46 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SLASH = 47 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ZERO = 48 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ONE = 49 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_TWO = 50 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_THREE = 51 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_FOUR = 52 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_FIVE = 53 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SIX = 54 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SEVEN = 55 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_EIGHT = 56 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_NINE = 57 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SEMICOLON = 59 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_EQUAL = 61 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_A = 65 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_B = 66 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_C = 67 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_D = 68 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_E = 69 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F = 70 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_G = 71 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_H = 72 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_I = 73 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_J = 74 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_K = 75 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_L = 76 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_M = 77 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_N = 78 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_O = 79 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_P = 80 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_Q = 81 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_R = 82 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_S = 83 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_T = 84 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_U = 85 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_V = 86 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_W = 87 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_X = 88 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_Y = 89 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_Z = 90 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_BRACKET = 91 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_BACKSLASH = 92 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_BRACKET = 93 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_GRAVE = 96 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SPACE = 32 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ESCAPE = 256 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ENTER = 257 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_TAB = 258 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_BACKSPACE = 259 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_INSERT = 260 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_DELETE = 261 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT = 262 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT = 263 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_DOWN = 264 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_UP = 265 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PAGE_UP = 266 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PAGE_DOWN = 267 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_HOME = 268 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_END = 269 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_CAPS_LOCK = 280 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SCROLL_LOCK = 281 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_NUM_LOCK = 282 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PRINT_SCREEN = 283 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PAUSE = 284 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F1 = 290 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F2 = 291 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F3 = 292 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F4 = 293 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F5 = 294 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F6 = 295 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F7 = 296 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F8 = 297 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F9 = 298 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F10 = 299 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F11 = 300 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F12 = 301 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_SHIFT = 340 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_CONTROL = 341 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_ALT = 342 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_SUPER = 343 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_SHIFT = 344 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_CONTROL = 345 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_ALT = 346 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_SUPER = 347 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KB_MENU = 348 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_0 = 320 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_1 = 321 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_2 = 322 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_3 = 323 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_4 = 324 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_5 = 325 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_6 = 326 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_7 = 327 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_8 = 328 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_9 = 329 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_DECIMAL = 330 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_DIVIDE = 331 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_MULTIPLY = 332 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_SUBTRACT = 333 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_ADD = 334 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_ENTER = 335 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_EQUAL = 336 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_BACK = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_MENU = 82 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_VOLUME_UP = 24 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_VOLUME_DOWN = 25 - -! MouseButton -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_LEFT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_RIGHT = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_MIDDLE = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_SIDE = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_EXTRA = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_FORWARD = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_BACK = 6 - -! MouseCursor -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_DEFAULT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_ARROW = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_IBEAM = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_CROSSHAIR = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_POINTING_HAND = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_EW = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_NS = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_NWSE = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_NESW = 8 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_ALL = 9 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_NOT_ALLOWED = 10 - -! GamepadButton -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_UNKNOWN = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_UP = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_RIGHT = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_DOWN = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_LEFT = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_UP = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_RIGHT = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_DOWN = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_LEFT = 8 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_TRIGGER_1 = 9 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_TRIGGER_2 = 10 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_TRIGGER_1 = 11 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_TRIGGER_2 = 12 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_MIDDLE_LEFT = 13 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_MIDDLE = 14 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_MIDDLE_RIGHT = 15 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_THUMB = 16 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_THUMB = 17 - -! GamepadAxis -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_LEFT_X = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_LEFT_Y = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_RIGHT_X = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_RIGHT_Y = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_LEFT_TRIGGER = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_RIGHT_TRIGGER = 5 - -! MaterialMapIndex -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_ALBEDO = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_METALNESS = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_NORMAL = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_ROUGHNESS = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_OCCLUSION = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_EMISSION = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_HEIGHT = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_CUBEMAP = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_IRRADIANCE = 8 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_PREFILTER = 9 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_BRDF = 10 - -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_DIFFUSE = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_SPECULAR = 1 - -! ShaderLocationIndex -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_POSITION = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_TEXCOORD01 = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_TEXCOORD02 = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_NORMAL = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_TANGENT = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_COLOR = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_MVP = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_VIEW = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_PROJECTION = 8 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_MODEL = 9 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_NORMAL = 10 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VECTOR_VIEW = 11 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_COLOR_DIFFUSE = 12 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_COLOR_SPECULAR = 13 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_COLOR_AMBIENT = 14 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_ALBEDO = 15 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_METALNESS = 16 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_NORMAL = 17 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_ROUGHNESS = 18 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_OCCLUSION = 19 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_EMISSION = 20 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_HEIGHT = 21 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_CUBEMAP = 22 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_IRRADIANCE = 23 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_PREFILTER = 24 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_BRDF = 25 - -! ShaderUniformDataType -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_FLOAT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_VEC2 = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_VEC3 = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_VEC4 = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_INT = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_IVEC2 = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_IVEC3 = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_IVEC4 = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_SAMPLER2D = 8 - -! ShaderAttributeDataType -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_FLOAT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_VEC2 = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_VEC3 = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_VEC4 = 3 - -! PixelFormat -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_GRAYSCALE & - = 1 -integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_GRAY_ALPHA & - = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R5G6B5 & - = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R8G8B8 & - = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R5G5B5A1 & - = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R4G4B4A4 & - = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R8G8B8A8 & - = 7 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R32 & - = 8 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R32G32B32 & - = 9 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & - PIXELFORMAT_UNCOMPRESSED_R32G32B32A32 = 10 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R16 & - = 11 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R16G16B16 & - = 12 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & - PIXELFORMAT_UNCOMPRESSED_R16G16B16A16 = 13 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT1_RGB & - = 14 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT1_RGBA & - = 15 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT3_RGBA & - = 16 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT5_RGBA & - = 17 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_ETC1_RGB & - = 18 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_ETC2_RGB & - = 19 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & - PIXELFORMAT_COMPRESSED_ETC2_EAC_RGBA = 20 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_PVRT_RGB & - = 21 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_PVRT_RGBA & - = 22 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & - PIXELFORMAT_COMPRESSED_ASTC_4x4_RGBA = 23 - -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & - PIXELFORMAT_COMPRESSED_ASTC_8x8_RGBA = 24 - -! TextureFilter -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_POINT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_BILINEAR = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_TRILINEAR = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_ANISOTROPIC_4X = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_ANISOTROPIC_8X = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_ANISOTROPIC_16X = 5 - -! TextureWrap -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_REPEAT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_CLAMP = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_MIRROR_REPEAT = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_MIRROR_CLAMP = 3 - -! CubemapLayout -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_AUTO_DETECT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_LINE_VERTICAL = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_LINE_HORIZONTAL = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_CROSS_THREE_BY_FOUR & - = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_CROSS_FOUR_BY_THREE & - = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_PANORAMA = 5 - -! FontType -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FONT_DEFAULT = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FONT_BITMAP = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FONT_SDF = 2 - -! BlendMode -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ALPHA = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ADDITIVE = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_MULTIPLIED = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ADD_COLORS = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_SUBTRACT_COLORS = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ALPHA_PREMULTIPLY = 5 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_CUSTOM = 6 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_CUSTOM_SEPARATE = 7 - -! Gesture -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_NONE = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_TAP = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_DOUBLETAP = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_HOLD = 4 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_DRAG = 8 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_RIGHT = 16 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_LEFT = 32 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_UP = 64 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_DOWN = 128 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_PINCH_IN = 256 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_PINCH_OUT = 512 - -! CameraMode -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_CUSTOM = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_FREE = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_ORBITAL = 2 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_FIRST_PERSON = 3 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_THIRD_PERSON = 4 - -! CameraProjection -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_PERSPECTIVE = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_ORTHOGRAPHIC = 1 - -! NPatchLayout -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: NPATCH_NINE_PATCH = 0 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: NPATCH_THREE_PATCH_VERTICAL = 1 -INTEGER(kind=C_INT), PARAMETER, PUBLIC :: NPATCH_THREE_PATCH_HORIZONTAL = 2 - -END MODULE RaylibEnums diff --git a/src/modules/RaylibInterface/src/RaylibGenMethods.F90 b/src/modules/RaylibInterface/src/RaylibGenMethods.F90 deleted file mode 100644 index 641e5952d..000000000 --- a/src/modules/RaylibInterface/src/RaylibGenMethods.F90 +++ /dev/null @@ -1,283 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibGenMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: GenImageCellular -PUBLIC :: GenImageChecked -PUBLIC :: GenImageColor -PUBLIC :: GenImageFontAtlas -PUBLIC :: GenImageGradientLinear -PUBLIC :: GenImageGradientRadial -PUBLIC :: GenImageGradientSquare -PUBLIC :: GenImageWhiteNoise -PUBLIC :: GenImagePerlinNoise -PUBLIC :: GenImageText -PUBLIC :: GenMeshCone -PUBLIC :: GenMeshCube -PUBLIC :: GenMeshCubicmap -PUBLIC :: GenMeshCylinder -PUBLIC :: GenMeshHeightmap -PUBLIC :: GenMeshHemiSphere -PUBLIC :: GenMeshKnot -PUBLIC :: GenMeshPlane -PUBLIC :: GenMeshPoly -PUBLIC :: GenMeshSphere -PUBLIC :: GenMeshTangents -PUBLIC :: GenMeshTorus -PUBLIC :: GenTextureMipmaps - -INTERFACE - - ! Image GenImageCellular(int width, int height, int tileSize) - function GenImageCellular(width, height, tile_size) bind(c, name='GenImageCellular') - IMPORT :: C_INT, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: tile_size - TYPE(image_) :: GenImageCellular - END FUNCTION GenImageCellular - - ! Image GenImageChecked(int width, int height, int checksX, int checksY, Color col1, Color col2) - function GenImageChecked(width, height, checks_x, checks_y, col1, col2) bind(c, name='GenImageChecked') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: checks_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: checks_y - TYPE(color_), INTENT(in), VALUE :: col1 - TYPE(color_), INTENT(in), VALUE :: col2 - TYPE(image_) :: GenImageChecked - END FUNCTION GenImageChecked - - ! Image GenImageColor(int width, int height, Color color) - FUNCTION GenImageColor(width, height, color) BIND(c, name='GenImageColor') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(color_), INTENT(in), VALUE :: color - TYPE(image_) :: GenImageColor - END FUNCTION GenImageColor - - ! Image GenImageFontAtlas(const GlyphInfo *glyphs, Rectangle **glyphRecs, int glyphCount, int fontSize, int padding, int packMethod) - function GenImageFontAtlas(glyphs, glyph_recs, glyph_count, font_size, padding, pack_method) & - BIND(c, name='GenImageFontAtlas') - IMPORT :: C_INT, glyph_info_, image_, rectangle_ - IMPLICIT NONE - TYPE(glyph_info_), INTENT(inout) :: glyphs - TYPE(rectangle_), INTENT(inout) :: glyph_recs(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: glyph_count - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - INTEGER(kind=C_INT), INTENT(in), VALUE :: padding - INTEGER(kind=C_INT), INTENT(in), VALUE :: pack_method - TYPE(image_) :: GenImageFontAtlas - END FUNCTION GenImageFontAtlas - - ! Image GenImageGradientLinear(int width, int height, int direction, Color start, Color end) - function GenImageGradientLinear(width, height, direction, start, end) bind(c, name='GenImageGradientLinear') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: direction - TYPE(color_), INTENT(in), VALUE :: start - TYPE(color_), INTENT(in), VALUE :: END - TYPE(image_) :: GenImageGradientLinear - END FUNCTION GenImageGradientLinear - - ! Image GenImageGradientRadial(int width, int height, float density, Color inner, Color outer) - function GenImageGradientRadial(width, height, density, inner, outer) bind(c, name='GenImageGradientRadial') - IMPORT :: C_FLOAT, C_INT, color_, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - REAL(kind=C_FLOAT), INTENT(in), VALUE :: density - TYPE(color_), INTENT(in), VALUE :: inner - TYPE(color_), INTENT(in), VALUE :: outer - TYPE(image_) :: GenImageGradientRadial - END FUNCTION GenImageGradientRadial - - ! Image GenImageGradientSquare(int width, int height, float density, Color inner, Color outer) - function GenImageGradientSquare(width, height, density, inner, outer) bind(c, name='GenImageGradientSquare') - IMPORT :: C_FLOAT, C_INT, color_, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - REAL(kind=C_FLOAT), INTENT(in), VALUE :: density - TYPE(color_), INTENT(in), VALUE :: inner - TYPE(color_), INTENT(in), VALUE :: outer - TYPE(image_) :: GenImageGradientSquare - END FUNCTION GenImageGradientSquare - - ! Image GenImageWhiteNoise(int width, int height, float factor) - function GenImageWhiteNoise(width, height, factor) bind(c, name='GenImageWhiteNoise') - IMPORT :: C_FLOAT, C_INT, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - REAL(kind=C_FLOAT), INTENT(in), VALUE :: factor - TYPE(image_) :: GenImageWhiteNoise - END FUNCTION GenImageWhiteNoise - - ! Image GenImagePerlinNoise(int width, int height, int offsetX, int offsetY, float scale) - function GenImagePerlinNoise(width, height, offset_x, offset_y, scale) bind(c, name='GenImagePerlinNoise') - IMPORT :: C_FLOAT, C_INT, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale - TYPE(image_) :: GenImagePerlinNoise - END FUNCTION GenImagePerlinNoise - - ! Image GenImageText(int width, int height, const char *text) - FUNCTION GenImageText(width, height, text) BIND(c, name='GenImageText') - IMPORT :: C_CHAR, C_INT, image_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - CHARACTER(kind=C_CHAR), INTENT(in) :: text - TYPE(image_) :: GenImageText - END FUNCTION GenImageText - - ! Mesh GenMeshCone(float radius, float height, int slices) - FUNCTION GenMeshCone(radius, height, slices) BIND(c, name='GenMeshCone') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(mesh_) :: GenMeshCone - END FUNCTION GenMeshCone - - ! Mesh GenMeshCube(float width, float height, float length) - FUNCTION GenMeshCube(width, height, length) BIND(c, name='GenMeshCube') - IMPORT :: C_FLOAT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: width - REAL(kind=C_FLOAT), INTENT(in), VALUE :: height - REAL(kind=C_FLOAT), INTENT(in), VALUE :: length - TYPE(mesh_) :: GenMeshCube - END FUNCTION GenMeshCube - - ! Mesh GenMeshCubicmap(Image cubicmap, Vector3 cubeSize) - FUNCTION GenMeshCubicmap(cubicmap, cube_size) BIND(c, name='GenMeshCubicmap') - IMPORT :: image_, mesh_, vector3_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: cubicmap - TYPE(vector3_), INTENT(in), VALUE :: cube_size - TYPE(mesh_) :: GenMeshCubicmap - END FUNCTION GenMeshCubicmap - - ! Mesh GenMeshCylinder(float radius, float height, int slices) - function GenMeshCylinder(radius, height, slices) bind(c, name='GenMeshCylinder') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(mesh_) :: GenMeshCylinder - END FUNCTION GenMeshCylinder - - ! Mesh GenMeshHeightmap(Image heightmap, Vector3 size) - FUNCTION GenMeshHeightmap(heightmap, size) BIND(c, name='GenMeshHeightmap') - IMPORT :: image_, mesh_, vector3_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: heightmap - TYPE(vector3_), INTENT(in), VALUE :: size - TYPE(mesh_) :: GenMeshHeightmap - END FUNCTION GenMeshHeightmap - - ! Mesh GenMeshHemiSphere(float radius, int rings, int slices) - function GenMeshHemiSphere(radius, rings, slices) bind(c, name='GenMeshHemiSphere') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: rings - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(mesh_) :: GenMeshHemiSphere - END FUNCTION GenMeshHemiSphere - - ! Mesh GenMeshKnot(float radius, float size, int radSeg, int sides) -FUNCTION GenMeshKnot(radius, size, rad_seg, sides) BIND(c, name='GenMeshKnot') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: size - INTEGER(kind=C_INT), INTENT(in), VALUE :: rad_seg - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - TYPE(mesh_) :: GenMeshKnot - END FUNCTION GenMeshKnot - - ! Mesh GenMeshPlane(float width, float length, int resX, int resZ) - function GenMeshPlane(width, length, res_x, res_z) bind(c, name='GenMeshPlane') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: width - REAL(kind=C_FLOAT), INTENT(in), VALUE :: length - INTEGER(kind=C_INT), INTENT(in), VALUE :: res_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: res_z - TYPE(mesh_) :: GenMeshPlane - END FUNCTION GenMeshPlane - - ! Mesh GenMeshPoly(int sides, float radius) - FUNCTION GenMeshPoly(sides, radius) BIND(c, name='GenMeshPoly') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(mesh_) :: GenMeshPoly - END FUNCTION GenMeshPoly - - ! Mesh GenMeshSphere(float radius, int rings, int slices) - FUNCTION GenMeshSphere(radius, rings, slices) BIND(c, name='GenMeshSphere') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - INTEGER(kind=C_INT), INTENT(in), VALUE :: rings - INTEGER(kind=C_INT), INTENT(in), VALUE :: slices - TYPE(mesh_) :: GenMeshSphere - END FUNCTION GenMeshSphere - - ! void GenMeshTangents(Mesh *mesh) - SUBROUTINE GenMeshTangents(mesh) BIND(c, name='GenMeshTangents') - IMPORT :: mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in) :: mesh - END SUBROUTINE GenMeshTangents - - ! Mesh GenMeshTorus(float radius, float size, int radSeg, int sides) - function GenMeshTorus(radius, size, rad_seg, sides) bind(c, name='GenMeshTorus') - IMPORT :: C_FLOAT, C_INT, mesh_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - REAL(kind=C_FLOAT), INTENT(in), VALUE :: size - INTEGER(kind=C_INT), INTENT(in), VALUE :: rad_seg - INTEGER(kind=C_INT), INTENT(in), VALUE :: sides - TYPE(mesh_) :: GenMeshTorus - END FUNCTION GenMeshTorus - - ! void GenTextureMipmaps(Texture2D *texture) - SUBROUTINE GenTextureMipmaps(texture) BIND(c, name='GenTextureMipmaps') - IMPORT :: texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(inout) :: texture - END SUBROUTINE GenTextureMipmaps - -END INTERFACE - -END MODULE RaylibGenMethods diff --git a/src/modules/RaylibInterface/src/RaylibGetMethods.F90 b/src/modules/RaylibInterface/src/RaylibGetMethods.F90 deleted file mode 100644 index eeb26d7df..000000000 --- a/src/modules/RaylibInterface/src/RaylibGetMethods.F90 +++ /dev/null @@ -1,794 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibGetMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetWorldToScreen2D -PUBLIC :: GetWorkingDirectory -PUBLIC :: GetWindowHandle -PUBLIC :: GetTouchY -PUBLIC :: GetTouchX -PUBLIC :: GetTouchPointId -PUBLIC :: GetTouchPointCount -PUBLIC :: GetTime -PUBLIC :: GetSplinePointLinear -PUBLIC :: GetSplinePointCatmullRom -PUBLIC :: GetSplinePointBezierQuad -PUBLIC :: GetSplinePointBezierCubic -PUBLIC :: GetSplinePointBasis -PUBLIC :: GetShaderLocationAttrib -PUBLIC :: GetShaderLocation -PUBLIC :: GetScreenWidth - -PUBLIC :: GetScreenToWorld2D -PUBLIC :: GetScreenHeight -PUBLIC :: GetRenderWidth -PUBLIC :: GetRenderHeight -PUBLIC :: GetRayCollisionTriangle -PUBLIC :: GetRayCollisionSphere -PUBLIC :: GetRayCollisionQuad -PUBLIC :: GetRayCollisionMesh -PUBLIC :: GetRayCollisionBox -PUBLIC :: GetRandomValue - -PUBLIC :: GetPrevDirectoryPath -PUBLIC :: GetPixelDataSize -PUBLIC :: GetPixelColor -PUBLIC :: GetMusicTimePlayed -PUBLIC :: GetMusicTimeLength -PUBLIC :: GetMouseY -PUBLIC :: GetMouseX -PUBLIC :: GetMouseWheelMove -PUBLIC :: GetMouseRay -PUBLIC :: GetMousePosition -PUBLIC :: GetMouseDelta -PUBLIC :: GetMonitorWidth -PUBLIC :: GetMonitorRefreshRate -PUBLIC :: GetMonitorPhysicalWidth -PUBLIC :: GetMonitorPhysicalHeight -PUBLIC :: GetMonitorName - -PUBLIC :: GetMonitorHeight -PUBLIC :: GetMonitorCount -PUBLIC :: GetModelBoundingBox -PUBLIC :: GetMeshBoundingBox -PUBLIC :: GetMasterVolume -PUBLIC :: GetKeyPressed -PUBLIC :: GetImageColor -PUBLIC :: GetImageAlphaBorder -PUBLIC :: GetGlyphInfo -PUBLIC :: GetGlyphIndex -PUBLIC :: GetGlyphAtlasRec -PUBLIC :: GetGesturePinchAngle -PUBLIC :: GetGestureHoldDuration -PUBLIC :: GetGestureDragAngle -PUBLIC :: GetGestureDetected -PUBLIC :: GetGamepadName -PUBLIC :: GetGamepadButtonPressed -PUBLIC :: GetGamepadAxisMovement -PUBLIC :: GetGamepadAxisCount -PUBLIC :: GetFrameTime - -PUBLIC :: GetFPS -PUBLIC :: GetFontDefault -PUBLIC :: GetFileNameWithoutExt -PUBLIC :: GetFileName -PUBLIC :: GetFileModTime -PUBLIC :: GetFileLength -PUBLIC :: GetFileExtension -PUBLIC :: GetDirectoryPath -PUBLIC :: GetCurrentMonitor -PUBLIC :: GetColor -PUBLIC :: GetCollisionRec -PUBLIC :: GetCodepointPrevious -PUBLIC :: GetCodepointNext -PUBLIC :: GetCodepointCount -PUBLIC :: GetCodepoint -PUBLIC :: GetClipboardText -PUBLIC :: GetCharPressed -PUBLIC :: GetCameraMatrix2D -PUBLIC :: GetCameraMatrix -PUBLIC :: GetApplicationDirectory - -INTERFACE - - FUNCTION GetApplicationDirectory() BIND(c, name='GetApplicationDirectory') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR) :: GetApplicationDirectory - END FUNCTION GetApplicationDirectory - - ! Matrix GetCameraMatrix(Camera camera) - FUNCTION GetCameraMatrix(camera) BIND(c, name='GetCameraMatrix') - IMPORT :: camera3d_, matrix_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(in), VALUE :: camera - TYPE(matrix_) :: GetCameraMatrix - END FUNCTION GetCameraMatrix - - ! Matrix GetCameraMatrix2D(Camera2D camera) - FUNCTION GetCameraMatrix2D(camera) BIND(c, name='GetCameraMatrix2D') - IMPORT :: camera2d_, matrix_ - IMPLICIT NONE - TYPE(camera2d_), INTENT(in), VALUE :: camera - TYPE(matrix_) :: GetCameraMatrix2D - END FUNCTION GetCameraMatrix2D - - ! int GetCharPressed(void) - FUNCTION GetCharPressed() BIND(c, name='GetCharPressed') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetCharPressed - END FUNCTION GetCharPressed - - ! const char *GetClipboardText(void) - FUNCTION GetClipboardText() BIND(c, name='GetClipboardText') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR) :: GetClipboardText - END FUNCTION GetClipboardText - - ! int GetCodepoint(const char *text, int *codepointSize) - FUNCTION GetCodepoint(text, codepoint_size) BIND(c, name='GetCodepoint') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(out) :: codepoint_size - INTEGER(kind=C_INT) :: GetCodepoint - END FUNCTION GetCodepoint - - ! int GetCodepointCount(const char *text) - FUNCTION GetCodepointCount(text) BIND(c, name='GetCodepointCount') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT) :: GetCodepointCount - END FUNCTION GetCodepointCount - - ! int GetCodepointNext(const char *text, int *codepointSize) - FUNCTION GetCodepointNext(text, codepoint_size) BIND(c, name='GetCodepointNext') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(out) :: codepoint_size - INTEGER(kind=C_INT) :: GetCodepointNext - END FUNCTION GetCodepointNext - - ! int GetCodepointPrevious(const char *text, int *codepointSize) - FUNCTION GetCodepointPrevious(text, codepoint_size) & - BIND(c, name='GetCodepointPrevious') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(out) :: codepoint_size - INTEGER(kind=C_INT) :: GetCodepointPrevious - END FUNCTION GetCodepointPrevious - - ! Rectangle GetCollisionRec(Rectangle rec1, Rectangle rec2) - FUNCTION GetCollisionRec(rec1, rec2) BIND(c, name='GetCollisionRec') - IMPORT :: rectangle_ - IMPLICIT NONE - TYPE(rectangle_), INTENT(in), VALUE :: rec1 - TYPE(rectangle_), INTENT(in), VALUE :: rec2 - TYPE(rectangle_) :: GetCollisionRec - END FUNCTION GetCollisionRec - - ! Color GetColor(unsigned int hexValue) - FUNCTION GetColor(hex_value) BIND(c, name='GetColor') - IMPORT :: c_unsigned_int, color_ - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: hex_value - TYPE(color_) :: GetColor - END FUNCTION GetColor - - ! int GetCurrentMonitor(void) - FUNCTION GetCurrentMonitor() BIND(c, name='GetCurrentMonitor') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetCurrentMonitor - END FUNCTION GetCurrentMonitor - - ! const char *GetDirectoryPath(const char *filePath) - FUNCTION GetDirectoryPath(file_path) BIND(c, name='GetDirectoryPath') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_path - TYPE(C_PTR) :: GetDirectoryPath - END FUNCTION GetDirectoryPath - - ! int GetFPS(void) - FUNCTION GetFPS() BIND(c, name='GetFPS') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetFPS - END FUNCTION GetFPS - - ! const char *GetFileExtension(const char *fileName) - FUNCTION GetFileExtension(file_name) BIND(c, name='GetFileExtension') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(C_PTR) :: GetFileExtension - END FUNCTION GetFileExtension - - ! int GetFileLength(const char *fileName) - FUNCTION GetFileLength(file_name) BIND(c, name='GetFileLength') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_INT) :: GetFileLength - END FUNCTION GetFileLength - - ! long GetFileModTime(const char *fileName) - FUNCTION GetFileModTime(file_name) BIND(c, name='GetFileModTime') - IMPORT :: C_CHAR, C_LONG - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_LONG) :: GetFileModTime - END FUNCTION GetFileModTime - - ! const char *GetFileName(const char *filePath) - FUNCTION GetFileName(file_path) BIND(c, name='GetFileName') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_path - TYPE(C_PTR) :: GetFileName - END FUNCTION GetFileName - - ! const char *GetFileNameWithoutExt(const char *filePath) - FUNCTION GetFileNameWithoutExt(file_path) BIND(c, name='GetFileNameWithoutExt') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_path - TYPE(C_PTR) :: GetFileNameWithoutExt - END FUNCTION GetFileNameWithoutExt - - ! Font GetFontDefault(void) - FUNCTION GetFontDefault() BIND(c, name='GetFontDefault') - IMPORT :: font_ - IMPLICIT NONE - TYPE(font_) :: GetFontDefault - END FUNCTION GetFontDefault - - ! float GetFrameTime(void) - FUNCTION GetFrameTime() BIND(c, name='GetFrameTime') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT) :: GetFrameTime - END FUNCTION GetFrameTime - - ! int GetGamepadAxisCount(int gamepad) - FUNCTION GetGamepadAxisCount(gamepad) BIND(c, name='GetGamepadAxisCount') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - INTEGER(kind=C_INT) :: GetGamepadAxisCount - END FUNCTION GetGamepadAxisCount - - ! float GetGamepadAxisMovement(int gamepad, int axis) - FUNCTION GetGamepadAxisMovement(gamepad, axis) BIND(c, name='GetGamepadAxisMovement') - IMPORT :: C_FLOAT, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - INTEGER(kind=C_INT), INTENT(in), VALUE :: axis - REAL(kind=C_FLOAT) :: GetGamepadAxisMovement - END FUNCTION GetGamepadAxisMovement - - ! int GetGamepadButtonPressed(void) - FUNCTION GetGamepadButtonPressed() BIND(c, name='GetGamepadButtonPressed') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetGamepadButtonPressed - END FUNCTION GetGamepadButtonPressed - - ! const char *GetGamepadName(int gamepad) - FUNCTION GetGamepadName(gamepad) BIND(c, name='GetGamepadName') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - TYPE(C_PTR) :: GetGamepadName - END FUNCTION GetGamepadName - - ! int GetGestureDetected(void) - FUNCTION GetGestureDetected() BIND(c, name='GetGestureDetected') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetGestureDetected - END FUNCTION GetGestureDetected - - ! float GetGestureDragAngle(void) - FUNCTION GetGestureDragAngle() BIND(c, name='GetGestureDragAngle') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT) :: GetGestureDragAngle - END FUNCTION GetGestureDragAngle - - ! float GetGestureHoldDuration(void) - FUNCTION GetGestureHoldDuration() BIND(c, name='GetGestureHoldDuration') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT) :: GetGestureHoldDuration - END FUNCTION GetGestureHoldDuration - - ! float GetGesturePinchAngle(void) - FUNCTION GetGesturePinchAngle() BIND(c, name='GetGesturePinchAngle') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT) :: GetGesturePinchAngle - END FUNCTION GetGesturePinchAngle - - ! Rectangle GetGlyphAtlasRec(Font font, int codepoint) - FUNCTION GetGlyphAtlasRec(font, codepoint) BIND(c, name='GetGlyphAtlasRec') - IMPORT :: C_INT, font_, rectangle_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint - TYPE(rectangle_) :: GetGlyphAtlasRec - END FUNCTION GetGlyphAtlasRec - - ! int GetGlyphIndex(Font font, int codepoint) - FUNCTION GetGlyphIndex(font, codepoint) BIND(c, name='GetGlyphIndex') - IMPORT :: C_INT, font_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint - INTEGER(kind=C_INT) :: GetGlyphIndex - END FUNCTION GetGlyphIndex - - ! GlyphInfo GetGlyphInfo(Font font, int codepoint) - FUNCTION GetGlyphInfo(font, codepoint) BIND(c, name='GetGlyphInfo') - IMPORT :: C_INT, font_, glyph_info_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint - TYPE(glyph_info_) :: GetGlyphInfo - END FUNCTION GetGlyphInfo - - ! float GetMasterVolume(void) - FUNCTION GetMasterVolume() BIND(c, name='GetMasterVolume') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT) :: GetMasterVolume - END FUNCTION GetMasterVolume - - ! Rectangle GetImageAlphaBorder(Image image, float threshold) - FUNCTION GetImageAlphaBorder(image, threshold) BIND(c, name='GetImageAlphaBorder') - IMPORT :: C_FLOAT, image_, rectangle_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - REAL(kind=C_FLOAT), INTENT(in), VALUE :: threshold - TYPE(rectangle_) :: GetImageAlphaBorder - END FUNCTION GetImageAlphaBorder - - ! Vector2 GetSplinePointBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) - FUNCTION GetSplinePointBasis(p1, p2, p3, p4, t) BIND(c, & - name='GetSplinePointBasis') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: p2 - TYPE(vector2_), INTENT(in), VALUE :: p3 - TYPE(vector2_), INTENT(in), VALUE :: p4 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: t - TYPE(vector2_) :: GetSplinePointBasis - END FUNCTION GetSplinePointBasis - - ! Vector2 GetSplinePointBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float t) - FUNCTION GetSplinePointBezierCubic(p1, c2, c3, p4, t) BIND(c, & - name='GetSplinePointBezierCubic') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: c2 - TYPE(vector2_), INTENT(in), VALUE :: c3 - TYPE(vector2_), INTENT(in), VALUE :: p4 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: t - TYPE(vector2_) :: GetSplinePointBezierCubic - END FUNCTION GetSplinePointBezierCubic - - ! Vector2 GetSplinePointBezierQuad(Vector2 p1, Vector2 c2, Vector2 p3, float t) - FUNCTION GetSplinePointBezierQuad(p1, c2, p3, t) BIND(c, name='GetSplinePointBezierQuad') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: c2 - TYPE(vector2_), INTENT(in), VALUE :: p3 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: t - TYPE(vector2_) :: GetSplinePointBezierQuad - END FUNCTION GetSplinePointBezierQuad - - ! Vector2 GetSplinePointCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) - FUNCTION GetSplinePointCatmullRom(p1, p2, p3, p4, t) BIND(c, & - name='GetSplinePointCatmullRom') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p1 - TYPE(vector2_), INTENT(in), VALUE :: p2 - TYPE(vector2_), INTENT(in), VALUE :: p3 - TYPE(vector2_), INTENT(in), VALUE :: p4 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: t - TYPE(vector2_) :: GetSplinePointCatmullRom - END FUNCTION GetSplinePointCatmullRom - - ! Vector2 GetSplinePointLinear(Vector2 startPos, Vector2 endPos, float t) - FUNCTION GetSplinePointLinear(start_pos, end_pos, t) BIND(c, name='GetSplinePointLinear') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: start_pos - TYPE(vector2_), INTENT(in), VALUE :: end_pos - REAL(kind=C_FLOAT), INTENT(in), VALUE :: t - TYPE(vector2_) :: GetSplinePointLinear - END FUNCTION GetSplinePointLinear - - ! Color GetImageColor(Image image, int x, int y) - FUNCTION GetImageColor(image, x, y) BIND(c, name='GetImageColor') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: x - INTEGER(kind=C_INT), INTENT(in), VALUE :: y - TYPE(color_) :: GetImageColor - END FUNCTION GetImageColor - - ! int GetKeyPressed(void) - FUNCTION GetKeyPressed() BIND(c, name='GetKeyPressed') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetKeyPressed - END FUNCTION GetKeyPressed - - ! BoundingBox GetMeshBoundingBox(Mesh mesh) - FUNCTION GetMeshBoundingBox(mesh) BIND(c, name='GetMeshBoundingBox') - IMPORT :: bounding_box_, mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in), VALUE :: mesh - TYPE(bounding_box_) :: GetMeshBoundingBox - END FUNCTION GetMeshBoundingBox - - ! BoundingBox GetModelBoundingBox(Model model) - FUNCTION GetModelBoundingBox(model) BIND(c, name='GetModelBoundingBox') - IMPORT :: bounding_box_, model_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - TYPE(bounding_box_) :: GetModelBoundingBox - END FUNCTION GetModelBoundingBox - - ! int GetMonitorCount(void) - FUNCTION GetMonitorCount() BIND(c, name='GetMonitorCount') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetMonitorCount - END FUNCTION GetMonitorCount - - ! int GetMonitorHeight(int monitor) - FUNCTION GetMonitorHeight(monitor) BIND(c, name='GetMonitorHeight') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor - INTEGER(kind=C_INT) :: GetMonitorHeight - END FUNCTION GetMonitorHeight - - ! const char *GetMonitorName(int monitor) - FUNCTION GetMonitorName(monitor) BIND(c, name='GetMonitorName') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor - TYPE(C_PTR) :: GetMonitorName - END FUNCTION GetMonitorName - - ! int GetMonitorPhysicalHeight(int monitor) - FUNCTION GetMonitorPhysicalHeight(monitor) BIND(c, name='GetMonitorPhysicalHeight') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor - INTEGER(kind=C_INT) :: GetMonitorPhysicalHeight - END FUNCTION GetMonitorPhysicalHeight - - ! int GetMonitorPhysicalWidth(int monitor) - FUNCTION GetMonitorPhysicalWidth(monitor) BIND(c, name='GetMonitorPhysicalWidth') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor - INTEGER(kind=C_INT) :: GetMonitorPhysicalWidth - END FUNCTION GetMonitorPhysicalWidth - - ! int GetMonitorRefreshRate(int monitor) - FUNCTION GetMonitorRefreshRate(monitor) BIND(c, name='GetMonitorRefreshRate') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor - INTEGER(kind=C_INT) :: GetMonitorRefreshRate - END FUNCTION GetMonitorRefreshRate - - ! int GetMonitorWidth(int monitor) - FUNCTION GetMonitorWidth(monitor) BIND(c, name='GetMonitorWidth') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor - INTEGER(kind=C_INT) :: GetMonitorWidth - END FUNCTION GetMonitorWidth - - ! Vector2 GetMouseDelta(void) - FUNCTION GetMouseDelta() BIND(c, name='GetMouseDelta') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_) :: GetMouseDelta - END FUNCTION GetMouseDelta - - ! Vector2 GetMousePosition(void) - FUNCTION GetMousePosition() BIND(c, name='GetMousePosition') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_) :: GetMousePosition - END FUNCTION GetMousePosition - - ! Ray GetMouseRay(Vector2 mousePosition, Camera camera) - FUNCTION GetMouseRay(mouse_position, camera) BIND(c, name='GetMouseRay') - IMPORT :: camera3d_, ray_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: mouse_position - TYPE(camera3d_), INTENT(in), VALUE :: camera - TYPE(ray_) :: GetMouseRay - END FUNCTION GetMouseRay - - ! float GetMouseWheelMove(void) - FUNCTION GetMouseWheelMove() BIND(c, name='GetMouseWheelMove') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT) :: GetMouseWheelMove - END FUNCTION GetMouseWheelMove - - ! int GetMouseX(void) - FUNCTION GetMouseX() BIND(c, name='GetMouseX') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetMouseX - END FUNCTION GetMouseX - - ! int GetMouseY(void) - FUNCTION GetMouseY() BIND(c, name='GetMouseY') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetMouseY - END FUNCTION GetMouseY - - ! float GetMusicTimeLength(Music music) - FUNCTION GetMusicTimeLength(music) BIND(c, name='GetMusicTimeLength') - IMPORT :: C_FLOAT, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - REAL(kind=C_FLOAT) :: GetMusicTimeLength - END FUNCTION GetMusicTimeLength - - ! float GetMusicTimePlayed(Music music) - FUNCTION GetMusicTimePlayed(music) BIND(c, name='GetMusicTimePlayed') - IMPORT :: C_FLOAT, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - REAL(kind=C_FLOAT) :: GetMusicTimePlayed - END FUNCTION GetMusicTimePlayed - - ! Color GetPixelColor(void *srcPtr, int format) - FUNCTION GetPixelColor(src_ptr, FORMAT) BIND(c, name='GetPixelColor') - IMPORT :: C_INT, C_PTR, color_ - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: src_ptr - INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT - TYPE(color_) :: GetPixelColor - END FUNCTION GetPixelColor - - ! int GetPixelDataSize(int width, int height, int format) - FUNCTION GetPixelDataSize(width, height, FORMAT) BIND(c, name='GetPixelDataSize') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT - INTEGER(kind=C_INT) :: GetPixelDataSize - END FUNCTION GetPixelDataSize - - ! const char *GetPrevDirectoryPath(const char *dirPath) - FUNCTION GetPrevDirectoryPath(dir_path) BIND(c, & - name='GetPrevDirectoryPath') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: dir_path - TYPE(C_PTR) :: GetPrevDirectoryPath - END FUNCTION GetPrevDirectoryPath - - ! int GetRandomValue(int min, int max) - FUNCTION GetRandomValue(min, max) BIND(c, name='GetRandomValue') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: min - INTEGER(kind=C_INT), INTENT(in), VALUE :: max - INTEGER(kind=C_INT) :: GetRandomValue - END FUNCTION GetRandomValue - - ! RayCollision GetRayCollisionBox(Ray ray, BoundingBox box) - FUNCTION GetRayCollisionBox(ray, box) BIND(c, name='GetRayCollisionBox') - IMPORT :: bounding_box_, ray_collision_, ray_ - IMPLICIT NONE - TYPE(ray_), INTENT(in), VALUE :: ray - TYPE(bounding_box_), INTENT(in), VALUE :: box - TYPE(ray_collision_) :: GetRayCollisionBox - END FUNCTION GetRayCollisionBox - - ! RayCollision GetRayCollisionMesh(Ray ray, Mesh mesh, Matrix transform) - FUNCTION GetRayCollisionMesh(ray, mesh, transform) & - BIND(c, name='GetRayCollisionMesh') - IMPORT :: matrix_, mesh_, ray_collision_, ray_ - IMPLICIT NONE - TYPE(ray_), INTENT(in), VALUE :: ray - TYPE(mesh_), INTENT(in), VALUE :: mesh - TYPE(matrix_), INTENT(in), VALUE :: transform - TYPE(ray_collision_) :: GetRayCollisionMesh - END FUNCTION GetRayCollisionMesh - - ! RayCollision GetRayCollisionQuad(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3, Vector3 p4) - FUNCTION GetRayCollisionQuad(ray, p1, p2, p3, p4) & - BIND(c, name='GetRayCollisionQuad') - IMPORT :: ray_collision_, ray_, vector3_ - IMPLICIT NONE - TYPE(ray_), INTENT(in), VALUE :: ray - TYPE(vector3_), INTENT(in), VALUE :: p1 - TYPE(vector3_), INTENT(in), VALUE :: p2 - TYPE(vector3_), INTENT(in), VALUE :: p3 - TYPE(vector3_), INTENT(in), VALUE :: p4 - TYPE(ray_collision_) :: GetRayCollisionQuad - END FUNCTION GetRayCollisionQuad - - ! RayCollision GetRayCollisionSphere(Ray ray, Vector3 center, float radius) - FUNCTION GetRayCollisionSphere(ray, center, radius) & - BIND(c, name='GetRayCollisionSphere') - IMPORT :: C_FLOAT, ray_collision_, ray_, vector3_ - IMPLICIT NONE - TYPE(ray_), INTENT(in), VALUE :: ray - TYPE(vector3_), INTENT(in), VALUE :: center - REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius - TYPE(ray_collision_) :: GetRayCollisionSphere - END FUNCTION GetRayCollisionSphere - - ! RayCollision GetRayCollisionTriangle(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3) - FUNCTION GetRayCollisionTriangle(ray, p1, p2, p3) & - BIND(c, name='GetRayCollisionTriangle') - IMPORT :: ray_collision_, ray_, vector3_ - IMPLICIT NONE - TYPE(ray_), INTENT(in), VALUE :: ray - TYPE(vector3_), INTENT(in), VALUE :: p1 - TYPE(vector3_), INTENT(in), VALUE :: p2 - TYPE(vector3_), INTENT(in), VALUE :: p3 - TYPE(ray_collision_) :: GetRayCollisionTriangle - END FUNCTION GetRayCollisionTriangle - - ! int GetRenderHeight(void) - FUNCTION GetRenderHeight() BIND(c, name='GetRenderHeight') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetRenderHeight - END FUNCTION GetRenderHeight - - ! int GetRenderWidth(void) - FUNCTION GetRenderWidth() BIND(c, name='GetRenderWidth') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetRenderWidth - END FUNCTION GetRenderWidth - - ! int GetScreenHeight(void) - FUNCTION GetScreenHeight() BIND(c, name='GetScreenHeight') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetScreenHeight - END FUNCTION GetScreenHeight - - ! Vector2 GetScreenToWorld2D(Vector2 position, Camera2D camera) - FUNCTION GetScreenToWorld2D(position, camera) & - BIND(c, name='GetScreenToWorld2D') - IMPORT :: camera2d_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(camera2d_), INTENT(in), VALUE :: camera - TYPE(vector2_) :: GetScreenToWorld2D - END FUNCTION GetScreenToWorld2D - - ! int GetScreenWidth(void) - FUNCTION GetScreenWidth() BIND(c, name='GetScreenWidth') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetScreenWidth - END FUNCTION GetScreenWidth - - ! int GetShaderLocation(Shader shader, const char *uniformName) - FUNCTION GetShaderLocation(shader, uniform_name) & - BIND(c, name='GetShaderLocation') - IMPORT :: C_CHAR, C_INT, shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - CHARACTER(kind=C_CHAR), INTENT(in) :: uniform_name - INTEGER(kind=C_INT) :: GetShaderLocation - END FUNCTION GetShaderLocation - - ! int GetShaderLocationAttrib(Shader shader, const char *attribName) - FUNCTION GetShaderLocationAttrib(shader, attrib_name) & - BIND(c, name='GetShaderLocationAttrib') - IMPORT :: C_CHAR, C_INT, shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - CHARACTER(kind=C_CHAR), INTENT(in) :: attrib_name - INTEGER(kind=C_INT) :: GetShaderLocationAttrib - END FUNCTION GetShaderLocationAttrib - - ! double GetTime(void) - FUNCTION GetTime() BIND(c, name='GetTime') - IMPORT :: C_DOUBLE - IMPLICIT NONE - REAL(kind=C_DOUBLE) :: GetTime - END FUNCTION GetTime - - ! int GetTouchPointCount(void) - FUNCTION GetTouchPointCount() BIND(c, name='GetTouchPointCount') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetTouchPointCount - END FUNCTION GetTouchPointCount - - ! int GetTouchPointId(int index) - FUNCTION GetTouchPointId(index) BIND(c, name='GetTouchPointId') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: index - INTEGER(kind=C_INT) :: GetTouchPointId - END FUNCTION GetTouchPointId - - ! int GetTouchX(void) - FUNCTION GetTouchX() BIND(c, name='GetTouchX') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetTouchX - END FUNCTION GetTouchX - - ! int GetTouchY(void) - FUNCTION GetTouchY() BIND(c, name='GetTouchY') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: GetTouchY - END FUNCTION GetTouchY - - ! void *GetWindowHandle(void) - FUNCTION GetWindowHandle() BIND(c, name='GetWindowHandle') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR) :: GetWindowHandle - END FUNCTION GetWindowHandle - - ! const char *GetWorkingDirectory(void) - FUNCTION GetWorkingDirectory() BIND(c, name='GetWorkingDirectory') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR) :: GetWorkingDirectory - END FUNCTION GetWorkingDirectory - - ! Vector2 GetWorldToScreen2D(Vector2 position, Camera2D camera) - FUNCTION GetWorldToScreen2D(position, camera) & - BIND(c, name='GetWorldToScreen2D') - IMPORT :: camera2d_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(camera2d_), INTENT(in), VALUE :: camera - TYPE(vector2_) :: GetWorldToScreen2D - END FUNCTION GetWorldToScreen2D - -END INTERFACE - -END MODULE RaylibGetMethods diff --git a/src/modules/RaylibInterface/src/RaylibImageMethods.F90 b/src/modules/RaylibInterface/src/RaylibImageMethods.F90 deleted file mode 100644 index 9368d4d16..000000000 --- a/src/modules/RaylibInterface/src/RaylibImageMethods.F90 +++ /dev/null @@ -1,477 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibImageMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: ImageToPOT -PUBLIC :: ImageTextEx -PUBLIC :: ImageText -PUBLIC :: ImageRotateCW -PUBLIC :: ImageRotateCCW -PUBLIC :: ImageRotate -PUBLIC :: ImageResizeNN -PUBLIC :: ImageResizeCanvas -PUBLIC :: ImageResize -PUBLIC :: ImageMipmaps -PUBLIC :: ImageKernelConvolution -PUBLIC :: ImageFromImage -PUBLIC :: ImageFormat -PUBLIC :: ImageFlipVertical -PUBLIC :: ImageFlipHorizontal -PUBLIC :: ImageDrawTextEx -PUBLIC :: ImageDrawText -PUBLIC :: ImageDrawRectangleV -PUBLIC :: ImageDrawRectangleRec -PUBLIC :: ImageDrawRectangleLines -PUBLIC :: ImageDrawRectangle -PUBLIC :: ImageDrawPixelV -PUBLIC :: ImageDrawPixel -PUBLIC :: ImageDrawLineV -PUBLIC :: ImageDrawLine -PUBLIC :: ImageDrawCircleV -PUBLIC :: ImageDrawCircleLinesV -PUBLIC :: ImageDrawCircleLines -PUBLIC :: ImageDrawCircle -PUBLIC :: ImageDraw -PUBLIC :: ImageDither -PUBLIC :: ImageCrop -PUBLIC :: ImageCopy -PUBLIC :: ImageColorTint -PUBLIC :: ImageColorReplace -PUBLIC :: ImageColorInvert -PUBLIC :: ImageColorGrayscale -PUBLIC :: ImageColorContrast -PUBLIC :: ImageColorBrightness -PUBLIC :: ImageClearBackground -PUBLIC :: ImageBlurGaussian -PUBLIC :: ImageAlphaPremultiply -PUBLIC :: ImageAlphaMask -PUBLIC :: ImageAlphaCrop -PUBLIC :: ImageAlphaClear - -INTERFACE - - ! void ImageBlurGaussian(Image *image, int blurSize) - SUBROUTINE ImageBlurGaussian(image, blur_size) BIND(c, name='ImageBlurGaussian') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: blur_size - END SUBROUTINE ImageBlurGaussian - - ! void ImageAlphaClear(Image *image, Color color, float threshold) - subroutine ImageAlphaClear(image, color, threshold) bind(c, name='ImageAlphaClear') - IMPORT :: C_FLOAT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - TYPE(color_), INTENT(in), VALUE :: color - REAL(kind=C_FLOAT), INTENT(in), VALUE :: threshold - END SUBROUTINE ImageAlphaClear - - ! void ImageAlphaCrop(Image *image, float threshold) - SUBROUTINE ImageAlphaCrop(image, threshold) BIND(c, name='ImageAlphaCrop') - IMPORT :: C_FLOAT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - REAL(kind=C_FLOAT), INTENT(in), VALUE :: threshold - END SUBROUTINE ImageAlphaCrop - - ! void ImageAlphaMask(Image *image, Image alphaMask) - SUBROUTINE ImageAlphaMask(image, alpha_mask) BIND(c, name='ImageAlphaMask') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - TYPE(image_), INTENT(in), VALUE :: alpha_mask - END SUBROUTINE ImageAlphaMask - - ! void ImageAlphaPremultiply(Image *image) - SUBROUTINE ImageAlphaPremultiply(image) BIND(c, name='ImageAlphaPremultiply') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageAlphaPremultiply - - ! void ImageClearBackground(Image *dst, Color color) - subroutine ImageClearBackground(dst, color) bind(c, name='ImageClearBackground') - IMPORT :: color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageClearBackground - - ! void ImageColorBrightness(Image *image, int brightness) - subroutine ImageColorBrightness(image, brightness) bind(c, name='ImageColorBrightness') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: brightness - END SUBROUTINE ImageColorBrightness - - ! void ImageColorContrast(Image *image, float contrast) - subroutine ImageColorContrast(image, contrast) bind(c, name='ImageColorContrast') - IMPORT :: C_FLOAT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - REAL(kind=C_FLOAT), INTENT(in), VALUE :: contrast - END SUBROUTINE ImageColorContrast - - ! void ImageColorGrayscale(Image *image) - SUBROUTINE ImageColorGrayscale(image) BIND(c, name='ImageColorGrayscale') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageColorGrayscale - - ! void ImageColorInvert(Image *image) - SUBROUTINE ImageColorInvert(image) BIND(c, name='ImageColorInvert') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageColorInvert - - ! void ImageColorReplace(Image *image, Color color, Color replace) - subroutine ImageColorReplace(image, color, replace) bind(c, name='ImageColorReplace') - IMPORT :: color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - TYPE(color_), INTENT(in), VALUE :: color - TYPE(color_), INTENT(in), VALUE :: replace - END SUBROUTINE ImageColorReplace - - ! void ImageColorTint(Image *image, Color color) - SUBROUTINE ImageColorTint(image, color) BIND(c, name='ImageColorTint') - IMPORT :: color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageColorTint - - ! Image ImageCopy(Image image) - FUNCTION ImageCopy(image) BIND(c, name='ImageCopy') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - TYPE(image_) :: ImageCopy - END FUNCTION ImageCopy - - ! void ImageCrop(Image *image, Rectangle crop) - SUBROUTINE ImageCrop(image, crop) BIND(c, name='ImageCrop') - IMPORT :: image_, rectangle_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - TYPE(rectangle_), INTENT(in), VALUE :: crop - END SUBROUTINE ImageCrop - - ! void ImageDither(Image *image, int rBpp, int gBpp, int bBpp, int aBpp) - subroutine ImageDither(image, r_bpp, g_bpp, b_bpp, a_bpp) bind(c, name='ImageDither') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: r_bpp - INTEGER(kind=C_INT), INTENT(in), VALUE :: g_bpp - INTEGER(kind=C_INT), INTENT(in), VALUE :: b_bpp - INTEGER(kind=C_INT), INTENT(in), VALUE :: a_bpp - END SUBROUTINE ImageDither - - ! void ImageDraw(Image *dst, Image src, Rectangle srcRec, Rectangle dstRec, Color tint) - subroutine ImageDraw(dst, src, src_rec, dst_rec, tint) bind(c, name='ImageDraw') - IMPORT :: color_, image_, rectangle_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(image_), INTENT(in), VALUE :: src - TYPE(rectangle_), INTENT(in), VALUE :: src_rec - TYPE(rectangle_), INTENT(in), VALUE :: dst_rec - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE ImageDraw - - ! void ImageDrawCircle(Image *dst, int centerX, int centerY, int radius, Color color) - subroutine ImageDrawCircle(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircle') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawCircle - - ! void ImageDrawCircleLines(Image *dst, int centerX, int centerY, int radius, Color color) - subroutine ImageDrawCircleLines(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircleLines') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawCircleLines - - ! void ImageDrawCircleLinesV(Image *dst, Vector2 center, int radius, Color color) - subroutine ImageDrawCircleLinesV(dst, center, radius, color) bind(c, name='ImageDrawCircleLinesV') - IMPORT :: C_INT, color_, image_, vector2_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(vector2_), INTENT(in), VALUE :: center - INTEGER(kind=C_INT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawCircleLinesV - - ! void ImageDrawCircleV(Image *dst, Vector2 center, int radius, Color color) - subroutine ImageDrawCircleV(dst, center, radius, color) bind(c, name='ImageDrawCircleV') - IMPORT :: C_INT, color_, image_, vector2_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(vector2_), INTENT(in), VALUE :: center - INTEGER(kind=C_INT), INTENT(in), VALUE :: radius - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawCircleV - - ! void ImageDrawLine(Image *dst, int startPosX, int startPosY, int endPosX, int endPosY, Color color) - subroutine ImageDrawLine(dst, start_pos_x, start_pos_y, end_pos_x, end_pos_y, color) & - BIND(c, name='ImageDrawLine') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_y - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawLine - - ! void ImageDrawLineV(Image *dst, Vector2 start, Vector2 end, Color color) - subroutine ImageDrawLineV(dst, start, end, color) bind(c, name='ImageDrawLineV') - IMPORT :: color_, image_, vector2_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(vector2_), INTENT(in), VALUE :: start - TYPE(vector2_), INTENT(in), VALUE :: END - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawLineV - - ! void ImageDrawPixel(Image *dst, int posX, int posY, Color color) - subroutine ImageDrawPixel(dst, pos_x, pos_y, color) bind(c, name='ImageDrawPixel') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawPixel - - ! void ImageDrawPixelV(Image *dst, Vector2 position, Color color) - subroutine ImageDrawPixelV(dst, position, color) bind(c, name='ImageDrawPixelV') - IMPORT :: color_, image_, vector2_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawPixelV - - ! void ImageDrawRectangle(Image *dst, int posX, int posY, int width, int height, Color color) - subroutine ImageDrawRectangle(dst, pos_x, pos_y, width, height, color) bind(c, name='ImageDrawRectangle') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawRectangle - - ! void ImageDrawRectangleLines(Image *dst, Rectangle rec, int thick, Color color) - subroutine ImageDrawRectangleLines(dst, rec, thick, color) bind(c, name='ImageDrawRectangleLines') - IMPORT :: C_INT, color_, image_, rectangle_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(rectangle_), INTENT(in), VALUE :: rec - INTEGER(kind=C_INT), INTENT(in), VALUE :: thick - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawRectangleLines - - ! void ImageDrawRectangleRec(Image *dst, Rectangle rec, Color color) - subroutine ImageDrawRectangleRec(dst, rec, color) bind(c, name='ImageDrawRectangleRec') - IMPORT :: color_, image_, rectangle_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(rectangle_), INTENT(in), VALUE :: rec - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawRectangleRec - - ! void ImageDrawRectangleV(Image *dst, Vector2 position, Vector2 size, Color color) - subroutine ImageDrawRectangleV(dst, position, size, color) bind(c, name='ImageDrawRectangleV') - IMPORT :: color_, image_, vector2_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(vector2_), INTENT(in), VALUE :: position - TYPE(vector2_), INTENT(in), VALUE :: size - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawRectangleV - - ! void ImageDrawText(Image *dst, const char *text, int posX, int posY, int fontSize, Color color) - subroutine ImageDrawText(dst, text, pos_x, pos_y, font_size, color) bind(c, name='ImageDrawText') - IMPORT :: C_CHAR, C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ImageDrawText - - ! void ImageDrawTextEx(Image *dst, Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) - subroutine ImageDrawTextEx(dst, font, text, position, font_size, spacing, tint) bind(c, name='ImageDrawTextEx') - IMPORT :: C_CHAR, C_FLOAT, color_, font_, image_, vector2_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: dst - TYPE(font_), INTENT(in), VALUE :: font - CHARACTER(kind=C_CHAR), INTENT(in) :: text - TYPE(vector2_), INTENT(in), VALUE :: position - REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size - REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing - TYPE(color_), INTENT(in), VALUE :: tint - END SUBROUTINE ImageDrawTextEx - - ! void ImageFlipHorizontal(Image *image) - SUBROUTINE ImageFlipHorizontal(image) BIND(c, name='ImageFlipHorizontal') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageFlipHorizontal - - ! void ImageFlipVertical(Image *image) - SUBROUTINE ImageFlipVertical(image) BIND(c, name='ImageFlipVertical') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageFlipVertical - - ! void ImageFormat(Image *image, int newFormat) - SUBROUTINE ImageFormat(image, new_format) BIND(c, name='ImageFormat') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: new_format - END SUBROUTINE ImageFormat - - ! Image ImageFromImage(Image image, Rectangle rec) - FUNCTION ImageFromImage(image, rec) BIND(c, name='ImageFromImage') - IMPORT :: image_, rectangle_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - TYPE(rectangle_), INTENT(in), VALUE :: rec - TYPE(image_) :: ImageFromImage - END FUNCTION ImageFromImage - - ! void ImageKernelConvolution(Image *image, float *kernel, int kernelSize) - subroutine ImageKernelConvolution(image, kernel, kernel_size) bind(c, name='ImageKernelConvolution') - IMPORT :: C_FLOAT, C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - REAL(kind=C_FLOAT), INTENT(inout) :: kernel - INTEGER(kind=C_INT), INTENT(in), VALUE :: kernel_size - END SUBROUTINE ImageKernelConvolution - - ! void ImageMipmaps(Image *image) - SUBROUTINE ImageMipmaps(image) BIND(c, name='ImageMipmaps') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageMipmaps - - ! void ImageResize(Image *image, int newWidth, int newHeight) - subroutine ImageResize(image, new_width, new_height) bind(c, name='ImageResize') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: new_width - INTEGER(kind=C_INT), INTENT(in), VALUE :: new_height - END SUBROUTINE ImageResize - - ! void ImageResizeCanvas(Image *image, int newWidth, int newHeight, int offsetX, int offsetY, Color fill) - subroutine ImageResizeCanvas(image, new_width, new_height, offset_x, offset_y, fill) bind(c, name='ImageResizeCanvas') - IMPORT :: C_INT, color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: new_width - INTEGER(kind=C_INT), INTENT(in), VALUE :: new_height - INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_y - TYPE(color_), INTENT(in), VALUE :: fill - END SUBROUTINE ImageResizeCanvas - - ! void ImageResizeNN(Image *image, int newWidth,int newHeight) - subroutine ImageResizeNN(image, new_width, new_height) bind(c, name='ImageResizeNN') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: new_width - INTEGER(kind=C_INT), INTENT(in), VALUE :: new_height - END SUBROUTINE ImageResizeNN - - ! void ImageRotate(Image *image, int degrees) - SUBROUTINE ImageRotate(image, degrees) BIND(c, name='ImageRotate') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: degrees - END SUBROUTINE ImageRotate - - ! void ImageRotateCCW(Image *image) - SUBROUTINE ImageRotateCCW(image) BIND(c, name='ImageRotateCCW') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageRotateCCW - - ! void ImageRotateCW(Image *image) - SUBROUTINE ImageRotateCW(image) BIND(c, name='ImageRotateCW') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - END SUBROUTINE ImageRotateCW - - ! Image ImageText(const char *text, int fontSize, Color color) - FUNCTION ImageText(text, font_size, color) BIND(c, name='ImageText') - IMPORT :: C_CHAR, C_INT, color_, image_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - TYPE(color_), INTENT(in), VALUE :: color - TYPE(image_) :: ImageText - END FUNCTION ImageText - - ! Image ImageTextEx(Font font, const char *text, float fontSize, float spacing, Color tint) - function ImageTextEx(font, text, font_size, spacing, tint) bind(c, name='ImageTextEx') - IMPORT :: C_CHAR, C_FLOAT, color_, font_, image_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - CHARACTER(kind=C_CHAR), INTENT(in) :: text - REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size - REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing - TYPE(color_), INTENT(in), VALUE :: tint - TYPE(image_) :: ImageTextEx - END FUNCTION ImageTextEx - - ! void ImageToPOT(Image *image, Color fill) - SUBROUTINE ImageToPOT(image, fill) BIND(c, name='ImageToPOT') - IMPORT :: color_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: image - TYPE(color_), INTENT(in), VALUE :: fill - END SUBROUTINE ImageToPOT -END INTERFACE - -END MODULE RaylibImageMethods diff --git a/src/modules/RaylibInterface/src/RaylibIsMethods.F90 b/src/modules/RaylibInterface/src/RaylibIsMethods.F90 deleted file mode 100644 index dd3f36ed3..000000000 --- a/src/modules/RaylibInterface/src/RaylibIsMethods.F90 +++ /dev/null @@ -1,419 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibIsMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: IsWindowState -PUBLIC :: IsWindowResized -PUBLIC :: IsWindowReady -PUBLIC :: IsWindowMinimized -PUBLIC :: IsWindowMaximized -PUBLIC :: IsWindowHidden -PUBLIC :: IsWindowFullscreen -PUBLIC :: IsWindowFocused -PUBLIC :: IsWaveReady -PUBLIC :: IsTextureReady -PUBLIC :: IsSoundReady -PUBLIC :: IsSoundPlaying -PUBLIC :: IsShaderReady -PUBLIC :: IsRenderTextureReady -PUBLIC :: IsPathFile -PUBLIC :: IsMusicStreamPlaying -PUBLIC :: IsMusicReady -PUBLIC :: IsMouseButtonUp -PUBLIC :: IsMouseButtonReleased -PUBLIC :: IsMouseButtonPressed -PUBLIC :: IsMouseButtonDown -PUBLIC :: IsModelReady -PUBLIC :: IsModelAnimationValid -PUBLIC :: IsMaterialReady -PUBLIC :: IsKeyUp -PUBLIC :: IsKeyReleased -PUBLIC :: IsKeyPressedRepeat -PUBLIC :: IsKeyPressed -PUBLIC :: IsKeyDown -PUBLIC :: IsImageReady -PUBLIC :: IsGestureDetected -PUBLIC :: IsGamepadButtonUp -PUBLIC :: IsGamepadButtonReleased -PUBLIC :: IsGamepadButtonPressed -PUBLIC :: IsGamepadButtonDown -PUBLIC :: IsGamepadAvailable -PUBLIC :: IsFontReady -PUBLIC :: IsFileExtension -PUBLIC :: IsFileDropped -PUBLIC :: IsCursorOnScreen -PUBLIC :: IsCursorHidden -PUBLIC :: IsAudioStreamReady -PUBLIC :: IsAudioStreamProcessed -PUBLIC :: IsAudioStreamPlaying -PUBLIC :: IsAudioDeviceReady - -INTERFACE - ! bool IsAudioDeviceReady(void) - FUNCTION IsAudioDeviceReady() BIND(c, name='IsAudioDeviceReady') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsAudioDeviceReady - END FUNCTION IsAudioDeviceReady - - ! bool IsAudioStreamPlaying(AudioStream stream) - FUNCTION IsAudioStreamPlaying(stream) BIND(c, name='IsAudioStreamPlaying') - IMPORT :: audio_stream_, C_BOOL - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - LOGICAL(kind=C_BOOL) :: IsAudioStreamPlaying - END FUNCTION IsAudioStreamPlaying - - ! bool IsAudioStreamProcessed(AudioStream stream) -FUNCTION IsAudioStreamProcessed(stream) BIND(c, name='IsAudioStreamProcessed') - IMPORT :: audio_stream_, C_BOOL - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - LOGICAL(kind=C_BOOL) :: IsAudioStreamProcessed - END FUNCTION IsAudioStreamProcessed - - ! bool IsAudioStreamReady(AudioStream stream) - FUNCTION IsAudioStreamReady(stream) BIND(c, name='IsAudioStreamReady') - IMPORT :: audio_stream_, C_BOOL - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - LOGICAL(kind=C_BOOL) :: IsAudioStreamReady - END FUNCTION IsAudioStreamReady - - ! bool IsCursorHidden(void) - FUNCTION IsCursorHidden() BIND(c, name='IsCursorHidden') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsCursorHidden - END FUNCTION IsCursorHidden - - ! bool IsCursorOnScreen(void) - FUNCTION IsCursorOnScreen() BIND(c, name='IsCursorOnScreen') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsCursorOnScreen - END FUNCTION IsCursorOnScreen - - ! bool IsFileDropped(void) - FUNCTION IsFileDropped() BIND(c, name='IsFileDropped') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsFileDropped - END FUNCTION IsFileDropped - - ! bool IsFileExtension(const char *fileName, const char *ext) - FUNCTION IsFileExtension(file_name, ext) BIND(c, name='IsFileExtension') - IMPORT :: C_BOOL, C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - CHARACTER(kind=C_CHAR), INTENT(in) :: ext - LOGICAL(kind=C_BOOL) :: IsFileExtension - END FUNCTION IsFileExtension - - ! bool IsFontReady(Font font) - FUNCTION IsFontReady(font) BIND(c, name='IsFontReady') - IMPORT :: C_BOOL, font_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - LOGICAL(kind=C_BOOL) :: IsFontReady - END FUNCTION IsFontReady - - ! bool IsGamepadAvailable(int gamepad) - FUNCTION IsGamepadAvailable(gamepad) BIND(c, name='IsGamepadAvailable') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - LOGICAL(kind=C_BOOL) :: IsGamepadAvailable - END FUNCTION IsGamepadAvailable - - ! bool IsGamepadButtonDown(int gamepad, int button) - function IsGamepadButtonDown(gamepad, button) bind(c, name='IsGamepadButtonDown') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsGamepadButtonDown - END FUNCTION IsGamepadButtonDown - - ! bool IsGamepadButtonPressed(int gamepad, int button) - function IsGamepadButtonPressed(gamepad, button) bind(c, name='IsGamepadButtonPressed') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsGamepadButtonPressed - END FUNCTION IsGamepadButtonPressed - - ! bool IsGamepadButtonReleased(int gamepad, int button) - function IsGamepadButtonReleased(gamepad, button) bind(c, name='IsGamepadButtonReleased') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsGamepadButtonReleased - END FUNCTION IsGamepadButtonReleased - - ! bool IsGamepadButtonUp(int gamepad, int button) - FUNCTION IsGamepadButtonUp(gamepad, button) BIND(c, name='IsGamepadButtonUp') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsGamepadButtonUp - END FUNCTION IsGamepadButtonUp - - ! bool IsGestureDetected(unsigned int gesture) - FUNCTION IsGestureDetected(gesture) BIND(c, name='IsGestureDetected') - IMPORT :: C_BOOL, c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: gesture - LOGICAL(kind=C_BOOL) :: IsGestureDetected - END FUNCTION IsGestureDetected - - ! bool IsImageReady(Image image) - FUNCTION IsImageReady(image) BIND(c, name='IsImageReady') - IMPORT :: C_BOOL, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - LOGICAL(kind=C_BOOL) :: IsImageReady - END FUNCTION IsImageReady - - ! bool IsKeyDown(int key) - FUNCTION IsKeyDown(key) BIND(c, name='IsKeyDown') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key - LOGICAL(kind=C_BOOL) :: IsKeyDown - END FUNCTION IsKeyDown - - ! bool IsKeyPressed(int key) - FUNCTION IsKeyPressed(key) BIND(c, name='IsKeyPressed') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key - LOGICAL(kind=C_BOOL) :: IsKeyPressed - END FUNCTION IsKeyPressed - - ! bool IsKeyPressedRepeat(int key) - FUNCTION IsKeyPressedRepeat(key) BIND(c, name='IsKeyPressedRepeat') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key - LOGICAL(kind=C_BOOL) :: IsKeyPressedRepeat - END FUNCTION IsKeyPressedRepeat - - ! bool IsKeyReleased(int key) - FUNCTION IsKeyReleased(key) BIND(c, name='IsKeyReleased') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key - LOGICAL(kind=C_BOOL) :: IsKeyReleased - END FUNCTION IsKeyReleased - - ! bool IsKeyUp(int key) - FUNCTION IsKeyUp(key) BIND(c, name='IsKeyUp') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key - LOGICAL(kind=C_BOOL) :: IsKeyUp - END FUNCTION IsKeyUp - - ! bool IsMaterialReady(Material material) - FUNCTION IsMaterialReady(material) BIND(c, name='IsMaterialReady') - IMPORT :: C_BOOL, material_ - IMPLICIT NONE - TYPE(material_), INTENT(in), VALUE :: material - LOGICAL(kind=C_BOOL) :: IsMaterialReady - END FUNCTION IsMaterialReady - - ! bool IsModelAnimationValid(Model model, ModelAnimation anim) - function IsModelAnimationValid(model, anim) bind(c, name='IsModelAnimationValid') - IMPORT :: C_BOOL, model_animation_, model_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - TYPE(model_animation_), INTENT(in), VALUE :: anim - LOGICAL(kind=C_BOOL) :: IsModelAnimationValid - END FUNCTION IsModelAnimationValid - - ! bool IsModelReady(Model model) - FUNCTION IsModelReady(model) BIND(c, name='IsModelReady') - IMPORT :: C_BOOL, model_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - LOGICAL(kind=C_BOOL) :: IsModelReady - END FUNCTION IsModelReady - - ! bool IsMouseButtonDown(int button) - FUNCTION IsMouseButtonDown(button) BIND(c, name='IsMouseButtonDown') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsMouseButtonDown - END FUNCTION IsMouseButtonDown - - ! bool IsMouseButtonPressed(int button) - FUNCTION IsMouseButtonPressed(button) BIND(c, name='IsMouseButtonPressed') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsMouseButtonPressed - END FUNCTION IsMouseButtonPressed - - ! bool IsMouseButtonReleased(int button) - FUNCTION IsMouseButtonReleased(button) BIND(c, name='IsMouseButtonReleased') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsMouseButtonReleased - END FUNCTION IsMouseButtonReleased - - ! bool IsMouseButtonUp(int button) - FUNCTION IsMouseButtonUp(button) BIND(c, name='IsMouseButtonUp') - IMPORT :: C_BOOL, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: button - LOGICAL(kind=C_BOOL) :: IsMouseButtonUp - END FUNCTION IsMouseButtonUp - - ! bool IsMusicReady(Music music) - FUNCTION IsMusicReady(music) BIND(c, name='IsMusicReady') - IMPORT :: C_BOOL, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - LOGICAL(kind=C_BOOL) :: IsMusicReady - END FUNCTION IsMusicReady - - ! bool IsMusicStreamPlaying(Music music) - FUNCTION IsMusicStreamPlaying(music) BIND(c, name='IsMusicStreamPlaying') - IMPORT :: C_BOOL, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - LOGICAL(kind=C_BOOL) :: IsMusicStreamPlaying - END FUNCTION IsMusicStreamPlaying - - ! bool IsPathFile(const char *path) - FUNCTION IsPathFile(path) BIND(c, name='IsPathFile') - IMPORT :: C_BOOL, C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: path - LOGICAL(kind=C_BOOL) :: IsPathFile - END FUNCTION IsPathFile - - ! bool IsRenderTextureReady(RenderTexture2D target) - FUNCTION IsRenderTextureReady(TARGET) BIND(c, name='IsRenderTextureReady') - IMPORT :: C_BOOL, render_texture2d_ - IMPLICIT NONE - TYPE(render_texture2d_), INTENT(in), VALUE :: TARGET - LOGICAL(kind=C_BOOL) :: IsRenderTextureReady - END FUNCTION IsRenderTextureReady - - ! bool IsShaderReady(Shader shader) - FUNCTION IsShaderReady(shader) BIND(c, name='IsShaderReady') - IMPORT :: C_BOOL, shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - LOGICAL(kind=C_BOOL) :: IsShaderReady - END FUNCTION IsShaderReady - - ! bool IsSoundPlaying(Sound sound) - FUNCTION IsSoundPlaying(sound) BIND(c, name='IsSoundPlaying') - IMPORT :: C_BOOL, sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - LOGICAL(kind=C_BOOL) :: IsSoundPlaying - END FUNCTION IsSoundPlaying - - ! bool IsSoundReady(Sound sound) - FUNCTION IsSoundReady(sound) BIND(c, name='IsSoundReady') - IMPORT :: C_BOOL, sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - LOGICAL(kind=C_BOOL) :: IsSoundReady - END FUNCTION IsSoundReady - - ! bool IsTextureReady(Texture2D texture) - FUNCTION IsTextureReady(texture) BIND(c, name='IsTextureReady') - IMPORT :: C_BOOL, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - LOGICAL(kind=C_BOOL) :: IsTextureReady - END FUNCTION IsTextureReady - - ! bool IsWaveReady(Wave wave) - FUNCTION IsWaveReady(wave) BIND(c, name='IsWaveReady') - IMPORT :: C_BOOL, wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in), VALUE :: wave - LOGICAL(kind=C_BOOL) :: IsWaveReady - END FUNCTION IsWaveReady - - ! bool IsWindowFocused(void) - FUNCTION IsWindowFocused() BIND(c, name='IsWindowFocused') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsWindowFocused - END FUNCTION IsWindowFocused - - ! bool IsWindowFullscreen(void) - FUNCTION IsWindowFullscreen() BIND(c, name='IsWindowFullscreen') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsWindowFullscreen - END FUNCTION IsWindowFullscreen - - ! bool IsWindowHidden(void) - FUNCTION IsWindowHidden() BIND(c, name='IsWindowHidden') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsWindowHidden - END FUNCTION IsWindowHidden - - ! bool IsWindowMaximized(void) - FUNCTION IsWindowMaximized() BIND(c, name='IsWindowMaximized') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsWindowMaximized - END FUNCTION IsWindowMaximized - - ! bool IsWindowMinimized(void) - FUNCTION IsWindowMinimized() BIND(c, name='IsWindowMinimized') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsWindowMinimized - END FUNCTION IsWindowMinimized - - ! bool IsWindowReady(void) - FUNCTION IsWindowReady() BIND(c, name='IsWindowReady') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsWindowReady - END FUNCTION IsWindowReady - - ! bool IsWindowResized(void) - FUNCTION IsWindowResized() BIND(c, name='IsWindowResized') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: IsWindowResized - END FUNCTION IsWindowResized - - ! bool IsWindowState(unsigned int flag) - FUNCTION IsWindowState(flag) BIND(c, name='IsWindowState') - IMPORT :: C_BOOL, c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flag - LOGICAL(kind=C_BOOL) :: IsWindowState - END FUNCTION IsWindowState -END INTERFACE - -END MODULE RaylibIsMethods diff --git a/src/modules/RaylibInterface/src/RaylibLoadMethods.F90 b/src/modules/RaylibInterface/src/RaylibLoadMethods.F90 deleted file mode 100644 index 6e5c34e77..000000000 --- a/src/modules/RaylibInterface/src/RaylibLoadMethods.F90 +++ /dev/null @@ -1,450 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibLoadMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: LoadWaveSamples -PUBLIC :: LoadWaveFromMemory -PUBLIC :: LoadWave -PUBLIC :: LoadVrStereoConfig -PUBLIC :: LoadUTF8 -PUBLIC :: LoadTextureFromImage -PUBLIC :: LoadTextureCubemap -PUBLIC :: LoadTexture -PUBLIC :: LoadSoundFromWave -PUBLIC :: LoadSoundAlias -PUBLIC :: LoadSound -PUBLIC :: LoadShaderFromMemory -PUBLIC :: LoadShader -PUBLIC :: LoadRenderTexture -PUBLIC :: LoadRandomSequence -PUBLIC :: LoadMusicStreamFromMemory -PUBLIC :: LoadMusicStream -PUBLIC :: LoadModelFromMesh -PUBLIC :: LoadModelAnimations -PUBLIC :: LoadModel -PUBLIC :: LoadMaterials -PUBLIC :: LoadMaterialDefault -PUBLIC :: LoadImageSvg -PUBLIC :: LoadImageRaw -PUBLIC :: LoadImagePalette -PUBLIC :: LoadImageFromTexture -PUBLIC :: LoadImageFromScreen -PUBLIC :: LoadImageFromMemory -PUBLIC :: LoadImageColors -PUBLIC :: LoadImageAnim -PUBLIC :: LoadImage -PUBLIC :: LoadFontFromMemory -PUBLIC :: LoadFontFromImage -PUBLIC :: LoadFontEx -PUBLIC :: LoadFontData -PUBLIC :: LoadFont -PUBLIC :: LoadFileText -PUBLIC :: LoadFileData -PUBLIC :: LoadDroppedFiles -PUBLIC :: LoadDirectoryFilesEx -PUBLIC :: LoadDirectoryFiles -PUBLIC :: LoadCodepoints -PUBLIC :: LoadAudioStream - -INTERFACE - ! AudioStream LoadAudioStream(unsigned int sampleRate, unsigned int sampleSize, unsigned int channels) - function LoadAudioStream(sample_rate, sample_size, channels) bind(c, name='LoadAudioStream') - IMPORT :: audio_stream_, c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: sample_rate - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: sample_size - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: channels - TYPE(audio_stream_) :: LoadAudioStream - END FUNCTION LoadAudioStream - - ! int *LoadCodepoints(const char *text, int *count) - FUNCTION LoadCodepoints(text, count) BIND(c, name='LoadCodepoints') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(out) :: count - TYPE(C_PTR) :: LoadCodepoints - END FUNCTION LoadCodepoints - - ! FilePathList LoadDirectoryFiles(const char *dirPath) - FUNCTION LoadDirectoryFiles(dir_path) BIND(c, name='LoadDirectoryFiles') - IMPORT :: C_CHAR, file_path_list_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: dir_path - TYPE(file_path_list_) :: LoadDirectoryFiles - END FUNCTION LoadDirectoryFiles - - ! FilePathList LoadDirectoryFilesEx(const char *basePath, const char *filter, bool scanSubdirs) - function LoadDirectoryFilesEx(base_path, filter, scan_subdirs) bind(c, name='LoadDirectoryFilesEx') - IMPORT :: C_BOOL, C_CHAR, file_path_list_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: base_path - CHARACTER(kind=C_CHAR), INTENT(in) :: filter - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: scan_subdirs - TYPE(file_path_list_) :: LoadDirectoryFilesEx - END FUNCTION LoadDirectoryFilesEx - - ! FilePathList LoadDroppedFiles(void) - FUNCTION LoadDroppedFiles() BIND(c, name='LoadDroppedFiles') - IMPORT :: file_path_list_ - IMPLICIT NONE - TYPE(file_path_list_) :: LoadDroppedFiles - END FUNCTION LoadDroppedFiles - - ! unsigned char *LoadFileData(const char *fileName, int *dataSize) - FUNCTION LoadFileData(file_name, data_size) BIND(c, name='LoadFileData') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_INT), INTENT(out) :: data_size - TYPE(C_PTR) :: LoadFileData - END FUNCTION LoadFileData - - ! char *LoadFileText(const char *fileName) - FUNCTION LoadFileText(file_name) BIND(c, name='LoadFileText') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(C_PTR) :: LoadFileText - END FUNCTION LoadFileText - - ! Font LoadFont(const char *fileName) - FUNCTION LoadFont(file_name) BIND(c, name='LoadFont') - IMPORT :: C_CHAR, font_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(font_) :: LoadFont - END FUNCTION LoadFont - - ! GlyphInfo *LoadFontData(const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount, int type) - function LoadFontData(file_data, data_size, font_size, codepoints, codepoints_count, type) & - BIND(c, name='LoadFontData') - IMPORT :: C_INT, C_PTR, c_unsigned_char, glyph_info_ - IMPLICIT NONE - INTEGER(kind=c_unsigned_char), INTENT(inout) :: file_data - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoints_count - INTEGER(kind=C_INT), INTENT(in), VALUE :: TYPE - TYPE(C_PTR) :: LoadFontData - END FUNCTION LoadFontData - - ! Font LoadFontEx(const char *fileName, int fontSize, int *codepoints, int codepointsCount) - function LoadFontEx(file_name, font_size, codepoints, codepoints_count) bind(c, name='LoadFontEx') - IMPORT :: C_CHAR, C_INT, font_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoints_count - TYPE(font_) :: LoadFontEx - END FUNCTION LoadFontEx - - ! Font LoadFontFromImage(Image image, Color key, int firstChar) - function LoadFontFromImage(image, key, first_char) bind(c, name='LoadFontFromImage') - IMPORT :: C_INT, color_, font_, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - TYPE(color_), INTENT(in), VALUE :: key - INTEGER(kind=C_INT), INTENT(in), VALUE :: first_char - TYPE(font_) :: LoadFontFromImage - END FUNCTION LoadFontFromImage - - ! Font LoadFontFromMemory(const char *fileType, const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount) - function LoadFontFromMemory(file_, file_data, data_size, font_size, codepoints, codepoints_count) & - BIND(c, name='LoadFontFromMemory') - IMPORT :: C_CHAR, C_INT, c_unsigned_char, font_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_ - INTEGER(kind=c_unsigned_char), INTENT(in) :: file_data - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoints_count - TYPE(font_) :: LoadFontFromMemory - END FUNCTION LoadFontFromMemory - - ! Image LoadImage(const char *fileName) - FUNCTION LoadImage(file_name) BIND(c, name='LoadImage') - IMPORT :: C_CHAR, image_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(image_) :: LoadImage - END FUNCTION LoadImage - - ! Image LoadImageAnim(const char *fileName, int *frames) - FUNCTION LoadImageAnim(file_name, frames) BIND(c, name='LoadImageAnim') - IMPORT :: C_CHAR, C_INT, image_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_INT), INTENT(out) :: frames - TYPE(image_) :: LoadImageAnim - END FUNCTION LoadImageAnim - - ! Color *LoadImageColors(Image image) - FUNCTION LoadImageColors(image) BIND(c, name='LoadImageColors') - IMPORT :: C_PTR, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - TYPE(C_PTR) :: LoadImageColors - END FUNCTION LoadImageColors - - ! Image LoadImageFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) - function LoadImageFromMemory(file_, file_data, data_size) bind(c, name='LoadImageFromMemory') - IMPORT :: C_CHAR, C_INT, c_unsigned_char, image_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_ - INTEGER(kind=c_unsigned_char), INTENT(in) :: file_data - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - TYPE(image_) :: LoadImageFromMemory - END FUNCTION LoadImageFromMemory - - ! Image LoadImageFromScreen(void) - FUNCTION LoadImageFromScreen() BIND(c, name='LoadImageFromScreen') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_) :: LoadImageFromScreen - END FUNCTION LoadImageFromScreen - - ! Image LoadImageFromTexture(Texture2D texture) - FUNCTION LoadImageFromTexture(texture) BIND(c, name='LoadImageFromTexture') - IMPORT :: image_, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(image_) :: LoadImageFromTexture - END FUNCTION LoadImageFromTexture - - ! Color *LoadImagePalette(Image image, int maxPaletteSize, int *colorCount) - function LoadImagePalette(image, max_palette_size, color_count) bind(c, name='LoadImagePalette') - IMPORT :: C_INT, C_PTR, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: max_palette_size - INTEGER(kind=C_INT), INTENT(out) :: color_count - TYPE(C_PTR) :: LoadImagePalette - END FUNCTION LoadImagePalette - - ! Image LoadImageRaw(const char *fileName, int width, int height, int format, int headerSize) - function LoadImageRaw(file_name, width, height, format, header_size) bind(c, name='LoadImageRaw') - IMPORT :: C_CHAR, C_INT, image_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT - INTEGER(kind=C_INT), INTENT(in), VALUE :: header_size - TYPE(image_) :: LoadImageRaw - END FUNCTION LoadImageRaw - - ! Image LoadImageSvg(const char *fileNameOrString, int width, int height) - function LoadImageSvg(file_name_or_string, width, height) bind(c, name='LoadImageSvg') - IMPORT :: C_CHAR, C_INT, image_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name_or_string - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(image_) :: LoadImageSvg - END FUNCTION LoadImageSvg - - ! Material LoadMaterialDefault(void) - FUNCTION LoadMaterialDefault() BIND(c, name='LoadMaterialDefault') - IMPORT :: material_ - IMPLICIT NONE - TYPE(material_) :: LoadMaterialDefault - END FUNCTION LoadMaterialDefault - - ! Material *LoadMaterials(const char *fileName, int *materialCount) - function LoadMaterials(file_name, material_count) bind(c, name='LoadMaterials') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_INT), INTENT(out) :: material_count - TYPE(C_PTR) :: LoadMaterials - END FUNCTION LoadMaterials - - ! Model LoadModel(const char *fileName) - FUNCTION LoadModel(file_name) BIND(c, name='LoadModel') - IMPORT :: C_CHAR, model_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(model_) :: LoadModel - END FUNCTION LoadModel - - ! ModelAnimation *LoadModelAnimations(const char *fileName, int *animCount) - function LoadModelAnimations(file_name, anim_count) bind(c, name='LoadModelAnimations') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - INTEGER(kind=C_INT), INTENT(out) :: anim_count - TYPE(C_PTR) :: LoadModelAnimations - END FUNCTION LoadModelAnimations - - ! Model LoadModelFromMesh(Mesh mesh) - FUNCTION LoadModelFromMesh(mesh) BIND(c, name='LoadModelFromMesh') - IMPORT :: mesh_, model_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in), VALUE :: mesh - TYPE(model_) :: LoadModelFromMesh - END FUNCTION LoadModelFromMesh - - ! Music LoadMusicStream(const char *fileName) - FUNCTION LoadMusicStream(file_name) BIND(c, name='LoadMusicStream') - IMPORT :: C_CHAR, music_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(music_) :: LoadMusicStream - END FUNCTION LoadMusicStream - - ! Music LoadMusicStreamFromMemory(const char *fileType, const unsigned char *data, int dataSize) - function LoadMusicStreamFromMemory(file_, data, data_size) bind(c, name='LoadMusicStreamFromMemory') - IMPORT :: C_CHAR, C_INT, c_unsigned_char, music_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_ - INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - TYPE(music_) :: LoadMusicStreamFromMemory - END FUNCTION LoadMusicStreamFromMemory - - ! int *LoadRandomSequence(unsigned int count, int min, int max) - function LoadRandomSequence(count, min, max) bind(c, name='LoadRandomSequence') - IMPORT :: C_INT, C_PTR, c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: count - INTEGER(kind=C_INT), INTENT(in), VALUE :: min - INTEGER(kind=C_INT), INTENT(in), VALUE :: max - TYPE(C_PTR) :: LoadRandomSequence - END FUNCTION LoadRandomSequence - - ! RenderTexture2D LoadRenderTexture(int width, int height) - FUNCTION LoadRenderTexture(width, height) BIND(c, name='LoadRenderTexture') - IMPORT :: C_INT, render_texture2d_ - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - TYPE(render_texture2d_) :: LoadRenderTexture - END FUNCTION LoadRenderTexture - - ! Shader LoadShader(const char *vsFileName, const char *fsFileName) - FUNCTION LoadShader(vs_file_name, fs_file_name) BIND(c, name='LoadShader') - IMPORT :: C_CHAR, shader_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: vs_file_name - CHARACTER(kind=C_CHAR), INTENT(in) :: fs_file_name - TYPE(shader_) :: LoadShader - END FUNCTION LoadShader - - ! Shader LoadShaderFromMemory(const char *vsCode, const char *fsCode) - function LoadShaderFromMemory(vs_code, fs_code) bind(c, name='LoadShaderFromMemory') - IMPORT :: C_CHAR, shader_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: vs_code - CHARACTER(kind=C_CHAR), INTENT(in) :: fs_code - TYPE(shader_) :: LoadShaderFromMemory - END FUNCTION LoadShaderFromMemory - - ! Sound LoadSound(const char *fileName) - FUNCTION LoadSound(file_name) BIND(c, name='LoadSound') - IMPORT :: C_CHAR, sound_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(sound_) :: LoadSound - END FUNCTION LoadSound - - ! Sound LoadSoundAlias(Sound source) - FUNCTION LoadSoundAlias(source) BIND(c, name='LoadSoundAlias') - IMPORT :: sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: source - TYPE(sound_) :: LoadSoundAlias - END FUNCTION LoadSoundAlias - - ! Sound LoadSoundFromWave(Wave wave) - FUNCTION LoadSoundFromWave(wave) BIND(c, name='LoadSoundFromWave') - IMPORT :: sound_, wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in), VALUE :: wave - TYPE(sound_) :: LoadSoundFromWave - END FUNCTION LoadSoundFromWave - - ! Texture2D LoadTexture(const char *fileName) - FUNCTION LoadTexture(file_name) BIND(c, name='LoadTexture') - IMPORT :: C_CHAR, texture2d_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(texture2d_) :: LoadTexture - END FUNCTION LoadTexture - - ! TextureCubemap LoadTextureCubemap(Image image, int layout) - FUNCTION LoadTextureCubemap(image, layout) BIND(c, name='LoadTextureCubemap') - IMPORT :: C_INT, image_, texture_cubemap_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - INTEGER(kind=C_INT), INTENT(in), VALUE :: layout - TYPE(texture_cubemap_) :: LoadTextureCubemap - END FUNCTION LoadTextureCubemap - - ! Texture2D LoadTextureFromImage(Image image) - FUNCTION LoadTextureFromImage(image) BIND(c, name='LoadTextureFromImage') - IMPORT :: image_, texture2d_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - TYPE(texture2d_) :: LoadTextureFromImage - END FUNCTION LoadTextureFromImage - - ! char *LoadUTF8(const int *codepoints, int length) - FUNCTION LoadUTF8(codepoints, length) BIND(c, name='LoadUTF8') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(out) :: codepoints(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: length - TYPE(C_PTR) :: LoadUTF8 - END FUNCTION LoadUTF8 - - ! VrStereoConfig LoadVrStereoConfig(VrDeviceInfo device) - FUNCTION LoadVrStereoConfig(device) BIND(c, name='LoadVrStereoConfig') - IMPORT :: vr_device_info_, vr_stereo_config_ - IMPLICIT NONE - TYPE(vr_device_info_), INTENT(in), VALUE :: device - TYPE(vr_stereo_config_) :: LoadVrStereoConfig - END FUNCTION LoadVrStereoConfig - - ! Wave LoadWave(const char *fileName) - FUNCTION LoadWave(file_name) BIND(c, name='LoadWave') - IMPORT :: C_CHAR, wave_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(wave_) :: LoadWave - END FUNCTION LoadWave - - ! Wave LoadWaveFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) - function LoadWaveFromMemory(file_, file_data, data_size) bind(c, name='LoadWaveFromMemory') - IMPORT :: C_CHAR, C_INT, c_unsigned_char, wave_ - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_ - INTEGER(kind=c_unsigned_char), INTENT(in) :: file_data - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - TYPE(wave_) :: LoadWaveFromMemory - END FUNCTION LoadWaveFromMemory - - ! float *LoadWaveSamples(Wave wave) - FUNCTION LoadWaveSamples(wave) BIND(c, name='LoadWaveSamples') - IMPORT :: C_PTR, wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in), VALUE :: wave - TYPE(C_PTR) :: LoadWaveSamples - END FUNCTION LoadWaveSamples -END INTERFACE - -END MODULE RaylibLoadMethods diff --git a/src/modules/RaylibInterface/src/RaylibMath.F90 b/src/modules/RaylibInterface/src/RaylibMath.F90 deleted file mode 100644 index 5353f951c..000000000 --- a/src/modules/RaylibInterface/src/RaylibMath.F90 +++ /dev/null @@ -1,1140 +0,0 @@ -! raylib_math.f90 -! -! Fortran 2018 interface bindings to `raymath.h`. -! -! Author: Philipp Engel -! Licence: ISC -MODULE raylib_math -USE, INTRINSIC :: ISO_C_BINDING -USE :: raylib -IMPLICIT NONE(TYPE, EXTERNAL) -PRIVATE - -! float3 -TYPE, BIND(c), PUBLIC :: float3_ - REAL(kind=C_FLOAT) :: v(0:2) = 0.0 -END TYPE float3_ - -! float16 -TYPE, BIND(c), PUBLIC :: float16_ - REAL(kind=C_FLOAT) :: v(0:15) = 0.0 -END TYPE float16_ - -PUBLIC :: clamp -PUBLIC :: float_equals -PUBLIC :: lerp -PUBLIC :: matrix_add -PUBLIC :: matrix_determinant -PUBLIC :: matrix_frustum -PUBLIC :: matrix_identity -PUBLIC :: matrix_invert -PUBLIC :: matrix_look_at -PUBLIC :: matrix_multiply -PUBLIC :: matrix_ortho -PUBLIC :: matrix_perspective -PUBLIC :: matrix_rotate -PUBLIC :: matrix_rotate_x -PUBLIC :: matrix_rotate_xyz -PUBLIC :: matrix_rotate_y -PUBLIC :: matrix_rotate_z -PUBLIC :: matrix_rotate_zyx -PUBLIC :: matrix_scale -PUBLIC :: matrix_subtract -PUBLIC :: matrix_to_float_v -PUBLIC :: matrix_trace -PUBLIC :: matrix_translate -PUBLIC :: matrix_transpose -PUBLIC :: normalize -PUBLIC :: quaternion_add -PUBLIC :: quaternion_add_value -PUBLIC :: quaternion_divide -PUBLIC :: quaternion_equals -PUBLIC :: quaternion_from_axis_angle -PUBLIC :: quaternion_from_euler -PUBLIC :: quaternion_from_matrix -PUBLIC :: quaternion_from_vector3_to_vector3 -PUBLIC :: quaternion_identity -PUBLIC :: quaternion_invert -PUBLIC :: quaternion_length -PUBLIC :: quaternion_lerp -PUBLIC :: quaternion_multiply -PUBLIC :: quaternion_nlerp -PUBLIC :: quaternion_normalize -PUBLIC :: quaternion_scale -PUBLIC :: quaternion_slerp -PUBLIC :: quaternion_subtract -PUBLIC :: quaternion_subtract_value -PUBLIC :: quaternion_to_axis_angle -PUBLIC :: quaternion_to_euler -PUBLIC :: quaternion_to_matrix -PUBLIC :: quaternion_transform -PUBLIC :: remap -PUBLIC :: vector2_add -PUBLIC :: vector2_add_value -PUBLIC :: vector2_angle -PUBLIC :: vector2_clamp -PUBLIC :: vector2_clamp_value -PUBLIC :: vector2_distance -PUBLIC :: vector2_distance_sqr -PUBLIC :: vector2_divide -PUBLIC :: vector2_dot_product -PUBLIC :: vector2_equals -PUBLIC :: vector2_invert -PUBLIC :: vector2_length -PUBLIC :: vector2_length_sqr -PUBLIC :: vector2_lerp -PUBLIC :: vector2_line_angle -PUBLIC :: vector2_move_towards -PUBLIC :: vector2_multiply -PUBLIC :: vector2_negate -PUBLIC :: vector2_normalize -PUBLIC :: vector2_one -PUBLIC :: vector2_reflect -PUBLIC :: vector2_rotate -PUBLIC :: vector2_scale -PUBLIC :: vector2_subtract -PUBLIC :: vector2_subtract_value -PUBLIC :: vector2_transform -PUBLIC :: vector2_zero -PUBLIC :: vector3_add -PUBLIC :: vector3_add_value -PUBLIC :: vector3_angle -PUBLIC :: vector3_barycenter -PUBLIC :: vector3_clamp -PUBLIC :: vector3_clamp_value -PUBLIC :: vector3_cross_product -PUBLIC :: vector3_distance -PUBLIC :: vector3_distance_sqr -PUBLIC :: vector3_divide -PUBLIC :: vector3_dot_product -PUBLIC :: vector3_equals -PUBLIC :: vector3_invert -PUBLIC :: vector3_length -PUBLIC :: vector3_length_sqr -PUBLIC :: vector3_lerp -PUBLIC :: vector3_max -PUBLIC :: vector3_min -PUBLIC :: vector3_multiply -PUBLIC :: vector3_negate -PUBLIC :: vector3_normalize -PUBLIC :: vector3_one -PUBLIC :: vector3_ortho_normalize -PUBLIC :: vector3_perpendicular -PUBLIC :: vector3_reflect -PUBLIC :: vector3_refract -PUBLIC :: vector3_rotate_by_axis_angle -PUBLIC :: vector3_rotate_by_quaternion -PUBLIC :: vector3_scale -PUBLIC :: vector3_subtract -PUBLIC :: vector3_subtract_value -PUBLIC :: vector3_to_float_v -PUBLIC :: vector3_transform -PUBLIC :: vector3_unproject -PUBLIC :: vector3_zero -PUBLIC :: wrap - -INTERFACE - ! float Clamp(float value, float min, float max) - FUNCTION clamp(VALUE, min, max) BIND(c, name='Clamp') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: min - REAL(kind=C_FLOAT), INTENT(in), VALUE :: max - REAL(kind=C_FLOAT) :: clamp - END FUNCTION clamp - - ! int FloatEquals(float x, float y) - FUNCTION float_equals(x, y) BIND(c, name='FloatEquals') - IMPORT :: C_FLOAT, C_INT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: x - REAL(kind=C_FLOAT), INTENT(in), VALUE :: y - INTEGER(kind=C_INT) :: float_equals - END FUNCTION float_equals - - ! float Lerp(float start, float end, float amount) - FUNCTION lerp(start, END, amount) BIND(c, name='Lerp') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start - REAL(kind=C_FLOAT), INTENT(in), VALUE :: END - REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount - REAL(kind=C_FLOAT) :: lerp - END FUNCTION lerp - - ! Matrix MatrixAdd(Matrix left, Matrix right) - FUNCTION matrix_add(left, right) BIND(c, name='MatrixAdd') - IMPORT :: matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: left - TYPE(matrix_), INTENT(in), VALUE :: right - TYPE(matrix_) :: matrix_add - END FUNCTION matrix_add - - ! float MatrixDeterminant(Matrix mat) - FUNCTION matrix_determinant(mat) BIND(c, name='MatrixDeterminant') - IMPORT :: C_FLOAT, matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: mat - REAL(kind=C_FLOAT) :: matrix_determinant - END FUNCTION matrix_determinant - - ! Matrix MatrixFrustum(double left, double right, double bottom, double top, double near, double far) - function matrix_frustum(left, right, bottom, top, near, far) bind(c, name='MatrixFrustum') - IMPORT :: C_DOUBLE, matrix_ - IMPLICIT NONE - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: left - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: right - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: bottom - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: top - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: near - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: far - TYPE(matrix_) :: matrix_frustum - END FUNCTION matrix_frustum - - ! Matrix MatrixIdentity(void) - FUNCTION matrix_identity() BIND(c, name='MatrixIdentity') - IMPORT :: matrix_ - IMPLICIT NONE - TYPE(matrix_) :: matrix_identity - END FUNCTION matrix_identity - - ! Matrix MatrixInvert(Matrix mat) - FUNCTION matrix_invert(mat) BIND(c, name='MatrixInvert') - IMPORT :: matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: mat - TYPE(matrix_) :: matrix_invert - END FUNCTION matrix_invert - - ! Matrix MatrixLookAt(Vector3 eye, Vector3 target, Vector3 up) - FUNCTION matrix_look_at(eye, TARGET, up) BIND(c, name='MatrixLookAt') - IMPORT :: matrix_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: eye - TYPE(vector3_), INTENT(in), VALUE :: TARGET - TYPE(vector3_), INTENT(in), VALUE :: up - TYPE(matrix_) :: matrix_look_at - END FUNCTION matrix_look_at - - ! Matrix MatrixMultiply(Matrix left, Matrix right) - FUNCTION matrix_multiply(left, right) BIND(c, name='MatrixMultiply') - IMPORT :: matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: left - TYPE(matrix_), INTENT(in), VALUE :: right - TYPE(matrix_) :: matrix_multiply - END FUNCTION matrix_multiply - - ! Matrix MatrixOrtho(double left, double right, double bottom, double top, double near, double far) - function matrix_ortho(left, right, bottom, top, near, far) bind(c, name='MatrixOrtho') - IMPORT :: C_DOUBLE, matrix_ - IMPLICIT NONE - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: left - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: right - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: bottom - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: top - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: near - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: far - TYPE(matrix_) :: matrix_ortho - END FUNCTION matrix_ortho - - ! Matrix MatrixPerspective(double fovy, double aspect, double near, double far) - function matrix_perspective(fovy, aspect, near, far) bind(c, name='MatrixPerspective') - IMPORT :: C_DOUBLE, matrix_ - IMPLICIT NONE - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: fovy - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: aspect - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: near - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: far - TYPE(matrix_) :: matrix_perspective - END FUNCTION matrix_perspective - - ! Matrix MatrixRotate(Vector3 axis, float angle) - FUNCTION matrix_rotate(axis, angle) BIND(c, name='MatrixRotate') - IMPORT :: C_FLOAT, matrix_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: axis - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - TYPE(matrix_) :: matrix_rotate - END FUNCTION matrix_rotate - - ! Matrix MatrixRotateX(float angle) - FUNCTION matrix_rotate_x(angle) BIND(c, name='MatrixRotateX') - IMPORT :: C_FLOAT, matrix_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - TYPE(matrix_) :: matrix_rotate_x - END FUNCTION matrix_rotate_x - - ! Matrix MatrixRotateXYZ(Vector3 angle) - FUNCTION matrix_rotate_xyz(angle) BIND(c, name='MatrixRotateXYZ') - IMPORT :: matrix_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: angle - TYPE(matrix_) :: matrix_rotate_xyz - END FUNCTION matrix_rotate_xyz - - ! Matrix MatrixRotateY(float angle) - FUNCTION matrix_rotate_y(angle) BIND(c, name='MatrixRotateY') - IMPORT :: C_FLOAT, matrix_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - TYPE(matrix_) :: matrix_rotate_y - END FUNCTION matrix_rotate_y - - ! Matrix MatrixRotateZ(float angle) - FUNCTION matrix_rotate_z(angle) BIND(c, name='MatrixRotateZ') - IMPORT :: C_FLOAT, matrix_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - TYPE(matrix_) :: matrix_rotate_z - END FUNCTION matrix_rotate_z - - ! Matrix MatrixRotateZYX(Vector3 angle) - FUNCTION matrix_rotate_zyx(angle) BIND(c, name='MatrixRotateZYX') - IMPORT :: matrix_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: angle - TYPE(matrix_) :: matrix_rotate_zyx - END FUNCTION matrix_rotate_zyx - - ! Matrix MatrixScale(float x, float y, float z) - FUNCTION matrix_scale(x, y, z) BIND(c, name='MatrixScale') - IMPORT :: C_FLOAT, matrix_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: x - REAL(kind=C_FLOAT), INTENT(in), VALUE :: y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: z - TYPE(matrix_) :: matrix_scale - END FUNCTION matrix_scale - - ! Matrix MatrixSubtract(Matrix left, Matrix right) - FUNCTION matrix_subtract(left, right) BIND(c, name='MatrixSubtract') - IMPORT :: matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: left - TYPE(matrix_), INTENT(in), VALUE :: right - TYPE(matrix_) :: matrix_subtract - END FUNCTION matrix_subtract - - ! float16 MatrixToFloatV(Matrix mat) - FUNCTION matrix_to_float_v(mat) BIND(c, name='MatrixToFloatV') - IMPORT :: float16_, matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: mat - TYPE(float16_) :: matrix_to_float_v - END FUNCTION matrix_to_float_v - - ! float MatrixTrace(Matrix mat) - FUNCTION matrix_trace(mat) BIND(c, name='MatrixTrace') - IMPORT :: C_FLOAT, matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: mat - REAL(kind=C_FLOAT) :: matrix_trace - END FUNCTION matrix_trace - - ! Matrix MatrixTranslate(float x, float y, float z) - FUNCTION matrix_translate(x, y, z) BIND(c, name='MatrixTranslate') - IMPORT :: C_FLOAT, matrix_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: x - REAL(kind=C_FLOAT), INTENT(in), VALUE :: y - REAL(kind=C_FLOAT), INTENT(in), VALUE :: z - TYPE(matrix_) :: matrix_translate - END FUNCTION matrix_translate - - ! Matrix MatrixTranspose(Matrix mat) - FUNCTION matrix_transpose(mat) BIND(c, name='MatrixTranspose') - IMPORT :: matrix_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: mat - TYPE(matrix_) :: matrix_transpose - END FUNCTION matrix_transpose - - ! float Normalize(float value, float start, float end) - FUNCTION normalize(VALUE, start, END) BIND(c, name='Normalize') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: start - REAL(kind=C_FLOAT), INTENT(in), VALUE :: END - REAL(kind=C_FLOAT) :: normalize - END FUNCTION normalize - - ! Quaternion QuaternionAdd(Quaternion q1, Quaternion q2) - FUNCTION quaternion_add(q1, q2) BIND(c, name='QuaternionAdd') - IMPORT :: quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q1 - TYPE(quaternion_), INTENT(in), VALUE :: q2 - TYPE(quaternion_) :: quaternion_add - END FUNCTION quaternion_add - - ! Quaternion QuaternionAddValue(Quaternion q, float add) - FUNCTION quaternion_add_value(q, add) BIND(c, name='QuaternionAddValue') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - REAL(kind=C_FLOAT), INTENT(in), VALUE :: add - TYPE(quaternion_) :: quaternion_add_value - END FUNCTION quaternion_add_value - - ! Quaternion QuaternionDivide(Quaternion q1, Quaternion q2) - FUNCTION quaternion_divide(q1, q2) BIND(c, name='QuaternionDivide') - IMPORT :: quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q1 - TYPE(quaternion_), INTENT(in), VALUE :: q2 - TYPE(quaternion_) :: quaternion_divide - END FUNCTION quaternion_divide - - ! int QuaternionEquals(Quaternion p, Quaternion q) - FUNCTION quaternion_equals(p, q) BIND(c, name='QuaternionEquals') - IMPORT :: C_INT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: p - TYPE(quaternion_), INTENT(in), VALUE :: q - INTEGER(kind=C_INT) :: quaternion_equals - END FUNCTION quaternion_equals - - ! Quaternion QuaternionFromAxisAngle(Vector3 axis, float angle) - function quaternion_from_axis_angle(axis, angle) bind(c, name='QuaternionFromAxisAngle') - IMPORT :: C_FLOAT, quaternion_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: axis - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - TYPE(quaternion_) :: quaternion_from_axis_angle - END FUNCTION quaternion_from_axis_angle - - ! Quaternion QuaternionFromEuler(float pitch, float yaw, float roll) - function quaternion_from_euler(pitch, yaw, roll) bind(c, name='QuaternionFromEuler') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch - REAL(kind=C_FLOAT), INTENT(in), VALUE :: yaw - REAL(kind=C_FLOAT), INTENT(in), VALUE :: roll - TYPE(quaternion_) :: quaternion_from_euler - END FUNCTION quaternion_from_euler - - ! Quaternion QuaternionFromMatrix(Matrix mat) - FUNCTION quaternion_from_matrix(mat) BIND(c, name='QuaternionFromMatrix') - IMPORT :: matrix_, quaternion_ - IMPLICIT NONE - TYPE(matrix_), INTENT(in), VALUE :: mat - TYPE(quaternion_) :: quaternion_from_matrix - END FUNCTION quaternion_from_matrix - - ! Quaternion QuaternionFromVector3ToVector3(Vector3 from, Vector3 to) - function quaternion_from_vector3_to_vector3(from, to) bind(c, name='QuaternionFromVector3ToVector3') - IMPORT :: quaternion_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: from - TYPE(vector3_), INTENT(in), VALUE :: to - TYPE(quaternion_) :: quaternion_from_vector3_to_vector3 - END FUNCTION quaternion_from_vector3_to_vector3 - - ! Quaternion QuaternionIdentity(void) - FUNCTION quaternion_identity() BIND(c, name='QuaternionIdentity') - IMPORT :: quaternion_ - IMPLICIT NONE - TYPE(quaternion_) :: quaternion_identity - END FUNCTION quaternion_identity - - ! Quaternion QuaternionInvert(Quaternion q) - FUNCTION quaternion_invert(q) BIND(c, name='QuaternionInvert') - IMPORT :: quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - TYPE(quaternion_) :: quaternion_invert - END FUNCTION quaternion_invert - - ! float QuaternionLength(Quaternion q) - FUNCTION quaternion_length(q) BIND(c, name='QuaternionLength') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - REAL(kind=C_FLOAT) :: quaternion_length - END FUNCTION quaternion_length - - ! Quaternion QuaternionLerp(Quaternion q1, Quaternion q2, float amount) - FUNCTION quaternion_lerp(q1, q2, amount) BIND(c, name='QuaternionLerp') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q1 - TYPE(quaternion_), INTENT(in), VALUE :: q2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount - TYPE(quaternion_) :: quaternion_lerp - END FUNCTION quaternion_lerp - - ! Quaternion QuaternionMultiply(Quaternion q1, Quaternion q2) - FUNCTION quaternion_multiply(q1, q2) BIND(c, name='QuaternionMultiply') - IMPORT :: quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q1 - TYPE(quaternion_), INTENT(in), VALUE :: q2 - TYPE(quaternion_) :: quaternion_multiply - END FUNCTION quaternion_multiply - - ! Quaternion QuaternionNlerp(Quaternion q1, Quaternion q2, float amount) - FUNCTION quaternion_nlerp(q1, q2, amount) BIND(c, name='QuaternionNlerp') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q1 - TYPE(quaternion_), INTENT(in), VALUE :: q2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount - TYPE(quaternion_) :: quaternion_nlerp - END FUNCTION quaternion_nlerp - - ! Quaternion QuaternionNormalize(Quaternion q) - FUNCTION quaternion_normalize(q) BIND(c, name='QuaternionNormalize') - IMPORT :: quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - TYPE(quaternion_) :: quaternion_normalize - END FUNCTION quaternion_normalize - - ! Quaternion QuaternionScale(Quaternion q, float mul) - FUNCTION quaternion_scale(q, mul) BIND(c, name='QuaternionScale') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - REAL(kind=C_FLOAT), INTENT(in), VALUE :: mul - TYPE(quaternion_) :: quaternion_scale - END FUNCTION quaternion_scale - - ! Quaternion QuaternionSlerp(Quaternion q1, Quaternion q2, float amount) - FUNCTION quaternion_slerp(q1, q2, amount) BIND(c, name='QuaternionSlerp') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q1 - TYPE(quaternion_), INTENT(in), VALUE :: q2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount - TYPE(quaternion_) :: quaternion_slerp - END FUNCTION quaternion_slerp - - ! Quaternion QuaternionSubtract(Quaternion q1, Quaternion q2) - FUNCTION quaternion_subtract(q1, q2) BIND(c, name='QuaternionSubtract') - IMPORT :: quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q1 - TYPE(quaternion_), INTENT(in), VALUE :: q2 - TYPE(quaternion_) :: quaternion_subtract - END FUNCTION quaternion_subtract - - ! Quaternion QuaternionSubtractValue(Quaternion q, float sub) - function quaternion_subtract_value(q, sub) bind(c, name='QuaternionSubtractValue') - IMPORT :: C_FLOAT, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - REAL(kind=C_FLOAT), INTENT(in), VALUE :: sub - TYPE(quaternion_) :: quaternion_subtract_value - END FUNCTION quaternion_subtract_value - - ! void QuaternionToAxisAngle(Quaternion q, Vector3 *outAxis, float *outAngle) - subroutine quaternion_to_axis_angle(q, out_axis, out_angle) bind(c, name='QuaternionToAxisAngle') - IMPORT :: C_FLOAT, quaternion_, vector3_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - TYPE(vector3_), INTENT(inout) :: out_axis(*) - REAL(kind=C_FLOAT), INTENT(out) :: out_angle - END SUBROUTINE quaternion_to_axis_angle - - ! Vector3 QuaternionToEuler(Quaternion q) - FUNCTION quaternion_to_euler(q) BIND(c, name='QuaternionToEuler') - IMPORT :: quaternion_, vector3_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - TYPE(vector3_) :: quaternion_to_euler - END FUNCTION quaternion_to_euler - - ! Matrix QuaternionToMatrix(Quaternion q) - FUNCTION quaternion_to_matrix(q) BIND(c, name='QuaternionToMatrix') - IMPORT :: matrix_, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - TYPE(matrix_) :: quaternion_to_matrix - END FUNCTION quaternion_to_matrix - - ! Quaternion QuaternionTransform(Quaternion q, Matrix mat) - FUNCTION quaternion_transform(q, mat) BIND(c, name='QuaternionTransform') - IMPORT :: matrix_, quaternion_ - IMPLICIT NONE - TYPE(quaternion_), INTENT(in), VALUE :: q - TYPE(matrix_), INTENT(in), VALUE :: mat - TYPE(quaternion_) :: quaternion_transform - END FUNCTION quaternion_transform - - ! float Remap(float value, float inputStart, float inputEnd, float outputStart, float outputEnd) - function remap(value, input_start, input_end, output_start, output_end) bind(c, name='Remap') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: input_start - REAL(kind=C_FLOAT), INTENT(in), VALUE :: input_end - REAL(kind=C_FLOAT), INTENT(in), VALUE :: output_start - REAL(kind=C_FLOAT), INTENT(in), VALUE :: output_end - REAL(kind=C_FLOAT) :: remap - END FUNCTION remap - - ! Vector2 Vector2Add(Vector2 v1, Vector2 v2) - FUNCTION vector2_add(v1, v2) BIND(c, name='Vector2Add') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - TYPE(vector2_) :: vector2_add - END FUNCTION vector2_add - - ! Vector2 Vector2AddValue(Vector2 v, float add) - FUNCTION vector2_add_value(v, add) BIND(c, name='Vector2AddValue') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: add - TYPE(vector2_) :: vector2_add_value - END FUNCTION vector2_add_value - - ! float Vector2Angle(Vector2 v1, Vector2 v2) - FUNCTION vector2_angle(v1, v2) BIND(c, name='Vector2Angle') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector2_angle - END FUNCTION vector2_angle - - ! Vector2 Vector2Clamp(Vector2 v, Vector2 min, Vector2 max) - FUNCTION vector2_clamp(v, min, max) BIND(c, name='Vector2Clamp') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - TYPE(vector2_), INTENT(in), VALUE :: min - TYPE(vector2_), INTENT(in), VALUE :: max - TYPE(vector2_) :: vector2_clamp - END FUNCTION vector2_clamp - - ! Vector2 Vector2ClampValue(Vector2 v, float min, float max) - FUNCTION vector2_clamp_value(v, min, max) BIND(c, name='Vector2ClampValue') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: min - REAL(kind=C_FLOAT), INTENT(in), VALUE :: max - TYPE(vector2_) :: vector2_clamp_value - END FUNCTION vector2_clamp_value - - ! float Vector2Distance(Vector2 v1, Vector2 v2) - FUNCTION vector2_distance(v1, v2) BIND(c, name='Vector2Distance') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector2_distance - END FUNCTION vector2_distance - - ! float Vector2DistanceSqr(Vector2 v1, Vector2 v2) - FUNCTION vector2_distance_sqr(v1, v2) BIND(c, name='Vector2DistanceSqr') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector2_distance_sqr - END FUNCTION vector2_distance_sqr - - ! Vector2 Vector2Divide(Vector2 v1, Vector2 v2) - FUNCTION vector2_divide(v1, v2) BIND(c, name='Vector2Divide') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - TYPE(vector2_) :: vector2_divide - END FUNCTION vector2_divide - - ! float Vector2DotProduct(Vector2 v1, Vector2 v2) - FUNCTION vector2_dot_product(v1, v2) BIND(c, name='Vector2DotProduct') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector2_dot_product - END FUNCTION vector2_dot_product - - ! int Vector2Equals(Vector2 p, Vector2 q) - FUNCTION vector2_equals(p, q) BIND(c, name='Vector2Equals') - IMPORT :: C_INT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: p - TYPE(vector2_), INTENT(in), VALUE :: q - INTEGER(kind=C_INT) :: vector2_equals - END FUNCTION vector2_equals - - ! Vector2 Vector2Invert(Vector2 v) - FUNCTION vector2_invert(v) BIND(c, name='Vector2Invert') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - TYPE(vector2_) :: vector2_invert - END FUNCTION vector2_invert - - ! float Vector2Length(Vector2 v) - FUNCTION vector2_length(v) BIND(c, name='Vector2Length') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT) :: vector2_length - END FUNCTION vector2_length - - ! float Vector2LengthSqr(Vector2 v) - FUNCTION vector2_length_sqr(v) BIND(c, name='Vector2LengthSqr') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT) :: vector2_length_sqr - END FUNCTION vector2_length_sqr - - ! Vector2 Vector2Lerp(Vector2 v1, Vector2 v2, float amount) - FUNCTION vector2_lerp(v1, v2, amount) BIND(c, name='Vector2Lerp') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount - TYPE(vector2_) :: vector2_lerp - END FUNCTION vector2_lerp - - ! float Vector2LineAngle(Vector2 start, Vector2 end) - FUNCTION vector2_line_angle(start, END) BIND(c, name='Vector2LineAngle') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: start - TYPE(vector2_), INTENT(in), VALUE :: END - REAL(kind=C_FLOAT) :: vector2_line_angle - END FUNCTION vector2_line_angle - - ! Vector2 Vector2MoveTowards(Vector2 v, Vector2 target, float maxDistance) - function vector2_move_towards(v, target, max_distance) bind(c, name='Vector2MoveTowards') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - TYPE(vector2_), INTENT(in), VALUE :: TARGET - REAL(kind=C_FLOAT), INTENT(in), VALUE :: max_distance - TYPE(vector2_) :: vector2_move_towards - END FUNCTION vector2_move_towards - - ! Vector2 Vector2Multiply(Vector2 v1, Vector2 v2) - FUNCTION vector2_multiply(v1, v2) BIND(c, name='Vector2Multiply') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - TYPE(vector2_) :: vector2_multiply - END FUNCTION vector2_multiply - - ! Vector2 Vector2Negate(Vector2 v) - FUNCTION vector2_negate(v) BIND(c, name='Vector2Negate') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - TYPE(vector2_) :: vector2_negate - END FUNCTION vector2_negate - - ! Vector2 Vector2Normalize(Vector2 v) - FUNCTION vector2_normalize(v) BIND(c, name='Vector2Normalize') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - TYPE(vector2_) :: vector2_normalize - END FUNCTION vector2_normalize - - ! Vector2 Vector2One(void) - FUNCTION vector2_one() BIND(c, name='Vector2One') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_) :: vector2_one - END FUNCTION vector2_one - - ! Vector2 Vector2Reflect(Vector2 v, Vector2 normal) - FUNCTION vector2_reflect(v, normal) BIND(c, name='Vector2Reflect') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - TYPE(vector2_), INTENT(in), VALUE :: normal - TYPE(vector2_) :: vector2_reflect - END FUNCTION vector2_reflect - - ! Vector2 Vector2Rotate(Vector2 v, float angle) - FUNCTION vector2_rotate(v, angle) BIND(c, name='Vector2Rotate') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - TYPE(vector2_) :: vector2_rotate - END FUNCTION vector2_rotate - - ! Vector2 Vector2Scale(Vector2 v, float scale) - FUNCTION vector2_scale(v, scale) BIND(c, name='Vector2Scale') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale - TYPE(vector2_) :: vector2_scale - END FUNCTION vector2_scale - - ! Vector2 Vector2Subtract(Vector2 v1, Vector2 v2) - FUNCTION vector2_subtract(v1, v2) BIND(c, name='Vector2Subtract') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v1 - TYPE(vector2_), INTENT(in), VALUE :: v2 - TYPE(vector2_) :: vector2_subtract - END FUNCTION vector2_subtract - - ! Vector2 Vector2SubtractValue(Vector2 v, float sub) - FUNCTION vector2_subtract_value(v, sub) BIND(c, name='Vector2SubtractValue') - IMPORT :: C_FLOAT, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: sub - TYPE(vector2_) :: vector2_subtract_value - END FUNCTION vector2_subtract_value - - ! Vector2 Vector2Transform(Vector2 v, Matrix mat) - FUNCTION vector2_transform(v, mat) BIND(c, name='Vector2Transform') - IMPORT :: matrix_, vector2_ - IMPLICIT NONE - TYPE(vector2_), INTENT(in), VALUE :: v - TYPE(matrix_), INTENT(in), VALUE :: mat - TYPE(vector2_) :: vector2_transform - END FUNCTION vector2_transform - - ! Vector2 Vector2Zero(void) - FUNCTION vector2_zero() BIND(c, name='Vector2Zero') - IMPORT :: vector2_ - IMPLICIT NONE - TYPE(vector2_) :: vector2_zero - END FUNCTION vector2_zero - - ! Vector3 Vector3Add(Vector3 v1, Vector3 v2) - FUNCTION vector3_add(v1, v2) BIND(c, name='Vector3Add') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_) :: vector3_add - END FUNCTION vector3_add - - ! Vector3 Vector3AddValue(Vector3 v, float add) - FUNCTION vector3_add_value(v, add) BIND(c, name='Vector3AddValue') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: add - TYPE(vector3_) :: vector3_add_value - END FUNCTION vector3_add_value - - ! float Vector3Angle(Vector3 v1, Vector3 v2) - FUNCTION vector3_angle(v1, v2) BIND(c, name='Vector3Angle') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector3_angle - END FUNCTION vector3_angle - - ! Vector3 Vector3Barycenter(Vector3 p, Vector3 a, Vector3 b, Vector3 c) - FUNCTION vector3_barycenter(p, a, b, c) BIND(c, name='Vector3Barycenter') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: p - TYPE(vector3_), INTENT(in), VALUE :: a - TYPE(vector3_), INTENT(in), VALUE :: b - TYPE(vector3_), INTENT(in), VALUE :: c - TYPE(vector3_) :: vector3_barycenter - END FUNCTION vector3_barycenter - - ! Vector3 Vector3Clamp(Vector3 v, Vector3 min, Vector3 max) - FUNCTION vector3_clamp(v, min, max) BIND(c, name='Vector3Clamp') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_), INTENT(in), VALUE :: min - TYPE(vector3_), INTENT(in), VALUE :: max - TYPE(vector3_) :: vector3_clamp - END FUNCTION vector3_clamp - - ! Vector3 Vector3ClampValue(Vector3 v, float min, float max) - FUNCTION vector3_clamp_value(v, min, max) BIND(c, name='Vector3ClampValue') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: min - REAL(kind=C_FLOAT), INTENT(in), VALUE :: max - TYPE(vector3_) :: vector3_clamp_value - END FUNCTION vector3_clamp_value - - ! Vector3 Vector3CrossProduct(Vector3 v1, Vector3 v2) - FUNCTION vector3_cross_product(v1, v2) BIND(c, name='Vector3CrossProduct') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_) :: vector3_cross_product - END FUNCTION vector3_cross_product - - ! float Vector3Distance(Vector3 v1, Vector3 v2) - FUNCTION vector3_distance(v1, v2) BIND(c, name='Vector3Distance') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector3_distance - END FUNCTION vector3_distance - - ! float Vector3DistanceSqr(Vector3 v1, Vector3 v2) - FUNCTION vector3_distance_sqr(v1, v2) BIND(c, name='Vector3DistanceSqr') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector3_distance_sqr - END FUNCTION vector3_distance_sqr - - ! Vector3 Vector3Divide(Vector3 v1, Vector3 v2) - FUNCTION vector3_divide(v1, v2) BIND(c, name='Vector3Divide') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_) :: vector3_divide - END FUNCTION vector3_divide - - ! float Vector3DotProduct(Vector3 v1, Vector3 v2) - FUNCTION vector3_dot_product(v1, v2) BIND(c, name='Vector3DotProduct') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT) :: vector3_dot_product - END FUNCTION vector3_dot_product - - ! int Vector3Equals(Vector3 p, Vector3 q) - FUNCTION vector3_equals(p, q) BIND(c, name='Vector3Equals') - IMPORT :: C_INT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: p - TYPE(vector3_), INTENT(in), VALUE :: q - INTEGER(kind=C_INT) :: vector3_equals - END FUNCTION vector3_equals - - ! Vector3 Vector3Invert(Vector3 v) - FUNCTION vector3_invert(v) BIND(c, name='Vector3Invert') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_) :: vector3_invert - END FUNCTION vector3_invert - - ! float Vector3Length(const Vector3 v) - FUNCTION vector3_length(v) BIND(c, name='Vector3Length') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT) :: vector3_length - END FUNCTION vector3_length - - ! float Vector3LengthSqr(const Vector3 v) - FUNCTION vector3_length_sqr(v) BIND(c, name='Vector3LengthSqr') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT) :: vector3_length_sqr - END FUNCTION vector3_length_sqr - - ! Vector3 Vector3Lerp(Vector3 v1, Vector3 v2, float amount) - FUNCTION vector3_lerp(v1, v2, amount) BIND(c, name='Vector3Lerp') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount - TYPE(vector3_) :: vector3_lerp - END FUNCTION vector3_lerp - - ! Vector3 Vector3Max(Vector3 v1, Vector3 v2) - FUNCTION vector3_max(v1, v2) BIND(c, name='Vector3Max') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_) :: vector3_max - END FUNCTION vector3_max - - ! Vector3 Vector3Min(Vector3 v1, Vector3 v2) - FUNCTION vector3_min(v1, v2) BIND(c, name='Vector3Min') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_) :: vector3_min - END FUNCTION vector3_min - - ! Vector3 Vector3Multiply(Vector3 v1, Vector3 v2) - FUNCTION vector3_multiply(v1, v2) BIND(c, name='Vector3Multiply') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_) :: vector3_multiply - END FUNCTION vector3_multiply - - ! Vector3 Vector3Negate(Vector3 v) - FUNCTION vector3_negate(v) BIND(c, name='Vector3Negate') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_) :: vector3_negate - END FUNCTION vector3_negate - - ! Vector3 Vector3Normalize(Vector3 v) - FUNCTION vector3_normalize(v) BIND(c, name='Vector3Normalize') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_) :: vector3_normalize - END FUNCTION vector3_normalize - - ! Vector3 Vector3One(void) - FUNCTION vector3_one() BIND(c, name='Vector3One') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_) :: vector3_one - END FUNCTION vector3_one - - ! void Vector3OrthoNormalize(Vector3 *v1, Vector3 *v2) - subroutine vector3_ortho_normalize(v1, v2) bind(c, name='Vector3OrthoNormalize') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(inout) :: v1(*) - TYPE(vector3_), INTENT(inout) :: v2(*) - END SUBROUTINE vector3_ortho_normalize - - ! Vector3 Vector3Perpendicular(Vector3 v) - FUNCTION vector3_perpendicular(v) BIND(c, name='Vector3Perpendicular') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_) :: vector3_perpendicular - END FUNCTION vector3_perpendicular - - ! Vector3 Vector3Reflect(Vector3 v, Vector3 normal) - FUNCTION vector3_reflect(v, normal) BIND(c, name='Vector3Reflect') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_), INTENT(in), VALUE :: normal - TYPE(vector3_) :: vector3_reflect - END FUNCTION vector3_reflect - - ! Vector3 Vector3Refract(Vector3 v, Vector3 n, float r) - FUNCTION vector3_refract(v, n, r) BIND(c, name='Vector3Refract') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_), INTENT(in), VALUE :: n - REAL(kind=C_FLOAT), INTENT(in), VALUE :: r - TYPE(vector3_) :: vector3_refract - END FUNCTION vector3_refract - - ! Vector3 Vector3RotateByAxisAngle(Vector3 v, Vector3 axis, float angle) - function vector3_rotate_by_axis_angle(v, axis, angle) bind(c, name='Vector3RotateByAxisAngle') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(vector3_), INTENT(in), VALUE :: axis - REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle - TYPE(vector3_) :: vector3_rotate_by_axis_angle - END FUNCTION vector3_rotate_by_axis_angle - - ! Vector3 Vector3RotateByQuaternion(Vector3 v, Quaternion q) - function vector3_rotate_by_quaternion(v, q) bind(c, name='Vector3RotateByQuaternion') - IMPORT :: quaternion_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(quaternion_), INTENT(in), VALUE :: q - TYPE(vector3_) :: vector3_rotate_by_quaternion - END FUNCTION vector3_rotate_by_quaternion - - ! Vector3 Vector3Scale(Vector3 v, float scalar) - FUNCTION vector3_scale(v, scalar) BIND(c, name='Vector3Scale') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scalar - TYPE(vector3_) :: vector3_scale - END FUNCTION vector3_scale - - ! Vector3 Vector3Subtract(Vector3 v1, Vector3 v2) - FUNCTION vector3_subtract(v1, v2) BIND(c, name='Vector3Subtract') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v1 - TYPE(vector3_), INTENT(in), VALUE :: v2 - TYPE(vector3_) :: vector3_subtract - END FUNCTION vector3_subtract - - ! Vector3 Vector3SubtractValue(Vector3 v, float sub) - FUNCTION vector3_subtract_value(v, sub) BIND(c, name='Vector3SubtractValue') - IMPORT :: C_FLOAT, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - REAL(kind=C_FLOAT), INTENT(in), VALUE :: sub - TYPE(vector3_) :: vector3_subtract_value - END FUNCTION vector3_subtract_value - - ! float3 Vector3ToFloatV(Vector3 v) - FUNCTION vector3_to_float_v(v) BIND(c, name='Vector3ToFloatV') - IMPORT :: float3_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(float3_) :: vector3_to_float_v - END FUNCTION vector3_to_float_v - - ! Vector3 Vector3Transform(Vector3 v, Matrix mat) - FUNCTION vector3_transform(v, mat) BIND(c, name='Vector3Transform') - IMPORT :: matrix_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: v - TYPE(matrix_), INTENT(in), VALUE :: mat - TYPE(vector3_) :: vector3_transform - END FUNCTION vector3_transform - - ! Vector3 Vector3Unproject(Vector3 source, Matrix projection, Matrix view) - function vector3_unproject(source, projection, view) bind(c, name='Vector3Unproject') - IMPORT :: matrix_, vector3_ - IMPLICIT NONE - TYPE(vector3_), INTENT(in), VALUE :: source - TYPE(matrix_), INTENT(in), VALUE :: projection - TYPE(matrix_), INTENT(in), VALUE :: view - TYPE(vector3_) :: vector3_unproject - END FUNCTION vector3_unproject - - ! Vector3 Vector3Zero(void) - FUNCTION vector3_zero() BIND(c, name='Vector3Zero') - IMPORT :: vector3_ - IMPLICIT NONE - TYPE(vector3_) :: vector3_zero - END FUNCTION vector3_zero - - ! float Wrap(float value, float min, float max) - FUNCTION wrap(VALUE, min, max) BIND(c, name='Wrap') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: min - REAL(kind=C_FLOAT), INTENT(in), VALUE :: max - REAL(kind=C_FLOAT) :: wrap - END FUNCTION wrap -END INTERFACE -END MODULE raylib_math diff --git a/src/modules/RaylibInterface/src/RaylibMethods.F90 b/src/modules/RaylibInterface/src/RaylibMethods.F90 deleted file mode 100644 index 88e2a1c6d..000000000 --- a/src/modules/RaylibInterface/src/RaylibMethods.F90 +++ /dev/null @@ -1,1060 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: AttachAudioMixedProcessor -PUBLIC :: AttachAudioStreamProcessor -PUBLIC :: BeginBlendMode -PUBLIC :: BeginDrawing -PUBLIC :: BeginMode2D -PUBLIC :: BeginMode3D -PUBLIC :: BeginScissorMode -PUBLIC :: BeginShaderMode -PUBLIC :: BeginTextureMode -PUBLIC :: BeginVrStereoMode -PUBLIC :: ChangeDirectory -PUBLIC :: ClearBackground -PUBLIC :: ClearWindowState -PUBLIC :: CloseAudioDevice -PUBLIC :: CloseWindow -PUBLIC :: CodepointToUTF8 -PUBLIC :: ColorAlpha -PUBLIC :: ColorAlphaBlend -PUBLIC :: ColorBrightness -PUBLIC :: ColorContrast -PUBLIC :: ColorFromHSV -PUBLIC :: ColorFromNormalized -PUBLIC :: ColorTint -PUBLIC :: ColorToInt -PUBLIC :: CompressData -PUBLIC :: DecodeDataBase64 -PUBLIC :: DecompressData -PUBLIC :: DetachAudioMixedProcessor -PUBLIC :: DetachAudioStreamProcessor -PUBLIC :: DirectoryExists -PUBLIC :: DisableCursor -PUBLIC :: DisableEventWaiting -PUBLIC :: EnableCursor -PUBLIC :: EnableEventWaiting -PUBLIC :: EncodeDataBase64 -PUBLIC :: EndBlendMode -PUBLIC :: EndDrawing -PUBLIC :: EndMode2D -PUBLIC :: EndMode3D -PUBLIC :: EndScissorMode -PUBLIC :: EndShaderMode -PUBLIC :: EndTextureMode -PUBLIC :: EndVrStereoMode -PUBLIC :: ExportDataAsCode -PUBLIC :: ExportFontAsCode -PUBLIC :: ExportImage -PUBLIC :: ExportImageAsCode - -PUBLIC :: ExportImageToMemory -PUBLIC :: ExportMesh -PUBLIC :: ExportWave -PUBLIC :: ExportWaveAsCode -PUBLIC :: fade -PUBLIC :: FileExists -PUBLIC :: HideCursor -PUBLIC :: InitAudioDevice -PUBLIC :: InitWindow -PUBLIC :: MaximizeWindow -PUBLIC :: MeasureText -PUBLIC :: MeasureTextEx -PUBLIC :: MemAlloc -PUBLIC :: MemFree -PUBLIC :: MemRealloc -PUBLIC :: MinimizeWindow -PUBLIC :: OpenURL -PUBLIC :: PauseAudioStream -PUBLIC :: PauseMusicStream -PUBLIC :: PauseSound -PUBLIC :: PlayAudioStream -PUBLIC :: PlayMusicStream -PUBLIC :: PlaySound -PUBLIC :: PollInputEvents -PUBLIC :: RestoreWindow -PUBLIC :: ResumeAudioStream -PUBLIC :: ResumeMusicStream -PUBLIC :: ResumeSound -PUBLIC :: SaveFileData -PUBLIC :: SaveFileText -PUBLIC :: SeekMusicStream -PUBLIC :: ShowCursor -PUBLIC :: StopAudioStream -PUBLIC :: StopMusicStream -PUBLIC :: StopSound -PUBLIC :: SwapScreenBuffer -PUBLIC :: TakeScreenshot - -PUBLIC :: TextAppend -PUBLIC :: TextCopy -PUBLIC :: TextFindIndex -PUBLIC :: TextInsert -PUBLIC :: TextIsEqual -PUBLIC :: TextJoin -PUBLIC :: TextLength -PUBLIC :: TextReplace -PUBLIC :: TextSplit -PUBLIC :: TextSubtext -PUBLIC :: TextToInteger -PUBLIC :: TextToLower -PUBLIC :: TextToPascal -PUBLIC :: TextToUpper - -PUBLIC :: ToggleBorderlessWindowed -PUBLIC :: ToggleFullscreen -PUBLIC :: TraceLog - -PUBLIC :: UpdateAudioStream -PUBLIC :: UpdateCamera -PUBLIC :: UpdateMeshBuffer -PUBLIC :: UpdateModelAnimation -PUBLIC :: UpdateMusicStream -PUBLIC :: UpdateSound -PUBLIC :: UpdateTexture -PUBLIC :: UpdateTextureRec - -PUBLIC :: UploadMesh -PUBLIC :: WaitTime -PUBLIC :: WaveCopy -PUBLIC :: WaveCrop -PUBLIC :: WaveFormat -PUBLIC :: WindowShouldClose - -PUBLIC :: load_file_data_callback -PUBLIC :: SaveFileData_callback -PUBLIC :: load_file_text_callback -PUBLIC :: SaveFileText_callback -PUBLIC :: TraceLog_callback - -PUBLIC :: deg2rad -PUBLIC :: rad2deg - -ABSTRACT INTERFACE - ! unsigned char *(*LoadFileDataCallback)(const char *fileName, unsigned int *bytesRead) - FUNCTION load_file_data_callback(file_name, bytes_read) BIND(c) - IMPORT :: C_PTR, c_unsigned_int - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: file_name - INTEGER(kind=c_unsigned_int), INTENT(out) :: bytes_read - TYPE(C_PTR) :: load_file_data_callback - END FUNCTION load_file_data_callback - - ! bool (*SaveFileDataCallback)(const char *fileName, void *data, unsigned int bytesToWrite) - FUNCTION SaveFileData_callback(file_name, DATA, bytes_to_write) BIND(c) - IMPORT :: C_BOOL, C_PTR, c_unsigned_int - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: file_name - TYPE(C_PTR), INTENT(in), VALUE :: DATA - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: bytes_to_write - LOGICAL(kind=C_BOOL) :: SaveFileData_callback - END FUNCTION SaveFileData_callback - - ! char *(*LoadFileTextCallback)(const char *fileName) - FUNCTION load_file_text_callback(file_name) BIND(c) - IMPORT :: C_PTR, c_unsigned_int - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: file_name - TYPE(C_PTR) :: load_file_text_callback - END FUNCTION load_file_text_callback - - ! bool (*SaveFileTextCallback)(const char *fileName, char *text) - FUNCTION SaveFileText_callback(file_name, text) BIND(c) - IMPORT :: C_BOOL, C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: file_name - TYPE(C_PTR), INTENT(in), VALUE :: text - LOGICAL(kind=C_BOOL) :: SaveFileText_callback - END FUNCTION SaveFileText_callback - - ! void (*TraceLogCallback)(int logLevel, const char *text, va_list args) - SUBROUTINE TraceLog_callback(log_level, text, args) BIND(c) - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: log_level - TYPE(C_PTR), INTENT(in), VALUE :: text - TYPE(C_PTR), INTENT(in) :: args(*) - END SUBROUTINE TraceLog_callback -END INTERFACE - -INTERFACE - ! void AttachAudioMixedProcessor(AudioCallback processor) - subroutine AttachAudioMixedProcessor(processor) bind(c, name='AttachAudioMixedProcessor') - IMPORT :: C_FUNPTR - IMPLICIT NONE - TYPE(C_FUNPTR), INTENT(in), VALUE :: processor - END SUBROUTINE AttachAudioMixedProcessor - - ! void AttachAudioStreamProcessor(AudioStream stream, AudioCallback processor) - subroutine AttachAudioStreamProcessor(stream, processor) bind(c, name='AttachAudioStreamProcessor') - IMPORT :: audio_stream_, C_FUNPTR - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - TYPE(C_FUNPTR), INTENT(in), VALUE :: processor - END SUBROUTINE AttachAudioStreamProcessor - - ! void BeginBlendMode(int mode) - SUBROUTINE BeginBlendMode(mode) BIND(c, name='BeginBlendMode') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: mode - END SUBROUTINE BeginBlendMode - - ! void BeginDrawing(void) - SUBROUTINE BeginDrawing() BIND(c, name='BeginDrawing') - END SUBROUTINE BeginDrawing - - ! void BeginMode2D(Camera2D camera) - SUBROUTINE BeginMode2D(camera) BIND(c, name='BeginMode2D') - IMPORT :: camera2d_ - IMPLICIT NONE - TYPE(camera2d_), INTENT(in), VALUE :: camera - END SUBROUTINE BeginMode2D - - ! void BeginMode3D(Camera3D camera) - SUBROUTINE BeginMode3D(camera) BIND(c, name='BeginMode3D') - IMPORT :: camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(in), VALUE :: camera - END SUBROUTINE BeginMode3D - - ! void BeginScissorMode(int x, int y, int width, int height) - subroutine BeginScissorMode(x, y, width, height) bind(c, name='BeginScissorMode') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: x - INTEGER(kind=C_INT), INTENT(in), VALUE :: y - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - END SUBROUTINE BeginScissorMode - - ! void BeginShaderMode(Shader shader) - SUBROUTINE BeginShaderMode(shader) BIND(c, name='BeginShaderMode') - IMPORT :: shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - END SUBROUTINE BeginShaderMode - - ! void BeginTextureMode(RenderTexture2D target) - SUBROUTINE BeginTextureMode(TARGET) BIND(c, name='BeginTextureMode') - IMPORT :: render_texture2d_ - IMPLICIT NONE - TYPE(render_texture2d_), INTENT(in), VALUE :: TARGET - END SUBROUTINE BeginTextureMode - - ! void BeginVrStereoMode(VrStereoConfig config) - SUBROUTINE BeginVrStereoMode(config) BIND(c, name='BeginVrStereoMode') - IMPORT :: vr_stereo_config_ - IMPLICIT NONE - TYPE(vr_stereo_config_), INTENT(in), VALUE :: config - END SUBROUTINE BeginVrStereoMode - - ! bool ChangeDirectory(const char *dir) - FUNCTION ChangeDirectory(dir) BIND(c, name='ChangeDirectory') - IMPORT :: C_BOOL, C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: dir - LOGICAL(kind=C_BOOL) :: ChangeDirectory - END FUNCTION ChangeDirectory - - ! void ClearBackground(Color color) - SUBROUTINE ClearBackground(color) BIND(c, name='ClearBackground') - IMPORT :: color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: color - END SUBROUTINE ClearBackground - - ! void ClearWindowState(unsigned int flags) - SUBROUTINE ClearWindowState(flags) BIND(c, name='ClearWindowState') - IMPORT :: c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags - END SUBROUTINE ClearWindowState - - ! void CloseAudioDevice(void) - SUBROUTINE CloseAudioDevice() BIND(c, name='CloseAudioDevice') - END SUBROUTINE CloseAudioDevice - - ! void CloseWindow(void) - SUBROUTINE CloseWindow() BIND(c, name='CloseWindow') - END SUBROUTINE CloseWindow - - ! const char *CodepointToUTF8(int codepoint, int *utf8Size) -FUNCTION CodepointToUTF8(codepoint, utf8_size) BIND(c, name='CodepointToUTF8') - IMPORT :: C_INT, C_PTR - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint - INTEGER(kind=C_INT), INTENT(out) :: utf8_size - TYPE(C_PTR) :: CodepointToUTF8 - END FUNCTION CodepointToUTF8 - - ! Color ColorAlpha(Color color, float alpha) - FUNCTION ColorAlpha(color, alpha) BIND(c, name='ColorAlpha') - IMPORT :: C_FLOAT, color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: color - REAL(kind=C_FLOAT), INTENT(in), VALUE :: alpha - TYPE(color_) :: ColorAlpha - END FUNCTION ColorAlpha - - ! Color ColorAlphaBlend(Color dst, Color src, Color tint) - FUNCTION ColorAlphaBlend(dst, src, tint) BIND(c, name='ColorAlphaBlend') - IMPORT :: color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: dst - TYPE(color_), INTENT(in), VALUE :: src - TYPE(color_), INTENT(in), VALUE :: tint - TYPE(color_) :: ColorAlphaBlend - END FUNCTION ColorAlphaBlend - - ! Color ColorBrightness(Color color, float factor) - FUNCTION ColorBrightness(color, factor) BIND(c, name='ColorBrightness') - IMPORT :: C_FLOAT, color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: color - REAL(kind=C_FLOAT), INTENT(in), VALUE :: factor - TYPE(color_) :: ColorBrightness - END FUNCTION ColorBrightness - - ! Color ColorContrast(Color color, float contrast) - FUNCTION ColorContrast(color, contrast) BIND(c, name='ColorContrast') - IMPORT :: C_FLOAT, color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: color - REAL(kind=C_FLOAT), INTENT(in), VALUE :: contrast - TYPE(color_) :: ColorContrast - END FUNCTION ColorContrast - - ! Color ColorFromHSV(float hue, float saturation, float value) - FUNCTION ColorFromHSV(hue, saturation, VALUE) BIND(c, name='ColorFromHSV') - IMPORT :: C_FLOAT, color_ - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: hue - REAL(kind=C_FLOAT), INTENT(in), VALUE :: saturation - REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE - TYPE(color_) :: ColorFromHSV - END FUNCTION ColorFromHSV - - ! Color ColorFromNormalized(Vector4 normalized) - FUNCTION ColorFromNormalized(normalized) BIND(c, name='ColorFromNormalized') - IMPORT :: color_, vector4_ - IMPLICIT NONE - TYPE(vector4_), INTENT(in), VALUE :: normalized - TYPE(color_) :: ColorFromNormalized - END FUNCTION ColorFromNormalized - - ! Color ColorTint(Color color, Color tint) - FUNCTION ColorTint(color, tint) BIND(c, name='ColorTint') - IMPORT :: color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: color - TYPE(color_), INTENT(in), VALUE :: tint - TYPE(color_) :: ColorTint - END FUNCTION ColorTint - - ! int ColorToInt(Color color) - FUNCTION ColorToInt(color) BIND(c, name='ColorToInt') - IMPORT :: C_INT, color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: color - INTEGER(kind=C_INT) :: ColorToInt - END FUNCTION ColorToInt - - ! unsigned char *CompressData(const unsigned char *data, int dataSize, int *compDataSize) - function CompressData(data, data_size, comp_data_size) bind(c, name='CompressData') - IMPORT :: C_INT, C_PTR, c_unsigned_char - IMPLICIT NONE - INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - INTEGER(kind=C_INT), INTENT(out) :: comp_data_size - TYPE(C_PTR) :: CompressData - END FUNCTION CompressData - - ! unsigned char *DecodeDataBase64(const unsigned char *data, int *outputSize) - FUNCTION DecodeDataBase64(DATA, output_size) BIND(c, name='DecodeDataBase64') - IMPORT :: C_INT, c_unsigned_char, C_PTR - IMPLICIT NONE - INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA - INTEGER(kind=C_INT), INTENT(out) :: output_size - TYPE(C_PTR) :: DecodeDataBase64 - END FUNCTION DecodeDataBase64 - - ! unsigned char *DecompressData(const unsigned char *compData, int compDataSize, int *dataSize) - function DecompressData(comp_data, comp_data_size, data_size) bind(c, name='DecompressData') - IMPORT :: C_INT, C_PTR, c_unsigned_char - IMPLICIT NONE - INTEGER(kind=c_unsigned_char), INTENT(in) :: comp_data - INTEGER(kind=C_INT), INTENT(in), VALUE :: comp_data_size - INTEGER(kind=C_INT), INTENT(out) :: data_size - TYPE(C_PTR) :: DecompressData - END FUNCTION DecompressData - - ! void DetachAudioMixedProcessor(AudioCallback processor) - subroutine DetachAudioMixedProcessor(processor) bind(c, name='DetachAudioMixedProcessor') - IMPORT :: C_FUNPTR - IMPLICIT NONE - TYPE(C_FUNPTR), INTENT(in), VALUE :: processor - END SUBROUTINE DetachAudioMixedProcessor - - ! void DetachAudioStreamProcessor(AudioStream stream, AudioCallback processor) - subroutine DetachAudioStreamProcessor(stream, processor) bind(c, name='DetachAudioStreamProcessor') - IMPORT :: audio_stream_, C_FUNPTR - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - TYPE(C_FUNPTR), INTENT(in), VALUE :: processor - END SUBROUTINE DetachAudioStreamProcessor - - ! bool DirectoryExists(const char *dirPath) - FUNCTION DirectoryExists(dir_path) BIND(c, name='DirectoryExists') - IMPORT :: C_BOOL, C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: dir_path - LOGICAL(kind=C_BOOL) :: DirectoryExists - END FUNCTION DirectoryExists - - ! void DisableCursor(void) - SUBROUTINE DisableCursor() BIND(c, name='DisableCursor') - END SUBROUTINE DisableCursor - - ! void DisableEventWaiting(void) - SUBROUTINE DisableEventWaiting() BIND(c, name='DisableEventWaiting') - END SUBROUTINE DisableEventWaiting - - ! void EnableCursor(void) - SUBROUTINE EnableCursor() BIND(c, name='EnableCursor') - END SUBROUTINE EnableCursor - - ! void EnableEventWaiting(void) - SUBROUTINE EnableEventWaiting() BIND(c, name='EnableEventWaiting') - END SUBROUTINE EnableEventWaiting - - ! char *EncodeDataBase64(const unsigned char *data, int dataSize, int *outputSize) - function EncodeDataBase64(data, data_size, output_size) bind(c, name='EncodeDataBase64') - IMPORT :: C_INT, c_unsigned_char, C_PTR - IMPLICIT NONE - INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - INTEGER(kind=C_INT), INTENT(out) :: output_size - TYPE(C_PTR) :: EncodeDataBase64 - END FUNCTION EncodeDataBase64 - - ! void EndBlendMode(void) - SUBROUTINE EndBlendMode() BIND(c, name='EndBlendMode') - END SUBROUTINE EndBlendMode - - ! void EndDrawing(void) - SUBROUTINE EndDrawing() BIND(c, name='EndDrawing') - END SUBROUTINE EndDrawing - - ! void EndMode2D(void) - SUBROUTINE EndMode2D() BIND(c, name='EndMode2D') - END SUBROUTINE EndMode2D - - ! void EndMode3D(void) - SUBROUTINE EndMode3D() BIND(c, name='EndMode3D') - END SUBROUTINE EndMode3D - - ! void EndScissorMode(void) - SUBROUTINE EndScissorMode() BIND(c, name='EndScissorMode') - END SUBROUTINE EndScissorMode - - ! void EndShaderMode(void) - SUBROUTINE EndShaderMode() BIND(c, name='EndShaderMode') - END SUBROUTINE EndShaderMode - - ! void EndTextureMode(void) - SUBROUTINE EndTextureMode() BIND(c, name='EndTextureMode') - END SUBROUTINE EndTextureMode - - ! void EndVrStereoMode(void) - SUBROUTINE EndVrStereoMode() BIND(c, name='EndVrStereoMode') - END SUBROUTINE EndVrStereoMode - - ! bool ExportDataAsCode(const unsigned char *data, int dataSize, const char *fileName) - function ExportDataAsCode(data, data_size, file_name) bind(c, name='ExportDataAsCode') - IMPORT :: C_BOOL, C_CHAR, C_INT, c_unsigned_char - IMPLICIT NONE - INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: ExportDataAsCode - END FUNCTION ExportDataAsCode - - ! bool ExportFontAsCode(Font font, const char *fileName) - FUNCTION ExportFontAsCode(font, file_name) BIND(c, name='ExportFontAsCode') - IMPORT :: C_BOOL, C_CHAR, font_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: ExportFontAsCode - END FUNCTION ExportFontAsCode - - ! bool ExportImage(Image image, const char *fileName) - FUNCTION ExportImage(image, file_name) BIND(c, name='ExportImage') - IMPORT :: C_BOOL, C_CHAR, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: ExportImage - END FUNCTION ExportImage - - ! bool ExportImageAsCode(Image image, const char *fileName) -FUNCTION ExportImageAsCode(image, file_name) BIND(c, name='ExportImageAsCode') - IMPORT :: C_BOOL, C_CHAR, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: ExportImageAsCode - END FUNCTION ExportImageAsCode - - ! unsigned char *ExportImageToMemory(Image image, const char *fileType, int *fileSize) - function ExportImageToMemory(image, file_, file_size) bind(c, name='ExportImageToMemory') - IMPORT :: C_CHAR, C_INT, C_PTR, image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - CHARACTER(kind=C_CHAR), INTENT(in) :: file_ - INTEGER(kind=C_INT), INTENT(out) :: file_size - TYPE(C_PTR) :: ExportImageToMemory - END FUNCTION ExportImageToMemory - - ! bool ExportMesh(Mesh mesh, const char *fileName) - FUNCTION ExportMesh(mesh, file_name) BIND(c, name='ExportMesh') - IMPORT :: C_BOOL, C_CHAR, mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in), VALUE :: mesh - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: ExportMesh - END FUNCTION ExportMesh - - ! bool ExportWave(Wave wave, const char *fileName) - FUNCTION ExportWave(wave, file_name) BIND(c, name='ExportWave') - IMPORT :: C_BOOL, C_CHAR, wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in), VALUE :: wave - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: ExportWave - END FUNCTION ExportWave - - ! bool ExportWaveAsCode(Wave wave, const char *fileName) - FUNCTION ExportWaveAsCode(wave, file_name) BIND(c, name='ExportWaveAsCode') - IMPORT :: C_BOOL, C_CHAR, wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in), VALUE :: wave - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: ExportWaveAsCode - END FUNCTION ExportWaveAsCode - - ! Color Fade(Color color, float alpha) - FUNCTION fade(color, alpha) BIND(c, name='Fade') - IMPORT :: C_FLOAT, color_ - IMPLICIT NONE - TYPE(color_), INTENT(in), VALUE :: color - REAL(kind=C_FLOAT), INTENT(in), VALUE :: alpha - TYPE(color_) :: fade - END FUNCTION fade - - ! bool FileExists(const char *fileName) - FUNCTION FileExists(file_name) BIND(c, name='FileExists') - IMPORT :: C_BOOL, C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - LOGICAL(kind=C_BOOL) :: FileExists - END FUNCTION FileExists - - ! void HideCursor(void) - SUBROUTINE HideCursor() BIND(c, name='HideCursor') - END SUBROUTINE HideCursor - - ! void InitAudioDevice(void) - SUBROUTINE InitAudioDevice() BIND(c, name='InitAudioDevice') - END SUBROUTINE InitAudioDevice - - ! void InitWindow(int width, int height, const char *title) - SUBROUTINE InitWindow(width, height, title) BIND(c, name='InitWindow') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - CHARACTER(kind=C_CHAR), INTENT(in) :: title - END SUBROUTINE InitWindow - - ! void MaximizeWindow(void) - SUBROUTINE MaximizeWindow() BIND(c, name='MaximizeWindow') - END SUBROUTINE MaximizeWindow - - ! int MeasureText(const char *text, int fontSize) - FUNCTION MeasureText(text, font_size) BIND(c, name='MeasureText') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size - INTEGER(kind=C_INT) :: MeasureText - END FUNCTION MeasureText - - ! Vector2 MeasureTextEx(Font font, const char *text, float fontSize, float spacing) - function MeasureTextEx(font, text, font_size, spacing) bind(c, name='MeasureTextEx') - IMPORT :: C_CHAR, C_FLOAT, font_, vector2_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - CHARACTER(kind=C_CHAR), INTENT(in) :: text - REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size - REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing - TYPE(vector2_) :: MeasureTextEx - END FUNCTION MeasureTextEx - - ! void *MemAlloc(unsigned int size) - FUNCTION MemAlloc(size) BIND(c, name='MemAlloc') - IMPORT :: C_PTR, c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: size - TYPE(C_PTR) :: MemAlloc - END FUNCTION MemAlloc - - ! void MemFree(void *ptr) - SUBROUTINE MemFree(ptr) BIND(c, name='MemFree') - IMPORT :: C_PTR - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: ptr - END SUBROUTINE MemFree - - ! void *MemRealloc(void *ptr, unsigned int size) - FUNCTION MemRealloc(ptr, size) BIND(c, name='MemRealloc') - IMPORT :: C_PTR, c_unsigned_int - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: ptr - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: size - TYPE(C_PTR) :: MemRealloc - END FUNCTION MemRealloc - - ! void MinimizeWindow(void) - SUBROUTINE MinimizeWindow() BIND(c, name='MinimizeWindow') - END SUBROUTINE MinimizeWindow - - ! void OpenURL(const char *url) - SUBROUTINE OpenURL(url) BIND(c, name='OpenURL') - IMPORT :: C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: url - END SUBROUTINE OpenURL - - ! void PauseAudioStream(AudioStream stream) - SUBROUTINE PauseAudioStream(stream) BIND(c, name='PauseAudioStream') - IMPORT :: audio_stream_ - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - END SUBROUTINE PauseAudioStream - - ! void PauseMusicStream(Music music) - SUBROUTINE PauseMusicStream(music) BIND(c, name='PauseMusicStream') - IMPORT :: music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - END SUBROUTINE PauseMusicStream - - ! void PauseSound(Sound sound) - SUBROUTINE PauseSound(sound) BIND(c, name='PauseSound') - IMPORT :: sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - END SUBROUTINE PauseSound - - ! void PlayAudioStream(AudioStream stream) - SUBROUTINE PlayAudioStream(stream) BIND(c, name='PlayAudioStream') - IMPORT :: audio_stream_ - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - END SUBROUTINE PlayAudioStream - - ! void PlayMusicStream(Music music) - SUBROUTINE PlayMusicStream(music) BIND(c, name='PlayMusicStream') - IMPORT :: music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - END SUBROUTINE PlayMusicStream - - ! void PlaySound(Sound sound) - SUBROUTINE PlaySound(sound) BIND(c, name='PlaySound') - IMPORT :: sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - END SUBROUTINE PlaySound - - ! void PollInputEvents(void) - SUBROUTINE PollInputEvents() BIND(c, name='PollInputEvents') - END SUBROUTINE PollInputEvents - - ! void RestoreWindow(void) - SUBROUTINE RestoreWindow() BIND(c, name='RestoreWindow') - END SUBROUTINE RestoreWindow - - ! void ResumeAudioStream(AudioStream stream) - SUBROUTINE ResumeAudioStream(stream) BIND(c, name='ResumeAudioStream') - IMPORT :: audio_stream_ - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - END SUBROUTINE ResumeAudioStream - - ! void ResumeMusicStream(Music music) - SUBROUTINE ResumeMusicStream(music) BIND(c, name='ResumeMusicStream') - IMPORT :: music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - END SUBROUTINE ResumeMusicStream - - ! void ResumeSound(Sound sound) - SUBROUTINE ResumeSound(sound) BIND(c, name='ResumeSound') - IMPORT :: sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - END SUBROUTINE ResumeSound - - ! bool SaveFileData(const char *fileName, void *data, int dataSize) -FUNCTION SaveFileData(file_name, DATA, data_size) BIND(c, name='SaveFileData') - IMPORT :: C_BOOL, C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - TYPE(C_PTR), INTENT(in), VALUE :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - LOGICAL(kind=C_BOOL) :: SaveFileData - END FUNCTION SaveFileData - - ! bool SaveFileText(const char *fileName, char *text) - FUNCTION SaveFileText(file_name, text) BIND(c, name='SaveFileText') - IMPORT :: C_BOOL, C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - CHARACTER(kind=C_CHAR), INTENT(in) :: text - LOGICAL(kind=C_BOOL) :: SaveFileText - END FUNCTION SaveFileText - - ! void SeekMusicStream(Music music, float position) - SUBROUTINE SeekMusicStream(music, position) BIND(c, name='SeekMusicStream') - IMPORT :: C_FLOAT, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - REAL(kind=C_FLOAT), INTENT(in), VALUE :: position - END SUBROUTINE SeekMusicStream - - ! void ShowCursor(void) - SUBROUTINE ShowCursor() BIND(c, name='ShowCursor') - END SUBROUTINE ShowCursor - - ! void StopAudioStream(AudioStream stream) - SUBROUTINE StopAudioStream(stream) BIND(c, name='StopAudioStream') - IMPORT :: audio_stream_ - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - END SUBROUTINE StopAudioStream - - ! void StopMusicStream(Music music) - SUBROUTINE StopMusicStream(music) BIND(c, name='StopMusicStream') - IMPORT :: music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - END SUBROUTINE StopMusicStream - - ! void StopSound(Sound sound) - SUBROUTINE StopSound(sound) BIND(c, name='StopSound') - IMPORT :: sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - END SUBROUTINE StopSound - - ! void SwapScreenBuffer(void) - SUBROUTINE SwapScreenBuffer() BIND(c, name='SwapScreenBuffer') - END SUBROUTINE SwapScreenBuffer - - ! void TakeScreenshot(const char *fileName) - SUBROUTINE TakeScreenshot(file_name) BIND(c, name='TakeScreenshot') - IMPORT :: C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: file_name - END SUBROUTINE TakeScreenshot - - ! void TextAppend(char *text, const char *append, int *position) - SUBROUTINE TextAppend(text, append, position) BIND(c, name='TextAppend') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - CHARACTER(kind=C_CHAR), INTENT(in) :: append - INTEGER(kind=C_INT), INTENT(in) :: position - END SUBROUTINE TextAppend - - ! int TextCopy(char *dst, const char *src) - FUNCTION TextCopy(dst, src) BIND(c, name='TextCopy') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: dst - CHARACTER(kind=C_CHAR), INTENT(in) :: src - INTEGER(kind=C_INT) :: TextCopy - END FUNCTION TextCopy - - ! int TextFindIndex(const char *text, const char *find) - FUNCTION TextFindIndex(text, find) BIND(c, name='TextFindIndex') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - CHARACTER(kind=C_CHAR), INTENT(in) :: find - INTEGER(kind=C_INT) :: TextFindIndex - END FUNCTION TextFindIndex - - ! char *TextInsert(const char *text, const char *insert, int position) - FUNCTION TextInsert(text, insert, position) BIND(c, name='TextInsert') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - CHARACTER(kind=C_CHAR), INTENT(in) :: insert - INTEGER(kind=C_INT), INTENT(in), VALUE :: position - TYPE(C_PTR) :: TextInsert - END FUNCTION TextInsert - - ! bool TextIsEqual(const char *text1, const char *text2) - FUNCTION TextIsEqual(text1, text2) BIND(c, name='TextIsEqual') - IMPORT :: C_BOOL, C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text1 - CHARACTER(kind=C_CHAR), INTENT(in) :: text2 - LOGICAL(kind=C_BOOL) :: TextIsEqual - END FUNCTION TextIsEqual - - ! const char *TextJoin(const char **textList, int count, const char *delimiter) - FUNCTION TextJoin(text_list, count, delimiter) BIND(c, name='TextJoin') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text_list(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: count - CHARACTER(kind=C_CHAR), INTENT(in) :: delimiter - TYPE(C_PTR) :: TextJoin - END FUNCTION TextJoin - - ! unsigned int TextLength(const char *text) - FUNCTION TextLength(text) BIND(c, name='TextLength') - IMPORT :: C_CHAR, c_unsigned_int - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=c_unsigned_int) :: TextLength - END FUNCTION TextLength - - ! char *TextReplace(char *text, const char *replace, const char *by) - FUNCTION TextReplace(text, replace, by) BIND(c, name='TextReplace') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - CHARACTER(kind=C_CHAR), INTENT(in) :: replace - CHARACTER(kind=C_CHAR), INTENT(in) :: by - TYPE(C_PTR) :: TextReplace - END FUNCTION TextReplace - - ! const char **TextSplit(const char *text, char delimiter, int *count) - FUNCTION TextSplit(text, delimiter, count) BIND(c, name='TextSplit') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - CHARACTER(kind=C_CHAR), INTENT(in), VALUE :: delimiter - INTEGER(kind=C_INT), INTENT(out) :: count - TYPE(C_PTR) :: TextSplit - END FUNCTION TextSplit - - ! const char *TextSubtext(const char *text, int position, int length) - FUNCTION TextSubtext(text, position, length) BIND(c, name='TextSubtext') - IMPORT :: C_CHAR, C_INT, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT), INTENT(in), VALUE :: position - INTEGER(kind=C_INT), INTENT(in), VALUE :: length - TYPE(C_PTR) :: TextSubtext - END FUNCTION TextSubtext - - ! int TextToInteger(const char *text) - FUNCTION TextToInteger(text) BIND(c, name='TextToInteger') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - INTEGER(kind=C_INT) :: TextToInteger - END FUNCTION TextToInteger - - ! const char *TextToLower(const char *text) - FUNCTION TextToLower(text) BIND(c, name='TextToLower') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - TYPE(C_PTR) :: TextToLower - END FUNCTION TextToLower - - ! const char *TextToPascal(const char *text) - FUNCTION TextToPascal(text) BIND(c, name='TextToPascal') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - TYPE(C_PTR) :: TextToPascal - END FUNCTION TextToPascal - - ! const char *TextToUpper(const char *text) - FUNCTION TextToUpper(text) BIND(c, name='TextToUpper') - IMPORT :: C_CHAR, C_PTR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - TYPE(C_PTR) :: TextToUpper - END FUNCTION TextToUpper - - ! void ToggleBorderlessWindowed(void) -SUBROUTINE ToggleBorderlessWindowed() BIND(c, name='ToggleBorderlessWindowed') - END SUBROUTINE ToggleBorderlessWindowed - - ! void ToggleFullscreen(void) - SUBROUTINE ToggleFullscreen() BIND(c, name='ToggleFullscreen') - END SUBROUTINE ToggleFullscreen - - ! void TraceLog(int logLevel, const char *text) - SUBROUTINE TraceLog(log_level, text) BIND(c, name='TraceLog') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: log_level - CHARACTER(kind=C_CHAR), INTENT(in) :: text - END SUBROUTINE TraceLog - - ! void UpdateAudioStream(AudioStream stream, const void *data, int frameCount) - subroutine UpdateAudioStream(stream, data, frame_count) bind(c, name='UpdateAudioStream') - IMPORT :: audio_stream_, C_INT, C_PTR - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - TYPE(C_PTR), INTENT(in), VALUE :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: frame_count - END SUBROUTINE UpdateAudioStream - - ! void UpdateCamera(Camera *camera, int mode) - SUBROUTINE UpdateCamera(camera, mode) BIND(c, name='UpdateCamera') - IMPORT :: camera3d_, C_INT - IMPLICIT NONE - TYPE(camera3d_), INTENT(inout) :: camera - INTEGER(kind=C_INT), INTENT(in), VALUE :: mode - END SUBROUTINE UpdateCamera - - ! void UpdateMeshBuffer(Mesh mesh, int index, const void *data, int dataSize, int offset) - subroutine UpdateMeshBuffer(mesh, index, data, data_size, offset) bind(c, name='UpdateMeshBuffer') - IMPORT :: C_INT, C_PTR, mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in), VALUE :: mesh - INTEGER(kind=C_INT), INTENT(in), VALUE :: index - TYPE(C_PTR), INTENT(in), VALUE :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size - INTEGER(kind=C_INT), INTENT(in), VALUE :: offset - END SUBROUTINE UpdateMeshBuffer - - ! void UpdateModelAnimation(Model model, ModelAnimation anim, int frame) - subroutine UpdateModelAnimation(model, anim, frame) bind(c, name='UpdateModelAnimation') - IMPORT :: C_INT, model_animation_, model_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - TYPE(model_animation_), INTENT(in), VALUE :: anim - INTEGER(kind=C_INT), INTENT(in), VALUE :: frame - END SUBROUTINE UpdateModelAnimation - - ! void UpdateMusicStream(Music music) - SUBROUTINE UpdateMusicStream(music) BIND(c, name='UpdateMusicStream') - IMPORT :: music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - END SUBROUTINE UpdateMusicStream - - ! void UpdateSound(Sound sound, const void *data, int sampleCount) - SUBROUTINE UpdateSound(sound, DATA, sample_count) BIND(c, name='UpdateSound') - IMPORT :: C_INT, C_PTR, sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - TYPE(C_PTR), INTENT(in), VALUE :: DATA - INTEGER(kind=C_INT), INTENT(in), VALUE :: sample_count - END SUBROUTINE UpdateSound - - ! void UpdateTexture(Texture2D texture, const void *pixels) - SUBROUTINE UpdateTexture(texture, pixels) BIND(c, name='UpdateTexture') - IMPORT :: C_PTR, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(C_PTR), INTENT(in), VALUE :: pixels - END SUBROUTINE UpdateTexture - - ! void UpdateTextureRec(Texture2D texture, Rectangle rec, const void *pixels) - subroutine UpdateTextureRec(texture, rec, pixels) bind(c, name='UpdateTextureRec') - IMPORT :: C_PTR, rectangle_, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(rectangle_), INTENT(in), VALUE :: rec - TYPE(C_PTR), INTENT(in), VALUE :: pixels - END SUBROUTINE UpdateTextureRec - - ! void UploadMesh(Mesh *mesh, bool dynamic) - SUBROUTINE UploadMesh(mesh, dynamic) BIND(c, name='UploadMesh') - IMPORT :: C_BOOL, mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(inout) :: mesh - LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: dynamic - END SUBROUTINE UploadMesh - - ! void WaitTime(double seconds) - SUBROUTINE WaitTime(seconds) BIND(c, name='WaitTime') - IMPORT :: C_DOUBLE - IMPLICIT NONE - REAL(kind=C_DOUBLE), INTENT(in), VALUE :: seconds - END SUBROUTINE WaitTime - - ! Wave WaveCopy(Wave wave) - FUNCTION WaveCopy(wave) BIND(c, name='WaveCopy') - IMPORT :: wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in), VALUE :: wave - TYPE(wave_) :: WaveCopy - END FUNCTION WaveCopy - - ! void WaveCrop(Wave *wave, int initSample, int finalSample) - SUBROUTINE WaveCrop(wave, init_sample, final_sample) BIND(c, name='WaveCrop') - IMPORT :: C_INT, wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in) :: wave - INTEGER(kind=C_INT), INTENT(in), VALUE :: init_sample - INTEGER(kind=C_INT), INTENT(in), VALUE :: final_sample - END SUBROUTINE WaveCrop - - ! void WaveFormat(Wave *wave, int sampleRate, int sampleSize, int channels) - subroutine WaveFormat(wave, sample_rate, sample_size, channels) bind(c, name='WaveFormat') - IMPORT :: C_INT, wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in) :: wave - INTEGER(kind=C_INT), INTENT(in), VALUE :: sample_rate - INTEGER(kind=C_INT), INTENT(in), VALUE :: sample_size - INTEGER(kind=C_INT), INTENT(in), VALUE :: channels - END SUBROUTINE WaveFormat - - ! bool WindowShouldClose(void) - FUNCTION WindowShouldClose() BIND(c, name='WindowShouldClose') - IMPORT :: C_BOOL - IMPLICIT NONE - LOGICAL(kind=C_BOOL) :: WindowShouldClose - END FUNCTION WindowShouldClose -END INTERFACE -CONTAINS -ELEMENTAL REAL FUNCTION deg2rad(d) RESULT(r) - REAL, INTENT(in) :: d - - r = d * (PI / 180.0) -END FUNCTION deg2rad - -ELEMENTAL REAL FUNCTION rad2deg(r) RESULT(d) - REAL, INTENT(in) :: r - - d = r * (180.0 / PI) -END FUNCTION rad2deg -END MODULE RaylibMethods diff --git a/src/modules/RaylibInterface/src/RaylibSetMethods.F90 b/src/modules/RaylibInterface/src/RaylibSetMethods.F90 deleted file mode 100644 index 947be0d0a..000000000 --- a/src/modules/RaylibInterface/src/RaylibSetMethods.F90 +++ /dev/null @@ -1,503 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibSetMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: SetWindowTitle -PUBLIC :: SetWindowState -PUBLIC :: SetWindowSize -PUBLIC :: SetWindowPosition -PUBLIC :: SetWindowOpacity -PUBLIC :: SetWindowMonitor -PUBLIC :: SetWindowMinSize -PUBLIC :: SetWindowMaxSize -PUBLIC :: SetWindowIcons -PUBLIC :: SetWindowIcon -PUBLIC :: SetWindowFocused -PUBLIC :: SetTraceLogLevel -PUBLIC :: SetTraceLogCallback -PUBLIC :: SetTextureWrap -PUBLIC :: SetTextureFilter -PUBLIC :: SetTextLineSpacing -PUBLIC :: SetTargetFPS -PUBLIC :: SetSoundVolume -PUBLIC :: SetSoundPitch -PUBLIC :: SetSoundPan -PUBLIC :: SetShapesTexture -PUBLIC :: SetShaderValueV -PUBLIC :: SetShaderValueTexture -PUBLIC :: SetShaderValueMatrix -PUBLIC :: SetShaderValue -PUBLIC :: SetSaveFileTextCallback -PUBLIC :: SetSaveFileDataCallback -PUBLIC :: SetRandomSeed -PUBLIC :: SetPixelColor -PUBLIC :: SetMusicVolume -PUBLIC :: SetMusicPitch -PUBLIC :: SetMusicPan -PUBLIC :: SetMouseScale -PUBLIC :: SetMousePosition -PUBLIC :: SetMouseOffset -PUBLIC :: SetMouseCursor -PUBLIC :: SetModelMeshMaterial -PUBLIC :: SetMaterialTexture -PUBLIC :: SetMasterVolume -PUBLIC :: SetLoadFileTextCallback -PUBLIC :: SetLoadFileDataCallback -PUBLIC :: SetGesturesEnabled -PUBLIC :: SetGamepadMappings -PUBLIC :: SetExitKey -PUBLIC :: SetConfigFlags -PUBLIC :: SetClipboardText -PUBLIC :: SetCameraSmoothZoomControl -PUBLIC :: SetCameraPanControl -PUBLIC :: SetCameraMoveControls -PUBLIC :: SetCameraMode -PUBLIC :: SetCameraAltControl -PUBLIC :: SetAudioStreamVolume -PUBLIC :: SetAudioStreamPitch -PUBLIC :: SetAudioStreamPan -PUBLIC :: SetAudioStreamBufferSizeDefault - -INTERFACE - - ! void SetAudioStreamBufferSizeDefault(int size) - subroutine SetAudioStreamBufferSizeDefault(size) bind(c, name='SetAudioStreamBufferSizeDefault') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: size - END SUBROUTINE SetAudioStreamBufferSizeDefault - - ! void SetAudioStreamPan(AudioStream stream, float pan) - SUBROUTINE SetAudioStreamPan(stream, pan) BIND(c, name='SetAudioStreamPan') - IMPORT :: audio_stream_, C_FLOAT - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - REAL(kind=C_FLOAT), INTENT(in), VALUE :: pan - END SUBROUTINE SetAudioStreamPan - - ! void SetAudioStreamPitch(AudioStream stream, float pitch) - subroutine SetAudioStreamPitch(stream, pitch) bind(c, name='SetAudioStreamPitch') - IMPORT :: audio_stream_, C_FLOAT - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch - END SUBROUTINE SetAudioStreamPitch - - ! void SetAudioStreamVolume(AudioStream stream, float volume) - subroutine SetAudioStreamVolume(stream, volume) bind(c, name='SetAudioStreamVolume') - IMPORT :: audio_stream_, C_FLOAT - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume - END SUBROUTINE SetAudioStreamVolume - - ! void SetCameraAltControl(int keyAlt) - SUBROUTINE SetCameraAltControl(key_alt) BIND(c, name='SetCameraAltControl') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_alt - END SUBROUTINE SetCameraAltControl - - ! void SetCameraMode(Camera camera, int mode) - SUBROUTINE SetCameraMode(camera, mode) BIND(c, name='SetCameraMode') - IMPORT :: C_INT, camera3d_ - IMPLICIT NONE - TYPE(camera3d_), INTENT(in), VALUE :: camera - INTEGER(kind=C_INT), INTENT(in), VALUE :: mode - END SUBROUTINE SetCameraMode - - ! void SetCameraMoveControls(int keyFront, int keyBack, int keyRight, int keyLeft, int keyUp, int keyDown) - subroutine SetCameraMoveControls(key_front, key_back, key_right, key_left, key_up, key_down) & - BIND(c, name='SetCameraMoveControls') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_front - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_back - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_right - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_left - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_up - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_down - END SUBROUTINE SetCameraMoveControls - - ! void SetCameraPanControl(int keyPan) - SUBROUTINE SetCameraPanControl(key_pan) BIND(c, name='SetCameraPanControl') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_pan - END SUBROUTINE SetCameraPanControl - - ! void SetCameraSmoothZoomControl(int keySmoothZoom) - subroutine SetCameraSmoothZoomControl(key_smooth_zoom) bind(c, name='SetCameraSmoothZoomControl') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key_smooth_zoom - END SUBROUTINE SetCameraSmoothZoomControl - - ! void SetClipboardText(const char *text) - SUBROUTINE SetClipboardText(text) BIND(c, name='SetClipboardText') - IMPORT :: C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - END SUBROUTINE SetClipboardText - - ! void SetConfigFlags(unsigned int flags) - SUBROUTINE SetConfigFlags(flags) BIND(c, name='SetConfigFlags') - IMPORT :: c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags - END SUBROUTINE SetConfigFlags - - ! void SetExitKey(int key) - SUBROUTINE SetExitKey(key) BIND(c, name='SetExitKey') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: key - END SUBROUTINE SetExitKey - - ! int SetGamepadMappings(const char *mappings) - FUNCTION SetGamepadMappings(mappings) BIND(c, name='SetGamepadMappings') - IMPORT :: C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: mappings - INTEGER(kind=C_INT) :: SetGamepadMappings - END FUNCTION SetGamepadMappings - - ! void SetGesturesEnabled(unsigned int flags) - SUBROUTINE SetGesturesEnabled(flags) BIND(c, name='SetGesturesEnabled') - IMPORT :: c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags - END SUBROUTINE SetGesturesEnabled - - ! void SetLoadFileDataCallback(LoadFileDataCallback callback) - subroutine SetLoadFileDataCallback(callback) bind(c, name='SetLoadFileDataCallback') - IMPORT :: C_FUNPTR - IMPLICIT NONE - TYPE(C_FUNPTR), INTENT(in), VALUE :: callback - END SUBROUTINE SetLoadFileDataCallback - - ! void SetLoadFileTextCallback(LoadFileTextCallback callback) - subroutine SetLoadFileTextCallback(callback) bind(c, name='SetLoadFileTextCallback') - IMPORT :: C_FUNPTR - IMPLICIT NONE - TYPE(C_FUNPTR), INTENT(in), VALUE :: callback - END SUBROUTINE SetLoadFileTextCallback - - ! void SetMasterVolume(float volume) - SUBROUTINE SetMasterVolume(volume) BIND(c, name='SetMasterVolume') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume - END SUBROUTINE SetMasterVolume - - ! void SetMaterialTexture(Material *material, int mapType, Texture2D texture) - subroutine SetMaterialTexture(material, map_, texture) bind(c, name='SetMaterialTexture') - IMPORT :: C_INT, material_, texture2d_ - IMPLICIT NONE - TYPE(material_), INTENT(inout) :: material - INTEGER(kind=C_INT), INTENT(in), VALUE :: map_ - TYPE(texture2d_), INTENT(in), VALUE :: texture - END SUBROUTINE SetMaterialTexture - - ! void SetModelMeshMaterial(Model *model, int meshId, int materialId) - subroutine SetModelMeshMaterial(model, mesh_id, material_id) bind(c, name='SetModelMeshMaterial') - IMPORT :: C_INT, model_ - IMPLICIT NONE - TYPE(model_), INTENT(inout) :: model - INTEGER(kind=C_INT), INTENT(in), VALUE :: mesh_id - INTEGER(kind=C_INT), INTENT(in), VALUE :: material_id - END SUBROUTINE SetModelMeshMaterial - - ! void SetMouseCursor(int cursor) - SUBROUTINE SetMouseCursor(cursor) BIND(c, name='SetMouseCursor') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: cursor - END SUBROUTINE SetMouseCursor - - ! void SetMouseOffset(int offsetX, int offsetY) - SUBROUTINE SetMouseOffset(offset_x, offset_y) BIND(c, name='SetMouseOffset') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_x - INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_y - END SUBROUTINE SetMouseOffset - - ! void SetMousePosition(int x, int y) - SUBROUTINE SetMousePosition(x, y) BIND(c, name='SetMousePosition') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: x - INTEGER(kind=C_INT), INTENT(in), VALUE :: y - END SUBROUTINE SetMousePosition - - ! void SetMouseScale(float scaleX, float scaleY) - SUBROUTINE SetMouseScale(scale_x, scale_y) BIND(c, name='SetMouseScale') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale_x - REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale_y - END SUBROUTINE SetMouseScale - - ! void SetMusicPan(Music music, float pan) - SUBROUTINE SetMusicPan(music, pan) BIND(c, name='SetMusicPan') - IMPORT :: C_FLOAT, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - REAL(kind=C_FLOAT), INTENT(in), VALUE :: pan - END SUBROUTINE SetMusicPan - - ! void SetMusicPitch(Music music, float pitch) - SUBROUTINE SetMusicPitch(music, pitch) BIND(c, name='SetMusicPitch') - IMPORT :: C_FLOAT, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch - END SUBROUTINE SetMusicPitch - - ! void SetMusicVolume(Music music, float volume) - SUBROUTINE SetMusicVolume(music, volume) BIND(c, name='SetMusicVolume') - IMPORT :: C_FLOAT, music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume - END SUBROUTINE SetMusicVolume - - ! void SetPixelColor(void *dstPtr, Color color, int format) -SUBROUTINE SetPixelColor(dst_ptr, color, FORMAT) BIND(c, name='SetPixelColor') - IMPORT :: C_INT, C_PTR, color_ - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: dst_ptr - TYPE(color_), INTENT(in), VALUE :: color - INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT - END SUBROUTINE SetPixelColor - - ! void SetRandomSeed(unsigned int seed) - SUBROUTINE SetRandomSeed(seed) BIND(c, name='SetRandomSeed') - IMPORT :: c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: seed - END SUBROUTINE SetRandomSeed - - ! void SetSaveFileDataCallback(SaveFileDataCallback callback) - subroutine SetSaveFileDataCallback(callback) bind(c, name='SetSaveFileDataCallback') - IMPORT :: C_FUNPTR - IMPLICIT NONE - TYPE(C_FUNPTR), INTENT(in), VALUE :: callback - END SUBROUTINE SetSaveFileDataCallback - - ! void SetSaveFileTextCallback(SaveFileTextCallback callback) - subroutine SetSaveFileTextCallback(callback) bind(c, name='SetSaveFileTextCallback') - IMPORT :: C_FUNPTR - IMPLICIT NONE - TYPE(C_FUNPTR), INTENT(in), VALUE :: callback - END SUBROUTINE SetSaveFileTextCallback - - ! void SetShaderValue(Shader shader, int locIndex, const void *value, int uniformType) - subroutine SetShaderValue(shader, loc_index, value, uniform_) bind(c, name='SetShaderValue') - IMPORT :: C_INT, C_PTR, shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index - TYPE(C_PTR), INTENT(in), VALUE :: VALUE - INTEGER(kind=C_INT), INTENT(in), VALUE :: uniform_ - END SUBROUTINE SetShaderValue - - ! void SetShaderValueMatrix(Shader shader, int locIndex, Matrix mat) - subroutine SetShaderValueMatrix(shader, loc_index, mat) bind(c, name='SetShaderValueMatrix') - IMPORT :: C_INT, matrix_, shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index - TYPE(matrix_), INTENT(in), VALUE :: mat - END SUBROUTINE SetShaderValueMatrix - - ! void SetShaderValueTexture(Shader shader, int locIndex, Texture2D texture) - subroutine SetShaderValueTexture(shader, loc_index, texture) bind(c, name='SetShaderValueTexture') - IMPORT :: C_INT, shader_, texture2d_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index - TYPE(texture2d_), INTENT(in), VALUE :: texture - END SUBROUTINE SetShaderValueTexture - - ! void SetShaderValueV(Shader shader, int locIndex, const void *value, int uniformType, int count) - subroutine SetShaderValueV(shader, loc_index, value, uniform_, count) bind(c, name='SetShaderValueV') - IMPORT :: C_INT, C_PTR, shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index - TYPE(C_PTR), INTENT(in), VALUE :: VALUE - INTEGER(kind=C_INT), INTENT(in), VALUE :: uniform_ - INTEGER(kind=C_INT), INTENT(in), VALUE :: count - END SUBROUTINE SetShaderValueV - - ! void SetShapesTexture(Texture2D texture, Rectangle source) - SUBROUTINE SetShapesTexture(texture, source) BIND(c, name='SetShapesTexture') - IMPORT :: rectangle_, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - TYPE(rectangle_), INTENT(in), VALUE :: source - END SUBROUTINE SetShapesTexture - - ! void SetSoundPan(Sound sound, float pan) - SUBROUTINE SetSoundPan(sound, pan) BIND(c, name='SetSoundPan') - IMPORT :: C_FLOAT, sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - REAL(kind=C_FLOAT), INTENT(in), VALUE :: pan - END SUBROUTINE SetSoundPan - - ! void SetSoundPitch(Sound sound, float pitch) - SUBROUTINE SetSoundPitch(sound, pitch) BIND(c, name='SetSoundPitch') - IMPORT :: C_FLOAT, sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch - END SUBROUTINE SetSoundPitch - - ! void SetSoundVolume(Sound sound, float volume) - SUBROUTINE SetSoundVolume(sound, volume) BIND(c, name='SetSoundVolume') - IMPORT :: C_FLOAT, sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume - END SUBROUTINE SetSoundVolume - - ! void SetTargetFPS(int fps) - SUBROUTINE SetTargetFPS(fps) BIND(c, name='SetTargetFPS') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: fps - END SUBROUTINE SetTargetFPS - - ! void SetTextLineSpacing(int spacing) - SUBROUTINE SetTextLineSpacing(spacing) BIND(c, name='SetTextLineSpacing') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: spacing - END SUBROUTINE SetTextLineSpacing - - ! void SetTextureFilter(Texture2D texture, int filter) - SUBROUTINE SetTextureFilter(texture, filter) BIND(c, name='SetTextureFilter') - IMPORT :: C_INT, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - INTEGER(kind=C_INT), INTENT(in), VALUE :: filter - END SUBROUTINE SetTextureFilter - - ! void SetTextureWrap(Texture2D texture, int wrap) - SUBROUTINE SetTextureWrap(texture, wrap) BIND(c, name='SetTextureWrap') - IMPORT :: C_INT, texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - INTEGER(kind=C_INT), INTENT(in), VALUE :: wrap - END SUBROUTINE SetTextureWrap - - ! void SetTraceLogCallback(TraceLogCallback callback) - SUBROUTINE SetTraceLogCallback(callback) BIND(c, name='SetTraceLogCallback') - IMPORT :: C_FUNPTR - IMPLICIT NONE - TYPE(C_FUNPTR), INTENT(in), VALUE :: callback - END SUBROUTINE SetTraceLogCallback - - ! void SetTraceLogLevel(int logLevel) - SUBROUTINE SetTraceLogLevel(log_level) BIND(c, name='SetTraceLogLevel') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: log_level - END SUBROUTINE SetTraceLogLevel - - ! void SetWindowFocused(void) - SUBROUTINE SetWindowFocused() BIND(c, name='SetWindowFocused') - END SUBROUTINE SetWindowFocused - - ! void SetWindowIcon(Image image) - SUBROUTINE SetWindowIcon(image) BIND(c, name='SetWindowIcon') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - END SUBROUTINE SetWindowIcon - - ! void SetWindowIcons(Image *images, int count) - SUBROUTINE SetWindowIcons(images, count) BIND(c, name='SetWindowIcons') - IMPORT :: C_INT, image_ - IMPLICIT NONE - TYPE(image_), INTENT(inout) :: images - INTEGER(kind=C_INT), INTENT(in), VALUE :: count - END SUBROUTINE SetWindowIcons - - ! void SetWindowMaxSize(int width, int height) - SUBROUTINE SetWindowMaxSize(width, height) BIND(c, name='SetWindowMaxSize') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - END SUBROUTINE SetWindowMaxSize - - ! void SetWindowMinSize(int width, int height) - SUBROUTINE SetWindowMinSize(width, height) BIND(c, name='SetWindowMinSize') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - END SUBROUTINE SetWindowMinSize - - ! void SetWindowMonitor(int monitor) - SUBROUTINE SetWindowMonitor(monitor) BIND(c, name='SetWindowMonitor') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor - END SUBROUTINE SetWindowMonitor - - ! void SetWindowOpacity(float opacity) - SUBROUTINE SetWindowOpacity(opacity) BIND(c, name='SetWindowOpacity') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(in), VALUE :: opacity - END SUBROUTINE SetWindowOpacity - - ! void SetWindowPosition(int x, int y) - SUBROUTINE SetWindowPosition(x, y) BIND(c, name='SetWindowPosition') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: x - INTEGER(kind=C_INT), INTENT(in), VALUE :: y - END SUBROUTINE SetWindowPosition - - ! void SetWindowSize(int width, int height) - SUBROUTINE SetWindowSize(width, height) BIND(c, name='SetWindowSize') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(in), VALUE :: width - INTEGER(kind=C_INT), INTENT(in), VALUE :: height - END SUBROUTINE SetWindowSize - - ! void SetWindowState(unsigned int flags) - SUBROUTINE SetWindowState(flags) BIND(c, name='SetWindowState') - IMPORT :: c_unsigned_int - IMPLICIT NONE - INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags - END SUBROUTINE SetWindowState - - ! void SetWindowTitle(const char *title) - SUBROUTINE SetWindowTitle(title) BIND(c, name='SetWindowTitle') - IMPORT :: C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: title - END SUBROUTINE SetWindowTitle - -END INTERFACE - -END MODULE RaylibSetMethods diff --git a/src/modules/RaylibInterface/src/RaylibTypes.F90 b/src/modules/RaylibInterface/src/RaylibTypes.F90 deleted file mode 100644 index 52f7725ad..000000000 --- a/src/modules/RaylibInterface/src/RaylibTypes.F90 +++ /dev/null @@ -1,380 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-02 -! summary: I have subdivided the big raylib module into smaller modules - -MODULE RaylibTypes -USE, INTRINSIC :: ISO_C_BINDING -IMPLICIT NONE -PRIVATE - -INTEGER, PARAMETER, PUBLIC :: c_unsigned_int = C_INT -INTEGER, PARAMETER, PUBLIC :: c_unsigned_char = C_SIGNED_CHAR - -REAL, PARAMETER, PUBLIC :: PI = ACOS(-1.0) - -! Vector2 -TYPE, BIND(c), PUBLIC :: vector2_ - REAL(kind=C_FLOAT) :: x = 0.0 - REAL(kind=C_FLOAT) :: y = 0.0 -END TYPE vector2_ - -! Vector3 -TYPE, BIND(c), PUBLIC :: vector3_ - REAL(kind=C_FLOAT) :: x = 0.0 - REAL(kind=C_FLOAT) :: y = 0.0 - REAL(kind=C_FLOAT) :: z = 0.0 -END TYPE vector3_ - -! Vector4 -TYPE, BIND(c), PUBLIC :: vector4_ - REAL(kind=C_FLOAT) :: x = 0.0 - REAL(kind=C_FLOAT) :: y = 0.0 - REAL(kind=C_FLOAT) :: z = 0.0 - REAL(kind=C_FLOAT) :: w = 0.0 -END TYPE vector4_ - -! Quaternion -TYPE, BIND(c), PUBLIC :: quaternion_ - REAL(kind=C_FLOAT) :: x = 0.0 - REAL(kind=C_FLOAT) :: y = 0.0 - REAL(kind=C_FLOAT) :: z = 0.0 - REAL(kind=C_FLOAT) :: w = 0.0 -END TYPE quaternion_ - -! Matrix -TYPE, BIND(c), PUBLIC :: matrix_ - REAL(kind=C_FLOAT) :: m0 = 0.0, m4 = 0.0, m8 = 0.0, m12 = 0.0 - REAL(kind=C_FLOAT) :: m1 = 0.0, m5 = 0.0, m9 = 0.0, m13 = 0.0 - REAL(kind=C_FLOAT) :: m2 = 0.0, m6 = 0.0, m10 = 0.0, m14 = 0.0 - REAL(kind=C_FLOAT) :: m3 = 0.0, m7 = 0.0, m11 = 0.0, m15 = 0.0 -END TYPE matrix_ - -! Color -TYPE, BIND(c), PUBLIC :: color_ - INTEGER(kind=c_unsigned_char) :: r = 0_C_UNSIGNED_CHAR - INTEGER(kind=c_unsigned_char) :: g = 0_C_UNSIGNED_CHAR - INTEGER(kind=c_unsigned_char) :: b = 0_C_UNSIGNED_CHAR - INTEGER(kind=c_unsigned_char) :: a = 255_C_UNSIGNED_CHAR -END TYPE color_ - -! Rectangle -TYPE, BIND(c), PUBLIC :: rectangle_ - REAL(kind=C_FLOAT) :: x = 0.0 - REAL(kind=C_FLOAT) :: y = 0.0 - REAL(kind=C_FLOAT) :: width = 0.0 - REAL(kind=C_FLOAT) :: height = 0.0 -END TYPE rectangle_ - -! Image -TYPE, BIND(c), PUBLIC :: image_ - TYPE(C_PTR) :: DATA = C_NULL_PTR !! void * - INTEGER(kind=C_INT) :: width = 0 - INTEGER(kind=C_INT) :: height = 0 - INTEGER(kind=C_INT) :: mipmaps = 0 - INTEGER(kind=C_INT) :: FORMAT = 0 -END TYPE image_ - -! Texture2D -TYPE, BIND(c), PUBLIC :: texture2d_ - INTEGER(kind=c_unsigned_int) :: id = 0 - INTEGER(kind=C_INT) :: width = 0 - INTEGER(kind=C_INT) :: height = 0 - INTEGER(kind=C_INT) :: mipmaps = 0 - INTEGER(kind=C_INT) :: FORMAT = 0 -END TYPE texture2d_ - -! TextureCubemap -TYPE, BIND(c), PUBLIC :: texture_cubemap_ - INTEGER(kind=c_unsigned_int) :: id = 0_C_UNSIGNED_INT - INTEGER(kind=C_INT) :: width = 0 - INTEGER(kind=C_INT) :: height = 0 - INTEGER(kind=C_INT) :: mipmaps = 0 - INTEGER(kind=C_INT) :: FORMAT = 0 -END TYPE texture_cubemap_ - -! RenderTexture -TYPE, BIND(c), PUBLIC :: render_texture_ - INTEGER(kind=c_unsigned_int) :: id = 0_C_UNSIGNED_INT - TYPE(texture2d_) :: texture - TYPE(texture2d_) :: depth -END TYPE render_texture_ - -! RenderTexture2D -TYPE, BIND(c), PUBLIC :: render_texture2d_ - INTEGER(kind=c_unsigned_int) :: id = 0_C_UNSIGNED_INT - TYPE(texture2d_) :: texture - TYPE(texture2d_) :: depth -END TYPE render_texture2d_ - -! NPatchInfo -TYPE, BIND(c), PUBLIC :: npatch_info_ - TYPE(rectangle_) :: source - INTEGER(kind=C_INT) :: left = 0 - INTEGER(kind=C_INT) :: top = 0 - INTEGER(kind=C_INT) :: right = 0 - INTEGER(kind=C_INT) :: bottom = 0 - INTEGER(kind=C_INT) :: layout = 0 -END TYPE npatch_info_ - -! GlyphInfo -TYPE, BIND(c), PUBLIC :: glyph_info_ - INTEGER(kind=C_INT) :: VALUE = 0 - INTEGER(kind=C_INT) :: offset_x = 0 - INTEGER(kind=C_INT) :: offset_y = 0 - INTEGER(kind=C_INT) :: advance_x = 0 - TYPE(image_) :: image -END TYPE glyph_info_ - -! Font -TYPE, BIND(c), PUBLIC :: font_ - INTEGER(kind=C_INT) :: base_size = 0 - INTEGER(kind=C_INT) :: glyph_count = 0 - INTEGER(kind=C_INT) :: glyph_padding = 0 - TYPE(texture2d_) :: texture - TYPE(C_PTR) :: recs = C_NULL_PTR !! Rectangle * - TYPE(C_PTR) :: glyphs = C_NULL_PTR !! GlyphInfo * -END TYPE font_ - -! Camera, Camera3D -TYPE, BIND(c), PUBLIC :: camera3d_ - TYPE(vector3_) :: position - TYPE(vector3_) :: TARGET - TYPE(vector3_) :: up - REAL(kind=C_FLOAT) :: fovy = 0.0 - INTEGER(kind=C_INT) :: projection = 0 -END TYPE camera3d_ - -! Camera2D -TYPE, BIND(c), PUBLIC :: camera2d_ - TYPE(vector2_) :: offset - TYPE(vector2_) :: TARGET - REAL(kind=C_FLOAT) :: rotation = 0.0 - REAL(kind=C_FLOAT) :: zoom = 0.0 -END TYPE camera2d_ - -! Mesh -TYPE, BIND(c), PUBLIC :: mesh_ - INTEGER(kind=C_INT) :: vertex_count = 0 - INTEGER(kind=C_INT) :: triangle_count = 0 - TYPE(C_PTR) :: vertices = C_NULL_PTR !! float * - TYPE(C_PTR) :: texcoords = C_NULL_PTR !! float * - TYPE(C_PTR) :: texcoords2 = C_NULL_PTR !! float * - TYPE(C_PTR) :: normals = C_NULL_PTR !! float * - TYPE(C_PTR) :: tangents = C_NULL_PTR !! float * - TYPE(C_PTR) :: colors = C_NULL_PTR !! unsigned char * - TYPE(C_PTR) :: indices = C_NULL_PTR !! unsigned short * - TYPE(C_PTR) :: anim_vertices = C_NULL_PTR !! float * - TYPE(C_PTR) :: anim_normals = C_NULL_PTR !! float * - TYPE(C_PTR) :: bone_ids = C_NULL_PTR !! unsigned char * - TYPE(C_PTR) :: bone_weights = C_NULL_PTR !! float * - INTEGER(kind=c_unsigned_int) :: vao_id = 0_C_UNSIGNED_INT - TYPE(C_PTR) :: vbo_id = C_NULL_PTR !! unsigned int * -END TYPE mesh_ - -! Shader -TYPE, BIND(c), PUBLIC :: shader_ - INTEGER(kind=c_unsigned_int) :: id = 0 - TYPE(C_PTR) :: locs = C_NULL_PTR !! int * -END TYPE shader_ - -! MaterialMap -TYPE, BIND(c), PUBLIC :: material_map_ - TYPE(texture2d_) :: texture - TYPE(color_) :: color - REAL(kind=C_FLOAT) :: VALUE = 0 -END TYPE material_map_ - -! Material -TYPE, BIND(c), PUBLIC :: material_ - TYPE(shader_) :: shader - TYPE(C_PTR) :: maps = C_NULL_PTR !! MaterialMap * - REAL(kind=C_FLOAT) :: params(0:3) = 0.0 -END TYPE material_ - -! Transform -TYPE, BIND(c), PUBLIC :: transform_ - TYPE(vector3_) :: translation - TYPE(quaternion_) :: rotation - TYPE(vector3_) :: scale -END TYPE transform_ - -! BoneInfo -TYPE, BIND(c), PUBLIC :: bone_info_ - CHARACTER(kind=C_CHAR) :: name(0:31) = C_NULL_CHAR - INTEGER(kind=C_INT) :: parent = 0 -END TYPE bone_info_ - -! Model -TYPE, BIND(c), PUBLIC :: model_ - TYPE(matrix_) :: transform - INTEGER(kind=C_INT) :: mesh_count = 0 - INTEGER(kind=C_INT) :: material_count = 0 - TYPE(C_PTR) :: meshes = C_NULL_PTR !! Mesh * - TYPE(C_PTR) :: materials = C_NULL_PTR !! Material * - TYPE(C_PTR) :: mesh_material = C_NULL_PTR !! int * - INTEGER(kind=C_INT) :: bone_count = 0 - TYPE(C_PTR) :: bones = C_NULL_PTR !! BoneInfo * - TYPE(C_PTR) :: bind_pose = C_NULL_PTR !! Transform * -END TYPE model_ - -! ModelAnimation -TYPE, BIND(c), PUBLIC :: model_animation_ - INTEGER(kind=C_INT) :: bone_count = 0 - INTEGER(kind=C_INT) :: frame_count = 0 - TYPE(C_PTR) :: bones = C_NULL_PTR !! BoneInfo * - TYPE(C_PTR) :: frame_poses = C_NULL_PTR !! Transform ** - CHARACTER(kind=C_CHAR) :: name(0:31) = C_NULL_CHAR -END TYPE model_animation_ - -! Ray -TYPE, BIND(c), PUBLIC :: ray_ - TYPE(vector3_) :: position - TYPE(vector3_) :: direction -END TYPE ray_ - -! RayCollision -TYPE, BIND(c), PUBLIC :: ray_collision_ - LOGICAL(kind=C_BOOL) :: hit = .FALSE._C_BOOL - REAL(kind=C_FLOAT) :: distance = 0.0 - TYPE(vector3_) :: point - TYPE(vector3_) :: normal -END TYPE ray_collision_ - -! BoundingBox -TYPE, BIND(c), PUBLIC :: bounding_box_ - TYPE(vector3_) :: min - TYPE(vector3_) :: max -END TYPE bounding_box_ - -! Wave -TYPE, BIND(c), PUBLIC :: wave_ - INTEGER(kind=c_unsigned_int) :: frame_count = 0_C_UNSIGNED_INT - INTEGER(kind=c_unsigned_int) :: sample_rate = 0_C_UNSIGNED_INT - INTEGER(kind=c_unsigned_int) :: sample_size = 0_C_UNSIGNED_INT - INTEGER(kind=c_unsigned_int) :: channels = 0_C_UNSIGNED_INT - TYPE(C_PTR) :: DATA = C_NULL_PTR !! void * -END TYPE wave_ - -! AudioStream -TYPE, BIND(c), PUBLIC :: audio_stream_ - TYPE(C_PTR) :: buffer = C_NULL_PTR !! rAudioBuffer * - TYPE(C_PTR) :: processor = C_NULL_PTR !! rAudioProcessor * - INTEGER(kind=c_unsigned_int) :: sample_rate = 0_C_UNSIGNED_INT - INTEGER(kind=c_unsigned_int) :: sample_size = 0_C_UNSIGNED_INT - INTEGER(kind=c_unsigned_int) :: channels = 0_C_UNSIGNED_INT -END TYPE audio_stream_ - -! Sound -TYPE, BIND(c), PUBLIC :: sound_ - TYPE(audio_stream_) :: stream - INTEGER(kind=c_unsigned_int) :: frame_count = 0 -END TYPE sound_ - -! Music -TYPE, BIND(c), PUBLIC :: music_ - TYPE(audio_stream_) :: stream - INTEGER(kind=c_unsigned_int) :: frame_count = 0_C_UNSIGNED_INT - LOGICAL(kind=C_BOOL) :: looping = .FALSE._C_BOOL - INTEGER(kind=C_INT) :: ctx_ = 0 - TYPE(C_PTR) :: ctx_data = C_NULL_PTR !! void * -END TYPE music_ - -! VrDeviceInfo -TYPE, BIND(c), PUBLIC :: vr_device_info_ - INTEGER(kind=C_INT) :: h_resolution = 0 - INTEGER(kind=C_INT) :: v_resolution = 0 - REAL(kind=C_FLOAT) :: h_screen_size = 0.0 - REAL(kind=C_FLOAT) :: v_screen_size = 0.0 - REAL(kind=C_FLOAT) :: v_screen_center = 0.0 - REAL(kind=C_FLOAT) :: eye_to_screen_distance = 0.0 - REAL(kind=C_FLOAT) :: lens_separation_distance = 0.0 - REAL(kind=C_FLOAT) :: interpupillary_distance = 0.0 - REAL(kind=C_FLOAT) :: lens_distortion_values(0:3) = 0.0 - REAL(kind=C_FLOAT) :: chroma_ab_correction(0:3) = 0.0 -END TYPE vr_device_info_ - -! VrStereoConfig -TYPE, BIND(c), PUBLIC :: vr_stereo_config_ - TYPE(matrix_) :: projection(0:1) - TYPE(matrix_) :: view_offset(0:1) - REAL(kind=C_FLOAT) :: left_lens_center(0:1) = 0.0 - REAL(kind=C_FLOAT) :: right_lens_center(0:1) = 0.0 - REAL(kind=C_FLOAT) :: left_screen_center(0:1) = 0.0 - REAL(kind=C_FLOAT) :: right_screen_center(0:1) = 0.0 - REAL(kind=C_FLOAT) :: SCALE(0:1) = 0.0 - REAL(kind=C_FLOAT) :: scale_in(0:1) = 0.0 -END TYPE vr_stereo_config_ - -! FilePathList -TYPE, BIND(c), PUBLIC :: file_path_list_ - INTEGER(kind=c_unsigned_int) :: capacity = 0_C_UNSIGNED_INT - INTEGER(kind=c_unsigned_int) :: count = 0_C_UNSIGNED_INT - TYPE(C_PTR) :: paths = C_NULL_PTR !! char ** -END TYPE file_path_list_ - -TYPE(color_), PARAMETER, PUBLIC :: LIGHTGRAY = & - color_(200_C_UNSIGNED_CHAR, & - 200_C_UNSIGNED_CHAR, 200_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: GRAY = color_(130_C_UNSIGNED_CHAR, & - 130_C_UNSIGNED_CHAR, 130_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: DARKGRAY = color_(80_C_UNSIGNED_CHAR, & - 80_C_UNSIGNED_CHAR, 80_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: YELLOW = color_(253_C_UNSIGNED_CHAR, & - 249_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: GOLD = color_(255_C_UNSIGNED_CHAR, & - 203_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: ORANGE = color_(255_C_UNSIGNED_CHAR, & - 161_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: PINK = color_(255_C_UNSIGNED_CHAR, & - 109_C_UNSIGNED_CHAR, 194_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: RED = color_(230_C_UNSIGNED_CHAR, & - 41_C_UNSIGNED_CHAR, 55_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: MAROON = color_(190_C_UNSIGNED_CHAR, & - 33_C_UNSIGNED_CHAR, 55_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: GREEN = color_(0_C_UNSIGNED_CHAR, & - 228_C_UNSIGNED_CHAR, 48_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: LIME = color_(0_C_UNSIGNED_CHAR, & - 158_C_UNSIGNED_CHAR, 47_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: DARKGREEN = color_(0_C_UNSIGNED_CHAR, & - 117_C_UNSIGNED_CHAR, 44_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: SKYBLUE = & - color_(102_C_UNSIGNED_CHAR, & - 191_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: BLUE = color_(0_C_UNSIGNED_CHAR, & - 121_C_UNSIGNED_CHAR, 241_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: DARKBLUE = color_(0_C_UNSIGNED_CHAR, & - 82_C_UNSIGNED_CHAR, 172_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: PURPLE = color_(200_C_UNSIGNED_CHAR, & - 122_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: VIOLET = color_(135_C_UNSIGNED_CHAR, & - 60_C_UNSIGNED_CHAR, 190_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: DARKPURPLE = & - color_(112_C_UNSIGNED_CHAR, & - 31_C_UNSIGNED_CHAR, 126_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: BEIGE = color_(211_C_UNSIGNED_CHAR, & - 176_C_UNSIGNED_CHAR, 131_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: BROWN = color_(127_C_UNSIGNED_CHAR, & - 106_C_UNSIGNED_CHAR, 79_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: DARKBROWN = color_(76_C_UNSIGNED_CHAR, & - 63_C_UNSIGNED_CHAR, 47_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: WHITE = color_(255_C_UNSIGNED_CHAR, & - 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: BLACK = color_(0_C_UNSIGNED_CHAR, & - 0_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: BLANK = color_(0_C_UNSIGNED_CHAR, & - 0_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: MAGENTA = color_(255_C_UNSIGNED_CHAR, & - 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) -TYPE(color_), PARAMETER, PUBLIC :: RAYWHITE = & - color_(245_C_UNSIGNED_CHAR, & - 245_C_UNSIGNED_CHAR, 245_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) - -END MODULE RaylibTypes diff --git a/src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 b/src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 deleted file mode 100644 index 8323ef135..000000000 --- a/src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 +++ /dev/null @@ -1,237 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE RaylibUnloadMethods -USE, INTRINSIC :: ISO_C_BINDING -USE RaylibTypes -USE RaylibEnums -IMPLICIT NONE -PRIVATE - -PUBLIC :: UnloadWaveSamples -PUBLIC :: UnloadWave -PUBLIC :: UnloadVrStereoConfig -PUBLIC :: UnloadUTF8 -PUBLIC :: UnloadTexture -PUBLIC :: UnloadSoundAlias -PUBLIC :: UnloadSound -PUBLIC :: UnloadShader -PUBLIC :: UnloadRenderTexture -PUBLIC :: UnloadRandomSequence -PUBLIC :: UnloadMusicStream -PUBLIC :: UnloadModelAnimations -PUBLIC :: UnloadModelAnimation -PUBLIC :: UnloadModel -PUBLIC :: UnloadMesh -PUBLIC :: UnloadMaterial -PUBLIC :: UnloadImagePalette -PUBLIC :: UnloadImageColors -PUBLIC :: UnloadImage -PUBLIC :: UnloadFontData -PUBLIC :: UnloadFont -PUBLIC :: UnloadFileText -PUBLIC :: UnloadFileData -PUBLIC :: UnloadDroppedFiles -PUBLIC :: UnloadDirectoryFiles -PUBLIC :: UnloadCodepoints -PUBLIC :: UnloadAudioStream - -INTERFACE - ! void UnloadAudioStream(AudioStream stream) - SUBROUTINE UnloadAudioStream(stream) BIND(c, name='UnloadAudioStream') - IMPORT :: audio_stream_ - IMPLICIT NONE - TYPE(audio_stream_), INTENT(in), VALUE :: stream - END SUBROUTINE UnloadAudioStream - - ! void UnloadCodepoints(int *codepoints) - SUBROUTINE UnloadCodepoints(codepoints) BIND(c, name='UnloadCodepoints') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) - END SUBROUTINE UnloadCodepoints - - ! void UnloadDirectoryFiles(FilePathList files) - SUBROUTINE UnloadDirectoryFiles(files) BIND(c, name='UnloadDirectoryFiles') - IMPORT :: file_path_list_ - IMPLICIT NONE - TYPE(file_path_list_), INTENT(in), VALUE :: files - END SUBROUTINE UnloadDirectoryFiles - - ! void UnloadDroppedFiles(FilePathList files) - SUBROUTINE UnloadDroppedFiles(files) BIND(c, name='UnloadDroppedFiles') - IMPORT :: file_path_list_ - IMPLICIT NONE - TYPE(file_path_list_), INTENT(in), VALUE :: files - END SUBROUTINE UnloadDroppedFiles - - ! void UnloadFileData(unsigned char *data) - SUBROUTINE UnloadFileData(DATA) BIND(c, name='UnloadFileData') - IMPORT :: c_unsigned_char - IMPLICIT NONE - INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA - END SUBROUTINE UnloadFileData - - ! void UnloadFileText(char *text) - SUBROUTINE UnloadFileText(text) BIND(c, name='UnloadFileText') - IMPORT :: C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - END SUBROUTINE UnloadFileText - - ! void UnloadFont(Font font) - SUBROUTINE UnloadFont(font) BIND(c, name='UnloadFont') - IMPORT :: font_ - IMPLICIT NONE - TYPE(font_), INTENT(in), VALUE :: font - END SUBROUTINE UnloadFont - - ! void UnloadFontData(GlyphInfo *glyphs, int glyphCount) - SUBROUTINE UnloadFontData(glyphs, glyph_count) BIND(c, name='UnloadFontData') - IMPORT :: C_INT, glyph_info_ - IMPLICIT NONE - TYPE(glyph_info_), INTENT(inout) :: glyphs - INTEGER(kind=C_INT), INTENT(in), VALUE :: glyph_count - END SUBROUTINE UnloadFontData - - ! void UnloadImage(Image image) - SUBROUTINE UnloadImage(image) BIND(c, name='UnloadImage') - IMPORT :: image_ - IMPLICIT NONE - TYPE(image_), INTENT(in), VALUE :: image - END SUBROUTINE UnloadImage - - ! void UnloadImageColors(Color *colors) - SUBROUTINE UnloadImageColors(colors) BIND(c, name='UnloadImageColors') - IMPORT :: color_ - IMPLICIT NONE - TYPE(color_), INTENT(inout) :: colors(*) - END SUBROUTINE UnloadImageColors - - ! void UnloadImagePalette(Color *colors) - SUBROUTINE UnloadImagePalette(colors) BIND(c, name='UnloadImagePalette') - IMPORT :: color_ - IMPLICIT NONE - TYPE(color_), INTENT(inout) :: colors(*) - END SUBROUTINE UnloadImagePalette - - ! void UnloadMaterial(Material material) - SUBROUTINE UnloadMaterial(material) BIND(c, name='UnloadMaterial') - IMPORT :: material_ - IMPLICIT NONE - TYPE(material_), INTENT(in), VALUE :: material - END SUBROUTINE UnloadMaterial - - ! void UnloadMesh(Mesh mesh) - SUBROUTINE UnloadMesh(mesh) BIND(c, name='UnloadMesh') - IMPORT :: mesh_ - IMPLICIT NONE - TYPE(mesh_), INTENT(in), VALUE :: mesh - END SUBROUTINE UnloadMesh - - ! void UnloadModel(Model model) - SUBROUTINE UnloadModel(model) BIND(c, name='UnloadModel') - IMPORT :: model_ - IMPLICIT NONE - TYPE(model_), INTENT(in), VALUE :: model - END SUBROUTINE UnloadModel - - ! void UnloadModelAnimation(ModelAnimation anim) - SUBROUTINE UnloadModelAnimation(anim) BIND(c, name='UnloadModelAnimation') - IMPORT :: model_animation_ - IMPLICIT NONE - TYPE(model_animation_), INTENT(in), VALUE :: anim - END SUBROUTINE UnloadModelAnimation - - ! void UnloadModelAnimations(ModelAnimation *animations, int count) - subroutine UnloadModelAnimations(animations, count) bind(c, name='UnloadModelAnimations') - IMPORT :: C_INT, model_animation_ - IMPLICIT NONE - TYPE(model_animation_), INTENT(inout) :: animations(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: count - END SUBROUTINE UnloadModelAnimations - - ! void UnloadMusicStream(Music music) - SUBROUTINE UnloadMusicStream(music) BIND(c, name='UnloadMusicStream') - IMPORT :: music_ - IMPLICIT NONE - TYPE(music_), INTENT(in), VALUE :: music - END SUBROUTINE UnloadMusicStream - - ! void UnloadRandomSequence(int *sequence) -SUBROUTINE UnloadRandomSequence(SEQUENCE) BIND(c, name='UnloadRandomSequence') - IMPORT :: C_INT - IMPLICIT NONE - INTEGER(kind=C_INT), INTENT(inout) :: SEQUENCE(*) - END SUBROUTINE UnloadRandomSequence - - ! void UnloadRenderTexture(RenderTexture2D target) - SUBROUTINE UnloadRenderTexture(TARGET) BIND(c, name='UnloadRenderTexture') - IMPORT :: render_texture2d_ - IMPLICIT NONE - TYPE(render_texture2d_), INTENT(in), VALUE :: TARGET - END SUBROUTINE UnloadRenderTexture - - ! void UnloadShader(Shader shader) - SUBROUTINE UnloadShader(shader) BIND(c, name='UnloadShader') - IMPORT :: shader_ - IMPLICIT NONE - TYPE(shader_), INTENT(in), VALUE :: shader - END SUBROUTINE UnloadShader - - ! void UnloadSound(Sound sound) - SUBROUTINE UnloadSound(sound) BIND(c, name='UnloadSound') - IMPORT :: sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: sound - END SUBROUTINE UnloadSound - - ! void UnloadSoundAlias(Sound alias) - SUBROUTINE UnloadSoundAlias(alias) BIND(c, name='UnloadSoundAlias') - IMPORT :: sound_ - IMPLICIT NONE - TYPE(sound_), INTENT(in), VALUE :: alias - END SUBROUTINE UnloadSoundAlias - - ! void UnloadTexture(Texture2D texture) - SUBROUTINE UnloadTexture(texture) BIND(c, name='UnloadTexture') - IMPORT :: texture2d_ - IMPLICIT NONE - TYPE(texture2d_), INTENT(in), VALUE :: texture - END SUBROUTINE UnloadTexture - - ! void UnloadUTF8(char *text) - SUBROUTINE UnloadUTF8(text) BIND(c, name='UnloadUTF8') - IMPORT :: C_CHAR - IMPLICIT NONE - CHARACTER(kind=C_CHAR), INTENT(in) :: text - END SUBROUTINE UnloadUTF8 - - ! void UnloadVrStereoConfig(VrStereoConfig config) - SUBROUTINE UnloadVrStereoConfig(config) BIND(c, name='UnloadVrStereoConfig') - IMPORT :: vr_stereo_config_ - IMPLICIT NONE - TYPE(vr_stereo_config_), INTENT(in), VALUE :: config - END SUBROUTINE UnloadVrStereoConfig - - ! void UnloadWave(Wave wave) - SUBROUTINE UnloadWave(wave) BIND(c, name='UnloadWave') - IMPORT :: wave_ - IMPLICIT NONE - TYPE(wave_), INTENT(in), VALUE :: wave - END SUBROUTINE UnloadWave - - ! void UnloadWaveSamples(float *samples) - SUBROUTINE UnloadWaveSamples(samples) BIND(c, name='UnloadWaveSamples') - IMPORT :: C_FLOAT - IMPLICIT NONE - REAL(kind=C_FLOAT), INTENT(inout) :: samples(*) - END SUBROUTINE UnloadWaveSamples -END INTERFACE - -END MODULE RaylibUnloadMethods diff --git a/src/modules/RaylibInterface/src/RaylibUtil.F90 b/src/modules/RaylibInterface/src/RaylibUtil.F90 deleted file mode 100644 index 3606e904d..000000000 --- a/src/modules/RaylibInterface/src/RaylibUtil.F90 +++ /dev/null @@ -1,48 +0,0 @@ -! raylib_util.f90 -! -! Utility procedures for C inter-operability with raylib. -! -! Author: Philipp Engel -! Licence: ISC - -MODULE raylib_util -USE, INTRINSIC :: ISO_C_BINDING -IMPLICIT NONE(TYPE, EXTERNAL) -PRIVATE - -INTERFACE - FUNCTION c_strlen(str) BIND(c, name='strlen') - IMPORT :: C_PTR, C_SIZE_T - IMPLICIT NONE - TYPE(C_PTR), INTENT(in), VALUE :: str - INTEGER(kind=C_SIZE_T) :: c_strlen - END FUNCTION c_strlen -END INTERFACE - -PUBLIC :: c_f_str_ptr -CONTAINS -SUBROUTINE c_f_str_ptr(c_str, f_str) - !! Copies a C string, passed as a C pointer, to a Fortran string. - TYPE(C_PTR), INTENT(in) :: c_str - CHARACTER(:), ALLOCATABLE, INTENT(out) :: f_str - - CHARACTER(kind=C_CHAR), POINTER :: ptrs(:) - INTEGER(kind=C_SIZE_T) :: i, sz - - copy_block: BLOCK - IF (.NOT. C_ASSOCIATED(c_str)) EXIT copy_block - sz = c_strlen(c_str) - IF (sz < 0) EXIT copy_block - CALL C_F_POINTER(c_str, ptrs, [sz]) - ALLOCATE (CHARACTER(len=sz) :: f_str) - - DO i = 1, sz - f_str(i:i) = ptrs(i) - END DO - - RETURN - END BLOCK copy_block - - IF (.NOT. ALLOCATED(f_str)) f_str = '' -END SUBROUTINE c_f_str_ptr -END MODULE raylib_util diff --git a/src/modules/RaylibInterface/src/__Raylib.F90 b/src/modules/RaylibInterface/src/__Raylib.F90 deleted file mode 100644 index 5fa6177af..000000000 --- a/src/modules/RaylibInterface/src/__Raylib.F90 +++ /dev/null @@ -1,5913 +0,0 @@ -! raylib.f90 -! -! A collection of auto-generated Fortran 2018 interface bindings to -! raylib 5.1. -! -! Author: Philipp Engel -! Licence: ISC - -module Raylib - use, intrinsic :: iso_c_binding - implicit none (type, external) - private - - integer, parameter, public :: c_unsigned_int = c_int - integer, parameter, public :: c_unsigned_char = c_signed_char - - real, parameter, public :: PI = acos(-1.0) - - ! Vector2 - type, bind(c), public :: vector2_type - real(kind=c_float) :: x = 0.0 - real(kind=c_float) :: y = 0.0 - end type vector2_type - - ! Vector3 - type, bind(c), public :: vector3_type - real(kind=c_float) :: x = 0.0 - real(kind=c_float) :: y = 0.0 - real(kind=c_float) :: z = 0.0 - end type vector3_type - - ! Vector4 - type, bind(c), public :: vector4_type - real(kind=c_float) :: x = 0.0 - real(kind=c_float) :: y = 0.0 - real(kind=c_float) :: z = 0.0 - real(kind=c_float) :: w = 0.0 - end type vector4_type - - ! Quaternion - type, bind(c), public :: quaternion_type - real(kind=c_float) :: x = 0.0 - real(kind=c_float) :: y = 0.0 - real(kind=c_float) :: z = 0.0 - real(kind=c_float) :: w = 0.0 - end type quaternion_type - - ! Matrix - type, bind(c), public :: matrix_type - real(kind=c_float) :: m0 = 0.0, m4 = 0.0, m8 = 0.0, m12 = 0.0 - real(kind=c_float) :: m1 = 0.0, m5 = 0.0, m9 = 0.0, m13 = 0.0 - real(kind=c_float) :: m2 = 0.0, m6 = 0.0, m10 = 0.0, m14 = 0.0 - real(kind=c_float) :: m3 = 0.0, m7 = 0.0, m11 = 0.0, m15 = 0.0 - end type matrix_type - - ! Color - type, bind(c), public :: color_type - integer(kind=c_unsigned_char) :: r = 0_c_unsigned_int - integer(kind=c_unsigned_char) :: g = 0_c_unsigned_int - integer(kind=c_unsigned_char) :: b = 0_c_unsigned_int - integer(kind=c_unsigned_char) :: a = 255_c_unsigned_int - end type color_type - - ! Rectangle - type, bind(c), public :: rectangle_type - real(kind=c_float) :: x = 0.0 - real(kind=c_float) :: y = 0.0 - real(kind=c_float) :: width = 0.0 - real(kind=c_float) :: height = 0.0 - end type rectangle_type - - ! Image - type, bind(c), public :: image_type - type(c_ptr) :: data = c_null_ptr !! void * - integer(kind=c_int) :: width = 0 - integer(kind=c_int) :: height = 0 - integer(kind=c_int) :: mipmaps = 0 - integer(kind=c_int) :: format = 0 - end type image_type - - ! Texture2D - type, bind(c), public :: texture2d_type - integer(kind=c_unsigned_int) :: id = 0 - integer(kind=c_int) :: width = 0 - integer(kind=c_int) :: height = 0 - integer(kind=c_int) :: mipmaps = 0 - integer(kind=c_int) :: format = 0 - end type texture2d_type - - ! TextureCubemap - type, bind(c), public :: texture_cubemap_type - integer(kind=c_unsigned_int) :: id = 0_c_unsigned_int - integer(kind=c_int) :: width = 0 - integer(kind=c_int) :: height = 0 - integer(kind=c_int) :: mipmaps = 0 - integer(kind=c_int) :: format = 0 - end type texture_cubemap_type - - ! RenderTexture - type, bind(c), public :: render_texture_type - integer(kind=c_unsigned_int) :: id = 0_c_unsigned_int - type(texture2d_type) :: texture - type(texture2d_type) :: depth - end type render_texture_type - - ! RenderTexture2D - type, bind(c), public :: render_texture2d_type - integer(kind=c_unsigned_int) :: id = 0_c_unsigned_int - type(texture2d_type) :: texture - type(texture2d_type) :: depth - end type render_texture2d_type - - ! NPatchInfo - type, bind(c), public :: npatch_info_type - type(rectangle_type) :: source - integer(kind=c_int) :: left = 0 - integer(kind=c_int) :: top = 0 - integer(kind=c_int) :: right = 0 - integer(kind=c_int) :: bottom = 0 - integer(kind=c_int) :: layout = 0 - end type npatch_info_type - - ! GlyphInfo - type, bind(c), public :: glyph_info_type - integer(kind=c_int) :: value = 0 - integer(kind=c_int) :: offset_x = 0 - integer(kind=c_int) :: offset_y = 0 - integer(kind=c_int) :: advance_x = 0 - type(image_type) :: image - end type glyph_info_type - - ! Font - type, bind(c), public :: font_type - integer(kind=c_int) :: base_size = 0 - integer(kind=c_int) :: glyph_count = 0 - integer(kind=c_int) :: glyph_padding = 0 - type(texture2d_type) :: texture - type(c_ptr) :: recs = c_null_ptr !! Rectangle * - type(c_ptr) :: glyphs = c_null_ptr !! GlyphInfo * - end type font_type - - ! Camera, Camera3D - type, bind(c), public :: camera3d_type - type(vector3_type) :: position - type(vector3_type) :: target - type(vector3_type) :: up - real(kind=c_float) :: fov_y = 0.0 - integer(kind=c_int) :: projection = 0 - end type camera3d_type - - ! Camera2D - type, bind(c), public :: camera2d_type - type(vector2_type) :: offset - type(vector2_type) :: target - real(kind=c_float) :: rotation = 0.0 - real(kind=c_float) :: zoom = 0.0 - end type camera2d_type - - ! Mesh - type, bind(c), public :: mesh_type - integer(kind=c_int) :: vertex_count = 0 - integer(kind=c_int) :: triangle_count = 0 - type(c_ptr) :: vertices = c_null_ptr !! float * - type(c_ptr) :: texcoords = c_null_ptr !! float * - type(c_ptr) :: texcoords2 = c_null_ptr !! float * - type(c_ptr) :: normals = c_null_ptr !! float * - type(c_ptr) :: tangents = c_null_ptr !! float * - type(c_ptr) :: colors = c_null_ptr !! unsigned char * - type(c_ptr) :: indices = c_null_ptr !! unsigned short * - type(c_ptr) :: anim_vertices = c_null_ptr !! float * - type(c_ptr) :: anim_normals = c_null_ptr !! float * - type(c_ptr) :: bone_ids = c_null_ptr !! unsigned char * - type(c_ptr) :: bone_weights = c_null_ptr !! float * - integer(kind=c_unsigned_int) :: vao_id = 0_c_unsigned_int - type(c_ptr) :: vbo_id = c_null_ptr !! unsigned int * - end type mesh_type - - ! Shader - type, bind(c), public :: shader_type - integer(kind=c_unsigned_int) :: id = 0 - type(c_ptr) :: locs = c_null_ptr !! int * - end type shader_type - - ! MaterialMap - type, bind(c), public :: material_map_type - type(texture2d_type) :: texture - type(color_type) :: color - real(kind=c_float) :: value = 0 - end type material_map_type - - ! Material - type, bind(c), public :: material_type - type(shader_type) :: shader - type(c_ptr) :: maps = c_null_ptr !! MaterialMap * - real(kind=c_float) :: params(0:3) = 0.0 - end type material_type - - ! Transform - type, bind(c), public :: transform_type - type(vector3_type) :: translation - type(quaternion_type) :: rotation - type(vector3_type) :: scale - end type transform_type - - ! BoneInfo - type, bind(c), public :: bone_info_type - character(kind=c_char) :: name(0:31) = c_null_char - integer(kind=c_int) :: parent = 0 - end type bone_info_type - - ! Model - type, bind(c), public :: model_type - type(matrix_type) :: transform - integer(kind=c_int) :: mesh_count = 0 - integer(kind=c_int) :: material_count = 0 - type(c_ptr) :: meshes = c_null_ptr !! Mesh * - type(c_ptr) :: materials = c_null_ptr !! Material * - type(c_ptr) :: mesh_material = c_null_ptr !! int * - integer(kind=c_int) :: bone_count = 0 - type(c_ptr) :: bones = c_null_ptr !! BoneInfo * - type(c_ptr) :: bind_pose = c_null_ptr !! Transform * - end type model_type - - ! ModelAnimation - type, bind(c), public :: model_animation_type - integer(kind=c_int) :: bone_count = 0 - integer(kind=c_int) :: frame_count = 0 - type(c_ptr) :: bones = c_null_ptr !! BoneInfo * - type(c_ptr) :: frame_poses = c_null_ptr !! Transform ** - character(kind=c_char) :: name(0:31) = c_null_char - end type model_animation_type - - ! Ray - type, bind(c), public :: ray_type - type(vector3_type) :: position - type(vector3_type) :: direction - end type ray_type - - ! RayCollision - type, bind(c), public :: ray_collision_type - logical(kind=c_bool) :: hit = .false._c_bool - real(kind=c_float) :: distance = 0.0 - type(vector3_type) :: point - type(vector3_type) :: normal - end type ray_collision_type - - ! BoundingBox - type, bind(c), public :: bounding_box_type - type(vector3_type) :: min - type(vector3_type) :: max - end type bounding_box_type - - ! Wave - type, bind(c), public :: wave_type - integer(kind=c_unsigned_int) :: frame_count = 0_c_unsigned_int - integer(kind=c_unsigned_int) :: sample_rate = 0_c_unsigned_int - integer(kind=c_unsigned_int) :: sample_size = 0_c_unsigned_int - integer(kind=c_unsigned_int) :: channels = 0_c_unsigned_int - type(c_ptr) :: data = c_null_ptr !! void * - end type wave_type - - ! AudioStream - type, bind(c), public :: audio_stream_type - type(c_ptr) :: buffer = c_null_ptr !! rAudioBuffer * - type(c_ptr) :: processor = c_null_ptr !! rAudioProcessor * - integer(kind=c_unsigned_int) :: sample_rate = 0_c_unsigned_int - integer(kind=c_unsigned_int) :: sample_size = 0_c_unsigned_int - integer(kind=c_unsigned_int) :: channels = 0_c_unsigned_int - end type audio_stream_type - - ! Sound - type, bind(c), public :: sound_type - type(audio_stream_type) :: stream - integer(kind=c_unsigned_int) :: frame_count = 0 - end type sound_type - - ! Music - type, bind(c), public :: music_type - type(audio_stream_type) :: stream - integer(kind=c_unsigned_int) :: frame_count = 0_c_unsigned_int - logical(kind=c_bool) :: looping = .false._c_bool - integer(kind=c_int) :: ctx_type = 0 - type(c_ptr) :: ctx_data = c_null_ptr !! void * - end type music_type - - ! VrDeviceInfo - type, bind(c), public :: vr_device_info_type - integer(kind=c_int) :: h_resolution = 0 - integer(kind=c_int) :: v_resolution = 0 - real(kind=c_float) :: h_screen_size = 0.0 - real(kind=c_float) :: v_screen_size = 0.0 - real(kind=c_float) :: v_screen_center = 0.0 - real(kind=c_float) :: eye_to_screen_distance = 0.0 - real(kind=c_float) :: lens_separation_distance = 0.0 - real(kind=c_float) :: interpupillary_distance = 0.0 - real(kind=c_float) :: lens_distortion_values(0:3) = 0.0 - real(kind=c_float) :: chroma_ab_correction(0:3) = 0.0 - end type vr_device_info_type - - ! VrStereoConfig - type, bind(c), public :: vr_stereo_config_type - type(matrix_type) :: projection(0:1) - type(matrix_type) :: view_offset(0:1) - real(kind=c_float) :: left_lens_center(0:1) = 0.0 - real(kind=c_float) :: right_lens_center(0:1) = 0.0 - real(kind=c_float) :: left_screen_center(0:1) = 0.0 - real(kind=c_float) :: right_screen_center(0:1) = 0.0 - real(kind=c_float) :: scale(0:1) = 0.0 - real(kind=c_float) :: scale_in(0:1) = 0.0 - end type vr_stereo_config_type - - ! FilePathList - type, bind(c), public :: file_path_list_type - integer(kind=c_unsigned_int) :: capacity = 0_c_unsigned_int - integer(kind=c_unsigned_int) :: count = 0_c_unsigned_int - type(c_ptr) :: paths = c_null_ptr !! char ** - end type file_path_list_type - - type(color_type), parameter, public :: LIGHTGRAY = color_type(200, 200, 200, 255) - type(color_type), parameter, public :: GRAY = color_type(130, 130, 130, 255) - type(color_type), parameter, public :: DARKGRAY = color_type( 80, 80, 80, 255) - type(color_type), parameter, public :: YELLOW = color_type(253, 249, 0, 255) - type(color_type), parameter, public :: GOLD = color_type(255, 203, 0, 255) - type(color_type), parameter, public :: ORANGE = color_type(255, 161, 0, 255) - type(color_type), parameter, public :: PINK = color_type(255, 109, 194, 255) - type(color_type), parameter, public :: RED = color_type(230, 41, 55, 255) - type(color_type), parameter, public :: MAROON = color_type(190, 33, 55, 255) - type(color_type), parameter, public :: GREEN = color_type( 0, 228, 48, 255) - type(color_type), parameter, public :: LIME = color_type( 0, 158, 47, 255) - type(color_type), parameter, public :: DARKGREEN = color_type( 0, 117, 44, 255) - type(color_type), parameter, public :: SKYBLUE = color_type(102, 191, 255, 255) - type(color_type), parameter, public :: BLUE = color_type( 0, 121, 241, 255) - type(color_type), parameter, public :: DARKBLUE = color_type( 0, 82, 172, 255) - type(color_type), parameter, public :: PURPLE = color_type(200, 122, 255, 255) - type(color_type), parameter, public :: VIOLET = color_type(135, 60, 190, 255) - type(color_type), parameter, public :: DARKPURPLE = color_type(112, 31, 126, 255) - type(color_type), parameter, public :: BEIGE = color_type(211, 176, 131, 255) - type(color_type), parameter, public :: BROWN = color_type(127, 106, 79, 255) - type(color_type), parameter, public :: DARKBROWN = color_type( 76, 63, 47, 255) - type(color_type), parameter, public :: WHITE = color_type(255, 255, 255, 255) - type(color_type), parameter, public :: BLACK = color_type( 0, 0, 0, 255) - type(color_type), parameter, public :: BLANK = color_type( 0, 0, 0, 0) - type(color_type), parameter, public :: MAGENTA = color_type(255, 0, 255, 255) - type(color_type), parameter, public :: RAYWHITE = color_type(245, 245, 245, 255) - - ! ConfigFlags - integer(kind=c_int), parameter, public :: FLAG_VSYNC_HINT = int(z'00000040') - integer(kind=c_int), parameter, public :: FLAG_FULLSCREEN_MODE = int(z'00000002') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_RESIZABLE = int(z'00000004') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_UNDECORATED = int(z'00000008') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_HIDDEN = int(z'00000080') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_MINIMIZED = int(z'00000200') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_MAXIMIZED = int(z'00000400') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_UNFOCUSED = int(z'00000800') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_TOPMOST = int(z'00001000') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_ALWAYS_RUN = int(z'00000100') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_TRANSPARENT = int(z'00000010') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_HIGHDPI = int(z'00002000') - integer(kind=c_int), parameter, public :: FLAG_WINDOW_MOUSE_PASSTHROUGH = int(z'00004000') - integer(kind=c_int), parameter, public :: FLAG_BORDERLESS_WINDOWED_MODE = int(z'00008000') - integer(kind=c_int), parameter, public :: FLAG_MSAA_4X_HINT = int(z'00000020') - integer(kind=c_int), parameter, public :: FLAG_INTERLACED_HINT = int(z'00010000') - - ! TraceLogLevel - integer(kind=c_int), parameter, public :: LOG_ALL = 0 - integer(kind=c_int), parameter, public :: LOG_TRACE = 1 - integer(kind=c_int), parameter, public :: LOG_DEBUG = 2 - integer(kind=c_int), parameter, public :: LOG_INFO = 3 - integer(kind=c_int), parameter, public :: LOG_WARNING = 4 - integer(kind=c_int), parameter, public :: LOG_ERROR = 5 - integer(kind=c_int), parameter, public :: LOG_FATAL = 6 - integer(kind=c_int), parameter, public :: LOG_NONE = 7 - - ! KeyboardKey - integer(kind=c_int), parameter, public :: KEY_NULL = 0 - integer(kind=c_int), parameter, public :: KEY_APOSTROPHE = 39 - integer(kind=c_int), parameter, public :: KEY_COMMA = 44 - integer(kind=c_int), parameter, public :: KEY_MINUS = 45 - integer(kind=c_int), parameter, public :: KEY_PERIOD = 46 - integer(kind=c_int), parameter, public :: KEY_SLASH = 47 - integer(kind=c_int), parameter, public :: KEY_ZERO = 48 - integer(kind=c_int), parameter, public :: KEY_ONE = 49 - integer(kind=c_int), parameter, public :: KEY_TWO = 50 - integer(kind=c_int), parameter, public :: KEY_THREE = 51 - integer(kind=c_int), parameter, public :: KEY_FOUR = 52 - integer(kind=c_int), parameter, public :: KEY_FIVE = 53 - integer(kind=c_int), parameter, public :: KEY_SIX = 54 - integer(kind=c_int), parameter, public :: KEY_SEVEN = 55 - integer(kind=c_int), parameter, public :: KEY_EIGHT = 56 - integer(kind=c_int), parameter, public :: KEY_NINE = 57 - integer(kind=c_int), parameter, public :: KEY_SEMICOLON = 59 - integer(kind=c_int), parameter, public :: KEY_EQUAL = 61 - integer(kind=c_int), parameter, public :: KEY_A = 65 - integer(kind=c_int), parameter, public :: KEY_B = 66 - integer(kind=c_int), parameter, public :: KEY_C = 67 - integer(kind=c_int), parameter, public :: KEY_D = 68 - integer(kind=c_int), parameter, public :: KEY_E = 69 - integer(kind=c_int), parameter, public :: KEY_F = 70 - integer(kind=c_int), parameter, public :: KEY_G = 71 - integer(kind=c_int), parameter, public :: KEY_H = 72 - integer(kind=c_int), parameter, public :: KEY_I = 73 - integer(kind=c_int), parameter, public :: KEY_J = 74 - integer(kind=c_int), parameter, public :: KEY_K = 75 - integer(kind=c_int), parameter, public :: KEY_L = 76 - integer(kind=c_int), parameter, public :: KEY_M = 77 - integer(kind=c_int), parameter, public :: KEY_N = 78 - integer(kind=c_int), parameter, public :: KEY_O = 79 - integer(kind=c_int), parameter, public :: KEY_P = 80 - integer(kind=c_int), parameter, public :: KEY_Q = 81 - integer(kind=c_int), parameter, public :: KEY_R = 82 - integer(kind=c_int), parameter, public :: KEY_S = 83 - integer(kind=c_int), parameter, public :: KEY_T = 84 - integer(kind=c_int), parameter, public :: KEY_U = 85 - integer(kind=c_int), parameter, public :: KEY_V = 86 - integer(kind=c_int), parameter, public :: KEY_W = 87 - integer(kind=c_int), parameter, public :: KEY_X = 88 - integer(kind=c_int), parameter, public :: KEY_Y = 89 - integer(kind=c_int), parameter, public :: KEY_Z = 90 - integer(kind=c_int), parameter, public :: KEY_LEFT_BRACKET = 91 - integer(kind=c_int), parameter, public :: KEY_BACKSLASH = 92 - integer(kind=c_int), parameter, public :: KEY_RIGHT_BRACKET = 93 - integer(kind=c_int), parameter, public :: KEY_GRAVE = 96 - integer(kind=c_int), parameter, public :: KEY_SPACE = 32 - integer(kind=c_int), parameter, public :: KEY_ESCAPE = 256 - integer(kind=c_int), parameter, public :: KEY_ENTER = 257 - integer(kind=c_int), parameter, public :: KEY_TAB = 258 - integer(kind=c_int), parameter, public :: KEY_BACKSPACE = 259 - integer(kind=c_int), parameter, public :: KEY_INSERT = 260 - integer(kind=c_int), parameter, public :: KEY_DELETE = 261 - integer(kind=c_int), parameter, public :: KEY_RIGHT = 262 - integer(kind=c_int), parameter, public :: KEY_LEFT = 263 - integer(kind=c_int), parameter, public :: KEY_DOWN = 264 - integer(kind=c_int), parameter, public :: KEY_UP = 265 - integer(kind=c_int), parameter, public :: KEY_PAGE_UP = 266 - integer(kind=c_int), parameter, public :: KEY_PAGE_DOWN = 267 - integer(kind=c_int), parameter, public :: KEY_HOME = 268 - integer(kind=c_int), parameter, public :: KEY_END = 269 - integer(kind=c_int), parameter, public :: KEY_CAPS_LOCK = 280 - integer(kind=c_int), parameter, public :: KEY_SCROLL_LOCK = 281 - integer(kind=c_int), parameter, public :: KEY_NUM_LOCK = 282 - integer(kind=c_int), parameter, public :: KEY_PRINT_SCREEN = 283 - integer(kind=c_int), parameter, public :: KEY_PAUSE = 284 - integer(kind=c_int), parameter, public :: KEY_F1 = 290 - integer(kind=c_int), parameter, public :: KEY_F2 = 291 - integer(kind=c_int), parameter, public :: KEY_F3 = 292 - integer(kind=c_int), parameter, public :: KEY_F4 = 293 - integer(kind=c_int), parameter, public :: KEY_F5 = 294 - integer(kind=c_int), parameter, public :: KEY_F6 = 295 - integer(kind=c_int), parameter, public :: KEY_F7 = 296 - integer(kind=c_int), parameter, public :: KEY_F8 = 297 - integer(kind=c_int), parameter, public :: KEY_F9 = 298 - integer(kind=c_int), parameter, public :: KEY_F10 = 299 - integer(kind=c_int), parameter, public :: KEY_F11 = 300 - integer(kind=c_int), parameter, public :: KEY_F12 = 301 - integer(kind=c_int), parameter, public :: KEY_LEFT_SHIFT = 340 - integer(kind=c_int), parameter, public :: KEY_LEFT_CONTROL = 341 - integer(kind=c_int), parameter, public :: KEY_LEFT_ALT = 342 - integer(kind=c_int), parameter, public :: KEY_LEFT_SUPER = 343 - integer(kind=c_int), parameter, public :: KEY_RIGHT_SHIFT = 344 - integer(kind=c_int), parameter, public :: KEY_RIGHT_CONTROL = 345 - integer(kind=c_int), parameter, public :: KEY_RIGHT_ALT = 346 - integer(kind=c_int), parameter, public :: KEY_RIGHT_SUPER = 347 - integer(kind=c_int), parameter, public :: KEY_KB_MENU = 348 - integer(kind=c_int), parameter, public :: KEY_KP_0 = 320 - integer(kind=c_int), parameter, public :: KEY_KP_1 = 321 - integer(kind=c_int), parameter, public :: KEY_KP_2 = 322 - integer(kind=c_int), parameter, public :: KEY_KP_3 = 323 - integer(kind=c_int), parameter, public :: KEY_KP_4 = 324 - integer(kind=c_int), parameter, public :: KEY_KP_5 = 325 - integer(kind=c_int), parameter, public :: KEY_KP_6 = 326 - integer(kind=c_int), parameter, public :: KEY_KP_7 = 327 - integer(kind=c_int), parameter, public :: KEY_KP_8 = 328 - integer(kind=c_int), parameter, public :: KEY_KP_9 = 329 - integer(kind=c_int), parameter, public :: KEY_KP_DECIMAL = 330 - integer(kind=c_int), parameter, public :: KEY_KP_DIVIDE = 331 - integer(kind=c_int), parameter, public :: KEY_KP_MULTIPLY = 332 - integer(kind=c_int), parameter, public :: KEY_KP_SUBTRACT = 333 - integer(kind=c_int), parameter, public :: KEY_KP_ADD = 334 - integer(kind=c_int), parameter, public :: KEY_KP_ENTER = 335 - integer(kind=c_int), parameter, public :: KEY_KP_EQUAL = 336 - integer(kind=c_int), parameter, public :: KEY_BACK = 4 - integer(kind=c_int), parameter, public :: KEY_MENU = 82 - integer(kind=c_int), parameter, public :: KEY_VOLUME_UP = 24 - integer(kind=c_int), parameter, public :: KEY_VOLUME_DOWN = 25 - - ! MouseButton - integer(kind=c_int), parameter, public :: MOUSE_BUTTON_LEFT = 0 - integer(kind=c_int), parameter, public :: MOUSE_BUTTON_RIGHT = 1 - integer(kind=c_int), parameter, public :: MOUSE_BUTTON_MIDDLE = 2 - integer(kind=c_int), parameter, public :: MOUSE_BUTTON_SIDE = 3 - integer(kind=c_int), parameter, public :: MOUSE_BUTTON_EXTRA = 4 - integer(kind=c_int), parameter, public :: MOUSE_BUTTON_FORWARD = 5 - integer(kind=c_int), parameter, public :: MOUSE_BUTTON_BACK = 6 - - ! MouseCursor - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_DEFAULT = 0 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_ARROW = 1 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_IBEAM = 2 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_CROSSHAIR = 3 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_POINTING_HAND = 4 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_EW = 5 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_NS = 6 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_NWSE = 7 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_NESW = 8 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_ALL = 9 - integer(kind=c_int), parameter, public :: MOUSE_CURSOR_NOT_ALLOWED = 10 - - ! GamepadButton - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_UNKNOWN = 0 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_UP = 1 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_RIGHT = 2 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_DOWN = 3 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_LEFT = 4 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_UP = 5 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_RIGHT = 6 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_DOWN = 7 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_LEFT = 8 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_TRIGGER_1 = 9 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_TRIGGER_2 = 10 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_TRIGGER_1 = 11 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_TRIGGER_2 = 12 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_MIDDLE_LEFT = 13 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_MIDDLE = 14 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_MIDDLE_RIGHT = 15 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_THUMB = 16 - integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_THUMB = 17 - - ! GamepadAxis - integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_LEFT_X = 0 - integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_LEFT_Y = 1 - integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_RIGHT_X = 2 - integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_RIGHT_Y = 3 - integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_LEFT_TRIGGER = 4 - integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_RIGHT_TRIGGER = 5 - - ! MaterialMapIndex - integer(kind=c_int), parameter, public :: MATERIAL_MAP_ALBEDO = 0 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_METALNESS = 1 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_NORMAL = 2 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_ROUGHNESS = 3 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_OCCLUSION = 4 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_EMISSION = 5 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_HEIGHT = 6 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_CUBEMAP = 7 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_IRRADIANCE = 8 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_PREFILTER = 9 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_BRDF = 10 - - integer(kind=c_int), parameter, public :: MATERIAL_MAP_DIFFUSE = 0 - integer(kind=c_int), parameter, public :: MATERIAL_MAP_SPECULAR = 1 - - ! ShaderLocationIndex - integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_POSITION = 0 - integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_TEXCOORD01 = 1 - integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_TEXCOORD02 = 2 - integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_NORMAL = 3 - integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_TANGENT = 4 - integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_COLOR = 5 - integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_MVP = 6 - integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_VIEW = 7 - integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_PROJECTION = 8 - integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_MODEL = 9 - integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_NORMAL = 10 - integer(kind=c_int), parameter, public :: SHADER_LOC_VECTOR_VIEW = 11 - integer(kind=c_int), parameter, public :: SHADER_LOC_COLOR_DIFFUSE = 12 - integer(kind=c_int), parameter, public :: SHADER_LOC_COLOR_SPECULAR = 13 - integer(kind=c_int), parameter, public :: SHADER_LOC_COLOR_AMBIENT = 14 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_ALBEDO = 15 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_METALNESS = 16 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_NORMAL = 17 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_ROUGHNESS = 18 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_OCCLUSION = 19 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_EMISSION = 20 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_HEIGHT = 21 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_CUBEMAP = 22 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_IRRADIANCE = 23 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_PREFILTER = 24 - integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_BRDF = 25 - - ! ShaderUniformDataType - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_FLOAT = 0 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_VEC2 = 1 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_VEC3 = 2 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_VEC4 = 3 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_INT = 4 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_IVEC2 = 5 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_IVEC3 = 6 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_IVEC4 = 7 - integer(kind=c_int), parameter, public :: SHADER_UNIFORM_SAMPLER2D = 8 - - ! ShaderAttributeDataType - integer(kind=c_int), parameter, public :: SHADER_ATTRIB_FLOAT = 0 - integer(kind=c_int), parameter, public :: SHADER_ATTRIB_VEC2 = 1 - integer(kind=c_int), parameter, public :: SHADER_ATTRIB_VEC3 = 2 - integer(kind=c_int), parameter, public :: SHADER_ATTRIB_VEC4 = 3 - - ! PixelFormat - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_GRAYSCALE = 1 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_GRAY_ALPHA = 2 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R5G6B5 = 3 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R8G8B8 = 4 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R5G5B5A1 = 5 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R4G4B4A4 = 6 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R8G8B8A8 = 7 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R32 = 8 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R32G32B32 = 9 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R32G32B32A32 = 10 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R16 = 11 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R16G16B16 = 12 - integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R16G16B16A16 = 13 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT1_RGB = 14 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT1_RGBA = 15 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT3_RGBA = 16 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT5_RGBA = 17 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ETC1_RGB = 18 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ETC2_RGB = 19 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ETC2_EAC_RGBA = 20 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_PVRT_RGB = 21 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_PVRT_RGBA = 22 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ASTC_4x4_RGBA = 23 - integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ASTC_8x8_RGBA = 24 - - ! TextureFilter - integer(kind=c_int), parameter, public :: TEXTURE_FILTER_POINT = 0 - integer(kind=c_int), parameter, public :: TEXTURE_FILTER_BILINEAR = 1 - integer(kind=c_int), parameter, public :: TEXTURE_FILTER_TRILINEAR = 2 - integer(kind=c_int), parameter, public :: TEXTURE_FILTER_ANISOTROPIC_4X = 3 - integer(kind=c_int), parameter, public :: TEXTURE_FILTER_ANISOTROPIC_8X = 4 - integer(kind=c_int), parameter, public :: TEXTURE_FILTER_ANISOTROPIC_16X = 5 - - ! TextureWrap - integer(kind=c_int), parameter, public :: TEXTURE_WRAP_REPEAT = 0 - integer(kind=c_int), parameter, public :: TEXTURE_WRAP_CLAMP = 1 - integer(kind=c_int), parameter, public :: TEXTURE_WRAP_MIRROR_REPEAT = 2 - integer(kind=c_int), parameter, public :: TEXTURE_WRAP_MIRROR_CLAMP = 3 - - ! CubemapLayout - integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_AUTO_DETECT = 0 - integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_LINE_VERTICAL = 1 - integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_LINE_HORIZONTAL = 2 - integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_CROSS_THREE_BY_FOUR = 3 - integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_CROSS_FOUR_BY_THREE = 4 - integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_PANORAMA = 5 - - ! FontType - integer(kind=c_int), parameter, public :: FONT_DEFAULT = 0 - integer(kind=c_int), parameter, public :: FONT_BITMAP = 1 - integer(kind=c_int), parameter, public :: FONT_SDF = 2 - - ! BlendMode - integer(kind=c_int), parameter, public :: BLEND_ALPHA = 0 - integer(kind=c_int), parameter, public :: BLEND_ADDITIVE = 1 - integer(kind=c_int), parameter, public :: BLEND_MULTIPLIED = 2 - integer(kind=c_int), parameter, public :: BLEND_ADD_COLORS = 3 - integer(kind=c_int), parameter, public :: BLEND_SUBTRACT_COLORS = 4 - integer(kind=c_int), parameter, public :: BLEND_ALPHA_PREMULTIPLY = 5 - integer(kind=c_int), parameter, public :: BLEND_CUSTOM = 6 - integer(kind=c_int), parameter, public :: BLEND_CUSTOM_SEPARATE = 7 - - ! Gesture - integer(kind=c_int), parameter, public :: GESTURE_NONE = 0 - integer(kind=c_int), parameter, public :: GESTURE_TAP = 1 - integer(kind=c_int), parameter, public :: GESTURE_DOUBLETAP = 2 - integer(kind=c_int), parameter, public :: GESTURE_HOLD = 4 - integer(kind=c_int), parameter, public :: GESTURE_DRAG = 8 - integer(kind=c_int), parameter, public :: GESTURE_SWIPE_RIGHT = 16 - integer(kind=c_int), parameter, public :: GESTURE_SWIPE_LEFT = 32 - integer(kind=c_int), parameter, public :: GESTURE_SWIPE_UP = 64 - integer(kind=c_int), parameter, public :: GESTURE_SWIPE_DOWN = 128 - integer(kind=c_int), parameter, public :: GESTURE_PINCH_IN = 256 - integer(kind=c_int), parameter, public :: GESTURE_PINCH_OUT = 512 - - ! CameraMode - integer(kind=c_int), parameter, public :: CAMERA_CUSTOM = 0 - integer(kind=c_int), parameter, public :: CAMERA_FREE = 1 - integer(kind=c_int), parameter, public :: CAMERA_ORBITAL = 2 - integer(kind=c_int), parameter, public :: CAMERA_FIRST_PERSON = 3 - integer(kind=c_int), parameter, public :: CAMERA_THIRD_PERSON = 4 - - ! CameraProjection - integer(kind=c_int), parameter, public :: CAMERA_PERSPECTIVE = 0 - integer(kind=c_int), parameter, public :: CAMERA_ORTHOGRAPHIC = 1 - - ! NPatchLayout - integer(kind=c_int), parameter, public :: NPATCH_NINE_PATCH = 0 - integer(kind=c_int), parameter, public :: NPATCH_THREE_PATCH_VERTICAL = 1 - integer(kind=c_int), parameter, public :: NPATCH_THREE_PATCH_HORIZONTAL = 2 - - public :: attach_audio_mixed_processor - public :: attach_audio_stream_processor - public :: begin_blend_mode - public :: begin_drawing - public :: begin_mode2d - public :: begin_mode3d - public :: begin_scissor_mode - public :: begin_shader_mode - public :: begin_texture_mode - public :: begin_vr_stereo_mode - public :: change_directory - public :: check_collision_box_sphere - public :: check_collision_boxes - public :: check_collision_circle_rec - public :: check_collision_circles - public :: check_collision_lines - public :: check_collision_point_circle - public :: check_collision_point_line - public :: check_collision_point_poly - public :: check_collision_point_rec - public :: check_collision_point_triangle - public :: check_collision_recs - public :: check_collision_spheres - public :: clear_background - public :: clear_window_state - public :: close_audio_device - public :: close_window - public :: codepoint_to_utf8 - public :: color_alpha - public :: color_alpha_blend - public :: color_brightness - public :: color_contrast - public :: color_from_hsv - public :: color_from_normalized - public :: color_tint - public :: color_to_int - public :: compress_data - public :: decode_data_base64 - public :: decompress_data - public :: detach_audio_mixed_processor - public :: detach_audio_stream_processor - public :: directory_exists - public :: disable_cursor - public :: disable_event_waiting - public :: draw_billboard - public :: draw_billboard_pro - public :: draw_billboard_rec - public :: draw_bounding_box - public :: draw_capsule - public :: draw_capsule_wires - public :: draw_circle - public :: draw_circle3d - public :: draw_circle_gradient - public :: draw_circle_lines - public :: draw_circle_lines_v - public :: draw_circle_sector - public :: draw_circle_sector_lines - public :: draw_circle_v - public :: draw_cube - public :: draw_cube_v - public :: draw_cube_wires - public :: draw_cube_wires_v - public :: draw_cylinder - public :: draw_cylinder_ex - public :: draw_cylinder_wires - public :: draw_cylinder_wires_ex - public :: draw_ellipse - public :: draw_ellipse_lines - public :: draw_fps - public :: draw_grid - public :: draw_line - public :: draw_line3d - public :: draw_line_bezier - public :: draw_line_ex - public :: draw_line_strip - public :: draw_line_v - public :: draw_mesh - public :: draw_mesh_instanced - public :: draw_model - public :: draw_model_ex - public :: draw_model_wires - public :: draw_model_wires_ex - public :: draw_pixel - public :: draw_pixel_v - public :: draw_plane - public :: draw_point3d - public :: draw_poly - public :: draw_poly_lines - public :: draw_poly_lines_ex - public :: draw_ray - public :: draw_rectangle - public :: draw_rectangle_gradient_ex - public :: draw_rectangle_gradient_h - public :: draw_rectangle_gradient_v - public :: draw_rectangle_lines - public :: draw_rectangle_lines_ex - public :: draw_rectangle_pro - public :: draw_rectangle_rec - public :: draw_rectangle_rounded - public :: draw_rectangle_rounded_lines - public :: draw_rectangle_v - public :: draw_ring - public :: draw_ring_lines - public :: draw_sphere - public :: draw_sphere_ex - public :: draw_sphere_wires - public :: draw_spline_basis - public :: draw_spline_bezier_cubic - public :: draw_spline_bezier_quadratic - public :: draw_spline_catmull_rom - public :: draw_spline_linear - public :: draw_spline_segment_basis - public :: draw_spline_segment_bezier_cubic - public :: draw_spline_segment_bezier_quadratic - public :: draw_spline_segment_catmull_rom - public :: draw_spline_segment_linear - public :: draw_text - public :: draw_text_codepoint - public :: draw_text_codepoints - public :: draw_text_ex - public :: draw_text_pro - public :: draw_texture - public :: draw_texture_ex - public :: draw_texture_npatch - public :: draw_texture_pro - public :: draw_texture_rec - public :: draw_texture_v - public :: draw_triangle - public :: draw_triangle3d - public :: draw_triangle_fan - public :: draw_triangle_lines - public :: draw_triangle_strip - public :: draw_triangle_strip3d - public :: enable_cursor - public :: enable_event_waiting - public :: encode_data_base64 - public :: end_blend_mode - public :: end_drawing - public :: end_mode2d - public :: end_mode3d - public :: end_scissor_mode - public :: end_shader_mode - public :: end_texture_mode - public :: end_vr_stereo_mode - public :: export_data_as_code - public :: export_font_as_code - public :: export_image - public :: export_image_as_code - public :: export_image_to_memory - public :: export_mesh - public :: export_wave - public :: export_wave_as_code - public :: fade - public :: file_exists - public :: gen_image_cellular - public :: gen_image_checked - public :: gen_image_color - public :: gen_image_font_atlas - public :: gen_image_gradient_linear - public :: gen_image_gradient_radial - public :: gen_image_gradient_square - public :: gen_image_perlin_noise - public :: gen_image_text - public :: gen_image_white_noise - public :: gen_mesh_cone - public :: gen_mesh_cube - public :: gen_mesh_cubicmap - public :: gen_mesh_cylinder - public :: gen_mesh_heightmap - public :: gen_mesh_hemi_sphere - public :: gen_mesh_knot - public :: gen_mesh_plane - public :: gen_mesh_poly - public :: gen_mesh_sphere - public :: gen_mesh_tangents - public :: gen_mesh_torus - public :: gen_texture_mipmaps - public :: get_application_directory - public :: get_camera_matrix - public :: get_camera_matrix2d - public :: get_char_pressed - public :: get_clipboard_text - public :: get_codepoint - public :: get_codepoint_count - public :: get_codepoint_next - public :: get_codepoint_previous - public :: get_collision_rec - public :: get_color - public :: get_current_monitor - public :: get_directory_path - public :: get_file_extension - public :: get_file_length - public :: get_file_mod_time - public :: get_file_name - public :: get_file_name_without_ext - public :: get_font_default - public :: get_fps - public :: get_frame_time - public :: get_gamepad_axis_count - public :: get_gamepad_axis_movement - public :: get_gamepad_button_pressed - public :: get_gamepad_name - public :: get_gesture_detected - public :: get_gesture_drag_angle - public :: get_gesture_hold_duration - public :: get_gesture_pinch_angle - public :: get_glyph_atlas_rec - public :: get_glyph_index - public :: get_glyph_info - public :: get_image_alpha_border - public :: get_image_color - public :: get_key_pressed - public :: get_master_volume - public :: get_mesh_bounding_box - public :: get_model_bounding_box - public :: get_monitor_count - public :: get_monitor_height - public :: get_monitor_name - public :: get_monitor_physical_height - public :: get_monitor_physical_width - public :: get_monitor_refresh_rate - public :: get_monitor_width - public :: get_mouse_delta - public :: get_mouse_position - public :: get_mouse_ray - public :: get_mouse_wheel_move - public :: get_mouse_x - public :: get_mouse_y - public :: get_music_time_length - public :: get_music_time_played - public :: get_pixel_color - public :: get_pixel_data_size - public :: get_prev_directory_path - public :: get_random_value - public :: get_ray_collision_box - public :: get_ray_collision_mesh - public :: get_ray_collision_quad - public :: get_ray_collision_sphere - public :: get_ray_collision_triangle - public :: get_render_height - public :: get_render_width - public :: get_screen_height - public :: get_screen_to_world2d - public :: get_screen_width - public :: get_shader_location - public :: get_shader_location_attrib - public :: get_spline_point_basis - public :: get_spline_point_bezier_cubic - public :: get_spline_point_bezier_quad - public :: get_spline_point_catmull_rom - public :: get_spline_point_linear - public :: get_time - public :: get_touch_point_count - public :: get_touch_point_id - public :: get_touch_x - public :: get_touch_y - public :: get_window_handle - public :: get_working_directory - public :: get_world_to_screen2d - public :: hide_cursor - public :: image_alpha_clear - public :: image_alpha_crop - public :: image_alpha_mask - public :: image_alpha_premultiply - public :: image_blur_gaussian - public :: image_clear_background - public :: image_color_brightness - public :: image_color_contrast - public :: image_color_grayscale - public :: image_color_invert - public :: image_color_replace - public :: image_color_tint - public :: image_copy - public :: image_crop - public :: image_dither - public :: image_draw - public :: image_draw_circle - public :: image_draw_circle_lines - public :: image_draw_circle_lines_v - public :: image_draw_circle_v - public :: image_draw_line - public :: image_draw_line_v - public :: image_draw_pixel - public :: image_draw_pixel_v - public :: image_draw_rectangle - public :: image_draw_rectangle_lines - public :: image_draw_rectangle_rec - public :: image_draw_rectangle_v - public :: image_draw_text - public :: image_draw_text_ex - public :: image_flip_horizontal - public :: image_flip_vertical - public :: image_format - public :: image_from_image - public :: image_kernel_convolution - public :: image_mipmaps - public :: image_resize - public :: image_resize_canvas - public :: image_resize_nn - public :: image_rotate - public :: image_rotate_ccw - public :: image_rotate_cw - public :: image_text - public :: image_text_ex - public :: image_to_pot - public :: init_audio_device - public :: init_window - public :: is_audio_device_ready - public :: is_audio_stream_playing - public :: is_audio_stream_processed - public :: is_audio_stream_ready - public :: is_cursor_hidden - public :: is_cursor_on_screen - public :: is_file_dropped - public :: is_file_extension - public :: is_font_ready - public :: is_gamepad_available - public :: is_gamepad_button_down - public :: is_gamepad_button_pressed - public :: is_gamepad_button_released - public :: is_gamepad_button_up - public :: is_gesture_detected - public :: is_image_ready - public :: is_key_down - public :: is_key_pressed - public :: is_key_pressed_repeat - public :: is_key_released - public :: is_key_up - public :: is_material_ready - public :: is_model_animation_valid - public :: is_model_ready - public :: is_mouse_button_down - public :: is_mouse_button_pressed - public :: is_mouse_button_released - public :: is_mouse_button_up - public :: is_music_ready - public :: is_music_stream_playing - public :: is_path_file - public :: is_render_texture_ready - public :: is_shader_ready - public :: is_sound_playing - public :: is_sound_ready - public :: is_texture_ready - public :: is_wave_ready - public :: is_window_focused - public :: is_window_fullscreen - public :: is_window_hidden - public :: is_window_maximized - public :: is_window_minimized - public :: is_window_ready - public :: is_window_resized - public :: is_window_state - public :: load_audio_stream - public :: load_codepoints - public :: load_directory_files - public :: load_directory_files_ex - public :: load_dropped_files - public :: load_file_data - public :: load_file_text - public :: load_font - public :: load_font_data - public :: load_font_ex - public :: load_font_from_image - public :: load_font_from_memory - public :: load_image - public :: load_image_anim - public :: load_image_colors - public :: load_image_from_memory - public :: load_image_from_screen - public :: load_image_from_texture - public :: load_image_palette - public :: load_image_raw - public :: load_image_svg - public :: load_material_default - public :: load_materials - public :: load_model - public :: load_model_animations - public :: load_model_from_mesh - public :: load_music_stream - public :: load_music_stream_from_memory - public :: load_random_sequence - public :: load_render_texture - public :: load_shader - public :: load_shader_from_memory - public :: load_sound - public :: load_sound_alias - public :: load_sound_from_wave - public :: load_texture - public :: load_texture_cubemap - public :: load_texture_from_image - public :: load_utf8 - public :: load_vr_stereo_config - public :: load_wave - public :: load_wave_from_memory - public :: load_wave_samples - public :: maximize_window - public :: measure_text - public :: measure_text_ex - public :: mem_alloc - public :: mem_free - public :: mem_realloc - public :: minimize_window - public :: open_url - public :: pause_audio_stream - public :: pause_music_stream - public :: pause_sound - public :: play_audio_stream - public :: play_music_stream - public :: play_sound - public :: poll_input_events - public :: restore_window - public :: resume_audio_stream - public :: resume_music_stream - public :: resume_sound - public :: save_file_data - public :: save_file_text - public :: seek_music_stream - public :: set_audio_stream_buffer_size_default - public :: set_audio_stream_pan - public :: set_audio_stream_pitch - public :: set_audio_stream_volume - public :: set_camera_alt_control - public :: set_camera_mode - public :: set_camera_move_controls - public :: set_camera_pan_control - public :: set_camera_smooth_zoom_control - public :: set_clipboard_text - public :: set_config_flags - public :: set_exit_key - public :: set_gamepad_mappings - public :: set_gestures_enabled - public :: set_load_file_data_callback - public :: set_load_file_text_callback - public :: set_master_volume - public :: set_material_texture - public :: set_model_mesh_material - public :: set_mouse_cursor - public :: set_mouse_offset - public :: set_mouse_position - public :: set_mouse_scale - public :: set_music_pan - public :: set_music_pitch - public :: set_music_volume - public :: set_pixel_color - public :: set_random_seed - public :: set_save_file_data_callback - public :: set_save_file_text_callback - public :: set_shader_value - public :: set_shader_value_matrix - public :: set_shader_value_texture - public :: set_shader_value_v - public :: set_shapes_texture - public :: set_sound_pan - public :: set_sound_pitch - public :: set_sound_volume - public :: set_target_fps - public :: set_text_line_spacing - public :: set_texture_filter - public :: set_texture_wrap - public :: set_trace_log_callback - public :: set_trace_log_level - public :: set_window_focused - public :: set_window_icon - public :: set_window_icons - public :: set_window_max_size - public :: set_window_min_size - public :: set_window_monitor - public :: set_window_opacity - public :: set_window_position - public :: set_window_size - public :: set_window_state - public :: set_window_title - public :: show_cursor - public :: stop_audio_stream - public :: stop_music_stream - public :: stop_sound - public :: swap_screen_buffer - public :: take_screenshot - public :: text_append - public :: text_copy - public :: text_find_index - public :: text_insert - public :: text_is_equal - public :: text_join - public :: text_length - public :: text_replace - public :: text_split - public :: text_subtext - public :: text_to_integer - public :: text_to_lower - public :: text_to_pascal - public :: text_to_upper - public :: toggle_borderless_windowed - public :: toggle_fullscreen - public :: trace_log - public :: unload_audio_stream - public :: unload_codepoints - public :: unload_directory_files - public :: unload_dropped_files - public :: unload_file_data - public :: unload_file_text - public :: unload_font - public :: unload_font_data - public :: unload_image - public :: unload_image_colors - public :: unload_image_palette - public :: unload_material - public :: unload_mesh - public :: unload_model - public :: unload_model_animation - public :: unload_model_animations - public :: unload_music_stream - public :: unload_random_sequence - public :: unload_render_texture - public :: unload_shader - public :: unload_sound - public :: unload_sound_alias - public :: unload_texture - public :: unload_utf8 - public :: unload_vr_stereo_config - public :: unload_wave - public :: unload_wave_samples - public :: update_audio_stream - public :: update_camera - public :: update_mesh_buffer - public :: update_model_animation - public :: update_music_stream - public :: update_sound - public :: update_texture - public :: update_texture_rec - public :: upload_mesh - public :: wait_time - public :: wave_copy - public :: wave_crop - public :: wave_format - public :: window_should_close - - public :: load_file_data_callback - public :: save_file_data_callback - public :: load_file_text_callback - public :: save_file_text_callback - public :: trace_log_callback - - public :: deg2rad - public :: rad2deg - - abstract interface - ! unsigned char *(*LoadFileDataCallback)(const char *fileName, unsigned int *bytesRead) - function load_file_data_callback(file_name, bytes_read) bind(c) - import :: c_ptr, c_unsigned_int - implicit none - type(c_ptr), intent(in), value :: file_name - integer(kind=c_unsigned_int), intent(out) :: bytes_read - type(c_ptr) :: load_file_data_callback - end function load_file_data_callback - - ! bool (*SaveFileDataCallback)(const char *fileName, void *data, unsigned int bytesToWrite) - function save_file_data_callback(file_name, data, bytes_to_write) bind(c) - import :: c_bool, c_ptr, c_unsigned_int - implicit none - type(c_ptr), intent(in), value :: file_name - type(c_ptr), intent(in), value :: data - integer(kind=c_unsigned_int), intent(in), value :: bytes_to_write - logical(kind=c_bool) :: save_file_data_callback - end function save_file_data_callback - - ! char *(*LoadFileTextCallback)(const char *fileName) - function load_file_text_callback(file_name) bind(c) - import :: c_ptr, c_unsigned_int - implicit none - type(c_ptr), intent(in), value :: file_name - type(c_ptr) :: load_file_text_callback - end function load_file_text_callback - - ! bool (*SaveFileTextCallback)(const char *fileName, char *text) - function save_file_text_callback(file_name, text) bind(c) - import :: c_bool, c_ptr - implicit none - type(c_ptr), intent(in), value :: file_name - type(c_ptr), intent(in), value :: text - logical(kind=c_bool) :: save_file_text_callback - end function save_file_text_callback - - ! void (*TraceLogCallback)(int logLevel, const char *text, va_list args) - subroutine trace_log_callback(log_level, text, args) bind(c) - import :: c_int, c_ptr - implicit none - integer(kind=c_int), intent(in), value :: log_level - type(c_ptr), intent(in), value :: text - type(c_ptr), intent(in) :: args(*) - end subroutine trace_log_callback - end interface - - interface - ! void AttachAudioMixedProcessor(AudioCallback processor) - subroutine attach_audio_mixed_processor(processor) bind(c, name='AttachAudioMixedProcessor') - import :: c_funptr - implicit none - type(c_funptr), intent(in), value :: processor - end subroutine attach_audio_mixed_processor - - ! void AttachAudioStreamProcessor(AudioStream stream, AudioCallback processor) - subroutine attach_audio_stream_processor(stream, processor) bind(c, name='AttachAudioStreamProcessor') - import :: audio_stream_type, c_funptr - implicit none - type(audio_stream_type), intent(in), value :: stream - type(c_funptr), intent(in), value :: processor - end subroutine attach_audio_stream_processor - - ! void BeginBlendMode(int mode) - subroutine begin_blend_mode(mode) bind(c, name='BeginBlendMode') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: mode - end subroutine begin_blend_mode - - ! void BeginDrawing(void) - subroutine begin_drawing() bind(c, name='BeginDrawing') - end subroutine begin_drawing - - ! void BeginMode2D(Camera2D camera) - subroutine begin_mode2d(camera) bind(c, name='BeginMode2D') - import :: camera2d_type - implicit none - type(camera2d_type), intent(in), value :: camera - end subroutine begin_mode2d - - ! void BeginMode3D(Camera3D camera) - subroutine begin_mode3d(camera) bind(c, name='BeginMode3D') - import :: camera3d_type - implicit none - type(camera3d_type), intent(in), value :: camera - end subroutine begin_mode3d - - ! void BeginScissorMode(int x, int y, int width, int height) - subroutine begin_scissor_mode(x, y, width, height) bind(c, name='BeginScissorMode') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: x - integer(kind=c_int), intent(in), value :: y - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - end subroutine begin_scissor_mode - - ! void BeginShaderMode(Shader shader) - subroutine begin_shader_mode(shader) bind(c, name='BeginShaderMode') - import :: shader_type - implicit none - type(shader_type), intent(in), value :: shader - end subroutine begin_shader_mode - - ! void BeginTextureMode(RenderTexture2D target) - subroutine begin_texture_mode(target) bind(c, name='BeginTextureMode') - import :: render_texture2d_type - implicit none - type(render_texture2d_type), intent(in), value :: target - end subroutine begin_texture_mode - - ! void BeginVrStereoMode(VrStereoConfig config) - subroutine begin_vr_stereo_mode(config) bind(c, name='BeginVrStereoMode') - import :: vr_stereo_config_type - implicit none - type(vr_stereo_config_type), intent(in), value :: config - end subroutine begin_vr_stereo_mode - - ! bool ChangeDirectory(const char *dir) - function change_directory(dir) bind(c, name='ChangeDirectory') - import :: c_bool, c_char - implicit none - character(kind=c_char), intent(in) :: dir - logical(kind=c_bool) :: change_directory - end function change_directory - - ! bool CheckCollisionBoxSphere(BoundingBox box, Vector3 center, float radius) - function check_collision_box_sphere(box, center, radius) bind(c, name='CheckCollisionBoxSphere') - import :: bounding_box_type, c_bool, c_float, vector3_type - implicit none - type(bounding_box_type), intent(in), value :: box - type(vector3_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - logical(kind=c_bool) :: check_collision_box_sphere - end function check_collision_box_sphere - - ! bool CheckCollisionBoxes(BoundingBox box1, BoundingBox box2) - function check_collision_boxes(box1, box2) bind(c, name='CheckCollisionBoxes') - import :: bounding_box_type, c_bool - implicit none - type(bounding_box_type), intent(in), value :: box1 - type(bounding_box_type), intent(in), value :: box2 - logical(kind=c_bool) :: check_collision_boxes - end function check_collision_boxes - - ! bool CheckCollisionCircleRec(Vector2 center, float radius, Rectangle rec) - function check_collision_circle_rec(center, radius, rec) bind(c, name='CheckCollisionCircleRec') - import :: c_bool, c_float, rectangle_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - type(rectangle_type), intent(in), value :: rec - logical(kind=c_bool) :: check_collision_circle_rec - end function check_collision_circle_rec - - ! bool CheckCollisionCircles(Vector2 center1, float radius1, Vector2 center2, float radius2) - function check_collision_circles(center1, radius1, center2, radius2) bind(c, name='CheckCollisionCircles') - import :: c_bool, c_float, vector2_type - implicit none - type(vector2_type), intent(in), value :: center1 - real(kind=c_float), intent(in), value :: radius1 - type(vector2_type), intent(in), value :: center2 - real(kind=c_float), intent(in), value :: radius2 - logical(kind=c_bool) :: check_collision_circles - end function check_collision_circles - - ! bool CheckCollisionLines(Vector2 startPos1, Vector2 endPos1, Vector2 startPos2, Vector2 endPos2, Vector2 *collisionPoint) - function check_collision_lines(start_pos1, end_pos1, start_pos2, end_pos2, collision_point) & - bind(c, name='CheckCollisionLines') - import :: c_bool, vector2_type - implicit none - type(vector2_type), intent(in), value :: start_pos1 - type(vector2_type), intent(in), value :: end_pos1 - type(vector2_type), intent(in), value :: start_pos2 - type(vector2_type), intent(in), value :: end_pos2 - type(vector2_type), intent(out) :: collision_point - logical(kind=c_bool) :: check_collision_lines - end function check_collision_lines - - ! bool CheckCollisionPointCircle(Vector2 point, Vector2 center, float radius) - function check_collision_point_circle(point, center, radius) bind(c, name='CheckCollisionPointCircle') - import :: c_bool, c_float, vector2_type - implicit none - type(vector2_type), intent(in), value :: point - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - logical(kind=c_bool) :: check_collision_point_circle - end function check_collision_point_circle - - ! bool CheckCollisionPointLine(Vector2 point, Vector2 p1, Vector2 p2, int threshold) - function check_collision_point_line(point, p1, p2, threshold) bind(c, name='CheckCollisionPointLine') - import :: c_bool, c_int, vector2_type - implicit none - type(vector2_type), intent(in), value :: point - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: p2 - integer(kind=c_int), intent(in), value :: threshold - logical(kind=c_bool) :: check_collision_point_line - end function check_collision_point_line - - ! bool CheckCollisionPointPoly(Vector2 point, Vector2 *points, int pointCount) - function check_collision_point_poly(point, points, point_count) bind(c, name='CheckCollisionPointPoly') - import :: c_bool, c_int, vector2_type - implicit none - type(vector2_type), intent(in), value :: point - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - logical(kind=c_bool) :: check_collision_point_poly - end function check_collision_point_poly - - ! bool CheckCollisionPointRec(Vector2 point, Rectangle rec) - function check_collision_point_rec(point, rec) bind(c, name='CheckCollisionPointRec') - import :: c_bool, rectangle_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: point - type(rectangle_type), intent(in), value :: rec - logical(kind=c_bool) :: check_collision_point_rec - end function check_collision_point_rec - - ! bool CheckCollisionPointTriangle(Vector2 point, Vector2 p1, Vector2 p2, Vector2 p3) - function check_collision_point_triangle(point, p1, p2, p3) bind(c, name='CheckCollisionPointTriangle') - import :: c_bool, vector2_type - implicit none - type(vector2_type), intent(in), value :: point - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: p2 - type(vector2_type), intent(in), value :: p3 - logical(kind=c_bool) :: check_collision_point_triangle - end function check_collision_point_triangle - - ! bool CheckCollisionRecs(Rectangle rec1, Rectangle rec2) - function check_collision_recs(rec1, rec2) bind(c, name='CheckCollisionRecs') - import :: c_bool, rectangle_type - implicit none - type(rectangle_type), intent(in), value :: rec1 - type(rectangle_type), intent(in), value :: rec2 - logical(kind=c_bool) :: check_collision_recs - end function check_collision_recs - - ! bool CheckCollisionSpheres(Vector3 center1, float radius1, Vector3 center2, float radius2) - function check_collision_spheres(center1, radius1, center2, radius2) bind(c, name='CheckCollisionSpheres') - import :: c_bool, c_float, vector3_type - implicit none - type(vector3_type), intent(in), value :: center1 - real(kind=c_float), intent(in), value :: radius1 - type(vector3_type), intent(in), value :: center2 - real(kind=c_float), intent(in), value :: radius2 - logical(kind=c_bool) :: check_collision_spheres - end function check_collision_spheres - - ! void ClearBackground(Color color) - subroutine clear_background(color) bind(c, name='ClearBackground') - import :: color_type - implicit none - type(color_type), intent(in), value :: color - end subroutine clear_background - - ! void ClearWindowState(unsigned int flags) - subroutine clear_window_state(flags) bind(c, name='ClearWindowState') - import :: c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: flags - end subroutine clear_window_state - - ! void CloseAudioDevice(void) - subroutine close_audio_device() bind(c, name='CloseAudioDevice') - end subroutine close_audio_device - - ! void CloseWindow(void) - subroutine close_window() bind(c, name='CloseWindow') - end subroutine close_window - - ! const char *CodepointToUTF8(int codepoint, int *utf8Size) - function codepoint_to_utf8(codepoint, utf8_size) bind(c, name='CodepointToUTF8') - import :: c_int, c_ptr - implicit none - integer(kind=c_int), intent(in), value :: codepoint - integer(kind=c_int), intent(out) :: utf8_size - type(c_ptr) :: codepoint_to_utf8 - end function codepoint_to_utf8 - - ! Color ColorAlpha(Color color, float alpha) - function color_alpha(color, alpha) bind(c, name='ColorAlpha') - import :: c_float, color_type - implicit none - type(color_type), intent(in), value :: color - real(kind=c_float), intent(in), value :: alpha - type(color_type) :: color_alpha - end function color_alpha - - ! Color ColorAlphaBlend(Color dst, Color src, Color tint) - function color_alpha_blend(dst, src, tint) bind(c, name='ColorAlphaBlend') - import :: color_type - implicit none - type(color_type), intent(in), value :: dst - type(color_type), intent(in), value :: src - type(color_type), intent(in), value :: tint - type(color_type) :: color_alpha_blend - end function color_alpha_blend - - ! Color ColorBrightness(Color color, float factor) - function color_brightness(color, factor) bind(c, name='ColorBrightness') - import :: c_float, color_type - implicit none - type(color_type), intent(in), value :: color - real(kind=c_float), intent(in), value :: factor - type(color_type) :: color_brightness - end function color_brightness - - ! Color ColorContrast(Color color, float contrast) - function color_contrast(color, contrast) bind(c, name='ColorContrast') - import :: c_float, color_type - implicit none - type(color_type), intent(in), value :: color - real(kind=c_float), intent(in), value :: contrast - type(color_type) :: color_contrast - end function color_contrast - - ! Color ColorFromHSV(float hue, float saturation, float value) - function color_from_hsv(hue, saturation, value) bind(c, name='ColorFromHSV') - import :: c_float, color_type - implicit none - real(kind=c_float), intent(in), value :: hue - real(kind=c_float), intent(in), value :: saturation - real(kind=c_float), intent(in), value :: value - type(color_type) :: color_from_hsv - end function color_from_hsv - - ! Color ColorFromNormalized(Vector4 normalized) - function color_from_normalized(normalized) bind(c, name='ColorFromNormalized') - import :: color_type, vector4_type - implicit none - type(vector4_type), intent(in), value :: normalized - type(color_type) :: color_from_normalized - end function color_from_normalized - - ! Color ColorTint(Color color, Color tint) - function color_tint(color, tint) bind(c, name='ColorTint') - import :: color_type - implicit none - type(color_type), intent(in), value :: color - type(color_type), intent(in), value :: tint - type(color_type) :: color_tint - end function color_tint - - ! int ColorToInt(Color color) - function color_to_int(color) bind(c, name='ColorToInt') - import :: c_int, color_type - implicit none - type(color_type), intent(in), value :: color - integer(kind=c_int) :: color_to_int - end function color_to_int - - ! unsigned char *CompressData(const unsigned char *data, int dataSize, int *compDataSize) - function compress_data(data, data_size, comp_data_size) bind(c, name='CompressData') - import :: c_int, c_ptr, c_unsigned_char - implicit none - integer(kind=c_unsigned_char), intent(in) :: data - integer(kind=c_int), intent(in), value :: data_size - integer(kind=c_int), intent(out) :: comp_data_size - type(c_ptr) :: compress_data - end function compress_data - - ! unsigned char *DecodeDataBase64(const unsigned char *data, int *outputSize) - function decode_data_base64(data, output_size) bind(c, name='DecodeDataBase64') - import :: c_int, c_unsigned_char, c_ptr - implicit none - integer(kind=c_unsigned_char), intent(in) :: data - integer(kind=c_int), intent(out) :: output_size - type(c_ptr) :: decode_data_base64 - end function decode_data_base64 - - ! unsigned char *DecompressData(const unsigned char *compData, int compDataSize, int *dataSize) - function decompress_data(comp_data, comp_data_size, data_size) bind(c, name='DecompressData') - import :: c_int, c_ptr, c_unsigned_char - implicit none - integer(kind=c_unsigned_char), intent(in) :: comp_data - integer(kind=c_int), intent(in), value :: comp_data_size - integer(kind=c_int), intent(out) :: data_size - type(c_ptr) :: decompress_data - end function decompress_data - - ! void DetachAudioMixedProcessor(AudioCallback processor) - subroutine detach_audio_mixed_processor(processor) bind(c, name='DetachAudioMixedProcessor') - import :: c_funptr - implicit none - type(c_funptr), intent(in), value :: processor - end subroutine detach_audio_mixed_processor - - ! void DetachAudioStreamProcessor(AudioStream stream, AudioCallback processor) - subroutine detach_audio_stream_processor(stream, processor) bind(c, name='DetachAudioStreamProcessor') - import :: audio_stream_type, c_funptr - implicit none - type(audio_stream_type), intent(in), value :: stream - type(c_funptr), intent(in), value :: processor - end subroutine detach_audio_stream_processor - - ! bool DirectoryExists(const char *dirPath) - function directory_exists(dir_path) bind(c, name='DirectoryExists') - import :: c_bool, c_char - implicit none - character(kind=c_char), intent(in) :: dir_path - logical(kind=c_bool) :: directory_exists - end function directory_exists - - ! void DisableCursor(void) - subroutine disable_cursor() bind(c, name='DisableCursor') - end subroutine disable_cursor - - ! void DisableEventWaiting(void) - subroutine disable_event_waiting() bind(c, name='DisableEventWaiting') - end subroutine disable_event_waiting - - ! void DrawBillboard(Camera camera, Texture2D texture, Vector3 position, float size, Color tint) - subroutine draw_billboard(camera, texture, position, size, tint) bind(c, name='DrawBillboard') - import :: c_float, camera3d_type, color_type, texture2d_type, vector3_type - implicit none - type(camera3d_type), intent(in), value :: camera - type(texture2d_type), intent(in), value :: texture - type(vector3_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: size - type(color_type), intent(in), value :: tint - end subroutine draw_billboard - - ! void DrawBillboardPro(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector3 up, Vector2 size, Vector2 origin, float rotation, Color tint) - subroutine draw_billboard_pro(camera, texture, source, position, up, size, origin, rotation, tint) & - bind(c, name='DrawBillboardPro') - import :: c_float, camera3d_type, color_type, rectangle_type, texture2d_type, vector2_type, vector3_type - implicit none - type(camera3d_type), intent(in), value :: camera - type(texture2d_type), intent(in), value :: texture - type(rectangle_type), intent(in), value :: source - type(vector3_type), intent(in), value :: position - type(vector3_type), intent(in), value :: up - type(vector2_type), intent(in), value :: size - type(vector2_type), intent(in), value :: origin - real(kind=c_float), intent(in), value :: rotation - type(color_type), intent(in), value :: tint - end subroutine draw_billboard_pro - - ! void DrawBillboardRec(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector2 size, Color tint) - subroutine draw_billboard_rec(camera, texture, source, position, size, tint) bind(c, name='DrawBillboardRec') - import :: camera3d_type, color_type, rectangle_type, texture2d_type, vector2_type, vector3_type - implicit none - type(camera3d_type), intent(in), value :: camera - type(texture2d_type), intent(in), value :: texture - type(rectangle_type), intent(in), value :: source - type(vector3_type), intent(in), value :: position - type(vector2_type), intent(in), value :: size - type(color_type), intent(in), value :: tint - end subroutine draw_billboard_rec - - ! void DrawBoundingBox(BoundingBox box, Color color) - subroutine draw_bounding_box(box, color) bind(c, name='DrawBoundingBox') - import :: bounding_box_type, color_type - implicit none - type(bounding_box_type), intent(in), value :: box - type(color_type), intent(in), value :: color - end subroutine draw_bounding_box - - ! void DrawCapsule(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) - subroutine draw_capsule(start_pos, end_pos, radius, slices, rings, color) bind(c, name='DrawCapsule') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: start_pos - type(vector3_type), intent(in), value :: end_pos - real(kind=c_float), intent(in), value :: radius - integer(kind=c_int), intent(in), value :: slices - integer(kind=c_int), intent(in), value :: rings - type(color_type), intent(in), value :: color - end subroutine draw_capsule - - ! void DrawCapsuleWires(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) - subroutine draw_capsule_wires(start_pos, end_pos, radius, slices, rings, color) bind(c, name='DrawCapsuleWires') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: start_pos - type(vector3_type), intent(in), value :: end_pos - real(kind=c_float), intent(in), value :: radius - integer(kind=c_int), intent(in), value :: slices - integer(kind=c_int), intent(in), value :: rings - type(color_type), intent(in), value :: color - end subroutine draw_capsule_wires - - ! void DrawCircle(int centerX, int centerY, float radius, Color color) - subroutine draw_circle(center_x, center_y, radius, color) bind(c, name='DrawCircle') - import :: c_float, c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: center_x - integer(kind=c_int), intent(in), value :: center_y - real(kind=c_float), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine draw_circle - - ! void DrawCircle3D(Vector3 center, float radius, Vector3 rotationAxis, float rotationAngle, Color color) - subroutine draw_circle3d(center, radius, rotation_axis, rotation_angle, color) bind(c, name='DrawCircle3D') - import :: c_float, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - type(vector3_type), intent(in), value :: rotation_axis - real(kind=c_float), intent(in), value :: rotation_angle - type(color_type), intent(in), value :: color - end subroutine draw_circle3d - - ! void DrawCircleGradient(int centerX, int centerY, float radius, Color color1, Color color2) - subroutine draw_circle_gradient(center_x, center_y, radius, color1, color2) bind(c, name='DrawCircleGradient') - import :: c_float, c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: center_x - integer(kind=c_int), intent(in), value :: center_y - real(kind=c_float), intent(in), value :: radius - type(color_type), intent(in), value :: color1 - type(color_type), intent(in), value :: color2 - end subroutine draw_circle_gradient - - ! void DrawCircleLines(int centerX, int centerY, float radius, Color color) - subroutine draw_circle_lines(center_x, center_y, radius, color) bind(c, name='DrawCircleLines') - import :: c_float, c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: center_x - integer(kind=c_int), intent(in), value :: center_y - real(kind=c_float), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine draw_circle_lines - - ! void DrawCircleLinesV(Vector2 center, float radius, Color color) - subroutine draw_circle_lines_v(center, radius, color) bind(c, name='DrawCircleLinesV') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine draw_circle_lines_v - - ! void DrawCircleSector(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) - subroutine draw_circle_sector(center, radius, start_angle, end_angle, segments, color) & - bind(c, name='DrawCircleSector') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - real(kind=c_float) , intent(in), value :: start_angle - real(kind=c_float), intent(in), value :: end_angle - integer(kind=c_int), intent(in), value :: segments - type(color_type), intent(in), value :: color - end subroutine draw_circle_sector - - ! void DrawCircleSectorLines(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) - subroutine draw_circle_sector_lines(center, radius, start_angle, end_angle, segments, color) & - bind(c, name='DrawCircleSectorLines') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: start_angle - real(kind=c_float), intent(in), value :: end_angle - integer(kind=c_int), intent(in), value :: segments - type(color_type), intent(in), value :: color - end subroutine draw_circle_sector_lines - - ! void DrawCircleV(Vector2 center, float radius, Color color) - subroutine draw_circle_v(center, radius, color) bind(c, name='DrawCircleV') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine draw_circle_v - - ! void DrawCube(Vector3 position, float width, float height, float length, Color color) - subroutine draw_cube(position, width, height, length, color) bind(c, name='DrawCube') - import :: c_float, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: width - real(kind=c_float), intent(in), value :: height - real(kind=c_float), intent(in), value :: length - type(color_type), intent(in), value :: color - end subroutine draw_cube - - ! void DrawCubeV(Vector3 position, Vector3 size, Color color) - subroutine draw_cube_v(position, size, color) bind(c, name='DrawCubeV') - import :: color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: position - type(vector3_type), intent(in), value :: size - type(color_type), intent(in), value :: color - end subroutine draw_cube_v - - ! void DrawCubeWires(Vector3 position, float width, float height, float length, Color color) - subroutine draw_cube_wires(position, width, height, length, color) bind(c, name='DrawCubeWires') - import :: c_float, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: width - real(kind=c_float), intent(in), value :: height - real(kind=c_float), intent(in), value :: length - type(color_type), intent(in), value :: color - end subroutine draw_cube_wires - - ! void DrawCubeWiresV(Vector3 position, Vector3 size, Color color) - subroutine draw_cube_wires_v(position, size, color) bind(c, name='DrawCubeWiresV') - import :: color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: position - type(vector3_type), intent(in), value :: size - type(color_type), intent(in), value :: color - end subroutine draw_cube_wires_v - - ! void DrawCylinder(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) - subroutine draw_cylinder(position, radius_top, radius_bottom, height, slices, color) bind(c, name='DrawCylinder') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: radius_top - real(kind=c_float), intent(in), value :: radius_bottom - real(kind=c_float), intent(in), value :: height - integer(kind=c_int), intent(in), value :: slices - type(color_type), intent(in), value :: color - end subroutine draw_cylinder - - ! void DrawCylinderEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) - subroutine draw_cylinder_ex(start_pos, end_pos, start_radius, end_radius, sides, color) bind(c, name='DrawCylinderEx') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: start_pos - type(vector3_type), intent(in), value :: end_pos - real(kind=c_float), intent(in), value :: start_radius - real(kind=c_float), intent(in), value :: end_radius - integer(kind=c_int), intent(in), value :: sides - type(color_type), intent(in), value :: color - end subroutine draw_cylinder_ex - - ! void DrawCylinderWires(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) - subroutine draw_cylinder_wires(position, radius_top, radius_bottom, height, slices, color) & - bind(c, name='DrawCylinderWires') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: radius_top - real(kind=c_float), intent(in), value :: radius_bottom - real(kind=c_float), intent(in), value :: height - integer(kind=c_int), intent(in), value :: slices - type(color_type), intent(in), value :: color - end subroutine draw_cylinder_wires - - ! void DrawCylinderWiresEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) - subroutine draw_cylinder_wires_ex(start_pos, end_pos, start_radius, end_radius, sides, color) & - bind(c, name='DrawCylinderWiresEx') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: start_pos - type(vector3_type), intent(in), value :: end_pos - real(kind=c_float), intent(in), value :: start_radius - real(kind=c_float), intent(in), value :: end_radius - integer(kind=c_int), intent(in), value :: sides - type(color_type), intent(in), value :: color - end subroutine draw_cylinder_wires_ex - - ! void DrawEllipse(int centerX, int centerY, float radiusH, float radiusV, Color color) - subroutine draw_ellipse(center_x, center_y, radius_h, radius_v, color) bind(c, name='DrawEllipse') - import :: c_float, c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: center_x - integer(kind=c_int), intent(in), value :: center_y - real(kind=c_float), intent(in), value :: radius_h - real(kind=c_float), intent(in), value :: radius_v - type(color_type), intent(in), value :: color - end subroutine draw_ellipse - - ! void DrawEllipseLines(int centerX, int centerY, float radiusH, float radiusV, Color color) - subroutine draw_ellipse_lines(center_x, center_y, radius_h, radius_v, color) bind(c, name='DrawEllipseLines') - import :: c_float, c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: center_x - integer(kind=c_int), intent(in), value :: center_y - real(kind=c_float), intent(in), value :: radius_h - real(kind=c_float), intent(in), value :: radius_v - type(color_type), intent(in), value :: color - end subroutine draw_ellipse_lines - - ! void DrawFPS(int posX, int posY) - subroutine draw_fps(pos_x, pos_y) bind(c, name='DrawFPS') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - end subroutine draw_fps - - ! void DrawGrid(int slices, float spacing) - subroutine draw_grid(slices, spacing) bind(c, name='DrawGrid') - import :: c_float, c_int - implicit none - integer(kind=c_int), intent(in), value :: slices - real(kind=c_float), intent(in), value :: spacing - end subroutine draw_grid - - ! void DrawLine(int startPosX, int startPosY, int endPosX, int endPosY, Color color) - subroutine draw_line(start_pos_x, start_pos_y, end_pos_x, end_pos_y, color) bind(c, name='DrawLine') - import :: c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: start_pos_x - integer(kind=c_int), intent(in), value :: start_pos_y - integer(kind=c_int), intent(in), value :: end_pos_x - integer(kind=c_int), intent(in), value :: end_pos_y - type(color_type), intent(in), value :: color - end subroutine draw_line - - ! void DrawLine3D(Vector3 startPos, Vector3 endPos, Color color) - subroutine draw_line3d(start_pos, end_pos, color) bind(c, name='DrawLine3D') - import :: color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: start_pos - type(vector3_type), intent(in), value :: end_pos - type(color_type), intent(in), value :: color - end subroutine draw_line3d - - ! void DrawLineBezier(Vector2 startPos, Vector2 endPos, float thick, Color color) - subroutine draw_line_bezier(start_pos, end_pos, thick, color) bind(c, name='DrawLineBezier') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: start_pos - type(vector2_type), intent(in), value :: end_pos - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_line_bezier - - ! void DrawLineEx(Vector2 startPos, Vector2 endPos, float thick, Color color) - subroutine draw_line_ex(start_pos, end_pos, thick, color) bind(c, name='DrawLineEx') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: start_pos - type(vector2_type), intent(in), value :: end_pos - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_line_ex - - ! void DrawLineStrip(Vector2 *points, int pointCount, Color color) - subroutine draw_line_strip(points, point_count, color) bind(c, name='DrawLineStrip') - import :: c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - type(color_type), intent(in), value :: color - end subroutine draw_line_strip - - ! void DrawLineV(Vector2 startPos, Vector2 endPos, Color color) - subroutine draw_line_v(start_pos, end_pos, color) bind(c, name='DrawLineV') - import :: color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: start_pos - type(vector2_type), intent(in), value :: end_pos - type(color_type), intent(in), value :: color - end subroutine draw_line_v - - ! void DrawMesh(Mesh mesh, Material material, Matrix transform) - subroutine draw_mesh(mesh, material, transform) bind(c, name='DrawMesh') - import :: material_type, matrix_type, mesh_type - implicit none - type(mesh_type), intent(in), value :: mesh - type(material_type), intent(in), value :: material - type(matrix_type), intent(in), value :: transform - end subroutine draw_mesh - - ! void DrawMeshInstanced(Mesh mesh, Material material, const Matrix *transforms, int instances) - subroutine draw_mesh_instanced(mesh, material, transforms, instances) bind(c, name='DrawMeshInstanced') - import :: c_int, material_type, matrix_type, mesh_type - implicit none - type(mesh_type), intent(in), value :: mesh - type(material_type), intent(in), value :: material - type(matrix_type), intent(inout) :: transforms - integer(kind=c_int), intent(in), value :: instances - end subroutine draw_mesh_instanced - - ! void DrawModel(Model model, Vector3 position, float scale, Color tint) - subroutine draw_model(model, position, scale, tint) bind(c, name='DrawModel') - import :: c_float, color_type, model_type, vector3_type - implicit none - type(model_type), intent(in), value :: model - type(vector3_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: scale - type(color_type), intent(in), value :: tint - end subroutine draw_model - - ! void DrawModelEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) - subroutine draw_model_ex(model, position, rotation_axis, rotation_angle, scale, tint) & - bind(c, name='DrawModelEx') - import :: c_float, color_type, model_type, vector3_type - implicit none - type(model_type), intent(in), value :: model - type(vector3_type), intent(in), value :: position - type(vector3_type), intent(in), value :: rotation_axis - real(kind=c_float), intent(in), value :: rotation_angle - type(vector3_type), intent(in), value :: scale - type(color_type), intent(in), value :: tint - end subroutine draw_model_ex - - ! void DrawModelWires(Model model, Vector3 position, float scale, Color tint) - subroutine draw_model_wires(model, position, scale, tint) bind(c, name='DrawModelWires') - import :: c_float, color_type, model_type, vector3_type - implicit none - type(model_type), intent(in), value :: model - type(vector3_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: scale - type(color_type), intent(in), value :: tint - end subroutine draw_model_wires - - ! void DrawModelWiresEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) - subroutine draw_model_wires_ex(model, position, rotation_axis, rotation_angle, scale, tint) & - bind(c, name='DrawModelWiresEx') - import :: c_float, color_type, model_type, vector3_type - implicit none - type(model_type), intent(in), value :: model - type(vector3_type), intent(in), value :: position - type(vector3_type), intent(in), value :: rotation_axis - real(kind=c_float), intent(in), value :: rotation_angle - type(vector3_type), intent(in), value :: scale - type(color_type), intent(in), value :: tint - end subroutine draw_model_wires_ex - - ! void DrawPixel(int posX, int posY, Color color) - subroutine draw_pixel(pos_x, pos_y, color) bind(c, name='DrawPixel') - import :: c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - type(color_type), intent(in), value :: color - end subroutine draw_pixel - - ! void DrawPixelV(Vector2 position, Color color) - subroutine draw_pixel_v(position, color) bind(c, name='DrawPixelV') - import :: color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: position - type(color_type), intent(in), value :: color - end subroutine draw_pixel_v - - ! void DrawPlane(Vector3 centerPos, Vector2 size, Color color) - subroutine draw_plane(center_pos, size, color) bind(c, name='DrawPlane') - import :: color_type, vector2_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: center_pos - type(vector2_type), intent(in), value :: size - type(color_type), intent(in), value :: color - end subroutine draw_plane - - ! void DrawPoint3D(Vector3 position, Color color) - subroutine draw_point3d(position, color) bind(c, name='DrawPoint3D') - import :: color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: position - type(color_type), intent(in), value :: color - end subroutine draw_point3d - - ! void DrawPoly(Vector2 center, int sides, float radius, float rotation, Color color) - subroutine draw_poly(center, sides, radius, rotation, color) bind(c, name='DrawPoly') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - integer(kind=c_int), intent(in), value :: sides - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: rotation - type(color_type), intent(in), value :: color - end subroutine draw_poly - - ! void DrawPolyLines(Vector2 center, int sides, float radius, float rotation, Color color) - subroutine draw_poly_lines(center, sides, radius, rotation, color) bind(c, name='DrawPolyLines') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - integer(kind=c_int), intent(in), value :: sides - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: rotation - type(color_type), intent(in), value :: color - end subroutine draw_poly_lines - - ! void DrawPolyLinesEx(Vector2 center, int sides, float radius, float rotation, float lineThick, Color color) - subroutine draw_poly_lines_ex(center, sides, radius, rotation, line_thick, color) & - bind(c, name='DrawPolyLinesEx') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - integer(kind=c_int), intent(in), value :: sides - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: rotation - real(kind=c_float), intent(in), value :: line_thick - type(color_type), intent(in), value :: color - end subroutine draw_poly_lines_ex - - ! void DrawRay(Ray ray, Color color) - subroutine draw_ray(ray, color) bind(c, name='DrawRay') - import :: color_type, ray_type - implicit none - type(ray_type), intent(in), value :: ray - type(color_type), intent(in), value :: color - end subroutine draw_ray - - ! void DrawRectangle(int posX, int posY, int width, int height, Color color) - subroutine draw_rectangle(pos_x, pos_y, width, height, color) bind(c, name='DrawRectangle') - import :: c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(color_type), intent(in), value :: color - end subroutine draw_rectangle - - ! void DrawRectangleGradientEx(Rectangle rec, Color col1, Color col2, Color col3, Color col4) - subroutine draw_rectangle_gradient_ex(rec, col1, col2, col3, col4) bind(c, name='DrawRectangleGradientEx') - import :: color_type, rectangle_type - implicit none - type(rectangle_type), intent(in), value :: rec - type(color_type), intent(in), value :: col1 - type(color_type), intent(in), value :: col2 - type(color_type), intent(in), value :: col3 - type(color_type), intent(in), value :: col4 - end subroutine draw_rectangle_gradient_ex - - ! void DrawRectangleGradientH(int posX, int posY, int width, int height, Color color1, Color color2) - subroutine draw_rectangle_gradient_h(pos_x, pos_y, width, height, color1, color2) & - bind(c, name='DrawRectangleGradientH') - import :: c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(color_type), intent(in), value :: color1 - type(color_type), intent(in), value :: color2 - end subroutine draw_rectangle_gradient_h - - ! void DrawRectangleGradientV(int posX, int posY, int width, int height, Color color1, Color color2) - subroutine draw_rectangle_gradient_v(pos_x, pos_y, width, height, color1, color2) & - bind(c, name='DrawRectangleGradientV') - import :: c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(color_type), intent(in), value :: color1 - type(color_type), intent(in), value :: color2 - end subroutine draw_rectangle_gradient_v - - ! void DrawRectangleLines(int posX, int posY, int width, int height, Color color) - subroutine draw_rectangle_lines(pos_x, pos_y, width, height, color) bind(c, name='DrawRectangleLines') - import :: c_int, color_type - implicit none - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(color_type), intent(in), value :: color - end subroutine draw_rectangle_lines - - ! void DrawRectangleLinesEx(Rectangle rec, float lineThick, Color color) - subroutine draw_rectangle_lines_ex(rec, line_thick, color) bind(c, name='DrawRectangleLinesEx') - import :: c_float, color_type, rectangle_type - implicit none - type(rectangle_type), intent(in), value :: rec - real(kind=c_float), intent(in), value :: line_thick - type(color_type), intent(in), value :: color - end subroutine draw_rectangle_lines_ex - - ! void DrawRectanglePro(Rectangle rec, Vector2 origin, float rotation, Color color) - subroutine draw_rectangle_pro(rec, origin, rotation, color) bind(c, name='DrawRectanglePro') - import :: c_float, color_type, rectangle_type, vector2_type - implicit none - type(rectangle_type), intent(in), value :: rec - type(vector2_type), intent(in), value :: origin - real(kind=c_float), intent(in), value :: rotation - type(color_type), intent(in), value :: color - end subroutine draw_rectangle_pro - - ! void DrawRectangleRec(Rectangle rec, Color color) - subroutine draw_rectangle_rec(rec, color) bind(c, name='DrawRectangleRec') - import :: color_type, rectangle_type - implicit none - type(rectangle_type), intent(in), value :: rec - type(color_type), intent(in), value :: color - end subroutine draw_rectangle_rec - - ! void DrawRectangleRounded(Rectangle rec, float roundness, int segments, Color color) - subroutine draw_rectangle_rounded(rec, roundness, segments, color) bind(c, name='DrawRectangleRounded') - import :: c_float, c_int, color_type, rectangle_type - implicit none - type(rectangle_type), intent(in), value :: rec - real(kind=c_float), intent(in), value :: roundness - integer(kind=c_int), intent(in), value :: segments - type(color_type), intent(in), value :: color - end subroutine draw_rectangle_rounded - - ! void DrawRectangleRoundedLines(Rectangle rec, float roundness, int segments, float lineThick, Color color) - subroutine draw_rectangle_rounded_lines(rec, roundness, segments, line_thick, color) & - bind(c, name='DrawRectangleRoundedLines') - import :: c_float, c_int, color_type, rectangle_type - implicit none - type(rectangle_type), intent(in), value :: rec - real(kind=c_float), intent(in), value :: roundness - integer(kind=c_int), intent(in), value :: segments - real(kind=c_float), intent(in), value :: line_thick - type(color_type), intent(in), value :: color - end subroutine draw_rectangle_rounded_lines - - ! void DrawRectangleV(Vector2 position, Vector2 size, Color color) - subroutine draw_rectangle_v(position, size, color) bind(c, name='DrawRectangleV') - import :: color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: position - type(vector2_type), intent(in), value :: size - type(color_type), intent(in), value :: color - end subroutine draw_rectangle_v - - ! void DrawRing(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) - subroutine draw_ring(center, inner_radius, outer_radius, start_angle, end_angle, segments, color) & - bind(c, name='DrawRing') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: inner_radius - real(kind=c_float), intent(in), value :: outer_radius - real(kind=c_float), intent(in), value :: start_angle - real(kind=c_float), intent(in), value :: end_angle - integer(kind=c_int), intent(in), value :: segments - type(color_type), intent(in), value :: color - end subroutine draw_ring - - ! void DrawRingLines(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) - subroutine draw_ring_lines(center, inner_radius, outer_radius, start_angle, end_angle, segments, color) & - bind(c, name='DrawRingLines') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: inner_radius - real(kind=c_float), intent(in), value :: outer_radius - real(kind=c_float), intent(in), value :: start_angle - real(kind=c_float), intent(in), value :: end_angle - integer(kind=c_int), intent(in), value :: segments - type(color_type), intent(in), value :: color - end subroutine draw_ring_lines - - ! void DrawSphere(Vector3 centerPos, float radius, Color color) - subroutine draw_sphere(center_pos, radius, color) bind(c, name='DrawSphere') - import :: c_float, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: center_pos - real(kind=c_float), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine draw_sphere - - ! void DrawSphereEx(Vector3 centerPos, float radius, int rings, int slices, Color color) - subroutine draw_sphere_ex(center_pos, radius, rings, slices, color) bind(c, name='DrawSphereEx') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: center_pos - real(kind=c_float), intent(in), value :: radius - integer(kind=c_int), intent(in), value :: rings - integer(kind=c_int), intent(in), value :: slices - type(color_type), intent(in), value :: color - end subroutine draw_sphere_ex - - ! void DrawSphereWires(Vector3 centerPos, float radius, int rings, int slices, Color color) - subroutine draw_sphere_wires(center_pos, radius, rings, slices, color) bind(c, name='DrawSphereWires') - import :: c_float, c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: center_pos - real(kind=c_float), intent(in), value :: radius - integer(kind=c_int), intent(in), value :: rings - integer(kind=c_int), intent(in), value :: slices - type(color_type), intent(in), value :: color - end subroutine draw_sphere_wires - - ! void DrawSplineBasis(Vector2 *points, int pointCount, float thick, Color color) - subroutine draw_spline_basis(points, point_count, thick, color) bind(c, name='DrawSplineBasis') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_basis - - ! void DrawSplineBezierCubic(Vector2 *points, int pointCount, float thick, Color color) - subroutine draw_spline_bezier_cubic(points, point_count, thick, color) bind(c, name='DrawSplineBezierCubic') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_bezier_cubic - - ! void DrawSplineBezierQuadratic(Vector2 *points, int pointCount, float thick, Color color) - subroutine draw_spline_bezier_quadratic(points, point_count, thick, color) bind(c, name='DrawSplineBezierQuadratic') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_bezier_quadratic - - ! void DrawSplineCatmullRom(Vector2 *points, int pointCount, float thick, Color color) - subroutine draw_spline_catmull_rom(points, point_count, thick, color) bind(c, name='DrawSplineCatmullRom') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_catmull_rom - - ! void DrawSplineLinear(Vector2 *points, int pointCount, float thick, Color color) - subroutine draw_spline_linear(points, point_count, thick, color) bind(c, name='DrawSplineLinear') - import :: c_float, c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_linear - - ! void DrawSplineSegmentBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) - subroutine draw_spline_segment_basis(p1, p2, p3, p4, thick, color) bind(c, name='DrawSplineSegmentBasis') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: p2 - type(vector2_type), intent(in), value :: p3 - type(vector2_type), intent(in), value :: p4 - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_segment_basis - - ! void DrawSplineSegmentBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float thick, Color color) - subroutine draw_spline_segment_bezier_cubic(p1, c2, c3, p4, thick, color) bind(c, name='DrawSplineSegmentBezierCubic') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: c2 - type(vector2_type), intent(in), value :: c3 - type(vector2_type), intent(in), value :: p4 - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_segment_bezier_cubic - - ! void DrawSplineSegmentBezierQuadratic(Vector2 p1, Vector2 c2, Vector2 p3, float thick, Color color) - subroutine draw_spline_segment_bezier_quadratic(p1, c2, p3, thick, color) bind(c, name='DrawSplineSegmentBezierQuadratic') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: c2 - type(vector2_type), intent(in), value :: p3 - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_segment_bezier_quadratic - - ! void DrawSplineSegmentCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) - subroutine draw_spline_segment_catmull_rom(p1, p2, p3, p4, thick, color) bind(c, name='DrawSplineSegmentCatmullRom') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: p2 - type(vector2_type), intent(in), value :: p3 - type(vector2_type), intent(in), value :: p4 - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_segment_catmull_rom - - ! void DrawSplineSegmentLinear(Vector2 p1, Vector2 p2, float thick, Color color) - subroutine draw_spline_segment_linear(p1, p2, thick, color) bind(c, name='DrawSplineSegmentLinear') - import :: c_float, color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: p2 - real(kind=c_float), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine draw_spline_segment_linear - - ! void DrawTriangleStrip3D(Vector3 *points, int pointCount, Color color) - subroutine draw_triangle_strip3d(points, point_count, color) bind(c, name='DrawTriangleStrip3D') - import :: c_int, color_type, vector3_type - implicit none - type(vector3_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - type(color_type), intent(in), value :: color - end subroutine draw_triangle_strip3d - - ! void DrawText(const char *text, int posX, int posY, int fontSize, Color color) - subroutine draw_text(text, pos_x, pos_y, font_size, color) bind(c, name='DrawText') - import :: c_char, c_int, color_type - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - integer(kind=c_int), intent(in), value :: font_size - type(color_type), intent(in), value :: color - end subroutine draw_text - - ! void DrawTextCodepoint(Font font, int codepoint, Vector2 position, float fontSize, Color tint) - subroutine draw_text_codepoint(font, codepoint, position, font_size, tint) bind(c, name='DrawTextCodepoint') - import :: c_float, c_int, color_type, font_type, vector2_type - implicit none - type(font_type), intent(in), value :: font - integer(kind=c_int), intent(in), value :: codepoint - type(vector2_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: font_size - type(color_type), intent(in), value :: tint - end subroutine draw_text_codepoint - - ! void DrawTextCodepoints(Font font, const int *codepoints, int codepointCount, Vector2 position, float fontSize, float spacing, Color tint) - subroutine draw_text_codepoints(font, codepoints, codepointCount, position, font_size, spacing, tint) & - bind(c, name='DrawTextCodepoints') - import :: c_float, c_int, color_type, font_type, vector2_type - implicit none - type(font_type), intent(in), value :: font - integer(kind=c_int), intent(inout) :: codepoints(*) - integer(kind=c_int), intent(in), value :: codepointCount - type(vector2_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: font_size - real(kind=c_float), intent(in), value :: spacing - type(color_type), intent(in), value :: tint - end subroutine draw_text_codepoints - - ! void DrawTextEx(Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) - subroutine draw_text_ex(font, text, position, font_size, spacing, tint) bind(c, name='DrawTextEx') - import :: c_char, c_float, color_type, font_type, vector2_type - implicit none - type(font_type), intent(in), value :: font - character(kind=c_char), intent(in) :: text - type(vector2_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: font_size - real(kind=c_float), intent(in), value :: spacing - type(color_type), intent(in), value :: tint - end subroutine draw_text_ex - - ! void DrawTextPro(Font font, const char *text, Vector2 position, Vector2 origin, float rotation, float fontSize, float spacing, Color tint) - subroutine draw_text_pro(font, text, position, origin, rotation, font_size, spacing, tint) & - bind(c, name='DrawTextPro') - import :: c_char, c_float, color_type, font_type, vector2_type - implicit none - type(font_type), intent(in), value :: font - character(kind=c_char), intent(in) :: text - type(vector2_type), intent(in), value :: position - type(vector2_type), intent(in), value :: origin - real(kind=c_float), intent(in), value :: rotation - real(kind=c_float), intent(in), value :: font_size - real(kind=c_float), intent(in), value :: spacing - type(color_type), intent(in), value :: tint - end subroutine draw_text_pro - - ! void DrawTexture(Texture2D texture, int posX, int posY, Color tint) - subroutine draw_texture(texture, pos_x, pos_y, tint) bind(c, name='DrawTexture') - import :: c_int, color_type, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - type(color_type), intent(in), value :: tint - end subroutine draw_texture - - ! void DrawTextureEx(Texture2D texture, Vector2 position, float rotation, float scale, Color tint) - subroutine draw_texture_ex(texture, position, rotation, scale, tint) bind(c, name='DrawTextureEx') - import :: c_float, color_type, texture2d_type, vector2_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(vector2_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: rotation - real(kind=c_float), intent(in), value :: scale - type(color_type), intent(in), value :: tint - end subroutine draw_texture_ex - - ! void DrawTextureNPatch(Texture2D texture, NPatchInfo nPatchInfo, Rectangle dest, Vector2 origin, float rotation, Color tint) - subroutine draw_texture_npatch(texture, npatch_info, dest, origin, rotation, tint) & - bind(c, name='DrawTextureNPatch') - import :: c_float, color_type, npatch_info_type, rectangle_type, texture2d_type, vector2_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(npatch_info_type), intent(in), value :: npatch_info - type(rectangle_type), intent(in), value :: dest - type(vector2_type), intent(in), value :: origin - real(kind=c_float), intent(in), value :: rotation - type(color_type), intent(in), value :: tint - end subroutine draw_texture_npatch - - ! void DrawTexturePro(Texture2D texture, Rectangle source, Rectangle dest, Vector2 origin, float rotation, Color tint) - subroutine draw_texture_pro(texture, source, dest, origin, rotation, tint) bind(c, name='DrawTexturePro') - import :: c_float, color_type, rectangle_type, texture2d_type, vector2_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(rectangle_type), intent(in), value :: source - type(rectangle_type), intent(in), value :: dest - type(vector2_type), intent(in), value :: origin - real(kind=c_float), intent(in), value :: rotation - type(color_type), intent(in), value :: tint - end subroutine draw_texture_pro - - ! void DrawTextureRec(Texture2D texture, Rectangle source, Vector2 position, Color tint) - subroutine draw_texture_rec(texture, source, position, tint) bind(c, name='DrawTextureRec') - import :: color_type, rectangle_type, texture2d_type, vector2_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(rectangle_type), intent(in), value :: source - type(vector2_type), intent(in), value :: position - type(color_type), intent(in), value :: tint - end subroutine draw_texture_rec - - ! void DrawTextureV(Texture2D texture, Vector2 position, Color tint) - subroutine draw_texture_v(texture, position, tint) bind(c, name='DrawTextureV') - import :: color_type, texture2d_type, vector2_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(vector2_type), intent(in), value :: position - type(color_type), intent(in), value :: tint - end subroutine draw_texture_v - - ! void DrawTriangle(Vector2 v1, Vector2 v2, Vector2 v3, Color color) - subroutine draw_triangle(v1, v2, v3, color) bind(c, name='DrawTriangle') - import :: color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: v1 - type(vector2_type), intent(in), value :: v2 - type(vector2_type), intent(in), value :: v3 - type(color_type), intent(in), value :: color - end subroutine draw_triangle - - ! void DrawTriangle3D(Vector3 v1, Vector3 v2, Vector3 v3, Color color) - subroutine draw_triangle3d(v1, v2, v3, color) bind(c, name='DrawTriangle3D') - import :: color_type, vector3_type - implicit none - type(vector3_type), intent(in), value :: v1 - type(vector3_type), intent(in), value :: v2 - type(vector3_type), intent(in), value :: v3 - type(color_type), intent(in), value :: color - end subroutine draw_triangle3d - - ! void DrawTriangleFan(Vector2 *points, int pointCount, Color color) - subroutine draw_triangle_fan(points, point_count, color) bind(c, name='DrawTriangleFan') - import :: c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - type(color_type), intent(in), value :: color - end subroutine draw_triangle_fan - - ! void DrawTriangleLines(Vector2 v1, Vector2 v2, Vector2 v3, Color color) - subroutine draw_triangle_lines(v1, v2, v3, color) bind(c, name='DrawTriangleLines') - import :: color_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: v1 - type(vector2_type), intent(in), value :: v2 - type(vector2_type), intent(in), value :: v3 - type(color_type), intent(in), value :: color - end subroutine draw_triangle_lines - - ! void DrawTriangleStrip(Vector2 *points, int pointCount, Color color) - subroutine draw_triangle_strip(points, point_count, color) bind(c, name='DrawTriangleStrip') - import :: c_int, color_type, vector2_type - implicit none - type(vector2_type), intent(in) :: points(*) - integer(kind=c_int), intent(in), value :: point_count - type(color_type), intent(in), value :: color - end subroutine draw_triangle_strip - - ! void EnableCursor(void) - subroutine enable_cursor() bind(c, name='EnableCursor') - end subroutine enable_cursor - - ! void EnableEventWaiting(void) - subroutine enable_event_waiting() bind(c, name='EnableEventWaiting') - end subroutine enable_event_waiting - - ! char *EncodeDataBase64(const unsigned char *data, int dataSize, int *outputSize) - function encode_data_base64(data, data_size, output_size) bind(c, name='EncodeDataBase64') - import :: c_int, c_unsigned_char, c_ptr - implicit none - integer(kind=c_unsigned_char), intent(in) :: data - integer(kind=c_int), intent(in), value :: data_size - integer(kind=c_int), intent(out) :: output_size - type(c_ptr) :: encode_data_base64 - end function encode_data_base64 - - ! void EndBlendMode(void) - subroutine end_blend_mode() bind(c, name='EndBlendMode') - end subroutine end_blend_mode - - ! void EndDrawing(void) - subroutine end_drawing() bind(c, name='EndDrawing') - end subroutine end_drawing - - ! void EndMode2D(void) - subroutine end_mode2d() bind(c, name='EndMode2D') - end subroutine end_mode2d - - ! void EndMode3D(void) - subroutine end_mode3d() bind(c, name='EndMode3D') - end subroutine end_mode3d - - ! void EndScissorMode(void) - subroutine end_scissor_mode() bind(c, name='EndScissorMode') - end subroutine end_scissor_mode - - ! void EndShaderMode(void) - subroutine end_shader_mode() bind(c, name='EndShaderMode') - end subroutine end_shader_mode - - ! void EndTextureMode(void) - subroutine end_texture_mode() bind(c, name='EndTextureMode') - end subroutine end_texture_mode - - ! void EndVrStereoMode(void) - subroutine end_vr_stereo_mode() bind(c, name='EndVrStereoMode') - end subroutine end_vr_stereo_mode - - ! bool ExportDataAsCode(const unsigned char *data, int dataSize, const char *fileName) - function export_data_as_code(data, data_size, file_name) bind(c, name='ExportDataAsCode') - import :: c_bool, c_char, c_int, c_unsigned_char - implicit none - integer(kind=c_unsigned_char), intent(in) :: data - integer(kind=c_int), intent(in), value :: data_size - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: export_data_as_code - end function export_data_as_code - - ! bool ExportFontAsCode(Font font, const char *fileName) - function export_font_as_code(font, file_name) bind(c, name='ExportFontAsCode') - import :: c_bool, c_char, font_type - implicit none - type(font_type), intent(in), value :: font - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: export_font_as_code - end function export_font_as_code - - ! bool ExportImage(Image image, const char *fileName) - function export_image(image, file_name) bind(c, name='ExportImage') - import :: c_bool, c_char, image_type - implicit none - type(image_type), intent(in), value :: image - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: export_image - end function export_image - - ! bool ExportImageAsCode(Image image, const char *fileName) - function export_image_as_code(image, file_name) bind(c, name='ExportImageAsCode') - import :: c_bool, c_char, image_type - implicit none - type(image_type), intent(in), value :: image - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: export_image_as_code - end function export_image_as_code - - ! unsigned char *ExportImageToMemory(Image image, const char *fileType, int *fileSize) - function export_image_to_memory(image, file_type, file_size) bind(c, name='ExportImageToMemory') - import :: c_char, c_int, c_ptr, image_type - implicit none - type(image_type), intent(in), value :: image - character(kind=c_char), intent(in) :: file_type - integer(kind=c_int), intent(out) :: file_size - type(c_ptr) :: export_image_to_memory - end function export_image_to_memory - - ! bool ExportMesh(Mesh mesh, const char *fileName) - function export_mesh(mesh, file_name) bind(c, name='ExportMesh') - import :: c_bool, c_char, mesh_type - implicit none - type(mesh_type), intent(in), value :: mesh - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: export_mesh - end function export_mesh - - ! bool ExportWave(Wave wave, const char *fileName) - function export_wave(wave, file_name) bind(c, name='ExportWave') - import :: c_bool, c_char, wave_type - implicit none - type(wave_type), intent(in), value :: wave - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: export_wave - end function export_wave - - ! bool ExportWaveAsCode(Wave wave, const char *fileName) - function export_wave_as_code(wave, file_name) bind(c, name='ExportWaveAsCode') - import :: c_bool, c_char, wave_type - implicit none - type(wave_type), intent(in), value :: wave - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: export_wave_as_code - end function export_wave_as_code - - ! Color Fade(Color color, float alpha) - function fade(color, alpha) bind(c, name='Fade') - import :: c_float, color_type - implicit none - type(color_type), intent(in), value :: color - real(kind=c_float), intent(in), value :: alpha - type(color_type) :: fade - end function fade - - ! bool FileExists(const char *fileName) - function file_exists(file_name) bind(c, name='FileExists') - import :: c_bool, c_char - implicit none - character(kind=c_char), intent(in) :: file_name - logical(kind=c_bool) :: file_exists - end function file_exists - - ! Image GenImageCellular(int width, int height, int tileSize) - function gen_image_cellular(width, height, tile_size) bind(c, name='GenImageCellular') - import :: c_int, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - integer(kind=c_int), intent(in), value :: tile_size - type(image_type) :: gen_image_cellular - end function gen_image_cellular - - ! Image GenImageChecked(int width, int height, int checksX, int checksY, Color col1, Color col2) - function gen_image_checked(width, height, checks_x, checks_y, col1, col2) bind(c, name='GenImageChecked') - import :: c_int, color_type, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - integer(kind=c_int), intent(in), value :: checks_x - integer(kind=c_int), intent(in), value :: checks_y - type(color_type), intent(in), value :: col1 - type(color_type), intent(in), value :: col2 - type(image_type) :: gen_image_checked - end function gen_image_checked - - ! Image GenImageColor(int width, int height, Color color) - function gen_image_color(width, height, color) bind(c, name='GenImageColor') - import :: c_int, color_type, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(color_type), intent(in), value :: color - type(image_type) :: gen_image_color - end function gen_image_color - - ! Image GenImageFontAtlas(const GlyphInfo *glyphs, Rectangle **glyphRecs, int glyphCount, int fontSize, int padding, int packMethod) - function gen_image_font_atlas(glyphs, glyph_recs, glyph_count, font_size, padding, pack_method) & - bind(c, name='GenImageFontAtlas') - import :: c_int, glyph_info_type, image_type, rectangle_type - implicit none - type(glyph_info_type), intent(inout) :: glyphs - type(rectangle_type), intent(inout) :: glyph_recs(*) - integer(kind=c_int), intent(in), value :: glyph_count - integer(kind=c_int), intent(in), value :: font_size - integer(kind=c_int), intent(in), value :: padding - integer(kind=c_int), intent(in), value :: pack_method - type(image_type) :: gen_image_font_atlas - end function gen_image_font_atlas - - ! Image GenImageGradientLinear(int width, int height, int direction, Color start, Color end) - function gen_image_gradient_linear(width, height, direction, start, end) bind(c, name='GenImageGradientLinear') - import :: c_int, color_type, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - integer(kind=c_int), intent(in), value :: direction - type(color_type), intent(in), value :: start - type(color_type), intent(in), value :: end - type(image_type) :: gen_image_gradient_linear - end function gen_image_gradient_linear - - ! Image GenImageGradientRadial(int width, int height, float density, Color inner, Color outer) - function gen_image_gradient_radial(width, height, density, inner, outer) bind(c, name='GenImageGradientRadial') - import :: c_float, c_int, color_type, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - real(kind=c_float), intent(in), value :: density - type(color_type), intent(in), value :: inner - type(color_type), intent(in), value :: outer - type(image_type) :: gen_image_gradient_radial - end function gen_image_gradient_radial - - ! Image GenImageGradientSquare(int width, int height, float density, Color inner, Color outer) - function gen_image_gradient_square(width, height, density, inner, outer) bind(c, name='GenImageGradientSquare') - import :: c_float, c_int, color_type, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - real(kind=c_float), intent(in), value :: density - type(color_type), intent(in), value :: inner - type(color_type), intent(in), value :: outer - type(image_type) :: gen_image_gradient_square - end function gen_image_gradient_square - - ! Image GenImageWhiteNoise(int width, int height, float factor) - function gen_image_white_noise(width, height, factor) bind(c, name='GenImageWhiteNoise') - import :: c_float, c_int, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - real(kind=c_float), intent(in), value :: factor - type(image_type) :: gen_image_white_noise - end function gen_image_white_noise - - ! Image GenImagePerlinNoise(int width, int height, int offsetX, int offsetY, float scale) - function gen_image_perlin_noise(width, height, offset_x, offset_y, scale) bind(c, name='GenImagePerlinNoise') - import :: c_float, c_int, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - integer(kind=c_int), intent(in), value :: offset_x - integer(kind=c_int), intent(in), value :: offset_y - real(kind=c_float), intent(in), value :: scale - type(image_type) :: gen_image_perlin_noise - end function gen_image_perlin_noise - - ! Image GenImageText(int width, int height, const char *text) - function gen_image_text(width, height, text) bind(c, name='GenImageText') - import :: c_char, c_int, image_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - character(kind=c_char), intent(in) :: text - type(image_type) :: gen_image_text - end function gen_image_text - - ! Mesh GenMeshCone(float radius, float height, int slices) - function gen_mesh_cone(radius, height, slices) bind(c, name='GenMeshCone') - import :: c_float, c_int, mesh_type - implicit none - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: height - integer(kind=c_int), intent(in), value :: slices - type(mesh_type) :: gen_mesh_cone - end function gen_mesh_cone - - ! Mesh GenMeshCube(float width, float height, float length) - function gen_mesh_cube(width, height, length) bind(c, name='GenMeshCube') - import :: c_float, mesh_type - implicit none - real(kind=c_float), intent(in), value :: width - real(kind=c_float), intent(in), value :: height - real(kind=c_float), intent(in), value :: length - type(mesh_type) :: gen_mesh_cube - end function gen_mesh_cube - - ! Mesh GenMeshCubicmap(Image cubicmap, Vector3 cubeSize) - function gen_mesh_cubicmap(cubicmap, cube_size) bind(c, name='GenMeshCubicmap') - import :: image_type, mesh_type, vector3_type - implicit none - type(image_type), intent(in), value :: cubicmap - type(vector3_type), intent(in), value :: cube_size - type(mesh_type) :: gen_mesh_cubicmap - end function gen_mesh_cubicmap - - ! Mesh GenMeshCylinder(float radius, float height, int slices) - function gen_mesh_cylinder(radius, height, slices) bind(c, name='GenMeshCylinder') - import :: c_float, c_int, mesh_type - implicit none - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: height - integer(kind=c_int), intent(in), value :: slices - type(mesh_type) :: gen_mesh_cylinder - end function gen_mesh_cylinder - - ! Mesh GenMeshHeightmap(Image heightmap, Vector3 size) - function gen_mesh_heightmap(heightmap, size) bind(c, name='GenMeshHeightmap') - import :: image_type, mesh_type, vector3_type - implicit none - type(image_type), intent(in), value :: heightmap - type(vector3_type), intent(in), value :: size - type(mesh_type) :: gen_mesh_heightmap - end function gen_mesh_heightmap - - ! Mesh GenMeshHemiSphere(float radius, int rings, int slices) - function gen_mesh_hemi_sphere(radius, rings, slices) bind(c, name='GenMeshHemiSphere') - import :: c_float, c_int, mesh_type - implicit none - real(kind=c_float), intent(in), value :: radius - integer(kind=c_int), intent(in), value :: rings - integer(kind=c_int), intent(in), value :: slices - type(mesh_type) :: gen_mesh_hemi_sphere - end function gen_mesh_hemi_sphere - - ! Mesh GenMeshKnot(float radius, float size, int radSeg, int sides) - function gen_mesh_knot(radius, size, rad_seg, sides) bind(c, name='GenMeshKnot') - import :: c_float, c_int, mesh_type - implicit none - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: size - integer(kind=c_int), intent(in), value :: rad_seg - integer(kind=c_int), intent(in), value :: sides - type(mesh_type) :: gen_mesh_knot - end function gen_mesh_knot - - ! Mesh GenMeshPlane(float width, float length, int resX, int resZ) - function gen_mesh_plane(width, length, res_x, res_z) bind(c, name='GenMeshPlane') - import :: c_float, c_int, mesh_type - implicit none - real(kind=c_float), intent(in), value :: width - real(kind=c_float), intent(in), value :: length - integer(kind=c_int), intent(in), value :: res_x - integer(kind=c_int), intent(in), value :: res_z - type(mesh_type) :: gen_mesh_plane - end function gen_mesh_plane - - ! Mesh GenMeshPoly(int sides, float radius) - function gen_mesh_poly(sides, radius) bind(c, name='GenMeshPoly') - import :: c_float, c_int, mesh_type - implicit none - integer(kind=c_int), intent(in), value :: sides - real(kind=c_float), intent(in), value :: radius - type(mesh_type) :: gen_mesh_poly - end function gen_mesh_poly - - ! Mesh GenMeshSphere(float radius, int rings, int slices) - function gen_mesh_sphere(radius, rings, slices) bind(c, name='GenMeshSphere') - import :: c_float, c_int, mesh_type - implicit none - real(kind=c_float), intent(in), value :: radius - integer(kind=c_int), intent(in), value :: rings - integer(kind=c_int), intent(in), value :: slices - type(mesh_type) :: gen_mesh_sphere - end function gen_mesh_sphere - - ! void GenMeshTangents(Mesh *mesh) - subroutine gen_mesh_tangents(mesh) bind(c, name='GenMeshTangents') - import :: mesh_type - implicit none - type(mesh_type), intent(in) :: mesh - end subroutine gen_mesh_tangents - - ! Mesh GenMeshTorus(float radius, float size, int radSeg, int sides) - function gen_mesh_torus(radius, size, rad_seg, sides) bind(c, name='GenMeshTorus') - import :: c_float, c_int, mesh_type - implicit none - real(kind=c_float), intent(in), value :: radius - real(kind=c_float), intent(in), value :: size - integer(kind=c_int), intent(in), value :: rad_seg - integer(kind=c_int), intent(in), value :: sides - type(mesh_type) :: gen_mesh_torus - end function gen_mesh_torus - - ! void GenTextureMipmaps(Texture2D *texture) - subroutine gen_texture_mipmaps(texture) bind(c, name='GenTextureMipmaps') - import :: texture2d_type - implicit none - type(texture2d_type), intent(inout) :: texture - end subroutine gen_texture_mipmaps - - ! const char *GetApplicationDirectory(void) - function get_application_directory() bind(c, name='GetApplicationDirectory') - import :: c_ptr - implicit none - type(c_ptr) :: get_application_directory - end function get_application_directory - - ! Matrix GetCameraMatrix(Camera camera) - function get_camera_matrix(camera) bind(c, name='GetCameraMatrix') - import :: camera3d_type, matrix_type - implicit none - type(camera3d_type), intent(in), value :: camera - type(matrix_type) :: get_camera_matrix - end function get_camera_matrix - - ! Matrix GetCameraMatrix2D(Camera2D camera) - function get_camera_matrix2d(camera) bind(c, name='GetCameraMatrix2D') - import :: camera2d_type, matrix_type - implicit none - type(camera2d_type), intent(in), value :: camera - type(matrix_type) :: get_camera_matrix2d - end function get_camera_matrix2d - - ! int GetCharPressed(void) - function get_char_pressed() bind(c, name='GetCharPressed') - import :: c_int - implicit none - integer(kind=c_int) :: get_char_pressed - end function get_char_pressed - - ! const char *GetClipboardText(void) - function get_clipboard_text() bind(c, name='GetClipboardText') - import :: c_ptr - implicit none - type(c_ptr) :: get_clipboard_text - end function get_clipboard_text - - ! int GetCodepoint(const char *text, int *codepointSize) - function get_codepoint(text, codepoint_size) bind(c, name='GetCodepoint') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(out) :: codepoint_size - integer(kind=c_int) :: get_codepoint - end function get_codepoint - - ! int GetCodepointCount(const char *text) - function get_codepoint_count(text) bind(c, name='GetCodepointCount') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int) :: get_codepoint_count - end function get_codepoint_count - - ! int GetCodepointNext(const char *text, int *codepointSize) - function get_codepoint_next(text, codepoint_size) bind(c, name='GetCodepointNext') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(out) :: codepoint_size - integer(kind=c_int) :: get_codepoint_next - end function get_codepoint_next - - ! int GetCodepointPrevious(const char *text, int *codepointSize) - function get_codepoint_previous(text, codepoint_size) bind(c, name='GetCodepointPrevious') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(out) :: codepoint_size - integer(kind=c_int) :: get_codepoint_previous - end function get_codepoint_previous - - ! Rectangle GetCollisionRec(Rectangle rec1, Rectangle rec2) - function get_collision_rec(rec1, rec2) bind(c, name='GetCollisionRec') - import :: rectangle_type - implicit none - type(rectangle_type), intent(in), value :: rec1 - type(rectangle_type), intent(in), value :: rec2 - type(rectangle_type) :: get_collision_rec - end function get_collision_rec - - ! Color GetColor(unsigned int hexValue) - function get_color(hex_value) bind(c, name='GetColor') - import :: c_unsigned_int, color_type - implicit none - integer(kind=c_unsigned_int), intent(in), value :: hex_value - type(color_type) :: get_color - end function get_color - - ! int GetCurrentMonitor(void) - function get_current_monitor() bind(c, name='GetCurrentMonitor') - import :: c_int - implicit none - integer(kind=c_int) :: get_current_monitor - end function get_current_monitor - - ! const char *GetDirectoryPath(const char *filePath) - function get_directory_path(file_path) bind(c, name='GetDirectoryPath') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_path - type(c_ptr) :: get_directory_path - end function get_directory_path - - ! int GetFPS(void) - function get_fps() bind(c, name='GetFPS') - import :: c_int - implicit none - integer(kind=c_int) :: get_fps - end function get_fps - - ! const char *GetFileExtension(const char *fileName) - function get_file_extension(file_name) bind(c, name='GetFileExtension') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_name - type(c_ptr) :: get_file_extension - end function get_file_extension - - ! int GetFileLength(const char *fileName) - function get_file_length(file_name) bind(c, name='GetFileLength') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_int) :: get_file_length - end function get_file_length - - ! long GetFileModTime(const char *fileName) - function get_file_mod_time(file_name) bind(c, name='GetFileModTime') - import :: c_char, c_long - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_long) :: get_file_mod_time - end function get_file_mod_time - - ! const char *GetFileName(const char *filePath) - function get_file_name(file_path) bind(c, name='GetFileName') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_path - type(c_ptr) :: get_file_name - end function get_file_name - - ! const char *GetFileNameWithoutExt(const char *filePath) - function get_file_name_without_ext(file_path) bind(c, name='GetFileNameWithoutExt') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_path - type(c_ptr) :: get_file_name_without_ext - end function get_file_name_without_ext - - ! Font GetFontDefault(void) - function get_font_default() bind(c, name='GetFontDefault') - import :: font_type - implicit none - type(font_type) :: get_font_default - end function get_font_default - - ! float GetFrameTime(void) - function get_frame_time() bind(c, name='GetFrameTime') - import :: c_float - implicit none - real(kind=c_float) :: get_frame_time - end function get_frame_time - - ! int GetGamepadAxisCount(int gamepad) - function get_gamepad_axis_count(gamepad) bind(c, name='GetGamepadAxisCount') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: gamepad - integer(kind=c_int) :: get_gamepad_axis_count - end function get_gamepad_axis_count - - ! float GetGamepadAxisMovement(int gamepad, int axis) - function get_gamepad_axis_movement(gamepad, axis) bind(c, name='GetGamepadAxisMovement') - import :: c_float, c_int - implicit none - integer(kind=c_int), intent(in), value :: gamepad - integer(kind=c_int), intent(in), value :: axis - real(kind=c_float) :: get_gamepad_axis_movement - end function get_gamepad_axis_movement - - ! int GetGamepadButtonPressed(void) - function get_gamepad_button_pressed() bind(c, name='GetGamepadButtonPressed') - import :: c_int - implicit none - integer(kind=c_int) :: get_gamepad_button_pressed - end function get_gamepad_button_pressed - - ! const char *GetGamepadName(int gamepad) - function get_gamepad_name(gamepad) bind(c, name='GetGamepadName') - import :: c_char, c_int, c_ptr - implicit none - integer(kind=c_int), intent(in), value :: gamepad - type(c_ptr) :: get_gamepad_name - end function get_gamepad_name - - ! int GetGestureDetected(void) - function get_gesture_detected() bind(c, name='GetGestureDetected') - import :: c_int - implicit none - integer(kind=c_int) :: get_gesture_detected - end function get_gesture_detected - - ! float GetGestureDragAngle(void) - function get_gesture_drag_angle() bind(c, name='GetGestureDragAngle') - import :: c_float - implicit none - real(kind=c_float) :: get_gesture_drag_angle - end function get_gesture_drag_angle - - ! float GetGestureHoldDuration(void) - function get_gesture_hold_duration() bind(c, name='GetGestureHoldDuration') - import :: c_float - implicit none - real(kind=c_float) :: get_gesture_hold_duration - end function get_gesture_hold_duration - - ! float GetGesturePinchAngle(void) - function get_gesture_pinch_angle() bind(c, name='GetGesturePinchAngle') - import :: c_float - implicit none - real(kind=c_float) :: get_gesture_pinch_angle - end function get_gesture_pinch_angle - - ! Rectangle GetGlyphAtlasRec(Font font, int codepoint) - function get_glyph_atlas_rec(font, codepoint) bind(c, name='GetGlyphAtlasRec') - import :: c_int, font_type, rectangle_type - implicit none - type(font_type), intent(in), value :: font - integer(kind=c_int), intent(in), value :: codepoint - type(rectangle_type) :: get_glyph_atlas_rec - end function get_glyph_atlas_rec - - ! int GetGlyphIndex(Font font, int codepoint) - function get_glyph_index(font, codepoint) bind(c, name='GetGlyphIndex') - import :: c_int, font_type - implicit none - type(font_type), intent(in), value :: font - integer(kind=c_int), intent(in), value :: codepoint - integer(kind=c_int) :: get_glyph_index - end function get_glyph_index - - ! GlyphInfo GetGlyphInfo(Font font, int codepoint) - function get_glyph_info(font, codepoint) bind(c, name='GetGlyphInfo') - import :: c_int, font_type, glyph_info_type - implicit none - type(font_type), intent(in), value :: font - integer(kind=c_int), intent(in), value :: codepoint - type(glyph_info_type) :: get_glyph_info - end function get_glyph_info - - ! float GetMasterVolume(void) - function get_master_volume() bind(c, name='GetMasterVolume') - import :: c_float - implicit none - real(kind=c_float) :: get_master_volume - end function get_master_volume - - ! Rectangle GetImageAlphaBorder(Image image, float threshold) - function get_image_alpha_border(image, threshold) bind(c, name='GetImageAlphaBorder') - import :: c_float, image_type, rectangle_type - implicit none - type(image_type), intent(in), value :: image - real(kind=c_float), intent(in), value :: threshold - type(rectangle_type) :: get_image_alpha_border - end function get_image_alpha_border - - ! Vector2 GetSplinePointBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) - function get_spline_point_basis(p1, p2, p3, p4, t) bind(c, name='GetSplinePointBasis') - import :: c_float, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: p2 - type(vector2_type), intent(in), value :: p3 - type(vector2_type), intent(in), value :: p4 - real(kind=c_float), intent(in), value :: t - type(vector2_type) :: get_spline_point_basis - end function get_spline_point_basis - - ! Vector2 GetSplinePointBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float t) - function get_spline_point_bezier_cubic(p1, c2, c3, p4, t) bind(c, name='GetSplinePointBezierCubic') - import :: c_float, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: c2 - type(vector2_type), intent(in), value :: c3 - type(vector2_type), intent(in), value :: p4 - real(kind=c_float), intent(in), value :: t - type(vector2_type) :: get_spline_point_bezier_cubic - end function get_spline_point_bezier_cubic - - ! Vector2 GetSplinePointBezierQuad(Vector2 p1, Vector2 c2, Vector2 p3, float t) - function get_spline_point_bezier_quad(p1, c2, p3, t) bind(c, name='GetSplinePointBezierQuad') - import :: c_float, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: c2 - type(vector2_type), intent(in), value :: p3 - real(kind=c_float), intent(in), value :: t - type(vector2_type) :: get_spline_point_bezier_quad - end function get_spline_point_bezier_quad - - ! Vector2 GetSplinePointCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) - function get_spline_point_catmull_rom(p1, p2, p3, p4, t) bind(c, name='GetSplinePointCatmullRom') - import :: c_float, vector2_type - implicit none - type(vector2_type), intent(in), value :: p1 - type(vector2_type), intent(in), value :: p2 - type(vector2_type), intent(in), value :: p3 - type(vector2_type), intent(in), value :: p4 - real(kind=c_float), intent(in), value :: t - type(vector2_type) :: get_spline_point_catmull_rom - end function get_spline_point_catmull_rom - - ! Vector2 GetSplinePointLinear(Vector2 startPos, Vector2 endPos, float t) - function get_spline_point_linear(start_pos, end_pos, t) bind(c, name='GetSplinePointLinear') - import :: c_float, vector2_type - implicit none - type(vector2_type), intent(in), value :: start_pos - type(vector2_type), intent(in), value :: end_pos - real(kind=c_float), intent(in), value :: t - type(vector2_type) :: get_spline_point_linear - end function get_spline_point_linear - - ! void ImageBlurGaussian(Image *image, int blurSize) - subroutine image_blur_gaussian(image, blur_size) bind(c, name='ImageBlurGaussian') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: blur_size - end subroutine image_blur_gaussian - - ! Color GetImageColor(Image image, int x, int y) - function get_image_color(image, x, y) bind(c, name='GetImageColor') - import :: c_int, color_type, image_type - implicit none - type(image_type), intent(in), value :: image - integer(kind=c_int), intent(in), value :: x - integer(kind=c_int), intent(in), value :: y - type(color_type) :: get_image_color - end function get_image_color - - ! int GetKeyPressed(void) - function get_key_pressed() bind(c, name='GetKeyPressed') - import :: c_int - implicit none - integer(kind=c_int) :: get_key_pressed - end function get_key_pressed - - ! BoundingBox GetMeshBoundingBox(Mesh mesh) - function get_mesh_bounding_box(mesh) bind(c, name='GetMeshBoundingBox') - import :: bounding_box_type, mesh_type - implicit none - type(mesh_type), intent(in), value :: mesh - type(bounding_box_type) :: get_mesh_bounding_box - end function get_mesh_bounding_box - - ! BoundingBox GetModelBoundingBox(Model model) - function get_model_bounding_box(model) bind(c, name='GetModelBoundingBox') - import :: bounding_box_type, model_type - implicit none - type(model_type), intent(in), value :: model - type(bounding_box_type) :: get_model_bounding_box - end function get_model_bounding_box - - ! int GetMonitorCount(void) - function get_monitor_count() bind(c, name='GetMonitorCount') - import :: c_int - implicit none - integer(kind=c_int) :: get_monitor_count - end function get_monitor_count - - ! int GetMonitorHeight(int monitor) - function get_monitor_height(monitor) bind(c, name='GetMonitorHeight') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: monitor - integer(kind=c_int) :: get_monitor_height - end function get_monitor_height - - ! const char *GetMonitorName(int monitor) - function get_monitor_name(monitor) bind(c, name='GetMonitorName') - import :: c_int, c_ptr - implicit none - integer(kind=c_int), intent(in), value :: monitor - type(c_ptr) :: get_monitor_name - end function get_monitor_name - - ! int GetMonitorPhysicalHeight(int monitor) - function get_monitor_physical_height(monitor) bind(c, name='GetMonitorPhysicalHeight') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: monitor - integer(kind=c_int) :: get_monitor_physical_height - end function get_monitor_physical_height - - ! int GetMonitorPhysicalWidth(int monitor) - function get_monitor_physical_width(monitor) bind(c, name='GetMonitorPhysicalWidth') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: monitor - integer(kind=c_int) :: get_monitor_physical_width - end function get_monitor_physical_width - - ! int GetMonitorRefreshRate(int monitor) - function get_monitor_refresh_rate(monitor) bind(c, name='GetMonitorRefreshRate') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: monitor - integer(kind=c_int) :: get_monitor_refresh_rate - end function get_monitor_refresh_rate - - ! int GetMonitorWidth(int monitor) - function get_monitor_width(monitor) bind(c, name='GetMonitorWidth') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: monitor - integer(kind=c_int) :: get_monitor_width - end function get_monitor_width - - ! Vector2 GetMouseDelta(void) - function get_mouse_delta() bind(c, name='GetMouseDelta') - import :: vector2_type - implicit none - type(vector2_type) :: get_mouse_delta - end function get_mouse_delta - - ! Vector2 GetMousePosition(void) - function get_mouse_position() bind(c, name='GetMousePosition') - import :: vector2_type - implicit none - type(vector2_type) :: get_mouse_position - end function get_mouse_position - - ! Ray GetMouseRay(Vector2 mousePosition, Camera camera) - function get_mouse_ray(mouse_position, camera) bind(c, name='GetMouseRay') - import :: camera3d_type, ray_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: mouse_position - type(camera3d_type),intent(in), value :: camera - type(ray_type) :: get_mouse_ray - end function get_mouse_ray - - ! float GetMouseWheelMove(void) - function get_mouse_wheel_move() bind(c, name='GetMouseWheelMove') - import :: c_float - implicit none - real(kind=c_float) :: get_mouse_wheel_move - end function get_mouse_wheel_move - - ! int GetMouseX(void) - function get_mouse_x() bind(c, name='GetMouseX') - import :: c_int - implicit none - integer(kind=c_int) :: get_mouse_x - end function get_mouse_x - - ! int GetMouseY(void) - function get_mouse_y() bind(c, name='GetMouseY') - import :: c_int - implicit none - integer(kind=c_int) :: get_mouse_y - end function get_mouse_y - - ! float GetMusicTimeLength(Music music) - function get_music_time_length(music) bind(c, name='GetMusicTimeLength') - import :: c_float, music_type - implicit none - type(music_type), intent(in), value :: music - real(kind=c_float) :: get_music_time_length - end function get_music_time_length - - ! float GetMusicTimePlayed(Music music) - function get_music_time_played(music) bind(c, name='GetMusicTimePlayed') - import :: c_float, music_type - implicit none - type(music_type), intent(in), value :: music - real(kind=c_float) :: get_music_time_played - end function get_music_time_played - - ! Color GetPixelColor(void *srcPtr, int format) - function get_pixel_color(src_ptr, format) bind(c, name='GetPixelColor') - import :: c_int, c_ptr, color_type - implicit none - type(c_ptr), intent(in), value :: src_ptr - integer(kind=c_int), intent(in), value :: format - type(color_type) :: get_pixel_color - end function get_pixel_color - - ! int GetPixelDataSize(int width, int height, int format) - function get_pixel_data_size(width, height, format) bind(c, name='GetPixelDataSize') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - integer(kind=c_int), intent(in), value :: format - integer(kind=c_int) :: get_pixel_data_size - end function get_pixel_data_size - - ! const char *GetPrevDirectoryPath(const char *dirPath) - function get_prev_directory_path(dir_path) bind(c, name='GetPrevDirectoryPath') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: dir_path - type(c_ptr) :: get_prev_directory_path - end function get_prev_directory_path - - ! int GetRandomValue(int min, int max) - function get_random_value(min, max) bind(c, name='GetRandomValue') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: min - integer(kind=c_int), intent(in), value :: max - integer(kind=c_int) :: get_random_value - end function get_random_value - - ! RayCollision GetRayCollisionBox(Ray ray, BoundingBox box) - function get_ray_collision_box(ray, box) bind(c, name='GetRayCollisionBox') - import :: bounding_box_type, ray_collision_type, ray_type - implicit none - type(ray_type), intent(in), value :: ray - type(bounding_box_type), intent(in), value :: box - type(ray_collision_type) :: get_ray_collision_box - end function get_ray_collision_box - - ! RayCollision GetRayCollisionMesh(Ray ray, Mesh mesh, Matrix transform) - function get_ray_collision_mesh(ray, mesh, transform) bind(c, name='GetRayCollisionMesh') - import :: matrix_type, mesh_type, ray_collision_type, ray_type - implicit none - type(ray_type), intent(in), value :: ray - type(mesh_type), intent(in), value :: mesh - type(matrix_type), intent(in), value :: transform - type(ray_collision_type) :: get_ray_collision_mesh - end function get_ray_collision_mesh - - ! RayCollision GetRayCollisionQuad(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3, Vector3 p4) - function get_ray_collision_quad(ray, p1, p2, p3, p4) bind(c, name='GetRayCollisionQuad') - import :: ray_collision_type, ray_type, vector3_type - implicit none - type(ray_type), intent(in), value :: ray - type(vector3_type), intent(in), value :: p1 - type(vector3_type), intent(in), value :: p2 - type(vector3_type), intent(in), value :: p3 - type(vector3_type), intent(in), value :: p4 - type(ray_collision_type) :: get_ray_collision_quad - end function get_ray_collision_quad - - ! RayCollision GetRayCollisionSphere(Ray ray, Vector3 center, float radius) - function get_ray_collision_sphere(ray, center, radius) bind(c, name='GetRayCollisionSphere') - import :: c_float, ray_collision_type, ray_type, vector3_type - implicit none - type(ray_type), intent(in), value :: ray - type(vector3_type), intent(in), value :: center - real(kind=c_float), intent(in), value :: radius - type(ray_collision_type) :: get_ray_collision_sphere - end function get_ray_collision_sphere - - ! RayCollision GetRayCollisionTriangle(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3) - function get_ray_collision_triangle(ray, p1, p2, p3) bind(c, name='GetRayCollisionTriangle') - import :: ray_collision_type, ray_type, vector3_type - implicit none - type(ray_type), intent(in), value :: ray - type(vector3_type), intent(in), value :: p1 - type(vector3_type), intent(in), value :: p2 - type(vector3_type), intent(in), value :: p3 - type(ray_collision_type) :: get_ray_collision_triangle - end function get_ray_collision_triangle - - ! int GetRenderHeight(void) - function get_render_height() bind(c, name='GetRenderHeight') - import :: c_int - implicit none - integer(kind=c_int) :: get_render_height - end function get_render_height - - ! int GetRenderWidth(void) - function get_render_width() bind(c, name='GetRenderWidth') - import :: c_int - implicit none - integer(kind=c_int) :: get_render_width - end function get_render_width - - ! int GetScreenHeight(void) - function get_screen_height() bind(c, name='GetScreenHeight') - import :: c_int - implicit none - integer(kind=c_int) :: get_screen_height - end function get_screen_height - - ! Vector2 GetScreenToWorld2D(Vector2 position, Camera2D camera) - function get_screen_to_world2d(position, camera) bind(c, name='GetScreenToWorld2D') - import :: camera2d_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: position - type(camera2d_type), intent(in), value :: camera - type(vector2_type) :: get_screen_to_world2d - end function get_screen_to_world2d - - ! int GetScreenWidth(void) - function get_screen_width() bind(c, name='GetScreenWidth') - import :: c_int - implicit none - integer(kind=c_int) :: get_screen_width - end function get_screen_width - - ! int GetShaderLocation(Shader shader, const char *uniformName) - function get_shader_location(shader, uniform_name) bind(c, name='GetShaderLocation') - import :: c_char, c_int, shader_type - implicit none - type(shader_type), intent(in), value :: shader - character(kind=c_char), intent(in) :: uniform_name - integer(kind=c_int) :: get_shader_location - end function get_shader_location - - ! int GetShaderLocationAttrib(Shader shader, const char *attribName) - function get_shader_location_attrib(shader, attrib_name) bind(c, name='GetShaderLocationAttrib') - import :: c_char, c_int, shader_type - implicit none - type(shader_type), intent(in), value :: shader - character(kind=c_char), intent(in) :: attrib_name - integer(kind=c_int) :: get_shader_location_attrib - end function get_shader_location_attrib - - ! double GetTime(void) - function get_time() bind(c, name='GetTime') - import :: c_double - implicit none - real(kind=c_double) :: get_time - end function get_time - - ! int GetTouchPointCount(void) - function get_touch_point_count() bind(c, name='GetTouchPointCount') - import :: c_int - implicit none - integer(kind=c_int) :: get_touch_point_count - end function get_touch_point_count - - ! int GetTouchPointId(int index) - function get_touch_point_id(index) bind(c, name='GetTouchPointId') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: index - integer(kind=c_int) :: get_touch_point_id - end function get_touch_point_id - - ! int GetTouchX(void) - function get_touch_x() bind(c, name='GetTouchX') - import :: c_int - implicit none - integer(kind=c_int) :: get_touch_x - end function get_touch_x - - ! int GetTouchY(void) - function get_touch_y() bind(c, name='GetTouchY') - import :: c_int - implicit none - integer(kind=c_int) :: get_touch_y - end function get_touch_y - - ! void *GetWindowHandle(void) - function get_window_handle() bind(c, name='GetWindowHandle') - import :: c_ptr - implicit none - type(c_ptr) :: get_window_handle - end function get_window_handle - - ! const char *GetWorkingDirectory(void) - function get_working_directory() bind(c, name='GetWorkingDirectory') - import :: c_ptr - implicit none - type(c_ptr) :: get_working_directory - end function get_working_directory - - ! Vector2 GetWorldToScreen2D(Vector2 position, Camera2D camera) - function get_world_to_screen2d(position, camera) bind(c, name='GetWorldToScreen2D') - import :: camera2d_type, vector2_type - implicit none - type(vector2_type), intent(in), value :: position - type(camera2d_type), intent(in), value :: camera - type(vector2_type) :: get_world_to_screen2d - end function get_world_to_screen2d - - ! void HideCursor(void) - subroutine hide_cursor() bind(c, name='HideCursor') - end subroutine hide_cursor - - ! void ImageAlphaClear(Image *image, Color color, float threshold) - subroutine image_alpha_clear(image, color, threshold) bind(c, name='ImageAlphaClear') - import :: c_float, color_type, image_type - implicit none - type(image_type), intent(inout) :: image - type(color_type), intent(in), value :: color - real(kind=c_float), intent(in), value :: threshold - end subroutine image_alpha_clear - - ! void ImageAlphaCrop(Image *image, float threshold) - subroutine image_alpha_crop(image, threshold) bind(c, name='ImageAlphaCrop') - import :: c_float, image_type - implicit none - type(image_type), intent(inout) :: image - real(kind=c_float), intent(in), value :: threshold - end subroutine image_alpha_crop - - ! void ImageAlphaMask(Image *image, Image alphaMask) - subroutine image_alpha_mask(image, alpha_mask) bind(c, name='ImageAlphaMask') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - type(image_type), intent(in), value :: alpha_mask - end subroutine image_alpha_mask - - ! void ImageAlphaPremultiply(Image *image) - subroutine image_alpha_premultiply(image) bind(c, name='ImageAlphaPremultiply') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_alpha_premultiply - - ! void ImageClearBackground(Image *dst, Color color) - subroutine image_clear_background(dst, color) bind(c, name='ImageClearBackground') - import :: color_type, image_type - implicit none - type(image_type), intent(inout) :: dst - type(color_type), intent(in), value :: color - end subroutine image_clear_background - - ! void ImageColorBrightness(Image *image, int brightness) - subroutine image_color_brightness(image, brightness) bind(c, name='ImageColorBrightness') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: brightness - end subroutine image_color_brightness - - ! void ImageColorContrast(Image *image, float contrast) - subroutine image_color_contrast(image, contrast) bind(c, name='ImageColorContrast') - import :: c_float, image_type - implicit none - type(image_type), intent(inout) :: image - real(kind=c_float), intent(in), value :: contrast - end subroutine image_color_contrast - - ! void ImageColorGrayscale(Image *image) - subroutine image_color_grayscale(image) bind(c, name='ImageColorGrayscale') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_color_grayscale - - ! void ImageColorInvert(Image *image) - subroutine image_color_invert(image) bind(c, name='ImageColorInvert') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_color_invert - - ! void ImageColorReplace(Image *image, Color color, Color replace) - subroutine image_color_replace(image, color, replace) bind(c, name='ImageColorReplace') - import :: color_type, image_type - implicit none - type(image_type), intent(inout) :: image - type(color_type), intent(in), value :: color - type(color_type), intent(in), value :: replace - end subroutine image_color_replace - - ! void ImageColorTint(Image *image, Color color) - subroutine image_color_tint(image, color) bind(c, name='ImageColorTint') - import :: color_type, image_type - implicit none - type(image_type), intent(inout) :: image - type(color_type), intent(in), value :: color - end subroutine image_color_tint - - ! Image ImageCopy(Image image) - function image_copy(image) bind(c, name='ImageCopy') - import :: image_type - implicit none - type(image_type), intent(in), value :: image - type(image_type) :: image_copy - end function image_copy - - ! void ImageCrop(Image *image, Rectangle crop) - subroutine image_crop(image, crop) bind(c, name='ImageCrop') - import :: image_type, rectangle_type - implicit none - type(image_type), intent(inout) :: image - type(rectangle_type), intent(in), value :: crop - end subroutine image_crop - - ! void ImageDither(Image *image, int rBpp, int gBpp, int bBpp, int aBpp) - subroutine image_dither(image, r_bpp, g_bpp, b_bpp, a_bpp) bind(c, name='ImageDither') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: r_bpp - integer(kind=c_int), intent(in), value :: g_bpp - integer(kind=c_int), intent(in), value :: b_bpp - integer(kind=c_int), intent(in), value :: a_bpp - end subroutine image_dither - - ! void ImageDraw(Image *dst, Image src, Rectangle srcRec, Rectangle dstRec, Color tint) - subroutine image_draw(dst, src, src_rec, dst_rec, tint) bind(c, name='ImageDraw') - import :: color_type, image_type, rectangle_type - implicit none - type(image_type), intent(inout) :: dst - type(image_type), intent(in), value :: src - type(rectangle_type), intent(in), value :: src_rec - type(rectangle_type), intent(in), value :: dst_rec - type(color_type), intent(in), value :: tint - end subroutine image_draw - - ! void ImageDrawCircle(Image *dst, int centerX, int centerY, int radius, Color color) - subroutine image_draw_circle(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircle') - import :: c_int, color_type, image_type - implicit none - type(image_type), intent(inout) :: dst - integer(kind=c_int), intent(in), value :: center_x - integer(kind=c_int), intent(in), value :: center_y - integer(kind=c_int), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine image_draw_circle - - ! void ImageDrawCircleLines(Image *dst, int centerX, int centerY, int radius, Color color) - subroutine image_draw_circle_lines(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircleLines') - import :: c_int, color_type, image_type - implicit none - type(image_type), intent(inout) :: dst - integer(kind=c_int), intent(in), value :: center_x - integer(kind=c_int), intent(in), value :: center_y - integer(kind=c_int), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine image_draw_circle_lines - - ! void ImageDrawCircleLinesV(Image *dst, Vector2 center, int radius, Color color) - subroutine image_draw_circle_lines_v(dst, center, radius, color) bind(c, name='ImageDrawCircleLinesV') - import :: c_int, color_type, image_type, vector2_type - implicit none - type(image_type), intent(inout) :: dst - type(vector2_type), intent(in), value :: center - integer(kind=c_int), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine image_draw_circle_lines_v - - ! void ImageDrawCircleV(Image *dst, Vector2 center, int radius, Color color) - subroutine image_draw_circle_v(dst, center, radius, color) bind(c, name='ImageDrawCircleV') - import :: c_int, color_type, image_type, vector2_type - implicit none - type(image_type), intent(inout) :: dst - type(vector2_type), intent(in), value :: center - integer(kind=c_int), intent(in), value :: radius - type(color_type), intent(in), value :: color - end subroutine image_draw_circle_v - - ! void ImageDrawLine(Image *dst, int startPosX, int startPosY, int endPosX, int endPosY, Color color) - subroutine image_draw_line(dst, start_pos_x, start_pos_y, end_pos_x, end_pos_y, color) & - bind(c, name='ImageDrawLine') - import :: c_int, color_type, image_type - implicit none - type(image_type), intent(inout) :: dst - integer(kind=c_int), intent(in), value :: start_pos_x - integer(kind=c_int), intent(in), value :: start_pos_y - integer(kind=c_int), intent(in), value :: end_pos_x - integer(kind=c_int), intent(in), value :: end_pos_y - type(color_type), intent(in), value :: color - end subroutine image_draw_line - - ! void ImageDrawLineV(Image *dst, Vector2 start, Vector2 end, Color color) - subroutine image_draw_line_v(dst, start, end, color) bind(c, name='ImageDrawLineV') - import :: color_type, image_type, vector2_type - implicit none - type(image_type), intent(inout) :: dst - type(vector2_type), intent(in), value :: start - type(vector2_type), intent(in), value :: end - type(color_type) , intent(in), value :: color - end subroutine image_draw_line_v - - ! void ImageDrawPixel(Image *dst, int posX, int posY, Color color) - subroutine image_draw_pixel(dst, pos_x, pos_y, color) bind(c, name='ImageDrawPixel') - import :: c_int, color_type, image_type - implicit none - type(image_type), intent(inout) :: dst - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - type(color_type), intent(in), value :: color - end subroutine image_draw_pixel - - ! void ImageDrawPixelV(Image *dst, Vector2 position, Color color) - subroutine image_draw_pixel_v(dst, position, color) bind(c, name='ImageDrawPixelV') - import :: color_type, image_type, vector2_type - implicit none - type(image_type), intent(inout) :: dst - type(vector2_type), intent(in), value :: position - type(color_type), intent(in), value :: color - end subroutine image_draw_pixel_v - - ! void ImageDrawRectangle(Image *dst, int posX, int posY, int width, int height, Color color) - subroutine image_draw_rectangle(dst, pos_x, pos_y, width, height, color) bind(c, name='ImageDrawRectangle') - import :: c_int, color_type, image_type - implicit none - type(image_type), intent(inout) :: dst - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(color_type), intent(in), value :: color - end subroutine image_draw_rectangle - - ! void ImageDrawRectangleLines(Image *dst, Rectangle rec, int thick, Color color) - subroutine image_draw_rectangle_lines(dst, rec, thick, color) bind(c, name='ImageDrawRectangleLines') - import :: c_int, color_type, image_type, rectangle_type - implicit none - type(image_type), intent(inout) :: dst - type(rectangle_type), intent(in), value :: rec - integer(kind=c_int), intent(in), value :: thick - type(color_type), intent(in), value :: color - end subroutine image_draw_rectangle_lines - - ! void ImageDrawRectangleRec(Image *dst, Rectangle rec, Color color) - subroutine image_draw_rectangle_rec(dst, rec, color) bind(c, name='ImageDrawRectangleRec') - import :: color_type, image_type, rectangle_type - implicit none - type(image_type), intent(inout) :: dst - type(rectangle_type), intent(in), value :: rec - type(color_type), intent(in), value :: color - end subroutine image_draw_rectangle_rec - - ! void ImageDrawRectangleV(Image *dst, Vector2 position, Vector2 size, Color color) - subroutine image_draw_rectangle_v(dst, position, size, color) bind(c, name='ImageDrawRectangleV') - import :: color_type, image_type, vector2_type - implicit none - type(image_type), intent(inout) :: dst - type(vector2_type), intent(in), value :: position - type(vector2_type), intent(in), value :: size - type(color_type), intent(in), value :: color - end subroutine image_draw_rectangle_v - - ! void ImageDrawText(Image *dst, const char *text, int posX, int posY, int fontSize, Color color) - subroutine image_draw_text(dst, text, pos_x, pos_y, font_size, color) bind(c, name='ImageDrawText') - import :: c_char, c_int, color_type, image_type - implicit none - type(image_type), intent(inout) :: dst - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(in), value :: pos_x - integer(kind=c_int), intent(in), value :: pos_y - integer(kind=c_int), intent(in), value :: font_size - type(color_type), intent(in), value :: color - end subroutine image_draw_text - - ! void ImageDrawTextEx(Image *dst, Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) - subroutine image_draw_text_ex(dst, font, text, position, font_size, spacing, tint) bind(c, name='ImageDrawTextEx') - import :: c_char, c_float, color_type, font_type, image_type, vector2_type - implicit none - type(image_type), intent(inout) :: dst - type(font_type), intent(in), value :: font - character(kind=c_char), intent(in) :: text - type(vector2_type), intent(in), value :: position - real(kind=c_float), intent(in), value :: font_size - real(kind=c_float), intent(in), value :: spacing - type(color_type), intent(in), value :: tint - end subroutine image_draw_text_ex - - ! void ImageFlipHorizontal(Image *image) - subroutine image_flip_horizontal(image) bind(c, name='ImageFlipHorizontal') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_flip_horizontal - - ! void ImageFlipVertical(Image *image) - subroutine image_flip_vertical(image) bind(c, name='ImageFlipVertical') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_flip_vertical - - ! void ImageFormat(Image *image, int newFormat) - subroutine image_format(image, new_format) bind(c, name='ImageFormat') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: new_format - end subroutine image_format - - ! Image ImageFromImage(Image image, Rectangle rec) - function image_from_image(image, rec) bind(c, name='ImageFromImage') - import :: image_type, rectangle_type - implicit none - type(image_type), intent(in), value :: image - type(rectangle_type), intent(in), value :: rec - type(image_type) :: image_from_image - end function image_from_image - - ! void ImageKernelConvolution(Image *image, float *kernel, int kernelSize) - subroutine image_kernel_convolution(image, kernel, kernel_size) bind(c, name='ImageKernelConvolution') - import :: c_float, c_int, image_type - implicit none - type(image_type), intent(inout) :: image - real(kind=c_float), intent(inout) :: kernel - integer(kind=c_int), intent(in), value :: kernel_size - end subroutine image_kernel_convolution - - ! void ImageMipmaps(Image *image) - subroutine image_mipmaps(image) bind(c, name='ImageMipmaps') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_mipmaps - - ! void ImageResize(Image *image, int newWidth, int newHeight) - subroutine image_resize(image, new_width, new_height) bind(c, name='ImageResize') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: new_width - integer(kind=c_int), intent(in), value :: new_height - end subroutine image_resize - - ! void ImageResizeCanvas(Image *image, int newWidth, int newHeight, int offsetX, int offsetY, Color fill) - subroutine image_resize_canvas(image, new_width, new_height, offset_x, offset_y, fill) bind(c, name='ImageResizeCanvas') - import :: c_int, color_type, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: new_width - integer(kind=c_int), intent(in), value :: new_height - integer(kind=c_int), intent(in), value :: offset_x - integer(kind=c_int), intent(in), value :: offset_y - type(color_type), intent(in), value :: fill - end subroutine image_resize_canvas - - ! void ImageResizeNN(Image *image, int newWidth,int newHeight) - subroutine image_resize_nn(image, new_width, new_height) bind(c, name='ImageResizeNN') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: new_width - integer(kind=c_int), intent(in), value :: new_height - end subroutine image_resize_nn - - ! void ImageRotate(Image *image, int degrees) - subroutine image_rotate(image, degrees) bind(c, name='ImageRotate') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: image - integer(kind=c_int), intent(in), value :: degrees - end subroutine image_rotate - - ! void ImageRotateCCW(Image *image) - subroutine image_rotate_ccw(image) bind(c, name='ImageRotateCCW') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_rotate_ccw - - ! void ImageRotateCW(Image *image) - subroutine image_rotate_cw(image) bind(c, name='ImageRotateCW') - import :: image_type - implicit none - type(image_type), intent(inout) :: image - end subroutine image_rotate_cw - - ! Image ImageText(const char *text, int fontSize, Color color) - function image_text(text, font_size, color) bind(c, name='ImageText') - import :: c_char, c_int, color_type, image_type - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(in), value :: font_size - type(color_type), intent(in), value :: color - type(image_type) :: image_text - end function image_text - - ! Image ImageTextEx(Font font, const char *text, float fontSize, float spacing, Color tint) - function image_text_ex(font, text, font_size, spacing, tint) bind(c, name='ImageTextEx') - import :: c_char, c_float, color_type, font_type, image_type - implicit none - type(font_type), intent(in), value :: font - character(kind=c_char), intent(in) :: text - real(kind=c_float), intent(in), value :: font_size - real(kind=c_float), intent(in), value :: spacing - type(color_type), intent(in), value :: tint - type(image_type) :: image_text_ex - end function image_text_ex - - ! void ImageToPOT(Image *image, Color fill) - subroutine image_to_pot(image, fill) bind(c, name='ImageToPOT') - import :: color_type, image_type - implicit none - type(image_type), intent(inout) :: image - type(color_type), intent(in), value :: fill - end subroutine image_to_pot - - ! void InitAudioDevice(void) - subroutine init_audio_device() bind(c, name='InitAudioDevice') - end subroutine init_audio_device - - ! void InitWindow(int width, int height, const char *title) - subroutine init_window(width, height, title) bind(c, name='InitWindow') - import :: c_char, c_int - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - character(kind=c_char), intent(in) :: title - end subroutine init_window - - ! bool IsAudioDeviceReady(void) - function is_audio_device_ready() bind(c, name='IsAudioDeviceReady') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_audio_device_ready - end function is_audio_device_ready - - ! bool IsAudioStreamPlaying(AudioStream stream) - function is_audio_stream_playing(stream) bind(c, name='IsAudioStreamPlaying') - import :: audio_stream_type, c_bool - implicit none - type(audio_stream_type), intent(in), value :: stream - logical(kind=c_bool) :: is_audio_stream_playing - end function is_audio_stream_playing - - ! bool IsAudioStreamProcessed(AudioStream stream) - function is_audio_stream_processed(stream) bind(c, name='IsAudioStreamProcessed') - import :: audio_stream_type, c_bool - implicit none - type(audio_stream_type), intent(in), value :: stream - logical(kind=c_bool) :: is_audio_stream_processed - end function is_audio_stream_processed - - ! bool IsAudioStreamReady(AudioStream stream) - function is_audio_stream_ready(stream) bind(c, name='IsAudioStreamReady') - import :: audio_stream_type, c_bool - implicit none - type(audio_stream_type), intent(in), value :: stream - logical(kind=c_bool) :: is_audio_stream_ready - end function is_audio_stream_ready - - ! bool IsCursorHidden(void) - function is_cursor_hidden() bind(c, name='IsCursorHidden') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_cursor_hidden - end function is_cursor_hidden - - ! bool IsCursorOnScreen(void) - function is_cursor_on_screen() bind(c, name='IsCursorOnScreen') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_cursor_on_screen - end function is_cursor_on_screen - - ! bool IsFileDropped(void) - function is_file_dropped() bind(c, name='IsFileDropped') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_file_dropped - end function is_file_dropped - - ! bool IsFileExtension(const char *fileName, const char *ext) - function is_file_extension(file_name, ext) bind(c, name='IsFileExtension') - import :: c_bool, c_char - implicit none - character(kind=c_char), intent(in) :: file_name - character(kind=c_char), intent(in) :: ext - logical(kind=c_bool) :: is_file_extension - end function is_file_extension - - ! bool IsFontReady(Font font) - function is_font_ready(font) bind(c, name='IsFontReady') - import :: c_bool, font_type - implicit none - type(font_type), intent(in), value :: font - logical(kind=c_bool) :: is_font_ready - end function is_font_ready - - ! bool IsGamepadAvailable(int gamepad) - function is_gamepad_available(gamepad) bind(c, name='IsGamepadAvailable') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: gamepad - logical(kind=c_bool) :: is_gamepad_available - end function is_gamepad_available - - ! bool IsGamepadButtonDown(int gamepad, int button) - function is_gamepad_button_down(gamepad, button) bind(c, name='IsGamepadButtonDown') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: gamepad - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_gamepad_button_down - end function is_gamepad_button_down - - ! bool IsGamepadButtonPressed(int gamepad, int button) - function is_gamepad_button_pressed(gamepad, button) bind(c, name='IsGamepadButtonPressed') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: gamepad - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_gamepad_button_pressed - end function is_gamepad_button_pressed - - ! bool IsGamepadButtonReleased(int gamepad, int button) - function is_gamepad_button_released(gamepad, button) bind(c, name='IsGamepadButtonReleased') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: gamepad - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_gamepad_button_released - end function is_gamepad_button_released - - ! bool IsGamepadButtonUp(int gamepad, int button) - function is_gamepad_button_up(gamepad, button) bind(c, name='IsGamepadButtonUp') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: gamepad - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_gamepad_button_up - end function is_gamepad_button_up - - ! bool IsGestureDetected(unsigned int gesture) - function is_gesture_detected(gesture) bind(c, name='IsGestureDetected') - import :: c_bool, c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: gesture - logical(kind=c_bool) :: is_gesture_detected - end function is_gesture_detected - - ! bool IsImageReady(Image image) - function is_image_ready(image) bind(c, name='IsImageReady') - import :: c_bool, image_type - implicit none - type(image_type), intent(in), value :: image - logical(kind=c_bool) :: is_image_ready - end function is_image_ready - - ! bool IsKeyDown(int key) - function is_key_down(key) bind(c, name='IsKeyDown') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: key - logical(kind=c_bool) :: is_key_down - end function is_key_down - - ! bool IsKeyPressed(int key) - function is_key_pressed(key) bind(c, name='IsKeyPressed') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: key - logical(kind=c_bool) :: is_key_pressed - end function is_key_pressed - - ! bool IsKeyPressedRepeat(int key) - function is_key_pressed_repeat(key) bind(c, name='IsKeyPressedRepeat') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: key - logical(kind=c_bool) :: is_key_pressed_repeat - end function is_key_pressed_repeat - - ! bool IsKeyReleased(int key) - function is_key_released(key) bind(c, name='IsKeyReleased') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: key - logical(kind=c_bool) :: is_key_released - end function is_key_released - - ! bool IsKeyUp(int key) - function is_key_up(key) bind(c, name='IsKeyUp') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: key - logical(kind=c_bool) :: is_key_up - end function is_key_up - - ! bool IsMaterialReady(Material material) - function is_material_ready(material) bind(c, name='IsMaterialReady') - import :: c_bool, material_type - implicit none - type(material_type), intent(in), value :: material - logical(kind=c_bool) :: is_material_ready - end function is_material_ready - - ! bool IsModelAnimationValid(Model model, ModelAnimation anim) - function is_model_animation_valid(model, anim) bind(c, name='IsModelAnimationValid') - import :: c_bool, model_animation_type, model_type - implicit none - type(model_type), intent(in), value :: model - type(model_animation_type), intent(in), value :: anim - logical(kind=c_bool) :: is_model_animation_valid - end function is_model_animation_valid - - ! bool IsModelReady(Model model) - function is_model_ready(model) bind(c, name='IsModelReady') - import :: c_bool, model_type - implicit none - type(model_type), intent(in), value :: model - logical(kind=c_bool) :: is_model_ready - end function is_model_ready - - ! bool IsMouseButtonDown(int button) - function is_mouse_button_down(button) bind(c, name='IsMouseButtonDown') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_mouse_button_down - end function is_mouse_button_down - - ! bool IsMouseButtonPressed(int button) - function is_mouse_button_pressed(button) bind(c, name='IsMouseButtonPressed') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_mouse_button_pressed - end function is_mouse_button_pressed - - ! bool IsMouseButtonReleased(int button) - function is_mouse_button_released(button) bind(c, name='IsMouseButtonReleased') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_mouse_button_released - end function is_mouse_button_released - - ! bool IsMouseButtonUp(int button) - function is_mouse_button_up(button) bind(c, name='IsMouseButtonUp') - import :: c_bool, c_int - implicit none - integer(kind=c_int), intent(in), value :: button - logical(kind=c_bool) :: is_mouse_button_up - end function is_mouse_button_up - - ! bool IsMusicReady(Music music) - function is_music_ready(music) bind(c, name='IsMusicReady') - import :: c_bool, music_type - implicit none - type(music_type), intent(in), value :: music - logical(kind=c_bool) :: is_music_ready - end function is_music_ready - - ! bool IsMusicStreamPlaying(Music music) - function is_music_stream_playing(music) bind(c, name='IsMusicStreamPlaying') - import :: c_bool, music_type - implicit none - type(music_type), intent(in), value :: music - logical(kind=c_bool) :: is_music_stream_playing - end function is_music_stream_playing - - ! bool IsPathFile(const char *path) - function is_path_file(path) bind(c, name='IsPathFile') - import :: c_bool, c_char - implicit none - character(kind=c_char), intent(in) :: path - logical(kind=c_bool) :: is_path_file - end function is_path_file - - ! bool IsRenderTextureReady(RenderTexture2D target) - function is_render_texture_ready(target) bind(c, name='IsRenderTextureReady') - import :: c_bool, render_texture2d_type - implicit none - type(render_texture2d_type), intent(in), value :: target - logical(kind=c_bool) :: is_render_texture_ready - end function is_render_texture_ready - - ! bool IsShaderReady(Shader shader) - function is_shader_ready(shader) bind(c, name='IsShaderReady') - import :: c_bool, shader_type - implicit none - type(shader_type), intent(in), value :: shader - logical(kind=c_bool) :: is_shader_ready - end function is_shader_ready - - ! bool IsSoundPlaying(Sound sound) - function is_sound_playing(sound) bind(c, name='IsSoundPlaying') - import :: c_bool, sound_type - implicit none - type(sound_type), intent(in), value :: sound - logical(kind=c_bool) :: is_sound_playing - end function is_sound_playing - - ! bool IsSoundReady(Sound sound) - function is_sound_ready(sound) bind(c, name='IsSoundReady') - import :: c_bool, sound_type - implicit none - type(sound_type), intent(in), value :: sound - logical(kind=c_bool) :: is_sound_ready - end function is_sound_ready - - ! bool IsTextureReady(Texture2D texture) - function is_texture_ready(texture) bind(c, name='IsTextureReady') - import :: c_bool, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - logical(kind=c_bool) :: is_texture_ready - end function is_texture_ready - - ! bool IsWaveReady(Wave wave) - function is_wave_ready(wave) bind(c, name='IsWaveReady') - import :: c_bool, wave_type - implicit none - type(wave_type), intent(in), value :: wave - logical(kind=c_bool) :: is_wave_ready - end function is_wave_ready - - ! bool IsWindowFocused(void) - function is_window_focused() bind(c, name='IsWindowFocused') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_window_focused - end function is_window_focused - - ! bool IsWindowFullscreen(void) - function is_window_fullscreen() bind(c, name='IsWindowFullscreen') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_window_fullscreen - end function is_window_fullscreen - - ! bool IsWindowHidden(void) - function is_window_hidden() bind(c, name='IsWindowHidden') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_window_hidden - end function is_window_hidden - - ! bool IsWindowMaximized(void) - function is_window_maximized() bind(c, name='IsWindowMaximized') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_window_maximized - end function is_window_maximized - - ! bool IsWindowMinimized(void) - function is_window_minimized() bind(c, name='IsWindowMinimized') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_window_minimized - end function is_window_minimized - - ! bool IsWindowReady(void) - function is_window_ready() bind(c, name='IsWindowReady') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_window_ready - end function is_window_ready - - ! bool IsWindowResized(void) - function is_window_resized() bind(c, name='IsWindowResized') - import :: c_bool - implicit none - logical(kind=c_bool) :: is_window_resized - end function is_window_resized - - ! bool IsWindowState(unsigned int flag) - function is_window_state(flag) bind(c, name='IsWindowState') - import :: c_bool, c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: flag - logical(kind=c_bool) :: is_window_state - end function is_window_state - - ! AudioStream LoadAudioStream(unsigned int sampleRate, unsigned int sampleSize, unsigned int channels) - function load_audio_stream(sample_rate, sample_size, channels) bind(c, name='LoadAudioStream') - import :: audio_stream_type, c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: sample_rate - integer(kind=c_unsigned_int), intent(in), value :: sample_size - integer(kind=c_unsigned_int), intent(in), value :: channels - type(audio_stream_type) :: load_audio_stream - end function load_audio_stream - - ! int *LoadCodepoints(const char *text, int *count) - function load_codepoints(text, count) bind(c, name='LoadCodepoints') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(out) :: count - type(c_ptr) :: load_codepoints - end function load_codepoints - - ! FilePathList LoadDirectoryFiles(const char *dirPath) - function load_directory_files(dir_path) bind(c, name='LoadDirectoryFiles') - import :: c_char, file_path_list_type - implicit none - character(kind=c_char), intent(in) :: dir_path - type(file_path_list_type) :: load_directory_files - end function load_directory_files - - ! FilePathList LoadDirectoryFilesEx(const char *basePath, const char *filter, bool scanSubdirs) - function load_directory_files_ex(base_path, filter, scan_subdirs) bind(c, name='LoadDirectoryFilesEx') - import :: c_bool, c_char, file_path_list_type - implicit none - character(kind=c_char), intent(in) :: base_path - character(kind=c_char), intent(in) :: filter - logical(kind=c_bool), intent(in), value :: scan_subdirs - type(file_path_list_type) :: load_directory_files_ex - end function load_directory_files_ex - - ! FilePathList LoadDroppedFiles(void) - function load_dropped_files() bind(c, name='LoadDroppedFiles') - import :: file_path_list_type - implicit none - type(file_path_list_type) :: load_dropped_files - end function load_dropped_files - - ! unsigned char *LoadFileData(const char *fileName, int *dataSize) - function load_file_data(file_name, data_size) bind(c, name='LoadFileData') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_int), intent(out) :: data_size - type(c_ptr) :: load_file_data - end function load_file_data - - ! char *LoadFileText(const char *fileName) - function load_file_text(file_name) bind(c, name='LoadFileText') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_name - type(c_ptr) :: load_file_text - end function load_file_text - - ! Font LoadFont(const char *fileName) - function load_font(file_name) bind(c, name='LoadFont') - import :: c_char, font_type - implicit none - character(kind=c_char), intent(in) :: file_name - type(font_type) :: load_font - end function load_font - - ! GlyphInfo *LoadFontData(const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount, int type) - function load_font_data(file_data, data_size, font_size, codepoints, codepoints_count, type) & - bind(c, name='LoadFontData') - import :: c_int, c_ptr, c_unsigned_char, glyph_info_type - implicit none - integer(kind=c_unsigned_char), intent(inout) :: file_data - integer(kind=c_int), intent(in), value :: data_size - integer(kind=c_int), intent(in), value :: font_size - integer(kind=c_int), intent(inout) :: codepoints(*) - integer(kind=c_int), intent(in), value :: codepoints_count - integer(kind=c_int), intent(in), value :: type - type(c_ptr) :: load_font_data - end function load_font_data - - ! Font LoadFontEx(const char *fileName, int fontSize, int *codepoints, int codepointsCount) - function load_font_ex(file_name, font_size, codepoints, codepoints_count) bind(c, name='LoadFontEx') - import :: c_char, c_int, font_type - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_int), intent(in), value :: font_size - integer(kind=c_int), intent(inout) :: codepoints(*) - integer(kind=c_int), intent(in), value :: codepoints_count - type(font_type) :: load_font_ex - end function load_font_ex - - ! Font LoadFontFromImage(Image image, Color key, int firstChar) - function load_font_from_image(image, key, first_char) bind(c, name='LoadFontFromImage') - import :: c_int, color_type, font_type, image_type - implicit none - type(image_type), intent(in), value :: image - type(color_type), intent(in), value :: key - integer(kind=c_int), intent(in), value :: first_char - type(font_type) :: load_font_from_image - end function load_font_from_image - - ! Font LoadFontFromMemory(const char *fileType, const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount) - function load_font_from_memory(file_type, file_data, data_size, font_size, codepoints, codepoints_count) & - bind(c, name='LoadFontFromMemory') - import :: c_char, c_int, c_unsigned_char, font_type - implicit none - character(kind=c_char), intent(in) :: file_type - integer(kind=c_unsigned_char), intent(in) :: file_data - integer(kind=c_int), intent(in), value :: data_size - integer(kind=c_int), intent(in), value :: font_size - integer(kind=c_int), intent(inout) :: codepoints(*) - integer(kind=c_int), intent(in), value :: codepoints_count - type(font_type) :: load_font_from_memory - end function load_font_from_memory - - ! Image LoadImage(const char *fileName) - function load_image(file_name) bind(c, name='LoadImage') - import :: c_char, image_type - implicit none - character(kind=c_char), intent(in) :: file_name - type(image_type) :: load_image - end function load_image - - ! Image LoadImageAnim(const char *fileName, int *frames) - function load_image_anim(file_name, frames) bind(c, name='LoadImageAnim') - import :: c_char, c_int, image_type - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_int), intent(out) :: frames - type(image_type) :: load_image_anim - end function load_image_anim - - ! Color *LoadImageColors(Image image) - function load_image_colors(image) bind(c, name='LoadImageColors') - import :: c_ptr, image_type - implicit none - type(image_type), intent(in), value :: image - type(c_ptr) :: load_image_colors - end function load_image_colors - - ! Image LoadImageFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) - function load_image_from_memory(file_type, file_data, data_size) bind(c, name='LoadImageFromMemory') - import :: c_char, c_int, c_unsigned_char, image_type - implicit none - character(kind=c_char), intent(in) :: file_type - integer(kind=c_unsigned_char), intent(in) :: file_data - integer(kind=c_int), intent(in), value :: data_size - type(image_type) :: load_image_from_memory - end function load_image_from_memory - - ! Image LoadImageFromScreen(void) - function load_image_from_screen() bind(c, name='LoadImageFromScreen') - import :: image_type - implicit none - type(image_type) :: load_image_from_screen - end function load_image_from_screen - - ! Image LoadImageFromTexture(Texture2D texture) - function load_image_from_texture(texture) bind(c, name='LoadImageFromTexture') - import :: image_type, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(image_type) :: load_image_from_texture - end function load_image_from_texture - - ! Color *LoadImagePalette(Image image, int maxPaletteSize, int *colorCount) - function load_image_palette(image, max_palette_size, color_count) bind(c, name='LoadImagePalette') - import :: c_int, c_ptr, image_type - implicit none - type(image_type), intent(in), value :: image - integer(kind=c_int), intent(in), value :: max_palette_size - integer(kind=c_int), intent(out) :: color_count - type(c_ptr) :: load_image_palette - end function load_image_palette - - ! Image LoadImageRaw(const char *fileName, int width, int height, int format, int headerSize) - function load_image_raw(file_name, width, height, format, header_size) bind(c, name='LoadImageRaw') - import :: c_char, c_int, image_type - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - integer(kind=c_int), intent(in), value :: format - integer(kind=c_int), intent(in), value :: header_size - type(image_type) :: load_image_raw - end function load_image_raw - - ! Image LoadImageSvg(const char *fileNameOrString, int width, int height) - function load_image_svg(file_name_or_string, width, height) bind(c, name='LoadImageSvg') - import :: c_char, c_int, image_type - implicit none - character(kind=c_char), intent(in) :: file_name_or_string - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(image_type) :: load_image_svg - end function load_image_svg - - ! Material LoadMaterialDefault(void) - function load_material_default() bind(c, name='LoadMaterialDefault') - import :: material_type - implicit none - type(material_type) :: load_material_default - end function load_material_default - - ! Material *LoadMaterials(const char *fileName, int *materialCount) - function load_materials(file_name, material_count) bind(c, name='LoadMaterials') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_int), intent(out) :: material_count - type(c_ptr) :: load_materials - end function load_materials - - ! Model LoadModel(const char *fileName) - function load_model(file_name) bind(c, name='LoadModel') - import :: c_char, model_type - implicit none - character(kind=c_char), intent(in) :: file_name - type(model_type) :: load_model - end function load_model - - ! ModelAnimation *LoadModelAnimations(const char *fileName, int *animCount) - function load_model_animations(file_name, anim_count) bind(c, name='LoadModelAnimations') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_name - integer(kind=c_int), intent(out) :: anim_count - type(c_ptr) :: load_model_animations - end function load_model_animations - - ! Model LoadModelFromMesh(Mesh mesh) - function load_model_from_mesh(mesh) bind(c, name='LoadModelFromMesh') - import :: mesh_type, model_type - implicit none - type(mesh_type), intent(in), value :: mesh - type(model_type) :: load_model_from_mesh - end function load_model_from_mesh - - ! Music LoadMusicStream(const char *fileName) - function load_music_stream(file_name) bind(c, name='LoadMusicStream') - import :: c_char, music_type - implicit none - character(kind=c_char), intent(in) :: file_name - type(music_type) :: load_music_stream - end function load_music_stream - - ! Music LoadMusicStreamFromMemory(const char *fileType, const unsigned char *data, int dataSize) - function load_music_stream_from_memory(file_type, data, data_size) bind(c, name='LoadMusicStreamFromMemory') - import :: c_char, c_int, c_unsigned_char, music_type - implicit none - character(kind=c_char), intent(in) :: file_type - integer(kind=c_unsigned_char), intent(in) :: data - integer(kind=c_int), intent(in), value :: data_size - type(music_type) :: load_music_stream_from_memory - end function load_music_stream_from_memory - - ! int *LoadRandomSequence(unsigned int count, int min, int max) - function load_random_sequence(count, min, max) bind(c, name='LoadRandomSequence') - import :: c_int, c_ptr, c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: count - integer(kind=c_int), intent(in), value :: min - integer(kind=c_int), intent(in), value :: max - type(c_ptr) :: load_random_sequence - end function load_random_sequence - - ! RenderTexture2D LoadRenderTexture(int width, int height) - function load_render_texture(width, height) bind(c, name='LoadRenderTexture') - import :: c_int, render_texture2d_type - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - type(render_texture2d_type) :: load_render_texture - end function load_render_texture - - ! Shader LoadShader(const char *vsFileName, const char *fsFileName) - function load_shader(vs_file_name, fs_file_name) bind(c, name='LoadShader') - import :: c_char, shader_type - implicit none - character(kind=c_char), intent(in) :: vs_file_name - character(kind=c_char), intent(in) :: fs_file_name - type(shader_type) :: load_shader - end function load_shader - - ! Shader LoadShaderFromMemory(const char *vsCode, const char *fsCode) - function load_shader_from_memory(vs_code, fs_code) bind(c, name='LoadShaderFromMemory') - import :: c_char, shader_type - implicit none - character(kind=c_char), intent(in) :: vs_code - character(kind=c_char), intent(in) :: fs_code - type(shader_type) :: load_shader_from_memory - end function load_shader_from_memory - - ! Sound LoadSound(const char *fileName) - function load_sound(file_name) bind(c, name='LoadSound') - import :: c_char, sound_type - implicit none - character(kind=c_char), intent(in) :: file_name - type(sound_type) :: load_sound - end function load_sound - - ! Sound LoadSoundAlias(Sound source) - function load_sound_alias(source) bind(c, name='LoadSoundAlias') - import :: sound_type - implicit none - type(sound_type), intent(in), value :: source - type(sound_type) :: load_sound_alias - end function load_sound_alias - - ! Sound LoadSoundFromWave(Wave wave) - function load_sound_from_wave(wave) bind(c, name='LoadSoundFromWave') - import :: sound_type, wave_type - implicit none - type(wave_type), intent(in), value :: wave - type(sound_type) :: load_sound_from_wave - end function load_sound_from_wave - - ! Texture2D LoadTexture(const char *fileName) - function load_texture(file_name) bind(c, name='LoadTexture') - import :: c_char, texture2d_type - implicit none - character(kind=c_char), intent(in) :: file_name - type(texture2d_type) :: load_texture - end function load_texture - - ! TextureCubemap LoadTextureCubemap(Image image, int layout) - function load_texture_cubemap(image, layout) bind(c, name='LoadTextureCubemap') - import :: c_int, image_type, texture_cubemap_type - implicit none - type(image_type), intent(in), value :: image - integer(kind=c_int), intent(in), value :: layout - type(texture_cubemap_type) :: load_texture_cubemap - end function load_texture_cubemap - - ! Texture2D LoadTextureFromImage(Image image) - function load_texture_from_image(image) bind(c, name='LoadTextureFromImage') - import :: image_type, texture2d_type - implicit none - type(image_type), intent(in), value :: image - type(texture2d_type) :: load_texture_from_image - end function load_texture_from_image - - ! char *LoadUTF8(const int *codepoints, int length) - function load_utf8(codepoints, length) bind(c, name='LoadUTF8') - import :: c_int, c_ptr - implicit none - integer(kind=c_int), intent(out) :: codepoints(*) - integer(kind=c_int), intent(in), value :: length - type(c_ptr) :: load_utf8 - end function load_utf8 - - ! VrStereoConfig LoadVrStereoConfig(VrDeviceInfo device) - function load_vr_stereo_config(device) bind(c, name='LoadVrStereoConfig') - import :: vr_device_info_type, vr_stereo_config_type - implicit none - type(vr_device_info_type), intent(in), value :: device - type(vr_stereo_config_type) :: load_vr_stereo_config - end function load_vr_stereo_config - - ! Wave LoadWave(const char *fileName) - function load_wave(file_name) bind(c, name='LoadWave') - import :: c_char, wave_type - implicit none - character(kind=c_char), intent(in) :: file_name - type(wave_type) :: load_wave - end function load_wave - - ! Wave LoadWaveFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) - function load_wave_from_memory(file_type, file_data, data_size) bind(c, name='LoadWaveFromMemory') - import :: c_char, c_int, c_unsigned_char, wave_type - implicit none - character(kind=c_char), intent(in) :: file_type - integer(kind=c_unsigned_char), intent(in) :: file_data - integer(kind=c_int), intent(in), value :: data_size - type(wave_type) :: load_wave_from_memory - end function load_wave_from_memory - - ! float *LoadWaveSamples(Wave wave) - function load_wave_samples(wave) bind(c, name='LoadWaveSamples') - import :: c_ptr, wave_type - implicit none - type(wave_type), intent(in), value :: wave - type(c_ptr) :: load_wave_samples - end function load_wave_samples - - ! void MaximizeWindow(void) - subroutine maximize_window() bind(c, name='MaximizeWindow') - end subroutine maximize_window - - ! int MeasureText(const char *text, int fontSize) - function measure_text(text, font_size) bind(c, name='MeasureText') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(in), value :: font_size - integer(kind=c_int) :: measure_text - end function measure_text - - ! Vector2 MeasureTextEx(Font font, const char *text, float fontSize, float spacing) - function measure_text_ex(font, text, font_size, spacing) bind(c, name='MeasureTextEx') - import :: c_char, c_float, font_type, vector2_type - implicit none - type(font_type), intent(in), value :: font - character(kind=c_char), intent(in) :: text - real(kind=c_float), intent(in), value :: font_size - real(kind=c_float), intent(in), value :: spacing - type(vector2_type) :: measure_text_ex - end function measure_text_ex - - ! void *MemAlloc(unsigned int size) - function mem_alloc(size) bind(c, name='MemAlloc') - import :: c_ptr, c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: size - type(c_ptr) :: mem_alloc - end function mem_alloc - - ! void MemFree(void *ptr) - subroutine mem_free(ptr) bind(c, name='MemFree') - import :: c_ptr - implicit none - type(c_ptr), intent(in), value :: ptr - end subroutine mem_free - - ! void *MemRealloc(void *ptr, unsigned int size) - function mem_realloc(ptr, size) bind(c, name='MemRealloc') - import :: c_ptr, c_unsigned_int - implicit none - type(c_ptr), intent(in), value :: ptr - integer(kind=c_unsigned_int), intent(in), value :: size - type(c_ptr) :: mem_realloc - end function mem_realloc - - ! void MinimizeWindow(void) - subroutine minimize_window() bind(c, name='MinimizeWindow') - end subroutine minimize_window - - ! void OpenURL(const char *url) - subroutine open_url(url) bind(c, name='OpenURL') - import :: c_char - implicit none - character(kind=c_char), intent(in) :: url - end subroutine open_url - - ! void PauseAudioStream(AudioStream stream) - subroutine pause_audio_stream(stream) bind(c, name='PauseAudioStream') - import :: audio_stream_type - implicit none - type(audio_stream_type), intent(in), value :: stream - end subroutine pause_audio_stream - - ! void PauseMusicStream(Music music) - subroutine pause_music_stream(music) bind(c, name='PauseMusicStream') - import :: music_type - implicit none - type(music_type), intent(in), value :: music - end subroutine pause_music_stream - - ! void PauseSound(Sound sound) - subroutine pause_sound(sound) bind(c, name='PauseSound') - import :: sound_type - implicit none - type(sound_type), intent(in), value :: sound - end subroutine pause_sound - - ! void PlayAudioStream(AudioStream stream) - subroutine play_audio_stream(stream) bind(c, name='PlayAudioStream') - import :: audio_stream_type - implicit none - type(audio_stream_type), intent(in), value :: stream - end subroutine play_audio_stream - - ! void PlayMusicStream(Music music) - subroutine play_music_stream(music) bind(c, name='PlayMusicStream') - import :: music_type - implicit none - type(music_type), intent(in), value :: music - end subroutine play_music_stream - - ! void PlaySound(Sound sound) - subroutine play_sound(sound) bind(c, name='PlaySound') - import :: sound_type - implicit none - type(sound_type), intent(in), value :: sound - end subroutine play_sound - - ! void PollInputEvents(void) - subroutine poll_input_events() bind(c, name='PollInputEvents') - end subroutine poll_input_events - - ! void RestoreWindow(void) - subroutine restore_window() bind(c, name='RestoreWindow') - end subroutine restore_window - - ! void ResumeAudioStream(AudioStream stream) - subroutine resume_audio_stream(stream) bind(c, name='ResumeAudioStream') - import :: audio_stream_type - implicit none - type(audio_stream_type), intent(in), value :: stream - end subroutine resume_audio_stream - - ! void ResumeMusicStream(Music music) - subroutine resume_music_stream(music) bind(c, name='ResumeMusicStream') - import :: music_type - implicit none - type(music_type), intent(in), value :: music - end subroutine resume_music_stream - - ! void ResumeSound(Sound sound) - subroutine resume_sound(sound) bind(c, name='ResumeSound') - import :: sound_type - implicit none - type(sound_type), intent(in), value :: sound - end subroutine resume_sound - - ! bool SaveFileData(const char *fileName, void *data, int dataSize) - function save_file_data(file_name, data, data_size) bind(c, name='SaveFileData') - import :: c_bool, c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: file_name - type(c_ptr), intent(in), value :: data - integer(kind=c_int), intent(in), value :: data_size - logical(kind=c_bool) :: save_file_data - end function save_file_data - - ! bool SaveFileText(const char *fileName, char *text) - function save_file_text(file_name, text) bind(c, name='SaveFileText') - import :: c_bool, c_char - implicit none - character(kind=c_char), intent(in) :: file_name - character(kind=c_char), intent(in) :: text - logical(kind=c_bool) :: save_file_text - end function save_file_text - - ! void SeekMusicStream(Music music, float position) - subroutine seek_music_stream(music, position) bind(c, name='SeekMusicStream') - import :: c_float, music_type - implicit none - type(music_type), intent(in), value :: music - real(kind=c_float), intent(in), value :: position - end subroutine seek_music_stream - - ! void SetAudioStreamBufferSizeDefault(int size) - subroutine set_audio_stream_buffer_size_default(size) bind(c, name='SetAudioStreamBufferSizeDefault') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: size - end subroutine set_audio_stream_buffer_size_default - - ! void SetAudioStreamPan(AudioStream stream, float pan) - subroutine set_audio_stream_pan(stream, pan) bind(c, name='SetAudioStreamPan') - import :: audio_stream_type, c_float - implicit none - type(audio_stream_type), intent(in), value :: stream - real(kind=c_float), intent(in), value :: pan - end subroutine set_audio_stream_pan - - ! void SetAudioStreamPitch(AudioStream stream, float pitch) - subroutine set_audio_stream_pitch(stream, pitch) bind(c, name='SetAudioStreamPitch') - import :: audio_stream_type, c_float - implicit none - type(audio_stream_type), intent(in), value :: stream - real(kind=c_float), intent(in), value :: pitch - end subroutine set_audio_stream_pitch - - ! void SetAudioStreamVolume(AudioStream stream, float volume) - subroutine set_audio_stream_volume(stream, volume) bind(c, name='SetAudioStreamVolume') - import :: audio_stream_type, c_float - implicit none - type(audio_stream_type), intent(in), value :: stream - real(kind=c_float), intent(in), value :: volume - end subroutine set_audio_stream_volume - - ! void SetCameraAltControl(int keyAlt) - subroutine set_camera_alt_control(key_alt) bind(c, name='SetCameraAltControl') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: key_alt - end subroutine set_camera_alt_control - - ! void SetCameraMode(Camera camera, int mode) - subroutine set_camera_mode(camera, mode) bind(c, name='SetCameraMode') - import :: c_int, camera3d_type - implicit none - type(camera3d_type), intent(in), value :: camera - integer(kind=c_int), intent(in), value :: mode - end subroutine set_camera_mode - - ! void SetCameraMoveControls(int keyFront, int keyBack, int keyRight, int keyLeft, int keyUp, int keyDown) - subroutine set_camera_move_controls(key_front, key_back, key_right, key_left, key_up, key_down) & - bind(c, name='SetCameraMoveControls') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: key_front - integer(kind=c_int), intent(in), value :: key_back - integer(kind=c_int), intent(in), value :: key_right - integer(kind=c_int), intent(in), value :: key_left - integer(kind=c_int), intent(in), value :: key_up - integer(kind=c_int), intent(in), value :: key_down - end subroutine set_camera_move_controls - - ! void SetCameraPanControl(int keyPan) - subroutine set_camera_pan_control(key_pan) bind(c, name='SetCameraPanControl') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: key_pan - end subroutine set_camera_pan_control - - ! void SetCameraSmoothZoomControl(int keySmoothZoom) - subroutine set_camera_smooth_zoom_control(key_smooth_zoom) bind(c, name='SetCameraSmoothZoomControl') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: key_smooth_zoom - end subroutine set_camera_smooth_zoom_control - - ! void SetClipboardText(const char *text) - subroutine set_clipboard_text(text) bind(c, name='SetClipboardText') - import :: c_char - implicit none - character(kind=c_char), intent(in) :: text - end subroutine set_clipboard_text - - ! void SetConfigFlags(unsigned int flags) - subroutine set_config_flags(flags) bind(c, name='SetConfigFlags') - import :: c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: flags - end subroutine set_config_flags - - ! void SetExitKey(int key) - subroutine set_exit_key(key) bind(c, name='SetExitKey') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: key - end subroutine set_exit_key - - ! int SetGamepadMappings(const char *mappings) - function set_gamepad_mappings(mappings) bind(c, name='SetGamepadMappings') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: mappings - integer(kind=c_int) :: set_gamepad_mappings - end function set_gamepad_mappings - - ! void SetGesturesEnabled(unsigned int flags) - subroutine set_gestures_enabled(flags) bind(c, name='SetGesturesEnabled') - import :: c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: flags - end subroutine set_gestures_enabled - - ! void SetLoadFileDataCallback(LoadFileDataCallback callback) - subroutine set_load_file_data_callback(callback) bind(c, name='SetLoadFileDataCallback') - import :: c_funptr - implicit none - type(c_funptr), intent(in), value :: callback - end subroutine set_load_file_data_callback - - ! void SetLoadFileTextCallback(LoadFileTextCallback callback) - subroutine set_load_file_text_callback(callback) bind(c, name='SetLoadFileTextCallback') - import :: c_funptr - implicit none - type(c_funptr), intent(in), value :: callback - end subroutine set_load_file_text_callback - - ! void SetMasterVolume(float volume) - subroutine set_master_volume(volume) bind(c, name='SetMasterVolume') - import :: c_float - implicit none - real(kind=c_float), intent(in), value :: volume - end subroutine set_master_volume - - ! void SetMaterialTexture(Material *material, int mapType, Texture2D texture) - subroutine set_material_texture(material, map_type, texture) bind(c, name='SetMaterialTexture') - import :: c_int, material_type, texture2d_type - implicit none - type(material_type), intent(inout) :: material - integer(kind=c_int), intent(in), value :: map_type - type(texture2d_type), intent(in), value :: texture - end subroutine set_material_texture - - ! void SetModelMeshMaterial(Model *model, int meshId, int materialId) - subroutine set_model_mesh_material(model, mesh_id, material_id) bind(c, name='SetModelMeshMaterial') - import :: c_int, model_type - implicit none - type(model_type), intent(inout) :: model - integer(kind=c_int), intent(in), value :: mesh_id - integer(kind=c_int), intent(in), value :: material_id - end subroutine set_model_mesh_material - - ! void SetMouseCursor(int cursor) - subroutine set_mouse_cursor(cursor) bind(c, name='SetMouseCursor') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: cursor - end subroutine set_mouse_cursor - - ! void SetMouseOffset(int offsetX, int offsetY) - subroutine set_mouse_offset(offset_x, offset_y) bind(c, name='SetMouseOffset') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: offset_x - integer(kind=c_int), intent(in), value :: offset_y - end subroutine set_mouse_offset - - ! void SetMousePosition(int x, int y) - subroutine set_mouse_position(x, y) bind(c, name='SetMousePosition') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: x - integer(kind=c_int), intent(in), value :: y - end subroutine set_mouse_position - - ! void SetMouseScale(float scaleX, float scaleY) - subroutine set_mouse_scale(scale_x, scale_y) bind(c, name='SetMouseScale') - import :: c_float - implicit none - real(kind=c_float), intent(in), value :: scale_x - real(kind=c_float), intent(in), value :: scale_y - end subroutine set_mouse_scale - - ! void SetMusicPan(Music music, float pan) - subroutine set_music_pan(music, pan) bind(c, name='SetMusicPan') - import :: c_float, music_type - implicit none - type(music_type), intent(in), value :: music - real(kind=c_float), intent(in), value :: pan - end subroutine set_music_pan - - ! void SetMusicPitch(Music music, float pitch) - subroutine set_music_pitch(music, pitch) bind(c, name='SetMusicPitch') - import :: c_float, music_type - implicit none - type(music_type), intent(in), value :: music - real(kind=c_float), intent(in), value :: pitch - end subroutine set_music_pitch - - ! void SetMusicVolume(Music music, float volume) - subroutine set_music_volume(music, volume) bind(c, name='SetMusicVolume') - import :: c_float, music_type - implicit none - type(music_type), intent(in), value :: music - real(kind=c_float), intent(in), value :: volume - end subroutine set_music_volume - - ! void SetPixelColor(void *dstPtr, Color color, int format) - subroutine set_pixel_color(dst_ptr, color, format) bind(c, name='SetPixelColor') - import :: c_int, c_ptr, color_type - implicit none - type(c_ptr), intent(in), value :: dst_ptr - type(color_type), intent(in), value :: color - integer(kind=c_int), intent(in), value :: format - end subroutine set_pixel_color - - ! void SetRandomSeed(unsigned int seed) - subroutine set_random_seed(seed) bind(c, name='SetRandomSeed') - import :: c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: seed - end subroutine set_random_seed - - ! void SetSaveFileDataCallback(SaveFileDataCallback callback) - subroutine set_save_file_data_callback(callback) bind(c, name='SetSaveFileDataCallback') - import :: c_funptr - implicit none - type(c_funptr), intent(in), value :: callback - end subroutine set_save_file_data_callback - - ! void SetSaveFileTextCallback(SaveFileTextCallback callback) - subroutine set_save_file_text_callback(callback) bind(c, name='SetSaveFileTextCallback') - import :: c_funptr - implicit none - type(c_funptr), intent(in), value :: callback - end subroutine set_save_file_text_callback - - ! void SetShaderValue(Shader shader, int locIndex, const void *value, int uniformType) - subroutine set_shader_value(shader, loc_index, value, uniform_type) bind(c, name='SetShaderValue') - import :: c_int, c_ptr, shader_type - implicit none - type(shader_type), intent(in), value :: shader - integer(kind=c_int), intent(in), value :: loc_index - type(c_ptr), intent(in), value :: value - integer(kind=c_int), intent(in), value :: uniform_type - end subroutine set_shader_value - - ! void SetShaderValueMatrix(Shader shader, int locIndex, Matrix mat) - subroutine set_shader_value_matrix(shader, loc_index, mat) bind(c, name='SetShaderValueMatrix') - import :: c_int, matrix_type, shader_type - implicit none - type(shader_type), intent(in), value :: shader - integer(kind=c_int), intent(in), value :: loc_index - type(matrix_type), intent(in), value :: mat - end subroutine set_shader_value_matrix - - ! void SetShaderValueTexture(Shader shader, int locIndex, Texture2D texture) - subroutine set_shader_value_texture(shader, loc_index, texture) bind(c, name='SetShaderValueTexture') - import :: c_int, shader_type, texture2d_type - implicit none - type(shader_type), intent(in), value :: shader - integer(kind=c_int), intent(in), value :: loc_index - type(texture2d_type), intent(in), value :: texture - end subroutine set_shader_value_texture - - ! void SetShaderValueV(Shader shader, int locIndex, const void *value, int uniformType, int count) - subroutine set_shader_value_v(shader, loc_index, value, uniform_type, count) bind(c, name='SetShaderValueV') - import :: c_int, c_ptr, shader_type - implicit none - type(shader_type), intent(in), value :: shader - integer(kind=c_int), intent(in), value :: loc_index - type(c_ptr), intent(in), value :: value - integer(kind=c_int), intent(in), value :: uniform_type - integer(kind=c_int), intent(in), value :: count - end subroutine set_shader_value_v - - ! void SetShapesTexture(Texture2D texture, Rectangle source) - subroutine set_shapes_texture(texture, source) bind(c, name='SetShapesTexture') - import :: rectangle_type, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(rectangle_type), intent(in), value :: source - end subroutine set_shapes_texture - - ! void SetSoundPan(Sound sound, float pan) - subroutine set_sound_pan(sound, pan) bind(c, name='SetSoundPan') - import :: c_float, sound_type - implicit none - type(sound_type), intent(in), value :: sound - real(kind=c_float), intent(in), value :: pan - end subroutine set_sound_pan - - ! void SetSoundPitch(Sound sound, float pitch) - subroutine set_sound_pitch(sound, pitch) bind(c, name='SetSoundPitch') - import :: c_float, sound_type - implicit none - type(sound_type), intent(in), value :: sound - real(kind=c_float), intent(in), value :: pitch - end subroutine set_sound_pitch - - ! void SetSoundVolume(Sound sound, float volume) - subroutine set_sound_volume(sound, volume) bind(c, name='SetSoundVolume') - import :: c_float, sound_type - implicit none - type(sound_type), intent(in), value :: sound - real(kind=c_float), intent(in), value :: volume - end subroutine set_sound_volume - - ! void SetTargetFPS(int fps) - subroutine set_target_fps(fps) bind(c, name='SetTargetFPS') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: fps - end subroutine set_target_fps - - ! void SetTextLineSpacing(int spacing) - subroutine set_text_line_spacing(spacing) bind(c, name='SetTextLineSpacing') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: spacing - end subroutine set_text_line_spacing - - ! void SetTextureFilter(Texture2D texture, int filter) - subroutine set_texture_filter(texture, filter) bind(c, name='SetTextureFilter') - import :: c_int, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - integer(kind=c_int), intent(in), value :: filter - end subroutine set_texture_filter - - ! void SetTextureWrap(Texture2D texture, int wrap) - subroutine set_texture_wrap(texture, wrap) bind(c, name='SetTextureWrap') - import :: c_int, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - integer(kind=c_int), intent(in), value :: wrap - end subroutine set_texture_wrap - - ! void SetTraceLogCallback(TraceLogCallback callback) - subroutine set_trace_log_callback(callback) bind(c, name='SetTraceLogCallback') - import :: c_funptr - implicit none - type(c_funptr), intent(in), value :: callback - end subroutine set_trace_log_callback - - ! void SetTraceLogLevel(int logLevel) - subroutine set_trace_log_level(log_level) bind(c, name='SetTraceLogLevel') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: log_level - end subroutine set_trace_log_level - - ! void SetWindowFocused(void) - subroutine set_window_focused() bind(c, name='SetWindowFocused') - end subroutine set_window_focused - - ! void SetWindowIcon(Image image) - subroutine set_window_icon(image) bind(c, name='SetWindowIcon') - import :: image_type - implicit none - type(image_type), intent(in), value :: image - end subroutine set_window_icon - - ! void SetWindowIcons(Image *images, int count) - subroutine set_window_icons(images, count) bind(c, name='SetWindowIcons') - import :: c_int, image_type - implicit none - type(image_type), intent(inout) :: images - integer(kind=c_int), intent(in), value :: count - end subroutine set_window_icons - - ! void SetWindowMaxSize(int width, int height) - subroutine set_window_max_size(width, height) bind(c, name='SetWindowMaxSize') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - end subroutine set_window_max_size - - ! void SetWindowMinSize(int width, int height) - subroutine set_window_min_size(width, height) bind(c, name='SetWindowMinSize') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - end subroutine set_window_min_size - - ! void SetWindowMonitor(int monitor) - subroutine set_window_monitor(monitor) bind(c, name='SetWindowMonitor') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: monitor - end subroutine set_window_monitor - - ! void SetWindowOpacity(float opacity) - subroutine set_window_opacity(opacity) bind(c, name='SetWindowOpacity') - import :: c_float - implicit none - real(kind=c_float), intent(in), value :: opacity - end subroutine set_window_opacity - - ! void SetWindowPosition(int x, int y) - subroutine set_window_position(x, y) bind(c, name='SetWindowPosition') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: x - integer(kind=c_int), intent(in), value :: y - end subroutine set_window_position - - ! void SetWindowSize(int width, int height) - subroutine set_window_size(width, height) bind(c, name='SetWindowSize') - import :: c_int - implicit none - integer(kind=c_int), intent(in), value :: width - integer(kind=c_int), intent(in), value :: height - end subroutine set_window_size - - ! void SetWindowState(unsigned int flags) - subroutine set_window_state(flags) bind(c, name='SetWindowState') - import :: c_unsigned_int - implicit none - integer(kind=c_unsigned_int), intent(in), value :: flags - end subroutine set_window_state - - ! void SetWindowTitle(const char *title) - subroutine set_window_title(title) bind(c, name='SetWindowTitle') - import :: c_char - implicit none - character(kind=c_char), intent(in) :: title - end subroutine set_window_title - - ! void ShowCursor(void) - subroutine show_cursor() bind(c, name='ShowCursor') - end subroutine show_cursor - - ! void StopAudioStream(AudioStream stream) - subroutine stop_audio_stream(stream) bind(c, name='StopAudioStream') - import :: audio_stream_type - implicit none - type(audio_stream_type), intent(in), value :: stream - end subroutine stop_audio_stream - - ! void StopMusicStream(Music music) - subroutine stop_music_stream(music) bind(c, name='StopMusicStream') - import :: music_type - implicit none - type(music_type), intent(in), value :: music - end subroutine stop_music_stream - - ! void StopSound(Sound sound) - subroutine stop_sound(sound) bind(c, name='StopSound') - import :: sound_type - implicit none - type(sound_type), intent(in), value :: sound - end subroutine stop_sound - - ! void SwapScreenBuffer(void) - subroutine swap_screen_buffer() bind(c, name='SwapScreenBuffer') - end subroutine swap_screen_buffer - - ! void TakeScreenshot(const char *fileName) - subroutine take_screenshot(file_name) bind(c, name='TakeScreenshot') - import :: c_char - implicit none - character(kind=c_char), intent(in) :: file_name - end subroutine take_screenshot - - ! void TextAppend(char *text, const char *append, int *position) - subroutine text_append(text, append, position) bind(c, name='TextAppend') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - character(kind=c_char), intent(in) :: append - integer(kind=c_int), intent(in) :: position - end subroutine text_append - - ! int TextCopy(char *dst, const char *src) - function text_copy(dst, src) bind(c, name='TextCopy') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: dst - character(kind=c_char), intent(in) :: src - integer(kind=c_int) :: text_copy - end function text_copy - - ! int TextFindIndex(const char *text, const char *find) - function text_find_index(text, find) bind(c, name='TextFindIndex') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - character(kind=c_char), intent(in) :: find - integer(kind=c_int) :: text_find_index - end function text_find_index - - ! char *TextInsert(const char *text, const char *insert, int position) - function text_insert(text, insert, position) bind(c, name='TextInsert') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - character(kind=c_char), intent(in) :: insert - integer(kind=c_int), intent(in), value :: position - type(c_ptr) :: text_insert - end function text_insert - - ! bool TextIsEqual(const char *text1, const char *text2) - function text_is_equal(text1, text2) bind(c, name='TextIsEqual') - import :: c_bool, c_char - implicit none - character(kind=c_char), intent(in) :: text1 - character(kind=c_char), intent(in) :: text2 - logical(kind=c_bool) :: text_is_equal - end function text_is_equal - - ! const char *TextJoin(const char **textList, int count, const char *delimiter) - function text_join(text_list, count, delimiter) bind(c, name='TextJoin') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: text_list(*) - integer(kind=c_int), intent(in), value :: count - character(kind=c_char), intent(in) :: delimiter - type(c_ptr) :: text_join - end function text_join - - ! unsigned int TextLength(const char *text) - function text_length(text) bind(c, name='TextLength') - import :: c_char, c_unsigned_int - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_unsigned_int) :: text_length - end function text_length - - ! char *TextReplace(char *text, const char *replace, const char *by) - function text_replace(text, replace, by) bind(c, name='TextReplace') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - character(kind=c_char), intent(in) :: replace - character(kind=c_char), intent(in) :: by - type(c_ptr) :: text_replace - end function text_replace - - ! const char **TextSplit(const char *text, char delimiter, int *count) - function text_split(text, delimiter, count) bind(c, name='TextSplit') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - character(kind=c_char), intent(in), value :: delimiter - integer(kind=c_int), intent(out) :: count - type(c_ptr) :: text_split - end function text_split - - ! const char *TextSubtext(const char *text, int position, int length) - function text_subtext(text, position, length) bind(c, name='TextSubtext') - import :: c_char, c_int, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int), intent(in), value :: position - integer(kind=c_int), intent(in), value :: length - type(c_ptr) :: text_subtext - end function text_subtext - - ! int TextToInteger(const char *text) - function text_to_integer(text) bind(c, name='TextToInteger') - import :: c_char, c_int - implicit none - character(kind=c_char), intent(in) :: text - integer(kind=c_int) :: text_to_integer - end function text_to_integer - - ! const char *TextToLower(const char *text) - function text_to_lower(text) bind(c, name='TextToLower') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - type(c_ptr) :: text_to_lower - end function text_to_lower - - ! const char *TextToPascal(const char *text) - function text_to_pascal(text) bind(c, name='TextToPascal') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - type(c_ptr) :: text_to_pascal - end function text_to_pascal - - ! const char *TextToUpper(const char *text) - function text_to_upper(text) bind(c, name='TextToUpper') - import :: c_char, c_ptr - implicit none - character(kind=c_char), intent(in) :: text - type(c_ptr) :: text_to_upper - end function text_to_upper - - ! void ToggleBorderlessWindowed(void) - subroutine toggle_borderless_windowed() bind(c, name='ToggleBorderlessWindowed') - end subroutine toggle_borderless_windowed - - ! void ToggleFullscreen(void) - subroutine toggle_fullscreen() bind(c, name='ToggleFullscreen') - end subroutine toggle_fullscreen - - ! void TraceLog(int logLevel, const char *text) - subroutine trace_log(log_level, text) bind(c, name='TraceLog') - import :: c_char, c_int - implicit none - integer(kind=c_int), intent(in), value :: log_level - character(kind=c_char), intent(in) :: text - end subroutine trace_log - - ! void UnloadAudioStream(AudioStream stream) - subroutine unload_audio_stream(stream) bind(c, name='UnloadAudioStream') - import :: audio_stream_type - implicit none - type(audio_stream_type), intent(in), value :: stream - end subroutine unload_audio_stream - - ! void UnloadCodepoints(int *codepoints) - subroutine unload_codepoints(codepoints) bind(c, name='UnloadCodepoints') - import :: c_int - implicit none - integer(kind=c_int), intent(inout) :: codepoints(*) - end subroutine unload_codepoints - - ! void UnloadDirectoryFiles(FilePathList files) - subroutine unload_directory_files(files) bind(c, name='UnloadDirectoryFiles') - import :: file_path_list_type - implicit none - type(file_path_list_type), intent(in), value :: files - end subroutine unload_directory_files - - ! void UnloadDroppedFiles(FilePathList files) - subroutine unload_dropped_files(files) bind(c, name='UnloadDroppedFiles') - import :: file_path_list_type - implicit none - type(file_path_list_type), intent(in), value :: files - end subroutine unload_dropped_files - - ! void UnloadFileData(unsigned char *data) - subroutine unload_file_data(data) bind(c, name='UnloadFileData') - import :: c_unsigned_char - implicit none - integer(kind=c_unsigned_char), intent(in) :: data - end subroutine unload_file_data - - ! void UnloadFileText(char *text) - subroutine unload_file_text(text) bind(c, name='UnloadFileText') - import :: c_char - implicit none - character(kind=c_char), intent(in) :: text - end subroutine unload_file_text - - ! void UnloadFont(Font font) - subroutine unload_font(font) bind(c, name='UnloadFont') - import :: font_type - implicit none - type(font_type), intent(in), value :: font - end subroutine unload_font - - ! void UnloadFontData(GlyphInfo *glyphs, int glyphCount) - subroutine unload_font_data(glyphs, glyph_count) bind(c, name='UnloadFontData') - import :: c_int, glyph_info_type - implicit none - type(glyph_info_type), intent(inout) :: glyphs - integer(kind=c_int), intent(in), value :: glyph_count - end subroutine unload_font_data - - ! void UnloadImage(Image image) - subroutine unload_image(image) bind(c, name='UnloadImage') - import :: image_type - implicit none - type(image_type), intent(in), value :: image - end subroutine unload_image - - ! void UnloadImageColors(Color *colors) - subroutine unload_image_colors(colors) bind(c, name='UnloadImageColors') - import :: color_type - implicit none - type(color_type), intent(inout) :: colors(*) - end subroutine unload_image_colors - - ! void UnloadImagePalette(Color *colors) - subroutine unload_image_palette(colors) bind(c, name='UnloadImagePalette') - import :: color_type - implicit none - type(color_type), intent(inout) :: colors(*) - end subroutine unload_image_palette - - ! void UnloadMaterial(Material material) - subroutine unload_material(material) bind(c, name='UnloadMaterial') - import :: material_type - implicit none - type(material_type), intent(in), value :: material - end subroutine unload_material - - ! void UnloadMesh(Mesh mesh) - subroutine unload_mesh(mesh) bind(c, name='UnloadMesh') - import :: mesh_type - implicit none - type(mesh_type), intent(in), value :: mesh - end subroutine unload_mesh - - ! void UnloadModel(Model model) - subroutine unload_model(model) bind(c, name='UnloadModel') - import :: model_type - implicit none - type(model_type), intent(in), value :: model - end subroutine unload_model - - ! void UnloadModelAnimation(ModelAnimation anim) - subroutine unload_model_animation(anim) bind(c, name='UnloadModelAnimation') - import :: model_animation_type - implicit none - type(model_animation_type), intent(in), value :: anim - end subroutine unload_model_animation - - ! void UnloadModelAnimations(ModelAnimation *animations, int count) - subroutine unload_model_animations(animations, count) bind(c, name='UnloadModelAnimations') - import :: c_int, model_animation_type - implicit none - type(model_animation_type), intent(inout) :: animations(*) - integer(kind=c_int), intent(in), value :: count - end subroutine unload_model_animations - - ! void UnloadMusicStream(Music music) - subroutine unload_music_stream(music) bind(c, name='UnloadMusicStream') - import :: music_type - implicit none - type(music_type), intent(in), value :: music - end subroutine unload_music_stream - - ! void UnloadRandomSequence(int *sequence) - subroutine unload_random_sequence(sequence) bind(c, name='UnloadRandomSequence') - import :: c_int - implicit none - integer(kind=c_int), intent(inout) :: sequence(*) - end subroutine unload_random_sequence - - ! void UnloadRenderTexture(RenderTexture2D target) - subroutine unload_render_texture(target) bind(c, name='UnloadRenderTexture') - import :: render_texture2d_type - implicit none - type(render_texture2d_type), intent(in), value :: target - end subroutine unload_render_texture - - ! void UnloadShader(Shader shader) - subroutine unload_shader(shader) bind(c, name='UnloadShader') - import :: shader_type - implicit none - type(shader_type), intent(in), value :: shader - end subroutine unload_shader - - ! void UnloadSound(Sound sound) - subroutine unload_sound(sound) bind(c, name='UnloadSound') - import :: sound_type - implicit none - type(sound_type), intent(in), value :: sound - end subroutine unload_sound - - ! void UnloadSoundAlias(Sound alias) - subroutine unload_sound_alias(alias) bind(c, name='UnloadSoundAlias') - import :: sound_type - implicit none - type(sound_type), intent(in), value :: alias - end subroutine unload_sound_alias - - ! void UnloadTexture(Texture2D texture) - subroutine unload_texture(texture) bind(c, name='UnloadTexture') - import :: texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - end subroutine unload_texture - - ! void UnloadUTF8(char *text) - subroutine unload_utf8(text) bind(c, name='UnloadUTF8') - import :: c_char - implicit none - character(kind=c_char), intent(in) :: text - end subroutine unload_utf8 - - ! void UnloadVrStereoConfig(VrStereoConfig config) - subroutine unload_vr_stereo_config(config) bind(c, name='UnloadVrStereoConfig') - import :: vr_stereo_config_type - implicit none - type(vr_stereo_config_type), intent(in), value :: config - end subroutine unload_vr_stereo_config - - ! void UnloadWave(Wave wave) - subroutine unload_wave(wave) bind(c, name='UnloadWave') - import :: wave_type - implicit none - type(wave_type), intent(in), value :: wave - end subroutine unload_wave - - ! void UnloadWaveSamples(float *samples) - subroutine unload_wave_samples(samples) bind(c, name='UnloadWaveSamples') - import :: c_float - implicit none - real(kind=c_float), intent(inout) :: samples(*) - end subroutine unload_wave_samples - - ! void UpdateAudioStream(AudioStream stream, const void *data, int frameCount) - subroutine update_audio_stream(stream, data, frame_count) bind(c, name='UpdateAudioStream') - import :: audio_stream_type, c_int, c_ptr - implicit none - type(audio_stream_type), intent(in), value :: stream - type(c_ptr), intent(in), value :: data - integer(kind=c_int), intent(in), value :: frame_count - end subroutine update_audio_stream - - ! void UpdateCamera(Camera *camera, int mode) - subroutine update_camera(camera, mode) bind(c, name='UpdateCamera') - import :: camera3d_type, c_int - implicit none - type(camera3d_type), intent(inout) :: camera - integer(kind=c_int), intent(in), value :: mode - end subroutine update_camera - - ! void UpdateMeshBuffer(Mesh mesh, int index, const void *data, int dataSize, int offset) - subroutine update_mesh_buffer(mesh, index, data, data_size, offset) bind(c, name='UpdateMeshBuffer') - import :: c_int, c_ptr, mesh_type - implicit none - type(mesh_type), intent(in), value :: mesh - integer(kind=c_int), intent(in), value :: index - type(c_ptr), intent(in), value :: data - integer(kind=c_int), intent(in), value :: data_size - integer(kind=c_int), intent(in), value :: offset - end subroutine update_mesh_buffer - - ! void UpdateModelAnimation(Model model, ModelAnimation anim, int frame) - subroutine update_model_animation(model, anim, frame) bind(c, name='UpdateModelAnimation') - import :: c_int, model_animation_type, model_type - implicit none - type(model_type), intent(in), value :: model - type(model_animation_type), intent(in), value :: anim - integer(kind=c_int), intent(in), value :: frame - end subroutine update_model_animation - - ! void UpdateMusicStream(Music music) - subroutine update_music_stream(music) bind(c, name='UpdateMusicStream') - import :: music_type - implicit none - type(music_type), intent(in), value :: music - end subroutine update_music_stream - - ! void UpdateSound(Sound sound, const void *data, int sampleCount) - subroutine update_sound(sound, data, sample_count) bind(c, name='UpdateSound') - import :: c_int, c_ptr, sound_type - implicit none - type(sound_type), intent(in), value :: sound - type(c_ptr), intent(in), value :: data - integer(kind=c_int), intent(in), value :: sample_count - end subroutine update_sound - - ! void UpdateTexture(Texture2D texture, const void *pixels) - subroutine update_texture(texture, pixels) bind(c, name='UpdateTexture') - import :: c_ptr, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(c_ptr), intent(in), value :: pixels - end subroutine update_texture - - ! void UpdateTextureRec(Texture2D texture, Rectangle rec, const void *pixels) - subroutine update_texture_rec(texture, rec, pixels) bind(c, name='UpdateTextureRec') - import :: c_ptr, rectangle_type, texture2d_type - implicit none - type(texture2d_type), intent(in), value :: texture - type(rectangle_type), intent(in), value :: rec - type(c_ptr), intent(in), value :: pixels - end subroutine update_texture_rec - - ! void UploadMesh(Mesh *mesh, bool dynamic) - subroutine upload_mesh(mesh, dynamic) bind(c, name='UploadMesh') - import :: c_bool, mesh_type - implicit none - type(mesh_type), intent(inout) :: mesh - logical(kind=c_bool), intent(in), value :: dynamic - end subroutine upload_mesh - - ! void WaitTime(double seconds) - subroutine wait_time(seconds) bind(c, name='WaitTime') - import :: c_double - implicit none - real(kind=c_double), intent(in), value :: seconds - end subroutine wait_time - - ! Wave WaveCopy(Wave wave) - function wave_copy(wave) bind(c, name='WaveCopy') - import :: wave_type - implicit none - type(wave_type), intent(in), value :: wave - type(wave_type) :: wave_copy - end function wave_copy - - ! void WaveCrop(Wave *wave, int initSample, int finalSample) - subroutine wave_crop(wave, init_sample, final_sample) bind(c, name='WaveCrop') - import :: c_int, wave_type - implicit none - type(wave_type), intent(in) :: wave - integer(kind=c_int), intent(in), value :: init_sample - integer(kind=c_int), intent(in), value :: final_sample - end subroutine wave_crop - - ! void WaveFormat(Wave *wave, int sampleRate, int sampleSize, int channels) - subroutine wave_format(wave, sample_rate, sample_size, channels) bind(c, name='WaveFormat') - import :: c_int, wave_type - implicit none - type(wave_type), intent(in) :: wave - integer(kind=c_int), intent(in), value :: sample_rate - integer(kind=c_int), intent(in), value :: sample_size - integer(kind=c_int), intent(in), value :: channels - end subroutine wave_format - - ! bool WindowShouldClose(void) - function window_should_close() bind(c, name='WindowShouldClose') - import :: c_bool - implicit none - logical(kind=c_bool) :: window_should_close - end function window_should_close - end interface -contains - elemental real function deg2rad(d) result(r) - real, intent(in) :: d - - r = d * (PI / 180.0) - end function deg2rad - - elemental real function rad2deg(r) result(d) - real, intent(in) :: r - - d = r * (180.0 / PI) - end function rad2deg -end module Raylib diff --git a/src/modules/RealMatrix/CMakeLists.txt b/src/modules/RealMatrix/CMakeLists.txt deleted file mode 100644 index cfd218414..000000000 --- a/src/modules/RealMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/RealMatrix_Method.F90 -) diff --git a/src/modules/RealMatrix/src/RealMatrix_Method.F90 b/src/modules/RealMatrix/src/RealMatrix_Method.F90 deleted file mode 100644 index 79fdc3b4c..000000000 --- a/src/modules/RealMatrix/src/RealMatrix_Method.F90 +++ /dev/null @@ -1,1360 +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: 6 March 2021 -! summary: This module contains methods for [[RealMatrix_]] data type - -MODULE RealMatrix_Method -USE GlobalData -USE BaSetype -IMPLICIT NONE -PRIVATE - -PUBLIC :: Shape -PUBLIC :: Size -PUBLIC :: TotalDimension -PUBLIC :: SetTotalDimension -PUBLIC :: ALLOCATE -PUBLIC :: DEALLOCATE -PUBLIC :: Initiate -PUBLIC :: RealMatrix -PUBLIC :: Eye -PUBLIC :: Convert -PUBLIC :: RealMatrix_Pointer -PUBLIC :: SYM -PUBLIC :: SkewSym -PUBLIC :: MakeDiagonalCopies -PUBLIC :: RANDOM_NUMBER -PUBLIC :: TestMatrix -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: GetPointer -PUBLIC :: Copy -PUBLIC :: Get -PUBLIC :: Display -PUBLIC :: LinearSolver_CG -PUBLIC :: Matmul -PUBLIC :: Set -PUBLIC :: Add - -!---------------------------------------------------------------------------- -! Shape@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Return Shape of [[RealMatrix_]] -! -!# Introduction -! -! This function return Shape of [[RealMatrix_]] -! -!### Usage -! -! ```fortran -! s = Shape( obj ) -! ``` - -INTERFACE Shape - MODULE PURE FUNCTION Get_Shape(obj) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - INTEGER(I4B) :: Ans(2) - END FUNCTION Get_Shape -END INTERFACE Shape - -!---------------------------------------------------------------------------- -! Size@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Return size of [[RealMatrix_]] -! -!# Introduction -! -! This function return size of `RealMatrix_` -! - If `Dims` is present and equal to 1 then total number of rows (m) -! - If `Dims` is present and equal to 2 then total number of cols (n) -! - If `Dimes` is absent then Ans = m * n -! -!### Usage -! -!```fortran -! trow = SIZE( obj, 1 ) -! tcol = SIZE( obj, 2 ) -! t = SIZE( obj ) -!``` - -INTERFACE Size - MODULE PURE FUNCTION Get_size(obj, Dims) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims - INTEGER(I4B) :: Ans - END FUNCTION Get_size -END INTERFACE Size - -!---------------------------------------------------------------------------- -! TotalDimension@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Returns the total dimension of an array -! -!# Introduction -! -! This function returns the total dimension (or rank) of an array, - -INTERFACE TotalDimension - MODULE PURE FUNCTION Get_tdimension(obj) RESULT(Ans) - CLASS(RealMatrix_), INTENT(IN) :: obj - INTEGER(I4B) :: Ans - END FUNCTION Get_tdimension -END INTERFACE TotalDimension - -!---------------------------------------------------------------------------- -! SetTotalDimension@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine Set the total dimension (rank) of an array -! -!# Introduction -! -! This subroutine Sets the rank(total dimension) of an array - -INTERFACE SetTotalDimension - MODULE PURE SUBROUTINE Set_tdimension(obj, tDimension) - CLASS(RealMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tDimension - END SUBROUTINE Set_tdimension -END INTERFACE SetTotalDimension - -!---------------------------------------------------------------------------- -! Allocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine allocate memory for [[RealMatrix_]] -! -! -!### Usage -! -! ```fortran -! call Allocate( obj, Dims ) -! ``` - -INTERFACE ALLOCATE - MODULE PURE SUBROUTINE Allocate_Data(obj, Dims) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Dims(2) - END SUBROUTINE Allocate_Data -END INTERFACE ALLOCATE - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Deallocate data in [[RealMatrix_]] -! -!# Introduction -! -! This routine deallocates data stored in obj -! -!### Usage -! -! ```fortran -! call Deallocate( obj ) -! ``` - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE Deallocate_Data(obj) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - END SUBROUTINE Deallocate_Data -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine Initiate `obj` with Shape `Dims` -! -!### Usage -! -!```fortran -! call Initiate( obj, [2,3] ) -!``` -! The above call will Initiate a matrix of Shape (2,3) - -INTERFACE Initiate - MODULE PURE SUBROUTINE realmat_Initiate1(obj, Dims) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Dims(2) - END SUBROUTINE realmat_Initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine Initiate `obj` with Shape `Dims` -! -!### Usage -! -!```fortran -! call Initiate( obj, [2,3] ) -!``` -! The above call will Initiate a matrix of Shape (2,3) - -INTERFACE Initiate - MODULE PURE SUBROUTINE realmat_Initiate2(obj, nrow, ncol) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nrow - INTEGER(I4B), INTENT(IN) :: ncol - END SUBROUTINE realmat_Initiate2 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Initiate vector of [[realmatrix_]] with Shape `Dims` -! -!### Usage -! -!```fortran -! type( realmatrix_ ) :: obj( 4 ) -! call Initiate( obj, [2,3] ) -!``` -! The above call will Initiate `obj` vector of matrices of Shape (2,3) - -INTERFACE Initiate - MODULE PURE SUBROUTINE realmat_Initiate3(obj, Dims) - TYPE(RealMatrix_), INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: Dims(2) - END SUBROUTINE realmat_Initiate3 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Initiate an instance of [[RealMatrix_]] -! -!# Introduction -! -! This subroutine Initiate vector of [[realmatrix_]] with matrices of -! different Shapes given in `Dims` -! - `Dims` has two columns; the first column denotes the number of rows, and -! second column denotes the number of columns in a matrix -! - irow of `Dims` corresponds to the Shape of `obj(irow)` -! - in this way `SIZE(obj)` should be equal to the SIZE(Dims, 1) -! -!### Usage -! -!```fortran -! type( realmatrix_ ) :: obj( 3 ) -! integer( i4b ) :: Dims( 3, 2 ) -! -! Dims( 1, : ) = [2,2] -! Dims( 2, : ) = [4,4] -! Dims( 3, : ) = [4,4] -! call Initiate( obj, Dims ) -!``` -! -! - The above call will Initiate a obj( 1 ) with Shape (2,2) -! - The above call will Initiate a obj( 2 ) with Shape (4,4) -! - The above call will Initiate a obj( 3 ) with Shape (4,4) - -INTERFACE Initiate - MODULE PURE SUBROUTINE realmat_Initiate4(obj, Dims) - TYPE(RealMatrix_), INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: Dims(:, :) - END SUBROUTINE realmat_Initiate4 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine performs `obj%l = Val` -! -!### Usage -! -! ```fortran -! call Initiate( obj, val ) -! ``` - -INTERFACE Initiate - MODULE PURE SUBROUTINE realmat_Initiate5(obj, Val) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :) - END SUBROUTINE realmat_Initiate5 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE realmat_Initiate5 -END INTERFACE - -!---------------------------------------------------------------------------- -! Matrix@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Constructor function for [[RealMatrix_]] -! -!# Introduction -! -! This function returns an instance of [[realmatrix_]] -! -!### Usage -! -!```fortran -! obj = RealMatrix( [2,2] ) -!``` - -INTERFACE RealMatrix - MODULE PURE FUNCTION Constructor1(Dims) RESULT(obj) - TYPE(RealMatrix_) :: obj - INTEGER(I4B), INTENT(IN) :: Dims(2) - END FUNCTION Constructor1 -END INTERFACE RealMatrix - -!---------------------------------------------------------------------------- -! Eye@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-11-04 -! summary: Return identity matrix of type [[realmatrix_]] -! -!# Introduction -! -! This function returns identity matrix of type [[realmatrix_]] -! -!### Usage -! -! ```fortran -! obj = eye( 3, typeRealMatrix ) -! ``` - -INTERFACE - - MODULE PURE FUNCTION realMat_eye1(m, dataType) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: m - TYPE(RealMatrix_), INTENT(IN) :: dataType - TYPE(RealMatrix_) :: Ans - END FUNCTION realMat_eye1 -END INTERFACE - -INTERFACE Eye - MODULE PROCEDURE realMat_eye1 -END INTERFACE Eye - -!---------------------------------------------------------------------------- -! Convert@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Rearrange the dofs in finite element matrix -! -!# Introduction -! -! This subroutine changes the storage pattern of a two-d matrix -! - Usually element matrix in easifem are stored in `FMT_DOF` -! - Global matrices/tanmat, however, are stored in `FMT_Nodes` -! - This subroutine is, therefore, in Settings or Adding values in -! [[SparseMatrix_]]. -! -! > This subroutine converts changes the storage format of dense matrix. -! Usually, elemental finite element matrix is stored in `DOF_FMT`, and global -! matrix/ tanmat, may be stored in `Nodes_FMT`. -! - -INTERFACE Convert - MODULE PURE SUBROUTINE realmat_convert_1(From, To, Conversion, & - & nns, tdof) - TYPE(RealMatrix_), INTENT(IN) :: From - !! Matrix in one format - TYPE(RealMatrix_), INTENT(INOUT) :: To - !! Matrix in one format - INTEGER(I4B), INTENT(IN) :: Conversion - !! `Conversion` can be `NodesToDOF` or `DOFToNodes` - INTEGER(I4B), INTENT(IN) :: nns, tdof - END SUBROUTINE realmat_convert_1 -END INTERFACE Convert - -!---------------------------------------------------------------------------- -! Matrix_Pointer@ConstructorMethods -!---------------------------------------------------------------------------- - -INTERFACE RealMatrix_Pointer - MODULE PURE FUNCTION Constructor_1(Dims) RESULT(obj) - CLASS(RealMatrix_), POINTER :: obj - INTEGER(I4B), INTENT(IN) :: Dims(2) - END FUNCTION Constructor_1 -END INTERFACE RealMatrix_Pointer - -!---------------------------------------------------------------------------- -! Sym@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Return sym(obj) = 0.5*(obj + transpose( obj ) ) -! -!# Introduction -! -! Return symmetric part of obj -! -!### Usage -! -! ```fortran -! realMat = Sym( obj ) -! ``` - -INTERFACE Sym - MODULE PURE FUNCTION sym_obj(obj) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - !! Real matrix - TYPE(RealMatrix_) :: Ans - !! Symmetric real matrix - END FUNCTION sym_obj -END INTERFACE Sym - -!---------------------------------------------------------------------------- -! Sym@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Return sym(obj) = 0.5*(obj + transpose( obj ) ) -! -!# Introduction -! -! Return symmetric part of obj -! -!### Usage -! -!```fortran -! realMat = Sym( obj ) -!``` - -INTERFACE Sym - MODULE PURE FUNCTION sym_array(obj) RESULT(Ans) - REAL(DFP), INTENT(IN) :: obj(:, :) - !! Two dimensiona array - REAL(DFP) :: Ans(SIZE(obj, 1), SIZE(obj, 2)) - !! Symmetric array - END FUNCTION sym_array -END INTERFACE Sym - -!---------------------------------------------------------------------------- -! SkewSym@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Return SkewSymmetric part of obj -! -!### Usage -! -!```fortran -! realMat = SkewSym( obj ) -!``` - -INTERFACE SkewSym - MODULE PURE FUNCTION SkewSym_obj(obj) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - !! Real matrix - TYPE(RealMatrix_) :: Ans - !! SkewSymmetric real matrix - END FUNCTION SkewSym_obj -END INTERFACE SkewSym - -!---------------------------------------------------------------------------- -! SkewSym@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Return SkewSym(obj) = 0.5*(obj + transpose( obj ) ) -! -!# Introduction -! -! Return SkewSymmetric part of obj -! -!### Usage -! -!```fortran -! realMat = SkewSym( obj ) -!``` - -INTERFACE SkewSym - MODULE PURE FUNCTION SkewSym_array(obj) RESULT(Ans) - REAL(DFP), INTENT(IN) :: obj(:, :) - !! Two dimensiona array - REAL(DFP) :: Ans(SIZE(obj, 1), SIZE(obj, 2)) - !! SkewSymmetric array - END FUNCTION SkewSym_array -END INTERFACE SkewSym - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Make diagonal copies of Matrix -! -!# Introduction -! -! This subroutine makes `nCopy` diagonal copies of `Mat` The size of `Mat` on -! return is nCopy * SIZE( Mat, 1 ) -! -!### Usage -! -!```fortran -! call MakeDiagonalCopies( Mat, nCopy ) -!``` - -INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy1(Mat, nCopy) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy1 -END INTERFACE MakeDiagonalCopies - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Make diagonal copies of Matrix -! -! This subroutine makes `nCopy` diagonal copies of `Mat` -! -!### Usage -! -!```fortran -! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy ) -!``` - -INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy2(From, To, nCopy) - REAL(DFP), INTENT(IN) :: From(:, :) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy2 -END INTERFACE MakeDiagonalCopies - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Make diagonal copies of [[realmatrix_]] -! -! This subroutine makes `nCopy` diagonal copies of `Mat`, The size of `Mat` -! on return is nCopy * SIZE( Mat, 1 ) -! -!### Usage -! -!```fortran -! call MakeDiagonalCopies( Mat, nCopy ) -!``` - -INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy3(Mat, nCopy) - TYPE(RealMatrix_), INTENT(INOUT) :: Mat - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy3 -END INTERFACE MakeDiagonalCopies - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Make diagonal copies of Matrix -! -!# Introduction -! -! This subroutine makes `nCopy` diagonal copies of `Mat` -! -!### Usage -! -!```fortran -! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy ) -!``` - -INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy4(From, To, nCopy) - TYPE(RealMatrix_), INTENT(IN) :: From - TYPE(RealMatrix_), INTENT(INOUT) :: To - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy4 -END INTERFACE MakeDiagonalCopies - -!---------------------------------------------------------------------------- -! Random_number@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Set a values in [[realmatrix_]] obj to random values -! -!# Introduction -! -! This subroutine Set values in `obj%Val` to random -! - This subroutine calls `RANDOM_NUMBER()` function from Fortran - -INTERFACE Random_number - MODULE SUBROUTINE realmat_random_number(obj, m, n) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - INTEGER(I4B), OPTIONAL, INTENT(IN) :: m, n - END SUBROUTINE realmat_random_number -END INTERFACE Random_number - -!---------------------------------------------------------------------------- -! TestMatrix@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 7 March 2021 -! summary: This function returns the example matrix - -INTERFACE - MODULE FUNCTION TestMatrix(matNo) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: matNo - REAL(DFP), ALLOCATABLE :: Ans(:, :) - END FUNCTION TestMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns the values of [[RealMatrix_]] obj in 2D array -! -!# Introduction -! -! This function returns the value stored in `obj%l` in a 2D fortran array -! -!### Usage -! -!```fortran -! Val = Get( obj, 1.0_dfp ) -!``` - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get1(obj, dataType) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: dataType - REAL(DFP), ALLOCATABLE :: Ans(:, :) - END FUNCTION realmat_Get1 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns the values of [[RealMatrix_]] obj in 2D array -! -!# Introduction -! -! This function returns the value stored in `obj%l` in a 2D fortran array -! -!### Usage -! -!```fortran -! Val = Get( obj, 1.0_dfp ) -!``` - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get1b(obj) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE :: Ans(:, :) - END FUNCTION realmat_Get1b -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns the values of [[RealMatrix_]] obj in 2D array -! -!# Introduction -! -! This function returns a section of `obj%l` in a 2D fortran array. This -! is equivalent to `Val = obj%l(RIndx, CIndx)` -! -!### Usage -! -!```fortran -! integer( i4b ) :: r( 2 ), c( 2 ) -! type( RealMatrix_ ) :: obj -! call Initiate( obj, [4,4] ) -! call random_number( obj ); r=[1,2]; c=[2,3] -! Val = Get( obj, R, C, 1.0_dfp ) -!``` -! -! The above call will return `obj%Val[1:2, 2:3]` - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get2(obj, RIndx, CIndx, dataType) & - & RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: RIndx(:), CIndx(:) - REAL(DFP), INTENT(IN) :: dataType - REAL(DFP), ALLOCATABLE :: Ans(:, :) - END FUNCTION realmat_Get2 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns the values of [[RealMatrix_]] obj in 2D array -! -!# Introduction -! -! This function returns a section of `obj%l` in a 2D fortran array. This -! is equivalent to `Val = obj%l(is:ie:s, is:ie:s)` -! -!### Usage -! -!```fortran -! integer( i4b ) :: r( 2 ), c( 2 ) -! type( RealMatrix_ ) :: obj -! call Initiate( obj, [4,4] ) -! call random_number( obj ) -! Val = Get( obj, 1, 2, 1, 1.0_dfp ) -!``` -! -! The above call will return `obj%Val[1:2:1, 1:2:1]` - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get3(obj, iStart, iEnd, Stride, & - & dataType) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - REAL(DFP), INTENT(IN) :: dataType - REAL(DFP), ALLOCATABLE :: Ans(:, :) - END FUNCTION realmat_Get3 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns [[RealMatrix_]] obj from [[realmatrix_]] - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get4(obj, dataType) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - TYPE(RealMatrix_), INTENT(IN) :: dataType - TYPE(RealMatrix_) :: Ans - END FUNCTION realmat_Get4 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns [[RealMatrix_]] obj from a section of [[realmatrix_]] -! -!# Introduction -! -! This function is essentially Copy method `Ans=obj(RIndx, CIndx)` - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get5(obj, RIndx, CIndx, dataType) & - & RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: RIndx(:), CIndx(:) - TYPE(RealMatrix_), INTENT(IN) :: dataType - TYPE(RealMatrix_) :: Ans - END FUNCTION realmat_Get5 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns [[RealMatrix_]] obj from a section of [[realmatrix_]] -! -!# Introduction -! This function is essentially Copy method `Ans=obj(is:ie, is:ie)` - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get6(obj, iStart, iEnd, & - & Stride, dataType) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - TYPE(RealMatrix_), INTENT(IN) :: dataType - TYPE(RealMatrix_) :: Ans - END FUNCTION realmat_Get6 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns values in 2D fortran array from [[realmatrix_]] -! -!# Introduction -! -! This function combines all [[realmatrix_]] value of `obj` and -! returns a 2D fortrn array - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get7(obj, dataType) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj(:, :) - REAL(DFP), INTENT(IN) :: dataType - REAL(DFP), ALLOCATABLE :: Ans(:, :) - END FUNCTION realmat_Get7 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns [[realmatrix_]] object from a 2D array of [[realmatrix_]] -! -!# Introduction -! -! This function combines all [[realmatrix_]] value of `obj` and -! returns a [[realmatrix_]] object - -INTERFACE Get - MODULE PURE FUNCTION realmat_Get8(obj, dataType) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj(:, :) - TYPE(RealMatrix_), INTENT(IN) :: dataType - TYPE(RealMatrix_) :: Ans - END FUNCTION realmat_Get8 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Copy@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Copy from [[realmatrix_]] to 2D fortran array -! -!# Introduction -! -! This subroutine Copy the contents of [[realmatrix_]] object into a 2D -! fortran array - -INTERFACE Copy - MODULE PURE SUBROUTINE realmat_Copy1(From, To) - TYPE(RealMatrix_), INTENT(IN) :: From - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) - END SUBROUTINE realmat_Copy1 -END INTERFACE Copy - -INTERFACE Convert - MODULE PROCEDURE realmat_Copy1 -END INTERFACE Convert - -!---------------------------------------------------------------------------- -! Copy@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Copy from RealMatrix to another RealMatrix -! -!# Introduction -! -! This subroutine Copy the contents of RealMatrix object to another -! RealMatrix object - -INTERFACE Copy - MODULE PURE SUBROUTINE realmat_Copy2(From, To) - TYPE(RealMatrix_), INTENT(IN) :: From - TYPE(RealMatrix_), INTENT(INOUT) :: To - END SUBROUTINE realmat_Copy2 -END INTERFACE Copy - -INTERFACE Convert - MODULE PROCEDURE realmat_Copy2 -END INTERFACE Convert - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE realmat_Copy2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Copy@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Copy from 2D fortran array to RealMatrix -! -!# Introduction -! -! This subroutine Copy the contents of a 2D fortran array to RealMatrix -! object - -INTERFACE Copy - MODULE PURE SUBROUTINE realmat_Copy3(From, To) - REAL(DFP), INTENT(IN) :: From(:, :) - TYPE(RealMatrix_), INTENT(INOUT) :: To - END SUBROUTINE realmat_Copy3 -END INTERFACE Copy - -INTERFACE Convert - MODULE PROCEDURE realmat_Copy3 -END INTERFACE Convert - -!---------------------------------------------------------------------------- -! ArrayPointer@GetValuesMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Get pointer to the values stored inside [[realmatrix_]] -! -!# Introduction -! -! This function returns the pointer to the values stored inside the -! [[realmatrix_]] - -INTERFACE GetPointer - MODULE FUNCTION realmat_GetPointer(obj, dataType) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN), TARGET :: obj - REAL(DFP), INTENT(IN) :: dataType - REAL(DFP), POINTER :: Ans(:, :) - END FUNCTION realmat_GetPointer -END INTERFACE GetPointer - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Display content of [[realmatrix_]] - -INTERFACE Display - MODULE SUBROUTINE realmat_Display1(obj, Msg, UnitNo) - TYPE(RealMatrix_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: Msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - END SUBROUTINE realmat_Display1 -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Display content of [[realmatrix_]] - -INTERFACE Display - MODULE SUBROUTINE realmat_Display2(obj, Msg, UnitNo) - TYPE(RealMatrix_), INTENT(IN) :: obj(:) - CHARACTER(*), INTENT(IN) :: Msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - END SUBROUTINE realmat_Display2 -END INTERFACE Display - -!---------------------------------------------------------------------------- -! CG@IterativeSolverMethods -!---------------------------------------------------------------------------- - -INTERFACE LinearSolver_CG - MODULE PURE SUBROUTINE realmat_CG_1(mat, rhs, sol, maxIter, & - & rtol, atol, convergenceIn, relativeToRHS, & - & restartAfter) - REAL(DFP), INTENT(IN) :: mat(:, :) - !! Symmetric matrix - REAL(DFP), INTENT(IN) :: rhs(:) - REAL(DFP), INTENT(INOUT) :: sol(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter - !! maximum number of iteration - !! if maxIter < 0 then maxIter=infinite - !! if maxIter is absent then min( size(mat,1), 10 ) - REAL(DFP), OPTIONAL, INTENT(IN) :: rtol - !! relative tolerance, default is 1.0E-6 - REAL(DFP), OPTIONAL, INTENT(IN) :: atol - !! absolute tolerance, default is 0.0 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: convergenceIn - !! convergenceInRes <-- default - !! convergenceInSol - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: relativeToRHS - !! FALSE <--- relative converfence is checked with respect to ||res|| - !! TRUE Convergence is checked with respect to ||rhs|| - INTEGER(I4B), OPTIONAL, INTENT(IN) :: restartAfter - !! recompute residual by using b-Ax - END SUBROUTINE realmat_CG_1 -END INTERFACE LinearSolver_CG - -!---------------------------------------------------------------------------- -! MatMul@MatrixMultiplication -!---------------------------------------------------------------------------- - -INTERFACE Matmul - MODULE PURE FUNCTION realmat_MatMul1(obj1, obj2) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj1, obj2 - TYPE(RealMatrix_) :: Ans - END FUNCTION realmat_MatMul1 -END INTERFACE Matmul - -!---------------------------------------------------------------------------- -! MatMul@MatrixMultiplication -!---------------------------------------------------------------------------- - -INTERFACE Matmul - MODULE PURE FUNCTION realmat_MatMul2(obj, Vec) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Vec(:) - REAL(DFP), ALLOCATABLE :: Ans(:) - END FUNCTION realmat_MatMul2 -END INTERFACE Matmul - -!---------------------------------------------------------------------------- -! MatMul@MatrixMultiplication -!---------------------------------------------------------------------------- - -INTERFACE Matmul - MODULE PURE FUNCTION realmat_MatMul3(obj, Vec) RESULT(Ans) - TYPE(RealMatrix_), INTENT(IN) :: obj - TYPE(RealVector_), INTENT(IN) :: Vec - TYPE(RealVector_) :: Ans - END FUNCTION realmat_MatMul3 -END INTERFACE Matmul - -!---------------------------------------------------------------------------- -! SetValues@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Add values in [[realmatrix_]] -! -!# Introduction -! -! This subroutine Set `obj%val` to `Val` - -INTERFACE Set - MODULE PURE SUBROUTINE realmat_Set_1(obj, Val) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :) - END SUBROUTINE realmat_Set_1 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! SetValues@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Set values in [[realmatrix_]] - -!> author: Dr. Vikas Sharma -! -! This subroutine Set values in `obj%l` -! `obj%l( i, j ) = Val` - -INTERFACE Set - MODULE PURE SUBROUTINE realmat_Set_2(obj, Val, Row, Col) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - INTEGER(I4B), INTENT(IN) :: Col, Row - END SUBROUTINE realmat_Set_2 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! SetValues@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Set values in [[realmatrix_]] -! -!# Introduction -! -! This subroutine Set values in `obj%l` -! - -INTERFACE Set - MODULE PURE SUBROUTINE realmat_Set_3(obj, Val, Row, Col) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :) - INTEGER(I4B), INTENT(IN) :: Col(:), Row(:) - END SUBROUTINE realmat_Set_3 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! SetValues@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Set values in [[realmatrix_]] -! -!# Introduction -! -! This subroutine Set values in `obj%l` -! - If `ExtraOption=MATRIX_DIAGONAL` then diagonal values are Set; and `Indx` -! denotes diagonal number with `0` being the main diagonal -! - If `Extraoption=MATRIX_ROW` then row values are Set; `Indx` then denotes -! row number -! - If `Extraoption=MATRIX_COLUMN` then col values are Set; `Indx` then -! denotes col number - -INTERFACE Set - MODULE PURE SUBROUTINE realmat_Set_4(obj, Val, Indx, ExtraOption) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: Indx - INTEGER(I4B), INTENT(IN) :: ExtraOption - END SUBROUTINE realmat_Set_4 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! SetValues@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Set values in [[realmatrix_]] -! -!# Introduction -! -! This subroutine Set values in `obj%l` -! - If `ExtraOption=MATRIX_DIAGONAL` then diagonal values are Set; and `Indx` -! denotes the diagonal number with `0` being the main diagonal -! - If `Extraoption=ROW` then row values are Set; `Indx` then denotes row -! number -! - If `Extraoption=COLUMN` then col values are Set; `Indx` then denotes col -! number - -INTERFACE Set - MODULE PURE SUBROUTINE realmat_Set_5(obj, Val, Indx, ExtraOption) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :) - INTEGER(I4B), INTENT(IN) :: Indx(:), ExtraOption - END SUBROUTINE realmat_Set_5 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! SetValues@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Add values in [[realmatrix_]] -! -!# Introduction -! -! This subroutine Set `obj%l` to `Val` - -INTERFACE Set - MODULE PURE SUBROUTINE realmat_Set_6(obj, Val) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - END SUBROUTINE realmat_Set_6 -END INTERFACE Set - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE realmat_Set_6 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! AddContribution@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Add contribution in values of [[realmatrix_]] -! -!# Introduction -! -! This subroutine Adds contribution in values of `obj%l`. This subroutine -! performs following task: -! -! $$obj = obj scale * val $$ -! -! Here `op` can be `+, -, *, /`. -! -!@todo -! Use Blas routines or OpenMP support? -!@endtodo - -INTERFACE Add - MODULE PURE SUBROUTINE realmat_Add_1(obj, Val, Scale, Op) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :) - REAL(DFP), INTENT(IN) :: Scale - !! Scaling for `Val` - CHARACTER(1), INTENT(IN) :: Op - !! operator symbol; `+, -, *, /` - END SUBROUTINE realmat_Add_1 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! AddContribution@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Add contribution in values of [[Realmatrix_]] -! -!# Introduction -! -! This subroutine Adds contribution in values of `obj%l` -! -!```fortran -! obj%l = obj%v%*Op* scale * val -!``` - -INTERFACE Add - MODULE PURE SUBROUTINE realmat_Add_2(obj, Val, Row, Col, Scale, Op) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val - REAL(DFP), INTENT(IN) :: Scale - INTEGER(I4B), INTENT(IN) :: Row - INTEGER(I4B), INTENT(IN) :: Col - CHARACTER(1), INTENT(IN) :: Op - END SUBROUTINE realmat_Add_2 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! AddContribution@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Add contribution in values of [[realmatrix_]] -! -!# Introduction -! -! This subroutine Adds contribution in values of `obj%l` -! -!```fortran -! obj%l = obj%v%*Op* scale * val -!``` - -INTERFACE Add - MODULE PURE SUBROUTINE realmat_Add_3(obj, Val, Row, Col, Scale, Op) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :) - REAL(DFP), INTENT(IN) :: Scale - INTEGER(I4B), INTENT(IN) :: Row(:) - INTEGER(I4B), INTENT(IN) :: Col(:) - CHARACTER(1), INTENT(IN) :: Op - END SUBROUTINE realmat_Add_3 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! AddContribution@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Add contribution in values of [[Realmatrix_]] -! -!# Introduction -! -! This subroutine Adds contribution in values of `obj%l` -! -! ```fortran -! obj%l = obj%v%*Op* scale * val -! ``` - -INTERFACE Add - MODULE PURE SUBROUTINE realmat_Add_4(obj, Val, Indx, ExtraOption, Scale, Op) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:), Scale - INTEGER(I4B), INTENT(IN) :: Indx - INTEGER(I4B), INTENT(IN) :: ExtraOption - CHARACTER(1), INTENT(IN) :: Op - END SUBROUTINE realmat_Add_4 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! AddContribution@SetValues -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Add contribution in values of [[realmatrix_]] -! -!# Introduction -! -! This subroutine Adds contribution in values of `obj%l` -! -!```fortran -! obj%l = obj%v%*Op* scale * val -!``` - -INTERFACE Add - MODULE PURE SUBROUTINE realmat_Add_5(obj, Val, Indx, ExtraOption, & - & Scale, Op) - TYPE(RealMatrix_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:, :), Scale - INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(I4B), INTENT(IN) :: ExtraOption - CHARACTER(1), INTENT(IN) :: Op - END SUBROUTINE realmat_Add_5 -END INTERFACE Add - -END MODULE RealMatrix_Method diff --git a/src/modules/RealVector/CMakeLists.txt b/src/modules/RealVector/CMakeLists.txt deleted file mode 100644 index 0389b0111..000000000 --- a/src/modules/RealVector/CMakeLists.txt +++ /dev/null @@ -1,35 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/RealVector_Method.F90 - ${src_path}/RealVector_AddMethods.F90 - ${src_path}/RealVector_AppendMethods.F90 - ${src_path}/RealVector_AssignMethods.F90 - ${src_path}/RealVector_Blas1Methods.F90 - ${src_path}/RealVector_ComparisonMethods.F90 - ${src_path}/RealVector_ConstructorMethods.F90 - ${src_path}/RealVector_GetMethods.F90 - ${src_path}/RealVector_GetValueMethods.F90 - ${src_path}/RealVector_IOMethods.F90 - ${src_path}/RealVector_Norm2ErrorMethods.F90 - ${src_path}/RealVector_Norm2Methods.F90 - ${src_path}/RealVector_SetMethods.F90 - ${src_path}/RealVector_ShallowCopyMethods.F90 -) diff --git a/src/modules/RealVector/src/RealVector_AddMethods.F90 b/src/modules/RealVector/src/RealVector_AddMethods.F90 deleted file mode 100644 index 9ee9b14dc..000000000 --- a/src/modules/RealVector/src/RealVector_AddMethods.F90 +++ /dev/null @@ -1,717 +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 RealVector_AddMethods -USE GlobalData, ONLY: DFP, I4B -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Add all values to given scalar -! -!# Introduction -! -!@note -! We call F77_AXPY in this method -!@endnote - -INTERFACE Add - MODULE SUBROUTINE obj_Add1(obj, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add1 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Add all values by given vector -! -!@note -! We call F95_AXPY in this method -!@endnote - -INTERFACE Add - MODULE SUBROUTINE obj_Add2(obj, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - !! obj = obj + scale*VALUE - REAL(DFP), INTENT(IN) :: VALUE(:) - !! Size of value should be equal to the size of obj - REAL(DFP), INTENT(IN) :: scale - !! scale - END SUBROUTINE obj_Add2 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Jan 2022 -! summary: Add selected values - -INTERFACE Add - MODULE SUBROUTINE obj_Add3(obj, nodenum, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add3 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add4(obj, nodenum, VALUE, scale) - TYPE(Realvector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add4 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Jan 2022 -! summary: Add selected values - -INTERFACE Add - MODULE SUBROUTINE obj_Add5(obj, nodenum, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add5 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Add range of values to a scalar -! -!@note -! We call F77_AXPY in this method -!@endnote - -INTERFACE Add - MODULE SUBROUTINE obj_Add6(obj, istart, iend, stride, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to be added - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - REAL(DFP), INTENT(IN) :: scale - !! scale - END SUBROUTINE obj_Add6 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Add range of values to a vector -! -!@note! -! We call F77_AXPY -!@endnote - -INTERFACE Add - MODULE SUBROUTINE obj_Add7(obj, istart, iend, stride, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add7 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add8(obj, dofobj, nodenum, VALUE, & - scale, conversion) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: conversion(1) - END SUBROUTINE obj_Add8 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add9(obj, dofobj, nodenum, VALUE, & - scale) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add9 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add10(obj, dofobj, nodenum, VALUE, & - scale, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add10 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add11(obj, dofobj, nodenum, VALUE, & - scale, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add11 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add12(obj, dofobj, nodenum, VALUE, & - scale, ivar, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add12 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add13(obj, dofobj, nodenum, VALUE, & - scale, ivar, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add13 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add14(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add14 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add15(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add15 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add16(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - END SUBROUTINE obj_Add16 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add17(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - END SUBROUTINE obj_Add17 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add18(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add18 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Add2]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add19(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add19 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add20(obj, dofobj, nodenum, VALUE, & - scale) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add20 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add21(obj, dofobj, nodenum, VALUE, & - scale, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add21 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add22(obj, dofobj, nodenum, VALUE, & - scale, ivar, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_Add22 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add23(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add23 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add24(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo(:) - END SUBROUTINE obj_Add24 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Add1]] - -INTERFACE Add - MODULE SUBROUTINE obj_Add25(obj, dofobj, nodenum, VALUE, & - scale, ivar, spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - INTEGER(I4B), INTENT(IN) :: timecompo - END SUBROUTINE obj_Add25 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 June 2022 -! summary: obj1=obj2 - -INTERFACE Add - MODULE SUBROUTINE obj_Add26(obj, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - CLASS(RealVector_), INTENT(IN) :: VALUE - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add26 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-29 -! summary: obj = obj + scale*VALUE -! -!# Introduction -! -! Value contains the nodal values of all dofs -! Number of cols in values should be at least equal to the total dof in obj -! Number of rows in values should be at least equal to the total nodes in obj - -INTERFACE Add - MODULE SUBROUTINE obj_Add27(obj, dofobj, VALUE, scale) - CLASS(RealVector_), INTENT(INOUT) :: obj - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - REAL(DFP), INTENT(IN) :: VALUE(:, :) - !! number of cols should be equal to the total dof in obj - !! number of rows should be equal to the total nodes in obj - REAL(DFP), INTENT(IN) :: scale - END SUBROUTINE obj_Add27 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-29 -! summary: obj = obj + scale*VALUE - -INTERFACE Add - MODULE SUBROUTINE obj_Add28(obj, dofobj, VALUE, scale, idof) - CLASS(RealVector_), INTENT(INOUT) :: obj - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - REAL(DFP), INTENT(IN) :: VALUE(:) - !! number of cols should be equal to the total dof in obj - !! number of rows should be equal to the total nodes in obj - REAL(DFP), INTENT(IN) :: scale - !! scale - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom in dofobj - END SUBROUTINE obj_Add28 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-29 -! summary: obj = obj + scale*VALUE - -INTERFACE Add - MODULE SUBROUTINE obj_Add29(obj1, dofobj1, idof1, obj2, dofobj2, idof2, & - scale) - TYPE(RealVector_), INTENT(INOUT) :: obj1 - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj1 - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof1 - !! global degree of freedom in dof1 - TYPE(RealVector_), INTENT(IN) :: obj2 - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj2 - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof2 - !! global degree of freedom in dof2 - REAL(DFP), INTENT(IN) :: scale - !! Scale - END SUBROUTINE obj_Add29 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-30 -! summary: Add range of values to a scalar - -INTERFACE Add - MODULE SUBROUTINE obj_Add30(obj, dofobj, istart, iend, stride, VALUE, & - idof, scale) - TYPE(RealVector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE - !! Scalar value - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - REAL(DFP), INTENT(IN) :: scale - !! scale - END SUBROUTINE obj_Add30 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-30 -! summary: Add range of values to a vector - -INTERFACE Add - MODULE SUBROUTINE obj_Add31(obj, dofobj, istart, iend, stride, VALUE, & - idof, scale) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! ob(istart:iend:stride)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - REAL(DFP), INTENT(IN) :: scale - !! scale - END SUBROUTINE obj_Add31 -END INTERFACE Add - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-30 -! summary: Add range of values to a vector - -INTERFACE Add - MODULE SUBROUTINE obj_Add32(obj, istart, iend, stride, VALUE, & - istart_value, iend_value, stride_value, scale) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! ob(istart:iend:stride)=VALUE - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value - !! range of values to set - REAL(DFP), INTENT(IN) :: scale - !! scale - END SUBROUTINE obj_Add32 -END INTERFACE Add - -END MODULE RealVector_AddMethods diff --git a/src/modules/RealVector/src/RealVector_AppendMethods.F90 b/src/modules/RealVector/src/RealVector_AppendMethods.F90 deleted file mode 100644 index a0970a40b..000000000 --- a/src/modules/RealVector/src/RealVector_AppendMethods.F90 +++ /dev/null @@ -1,72 +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 RealVector_AppendMethods -USE GlobalData, ONLY: DFP -USE BaseType, ONLY: RealVector_ - -IMPLICIT NONE - -PRIVATE -PUBLIC :: Append - -!---------------------------------------------------------------------------- -! Append@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This subroutine appends value to [[RealVector_]] - -INTERFACE Append - MODULE PURE SUBROUTINE obj_Append1(obj, VALUE) - CLASS(RealVector_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE obj_Append1 -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This subroutine appends value to [[RealVector_]] - -INTERFACE Append - MODULE PURE SUBROUTINE obj_Append2(obj, VALUE) - CLASS(RealVector_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: VALUE(:) - END SUBROUTINE obj_Append2 -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@setMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This subroutine appends value to [[RealVector_]] - -INTERFACE Append - MODULE PURE SUBROUTINE obj_Append3(obj, anotherobj) - CLASS(RealVector_), INTENT(INOUT) :: obj - CLASS(RealVector_), INTENT(IN) :: anotherobj - END SUBROUTINE obj_Append3 -END INTERFACE Append - -END MODULE RealVector_AppendMethods diff --git a/src/modules/RealVector/src/RealVector_AssignMethods.F90 b/src/modules/RealVector/src/RealVector_AssignMethods.F90 deleted file mode 100644 index d3d6d4502..000000000 --- a/src/modules/RealVector/src/RealVector_AssignMethods.F90 +++ /dev/null @@ -1,129 +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 RealVector_AssignMethods -USE GlobalData, ONLY: DFP, I4B, REAL32, REAL64 -USE BaseType, ONLY: RealVector_ - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign1(lhs, rhs) - CLASS(RealVector_), INTENT(INOUT) :: lhs - CLASS(RealVector_), INTENT(IN) :: rhs - END SUBROUTINE obj_assign1 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign2(lhs, rhs) - CLASS(RealVector_), INTENT(INOUT) :: lhs - CLASS(RealVector_), INTENT(IN) :: rhs(:) - END SUBROUTINE obj_assign2 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign3a(lhs, rhs) - CLASS(RealVector_), INTENT(INOUT) :: lhs - REAL(REAL32), INTENT(IN) :: rhs(:) - END SUBROUTINE obj_assign3a - - MODULE PURE SUBROUTINE obj_assign3b(lhs, rhs) - CLASS(RealVector_), INTENT(INOUT) :: lhs - REAL(REAL64), INTENT(IN) :: rhs(:) - END SUBROUTINE obj_assign3b -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign4a(lhs, rhs) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: lhs(:) - CLASS(RealVector_), INTENT(IN) :: rhs - END SUBROUTINE obj_assign4a - MODULE PURE SUBROUTINE obj_assign4b(lhs, rhs) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: lhs(:) - CLASS(RealVector_), INTENT(IN) :: rhs - END SUBROUTINE obj_assign4b -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign5a(lhs, rhs) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: lhs(:) - CLASS(RealVector_), INTENT(IN) :: rhs(:) - END SUBROUTINE obj_assign5a - MODULE PURE SUBROUTINE obj_assign5b(lhs, rhs) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: lhs(:) - CLASS(RealVector_), INTENT(IN) :: rhs(:) - END SUBROUTINE obj_assign5b -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign6(lhs, rhs) - CLASS(RealVector_), INTENT(INOUT) :: lhs - INTEGER(I4B), INTENT(IN) :: rhs(:) - END SUBROUTINE obj_assign6 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign7(lhs, rhs) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: lhs(:) - CLASS(RealVector_), INTENT(IN) :: rhs - END SUBROUTINE obj_assign7 -END INTERFACE ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Assign@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_assign8(lhs, rhs) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: lhs(:) - CLASS(RealVector_), INTENT(IN) :: rhs(:) - END SUBROUTINE obj_assign8 -END INTERFACE ASSIGNMENT(=) - -END MODULE RealVector_AssignMethods diff --git a/src/modules/RealVector/src/RealVector_Blas1Methods.F90 b/src/modules/RealVector/src/RealVector_Blas1Methods.F90 deleted file mode 100644 index 939e95f13..000000000 --- a/src/modules/RealVector/src/RealVector_Blas1Methods.F90 +++ /dev/null @@ -1,810 +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: 7 March 2021 -! summary: This module contains BLAS1 methods - -MODULE RealVector_Blas1Methods -USE GlobalData, ONLY: DFP, I4B, LGT, REAL32, REAL64 -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: ASUM -PUBLIC :: AXPY -PUBLIC :: COPY -PUBLIC :: Compact -PUBLIC :: DOT_PRODUCT -PUBLIC :: NORM2 -PUBLIC :: NORM1 -PUBLIC :: NORMi -PUBLIC :: SWAP -PUBLIC :: SCAL -PUBLIC :: PMUL -PUBLIC :: PDIV -PUBLIC :: Reciprocal - -!---------------------------------------------------------------------------- -! ASUM@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function computes the absolute sum of a vector -! -!# Introduction -! -! This function computes the absolute sum of a vector. -! -! $$\left| \left| V\right| \right|_{1} =\sum^{N}_{i=1} \left( \ -! \left| V_{i}\right| \right)$$ -! -!@note -! This function calls BLAS function ASUM. -!@endnote -! -!@todo -! subroutine test1 -! type( RealVector_ ) :: obj -! real( dfp ) :: ans -! obj = RealVector(arange(1,1000,1)) -! ans = ASUM(obj) -! call display( ans-sum(obj%val), "test1: 0 if correct : " ) -! end -!@endtodo - -INTERFACE ASUM - MODULE FUNCTION ASUMScalar(obj) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION ASUMScalar -END INTERFACE ASUM - -!---------------------------------------------------------------------------- -! ASUM@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function computes the absolute sum of a vector -!# Introduction -! -! This function computes the absolute sum of a vector. -! -! $$\left| \left| V\right| \right|_{1} =\sum^{N}_{i=1} \left( \ -! \left| V_{i}\right| \right)$$ -! -!@note -! This function calls [[ASUMScalar]] method -!@endnote -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 10, m=5 -! integer( i4b ) :: i -! type( RealVector_ ) :: obj( m ) -! real( dfp ) :: ans_l(m), ans -! do i = 1, m -! obj( i ) = RealVector(arange(1,n,1)) -! end do -! ans = 0.0 -! !$omp parallel default(shared) private( i ) reduction(+:ans) -! CALL OMP_INITIATE -! !$omp do -! do i = 1, m -! ans = ans + ASUM(obj(i)) !! no parallel -! enddo -! !$omp enddo -! CALL OMP_FINALIZE -! !$omp end parallel -! call display( ans - (m*sum(obj(1)%val)), "test2: 0 if correct : " ) -!``` -! -! Another example -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 100, m=5 -! integer( i4b ) :: i -! type( RealVector_ ) :: obj( m ) -! real( dfp ) :: ans_l(m), ans -! do i = 1, m -! obj( i ) = RealVector(arange(1,n,1)) -! end do -! ans = ASUM(obj) -! call display( ans - (m*sum(obj(1)%val)), "test3: 0 if correct : " ) -!``` - -INTERFACE ASUM - MODULE FUNCTION ASUMvector(obj) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj(:) - REAL(DFP) :: ans - END FUNCTION ASUMvector -END INTERFACE ASUM - -!---------------------------------------------------------------------------- -! AXPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 March 2021 -! summary: This subroutine computes AXPY -! -!# Introduction -! -! This subroutine performs following task -! -! $$Y=Y+A*X$$ -! -! Y = Y + A*X -! -! Here A is an scalar -! -!@note -! In joined state this subroutine creates new threads and share the work. -! If this subroutine is called within parallel block (i.e., forked state) -! then it does not create any new threads. Each thread will call this -! subroutine while X, Y, A treated as shared type. -!@endnote -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 100 -! integer( i4b ) :: i -! real( dfp ) :: a = 1.0_DFP -! type( RealVector_ ) :: x, y, z -! call random_number( x, n ) -! call random_number( y, n ) -! z%val = y%val + a * x%val -! call AXPY( x = x, y = y, A = a ) -! call display( ASUM(y%val - z%val), "test4: 0 if correct : " ) -!``` - -INTERFACE AXPY - MODULE SUBROUTINE scalarAXPYscalar(X, Y, A) - CLASS(RealVector_), INTENT(IN) :: X - CLASS(RealVector_), INTENT(INOUT) :: Y - REAL(DFP), INTENT(IN) :: A - END SUBROUTINE scalarAXPYscalar -END INTERFACE AXPY - -!---------------------------------------------------------------------------- -! AXPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 March 2021 -! summary: This subroutine computes AXPY -! -!# Introduction -! This subroutine performs following task -! -! $$Y=Y+A*X$$ -! -! Here A is an scalar -! -!@note -! In joined state this subroutine creates new threads and share the work. -! If this subroutine is called within parallel block (i.e., forked state) -! then it does not create any new threads. Each thread will call this -! subroutine while X, Y, A treated as shared type. -!@endnote -! - -INTERFACE AXPY - MODULE SUBROUTINE scalarAXPYintrinsic(X, Y, A) - REAL(DFP), INTENT(IN) :: X(:) - CLASS(RealVector_), INTENT(INOUT) :: Y - REAL(DFP), INTENT(IN) :: A - END SUBROUTINE scalarAXPYintrinsic -END INTERFACE AXPY - -!---------------------------------------------------------------------------- -! AXPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 March 2021 -! summary: This subroutine computes AXPY -! -!# Introduction -! This subroutine performs `AXPY` operation. It performs the following task. -! -! $$Y(i)=Y(i)+A(i)*X(i)$$ -! -! Here A is an vector of length same as size of `X` or `Y`. -! -!@note -! In joined state this subroutine creates new threads and share the work. -! If this subroutine is called within parallel block (i.e., forked state) -! then it does not create any new threads. Each thread will call this -! subroutine while X, Y, A treated as shared type. -!@endnote -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 100, m = 4 -! integer( i4b ) :: i, tsize(m) -! real( dfp ) :: a( m ), ans -! type( RealVector_ ), allocatable :: x( : ), y( : ), z( : ) -! tsize = m; a = 1.0 -! call random_number( x, tsize ) -! call random_number( y, tsize ) -! call initiate( z, tsize ) -! do i = 1, m -! z(i)%val = y(i)%val + a( i ) * x(i)%val -! end do -! call AXPY( x = x, y = y, A = a ) -! ans = 0.0 -! do i = 1, m -! ans = ans + ASUM( y(i)%val - z(i)%val ) -! end do -! call display( ans, "test5: 0 if correct : " ) -!``` - -INTERFACE AXPY - MODULE SUBROUTINE vectorAXPYvector(X, Y, A) - CLASS(RealVector_), INTENT(IN) :: X(:) - CLASS(RealVector_), INTENT(INOUT) :: Y(:) - REAL(DFP), INTENT(IN) :: A(:) - END SUBROUTINE vectorAXPYvector -END INTERFACE AXPY - -!---------------------------------------------------------------------------- -! COPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine copies one vector into another -! -!# Introduction -! This subroutine copies one [[RealVector_]] object into another object, i.e. -! `Y=X`. See figure given below: -! -! drawing -! -!@note -! This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. -!@endnote -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 10000 -! type( RealVector_ ) :: x, y -! real( dfp ), allocatable :: z( : ) -! call random_number( x, n ) -! call COPY( x = x, y = y ) -! call display( ASUM( x%val - y%val ), "test6: 0 if correct : " ) -! call COPY( y=z, x=x ) -! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) -! call COPY( y=x, x=z ) -! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) -!``` - -INTERFACE COPY - MODULE SUBROUTINE scalarCOPYscalar(Y, X) - TYPE(RealVector_), INTENT(INOUT) :: Y - CLASS(RealVector_), INTENT(IN) :: X - END SUBROUTINE scalarCOPYscalar -END INTERFACE COPY - -!---------------------------------------------------------------------------- -! COPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine copies one vector into another -! -!# Introduction -! This subroutine COPY a fortran vector into [[RealVector_]] obj, i.e. `Y=X` -! -!@note -! This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. -!@endnote -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 10000 -! type( RealVector_ ) :: x, y -! real( dfp ), allocatable :: z( : ) -! call random_number( x, n ) -! call COPY( x = x, y = y ) -! call display( ASUM( x%val - y%val ), "test6: 0 if correct : " ) -! call COPY( y=z, x=x ) -! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) -! call COPY( y=x, x=z ) -! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) -!``` - -INTERFACE COPY - MODULE SUBROUTINE scalarCOPYintrinsic_1a(Y, X) - CLASS(RealVector_), INTENT(INOUT) :: Y - REAL(REAL32), INTENT(IN) :: X(:) - END SUBROUTINE scalarCOPYintrinsic_1a -END INTERFACE COPY - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE COPY - MODULE SUBROUTINE scalarCOPYintrinsic_1b(Y, X) - CLASS(RealVector_), INTENT(INOUT) :: Y - REAL(REAL64), INTENT(IN) :: X(:) - END SUBROUTINE scalarCOPYintrinsic_1b -END INTERFACE COPY - -!---------------------------------------------------------------------------- -! COPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine copies one vector into another -! -!# Introduction -! This subroutine COPY an instance of [[RealVector_]] in another fortran -! vector, i.e. `Val=obj` -! -!@note -! This subroutine internally calls [[intrinsicCOPYintrinsic]]. Also `Val` -! is allocatable. -!@endnote -! -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 10000 -! type( RealVector_ ) :: x, y -! real( dfp ), allocatable :: z( : ) -! call random_number( x, n ) -! call COPY( x = x, y = y ) -! call display( ASUM( x%val - y%val ), "test6: 0 if correct : " ) -! call COPY( y=z, x=x ) -! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) -! call COPY( y=x, x=z ) -! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) -!``` - -INTERFACE COPY - MODULE SUBROUTINE intrinsicCOPYscalar_1a(Y, X) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X - END SUBROUTINE intrinsicCOPYscalar_1a -END INTERFACE COPY - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE COPY - MODULE SUBROUTINE intrinsicCOPYscalar_1b(Y, X) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X - END SUBROUTINE intrinsicCOPYscalar_1b -END INTERFACE - -!---------------------------------------------------------------------------- -! COPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine copies one vector into another -! -!# Introduction -! This subroutine COPY a vector of [[RealVector_]] into another vector, i.e. -! `obj1=obj2` see the figure below: -! -! drawing -! -!@note -!This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. Also -! note that `obj1` and `obj2` are vectors of [[RealVector_]] data type. -!@endnote -! -! -!### Usage -! -!```fortran -! integer( i4b ), parameter :: n = 10000, m = 5 -! type( RealVector_ ), allocatable :: x( : ), y( : ) -! integer( i4b ) :: tsize( m ), i -! real( dfp ), allocatable :: z( : ) -! real( dfp ) :: ans -! tsize = n -! call random_number(x, tsize) -! call COPY( x = x, y = y ) -! ans = 0.0 -! do i = 1, size( x ) -! ans = ans + ASUM( x(i)%val - y(i)%val ) -! end do -! call display( ans, "test7: 0 if correct : " ) -!``` - -INTERFACE COPY - MODULE SUBROUTINE vectorCOPYvector(Y, X) - TYPE(RealVector_), INTENT(INOUT), ALLOCATABLE :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X(:) - END SUBROUTINE vectorCOPYvector -END INTERFACE COPY - -!---------------------------------------------------------------------------- -! COPY@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine copies one vector into another -! -!# Introduction -! This subroutine copies a vector of [[RealVector_]] into a scalar instance -! of [[RealVector_]]. See Figure below: -! -! drawing -! -!@note -! This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. -!@endnote -! -!@todo -! need parallel -!@endtodo - -INTERFACE COPY - MODULE SUBROUTINE scalarCOPYvector(Y, X) - TYPE(RealVector_), INTENT(INOUT) :: Y - CLASS(RealVector_), INTENT(IN) :: X(:) - END SUBROUTINE scalarCOPYvector -END INTERFACE COPY - -!---------------------------------------------------------------------------- -! Compact@BLAS1V -!---------------------------------------------------------------------------- - -INTERFACE Compact - MODULE SUBROUTINE Compact_real_1(Val, row) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Val(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE -END INTERFACE Compact - -!---------------------------------------------------------------------------- -! Compact@BLAS1V -!---------------------------------------------------------------------------- - -INTERFACE Compact - MODULE SUBROUTINE Compact_int_1(Val, row) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Val(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE -END INTERFACE Compact - -!---------------------------------------------------------------------------- -! DOT@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine returns dot product of two [[RealVector_]] -! -!@todo -! type(_obj_) :: obj1, obj2 -! call RANDOM_NUMBER( obj1, 100 ) -! call RANDOM_NUMBER( obj2, 100 ) -! CALL Display( DOT(obj1, obj2), "dot 1=" ) -!@endtodo - -INTERFACE DOT_PRODUCT - MODULE PURE FUNCTION scalarDOTscalar(obj1, obj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj1, obj2 - REAL(DFP) :: ans - END FUNCTION scalarDOTscalar -END INTERFACE DOT_PRODUCT - -!---------------------------------------------------------------------------- -! DOT@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine computes dot product of a fortran array and scalar -! instance of [[RealVector_]] -! -!@todo -! type(_obj_) :: obj1 -! real( dfp ) :: val( 100 ) -! call RANDOM_NUMBER( obj1, 100 ) -! call RANDOM_NUMBER( val ) -! CALL Display( DOT(obj1, val), "dot =" ) -!@endtodo - -INTERFACE DOT_PRODUCT - MODULE PURE FUNCTION scalarDOTintrinsic(obj, Val) RESULT(ans) - REAL(DFP), INTENT(IN) :: Val(:) - CLASS(RealVector_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION scalarDOTintrinsic -END INTERFACE DOT_PRODUCT - -!---------------------------------------------------------------------------- -! DOT@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routines returns the dot product of vector of -! [[RealVector_]] data type. -! -!@todo -! type(_obj_) :: obj1(2), obj2(2) -! call RANDOM_NUMBER( obj1(1), 100 ) -! call RANDOM_NUMBER( obj1(2), 100 ) -! obj2 = obj1 -! CALL Display( DOT(obj1, obj2), "dot =" ) -!@endtodo - -INTERFACE DOT_PRODUCT - MODULE PURE FUNCTION vectorDOTvector(obj1, obj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj1(:), obj2(:) - REAL(DFP) :: ans - END FUNCTION vectorDOTvector -END INTERFACE DOT_PRODUCT - -!---------------------------------------------------------------------------- -! DOT@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine computes dot product of a vector of [[RealVector_]] -! and scalar of [[RealVector_]] -! -!@todo -! type(_obj_) :: obj1(2), obj2(2) -! call RANDOM_NUMBER( obj1(1), 100 ) -! call RANDOM_NUMBER( obj1(2), 100 ) -! obj2 = obj1 -! CALL Display( DOT(obj1, obj2), "dot =" ) -!@endtodo - -INTERFACE DOT_PRODUCT - MODULE PURE FUNCTION vectorDOTscalar(obj1, obj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj1(:), obj2 - REAL(DFP) :: ans - END FUNCTION vectorDOTscalar -END INTERFACE DOT_PRODUCT - -!---------------------------------------------------------------------------- -! DOT@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine computes dot product of a scalar of [[RealVector_]] -! and vector of [[RealVector_]] -! -!### Usage -! -!```fortran -! type(_obj_) :: obj1 -! real( dfp ) :: val( 100 ) -! call RANDOM_NUMBER( obj1, 100 ) -! call RANDOM_NUMBER( val ) -! CALL Display( DOT(obj1, val), "dot =" ) -!``` - -INTERFACE DOT_PRODUCT - MODULE PURE FUNCTION scalarDOTvector(obj1, obj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj1, obj2(:) - REAL(DFP) :: ans - END FUNCTION scalarDOTvector -END INTERFACE DOT_PRODUCT - -!---------------------------------------------------------------------------- -! Norm2@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function computes Euclidean norm of [[RealVector_]] -! -!# Introduction -! -! L2 norm of a vector is give by -! -! $$\left| \left| \bf{V} \right| \right| =\sqrt{\bf{V} \cdot \bf{V} }$$ -! -!@note -! This subroutine uses DOT function. -!@endnote -! -!### Usage -! -!```fortran -!s = NORM2(obj) -!``` - -INTERFACE NORM2 - MODULE PURE FUNCTION NRM2scalar(obj) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION NRM2scalar -END INTERFACE NORM2 - -!---------------------------------------------------------------------------- -! Norm2@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This routine computes the L2 norm of [[RealVector_]] -! -!# Introduction -! -! This routine computes L2 norm of a vector of [[RealVector_]]. -! -!@note -! This function employs DOT function. -!@endnote -! -!@todo -! type(_obj_) :: obj1 -! real( dfp ) :: val( 100 ) -! call RANDOM_NUMBER( obj1, 100 ) -! call RANDOM_NUMBER( val ) -! CALL Display( DOT(obj1, val), "dot =" ) -!@endtodo - -INTERFACE NORM2 - MODULE PURE FUNCTION NRM2vector(obj) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj(:) - REAL(DFP) :: ans - END FUNCTION NRM2vector -END INTERFACE NORM2 - -!---------------------------------------------------------------------------- -! Norm2@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function computes the l1 norm - -INTERFACE NORM1 - MODULE FUNCTION obj_NORM1(obj) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION obj_NORM1 -END INTERFACE NORM1 - -!---------------------------------------------------------------------------- -! Norm2@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function computes the l1 norm - -INTERFACE NORMi - MODULE FUNCTION obj_NORMi(obj) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - REAL(DFP) :: ans - END FUNCTION obj_NORMi -END INTERFACE NORMi - -!---------------------------------------------------------------------------- -! SWAP@BLAS1 -!---------------------------------------------------------------------------- - -INTERFACE SWAP - MODULE PURE SUBROUTINE scalarSWAPscalar(X, Y) - CLASS(RealVector_), INTENT(INOUT) :: X - CLASS(RealVector_), INTENT(INOUT) :: Y - END SUBROUTINE scalarSWAPscalar - - MODULE PURE SUBROUTINE vectorSWAPvector(X, Y) - CLASS(RealVector_), INTENT(INOUT) :: X(:) - CLASS(RealVector_), INTENT(INOUT) :: Y(:) - END SUBROUTINE vectorSWAPvector - - MODULE PURE SUBROUTINE scalarSWAPintrinsic(X, Y) - CLASS(RealVector_), INTENT(INOUT) :: X - REAL(DFP), INTENT(INOUT) :: Y(:) - END SUBROUTINE scalarSWAPintrinsic -END INTERFACE SWAP - -!---------------------------------------------------------------------------- -! SCALE@BLAS1 -!---------------------------------------------------------------------------- - -INTERFACE SCAL - MODULE PURE SUBROUTINE SCALscalar(X, A) - CLASS(RealVector_), INTENT(INOUT) :: X - REAL(DFP), INTENT(IN) :: A - END SUBROUTINE SCALscalar - - MODULE PURE SUBROUTINE SCALvector(X, A) - CLASS(RealVector_), INTENT(INOUT) :: X(:) - REAL(DFP), INTENT(IN) :: A - END SUBROUTINE SCALvector -END INTERFACE SCAL - -!---------------------------------------------------------------------------- -! PMUL@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-28 -! summary: obj = obj1 * obj2 - -INTERFACE PMUL - MODULE SUBROUTINE obj_PMUL1(obj, obj1, obj2) - CLASS(RealVector_), INTENT(INOUT) :: obj - CLASS(RealVector_), INTENT(IN) :: obj1 - CLASS(RealVector_), INTENT(IN) :: obj2 - END SUBROUTINE obj_PMUL1 -END INTERFACE PMUL - -!---------------------------------------------------------------------------- -! PMUL@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-28 -! summary: obj = obj1 / obj2 - -INTERFACE PDIV - MODULE SUBROUTINE obj_PDIV1(obj, obj1, obj2, check_divide_by_zero) - CLASS(RealVector_), INTENT(INOUT) :: obj - CLASS(RealVector_), INTENT(IN) :: obj1 - CLASS(RealVector_), INTENT(IN) :: obj2 - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: check_divide_by_zero - END SUBROUTINE obj_PDIV1 -END INTERFACE PDIV - -!---------------------------------------------------------------------------- -! PMUL@BLAS1 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-12-28 -! summary: Reciprocal obj1 = 1.0/obj2 - -INTERFACE Reciprocal - MODULE SUBROUTINE obj_Reciprocal1(obj1, obj2, check_divide_by_zero) - CLASS(RealVector_), INTENT(INOUT) :: obj1 - CLASS(RealVector_), INTENT(IN) :: obj2 - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: check_divide_by_zero - END SUBROUTINE obj_Reciprocal1 -END INTERFACE Reciprocal - -END MODULE RealVector_Blas1Methods diff --git a/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 b/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 deleted file mode 100644 index 2d6bfd5da..000000000 --- a/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 +++ /dev/null @@ -1,40 +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 RealVector_ComparisonMethods -USE GlobalData, ONLY: LGT -USE BaseType, ONLY: RealVector_ - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: OPERATOR(.EQ.) - -!---------------------------------------------------------------------------- -! EQ -!---------------------------------------------------------------------------- - -INTERFACE OPERATOR(.EQ.) - MODULE PURE FUNCTION obj_isEqual(obj, obj2) RESULT(Ans) - CLASS(RealVector_), INTENT(IN) :: obj - CLASS(RealVector_), INTENT(IN) :: obj2 - LOGICAL(LGT) :: ans - END FUNCTION obj_isEqual -END INTERFACE OPERATOR(.EQ.) - -END MODULE RealVector_ComparisonMethods diff --git a/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 b/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 deleted file mode 100644 index 90259cff1..000000000 --- a/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 +++ /dev/null @@ -1,453 +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 RealVector_ConstructorMethods -USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: Shape -PUBLIC :: SIZE -PUBLIC :: GetTotalDimension -PUBLIC :: SetTotalDimension -PUBLIC :: ALLOCATE -PUBLIC :: DEALLOCATE -PUBLIC :: Initiate -PUBLIC :: RANDOM_NUMBER -PUBLIC :: RealVector -PUBLIC :: RealVector_Pointer -PUBLIC :: Reallocate -PUBLIC :: isAllocated -PUBLIC :: isInitiated - -!---------------------------------------------------------------------------- -! isAllocated@EnquireMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! summary: Returns true if the instance is allocated - -INTERFACE isAllocated - MODULE PURE FUNCTION obj_isAllocated(obj) RESULT(Ans) - CLASS(RealVector_), INTENT(IN) :: obj - LOGICAL(LGT) :: ans - END FUNCTION obj_isAllocated -END INTERFACE isAllocated - -INTERFACE isInitiated - MODULE PROCEDURE obj_isAllocated -END INTERFACE isInitiated - -!---------------------------------------------------------------------------- -! Shape@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Feb 2021 -! summary: This function returns the shape of RealVector_ - -INTERFACE Shape - MODULE PURE FUNCTION obj_shape(obj) RESULT(Ans) - CLASS(RealVector_), INTENT(IN) :: obj - INTEGER(I4B) :: Ans(1) - END FUNCTION obj_shape -END INTERFACE Shape - -!---------------------------------------------------------------------------- -! SIZE@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Feb 2021 -! summary: This function returns the size of RealVector_ - -INTERFACE Size - MODULE PURE FUNCTION obj_size(obj, Dims) RESULT(Ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims - INTEGER(I4B) :: Ans - END FUNCTION obj_size -END INTERFACE Size - -!---------------------------------------------------------------------------- -! TotalDimension@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Returns the total dimension of an array -! -!# Introduction -! -! This function returns the total dimension (or rank) of an array, - -INTERFACE GetTotalDimension - MODULE PURE FUNCTION RealVec_GetTotalDimension(obj) RESULT(Ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION RealVec_GetTotalDimension -END INTERFACE GetTotalDimension - -!---------------------------------------------------------------------------- -! SetTotalDimension@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine Set the total dimension (rank) of an array -! -!# Introduction -! -! This subroutine Sets the rank(total dimension) of an array - -INTERFACE SetTotalDimension - MODULE PURE SUBROUTINE RealVec_SetTotalDimension(obj, tDimension) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tDimension - END SUBROUTINE RealVec_SetTotalDimension -END INTERFACE SetTotalDimension - -!---------------------------------------------------------------------------- -! Allocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Feb 2021 -! summary: This subroutine allocates memory for RealVector - -INTERFACE ALLOCATE - MODULE PURE SUBROUTINE obj_Allocate(obj, Dims) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Dims - END SUBROUTINE obj_Allocate -END INTERFACE ALLOCATE - -!---------------------------------------------------------------------------- -! Reallocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Allocate memory for the vector - -INTERFACE Reallocate - MODULE PURE SUBROUTINE obj_Reallocate(obj, row) - TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE obj_Reallocate -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Deallocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Feb 2021 -! summary: This subroutine deallocates the data in RealVector_ - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE obj_Deallocate(obj) - CLASS(RealVector_), INTENT(INOUT) :: obj - END SUBROUTINE obj_Deallocate -END INTERFACE DEALLOCATE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Feb 2021 -! summary: This subroutine allocates the memory for RealVector_ -! -!# Introduction This subroutine allocates the memeory for RealVector_ -! -!@note -! This subroutine is an alias for Allocate_Data -!@endnote - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate1(obj, tSize) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tSize - END SUBROUTINE obj_initiate1 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Feb 2021 -! summary: This subroutine allocate the memory for a vector of type -! RealVector_ -! -!# Introduction -! This subroutine allocate the memory for a vector of type RealVector_ -!@note -! The size of `obj` would be same as the size of `tSize` -!@endnote - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_Initiate2(obj, tSize) - TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: tSize(:) - END SUBROUTINE obj_Initiate2 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Feb 2021 -! summary: This subroutine allocate the memory for an instance of -! RealVector_ -! -!# Introduction -! This subroutine allocate the memory for an instance of RealVector_. -! User can specify the lowerbounds and upper bounds. - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_Initiate3(obj, a, b) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: a, b - END SUBROUTINE obj_Initiate3 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Initiate RealVector_ using dof_ object -! -!# Introduction -! -! This subroutine initiate RealVector_ using the information stored inside -! dof_ object. It Gets the information of total size of RealVector_ -! from DOF_ and call RealVector_Method:Initiate routine. -! All values of RealVector_ is Set to zero. - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_Initiate4(obj, dofobj) - CLASS(RealVector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj - END SUBROUTINE obj_Initiate4 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 Oct, 2021 -! summary: Initiate a vector of realvector_ from dof_ object -! -!# Introduction -! -! This subroutine initiates a vector of realvector_ object. -! The size of `val` will be total number of degrees of freedom inside -! the DOF_ object. Therefore, each `val( idof )` denotes the -! nodal vector of correrponding to a degree of freedom number `idof` - -INTERFACE Initiate - MODULE PURE SUBROUTINE obj_Initiate5(obj, dofobj) - TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - CLASS(DOF_), INTENT(IN) :: dofobj - END SUBROUTINE obj_Initiate5 -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! Random_number@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This routine computes radom_number -! -!# Introduction -! -! This routine calls `RANDOM_NUMBER` to generate a random instnance of -! RealVector_ - -INTERFACE RANDOM_NUMBER - MODULE SUBROUTINE obj_Random_Number1(obj, tsize) - CLASS(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tsize - END SUBROUTINE obj_Random_Number1 -END INTERFACE RANDOM_NUMBER - -!---------------------------------------------------------------------------- -! Random_number@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This routine computes radom_number -! -!# Introduction -! -! This routine calls `RANDOM_NUMBER` to generate a random instnance of -! RealVector_ -! -!@note -! Here argument `obj` is a vector of RealVector_ data-types. -!@endnote - -INTERFACE RANDOM_NUMBER - MODULE SUBROUTINE obj_Random_Number2(obj, tsize) - TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) - INTEGER(I4B), INTENT(IN) :: tsize(:) - END SUBROUTINE obj_Random_Number2 -END INTERFACE RANDOM_NUMBER - -!---------------------------------------------------------------------------- -! RealVector@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns an instance of RealVector_ -! -!# Introduction -! -! This function returns an instance of RealVector_ - -INTERFACE RealVector - MODULE PURE FUNCTION obj_Constructor1(tSize) RESULT(obj) - TYPE(RealVector_) :: obj - INTEGER(I4B), INTENT(IN) :: tSize - END FUNCTION obj_Constructor1 -END INTERFACE RealVector - -!---------------------------------------------------------------------------- -! RealVector@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns an instance of RealVector_ -! -!# Introduction -! This function returns an instance of RealVector_ by copying the -! contents of a fortran integer vector. -! -!@note -! This routine internally calls RealVector_Method:COPY routine. -!@endnote - -INTERFACE RealVector - MODULE PURE FUNCTION obj_Constructor2(Val) RESULT(obj) - TYPE(RealVector_) :: obj - INTEGER(I4B), INTENT(IN) :: Val(:) - END FUNCTION obj_Constructor2 -END INTERFACE RealVector - -!---------------------------------------------------------------------------- -! RealVector@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns an instance of RealVector_ -! -!# Introduction -! This function returns an instance of RealVector_ by copying the -! contents of a fortran real vector. -! -!@note -! This routine internally calls RealVector_Method:COPY routine. -!@endnote - -INTERFACE RealVector - MODULE PURE FUNCTION obj_Constructor3(Val) RESULT(obj) - TYPE(RealVector_) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - END FUNCTION obj_Constructor3 -END INTERFACE RealVector - -!---------------------------------------------------------------------------- -! RealVector_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returnt the pointer to a newly created instance of -! RealVector_ -! -!# Introduction -! This function returnt the pointer to a newly created instance of -! RealVector_ - -INTERFACE RealVector_Pointer - MODULE PURE FUNCTION obj_Constructor_1(tSize) RESULT(obj) - CLASS(RealVector_), POINTER :: obj - INTEGER(I4B), INTENT(IN) :: tSize - END FUNCTION obj_Constructor_1 -END INTERFACE RealVector_Pointer - -!---------------------------------------------------------------------------- -! RealVector_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns the pointer to an instance ofRealVector_ -! -!# Introduction -! This function returns a pointer to an newly created instance of -! RealVector_ by copying the contents of a fortran integer vector. -! -!@note -! This routine internally calls RealVector_Method:COPY routine. -!@endnote - -INTERFACE RealVector_Pointer - MODULE PURE FUNCTION obj_Constructor_2(Val) RESULT(obj) - CLASS(RealVector_), POINTER :: obj - INTEGER(I4B), INTENT(IN) :: Val(:) - END FUNCTION obj_Constructor_2 -END INTERFACE RealVector_Pointer - -!---------------------------------------------------------------------------- -! RealVector_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns the pointer to an instance ofRealVector_ -! -!# Introduction -! This function returns a pointer to an newly created instance of -! RealVector_ by copying the contents of a fortran real vector. -! -!@note -! This routine internally calls RealVector_Method:COPY routine. -!@endnote - -INTERFACE RealVector_Pointer - MODULE PURE FUNCTION obj_Constructor_3(Val) RESULT(obj) - CLASS(RealVector_), POINTER :: obj - REAL(DFP), INTENT(IN) :: Val(:) - END FUNCTION obj_Constructor_3 -END INTERFACE RealVector_Pointer - -END MODULE RealVector_ConstructorMethods diff --git a/src/modules/RealVector/src/RealVector_GetMethods.F90 b/src/modules/RealVector/src/RealVector_GetMethods.F90 deleted file mode 100644 index fed8f2c22..000000000 --- a/src/modules/RealVector/src/RealVector_GetMethods.F90 +++ /dev/null @@ -1,708 +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 RealVector_GetMethods -USE GlobalData, ONLY: DFP, I4B, LGT, REAL32, REAL64 - -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetIndex -PUBLIC :: Get -PUBLIC :: IsPresent -PUBLIC :: GetPointer - -!---------------------------------------------------------------------------- -! GetPointer@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: Returns the pointer to vector of real numbers in [[RealVector_]] -! -!# Introduction -! -! This function returns the pointer to vector of real numbers stored -! inside [[RealVector_]] - -INTERFACE GetPointer - MODULE FUNCTION obj_GetPointer1(obj) RESULT(val) - TYPE(RealVector_), INTENT(IN), TARGET :: obj - REAL(DFP), POINTER :: val(:) - END FUNCTION obj_GetPointer1 -END INTERFACE GetPointer - -!---------------------------------------------------------------------------- -! GetPointer@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: Returns the pointer to vector of real numbers -! -!# Introduction -! This function returns the pointer to vector of real numbers stored -! inside [[RealVector_]] for a given degree of freedom - -INTERFACE GetPointer - MODULE FUNCTION obj_GetPointer2(obj, dofobj, idof) RESULT(val) - TYPE(RealVector_), INTENT(IN), TARGET :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), POINTER :: val(:) - END FUNCTION obj_GetPointer2 -END INTERFACE GetPointer - -!---------------------------------------------------------------------------- -! GetIndex@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function finds location of value inside the [[RealVector_]] -! -!# Introduction -! -! This function finds the location of `value` inside the instance of -! [[RealVector_]] - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex1(obj, VALUE, tol) RESULT(Ans) - TYPE(RealVector_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - INTEGER(I4B) :: Ans - END FUNCTION obj_GetIndex1 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! IndexOf@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: Returns location of values inside the [[RealVector_]] -! -!# Introduction -! -! This function returns the nearest location of values inside the -! [[RealVector_]] - -INTERFACE GetIndex - MODULE PURE FUNCTION obj_GetIndex2(obj, VALUE, tol) RESULT(Ans) - TYPE(RealVector_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - INTEGER(I4B), ALLOCATABLE :: Ans(:) - END FUNCTION obj_GetIndex2 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! IsPresent@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: Returns true if value is present inside [[RealVector_]] - -INTERFACE IsPresent - MODULE PURE FUNCTION obj_IsPresent1(obj, VALUE, tol) RESULT(Ans) - TYPE(RealVector_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: VALUE - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION obj_IsPresent1 -END INTERFACE IsPresent - -!---------------------------------------------------------------------------- -! IsPresentGetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: Returns true if value is present inside [[RealVector_]] - -INTERFACE IsPresent - MODULE PURE FUNCTION obj_IsPresent2(obj, VALUE, tol) RESULT(Ans) - TYPE(RealVector_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: VALUE(:) - REAL(DFP), OPTIONAL, INTENT(IN) :: tol - LOGICAL(LGT), ALLOCATABLE :: Ans(:) - END FUNCTION obj_IsPresent2 -END INTERFACE IsPresent - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of Integer from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get1(obj, dataType) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: dataType - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get1 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of integer from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get2(obj, nodenum, dataType) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: dataType - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get2 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of integer from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get3(obj, istart, iend, stride, dataType) & - RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(I4B), INTENT(IN) :: dataType - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get3 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get4a(obj, dataType) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - REAL(REAL32), INTENT(IN) :: dataType - REAL(REAL32), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get4a - - MODULE PURE FUNCTION obj_Get4b(obj, dataType) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - REAL(REAL64), INTENT(IN) :: dataType - REAL(REAL64), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get4b -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get5a(obj, nodenum, dataType) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(REAL32), INTENT(IN) :: dataType - REAL(REAL32), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get5a - MODULE PURE FUNCTION obj_Get5b(obj, nodenum, dataType) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(REAL64), INTENT(IN) :: dataType - REAL(REAL64), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get5b -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get6(obj, istart, iend, stride, dataType) & - RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - REAL(DFP), INTENT(IN) :: dataType - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get6 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns the vector of integer from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get7(obj, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: dataType - INTEGER(I4B), ALLOCATABLE :: val(:) - END FUNCTION obj_Get7 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of integer from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get8(obj, nodenum, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: dataType - INTEGER(I4B), ALLOCATABLE :: val(:) - END FUNCTION obj_Get8 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns an integer vector from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get9(obj, istart, iend, stride, dataType) & - RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: istart - INTEGER(I4B), INTENT(IN) :: iend - INTEGER(I4B), INTENT(IN) :: stride - INTEGER(I4B), INTENT(IN) :: dataType - INTEGER(I4B), ALLOCATABLE :: val(:) - END FUNCTION obj_Get9 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get10a(obj, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - REAL(REAL32), INTENT(IN) :: dataType - REAL(REAL32), ALLOCATABLE :: val(:) - END FUNCTION obj_Get10a - - MODULE PURE FUNCTION obj_Get10b(obj, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - REAL(REAL64), INTENT(IN) :: dataType - REAL(REAL64), ALLOCATABLE :: val(:) - END FUNCTION obj_Get10b -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get11a(obj, nodenum, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - REAL(REAL32), INTENT(IN) :: dataType - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(REAL32), ALLOCATABLE :: val(:) - END FUNCTION obj_Get11a - - MODULE PURE FUNCTION obj_Get11b(obj, nodenum, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - REAL(REAL64), INTENT(IN) :: dataType - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(REAL64), ALLOCATABLE :: val(:) - END FUNCTION obj_Get11b -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get12a(obj, istart, iend, stride, dataType) & - RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - REAL(REAL32), INTENT(IN) :: dataType - REAL(REAL32), ALLOCATABLE :: val(:) - END FUNCTION obj_Get12a - - MODULE PURE FUNCTION obj_Get12b(obj, istart, iend, stride, & - & dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - REAL(REAL64), INTENT(IN) :: dataType - REAL(REAL64), ALLOCATABLE :: val(:) - END FUNCTION obj_Get12b -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns the instance of [[RealVector_]] -! -!# Introduction -! This function returns an scalar instance of [[RealVector_]] by -! combining different entries of a vector of [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get13(obj, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - TYPE(RealVector_), INTENT(IN) :: dataType - TYPE(RealVector_) :: val - END FUNCTION obj_Get13 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns the instance of [[RealVector_]] -! -!# Introduction -! This function returns the instance of [[RealVector_]] from the vector of -! [[RealVector_]]. - -INTERFACE Get - MODULE PURE FUNCTION obj_Get14(obj, nodenum, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: nodenum(:) - TYPE(RealVector_), INTENT(IN) :: dataType - TYPE(RealVector_) :: val - END FUNCTION obj_Get14 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns the instance of [[RealVector_]] -! -!# Introduction -! This function returns the instance of [[RealVector_]] from the vector of -! [[RealVector_]]. - -INTERFACE Get - MODULE PURE FUNCTION obj_Get15(obj, istart, iend, stride, & - dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - TYPE(RealVector_), INTENT(IN) :: dataType - TYPE(RealVector_) :: val - END FUNCTION obj_Get15 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns an instance of [[RealVector_]] -! -!# Introduction -! -! This function returns an instance of [[RealVector_]] by using selective -! from `obj` - -INTERFACE Get - MODULE PURE FUNCTION obj_Get16(obj, nodenum, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - TYPE(RealVector_), INTENT(IN) :: dataType - TYPE(RealVector_) :: val - END FUNCTION obj_Get16 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns the instance of [[RealVector_]] -! -!# Introduction -! This function returns the instance of [[RealVector_]] using istart, iend, -! stride values - -INTERFACE Get - MODULE PURE FUNCTION obj_Get17(obj, istart, iend, stride, & - dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - TYPE(RealVector_), INTENT(IN) :: dataType - TYPE(RealVector_) :: val - END FUNCTION obj_Get17 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION obj_Get18a(obj, nodenum, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(REAL32), INTENT(IN) :: dataType - REAL(REAL32) :: val - END FUNCTION obj_Get18a - - MODULE PURE FUNCTION obj_Get18b(obj, nodenum, dataType) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - REAL(REAL64), INTENT(IN) :: dataType - REAL(REAL64) :: val - END FUNCTION obj_Get18b -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get19(obj) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get19 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get20(obj, nodenum) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get20 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get21(obj, istart, iend, stride) & - RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get21 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get22(obj) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE :: val(:) - END FUNCTION obj_Get22 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get23(obj, nodenum) RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: nodenum(:) - REAL(DFP), ALLOCATABLE :: val(:) - END FUNCTION obj_Get23 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get24(obj, istart, iend, stride) & - RESULT(val) - TYPE(RealVector_), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - REAL(DFP), ALLOCATABLE :: val(:) - END FUNCTION obj_Get24 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get25(obj, dofobj, nodenum, ivar, idof) & - RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP) :: ans - END FUNCTION obj_Get25 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get26(obj, dofobj, nodenum, ivar, idof) & - RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP) :: ans(SIZE(nodenum)) - END FUNCTION obj_Get26 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get27(obj, dofobj, nodenum, ivar) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get27 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get28(obj, dofobj, nodenum, & - ivar, spacecompo, timecompo) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: nodenum(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spacecompo - INTEGER(I4B), INTENT(IN) :: timecompo - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get28 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get@GetMethod -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE Get - MODULE PURE FUNCTION obj_Get29(obj, dofobj, idof) RESULT(ans) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: idof - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION obj_Get29 -END INTERFACE Get - -END MODULE RealVector_GetMethods diff --git a/src/modules/RealVector/src/RealVector_GetValueMethods.F90 b/src/modules/RealVector/src/RealVector_GetValueMethods.F90 deleted file mode 100644 index cff868762..000000000 --- a/src/modules/RealVector/src/RealVector_GetValueMethods.F90 +++ /dev/null @@ -1,1168 +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 RealVector_GetValueMethods -USE GlobalData, ONLY: DFP, I4B, LGT -USE BaseType, ONLY: DOF_, RealVector_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: GetValue -PUBLIC :: GetValue_ - -INTERFACE GetValue_ -MODULE PROCEDURE obj_GetValue1, obj_GetValue2, obj_GetValue3, obj_GetValue4, & - obj_GetValue5, obj_GetValue6, obj_GetValue7, obj_GetValue8, & - obj_GetValue9, obj_GetValue10, obj_GetValue11, obj_GetValue15, & - obj_GetValue24 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. -! -!@note -! We call set method -!@endnote - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue1(obj, VALUE, istart, iend, stride) - TYPE(RealVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - TYPE(RealVector_), INTENT(INOUT) :: VALUE - END SUBROUTINE obj_GetValue1 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. -! -!@note -! We call set method -!@endnote - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue2(obj, dofobj, VALUE, idof) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_GetValue2 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue3(obj, dofobj, VALUE, ivar, idof) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_GetValue3 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue4(obj, dofobj, VALUE, ivar, & - spaceCompo, timeCompo) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spaceCompo - INTEGER(I4B), INTENT(IN) :: timeCompo - END SUBROUTINE obj_GetValue4 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue5(obj, dofobj, idofobj, & - VALUE, dofvalue, idofvalue) - TYPE(RealVector_), INTENT(IN) :: obj - !! Real vector whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! DOF for obj - INTEGER(I4B), INTENT(IN) :: idofobj - !! idof for obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - !! real vector to be returned - TYPE(DOF_), INTENT(IN) :: dofvalue - !! dof for value - INTEGER(I4B), INTENT(IN) :: idofvalue - !! idof for value - END SUBROUTINE obj_GetValue5 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. -! -!@note -! The size of idofobj and idofvalue should be equal. -!@endnote - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue6(obj, dofobj, idofobj, & - VALUE, dofvalue, idofvalue) - TYPE(RealVector_), INTENT(IN) :: obj - !! Real vector whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! DOF for obj - INTEGER(I4B), INTENT(IN) :: idofobj(:) - !! idof for obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - !! values to be returned - TYPE(DOF_), INTENT(IN) :: dofvalue - !! dof for value - INTEGER(I4B), INTENT(IN) :: idofvalue(:) - !! idof for value - END SUBROUTINE obj_GetValue6 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue7(obj, dofobj, ivarobj, idofobj, & - VALUE, dofvalue, ivarvalue, idofvalue) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object for obj - INTEGER(I4B), INTENT(IN) :: ivarobj - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: idofobj - !! local degree of freedom of physical variable for obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - TYPE(DOF_), INTENT(IN) :: dofvalue - !! degree of freedom object for value - INTEGER(I4B), INTENT(IN) :: ivarvalue - !! physical variable for value - INTEGER(I4B), INTENT(IN) :: idofvalue - !! local degree of freedom of physical variable for value - END SUBROUTINE obj_GetValue7 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. -! -!@note -! The size of idofobj and idofvalue should be equal. -!@endnote - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue8(obj, dofobj, ivarobj, idofobj, & - VALUE, dofvalue, ivarvalue, idofvalue) - TYPE(RealVector_), INTENT(IN) :: obj - !! Real vector whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object for obj - INTEGER(I4B), INTENT(IN) :: ivarobj - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: idofobj(:) - !! local degree of freedom of physical variable for obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - !! values to be returned - TYPE(DOF_), INTENT(IN) :: dofvalue - !! degree of freedom object for value - INTEGER(I4B), INTENT(IN) :: ivarvalue - !! physical variable for value - INTEGER(I4B), INTENT(IN) :: idofvalue(:) - !! local degree of freedom of physical variable for value - END SUBROUTINE obj_GetValue8 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue9(obj, dofobj, ivarobj, & - spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, & - spaceCompoValue, timeCompoValue) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivarobj - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: spaceCompoObj - !! space component for obj - INTEGER(I4B), INTENT(IN) :: timeCompoObj - !! time component for obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - !! values to be returned - TYPE(DOF_), INTENT(IN) :: dofvalue - !! dof for value - INTEGER(I4B), INTENT(IN) :: ivarvalue - !! physical variable for value - INTEGER(I4B), INTENT(IN) :: spaceCompoValue - !! space component for value - INTEGER(I4B), INTENT(IN) :: timeCompoValue - !! time component for value - END SUBROUTINE obj_GetValue9 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue10(obj, dofobj, ivarobj, & - spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, & - spaceCompoValue, timeCompoValue) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivarobj - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: spaceCompoObj - !! space component for obj - INTEGER(I4B), INTENT(IN) :: timeCompoObj(:) - !! time component for obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - !! values to be returned - TYPE(DOF_), INTENT(IN) :: dofvalue - !! dof value - INTEGER(I4B), INTENT(IN) :: ivarvalue - !! physical variable for value - INTEGER(I4B), INTENT(IN) :: spaceCompoValue - !! space compoenent for value - INTEGER(I4B), INTENT(IN) :: timeCompoValue(:) - !! time component for value - END SUBROUTINE obj_GetValue10 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Jan 2022 -! summary: Returns a vector of real from [[RealVector_]] -! -!# Introduction -! -! This routine returns a RealVector from a subset of another -! RealVector. -! -! Both obj and value should be allocated. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue11(obj, dofobj, ivarobj, & - spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, & - spaceCompoValue, timeCompoValue) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivarobj - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: spaceCompoObj(:) - !! space component for obj - INTEGER(I4B), INTENT(IN) :: timeCompoObj - !! time component for obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - !! values to be returned - TYPE(DOF_), INTENT(IN) :: dofvalue - !! dof value - INTEGER(I4B), INTENT(IN) :: ivarvalue - !! physical variable for value - INTEGER(I4B), INTENT(IN) :: spaceCompoValue(:) - !! psace component for value - INTEGER(I4B), INTENT(IN) :: timeCompoValue - !! time component for value - END SUBROUTINE obj_GetValue11 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue12(obj, dofobj, idof, VALUE, & - storageFMT, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! global degree of freedom for obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(IN) :: storageFMT - !! storage format - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! nodenum - END SUBROUTINE obj_GetValue12 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue13(obj, dofobj, idof, VALUE, & - storageFMT) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(IN) :: storageFMT - !! stroage format - END SUBROUTINE obj_GetValue13 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue14(obj, dofobj, idof, VALUE, & - force3D) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:, :) - !! values to be returned - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D - !! force 3D - END SUBROUTINE obj_GetValue14 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue15(obj, dofobj, ivar, idof, & - VALUE, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: idof - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE - !! values to be returned - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number - END SUBROUTINE obj_GetValue15 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue16(obj, dofobj, ivar, idof, & - VALUE, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: idof - !! idof for obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - END SUBROUTINE obj_GetValue16 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue17(obj, dofobj, ivar, VALUE, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable for obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - END SUBROUTINE obj_GetValue17 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue18(obj, dofobj, ivar, spaceCompo, & - timeCompo, VALUE, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spaceCompo - INTEGER(I4B), INTENT(IN) :: timeCompo - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(IN) :: nodenum(:) - END SUBROUTINE obj_GetValue18 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue19(obj, dofobj, VALUE, idof) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_GetValue19 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue20(obj, dofobj, VALUE, ivar, idof) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_GetValue20 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue21(obj, dofobj, VALUE, ivar, & - spaceCompo, timeCompo) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spaceCompo - INTEGER(I4B), INTENT(IN) :: timeCompo - END SUBROUTINE obj_GetValue21 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue22(obj, dofobj, idof, VALUE, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: idof(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(IN) :: nodenum(:) - END SUBROUTINE obj_GetValue22 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue23(obj, dofobj, idof, VALUE) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: idof(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) - END SUBROUTINE obj_GetValue23 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 10 May 2022 -! summary: copy a realvector into another realvector - -INTERFACE GetValue - MODULE SUBROUTINE obj_GetValue24(obj, VALUE) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(RealVector_), INTENT(INOUT) :: VALUE - END SUBROUTINE obj_GetValue24 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! -! This routine is similar to the ob_GetValue12 but it does not allocate -! extra memory for value. - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_12(obj, dofobj, idof, VALUE, & - tsize, storageFMT, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total entries written to value - INTEGER(I4B), INTENT(IN) :: storageFMT - !! storage format - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! nodenum - END SUBROUTINE obj_GetValue_12 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! -! This routine is similar to the ob_GetValue13 but it does not allocate -! extra memory for value. - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_13(obj, dofobj, idof, VALUE, & - tsize, storageFMT) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total entries written to value - INTEGER(I4B), INTENT(IN) :: storageFMT - !! stroage format - END SUBROUTINE obj_GetValue_13 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! -! This routine is similar to the ob_GetValue14 but it does not allocate -! extra memory for value. - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_14(obj, dofobj, idof, VALUE, & - nrow, ncol, force3D) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written to value - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D - !! force 3D - END SUBROUTINE obj_GetValue_14 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_16(obj, dofobj, ivar, idof, & - VALUE, tsize, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: idof - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written to value - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - END SUBROUTINE obj_GetValue_16 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: This function returns a vector of real from [[RealVector_]] -! -!# Introduction -! -!@note -! This routine first computes the IDOF and then -! This routine calls obj_GetValue_12 -!@endnote - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_17(obj, dofobj, ivar, VALUE, & - tsize, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj whose value is to be extracted - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written to value - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - END SUBROUTINE obj_GetValue_17 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_18(obj, dofobj, ivar, spaceCompo, & - timeCompo, VALUE, tsize, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom for obj - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable for obj - INTEGER(I4B), INTENT(IN) :: spaceCompo - !! space component for obj - INTEGER(I4B), INTENT(IN) :: timeCompo - !! time component for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written to value - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number - END SUBROUTINE obj_GetValue_18 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_19(obj, dofobj, VALUE, tsize, idof) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(OUT) :: tsize - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_GetValue_19 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_20(obj, dofobj, VALUE, tsize, & - ivar, idof) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(OUT) :: tsize - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: idof - END SUBROUTINE obj_GetValue_20 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: This function returns a vector of real from [[RealVector_]] - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_21(obj, dofobj, VALUE, tsize, ivar, & - spaceCompo, timeCompo) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(OUT) :: tsize - INTEGER(I4B), INTENT(IN) :: ivar - INTEGER(I4B), INTENT(IN) :: spaceCompo - INTEGER(I4B), INTENT(IN) :: timeCompo - END SUBROUTINE obj_GetValue_21 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-25 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_22(obj, dofobj, idof, VALUE, & - tsize, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: idof(:) - REAL(DFP), INTENT(INOUT) :: VALUE(:) - INTEGER(I4B), INTENT(OUT) :: tsize - INTEGER(I4B), INTENT(IN) :: nodenum(:) - END SUBROUTINE obj_GetValue_22 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_23(obj, dofobj, idof, VALUE, tsize) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of entries written to value - END SUBROUTINE obj_GetValue_23 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_24(obj, dofobj, idof, VALUE, nrow, ncol, & - storageFMT, nodenum) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: nrow - !! number of rows written to value - INTEGER(I4B), INTENT(OUT) :: ncol - !! number of columns written to value - INTEGER(I4B), INTENT(IN) :: storageFMT - !! storage format can be DOF_FMT or Nodes_FMT - !! if DOF_FMT then nrow size(nodenum) and ncol size(idof) - !! if Nodes_FMT then nrow is size(idof) and ncol is size(nodenum) - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node numbers - END SUBROUTINE obj_GetValue_24 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Returns the values of degrees of freedom in a single vector -! -!# Introduction -! This subroutine extracts the values from `val` corresponding to -! degrees of freedom specified by `idof(:)` and return it in `V` -! -! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage -! format of returned vector. - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_25(obj, dofobj, idof, VALUE, nrow, ncol, & - storageFMT) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - TYPE(DOF_), INTENT(IN) :: dofobj - !! dof for obj - INTEGER(I4B), INTENT(IN) :: idof(:) - !! idof for obj - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: nrow - !! number of rows written to value - INTEGER(I4B), INTENT(OUT) :: ncol - !! number of columns written to value - INTEGER(I4B), INTENT(IN) :: storageFMT - !! storage format can be DOF_FMT or Nodes_FMT - !! if DOF_FMT then nrow size(nodenum) and ncol size(idof) - !! if Nodes_FMT then nrow is size(idof) and ncol is size(nodenum) - END SUBROUTINE obj_GetValue_25 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Get multiple values - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_26(obj, nodenum, VALUE, tsize) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! index - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written to value - END SUBROUTINE obj_GetValue_26 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Get multiple values - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_27(obj, istart, iend, stride, VALUE, tsize) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! index - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written to value - END SUBROUTINE obj_GetValue_27 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Get multiple values - -INTERFACE GetValue_ - MODULE SUBROUTINE obj_GetValue_28(obj, istart, iend, stride, VALUE, & - tsize, istart_value, iend_value, stride_value) - TYPE(RealVector_), INTENT(IN) :: obj - !! obj to extract values - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! index - REAL(DFP), INTENT(INOUT) :: VALUE(:) - !! values to be returned - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size written to value - INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value - END SUBROUTINE obj_GetValue_28 -END INTERFACE GetValue_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE RealVector_GetValueMethods diff --git a/src/modules/RealVector/src/RealVector_IOMethods.F90 b/src/modules/RealVector/src/RealVector_IOMethods.F90 deleted file mode 100644 index 7d073fd6a..000000000 --- a/src/modules/RealVector/src/RealVector_IOMethods.F90 +++ /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 -! - -MODULE RealVector_IOMethods -USE GlobalData, ONLY: I4B -USE BaseType, ONLY: RealVector_ - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -INTERFACE Display - MODULE SUBROUTINE obj_display1(obj, msg, unitno) - CLASS(RealVector_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - END SUBROUTINE obj_display1 -END INTERFACE Display - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -INTERFACE Display - MODULE SUBROUTINE obj_display2(obj, msg, unitno) - CLASS(RealVector_), INTENT(IN) :: obj(:) - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno - END SUBROUTINE obj_display2 -END INTERFACE Display - -END MODULE RealVector_IOMethods diff --git a/src/modules/RealVector/src/RealVector_Method.F90 b/src/modules/RealVector/src/RealVector_Method.F90 deleted file mode 100644 index db109b577..000000000 --- a/src/modules/RealVector/src/RealVector_Method.F90 +++ /dev/null @@ -1,45 +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: 24 Feb 2021 -! summary: This module contains methods of [[RealVector_]] data type. -! -!###Introduction -! -! This module contains methods of [[RealVector_]] data type. -! This module only contains the definition of the interfaces of these -! methods. The actual implementation is given inside the submodules. This -! modules has following submodules: -! -!@todo Documentation, testing, usage - -MODULE RealVector_Method -USE RealVector_AddMethods -USE RealVector_AppendMethods -USE RealVector_AssignMethods -USE RealVector_ComparisonMethods -USE RealVector_ConstructorMethods -USE RealVector_GetMethods -USE RealVector_GetValueMethods -USE RealVector_IOMethods -USE RealVector_Norm2Methods -USE RealVector_Norm2ErrorMethods -USE RealVector_SetMethods -USE RealVector_ShallowCopyMethods -USE RealVector_Blas1Methods -END MODULE RealVector_Method diff --git a/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 b/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 deleted file mode 100644 index 38ccc8bd6..000000000 --- a/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 +++ /dev/null @@ -1,165 +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 RealVector_Norm2ErrorMethods -USE GlobalData, ONLY: I4B, DFP -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: Norm2Error - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -INTERFACE Norm2Error - MODULE PURE FUNCTION obj_norm2error_1(obj, dofobj, ivarobj, & - idofobj, obj2, dofobj2, ivarobj2, idofobj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: ivarobj - INTEGER(I4B), INTENT(IN) :: idofobj - CLASS(RealVector_), INTENT(IN) :: obj2 - TYPE(DOF_), INTENT(IN) :: dofobj2 - INTEGER(I4B), INTENT(IN) :: ivarobj2 - INTEGER(I4B), INTENT(IN) :: idofobj2 - REAL(DFP) :: ans - END FUNCTION obj_norm2error_1 -END INTERFACE Norm2Error - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -INTERFACE Norm2Error - MODULE PURE FUNCTION obj_norm2error_2(obj, dofobj, ivarobj, & - idofobj, obj2, dofobj2, ivarobj2, idofobj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: ivarobj - INTEGER(I4B), INTENT(IN) :: idofobj(:) - CLASS(RealVector_), INTENT(IN) :: obj2 - TYPE(DOF_), INTENT(IN) :: dofobj2 - INTEGER(I4B), INTENT(IN) :: ivarobj2 - INTEGER(I4B), INTENT(IN) :: idofobj2(:) - REAL(DFP) :: ans - END FUNCTION obj_norm2error_2 -END INTERFACE Norm2Error - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -INTERFACE Norm2Error - MODULE PURE FUNCTION obj_norm2error_3(obj, dofobj, idofobj, obj2, & - dofobj2, idofobj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: idofobj - CLASS(RealVector_), INTENT(IN) :: obj2 - TYPE(DOF_), INTENT(IN) :: dofobj2 - INTEGER(I4B), INTENT(IN) :: idofobj2 - REAL(DFP) :: ans - END FUNCTION obj_norm2error_3 -END INTERFACE Norm2Error - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -INTERFACE Norm2Error - MODULE PURE FUNCTION obj_norm2error_4(obj, dofobj, idofobj, obj2, & - dofobj2, idofobj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: idofobj(:) - CLASS(RealVector_), INTENT(IN) :: obj2 - TYPE(DOF_), INTENT(IN) :: dofobj2 - INTEGER(I4B), INTENT(IN) :: idofobj2(:) - REAL(DFP) :: ans - END FUNCTION obj_norm2error_4 -END INTERFACE Norm2Error - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -INTERFACE Norm2Error - MODULE PURE FUNCTION obj_norm2error_5(obj, dofobj, ivarobj, & - spaceCompoObj, timeCompoObj, obj2, dofobj2, ivarobj2, & - spaceCompoobj2, timeCompoobj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: ivarobj - INTEGER(I4B), INTENT(IN) :: spaceCompoObj - INTEGER(I4B), INTENT(IN) :: timeCompoObj - CLASS(RealVector_), INTENT(IN) :: obj2 - TYPE(DOF_), INTENT(IN) :: dofobj2 - INTEGER(I4B), INTENT(IN) :: ivarobj2 - INTEGER(I4B), INTENT(IN) :: spaceCompoobj2 - INTEGER(I4B), INTENT(IN) :: timeCompoobj2 - REAL(DFP) :: ans - END FUNCTION obj_norm2error_5 -END INTERFACE Norm2Error - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -INTERFACE Norm2Error - MODULE PURE FUNCTION obj_norm2error_6(obj, dofobj, ivarobj, & - spaceCompoObj, timeCompoObj, obj2, dofobj2, ivarobj2, & - spaceCompoobj2, timeCompoobj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: ivarobj - INTEGER(I4B), INTENT(IN) :: spaceCompoObj - INTEGER(I4B), INTENT(IN) :: timeCompoObj(:) - CLASS(RealVector_), INTENT(IN) :: obj2 - TYPE(DOF_), INTENT(IN) :: dofobj2 - INTEGER(I4B), INTENT(IN) :: ivarobj2 - INTEGER(I4B), INTENT(IN) :: spaceCompoobj2 - INTEGER(I4B), INTENT(IN) :: timeCompoobj2(:) - REAL(DFP) :: ans - END FUNCTION obj_norm2error_6 -END INTERFACE Norm2Error - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -INTERFACE Norm2Error - MODULE PURE FUNCTION obj_norm2error_7(obj, dofobj, ivarobj, & - spaceCompoObj, timeCompoObj, obj2, dofobj2, ivarobj2, & - spaceCompoobj2, timeCompoobj2) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - INTEGER(I4B), INTENT(IN) :: ivarobj - INTEGER(I4B), INTENT(IN) :: spaceCompoObj(:) - INTEGER(I4B), INTENT(IN) :: timeCompoObj - CLASS(RealVector_), INTENT(IN) :: obj2 - TYPE(DOF_), INTENT(IN) :: dofobj2 - INTEGER(I4B), INTENT(IN) :: ivarobj2 - INTEGER(I4B), INTENT(IN) :: spaceCompoobj2(:) - INTEGER(I4B), INTENT(IN) :: timeCompoobj2 - REAL(DFP) :: ans - END FUNCTION obj_norm2error_7 -END INTERFACE Norm2Error - -END MODULE RealVector_Norm2ErrorMethods diff --git a/src/modules/RealVector/src/RealVector_Norm2Methods.F90 b/src/modules/RealVector/src/RealVector_Norm2Methods.F90 deleted file mode 100644 index 63cef3d0e..000000000 --- a/src/modules/RealVector/src/RealVector_Norm2Methods.F90 +++ /dev/null @@ -1,153 +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 RealVector_Norm2Methods -USE GlobalData, ONLY: DFP, I4B -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: Norm2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -INTERFACE Norm2 - MODULE PURE FUNCTION obj_norm2_1(obj, dof, ivar, idof) & - RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dof - !! degree of freedom - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom - REAL(DFP) :: ans - END FUNCTION obj_norm2_1 -END INTERFACE Norm2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -INTERFACE Norm2 - MODULE PURE FUNCTION obj_norm2_2(obj, dof, ivar, idof) & - RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dof - !! degree of freedom - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof(:) - !! local degree of freedom - REAL(DFP) :: ans - END FUNCTION obj_norm2_2 -END INTERFACE Norm2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -INTERFACE Norm2 - MODULE PURE FUNCTION obj_norm2_3(obj, dof, idof) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dof - !! degree of freedom - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom - REAL(DFP) :: ans - END FUNCTION obj_norm2_3 -END INTERFACE Norm2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -INTERFACE Norm2 - MODULE PURE FUNCTION obj_norm2_4(obj, dof, idof) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dof - !! degree of freedom - INTEGER(I4B), INTENT(IN) :: idof(:) - !! global degree of freedom - REAL(DFP) :: ans - END FUNCTION obj_norm2_4 -END INTERFACE Norm2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -INTERFACE Norm2 - MODULE PURE FUNCTION obj_norm2_5(obj, dof, ivar, & - spaceCompo, timeCompo) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dof - !! degree of freedom - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spaceCompo - !! space component of degree of physical variable - INTEGER(I4B), INTENT(IN) :: timeCompo - !! time component of degree of physical variable - REAL(DFP) :: ans - END FUNCTION obj_norm2_5 -END INTERFACE Norm2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -INTERFACE Norm2 - MODULE PURE FUNCTION obj_norm2_6(obj, dof, ivar, & - spaceCompo, timeCompo) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dof - !! degree of freedom - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spaceCompo - !! space component of degree of physical variable - INTEGER(I4B), INTENT(IN) :: timeCompo(:) - !! time component of degree of physical variable - REAL(DFP) :: ans - END FUNCTION obj_norm2_6 -END INTERFACE Norm2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -INTERFACE Norm2 - MODULE PURE FUNCTION obj_norm2_7(obj, dof, ivar, & - spaceCompo, timeCompo) RESULT(ans) - CLASS(RealVector_), INTENT(IN) :: obj - TYPE(DOF_), INTENT(IN) :: dof - !! degree of freedom - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spaceCompo(:) - !! space component of degree of physical variable - INTEGER(I4B), INTENT(IN) :: timeCompo - !! time component of degree of physical variable - REAL(DFP) :: ans - END FUNCTION obj_norm2_7 -END INTERFACE Norm2 - -END MODULE RealVector_Norm2Methods diff --git a/src/modules/RealVector/src/RealVector_SetMethods.F90 b/src/modules/RealVector/src/RealVector_SetMethods.F90 deleted file mode 100644 index 9510aad40..000000000 --- a/src/modules/RealVector/src/RealVector_SetMethods.F90 +++ /dev/null @@ -1,772 +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 RealVector_SetMethods -USE GlobalData, ONLY: DFP, I4B -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE -PRIVATE - -PUBLIC :: Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Set all values to given scalar -! -!# Introduction -! -!@note -! F77_Copy method from F77_Blas is called. -!@endnote - -INTERFACE Set - MODULE SUBROUTINE obj_Set1(obj, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: VALUE - END SUBROUTINE obj_Set1 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Set all values by given vector (obj=value) -! -!# Introduction -! -!@note -! F95_Copy method from F95_Blas is called. -!@endnote - -INTERFACE Set - MODULE SUBROUTINE obj_Set2(obj, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: VALUE(:) - !! the length of the vector must be equal to the length of the object - END SUBROUTINE obj_Set2 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Jan 2022 -! summary: set selected values (obj(nodenum)=VALUE) - -INTERFACE Set - MODULE SUBROUTINE obj_Set3(obj, nodenum, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - END SUBROUTINE obj_Set3 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set4(obj, nodenum, VALUE) - TYPE(Realvector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - END SUBROUTINE obj_Set4 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Jan 2022 -! summary: set selected values - -INTERFACE Set - MODULE SUBROUTINE obj_Set5(obj, nodenum, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value, the size of value should be equal to tdof * size(nodenum) - END SUBROUTINE obj_Set5 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Set range of values to a scalar - -INTERFACE Set - MODULE SUBROUTINE obj_Set6(obj, istart, iend, stride, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE - !! Scalar value - END SUBROUTINE obj_Set6 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: Set range of values to a vector - -INTERFACE Set - MODULE SUBROUTINE obj_Set7(obj, istart, iend, stride, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! ob(istart:iend:stride)=VALUE - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - END SUBROUTINE obj_Set7 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set8(obj, dofobj, nodenum, VALUE, conversion) - TYPE(Realvector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - INTEGER(I4B), INTENT(IN) :: conversion(1) - !! conversion factor, NodesToDOF, DOFToNodes - END SUBROUTINE obj_Set8 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set9(obj, dofobj, nodenum, VALUE) - TYPE(Realvector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - END SUBROUTINE obj_Set9 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set10(obj, dofobj, nodenum, VALUE, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value, - !! the size of value should be equal to size(nodenum) - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - END SUBROUTINE obj_Set10 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set11(obj, dofobj, nodenum, VALUE, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - END SUBROUTINE obj_Set11 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set12(obj, dofobj, nodenum, VALUE, ivar, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - !! the size of value should be equal to size(nodenum) - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom number in physical variable - END SUBROUTINE obj_Set12 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set13(obj, dofobj, nodenum, VALUE, ivar, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - !! obj(nodenum)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom number in physical variable - END SUBROUTINE obj_Set13 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set14(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - !! the size of value should be equal to size(nodenum) - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component number - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component number - END SUBROUTINE obj_Set14 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set15(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component number - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component number - END SUBROUTINE obj_Set15 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set16(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - !! the size of value should be equal to size(nodenum)*size(timecompo) - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component number - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time component number - END SUBROUTINE obj_Set16 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set17(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component number - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time component number - END SUBROUTINE obj_Set17 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set18(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - !! the size of value should be equal to size(nodenum)*size(spacecompo) - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! space component number of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component number of physical variable - END SUBROUTINE obj_Set18 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 June 2021 -! summary: See [[DOF_Method::dof_Set2]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set19(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum(:) - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! space component number of physical variable - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component number of physical variable - END SUBROUTINE obj_Set19 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set20(obj, dofobj, nodenum, VALUE) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - END SUBROUTINE obj_Set20 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set21(obj, dofobj, nodenum, VALUE, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - END SUBROUTINE obj_Set21 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set22(obj, dofobj, nodenum, VALUE, ivar, idof) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: idof - !! local degree of freedom number in physical variable - END SUBROUTINE obj_Set22 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set23(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component number - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component number - END SUBROUTINE obj_Set23 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set24(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo - !! space component number - INTEGER(I4B), INTENT(IN) :: timecompo(:) - !! time component number - END SUBROUTINE obj_Set24 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 June 2021 -! summary: See [[DOF_Method::dof_Set1]] - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set25(obj, dofobj, nodenum, VALUE, ivar, & - spacecompo, timecompo) - TYPE(Realvector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: nodenum - !! node number to set the value - REAL(DFP), INTENT(IN) :: VALUE - !! scalar value - INTEGER(I4B), INTENT(IN) :: ivar - !! physical variable number - INTEGER(I4B), INTENT(IN) :: spacecompo(:) - !! space component number - INTEGER(I4B), INTENT(IN) :: timecompo - !! time component number - END SUBROUTINE obj_Set25 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 June 2022 -! summary: obj1=obj2 - -INTERFACE Set - MODULE PURE SUBROUTINE obj_Set26(obj, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - TYPE(RealVector_), INTENT(IN) :: VALUE - END SUBROUTINE obj_Set26 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-29 -! summary: obj = Value -! -!# Introduction -! -! Value contains the nodal values of all dofs -! Number of cols in values should be at least equal to the total dof in obj -! Number of rows in values should be at least equal to the total nodes in obj - -INTERFACE Set - MODULE SUBROUTINE obj_Set27(obj, dofobj, VALUE) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - REAL(DFP), INTENT(IN) :: VALUE(:, :) - !! number of cols should be equal to the total dof in obj - !! number of rows should be equal to the total nodes in obj - END SUBROUTINE obj_Set27 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-29 -! summary: obj = obj + scale*VALUE - -INTERFACE Set - MODULE SUBROUTINE obj_Set28(obj, dofobj, VALUE, idof) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - REAL(DFP), INTENT(IN) :: VALUE(:) - !! number of cols should be equal to the total dof in obj - !! number of rows should be equal to the total nodes in obj - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom in dofobj - END SUBROUTINE obj_Set28 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-29 -! summary: obj = obj + scale*VALUE - -INTERFACE Set - MODULE SUBROUTINE obj_Set29(obj1, dofobj1, idof1, obj2, dofobj2, idof2) - TYPE(RealVector_), INTENT(INOUT) :: obj1 - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj1 - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof1 - !! global degree of freedom in dof1 - TYPE(RealVector_), INTENT(IN) :: obj2 - !! real vector - TYPE(DOF_), INTENT(IN) :: dofobj2 - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: idof2 - !! global degree of freedom in dof2 - END SUBROUTINE obj_Set29 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-30 -! summary: Set range of values to a scalar - -INTERFACE Set - MODULE SUBROUTINE obj_Set30(obj, dofobj, istart, iend, stride, VALUE, idof) - TYPE(RealVector_), INTENT(INOUT) :: obj - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE - !! Scalar value - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - END SUBROUTINE obj_Set30 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-30 -! summary: Set range of values to a vector - -INTERFACE Set - MODULE SUBROUTINE obj_Set31(obj, dofobj, istart, iend, stride, VALUE, idof) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! ob(istart:iend:stride)=VALUE - TYPE(DOF_), INTENT(IN) :: dofobj - !! degree of freedom object - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - INTEGER(I4B), INTENT(IN) :: idof - !! global degree of freedom number - END SUBROUTINE obj_Set31 -END INTERFACE Set - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-30 -! summary: Set range of values to a vector - -INTERFACE Set - MODULE SUBROUTINE obj_Set32(obj, istart, iend, stride, VALUE, & - istart_value, iend_value, stride_value) - TYPE(RealVector_), INTENT(INOUT) :: obj - !! ob(istart:iend:stride)=VALUE - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - !! range of values to set - REAL(DFP), INTENT(IN) :: VALUE(:) - !! vector value - INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value - !! range of values to set - END SUBROUTINE obj_Set32 -END INTERFACE Set - -END MODULE RealVector_SetMethods diff --git a/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 b/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 deleted file mode 100644 index 57663b4a1..000000000 --- a/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 +++ /dev/null @@ -1,159 +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 RealVector_ShallowCopyMethods -USE GlobalData, ONLY: DFP, I4B, REAL32, REAL64 -USE BaseType, ONLY: RealVector_, DOF_ - -IMPLICIT NONE - -PRIVATE -PUBLIC :: ShallowCopy - -!---------------------------------------------------------------------------- -! ShallowCopy@ShallowCopyMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-28 -! summary: Copy only the structure for Y = X - -INTERFACE ShallowCopy - MODULE PURE SUBROUTINE obj_ShallowCopy1a(Y, X) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) - REAL(REAL32), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy1a - - MODULE PURE SUBROUTINE obj_ShallowCopy1b(Y, X) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) - REAL(REAL64), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy1b - - MODULE PURE SUBROUTINE obj_ShallowCopy1c(Y, X) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) - REAL(REAL32), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy1c - - MODULE PURE SUBROUTINE obj_ShallowCopy1d(Y, X) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) - REAL(REAL64), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy1d -END INTERFACE ShallowCopy - -!---------------------------------------------------------------------------- -! ShallowCopy@ShallowCopyMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 |June 2021 -! summary: Copy only the structure for Y = X - -INTERFACE ShallowCopy - MODULE PURE SUBROUTINE obj_ShallowCopy2(Y, X) - TYPE(RealVector_), INTENT(INOUT) :: Y - CLASS(RealVector_), INTENT(IN) :: X - END SUBROUTINE obj_ShallowCopy2 -END INTERFACE ShallowCopy - -!---------------------------------------------------------------------------- -! ShallowCopy@ShallowCopyMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 |June 2021 -! summary: Copy only the structure for Y = X - -INTERFACE ShallowCopy - MODULE PURE SUBROUTINE obj_ShallowCopy3(Y, X) - TYPE(RealVector_), INTENT(INOUT), ALLOCATABLE :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy3 -END INTERFACE ShallowCopy - -!---------------------------------------------------------------------------- -! ShallowCopy@ShallowCopyMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 |June 2021 -! summary: Copy only the structure for Y = X - -INTERFACE ShallowCopy - MODULE PURE SUBROUTINE obj_ShallowCopy4(Y, X) - TYPE(RealVector_), INTENT(INOUT) :: Y - CLASS(RealVector_), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy4 -END INTERFACE ShallowCopy - -!---------------------------------------------------------------------------- -! ShallowCopy@ShallowCopyMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 |June 2021 -! summary: Copy only the structure for Y = X - -INTERFACE ShallowCopy - MODULE PURE SUBROUTINE obj_ShallowCopy5a(Y, X) - CLASS(RealVector_), INTENT(INOUT) :: Y - REAL(REAL32), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy5a - MODULE PURE SUBROUTINE obj_ShallowCopy5b(Y, X) - CLASS(RealVector_), INTENT(INOUT) :: Y - REAL(REAL64), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy5b -END INTERFACE ShallowCopy - -!---------------------------------------------------------------------------- -! ShallowCopy@ShallowCopyMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 |June 2021 -! summary: Copy only the structure for Y = X - -INTERFACE ShallowCopy - MODULE PURE SUBROUTINE obj_ShallowCopy6a(Y, X) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X - END SUBROUTINE obj_ShallowCopy6a - MODULE PURE SUBROUTINE obj_ShallowCopy6b(Y, X) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X - END SUBROUTINE obj_ShallowCopy6b -END INTERFACE ShallowCopy - -!---------------------------------------------------------------------------- -! ShallowCopy@ShallowCopyMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 26 |June 2021 -! summary: Copy only the structure for Y = X - -INTERFACE ShallowCopy - MODULE PURE SUBROUTINE obj_ShallowCopy7a(Y, X) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy7a - MODULE PURE SUBROUTINE obj_ShallowCopy7b(Y, X) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) - CLASS(RealVector_), INTENT(IN) :: X(:) - END SUBROUTINE obj_ShallowCopy7b -END INTERFACE ShallowCopy - -END MODULE RealVector_ShallowCopyMethods diff --git a/src/modules/STConvectiveMatrix/CMakeLists.txt b/src/modules/STConvectiveMatrix/CMakeLists.txt deleted file mode 100644 index 1728f6122..000000000 --- a/src/modules/STConvectiveMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STConvectiveMatrix_Method.F90 -) diff --git a/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 b/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 deleted file mode 100644 index 1ce08aefa..000000000 --- a/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 +++ /dev/null @@ -1,294 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE STConvectiveMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_1(test, trial, & - & term1, term2, opt, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! This option is used to create - !! ncopy Mii(I,J,a,b) - !! and Mi1(I,J,a,b) - !! and M1i(I,J,a,b) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_1 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_1 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_2(test, trial, c, crank, & - & term1, term2, opt, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! scalar FEVariable - TYPE(FEVariableScalar_), INTENT( IN ) :: crank - !! scalar variable - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! This option is used to create - !! ncopy Mii(I,J,a,b) - !! and Mi1(I,J,a,b) - !! and M1i(I,J,a,b) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_2 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_2 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_3(test, trial, c, crank, & - & term1, term2, opt, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! vector FEVariable, convective velocity - TYPE(FEVariableVector_), INTENT( IN ) :: crank - !! convective velocity - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! This option is used to create - !! ncopy Mii(I,J,a,b) - !! and Mi1(I,J,a,b) - !! and M1i(I,J,a,b) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - !! it is needed only when - !! term1=term2= {del_x, del_y, del_z, del_x_all} - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_3 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_3 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_4(test, trial, c1, c2, & - & c1rank, c2rank, term1, term2, opt, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - !! Scalar FE variable - TYPE(FEVariable_), INTENT(IN) :: c2 - !! convective velocity, vector FEVariable, - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - !! Scalar FE variable - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! vector FEVariable, - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! This option is used to create - !! ncopy Mii(I,J,a,b) - !! and Mi1(I,J,a,b) - !! and M1i(I,J,a,b) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_4 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_4 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array -! -! This is a special matrix -! it calls STCM_13a, STCM_13b, STCM_13c, STCM_13d -! it calls STCM_14a, STCM_14b, STCM_14c, STCM_14d - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_5(test, trial, c, crank, & - & term1, term2, opt) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - TYPE(FEVariableVector_), INTENT(IN) :: crank - !! convective velocity - INTEGER(I4B), INTENT(IN) :: term1 - !! - INTEGER(I4B), INTENT(IN) :: term2 - !! - INTEGER( I4B ), INTENT( IN ) :: opt(1) - !! 1 --> v(i) dNTdXt(:,:,j) - !! 2 --> dNTdXt(:,:,i) v(j) - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_5 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_5 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array -! -! This is a special matrix -! it calls STCM_15a, STCM_15b, STCM_15c, STCM_15d -! it calls STCM_16a, STCM_16b, STCM_16c, STCM_16d -! it calls STCM_17a, STCM_17b, STCM_17c, STCM_17d - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_6(test, trial, c1, & - & c2, c1rank, c2rank, term1, term2, opt, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - !! scalar FEVariable - TYPE(FEVariable_), INTENT(IN) :: c2 - !! vector FEVariable - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - !! scalar FEvariable - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank - !! vector FEVariable - INTEGER(I4B), INTENT(IN) :: term1 - !! - INTEGER(I4B), INTENT(IN) :: term2 - !! - INTEGER( I4B ), INTENT( IN ) :: opt(1) - !! 1 --> v(i) dNTdXt(:,:,j) - !! 2 --> dNTdXt(:,:,i) v(j) - CHARACTER(LEN=*), OPTIONAL, INTENT( IN ) :: projecton - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_6 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_6 -END INTERFACE STConvectiveMatrix - -END MODULE STConvectiveMatrix_Method diff --git a/src/modules/STConvectiveMatrix/src/del.inc b/src/modules/STConvectiveMatrix/src/del.inc deleted file mode 100644 index 2b1418c88..000000000 --- a/src/modules/STConvectiveMatrix/src/del.inc +++ /dev/null @@ -1,540 +0,0 @@ - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_1(test, trial, c, & - & term1, term2, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! convective velocity - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_1 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_1 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_2(test, trial, c1, c2, & - & term1, term2, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - !! Scalar FE variable - TYPE(FEVariable_), INTENT(IN) :: c2 - !! convective velocity, vector FEVariable, - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_2 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_2 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_3(test, trial, c, & - & term1, term2, ncopy, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! convective velocity - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), INTENT( IN ) :: ncopy - !! number of diagonal copies - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_3 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_3 -END INTERFACE STConvectiveMatrix - - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_4(test, trial, c1, c2, & - & term1, term2, ncopy, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - !! Scalar FE variable - TYPE(FEVariable_), INTENT(IN) :: c2 - !! convective velocity, vector FEVariable, - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), INTENT( IN ) :: ncopy - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_4 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_4 -END INTERFACE STConvectiveMatrix - - - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix - -INTERFACE - MODULE PURE FUNCTION Mat2_STConvectiveMatrix_1(test, trial, c, crank, & - & term1, term2, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - INTEGER(I4B), INTENT(IN) :: term1 - INTEGER(I4B), INTENT(IN) :: term2 - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION Mat2_STConvectiveMatrix_1 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE Mat2_STConvectiveMatrix_1 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-06 -! update: 2021-12-06 -! summary: Returns the space-time convective matrix - -INTERFACE - MODULE PURE FUNCTION Mat2_STConvectiveMatrix_2(test, trial, c1, c2, & - & term1, term2, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - INTEGER(I4B), INTENT(IN) :: term1 - INTEGER(I4B), INTENT(IN) :: term2 - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION Mat2_STConvectiveMatrix_2 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE Mat2_STConvectiveMatrix_2 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix - -INTERFACE - MODULE PURE FUNCTION Mat2_STConvectiveMatrix_3(test, trial, c, & - & term1, term2, ncopy, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - INTEGER(I4B), INTENT(IN) :: term1 - INTEGER(I4B), INTENT(IN) :: term2 - INTEGER( I4B ), INTENT( IN ) :: ncopy - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION Mat2_STConvectiveMatrix_3 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE Mat2_STConvectiveMatrix_3 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-06 -! update: 2021-12-06 -! summary: Returns the space-time convective matrix - -INTERFACE - MODULE PURE FUNCTION Mat2_STConvectiveMatrix_4(test, trial, c1, c2, & - & term1, term2, ncopy, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - INTEGER(I4B), INTENT(IN) :: term1 - INTEGER(I4B), INTENT(IN) :: term2 - INTEGER(I4B), INTENT(IN) :: ncopy - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION Mat2_STConvectiveMatrix_4 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE Mat2_STConvectiveMatrix_4 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix - -INTERFACE - MODULE PURE FUNCTION Mat2_STConvectiveMatrix_5(test, trial, c, & - & term1, term2, opt) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - INTEGER(I4B), INTENT(IN) :: term1 - INTEGER(I4B), INTENT(IN) :: term2 - INTEGER( I4B ), INTENT( IN ) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION Mat2_STConvectiveMatrix_5 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE Mat2_STConvectiveMatrix_5 -END INTERFACE ConvectiveMatrix - -!---------------------------------------------------------------------------- -! ConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-06 -! update: 2021-12-06 -! summary: Returns the space-time convective matrix - -INTERFACE - MODULE PURE FUNCTION Mat2_STConvectiveMatrix_6(test, trial, c1, c2, & - & term1, term2, opt) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - INTEGER(I4B), INTENT(IN) :: term1 - INTEGER(I4B), INTENT(IN) :: term2 - INTEGER(I4B), INTENT(IN) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION Mat2_STConvectiveMatrix_6 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE Mat2_STConvectiveMatrix_6 -END INTERFACE ConvectiveMatrix - - - -! !---------------------------------------------------------------------------- -! ! ConvectiveMatrix -! !---------------------------------------------------------------------------- - -! MODULE PROCEDURE Mat2_STConvectiveMatrix_1 -! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) -! m4 = STConvectiveMatrix(test=test, trial=trial, term1=term1, & -! & term2=term2, c=c, projecton=projecton) -! CALL convert(from=m4, to=ans) -! DEALLOCATE (m4) -! END PROCEDURE Mat2_STConvectiveMatrix_1 - -! !---------------------------------------------------------------------------- -! ! ConvectiveMatrix -! !---------------------------------------------------------------------------- - -! MODULE PROCEDURE Mat2_STConvectiveMatrix_2 -! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) -! m4 = STConvectiveMatrix(test=test, trial=trial, term1=term1, & -! & term2=term2, c1=c1, c2=c2, projecton=projecton) -! CALL convert(from=m4, to=ans) -! DEALLOCATE (m4) -! END PROCEDURE Mat2_STConvectiveMatrix_2 - -! !---------------------------------------------------------------------------- -! ! ConvectiveMatrix -! !---------------------------------------------------------------------------- - -! MODULE PROCEDURE Mat2_STConvectiveMatrix_3 -! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) -! m4 = STConvectiveMatrix(test=test, trial=trial, term1=term1, & -! & term2=term2, ncopy=ncopy, c=c, projecton=projecton) -! CALL convert(from=m4, to=ans) -! DEALLOCATE (m4) -! END PROCEDURE Mat2_STConvectiveMatrix_3 - -! !---------------------------------------------------------------------------- -! ! ConvectiveMatrix -! !---------------------------------------------------------------------------- - -! MODULE PROCEDURE Mat2_STConvectiveMatrix_4 -! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) -! m4 = STConvectiveMatrix(test=test, trial=trial, & -! & c1=c1, c2=c2, term1=term1, & -! & term2=term2, ncopy=ncopy, projecton=projecton) -! CALL convert(from=m4, to=ans) -! DEALLOCATE (m4) -! END PROCEDURE Mat2_STConvectiveMatrix_4 - - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_5(test, trial, c, crank, & - & term1, term2, opt, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - TYPE(FEVariableVector_), INTENT( IN ) :: crank - !! vector fevariable - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), INTENT( IN ) :: opt - !! number of diagonal copies - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_5 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_5 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_6(test, trial, c, crank, & - & term1, term2, ncopy, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! scalar fevariable - TYPE(FEVariableScalar_), INTENT( IN ) :: crank - !! scalar fevariable - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), INTENT( IN ) :: ncopy - !! number of diagonal copies - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_6 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_6 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_7(test, trial, & - & term1, term2, ncopy, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), INTENT( IN ) :: ncopy - !! number of diagonal copies - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_7 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_7 -END INTERFACE STConvectiveMatrix - -!---------------------------------------------------------------------------- -! STConvectiveMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-22 -! update: 2021-11-22 -! summary: Returns the space-time convective matrix in rank-4 array - -INTERFACE - MODULE PURE FUNCTION Mat4_STConvectiveMatrix_8(test, trial, c1, c2, & - & c1rank, c2rank, term1, term2, ncopy, projecton) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c1 - !! Scalar FE variable - TYPE(FEVariable_), INTENT(IN) :: c2 - !! convective velocity, vector FEVariable, - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank - INTEGER(I4B), INTENT(IN) :: term1 - !! term1 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - INTEGER(I4B), INTENT(IN) :: term2 - !! term2 denotes first order derivative in space or time - !! DEL_NONE => no derivative - !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative - !! DEL_t => time derivative - INTEGER( I4B ), INTENT( IN ) :: ncopy - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - !! "trial" take projection of C on trial - !! "test" take projection of C on test - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - !! returned finite element matrix. - END FUNCTION Mat4_STConvectiveMatrix_8 -END INTERFACE - -INTERFACE STConvectiveMatrix - MODULE PROCEDURE Mat4_STConvectiveMatrix_8 -END INTERFACE STConvectiveMatrix diff --git a/src/modules/STDiffusionMatrix/CMakeLists.txt b/src/modules/STDiffusionMatrix/CMakeLists.txt deleted file mode 100644 index ddfe703f4..000000000 --- a/src/modules/STDiffusionMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STDiffusionMatrix_Method.F90 -) diff --git a/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 b/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 deleted file mode 100644 index 333d0c149..000000000 --- a/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 +++ /dev/null @@ -1,449 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE STDiffusionMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_1(test, trial, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_1 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_1 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_2(test, trial, k, krank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: k - TYPE(FEVariableScalar_), INTENT( IN ) :: krank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_2 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_2 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_3(test, trial, k, krank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: k - TYPE(FEVariableVector_), INTENT( IN ) :: krank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_3 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_3 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_4(test, trial, k, krank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: k - TYPE(FEVariableMatrix_), INTENT( IN ) :: krank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_4 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_4 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_5(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_5 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_5 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_6(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_6 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_6 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_7(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_7 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_7 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_8(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_8 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_8 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_9(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_9 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_9 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_10(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_10 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_10 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_11(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableMatrix_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_11 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_11 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_12(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableMatrix_), INTENT( IN ) :: c1rank - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_12 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_12 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_13(test, trial, c1, c2, & - & c1rank, c2rank, opt) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableMatrix_), INTENT( IN ) :: c1rank - TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_13 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_13 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_14(test, trial, k, krank, & - & opt) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: k - TYPE(FEVariableScalar_), INTENT( IN ) :: krank - !! scalar - INTEGER( I4B ), INTENT( IN ) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_14 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_14 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_15(test, trial, k, krank, & - & opt) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: k - TYPE(FEVariableVector_), INTENT( IN ) :: krank - !! Vector - INTEGER( I4B ), INTENT( IN ) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_15 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_15 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_16(test, trial, c1, c2, & - & c1rank, c2rank, opt) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - !! scalar - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank - !! scalar - INTEGER( I4B ), INTENT( IN ) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_16 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_16 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! STDiffusionMatrix -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-17 -! update: 2021-12-17 -! summary: Space-time diffusion matrix - -INTERFACE - MODULE PURE FUNCTION mat4_STDiffusionMatrix_17(test, trial, c1, c2, & - & c1rank, c2rank, opt) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - !! Scalar - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank - !! Vector - INTEGER( I4B ), INTENT( IN ) :: opt(1) - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STDiffusionMatrix_17 -END INTERFACE - -INTERFACE STDiffusionMatrix - MODULE PROCEDURE mat4_STDiffusionMatrix_17 -END INTERFACE STDiffusionMatrix - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -END MODULE STDiffusionMatrix_Method diff --git a/src/modules/STForceVector/CMakeLists.txt b/src/modules/STForceVector/CMakeLists.txt deleted file mode 100644 index 8636615f8..000000000 --- a/src/modules/STForceVector/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STForceVector_Method.F90 -) diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 deleted file mode 100644 index ca9504944..000000000 --- a/src/modules/STForceVector/src/STForceVector_Method.F90 +++ /dev/null @@ -1,533 +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 STForceVector_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: STForceVector - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: Force vector - -INTERFACE - MODULE PURE FUNCTION STForceVector_1(test) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_1 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_1 -END INTERFACE STForceVector - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_2 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_3 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_4 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_5 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_6 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_7 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_7 -END INTERFACE STForceVector - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! summary: Force vector - -INTERFACE - MODULE PURE FUNCTION STForceVector_8(test, term1) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_8 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_8 -END INTERFACE STForceVector - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_9 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_10 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_11 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_12 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_13 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_14 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_14 -END INTERFACE STForceVector - - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_15 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_15 -END INTERFACE STForceVector - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_16 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_16 -END INTERFACE STForceVector - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_17 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_17 -END INTERFACE STForceVector - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 Jan 2022 -! 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_18 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_19 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_20 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE 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 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_21 -END INTERFACE - -INTERFACE STForceVector - MODULE PROCEDURE STForceVector_21 -END INTERFACE STForceVector - -END MODULE STForceVector_Method \ No newline at end of file diff --git a/src/modules/STMassMatrix/CMakeLists.txt b/src/modules/STMassMatrix/CMakeLists.txt deleted file mode 100644 index c50dadd9f..000000000 --- a/src/modules/STMassMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STMassMatrix_Method.F90 -) diff --git a/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 b/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 deleted file mode 100644 index a00403b9a..000000000 --- a/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 +++ /dev/null @@ -1,218 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE STMassMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: STMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE STMassMatrix - MODULE PURE FUNCTION mat4_STMassMatrix_1(test, trial, term1, term2, opt) & - & RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t, del_none - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STMassMatrix_1 -END INTERFACE STMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE STMassMatrix - MODULE PURE FUNCTION mat4_STMassMatrix_2(test, trial, term1, term2, & - & rho, rhorank, opt) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t, del_none - CLASS(FEVariable_), INTENT(IN) :: rho - TYPE(FEVariableScalar_), INTENT(IN) :: rhorank - !! Scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STMassMatrix_2 -END INTERFACE STMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE STMassMatrix - MODULE PURE FUNCTION mat4_STMassMatrix_3(test, trial, term1, term2, & - & rho, rhorank, opt) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t, del_none - CLASS(FEVariable_), INTENT(IN) :: rho - TYPE(FEVariableVector_), INTENT(IN) :: rhorank - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! 1, 2, 3, 4 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STMassMatrix_3 -END INTERFACE STMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE STMassMatrix - MODULE PURE FUNCTION mat4_STMassMatrix_4(test, trial, term1, term2, & - & rho, rhorank) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t, del_none - CLASS(FEVariable_), INTENT(IN) :: rho - TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank - !! Matrix - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STMassMatrix_4 -END INTERFACE STMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE STMassMatrix - MODULE PURE FUNCTION mat4_STMassMatrix_5(test, trial, term1, term2, & - & c1, c1rank, c2, c2rank, opt) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t, del_none - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - !! Scalar - TYPE(FEVariableScalar_), INTENT(IN) :: c2rank - !! Scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! ncopy - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STMassMatrix_5 -END INTERFACE STMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE STMassMatrix - MODULE PURE FUNCTION mat4_STMassMatrix_6(test, trial, term1, term2, & - & c1, c1rank, c2, c2rank, opt) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t, del_none - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - !! Scalar - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! 1,2,3,4 - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STMassMatrix_6 -END INTERFACE STMassMatrix - -!---------------------------------------------------------------------------- -! MassMatrix@MassMatrixMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain - -INTERFACE STMassMatrix - MODULE PURE FUNCTION mat4_STMassMatrix_7(test, trial, term1, term2, & - & c1, c1rank, c2, c2rank) RESULT(Ans) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t, del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t, del_none - CLASS(FEVariable_), INTENT(IN) :: c1 - CLASS(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - !! Scalar - TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank - !! Matrix - REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION mat4_STMassMatrix_7 -END INTERFACE STMassMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE STMassMatrix_Method diff --git a/src/modules/StiffnessMatrix/CMakeLists.txt b/src/modules/StiffnessMatrix/CMakeLists.txt deleted file mode 100644 index 8a927fe44..000000000 --- a/src/modules/StiffnessMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/StiffnessMatrix_Method.F90 -) diff --git a/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 b/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 deleted file mode 100644 index 2f9b0479a..000000000 --- a/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 +++ /dev/null @@ -1,104 +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: 6 March 2021 -! summary: This module contains method to construct finite element matrices - -MODULE StiffnessMatrix_Method -USE BaseType -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: StiffnessMatrix - -!---------------------------------------------------------------------------- -! StiffnessMatrix@StiffnessMatrixMethods -!---------------------------------------------------------------------------- - -INTERFACE StiffnessMatrix - MODULE PURE FUNCTION obj_StiffnessMatrix1(test, trial, Cijkl) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - CLASS(FEVariable_), INTENT(IN) :: Cijkl - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_StiffnessMatrix1 -END INTERFACE StiffnessMatrix - -!---------------------------------------------------------------------------- -! StiffnessMatrix@StiffnessMatrixMethods -!---------------------------------------------------------------------------- - -INTERFACE StiffnessMatrix - MODULE PURE FUNCTION obj_StiffnessMatrix2(test, trial, lambda, mu, & - & isLambdaYoungsModulus) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - !! Shape function data - CLASS(FEVariable_), INTENT(IN) :: lambda, mu - !! Two elastic parameters - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isLambdaYoungsModulus - !! if it is true then lambda is YoungsModulus - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_StiffnessMatrix2 -END INTERFACE StiffnessMatrix - -!---------------------------------------------------------------------------- -! StiffnessMatrix@StiffnessMatrixMethods -!---------------------------------------------------------------------------- - -INTERFACE StiffnessMatrix - MODULE PURE FUNCTION obj_StiffnessMatrix3(test, trial, lambda, & - & mu) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: lambda, mu - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_StiffnessMatrix3 -END INTERFACE StiffnessMatrix - -!---------------------------------------------------------------------------- -! StiffnessMatrix@StiffnessMatrixMethods -!---------------------------------------------------------------------------- - -INTERFACE StiffnessMatrix - MODULE PURE FUNCTION obj_StiffnessMatrix4(test, trial, Cijkl) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: Cijkl(:, :) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_StiffnessMatrix4 -END INTERFACE StiffnessMatrix - -!---------------------------------------------------------------------------- -! StiffnessMatrix@StiffnessMatrixMethods -!---------------------------------------------------------------------------- - -INTERFACE StiffnessMatrix - MODULE PURE FUNCTION obj_StiffnessMatrix5(test, trial, lambda, mu) & - & RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test, trial - REAL(DFP), INTENT(IN) :: lambda(:) - REAL(DFP), INTENT(IN) :: mu(:) - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_StiffnessMatrix5 -END INTERFACE StiffnessMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE StiffnessMatrix_Method diff --git a/src/modules/String/CMakeLists.txt b/src/modules/String/CMakeLists.txt deleted file mode 100644 index 353c59c03..000000000 --- a/src/modules/String/CMakeLists.txt +++ /dev/null @@ -1,38 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/String_Class.F90 - ${src_path}/String_Method.F90 -) - -# set variables used for compile definitions of targets after support check -INCLUDE(CheckFortranSourceRuns) -check_fortran_source_runs( - "program r16p_support; - integer, parameter :: r16p = selected_real_kind(33, 4931); - if(r16p < 0) stop 1; - end program r16p_support" - R16P_SUPPORTED - SRC_EXT f90) -IF(R16P_SUPPORTED) - SET(r16p_supported "-D_R16P") -ENDIF() - -LIST( APPEND TARGET_COMPILE_DEF ${r16p_supported} ) \ No newline at end of file diff --git a/src/modules/String/src/String_Class.F90 b/src/modules/String/src/String_Class.F90 deleted file mode 100644 index d186c7b07..000000000 --- a/src/modules/String/src/String_Class.F90 +++ /dev/null @@ -1,5680 +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: 21 Oct 2021 -! summary: String datatype - -MODULE String_Class -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_EOR, stdout => OUTPUT_UNIT -USE BeFor64, ONLY: b64_decode, b64_encode -USE FACE, ONLY: colorize -USE PENF, ONLY: I1P, I2P, I4P, I8P, R4P, R8P, R16P, str -IMPLICIT NONE -PRIVATE -!! -! INTEGER, PARAMETER, PUBLIC :: CK = SELECTED_CHAR_KIND('DEFAULT') -INTEGER, PARAMETER :: CK = SELECTED_CHAR_KIND('DEFAULT') -! internal parameters -CHARACTER(kind=CK, len=26), PARAMETER :: UPPER_ALPHABET = & - & 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' -CHARACTER(kind=CK, len=26), PARAMETER :: LOWER_ALPHABET = & - & 'abcdefghijklmnopqrstuvwxyz' -CHARACTER(kind=CK, len=1), PARAMETER :: SPACE = ' ' -CHARACTER(kind=CK, len=1), PARAMETER :: TAB = ACHAR(9) -CHARACTER(kind=CK, len=1), PARAMETER :: UIX_DIR_SEP = CHAR(47) -CHARACTER(kind=CK, len=1), PARAMETER :: BACKSLASH = CHAR(92) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE strjoin - MODULE PROCEDURE strjoin_strings, strjoin_characters, & - & strjoin_strings_array, strjoin_characters_array -END INTERFACE strjoin - -PUBLIC :: strjoin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! builtin overloading -INTERFACE adjustl - !< Builtin adjustl overloading. - MODULE PROCEDURE sadjustl_character -END INTERFACE adjustl - -PUBLIC :: adjustl - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE adjustr - !< Builtin adjustr overloading. - MODULE PROCEDURE sadjustr_character -END INTERFACE adjustr - -PUBLIC :: adjustr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE count - !< Builtin count overloading. - MODULE PROCEDURE count_substring -END INTERFACE - -PUBLIC :: count - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE index - MODULE PROCEDURE sindex_string_string, sindex_string_character, & - & sindex_character_string -END INTERFACE index - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE len - MODULE PROCEDURE slen -END INTERFACE len - -PUBLIC :: LEN - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE len_trim - !< Builtin len_trim overloading. - MODULE PROCEDURE slen_trim -END INTERFACE len_trim - -PUBLIC :: len_trim - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE repeat - MODULE PROCEDURE srepeat_string_string -END INTERFACE repeat - -PUBLIC :: repeat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE scan - MODULE PROCEDURE sscan_string_string, sscan_string_character, & - & sscan_character_string -END INTERFACE scan - -PUBLIC :: scan - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE trim - MODULE PROCEDURE strim -END INTERFACE trim - -PUBLIC :: trim - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE verify - MODULE PROCEDURE sverify_string_string, sverify_string_character, & - & sverify_character_string -END INTERFACE verify - -PUBLIC :: verify - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE string - MODULE PROCEDURE constructor1, constructor2 -END INTERFACE string - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE display - MODULE PROCEDURE display_str -END INTERFACE display - -PUBLIC :: display - -INTERFACE Reallocate - MODULE PROCEDURE String_Reallocate1, String_Reallocate2 -END INTERFACE Reallocate - -PUBLIC :: Reallocate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 Oct 2021 -! summary: String data type -! -!# Introduction -! {!pages/docs-api/String/String_.md} - -TYPE :: String - !< OOP designed string class. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw - !! Raw data. -CONTAINS - ! public methods - ! builtins replacements - PROCEDURE, PASS(self) :: adjustl => sadjustl - !! Adjustl replacement. - PROCEDURE, PASS(self) :: adjustr => sadjustr - !! Adjustr replacement. - PROCEDURE, PASS(self) :: count => scount - !! Count replacement. - GENERIC :: index => sindex_string_string, & - sindex_string_character - !! Index replacement. - PROCEDURE, PASS(self) :: len => slen - !! Len replacement. - PROCEDURE, PASS(self) :: len_trim => slen_trim - !! Len_trim replacement. - GENERIC :: repeat => srepeat_string_string, & - srepeat_character_string - !! Repeat replacement. - GENERIC :: scan => sscan_string_string, & - sscan_string_character - !! Scan replacement. - PROCEDURE, PASS(self) :: trim => strim - !! Trim replacement. - GENERIC :: verify => sverify_string_string, & - sverify_string_character - !! Verify replacement. - ! auxiliary methods - PROCEDURE, PASS(self) :: basedir - !! Return the base directory name of a string containing a file name. - PROCEDURE, PASS(self) :: basename - !! Return the base file name of a string containing a file name. - PROCEDURE, PASS(self) :: camelcase - !! Return a string with all words capitalized without spaces. - PROCEDURE, PASS(self) :: capitalize - !! Return a string with its first character capitalized and the rest - !! lowercased. - PROCEDURE, PASS(self) :: chars - !! Return the raw characters data. - GENERIC :: colorize => colorize_str - !! Colorize and stylize strings. - PROCEDURE, PASS(self) :: decode - !! Decode string. - PROCEDURE, PASS(self) :: encode - !! Encode string. - PROCEDURE, PASS(self) :: escape - !! Escape backslashes (or custom escape character). - PROCEDURE, PASS(self) :: extension - !! Return the extension of a string containing a file name. - PROCEDURE, PASS(self) :: fill - !! Pad string on the left (or right) with zeros (or other char) to fill - !! width. - PROCEDURE, PASS(self) :: free - !! Free dynamic memory. - GENERIC :: glob => & - glob_character, & - glob_string - !! Glob search, finds all the pathnames matching a given pattern. - GENERIC :: insert => & - insert_string, & - insert_character - !! Insert substring into string at a specified position. - GENERIC :: join => & - join_strings, & - join_characters - !! Return a string that is a join of an array of strings or characters. - GENERIC :: strjoin => & - strjoin_strings, & - strjoin_characters, & - strjoin_strings_array, & - strjoin_characters_array - !! Return a string that is a join of an array of strings or characters; - !! Return join 1D string array of an 2D array of strings or - !! characters in columns or rows. - PROCEDURE, PASS(self) :: lower - !! Return a string with all lowercase characters. - PROCEDURE, PASS(self) :: partition - !! Split string at separator and return the 3 parts (before, the - !! separator and after). - PROCEDURE, PASS(self) :: read_file - !! Read a file a single string stream. - GENERIC, PUBLIC :: readFile => read_file - !! Generic function for reading file - PROCEDURE, PASS(self) :: read_line - !! Read line (record) from a connected unit. - GENERIC, PUBLIC :: readLine => read_line - !! Generic method for reading a record from file - PROCEDURE, PASS(self) :: read_lines - !! Read (all) lines (records) from a connected unit as a single ascii - !! stream. - GENERIC, PUBLIC :: readLines => read_lines - !! Generic method for reading all lines from a file - PROCEDURE, PASS(self) :: replace - !! Return a string with all occurrences of substring old replaced by new. - PROCEDURE, PASS(self) :: reverse - !! Return a reversed string. - PROCEDURE, PASS(self) :: search - !! Search for *tagged* record into string. - PROCEDURE, PASS(self) :: slice - !! Return the raw characters data sliced. - PROCEDURE, PASS(self) :: snakecase - !! Return a string with all words lowercase separated by "_". - PROCEDURE, PASS(self) :: split - !! Return a list of substring in the string, using sep as the - !! delimiter string. - PROCEDURE, PASS(self) :: split_chunked - !! Return a list of substring in the string, using sep as the - !! delimiter string. - PROCEDURE, PASS(self) :: startcase - !! Return a string with all words capitalized, e.g. title case. - PROCEDURE, PASS(self) :: strip - !! Return a string with the leading and trailing characters removed. - PROCEDURE, PASS(self) :: swapcase - !! Return a string with uppercase chars converted to lowercase - !! and vice versa. - PROCEDURE, PASS(self) :: tempname - !! Return a safe temporary name suitable for temporary file - !! or directories. - GENERIC :: to_number => & - to_integer_I1P, & -#ifndef _NVF - to_integer_I2P, & -#endif - to_integer_I4P, & - to_integer_I8P, & -#ifdef _R16P - to_real_R16P, & -#endif - to_real_R8P, & - to_real_R4P - !! Cast string to number. - PROCEDURE, PASS(self) :: unescape - !! Unescape double backslashes (or custom escaped character). - PROCEDURE, PASS(self) :: unique - !! Reduce to one (unique) multiple occurrences of a substring into - !! a string. - PROCEDURE, PASS(self) :: upper - !! Return a string with all uppercase characters. - PROCEDURE, PASS(self) :: write_file - !! Write a single string stream into file. - PROCEDURE, PASS(self) :: write_line - !! Write line (record) to a connected unit. - PROCEDURE, PASS(self) :: write_lines - !! Write lines (records) to a connected unit. - ! inquire methods - PROCEDURE, PASS(self) :: end_with - !! Return true if a string ends with a specified suffix. - PROCEDURE, PASS(self) :: is_allocated - !! Return true if the string is allocated. - PROCEDURE, PASS(self) :: is_digit - !! Return true if all characters in the string are digits. - PROCEDURE, PASS(self) :: is_integer - !! Return true if the string contains an integer. - PROCEDURE, PASS(self) :: is_number - !! Return true if the string contains a number (real or integer). - PROCEDURE, PASS(self) :: is_real - !! Return true if the string contains an real. - PROCEDURE, PASS(self) :: is_logical - !! Return true if the string contains logical. - PROCEDURE, PASS(self) :: is_lower - !! Return true if all characters in the string are lowercase. - PROCEDURE, PASS(self) :: is_upper - !! Return true if all characters in the string are uppercase. - PROCEDURE, PASS(self) :: start_with - !! Return true if a string starts with a specified prefix. - ! operators - GENERIC :: ASSIGNMENT(=) => string_assign_string, & - string_assign_character, & - string_assign_integer_I1P, & - string_assign_integer_I2P, & - string_assign_integer_I4P, & - string_assign_integer_I8P, & -#ifdef _R16P - string_assign_real_R16P, & -#endif - string_assign_real_R8P, & - string_assign_real_R4P - !! Assignment operator overloading. - GENERIC :: OPERATOR(//) => & - & string_concat_string, & - & string_concat_character, & - & character_concat_string - !! Concatenation operator overloading. - GENERIC :: OPERATOR(.cat.) => & - & string_concat_string_string, & - & string_concat_character_string, & - & character_concat_string_string - !! Concatenation operator (string output) overloading. - GENERIC :: OPERATOR(==) => string_eq_string, & - string_eq_character, & - character_eq_string - !! Equal operator overloading. - GENERIC :: OPERATOR(/=) => string_ne_string, & - string_ne_character, & - character_ne_string - !! Not equal operator overloading. - GENERIC :: OPERATOR(<) => string_lt_string, & - string_lt_character, & - character_lt_string - !! Lower than operator overloading. - GENERIC :: OPERATOR(<=) => string_le_string, & - string_le_character, & - character_le_string - !! Lower equal than operator overloading. - GENERIC :: OPERATOR(>=) => string_ge_string, & - string_ge_character, & - character_ge_string - !! Greater equal than operator overloading. - GENERIC :: OPERATOR(>) => string_gt_string, & - string_gt_character, & - character_gt_string - !! Greater than operator overloading. - ! IO - GENERIC :: READ (formatted) => read_formatted - !! Formatted input. - GENERIC :: WRITE (formatted) => write_formatted - !! Formatted output. - GENERIC :: READ (unformatted) => read_unformatted - !! Unformatted input. - GENERIC :: WRITE (unformatted) => write_unformatted - !! Unformatted output. - PROCEDURE, PUBLIC, PASS(self) :: Display => display_str - ! private methods - ! builtins replacements - PROCEDURE, PRIVATE, PASS(self) :: sindex_string_string - !! Index replacement. - PROCEDURE, PRIVATE, PASS(self) :: sindex_string_character - !! Index replacement. - PROCEDURE, PRIVATE, PASS(self) :: srepeat_string_string - !! Repeat replacement. - PROCEDURE, PRIVATE, NOPASS :: srepeat_character_string - !! Repeat replacement. - PROCEDURE, PRIVATE, PASS(self) :: sscan_string_string - !! Scan replacement. - PROCEDURE, PRIVATE, PASS(self) :: sscan_string_character - !! Scan replacement. - PROCEDURE, PRIVATE, PASS(self) :: sverify_string_string - !! Verify replacement. - PROCEDURE, PRIVATE, PASS(self) :: sverify_string_character - !! Verify replacement. - ! auxiliary methods - PROCEDURE, PRIVATE, PASS(self) :: colorize_str - !! Colorize and stylize strings. - PROCEDURE, PRIVATE, PASS(self) :: glob_character - !! Glob search (character output). - PROCEDURE, PRIVATE, PASS(self) :: glob_string - !! Glob search (string output). - PROCEDURE, PRIVATE, PASS(self) :: insert_string - !! Insert substring into string at a specified position. - PROCEDURE, PRIVATE, PASS(self) :: insert_character - !! Insert substring into string at a specified position. - PROCEDURE, PRIVATE, PASS(self) :: join_strings - !! Return join string of an array of strings. - PROCEDURE, PRIVATE, PASS(self) :: join_characters - !! Return join string of an array of characters. - PROCEDURE, PRIVATE, NOPASS :: strjoin_strings - !! Return join string of an array of strings. - PROCEDURE, PRIVATE, NOPASS :: strjoin_characters - !! Return join string of an array of strings. - PROCEDURE, PRIVATE, NOPASS :: strjoin_strings_array - !! Return join 1D string array of an 2D array of strings in columns - !! or rows. - PROCEDURE, PRIVATE, NOPASS :: strjoin_characters_array - !! Return join 1D string array of an 2D array of characters in columns - !! or rows. - PROCEDURE, PRIVATE, PASS(self) :: to_integer_I1P - !! Cast string to integer. -#ifndef _NVF - PROCEDURE, PRIVATE, PASS(self) :: to_integer_I2P - !! Cast string to integer. -#endif - PROCEDURE, PRIVATE, PASS(self) :: to_integer_I4P - !! Cast string to integer. - PROCEDURE, PRIVATE, PASS(self) :: to_integer_I8P - !! Cast string to integer. - PROCEDURE, PRIVATE, PASS(self) :: to_real_R4P - !! Cast string to real. - PROCEDURE, PRIVATE, PASS(self) :: to_real_R8P - !! Cast string to real. - PROCEDURE, PRIVATE, PASS(self) :: to_real_R16P - !! Cast string to real. - PROCEDURE, PUBLIC, PASS(self) :: to_logical - !! Convert a string to logical - ! assignments - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_string - !! Assignment operator from string input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_character - !! Assignment operator from character input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I1P - !! Assignment operator from integer input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I2P - !! Assignment operator from integer input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I4P - !! Assignment operator from integer input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I8P - !! Assignment operator from integer input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_real_R4P - !! Assignment operator from real input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_real_R8P - !! Assignment operator from real input. - PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_real_R16P - !! Assignment operator from real input. - ! concatenation operators - PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_string - !! Concatenation with string. - PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_character - !! Concatenation with character. - PROCEDURE, PRIVATE, PASS(rhs) :: character_concat_string - !! Concatenation with character (inverted). - PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_string_string - !! Concatenation with string (string output). - PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_character_string - !! Concatenation with character (string output). - PROCEDURE, PRIVATE, PASS(rhs) :: character_concat_string_string - !! Concatenation with character (inverted, string output). - !! logical operators - PROCEDURE, PRIVATE, PASS(lhs) :: string_eq_string - !! Equal to string logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_eq_character - !! Equal to character logical operator. - PROCEDURE, PRIVATE, PASS(rhs) :: character_eq_string - !! Equal to character (inverted) logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_ne_string - !! Not equal to string logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_ne_character - !! Not equal to character logical operator. - PROCEDURE, PRIVATE, PASS(rhs) :: character_ne_string - !! Not equal to character (inverted) logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_lt_string - !! Lower than to string logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_lt_character - !! Lower than to character logical operator. - PROCEDURE, PRIVATE, PASS(rhs) :: character_lt_string - !! Lower than to character (inverted) logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_le_string - !! Lower equal than to string logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_le_character - !! Lower equal than to character logical operator. - PROCEDURE, PRIVATE, PASS(rhs) :: character_le_string - !! Lower equal than to character (inverted) logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_ge_string - !! Greater equal than to string logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_ge_character - !! Greater equal than to character logical operator. - PROCEDURE, PRIVATE, PASS(rhs) :: character_ge_string - !! Greater equal than to character (inverted) logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_gt_string - !! Greater than to string logical operator. - PROCEDURE, PRIVATE, PASS(lhs) :: string_gt_character - !! Greater than to character logical operator. - PROCEDURE, PRIVATE, PASS(rhs) :: character_gt_string - !! Greater than to character (inverted) logical operator. - !! IO - PROCEDURE, PRIVATE, PASS(dtv) :: read_formatted - !! Formatted input. - PROCEDURE, PRIVATE, PASS(dtv) :: read_delimited - !! Read a delimited input. - PROCEDURE, PRIVATE, PASS(dtv) :: read_undelimited - !! Read an undelimited input. - PROCEDURE, PRIVATE, PASS(dtv) :: read_undelimited_listdirected - !! Read an undelimited list directed input. - PROCEDURE, PRIVATE, PASS(dtv) :: write_formatted - !! Formatted output. - PROCEDURE, PRIVATE, PASS(dtv) :: read_unformatted - !! Unformatted input. - PROCEDURE, PRIVATE, PASS(dtv) :: write_unformatted - !! Unformatted output. - PROCEDURE, PRIVATE, PASS(self) :: replace_one_occurrence - !! Replace the first occurrence of substring old by new. - PROCEDURE, PRIVATE, PASS(obj) :: nmatchstr_1, nmatchstr_2 - GENERIC, PUBLIC :: nmatchstr => nmatchstr_1, nmatchstr_2 - PROCEDURE, PRIVATE, PASS(obj) :: strfind_1, strfind_2 - GENERIC, PUBLIC :: strfind => strfind_1, strfind_2 -END TYPE string - -PUBLIC :: String - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE(String), PUBLIC, PARAMETER :: TypeString = String(raw=NULL()) - -TYPE :: StringPointer_ - CLASS(String), POINTER :: ptr => NULL() -END TYPE StringPointer_ -PUBLIC :: StringPointer_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 26 July 2022 -! summary: Overloading glob procedure. -! -! -!```fortran -! type(string) :: astring -! character(len=:), allocatable :: alist_chr(:) -! type(string), allocatable :: alist_str(:) -! integer, parameter :: Nf=5 -! character(14) :: files(1:Nf) -! integer :: file_unit -! integer :: f -! integer :: ff -! logical :: test_passed -! do f=1, Nf -! files(f) = astring%tempname(prefix='foo-') -! open(newunit=file_unit, file=files(f)) -! write(file_unit, *)f -! close(unit=file_unit) -! enddo -! call glob(self=astring, pattern='foo-*', list=alist_chr) -! call glob(self=astring, pattern='foo-*', list=alist_str) -! do f=1, Nf -! open(newunit=file_unit, file=files(f)) -! close(unit=file_unit, status='delete') -! enddo -! test_passed = .false. -! outer_chr: do f=1, size(alist_chr, dim=1) -! do ff=1, Nf -! test_passed = alist_chr(f) == files(ff) -! if (test_passed) cycle outer_chr -! enddo -! enddo outer_chr -! if (test_passed) then -! test_passed = .false. -! outer_str: do f=1, size(alist_str, dim=1) -! do ff=1, Nf -! test_passed = alist_str(f) == files(ff) -! if (test_passed) cycle outer_str -! enddo -! enddo outer_str -! endif -! print '(L1)', test_passed -!``` - -INTERFACE glob - MODULE PROCEDURE glob_character, glob_string -END INTERFACE glob - -PUBLIC :: glob - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS -! public non TBP - -! creator -PURE FUNCTION string_(c) - !< Return a string given a character input. - !< - !<```fortran - !< print "(L1)", string('Hello World')//''=='Hello World' - !<``` - !=> T <<< - CHARACTER(*), INTENT(IN) :: c !< Character. - TYPE(string) :: string_ !< String. - - string_%raw = c -END FUNCTION string_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! builtins replacements -PURE FUNCTION sadjustl_character(s) RESULT(adjusted) - !< Left adjust a string by removing leading spaces (character output). - !< - !<```fortran - !< type(string) :: astring - !< astring = ' Hello World!' - !< print "(L1)", adjustl(astring)=='Hello World! ' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: s !< String. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: adjusted !< Adjusted string. - - IF (ALLOCATED(s%raw)) adjusted = ADJUSTL(s%raw) -END FUNCTION sadjustl_character - -PURE FUNCTION sadjustr_character(s) RESULT(adjusted) - !< Right adjust a string by removing leading spaces (character output). - !< - !<```fortran - !< type(string) :: astring - !< astring = 'Hello World! ' - !< print "(L1)", adjustr(astring)==' Hello World!' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: s !< String. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: adjusted !< Adjusted string. - - IF (ALLOCATED(s%raw)) adjusted = ADJUSTR(s%raw) -END FUNCTION sadjustr_character - -ELEMENTAL FUNCTION count_substring(s, substring) RESULT(No) - !< Count the number of occurences of a substring into a string. - !< - !<```fortran - !< print "(L1)", count('hello', substring='ll')==1 - !<``` - !=> T <<< - CHARACTER(*), INTENT(IN) :: s !< String. - CHARACTER(*), INTENT(IN) :: substring !< Substring. - INTEGER(I4P) :: No !< Number of occurrences. - INTEGER(I4P) :: c1 !< Counters. - INTEGER(I4P) :: c2 !< Counters. - - No = 0 - IF (LEN(substring) > LEN(s)) RETURN - c1 = 1 - DO - c2 = INDEX(string=s(c1:), substring=substring) - IF (c2 == 0) RETURN - No = No + 1 - c1 = c1 + c2 + LEN(substring) - END DO -END FUNCTION count_substring - -ELEMENTAL FUNCTION sindex_character_string(s, substring, back) RESULT(i) - !< Return the position of the start of the first occurrence of string `substring` as a substring in `string`, counting from one. - !< If `substring` is not present in `string`, zero is returned. If the back argument is present and true, the return value is - !< the start of the last occurrence rather than the first. - !< - !<```fortran - !< type(string) :: string1 - !< logical :: test_passed(2) - !< string1 = 'llo' - !< test_passed(1) = index(s='Hello World Hello!', substring=string1)==index(string='Hello World Hello!', substring='llo') - !< test_passed(2) = index(s='Hello World Hello!', substring=string1, back=.true.)==index(string='Hello World Hello!', & - !< substring='llo', back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: s !< String. - TYPE(string), INTENT(IN) :: substring !< Searched substring. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(substring%raw)) THEN - i = INDEX(string=s, substring=substring%raw, back=back) - ELSE - i = 0 - END IF -END FUNCTION sindex_character_string - -ELEMENTAL FUNCTION sscan_character_string(s, set, back) RESULT(i) - !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is in `set`. - !< - !<```fortran - !< type(string) :: string1 - !< logical :: test_passed(2) - !< string1 = 'llo' - !< test_passed(1) = scan(s='Hello World Hello!', set=string1)==scan(string='Hello World Hello!', set='llo') - !< test_passed(2) = scan(s='Hello World Hello!', set=string1, back=.true.)==scan(string='Hello World Hello!', & - !< set='llo', back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: s !< String. - TYPE(string), INTENT(IN) :: set !< Searched set. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(set%raw)) THEN - i = SCAN(string=s, set=set%raw, back=back) - ELSE - i = 0 - END IF -END FUNCTION sscan_character_string - -ELEMENTAL FUNCTION sverify_character_string(s, set, back) RESULT(i) - !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is not - !< in `set`. If all characters of `string` are found in `set`, the result is zero. - !< - !<```fortran - !< type(string) :: string1 - !< logical :: test_passed(2) - !< string1 = 'ell' - !< test_passed(1) = verify(s='Hello World Hello!', set=string1)==verify(string='Hello World Hello!', set='llo') - !< test_passed(2) = verify(s='Hello World Hello!', set=string1, back=.true.)==verify(string='Hello World Hello!', set='llo', & - !< back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: s !< String. - TYPE(string), INTENT(IN) :: set !< Searched set. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(set%raw)) THEN - i = VERIFY(string=s, set=set%raw, back=back) - ELSE - i = 0 - END IF -END FUNCTION sverify_character_string - -! public methods - -! builtins replacements -ELEMENTAL FUNCTION sadjustl(self) RESULT(adjusted) - !< Left adjust a string by removing leading spaces. - !< - !<```fortran - !< type(string) :: astring - !< astring = ' Hello World!' - !< print "(L1)", astring%adjustl()//''=='Hello World! ' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: adjusted !< Adjusted string. - - adjusted = self - IF (ALLOCATED(adjusted%raw)) adjusted%raw = ADJUSTL(adjusted%raw) -END FUNCTION sadjustl - -ELEMENTAL FUNCTION sadjustr(self) RESULT(adjusted) - !< Right adjust a string by removing leading spaces. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'Hello World! ' - !< print "(L1)", astring%adjustr()//''==' Hello World!' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: adjusted !< Adjusted string. - - adjusted = self - IF (ALLOCATED(adjusted%raw)) adjusted%raw = ADJUSTR(adjusted%raw) -END FUNCTION sadjustr - -ELEMENTAL FUNCTION scount(self, substring, ignore_isolated) RESULT(No) - !< Count the number of occurences of a substring into a string. - !< - !< @note If `ignore_isolated` is set to true the eventual "isolated" occurences are ignored: an isolated occurrences are those - !< occurrences happening at the start of string (thus not having a left companion) or at the end of the string (thus not having a - !< right companion). - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(4) - !< astring = ' Hello World ! ' - !< test_passed(1) = astring%count(substring=' ')==10 - !< astring = 'Hello World ! ' - !< test_passed(2) = astring%count(substring=' ', ignore_isolated=.true.)==6 - !< astring = ' Hello World !' - !< test_passed(3) = astring%count(substring=' ', ignore_isolated=.true.)==6 - !< astring = ' Hello World ! ' - !< test_passed(4) = astring%count(substring=' ', ignore_isolated=.true.)==8 - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(*), INTENT(IN) :: substring !< Substring. - LOGICAL, INTENT(IN), OPTIONAL :: ignore_isolated !< Ignore "isolated" occurrences. - INTEGER :: No !< Number of occurrences. - LOGICAL :: ignore_isolated_ !< Ignore "isolated" occurrences, local variable. - INTEGER :: c1 !< Counter. - INTEGER :: c2 !< Counter. - - No = 0 - IF (ALLOCATED(self%raw)) THEN - IF (LEN(substring) > LEN(self%raw)) RETURN - ignore_isolated_ = .FALSE.; IF (PRESENT(ignore_isolated)) ignore_isolated_ = ignore_isolated - c1 = 1 - DO - c2 = INDEX(string=self%raw(c1:), substring=substring) - IF (c2 == 0) RETURN - IF (.NOT. ignore_isolated_) THEN - No = No + 1 - ELSE - IF (.NOT. ((c1 == 1 .AND. c2 == 1) & - & .OR. (c1 == LEN(self%raw) - LEN(substring) + 1))) THEN - No = No + 1 - END IF - END IF - c1 = c1 + c2 - 1 + LEN(substring) - END DO - END IF -END FUNCTION scount - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION sindex_string_string(self, substring, back) RESULT(i) - !< Return the position of the start of the first occurrence of string `substring` as a substring in `string`, counting from one. - !< If `substring` is not present in `string`, zero is returned. If the back argument is present and true, the return value is - !< the start of the last occurrence rather than the first. - !< - !<```fortran - !< type(string) :: string1 - !< type(string) :: string2 - !< logical :: test_passed(2) - !< string1 = 'Hello World Hello!' - !< string2 = 'llo' - !< test_passed(1) = string1%index(substring=string2)==index(string='Hello World Hello!', substring='llo') - !< test_passed(2) = string1%index(substring=string2, back=.true.)==index(string='Hello World Hello!', substring='llo', & - !< back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string), INTENT(IN) :: substring !< Searched substring. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(self%raw)) THEN - i = INDEX(string=self%raw, substring=substring%raw, back=back) - ELSE - i = 0 - END IF -END FUNCTION sindex_string_string - -ELEMENTAL FUNCTION sindex_string_character(self, substring, back) RESULT(i) - !< Return the position of the start of the first occurrence of string `substring` as a substring in `string`, counting from one. - !< If `substring` is not present in `string`, zero is returned. If the back argument is present and true, the return value is - !< the start of the last occurrence rather than the first. - !< - !<```fortran - !< type(string) :: string1 - !< logical :: test_passed(2) - !< string1 = 'Hello World Hello!' - !< test_passed(1) = string1%index(substring='llo')==index(string='Hello World Hello!', substring='llo') - !< test_passed(2) = string1%index(substring='llo', back=.true.)==index(string='Hello World Hello!', substring='llo', back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: substring !< Searched substring. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(self%raw)) THEN - i = INDEX(string=self%raw, substring=substring, back=back) - ELSE - i = 0 - END IF -END FUNCTION sindex_string_character - -ELEMENTAL FUNCTION slen(self) RESULT(l) - !< Return the length of a string. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'Hello World! ' - !< print "(L1)", astring%len()==len('Hello World! ') - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - INTEGER :: l !< String length. - - IF (ALLOCATED(self%raw)) THEN - l = LEN(string=self%raw) - ELSE - l = 0 - END IF -END FUNCTION slen - -ELEMENTAL FUNCTION slen_trim(self) RESULT(l) - !< Return the length of a string, ignoring any trailing blanks. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'Hello World! ' - !< print "(L1)", astring%len_trim()==len_trim('Hello World! ') - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - INTEGER :: l !< String length. - - IF (ALLOCATED(self%raw)) THEN - l = LEN_TRIM(string=self%raw) - ELSE - l = 0 - END IF -END FUNCTION slen_trim - -ELEMENTAL FUNCTION srepeat_string_string(self, ncopies) RESULT(repeated) - !< Concatenates several copies of an input string. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'x' - !< print "(L1)", astring%repeat(5)//''=='xxxxx' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< String to be repeated. - INTEGER, INTENT(IN) :: ncopies !< Number of string copies. - TYPE(string) :: repeated !< Repeated string. -#ifdef _NVF - CHARACTER(9999) :: nvf_bug !< Work around for NVFortran bug. -#endif - -#ifdef _NVF - nvf_bug = self%raw - repeated%raw = REPEAT(string=TRIM(nvf_bug), ncopies=ncopies) -#else - repeated%raw = REPEAT(string=self%raw, ncopies=ncopies) -#endif -END FUNCTION srepeat_string_string - -ELEMENTAL FUNCTION srepeat_character_string(rstring, ncopies) RESULT(repeated) - !< Concatenates several copies of an input string. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'y' - !< print "(L1)", astring%repeat('x', 5)//''=='xxxxx' - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: rstring !< String to be repeated. - INTEGER, INTENT(IN) :: ncopies !< Number of string copies. - TYPE(string) :: repeated !< Repeated string. - - repeated%raw = REPEAT(string=rstring, ncopies=ncopies) -END FUNCTION srepeat_character_string - -ELEMENTAL FUNCTION sscan_string_string(self, set, back) RESULT(i) - !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is in `set`. - !< - !<```fortran - !< type(string) :: string1 - !< type(string) :: string2 - !< logical :: test_passed(2) - !< string1 = 'Hello World Hello!' - !< string2 = 'llo' - !< test_passed(1) = string1%scan(set=string2)==scan(string='Hello World Hello!', set='llo') - !< test_passed(2) = string1%scan(set=string2, back=.true.)==scan(string='Hello World Hello!', set='llo', back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string), INTENT(IN) :: set !< Searched set. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(self%raw) .AND. ALLOCATED(set%raw)) THEN - i = SCAN(string=self%raw, set=set%raw, back=back) - ELSE - i = 0 - END IF -END FUNCTION sscan_string_string - -ELEMENTAL FUNCTION sscan_string_character(self, set, back) RESULT(i) - !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is in `set`. - !< - !<```fortran - !< type(string) :: string1 - !< logical :: test_passed(2) - !< string1 = 'Hello World Hello!' - !< test_passed(1) = string1%scan(set='llo')==scan(string='Hello World Hello!', set='llo') - !< test_passed(2) = string1%scan(set='llo', back=.true.)==scan(string='Hello World Hello!', set='llo', back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: set !< Searched set. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(self%raw)) THEN - i = SCAN(string=self%raw, set=set, back=back) - ELSE - i = 0 - END IF -END FUNCTION sscan_string_character - -ELEMENTAL FUNCTION strim(self) RESULT(trimmed) - !< Remove trailing spaces. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'Hello World! ' - !< print "(L1)", astring%trim()==trim('Hello World! ') - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: trimmed !< Trimmed string. - - trimmed = self - IF (ALLOCATED(trimmed%raw)) trimmed%raw = TRIM(trimmed%raw) -END FUNCTION strim - -ELEMENTAL FUNCTION sverify_string_string(self, set, back) RESULT(i) - !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is not - !< in `set`. If all characters of `string` are found in `set`, the result is zero. - !< - !<```fortran - !< type(string) :: string1 - !< type(string) :: string2 - !< logical :: test_passed(2) - !< string1 = 'Hello World Hello!' - !< string2 = 'llo' - !< test_passed(1) = string1%verify(set=string2)==verify(string='Hello World Hello!', set='llo') - !< test_passed(2) = string1%verify(set=string2, back=.true.)==verify(string='Hello World Hello!', set='llo', back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string), INTENT(IN) :: set !< Searched set. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(self%raw) .AND. ALLOCATED(set%raw)) THEN - i = VERIFY(string=self%raw, set=set%raw, back=back) - ELSE - i = 0 - END IF -END FUNCTION sverify_string_string - -ELEMENTAL FUNCTION sverify_string_character(self, set, back) RESULT(i) - !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is not - !< in `set`. If all characters of `string` are found in `set`, the result is zero. - !< - !<```fortran - !< type(string) :: string1 - !< logical :: test_passed(2) - !< string1 = 'Hello World Hello!' - !< test_passed(1) = string1%verify(set='llo')==verify(string='Hello World Hello!', set='llo') - !< test_passed(2) = string1%verify(set='llo', back=.true.)==verify(string='Hello World Hello!', set='llo', back=.true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: set !< Searched set. - LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. - INTEGER :: i !< Result of the search. - - IF (ALLOCATED(self%raw)) THEN - i = VERIFY(string=self%raw, set=set, back=back) - ELSE - i = 0 - END IF -END FUNCTION sverify_string_character - -! auxiliary methods -ELEMENTAL FUNCTION basedir(self, sep) - !< Return the base directory name of a string containing a file name. - !< - !<```fortran - !< type(string) :: string1 - !< logical :: test_passed(4) - !< string1 = '/bar/foo.tar.bz2' - !< test_passed(1) = string1%basedir()//''=='/bar' - !< string1 = './bar/foo.tar.bz2' - !< test_passed(2) = string1%basedir()//''=='./bar' - !< string1 = 'bar/foo.tar.bz2' - !< test_passed(3) = string1%basedir()//''=='bar' - !< string1 = '\bar\foo.tar.bz2' - !< test_passed(4) = string1%basedir(sep='\')//''=='\bar' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Directory separator. - TYPE(string) :: basedir !< Base directory name. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - INTEGER :: pos !< Character position. - - IF (ALLOCATED(self%raw)) THEN - sep_ = UIX_DIR_SEP; IF (PRESENT(sep)) sep_ = sep - basedir = self - pos = INDEX(self%raw, sep_, back=.TRUE.) - IF (pos > 0) basedir%raw = self%raw(1:pos - 1) - END IF -END FUNCTION basedir - -ELEMENTAL FUNCTION basename(self, sep, extension, strip_last_extension) - !< Return the base file name of a string containing a file name. - !< - !< Optionally, the extension is also stripped if provided or the last one if required, e.g. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(5) - !< astring = 'bar/foo.tar.bz2' - !< test_passed(1) = astring%basename()//''=='foo.tar.bz2' - !< test_passed(2) = astring%basename(extension='.tar.bz2')//''=='foo' - !< test_passed(3) = astring%basename(strip_last_extension=.true.)//''=='foo.tar' - !< astring = '\bar\foo.tar.bz2' - !< test_passed(4) = astring%basename(sep='\')//''=='foo.tar.bz2' - !< astring = 'bar' - !< test_passed(5) = astring%basename(strip_last_extension=.true.)//''=='bar' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Directory separator. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: extension !< File extension. - LOGICAL, INTENT(IN), OPTIONAL :: strip_last_extension !< Flag to enable the stripping of last extension. - TYPE(string) :: basename !< Base file name. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - INTEGER :: pos !< Character position. - - IF (ALLOCATED(self%raw)) THEN - sep_ = UIX_DIR_SEP; IF (PRESENT(sep)) sep_ = sep - basename = self - pos = INDEX(basename%raw, sep_, back=.TRUE.) - IF (pos > 0) basename%raw = self%raw(pos + 1:) - IF (PRESENT(extension)) THEN - pos = INDEX(basename%raw, extension, back=.TRUE.) - IF (pos > 0) basename%raw = basename%raw(1:pos - 1) - ELSEIF (PRESENT(strip_last_extension)) THEN - IF (strip_last_extension) THEN - pos = INDEX(basename%raw, '.', back=.TRUE.) - IF (pos > 0) basename%raw = basename%raw(1:pos - 1) - END IF - END IF - END IF -END FUNCTION basename - -ELEMENTAL FUNCTION camelcase(self, sep) - !< Return a string with all words capitalized without spaces. - !< - !< @note Multiple subsequent separators are collapsed to one occurence. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'caMeL caSe var' - !< print '(L1)', astring%camelcase()//''=='CamelCaseVar' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - TYPE(string) :: camelcase !< Camel case string. - TYPE(string), ALLOCATABLE :: tokens(:) !< String tokens. - - IF (ALLOCATED(self%raw)) THEN - CALL self%split(tokens=tokens, sep=sep) - tokens = tokens%capitalize() - camelcase = camelcase%join(array=tokens) - END IF -END FUNCTION camelcase - -ELEMENTAL FUNCTION capitalize(self) RESULT(capitalized) - !< Return a string with its first character capitalized and the rest lowercased. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'say all Hello WorLD!' - !< print '(L1)', astring%capitalize()//''=='Say all hello world!' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: capitalized !< Upper case string. - INTEGER :: c !< Character counter. - - IF (ALLOCATED(self%raw)) THEN - capitalized = self%lower() - c = INDEX(LOWER_ALPHABET, capitalized%raw(1:1)) - IF (c > 0) capitalized%raw(1:1) = UPPER_ALPHABET(c:c) - END IF -END FUNCTION capitalize - -PURE FUNCTION chars(self) RESULT(raw) - !< Return the raw characters data. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'say all Hello WorLD!' - !< print '(L1)', astring%chars()=='say all Hello WorLD!' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw !< Raw characters data. - - IF (ALLOCATED(self%raw)) THEN - raw = self%raw - ELSE - raw = '' - END IF -END FUNCTION chars - -PURE FUNCTION colorize_str(self, color_fg, color_bg, style) RESULT(colorized) - !< Colorize and stylize strings, DEFAULT kind. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'say all Hello WorLD!' - !< print '(L1)', astring%colorize(color_fg='red')=='say all Hello WorLD!' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: color_fg !< Foreground color definition. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: color_bg !< Background color definition. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: style !< Style definition. - CHARACTER(len=:), ALLOCATABLE :: colorized !< Colorized string. - - colorized = colorize(string=self%chars(), color_fg=color_fg, color_bg=color_bg, style=style) -END FUNCTION colorize_str - -ELEMENTAL FUNCTION decode(self, codec) RESULT(decoded) - !< Return a string decoded accordingly the codec. - !< - !< @note Only BASE64 codec is currently available. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'SG93IGFyZSB5b3U/' - !< print '(L1)', astring%decode(codec='base64')//''=='How are you?' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: codec !< Encoding codec. - TYPE(string) :: decoded !< Decoded string. - TYPE(string) :: codec_u !< Encoding codec in upper case string. - - IF (ALLOCATED(self%raw)) THEN - decoded = self - codec_u = codec - SELECT CASE (codec_u%upper()//'') - CASE ('BASE64') - CALL b64_decode(code=self%raw, s=decoded%raw) - END SELECT - decoded = decoded%strip(remove_nulls=.TRUE.) - END IF -END FUNCTION decode - -ELEMENTAL FUNCTION encode(self, codec) RESULT(encoded) - !< Return a string encoded accordingly the codec. - !< - !< @note Only BASE64 codec is currently available. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'How are you?' - !< print '(L1)', astring%encode(codec='base64')//''=='SG93IGFyZSB5b3U/' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: codec !< Encoding codec. - TYPE(string) :: encoded !< Encoded string. - - IF (ALLOCATED(self%raw)) THEN - encoded = codec - SELECT CASE (encoded%upper()//'') - CASE ('BASE64') - CALL b64_encode(s=self%raw, code=encoded%raw) - END SELECT - END IF -END FUNCTION encode - -ELEMENTAL FUNCTION escape(self, to_escape, esc) RESULT(escaped) - !< Escape backslashes (or custom escape character). - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(2) - !< astring = '^\s \d+\s*' - !< test_passed(1) = astring%escape(to_escape='\')//''=='^\\s \\d+\\s*' - !< test_passed(2) = astring%escape(to_escape='\', esc='|')//''=='^|\s |\d+|\s*' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=1), INTENT(IN) :: to_escape !< Character to be escaped. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: esc !< Character used to escape. - TYPE(string) :: escaped !< Escaped string. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: esc_ !< Character to escape, local variable. - INTEGER :: c !< Character counter. - - IF (ALLOCATED(self%raw)) THEN - esc_ = BACKSLASH; IF (PRESENT(esc)) esc_ = esc - escaped%raw = '' - DO c = 1, LEN(self%raw) - IF (self%raw(c:c) == to_escape) THEN - escaped%raw = escaped%raw//esc_//to_escape - ELSE - escaped%raw = escaped%raw//self%raw(c:c) - END IF - END DO - END IF -END FUNCTION escape - -ELEMENTAL FUNCTION extension(self) - !< Return the extension of a string containing a file name. - !< - !<```fortran - !< type(string) :: astring - !< astring = '/bar/foo.tar.bz2' - !< print '(L1)', astring%extension()//''=='.bz2' - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: extension !< Extension file name. - INTEGER :: pos !< Character position. - - IF (ALLOCATED(self%raw)) THEN - extension = '' - pos = INDEX(self%raw, '.', back=.TRUE.) - IF (pos > 0) extension%raw = self%raw(pos:) - END IF -END FUNCTION extension - -ELEMENTAL FUNCTION fill(self, width, right, filling_char) RESULT(filled) - !< Pad string on the left (or right) with zeros (or other char) to fill width. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(4) - !< astring = 'this is string example....wow!!!' - !< test_passed(1) = astring%fill(width=40)//''=='00000000this is string example....wow!!!' - !< test_passed(2) = astring%fill(width=50)//''=='000000000000000000this is string example....wow!!!' - !< test_passed(3) = astring%fill(width=50, right=.true.)//''=='this is string example....wow!!!000000000000000000' - !< test_passed(4) = astring%fill(width=40, filling_char='*')//''=='********this is string example....wow!!!' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - INTEGER, INTENT(IN) :: width !< Final width of filled string. - LOGICAL, INTENT(IN), OPTIONAL :: right !< Fill on the right instead of left. - CHARACTER(kind=CK, len=1), INTENT(IN), OPTIONAL :: filling_char !< Filling character (default "0"). - TYPE(string) :: filled !< Filled string. - LOGICAL :: right_ !< Fill on the right instead of left, local variable. - CHARACTER(kind=CK, len=1) :: filling_char_ !< Filling character (default "0"), local variable. - - IF (ALLOCATED(self%raw)) THEN - IF (width > LEN(self%raw)) THEN - right_ = .FALSE.; IF (PRESENT(right)) right_ = right - filling_char_ = '0'; IF (PRESENT(filling_char)) filling_char_ = filling_char - IF (.NOT. right_) THEN - filled%raw = REPEAT(filling_char_, width - LEN(self%raw))//self%raw - ELSE - filled%raw = self%raw//REPEAT(filling_char_, width - LEN(self%raw)) - END IF - END IF - END IF -END FUNCTION fill - -ELEMENTAL SUBROUTINE free(self) - !< Free dynamic memory. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'this is string example....wow!!!' - !< call astring%free - !< print '(L1)', astring%is_allocated().eqv..false. - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: self !< The string. - - IF (ALLOCATED(self%raw)) DEALLOCATE (self%raw) -END SUBROUTINE free - -SUBROUTINE glob_character(self, pattern, list) - !< Glob search (character output), finds all the pathnames matching a given pattern according to the rules used by the Unix shell. - !< - !< @note Method not portable: works only on Unix/GNU Linux OS. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: alist_chr(:) - !< integer, parameter :: Nf=5 - !< character(14) :: files(1:Nf) - !< integer :: file_unit - !< integer :: f - !< integer :: ff - !< logical :: test_passed - !< do f=1, Nf - !< files(f) = astring%tempname(prefix='foo-') - !< open(newunit=file_unit, file=files(f)) - !< write(file_unit, *)f - !< close(unit=file_unit) - !< enddo - !< call astring%glob(pattern='foo-*', list=alist_chr) - !< do f=1, Nf - !< open(newunit=file_unit, file=files(f)) - !< close(unit=file_unit, status='delete') - !< enddo - !< test_passed = .false. - !< outer_chr: do f=1, size(alist_chr, dim=1) - !< do ff=1, Nf - !< test_passed = alist_chr(f) == files(ff) - !< if (test_passed) cycle outer_chr - !< enddo - !< enddo outer_chr - !< print '(L1)', test_passed - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(*), INTENT(IN) :: pattern !< Given pattern. - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: list(:) !< List of matching pathnames. - TYPE(string), ALLOCATABLE :: list_(:) !< List of matching pathnames. - INTEGER(I4P) :: max_len !< Maximum length. - INTEGER(I4P) :: matches_number !< Matches number. - INTEGER(I4P) :: m !< Counter. - - CALL self%glob(pattern=pattern, list=list_) - IF (ALLOCATED(list_)) THEN - matches_number = SIZE(list_, dim=1) - max_len = 0 - DO m = 1, matches_number - max_len = MAX(max_len, list_(m)%LEN()) - END DO - ALLOCATE (CHARACTER(max_len) :: list(1:matches_number)) - DO m = 1, matches_number - list(m) = list_(m)%chars() - END DO - END IF -END SUBROUTINE glob_character - -SUBROUTINE glob_string(self, pattern, list) - !< Glob search (string output), finds all the pathnames matching a given pattern according to the rules used by the Unix shell. - !< - !< @note Method not portable: works only on Unix/GNU Linux OS. - !< - !<```fortran - !< type(string) :: astring - !< type(string), allocatable :: alist_str(:) - !< integer, parameter :: Nf=5 - !< character(14) :: files(1:Nf) - !< integer :: file_unit - !< integer :: f - !< integer :: ff - !< logical :: test_passed - !< - !< do f=1, Nf - !< files(f) = astring%tempname(prefix='foo-') - !< open(newunit=file_unit, file=files(f)) - !< write(file_unit, *)f - !< close(unit=file_unit) - !< enddo - !< call astring%glob(pattern='foo-*', list=alist_str) - !< do f=1, Nf - !< open(newunit=file_unit, file=files(f)) - !< close(unit=file_unit, status='delete') - !< enddo - !< test_passed = .false. - !< outer_str: do f=1, size(alist_str, dim=1) - !< do ff=1, Nf - !< test_passed = alist_str(f) == files(ff) - !< if (test_passed) cycle outer_str - !< enddo - !< enddo outer_str - !< print '(L1)', test_passed - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(*), INTENT(IN) :: pattern !< Given pattern. - TYPE(string), ALLOCATABLE, INTENT(out) :: list(:) !< List of matching pathnames. - TYPE(string) :: tempfile !< Safe temporary file. - CHARACTER(len=:), ALLOCATABLE :: tempname !< Safe temporary name. - INTEGER(I4P) :: tempunit !< Unit of temporary file. - - tempname = self%tempname() - CALL execute_command_LINE('ls -1 '//TRIM(ADJUSTL(pattern))//' > '//tempname) - CALL tempfile%read_file(file=tempname) - CALL tempfile%split(sep=NEW_LINE('a'), tokens=list) - OPEN (newunit=tempunit, file=tempname) - CLOSE (unit=tempunit, status='delete') -END SUBROUTINE glob_string - -ELEMENTAL FUNCTION insert_character(self, substring, pos) RESULT(inserted) - !< Insert substring into string at a specified position. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(5) - !< astring = 'this is string example wow!!!' - !< acharacter = '... ' - !< test_passed(1) = astring%insert(substring=acharacter, pos=1)//''=='... this is string example wow!!!' - !< test_passed(2) = astring%insert(substring=acharacter, pos=23)//''=='this is string example... wow!!!' - !< test_passed(3) = astring%insert(substring=acharacter, pos=29)//''=='this is string example wow!!!... ' - !< test_passed(4) = astring%insert(substring=acharacter, pos=-1)//''=='... this is string example wow!!!' - !< test_passed(5) = astring%insert(substring=acharacter, pos=100)//''=='this is string example wow!!!... ' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(len=*), INTENT(IN) :: substring !< Substring. - INTEGER, INTENT(IN) :: pos !< Position from which insert substring. - TYPE(string) :: inserted !< Inserted string. - INTEGER :: safepos !< Safe position from which insert substring. - - IF (ALLOCATED(self%raw)) THEN - inserted = self - safepos = MIN(MAX(1, pos), LEN(self%raw)) - IF (safepos == 1) THEN - inserted%raw = substring//self%raw - ELSEIF (safepos == LEN(self%raw)) THEN - inserted%raw = self%raw//substring - ELSE - inserted%raw = self%raw(1:safepos - 1)//substring//self%raw(safepos:) - END IF - ELSE - inserted%raw = substring - END IF -END FUNCTION insert_character - -ELEMENTAL FUNCTION insert_string(self, substring, pos) RESULT(inserted) - !< Insert substring into string at a specified position. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(5) - !< astring = 'this is string example wow!!!' - !< anotherstring = '... ' - !< test_passed(1) = astring%insert(substring=anotherstring, pos=1)//''=='... this is string example wow!!!' - !< test_passed(2) = astring%insert(substring=anotherstring, pos=23)//''=='this is string example... wow!!!' - !< test_passed(3) = astring%insert(substring=anotherstring, pos=29)//''=='this is string example wow!!!... ' - !< test_passed(4) = astring%insert(substring=anotherstring, pos=-1)//''=='... this is string example wow!!!' - !< test_passed(5) = astring%insert(substring=anotherstring, pos=100)//''=='this is string example wow!!!... ' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string), INTENT(IN) :: substring !< Substring. - INTEGER, INTENT(IN) :: pos !< Position from which insert substring. - TYPE(string) :: inserted !< Inserted string. - INTEGER :: safepos !< Safe position from which insert substring. - - IF (ALLOCATED(self%raw)) THEN - inserted = self - IF (ALLOCATED(substring%raw)) THEN - safepos = MIN(MAX(1, pos), LEN(self%raw)) - IF (safepos == 1) THEN - inserted%raw = substring%raw//self%raw - ELSEIF (safepos == LEN(self%raw)) THEN - inserted%raw = self%raw//substring%raw - ELSE - inserted%raw = self%raw(1:safepos - 1)//substring%raw//self%raw(safepos:) - END IF - END IF - ELSE - IF (ALLOCATED(substring%raw)) inserted%raw = substring%raw - END IF -END FUNCTION insert_string - -PURE FUNCTION join_strings(self, array, sep) RESULT(join) - !< Return a string that is a join of an array of strings. - !< - !< The join-separator is set equals to self if self has a value or it is set to a null string ''. This value can be overridden - !< passing a custom separator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: strings(3) - !< logical :: test_passed(5) - !< strings(1) = 'one' - !< strings(2) = 'two' - !< strings(3) = 'three' - !< test_passed(1) = (astring%join(array=strings)//''==strings(1)//strings(2)//strings(3)) - !< test_passed(2) = (astring%join(array=strings, sep='-')//''==strings(1)//'-'//strings(2)//'-'//strings(3)) - !< call strings(1)%free - !< strings(2) = 'two' - !< strings(3) = 'three' - !< test_passed(3) = (astring%join(array=strings, sep='-')//''==strings(2)//'-'//strings(3)) - !< strings(1) = 'one' - !< strings(2) = 'two' - !< call strings(3)%free - !< test_passed(4) = (astring%join(array=strings, sep='-')//''==strings(1)//'-'//strings(2)) - !< strings(1) = 'one' - !< call strings(2)%free - !< strings(3) = 'three' - !< test_passed(5) = (astring%join(array=strings, sep='-')//''==strings(1)//'-'//strings(3)) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string), INTENT(IN) :: array(1:) !< Array to be joined. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - TYPE(string) :: join !< The join of array. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - INTEGER :: a !< Counter. - - IF (ALLOCATED(self%raw)) THEN - sep_ = self%raw - ELSE - sep_ = '' - END IF - IF (PRESENT(sep)) sep_ = sep - join = '' - DO a = 2, SIZE(array, dim=1) - IF (ALLOCATED(array(a)%raw)) join%raw = join%raw//sep_//array(a)%raw - END DO - IF (ALLOCATED(array(1)%raw)) THEN - join%raw = array(1)%raw//join%raw - ELSE - join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) - END IF -END FUNCTION join_strings - -PURE FUNCTION join_characters(self, array, sep) RESULT(join) - !< Return a string that is a join of an array of characters. - !< - !< The join-separator is set equals to self if self has a value or it is set to a null string ''. This value can be overridden - !< passing a custom separator. - !< - !<```fortran - !< type(string) :: astring - !< character(5) :: characters(3) - !< logical :: test_passed(6) - !< characters(1) = 'one' - !< characters(2) = 'two' - !< characters(3) = 'three' - !< test_passed(1) = (astring%join(array=characters)//''==characters(1)//characters(2)//characters(3)) - !< test_passed(2) = (astring%join(array=characters, sep='-')//''==characters(1)//'-'//characters(2)//'-'//characters(3)) - !< characters(1) = '' - !< characters(2) = 'two' - !< characters(3) = 'three' - !< test_passed(3) = (astring%join(array=characters, sep='-')//''==characters(2)//'-'//characters(3)) - !< characters(1) = 'one' - !< characters(2) = 'two' - !< characters(3) = '' - !< test_passed(4) = (astring%join(array=characters, sep='-')//''==characters(1)//'-'//characters(2)) - !< characters(1) = 'one' - !< characters(2) = '' - !< characters(3) = 'three' - !< test_passed(5) = (astring%join(array=characters, sep='-')//''==characters(1)//'-'//characters(3)) - !< characters(1) = 'one' - !< characters(2) = 'two' - !< characters(3) = 'three' - !< astring = '_' - !< test_passed(6) = (astring%join(array=characters)//''==characters(1)//'_'//characters(2)//'_'//characters(3)) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: array(1:) !< Array to be joined. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - TYPE(string) :: join !< The join of array. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - INTEGER :: a !< Counter. - - IF (ALLOCATED(self%raw)) THEN - sep_ = self%raw - ELSE - sep_ = '' - END IF - IF (PRESENT(sep)) sep_ = sep - join = '' - DO a = 2, SIZE(array, dim=1) - IF (array(a) /= '') join%raw = join%raw//sep_//array(a) - END DO - IF (array(1) /= '') THEN - join%raw = array(1)//join%raw - ELSE - join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) - END IF -END FUNCTION join_characters - -PURE FUNCTION strjoin_strings(array, sep) RESULT(join) - !< Return a string that is a join of an array of strings. - !< - !< The join-separator is set equals to a null string '' if custom separator isn't specified. - !< - !<```fortran - !< type(string) :: strings(3) - !< logical :: test_passed(5) - !< strings(1) = 'one' - !< strings(2) = 'two' - !< strings(3) = 'three' - !< test_passed(1) = (strjoin(array=strings)//''==strings(1)//strings(2)//strings(3)) - !< test_passed(2) = (strjoin(array=strings, sep='-')//''==strings(1)//'-'//strings(2)//'-'//strings(3)) - !< call strings(1)%free - !< strings(2) = 'two' - !< strings(3) = 'three' - !< test_passed(3) = (strjoin(array=strings, sep='-')//''==strings(2)//'-'//strings(3)) - !< strings(1) = 'one' - !< strings(2) = 'two' - !< call strings(3)%free - !< test_passed(4) = (strjoin(array=strings, sep='-')//''==strings(1)//'-'//strings(2)) - !< strings(1) = 'one' - !< call strings(2)%free - !< strings(3) = 'three' - !< test_passed(5) = (strjoin(array=strings, sep='-')//''==strings(1)//'-'//strings(3)) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: array(1:) !< Array to be joined. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - TYPE(string) :: join !< The join of array. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - INTEGER :: a !< Counter. - - sep_ = '' - IF (PRESENT(sep)) sep_ = sep - join = '' - DO a = 2, SIZE(array, dim=1) - IF (ALLOCATED(array(a)%raw)) join%raw = join%raw//sep_//array(a)%raw - END DO - IF (ALLOCATED(array(1)%raw)) THEN - join%raw = array(1)%raw//join%raw - ELSE - join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) - END IF -END FUNCTION strjoin_strings - -PURE FUNCTION strjoin_characters(array, sep, is_trim) RESULT(join) - !< Return a string that is a join of an array of characters. - !< - !< The join-separator is set equals to a null string '' if custom separator isn't specified. - !< The trim function is applied to array items if optional logical is_trim variable isn't set to .false. - !< - !<```fortran - !< character(5) :: characters(3) - !< logical :: test_passed(13) - !< characters(1) = 'one' - !< characters(2) = 'two' - !< characters(3) = 'three' - !< test_passed(1) = (strjoin(array=characters)//''==trim(characters(1))//trim(characters(2))//trim(characters(3))) - !< test_passed(2) = (strjoin(array=characters, sep='-')//''==trim(characters(1))//'-'//trim(characters(2))//'-'//trim(characters(3))) - !< test_passed(3) = ( strjoin(array=characters, is_trim=.false.)//''==characters(1)//characters(2)//characters(3)) - !< test_passed(4) = ( strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(1)//'-'//characters(2)//'-'//characters(3)) - !< characters(1) = '' - !< characters(2) = 'two' - !< characters(3) = 'three' - !< test_passed(5) = (strjoin(array=characters)//''==trim(characters(2))//trim(characters(3))) - !< characters(1) = 'one' - !< characters(2) = 'two' - !< characters(3) = '' - !< test_passed(6) = (strjoin(array=characters)//''==trim(characters(1))//trim(characters(2))) - !< characters(1) = 'one' - !< characters(2) = '' - !< characters(3) = 'three' - !< test_passed(7) = (strjoin(array=characters)//''==trim(characters(1))//trim(characters(3))) - !< characters(1) = '' - !< characters(2) = 'two' - !< characters(3) = 'three' - !< test_passed(8) = (strjoin(array=characters, sep='-')//''==trim(characters(2))//'-'//trim(characters(3))) - !< characters(1) = 'one' - !< characters(2) = 'two' - !< characters(3) = '' - !< test_passed(9) = (strjoin(array=characters, sep='-')//''==trim(characters(1))//'-'//trim(characters(2))) - !< characters(1) = 'one' - !< characters(2) = '' - !< characters(3) = 'three' - !< test_passed(10) = (strjoin(array=characters, sep='-')//''==trim(characters(1))//'-'//trim(characters(3))) - !< characters(1) = '' - !< characters(2) = 'two' - !< characters(3) = 'three' - !< test_passed(11) = (strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(2)//'-'//characters(3)) - !< characters(1) = 'one' - !< characters(2) = 'two' - !< characters(3) = '' - !< test_passed(12) = (strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(1)//'-'//characters(2)) - !< characters(1) = 'one' - !< characters(2) = '' - !< characters(3) = 'three' - !< test_passed(13) = (strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(1)//'-'//characters(3)) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: array(1:) !< Array to be joined. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - LOGICAL, INTENT(IN), OPTIONAL :: is_trim !< Flag to setup trim character or not - TYPE(string) :: join !< The join of array. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - LOGICAL :: is_trim_ !< Flag to setup trim character or not - INTEGER :: a !< Counter. - - sep_ = '' - IF (PRESENT(sep)) sep_ = sep - is_trim_ = .TRUE.; IF (PRESENT(is_trim)) is_trim_ = is_trim - join = '' - - IF (is_trim_) THEN - DO a = 2, SIZE(array, dim=1) - IF (TRIM(array(a)) /= '') join%raw = join%raw//sep_//TRIM(array(a)) - END DO - IF (TRIM(array(1)) /= '') THEN - join%raw = TRIM(array(1))//join%raw - ELSE - join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) - END IF - ELSE - DO a = 2, SIZE(array, dim=1) - IF (array(a) /= '') join%raw = join%raw//sep_//array(a) - END DO - IF (array(1) /= '') THEN - join%raw = array(1)//join%raw - ELSE - join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) - END IF - END IF -END FUNCTION strjoin_characters - -PURE FUNCTION strjoin_strings_array(array, sep, is_col) RESULT(join) - !< Return a string that is a join of columns or rows of an array of strings. - !< - !< The join-separator is set equals to a null string '' if custom separator isn't specified. - !< The is_col is setup the direction of join: within default columns (.true.) or rows(.false.). - !< - !<```fortran - !< type(string), allocatable :: strings_arr(:, :) - !< logical :: test_passed(5) - !< - !< strings_arr = reshape( source = & - !< [string('one'), string('two'), string('three'), & - !< string('ONE'), string('TWO'), string('THREE')], & - !< shape = [3, 2] ) - !< - !< test_passed(1) = all( strjoin(array=strings_arr) == & - !< reshape([string('onetwothree'), string('ONETWOTHREE')], & - !< shape = [2]) ) - !< - !< test_passed(2) = all( strjoin(array=strings_arr, sep='_') == & - !< reshape([string('one_two_three'), string('ONE_TWO_THREE')], & - !< shape = [2]) ) - !< - !< test_passed(3) = all( strjoin(array=strings_arr, is_col=.false.) == & - !< reshape([string('oneONE'), string('twoTWO'), string('threeTHREE')], & - !< shape = [3]) ) - !< - !< test_passed(4) = all( strjoin(array=strings_arr, sep='_', is_col=.false.) == & - !< reshape([string('one_ONE'), string('two_TWO'), string('three_THREE')], & - !< shape = [3]) ) - !< - !< call strings_arr(2, 1)%free - !< test_passed(5) = all( strjoin(array=strings_arr, sep='_', is_col=.false.) == & - !< reshape([string('one_ONE'), string('TWO'), string('three_THREE')], & - !< shape = [3]) ) - !< - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: array(1:, 1:) !< Array to be joined. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - LOGICAL, INTENT(IN), OPTIONAL :: is_col !< Direction: 'columns' if .true. or 'rows' if .false. - TYPE(string), ALLOCATABLE :: join(:) !< The join of array. - TYPE(string), ALLOCATABLE :: slice(:) !< The column or row slice of array - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - LOGICAL :: is_col_ !< Direction, default value. - INTEGER :: a, join_size, slice_size !< Counter, sizes of join vector and of slice of array - - sep_ = ''; IF (PRESENT(sep)) sep_ = sep - is_col_ = .TRUE.; IF (PRESENT(is_col)) is_col_ = is_col - - IF (is_col_) THEN - join_size = SIZE(array, dim=2) - slice_size = SIZE(array, dim=1) - - IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) - IF (.NOT. ALLOCATED(slice)) ALLOCATE (slice(slice_size)) - DO a = 1, join_size - slice(:) = array(:, a) - join(a) = strjoin_strings(slice, sep_) - END DO - ELSE - join_size = SIZE(array, dim=1) - slice_size = SIZE(array, dim=2) - - IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) - IF (.NOT. ALLOCATED(slice)) ALLOCATE (slice(slice_size)) - DO a = 1, join_size - slice(:) = array(a, :) - join(a) = strjoin_strings(slice, sep_) - END DO - END IF -END FUNCTION strjoin_strings_array - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 21 July 2022 -! summary: Return a string that is a join of columns or rows of an array of characters -! -!# Introduction -! -! The join-separator is set equals to a null string '' if custom separator -! isn't specified. -! The trim function is applied to array items if optional logical is_trim -! variable isn't set to .false. -! The is_col is setup the direction of join: within default columns (.true.) -! or rows(.false.). -! -!```fortran -! character(len=10) :: chars_arr(3, 2) -! logical :: test_passed(9) -! chars_arr(:, 1) = ['one ', 'two ', 'three '] -! chars_arr(:, 2) = ['ONE ', 'TWO ', 'THREE '] -! -! test_passed(1) = all( strjoin(array=chars_arr) == & -! reshape([string('onetwothree'), string -! ('ONETWOTHREE')], & -! shape = [2]) ) -! -! test_passed(2) = all( strjoin(array=chars_arr, is_trim=.false.) == & -! reshape([string('one two three '), & -! string('ONE TWO THREE ')], & -! shape = [2]) ) -! -! test_passed(3) = all( strjoin(array=chars_arr, sep='_') == & -! reshape([string('one_two_three'), string -! ('ONE_TWO_THREE')], & -! shape = [2]) ) -! -! test_passed(4) = all( strjoin(array=chars_arr, sep='_', is_trim=.false.) -! == & -! reshape([string('one _two _three -! '), & -! string('ONE _TWO _THREE -! ')], & -! shape = [2]) ) -! -! test_passed(5) = all( strjoin(array=chars_arr, is_col=.false.) == & -! reshape([string('oneONE'), string('twoTWO'), string -! ('threeTHREE')], & -! shape = [3]) ) -! -! test_passed(6) = all( strjoin(array=chars_arr, is_trim=.false., is_col=. -! false.) == & -! reshape([string('one ONE '), & -! string('two TWO '), & -! string('three THREE ')], & -! shape = [3]) ) -! -! test_passed(7) = all( strjoin(array=chars_arr, sep='_', is_col=.false.) == & -! reshape([string('one_ONE'), string('two_TWO'), string -! ('three_THREE')], & -! shape = [3]) ) -! -! test_passed(8) = all( strjoin(array=chars_arr, sep='_', is_trim=.false., -! is_col=.false.) == & -! reshape([string('one _ONE '), & -! string('two _TWO '), & -! string('three _THREE ')], & -! shape = [3]) ) -! -! chars_arr(2,1) = '' -! test_passed(9) = all( strjoin(array=chars_arr, sep='_', is_col=.false.) -! == & -! reshape([string('one_ONE'), & -! string('TWO'), & -! string('three_THREE')], & -! shape = [3]) ) -! -! print '(L1)', all(test_passed) -!``` - -PURE FUNCTION strjoin_characters_array(array, sep, is_trim, is_col) & - & RESULT(join) - !! - CHARACTER(kind=CK, len=*), INTENT(IN) :: array(1:, 1:) - !! Array to be joined. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep - !! Separator. - LOGICAL, INTENT(IN), OPTIONAL :: is_trim - !! Flag to setup trim character or not - LOGICAL, INTENT(IN), OPTIONAL :: is_col - !! Direction: 'columns' if .true. or 'rows' if .false. - TYPE(string), ALLOCATABLE :: join(:) - !! The join of array. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: slice(:) - !! The column or row slice of array - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ - !! Separator, default value. - LOGICAL :: is_trim_ - !! Flag to setup trim character or not - LOGICAL :: is_col_ - !! Direction, default value. - INTEGER :: a, join_size, slice_size - !! Counter, sizes of join vector and of slice of array - INTEGER :: item_len - !! Length of array item (all items of character array have equal lengths) - !! - !! - item_len = LEN(array(1, 1)) - !! - !! all items of character array have equal lengths - !! - sep_ = ''; IF (PRESENT(sep)) sep_ = sep - is_trim_ = .TRUE.; IF (PRESENT(is_trim)) is_trim_ = is_trim - is_col_ = .TRUE.; IF (PRESENT(is_col)) is_col_ = is_col - !! - IF (is_col_) THEN - join_size = SIZE(array, dim=2) - slice_size = SIZE(array, dim=1) - !! - IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) - IF (.NOT. ALLOCATED(slice)) & - & ALLOCATE (CHARACTER(len=item_len) :: slice(slice_size)) - !! - DO a = 1, join_size - slice(:) = array(:, a) - join(a) = strjoin_characters(slice, sep_, is_trim_) - END DO - !! - ELSE - !! - join_size = SIZE(array, dim=1) - slice_size = SIZE(array, dim=2) - !! - IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) - IF (.NOT. ALLOCATED(slice)) & - & ALLOCATE (CHARACTER(len=item_len) :: slice(slice_size)) - !! - DO a = 1, join_size - slice(:) = array(a, :) - join(a) = strjoin_characters(slice, sep_, is_trim_) - END DO - END IF - !! -END FUNCTION strjoin_characters_array - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION lower(self) - !< Return a string with all lowercase characters. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 'Hello WorLD!' - !< test_passed(1) = astring%lower()//''=='hello world!' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: lower !< Upper case string. - INTEGER :: n1 !< Characters counter. - INTEGER :: n2 !< Characters counter. - - IF (ALLOCATED(self%raw)) THEN - lower = self - DO n1 = 1, LEN(self%raw) - n2 = INDEX(UPPER_ALPHABET, self%raw(n1:n1)) - IF (n2 > 0) lower%raw(n1:n1) = LOWER_ALPHABET(n2:n2) - END DO - END IF -END FUNCTION lower - -PURE FUNCTION partition(self, sep) RESULT(partitions) - !< Split string at separator and return the 3 parts (before, the separator and after). - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: strings(3) - !< logical :: test_passed(3) - !< astring = 'Hello WorLD!' - !< strings = astring%partition(sep='lo Wo') - !< test_passed(1) = (strings(1)//''=='Hel'.and.strings(2)//''=='lo Wo'.and.strings(3)//''=='rLD!') - !< strings = astring%partition(sep='Hello') - !< test_passed(2) = (strings(1)//''==''.and.strings(2)//''=='Hello'.and.strings(3)//''==' WorLD!') - !< astring = 'Hello WorLD!' - !< strings = astring%partition() - !< test_passed(3) = (strings(1)//''=='Hello'.and.strings(2)//''==' '.and.strings(3)//''=='WorLD!') - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - TYPE(string) :: partitions(1:3) !< Partions: before the separator, the separator itsels and - !< after the separator. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - INTEGER :: c !< Character counter. - - IF (ALLOCATED(self%raw)) THEN - sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep - - partitions(1) = self - partitions(2) = sep_ - partitions(3) = '' - IF (LEN(sep_) >= LEN(self%raw)) RETURN - c = INDEX(self%raw, sep_) - IF (c > 0) THEN - partitions(1)%raw = self%raw(1:c - 1) - partitions(2)%raw = self%raw(c:c + LEN(sep_) - 1) - partitions(3)%raw = self%raw(c + LEN(sep_):) - END IF - END IF -END FUNCTION partition - -!--------------------------------------------------------------------------- -! ReadFile -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 2022-12-16 -! summary: Read a file -! -!# Introduction -! -! Read a file as a single string stream. -! -! @note All the lines are stored into the string self as a single -! ascii stream. Each line (record) is separated by a `new_line` -! character. -! -!@note -! For unformatted read only `access='stream'` is supported -! with new_line as line terminator. -! -!@note -! *Fast* file reading allows a very efficient reading of -! streamed file, but it dumps file as single streamed string. -! -!```fortran -! type(string) :: astring -! type(string), allocatable :: strings(:) -! type(string) :: line(3) -! integer :: iostat -! character(len=99) :: iomsg -! integer :: scratch -! integer :: l -! logical :: test_passed(9) -! line(1) = ' Hello World! ' -! line(2) = 'How are you? ' -! line(3) = ' All say: "Fine thanks"' -! open(newunit=scratch, file='read_file_test.tmp') -! write(scratch, "(A)") line(1)%chars() -! write(scratch, "(A)") line(2)%chars() -! write(scratch, "(A)") line(3)%chars() -! close(scratch) -! call astring%read_file(file='read_file_test.tmp', & -! & iostat=iostat, iomsg=iomsg) -! call astring%split(tokens=strings, sep=new_line('a')) -! test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) -! do l=1, size(strings, dim=1) -! test_passed(l+1) = (strings(l)==line(l)) -! enddo -! open(newunit=scratch, file='read_file_test.tmp', & -! & form='UNFORMATTED', access='STREAM') -! write(scratch) line(1)%chars()//new_line('a') -! write(scratch) line(2)%chars()//new_line('a') -! write(scratch) line(3)%chars()//new_line('a') -! close(scratch) -! call astring%read_file(file='read_file_test.tmp', form='unformatted', & -! & iostat=iostat, iomsg=iomsg) -! call astring%split(tokens=strings, sep=new_line('a')) -! test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) -! do l=1, size(strings, dim=1) -! test_passed(l+5) = (strings(l)==line(l)) -! enddo -! open(newunit=scratch, file='read_file_test.tmp', form='UNFORMATTED', & -! & access='STREAM') -! close(scratch, status='DELETE') -! call astring%read_file(file='read_file_test.tmp', iostat=iostat) -! test_passed(9) = (iostat/=0) -! print '(L1)', all(test_passed) -!``` - -SUBROUTINE read_file(self, file, is_fast, form, iostat, iomsg) - CLASS(string), INTENT(inout) :: self - !! The string. - CHARACTER(len=*), INTENT(IN) :: file - !! File name. - LOGICAL, INTENT(IN), OPTIONAL :: is_fast - !! Flag to enable (super) fast file reading. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: form - !! Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat - !! IO status code. - CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg - !! IO status message. - ! - ! internal variables - ! - LOGICAL :: is_fast_ - !! Flag to enable (super) fast file reading, local variable. - TYPE(string) :: form_ - !! Format of unit, local variable. - INTEGER :: iostat_ - !! IO status code, local variable. - CHARACTER(len=:), ALLOCATABLE :: iomsg_ - !! IO status message, local variable. - INTEGER :: unit - !! Logical unit. - LOGICAL :: does_exist - !! Check if file exist. - INTEGER(I4P) :: filesize - !! Size of the file for fast reading. - ! - ! main program - ! - iomsg_ = REPEAT(' ', 99) - IF (PRESENT(iomsg)) iomsg_ = iomsg - INQUIRE (file=file, iomsg=iomsg_, iostat=iostat_, exist=does_exist) - ! - IF (does_exist) THEN - is_fast_ = .FALSE.; - IF (PRESENT(is_fast)) is_fast_ = is_fast - IF (is_fast_) THEN - OPEN (newunit=unit, file=file, & - & access='STREAM', form='UNFORMATTED', iomsg=iomsg_, iostat=iostat_) - INQUIRE (file=file, size=filesize) - IF (ALLOCATED(self%raw)) DEALLOCATE (self%raw) - ALLOCATE (CHARACTER(len=filesize) :: self%raw) - READ (unit=unit, iostat=iostat_, iomsg=iomsg_) self%raw - CLOSE (unit) - ELSE - form_ = 'FORMATTED' - IF (PRESENT(form)) form_ = form - form_ = form_%upper() - SELECT CASE (form_%chars()) - CASE ('FORMATTED') - OPEN (newunit=unit, file=file, status='OLD', & - & action='READ', iomsg=iomsg_, iostat=iostat_, err=10) - CASE ('UNFORMATTED') - OPEN (newunit=unit, file=file, status='OLD', & - & action='READ', form='UNFORMATTED', access='STREAM', & - & iomsg=iomsg_, iostat=iostat_, err=10) - END SELECT - CALL self%read_lines(unit=unit, form=form, iomsg=iomsg_, iostat=iostat_) -10 CLOSE (unit) - END IF - ELSE - iostat_ = 1 - iomsg_ = 'file not found' - END IF - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE read_file - -!---------------------------------------------------------------------------- -! readLine -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 2022-12-16 -! summary: 2022-12-16 -! -!# Introduction -! -! Read line (record) from a connected unit. -! -! The line is read as an ascii stream read until the eor -! is reached. -! -!@note -! For unformatted read only `access='stream'` is -! supported with new_line as line terminator. -!@endnote -! -!```fortran -! type(string) :: astring -! type(string) :: line(3) -! integer :: iostat -! character(len=99) :: iomsg -! integer :: scratch -! integer :: l -! logical :: test_passed(6) -! line(1) = ' Hello World! ' -! line(2) = 'How are you? ' -! line(3) = ' All say: "Fine thanks"' -! open(newunit=scratch, status='SCRATCH') -! write(scratch, "(A)") line(1)%chars() -! write(scratch, "(A)") line(2)%chars() -! write(scratch, "(A)") line(3)%chars() -! rewind(scratch) -! l = 0 -! iostat = 0 -! do -! l = l + 1 -! call astring%read_line(unit=scratch, & -! & iostat=iostat, iomsg=iomsg) -! if (iostat/=0.and..not.is_iostat_eor(iostat)) then -! exit -! else -! test_passed(l) = (astring==line(l)) -! endif -! enddo -! close(scratch) -! open(newunit=scratch, status='SCRATCH', form='UNFORMATTED', access='STREAM') -! write(scratch) line(1)%chars()//new_line('a') -! write(scratch) line(2)%chars()//new_line('a') -! write(scratch) line(3)%chars()//new_line('a') -! rewind(scratch) -! l = 0 -! iostat = 0 -! do -! l = l + 1 -! call astring%read_line(unit=scratch, & -! & iostat=iostat, iomsg=iomsg, form='UnfORMatteD') -! if (iostat/=0.and..not.is_iostat_eor(iostat)) then -! exit -! else -! test_passed(l+3) = (astring==line(l)) -! endif -! enddo -! close(scratch) -! print '(L1)', all(test_passed) -!``` - -SUBROUTINE read_line(self, unit, form, iostat, iomsg) - CLASS(string), INTENT(inout) :: self - !! The string. - INTEGER, INTENT(IN) :: unit - !! Logical unit. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: form - !! Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat - !! IO status code. - CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg - !! IO status message. - TYPE(string) :: form_ - !! Format of unit, local variable. - INTEGER :: iostat_ - !! IO status code, local variable. - CHARACTER(len=:), ALLOCATABLE :: iomsg_ - !! IO status message, local variable. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: line - !! Line storage. - CHARACTER(kind=CK, len=1) :: ch - !! Character storage. - - form_ = 'FORMATTED' - IF (PRESENT(form)) form_ = form - form_ = form_%upper() - iomsg_ = REPEAT(' ', 99) - IF (PRESENT(iomsg)) iomsg_ = iomsg - line = '' - SELECT CASE (form_%chars()) - CASE ('FORMATTED') - DO - !! - READ (unit, "(A)", advance='no', iostat=iostat_, & - & iomsg=iomsg_, err=10, END=10, eor=10) & - & ch - line = line//ch - END DO - CASE ('UNFORMATTED') - DO - READ (unit, iostat=iostat_, iomsg=iomsg_, & - & err=10, END=10) ch - IF (ch == NEW_LINE('a')) THEN - iostat_ = IOSTAT_EOR - EXIT - END IF - line = line//ch - END DO - END SELECT -10 IF (line /= '') self%raw = line - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE read_line - -! Read (all) lines (records) from a connected unit as a single ascii stream. -! -!@note -! All the lines are stored into the string self as a single ascii stream. -! Each line (record) is separated by a `new_line` -! character. The line is read as an ascii stream read until the eor -! is reached. -!@endnote -! -!@note -! The connected unit is rewinded. -! At a successful exit current record is at eof, -! at the beginning otherwise. -!@endnote -! -!@note -! For unformatted read only `access='stream'` is -! supported with new_line as line terminator. -!@endnote -! -!```fortran -! type(string) :: astring -! type(string), allocatable :: strings(:) -! type(string) :: line(3) -! integer :: iostat -! character(len=99) :: iomsg -! integer :: scratch -! integer :: l -! logical :: test_passed(8) -! -! line(1) = ' Hello World! ' -! line(2) = 'How are you? ' -! line(3) = ' All say: "Fine thanks"' -! open(newunit=scratch, status='SCRATCH') -! write(scratch, "(A)") line(1)%chars() -! write(scratch, "(A)") line(2)%chars() -! write(scratch, "(A)") line(3)%chars() -! call astring%read_lines(unit=scratch, iostat=iostat, iomsg=iomsg) -! call astring%split(tokens=strings, sep=new_line('a')) -! test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) -! do l=1, size(strings, dim=1) -! test_passed(l+1) = (strings(l)==line(l)) -! enddo -! close(scratch) -! open(newunit=scratch, status='SCRATCH', form='UNFORMATTED', access='STREAM') -! write(scratch) line(1)%chars()//new_line('a') -! write(scratch) line(2)%chars()//new_line('a') -! write(scratch) line(3)%chars()//new_line('a') -! call astring%read_lines(unit=scratch, & -! form='unformatted', iostat=iostat, iomsg=iomsg) -! call astring%split(tokens=strings, sep=new_line('a')) -! test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) -! do l=1, size(strings, dim=1) -! test_passed(l+5) = (strings(l)==line(l)) -! enddo -! close(scratch) -! print '(L1)', all(test_passed) -!``` - -SUBROUTINE read_lines(self, unit, form, iostat, iomsg) - CLASS(string), INTENT(inout) :: self - !! The string. - INTEGER, INTENT(IN) :: unit - !! Logical unit. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: form - !! Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat - !! IO status code. - CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg - !! IO status message. - INTEGER :: iostat_ - !! IO status code, local variable. - CHARACTER(len=:), ALLOCATABLE :: iomsg_ - !! IO status message, local variable. - TYPE(string) :: lines - !! Lines storage. - TYPE(string) :: line - !! Line storage. - - iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg - REWIND (unit) - iostat_ = 0 - lines%raw = '' - DO - line%raw = '' - CALL line%read_line(unit=unit, form=form, iostat=iostat_, iomsg=iomsg_) - IF (iostat_ /= 0 .AND. .NOT. is_iostat_eor(iostat_)) THEN - EXIT - ELSEIF (line /= '') THEN - lines%raw = lines%raw//line%raw//NEW_LINE('a') - END IF - END DO - IF (lines%raw /= '') self%raw = lines%raw - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE read_lines - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION replace(self, old, NEW, count) RESULT(replaced) - !< Return a string with all occurrences of substring old replaced by new. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(3) - !< astring = 'When YOU are sad YOU should think to me :-)' - !< test_passed(1) = (astring%replace(old='YOU', new='THEY')//''=='When THEY are sad THEY should think to me :-)') - !< test_passed(2) = (astring%replace(old='YOU', new='THEY', count=1)//''=='When THEY are sad YOU should think to me :-)') - !< astring = repeat(new_line('a')//'abcd', 20) - !< astring = astring%replace(old=new_line('a'), new='|cr|') - !< astring = astring%replace(old='|cr|', new=new_line('a')//' ') - !< test_passed(3) = (astring//''==repeat(new_line('a')//' '//'abcd', 20)) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: old !< Old substring. - CHARACTER(kind=CK, len=*), INTENT(IN) :: NEW !< New substring. - INTEGER, INTENT(IN), OPTIONAL :: count !< Number of old occurences to be replaced. - TYPE(string) :: replaced !< The string with old replaced by new. - INTEGER :: r !< Counter. - - IF (ALLOCATED(self%raw)) THEN - replaced = self - r = 0 - DO - IF (INDEX(replaced%raw, old) > 0) THEN - replaced = replaced%replace_one_occurrence(old=old, NEW=NEW) - r = r + 1 - IF (PRESENT(count)) THEN - IF (r >= count) EXIT - END IF - ELSE - EXIT - END IF - END DO - END IF -END FUNCTION replace - -ELEMENTAL FUNCTION reverse(self) RESULT(reversed) - !< Return a reversed string. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(2) - !< astring = 'abcdefghilmnopqrstuvz' - !< test_passed(1) = (astring%reverse()//''=='zvutsrqponmlihgfedcba') - !< astring = '0123456789' - !< test_passed(2) = (astring%reverse()//''=='9876543210') - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: reversed !< The reversed string. - INTEGER :: length !< Length of the string. - INTEGER :: c !< Counter. - - IF (ALLOCATED(self%raw)) THEN - reversed = self - length = LEN(self%raw) - DO c = 1, length - reversed%raw(c:c) = self%raw(length - c + 1:length - c + 1) - END DO - END IF -END FUNCTION reverse - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION search(self, tag_start, tag_end, in_string, in_character, & - & istart, iend) RESULT(tag) - !< Search for *tagged* record into string, return the first record found (if any) matching the tags. - !< - !< Optionally, returns the indexes of tag start/end, thus this is not an `elemental` function. - !< - !< @note The tagged record is searched into self if allocated otherwise into `in_string` if passed or, eventually, into - !< `in_character` is passed. If tag is not found the return string is not allocated and the start/end indexes (if requested) are - !< zero. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< character(len=:), allocatable :: acharacter - !< integer :: istart - !< integer :: iend - !< logical :: test_passed(5) - !< astring = ' hello not the first ' - !< anotherstring = astring%search(tag_start='', tag_end='') - !< test_passed(1) = anotherstring//''==' hello ' - !< astring = ' the nested a ' - !< anotherstring = astring%search(tag_start='', tag_end='') - !< test_passed(2) = anotherstring//''==' the nested a ' - !< call astring%free - !< anotherstring = ' the nested a ' - !< astring = astring%search(in_string=anotherstring, tag_start='', tag_end='') - !< test_passed(3) = astring//''==' the nested a ' - !< call astring%free - !< acharacter = ' the nested a ' - !< astring = astring%search(in_character=acharacter, tag_start='', tag_end='') - !< test_passed(4) = astring//''==' the nested a ' - !< acharacter = ' hello not the first ' - !< astring = astring%search(in_character=acharacter, tag_start='', tag_end='', istart=istart, iend=iend) - !< test_passed(5) = astring//''==acharacter(31:67) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: tag_start !< Start tag. - CHARACTER(kind=CK, len=*), INTENT(IN) :: tag_end !< End tag. - TYPE(string), INTENT(IN), OPTIONAL :: in_string !< Search into this string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: in_character !< Search into this character string. - INTEGER, INTENT(out), OPTIONAL :: istart !< Starting index of tag inside the string. - INTEGER, INTENT(out), OPTIONAL :: iend !< Ending index of tag inside the string. - TYPE(string) :: tag !< First tag found. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw !< Raw string into which search the tag. - INTEGER :: istart_ !< Starting index of tag inside the string, local variable. - INTEGER :: iend_ !< Ending index of tag inside the string, local variable. - INTEGER :: nested_tags !< Number of nested tags inside tag. - INTEGER :: t !< Counter. - - raw = '' - IF (PRESENT(in_string)) THEN - raw = in_string%raw - ELSEIF (PRESENT(in_character)) THEN - raw = in_character - ELSE - IF (ALLOCATED(self%raw)) raw = self%raw - END IF - istart_ = 0 - iend_ = 0 - IF (raw /= '') THEN - istart_ = INDEX(raw, tag_start) - iend_ = INDEX(raw, tag_end) - IF (istart_ > 0 .AND. iend_ > 0) THEN - iend_ = iend_ + LEN(tag_end) - 1 - tag%raw = raw(istart_:iend_) - nested_tags = tag%COUNT(tag_start) - IF (nested_tags > 1) THEN - DO t = 2, nested_tags - iend_ = iend_ + LEN(tag_end) - 1 + INDEX(raw(iend_ + 1:), tag_end) - END DO - tag%raw = raw(istart_:iend_) - END IF - END IF - END IF - IF (PRESENT(istart)) istart = istart_ - IF (PRESENT(iend)) iend = iend_ -END FUNCTION search - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION slice(self, istart, iend) RESULT(raw) - !< Return the raw characters data sliced. - !< - !<```fortran - !< type(string) :: astring - !< astring = 'the Quick Brown fox Jumps over the Lazy Dog.' - !< print "(A)", astring%slice(11,25) - !<``` - !=> Brown fox Jumps <<< - CLASS(string), INTENT(IN) :: self !< The string. - INTEGER, INTENT(IN) :: istart !< Slice start index. - INTEGER, INTENT(IN) :: iend !< Slice end index. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw !< Raw characters data. - - IF (ALLOCATED(self%raw)) THEN - raw = self%raw(istart:iend) - ELSE - raw = '' - END IF -END FUNCTION slice - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION snakecase(self, sep) - !< Return a string with all words lowercase separated by "_". - !< - !< @note Multiple subsequent separators are collapsed to one occurence. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 'the Quick Brown fox Jumps over the Lazy Dog.' - !< test_passed(1) = astring%snakecase()//''=='the_quick_brown_fox_jumps_over_the_lazy_dog.' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - TYPE(string) :: snakecase !< Snake case string. - TYPE(string), ALLOCATABLE :: tokens(:) !< String tokens. - - IF (ALLOCATED(self%raw)) THEN - CALL self%split(tokens=tokens, sep=sep) - tokens = tokens%lower() - snakecase = snakecase%join(array=tokens, sep='_') - END IF -END FUNCTION snakecase - -!---------------------------------------------------------------------------- -! Split -!---------------------------------------------------------------------------- - -!> author: Szaghi -! date: 11 May 2022 -! summary: Return a list of substring in the string -! -!# Introduction -! -! Return a list of substring in the string, using sep as the delimiter string -! -!@note -! Multiple subsequent separators are collapsed to one occurrence. -!@endnote -! -!@note -! If `max_tokens` is passed the returned number of tokens is either -! `max_tokens` or `max_tokens + 1`. -!@endnote -! -!```fortran -! type(string) :: astring -! type(string), allocatable :: strings(:) -! logical :: test_passed(11) -! astring = '+ab-++cre-++cre-ab+' -! call astring%split(tokens=strings, sep='+') -! test_passed(1) = (strings(1)//''=='ab-'.and.strings(2)//''=='cre-'.and. -! strings(3)//''=='cre-ab') -! astring = 'ab-++cre-++cre-ab+' -! call astring%split(tokens=strings, sep='+') -! test_passed(2) = (strings(1)//''=='ab-'.and.strings(2)//''=='cre-'.and. -! strings(3)//''=='cre-ab') -! astring = 'ab-++cre-++cre-ab' -! call astring%split(tokens=strings, sep='+') -! test_passed(3) = (strings(1)//''=='ab-'.and.strings(2)//''=='cre-'.and. -! strings(3)//''=='cre-ab') -! astring = 'Hello '//new_line('a')//'World!' -! call astring%split(tokens=strings, sep=new_line('a')) -! test_passed(4) = (strings(1)//''=='Hello '.and.strings(2)//''=='World!') -! astring = 'Hello World!' -! call astring%split(tokens=strings) -! test_passed(5) = (strings(1)//''=='Hello'.and.strings(2)//''=='World!') -! astring = '+ab-' -! call astring%split(tokens=strings, sep='+') -! test_passed(6) = (strings(1)//''=='ab-') -! astring = '+ab-' -! call astring%split(tokens=strings, sep='-') -! test_passed(7) = (strings(1)//''=='+ab') -! astring = '+ab-+cd-' -! call astring%split(tokens=strings, sep='+') -! test_passed(8) = (strings(1)//''=='ab-'.and.strings(2)//''=='cd-') -! astring = 'ab-+cd-+' -! call astring%split(tokens=strings, sep='+') -! test_passed(9) = (strings(1)//''=='ab-'.and.strings(2)//''=='cd-') -! astring = '+ab-+cd-+' -! call astring%split(tokens=strings, sep='+') -! test_passed(10) = (strings(1)//''=='ab-'.and.strings(2)//''=='cd-') -! astring = '1-2-3-4-5-6-7-8' -! call astring%split(tokens=strings, sep='-', max_tokens=3) -! test_passed(11) = (strings(1)//''=='1'.and.strings(2)//''=='2'.and.strings -! (3)//''=='3'.and.strings(4)//''=='4-5-6-7-8') -! print '(L1)', all(test_passed) -!``` - -PURE SUBROUTINE split(self, tokens, sep, max_tokens) - CLASS(string), INTENT(IN) :: self - !! The string. - TYPE(string), ALLOCATABLE, INTENT(out) :: tokens(:) - !! Tokens substring. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep - !! Separator. - INTEGER, INTENT(IN), OPTIONAL :: max_tokens - !! Fix the maximum number of returned tokens. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ - !! Separator, default value. - INTEGER :: No - !! Number of occurrences of sep. - INTEGER :: t - !! Character counter. - TYPE(string) :: temporary - !! Temporary storage. - TYPE(string), ALLOCATABLE :: temp_toks(:, :) - !! Temporary tokens substring. - !! - !! - !! - IF (ALLOCATED(self%raw)) THEN - !! - sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep - !! - temporary = self%unique(sep_) - No = temporary%COUNT(sep_) - !! - IF (No > 0) THEN - IF (PRESENT(max_tokens)) THEN - IF (max_tokens < No .AND. max_tokens > 0) No = max_tokens - END IF - ALLOCATE (temp_toks(3, No)) - temp_toks(:, 1) = temporary%partition(sep_) - IF (No > 1) THEN - DO t = 2, No - temp_toks(:, t) = temp_toks(3, t - 1)%partition(sep_) - END DO - END IF - !! - IF (temp_toks(1, 1)%raw /= '' .AND. temp_toks(3, No)%raw /= '') THEN - ALLOCATE (tokens(No + 1)) - DO t = 1, No - IF (t == No) THEN - tokens(t) = temp_toks(1, t) - tokens(t + 1) = temp_toks(3, t) - ELSE - tokens(t) = temp_toks(1, t) - END IF - END DO - ELSEIF (temp_toks(1, 1)%raw /= '') THEN - ALLOCATE (tokens(No)) - DO t = 1, No - tokens(t) = temp_toks(1, t) - END DO - ELSEIF (temp_toks(3, No)%raw /= '') THEN - ALLOCATE (tokens(No)) - DO t = 1, No - 1 - tokens(t) = temp_toks(1, t + 1) - END DO - tokens(No) = temp_toks(3, No) - ELSE - ALLOCATE (tokens(No - 1)) - DO t = 2, No - tokens(t - 1) = temp_toks(1, t) - END DO - END IF - !! - ELSE - ALLOCATE (tokens(1)) - tokens(1) = self - END IF - END IF -END SUBROUTINE split - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Szaghi -! date: 21 July 2022 -! summary: Return substrings -! -!# Introduction -! -! Return a list of substring in the string, using sep as the delimiter -! string, chunked (memory-efficient) algorithm. -! -!@note -! Multiple subsequent separators are collapsed to one occurrence. -!@endnote -! -!@note -! The split is performed in chunks of `#chunks` to avoid excessive memory -! consumption. -!@endnote -! -!```fortran -! type(string) :: astring -! type(string), allocatable :: strings(:) -! logical :: test_passed(1) -! astring = '-1-2-3-4-5-6-7-8-' -! call astring%split_chunked(tokens=strings, sep='-', chunks=3) -! test_passed(1) = (strings(1)//''=='1'.and.strings(2)//''=='2'.and.strings -! (3)//''=='3'.and.strings(4)//''=='4'.and. & -! strings(5)//''=='5'.and.strings(6)//''=='6'.and.strings -! (7)//''=='7'.and.strings(8)//''=='8') -! print '(L1)', all(test_passed) -!``` - -PURE SUBROUTINE split_chunked(self, tokens, chunks, sep) - !! - CLASS(string), INTENT(IN) :: self - !! The string. - TYPE(string), ALLOCATABLE, INTENT(out) :: tokens(:) - !! Tokens substring. - INTEGER, INTENT(IN) :: chunks - !! Number of chunks. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep - !! Separator. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ - !! Separator, default value. - INTEGER :: Nt - !! Number of actual tokens. - INTEGER :: t - !! Counter. - LOGICAL :: isok - !! - !! - !! - IF (ALLOCATED(self%raw)) THEN - sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep - !! - Nt = self%COUNT(sep_) - IF (self%start_with(prefix=sep_)) Nt = Nt - 1 - IF (self%end_with(suffix=sep_)) Nt = Nt - 1 - t = 0 - CALL self%split(tokens=tokens, sep=sep_, max_tokens=chunks) - DO - t = SIZE(tokens, dim=1) - IF (t > Nt) EXIT - CALL split_last_token(tokens=tokens, max_tokens=chunks, isok=isok) - IF (isok) THEN - ELSE - EXIT - END IF - END DO - !! - t = SIZE(tokens, dim=1) - IF (tokens(t)%COUNT(sep_) > 0) THEN - CALL split_last_token(tokens=tokens, isok=isok) - END IF - END IF - !! -CONTAINS - !! - PURE SUBROUTINE split_last_token(tokens, max_tokens, isok) - !! Split last token. - TYPE(string), ALLOCATABLE, INTENT(inout) :: tokens(:) - !! Tokens substring. - INTEGER, INTENT(IN), OPTIONAL :: max_tokens - !! Max tokens returned. - TYPE(string), ALLOCATABLE :: tokens_(:) - !! Temporary tokens. - TYPE(string), ALLOCATABLE :: tokens_swap(:) - !! Swap tokens. - INTEGER :: Nt_ - !! Number of last created tokens. - LOGICAL, INTENT(out) :: isok - !! - isok = .TRUE. - CALL tokens(t)%split(tokens=tokens_, sep=sep_, max_tokens=max_tokens) - IF (ALLOCATED(tokens_)) THEN - Nt_ = SIZE(tokens_, dim=1) - IF (Nt_ >= 1) THEN - ALLOCATE (tokens_swap(1:t - 1 + Nt_)) - tokens_swap(1:t - 1) = tokens(1:t - 1) - tokens_swap(t:) = tokens_(:) - CALL MOVE_ALLOC(from=tokens_swap, to=tokens) - END IF - IF (Nt_ == 1) THEN - isok = .FALSE. - END IF - DEALLOCATE (tokens_) - END IF - END SUBROUTINE split_last_token - !! -END SUBROUTINE split_chunked - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION startcase(self, sep) - !< Return a string with all words capitalized, e.g. title case. - !< - !< @note Multiple subsequent separators are collapsed to one occurence. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 'the Quick Brown fox Jumps over the Lazy Dog.' - !< test_passed(1) = astring%startcase()//''=='The Quick Brown Fox Jumps Over The Lazy Dog.' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. - TYPE(string) :: startcase !< Start case string. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. - TYPE(string), ALLOCATABLE :: tokens(:) !< String tokens. - - IF (ALLOCATED(self%raw)) THEN - sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep - CALL self%split(tokens=tokens, sep=sep_) - tokens = tokens%capitalize() - startcase = startcase%join(array=tokens, sep=sep_) - END IF -END FUNCTION startcase - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION strip(self, remove_nulls) - !< Return a copy of the string with the leading and trailing characters removed. - !< - !< @note Multiple subsequent separators are collapsed to one occurence. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = ' Hello World! ' - !< test_passed(1) = astring%strip()//''=='Hello World!' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - LOGICAL, INTENT(IN), OPTIONAL :: remove_nulls !< Remove null characters at the end. - TYPE(string) :: strip !< The stripped string. - INTEGER :: c !< Counter. - - IF (ALLOCATED(self%raw)) THEN - strip = self%ADJUSTL() - strip = strip%TRIM() - IF (PRESENT(remove_nulls)) THEN - IF (remove_nulls) THEN - c = INDEX(self%raw, CHAR(0)) - IF (c > 0) strip%raw = strip%raw(1:c - 1) - END IF - END IF - END IF -END FUNCTION strip - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION swapcase(self) - !< Return a copy of the string with uppercase characters converted to lowercase and vice versa. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = ' Hello World! ' - !< test_passed(1) = astring%swapcase()//''==' hELLO wORLD! ' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: swapcase !< Upper case string. - INTEGER :: n1 !< Characters counter. - INTEGER :: n2 !< Characters counter. - - IF (ALLOCATED(self%raw)) THEN - swapcase = self - DO n1 = 1, LEN(self%raw) - n2 = INDEX(UPPER_ALPHABET, self%raw(n1:n1)) - IF (n2 > 0) THEN - swapcase%raw(n1:n1) = LOWER_ALPHABET(n2:n2) - ELSE - n2 = INDEX(LOWER_ALPHABET, self%raw(n1:n1)) - IF (n2 > 0) swapcase%raw(n1:n1) = UPPER_ALPHABET(n2:n2) - END IF - END DO - END IF -END FUNCTION swapcase - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -FUNCTION tempname(self, is_file, prefix, path) - !< Return a safe temporary name suitable for temporary file or directories. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: tmpname - !< logical :: test_passed(5) - !< tmpname = astring%tempname() - !< inquire(file=tmpname, exist=test_passed(1)) - !< test_passed(1) = .not.test_passed(1) - !< tmpname = astring%tempname(is_file=.false.) - !< inquire(file=tmpname, exist=test_passed(2)) - !< test_passed(2) = .not.test_passed(2) - !< tmpname = astring%tempname(path='./') - !< inquire(file=tmpname, exist=test_passed(3)) - !< test_passed(3) = .not.test_passed(3) - !< astring = 'me-' - !< tmpname = astring%tempname() - !< inquire(file=tmpname, exist=test_passed(4)) - !< test_passed(4) = .not.test_passed(4) - !< tmpname = astring%tempname(prefix='you-') - !< inquire(file=tmpname, exist=test_passed(5)) - !< test_passed(5) = .not.test_passed(5) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - LOGICAL, INTENT(IN), OPTIONAL :: is_file !< True if tempname should be used for file (the default). - CHARACTER(*), INTENT(IN), OPTIONAL :: prefix !< Name prefix, otherwise self is used (if allocated). - CHARACTER(*), INTENT(IN), OPTIONAL :: path !< Path where file/directory should be used, default `./`. - CHARACTER(len=:), ALLOCATABLE :: tempname !< Safe (unique) temporary name. - LOGICAL :: is_file_ !< True if tempname should be used for file (the default). - CHARACTER(len=:), ALLOCATABLE :: prefix_ !< Name prefix, otherwise self is used (if allocated). - CHARACTER(len=:), ALLOCATABLE :: path_ !< Path where file/directory should be used, default `./`. - LOGICAL, SAVE :: is_initialized = .FALSE. !< Status of random seed initialization. - REAL(R4P) :: random_real !< Random number (real). - INTEGER(I4P) :: random_integer !< Random number (integer). - LOGICAL :: is_hold !< Flag to check if a safe tempname has been found. - - is_file_ = .TRUE.; IF (PRESENT(is_file)) is_file_ = is_file - path_ = ''; IF (PRESENT(path)) path_ = path - prefix_ = '' - IF (PRESENT(prefix)) THEN - prefix_ = prefix - ELSEIF (ALLOCATED(self%raw)) THEN - prefix_ = self%raw - END IF - IF (.NOT. is_initialized) THEN - CALL random_seed - is_initialized = .TRUE. - END IF - tempname = REPEAT(' ', LEN(path_) + LEN(prefix_) + 10) ! [path_] + [prefix_] + 6 random chars + [.tmp] - DO - CALL RANDOM_NUMBER(random_real) - random_integer = TRANSFER(random_real, random_integer) - random_integer = IAND(random_integer, 16777215_I4P) - IF (is_file_) THEN - WRITE (tempname, '(A,Z6.6,A)') path_//prefix_, random_integer, '.tmp' - ELSE - WRITE (tempname, '(A,Z6.6)') path_//prefix_, random_integer - tempname = TRIM(tempname) - END IF - INQUIRE (file=tempname, exist=is_hold) - IF (.NOT. is_hold) EXIT - END DO -END FUNCTION tempname - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2022 -! summary: Cast string to integer (I1P). -! -!# Introduction -! -!```fortran -! use penf -! type(string) :: astring -! integer(I1P) :: integer_ -! logical :: test_passed(1) -! astring = '127' -! integer_ = astring%to_number(kind=1_I1P) -! test_passed(1) = integer_==127_I1P -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION to_integer_I1P(self, kind) RESULT(to_number) - CLASS(string), INTENT(IN) :: self - !! The string. - INTEGER(I1P), INTENT(IN) :: kind - !! Mold parameter for kind detection. - INTEGER(I1P) :: to_number - !! The number into the string. - IF (ALLOCATED(self%raw)) THEN - IF (self%is_integer()) READ (self%raw, *) to_number - END IF -END FUNCTION to_integer_I1P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#ifndef _NVF -!> author: Vikas Sharma, Ph. D. -! date: 22 July 2023 -! summary: Cast string to integer (I2P). -! -!# Introduction -! -!```fortran -! use penf -! type(string) :: astring -! integer(I2P) :: integer_ -! logical :: test_passed(1) -! astring = '127' -! integer_ = astring%to_number(kind=1_I2P) -! test_passed(1) = integer_==127_I2P -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION to_integer_I2P(self, kind) RESULT(to_number) - CLASS(string), INTENT(IN) :: self - !! The string. - INTEGER(I2P), INTENT(IN) :: kind - !! Mold parameter for kind detection. - INTEGER(I2P) :: to_number - !! The number into the string. - IF (ALLOCATED(self%raw)) THEN - IF (self%is_integer()) READ (self%raw, *) to_number - END IF -END FUNCTION to_integer_I2P -#endif - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2022 -! summary: Cast string to integer (I4P). -! -!# Introduction -! -! -!```fortran -! use penf -! type(string) :: astring -! integer(I4P) :: integer_ -! logical :: test_passed(1) -! astring = '127' -! integer_ = astring%to_number(kind=1_I4P) -! test_passed(1) = integer_==127_I4P -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION to_integer_I4P(self, kind) RESULT(to_number) - CLASS(string), INTENT(IN) :: self - !! The string. - INTEGER(I4P), INTENT(IN) :: kind - !! Mold parameter for kind detection. - INTEGER(I4P) :: to_number - !! The number into the string. - IF (ALLOCATED(self%raw)) THEN - IF (self%is_integer()) READ (self%raw, *) to_number - END IF -END FUNCTION to_integer_I4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2023 -! summary: Cast string to integer (I8P). -! -!# Introduction -! -!```fortran -! use penf -! type(string) :: astring -! integer(I8P) :: integer_ -! logical :: test_passed(1) -! astring = '127' -! integer_ = astring%to_number(kind=1_I8P) -! test_passed(1) = integer_==127_I8P -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION to_integer_I8P(self, kind) RESULT(to_number) - CLASS(string), INTENT(IN) :: self - !! The string. - INTEGER(I8P), INTENT(IN) :: kind - !! Mold parameter for kind detection. - INTEGER(I8P) :: to_number - !! The number into the string. - IF (ALLOCATED(self%raw)) THEN - IF (self%is_integer()) READ (self%raw, *) to_number - END IF -END FUNCTION to_integer_I8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Cast string to real (R4P). -! -!# Introduction -! -!```fortran -! use penf -! type(string) :: astring -! real(R4P) :: real_ -! logical :: test_passed(1) -! astring = '3.4e9' -! real_ = astring%to_number(kind=1._R4P) -! test_passed(1) = real_==3.4e9_R4P -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION to_real_R4P(self, kind) RESULT(to_number) - CLASS(string), INTENT(IN) :: self - !! The string. - REAL(R4P), INTENT(IN) :: kind - !! Mold parameter for kind detection. - REAL(R4P) :: to_number - !! The number into the string. - IF (ALLOCATED(self%raw)) THEN - IF (self%is_real()) READ (self%raw, *) to_number - END IF -END FUNCTION to_real_R4P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Cast string to real (R8P). -! -!# Introduction -! -!```fortran -! use penf -! type(string) :: astring -! real(R8P) :: real_ -! logical :: test_passed(1) -! astring = '3.4e9' -! real_ = astring%to_number(kind=1._R8P) -! test_passed(1) = real_==3.4e9_R8P -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION to_real_R8P(self, kind) RESULT(to_number) - CLASS(string), INTENT(IN) :: self - !! The string. - REAL(R8P), INTENT(IN) :: kind - !! Mold parameter for kind detection. - REAL(R8P) :: to_number - !! The number into the string. - IF (ALLOCATED(self%raw)) THEN - IF (self%is_real()) READ (self%raw, *) to_number - END IF -END FUNCTION to_real_R8P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION to_real_R16P(self, kind) RESULT(to_number) - !< Cast string to real (R16P). - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< real(R16P) :: real_ - !< logical :: test_passed(1) - !< astring = '3.4e9' - !< real_ = astring%to_number(kind=1._R16P) - !< test_passed(1) = real_==3.4e9_R16P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - REAL(R16P), INTENT(IN) :: kind !< Mold parameter for kind detection. - REAL(R16P) :: to_number !< The number into the string. - - IF (ALLOCATED(self%raw)) THEN - IF (self%is_real()) READ (self%raw, *) to_number - END IF -END FUNCTION to_real_R16P - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2022 -! summary: Convert a string to boolean - -ELEMENTAL FUNCTION to_logical(self) RESULT(ans) - CLASS(string), INTENT(IN) :: self - !! The string. - LOGICAL :: ans - !! - TYPE(String) :: tmp - ! True and False options (all lowercase): - CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: true_str = ['1 ', & - 't ', & - 'true ', & - '.true.'] - CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: false_str = ['0 ', & - 'f ', & - 'false ', & - '.false.'] - !! - IF (ALLOCATED(self%raw)) THEN - tmp = self%lower() - IF (ANY(tmp .EQ. true_str)) THEN - ans = .TRUE. - ELSEIF (ANY(tmp .EQ. false_str)) THEN - ans = .FALSE. - ELSE - ans = .FALSE. - END IF - END IF - !! -END FUNCTION to_logical - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION unescape(self, to_unescape, unesc) RESULT(unescaped) - !< Unescape double backslashes (or custom escaped character). - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(2) - !< astring = '^\\s \\d+\\s*' - !< test_passed(1) = (astring%unescape(to_unescape='\')//''=='^\s \d+\s*') - !< test_passed(2) = (astring%unescape(to_unescape='s')//''=='^\s \\d+\s*') - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self - !! The string. - CHARACTER(kind=CK, len=1), INTENT(IN) :: to_unescape - !! Character to be unescaped. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: unesc - !! Character used to unescape. - TYPE(string) :: unescaped - !! Escaped string. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: unesc_ - !! Character to unescape, local variable. - INTEGER :: c - !! Character counter. - - IF (ALLOCATED(self%raw)) THEN - unesc_ = ''; IF (PRESENT(unesc)) unesc_ = unesc - unescaped%raw = '' - c = 1 - DO - IF (c > LEN(self%raw)) EXIT - IF (c == LEN(self%raw)) THEN - unescaped%raw = unescaped%raw//self%raw(c:c) - EXIT - ELSE - IF (self%raw(c:c + 1) == BACKSLASH//to_unescape) THEN - unescaped%raw = unescaped%raw//to_unescape - c = c + 2 - ELSE - unescaped%raw = unescaped%raw//self%raw(c:c) - c = c + 1 - END IF - END IF - END DO - END IF -END FUNCTION unescape - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION unique(self, substring) RESULT(uniq) - !< Reduce to one (unique) multiple (sequential) occurrences of a substring into a string. - !< - !< For example the string ' ab-cre-cre-ab' is reduce to 'ab-cre-ab' if the substring is '-cre'. - !< @note Eventual multiple trailing white space are not reduced to one occurrence. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = '+++ab-++cre-++cre-ab+++++' - !< test_passed(1) = astring%unique(substring='+')//''=='+ab-+cre-+cre-ab+' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self - !! The string. - CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: substring - !! Substring which multiple occurences must be reduced to one. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: substring_ - !! Substring, default value. - TYPE(string) :: uniq - !! String parsed. -#ifdef _NVF - CHARACTER(9999) :: nvf_bug - !! Work around for NVFortran bug. -#endif - - IF (ALLOCATED(self%raw)) THEN - substring_ = SPACE; IF (PRESENT(substring)) substring_ = substring - - uniq = self - DO -#ifdef _NVF - nvf_bug = substring_ - IF (.NOT. uniq%INDEX(REPEAT(TRIM(nvf_bug), 2)) > 0) EXIT - uniq = uniq%replace(old=REPEAT(TRIM(nvf_bug), 2), NEW=substring_) -#else - IF (.NOT. uniq%INDEX(REPEAT(substring_, 2)) > 0) EXIT - uniq = uniq%replace(old=REPEAT(substring_, 2), NEW=substring_) -#endif - END DO - END IF -END FUNCTION unique - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION upper(self) - !< Return a string with all uppercase characters. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 'Hello WorLD!' - !< test_passed(1) = astring%upper()//''=='HELLO WORLD!' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - TYPE(string) :: upper !< Upper case string. - INTEGER :: n1 !< Characters counter. - INTEGER :: n2 !< Characters counter. - - IF (ALLOCATED(self%raw)) THEN - upper = self - DO n1 = 1, LEN(self%raw) - n2 = INDEX(LOWER_ALPHABET, self%raw(n1:n1)) - IF (n2 > 0) upper%raw(n1:n1) = UPPER_ALPHABET(n2:n2) - END DO - END IF -END FUNCTION upper - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE write_file(self, file, form, iostat, iomsg) - !< Write a single string stream into file. - !< - !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< type(string), allocatable :: strings(:) - !< type(string) :: line(3) - !< integer :: iostat - !< character(len=99) :: iomsg - !< integer :: scratch - !< integer :: l - !< logical :: test_passed(8) - !< line(1) = ' Hello World! ' - !< line(2) = 'How are you? ' - !< line(3) = ' All say: "Fine thanks"' - !< anotherstring = anotherstring%join(array=line, sep=new_line('a')) - !< call anotherstring%write_file(file='write_file_test.tmp', iostat=iostat, iomsg=iomsg) - !< call astring%read_file(file='write_file_test.tmp', iostat=iostat, iomsg=iomsg) - !< call astring%split(tokens=strings, sep=new_line('a')) - !< test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) - !< do l=1, size(strings, dim=1) - !< test_passed(l+1) = (strings(l)==line(l)) - !< enddo - !< call anotherstring%write_file(file='write_file_test.tmp', form='unformatted', iostat=iostat, iomsg=iomsg) - !< call astring%read_file(file='write_file_test.tmp', form='unformatted', iostat=iostat, iomsg=iomsg) - !< call astring%split(tokens=strings, sep=new_line('a')) - !< test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) - !< do l=1, size(strings, dim=1) - !< test_passed(l+5) = (strings(l)==line(l)) - !< enddo - !< open(newunit=scratch, file='write_file_test.tmp') - !< close(unit=scratch, status='delete') - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(len=*), INTENT(IN) :: file !< File name. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: form !< Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. - CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. - TYPE(string) :: form_ !< Format of unit, local variable. - INTEGER :: iostat_ !< IO status code, local variable. - CHARACTER(len=:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. - INTEGER :: unit !< Logical unit. - - iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg - form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() - SELECT CASE (form_%chars()) - CASE ('FORMATTED') - OPEN (newunit=unit, file=file, action='WRITE', iomsg=iomsg_, iostat=iostat_, err=10) - CASE ('UNFORMATTED') - OPEN (newunit=unit, file=file, action='WRITE', form='UNFORMATTED', access='STREAM', iomsg=iomsg_, iostat=iostat_, err=10) - END SELECT - CALL self%write_lines(unit=unit, form=form, iomsg=iomsg_, iostat=iostat_) -10 CLOSE (unit) - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE write_file - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE write_line(self, unit, form, iostat, iomsg) - !< Write line (record) to a connected unit. - !< - !< @note If the connected unit is unformatted a `new_line()` character is added at the end (if necessary) to mark the end of line. - !< - !< @note There is no doctests, this being tested by means of [[string:write_file]] doctests. - CLASS(string), INTENT(IN) :: self !< The string. - INTEGER, INTENT(IN) :: unit !< Logical unit. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: form !< Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. - CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. - TYPE(string) :: form_ !< Format of unit, local variable. - INTEGER :: iostat_ !< IO status code, local variable. - CHARACTER(len=:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. - - iostat_ = 0 - iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg - IF (ALLOCATED(self%raw)) THEN - form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() - SELECT CASE (form_%chars()) - CASE ('FORMATTED') - WRITE (unit, "(A)", iostat=iostat_, iomsg=iomsg_) self%raw - CASE ('UNFORMATTED') - IF (self%end_with(NEW_LINE('a'))) THEN - WRITE (unit, iostat=iostat_, iomsg=iomsg_) self%raw - ELSE - WRITE (unit, iostat=iostat_, iomsg=iomsg_) self%raw//NEW_LINE('a') - END IF - END SELECT - END IF - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE write_line - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Write lines (records) to a connected unit. -! -!# Introduction -! -! -! This method checks if self contains more than one line (records) and writes -! them as lines (records). -! -! @note If the connected unit is unformatted a `new_line()` character is -! added at the end (if necessary) to mark the end of line. -! -! @note There is no doctests, this being tested by means of -! [[string:write_file]] doctests. - -SUBROUTINE write_lines(self, unit, form, iostat, iomsg) - CLASS(string), INTENT(IN) :: self - !! The string. - INTEGER, INTENT(IN) :: unit - !! Logical unit. - CHARACTER(len=*), INTENT(IN), OPTIONAL :: form - !! Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat - !! IO status code. - CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg - !! IO status message. - TYPE(string), ALLOCATABLE :: lines(:) - !! Lines. - INTEGER :: l - !! Counter. - !! - IF (ALLOCATED(self%raw)) THEN - CALL self%split(tokens=lines, sep=NEW_LINE('a')) - DO l = 1, SIZE(lines, dim=1) - CALL lines(l)%write_line(unit=unit, form=form, iostat=iostat, iomsg=iomsg) - END DO - END IF -END SUBROUTINE write_lines - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Return true if a string ends with a specified suffix. -! -!# Introduction -! -!```fortran -! type(string) :: astring -! logical :: test_passed(5) -! astring = 'Hello WorLD!' -! test_passed(1) = astring%end_with(suffix='LD!').eqv..true. -! test_passed(2) = astring%end_with(suffix='lD!').eqv..false. -! test_passed(3) = astring%end_with(suffix='orLD!', start=5).eqv..true. -! test_passed(4) = astring%end_with(suffix='orLD!', start=8, end=12).eqv.. -! true. -! test_passed(5) = astring%end_with(suffix='!').eqv..true. -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION end_with(self, suffix, start, END, ignore_null_eof) - CLASS(string), INTENT(IN) :: self - !! The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: suffix - !! Searched suffix. - INTEGER, INTENT(IN), OPTIONAL :: start - !! Start position into the string. - INTEGER, INTENT(IN), OPTIONAL :: END - !! End position into the string. - LOGICAL, INTENT(IN), OPTIONAL :: ignore_null_eof - !! Ignore null character at the end of file. - LOGICAL :: end_with - !! Result of the test. - INTEGER :: start_ - !! Start position into the string, local variable. - INTEGER :: end_ - !! End position into the string, local variable. - LOGICAL :: ignore_null_eof_ - !! Ignore null character at the end of file, local variable. - !! - end_with = .FALSE. - IF (ALLOCATED(self%raw)) THEN - start_ = 1; IF (PRESENT(start)) start_ = start - end_ = LEN(self%raw); IF (PRESENT(END)) end_ = END - ignore_null_eof_ = .FALSE.; - IF (PRESENT(ignore_null_eof)) ignore_null_eof_ = ignore_null_eof - IF (ignore_null_eof_ .AND. (self%raw(end_:end_) == CHAR(0))) end_ = end_ - 1 - IF (LEN(suffix) <= LEN(self%raw(start_:end_))) THEN - end_with = self%raw(end_ - LEN(suffix) + 1:end_) == suffix - END IF - END IF -END FUNCTION end_with - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Return true if the string is allocated. -! -!# Introduction -! -!```fortran -! type(string) :: astring -! logical :: test_passed(2) -! test_passed(1) = astring%is_allocated().eqv..false. -! astring = 'hello' -! test_passed(2) = astring%is_allocated().eqv..true. -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION is_allocated(self) - CLASS(string), INTENT(IN) :: self - !! The string. - LOGICAL :: is_allocated - !! Result of the test. - is_allocated = ALLOCATED(self%raw) -END FUNCTION is_allocated - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Return true if all characters in the string are digits. -! -!# Introduction -! -!```fortran -! type(string) :: astring -! logical :: test_passed(2) -! astring = ' -1212112.3 ' -! test_passed(1) = astring%is_digit().eqv..false. -! astring = '12121123' -! test_passed(2) = astring%is_digit().eqv..true. -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION is_digit(self) - CLASS(string), INTENT(IN) :: self - !! The string. - LOGICAL :: is_digit - !! Result of the test. - INTEGER :: c - !! Character counter. - is_digit = .FALSE. - IF (ALLOCATED(self%raw)) THEN - DO c = 1, LEN(self%raw) - SELECT CASE (self%raw(c:c)) - CASE ('0':'9') - is_digit = .TRUE. - CASE default - is_digit = .FALSE. - EXIT - END SELECT - END DO - END IF -END FUNCTION is_digit - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Return true if the string contains an integer. -! -!# Introduction -! -! -! The regular expression is `\s*[\+\-]?\d+([eE]\+?\d+)?\s*`. The parse -! algorithm is done in stages: -! -! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | -! |-----|---------|-----|------|-----|-----|-----| -! |`\s*`|`[\+\-]?`|`\d+`|`[eE]`|`\+?`|`\d+`|`\s*`| -! -! Exit on stages-parsing results in: -! -! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | -! |----|----|----|----|----|----|----| -! | F | F | T | F | F | T | T | -! -! @note This implementation is courtesy of -! [tomedunn](https://github.com/tomedunn/fortran-string-utility-module/blob/ -! master/src/string_utility_module.f90#L294) -! -!```fortran -! type(string) :: astring -! logical :: test_passed(6) -! astring = ' -1212112 ' -! test_passed(1) = astring%is_integer().eqv..true. -! astring = ' -1212112' -! test_passed(2) = astring%is_integer(allow_spaces=.false.).eqv..false. -! astring = '-1212112 ' -! test_passed(3) = astring%is_integer(allow_spaces=.false.).eqv..false. -! astring = '+2e20' -! test_passed(4) = astring%is_integer().eqv..true. -! astring = ' -2E13 ' -! test_passed(5) = astring%is_integer().eqv..true. -! astring = ' -2 E13 ' -! test_passed(6) = astring%is_integer().eqv..false. -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION is_integer(self, allow_spaces) - CLASS(string), INTENT(IN) :: self - !! The string. - LOGICAL, INTENT(IN), OPTIONAL :: allow_spaces - !! Allow leading-trailing spaces. - LOGICAL :: is_integer - !! Result of the test. - LOGICAL :: allow_spaces_ - !! Allow leading-trailing spaces, local variable. - INTEGER :: stage - !! Stages counter. - INTEGER :: c - !! Character counter. - !! - IF (ALLOCATED(self%raw)) THEN - allow_spaces_ = .TRUE. - IF (PRESENT(allow_spaces)) allow_spaces_ = allow_spaces - stage = 0 - is_integer = .TRUE. - DO c = 1, LEN(self%raw) - SELECT CASE (self%raw(c:c)) - CASE (SPACE, TAB) - SELECT CASE (stage) - CASE (0, 6) - is_integer = allow_spaces_ - CASE (2, 5) - is_integer = allow_spaces_ - stage = 6 - CASE default - is_integer = .FALSE. - END SELECT - CASE ('-') - SELECT CASE (stage) - CASE (0) - stage = 1 - CASE default - is_integer = .FALSE. - END SELECT - CASE ('+') - SELECT CASE (stage) - CASE (0) - stage = 1 - CASE (3) - stage = 4 - CASE default - is_integer = .FALSE. - END SELECT - CASE ('0':'9') - SELECT CASE (stage) - CASE (0:1) - stage = 2 - CASE (3:4) - stage = 5 - CASE default - CONTINUE - END SELECT - CASE ('e', 'E') - SELECT CASE (stage) - CASE (2) - stage = 3 - CASE default - is_integer = .FALSE. - END SELECT - CASE default - is_integer = .FALSE. - END SELECT - IF (.NOT. is_integer) EXIT - END DO - END IF - IF (is_integer) THEN - SELECT CASE (stage) - CASE (2, 5, 6) - is_integer = .TRUE. - CASE default - is_integer = .FALSE. - END SELECT - END IF -END FUNCTION is_integer - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Return true if the string contains a number (real or integer). -! -!# Introduction -! -!```fortran -! type(string) :: astring -! logical :: test_passed(7) -! astring = ' -1212112 ' -! test_passed(1) = astring%is_number().eqv..true. -! astring = ' -121.2112 ' -! test_passed(2) = astring%is_number().eqv..true. -! astring = ' -1212112' -! test_passed(3) = astring%is_number(allow_spaces=.false.).eqv..false. -! astring = '-12121.12 ' -! test_passed(4) = astring%is_number(allow_spaces=.false.).eqv..false. -! astring = '+2e20' -! test_passed(5) = astring%is_number().eqv..true. -! astring = ' -2.4E13 ' -! test_passed(6) = astring%is_number().eqv..true. -! astring = ' -2 E13 ' -! test_passed(7) = astring%is_number().eqv..false. -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION is_number(self, allow_spaces) - CLASS(string), INTENT(IN) :: self - !! The string. - LOGICAL, INTENT(IN), OPTIONAL :: allow_spaces - !! Allow leading-trailing spaces. - LOGICAL :: is_number !< Result of the test. - !! - is_number = (self%is_integer(allow_spaces=allow_spaces) & - & .OR. self%is_real(allow_spaces=allow_spaces)) - !! -END FUNCTION is_number - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Return true if the string contains a real. -! -!# Introduction -! -! The regular expression is `\s*[\+\-]?\d*(|\.?\d*([deDE][\+\-]?\d+)?)\s*`. The parse algorithm is done in stages: -! -! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | -! |-----|---------|-----|-----|-----|--------|---------|-----|-----| -! |`\s*`|`[\+\-]?`|`\d*`|`\.?`|`\d*`|`[deDE]`|`[\+\-]?`|`\d*`|`\s*`| -! -! Exit on stages-parsing results in: -! -! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | -! |----|----|----|----|----|----|----|----|----| -! | F | F | T | T | T | F | F | T | T | -! -! @note This implementation is courtesy of -! [tomedunn](https://github.com/tomedunn/fortran-string-utility-module/blob/ -! master/src/string_utility_module.f90#L614) -! -!```fortran -! type(string) :: astring -! logical :: test_passed(6) -! astring = ' -1212112.d0 ' -! test_passed(1) = astring%is_real().eqv..true. -! astring = ' -1212112.d0' -! test_passed(2) = astring%is_real(allow_spaces=.false.).eqv..false. -! astring = '-1212112.d0 ' -! test_passed(3) = astring%is_real(allow_spaces=.false.).eqv..false. -! astring = '+2.e20' -! test_passed(4) = astring%is_real().eqv..true. -! astring = ' -2.01E13 ' -! test_passed(5) = astring%is_real().eqv..true. -! astring = ' -2.01 E13 ' -! test_passed(6) = astring%is_real().eqv..false. -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION is_real(self, allow_spaces) - CLASS(string), INTENT(IN) :: self - !! The string. - LOGICAL, INTENT(IN), OPTIONAL :: allow_spaces - !! Allow leading-trailing spaces. - LOGICAL :: is_real - !! Result of the test. - LOGICAL :: allow_spaces_ - !! Allow leading-trailing spaces, local variable. - LOGICAL :: has_leading_digit - !! Check the presence of leading digits. - INTEGER :: stage - !! Stages counter. - INTEGER :: c - !! Character counter. - IF (ALLOCATED(self%raw)) THEN - allow_spaces_ = .TRUE. - IF (PRESENT(allow_spaces)) allow_spaces_ = allow_spaces - stage = 0 - is_real = .TRUE. - has_leading_digit = .FALSE. - DO c = 1, LEN(self%raw) - SELECT CASE (self%raw(c:c)) - CASE (SPACE, TAB) - SELECT CASE (stage) - CASE (0, 8) - is_real = allow_spaces_ - CONTINUE - CASE (2:4, 7) - is_real = allow_spaces_ - stage = 8 - CASE default - is_real = .FALSE. - END SELECT - CASE ('+', '-') - SELECT CASE (stage) - CASE (0) - stage = 1 - CASE (5) - stage = 6 - CASE default - is_real = .FALSE. - END SELECT - CASE ('0':'9') - SELECT CASE (stage) - CASE (0:1) - stage = 2 - has_leading_digit = .TRUE. - CASE (3) - stage = 4 - CASE (5:6) - stage = 7 - CASE default - CONTINUE - END SELECT - CASE ('.') - SELECT CASE (stage) - CASE (0:2) - stage = 3 - CASE default - is_real = .FALSE. - END SELECT - CASE ('e', 'E', 'd', 'D') - SELECT CASE (stage) - CASE (2:4) - stage = 5 - CASE default - is_real = .FALSE. - END SELECT - CASE default - is_real = .FALSE. - END SELECT - IF (.NOT. is_real) EXIT - END DO - END IF - IF (is_real) THEN - SELECT CASE (stage) - CASE (2, 4, 7, 8) - is_real = .TRUE. - CASE (3) - is_real = has_leading_digit - CASE default - is_real = .FALSE. - END SELECT - END IF -END FUNCTION is_real - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2022 -! summary: Returns true if string contains boolean character -! -!# Introduction -! - -ELEMENTAL FUNCTION is_logical(self) - CLASS(string), INTENT(IN) :: self - !! The string. - LOGICAL :: is_logical - !! - TYPE(String) :: tmp - ! True and False options (all lowercase): - CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: true_str = ['1 ', & - 't ', & - 'true ', & - '.true.'] - CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: false_str = ['0 ', & - 'f ', & - 'false ', & - '.false.'] - IF (ALLOCATED(self%raw)) THEN - tmp = self%lower() - IF (ANY(tmp .EQ. true_str)) THEN - is_logical = .TRUE. - ELSEIF (ANY(tmp .EQ. false_str)) THEN - is_logical = .FALSE. - ELSE - is_logical = .FALSE. - END IF - END IF - !! -END FUNCTION is_logical - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 23 July 2022 -! summary: Return true if all characters in the string are lowercase. -! -!# Introduction -! -! -!```fortran -! type(string) :: astring -! logical :: test_passed(3) -! astring = ' Hello World' -! test_passed(1) = astring%is_lower().eqv..false. -! astring = ' HELLO WORLD' -! test_passed(2) = astring%is_lower().eqv..false. -! astring = ' hello world' -! test_passed(3) = astring%is_lower().eqv..true. -! print '(L1)', all(test_passed) -!``` - -ELEMENTAL FUNCTION is_lower(self) - CLASS(string), INTENT(IN) :: self !< The string. - LOGICAL :: is_lower !< Result of the test. - INTEGER :: c !< Character counter. - - is_lower = .FALSE. - IF (ALLOCATED(self%raw)) THEN - is_lower = .TRUE. - DO c = 1, LEN(self%raw) - IF (INDEX(UPPER_ALPHABET, self%raw(c:c)) > 0) THEN - is_lower = .FALSE. - EXIT - END IF - END DO - END IF -END FUNCTION is_lower - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ELEMENTAL FUNCTION is_upper(self) - !< Return true if all characters in the string are uppercase. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(3) - !< astring = ' Hello World' - !< test_passed(1) = astring%is_upper().eqv..false. - !< astring = ' HELLO WORLD' - !< test_passed(2) = astring%is_upper().eqv..true. - !< astring = ' hello world' - !< test_passed(3) = astring%is_upper().eqv..false. - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - LOGICAL :: is_upper !< Result of the test. - INTEGER :: c !< Character counter. - - is_upper = .FALSE. - IF (ALLOCATED(self%raw)) THEN - is_upper = .TRUE. - DO c = 1, LEN(self%raw) - IF (INDEX(LOWER_ALPHABET, self%raw(c:c)) > 0) THEN - is_upper = .FALSE. - EXIT - END IF - END DO - END IF -END FUNCTION is_upper - -ELEMENTAL FUNCTION start_with(self, prefix, start, END) - !< Return true if a string starts with a specified prefix. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(4) - !< astring = 'Hello WorLD!' - !< test_passed(1) = astring%start_with(prefix='Hello').eqv..true. - !< test_passed(2) = astring%start_with(prefix='hell').eqv..false. - !< test_passed(3) = astring%start_with(prefix='llo Wor', start=3).eqv..true. - !< test_passed(4) = astring%start_with(prefix='lo W', start=4, end=7).eqv..true. - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: self !< The string. - CHARACTER(kind=CK, len=*), INTENT(IN) :: prefix !< Searched prefix. - INTEGER, INTENT(IN), OPTIONAL :: start !< Start position into the string. - INTEGER, INTENT(IN), OPTIONAL :: END !< End position into the string. - LOGICAL :: start_with !< Result of the test. - INTEGER :: start_ !< Start position into the string, local variable. - INTEGER :: end_ !< End position into the string, local variable. - - start_with = .FALSE. - IF (ALLOCATED(self%raw)) THEN - start_ = 1; IF (PRESENT(start)) start_ = start - end_ = LEN(self%raw); IF (PRESENT(END)) end_ = END - IF (LEN(prefix) <= LEN(self%raw(start_:end_))) THEN - start_with = INDEX(self%raw(start_:end_), prefix) == 1 - END IF - END IF -END FUNCTION start_with - -! private methods - -! assignments -PURE SUBROUTINE string_assign_string(lhs, rhs) - !< Assignment operator from string input. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(1) - !< astring = 'hello' - !< anotherstring = astring - !< test_passed(1) = astring%chars()==anotherstring%chars() - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - - IF (ALLOCATED(rhs%raw)) lhs%raw = rhs%raw -END SUBROUTINE string_assign_string - -PURE SUBROUTINE string_assign_character(lhs, rhs) - !< Assignment operator from character input. - !< - !<```fortran - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 'hello' - !< test_passed(1) = astring%chars()=='hello' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = rhs -END SUBROUTINE string_assign_character - -PURE SUBROUTINE string_assign_integer_I1P(lhs, rhs) - !< Assignment operator from integer input. - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 127_I1P - !< test_passed(1) = astring%to_number(kind=1_I1P)==127_I1P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - INTEGER(I1P), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = TRIM(str(rhs)) -END SUBROUTINE string_assign_integer_I1P - -PURE SUBROUTINE string_assign_integer_I2P(lhs, rhs) - !< Assignment operator from integer input. - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 127_I2P - !< test_passed(1) = astring%to_number(kind=1_I2P)==127_I2P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - INTEGER(I2P), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = TRIM(str(rhs)) -END SUBROUTINE string_assign_integer_I2P - -PURE SUBROUTINE string_assign_integer_I4P(lhs, rhs) - !< Assignment operator from integer input. - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 127_I4P - !< test_passed(1) = astring%to_number(kind=1_I4P)==127_I4P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - INTEGER(I4P), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = TRIM(str(rhs)) -END SUBROUTINE string_assign_integer_I4P - -PURE SUBROUTINE string_assign_integer_I8P(lhs, rhs) - !< Assignment operator from integer input. - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 127_I8P - !< test_passed(1) = astring%to_number(kind=1_I8P)==127_I8P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - INTEGER(I8P), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = TRIM(str(rhs)) -END SUBROUTINE string_assign_integer_I8P - -PURE SUBROUTINE string_assign_real_R4P(lhs, rhs) - !< Assignment operator from real input. - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 3.021e6_R4P - !< test_passed(1) = astring%to_number(kind=1._R4P)==3.021e6_R4P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - REAL(R4P), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = TRIM(str(rhs)) -END SUBROUTINE string_assign_real_R4P - -PURE SUBROUTINE string_assign_real_R8P(lhs, rhs) - !< Assignment operator from real input. - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 3.021e6_R8P - !< test_passed(1) = astring%to_number(kind=1._R8P)==3.021e6_R8P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - REAL(R8P), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = TRIM(str(rhs)) -END SUBROUTINE string_assign_real_R8P - -PURE SUBROUTINE string_assign_real_R16P(lhs, rhs) - !< Assignment operator from real input. - !< - !<```fortran - !< use penf - !< type(string) :: astring - !< logical :: test_passed(1) - !< astring = 3.021e6_R8P - !< test_passed(1) = astring%to_number(kind=1._R8P)==3.021e6_R8P - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(inout) :: lhs !< Left hand side. - REAL(R16P), INTENT(IN) :: rhs !< Right hand side. - - lhs%raw = TRIM(str(rhs)) -END SUBROUTINE string_assign_real_R16P - -! contatenation operators -PURE FUNCTION string_concat_string(lhs, rhs) RESULT(concat) - !< Concatenation with string. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(1) - !< astring = 'Hello ' - !< anotherstring = 'Bye bye' - !< test_passed(1) = astring//anotherstring=='Hello Bye bye' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: concat !< Concatenated string. - - concat = '' - IF (ALLOCATED(lhs%raw)) concat = lhs%raw - IF (ALLOCATED(rhs%raw)) concat = concat//rhs%raw -END FUNCTION string_concat_string - -PURE FUNCTION string_concat_character(lhs, rhs) RESULT(concat) - !< Concatenation with character. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(1) - !< astring = 'Hello ' - !< acharacter = 'World!' - !< test_passed(1) = astring//acharacter=='Hello World!' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: concat !< Concatenated string. - - IF (ALLOCATED(lhs%raw)) THEN - concat = lhs%raw//rhs - ELSE - concat = rhs - END IF -END FUNCTION string_concat_character - -PURE FUNCTION character_concat_string(lhs, rhs) RESULT(concat) - !< Concatenation with character (inverted). - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(1) - !< astring = 'Hello ' - !< acharacter = 'World!' - !< test_passed(1) = acharacter//astring=='World!Hello ' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: concat !< Concatenated string. - - IF (ALLOCATED(rhs%raw)) THEN - concat = lhs//rhs%raw - ELSE - concat = lhs - END IF -END FUNCTION character_concat_string - -ELEMENTAL FUNCTION string_concat_string_string(lhs, rhs) RESULT(concat) - !< Concatenation with string. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< type(string) :: yetanotherstring - !< logical :: test_passed(1) - !< astring = 'Hello ' - !< anotherstring = 'Bye bye' - !< yetanotherstring = astring.cat.anotherstring - !< test_passed(1) = yetanotherstring%chars()=='Hello Bye bye' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - TYPE(string) :: concat !< Concatenated string. - CHARACTER(kind=CK, len=:), ALLOCATABLE :: temporary !< Temporary concatenated string. - - temporary = '' - IF (ALLOCATED(lhs%raw)) temporary = lhs%raw - IF (ALLOCATED(rhs%raw)) temporary = temporary//rhs%raw - IF (temporary /= '') concat%raw = temporary -END FUNCTION string_concat_string_string - -ELEMENTAL FUNCTION string_concat_character_string(lhs, rhs) RESULT(concat) - !< Concatenation with character. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: yetanotherstring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(1) - !< astring = 'Hello ' - !< acharacter = 'World!' - !< yetanotherstring = astring.cat.acharacter - !< test_passed(1) = yetanotherstring%chars()=='Hello World!' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - TYPE(string) :: concat !< Concatenated string. - - IF (ALLOCATED(lhs%raw)) THEN - concat%raw = lhs%raw//rhs - ELSE - concat%raw = rhs - END IF -END FUNCTION string_concat_character_string - -ELEMENTAL FUNCTION character_concat_string_string(lhs, rhs) RESULT(concat) - !< Concatenation with character (inverted). - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: yetanotherstring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(1) - !< astring = 'Hello ' - !< acharacter = 'World!' - !< yetanotherstring = acharacter.cat.astring - !< test_passed(1) = yetanotherstring%chars()=='World!Hello ' - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - TYPE(string) :: concat !< Concatenated string. - - IF (ALLOCATED(rhs%raw)) THEN - concat%raw = lhs//rhs%raw - ELSE - concat%raw = lhs - END IF -END FUNCTION character_concat_string_string - -! logical operators -ELEMENTAL FUNCTION string_eq_string(lhs, rhs) RESULT(is_it) - !< Equal to string logical operator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(2) - !< astring = ' one ' - !< anotherstring = 'two' - !< test_passed(1) = ((astring==anotherstring).eqv..false.) - !< astring = 'the same ' - !< anotherstring = 'the same ' - !< test_passed(2) = ((astring==anotherstring).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw == rhs%raw -END FUNCTION string_eq_string - -ELEMENTAL FUNCTION string_eq_character(lhs, rhs) RESULT(is_it) - !< Equal to character logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = ' one ' - !< acharacter = 'three' - !< test_passed(1) = ((astring==acharacter).eqv..false.) - !< astring = 'the same ' - !< acharacter = 'the same ' - !< test_passed(2) = ((astring==acharacter).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw == rhs -END FUNCTION string_eq_character - -ELEMENTAL FUNCTION character_eq_string(lhs, rhs) RESULT(is_it) - !< Equal to character (inverted) logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = ' one ' - !< acharacter = 'three' - !< test_passed(1) = ((acharacter==astring).eqv..false.) - !< astring = 'the same ' - !< acharacter = 'the same ' - !< test_passed(2) = ((acharacter==astring).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = rhs%raw == lhs -END FUNCTION character_eq_string - -ELEMENTAL FUNCTION string_ne_string(lhs, rhs) RESULT(is_it) - !< Not equal to string logical operator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(2) - !< astring = ' one ' - !< anotherstring = 'two' - !< test_passed(1) = ((astring/=anotherstring).eqv..true.) - !< astring = 'the same ' - !< anotherstring = 'the same ' - !< test_passed(2) = ((astring/=anotherstring).eqv..false.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw /= rhs%raw -END FUNCTION string_ne_string - -ELEMENTAL FUNCTION string_ne_character(lhs, rhs) RESULT(is_it) - !< Not equal to character logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = ' one ' - !< acharacter = 'three' - !< test_passed(1) = ((astring/=acharacter).eqv..true.) - !< astring = 'the same ' - !< acharacter = 'the same ' - !< test_passed(2) = ((astring/=acharacter).eqv..false.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw /= rhs -END FUNCTION string_ne_character - -ELEMENTAL FUNCTION character_ne_string(lhs, rhs) RESULT(is_it) - !< Not equal to character (inverted) logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = ' one ' - !< acharacter = 'three' - !< test_passed(1) = ((acharacter/=astring).eqv..true.) - !< astring = 'the same ' - !< acharacter = 'the same ' - !< test_passed(2) = ((acharacter/=astring).eqv..false.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = rhs%raw /= lhs -END FUNCTION character_ne_string - -ELEMENTAL FUNCTION string_lt_string(lhs, rhs) RESULT(is_it) - !< Lower than to string logical operator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(2) - !< astring = 'one' - !< anotherstring = 'ONE' - !< test_passed(1) = ((astring T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw < rhs%raw -END FUNCTION string_lt_string - -ELEMENTAL FUNCTION string_lt_character(lhs, rhs) RESULT(is_it) - !< Lower than to character logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((astring T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw < rhs -END FUNCTION string_lt_character - -ELEMENTAL FUNCTION character_lt_string(lhs, rhs) RESULT(is_it) - !< Lower than to character (inverted) logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((acharacter T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs < rhs%raw -END FUNCTION character_lt_string - -ELEMENTAL FUNCTION string_le_string(lhs, rhs) RESULT(is_it) - !< Lower equal than to string logical operator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(3) - !< astring = 'one' - !< anotherstring = 'ONE' - !< test_passed(1) = ((astring<=anotherstring).eqv..false.) - !< astring = 'ONE' - !< anotherstring = 'one' - !< test_passed(2) = ((astring<=anotherstring).eqv..true.) - !< astring = 'ONE' - !< anotherstring = 'ONE' - !< test_passed(3) = ((astring<=anotherstring).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw <= rhs%raw -END FUNCTION string_le_string - -ELEMENTAL FUNCTION string_le_character(lhs, rhs) RESULT(is_it) - !< Lower equal than to character logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(3) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((astring<=acharacter).eqv..false.) - !< astring = 'ONE' - !< acharacter = 'one' - !< test_passed(2) = ((astring<=acharacter).eqv..true.) - !< astring = 'ONE' - !< acharacter = 'ONE' - !< test_passed(3) = ((astring<=acharacter).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw <= rhs -END FUNCTION string_le_character - -ELEMENTAL FUNCTION character_le_string(lhs, rhs) RESULT(is_it) - !< Lower equal than to character (inverted) logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(3) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((acharacter<=astring).eqv..true.) - !< astring = 'ONE' - !< acharacter = 'one' - !< test_passed(2) = ((acharacter<=astring).eqv..false.) - !< astring = 'ONE' - !< acharacter = 'ONE' - !< test_passed(3) = ((acharacter<=astring).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs <= rhs%raw -END FUNCTION character_le_string - -ELEMENTAL FUNCTION string_ge_string(lhs, rhs) RESULT(is_it) - !< Greater equal than to string logical operator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(3) - !< astring = 'one' - !< anotherstring = 'ONE' - !< test_passed(1) = ((astring>=anotherstring).eqv..true.) - !< astring = 'ONE' - !< anotherstring = 'one' - !< test_passed(2) = ((astring>=anotherstring).eqv..false.) - !< astring = 'ONE' - !< anotherstring = 'ONE' - !< test_passed(3) = ((astring>=anotherstring).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw >= rhs%raw -END FUNCTION string_ge_string - -ELEMENTAL FUNCTION string_ge_character(lhs, rhs) RESULT(is_it) - !< Greater equal than to character logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(3) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((astring>=acharacter).eqv..true.) - !< astring = 'ONE' - !< acharacter = 'one' - !< test_passed(2) = ((astring>=acharacter).eqv..false.) - !< astring = 'ONE' - !< acharacter = 'ONE' - !< test_passed(3) = ((astring>=acharacter).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw >= rhs -END FUNCTION string_ge_character - -ELEMENTAL FUNCTION character_ge_string(lhs, rhs) RESULT(is_it) - !< Greater equal than to character (inverted) logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(3) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((acharacter>=astring).eqv..false.) - !< astring = 'ONE' - !< acharacter = 'one' - !< test_passed(2) = ((acharacter>=astring).eqv..true.) - !< astring = 'ONE' - !< acharacter = 'ONE' - !< test_passed(3) = ((acharacter>=astring).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs >= rhs%raw -END FUNCTION character_ge_string - -ELEMENTAL FUNCTION string_gt_string(lhs, rhs) RESULT(is_it) - !< Greater than to string logical operator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< logical :: test_passed(2) - !< astring = 'one' - !< anotherstring = 'ONE' - !< test_passed(1) = ((astring>anotherstring).eqv..true.) - !< astring = 'ONE' - !< anotherstring = 'one' - !< test_passed(2) = ((astring>anotherstring).eqv..false.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - TYPE(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw > rhs%raw -END FUNCTION string_gt_string - -ELEMENTAL FUNCTION string_gt_character(lhs, rhs) RESULT(is_it) - !< Greater than to character logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((astring>acharacter).eqv..true.) - !< astring = 'ONE' - !< acharacter = 'one' - !< test_passed(2) = ((astring>acharacter).eqv..false.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CLASS(string), INTENT(IN) :: lhs !< Left hand side. - CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs%raw > rhs -END FUNCTION string_gt_character - -ELEMENTAL FUNCTION character_gt_string(lhs, rhs) RESULT(is_it) - !< Greater than to character (inverted) logical operator. - !< - !<```fortran - !< type(string) :: astring - !< character(len=:), allocatable :: acharacter - !< logical :: test_passed(2) - !< astring = 'one' - !< acharacter = 'ONE' - !< test_passed(1) = ((acharacter>astring).eqv..false.) - !< astring = 'ONE' - !< acharacter = 'one' - !< test_passed(2) = ((acharacter>astring).eqv..true.) - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. - CLASS(string), INTENT(IN) :: rhs !< Right hand side. - LOGICAL :: is_it !< Opreator test result. - - is_it = lhs > rhs%raw -END FUNCTION character_gt_string - -! IO -SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) - !< Formatted input. - !< - !< @bug Change temporary acks: find a more precise length of the input string and avoid the trimming! - !< - !< @bug Read listdirected with and without delimiters does not work. - CLASS(string), INTENT(inout) :: dtv !< The string. - INTEGER, INTENT(IN) :: unit !< Logical unit. - CHARACTER(len=*), INTENT(IN) :: iotype !< Edit descriptor. - INTEGER, INTENT(IN) :: v_list(:) !< Edit descriptor list. - INTEGER, INTENT(out) :: iostat !< IO status code. - CHARACTER(len=*), INTENT(inout) :: iomsg !< IO status message. - CHARACTER(len=LEN(iomsg)) :: local_iomsg !< Local variant of iomsg, so it doesn't get inappropriately redefined. - CHARACTER(kind=CK, len=1) :: delim !< String delimiter, if any. - CHARACTER(kind=CK, len=100) :: temporary !< Temporary storage string. - - IF (iotype == 'LISTDIRECTED') THEN - CALL get_next_non_blank_character_any_record(unit=unit, ch=delim, iostat=iostat, iomsg=iomsg) - IF (iostat /= 0) RETURN - IF (delim == '"' .OR. delim == "'") THEN - CALL dtv%read_delimited(unit=unit, delim=delim, iostat=iostat, iomsg=local_iomsg) - ELSE - ! step back before the non-blank - READ (unit, "(TL1)", iostat=iostat, iomsg=iomsg) - IF (iostat /= 0) RETURN - CALL dtv%read_undelimited_listdirected(unit=unit, iostat=iostat, iomsg=local_iomsg) - END IF - IF (is_iostat_eor(iostat)) THEN - ! suppress IOSTAT_EOR - iostat = 0 - ELSEIF (iostat /= 0) THEN - iomsg = local_iomsg - END IF - RETURN - ELSE - READ (unit, "(A)", iostat=iostat, iomsg=iomsg) temporary - dtv%raw = TRIM(temporary) - END IF -END SUBROUTINE read_formatted - -SUBROUTINE read_delimited(dtv, unit, delim, iostat, iomsg) - !< Read a delimited string from a unit connected for formatted input. - !< - !< If the closing delimiter is followed by end of record, then we return end of record. - !< - !< @note This does not need a doctest, it being tested by [[string::read_formatted]]. - CLASS(string), INTENT(out) :: dtv !< The string. - INTEGER, INTENT(IN) :: unit !< Logical unit. - CHARACTER(kind=CK, len=1), INTENT(IN) :: delim !< String delimiter. - INTEGER, INTENT(out) :: iostat !< IO status code. - CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg !< IO status message. - CHARACTER(kind=CK, len=1) :: ch !< A character read. - LOGICAL :: was_delim !< Indicates that the last character read was a delimiter. - - was_delim = .FALSE. - dtv%raw = '' - DO - READ (unit, "(A)", iostat=iostat, iomsg=iomsg) ch - IF (is_iostat_eor(iostat)) THEN - IF (was_delim) THEN - ! end of delimited string followed by end of record is end of the string. Pass back the - ! end of record condition to the caller - RETURN - ELSE - ! end of record without terminating delimiter - move along - CYCLE - END IF - ELSEIF (iostat /= 0) THEN - RETURN - END IF - IF (ch == delim) THEN - IF (was_delim) THEN - ! doubled delimiter is one delimiter in the value - dtv%raw = dtv%raw//ch - was_delim = .FALSE. - ELSE - ! need to test next character to see what is happening - was_delim = .TRUE. - END IF - ELSEIF (was_delim) THEN - ! the previous character was actually the delimiter for the end of the string. Put back this character - READ (unit, "(TL1)", iostat=iostat, iomsg=iomsg) - RETURN - ELSE - dtv%raw = dtv%raw//ch - END IF - END DO -END SUBROUTINE read_delimited - -SUBROUTINE read_undelimited_listdirected(dtv, unit, iostat, iomsg) - !< Read an undelimited (no leading apostrophe or double quote) character value according to the rules for list directed input. - !< - !< A blank, comma/semicolon (depending on the decimal mode), slash or end of record terminates the string. - !< - !< If input is terminated by end of record, then this procedure returns an end-of-record condition. - CLASS(string), INTENT(inout) :: dtv !< The string. - INTEGER, INTENT(IN) :: unit !< Logical unit. - INTEGER, INTENT(out) :: iostat !< IO status code. - CHARACTER(len=*), INTENT(inout) :: iomsg !< IO status message. - LOGICAL :: decimal_point ! 0) THEN - IF (pos == 1) THEN - replaced%raw = NEW//self%raw(LEN(old) + 1:) - ELSE - replaced%raw = self%raw(1:pos - 1)//NEW//self%raw(pos + LEN(old):) - END IF - END IF - END IF -END FUNCTION replace_one_occurrence - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 21 July 2021 -! summary: Get the DELIM changeable connection mode for the given unit. -! -!# Introduction -! -! If the unit is connected to an internal file, then the default value of -! NONE is always returned. - -! non type-bound-procedures -SUBROUTINE get_delimiter_mode(unit, delim, iostat, iomsg) - USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_INQUIRE_INTERNAL_UNIT - INTEGER, INTENT(IN) :: unit - !! The unit for the connection. - CHARACTER(len=1, kind=CK), INTENT(out) :: delim - !! Represents the value of the DELIM mode. - INTEGER, INTENT(out) :: iostat - !! IOSTAT error code, non-zero on error. - CHARACTER(*), INTENT(inout) :: iomsg - !! IOMSG explanatory message - only defined if iostat is non-zero. - CHARACTER(10) :: delim_buffer - !! Buffer for INQUIRE about DELIM, sized for APOSTROHPE. - CHARACTER(LEN(iomsg)) :: local_iomsg - !! Local variant of iomsg, so it doesn't get inappropriately redefined. - !! - !! get the string representation of the changeable mode - !! - INQUIRE (unit, delim=delim_buffer, iostat=iostat, iomsg=local_iomsg) - !! - IF (iostat == IOSTAT_INQUIRE_INTERNAL_UNIT) THEN - ! no way of determining the DELIM mode for an internal file - iostat = 0 - delim = '' - RETURN - ELSEIF (iostat /= 0) THEN - iomsg = local_iomsg - RETURN - END IF - ! interpret the DELIM string - IF (delim_buffer == 'QUOTE') THEN - delim = '"' - ELSEIF (delim_buffer == 'APOSTROPHE') THEN - delim = '''' - ELSE - delim = '"' - END IF -END SUBROUTINE get_delimiter_mode - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 21 July 2022 -! summary: Get the next non-blank character in the current record. - -SUBROUTINE get_next_non_blank_character_this_record(unit, ch, iostat, iomsg) - INTEGER, INTENT(IN) :: unit - !! Logical unit. - CHARACTER(kind=CK, len=1), INTENT(out) :: ch - !! The non-blank character read. Not valid if IOSTAT is non-zero. - INTEGER, INTENT(out) :: iostat - !! IO status code. - CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg - !! IO status message. - !! - DO - ! we spcify non-advancing, just in case we want this callable outside the - ! context of a child input statement - ! the PAD specifier simply saves the need for the READ statement to - ! define ch if EOR is hit - ! read(unit, "(A)", iostat=iostat, iomsg=iomsg, advance='NO') ch - ! ...but that causes ifort to blow up at runtime - READ (unit, "(A)", iostat=iostat, iomsg=iomsg, pad='NO') ch - IF (iostat .NE. 0) RETURN - IF (ch .NE. '') EXIT - END DO -END SUBROUTINE get_next_non_blank_character_this_record - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 21 July 2022 -! summary: Get the next non-blank character, advancing records if necessary. - -SUBROUTINE get_next_non_blank_character_any_record(unit, ch, iostat, iomsg) - INTEGER, INTENT(IN) :: unit - !! Logical unit. - CHARACTER(kind=CK, len=1), INTENT(out) :: ch - !! The non-blank character read. Not valid if IOSTAT is non-zero. - INTEGER, INTENT(out) :: iostat - !! IO status code. - CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg - !! IO status message. - CHARACTER(LEN(iomsg)) :: local_iomsg - !! Local variant of iomsg, so it doesn't get inappropriately redefined. - !! - DO - CALL get_next_non_blank_character_this_record(unit=unit, ch=ch, & - & iostat=iostat, iomsg=local_iomsg) - IF (IS_IOSTAT_EOR(iostat)) THEN - ! try again on the next record - READ (unit, "(/)", iostat=iostat, iomsg=iomsg) - IF (iostat .NE. 0) RETURN - ELSEIF (iostat .NE. 0) THEN - ! some sort of problem - iomsg = local_iomsg - RETURN - ELSE - ! got it - EXIT - END IF - END DO -END SUBROUTINE get_next_non_blank_character_any_record - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Stefano Zaghi, https://github.com/szaghi -! date: 21 July 2022 -! summary: Get the DECIMAL changeable connection mode for the given unit. -! -!# Introduction -! -! If the unit is connected to an internal file, -! then the default value of DECIMAL is always returned. -! This may not be the actual value in force at the time of the call -! to this procedure. - -SUBROUTINE get_decimal_mode(unit, decimal_point, iostat, iomsg) - USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_INQUIRE_INTERNAL_UNIT - INTEGER, INTENT(IN) :: unit - !! Logical unit. - LOGICAL, INTENT(out) :: decimal_point - !! True if the decimal mode is POINT, false otherwise. - INTEGER, INTENT(out) :: iostat - !! IO status code. - CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg - !! IO status message. - CHARACTER(5) :: decimal_buffer - !! Buffer for INQUIRE about DECIMAL, sized for POINT or COMMA. - CHARACTER(LEN(iomsg)) :: local_iomsg - !! Local iomsg, so it doesn't get inappropriately redefined. - !! - !! - INQUIRE (unit, decimal=decimal_buffer, iostat=iostat, iomsg=local_iomsg) - !! - IF (iostat .EQ. IOSTAT_INQUIRE_INTERNAL_UNIT) THEN - ! no way of determining the decimal mode for an internal file - iostat = 0 - decimal_point = .TRUE. - RETURN - ELSE IF (iostat .NE. 0) THEN - iomsg = local_iomsg - RETURN - END IF - decimal_point = decimal_buffer == 'POINT' -END SUBROUTINE get_decimal_mode - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 July 2022 -! summary: Display the contents of a given string -! -!# Introduction -! -!```fortran -! type(string) :: astring -! astring = ' Hello World!' -! call display( astring, "hello-world" ) -!``` - -SUBROUTINE display_str(self, msg, unitno, advance) - CLASS(String), INTENT(IN) :: self - CHARACTER(LEN=*), INTENT(IN) :: msg - INTEGER(I4P), OPTIONAL, INTENT(IN) :: unitno - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: advance - !! - TYPE(String) :: adv0 - INTEGER(i4p) :: i - !! - IF (PRESENT(advance)) THEN - adv0 = TRIM(advance) - ELSE - adv0 = "YES" - END IF - !! - IF (PRESENT(unitno)) THEN - i = unitno - ELSE - i = stdout - END IF - !! - WRITE (i, "(A)", ADVANCE=adv0%chars()) TRIM(msg)//self%chars() -END SUBROUTINE display_str - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION constructor1(c) RESULT(self) - !< Constructor of string from intrinsic fortran data type - !< - !<```fortran - !< type(string) :: astring - !< astring = String('hello') - !< astring = String( 1 ) - !< astring = String( 1.0 ) - !<``` - !=> T <<< - TYPE(string) :: self - CLASS(*), INTENT(IN) :: c - SELECT TYPE (c) - TYPE is (CHARACTER(*)) - self = c - TYPE is (REAL(r4p)) - self = c - TYPE is (REAL(r8p)) - self = c -#if defined _R16P - TYPE is (REAL(r16p)) - self = c -#endif - TYPE is (INTEGER(i1p)) - self = str(c, .TRUE.) - TYPE is (INTEGER(i2p)) - self = str(c, .TRUE.) - TYPE is (INTEGER(i4p)) - self = str(c, .TRUE.) - TYPE is (INTEGER(i8p)) - self = str(c, .TRUE.) - TYPE is (string) - self = c - END SELECT -END FUNCTION constructor1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION constructor2(c) RESULT(self) - CLASS(*), INTENT(IN) :: c(:) - TYPE(string) :: self(SIZE(c)) - ! internal - INTEGER(I4P) :: ii, tsize - - tsize = SIZE(c) - - DO ii = 1, tsize - self(ii) = String(c(ii)) - END DO -END FUNCTION constructor2 - -!---------------------------------------------------------------------------- -! NmatchStr -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 May 2021 -! summary: Returns the total number of times the substring pattern is found -! -!### Introduction -! Returns the total number of times the substring @c pattern is found in -! string. -! -!@note -! Does not handle trailing spaces that can be eliminated by TRIM() so -! strings should be trimmed when passing into function. -!@endnote - -PURE FUNCTION nmatchstr_1(obj, pattern) RESULT(ans) - CLASS(String), INTENT(IN) :: obj - !! the string to search - CHARACTER(LEN=*), INTENT(IN) :: pattern - !! the pattern to be searched - INTEGER(I4P) :: ans - !! number of mathces - INTEGER(I4P) :: ii, n - - ans = 0; n = obj%LEN() - DO ii = 1, n - IF ((ii + LEN(pattern) - 1) .GT. n) EXIT - IF (obj%raw(ii:ii + LEN(pattern) - 1) .EQ. pattern) ans = ans + 1 - END DO -END FUNCTION nmatchstr_1 - -!---------------------------------------------------------------------------- -! NmatchStr -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 May 2021 -! summary: Returns the total number of times the substring pattern is found -! -!### Introduction -! Returns the total number of times the substring @c pattern is found in -! string. -! -!@note -! Does not handle trailing spaces that can be eliminated by TRIM() so -! strings should be trimmed when passing into function. -!@endnote - -PURE FUNCTION nmatchstr_2(obj, pattern) RESULT(ans) - CLASS(String), INTENT(IN) :: obj - !! the string to search - TYPE(String), INTENT(IN) :: pattern - !! the pattern to be searched - INTEGER(I4P) :: ans - !! number of mathces - INTEGER(I4P) :: ii, n, m - - ans = 0; n = obj%LEN(); m = pattern%LEN() - DO ii = 1, n - IF ((ii + m - 1) .GT. n) EXIT - IF (obj%raw(ii:ii + m - 1) .EQ. pattern%raw(1:m)) ans = ans + 1 - END DO -END FUNCTION nmatchstr_2 - -!---------------------------------------------------------------------------- -! findStr -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 May 2021 -! summary: Returns the indices in a string where substring pattern are found -! -!### Introduction -! Function returns the indices in a string where substring pattern is found. - -PURE SUBROUTINE strfind_1(obj, pattern, indices) - CLASS(String), INTENT(IN) :: obj - CHARACTER(LEN=*), INTENT(IN) :: pattern - INTEGER(I4P), ALLOCATABLE, INTENT(OUT) :: indices(:) - ! Internal variables - INTEGER(I4P) :: i, n, m, count - - n = obj%LEN(); m = LEN(pattern); count = 0 - IF (ALLOCATED(indices)) DEALLOCATE (indices) - ALLOCATE (indices(obj%nmatchstr(pattern))) - DO i = 1, n - IF ((i + m - 1) .GT. n) EXIT - IF (obj%raw(i:i + m - 1) .EQ. pattern(1:m)) THEN - count = count + 1 - indices(count) = i - END IF - END DO -END SUBROUTINE strfind_1 - -!---------------------------------------------------------------------------- -! strfind -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 9 May 2021 -! summary: Returns the indices in a string where substring pattern are found -! -!### Introduction -! Function returns the indices in a string where substring pattern is found. - -PURE SUBROUTINE strfind_2(obj, pattern, indices) - CLASS(String), INTENT(IN) :: obj - CLASS(String), INTENT(IN) :: pattern - INTEGER(I4P), ALLOCATABLE, INTENT(OUT) :: indices(:) - ! Internal variables - CALL strfind_1(obj, TRIM(pattern%chars()), indices) -END SUBROUTINE strfind_2 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2022 -! summary: Reallocate string - -PURE SUBROUTINE String_Reallocate1(obj, row) - TYPE(String), ALLOCATABLE, INTENT(INOUT) :: obj(:) - INTEGER(I4P), INTENT(IN) :: row - INTEGER(I4P) :: ii - - IF (ALLOCATED(obj)) THEN - IF (SIZE(obj) .NE. row) THEN - DEALLOCATE (obj) - ALLOCATE (obj(row)) - END IF - ELSE - ALLOCATE (obj(row)) - END IF - - DO ii = 1, row - obj(ii) = "" - END DO -END SUBROUTINE String_Reallocate1 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2022 -! summary: Reallocate string - -PURE SUBROUTINE String_Reallocate2(obj, row, col) - TYPE(String), ALLOCATABLE, INTENT(INOUT) :: obj(:, :) - INTEGER(I4P), INTENT(IN) :: row - INTEGER(I4P), INTENT(IN) :: col - !! - INTEGER(I4P) :: ii, jj - - IF (ALLOCATED(obj)) THEN - IF (ANY(SHAPE(obj) .NE. [row, col])) THEN - DEALLOCATE (obj) - ALLOCATE (obj(row, col)) - END IF - ELSE - ALLOCATE (obj(row, col)) - END IF - - DO jj = 1, col - DO ii = 1, row - obj(ii, jj) = "" - END DO - END DO -END SUBROUTINE String_Reallocate2 - -END MODULE String_Class - -!! Changed stringifor_string_t to StringiFor_Class diff --git a/src/modules/String/src/String_Method.F90 b/src/modules/String/src/String_Method.F90 deleted file mode 100644 index 0fd29514e..000000000 --- a/src/modules/String/src/String_Method.F90 +++ /dev/null @@ -1,255 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> author: Vikas Sharma, Ph. D. -! date: 21 Oct 2021 -! summary: Additional String Methods - -MODULE String_Method -USE String_Class, ONLY: repeat, string -IMPLICIT NONE -PRIVATE -! expose StingiFor new procedures -PUBLIC :: read_file, read_lines, write_file, write_lines - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE read_file(file, lines, form, iostat, iomsg) - !< Read a file as a single string stream. - !< - !< The lines are returned as an array of strings that are read until the eof is reached. - !< The line is read as an ascii stream read until the eor is reached. - !< - !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. - !< - !<```fortran - !< type(string) :: astring - !< type(string), allocatable :: strings(:) - !< type(string) :: line(3) - !< integer :: iostat - !< character(99) :: iomsg - !< integer :: scratch - !< integer :: l - !< logical :: test_passed(8) - !< line(1) = ' Hello World! ' - !< line(2) = 'How are you? ' - !< line(3) = ' All say: "Fine thanks"' - !< open(newunit=scratch, file='read_file_test.tmp') - !< write(scratch, "(A)") line(1)%chars() - !< write(scratch, "(A)") line(2)%chars() - !< write(scratch, "(A)") line(3)%chars() - !< close(scratch) - !< call read_file(file='read_file_test.tmp', lines=strings, iostat=iostat, iomsg=iomsg) - !< test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) - !< do l=1, size(strings, dim=1) - !< test_passed(l+1) = (strings(l)==line(l)) - !< enddo - !< open(newunit=scratch, file='read_file_test.tmp', form='UNFORMATTED', access='STREAM') - !< write(scratch) line(1)%chars()//new_line('a') - !< write(scratch) line(2)%chars()//new_line('a') - !< write(scratch) line(3)%chars()//new_line('a') - !< close(scratch) - !< call read_file(file='read_file_test.tmp', lines=strings, form='unformatted', iostat=iostat, iomsg=iomsg) - !< test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) - !< do l=1, size(strings, dim=1) - !< test_passed(l+5) = (strings(l)==line(l)) - !< enddo - !< open(newunit=scratch, file='read_file_test.tmp', form='UNFORMATTED', access='STREAM') - !< close(scratch, status='DELETE') - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(*), INTENT(in) :: file !< File name. - TYPE(string), INTENT(out), ALLOCATABLE :: lines(:) !< The lines. - CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. - CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. - TYPE(string) :: form_ !< Format of unit, local variable. - INTEGER :: iostat_ !< IO status code, local variable. - CHARACTER(:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. - INTEGER :: unit !< Logical unit. - LOGICAL :: does_exist !< Check if file exist. - - iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg - INQUIRE (file=file, iomsg=iomsg_, iostat=iostat_, exist=does_exist) - IF (does_exist) THEN - form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() - SELECT CASE (form_%chars()) - CASE ('FORMATTED') - open (newunit=unit, file=file, status='OLD', action='READ', iomsg=iomsg_, iostat=iostat_, err=10) - CASE ('UNFORMATTED') - open (newunit=unit, file=file, status='OLD', action='READ', form='UNFORMATTED', access='STREAM', & - iomsg=iomsg_, iostat=iostat_, err=10) - END SELECT - CALL read_lines(unit=unit, lines=lines, form=form, iomsg=iomsg_, & - & iostat=iostat_) -10 CLOSE (unit) - END IF - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE read_file - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE read_lines(unit, lines, form, iostat, iomsg) - !< Read lines (records) from a connected-formatted unit. - !< - !< @note The connected unit is rewinded. At a successful exit current record is at eof, at the beginning otherwise. - !< - !< The lines are returned as an array of strings that are read until the eof is reached. - !< The line is read as an ascii stream read until the eor is reached. - !< - !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. - !< - !< @note There is no doctests, this being tested by means of [[read_file]] doctests. - INTEGER, INTENT(in) :: unit !< Logical unit. - TYPE(string), INTENT(out), ALLOCATABLE :: lines(:) !< The lines. - CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. - CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. - TYPE(string) :: form_ !< Format of unit, local variable. - INTEGER :: iostat_ !< IO status code, local variable. - CHARACTER(:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. - CHARACTER(1) :: ch !< Character storage. - INTEGER :: l !< Counter. - - form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() - iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg - REWIND (unit) - SELECT CASE (form_%chars()) - CASE ('FORMATTED') - l = 0 - DO - READ (unit, *, err=10, END=10) - l = l + 1 - END DO - CASE ('UNFORMATTED') - l = 0 - DO - READ (unit, err=10, END=10) ch - IF (ch == NEW_LINE('a')) l = l + 1 - END DO - END SELECT -10 REWIND (unit) - IF (l > 0) THEN - ALLOCATE (lines(1:l)) - l = 1 - iostat_ = 0 - DO - CALL lines(l)%read_line(unit=unit, form=form, iostat=iostat_, iomsg=iomsg_) - if ((iostat_ /= 0 .and. .not. is_iostat_eor(iostat_)) .or. (l >= size(lines, dim=1))) then - EXIT - END IF - l = l + 1 - END DO - END IF - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE read_lines - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE write_file(file, lines, form, iostat, iomsg) - !< Write a single string stream into file. - !< - !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. - !< - !<```fortran - !< type(string) :: astring - !< type(string) :: anotherstring - !< type(string), allocatable :: strings(:) - !< type(string) :: line(3) - !< integer :: iostat - !< character(99) :: iomsg - !< integer :: scratch - !< integer :: l - !< logical :: test_passed(8) - !< line(1) = ' Hello World! ' - !< line(2) = 'How are you? ' - !< line(3) = ' All say: "Fine thanks"' - !< anotherstring = anotherstring%join(array=line, sep=new_line('a')) - !< call write_file(file='write_file_test.tmp', lines=line, iostat=iostat, iomsg=iomsg) - !< call astring%read_file(file='write_file_test.tmp', iostat=iostat, iomsg=iomsg) - !< call astring%split(tokens=strings, sep=new_line('a')) - !< test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) - !< do l=1, size(strings, dim=1) - !< test_passed(l+1) = (strings(l)==line(l)) - !< enddo - !< call write_file(file='write_file_test.tmp', lines=line, form='unformatted', iostat=iostat, iomsg=iomsg) - !< call astring%read_file(file='write_file_test.tmp', form='unformatted', iostat=iostat, iomsg=iomsg) - !< call astring%split(tokens=strings, sep=new_line('a')) - !< test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) - !< do l=1, size(strings, dim=1) - !< test_passed(l+5) = (strings(l)==line(l)) - !< enddo - !< open(newunit=scratch, file='write_file_test.tmp') - !< close(scratch, status='DELETE') - !< print '(L1)', all(test_passed) - !<``` - !=> T <<< - CHARACTER(*), INTENT(in) :: file !< File name. - TYPE(string), INTENT(in) :: lines(1:) !< The lines. - CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. - CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. - TYPE(string) :: form_ !< Format of unit, local variable. - INTEGER :: iostat_ !< IO status code, local variable. - CHARACTER(:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. - INTEGER :: unit !< Logical unit. - - iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg - form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() - SELECT CASE (form_%chars()) - CASE ('FORMATTED') - open (newunit=unit, file=file, action='WRITE', iomsg=iomsg_, iostat=iostat_, err=10) - CASE ('UNFORMATTED') - open (newunit=unit, file=file, action='WRITE', form='UNFORMATTED', access='STREAM', iomsg=iomsg_, iostat=iostat_, err=10) - END SELECT - call write_lines(unit=unit, lines=lines, form=form, iomsg=iomsg_, iostat=iostat_) -10 CLOSE (unit) - IF (PRESENT(iostat)) iostat = iostat_ - IF (PRESENT(iomsg)) iomsg = iomsg_ -END SUBROUTINE write_file - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE write_lines(unit, lines, form, iostat, iomsg) - !< Write lines (records) to a connected-formatted unit. - !< - !< @note There is no doctests, this being tested by means of [[write_file]] doctests. - INTEGER, INTENT(in) :: unit !< Logical unit. - TYPE(string), INTENT(in) :: lines(1:) !< The lines. - CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. - INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. - CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. - INTEGER :: l !< Counter. - - DO l = 1, SIZE(lines, dim=1) - CALL lines(l)%write_line(unit=unit, form=form, iostat=iostat, iomsg=iomsg) - END DO -END SUBROUTINE write_lines -END MODULE String_Method diff --git a/src/modules/SuperLUInterface/CMakeLists.txt b/src/modules/SuperLUInterface/CMakeLists.txt deleted file mode 100644 index 5ad0d4d3c..000000000 --- a/src/modules/SuperLUInterface/CMakeLists.txt +++ /dev/null @@ -1,38 +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 -# - -IF(USE_SUPERLU) - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/SuperLU_Types.F90 - ${src_path}/SuperLU_Enums.F90 - ${src_path}/SuperLU_Util_Methods.F90 - ${src_path}/SuperLU_dUtil_Methods.F90 - ${src_path}/SuperLU_dgssv_Methods.F90 - ${src_path}/SuperLU_dgssvx_Methods.F90 - ${src_path}/SuperLU_dgsitrf_Methods.F90 - ${src_path}/SuperLU_dgsisx_Methods.F90 - ${src_path}/SuperLU_dgstrf_Methods.F90 - ${src_path}/SuperLU_dgstrs_Methods.F90 - ${src_path}/SuperLU_dgscon_Methods.F90 - ${src_path}/SuperLU_dgsequ_Methods.F90 - ${src_path}/SuperLU_dlaqgs_Methods.F90 - ${src_path}/SuperLU_dgsrfs_Methods.F90 - ${src_path}/SuperLUInterface.F90 - ) -ENDIF() diff --git a/src/modules/SuperLUInterface/src/SuperLUInterface.F90 b/src/modules/SuperLUInterface/src/SuperLUInterface.F90 deleted file mode 100644 index c963bcbc7..000000000 --- a/src/modules/SuperLUInterface/src/SuperLUInterface.F90 +++ /dev/null @@ -1,34 +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 SuperLUInterface -USE SuperLU_Types -USE SuperLU_Util_Methods -USE SuperLU_dUtil_Methods -USE SuperLU_dgssv_Methods -USE SuperLU_dgssvx_Methods -USE SuperLU_dgsitrf_Methods -USE SuperLU_dgsisx_Methods -USE SuperLU_dgstrf_Methods -USE SuperLU_dgstrs_Methods -USE SuperLU_dgstrs_Methods -USE SuperLU_dgscon_Methods -USE SuperLU_dgsequ_Methods -USE SuperLU_dlaqgs_Methods -USE SuperLU_dgsrfs_Methods -IMPLICIT NONE -END MODULE SuperLUInterface diff --git a/src/modules/SuperLUInterface/src/SuperLU_Enums.F90 b/src/modules/SuperLUInterface/src/SuperLU_Enums.F90 deleted file mode 100644 index 9ed1265b1..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_Enums.F90 +++ /dev/null @@ -1,320 +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 SuperLU_Enums -USE ISO_C_BINDING, ONLY: C_INT, C_DOUBLE, C_CHAR, C_FLOAT, C_PTR -IMPLICIT NONE - -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {NO, YES} yes_no_t; - -ENUM, BIND(c) - ENUMERATOR :: NO, YES -END ENUM - -PUBLIC :: NO, YES - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED} fact_t; - -ENUM, BIND(c) - ENUMERATOR :: DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED -END ENUM - -PUBLIC :: DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef ENUM{NOROWPERM, LargeDiag_MC64, LargeDiag_HWPM, MY_PERMR}rowperm_t; -ENUM, BIND(C) - ENUMERATOR :: NOROWPERM, LargeDiag_MC64, LargeDiag_HWPM, MY_PERMR -END ENUM - -PUBLIC :: NOROWPERM, LargeDiag_MC64, LargeDiag_HWPM, MY_PERMR - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {NATURAL, MMD_ATA, MMD_AT_PLUS_A, COLAMD, -! METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC} colperm_t; - -ENUM, BIND(c) - ENUMERATOR :: NATURAL, MMD_ATA, MMD_AT_PLUS_A, COLAMD, & - & METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC -END ENUM - -PUBLIC :: NATURAL, MMD_ATA, MMD_AT_PLUS_A, COLAMD, & -& METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {NOTRANS, TRANS, CONJ} trans_t; - -ENUM, BIND(C) - ENUMERATOR :: NOTRANS, TRANS, CONJ -END ENUM - -PUBLIC :: NOTRANS, TRANS, CONJ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {NOEQUIL, ROW, COL, BOTH} DiagScale_t; -ENUM, BIND(C) - ENUMERATOR :: NOEQUIL, ROW, COL, BOTH -END ENUM - -PUBLIC :: NOEQUIL, ROW, COL, BOTH - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {NOREFINE, SLU_SINGLE=1, SLU_DOUBLE, SLU_EXTRA} IterRefine_t; - -ENUM, BIND(C) - ENUMERATOR :: NOREFINE, SLU_SINGLE = 1, SLU_DOUBLE, SLU_EXTRA -END ENUM - -PUBLIC :: NOREFINE, SLU_SINGLE, SLU_DOUBLE, SLU_EXTRA - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE} MemType; - -ENUM, BIND(C) - ENUMERATOR :: USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE -END ENUM - -PUBLIC :: USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {HEAD, TAIL} stack_end_t; - -ENUM, BIND(C) - ENUMERATOR :: HEAD, TAIL -END ENUM - -PUBLIC :: HEAD, TAIL - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {SYSTEM, USER} LU_space_t; - -ENUM, BIND(c) - ENUMERATOR :: SYSTEM, USER -END ENUM - -PUBLIC :: SYSTEM, USER - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {ONE_NORM, TWO_NORM, INF_NORM} norm_t; - -ENUM, BIND(C) - ENUMERATOR :: ONE_NORM, TWO_NORM, INF_NORM -END ENUM - -PUBLIC :: ONE_NORM, TWO_NORM, INF_NORM - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {SILU, SMILU_1, SMILU_2, SMILU_3} milu_t; -ENUM, BIND(C) - ENUMERATOR :: SILU, SMILU_1, SMILU_2, SMILU_3 -END ENUM - -PUBLIC :: SILU, SMILU_1, SMILU_2, SMILU_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! /* -! * The following enumerate type is used by the statistics variable -! * to keep track of flop count and time spent at various stages. -! * -! * Note that not all of the fields are disjoint. -! */ -! typedef enum { -! COLPERM, /* find a column ordering that minimizes fills */ -! ROWPERM, /* find a row ordering maximizes diagonal. */ -! RELAX, /* find artificial supernodes */ -! ETREE, /* compute column etree */ -! EQUIL, /* equilibrate the original matrix */ -! SYMBFAC, /* symbolic factorization. */ -! DIST, /* distribute matrix. */ -! FACT, /* perform LU factorization */ -! COMM, /* communication for factorization */ -! COMM_DIAG, /* Bcast diagonal block to process column */ -! COMM_RIGHT, /* communicate L panel */ -! COMM_DOWN, /* communicate U panel */ -! SOL_COMM,/* communication for solve */ -! SOL_GEMM,/* gemm for solve */ -! SOL_TRSM,/* trsm for solve */ -! SOL_TOT, /* LU-solve time*/ -! RCOND, /* estimate reciprocal condition number */ -! SOLVE, /* forward and back solves */ -! REFINE, /* perform iterative refinement */ -! TRSV, /* fraction of FACT spent in xTRSV */ -! GEMV, /* fraction of FACT spent in xGEMV */ -! FERR, /* estimate error bounds after iterative refinement */ -! NPHASES /* total number of phases */ -! } PhaseType; - -ENUM, BIND(C) - ENUMERATOR :: COLPERM, ROWPERM, RELAX, ETREE, EQUIL, SYMBFAC, & - & DIST, FACT, COMM, COMM_DIAG, COMM_RIGHT, COMM_DOWN,& - & SOL_COMM, SOL_GEMM, SOL_TRSM, SOL_TOT, RCOND, SOLVE, REFINE, & - & TRSV, GEMV, FERR, NPHASES -END ENUM - -PUBLIC :: COLPERM, ROWPERM, RELAX, ETREE, EQUIL, SYMBFAC, & - & DIST, FACT, COMM, COMM_DIAG, COMM_RIGHT, COMM_DOWN,& - & SOL_COMM, SOL_GEMM, SOL_TRSM, SOL_TOT, RCOND, SOLVE, REFINE, & - & TRSV, GEMV, FERR, NPHASES - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-21 -! summary: Stype_t enums -! -!# Introduction -! -! typedef enum { -! SLU_NC, /* column-wise, no supernode */ -! SLU_NCP, /* column-wise, column-permuted, no supernode -! (The consecutive columns of nonzeros, after permutation, -! may not be stored contiguously.) */ -! SLU_NR, /* row-wize, no supernode */ -! SLU_SC, /* column-wise, supernode */ -! SLU_SCP, /* supernode, column-wise, permuted */ -! SLU_SR, /* row-wise, supernode */ -! SLU_DN, /* Fortran style column-wise storage for dense matrix */ -! SLU_NR_loc /* distributed compressed row format */ -! } Stype_t; -! -ENUM, BIND(C) - ENUMERATOR :: SLU_NC - ENUMERATOR :: SLU_NCP - ENUMERATOR :: SLU_NR - ENUMERATOR :: SLU_SC - ENUMERATOR :: SLU_SCP - ENUMERATOR :: SLU_SR - ENUMERATOR :: SLU_DN - ENUMERATOR :: SLU_NR_loc -END ENUM - -PUBLIC :: SLU_NC, SLU_NCP, SLU_NR, SLU_SC, SLU_SCP, SLU_SR, & - & SLU_DN, SLU_NR_loc - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-21 -! summary: Dtype_t -! -!# Introduction -! -!```c -! typedef enum { -! SLU_S, /* single */ -! SLU_D, /* double */ -! SLU_C, /* single complex */ -! SLU_Z /* double complex */ -! } Dtype_t; -!``` - -ENUM, BIND(c) - ENUMERATOR :: SLU_S - ENUMERATOR :: SLU_D - ENUMERATOR :: SLU_C - ENUMERATOR :: SLU_Z -END ENUM - -PUBLIC :: SLU_S, SLU_D, SLU_C, SLU_Z - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-21 -! summary: MType_t -! -!# Introduction -! -!```c -! typedef enum { -! SLU_GE, /* general */ -! SLU_TRLU, /* lower triangular, unit diagonal */ -! SLU_TRUU, /* upper triangular, unit diagonal */ -! SLU_TRL, /* lower triangular */ -! SLU_TRU, /* upper triangular */ -! SLU_SYL, /* symmetric, store lower half */ -! SLU_SYU, /* symmetric, store upper half */ -! SLU_HEL, /* Hermitian, store lower half */ -! SLU_HEU /* Hermitian, store upper half */ -! } Mtype_t; -!``` - -ENUM, BIND(c) - ENUMERATOR :: SLU_GE - ENUMERATOR :: SLU_TRLU - ENUMERATOR :: SLU_TRUU - ENUMERATOR :: SLU_TRL - ENUMERATOR :: SLU_TRU - ENUMERATOR :: SLU_SYL - ENUMERATOR :: SLU_SYU - ENUMERATOR :: SLU_HEL - ENUMERATOR :: SLU_HEU -END ENUM - -PUBLIC :: SLU_GE, SLU_TRLU, SLU_TRUU, SLU_TRL, SLU_TRU, SLU_SYL, & - & SLU_SYU, SLU_HEL, SLU_HEU - -END MODULE SuperLU_Enums diff --git a/src/modules/SuperLUInterface/src/SuperLU_Types.F90 b/src/modules/SuperLUInterface/src/SuperLU_Types.F90 deleted file mode 100644 index 7db388c16..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_Types.F90 +++ /dev/null @@ -1,668 +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 SuperLU_Types -USE ISO_C_BINDING, ONLY: C_INT, C_DOUBLE, C_CHAR, C_FLOAT, C_PTR -USE SuperLU_Enums -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: yes_no_ - INTEGER(C_INT) :: no, yes -END TYPE - -TYPE(yes_no_), PUBLIC, PARAMETER :: yes_no_t = yes_no_(no=no, yes=yes) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: fact_ - INTEGER(C_INT) :: DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED -END TYPE fact_ - -TYPE(fact_), PARAMETER, PUBLIC :: fact_t = fact_(& - & DOFACT=DOFACT, & - & SamePattern=SamePattern, & - & SamePattern_SameRowPerm=SamePattern_SameRowPerm, & - & FACTORED=FACTORED & - &) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: rowperm_ - INTEGER(C_INT) :: NOROWPERM - INTEGER(C_INT) :: LargeDiag_MC64 - INTEGER(C_INT) :: LargeDiag_HWPM - INTEGER(C_INT) :: MY_PERMR -END TYPE rowperm_ - -TYPE(rowperm_), PUBLIC, PARAMETER :: rowperm_t = rowperm_(& - & NOROWPERM=NOROWPERM, & - & LargeDiag_MC64=LargeDiag_MC64, & - & LargeDiag_HWPM=LargeDiag_HWPM, & - & MY_PERMR=MY_PERMR & - & ) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: colperm_ - INTEGER(C_INT) :: NATURAL, MMD_ATA, MMD_AT_PLUS_A, & - & COLAMD, METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC -END TYPE colperm_ - -TYPE(colperm_), PUBLIC, PARAMETER :: colperm_t = colperm_(& - & NATURAL=NATURAL, & - & MMD_ATA=MMD_ATA, & - & MMD_AT_PLUS_A=MMD_AT_PLUS_A, & - & COLAMD=COLAMD, & - & METIS_AT_PLUS_A=METIS_AT_PLUS_A, & - & PARMETIS=PARMETIS, & - & ZOLTAN=ZOLTAN, & - & MY_PERMC=MY_PERMC & - &) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: trans_ - INTEGER(C_INT) :: NOTRANS, TRANS, CONJ -END TYPE trans_ - -TYPE(trans_), PARAMETER, PUBLIC :: trans_t = trans_(& - & NOTRANS=NOTRANS, trans=trans, conj=conj) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: DiagScale_ - INTEGER(C_INT) :: NOEQUIL, ROW, COL, BOTH -END TYPE DiagScale_ - -TYPE(DiagScale_), PARAMETER, PUBLIC :: DiagScale_t = DiagScale_(& - & NOEQUIL=NOEQUIL, ROW=ROW, COL=COL, BOTH=BOTH) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {NOREFINE, SLU_SINGLE=1, SLU_DOUBLE, SLU_EXTRA} IterRefine_t; - -TYPE :: IterRefine_ - INTEGER(C_INT) :: NOREFINE, SLU_SINGLE = 1, SLU_DOUBLE, SLU_EXTRA -END TYPE - -TYPE(IterRefine_), PARAMETER, PUBLIC :: IterRefine_t = IterRefine_(& -& NOREFINE, SLU_SINGLE, SLU_DOUBLE, SLU_EXTRA) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: MemType_ - INTEGER(C_INT) :: USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE -END TYPE - -TYPE(MemType_), PUBLIC, PARAMETER :: MemType_t = MemType_( & -& USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef enum {HEAD, TAIL} stack_end_t; - -TYPE :: stack_end_ - INTEGER(C_INT) :: HEAD, TAIL -END TYPE - -TYPE(stack_end_), PUBLIC, PARAMETER :: stack_end_t = stack_end_(& -& HEAD, TAIL) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: LU_space_ - INTEGER(C_INT) :: SYSTEM - INTEGER(C_INT) :: USER -END TYPE LU_space_ - -TYPE(LU_space_), PARAMETER, PUBLIC :: LU_space_t = LU_space_(& - & SYSTEM=SYSTEM, & - & USER=USER & - & ) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: Stype_ - INTEGER(C_INT) :: SLU_NC - INTEGER(C_INT) :: SLU_NCP - INTEGER(C_INT) :: SLU_NR - INTEGER(C_INT) :: SLU_SC - INTEGER(C_INT) :: SLU_SCP - INTEGER(C_INT) :: SLU_SR - INTEGER(C_INT) :: SLU_DN - INTEGER(C_INT) :: SLU_NR_LOC -END TYPE Stype_ - -TYPE(Stype_), PARAMETER, PUBLIC :: Stype_t = Stype_(& - & SLU_NC=SLU_NC, & - & SLU_NCP=SLU_NCP, & - & SLU_NR=SLU_NR, & - & SLU_SC=SLU_SC, & - & SLU_SCP=SLU_SCP, & - & SLU_SR=SLU_SR, & - & SLU_DN=SLU_DN, & - & SLU_NR_LOC=SLU_NR_LOC & - & ) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: Dtype_ - INTEGER(C_INT) :: SLU_S - INTEGER(C_INT) :: SLU_D - INTEGER(C_INT) :: SLU_C - INTEGER(C_INT) :: SLU_Z -END TYPE Dtype_ - -TYPE(Dtype_), PARAMETER, PUBLIC :: Dtype_t = Dtype_(& - & SLU_S=SLU_S, & - & SLU_D=SLU_D, & - & SLU_C=SLU_C, & - & SLU_Z=SLU_Z) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE :: Mtype_ - INTEGER(C_INT) :: SLU_GE - INTEGER(C_INT) :: SLU_TRLU - INTEGER(C_INT) :: SLU_TRUU - INTEGER(C_INT) :: SLU_TRL - INTEGER(C_INT) :: SLU_TRU - INTEGER(C_INT) :: SLU_SYL - INTEGER(C_INT) :: SLU_SYU - INTEGER(C_INT) :: SLU_HEL - INTEGER(C_INT) :: SLU_HEU -END TYPE Mtype_ - -TYPE(Mtype_), PUBLIC, PARAMETER :: Mtype_t = Mtype_(& - & SLU_GE=SLU_GE, & - & SLU_TRLU=SLU_TRLU, & - & SLU_TRUU=SLU_TRUU, & - & SLU_TRL=SLU_TRL, & - & SLU_TRU=SLU_TRU, & - & SLU_SYL=SLU_SYL, & - & SLU_SYU=SLU_SYU, & - & SLU_HEL=SLU_HEL, & - & SLU_HEU=SLU_HEU) - -!---------------------------------------------------------------------------- -! superlu_options_t -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-21 -! summary: SuperLU options -! -!# Introduction -! - -! typedef struct { -! fact_t Fact; -! yes_no_t Equil; -! colperm_t ColPerm; -! trans_t Trans; -! IterRefine_t IterRefine; -! double DiagPivotThresh; -! yes_no_t SymmetricMode; -! yes_no_t PivotGrowth; -! yes_no_t ConditionNumber; -! rowperm_t RowPerm; -! int ILU_DropRule; -! double ILU_DropTol; /* threshold for dropping */ -! double ILU_FillFactor; /* gamma in the secondary dropping */ -! norm_t ILU_Norm; /* infinity-norm, 1-norm, or 2-norm */ -! double ILU_FillTol; /* threshold for zero pivot perturbation */ -! milu_t ILU_MILU; -! double ILU_MILU_Dim; /* Dimension of PDE (if available) */ -! yes_no_t ParSymbFact; -! yes_no_t ReplaceTinyPivot; /* used in SuperLU_DIST */ -! yes_no_t SolveInitialized; -! yes_no_t RefineInitialized; -! yes_no_t PrintStat; -! int nnzL, nnzU; /* used to store nnzs for now */ -! int num_lookaheads; /* num of levels in look-ahead */ -! yes_no_t lookahead_etree; /* use etree computed from the -! serial symbolic factorization */ -! yes_no_t SymPattern; /* symmetric factorization */ -! } superlu_options_t; -! - -TYPE, BIND(C) :: superlu_options_t - INTEGER(C_INT) :: Fact - INTEGER(C_INT) :: Equil - INTEGER(C_INT) :: ColPerm - INTEGER(C_INT) :: Trans - INTEGER(C_INT) :: IterRefine - REAL(C_DOUBLE) :: DiagPivotThresh - INTEGER(C_INT) :: SymmetricMode - INTEGER(C_INT) :: PivotGrowth - INTEGER(C_INT) :: ConditionNumber - INTEGER(C_INT) :: RowPerm - INTEGER(C_INT) :: ILU_DropRule - REAL(C_DOUBLE) :: ILU_DropTol - REAL(C_DOUBLE) :: ILU_FillFactor - INTEGER(C_INT) :: ILU_Norm - REAL(C_DOUBLE) :: ILU_FillTol - INTEGER(C_INT) :: ILU_MILU; - REAL(C_DOUBLE) :: ILU_MILU_Dim - INTEGER(C_INT) :: ParSymbFact - INTEGER(C_INT) :: ReplaceTinyPivot - INTEGER(C_INT) :: SolveInitialized - INTEGER(C_INT) :: RefineInitialized - INTEGER(C_INT) :: PrintStat = 0 - INTEGER(C_INT) :: nnzL - INTEGER(C_INT) :: nnzU - INTEGER(C_INT) :: num_lookaheads - INTEGER(C_INT) :: lookahead_etree - INTEGER(C_INT) :: SymPattern -END TYPE superlu_options_t - -PUBLIC :: superlu_options_t - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct e_node { -! int size; /* length of the memory that has been used */ -! void *mem; /* pointer to the new malloc'd store */ -! } ExpHeader; - -TYPE, BIND(c) :: ExpHeader - INTEGER(C_INT) :: size - TYPE(C_PTR) :: mem -END TYPE ExpHeader - -PUBLIC :: ExpHeader - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int size; -! int used; -! int top1; /* grow upward, relative to &array[0] */ -! int top2; /* grow downward */ -! void *array; -! } LU_stack_t; - -TYPE, BIND(c) :: LU_stack_t - INTEGER(C_INT) :: size - INTEGER(C_INT) :: used - INTEGER(C_INT) :: top1 - INTEGER(C_INT) :: top2 - TYPE(C_PTR) :: array -END TYPE LU_stack_t - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int *panel_histo; /* histogram of panel size distribution */ -! double *utime; /* running time at various phases */ -! flops_t *ops; /* operation count at various phases */ -! int TinyPivots; /* number of tiny pivots */ -! int RefineSteps; /* number of iterative refinement steps */ -! int expansions; /* number of memory expansions */ -! } SuperLUStat_t; - -TYPE, BIND(C) :: SuperLUStat_t - ! INTEGER(C_INT), POINTER :: panel_histo(:) - ! REAL(C_DOUBLE), POINTER :: utime(:) - ! REAL(C_FLOAT), POINTER :: ops(:) - TYPE(C_PTR) :: panel_histo - TYPE(C_PTR) :: utime - TYPE(C_PTR) :: ops - INTEGER(C_INT) :: TinyPivots - INTEGER(C_INT) :: RefineSteps - INTEGER(C_INT) :: expansions -END TYPE SuperLUStat_t - -PUBLIC :: SuperLUStat_t - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! float for_lu; -! float total_needed; -! } mem_usage_t; - -TYPE, BIND(C) :: mem_usage_t - REAL(C_FLOAT) :: for_lu - REAL(C_FLOAT) :: total_needed -END TYPE mem_usage_t - -PUBLIC :: mem_usage_t - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct{ -! int * xsup; /*supernode and column mapping*/ -! int * supno; -! int * lsub; /*compressed L subscripts*/ -! int * xlsub; -! void * lusup; /*L supernodes*/ -! int * xlusup; -! void * ucol; /*U columns*/ -! int * usub; -! int * xusub; -! int nzlmax; /*current max size of lsub*/ -! int nzumax; int nzlumax; int n; /*number of columns in the matrix*/ -! LU_space_t MemModel; int num_expansions; -! ExpHeader * expanders; /*Array of pointers to 4 types of memory*/ -! LU_stack_t stack; /*USE user supplied memory*/ -! }GlobalLU_t; - -TYPE, BIND(c) :: GlobalLU_t - TYPE(C_PTR) :: xsup, supno, lsub, xlsub, lusup, xlusup, ucol, usub - TYPE(C_PTR) :: xusub - INTEGER(C_INT) :: nzlmax, nzumax, nzlumax, n, num_expansions - INTEGER(C_INT) :: MemModel - TYPE(ExpHeader) :: expanders - TYPE(LU_stack_t) :: stack -END TYPE GlobalLU_t - -PUBLIC :: GlobalLU_t - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! Stype_t Stype; /* Storage type: interprets the storage structure -! pointed to by *Store. */ -! Dtype_t Dtype; /* Data type. */ -! Mtype_t Mtype; /* Matrix type: describes the mathematical property of -! the matrix. */ -! int_t nrow; /* number of rows */ -! int_t ncol; /* number of columns */ -! void *Store; /* pointer to the actual storage of the matrix */ -! } SuperMatrix; - -TYPE, BIND(C) :: SuperMatrix - INTEGER(C_INT) :: Stype; - INTEGER(C_INT) :: Dtype; - INTEGER(C_INT) :: Mtype; - INTEGER(C_INT) :: nrow - INTEGER(C_INT) :: ncol - TYPE(C_PTR) :: Store -END TYPE SuperMatrix - -PUBLIC :: SuperMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int_t nnz; /* number of nonzeros in the matrix */ -! void *nzval; /* pointer to array of nonzero values, packed by column */ -! int_t *rowind; /* pointer to array of row indices of the nonzeros */ -! int_t *colptr; /* pointer to array of beginning of columns in nzval[] -! and rowind[] */ -! /* Note: -! Zero-based indexing is used; -! colptr[] has ncol+1 entries, the last one pointing -! beyond the last column, so that colptr[ncol] = nnz. */ -! } NCformat; - -TYPE, BIND(c) :: NCformat - INTEGER(C_INT) :: nnz - TYPE(C_PTR) :: nzval - TYPE(C_PTR) :: rowind - TYPE(C_PTR) :: colptr -END TYPE NCformat - -PUBLIC :: NCformat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int_t nnz; /* number of nonzeros in the matrix */ -! void *nzval; /* pointer to array of nonzero values, packed by raw */ -! int_t *colind; /* pointer to array of columns indices of the nonzeros */ -! int_t *rowptr; /* pointer to array of beginning of rows in nzval[] -! and colind[] */ -! /* Note: -! Zero-based indexing is used; -! rowptr[] has nrow+1 entries, the last one pointing -! beyond the last row, so that rowptr[nrow] = nnz. */ -! } NRformat; - -TYPE, BIND(c) :: NRformat - INTEGER(C_INT) :: nnz - TYPE(C_PTR) :: nzval - TYPE(C_PTR) :: colind - TYPE(C_PTR) :: rowptr -END TYPE NRformat - -PUBLIC :: NRformat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int_t nnz; /* number of nonzeros in the matrix */ -! int_t nsuper; /* number of supernodes, minus 1 */ -! void *nzval; /* pointer to array of nonzero values, packed by column */ -! int_t *nzval_colptr; /* pointer to array of beginning of columns in nzval[] */ -! int_t *rowind; /* pointer to array of compressed row indices of -! rectangular supernodes */ -! int_t -! *rowind_colptr; /* pointer to array of beginning of columns in rowind[] */ -! int_t *col_to_sup; /* col_to_sup[j] is the supernode number to which column -! j belongs; mapping from column to supernode number. */ -! int_t *sup_to_col; /* sup_to_col[s] points to the start of the s-th -! supernode; mapping from supernode number to column. -! e.g.: col_to_sup: 0 1 2 2 3 3 3 4 4 4 4 4 4 (ncol=12) -! sup_to_col: 0 1 2 4 7 12 (nsuper=4) */ -! /* Note: -! Zero-based indexing is used; -! nzval_colptr[], rowind_colptr[], col_to_sup and -! sup_to_col[] have ncol+1 entries, the last one -! pointing beyond the last column. -! For col_to_sup[], only the first ncol entries are -! defined. For sup_to_col[], only the first nsuper+2 -! entries are defined. */ -! } SCformat; -! - -TYPE, BIND(c) :: SCformat - INTEGER(C_INT) :: nnz - INTEGER(C_INT) :: nsuper - TYPE(C_PTR) :: nzval - TYPE(C_PTR) :: nzval_colptr - TYPE(C_PTR) :: rowind - TYPE(C_PTR) :: rowind_colptr - TYPE(C_PTR) :: col_to_sup - TYPE(C_PTR) :: sup_to_col -END TYPE SCformat - -PUBLIC :: SCformat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int_t nnz; /* number of nonzeros in the matrix */ -! int_t nsuper; /* number of supernodes */ -! void *nzval; /* pointer to array of nonzero values, packed by column */ -! int_t *nzval_colbeg; /* nzval_colbeg[j] points to beginning of column j -! in nzval[] */ -! int_t *nzval_colend; /* nzval_colend[j] points to one past the last element -! of column j in nzval[] */ -! int_t *rowind; /* pointer to array of compressed row indices of -! rectangular supernodes */ -! int_t *rowind_colbeg; /* rowind_colbeg[j] points to beginning of column j -! in rowind[] */ -! int_t *rowind_colend; /* rowind_colend[j] points to one past the last element -! of column j in rowind[] */ -! int_t *col_to_sup; /* col_to_sup[j] is the supernode number to which column -! j belongs; mapping from column to supernode. */ -! int_t *sup_to_colbeg; /* sup_to_colbeg[s] points to the start of the s-th -! supernode; mapping from supernode to column.*/ -! int_t *sup_to_colend; /* sup_to_colend[s] points to one past the end of the -! s-th supernode; mapping from supernode number to -! column. -! e.g.: col_to_sup: 0 1 2 2 3 3 3 4 4 4 4 4 4 (ncol=12) -! sup_to_colbeg: 0 1 2 4 7 (nsuper=4) -! sup_to_colend: 1 2 4 7 12 */ -! /* Note: -! Zero-based indexing is used; -! nzval_colptr[], rowind_colptr[], col_to_sup and -! sup_to_col[] have ncol+1 entries, the last one -! pointing beyond the last column. */ -! } SCPformat; - -TYPE, BIND(c) :: SCPformat - INTEGER(C_INT) :: nnz, nsuper - TYPE(C_PTR) :: nzval, nzval_colbeg, nzval_colend, rowind, & - & rowind_colbeg, rowindx_colend, col_to_sup, sup_to_colbeg, & - & sup_to_colend -END TYPE SCPformat - -PUBLIC :: SCPformat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int_t nnz; /* number of nonzeros in the matrix */ -! void *nzval; /* pointer to array of nonzero values, packed by column */ -! int_t *rowind; /* pointer to array of row indices of the nonzeros */ -! /* Note: nzval[]/rowind[] always have the same length */ -! int_t *colbeg; /* colbeg[j] points to the beginning of column j in nzval[] -! and rowind[] */ -! int_t *colend; /* colend[j] points to one past the last element of column -! j in nzval[] and rowind[] */ -! /* Note: -! Zero-based indexing is used; -! The consecutive columns of the nonzeros may not be -! contiguous in storage, because the matrix has been -! postmultiplied by a column permutation matrix. */ -! } NCPformat; - -TYPE, BIND(c) :: NCPformat - INTEGER(C_INT) :: nnz - TYPE(C_PTR) :: nzval, rowindx, colbeg, colend -END TYPE NCPformat - -PUBLIC :: NCPformat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int_t lda; /* leading dimension */ -! void *nzval; /* array of size lda*ncol to represent a dense matrix */ -! } DNformat; - -TYPE, BIND(c) :: DNformat - INTEGER(C_INT) :: lda - TYPE(C_PTR) :: nzval -END TYPE DNformat - -PUBLIC :: DNformat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct { -! int_t nnz_loc; /* number of nonzeros in the local submatrix */ -! int_t m_loc; /* number of rows local to this processor */ -! int_t fst_row; /* global index of the first row */ -! void *nzval; /* pointer to array of nonzero values, packed by row */ -! int_t *rowptr; /* pointer to array of beginning of rows in nzval[] -! and colind[] */ -! int_t *colind; /* pointer to array of column indices of the nonzeros */ -! /* Note: -! Zero-based indexing is used; -! rowptr[] has n_loc + 1 entries, the last one pointing -! beyond the last row, so that rowptr[n_loc] = nnz_loc.*/ -! } NRformat_loc; - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! typedef struct NRformat_loc3d { -! NRformat_loc *A_nfmt; // Gathered A matrix on 2D grid-0 -! void *B3d; // on the entire 3D process grid -! int ldb; // relative to 3D process grid -! int nrhs; -! int m_loc; // relative to 3D process grid -! void *B2d; // on 2D process layer grid-0 -! -! int *row_counts_int; // these counts are stored on 2D layer grid-0, -! int *row_disp; // but count the number of {A, B} rows along Z-dimension -! int *nnz_counts_int; -! int *nnz_disp; -! int *b_counts_int; -! int *b_disp; -! -! /* The following 4 structures are used for scattering -! solution X from 2D grid-0 back to 3D processes */ -! int num_procs_to_send; -! int *procs_to_send_list; -! int *send_count_list; -! int num_procs_to_recv; -! int *procs_recv_from_list; -! int *recv_count_list; -! } NRformat_loc3d; - -END MODULE SuperLU_Types diff --git a/src/modules/SuperLUInterface/src/SuperLU_Util_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_Util_Methods.F90 deleted file mode 100644 index c239952e4..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_Util_Methods.F90 +++ /dev/null @@ -1,556 +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 SuperLU_Util_Methods -USE ISO_C_BINDING, ONLY: C_PTR, C_INT, C_DOUBLE, C_CHAR, C_FLOAT, & - & C_SIZE_T -USE SuperLU_Types -IMPLICIT NONE - -PRIVATE - -#include "./include/macros.inc" - -!---------------------------------------------------------------------------- -! set_default_options -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE set_default_options(options) BIND(C, & - & NAME='set_default_options') - IMPORT superlu_options_t - TYPE(superlu_options_t), INTENT(INOUT) :: options - END SUBROUTINE set_default_options -END INTERFACE - -PUBLIC :: set_default_options - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Set the default values for the options argument for ILU. -! void ilu_set_default_options(superlu_options_t *options) - -INTERFACE - SUBROUTINE ilu_set_default_options(options) & - & BIND(C, name="ilu_set_default_options") - IMPORT :: superlu_options_t - TYPE(superlu_options_t), INTENT(inout) :: options - END SUBROUTINE ilu_set_default_options -END INTERFACE - -PUBLIC :: ilu_set_default_options - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! brief Print the options setting. -! void print_options(superlu_options_t *options) - -INTERFACE - SUBROUTINE print_options(options) & - & BIND(C, name="print_options") - IMPORT :: superlu_options_t - TYPE(superlu_options_t), INTENT(IN) :: options - END SUBROUTINE print_options -END INTERFACE - -PUBLIC :: print_options - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Print the options setting. -! void print_ilu_options(superlu_options_t *options) - -INTERFACE - SUBROUTINE print_ilu_options(options) & - & BIND(C, name="print_ilu_options") - IMPORT :: superlu_options_t - TYPE(superlu_options_t), INTENT(IN) :: options - END SUBROUTINE print_ilu_options -END INTERFACE - -PUBLIC :: print_ilu_options - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Deallocate the structure pointing to the actual storage of the matrix. */ -! void -! Destroy_SuperMatrix_Store(SuperMatrix *A) - -INTERFACE - SUBROUTINE Destroy_SuperMatrix_Store(A) & - & BIND(C, name="Destroy_SuperMatrix_Store") - IMPORT :: C_PTR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(IN) :: A -#else - TYPE(SuperMatrix), INTENT(INOUT) :: A -#endif - END SUBROUTINE Destroy_SuperMatrix_Store -END INTERFACE - -PUBLIC :: Destroy_SuperMatrix_Store - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Deallocate the structure pointing to the actual storage of the matrix. */ -! void -! extern void Destroy_CompCol_Matrix(SuperMatrix *); - -INTERFACE - SUBROUTINE Destroy_CompCol_Matrix(A) & - & BIND(C, name="Destroy_CompCol_Matrix") - IMPORT :: C_PTR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(INOUT) :: A -#else - TYPE(SuperMatrix), INTENT(INOUT) :: A -#endif - END SUBROUTINE Destroy_CompCol_Matrix -END INTERFACE - -PUBLIC :: Destroy_CompCol_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Deallocate the structure pointing to the actual storage of the matrix. */ -! void -! Destroy_SuperMatrix_Store(SuperMatrix *A) - -INTERFACE - SUBROUTINE Destroy_CompRow_Matrix(A) & - & BIND(C, name="Destroy_CompRow_Matrix") - IMPORT :: C_PTR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(INOUT) :: A -#else - TYPE(SuperMatrix), INTENT(INOUT) :: A -#endif - END SUBROUTINE Destroy_CompRow_Matrix -END INTERFACE - -PUBLIC :: Destroy_CompRow_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Deallocate the structure pointing to the actual storage of the matrix. */ -! void -! Destroy_SuperMatrix_Store(SuperMatrix *A) - -INTERFACE - SUBROUTINE Destroy_SuperNode_Matrix(A) & - & BIND(C, name="Destroy_SuperNode_Matrix") - IMPORT :: C_PTR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(INOUT) :: A -#else - TYPE(SuperMatrix), INTENT(INOUT) :: A -#endif - END SUBROUTINE Destroy_SuperNode_Matrix -END INTERFACE - -PUBLIC :: Destroy_SuperNode_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Deallocate the structure pointing to the actual storage of the matrix. */ -! void -! Destroy_SuperMatrix_Store(SuperMatrix *A) - -INTERFACE - SUBROUTINE Destroy_CompCol_Permuted(A) & - & BIND(C, name="Destroy_CompCol_Permuted") - IMPORT :: C_PTR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(INOUT) :: A -#else - TYPE(SuperMatrix), INTENT(INOUT) :: A -#endif - END SUBROUTINE Destroy_CompCol_Permuted -END INTERFACE - -PUBLIC :: Destroy_CompCol_Permuted - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE Destroy_Dense_Matrix(A) & - & BIND(C, name="Destroy_Dense_Matrix") - IMPORT :: C_PTR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(INOUT) :: A -#else - TYPE(SuperMatrix), INTENT(INOUT) :: A -#endif - END SUBROUTINE Destroy_Dense_Matrix -END INTERFACE - -PUBLIC :: Destroy_Dense_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Count the total number of nonzeros in factors L and U, and in the symmetrically reduced L. -! void -! countnz(const int n, int *xprune, int *nnzL, int *nnzU, GlobalLU_t *Glu) - -INTERFACE - SUBROUTINE countnz(n, xprune, nnzL, nnzU, Glu) & - & BIND(C, name="countnz") - IMPORT :: C_INT, C_PTR, GlobalLU_t - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), INTENT(IN) :: xprune(*) - INTEGER(C_INT), INTENT(INOUT) :: nnzL - INTEGER(C_INT), INTENT(INOUT) :: nnzU - TYPE(GlobalLU_t), INTENT(IN) :: Glu - END SUBROUTINE countnz -END INTERFACE - -PUBLIC :: countnz - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! !brief Count the total number of nonzeros in factors L and U. -! void -! ilu_countnz(const int n, int *nnzL, int *nnzU, GlobalLU_t *Glu) - -INTERFACE - SUBROUTINE ilu_countnz(n, nnzL, nnzU, Glu) & - & BIND(C, name="ilu_countnz") - IMPORT :: C_INT, C_PTR, GlobalLU_t - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), INTENT(INOUT) :: nnzL - INTEGER(C_INT), INTENT(INOUT) :: nnzU - TYPE(GlobalLU_t), INTENT(IN) :: Glu - END SUBROUTINE ilu_countnz -END INTERFACE - -PUBLIC :: ilu_countnz - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! TODO - -!brief Diagnostic print of segment info after panel_dfs(). -! void print_panel_seg(int n, int w, int jcol, int nseg, -! int *segrep, int *repfnz) - -!---------------------------------------------------------------------------- -! -!--------------------------------------------------------------------------- - -! void -! StatInit(SuperLUStat_t *stat) - -INTERFACE - SUBROUTINE StatInit(stat) & - & BIND(C, name="StatInit") -#ifdef SUPERLU_CPTR_ONLY - IMPORT :: C_PTR - TYPE(C_PTR), INTENT(IN) :: stat -#else - IMPORT :: SuperLUStat_t - TYPE(SuperLUStat_t), INTENT(IN) :: stat -#endif - END SUBROUTINE StatInit -END INTERFACE - -PUBLIC :: StatInit - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! StatPrint(SuperLUStat_t *stat) - -INTERFACE - SUBROUTINE StatPrint(stat) & - & BIND(C, name="StatPrint") - IMPORT :: C_PTR, SuperLUStat_t -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(IN) :: stat -#else - TYPE(SuperLUStat_t), INTENT(IN) :: stat -#endif - END SUBROUTINE StatPrint -END INTERFACE - -PUBLIC :: StatPrint - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! StatFree(SuperLUStat_t *stat) - -INTERFACE - SUBROUTINE StatFree(stat) & - & BIND(C, name="StatFree") - IMPORT :: C_PTR, SuperLUStat_t -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(IN) :: stat -#else - TYPE(SuperLUStat_t), INTENT(IN) :: stat -#endif - END SUBROUTINE StatFree -END INTERFACE - -PUBLIC :: StatFree - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! flops_t -! LUFactFlops(SuperLUStat_t *stat) - -INTERFACE - FUNCTION LUFactFlops(stat) RESULT(ans) & - & BIND(C, name="LUFactFlops") - IMPORT :: C_PTR - TYPE(C_PTR), INTENT(IN) :: stat - TYPE(C_PTR) :: ans - END FUNCTION LUFactFlops -END INTERFACE - -PUBLIC :: LUFactFlops - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! flops_t -! LUSolveFlops(SuperLUStat_t *stat) - -INTERFACE - FUNCTION LUSolveFlops(stat) RESULT(ans) & - & BIND(C, name="LUSolveFlops") - IMPORT :: C_PTR - TYPE(C_PTR), INTENT(IN) :: stat - TYPE(C_PTR) :: ans - END FUNCTION LUSolveFlops -END INTERFACE - -PUBLIC :: LUSolveFlops - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Fills an integer array with a given value. -! void ifill(int *a, int alen, int ival) - -INTERFACE - SUBROUTINE ifill(a, alen, ival) & - & BIND(C, name="ifill") - IMPORT :: C_INT - INTEGER(C_INT), INTENT(INOUT) :: a(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: alen - INTEGER(C_INT), VALUE, INTENT(IN) :: ival - END SUBROUTINE ifill -END INTERFACE - -PUBLIC :: ifill - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Get the statistics of the supernodes -! void super_stats(int nsuper, int *xsup) - -INTERFACE - SUBROUTINE super_stats(nsuper, xsup) & - & BIND(C, name="super_stats") - IMPORT :: C_INT - INTEGER(C_INT), VALUE, INTENT(IN) :: nsuper - INTEGER(C_INT), INTENT(IN) :: xsup(*) - END SUBROUTINE super_stats -END INTERFACE - -PUBLIC :: super_stats - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! float SpaSize(int n, int np, float sum_npw) - -INTERFACE - SUBROUTINE SpaSize(n, np, sum_npw) & - & BIND(C, name="SpaSize") - IMPORT :: C_INT, C_FLOAT - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), VALUE, INTENT(IN) :: np - REAL(C_FLOAT), VALUE, INTENT(IN) :: sum_npw - END SUBROUTINE SpaSize -END INTERFACE - -PUBLIC :: SpaSize - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! float DenseSize(int n, float sum_nw) - -INTERFACE - FUNCTION DenseSize(n, sum_nw) RESULT(ans) & - & BIND(C, name="DenseSize") - IMPORT :: C_INT, C_FLOAT - INTEGER(C_INT), VALUE, INTENT(IN) :: n - REAL(C_FLOAT), VALUE, INTENT(IN) :: sum_nw - REAL(C_FLOAT) :: ans - END FUNCTION DenseSize -END INTERFACE - -PUBLIC :: DenseSize - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Check whether repfnz[] == EMPTY after reset. -! void check_repfnz(int n, int w, int jcol, int *repfnz) - -INTERFACE - - SUBROUTINE check_repfnz(n, w, jcol, repfnz) & - & BIND(C, name="check_repfnz") - IMPORT :: C_INT - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), VALUE, INTENT(IN) :: w - INTEGER(C_INT), VALUE, INTENT(IN) :: jcol - INTEGER(C_INT), INTENT(IN) :: repfnz(*) - END SUBROUTINE check_repfnz -END INTERFACE - -PUBLIC :: check_repfnz - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Print a summary of the testing results. */ -! void -! PrintSumm(char *type, int nfail, int nrun, int nerrs) - -INTERFACE - SUBROUTINE PrintSumm(type_, nfail, nrun, nerrs) & - & BIND(C, name="PrintSumm") - IMPORT :: C_CHAR, C_INT - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: type_(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: nfail - INTEGER(C_INT), VALUE, INTENT(IN) :: nrun - INTEGER(C_INT), VALUE, INTENT(IN) :: nerrs - END SUBROUTINE PrintSumm -END INTERFACE - -PUBLIC :: PrintSumm - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! int print_int_vec(char *what, int n, int *vec) - -INTERFACE - FUNCTION print_int_vec(what, n, vec) RESULT(ans) & - & BIND(C, name="print_int_vec") - IMPORT :: C_CHAR, C_INT - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: what(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), INTENT(IN) :: vec(*) - INTEGER(C_INT) :: ans - END FUNCTION print_int_vec -END INTERFACE - -PUBLIC :: print_int_vec - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! int slu_PrintInt10(char *name, int len, int *x) - -INTERFACE - FUNCTION slu_PrintInt10(name, len, x) RESULT(ans) & - & BIND(C, name="print_int_vec") - IMPORT :: C_CHAR, C_INT - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: name(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: len - INTEGER(C_INT), INTENT(IN) :: x(*) - INTEGER(C_INT) :: ans - END FUNCTION slu_PrintInt10 -END INTERFACE - -PUBLIC :: slu_PrintInt10 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE superlu_free(addr) & - & BIND(C, name="superlu_free") - IMPORT :: C_PTR - TYPE(C_PTR), INTENT(in) :: addr - END SUBROUTINE superlu_free -END INTERFACE - -PUBLIC :: superlu_free - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - FUNCTION superlu_malloc(size) RESULT(ans) & - & BIND(C, name="superlu_malloc") - IMPORT :: C_PTR, C_SIZE_T - TYPE(C_PTR) :: ans - INTEGER(C_SIZE_T) :: size - END FUNCTION superlu_malloc -END INTERFACE - -PUBLIC :: superlu_malloc - -END MODULE SuperLU_Util_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 deleted file mode 100644 index 98cdf2d05..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 +++ /dev/null @@ -1,470 +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 -! - -#include "./include/macros.inc" - -MODULE SuperLU_dUtil_Methods -USE ISO_C_BINDING, ONLY: C_PTR, C_INT, C_DOUBLE, C_CHAR -USE SuperLU_Types -IMPLICIT NONE - -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern void -! dCreate_CompCol_Matrix(SuperMatrix *, int, int, int, double *, -! int *, int *, Stype_t, Dtype_t, Mtype_t); - -INTERFACE - SUBROUTINE dCreate_CompCol_Matrix(A, m, n, nnz, nzval, rowind, colptr, & - & stype, dtype, mtype) BIND(C, name="dCreate_CompCol_Matrix") - IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix - TYPE(SuperMatrix), INTENT(INOUT) :: A - INTEGER(C_INT), VALUE, INTENT(IN) :: m - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), VALUE, INTENT(IN) :: nnz - REAL(C_DOUBLE), INTENT(INOUT) :: nzval(*) - INTEGER(C_INT), INTENT(INOUT) :: rowind(*) - INTEGER(C_INT), INTENT(INOUT) :: colptr(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: stype - INTEGER(C_INT), VALUE, INTENT(IN) :: dtype - INTEGER(C_INT), VALUE, INTENT(IN) :: mtype - END SUBROUTINE dCreate_CompCol_Matrix -END INTERFACE - -PUBLIC :: dCreate_CompCol_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dCreate_CompRow_Matrix(SuperMatrix *A, int m, int n, int nnz, -! double *nzval, int *colind, int *rowptr, -! Stype_t stype, Dtype_t dtype, Mtype_t mtype) - -INTERFACE - SUBROUTINE dCreate_CompRow_Matrix(A, m, n, nnz, nzval, colind, rowptr, & - & stype, dtype, mtype) BIND(C, name="dCreate_CompCol_Matrix") - IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix - TYPE(SuperMatrix), INTENT(INOUT) :: A - INTEGER(C_INT), VALUE, INTENT(IN) :: m - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), VALUE, INTENT(IN) :: nnz - REAL(C_DOUBLE), INTENT(IN) :: nzval(*) - INTEGER(C_INT), INTENT(IN) :: colind(*) - INTEGER(C_INT), INTENT(IN) :: rowptr(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: stype - INTEGER(C_INT), VALUE, INTENT(IN) :: dtype - INTEGER(C_INT), VALUE, INTENT(IN) :: mtype - END SUBROUTINE dCreate_CompRow_Matrix -END INTERFACE - -PUBLIC :: dCreate_CompRow_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! /*! \brief Copy matrix A into matrix B. */ -! void -! dCopy_CompCol_Matrix(SuperMatrix *A, SuperMatrix *B) - -INTERFACE - SUBROUTINE dCopy_CompCol_Matrix(A, B) BIND(C, name="dCopy_CompCol_Matrix") - IMPORT :: C_PTR, SuperMatrix - TYPE(SuperMatrix), INTENT(INOUT) :: A, B - END SUBROUTINE dCopy_CompCol_Matrix -END INTERFACE - -PUBLIC :: dCopy_CompCol_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dCreate_Dense_Matrix(SuperMatrix *X, int m, int n, double *x, int ldx, -! Stype_t stype, Dtype_t dtype, Mtype_t mtype) -INTERFACE - SUBROUTINE dCreate_Dense_Matrix(A, m, n, x, ldx, stype, dtype, mtype) & - & BIND(C, name="dCreate_Dense_Matrix") - IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix - TYPE(SuperMatrix), INTENT(INOUT) :: A - INTEGER(C_INT), VALUE, INTENT(IN) :: m - INTEGER(C_INT), VALUE, INTENT(IN) :: n - REAL(C_DOUBLE), INTENT(INOUT) :: x(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: ldx - INTEGER(C_INT), VALUE, INTENT(IN) :: stype - INTEGER(C_INT), VALUE, INTENT(IN) :: dtype - INTEGER(C_INT), VALUE, INTENT(IN) :: mtype - END SUBROUTINE dCreate_Dense_Matrix -END INTERFACE - -PUBLIC :: dCreate_Dense_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dCopy_Dense_Matrix(int M, int N, double *X, int ldx, -! double *Y, int ldy) -! { -! /*! \brief Copies a two-dimensional matrix X to another matrix Y. -! */ - -INTERFACE - SUBROUTINE dCopy_Dense_Matrix(M, N, X, ldx, Y, ldy) & - & BIND(C, name="dCopy_Dense_Matrix") - IMPORT :: C_INT, C_DOUBLE - INTEGER(C_INT), VALUE, INTENT(IN) :: M - INTEGER(C_INT), VALUE, INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(IN) :: X(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: ldx - REAL(C_DOUBLE), INTENT(INOUT) :: Y(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: ldy - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dCreate_SuperNode_Matrix(SuperMatrix *L, int m, int n, int nnz, -! double *nzval, int *nzval_colptr, int *rowind, -! int *rowind_colptr, int *col_to_sup, int *sup_to_col, -! Stype_t stype, Dtype_t dtype, Mtype_t mtype) - -INTERFACE - SUBROUTINE dCreate_SuperNode_Matrix(L, m, n, nnz, nzval, nzval_colptr, & - & rowind, rowind_colptr, col_to_sup, sup_to_col, stype, dtype, mtype) & - & BIND(C, name="dCreate_SuperNode_Matrix") - IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(INOUT) :: L -#else - TYPE(SuperMatrix), INTENT(INOUT) :: L -#endif - INTEGER(C_INT), VALUE, INTENT(IN) :: m - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), VALUE, INTENT(IN) :: nnz - REAL(C_DOUBLE), INTENT(IN) :: nzval(*) - INTEGER(C_INT), INTENT(IN) :: nzval_colptr(*) - INTEGER(C_INT), INTENT(IN) :: rowind(*) - INTEGER(C_INT), INTENT(IN) :: rowind_colptr(*) - INTEGER(C_INT), INTENT(IN) :: col_to_sup(*) - INTEGER(C_INT), INTENT(IN) :: sup_to_col(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: stype - INTEGER(C_INT), VALUE, INTENT(IN) :: dtype - INTEGER(C_INT), VALUE, INTENT(IN) :: mtype - END SUBROUTINE dCreate_SuperNode_Matrix -END INTERFACE - -PUBLIC :: dCreate_SuperNode_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dCompRow_to_CompCol(int m, int n, int nnz, -! double *a, int *colind, int *rowptr, -! double **at, int **rowind, int **colptr) -! brief Convert a row compressed storage into a column -! compressed storage. - -INTERFACE - SUBROUTINE dCompRow_to_CompCol(m, n, nnz, a, colind, rowptr, & - & at, rowind, colptr) BIND(C, name="dCompRow_to_CompCol") - IMPORT :: C_INT, C_DOUBLE, C_PTR - INTEGER(C_INT), VALUE, INTENT(IN) :: m - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), VALUE, INTENT(IN) :: nnz - REAL(C_DOUBLE), INTENT(IN) :: a(*) - INTEGER(C_INT), INTENT(IN) :: colind(*) - INTEGER(C_INT), INTENT(IN) :: rowptr(*) - TYPE(C_PTR), INTENT(INOUT) :: at - TYPE(C_PTR), INTENT(INOUT) :: rowind - TYPE(C_PTR), INTENT(INOUT) :: colptr - END SUBROUTINE dCompRow_to_CompCol -END INTERFACE - -PUBLIC :: dCompRow_to_CompCol - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! dPrint_CompCol_Matrix(char *what, SuperMatrix *A) - -INTERFACE - SUBROUTINE dPrint_CompCol_Matrix(what, A) BIND(C, name="dPrint_CompCol_Matrix") - IMPORT :: C_PTR, C_CHAR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(IN) :: A -#else - TYPE(SuperMatrix), INTENT(IN) :: A -#endif - CHARACTER(1, kind=C_CHAR), INTENT(in) :: what(*) - END SUBROUTINE dPrint_CompCol_Matrix -END INTERFACE - -PUBLIC :: dPrint_CompCol_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dPrint_SuperNode_Matrix(char *what, SuperMatrix *A) - -INTERFACE - SUBROUTINE dPrint_SuperNode_Matrix(what, A) & - & BIND(C, name="dPrint_SuperNode_Matrix") - IMPORT :: C_PTR, C_CHAR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(IN) :: A -#else - TYPE(SuperMatrix), INTENT(IN) :: A -#endif - CHARACTER(1, kind=C_CHAR), INTENT(in) :: what(*) - END SUBROUTINE dPrint_SuperNode_Matrix -END INTERFACE - -PUBLIC :: dPrint_SuperNode_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dPrint_Dense_Matrix(char *what, SuperMatrix *A) - -INTERFACE - SUBROUTINE dPrint_Dense_Matrix(what, A) & - & BIND(C, name="dPrint_Dense_Matrix") - IMPORT :: C_PTR, C_CHAR, SuperMatrix -#ifdef SUPERLU_CPTR_ONLY - TYPE(C_PTR), INTENT(IN) :: A -#else - TYPE(SuperMatrix), INTENT(IN) :: A -#endif - CHARACTER(1, kind=C_CHAR), INTENT(in) :: what(*) - END SUBROUTINE dPrint_Dense_Matrix -END INTERFACE - -PUBLIC :: dPrint_Dense_Matrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! brief Diagnostic print of column "jcol" in the U/L factor. -! void -! dprint_lu_col(char *msg, int jcol, int pivrow, int *xprune, GlobalLU_t *Glu) - -INTERFACE - SUBROUTINE dprint_lu_col(msg, jcol, pivrow, xprune, Glu) & - & BIND(C, name="dprint_lu_col") - IMPORT :: C_CHAR, C_INT, C_PTR - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: msg - INTEGER(C_INT), VALUE, INTENT(IN) :: jcol - INTEGER(C_INT), VALUE, INTENT(IN) :: pivrow - INTEGER(C_INT), INTENT(IN) :: xprune(*) - TYPE(C_PTR), INTENT(IN) :: Glu - END SUBROUTINE dprint_lu_col -END INTERFACE - -PUBLIC :: dprint_lu_col - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! brief Check whether tempv[] == 0. This should be true before and -! after calling any numeric routines, i.e., "panel_bmod" and "column_bmod". -! void dcheck_tempv(int n, double *tempv) - -INTERFACE - SUBROUTINE dcheck_tempv(n, tempv) & - & BIND(C, name="dcheck_tempv") - IMPORT :: C_INT, C_DOUBLE - INTEGER(C_INT), VALUE, INTENT(IN) :: n - REAL(C_DOUBLE), INTENT(IN) :: tempv(*) - END SUBROUTINE dcheck_tempv -END INTERFACE - -PUBLIC :: dcheck_tempv - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! void -! dGenXtrue(int n, int nrhs, double *x, int ldx) - -INTERFACE - SUBROUTINE dGenXtrue(n, nrhs, x, ldx) & - & BIND(C, name="dGenXtrue") - IMPORT :: C_INT, C_DOUBLE - INTEGER(C_INT), VALUE, INTENT(IN) :: n - INTEGER(C_INT), VALUE, INTENT(IN) :: nrhs - REAL(C_DOUBLE), INTENT(INOUT) :: x(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: ldx - END SUBROUTINE dGenXtrue -END INTERFACE - -PUBLIC :: dGenXtrue - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!brief Let rhs[i] = sum of i-th row of A, so the solution vector is all 1's -! void -! dFillRHS(trans_t trans, int nrhs, double *x, int ldx, -! SuperMatrix *A, SuperMatrix *B) - -INTERFACE - SUBROUTINE dFillRHS(trans, nrhs, x, ldx, A, B) & - & BIND(C, name="dFillRHS") - IMPORT :: C_INT, C_DOUBLE, SuperMatrix - INTEGER(C_INT), VALUE, INTENT(IN) :: trans - INTEGER(C_INT), VALUE, INTENT(IN) :: nrhs - REAL(C_DOUBLE), INTENT(INOUT) :: x(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: ldx - TYPE(SuperMatrix), INTENT(IN) :: A - TYPE(SuperMatrix), INTENT(IN) :: B - END SUBROUTINE dFillRHS -END INTERFACE - -PUBLIC :: dFillRHS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! ! \brief Fills a double precision array with a given value. -! void -! dfill(double *a, int alen, double dval) - -INTERFACE - SUBROUTINE dfill(a, alen, dval) & - & BIND(C, name="dfill") - IMPORT :: C_DOUBLE, C_INT - REAL(C_DOUBLE), INTENT(INOUT) :: a(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: alen - REAL(C_DOUBLE), VALUE, INTENT(IN) :: dval - END SUBROUTINE dfill -END INTERFACE - -PUBLIC :: dfill - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! brief Check the inf-norm of the error vector -! void dinf_norm_error(int nrhs, SuperMatrix *X, double *xtrue) - -INTERFACE - SUBROUTINE dinf_norm_error(nrhs, X, xtrue) & - & BIND(C, name="dinf_norm_error") - IMPORT :: C_INT, C_PTR, C_DOUBLE - INTEGER(C_INT), VALUE, INTENT(IN) :: nrhs - TYPE(C_PTR), INTENT(IN) :: X - REAL(C_DOUBLE), INTENT(IN) :: xtrue(*) - END SUBROUTINE dinf_norm_error -END INTERFACE - -PUBLIC :: dinf_norm_error - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! brief Print performance of the code. -! void -! dPrintPerf(SuperMatrix *L, SuperMatrix *U, mem_usage_t *mem_usage, -! double rpg, double rcond, double *ferr, -! double *berr, char *equed, SuperLUStat_t *stat) - -INTERFACE - SUBROUTINE dPrintPerf(L, U, mem_usage, rpg, rcond, ferr, & - & berr, equed, stat) & - & BIND(C, name="dPrintPerf") - IMPORT :: C_PTR, C_DOUBLE, C_CHAR - TYPE(C_PTR), INTENT(IN) :: L - TYPE(C_PTR), INTENT(IN) :: U - TYPE(C_PTR), INTENT(IN) :: mem_usage - REAL(C_DOUBLE), VALUE, INTENT(IN) :: rpg - REAL(C_DOUBLE), VALUE, INTENT(in) :: rcond - REAL(C_DOUBLE), INTENT(IN) :: ferr(*) - REAL(C_DOUBLE), INTENT(IN) :: berr(*) - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: equed(*) - TYPE(C_PTR), INTENT(IN) :: stat - END SUBROUTINE dPrintPerf -END INTERFACE - -PUBLIC :: dPrintPerf - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! int -! print_double_vec(char *what, int n, double *vec) - -INTERFACE - SUBROUTINE print_double_vec(what, n, vec) & - & BIND(C, name="print_double_vec") - IMPORT :: C_CHAR, C_INT, C_DOUBLE - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: what(*) - INTEGER(C_INT), VALUE, INTENT(IN) :: n - REAL(C_DOUBLE), INTENT(IN) :: vec(*) - END SUBROUTINE print_double_vec -END INTERFACE - -PUBLIC :: print_double_vec - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! extern int dQuerySpace (SuperMatrix *, SuperMatrix *, mem_usage_t *); - -INTERFACE - SUBROUTINE dQuerySpace(A, B, mem) & - & BIND(C, name="dQuerySpace") - IMPORT :: SuperMatrix, mem_usage_t - TYPE(SuperMatrix), INTENT(in) :: A, B - TYPE(mem_usage_t), INTENT(in) :: mem - END SUBROUTINE dQuerySpace -END INTERFACE - -PUBLIC :: dQuerySpace - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE SuperLU_dUtil_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 deleted file mode 100644 index 5387f5c5d..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 +++ /dev/null @@ -1,95 +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 SuperLU_dgscon_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! * Purpose -! * ======= -! * -! * DGSCON estimates the reciprocal of the condition number of a general -! * real matrix A, in either the 1-norm or the infinity-norm, using -! * the LU factorization computed by DGETRF. * -! * -! * An estimate is obtained for norm(inv(A)), and the reciprocal of the -! * condition number is computed as -! * RCOND = 1 / ( norm(A) * norm(inv(A)) ). -! * -! * See supermatrix.h for the definition of 'SuperMatrix' structure. -! * -! * Arguments -! * ========= -! * -! * NORM (input) char* -! * Specifies whether the 1-norm condition number or the -! * infinity-norm condition number is required: -! * = '1' or 'O': 1-norm; -! * = 'I': Infinity-norm. -! * -! * L (input) SuperMatrix* -! * The factor L from the factorization Pr*A*Pc=L*U as computed by -! * dgstrf(). Use compressed row subscripts storage for supernodes, -! * i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. -! * -! * U (input) SuperMatrix* -! * The factor U from the factorization Pr*A*Pc=L*U as computed by -! * dgstrf(). Use column-wise storage scheme, i.e., U has types: -! * Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. -! * -! * ANORM (input) double -! * If NORM = '1' or 'O', the 1-norm of the original matrix A. -! * If NORM = 'I', the infinity-norm of the original matrix A. -! * -! * RCOND (output) double* -! * The reciprocal of the condition number of the matrix A, -! * computed as RCOND = 1/(norm(A) * norm(inv(A))). -! * -! * INFO (output) int* -! * = 0: successful exit -! * < 0: if INFO = -i, the i-th argument had an illegal value -! * -! * ===================================================================== - -! void -! dgscon(char *norm, SuperMatrix *L, SuperMatrix *U, -! double anorm, double *rcond, SuperLUStat_t *stat, int *info) - -INTERFACE - SUBROUTINE dgscon(norm, L, U, anorm, rcond, stat, info) & - & BIND(C, name="dgscon") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix, C_CHAR, C_DOUBLE - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: norm - TYPE(SuperMatrix), INTENT(INOUT) :: L - TYPE(SuperMatrix), INTENT(INOUT) :: U - REAL(C_DOUBLE), VALUE, INTENT(IN) :: anorm - REAL(C_DOUBLE), INTENT(INOUT) :: rcond - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - INTEGER(C_INT), INTENT(INOUT) :: info - END SUBROUTINE dgscon -END INTERFACE - -PUBLIC :: dgscon - -END MODULE SuperLU_dgscon_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 deleted file mode 100644 index e66e057e2..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 +++ /dev/null @@ -1,108 +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 SuperLU_dgsequ_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! * Purpose -! * ======= -! * -! * DGSEQU computes row and column scalings intended to equilibrate an -! * M-by-N sparse matrix A and reduce its condition number. R returns the row -! * scale factors and C the column scale factors, chosen to try to make -! * the largest element in each row and column of the matrix B with -! * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. -! * -! * R(i) and C(j) are restricted to be between SMLNUM = smallest safe -! * number and BIGNUM = largest safe number. Use of these scaling -! * factors is not guaranteed to reduce the condition number of A but -! * works well in practice. -! * -! * See supermatrix.h for the definition of 'SuperMatrix' structure. -! * -! * Arguments -! * ========= -! * -! * A (input) SuperMatrix* -! * The matrix of dimension (A->nrow, A->ncol) whose equilibration -! * factors are to be computed. The type of A can be: -! * Stype = SLU_NC; Dtype = SLU_D; Mtype = SLU_GE. -! * -! * R (output) double*, size A->nrow -! * If INFO = 0 or INFO > M, R contains the row scale factors -! * for A. -! * -! * C (output) double*, size A->ncol -! * If INFO = 0, C contains the column scale factors for A. -! * -! * ROWCND (output) double* -! * If INFO = 0 or INFO > M, ROWCND contains the ratio of the -! * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and -! * AMAX is neither too large nor too small, it is not worth -! * scaling by R. -! * -! * COLCND (output) double* -! * If INFO = 0, COLCND contains the ratio of the smallest -! * C(i) to the largest C(i). If COLCND >= 0.1, it is not -! * worth scaling by C. -! * -! * AMAX (output) double* -! * Absolute value of largest matrix element. If AMAX is very -! * close to overflow or very close to underflow, the matrix -! * should be scaled. -! * -! * INFO (output) int* -! * = 0: successful exit -! * < 0: if INFO = -i, the i-th argument had an illegal value -! * > 0: if INFO = i, and i is -! * <= A->nrow: the i-th row of A is exactly zero -! * > A->ncol: the (i-M)-th column of A is exactly zero -! * -! -! void -! dgsequ(SuperMatrix *A, double *r, double *c, double *rowcnd, -! double *colcnd, double *amax, int *info) - -INTERFACE - SUBROUTINE dgsequ(A, r, c, rowcnd, colcnd, amax, info)& - & BIND(C, name="dgsequ") - IMPORT :: SuperMatrix, C_DOUBLE, C_INT - - TYPE(SuperMatrix), INTENT(INOUT) :: A - REAL(C_DOUBLE), INTENT(INOUT) :: r(*) - REAL(C_DOUBLE), INTENT(INOUT) :: c(*) - REAL(C_DOUBLE), INTENT(INOUT) :: rowcnd - REAL(C_DOUBLE), INTENT(INOUT) :: colcnd - REAL(C_DOUBLE), INTENT(INOUT) :: amax - INTEGER(C_INT), INTENT(inout) :: info - END SUBROUTINE dgsequ -END INTERFACE - -PUBLIC :: dgsequ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE SuperLU_dgsequ_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 deleted file mode 100644 index 040c8d2ba..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 +++ /dev/null @@ -1,446 +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 SuperLU_dgsisx_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -! -! -! * Purpose -! * ======= -! * -! * DGSISX computes an approximate solutions of linear equations -! * A*X=B or A'*X=B, using the ILU factorization from dgsitrf(). -! * An estimation of the condition number is provided. -! * The routine performs the following steps: -! * -! * 1. If A is stored column-wise (A->Stype = SLU_NC): -! * -! * 1.1. If options->Equil = YES or options->RowPerm = LargeDiag_MC64, scaling -! * factors are computed to equilibrate the system: -! * options->Trans = NOTRANS: -! * diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -! * options->Trans = TRANS: -! * (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -! * options->Trans = CONJ: -! * (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -! * Whether or not the system will be equilibrated depends on the -! * scaling of the matrix A, but if equilibration is used, A is -! * overwritten by diag(R)*A*diag(C) and B by diag(R)*B -! * (if options->Trans=NOTRANS) or diag(C)*B (if options->Trans -! * = TRANS or CONJ). -! * -! * 1.2. Permute columns of A, forming A*Pc, where Pc is a permutation -! * matrix that usually preserves sparsity. -! * For more details of this step, see sp_preorder.c. -! * -! * 1.3. If options->Fact != FACTORED, the LU decomposition is used to -! * factor the matrix A (after equilibration if options->Equil = YES) -! * as Pr*A*Pc = L*U, with Pr determined by partial pivoting. -! * -! * 1.4. Compute the reciprocal pivot growth factor. -! * -! * 1.5. If some U(i,i) = 0, so that U is exactly singular, then the -! * routine fills a small number on the diagonal entry, that is -! * U(i,i) = ||A(:,i)||_oo * options->ILU_FillTol ** (1 - i / n), -! * and info will be increased by 1. The factored form of A is used -! * to estimate the condition number of the preconditioner. If the -! * reciprocal of the condition number is less than machine precision, -! * info = A->ncol+1 is returned as a warning, but the routine still -! * goes on to solve for X. -! * -! * 1.6. The system of equations is solved for X using the factored form -! * of A. -! * -! * 1.7. options->IterRefine is not used -! * -! * 1.8. If equilibration was used, the matrix X is premultiplied by -! * diag(C) (if options->Trans = NOTRANS) or diag(R) -! * (if options->Trans = TRANS or CONJ) so that it solves the -! * original system before equilibration. -! * -! * 1.9. options for ILU only -! * 1) If options->RowPerm = LargeDiag_MC64, MC64 is used to scale and -! * permute the matrix to an I-matrix, that is Pr*Dr*A*Dc has -! * entries of modulus 1 on the diagonal and off-diagonal entries -! * of modulus at most 1. If MC64 fails, dgsequ() is used to -! * equilibrate the system. -! * ( Default: LargeDiag_MC64 ) -! * 2) options->ILU_DropTol = tau is the threshold for dropping. -! * For L, it is used directly (for the whole row in a supernode); -! * For U, ||A(:,i)||_oo * tau is used as the threshold -! * for the i-th column. -! * If a secondary dropping rule is required, tau will -! * also be used to compute the second threshold. -! * ( Default: 1e-4 ) -! * 3) options->ILU_FillFactor = gamma, used as the initial guess -! * of memory growth. -! * If a secondary dropping rule is required, it will also -! * be used as an upper bound of the memory. -! * ( Default: 10 ) -! * 4) options->ILU_DropRule specifies the dropping rule. -! * Option Meaning -! * ====== =========== -! * DROP_BASIC: Basic dropping rule, supernodal based ILUTP(tau). -! * DROP_PROWS: Supernodal based ILUTP(p,tau), p = gamma*nnz(A)/n. -! * DROP_COLUMN: Variant of ILUTP(p,tau), for j-th column, -! * p = gamma * nnz(A(:,j)). -! * DROP_AREA: Variation of ILUTP, for j-th column, use -! * nnz(F(:,1:j)) / nnz(A(:,1:j)) to control memory. -! * DROP_DYNAMIC: Modify the threshold tau during factorizaion: -! * If nnz(L(:,1:j)) / nnz(A(:,1:j)) > gamma -! * tau_L(j) := MIN(tau_0, tau_L(j-1) * 2); -! * Otherwise -! * tau_L(j) := MAX(tau_0, tau_L(j-1) / 2); -! * tau_U(j) uses the similar rule. -! * NOTE: the thresholds used by L and U are separate. -! * DROP_INTERP: Compute the second dropping threshold by -! * interpolation instead of sorting (default). -! * In this case, the actual fill ratio is not -! * guaranteed smaller than gamma. -! * DROP_PROWS, DROP_COLUMN and DROP_AREA are mutually exclusive. -! * ( Default: DROP_BASIC | DROP_AREA ) -! * 5) options->ILU_Norm is the criterion of measuring the magnitude -! * of a row in a supernode of L. ( Default is INF_NORM ) -! * options->ILU_Norm RowSize(x[1:n]) -! * ================= =============== -! * ONE_NORM ||x||_1 / n -! * TWO_NORM ||x||_2 / sqrt(n) -! * INF_NORM max{|x[i]|} -! * 6) options->ILU_MILU specifies the type of MILU's variation. -! * = SILU: do not perform Modified ILU; -! * = SMILU_1 (not recommended): -! * U(i,i) := U(i,i) + sum(dropped entries); -! * = SMILU_2: -! * U(i,i) := U(i,i) + SGN(U(i,i)) * sum(dropped entries); -! * = SMILU_3: -! * U(i,i) := U(i,i) + SGN(U(i,i)) * sum(|dropped entries|); -! * NOTE: Even SMILU_1 does not preserve the column sum because of -! * late dropping. -! * ( Default: SILU ) -! * 7) options->ILU_FillTol is used as the perturbation when -! * encountering zero pivots. If some U(i,i) = 0, so that U is -! * exactly singular, then -! * U(i,i) := ||A(:,i)|| * options->ILU_FillTol ** (1 - i / n). -! * ( Default: 1e-2 ) -! * -! * 2. If A is stored row-wise (A->Stype = SLU_NR), apply the above algorithm -! * to the transpose of A: -! * -! * 2.1. If options->Equil = YES or options->RowPerm = LargeDiag_MC64, scaling -! * factors are computed to equilibrate the system: -! * options->Trans = NOTRANS: -! * diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -! * options->Trans = TRANS: -! * (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -! * options->Trans = CONJ: -! * (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -! * Whether or not the system will be equilibrated depends on the -! * scaling of the matrix A, but if equilibration is used, A' is -! * overwritten by diag(R)*A'*diag(C) and B by diag(R)*B -! * (if trans='N') or diag(C)*B (if trans = 'T' or 'C'). -! * -! * 2.2. Permute columns of transpose(A) (rows of A), -! * forming transpose(A)*Pc, where Pc is a permutation matrix that -! * usually preserves sparsity. -! * For more details of this step, see sp_preorder.c. -! * -! * 2.3. If options->Fact != FACTORED, the LU decomposition is used to -! * factor the transpose(A) (after equilibration if -! * options->Fact = YES) as Pr*transpose(A)*Pc = L*U with the -! * permutation Pr determined by partial pivoting. -! * -! * 2.4. Compute the reciprocal pivot growth factor. -! * -! * 2.5. If some U(i,i) = 0, so that U is exactly singular, then the -! * routine fills a small number on the diagonal entry, that is -! * U(i,i) = ||A(:,i)||_oo * options->ILU_FillTol ** (1 - i / n). -! * And info will be increased by 1. The factored form of A is used -! * to estimate the condition number of the preconditioner. If the -! * reciprocal of the condition number is less than machine precision, -! * info = A->ncol+1 is returned as a warning, but the routine still -! * goes on to solve for X. -! * -! * 2.6. The system of equations is solved for X using the factored form -! * of transpose(A). -! * -! * 2.7. If options->IterRefine is not used. -! * -! * 2.8. If equilibration was used, the matrix X is premultiplied by -! * diag(C) (if options->Trans = NOTRANS) or diag(R) -! * (if options->Trans = TRANS or CONJ) so that it solves the -! * original system before equilibration. -! * -! * See supermatrix.h for the definition of 'SuperMatrix' structure. -! * -! * Arguments -! * ========= -! * -! * options (input) superlu_options_t* -! * The structure defines the input parameters to control -! * how the LU decomposition will be performed and how the -! * system will be solved. -! * -! * A (input/output) SuperMatrix* -! * Matrix A in A*X=B, of dimension (A->nrow, A->ncol). The number -! * of the linear equations is A->nrow. Currently, the type of A can be: -! * Stype = SLU_NC or SLU_NR, Dtype = SLU_D, Mtype = SLU_GE. -! * In the future, more general A may be handled. -! * -! * On entry, If options->Fact = FACTORED and equed is not 'N', -! * then A must have been equilibrated by the scaling factors in -! * R and/or C. -! * On exit, A is not modified -! * if options->Equil = NO, or -! * if options->Equil = YES but equed = 'N' on exit, or -! * if options->RowPerm = NO. -! * -! * Otherwise, if options->Equil = YES and equed is not 'N', -! * A is scaled as follows: -! * If A->Stype = SLU_NC: -! * equed = 'R': A := diag(R) * A -! * equed = 'C': A := A * diag(C) -! * equed = 'B': A := diag(R) * A * diag(C). -! * If A->Stype = SLU_NR: -! * equed = 'R': transpose(A) := diag(R) * transpose(A) -! * equed = 'C': transpose(A) := transpose(A) * diag(C) -! * equed = 'B': transpose(A) := diag(R) * transpose(A) * diag(C). -! * -! * If options->RowPerm = LargeDiag_MC64, MC64 is used to scale and permute -! * the matrix to an I-matrix, that is A is modified as follows: -! * P*Dr*A*Dc has entries of modulus 1 on the diagonal and -! * off-diagonal entries of modulus at most 1. P is a permutation -! * obtained from MC64. -! * If MC64 fails, dgsequ() is used to equilibrate the system, -! * and A is scaled as above, but no permutation is involved. -! * On exit, A is restored to the orginal row numbering, so -! * Dr*A*Dc is returned. -! * -! * perm_c (input/output) int* -! * If A->Stype = SLU_NC, Column permutation vector of size A->ncol, -! * which defines the permutation matrix Pc; perm_c[i] = j means -! * column i of A is in position j in A*Pc. -! * On exit, perm_c may be overwritten by the product of the input -! * perm_c and a permutation that postorders the elimination tree -! * of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree -! * is already in postorder. -! * -! * If A->Stype = SLU_NR, column permutation vector of size A->nrow, -! * which describes permutation of columns of transpose(A) -! * (rows of A) as described above. -! * -! * perm_r (input/output) int* -! * If A->Stype = SLU_NC, row permutation vector of size A->nrow, -! * which defines the permutation matrix Pr, and is determined -! * by MC64 first then followed by partial pivoting. -! * perm_r[i] = j means row i of A is in position j in Pr*A. -! * -! * If A->Stype = SLU_NR, permutation vector of size A->ncol, which -! * determines permutation of rows of transpose(A) -! * (columns of A) as described above. -! * -! * If options->Fact = SamePattern_SameRowPerm, the pivoting routine -! * will try to use the input perm_r, unless a certain threshold -! * criterion is violated. In that case, perm_r is overwritten by a -! * new permutation determined by partial pivoting or diagonal -! * threshold pivoting. -! * Otherwise, perm_r is output argument. -! * -! * etree (input/output) int*, dimension (A->ncol) -! * Elimination tree of Pc'*A'*A*Pc. -! * If options->Fact != FACTORED and options->Fact != DOFACT, -! * etree is an input argument, otherwise it is an output argument. -! * Note: etree is a vector of parent pointers for a forest whose -! * vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. -! * -! * equed (input/output) char* -! * Specifies the form of equilibration that was done. -! * = 'N': No equilibration. -! * = 'R': Row equilibration, i.e., A was premultiplied by diag(R). -! * = 'C': Column equilibration, i.e., A was postmultiplied by diag(C). -! * = 'B': Both row and column equilibration, i.e., A was replaced -! * by diag(R)*A*diag(C). -! * If options->Fact = FACTORED, equed is an input argument, -! * otherwise it is an output argument. -! * -! * R (input/output) double*, dimension (A->nrow) -! * The row scale factors for A or transpose(A). -! * If equed = 'R' or 'B', A (if A->Stype = SLU_NC) or transpose(A) -! * (if A->Stype = SLU_NR) is multiplied on the left by diag(R). -! * If equed = 'N' or 'C', R is not accessed. -! * If options->Fact = FACTORED, R is an input argument, -! * otherwise, R is output. -! * If options->Fact = FACTORED and equed = 'R' or 'B', each element -! * of R must be positive. -! * -! * C (input/output) double*, dimension (A->ncol) -! * The column scale factors for A or transpose(A). -! * If equed = 'C' or 'B', A (if A->Stype = SLU_NC) or transpose(A) -! * (if A->Stype = SLU_NR) is multiplied on the right by diag(C). -! * If equed = 'N' or 'R', C is not accessed. -! * If options->Fact = FACTORED, C is an input argument, -! * otherwise, C is output. -! * If options->Fact = FACTORED and equed = 'C' or 'B', each element -! * of C must be positive. -! * -! * L (output) SuperMatrix* -! * The factor L from the factorization -! * Pr*A*Pc=L*U (if A->Stype SLU_= NC) or -! * Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). -! * Uses compressed row subscripts storage for supernodes, i.e., -! * L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. -! * -! * U (output) SuperMatrix* -! * The factor U from the factorization -! * Pr*A*Pc=L*U (if A->Stype = SLU_NC) or -! * Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). -! * Uses column-wise storage scheme, i.e., U has types: -! * Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. -! * -! * work (workspace/output) void*, size (lwork) (in bytes) -! * User supplied workspace, should be large enough -! * to hold data structures for factors L and U. -! * On exit, if fact is not 'F', L and U point to this array. -! * -! * lwork (input) int -! * Specifies the size of work array in bytes. -! * = 0: allocate space internally by system malloc; -! * > 0: use user-supplied work array of length lwork in bytes, -! * returns error if space runs out. -! * = -1: the routine guesses the amount of space needed without -! * performing the factorization, and returns it in -! * mem_usage->total_needed; no other side effects. -! * -! * See argument 'mem_usage' for memory usage statistics. -! * -! * B (input/output) SuperMatrix* -! * B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. -! * On entry, the right hand side matrix. -! * If B->ncol = 0, only LU decomposition is performed, the triangular -! * solve is skipped. -! * On exit, -! * if equed = 'N', B is not modified; otherwise -! * if A->Stype = SLU_NC: -! * if options->Trans = NOTRANS and equed = 'R' or 'B', -! * B is overwritten by diag(R)*B; -! * if options->Trans = TRANS or CONJ and equed = 'C' of 'B', -! * B is overwritten by diag(C)*B; -! * if A->Stype = SLU_NR: -! * if options->Trans = NOTRANS and equed = 'C' or 'B', -! * B is overwritten by diag(C)*B; -! * if options->Trans = TRANS or CONJ and equed = 'R' of 'B', -! * B is overwritten by diag(R)*B. -! * -! * X (output) SuperMatrix* -! * X has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. -! * If info = 0 or info = A->ncol+1, X contains the solution matrix -! * to the original system of equations. Note that A and B are modified -! * on exit if equed is not 'N', and the solution to the equilibrated -! * system is inv(diag(C))*X if options->Trans = NOTRANS and -! * equed = 'C' or 'B', or inv(diag(R))*X if options->Trans = 'T' or 'C' -! * and equed = 'R' or 'B'. -! * -! * recip_pivot_growth (output) double* -! * The reciprocal pivot growth factor max_j( norm(A_j)/norm(U_j) ). -! * The infinity norm is used. If recip_pivot_growth is much less -! * than 1, the stability of the LU factorization could be poor. -! * -! * rcond (output) double* -! * The estimate of the reciprocal condition number of the matrix A -! * after equilibration (if done). If rcond is less than the machine -! * precision (in particular, if rcond = 0), the matrix is singular -! * to working precision. This condition is indicated by a return -! * code of info > 0. -! * -! * mem_usage (output) mem_usage_t* -! * Record the memory usage statistics, consisting of following fields: -! * - for_lu (float) -! * The amount of space used in bytes for L\U data structures. -! * - total_needed (float) -! * The amount of space needed in bytes to perform factorization. -! * - expansions (int) -! * The number of memory expansions during the LU factorization. -! * -! * stat (output) SuperLUStat_t* -! * Record the statistics on runtime and floating-point operation count. -! * See slu_util.h for the definition of 'SuperLUStat_t'. -! * -! * info (output) int* -! * = 0: successful exit -! * < 0: if info = -i, the i-th argument had an illegal value -! * > 0: if info = i, and i is -! * <= A->ncol: number of zero pivots. They are replaced by small -! * entries due to options->ILU_FillTol. -! * = A->ncol+1: U is nonsingular, but RCOND is less than machine -! * precision, meaning that the matrix is singular to -! * working precision. Nevertheless, the solution and -! * error bounds are computed because there are a number -! * of situations where the computed solution can be more -! * accurate than the value of RCOND would suggest. -! * > A->ncol+1: number of bytes allocated when memory allocation -! * failure occurred, plus A->ncol. -! * -! */ -! -! void -! dgsisx(superlu_options_t *options, SuperMatrix *A, int *perm_c, int *perm_r, -! int *etree, char *equed, double *R, double *C, -! SuperMatrix *L, SuperMatrix *U, void *work, int lwork, -! SuperMatrix *B, SuperMatrix *X, -! double *recip_pivot_growth, double *rcond, -! GlobalLU_t *Glu, mem_usage_t *mem_usage, SuperLUStat_t *stat, int *info) - -INTERFACE - SUBROUTINE dgsisx(options, A, perm_c, perm_r, etree, & - & equed, R, C, L, U, work, lwork, B, X, recip_pivot_growth, & - & rcond, Glu, mem_usage, stat, info) & - & BIND(C, name="dgsisx") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix, GlobalLU_t, C_CHAR, C_DOUBLE, mem_usage_t - ! - TYPE(superlu_options_t), INTENT(IN) :: options - TYPE(SuperMatrix), INTENT(INOUT) :: A - INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) - INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) - INTEGER(C_INT), INTENT(INOUT) :: etree(*) - CHARACTER(1, kind=C_CHAR), INTENT(IN) :: equed - REAL(C_DOUBLE), INTENT(INOUT) :: R(*) - REAL(C_DOUBLE), INTENT(INOUT) :: C(*) - TYPE(SuperMatrix), INTENT(INOUT) :: L - TYPE(SuperMatrix), INTENT(INOUT) :: U - TYPE(C_PTR), INTENT(inout) :: work - INTEGER(C_INT), VALUE, INTENT(IN) :: lwork - TYPE(SuperMatrix), INTENT(INOUT) :: B - TYPE(SuperMatrix), INTENT(INOUT) :: X - REAL(C_DOUBLE), INTENT(INOUT) :: recip_pivot_growth - REAL(C_DOUBLE), INTENT(INOUT) :: rcond - TYPE(GlobalLU_t), INTENT(inout) :: Glu - TYPE(mem_usage_t), INTENT(INOUT) :: mem_usage - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - INTEGER(C_INT), INTENT(INOUT) :: info - END SUBROUTINE dgsisx -END INTERFACE - -PUBLIC :: dgsisx - -END MODULE SuperLU_dgsisx_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsitrf_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsitrf_Methods.F90 deleted file mode 100644 index ecee97e3a..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgsitrf_Methods.F90 +++ /dev/null @@ -1,196 +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 SuperLU_dgsitrf_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -! -! -! DGSITRF computes an ILU factorization of a general sparse m-by-n -! matrix A using partial pivoting with row interchanges. -! The factorization has the form -! Pr * A = L * U -! where Pr is a row permutation matrix, L is lower triangular with unit -! diagonal elements (lower trapezoidal if A->nrow > A->ncol), and U is upper -! triangular (upper trapezoidal if A->nrow < A->ncol). -! -! See supermatrix.h for the definition of 'SuperMatrix' structure. -! -! ====================================================================== -! -! Local Working Arrays: -! ====================== -! m = number of rows in the matrix -! n = number of columns in the matrix -! -! marker[0:3*m-1]: marker[i] = j means that node i has been -! reached when working on column j. -! Storage: relative to original row subscripts -! NOTE: There are 4 of them: -! marker/marker1 are used for panel dfs, see (ilu_)dpanel_dfs.c; -! marker2 is used for inner-factorization, see (ilu)_dcolumn_dfs.c; -! marker_relax(has its own space) is used for relaxed supernodes. -! -! parent[0:m-1]: parent vector used during dfs -! Storage: relative to new row subscripts -! -! xplore[0:m-1]: xplore[i] gives the location of the next (dfs) -! unexplored neighbor of i in lsub[*] -! -! segrep[0:nseg-1]: contains the list of supernodal representatives -! in topological order of the dfs. A supernode representative is the -! last column of a supernode. -! The maximum size of segrep[] is n. -! -! repfnz[0:W*m-1]: for a nonzero segment U[*,j] that ends at a -! supernodal representative r, repfnz[r] is the location of the first -! nonzero in this segment. It is also used during the dfs: repfnz[r]>0 -! indicates the supernode r has been explored. -! NOTE: There are W of them, each used for one column of a panel. -! -! panel_lsub[0:W*m-1]: temporary for the nonzeros row indices below -! the panel diagonal. These are filled in during dpanel_dfs(), and are -! used later in the inner LU factorization within the panel. -! panel_lsub[]/dense[] pair forms the SPA data structure. -! NOTE: There are W of them. -! -! dense[0:W*m-1]: sparse accumulating (SPA) vector for intermediate values; -! NOTE: there are W of them. -! -! tempv[0:*]: real temporary used for dense numeric kernels; -! The size of this array is defined by NUM_TEMPV() in slu_util.h. -! It is also used by the dropping routine ilu_ddrop_row(). -! -! void -! dgsitrf(superlu_options_t *options, SuperMatrix *A, int relax, int panel_size, -! int *etree, void *work, int lwork, int *perm_c, int *perm_r, -! SuperMatrix *L, SuperMatrix *U, -! GlobalLU_t *Glu, /* persistent to facilitate multiple factorizations */ -! SuperLUStat_t *stat, int *info) - -INTERFACE - SUBROUTINE dgsitrf(options, A, relax, panel_size, etree, & - & work, lwork, perm_c, perm_r, & - & L, U, & - & Glu, stat, info) & - & BIND(C, name="dgsitrf") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix, GlobalLU_t, C_CHAR, C_DOUBLE - ! - TYPE(superlu_options_t), INTENT(IN) :: options - ! options (input) superlu_options_t* - ! The structure defines the input parameters to control - ! how the ILU decomposition will be performed. - TYPE(SuperMatrix), INTENT(INOUT) :: A - ! A (input) SuperMatrix* - ! Original matrix A, permuted by columns, of dimension - ! (A->nrow, A->ncol). The type of A can be: - ! Stype = SLU_NCP; Dtype = SLU_D; Mtype = SLU_GE. - INTEGER(C_INT), VALUE, INTENT(IN) :: relax - ! relax (input) int - ! To control degree of relaxing supernodes. If the number - ! of nodes (columns) in a subtree of the elimination tree is less - ! than relax, this subtree is considered as one supernode, - ! regardless of the row structures of those columns. - INTEGER(C_INT), VALUE, INTENT(IN) :: panel_size - ! panel_size (input) int - ! A panel consists of at most panel_size consecutive columns. - INTEGER(C_INT), INTENT(INOUT) :: etree(*) - ! etree (input) int*, dimension (A->ncol) - ! Elimination tree of A'*A. - ! Note: etree is a vector of parent pointers for a forest whose - ! vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. - ! On input, the columns of A should be permuted so that the - ! etree is in a certain postorder. - TYPE(C_PTR), INTENT(inout) :: work - ! work (input/output) void*, size (lwork) (in bytes) - ! User-supplied work space and space for the output data structures. - ! Not referenced if lwork = 0; - INTEGER(C_INT), VALUE, INTENT(IN) :: lwork - ! lwork (input) int - ! Specifies the size of work array in bytes. - ! = 0: allocate space internally by system malloc; - ! > 0: use user-supplied work array of length lwork in bytes, - ! returns error if space runs out. - ! = -1: the routine guesses the amount of space needed without - ! performing the factorization, and returns it in - ! *info; no other side effects. - INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) - ! perm_c (input) int*, dimension (A->ncol) - ! Column permutation vector, which defines the - ! permutation matrix Pc; perm_c[i] = j means column i of A is - ! in position j in A*Pc. - ! When searching for diagonal, perm_c[*] is applied to the - ! row subscripts of A, so that diagonal threshold pivoting - ! can find the diagonal of A, rather than that of A*Pc. - INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) - ! perm_r (input/output) int*, dimension (A->nrow) - ! Row permutation vector which defines the permutation matrix Pr, - ! perm_r[i] = j means row i of A is in position j in Pr*A. - ! If options->Fact = SamePattern_SameRowPerm, the pivoting routine - ! will try to use the input perm_r, unless a certain threshold - ! criterion is violated. In that case, perm_r is overwritten by - ! a new permutation determined by partial pivoting or diagonal - ! threshold pivoting. - ! Otherwise, perm_r is output argument; - TYPE(SuperMatrix), INTENT(INOUT) :: L - ! L (output) SuperMatrix* - ! The factor L from the factorization Pr*A=L*U; use compressed row - ! subscripts storage for supernodes, i.e., L has type: - ! Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. - TYPE(SuperMatrix), INTENT(INOUT) :: U - ! U (output) SuperMatrix* - ! The factor U from the factorization Pr*A*Pc=L*U. Use column-wise - ! storage scheme, i.e., U has types: Stype = SLU_NC, - ! Dtype = SLU_D, Mtype = SLU_TRU. - TYPE(GlobalLU_t), INTENT(inout) :: Glu - ! Glu (input/output) GlobalLU_t * - ! If options->Fact == SamePattern_SameRowPerm, it is an input; - ! The matrix A will be factorized assuming that a - ! factorization of a matrix with the same sparsity pattern - ! and similar numerical values was performed prior to this one. - ! Therefore, this factorization will reuse both row and column - ! scaling factors R and C, both row and column permutation - ! vectors perm_r and perm_c, and the L & U data structures - ! set up from the previous factorization. - ! Otherwise, it is an output. - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - ! stat (output) SuperLUStat_t* - ! Record the statistics on runtime and floating-point operation count. - ! See slu_util.h for the definition of 'SuperLUStat_t'. - INTEGER(C_INT), INTENT(INOUT) :: info - ! info (output) int* - ! = 0: successful exit - ! < 0: if info = -i, the i-th argument had an illegal value - ! > 0: if info = i, and i is - ! <= A->ncol: number of zero pivots. They are replaced by small - ! entries according to options->ILU_FillTol. - ! > A->ncol: number of bytes allocated when memory allocation - ! failure occurred, plus A->ncol. If lwork = -1, it is - ! the estimated amount of space needed, plus A->ncol. - END SUBROUTINE dgsitrf -END INTERFACE - -PUBLIC :: dgsitrf - -END MODULE SuperLU_dgsitrf_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 deleted file mode 100644 index f158aa7d7..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 +++ /dev/null @@ -1,165 +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 SuperLU_dgsrfs_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! * Purpose -! * ======= -! * -! * DGSRFS improves the computed solution to a system of linear -! * equations and provides error bounds and backward error estimates for -! * the solution. -! * -! * If equilibration was performed, the system becomes: -! * (diag(R)*A_original*diag(C)) * X = diag(R)*B_original. -! * -! * See supermatrix.h for the definition of 'SuperMatrix' structure. -! * -! * Arguments -! * ========= -! * -! * trans (input) trans_t -! * Specifies the form of the system of equations: -! * = NOTRANS: A * X = B (No transpose) -! * = TRANS: A'* X = B (Transpose) -! * = CONJ: A**H * X = B (Conjugate transpose) -! * -! * A (input) SuperMatrix* -! * The original matrix A in the system, or the scaled A if -! * equilibration was done. The type of A can be: -! * Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_GE. -! * -! * L (input) SuperMatrix* -! * The factor L from the factorization Pr*A*Pc=L*U. Use -! * compressed row subscripts storage for supernodes, -! * i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. -! * -! * U (input) SuperMatrix* -! * The factor U from the factorization Pr*A*Pc=L*U as computed by -! * dgstrf(). Use column-wise storage scheme, -! * i.e., U has types: Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. -! * -! * perm_c (input) int*, dimension (A->ncol) -! * Column permutation vector, which defines the -! * permutation matrix Pc; perm_c[i] = j means column i of A is -! * in position j in A*Pc. -! * -! * perm_r (input) int*, dimension (A->nrow) -! * Row permutation vector, which defines the permutation matrix Pr; -! * perm_r[i] = j means row i of A is in position j in Pr*A. -! * -! * equed (input) Specifies the form of equilibration that was done. -! * = 'N': No equilibration. -! * = 'R': Row equilibration, i.e., A was premultiplied by diag(R). -! * = 'C': Column equilibration, i.e., A was postmultiplied by -! * diag(C). -! * = 'B': Both row and column equilibration, i.e., A was replaced -! * by diag(R)*A*diag(C). -! * -! * R (input) double*, dimension (A->nrow) -! * The row scale factors for A. -! * If equed = 'R' or 'B', A is premultiplied by diag(R). -! * If equed = 'N' or 'C', R is not accessed. -! * -! * C (input) double*, dimension (A->ncol) -! * The column scale factors for A. -! * If equed = 'C' or 'B', A is postmultiplied by diag(C). -! * If equed = 'N' or 'R', C is not accessed. -! * -! * B (input) SuperMatrix* -! * B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. -! * The right hand side matrix B. -! * if equed = 'R' or 'B', B is premultiplied by diag(R). -! * -! * X (input/output) SuperMatrix* -! * X has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. -! * On entry, the solution matrix X, as computed by dgstrs(). -! * On exit, the improved solution matrix X. -! * if *equed = 'C' or 'B', X should be premultiplied by diag(C) -! * in order to obtain the solution to the original system. -! * -! * FERR (output) double*, dimension (B->ncol) -! * The estimated forward error bound for each solution vector -! * X(j) (the j-th column of the solution matrix X). -! * If XTRUE is the true solution corresponding to X(j), FERR(j) -! * is an estimated upper bound for the magnitude of the largest -! * element in (X(j) - XTRUE) divided by the magnitude of the -! * largest element in X(j). The estimate is as reliable as -! * the estimate for RCOND, and is almost always a slight -! * overestimate of the true error. -! * -! * BERR (output) double*, dimension (B->ncol) -! * The componentwise relative backward error of each solution -! * vector X(j) (i.e., the smallest relative change in -! * any element of A or B that makes X(j) an exact solution). -! * -! * stat (output) SuperLUStat_t* -! * Record the statistics on runtime and floating-point operation count. -! * See util.h for the definition of 'SuperLUStat_t'. -! * -! * info (output) int* -! * = 0: successful exit -! * < 0: if INFO = -i, the i-th argument had an illegal value -! * -! * Internal Parameters -! * =================== -! * -! * ITMAX is the maximum number of steps of iterative refinement. -! * -! void -! dgsrfs(trans_t trans, SuperMatrix *A, SuperMatrix *L, SuperMatrix *U, -! int *perm_c, int *perm_r, char *equed, double *R, double *C, -! SuperMatrix *B, SuperMatrix *X, double *ferr, double *berr, -! SuperLUStat_t *stat, int *info) - -INTERFACE - SUBROUTINE dgsrfs(trans, A, L, U, perm_c, perm_r, & - & equed, R, C, B, X, ferr, berr, & - & stat, info) & - & BIND(C, name="dgsrfs") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix, GlobalLU_t, mem_usage_t, C_CHAR, C_DOUBLE - ! - INTEGER(C_INT), VALUE, INTENT(IN) :: trans - TYPE(SuperMatrix), INTENT(INOUT) :: A - TYPE(SuperMatrix), INTENT(INOUT) :: L - TYPE(SuperMatrix), INTENT(INOUT) :: U - INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) - INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) - CHARACTER(1, kind=C_CHAR), INTENT(inout) :: equed(*) - REAL(C_DOUBLE), INTENT(inout) :: R(*) - REAL(C_DOUBLE), INTENT(inout) :: C(*) - TYPE(SuperMatrix), INTENT(INOUT) :: B - TYPE(SuperMatrix), INTENT(INOUT) :: X - REAL(C_DOUBLE), INTENT(inout) :: ferr(*) - REAL(C_DOUBLE), INTENT(inout) :: berr(*) - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - INTEGER(C_INT), INTENT(INOUT) :: info - END SUBROUTINE dgsrfs -END INTERFACE - -PUBLIC :: dgsrfs - -END MODULE SuperLU_dgsrfs_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 deleted file mode 100644 index 6a8d413e0..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 +++ /dev/null @@ -1,150 +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 SuperLU_dgssv_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -! -! DGSSV solves the system of linear equations A*X=B, using the -! LU factorization from DGSTRF. It performs the following steps: -! -! 1. If A is stored column-wise (A->Stype = SLU_NC): -! -! 1.1. Permute the columns of A, forming A*Pc, where Pc -! is a permutation matrix. For more details of this step, -! see sp_preorder.c. -! -! 1.2. Factor A as Pr*A*Pc=L*U with the permutation Pr determined -! by Gaussian elimination with partial pivoting. -! L is unit lower triangular with offdiagonal entries -! bounded by 1 in magnitude, and U is upper triangular. -! -! 1.3. Solve the system of equations A*X=B using the factored -! form of A. -! -! 2. If A is stored row-wise (A->Stype = SLU_NR), apply the -! above algorithm to the transpose of A: -! -! 2.1. Permute columns of transpose(A) (rows of A), -! forming transpose(A)*Pc, where Pc is a permutation matrix. -! For more details of this step, see sp_preorder.c. -! -! 2.2. Factor A as Pr*transpose(A)*Pc=L*U with the permutation Pr -! determined by Gaussian elimination with partial pivoting. -! L is unit lower triangular with offdiagonal entries -! bounded by 1 in magnitude, and U is upper triangular. -! -! 2.3. Solve the system of equations A*X=B using the factored -! form of A. -! -! See supermatrix.h for the definition of 'SuperMatrix' structure. -! -! void -! dgssv(superlu_options_t *options, SuperMatrix *A, int *perm_c, int *perm_r, -! SuperMatrix *L, SuperMatrix *U, SuperMatrix *B, -! SuperLUStat_t *stat, int *info ) - -INTERFACE - SUBROUTINE dgssv(options, A, perm_c, perm_r, L, U, B, stat, info) & - & BIND(C, name="dgssv") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix - TYPE(superlu_options_t), INTENT(INOUT) :: options - ! options (input) superlu_options_t* - ! The structure defines the input parameters to control - ! how the LU decomposition will be performed and how the - ! system will be solved. - TYPE(SuperMatrix), INTENT(INOUT) :: A - ! A (input) SuperMatrix* - ! Matrix A in A*X=B, of dimension (A->nrow, A->ncol). The number - ! of linear equations is A->nrow. Currently, the type of A can be: - ! Stype = SLU_NC or SLU_NR; Dtype = SLU_D; Mtype = SLU_GE. - ! In the future, more general A may be handled. - INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) - ! perm_c (input/output) int* - ! If A->Stype = SLU_NC, column permutation vector of size A->ncol - ! which defines the permutation matrix Pc; perm_c[i] = j means - ! column i of A is in position j in A*Pc. - ! If A->Stype = SLU_NR, column permutation vector of size A->nrow - ! which describes permutation of columns of transpose(A) - ! (rows of A) as described above. - ! - ! If options->ColPerm = MY_PERMC or options->Fact = SamePattern or - ! options->Fact = SamePattern_SameRowPerm, it is an input argument. - ! On exit, perm_c may be overwritten by the product of the input - ! perm_c and a permutation that postorders the elimination tree - ! of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree - ! is already in postorder. - ! Otherwise, it is an output argument. - INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) - ! perm_r (input/output) int* - ! If A->Stype = SLU_NC, row permutation vector of size A->nrow, - ! which defines the permutation matrix Pr, and is determined - ! by partial pivoting. perm_r[i] = j means row i of A is in - ! position j in Pr*A. - ! If A->Stype = SLU_NR, permutation vector of size A->ncol, which - ! determines permutation of rows of transpose(A) - ! (columns of A) as described above. - ! - ! If options->RowPerm = MY_PERMR or - ! options->Fact = SamePattern_SameRowPerm, perm_r is an - ! input argument. - ! otherwise it is an output argument. - TYPE(SuperMatrix), INTENT(INOUT) :: L - ! L (output) SuperMatrix* - ! The factor L from the factorization - ! Pr*A*Pc=L*U (if A->Stype = SLU_NC) or - ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). - ! Uses compressed row subscripts storage for supernodes, i.e., - ! L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. - TYPE(SuperMatrix), INTENT(INOUT) :: U - ! U (output) SuperMatrix* - ! The factor U from the factorization - ! Pr*A*Pc=L*U (if A->Stype = SLU_NC) or - ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). - ! Uses column-wise storage scheme, i.e., U has types: - ! Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. - TYPE(SuperMatrix), INTENT(INOUT) :: B - ! B (input/output) SuperMatrix* - ! B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. - ! On entry, the right hand side matrix. - ! On exit, the solution matrix if info = 0; - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - ! stat (output) SuperLUStat_t* - ! Record the statistics on runtime and floating-point operation count. - ! See util.h for the definition of 'SuperLUStat_t'. - INTEGER(C_INT), INTENT(INOUT) :: info - ! info (output) int* - ! = 0: successful exit - ! > 0: if info = i, and i is - ! <= A->ncol: U(i,i) is exactly zero. The factorization has - ! been completed, but the factor U is exactly singular, - ! so the solution could not be computed. - ! > A->ncol: number of bytes allocated when memory allocation - ! failure occurred, plus A->ncol. - END SUBROUTINE dgssv -END INTERFACE - -PUBLIC :: dgssv - -END MODULE diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 deleted file mode 100644 index afb8ed926..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 +++ /dev/null @@ -1,375 +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 SuperLU_dgssvx_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR, C_SIZE_T -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -! -! -! DGSSVX solves the system of linear equations A*X=B or A'*X=B, using -! the LU factorization from dgstrf(). Error bounds on the solution and -! a condition estimate are also provided. It performs the following steps: -! -! 1. If A is stored column-wise (A->Stype = SLU_NC): -! -! 1.1. If options->Equil = YES, scaling factors are computed to -! equilibrate the system: -! options->Trans = NOTRANS: -! diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -! options->Trans = TRANS: -! (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -! options->Trans = CONJ: -! (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -! Whether or not the system will be equilibrated depends on the -! scaling of the matrix A, but if equilibration is used, A is -! overwritten by diag(R)*A*diag(C) and B by diag(R)*B -! (if options->Trans=NOTRANS) or diag(C)*B (if options->Trans -! = TRANS or CONJ). -! -! 1.2. Permute columns of A, forming A*Pc, where Pc is a permutation -! matrix that usually preserves sparsity. -! For more details of this step, see sp_preorder.c. -! -! 1.3. If options->Fact != FACTORED, the LU decomposition is used to -! factor the matrix A (after equilibration if options->Equil = YES) -! as Pr*A*Pc = L*U, with Pr determined by partial pivoting. -! -! 1.4. Compute the reciprocal pivot growth factor. -! -! 1.5. If some U(i,i) = 0, so that U is exactly singular, then the -! routine returns with info = i. Otherwise, the factored form of -! A is used to estimate the condition number of the matrix A. If -! the reciprocal of the condition number is less than machine -! precision, info = A->ncol+1 is returned as a warning, but the -! routine still goes on to solve for X and computes error bounds -! as described below. -! -! 1.6. The system of equations is solved for X using the factored form -! of A. -! -! 1.7. If options->IterRefine != NOREFINE, iterative refinement is -! applied to improve the computed solution matrix and calculate -! error bounds and backward error estimates for it. -! -! 1.8. If equilibration was used, the matrix X is premultiplied by -! diag(C) (if options->Trans = NOTRANS) or diag(R) -! (if options->Trans = TRANS or CONJ) so that it solves the -! original system before equilibration. -! -! 2. If A is stored row-wise (A->Stype = SLU_NR), apply the above algorithm -! to the transpose of A: -! -! 2.1. If options->Equil = YES, scaling factors are computed to -! equilibrate the system: -! options->Trans = NOTRANS: -! diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -! options->Trans = TRANS: -! (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -! options->Trans = CONJ: -! (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -! Whether or not the system will be equilibrated depends on the -! scaling of the matrix A, but if equilibration is used, A' is -! overwritten by diag(R)*A'*diag(C) and B by diag(R)*B -! (if trans='N') or diag(C)*B (if trans = 'T' or 'C'). -! -! 2.2. Permute columns of transpose(A) (rows of A), -! forming transpose(A)*Pc, where Pc is a permutation matrix that -! usually preserves sparsity. -! For more details of this step, see sp_preorder.c. -! -! 2.3. If options->Fact != FACTORED, the LU decomposition is used to -! factor the transpose(A) (after equilibration if -! options->Fact = YES) as Pr*transpose(A)*Pc = L*U with the -! permutation Pr determined by partial pivoting. -! -! 2.4. Compute the reciprocal pivot growth factor. -! -! 2.5. If some U(i,i) = 0, so that U is exactly singular, then the -! routine returns with info = i. Otherwise, the factored form -! of transpose(A) is used to estimate the condition number of the -! matrix A. If the reciprocal of the condition number -! is less than machine precision, info = A->nrow+1 is returned as -! a warning, but the routine still goes on to solve for X and -! computes error bounds as described below. -! -! 2.6. The system of equations is solved for X using the factored form -! of transpose(A). -! -! 2.7. If options->IterRefine != NOREFINE, iterative refinement is -! applied to improve the computed solution matrix and calculate -! error bounds and backward error estimates for it. -! -! 2.8. If equilibration was used, the matrix X is premultiplied by -! diag(C) (if options->Trans = NOTRANS) or diag(R) -! (if options->Trans = TRANS or CONJ) so that it solves the -! original system before equilibration. -! -! See supermatrix.h for the definition of 'SuperMatrix' structure. -! -! void -! dgssvx(superlu_options_t *options, SuperMatrix *A, int *perm_c, int *perm_r, -! int *etree, char *equed, double *R, double *C, -! SuperMatrix *L, SuperMatrix *U, void *work, int lwork, -! SuperMatrix *B, SuperMatrix *X, double *recip_pivot_growth, -! double *rcond, double *ferr, double *berr, -! GlobalLU_t *Glu, mem_usage_t *mem_usage, SuperLUStat_t *stat, int *info ) - -INTERFACE - SUBROUTINE dgssvx(options, A, perm_c, perm_r, & - & etree, equed, R, C, L, U, work, lwork, & - & B, X, recip_pivot_growth, rcond, ferr, berr, & - & Glu, mem_usage, stat, info) & - & BIND(C, name="dgssvx") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix, GlobalLU_t, mem_usage_t, C_CHAR, C_DOUBLE, & - & C_SIZE_T - ! - TYPE(superlu_options_t), INTENT(IN) :: options - ! options (input) superlu_options_t* - ! The structure defines the input parameters to control - ! how the LU decomposition will be performed and how the - ! system will be solved. - TYPE(SuperMatrix), INTENT(INOUT) :: A - ! A (input/output) SuperMatrix* - ! Matrix A in A*X=B, of dimension (A->nrow, A->ncol). The number - ! of the linear equations is A->nrow. Currently, the type of A can be: - ! Stype = SLU_NC or SLU_NR, Dtype = SLU_D, Mtype = SLU_GE. - ! In the future, more general A may be handled. - ! - ! On entry, If options->Fact = FACTORED and equed is not 'N', - ! then A must have been equilibrated by the scaling factors in - ! R and/or C. - ! On exit, A is not modified if options->Equil = NO, or if - ! options->Equil = YES but equed = 'N' on exit. - ! Otherwise, if options->Equil = YES and equed is not 'N', - ! A is scaled as follows: - ! If A->Stype = SLU_NC: - ! equed = 'R': A := diag(R) * A - ! equed = 'C': A := A * diag(C) - ! equed = 'B': A := diag(R) * A * diag(C). - ! If A->Stype = SLU_NR: - ! equed = 'R': transpose(A) := diag(R) * transpose(A) - ! equed = 'C': transpose(A) := transpose(A) * diag(C) - ! equed = 'B': transpose(A) := diag(R) * transpose(A) * diag(C). - INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) - ! perm_c (input/output) int* - ! If A->Stype = SLU_NC, Column permutation vector of size A->ncol, - ! which defines the permutation matrix Pc; perm_c[i] = j means - ! column i of A is in position j in A*Pc. - ! On exit, perm_c may be overwritten by the product of the input - ! perm_c and a permutation that postorders the elimination tree - ! of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree - ! is already in postorder. - ! - ! If A->Stype = SLU_NR, column permutation vector of size A->nrow, - ! which describes permutation of columns of transpose(A) - ! (rows of A) as described above. - INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) - ! perm_r (input/output) int* - ! If A->Stype = SLU_NC, row permutation vector of size A->nrow, - ! which defines the permutation matrix Pr, and is determined - ! by partial pivoting. perm_r[i] = j means row i of A is in - ! position j in Pr*A. - ! - ! If A->Stype = SLU_NR, permutation vector of size A->ncol, which - ! determines permutation of rows of transpose(A) - ! (columns of A) as described above. - ! - ! If options->Fact = SamePattern_SameRowPerm, the pivoting routine - ! will try to use the input perm_r, unless a certain threshold - ! criterion is violated. In that case, perm_r is overwritten by a - ! new permutation determined by partial pivoting or diagonal - ! threshold pivoting. - ! Otherwise, perm_r is output argument. - INTEGER(C_INT), INTENT(INOUT) :: etree(*) - ! etree (input/output) int*, dimension (A->ncol) - ! Elimination tree of Pc'*A'*A*Pc. - ! If options->Fact != FACTORED and options->Fact != DOFACT, - ! etree is an input argument, otherwise it is an output argument. - ! Note: etree is a vector of parent pointers for a forest whose - ! vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. - CHARACTER(1, kind=C_CHAR), INTENT(inout) :: equed(*) - ! equed (input/output) char* - ! Specifies the form of equilibration that was done. - ! = 'N': No equilibration. - ! = 'R': Row equilibration, i.e., A was premultiplied by diag(R). - ! = 'C': Column equilibration, i.e., A was postmultiplied by diag(C). - ! = 'B': Both row and column equilibration, i.e., A was replaced - ! by diag(R)*A*diag(C). - ! If options->Fact = FACTORED, equed is an input argument, - ! otherwise it is an output argument. - REAL(C_DOUBLE), INTENT(inout) :: R(*) - ! R (input/output) double*, dimension (A->nrow) - ! The row scale factors for A or transpose(A). - ! If equed = 'R' or 'B', A (if A->Stype = SLU_NC) or transpose(A) - ! (if A->Stype = SLU_NR) is multiplied on the left by diag(R). - ! If equed = 'N' or 'C', R is not accessed. - ! If options->Fact = FACTORED, R is an input argument, - ! otherwise, R is output. - ! If options->Fact = FACTORED and equed = 'R' or 'B', each element - ! of R must be positive. - REAL(C_DOUBLE), INTENT(inout) :: C(*) - ! C (input/output) double*, dimension (A->ncol) - ! The column scale factors for A or transpose(A). - ! If equed = 'C' or 'B', A (if A->Stype = SLU_NC) or transpose(A) - ! (if A->Stype = SLU_NR) is multiplied on the right by diag(C). - ! If equed = 'N' or 'R', C is not accessed. - ! If options->Fact = FACTORED, C is an input argument, - ! otherwise, C is output. - ! If options->Fact = FACTORED and equed = 'C' or 'B', each element - ! of C must be positive. - TYPE(SuperMatrix), INTENT(INOUT) :: L - ! L (output) SuperMatrix* - ! The factor L from the factorization - ! Pr*A*Pc=L*U (if A->Stype SLU_= NC) or - ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). - ! Uses compressed row subscripts storage for supernodes, i.e., - ! L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. - TYPE(SuperMatrix), INTENT(INOUT) :: U - ! U (output) SuperMatrix* - ! The factor U from the factorization - ! Pr*A*Pc=L*U (if A->Stype = SLU_NC) or - ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). - ! Uses column-wise storage scheme, i.e., U has types: - ! Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. - TYPE(C_PTR), INTENT(inout) :: work - ! work (workspace/output) void*, size (lwork) (in bytes) - ! User supplied workspace, should be large enough - ! to hold data structures for factors L and U. - ! On exit, if fact is not 'F', L and U point to this array. - ! - INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: lwork - ! lwork (input) int - ! Specifies the size of work array in bytes. - ! = 0: allocate space internally by system malloc; - ! > 0: use user-supplied work array of length lwork in bytes, - ! returns error if space runs out. - ! = -1: the routine guesses the amount of space needed without - ! performing the factorization, and returns it in - ! mem_usage->total_needed; no other side effects. - ! - ! See argument 'mem_usage' for memory usage statistics. - TYPE(SuperMatrix), INTENT(INOUT) :: B - ! B (input/output) SuperMatrix* - ! B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. - ! On entry, the right hand side matrix. - ! If B->ncol = 0, only LU decomposition is performed, the triangular - ! solve is skipped. - ! On exit, - ! if equed = 'N', B is not modified; otherwise - ! if A->Stype = SLU_NC: - ! if options->Trans = NOTRANS and equed = 'R' or 'B', - ! B is overwritten by diag(R)*B; - ! if options->Trans = TRANS or CONJ and equed = 'C' of 'B', - ! B is overwritten by diag(C)*B; - ! if A->Stype = SLU_NR: - ! if options->Trans = NOTRANS and equed = 'C' or 'B', - ! B is overwritten by diag(C)*B; - ! if options->Trans = TRANS or CONJ and equed = 'R' of 'B', - ! B is overwritten by diag(R)*B. - TYPE(SuperMatrix), INTENT(INOUT) :: X - ! (output) SuperMatrix* - ! X has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. - ! If info = 0 or info = A->ncol+1, X contains the solution matrix - ! to the original system of equations. Note that A and B are modified - ! on exit if equed is not 'N', and the solution to the equilibrated - ! system is inv(diag(C))*X if options->Trans = NOTRANS and - ! equed = 'C' or 'B', or inv(diag(R))*X if options->Trans = 'T' or 'C' - ! and equed = 'R' or 'B'. - ! - REAL(C_DOUBLE), INTENT(INOUT) :: recip_pivot_growth - ! recip_pivot_growth (output) double* - ! The reciprocal pivot growth factor max_j( norm(A_j)/norm(U_j) ). - ! The infinity norm is used. If recip_pivot_growth is much less - ! than 1, the stability of the LU factorization could be poor. - REAL(C_DOUBLE), INTENT(inout) :: rcond - ! rcond (output) double* - ! The estimate of the reciprocal condition number of the matrix A - ! after equilibration (if done). If rcond is less than the machine - ! precision (in particular, if rcond = 0), the matrix is singular - ! to working precision. This condition is indicated by a return - ! code of info > 0. - REAL(C_DOUBLE), INTENT(inout) :: ferr(*) - ! FERR (output) double*, dimension (B->ncol) - ! The estimated forward error bound for each solution vector - ! X(j) (the j-th column of the solution matrix X). - ! If XTRUE is the true solution corresponding to X(j), FERR(j) - ! is an estimated upper bound for the magnitude of the largest - ! element in (X(j) - XTRUE) divided by the magnitude of the - ! largest element in X(j). The estimate is as reliable as - ! the estimate for RCOND, and is almost always a slight - ! overestimate of the true error. - ! If options->IterRefine = NOREFINE, ferr = 1.0. - REAL(C_DOUBLE), INTENT(inout) :: berr(*) - ! BERR (output) double*, dimension (B->ncol) - ! The componentwise relative backward error of each solution - ! vector X(j) (i.e., the smallest relative change in - ! any element of A or B that makes X(j) an exact solution). - ! If options->IterRefine = NOREFINE, berr = 1.0. - TYPE(GlobalLU_t), INTENT(inout) :: Glu - ! Glu (input/output) GlobalLU_t * - ! If options->Fact == SamePattern_SameRowPerm, it is an input; - ! The matrix A will be factorized assuming that a - ! factorization of a matrix with the same sparsity pattern - ! and similar numerical values was performed prior to this one. - ! Therefore, this factorization will reuse both row and column - ! scaling factors R and C, both row and column permutation - ! vectors perm_r and perm_c, and the L & U data structures - ! set up from the previous factorization. - ! Otherwise, it is an output. - TYPE(mem_usage_t), INTENT(inout) :: mem_usage - ! mem_usage (output) mem_usage_t* - ! Record the memory usage statistics, consisting of following fields: - ! - for_lu (float) - ! The amount of space used in bytes for L\U data structures. - ! - total_needed (float) - ! The amount of space needed in bytes to perform factorization. - ! - expansions (int) - ! The number of memory expansions during the LU factorization. - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - ! stat (output) SuperLUStat_t* - ! Record the statistics on runtime and floating-point operation count. - ! See slu_util.h for the definition of 'SuperLUStat_t'. - INTEGER(C_SIZE_T), INTENT(INOUT) :: info - ! info (output) int* - ! = 0: successful exit - ! < 0: if info = -i, the i-th argument had an illegal value - ! > 0: if info = i, and i is - ! <= A->ncol: U(i,i) is exactly zero. The factorization has - ! been completed, but the factor U is exactly - ! singular, so the solution and error bounds - ! could not be computed. - ! = A->ncol+1: U is nonsingular, but RCOND is less than machine - ! precision, meaning that the matrix is singular to - ! working precision. Nevertheless, the solution and - ! error bounds are computed because there are a number - ! of situations where the computed solution can be more - ! accurate than the value of RCOND would suggest. - ! > A->ncol+1: number of bytes allocated when memory allocation - ! failure occurred, plus A->ncol. - END SUBROUTINE dgssvx -END INTERFACE - -PUBLIC :: dgssvx - -END MODULE SuperLU_dgssvx_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.F90 deleted file mode 100644 index 3eb8725e7..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.F90 +++ /dev/null @@ -1,302 +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 SuperLU_dgstrf_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23-01-23 -! summary: -! -!# Introduction -! -! * Purpose -! * ======= -! * -! * DGSTRF computes an LU factorization of a general sparse m-by-n -! * matrix A using partial pivoting with row interchanges. -! * The factorization has the form -! * Pr * A = L * U -! * where Pr is a row permutation matrix, L is lower triangular with unit -! * diagonal elements (lower trapezoidal if A->nrow > A->ncol), and U is upper -! * triangular (upper trapezoidal if A->nrow < A->ncol). -! * -! * See supermatrix.h for the definition of 'SuperMatrix' structure. -! * -! * Arguments -! * ========= -! * -! * options (input) superlu_options_t* -! * The structure defines the input parameters to control -! * how the LU decomposition will be performed. -! * -! * A (input) SuperMatrix* -! * Original matrix A, permuted by columns, of dimension -! * (A->nrow, A->ncol). The type of A can be: -! * Stype = SLU_NCP; Dtype = SLU_D; Mtype = SLU_GE. -! * -! * relax (input) int -! * To control degree of relaxing supernodes. If the number -! * of nodes (columns) in a subtree of the elimination tree is less -! * than relax, this subtree is considered as one supernode, -! * regardless of the row structures of those columns. -! * -! * panel_size (input) int -! * A panel consists of at most panel_size consecutive columns. -! * -! * etree (input) int*, dimension (A->ncol) -! * Elimination tree of A'*A. -! * Note: etree is a vector of parent pointers for a forest whose -! * vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. -! * On input, the columns of A should be permuted so that the -! * etree is in a certain postorder. -! * -! * work (input/output) void*, size (lwork) (in bytes) -! * User-supplied work space and space for the output data structures. -! * Not referenced if lwork = 0; -! * -! * lwork (input) int -! * Specifies the size of work array in bytes. -! * = 0: allocate space internally by system malloc; -! * > 0: use user-supplied work array of length lwork in bytes, -! * returns error if space runs out. -! * = -1: the routine guesses the amount of space needed without -! * performing the factorization, and returns it in -! * *info; no other side effects. -! * -! * perm_c (input) int*, dimension (A->ncol) -! * Column permutation vector, which defines the -! * permutation matrix Pc; perm_c[i] = j means column i of A is -! * in position j in A*Pc. -! * When searching for diagonal, perm_c[*] is applied to the -! * row subscripts of A, so that diagonal threshold pivoting -! * can find the diagonal of A, rather than that of A*Pc. -! * -! * perm_r (input/output) int*, dimension (A->nrow) -! * Row permutation vector which defines the permutation matrix Pr, -! * perm_r[i] = j means row i of A is in position j in Pr*A. -! * If options->Fact == SamePattern_SameRowPerm, the pivoting routine -! * will try to use the input perm_r, unless a certain threshold -! * criterion is violated. In that case, perm_r is overwritten by -! * a new permutation determined by partial pivoting or diagonal -! * threshold pivoting. -! * Otherwise, perm_r is output argument; -! * -! * L (output) SuperMatrix* -! * The factor L from the factorization Pr*A=L*U; use compressed row -! * subscripts storage for supernodes, i.e., L has type: -! * Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. -! * -! * U (output) SuperMatrix* -! * The factor U from the factorization Pr*A*Pc=L*U. Use column-wise -! * storage scheme, i.e., U has types: Stype = SLU_NC, -! * Dtype = SLU_D, Mtype = SLU_TRU. -! * -! * Glu (input/output) GlobalLU_t * -! * If options->Fact == SamePattern_SameRowPerm, it is an input; -! * The matrix A will be factorized assuming that a -! * factorization of a matrix with the same sparsity pattern -! * and similar numerical values was performed prior to this one. -! * Therefore, this factorization will reuse both row and column -! * scaling factors R and C, both row and column permutation -! * vectors perm_r and perm_c, and the L & U data structures -! * set up from the previous factorization. -! * Otherwise, it is an output. -! * -! * stat (output) SuperLUStat_t* -! * Record the statistics on runtime and floating-point operation count. -! * See slu_util.h for the definition of 'SuperLUStat_t'. -! * -! * info (output) int* -! * = 0: successful exit -! * < 0: if info = -i, the i-th argument had an illegal value -! * > 0: if info = i, and i is -! * <= A->ncol: U(i,i) is exactly zero. The factorization has -! * been completed, but the factor U is exactly singular, -! * and division by zero will occur if it is used to solve a -! * system of equations. -! * > A->ncol: number of bytes allocated when memory allocation -! * failure occurred, plus A->ncol. If lwork = -1, it is -! * the estimated amount of space needed, plus A->ncol. -! * -! * ====================================================================== -! * -! * Local Working Arrays: -! * ====================== -! * m = number of rows in the matrix -! * n = number of columns in the matrix -! * -! * xprune[0:n-1]: xprune[*] points to locations in subscript -! * vector lsub[*]. For column i, xprune[i] denotes the point where -! * structural pruning begins. I.e. only xlsub[i],..,xprune[i]-1 need -! * to be traversed for symbolic factorization. -! * -! * marker[0:3*m-1]: marker[i] = j means that node i has been -! * reached when working on column j. -! * Storage: relative to original row subscripts -! * NOTE: There are 3 of them: marker/marker1 are used for panel dfs, -! * see dpanel_dfs.c; marker2 is used for inner-factorization, -! * see dcolumn_dfs.c. -! * -! * parent[0:m-1]: parent vector used during dfs -! * Storage: relative to new row subscripts -! * -! * xplore[0:m-1]: xplore[i] gives the location of the next (dfs) -! * unexplored neighbor of i in lsub[*] -! * -! * segrep[0:nseg-1]: contains the list of supernodal representatives -! * in topological order of the dfs. A supernode representative is the -! * last column of a supernode. -! * The maximum size of segrep[] is n. -! * -! * repfnz[0:W*m-1]: for a nonzero segment U[*,j] that ends at a -! * supernodal representative r, repfnz[r] is the location of the first -! * nonzero in this segment. It is also used during the dfs: repfnz[r]>0 -! * indicates the supernode r has been explored. -! * NOTE: There are W of them, each used for one column of a panel. -! * -! * panel_lsub[0:W*m-1]: temporary for the nonzeros row indices below -! * the panel diagonal. These are filled in during dpanel_dfs(), and are -! * used later in the inner LU factorization within the panel. -! * panel_lsub[]/dense[] pair forms the SPA data structure. -! * NOTE: There are W of them. -! * -! * dense[0:W*m-1]: sparse accumulating (SPA) vector for intermediate values; -! * NOTE: there are W of them. -! * -! * tempv[0:*]: real temporary used for dense numeric kernels; -! * The size of this array is defined by NUM_TEMPV() in slu_ddefs.h. -! void -! dgstrf (superlu_options_t *options, SuperMatrix *A, -! int relax, int panel_size, int *etree, void *work, int lwork, -! int *perm_c, int *perm_r, SuperMatrix *L, SuperMatrix *U, -! GlobalLU_t *Glu, /* persistent to facilitate multiple factorizations */ -! SuperLUStat_t *stat, int *info) - -INTERFACE - SUBROUTINE dgstrf(options, A, relax, panel_size, etree, & - & work, lwork, perm_c, perm_r, & - & L, U, & - & Glu, stat, info) & - & BIND(C, name="dgstrf") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix, GlobalLU_t, C_CHAR, C_DOUBLE - ! - TYPE(superlu_options_t), INTENT(IN) :: options - ! options (input) superlu_options_t* - ! The structure defines the input parameters to control - ! how the ILU decomposition will be performed. - TYPE(SuperMatrix), INTENT(INOUT) :: A - ! A (input) SuperMatrix* - ! Original matrix A, permuted by columns, of dimension - ! (A->nrow, A->ncol). The type of A can be: - ! Stype = SLU_NCP; Dtype = SLU_D; Mtype = SLU_GE. - INTEGER(C_INT), VALUE, INTENT(IN) :: relax - ! relax (input) int - ! To control degree of relaxing supernodes. If the number - ! of nodes (columns) in a subtree of the elimination tree is less - ! than relax, this subtree is considered as one supernode, - ! regardless of the row structures of those columns. - INTEGER(C_INT), VALUE, INTENT(IN) :: panel_size - ! panel_size (input) int - ! A panel consists of at most panel_size consecutive columns. - INTEGER(C_INT), INTENT(INOUT) :: etree(*) - ! etree (input) int*, dimension (A->ncol) - ! Elimination tree of A'*A. - ! Note: etree is a vector of parent pointers for a forest whose - ! vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. - ! On input, the columns of A should be permuted so that the - ! etree is in a certain postorder. - TYPE(C_PTR), INTENT(inout) :: work - ! work (input/output) void*, size (lwork) (in bytes) - ! User-supplied work space and space for the output data structures. - ! Not referenced if lwork = 0; - INTEGER(C_INT), VALUE, INTENT(IN) :: lwork - ! lwork (input) int - ! Specifies the size of work array in bytes. - ! = 0: allocate space internally by system malloc; - ! > 0: use user-supplied work array of length lwork in bytes, - ! returns error if space runs out. - ! = -1: the routine guesses the amount of space needed without - ! performing the factorization, and returns it in - ! *info; no other side effects. - INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) - ! perm_c (input) int*, dimension (A->ncol) - ! Column permutation vector, which defines the - ! permutation matrix Pc; perm_c[i] = j means column i of A is - ! in position j in A*Pc. - ! When searching for diagonal, perm_c[*] is applied to the - ! row subscripts of A, so that diagonal threshold pivoting - ! can find the diagonal of A, rather than that of A*Pc. - INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) - ! perm_r (input/output) int*, dimension (A->nrow) - ! Row permutation vector which defines the permutation matrix Pr, - ! perm_r[i] = j means row i of A is in position j in Pr*A. - ! If options->Fact = SamePattern_SameRowPerm, the pivoting routine - ! will try to use the input perm_r, unless a certain threshold - ! criterion is violated. In that case, perm_r is overwritten by - ! a new permutation determined by partial pivoting or diagonal - ! threshold pivoting. - ! Otherwise, perm_r is output argument; - TYPE(SuperMatrix), INTENT(INOUT) :: L - ! L (output) SuperMatrix* - ! The factor L from the factorization Pr*A=L*U; use compressed row - ! subscripts storage for supernodes, i.e., L has type: - ! Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. - TYPE(SuperMatrix), INTENT(INOUT) :: U - ! U (output) SuperMatrix* - ! The factor U from the factorization Pr*A*Pc=L*U. Use column-wise - ! storage scheme, i.e., U has types: Stype = SLU_NC, - ! Dtype = SLU_D, Mtype = SLU_TRU. - TYPE(GlobalLU_t), INTENT(inout) :: Glu - ! Glu (input/output) GlobalLU_t * - ! If options->Fact == SamePattern_SameRowPerm, it is an input; - ! The matrix A will be factorized assuming that a - ! factorization of a matrix with the same sparsity pattern - ! and similar numerical values was performed prior to this one. - ! Therefore, this factorization will reuse both row and column - ! scaling factors R and C, both row and column permutation - ! vectors perm_r and perm_c, and the L & U data structures - ! set up from the previous factorization. - ! Otherwise, it is an output. - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - ! stat (output) SuperLUStat_t* - ! Record the statistics on runtime and floating-point operation count. - ! See slu_util.h for the definition of 'SuperLUStat_t'. - INTEGER(C_INT), INTENT(INOUT) :: info - ! info (output) int* - ! = 0: successful exit - ! < 0: if info = -i, the i-th argument had an illegal value - ! > 0: if info = i, and i is - ! <= A->ncol: number of zero pivots. They are replaced by small - ! entries according to options->ILU_FillTol. - ! > A->ncol: number of bytes allocated when memory allocation - ! failure occurred, plus A->ncol. If lwork = -1, it is - ! the estimated amount of space needed, plus A->ncol. - END SUBROUTINE dgstrf -END INTERFACE - -PUBLIC :: dgstrf - -END MODULE SuperLU_dgstrf_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 deleted file mode 100644 index f275be4de..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 +++ /dev/null @@ -1,101 +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 SuperLU_dgstrs_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Purpose -! ======= -! -! DGSTRS solves a system of linear equations A*X=B or A'*X=B -! with A sparse and B dense, using the LU factorization computed by -! DGSTRF. -! -! See supermatrix.h for the definition of 'SuperMatrix' structure. -! -! Arguments -! ========= -! -! trans (input) trans_t -! Specifies the form of the system of equations: -! = NOTRANS: A * X = B (No transpose) -! = TRANS: A'* X = B (Transpose) -! = CONJ: A**H * X = B (Conjugate transpose) -! -! L (input) SuperMatrix* -! The factor L from the factorization Pr*A*Pc=L*U as computed by -! dgstrf(). Use compressed row subscripts storage for supernodes, -! i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. -! -! U (input) SuperMatrix* -! The factor U from the factorization Pr*A*Pc=L*U as computed by -! dgstrf(). Use column-wise storage scheme, i.e., U has types: -! Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. -! -! perm_c (input) int*, dimension (L->ncol) -! Column permutation vector, which defines the -! permutation matrix Pc; perm_c[i] = j means column i of A is -! in position j in A*Pc. -! -! perm_r (input) int*, dimension (L->nrow) -! Row permutation vector, which defines the permutation matrix Pr; -! perm_r[i] = j means row i of A is in position j in Pr*A. -! -! B (input/output) SuperMatrix* -! B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. -! On entry, the right hand side matrix. -! On exit, the solution matrix if info = 0; -! -! stat (output) SuperLUStat_t* -! Record the statistics on runtime and floating-point operation count. -! See util.h for the definition of 'SuperLUStat_t'. -! -! info (output) int* -! = 0: successful exit -! < 0: if info = -i, the i-th argument had an illegal value -! -! void -! dgstrs (trans_t trans, SuperMatrix *L, SuperMatrix *U, -! int *perm_c, int *perm_r, SuperMatrix *B, -! SuperLUStat_t *stat, int *info) - -INTERFACE - SUBROUTINE dgstrs(trans, L, U, perm_c, perm_r, B, stat, info) & - & BIND(C, name="dgstrs") - IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & - & SuperMatrix - INTEGER(C_INT), VALUE, INTENT(IN) :: trans - TYPE(SuperMatrix), INTENT(INOUT) :: L - TYPE(SuperMatrix), INTENT(INOUT) :: U - INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) - INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) - TYPE(SuperMatrix), INTENT(INOUT) :: B - TYPE(SuperLUStat_t), INTENT(INOUT) :: stat - INTEGER(C_INT), INTENT(INOUT) :: info - END SUBROUTINE dgstrs -END INTERFACE - -PUBLIC :: dgstrs - -END MODULE SuperLU_dgstrs_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 deleted file mode 100644 index 578d170e0..000000000 --- a/src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 +++ /dev/null @@ -1,101 +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 SuperLU_dlaqgs_Methods -USE SuperLU_Types -USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE -PRIVATE - -! * Purpose -! * ======= -! * -! * DLAQGS equilibrates a general sparse M by N matrix A using the row and -! * scaling factors in the vectors R and C. -! * -! * See supermatrix.h for the definition of 'SuperMatrix' structure. -! * -! * Arguments -! * ========= -! * -! * A (input/output) SuperMatrix* -! * On exit, the equilibrated matrix. See EQUED for the form of -! * the equilibrated matrix. The type of A can be: -! * Stype = NC; Dtype = SLU_D; Mtype = GE. -! * -! * R (input) double*, dimension (A->nrow) -! * The row scale factors for A. -! * -! * C (input) double*, dimension (A->ncol) -! * The column scale factors for A. -! * -! * ROWCND (input) double -! * Ratio of the smallest R(i) to the largest R(i). -! * -! * COLCND (input) double -! * Ratio of the smallest C(i) to the largest C(i). -! * -! * AMAX (input) double -! * Absolute value of largest matrix entry. -! * -! * EQUED (output) char* -! * Specifies the form of equilibration that was done. -! * = 'N': No equilibration -! * = 'R': Row equilibration, i.e., A has been premultiplied by -! * diag(R). -! * = 'C': Column equilibration, i.e., A has been postmultiplied -! * by diag(C). -! * = 'B': Both row and column equilibration, i.e., A has been -! * replaced by diag(R) * A * diag(C). -! * -! * Internal Parameters -! * =================== -! * -! * THRESH is a threshold value used to decide if row or column scaling -! * should be done based on the ratio of the row or column scaling -! * factors. If ROWCND < THRESH, row scaling is done, and if -! * COLCND < THRESH, column scaling is done. -! * -! * LARGE and SMALL are threshold values used to decide if row scaling -! * should be done based on the absolute size of the largest matrix -! * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. -! * -! * ===================================================================== -! -! void -! dlaqgs(SuperMatrix *A, double *r, double *c, -! double rowcnd, double colcnd, double amax, char *equed) -! - -INTERFACE - SUBROUTINE dlaqgs(A, r, c, rowcnd, colcnd, amax, equed)& - & BIND(C, name="dlaqgs") - IMPORT :: SuperMatrix, C_DOUBLE, C_CHAR - - TYPE(SuperMatrix), INTENT(INOUT) :: A - REAL(C_DOUBLE), INTENT(INOUT) :: r(*) - REAL(C_DOUBLE), INTENT(INOUT) :: c(*) - REAL(C_DOUBLE), VALUE, INTENT(IN) :: rowcnd - REAL(C_DOUBLE), VALUE, INTENT(IN) :: colcnd - REAL(C_DOUBLE), VALUE, INTENT(IN) :: amax - CHARACTER(1, kind=C_CHAR), INTENT(INOUT) :: equed - END SUBROUTINE dlaqgs -END INTERFACE - -PUBLIC :: dlaqgs - -END MODULE SuperLU_dlaqgs_Methods diff --git a/src/modules/SuperLUInterface/src/include/macros.inc b/src/modules/SuperLUInterface/src/include/macros.inc deleted file mode 100644 index 20c770285..000000000 --- a/src/modules/SuperLUInterface/src/include/macros.inc +++ /dev/null @@ -1,18 +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 SUPERLU_CPTR_ONLY diff --git a/src/modules/System/CMakeLists.txt b/src/modules/System/CMakeLists.txt deleted file mode 100644 index 801f528f7..000000000 --- a/src/modules/System/CMakeLists.txt +++ /dev/null @@ -1,43 +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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources(${PROJECT_NAME} PRIVATE ${src_path}/System_Method.F90) - - -set(subproject_name "easifemSystem") - -add_library(${subproject_name} STATIC ${src_path}/System_Method.c) - -target_link_libraries(${PROJECT_NAME} PUBLIC ${subproject_name}) - -# target properties - -set_target_properties( - ${subproject_name} - PROPERTIES POSITION_INDEPENDENT_CODE 1 - SOVERSION ${VERSION_MAJOR} - # OUTPUT_NAME ${PROJECT_NAME} - LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - MACOSX_RPATH ON - WINDOWS_EXPORT_ALL_SYMBOLS ON - LINKER_LANGUAGE C) - - -list(APPEND C_PROJECTS ${subproject_name}) diff --git a/src/modules/System/src/System_Method.F90 b/src/modules/System/src/System_Method.F90 deleted file mode 100755 index a39ca633f..000000000 --- a/src/modules/System/src/System_Method.F90 +++ /dev/null @@ -1,5427 +0,0 @@ -! This program is a part of EASIFEM library. -! This program is directly taken from the -! source: https://github.com/urbanjost/M_system. -! The original name of the program has been changed -! from M_SYSTEM to System_Method. -! This is to confirm to the coding sytles of easifem. -! -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> -!##NAME -! M_system(3fm) - [M_system::INTRO] Fortran interface to C system interface -! (LICENSE:PD) -!##SYNOPSIS -! -! Public objects: -! -! ! ENVIRONMENT -! use M_system, only : set_environment_variable, system_unsetenv, & -! system_putenv, system_getenv -! -! use M_system, only : system_intenv, system_readenv, system_clearenv -! ! FILE SYSTEM -! use M_system, only : system_getcwd, system_link, & -! system_mkfifo, system_remove, system_rename, & -! system_umask, system_unlink, fileglob, & -! system_rmdir, system_chdir, system_mkdir, & -! system_stat, system_isdir, system_islnk, system_isreg, & -! system_isblk, system_ischr, system_isfifo, & -! system_realpath, & -! system_access, & -! system_utime, & -! system_issock, system_perm, & -! system_dir, & -! system_memcpy -! -! !!use M_system, only : system_getc, system_putc -! ! ERROR PROCESSING -! use M_system, only : system_errno, system_perror -! ! INFO -! use M_system, only : system_getegid, system_geteuid, system_getgid, & -! system_gethostname, system_getpid, system_getppid, system_setsid, & -! system_getsid, system_getuid, system_uname -! ! SIGNALS -! use M_system, only : system_kill,system_signal -! ! RANDOM NUMBERS -! use M_system, only : system_rand, system_srand -! ! PROCESS INFORMATION -! use M_system, only : system_cpu_time -! -!##DESCRIPTION -! M_system(3fm) is a collection of Fortran procedures that call C -! or a C wrapper using the ISO_C_BINDING interface to access system calls. -! System calls are a special set of functions used by programs to communicate -! directly with an operating system. -! -! Generally, system calls are slower than normal function calls because -! when you make a call control is relinquished to the operating system -! to perform the system call. In addition, depending on the nature of the -! system call, your program may be blocked by the OS until the system call -! has finished, thus making the execution time of your program even longer. -! -! One rule-of-thumb that should always be followed when calling a system -! call -- Always check the return value. -!##ENVIRONMENT ACCESS -! o system_putenv(3f): call putenv(3c) -! o system_getenv(3f): function call to get_environment_variable(3f) -! o system_unsetenv(3f): call unsetenv(3c) to remove variable from environment -! o set_environment_variable(3f): set environment variable by calling setenv(3c) -! -! o system_initenv(3f): initialize environment table for reading -! o system_readenv(3f): read next entry from environment table -! o system_clearenv(3f): emulate clearenv(3c) to clear environment -!##FILE SYSTEM -! o system_chdir(3f): call chdir(3c) to change current directory of a process -! o system_getcwd(3f): call getcwd(3c) to get pathname of current working directory -! -! o system_stat(3f): determine system information of file by name -! o system_perm(3f): create string representing file permission and type -! o system_access(3f): determine filename access or existence -! o system_isdir(3f): determine if filename is a directory -! o system_islnk(3f): determine if filename is a link -! o system_isreg(3f): determine if filename is a regular file -! o system_isblk(3f): determine if filename is a block device -! o system_ischr(3f): determine if filename is a character device -! o system_isfifo(3f): determine if filename is a fifo - named pipe -! o system_issock(3f): determine if filename is a socket -! o system_realpath(3f): resolve a pathname -! -! o system_chmod(3f): call chmod(3c) to set file permission mode -! o system_chown(3f): call chown(3c) to set file owner -! o system_getumask(3f): call umask(3c) to get process permission mask -! o system_setumask(3f): call umask(3c) to set process permission mask -! -! o system_mkdir(3f): call mkdir(3c) to create empty directory -! o system_mkfifo(3f): call mkfifo(3c) to create a special FIFO file -! o system_link(3f): call link(3c) to create a filename link -! -! o system_rename(3f): call rename(3c) to change filename -! -! o system_remove(3f): call remove(3c) to remove file -! o system_rmdir(3f): call rmdir(3c) to remove empty directory -! o system_unlink(3f): call unlink(3c) to remove a link to a file -! o system_utime(3f): call utime(3c) to set file access and modification times -! o system_dir(3f): read name of files in specified directory matching a wildcard string -! -! o fileglob(3f): Returns list of files using a file globbing pattern -! -!##STREAM IO -! o system_getc(3f): get a character from stdin -! o system_putc(3f): put a character on stdout -!##RANDOM NUMBERS -! o system_srand(3f): call srand(3c) -! o system_rand(3f): call rand(3c) -!##C ERROR INFORMATION -! o system_errno(3f): return errno(3c) -! o system_perror(3f): call perror(3c) to display last C error message -!##QUERIES -! o system_geteuid(3f): call geteuid(3c) -! o system_getuid(3f): call getuid(3c) -! o system_getegid(3f): call getegid(3c) -! o system_getgid(3f): call getgid(3c) -! o system_getpid(3f): call getpid(3c) -! o system_getppid(3f): call getppid(3c) -! o system_gethostname(3f): get name of current host -! o system_uname(3f): call my_uname(3c) which calls uname(3c) -! o system_getlogin(3f): get login name -! o system_getpwuid(3f): get login name associated with given UID -! o system_getgrgid(3f): get group name associated with given GID -! o system_cpu_time(3f) : get processor time in seconds using times(3c) -! -!##FUTURE DIRECTIONS -! A good idea of what system routines are commonly required is to refer -! to the POSIX binding standards. (Note: IEEE 1003.9-1992 was withdrawn 6 -! February 2003.) The IEEE standard covering Fortran 77 POSIX bindings -! is available online, though currently (unfortunately) only from -! locations with appropriate subscriptions to the IEEE server (e.g., -! many university networks). For those who do have such access, the link -! is: POSIX Fortran 77 Language Interfaces (IEEE Std 1003.9-1992) (pdf) -! -!##SEE ALSO -! Some vendors provide their own way to access POSIX functions and make -! those available as modules; for instance ... -! -! o the IFPORT module of Intel -! o or the f90_* modules of NAG. -! o There are also other compiler-independent efforts to make the -! POSIX procedures accessible from Fortran... -! -! o Posix90 (doc), -! o flib.a platform/files and directories, -! o fortranposix. - -MODULE System_Method -USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR -use,intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer, c_null_char, c_null_ptr -USE, INTRINSIC :: ISO_C_BINDING -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT8, INT16, INT32, INT64 -!!, real32, real64, real128, dp=>real128 - -IMPLICIT NONE -PRIVATE -! C types. Might be platform dependent -INTEGER, PARAMETER, PUBLIC :: mode_t = INT32 - -PUBLIC :: system_rand -PUBLIC :: system_srand - -!-!public :: system_getc -!-!public :: system_putc - -PUBLIC :: system_getpid ! return process ID -PUBLIC :: system_getppid ! return parent process ID -PUBLIC :: system_getuid, system_geteuid ! return user ID -PUBLIC :: system_getgid, system_getegid ! return group ID -PUBLIC :: system_setsid -PUBLIC :: system_getsid -PUBLIC :: system_kill ! (pid, signal) kill process (defaults: pid=0, signal=SIGTERM) -PUBLIC :: system_signal ! (signal,[handler]) install signal handler subroutine - -PUBLIC :: system_errno -PUBLIC :: system_perror - -PUBLIC :: system_putenv -PUBLIC :: system_getenv -PUBLIC :: set_environment_variable -PUBLIC :: system_unsetenv - -PUBLIC :: system_initenv -PUBLIC :: system_readenv -PUBLIC :: system_clearenv - -PUBLIC :: system_stat ! call stat(3c) to determine system information of file by name -PUBLIC :: system_perm ! create string representing file permission and type -PUBLIC :: system_access ! determine filename access or existence -PUBLIC :: system_isdir ! determine if filename is a directory -PUBLIC :: system_islnk ! determine if filename is a link -PUBLIC :: system_isreg ! determine if filename is a regular file -PUBLIC :: system_isblk ! determine if filename is a block device -PUBLIC :: system_ischr ! determine if filename is a character device -PUBLIC :: system_isfifo ! determine if filename is a fifo - named pipe -PUBLIC :: system_issock ! determine if filename is a socket -PUBLIC :: system_realpath ! resolve pathname - -PUBLIC :: system_chdir -PUBLIC :: system_rmdir -PUBLIC :: system_remove -PUBLIC :: system_rename - -PUBLIC :: system_mkdir -PUBLIC :: system_mkfifo -PUBLIC :: system_chmod -PUBLIC :: system_chown -PUBLIC :: system_link -PUBLIC :: system_unlink -PUBLIC :: system_utime - -PUBLIC :: system_setumask -PUBLIC :: system_getumask -PUBLIC :: system_umask - -PUBLIC :: system_getcwd - -PUBLIC :: system_opendir -PUBLIC :: system_readdir -PUBLIC :: system_rewinddir -PUBLIC :: system_closedir - -PUBLIC :: system_cpu_time - -PUBLIC :: system_uname -PUBLIC :: system_gethostname -PUBLIC :: system_getlogin -PUBLIC :: system_getpwuid -PUBLIC :: system_getgrgid -PUBLIC :: fileglob - -PUBLIC :: system_alarm -PUBLIC :: system_calloc -PUBLIC :: system_clock -PUBLIC :: system_time -!public :: system_time -!public :: system_qsort - -PUBLIC :: system_realloc -PUBLIC :: system_malloc -PUBLIC :: system_free -PUBLIC :: system_memcpy - -PUBLIC :: system_dir - -public :: R_GRP,R_OTH,R_USR,RWX_G,RWX_O,RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR,DEFFILEMODE,ACCESSPERMS -PUBLIC :: R_OK, W_OK, X_OK, F_OK ! for system_access - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: dirent_SYSTEMA - INTEGER(C_LONG) :: d_ino - INTEGER(C_LONG) :: d_off; ! __off_t, check size - INTEGER(C_SHORT) :: d_reclen - CHARACTER(len=1, kind=C_CHAR) :: d_name(256) -END TYPE - -TYPE, BIND(C) :: dirent_CYGWIN - INTEGER(C_INT) :: d_version - INTEGER(C_LONG) :: d_ino - CHARACTER(kind=C_CHAR) :: d_type - CHARACTER(kind=C_CHAR) :: d_unused1(3) - INTEGER(C_INT) :: d_internal1 - CHARACTER(len=1, kind=C_CHAR) :: d_name(256) -END TYPE - -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_alarm(seconds) BIND(c, name="alarm") - IMPORT C_INT - INTEGER(kind=C_INT), VALUE :: seconds - INTEGER(kind=C_INT) system_alarm - END FUNCTION system_alarm -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_calloc(nelem, elsize) BIND(c, name="calloc") - IMPORT C_SIZE_T, C_INTPTR_T - INTEGER(C_SIZE_T), VALUE :: nelem, elsize - INTEGER(C_INTPTR_T) system_calloc - END FUNCTION system_calloc -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - PURE FUNCTION SYSTEM_CLOCK() BIND(c, name="clock") - IMPORT C_LONG - INTEGER(C_LONG) system_clock - END FUNCTION system_clock -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. -! extern void *memcpy (void *dest, const void *src, size_t n); -INTERFACE - SUBROUTINE system_memcpy(dest, src, n) BIND(C, name='memcpy') - IMPORT C_INTPTR_T, C_SIZE_T - INTEGER(C_INTPTR_T), VALUE :: dest - INTEGER(C_INTPTR_T), VALUE :: src - INTEGER(C_SIZE_T), VALUE :: n - END SUBROUTINE system_memcpy -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - SUBROUTINE system_free(ptr) BIND(c, name="free") - IMPORT C_INTPTR_T - INTEGER(C_INTPTR_T), VALUE :: ptr - END SUBROUTINE system_free -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_malloc(size) BIND(c, name="malloc") - IMPORT C_SIZE_T, C_INTPTR_T - INTEGER(C_SIZE_T), VALUE :: size - INTEGER(C_INTPTR_T) system_malloc - END FUNCTION system_malloc -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_realloc(ptr, size) BIND(c, name="realloc") - IMPORT C_SIZE_T, C_INTPTR_T - INTEGER(C_INTPTR_T), VALUE :: ptr - INTEGER(C_SIZE_T), VALUE :: size - INTEGER(C_INTPTR_T) system_realloc - END FUNCTION system_realloc -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_time(tloc) BIND(c, name="time") - ! tloc argument should be loaded via C_LOC from iso_c_binding - IMPORT C_PTR, C_LONG - TYPE(C_PTR), VALUE :: tloc - INTEGER(C_LONG) system_time - END FUNCTION system_time -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! abstract interface -! integer(4) function compar_iface(a, b) -! import c_int -! integer, intent(in) :: a, b -!-! Until implement TYPE(*) -! integer(kind=c_int) :: compar_iface -! end function compar_iface -! end interface -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! interface -! subroutine system_qsort(base, nel, width, compar) bind(c, name="qsort") -! import C_SIZE_T, compar_iface -! integer :: base -!-! Until implement TYPE(*) -! integer(C_SIZE_T), value :: nel, width -! procedure(compar_iface) compar -! end subroutine system_qsort -! end interface -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_srand(3f) - [M_system:PSEUDORANDOM] set seed for pseudo-random number generator system_rand(3f) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_srand() -!! -!!##DESCRIPTION -!! system_srand(3f) calls the C routine srand(3c) The -!! srand(3c)/system_srand(3f) function uses its argument as the seed -!! for a new sequence of pseudo-random integers to be returned by -!! system_rand(3f)/rand(3c). These sequences are repeatable by calling -!! system_srand(3f) with the same seed value. If no seed value is -!! provided, the system_rand(3f) function is automatically seeded with -!! a value of 1. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_srand -!! use M_system, only : system_srand, system_rand -!! implicit none -!! integer :: i,j -!! do j=1,2 -!! call system_srand(1001) -!! do i=1,10 -!! write(*,*)system_rand() -!! enddo -!! write(*,*) -!! enddo -!! end program demo_system_srand -!! expected results: -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -!! -!!##SEE ALSO -!! drand48(3c), random(3c) -! void srand_system(int *seed) -INTERFACE - SUBROUTINE system_srand(seed) BIND(c, name='srand') - IMPORT C_INT - INTEGER(kind=C_INT), INTENT(in) :: seed - END SUBROUTINE system_srand -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_kill(3f) - [M_system:SIGNALS] send a signal to a process or a group of processes -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_kill(pid,sig) -!! -!! integer,intent(in) :: pid -!! integer,intent(in) :: sig -!! -!!##DESCRIPTION -!! -!! The kill() function shall send a signal to a process or a group of -!! processes specified by pid. The signal to be sent is specified by sig -!! and is either one from the list given in or 0. If sig is 0 -!! (the null signal), error checking is performed but no signal is actually -!! sent. The null signal can be used to check the validity of pid. -!! -!! For a process to have permission to send a signal to a process designated -!! by pid, unless the sending process has appropriate privileges, the real -!! or effective user ID of the sending process shall match the real or -!! saved set-user-ID of the receiving process. -!! -!! If pid is greater than 0, sig shall be sent to the process whose process -!! ID is equal to pid. -!! -!! If pid is 0, sig shall be sent to all processes (excluding an unspecified -!! set of system processes) whose process group ID is equal to the process -!! group ID of the sender, and for which the process has permission to send -!! a signal. -!! -!! If pid is -1, sig shall be sent to all processes (excluding an unspecified -!! set of system processes) for which the process has permission to send -!! that signal. -!! -!! If pid is negative, but not -1, sig shall be sent to all processes -!! (excluding an unspecified set of system processes) whose process group -!! ID is equal to the absolute value of pid, and for which the process has -!! permission to send a signal. -!! -!! If the value of pid causes sig to be generated for the sending process, -!! and if sig is not blocked for the calling thread and if no other thread -!! has sig unblocked or is waiting in a sigwait() function for sig, either -!! sig or at least one pending unblocked signal shall be delivered to the -!! sending thread before kill() returns. -!! -!! The user ID tests described above shall not be applied when sending -!! SIGCONT to a process that is a member of the same session as the sending -!! process. -!! -!! An implementation that provides extended security controls may impose -!! further implementation-defined restrictions on the sending of signals, -!! including the null signal. In particular, the system may deny the -!! existence of some or all of the processes specified by pid. -!! -!! The kill() function is successful if the process has permission to send -!! sig to any of the processes specified by pid. If kill() fails, no signal -!! shall be sent. -!! -!! -!!##RETURN VALUE -!! -!! Upon successful completion, 0 shall be returned. Otherwise, -1 shall be -!! returned and errno set to indicate the error. -!! -!!##ERRORS -!! The kill() function shall fail if: -!! -!! EINVAL The value of the sig argument is an invalid or unsupported -!! signal number. -!! EPERM The process does not have permission to send the signal to -!! any receiving process. -!! ESRCH No process or process group can be found corresponding to -!! that specified by pid. The following sections are informative. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_kill -!! use M_system, only : system_kill -!! use M_system, only : system_perror -!! implicit none -!! integer :: i,pid,ios,ierr,signal=9 -!! character(len=80) :: argument -!! -!! do i=1,command_argument_count() -!! ! get arguments from command line -!! call get_command_argument(i, argument) -!! ! convert arguments to integers assuming they are PID numbers -!! read(argument,'(i80)',iostat=ios) pid -!! if(ios.ne.0)then -!! write(*,*)'bad PID=',trim(argument) -!! else -!! write(*,*)'kill SIGNAL=',signal,' PID=',pid -!! ! send signal SIGNAL to pid PID -!! ierr=system_kill(pid,signal) -!! ! write message if an error was detected -!! if(ierr.ne.0)then -!! call system_perror('*demo_system_kill*') -!! endif -!! endif -!! enddo -!! end program demo_system_kill -!! -!!##SEE ALSO -!! getpid(), raise(), setsid(), sigaction(), sigqueue(), - -! int kill(pid_t pid, int sig); -INTERFACE - FUNCTION system_kill(c_pid, c_signal) BIND(c, name="kill") RESULT(c_ierr) - IMPORT C_INT - INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_pid - INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_signal - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_errno(3f) - [M_system:ERROR_PROCESSING] C error return value -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_errno() -!! -!!##DESCRIPTION -!! Many C routines return an error code which can be queried by errno. -!! The M_system(3fm) is primarily composed of Fortran routines that call -!! C routines. In the cases where an error code is returned vi system_errno(3f) -!! these routines will indicate it. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_errno -!! use M_system, only : system_errno, system_unlink, system_perror -!! implicit none -!! integer :: stat -!! stat=system_unlink('not there/OR/anywhere') -!! if(stat.ne.0)then -!! write(*,*)'err=',system_errno() -!! call system_perror('*demo_system_errno*') -!! endif -!! end program demo_system_errno -!! -!! Typical Results: -!! -!! err= 2 -!! *demo_system_errno*: No such file or directory - -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_errno() BIND(C, name="my_errno") - IMPORT C_INT - END FUNCTION system_errno -END INTERFACE -!-! if a macro on XLF -!-! interface system_errno -!-! function ierrno_() bind(c, name="ierrno_") -!-! import c_int -!-! integer(kind=c_int) :: ierrno_ -!-! end function system_errno -!-! end interface -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_geteuid(3f) - [M_system:QUERY] get effective UID of current process from Fortran by calling geteuid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_geteuid() -!! -!!##DESCRIPTION -!! The system_geteuid(3f) function shall return the effective user -!! ID of the calling process. The geteuid() function shall always be -!! successful and no return value is reserved to indicate the error. -!!##EXAMPLE -!! -!! Get group ID from Fortran: -!! -!! program demo_system_geteuid -!! use M_system, only : system_geteuid -!! implicit none -!! write(*,*)'EFFECTIVE UID=',system_geteuid() -!! end program demo_system_geteuid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_geteuid() BIND(C, name="geteuid") - IMPORT C_INT - END FUNCTION system_geteuid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getuid(3f) - [M_system:QUERY] get real UID of current process from Fortran by calling getuid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getuid() -!! -!!##DESCRIPTION -!! The system_getuid(3f) function shall return the real user ID -!! of the calling process. The getuid() function shall always be -!! successful and no return value is reserved to indicate the error. -!!##EXAMPLE -!! -!! Get group ID from Fortran: -!! -!! program demo_system_getuid -!! use M_system, only : system_getuid -!! implicit none -!! write(*,*)'UID=',system_getuid() -!! end program demo_system_getuid -!! -!! Results: -!! -!! UID= 197609 -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getuid() BIND(C, name="getuid") - IMPORT C_INT - END FUNCTION system_getuid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getegid(3f) - [M_system:QUERY] get the effective group ID (GID) of current process from Fortran by calling getegid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getegid() -!!##DESCRIPTION -!! The getegid() function returns the effective group ID of the -!! calling process. -!! -!!##RETURN VALUE -!! The getegid() should always be successful and no return value is -!! reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(), -!! setregid(), setreuid(), setuid() -!! -!!##EXAMPLE -!! -!! Get group ID from Fortran -!! -!! program demo_system_getegid -!! use M_system, only : system_getegid -!! implicit none -!! write(*,*)'GID=',system_getegid() -!! end program demo_system_getegid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getegid() BIND(C, name="getegid") - IMPORT C_INT - END FUNCTION system_getegid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getgid(3f) - [M_system:QUERY] get the real group ID (GID) of current process from Fortran by calling getgid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getgid() -!!##DESCRIPTION -!! The getgid() function returns the real group ID of the calling process. -!! -!!##RETURN VALUE -!! The getgid() should always be successful and no return value is -!! reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(), -!! setregid(), setreuid(), setuid() -!! -!!##EXAMPLE -!! -!! Get group ID from Fortran -!! -!! program demo_system_getgid -!! use M_system, only : system_getgid -!! implicit none -!! write(*,*)'GID=',system_getgid() -!! end program demo_system_getgid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getgid() BIND(C, name="getgid") - IMPORT C_INT - END FUNCTION system_getgid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_setsid(3f) - [M_system:QUERY] create session and set the process group ID of a session leader -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_setsid(pid) -!! integer(kind=c_int) :: pid -!!##DESCRIPTION -!! The setsid() function creates a new session, if the calling process is not a process group leader. Upon return the -!! calling process shall be the session leader of this new session, shall be the process group leader of a new process -!! group, and shall have no controlling terminal. The process group ID of the calling process shall be set equal to the -!! process ID of the calling process. The calling process shall be the only process in the new process group and the only -!! process in the new session. -!! -!!##RETURN VALUE -!! Upon successful completion, setsid() shall return the value of the new process group ID of the calling process. Otherwise, -!! it shall return �-1 and set errno to indicate the error. -!!##ERRORS -!! The setsid() function shall fail if: -!! -!! o The calling process is already a process group leader -!! o the process group ID of a process other than the calling process matches the process ID of the calling process. -!!##EXAMPLE -!! -!! Set SID from Fortran -!! -!! program demo_system_setsid -!! use M_system, only : system_setsid -!! implicit none -!! write(*,*)'SID=',system_setsid() -!! end program demo_system_setsid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_setsid() BIND(C, name="setsid") - IMPORT C_INT - END FUNCTION system_setsid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getsid(3f) - [M_system:QUERY] get the process group ID of a session leader -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getsid(pid) -!! integer(kind=c_int) :: pid -!!##DESCRIPTION -!! The system_getsid() function obtains the process group ID of the -!! process that is the session leader of the process specified by pid. -!! If pid is 0, it specifies the calling process. -!!##RETURN VALUE -!! Upon successful completion, system_getsid() shall return the process group -!! ID of the session leader of the specified process. Otherwise, -!! it shall return -1 and set errno to indicate the error. -!!##EXAMPLE -!! -!! Get SID from Fortran -!! -!! program demo_system_getsid -!! use M_system, only : system_getsid -!! use ISO_C_BINDING, only : c_int -!! implicit none -!! write(*,*)'SID=',system_getsid(0_c_int) -!! end program demo_system_getsid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getsid(c_pid) BIND(C, name="getsid") - IMPORT C_INT - INTEGER(kind=C_INT) :: c_pid - END FUNCTION system_getsid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getpid(3f) - [M_system:QUERY] get PID (process ID) of current process from Fortran by calling getpid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer function system_getpid() -!!##DESCRIPTION -!! The system_getpid() function returns the process ID of the -!! calling process. -!!##RETURN VALUE -!! The value returned is the integer process ID. The system_getpid() -!! function shall always be successful and no return value is reserved -!! to indicate an error. -!!##EXAMPLE -!! -!! Get process PID from Fortran -!! -!! program demo_system_getpid -!! use M_system, only : system_getpid -!! implicit none -!! write(*,*)'PID=',system_getpid() -!! end program demo_system_getpid - -INTERFACE - PURE INTEGER(kind=C_INT) FUNCTION system_getpid() BIND(C, name="getpid") - IMPORT C_INT - END FUNCTION system_getpid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getppid(3f) - [M_system:QUERY] get parent process ID (PPID) of current process from Fortran by calling getppid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getppid() -!!##DESCRIPTION -!! The system_getppid() function returns the parent process ID of -!! the calling process. -!! -!!##RETURN VALUE -!! The system_getppid() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! exec, fork(), getpgid(), getpgrp(), getpid(), kill(), -!! setpgid(), setsid() -!! -!!##EXAMPLE -!! -!! Get parent process PID (PPID) from Fortran -!! -!! program demo_system_getppid -!! use M_system, only : system_getppid -!! implicit none -!! write(*,*)'PPID=',system_getppid() -!! end program demo_system_getppid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getppid() BIND(C, name="getppid") - IMPORT C_INT - END FUNCTION system_getppid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_umask(3fp) - [M_system] set and get the file mode creation mask -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_umask(umask_value) -!! -!!##DESCRIPTION -!! The system_umask() function shall set the file mode creation mask of the -!! process to cmask and return the previous value of the mask. Only -!! the file permission bits of cmask (see ) are used; -!! the meaning of the other bits is implementation-defined. -!! -!! The file mode creation mask of the process is used to turn off -!! permission bits in the mode argument supplied during calls to -!! the following functions: -!! -!! * open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat() -!! * mknod(), mknodat() -!! * mq_open() -!! * sem_open() -!! -!! Bit positions that are set in cmask are cleared in the mode of the created file. -!! -!!##RETURN VALUE -!! The file permission bits in the value returned by umask() shall be -!! the previous value of the file mode creation mask. The state of any -!! other bits in that value is unspecified, except that a subsequent -!! call to umask() with the returned value as cmask shall leave the -!! state of the mask the same as its state before the first call, -!! including any unspecified use of those bits. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_umask -!! use M_system, only : system_getumask, system_setumask -!! implicit none -!! integer value -!! integer mask -!! mask=O'002' -!! value=system_setumask(mask) -!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'OLD VALUE=',value,value -!! value=system_getumask() -!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'MASK=',mask,mask -!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'NEW VALUE=',value,value -!! end program demo_system_umask -!! -!! Expected results: -!! -!! OLD VALUE=octal=0022 decimal=18 -!! MASK=octal=0002 decimal=2 -!! NEW VALUE=octal=0002 decimal=2 -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_umask(umask_value) BIND(C, name="umask") - IMPORT C_INT - INTEGER(kind=C_INT), VALUE :: umask_value - END FUNCTION system_umask -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_rand(3f) - [M_system:PSEUDORANDOM] call pseudo-random number generator rand(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) :: function system_rand() -!!##DESCRIPTION -!! Use rand(3c) to generate pseudo-random numbers. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rand -!! use M_system, only : system_srand, system_rand -!! implicit none -!! integer :: i -!! -!! call system_srand(1001) -!! do i=1,10 -!! write(*,*)system_rand() -!! enddo -!! write(*,*) -!! -!! end program demo_system_rand -!! expected results: -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_rand() BIND(C, name="rand") - IMPORT C_INT - END FUNCTION system_rand -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - SUBROUTINE c_flush() BIND(C, name="my_flush") - END SUBROUTINE c_flush -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_initenv(3f) - [M_system:ENVIRONMENT] initialize environment table pointer and size so table can be read by readenv(3f) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_initenv() -!!##DESCRIPTION -!! A simple interface allows reading the environment variable table -!! of the process. Call system_initenv(3f) to initialize reading the -!! environment table, then call system_readenv(3f) until a blank line -!! is returned. If more than one thread reads the environment or the -!! environment is changed while being read the results are undefined. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_initenv -!! use M_system, only : system_initenv, system_readenv -!! character(len=:),allocatable :: string -!! call system_initenv() -!! do -!! string=system_readenv() -!! if(string.eq.'')then -!! exit -!! else -!! write(*,'(a)')string -!! endif -!! enddo -!! end program demo_system_initenv -!! -!! Sample results: -!! -!! USERDOMAIN_ROAMINGPROFILE=buzz -!! HOMEPATH=\Users\JSU -!! APPDATA=C:\Users\JSU\AppData\Roaming -!! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man::: -!! DISPLAYNUM=0 -!! ProgramW6432=C:\Program Files -!! HOSTNAME=buzz -!! XKEYSYMDB=/usr/share/X11/XKeysymDB -!! PUBLISH_CMD= -!! OnlineServices=Online Services -!! : -!! : -!! : - -integer(kind=c_long),bind(c,name="longest_env_variable") :: longest_env_variable - -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - SUBROUTINE system_initenv() BIND(C, NAME='my_initenv') - END SUBROUTINE system_initenv -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!-!type(c_ptr),bind(c,name="environ") :: c_environ - -INTEGER(kind=mode_t), BIND(c, name="FS_IRGRP") :: R_GRP -INTEGER(kind=mode_t), BIND(c, name="FS_IROTH") :: R_OTH -INTEGER(kind=mode_t), BIND(c, name="FS_IRUSR") :: R_USR -INTEGER(kind=mode_t), BIND(c, name="FS_IRWXG") :: RWX_G -INTEGER(kind=mode_t), BIND(c, name="FS_IRWXO") :: RWX_O -INTEGER(kind=mode_t), BIND(c, name="FS_IRWXU") :: RWX_U -INTEGER(kind=mode_t), BIND(c, name="FS_IWGRP") :: W_GRP -INTEGER(kind=mode_t), BIND(c, name="FS_IWOTH") :: W_OTH -INTEGER(kind=mode_t), BIND(c, name="FS_IWUSR") :: W_USR -INTEGER(kind=mode_t), BIND(c, name="FS_IXGRP") :: X_GRP -INTEGER(kind=mode_t), BIND(c, name="FS_IXOTH") :: X_OTH -INTEGER(kind=mode_t), BIND(c, name="FS_IXUSR") :: X_USR -INTEGER(kind=mode_t), BIND(c, name="FDEFFILEMODE") :: DEFFILEMODE -INTEGER(kind=mode_t), BIND(c, name="FACCESSPERMS") :: ACCESSPERMS - -! Host names are limited to {HOST_NAME_MAX} bytes. -INTEGER(kind=mode_t), BIND(c, name="FHOST_NAME_MAX") :: HOST_NAME_MAX -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! for system_access(3f) -!integer(kind=c_int),bind(c,name="F_OK") :: F_OK -!integer(kind=c_int),bind(c,name="R_OK") :: R_OK -!integer(kind=c_int),bind(c,name="W_OK") :: W_OK -!integer(kind=c_int),bind(c,name="X_OK") :: X_OK -! not sure these will be the same on all systems, but above did not work -INTEGER(kind=C_INT), PARAMETER :: F_OK = 0 -INTEGER(kind=C_INT), PARAMETER :: R_OK = 4 -INTEGER(kind=C_INT), PARAMETER :: W_OK = 2 -INTEGER(kind=C_INT), PARAMETER :: X_OK = 1 -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -ABSTRACT INTERFACE ! mold for signal handler to be installed by system_signal - SUBROUTINE handler(signum) - INTEGER :: signum - END SUBROUTINE handler -END INTERFACE -TYPE handler_pointer - PROCEDURE(handler), POINTER, NOPASS :: sub -END TYPE handler_pointer -INTEGER, PARAMETER :: no_of_signals = 64 ! obtained with command: kill -l -TYPE(handler_pointer), DIMENSION(no_of_signals) :: handler_ptr_array -!=================================================================================================================================== -CONTAINS -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_signal(3f) - [M_system:SIGNALS] install a signal handler -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_signal(sig,handler) -!! -!! integer,intent(in) :: sig -!! interface -!! subroutine handler(signum) -!! integer :: signum -!! end subroutine handler -!! end interface -!! optional :: handler -!! -!!##DESCRIPTION -!! Calling system_signal(NUMBER, HANDLER) causes user-defined -!! subroutine HANDLER to be executed when the signal NUMBER is -!! caught. The same subroutine HANDLER maybe installed to handle -!! different signals. HANDLER takes only one integer argument which -!! is assigned the signal number that is caught. See sample program -!! below for illustration. -!! -!! Calling system_signal(NUMBER) installs a do-nothing handler. This -!! is not equivalent to ignoring the signal NUMBER though, because -!! the signal can still interrupt any sleep or idle-wait. -!! -!! Note that the signals SIGKILL and SIGSTOP cannot be handled -!! this way. -!! -!! [Compare signal(2) and the GNU extension signal in gfortran.] -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_signal -!! use M_system, only : system_signal -!! implicit none -!! logical :: loop=.true. -!! integer, parameter :: SIGINT=2,SIGQUIT=3 -!! call system_signal(SIGINT,exitloop) -!! call system_signal(SIGQUIT,quit) -!! write(*,*)'Starting infinite loop. Press Ctrl+C to exit.' -!! do while(loop) -!! enddo -!! write(*,*)'Reporting from outside the infinite loop.' -!! write(*,*)'Starting another loop. Do Ctrl+\ anytime to quit.' -!! loop=.true. -!! call system_signal(2) -!! write(*,*)'Just installed do-nothing handler for SIGINT. Try Ctrl+C to test.' -!! do while(loop) -!! enddo -!! write(*,*)'You should never see this line when running this demo.' -!! -!! contains -!! -!! subroutine exitloop(signum) -!! integer :: signum -!! write(*,*)'Caught SIGINT. Exiting infinite loop.' -!! loop=.false. -!! end subroutine exitloop -!! -!! subroutine quit(signum) -!! integer :: signum -!! STOP 'Caught SIGQUIT. Stopping demo.' -!! end subroutine quit -!! end program demo_system_signal -!! -!!##AUTHOR -!! Somajit Dey -!! -!!##LICENSE -!! Public Domain -SUBROUTINE system_signal(signum, handler_routine) - INTEGER, INTENT(in) :: signum - PROCEDURE(handler), OPTIONAL :: handler_routine - TYPE(C_FUNPTR) :: ret, c_handler - - INTERFACE - FUNCTION c_signal(signal, sighandler) BIND(c, name='signal') - IMPORT :: C_INT, C_FUNPTR - INTEGER(C_INT), VALUE, INTENT(in) :: signal - TYPE(C_FUNPTR), VALUE, INTENT(in) :: sighandler - TYPE(C_FUNPTR) :: c_signal - END FUNCTION c_signal - END INTERFACE - - IF (PRESENT(handler_routine)) THEN - handler_ptr_array(signum)%sub => handler_routine - ELSE - !!handler_ptr_array(signum)%sub => null(handler_ptr_array(signum)%sub) - handler_ptr_array(signum)%sub => NULL() - END IF - c_handler = C_FUNLOC(f_handler) - ret = c_signal(signum, c_handler) -END SUBROUTINE system_signal - -SUBROUTINE f_handler(signum) BIND(c) - INTEGER(C_INT), INTENT(in), VALUE :: signum - if(associated(handler_ptr_array(signum)%sub))call handler_ptr_array(signum)%sub(signum) -END SUBROUTINE f_handler -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_access(3f) - [M_system:QUERY_FILE] checks accessibility or existence of a pathname -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_access(pathname,amode) -!! -!! character(len=*),intent(in) :: pathname -!! integer,intent(in) :: amode -!! -!!##DESCRIPTION -!! -!! The system_access(3f) function checks pathname existence and access -!! permissions. The function checks the pathname for accessibility -!! according to the bit pattern contained in amode, using the real user -!! ID in place of the effective user ID and the real group ID in place -!! of the effective group ID. -!! -!! The value of amode is either the bitwise-inclusive OR of the access -!! permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). -!! -!!##OPTIONS -!! pathname a character string representing a directory pathname. Trailing spaces are ignored. -!! amode bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. -!! -!!##RETURN VALUE -!! If not true an error occurred or the requested access is not granted -!! -!!##EXAMPLE -!! -!! check if filename is accessible -!! -!! Sample program: -!! -!! program demo_system_access -!! use M_system, only : system_access, F_OK, R_OK, W_OK, X_OK -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/usr/bin/bash ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' does ',trim(names(i)),' exist? ', system_access(names(i),F_OK) -!! write(*,*)' is ',trim(names(i)),' readable? ', system_access(names(i),R_OK) -!! write(*,*)' is ',trim(names(i)),' writable? ', system_access(names(i),W_OK) -!! write(*,*)' is ',trim(names(i)),' executable? ', system_access(names(i),X_OK) -!! enddo -!! end program demo_system_access -ELEMENTAL impure FUNCTION system_access(pathname, amode) - IMPLICIT NONE - -! ident_1="@(#)M_system::system_access(3f): checks accessibility or existence of a pathname" - - CHARACTER(len=*), INTENT(in) :: pathname - INTEGER, INTENT(in) :: amode - LOGICAL :: system_access - - INTERFACE - function c_access(c_pathname,c_amode) bind (C,name="my_access") result (c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) - INTEGER(kind=C_INT), VALUE :: c_amode - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_access - END INTERFACE - - IF (c_access(str2_carr(TRIM(pathname)), INT(amode, kind=C_INT)) .EQ. 0) THEN - system_access = .TRUE. - ELSE - system_access = .FALSE. - !!if(system_errno().ne.0)then - !! call perror('*system_access*') - !!endif - END IF - -END FUNCTION system_access -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_utime(3f) - [M_system:FILE_SYSTEM] set file access and modification times -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function utime(pathname,times) -!! -!! character(len=*),intent(in) :: pathname -!! integer,intent(in),optional :: times(2) -!! logical :: utime -!! -!!##DESCRIPTION -!! The system_utime(3f) function sets the access and modification -!! times of the file named by the path argument by calling utime(3c). -!! -!! If times() is not present the access and modification times of -!! the file shall be set to the current time. -!! -!! To use system_utime(3f) the effective user ID of the process must -!! match the owner of the file, or the process has to have write -!! permission to the file or have appropriate privileges, -!! -!!##OPTIONS -!! times If present, the values will be interpreted as the access -!! and modification times as Unix Epoch values. That is, -!! they are times measured in seconds since the Unix Epoch. -!! -!! pathname name of the file whose access and modification times -!! are to be updated. -!! -!!##RETURN VALUE -!! Upon successful completion .TRUE. is returned. Otherwise, -!! .FALSE. is returned and errno shall be set to indicate the error, -!! and the file times remain unaffected. -!! -!!##ERRORS -!! The underlying utime(3c) function fails if: -!! -!! EACCES Search permission is denied by a component of the path -!! prefix; or the times argument is a null pointer and the -!! effective user ID of the process does not match the owner -!! of the file, the process does not have write permission -!! for the file, and the process does not have appropriate -!! privileges. -!! -!! ELOOP A loop exists in symbolic links encountered during -!! resolution of the path argument. -!! -!! ENAMETOOLONG The length of a component of a pathname is longer -!! than {NAME_MAX}. -!! -!! ENOENT A component of path does not name an existing file -!! or path is an empty string. -!! -!! ENOTDIR A component of the path prefix names an existing file -!! that is neither a directory nor a symbolic link to a -!! directory, or the path argument contains at least one -!! non- character and ends with one or more trailing -!! characters and the last pathname component -!! names an existing file that is neither a directory nor -!! a symbolic link to a directory. -!! -!! EPERM The times argument is not a null pointer and the effective -!! user ID of the calling process does not match the owner -!! of the file and the calling process does not have -!! appropriate privileges. -!! -!! EROFS The file system containing the file is read-only. -!! -!! The utime() function may fail if: -!! -!! ELOOP More than {SYMLOOP_MAX} symbolic links were encountered -!! during resolution of the path argument. -!! -!! ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, or -!! pathname resolution of a symbolic link produced -!! an intermediate result with a length that exceeds -!! {PATH_MAX}. -!! -!!##EXAMPLES -!! -!! Sample program -!! -!! program demo_system_utime -!! use M_system, only : system_utime, system_perror -!! implicit none -!! character(len=4096) :: pathname -!! integer :: times(2) -!! integer :: i -!! do i=1,command_argument_count() -!! call get_command_argument(i, pathname) -!! if(.not.system_utime(pathname,times))then -!! call system_perror('*demo_system_utime*') -!! endif -!! enddo -!! end program demo_system_utime -FUNCTION system_utime(pathname, times) - IMPLICIT NONE - -! ident_2="@(#)M_system::system_utime(3f): set access and modification times of a pathname" - - CHARACTER(len=*), INTENT(in) :: pathname - INTEGER, INTENT(in), OPTIONAL :: times(2) - INTEGER :: times_local(2) - LOGICAL :: system_utime - -!-! int my_utime(const char *path, int times[2]) - INTERFACE - FUNCTION c_utime(c_pathname, c_times) BIND(C, name="my_utime") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) - INTEGER(kind=C_INT), INTENT(in) :: c_times(2) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_utime - END INTERFACE - IF (PRESENT(times)) THEN - times_local = times - ELSE - times_local = timestamp() - END IF - if(c_utime(str2_carr(trim(pathname)),int(times_local,kind=c_int)).eq.0)then - system_utime = .TRUE. - ELSE - system_utime = .FALSE. - !!if(system_errno().ne.0)then - !! call perror('*system_utime*') - !!endif - END IF - -END FUNCTION system_utime -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -FUNCTION timestamp() RESULT(epoch) - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_LONG - IMPLICIT NONE - INTEGER(kind=8) :: epoch - INTERFACE - ! time_t time(time_t *tloc) - FUNCTION c_time(tloc) BIND(c, name='time') - IMPORT :: C_LONG - INTEGER(kind=C_LONG), INTENT(in), VALUE :: tloc - INTEGER(kind=C_LONG) :: c_time - END FUNCTION c_time - END INTERFACE - epoch = c_time(INT(0, kind=8)) -END FUNCTION timestamp -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_realpath(3f) - [M_system:FILE_SYSTEM] call realpath(3c) to resolve a pathname -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_realpath(input) result(output) -!! -!! character(len=*),intent(in) :: input -!! character(len=:),allocatable :: output -!!##DESCRIPTION -!! system_realpath(3f) calls the C routine realpath(3c) to obtain the absolute pathname of given path -!!##OPTIONS -!! -!! INPUT pathname to resolve -!! -!!##RETURN VALUE -!! OUTPUT The absolute pathname of the given input pathname. -!! The pathname shall contain no components that are dot -!! or dot-dot, or are symbolic links. It is equal to the -!! NULL character if an error occurred. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_realpath -!! use M_system, only : system_realpath, system_perror -!! implicit none -!! ! resolve each pathname given on command line -!! character(len=:),allocatable :: pathi,patho -!! integer :: i -!! integer :: filename_length -!! do i = 1, command_argument_count() -!! ! get pathname from command line arguments -!! call get_command_argument (i , length=filename_length) -!! if(allocated(pathi))deallocate(pathi) -!! allocate(character(len=filename_length) :: pathi) -!! call get_command_argument (i , value=pathi) -!! ! -!! ! resolve each pathname -!! patho=system_realpath(pathi) -!! if(patho.ne.char(0))then -!! write(*,*)trim(pathi),'=>',trim(patho) -!! else -!! call system_perror('*system_realpath* error for pathname '//trim(pathi)//':') -!! write(*,*)trim(pathi),'=>',trim(patho) -!! endif -!! deallocate(pathi) -!! enddo -!! ! if there were no pathnames given resolve the pathname "." -!! if(i.eq.1)then -!! patho=system_realpath('.') -!! write(*,*)'.=>',trim(patho) -!! endif -!! end program demo_system_realpath -!! -!! Example usage: -!! -!! demo_system_realpath -!! .=>/home/urbanjs/V600 -!! -!! cd /usr/share/man -!! demo_system_realpath . .. NotThere -!! .=>/usr/share/man -!! ..=>/usr/share -!! *system_realpath* error for pathname NotThere:: No such file or directory -!! NotThere=>NotThere -FUNCTION system_realpath(input) RESULT(string) - -! ident_3="@(#)M_system::system_realpath(3f):call realpath(3c) to get pathname of current working directory" - - CHARACTER(len=*), INTENT(in) :: input - TYPE(C_PTR) :: c_output - CHARACTER(len=:), ALLOCATABLE :: string - INTERFACE - FUNCTION c_realpath(c_input) BIND(c, name="my_realpath") RESULT(c_buffer) - IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) - TYPE(C_PTR) :: c_buffer - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - c_output = c_realpath(str2_carr(TRIM(input))) - IF (.NOT. C_ASSOCIATED(c_output)) THEN - string = CHAR(0) - ELSE - string = C2F_string(c_output) - END IF -END FUNCTION system_realpath -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_issock(3f) - [M_system:QUERY_FILE] checks if argument is a socket -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_issock(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_issock -!! -!!##DESCRIPTION -!! The issock(3f) function checks if path is a path to a socket -!! -!!##OPTIONS -!! path a character string representing a socket pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_issock() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a socket -!! -!! program demo_system_issock -!! use M_system, only : system_issock -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'sock.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a socket? ', system_issock(names(i)) -!! enddo -!! end program demo_system_issock -FUNCTION system_issock(pathname) - IMPLICIT NONE - -! ident_4="@(#)M_system::system_issock(3f): determine if pathname is a socket" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_issock - - INTERFACE - FUNCTION c_issock(pathname) BIND(C, name="my_issock") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_issock - END INTERFACE - - IF (c_issock(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_issock = .TRUE. - ELSE - system_issock = .FALSE. - END IF - -END FUNCTION system_issock -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_isfifo(3f) - [M_system:QUERY_FILE] checks if argument is a fifo - named pipe -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isfifo(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isfifo -!! -!!##DESCRIPTION -!! The isfifo(3f) function checks if path is a path to a fifo - named pipe. -!! -!!##OPTIONS -!! path a character string representing a fifo - named pipe pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isfifo() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a FIFO file -!! -!! program demo_system_isfifo -!! use M_system, only : system_isfifo -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'fifo.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a fifo(named pipe)? ', system_isfifo(names(i)) -!! enddo -!! end program demo_system_isfifo -ELEMENTAL impure FUNCTION system_isfifo(pathname) - IMPLICIT NONE - -! ident_5="@(#)M_system::system_isfifo(3f): determine if pathname is a fifo(named pipe)" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_isfifo - - INTERFACE - FUNCTION c_isfifo(pathname) BIND(C, name="my_isfifo") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isfifo - END INTERFACE - - IF (c_isfifo(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isfifo = .TRUE. - ELSE - system_isfifo = .FALSE. - END IF - -END FUNCTION system_isfifo -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_ischr(3f) - [M_system:QUERY_FILE] checks if argument is a character device -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_ischr(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_ischr -!! -!!##DESCRIPTION -!! The ischr(3f) function checks if path is a path to a character device. -!! -!!##OPTIONS -!! path a character string representing a character device pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_ischr() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a character file -!! -!! program demo_system_ischr -!! use M_system, only : system_ischr -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'char_dev.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a character device? ', system_ischr(names(i)) -!! enddo -!! end program demo_system_ischr -!! -!! Results: -ELEMENTAL impure FUNCTION system_ischr(pathname) - IMPLICIT NONE - -! ident_6="@(#)M_system::system_ischr(3f): determine if pathname is a link" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_ischr - - INTERFACE - FUNCTION c_ischr(pathname) BIND(C, name="my_ischr") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_ischr - END INTERFACE - - IF (c_ischr(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_ischr = .TRUE. - ELSE - system_ischr = .FALSE. - END IF - -END FUNCTION system_ischr -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_isreg(3f) - [M_system:QUERY_FILE] checks if argument is a regular file -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isreg(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isreg -!! -!!##DESCRIPTION -!! The isreg(3f) function checks if path is a regular file -!! -!!##OPTIONS -!! path a character string representing a pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isreg() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_islnk(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a regular file -!! -!! program simple -!! use M_system, only : system_isreg -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! 'test.txt ', & -!! '~/.bashrc ', & -!! '.bashrc ', & -!! '. '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a regular file? ', system_isreg(names(i)) -!! enddo -!! end program simple -!! -!! EXTENDED EXAMPLE -!! list readable non-hidden regular files and links in current directory -!! -!! program demo_system_isreg -!! use M_system, only : isreg=>system_isreg, islnk=>system_islnk -!! use M_system, only : access=>system_access, R_OK -!! use M_system, only : system_dir -!! implicit none -!! character(len=1024),allocatable :: filenames(:) ! BUG: cannot use len=: in gfortran 8.3.1 -!! logical,allocatable :: mymask(:) -!! integer :: i -!! ! list readable non-hidden regular files and links in current directory -!! filenames=system_dir(pattern='*') ! make list of all files in current directory -!! mymask= isreg(filenames).or.islnk(filenames) ! select regular files and links -!! where(mymask) mymask=filenames(:)(1:1).ne.'.' ! skip hidden directories in those -!! where(mymask) mymask=access(filenames,R_OK) ! select readable files in those -!! filenames=pack(filenames,mask=mymask) -!! write(*,'(a)')(trim(filenames(i)),i=1,size(filenames)) -!! end program demo_system_isreg -ELEMENTAL impure FUNCTION system_isreg(pathname) - IMPLICIT NONE - -! ident_7="@(#)M_system::system_isreg(3f): determine if pathname is a regular file" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_isreg - - INTERFACE - FUNCTION c_isreg(pathname) BIND(C, name="my_isreg") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isreg - END INTERFACE - - IF (c_isreg(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isreg = .TRUE. - ELSE - system_isreg = .FALSE. - END IF - -END FUNCTION system_isreg -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_islnk(3f) - [M_system:QUERY_FILE] checks if argument is a link -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_islnk(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_islnk -!! -!!##DESCRIPTION -!! The islnk(3f) function checks if path is a path to a link. -!! -!!##OPTIONS -!! path a character string representing a link -!! pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! system_islnk The system_islnk() function should always be -!! successful and no return value is reserved to -!! indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! -!! Sample program: -!! -!! program demo_system_islnk -!! use M_system, only : system_islnk -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'link.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a link? ', system_islnk(names(i)) -!! enddo -!! end program demo_system_islnk -!! -!! Results: -ELEMENTAL impure FUNCTION system_islnk(pathname) - IMPLICIT NONE - -! ident_8="@(#)M_system::system_islnk(3f): determine if pathname is a link" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_islnk - - INTERFACE - FUNCTION c_islnk(pathname) BIND(C, name="my_islnk") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_islnk - END INTERFACE - - IF (c_islnk(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_islnk = .TRUE. - ELSE - system_islnk = .FALSE. - END IF - -END FUNCTION system_islnk -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_isblk(3f) - [M_system:QUERY_FILE] checks if argument is a block device -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isblk(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isblk -!! -!!##DESCRIPTION -!! The isblk(3f) function checks if path is a path to a block device. -!! -!!##OPTIONS -!! path a character string representing a block device pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isblk() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a block device -!! -!! program demo_system_isblk -!! use M_system, only : system_isblk -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'block_device.tst', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a block device? ', system_isblk(names(i)) -!! enddo -!! end program demo_system_isblk -!! -!! Results: -ELEMENTAL impure FUNCTION system_isblk(pathname) - IMPLICIT NONE - -! ident_9="@(#)M_system::system_isblk(3f): determine if pathname is a block device" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_isblk - - INTERFACE - FUNCTION c_isblk(pathname) BIND(C, name="my_isblk") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isblk - END INTERFACE - - IF (c_isblk(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isblk = .TRUE. - ELSE - system_isblk = .FALSE. - END IF - -END FUNCTION system_isblk -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_isdir(3f) - [M_system:QUERY_FILE] checks if argument is a directory path -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isdir(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isdir -!! -!!##DESCRIPTION -!! The system_isdir(3f) function checks if path is a directory. -!! -!!##OPTIONS -!! path a character string representing a directory pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isdir() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_islnk(3f), system_stat(3f), isreg(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! -!! Sample program -!! -!! program demo_system_isdir -!! use M_system, only : system_isdir -!! use M_system, only : access=>system_access, R_OK -!! use M_system, only : system_dir -!! implicit none -!! character(len=1024),allocatable :: filenames(:) ! BUG: cannot use len=: in gfortran 8.3.1 -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! & '/tmp ', & -!! & '/tmp/NOTTHERE ', & -!! & '/usr/local ', & -!! & '. ', & -!! & 'PROBABLY_NOT '] -!! ! -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a directory? ', system_isdir(names(i)) -!! enddo -!! ! -!! ! EXTENDED EXAMPLE: list readable non-hidden directories in current directory -!! filenames=system_dir(pattern='*') ! list all files in current directory -!! ! select readable directories -!! filenames=pack(filenames,system_isdir(filenames).and.access(filenames,R_OK)) -!! filenames=pack(filenames,filenames(:)(1:1) .ne.'.') ! skip hidden directories -!! do i=1,size(filenames) -!! write(*,*)' ',trim(filenames(i)),' is a directory' -!! enddo -!! ! -!! end program demo_system_isdir -!! -!! -!! Results: -!! -!! is /tmp a directory? T -!! is /tmp/NOTTHERE a directory? F -!! is /usr/local a directory? T -!! is . a directory? T -!! is PROBABLY_NOT a directory? F -!! -!! TEST is a directory -!! EXAMPLE is a directory -ELEMENTAL impure FUNCTION system_isdir(dirname) - IMPLICIT NONE - -! ident_10="@(#)M_system::system_isdir(3f): determine if DIRNAME is a directory name" - - CHARACTER(len=*), INTENT(in) :: dirname - LOGICAL :: system_isdir - - INTERFACE - FUNCTION c_isdir(dirname) BIND(C, name="my_isdir") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: dirname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isdir - END INTERFACE - - IF (c_isdir(str2_carr(TRIM(dirname))) .EQ. 1) THEN - system_isdir = .TRUE. - ELSE - system_isdir = .FALSE. - END IF - -END FUNCTION system_isdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_chown(3f) - [M_system:FILE_SYSTEM] change file owner and group -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_chown(path,owner,group) -!! -!! character(len=*),intent(in) :: path -!! integer,intent(in) :: owner -!! integer,intent(in) :: group -!! -!!##DESCRIPTION -!! The chown(3f) function changes owner and group of a file -!! -!! The path argument points to a pathname naming a file. The -!! user ID and group ID of the named file shall be set to the numeric -!! values contained in owner and group, respectively. -!! -!! Only processes with an effective user ID equal to the user ID of -!! the file or with appropriate privileges may change the ownership -!! of a file. -!! -!!##OPTIONS -!! path a character string representing a file pathname. -!! Trailing spaces are ignored. -!! owner UID of owner that ownership is to be changed to -!! group GID of group that ownership is to be changed to -!! -!!##RETURN VALUE -!! The system_chown(3f) function should return zero 0 if successful. -!! Otherwise, these functions shall return 1 and set errno to -!! indicate the error. If 1 is returned, no changes are made in -!! the user ID and group ID of the file. -!! -!!##EXAMPLE -!! -!! -!! Sample program: -!! -!! program demo_system_chown -!! use M_system, only : system_chown -!! use M_system, only : system_getuid -!! use M_system, only : system_getgid -!! use M_system, only : system_perror -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[character(len=80) :: 'myfile1','/usr/local'] -!! do i=1,size(names) -!! if(.not. system_chown(& -!! & trim(names(i)), & -!! & system_getuid(), & -!! & system_getgid()) & -!! )then -!! call system_perror('*demo_system_chown* '//trim(names(i))) -!! endif -!! enddo -!! end program demo_system_chown -ELEMENTAL impure FUNCTION system_chown(dirname, owner, group) - IMPLICIT NONE - -! ident_11="@(#)M_system::system_chown(3f): change owner and group of a file relative to directory file descriptor" - - CHARACTER(len=*), INTENT(in) :: dirname - INTEGER, INTENT(in) :: owner - INTEGER, INTENT(in) :: group - LOGICAL :: system_chown - -! int chown(const char *path, uid_t owner, gid_t group); - INTERFACE - function c_chown(c_dirname,c_owner,c_group) bind (C,name="my_chown") result (c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_dirname(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_owner - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_group - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_chown - END INTERFACE - - if(c_chown(str2_carr(trim(dirname)),int(owner,kind=c_int),int(group,kind=c_int)).eq.1)then - system_chown = .TRUE. - ELSE - system_chown = .FALSE. - END IF - -END FUNCTION system_chown -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_cpu_time(3f) - [M_system] get processor time by calling times(3c) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_cpu_time(c_user, c_system, c_total) -!! -!! real,intent(out) :: c_total -!! real,intent(out) :: c_user -!! real,intent(out) :: c_system -!! -!!##DESCRIPTION -!! -!!##OUTPUT -!! c_total total processor time ( c_user + c_system ) -!! c_user processor user time -!! c_system processor system time -!! -!!##ERRORS -!! No errors are defined. -!! -!!##EXAMPLES -!! -!! -!! Sample program: -!! -!! program demo_system_cpu_time -!! -!! use M_system, only : system_cpu_time -!! use ISO_C_BINDING, only : c_float -!! implicit none -!! real :: user_start, system_start, total_start -!! real :: user_finish, system_finish, total_finish -!! integer :: i -!! integer :: itimes=1000000 -!! real :: value -!! -!! call system_cpu_time(total_start,user_start,system_start) -!! -!! value=0.0 -!! do i=1,itimes -!! value=sqrt(real(i)+value) -!! enddo -!! write(10,*)value -!! flush(10) -!! write(*,*)'average sqrt value=',value/itimes -!! call system_cpu_time(total_finish,user_finish,system_finish) -!! write(*,*)'USER ......',user_finish-user_start -!! write(*,*)'SYSTEM ....',system_finish-system_start -!! write(*,*)'TOTAL .....',total_finish-total_start -!! -!! end program demo_system_cpu_time -!! -!! Typical Results: -!-! GET ERRORS ABOUT MISSING LONGEST_ENV_VARIABLE IN GFORTRAN 6.4.0 IF JUST USE INTERFACE INSTEAD OF MAKING SUBROUTINE -!-!interface -!-! subroutine system_cpu_time(c_total,c_user,c_system) bind (C,NAME='my_cpu_time') -!-! import c_float -!-! real(kind=c_float) :: c_user,c_system,c_total -!-! end subroutine system_cpu_time -!-!end interface -SUBROUTINE system_cpu_time(total, user, system) - - REAL, INTENT(out) :: user, system, total - REAL(kind=C_FLOAT) :: c_user, c_system, c_total - - INTERFACE - SUBROUTINE c_cpu_time(c_total, c_user, c_system) BIND(C, NAME='my_cpu_time') - IMPORT C_FLOAT - REAL(kind=C_FLOAT) :: c_total, c_user, c_system - END SUBROUTINE c_cpu_time - END INTERFACE - - CALL c_cpu_time(c_total, c_user, c_system) - user = c_user - system = c_system - total = c_total -END SUBROUTINE system_cpu_time -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_link(3f) - [M_system:FILE_SYSTEM] link one file to another -!! file relative to two directory file descriptors -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure integer function link(oldpath,newpath); -!! -!! character(len=*),intent(in) :: oldpath -!! character(len=*),intent(in) :: newpath -!! -!!##DESCRIPTION -!! The link() function shall create a new link (directory entry) -!! for the existing file, path1. -!! -!! The path1 argument points to a pathname naming an existing -!! file. The path2 argument points to a pathname naming the -!! new directory entry to be created. The link() function shall -!! atomically create a new link for the existing file and the link -!! count of the file shall be incremented by one. -!! -!! If path1 names a directory, link() shall fail unless the process -!! has appropriate privileges and the implementation supports using -!! link() on directories. -!! -!! If path1 names a symbolic link, it is implementation-defined -!! whether link() follows the symbolic link, or creates a new link -!! to the symbolic link itself. -!! -!! Upon successful completion, link() shall mark for update the -!! last file status change timestamp of the file. Also, the last -!! data modification and last file status change timestamps of the -!! directory that contains the new entry shall be marked for update. -!! -!! If link() fails, no link shall be created and the link count of -!! the file shall remain unchanged. -!! -!! The implementation may require that the calling process has -!! permission to access the existing file. -!! -!! The linkat() function shall be equivalent to the link() function -!! except that symbolic links shall be handled as specified by the -!! value of flag (see below) and except in the case where either path1 -!! or path2 or both are relative paths. In this case a relative path -!! path1 is interpreted relative to the directory associated with -!! the file descriptor fd1 instead of the current working directory -!! and similarly for path2 and the file descriptor fd2. If the -!! file descriptor was opened without O_SEARCH, the function shall -!! check whether directory searches are permitted using the current -!! permissions of the directory underlying the file descriptor. If -!! the file descriptor was opened with O_SEARCH, the function shall -!! not perform the check. -!! -!! Values for flag are constructed by a bitwise-inclusive OR of -!! flags from the following list, defined in : -!! -!! AT_SYMLINK_FOLLOW -!! If path1 names a symbolic link, a new link for the target -!! of the symbolic link is created. -!! -!! If linkat() is passed the special value AT_FDCWD in the fd1 or -!! fd2 parameter, the current working directory shall be used for the -!! respective path argument. If both fd1 and fd2 have value AT_FDCWD, -!! the behavior shall be identical to a call to link(), except that -!! symbolic links shall be handled as specified by the value of flag. -!! -!! Some implementations do allow links between file systems. -!! -!! If path1 refers to a symbolic link, application developers should -!! use linkat() with appropriate flags to select whether or not the -!! symbolic link should be resolved. -!! -!! If the AT_SYMLINK_FOLLOW flag is clear in the flag argument and -!! the path1 argument names a symbolic link, a new link is created -!! for the symbolic link path1 and not its target. -!! -!!##RETURN VALUE -!! Upon successful completion, these functions shall return -!! 0. Otherwise, these functions shall return -1 and set errno to -!! indicate the error. -!! -!!##EXAMPLES -!! -!! Creating a Link to a File -!! -!! program demo_system_link -!! use M_system, only : system_link, system_perror -!! integer :: ierr -!! ierr = system_link('myfile1','myfile2') -!! if(ierr.ne.0)then -!! call system_perror('*demo_system_link*') -!! endif -!! end program demo_system_link -ELEMENTAL impure FUNCTION system_link(oldname, newname) RESULT(ierr) - -! ident_12="@(#)M_system::system_link(3f): call link(3c) to create a file link" - - CHARACTER(len=*), INTENT(in) :: oldname - CHARACTER(len=*), INTENT(in) :: newname - INTEGER :: ierr - INTEGER(kind=C_INT) :: c_ierr - - INTERFACE - FUNCTION c_link(c_oldname, c_newname) BIND(C, name="link") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_link - END INTERFACE - - c_ierr = c_link(str2_carr(TRIM(oldname)), str2_carr(TRIM(newname))) - ierr = c_ierr - -END FUNCTION system_link -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_unlink(3f) - [M_system:FILE_SYSTEM] remove a directory -!! entry relative to directory file descriptor -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure integer function unlink(path); -!! -!! character(len=*) :: path -!! -!!##DESCRIPTION -!! The unlink() function shall remove a link to a file. If path names a -!! symbolic link, unlink() shall remove the symbolic link named by path -!! and shall not affect any file or directory named by the contents of -!! the symbolic link. Otherwise, unlink() shall remove the link named by -!! the pathname pointed to by path and shall decrement the link count of -!! the file referenced by the link. -!! -!! When the files link count becomes 0 and no process has the file open, -!! the space occupied by the file shall be freed and the file shall no -!! longer be accessible. If one or more processes have the file open when -!! the last link is removed, the link shall be removed before unlink() -!! returns, but the removal of the file contents shall be postponed until -!! all references to the file are closed. -!! -!! The path argument shall not name a directory unless the process has -!! appropriate privileges and the implementation supports using unlink() -!! on directories. -!! -!! Upon successful completion, unlink() shall mark for update the last -!! data modification and last file status change timestamps of the parent -!! directory. Also, if the file link count is not 0, the last file status -!! change timestamp of the file shall be marked for update. -!! -!! Values for flag are constructed by a bitwise-inclusive OR of flags from -!! the following list, defined in : -!! -!! AT_REMOVEDIR -!! -!! Remove the directory entry specified by fd and path as a -!! directory, not a normal file. -!! -!!##RETURN VALUE -!! -!! Upon successful completion, these functions shall return 0. Otherwise, -!! these functions shall return -1 and set errno to indicate the error. If -!! -1 is returned, the named file shall not be changed. -!! -!!##EXAMPLES -!! -!! Removing a link to a file -!! -!! program demo_system_unlink -!! use M_system, only : system_unlink, system_perror -!! integer :: ierr -!! ierr = system_unlink('myfile1') -!! if(ierr.ne.0)then -!! call system_perror('*demo_system_unlink*') -!! endif -!! end program demo_system_unlink -ELEMENTAL impure FUNCTION system_unlink(fname) RESULT(ierr) - -! ident_13="@(#)M_system::system_unlink(3f): call unlink(3c) to rm file link" - - CHARACTER(len=*), INTENT(in) :: fname - INTEGER :: ierr - - INTERFACE - FUNCTION c_unlink(c_fname) BIND(C, name="unlink") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_unlink - END INTERFACE - ierr = c_unlink(str2_carr(TRIM(fname))) -END FUNCTION system_unlink -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_setumask(3f) - [M_system:FILE_SYSTEM] set the file mode creation umask -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer function system_setumask(new_umask) result (old_umask) -!! -!! integer,intent(in) :: new_umask -!! integer(kind=c_int) :: umask_c -!! -!!##DESCRIPTION -!! The system_umask(3f) function sets the file mode creation mask of the -!! process to cmask and return the previous value of the mask. Only -!! the file permission bits of cmask (see ) are used; -!! the meaning of the other bits is implementation-defined. -!! -!! The file mode creation mask of the process is used to turn off -!! permission bits in the mode argument supplied during calls to -!! the following functions: -!! -!! * open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat() -!! * mknod(), mknodat() -!! * mq_open() -!! * sem_open() -!! -!! Bit positions that are set in cmask are cleared in the mode of -!! the created file. -!! -!!##RETURN VALUE -!! The file permission bits in the value returned by umask() shall be -!! the previous value of the file mode creation mask. The state of any -!! other bits in that value is unspecified, except that a subsequent -!! call to umask() with the returned value as cmask shall leave the -!! state of the mask the same as its state before the first call, -!! including any unspecified use of those bits. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##EXAMPLE -!! -!! Sample program -!! -!! program demo_setumask -!! use M_system, only : system_getumask, system_setumask -!! integer :: newmask -!! integer :: i -!! integer :: old_umask -!! write(*,101)(system_getumask(),i=1,4) -!! 101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'") -!! newmask=63 -!! old_umask=system_setumask(newmask) -!! write(*,*)'NEW' -!! write(*,101)(system_getumask(),i=1,4) -!! end program demo_setumask -!! -!! Expected output -!! -!! 18 O'022' Z"12' B'000010010" -!! NEW -!! 63 O'077' Z"3F' B'000111111" -INTEGER FUNCTION system_setumask(umask_value) RESULT(old_umask) - INTEGER, INTENT(in) :: umask_value - INTEGER(kind=C_INT) :: umask_c - - umask_c = umask_value - old_umask = system_umask(umask_c) ! set current umask - -END FUNCTION system_setumask -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getumask(3f) - [M_system:QUERY_FILE] get current umask -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer function system_getumask() result (umask_value) -!!##DESCRIPTION -!! The return value from getumask(3f) is the value of the file -!! creation mask, obtained by using umask(3c). -!!##EXAMPLE -!! -!! Sample program -!! -!! program demo_getumask -!! use M_system, only : system_getumask, system_setumask -!! integer :: i -!! write(*,101)(system_getumask(),i=1,4) -!! 101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'") -!! end program demo_getumask -!! -!! Expected output -!! -!! 18 O'022' Z"12' B'000010010" -INTEGER FUNCTION system_getumask() RESULT(umask_value) -! The return value from umask() is just the previous value of the file -! creation mask, so that this system call can be used both to get and -! set the required values. Sadly, however, there is no way to get the old -! umask value without setting a new value at the same time. - -! This means that in order just to see the current value, it is necessary -! to execute a piece of code like the following function: - INTEGER :: idum - INTEGER(kind=C_INT) :: old_umask - old_umask = system_umask(0_C_INT) ! get current umask but by setting umask to 0 (a conservative mask so no vulnerability is open) - idum = system_umask(old_umask) ! set back to original mask - umask_value = old_umask -END FUNCTION system_getumask -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! perror(3f) - [M_system:ERROR_PROCESSING] print error message for last C error on stderr -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_perror(prefix) -!! -!! character(len=*),intent(in) :: prefix -!! -!!##DESCRIPTION -!! Use system_perror(3f) to print an error message on stderr -!! corresponding to the current value of the C global variable errno. -!! Unless you use NULL as the argument prefix, the error message will -!! begin with the prefix string, followed by a colon and a space -!! (:). The remainder of the error message produced is one of the -!! strings described for strerror(3c). -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_perror -!! use M_system, only : system_perror,system_rmdir -!! implicit none -!! character(len=:),allocatable :: DIRNAME -!! DIRNAME='/NOT/THERE/OR/ANYWHERE' -!! ! generate an error with a routine that supports errno and perror(3c) -!! if(system_rmdir(DIRNAME).ne.0)then -!! call system_perror('*demo_system_perror*:'//DIRNAME) -!! endif -!! write(*,'(a)')"That is all Folks!" -!! end program demo_system_perror -!! -!! Expected results: -!! -!! *demo_system_perror*:/NOT/THERE/OR/ANYWHERE: No such file or directory -!! That is all Folks! -SUBROUTINE system_perror(prefix) - USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT ! access computing environment - -! ident_14="@(#)M_system::system_perror(3f): call perror(3c) to display error message" - - CHARACTER(len=*), INTENT(in) :: prefix - INTEGER :: ios - - INTERFACE - SUBROUTINE c_perror(c_prefix) BIND(C, name="perror") - IMPORT C_CHAR - CHARACTER(kind=C_CHAR) :: c_prefix(*) - END SUBROUTINE c_perror - END INTERFACE - - FLUSH (unit=ERROR_UNIT, iostat=ios) - FLUSH (unit=OUTPUT_UNIT, iostat=ios) - FLUSH (unit=INPUT_UNIT, iostat=ios) - CALL c_perror(str2_carr((TRIM(prefix)))) - CALL c_flush() - -END SUBROUTINE system_perror -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_chdir(3f) - [M_system_FILE_SYSTEM] call chdir(3c) from Fortran to change working directory -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_chdir(path, err) -!! -!! character(len=*) :: path -!! integer, optional, intent(out) :: err -!! -!!##DESCRIPTION -!! -!! system_chdir(3f) changes the current working directory of the calling -!! process to the directory specified in path. The current working -!! directory is the starting point for interpreting relative pathnames -!! (those not starting with '/'). -!! -!!##RETURN VALUE -!! -!! On success, zero is returned. On error, -1 is returned, and errno is -!! set appropriately. -!! -!! -!! Depending on the file system, other errors can be returned. The more -!! general errors for chdir() are listed below, by their C definitions: -!! -!! Errors -!! EACCES Search permission is denied for one of the components of path. -!! (See also path_resolution(7).) -!! EFAULT path points outside your accessible address space. -!! EIO An I/O error occurred. -!! ELOOP Too many symbolic links were encountered in resolving path. -!! ENAMETOOLONG path is too long. -!! ENOENT The file does not exist. -!! ENOMEM Insufficient kernel memory was available. -!! ENOTDIR A component of path is not a directory. -!! -!!##SEE ALSO -!! -!! chroot(2), getcwd(3), path_resolution(7) -!! -!!##EXAMPLE -!! -!! Change working directory from Fortran -!! -!! program demo_system_chdir -!! use M_system, only : system_chdir -!! implicit none -!! integer :: ierr -!! -!! call execute_command_line('pwd') -!! call system_chdir('/tmp',ierr) -!! call execute_command_line('pwd') -!! write(*,*)'*CHDIR TEST* IERR=',ierr -!! -!! end program demo_system_chdir -!! -!!##RESULTS: -!! Sample run output: -!! -!! /home/urbanjs/V600 -!! /tmp -!! *CHDIR TEST* IERR= 0 -SUBROUTINE system_chdir(path, err) - -! ident_15="@(#)M_system::system_chdir(3f): call chdir(3c)" - - CHARACTER(len=*) :: path - INTEGER, OPTIONAL, INTENT(out) :: err - - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_chdir(c_path) BIND(C, name="chdir") - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR) :: c_path(*) - END FUNCTION - END INTERFACE - INTEGER :: loc_err -!----------------------------------------------------------------------------------------------------------------------------------- - loc_err = c_chdir(str2_carr(TRIM(path))) - IF (PRESENT(err)) THEN - err = loc_err - END IF -END SUBROUTINE system_chdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_remove(3f) - [M_system_FILE_SYSTEM] call remove(3c) to remove file -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! elemental impure function system_remove(path) result(err) -!! -!! character(*),intent(in) :: path -!! integer(c_int) :: err -!! -!!##DESCRIPTION -!! Fortran supports scratch files via the OPEN(3c) command; but does -!! not otherwise allow for removing files. The system_remove(3f) command -!! allows for removing files by name that the user has the authority to -!! remove by calling the C remove(3c) function. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_remove -!! use M_system, only : system_remove -!! character(len=*),parameter :: FILE='MyJunkFile.txt' -!! integer :: ierr -!! write(*,*)'BEFORE CREATED '//FILE -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! ! note intentionally causes error if file exists -!! open(unit=10,file=FILE,status='NEW') -!! write(*,*)'AFTER OPENED '//FILE -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! write(10,'(a)') 'This is a file I want to delete' -!! close(unit=10) -!! write(*,*)'AFTER CLOSED ' -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! ierr=system_remove(FILE) -!! write(*,*)'AFTER REMOVED',IERR -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! end program demo_system_remove -!! -!! Expected Results: -!! -!! > BEFORE CREATED MyJunkFile.txt -!! > ls: cannot access 'MyJunkFile.txt': No such file or directory -!! > -!! > AFTER OPENED MyJunkFile.txt -!! > -rw-r--r-- 1 JSU None 0 Nov 19 19:32 MyJunkFile.txt -!! > -!! > AFTER CLOSED -!! > -rw-r--r-- 1 JSU None 32 Nov 19 19:32 MyJunkFile.txt -!! > -!! > AFTER REMOVED 0 -!! > ls: cannot access 'MyJunkFile.txt': No such file or directory -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -ELEMENTAL impure FUNCTION system_remove(path) RESULT(err) - -! ident_16="@(#)M_system::system_remove(3f): call remove(3c) to remove file" - - CHARACTER(*), INTENT(in) :: path - INTEGER(C_INT) :: err - - INTERFACE - FUNCTION c_remove(c_path) BIND(c, name="remove") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - err = c_remove(str2_carr(TRIM(path))) -END FUNCTION system_remove -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_rename(3f) - [M_system_FILE_SYSTEM] call rename(3c) to rename a system file -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_rename(input,output) result(ierr) -!! -!! character(*),intent(in) :: input,output -!! integer :: ierr -!!##DESCRIPTION -!! Rename a file by calling rename(3c). It is not recommended that the -!! rename occur while either filename is being used on a file currently -!! OPEN(3f) by the program. -!! -!! Both the old and new names must be on the same device. -!!##OPTIONS -!! INPUT system filename of an existing file to rename -!! OUTPUT system filename to be created or overwritten by INPUT file. -!! Must be on the same device as the INPUT file. -!!##RETURNS -!! IERR zero (0) if no error occurs. If not zero a call to -!! system_errno(3f) or system_perror(3f) is supported -!! to diagnose error -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rename -!! use M_system, only : system_rename -!! use M_system, only : system_remove -!! use M_system, only : system_perror -!! implicit none -!! character(len=256) :: string -!! integer :: ios, ierr -!! -!! ! try to remove junk files just in case -!! ierr=system_remove('_scratch_file_') -!! write(*,'(a,i0)') 'should not be zero ',ierr -!! call system_perror('*demo_system_rename*') -!! ierr=system_remove('_renamed_scratch_file_') -!! write(*,'(a,i0)') 'should not be zero ',ierr -!! call system_perror('*demo_system_rename*') -!! -!! ! create scratch file to rename -!! open(unit=10,file='_scratch_file_',status='new') -!! write(10,'(a)') 'Test by renaming "_scratch_file_" to "_renamed_scratch_file_"' -!! write(10,'(a)') 'IF YOU SEE THIS ON OUTPUT THE RENAME WORKED' -!! close(10) -!! ! rename scratch file -!! ierr=system_rename('_scratch_file_','_renamed_scratch_file_') -!! if(ierr.ne.0)then -!! write(*,*)'ERROR RENAMING FILE ',ierr -!! endif -!! ! read renamed file -!! open(unit=11,file='_renamed_scratch_file_',status='old') -!! INFINITE: do -!! read(11,'(a)',iostat=ios)string -!! if(ios.ne.0)exit INFINITE -!! write(*,'(a)')trim(string) -!! enddo INFINITE -!! close(unit=11) -!! -!! ! clean up -!! ierr=system_remove('_scratch_file_') -!! write(*,'(a,i0)') 'should not be zero ',ierr -!! ierr=system_remove('_renamed_scratch_file_') -!! write(*,'(a,i0)') 'should be zero ',ierr -!! -!! end program demo_system_rename -!! -!! Expected output: -!! -!! > should not be zero -1 -!! > *demo_system_rename*: No such file or directory -!! > should not be zero -1 -!! > *demo_system_rename*: No such file or directory -!! > Test by renaming "_scratch_file_" to "_renamed_scratch_file_" -!! > IF YOU SEE THIS ON OUTPUT THE RENAME WORKED -!! > should not be zero -1 -!! > should be zero 0 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_rename(input, output) RESULT(ierr) - -! ident_17="@(#)M_system::system_rename(3f): call rename(3c) to change filename" - - CHARACTER(*), INTENT(in) :: input, output - INTEGER :: ierr - INTERFACE - FUNCTION c_rename(c_input, c_output) BIND(c, name="rename") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) - CHARACTER(kind=C_CHAR), INTENT(in) :: c_output(*) - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - ierr = c_rename(str2_carr(TRIM(input)), str2_carr(TRIM(output))) -END FUNCTION system_rename -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_chmod(3f) - [M_system_FILE_SYSTEM] call chmod(3c) to change -!! permission mode of a file relative to directory file descriptor -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_chmod(filename,mode) result(ierr) -!! -!! character(len=*),intent(in) :: filename -!! integer,value,intent(in) :: mode -!! integer :: ierr -!! -!!##DESCRIPTION -!! The system_chmod(3f) function shall change UID, _ISGID, S_ISVTX, and the -!! file permission bits of the file named by the pathname pointed -!! to by the path argument to the corresponding bits in the mode -!! argument. The application shall ensure that the effective user -!! ID of the process matches the owner of the file or the process -!! has appropriate privileges in order to do this. -!! -!! S_ISUID, S_ISGID, S_ISVTX, and the file permission bits are -!! described in . -!! -!! If the calling process does not have appropriate privileges, -!! and if the group ID of the file does not match the effective -!! group ID or one of the supplementary group IDs and if the file -!! is a regular file, bit S_ISGID (set-group-ID on execution) in the -!! file mode shall be cleared upon successful return from chmod(). -!! -!! Additional implementation-defined restrictions may cause the -!! S_ISUID and S_ISGID bits in mode to be ignored. -!! -!! Upon successful completion, system_chmod() marks for update the -!! last file status change timestamp of the file. -!! -!! Values for flag are constructed by a bitwise-inclusive OR of -!! flags from the following list, defined in : -!! -!! AT_SYMLINK_NOFOLLOW -!! If path names a symbolic link, then the mode of the symbolic -!! link is changed. -!! -!! -!!##RETURN VALUE -!! Upon successful completion, system_chmod(3f) returns 0. -!! Otherwise, it returns -1 and sets errno to indicate the error. If -!! -1 is returned, no change to the file mode occurs. -!! -!!##EXAMPLES -!! -!! Sample program: -!! -!! program demo_system_chmod -!! use M_system, only : system_chmod -!! use M_system, only : system_stat -!! use M_system, only : R_GRP,R_OTH,R_USR, RWX_G, RWX_U, W_OTH, X_GRP -!! !use M_system, only : RWX_O, W_GRP,W_USR,X_OTH,X_USR -!! !use M_system, only : DEFFILEMODE, ACCESSPERMS -!! use,intrinsic :: iso_fortran_env, only : int64 -!! implicit none -!! integer :: ierr -!! integer :: status -!! integer(kind=int64) :: buffer(13) -!! !Setting Read Permissions for User, Group, and Others -!! ! The following example sets read permissions for the owner, group, and others. -!! open(file='_test1',unit=10) -!! write(10,*)'TEST FILE 1' -!! close(unit=10) -!! ierr=system_chmod('_test1', IANY([R_USR,R_GRP,R_OTH])) -!! -!! !Setting Read, Write, and Execute Permissions for the Owner Only -!! ! The following example sets read, write, and execute permissions for the owner, and no permissions for group and others. -!! open(file='_test2',unit=10) -!! write(10,*)'TEST FILE 2' -!! close(unit=10) -!! ierr=system_chmod('_test2', RWX_U) -!! -!! !Setting Different Permissions for Owner, Group, and Other -!! ! The following example sets owner permissions for CHANGEFILE to read, write, and execute, group permissions to read and -!! ! execute, and other permissions to read. -!! open(file='_test3',unit=10) -!! write(10,*)'TEST FILE 3' -!! close(unit=10) -!! ierr=system_chmod('_test3', IANY([RWX_U,R_GRP,X_GRP,R_OTH])); -!! -!! !Setting and Checking File Permissions -!! ! The following example sets the file permission bits for a file named /home/cnd/mod1, then calls the stat() function to -!! ! verify the permissions. -!! -!! ierr=system_chmod("home/cnd/mod1", IANY([RWX_U,RWX_G,R_OTH,W_OTH])) -!! call system_stat("home/cnd/mod1", buffer,status) -!! -!! ! In order to ensure that the S_ISUID and S_ISGID bits are set, an application requiring this should use stat() after a -!! ! successful chmod() to verify this. -!! -!! ! Any files currently open could possibly become invalid if the mode -!! ! of the file is changed to a value which would deny access to -!! ! that process. -!! -!! end program demo_system_chmod -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_chmod(filename, mode) RESULT(ierr) - CHARACTER(len=*), INTENT(in) :: filename - INTEGER, VALUE, INTENT(in) :: mode - INTEGER :: ierr - INTERFACE - FUNCTION c_chmod(c_filename, c_mode) BIND(c, name="chmod") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_filename(*) - INTEGER(C_INT), VALUE, INTENT(in) :: c_mode - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - ierr = c_chmod(str2_carr(TRIM(filename)), INT(mode, KIND(0_C_INT))) -END FUNCTION system_chmod -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getcwd(3f) - [M_system:QUERY_FILE] call getcwd(3c) to get the pathname of the current working directory -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_getcwd(output,ierr) -!! -!! character(len=:),allocatable,intent(out) :: output -!! integer,intent(out) :: ierr -!!##DESCRIPTION -!! system_getcwd(3f) calls the C routine getcwd(3c) to obtain the absolute pathname of the current working directory. -!! -!!##RETURN VALUE -!! OUTPUT The absolute pathname of the current working directory -!! The pathname shall contain no components that are dot or dot-dot, -!! or are symbolic links. -!! IERR is not zero if an error occurs. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getcwd -!! use M_system, only : system_getcwd -!! implicit none -!! character(len=:),allocatable :: dirname -!! integer :: ierr -!! call system_getcwd(dirname,ierr) -!! if(ierr.eq.0)then -!! write(*,*)'CURRENT DIRECTORY ',trim(dirname) -!! else -!! write(*,*)'ERROR OBTAINING CURRENT DIRECTORY NAME' -!! endif -!! end program demo_system_getcwd -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_getcwd(output, ierr) - -! ident_18="@(#)M_system::system_getcwd(3f):call getcwd(3c) to get pathname of current working directory" - - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output - INTEGER, INTENT(out) :: ierr - INTEGER(kind=C_LONG), PARAMETER :: length = 4097_C_LONG - CHARACTER(kind=C_CHAR, len=1) :: buffer(length) - TYPE(C_PTR) :: buffer2 - INTERFACE - FUNCTION c_getcwd(buffer, size) BIND(c, name="getcwd") RESULT(buffer_result) - IMPORT C_CHAR, C_SIZE_T, C_PTR - CHARACTER(kind=C_CHAR), INTENT(out) :: buffer(*) - INTEGER(C_SIZE_T), VALUE, INTENT(in) :: size - TYPE(C_PTR) :: buffer_result - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - buffer = ' ' - buffer2 = c_getcwd(buffer, length) - IF (.NOT. C_ASSOCIATED(buffer2)) THEN - output = '' - ierr = -1 - ELSE - output = TRIM(arr2str(buffer)) - ierr = 0 - END IF -END SUBROUTINE system_getcwd -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_rmdir(3f) - [M_system:FILE_SYSTEM] call rmdir(3c) to remove empty directories -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_rmdir(dirname) result(err) -!! -!! character(*),intent(in) :: dirname -!! integer(c_int) :: err -!! -!!##DESCRIPTION -!! DIRECTORY The name of a directory to remove if it is empty -!! err zero (0) if no error occurred -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rmdir -!! use M_system, only : system_perror -!! use M_system, only : system_rmdir, system_mkdir -!! use M_system, only : RWX_U -!! implicit none -!! integer :: ierr -!! write(*,*)'BEFORE TRY TO CREATE _scratch/' -!! call execute_command_line('ls -ld _scratch') -!! -!! write(*,*)'TRY TO CREATE _scratch/' -!! ierr=system_mkdir('_scratch',RWX_U) -!! write(*,*)'IERR=',ierr -!! call execute_command_line('ls -ld _scratch') -!! -!! write(*,*)'TRY TO REMOVE _scratch/' -!! ierr=system_rmdir('_scratch') -!! write(*,*)'IERR=',ierr -!! call execute_command_line('ls -ld _scratch') -!! -!! write(*,*)'TRY TO REMOVE _scratch when it should be gone/' -!! ierr=system_rmdir('_scratch') -!! call system_perror('*test of system_rmdir*') -!! write(*,*)'IERR=',ierr -!! call execute_command_line('ls -ld _scratch') -!! -!! end program demo_system_rmdir -!! -!! Expected output: -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_rmdir(dirname) RESULT(err) - -! ident_19="@(#)M_system::system_rmdir(3f): call rmdir(3c) to remove empty directory" - - CHARACTER(*), INTENT(in) :: dirname - INTEGER(C_INT) :: err - - INTERFACE - FUNCTION c_rmdir(c_path) BIND(c, name="rmdir") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - err = c_rmdir(str2_carr(TRIM(dirname))) - IF (err .NE. 0) err = system_errno() -END FUNCTION system_rmdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_mkfifo(3f) - [M_system:FILE_SYSTEM] make a FIFO special file relative to directory file descriptor -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_mkfifo(pathname,mode) result(ierr) -!! -!! character(len=*),intent(in) :: pathname -!! integer,intent(in) :: mode -!! integer :: ierr -!! -!!##DESCRIPTION -!! A regular pipe can only connect two related processes. It is created by -!! a process and will vanish when the last process closes it. -!! -!! A named pipe, also called a FIFO for its behavior, can be used to connect -!! two unrelated processes and exists independently of the processes; -!! meaning it can exist even if no one is using it. A FIFO is created using -!! the mkfifo() library function. -!! -!! The mkfifo() function creates a new FIFO special file named by the -!! pathname. -!! -!! The file permission bits of the new FIFO are initialized from mode. -!! -!! The file permission bits of the mode argument are modified by the -!! process file creation mask. -!! -!! When bits in mode other than the file permission bits are set, the -!! effect is implementation-defined. -!! -!! If path names a symbolic link, mkfifo() shall fail and set errno to -!! [EEXIST]. -!! -!! The FIFOs user ID will be set to the process effective user ID. -!! -!! The FIFOs group ID shall be set to the group ID of the parent -!! directory or to the effective group ID of the process. -!! -!! Implementations shall provide a way to initialize the FIFOs group -!! ID to the group ID of the parent directory. -!! -!! Implementations may, but need not, provide an implementation-defined -!! way to initialize the FIFOs group ID to the effective group ID of -!! the calling process. -!! -!! Upon successful completion, mkfifo() shall mark for update the -!! last data access, last data modification, and last file status change -!! timestamps of the file. -!! -!! Also, the last data modification and last file status change -!! timestamps of the directory that contains the new entry shall be -!! marked for update. -!! -!! Predefined variables are typically used to set permission modes. -!! -!! You can bytewise-OR together these variables to create the most -!! common permissions mode: -!! -!! User: R_USR (read), W_USR (write), X_USR(execute) -!! Group: R_GRP (read), W_GRP (write), X_GRP(execute) -!! Others: R_OTH (read), W_OTH (write), X_OTH(execute) -!! -!! Additionally, some shortcuts are provided (basically a bitwise-OR -!! combination of the above): -!! -!! Read + Write + Execute: RWX_U (User), RWX_G (Group), RWX_O (Others) -!! DEFFILEMODE: Equivalent of 0666 =rw-rw-rw- -!! ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx -!! -!! Therefore, to give only the user rwx (read+write+execute) rights whereas -!! group members and others may not do anything, you can use any of the -!! following mkfifo() calls equivalently: -!! -!! ierr= mkfifo("myfile", IANY([R_USR, W_USR, X_USR])); -!! ierr= mkfifo("myfile", RWX_U); -!! -!! In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can -!! use any of the following calls equivalently: -!! -!! ierr= mkfifo("myfile",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH])); -!! ierr= mkfifo("myfile",IANY([RWX_U,RWX_G,RWX_O])); -!! ierr= mkfifo("myfile",ACCESSPERMS); -!!##RETURN VALUE -!! Upon successful completion, return 0. -!! Otherwise, return -1 and set errno to indicate the error. -!! If -1 is returned, no FIFO is created. -!! -!!##EXAMPLES -!! -!! The following example shows how to create a FIFO file named -!! /home/cnd/mod_done, with read/write permissions for owner, and -!! with read permissions for group and others. -!! -!! program demo_system_mkfifo -!! use M_system, only : system_mkfifo, system_perror -!! !use M_system, only : R_GRP,R_OTH,R_USR,RWX_G,RWX_O -!! !use M_system, only : RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR -!! !use M_system, only : DEFFILEMODE, ACCESSPERMS -!! use M_system, only : W_USR, R_USR, R_GRP, R_OTH -!! implicit none -!! integer :: status -!! status = system_mkfifo("/tmp/buffer", IANY([W_USR, R_USR, R_GRP, R_OTH])) -!! if(status.ne.0)then -!! call system_perror('*mkfifo* error:') -!! endif -!! end program demo_system_mkfifo -!! -!! Now some other process (or this one) can read from /tmp/buffer while this program -!! is running or after, consuming the data as it is read. -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_mkfifo(pathname, mode) RESULT(err) - -! ident_20="@(#)M_system::system_mkfifo(3f): call mkfifo(3c) to create a new FIFO special file" - - CHARACTER(len=*), INTENT(in) :: pathname - INTEGER, INTENT(in) :: mode - INTEGER :: c_mode - INTEGER :: err - - INTERFACE - FUNCTION c_mkfifo(c_path, c_mode) BIND(c, name="mkfifo") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) - INTEGER(C_INT), INTENT(in), VALUE :: c_mode - INTEGER(C_INT) :: c_err - END FUNCTION c_mkfifo - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - c_mode = mode - err = c_mkfifo(str2_carr(TRIM(pathname)), c_mode) -END FUNCTION system_mkfifo -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_mkdir(3f) - [M_system:FILE_SYSTEM] call mkdir(3c) to create a new directory -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!!##DESCRIPTION -!! -!! Predefined variables are typically used to set permission modes. -!! You can bytewise-OR together these variables to create the most common -!! permissions mode: -!! -!! User: R_USR (read), W_USR (write), X_USR(execute) -!! Group: R_GRP (read), W_GRP (write), X_GRP(execute) -!! Others: R_OTH (read), W_OTH (write), X_OTH(execute) -!! -!! Additionally, some shortcuts are provided (basically a bitwise-OR combination of the above): -!! -!! Read + Write + Execute: RWX_U (User), RWX_G (Group), RWX_O (Others) -!! DEFFILEMODE: Equivalent of 0666 =rw-rw-rw- -!! ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx -!! -!! Therefore, to give only the user rwx (read+write+execute) rights whereas -!! group members and others may not do anything, you can use any of the -!! following mkdir() calls equivalently: -!! -!! ierr= mkdir("mydir", IANY([R_USR, W_USR, X_USR])); -!! ierr= mkdir("mydir", RWX_U); -!! -!! In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can -!! use any of the following calls equivalently: -!! -!! ierr= mkdir("mydir",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH])); -!! ierr= mkdir("mydir",IANY([RWX_U,RWX_G,RWX_O])); -!! ierr= mkdir("mydir",ACCESSPERMS); -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_mkdir -!! use M_system, only : system_perror -!! use M_system, only : system_mkdir -!! use M_system, only : R_GRP,R_OTH,R_USR,RWX_G,RWX_O -!! use M_system, only : RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR -!! use M_system, only : DEFFILEMODE, ACCESSPERMS -!! implicit none -!! integer :: ierr -!! ierr=system_mkdir('_scratch',IANY([R_USR,W_USR,X_USR])) -!! end program demo_system_mkdir -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_mkdir(dirname, mode) RESULT(ierr) - -! ident_21="@(#)M_system::system_mkdir(3f): call mkdir(3c) to create empty directory" - - CHARACTER(len=*), INTENT(in) :: dirname - INTEGER, INTENT(in) :: mode - INTEGER :: c_mode - INTEGER(kind=C_INT) :: err - INTEGER :: ierr - - INTERFACE - FUNCTION c_mkdir(c_path, c_mode) BIND(c, name="mkdir") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) - INTEGER(C_INT), INTENT(in), VALUE :: c_mode - INTEGER(C_INT) :: c_err - END FUNCTION c_mkdir - END INTERFACE - INTERFACE - SUBROUTINE my_mkdir(string, c_mode, c_err) BIND(C, name="my_mkdir") - USE ISO_C_BINDING, ONLY: C_CHAR, C_INT - CHARACTER(kind=C_CHAR) :: string(*) - INTEGER(C_INT), INTENT(in), VALUE :: c_mode - INTEGER(C_INT) :: c_err - END SUBROUTINE my_mkdir - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - c_mode = mode - IF (INDEX(dirname, '/') .NE. 0) THEN - CALL my_mkdir(str2_carr(TRIM(dirname)), c_mode, err) - ELSE - err = c_mkdir(str2_carr(TRIM(dirname)), c_mode) - END IF - ierr = err ! c_int to default integer kind -END FUNCTION system_mkdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_opendir(3f) - [M_system:QUERY_FILE] open directory stream by calling opendir(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_opendir(dirname,dir,ierr) -!! -!! character(len=*), intent(in) :: dirname -!! type(c_ptr) :: dir -!! integer,intent(out) :: ierr -!! -!!##DESCRIPTION -!! The system_opendir(3f) procedure opens a directory stream -!! corresponding to the directory named by the dirname argument. -!! The directory stream is positioned at the first entry. -!! -!!##RETURN VALUE -!! Upon successful completion, a pointer to a C dir type is returned. -!! Otherwise, these functions shall return a null pointer and set -!! IERR to indicate the error. -!! -!!##ERRORS -!! -!! An error corresponds to a condition described in opendir(3c): -!! -!! EACCES Search permission is denied for the component of the -!! path prefix of dirname or read permission is denied -!! for dirname. -!! -!! ELOOP A loop exists in symbolic links encountered during -!! resolution of the dirname argument. -!! -!! ENAMETOOLONG The length of a component of a pathname is longer than {NAME_MAX}. -!! -!! ENOENT A component of dirname does not name an existing directory or dirname is an empty string. -!! -!! ENOTDIR A component of dirname names an existing file that is neither a directory nor a symbolic link to a directory. -!! -!! ELOOP More than {SYMLOOP_MAX} symbolic links were encountered during resolution of the dirname argument. -!! -!! EMFILE All file descriptors available to the process are currently open. -!! -!! ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, -!! or pathname resolution of a symbolic link produced an intermediate -!! result with a length that exceeds {PATH_MAX}. -!! -!! ENFILE Too many files are currently open in the system. -!! -!!##APPLICATION USAGE -!! The opendir() function should be used in conjunction with readdir(), closedir(), and rewinddir() to examine the contents -!! of the directory (see the EXAMPLES section in readdir()). This method is recommended for portability. -!!##OPTIONS -!! dirname name of directory to open a directory stream for -!!##RETURNS -!! dir pointer to directory stream. If an -!! error occurred, it will not be associated. -!! ierr 0 indicates no error occurred -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_opendir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_closedir -!! use iso_c_binding -!! implicit none -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: ierr -!! !--- open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! if(ierr.eq.0)then -!! !--- read directory stream -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! endif -!! !--- close directory stream -!! call system_closedir(dir,ierr) -!! end program demo_system_opendir -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_opendir(dirname, dir, ierr) - CHARACTER(len=*), INTENT(in) :: dirname - TYPE(C_PTR) :: dir - INTEGER, INTENT(out) :: ierr - - INTERFACE - FUNCTION c_opendir(c_dirname) BIND(c, name="opendir") RESULT(c_dir) - IMPORT C_CHAR, C_INT, C_PTR - CHARACTER(kind=C_CHAR), INTENT(in) :: c_dirname(*) - TYPE(C_PTR) :: c_dir - END FUNCTION c_opendir - END INTERFACE - - ierr = 0 - dir = c_opendir(str2_carr(TRIM(dirname))) - IF (.NOT. C_ASSOCIATED(dir)) THEN - WRITE (*, '(a)') '*system_opendir* Error opening '//TRIM(dirname) - ierr = -1 - END IF - -END SUBROUTINE system_opendir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_readdir(3f) - [M_system:QUERY_FILE] read a directory using readdir(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_readdir(dir,filename,ierr) -!! -!! type(c_ptr),value :: dir -!! character(len=:),intent(out),allocatable :: filename -!! integer,intent(out) :: ierr -!! -!!##DESCRIPTION -!! -!! system_readdir(3f) returns the name of the directory entry at the -!! current position in the directory stream specified by the argument -!! DIR, and positions the directory stream at the next entry. It returns -!! a null name upon reaching the end of the directory stream. -!! -!!##OPTIONS -!! -!! DIR A pointer to the directory opened by system_opendir(3f). -!! -!!##RETURNS -!! -!! FILENAME the name of the directory entry at the current position in -!! the directory stream specified by the argument DIR, and -!! positions the directory stream at the next entry. -!! -!! The readdir() function does not return directory entries -!! containing empty names. If entries for dot or dot-dot exist, -!! one entry is returned for dot and one entry is returned -!! for dot-dot. -!! -!! The entry is marked for update of the last data access -!! timestamp each time it is read. -!! -!! reaching the end of the directory stream, the name is a blank name. -!! -!! IERR If IERR is set to non-zero on return, an error occurred. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_readdir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_rewinddir,system_closedir -!! use iso_c_binding -!! implicit none -!! -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: i, ierr -!! !--- open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! if(ierr.eq.0)then -!! !--- read directory stream twice -!! do i=1,2 -!! write(*,'(a,i0)')'PASS ',i -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! call system_rewinddir(dir) -!! enddo -!! endif -!! !--- close directory stream -!! call system_closedir(dir,ierr) -!! -!! end program demo_system_readdir -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_readdir(dir, filename, ierr) - TYPE(C_PTR), VALUE :: dir - CHARACTER(len=:), INTENT(out), ALLOCATABLE :: filename - INTEGER, INTENT(out) :: ierr - INTEGER(kind=C_INT) :: ierr_local - - CHARACTER(kind=C_CHAR, len=1) :: buf(4097) - - INTERFACE - SUBROUTINE c_readdir(c_dir, c_filename, c_ierr) BIND(C, NAME='my_readdir') - IMPORT C_CHAR, C_INT, C_PTR - TYPE(C_PTR), VALUE :: c_dir - CHARACTER(kind=C_CHAR) :: c_filename(*) - INTEGER(kind=C_INT) :: c_ierr - END SUBROUTINE c_readdir - END INTERFACE - - buf = ' ' - ierr_local = 0 - CALL c_readdir(dir, buf, ierr_local) - filename = TRIM(arr2str(buf)) - ierr = ierr_local - -END SUBROUTINE system_readdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_rewinddir(3f) - [M_system:QUERY_FILE] call rewinddir(3c) to rewind directory stream -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_rewinddir(dir) -!! -!! type(c_ptr),value :: dir -!! -!!##DESCRIPTION -!! Return to pointer to the beginning of the list for a currently open directory list. -!! -!!##OPTIONS -!! DIR A C_pointer assumed to have been allocated by a call to SYSTEM_OPENDIR(3f). -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rewinddir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_rewinddir,system_closedir -!! use iso_c_binding -!! implicit none -!! -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: i, ierr -!! !>>> open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! !>>> read directory stream twice -!! do i=1,2 -!! write(*,'(a,i0)')'PASS ',i -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! !>>> rewind directory stream -!! call system_rewinddir(dir) -!! enddo -!! !>>> close directory stream -!! call system_closedir(dir,ierr) -!! -!! end program demo_system_rewinddir -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_rewinddir(dir) - TYPE(C_PTR), VALUE :: dir - - INTERFACE - SUBROUTINE c_rewinddir(c_dir) BIND(c, name="rewinddir") - IMPORT C_CHAR, C_INT, C_PTR - TYPE(C_PTR), VALUE :: c_dir - END SUBROUTINE c_rewinddir - END INTERFACE - - CALL c_rewinddir(dir) - -END SUBROUTINE system_rewinddir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_closedir(3f) - [M_system:QUERY_FILE] close a directory stream by calling closedir(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_closedir(dir,ierr) -!! -!! type(c_ptr) :: dir -!! integer,intent(out) :: ierr -!!##DESCRIPTION -!! The SYSTEM_CLOSEDIR(3f) function closes the directory stream referred to by the argument DIR. -!! Upon return, the value of DIR may no longer point to an accessible object. -!!##OPTIONS -!! dir directory stream pointer opened by SYSTEM_OPENDIR(3f). -!! ierr Upon successful completion, SYSTEM_CLOSEDIR(3f) returns 0; -!! otherwise, an error has occurred. -!!##ERRORS -!! system_closedir(3f) may fail if: -!! -!! EBADF The dirp argument does not refer to an open directory stream. -!! EINTR The closedir() function was interrupted by a signal. -!!##EXAMPLE -!! -!! Sample program -!! -!! program demo_system_closedir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_closedir, system_rewinddir -!! use iso_c_binding, only : c_ptr -!! implicit none -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: ierr -!! !--- open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! !--- read directory stream -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! call system_rewinddir(dir) -!! !--- close directory stream -!! call system_closedir(dir,ierr) -!! end program demo_system_closedir -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_closedir(dir, ierr) - USE ISO_C_BINDING - TYPE(C_PTR), VALUE :: dir - INTEGER, INTENT(out), OPTIONAL :: ierr - INTEGER :: ierr_local - - INTERFACE - FUNCTION c_closedir(c_dir) BIND(c, name="closedir") RESULT(c_err) - IMPORT C_CHAR, C_INT, C_PTR - TYPE(C_PTR), VALUE :: c_dir - INTEGER(kind=C_INT) :: c_err - END FUNCTION c_closedir - END INTERFACE - - ierr_local = c_closedir(dir) - IF (PRESENT(ierr)) THEN - ierr = ierr_local - ELSE - IF (ierr_local /= 0) THEN - PRINT *, "*system_closedir* error", ierr_local - STOP 3 - END IF - END IF - -END SUBROUTINE system_closedir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_putenv(3f) - [M_system:ENVIRONMENT] set environment variable from Fortran by calling putenv(3c) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_putenv(string, err) -!! -!! character(len=*),intent(in) :: string -!! integer, optional, intent(out) :: err -!! -!!##DESCRIPTION -!! The system_putenv() function adds or changes the value of environment variables. -!! -!!##OPTIONS -!! string string of format "NAME=value". -!! If name does not already exist in the environment, then string is added to the environment. -!! If name does exist, then the value of name in the environment is changed to value. -!! The string passed to putenv(3c) becomes part of the environment, -!! so this routine creates a string each time it is called that increases the amount of -!! memory the program uses. -!! err The system_putenv() function returns zero on success, or nonzero if an error occurs. -!! A non-zero error usually indicates sufficient memory does not exist to store the -!! variable. -!! -!!##EXAMPLE -!! -!! Sample setting an environment variable from Fortran: -!! -!! program demo_system_putenv -!! use M_system, only : system_putenv -!! use iso_c_binding -!! implicit none -!! integer :: ierr -!! ! -!! write(*,'(a)')'no environment variables containing "GRU":' -!! call execute_command_line('env|grep GRU') -!! ! -!! call system_putenv('GRU=this is the value',ierr) -!! write(*,'(a,i0)')'now "GRU" should be defined: ',ierr -!! call execute_command_line('env|grep GRU') -!! ! -!! call system_putenv('GRU2=this is the second value',ierr) -!! write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined: ',ierr -!! call execute_command_line('env|grep GRU') -!! ! -!! call system_putenv('GRU2',ierr) -!! call system_putenv('GRU',ierr) -!! write(*,'(a,i0)')'should be gone, varies with different putenv(3c): ',ierr -!! call execute_command_line('env|grep GRU') -!! write(*,'(a)')'system_unsetenv(3f) is a better way to remove variables' -!! ! -!! end program demo_system_putenv -!! -!! Results: -!! -!! no environment variables containing "GRU": -!! now "GRU" should be defined: 0 -!! GRU=this is the value -!! now "GRU" and "GRU2" should be defined: 0 -!! GRU2=this is the second value -!! GRU=this is the value -!! should be gone, varies with different putenv(3c): 0 -!! system_unsetenv(3f) is a better way to remove variables -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_putenv(string, err) - -! ident_22="@(#)M_system::system_putenv(3f): call putenv(3c)" - - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_string(*) - END FUNCTION - END INTERFACE - - CHARACTER(len=*), INTENT(in) :: string - INTEGER, OPTIONAL, INTENT(out) :: err - INTEGER :: loc_err - INTEGER :: i - - ! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit - CHARACTER(len=1, kind=C_CHAR), SAVE, POINTER :: memleak(:) - - ALLOCATE (memleak(LEN(string) + 1)) - DO i = 1, LEN(string) - memleak(i) = string(i:i) - END DO - memleak(LEN(string) + 1) = C_NULL_CHAR - - loc_err = c_putenv(memleak) - IF (PRESENT(err)) err = loc_err - -END SUBROUTINE system_putenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getenv(3f) - [M_system:ENVIRONMENT] get environment variable -!! from Fortran by calling get_environment_variable(3f) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_getenv(name,default) -!! -!! character(len=:),allocatable :: system_getenv -!! character(len=*),intent(in) :: name -!! character(len=*),intent(in),optional :: default -!! -!!##DESCRIPTION -!! The system_getenv() function gets the value of an environment variable. -!! -!!##OPTIONS -!! name Return the value of the specified environment variable or -!! blank if the variable is not defined. -!! default If the value returned would be blank this value will be used -!! instead. -!! -!!##EXAMPLE -!! -!! Sample setting an environment variable from Fortran: -!! -!! program demo_system_getenv -!! use M_system, only : system_getenv -!! implicit none -!! write(*,'("USER : ",a)')system_getenv('USER') -!! write(*,'("LOGNAME : ",a)')system_getenv('LOGNAME') -!! write(*,'("USERNAME : ",a)')system_getenv('USERNAME') -!! end program demo_system_getenv -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_getenv(name, default) RESULT(VALUE) - -! ident_23="@(#)M_system::system_getenv(3f): call get_environment_variable as a function with a default value(3f)" - - CHARACTER(len=*), INTENT(in) :: name - CHARACTER(len=*), INTENT(in), OPTIONAL :: default - INTEGER :: howbig - INTEGER :: stat - CHARACTER(len=:), ALLOCATABLE :: VALUE - - IF (NAME .NE. '') THEN - call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value - IF (howbig .NE. 0) THEN - SELECT CASE (stat) - CASE (1) ! print *, NAME, " is not defined in the environment. Strange..." - VALUE = '' - CASE (2) ! print *, "This processor doesn't support environment variables. Boooh!" - VALUE = '' - CASE default ! make string to hold value of sufficient size and get value - IF (ALLOCATED(VALUE)) DEALLOCATE (VALUE) - ALLOCATE (CHARACTER(len=MAX(howbig, 1)) :: VALUE) - CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, status=stat, trim_name=.TRUE.) - IF (stat .NE. 0) VALUE = '' - END SELECT - ELSE - VALUE = '' - END IF - ELSE - VALUE = '' - END IF - IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default - -END FUNCTION system_getenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! set_environment_variable(3f) - [M_system:ENVIRONMENT] call setenv(3c) to set environment variable -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine set_environment_variable(NAME, VALUE, STATUS) -!! -!! character(len=*) :: NAME -!! character(len=*) :: VALUE -!! integer, optional, intent(out) :: STATUS -!! -!!##DESCRIPTION -!! The set_environment_variable() procedure adds or changes the value of environment variables. -!! -!!##OPTIONS -!! NAME If name does not already exist in the environment, then string is added to the environment. -!! If name does exist, then the value of name in the environment is changed to value. -!! VALUE Value to assign to environment variable NAME -!! STATUS returns zero on success, or nonzero if an error occurs. -!! A non-zero error usually indicates sufficient memory does not exist to store the -!! variable. -!! -!!##EXAMPLE -!! -!! Sample setting an environment variable from Fortran: -!! -!! program demo_set_environment_variable -!! use M_system, only : set_environment_variable -!! use iso_c_binding -!! implicit none -!! integer :: ierr -!! !! -!! write(*,'(a)')'no environment variables containing "GRU":' -!! call execute_command_line('env|grep GRU') -!! !! -!! call set_environment_variable('GRU','this is the value',ierr) -!! write(*,'(a,i0)')'now "GRU" should be defined, status=',ierr -!! call execute_command_line('env|grep GRU') -!! !! -!! call set_environment_variable('GRU2','this is the second value',ierr) -!! write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined, status =',ierr -!! !! -!! call execute_command_line('env|grep GRU') -!! end program demo_set_environment_variable -!! -!! Results: -!! -!! no environment variables containing "GRU": -!! now "GRU" should be defined, status=0 -!! GRU=this is the value -!! now "GRU" and "GRU2" should be defined, status =0 -!! GRU2=this is the second value -!! GRU=this is the value -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE set_environment_variable(NAME, VALUE, STATUS) - -! ident_24="@(#)M_system::set_environment_variable(3f): call setenv(3c) to set environment variable" - - CHARACTER(len=*) :: NAME - CHARACTER(len=*) :: VALUE - INTEGER, OPTIONAL, INTENT(out) :: STATUS - INTEGER :: loc_err - - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_name(*) - CHARACTER(kind=C_CHAR) :: c_VALUE(*) - END FUNCTION - END INTERFACE - - loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) - IF (PRESENT(STATUS)) STATUS = loc_err -END SUBROUTINE set_environment_variable -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_clearenv(3f) - [M_system:ENVIRONMENT] clear environment by calling clearenv(3c) -!! (LICENSE:PD) -!! -!! -!!##SYNOPSIS -!! -!! subroutine system_clearenv(ierr) -!! -!! integer,intent(out),optional :: ierr -!! -!!##DESCRIPTION -!! The clearenv() procedure clears the environment of all name-value -!! pairs. Typically used in security-conscious applications or ones where -!! configuration control requires ensuring specific variables are set. -!! -!!##RETURN VALUES -!! ierr returns zero on success, and a nonzero value on failure. Optional. -!! If not present and an error occurs the program stops. -!! -!!##EXAMPLE -!! -!! -!! Sample program: -!! -!! program demo_system_clearenv -!! use M_system, only : system_clearenv -!! implicit none -!! ! environment before clearing -!! call execute_command_line('env|wc') -!! ! environment after clearing (not necessarily blank!!) -!! call system_clearenv() -!! call execute_command_line('env') -!! end program demo_system_clearenv -!! -!! Typical output: -!! -!! 89 153 7427 -!! PWD=/home/urbanjs/V600 -!! SHLVL=1 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_clearenv(ierr) -! emulating because not available on some platforms - -! ident_25="@(#)M_system::system_clearenv(3f): emulate clearenv(3c) to clear environment" - - INTEGER, INTENT(out), OPTIONAL :: ierr - CHARACTER(len=:), ALLOCATABLE :: string - INTEGER :: ierr_local1, ierr_local2 - ierr_local2 = 0 - INFINITE: DO - CALL system_initenv() ! important -- changing table causes undefined behavior so reset after each unsetenv - string = system_readenv() ! get first name=value pair - IF (string .EQ. '') EXIT INFINITE - CALL system_unsetenv(string(1:INDEX(string, '=') - 1), ierr_local1) ! remove first name=value pair - IF (ierr_local1 .NE. 0) ierr_local2 = ierr_local1 - END DO INFINITE - IF (PRESENT(ierr)) THEN - ierr = ierr_local2 - ELSEIF (ierr_local2 .NE. 0) THEN ! if error occurs and not being returned, stop - WRITE (*, *) '*system_clearenv* error=', ierr_local2 - STOP - END IF -END SUBROUTINE system_clearenv -!--subroutine system_clearenv(ierr) -!--! clearenv(3c) not available on some systems I tried -!--! Found reference that if it is unavailable the assignment -! "environ = NULL;" will probably do but emulating instead -!--$@ (#)M_system::system_clearenv(3f): call clearenv(3c) to clear -! "environment" -!--integer,intent(out),optional :: ierr -!-- integer :: ierr_local -!-- -!--interface -!-- integer(kind=c_int) function c_clearenv() bind(C,NAME="clearenv") -!-- import c_int -!-- end function -!--end interface -!-- -!-- ierr_local = c_clearenv() -!-- if(present(ierr))then -!-- ierr=ierr_local -!-- elseif(ierr_local.ne.0)then ! if error occurs and not being returned, stop -!-- write(*,*)'*system_clearenv* error=',ierr_local -!-- stop -!-- endif -!-- -!--end subroutine system_clearenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_unsetenv(3f) - [M_system:ENVIRONMENT] delete an environment variable by calling unsetenv(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_unsetenv(name,ierr) -!! -!! character(len=*),intent(in) :: name -!! integer,intent(out),optional :: ierr -!! -!!##DESCRIPTION -!! -!! The system_unsetenv(3f) function deletes the variable name from the -!! environment. -!! -!!##OPTIONS -!! name name of variable to delete. -!! If name does not exist in the environment, then the -!! function succeeds, and the environment is unchanged. -!! -!! ierr The system_unsetenv(3f) function returns zero on success, or -1 on error. -!! name is NULL, points to a string of length 0, or contains an '=' character. -!! Insufficient memory to add a new variable to the environment. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_unsetenv -!! use M_system, only : system_unsetenv, system_putenv -!! implicit none -!! call system_putenv('GRU=this is the value') -!! write(*,'(a)')'The variable GRU should be set' -!! call execute_command_line('env|grep GRU') -!! call system_unsetenv('GRU') -!! write(*,'(a)')'The variable GRU should not be set' -!! call execute_command_line('env|grep GRU') -!! end program demo_system_unsetenv -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_unsetenv(name, ierr) - -! ident_26="@(#)M_system::system_unsetenv(3f): call unsetenv(3c) to remove variable from environment" - - CHARACTER(len=*), INTENT(in) :: name - INTEGER, INTENT(out), OPTIONAL :: ierr - INTEGER :: ierr_local - -! int unsetenv(void) - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") - IMPORT C_INT, C_CHAR - CHARACTER(len=1, kind=C_CHAR) :: c_name(*) - END FUNCTION - END INTERFACE - - ierr_local = c_unsetenv(str2_carr(TRIM(NAME))) - - IF (PRESENT(ierr)) THEN - ierr = ierr_local - ELSEIF (ierr_local .NE. 0) THEN ! if error occurs and not being returned, stop - WRITE (*, *) '*system_unsetenv* error=', ierr_local - STOP - END IF - -END SUBROUTINE system_unsetenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_readenv(3f) - [M_system:ENVIRONMENT] step thru and read environment table -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_readenv() result(string) -!! -!! character(len=:),allocatable :: string -!!##DESCRIPTION -!! A simple interface allows reading the environment variable table of the process. Call -!! system_initenv(3f) to initialize reading the environment table, then call system_readenv(3f) can -!! be called until a blank line is returned. If more than one thread -!! reads the environment or the environment is changed while being read the results are undefined. -!!##OPTIONS -!! string the string returned from the environment of the form "NAME=VALUE" -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_readenv -!! use M_system, only : system_initenv, system_readenv -!! character(len=:),allocatable :: string -!! call system_initenv() -!! do -!! string=system_readenv() -!! if(string.eq.'')then -!! exit -!! else -!! write(*,'(a)')string -!! endif -!! enddo -!! end program demo_system_readenv -!! -!! Sample results: -!! -!! USERDOMAIN_ROAMINGPROFILE=buzz -!! HOMEPATH=\Users\JSU -!! APPDATA=C:\Users\JSU\AppData\Roaming -!! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man::: -!! DISPLAYNUM=0 -!! ProgramW6432=C:\Program Files -!! HOSTNAME=buzz -!! XKEYSYMDB=/usr/share/X11/XKeysymDB -!! PUBLISH_CMD= -!! OnlineServices=Online Services -!! : -!! : -!! : -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_readenv() RESULT(string) - -! ident_27="@(#)M_system::system_readenv(3f): read next entry from environment table" - - CHARACTER(len=:), ALLOCATABLE :: string - CHARACTER(kind=C_CHAR) :: c_buff(longest_env_variable + 1) - - INTERFACE - SUBROUTINE c_readenv(c_string) BIND(C, NAME='my_readenv') - IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T - CHARACTER(kind=C_CHAR), INTENT(out) :: c_string(*) - END SUBROUTINE c_readenv - END INTERFACE - - c_buff = ' ' - c_buff(longest_env_variable + 1:longest_env_variable + 1) = C_NULL_CHAR - CALL c_readenv(c_buff) - string = TRIM(arr2str(c_buff)) - -END FUNCTION system_readenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! fileglob(3f) - [M_system:QUERY_FILE] Read output of an ls(1) command from Fortran -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine fileglob(glob,list) -!! -!! character(len=*),intent(in) :: glob -!! character(len=*),pointer :: list(:) -!! -!!##DESCRIPTION -!! Non-portable procedure uses the shell and the ls(1) command to expand a filename -!! and returns a pointer to a list of expanded filenames. -!! -!!##OPTIONS -!! glob Pattern for the filenames (like: *.txt) -!! list Allocated list of filenames (returned), the caller must deallocate it. -!! -!!##EXAMPLE -!! -!! Read output of an ls(1) command from Fortran -!! -!! program demo_fileglob ! simple unit test -!! call tryit('*.*') -!! call tryit('/tmp/__notthere.txt') -!! contains -!! -!! subroutine tryit(string) -!! use M_system, only : fileglob -!! character(len=255),pointer :: list(:) -!! character(len=*) :: string -!! call fileglob(string, list) -!! write(*,*)'Files:',size(list) -!! write(*,'(a)')(trim(list(i)),i=1,size(list)) -!! deallocate(list) -!! end subroutine tryit -!! -!! end program demo_fileglob ! simple unit test -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE fileglob(glob, list) ! NON-PORTABLE AT THIS POINT. REQUIRES ls(1) command, assumes 1 line per file -! The length of the character strings in list() must be long enough for the filenames. -! The list can be zero names long, it is still allocated. - IMPLICIT NONE - -! ident_28="@(#)M_system::fileglob(3f): Returns list of files using a file globbing pattern" - -!----------------------------------------------------------------------------------------------------------------------------------- - CHARACTER(len=*), INTENT(in) :: glob ! Pattern for the filenames (like: *.txt) - CHARACTER(len=*), POINTER :: list(:) ! Allocated list of filenames (returned), the caller must deallocate it. -!----------------------------------------------------------------------------------------------------------------------------------- - CHARACTER(len=255) :: tmpfile ! scratch filename to hold expanded file list - CHARACTER(len=255) :: cmd ! string to build system command in - INTEGER :: iotmp ! needed to open unique scratch file for holding file list - INTEGER :: i, ios, icount - write(tmpfile,'(*(g0))')'/tmp/__filelist_',timestamp(),'_',system_getpid() ! preliminary scratch file name - cmd = 'ls -d '//TRIM(glob)//'>'//TRIM(tmpfile)//' ' ! build command string - CALL execute_command_line(cmd) ! Execute the command specified by the string. - OPEN (newunit=iotmp, file=tmpfile, iostat=ios) ! open unique scratch filename - IF (ios .NE. 0) RETURN ! the open failed - icount = 0 ! number of filenames in expanded list - DO ! count the number of lines (assumed ==files) so know what to allocate - READ (iotmp, '(a)', iostat=ios) ! move down a line in the file to count number of lines - IF (ios .NE. 0) EXIT ! hopefully, this is because end of file was encountered so done - icount = icount + 1 ! increment line count - END DO - REWIND (iotmp) ! rewind file list so can read and store it - ALLOCATE (list(icount)) ! allocate and fill the array - DO i = 1, icount - READ (iotmp, '(a)') list(i) ! read a filename from a line - END DO - CLOSE (iotmp, status='delete', iostat=ios) ! close and delete scratch file -END SUBROUTINE fileglob -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_uname(3f) - [M_system] call a C wrapper that calls uname(3c) to get current system information from Fortran -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_uname(WHICH,NAMEOUT) -!! -!! character(KIND=C_CHAR),intent(in) :: WHICH -!! character(len=*),intent(out) :: NAMEOUT -!!##DESCRIPTION -!! Given a letter, return a corresponding description of the current operating system. -!! The NAMEOUT variable is assumed sufficiently large enough to hold the value. -!! -!! s return the kernel name -!! r return the kernel release -!! v return the kernel version -!! n return the network node hostname -!! m return the machine hardware name -!! T test mode -- print all information, in the following order - srvnm -!! -!!##EXAMPLE -!! -!! Call uname(3c) from Fortran -!! -!! program demo_system_uname -!! use M_system, only : system_uname -!! implicit none -!! integer,parameter :: is=100 -!! integer :: i -!! character(len=*),parameter :: letters='srvnmxT' -!! character(len=is) :: string=' ' -!! -!! do i=1,len(letters) -!! write(*,'(80("="))') -!! call system_uname(letters(i:i),string) -!! write(*,*)'=====> TESTING system_uname('//letters(i:i)//')--->'//trim(string) -!! enddo -!! -!! end program demo_system_uname -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_uname(WHICH, NAMEOUT) - IMPLICIT NONE - -! ident_29="@(#)M_system::system_uname(3f): call my_uname(3c) which calls uname(3c)" - - CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH - CHARACTER(len=*), INTENT(out) :: NAMEOUT - -! describe the C routine to Fortran -! void system_uname(char *which, char *buf, int *buflen); - INTERFACE - SUBROUTINE system_uname_c(WHICH, BUF, BUFLEN) BIND(C, NAME='my_uname') - IMPORT C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH - CHARACTER(KIND=C_CHAR), INTENT(out) :: BUF(*) - INTEGER(kind=C_INT), INTENT(in) :: BUFLEN - END SUBROUTINE system_uname_c - END INTERFACE - - NAMEOUT = 'unknown' - CALL system_uname_c(WHICH, NAMEOUT, INT(LEN(NAMEOUT), KIND(0_C_INT))) - -END SUBROUTINE system_uname -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_gethostname(3f) - [M_system:QUERY] get name of current host -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_gethostname(string,ierr) -!! -!! character(len=:),allocatable,intent(out) :: NAME -!! integer,intent(out) :: IERR -!!##DESCRIPTION -!! The system_gethostname(3f) procedure returns the standard host -!! name for the current machine. -!! -!!##OPTIONS -!! string returns the hostname. Must be an allocatable CHARACTER variable. -!! ierr Upon successful completion, 0 shall be returned; otherwise, -1 -!! shall be returned. -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_gethostname -!! use M_system, only : system_gethostname -!! implicit none -!! character(len=:),allocatable :: name -!! integer :: ierr -!! call system_gethostname(name,ierr) -!! if(ierr.eq.0)then -!! write(*,'("hostname[",a,"]")')name -!! else -!! write(*,'(a)')'ERROR: could not get hostname' -!! endif -!! end program demo_system_gethostname -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_gethostname(NAME, IERR) - IMPLICIT NONE - -! ident_30="@(#)M_system::system_gethostname(3f): get name of current host by calling gethostname(3c)" - - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: NAME - INTEGER, INTENT(out) :: IERR - CHARACTER(kind=C_CHAR, len=1) :: C_BUFF(HOST_NAME_MAX + 1) - -! describe the C routine to Fortran -!int gethostname(char *name, size_t namelen); - INTERFACE - FUNCTION system_gethostname_c(c_buf, c_buflen) BIND(C, NAME='gethostname') - IMPORT C_CHAR, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: system_gethostname_c - CHARACTER(KIND=C_CHAR), INTENT(out) :: c_buf(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_buflen - END FUNCTION system_gethostname_c - END INTERFACE - - C_BUFF = ' ' - ierr = system_gethostname_c(C_BUFF, HOST_NAME_MAX) ! Host names are limited to {HOST_NAME_MAX} bytes. - NAME = TRIM(arr2str(C_BUFF)) - -END SUBROUTINE system_gethostname -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getlogin(3f) - [M_system:QUERY] get login name -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_getlogin() result (fname) -!! -!! character(len=:),allocatable :: FNAME -!! -!!##DESCRIPTION -!! -!! The system_getlogin(3f) function returns a string containing the user -!! name associated by the login activity with the controlling terminal -!! of the current process. Otherwise, it returns a null string and sets -!! errno to indicate the error. -!! -!! Three names associated with the current process can be determined: -!! -!! o system_getpwuid(system_getuid()) returns the name associated with the real user ID of the process. -!! o system_getpwuid(system_geteuid()) returns the name associated with the effective user ID of the process -!! o system_getlogin() returns the name associated with the current login activity -!! -!!##RETURN VALUE -!! fname returns the login name. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getlogin -!! use M_system, only : system_getlogin -!! implicit none -!! character(len=:),allocatable :: name -!! name=system_getlogin() -!! write(*,'("login[",a,"]")')name -!! end program demo_system_getlogin -!! -!! Results: -!! -!! login[JSU] -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -!-- The following example calls the getlogin() function to obtain the name of the user associated with the calling process, -!-- and passes this information to the getpwnam() function to get the associated user database information. -!-- ... -!-- char *lgn; -!-- struct passwd *pw; -!-- ... -!-- if ((lgn = getlogin()) == NULL || (pw = getpwnam(lgn)) == NULL) { -!-- fprintf(stderr, "Get of user information failed.\n"); exit(1); -!-- } -!--APPLICATION USAGE -!--SEE ALSO -!-- getpwnam(), getpwuid(), system_geteuid(), getuid() -FUNCTION system_getlogin() RESULT(fname) - CHARACTER(len=:), ALLOCATABLE :: fname - TYPE(C_PTR) :: username - - INTERFACE - FUNCTION c_getlogin() BIND(c, name="getlogin") RESULT(c_username) - IMPORT C_INT, C_PTR - TYPE(C_PTR) :: c_username - END FUNCTION c_getlogin - END INTERFACE - - username = c_getlogin() - IF (.NOT. C_ASSOCIATED(username)) THEN - !! in windows 10 subsystem running Ubunto does not work - !!write(*,'(a)')'*system_getlogin* Error getting username. not associated' - !!fname=c_null_char - fname = system_getpwuid(system_geteuid()) - ELSE - fname = c2f_string(username) - END IF - -END FUNCTION system_getlogin -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_perm(3f) - [M_system:QUERY_FILE] get file type and permission as a string -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_perm(mode) result (perms) -!! -!! integer(kind=int64),intent(in) :: MODE -!! character(len=:),allocatable :: PERMS -!! -!!##DESCRIPTION -!! -!! The system_perm(3f) function returns a string containing the type -!! and permission of a file implied by the value of the mode value. -!! -!!##RETURN VALUE -!! PERMS returns the permission string in a format similar to that -!! used by Unix commands such as ls(1). -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_perm -!! use M_system, only : system_perm, system_stat -!! use,intrinsic :: iso_fortran_env, only : int64 -!! implicit none -!! character(len=4096) :: string -!! integer(kind=int64) :: values(13) -!! integer :: ierr -!! character(len=:),allocatable :: perms -!! values=0 -!! ! get pathname from command line -!! call get_command_argument(1, string) -!! ! get pathname information -!! call system_stat(string,values,ierr) -!! if(ierr.eq.0)then -!! ! convert permit mode to a string -!! perms=system_perm(values(3)) -!! ! print permits as a string, decimal value, and octal value -!! write(*,'("for ",a," permits[",a,"]",1x,i0,1x,o0)') & -!! & trim(string),perms,values(3),values(3) -!! endif -!! end program demo_system_perm -!! -!! Results: -!! -!! demo_system_perm /tmp -!! -!! for /tmp permits[drwxrwxrwx --S] 17407 41777 -!! -!!##AUTHOR -!! John S. Urban -!! -!!##LICENSE -!! Public Domain -FUNCTION system_perm(mode) RESULT(perms) - CLASS(*), INTENT(in) :: mode - CHARACTER(len=:), ALLOCATABLE :: perms - TYPE(C_PTR) :: permissions - INTEGER(kind=C_LONG) :: mode_local - INTERFACE - FUNCTION c_perm(c_mode) BIND(c, name="my_get_perm") RESULT(c_permissions) - IMPORT C_INT, C_PTR, C_LONG - INTEGER(kind=C_LONG), VALUE :: c_mode - TYPE(C_PTR) :: c_permissions - END FUNCTION c_perm - END INTERFACE - - mode_local = INT(anyinteger_to_64bit(mode), kind=C_LONG) - permissions = c_perm(mode_local) - IF (.NOT. C_ASSOCIATED(permissions)) THEN - WRITE (*, '(a)') '*system_perm* Error getting permissions. not associated' - perms = C_NULL_CHAR - ELSE - perms = c2f_string(permissions) - END IF - -END FUNCTION system_perm -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getgrgid(3f) - [M_system:QUERY] get groupd name associated with a GID -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_getgrgid(gid) result (gname) -!! -!! class(*),intent(in) :: gid ! any INTEGER type -!! character(len=:),allocatable :: gname -!! -!!##DESCRIPTION -!! -!! The system_getlogin() function returns a string containing the group -!! name associated with the given GID. If no match is found -!! it returns a null string and sets errno to indicate the error. -!! -!!##OPTION -!! gid GID to try to look up associated group for. Can be of any -!! INTEGER type. -!! -!!##RETURN VALUE -!! gname returns the group name. Blank if an error occurs -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getgrgid -!! use M_system, only : system_getgrgid -!! use M_system, only : system_getgid -!! implicit none -!! character(len=:),allocatable :: name -!! name=system_getgrgid( system_getgid() ) -!! write(*,'("group[",a,"] for ",i0)')name,system_getgid() -!! end program demo_system_getgrgid -!! -!! Results: -!! -!! group[default] for 197121 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_getgrgid(gid) RESULT(gname) - CLASS(*), INTENT(in) :: gid - CHARACTER(len=:), ALLOCATABLE :: gname - CHARACTER(kind=C_CHAR, len=1) :: groupname(4097) ! assumed long enough for any groupname - INTEGER :: ierr - INTEGER(kind=C_LONG_LONG) :: gid_local - - INTERFACE - function c_getgrgid(c_gid,c_groupname) bind(c,name="my_getgrgid") result(c_ierr) - IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG - INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_gid - CHARACTER(kind=C_CHAR), INTENT(out) :: c_groupname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_getgrgid - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - gid_local = anyinteger_to_64bit(gid) - ierr = c_getgrgid(gid_local, groupname) - IF (ierr .EQ. 0) THEN - gname = TRIM(arr2str(groupname)) - ELSE - gname = '' - END IF -!----------------------------------------------------------------------------------------------------------------------------------- -END FUNCTION system_getgrgid -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getpwuid(3f) - [M_system:QUERY] get login name associated with a UID -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_getpwuid(uid) result (uname) -!! -!! class(*),intent(in) :: uid ! any INTEGER type -!! character(len=:),allocatable :: uname -!! -!!##DESCRIPTION -!! -!! The system_getpwuid() function returns a string containing the user -!! name associated with the given UID. If no match is found it returns -!! a null string and sets errno to indicate the error. -!! -!!##OPTION -!! uid UID to try to look up associated username for. Can be of any -!! INTEGER type. -!! -!!##RETURN VALUE -!! uname returns the login name. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getpwuid -!! use M_system, only : system_getpwuid -!! use M_system, only : system_getuid -!! use,intrinsic :: iso_fortran_env, only : int64 -!! implicit none -!! character(len=:),allocatable :: name -!! integer(kind=int64) :: uid -!! uid=system_getuid() -!! name=system_getpwuid(uid) -!! write(*,'("login[",a,"] has UID ",i0)')name,uid -!! end program demo_system_getpwuid -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_getpwuid(uid) RESULT(uname) - CLASS(*), INTENT(in) :: uid - CHARACTER(len=:), ALLOCATABLE :: uname - CHARACTER(kind=C_CHAR, len=1) :: username(4097) ! assumed long enough for any username - INTEGER :: ierr - INTEGER(kind=C_LONG_LONG) :: uid_local - - INTERFACE - function c_getpwuid(c_uid,c_username) bind(c,name="my_getpwuid") result(c_ierr) - IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG - INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_uid - CHARACTER(kind=C_CHAR), INTENT(out) :: c_username(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_getpwuid - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - uid_local = anyinteger_to_64bit(uid) - ierr = c_getpwuid(uid_local, username) - IF (ierr .EQ. 0) THEN - uname = TRIM(arr2str(username)) - ELSE - uname = '' - END IF -!----------------------------------------------------------------------------------------------------------------------------------- -END FUNCTION system_getpwuid -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -PURE FUNCTION arr2str(array) RESULT(string) - -! ident_31="@(#)M_system::arr2str(3fp): function copies null-terminated char array to string" - - CHARACTER(len=1), INTENT(in) :: array(:) - CHARACTER(len=SIZE(array)) :: string - INTEGER :: i - - string = ' ' - DO i = 1, SIZE(array) - IF (array(i) .EQ. CHAR(0)) THEN - EXIT - ELSE - string(i:i) = array(i) - END IF - END DO - -END FUNCTION arr2str -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -PURE FUNCTION str2_carr(string) RESULT(array) - -! ident_32="@(#)M_system::str2_carr(3fp): function copies string to null terminated char array" - - CHARACTER(len=*), INTENT(in) :: string - CHARACTER(len=1, kind=C_CHAR) :: array(LEN(string) + 1) - INTEGER :: i - - DO i = 1, LEN_TRIM(string) - array(i) = string(i:i) - END DO - array(i:i) = C_NULL_CHAR - -END FUNCTION str2_carr -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -FUNCTION C2F_string(c_string_pointer) RESULT(f_string) - -! gets a C string (pointer), and returns the corresponding Fortran string up to 4096(max_len) characters; -! If the C string is null, it returns string C "null" character: - - TYPE(C_PTR), INTENT(in) :: c_string_pointer - CHARACTER(len=:), ALLOCATABLE :: f_string - CHARACTER(kind=C_CHAR), DIMENSION(:), POINTER :: char_array_pointer => NULL() - INTEGER, PARAMETER :: max_len = 4096 - CHARACTER(len=max_len) :: aux_string - INTEGER :: i - INTEGER :: length - - length = 0 - CALL C_F_POINTER(c_string_pointer, char_array_pointer, [max_len]) - - IF (.NOT. ASSOCIATED(char_array_pointer)) THEN - IF (ALLOCATED(f_string)) DEALLOCATE (f_string) - ALLOCATE (CHARACTER(len=4) :: f_string) - f_string = C_NULL_CHAR - RETURN - END IF - - aux_string = " " - - DO i = 1, max_len - IF (char_array_pointer(i) == C_NULL_CHAR) THEN - length = i - 1; EXIT - END IF - aux_string(i:i) = char_array_pointer(i) - END DO - - IF (ALLOCATED(f_string)) DEALLOCATE (f_string) - ALLOCATE (CHARACTER(len=length) :: f_string) - f_string = aux_string(1:length) -END FUNCTION C2F_string -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! SYSTEM_STAT - [M_system:QUERY_FILE] Get file status information -!! (LICENSE:PD) -!! -!!##SYNTAX -!! CALL SYSTEM_STAT(NAME, VALUES [, STATUS],[DEBUG]) -!! -!! character(len=*),intent(in) :: NAME -!! integer(kind=int64),intent(out) :: values(13) -!! integer,optional,intent(out) :: status -!! integer,intent(in) :: debug -!! -!!##DESCRIPTION -!! -!! This function returns information about a file. No permissions are -!! required on the file itself, but execute (search) permission is required -!! on all of the directories in path that lead to the file. The elements -!! that are obtained and stored in the array VALUES: -!! -!! VALUES(1) Device ID -!! VALUES(2) Inode number -!! VALUES(3) File mode -!! VALUES(4) Number of links -!! VALUES(5) Owner uid -!! VALUES(6) Owner gid -!! VALUES(7) ID of device containing directory entry for file (0 if not available) -!! VALUES(8) File size (bytes) -!! VALUES(9) Last access time as a Unix Epoch time rounded to seconds -!! VALUES(10) Last modification time as a Unix Epoch time rounded to seconds -!! VALUES(11) Last file status change time as a Unix Epoch time rounded to seconds -!! VALUES(12) Preferred I/O block size (-1 if not available) -!! VALUES(13) Number of blocks allocated (-1 if not available) -!! -!! Not all these elements are relevant on all systems. If an element is -!! not relevant, it is returned as 0. -!! -!!##OPTIONS -!! -!! NAME The type shall be CHARACTER, of the default kind and a valid -!! path within the file system. -!! VALUES The type shall be INTEGER(8), DIMENSION(13). -!! STATUS (Optional) status flag of type INTEGER(4). Returns 0 on success -!! and a system specific error code otherwise. -!! DEBUG (Optional) print values being returned from C routine being -!! called if value of 0 is used -!! -!!##EXAMPLE -!! -!! program demo_system_stat -!! -!! use M_system, only : system_stat, system_getpwuid, system_getgrgid -!! use M_time, only : fmtdate, u2d -!! use, intrinsic :: iso_fortran_env, only : int32, int64 -!! implicit none -!! -!! integer(kind=int64) :: buff(13) -!! integer(kind=int32) :: status -!! character(len=*),parameter :: fmt_date='year-month-day hour:minute:second' -!! -!! integer(kind=int64) :: & -!! Device_ID, Inode_number, File_mode, Number_of_links, -!! Owner_uid, & -!! Owner_gid, Directory_device, File_size, Last_access, -!! Last_modification,& -!! Last_status_change, Preferred_block_size, Number_of_blocks_allocated -!! equivalence & -!! ( buff(1) , Device_ID ) , & -!! ( buff(2) , Inode_number ) , & -!! ( buff(3) , File_mode ) , & -!! ( buff(4) , Number_of_links ) , & -!! ( buff(5) , Owner_uid ) , & -!! ( buff(6) , Owner_gid ) , & -!! ( buff(7) , Directory_device ) , & -!! ( buff(8) , File_size ) , & -!! ( buff(9) , Last_access ) , & -!! ( buff(10) , Last_modification ) , & -!! ( buff(11) , Last_status_change ) , & -!! ( buff(12) , Preferred_block_size ) , & -!! ( buff(13) , Number_of_blocks_allocated ) -!! -!! CALL SYSTEM_STAT("/etc/hosts", buff, status) -!! -!! if (status == 0) then -!! write (*, FMT="('Device ID(hex/decimal):', & -!! & T30, Z0,'h/',I0,'d')") buff(1),buff(1) -!! write (*, FMT="('Inode number:', & -!! & T30, I0)") buff(2) -!! write (*, FMT="('File mode (octal):', & -!! & T30, O19)") buff(3) -!! write (*, FMT="('Number of links:', & -!! & T30, I0)") buff(4) -!! write (*, FMT="('Owner''s uid/username:', & -!! & T30, I0,1x, A)") buff(5), system_getpwuid(buff(5)) -!! write (*, FMT="('Owner''s gid/group:', & -!! & T30, I0,1x, A)") buff(6), system_getgrgid(buff(6)) -!! write (*, FMT="('Device where located:', & -!! & T30, I0)") buff(7) -!! write (*, FMT="('File size(bytes):', & -!! & T30, I0)") buff(8) -!! write (*, FMT="('Last access time:', & -!! & T30, I0,1x, A)") buff(9), fmtdate(u2d(int(buff(9))),fmt_date) -!! write (*, FMT="('Last modification time:', & -!! & T30, I0,1x, A)") buff(10),fmtdate(u2d(int(buff(10))),fmt_date) -!! write (*, FMT="('Last status change time:', & -!! & T30, I0,1x, A)") buff(11),fmtdate(u2d(int(buff(11))),fmt_date) -!! write (*, FMT="('Preferred block size(bytes):', & -!! & T30, I0)") buff(12) -!! write (*, FMT="('No. of blocks allocated:', & -!! & T30, I0)") buff(13) -!! endif -!! -!! end program demo_system_stat -!! -!! Results: -!! -!! Device ID(hex/decimal): 3E6BE045h/1047257157d -!! Inode number: 1407374886070599 -!! File mode (octal): 100750 -!! Number of links: 1 -!! Owner uid/username: 18 SYSTEM -!! Owner gid/group: 18 SYSTEM -!! Device where located: 0 -!! File size(bytes): 824 -!! Last access time: 1557983191 2019-05-16 01:06:31 -!! Last modification time: 1557983191 2019-05-16 01:06:31 -!! Last status change time: 1557983532 2019-05-16 01:12:12 -!! Preferred block size(bytes): 65536 -!! No. of blocks allocated: 4 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -SUBROUTINE system_stat(pathname, values, ierr) - IMPLICIT NONE - -! ident_33="@(#)M_system::system_stat(3f): call stat(3c) to get pathname information" - - CHARACTER(len=*), INTENT(in) :: pathname - - INTEGER(kind=INT64), INTENT(out) :: values(13) - INTEGER(kind=C_LONG) :: cvalues(13) - - INTEGER, OPTIONAL, INTENT(out) :: ierr - INTEGER(kind=C_INT) :: cierr - - INTERFACE - SUBROUTINE c_stat(buffer, cvalues, cierr, cdebug) BIND(c, name="my_stat") - IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT, C_LONG - CHARACTER(kind=C_CHAR), INTENT(in) :: buffer(*) - INTEGER(kind=C_LONG), INTENT(out) :: cvalues(*) - INTEGER(kind=C_INT) :: cierr - INTEGER(kind=C_INT), INTENT(in) :: cdebug - END SUBROUTINE c_stat - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - CALL c_stat(str2_carr(TRIM(pathname)), cvalues, cierr, 0_C_INT) - values = cvalues - IF (PRESENT(ierr)) THEN - ierr = cierr - END IF -END SUBROUTINE system_stat -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_dir(3f) - [M_io] return filenames in a directory matching specified wildcard string -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_dir(directory,pattern) -!! -!! character(len=*),intent(in),optional :: directory -!! character(len=*),intent(in),optional :: pattern -!! character(len=:),allocatable :: system_dir(:) -!! -!!##DESCRIPTION -!! returns an array of filenames in the specified directory matching -!! the wildcard string (which defaults to "*"). -!! -!!##OPTIONS -!! DIRECTORY name of directory to match filenames in. Defaults to ".". -!! PATTERN wildcard string matching the rules of the matchw(3f) function. Basically -!! o "*" matches anything -!! o "?" matches any single character -!! -!!##RETURNS -!! system_dir An array right-padded to the length of the longest -!! filename. Note that this means filenames actually containing -!! trailing spaces in their names may be incorrect. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_dir -!! use M_system, only : system_dir -!! implicit none -!! write(*, '(a)')system_dir(pattern='*.F90') -!! end program demo_system_dir -!! -!!##AUTHOR -!! John S. Urban -!! -!!##LICENSE -!! Public Domain -FUNCTION system_dir(directory, pattern) -!use M_system, only : system_opendir, system_readdir, system_rewinddir, system_closedir - USE ISO_C_BINDING - IMPLICIT NONE - CHARACTER(len=*), INTENT(in), OPTIONAL :: directory - CHARACTER(len=*), INTENT(in), OPTIONAL :: pattern - CHARACTER(len=:), ALLOCATABLE :: system_dir(:) - CHARACTER(len=:), ALLOCATABLE :: wild - TYPE(C_PTR) :: dir - CHARACTER(len=:), ALLOCATABLE :: filename - INTEGER :: i, ierr, icount, longest - longest = 0 - icount = 0 - IF (PRESENT(pattern)) THEN - wild = pattern - ELSE - wild = '*' - END IF - IF (PRESENT(directory)) THEN !--- open directory stream to read from - CALL system_opendir(directory, dir, ierr) - ELSE - CALL system_opendir('.', dir, ierr) - END IF - IF (ierr .EQ. 0) THEN - DO i = 1, 2 !--- read directory stream twice, first time to get size - DO - CALL system_readdir(dir, filename, ierr) - IF (filename .EQ. ' ') EXIT - IF (wild .NE. '*') THEN - IF (.NOT. matchw(filename, wild)) CYCLE ! Call a wildcard matching routine. - END IF - icount = icount + 1 - SELECT CASE (i) - CASE (1) - longest = MAX(longest, LEN(filename)) - CASE (2) - system_dir(icount) = filename - END SELECT - END DO - IF (i .EQ. 1) THEN - CALL system_rewinddir(dir) - IF (ALLOCATED(system_dir)) DEALLOCATE (system_dir) - ALLOCATE (CHARACTER(len=longest) :: system_dir(icount)) - icount = 0 - END IF - END DO - END IF - CALL system_closedir(dir, ierr) !--- close directory stream -END FUNCTION system_dir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! copied from M_strings.ff to make stand-alone github version -FUNCTION matchw(tame, wild) - -! ident_34="@(#)M_strings::matchw(3f): function compares text strings, one of which can have wildcards ('*' or '?')." - - LOGICAL :: matchw - CHARACTER(len=*) :: tame ! A string without wildcards - CHARACTER(len=*) :: wild ! A (potentially) corresponding string with wildcards - CHARACTER(len=LEN(tame) + 1) :: tametext - CHARACTER(len=LEN(wild) + 1) :: wildtext - CHARACTER(len=1), PARAMETER :: NULL = CHAR(0) - INTEGER :: wlen - INTEGER :: ti, wi - INTEGER :: i - CHARACTER(len=:), ALLOCATABLE :: tbookmark, wbookmark -! These two values are set when we observe a wildcard character. They -! represent the locations, in the two strings, from which we start once we've observed it. - tametext = tame//NULL - wildtext = wild//NULL - tbookmark = NULL - wbookmark = NULL - wlen = LEN(wild) - wi = 1 - ti = 1 - DO ! Walk the text strings one character at a time. - IF (wildtext(wi:wi) == '*') THEN ! How do you match a unique text string? - DO i = wi, wlen ! Easy: unique up on it! - IF (wildtext(wi:wi) .EQ. '*') THEN - wi = wi + 1 - ELSE - EXIT - END IF - END DO - IF (wildtext(wi:wi) .EQ. NULL) THEN ! "x" matches "*" - matchw = .TRUE. - RETURN - END IF - IF (wildtext(wi:wi) .NE. '?') THEN - ! Fast-forward to next possible match. - DO WHILE (tametext(ti:ti) .NE. wildtext(wi:wi)) - ti = ti + 1 - IF (tametext(ti:ti) .EQ. NULL) THEN - matchw = .FALSE. - RETURN ! "x" doesn't match "*y*" - END IF - END DO - END IF - wbookmark = wildtext(wi:) - tbookmark = tametext(ti:) - elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then - ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. - IF (wbookmark .NE. NULL) THEN - IF (wildtext(wi:) .NE. wbookmark) THEN - wildtext = wbookmark; - wlen = LEN_TRIM(wbookmark) - wi = 1 - ! Don't go this far back again. - IF (tametext(ti:ti) .NE. wildtext(wi:wi)) THEN - tbookmark = tbookmark(2:) - tametext = tbookmark - ti = 1 - CYCLE ! "xy" matches "*y" - ELSE - wi = wi + 1 - END IF - END IF - IF (tametext(ti:ti) .NE. NULL) THEN - ti = ti + 1 - CYCLE ! "mississippi" matches "*sip*" - END IF - END IF - matchw = .FALSE. - RETURN ! "xy" doesn't match "x" - END IF - ti = ti + 1 - wi = wi + 1 - IF (tametext(ti:ti) .EQ. NULL) THEN ! How do you match a tame text string? - IF (wildtext(wi:wi) .NE. NULL) THEN - DO WHILE (wildtext(wi:wi) == '*') ! The tame way: unique up on it! - wi = wi + 1 ! "x" matches "x*" - IF (wildtext(wi:wi) .EQ. NULL) EXIT - END DO - END IF - IF (wildtext(wi:wi) .EQ. NULL) THEN - matchw = .TRUE. - RETURN ! "x" matches "x" - END IF - matchw = .FALSE. - RETURN ! "x" doesn't match "xy" - END IF - END DO -END FUNCTION matchw -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!>NAME -!! -!! anyinteger_to_64bit(3f) - [M_anything] convert integer any kind to integer(kind=int64) -!! (LICENSE:PD) -!! -!!SYNOPSIS -!! -!! pure elemental function anyinteger_to_64bit(intin) result(ii38) -!! -!! integer(kind=int64) function anyinteger_to_64bit(value) -!! class(*),intent(in) :: intin -!! integer(kind=int8|int16|int32|int64) :: value -!! -!!DESCRIPTION -!! -!! This function uses polymorphism to allow arguments of different types -!! generically. It is used to create other procedures that can take -!! many scalar arguments as input options, equivalent to passing the -!! parameter VALUE as int(VALUE,0_int64). -!! -!!OPTIONS -!! -!! VALUEIN input argument of a procedure to convert to type INTEGER(KIND=int64). -!! May be of KIND kind=int8, kind=int16, kind=int32, kind=int64. -!!RESULTS -!! The value of VALUIN converted to INTEGER(KIND=INT64). -!!EXAMPLE -!! Sample program -!! -!! program demo_anyinteger_to_64bit -!! use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 -!! implicit none -!! ! call same function with many scalar input types -!! write(*,*)squarei(huge(0_int8)),huge(0_int8) , & -!! & '16129' -!! write(*,*)squarei(huge(0_int16)),huge(0_int16) , & -!! & '1073676289' -!! write(*,*)squarei(huge(0_int32)),huge(0_int32) , & -!! & '4611686014132420609' -!! write(*,*)squarei(huge(0_int64)),huge(0_int64) , & -!! & '85070591730234615847396907784232501249' -!! contains -!! ! -!! function squarei(invalue) -!! use M_anything, only : anyinteger_to_64bit -!! class(*),intent(in) :: invalue -!! doubleprecision :: invalue_local -!! doubleprecision :: squarei -!! invalue_local=anyinteger_to_64bit(invalue) -!! squarei=invalue_local*invalue_local -!! end function squarei -!! ! -!! end program demo_anyinteger_to_64bit -!! -!! Results -!! -!! 16129.000000000000 127 \ -!! 16129 -!! 1073676289.0000000 32767 \ -!! 1073676289 -!! 4.6116860141324206E+018 2147483647 \ -!! 4611686014132420609 -!! 8.5070591730234616E+037 9223372036854775807 \ -!! 85070591730234615847396907784232501249 -!! 2.8948022309329049E+076 170141183460469231731687303715884105727 \ -!! 28948022309329048855892746252171976962977213799489202546401021394546514198529 -!! -!!AUTHOR -!! John S. Urban -!!LICENSE -!! Public Domain -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -PURE ELEMENTAL FUNCTION anyinteger_to_64bit(intin) RESULT(ii38) - USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT !! ,input_unit,output_unit - IMPLICIT NONE - -!!@(#) M_anything::anyinteger_to_64(3f): convert integer parameter of any kind to 64-bit integer - - CLASS(*), INTENT(in) :: intin - INTEGER(kind=INT64) :: ii38 - SELECT TYPE (intin) - TYPE is (INTEGER(kind=INT8)); ii38 = INT(intin, kind=INT64) - TYPE is (INTEGER(kind=INT16)); ii38 = INT(intin, kind=INT64) - TYPE is (INTEGER(kind=INT32)); ii38 = intin - TYPE is (INTEGER(kind=INT64)); ii38 = intin - !class default - !write(error_unit,*)'ERROR: unknown integer type' - !stop 'ERROR: *anyinteger_to_64* unknown integer type' - END SELECT -END FUNCTION anyinteger_to_64bit -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -END MODULE System_Method diff --git a/src/modules/System/src/System_Method.c b/src/modules/System/src/System_Method.c deleted file mode 100755 index 795659d2d..000000000 --- a/src/modules/System/src/System_Method.c +++ /dev/null @@ -1,641 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#ifndef __USE_POSIX -#define __USE_POSIX -#endif - -#include - -#ifndef HZ -#define HZ 60 -#endif - -#define MIN(x, y) ((x) < (y) ? (x) : (y)) - -extern char **environ; - -#ifdef Linux_SYSTEM -// extern int HOST_NAME_MAX; -int FHOST_NAME_MAX = HOST_NAME_MAX; -#endif - -#ifdef Darwin_SYSTEM -#define HOST_NAME_MAX 255 -int FHOST_NAME_MAX = HOST_NAME_MAX; -#endif - -extern mode_t FS_IRGRP; -extern mode_t FS_IROTH; -extern mode_t FS_IRUSR; -extern mode_t FS_IRWXG; -extern mode_t FS_IRWXO; -extern mode_t FS_IRWXU; -extern mode_t FS_IWGRP; -extern mode_t FS_IWOTH; -extern mode_t FS_IWUSR; -extern mode_t FS_IXGRP; -extern mode_t FS_IXOTH; -extern mode_t FS_IXUSR; -extern mode_t FDEFFILEMODE; -extern mode_t FACCESSPERMS; - -mode_t FS_IRGRP = S_IRGRP; -mode_t FS_IROTH = S_IROTH; -mode_t FS_IRUSR = S_IRUSR; -mode_t FS_IRWXG = S_IRWXG; -mode_t FS_IRWXO = S_IRWXO; -mode_t FS_IRWXU = S_IRWXU; -mode_t FS_IWGRP = S_IWGRP; -mode_t FS_IWOTH = S_IWOTH; -mode_t FS_IWUSR = S_IWUSR; -mode_t FS_IXGRP = S_IXGRP; -mode_t FS_IXOTH = S_IXOTH; -mode_t FS_IXUSR = S_IXUSR; -mode_t FDEFFILEMODE = DEFFILEMODE; -mode_t FACCESSPERMS = ACCESSPERMS; - -char **ep; - -extern long int longest_env_variable; -long int longest_env_variable = 0L; -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - wrapper around access(3c) for a call from Fortran -*/ -int my_access(const char *pathname, int which) { - int n; - /*fprintf(stdout," which values = %d %d %d %d - * %d\n",F_OK,R_OK,W_OK,X_OK,which);*/ - n = access(pathname, which); - return (n); -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* does a recursive mkdir(3c) for a POSIX pathname */ -void my_mkdir(char *dir, int mode, int *ier) { - char *p = NULL; - char buf[4096]; - size_t len; - - snprintf(buf, sizeof(buf), "%s", dir); - len = strlen(buf); - if (buf[len - 1] == '/') { - buf[len - 1] = 0; - } - for (p = buf + 1; *p; p++) { - if (*p == '/') { - *p = 0; - mkdir(buf, mode); - *p = '/'; - } - } - *ier = mkdir(buf, mode); -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - wrapper around utime(3c) for a call from Fortran -*/ -int my_utime(const char *file, int times[2]) { - struct utimbuf ut; - /* time_t ut[2]; */ - int n; - - ut.actime = (time_t)times[0]; - ut.modtime = (time_t)times[1]; - n = utime(file, &ut); - /* - ut[0] = times[0]; - ut[1] = times[l]; - n = utime (file, ut); - */ - return (n); -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - wrapper around chown(3c) for a call from Fortran -*/ -int my_chown(char *filename, long long int uid, long long int gid) { - return chown(filename, (uid_t)uid, (gid_t)gid); -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - wrapper around readdir(3c) for a call from Fortran -*/ -void my_readdir(DIR *dirp, char *filename, int *ierr) { - - struct dirent *dp; - int length; - - *ierr = 0; - length = 0; - - if ((dp = readdir(dirp)) != NULL) { - length = (int)strlen(dp->d_name) + 1; - memcpy(filename, dp->d_name, length); - } else { - *ierr = -1; /*When the end of the directory is encountered, a null pointer - is returned and errno is not changed.*/ - } -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - flush stdin and stderr and all files open in C -*/ -void my_flush(void) { - fflush(NULL); - /* For good measure */ - fflush(stdin); - fflush(stdout); -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -char *my_realpath(char *symlinkpath) { return (realpath(symlinkpath, NULL)); } -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - wrapper to step through environment table -*/ -/*--------------------------------------------------------------------------------------------------------------------------------*/ -void my_initenv() { - /* - Set pointer into environment table to beginning of table, - but find longest current variable length so can make buffer - big enough by scanning current table. There is probably a - C variable that defines this length; but hopefully this - entire method of reading the environment table will be - superseded if I can figure out what is wrong with the - version that returns an arbitrary string length directly. - See: - xargs --show-limits - */ - long int newlength; - ep = environ; - longest_env_variable = 4096; - while ((*ep)) { - newlength = (long int)strlen(*ep); - if (newlength > longest_env_variable) { - longest_env_variable = newlength; - } - *ep++; - } - ep = environ; -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -void my_readenv(char *variable) { - size_t length_in; - size_t length_out; - size_t length_copy; - if (*ep == NULL) { - strncpy(variable, "", 1); - /* - fprintf(stdout,"%s [%s]\n","REWIND TABLE",variable); - */ - my_initenv(); /* reset pointer to start of table */ - } else { - length_in = strlen(variable); - length_out = strlen(*ep); - length_copy = MIN(length_in, length_out); - - memcpy(variable, *ep, length_copy + 1); - *ep++; - } -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -int my_getgrgid(long long int id, char *groupname) { - struct group *grp; - - errno = 0; - - if ((grp = getgrgid((gid_t)id)) != NULL) { - strcpy(groupname, grp->gr_name); - } else { - strncpy(groupname, "", 1); - perror("getgrgid"); - } - return errno; -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -int my_getpwuid(long long int id, char *username) { - struct passwd *pwd; - - errno = 0; - - if ((pwd = getpwuid((uid_t)id)) != NULL) { - strcpy(username, pwd->pw_name); - } else { - strncpy(username, "", 1); - perror("getpwuid"); - } - return errno; -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - return last error number for functions that explicitly state they set it - use a function as this might be a macro -*/ -int my_errno() { return (errno); } -/*--------------------------------------------------------------------------------------------------------------------------------*/ -void system_unbuffer() { - /* - This routine turns off buffering of standard input so that Kevin - Serafini can control both input and output so that he can control - USH from the xush(1) X11 windows GUI program using forked pipes - */ - char ident[] = "@(#)system_unbuffer(3c): FORTRAN-callable call to turn off " - "buffering of stdin"; - - if (setvbuf(stdin, NULL, _IOLBF, 0) != 0) { - perror("setvbuf"); - exit(5); - } - if (setvbuf(stdout, NULL, _IOLBF, 0) != 0) { - perror("setvbuf"); - exit(5); - } - fprintf(stderr, "IN THE BUFF!\n"); -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - my_uname -- return system information from uname(3c) to Fortran subroutine -*/ -void my_uname(char *which, char *string, int *stringlen) { - struct utsname name; - int j; - if (uname(&name) == -1) { - fprintf(stderr, "*my_uname* cannot get system name\n"); - strncpy(string, "UNKNOWN", *stringlen); - } else { - switch (*which) { - case 's': - strncpy(string, name.sysname, *stringlen); - break; - case 'n': - strncpy(string, name.nodename, *stringlen); - break; - case 'r': - strncpy(string, name.release, *stringlen); - break; - case 'v': - strncpy(string, name.version, *stringlen); - break; - case 'm': - strncpy(string, name.machine, *stringlen); - break; - case 'T': - fprintf(stderr, "*my_uname* sysname: %s\n", name.sysname); - fprintf(stderr, "*my_uname* nodename: %s\n", name.nodename); - fprintf(stderr, "*my_uname* release: %s\n", name.release); - fprintf(stderr, "*my_uname* version: %s\n", name.version); - fprintf(stderr, "*my_uname* machine: %s\n", name.machine); - strncpy(string, "", *stringlen); - break; - default: - fprintf(stderr, "*my_uname* error: unknown switch %c \n", *which); - fprintf(stderr, "*my_uname* my_uname:%s:%c:%d\n", string, *which, - *stringlen); - strncpy(string, "UNKNOWN", *stringlen); - } - } - /* - remove null string terminator and fill string with blanks for Fortran - */ - for (j = strlen(string); j < *stringlen; j++) { - string[j] = ' '; - } -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* - Use unix routine times(3c) to measure user execution time between - calls in seconds. -*/ - -void my_cpu_time(float *c, float *u, float *s) { -#include -#include - clock_t t; - struct tms mytime; - - t = times(&mytime); /* call "times" */ - *u = ((float)mytime.tms_utime) / - ((float)HZ); /* user time in 1/HZ seconds is in tms_utime */ - *s = ((float)mytime.tms_stime) / ((float)HZ); /* HZ is in sys/param.h */ - *c = *u + *s; - return; -} -/*--------------------------------------------------------------------------------------------------------------------------------*/ -/* ===============================================================================================================================*/ -/* - * Decides whether a given file name is a directory. - * return 1 if file exists and is a directory - */ -int my_isdir(const char *path) { - struct stat sb; - return stat(path, &sb) == 0 && S_ISDIR(sb.st_mode); -} -/* ===============================================================================================================================*/ -/* Check for regular file. */ -int my_isreg(const char *path) { - struct stat sb; - return stat(path, &sb) == 0 && S_ISREG(sb.st_mode); -} -/* ===============================================================================================================================*/ -/* determine if filename is a block device */ -int my_isblk(const char *path) { - struct stat sb; - return stat(path, &sb) == 0 && S_ISBLK(sb.st_mode); -} -/* ===============================================================================================================================*/ -/* determine if filename is a character device */ -int my_ischr(const char *path) { - struct stat sb; - return stat(path, &sb) == 0 && S_ISCHR(sb.st_mode); -} -/* ===============================================================================================================================*/ -/* determine if filename is a fifo - named pipe */ -int my_isfifo(const char *path) { - struct stat sb; - return stat(path, &sb) == 0 && S_ISFIFO(sb.st_mode); -} -/* ===============================================================================================================================*/ -/* determine if filename is a socket */ -int my_issock(const char *path) { - struct stat sb; - return stat(path, &sb) == 0 && S_ISSOCK(sb.st_mode); -} -/* ===============================================================================================================================*/ -/* - * Decides whether a given file name is a symbolic link. - * return 1 if file exists and is a symlink, 0 otherwise. - */ -int my_islnk(const char *fname) { - struct stat statbuf; - - if (lstat(fname, &statbuf)) { - return 0; - } else { - return S_ISLNK(statbuf.st_mode); - } -} -/* ===============================================================================================================================*/ -/* - * Checks whether a given file exists. - * return 1 if file exists, 0 otherwise. - */ -int my_file_exists(const char *fname) { - struct stat statbuf; - return !stat(fname, &statbuf); -} -/* ===============================================================================================================================*/ -#include -#include -#include -#include -#include - -void my_stat(char *file, long int *values, int *ierr, int debug) { - struct stat *buf = - malloc(sizeof(struct stat)); /* allocates memory for stat structure. */ - struct passwd *pwd; - struct group *grp; - struct tm *tm; - char datestring[256]; - static char local_buff[17] = {0}; - int i; - - errno = 0; /* always set errno to zero first. */ - if (stat(file, buf) != 0) { - perror(file); /* if stat does not work, print a diagnostic. */ - *ierr = 1; - return; - } - - *ierr = 0; - values[0] = buf->st_dev; /* st_dev device file currently resides on. */ - values[1] = buf->st_ino; /* st_ino The inode for the file */ - values[2] = buf->st_mode; /* st_mode The current permissions on the file. */ - values[3] = buf->st_nlink; /* st_nlink number of links to this file. */ - values[4] = buf->st_uid; /* st_uid The User ID for the file. */ - values[5] = buf->st_gid; /* st_gid The Group ID for the file. */ - values[6] = buf->st_rdev; /* st_rdev ID of device containing directory entry - for file (0 if not available) */ - values[7] = buf->st_size; /* st_size file size in bytes */ - values[8] = - buf->st_atime + 0.5; /* st_atime most recent time file was accessed. */ - values[9] = buf->st_mtime + - 0.5; /* st_mtime most recent time file contents modified. */ - values[10] = buf->st_ctime + - 0.5; /* st_ctime most recent time file permissions changed. */ - values[11] = buf->st_blksize; /* Preferred I/O block size (-1 if not - available) */ - values[12] = buf->st_blocks; /* Number of blocks allocated (-1 if - not available) */ - - if (debug == 0) { - printf("Information for %s ", file); - printf("(The file %s a symbolic link)\n", - (S_ISLNK(buf->st_mode)) ? "is" : "is not"); - printf("---------------------------\n"); - printf("File Size ........................ %jd bytes\n", - (intmax_t)buf->st_size); /* st_size file size in bytes */ - printf("Number of Links .................. %ld\n", - buf->st_nlink); /* st_nlink number of links to this file. */ - printf("File inode ....................... %ld\n", - buf->st_ino); /* st_ino The inode for the file */ - - i = 0; - /* - This varies, but at least one ls(1) command uses this convention: - - The file type is one of the following characters: - - regular file - b block special file - c character special file - C high performance ( contiguous data ) file - d directory - D door (Solaris 2.5 and up) - l symbolic link - M off-line ( migrated ) file (Cray DMF) - n network special file (HP-UX) - p FIFO (named pipe) - P port (Solaris 10 and up) - s socket - ? some other file type - The file mode bits listed are similar to symbolic mode specifications - (*note Symbolic Modes::). But ls(1) combines multiple bits into the third - character of each set of permissions as follows: s If the set-user-ID - or set-group-ID bit and the corresponding executable bit are both set. S - If the set-user-ID or set-group-ID bit is set but the corresponding - executable bit is not set. t If the restricted deletion flag or sticky - bit, and the other-executable bit, are both set. The restricted deletion - flag is another name for the sticky bit. *Note Mode Structure::. - T If the restricted deletion flag or sticky bit is set but the - other-executable bit is not set. x If the executable bit is set and - none of the above apply. - - Otherwise. - Following the file mode bits is a single character that specifies - whether an alternate access method such as an access control list - applies to the file. When the character following the file mode - bits is a space, there is no alternate access method. When it is a - printing character, then there is such a method. - - GNU ls(1) uses a . character to indicate a file with a security context, - but no other alternate access method. - - A file with any other combination of alternate access methods is marked - with a + character. - - */ - if (S_ISDIR(buf->st_mode)) { /* st_mode The current permissions on the - file. */ - local_buff[i] = 'd'; - } else if (S_ISCHR(buf->st_mode)) { - local_buff[i] = 'c'; - } else if (S_ISLNK(buf->st_mode)) { - local_buff[i] = 'l'; - } else if (S_ISBLK(buf->st_mode)) { - local_buff[i] = 'b'; - } else if (S_ISFIFO(buf->st_mode)) { - local_buff[i] = 'p'; - } else if (S_ISSOCK(buf->st_mode)) { - local_buff[i] = 's'; - } else if (S_ISREG(buf->st_mode)) { - local_buff[i] = '-'; - } else { - local_buff[i] = '?'; - } - i++; - local_buff[i] = (buf->st_mode & S_IRUSR) ? 'r' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IWUSR) ? 'w' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IXUSR) ? 'x' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IRGRP) ? 'r' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IWGRP) ? 'w' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IXGRP) ? 'x' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IROTH) ? 'r' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IWOTH) ? 'w' : '-'; - i++; - local_buff[i] = (buf->st_mode & S_IXOTH) ? 'x' : '-'; - i++; - local_buff[i] = '\0'; - printf("File Permissions ................. %s\n", local_buff); - printf("Owner ID ........................ %-8d\n", buf->st_uid); - - /* Print out owner name if found using getpwuid(). */ - if ((pwd = getpwuid(buf->st_uid)) != - NULL) { /* st_uid The User ID for the file. */ - printf("Owner ........................... %-8s\n", pwd->pw_name); - } - printf("Owner ID ........................ %-8d\n", buf->st_uid); - /* Print out group name if found using getgrgid(). */ - if ((grp = getgrgid(buf->st_gid)) != - NULL) { /* st_gid The Group ID for the file. */ - printf("Group name ...................... %-8s\n", grp->gr_name); - } - printf("Group ID ........................ %-8d\n", buf->st_gid); - - tm = localtime(&buf->st_mtime); /* st_mtime most recent time file contents - modified. */ - strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), - tm); /* Get localized date string. */ - printf("file contents last modified ..... %s\n", datestring); - - tm = localtime( - &buf->st_atime); /* st_atime most recent time file was accessed. */ - strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), - tm); /* Get localized date string. */ - printf("file contents last accessed ..... %s\n", datestring); - - tm = localtime(&buf->st_ctime); /* st_ctime most recent time file - permissions changed. */ - strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), - tm); /* Get localized date string. */ - printf("file permissions last changed ... %s\n", datestring); - - printf("device .......................... %ld\n", - buf->st_dev); /* st_dev device file currently resides on. */ - } -} -/* ===============================================================================================================================*/ -/* -int main () { - printf ("input.txt is a regular file? %s\n", - check_reg ("input.txt") ? "yes" : "no"); - printf ("docs is a directory? %s\n", check_dir ("docs") ? "yes" : "no"); - printf ("/input.txt is a regular file? %s\n", - check_reg ("/input.txt") ? "yes" : "no"); - printf ("/docs is a directory? %s\n", check_dir ("/docs") ? "yes" : "no"); - return 0; -} -*/ -/* ===============================================================================================================================*/ -const char *my_get_perm(long int imode) { - static char perms_buff[15]; - char ftype = '?'; - mode_t mode; - - mode = (mode_t)imode; - if (S_ISREG(mode)) - ftype = '-'; - if (S_ISLNK(mode)) - ftype = 'l'; - if (S_ISDIR(mode)) - ftype = 'd'; - if (S_ISBLK(mode)) - ftype = 'b'; - if (S_ISCHR(mode)) - ftype = 'c'; - if (S_ISFIFO(mode)) - ftype = 'p'; -#ifdef S_ISDOOR - if (S_ISDOOR(mode)) - ftype = 'D'; /* Solaris 2.6, etc. */ -#endif - - sprintf(perms_buff, "%c%c%c%c%c%c%c%c%c%c %c%c%c", ftype, - mode & S_IRUSR ? 'r' : '-', mode & S_IWUSR ? 'w' : '-', - mode & S_IXUSR ? 'x' : '-', - - mode & S_IRGRP ? 'r' : '-', mode & S_IWGRP ? 'w' : '-', - mode & S_IXGRP ? 'x' : '-', - - mode & S_IROTH ? 'r' : '-', mode & S_IWOTH ? 'w' : '-', - mode & S_IXOTH ? 'x' : '-', - - mode & S_ISUID ? 'U' : '-', mode & S_ISGID ? 'G' : '-', - mode & S_ISVTX ? 'S' : '-'); - - return perms_buff; -} -/* ===============================================================================================================================*/ -/* - To get stream I/O out of stdin and stdout, make a getc and putc callable from - Fortran -*/ -char getkeyC(void) { - /* @(#) Driver for reading a character from stdin */ - char c; - read(0, &c, 1); - return (c); -} - -int putkeyC(char c) { - /* @(#) Driver for writing a character to stdout */ - write(1, &c, 1); - return (c); -} -/* ===============================================================================================================================*/ diff --git a/src/modules/Test/CMakeLists.txt b/src/modules/Test/CMakeLists.txt deleted file mode 100644 index b54f0c97e..000000000 --- a/src/modules/Test/CMakeLists.txt +++ /dev/null @@ -1,26 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/Test_Base.F90 ${src_path}/Test_Planning.F90 - ${src_path}/Test_Is.F90 ${src_path}/Test_More.F90 - ${src_path}/Test_Method.F90) - diff --git a/src/modules/Test/src/README.txt b/src/modules/Test/src/README.txt deleted file mode 100644 index e8c75ec15..000000000 --- a/src/modules/Test/src/README.txt +++ /dev/null @@ -1,486 +0,0 @@ -A Fortran implementation of http://testanything.org/ (TAP) -========================================================== - -Testing does not have to be complicated. - -TAP stands for Test Anything Protocol, and is a textual -protocol supported by many testing tools, and build servers -such as Jenkins. - -This is a TAP producer module, test, inspired by Perl's -Test::More module, and comes with a small command line TAP -consumer program that works as a simple test harness for -bare needs. - -Perl's prove(1) can also be used for now as long as one remember -to let the test programs have the suffix ".t" - -The test module has some additions for comparing floating point -numbers: absolute and relative comparison with the subroutines -isabs and isrel, in addition to isnear, which uses division -instead of subtraction as isabs. - -Other than that compile time overloading is used for the -subroutines is and isnt. There is no support for subtests. They -would be nice to have, but you can just write more test programs -or use plain old subroutines to divide the work, so most likely -they will not be implemented. - -There are also 2 public streams for test output and diagnostic -notes, which by default are assigned to OUTPUT_UNIT and -ERROR_UNIT. - -See http://testanything.org/tap-specification.html to understand -the output that the test module is supposed to produce. The -subroutines are transparent and easy to understand once you -understand the simple test protocol (TAP). - -The philosophy behind this implementation is to have something -simple to quickly get on with testing while at the same -time it is easy to modify and extend for one's own purpose: -All too often it is too difficult to remove something from -a library. It's better to strike a balance, and make it easy -to add to a library while still having an implementation that -takes care of the most common things. - -Fortran-testanything comes with the OpenBSD/ISC license. - -Tectonics ---------- - -See the Makefile. The Fortran 2008 source file test.f08 includes -the is_i.inc and is_r.inc files, so they should stay together, -or the *.inc files should be in a directory in the include search -path (-I option). Compile tests with test.f08, and that is it. - -See test_examples.f08 for an example of use. - -Synopsis --------- - -use test - -call plan(23) -! or -call skip_all(reason) -! or see done_testing - -! Various ways to say 'ok' -call ok(got .eq. expected, test_name) ! test names are optional - -call is(got, expected, test_name) -call isnt(got, expected, test_name) - -call isabs(got, expected, epsilon, test_name) -call isrel(got, expected, epsilon, test_name) -call isnear(got, expected, test_name) - -! Rather than WRITE (ERROR_UNIT,'(A)') "# here's what went wrong" -call diag("here's what went wrong") - -if (.not. have_some_feature()) then - call skip(why, how_many) ! how_many is optional and default 1 -else - call ok(foo(), test_name) - call is(foo(42), 23, test_name) - ! ... -end if - -call todo(why, how_many) -call ok(foo(), test_name) -call is(foo(42), 23, test_name) -! ... - -call pass(test_name) -call fail(test_name) - -! Stop test program after writing why rather than ERROR STOP -call bail_out(why) - -Description ------------ - -Subroutines - - * plan/skip_all - * done_testing - * ok - * is/isnt - * isabs/isntabs - * isrel/isntrel - * isnear/isntnear - * pass/fail - * skip/todo - * note/diag - * bail_out - -The examples use "=>" in a comment to indicate output. - -See http://search.cpan.org/~mschwern/Test-Simple/lib/Test/More.pm for -a more detailed explanation and raison d'être of the test routines. - -To plan or not to plan ----------------------- - -The number of tests to run is part of a test program, so that the test -harness (TAP consumer) can report if any test wasn't run at all. - -You indicate this either at the beginning or at the end of a test -program. The number of tests can be calculated in both instances. - -Calling skip_all stops the test immediately after writing the reason why -on test output. - -Examples: - -call plan(23) -! => 1..23 - -call plan(size(keys) * 3) ! Given size(keys) = 4 -! => 1..12 - -call skip_all("Only relevant on OpenBSD") -! => 1..0 # Skipped: Only relevant on OpenBSD - -call done_testing ! Simply does nothing if you planned ahead - -call done_testing(11) -! => 1..11 - -call done_testing(cases * 5) ! Given cases = 6 -! => 1..30 - -Test names ----------- - -Test names are optional, and by default nothing more than test result -"ok" or "not ok" including a test number is output. Including them gives -you an idea of what failed. - -What would you rather see? - -ok 34 - basic standard variance -not ok 35 - root mean square -ok 36 - volt == ampere * ohm - -or - -ok 34 -not ok 35 -ok 36 - -It also makes it easier to find tests in your program, e.g. it's easier -to search for "root mean square" than "35". On the other hand the test -number uniquely identifies a test. - -Examples: - -call ok(3 == 3, 'Integer equivalence') -! => ok 1 - Integer equivalence - -call ok(leq("Dines", "Dennis")) -! => not ok 2 - -call is(5, 2+2, '2 + 2 == 5') -! => not ok 3 - 2 + 2 == 5 -! => # Failed test '2 + 2 == 5' -! => # got: 4 -! => # expected: 5 - -A failed test outputs some more diagnostic output about why. Diagnostic -output lines begins with a number sign (octothorpe), "#". - -How tests do comparisons ------------------------- - -You can stick to using routine ok to do tests, but some convenient -routines are supplied for easier comparison of different types. In -particular the "is" routine is overloaded for different types. - -There are also a few special is routines for comparison of -floating point numbers whose representation by definition -is inexact: isabs, isrel, and isnear. The routine isabs is -good for comparison of small numbers while isrel is good -for comparison of large numbers. They both take an optional -epsilon which by default is the intrinsic epsilon(expected) - 1. -The routine isnear is similar to isabs, but uses division intead -of subtraction. Originally the routine was supposed to use the -intrinsic nearest(x, s), which returns the nearest different -machine number in the direction given by the sign of the real s, -but then I discovered 2 ways of doing relative comparisons of -floating point numbers. One can still use nearest to compare -the floating point numbers A and B: - - call ok(nearest(A, -1.0) <= B .and. B <= nearest(A, +1.0)) - -Using nearest in such a way considers a near miss to be a hit, -but it seems more fragile than analyzing the calculation and -taking precision and accuracy into account. - -For other values, just use the routine is with the result as -first argument and the expected result as second argument. - -Examples: - -call is(3, 3) -call is("Dines", "Dines") -call is(.true., .false.) -call is(point(2, 3), point(2, 3)) ! Given operator(==) is overloaded. - -call isabs(sqrt(2.0), 1.4142, 0.5e-3) ! 3 decimal digit precision -call isrel(10023.0, 10025.0, 0.5e-4) ! 4 largest digits precision - -In summary: - -is(a,b): is a equal to b? -isabs(a, b): abs(a) - abs(b) < e, where e = eps -isrel(a, b): abs(a) - abs(b) < e, where e = (abs(a) + abs(b)) * eps -isnear(a,b): abs(abs(a) / abs(b) - 1) <= e, where e = eps - -Complex numbers cannot be compared directly with relative -operators or equality operators. In that case use either the -intrinsic functions real and imag, or the pseudo-components -(since Fortran 2003) re and im to compare the real and imaginary -parts of a complex number. - -Examples: - -call is(real(a), real(b)) -call is(imag(a), imag(b)) -call is(a%re, b%re) -call is(a%im, b%im) - -Testing arrays --------------- - -Deep comparison of elements in arrays or derived types doesn't -make a lot of sense in Fortran, in part because it can be -overloaded on derived types, but also because very often better -comparison techniques can be used instead. It depends on the -problem. Hence they are not as useful, and has not implemented. - -Complex tests -------------- - -This test module does not implement subtests. They could be useful, but -on the other hand they would require so much more to set up that it would -defeat the purpose. Separating stuff into test programs will handle most -cases with easy anyway, and the rest with minimal pain. It is possible -to use program generation if need be or just plain old subroutines. - -If having complicated tests, one can use the routines pass and fail, -which are synonymous with ok(.true.) and ok(.false.) to tell whether a -test is to pass or fail. - -Examples: - -call pass -! => ok 40 -call pass("support for linear regression") -! => ok 41 - support for linear regression -call fail -! => not ok 42 -call fail("hairy numbers does not work") -! => not ok 43 - hairy numbers does not work - -In that case it is also useful to write one's own notes and -diagnostics. Both the routines note and diag outputs a string -as a single line preceded with a number sign (octothorpe), -"#", but note does it on the test output, which will not be -seen in a test harness, while diag does it on the diagnostic -output which is always visible. By default test output unit is -OUTPUT_UNIT, and diagnostic output is ERROR_UNIT. - -call note("Tempfile is " // tempfile) -! => # Tempfile is XYZ123456 -call diag("There is no XYZ, check that /etc/XYZ.ini is set up right") -! => # There is no XYZ, check that /etc/XYZ.ini is set up right - -Currently there is no overloaded subroutine that will take several -strings for several lines, since that has not been very useful, but -maybe in the future. - -Conditional tests ------------------ - -One can skip a test if there is insufficient conditions to run it, or -it doesn't make sense, or it's impossible to do so. In that case one -calls skip _instead of_ the test routines. Skipped tests are always -reported as being ok. Please note that calling skip unconditionally, -i.e. outside an if block or similar is surely a mistake. If the test -program is planned, this mistake will be caught by the test harness, -or simply by the test program failing by error. - -One does not skip tests with failures or tests with only stubbed-out -code to be tested. For that one uses todo tests. - -One can indicate a test as unfinished and yet to be done by calling the -routine todo. The test must still be run, and it is expected to fail. Any -todo test that passes is supposed to be reported by any test harness as -unexpectedly passing, so one can remove the todo status, once the work -is done. - -Both skip and todo routines take an optional test_name and an optional -how_many, which is default 1. - -Examples: - -call skip -! => ok 50 # Skipped -call skip("No test data on the network") -! => ok 51 # SKIP: No test data on the network -call skip("No APP_DATA directory", 3) -! => ok 52 # SKIP: No APP_DATA directory -! => ok 53 # SKIP: No APP_DATA directory -! => ok 54 # SKIP: No APP_DATA directory -call skip(2) -! => ok 55 # SKIP -! => ok 56 # SKIP - -call todo -call ok(.false.) -! => not ok 57 - # TODO -call todo("Lookup details in the cryptic article") -call ok(.false.) -! => not ok 58 - # TODO: Lookup details in the cryptic article -call todo -call ok(.false., "Monte carlo test set up") -! => not ok 59 - Monte carlo test set up # TODO -call todo("Resolve learning problems") -call is(supervise(data), 97.0, "Bayes with 97% class") -! => not ok 60 - Bayes with 97% class # TODO: Resolve learning problems - -call todo("Halting problem unsolved", 3) -call ok(.false., "Infinite loop") -call ok(.false., "Infinite recursion") -call ok(.false., "Infinite Turing tape") -! => not ok 61 - Infinite loop # TODO: Halting problem unsolved -! => not ok 62 - Infinite recursion # TODO: Halting problem unsolved -! => not ok 63 - Infinite Turing tape # TODO: Halting problem unsolved -call todo(2) -call ok(.false., "Stubbed-out") -call ok(.false., "Stubbed-out") -! => not ok 64 - # TODO -! => not ok 65 - # TODO - -Skipping a todo test has not been implemented yet. Maybe it'll be useful, -maybe not. Currently skipping a test means also skipping a todo test. - -Diagnostic output ------------------ - -The note routine writes a string on the TEST_UNIT (default OUTPUT_UNIT), -also known as the TAP stream, together with the other test lines without -interfering with the test harness. The output is not visible when run -from a test harness. It is useful for notes, headlines, error correction, -and other things that are not exactly problems. - -The diag routine writes a string on the DIAG_UNIT (default ERROR_UNIT), -and is always visible, even when run from a test harness. Output about -gotten and expected outputs are written this way. It is useful for -diagnostic output in complex tests (see "Complex tests" above) - -The TEST_UNIT and DIAG_UNIT can be set to other unit for the purpose -of redirecting the TAP or diagnostic stream elsewhere for particular -testing purposes: They are public from the test module. - -Stopping a test ---------------- - -The bail_out routine does an error stop after writing an optional message. - -Examples: - -call bail_out -! => Bail out! - -call bail_out("PostgreSQL is not running") -! => Bail out! PostgreSQL is not running - -Caveats -------- - -The test module is not thread safe. You can run test programs in parallel -or use test routines with coarrays, but the test module itself "is thread -ignorant" and is inherently sequential. You can of course divide your -tests into subroutines, and are encouraged to do so. - -Exit codes ----------- - -The status/exit code has some historical complications both -for test programs as well as for Fortran in general, so it's -not supported at all. A test program exits with status code 0 -(zero) on those platforms that have such a thing, but in reality -it depends on the fortran processor (compiler). - -History -------- - -The test module was inspired by Perl's simple Test, Test::More and -Test Anything Protocol (TAP) that Perl's Test::Harness handles. In Perl -the tool prove(1) handles TAP. - -The great idea is to separate tests from test result consumers via a -simple text based protocol. - -It turns out that the Test Anything Protocol is easy, simple, and -transparent to implement in Fortran itself. There is no need for -heavy tooling even in big, elaborate test suites. Perl itself is -proof of that. It is customary for a perl module uploaded to the -Comprehensive Perl Archive Network (CPAN) to be accompanied with -tests, and currently there are beyond 25000 modules on CPAN. - -There is a curious lack of Fortran test libraries written -in Fortran itself. They usually requires a preprocessor or a -scripting language to do collection, preprocessing, transcription -and processing of the tests. Examples of popular ones are Fruit, -ftunit, pFUnit, flibs, FortUnit, FUnit, and objecxxFTK: - - * Fruit (fortranxunit): Fortran Unit Test Framework, BSD-like - license, requires Ruby, active in 2015, - * ftunit (NASA): NASA open source license 1.3, requires Ruby, - active in 2015, - * pFUnit (NASA): NASA open source license 1.3, requires Python, - * flibs (Arjen Markus): BSD-like license, requires Tcl, - stopped in 2008, - * FortUnit: GPLv2 license, requires Perl, stopped in 2004 and - seems gone (no source), - * FUnit: requires Ruby, stopped in 2009, - * objecxxFTK: requires Python; perpetual, royalty-free license - for source allowing client modifications - modest license fee. - -Fortran-testanything is pure Modern Fortran, and does not require -any scripting language. This is due to the separation between -test producers and test consumers. While one can use Perl's -prove(1) tool as a test harness, one can also use any other test -harness written in any other programming language implementation, -e.g. the plugins in the Jenkins build server to handle the TAP -streams and make pretty reports. Fortran-testanything comes -with its own little test harness if one does not have or does -not want to install Perl. - -Frameworks such as pFUnit comes with much more support -for things such as MPI, OpenMP, and MPICH; array tools -for checking size, rank, and shape; preprocessing; and -OO-support. Fortran-testanything on the other hand tries to be -small and easily modifiable. Adding small functions and test -subroutines to supplement specific use cases is easy. - -Testing does not have to be complicated. - -License -------- - -Fortran-testanything comes with the OpenBSD/ISC license, -i.e. the ISC license anno 2003, the one without the "and/or" -conjunction. Lawyers have told me that it does not make any legal -difference in its context, which is already quite clear, and so -a simpler language is preferred, hence just the "and" junction -as in the original license. By the way, the original ISC license -is extremely close to the words of the original BSD license, -but without any words made unnecessary by the Berne Convention. - -It is one of the least restrictive licenses under the Berne -Convention. - diff --git a/src/modules/Test/src/Test_Base.F90 b/src/modules/Test/src/Test_Base.F90 deleted file mode 100644 index 6cfabed09..000000000 --- a/src/modules/Test/src/Test_Base.F90 +++ /dev/null @@ -1,170 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE Test_Base -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT, ERROR_UNIT -IMPLICIT NONE - -! Kept as variables instead of aliases, -! so that test output or diagonostic output can be redirected -INTEGER :: test_unit = OUTPUT_UNIT, diago_unit = ERROR_UNIT - -INTEGER :: tests = 0, todos = 0 -CHARACTER(120) :: todomsg = "" - -INTERFACE todo - MODULE PROCEDURE todo_i, todo_s, todo_s_i, todo -END INTERFACE - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE diago(msg) - CHARACTER(*), INTENT(in) :: msg - WRITE (diago_unit, '("# ",A)') TRIM(msg) ! only trailing spaces -END SUBROUTINE diago - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE note(msg) - CHARACTER(*), INTENT(in) :: msg - WRITE (test_unit, '("# ",A)') TRIM(msg) -END SUBROUTINE note - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE testline(ok, msg, idmsg, gotmsg, expectedmsg) - LOGICAL, INTENT(in) :: ok - CHARACTER(*), INTENT(in) :: msg, idmsg, gotmsg, expectedmsg - - tests = tests + 1 - IF (.NOT. ok) CALL out("not ") - WRITE (test_unit, '("ok ",I0)', advance="NO") tests - - IF (msg /= "" .OR. todos > 0) CALL out(" - ") - - IF (msg /= "") CALL out(TRIM(msg)) - - IF (todos > 0) THEN - todos = todos - 1 - IF (msg /= "") CALL out(" ") - CALL out("# TODO") - IF (todomsg .NE. "") THEN - CALL out(": ") - CALL out(TRIM(todomsg)) - END IF - END IF - IF (todos == 0) todomsg = "" - - WRITE (test_unit, *) "" - - IF (.NOT. ok) THEN - ! 3 spaces prepended = 4 spaces indentation after # on diago - IF (idmsg /= "") CALL diago(" "//idmsg) - IF (gotmsg /= "") CALL diago(" "//gotmsg) - IF (expectedmsg /= "") CALL diago(" "//expectedmsg) - END IF -CONTAINS - SUBROUTINE out(str) - CHARACTER(*), INTENT(in) :: str - WRITE (test_unit, '(A)', advance="NO") str - END -END SUBROUTINE testline - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE ok(condition, msg) - LOGICAL, INTENT(in) :: condition - CHARACTER(*), INTENT(in), OPTIONAL :: msg - IF (PRESENT(msg)) THEN - CALL testline(condition, msg, "", "", "") - ELSE - CALL testline(condition, "", "", "", "") - END IF -END SUBROUTINE ok - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE PASS(msg) - CHARACTER(*), INTENT(in), OPTIONAL :: msg - CALL ok(.TRUE., msg) -END SUBROUTINE PASS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE fail(msg) - CHARACTER(*), INTENT(in), OPTIONAL :: msg - CALL ok(.FALSE., msg) -END SUBROUTINE fail - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE todo_s_i(msg, howmany) - CHARACTER(*), INTENT(in) :: msg - INTEGER, INTENT(in) :: howmany - todomsg = msg - todos = howmany -END SUBROUTINE todo_s_i - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE todo - CALL todo_s_i("", 1) -END SUBROUTINE todo - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE todo_s(msg) - CHARACTER(*), INTENT(in) :: msg - CALL todo_s_i(msg, 1) -END SUBROUTINE todo_s - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE todo_i(howmany) - INTEGER, INTENT(in) :: howmany - CALL todo_s_i("", howmany) -END SUBROUTINE todo_i - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE Test_Base diff --git a/src/modules/Test/src/Test_Is.F90 b/src/modules/Test/src/Test_Is.F90 deleted file mode 100644 index c9a194409..000000000 --- a/src/modules/Test/src/Test_Is.F90 +++ /dev/null @@ -1,130 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE is_i8_mod -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT8 -USE, NON_INTRINSIC :: test_base, ONLY: testline, tests -CONTAINS -INCLUDE "is_i.inc" -END MODULE is_i8_mod - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_i16_mod -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT16 -USE, NON_INTRINSIC :: test_base, ONLY: testline, tests -CONTAINS -INCLUDE "is_i.inc" -END MODULE is_i16_mod - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_i32_mod -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT32 -USE, NON_INTRINSIC :: test_base, ONLY: testline, tests -CONTAINS -INCLUDE "is_i.inc" -END MODULE is_i32_mod - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_i64_mod -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT64 -USE, NON_INTRINSIC :: test_base, ONLY: testline, tests -CONTAINS -INCLUDE "is_i.inc" -END MODULE is_i64_mod - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_i -USE is_i8_mod, ONLY: is_i8 => is -USE is_i16_mod, ONLY: is_i16 => is -USE is_i32_mod, ONLY: is_i32 => is -USE is_i64_mod, ONLY: is_i64 => is -INTERFACE is - MODULE PROCEDURE is_i8, is_i16, is_i32, is_i64 -END INTERFACE -END MODULE is_i - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_r32_mod -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => REAL32 -USE, NON_INTRINSIC :: test_base, ONLY: testline, tests -CONTAINS -INCLUDE "is_r.inc" -END MODULE is_r32_mod - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_r64_mod -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => REAL64 -USE, NON_INTRINSIC :: test_base, ONLY: testline, tests -CONTAINS -INCLUDE "is_r.inc" -END MODULE is_r64_mod - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_r128_mod -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => REAL128 -USE, NON_INTRINSIC :: test_base, ONLY: testline, tests -CONTAINS -INCLUDE "is_r.inc" -END MODULE is_r128_mod - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE is_r -USE is_r32_mod, ONLY: isrel_r32 => isrel, isabs_r32 => isabs, & - & isnear_r32 => isnear -USE is_r64_mod, ONLY: isrel_r64 => isrel, isabs_r64 => isabs, & - & isnear_r64 => isnear -USE is_r128_mod, ONLY: isrel_r128 => isrel, isabs_r128 => isabs, & - & isnear_r128 => isnear -INTERFACE isrel - MODULE PROCEDURE isrel_r32, isrel_r64, isrel_r128 -END INTERFACE - -INTERFACE isabs - MODULE PROCEDURE isabs_r32, isabs_r64, isabs_r128 -END INTERFACE - -INTERFACE isnear - MODULE PROCEDURE isnear_r32, isnear_r64, isnear_r128 -END INTERFACE - -END MODULE is_r diff --git a/src/modules/Test/src/Test_Method.F90 b/src/modules/Test/src/Test_Method.F90 deleted file mode 100644 index 3e96c581a..000000000 --- a/src/modules/Test/src/Test_Method.F90 +++ /dev/null @@ -1,27 +0,0 @@ -! Copyright 2015 Dennis Decker Jensen -! See and -! Tectonics: gfortran -g -Wall -Wextra -std=f2008ts -c test.f08 -! -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General 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 Test_Method -USE Test_Base, ONLY: test_unit, diago_unit, & - & ok, diago, note, PASS, fail, todo -USE Test_Planning, ONLY: plan, done_testing, skip_all, bail_out -USE Test_More, ONLY: is, isabs, isrel, isnear, skip -END MODULE Test_Method diff --git a/src/modules/Test/src/Test_More.F90 b/src/modules/Test/src/Test_More.F90 deleted file mode 100644 index d382baf8f..000000000 --- a/src/modules/Test/src/Test_More.F90 +++ /dev/null @@ -1,154 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE Test_More -USE test_base, ONLY: testline, tests, test_unit -USE test_planning, ONLY: bail_out ! for negative skips -USE is_i, ONLY: is, is_i8, is_i16, is_i32, is_i64 -USE is_r, ONLY: isabs, isrel, isnear, & - & isabs_r32, isrel_r32, isnear_r32, & - & isabs_r64, isrel_r64, isnear_r64, & - & isabs_r128, isrel_r128, isnear_r128 - -! Complex numbers cannot be compared, hence no is_c module - -IMPLICIT NONE - -INTERFACE skip - MODULE PROCEDURE skip_i, skip_s, skip_s_i, skip -END INTERFACE - -INTERFACE is - MODULE PROCEDURE is_s, is_l -END INTERFACE - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE skip_s_i(msg, howmany) - CHARACTER(*), INTENT(in) :: msg - INTEGER, INTENT(in) :: howmany - CHARACTER(120) skipmsg - INTEGER i - - IF (howmany <= 0) THEN - CALL bail_out("Skipped non-positive number of tests") - END IF - - IF (msg == "") THEN - skipmsg = "# SKIP" - ELSE - skipmsg = "# SKIP: "//TRIM(msg) - END IF - - DO i = 1, howmany - tests = tests + 1 - WRITE (test_unit, '("ok ",I0," ",A)') tests, TRIM(skipmsg) - END DO -END SUBROUTINE skip_s_i - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE skip - CALL skip_s_i("", 1) -END SUBROUTINE skip - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE skip_s(msg) - CHARACTER(*), INTENT(in) :: msg - CALL skip_s_i(msg, 1) -END SUBROUTINE skip_s - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE skip_i(howmany) - INTEGER, INTENT(in) :: howmany - CALL skip_s_i("", howmany) -END SUBROUTINE skip_i - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! Duplicates of is_i routines in file is_i.inc and ditto is_r -! They are not factored any further, because it is easier -! to see all the output together rather than in separate routines - -SUBROUTINE is_s(got, expected, msg) - CHARACTER(*), INTENT(in) :: got - CHARACTER(*), INTENT(in) :: expected - CHARACTER(*), INTENT(in), OPTIONAL :: msg - CHARACTER(:), ALLOCATABLE :: testmsg, idmsg - CHARACTER(120) gotmsg, expectedmsg - LOGICAL good - - IF (PRESENT(msg)) THEN - ALLOCATE (CHARACTER(LEN_TRIM(msg) + 20) :: testmsg, idmsg) - WRITE (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', TRIM(msg), '"' - testmsg = TRIM(msg) - ELSE - ALLOCATE (CHARACTER(30) :: testmsg, idmsg) - WRITE (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 - testmsg = "" - END IF - WRITE (unit=gotmsg, fmt='(A,A,A)') ' got: "', got, '"' - WRITE (unit=expectedmsg, fmt='(A,A,A)') 'expected: "', expected, '"' - - good = got == expected - CALL testline(good, testmsg, idmsg, gotmsg, expectedmsg) -END SUBROUTINE is_s - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE is_l(got, expected, msg) - LOGICAL, INTENT(in) :: got, expected - CHARACTER(*), INTENT(in), OPTIONAL :: msg - CHARACTER(:), ALLOCATABLE :: testmsg, idmsg - CHARACTER(120) gotmsg, expectedmsg - LOGICAL good - - IF (PRESENT(msg)) THEN - ALLOCATE (CHARACTER(LEN_TRIM(msg) + 20) :: testmsg, idmsg) - WRITE (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', TRIM(msg), '"' - testmsg = TRIM(msg) - ELSE - ALLOCATE (CHARACTER(30) :: testmsg, idmsg) - WRITE (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 - testmsg = "" - END IF - WRITE (unit=gotmsg, fmt='(A,L1)') ' got: ', got - WRITE (unit=expectedmsg, fmt='(A,L1)') 'expected: ', expected - - good = got .EQV. expected - CALL testline(good, testmsg, idmsg, gotmsg, expectedmsg) -END SUBROUTINE is_l - -END MODULE Test_More diff --git a/src/modules/Test/src/Test_Planning.F90 b/src/modules/Test/src/Test_Planning.F90 deleted file mode 100644 index 7b8c59c83..000000000 --- a/src/modules/Test/src/Test_Planning.F90 +++ /dev/null @@ -1,77 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE Test_Planning -USE test_base, ONLY: test_unit, tests -IMPLICIT NONE - -INTEGER, PRIVATE :: planned = 0 - -CONTAINS - -SUBROUTINE bail_out(msg) - CHARACTER(*), INTENT(in), OPTIONAL :: msg - IF (PRESENT(msg)) THEN - WRITE (test_unit, '("Bail out! ",A)') msg - ELSE - WRITE (test_unit, '("Bail out!")') - END IF - STOP -END SUBROUTINE bail_out - -SUBROUTINE plan(tests) - INTEGER, INTENT(in) :: tests - - SELECT CASE (tests) - CASE (:-1) - CALL bail_out("A plan with a negative number of tests") - CASE (0) - WRITE (test_unit, '("1..0")') - STOP ! The same as skip_all without a given reason - CASE (1:) - IF (planned > 0) & - & CALL bail_out("More than one plan in test output") - planned = tests - WRITE (test_unit, '("1..",I0)') planned - END SELECT -END SUBROUTINE plan - -SUBROUTINE done_testing(howmany) - INTEGER, INTENT(in), OPTIONAL :: howmany - - ! Put plan at the end of test output - IF (PRESENT(howmany)) THEN - CALL plan(howmany) - ELSE - IF (planned == 0) CALL plan(tests) - ! else - We already have a plan - END IF -END SUBROUTINE done_testing - -SUBROUTINE skip_all(msg) - CHARACTER(*), INTENT(in), OPTIONAL :: msg - IF (PRESENT(msg)) THEN - WRITE (test_unit, '("1..0 # Skipped: ",A)') msg - ELSE - WRITE (test_unit, '("1..0 # Skipped all")') - END IF - STOP -END SUBROUTINE skip_all - -END MODULE Test_Planning diff --git a/src/modules/Test/src/is_i.inc b/src/modules/Test/src/is_i.inc deleted file mode 100644 index 7f98a0908..000000000 --- a/src/modules/Test/src/is_i.inc +++ /dev/null @@ -1,24 +0,0 @@ -! Template parameter: wp (working precision) -! Template free identifiers: testline, tests -subroutine is(got, expected, msg) - integer(kind=wp), intent(in) :: got, expected - character(len=*), intent(in), optional :: msg - character(len=:), allocatable :: testmsg, idmsg - character(len=120) gotmsg, expectedmsg - logical good - - if (present(msg)) then - allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) - write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' - testmsg = trim(msg) - else - allocate(character(len=30) :: testmsg, idmsg) - write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 - testmsg = "" - end if - write (unit=gotmsg, fmt='(A,I0)') ' got: ', got - write (unit=expectedmsg, fmt='(A,I0)') 'expected: ', expected - - good = got == expected - call testline(good, testmsg, idmsg, gotmsg, expectedmsg) -end diff --git a/src/modules/Test/src/is_r.inc b/src/modules/Test/src/is_r.inc deleted file mode 100644 index 98599716b..000000000 --- a/src/modules/Test/src/is_r.inc +++ /dev/null @@ -1,83 +0,0 @@ -! Template parameter: wp (working precision) -! Template free identifiers: testline, tests -subroutine isabs(got, expected, eps, msg) - real(kind=wp), intent(in) :: got, expected - character(len=*), intent(in), optional :: msg - real(kind=wp), intent(in), optional :: eps - character(len=:), allocatable :: testmsg, idmsg - character(len=120) gotmsg, expectedmsg - real(kind=wp) tolerance - logical good - - if (present(msg)) then - allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) - write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' - testmsg = trim(msg) - else - allocate(character(len=30) :: testmsg, idmsg) - write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 - testmsg = "" - end if - write (unit=gotmsg, fmt='(A,G0)') ' got: ', got - write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected - - if (present(eps)) then - tolerance = eps - else - tolerance = epsilon(got) - end if - ! eps = 0.5e-10_wp - ! Absolute accuracy within the 10 least significant digits - good = abs(got - expected) < tolerance - call testline(good, testmsg, idmsg, gotmsg, expectedmsg) -end - -subroutine isrel(got, expected, eps, msg) - real(kind=wp), intent(in) :: got, expected - character(len=*), intent(in), optional :: msg - real(kind=wp), intent(in), optional :: eps - real(kind=wp) tolerance - - ! eps = (abs(a) + abs(b)) * 0.5e-10_wp - ! Relative accuracy within the 10 most significant digits - tolerance = (abs(got) + abs(expected)) - if (present(eps)) then - tolerance = tolerance * eps - else - tolerance = tolerance * epsilon(got) - end if - call isabs(got, expected, tolerance, msg) -end - -subroutine isnear(got, expected, eps, msg) - real(kind=wp), intent(in) :: got, expected - character(len=*), intent(in), optional :: msg - real(kind=wp), intent(in), optional :: eps - character(len=:), allocatable :: testmsg, idmsg - character(len=120) gotmsg, expectedmsg - real(kind=wp) tolerance - logical good - - if (present(msg)) then - allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) - write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' - testmsg = trim(msg) - else - allocate(character(len=30) :: testmsg, idmsg) - write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 - testmsg = "" - end if - write (unit=gotmsg, fmt='(A,G0)') ' got: ', got - write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected - - if (present(eps)) then - tolerance = eps - else - tolerance = epsilon(got) ! minimun eps for which 1 + eps /= 1 - end if - ! Relative accuracy around 1.0_wp - ! Semantics of isnear means using <=, and not <, c.f. epsilon(got) - good = abs(got / expected - 1.0_wp) <= tolerance - call testline(good, testmsg, idmsg, gotmsg, expectedmsg) -end - diff --git a/src/modules/TriangleInterface/CMakeLists.txt b/src/modules/TriangleInterface/CMakeLists.txt deleted file mode 100644 index 90f73fd70..000000000 --- a/src/modules/TriangleInterface/CMakeLists.txt +++ /dev/null @@ -1,63 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources(${PROJECT_NAME} PRIVATE ${src_path}/TriangleInterface.F90) - -add_library(easifemTriangle STATIC - ${src_path}/triangle.c - ${src_path}/report.c -) - -target_link_libraries(${PROJECT_NAME} PUBLIC easifemTriangle) - -list(APPEND TRIANGLE_COMPILE_DEF "-DTRILIBRARY" "-DANSI_DECLARATORS" -"-DNO_TIMER") - -if(USE_Real64) - list(APPEND TRIANGLE_COMPILE_DEF "-DUSE_Real64") -endif() - -if(LINUX) - list(APPEND TRIANGLE_COMPILE_DEF "-DLINUX") - -elseif(WIN32) - list(APPEND TRIANGLE_COMPILE_DEF "-DCPU86") - -endif() - -target_compile_definitions(easifemTriangle PRIVATE ${TRIANGLE_COMPILE_DEF}) - -list(APPEND TRIANGLE_COMPILE_OPTIONS "-O3") - -target_compile_options(easifemTriangle PRIVATE ${TRIANGLE_COMPILE_OPTIONS}) - -# target properties -set_target_properties( - easifemTriangle - PROPERTIES POSITION_INDEPENDENT_CODE 1 - SOVERSION ${VERSION_MAJOR} - # OUTPUT_NAME ${PROJECT_NAME} - LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - MACOSX_RPATH ON - WINDOWS_EXPORT_ALL_SYMBOLS ON - LINKER_LANGUAGE C ) - -list(APPEND C_PROJECTS "easifemTriangle") diff --git a/src/modules/TriangleInterface/src/TriangleInterface.F90 b/src/modules/TriangleInterface/src/TriangleInterface.F90 deleted file mode 100644 index 27a631956..000000000 --- a/src/modules/TriangleInterface/src/TriangleInterface.F90 +++ /dev/null @@ -1,257 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE TriangleInterface -USE ISO_C_BINDING, ONLY: C_INT, C_CHAR, C_PTR, C_NULL_PTR -USE GlobalData, ONLY: DFP, I4B, LGT - -IMPLICIT NONE -PRIVATE - -PUBLIC :: TriangulateIO_ -PUBLIC :: Triangulate -PUBLIC :: TriangleReport -PUBLIC :: TriangleFree -PUBLIC :: TriangleDeallocate -PUBLIC :: TriangleSetParam -PUBLIC :: TriangleGetParam -PUBLIC :: TriangleNullify -PUBLIC :: TriangleDisplay -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! TriangulateIO_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-09 -! summary: TringulateIO - -TYPE, BIND(c) :: TriangulateIO_ - TYPE(C_PTR) :: pointlist = C_NULL_PTR - TYPE(C_PTR) :: pointattributelist = C_NULL_PTR - TYPE(C_PTR) :: pointmarkerlist = C_NULL_PTR - INTEGER(C_INT) :: numberofpoints = 0 - INTEGER(C_INT) :: numberofpointattributes = 0 - - TYPE(C_PTR) :: trianglelist = C_NULL_PTR - TYPE(C_PTR) :: triangleattributelist = C_NULL_PTR - TYPE(C_PTR) :: trianglearealist = C_NULL_PTR - !! In - TYPE(C_PTR) :: neighborlist = C_NULL_PTR - !! Out - INTEGER(C_INT) :: numberoftriangles = 0 - INTEGER(C_INT) :: numberofcorners = 0 - INTEGER(C_INT) :: numberoftriangleattributes = 0 - - TYPE(C_PTR) :: segmentlist = C_NULL_PTR - !! Inout - TYPE(C_PTR) :: segmentmarkerlist = C_NULL_PTR - !! Inout - INTEGER(C_INT) :: numberofsegments = 0 - !! Inout - - TYPE(C_PTR) :: holelist = C_NULL_PTR - !! In, but pointer to array copied out - INTEGER(C_INT) :: numberofholes = 0 - !! In, but copied out - - TYPE(C_PTR) :: regionlist = C_NULL_PTR - !! In, but pointer to array copied out - INTEGER(C_INT) :: numberofregions = 0 - !! In but copied out - - TYPE(C_PTR) :: edgelist = C_NULL_PTR - !! Out only - TYPE(C_PTR) :: edgemarkerlist = C_NULL_PTR - !! Not used with Voronoi diagram, out only - TYPE(C_PTR) :: normlist = C_NULL_PTR - !! Used only with Voronoi diagram, out only - INTEGER(C_INT) :: numberofedges = 0 - !! Out only - -END TYPE TriangulateIO_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - ! void triangulate(char *, struct triangulateio *, struct triangulateio *, - ! struct triangulateio *) - SUBROUTINE Triangulate(triswitches, in, out, vorout) & - BIND(c, name='triangulate') - IMPORT :: C_CHAR, TriangulateIO_ - CHARACTER(kind=C_CHAR), INTENT(IN) :: triswitches - TYPE(TriangulateIO_), INTENT(INOUT) :: in - TYPE(TriangulateIO_), INTENT(INOUT) :: out - TYPE(TriangulateIO_), INTENT(INOUT) :: vorout - END SUBROUTINE Triangulate -END INTERFACE - -!---------------------------------------------------------------------------- -! TriangleReport -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE TriangleReport(io, markers, reporttriangles, & - reportneighbors, reportsegments, reportedges, reportnorms) & - BIND(c, name="report") - IMPORT :: TriangulateIO_, C_INT - TYPE(TriangulateIO_), INTENT(IN) :: io - INTEGER(C_INT), VALUE, INTENT(IN) :: markers - INTEGER(C_INT), VALUE, INTENT(IN) :: reporttriangles - INTEGER(C_INT), VALUE, INTENT(IN) :: reportneighbors - INTEGER(C_INT), VALUE, INTENT(IN) :: reportsegments - INTEGER(C_INT), VALUE, INTENT(IN) :: reportedges - INTEGER(C_INT), VALUE, INTENT(IN) :: reportnorms - END SUBROUTINE TriangleReport -END INTERFACE - -!---------------------------------------------------------------------------- -! TriangleReport -!---------------------------------------------------------------------------- - -INTERFACE TriangleFree - SUBROUTINE TriangleFree1(io) BIND(c, name="trianglefree") - IMPORT :: TriangulateIO_ - TYPE(TriangulateIO_), INTENT(INOUT) :: io - END SUBROUTINE TriangleFree1 -END INTERFACE TriangleFree - -!---------------------------------------------------------------------------- -! TriangleReport -!---------------------------------------------------------------------------- - -INTERFACE TriangleFree - SUBROUTINE TriangleFree2(io) BIND(c, name="trifree") - IMPORT :: C_PTR - TYPE(C_PTR), VALUE, INTENT(IN) :: io - END SUBROUTINE TriangleFree2 -END INTERFACE TriangleFree - -!---------------------------------------------------------------------------- -! TriangleReport@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE TriangleDeallocate(obj) - TYPE(TriangulateIO_), INTENT(INOUT) :: obj - END SUBROUTINE TriangleDeallocate -END INTERFACE - -!---------------------------------------------------------------------------- -! TriangleSetPointList -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE TriangleSetParam(obj, pointList, pointattributelist, & - pointmarkerlist, numberofpoints, numberofpointattributes, & - trianglelist, triangleattributelist, trianglearealist, neighborlist, & -numberoftriangles, numberofcorners, numberoftriangleattributes, segmentlist, & - segmentmarkerlist, numberofsegments, holelist, numberofholes, regionlist, & - numberofregions, edgelist, edgemarkerlist, normlist, numberofedges) - TYPE(TriangulateIO_), INTENT(INOUT) :: obj - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: pointList(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: pointattributelist(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: pointmarkerlist(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofpoints - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofpointattributes - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: trianglelist(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: triangleattributelist(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: trianglearealist(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: neighborlist(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberoftriangles - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofcorners - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberoftriangleattributes - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: segmentlist(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: segmentmarkerlist(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofsegments - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: holelist(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofholes - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: regionlist(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofregions - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: edgelist(:) - INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: edgemarkerlist(:) - REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: normlist(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofedges - END SUBROUTINE TriangleSetParam -END INTERFACE - -!---------------------------------------------------------------------------- -! TriangleSetPointList -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE TriangleGetParam(obj, pointlist, pointattributelist, & - pointmarkerlist, numberofpoints, numberofpointattributes, & - trianglelist, triangleattributelist, trianglearealist, neighborlist, & -numberoftriangles, numberofcorners, numberoftriangleattributes, segmentlist, & - segmentmarkerlist, numberofsegments, holelist, numberofholes, regionlist, & - numberofregions, edgelist, edgemarkerlist, normlist, numberofedges) - TYPE(TriangulateIO_), INTENT(IN) :: obj - REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: pointlist(:) - REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: pointattributelist(:) - INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: pointmarkerlist(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofpoints - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofpointattributes - INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: trianglelist(:) - REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: triangleattributelist(:) - REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: trianglearealist(:) - INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: neighborlist(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberoftriangles - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofcorners - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberoftriangleattributes - INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: segmentlist(:) - INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: segmentmarkerlist(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofsegments - REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: holelist(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofholes - REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: regionlist(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofregions - INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: edgelist(:) - INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: edgemarkerlist(:) - REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: normlist(:) - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofedges - END SUBROUTINE TriangleGetParam -END INTERFACE - -!---------------------------------------------------------------------------- -! TriangleNullify -!---------------------------------------------------------------------------- - -INTERFACE - MODULE SUBROUTINE TriangleNullify(obj) - TYPE(TriangulateIO_), INTENT(INOUT) :: obj - END SUBROUTINE TriangleNullify -END INTERFACE - -!---------------------------------------------------------------------------- -! TriangleDisplay -!---------------------------------------------------------------------------- - -INTERFACE Display - MODULE SUBROUTINE TriangleDisplay(obj, msg, unitno) - TYPE(TriangulateIO_), INTENT(INOUT) :: obj - CHARACTER(*), INTENT(IN) :: msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno - END SUBROUTINE TriangleDisplay -END INTERFACE Display - -END MODULE TriangleInterface diff --git a/src/modules/TriangleInterface/src/report.c b/src/modules/TriangleInterface/src/report.c deleted file mode 100644 index e7a89f0e6..000000000 --- a/src/modules/TriangleInterface/src/report.c +++ /dev/null @@ -1,126 +0,0 @@ -/* The next line is used to outsmart some very stupid compilers. If your */ -/* compiler is smarter, feel free to replace the "int" with "void". */ -/* Not that it matters. */ - -#define VOID int - -// this void is also defined in triangle.c - -#include "triangle.h" -#include -#include - -void report(struct triangulateio *, int, int, int, int, int, int); -void trianglefree(struct triangulateio *); - -void report(io, markers, reporttriangles, reportneighbors, reportsegments, - reportedges, reportnorms) struct triangulateio *io; -int markers; -int reporttriangles; -int reportneighbors; -int reportsegments; -int reportedges; -int reportnorms; -{ - int i, j; - - for (i = 0; i < io->numberofpoints; i++) { - printf("Point %4d:", i); - for (j = 0; j < 2; j++) { - printf(" %.6g", io->pointlist[i * 2 + j]); - } - if (io->numberofpointattributes > 0) { - printf(" attributes"); - } - for (j = 0; j < io->numberofpointattributes; j++) { - printf(" %.6g", - io->pointattributelist[i * io->numberofpointattributes + j]); - } - if (markers) { - printf(" marker %d\n", io->pointmarkerlist[i]); - } else { - printf("\n"); - } - } - printf("\n"); - - if (reporttriangles || reportneighbors) { - for (i = 0; i < io->numberoftriangles; i++) { - if (reporttriangles) { - printf("Triangle %4d points:", i); - for (j = 0; j < io->numberofcorners; j++) { - printf(" %4d", io->trianglelist[i * io->numberofcorners + j]); - } - if (io->numberoftriangleattributes > 0) { - printf(" attributes"); - } - for (j = 0; j < io->numberoftriangleattributes; j++) { - printf(" %.6g", - io->triangleattributelist[i * io->numberoftriangleattributes + - j]); - } - printf("\n"); - } - if (reportneighbors) { - printf("Triangle %4d neighbors:", i); - for (j = 0; j < 3; j++) { - printf(" %4d", io->neighborlist[i * 3 + j]); - } - printf("\n"); - } - } - printf("\n"); - } - - if (reportsegments) { - for (i = 0; i < io->numberofsegments; i++) { - printf("Segment %4d points:", i); - for (j = 0; j < 2; j++) { - printf(" %4d", io->segmentlist[i * 2 + j]); - } - if (markers) { - printf(" marker %d\n", io->segmentmarkerlist[i]); - } else { - printf("\n"); - } - } - printf("\n"); - } - - if (reportedges) { - for (i = 0; i < io->numberofedges; i++) { - printf("Edge %4d points:", i); - for (j = 0; j < 2; j++) { - printf(" %4d", io->edgelist[i * 2 + j]); - } - if (reportnorms && (io->edgelist[i * 2 + 1] == -1)) { - for (j = 0; j < 2; j++) { - printf(" %.6g", io->normlist[i * 2 + j]); - } - } - if (markers) { - printf(" marker %d\n", io->edgemarkerlist[i]); - } else { - printf("\n"); - } - } - printf("\n"); - } -} - -void trianglefree(struct triangulateio *io) { - - free(io->pointlist); - free(io->pointattributelist); - free(io->pointmarkerlist); - free(io->trianglelist); - free(io->triangleattributelist); - free(io->trianglearealist); - free(io->neighborlist); - free(io->segmentlist); - free(io->segmentmarkerlist); - free(io->holelist); - free(io->regionlist); - free(io->edgelist); - free(io->edgemarkerlist); -} diff --git a/src/modules/TriangleInterface/src/triangle.c b/src/modules/TriangleInterface/src/triangle.c deleted file mode 100644 index 4ff0e0270..000000000 --- a/src/modules/TriangleInterface/src/triangle.c +++ /dev/null @@ -1,15737 +0,0 @@ -/*****************************************************************************/ -/* */ -/* 888888888 ,o, / 888 */ -/* 888 88o88o " o8888o 88o8888o o88888o 888 o88888o */ -/* 888 888 888 88b 888 888 888 888 888 d888 88b */ -/* 888 888 888 o88^o888 888 888 "88888" 888 8888oo888 */ -/* 888 888 888 C888 888 888 888 / 888 q888 */ -/* 888 888 888 "88o^888 888 888 Cb 888 "88oooo" */ -/* "8oo8D */ -/* */ -/* A Two-Dimensional Quality Mesh Generator and Delaunay Triangulator. */ -/* (triangle.c) */ -/* */ -/* Version 1.6 */ -/* July 28, 2005 */ -/* */ -/* Copyright 1993, 1995, 1997, 1998, 2002, 2005 */ -/* Jonathan Richard Shewchuk */ -/* 2360 Woolsey #H */ -/* Berkeley, California 94705-1927 */ -/* jrs@cs.berkeley.edu */ -/* */ -/* This program may be freely redistributed under the condition that the */ -/* copyright notices (including this entire header and the copyright */ -/* notice printed when the `-h' switch is selected) are not removed, and */ -/* no compensation is received. Private, research, and institutional */ -/* use is free. You may distribute modified versions of this code UNDER */ -/* THE CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE TO IT IN THE */ -/* SAME FILE REMAIN UNDER COPYRIGHT OF THE ORIGINAL AUTHOR, BOTH SOURCE */ -/* AND OBJECT CODE ARE MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR */ -/* NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution of this code as */ -/* part of a commercial system is permissible ONLY BY DIRECT ARRANGEMENT */ -/* WITH THE AUTHOR. (If you are not directly supplying this code to a */ -/* customer, and you are instead telling them how they can obtain it for */ -/* free, then you are not required to make any arrangement with me.) */ -/* */ -/* Hypertext instructions for Triangle are available on the Web at */ -/* */ -/* http://www.cs.cmu.edu/~quake/triangle.html */ -/* */ -/* Disclaimer: Neither I nor Carnegie Mellon warrant this code in any way */ -/* whatsoever. This code is provided "as-is". Use at your own risk. */ -/* */ -/* Some of the references listed below are marked with an asterisk. [*] */ -/* These references are available for downloading from the Web page */ -/* */ -/* http://www.cs.cmu.edu/~quake/triangle.research.html */ -/* */ -/* Three papers discussing aspects of Triangle are available. A short */ -/* overview appears in "Triangle: Engineering a 2D Quality Mesh */ -/* Generator and Delaunay Triangulator," in Applied Computational */ -/* Geometry: Towards Geometric Engineering, Ming C. Lin and Dinesh */ -/* Manocha, editors, Lecture Notes in Computer Science volume 1148, */ -/* pages 203-222, Springer-Verlag, Berlin, May 1996 (from the First ACM */ -/* Workshop on Applied Computational Geometry). [*] */ -/* */ -/* The algorithms are discussed in the greatest detail in "Delaunay */ -/* Refinement Algorithms for Triangular Mesh Generation," Computational */ -/* Geometry: Theory and Applications 22(1-3):21-74, May 2002. [*] */ -/* */ -/* More detail about the data structures may be found in my dissertation: */ -/* "Delaunay Refinement Mesh Generation," Ph.D. thesis, Technical Report */ -/* CMU-CS-97-137, School of Computer Science, Carnegie Mellon University, */ -/* Pittsburgh, Pennsylvania, 18 May 1997. [*] */ -/* */ -/* Triangle was created as part of the Quake Project in the School of */ -/* Computer Science at Carnegie Mellon University. For further */ -/* information, see Hesheng Bao, Jacobo Bielak, Omar Ghattas, Loukas F. */ -/* Kallivokas, David R. O'Hallaron, Jonathan R. Shewchuk, and Jifeng Xu, */ -/* "Large-scale Simulation of Elastic Wave Propagation in Heterogeneous */ -/* Media on Parallel Computers," Computer Methods in Applied Mechanics */ -/* and Engineering 152(1-2):85-102, 22 January 1998. */ -/* */ -/* Triangle's Delaunay refinement algorithm for quality mesh generation is */ -/* a hybrid of one due to Jim Ruppert, "A Delaunay Refinement Algorithm */ -/* for Quality 2-Dimensional Mesh Generation," Journal of Algorithms */ -/* 18(3):548-585, May 1995 [*], and one due to L. Paul Chew, "Guaranteed- */ -/* Quality Mesh Generation for Curved Surfaces," Proceedings of the Ninth */ -/* Annual Symposium on Computational Geometry (San Diego, California), */ -/* pages 274-280, Association for Computing Machinery, May 1993, */ -/* http://portal.acm.org/citation.cfm?id=161150 . */ -/* */ -/* The Delaunay refinement algorithm has been modified so that it meshes */ -/* domains with small input angles well, as described in Gary L. Miller, */ -/* Steven E. Pav, and Noel J. Walkington, "When and Why Ruppert's */ -/* Algorithm Works," Twelfth International Meshing Roundtable, pages */ -/* 91-102, Sandia National Laboratories, September 2003. [*] */ -/* */ -/* My implementation of the divide-and-conquer and incremental Delaunay */ -/* triangulation algorithms follows closely the presentation of Guibas */ -/* and Stolfi, even though I use a triangle-based data structure instead */ -/* of their quad-edge data structure. (In fact, I originally implemented */ -/* Triangle using the quad-edge data structure, but the switch to a */ -/* triangle-based data structure sped Triangle by a factor of two.) The */ -/* mesh manipulation primitives and the two aforementioned Delaunay */ -/* triangulation algorithms are described by Leonidas J. Guibas and Jorge */ -/* Stolfi, "Primitives for the Manipulation of General Subdivisions and */ -/* the Computation of Voronoi Diagrams," ACM Transactions on Graphics */ -/* 4(2):74-123, April 1985, http://portal.acm.org/citation.cfm?id=282923 .*/ -/* */ -/* Their O(n log n) divide-and-conquer algorithm is adapted from Der-Tsai */ -/* Lee and Bruce J. Schachter, "Two Algorithms for Constructing the */ -/* Delaunay Triangulation," International Journal of Computer and */ -/* Information Science 9(3):219-242, 1980. Triangle's improvement of the */ -/* divide-and-conquer algorithm by alternating between vertical and */ -/* horizontal cuts was introduced by Rex A. Dwyer, "A Faster Divide-and- */ -/* Conquer Algorithm for Constructing Delaunay Triangulations," */ -/* Algorithmica 2(2):137-151, 1987. */ -/* */ -/* The incremental insertion algorithm was first proposed by C. L. Lawson, */ -/* "Software for C1 Surface Interpolation," in Mathematical Software III, */ -/* John R. Rice, editor, Academic Press, New York, pp. 161-194, 1977. */ -/* For point location, I use the algorithm of Ernst P. Mucke, Isaac */ -/* Saias, and Binhai Zhu, "Fast Randomized Point Location Without */ -/* Preprocessing in Two- and Three-Dimensional Delaunay Triangulations," */ -/* Proceedings of the Twelfth Annual Symposium on Computational Geometry, */ -/* ACM, May 1996. [*] If I were to randomize the order of vertex */ -/* insertion (I currently don't bother), their result combined with the */ -/* result of Kenneth L. Clarkson and Peter W. Shor, "Applications of */ -/* Random Sampling in Computational Geometry II," Discrete & */ -/* Computational Geometry 4(1):387-421, 1989, would yield an expected */ -/* O(n^{4/3}) bound on running time. */ -/* */ -/* The O(n log n) sweepline Delaunay triangulation algorithm is taken from */ -/* Steven Fortune, "A Sweepline Algorithm for Voronoi Diagrams", */ -/* Algorithmica 2(2):153-174, 1987. A random sample of edges on the */ -/* boundary of the triangulation are maintained in a splay tree for the */ -/* purpose of point location. Splay trees are described by Daniel */ -/* Dominic Sleator and Robert Endre Tarjan, "Self-Adjusting Binary Search */ -/* Trees," Journal of the ACM 32(3):652-686, July 1985, */ -/* http://portal.acm.org/citation.cfm?id=3835 . */ -/* */ -/* The algorithms for exact computation of the signs of determinants are */ -/* described in Jonathan Richard Shewchuk, "Adaptive Precision Floating- */ -/* Point Arithmetic and Fast Robust Geometric Predicates," Discrete & */ -/* Computational Geometry 18(3):305-363, October 1997. (Also available */ -/* as Technical Report CMU-CS-96-140, School of Computer Science, */ -/* Carnegie Mellon University, Pittsburgh, Pennsylvania, May 1996.) [*] */ -/* An abbreviated version appears as Jonathan Richard Shewchuk, "Robust */ -/* Adaptive Floating-Point Geometric Predicates," Proceedings of the */ -/* Twelfth Annual Symposium on Computational Geometry, ACM, May 1996. [*] */ -/* Many of the ideas for my exact arithmetic routines originate with */ -/* Douglas M. Priest, "Algorithms for Arbitrary Precision Floating Point */ -/* Arithmetic," Tenth Symposium on Computer Arithmetic, pp. 132-143, IEEE */ -/* Computer Society Press, 1991. [*] Many of the ideas for the correct */ -/* evaluation of the signs of determinants are taken from Steven Fortune */ -/* and Christopher J. Van Wyk, "Efficient Exact Arithmetic for Computa- */ -/* tional Geometry," Proceedings of the Ninth Annual Symposium on */ -/* Computational Geometry, ACM, pp. 163-172, May 1993, and from Steven */ -/* Fortune, "Numerical Stability of Algorithms for 2D Delaunay Triangu- */ -/* lations," International Journal of Computational Geometry & Applica- */ -/* tions 5(1-2):193-213, March-June 1995. */ -/* */ -/* The method of inserting new vertices off-center (not precisely at the */ -/* circumcenter of every poor-quality triangle) is from Alper Ungor, */ -/* "Off-centers: A New Type of Steiner Points for Computing Size-Optimal */ -/* Quality-Guaranteed Delaunay Triangulations," Proceedings of LATIN */ -/* 2004 (Buenos Aires, Argentina), April 2004. */ -/* */ -/* For definitions of and results involving Delaunay triangulations, */ -/* constrained and conforming versions thereof, and other aspects of */ -/* triangular mesh generation, see the excellent survey by Marshall Bern */ -/* and David Eppstein, "Mesh Generation and Optimal Triangulation," in */ -/* Computing and Euclidean Geometry, Ding-Zhu Du and Frank Hwang, */ -/* editors, World Scientific, Singapore, pp. 23-90, 1992. [*] */ -/* */ -/* The time for incrementally adding PSLG (planar straight line graph) */ -/* segments to create a constrained Delaunay triangulation is probably */ -/* O(t^2) per segment in the worst case and O(t) per segment in the */ -/* common case, where t is the number of triangles that intersect the */ -/* segment before it is inserted. This doesn't count point location, */ -/* which can be much more expensive. I could improve this to O(d log d) */ -/* time, but d is usually quite small, so it's not worth the bother. */ -/* (This note does not apply when the -s switch is used, invoking a */ -/* different method is used to insert segments.) */ -/* */ -/* The time for deleting a vertex from a Delaunay triangulation is O(d^2) */ -/* in the worst case and O(d) in the common case, where d is the degree */ -/* of the vertex being deleted. I could improve this to O(d log d) time, */ -/* but d is usually quite small, so it's not worth the bother. */ -/* */ -/* Ruppert's Delaunay refinement algorithm typically generates triangles */ -/* at a linear rate (constant time per triangle) after the initial */ -/* triangulation is formed. There may be pathological cases where */ -/* quadratic time is required, but these never arise in practice. */ -/* */ -/* The geometric predicates (circumcenter calculations, segment */ -/* intersection formulae, etc.) appear in my "Lecture Notes on Geometric */ -/* Robustness" at http://www.cs.berkeley.edu/~jrs/mesh . */ -/* */ -/* If you make any improvements to this code, please please please let me */ -/* know, so that I may obtain the improvements. Even if you don't change */ -/* the code, I'd still love to hear what it's being used for. */ -/* */ -/*****************************************************************************/ - -/* For single precision (which will save some memory and reduce paging), */ -/* define the symbol SINGLE by using the -DSINGLE compiler switch or by */ -/* writing "#define SINGLE" below. */ -/* */ -/* For double precision (which will allow you to refine meshes to a smaller */ -/* edge length), leave SINGLE undefined. */ -/* */ -/* Double precision uses more memory, but improves the resolution of the */ -/* meshes you can generate with Triangle. It also reduces the likelihood */ -/* of a floating exception due to overflow. Finally, it is much faster */ -/* than single precision on 64-bit architectures like the DEC Alpha. I */ -/* recommend double precision unless you want to generate a mesh for which */ -/* you do not have enough memory. */ - -/* #define SINGLE */ - -#ifdef USE_Real64 -#define REAL double -#else -#define REAL float -#endif - -/* If yours is not a Unix system, define the NO_TIMER compiler switch to */ -/* remove the Unix-specific timing code. */ - -/* #define NO_TIMER */ - -/* To insert lots of self-checks for internal errors, define the SELF_CHECK */ -/* symbol. This will slow down the program significantly. It is best to */ -/* define the symbol using the -DSELF_CHECK compiler switch, but you could */ -/* write "#define SELF_CHECK" below. If you are modifying this code, I */ -/* recommend you turn self-checks on until your work is debugged. */ - -/* #define SELF_CHECK */ - -/* To compile Triangle as a callable object library (triangle.o), define the */ -/* TRILIBRARY symbol. Read the file triangle.h for details on how to call */ -/* the procedure triangulate() that results. */ - -/* #define TRILIBRARY */ - -/* It is possible to generate a smaller version of Triangle using one or */ -/* both of the following symbols. Define the REDUCED symbol to eliminate */ -/* all features that are primarily of research interest; specifically, the */ -/* -i, -F, -s, and -C switches. Define the CDT_ONLY symbol to eliminate */ -/* all meshing algorithms above and beyond constrained Delaunay */ -/* triangulation; specifically, the -r, -q, -a, -u, -D, -S, and -s */ -/* switches. These reductions are most likely to be useful when */ -/* generating an object library (triangle.o) by defining the TRILIBRARY */ -/* symbol. */ - -/* #define REDUCED */ -/* #define CDT_ONLY */ - -/* On some machines, my exact arithmetic routines might be defeated by the */ -/* use of internal extended precision floating-point registers. The best */ -/* way to solve this problem is to set the floating-point registers to use */ -/* single or double precision internally. On 80x86 processors, this may */ -/* be accomplished by setting the CPU86 symbol for the Microsoft C */ -/* compiler, or the LINUX symbol for the gcc compiler running on Linux. */ -/* */ -/* An inferior solution is to declare certain values as `volatile', thus */ -/* forcing them to be stored to memory and rounded off. Unfortunately, */ -/* this solution might slow Triangle down quite a bit. To use volatile */ -/* values, write "#define INEXACT volatile" below. Normally, however, */ -/* INEXACT should be defined to be nothing. ("#define INEXACT".) */ -/* */ -/* For more discussion, see http://www.cs.cmu.edu/~quake/robust.pc.html . */ -/* For yet more discussion, see Section 5 of my paper, "Adaptive Precision */ -/* Floating-Point Arithmetic and Fast Robust Geometric Predicates" (also */ -/* available as Section 6.6 of my dissertation). */ - -/* #define CPU86 */ -/* #define LINUX */ - -#define INEXACT /* Nothing */ -/* #define INEXACT volatile */ - -/* Maximum number of characters in a file name (including the null). */ - -#define FILENAMESIZE 2048 - -/* Maximum number of characters in a line read from a file (including the */ -/* null). */ - -#define INPUTLINESIZE 1024 - -/* For efficiency, a variety of data structures are allocated in bulk. The */ -/* following constants determine how many of each structure is allocated */ -/* at once. */ - -#define TRIPERBLOCK 4092 /* Number of triangles allocated at once. */ -#define SUBSEGPERBLOCK 508 /* Number of subsegments allocated at once. */ -#define VERTEXPERBLOCK 4092 /* Number of vertices allocated at once. */ -#define VIRUSPERBLOCK 1020 /* Number of virus triangles allocated at once. */ -/* Number of encroached subsegments allocated at once. */ -#define BADSUBSEGPERBLOCK 252 -/* Number of skinny triangles allocated at once. */ -#define BADTRIPERBLOCK 4092 -/* Number of flipped triangles allocated at once. */ -#define FLIPSTACKERPERBLOCK 252 -/* Number of splay tree nodes allocated at once. */ -#define SPLAYNODEPERBLOCK 508 - -/* The vertex types. A DEADVERTEX has been deleted entirely. An */ -/* UNDEADVERTEX is not part of the mesh, but is written to the output */ -/* .node file and affects the node indexing in the other output files. */ - -#define INPUTVERTEX 0 -#define SEGMENTVERTEX 1 -#define FREEVERTEX 2 -#define DEADVERTEX -32768 -#define UNDEADVERTEX -32767 - -/* The next line is used to outsmart some very stupid compilers. If your */ -/* compiler is smarter, feel free to replace the "int" with "void". */ -/* Not that it matters. */ - -#define VOID int - -/* Two constants for algorithms based on random sampling. Both constants */ -/* have been chosen empirically to optimize their respective algorithms. */ - -/* Used for the point location scheme of Mucke, Saias, and Zhu, to decide */ -/* how large a random sample of triangles to inspect. */ - -#define SAMPLEFACTOR 11 - -/* Used in Fortune's sweepline Delaunay algorithm to determine what fraction */ -/* of boundary edges should be maintained in the splay tree for point */ -/* location on the front. */ - -#define SAMPLERATE 10 - -/* A number that speaks for itself, every kissable digit. */ - -#define PI 3.141592653589793238462643383279502884197169399375105820974944592308 - -/* Another fave. */ - -#define SQUAREROOTTWO 1.4142135623730950488016887242096980785696718753769480732 - -/* And here's one for those of you who are intimidated by math. */ - -#define ONETHIRD 0.333333333333333333333333333333333333333333333333333333333333 - -#include -#include -#include -#include -#ifndef NO_TIMER -#include -#endif /* not NO_TIMER */ -#ifdef CPU86 -#include -#endif /* CPU86 */ -#ifdef LINUX -#include -#endif /* LINUX */ -#ifdef TRILIBRARY -#include "triangle.h" -#endif /* TRILIBRARY */ - -/* A few forward declarations. */ - -#ifndef TRILIBRARY -char *readline(); -char *findfield(); -#endif /* not TRILIBRARY */ - -/* Labels that signify the result of point location. The result of a */ -/* search indicates that the point falls in the interior of a triangle, on */ -/* an edge, on a vertex, or outside the mesh. */ - -enum locateresult { INTRIANGLE, ONEDGE, ONVERTEX, OUTSIDE }; - -/* Labels that signify the result of vertex insertion. The result indicates */ -/* that the vertex was inserted with complete success, was inserted but */ -/* encroaches upon a subsegment, was not inserted because it lies on a */ -/* segment, or was not inserted because another vertex occupies the same */ -/* location. */ - -enum insertvertexresult { - SUCCESSFULVERTEX, - ENCROACHINGVERTEX, - VIOLATINGVERTEX, - DUPLICATEVERTEX -}; - -/* Labels that signify the result of direction finding. The result */ -/* indicates that a segment connecting the two query points falls within */ -/* the direction triangle, along the left edge of the direction triangle, */ -/* or along the right edge of the direction triangle. */ - -enum finddirectionresult { WITHIN, LEFTCOLLINEAR, RIGHTCOLLINEAR }; - -/*****************************************************************************/ -/* */ -/* The basic mesh data structures */ -/* */ -/* There are three: vertices, triangles, and subsegments (abbreviated */ -/* `subseg'). These three data structures, linked by pointers, comprise */ -/* the mesh. A vertex simply represents a mesh vertex and its properties. */ -/* A triangle is a triangle. A subsegment is a special data structure used */ -/* to represent an impenetrable edge of the mesh (perhaps on the outer */ -/* boundary, on the boundary of a hole, or part of an internal boundary */ -/* separating two triangulated regions). Subsegments represent boundaries, */ -/* defined by the user, that triangles may not lie across. */ -/* */ -/* A triangle consists of a list of three vertices, a list of three */ -/* adjoining triangles, a list of three adjoining subsegments (when */ -/* segments exist), an arbitrary number of optional user-defined */ -/* floating-point attributes, and an optional area constraint. The latter */ -/* is an upper bound on the permissible area of each triangle in a region, */ -/* used for mesh refinement. */ -/* */ -/* For a triangle on a boundary of the mesh, some or all of the neighboring */ -/* triangles may not be present. For a triangle in the interior of the */ -/* mesh, often no neighboring subsegments are present. Such absent */ -/* triangles and subsegments are never represented by NULL pointers; they */ -/* are represented by two special records: `dummytri', the triangle that */ -/* fills "outer space", and `dummysub', the omnipresent subsegment. */ -/* `dummytri' and `dummysub' are used for several reasons; for instance, */ -/* they can be dereferenced and their contents examined without violating */ -/* protected memory. */ -/* */ -/* However, it is important to understand that a triangle includes other */ -/* information as well. The pointers to adjoining vertices, triangles, and */ -/* subsegments are ordered in a way that indicates their geometric relation */ -/* to each other. Furthermore, each of these pointers contains orientation */ -/* information. Each pointer to an adjoining triangle indicates which face */ -/* of that triangle is contacted. Similarly, each pointer to an adjoining */ -/* subsegment indicates which side of that subsegment is contacted, and how */ -/* the subsegment is oriented relative to the triangle. */ -/* */ -/* The data structure representing a subsegment may be thought to be */ -/* abutting the edge of one or two triangle data structures: either */ -/* sandwiched between two triangles, or resting against one triangle on an */ -/* exterior boundary or hole boundary. */ -/* */ -/* A subsegment consists of a list of four vertices--the vertices of the */ -/* subsegment, and the vertices of the segment it is a part of--a list of */ -/* two adjoining subsegments, and a list of two adjoining triangles. One */ -/* of the two adjoining triangles may not be present (though there should */ -/* always be one), and neighboring subsegments might not be present. */ -/* Subsegments also store a user-defined integer "boundary marker". */ -/* Typically, this integer is used to indicate what boundary conditions are */ -/* to be applied at that location in a finite element simulation. */ -/* */ -/* Like triangles, subsegments maintain information about the relative */ -/* orientation of neighboring objects. */ -/* */ -/* Vertices are relatively simple. A vertex is a list of floating-point */ -/* numbers, starting with the x, and y coordinates, followed by an */ -/* arbitrary number of optional user-defined floating-point attributes, */ -/* followed by an integer boundary marker. During the segment insertion */ -/* phase, there is also a pointer from each vertex to a triangle that may */ -/* contain it. Each pointer is not always correct, but when one is, it */ -/* speeds up segment insertion. These pointers are assigned values once */ -/* at the beginning of the segment insertion phase, and are not used or */ -/* updated except during this phase. Edge flipping during segment */ -/* insertion will render some of them incorrect. Hence, don't rely upon */ -/* them for anything. */ -/* */ -/* Other than the exception mentioned above, vertices have no information */ -/* about what triangles, subfacets, or subsegments they are linked to. */ -/* */ -/*****************************************************************************/ - -/*****************************************************************************/ -/* */ -/* Handles */ -/* */ -/* The oriented triangle (`otri') and oriented subsegment (`osub') data */ -/* structures defined below do not themselves store any part of the mesh. */ -/* The mesh itself is made of `triangle's, `subseg's, and `vertex's. */ -/* */ -/* Oriented triangles and oriented subsegments will usually be referred to */ -/* as "handles." A handle is essentially a pointer into the mesh; it */ -/* allows you to "hold" one particular part of the mesh. Handles are used */ -/* to specify the regions in which one is traversing and modifying the mesh.*/ -/* A single `triangle' may be held by many handles, or none at all. (The */ -/* latter case is not a memory leak, because the triangle is still */ -/* connected to other triangles in the mesh.) */ -/* */ -/* An `otri' is a handle that holds a triangle. It holds a specific edge */ -/* of the triangle. An `osub' is a handle that holds a subsegment. It */ -/* holds either the left or right side of the subsegment. */ -/* */ -/* Navigation about the mesh is accomplished through a set of mesh */ -/* manipulation primitives, further below. Many of these primitives take */ -/* a handle and produce a new handle that holds the mesh near the first */ -/* handle. Other primitives take two handles and glue the corresponding */ -/* parts of the mesh together. The orientation of the handles is */ -/* important. For instance, when two triangles are glued together by the */ -/* bond() primitive, they are glued at the edges on which the handles lie. */ -/* */ -/* Because vertices have no information about which triangles they are */ -/* attached to, I commonly represent a vertex by use of a handle whose */ -/* origin is the vertex. A single handle can simultaneously represent a */ -/* triangle, an edge, and a vertex. */ -/* */ -/*****************************************************************************/ - -/* The triangle data structure. Each triangle contains three pointers to */ -/* adjoining triangles, plus three pointers to vertices, plus three */ -/* pointers to subsegments (declared below; these pointers are usually */ -/* `dummysub'). It may or may not also contain user-defined attributes */ -/* and/or a floating-point "area constraint." It may also contain extra */ -/* pointers for nodes, when the user asks for high-order elements. */ -/* Because the size and structure of a `triangle' is not decided until */ -/* runtime, I haven't simply declared the type `triangle' as a struct. */ - -typedef REAL **triangle; /* Really: typedef triangle *triangle */ - -/* An oriented triangle: includes a pointer to a triangle and orientation. */ -/* The orientation denotes an edge of the triangle. Hence, there are */ -/* three possible orientations. By convention, each edge always points */ -/* counterclockwise about the corresponding triangle. */ - -struct otri { - triangle *tri; - int orient; /* Ranges from 0 to 2. */ -}; - -/* The subsegment data structure. Each subsegment contains two pointers to */ -/* adjoining subsegments, plus four pointers to vertices, plus two */ -/* pointers to adjoining triangles, plus one boundary marker, plus one */ -/* segment number. */ - -typedef REAL **subseg; /* Really: typedef subseg *subseg */ - -/* An oriented subsegment: includes a pointer to a subsegment and an */ -/* orientation. The orientation denotes a side of the edge. Hence, there */ -/* are two possible orientations. By convention, the edge is always */ -/* directed so that the "side" denoted is the right side of the edge. */ - -struct osub { - subseg *ss; - int ssorient; /* Ranges from 0 to 1. */ -}; - -/* The vertex data structure. Each vertex is actually an array of REALs. */ -/* The number of REALs is unknown until runtime. An integer boundary */ -/* marker, and sometimes a pointer to a triangle, is appended after the */ -/* REALs. */ - -typedef REAL *vertex; - -/* A queue used to store encroached subsegments. Each subsegment's vertices */ -/* are stored so that we can check whether a subsegment is still the same. */ - -struct badsubseg { - subseg encsubseg; /* An encroached subsegment. */ - vertex subsegorg, subsegdest; /* Its two vertices. */ -}; - -/* A queue used to store bad triangles. The key is the square of the cosine */ -/* of the smallest angle of the triangle. Each triangle's vertices are */ -/* stored so that one can check whether a triangle is still the same. */ - -struct badtriang { - triangle poortri; /* A skinny or too-large triangle. */ - REAL key; /* cos^2 of smallest (apical) angle. */ - vertex triangorg, triangdest, triangapex; /* Its three vertices. */ - struct badtriang *nexttriang; /* Pointer to next bad triangle. */ -}; - -/* A stack of triangles flipped during the most recent vertex insertion. */ -/* The stack is used to undo the vertex insertion if the vertex encroaches */ -/* upon a subsegment. */ - -struct flipstacker { - triangle flippedtri; /* A recently flipped triangle. */ - struct flipstacker *prevflip; /* Previous flip in the stack. */ -}; - -/* A node in a heap used to store events for the sweepline Delaunay */ -/* algorithm. Nodes do not point directly to their parents or children in */ -/* the heap. Instead, each node knows its position in the heap, and can */ -/* look up its parent and children in a separate array. The `eventptr' */ -/* points either to a `vertex' or to a triangle (in encoded format, so */ -/* that an orientation is included). In the latter case, the origin of */ -/* the oriented triangle is the apex of a "circle event" of the sweepline */ -/* algorithm. To distinguish site events from circle events, all circle */ -/* events are given an invalid (smaller than `xmin') x-coordinate `xkey'. */ - -struct event { - REAL xkey, ykey; /* Coordinates of the event. */ - VOID *eventptr; /* Can be a vertex or the location of a circle event. */ - int heapposition; /* Marks this event's position in the heap. */ -}; - -/* A node in the splay tree. Each node holds an oriented ghost triangle */ -/* that represents a boundary edge of the growing triangulation. When a */ -/* circle event covers two boundary edges with a triangle, so that they */ -/* are no longer boundary edges, those edges are not immediately deleted */ -/* from the tree; rather, they are lazily deleted when they are next */ -/* encountered. (Since only a random sample of boundary edges are kept */ -/* in the tree, lazy deletion is faster.) `keydest' is used to verify */ -/* that a triangle is still the same as when it entered the splay tree; if */ -/* it has been rotated (due to a circle event), it no longer represents a */ -/* boundary edge and should be deleted. */ - -struct splaynode { - struct otri keyedge; /* Lprev of an edge on the front. */ - vertex keydest; /* Used to verify that splay node is still live. */ - struct splaynode *lchild, *rchild; /* Children in splay tree. */ -}; - -/* A type used to allocate memory. firstblock is the first block of items. */ -/* nowblock is the block from which items are currently being allocated. */ -/* nextitem points to the next slab of free memory for an item. */ -/* deaditemstack is the head of a linked list (stack) of deallocated items */ -/* that can be recycled. unallocateditems is the number of items that */ -/* remain to be allocated from nowblock. */ -/* */ -/* Traversal is the process of walking through the entire list of items, and */ -/* is separate from allocation. Note that a traversal will visit items on */ -/* the "deaditemstack" stack as well as live items. pathblock points to */ -/* the block currently being traversed. pathitem points to the next item */ -/* to be traversed. pathitemsleft is the number of items that remain to */ -/* be traversed in pathblock. */ -/* */ -/* alignbytes determines how new records should be aligned in memory. */ -/* itembytes is the length of a record in bytes (after rounding up). */ -/* itemsperblock is the number of items allocated at once in a single */ -/* block. itemsfirstblock is the number of items in the first block, */ -/* which can vary from the others. items is the number of currently */ -/* allocated items. maxitems is the maximum number of items that have */ -/* been allocated at once; it is the current number of items plus the */ -/* number of records kept on deaditemstack. */ - -struct memorypool { - VOID **firstblock, **nowblock; - VOID *nextitem; - VOID *deaditemstack; - VOID **pathblock; - VOID *pathitem; - int alignbytes; - int itembytes; - int itemsperblock; - int itemsfirstblock; - long items, maxitems; - int unallocateditems; - int pathitemsleft; -}; - -/* Global constants. */ - -REAL splitter; /* Used to split REAL factors for exact multiplication. */ -REAL epsilon; /* Floating-point machine epsilon. */ -REAL resulterrbound; -REAL ccwerrboundA, ccwerrboundB, ccwerrboundC; -REAL iccerrboundA, iccerrboundB, iccerrboundC; -REAL o3derrboundA, o3derrboundB, o3derrboundC; - -/* Random number seed is not constant, but I've made it global anyway. */ - -unsigned long randomseed; /* Current random number seed. */ - -/* Mesh data structure. Triangle operates on only one mesh, but the mesh */ -/* structure is used (instead of global variables) to allow reentrancy. */ - -struct mesh { - - /* Variables used to allocate memory for triangles, subsegments, vertices, */ - /* viri (triangles being eaten), encroached segments, bad (skinny or too */ - /* large) triangles, and splay tree nodes. */ - - struct memorypool triangles; - struct memorypool subsegs; - struct memorypool vertices; - struct memorypool viri; - struct memorypool badsubsegs; - struct memorypool badtriangles; - struct memorypool flipstackers; - struct memorypool splaynodes; - - /* Variables that maintain the bad triangle queues. The queues are */ - /* ordered from 4095 (highest priority) to 0 (lowest priority). */ - - struct badtriang *queuefront[4096]; - struct badtriang *queuetail[4096]; - int nextnonemptyq[4096]; - int firstnonemptyq; - - /* Variable that maintains the stack of recently flipped triangles. */ - - struct flipstacker *lastflip; - - /* Other variables. */ - - REAL xmin, xmax, ymin, ymax; /* x and y bounds. */ - REAL xminextreme; /* Nonexistent x value used as a flag in sweepline. */ - int invertices; /* Number of input vertices. */ - int inelements; /* Number of input triangles. */ - int insegments; /* Number of input segments. */ - int holes; /* Number of input holes. */ - int regions; /* Number of input regions. */ - int undeads; /* Number of input vertices that don't appear in the mesh. */ - long edges; /* Number of output edges. */ - int mesh_dim; /* Dimension (ought to be 2). */ - int nextras; /* Number of attributes per vertex. */ - int eextras; /* Number of attributes per triangle. */ - long hullsize; /* Number of edges in convex hull. */ - int steinerleft; /* Number of Steiner points not yet used. */ - int vertexmarkindex; /* Index to find boundary marker of a vertex. */ - int vertex2triindex; /* Index to find a triangle adjacent to a vertex. */ - int highorderindex; /* Index to find extra nodes for high-order elements. */ - int elemattribindex; /* Index to find attributes of a triangle. */ - int areaboundindex; /* Index to find area bound of a triangle. */ - int checksegments; /* Are there segments in the triangulation yet? */ - int checkquality; /* Has quality triangulation begun yet? */ - int readnodefile; /* Has a .node file been read? */ - long samples; /* Number of random samples for point location. */ - - long incirclecount; /* Number of incircle tests performed. */ - long counterclockcount; /* Number of counterclockwise tests performed. */ - long orient3dcount; /* Number of 3D orientation tests performed. */ - long hyperbolacount; /* Number of right-of-hyperbola tests performed. */ - long circumcentercount; /* Number of circumcenter calculations performed. */ - long circletopcount; /* Number of circle top calculations performed. */ - - /* Triangular bounding box vertices. */ - - vertex infvertex1, infvertex2, infvertex3; - - /* Pointer to the `triangle' that occupies all of "outer space." */ - - triangle *dummytri; - triangle *dummytribase; /* Keep base address so we can free() it later. */ - - /* Pointer to the omnipresent subsegment. Referenced by any triangle or */ - /* subsegment that isn't really connected to a subsegment at that */ - /* location. */ - - subseg *dummysub; - subseg *dummysubbase; /* Keep base address so we can free() it later. */ - - /* Pointer to a recently visited triangle. Improves point location if */ - /* proximate vertices are inserted sequentially. */ - - struct otri recenttri; - -}; /* End of `struct mesh'. */ - -/* Data structure for command line switches and file names. This structure */ -/* is used (instead of global variables) to allow reentrancy. */ - -struct behavior { - - /* Switches for the triangulator. */ - /* poly: -p switch. refine: -r switch. */ - /* quality: -q switch. */ - /* minangle: minimum angle bound, specified after -q switch. */ - /* goodangle: cosine squared of minangle. */ - /* offconstant: constant used to place off-center Steiner points. */ - /* vararea: -a switch without number. */ - /* fixedarea: -a switch with number. */ - /* maxarea: maximum area bound, specified after -a switch. */ - /* usertest: -u switch. */ - /* regionattrib: -A switch. convex: -c switch. */ - /* weighted: 1 for -w switch, 2 for -W switch. jettison: -j switch */ - /* firstnumber: inverse of -z switch. All items are numbered starting */ - /* from `firstnumber'. */ - /* edgesout: -e switch. voronoi: -v switch. */ - /* neighbors: -n switch. geomview: -g switch. */ - /* nobound: -B switch. nopolywritten: -P switch. */ - /* nonodewritten: -N switch. noelewritten: -E switch. */ - /* noiterationnum: -I switch. noholes: -O switch. */ - /* noexact: -X switch. */ - /* order: element order, specified after -o switch. */ - /* nobisect: count of how often -Y switch is selected. */ - /* steiner: maximum number of Steiner points, specified after -S switch. */ - /* incremental: -i switch. sweepline: -F switch. */ - /* dwyer: inverse of -l switch. */ - /* splitseg: -s switch. */ - /* conformdel: -D switch. docheck: -C switch. */ - /* quiet: -Q switch. verbose: count of how often -V switch is selected. */ - /* usesegments: -p, -r, -q, or -c switch; determines whether segments are */ - /* used at all. */ - /* */ - /* Read the instructions to find out the meaning of these switches. */ - - int poly, refine, quality, vararea, fixedarea, usertest; - int regionattrib, convex, weighted, jettison; - int firstnumber; - int edgesout, voronoi, neighbors, geomview; - int nobound, nopolywritten, nonodewritten, noelewritten, noiterationnum; - int noholes, noexact, conformdel; - int incremental, sweepline, dwyer; - int splitseg; - int docheck; - int quiet, verbose; - int usesegments; - int order; - int nobisect; - int steiner; - REAL minangle, goodangle, offconstant; - REAL maxarea; - - /* Variables for file names. */ - -#ifndef TRILIBRARY - char innodefilename[FILENAMESIZE]; - char inelefilename[FILENAMESIZE]; - char inpolyfilename[FILENAMESIZE]; - char areafilename[FILENAMESIZE]; - char outnodefilename[FILENAMESIZE]; - char outelefilename[FILENAMESIZE]; - char outpolyfilename[FILENAMESIZE]; - char edgefilename[FILENAMESIZE]; - char vnodefilename[FILENAMESIZE]; - char vedgefilename[FILENAMESIZE]; - char neighborfilename[FILENAMESIZE]; - char offfilename[FILENAMESIZE]; -#endif /* not TRILIBRARY */ - -}; /* End of `struct behavior'. */ - -/*****************************************************************************/ -/* */ -/* Mesh manipulation primitives. Each triangle contains three pointers to */ -/* other triangles, with orientations. Each pointer points not to the */ -/* first byte of a triangle, but to one of the first three bytes of a */ -/* triangle. It is necessary to extract both the triangle itself and the */ -/* orientation. To save memory, I keep both pieces of information in one */ -/* pointer. To make this possible, I assume that all triangles are aligned */ -/* to four-byte boundaries. The decode() routine below decodes a pointer, */ -/* extracting an orientation (in the range 0 to 2) and a pointer to the */ -/* beginning of a triangle. The encode() routine compresses a pointer to a */ -/* triangle and an orientation into a single pointer. My assumptions that */ -/* triangles are four-byte-aligned and that the `unsigned long' type is */ -/* long enough to hold a pointer are two of the few kludges in this program.*/ -/* */ -/* Subsegments are manipulated similarly. A pointer to a subsegment */ -/* carries both an address and an orientation in the range 0 to 1. */ -/* */ -/* The other primitives take an oriented triangle or oriented subsegment, */ -/* and return an oriented triangle or oriented subsegment or vertex; or */ -/* they change the connections in the data structure. */ -/* */ -/* Below, triangles and subsegments are denoted by their vertices. The */ -/* triangle abc has origin (org) a, destination (dest) b, and apex (apex) */ -/* c. These vertices occur in counterclockwise order about the triangle. */ -/* The handle abc may simultaneously denote vertex a, edge ab, and triangle */ -/* abc. */ -/* */ -/* Similarly, the subsegment ab has origin (sorg) a and destination (sdest) */ -/* b. If ab is thought to be directed upward (with b directly above a), */ -/* then the handle ab is thought to grasp the right side of ab, and may */ -/* simultaneously denote vertex a and edge ab. */ -/* */ -/* An asterisk (*) denotes a vertex whose identity is unknown. */ -/* */ -/* Given this notation, a partial list of mesh manipulation primitives */ -/* follows. */ -/* */ -/* */ -/* For triangles: */ -/* */ -/* sym: Find the abutting triangle; same edge. */ -/* sym(abc) -> ba* */ -/* */ -/* lnext: Find the next edge (counterclockwise) of a triangle. */ -/* lnext(abc) -> bca */ -/* */ -/* lprev: Find the previous edge (clockwise) of a triangle. */ -/* lprev(abc) -> cab */ -/* */ -/* onext: Find the next edge counterclockwise with the same origin. */ -/* onext(abc) -> ac* */ -/* */ -/* oprev: Find the next edge clockwise with the same origin. */ -/* oprev(abc) -> a*b */ -/* */ -/* dnext: Find the next edge counterclockwise with the same destination. */ -/* dnext(abc) -> *ba */ -/* */ -/* dprev: Find the next edge clockwise with the same destination. */ -/* dprev(abc) -> cb* */ -/* */ -/* rnext: Find the next edge (counterclockwise) of the adjacent triangle. */ -/* rnext(abc) -> *a* */ -/* */ -/* rprev: Find the previous edge (clockwise) of the adjacent triangle. */ -/* rprev(abc) -> b** */ -/* */ -/* org: Origin dest: Destination apex: Apex */ -/* org(abc) -> a dest(abc) -> b apex(abc) -> c */ -/* */ -/* bond: Bond two triangles together at the resepective handles. */ -/* bond(abc, bad) */ -/* */ -/* */ -/* For subsegments: */ -/* */ -/* ssym: Reverse the orientation of a subsegment. */ -/* ssym(ab) -> ba */ -/* */ -/* spivot: Find adjoining subsegment with the same origin. */ -/* spivot(ab) -> a* */ -/* */ -/* snext: Find next subsegment in sequence. */ -/* snext(ab) -> b* */ -/* */ -/* sorg: Origin sdest: Destination */ -/* sorg(ab) -> a sdest(ab) -> b */ -/* */ -/* sbond: Bond two subsegments together at the respective origins. */ -/* sbond(ab, ac) */ -/* */ -/* */ -/* For interacting tetrahedra and subfacets: */ -/* */ -/* tspivot: Find a subsegment abutting a triangle. */ -/* tspivot(abc) -> ba */ -/* */ -/* stpivot: Find a triangle abutting a subsegment. */ -/* stpivot(ab) -> ba* */ -/* */ -/* tsbond: Bond a triangle to a subsegment. */ -/* tsbond(abc, ba) */ -/* */ -/*****************************************************************************/ - -/********* Mesh manipulation primitives begin here *********/ -/** **/ -/** **/ - -/* Fast lookup arrays to speed some of the mesh manipulation primitives. */ - -int plus1mod3[3] = {1, 2, 0}; -int minus1mod3[3] = {2, 0, 1}; - -/********* Primitives for triangles *********/ -/* */ -/* */ - -/* decode() converts a pointer to an oriented triangle. The orientation is */ -/* extracted from the two least significant bits of the pointer. */ - -#define decode(ptr, otri) \ - (otri).orient = (int)((unsigned long)(ptr) & (unsigned long)3l); \ - (otri).tri = (triangle *)((unsigned long)(ptr) ^ (unsigned long)(otri).orient) - -/* encode() compresses an oriented triangle into a single pointer. It */ -/* relies on the assumption that all triangles are aligned to four-byte */ -/* boundaries, so the two least significant bits of (otri).tri are zero. */ - -#define encode(otri) \ - (triangle)((unsigned long)(otri).tri | (unsigned long)(otri).orient) - -/* The following handle manipulation primitives are all described by Guibas */ -/* and Stolfi. However, Guibas and Stolfi use an edge-based data */ -/* structure, whereas I use a triangle-based data structure. */ - -/* sym() finds the abutting triangle, on the same edge. Note that the edge */ -/* direction is necessarily reversed, because the handle specified by an */ -/* oriented triangle is directed counterclockwise around the triangle. */ - -#define sym(otri1, otri2) \ - ptr = (otri1).tri[(otri1).orient]; \ - decode(ptr, otri2); - -#define symself(otri) \ - ptr = (otri).tri[(otri).orient]; \ - decode(ptr, otri); - -/* lnext() finds the next edge (counterclockwise) of a triangle. */ - -#define lnext(otri1, otri2) \ - (otri2).tri = (otri1).tri; \ - (otri2).orient = plus1mod3[(otri1).orient] - -#define lnextself(otri) (otri).orient = plus1mod3[(otri).orient] - -/* lprev() finds the previous edge (clockwise) of a triangle. */ - -#define lprev(otri1, otri2) \ - (otri2).tri = (otri1).tri; \ - (otri2).orient = minus1mod3[(otri1).orient] - -#define lprevself(otri) (otri).orient = minus1mod3[(otri).orient] - -/* onext() spins counterclockwise around a vertex; that is, it finds the */ -/* next edge with the same origin in the counterclockwise direction. This */ -/* edge is part of a different triangle. */ - -#define onext(otri1, otri2) \ - lprev(otri1, otri2); \ - symself(otri2); - -#define onextself(otri) \ - lprevself(otri); \ - symself(otri); - -/* oprev() spins clockwise around a vertex; that is, it finds the next edge */ -/* with the same origin in the clockwise direction. This edge is part of */ -/* a different triangle. */ - -#define oprev(otri1, otri2) \ - sym(otri1, otri2); \ - lnextself(otri2); - -#define oprevself(otri) \ - symself(otri); \ - lnextself(otri); - -/* dnext() spins counterclockwise around a vertex; that is, it finds the */ -/* next edge with the same destination in the counterclockwise direction. */ -/* This edge is part of a different triangle. */ - -#define dnext(otri1, otri2) \ - sym(otri1, otri2); \ - lprevself(otri2); - -#define dnextself(otri) \ - symself(otri); \ - lprevself(otri); - -/* dprev() spins clockwise around a vertex; that is, it finds the next edge */ -/* with the same destination in the clockwise direction. This edge is */ -/* part of a different triangle. */ - -#define dprev(otri1, otri2) \ - lnext(otri1, otri2); \ - symself(otri2); - -#define dprevself(otri) \ - lnextself(otri); \ - symself(otri); - -/* rnext() moves one edge counterclockwise about the adjacent triangle. */ -/* (It's best understood by reading Guibas and Stolfi. It involves */ -/* changing triangles twice.) */ - -#define rnext(otri1, otri2) \ - sym(otri1, otri2); \ - lnextself(otri2); \ - symself(otri2); - -#define rnextself(otri) \ - symself(otri); \ - lnextself(otri); \ - symself(otri); - -/* rprev() moves one edge clockwise about the adjacent triangle. */ -/* (It's best understood by reading Guibas and Stolfi. It involves */ -/* changing triangles twice.) */ - -#define rprev(otri1, otri2) \ - sym(otri1, otri2); \ - lprevself(otri2); \ - symself(otri2); - -#define rprevself(otri) \ - symself(otri); \ - lprevself(otri); \ - symself(otri); - -/* These primitives determine or set the origin, destination, or apex of a */ -/* triangle. */ - -#define org(otri, vertexptr) \ - vertexptr = (vertex)(otri).tri[plus1mod3[(otri).orient] + 3] - -#define dest(otri, vertexptr) \ - vertexptr = (vertex)(otri).tri[minus1mod3[(otri).orient] + 3] - -#define apex(otri, vertexptr) vertexptr = (vertex)(otri).tri[(otri).orient + 3] - -#define setorg(otri, vertexptr) \ - (otri).tri[plus1mod3[(otri).orient] + 3] = (triangle)vertexptr - -#define setdest(otri, vertexptr) \ - (otri).tri[minus1mod3[(otri).orient] + 3] = (triangle)vertexptr - -#define setapex(otri, vertexptr) \ - (otri).tri[(otri).orient + 3] = (triangle)vertexptr - -/* Bond two triangles together. */ - -#define bond(otri1, otri2) \ - (otri1).tri[(otri1).orient] = encode(otri2); \ - (otri2).tri[(otri2).orient] = encode(otri1) - -/* Dissolve a bond (from one side). Note that the other triangle will still */ -/* think it's connected to this triangle. Usually, however, the other */ -/* triangle is being deleted entirely, or bonded to another triangle, so */ -/* it doesn't matter. */ - -#define dissolve(otri) (otri).tri[(otri).orient] = (triangle)m->dummytri - -/* Copy an oriented triangle. */ - -#define otricopy(otri1, otri2) \ - (otri2).tri = (otri1).tri; \ - (otri2).orient = (otri1).orient - -/* Test for equality of oriented triangles. */ - -#define otriequal(otri1, otri2) \ - (((otri1).tri == (otri2).tri) && ((otri1).orient == (otri2).orient)) - -/* Primitives to infect or cure a triangle with the virus. These rely on */ -/* the assumption that all subsegments are aligned to four-byte boundaries.*/ - -#define infect(otri) \ - (otri).tri[6] = (triangle)((unsigned long)(otri).tri[6] | (unsigned long)2l) - -#define uninfect(otri) \ - (otri).tri[6] = (triangle)((unsigned long)(otri).tri[6] & ~(unsigned long)2l) - -/* Test a triangle for viral infection. */ - -#define infected(otri) \ - (((unsigned long)(otri).tri[6] & (unsigned long)2l) != 0l) - -/* Check or set a triangle's attributes. */ - -#define elemattribute(otri, attnum) \ - ((REAL *)(otri).tri)[m->elemattribindex + (attnum)] - -#define setelemattribute(otri, attnum, value) \ - ((REAL *)(otri).tri)[m->elemattribindex + (attnum)] = value - -/* Check or set a triangle's maximum area bound. */ - -#define areabound(otri) ((REAL *)(otri).tri)[m->areaboundindex] - -#define setareabound(otri, value) \ - ((REAL *)(otri).tri)[m->areaboundindex] = value - -/* Check or set a triangle's deallocation. Its second pointer is set to */ -/* NULL to indicate that it is not allocated. (Its first pointer is used */ -/* for the stack of dead items.) Its fourth pointer (its first vertex) */ -/* is set to NULL in case a `badtriang' structure points to it. */ - -#define deadtri(tria) ((tria)[1] == (triangle)NULL) - -#define killtri(tria) \ - (tria)[1] = (triangle)NULL; \ - (tria)[3] = (triangle)NULL - -/********* Primitives for subsegments *********/ -/* */ -/* */ - -/* sdecode() converts a pointer to an oriented subsegment. The orientation */ -/* is extracted from the least significant bit of the pointer. The two */ -/* least significant bits (one for orientation, one for viral infection) */ -/* are masked out to produce the real pointer. */ - -#define sdecode(sptr, osub) \ - (osub).ssorient = (int)((unsigned long)(sptr) & (unsigned long)1l); \ - (osub).ss = (subseg *)((unsigned long)(sptr) & ~(unsigned long)3l) - -/* sencode() compresses an oriented subsegment into a single pointer. It */ -/* relies on the assumption that all subsegments are aligned to two-byte */ -/* boundaries, so the least significant bit of (osub).ss is zero. */ - -#define sencode(osub) \ - (subseg)((unsigned long)(osub).ss | (unsigned long)(osub).ssorient) - -/* ssym() toggles the orientation of a subsegment. */ - -#define ssym(osub1, osub2) \ - (osub2).ss = (osub1).ss; \ - (osub2).ssorient = 1 - (osub1).ssorient - -#define ssymself(osub) (osub).ssorient = 1 - (osub).ssorient - -/* spivot() finds the other subsegment (from the same segment) that shares */ -/* the same origin. */ - -#define spivot(osub1, osub2) \ - sptr = (osub1).ss[(osub1).ssorient]; \ - sdecode(sptr, osub2) - -#define spivotself(osub) \ - sptr = (osub).ss[(osub).ssorient]; \ - sdecode(sptr, osub) - -/* snext() finds the next subsegment (from the same segment) in sequence; */ -/* one whose origin is the input subsegment's destination. */ - -#define snext(osub1, osub2) \ - sptr = (osub1).ss[1 - (osub1).ssorient]; \ - sdecode(sptr, osub2) - -#define snextself(osub) \ - sptr = (osub).ss[1 - (osub).ssorient]; \ - sdecode(sptr, osub) - -/* These primitives determine or set the origin or destination of a */ -/* subsegment or the segment that includes it. */ - -#define sorg(osub, vertexptr) vertexptr = (vertex)(osub).ss[2 + (osub).ssorient] - -#define sdest(osub, vertexptr) \ - vertexptr = (vertex)(osub).ss[3 - (osub).ssorient] - -#define setsorg(osub, vertexptr) \ - (osub).ss[2 + (osub).ssorient] = (subseg)vertexptr - -#define setsdest(osub, vertexptr) \ - (osub).ss[3 - (osub).ssorient] = (subseg)vertexptr - -#define segorg(osub, vertexptr) \ - vertexptr = (vertex)(osub).ss[4 + (osub).ssorient] - -#define segdest(osub, vertexptr) \ - vertexptr = (vertex)(osub).ss[5 - (osub).ssorient] - -#define setsegorg(osub, vertexptr) \ - (osub).ss[4 + (osub).ssorient] = (subseg)vertexptr - -#define setsegdest(osub, vertexptr) \ - (osub).ss[5 - (osub).ssorient] = (subseg)vertexptr - -/* These primitives read or set a boundary marker. Boundary markers are */ -/* used to hold user-defined tags for setting boundary conditions in */ -/* finite element solvers. */ - -#define mark(osub) (*(int *)((osub).ss + 8)) - -#define setmark(osub, value) *(int *)((osub).ss + 8) = value - -/* Bond two subsegments together. */ - -#define sbond(osub1, osub2) \ - (osub1).ss[(osub1).ssorient] = sencode(osub2); \ - (osub2).ss[(osub2).ssorient] = sencode(osub1) - -/* Dissolve a subsegment bond (from one side). Note that the other */ -/* subsegment will still think it's connected to this subsegment. */ - -#define sdissolve(osub) (osub).ss[(osub).ssorient] = (subseg)m->dummysub - -/* Copy a subsegment. */ - -#define subsegcopy(osub1, osub2) \ - (osub2).ss = (osub1).ss; \ - (osub2).ssorient = (osub1).ssorient - -/* Test for equality of subsegments. */ - -#define subsegequal(osub1, osub2) \ - (((osub1).ss == (osub2).ss) && ((osub1).ssorient == (osub2).ssorient)) - -/* Check or set a subsegment's deallocation. Its second pointer is set to */ -/* NULL to indicate that it is not allocated. (Its first pointer is used */ -/* for the stack of dead items.) Its third pointer (its first vertex) */ -/* is set to NULL in case a `badsubseg' structure points to it. */ - -#define deadsubseg(sub) ((sub)[1] == (subseg)NULL) - -#define killsubseg(sub) \ - (sub)[1] = (subseg)NULL; \ - (sub)[2] = (subseg)NULL - -/********* Primitives for interacting triangles and subsegments *********/ -/* */ -/* */ - -/* tspivot() finds a subsegment abutting a triangle. */ - -#define tspivot(otri, osub) \ - sptr = (subseg)(otri).tri[6 + (otri).orient]; \ - sdecode(sptr, osub) - -/* stpivot() finds a triangle abutting a subsegment. It requires that the */ -/* variable `ptr' of type `triangle' be defined. */ - -#define stpivot(osub, otri) \ - ptr = (triangle)(osub).ss[6 + (osub).ssorient]; \ - decode(ptr, otri) - -/* Bond a triangle to a subsegment. */ - -#define tsbond(otri, osub) \ - (otri).tri[6 + (otri).orient] = (triangle)sencode(osub); \ - (osub).ss[6 + (osub).ssorient] = (subseg)encode(otri) - -/* Dissolve a bond (from the triangle side). */ - -#define tsdissolve(otri) (otri).tri[6 + (otri).orient] = (triangle)m->dummysub - -/* Dissolve a bond (from the subsegment side). */ - -#define stdissolve(osub) (osub).ss[6 + (osub).ssorient] = (subseg)m->dummytri - -/********* Primitives for vertices *********/ -/* */ -/* */ - -#define vertexmark(vx) ((int *)(vx))[m->vertexmarkindex] - -#define setvertexmark(vx, value) ((int *)(vx))[m->vertexmarkindex] = value - -#define vertextype(vx) ((int *)(vx))[m->vertexmarkindex + 1] - -#define setvertextype(vx, value) ((int *)(vx))[m->vertexmarkindex + 1] = value - -#define vertex2tri(vx) ((triangle *)(vx))[m->vertex2triindex] - -#define setvertex2tri(vx, value) ((triangle *)(vx))[m->vertex2triindex] = value - -/** **/ -/** **/ -/********* Mesh manipulation primitives end here *********/ - -/********* User-defined triangle evaluation routine begins here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* triunsuitable() Determine if a triangle is unsuitable, and thus must */ -/* be further refined. */ -/* */ -/* You may write your own procedure that decides whether or not a selected */ -/* triangle is too big (and needs to be refined). There are two ways to do */ -/* this. */ -/* */ -/* (1) Modify the procedure `triunsuitable' below, then recompile */ -/* Triangle. */ -/* */ -/* (2) Define the symbol EXTERNAL_TEST (either by adding the definition */ -/* to this file, or by using the appropriate compiler switch). This way, */ -/* you can compile triangle.c separately from your test. Write your own */ -/* `triunsuitable' procedure in a separate C file (using the same prototype */ -/* as below). Compile it and link the object code with triangle.o. */ -/* */ -/* This procedure returns 1 if the triangle is too large and should be */ -/* refined; 0 otherwise. */ -/* */ -/*****************************************************************************/ - -#ifdef EXTERNAL_TEST - -int triunsuitable(); - -#else /* not EXTERNAL_TEST */ - -#ifdef ANSI_DECLARATORS -int triunsuitable(vertex triorg, vertex tridest, vertex triapex, REAL area) -#else /* not ANSI_DECLARATORS */ -int triunsuitable(triorg, tridest, triapex, area) -vertex triorg; /* The triangle's origin vertex. */ -vertex tridest; /* The triangle's destination vertex. */ -vertex triapex; /* The triangle's apex vertex. */ -REAL area; /* The area of the triangle. */ -#endif /* not ANSI_DECLARATORS */ - -{ - REAL dxoa, dxda, dxod; - REAL dyoa, dyda, dyod; - REAL oalen, dalen, odlen; - REAL maxlen; - - dxoa = triorg[0] - triapex[0]; - dyoa = triorg[1] - triapex[1]; - dxda = tridest[0] - triapex[0]; - dyda = tridest[1] - triapex[1]; - dxod = triorg[0] - tridest[0]; - dyod = triorg[1] - tridest[1]; - /* Find the squares of the lengths of the triangle's three edges. */ - oalen = dxoa * dxoa + dyoa * dyoa; - dalen = dxda * dxda + dyda * dyda; - odlen = dxod * dxod + dyod * dyod; - /* Find the square of the length of the longest edge. */ - maxlen = (dalen > oalen) ? dalen : oalen; - maxlen = (odlen > maxlen) ? odlen : maxlen; - - if (maxlen > 0.05 * (triorg[0] * triorg[0] + triorg[1] * triorg[1]) + 0.02) { - return 1; - } else { - return 0; - } -} - -#endif /* not EXTERNAL_TEST */ - -/** **/ -/** **/ -/********* User-defined triangle evaluation routine ends here *********/ - -/********* Memory allocation and program exit wrappers begin here *********/ -/** **/ -/** **/ - -#ifdef ANSI_DECLARATORS -void triexit(int status) -#else /* not ANSI_DECLARATORS */ -void triexit(status) int status; -#endif /* not ANSI_DECLARATORS */ - -{ - exit(status); -} - -#ifdef ANSI_DECLARATORS -VOID *trimalloc(int size) -#else /* not ANSI_DECLARATORS */ -VOID *trimalloc(size) -int size; -#endif /* not ANSI_DECLARATORS */ - -{ - VOID *memptr; - - memptr = (VOID *)malloc((unsigned int)size); - if (memptr == (VOID *)NULL) { - printf("Error: Out of memory.\n"); - triexit(1); - } - return (memptr); -} - -#ifdef ANSI_DECLARATORS -void trifree(VOID *memptr) -#else /* not ANSI_DECLARATORS */ -void trifree(memptr) VOID *memptr; -#endif /* not ANSI_DECLARATORS */ - -{ - free(memptr); -} - -/** **/ -/** **/ -/********* Memory allocation and program exit wrappers end here *********/ - -/********* User interaction routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* syntax() Print list of command line switches. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -void syntax() { -#ifdef CDT_ONLY -#ifdef REDUCED - printf("triangle [-pAcjevngBPNEIOXzo_lQVh] input_file\n"); -#else /* not REDUCED */ - printf("triangle [-pAcjevngBPNEIOXzo_iFlCQVh] input_file\n"); -#endif /* not REDUCED */ -#else /* not CDT_ONLY */ -#ifdef REDUCED - printf("triangle [-prq__a__uAcDjevngBPNEIOXzo_YS__lQVh] input_file\n"); -#else /* not REDUCED */ - printf("triangle [-prq__a__uAcDjevngBPNEIOXzo_YS__iFlsCQVh] input_file\n"); -#endif /* not REDUCED */ -#endif /* not CDT_ONLY */ - - printf(" -p Triangulates a Planar Straight Line Graph (.poly file).\n"); -#ifndef CDT_ONLY - printf(" -r Refines a previously generated mesh.\n"); - printf( - " -q Quality mesh generation. A minimum angle may be specified.\n"); - printf(" -a Applies a maximum triangle area constraint.\n"); - printf(" -u Applies a user-defined triangle constraint.\n"); -#endif /* not CDT_ONLY */ - printf( - " -A Applies attributes to identify triangles in certain regions.\n"); - printf(" -c Encloses the convex hull with segments.\n"); -#ifndef CDT_ONLY - printf(" -D Conforming Delaunay: all triangles are truly Delaunay.\n"); -#endif /* not CDT_ONLY */ - /* - printf(" -w Weighted Delaunay triangulation.\n"); - printf(" -W Regular triangulation (lower hull of a height field).\n"); - */ - printf(" -j Jettison unused vertices from output .node file.\n"); - printf(" -e Generates an edge list.\n"); - printf(" -v Generates a Voronoi diagram.\n"); - printf(" -n Generates a list of triangle neighbors.\n"); - printf(" -g Generates an .off file for Geomview.\n"); - printf(" -B Suppresses output of boundary information.\n"); - printf(" -P Suppresses output of .poly file.\n"); - printf(" -N Suppresses output of .node file.\n"); - printf(" -E Suppresses output of .ele file.\n"); - printf(" -I Suppresses mesh iteration numbers.\n"); - printf(" -O Ignores holes in .poly file.\n"); - printf(" -X Suppresses use of exact arithmetic.\n"); - printf(" -z Numbers all items starting from zero (rather than one).\n"); - printf(" -o2 Generates second-order subparametric elements.\n"); -#ifndef CDT_ONLY - printf(" -Y Suppresses boundary segment splitting.\n"); - printf(" -S Specifies maximum number of added Steiner points.\n"); -#endif /* not CDT_ONLY */ -#ifndef REDUCED - printf(" -i Uses incremental method, rather than divide-and-conquer.\n"); - printf(" -F Uses Fortune's sweepline algorithm, rather than d-and-c.\n"); -#endif /* not REDUCED */ - printf(" -l Uses vertical cuts only, rather than alternating cuts.\n"); -#ifndef REDUCED -#ifndef CDT_ONLY - printf(" -s Force segments into mesh by splitting (instead of using " - "CDT).\n"); -#endif /* not CDT_ONLY */ - printf(" -C Check consistency of final mesh.\n"); -#endif /* not REDUCED */ - printf(" -Q Quiet: No terminal output except errors.\n"); - printf(" -V Verbose: Detailed information on what I'm doing.\n"); - printf(" -h Help: Detailed instructions for Triangle.\n"); - triexit(0); -} - -#endif /* not TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* info() Print out complete instructions. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -void info() { - printf("Triangle\n"); - printf( - "A Two-Dimensional Quality Mesh Generator and Delaunay Triangulator.\n"); - printf("Version 1.6\n\n"); - printf("Copyright 1993, 1995, 1997, 1998, 2002, 2005 Jonathan Richard " - "Shewchuk\n"); - printf("2360 Woolsey #H / Berkeley, California 94705-1927\n"); - printf("Bugs/comments to jrs@cs.berkeley.edu\n"); - printf("Created as part of the Quake project (tools for earthquake " - "simulation).\n"); - printf("Supported in part by NSF Grant CMS-9318163 and an NSERC 1967 " - "Scholarship.\n"); - printf("There is no warranty whatsoever. Use at your own risk.\n"); -#ifdef SINGLE - printf("This executable is compiled for single precision arithmetic.\n\n\n"); -#else /* not SINGLE */ - printf("This executable is compiled for double precision arithmetic.\n\n\n"); -#endif /* not SINGLE */ - printf("Triangle generates exact Delaunay triangulations, constrained " - "Delaunay\n"); - printf("triangulations, conforming Delaunay triangulations, Voronoi " - "diagrams, and\n"); - printf("high-quality triangular meshes. The latter can be generated with no " - "small\n"); - printf("or large angles, and are thus suitable for finite element analysis. " - "If no\n"); - printf("command line switch is specified, your .node input file is read, and " - "the\n"); - printf("Delaunay triangulation is returned in .node and .ele output files. " - "The\n"); - printf("command syntax is:\n\n"); - printf("triangle [-prq__a__uAcDjevngBPNEIOXzo_YS__iFlsCQVh] input_file\n\n"); - printf("Underscores indicate that numbers may optionally follow certain " - "switches.\n"); - printf( - "Do not leave any space between a switch and its numeric parameter.\n"); - printf("input_file must be a file with extension .node, or extension .poly " - "if the\n"); - printf("-p switch is used. If -r is used, you must supply .node and .ele " - "files,\n"); - printf("and possibly a .poly file and an .area file as well. The formats of " - "these\n"); - printf("files are described below.\n\n"); - printf("Command Line Switches:\n\n"); - printf(" -p Reads a Planar Straight Line Graph (.poly file), which can " - "specify\n"); - printf(" vertices, segments, holes, regional attributes, and regional " - "area\n"); - printf(" constraints. Generates a constrained Delaunay triangulation " - "(CDT)\n"); - printf(" fitting the input; or, if -s, -q, -a, or -u is used, a " - "conforming\n"); - printf(" constrained Delaunay triangulation (CCDT). If you want a " - "truly\n"); - printf(" Delaunay (not just constrained Delaunay) triangulation, use " - "-D as\n"); - printf(" well. When -p is not used, Triangle reads a .node file by " - "default.\n"); - printf(" -r Refines a previously generated mesh. The mesh is read from " - "a .node\n"); - printf(" file and an .ele file. If -p is also used, a .poly file is " - "read\n"); - printf(" and used to constrain segments in the mesh. If -a is also " - "used\n"); - printf(" (with no number following), an .area file is read and used " - "to\n"); - printf(" impose area constraints on the mesh. Further details on " - "refinement\n"); - printf(" appear below.\n"); - printf(" -q Quality mesh generation by Delaunay refinement (a hybrid of " - "Paul\n"); - printf(" Chew's and Jim Ruppert's algorithms). Adds vertices to the " - "mesh to\n"); - printf( - " ensure that all angles are between 20 and 140 degrees. An\n"); - printf(" alternative bound on the minimum angle, replacing 20 " - "degrees, may\n"); - printf(" be specified after the `q'. The specified angle may include " - "a\n"); - printf(" decimal point, but not exponential notation. Note that a " - "bound of\n"); - printf( - " theta degrees on the smallest angle also implies a bound of\n"); - printf(" (180 - 2 theta) on the largest angle. If the minimum angle " - "is 28.6\n"); - printf( - " degrees or smaller, Triangle is mathematically guaranteed to\n"); - printf(" terminate (assuming infinite precision arithmetic--Triangle " - "may\n"); - printf(" fail to terminate if you run out of precision). In " - "practice,\n"); - printf(" Triangle often succeeds for minimum angles up to 34 degrees. " - " For\n"); - printf(" some meshes, however, you might need to reduce the minimum " - "angle to\n"); - printf( - " avoid problems associated with insufficient floating-point\n"); - printf(" precision.\n"); - printf(" -a Imposes a maximum triangle area. If a number follows the " - "`a', no\n"); - printf(" triangle is generated whose area is larger than that number. " - " If no\n"); - printf(" number is specified, an .area file (if -r is used) or .poly " - "file\n"); - printf(" (if -r is not used) specifies a set of maximum area " - "constraints.\n"); - printf( - " An .area file contains a separate area constraint for each\n"); - printf(" triangle, and is useful for refining a finite element mesh " - "based on\n"); - printf(" a posteriori error estimates. A .poly file can optionally " - "contain\n"); - printf( - " an area constraint for each segment-bounded region, thereby\n"); - printf(" controlling triangle densities in a first triangulation of a " - "PSLG.\n"); - printf(" You can impose both a fixed area constraint and a varying " - "area\n"); - printf(" constraint by invoking the -a switch twice, once with and " - "once\n"); - printf(" without a number following. Each area specified may include " - "a\n"); - printf(" decimal point.\n"); - printf(" -u Imposes a user-defined constraint on triangle size. There " - "are two\n"); - printf(" ways to use this feature. One is to edit the " - "triunsuitable()\n"); - printf(" procedure in triangle.c to encode any constraint you like, " - "then\n"); - printf(" recompile Triangle. The other is to compile triangle.c with " - "the\n"); - printf(" EXTERNAL_TEST symbol set (compiler switch -DEXTERNAL_TEST), " - "then\n"); - printf(" link Triangle with a separate object file that implements\n"); - printf(" triunsuitable(). In either case, the -u switch causes the " - "user-\n"); - printf(" defined test to be applied to every triangle.\n"); - printf(" -A Assigns an additional floating-point attribute to each " - "triangle\n"); - printf(" that identifies what segment-bounded region each triangle " - "belongs\n"); - printf(" to. Attributes are assigned to regions by the .poly file. " - "If a\n"); - printf(" region is not explicitly marked by the .poly file, triangles " - "in\n"); - printf(" that region are assigned an attribute of zero. The -A " - "switch has\n"); - printf(" an effect only when the -p switch is used and the -r switch " - "is not.\n"); - printf(" -c Creates segments on the convex hull of the triangulation. " - "If you\n"); - printf(" are triangulating a vertex set, this switch causes a .poly " - "file to\n"); - printf(" be written, containing all edges of the convex hull. If you " - "are\n"); - printf(" triangulating a PSLG, this switch specifies that the whole " - "convex\n"); - printf( - " hull of the PSLG should be triangulated, regardless of what\n"); - printf( - " segments the PSLG has. If you do not use this switch when\n"); - printf(" triangulating a PSLG, Triangle assumes that you have " - "identified the\n"); - printf(" region to be triangulated by surrounding it with segments of " - "the\n"); - printf(" input PSLG. Beware: if you are not careful, this switch " - "can cause\n"); - printf(" the introduction of an extremely thin angle between a PSLG " - "segment\n"); - printf(" and a convex hull segment, which can cause overrefinement " - "(and\n"); - printf(" possibly failure if Triangle runs out of precision). If you " - "are\n"); - printf(" refining a mesh, the -c switch works differently: it causes " - "a\n"); - printf(" .poly file to be written containing the boundary edges of " - "the mesh\n"); - printf(" (useful if no .poly file was read).\n"); - printf(" -D Conforming Delaunay triangulation: use this switch if you " - "want to\n"); - printf(" ensure that all the triangles in the mesh are Delaunay, and " - "not\n"); - printf(" merely constrained Delaunay; or if you want to ensure that " - "all the\n"); - printf(" Voronoi vertices lie within the triangulation. (Some finite " - "volume\n"); - printf(" methods have this requirement.) This switch invokes " - "Ruppert's\n"); - printf(" original algorithm, which splits every subsegment whose " - "diametral\n"); - printf(" circle is encroached. It usually increases the number of " - "vertices\n"); - printf(" and triangles.\n"); - printf(" -j Jettisons vertices that are not part of the final " - "triangulation\n"); - printf( - " from the output .node file. By default, Triangle copies all\n"); - printf(" vertices in the input .node file to the output .node file, " - "in the\n"); - printf(" same order, so their indices do not change. The -j switch " - "prevents\n"); - printf(" duplicated input vertices, or vertices `eaten' by holes, " - "from\n"); - printf(" appearing in the output .node file. Thus, if two input " - "vertices\n"); - printf(" have exactly the same coordinates, only the first appears in " - "the\n"); - printf(" output. If any vertices are jettisoned, the vertex " - "numbering in\n"); - printf(" the output .node file differs from that of the input .node " - "file.\n"); - printf(" -e Outputs (to an .edge file) a list of edges of the " - "triangulation.\n"); - printf(" -v Outputs the Voronoi diagram associated with the " - "triangulation.\n"); - printf(" Does not attempt to detect degeneracies, so some Voronoi " - "vertices\n"); - printf(" may be duplicated. See the discussion of Voronoi diagrams " - "below.\n"); - printf(" -n Outputs (to a .neigh file) a list of triangles neighboring " - "each\n"); - printf(" triangle.\n"); - printf(" -g Outputs the mesh to an Object File Format (.off) file, " - "suitable for\n"); - printf(" viewing with the Geometry Center's Geomview package.\n"); - printf(" -B No boundary markers in the output .node, .poly, and .edge " - "output\n"); - printf(" files. See the detailed discussion of boundary markers " - "below.\n"); - printf(" -P No output .poly file. Saves disk space, but you lose the " - "ability\n"); - printf(" to maintain constraining segments on later refinements of " - "the mesh.\n"); - printf(" -N No output .node file.\n"); - printf(" -E No output .ele file.\n"); - printf(" -I No iteration numbers. Suppresses the output of .node and " - ".poly\n"); - printf(" files, so your input files won't be overwritten. (If your " - "input is\n"); - printf(" a .poly file only, a .node file is written.) Cannot be used " - "with\n"); - printf(" the -r switch, because that would overwrite your input .ele " - "file.\n"); - printf(" Shouldn't be used with the -q, -a, -u, or -s switch if you " - "are\n"); - printf(" using a .node file for input, because no .node file is " - "written, so\n"); - printf(" there is no record of any added Steiner points.\n"); - printf(" -O No holes. Ignores the holes in the .poly file.\n"); - printf(" -X No exact arithmetic. Normally, Triangle uses exact " - "floating-point\n"); - printf(" arithmetic for certain tests if it thinks the inexact tests " - "are not\n"); - printf(" accurate enough. Exact arithmetic ensures the robustness of " - "the\n"); - printf(" triangulation algorithms, despite floating-point roundoff " - "error.\n"); - printf( - " Disabling exact arithmetic with the -X switch causes a small\n"); - printf(" improvement in speed and creates the possibility that " - "Triangle will\n"); - printf(" fail to produce a valid mesh. Not recommended.\n"); - printf(" -z Numbers all items starting from zero (rather than one). " - "Note that\n"); - printf(" this switch is normally overridden by the value used to " - "number the\n"); - printf(" first vertex of the input .node or .poly file. However, " - "this\n"); - printf( - " switch is useful when calling Triangle from another program.\n"); - printf(" -o2 Generates second-order subparametric elements with six nodes " - "each.\n"); - printf(" -Y No new vertices on the boundary. This switch is useful when " - "the\n"); - printf( - " mesh boundary must be preserved so that it conforms to some\n"); - printf(" adjacent mesh. Be forewarned that you will probably " - "sacrifice much\n"); - printf(" of the quality of the mesh; Triangle will try, but the " - "resulting\n"); - printf(" mesh may contain poorly shaped triangles. Works well if all " - "the\n"); - printf(" boundary vertices are closely spaced. Specify this switch " - "twice\n"); - printf( - " (`-YY') to prevent all segment splitting, including internal\n"); - printf(" boundaries.\n"); - printf(" -S Specifies the maximum number of Steiner points (vertices " - "that are\n"); - printf(" not in the input, but are added to meet the constraints on " - "minimum\n"); - printf(" angle and maximum area). The default is to allow an " - "unlimited\n"); - printf( - " number. If you specify this switch with no number after it,\n"); - printf(" the limit is set to zero. Triangle always adds vertices at " - "segment\n"); - printf(" intersections, even if it needs to use more vertices than " - "the limit\n"); - printf(" you set. When Triangle inserts segments by splitting (-s), " - "it\n"); - printf(" always adds enough vertices to ensure that all the segments " - "of the\n"); - printf(" PLSG are recovered, ignoring the limit if necessary.\n"); - printf(" -i Uses an incremental rather than a divide-and-conquer " - "algorithm to\n"); - printf(" construct a Delaunay triangulation. Try it if the " - "divide-and-\n"); - printf(" conquer algorithm fails.\n"); - printf(" -F Uses Steven Fortune's sweepline algorithm to construct a " - "Delaunay\n"); - printf(" triangulation. Warning: does not use exact arithmetic for " - "all\n"); - printf(" calculations. An exact result is not guaranteed.\n"); - printf(" -l Uses only vertical cuts in the divide-and-conquer algorithm. " - " By\n"); - printf(" default, Triangle alternates between vertical and horizontal " - "cuts,\n"); - printf(" which usually improve the speed except with vertex sets that " - "are\n"); - printf(" small or short and wide. This switch is primarily of " - "theoretical\n"); - printf(" interest.\n"); - printf(" -s Specifies that segments should be forced into the " - "triangulation by\n"); - printf(" recursively splitting them at their midpoints, rather than " - "by\n"); - printf(" generating a constrained Delaunay triangulation. Segment " - "splitting\n"); - printf(" is true to Ruppert's original algorithm, but can create " - "needlessly\n"); - printf(" small triangles. This switch is primarily of theoretical " - "interest.\n"); - printf(" -C Check the consistency of the final mesh. Uses exact " - "arithmetic for\n"); - printf(" checking, even if the -X switch is used. Useful if you " - "suspect\n"); - printf(" Triangle is buggy.\n"); - printf(" -Q Quiet: Suppresses all explanation of what Triangle is " - "doing,\n"); - printf(" unless an error occurs.\n"); - printf(" -V Verbose: Gives detailed information about what Triangle is " - "doing.\n"); - printf( - " Add more `V's for increasing amount of detail. `-V' is most\n"); - printf(" useful; itgives information on algorithmic progress and much " - "more\n"); - printf(" detailed statistics. `-VV' gives vertex-by-vertex details, " - "and\n"); - printf(" prints so much that Triangle runs much more slowly. `-VVVV' " - "gives\n"); - printf(" information only a debugger could love.\n"); - printf(" -h Help: Displays these instructions.\n"); - printf("\n"); - printf("Definitions:\n"); - printf("\n"); - printf( - " A Delaunay triangulation of a vertex set is a triangulation whose\n"); - printf(" vertices are the vertex set, that covers the convex hull of the " - "vertex\n"); - printf(" set. A Delaunay triangulation has the property that no vertex " - "lies\n"); - printf(" inside the circumscribing circle (circle that passes through all " - "three\n"); - printf(" vertices) of any triangle in the triangulation.\n\n"); - printf(" A Voronoi diagram of a vertex set is a subdivision of the plane " - "into\n"); - printf(" polygonal cells (some of which may be unbounded, meaning " - "infinitely\n"); - printf(" large), where each cell is the set of points in the plane that are " - "closer\n"); - printf(" to some input vertex than to any other input vertex. The Voronoi " - "diagram\n"); - printf(" is a geometric dual of the Delaunay triangulation.\n\n"); - printf(" A Planar Straight Line Graph (PSLG) is a set of vertices and " - "segments.\n"); - printf(" Segments are simply edges, whose endpoints are all vertices in the " - "PSLG.\n"); - printf(" Segments may intersect each other only at their endpoints. The " - "file\n"); - printf(" format for PSLGs (.poly files) is described below.\n\n"); - printf(" A constrained Delaunay triangulation (CDT) of a PSLG is similar to " - "a\n"); - printf(" Delaunay triangulation, but each PSLG segment is present as a " - "single edge\n"); - printf( - " of the CDT. (A constrained Delaunay triangulation is not truly a\n"); - printf( - " Delaunay triangulation, because some of its triangles might not be\n"); - printf(" Delaunay.) By definition, a CDT does not have any vertices other " - "than\n"); - printf(" those specified in the input PSLG. Depending on context, a CDT " - "might\n"); - printf(" cover the convex hull of the PSLG, or it might cover only a " - "segment-\n"); - printf(" bounded region (e.g. a polygon).\n\n"); - printf(" A conforming Delaunay triangulation of a PSLG is a triangulation " - "in which\n"); - printf(" each triangle is truly Delaunay, and each PSLG segment is " - "represented by\n"); - printf(" a linear contiguous sequence of edges of the triangulation. New " - "vertices\n"); - printf(" (not part of the PSLG) may appear, and each input segment may have " - "been\n"); - printf(" subdivided into shorter edges (subsegments) by these additional " - "vertices.\n"); - printf( - " The new vertices are frequently necessary to maintain the Delaunay\n"); - printf(" property while ensuring that every segment is represented.\n\n"); - printf(" A conforming constrained Delaunay triangulation (CCDT) of a PSLG " - "is a\n"); - printf(" triangulation of a PSLG whose triangles are constrained Delaunay. " - "New\n"); - printf(" vertices may appear, and input segments may be subdivided into\n"); - printf(" subsegments, but not to guarantee that segments are respected; " - "rather, to\n"); - printf(" improve the quality of the triangles. The high-quality meshes " - "produced\n"); - printf(" by the -q switch are usually CCDTs, but can be made conforming " - "Delaunay\n"); - printf(" with the -D switch.\n\n"); - printf("File Formats:\n\n"); - printf(" All files may contain comments prefixed by the character '#'. " - "Vertices,\n"); - printf(" triangles, edges, holes, and maximum area constraints must be " - "numbered\n"); - printf(" consecutively, starting from either 1 or 0. Whichever you choose, " - "all\n"); - printf(" input files must be consistent; if the vertices are numbered from " - "1, so\n"); - printf(" must be all other objects. Triangle automatically detects your " - "choice\n"); - printf(" while reading the .node (or .poly) file. (When calling Triangle " - "from\n"); - printf(" another program, use the -z switch if you wish to number objects " - "from\n"); - printf(" zero.) Examples of these file formats are given below.\n\n"); - printf(" .node files:\n"); - printf(" First line: <# of vertices> <# of " - "attributes>\n"); - printf(" <# of boundary markers (0 " - "or 1)>\n"); - printf(" Remaining lines: [attributes] [boundary " - "marker]\n"); - printf("\n"); - printf(" The attributes, which are typically floating-point values of " - "physical\n"); - printf(" quantities (such as mass or conductivity) associated with the " - "nodes of\n"); - printf(" a finite element mesh, are copied unchanged to the output mesh. " - "If -q,\n"); - printf(" -a, -u, -D, or -s is selected, each new Steiner point added to " - "the mesh\n"); - printf(" has attributes assigned to it by linear interpolation.\n\n"); - printf(" If the fourth entry of the first line is `1', the last column of " - "the\n"); - printf(" remainder of the file is assumed to contain boundary markers. " - "Boundary\n"); - printf(" markers are used to identify boundary vertices and vertices " - "resting on\n"); - printf(" PSLG segments; a complete description appears in a section " - "below. The\n"); - printf(" .node file produced by Triangle contains boundary markers in the " - "last\n"); - printf(" column unless they are suppressed by the -B switch.\n\n"); - printf(" .ele files:\n"); - printf(" First line: <# of triangles> <# of " - "attributes>\n"); - printf(" Remaining lines: ... " - "[attributes]\n"); - printf("\n"); - printf(" Nodes are indices into the corresponding .node file. The first " - "three\n"); - printf(" nodes are the corner vertices, and are listed in " - "counterclockwise order\n"); - printf(" around each triangle. (The remaining nodes, if any, depend on " - "the type\n"); - printf(" of finite element used.)\n\n"); - printf(" The attributes are just like those of .node files. Because " - "there is no\n"); - printf(" simple mapping from input to output triangles, Triangle attempts " - "to\n"); - printf(" interpolate attributes, and may cause a lot of diffusion of " - "attributes\n"); - printf(" among nearby triangles as the triangulation is refined. " - "Attributes do\n"); - printf(" not diffuse across segments, so attributes used to identify\n"); - printf(" segment-bounded regions remain intact.\n\n"); - printf(" In .ele files produced by Triangle, each triangular element has " - "three\n"); - printf(" nodes (vertices) unless the -o2 switch is used, in which case\n"); - printf(" subparametric quadratic elements with six nodes each are " - "generated.\n"); - printf(" The first three nodes are the corners in counterclockwise order, " - "and\n"); - printf(" the fourth, fifth, and sixth nodes lie on the midpoints of the " - "edges\n"); - printf(" opposite the first, second, and third vertices, respectively.\n"); - printf("\n"); - printf(" .poly files:\n"); - printf(" First line: <# of vertices> <# of " - "attributes>\n"); - printf(" <# of boundary markers (0 " - "or 1)>\n"); - printf(" Following lines: [attributes] [boundary " - "marker]\n"); - printf(" One line: <# of segments> <# of boundary markers (0 or 1)>\n"); - printf(" Following lines: [boundary " - "marker]\n"); - printf(" One line: <# of holes>\n"); - printf(" Following lines: \n"); - printf(" Optional line: <# of regional attributes and/or area " - "constraints>\n"); - printf(" Optional following lines: \n"); - printf("\n"); - printf(" A .poly file represents a PSLG, as well as some additional " - "information.\n"); - printf(" The first section lists all the vertices, and is identical to " - "the\n"); - printf(" format of .node files. <# of vertices> may be set to zero to " - "indicate\n"); - printf(" that the vertices are listed in a separate .node file; .poly " - "files\n"); - printf(" produced by Triangle always have this format. A vertex set " - "represented\n"); - printf(" this way has the advantage that it may easily be triangulated " - "with or\n"); - printf(" without segments (depending on whether the -p switch is " - "invoked).\n"); - printf("\n"); - printf( - " The second section lists the segments. Segments are edges whose\n"); - printf(" presence in the triangulation is enforced. (Depending on the " - "choice of\n"); - printf( - " switches, segment might be subdivided into smaller edges). Each\n"); - printf(" segment is specified by listing the indices of its two " - "endpoints. This\n"); - printf(" means that you must include its endpoints in the vertex list. " - "Each\n"); - printf(" segment, like each point, may have a boundary marker.\n\n"); - printf(" If -q, -a, -u, and -s are not selected, Triangle produces a " - "constrained\n"); - printf(" Delaunay triangulation (CDT), in which each segment appears as a " - "single\n"); - printf(" edge in the triangulation. If -q, -a, -u, or -s is selected, " - "Triangle\n"); - printf(" produces a conforming constrained Delaunay triangulation (CCDT), " - "in\n"); - printf( - " which segments may be subdivided into smaller edges. If -D is\n"); - printf(" selected, Triangle produces a conforming Delaunay triangulation, " - "so\n"); - printf(" that every triangle is Delaunay, and not just constrained " - "Delaunay.\n"); - printf("\n"); - printf(" The third section lists holes (and concavities, if -c is " - "selected) in\n"); - printf(" the triangulation. Holes are specified by identifying a point " - "inside\n"); - printf(" each hole. After the triangulation is formed, Triangle creates " - "holes\n"); - printf(" by eating triangles, spreading out from each hole point until " - "its\n"); - printf(" progress is blocked by segments in the PSLG. You must be " - "careful to\n"); - printf(" enclose each hole in segments, or your whole triangulation might " - "be\n"); - printf(" eaten away. If the two triangles abutting a segment are eaten, " - "the\n"); - printf( - " segment itself is also eaten. Do not place a hole directly on a\n"); - printf(" segment; if you do, Triangle chooses one side of the segment\n"); - printf(" arbitrarily.\n\n"); - printf(" The optional fourth section lists regional attributes (to be " - "assigned\n"); - printf(" to all triangles in a region) and regional constraints on the " - "maximum\n"); - printf(" triangle area. Triangle reads this section only if the -A " - "switch is\n"); - printf(" used or the -a switch is used without a number following it, and " - "the -r\n"); - printf(" switch is not used. Regional attributes and area constraints " - "are\n"); - printf(" propagated in the same manner as holes: you specify a point for " - "each\n"); - printf( - " attribute and/or constraint, and the attribute and/or constraint\n"); - printf(" affects the whole region (bounded by segments) containing the " - "point.\n"); - printf(" If two values are written on a line after the x and y " - "coordinate, the\n"); - printf(" first such value is assumed to be a regional attribute (but is " - "only\n"); - printf(" applied if the -A switch is selected), and the second value is " - "assumed\n"); - printf(" to be a regional area constraint (but is only applied if the -a " - "switch\n"); - printf(" is selected). You may specify just one value after the " - "coordinates,\n"); - printf(" which can serve as both an attribute and an area constraint, " - "depending\n"); - printf(" on the choice of switches. If you are using the -A and -a " - "switches\n"); - printf(" simultaneously and wish to assign an attribute to some region " - "without\n"); - printf(" imposing an area constraint, use a negative maximum area.\n\n"); - printf(" When a triangulation is created from a .poly file, you must " - "either\n"); - printf(" enclose the entire region to be triangulated in PSLG segments, " - "or\n"); - printf(" use the -c switch, which automatically creates extra segments " - "that\n"); - printf(" enclose the convex hull of the PSLG. If you do not use the -c " - "switch,\n"); - printf(" Triangle eats all triangles that are not enclosed by segments; " - "if you\n"); - printf(" are not careful, your whole triangulation may be eaten away. If " - "you do\n"); - printf(" use the -c switch, you can still produce concavities by the " - "appropriate\n"); - printf( - " placement of holes just inside the boundary of the convex hull.\n"); - printf("\n"); - printf(" An ideal PSLG has no intersecting segments, nor any vertices " - "that lie\n"); - printf(" upon segments (except, of course, the endpoints of each " - "segment). You\n"); - printf(" aren't required to make your .poly files ideal, but you should " - "be aware\n"); - printf(" of what can go wrong. Segment intersections are relatively " - "safe--\n"); - printf(" Triangle calculates the intersection points for you and adds " - "them to\n"); - printf(" the triangulation--as long as your machine's floating-point " - "precision\n"); - printf(" doesn't become a problem. You are tempting the fates if you " - "have three\n"); - printf(" segments that cross at the same location, and expect Triangle to " - "figure\n"); - printf(" out where the intersection point is. Thanks to floating-point " - "roundoff\n"); - printf(" error, Triangle will probably decide that the three segments " - "intersect\n"); - printf(" at three different points, and you will find a minuscule " - "triangle in\n"); - printf(" your output--unless Triangle tries to refine the tiny triangle, " - "uses\n"); - printf(" up the last bit of machine precision, and fails to terminate at " - "all.\n"); - printf(" You're better off putting the intersection point in the input " - "files,\n"); - printf(" and manually breaking up each segment into two. Similarly, if " - "you\n"); - printf(" place a vertex at the middle of a segment, and hope that " - "Triangle will\n"); - printf(" break up the segment at that vertex, you might get lucky. On " - "the other\n"); - printf(" hand, Triangle might decide that the vertex doesn't lie " - "precisely on\n"); - printf(" the segment, and you'll have a needle-sharp triangle in your " - "output--or\n"); - printf(" a lot of tiny triangles if you're generating a quality mesh.\n"); - printf("\n"); - printf(" When Triangle reads a .poly file, it also writes a .poly file, " - "which\n"); - printf( - " includes all the subsegments--the edges that are parts of input\n"); - printf( - " segments. If the -c switch is used, the output .poly file also\n"); - printf(" includes all of the edges on the convex hull. Hence, the output " - ".poly\n"); - printf(" file is useful for finding edges associated with input segments " - "and for\n"); - printf(" setting boundary conditions in finite element simulations. " - "Moreover,\n"); - printf(" you will need the output .poly file if you plan to refine the " - "output\n"); - printf(" mesh, and don't want segments to be missing in later " - "triangulations.\n"); - printf("\n"); - printf(" .area files:\n"); - printf(" First line: <# of triangles>\n"); - printf(" Following lines: \n"); - printf("\n"); - printf(" An .area file associates with each triangle a maximum area that " - "is used\n"); - printf(" for mesh refinement. As with other file formats, every triangle " - "must\n"); - printf(" be represented, and the triangles must be numbered " - "consecutively. A\n"); - printf(" triangle may be left unconstrained by assigning it a negative " - "maximum\n"); - printf(" area.\n\n"); - printf(" .edge files:\n"); - printf(" First line: <# of edges> <# of boundary markers (0 or 1)>\n"); - printf(" Following lines: [boundary " - "marker]\n"); - printf("\n"); - printf(" Endpoints are indices into the corresponding .node file. " - "Triangle can\n"); - printf(" produce .edge files (use the -e switch), but cannot read them. " - "The\n"); - printf(" optional column of boundary markers is suppressed by the -B " - "switch.\n"); - printf("\n"); - printf(" In Voronoi diagrams, one also finds a special kind of edge that " - "is an\n"); - printf(" infinite ray with only one endpoint. For these edges, a " - "different\n"); - printf(" format is used:\n\n"); - printf(" -1 \n\n"); - printf(" The `direction' is a floating-point vector that indicates the " - "direction\n"); - printf(" of the infinite ray.\n\n"); - printf(" .neigh files:\n"); - printf(" First line: <# of triangles> <# of neighbors per triangle " - "(always 3)>\n"); - printf( - " Following lines: \n"); - printf("\n"); - printf(" Neighbors are indices into the corresponding .ele file. An " - "index of -1\n"); - printf(" indicates no neighbor (because the triangle is on an exterior\n"); - printf(" boundary). The first neighbor of triangle i is opposite the " - "first\n"); - printf(" corner of triangle i, and so on.\n\n"); - printf(" Triangle can produce .neigh files (use the -n switch), but " - "cannot read\n"); - printf(" them.\n\n"); - printf("Boundary Markers:\n\n"); - printf(" Boundary markers are tags used mainly to identify which output " - "vertices\n"); - printf(" and edges are associated with which PSLG segment, and to identify " - "which\n"); - printf(" vertices and edges occur on a boundary of the triangulation. A " - "common\n"); - printf(" use is to determine where boundary conditions should be applied to " - "a\n"); - printf(" finite element mesh. You can prevent boundary markers from being " - "written\n"); - printf(" into files produced by Triangle by using the -B switch.\n\n"); - printf(" The boundary marker associated with each segment in an output " - ".poly file\n"); - printf(" and each edge in an output .edge file is chosen as follows:\n"); - printf(" - If an output edge is part or all of a PSLG segment with a " - "nonzero\n"); - printf(" boundary marker, then the edge is assigned the same marker.\n"); - printf( - " - Otherwise, if the edge lies on a boundary of the triangulation\n"); - printf(" (even the boundary of a hole), then the edge is assigned the " - "marker\n"); - printf(" one (1).\n"); - printf(" - Otherwise, the edge is assigned the marker zero (0).\n"); - printf(" The boundary marker associated with each vertex in an output .node " - "file\n"); - printf(" is chosen as follows:\n"); - printf(" - If a vertex is assigned a nonzero boundary marker in the input " - "file,\n"); - printf( - " then it is assigned the same marker in the output .node file.\n"); - printf(" - Otherwise, if the vertex lies on a PSLG segment (even if it is " - "an\n"); - printf(" endpoint of the segment) with a nonzero boundary marker, then " - "the\n"); - printf(" vertex is assigned the same marker. If the vertex lies on " - "several\n"); - printf(" such segments, one of the markers is chosen arbitrarily.\n"); - printf(" - Otherwise, if the vertex occurs on a boundary of the " - "triangulation,\n"); - printf(" then the vertex is assigned the marker one (1).\n"); - printf(" - Otherwise, the vertex is assigned the marker zero (0).\n"); - printf("\n"); - printf(" If you want Triangle to determine for you which vertices and edges " - "are on\n"); - printf(" the boundary, assign them the boundary marker zero (or use no " - "markers at\n"); - printf(" all) in your input files. In the output files, all boundary " - "vertices,\n"); - printf(" edges, and segments will be assigned the value one.\n\n"); - printf("Triangulation Iteration Numbers:\n\n"); - printf( - " Because Triangle can read and refine its own triangulations, input\n"); - printf(" and output files have iteration numbers. For instance, Triangle " - "might\n"); - printf(" read the files mesh.3.node, mesh.3.ele, and mesh.3.poly, refine " - "the\n"); - printf( - " triangulation, and output the files mesh.4.node, mesh.4.ele, and\n"); - printf(" mesh.4.poly. Files with no iteration number are treated as if\n"); - printf(" their iteration number is zero; hence, Triangle might read the " - "file\n"); - printf(" points.node, triangulate it, and produce the files points.1.node " - "and\n"); - printf(" points.1.ele.\n\n"); - printf(" Iteration numbers allow you to create a sequence of successively " - "finer\n"); - printf(" meshes suitable for multigrid methods. They also allow you to " - "produce a\n"); - printf(" sequence of meshes using error estimate-driven mesh refinement.\n"); - printf("\n"); - printf(" If you're not using refinement or quality meshing, and you don't " - "like\n"); - printf(" iteration numbers, use the -I switch to disable them. This switch " - "also\n"); - printf(" disables output of .node and .poly files to prevent your input " - "files from\n"); - printf(" being overwritten. (If the input is a .poly file that contains " - "its own\n"); - printf( - " points, a .node file is written. This can be quite convenient for\n"); - printf(" computing CDTs or quality meshes.)\n\n"); - printf("Examples of How to Use Triangle:\n\n"); - printf(" `triangle dots' reads vertices from dots.node, and writes their " - "Delaunay\n"); - printf(" triangulation to dots.1.node and dots.1.ele. (dots.1.node is " - "identical\n"); - printf(" to dots.node.) `triangle -I dots' writes the triangulation to " - "dots.ele\n"); - printf(" instead. (No additional .node file is needed, so none is " - "written.)\n"); - printf("\n"); - printf(" `triangle -pe object.1' reads a PSLG from object.1.poly (and " - "possibly\n"); - printf(" object.1.node, if the vertices are omitted from object.1.poly) and " - "writes\n"); - printf(" its constrained Delaunay triangulation to object.2.node and " - "object.2.ele.\n"); - printf(" The segments are copied to object.2.poly, and all edges are " - "written to\n"); - printf(" object.2.edge.\n\n"); - printf(" `triangle -pq31.5a.1 object' reads a PSLG from object.poly (and " - "possibly\n"); - printf(" object.node), generates a mesh whose angles are all between 31.5 " - "and 117\n"); - printf(" degrees and whose triangles all have areas of 0.1 or less, and " - "writes the\n"); - printf(" mesh to object.1.node and object.1.ele. Each segment may be " - "broken up\n"); - printf(" into multiple subsegments; these are written to object.1.poly.\n"); - printf("\n"); - printf(" Here is a sample file `box.poly' describing a square with a square " - "hole:\n"); - printf("\n"); - printf(" # A box with eight vertices in 2D, no attributes, one boundary " - "marker.\n"); - printf(" 8 2 0 1\n"); - printf(" # Outer box has these vertices:\n"); - printf(" 1 0 0 0\n"); - printf(" 2 0 3 0\n"); - printf(" 3 3 0 0\n"); - printf(" 4 3 3 33 # A special marker for this vertex.\n"); - printf(" # Inner square has these vertices:\n"); - printf(" 5 1 1 0\n"); - printf(" 6 1 2 0\n"); - printf(" 7 2 1 0\n"); - printf(" 8 2 2 0\n"); - printf(" # Five segments with boundary markers.\n"); - printf(" 5 1\n"); - printf(" 1 1 2 5 # Left side of outer box.\n"); - printf(" # Square hole has these segments:\n"); - printf(" 2 5 7 0\n"); - printf(" 3 7 8 0\n"); - printf(" 4 8 6 10\n"); - printf(" 5 6 5 0\n"); - printf(" # One hole in the middle of the inner square.\n"); - printf(" 1\n"); - printf(" 1 1.5 1.5\n"); - printf("\n"); - printf(" Note that some segments are missing from the outer square, so you " - "must\n"); - printf(" use the `-c' switch. After `triangle -pqc box.poly', here is the " - "output\n"); - printf(" file `box.1.node', with twelve vertices. The last four vertices " - "were\n"); - printf(" added to meet the angle constraint. Vertices 1, 2, and 9 have " - "markers\n"); - printf(" from segment 1. Vertices 6 and 8 have markers from segment 4. " - "All the\n"); - printf(" other vertices but 4 have been marked to indicate that they lie on " - "a\n"); - printf(" boundary.\n\n"); - printf(" 12 2 0 1\n"); - printf(" 1 0 0 5\n"); - printf(" 2 0 3 5\n"); - printf(" 3 3 0 1\n"); - printf(" 4 3 3 33\n"); - printf(" 5 1 1 1\n"); - printf(" 6 1 2 10\n"); - printf(" 7 2 1 1\n"); - printf(" 8 2 2 10\n"); - printf(" 9 0 1.5 5\n"); - printf(" 10 1.5 0 1\n"); - printf(" 11 3 1.5 1\n"); - printf(" 12 1.5 3 1\n"); - printf(" # Generated by triangle -pqc box.poly\n"); - printf("\n"); - printf(" Here is the output file `box.1.ele', with twelve triangles.\n"); - printf("\n"); - printf(" 12 3 0\n"); - printf(" 1 5 6 9\n"); - printf(" 2 10 3 7\n"); - printf(" 3 6 8 12\n"); - printf(" 4 9 1 5\n"); - printf(" 5 6 2 9\n"); - printf(" 6 7 3 11\n"); - printf(" 7 11 4 8\n"); - printf(" 8 7 5 10\n"); - printf(" 9 12 2 6\n"); - printf(" 10 8 7 11\n"); - printf(" 11 5 1 10\n"); - printf(" 12 8 4 12\n"); - printf(" # Generated by triangle -pqc box.poly\n\n"); - printf(" Here is the output file `box.1.poly'. Note that segments have " - "been added\n"); - printf(" to represent the convex hull, and some segments have been " - "subdivided by\n"); - printf(" newly added vertices. Note also that <# of vertices> is set to " - "zero to\n"); - printf(" indicate that the vertices should be read from the .node file.\n"); - printf("\n"); - printf(" 0 2 0 1\n"); - printf(" 12 1\n"); - printf(" 1 1 9 5\n"); - printf(" 2 5 7 1\n"); - printf(" 3 8 7 1\n"); - printf(" 4 6 8 10\n"); - printf(" 5 5 6 1\n"); - printf(" 6 3 10 1\n"); - printf(" 7 4 11 1\n"); - printf(" 8 2 12 1\n"); - printf(" 9 9 2 5\n"); - printf(" 10 10 1 1\n"); - printf(" 11 11 3 1\n"); - printf(" 12 12 4 1\n"); - printf(" 1\n"); - printf(" 1 1.5 1.5\n"); - printf(" # Generated by triangle -pqc box.poly\n"); - printf("\n"); - printf("Refinement and Area Constraints:\n"); - printf("\n"); - printf( - " The -r switch causes a mesh (.node and .ele files) to be read and\n"); - printf(" refined. If the -p switch is also used, a .poly file is read and " - "used to\n"); - printf(" specify edges that are constrained and cannot be eliminated " - "(although\n"); - printf(" they can be subdivided into smaller edges) by the refinement " - "process.\n"); - printf("\n"); - printf(" When you refine a mesh, you generally want to impose tighter " - "constraints.\n"); - printf( - " One way to accomplish this is to use -q with a larger angle, or -a\n"); - printf(" followed by a smaller area than you used to generate the mesh you " - "are\n"); - printf(" refining. Another way to do this is to create an .area file, " - "which\n"); - printf( - " specifies a maximum area for each triangle, and use the -a switch\n"); - printf(" (without a number following). Each triangle's area constraint is " - "applied\n"); - printf( - " to that triangle. Area constraints tend to diffuse as the mesh is\n"); - printf(" refined, so if there are large variations in area constraint " - "between\n"); - printf(" adjacent triangles, you may not get the results you want. In that " - "case,\n"); - printf(" consider instead using the -u switch and writing a C procedure " - "that\n"); - printf(" determines which triangles are too large.\n\n"); - printf(" If you are refining a mesh composed of linear (three-node) " - "elements, the\n"); - printf(" output mesh contains all the nodes present in the input mesh, in " - "the same\n"); - printf(" order, with new nodes added at the end of the .node file. " - "However, the\n"); - printf(" refinement is not hierarchical: there is no guarantee that each " - "output\n"); - printf(" element is contained in a single input element. Often, an output " - "element\n"); - printf(" can overlap two or three input elements, and some input edges are " - "not\n"); - printf(" present in the output mesh. Hence, a sequence of refined meshes " - "forms a\n"); - printf(" hierarchy of nodes, but not a hierarchy of elements. If you " - "refine a\n"); - printf(" mesh of higher-order elements, the hierarchical property applies " - "only to\n"); - printf(" the nodes at the corners of an element; the midpoint nodes on each " - "edge\n"); - printf(" are discarded before the mesh is refined.\n\n"); - printf(" Maximum area constraints in .poly files operate differently from " - "those in\n"); - printf( - " .area files. A maximum area in a .poly file applies to the whole\n"); - printf(" (segment-bounded) region in which a point falls, whereas a maximum " - "area\n"); - printf(" in an .area file applies to only one triangle. Area constraints " - "in .poly\n"); - printf( - " files are used only when a mesh is first generated, whereas area\n"); - printf(" constraints in .area files are used only to refine an existing " - "mesh, and\n"); - printf(" are typically based on a posteriori error estimates resulting from " - "a\n"); - printf(" finite element simulation on that mesh.\n\n"); - printf(" `triangle -rq25 object.1' reads object.1.node and object.1.ele, " - "then\n"); - printf(" refines the triangulation to enforce a 25 degree minimum angle, " - "and then\n"); - printf(" writes the refined triangulation to object.2.node and " - "object.2.ele.\n"); - printf("\n"); - printf(" `triangle -rpaa6.2 z.3' reads z.3.node, z.3.ele, z.3.poly, and " - "z.3.area.\n"); - printf(" After reconstructing the mesh and its subsegments, Triangle " - "refines the\n"); - printf(" mesh so that no triangle has area greater than 6.2, and " - "furthermore the\n"); - printf(" triangles satisfy the maximum area constraints in z.3.area. No " - "angle\n"); - printf(" bound is imposed at all. The output is written to z.4.node, " - "z.4.ele, and\n"); - printf(" z.4.poly.\n\n"); - printf(" The sequence `triangle -qa1 x', `triangle -rqa.3 x.1', `triangle " - "-rqa.1\n"); - printf(" x.2' creates a sequence of successively finer meshes x.1, x.2, and " - "x.3,\n"); - printf(" suitable for multigrid.\n\n"); - printf("Convex Hulls and Mesh Boundaries:\n\n"); - printf(" If the input is a vertex set (not a PSLG), Triangle produces its " - "convex\n"); - printf(" hull as a by-product in the output .poly file if you use the -c " - "switch.\n"); - printf(" There are faster algorithms for finding a two-dimensional convex " - "hull\n"); - printf(" than triangulation, of course, but this one comes for free.\n\n"); - printf(" If the input is an unconstrained mesh (you are using the -r switch " - "but\n"); - printf( - " not the -p switch), Triangle produces a list of its boundary edges\n"); - printf(" (including hole boundaries) as a by-product when you use the -c " - "switch.\n"); - printf(" If you also use the -p switch, the output .poly file contains all " - "the\n"); - printf(" segments from the input .poly file as well.\n\n"); - printf("Voronoi Diagrams:\n\n"); - printf(" The -v switch produces a Voronoi diagram, in files suffixed " - ".v.node and\n"); - printf(" .v.edge. For example, `triangle -v points' reads points.node, " - "produces\n"); - printf( - " its Delaunay triangulation in points.1.node and points.1.ele, and\n"); - printf(" produces its Voronoi diagram in points.1.v.node and " - "points.1.v.edge. The\n"); - printf(" .v.node file contains a list of all Voronoi vertices, and the " - ".v.edge\n"); - printf(" file contains a list of all Voronoi edges, some of which may be " - "infinite\n"); - printf(" rays. (The choice of filenames makes it easy to run the set of " - "Voronoi\n"); - printf(" vertices through Triangle, if so desired.)\n\n"); - printf(" This implementation does not use exact arithmetic to compute the " - "Voronoi\n"); - printf(" vertices, and does not check whether neighboring vertices are " - "identical.\n"); - printf( - " Be forewarned that if the Delaunay triangulation is degenerate or\n"); - printf(" near-degenerate, the Voronoi diagram may have duplicate vertices " - "or\n"); - printf(" crossing edges.\n\n"); - printf(" The result is a valid Voronoi diagram only if Triangle's output is " - "a true\n"); - printf(" Delaunay triangulation. The Voronoi output is usually meaningless " - "(and\n"); - printf(" may contain crossing edges and other pathology) if the output is a " - "CDT or\n"); - printf(" CCDT, or if it has holes or concavities. If the triangulated " - "domain is\n"); - printf(" convex and has no holes, you can use -D switch to force Triangle " - "to\n"); - printf(" construct a conforming Delaunay triangulation instead of a CCDT, " - "so the\n"); - printf(" Voronoi diagram will be valid.\n\n"); - printf("Mesh Topology:\n\n"); - printf(" You may wish to know which triangles are adjacent to a certain " - "Delaunay\n"); - printf(" edge in an .edge file, which Voronoi cells are adjacent to a " - "certain\n"); - printf(" Voronoi edge in a .v.edge file, or which Voronoi cells are " - "adjacent to\n"); - printf(" each other. All of this information can be found by " - "cross-referencing\n"); - printf(" output files with the recollection that the Delaunay triangulation " - "and\n"); - printf(" the Voronoi diagram are planar duals.\n\n"); - printf(" Specifically, edge i of an .edge file is the dual of Voronoi edge " - "i of\n"); - printf(" the corresponding .v.edge file, and is rotated 90 degrees " - "counterclock-\n"); - printf(" wise from the Voronoi edge. Triangle j of an .ele file is the " - "dual of\n"); - printf(" vertex j of the corresponding .v.node file. Voronoi cell k is the " - "dual\n"); - printf(" of vertex k of the corresponding .node file.\n\n"); - printf(" Hence, to find the triangles adjacent to a Delaunay edge, look at " - "the\n"); - printf( - " vertices of the corresponding Voronoi edge. If the endpoints of a\n"); - printf(" Voronoi edge are Voronoi vertices 2 and 6 respectively, then " - "triangles 2\n"); - printf(" and 6 adjoin the left and right sides of the corresponding " - "Delaunay edge,\n"); - printf(" respectively. To find the Voronoi cells adjacent to a Voronoi " - "edge, look\n"); - printf(" at the endpoints of the corresponding Delaunay edge. If the " - "endpoints of\n"); - printf(" a Delaunay edge are input vertices 7 and 12, then Voronoi cells 7 " - "and 12\n"); - printf( - " adjoin the right and left sides of the corresponding Voronoi edge,\n"); - printf(" respectively. To find which Voronoi cells are adjacent to each " - "other,\n"); - printf(" just read the list of Delaunay edges.\n\n"); - printf(" Triangle does not write a list of the edges adjoining each Voronoi " - "cell,\n"); - printf(" but you can reconstructed it straightforwardly. For instance, to " - "find\n"); - printf(" all the edges of Voronoi cell 1, search the output .edge file for " - "every\n"); - printf(" edge that has input vertex 1 as an endpoint. The corresponding " - "dual\n"); - printf(" edges in the output .v.edge file form the boundary of Voronoi cell " - "1.\n"); - printf("\n"); - printf( - " For each Voronoi vertex, the .neigh file gives a list of the three\n"); - printf(" Voronoi vertices attached to it. You might find this more " - "convenient\n"); - printf(" than the .v.edge file.\n\n"); - printf("Quadratic Elements:\n\n"); - printf(" Triangle generates meshes with subparametric quadratic elements if " - "the\n"); - printf(" -o2 switch is specified. Quadratic elements have six nodes per " - "element,\n"); - printf(" rather than three. `Subparametric' means that the edges of the " - "triangles\n"); - printf( - " are always straight, so that subparametric quadratic elements are\n"); - printf(" geometrically identical to linear elements, even though they can " - "be used\n"); - printf(" with quadratic interpolating functions. The three extra nodes of " - "an\n"); - printf(" element fall at the midpoints of the three edges, with the fourth, " - "fifth,\n"); - printf(" and sixth nodes appearing opposite the first, second, and third " - "corners\n"); - printf(" respectively.\n\n"); - printf("Domains with Small Angles:\n\n"); - printf(" If two input segments adjoin each other at a small angle, clearly " - "the -q\n"); - printf(" switch cannot remove the small angle. Moreover, Triangle may have " - "no\n"); - printf(" choice but to generate additional triangles whose smallest angles " - "are\n"); - printf(" smaller than the specified bound. However, these triangles only " - "appear\n"); - printf(" between input segments separated by small angles. Moreover, if " - "you\n"); - printf(" request a minimum angle of theta degrees, Triangle will generally " - "produce\n"); - printf(" no angle larger than 180 - 2 theta, even if it is forced to " - "compromise on\n"); - printf(" the minimum angle.\n\n"); - printf("Statistics:\n\n"); - printf(" After generating a mesh, Triangle prints a count of entities in " - "the\n"); - printf(" output mesh, including the number of vertices, triangles, edges, " - "exterior\n"); - printf(" boundary edges (i.e. subsegments on the boundary of the " - "triangulation,\n"); - printf(" including hole boundaries), interior boundary edges (i.e. " - "subsegments of\n"); - printf(" input segments not on the boundary), and total subsegments. If " - "you've\n"); - printf(" forgotten the statistics for an existing mesh, run Triangle on " - "that mesh\n"); - printf(" with the -rNEP switches to read the mesh and print the statistics " - "without\n"); - printf(" writing any files. Use -rpNEP if you've got a .poly file for the " - "mesh.\n"); - printf("\n"); - printf(" The -V switch produces extended statistics, including a rough " - "estimate\n"); - printf(" of memory use, the number of calls to geometric predicates, and\n"); - printf(" histograms of the angles and the aspect ratios of the triangles in " - "the\n"); - printf(" mesh.\n\n"); - printf("Exact Arithmetic:\n\n"); - printf(" Triangle uses adaptive exact arithmetic to perform what " - "computational\n"); - printf(" geometers call the `orientation' and `incircle' tests. If the " - "floating-\n"); - printf(" point arithmetic of your machine conforms to the IEEE 754 standard " - "(as\n"); - printf(" most workstations do), and does not use extended precision " - "internal\n"); - printf( - " floating-point registers, then your output is guaranteed to be an\n"); - printf(" absolutely true Delaunay or constrained Delaunay triangulation, " - "roundoff\n"); - printf(" error notwithstanding. The word `adaptive' implies that these " - "arithmetic\n"); - printf(" routines compute the result only to the precision necessary to " - "guarantee\n"); - printf(" correctness, so they are usually nearly as fast as their " - "approximate\n"); - printf(" counterparts.\n\n"); - printf( - " May CPUs, including Intel x86 processors, have extended precision\n"); - printf(" floating-point registers. These must be reconfigured so their " - "precision\n"); - printf(" is reduced to memory precision. Triangle does this if it is " - "compiled\n"); - printf(" correctly. See the makefile for details.\n\n"); - printf(" The exact tests can be disabled with the -X switch. On most " - "inputs, this\n"); - printf(" switch reduces the computation time by about eight percent--it's " - "not\n"); - printf(" worth the risk. There are rare difficult inputs (having many " - "collinear\n"); - printf(" and cocircular vertices), however, for which the difference in " - "speed\n"); - printf(" could be a factor of two. Be forewarned that these are precisely " - "the\n"); - printf(" inputs most likely to cause errors if you use the -X switch. " - "Hence, the\n"); - printf(" -X switch is not recommended.\n\n"); - printf(" Unfortunately, the exact tests don't solve every numerical " - "problem.\n"); - printf(" Exact arithmetic is not used to compute the positions of new " - "vertices,\n"); - printf(" because the bit complexity of vertex coordinates would grow " - "without\n"); - printf(" bound. Hence, segment intersections aren't computed exactly; in " - "very\n"); - printf(" unusual cases, roundoff error in computing an intersection point " - "might\n"); - printf(" actually lead to an inverted triangle and an invalid " - "triangulation.\n"); - printf(" (This is one reason to specify your own intersection points in " - "your .poly\n"); - printf(" files.) Similarly, exact arithmetic is not used to compute the " - "vertices\n"); - printf(" of the Voronoi diagram.\n\n"); - printf(" Another pair of problems not solved by the exact arithmetic " - "routines is\n"); - printf(" underflow and overflow. If Triangle is compiled for double " - "precision\n"); - printf(" arithmetic, I believe that Triangle's geometric predicates work " - "correctly\n"); - printf(" if the exponent of every input coordinate falls in the range " - "[-148, 201].\n"); - printf(" Underflow can silently prevent the orientation and incircle tests " - "from\n"); - printf(" being performed exactly, while overflow typically causes a " - "floating\n"); - printf(" exception.\n\n"); - printf("Calling Triangle from Another Program:\n\n"); - printf(" Read the file triangle.h for details.\n\n"); - printf("Troubleshooting:\n\n"); - printf(" Please read this section before mailing me bugs.\n\n"); - printf(" `My output mesh has no triangles!'\n\n"); - printf(" If you're using a PSLG, you've probably failed to specify a " - "proper set\n"); - printf(" of bounding segments, or forgotten to use the -c switch. Or you " - "may\n"); - printf(" have placed a hole badly, thereby eating all your triangles. To " - "test\n"); - printf(" these possibilities, try again with the -c and -O switches.\n"); - printf(" Alternatively, all your input vertices may be collinear, in " - "which case\n"); - printf(" you can hardly expect to triangulate them.\n\n"); - printf(" `Triangle doesn't terminate, or just crashes.'\n\n"); - printf(" Bad things can happen when triangles get so small that the " - "distance\n"); - printf(" between their vertices isn't much larger than the precision of " - "your\n"); - printf(" machine's arithmetic. If you've compiled Triangle for " - "single-precision\n"); - printf(" arithmetic, you might do better by recompiling it for " - "double-precision.\n"); - printf(" Then again, you might just have to settle for more lenient " - "constraints\n"); - printf( - " on the minimum angle and the maximum area than you had planned.\n"); - printf("\n"); - printf(" You can minimize precision problems by ensuring that the origin " - "lies\n"); - printf( - " inside your vertex set, or even inside the densest part of your\n"); - printf(" mesh. If you're triangulating an object whose x-coordinates all " - "fall\n"); - printf(" between 6247133 and 6247134, you're not leaving much " - "floating-point\n"); - printf(" precision for Triangle to work with.\n\n"); - printf(" Precision problems can occur covertly if the input PSLG contains " - "two\n"); - printf(" segments that meet (or intersect) at an extremely small angle, " - "or if\n"); - printf(" such an angle is introduced by the -c switch. If you don't " - "realize\n"); - printf( - " that a tiny angle is being formed, you might never discover why\n"); - printf(" Triangle is crashing. To check for this possibility, use the -S " - "switch\n"); - printf(" (with an appropriate limit on the number of Steiner points, " - "found by\n"); - printf(" trial-and-error) to stop Triangle early, and view the output " - ".poly file\n"); - printf(" with Show Me (described below). Look carefully for regions " - "where dense\n"); - printf(" clusters of vertices are forming and for small angles between " - "segments.\n"); - printf(" Zoom in closely, as such segments might look like a single " - "segment from\n"); - printf(" a distance.\n\n"); - printf( - " If some of the input values are too large, Triangle may suffer a\n"); - printf( - " floating exception due to overflow when attempting to perform an\n"); - printf(" orientation or incircle test. (Read the section on exact " - "arithmetic\n"); - printf(" above.) Again, I recommend compiling Triangle for double " - "(rather\n"); - printf(" than single) precision arithmetic.\n\n"); - printf(" Unexpected problems can arise if you use quality meshing (-q, " - "-a, or\n"); - printf(" -u) with an input that is not segment-bounded--that is, if your " - "input\n"); - printf(" is a vertex set, or you're using the -c switch. If the convex " - "hull of\n"); - printf(" your input vertices has collinear vertices on its boundary, an " - "input\n"); - printf(" vertex that you think lies on the convex hull might actually lie " - "just\n"); - printf(" inside the convex hull. If so, the vertex and the nearby convex " - "hull\n"); - printf(" edge form an extremely thin triangle. When Triangle tries to " - "refine\n"); - printf(" the mesh to enforce angle and area constraints, Triangle might " - "generate\n"); - printf(" extremely tiny triangles, or it might fail because of " - "insufficient\n"); - printf(" floating-point precision.\n\n"); - printf(" `The numbering of the output vertices doesn't match the input " - "vertices.'\n"); - printf("\n"); - printf(" You may have had duplicate input vertices, or you may have eaten " - "some\n"); - printf(" of your input vertices with a hole, or by placing them outside " - "the area\n"); - printf(" enclosed by segments. In any case, you can solve the problem by " - "not\n"); - printf(" using the -j switch.\n\n"); - printf(" `Triangle executes without incident, but when I look at the " - "resulting\n"); - printf(" mesh, it has overlapping triangles or other geometric " - "inconsistencies.'\n"); - printf("\n"); - printf(" If you select the -X switch, Triangle occasionally makes " - "mistakes due\n"); - printf(" to floating-point roundoff error. Although these errors are " - "rare,\n"); - printf(" don't use the -X switch. If you still have problems, please " - "report the\n"); - printf(" bug.\n\n"); - printf(" `Triangle executes without incident, but when I look at the " - "resulting\n"); - printf(" Voronoi diagram, it has overlapping edges or other geometric\n"); - printf(" inconsistencies.'\n"); - printf("\n"); - printf(" If your input is a PSLG (-p), you can only expect a meaningful " - "Voronoi\n"); - printf(" diagram if the domain you are triangulating is convex and free " - "of\n"); - printf(" holes, and you use the -D switch to construct a conforming " - "Delaunay\n"); - printf(" triangulation (instead of a CDT or CCDT).\n\n"); - printf(" Strange things can happen if you've taken liberties with your " - "PSLG. Do\n"); - printf(" you have a vertex lying in the middle of a segment? Triangle " - "sometimes\n"); - printf(" copes poorly with that sort of thing. Do you want to lay out a " - "collinear\n"); - printf( - " row of evenly spaced, segment-connected vertices? Have you simply\n"); - printf(" defined one long segment connecting the leftmost vertex to the " - "rightmost\n"); - printf(" vertex, and a bunch of vertices lying along it? This method " - "occasionally\n"); - printf( - " works, especially with horizontal and vertical lines, but often it\n"); - printf(" doesn't, and you'll have to connect each adjacent pair of vertices " - "with a\n"); - printf(" separate segment. If you don't like it, tough.\n\n"); - printf(" Furthermore, if you have segments that intersect other than at " - "their\n"); - printf(" endpoints, try not to let the intersections fall extremely close " - "to PSLG\n"); - printf(" vertices or each other.\n\n"); - printf(" If you have problems refining a triangulation not produced by " - "Triangle:\n"); - printf(" Are you sure the triangulation is geometrically valid? Is it " - "formatted\n"); - printf(" correctly for Triangle? Are the triangles all listed so the first " - "three\n"); - printf(" vertices are their corners in counterclockwise order? Are all of " - "the\n"); - printf(" triangles constrained Delaunay? Triangle's Delaunay refinement " - "algorithm\n"); - printf(" assumes that it starts with a CDT.\n\n"); - printf("Show Me:\n\n"); - printf(" Triangle comes with a separate program named `Show Me', whose " - "primary\n"); - printf(" purpose is to draw meshes on your screen or in PostScript. Its " - "secondary\n"); - printf(" purpose is to check the validity of your input files, and do so " - "more\n"); - printf(" thoroughly than Triangle does. Unlike Triangle, Show Me requires " - "that\n"); - printf(" you have the X Windows system. Sorry, Microsoft Windows users.\n"); - printf("\n"); - printf("Triangle on the Web:\n"); - printf("\n"); - printf(" To see an illustrated version of these instructions, check out\n"); - printf("\n"); - printf(" http://www.cs.cmu.edu/~quake/triangle.html\n"); - printf("\n"); - printf("A Brief Plea:\n"); - printf("\n"); - printf(" If you use Triangle, and especially if you use it to accomplish " - "real\n"); - printf(" work, I would like very much to hear from you. A short letter or " - "email\n"); - printf(" (to jrs@cs.berkeley.edu) describing how you use Triangle will mean " - "a lot\n"); - printf(" to me. The more people I know are using this program, the more " - "easily I\n"); - printf(" can justify spending time on improvements, which in turn will " - "benefit\n"); - printf(" you. Also, I can put you on a list to receive email whenever a " - "new\n"); - printf(" version of Triangle is available.\n\n"); - printf(" If you use a mesh generated by Triangle in a publication, please " - "include\n"); - printf(" an acknowledgment as well. And please spell Triangle with a " - "capital `T'!\n"); - printf( - " If you want to include a citation, use `Jonathan Richard Shewchuk,\n"); - printf( - " ``Triangle: Engineering a 2D Quality Mesh Generator and Delaunay\n"); - printf(" Triangulator,'' in Applied Computational Geometry: Towards " - "Geometric\n"); - printf(" Engineering (Ming C. Lin and Dinesh Manocha, editors), volume 1148 " - "of\n"); - printf( - " Lecture Notes in Computer Science, pages 203-222, Springer-Verlag,\n"); - printf(" Berlin, May 1996. (From the First ACM Workshop on Applied " - "Computational\n"); - printf(" Geometry.)'\n\n"); - printf("Research credit:\n\n"); - printf(" Of course, I can take credit for only a fraction of the ideas that " - "made\n"); - printf(" this mesh generator possible. Triangle owes its existence to the " - "efforts\n"); - printf(" of many fine computational geometers and other researchers, " - "including\n"); - printf(" Marshall Bern, L. Paul Chew, Kenneth L. Clarkson, Boris Delaunay, " - "Rex A.\n"); - printf(" Dwyer, David Eppstein, Steven Fortune, Leonidas J. Guibas, Donald " - "E.\n"); - printf(" Knuth, Charles L. Lawson, Der-Tsai Lee, Gary L. Miller, Ernst P. " - "Mucke,\n"); - printf(" Steven E. Pav, Douglas M. Priest, Jim Ruppert, Isaac Saias, Bruce " - "J.\n"); - printf(" Schachter, Micha Sharir, Peter W. Shor, Daniel D. Sleator, Jorge " - "Stolfi,\n"); - printf(" Robert E. Tarjan, Alper Ungor, Christopher J. Van Wyk, Noel J.\n"); - printf(" Walkington, and Binhai Zhu. See the comments at the beginning of " - "the\n"); - printf(" source code for references.\n\n"); - triexit(0); -} - -#endif /* not TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* internalerror() Ask the user to send me the defective product. Exit. */ -/* */ -/*****************************************************************************/ - -void internalerror() { - printf(" Please report this bug to jrs@cs.berkeley.edu\n"); - printf(" Include the message above, your input data set, and the exact\n"); - printf(" command line you used to run Triangle.\n"); - triexit(1); -} - -/*****************************************************************************/ -/* */ -/* parsecommandline() Read the command line, identify switches, and set */ -/* up options and file names. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void parsecommandline(int argc, char **argv, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void parsecommandline(argc, argv, b) int argc; -char **argv; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ -#ifdef TRILIBRARY -#define STARTINDEX 0 -#else /* not TRILIBRARY */ -#define STARTINDEX 1 - int increment; - int meshnumber; -#endif /* not TRILIBRARY */ - int i, j, k; - char workstring[FILENAMESIZE]; - - b->poly = b->refine = b->quality = 0; - b->vararea = b->fixedarea = b->usertest = 0; - b->regionattrib = b->convex = b->weighted = b->jettison = 0; - b->firstnumber = 1; - b->edgesout = b->voronoi = b->neighbors = b->geomview = 0; - b->nobound = b->nopolywritten = b->nonodewritten = b->noelewritten = 0; - b->noiterationnum = 0; - b->noholes = b->noexact = 0; - b->incremental = b->sweepline = 0; - b->dwyer = 1; - b->splitseg = 0; - b->docheck = 0; - b->nobisect = 0; - b->conformdel = 0; - b->steiner = -1; - b->order = 1; - b->minangle = 0.0; - b->maxarea = -1.0; - b->quiet = b->verbose = 0; -#ifndef TRILIBRARY - b->innodefilename[0] = '\0'; -#endif /* not TRILIBRARY */ - - for (i = STARTINDEX; i < argc; i++) { -#ifndef TRILIBRARY - if (argv[i][0] == '-') { -#endif /* not TRILIBRARY */ - for (j = STARTINDEX; argv[i][j] != '\0'; j++) { - if (argv[i][j] == 'p') { - b->poly = 1; - } -#ifndef CDT_ONLY - if (argv[i][j] == 'r') { - b->refine = 1; - } - if (argv[i][j] == 'q') { - b->quality = 1; - if (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || - (argv[i][j + 1] == '.')) { - k = 0; - while (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || - (argv[i][j + 1] == '.')) { - j++; - workstring[k] = argv[i][j]; - k++; - } - workstring[k] = '\0'; - b->minangle = (REAL)strtod(workstring, (char **)NULL); - } else { - b->minangle = 20.0; - } - } - if (argv[i][j] == 'a') { - b->quality = 1; - if (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || - (argv[i][j + 1] == '.')) { - b->fixedarea = 1; - k = 0; - while (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || - (argv[i][j + 1] == '.')) { - j++; - workstring[k] = argv[i][j]; - k++; - } - workstring[k] = '\0'; - b->maxarea = (REAL)strtod(workstring, (char **)NULL); - if (b->maxarea <= 0.0) { - printf("Error: Maximum area must be greater than zero.\n"); - triexit(1); - } - } else { - b->vararea = 1; - } - } - if (argv[i][j] == 'u') { - b->quality = 1; - b->usertest = 1; - } -#endif /* not CDT_ONLY */ - if (argv[i][j] == 'A') { - b->regionattrib = 1; - } - if (argv[i][j] == 'c') { - b->convex = 1; - } - if (argv[i][j] == 'w') { - b->weighted = 1; - } - if (argv[i][j] == 'W') { - b->weighted = 2; - } - if (argv[i][j] == 'j') { - b->jettison = 1; - } - if (argv[i][j] == 'z') { - b->firstnumber = 0; - } - if (argv[i][j] == 'e') { - b->edgesout = 1; - } - if (argv[i][j] == 'v') { - b->voronoi = 1; - } - if (argv[i][j] == 'n') { - b->neighbors = 1; - } - if (argv[i][j] == 'g') { - b->geomview = 1; - } - if (argv[i][j] == 'B') { - b->nobound = 1; - } - if (argv[i][j] == 'P') { - b->nopolywritten = 1; - } - if (argv[i][j] == 'N') { - b->nonodewritten = 1; - } - if (argv[i][j] == 'E') { - b->noelewritten = 1; - } -#ifndef TRILIBRARY - if (argv[i][j] == 'I') { - b->noiterationnum = 1; - } -#endif /* not TRILIBRARY */ - if (argv[i][j] == 'O') { - b->noholes = 1; - } - if (argv[i][j] == 'X') { - b->noexact = 1; - } - if (argv[i][j] == 'o') { - if (argv[i][j + 1] == '2') { - j++; - b->order = 2; - } - } -#ifndef CDT_ONLY - if (argv[i][j] == 'Y') { - b->nobisect++; - } - if (argv[i][j] == 'S') { - b->steiner = 0; - while ((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) { - j++; - b->steiner = b->steiner * 10 + (int)(argv[i][j] - '0'); - } - } -#endif /* not CDT_ONLY */ -#ifndef REDUCED - if (argv[i][j] == 'i') { - b->incremental = 1; - } - if (argv[i][j] == 'F') { - b->sweepline = 1; - } -#endif /* not REDUCED */ - if (argv[i][j] == 'l') { - b->dwyer = 0; - } -#ifndef REDUCED -#ifndef CDT_ONLY - if (argv[i][j] == 's') { - b->splitseg = 1; - } - if ((argv[i][j] == 'D') || (argv[i][j] == 'L')) { - b->quality = 1; - b->conformdel = 1; - } -#endif /* not CDT_ONLY */ - if (argv[i][j] == 'C') { - b->docheck = 1; - } -#endif /* not REDUCED */ - if (argv[i][j] == 'Q') { - b->quiet = 1; - } - if (argv[i][j] == 'V') { - b->verbose++; - } -#ifndef TRILIBRARY - if ((argv[i][j] == 'h') || (argv[i][j] == 'H') || (argv[i][j] == '?')) { - info(); - } -#endif /* not TRILIBRARY */ - } -#ifndef TRILIBRARY - } else { - strncpy(b->innodefilename, argv[i], FILENAMESIZE - 1); - b->innodefilename[FILENAMESIZE - 1] = '\0'; - } -#endif /* not TRILIBRARY */ - } -#ifndef TRILIBRARY - if (b->innodefilename[0] == '\0') { - syntax(); - } - if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 5], ".node")) { - b->innodefilename[strlen(b->innodefilename) - 5] = '\0'; - } - if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 5], ".poly")) { - b->innodefilename[strlen(b->innodefilename) - 5] = '\0'; - b->poly = 1; - } -#ifndef CDT_ONLY - if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 4], ".ele")) { - b->innodefilename[strlen(b->innodefilename) - 4] = '\0'; - b->refine = 1; - } - if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 5], ".area")) { - b->innodefilename[strlen(b->innodefilename) - 5] = '\0'; - b->refine = 1; - b->quality = 1; - b->vararea = 1; - } -#endif /* not CDT_ONLY */ -#endif /* not TRILIBRARY */ - b->usesegments = b->poly || b->refine || b->quality || b->convex; - b->goodangle = cos(b->minangle * PI / 180.0); - if (b->goodangle == 1.0) { - b->offconstant = 0.0; - } else { - b->offconstant = 0.475 * sqrt((1.0 + b->goodangle) / (1.0 - b->goodangle)); - } - b->goodangle *= b->goodangle; - if (b->refine && b->noiterationnum) { - printf("Error: You cannot use the -I switch when refining a " - "triangulation.\n"); - triexit(1); - } - /* Be careful not to allocate space for element area constraints that */ - /* will never be assigned any value (other than the default -1.0). */ - if (!b->refine && !b->poly) { - b->vararea = 0; - } - /* Be careful not to add an extra attribute to each element unless the */ - /* input supports it (PSLG in, but not refining a preexisting mesh). */ - if (b->refine || !b->poly) { - b->regionattrib = 0; - } - /* Regular/weighted triangulations are incompatible with PSLGs */ - /* and meshing. */ - if (b->weighted && (b->poly || b->quality)) { - b->weighted = 0; - if (!b->quiet) { - printf("Warning: weighted triangulations (-w, -W) are incompatible\n"); - printf(" with PSLGs (-p) and meshing (-q, -a, -u). Weights ignored.\n"); - } - } - if (b->jettison && b->nonodewritten && !b->quiet) { - printf("Warning: -j and -N switches are somewhat incompatible.\n"); - printf(" If any vertices are jettisoned, you will need the output\n"); - printf(" .node file to reconstruct the new node indices."); - } - -#ifndef TRILIBRARY - strcpy(b->inpolyfilename, b->innodefilename); - strcpy(b->inelefilename, b->innodefilename); - strcpy(b->areafilename, b->innodefilename); - increment = 0; - strcpy(workstring, b->innodefilename); - j = 1; - while (workstring[j] != '\0') { - if ((workstring[j] == '.') && (workstring[j + 1] != '\0')) { - increment = j + 1; - } - j++; - } - meshnumber = 0; - if (increment > 0) { - j = increment; - do { - if ((workstring[j] >= '0') && (workstring[j] <= '9')) { - meshnumber = meshnumber * 10 + (int)(workstring[j] - '0'); - } else { - increment = 0; - } - j++; - } while (workstring[j] != '\0'); - } - if (b->noiterationnum) { - strcpy(b->outnodefilename, b->innodefilename); - strcpy(b->outelefilename, b->innodefilename); - strcpy(b->edgefilename, b->innodefilename); - strcpy(b->vnodefilename, b->innodefilename); - strcpy(b->vedgefilename, b->innodefilename); - strcpy(b->neighborfilename, b->innodefilename); - strcpy(b->offfilename, b->innodefilename); - strcat(b->outnodefilename, ".node"); - strcat(b->outelefilename, ".ele"); - strcat(b->edgefilename, ".edge"); - strcat(b->vnodefilename, ".v.node"); - strcat(b->vedgefilename, ".v.edge"); - strcat(b->neighborfilename, ".neigh"); - strcat(b->offfilename, ".off"); - } else if (increment == 0) { - strcpy(b->outnodefilename, b->innodefilename); - strcpy(b->outpolyfilename, b->innodefilename); - strcpy(b->outelefilename, b->innodefilename); - strcpy(b->edgefilename, b->innodefilename); - strcpy(b->vnodefilename, b->innodefilename); - strcpy(b->vedgefilename, b->innodefilename); - strcpy(b->neighborfilename, b->innodefilename); - strcpy(b->offfilename, b->innodefilename); - strcat(b->outnodefilename, ".1.node"); - strcat(b->outpolyfilename, ".1.poly"); - strcat(b->outelefilename, ".1.ele"); - strcat(b->edgefilename, ".1.edge"); - strcat(b->vnodefilename, ".1.v.node"); - strcat(b->vedgefilename, ".1.v.edge"); - strcat(b->neighborfilename, ".1.neigh"); - strcat(b->offfilename, ".1.off"); - } else { - workstring[increment] = '%'; - workstring[increment + 1] = 'd'; - workstring[increment + 2] = '\0'; - sprintf(b->outnodefilename, workstring, meshnumber + 1); - strcpy(b->outpolyfilename, b->outnodefilename); - strcpy(b->outelefilename, b->outnodefilename); - strcpy(b->edgefilename, b->outnodefilename); - strcpy(b->vnodefilename, b->outnodefilename); - strcpy(b->vedgefilename, b->outnodefilename); - strcpy(b->neighborfilename, b->outnodefilename); - strcpy(b->offfilename, b->outnodefilename); - strcat(b->outnodefilename, ".node"); - strcat(b->outpolyfilename, ".poly"); - strcat(b->outelefilename, ".ele"); - strcat(b->edgefilename, ".edge"); - strcat(b->vnodefilename, ".v.node"); - strcat(b->vedgefilename, ".v.edge"); - strcat(b->neighborfilename, ".neigh"); - strcat(b->offfilename, ".off"); - } - strcat(b->innodefilename, ".node"); - strcat(b->inpolyfilename, ".poly"); - strcat(b->inelefilename, ".ele"); - strcat(b->areafilename, ".area"); -#endif /* not TRILIBRARY */ -} - -/** **/ -/** **/ -/********* User interaction routines begin here *********/ - -/********* Debugging routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* printtriangle() Print out the details of an oriented triangle. */ -/* */ -/* I originally wrote this procedure to simplify debugging; it can be */ -/* called directly from the debugger, and presents information about an */ -/* oriented triangle in digestible form. It's also used when the */ -/* highest level of verbosity (`-VVV') is specified. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void printtriangle(struct mesh *m, struct behavior *b, struct otri *t) -#else /* not ANSI_DECLARATORS */ -void printtriangle(m, b, t) struct mesh *m; -struct behavior *b; -struct otri *t; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri printtri; - struct osub printsh; - vertex printvertex; - - printf("triangle x%lx with orientation %d:\n", (unsigned long)t->tri, - t->orient); - decode(t->tri[0], printtri); - if (printtri.tri == m->dummytri) { - printf(" [0] = Outer space\n"); - } else { - printf(" [0] = x%lx %d\n", (unsigned long)printtri.tri, - printtri.orient); - } - decode(t->tri[1], printtri); - if (printtri.tri == m->dummytri) { - printf(" [1] = Outer space\n"); - } else { - printf(" [1] = x%lx %d\n", (unsigned long)printtri.tri, - printtri.orient); - } - decode(t->tri[2], printtri); - if (printtri.tri == m->dummytri) { - printf(" [2] = Outer space\n"); - } else { - printf(" [2] = x%lx %d\n", (unsigned long)printtri.tri, - printtri.orient); - } - - org(*t, printvertex); - if (printvertex == (vertex)NULL) - printf(" Origin[%d] = NULL\n", (t->orient + 1) % 3 + 3); - else - printf(" Origin[%d] = x%lx (%.12g, %.12g)\n", (t->orient + 1) % 3 + 3, - (unsigned long)printvertex, printvertex[0], printvertex[1]); - dest(*t, printvertex); - if (printvertex == (vertex)NULL) - printf(" Dest [%d] = NULL\n", (t->orient + 2) % 3 + 3); - else - printf(" Dest [%d] = x%lx (%.12g, %.12g)\n", (t->orient + 2) % 3 + 3, - (unsigned long)printvertex, printvertex[0], printvertex[1]); - apex(*t, printvertex); - if (printvertex == (vertex)NULL) - printf(" Apex [%d] = NULL\n", t->orient + 3); - else - printf(" Apex [%d] = x%lx (%.12g, %.12g)\n", t->orient + 3, - (unsigned long)printvertex, printvertex[0], printvertex[1]); - - if (b->usesegments) { - sdecode(t->tri[6], printsh); - if (printsh.ss != m->dummysub) { - printf(" [6] = x%lx %d\n", (unsigned long)printsh.ss, - printsh.ssorient); - } - sdecode(t->tri[7], printsh); - if (printsh.ss != m->dummysub) { - printf(" [7] = x%lx %d\n", (unsigned long)printsh.ss, - printsh.ssorient); - } - sdecode(t->tri[8], printsh); - if (printsh.ss != m->dummysub) { - printf(" [8] = x%lx %d\n", (unsigned long)printsh.ss, - printsh.ssorient); - } - } - - if (b->vararea) { - printf(" Area constraint: %.4g\n", areabound(*t)); - } -} - -/*****************************************************************************/ -/* */ -/* printsubseg() Print out the details of an oriented subsegment. */ -/* */ -/* I originally wrote this procedure to simplify debugging; it can be */ -/* called directly from the debugger, and presents information about an */ -/* oriented subsegment in digestible form. It's also used when the highest */ -/* level of verbosity (`-VVV') is specified. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void printsubseg(struct mesh *m, struct behavior *b, struct osub *s) -#else /* not ANSI_DECLARATORS */ -void printsubseg(m, b, s) struct mesh *m; -struct behavior *b; -struct osub *s; -#endif /* not ANSI_DECLARATORS */ - -{ - struct osub printsh; - struct otri printtri; - vertex printvertex; - - printf("subsegment x%lx with orientation %d and mark %d:\n", - (unsigned long)s->ss, s->ssorient, mark(*s)); - sdecode(s->ss[0], printsh); - if (printsh.ss == m->dummysub) { - printf(" [0] = No subsegment\n"); - } else { - printf(" [0] = x%lx %d\n", (unsigned long)printsh.ss, printsh.ssorient); - } - sdecode(s->ss[1], printsh); - if (printsh.ss == m->dummysub) { - printf(" [1] = No subsegment\n"); - } else { - printf(" [1] = x%lx %d\n", (unsigned long)printsh.ss, printsh.ssorient); - } - - sorg(*s, printvertex); - if (printvertex == (vertex)NULL) - printf(" Origin[%d] = NULL\n", 2 + s->ssorient); - else - printf(" Origin[%d] = x%lx (%.12g, %.12g)\n", 2 + s->ssorient, - (unsigned long)printvertex, printvertex[0], printvertex[1]); - sdest(*s, printvertex); - if (printvertex == (vertex)NULL) - printf(" Dest [%d] = NULL\n", 3 - s->ssorient); - else - printf(" Dest [%d] = x%lx (%.12g, %.12g)\n", 3 - s->ssorient, - (unsigned long)printvertex, printvertex[0], printvertex[1]); - - decode(s->ss[6], printtri); - if (printtri.tri == m->dummytri) { - printf(" [6] = Outer space\n"); - } else { - printf(" [6] = x%lx %d\n", (unsigned long)printtri.tri, - printtri.orient); - } - decode(s->ss[7], printtri); - if (printtri.tri == m->dummytri) { - printf(" [7] = Outer space\n"); - } else { - printf(" [7] = x%lx %d\n", (unsigned long)printtri.tri, - printtri.orient); - } - - segorg(*s, printvertex); - if (printvertex == (vertex)NULL) - printf(" Segment origin[%d] = NULL\n", 4 + s->ssorient); - else - printf(" Segment origin[%d] = x%lx (%.12g, %.12g)\n", 4 + s->ssorient, - (unsigned long)printvertex, printvertex[0], printvertex[1]); - segdest(*s, printvertex); - if (printvertex == (vertex)NULL) - printf(" Segment dest [%d] = NULL\n", 5 - s->ssorient); - else - printf(" Segment dest [%d] = x%lx (%.12g, %.12g)\n", 5 - s->ssorient, - (unsigned long)printvertex, printvertex[0], printvertex[1]); -} - -/** **/ -/** **/ -/********* Debugging routines end here *********/ - -/********* Memory management routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* poolzero() Set all of a pool's fields to zero. */ -/* */ -/* This procedure should never be called on a pool that has any memory */ -/* allocated to it, as that memory would leak. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void poolzero(struct memorypool *pool) -#else /* not ANSI_DECLARATORS */ -void poolzero(pool) struct memorypool *pool; -#endif /* not ANSI_DECLARATORS */ - -{ - pool->firstblock = (VOID **)NULL; - pool->nowblock = (VOID **)NULL; - pool->nextitem = (VOID *)NULL; - pool->deaditemstack = (VOID *)NULL; - pool->pathblock = (VOID **)NULL; - pool->pathitem = (VOID *)NULL; - pool->alignbytes = 0; - pool->itembytes = 0; - pool->itemsperblock = 0; - pool->itemsfirstblock = 0; - pool->items = 0; - pool->maxitems = 0; - pool->unallocateditems = 0; - pool->pathitemsleft = 0; -} - -/*****************************************************************************/ -/* */ -/* poolrestart() Deallocate all items in a pool. */ -/* */ -/* The pool is returned to its starting state, except that no memory is */ -/* freed to the operating system. Rather, the previously allocated blocks */ -/* are ready to be reused. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void poolrestart(struct memorypool *pool) -#else /* not ANSI_DECLARATORS */ -void poolrestart(pool) struct memorypool *pool; -#endif /* not ANSI_DECLARATORS */ - -{ - unsigned long alignptr; - - pool->items = 0; - pool->maxitems = 0; - - /* Set the currently active block. */ - pool->nowblock = pool->firstblock; - /* Find the first item in the pool. Increment by the size of (VOID *). */ - alignptr = (unsigned long)(pool->nowblock + 1); - /* Align the item on an `alignbytes'-byte boundary. */ - pool->nextitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - - (alignptr % (unsigned long)pool->alignbytes)); - /* There are lots of unallocated items left in this block. */ - pool->unallocateditems = pool->itemsfirstblock; - /* The stack of deallocated items is empty. */ - pool->deaditemstack = (VOID *)NULL; -} - -/*****************************************************************************/ -/* */ -/* poolinit() Initialize a pool of memory for allocation of items. */ -/* */ -/* This routine initializes the machinery for allocating items. A `pool' */ -/* is created whose records have size at least `bytecount'. Items will be */ -/* allocated in `itemcount'-item blocks. Each item is assumed to be a */ -/* collection of words, and either pointers or floating-point values are */ -/* assumed to be the "primary" word type. (The "primary" word type is used */ -/* to determine alignment of items.) If `alignment' isn't zero, all items */ -/* will be `alignment'-byte aligned in memory. `alignment' must be either */ -/* a multiple or a factor of the primary word size; powers of two are safe. */ -/* `alignment' is normally used to create a few unused bits at the bottom */ -/* of each item's pointer, in which information may be stored. */ -/* */ -/* Don't change this routine unless you understand it. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void poolinit(struct memorypool *pool, int bytecount, int itemcount, - int firstitemcount, int alignment) -#else /* not ANSI_DECLARATORS */ -void poolinit(pool, bytecount, itemcount, firstitemcount, - alignment) struct memorypool *pool; -int bytecount; -int itemcount; -int firstitemcount; -int alignment; -#endif /* not ANSI_DECLARATORS */ - -{ - /* Find the proper alignment, which must be at least as large as: */ - /* - The parameter `alignment'. */ - /* - sizeof(VOID *), so the stack of dead items can be maintained */ - /* without unaligned accesses. */ - if (alignment > sizeof(VOID *)) { - pool->alignbytes = alignment; - } else { - pool->alignbytes = sizeof(VOID *); - } - pool->itembytes = ((bytecount - 1) / pool->alignbytes + 1) * pool->alignbytes; - pool->itemsperblock = itemcount; - if (firstitemcount == 0) { - pool->itemsfirstblock = itemcount; - } else { - pool->itemsfirstblock = firstitemcount; - } - - /* Allocate a block of items. Space for `itemsfirstblock' items and one */ - /* pointer (to point to the next block) are allocated, as well as space */ - /* to ensure alignment of the items. */ - pool->firstblock = - (VOID **)trimalloc(pool->itemsfirstblock * pool->itembytes + - (int)sizeof(VOID *) + pool->alignbytes); - /* Set the next block pointer to NULL. */ - *(pool->firstblock) = (VOID *)NULL; - poolrestart(pool); -} - -/*****************************************************************************/ -/* */ -/* pooldeinit() Free to the operating system all memory taken by a pool. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void pooldeinit(struct memorypool *pool) -#else /* not ANSI_DECLARATORS */ -void pooldeinit(pool) struct memorypool *pool; -#endif /* not ANSI_DECLARATORS */ - -{ - while (pool->firstblock != (VOID **)NULL) { - pool->nowblock = (VOID **)*(pool->firstblock); - trifree((VOID *)pool->firstblock); - pool->firstblock = pool->nowblock; - } -} - -/*****************************************************************************/ -/* */ -/* poolalloc() Allocate space for an item. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -VOID *poolalloc(struct memorypool *pool) -#else /* not ANSI_DECLARATORS */ -VOID *poolalloc(pool) -struct memorypool *pool; -#endif /* not ANSI_DECLARATORS */ - -{ - VOID *newitem; - VOID **newblock; - unsigned long alignptr; - - /* First check the linked list of dead items. If the list is not */ - /* empty, allocate an item from the list rather than a fresh one. */ - if (pool->deaditemstack != (VOID *)NULL) { - newitem = pool->deaditemstack; /* Take first item in list. */ - pool->deaditemstack = *(VOID **)pool->deaditemstack; - } else { - /* Check if there are any free items left in the current block. */ - if (pool->unallocateditems == 0) { - /* Check if another block must be allocated. */ - if (*(pool->nowblock) == (VOID *)NULL) { - /* Allocate a new block of items, pointed to by the previous block. */ - newblock = (VOID **)trimalloc(pool->itemsperblock * pool->itembytes + - (int)sizeof(VOID *) + pool->alignbytes); - *(pool->nowblock) = (VOID *)newblock; - /* The next block pointer is NULL. */ - *newblock = (VOID *)NULL; - } - - /* Move to the new block. */ - pool->nowblock = (VOID **)*(pool->nowblock); - /* Find the first item in the block. */ - /* Increment by the size of (VOID *). */ - alignptr = (unsigned long)(pool->nowblock + 1); - /* Align the item on an `alignbytes'-byte boundary. */ - pool->nextitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - - (alignptr % (unsigned long)pool->alignbytes)); - /* There are lots of unallocated items left in this block. */ - pool->unallocateditems = pool->itemsperblock; - } - - /* Allocate a new item. */ - newitem = pool->nextitem; - /* Advance `nextitem' pointer to next free item in block. */ - pool->nextitem = (VOID *)((char *)pool->nextitem + pool->itembytes); - pool->unallocateditems--; - pool->maxitems++; - } - pool->items++; - return newitem; -} - -/*****************************************************************************/ -/* */ -/* pooldealloc() Deallocate space for an item. */ -/* */ -/* The deallocated space is stored in a queue for later reuse. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void pooldealloc(struct memorypool *pool, VOID *dyingitem) -#else /* not ANSI_DECLARATORS */ -void pooldealloc(pool, dyingitem) struct memorypool *pool; -VOID *dyingitem; -#endif /* not ANSI_DECLARATORS */ - -{ - /* Push freshly killed item onto stack. */ - *((VOID **)dyingitem) = pool->deaditemstack; - pool->deaditemstack = dyingitem; - pool->items--; -} - -/*****************************************************************************/ -/* */ -/* traversalinit() Prepare to traverse the entire list of items. */ -/* */ -/* This routine is used in conjunction with traverse(). */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void traversalinit(struct memorypool *pool) -#else /* not ANSI_DECLARATORS */ -void traversalinit(pool) struct memorypool *pool; -#endif /* not ANSI_DECLARATORS */ - -{ - unsigned long alignptr; - - /* Begin the traversal in the first block. */ - pool->pathblock = pool->firstblock; - /* Find the first item in the block. Increment by the size of (VOID *). */ - alignptr = (unsigned long)(pool->pathblock + 1); - /* Align with item on an `alignbytes'-byte boundary. */ - pool->pathitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - - (alignptr % (unsigned long)pool->alignbytes)); - /* Set the number of items left in the current block. */ - pool->pathitemsleft = pool->itemsfirstblock; -} - -/*****************************************************************************/ -/* */ -/* traverse() Find the next item in the list. */ -/* */ -/* This routine is used in conjunction with traversalinit(). Be forewarned */ -/* that this routine successively returns all items in the list, including */ -/* deallocated ones on the deaditemqueue. It's up to you to figure out */ -/* which ones are actually dead. Why? I don't want to allocate extra */ -/* space just to demarcate dead items. It can usually be done more */ -/* space-efficiently by a routine that knows something about the structure */ -/* of the item. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -VOID *traverse(struct memorypool *pool) -#else /* not ANSI_DECLARATORS */ -VOID *traverse(pool) -struct memorypool *pool; -#endif /* not ANSI_DECLARATORS */ - -{ - VOID *newitem; - unsigned long alignptr; - - /* Stop upon exhausting the list of items. */ - if (pool->pathitem == pool->nextitem) { - return (VOID *)NULL; - } - - /* Check whether any untraversed items remain in the current block. */ - if (pool->pathitemsleft == 0) { - /* Find the next block. */ - pool->pathblock = (VOID **)*(pool->pathblock); - /* Find the first item in the block. Increment by the size of (VOID *). */ - alignptr = (unsigned long)(pool->pathblock + 1); - /* Align with item on an `alignbytes'-byte boundary. */ - pool->pathitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - - (alignptr % (unsigned long)pool->alignbytes)); - /* Set the number of items left in the current block. */ - pool->pathitemsleft = pool->itemsperblock; - } - - newitem = pool->pathitem; - /* Find the next item in the block. */ - pool->pathitem = (VOID *)((char *)pool->pathitem + pool->itembytes); - pool->pathitemsleft--; - return newitem; -} - -/*****************************************************************************/ -/* */ -/* dummyinit() Initialize the triangle that fills "outer space" and the */ -/* omnipresent subsegment. */ -/* */ -/* The triangle that fills "outer space," called `dummytri', is pointed to */ -/* by every triangle and subsegment on a boundary (be it outer or inner) of */ -/* the triangulation. Also, `dummytri' points to one of the triangles on */ -/* the convex hull (until the holes and concavities are carved), making it */ -/* possible to find a starting triangle for point location. */ -/* */ -/* The omnipresent subsegment, `dummysub', is pointed to by every triangle */ -/* or subsegment that doesn't have a full complement of real subsegments */ -/* to point to. */ -/* */ -/* `dummytri' and `dummysub' are generally required to fulfill only a few */ -/* invariants: their vertices must remain NULL and `dummytri' must always */ -/* be bonded (at offset zero) to some triangle on the convex hull of the */ -/* mesh, via a boundary edge. Otherwise, the connections of `dummytri' and */ -/* `dummysub' may change willy-nilly. This makes it possible to avoid */ -/* writing a good deal of special-case code (in the edge flip, for example) */ -/* for dealing with the boundary of the mesh, places where no subsegment is */ -/* present, and so forth. Other entities are frequently bonded to */ -/* `dummytri' and `dummysub' as if they were real mesh entities, with no */ -/* harm done. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void dummyinit(struct mesh *m, struct behavior *b, int trianglebytes, - int subsegbytes) -#else /* not ANSI_DECLARATORS */ -void dummyinit(m, b, trianglebytes, subsegbytes) struct mesh *m; -struct behavior *b; -int trianglebytes; -int subsegbytes; -#endif /* not ANSI_DECLARATORS */ - -{ - unsigned long alignptr; - - /* Set up `dummytri', the `triangle' that occupies "outer space." */ - m->dummytribase = - (triangle *)trimalloc(trianglebytes + m->triangles.alignbytes); - /* Align `dummytri' on a `triangles.alignbytes'-byte boundary. */ - alignptr = (unsigned long)m->dummytribase; - m->dummytri = - (triangle *)(alignptr + (unsigned long)m->triangles.alignbytes - - (alignptr % (unsigned long)m->triangles.alignbytes)); - /* Initialize the three adjoining triangles to be "outer space." These */ - /* will eventually be changed by various bonding operations, but their */ - /* values don't really matter, as long as they can legally be */ - /* dereferenced. */ - m->dummytri[0] = (triangle)m->dummytri; - m->dummytri[1] = (triangle)m->dummytri; - m->dummytri[2] = (triangle)m->dummytri; - /* Three NULL vertices. */ - m->dummytri[3] = (triangle)NULL; - m->dummytri[4] = (triangle)NULL; - m->dummytri[5] = (triangle)NULL; - - if (b->usesegments) { - /* Set up `dummysub', the omnipresent subsegment pointed to by any */ - /* triangle side or subsegment end that isn't attached to a real */ - /* subsegment. */ - m->dummysubbase = (subseg *)trimalloc(subsegbytes + m->subsegs.alignbytes); - /* Align `dummysub' on a `subsegs.alignbytes'-byte boundary. */ - alignptr = (unsigned long)m->dummysubbase; - m->dummysub = (subseg *)(alignptr + (unsigned long)m->subsegs.alignbytes - - (alignptr % (unsigned long)m->subsegs.alignbytes)); - /* Initialize the two adjoining subsegments to be the omnipresent */ - /* subsegment. These will eventually be changed by various bonding */ - /* operations, but their values don't really matter, as long as they */ - /* can legally be dereferenced. */ - m->dummysub[0] = (subseg)m->dummysub; - m->dummysub[1] = (subseg)m->dummysub; - /* Four NULL vertices. */ - m->dummysub[2] = (subseg)NULL; - m->dummysub[3] = (subseg)NULL; - m->dummysub[4] = (subseg)NULL; - m->dummysub[5] = (subseg)NULL; - /* Initialize the two adjoining triangles to be "outer space." */ - m->dummysub[6] = (subseg)m->dummytri; - m->dummysub[7] = (subseg)m->dummytri; - /* Set the boundary marker to zero. */ - *(int *)(m->dummysub + 8) = 0; - - /* Initialize the three adjoining subsegments of `dummytri' to be */ - /* the omnipresent subsegment. */ - m->dummytri[6] = (triangle)m->dummysub; - m->dummytri[7] = (triangle)m->dummysub; - m->dummytri[8] = (triangle)m->dummysub; - } -} - -/*****************************************************************************/ -/* */ -/* initializevertexpool() Calculate the size of the vertex data structure */ -/* and initialize its memory pool. */ -/* */ -/* This routine also computes the `vertexmarkindex' and `vertex2triindex' */ -/* indices used to find values within each vertex. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void initializevertexpool(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void initializevertexpool(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - int vertexsize; - - /* The index within each vertex at which the boundary marker is found, */ - /* followed by the vertex type. Ensure the vertex marker is aligned to */ - /* a sizeof(int)-byte address. */ - m->vertexmarkindex = - ((m->mesh_dim + m->nextras) * sizeof(REAL) + sizeof(int) - 1) / - sizeof(int); - vertexsize = (m->vertexmarkindex + 2) * sizeof(int); - if (b->poly) { - /* The index within each vertex at which a triangle pointer is found. */ - /* Ensure the pointer is aligned to a sizeof(triangle)-byte address. */ - m->vertex2triindex = (vertexsize + sizeof(triangle) - 1) / sizeof(triangle); - vertexsize = (m->vertex2triindex + 1) * sizeof(triangle); - } - - /* Initialize the pool of vertices. */ - poolinit(&m->vertices, vertexsize, VERTEXPERBLOCK, - m->invertices > VERTEXPERBLOCK ? m->invertices : VERTEXPERBLOCK, - sizeof(REAL)); -} - -/*****************************************************************************/ -/* */ -/* initializetrisubpools() Calculate the sizes of the triangle and */ -/* subsegment data structures and initialize */ -/* their memory pools. */ -/* */ -/* This routine also computes the `highorderindex', `elemattribindex', and */ -/* `areaboundindex' indices used to find values within each triangle. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void initializetrisubpools(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void initializetrisubpools(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - int trisize; - - /* The index within each triangle at which the extra nodes (above three) */ - /* associated with high order elements are found. There are three */ - /* pointers to other triangles, three pointers to corners, and possibly */ - /* three pointers to subsegments before the extra nodes. */ - m->highorderindex = 6 + (b->usesegments * 3); - /* The number of bytes occupied by a triangle. */ - trisize = ((b->order + 1) * (b->order + 2) / 2 + (m->highorderindex - 3)) * - sizeof(triangle); - /* The index within each triangle at which its attributes are found, */ - /* where the index is measured in REALs. */ - m->elemattribindex = (trisize + sizeof(REAL) - 1) / sizeof(REAL); - /* The index within each triangle at which the maximum area constraint */ - /* is found, where the index is measured in REALs. Note that if the */ - /* `regionattrib' flag is set, an additional attribute will be added. */ - m->areaboundindex = m->elemattribindex + m->eextras + b->regionattrib; - /* If triangle attributes or an area bound are needed, increase the number */ - /* of bytes occupied by a triangle. */ - if (b->vararea) { - trisize = (m->areaboundindex + 1) * sizeof(REAL); - } else if (m->eextras + b->regionattrib > 0) { - trisize = m->areaboundindex * sizeof(REAL); - } - /* If a Voronoi diagram or triangle neighbor graph is requested, make */ - /* sure there's room to store an integer index in each triangle. This */ - /* integer index can occupy the same space as the subsegment pointers */ - /* or attributes or area constraint or extra nodes. */ - if ((b->voronoi || b->neighbors) && - (trisize < 6 * sizeof(triangle) + sizeof(int))) { - trisize = 6 * sizeof(triangle) + sizeof(int); - } - - /* Having determined the memory size of a triangle, initialize the pool. */ - poolinit(&m->triangles, trisize, TRIPERBLOCK, - (2 * m->invertices - 2) > TRIPERBLOCK ? (2 * m->invertices - 2) - : TRIPERBLOCK, - 4); - - if (b->usesegments) { - /* Initialize the pool of subsegments. Take into account all eight */ - /* pointers and one boundary marker. */ - poolinit(&m->subsegs, 8 * sizeof(triangle) + sizeof(int), SUBSEGPERBLOCK, - SUBSEGPERBLOCK, 4); - - /* Initialize the "outer space" triangle and omnipresent subsegment. */ - dummyinit(m, b, m->triangles.itembytes, m->subsegs.itembytes); - } else { - /* Initialize the "outer space" triangle. */ - dummyinit(m, b, m->triangles.itembytes, 0); - } -} - -/*****************************************************************************/ -/* */ -/* triangledealloc() Deallocate space for a triangle, marking it dead. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void triangledealloc(struct mesh *m, triangle *dyingtriangle) -#else /* not ANSI_DECLARATORS */ -void triangledealloc(m, dyingtriangle) struct mesh *m; -triangle *dyingtriangle; -#endif /* not ANSI_DECLARATORS */ - -{ - /* Mark the triangle as dead. This makes it possible to detect dead */ - /* triangles when traversing the list of all triangles. */ - killtri(dyingtriangle); - pooldealloc(&m->triangles, (VOID *)dyingtriangle); -} - -/*****************************************************************************/ -/* */ -/* triangletraverse() Traverse the triangles, skipping dead ones. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -triangle *triangletraverse(struct mesh *m) -#else /* not ANSI_DECLARATORS */ -triangle *triangletraverse(m) -struct mesh *m; -#endif /* not ANSI_DECLARATORS */ - -{ - triangle *newtriangle; - - do { - newtriangle = (triangle *)traverse(&m->triangles); - if (newtriangle == (triangle *)NULL) { - return (triangle *)NULL; - } - } while (deadtri(newtriangle)); /* Skip dead ones. */ - return newtriangle; -} - -/*****************************************************************************/ -/* */ -/* subsegdealloc() Deallocate space for a subsegment, marking it dead. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void subsegdealloc(struct mesh *m, subseg *dyingsubseg) -#else /* not ANSI_DECLARATORS */ -void subsegdealloc(m, dyingsubseg) struct mesh *m; -subseg *dyingsubseg; -#endif /* not ANSI_DECLARATORS */ - -{ - /* Mark the subsegment as dead. This makes it possible to detect dead */ - /* subsegments when traversing the list of all subsegments. */ - killsubseg(dyingsubseg); - pooldealloc(&m->subsegs, (VOID *)dyingsubseg); -} - -/*****************************************************************************/ -/* */ -/* subsegtraverse() Traverse the subsegments, skipping dead ones. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -subseg *subsegtraverse(struct mesh *m) -#else /* not ANSI_DECLARATORS */ -subseg *subsegtraverse(m) -struct mesh *m; -#endif /* not ANSI_DECLARATORS */ - -{ - subseg *newsubseg; - - do { - newsubseg = (subseg *)traverse(&m->subsegs); - if (newsubseg == (subseg *)NULL) { - return (subseg *)NULL; - } - } while (deadsubseg(newsubseg)); /* Skip dead ones. */ - return newsubseg; -} - -/*****************************************************************************/ -/* */ -/* vertexdealloc() Deallocate space for a vertex, marking it dead. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void vertexdealloc(struct mesh *m, vertex dyingvertex) -#else /* not ANSI_DECLARATORS */ -void vertexdealloc(m, dyingvertex) struct mesh *m; -vertex dyingvertex; -#endif /* not ANSI_DECLARATORS */ - -{ - /* Mark the vertex as dead. This makes it possible to detect dead */ - /* vertices when traversing the list of all vertices. */ - setvertextype(dyingvertex, DEADVERTEX); - pooldealloc(&m->vertices, (VOID *)dyingvertex); -} - -/*****************************************************************************/ -/* */ -/* vertextraverse() Traverse the vertices, skipping dead ones. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -vertex vertextraverse(struct mesh *m) -#else /* not ANSI_DECLARATORS */ -vertex vertextraverse(m) -struct mesh *m; -#endif /* not ANSI_DECLARATORS */ - -{ - vertex newvertex; - - do { - newvertex = (vertex)traverse(&m->vertices); - if (newvertex == (vertex)NULL) { - return (vertex)NULL; - } - } while (vertextype(newvertex) == DEADVERTEX); /* Skip dead ones. */ - return newvertex; -} - -/*****************************************************************************/ -/* */ -/* badsubsegdealloc() Deallocate space for a bad subsegment, marking it */ -/* dead. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void badsubsegdealloc(struct mesh *m, struct badsubseg *dyingseg) -#else /* not ANSI_DECLARATORS */ -void badsubsegdealloc(m, dyingseg) struct mesh *m; -struct badsubseg *dyingseg; -#endif /* not ANSI_DECLARATORS */ - -{ - /* Set subsegment's origin to NULL. This makes it possible to detect dead */ - /* badsubsegs when traversing the list of all badsubsegs . */ - dyingseg->subsegorg = (vertex)NULL; - pooldealloc(&m->badsubsegs, (VOID *)dyingseg); -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* badsubsegtraverse() Traverse the bad subsegments, skipping dead ones. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -struct badsubseg *badsubsegtraverse(struct mesh *m) -#else /* not ANSI_DECLARATORS */ -struct badsubseg *badsubsegtraverse(m) -struct mesh *m; -#endif /* not ANSI_DECLARATORS */ - -{ - struct badsubseg *newseg; - - do { - newseg = (struct badsubseg *)traverse(&m->badsubsegs); - if (newseg == (struct badsubseg *)NULL) { - return (struct badsubseg *)NULL; - } - } while (newseg->subsegorg == (vertex)NULL); /* Skip dead ones. */ - return newseg; -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* getvertex() Get a specific vertex, by number, from the list. */ -/* */ -/* The first vertex is number 'firstnumber'. */ -/* */ -/* Note that this takes O(n) time (with a small constant, if VERTEXPERBLOCK */ -/* is large). I don't care to take the trouble to make it work in constant */ -/* time. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -vertex getvertex(struct mesh *m, struct behavior *b, int number) -#else /* not ANSI_DECLARATORS */ -vertex getvertex(m, b, number) -struct mesh *m; -struct behavior *b; -int number; -#endif /* not ANSI_DECLARATORS */ - -{ - VOID **getblock; - char *foundvertex; - unsigned long alignptr; - int current; - - getblock = m->vertices.firstblock; - current = b->firstnumber; - - /* Find the right block. */ - if (current + m->vertices.itemsfirstblock <= number) { - getblock = (VOID **)*getblock; - current += m->vertices.itemsfirstblock; - while (current + m->vertices.itemsperblock <= number) { - getblock = (VOID **)*getblock; - current += m->vertices.itemsperblock; - } - } - - /* Now find the right vertex. */ - alignptr = (unsigned long)(getblock + 1); - foundvertex = (char *)(alignptr + (unsigned long)m->vertices.alignbytes - - (alignptr % (unsigned long)m->vertices.alignbytes)); - return (vertex)(foundvertex + m->vertices.itembytes * (number - current)); -} - -/*****************************************************************************/ -/* */ -/* triangledeinit() Free all remaining allocated memory. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void triangledeinit(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void triangledeinit(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - pooldeinit(&m->triangles); - trifree((VOID *)m->dummytribase); - if (b->usesegments) { - pooldeinit(&m->subsegs); - trifree((VOID *)m->dummysubbase); - } - pooldeinit(&m->vertices); -#ifndef CDT_ONLY - if (b->quality) { - pooldeinit(&m->badsubsegs); - if ((b->minangle > 0.0) || b->vararea || b->fixedarea || b->usertest) { - pooldeinit(&m->badtriangles); - pooldeinit(&m->flipstackers); - } - } -#endif /* not CDT_ONLY */ -} - -/** **/ -/** **/ -/********* Memory management routines end here *********/ - -/********* Constructors begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* maketriangle() Create a new triangle with orientation zero. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void maketriangle(struct mesh *m, struct behavior *b, struct otri *newotri) -#else /* not ANSI_DECLARATORS */ -void maketriangle(m, b, newotri) struct mesh *m; -struct behavior *b; -struct otri *newotri; -#endif /* not ANSI_DECLARATORS */ - -{ - int i; - - newotri->tri = (triangle *)poolalloc(&m->triangles); - /* Initialize the three adjoining triangles to be "outer space". */ - newotri->tri[0] = (triangle)m->dummytri; - newotri->tri[1] = (triangle)m->dummytri; - newotri->tri[2] = (triangle)m->dummytri; - /* Three NULL vertices. */ - newotri->tri[3] = (triangle)NULL; - newotri->tri[4] = (triangle)NULL; - newotri->tri[5] = (triangle)NULL; - if (b->usesegments) { - /* Initialize the three adjoining subsegments to be the omnipresent */ - /* subsegment. */ - newotri->tri[6] = (triangle)m->dummysub; - newotri->tri[7] = (triangle)m->dummysub; - newotri->tri[8] = (triangle)m->dummysub; - } - for (i = 0; i < m->eextras; i++) { - setelemattribute(*newotri, i, 0.0); - } - if (b->vararea) { - setareabound(*newotri, -1.0); - } - - newotri->orient = 0; -} - -/*****************************************************************************/ -/* */ -/* makesubseg() Create a new subsegment with orientation zero. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void makesubseg(struct mesh *m, struct osub *newsubseg) -#else /* not ANSI_DECLARATORS */ -void makesubseg(m, newsubseg) struct mesh *m; -struct osub *newsubseg; -#endif /* not ANSI_DECLARATORS */ - -{ - newsubseg->ss = (subseg *)poolalloc(&m->subsegs); - /* Initialize the two adjoining subsegments to be the omnipresent */ - /* subsegment. */ - newsubseg->ss[0] = (subseg)m->dummysub; - newsubseg->ss[1] = (subseg)m->dummysub; - /* Four NULL vertices. */ - newsubseg->ss[2] = (subseg)NULL; - newsubseg->ss[3] = (subseg)NULL; - newsubseg->ss[4] = (subseg)NULL; - newsubseg->ss[5] = (subseg)NULL; - /* Initialize the two adjoining triangles to be "outer space." */ - newsubseg->ss[6] = (subseg)m->dummytri; - newsubseg->ss[7] = (subseg)m->dummytri; - /* Set the boundary marker to zero. */ - setmark(*newsubseg, 0); - - newsubseg->ssorient = 0; -} - -/** **/ -/** **/ -/********* Constructors end here *********/ - -/********* Geometric primitives begin here *********/ -/** **/ -/** **/ - -/* The adaptive exact arithmetic geometric predicates implemented herein are */ -/* described in detail in my paper, "Adaptive Precision Floating-Point */ -/* Arithmetic and Fast Robust Geometric Predicates." See the header for a */ -/* full citation. */ - -/* Which of the following two methods of finding the absolute values is */ -/* fastest is compiler-dependent. A few compilers can inline and optimize */ -/* the fabs() call; but most will incur the overhead of a function call, */ -/* which is disastrously slow. A faster way on IEEE machines might be to */ -/* mask the appropriate bit, but that's difficult to do in C without */ -/* forcing the value to be stored to memory (rather than be kept in the */ -/* register to which the optimizer assigned it). */ - -#define Absolute(a) ((a) >= 0.0 ? (a) : -(a)) -/* #define Absolute(a) fabs(a) */ - -/* Many of the operations are broken up into two pieces, a main part that */ -/* performs an approximate operation, and a "tail" that computes the */ -/* roundoff error of that operation. */ -/* */ -/* The operations Fast_Two_Sum(), Fast_Two_Diff(), Two_Sum(), Two_Diff(), */ -/* Split(), and Two_Product() are all implemented as described in the */ -/* reference. Each of these macros requires certain variables to be */ -/* defined in the calling routine. The variables `bvirt', `c', `abig', */ -/* `_i', `_j', `_k', `_l', `_m', and `_n' are declared `INEXACT' because */ -/* they store the result of an operation that may incur roundoff error. */ -/* The input parameter `x' (or the highest numbered `x_' parameter) must */ -/* also be declared `INEXACT'. */ - -#define Fast_Two_Sum_Tail(a, b, x, y) \ - bvirt = x - a; \ - y = b - bvirt - -#define Fast_Two_Sum(a, b, x, y) \ - x = (REAL)(a + b); \ - Fast_Two_Sum_Tail(a, b, x, y) - -#define Two_Sum_Tail(a, b, x, y) \ - bvirt = (REAL)(x - a); \ - avirt = x - bvirt; \ - bround = b - bvirt; \ - around = a - avirt; \ - y = around + bround - -#define Two_Sum(a, b, x, y) \ - x = (REAL)(a + b); \ - Two_Sum_Tail(a, b, x, y) - -#define Two_Diff_Tail(a, b, x, y) \ - bvirt = (REAL)(a - x); \ - avirt = x + bvirt; \ - bround = bvirt - b; \ - around = a - avirt; \ - y = around + bround - -#define Two_Diff(a, b, x, y) \ - x = (REAL)(a - b); \ - Two_Diff_Tail(a, b, x, y) - -#define Split(a, ahi, alo) \ - c = (REAL)(splitter * a); \ - abig = (REAL)(c - a); \ - ahi = c - abig; \ - alo = a - ahi - -#define Two_Product_Tail(a, b, x, y) \ - Split(a, ahi, alo); \ - Split(b, bhi, blo); \ - err1 = x - (ahi * bhi); \ - err2 = err1 - (alo * bhi); \ - err3 = err2 - (ahi * blo); \ - y = (alo * blo) - err3 - -#define Two_Product(a, b, x, y) \ - x = (REAL)(a * b); \ - Two_Product_Tail(a, b, x, y) - -/* Two_Product_Presplit() is Two_Product() where one of the inputs has */ -/* already been split. Avoids redundant splitting. */ - -#define Two_Product_Presplit(a, b, bhi, blo, x, y) \ - x = (REAL)(a * b); \ - Split(a, ahi, alo); \ - err1 = x - (ahi * bhi); \ - err2 = err1 - (alo * bhi); \ - err3 = err2 - (ahi * blo); \ - y = (alo * blo) - err3 - -/* Square() can be done more quickly than Two_Product(). */ - -#define Square_Tail(a, x, y) \ - Split(a, ahi, alo); \ - err1 = x - (ahi * ahi); \ - err3 = err1 - ((ahi + ahi) * alo); \ - y = (alo * alo) - err3 - -#define Square(a, x, y) \ - x = (REAL)(a * a); \ - Square_Tail(a, x, y) - -/* Macros for summing expansions of various fixed lengths. These are all */ -/* unrolled versions of Expansion_Sum(). */ - -#define Two_One_Sum(a1, a0, b, x2, x1, x0) \ - Two_Sum(a0, b, _i, x0); \ - Two_Sum(a1, _i, x2, x1) - -#define Two_One_Diff(a1, a0, b, x2, x1, x0) \ - Two_Diff(a0, b, _i, x0); \ - Two_Sum(a1, _i, x2, x1) - -#define Two_Two_Sum(a1, a0, b1, b0, x3, x2, x1, x0) \ - Two_One_Sum(a1, a0, b0, _j, _0, x0); \ - Two_One_Sum(_j, _0, b1, x3, x2, x1) - -#define Two_Two_Diff(a1, a0, b1, b0, x3, x2, x1, x0) \ - Two_One_Diff(a1, a0, b0, _j, _0, x0); \ - Two_One_Diff(_j, _0, b1, x3, x2, x1) - -/* Macro for multiplying a two-component expansion by a single component. */ - -#define Two_One_Product(a1, a0, b, x3, x2, x1, x0) \ - Split(b, bhi, blo); \ - Two_Product_Presplit(a0, b, bhi, blo, _i, x0); \ - Two_Product_Presplit(a1, b, bhi, blo, _j, _0); \ - Two_Sum(_i, _0, _k, x1); \ - Fast_Two_Sum(_j, _k, x3, x2) - -/*****************************************************************************/ -/* */ -/* exactinit() Initialize the variables used for exact arithmetic. */ -/* */ -/* `epsilon' is the largest power of two such that 1.0 + epsilon = 1.0 in */ -/* floating-point arithmetic. `epsilon' bounds the relative roundoff */ -/* error. It is used for floating-point error analysis. */ -/* */ -/* `splitter' is used to split floating-point numbers into two half- */ -/* length significands for exact multiplication. */ -/* */ -/* I imagine that a highly optimizing compiler might be too smart for its */ -/* own good, and somehow cause this routine to fail, if it pretends that */ -/* floating-point arithmetic is too much like real arithmetic. */ -/* */ -/* Don't change this routine unless you fully understand it. */ -/* */ -/*****************************************************************************/ - -void exactinit() { - REAL half; - REAL check, lastcheck; - int every_other; -#ifdef LINUX - int cword; -#endif /* LINUX */ - -#ifdef CPU86 -#ifdef SINGLE - _control87(_PC_24, _MCW_PC); /* Set FPU control word for single precision. */ -#else /* not SINGLE */ - _control87(_PC_53, _MCW_PC); /* Set FPU control word for double precision. */ -#endif /* not SINGLE */ -#endif /* CPU86 */ -#ifdef LINUX -#ifdef SINGLE - /* cword = 4223; */ - cword = 4210; /* set FPU control word for single precision */ -#else /* not SINGLE */ - /* cword = 4735; */ - cword = 4722; /* set FPU control word for double precision */ -#endif /* not SINGLE */ - _FPU_SETCW(cword); -#endif /* LINUX */ - - every_other = 1; - half = 0.5; - epsilon = 1.0; - splitter = 1.0; - check = 1.0; - /* Repeatedly divide `epsilon' by two until it is too small to add to */ - /* one without causing roundoff. (Also check if the sum is equal to */ - /* the previous sum, for machines that round up instead of using exact */ - /* rounding. Not that these routines will work on such machines.) */ - do { - lastcheck = check; - epsilon *= half; - if (every_other) { - splitter *= 2.0; - } - every_other = !every_other; - check = 1.0 + epsilon; - } while ((check != 1.0) && (check != lastcheck)); - splitter += 1.0; - /* Error bounds for orientation and incircle tests. */ - resulterrbound = (3.0 + 8.0 * epsilon) * epsilon; - ccwerrboundA = (3.0 + 16.0 * epsilon) * epsilon; - ccwerrboundB = (2.0 + 12.0 * epsilon) * epsilon; - ccwerrboundC = (9.0 + 64.0 * epsilon) * epsilon * epsilon; - iccerrboundA = (10.0 + 96.0 * epsilon) * epsilon; - iccerrboundB = (4.0 + 48.0 * epsilon) * epsilon; - iccerrboundC = (44.0 + 576.0 * epsilon) * epsilon * epsilon; - o3derrboundA = (7.0 + 56.0 * epsilon) * epsilon; - o3derrboundB = (3.0 + 28.0 * epsilon) * epsilon; - o3derrboundC = (26.0 + 288.0 * epsilon) * epsilon * epsilon; -} - -/*****************************************************************************/ -/* */ -/* fast_expansion_sum_zeroelim() Sum two expansions, eliminating zero */ -/* components from the output expansion. */ -/* */ -/* Sets h = e + f. See my Robust Predicates paper for details. */ -/* */ -/* If round-to-even is used (as with IEEE 754), maintains the strongly */ -/* nonoverlapping property. (That is, if e is strongly nonoverlapping, h */ -/* will be also.) Does NOT maintain the nonoverlapping or nonadjacent */ -/* properties. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -int fast_expansion_sum_zeroelim(int elen, REAL *e, int flen, REAL *f, REAL *h) -#else /* not ANSI_DECLARATORS */ -int fast_expansion_sum_zeroelim(elen, e, flen, f, h) /* h cannot be e or f. */ -int elen; -REAL *e; -int flen; -REAL *f; -REAL *h; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL Q; - INEXACT REAL Qnew; - INEXACT REAL hh; - INEXACT REAL bvirt; - REAL avirt, bround, around; - int eindex, findex, hindex; - REAL enow, fnow; - - enow = e[0]; - fnow = f[0]; - eindex = findex = 0; - if ((fnow > enow) == (fnow > -enow)) { - Q = enow; - enow = e[++eindex]; - } else { - Q = fnow; - fnow = f[++findex]; - } - hindex = 0; - if ((eindex < elen) && (findex < flen)) { - if ((fnow > enow) == (fnow > -enow)) { - Fast_Two_Sum(enow, Q, Qnew, hh); - enow = e[++eindex]; - } else { - Fast_Two_Sum(fnow, Q, Qnew, hh); - fnow = f[++findex]; - } - Q = Qnew; - if (hh != 0.0) { - h[hindex++] = hh; - } - while ((eindex < elen) && (findex < flen)) { - if ((fnow > enow) == (fnow > -enow)) { - Two_Sum(Q, enow, Qnew, hh); - enow = e[++eindex]; - } else { - Two_Sum(Q, fnow, Qnew, hh); - fnow = f[++findex]; - } - Q = Qnew; - if (hh != 0.0) { - h[hindex++] = hh; - } - } - } - while (eindex < elen) { - Two_Sum(Q, enow, Qnew, hh); - enow = e[++eindex]; - Q = Qnew; - if (hh != 0.0) { - h[hindex++] = hh; - } - } - while (findex < flen) { - Two_Sum(Q, fnow, Qnew, hh); - fnow = f[++findex]; - Q = Qnew; - if (hh != 0.0) { - h[hindex++] = hh; - } - } - if ((Q != 0.0) || (hindex == 0)) { - h[hindex++] = Q; - } - return hindex; -} - -/*****************************************************************************/ -/* */ -/* scale_expansion_zeroelim() Multiply an expansion by a scalar, */ -/* eliminating zero components from the */ -/* output expansion. */ -/* */ -/* Sets h = be. See my Robust Predicates paper for details. */ -/* */ -/* Maintains the nonoverlapping property. If round-to-even is used (as */ -/* with IEEE 754), maintains the strongly nonoverlapping and nonadjacent */ -/* properties as well. (That is, if e has one of these properties, so */ -/* will h.) */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -int scale_expansion_zeroelim(int elen, REAL *e, REAL b, REAL *h) -#else /* not ANSI_DECLARATORS */ -int scale_expansion_zeroelim(elen, e, b, h) /* e and h cannot be the same. */ -int elen; -REAL *e; -REAL b; -REAL *h; -#endif /* not ANSI_DECLARATORS */ - -{ - INEXACT REAL Q, sum; - REAL hh; - INEXACT REAL product1; - REAL product0; - int eindex, hindex; - REAL enow; - INEXACT REAL bvirt; - REAL avirt, bround, around; - INEXACT REAL c; - INEXACT REAL abig; - REAL ahi, alo, bhi, blo; - REAL err1, err2, err3; - - Split(b, bhi, blo); - Two_Product_Presplit(e[0], b, bhi, blo, Q, hh); - hindex = 0; - if (hh != 0) { - h[hindex++] = hh; - } - for (eindex = 1; eindex < elen; eindex++) { - enow = e[eindex]; - Two_Product_Presplit(enow, b, bhi, blo, product1, product0); - Two_Sum(Q, product0, sum, hh); - if (hh != 0) { - h[hindex++] = hh; - } - Fast_Two_Sum(product1, sum, Q, hh); - if (hh != 0) { - h[hindex++] = hh; - } - } - if ((Q != 0.0) || (hindex == 0)) { - h[hindex++] = Q; - } - return hindex; -} - -/*****************************************************************************/ -/* */ -/* estimate() Produce a one-word estimate of an expansion's value. */ -/* */ -/* See my Robust Predicates paper for details. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -REAL estimate(int elen, REAL *e) -#else /* not ANSI_DECLARATORS */ -REAL estimate(elen, e) -int elen; -REAL *e; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL Q; - int eindex; - - Q = e[0]; - for (eindex = 1; eindex < elen; eindex++) { - Q += e[eindex]; - } - return Q; -} - -/*****************************************************************************/ -/* */ -/* counterclockwise() Return a positive value if the points pa, pb, and */ -/* pc occur in counterclockwise order; a negative */ -/* value if they occur in clockwise order; and zero */ -/* if they are collinear. The result is also a rough */ -/* approximation of twice the signed area of the */ -/* triangle defined by the three points. */ -/* */ -/* Uses exact arithmetic if necessary to ensure a correct answer. The */ -/* result returned is the determinant of a matrix. This determinant is */ -/* computed adaptively, in the sense that exact arithmetic is used only to */ -/* the degree it is needed to ensure that the returned value has the */ -/* correct sign. Hence, this function is usually quite fast, but will run */ -/* more slowly when the input points are collinear or nearly so. */ -/* */ -/* See my Robust Predicates paper for details. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -REAL counterclockwiseadapt(vertex pa, vertex pb, vertex pc, REAL detsum) -#else /* not ANSI_DECLARATORS */ -REAL counterclockwiseadapt(pa, pb, pc, detsum) -vertex pa; -vertex pb; -vertex pc; -REAL detsum; -#endif /* not ANSI_DECLARATORS */ - -{ - INEXACT REAL acx, acy, bcx, bcy; - REAL acxtail, acytail, bcxtail, bcytail; - INEXACT REAL detleft, detright; - REAL detlefttail, detrighttail; - REAL det, errbound; - REAL B[4], C1[8], C2[12], D[16]; - INEXACT REAL B3; - int C1length, C2length, Dlength; - REAL u[4]; - INEXACT REAL u3; - INEXACT REAL s1, t1; - REAL s0, t0; - - INEXACT REAL bvirt; - REAL avirt, bround, around; - INEXACT REAL c; - INEXACT REAL abig; - REAL ahi, alo, bhi, blo; - REAL err1, err2, err3; - INEXACT REAL _i, _j; - REAL _0; - - acx = (REAL)(pa[0] - pc[0]); - bcx = (REAL)(pb[0] - pc[0]); - acy = (REAL)(pa[1] - pc[1]); - bcy = (REAL)(pb[1] - pc[1]); - - Two_Product(acx, bcy, detleft, detlefttail); - Two_Product(acy, bcx, detright, detrighttail); - - Two_Two_Diff(detleft, detlefttail, detright, detrighttail, B3, B[2], B[1], - B[0]); - B[3] = B3; - - det = estimate(4, B); - errbound = ccwerrboundB * detsum; - if ((det >= errbound) || (-det >= errbound)) { - return det; - } - - Two_Diff_Tail(pa[0], pc[0], acx, acxtail); - Two_Diff_Tail(pb[0], pc[0], bcx, bcxtail); - Two_Diff_Tail(pa[1], pc[1], acy, acytail); - Two_Diff_Tail(pb[1], pc[1], bcy, bcytail); - - if ((acxtail == 0.0) && (acytail == 0.0) && (bcxtail == 0.0) && - (bcytail == 0.0)) { - return det; - } - - errbound = ccwerrboundC * detsum + resulterrbound * Absolute(det); - det += (acx * bcytail + bcy * acxtail) - (acy * bcxtail + bcx * acytail); - if ((det >= errbound) || (-det >= errbound)) { - return det; - } - - Two_Product(acxtail, bcy, s1, s0); - Two_Product(acytail, bcx, t1, t0); - Two_Two_Diff(s1, s0, t1, t0, u3, u[2], u[1], u[0]); - u[3] = u3; - C1length = fast_expansion_sum_zeroelim(4, B, 4, u, C1); - - Two_Product(acx, bcytail, s1, s0); - Two_Product(acy, bcxtail, t1, t0); - Two_Two_Diff(s1, s0, t1, t0, u3, u[2], u[1], u[0]); - u[3] = u3; - C2length = fast_expansion_sum_zeroelim(C1length, C1, 4, u, C2); - - Two_Product(acxtail, bcytail, s1, s0); - Two_Product(acytail, bcxtail, t1, t0); - Two_Two_Diff(s1, s0, t1, t0, u3, u[2], u[1], u[0]); - u[3] = u3; - Dlength = fast_expansion_sum_zeroelim(C2length, C2, 4, u, D); - - return (D[Dlength - 1]); -} - -#ifdef ANSI_DECLARATORS -REAL counterclockwise(struct mesh *m, struct behavior *b, vertex pa, vertex pb, - vertex pc) -#else /* not ANSI_DECLARATORS */ -REAL counterclockwise(m, b, pa, pb, pc) -struct mesh *m; -struct behavior *b; -vertex pa; -vertex pb; -vertex pc; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL detleft, detright, det; - REAL detsum, errbound; - - m->counterclockcount++; - - detleft = (pa[0] - pc[0]) * (pb[1] - pc[1]); - detright = (pa[1] - pc[1]) * (pb[0] - pc[0]); - det = detleft - detright; - - if (b->noexact) { - return det; - } - - if (detleft > 0.0) { - if (detright <= 0.0) { - return det; - } else { - detsum = detleft + detright; - } - } else if (detleft < 0.0) { - if (detright >= 0.0) { - return det; - } else { - detsum = -detleft - detright; - } - } else { - return det; - } - - errbound = ccwerrboundA * detsum; - if ((det >= errbound) || (-det >= errbound)) { - return det; - } - - return counterclockwiseadapt(pa, pb, pc, detsum); -} - -/*****************************************************************************/ -/* */ -/* incircle() Return a positive value if the point pd lies inside the */ -/* circle passing through pa, pb, and pc; a negative value if */ -/* it lies outside; and zero if the four points are cocircular.*/ -/* The points pa, pb, and pc must be in counterclockwise */ -/* order, or the sign of the result will be reversed. */ -/* */ -/* Uses exact arithmetic if necessary to ensure a correct answer. The */ -/* result returned is the determinant of a matrix. This determinant is */ -/* computed adaptively, in the sense that exact arithmetic is used only to */ -/* the degree it is needed to ensure that the returned value has the */ -/* correct sign. Hence, this function is usually quite fast, but will run */ -/* more slowly when the input points are cocircular or nearly so. */ -/* */ -/* See my Robust Predicates paper for details. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -REAL incircleadapt(vertex pa, vertex pb, vertex pc, vertex pd, REAL permanent) -#else /* not ANSI_DECLARATORS */ -REAL incircleadapt(pa, pb, pc, pd, permanent) -vertex pa; -vertex pb; -vertex pc; -vertex pd; -REAL permanent; -#endif /* not ANSI_DECLARATORS */ - -{ - INEXACT REAL adx, bdx, cdx, ady, bdy, cdy; - REAL det, errbound; - - INEXACT REAL bdxcdy1, cdxbdy1, cdxady1, adxcdy1, adxbdy1, bdxady1; - REAL bdxcdy0, cdxbdy0, cdxady0, adxcdy0, adxbdy0, bdxady0; - REAL bc[4], ca[4], ab[4]; - INEXACT REAL bc3, ca3, ab3; - REAL axbc[8], axxbc[16], aybc[8], ayybc[16], adet[32]; - int axbclen, axxbclen, aybclen, ayybclen, alen; - REAL bxca[8], bxxca[16], byca[8], byyca[16], bdet[32]; - int bxcalen, bxxcalen, bycalen, byycalen, blen; - REAL cxab[8], cxxab[16], cyab[8], cyyab[16], cdet[32]; - int cxablen, cxxablen, cyablen, cyyablen, clen; - REAL abdet[64]; - int ablen; - REAL fin1[1152], fin2[1152]; - REAL *finnow, *finother, *finswap; - int finlength; - - REAL adxtail, bdxtail, cdxtail, adytail, bdytail, cdytail; - INEXACT REAL adxadx1, adyady1, bdxbdx1, bdybdy1, cdxcdx1, cdycdy1; - REAL adxadx0, adyady0, bdxbdx0, bdybdy0, cdxcdx0, cdycdy0; - REAL aa[4], bb[4], cc[4]; - INEXACT REAL aa3, bb3, cc3; - INEXACT REAL ti1, tj1; - REAL ti0, tj0; - REAL u[4], v[4]; - INEXACT REAL u3, v3; - REAL temp8[8], temp16a[16], temp16b[16], temp16c[16]; - REAL temp32a[32], temp32b[32], temp48[48], temp64[64]; - int temp8len, temp16alen, temp16blen, temp16clen; - int temp32alen, temp32blen, temp48len, temp64len; - REAL axtbb[8], axtcc[8], aytbb[8], aytcc[8]; - int axtbblen, axtcclen, aytbblen, aytcclen; - REAL bxtaa[8], bxtcc[8], bytaa[8], bytcc[8]; - int bxtaalen, bxtcclen, bytaalen, bytcclen; - REAL cxtaa[8], cxtbb[8], cytaa[8], cytbb[8]; - int cxtaalen, cxtbblen, cytaalen, cytbblen; - REAL axtbc[8], aytbc[8], bxtca[8], bytca[8], cxtab[8], cytab[8]; - int axtbclen, aytbclen, bxtcalen, bytcalen, cxtablen, cytablen; - REAL axtbct[16], aytbct[16], bxtcat[16], bytcat[16], cxtabt[16], cytabt[16]; - int axtbctlen, aytbctlen, bxtcatlen, bytcatlen, cxtabtlen, cytabtlen; - REAL axtbctt[8], aytbctt[8], bxtcatt[8]; - REAL bytcatt[8], cxtabtt[8], cytabtt[8]; - int axtbcttlen, aytbcttlen, bxtcattlen, bytcattlen, cxtabttlen, cytabttlen; - REAL abt[8], bct[8], cat[8]; - int abtlen, bctlen, catlen; - REAL abtt[4], bctt[4], catt[4]; - int abttlen, bcttlen, cattlen; - INEXACT REAL abtt3, bctt3, catt3; - REAL negate; - - INEXACT REAL bvirt; - REAL avirt, bround, around; - INEXACT REAL c; - INEXACT REAL abig; - REAL ahi, alo, bhi, blo; - REAL err1, err2, err3; - INEXACT REAL _i, _j; - REAL _0; - - adx = (REAL)(pa[0] - pd[0]); - bdx = (REAL)(pb[0] - pd[0]); - cdx = (REAL)(pc[0] - pd[0]); - ady = (REAL)(pa[1] - pd[1]); - bdy = (REAL)(pb[1] - pd[1]); - cdy = (REAL)(pc[1] - pd[1]); - - Two_Product(bdx, cdy, bdxcdy1, bdxcdy0); - Two_Product(cdx, bdy, cdxbdy1, cdxbdy0); - Two_Two_Diff(bdxcdy1, bdxcdy0, cdxbdy1, cdxbdy0, bc3, bc[2], bc[1], bc[0]); - bc[3] = bc3; - axbclen = scale_expansion_zeroelim(4, bc, adx, axbc); - axxbclen = scale_expansion_zeroelim(axbclen, axbc, adx, axxbc); - aybclen = scale_expansion_zeroelim(4, bc, ady, aybc); - ayybclen = scale_expansion_zeroelim(aybclen, aybc, ady, ayybc); - alen = fast_expansion_sum_zeroelim(axxbclen, axxbc, ayybclen, ayybc, adet); - - Two_Product(cdx, ady, cdxady1, cdxady0); - Two_Product(adx, cdy, adxcdy1, adxcdy0); - Two_Two_Diff(cdxady1, cdxady0, adxcdy1, adxcdy0, ca3, ca[2], ca[1], ca[0]); - ca[3] = ca3; - bxcalen = scale_expansion_zeroelim(4, ca, bdx, bxca); - bxxcalen = scale_expansion_zeroelim(bxcalen, bxca, bdx, bxxca); - bycalen = scale_expansion_zeroelim(4, ca, bdy, byca); - byycalen = scale_expansion_zeroelim(bycalen, byca, bdy, byyca); - blen = fast_expansion_sum_zeroelim(bxxcalen, bxxca, byycalen, byyca, bdet); - - Two_Product(adx, bdy, adxbdy1, adxbdy0); - Two_Product(bdx, ady, bdxady1, bdxady0); - Two_Two_Diff(adxbdy1, adxbdy0, bdxady1, bdxady0, ab3, ab[2], ab[1], ab[0]); - ab[3] = ab3; - cxablen = scale_expansion_zeroelim(4, ab, cdx, cxab); - cxxablen = scale_expansion_zeroelim(cxablen, cxab, cdx, cxxab); - cyablen = scale_expansion_zeroelim(4, ab, cdy, cyab); - cyyablen = scale_expansion_zeroelim(cyablen, cyab, cdy, cyyab); - clen = fast_expansion_sum_zeroelim(cxxablen, cxxab, cyyablen, cyyab, cdet); - - ablen = fast_expansion_sum_zeroelim(alen, adet, blen, bdet, abdet); - finlength = fast_expansion_sum_zeroelim(ablen, abdet, clen, cdet, fin1); - - det = estimate(finlength, fin1); - errbound = iccerrboundB * permanent; - if ((det >= errbound) || (-det >= errbound)) { - return det; - } - - Two_Diff_Tail(pa[0], pd[0], adx, adxtail); - Two_Diff_Tail(pa[1], pd[1], ady, adytail); - Two_Diff_Tail(pb[0], pd[0], bdx, bdxtail); - Two_Diff_Tail(pb[1], pd[1], bdy, bdytail); - Two_Diff_Tail(pc[0], pd[0], cdx, cdxtail); - Two_Diff_Tail(pc[1], pd[1], cdy, cdytail); - if ((adxtail == 0.0) && (bdxtail == 0.0) && (cdxtail == 0.0) && - (adytail == 0.0) && (bdytail == 0.0) && (cdytail == 0.0)) { - return det; - } - - errbound = iccerrboundC * permanent + resulterrbound * Absolute(det); - det += - ((adx * adx + ady * ady) * - ((bdx * cdytail + cdy * bdxtail) - (bdy * cdxtail + cdx * bdytail)) + - 2.0 * (adx * adxtail + ady * adytail) * (bdx * cdy - bdy * cdx)) + - ((bdx * bdx + bdy * bdy) * - ((cdx * adytail + ady * cdxtail) - (cdy * adxtail + adx * cdytail)) + - 2.0 * (bdx * bdxtail + bdy * bdytail) * (cdx * ady - cdy * adx)) + - ((cdx * cdx + cdy * cdy) * - ((adx * bdytail + bdy * adxtail) - (ady * bdxtail + bdx * adytail)) + - 2.0 * (cdx * cdxtail + cdy * cdytail) * (adx * bdy - ady * bdx)); - if ((det >= errbound) || (-det >= errbound)) { - return det; - } - - finnow = fin1; - finother = fin2; - - if ((bdxtail != 0.0) || (bdytail != 0.0) || (cdxtail != 0.0) || - (cdytail != 0.0)) { - Square(adx, adxadx1, adxadx0); - Square(ady, adyady1, adyady0); - Two_Two_Sum(adxadx1, adxadx0, adyady1, adyady0, aa3, aa[2], aa[1], aa[0]); - aa[3] = aa3; - } - if ((cdxtail != 0.0) || (cdytail != 0.0) || (adxtail != 0.0) || - (adytail != 0.0)) { - Square(bdx, bdxbdx1, bdxbdx0); - Square(bdy, bdybdy1, bdybdy0); - Two_Two_Sum(bdxbdx1, bdxbdx0, bdybdy1, bdybdy0, bb3, bb[2], bb[1], bb[0]); - bb[3] = bb3; - } - if ((adxtail != 0.0) || (adytail != 0.0) || (bdxtail != 0.0) || - (bdytail != 0.0)) { - Square(cdx, cdxcdx1, cdxcdx0); - Square(cdy, cdycdy1, cdycdy0); - Two_Two_Sum(cdxcdx1, cdxcdx0, cdycdy1, cdycdy0, cc3, cc[2], cc[1], cc[0]); - cc[3] = cc3; - } - - if (adxtail != 0.0) { - axtbclen = scale_expansion_zeroelim(4, bc, adxtail, axtbc); - temp16alen = scale_expansion_zeroelim(axtbclen, axtbc, 2.0 * adx, temp16a); - - axtcclen = scale_expansion_zeroelim(4, cc, adxtail, axtcc); - temp16blen = scale_expansion_zeroelim(axtcclen, axtcc, bdy, temp16b); - - axtbblen = scale_expansion_zeroelim(4, bb, adxtail, axtbb); - temp16clen = scale_expansion_zeroelim(axtbblen, axtbb, -cdy, temp16c); - - temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (adytail != 0.0) { - aytbclen = scale_expansion_zeroelim(4, bc, adytail, aytbc); - temp16alen = scale_expansion_zeroelim(aytbclen, aytbc, 2.0 * ady, temp16a); - - aytbblen = scale_expansion_zeroelim(4, bb, adytail, aytbb); - temp16blen = scale_expansion_zeroelim(aytbblen, aytbb, cdx, temp16b); - - aytcclen = scale_expansion_zeroelim(4, cc, adytail, aytcc); - temp16clen = scale_expansion_zeroelim(aytcclen, aytcc, -bdx, temp16c); - - temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (bdxtail != 0.0) { - bxtcalen = scale_expansion_zeroelim(4, ca, bdxtail, bxtca); - temp16alen = scale_expansion_zeroelim(bxtcalen, bxtca, 2.0 * bdx, temp16a); - - bxtaalen = scale_expansion_zeroelim(4, aa, bdxtail, bxtaa); - temp16blen = scale_expansion_zeroelim(bxtaalen, bxtaa, cdy, temp16b); - - bxtcclen = scale_expansion_zeroelim(4, cc, bdxtail, bxtcc); - temp16clen = scale_expansion_zeroelim(bxtcclen, bxtcc, -ady, temp16c); - - temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (bdytail != 0.0) { - bytcalen = scale_expansion_zeroelim(4, ca, bdytail, bytca); - temp16alen = scale_expansion_zeroelim(bytcalen, bytca, 2.0 * bdy, temp16a); - - bytcclen = scale_expansion_zeroelim(4, cc, bdytail, bytcc); - temp16blen = scale_expansion_zeroelim(bytcclen, bytcc, adx, temp16b); - - bytaalen = scale_expansion_zeroelim(4, aa, bdytail, bytaa); - temp16clen = scale_expansion_zeroelim(bytaalen, bytaa, -cdx, temp16c); - - temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (cdxtail != 0.0) { - cxtablen = scale_expansion_zeroelim(4, ab, cdxtail, cxtab); - temp16alen = scale_expansion_zeroelim(cxtablen, cxtab, 2.0 * cdx, temp16a); - - cxtbblen = scale_expansion_zeroelim(4, bb, cdxtail, cxtbb); - temp16blen = scale_expansion_zeroelim(cxtbblen, cxtbb, ady, temp16b); - - cxtaalen = scale_expansion_zeroelim(4, aa, cdxtail, cxtaa); - temp16clen = scale_expansion_zeroelim(cxtaalen, cxtaa, -bdy, temp16c); - - temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (cdytail != 0.0) { - cytablen = scale_expansion_zeroelim(4, ab, cdytail, cytab); - temp16alen = scale_expansion_zeroelim(cytablen, cytab, 2.0 * cdy, temp16a); - - cytaalen = scale_expansion_zeroelim(4, aa, cdytail, cytaa); - temp16blen = scale_expansion_zeroelim(cytaalen, cytaa, bdx, temp16b); - - cytbblen = scale_expansion_zeroelim(4, bb, cdytail, cytbb); - temp16clen = scale_expansion_zeroelim(cytbblen, cytbb, -adx, temp16c); - - temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - - if ((adxtail != 0.0) || (adytail != 0.0)) { - if ((bdxtail != 0.0) || (bdytail != 0.0) || (cdxtail != 0.0) || - (cdytail != 0.0)) { - Two_Product(bdxtail, cdy, ti1, ti0); - Two_Product(bdx, cdytail, tj1, tj0); - Two_Two_Sum(ti1, ti0, tj1, tj0, u3, u[2], u[1], u[0]); - u[3] = u3; - negate = -bdy; - Two_Product(cdxtail, negate, ti1, ti0); - negate = -bdytail; - Two_Product(cdx, negate, tj1, tj0); - Two_Two_Sum(ti1, ti0, tj1, tj0, v3, v[2], v[1], v[0]); - v[3] = v3; - bctlen = fast_expansion_sum_zeroelim(4, u, 4, v, bct); - - Two_Product(bdxtail, cdytail, ti1, ti0); - Two_Product(cdxtail, bdytail, tj1, tj0); - Two_Two_Diff(ti1, ti0, tj1, tj0, bctt3, bctt[2], bctt[1], bctt[0]); - bctt[3] = bctt3; - bcttlen = 4; - } else { - bct[0] = 0.0; - bctlen = 1; - bctt[0] = 0.0; - bcttlen = 1; - } - - if (adxtail != 0.0) { - temp16alen = scale_expansion_zeroelim(axtbclen, axtbc, adxtail, temp16a); - axtbctlen = scale_expansion_zeroelim(bctlen, bct, adxtail, axtbct); - temp32alen = - scale_expansion_zeroelim(axtbctlen, axtbct, 2.0 * adx, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (bdytail != 0.0) { - temp8len = scale_expansion_zeroelim(4, cc, adxtail, temp8); - temp16alen = - scale_expansion_zeroelim(temp8len, temp8, bdytail, temp16a); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, - temp16a, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (cdytail != 0.0) { - temp8len = scale_expansion_zeroelim(4, bb, -adxtail, temp8); - temp16alen = - scale_expansion_zeroelim(temp8len, temp8, cdytail, temp16a); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, - temp16a, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - - temp32alen = - scale_expansion_zeroelim(axtbctlen, axtbct, adxtail, temp32a); - axtbcttlen = scale_expansion_zeroelim(bcttlen, bctt, adxtail, axtbctt); - temp16alen = - scale_expansion_zeroelim(axtbcttlen, axtbctt, 2.0 * adx, temp16a); - temp16blen = - scale_expansion_zeroelim(axtbcttlen, axtbctt, adxtail, temp16b); - temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32b); - temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, - temp32b, temp64); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, - temp64, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (adytail != 0.0) { - temp16alen = scale_expansion_zeroelim(aytbclen, aytbc, adytail, temp16a); - aytbctlen = scale_expansion_zeroelim(bctlen, bct, adytail, aytbct); - temp32alen = - scale_expansion_zeroelim(aytbctlen, aytbct, 2.0 * ady, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - - temp32alen = - scale_expansion_zeroelim(aytbctlen, aytbct, adytail, temp32a); - aytbcttlen = scale_expansion_zeroelim(bcttlen, bctt, adytail, aytbctt); - temp16alen = - scale_expansion_zeroelim(aytbcttlen, aytbctt, 2.0 * ady, temp16a); - temp16blen = - scale_expansion_zeroelim(aytbcttlen, aytbctt, adytail, temp16b); - temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32b); - temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, - temp32b, temp64); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, - temp64, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - if ((bdxtail != 0.0) || (bdytail != 0.0)) { - if ((cdxtail != 0.0) || (cdytail != 0.0) || (adxtail != 0.0) || - (adytail != 0.0)) { - Two_Product(cdxtail, ady, ti1, ti0); - Two_Product(cdx, adytail, tj1, tj0); - Two_Two_Sum(ti1, ti0, tj1, tj0, u3, u[2], u[1], u[0]); - u[3] = u3; - negate = -cdy; - Two_Product(adxtail, negate, ti1, ti0); - negate = -cdytail; - Two_Product(adx, negate, tj1, tj0); - Two_Two_Sum(ti1, ti0, tj1, tj0, v3, v[2], v[1], v[0]); - v[3] = v3; - catlen = fast_expansion_sum_zeroelim(4, u, 4, v, cat); - - Two_Product(cdxtail, adytail, ti1, ti0); - Two_Product(adxtail, cdytail, tj1, tj0); - Two_Two_Diff(ti1, ti0, tj1, tj0, catt3, catt[2], catt[1], catt[0]); - catt[3] = catt3; - cattlen = 4; - } else { - cat[0] = 0.0; - catlen = 1; - catt[0] = 0.0; - cattlen = 1; - } - - if (bdxtail != 0.0) { - temp16alen = scale_expansion_zeroelim(bxtcalen, bxtca, bdxtail, temp16a); - bxtcatlen = scale_expansion_zeroelim(catlen, cat, bdxtail, bxtcat); - temp32alen = - scale_expansion_zeroelim(bxtcatlen, bxtcat, 2.0 * bdx, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (cdytail != 0.0) { - temp8len = scale_expansion_zeroelim(4, aa, bdxtail, temp8); - temp16alen = - scale_expansion_zeroelim(temp8len, temp8, cdytail, temp16a); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, - temp16a, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (adytail != 0.0) { - temp8len = scale_expansion_zeroelim(4, cc, -bdxtail, temp8); - temp16alen = - scale_expansion_zeroelim(temp8len, temp8, adytail, temp16a); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, - temp16a, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - - temp32alen = - scale_expansion_zeroelim(bxtcatlen, bxtcat, bdxtail, temp32a); - bxtcattlen = scale_expansion_zeroelim(cattlen, catt, bdxtail, bxtcatt); - temp16alen = - scale_expansion_zeroelim(bxtcattlen, bxtcatt, 2.0 * bdx, temp16a); - temp16blen = - scale_expansion_zeroelim(bxtcattlen, bxtcatt, bdxtail, temp16b); - temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32b); - temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, - temp32b, temp64); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, - temp64, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (bdytail != 0.0) { - temp16alen = scale_expansion_zeroelim(bytcalen, bytca, bdytail, temp16a); - bytcatlen = scale_expansion_zeroelim(catlen, cat, bdytail, bytcat); - temp32alen = - scale_expansion_zeroelim(bytcatlen, bytcat, 2.0 * bdy, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - - temp32alen = - scale_expansion_zeroelim(bytcatlen, bytcat, bdytail, temp32a); - bytcattlen = scale_expansion_zeroelim(cattlen, catt, bdytail, bytcatt); - temp16alen = - scale_expansion_zeroelim(bytcattlen, bytcatt, 2.0 * bdy, temp16a); - temp16blen = - scale_expansion_zeroelim(bytcattlen, bytcatt, bdytail, temp16b); - temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32b); - temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, - temp32b, temp64); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, - temp64, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - if ((cdxtail != 0.0) || (cdytail != 0.0)) { - if ((adxtail != 0.0) || (adytail != 0.0) || (bdxtail != 0.0) || - (bdytail != 0.0)) { - Two_Product(adxtail, bdy, ti1, ti0); - Two_Product(adx, bdytail, tj1, tj0); - Two_Two_Sum(ti1, ti0, tj1, tj0, u3, u[2], u[1], u[0]); - u[3] = u3; - negate = -ady; - Two_Product(bdxtail, negate, ti1, ti0); - negate = -adytail; - Two_Product(bdx, negate, tj1, tj0); - Two_Two_Sum(ti1, ti0, tj1, tj0, v3, v[2], v[1], v[0]); - v[3] = v3; - abtlen = fast_expansion_sum_zeroelim(4, u, 4, v, abt); - - Two_Product(adxtail, bdytail, ti1, ti0); - Two_Product(bdxtail, adytail, tj1, tj0); - Two_Two_Diff(ti1, ti0, tj1, tj0, abtt3, abtt[2], abtt[1], abtt[0]); - abtt[3] = abtt3; - abttlen = 4; - } else { - abt[0] = 0.0; - abtlen = 1; - abtt[0] = 0.0; - abttlen = 1; - } - - if (cdxtail != 0.0) { - temp16alen = scale_expansion_zeroelim(cxtablen, cxtab, cdxtail, temp16a); - cxtabtlen = scale_expansion_zeroelim(abtlen, abt, cdxtail, cxtabt); - temp32alen = - scale_expansion_zeroelim(cxtabtlen, cxtabt, 2.0 * cdx, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (adytail != 0.0) { - temp8len = scale_expansion_zeroelim(4, bb, cdxtail, temp8); - temp16alen = - scale_expansion_zeroelim(temp8len, temp8, adytail, temp16a); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, - temp16a, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (bdytail != 0.0) { - temp8len = scale_expansion_zeroelim(4, aa, -cdxtail, temp8); - temp16alen = - scale_expansion_zeroelim(temp8len, temp8, bdytail, temp16a); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, - temp16a, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - - temp32alen = - scale_expansion_zeroelim(cxtabtlen, cxtabt, cdxtail, temp32a); - cxtabttlen = scale_expansion_zeroelim(abttlen, abtt, cdxtail, cxtabtt); - temp16alen = - scale_expansion_zeroelim(cxtabttlen, cxtabtt, 2.0 * cdx, temp16a); - temp16blen = - scale_expansion_zeroelim(cxtabttlen, cxtabtt, cdxtail, temp16b); - temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32b); - temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, - temp32b, temp64); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, - temp64, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (cdytail != 0.0) { - temp16alen = scale_expansion_zeroelim(cytablen, cytab, cdytail, temp16a); - cytabtlen = scale_expansion_zeroelim(abtlen, abt, cdytail, cytabt); - temp32alen = - scale_expansion_zeroelim(cytabtlen, cytabt, 2.0 * cdy, temp32a); - temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, - temp32a, temp48); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, - temp48, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - - temp32alen = - scale_expansion_zeroelim(cytabtlen, cytabt, cdytail, temp32a); - cytabttlen = scale_expansion_zeroelim(abttlen, abtt, cdytail, cytabtt); - temp16alen = - scale_expansion_zeroelim(cytabttlen, cytabtt, 2.0 * cdy, temp16a); - temp16blen = - scale_expansion_zeroelim(cytabttlen, cytabtt, cdytail, temp16b); - temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, - temp16b, temp32b); - temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, - temp32b, temp64); - finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, - temp64, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - - return finnow[finlength - 1]; -} - -#ifdef ANSI_DECLARATORS -REAL incircle(struct mesh *m, struct behavior *b, vertex pa, vertex pb, - vertex pc, vertex pd) -#else /* not ANSI_DECLARATORS */ -REAL incircle(m, b, pa, pb, pc, pd) -struct mesh *m; -struct behavior *b; -vertex pa; -vertex pb; -vertex pc; -vertex pd; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL adx, bdx, cdx, ady, bdy, cdy; - REAL bdxcdy, cdxbdy, cdxady, adxcdy, adxbdy, bdxady; - REAL alift, blift, clift; - REAL det; - REAL permanent, errbound; - - m->incirclecount++; - - adx = pa[0] - pd[0]; - bdx = pb[0] - pd[0]; - cdx = pc[0] - pd[0]; - ady = pa[1] - pd[1]; - bdy = pb[1] - pd[1]; - cdy = pc[1] - pd[1]; - - bdxcdy = bdx * cdy; - cdxbdy = cdx * bdy; - alift = adx * adx + ady * ady; - - cdxady = cdx * ady; - adxcdy = adx * cdy; - blift = bdx * bdx + bdy * bdy; - - adxbdy = adx * bdy; - bdxady = bdx * ady; - clift = cdx * cdx + cdy * cdy; - - det = alift * (bdxcdy - cdxbdy) + blift * (cdxady - adxcdy) + - clift * (adxbdy - bdxady); - - if (b->noexact) { - return det; - } - - permanent = (Absolute(bdxcdy) + Absolute(cdxbdy)) * alift + - (Absolute(cdxady) + Absolute(adxcdy)) * blift + - (Absolute(adxbdy) + Absolute(bdxady)) * clift; - errbound = iccerrboundA * permanent; - if ((det > errbound) || (-det > errbound)) { - return det; - } - - return incircleadapt(pa, pb, pc, pd, permanent); -} - -/*****************************************************************************/ -/* */ -/* orient3d() Return a positive value if the point pd lies below the */ -/* plane passing through pa, pb, and pc; "below" is defined so */ -/* that pa, pb, and pc appear in counterclockwise order when */ -/* viewed from above the plane. Returns a negative value if */ -/* pd lies above the plane. Returns zero if the points are */ -/* coplanar. The result is also a rough approximation of six */ -/* times the signed volume of the tetrahedron defined by the */ -/* four points. */ -/* */ -/* Uses exact arithmetic if necessary to ensure a correct answer. The */ -/* result returned is the determinant of a matrix. This determinant is */ -/* computed adaptively, in the sense that exact arithmetic is used only to */ -/* the degree it is needed to ensure that the returned value has the */ -/* correct sign. Hence, this function is usually quite fast, but will run */ -/* more slowly when the input points are coplanar or nearly so. */ -/* */ -/* See my Robust Predicates paper for details. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -REAL orient3dadapt(vertex pa, vertex pb, vertex pc, vertex pd, REAL aheight, - REAL bheight, REAL cheight, REAL dheight, REAL permanent) -#else /* not ANSI_DECLARATORS */ -REAL orient3dadapt(pa, pb, pc, pd, aheight, bheight, cheight, dheight, - permanent) -vertex pa; -vertex pb; -vertex pc; -vertex pd; -REAL aheight; -REAL bheight; -REAL cheight; -REAL dheight; -REAL permanent; -#endif /* not ANSI_DECLARATORS */ - -{ - INEXACT REAL adx, bdx, cdx, ady, bdy, cdy, adheight, bdheight, cdheight; - REAL det, errbound; - - INEXACT REAL bdxcdy1, cdxbdy1, cdxady1, adxcdy1, adxbdy1, bdxady1; - REAL bdxcdy0, cdxbdy0, cdxady0, adxcdy0, adxbdy0, bdxady0; - REAL bc[4], ca[4], ab[4]; - INEXACT REAL bc3, ca3, ab3; - REAL adet[8], bdet[8], cdet[8]; - int alen, blen, clen; - REAL abdet[16]; - int ablen; - REAL *finnow, *finother, *finswap; - REAL fin1[192], fin2[192]; - int finlength; - - REAL adxtail, bdxtail, cdxtail; - REAL adytail, bdytail, cdytail; - REAL adheighttail, bdheighttail, cdheighttail; - INEXACT REAL at_blarge, at_clarge; - INEXACT REAL bt_clarge, bt_alarge; - INEXACT REAL ct_alarge, ct_blarge; - REAL at_b[4], at_c[4], bt_c[4], bt_a[4], ct_a[4], ct_b[4]; - int at_blen, at_clen, bt_clen, bt_alen, ct_alen, ct_blen; - INEXACT REAL bdxt_cdy1, cdxt_bdy1, cdxt_ady1; - INEXACT REAL adxt_cdy1, adxt_bdy1, bdxt_ady1; - REAL bdxt_cdy0, cdxt_bdy0, cdxt_ady0; - REAL adxt_cdy0, adxt_bdy0, bdxt_ady0; - INEXACT REAL bdyt_cdx1, cdyt_bdx1, cdyt_adx1; - INEXACT REAL adyt_cdx1, adyt_bdx1, bdyt_adx1; - REAL bdyt_cdx0, cdyt_bdx0, cdyt_adx0; - REAL adyt_cdx0, adyt_bdx0, bdyt_adx0; - REAL bct[8], cat[8], abt[8]; - int bctlen, catlen, abtlen; - INEXACT REAL bdxt_cdyt1, cdxt_bdyt1, cdxt_adyt1; - INEXACT REAL adxt_cdyt1, adxt_bdyt1, bdxt_adyt1; - REAL bdxt_cdyt0, cdxt_bdyt0, cdxt_adyt0; - REAL adxt_cdyt0, adxt_bdyt0, bdxt_adyt0; - REAL u[4], v[12], w[16]; - INEXACT REAL u3; - int vlength, wlength; - REAL negate; - - INEXACT REAL bvirt; - REAL avirt, bround, around; - INEXACT REAL c; - INEXACT REAL abig; - REAL ahi, alo, bhi, blo; - REAL err1, err2, err3; - INEXACT REAL _i, _j, _k; - REAL _0; - - adx = (REAL)(pa[0] - pd[0]); - bdx = (REAL)(pb[0] - pd[0]); - cdx = (REAL)(pc[0] - pd[0]); - ady = (REAL)(pa[1] - pd[1]); - bdy = (REAL)(pb[1] - pd[1]); - cdy = (REAL)(pc[1] - pd[1]); - adheight = (REAL)(aheight - dheight); - bdheight = (REAL)(bheight - dheight); - cdheight = (REAL)(cheight - dheight); - - Two_Product(bdx, cdy, bdxcdy1, bdxcdy0); - Two_Product(cdx, bdy, cdxbdy1, cdxbdy0); - Two_Two_Diff(bdxcdy1, bdxcdy0, cdxbdy1, cdxbdy0, bc3, bc[2], bc[1], bc[0]); - bc[3] = bc3; - alen = scale_expansion_zeroelim(4, bc, adheight, adet); - - Two_Product(cdx, ady, cdxady1, cdxady0); - Two_Product(adx, cdy, adxcdy1, adxcdy0); - Two_Two_Diff(cdxady1, cdxady0, adxcdy1, adxcdy0, ca3, ca[2], ca[1], ca[0]); - ca[3] = ca3; - blen = scale_expansion_zeroelim(4, ca, bdheight, bdet); - - Two_Product(adx, bdy, adxbdy1, adxbdy0); - Two_Product(bdx, ady, bdxady1, bdxady0); - Two_Two_Diff(adxbdy1, adxbdy0, bdxady1, bdxady0, ab3, ab[2], ab[1], ab[0]); - ab[3] = ab3; - clen = scale_expansion_zeroelim(4, ab, cdheight, cdet); - - ablen = fast_expansion_sum_zeroelim(alen, adet, blen, bdet, abdet); - finlength = fast_expansion_sum_zeroelim(ablen, abdet, clen, cdet, fin1); - - det = estimate(finlength, fin1); - errbound = o3derrboundB * permanent; - if ((det >= errbound) || (-det >= errbound)) { - return det; - } - - Two_Diff_Tail(pa[0], pd[0], adx, adxtail); - Two_Diff_Tail(pb[0], pd[0], bdx, bdxtail); - Two_Diff_Tail(pc[0], pd[0], cdx, cdxtail); - Two_Diff_Tail(pa[1], pd[1], ady, adytail); - Two_Diff_Tail(pb[1], pd[1], bdy, bdytail); - Two_Diff_Tail(pc[1], pd[1], cdy, cdytail); - Two_Diff_Tail(aheight, dheight, adheight, adheighttail); - Two_Diff_Tail(bheight, dheight, bdheight, bdheighttail); - Two_Diff_Tail(cheight, dheight, cdheight, cdheighttail); - - if ((adxtail == 0.0) && (bdxtail == 0.0) && (cdxtail == 0.0) && - (adytail == 0.0) && (bdytail == 0.0) && (cdytail == 0.0) && - (adheighttail == 0.0) && (bdheighttail == 0.0) && (cdheighttail == 0.0)) { - return det; - } - - errbound = o3derrboundC * permanent + resulterrbound * Absolute(det); - det += - (adheight * - ((bdx * cdytail + cdy * bdxtail) - (bdy * cdxtail + cdx * bdytail)) + - adheighttail * (bdx * cdy - bdy * cdx)) + - (bdheight * - ((cdx * adytail + ady * cdxtail) - (cdy * adxtail + adx * cdytail)) + - bdheighttail * (cdx * ady - cdy * adx)) + - (cdheight * - ((adx * bdytail + bdy * adxtail) - (ady * bdxtail + bdx * adytail)) + - cdheighttail * (adx * bdy - ady * bdx)); - if ((det >= errbound) || (-det >= errbound)) { - return det; - } - - finnow = fin1; - finother = fin2; - - if (adxtail == 0.0) { - if (adytail == 0.0) { - at_b[0] = 0.0; - at_blen = 1; - at_c[0] = 0.0; - at_clen = 1; - } else { - negate = -adytail; - Two_Product(negate, bdx, at_blarge, at_b[0]); - at_b[1] = at_blarge; - at_blen = 2; - Two_Product(adytail, cdx, at_clarge, at_c[0]); - at_c[1] = at_clarge; - at_clen = 2; - } - } else { - if (adytail == 0.0) { - Two_Product(adxtail, bdy, at_blarge, at_b[0]); - at_b[1] = at_blarge; - at_blen = 2; - negate = -adxtail; - Two_Product(negate, cdy, at_clarge, at_c[0]); - at_c[1] = at_clarge; - at_clen = 2; - } else { - Two_Product(adxtail, bdy, adxt_bdy1, adxt_bdy0); - Two_Product(adytail, bdx, adyt_bdx1, adyt_bdx0); - Two_Two_Diff(adxt_bdy1, adxt_bdy0, adyt_bdx1, adyt_bdx0, at_blarge, - at_b[2], at_b[1], at_b[0]); - at_b[3] = at_blarge; - at_blen = 4; - Two_Product(adytail, cdx, adyt_cdx1, adyt_cdx0); - Two_Product(adxtail, cdy, adxt_cdy1, adxt_cdy0); - Two_Two_Diff(adyt_cdx1, adyt_cdx0, adxt_cdy1, adxt_cdy0, at_clarge, - at_c[2], at_c[1], at_c[0]); - at_c[3] = at_clarge; - at_clen = 4; - } - } - if (bdxtail == 0.0) { - if (bdytail == 0.0) { - bt_c[0] = 0.0; - bt_clen = 1; - bt_a[0] = 0.0; - bt_alen = 1; - } else { - negate = -bdytail; - Two_Product(negate, cdx, bt_clarge, bt_c[0]); - bt_c[1] = bt_clarge; - bt_clen = 2; - Two_Product(bdytail, adx, bt_alarge, bt_a[0]); - bt_a[1] = bt_alarge; - bt_alen = 2; - } - } else { - if (bdytail == 0.0) { - Two_Product(bdxtail, cdy, bt_clarge, bt_c[0]); - bt_c[1] = bt_clarge; - bt_clen = 2; - negate = -bdxtail; - Two_Product(negate, ady, bt_alarge, bt_a[0]); - bt_a[1] = bt_alarge; - bt_alen = 2; - } else { - Two_Product(bdxtail, cdy, bdxt_cdy1, bdxt_cdy0); - Two_Product(bdytail, cdx, bdyt_cdx1, bdyt_cdx0); - Two_Two_Diff(bdxt_cdy1, bdxt_cdy0, bdyt_cdx1, bdyt_cdx0, bt_clarge, - bt_c[2], bt_c[1], bt_c[0]); - bt_c[3] = bt_clarge; - bt_clen = 4; - Two_Product(bdytail, adx, bdyt_adx1, bdyt_adx0); - Two_Product(bdxtail, ady, bdxt_ady1, bdxt_ady0); - Two_Two_Diff(bdyt_adx1, bdyt_adx0, bdxt_ady1, bdxt_ady0, bt_alarge, - bt_a[2], bt_a[1], bt_a[0]); - bt_a[3] = bt_alarge; - bt_alen = 4; - } - } - if (cdxtail == 0.0) { - if (cdytail == 0.0) { - ct_a[0] = 0.0; - ct_alen = 1; - ct_b[0] = 0.0; - ct_blen = 1; - } else { - negate = -cdytail; - Two_Product(negate, adx, ct_alarge, ct_a[0]); - ct_a[1] = ct_alarge; - ct_alen = 2; - Two_Product(cdytail, bdx, ct_blarge, ct_b[0]); - ct_b[1] = ct_blarge; - ct_blen = 2; - } - } else { - if (cdytail == 0.0) { - Two_Product(cdxtail, ady, ct_alarge, ct_a[0]); - ct_a[1] = ct_alarge; - ct_alen = 2; - negate = -cdxtail; - Two_Product(negate, bdy, ct_blarge, ct_b[0]); - ct_b[1] = ct_blarge; - ct_blen = 2; - } else { - Two_Product(cdxtail, ady, cdxt_ady1, cdxt_ady0); - Two_Product(cdytail, adx, cdyt_adx1, cdyt_adx0); - Two_Two_Diff(cdxt_ady1, cdxt_ady0, cdyt_adx1, cdyt_adx0, ct_alarge, - ct_a[2], ct_a[1], ct_a[0]); - ct_a[3] = ct_alarge; - ct_alen = 4; - Two_Product(cdytail, bdx, cdyt_bdx1, cdyt_bdx0); - Two_Product(cdxtail, bdy, cdxt_bdy1, cdxt_bdy0); - Two_Two_Diff(cdyt_bdx1, cdyt_bdx0, cdxt_bdy1, cdxt_bdy0, ct_blarge, - ct_b[2], ct_b[1], ct_b[0]); - ct_b[3] = ct_blarge; - ct_blen = 4; - } - } - - bctlen = fast_expansion_sum_zeroelim(bt_clen, bt_c, ct_blen, ct_b, bct); - wlength = scale_expansion_zeroelim(bctlen, bct, adheight, w); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - - catlen = fast_expansion_sum_zeroelim(ct_alen, ct_a, at_clen, at_c, cat); - wlength = scale_expansion_zeroelim(catlen, cat, bdheight, w); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - - abtlen = fast_expansion_sum_zeroelim(at_blen, at_b, bt_alen, bt_a, abt); - wlength = scale_expansion_zeroelim(abtlen, abt, cdheight, w); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - - if (adheighttail != 0.0) { - vlength = scale_expansion_zeroelim(4, bc, adheighttail, v); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, vlength, v, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (bdheighttail != 0.0) { - vlength = scale_expansion_zeroelim(4, ca, bdheighttail, v); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, vlength, v, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (cdheighttail != 0.0) { - vlength = scale_expansion_zeroelim(4, ab, cdheighttail, v); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, vlength, v, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - - if (adxtail != 0.0) { - if (bdytail != 0.0) { - Two_Product(adxtail, bdytail, adxt_bdyt1, adxt_bdyt0); - Two_One_Product(adxt_bdyt1, adxt_bdyt0, cdheight, u3, u[2], u[1], u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (cdheighttail != 0.0) { - Two_One_Product(adxt_bdyt1, adxt_bdyt0, cdheighttail, u3, u[2], u[1], - u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - if (cdytail != 0.0) { - negate = -adxtail; - Two_Product(negate, cdytail, adxt_cdyt1, adxt_cdyt0); - Two_One_Product(adxt_cdyt1, adxt_cdyt0, bdheight, u3, u[2], u[1], u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (bdheighttail != 0.0) { - Two_One_Product(adxt_cdyt1, adxt_cdyt0, bdheighttail, u3, u[2], u[1], - u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - } - if (bdxtail != 0.0) { - if (cdytail != 0.0) { - Two_Product(bdxtail, cdytail, bdxt_cdyt1, bdxt_cdyt0); - Two_One_Product(bdxt_cdyt1, bdxt_cdyt0, adheight, u3, u[2], u[1], u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (adheighttail != 0.0) { - Two_One_Product(bdxt_cdyt1, bdxt_cdyt0, adheighttail, u3, u[2], u[1], - u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - if (adytail != 0.0) { - negate = -bdxtail; - Two_Product(negate, adytail, bdxt_adyt1, bdxt_adyt0); - Two_One_Product(bdxt_adyt1, bdxt_adyt0, cdheight, u3, u[2], u[1], u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (cdheighttail != 0.0) { - Two_One_Product(bdxt_adyt1, bdxt_adyt0, cdheighttail, u3, u[2], u[1], - u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - } - if (cdxtail != 0.0) { - if (adytail != 0.0) { - Two_Product(cdxtail, adytail, cdxt_adyt1, cdxt_adyt0); - Two_One_Product(cdxt_adyt1, cdxt_adyt0, bdheight, u3, u[2], u[1], u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (bdheighttail != 0.0) { - Two_One_Product(cdxt_adyt1, cdxt_adyt0, bdheighttail, u3, u[2], u[1], - u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - if (bdytail != 0.0) { - negate = -cdxtail; - Two_Product(negate, bdytail, cdxt_bdyt1, cdxt_bdyt0); - Two_One_Product(cdxt_bdyt1, cdxt_bdyt0, adheight, u3, u[2], u[1], u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - if (adheighttail != 0.0) { - Two_One_Product(cdxt_bdyt1, cdxt_bdyt0, adheighttail, u3, u[2], u[1], - u[0]); - u[3] = u3; - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - } - } - - if (adheighttail != 0.0) { - wlength = scale_expansion_zeroelim(bctlen, bct, adheighttail, w); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (bdheighttail != 0.0) { - wlength = scale_expansion_zeroelim(catlen, cat, bdheighttail, w); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - if (cdheighttail != 0.0) { - wlength = scale_expansion_zeroelim(abtlen, abt, cdheighttail, w); - finlength = - fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); - finswap = finnow; - finnow = finother; - finother = finswap; - } - - return finnow[finlength - 1]; -} - -#ifdef ANSI_DECLARATORS -REAL orient3d(struct mesh *m, struct behavior *b, vertex pa, vertex pb, - vertex pc, vertex pd, REAL aheight, REAL bheight, REAL cheight, - REAL dheight) -#else /* not ANSI_DECLARATORS */ -REAL orient3d(m, b, pa, pb, pc, pd, aheight, bheight, cheight, dheight) -struct mesh *m; -struct behavior *b; -vertex pa; -vertex pb; -vertex pc; -vertex pd; -REAL aheight; -REAL bheight; -REAL cheight; -REAL dheight; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL adx, bdx, cdx, ady, bdy, cdy, adheight, bdheight, cdheight; - REAL bdxcdy, cdxbdy, cdxady, adxcdy, adxbdy, bdxady; - REAL det; - REAL permanent, errbound; - - m->orient3dcount++; - - adx = pa[0] - pd[0]; - bdx = pb[0] - pd[0]; - cdx = pc[0] - pd[0]; - ady = pa[1] - pd[1]; - bdy = pb[1] - pd[1]; - cdy = pc[1] - pd[1]; - adheight = aheight - dheight; - bdheight = bheight - dheight; - cdheight = cheight - dheight; - - bdxcdy = bdx * cdy; - cdxbdy = cdx * bdy; - - cdxady = cdx * ady; - adxcdy = adx * cdy; - - adxbdy = adx * bdy; - bdxady = bdx * ady; - - det = adheight * (bdxcdy - cdxbdy) + bdheight * (cdxady - adxcdy) + - cdheight * (adxbdy - bdxady); - - if (b->noexact) { - return det; - } - - permanent = (Absolute(bdxcdy) + Absolute(cdxbdy)) * Absolute(adheight) + - (Absolute(cdxady) + Absolute(adxcdy)) * Absolute(bdheight) + - (Absolute(adxbdy) + Absolute(bdxady)) * Absolute(cdheight); - errbound = o3derrboundA * permanent; - if ((det > errbound) || (-det > errbound)) { - return det; - } - - return orient3dadapt(pa, pb, pc, pd, aheight, bheight, cheight, dheight, - permanent); -} - -/*****************************************************************************/ -/* */ -/* nonregular() Return a positive value if the point pd is incompatible */ -/* with the circle or plane passing through pa, pb, and pc */ -/* (meaning that pd is inside the circle or below the */ -/* plane); a negative value if it is compatible; and zero if */ -/* the four points are cocircular/coplanar. The points pa, */ -/* pb, and pc must be in counterclockwise order, or the sign */ -/* of the result will be reversed. */ -/* */ -/* If the -w switch is used, the points are lifted onto the parabolic */ -/* lifting map, then they are dropped according to their weights, then the */ -/* 3D orientation test is applied. If the -W switch is used, the points' */ -/* heights are already provided, so the 3D orientation test is applied */ -/* directly. If neither switch is used, the incircle test is applied. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -REAL nonregular(struct mesh *m, struct behavior *b, vertex pa, vertex pb, - vertex pc, vertex pd) -#else /* not ANSI_DECLARATORS */ -REAL nonregular(m, b, pa, pb, pc, pd) -struct mesh *m; -struct behavior *b; -vertex pa; -vertex pb; -vertex pc; -vertex pd; -#endif /* not ANSI_DECLARATORS */ - -{ - if (b->weighted == 0) { - return incircle(m, b, pa, pb, pc, pd); - } else if (b->weighted == 1) { - return orient3d(m, b, pa, pb, pc, pd, pa[0] * pa[0] + pa[1] * pa[1] - pa[2], - pb[0] * pb[0] + pb[1] * pb[1] - pb[2], - pc[0] * pc[0] + pc[1] * pc[1] - pc[2], - pd[0] * pd[0] + pd[1] * pd[1] - pd[2]); - } else { - return orient3d(m, b, pa, pb, pc, pd, pa[2], pb[2], pc[2], pd[2]); - } -} - -/*****************************************************************************/ -/* */ -/* findcircumcenter() Find the circumcenter of a triangle. */ -/* */ -/* The result is returned both in terms of x-y coordinates and xi-eta */ -/* (barycentric) coordinates. The xi-eta coordinate system is defined in */ -/* terms of the triangle: the origin of the triangle is the origin of the */ -/* coordinate system; the destination of the triangle is one unit along the */ -/* xi axis; and the apex of the triangle is one unit along the eta axis. */ -/* This procedure also returns the square of the length of the triangle's */ -/* shortest edge. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void findcircumcenter(struct mesh *m, struct behavior *b, vertex torg, - vertex tdest, vertex tapex, vertex circumcenter, REAL *xi, - REAL *eta, int offcenter) -#else /* not ANSI_DECLARATORS */ -void findcircumcenter(m, b, torg, tdest, tapex, circumcenter, xi, eta, - offcenter) struct mesh *m; -struct behavior *b; -vertex torg; -vertex tdest; -vertex tapex; -vertex circumcenter; -REAL *xi; -REAL *eta; -int offcenter; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL xdo, ydo, xao, yao; - REAL dodist, aodist, dadist; - REAL denominator; - REAL dx, dy, dxoff, dyoff; - - m->circumcentercount++; - - /* Compute the circumcenter of the triangle. */ - xdo = tdest[0] - torg[0]; - ydo = tdest[1] - torg[1]; - xao = tapex[0] - torg[0]; - yao = tapex[1] - torg[1]; - dodist = xdo * xdo + ydo * ydo; - aodist = xao * xao + yao * yao; - dadist = (tdest[0] - tapex[0]) * (tdest[0] - tapex[0]) + - (tdest[1] - tapex[1]) * (tdest[1] - tapex[1]); - if (b->noexact) { - denominator = 0.5 / (xdo * yao - xao * ydo); - } else { - /* Use the counterclockwise() routine to ensure a positive (and */ - /* reasonably accurate) result, avoiding any possibility of */ - /* division by zero. */ - denominator = 0.5 / counterclockwise(m, b, tdest, tapex, torg); - /* Don't count the above as an orientation test. */ - m->counterclockcount--; - } - dx = (yao * dodist - ydo * aodist) * denominator; - dy = (xdo * aodist - xao * dodist) * denominator; - - /* Find the (squared) length of the triangle's shortest edge. This */ - /* serves as a conservative estimate of the insertion radius of the */ - /* circumcenter's parent. The estimate is used to ensure that */ - /* the algorithm terminates even if very small angles appear in */ - /* the input PSLG. */ - if ((dodist < aodist) && (dodist < dadist)) { - if (offcenter && (b->offconstant > 0.0)) { - /* Find the position of the off-center, as described by Alper Ungor. */ - dxoff = 0.5 * xdo - b->offconstant * ydo; - dyoff = 0.5 * ydo + b->offconstant * xdo; - /* If the off-center is closer to the origin than the */ - /* circumcenter, use the off-center instead. */ - if (dxoff * dxoff + dyoff * dyoff < dx * dx + dy * dy) { - dx = dxoff; - dy = dyoff; - } - } - } else if (aodist < dadist) { - if (offcenter && (b->offconstant > 0.0)) { - dxoff = 0.5 * xao + b->offconstant * yao; - dyoff = 0.5 * yao - b->offconstant * xao; - /* If the off-center is closer to the origin than the */ - /* circumcenter, use the off-center instead. */ - if (dxoff * dxoff + dyoff * dyoff < dx * dx + dy * dy) { - dx = dxoff; - dy = dyoff; - } - } - } else { - if (offcenter && (b->offconstant > 0.0)) { - dxoff = - 0.5 * (tapex[0] - tdest[0]) - b->offconstant * (tapex[1] - tdest[1]); - dyoff = - 0.5 * (tapex[1] - tdest[1]) + b->offconstant * (tapex[0] - tdest[0]); - /* If the off-center is closer to the destination than the */ - /* circumcenter, use the off-center instead. */ - if (dxoff * dxoff + dyoff * dyoff < - (dx - xdo) * (dx - xdo) + (dy - ydo) * (dy - ydo)) { - dx = xdo + dxoff; - dy = ydo + dyoff; - } - } - } - - circumcenter[0] = torg[0] + dx; - circumcenter[1] = torg[1] + dy; - - /* To interpolate vertex attributes for the new vertex inserted at */ - /* the circumcenter, define a coordinate system with a xi-axis, */ - /* directed from the triangle's origin to its destination, and */ - /* an eta-axis, directed from its origin to its apex. */ - /* Calculate the xi and eta coordinates of the circumcenter. */ - *xi = (yao * dx - xao * dy) * (2.0 * denominator); - *eta = (xdo * dy - ydo * dx) * (2.0 * denominator); -} - -/** **/ -/** **/ -/********* Geometric primitives end here *********/ - -/*****************************************************************************/ -/* */ -/* triangleinit() Initialize some variables. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void triangleinit(struct mesh *m) -#else /* not ANSI_DECLARATORS */ -void triangleinit(m) struct mesh *m; -#endif /* not ANSI_DECLARATORS */ - -{ - poolzero(&m->vertices); - poolzero(&m->triangles); - poolzero(&m->subsegs); - poolzero(&m->viri); - poolzero(&m->badsubsegs); - poolzero(&m->badtriangles); - poolzero(&m->flipstackers); - poolzero(&m->splaynodes); - - m->recenttri.tri = (triangle *)NULL; /* No triangle has been visited yet. */ - m->undeads = 0; /* No eliminated input vertices yet. */ - m->samples = 1; /* Point location should take at least one sample. */ - m->checksegments = 0; /* There are no segments in the triangulation yet. */ - m->checkquality = 0; /* The quality triangulation stage has not begun. */ - m->incirclecount = m->counterclockcount = m->orient3dcount = 0; - m->hyperbolacount = m->circletopcount = m->circumcentercount = 0; - randomseed = 1; - - exactinit(); /* Initialize exact arithmetic constants. */ -} - -/*****************************************************************************/ -/* */ -/* randomnation() Generate a random number between 0 and `choices' - 1. */ -/* */ -/* This is a simple linear congruential random number generator. Hence, it */ -/* is a bad random number generator, but good enough for most randomized */ -/* geometric algorithms. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -unsigned long randomnation(unsigned int choices) -#else /* not ANSI_DECLARATORS */ -unsigned long randomnation(choices) -unsigned int choices; -#endif /* not ANSI_DECLARATORS */ - -{ - randomseed = (randomseed * 1366l + 150889l) % 714025l; - return randomseed / (714025l / choices + 1); -} - -/********* Mesh quality testing routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* checkmesh() Test the mesh for topological consistency. */ -/* */ -/*****************************************************************************/ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void checkmesh(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void checkmesh(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri triangleloop; - struct otri oppotri, oppooppotri; - vertex triorg, tridest, triapex; - vertex oppoorg, oppodest; - int horrors; - int saveexact; - triangle ptr; /* Temporary variable used by sym(). */ - - /* Temporarily turn on exact arithmetic if it's off. */ - saveexact = b->noexact; - b->noexact = 0; - if (!b->quiet) { - printf(" Checking consistency of mesh...\n"); - } - horrors = 0; - /* Run through the list of triangles, checking each one. */ - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - while (triangleloop.tri != (triangle *)NULL) { - /* Check all three edges of the triangle. */ - for (triangleloop.orient = 0; triangleloop.orient < 3; - triangleloop.orient++) { - org(triangleloop, triorg); - dest(triangleloop, tridest); - if (triangleloop.orient == 0) { /* Only test for inversion once. */ - /* Test if the triangle is flat or inverted. */ - apex(triangleloop, triapex); - if (counterclockwise(m, b, triorg, tridest, triapex) <= 0.0) { - printf(" !! !! Inverted "); - printtriangle(m, b, &triangleloop); - horrors++; - } - } - /* Find the neighboring triangle on this edge. */ - sym(triangleloop, oppotri); - if (oppotri.tri != m->dummytri) { - /* Check that the triangle's neighbor knows it's a neighbor. */ - sym(oppotri, oppooppotri); - if ((triangleloop.tri != oppooppotri.tri) || - (triangleloop.orient != oppooppotri.orient)) { - printf(" !! !! Asymmetric triangle-triangle bond:\n"); - if (triangleloop.tri == oppooppotri.tri) { - printf(" (Right triangle, wrong orientation)\n"); - } - printf(" First "); - printtriangle(m, b, &triangleloop); - printf(" Second (nonreciprocating) "); - printtriangle(m, b, &oppotri); - horrors++; - } - /* Check that both triangles agree on the identities */ - /* of their shared vertices. */ - org(oppotri, oppoorg); - dest(oppotri, oppodest); - if ((triorg != oppodest) || (tridest != oppoorg)) { - printf( - " !! !! Mismatched edge coordinates between two triangles:\n"); - printf(" First mismatched "); - printtriangle(m, b, &triangleloop); - printf(" Second mismatched "); - printtriangle(m, b, &oppotri); - horrors++; - } - } - } - triangleloop.tri = triangletraverse(m); - } - if (horrors == 0) { - if (!b->quiet) { - printf(" In my studied opinion, the mesh appears to be consistent.\n"); - } - } else if (horrors == 1) { - printf(" !! !! !! !! Precisely one festering wound discovered.\n"); - } else { - printf(" !! !! !! !! %d abominations witnessed.\n", horrors); - } - /* Restore the status of exact arithmetic. */ - b->noexact = saveexact; -} - -#endif /* not REDUCED */ - -/*****************************************************************************/ -/* */ -/* checkdelaunay() Ensure that the mesh is (constrained) Delaunay. */ -/* */ -/*****************************************************************************/ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void checkdelaunay(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void checkdelaunay(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri triangleloop; - struct otri oppotri; - struct osub opposubseg; - vertex triorg, tridest, triapex; - vertex oppoapex; - int shouldbedelaunay; - int horrors; - int saveexact; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - /* Temporarily turn on exact arithmetic if it's off. */ - saveexact = b->noexact; - b->noexact = 0; - if (!b->quiet) { - printf(" Checking Delaunay property of mesh...\n"); - } - horrors = 0; - /* Run through the list of triangles, checking each one. */ - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - while (triangleloop.tri != (triangle *)NULL) { - /* Check all three edges of the triangle. */ - for (triangleloop.orient = 0; triangleloop.orient < 3; - triangleloop.orient++) { - org(triangleloop, triorg); - dest(triangleloop, tridest); - apex(triangleloop, triapex); - sym(triangleloop, oppotri); - apex(oppotri, oppoapex); - /* Only test that the edge is locally Delaunay if there is an */ - /* adjoining triangle whose pointer is larger (to ensure that */ - /* each pair isn't tested twice). */ - shouldbedelaunay = - (oppotri.tri != m->dummytri) && !deadtri(oppotri.tri) && - (triangleloop.tri < oppotri.tri) && (triorg != m->infvertex1) && - (triorg != m->infvertex2) && (triorg != m->infvertex3) && - (tridest != m->infvertex1) && (tridest != m->infvertex2) && - (tridest != m->infvertex3) && (triapex != m->infvertex1) && - (triapex != m->infvertex2) && (triapex != m->infvertex3) && - (oppoapex != m->infvertex1) && (oppoapex != m->infvertex2) && - (oppoapex != m->infvertex3); - if (m->checksegments && shouldbedelaunay) { - /* If a subsegment separates the triangles, then the edge is */ - /* constrained, so no local Delaunay test should be done. */ - tspivot(triangleloop, opposubseg); - if (opposubseg.ss != m->dummysub) { - shouldbedelaunay = 0; - } - } - if (shouldbedelaunay) { - if (nonregular(m, b, triorg, tridest, triapex, oppoapex) > 0.0) { - if (!b->weighted) { - printf(" !! !! Non-Delaunay pair of triangles:\n"); - printf(" First non-Delaunay "); - printtriangle(m, b, &triangleloop); - printf(" Second non-Delaunay "); - } else { - printf(" !! !! Non-regular pair of triangles:\n"); - printf(" First non-regular "); - printtriangle(m, b, &triangleloop); - printf(" Second non-regular "); - } - printtriangle(m, b, &oppotri); - horrors++; - } - } - } - triangleloop.tri = triangletraverse(m); - } - if (horrors == 0) { - if (!b->quiet) { - printf(" By virtue of my perceptive intelligence, I declare the mesh " - "Delaunay.\n"); - } - } else if (horrors == 1) { - printf( - " !! !! !! !! Precisely one terrifying transgression identified.\n"); - } else { - printf(" !! !! !! !! %d obscenities viewed with horror.\n", horrors); - } - /* Restore the status of exact arithmetic. */ - b->noexact = saveexact; -} - -#endif /* not REDUCED */ - -/*****************************************************************************/ -/* */ -/* enqueuebadtriang() Add a bad triangle data structure to the end of a */ -/* queue. */ -/* */ -/* The queue is actually a set of 4096 queues. I use multiple queues to */ -/* give priority to smaller angles. I originally implemented a heap, but */ -/* the queues are faster by a larger margin than I'd suspected. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void enqueuebadtriang(struct mesh *m, struct behavior *b, - struct badtriang *badtri) -#else /* not ANSI_DECLARATORS */ -void enqueuebadtriang(m, b, badtri) struct mesh *m; -struct behavior *b; -struct badtriang *badtri; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL length, multiplier; - int exponent, expincrement; - int queuenumber; - int posexponent; - int i; - - if (b->verbose > 2) { - printf(" Queueing bad triangle:\n"); - printf(" (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", - badtri->triangorg[0], badtri->triangorg[1], badtri->triangdest[0], - badtri->triangdest[1], badtri->triangapex[0], badtri->triangapex[1]); - } - - /* Determine the appropriate queue to put the bad triangle into. */ - /* Recall that the key is the square of its shortest edge length. */ - if (badtri->key >= 1.0) { - length = badtri->key; - posexponent = 1; - } else { - /* `badtri->key' is 2.0 to a negative exponent, so we'll record that */ - /* fact and use the reciprocal of `badtri->key', which is > 1.0. */ - length = 1.0 / badtri->key; - posexponent = 0; - } - /* `length' is approximately 2.0 to what exponent? The following code */ - /* determines the answer in time logarithmic in the exponent. */ - exponent = 0; - while (length > 2.0) { - /* Find an approximation by repeated squaring of two. */ - expincrement = 1; - multiplier = 0.5; - while (length * multiplier * multiplier > 1.0) { - expincrement *= 2; - multiplier *= multiplier; - } - /* Reduce the value of `length', then iterate if necessary. */ - exponent += expincrement; - length *= multiplier; - } - /* `length' is approximately squareroot(2.0) to what exponent? */ - exponent = 2.0 * exponent + (length > SQUAREROOTTWO); - /* `exponent' is now in the range 0...2047 for IEEE double precision. */ - /* Choose a queue in the range 0...4095. The shortest edges have the */ - /* highest priority (queue 4095). */ - if (posexponent) { - queuenumber = 2047 - exponent; - } else { - queuenumber = 2048 + exponent; - } - - /* Are we inserting into an empty queue? */ - if (m->queuefront[queuenumber] == (struct badtriang *)NULL) { - /* Yes, we are inserting into an empty queue. */ - /* Will this become the highest-priority queue? */ - if (queuenumber > m->firstnonemptyq) { - /* Yes, this is the highest-priority queue. */ - m->nextnonemptyq[queuenumber] = m->firstnonemptyq; - m->firstnonemptyq = queuenumber; - } else { - /* No, this is not the highest-priority queue. */ - /* Find the queue with next higher priority. */ - i = queuenumber + 1; - while (m->queuefront[i] == (struct badtriang *)NULL) { - i++; - } - /* Mark the newly nonempty queue as following a higher-priority queue. */ - m->nextnonemptyq[queuenumber] = m->nextnonemptyq[i]; - m->nextnonemptyq[i] = queuenumber; - } - /* Put the bad triangle at the beginning of the (empty) queue. */ - m->queuefront[queuenumber] = badtri; - } else { - /* Add the bad triangle to the end of an already nonempty queue. */ - m->queuetail[queuenumber]->nexttriang = badtri; - } - /* Maintain a pointer to the last triangle of the queue. */ - m->queuetail[queuenumber] = badtri; - /* Newly enqueued bad triangle has no successor in the queue. */ - badtri->nexttriang = (struct badtriang *)NULL; -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* enqueuebadtri() Add a bad triangle to the end of a queue. */ -/* */ -/* Allocates a badtriang data structure for the triangle, then passes it to */ -/* enqueuebadtriang(). */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void enqueuebadtri(struct mesh *m, struct behavior *b, struct otri *enqtri, - REAL minedge, vertex enqapex, vertex enqorg, vertex enqdest) -#else /* not ANSI_DECLARATORS */ -void enqueuebadtri(m, b, enqtri, minedge, enqapex, enqorg, - enqdest) struct mesh *m; -struct behavior *b; -struct otri *enqtri; -REAL minedge; -vertex enqapex; -vertex enqorg; -vertex enqdest; -#endif /* not ANSI_DECLARATORS */ - -{ - struct badtriang *newbad; - - /* Allocate space for the bad triangle. */ - newbad = (struct badtriang *)poolalloc(&m->badtriangles); - newbad->poortri = encode(*enqtri); - newbad->key = minedge; - newbad->triangapex = enqapex; - newbad->triangorg = enqorg; - newbad->triangdest = enqdest; - enqueuebadtriang(m, b, newbad); -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* dequeuebadtriang() Remove a triangle from the front of the queue. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -struct badtriang *dequeuebadtriang(struct mesh *m) -#else /* not ANSI_DECLARATORS */ -struct badtriang *dequeuebadtriang(m) -struct mesh *m; -#endif /* not ANSI_DECLARATORS */ - -{ - struct badtriang *result; - - /* If no queues are nonempty, return NULL. */ - if (m->firstnonemptyq < 0) { - return (struct badtriang *)NULL; - } - /* Find the first triangle of the highest-priority queue. */ - result = m->queuefront[m->firstnonemptyq]; - /* Remove the triangle from the queue. */ - m->queuefront[m->firstnonemptyq] = result->nexttriang; - /* If this queue is now empty, note the new highest-priority */ - /* nonempty queue. */ - if (result == m->queuetail[m->firstnonemptyq]) { - m->firstnonemptyq = m->nextnonemptyq[m->firstnonemptyq]; - } - return result; -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* checkseg4encroach() Check a subsegment to see if it is encroached; add */ -/* it to the list if it is. */ -/* */ -/* A subsegment is encroached if there is a vertex in its diametral lens. */ -/* For Ruppert's algorithm (-D switch), the "diametral lens" is the */ -/* diametral circle. For Chew's algorithm (default), the diametral lens is */ -/* just big enough to enclose two isosceles triangles whose bases are the */ -/* subsegment. Each of the two isosceles triangles has two angles equal */ -/* to `b->minangle'. */ -/* */ -/* Chew's algorithm does not require diametral lenses at all--but they save */ -/* time. Any vertex inside a subsegment's diametral lens implies that the */ -/* triangle adjoining the subsegment will be too skinny, so it's only a */ -/* matter of time before the encroaching vertex is deleted by Chew's */ -/* algorithm. It's faster to simply not insert the doomed vertex in the */ -/* first place, which is why I use diametral lenses with Chew's algorithm. */ -/* */ -/* Returns a nonzero value if the subsegment is encroached. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -int checkseg4encroach(struct mesh *m, struct behavior *b, - struct osub *testsubseg) -#else /* not ANSI_DECLARATORS */ -int checkseg4encroach(m, b, testsubseg) -struct mesh *m; -struct behavior *b; -struct osub *testsubseg; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri neighbortri; - struct osub testsym; - struct badsubseg *encroachedseg; - REAL dotproduct; - int encroached; - int sides; - vertex eorg, edest, eapex; - triangle ptr; /* Temporary variable used by stpivot(). */ - - encroached = 0; - sides = 0; - - sorg(*testsubseg, eorg); - sdest(*testsubseg, edest); - /* Check one neighbor of the subsegment. */ - stpivot(*testsubseg, neighbortri); - /* Does the neighbor exist, or is this a boundary edge? */ - if (neighbortri.tri != m->dummytri) { - sides++; - /* Find a vertex opposite this subsegment. */ - apex(neighbortri, eapex); - /* Check whether the apex is in the diametral lens of the subsegment */ - /* (the diametral circle if `conformdel' is set). A dot product */ - /* of two sides of the triangle is used to check whether the angle */ - /* at the apex is greater than (180 - 2 `minangle') degrees (for */ - /* lenses; 90 degrees for diametral circles). */ - dotproduct = (eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + - (eorg[1] - eapex[1]) * (edest[1] - eapex[1]); - if (dotproduct < 0.0) { - if (b->conformdel || - (dotproduct * dotproduct >= - (2.0 * b->goodangle - 1.0) * (2.0 * b->goodangle - 1.0) * - ((eorg[0] - eapex[0]) * (eorg[0] - eapex[0]) + - (eorg[1] - eapex[1]) * (eorg[1] - eapex[1])) * - ((edest[0] - eapex[0]) * (edest[0] - eapex[0]) + - (edest[1] - eapex[1]) * (edest[1] - eapex[1])))) { - encroached = 1; - } - } - } - /* Check the other neighbor of the subsegment. */ - ssym(*testsubseg, testsym); - stpivot(testsym, neighbortri); - /* Does the neighbor exist, or is this a boundary edge? */ - if (neighbortri.tri != m->dummytri) { - sides++; - /* Find the other vertex opposite this subsegment. */ - apex(neighbortri, eapex); - /* Check whether the apex is in the diametral lens of the subsegment */ - /* (or the diametral circle, if `conformdel' is set). */ - dotproduct = (eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + - (eorg[1] - eapex[1]) * (edest[1] - eapex[1]); - if (dotproduct < 0.0) { - if (b->conformdel || - (dotproduct * dotproduct >= - (2.0 * b->goodangle - 1.0) * (2.0 * b->goodangle - 1.0) * - ((eorg[0] - eapex[0]) * (eorg[0] - eapex[0]) + - (eorg[1] - eapex[1]) * (eorg[1] - eapex[1])) * - ((edest[0] - eapex[0]) * (edest[0] - eapex[0]) + - (edest[1] - eapex[1]) * (edest[1] - eapex[1])))) { - encroached += 2; - } - } - } - - if (encroached && (!b->nobisect || ((b->nobisect == 1) && (sides == 2)))) { - if (b->verbose > 2) { - printf( - " Queueing encroached subsegment (%.12g, %.12g) (%.12g, %.12g).\n", - eorg[0], eorg[1], edest[0], edest[1]); - } - /* Add the subsegment to the list of encroached subsegments. */ - /* Be sure to get the orientation right. */ - encroachedseg = (struct badsubseg *)poolalloc(&m->badsubsegs); - if (encroached == 1) { - encroachedseg->encsubseg = sencode(*testsubseg); - encroachedseg->subsegorg = eorg; - encroachedseg->subsegdest = edest; - } else { - encroachedseg->encsubseg = sencode(testsym); - encroachedseg->subsegorg = edest; - encroachedseg->subsegdest = eorg; - } - } - - return encroached; -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* testtriangle() Test a triangle for quality and size. */ -/* */ -/* Tests a triangle to see if it satisfies the minimum angle condition and */ -/* the maximum area condition. Triangles that aren't up to spec are added */ -/* to the bad triangle queue. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void testtriangle(struct mesh *m, struct behavior *b, struct otri *testtri) -#else /* not ANSI_DECLARATORS */ -void testtriangle(m, b, testtri) struct mesh *m; -struct behavior *b; -struct otri *testtri; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri tri1, tri2; - struct osub testsub; - vertex torg, tdest, tapex; - vertex base1, base2; - vertex org1, dest1, org2, dest2; - vertex joinvertex; - REAL dxod, dyod, dxda, dyda, dxao, dyao; - REAL dxod2, dyod2, dxda2, dyda2, dxao2, dyao2; - REAL apexlen, orglen, destlen, minedge; - REAL angle; - REAL area; - REAL dist1, dist2; - subseg sptr; /* Temporary variable used by tspivot(). */ - triangle ptr; /* Temporary variable used by oprev() and dnext(). */ - - org(*testtri, torg); - dest(*testtri, tdest); - apex(*testtri, tapex); - dxod = torg[0] - tdest[0]; - dyod = torg[1] - tdest[1]; - dxda = tdest[0] - tapex[0]; - dyda = tdest[1] - tapex[1]; - dxao = tapex[0] - torg[0]; - dyao = tapex[1] - torg[1]; - dxod2 = dxod * dxod; - dyod2 = dyod * dyod; - dxda2 = dxda * dxda; - dyda2 = dyda * dyda; - dxao2 = dxao * dxao; - dyao2 = dyao * dyao; - /* Find the lengths of the triangle's three edges. */ - apexlen = dxod2 + dyod2; - orglen = dxda2 + dyda2; - destlen = dxao2 + dyao2; - - if ((apexlen < orglen) && (apexlen < destlen)) { - /* The edge opposite the apex is shortest. */ - minedge = apexlen; - /* Find the square of the cosine of the angle at the apex. */ - angle = dxda * dxao + dyda * dyao; - angle = angle * angle / (orglen * destlen); - base1 = torg; - base2 = tdest; - otricopy(*testtri, tri1); - } else if (orglen < destlen) { - /* The edge opposite the origin is shortest. */ - minedge = orglen; - /* Find the square of the cosine of the angle at the origin. */ - angle = dxod * dxao + dyod * dyao; - angle = angle * angle / (apexlen * destlen); - base1 = tdest; - base2 = tapex; - lnext(*testtri, tri1); - } else { - /* The edge opposite the destination is shortest. */ - minedge = destlen; - /* Find the square of the cosine of the angle at the destination. */ - angle = dxod * dxda + dyod * dyda; - angle = angle * angle / (apexlen * orglen); - base1 = tapex; - base2 = torg; - lprev(*testtri, tri1); - } - - if (b->vararea || b->fixedarea || b->usertest) { - /* Check whether the area is larger than permitted. */ - area = 0.5 * (dxod * dyda - dyod * dxda); - if (b->fixedarea && (area > b->maxarea)) { - /* Add this triangle to the list of bad triangles. */ - enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); - return; - } - - /* Nonpositive area constraints are treated as unconstrained. */ - if ((b->vararea) && (area > areabound(*testtri)) && - (areabound(*testtri) > 0.0)) { - /* Add this triangle to the list of bad triangles. */ - enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); - return; - } - - if (b->usertest) { - /* Check whether the user thinks this triangle is too large. */ - if (triunsuitable(torg, tdest, tapex, area)) { - enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); - return; - } - } - } - - /* Check whether the angle is smaller than permitted. */ - if (angle > b->goodangle) { - /* Use the rules of Miller, Pav, and Walkington to decide that certain */ - /* triangles should not be split, even if they have bad angles. */ - /* A skinny triangle is not split if its shortest edge subtends a */ - /* small input angle, and both endpoints of the edge lie on a */ - /* concentric circular shell. For convenience, I make a small */ - /* adjustment to that rule: I check if the endpoints of the edge */ - /* both lie in segment interiors, equidistant from the apex where */ - /* the two segments meet. */ - /* First, check if both points lie in segment interiors. */ - if ((vertextype(base1) == SEGMENTVERTEX) && - (vertextype(base2) == SEGMENTVERTEX)) { - /* Check if both points lie in a common segment. If they do, the */ - /* skinny triangle is enqueued to be split as usual. */ - tspivot(tri1, testsub); - if (testsub.ss == m->dummysub) { - /* No common segment. Find a subsegment that contains `torg'. */ - otricopy(tri1, tri2); - do { - oprevself(tri1); - tspivot(tri1, testsub); - } while (testsub.ss == m->dummysub); - /* Find the endpoints of the containing segment. */ - segorg(testsub, org1); - segdest(testsub, dest1); - /* Find a subsegment that contains `tdest'. */ - do { - dnextself(tri2); - tspivot(tri2, testsub); - } while (testsub.ss == m->dummysub); - /* Find the endpoints of the containing segment. */ - segorg(testsub, org2); - segdest(testsub, dest2); - /* Check if the two containing segments have an endpoint in common. */ - joinvertex = (vertex)NULL; - if ((dest1[0] == org2[0]) && (dest1[1] == org2[1])) { - joinvertex = dest1; - } else if ((org1[0] == dest2[0]) && (org1[1] == dest2[1])) { - joinvertex = org1; - } - if (joinvertex != (vertex)NULL) { - /* Compute the distance from the common endpoint (of the two */ - /* segments) to each of the endpoints of the shortest edge. */ - dist1 = ((base1[0] - joinvertex[0]) * (base1[0] - joinvertex[0]) + - (base1[1] - joinvertex[1]) * (base1[1] - joinvertex[1])); - dist2 = ((base2[0] - joinvertex[0]) * (base2[0] - joinvertex[0]) + - (base2[1] - joinvertex[1]) * (base2[1] - joinvertex[1])); - /* If the two distances are equal, don't split the triangle. */ - if ((dist1 < 1.001 * dist2) && (dist1 > 0.999 * dist2)) { - /* Return now to avoid enqueueing the bad triangle. */ - return; - } - } - } - } - - /* Add this triangle to the list of bad triangles. */ - enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); - } -} - -#endif /* not CDT_ONLY */ - -/** **/ -/** **/ -/********* Mesh quality testing routines end here *********/ - -/********* Point location routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* makevertexmap() Construct a mapping from vertices to triangles to */ -/* improve the speed of point location for segment */ -/* insertion. */ -/* */ -/* Traverses all the triangles, and provides each corner of each triangle */ -/* with a pointer to that triangle. Of course, pointers will be */ -/* overwritten by other pointers because (almost) each vertex is a corner */ -/* of several triangles, but in the end every vertex will point to some */ -/* triangle that contains it. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void makevertexmap(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void makevertexmap(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri triangleloop; - vertex triorg; - - if (b->verbose) { - printf(" Constructing mapping from vertices to triangles.\n"); - } - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - while (triangleloop.tri != (triangle *)NULL) { - /* Check all three vertices of the triangle. */ - for (triangleloop.orient = 0; triangleloop.orient < 3; - triangleloop.orient++) { - org(triangleloop, triorg); - setvertex2tri(triorg, encode(triangleloop)); - } - triangleloop.tri = triangletraverse(m); - } -} - -/*****************************************************************************/ -/* */ -/* preciselocate() Find a triangle or edge containing a given point. */ -/* */ -/* Begins its search from `searchtri'. It is important that `searchtri' */ -/* be a handle with the property that `searchpoint' is strictly to the left */ -/* of the edge denoted by `searchtri', or is collinear with that edge and */ -/* does not intersect that edge. (In particular, `searchpoint' should not */ -/* be the origin or destination of that edge.) */ -/* */ -/* These conditions are imposed because preciselocate() is normally used in */ -/* one of two situations: */ -/* */ -/* (1) To try to find the location to insert a new point. Normally, we */ -/* know an edge that the point is strictly to the left of. In the */ -/* incremental Delaunay algorithm, that edge is a bounding box edge. */ -/* In Ruppert's Delaunay refinement algorithm for quality meshing, */ -/* that edge is the shortest edge of the triangle whose circumcenter */ -/* is being inserted. */ -/* */ -/* (2) To try to find an existing point. In this case, any edge on the */ -/* convex hull is a good starting edge. You must screen out the */ -/* possibility that the vertex sought is an endpoint of the starting */ -/* edge before you call preciselocate(). */ -/* */ -/* On completion, `searchtri' is a triangle that contains `searchpoint'. */ -/* */ -/* This implementation differs from that given by Guibas and Stolfi. It */ -/* walks from triangle to triangle, crossing an edge only if `searchpoint' */ -/* is on the other side of the line containing that edge. After entering */ -/* a triangle, there are two edges by which one can leave that triangle. */ -/* If both edges are valid (`searchpoint' is on the other side of both */ -/* edges), one of the two is chosen by drawing a line perpendicular to */ -/* the entry edge (whose endpoints are `forg' and `fdest') passing through */ -/* `fapex'. Depending on which side of this perpendicular `searchpoint' */ -/* falls on, an exit edge is chosen. */ -/* */ -/* This implementation is empirically faster than the Guibas and Stolfi */ -/* point location routine (which I originally used), which tends to spiral */ -/* in toward its target. */ -/* */ -/* Returns ONVERTEX if the point lies on an existing vertex. `searchtri' */ -/* is a handle whose origin is the existing vertex. */ -/* */ -/* Returns ONEDGE if the point lies on a mesh edge. `searchtri' is a */ -/* handle whose primary edge is the edge on which the point lies. */ -/* */ -/* Returns INTRIANGLE if the point lies strictly within a triangle. */ -/* `searchtri' is a handle on the triangle that contains the point. */ -/* */ -/* Returns OUTSIDE if the point lies outside the mesh. `searchtri' is a */ -/* handle whose primary edge the point is to the right of. This might */ -/* occur when the circumcenter of a triangle falls just slightly outside */ -/* the mesh due to floating-point roundoff error. It also occurs when */ -/* seeking a hole or region point that a foolish user has placed outside */ -/* the mesh. */ -/* */ -/* If `stopatsubsegment' is nonzero, the search will stop if it tries to */ -/* walk through a subsegment, and will return OUTSIDE. */ -/* */ -/* WARNING: This routine is designed for convex triangulations, and will */ -/* not generally work after the holes and concavities have been carved. */ -/* However, it can still be used to find the circumcenter of a triangle, as */ -/* long as the search is begun from the triangle in question. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -enum locateresult preciselocate(struct mesh *m, struct behavior *b, - vertex searchpoint, struct otri *searchtri, - int stopatsubsegment) -#else /* not ANSI_DECLARATORS */ -enum locateresult preciselocate(m, b, searchpoint, searchtri, stopatsubsegment) -struct mesh *m; -struct behavior *b; -vertex searchpoint; -struct otri *searchtri; -int stopatsubsegment; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri backtracktri; - struct osub checkedge; - vertex forg, fdest, fapex; - REAL orgorient, destorient; - int moveleft; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - if (b->verbose > 2) { - printf(" Searching for point (%.12g, %.12g).\n", searchpoint[0], - searchpoint[1]); - } - /* Where are we? */ - org(*searchtri, forg); - dest(*searchtri, fdest); - apex(*searchtri, fapex); - while (1) { - if (b->verbose > 2) { - printf(" At (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", forg[0], - forg[1], fdest[0], fdest[1], fapex[0], fapex[1]); - } - /* Check whether the apex is the point we seek. */ - if ((fapex[0] == searchpoint[0]) && (fapex[1] == searchpoint[1])) { - lprevself(*searchtri); - return ONVERTEX; - } - /* Does the point lie on the other side of the line defined by the */ - /* triangle edge opposite the triangle's destination? */ - destorient = counterclockwise(m, b, forg, fapex, searchpoint); - /* Does the point lie on the other side of the line defined by the */ - /* triangle edge opposite the triangle's origin? */ - orgorient = counterclockwise(m, b, fapex, fdest, searchpoint); - if (destorient > 0.0) { - if (orgorient > 0.0) { - /* Move left if the inner product of (fapex - searchpoint) and */ - /* (fdest - forg) is positive. This is equivalent to drawing */ - /* a line perpendicular to the line (forg, fdest) and passing */ - /* through `fapex', and determining which side of this line */ - /* `searchpoint' falls on. */ - moveleft = (fapex[0] - searchpoint[0]) * (fdest[0] - forg[0]) + - (fapex[1] - searchpoint[1]) * (fdest[1] - forg[1]) > - 0.0; - } else { - moveleft = 1; - } - } else { - if (orgorient > 0.0) { - moveleft = 0; - } else { - /* The point we seek must be on the boundary of or inside this */ - /* triangle. */ - if (destorient == 0.0) { - lprevself(*searchtri); - return ONEDGE; - } - if (orgorient == 0.0) { - lnextself(*searchtri); - return ONEDGE; - } - return INTRIANGLE; - } - } - - /* Move to another triangle. Leave a trace `backtracktri' in case */ - /* floating-point roundoff or some such bogey causes us to walk */ - /* off a boundary of the triangulation. */ - if (moveleft) { - lprev(*searchtri, backtracktri); - fdest = fapex; - } else { - lnext(*searchtri, backtracktri); - forg = fapex; - } - sym(backtracktri, *searchtri); - - if (m->checksegments && stopatsubsegment) { - /* Check for walking through a subsegment. */ - tspivot(backtracktri, checkedge); - if (checkedge.ss != m->dummysub) { - /* Go back to the last triangle. */ - otricopy(backtracktri, *searchtri); - return OUTSIDE; - } - } - /* Check for walking right out of the triangulation. */ - if (searchtri->tri == m->dummytri) { - /* Go back to the last triangle. */ - otricopy(backtracktri, *searchtri); - return OUTSIDE; - } - - apex(*searchtri, fapex); - } -} - -/*****************************************************************************/ -/* */ -/* locate() Find a triangle or edge containing a given point. */ -/* */ -/* Searching begins from one of: the input `searchtri', a recently */ -/* encountered triangle `recenttri', or from a triangle chosen from a */ -/* random sample. The choice is made by determining which triangle's */ -/* origin is closest to the point we are searching for. Normally, */ -/* `searchtri' should be a handle on the convex hull of the triangulation. */ -/* */ -/* Details on the random sampling method can be found in the Mucke, Saias, */ -/* and Zhu paper cited in the header of this code. */ -/* */ -/* On completion, `searchtri' is a triangle that contains `searchpoint'. */ -/* */ -/* Returns ONVERTEX if the point lies on an existing vertex. `searchtri' */ -/* is a handle whose origin is the existing vertex. */ -/* */ -/* Returns ONEDGE if the point lies on a mesh edge. `searchtri' is a */ -/* handle whose primary edge is the edge on which the point lies. */ -/* */ -/* Returns INTRIANGLE if the point lies strictly within a triangle. */ -/* `searchtri' is a handle on the triangle that contains the point. */ -/* */ -/* Returns OUTSIDE if the point lies outside the mesh. `searchtri' is a */ -/* handle whose primary edge the point is to the right of. This might */ -/* occur when the circumcenter of a triangle falls just slightly outside */ -/* the mesh due to floating-point roundoff error. It also occurs when */ -/* seeking a hole or region point that a foolish user has placed outside */ -/* the mesh. */ -/* */ -/* WARNING: This routine is designed for convex triangulations, and will */ -/* not generally work after the holes and concavities have been carved. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -enum locateresult locate(struct mesh *m, struct behavior *b, vertex searchpoint, - struct otri *searchtri) -#else /* not ANSI_DECLARATORS */ -enum locateresult locate(m, b, searchpoint, searchtri) -struct mesh *m; -struct behavior *b; -vertex searchpoint; -struct otri *searchtri; -#endif /* not ANSI_DECLARATORS */ - -{ - VOID **sampleblock; - char *firsttri; - struct otri sampletri; - vertex torg, tdest; - unsigned long alignptr; - REAL searchdist, dist; - REAL ahead; - long samplesperblock, totalsamplesleft, samplesleft; - long population, totalpopulation; - triangle ptr; /* Temporary variable used by sym(). */ - - if (b->verbose > 2) { - printf(" Randomly sampling for a triangle near point (%.12g, %.12g).\n", - searchpoint[0], searchpoint[1]); - } - /* Record the distance from the suggested starting triangle to the */ - /* point we seek. */ - org(*searchtri, torg); - searchdist = (searchpoint[0] - torg[0]) * (searchpoint[0] - torg[0]) + - (searchpoint[1] - torg[1]) * (searchpoint[1] - torg[1]); - if (b->verbose > 2) { - printf(" Boundary triangle has origin (%.12g, %.12g).\n", torg[0], - torg[1]); - } - - /* If a recently encountered triangle has been recorded and has not been */ - /* deallocated, test it as a good starting point. */ - if (m->recenttri.tri != (triangle *)NULL) { - if (!deadtri(m->recenttri.tri)) { - org(m->recenttri, torg); - if ((torg[0] == searchpoint[0]) && (torg[1] == searchpoint[1])) { - otricopy(m->recenttri, *searchtri); - return ONVERTEX; - } - dist = (searchpoint[0] - torg[0]) * (searchpoint[0] - torg[0]) + - (searchpoint[1] - torg[1]) * (searchpoint[1] - torg[1]); - if (dist < searchdist) { - otricopy(m->recenttri, *searchtri); - searchdist = dist; - if (b->verbose > 2) { - printf(" Choosing recent triangle with origin (%.12g, %.12g).\n", - torg[0], torg[1]); - } - } - } - } - - /* The number of random samples taken is proportional to the cube root of */ - /* the number of triangles in the mesh. The next bit of code assumes */ - /* that the number of triangles increases monotonically (or at least */ - /* doesn't decrease enough to matter). */ - while (SAMPLEFACTOR * m->samples * m->samples * m->samples < - m->triangles.items) { - m->samples++; - } - - /* We'll draw ceiling(samples * TRIPERBLOCK / maxitems) random samples */ - /* from each block of triangles (except the first)--until we meet the */ - /* sample quota. The ceiling means that blocks at the end might be */ - /* neglected, but I don't care. */ - samplesperblock = (m->samples * TRIPERBLOCK - 1) / m->triangles.maxitems + 1; - /* We'll draw ceiling(samples * itemsfirstblock / maxitems) random samples */ - /* from the first block of triangles. */ - samplesleft = - (m->samples * m->triangles.itemsfirstblock - 1) / m->triangles.maxitems + - 1; - totalsamplesleft = m->samples; - population = m->triangles.itemsfirstblock; - totalpopulation = m->triangles.maxitems; - sampleblock = m->triangles.firstblock; - sampletri.orient = 0; - while (totalsamplesleft > 0) { - /* If we're in the last block, `population' needs to be corrected. */ - if (population > totalpopulation) { - population = totalpopulation; - } - /* Find a pointer to the first triangle in the block. */ - alignptr = (unsigned long)(sampleblock + 1); - firsttri = (char *)(alignptr + (unsigned long)m->triangles.alignbytes - - (alignptr % (unsigned long)m->triangles.alignbytes)); - - /* Choose `samplesleft' randomly sampled triangles in this block. */ - do { - sampletri.tri = - (triangle *)(firsttri + (randomnation((unsigned int)population) * - m->triangles.itembytes)); - if (!deadtri(sampletri.tri)) { - org(sampletri, torg); - dist = (searchpoint[0] - torg[0]) * (searchpoint[0] - torg[0]) + - (searchpoint[1] - torg[1]) * (searchpoint[1] - torg[1]); - if (dist < searchdist) { - otricopy(sampletri, *searchtri); - searchdist = dist; - if (b->verbose > 2) { - printf(" Choosing triangle with origin (%.12g, %.12g).\n", - torg[0], torg[1]); - } - } - } - - samplesleft--; - totalsamplesleft--; - } while ((samplesleft > 0) && (totalsamplesleft > 0)); - - if (totalsamplesleft > 0) { - sampleblock = (VOID **)*sampleblock; - samplesleft = samplesperblock; - totalpopulation -= population; - population = TRIPERBLOCK; - } - } - - /* Where are we? */ - org(*searchtri, torg); - dest(*searchtri, tdest); - /* Check the starting triangle's vertices. */ - if ((torg[0] == searchpoint[0]) && (torg[1] == searchpoint[1])) { - return ONVERTEX; - } - if ((tdest[0] == searchpoint[0]) && (tdest[1] == searchpoint[1])) { - lnextself(*searchtri); - return ONVERTEX; - } - /* Orient `searchtri' to fit the preconditions of calling preciselocate(). */ - ahead = counterclockwise(m, b, torg, tdest, searchpoint); - if (ahead < 0.0) { - /* Turn around so that `searchpoint' is to the left of the */ - /* edge specified by `searchtri'. */ - symself(*searchtri); - } else if (ahead == 0.0) { - /* Check if `searchpoint' is between `torg' and `tdest'. */ - if (((torg[0] < searchpoint[0]) == (searchpoint[0] < tdest[0])) && - ((torg[1] < searchpoint[1]) == (searchpoint[1] < tdest[1]))) { - return ONEDGE; - } - } - return preciselocate(m, b, searchpoint, searchtri, 0); -} - -/** **/ -/** **/ -/********* Point location routines end here *********/ - -/********* Mesh transformation routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* insertsubseg() Create a new subsegment and insert it between two */ -/* triangles. */ -/* */ -/* The new subsegment is inserted at the edge described by the handle */ -/* `tri'. Its vertices are properly initialized. The marker `subsegmark' */ -/* is applied to the subsegment and, if appropriate, its vertices. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void insertsubseg(struct mesh *m, struct behavior *b, struct otri *tri, - int subsegmark) -#else /* not ANSI_DECLARATORS */ -void insertsubseg(m, b, tri, subsegmark) struct mesh *m; -struct behavior *b; -struct otri *tri; /* Edge at which to insert the new subsegment. */ -int subsegmark; /* Marker for the new subsegment. */ -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri oppotri; - struct osub newsubseg; - vertex triorg, tridest; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - org(*tri, triorg); - dest(*tri, tridest); - /* Mark vertices if possible. */ - if (vertexmark(triorg) == 0) { - setvertexmark(triorg, subsegmark); - } - if (vertexmark(tridest) == 0) { - setvertexmark(tridest, subsegmark); - } - /* Check if there's already a subsegment here. */ - tspivot(*tri, newsubseg); - if (newsubseg.ss == m->dummysub) { - /* Make new subsegment and initialize its vertices. */ - makesubseg(m, &newsubseg); - setsorg(newsubseg, tridest); - setsdest(newsubseg, triorg); - setsegorg(newsubseg, tridest); - setsegdest(newsubseg, triorg); - /* Bond new subsegment to the two triangles it is sandwiched between. */ - /* Note that the facing triangle `oppotri' might be equal to */ - /* `dummytri' (outer space), but the new subsegment is bonded to it */ - /* all the same. */ - tsbond(*tri, newsubseg); - sym(*tri, oppotri); - ssymself(newsubseg); - tsbond(oppotri, newsubseg); - setmark(newsubseg, subsegmark); - if (b->verbose > 2) { - printf(" Inserting new "); - printsubseg(m, b, &newsubseg); - } - } else { - if (mark(newsubseg) == 0) { - setmark(newsubseg, subsegmark); - } - } -} - -/*****************************************************************************/ -/* */ -/* Terminology */ -/* */ -/* A "local transformation" replaces a small set of triangles with another */ -/* set of triangles. This may or may not involve inserting or deleting a */ -/* vertex. */ -/* */ -/* The term "casing" is used to describe the set of triangles that are */ -/* attached to the triangles being transformed, but are not transformed */ -/* themselves. Think of the casing as a fixed hollow structure inside */ -/* which all the action happens. A "casing" is only defined relative to */ -/* a single transformation; each occurrence of a transformation will */ -/* involve a different casing. */ -/* */ -/*****************************************************************************/ - -/*****************************************************************************/ -/* */ -/* flip() Transform two triangles to two different triangles by flipping */ -/* an edge counterclockwise within a quadrilateral. */ -/* */ -/* Imagine the original triangles, abc and bad, oriented so that the */ -/* shared edge ab lies in a horizontal plane, with the vertex b on the left */ -/* and the vertex a on the right. The vertex c lies below the edge, and */ -/* the vertex d lies above the edge. The `flipedge' handle holds the edge */ -/* ab of triangle abc, and is directed left, from vertex a to vertex b. */ -/* */ -/* The triangles abc and bad are deleted and replaced by the triangles cdb */ -/* and dca. The triangles that represent abc and bad are NOT deallocated; */ -/* they are reused for dca and cdb, respectively. Hence, any handles that */ -/* may have held the original triangles are still valid, although not */ -/* directed as they were before. */ -/* */ -/* Upon completion of this routine, the `flipedge' handle holds the edge */ -/* dc of triangle dca, and is directed down, from vertex d to vertex c. */ -/* (Hence, the two triangles have rotated counterclockwise.) */ -/* */ -/* WARNING: This transformation is geometrically valid only if the */ -/* quadrilateral adbc is convex. Furthermore, this transformation is */ -/* valid only if there is not a subsegment between the triangles abc and */ -/* bad. This routine does not check either of these preconditions, and */ -/* it is the responsibility of the calling routine to ensure that they are */ -/* met. If they are not, the streets shall be filled with wailing and */ -/* gnashing of teeth. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void flip(struct mesh *m, struct behavior *b, struct otri *flipedge) -#else /* not ANSI_DECLARATORS */ -void flip(m, b, flipedge) struct mesh *m; -struct behavior *b; -struct otri *flipedge; /* Handle for the triangle abc. */ -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri botleft, botright; - struct otri topleft, topright; - struct otri top; - struct otri botlcasing, botrcasing; - struct otri toplcasing, toprcasing; - struct osub botlsubseg, botrsubseg; - struct osub toplsubseg, toprsubseg; - vertex leftvertex, rightvertex, botvertex; - vertex farvertex; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - /* Identify the vertices of the quadrilateral. */ - org(*flipedge, rightvertex); - dest(*flipedge, leftvertex); - apex(*flipedge, botvertex); - sym(*flipedge, top); -#ifdef SELF_CHECK - if (top.tri == m->dummytri) { - printf("Internal error in flip(): Attempt to flip on boundary.\n"); - lnextself(*flipedge); - return; - } - if (m->checksegments) { - tspivot(*flipedge, toplsubseg); - if (toplsubseg.ss != m->dummysub) { - printf("Internal error in flip(): Attempt to flip a segment.\n"); - lnextself(*flipedge); - return; - } - } -#endif /* SELF_CHECK */ - apex(top, farvertex); - - /* Identify the casing of the quadrilateral. */ - lprev(top, topleft); - sym(topleft, toplcasing); - lnext(top, topright); - sym(topright, toprcasing); - lnext(*flipedge, botleft); - sym(botleft, botlcasing); - lprev(*flipedge, botright); - sym(botright, botrcasing); - /* Rotate the quadrilateral one-quarter turn counterclockwise. */ - bond(topleft, botlcasing); - bond(botleft, botrcasing); - bond(botright, toprcasing); - bond(topright, toplcasing); - - if (m->checksegments) { - /* Check for subsegments and rebond them to the quadrilateral. */ - tspivot(topleft, toplsubseg); - tspivot(botleft, botlsubseg); - tspivot(botright, botrsubseg); - tspivot(topright, toprsubseg); - if (toplsubseg.ss == m->dummysub) { - tsdissolve(topright); - } else { - tsbond(topright, toplsubseg); - } - if (botlsubseg.ss == m->dummysub) { - tsdissolve(topleft); - } else { - tsbond(topleft, botlsubseg); - } - if (botrsubseg.ss == m->dummysub) { - tsdissolve(botleft); - } else { - tsbond(botleft, botrsubseg); - } - if (toprsubseg.ss == m->dummysub) { - tsdissolve(botright); - } else { - tsbond(botright, toprsubseg); - } - } - - /* New vertex assignments for the rotated quadrilateral. */ - setorg(*flipedge, farvertex); - setdest(*flipedge, botvertex); - setapex(*flipedge, rightvertex); - setorg(top, botvertex); - setdest(top, farvertex); - setapex(top, leftvertex); - if (b->verbose > 2) { - printf(" Edge flip results in left "); - printtriangle(m, b, &top); - printf(" and right "); - printtriangle(m, b, flipedge); - } -} - -/*****************************************************************************/ -/* */ -/* unflip() Transform two triangles to two different triangles by */ -/* flipping an edge clockwise within a quadrilateral. Reverses */ -/* the flip() operation so that the data structures representing */ -/* the triangles are back where they were before the flip(). */ -/* */ -/* Imagine the original triangles, abc and bad, oriented so that the */ -/* shared edge ab lies in a horizontal plane, with the vertex b on the left */ -/* and the vertex a on the right. The vertex c lies below the edge, and */ -/* the vertex d lies above the edge. The `flipedge' handle holds the edge */ -/* ab of triangle abc, and is directed left, from vertex a to vertex b. */ -/* */ -/* The triangles abc and bad are deleted and replaced by the triangles cdb */ -/* and dca. The triangles that represent abc and bad are NOT deallocated; */ -/* they are reused for cdb and dca, respectively. Hence, any handles that */ -/* may have held the original triangles are still valid, although not */ -/* directed as they were before. */ -/* */ -/* Upon completion of this routine, the `flipedge' handle holds the edge */ -/* cd of triangle cdb, and is directed up, from vertex c to vertex d. */ -/* (Hence, the two triangles have rotated clockwise.) */ -/* */ -/* WARNING: This transformation is geometrically valid only if the */ -/* quadrilateral adbc is convex. Furthermore, this transformation is */ -/* valid only if there is not a subsegment between the triangles abc and */ -/* bad. This routine does not check either of these preconditions, and */ -/* it is the responsibility of the calling routine to ensure that they are */ -/* met. If they are not, the streets shall be filled with wailing and */ -/* gnashing of teeth. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void unflip(struct mesh *m, struct behavior *b, struct otri *flipedge) -#else /* not ANSI_DECLARATORS */ -void unflip(m, b, flipedge) struct mesh *m; -struct behavior *b; -struct otri *flipedge; /* Handle for the triangle abc. */ -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri botleft, botright; - struct otri topleft, topright; - struct otri top; - struct otri botlcasing, botrcasing; - struct otri toplcasing, toprcasing; - struct osub botlsubseg, botrsubseg; - struct osub toplsubseg, toprsubseg; - vertex leftvertex, rightvertex, botvertex; - vertex farvertex; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - /* Identify the vertices of the quadrilateral. */ - org(*flipedge, rightvertex); - dest(*flipedge, leftvertex); - apex(*flipedge, botvertex); - sym(*flipedge, top); -#ifdef SELF_CHECK - if (top.tri == m->dummytri) { - printf("Internal error in unflip(): Attempt to flip on boundary.\n"); - lnextself(*flipedge); - return; - } - if (m->checksegments) { - tspivot(*flipedge, toplsubseg); - if (toplsubseg.ss != m->dummysub) { - printf("Internal error in unflip(): Attempt to flip a subsegment.\n"); - lnextself(*flipedge); - return; - } - } -#endif /* SELF_CHECK */ - apex(top, farvertex); - - /* Identify the casing of the quadrilateral. */ - lprev(top, topleft); - sym(topleft, toplcasing); - lnext(top, topright); - sym(topright, toprcasing); - lnext(*flipedge, botleft); - sym(botleft, botlcasing); - lprev(*flipedge, botright); - sym(botright, botrcasing); - /* Rotate the quadrilateral one-quarter turn clockwise. */ - bond(topleft, toprcasing); - bond(botleft, toplcasing); - bond(botright, botlcasing); - bond(topright, botrcasing); - - if (m->checksegments) { - /* Check for subsegments and rebond them to the quadrilateral. */ - tspivot(topleft, toplsubseg); - tspivot(botleft, botlsubseg); - tspivot(botright, botrsubseg); - tspivot(topright, toprsubseg); - if (toplsubseg.ss == m->dummysub) { - tsdissolve(botleft); - } else { - tsbond(botleft, toplsubseg); - } - if (botlsubseg.ss == m->dummysub) { - tsdissolve(botright); - } else { - tsbond(botright, botlsubseg); - } - if (botrsubseg.ss == m->dummysub) { - tsdissolve(topright); - } else { - tsbond(topright, botrsubseg); - } - if (toprsubseg.ss == m->dummysub) { - tsdissolve(topleft); - } else { - tsbond(topleft, toprsubseg); - } - } - - /* New vertex assignments for the rotated quadrilateral. */ - setorg(*flipedge, botvertex); - setdest(*flipedge, farvertex); - setapex(*flipedge, leftvertex); - setorg(top, farvertex); - setdest(top, botvertex); - setapex(top, rightvertex); - if (b->verbose > 2) { - printf(" Edge unflip results in left "); - printtriangle(m, b, flipedge); - printf(" and right "); - printtriangle(m, b, &top); - } -} - -/*****************************************************************************/ -/* */ -/* insertvertex() Insert a vertex into a Delaunay triangulation, */ -/* performing flips as necessary to maintain the Delaunay */ -/* property. */ -/* */ -/* The point `insertvertex' is located. If `searchtri.tri' is not NULL, */ -/* the search for the containing triangle begins from `searchtri'. If */ -/* `searchtri.tri' is NULL, a full point location procedure is called. */ -/* If `insertvertex' is found inside a triangle, the triangle is split into */ -/* three; if `insertvertex' lies on an edge, the edge is split in two, */ -/* thereby splitting the two adjacent triangles into four. Edge flips are */ -/* used to restore the Delaunay property. If `insertvertex' lies on an */ -/* existing vertex, no action is taken, and the value DUPLICATEVERTEX is */ -/* returned. On return, `searchtri' is set to a handle whose origin is the */ -/* existing vertex. */ -/* */ -/* Normally, the parameter `splitseg' is set to NULL, implying that no */ -/* subsegment should be split. In this case, if `insertvertex' is found to */ -/* lie on a segment, no action is taken, and the value VIOLATINGVERTEX is */ -/* returned. On return, `searchtri' is set to a handle whose primary edge */ -/* is the violated subsegment. */ -/* */ -/* If the calling routine wishes to split a subsegment by inserting a */ -/* vertex in it, the parameter `splitseg' should be that subsegment. In */ -/* this case, `searchtri' MUST be the triangle handle reached by pivoting */ -/* from that subsegment; no point location is done. */ -/* */ -/* `segmentflaws' and `triflaws' are flags that indicate whether or not */ -/* there should be checks for the creation of encroached subsegments or bad */ -/* quality triangles. If a newly inserted vertex encroaches upon */ -/* subsegments, these subsegments are added to the list of subsegments to */ -/* be split if `segmentflaws' is set. If bad triangles are created, these */ -/* are added to the queue if `triflaws' is set. */ -/* */ -/* If a duplicate vertex or violated segment does not prevent the vertex */ -/* from being inserted, the return value will be ENCROACHINGVERTEX if the */ -/* vertex encroaches upon a subsegment (and checking is enabled), or */ -/* SUCCESSFULVERTEX otherwise. In either case, `searchtri' is set to a */ -/* handle whose origin is the newly inserted vertex. */ -/* */ -/* insertvertex() does not use flip() for reasons of speed; some */ -/* information can be reused from edge flip to edge flip, like the */ -/* locations of subsegments. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -enum insertvertexresult insertvertex(struct mesh *m, struct behavior *b, - vertex newvertex, struct otri *searchtri, - struct osub *splitseg, int segmentflaws, - int triflaws) -#else /* not ANSI_DECLARATORS */ -enum insertvertexresult insertvertex(m, b, newvertex, searchtri, splitseg, - segmentflaws, triflaws) -struct mesh *m; -struct behavior *b; -vertex newvertex; -struct otri *searchtri; -struct osub *splitseg; -int segmentflaws; -int triflaws; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri horiz; - struct otri top; - struct otri botleft, botright; - struct otri topleft, topright; - struct otri newbotleft, newbotright; - struct otri newtopright; - struct otri botlcasing, botrcasing; - struct otri toplcasing, toprcasing; - struct otri testtri; - struct osub botlsubseg, botrsubseg; - struct osub toplsubseg, toprsubseg; - struct osub brokensubseg; - struct osub checksubseg; - struct osub rightsubseg; - struct osub newsubseg; - struct badsubseg *encroached; - struct flipstacker *newflip; - vertex first; - vertex leftvertex, rightvertex, botvertex, topvertex, farvertex; - vertex segmentorg, segmentdest; - REAL attrib; - REAL area; - enum insertvertexresult success; - enum locateresult intersect; - int doflip; - int mirrorflag; - int enq; - int i; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by spivot() and tspivot(). */ - - if (b->verbose > 1) { - printf(" Inserting (%.12g, %.12g).\n", newvertex[0], newvertex[1]); - } - - if (splitseg == (struct osub *)NULL) { - /* Find the location of the vertex to be inserted. Check if a good */ - /* starting triangle has already been provided by the caller. */ - if (searchtri->tri == m->dummytri) { - /* Find a boundary triangle. */ - horiz.tri = m->dummytri; - horiz.orient = 0; - symself(horiz); - /* Search for a triangle containing `newvertex'. */ - intersect = locate(m, b, newvertex, &horiz); - } else { - /* Start searching from the triangle provided by the caller. */ - otricopy(*searchtri, horiz); - intersect = preciselocate(m, b, newvertex, &horiz, 1); - } - } else { - /* The calling routine provides the subsegment in which */ - /* the vertex is inserted. */ - otricopy(*searchtri, horiz); - intersect = ONEDGE; - } - - if (intersect == ONVERTEX) { - /* There's already a vertex there. Return in `searchtri' a triangle */ - /* whose origin is the existing vertex. */ - otricopy(horiz, *searchtri); - otricopy(horiz, m->recenttri); - return DUPLICATEVERTEX; - } - if ((intersect == ONEDGE) || (intersect == OUTSIDE)) { - /* The vertex falls on an edge or boundary. */ - if (m->checksegments && (splitseg == (struct osub *)NULL)) { - /* Check whether the vertex falls on a subsegment. */ - tspivot(horiz, brokensubseg); - if (brokensubseg.ss != m->dummysub) { - /* The vertex falls on a subsegment, and hence will not be inserted. */ - if (segmentflaws) { - enq = b->nobisect != 2; - if (enq && (b->nobisect == 1)) { - /* This subsegment may be split only if it is an */ - /* internal boundary. */ - sym(horiz, testtri); - enq = testtri.tri != m->dummytri; - } - if (enq) { - /* Add the subsegment to the list of encroached subsegments. */ - encroached = (struct badsubseg *)poolalloc(&m->badsubsegs); - encroached->encsubseg = sencode(brokensubseg); - sorg(brokensubseg, encroached->subsegorg); - sdest(brokensubseg, encroached->subsegdest); - if (b->verbose > 2) { - printf(" Queueing encroached subsegment (%.12g, %.12g) (%.12g, " - "%.12g).\n", - encroached->subsegorg[0], encroached->subsegorg[1], - encroached->subsegdest[0], encroached->subsegdest[1]); - } - } - } - /* Return a handle whose primary edge contains the vertex, */ - /* which has not been inserted. */ - otricopy(horiz, *searchtri); - otricopy(horiz, m->recenttri); - return VIOLATINGVERTEX; - } - } - - /* Insert the vertex on an edge, dividing one triangle into two (if */ - /* the edge lies on a boundary) or two triangles into four. */ - lprev(horiz, botright); - sym(botright, botrcasing); - sym(horiz, topright); - /* Is there a second triangle? (Or does this edge lie on a boundary?) */ - mirrorflag = topright.tri != m->dummytri; - if (mirrorflag) { - lnextself(topright); - sym(topright, toprcasing); - maketriangle(m, b, &newtopright); - } else { - /* Splitting a boundary edge increases the number of boundary edges. */ - m->hullsize++; - } - maketriangle(m, b, &newbotright); - - /* Set the vertices of changed and new triangles. */ - org(horiz, rightvertex); - dest(horiz, leftvertex); - apex(horiz, botvertex); - setorg(newbotright, botvertex); - setdest(newbotright, rightvertex); - setapex(newbotright, newvertex); - setorg(horiz, newvertex); - for (i = 0; i < m->eextras; i++) { - /* Set the element attributes of a new triangle. */ - setelemattribute(newbotright, i, elemattribute(botright, i)); - } - if (b->vararea) { - /* Set the area constraint of a new triangle. */ - setareabound(newbotright, areabound(botright)); - } - if (mirrorflag) { - dest(topright, topvertex); - setorg(newtopright, rightvertex); - setdest(newtopright, topvertex); - setapex(newtopright, newvertex); - setorg(topright, newvertex); - for (i = 0; i < m->eextras; i++) { - /* Set the element attributes of another new triangle. */ - setelemattribute(newtopright, i, elemattribute(topright, i)); - } - if (b->vararea) { - /* Set the area constraint of another new triangle. */ - setareabound(newtopright, areabound(topright)); - } - } - - /* There may be subsegments that need to be bonded */ - /* to the new triangle(s). */ - if (m->checksegments) { - tspivot(botright, botrsubseg); - if (botrsubseg.ss != m->dummysub) { - tsdissolve(botright); - tsbond(newbotright, botrsubseg); - } - if (mirrorflag) { - tspivot(topright, toprsubseg); - if (toprsubseg.ss != m->dummysub) { - tsdissolve(topright); - tsbond(newtopright, toprsubseg); - } - } - } - - /* Bond the new triangle(s) to the surrounding triangles. */ - bond(newbotright, botrcasing); - lprevself(newbotright); - bond(newbotright, botright); - lprevself(newbotright); - if (mirrorflag) { - bond(newtopright, toprcasing); - lnextself(newtopright); - bond(newtopright, topright); - lnextself(newtopright); - bond(newtopright, newbotright); - } - - if (splitseg != (struct osub *)NULL) { - /* Split the subsegment into two. */ - setsdest(*splitseg, newvertex); - segorg(*splitseg, segmentorg); - segdest(*splitseg, segmentdest); - ssymself(*splitseg); - spivot(*splitseg, rightsubseg); - insertsubseg(m, b, &newbotright, mark(*splitseg)); - tspivot(newbotright, newsubseg); - setsegorg(newsubseg, segmentorg); - setsegdest(newsubseg, segmentdest); - sbond(*splitseg, newsubseg); - ssymself(newsubseg); - sbond(newsubseg, rightsubseg); - ssymself(*splitseg); - /* Transfer the subsegment's boundary marker to the vertex */ - /* if required. */ - if (vertexmark(newvertex) == 0) { - setvertexmark(newvertex, mark(*splitseg)); - } - } - - if (m->checkquality) { - poolrestart(&m->flipstackers); - m->lastflip = (struct flipstacker *)poolalloc(&m->flipstackers); - m->lastflip->flippedtri = encode(horiz); - m->lastflip->prevflip = (struct flipstacker *)&insertvertex; - } - -#ifdef SELF_CHECK - if (counterclockwise(m, b, rightvertex, leftvertex, botvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle prior to edge vertex insertion (bottom).\n"); - } - if (mirrorflag) { - if (counterclockwise(m, b, leftvertex, rightvertex, topvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle prior to edge vertex insertion (top).\n"); - } - if (counterclockwise(m, b, rightvertex, topvertex, newvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf( - " Clockwise triangle after edge vertex insertion (top right).\n"); - } - if (counterclockwise(m, b, topvertex, leftvertex, newvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf( - " Clockwise triangle after edge vertex insertion (top left).\n"); - } - } - if (counterclockwise(m, b, leftvertex, botvertex, newvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf( - " Clockwise triangle after edge vertex insertion (bottom left).\n"); - } - if (counterclockwise(m, b, botvertex, rightvertex, newvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf( - " Clockwise triangle after edge vertex insertion (bottom right).\n"); - } -#endif /* SELF_CHECK */ - if (b->verbose > 2) { - printf(" Updating bottom left "); - printtriangle(m, b, &botright); - if (mirrorflag) { - printf(" Updating top left "); - printtriangle(m, b, &topright); - printf(" Creating top right "); - printtriangle(m, b, &newtopright); - } - printf(" Creating bottom right "); - printtriangle(m, b, &newbotright); - } - - /* Position `horiz' on the first edge to check for */ - /* the Delaunay property. */ - lnextself(horiz); - } else { - /* Insert the vertex in a triangle, splitting it into three. */ - lnext(horiz, botleft); - lprev(horiz, botright); - sym(botleft, botlcasing); - sym(botright, botrcasing); - maketriangle(m, b, &newbotleft); - maketriangle(m, b, &newbotright); - - /* Set the vertices of changed and new triangles. */ - org(horiz, rightvertex); - dest(horiz, leftvertex); - apex(horiz, botvertex); - setorg(newbotleft, leftvertex); - setdest(newbotleft, botvertex); - setapex(newbotleft, newvertex); - setorg(newbotright, botvertex); - setdest(newbotright, rightvertex); - setapex(newbotright, newvertex); - setapex(horiz, newvertex); - for (i = 0; i < m->eextras; i++) { - /* Set the element attributes of the new triangles. */ - attrib = elemattribute(horiz, i); - setelemattribute(newbotleft, i, attrib); - setelemattribute(newbotright, i, attrib); - } - if (b->vararea) { - /* Set the area constraint of the new triangles. */ - area = areabound(horiz); - setareabound(newbotleft, area); - setareabound(newbotright, area); - } - - /* There may be subsegments that need to be bonded */ - /* to the new triangles. */ - if (m->checksegments) { - tspivot(botleft, botlsubseg); - if (botlsubseg.ss != m->dummysub) { - tsdissolve(botleft); - tsbond(newbotleft, botlsubseg); - } - tspivot(botright, botrsubseg); - if (botrsubseg.ss != m->dummysub) { - tsdissolve(botright); - tsbond(newbotright, botrsubseg); - } - } - - /* Bond the new triangles to the surrounding triangles. */ - bond(newbotleft, botlcasing); - bond(newbotright, botrcasing); - lnextself(newbotleft); - lprevself(newbotright); - bond(newbotleft, newbotright); - lnextself(newbotleft); - bond(botleft, newbotleft); - lprevself(newbotright); - bond(botright, newbotright); - - if (m->checkquality) { - poolrestart(&m->flipstackers); - m->lastflip = (struct flipstacker *)poolalloc(&m->flipstackers); - m->lastflip->flippedtri = encode(horiz); - m->lastflip->prevflip = (struct flipstacker *)NULL; - } - -#ifdef SELF_CHECK - if (counterclockwise(m, b, rightvertex, leftvertex, botvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle prior to vertex insertion.\n"); - } - if (counterclockwise(m, b, rightvertex, leftvertex, newvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle after vertex insertion (top).\n"); - } - if (counterclockwise(m, b, leftvertex, botvertex, newvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle after vertex insertion (left).\n"); - } - if (counterclockwise(m, b, botvertex, rightvertex, newvertex) < 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle after vertex insertion (right).\n"); - } -#endif /* SELF_CHECK */ - if (b->verbose > 2) { - printf(" Updating top "); - printtriangle(m, b, &horiz); - printf(" Creating left "); - printtriangle(m, b, &newbotleft); - printf(" Creating right "); - printtriangle(m, b, &newbotright); - } - } - - /* The insertion is successful by default, unless an encroached */ - /* subsegment is found. */ - success = SUCCESSFULVERTEX; - /* Circle around the newly inserted vertex, checking each edge opposite */ - /* it for the Delaunay property. Non-Delaunay edges are flipped. */ - /* `horiz' is always the edge being checked. `first' marks where to */ - /* stop circling. */ - org(horiz, first); - rightvertex = first; - dest(horiz, leftvertex); - /* Circle until finished. */ - while (1) { - /* By default, the edge will be flipped. */ - doflip = 1; - - if (m->checksegments) { - /* Check for a subsegment, which cannot be flipped. */ - tspivot(horiz, checksubseg); - if (checksubseg.ss != m->dummysub) { - /* The edge is a subsegment and cannot be flipped. */ - doflip = 0; -#ifndef CDT_ONLY - if (segmentflaws) { - /* Does the new vertex encroach upon this subsegment? */ - if (checkseg4encroach(m, b, &checksubseg)) { - success = ENCROACHINGVERTEX; - } - } -#endif /* not CDT_ONLY */ - } - } - - if (doflip) { - /* Check if the edge is a boundary edge. */ - sym(horiz, top); - if (top.tri == m->dummytri) { - /* The edge is a boundary edge and cannot be flipped. */ - doflip = 0; - } else { - /* Find the vertex on the other side of the edge. */ - apex(top, farvertex); - /* In the incremental Delaunay triangulation algorithm, any of */ - /* `leftvertex', `rightvertex', and `farvertex' could be vertices */ - /* of the triangular bounding box. These vertices must be */ - /* treated as if they are infinitely distant, even though their */ - /* "coordinates" are not. */ - if ((leftvertex == m->infvertex1) || (leftvertex == m->infvertex2) || - (leftvertex == m->infvertex3)) { - /* `leftvertex' is infinitely distant. Check the convexity of */ - /* the boundary of the triangulation. 'farvertex' might be */ - /* infinite as well, but trust me, this same condition should */ - /* be applied. */ - doflip = - counterclockwise(m, b, newvertex, rightvertex, farvertex) > 0.0; - } else if ((rightvertex == m->infvertex1) || - (rightvertex == m->infvertex2) || - (rightvertex == m->infvertex3)) { - /* `rightvertex' is infinitely distant. Check the convexity of */ - /* the boundary of the triangulation. 'farvertex' might be */ - /* infinite as well, but trust me, this same condition should */ - /* be applied. */ - doflip = - counterclockwise(m, b, farvertex, leftvertex, newvertex) > 0.0; - } else if ((farvertex == m->infvertex1) || - (farvertex == m->infvertex2) || - (farvertex == m->infvertex3)) { - /* `farvertex' is infinitely distant and cannot be inside */ - /* the circumcircle of the triangle `horiz'. */ - doflip = 0; - } else { - /* Test whether the edge is locally Delaunay. */ - doflip = incircle(m, b, leftvertex, newvertex, rightvertex, - farvertex) > 0.0; - } - if (doflip) { - /* We made it! Flip the edge `horiz' by rotating its containing */ - /* quadrilateral (the two triangles adjacent to `horiz'). */ - /* Identify the casing of the quadrilateral. */ - lprev(top, topleft); - sym(topleft, toplcasing); - lnext(top, topright); - sym(topright, toprcasing); - lnext(horiz, botleft); - sym(botleft, botlcasing); - lprev(horiz, botright); - sym(botright, botrcasing); - /* Rotate the quadrilateral one-quarter turn counterclockwise. */ - bond(topleft, botlcasing); - bond(botleft, botrcasing); - bond(botright, toprcasing); - bond(topright, toplcasing); - if (m->checksegments) { - /* Check for subsegments and rebond them to the quadrilateral. */ - tspivot(topleft, toplsubseg); - tspivot(botleft, botlsubseg); - tspivot(botright, botrsubseg); - tspivot(topright, toprsubseg); - if (toplsubseg.ss == m->dummysub) { - tsdissolve(topright); - } else { - tsbond(topright, toplsubseg); - } - if (botlsubseg.ss == m->dummysub) { - tsdissolve(topleft); - } else { - tsbond(topleft, botlsubseg); - } - if (botrsubseg.ss == m->dummysub) { - tsdissolve(botleft); - } else { - tsbond(botleft, botrsubseg); - } - if (toprsubseg.ss == m->dummysub) { - tsdissolve(botright); - } else { - tsbond(botright, toprsubseg); - } - } - /* New vertex assignments for the rotated quadrilateral. */ - setorg(horiz, farvertex); - setdest(horiz, newvertex); - setapex(horiz, rightvertex); - setorg(top, newvertex); - setdest(top, farvertex); - setapex(top, leftvertex); - for (i = 0; i < m->eextras; i++) { - /* Take the average of the two triangles' attributes. */ - attrib = 0.5 * (elemattribute(top, i) + elemattribute(horiz, i)); - setelemattribute(top, i, attrib); - setelemattribute(horiz, i, attrib); - } - if (b->vararea) { - if ((areabound(top) <= 0.0) || (areabound(horiz) <= 0.0)) { - area = -1.0; - } else { - /* Take the average of the two triangles' area constraints. */ - /* This prevents small area constraints from migrating a */ - /* long, long way from their original location due to flips. */ - area = 0.5 * (areabound(top) + areabound(horiz)); - } - setareabound(top, area); - setareabound(horiz, area); - } - - if (m->checkquality) { - newflip = (struct flipstacker *)poolalloc(&m->flipstackers); - newflip->flippedtri = encode(horiz); - newflip->prevflip = m->lastflip; - m->lastflip = newflip; - } - -#ifdef SELF_CHECK - if (newvertex != (vertex)NULL) { - if (counterclockwise(m, b, leftvertex, newvertex, rightvertex) < - 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle prior to edge flip (bottom).\n"); - } - /* The following test has been removed because constrainededge() */ - /* sometimes generates inverted triangles that insertvertex() */ - /* removes. */ - /* - if (counterclockwise(m, b, rightvertex, farvertex, - leftvertex) < 0.0) { printf("Internal error in - insertvertex():\n"); printf(" Clockwise triangle prior to edge - flip (top).\n"); - } - */ - if (counterclockwise(m, b, farvertex, leftvertex, newvertex) < - 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle after edge flip (left).\n"); - } - if (counterclockwise(m, b, newvertex, rightvertex, farvertex) < - 0.0) { - printf("Internal error in insertvertex():\n"); - printf(" Clockwise triangle after edge flip (right).\n"); - } - } -#endif /* SELF_CHECK */ - if (b->verbose > 2) { - printf(" Edge flip results in left "); - lnextself(topleft); - printtriangle(m, b, &topleft); - printf(" and right "); - printtriangle(m, b, &horiz); - } - /* On the next iterations, consider the two edges that were */ - /* exposed (this is, are now visible to the newly inserted */ - /* vertex) by the edge flip. */ - lprevself(horiz); - leftvertex = farvertex; - } - } - } - if (!doflip) { - /* The handle `horiz' is accepted as locally Delaunay. */ -#ifndef CDT_ONLY - if (triflaws) { - /* Check the triangle `horiz' for quality. */ - testtriangle(m, b, &horiz); - } -#endif /* not CDT_ONLY */ - /* Look for the next edge around the newly inserted vertex. */ - lnextself(horiz); - sym(horiz, testtri); - /* Check for finishing a complete revolution about the new vertex, or */ - /* falling outside of the triangulation. The latter will happen */ - /* when a vertex is inserted at a boundary. */ - if ((leftvertex == first) || (testtri.tri == m->dummytri)) { - /* We're done. Return a triangle whose origin is the new vertex. */ - lnext(horiz, *searchtri); - lnext(horiz, m->recenttri); - return success; - } - /* Finish finding the next edge around the newly inserted vertex. */ - lnext(testtri, horiz); - rightvertex = leftvertex; - dest(horiz, leftvertex); - } - } -} - -/*****************************************************************************/ -/* */ -/* triangulatepolygon() Find the Delaunay triangulation of a polygon that */ -/* has a certain "nice" shape. This includes the */ -/* polygons that result from deletion of a vertex or */ -/* insertion of a segment. */ -/* */ -/* This is a conceptually difficult routine. The starting assumption is */ -/* that we have a polygon with n sides. n - 1 of these sides are currently */ -/* represented as edges in the mesh. One side, called the "base", need not */ -/* be. */ -/* */ -/* Inside the polygon is a structure I call a "fan", consisting of n - 1 */ -/* triangles that share a common origin. For each of these triangles, the */ -/* edge opposite the origin is one of the sides of the polygon. The */ -/* primary edge of each triangle is the edge directed from the origin to */ -/* the destination; note that this is not the same edge that is a side of */ -/* the polygon. `firstedge' is the primary edge of the first triangle. */ -/* From there, the triangles follow in counterclockwise order about the */ -/* polygon, until `lastedge', the primary edge of the last triangle. */ -/* `firstedge' and `lastedge' are probably connected to other triangles */ -/* beyond the extremes of the fan, but their identity is not important, as */ -/* long as the fan remains connected to them. */ -/* */ -/* Imagine the polygon oriented so that its base is at the bottom. This */ -/* puts `firstedge' on the far right, and `lastedge' on the far left. */ -/* The right vertex of the base is the destination of `firstedge', and the */ -/* left vertex of the base is the apex of `lastedge'. */ -/* */ -/* The challenge now is to find the right sequence of edge flips to */ -/* transform the fan into a Delaunay triangulation of the polygon. Each */ -/* edge flip effectively removes one triangle from the fan, committing it */ -/* to the polygon. The resulting polygon has one fewer edge. If `doflip' */ -/* is set, the final flip will be performed, resulting in a fan of one */ -/* (useless?) triangle. If `doflip' is not set, the final flip is not */ -/* performed, resulting in a fan of two triangles, and an unfinished */ -/* triangular polygon that is not yet filled out with a single triangle. */ -/* On completion of the routine, `lastedge' is the last remaining triangle, */ -/* or the leftmost of the last two. */ -/* */ -/* Although the flips are performed in the order described above, the */ -/* decisions about what flips to perform are made in precisely the reverse */ -/* order. The recursive triangulatepolygon() procedure makes a decision, */ -/* uses up to two recursive calls to triangulate the "subproblems" */ -/* (polygons with fewer edges), and then performs an edge flip. */ -/* */ -/* The "decision" it makes is which vertex of the polygon should be */ -/* connected to the base. This decision is made by testing every possible */ -/* vertex. Once the best vertex is found, the two edges that connect this */ -/* vertex to the base become the bases for two smaller polygons. These */ -/* are triangulated recursively. Unfortunately, this approach can take */ -/* O(n^2) time not only in the worst case, but in many common cases. It's */ -/* rarely a big deal for vertex deletion, where n is rarely larger than */ -/* ten, but it could be a big deal for segment insertion, especially if */ -/* there's a lot of long segments that each cut many triangles. I ought to */ -/* code a faster algorithm some day. */ -/* */ -/* The `edgecount' parameter is the number of sides of the polygon, */ -/* including its base. `triflaws' is a flag that determines whether the */ -/* new triangles should be tested for quality, and enqueued if they are */ -/* bad. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void triangulatepolygon(struct mesh *m, struct behavior *b, - struct otri *firstedge, struct otri *lastedge, - int edgecount, int doflip, int triflaws) -#else /* not ANSI_DECLARATORS */ -void triangulatepolygon(m, b, firstedge, lastedge, edgecount, doflip, - triflaws) struct mesh *m; -struct behavior *b; -struct otri *firstedge; -struct otri *lastedge; -int edgecount; -int doflip; -int triflaws; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri testtri; - struct otri besttri; - struct otri tempedge; - vertex leftbasevertex, rightbasevertex; - vertex testvertex; - vertex bestvertex; - int bestnumber; - int i; - triangle ptr; /* Temporary variable used by sym(), onext(), and oprev(). */ - - /* Identify the base vertices. */ - apex(*lastedge, leftbasevertex); - dest(*firstedge, rightbasevertex); - if (b->verbose > 2) { - printf(" Triangulating interior polygon at edge\n"); - printf(" (%.12g, %.12g) (%.12g, %.12g)\n", leftbasevertex[0], - leftbasevertex[1], rightbasevertex[0], rightbasevertex[1]); - } - /* Find the best vertex to connect the base to. */ - onext(*firstedge, besttri); - dest(besttri, bestvertex); - otricopy(besttri, testtri); - bestnumber = 1; - for (i = 2; i <= edgecount - 2; i++) { - onextself(testtri); - dest(testtri, testvertex); - /* Is this a better vertex? */ - if (incircle(m, b, leftbasevertex, rightbasevertex, bestvertex, - testvertex) > 0.0) { - otricopy(testtri, besttri); - bestvertex = testvertex; - bestnumber = i; - } - } - if (b->verbose > 2) { - printf(" Connecting edge to (%.12g, %.12g)\n", bestvertex[0], - bestvertex[1]); - } - if (bestnumber > 1) { - /* Recursively triangulate the smaller polygon on the right. */ - oprev(besttri, tempedge); - triangulatepolygon(m, b, firstedge, &tempedge, bestnumber + 1, 1, triflaws); - } - if (bestnumber < edgecount - 2) { - /* Recursively triangulate the smaller polygon on the left. */ - sym(besttri, tempedge); - triangulatepolygon(m, b, &besttri, lastedge, edgecount - bestnumber, 1, - triflaws); - /* Find `besttri' again; it may have been lost to edge flips. */ - sym(tempedge, besttri); - } - if (doflip) { - /* Do one final edge flip. */ - flip(m, b, &besttri); -#ifndef CDT_ONLY - if (triflaws) { - /* Check the quality of the newly committed triangle. */ - sym(besttri, testtri); - testtriangle(m, b, &testtri); - } -#endif /* not CDT_ONLY */ - } - /* Return the base triangle. */ - otricopy(besttri, *lastedge); -} - -/*****************************************************************************/ -/* */ -/* deletevertex() Delete a vertex from a Delaunay triangulation, ensuring */ -/* that the triangulation remains Delaunay. */ -/* */ -/* The origin of `deltri' is deleted. The union of the triangles adjacent */ -/* to this vertex is a polygon, for which the Delaunay triangulation is */ -/* found. Two triangles are removed from the mesh. */ -/* */ -/* Only interior vertices that do not lie on segments or boundaries may be */ -/* deleted. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void deletevertex(struct mesh *m, struct behavior *b, struct otri *deltri) -#else /* not ANSI_DECLARATORS */ -void deletevertex(m, b, deltri) struct mesh *m; -struct behavior *b; -struct otri *deltri; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri countingtri; - struct otri firstedge, lastedge; - struct otri deltriright; - struct otri lefttri, righttri; - struct otri leftcasing, rightcasing; - struct osub leftsubseg, rightsubseg; - vertex delvertex; - vertex neworg; - int edgecount; - triangle ptr; /* Temporary variable used by sym(), onext(), and oprev(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - org(*deltri, delvertex); - if (b->verbose > 1) { - printf(" Deleting (%.12g, %.12g).\n", delvertex[0], delvertex[1]); - } - vertexdealloc(m, delvertex); - - /* Count the degree of the vertex being deleted. */ - onext(*deltri, countingtri); - edgecount = 1; - while (!otriequal(*deltri, countingtri)) { -#ifdef SELF_CHECK - if (countingtri.tri == m->dummytri) { - printf("Internal error in deletevertex():\n"); - printf(" Attempt to delete boundary vertex.\n"); - internalerror(); - } -#endif /* SELF_CHECK */ - edgecount++; - onextself(countingtri); - } - -#ifdef SELF_CHECK - if (edgecount < 3) { - printf("Internal error in deletevertex():\n Vertex has degree %d.\n", - edgecount); - internalerror(); - } -#endif /* SELF_CHECK */ - if (edgecount > 3) { - /* Triangulate the polygon defined by the union of all triangles */ - /* adjacent to the vertex being deleted. Check the quality of */ - /* the resulting triangles. */ - onext(*deltri, firstedge); - oprev(*deltri, lastedge); - triangulatepolygon(m, b, &firstedge, &lastedge, edgecount, 0, !b->nobisect); - } - /* Splice out two triangles. */ - lprev(*deltri, deltriright); - dnext(*deltri, lefttri); - sym(lefttri, leftcasing); - oprev(deltriright, righttri); - sym(righttri, rightcasing); - bond(*deltri, leftcasing); - bond(deltriright, rightcasing); - tspivot(lefttri, leftsubseg); - if (leftsubseg.ss != m->dummysub) { - tsbond(*deltri, leftsubseg); - } - tspivot(righttri, rightsubseg); - if (rightsubseg.ss != m->dummysub) { - tsbond(deltriright, rightsubseg); - } - - /* Set the new origin of `deltri' and check its quality. */ - org(lefttri, neworg); - setorg(*deltri, neworg); - if (!b->nobisect) { - testtriangle(m, b, deltri); - } - - /* Delete the two spliced-out triangles. */ - triangledealloc(m, lefttri.tri); - triangledealloc(m, righttri.tri); -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* undovertex() Undo the most recent vertex insertion. */ -/* */ -/* Walks through the list of transformations (flips and a vertex insertion) */ -/* in the reverse of the order in which they were done, and undoes them. */ -/* The inserted vertex is removed from the triangulation and deallocated. */ -/* Two triangles (possibly just one) are also deallocated. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void undovertex(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void undovertex(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri fliptri; - struct otri botleft, botright, topright; - struct otri botlcasing, botrcasing, toprcasing; - struct otri gluetri; - struct osub botlsubseg, botrsubseg, toprsubseg; - vertex botvertex, rightvertex; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - /* Walk through the list of transformations (flips and a vertex insertion) */ - /* in the reverse of the order in which they were done, and undo them. */ - while (m->lastflip != (struct flipstacker *)NULL) { - /* Find a triangle involved in the last unreversed transformation. */ - decode(m->lastflip->flippedtri, fliptri); - - /* We are reversing one of three transformations: a trisection of one */ - /* triangle into three (by inserting a vertex in the triangle), a */ - /* bisection of two triangles into four (by inserting a vertex in an */ - /* edge), or an edge flip. */ - if (m->lastflip->prevflip == (struct flipstacker *)NULL) { - /* Restore a triangle that was split into three triangles, */ - /* so it is again one triangle. */ - dprev(fliptri, botleft); - lnextself(botleft); - onext(fliptri, botright); - lprevself(botright); - sym(botleft, botlcasing); - sym(botright, botrcasing); - dest(botleft, botvertex); - - setapex(fliptri, botvertex); - lnextself(fliptri); - bond(fliptri, botlcasing); - tspivot(botleft, botlsubseg); - tsbond(fliptri, botlsubseg); - lnextself(fliptri); - bond(fliptri, botrcasing); - tspivot(botright, botrsubseg); - tsbond(fliptri, botrsubseg); - - /* Delete the two spliced-out triangles. */ - triangledealloc(m, botleft.tri); - triangledealloc(m, botright.tri); - } else if (m->lastflip->prevflip == (struct flipstacker *)&insertvertex) { - /* Restore two triangles that were split into four triangles, */ - /* so they are again two triangles. */ - lprev(fliptri, gluetri); - sym(gluetri, botright); - lnextself(botright); - sym(botright, botrcasing); - dest(botright, rightvertex); - - setorg(fliptri, rightvertex); - bond(gluetri, botrcasing); - tspivot(botright, botrsubseg); - tsbond(gluetri, botrsubseg); - - /* Delete the spliced-out triangle. */ - triangledealloc(m, botright.tri); - - sym(fliptri, gluetri); - if (gluetri.tri != m->dummytri) { - lnextself(gluetri); - dnext(gluetri, topright); - sym(topright, toprcasing); - - setorg(gluetri, rightvertex); - bond(gluetri, toprcasing); - tspivot(topright, toprsubseg); - tsbond(gluetri, toprsubseg); - - /* Delete the spliced-out triangle. */ - triangledealloc(m, topright.tri); - } - - /* This is the end of the list, sneakily encoded. */ - m->lastflip->prevflip = (struct flipstacker *)NULL; - } else { - /* Undo an edge flip. */ - unflip(m, b, &fliptri); - } - - /* Go on and process the next transformation. */ - m->lastflip = m->lastflip->prevflip; - } -} - -#endif /* not CDT_ONLY */ - -/** **/ -/** **/ -/********* Mesh transformation routines end here *********/ - -/********* Divide-and-conquer Delaunay triangulation begins here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* The divide-and-conquer bounding box */ -/* */ -/* I originally implemented the divide-and-conquer and incremental Delaunay */ -/* triangulations using the edge-based data structure presented by Guibas */ -/* and Stolfi. Switching to a triangle-based data structure doubled the */ -/* speed. However, I had to think of a few extra tricks to maintain the */ -/* elegance of the original algorithms. */ -/* */ -/* The "bounding box" used by my variant of the divide-and-conquer */ -/* algorithm uses one triangle for each edge of the convex hull of the */ -/* triangulation. These bounding triangles all share a common apical */ -/* vertex, which is represented by NULL and which represents nothing. */ -/* The bounding triangles are linked in a circular fan about this NULL */ -/* vertex, and the edges on the convex hull of the triangulation appear */ -/* opposite the NULL vertex. You might find it easiest to imagine that */ -/* the NULL vertex is a point in 3D space behind the center of the */ -/* triangulation, and that the bounding triangles form a sort of cone. */ -/* */ -/* This bounding box makes it easy to represent degenerate cases. For */ -/* instance, the triangulation of two vertices is a single edge. This edge */ -/* is represented by two bounding box triangles, one on each "side" of the */ -/* edge. These triangles are also linked together in a fan about the NULL */ -/* vertex. */ -/* */ -/* The bounding box also makes it easy to traverse the convex hull, as the */ -/* divide-and-conquer algorithm needs to do. */ -/* */ -/*****************************************************************************/ - -/*****************************************************************************/ -/* */ -/* vertexsort() Sort an array of vertices by x-coordinate, using the */ -/* y-coordinate as a secondary key. */ -/* */ -/* Uses quicksort. Randomized O(n log n) time. No, I did not make any of */ -/* the usual quicksort mistakes. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void vertexsort(vertex *sortarray, int arraysize) -#else /* not ANSI_DECLARATORS */ -void vertexsort(sortarray, arraysize) vertex *sortarray; -int arraysize; -#endif /* not ANSI_DECLARATORS */ - -{ - int left, right; - int pivot; - REAL pivotx, pivoty; - vertex temp; - - if (arraysize == 2) { - /* Recursive base case. */ - if ((sortarray[0][0] > sortarray[1][0]) || - ((sortarray[0][0] == sortarray[1][0]) && - (sortarray[0][1] > sortarray[1][1]))) { - temp = sortarray[1]; - sortarray[1] = sortarray[0]; - sortarray[0] = temp; - } - return; - } - /* Choose a random pivot to split the array. */ - pivot = (int)randomnation((unsigned int)arraysize); - pivotx = sortarray[pivot][0]; - pivoty = sortarray[pivot][1]; - /* Split the array. */ - left = -1; - right = arraysize; - while (left < right) { - /* Search for a vertex whose x-coordinate is too large for the left. */ - do { - left++; - } while ((left <= right) && ((sortarray[left][0] < pivotx) || - ((sortarray[left][0] == pivotx) && - (sortarray[left][1] < pivoty)))); - /* Search for a vertex whose x-coordinate is too small for the right. */ - do { - right--; - } while ((left <= right) && ((sortarray[right][0] > pivotx) || - ((sortarray[right][0] == pivotx) && - (sortarray[right][1] > pivoty)))); - if (left < right) { - /* Swap the left and right vertices. */ - temp = sortarray[left]; - sortarray[left] = sortarray[right]; - sortarray[right] = temp; - } - } - if (left > 1) { - /* Recursively sort the left subset. */ - vertexsort(sortarray, left); - } - if (right < arraysize - 2) { - /* Recursively sort the right subset. */ - vertexsort(&sortarray[right + 1], arraysize - right - 1); - } -} - -/*****************************************************************************/ -/* */ -/* vertexmedian() An order statistic algorithm, almost. Shuffles an */ -/* array of vertices so that the first `median' vertices */ -/* occur lexicographically before the remaining vertices. */ -/* */ -/* Uses the x-coordinate as the primary key if axis == 0; the y-coordinate */ -/* if axis == 1. Very similar to the vertexsort() procedure, but runs in */ -/* randomized linear time. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void vertexmedian(vertex *sortarray, int arraysize, int median, int axis) -#else /* not ANSI_DECLARATORS */ -void vertexmedian(sortarray, arraysize, median, axis) vertex *sortarray; -int arraysize; -int median; -int axis; -#endif /* not ANSI_DECLARATORS */ - -{ - int left, right; - int pivot; - REAL pivot1, pivot2; - vertex temp; - - if (arraysize == 2) { - /* Recursive base case. */ - if ((sortarray[0][axis] > sortarray[1][axis]) || - ((sortarray[0][axis] == sortarray[1][axis]) && - (sortarray[0][1 - axis] > sortarray[1][1 - axis]))) { - temp = sortarray[1]; - sortarray[1] = sortarray[0]; - sortarray[0] = temp; - } - return; - } - /* Choose a random pivot to split the array. */ - pivot = (int)randomnation((unsigned int)arraysize); - pivot1 = sortarray[pivot][axis]; - pivot2 = sortarray[pivot][1 - axis]; - /* Split the array. */ - left = -1; - right = arraysize; - while (left < right) { - /* Search for a vertex whose x-coordinate is too large for the left. */ - do { - left++; - } while ((left <= right) && ((sortarray[left][axis] < pivot1) || - ((sortarray[left][axis] == pivot1) && - (sortarray[left][1 - axis] < pivot2)))); - /* Search for a vertex whose x-coordinate is too small for the right. */ - do { - right--; - } while ((left <= right) && ((sortarray[right][axis] > pivot1) || - ((sortarray[right][axis] == pivot1) && - (sortarray[right][1 - axis] > pivot2)))); - if (left < right) { - /* Swap the left and right vertices. */ - temp = sortarray[left]; - sortarray[left] = sortarray[right]; - sortarray[right] = temp; - } - } - /* Unlike in vertexsort(), at most one of the following */ - /* conditionals is true. */ - if (left > median) { - /* Recursively shuffle the left subset. */ - vertexmedian(sortarray, left, median, axis); - } - if (right < median - 1) { - /* Recursively shuffle the right subset. */ - vertexmedian(&sortarray[right + 1], arraysize - right - 1, - median - right - 1, axis); - } -} - -/*****************************************************************************/ -/* */ -/* alternateaxes() Sorts the vertices as appropriate for the divide-and- */ -/* conquer algorithm with alternating cuts. */ -/* */ -/* Partitions by x-coordinate if axis == 0; by y-coordinate if axis == 1. */ -/* For the base case, subsets containing only two or three vertices are */ -/* always sorted by x-coordinate. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void alternateaxes(vertex *sortarray, int arraysize, int axis) -#else /* not ANSI_DECLARATORS */ -void alternateaxes(sortarray, arraysize, axis) vertex *sortarray; -int arraysize; -int axis; -#endif /* not ANSI_DECLARATORS */ - -{ - int divider; - - divider = arraysize >> 1; - if (arraysize <= 3) { - /* Recursive base case: subsets of two or three vertices will be */ - /* handled specially, and should always be sorted by x-coordinate. */ - axis = 0; - } - /* Partition with a horizontal or vertical cut. */ - vertexmedian(sortarray, arraysize, divider, axis); - /* Recursively partition the subsets with a cross cut. */ - if (arraysize - divider >= 2) { - if (divider >= 2) { - alternateaxes(sortarray, divider, 1 - axis); - } - alternateaxes(&sortarray[divider], arraysize - divider, 1 - axis); - } -} - -/*****************************************************************************/ -/* */ -/* mergehulls() Merge two adjacent Delaunay triangulations into a */ -/* single Delaunay triangulation. */ -/* */ -/* This is similar to the algorithm given by Guibas and Stolfi, but uses */ -/* a triangle-based, rather than edge-based, data structure. */ -/* */ -/* The algorithm walks up the gap between the two triangulations, knitting */ -/* them together. As they are merged, some of their bounding triangles */ -/* are converted into real triangles of the triangulation. The procedure */ -/* pulls each hull's bounding triangles apart, then knits them together */ -/* like the teeth of two gears. The Delaunay property determines, at each */ -/* step, whether the next "tooth" is a bounding triangle of the left hull */ -/* or the right. When a bounding triangle becomes real, its apex is */ -/* changed from NULL to a real vertex. */ -/* */ -/* Only two new triangles need to be allocated. These become new bounding */ -/* triangles at the top and bottom of the seam. They are used to connect */ -/* the remaining bounding triangles (those that have not been converted */ -/* into real triangles) into a single fan. */ -/* */ -/* On entry, `farleft' and `innerleft' are bounding triangles of the left */ -/* triangulation. The origin of `farleft' is the leftmost vertex, and */ -/* the destination of `innerleft' is the rightmost vertex of the */ -/* triangulation. Similarly, `innerright' and `farright' are bounding */ -/* triangles of the right triangulation. The origin of `innerright' and */ -/* destination of `farright' are the leftmost and rightmost vertices. */ -/* */ -/* On completion, the origin of `farleft' is the leftmost vertex of the */ -/* merged triangulation, and the destination of `farright' is the rightmost */ -/* vertex. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void mergehulls(struct mesh *m, struct behavior *b, struct otri *farleft, - struct otri *innerleft, struct otri *innerright, - struct otri *farright, int axis) -#else /* not ANSI_DECLARATORS */ -void mergehulls(m, b, farleft, innerleft, innerright, farright, - axis) struct mesh *m; -struct behavior *b; -struct otri *farleft; -struct otri *innerleft; -struct otri *innerright; -struct otri *farright; -int axis; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri leftcand, rightcand; - struct otri baseedge; - struct otri nextedge; - struct otri sidecasing, topcasing, outercasing; - struct otri checkedge; - vertex innerleftdest; - vertex innerrightorg; - vertex innerleftapex, innerrightapex; - vertex farleftpt, farrightpt; - vertex farleftapex, farrightapex; - vertex lowerleft, lowerright; - vertex upperleft, upperright; - vertex nextapex; - vertex checkvertex; - int changemade; - int badedge; - int leftfinished, rightfinished; - triangle ptr; /* Temporary variable used by sym(). */ - - dest(*innerleft, innerleftdest); - apex(*innerleft, innerleftapex); - org(*innerright, innerrightorg); - apex(*innerright, innerrightapex); - /* Special treatment for horizontal cuts. */ - if (b->dwyer && (axis == 1)) { - org(*farleft, farleftpt); - apex(*farleft, farleftapex); - dest(*farright, farrightpt); - apex(*farright, farrightapex); - /* The pointers to the extremal vertices are shifted to point to the */ - /* topmost and bottommost vertex of each hull, rather than the */ - /* leftmost and rightmost vertices. */ - while (farleftapex[1] < farleftpt[1]) { - lnextself(*farleft); - symself(*farleft); - farleftpt = farleftapex; - apex(*farleft, farleftapex); - } - sym(*innerleft, checkedge); - apex(checkedge, checkvertex); - while (checkvertex[1] > innerleftdest[1]) { - lnext(checkedge, *innerleft); - innerleftapex = innerleftdest; - innerleftdest = checkvertex; - sym(*innerleft, checkedge); - apex(checkedge, checkvertex); - } - while (innerrightapex[1] < innerrightorg[1]) { - lnextself(*innerright); - symself(*innerright); - innerrightorg = innerrightapex; - apex(*innerright, innerrightapex); - } - sym(*farright, checkedge); - apex(checkedge, checkvertex); - while (checkvertex[1] > farrightpt[1]) { - lnext(checkedge, *farright); - farrightapex = farrightpt; - farrightpt = checkvertex; - sym(*farright, checkedge); - apex(checkedge, checkvertex); - } - } - /* Find a line tangent to and below both hulls. */ - do { - changemade = 0; - /* Make innerleftdest the "bottommost" vertex of the left hull. */ - if (counterclockwise(m, b, innerleftdest, innerleftapex, innerrightorg) > - 0.0) { - lprevself(*innerleft); - symself(*innerleft); - innerleftdest = innerleftapex; - apex(*innerleft, innerleftapex); - changemade = 1; - } - /* Make innerrightorg the "bottommost" vertex of the right hull. */ - if (counterclockwise(m, b, innerrightapex, innerrightorg, innerleftdest) > - 0.0) { - lnextself(*innerright); - symself(*innerright); - innerrightorg = innerrightapex; - apex(*innerright, innerrightapex); - changemade = 1; - } - } while (changemade); - /* Find the two candidates to be the next "gear tooth." */ - sym(*innerleft, leftcand); - sym(*innerright, rightcand); - /* Create the bottom new bounding triangle. */ - maketriangle(m, b, &baseedge); - /* Connect it to the bounding boxes of the left and right triangulations. */ - bond(baseedge, *innerleft); - lnextself(baseedge); - bond(baseedge, *innerright); - lnextself(baseedge); - setorg(baseedge, innerrightorg); - setdest(baseedge, innerleftdest); - /* Apex is intentionally left NULL. */ - if (b->verbose > 2) { - printf(" Creating base bounding "); - printtriangle(m, b, &baseedge); - } - /* Fix the extreme triangles if necessary. */ - org(*farleft, farleftpt); - if (innerleftdest == farleftpt) { - lnext(baseedge, *farleft); - } - dest(*farright, farrightpt); - if (innerrightorg == farrightpt) { - lprev(baseedge, *farright); - } - /* The vertices of the current knitting edge. */ - lowerleft = innerleftdest; - lowerright = innerrightorg; - /* The candidate vertices for knitting. */ - apex(leftcand, upperleft); - apex(rightcand, upperright); - /* Walk up the gap between the two triangulations, knitting them together. */ - while (1) { - /* Have we reached the top? (This isn't quite the right question, */ - /* because even though the left triangulation might seem finished now, */ - /* moving up on the right triangulation might reveal a new vertex of */ - /* the left triangulation. And vice-versa.) */ - leftfinished = - counterclockwise(m, b, upperleft, lowerleft, lowerright) <= 0.0; - rightfinished = - counterclockwise(m, b, upperright, lowerleft, lowerright) <= 0.0; - if (leftfinished && rightfinished) { - /* Create the top new bounding triangle. */ - maketriangle(m, b, &nextedge); - setorg(nextedge, lowerleft); - setdest(nextedge, lowerright); - /* Apex is intentionally left NULL. */ - /* Connect it to the bounding boxes of the two triangulations. */ - bond(nextedge, baseedge); - lnextself(nextedge); - bond(nextedge, rightcand); - lnextself(nextedge); - bond(nextedge, leftcand); - if (b->verbose > 2) { - printf(" Creating top bounding "); - printtriangle(m, b, &nextedge); - } - /* Special treatment for horizontal cuts. */ - if (b->dwyer && (axis == 1)) { - org(*farleft, farleftpt); - apex(*farleft, farleftapex); - dest(*farright, farrightpt); - apex(*farright, farrightapex); - sym(*farleft, checkedge); - apex(checkedge, checkvertex); - /* The pointers to the extremal vertices are restored to the */ - /* leftmost and rightmost vertices (rather than topmost and */ - /* bottommost). */ - while (checkvertex[0] < farleftpt[0]) { - lprev(checkedge, *farleft); - farleftapex = farleftpt; - farleftpt = checkvertex; - sym(*farleft, checkedge); - apex(checkedge, checkvertex); - } - while (farrightapex[0] > farrightpt[0]) { - lprevself(*farright); - symself(*farright); - farrightpt = farrightapex; - apex(*farright, farrightapex); - } - } - return; - } - /* Consider eliminating edges from the left triangulation. */ - if (!leftfinished) { - /* What vertex would be exposed if an edge were deleted? */ - lprev(leftcand, nextedge); - symself(nextedge); - apex(nextedge, nextapex); - /* If nextapex is NULL, then no vertex would be exposed; the */ - /* triangulation would have been eaten right through. */ - if (nextapex != (vertex)NULL) { - /* Check whether the edge is Delaunay. */ - badedge = - incircle(m, b, lowerleft, lowerright, upperleft, nextapex) > 0.0; - while (badedge) { - /* Eliminate the edge with an edge flip. As a result, the */ - /* left triangulation will have one more boundary triangle. */ - lnextself(nextedge); - sym(nextedge, topcasing); - lnextself(nextedge); - sym(nextedge, sidecasing); - bond(nextedge, topcasing); - bond(leftcand, sidecasing); - lnextself(leftcand); - sym(leftcand, outercasing); - lprevself(nextedge); - bond(nextedge, outercasing); - /* Correct the vertices to reflect the edge flip. */ - setorg(leftcand, lowerleft); - setdest(leftcand, NULL); - setapex(leftcand, nextapex); - setorg(nextedge, NULL); - setdest(nextedge, upperleft); - setapex(nextedge, nextapex); - /* Consider the newly exposed vertex. */ - upperleft = nextapex; - /* What vertex would be exposed if another edge were deleted? */ - otricopy(sidecasing, nextedge); - apex(nextedge, nextapex); - if (nextapex != (vertex)NULL) { - /* Check whether the edge is Delaunay. */ - badedge = incircle(m, b, lowerleft, lowerright, upperleft, - nextapex) > 0.0; - } else { - /* Avoid eating right through the triangulation. */ - badedge = 0; - } - } - } - } - /* Consider eliminating edges from the right triangulation. */ - if (!rightfinished) { - /* What vertex would be exposed if an edge were deleted? */ - lnext(rightcand, nextedge); - symself(nextedge); - apex(nextedge, nextapex); - /* If nextapex is NULL, then no vertex would be exposed; the */ - /* triangulation would have been eaten right through. */ - if (nextapex != (vertex)NULL) { - /* Check whether the edge is Delaunay. */ - badedge = - incircle(m, b, lowerleft, lowerright, upperright, nextapex) > 0.0; - while (badedge) { - /* Eliminate the edge with an edge flip. As a result, the */ - /* right triangulation will have one more boundary triangle. */ - lprevself(nextedge); - sym(nextedge, topcasing); - lprevself(nextedge); - sym(nextedge, sidecasing); - bond(nextedge, topcasing); - bond(rightcand, sidecasing); - lprevself(rightcand); - sym(rightcand, outercasing); - lnextself(nextedge); - bond(nextedge, outercasing); - /* Correct the vertices to reflect the edge flip. */ - setorg(rightcand, NULL); - setdest(rightcand, lowerright); - setapex(rightcand, nextapex); - setorg(nextedge, upperright); - setdest(nextedge, NULL); - setapex(nextedge, nextapex); - /* Consider the newly exposed vertex. */ - upperright = nextapex; - /* What vertex would be exposed if another edge were deleted? */ - otricopy(sidecasing, nextedge); - apex(nextedge, nextapex); - if (nextapex != (vertex)NULL) { - /* Check whether the edge is Delaunay. */ - badedge = incircle(m, b, lowerleft, lowerright, upperright, - nextapex) > 0.0; - } else { - /* Avoid eating right through the triangulation. */ - badedge = 0; - } - } - } - } - if (leftfinished || - (!rightfinished && (incircle(m, b, upperleft, lowerleft, lowerright, - upperright) > 0.0))) { - /* Knit the triangulations, adding an edge from `lowerleft' */ - /* to `upperright'. */ - bond(baseedge, rightcand); - lprev(rightcand, baseedge); - setdest(baseedge, lowerleft); - lowerright = upperright; - sym(baseedge, rightcand); - apex(rightcand, upperright); - } else { - /* Knit the triangulations, adding an edge from `upperleft' */ - /* to `lowerright'. */ - bond(baseedge, leftcand); - lnext(leftcand, baseedge); - setorg(baseedge, lowerright); - lowerleft = upperleft; - sym(baseedge, leftcand); - apex(leftcand, upperleft); - } - if (b->verbose > 2) { - printf(" Connecting "); - printtriangle(m, b, &baseedge); - } - } -} - -/*****************************************************************************/ -/* */ -/* divconqrecurse() Recursively form a Delaunay triangulation by the */ -/* divide-and-conquer method. */ -/* */ -/* Recursively breaks down the problem into smaller pieces, which are */ -/* knitted together by mergehulls(). The base cases (problems of two or */ -/* three vertices) are handled specially here. */ -/* */ -/* On completion, `farleft' and `farright' are bounding triangles such that */ -/* the origin of `farleft' is the leftmost vertex (breaking ties by */ -/* choosing the highest leftmost vertex), and the destination of */ -/* `farright' is the rightmost vertex (breaking ties by choosing the */ -/* lowest rightmost vertex). */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void divconqrecurse(struct mesh *m, struct behavior *b, vertex *sortarray, - int vertices, int axis, struct otri *farleft, - struct otri *farright) -#else /* not ANSI_DECLARATORS */ -void divconqrecurse(m, b, sortarray, vertices, axis, farleft, - farright) struct mesh *m; -struct behavior *b; -vertex *sortarray; -int vertices; -int axis; -struct otri *farleft; -struct otri *farright; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri midtri, tri1, tri2, tri3; - struct otri innerleft, innerright; - REAL area; - int divider; - - if (b->verbose > 2) { - printf(" Triangulating %d vertices.\n", vertices); - } - if (vertices == 2) { - /* The triangulation of two vertices is an edge. An edge is */ - /* represented by two bounding triangles. */ - maketriangle(m, b, farleft); - setorg(*farleft, sortarray[0]); - setdest(*farleft, sortarray[1]); - /* The apex is intentionally left NULL. */ - maketriangle(m, b, farright); - setorg(*farright, sortarray[1]); - setdest(*farright, sortarray[0]); - /* The apex is intentionally left NULL. */ - bond(*farleft, *farright); - lprevself(*farleft); - lnextself(*farright); - bond(*farleft, *farright); - lprevself(*farleft); - lnextself(*farright); - bond(*farleft, *farright); - if (b->verbose > 2) { - printf(" Creating "); - printtriangle(m, b, farleft); - printf(" Creating "); - printtriangle(m, b, farright); - } - /* Ensure that the origin of `farleft' is sortarray[0]. */ - lprev(*farright, *farleft); - return; - } else if (vertices == 3) { - /* The triangulation of three vertices is either a triangle (with */ - /* three bounding triangles) or two edges (with four bounding */ - /* triangles). In either case, four triangles are created. */ - maketriangle(m, b, &midtri); - maketriangle(m, b, &tri1); - maketriangle(m, b, &tri2); - maketriangle(m, b, &tri3); - area = counterclockwise(m, b, sortarray[0], sortarray[1], sortarray[2]); - if (area == 0.0) { - /* Three collinear vertices; the triangulation is two edges. */ - setorg(midtri, sortarray[0]); - setdest(midtri, sortarray[1]); - setorg(tri1, sortarray[1]); - setdest(tri1, sortarray[0]); - setorg(tri2, sortarray[2]); - setdest(tri2, sortarray[1]); - setorg(tri3, sortarray[1]); - setdest(tri3, sortarray[2]); - /* All apices are intentionally left NULL. */ - bond(midtri, tri1); - bond(tri2, tri3); - lnextself(midtri); - lprevself(tri1); - lnextself(tri2); - lprevself(tri3); - bond(midtri, tri3); - bond(tri1, tri2); - lnextself(midtri); - lprevself(tri1); - lnextself(tri2); - lprevself(tri3); - bond(midtri, tri1); - bond(tri2, tri3); - /* Ensure that the origin of `farleft' is sortarray[0]. */ - otricopy(tri1, *farleft); - /* Ensure that the destination of `farright' is sortarray[2]. */ - otricopy(tri2, *farright); - } else { - /* The three vertices are not collinear; the triangulation is one */ - /* triangle, namely `midtri'. */ - setorg(midtri, sortarray[0]); - setdest(tri1, sortarray[0]); - setorg(tri3, sortarray[0]); - /* Apices of tri1, tri2, and tri3 are left NULL. */ - if (area > 0.0) { - /* The vertices are in counterclockwise order. */ - setdest(midtri, sortarray[1]); - setorg(tri1, sortarray[1]); - setdest(tri2, sortarray[1]); - setapex(midtri, sortarray[2]); - setorg(tri2, sortarray[2]); - setdest(tri3, sortarray[2]); - } else { - /* The vertices are in clockwise order. */ - setdest(midtri, sortarray[2]); - setorg(tri1, sortarray[2]); - setdest(tri2, sortarray[2]); - setapex(midtri, sortarray[1]); - setorg(tri2, sortarray[1]); - setdest(tri3, sortarray[1]); - } - /* The topology does not depend on how the vertices are ordered. */ - bond(midtri, tri1); - lnextself(midtri); - bond(midtri, tri2); - lnextself(midtri); - bond(midtri, tri3); - lprevself(tri1); - lnextself(tri2); - bond(tri1, tri2); - lprevself(tri1); - lprevself(tri3); - bond(tri1, tri3); - lnextself(tri2); - lprevself(tri3); - bond(tri2, tri3); - /* Ensure that the origin of `farleft' is sortarray[0]. */ - otricopy(tri1, *farleft); - /* Ensure that the destination of `farright' is sortarray[2]. */ - if (area > 0.0) { - otricopy(tri2, *farright); - } else { - lnext(*farleft, *farright); - } - } - if (b->verbose > 2) { - printf(" Creating "); - printtriangle(m, b, &midtri); - printf(" Creating "); - printtriangle(m, b, &tri1); - printf(" Creating "); - printtriangle(m, b, &tri2); - printf(" Creating "); - printtriangle(m, b, &tri3); - } - return; - } else { - /* Split the vertices in half. */ - divider = vertices >> 1; - /* Recursively triangulate each half. */ - divconqrecurse(m, b, sortarray, divider, 1 - axis, farleft, &innerleft); - divconqrecurse(m, b, &sortarray[divider], vertices - divider, 1 - axis, - &innerright, farright); - if (b->verbose > 1) { - printf(" Joining triangulations with %d and %d vertices.\n", divider, - vertices - divider); - } - /* Merge the two triangulations into one. */ - mergehulls(m, b, farleft, &innerleft, &innerright, farright, axis); - } -} - -#ifdef ANSI_DECLARATORS -long removeghosts(struct mesh *m, struct behavior *b, struct otri *startghost) -#else /* not ANSI_DECLARATORS */ -long removeghosts(m, b, startghost) -struct mesh *m; -struct behavior *b; -struct otri *startghost; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri searchedge; - struct otri dissolveedge; - struct otri deadtriangle; - vertex markorg; - long hullsize; - triangle ptr; /* Temporary variable used by sym(). */ - - if (b->verbose) { - printf(" Removing ghost triangles.\n"); - } - /* Find an edge on the convex hull to start point location from. */ - lprev(*startghost, searchedge); - symself(searchedge); - m->dummytri[0] = encode(searchedge); - /* Remove the bounding box and count the convex hull edges. */ - otricopy(*startghost, dissolveedge); - hullsize = 0; - do { - hullsize++; - lnext(dissolveedge, deadtriangle); - lprevself(dissolveedge); - symself(dissolveedge); - /* If no PSLG is involved, set the boundary markers of all the vertices */ - /* on the convex hull. If a PSLG is used, this step is done later. */ - if (!b->poly) { - /* Watch out for the case where all the input vertices are collinear. */ - if (dissolveedge.tri != m->dummytri) { - org(dissolveedge, markorg); - if (vertexmark(markorg) == 0) { - setvertexmark(markorg, 1); - } - } - } - /* Remove a bounding triangle from a convex hull triangle. */ - dissolve(dissolveedge); - /* Find the next bounding triangle. */ - sym(deadtriangle, dissolveedge); - /* Delete the bounding triangle. */ - triangledealloc(m, deadtriangle.tri); - } while (!otriequal(dissolveedge, *startghost)); - return hullsize; -} - -/*****************************************************************************/ -/* */ -/* divconqdelaunay() Form a Delaunay triangulation by the divide-and- */ -/* conquer method. */ -/* */ -/* Sorts the vertices, calls a recursive procedure to triangulate them, and */ -/* removes the bounding box, setting boundary markers as appropriate. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -long divconqdelaunay(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -long divconqdelaunay(m, b) -struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - vertex *sortarray; - struct otri hullleft, hullright; - int divider; - int i, j; - - if (b->verbose) { - printf(" Sorting vertices.\n"); - } - - /* Allocate an array of pointers to vertices for sorting. */ - sortarray = (vertex *)trimalloc(m->invertices * (int)sizeof(vertex)); - traversalinit(&m->vertices); - for (i = 0; i < m->invertices; i++) { - sortarray[i] = vertextraverse(m); - } - /* Sort the vertices. */ - vertexsort(sortarray, m->invertices); - /* Discard duplicate vertices, which can really mess up the algorithm. */ - i = 0; - for (j = 1; j < m->invertices; j++) { - if ((sortarray[i][0] == sortarray[j][0]) && - (sortarray[i][1] == sortarray[j][1])) { - if (!b->quiet) { - printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " - "was ignored.\n", - sortarray[j][0], sortarray[j][1]); - } - setvertextype(sortarray[j], UNDEADVERTEX); - m->undeads++; - } else { - i++; - sortarray[i] = sortarray[j]; - } - } - i++; - if (b->dwyer) { - /* Re-sort the array of vertices to accommodate alternating cuts. */ - divider = i >> 1; - if (i - divider >= 2) { - if (divider >= 2) { - alternateaxes(sortarray, divider, 1); - } - alternateaxes(&sortarray[divider], i - divider, 1); - } - } - - if (b->verbose) { - printf(" Forming triangulation.\n"); - } - - /* Form the Delaunay triangulation. */ - divconqrecurse(m, b, sortarray, i, 0, &hullleft, &hullright); - trifree((VOID *)sortarray); - - return removeghosts(m, b, &hullleft); -} - -/** **/ -/** **/ -/********* Divide-and-conquer Delaunay triangulation ends here *********/ - -/********* Incremental Delaunay triangulation begins here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* boundingbox() Form an "infinite" bounding triangle to insert vertices */ -/* into. */ -/* */ -/* The vertices at "infinity" are assigned finite coordinates, which are */ -/* used by the point location routines, but (mostly) ignored by the */ -/* Delaunay edge flip routines. */ -/* */ -/*****************************************************************************/ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void boundingbox(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void boundingbox(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri inftri; /* Handle for the triangular bounding box. */ - REAL width; - - if (b->verbose) { - printf(" Creating triangular bounding box.\n"); - } - /* Find the width (or height, whichever is larger) of the triangulation. */ - width = m->xmax - m->xmin; - if (m->ymax - m->ymin > width) { - width = m->ymax - m->ymin; - } - if (width == 0.0) { - width = 1.0; - } - /* Create the vertices of the bounding box. */ - m->infvertex1 = (vertex)trimalloc(m->vertices.itembytes); - m->infvertex2 = (vertex)trimalloc(m->vertices.itembytes); - m->infvertex3 = (vertex)trimalloc(m->vertices.itembytes); - m->infvertex1[0] = m->xmin - 50.0 * width; - m->infvertex1[1] = m->ymin - 40.0 * width; - m->infvertex2[0] = m->xmax + 50.0 * width; - m->infvertex2[1] = m->ymin - 40.0 * width; - m->infvertex3[0] = 0.5 * (m->xmin + m->xmax); - m->infvertex3[1] = m->ymax + 60.0 * width; - - /* Create the bounding box. */ - maketriangle(m, b, &inftri); - setorg(inftri, m->infvertex1); - setdest(inftri, m->infvertex2); - setapex(inftri, m->infvertex3); - /* Link dummytri to the bounding box so we can always find an */ - /* edge to begin searching (point location) from. */ - m->dummytri[0] = (triangle)inftri.tri; - if (b->verbose > 2) { - printf(" Creating "); - printtriangle(m, b, &inftri); - } -} - -#endif /* not REDUCED */ - -/*****************************************************************************/ -/* */ -/* removebox() Remove the "infinite" bounding triangle, setting boundary */ -/* markers as appropriate. */ -/* */ -/* The triangular bounding box has three boundary triangles (one for each */ -/* side of the bounding box), and a bunch of triangles fanning out from */ -/* the three bounding box vertices (one triangle for each edge of the */ -/* convex hull of the inner mesh). This routine removes these triangles. */ -/* */ -/* Returns the number of edges on the convex hull of the triangulation. */ -/* */ -/*****************************************************************************/ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -long removebox(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -long removebox(m, b) -struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri deadtriangle; - struct otri searchedge; - struct otri checkedge; - struct otri nextedge, finaledge, dissolveedge; - vertex markorg; - long hullsize; - triangle ptr; /* Temporary variable used by sym(). */ - - if (b->verbose) { - printf(" Removing triangular bounding box.\n"); - } - /* Find a boundary triangle. */ - nextedge.tri = m->dummytri; - nextedge.orient = 0; - symself(nextedge); - /* Mark a place to stop. */ - lprev(nextedge, finaledge); - lnextself(nextedge); - symself(nextedge); - /* Find a triangle (on the boundary of the vertex set) that isn't */ - /* a bounding box triangle. */ - lprev(nextedge, searchedge); - symself(searchedge); - /* Check whether nextedge is another boundary triangle */ - /* adjacent to the first one. */ - lnext(nextedge, checkedge); - symself(checkedge); - if (checkedge.tri == m->dummytri) { - /* Go on to the next triangle. There are only three boundary */ - /* triangles, and this next triangle cannot be the third one, */ - /* so it's safe to stop here. */ - lprevself(searchedge); - symself(searchedge); - } - /* Find a new boundary edge to search from, as the current search */ - /* edge lies on a bounding box triangle and will be deleted. */ - m->dummytri[0] = encode(searchedge); - hullsize = -2l; - while (!otriequal(nextedge, finaledge)) { - hullsize++; - lprev(nextedge, dissolveedge); - symself(dissolveedge); - /* If not using a PSLG, the vertices should be marked now. */ - /* (If using a PSLG, markhull() will do the job.) */ - if (!b->poly) { - /* Be careful! One must check for the case where all the input */ - /* vertices are collinear, and thus all the triangles are part of */ - /* the bounding box. Otherwise, the setvertexmark() call below */ - /* will cause a bad pointer reference. */ - if (dissolveedge.tri != m->dummytri) { - org(dissolveedge, markorg); - if (vertexmark(markorg) == 0) { - setvertexmark(markorg, 1); - } - } - } - /* Disconnect the bounding box triangle from the mesh triangle. */ - dissolve(dissolveedge); - lnext(nextedge, deadtriangle); - sym(deadtriangle, nextedge); - /* Get rid of the bounding box triangle. */ - triangledealloc(m, deadtriangle.tri); - /* Do we need to turn the corner? */ - if (nextedge.tri == m->dummytri) { - /* Turn the corner. */ - otricopy(dissolveedge, nextedge); - } - } - triangledealloc(m, finaledge.tri); - - trifree((VOID *)m->infvertex1); /* Deallocate the bounding box vertices. */ - trifree((VOID *)m->infvertex2); - trifree((VOID *)m->infvertex3); - - return hullsize; -} - -#endif /* not REDUCED */ - -/*****************************************************************************/ -/* */ -/* incrementaldelaunay() Form a Delaunay triangulation by incrementally */ -/* inserting vertices. */ -/* */ -/* Returns the number of edges on the convex hull of the triangulation. */ -/* */ -/*****************************************************************************/ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -long incrementaldelaunay(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -long incrementaldelaunay(m, b) -struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri starttri; - vertex vertexloop; - - /* Create a triangular bounding box. */ - boundingbox(m, b); - if (b->verbose) { - printf(" Incrementally inserting vertices.\n"); - } - traversalinit(&m->vertices); - vertexloop = vertextraverse(m); - while (vertexloop != (vertex)NULL) { - starttri.tri = m->dummytri; - if (insertvertex(m, b, vertexloop, &starttri, (struct osub *)NULL, 0, 0) == - DUPLICATEVERTEX) { - if (!b->quiet) { - printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " - "was ignored.\n", - vertexloop[0], vertexloop[1]); - } - setvertextype(vertexloop, UNDEADVERTEX); - m->undeads++; - } - vertexloop = vertextraverse(m); - } - /* Remove the bounding box. */ - return removebox(m, b); -} - -#endif /* not REDUCED */ - -/** **/ -/** **/ -/********* Incremental Delaunay triangulation ends here *********/ - -/********* Sweepline Delaunay triangulation begins here *********/ -/** **/ -/** **/ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void eventheapinsert(struct event **heap, int heapsize, struct event *newevent) -#else /* not ANSI_DECLARATORS */ -void eventheapinsert(heap, heapsize, newevent) struct event **heap; -int heapsize; -struct event *newevent; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL eventx, eventy; - int eventnum; - int parent; - int notdone; - - eventx = newevent->xkey; - eventy = newevent->ykey; - eventnum = heapsize; - notdone = eventnum > 0; - while (notdone) { - parent = (eventnum - 1) >> 1; - if ((heap[parent]->ykey < eventy) || - ((heap[parent]->ykey == eventy) && (heap[parent]->xkey <= eventx))) { - notdone = 0; - } else { - heap[eventnum] = heap[parent]; - heap[eventnum]->heapposition = eventnum; - - eventnum = parent; - notdone = eventnum > 0; - } - } - heap[eventnum] = newevent; - newevent->heapposition = eventnum; -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void eventheapify(struct event **heap, int heapsize, int eventnum) -#else /* not ANSI_DECLARATORS */ -void eventheapify(heap, heapsize, eventnum) struct event **heap; -int heapsize; -int eventnum; -#endif /* not ANSI_DECLARATORS */ - -{ - struct event *thisevent; - REAL eventx, eventy; - int leftchild, rightchild; - int smallest; - int notdone; - - thisevent = heap[eventnum]; - eventx = thisevent->xkey; - eventy = thisevent->ykey; - leftchild = 2 * eventnum + 1; - notdone = leftchild < heapsize; - while (notdone) { - if ((heap[leftchild]->ykey < eventy) || - ((heap[leftchild]->ykey == eventy) && - (heap[leftchild]->xkey < eventx))) { - smallest = leftchild; - } else { - smallest = eventnum; - } - rightchild = leftchild + 1; - if (rightchild < heapsize) { - if ((heap[rightchild]->ykey < heap[smallest]->ykey) || - ((heap[rightchild]->ykey == heap[smallest]->ykey) && - (heap[rightchild]->xkey < heap[smallest]->xkey))) { - smallest = rightchild; - } - } - if (smallest == eventnum) { - notdone = 0; - } else { - heap[eventnum] = heap[smallest]; - heap[eventnum]->heapposition = eventnum; - heap[smallest] = thisevent; - thisevent->heapposition = smallest; - - eventnum = smallest; - leftchild = 2 * eventnum + 1; - notdone = leftchild < heapsize; - } - } -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void eventheapdelete(struct event **heap, int heapsize, int eventnum) -#else /* not ANSI_DECLARATORS */ -void eventheapdelete(heap, heapsize, eventnum) struct event **heap; -int heapsize; -int eventnum; -#endif /* not ANSI_DECLARATORS */ - -{ - struct event *moveevent; - REAL eventx, eventy; - int parent; - int notdone; - - moveevent = heap[heapsize - 1]; - if (eventnum > 0) { - eventx = moveevent->xkey; - eventy = moveevent->ykey; - do { - parent = (eventnum - 1) >> 1; - if ((heap[parent]->ykey < eventy) || - ((heap[parent]->ykey == eventy) && (heap[parent]->xkey <= eventx))) { - notdone = 0; - } else { - heap[eventnum] = heap[parent]; - heap[eventnum]->heapposition = eventnum; - - eventnum = parent; - notdone = eventnum > 0; - } - } while (notdone); - } - heap[eventnum] = moveevent; - moveevent->heapposition = eventnum; - eventheapify(heap, heapsize - 1, eventnum); -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void createeventheap(struct mesh *m, struct event ***eventheap, - struct event **events, struct event **freeevents) -#else /* not ANSI_DECLARATORS */ -void createeventheap(m, eventheap, events, freeevents) struct mesh *m; -struct event ***eventheap; -struct event **events; -struct event **freeevents; -#endif /* not ANSI_DECLARATORS */ - -{ - vertex thisvertex; - int maxevents; - int i; - - maxevents = (3 * m->invertices) / 2; - *eventheap = - (struct event **)trimalloc(maxevents * (int)sizeof(struct event *)); - *events = (struct event *)trimalloc(maxevents * (int)sizeof(struct event)); - traversalinit(&m->vertices); - for (i = 0; i < m->invertices; i++) { - thisvertex = vertextraverse(m); - (*events)[i].eventptr = (VOID *)thisvertex; - (*events)[i].xkey = thisvertex[0]; - (*events)[i].ykey = thisvertex[1]; - eventheapinsert(*eventheap, i, *events + i); - } - *freeevents = (struct event *)NULL; - for (i = maxevents - 1; i >= m->invertices; i--) { - (*events)[i].eventptr = (VOID *)*freeevents; - *freeevents = *events + i; - } -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -int rightofhyperbola(struct mesh *m, struct otri *fronttri, vertex newsite) -#else /* not ANSI_DECLARATORS */ -int rightofhyperbola(m, fronttri, newsite) -struct mesh *m; -struct otri *fronttri; -vertex newsite; -#endif /* not ANSI_DECLARATORS */ - -{ - vertex leftvertex, rightvertex; - REAL dxa, dya, dxb, dyb; - - m->hyperbolacount++; - - dest(*fronttri, leftvertex); - apex(*fronttri, rightvertex); - if ((leftvertex[1] < rightvertex[1]) || - ((leftvertex[1] == rightvertex[1]) && (leftvertex[0] < rightvertex[0]))) { - if (newsite[0] >= rightvertex[0]) { - return 1; - } - } else { - if (newsite[0] <= leftvertex[0]) { - return 0; - } - } - dxa = leftvertex[0] - newsite[0]; - dya = leftvertex[1] - newsite[1]; - dxb = rightvertex[0] - newsite[0]; - dyb = rightvertex[1] - newsite[1]; - return dya * (dxb * dxb + dyb * dyb) > dyb * (dxa * dxa + dya * dya); -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -REAL circletop(struct mesh *m, vertex pa, vertex pb, vertex pc, REAL ccwabc) -#else /* not ANSI_DECLARATORS */ -REAL circletop(m, pa, pb, pc, ccwabc) -struct mesh *m; -vertex pa; -vertex pb; -vertex pc; -REAL ccwabc; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL xac, yac, xbc, ybc, xab, yab; - REAL aclen2, bclen2, ablen2; - - m->circletopcount++; - - xac = pa[0] - pc[0]; - yac = pa[1] - pc[1]; - xbc = pb[0] - pc[0]; - ybc = pb[1] - pc[1]; - xab = pa[0] - pb[0]; - yab = pa[1] - pb[1]; - aclen2 = xac * xac + yac * yac; - bclen2 = xbc * xbc + ybc * ybc; - ablen2 = xab * xab + yab * yab; - return pc[1] + - (xac * bclen2 - xbc * aclen2 + sqrt(aclen2 * bclen2 * ablen2)) / - (2.0 * ccwabc); -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -void check4deadevent(struct otri *checktri, struct event **freeevents, - struct event **eventheap, int *heapsize) -#else /* not ANSI_DECLARATORS */ -void check4deadevent(checktri, freeevents, eventheap, - heapsize) struct otri *checktri; -struct event **freeevents; -struct event **eventheap; -int *heapsize; -#endif /* not ANSI_DECLARATORS */ - -{ - struct event *deadevent; - vertex eventvertex; - int eventnum; - - org(*checktri, eventvertex); - if (eventvertex != (vertex)NULL) { - deadevent = (struct event *)eventvertex; - eventnum = deadevent->heapposition; - deadevent->eventptr = (VOID *)*freeevents; - *freeevents = deadevent; - eventheapdelete(eventheap, *heapsize, eventnum); - (*heapsize)--; - setorg(*checktri, NULL); - } -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -struct splaynode *splay(struct mesh *m, struct splaynode *splaytree, - vertex searchpoint, struct otri *searchtri) -#else /* not ANSI_DECLARATORS */ -struct splaynode *splay(m, splaytree, searchpoint, searchtri) -struct mesh *m; -struct splaynode *splaytree; -vertex searchpoint; -struct otri *searchtri; -#endif /* not ANSI_DECLARATORS */ - -{ - struct splaynode *child, *grandchild; - struct splaynode *lefttree, *righttree; - struct splaynode *leftright; - vertex checkvertex; - int rightofroot, rightofchild; - - if (splaytree == (struct splaynode *)NULL) { - return (struct splaynode *)NULL; - } - dest(splaytree->keyedge, checkvertex); - if (checkvertex == splaytree->keydest) { - rightofroot = rightofhyperbola(m, &splaytree->keyedge, searchpoint); - if (rightofroot) { - otricopy(splaytree->keyedge, *searchtri); - child = splaytree->rchild; - } else { - child = splaytree->lchild; - } - if (child == (struct splaynode *)NULL) { - return splaytree; - } - dest(child->keyedge, checkvertex); - if (checkvertex != child->keydest) { - child = splay(m, child, searchpoint, searchtri); - if (child == (struct splaynode *)NULL) { - if (rightofroot) { - splaytree->rchild = (struct splaynode *)NULL; - } else { - splaytree->lchild = (struct splaynode *)NULL; - } - return splaytree; - } - } - rightofchild = rightofhyperbola(m, &child->keyedge, searchpoint); - if (rightofchild) { - otricopy(child->keyedge, *searchtri); - grandchild = splay(m, child->rchild, searchpoint, searchtri); - child->rchild = grandchild; - } else { - grandchild = splay(m, child->lchild, searchpoint, searchtri); - child->lchild = grandchild; - } - if (grandchild == (struct splaynode *)NULL) { - if (rightofroot) { - splaytree->rchild = child->lchild; - child->lchild = splaytree; - } else { - splaytree->lchild = child->rchild; - child->rchild = splaytree; - } - return child; - } - if (rightofchild) { - if (rightofroot) { - splaytree->rchild = child->lchild; - child->lchild = splaytree; - } else { - splaytree->lchild = grandchild->rchild; - grandchild->rchild = splaytree; - } - child->rchild = grandchild->lchild; - grandchild->lchild = child; - } else { - if (rightofroot) { - splaytree->rchild = grandchild->lchild; - grandchild->lchild = splaytree; - } else { - splaytree->lchild = child->rchild; - child->rchild = splaytree; - } - child->lchild = grandchild->rchild; - grandchild->rchild = child; - } - return grandchild; - } else { - lefttree = splay(m, splaytree->lchild, searchpoint, searchtri); - righttree = splay(m, splaytree->rchild, searchpoint, searchtri); - - pooldealloc(&m->splaynodes, (VOID *)splaytree); - if (lefttree == (struct splaynode *)NULL) { - return righttree; - } else if (righttree == (struct splaynode *)NULL) { - return lefttree; - } else if (lefttree->rchild == (struct splaynode *)NULL) { - lefttree->rchild = righttree->lchild; - righttree->lchild = lefttree; - return righttree; - } else if (righttree->lchild == (struct splaynode *)NULL) { - righttree->lchild = lefttree->rchild; - lefttree->rchild = righttree; - return lefttree; - } else { - /* printf("Holy Toledo!!!\n"); */ - leftright = lefttree->rchild; - while (leftright->rchild != (struct splaynode *)NULL) { - leftright = leftright->rchild; - } - leftright->rchild = righttree; - return lefttree; - } - } -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -struct splaynode *splayinsert(struct mesh *m, struct splaynode *splayroot, - struct otri *newkey, vertex searchpoint) -#else /* not ANSI_DECLARATORS */ -struct splaynode *splayinsert(m, splayroot, newkey, searchpoint) -struct mesh *m; -struct splaynode *splayroot; -struct otri *newkey; -vertex searchpoint; -#endif /* not ANSI_DECLARATORS */ - -{ - struct splaynode *newsplaynode; - - newsplaynode = (struct splaynode *)poolalloc(&m->splaynodes); - otricopy(*newkey, newsplaynode->keyedge); - dest(*newkey, newsplaynode->keydest); - if (splayroot == (struct splaynode *)NULL) { - newsplaynode->lchild = (struct splaynode *)NULL; - newsplaynode->rchild = (struct splaynode *)NULL; - } else if (rightofhyperbola(m, &splayroot->keyedge, searchpoint)) { - newsplaynode->lchild = splayroot; - newsplaynode->rchild = splayroot->rchild; - splayroot->rchild = (struct splaynode *)NULL; - } else { - newsplaynode->lchild = splayroot->lchild; - newsplaynode->rchild = splayroot; - splayroot->lchild = (struct splaynode *)NULL; - } - return newsplaynode; -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -struct splaynode * -circletopinsert(struct mesh *m, struct behavior *b, struct splaynode *splayroot, - struct otri *newkey, vertex pa, vertex pb, vertex pc, REAL topy) -#else /* not ANSI_DECLARATORS */ -struct splaynode *circletopinsert(m, b, splayroot, newkey, pa, pb, pc, topy) -struct mesh *m; -struct behavior *b; -struct splaynode *splayroot; -struct otri *newkey; -vertex pa; -vertex pb; -vertex pc; -REAL topy; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL ccwabc; - REAL xac, yac, xbc, ybc; - REAL aclen2, bclen2; - REAL searchpoint[2]; - struct otri dummytri; - - ccwabc = counterclockwise(m, b, pa, pb, pc); - xac = pa[0] - pc[0]; - yac = pa[1] - pc[1]; - xbc = pb[0] - pc[0]; - ybc = pb[1] - pc[1]; - aclen2 = xac * xac + yac * yac; - bclen2 = xbc * xbc + ybc * ybc; - searchpoint[0] = pc[0] - (yac * bclen2 - ybc * aclen2) / (2.0 * ccwabc); - searchpoint[1] = topy; - return splayinsert(m, splay(m, splayroot, (vertex)searchpoint, &dummytri), - newkey, (vertex)searchpoint); -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -struct splaynode *frontlocate(struct mesh *m, struct splaynode *splayroot, - struct otri *bottommost, vertex searchvertex, - struct otri *searchtri, int *farright) -#else /* not ANSI_DECLARATORS */ -struct splaynode *frontlocate(m, splayroot, bottommost, searchvertex, searchtri, - farright) -struct mesh *m; -struct splaynode *splayroot; -struct otri *bottommost; -vertex searchvertex; -struct otri *searchtri; -int *farright; -#endif /* not ANSI_DECLARATORS */ - -{ - int farrightflag; - triangle ptr; /* Temporary variable used by onext(). */ - - otricopy(*bottommost, *searchtri); - splayroot = splay(m, splayroot, searchvertex, searchtri); - - farrightflag = 0; - while (!farrightflag && rightofhyperbola(m, searchtri, searchvertex)) { - onextself(*searchtri); - farrightflag = otriequal(*searchtri, *bottommost); - } - *farright = farrightflag; - return splayroot; -} - -#endif /* not REDUCED */ - -#ifndef REDUCED - -#ifdef ANSI_DECLARATORS -long sweeplinedelaunay(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -long sweeplinedelaunay(m, b) -struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct event **eventheap; - struct event *events; - struct event *freeevents; - struct event *nextevent; - struct event *newevent; - struct splaynode *splayroot; - struct otri bottommost; - struct otri searchtri; - struct otri fliptri; - struct otri lefttri, righttri, farlefttri, farrighttri; - struct otri inserttri; - vertex firstvertex, secondvertex; - vertex nextvertex, lastvertex; - vertex connectvertex; - vertex leftvertex, midvertex, rightvertex; - REAL lefttest, righttest; - int heapsize; - int check4events, farrightflag; - triangle ptr; /* Temporary variable used by sym(), onext(), and oprev(). */ - - poolinit(&m->splaynodes, sizeof(struct splaynode), SPLAYNODEPERBLOCK, - SPLAYNODEPERBLOCK, 0); - splayroot = (struct splaynode *)NULL; - - if (b->verbose) { - printf(" Placing vertices in event heap.\n"); - } - createeventheap(m, &eventheap, &events, &freeevents); - heapsize = m->invertices; - - if (b->verbose) { - printf(" Forming triangulation.\n"); - } - maketriangle(m, b, &lefttri); - maketriangle(m, b, &righttri); - bond(lefttri, righttri); - lnextself(lefttri); - lprevself(righttri); - bond(lefttri, righttri); - lnextself(lefttri); - lprevself(righttri); - bond(lefttri, righttri); - firstvertex = (vertex)eventheap[0]->eventptr; - eventheap[0]->eventptr = (VOID *)freeevents; - freeevents = eventheap[0]; - eventheapdelete(eventheap, heapsize, 0); - heapsize--; - do { - if (heapsize == 0) { - printf("Error: Input vertices are all identical.\n"); - triexit(1); - } - secondvertex = (vertex)eventheap[0]->eventptr; - eventheap[0]->eventptr = (VOID *)freeevents; - freeevents = eventheap[0]; - eventheapdelete(eventheap, heapsize, 0); - heapsize--; - if ((firstvertex[0] == secondvertex[0]) && - (firstvertex[1] == secondvertex[1])) { - if (!b->quiet) { - printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " - "was ignored.\n", - secondvertex[0], secondvertex[1]); - } - setvertextype(secondvertex, UNDEADVERTEX); - m->undeads++; - } - } while ((firstvertex[0] == secondvertex[0]) && - (firstvertex[1] == secondvertex[1])); - setorg(lefttri, firstvertex); - setdest(lefttri, secondvertex); - setorg(righttri, secondvertex); - setdest(righttri, firstvertex); - lprev(lefttri, bottommost); - lastvertex = secondvertex; - while (heapsize > 0) { - nextevent = eventheap[0]; - eventheapdelete(eventheap, heapsize, 0); - heapsize--; - check4events = 1; - if (nextevent->xkey < m->xmin) { - decode(nextevent->eventptr, fliptri); - oprev(fliptri, farlefttri); - check4deadevent(&farlefttri, &freeevents, eventheap, &heapsize); - onext(fliptri, farrighttri); - check4deadevent(&farrighttri, &freeevents, eventheap, &heapsize); - - if (otriequal(farlefttri, bottommost)) { - lprev(fliptri, bottommost); - } - flip(m, b, &fliptri); - setapex(fliptri, NULL); - lprev(fliptri, lefttri); - lnext(fliptri, righttri); - sym(lefttri, farlefttri); - - if (randomnation(SAMPLERATE) == 0) { - symself(fliptri); - dest(fliptri, leftvertex); - apex(fliptri, midvertex); - org(fliptri, rightvertex); - splayroot = circletopinsert(m, b, splayroot, &lefttri, leftvertex, - midvertex, rightvertex, nextevent->ykey); - } - } else { - nextvertex = (vertex)nextevent->eventptr; - if ((nextvertex[0] == lastvertex[0]) && - (nextvertex[1] == lastvertex[1])) { - if (!b->quiet) { - printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " - "was ignored.\n", - nextvertex[0], nextvertex[1]); - } - setvertextype(nextvertex, UNDEADVERTEX); - m->undeads++; - check4events = 0; - } else { - lastvertex = nextvertex; - - splayroot = frontlocate(m, splayroot, &bottommost, nextvertex, - &searchtri, &farrightflag); - /* - otricopy(bottommost, searchtri); - farrightflag = 0; - while (!farrightflag && rightofhyperbola(m, &searchtri, - nextvertex)) { onextself(searchtri); farrightflag = - otriequal(searchtri, bottommost); - } - */ - - check4deadevent(&searchtri, &freeevents, eventheap, &heapsize); - - otricopy(searchtri, farrighttri); - sym(searchtri, farlefttri); - maketriangle(m, b, &lefttri); - maketriangle(m, b, &righttri); - dest(farrighttri, connectvertex); - setorg(lefttri, connectvertex); - setdest(lefttri, nextvertex); - setorg(righttri, nextvertex); - setdest(righttri, connectvertex); - bond(lefttri, righttri); - lnextself(lefttri); - lprevself(righttri); - bond(lefttri, righttri); - lnextself(lefttri); - lprevself(righttri); - bond(lefttri, farlefttri); - bond(righttri, farrighttri); - if (!farrightflag && otriequal(farrighttri, bottommost)) { - otricopy(lefttri, bottommost); - } - - if (randomnation(SAMPLERATE) == 0) { - splayroot = splayinsert(m, splayroot, &lefttri, nextvertex); - } else if (randomnation(SAMPLERATE) == 0) { - lnext(righttri, inserttri); - splayroot = splayinsert(m, splayroot, &inserttri, nextvertex); - } - } - } - nextevent->eventptr = (VOID *)freeevents; - freeevents = nextevent; - - if (check4events) { - apex(farlefttri, leftvertex); - dest(lefttri, midvertex); - apex(lefttri, rightvertex); - lefttest = counterclockwise(m, b, leftvertex, midvertex, rightvertex); - if (lefttest > 0.0) { - newevent = freeevents; - freeevents = (struct event *)freeevents->eventptr; - newevent->xkey = m->xminextreme; - newevent->ykey = - circletop(m, leftvertex, midvertex, rightvertex, lefttest); - newevent->eventptr = (VOID *)encode(lefttri); - eventheapinsert(eventheap, heapsize, newevent); - heapsize++; - setorg(lefttri, newevent); - } - apex(righttri, leftvertex); - org(righttri, midvertex); - apex(farrighttri, rightvertex); - righttest = counterclockwise(m, b, leftvertex, midvertex, rightvertex); - if (righttest > 0.0) { - newevent = freeevents; - freeevents = (struct event *)freeevents->eventptr; - newevent->xkey = m->xminextreme; - newevent->ykey = - circletop(m, leftvertex, midvertex, rightvertex, righttest); - newevent->eventptr = (VOID *)encode(farrighttri); - eventheapinsert(eventheap, heapsize, newevent); - heapsize++; - setorg(farrighttri, newevent); - } - } - } - - pooldeinit(&m->splaynodes); - lprevself(bottommost); - return removeghosts(m, b, &bottommost); -} - -#endif /* not REDUCED */ - -/** **/ -/** **/ -/********* Sweepline Delaunay triangulation ends here *********/ - -/********* General mesh construction routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* delaunay() Form a Delaunay triangulation. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -long delaunay(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -long delaunay(m, b) -struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - long hulledges; - - m->eextras = 0; - initializetrisubpools(m, b); - -#ifdef REDUCED - if (!b->quiet) { - printf( - "Constructing Delaunay triangulation by divide-and-conquer method.\n"); - } - hulledges = divconqdelaunay(m, b); -#else /* not REDUCED */ - if (!b->quiet) { - printf("Constructing Delaunay triangulation "); - if (b->incremental) { - printf("by incremental method.\n"); - } else if (b->sweepline) { - printf("by sweepline method.\n"); - } else { - printf("by divide-and-conquer method.\n"); - } - } - if (b->incremental) { - hulledges = incrementaldelaunay(m, b); - } else if (b->sweepline) { - hulledges = sweeplinedelaunay(m, b); - } else { - hulledges = divconqdelaunay(m, b); - } -#endif /* not REDUCED */ - - if (m->triangles.items == 0) { - /* The input vertices were all collinear, so there are no triangles. */ - return 0l; - } else { - return hulledges; - } -} - -/*****************************************************************************/ -/* */ -/* reconstruct() Reconstruct a triangulation from its .ele (and possibly */ -/* .poly) file. Used when the -r switch is used. */ -/* */ -/* Reads an .ele file and reconstructs the original mesh. If the -p switch */ -/* is used, this procedure will also read a .poly file and reconstruct the */ -/* subsegments of the original mesh. If the -a switch is used, this */ -/* procedure will also read an .area file and set a maximum area constraint */ -/* on each triangle. */ -/* */ -/* Vertices that are not corners of triangles, such as nodes on edges of */ -/* subparametric elements, are discarded. */ -/* */ -/* This routine finds the adjacencies between triangles (and subsegments) */ -/* by forming one stack of triangles for each vertex. Each triangle is on */ -/* three different stacks simultaneously. Each triangle's subsegment */ -/* pointers are used to link the items in each stack. This memory-saving */ -/* feature makes the code harder to read. The most important thing to keep */ -/* in mind is that each triangle is removed from a stack precisely when */ -/* the corresponding pointer is adjusted to refer to a subsegment rather */ -/* than the next triangle of the stack. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -int reconstruct(struct mesh *m, struct behavior *b, int *trianglelist, - REAL *triangleattriblist, REAL *trianglearealist, int elements, - int corners, int attribs, int *segmentlist, - int *segmentmarkerlist, int numberofsegments) -#else /* not ANSI_DECLARATORS */ -int reconstruct(m, b, trianglelist, triangleattriblist, trianglearealist, - elements, corners, attribs, segmentlist, segmentmarkerlist, - numberofsegments) -struct mesh *m; -struct behavior *b; -int *trianglelist; -REAL *triangleattriblist; -REAL *trianglearealist; -int elements; -int corners; -int attribs; -int *segmentlist; -int *segmentmarkerlist; -int numberofsegments; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -long reconstruct(struct mesh *m, struct behavior *b, char *elefilename, - char *areafilename, char *polyfilename, FILE *polyfile) -#else /* not ANSI_DECLARATORS */ -long reconstruct(m, b, elefilename, areafilename, polyfilename, polyfile) -struct mesh *m; -struct behavior *b; -char *elefilename; -char *areafilename; -char *polyfilename; -FILE *polyfile; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - int vertexindex; - int attribindex; -#else /* not TRILIBRARY */ - FILE *elefile; - FILE *areafile; - char inputline[INPUTLINESIZE]; - char *stringptr; - int areaelements; -#endif /* not TRILIBRARY */ - struct otri triangleloop; - struct otri triangleleft; - struct otri checktri; - struct otri checkleft; - struct otri checkneighbor; - struct osub subsegloop; - triangle *vertexarray; - triangle *prevlink; - triangle nexttri; - vertex tdest, tapex; - vertex checkdest, checkapex; - vertex shorg; - vertex killvertex; - vertex segmentorg, segmentdest; - REAL area; - int corner[3]; - int end[2]; - int killvertexindex; - int incorners; - int segmentmarkers; - int boundmarker; - int aroundvertex; - long hullsize; - int notfound; - long elementnumber, segmentnumber; - int i, j; - triangle ptr; /* Temporary variable used by sym(). */ - -#ifdef TRILIBRARY - m->inelements = elements; - incorners = corners; - if (incorners < 3) { - printf("Error: Triangles must have at least 3 vertices.\n"); - triexit(1); - } - m->eextras = attribs; -#else /* not TRILIBRARY */ - /* Read the triangles from an .ele file. */ - if (!b->quiet) { - printf("Opening %s.\n", elefilename); - } - elefile = fopen(elefilename, "r"); - if (elefile == (FILE *)NULL) { - printf(" Error: Cannot access file %s.\n", elefilename); - triexit(1); - } - /* Read number of triangles, number of vertices per triangle, and */ - /* number of triangle attributes from .ele file. */ - stringptr = readline(inputline, elefile, elefilename); - m->inelements = (int)strtol(stringptr, &stringptr, 0); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - incorners = 3; - } else { - incorners = (int)strtol(stringptr, &stringptr, 0); - if (incorners < 3) { - printf("Error: Triangles in %s must have at least 3 vertices.\n", - elefilename); - triexit(1); - } - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - m->eextras = 0; - } else { - m->eextras = (int)strtol(stringptr, &stringptr, 0); - } -#endif /* not TRILIBRARY */ - - initializetrisubpools(m, b); - - /* Create the triangles. */ - for (elementnumber = 1; elementnumber <= m->inelements; elementnumber++) { - maketriangle(m, b, &triangleloop); - /* Mark the triangle as living. */ - triangleloop.tri[3] = (triangle)triangleloop.tri; - } - - segmentmarkers = 0; - if (b->poly) { -#ifdef TRILIBRARY - m->insegments = numberofsegments; - segmentmarkers = segmentmarkerlist != (int *)NULL; -#else /* not TRILIBRARY */ - /* Read number of segments and number of segment */ - /* boundary markers from .poly file. */ - stringptr = readline(inputline, polyfile, b->inpolyfilename); - m->insegments = (int)strtol(stringptr, &stringptr, 0); - stringptr = findfield(stringptr); - if (*stringptr != '\0') { - segmentmarkers = (int)strtol(stringptr, &stringptr, 0); - } -#endif /* not TRILIBRARY */ - - /* Create the subsegments. */ - for (segmentnumber = 1; segmentnumber <= m->insegments; segmentnumber++) { - makesubseg(m, &subsegloop); - /* Mark the subsegment as living. */ - subsegloop.ss[2] = (subseg)subsegloop.ss; - } - } - -#ifdef TRILIBRARY - vertexindex = 0; - attribindex = 0; -#else /* not TRILIBRARY */ - if (b->vararea) { - /* Open an .area file, check for consistency with the .ele file. */ - if (!b->quiet) { - printf("Opening %s.\n", areafilename); - } - areafile = fopen(areafilename, "r"); - if (areafile == (FILE *)NULL) { - printf(" Error: Cannot access file %s.\n", areafilename); - triexit(1); - } - stringptr = readline(inputline, areafile, areafilename); - areaelements = (int)strtol(stringptr, &stringptr, 0); - if (areaelements != m->inelements) { - printf("Error: %s and %s disagree on number of triangles.\n", - elefilename, areafilename); - triexit(1); - } - } -#endif /* not TRILIBRARY */ - - if (!b->quiet) { - printf("Reconstructing mesh.\n"); - } - /* Allocate a temporary array that maps each vertex to some adjacent */ - /* triangle. I took care to allocate all the permanent memory for */ - /* triangles and subsegments first. */ - vertexarray = - (triangle *)trimalloc(m->vertices.items * (int)sizeof(triangle)); - /* Each vertex is initially unrepresented. */ - for (i = 0; i < m->vertices.items; i++) { - vertexarray[i] = (triangle)m->dummytri; - } - - if (b->verbose) { - printf(" Assembling triangles.\n"); - } - /* Read the triangles from the .ele file, and link */ - /* together those that share an edge. */ - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - elementnumber = b->firstnumber; - while (triangleloop.tri != (triangle *)NULL) { -#ifdef TRILIBRARY - /* Copy the triangle's three corners. */ - for (j = 0; j < 3; j++) { - corner[j] = trianglelist[vertexindex++]; - if ((corner[j] < b->firstnumber) || - (corner[j] >= b->firstnumber + m->invertices)) { - printf("Error: Triangle %ld has an invalid vertex index.\n", - elementnumber); - triexit(1); - } - } -#else /* not TRILIBRARY */ - /* Read triangle number and the triangle's three corners. */ - stringptr = readline(inputline, elefile, elefilename); - for (j = 0; j < 3; j++) { - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Triangle %ld is missing vertex %d in %s.\n", - elementnumber, j + 1, elefilename); - triexit(1); - } else { - corner[j] = (int)strtol(stringptr, &stringptr, 0); - if ((corner[j] < b->firstnumber) || - (corner[j] >= b->firstnumber + m->invertices)) { - printf("Error: Triangle %ld has an invalid vertex index.\n", - elementnumber); - triexit(1); - } - } - } -#endif /* not TRILIBRARY */ - - /* Find out about (and throw away) extra nodes. */ - for (j = 3; j < incorners; j++) { -#ifdef TRILIBRARY - killvertexindex = trianglelist[vertexindex++]; -#else /* not TRILIBRARY */ - stringptr = findfield(stringptr); - if (*stringptr != '\0') { - killvertexindex = (int)strtol(stringptr, &stringptr, 0); -#endif /* not TRILIBRARY */ - if ((killvertexindex >= b->firstnumber) && - (killvertexindex < b->firstnumber + m->invertices)) { - /* Delete the non-corner vertex if it's not already deleted. */ - killvertex = getvertex(m, b, killvertexindex); - if (vertextype(killvertex) != DEADVERTEX) { - vertexdealloc(m, killvertex); - } - } -#ifndef TRILIBRARY - } -#endif /* not TRILIBRARY */ - } - - /* Read the triangle's attributes. */ - for (j = 0; j < m->eextras; j++) { -#ifdef TRILIBRARY - setelemattribute(triangleloop, j, triangleattriblist[attribindex++]); -#else /* not TRILIBRARY */ - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - setelemattribute(triangleloop, j, 0); - } else { - setelemattribute(triangleloop, j, - (REAL)strtod(stringptr, &stringptr)); - } -#endif /* not TRILIBRARY */ - } - - if (b->vararea) { -#ifdef TRILIBRARY - area = trianglearealist[elementnumber - b->firstnumber]; -#else /* not TRILIBRARY */ - /* Read an area constraint from the .area file. */ - stringptr = readline(inputline, areafile, areafilename); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - area = -1.0; /* No constraint on this triangle. */ - } else { - area = (REAL)strtod(stringptr, &stringptr); - } -#endif /* not TRILIBRARY */ - setareabound(triangleloop, area); - } - - /* Set the triangle's vertices. */ - triangleloop.orient = 0; - setorg(triangleloop, getvertex(m, b, corner[0])); - setdest(triangleloop, getvertex(m, b, corner[1])); - setapex(triangleloop, getvertex(m, b, corner[2])); - /* Try linking the triangle to others that share these vertices. */ - for (triangleloop.orient = 0; triangleloop.orient < 3; - triangleloop.orient++) { - /* Take the number for the origin of triangleloop. */ - aroundvertex = corner[triangleloop.orient]; - /* Look for other triangles having this vertex. */ - nexttri = vertexarray[aroundvertex - b->firstnumber]; - /* Link the current triangle to the next one in the stack. */ - triangleloop.tri[6 + triangleloop.orient] = nexttri; - /* Push the current triangle onto the stack. */ - vertexarray[aroundvertex - b->firstnumber] = encode(triangleloop); - decode(nexttri, checktri); - if (checktri.tri != m->dummytri) { - dest(triangleloop, tdest); - apex(triangleloop, tapex); - /* Look for other triangles that share an edge. */ - do { - dest(checktri, checkdest); - apex(checktri, checkapex); - if (tapex == checkdest) { - /* The two triangles share an edge; bond them together. */ - lprev(triangleloop, triangleleft); - bond(triangleleft, checktri); - } - if (tdest == checkapex) { - /* The two triangles share an edge; bond them together. */ - lprev(checktri, checkleft); - bond(triangleloop, checkleft); - } - /* Find the next triangle in the stack. */ - nexttri = checktri.tri[6 + checktri.orient]; - decode(nexttri, checktri); - } while (checktri.tri != m->dummytri); - } - } - triangleloop.tri = triangletraverse(m); - elementnumber++; -} - -#ifdef TRILIBRARY -vertexindex = 0; -#else /* not TRILIBRARY */ - fclose(elefile); - if (b->vararea) { - fclose(areafile); - } -#endif /* not TRILIBRARY */ - -hullsize = 0; /* Prepare to count the boundary edges. */ -if (b->poly) { - if (b->verbose) { - printf(" Marking segments in triangulation.\n"); - } - /* Read the segments from the .poly file, and link them */ - /* to their neighboring triangles. */ - boundmarker = 0; - traversalinit(&m->subsegs); - subsegloop.ss = subsegtraverse(m); - segmentnumber = b->firstnumber; - while (subsegloop.ss != (subseg *)NULL) { -#ifdef TRILIBRARY - end[0] = segmentlist[vertexindex++]; - end[1] = segmentlist[vertexindex++]; - if (segmentmarkers) { - boundmarker = segmentmarkerlist[segmentnumber - b->firstnumber]; - } -#else /* not TRILIBRARY */ - /* Read the endpoints of each segment, and possibly a boundary marker. - */ - stringptr = readline(inputline, polyfile, b->inpolyfilename); - /* Skip the first (segment number) field. */ - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Segment %ld has no endpoints in %s.\n", segmentnumber, - polyfilename); - triexit(1); - } else { - end[0] = (int)strtol(stringptr, &stringptr, 0); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Segment %ld is missing its second endpoint in %s.\n", - segmentnumber, polyfilename); - triexit(1); - } else { - end[1] = (int)strtol(stringptr, &stringptr, 0); - } - if (segmentmarkers) { - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - boundmarker = 0; - } else { - boundmarker = (int)strtol(stringptr, &stringptr, 0); - } - } -#endif /* not TRILIBRARY */ - for (j = 0; j < 2; j++) { - if ((end[j] < b->firstnumber) || - (end[j] >= b->firstnumber + m->invertices)) { - printf("Error: Segment %ld has an invalid vertex index.\n", - segmentnumber); - triexit(1); - } - } - - /* set the subsegment's vertices. */ - subsegloop.ssorient = 0; - segmentorg = getvertex(m, b, end[0]); - segmentdest = getvertex(m, b, end[1]); - setsorg(subsegloop, segmentorg); - setsdest(subsegloop, segmentdest); - setsegorg(subsegloop, segmentorg); - setsegdest(subsegloop, segmentdest); - setmark(subsegloop, boundmarker); - /* Try linking the subsegment to triangles that share these vertices. */ - for (subsegloop.ssorient = 0; subsegloop.ssorient < 2; - subsegloop.ssorient++) { - /* Take the number for the destination of subsegloop. */ - aroundvertex = end[1 - subsegloop.ssorient]; - /* Look for triangles having this vertex. */ - prevlink = &vertexarray[aroundvertex - b->firstnumber]; - nexttri = vertexarray[aroundvertex - b->firstnumber]; - decode(nexttri, checktri); - sorg(subsegloop, shorg); - notfound = 1; - /* Look for triangles having this edge. Note that I'm only */ - /* comparing each triangle's destination with the subsegment; */ - /* each triangle's apex is handled through a different vertex. */ - /* Because each triangle appears on three vertices' lists, each */ - /* occurrence of a triangle on a list can (and does) represent */ - /* an edge. In this way, most edges are represented twice, and */ - /* every triangle-subsegment bond is represented once. */ - while (notfound && (checktri.tri != m->dummytri)) { - dest(checktri, checkdest); - if (shorg == checkdest) { - /* We have a match. Remove this triangle from the list. */ - *prevlink = checktri.tri[6 + checktri.orient]; - /* Bond the subsegment to the triangle. */ - tsbond(checktri, subsegloop); - /* Check if this is a boundary edge. */ - sym(checktri, checkneighbor); - if (checkneighbor.tri == m->dummytri) { - /* The next line doesn't insert a subsegment (because there's */ - /* already one there), but it sets the boundary markers of */ - /* the existing subsegment and its vertices. */ - insertsubseg(m, b, &checktri, 1); - hullsize++; - } - notfound = 0; - } - /* Find the next triangle in the stack. */ - prevlink = &checktri.tri[6 + checktri.orient]; - nexttri = checktri.tri[6 + checktri.orient]; - decode(nexttri, checktri); - } - } - subsegloop.ss = subsegtraverse(m); - segmentnumber++; - } -} - -/* Mark the remaining edges as not being attached to any subsegment. */ -/* Also, count the (yet uncounted) boundary edges. */ -for (i = 0; i < m->vertices.items; i++) { - /* Search the stack of triangles adjacent to a vertex. */ - nexttri = vertexarray[i]; - decode(nexttri, checktri); - while (checktri.tri != m->dummytri) { - /* Find the next triangle in the stack before this */ - /* information gets overwritten. */ - nexttri = checktri.tri[6 + checktri.orient]; - /* No adjacent subsegment. (This overwrites the stack info.) */ - tsdissolve(checktri); - sym(checktri, checkneighbor); - if (checkneighbor.tri == m->dummytri) { - insertsubseg(m, b, &checktri, 1); - hullsize++; - } - decode(nexttri, checktri); - } -} - -trifree((VOID *)vertexarray); -return hullsize; -} - -#endif /* not CDT_ONLY */ - -/** **/ -/** **/ -/********* General mesh construction routines end here *********/ - -/********* Segment insertion begins here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* finddirection() Find the first triangle on the path from one point */ -/* to another. */ -/* */ -/* Finds the triangle that intersects a line segment drawn from the */ -/* origin of `searchtri' to the point `searchpoint', and returns the result */ -/* in `searchtri'. The origin of `searchtri' does not change, even though */ -/* the triangle returned may differ from the one passed in. This routine */ -/* is used to find the direction to move in to get from one point to */ -/* another. */ -/* */ -/* The return value notes whether the destination or apex of the found */ -/* triangle is collinear with the two points in question. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -enum finddirectionresult finddirection(struct mesh *m, struct behavior *b, - struct otri *searchtri, - vertex searchpoint) -#else /* not ANSI_DECLARATORS */ -enum finddirectionresult finddirection(m, b, searchtri, searchpoint) -struct mesh *m; -struct behavior *b; -struct otri *searchtri; -vertex searchpoint; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri checktri; - vertex startvertex; - vertex leftvertex, rightvertex; - REAL leftccw, rightccw; - int leftflag, rightflag; - triangle ptr; /* Temporary variable used by onext() and oprev(). */ - - org(*searchtri, startvertex); - dest(*searchtri, rightvertex); - apex(*searchtri, leftvertex); - /* Is `searchpoint' to the left? */ - leftccw = counterclockwise(m, b, searchpoint, startvertex, leftvertex); - leftflag = leftccw > 0.0; - /* Is `searchpoint' to the right? */ - rightccw = counterclockwise(m, b, startvertex, searchpoint, rightvertex); - rightflag = rightccw > 0.0; - if (leftflag && rightflag) { - /* `searchtri' faces directly away from `searchpoint'. We could go left */ - /* or right. Ask whether it's a triangle or a boundary on the left. */ - onext(*searchtri, checktri); - if (checktri.tri == m->dummytri) { - leftflag = 0; - } else { - rightflag = 0; - } - } - while (leftflag) { - /* Turn left until satisfied. */ - onextself(*searchtri); - if (searchtri->tri == m->dummytri) { - printf("Internal error in finddirection(): Unable to find a\n"); - printf(" triangle leading from (%.12g, %.12g) to", startvertex[0], - startvertex[1]); - printf(" (%.12g, %.12g).\n", searchpoint[0], searchpoint[1]); - internalerror(); - } - apex(*searchtri, leftvertex); - rightccw = leftccw; - leftccw = counterclockwise(m, b, searchpoint, startvertex, leftvertex); - leftflag = leftccw > 0.0; - } - while (rightflag) { - /* Turn right until satisfied. */ - oprevself(*searchtri); - if (searchtri->tri == m->dummytri) { - printf("Internal error in finddirection(): Unable to find a\n"); - printf(" triangle leading from (%.12g, %.12g) to", startvertex[0], - startvertex[1]); - printf(" (%.12g, %.12g).\n", searchpoint[0], searchpoint[1]); - internalerror(); - } - dest(*searchtri, rightvertex); - leftccw = rightccw; - rightccw = counterclockwise(m, b, startvertex, searchpoint, rightvertex); - rightflag = rightccw > 0.0; - } - if (leftccw == 0.0) { - return LEFTCOLLINEAR; - } else if (rightccw == 0.0) { - return RIGHTCOLLINEAR; - } else { - return WITHIN; - } -} - -/*****************************************************************************/ -/* */ -/* segmentintersection() Find the intersection of an existing segment */ -/* and a segment that is being inserted. Insert */ -/* a vertex at the intersection, splitting an */ -/* existing subsegment. */ -/* */ -/* The segment being inserted connects the apex of splittri to endpoint2. */ -/* splitsubseg is the subsegment being split, and MUST adjoin splittri. */ -/* Hence, endpoints of the subsegment being split are the origin and */ -/* destination of splittri. */ -/* */ -/* On completion, splittri is a handle having the newly inserted */ -/* intersection point as its origin, and endpoint1 as its destination. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void segmentintersection(struct mesh *m, struct behavior *b, - struct otri *splittri, struct osub *splitsubseg, - vertex endpoint2) -#else /* not ANSI_DECLARATORS */ -void segmentintersection(m, b, splittri, splitsubseg, endpoint2) struct mesh *m; -struct behavior *b; -struct otri *splittri; -struct osub *splitsubseg; -vertex endpoint2; -#endif /* not ANSI_DECLARATORS */ - -{ - struct osub opposubseg; - vertex endpoint1; - vertex torg, tdest; - vertex leftvertex, rightvertex; - vertex newvertex; - enum insertvertexresult success; - enum finddirectionresult collinear; - REAL ex, ey; - REAL tx, ty; - REAL etx, ety; - REAL split, denom; - int i; - triangle ptr; /* Temporary variable used by onext(). */ - subseg sptr; /* Temporary variable used by snext(). */ - - /* Find the other three segment endpoints. */ - apex(*splittri, endpoint1); - org(*splittri, torg); - dest(*splittri, tdest); - /* Segment intersection formulae; see the Antonio reference. */ - tx = tdest[0] - torg[0]; - ty = tdest[1] - torg[1]; - ex = endpoint2[0] - endpoint1[0]; - ey = endpoint2[1] - endpoint1[1]; - etx = torg[0] - endpoint2[0]; - ety = torg[1] - endpoint2[1]; - denom = ty * ex - tx * ey; - if (denom == 0.0) { - printf("Internal error in segmentintersection():"); - printf(" Attempt to find intersection of parallel segments.\n"); - internalerror(); - } - split = (ey * etx - ex * ety) / denom; - /* Create the new vertex. */ - newvertex = (vertex)poolalloc(&m->vertices); - /* Interpolate its coordinate and attributes. */ - for (i = 0; i < 2 + m->nextras; i++) { - newvertex[i] = torg[i] + split * (tdest[i] - torg[i]); - } - setvertexmark(newvertex, mark(*splitsubseg)); - setvertextype(newvertex, INPUTVERTEX); - if (b->verbose > 1) { - printf(" Splitting subsegment (%.12g, %.12g) (%.12g, %.12g) at (%.12g, " - "%.12g).\n", - torg[0], torg[1], tdest[0], tdest[1], newvertex[0], newvertex[1]); - } - /* Insert the intersection vertex. This should always succeed. */ - success = insertvertex(m, b, newvertex, splittri, splitsubseg, 0, 0); - if (success != SUCCESSFULVERTEX) { - printf("Internal error in segmentintersection():\n"); - printf(" Failure to split a segment.\n"); - internalerror(); - } - /* Record a triangle whose origin is the new vertex. */ - setvertex2tri(newvertex, encode(*splittri)); - if (m->steinerleft > 0) { - m->steinerleft--; - } - - /* Divide the segment into two, and correct the segment endpoints. */ - ssymself(*splitsubseg); - spivot(*splitsubseg, opposubseg); - sdissolve(*splitsubseg); - sdissolve(opposubseg); - do { - setsegorg(*splitsubseg, newvertex); - snextself(*splitsubseg); - } while (splitsubseg->ss != m->dummysub); - do { - setsegorg(opposubseg, newvertex); - snextself(opposubseg); - } while (opposubseg.ss != m->dummysub); - - /* Inserting the vertex may have caused edge flips. We wish to rediscover */ - /* the edge connecting endpoint1 to the new intersection vertex. */ - collinear = finddirection(m, b, splittri, endpoint1); - dest(*splittri, rightvertex); - apex(*splittri, leftvertex); - if ((leftvertex[0] == endpoint1[0]) && (leftvertex[1] == endpoint1[1])) { - onextself(*splittri); - } else if ((rightvertex[0] != endpoint1[0]) || - (rightvertex[1] != endpoint1[1])) { - printf("Internal error in segmentintersection():\n"); - printf(" Topological inconsistency after splitting a segment.\n"); - internalerror(); - } - /* `splittri' should have destination endpoint1. */ -} - -/*****************************************************************************/ -/* */ -/* scoutsegment() Scout the first triangle on the path from one endpoint */ -/* to another, and check for completion (reaching the */ -/* second endpoint), a collinear vertex, or the */ -/* intersection of two segments. */ -/* */ -/* Returns one if the entire segment is successfully inserted, and zero if */ -/* the job must be finished by conformingedge() or constrainededge(). */ -/* */ -/* If the first triangle on the path has the second endpoint as its */ -/* destination or apex, a subsegment is inserted and the job is done. */ -/* */ -/* If the first triangle on the path has a destination or apex that lies on */ -/* the segment, a subsegment is inserted connecting the first endpoint to */ -/* the collinear vertex, and the search is continued from the collinear */ -/* vertex. */ -/* */ -/* If the first triangle on the path has a subsegment opposite its origin, */ -/* then there is a segment that intersects the segment being inserted. */ -/* Their intersection vertex is inserted, splitting the subsegment. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -int scoutsegment(struct mesh *m, struct behavior *b, struct otri *searchtri, - vertex endpoint2, int newmark) -#else /* not ANSI_DECLARATORS */ -int scoutsegment(m, b, searchtri, endpoint2, newmark) -struct mesh *m; -struct behavior *b; -struct otri *searchtri; -vertex endpoint2; -int newmark; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri crosstri; - struct osub crosssubseg; - vertex leftvertex, rightvertex; - enum finddirectionresult collinear; - subseg sptr; /* Temporary variable used by tspivot(). */ - - collinear = finddirection(m, b, searchtri, endpoint2); - dest(*searchtri, rightvertex); - apex(*searchtri, leftvertex); - if (((leftvertex[0] == endpoint2[0]) && (leftvertex[1] == endpoint2[1])) || - ((rightvertex[0] == endpoint2[0]) && (rightvertex[1] == endpoint2[1]))) { - /* The segment is already an edge in the mesh. */ - if ((leftvertex[0] == endpoint2[0]) && (leftvertex[1] == endpoint2[1])) { - lprevself(*searchtri); - } - /* Insert a subsegment, if there isn't already one there. */ - insertsubseg(m, b, searchtri, newmark); - return 1; - } else if (collinear == LEFTCOLLINEAR) { - /* We've collided with a vertex between the segment's endpoints. */ - /* Make the collinear vertex be the triangle's origin. */ - lprevself(*searchtri); - insertsubseg(m, b, searchtri, newmark); - /* Insert the remainder of the segment. */ - return scoutsegment(m, b, searchtri, endpoint2, newmark); - } else if (collinear == RIGHTCOLLINEAR) { - /* We've collided with a vertex between the segment's endpoints. */ - insertsubseg(m, b, searchtri, newmark); - /* Make the collinear vertex be the triangle's origin. */ - lnextself(*searchtri); - /* Insert the remainder of the segment. */ - return scoutsegment(m, b, searchtri, endpoint2, newmark); - } else { - lnext(*searchtri, crosstri); - tspivot(crosstri, crosssubseg); - /* Check for a crossing segment. */ - if (crosssubseg.ss == m->dummysub) { - return 0; - } else { - /* Insert a vertex at the intersection. */ - segmentintersection(m, b, &crosstri, &crosssubseg, endpoint2); - otricopy(crosstri, *searchtri); - insertsubseg(m, b, searchtri, newmark); - /* Insert the remainder of the segment. */ - return scoutsegment(m, b, searchtri, endpoint2, newmark); - } - } -} - -/*****************************************************************************/ -/* */ -/* conformingedge() Force a segment into a conforming Delaunay */ -/* triangulation by inserting a vertex at its midpoint, */ -/* and recursively forcing in the two half-segments if */ -/* necessary. */ -/* */ -/* Generates a sequence of subsegments connecting `endpoint1' to */ -/* `endpoint2'. `newmark' is the boundary marker of the segment, assigned */ -/* to each new splitting vertex and subsegment. */ -/* */ -/* Note that conformingedge() does not always maintain the conforming */ -/* Delaunay property. Once inserted, segments are locked into place; */ -/* vertices inserted later (to force other segments in) may render these */ -/* fixed segments non-Delaunay. The conforming Delaunay property will be */ -/* restored by enforcequality() by splitting encroached subsegments. */ -/* */ -/*****************************************************************************/ - -#ifndef REDUCED -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void conformingedge(struct mesh *m, struct behavior *b, vertex endpoint1, - vertex endpoint2, int newmark) -#else /* not ANSI_DECLARATORS */ -void conformingedge(m, b, endpoint1, endpoint2, newmark) struct mesh *m; -struct behavior *b; -vertex endpoint1; -vertex endpoint2; -int newmark; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri searchtri1, searchtri2; - struct osub brokensubseg; - vertex newvertex; - vertex midvertex1, midvertex2; - enum insertvertexresult success; - int i; - subseg sptr; /* Temporary variable used by tspivot(). */ - - if (b->verbose > 2) { - printf("Forcing segment into triangulation by recursive splitting:\n"); - printf(" (%.12g, %.12g) (%.12g, %.12g)\n", endpoint1[0], endpoint1[1], - endpoint2[0], endpoint2[1]); - } - /* Create a new vertex to insert in the middle of the segment. */ - newvertex = (vertex)poolalloc(&m->vertices); - /* Interpolate coordinates and attributes. */ - for (i = 0; i < 2 + m->nextras; i++) { - newvertex[i] = 0.5 * (endpoint1[i] + endpoint2[i]); - } - setvertexmark(newvertex, newmark); - setvertextype(newvertex, SEGMENTVERTEX); - /* No known triangle to search from. */ - searchtri1.tri = m->dummytri; - /* Attempt to insert the new vertex. */ - success = - insertvertex(m, b, newvertex, &searchtri1, (struct osub *)NULL, 0, 0); - if (success == DUPLICATEVERTEX) { - if (b->verbose > 2) { - printf(" Segment intersects existing vertex (%.12g, %.12g).\n", - newvertex[0], newvertex[1]); - } - /* Use the vertex that's already there. */ - vertexdealloc(m, newvertex); - org(searchtri1, newvertex); - } else { - if (success == VIOLATINGVERTEX) { - if (b->verbose > 2) { - printf(" Two segments intersect at (%.12g, %.12g).\n", newvertex[0], - newvertex[1]); - } - /* By fluke, we've landed right on another segment. Split it. */ - tspivot(searchtri1, brokensubseg); - success = insertvertex(m, b, newvertex, &searchtri1, &brokensubseg, 0, 0); - if (success != SUCCESSFULVERTEX) { - printf("Internal error in conformingedge():\n"); - printf(" Failure to split a segment.\n"); - internalerror(); - } - } - /* The vertex has been inserted successfully. */ - if (m->steinerleft > 0) { - m->steinerleft--; - } - } - otricopy(searchtri1, searchtri2); - /* `searchtri1' and `searchtri2' are fastened at their origins to */ - /* `newvertex', and will be directed toward `endpoint1' and `endpoint2' */ - /* respectively. First, we must get `searchtri2' out of the way so it */ - /* won't be invalidated during the insertion of the first half of the */ - /* segment. */ - finddirection(m, b, &searchtri2, endpoint2); - if (!scoutsegment(m, b, &searchtri1, endpoint1, newmark)) { - /* The origin of searchtri1 may have changed if a collision with an */ - /* intervening vertex on the segment occurred. */ - org(searchtri1, midvertex1); - conformingedge(m, b, midvertex1, endpoint1, newmark); - } - if (!scoutsegment(m, b, &searchtri2, endpoint2, newmark)) { - /* The origin of searchtri2 may have changed if a collision with an */ - /* intervening vertex on the segment occurred. */ - org(searchtri2, midvertex2); - conformingedge(m, b, midvertex2, endpoint2, newmark); - } -} - -#endif /* not CDT_ONLY */ -#endif /* not REDUCED */ - -/*****************************************************************************/ -/* */ -/* delaunayfixup() Enforce the Delaunay condition at an edge, fanning out */ -/* recursively from an existing vertex. Pay special */ -/* attention to stacking inverted triangles. */ -/* */ -/* This is a support routine for inserting segments into a constrained */ -/* Delaunay triangulation. */ -/* */ -/* The origin of fixuptri is treated as if it has just been inserted, and */ -/* the local Delaunay condition needs to be enforced. It is only enforced */ -/* in one sector, however, that being the angular range defined by */ -/* fixuptri. */ -/* */ -/* This routine also needs to make decisions regarding the "stacking" of */ -/* triangles. (Read the description of constrainededge() below before */ -/* reading on here, so you understand the algorithm.) If the position of */ -/* the new vertex (the origin of fixuptri) indicates that the vertex before */ -/* it on the polygon is a reflex vertex, then "stack" the triangle by */ -/* doing nothing. (fixuptri is an inverted triangle, which is how stacked */ -/* triangles are identified.) */ -/* */ -/* Otherwise, check whether the vertex before that was a reflex vertex. */ -/* If so, perform an edge flip, thereby eliminating an inverted triangle */ -/* (popping it off the stack). The edge flip may result in the creation */ -/* of a new inverted triangle, depending on whether or not the new vertex */ -/* is visible to the vertex three edges behind on the polygon. */ -/* */ -/* If neither of the two vertices behind the new vertex are reflex */ -/* vertices, fixuptri and fartri, the triangle opposite it, are not */ -/* inverted; hence, ensure that the edge between them is locally Delaunay. */ -/* */ -/* `leftside' indicates whether or not fixuptri is to the left of the */ -/* segment being inserted. (Imagine that the segment is pointing up from */ -/* endpoint1 to endpoint2.) */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void delaunayfixup(struct mesh *m, struct behavior *b, struct otri *fixuptri, - int leftside) -#else /* not ANSI_DECLARATORS */ -void delaunayfixup(m, b, fixuptri, leftside) struct mesh *m; -struct behavior *b; -struct otri *fixuptri; -int leftside; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri neartri; - struct otri fartri; - struct osub faredge; - vertex nearvertex, leftvertex, rightvertex, farvertex; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - lnext(*fixuptri, neartri); - sym(neartri, fartri); - /* Check if the edge opposite the origin of fixuptri can be flipped. */ - if (fartri.tri == m->dummytri) { - return; - } - tspivot(neartri, faredge); - if (faredge.ss != m->dummysub) { - return; - } - /* Find all the relevant vertices. */ - apex(neartri, nearvertex); - org(neartri, leftvertex); - dest(neartri, rightvertex); - apex(fartri, farvertex); - /* Check whether the previous polygon vertex is a reflex vertex. */ - if (leftside) { - if (counterclockwise(m, b, nearvertex, leftvertex, farvertex) <= 0.0) { - /* leftvertex is a reflex vertex too. Nothing can */ - /* be done until a convex section is found. */ - return; - } - } else { - if (counterclockwise(m, b, farvertex, rightvertex, nearvertex) <= 0.0) { - /* rightvertex is a reflex vertex too. Nothing can */ - /* be done until a convex section is found. */ - return; - } - } - if (counterclockwise(m, b, rightvertex, leftvertex, farvertex) > 0.0) { - /* fartri is not an inverted triangle, and farvertex is not a reflex */ - /* vertex. As there are no reflex vertices, fixuptri isn't an */ - /* inverted triangle, either. Hence, test the edge between the */ - /* triangles to ensure it is locally Delaunay. */ - if (incircle(m, b, leftvertex, farvertex, rightvertex, nearvertex) <= 0.0) { - return; - } - /* Not locally Delaunay; go on to an edge flip. */ - } /* else fartri is inverted; remove it from the stack by flipping. */ - flip(m, b, &neartri); - lprevself(*fixuptri); /* Restore the origin of fixuptri after the flip. */ - /* Recursively process the two triangles that result from the flip. */ - delaunayfixup(m, b, fixuptri, leftside); - delaunayfixup(m, b, &fartri, leftside); -} - -/*****************************************************************************/ -/* */ -/* constrainededge() Force a segment into a constrained Delaunay */ -/* triangulation by deleting the triangles it */ -/* intersects, and triangulating the polygons that */ -/* form on each side of it. */ -/* */ -/* Generates a single subsegment connecting `endpoint1' to `endpoint2'. */ -/* The triangle `starttri' has `endpoint1' as its origin. `newmark' is the */ -/* boundary marker of the segment. */ -/* */ -/* To insert a segment, every triangle whose interior intersects the */ -/* segment is deleted. The union of these deleted triangles is a polygon */ -/* (which is not necessarily monotone, but is close enough), which is */ -/* divided into two polygons by the new segment. This routine's task is */ -/* to generate the Delaunay triangulation of these two polygons. */ -/* */ -/* You might think of this routine's behavior as a two-step process. The */ -/* first step is to walk from endpoint1 to endpoint2, flipping each edge */ -/* encountered. This step creates a fan of edges connected to endpoint1, */ -/* including the desired edge to endpoint2. The second step enforces the */ -/* Delaunay condition on each side of the segment in an incremental manner: */ -/* proceeding along the polygon from endpoint1 to endpoint2 (this is done */ -/* independently on each side of the segment), each vertex is "enforced" */ -/* as if it had just been inserted, but affecting only the previous */ -/* vertices. The result is the same as if the vertices had been inserted */ -/* in the order they appear on the polygon, so the result is Delaunay. */ -/* */ -/* In truth, constrainededge() interleaves these two steps. The procedure */ -/* walks from endpoint1 to endpoint2, and each time an edge is encountered */ -/* and flipped, the newly exposed vertex (at the far end of the flipped */ -/* edge) is "enforced" upon the previously flipped edges, usually affecting */ -/* only one side of the polygon (depending upon which side of the segment */ -/* the vertex falls on). */ -/* */ -/* The algorithm is complicated by the need to handle polygons that are not */ -/* convex. Although the polygon is not necessarily monotone, it can be */ -/* triangulated in a manner similar to the stack-based algorithms for */ -/* monotone polygons. For each reflex vertex (local concavity) of the */ -/* polygon, there will be an inverted triangle formed by one of the edge */ -/* flips. (An inverted triangle is one with negative area - that is, its */ -/* vertices are arranged in clockwise order - and is best thought of as a */ -/* wrinkle in the fabric of the mesh.) Each inverted triangle can be */ -/* thought of as a reflex vertex pushed on the stack, waiting to be fixed */ -/* later. */ -/* */ -/* A reflex vertex is popped from the stack when a vertex is inserted that */ -/* is visible to the reflex vertex. (However, if the vertex behind the */ -/* reflex vertex is not visible to the reflex vertex, a new inverted */ -/* triangle will take its place on the stack.) These details are handled */ -/* by the delaunayfixup() routine above. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void constrainededge(struct mesh *m, struct behavior *b, struct otri *starttri, - vertex endpoint2, int newmark) -#else /* not ANSI_DECLARATORS */ -void constrainededge(m, b, starttri, endpoint2, newmark) struct mesh *m; -struct behavior *b; -struct otri *starttri; -vertex endpoint2; -int newmark; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri fixuptri, fixuptri2; - struct osub crosssubseg; - vertex endpoint1; - vertex farvertex; - REAL area; - int collision; - int done; - triangle ptr; /* Temporary variable used by sym() and oprev(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - org(*starttri, endpoint1); - lnext(*starttri, fixuptri); - flip(m, b, &fixuptri); - /* `collision' indicates whether we have found a vertex directly */ - /* between endpoint1 and endpoint2. */ - collision = 0; - done = 0; - do { - org(fixuptri, farvertex); - /* `farvertex' is the extreme point of the polygon we are "digging" */ - /* to get from endpoint1 to endpoint2. */ - if ((farvertex[0] == endpoint2[0]) && (farvertex[1] == endpoint2[1])) { - oprev(fixuptri, fixuptri2); - /* Enforce the Delaunay condition around endpoint2. */ - delaunayfixup(m, b, &fixuptri, 0); - delaunayfixup(m, b, &fixuptri2, 1); - done = 1; - } else { - /* Check whether farvertex is to the left or right of the segment */ - /* being inserted, to decide which edge of fixuptri to dig */ - /* through next. */ - area = counterclockwise(m, b, endpoint1, endpoint2, farvertex); - if (area == 0.0) { - /* We've collided with a vertex between endpoint1 and endpoint2. */ - collision = 1; - oprev(fixuptri, fixuptri2); - /* Enforce the Delaunay condition around farvertex. */ - delaunayfixup(m, b, &fixuptri, 0); - delaunayfixup(m, b, &fixuptri2, 1); - done = 1; - } else { - if (area > 0.0) { /* farvertex is to the left of the segment. */ - oprev(fixuptri, fixuptri2); - /* Enforce the Delaunay condition around farvertex, on the */ - /* left side of the segment only. */ - delaunayfixup(m, b, &fixuptri2, 1); - /* Flip the edge that crosses the segment. After the edge is */ - /* flipped, one of its endpoints is the fan vertex, and the */ - /* destination of fixuptri is the fan vertex. */ - lprevself(fixuptri); - } else { /* farvertex is to the right of the segment. */ - delaunayfixup(m, b, &fixuptri, 0); - /* Flip the edge that crosses the segment. After the edge is */ - /* flipped, one of its endpoints is the fan vertex, and the */ - /* destination of fixuptri is the fan vertex. */ - oprevself(fixuptri); - } - /* Check for two intersecting segments. */ - tspivot(fixuptri, crosssubseg); - if (crosssubseg.ss == m->dummysub) { - flip(m, b, &fixuptri); /* May create inverted triangle at left. */ - } else { - /* We've collided with a segment between endpoint1 and endpoint2. */ - collision = 1; - /* Insert a vertex at the intersection. */ - segmentintersection(m, b, &fixuptri, &crosssubseg, endpoint2); - done = 1; - } - } - } - } while (!done); - /* Insert a subsegment to make the segment permanent. */ - insertsubseg(m, b, &fixuptri, newmark); - /* If there was a collision with an interceding vertex, install another */ - /* segment connecting that vertex with endpoint2. */ - if (collision) { - /* Insert the remainder of the segment. */ - if (!scoutsegment(m, b, &fixuptri, endpoint2, newmark)) { - constrainededge(m, b, &fixuptri, endpoint2, newmark); - } - } -} - -/*****************************************************************************/ -/* */ -/* insertsegment() Insert a PSLG segment into a triangulation. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void insertsegment(struct mesh *m, struct behavior *b, vertex endpoint1, - vertex endpoint2, int newmark) -#else /* not ANSI_DECLARATORS */ -void insertsegment(m, b, endpoint1, endpoint2, newmark) struct mesh *m; -struct behavior *b; -vertex endpoint1; -vertex endpoint2; -int newmark; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri searchtri1, searchtri2; - triangle encodedtri; - vertex checkvertex; - triangle ptr; /* Temporary variable used by sym(). */ - - if (b->verbose > 1) { - printf(" Connecting (%.12g, %.12g) to (%.12g, %.12g).\n", endpoint1[0], - endpoint1[1], endpoint2[0], endpoint2[1]); - } - - /* Find a triangle whose origin is the segment's first endpoint. */ - checkvertex = (vertex)NULL; - encodedtri = vertex2tri(endpoint1); - if (encodedtri != (triangle)NULL) { - decode(encodedtri, searchtri1); - org(searchtri1, checkvertex); - } - if (checkvertex != endpoint1) { - /* Find a boundary triangle to search from. */ - searchtri1.tri = m->dummytri; - searchtri1.orient = 0; - symself(searchtri1); - /* Search for the segment's first endpoint by point location. */ - if (locate(m, b, endpoint1, &searchtri1) != ONVERTEX) { - printf( - "Internal error in insertsegment(): Unable to locate PSLG vertex\n"); - printf(" (%.12g, %.12g) in triangulation.\n", endpoint1[0], - endpoint1[1]); - internalerror(); - } - } - /* Remember this triangle to improve subsequent point location. */ - otricopy(searchtri1, m->recenttri); - /* Scout the beginnings of a path from the first endpoint */ - /* toward the second. */ - if (scoutsegment(m, b, &searchtri1, endpoint2, newmark)) { - /* The segment was easily inserted. */ - return; - } - /* The first endpoint may have changed if a collision with an intervening */ - /* vertex on the segment occurred. */ - org(searchtri1, endpoint1); - - /* Find a triangle whose origin is the segment's second endpoint. */ - checkvertex = (vertex)NULL; - encodedtri = vertex2tri(endpoint2); - if (encodedtri != (triangle)NULL) { - decode(encodedtri, searchtri2); - org(searchtri2, checkvertex); - } - if (checkvertex != endpoint2) { - /* Find a boundary triangle to search from. */ - searchtri2.tri = m->dummytri; - searchtri2.orient = 0; - symself(searchtri2); - /* Search for the segment's second endpoint by point location. */ - if (locate(m, b, endpoint2, &searchtri2) != ONVERTEX) { - printf( - "Internal error in insertsegment(): Unable to locate PSLG vertex\n"); - printf(" (%.12g, %.12g) in triangulation.\n", endpoint2[0], - endpoint2[1]); - internalerror(); - } - } - /* Remember this triangle to improve subsequent point location. */ - otricopy(searchtri2, m->recenttri); - /* Scout the beginnings of a path from the second endpoint */ - /* toward the first. */ - if (scoutsegment(m, b, &searchtri2, endpoint1, newmark)) { - /* The segment was easily inserted. */ - return; - } - /* The second endpoint may have changed if a collision with an intervening */ - /* vertex on the segment occurred. */ - org(searchtri2, endpoint2); - -#ifndef REDUCED -#ifndef CDT_ONLY - if (b->splitseg) { - /* Insert vertices to force the segment into the triangulation. */ - conformingedge(m, b, endpoint1, endpoint2, newmark); - } else { -#endif /* not CDT_ONLY */ -#endif /* not REDUCED */ - /* Insert the segment directly into the triangulation. */ - constrainededge(m, b, &searchtri1, endpoint2, newmark); -#ifndef REDUCED -#ifndef CDT_ONLY - } -#endif /* not CDT_ONLY */ -#endif /* not REDUCED */ -} - -/*****************************************************************************/ -/* */ -/* markhull() Cover the convex hull of a triangulation with subsegments. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void markhull(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void markhull(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri hulltri; - struct otri nexttri; - struct otri starttri; - triangle ptr; /* Temporary variable used by sym() and oprev(). */ - - /* Find a triangle handle on the hull. */ - hulltri.tri = m->dummytri; - hulltri.orient = 0; - symself(hulltri); - /* Remember where we started so we know when to stop. */ - otricopy(hulltri, starttri); - /* Go once counterclockwise around the convex hull. */ - do { - /* Create a subsegment if there isn't already one here. */ - insertsubseg(m, b, &hulltri, 1); - /* To find the next hull edge, go clockwise around the next vertex. */ - lnextself(hulltri); - oprev(hulltri, nexttri); - while (nexttri.tri != m->dummytri) { - otricopy(nexttri, hulltri); - oprev(hulltri, nexttri); - } - } while (!otriequal(hulltri, starttri)); -} - -/*****************************************************************************/ -/* */ -/* formskeleton() Create the segments of a triangulation, including PSLG */ -/* segments and edges on the convex hull. */ -/* */ -/* The PSLG segments are read from a .poly file. The return value is the */ -/* number of segments in the file. */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void formskeleton(struct mesh *m, struct behavior *b, int *segmentlist, - int *segmentmarkerlist, int numberofsegments) -#else /* not ANSI_DECLARATORS */ - void formskeleton(m, b, segmentlist, segmentmarkerlist, - numberofsegments) struct mesh *m; - struct behavior *b; - int *segmentlist; - int *segmentmarkerlist; - int numberofsegments; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -void formskeleton(struct mesh *m, struct behavior *b, FILE *polyfile, - char *polyfilename) -#else /* not ANSI_DECLARATORS */ -void formskeleton(m, b, polyfile, polyfilename) struct mesh *m; -struct behavior *b; -FILE *polyfile; -char *polyfilename; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - char polyfilename[6]; - int index; -#else /* not TRILIBRARY */ - char inputline[INPUTLINESIZE]; - char *stringptr; -#endif /* not TRILIBRARY */ - vertex endpoint1, endpoint2; - int segmentmarkers; - int end1, end2; - int boundmarker; - int i; - - if (b->poly) { - if (!b->quiet) { - printf("Recovering segments in Delaunay triangulation.\n"); - } -#ifdef TRILIBRARY - strcpy(polyfilename, "input"); - m->insegments = numberofsegments; - segmentmarkers = segmentmarkerlist != (int *)NULL; - index = 0; -#else /* not TRILIBRARY */ - /* Read the segments from a .poly file. */ - /* Read number of segments and number of boundary markers. */ - stringptr = readline(inputline, polyfile, polyfilename); - m->insegments = (int)strtol(stringptr, &stringptr, 0); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - segmentmarkers = 0; - } else { - segmentmarkers = (int)strtol(stringptr, &stringptr, 0); - } -#endif /* not TRILIBRARY */ - /* If the input vertices are collinear, there is no triangulation, */ - /* so don't try to insert segments. */ - if (m->triangles.items == 0) { - return; - } - - /* If segments are to be inserted, compute a mapping */ - /* from vertices to triangles. */ - if (m->insegments > 0) { - makevertexmap(m, b); - if (b->verbose) { - printf(" Recovering PSLG segments.\n"); - } - } - - boundmarker = 0; - /* Read and insert the segments. */ - for (i = 0; i < m->insegments; i++) { -#ifdef TRILIBRARY - end1 = segmentlist[index++]; - end2 = segmentlist[index++]; - if (segmentmarkers) { - boundmarker = segmentmarkerlist[i]; - } -#else /* not TRILIBRARY */ - stringptr = readline(inputline, polyfile, b->inpolyfilename); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Segment %d has no endpoints in %s.\n", - b->firstnumber + i, polyfilename); - triexit(1); - } else { - end1 = (int)strtol(stringptr, &stringptr, 0); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Segment %d is missing its second endpoint in %s.\n", - b->firstnumber + i, polyfilename); - triexit(1); - } else { - end2 = (int)strtol(stringptr, &stringptr, 0); - } - if (segmentmarkers) { - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - boundmarker = 0; - } else { - boundmarker = (int)strtol(stringptr, &stringptr, 0); - } - } -#endif /* not TRILIBRARY */ - if ((end1 < b->firstnumber) || (end1 >= b->firstnumber + m->invertices)) { - if (!b->quiet) { - printf("Warning: Invalid first endpoint of segment %d in %s.\n", - b->firstnumber + i, polyfilename); - } - } else if ((end2 < b->firstnumber) || - (end2 >= b->firstnumber + m->invertices)) { - if (!b->quiet) { - printf("Warning: Invalid second endpoint of segment %d in %s.\n", - b->firstnumber + i, polyfilename); - } - } else { - /* Find the vertices numbered `end1' and `end2'. */ - endpoint1 = getvertex(m, b, end1); - endpoint2 = getvertex(m, b, end2); - if ((endpoint1[0] == endpoint2[0]) && (endpoint1[1] == endpoint2[1])) { - if (!b->quiet) { - printf("Warning: Endpoints of segment %d are coincident in %s.\n", - b->firstnumber + i, polyfilename); - } - } else { - insertsegment(m, b, endpoint1, endpoint2, boundmarker); - } - } - } - } else { - m->insegments = 0; - } - if (b->convex || !b->poly) { - /* Enclose the convex hull with subsegments. */ - if (b->verbose) { - printf(" Enclosing convex hull with segments.\n"); - } - markhull(m, b); - } -} - -/** **/ -/** **/ -/********* Segment insertion ends here *********/ - -/********* Carving out holes and concavities begins here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* infecthull() Virally infect all of the triangles of the convex hull */ -/* that are not protected by subsegments. Where there are */ -/* subsegments, set boundary markers as appropriate. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void infecthull(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void infecthull(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri hulltri; - struct otri nexttri; - struct otri starttri; - struct osub hullsubseg; - triangle **deadtriangle; - vertex horg, hdest; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - if (b->verbose) { - printf(" Marking concavities (external triangles) for elimination.\n"); - } - /* Find a triangle handle on the hull. */ - hulltri.tri = m->dummytri; - hulltri.orient = 0; - symself(hulltri); - /* Remember where we started so we know when to stop. */ - otricopy(hulltri, starttri); - /* Go once counterclockwise around the convex hull. */ - do { - /* Ignore triangles that are already infected. */ - if (!infected(hulltri)) { - /* Is the triangle protected by a subsegment? */ - tspivot(hulltri, hullsubseg); - if (hullsubseg.ss == m->dummysub) { - /* The triangle is not protected; infect it. */ - if (!infected(hulltri)) { - infect(hulltri); - deadtriangle = (triangle **)poolalloc(&m->viri); - *deadtriangle = hulltri.tri; - } - } else { - /* The triangle is protected; set boundary markers if appropriate. */ - if (mark(hullsubseg) == 0) { - setmark(hullsubseg, 1); - org(hulltri, horg); - dest(hulltri, hdest); - if (vertexmark(horg) == 0) { - setvertexmark(horg, 1); - } - if (vertexmark(hdest) == 0) { - setvertexmark(hdest, 1); - } - } - } - } - /* To find the next hull edge, go clockwise around the next vertex. */ - lnextself(hulltri); - oprev(hulltri, nexttri); - while (nexttri.tri != m->dummytri) { - otricopy(nexttri, hulltri); - oprev(hulltri, nexttri); - } - } while (!otriequal(hulltri, starttri)); -} - -/*****************************************************************************/ -/* */ -/* plague() Spread the virus from all infected triangles to any neighbors */ -/* not protected by subsegments. Delete all infected triangles. */ -/* */ -/* This is the procedure that actually creates holes and concavities. */ -/* */ -/* This procedure operates in two phases. The first phase identifies all */ -/* the triangles that will die, and marks them as infected. They are */ -/* marked to ensure that each triangle is added to the virus pool only */ -/* once, so the procedure will terminate. */ -/* */ -/* The second phase actually eliminates the infected triangles. It also */ -/* eliminates orphaned vertices. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void plague(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void plague(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri testtri; - struct otri neighbor; - triangle **virusloop; - triangle **deadtriangle; - struct osub neighborsubseg; - vertex testvertex; - vertex norg, ndest; - vertex deadorg, deaddest, deadapex; - int killorg; - triangle ptr; /* Temporary variable used by sym() and onext(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - if (b->verbose) { - printf(" Marking neighbors of marked triangles.\n"); - } - /* Loop through all the infected triangles, spreading the virus to */ - /* their neighbors, then to their neighbors' neighbors. */ - traversalinit(&m->viri); - virusloop = (triangle **)traverse(&m->viri); - while (virusloop != (triangle **)NULL) { - testtri.tri = *virusloop; - /* A triangle is marked as infected by messing with one of its pointers */ - /* to subsegments, setting it to an illegal value. Hence, we have to */ - /* temporarily uninfect this triangle so that we can examine its */ - /* adjacent subsegments. */ - uninfect(testtri); - if (b->verbose > 2) { - /* Assign the triangle an orientation for convenience in */ - /* checking its vertices. */ - testtri.orient = 0; - org(testtri, deadorg); - dest(testtri, deaddest); - apex(testtri, deadapex); - printf(" Checking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", - deadorg[0], deadorg[1], deaddest[0], deaddest[1], deadapex[0], - deadapex[1]); - } - /* Check each of the triangle's three neighbors. */ - for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { - /* Find the neighbor. */ - sym(testtri, neighbor); - /* Check for a subsegment between the triangle and its neighbor. */ - tspivot(testtri, neighborsubseg); - /* Check if the neighbor is nonexistent or already infected. */ - if ((neighbor.tri == m->dummytri) || infected(neighbor)) { - if (neighborsubseg.ss != m->dummysub) { - /* There is a subsegment separating the triangle from its */ - /* neighbor, but both triangles are dying, so the subsegment */ - /* dies too. */ - subsegdealloc(m, neighborsubseg.ss); - if (neighbor.tri != m->dummytri) { - /* Make sure the subsegment doesn't get deallocated again */ - /* later when the infected neighbor is visited. */ - uninfect(neighbor); - tsdissolve(neighbor); - infect(neighbor); - } - } - } else { /* The neighbor exists and is not infected. */ - if (neighborsubseg.ss == m->dummysub) { - /* There is no subsegment protecting the neighbor, so */ - /* the neighbor becomes infected. */ - if (b->verbose > 2) { - org(neighbor, deadorg); - dest(neighbor, deaddest); - apex(neighbor, deadapex); - printf(" Marking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", - deadorg[0], deadorg[1], deaddest[0], deaddest[1], - deadapex[0], deadapex[1]); - } - infect(neighbor); - /* Ensure that the neighbor's neighbors will be infected. */ - deadtriangle = (triangle **)poolalloc(&m->viri); - *deadtriangle = neighbor.tri; - } else { /* The neighbor is protected by a subsegment. */ - /* Remove this triangle from the subsegment. */ - stdissolve(neighborsubseg); - /* The subsegment becomes a boundary. Set markers accordingly. */ - if (mark(neighborsubseg) == 0) { - setmark(neighborsubseg, 1); - } - org(neighbor, norg); - dest(neighbor, ndest); - if (vertexmark(norg) == 0) { - setvertexmark(norg, 1); - } - if (vertexmark(ndest) == 0) { - setvertexmark(ndest, 1); - } - } - } - } - /* Remark the triangle as infected, so it doesn't get added to the */ - /* virus pool again. */ - infect(testtri); - virusloop = (triangle **)traverse(&m->viri); - } - - if (b->verbose) { - printf(" Deleting marked triangles.\n"); - } - - traversalinit(&m->viri); - virusloop = (triangle **)traverse(&m->viri); - while (virusloop != (triangle **)NULL) { - testtri.tri = *virusloop; - - /* Check each of the three corners of the triangle for elimination. */ - /* This is done by walking around each vertex, checking if it is */ - /* still connected to at least one live triangle. */ - for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { - org(testtri, testvertex); - /* Check if the vertex has already been tested. */ - if (testvertex != (vertex)NULL) { - killorg = 1; - /* Mark the corner of the triangle as having been tested. */ - setorg(testtri, NULL); - /* Walk counterclockwise about the vertex. */ - onext(testtri, neighbor); - /* Stop upon reaching a boundary or the starting triangle. */ - while ((neighbor.tri != m->dummytri) && - (!otriequal(neighbor, testtri))) { - if (infected(neighbor)) { - /* Mark the corner of this triangle as having been tested. */ - setorg(neighbor, NULL); - } else { - /* A live triangle. The vertex survives. */ - killorg = 0; - } - /* Walk counterclockwise about the vertex. */ - onextself(neighbor); - } - /* If we reached a boundary, we must walk clockwise as well. */ - if (neighbor.tri == m->dummytri) { - /* Walk clockwise about the vertex. */ - oprev(testtri, neighbor); - /* Stop upon reaching a boundary. */ - while (neighbor.tri != m->dummytri) { - if (infected(neighbor)) { - /* Mark the corner of this triangle as having been tested. */ - setorg(neighbor, NULL); - } else { - /* A live triangle. The vertex survives. */ - killorg = 0; - } - /* Walk clockwise about the vertex. */ - oprevself(neighbor); - } - } - if (killorg) { - if (b->verbose > 1) { - printf(" Deleting vertex (%.12g, %.12g)\n", testvertex[0], - testvertex[1]); - } - setvertextype(testvertex, UNDEADVERTEX); - m->undeads++; - } - } - } - - /* Record changes in the number of boundary edges, and disconnect */ - /* dead triangles from their neighbors. */ - for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { - sym(testtri, neighbor); - if (neighbor.tri == m->dummytri) { - /* There is no neighboring triangle on this edge, so this edge */ - /* is a boundary edge. This triangle is being deleted, so this */ - /* boundary edge is deleted. */ - m->hullsize--; - } else { - /* Disconnect the triangle from its neighbor. */ - dissolve(neighbor); - /* There is a neighboring triangle on this edge, so this edge */ - /* becomes a boundary edge when this triangle is deleted. */ - m->hullsize++; - } - } - /* Return the dead triangle to the pool of triangles. */ - triangledealloc(m, testtri.tri); - virusloop = (triangle **)traverse(&m->viri); - } - /* Empty the virus pool. */ - poolrestart(&m->viri); -} - -/*****************************************************************************/ -/* */ -/* regionplague() Spread regional attributes and/or area constraints */ -/* (from a .poly file) throughout the mesh. */ -/* */ -/* This procedure operates in two phases. The first phase spreads an */ -/* attribute and/or an area constraint through a (segment-bounded) region. */ -/* The triangles are marked to ensure that each triangle is added to the */ -/* virus pool only once, so the procedure will terminate. */ -/* */ -/* The second phase uninfects all infected triangles, returning them to */ -/* normal. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void regionplague(struct mesh *m, struct behavior *b, REAL attribute, REAL area) -#else /* not ANSI_DECLARATORS */ -void regionplague(m, b, attribute, area) struct mesh *m; -struct behavior *b; -REAL attribute; -REAL area; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri testtri; - struct otri neighbor; - triangle **virusloop; - triangle **regiontri; - struct osub neighborsubseg; - vertex regionorg, regiondest, regionapex; - triangle ptr; /* Temporary variable used by sym() and onext(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - if (b->verbose > 1) { - printf(" Marking neighbors of marked triangles.\n"); - } - /* Loop through all the infected triangles, spreading the attribute */ - /* and/or area constraint to their neighbors, then to their neighbors' */ - /* neighbors. */ - traversalinit(&m->viri); - virusloop = (triangle **)traverse(&m->viri); - while (virusloop != (triangle **)NULL) { - testtri.tri = *virusloop; - /* A triangle is marked as infected by messing with one of its pointers */ - /* to subsegments, setting it to an illegal value. Hence, we have to */ - /* temporarily uninfect this triangle so that we can examine its */ - /* adjacent subsegments. */ - uninfect(testtri); - if (b->regionattrib) { - /* Set an attribute. */ - setelemattribute(testtri, m->eextras, attribute); - } - if (b->vararea) { - /* Set an area constraint. */ - setareabound(testtri, area); - } - if (b->verbose > 2) { - /* Assign the triangle an orientation for convenience in */ - /* checking its vertices. */ - testtri.orient = 0; - org(testtri, regionorg); - dest(testtri, regiondest); - apex(testtri, regionapex); - printf(" Checking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", - regionorg[0], regionorg[1], regiondest[0], regiondest[1], - regionapex[0], regionapex[1]); - } - /* Check each of the triangle's three neighbors. */ - for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { - /* Find the neighbor. */ - sym(testtri, neighbor); - /* Check for a subsegment between the triangle and its neighbor. */ - tspivot(testtri, neighborsubseg); - /* Make sure the neighbor exists, is not already infected, and */ - /* isn't protected by a subsegment. */ - if ((neighbor.tri != m->dummytri) && !infected(neighbor) && - (neighborsubseg.ss == m->dummysub)) { - if (b->verbose > 2) { - org(neighbor, regionorg); - dest(neighbor, regiondest); - apex(neighbor, regionapex); - printf(" Marking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", - regionorg[0], regionorg[1], regiondest[0], regiondest[1], - regionapex[0], regionapex[1]); - } - /* Infect the neighbor. */ - infect(neighbor); - /* Ensure that the neighbor's neighbors will be infected. */ - regiontri = (triangle **)poolalloc(&m->viri); - *regiontri = neighbor.tri; - } - } - /* Remark the triangle as infected, so it doesn't get added to the */ - /* virus pool again. */ - infect(testtri); - virusloop = (triangle **)traverse(&m->viri); - } - - /* Uninfect all triangles. */ - if (b->verbose > 1) { - printf(" Unmarking marked triangles.\n"); - } - traversalinit(&m->viri); - virusloop = (triangle **)traverse(&m->viri); - while (virusloop != (triangle **)NULL) { - testtri.tri = *virusloop; - uninfect(testtri); - virusloop = (triangle **)traverse(&m->viri); - } - /* Empty the virus pool. */ - poolrestart(&m->viri); -} - -/*****************************************************************************/ -/* */ -/* carveholes() Find the holes and infect them. Find the area */ -/* constraints and infect them. Infect the convex hull. */ -/* Spread the infection and kill triangles. Spread the */ -/* area constraints. */ -/* */ -/* This routine mainly calls other routines to carry out all these */ -/* functions. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void carveholes(struct mesh *m, struct behavior *b, REAL *holelist, int holes, - REAL *regionlist, int regions) -#else /* not ANSI_DECLARATORS */ -void carveholes(m, b, holelist, holes, regionlist, regions) struct mesh *m; -struct behavior *b; -REAL *holelist; -int holes; -REAL *regionlist; -int regions; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri searchtri; - struct otri triangleloop; - struct otri *regiontris; - triangle **holetri; - triangle **regiontri; - vertex searchorg, searchdest; - enum locateresult intersect; - int i; - triangle ptr; /* Temporary variable used by sym(). */ - - if (!(b->quiet || (b->noholes && b->convex))) { - printf("Removing unwanted triangles.\n"); - if (b->verbose && (holes > 0)) { - printf(" Marking holes for elimination.\n"); - } - } - - if (regions > 0) { - /* Allocate storage for the triangles in which region points fall. */ - regiontris = (struct otri *)trimalloc(regions * (int)sizeof(struct otri)); - } else { - regiontris = (struct otri *)NULL; - } - - if (((holes > 0) && !b->noholes) || !b->convex || (regions > 0)) { - /* Initialize a pool of viri to be used for holes, concavities, */ - /* regional attributes, and/or regional area constraints. */ - poolinit(&m->viri, sizeof(triangle *), VIRUSPERBLOCK, VIRUSPERBLOCK, 0); - } - - if (!b->convex) { - /* Mark as infected any unprotected triangles on the boundary. */ - /* This is one way by which concavities are created. */ - infecthull(m, b); - } - - if ((holes > 0) && !b->noholes) { - /* Infect each triangle in which a hole lies. */ - for (i = 0; i < 2 * holes; i += 2) { - /* Ignore holes that aren't within the bounds of the mesh. */ - if ((holelist[i] >= m->xmin) && (holelist[i] <= m->xmax) && - (holelist[i + 1] >= m->ymin) && (holelist[i + 1] <= m->ymax)) { - /* Start searching from some triangle on the outer boundary. */ - searchtri.tri = m->dummytri; - searchtri.orient = 0; - symself(searchtri); - /* Ensure that the hole is to the left of this boundary edge; */ - /* otherwise, locate() will falsely report that the hole */ - /* falls within the starting triangle. */ - org(searchtri, searchorg); - dest(searchtri, searchdest); - if (counterclockwise(m, b, searchorg, searchdest, &holelist[i]) > 0.0) { - /* Find a triangle that contains the hole. */ - intersect = locate(m, b, &holelist[i], &searchtri); - if ((intersect != OUTSIDE) && (!infected(searchtri))) { - /* Infect the triangle. This is done by marking the triangle */ - /* as infected and including the triangle in the virus pool. */ - infect(searchtri); - holetri = (triangle **)poolalloc(&m->viri); - *holetri = searchtri.tri; - } - } - } - } - } - - /* Now, we have to find all the regions BEFORE we carve the holes, because */ - /* locate() won't work when the triangulation is no longer convex. */ - /* (Incidentally, this is the reason why regional attributes and area */ - /* constraints can't be used when refining a preexisting mesh, which */ - /* might not be convex; they can only be used with a freshly */ - /* triangulated PSLG.) */ - if (regions > 0) { - /* Find the starting triangle for each region. */ - for (i = 0; i < regions; i++) { - regiontris[i].tri = m->dummytri; - /* Ignore region points that aren't within the bounds of the mesh. */ - if ((regionlist[4 * i] >= m->xmin) && (regionlist[4 * i] <= m->xmax) && - (regionlist[4 * i + 1] >= m->ymin) && - (regionlist[4 * i + 1] <= m->ymax)) { - /* Start searching from some triangle on the outer boundary. */ - searchtri.tri = m->dummytri; - searchtri.orient = 0; - symself(searchtri); - /* Ensure that the region point is to the left of this boundary */ - /* edge; otherwise, locate() will falsely report that the */ - /* region point falls within the starting triangle. */ - org(searchtri, searchorg); - dest(searchtri, searchdest); - if (counterclockwise(m, b, searchorg, searchdest, ®ionlist[4 * i]) > - 0.0) { - /* Find a triangle that contains the region point. */ - intersect = locate(m, b, ®ionlist[4 * i], &searchtri); - if ((intersect != OUTSIDE) && (!infected(searchtri))) { - /* Record the triangle for processing after the */ - /* holes have been carved. */ - otricopy(searchtri, regiontris[i]); - } - } - } - } - } - - if (m->viri.items > 0) { - /* Carve the holes and concavities. */ - plague(m, b); - } - /* The virus pool should be empty now. */ - - if (regions > 0) { - if (!b->quiet) { - if (b->regionattrib) { - if (b->vararea) { - printf("Spreading regional attributes and area constraints.\n"); - } else { - printf("Spreading regional attributes.\n"); - } - } else { - printf("Spreading regional area constraints.\n"); - } - } - if (b->regionattrib && !b->refine) { - /* Assign every triangle a regional attribute of zero. */ - traversalinit(&m->triangles); - triangleloop.orient = 0; - triangleloop.tri = triangletraverse(m); - while (triangleloop.tri != (triangle *)NULL) { - setelemattribute(triangleloop, m->eextras, 0.0); - triangleloop.tri = triangletraverse(m); - } - } - for (i = 0; i < regions; i++) { - if (regiontris[i].tri != m->dummytri) { - /* Make sure the triangle under consideration still exists. */ - /* It may have been eaten by the virus. */ - if (!deadtri(regiontris[i].tri)) { - /* Put one triangle in the virus pool. */ - infect(regiontris[i]); - regiontri = (triangle **)poolalloc(&m->viri); - *regiontri = regiontris[i].tri; - /* Apply one region's attribute and/or area constraint. */ - regionplague(m, b, regionlist[4 * i + 2], regionlist[4 * i + 3]); - /* The virus pool should be empty now. */ - } - } - } - if (b->regionattrib && !b->refine) { - /* Note the fact that each triangle has an additional attribute. */ - m->eextras++; - } - } - - /* Free up memory. */ - if (((holes > 0) && !b->noholes) || !b->convex || (regions > 0)) { - pooldeinit(&m->viri); - } - if (regions > 0) { - trifree((VOID *)regiontris); - } -} - -/** **/ -/** **/ -/********* Carving out holes and concavities ends here *********/ - -/********* Mesh quality maintenance begins here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* tallyencs() Traverse the entire list of subsegments, and check each */ -/* to see if it is encroached. If so, add it to the list. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void tallyencs(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ - void tallyencs(m, b) struct mesh *m; - struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct osub subsegloop; - int dummy; - - traversalinit(&m->subsegs); - subsegloop.ssorient = 0; - subsegloop.ss = subsegtraverse(m); - while (subsegloop.ss != (subseg *)NULL) { - /* If the segment is encroached, add it to the list. */ - dummy = checkseg4encroach(m, b, &subsegloop); - subsegloop.ss = subsegtraverse(m); - } -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* precisionerror() Print an error message for precision problems. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -void precisionerror() { - printf("Try increasing the area criterion and/or reducing the minimum\n"); - printf(" allowable angle so that tiny triangles are not created.\n"); -#ifdef SINGLE - printf("Alternatively, try recompiling me with double precision\n"); - printf(" arithmetic (by removing \"#define SINGLE\" from the\n"); - printf(" source file or \"-DSINGLE\" from the makefile).\n"); -#endif /* SINGLE */ -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* splitencsegs() Split all the encroached subsegments. */ -/* */ -/* Each encroached subsegment is repaired by splitting it - inserting a */ -/* vertex at or near its midpoint. Newly inserted vertices may encroach */ -/* upon other subsegments; these are also repaired. */ -/* */ -/* `triflaws' is a flag that specifies whether one should take note of new */ -/* bad triangles that result from inserting vertices to repair encroached */ -/* subsegments. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void splitencsegs(struct mesh *m, struct behavior *b, int triflaws) -#else /* not ANSI_DECLARATORS */ - void splitencsegs(m, b, triflaws) struct mesh *m; - struct behavior *b; - int triflaws; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri enctri; - struct otri testtri; - struct osub testsh; - struct osub currentenc; - struct badsubseg *encloop; - vertex eorg, edest, eapex; - vertex newvertex; - enum insertvertexresult success; - REAL segmentlength, nearestpoweroftwo; - REAL split; - REAL multiplier, divisor; - int acuteorg, acuteorg2, acutedest, acutedest2; - int dummy; - int i; - triangle ptr; /* Temporary variable used by stpivot(). */ - subseg sptr; /* Temporary variable used by snext(). */ - - /* Note that steinerleft == -1 if an unlimited number */ - /* of Steiner points is allowed. */ - while ((m->badsubsegs.items > 0) && (m->steinerleft != 0)) { - traversalinit(&m->badsubsegs); - encloop = badsubsegtraverse(m); - while ((encloop != (struct badsubseg *)NULL) && (m->steinerleft != 0)) { - sdecode(encloop->encsubseg, currentenc); - sorg(currentenc, eorg); - sdest(currentenc, edest); - /* Make sure that this segment is still the same segment it was */ - /* when it was determined to be encroached. If the segment was */ - /* enqueued multiple times (because several newly inserted */ - /* vertices encroached it), it may have already been split. */ - if (!deadsubseg(currentenc.ss) && (eorg == encloop->subsegorg) && - (edest == encloop->subsegdest)) { - /* To decide where to split a segment, we need to know if the */ - /* segment shares an endpoint with an adjacent segment. */ - /* The concern is that, if we simply split every encroached */ - /* segment in its center, two adjacent segments with a small */ - /* angle between them might lead to an infinite loop; each */ - /* vertex added to split one segment will encroach upon the */ - /* other segment, which must then be split with a vertex that */ - /* will encroach upon the first segment, and so on forever. */ - /* To avoid this, imagine a set of concentric circles, whose */ - /* radii are powers of two, about each segment endpoint. */ - /* These concentric circles determine where the segment is */ - /* split. (If both endpoints are shared with adjacent */ - /* segments, split the segment in the middle, and apply the */ - /* concentric circles for later splittings.) */ - - /* Is the origin shared with another segment? */ - stpivot(currentenc, enctri); - lnext(enctri, testtri); - tspivot(testtri, testsh); - acuteorg = testsh.ss != m->dummysub; - /* Is the destination shared with another segment? */ - lnextself(testtri); - tspivot(testtri, testsh); - acutedest = testsh.ss != m->dummysub; - - /* If we're using Chew's algorithm (rather than Ruppert's) */ - /* to define encroachment, delete free vertices from the */ - /* subsegment's diametral circle. */ - if (!b->conformdel && !acuteorg && !acutedest) { - apex(enctri, eapex); - while ((vertextype(eapex) == FREEVERTEX) && - ((eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + - (eorg[1] - eapex[1]) * (edest[1] - eapex[1]) < - 0.0)) { - deletevertex(m, b, &testtri); - stpivot(currentenc, enctri); - apex(enctri, eapex); - lprev(enctri, testtri); - } - } - - /* Now, check the other side of the segment, if there's a triangle */ - /* there. */ - sym(enctri, testtri); - if (testtri.tri != m->dummytri) { - /* Is the destination shared with another segment? */ - lnextself(testtri); - tspivot(testtri, testsh); - acutedest2 = testsh.ss != m->dummysub; - acutedest = acutedest || acutedest2; - /* Is the origin shared with another segment? */ - lnextself(testtri); - tspivot(testtri, testsh); - acuteorg2 = testsh.ss != m->dummysub; - acuteorg = acuteorg || acuteorg2; - - /* Delete free vertices from the subsegment's diametral circle. */ - if (!b->conformdel && !acuteorg2 && !acutedest2) { - org(testtri, eapex); - while ((vertextype(eapex) == FREEVERTEX) && - ((eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + - (eorg[1] - eapex[1]) * (edest[1] - eapex[1]) < - 0.0)) { - deletevertex(m, b, &testtri); - sym(enctri, testtri); - apex(testtri, eapex); - lprevself(testtri); - } - } - } - - /* Use the concentric circles if exactly one endpoint is shared */ - /* with another adjacent segment. */ - if (acuteorg || acutedest) { - segmentlength = sqrt((edest[0] - eorg[0]) * (edest[0] - eorg[0]) + - (edest[1] - eorg[1]) * (edest[1] - eorg[1])); - /* Find the power of two that most evenly splits the segment. */ - /* The worst case is a 2:1 ratio between subsegment lengths. */ - nearestpoweroftwo = 1.0; - while (segmentlength > 3.0 * nearestpoweroftwo) { - nearestpoweroftwo *= 2.0; - } - while (segmentlength < 1.5 * nearestpoweroftwo) { - nearestpoweroftwo *= 0.5; - } - /* Where do we split the segment? */ - split = nearestpoweroftwo / segmentlength; - if (acutedest) { - split = 1.0 - split; - } - } else { - /* If we're not worried about adjacent segments, split */ - /* this segment in the middle. */ - split = 0.5; - } - - /* Create the new vertex. */ - newvertex = (vertex)poolalloc(&m->vertices); - /* Interpolate its coordinate and attributes. */ - for (i = 0; i < 2 + m->nextras; i++) { - newvertex[i] = eorg[i] + split * (edest[i] - eorg[i]); - } - - if (!b->noexact) { - /* Roundoff in the above calculation may yield a `newvertex' */ - /* that is not precisely collinear with `eorg' and `edest'. */ - /* Improve collinearity by one step of iterative refinement. */ - multiplier = counterclockwise(m, b, eorg, edest, newvertex); - divisor = ((eorg[0] - edest[0]) * (eorg[0] - edest[0]) + - (eorg[1] - edest[1]) * (eorg[1] - edest[1])); - if ((multiplier != 0.0) && (divisor != 0.0)) { - multiplier = multiplier / divisor; - /* Watch out for NANs. */ - if (multiplier == multiplier) { - newvertex[0] += multiplier * (edest[1] - eorg[1]); - newvertex[1] += multiplier * (eorg[0] - edest[0]); - } - } - } - - setvertexmark(newvertex, mark(currentenc)); - setvertextype(newvertex, SEGMENTVERTEX); - if (b->verbose > 1) { - printf(" Splitting subsegment (%.12g, %.12g) (%.12g, %.12g) at " - "(%.12g, %.12g).\n", - eorg[0], eorg[1], edest[0], edest[1], newvertex[0], - newvertex[1]); - } - /* Check whether the new vertex lies on an endpoint. */ - if (((newvertex[0] == eorg[0]) && (newvertex[1] == eorg[1])) || - ((newvertex[0] == edest[0]) && (newvertex[1] == edest[1]))) { - printf("Error: Ran out of precision at (%.12g, %.12g).\n", - newvertex[0], newvertex[1]); - printf("I attempted to split a segment to a smaller size than\n"); - printf(" can be accommodated by the finite precision of\n"); - printf(" floating point arithmetic.\n"); - precisionerror(); - triexit(1); - } - /* Insert the splitting vertex. This should always succeed. */ - success = - insertvertex(m, b, newvertex, &enctri, ¤tenc, 1, triflaws); - if ((success != SUCCESSFULVERTEX) && (success != ENCROACHINGVERTEX)) { - printf("Internal error in splitencsegs():\n"); - printf(" Failure to split a segment.\n"); - internalerror(); - } - if (m->steinerleft > 0) { - m->steinerleft--; - } - /* Check the two new subsegments to see if they're encroached. */ - dummy = checkseg4encroach(m, b, ¤tenc); - snextself(currentenc); - dummy = checkseg4encroach(m, b, ¤tenc); - } - - badsubsegdealloc(m, encloop); - encloop = badsubsegtraverse(m); - } - } -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* tallyfaces() Test every triangle in the mesh for quality measures. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void tallyfaces(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ - void tallyfaces(m, b) struct mesh *m; - struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri triangleloop; - - if (b->verbose) { - printf(" Making a list of bad triangles.\n"); - } - traversalinit(&m->triangles); - triangleloop.orient = 0; - triangleloop.tri = triangletraverse(m); - while (triangleloop.tri != (triangle *)NULL) { - /* If the triangle is bad, enqueue it. */ - testtriangle(m, b, &triangleloop); - triangleloop.tri = triangletraverse(m); - } -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* splittriangle() Inserts a vertex at the circumcenter of a triangle. */ -/* Deletes the newly inserted vertex if it encroaches */ -/* upon a segment. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void splittriangle(struct mesh *m, struct behavior *b, struct badtriang *badtri) -#else /* not ANSI_DECLARATORS */ - void splittriangle(m, b, badtri) struct mesh *m; - struct behavior *b; - struct badtriang *badtri; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri badotri; - vertex borg, bdest, bapex; - vertex newvertex; - REAL xi, eta; - enum insertvertexresult success; - int errorflag; - int i; - - decode(badtri->poortri, badotri); - org(badotri, borg); - dest(badotri, bdest); - apex(badotri, bapex); - /* Make sure that this triangle is still the same triangle it was */ - /* when it was tested and determined to be of bad quality. */ - /* Subsequent transformations may have made it a different triangle. */ - if (!deadtri(badotri.tri) && (borg == badtri->triangorg) && - (bdest == badtri->triangdest) && (bapex == badtri->triangapex)) { - if (b->verbose > 1) { - printf(" Splitting this triangle at its circumcenter:\n"); - printf(" (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", borg[0], - borg[1], bdest[0], bdest[1], bapex[0], bapex[1]); - } - - errorflag = 0; - /* Create a new vertex at the triangle's circumcenter. */ - newvertex = (vertex)poolalloc(&m->vertices); - findcircumcenter(m, b, borg, bdest, bapex, newvertex, &xi, &eta, 1); - - /* Check whether the new vertex lies on a triangle vertex. */ - if (((newvertex[0] == borg[0]) && (newvertex[1] == borg[1])) || - ((newvertex[0] == bdest[0]) && (newvertex[1] == bdest[1])) || - ((newvertex[0] == bapex[0]) && (newvertex[1] == bapex[1]))) { - if (!b->quiet) { - printf( - "Warning: New vertex (%.12g, %.12g) falls on existing vertex.\n", - newvertex[0], newvertex[1]); - errorflag = 1; - } - vertexdealloc(m, newvertex); - } else { - for (i = 2; i < 2 + m->nextras; i++) { - /* Interpolate the vertex attributes at the circumcenter. */ - newvertex[i] = - borg[i] + xi * (bdest[i] - borg[i]) + eta * (bapex[i] - borg[i]); - } - /* The new vertex must be in the interior, and therefore is a */ - /* free vertex with a marker of zero. */ - setvertexmark(newvertex, 0); - setvertextype(newvertex, FREEVERTEX); - - /* Ensure that the handle `badotri' does not represent the longest */ - /* edge of the triangle. This ensures that the circumcenter must */ - /* fall to the left of this edge, so point location will work. */ - /* (If the angle org-apex-dest exceeds 90 degrees, then the */ - /* circumcenter lies outside the org-dest edge, and eta is */ - /* negative. Roundoff error might prevent eta from being */ - /* negative when it should be, so I test eta against xi.) */ - if (eta < xi) { - lprevself(badotri); - } - - /* Insert the circumcenter, searching from the edge of the triangle, */ - /* and maintain the Delaunay property of the triangulation. */ - success = - insertvertex(m, b, newvertex, &badotri, (struct osub *)NULL, 1, 1); - if (success == SUCCESSFULVERTEX) { - if (m->steinerleft > 0) { - m->steinerleft--; - } - } else if (success == ENCROACHINGVERTEX) { - /* If the newly inserted vertex encroaches upon a subsegment, */ - /* delete the new vertex. */ - undovertex(m, b); - if (b->verbose > 1) { - printf(" Rejecting (%.12g, %.12g).\n", newvertex[0], newvertex[1]); - } - vertexdealloc(m, newvertex); - } else if (success == VIOLATINGVERTEX) { - /* Failed to insert the new vertex, but some subsegment was */ - /* marked as being encroached. */ - vertexdealloc(m, newvertex); - } else { /* success == DUPLICATEVERTEX */ - /* Couldn't insert the new vertex because a vertex is already there. */ - if (!b->quiet) { - printf( - "Warning: New vertex (%.12g, %.12g) falls on existing vertex.\n", - newvertex[0], newvertex[1]); - errorflag = 1; - } - vertexdealloc(m, newvertex); - } - } - if (errorflag) { - if (b->verbose) { - printf(" The new vertex is at the circumcenter of triangle\n"); - printf(" (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", borg[0], - borg[1], bdest[0], bdest[1], bapex[0], bapex[1]); - } - printf("This probably means that I am trying to refine triangles\n"); - printf(" to a smaller size than can be accommodated by the finite\n"); - printf(" precision of floating point arithmetic. (You can be\n"); - printf(" sure of this if I fail to terminate.)\n"); - precisionerror(); - } - } -} - -#endif /* not CDT_ONLY */ - -/*****************************************************************************/ -/* */ -/* enforcequality() Remove all the encroached subsegments and bad */ -/* triangles from the triangulation. */ -/* */ -/*****************************************************************************/ - -#ifndef CDT_ONLY - -#ifdef ANSI_DECLARATORS -void enforcequality(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ - void enforcequality(m, b) struct mesh *m; - struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct badtriang *badtri; - int i; - - if (!b->quiet) { - printf("Adding Steiner points to enforce quality.\n"); - } - /* Initialize the pool of encroached subsegments. */ - poolinit(&m->badsubsegs, sizeof(struct badsubseg), BADSUBSEGPERBLOCK, - BADSUBSEGPERBLOCK, 0); - if (b->verbose) { - printf(" Looking for encroached subsegments.\n"); - } - /* Test all segments to see if they're encroached. */ - tallyencs(m, b); - if (b->verbose && (m->badsubsegs.items > 0)) { - printf(" Splitting encroached subsegments.\n"); - } - /* Fix encroached subsegments without noting bad triangles. */ - splitencsegs(m, b, 0); - /* At this point, if we haven't run out of Steiner points, the */ - /* triangulation should be (conforming) Delaunay. */ - - /* Next, we worry about enforcing triangle quality. */ - if ((b->minangle > 0.0) || b->vararea || b->fixedarea || b->usertest) { - /* Initialize the pool of bad triangles. */ - poolinit(&m->badtriangles, sizeof(struct badtriang), BADTRIPERBLOCK, - BADTRIPERBLOCK, 0); - /* Initialize the queues of bad triangles. */ - for (i = 0; i < 4096; i++) { - m->queuefront[i] = (struct badtriang *)NULL; - } - m->firstnonemptyq = -1; - /* Test all triangles to see if they're bad. */ - tallyfaces(m, b); - /* Initialize the pool of recently flipped triangles. */ - poolinit(&m->flipstackers, sizeof(struct flipstacker), FLIPSTACKERPERBLOCK, - FLIPSTACKERPERBLOCK, 0); - m->checkquality = 1; - if (b->verbose) { - printf(" Splitting bad triangles.\n"); - } - while ((m->badtriangles.items > 0) && (m->steinerleft != 0)) { - /* Fix one bad triangle by inserting a vertex at its circumcenter. */ - badtri = dequeuebadtriang(m); - splittriangle(m, b, badtri); - if (m->badsubsegs.items > 0) { - /* Put bad triangle back in queue for another try later. */ - enqueuebadtriang(m, b, badtri); - /* Fix any encroached subsegments that resulted. */ - /* Record any new bad triangles that result. */ - splitencsegs(m, b, 1); - } else { - /* Return the bad triangle to the pool. */ - pooldealloc(&m->badtriangles, (VOID *)badtri); - } - } - } - /* At this point, if the "-D" switch was selected and we haven't run out */ - /* of Steiner points, the triangulation should be (conforming) Delaunay */ - /* and have no low-quality triangles. */ - - /* Might we have run out of Steiner points too soon? */ - if (!b->quiet && b->conformdel && (m->badsubsegs.items > 0) && - (m->steinerleft == 0)) { - printf("\nWarning: I ran out of Steiner points, but the mesh has\n"); - if (m->badsubsegs.items == 1) { - printf(" one encroached subsegment, and therefore might not be truly\n"); - } else { - printf(" %ld encroached subsegments, and therefore might not be truly\n", - m->badsubsegs.items); - } - printf(" Delaunay. If the Delaunay property is important to you,\n"); - printf(" try increasing the number of Steiner points (controlled by\n"); - printf(" the -S switch) slightly and try again.\n\n"); - } -} - -#endif /* not CDT_ONLY */ - -/** **/ -/** **/ -/********* Mesh quality maintenance ends here *********/ - -/*****************************************************************************/ -/* */ -/* highorder() Create extra nodes for quadratic subparametric elements. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void highorder(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void highorder(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri triangleloop, trisym; - struct osub checkmark; - vertex newvertex; - vertex torg, tdest; - int i; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - - if (!b->quiet) { - printf("Adding vertices for second-order triangles.\n"); - } - /* The following line ensures that dead items in the pool of nodes */ - /* cannot be allocated for the extra nodes associated with high */ - /* order elements. This ensures that the primary nodes (at the */ - /* corners of elements) will occur earlier in the output files, and */ - /* have lower indices, than the extra nodes. */ - m->vertices.deaditemstack = (VOID *)NULL; - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - /* To loop over the set of edges, loop over all triangles, and look at */ - /* the three edges of each triangle. If there isn't another triangle */ - /* adjacent to the edge, operate on the edge. If there is another */ - /* adjacent triangle, operate on the edge only if the current triangle */ - /* has a smaller pointer than its neighbor. This way, each edge is */ - /* considered only once. */ - while (triangleloop.tri != (triangle *)NULL) { - for (triangleloop.orient = 0; triangleloop.orient < 3; - triangleloop.orient++) { - sym(triangleloop, trisym); - if ((triangleloop.tri < trisym.tri) || (trisym.tri == m->dummytri)) { - org(triangleloop, torg); - dest(triangleloop, tdest); - /* Create a new node in the middle of the edge. Interpolate */ - /* its attributes. */ - newvertex = (vertex)poolalloc(&m->vertices); - for (i = 0; i < 2 + m->nextras; i++) { - newvertex[i] = 0.5 * (torg[i] + tdest[i]); - } - /* Set the new node's marker to zero or one, depending on */ - /* whether it lies on a boundary. */ - setvertexmark(newvertex, trisym.tri == m->dummytri); - setvertextype(newvertex, - trisym.tri == m->dummytri ? FREEVERTEX : SEGMENTVERTEX); - if (b->usesegments) { - tspivot(triangleloop, checkmark); - /* If this edge is a segment, transfer the marker to the new node. */ - if (checkmark.ss != m->dummysub) { - setvertexmark(newvertex, mark(checkmark)); - setvertextype(newvertex, SEGMENTVERTEX); - } - } - if (b->verbose > 1) { - printf(" Creating (%.12g, %.12g).\n", newvertex[0], newvertex[1]); - } - /* Record the new node in the (one or two) adjacent elements. */ - triangleloop.tri[m->highorderindex + triangleloop.orient] = - (triangle)newvertex; - if (trisym.tri != m->dummytri) { - trisym.tri[m->highorderindex + trisym.orient] = (triangle)newvertex; - } - } - } - triangleloop.tri = triangletraverse(m); - } -} - -/********* File I/O routines begin here *********/ -/** **/ -/** **/ - -/*****************************************************************************/ -/* */ -/* readline() Read a nonempty line from a file. */ -/* */ -/* A line is considered "nonempty" if it contains something that looks like */ -/* a number. Comments (prefaced by `#') are ignored. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -#ifdef ANSI_DECLARATORS -char *readline(char *string, FILE *infile, char *infilename) -#else /* not ANSI_DECLARATORS */ - char *readline(string, infile, infilename) char *string; - FILE *infile; - char *infilename; -#endif /* not ANSI_DECLARATORS */ - -{ - char *result; - - /* Search for something that looks like a number. */ - do { - result = fgets(string, INPUTLINESIZE, infile); - if (result == (char *)NULL) { - printf(" Error: Unexpected end of file in %s.\n", infilename); - triexit(1); - } - /* Skip anything that doesn't look like a number, a comment, */ - /* or the end of a line. */ - while ((*result != '\0') && (*result != '#') && (*result != '.') && - (*result != '+') && (*result != '-') && - ((*result < '0') || (*result > '9'))) { - result++; - } - /* If it's a comment or end of line, read another line and try again. */ - } while ((*result == '#') || (*result == '\0')); - return result; -} - -#endif /* not TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* findfield() Find the next field of a string. */ -/* */ -/* Jumps past the current field by searching for whitespace, then jumps */ -/* past the whitespace to find the next field. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -#ifdef ANSI_DECLARATORS -char *findfield(char *string) -#else /* not ANSI_DECLARATORS */ - char *findfield(string) char *string; -#endif /* not ANSI_DECLARATORS */ - -{ - char *result; - - result = string; - /* Skip the current field. Stop upon reaching whitespace. */ - while ((*result != '\0') && (*result != '#') && (*result != ' ') && - (*result != '\t')) { - result++; - } - /* Now skip the whitespace and anything else that doesn't look like a */ - /* number, a comment, or the end of a line. */ - while ((*result != '\0') && (*result != '#') && (*result != '.') && - (*result != '+') && (*result != '-') && - ((*result < '0') || (*result > '9'))) { - result++; - } - /* Check for a comment (prefixed with `#'). */ - if (*result == '#') { - *result = '\0'; - } - return result; -} - -#endif /* not TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* readnodes() Read the vertices from a file, which may be a .node or */ -/* .poly file. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void readnodes(struct mesh *m, struct behavior *b, char *nodefilename, - char *polyfilename, FILE **polyfile) -#else /* not ANSI_DECLARATORS */ - void readnodes(m, b, nodefilename, polyfilename, polyfile) struct mesh *m; - struct behavior *b; - char *nodefilename; - char *polyfilename; - FILE **polyfile; -#endif /* not ANSI_DECLARATORS */ - -{ - FILE *infile; - vertex vertexloop; - char inputline[INPUTLINESIZE]; - char *stringptr; - char *infilename; - REAL x, y; - int firstnode; - int nodemarkers; - int currentmarker; - int i, j; - - if (b->poly) { - /* Read the vertices from a .poly file. */ - if (!b->quiet) { - printf("Opening %s.\n", polyfilename); - } - *polyfile = fopen(polyfilename, "r"); - if (*polyfile == (FILE *)NULL) { - printf(" Error: Cannot access file %s.\n", polyfilename); - triexit(1); - } - /* Read number of vertices, number of dimensions, number of vertex */ - /* attributes, and number of boundary markers. */ - stringptr = readline(inputline, *polyfile, polyfilename); - m->invertices = (int)strtol(stringptr, &stringptr, 0); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - m->mesh_dim = 2; - } else { - m->mesh_dim = (int)strtol(stringptr, &stringptr, 0); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - m->nextras = 0; - } else { - m->nextras = (int)strtol(stringptr, &stringptr, 0); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - nodemarkers = 0; - } else { - nodemarkers = (int)strtol(stringptr, &stringptr, 0); - } - if (m->invertices > 0) { - infile = *polyfile; - infilename = polyfilename; - m->readnodefile = 0; - } else { - /* If the .poly file claims there are zero vertices, that means that */ - /* the vertices should be read from a separate .node file. */ - m->readnodefile = 1; - infilename = nodefilename; - } - } else { - m->readnodefile = 1; - infilename = nodefilename; - *polyfile = (FILE *)NULL; - } - - if (m->readnodefile) { - /* Read the vertices from a .node file. */ - if (!b->quiet) { - printf("Opening %s.\n", nodefilename); - } - infile = fopen(nodefilename, "r"); - if (infile == (FILE *)NULL) { - printf(" Error: Cannot access file %s.\n", nodefilename); - triexit(1); - } - /* Read number of vertices, number of dimensions, number of vertex */ - /* attributes, and number of boundary markers. */ - stringptr = readline(inputline, infile, nodefilename); - m->invertices = (int)strtol(stringptr, &stringptr, 0); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - m->mesh_dim = 2; - } else { - m->mesh_dim = (int)strtol(stringptr, &stringptr, 0); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - m->nextras = 0; - } else { - m->nextras = (int)strtol(stringptr, &stringptr, 0); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - nodemarkers = 0; - } else { - nodemarkers = (int)strtol(stringptr, &stringptr, 0); - } - } - - if (m->invertices < 3) { - printf("Error: Input must have at least three input vertices.\n"); - triexit(1); - } - if (m->mesh_dim != 2) { - printf("Error: Triangle only works with two-dimensional meshes.\n"); - triexit(1); - } - if (m->nextras == 0) { - b->weighted = 0; - } - - initializevertexpool(m, b); - - /* Read the vertices. */ - for (i = 0; i < m->invertices; i++) { - vertexloop = (vertex)poolalloc(&m->vertices); - stringptr = readline(inputline, infile, infilename); - if (i == 0) { - firstnode = (int)strtol(stringptr, &stringptr, 0); - if ((firstnode == 0) || (firstnode == 1)) { - b->firstnumber = firstnode; - } - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Vertex %d has no x coordinate.\n", b->firstnumber + i); - triexit(1); - } - x = (REAL)strtod(stringptr, &stringptr); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Vertex %d has no y coordinate.\n", b->firstnumber + i); - triexit(1); - } - y = (REAL)strtod(stringptr, &stringptr); - vertexloop[0] = x; - vertexloop[1] = y; - /* Read the vertex attributes. */ - for (j = 2; j < 2 + m->nextras; j++) { - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - vertexloop[j] = 0.0; - } else { - vertexloop[j] = (REAL)strtod(stringptr, &stringptr); - } - } - if (nodemarkers) { - /* Read a vertex marker. */ - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - setvertexmark(vertexloop, 0); - } else { - currentmarker = (int)strtol(stringptr, &stringptr, 0); - setvertexmark(vertexloop, currentmarker); - } - } else { - /* If no markers are specified in the file, they default to zero. */ - setvertexmark(vertexloop, 0); - } - setvertextype(vertexloop, INPUTVERTEX); - /* Determine the smallest and largest x and y coordinates. */ - if (i == 0) { - m->xmin = m->xmax = x; - m->ymin = m->ymax = y; - } else { - m->xmin = (x < m->xmin) ? x : m->xmin; - m->xmax = (x > m->xmax) ? x : m->xmax; - m->ymin = (y < m->ymin) ? y : m->ymin; - m->ymax = (y > m->ymax) ? y : m->ymax; - } - } - if (m->readnodefile) { - fclose(infile); - } - - /* Nonexistent x value used as a flag to mark circle events in sweepline */ - /* Delaunay algorithm. */ - m->xminextreme = 10 * m->xmin - 9 * m->xmax; -} - -#endif /* not TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* transfernodes() Read the vertices from memory. */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void transfernodes(struct mesh *m, struct behavior *b, REAL *pointlist, - REAL *pointattriblist, int *pointmarkerlist, - int numberofpoints, int numberofpointattribs) -#else /* not ANSI_DECLARATORS */ - void transfernodes(m, b, pointlist, pointattriblist, pointmarkerlist, - numberofpoints, numberofpointattribs) struct mesh *m; - struct behavior *b; - REAL *pointlist; - REAL *pointattriblist; - int *pointmarkerlist; - int numberofpoints; - int numberofpointattribs; -#endif /* not ANSI_DECLARATORS */ - -{ - vertex vertexloop; - REAL x, y; - int i, j; - int coordindex; - int attribindex; - - m->invertices = numberofpoints; - m->mesh_dim = 2; - m->nextras = numberofpointattribs; - m->readnodefile = 0; - if (m->invertices < 3) { - printf("Error: Input must have at least three input vertices.\n"); - triexit(1); - } - if (m->nextras == 0) { - b->weighted = 0; - } - - initializevertexpool(m, b); - - /* Read the vertices. */ - coordindex = 0; - attribindex = 0; - for (i = 0; i < m->invertices; i++) { - vertexloop = (vertex)poolalloc(&m->vertices); - /* Read the vertex coordinates. */ - x = vertexloop[0] = pointlist[coordindex++]; - y = vertexloop[1] = pointlist[coordindex++]; - /* Read the vertex attributes. */ - for (j = 0; j < numberofpointattribs; j++) { - vertexloop[2 + j] = pointattriblist[attribindex++]; - } - if (pointmarkerlist != (int *)NULL) { - /* Read a vertex marker. */ - setvertexmark(vertexloop, pointmarkerlist[i]); - } else { - /* If no markers are specified, they default to zero. */ - setvertexmark(vertexloop, 0); - } - setvertextype(vertexloop, INPUTVERTEX); - /* Determine the smallest and largest x and y coordinates. */ - if (i == 0) { - m->xmin = m->xmax = x; - m->ymin = m->ymax = y; - } else { - m->xmin = (x < m->xmin) ? x : m->xmin; - m->xmax = (x > m->xmax) ? x : m->xmax; - m->ymin = (y < m->ymin) ? y : m->ymin; - m->ymax = (y > m->ymax) ? y : m->ymax; - } - } - - /* Nonexistent x value used as a flag to mark circle events in sweepline */ - /* Delaunay algorithm. */ - m->xminextreme = 10 * m->xmin - 9 * m->xmax; -} - -#endif /* TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* readholes() Read the holes, and possibly regional attributes and area */ -/* constraints, from a .poly file. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void readholes(struct mesh *m, struct behavior *b, FILE *polyfile, - char *polyfilename, REAL **hlist, int *holes, REAL **rlist, - int *regions) -#else /* not ANSI_DECLARATORS */ - void readholes(m, b, polyfile, polyfilename, hlist, holes, rlist, - regions) struct mesh *m; - struct behavior *b; - FILE *polyfile; - char *polyfilename; - REAL **hlist; - int *holes; - REAL **rlist; - int *regions; -#endif /* not ANSI_DECLARATORS */ - -{ - REAL *holelist; - REAL *regionlist; - char inputline[INPUTLINESIZE]; - char *stringptr; - int index; - int i; - - /* Read the holes. */ - stringptr = readline(inputline, polyfile, polyfilename); - *holes = (int)strtol(stringptr, &stringptr, 0); - if (*holes > 0) { - holelist = (REAL *)trimalloc(2 * *holes * (int)sizeof(REAL)); - *hlist = holelist; - for (i = 0; i < 2 * *holes; i += 2) { - stringptr = readline(inputline, polyfile, polyfilename); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Hole %d has no x coordinate.\n", - b->firstnumber + (i >> 1)); - triexit(1); - } else { - holelist[i] = (REAL)strtod(stringptr, &stringptr); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Hole %d has no y coordinate.\n", - b->firstnumber + (i >> 1)); - triexit(1); - } else { - holelist[i + 1] = (REAL)strtod(stringptr, &stringptr); - } - } - } else { - *hlist = (REAL *)NULL; - } - -#ifndef CDT_ONLY - if ((b->regionattrib || b->vararea) && !b->refine) { - /* Read the area constraints. */ - stringptr = readline(inputline, polyfile, polyfilename); - *regions = (int)strtol(stringptr, &stringptr, 0); - if (*regions > 0) { - regionlist = (REAL *)trimalloc(4 * *regions * (int)sizeof(REAL)); - *rlist = regionlist; - index = 0; - for (i = 0; i < *regions; i++) { - stringptr = readline(inputline, polyfile, polyfilename); - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Region %d has no x coordinate.\n", - b->firstnumber + i); - triexit(1); - } else { - regionlist[index++] = (REAL)strtod(stringptr, &stringptr); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf("Error: Region %d has no y coordinate.\n", - b->firstnumber + i); - triexit(1); - } else { - regionlist[index++] = (REAL)strtod(stringptr, &stringptr); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - printf( - "Error: Region %d has no region attribute or area constraint.\n", - b->firstnumber + i); - triexit(1); - } else { - regionlist[index++] = (REAL)strtod(stringptr, &stringptr); - } - stringptr = findfield(stringptr); - if (*stringptr == '\0') { - regionlist[index] = regionlist[index - 1]; - } else { - regionlist[index] = (REAL)strtod(stringptr, &stringptr); - } - index++; - } - } - } else { - /* Set `*regions' to zero to avoid an accidental free() later. */ - *regions = 0; - *rlist = (REAL *)NULL; - } -#endif /* not CDT_ONLY */ - - fclose(polyfile); -} - -#endif /* not TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* finishfile() Write the command line to the output file so the user */ -/* can remember how the file was generated. Close the file. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void finishfile(FILE *outfile, int argc, char **argv) -#else /* not ANSI_DECLARATORS */ - void finishfile(outfile, argc, argv) FILE *outfile; - int argc; - char **argv; -#endif /* not ANSI_DECLARATORS */ - -{ - int i; - - fprintf(outfile, "# Generated by"); - for (i = 0; i < argc; i++) { - fprintf(outfile, " "); - fputs(argv[i], outfile); - } - fprintf(outfile, "\n"); - fclose(outfile); -} - -#endif /* not TRILIBRARY */ - -/*****************************************************************************/ -/* */ -/* writenodes() Number the vertices and write them to a .node file. */ -/* */ -/* To save memory, the vertex numbers are written over the boundary markers */ -/* after the vertices are written to a file. */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void writenodes(struct mesh *m, struct behavior *b, REAL **pointlist, - REAL **pointattriblist, int **pointmarkerlist) -#else /* not ANSI_DECLARATORS */ - void writenodes(m, b, pointlist, pointattriblist, - pointmarkerlist) struct mesh *m; - struct behavior *b; - REAL **pointlist; - REAL **pointattriblist; - int **pointmarkerlist; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -void writenodes(struct mesh *m, struct behavior *b, char *nodefilename, - int argc, char **argv) -#else /* not ANSI_DECLARATORS */ -void writenodes(m, b, nodefilename, argc, argv) struct mesh *m; -struct behavior *b; -char *nodefilename; -int argc; -char **argv; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - REAL *plist; - REAL *palist; - int *pmlist; - int coordindex; - int attribindex; -#else /* not TRILIBRARY */ - FILE *outfile; -#endif /* not TRILIBRARY */ - vertex vertexloop; - long outvertices; - int vertexnumber; - int i; - - if (b->jettison) { - outvertices = m->vertices.items - m->undeads; - } else { - outvertices = m->vertices.items; - } - -#ifdef TRILIBRARY - if (!b->quiet) { - printf("Writing vertices.\n"); - } - /* Allocate memory for output vertices if necessary. */ - if (*pointlist == (REAL *)NULL) { - *pointlist = (REAL *)trimalloc((int)(outvertices * 2 * sizeof(REAL))); - } - /* Allocate memory for output vertex attributes if necessary. */ - if ((m->nextras > 0) && (*pointattriblist == (REAL *)NULL)) { - *pointattriblist = - (REAL *)trimalloc((int)(outvertices * m->nextras * sizeof(REAL))); - } - /* Allocate memory for output vertex markers if necessary. */ - if (!b->nobound && (*pointmarkerlist == (int *)NULL)) { - *pointmarkerlist = (int *)trimalloc((int)(outvertices * sizeof(int))); - } - plist = *pointlist; - palist = *pointattriblist; - pmlist = *pointmarkerlist; - coordindex = 0; - attribindex = 0; -#else /* not TRILIBRARY */ - if (!b->quiet) { - printf("Writing %s.\n", nodefilename); - } - outfile = fopen(nodefilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", nodefilename); - triexit(1); - } - /* Number of vertices, number of dimensions, number of vertex attributes, */ - /* and number of boundary markers (zero or one). */ - fprintf(outfile, "%ld %d %d %d\n", outvertices, m->mesh_dim, m->nextras, - 1 - b->nobound); -#endif /* not TRILIBRARY */ - - traversalinit(&m->vertices); - vertexnumber = b->firstnumber; - vertexloop = vertextraverse(m); - while (vertexloop != (vertex)NULL) { - if (!b->jettison || (vertextype(vertexloop) != UNDEADVERTEX)) { -#ifdef TRILIBRARY - /* X and y coordinates. */ - plist[coordindex++] = vertexloop[0]; - plist[coordindex++] = vertexloop[1]; - /* Vertex attributes. */ - for (i = 0; i < m->nextras; i++) { - palist[attribindex++] = vertexloop[2 + i]; - } - if (!b->nobound) { - /* Copy the boundary marker. */ - pmlist[vertexnumber - b->firstnumber] = vertexmark(vertexloop); - } -#else /* not TRILIBRARY */ - /* Vertex number, x and y coordinates. */ - fprintf(outfile, "%4d %.17g %.17g", vertexnumber, vertexloop[0], - vertexloop[1]); - for (i = 0; i < m->nextras; i++) { - /* Write an attribute. */ - fprintf(outfile, " %.17g", vertexloop[i + 2]); - } - if (b->nobound) { - fprintf(outfile, "\n"); - } else { - /* Write the boundary marker. */ - fprintf(outfile, " %d\n", vertexmark(vertexloop)); - } -#endif /* not TRILIBRARY */ - - setvertexmark(vertexloop, vertexnumber); - vertexnumber++; - } - vertexloop = vertextraverse(m); - } - -#ifndef TRILIBRARY - finishfile(outfile, argc, argv); -#endif /* not TRILIBRARY */ -} - -/*****************************************************************************/ -/* */ -/* numbernodes() Number the vertices. */ -/* */ -/* Each vertex is assigned a marker equal to its number. */ -/* */ -/* Used when writenodes() is not called because no .node file is written. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void numbernodes(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void numbernodes(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - vertex vertexloop; - int vertexnumber; - - traversalinit(&m->vertices); - vertexnumber = b->firstnumber; - vertexloop = vertextraverse(m); - while (vertexloop != (vertex)NULL) { - setvertexmark(vertexloop, vertexnumber); - if (!b->jettison || (vertextype(vertexloop) != UNDEADVERTEX)) { - vertexnumber++; - } - vertexloop = vertextraverse(m); - } -} - -/*****************************************************************************/ -/* */ -/* writeelements() Write the triangles to an .ele file. */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void writeelements(struct mesh *m, struct behavior *b, int **trianglelist, - REAL **triangleattriblist) -#else /* not ANSI_DECLARATORS */ - void writeelements(m, b, trianglelist, triangleattriblist) struct mesh *m; - struct behavior *b; - int **trianglelist; - REAL **triangleattriblist; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -void writeelements(struct mesh *m, struct behavior *b, char *elefilename, - int argc, char **argv) -#else /* not ANSI_DECLARATORS */ -void writeelements(m, b, elefilename, argc, argv) struct mesh *m; -struct behavior *b; -char *elefilename; -int argc; -char **argv; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - int *tlist; - REAL *talist; - int vertexindex; - int attribindex; -#else /* not TRILIBRARY */ - FILE *outfile; -#endif /* not TRILIBRARY */ - struct otri triangleloop; - vertex p1, p2, p3; - vertex mid1, mid2, mid3; - long elementnumber; - int i; - -#ifdef TRILIBRARY - if (!b->quiet) { - printf("Writing triangles.\n"); - } - /* Allocate memory for output triangles if necessary. */ - if (*trianglelist == (int *)NULL) { - *trianglelist = (int *)trimalloc( - (int)(m->triangles.items * ((b->order + 1) * (b->order + 2) / 2) * - sizeof(int))); - } - /* Allocate memory for output triangle attributes if necessary. */ - if ((m->eextras > 0) && (*triangleattriblist == (REAL *)NULL)) { - *triangleattriblist = (REAL *)trimalloc( - (int)(m->triangles.items * m->eextras * sizeof(REAL))); - } - tlist = *trianglelist; - talist = *triangleattriblist; - vertexindex = 0; - attribindex = 0; -#else /* not TRILIBRARY */ - if (!b->quiet) { - printf("Writing %s.\n", elefilename); - } - outfile = fopen(elefilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", elefilename); - triexit(1); - } - /* Number of triangles, vertices per triangle, attributes per triangle. */ - fprintf(outfile, "%ld %d %d\n", m->triangles.items, - (b->order + 1) * (b->order + 2) / 2, m->eextras); -#endif /* not TRILIBRARY */ - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - triangleloop.orient = 0; - elementnumber = b->firstnumber; - while (triangleloop.tri != (triangle *)NULL) { - org(triangleloop, p1); - dest(triangleloop, p2); - apex(triangleloop, p3); - if (b->order == 1) { -#ifdef TRILIBRARY - tlist[vertexindex++] = vertexmark(p1); - tlist[vertexindex++] = vertexmark(p2); - tlist[vertexindex++] = vertexmark(p3); -#else /* not TRILIBRARY */ - /* Triangle number, indices for three vertices. */ - fprintf(outfile, "%4ld %4d %4d %4d", elementnumber, vertexmark(p1), - vertexmark(p2), vertexmark(p3)); -#endif /* not TRILIBRARY */ - } else { - mid1 = (vertex)triangleloop.tri[m->highorderindex + 1]; - mid2 = (vertex)triangleloop.tri[m->highorderindex + 2]; - mid3 = (vertex)triangleloop.tri[m->highorderindex]; -#ifdef TRILIBRARY - tlist[vertexindex++] = vertexmark(p1); - tlist[vertexindex++] = vertexmark(p2); - tlist[vertexindex++] = vertexmark(p3); - tlist[vertexindex++] = vertexmark(mid1); - tlist[vertexindex++] = vertexmark(mid2); - tlist[vertexindex++] = vertexmark(mid3); -#else /* not TRILIBRARY */ - /* Triangle number, indices for six vertices. */ - fprintf(outfile, "%4ld %4d %4d %4d %4d %4d %4d", elementnumber, - vertexmark(p1), vertexmark(p2), vertexmark(p3), vertexmark(mid1), - vertexmark(mid2), vertexmark(mid3)); -#endif /* not TRILIBRARY */ - } - -#ifdef TRILIBRARY - for (i = 0; i < m->eextras; i++) { - talist[attribindex++] = elemattribute(triangleloop, i); - } -#else /* not TRILIBRARY */ - for (i = 0; i < m->eextras; i++) { - fprintf(outfile, " %.17g", elemattribute(triangleloop, i)); - } - fprintf(outfile, "\n"); -#endif /* not TRILIBRARY */ - - triangleloop.tri = triangletraverse(m); - elementnumber++; - } - -#ifndef TRILIBRARY - finishfile(outfile, argc, argv); -#endif /* not TRILIBRARY */ -} - -/*****************************************************************************/ -/* */ -/* writepoly() Write the segments and holes to a .poly file. */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void writepoly(struct mesh *m, struct behavior *b, int **segmentlist, - int **segmentmarkerlist) -#else /* not ANSI_DECLARATORS */ - void writepoly(m, b, segmentlist, segmentmarkerlist) struct mesh *m; - struct behavior *b; - int **segmentlist; - int **segmentmarkerlist; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -void writepoly(struct mesh *m, struct behavior *b, char *polyfilename, - REAL *holelist, int holes, REAL *regionlist, int regions, - int argc, char **argv) -#else /* not ANSI_DECLARATORS */ -void writepoly(m, b, polyfilename, holelist, holes, regionlist, regions, argc, - argv) struct mesh *m; -struct behavior *b; -char *polyfilename; -REAL *holelist; -int holes; -REAL *regionlist; -int regions; -int argc; -char **argv; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - int *slist; - int *smlist; - int index; -#else /* not TRILIBRARY */ - FILE *outfile; - long holenumber, regionnumber; -#endif /* not TRILIBRARY */ - struct osub subsegloop; - vertex endpoint1, endpoint2; - long subsegnumber; - -#ifdef TRILIBRARY - if (!b->quiet) { - printf("Writing segments.\n"); - } - /* Allocate memory for output segments if necessary. */ - if (*segmentlist == (int *)NULL) { - *segmentlist = (int *)trimalloc((int)(m->subsegs.items * 2 * sizeof(int))); - } - /* Allocate memory for output segment markers if necessary. */ - if (!b->nobound && (*segmentmarkerlist == (int *)NULL)) { - *segmentmarkerlist = - (int *)trimalloc((int)(m->subsegs.items * sizeof(int))); - } - slist = *segmentlist; - smlist = *segmentmarkerlist; - index = 0; -#else /* not TRILIBRARY */ - if (!b->quiet) { - printf("Writing %s.\n", polyfilename); - } - outfile = fopen(polyfilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", polyfilename); - triexit(1); - } - /* The zero indicates that the vertices are in a separate .node file. */ - /* Followed by number of dimensions, number of vertex attributes, */ - /* and number of boundary markers (zero or one). */ - fprintf(outfile, "%d %d %d %d\n", 0, m->mesh_dim, m->nextras, - 1 - b->nobound); - /* Number of segments, number of boundary markers (zero or one). */ - fprintf(outfile, "%ld %d\n", m->subsegs.items, 1 - b->nobound); -#endif /* not TRILIBRARY */ - - traversalinit(&m->subsegs); - subsegloop.ss = subsegtraverse(m); - subsegloop.ssorient = 0; - subsegnumber = b->firstnumber; - while (subsegloop.ss != (subseg *)NULL) { - sorg(subsegloop, endpoint1); - sdest(subsegloop, endpoint2); -#ifdef TRILIBRARY - /* Copy indices of the segment's two endpoints. */ - slist[index++] = vertexmark(endpoint1); - slist[index++] = vertexmark(endpoint2); - if (!b->nobound) { - /* Copy the boundary marker. */ - smlist[subsegnumber - b->firstnumber] = mark(subsegloop); - } -#else /* not TRILIBRARY */ - /* Segment number, indices of its two endpoints, and possibly a marker. */ - if (b->nobound) { - fprintf(outfile, "%4ld %4d %4d\n", subsegnumber, - vertexmark(endpoint1), vertexmark(endpoint2)); - } else { - fprintf(outfile, "%4ld %4d %4d %4d\n", subsegnumber, - vertexmark(endpoint1), vertexmark(endpoint2), mark(subsegloop)); - } -#endif /* not TRILIBRARY */ - - subsegloop.ss = subsegtraverse(m); - subsegnumber++; - } - -#ifndef TRILIBRARY -#ifndef CDT_ONLY - fprintf(outfile, "%d\n", holes); - if (holes > 0) { - for (holenumber = 0; holenumber < holes; holenumber++) { - /* Hole number, x and y coordinates. */ - fprintf(outfile, "%4ld %.17g %.17g\n", b->firstnumber + holenumber, - holelist[2 * holenumber], holelist[2 * holenumber + 1]); - } - } - if (regions > 0) { - fprintf(outfile, "%d\n", regions); - for (regionnumber = 0; regionnumber < regions; regionnumber++) { - /* Region number, x and y coordinates, attribute, maximum area. */ - fprintf(outfile, "%4ld %.17g %.17g %.17g %.17g\n", - b->firstnumber + regionnumber, regionlist[4 * regionnumber], - regionlist[4 * regionnumber + 1], - regionlist[4 * regionnumber + 2], - regionlist[4 * regionnumber + 3]); - } - } -#endif /* not CDT_ONLY */ - - finishfile(outfile, argc, argv); -#endif /* not TRILIBRARY */ -} - -/*****************************************************************************/ -/* */ -/* writeedges() Write the edges to an .edge file. */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void writeedges(struct mesh *m, struct behavior *b, int **edgelist, - int **edgemarkerlist) -#else /* not ANSI_DECLARATORS */ - void writeedges(m, b, edgelist, edgemarkerlist) struct mesh *m; - struct behavior *b; - int **edgelist; - int **edgemarkerlist; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -void writeedges(struct mesh *m, struct behavior *b, char *edgefilename, - int argc, char **argv) -#else /* not ANSI_DECLARATORS */ -void writeedges(m, b, edgefilename, argc, argv) struct mesh *m; -struct behavior *b; -char *edgefilename; -int argc; -char **argv; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - int *elist; - int *emlist; - int index; -#else /* not TRILIBRARY */ - FILE *outfile; -#endif /* not TRILIBRARY */ - struct otri triangleloop, trisym; - struct osub checkmark; - vertex p1, p2; - long edgenumber; - triangle ptr; /* Temporary variable used by sym(). */ - subseg sptr; /* Temporary variable used by tspivot(). */ - -#ifdef TRILIBRARY - if (!b->quiet) { - printf("Writing edges.\n"); - } - /* Allocate memory for edges if necessary. */ - if (*edgelist == (int *)NULL) { - *edgelist = (int *)trimalloc((int)(m->edges * 2 * sizeof(int))); - } - /* Allocate memory for edge markers if necessary. */ - if (!b->nobound && (*edgemarkerlist == (int *)NULL)) { - *edgemarkerlist = (int *)trimalloc((int)(m->edges * sizeof(int))); - } - elist = *edgelist; - emlist = *edgemarkerlist; - index = 0; -#else /* not TRILIBRARY */ - if (!b->quiet) { - printf("Writing %s.\n", edgefilename); - } - outfile = fopen(edgefilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", edgefilename); - triexit(1); - } - /* Number of edges, number of boundary markers (zero or one). */ - fprintf(outfile, "%ld %d\n", m->edges, 1 - b->nobound); -#endif /* not TRILIBRARY */ - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - edgenumber = b->firstnumber; - /* To loop over the set of edges, loop over all triangles, and look at */ - /* the three edges of each triangle. If there isn't another triangle */ - /* adjacent to the edge, operate on the edge. If there is another */ - /* adjacent triangle, operate on the edge only if the current triangle */ - /* has a smaller pointer than its neighbor. This way, each edge is */ - /* considered only once. */ - while (triangleloop.tri != (triangle *)NULL) { - for (triangleloop.orient = 0; triangleloop.orient < 3; - triangleloop.orient++) { - sym(triangleloop, trisym); - if ((triangleloop.tri < trisym.tri) || (trisym.tri == m->dummytri)) { - org(triangleloop, p1); - dest(triangleloop, p2); -#ifdef TRILIBRARY - elist[index++] = vertexmark(p1); - elist[index++] = vertexmark(p2); -#endif /* TRILIBRARY */ - if (b->nobound) { -#ifndef TRILIBRARY - /* Edge number, indices of two endpoints. */ - fprintf(outfile, "%4ld %d %d\n", edgenumber, vertexmark(p1), - vertexmark(p2)); -#endif /* not TRILIBRARY */ - } else { - /* Edge number, indices of two endpoints, and a boundary marker. */ - /* If there's no subsegment, the boundary marker is zero. */ - if (b->usesegments) { - tspivot(triangleloop, checkmark); - if (checkmark.ss == m->dummysub) { -#ifdef TRILIBRARY - emlist[edgenumber - b->firstnumber] = 0; -#else /* not TRILIBRARY */ - fprintf(outfile, "%4ld %d %d %d\n", edgenumber, - vertexmark(p1), vertexmark(p2), 0); -#endif /* not TRILIBRARY */ - } else { -#ifdef TRILIBRARY - emlist[edgenumber - b->firstnumber] = mark(checkmark); -#else /* not TRILIBRARY */ - fprintf(outfile, "%4ld %d %d %d\n", edgenumber, - vertexmark(p1), vertexmark(p2), mark(checkmark)); -#endif /* not TRILIBRARY */ - } - } else { -#ifdef TRILIBRARY - emlist[edgenumber - b->firstnumber] = trisym.tri == m->dummytri; -#else /* not TRILIBRARY */ - fprintf(outfile, "%4ld %d %d %d\n", edgenumber, vertexmark(p1), - vertexmark(p2), trisym.tri == m->dummytri); -#endif /* not TRILIBRARY */ - } - } - edgenumber++; - } - } - triangleloop.tri = triangletraverse(m); - } - -#ifndef TRILIBRARY - finishfile(outfile, argc, argv); -#endif /* not TRILIBRARY */ -} - -/*****************************************************************************/ -/* */ -/* writevoronoi() Write the Voronoi diagram to a .v.node and .v.edge */ -/* file. */ -/* */ -/* The Voronoi diagram is the geometric dual of the Delaunay triangulation. */ -/* Hence, the Voronoi vertices are listed by traversing the Delaunay */ -/* triangles, and the Voronoi edges are listed by traversing the Delaunay */ -/* edges. */ -/* */ -/* WARNING: In order to assign numbers to the Voronoi vertices, this */ -/* procedure messes up the subsegments or the extra nodes of every */ -/* element. Hence, you should call this procedure last. */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void writevoronoi(struct mesh *m, struct behavior *b, REAL **vpointlist, - REAL **vpointattriblist, int **vpointmarkerlist, - int **vedgelist, int **vedgemarkerlist, REAL **vnormlist) -#else /* not ANSI_DECLARATORS */ - void writevoronoi(m, b, vpointlist, vpointattriblist, vpointmarkerlist, - vedgelist, vedgemarkerlist, vnormlist) struct mesh *m; - struct behavior *b; - REAL **vpointlist; - REAL **vpointattriblist; - int **vpointmarkerlist; - int **vedgelist; - int **vedgemarkerlist; - REAL **vnormlist; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -void writevoronoi(struct mesh *m, struct behavior *b, char *vnodefilename, - char *vedgefilename, int argc, char **argv) -#else /* not ANSI_DECLARATORS */ -void writevoronoi(m, b, vnodefilename, vedgefilename, argc, - argv) struct mesh *m; -struct behavior *b; -char *vnodefilename; -char *vedgefilename; -int argc; -char **argv; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - REAL *plist; - REAL *palist; - int *elist; - REAL *normlist; - int coordindex; - int attribindex; -#else /* not TRILIBRARY */ - FILE *outfile; -#endif /* not TRILIBRARY */ - struct otri triangleloop, trisym; - vertex torg, tdest, tapex; - REAL circumcenter[2]; - REAL xi, eta; - long vnodenumber, vedgenumber; - int p1, p2; - int i; - triangle ptr; /* Temporary variable used by sym(). */ - -#ifdef TRILIBRARY - if (!b->quiet) { - printf("Writing Voronoi vertices.\n"); - } - /* Allocate memory for Voronoi vertices if necessary. */ - if (*vpointlist == (REAL *)NULL) { - *vpointlist = - (REAL *)trimalloc((int)(m->triangles.items * 2 * sizeof(REAL))); - } - /* Allocate memory for Voronoi vertex attributes if necessary. */ - if (*vpointattriblist == (REAL *)NULL) { - *vpointattriblist = (REAL *)trimalloc( - (int)(m->triangles.items * m->nextras * sizeof(REAL))); - } - *vpointmarkerlist = (int *)NULL; - plist = *vpointlist; - palist = *vpointattriblist; - coordindex = 0; - attribindex = 0; -#else /* not TRILIBRARY */ - if (!b->quiet) { - printf("Writing %s.\n", vnodefilename); - } - outfile = fopen(vnodefilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", vnodefilename); - triexit(1); - } - /* Number of triangles, two dimensions, number of vertex attributes, */ - /* no markers. */ - fprintf(outfile, "%ld %d %d %d\n", m->triangles.items, 2, m->nextras, 0); -#endif /* not TRILIBRARY */ - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - triangleloop.orient = 0; - vnodenumber = b->firstnumber; - while (triangleloop.tri != (triangle *)NULL) { - org(triangleloop, torg); - dest(triangleloop, tdest); - apex(triangleloop, tapex); - findcircumcenter(m, b, torg, tdest, tapex, circumcenter, &xi, &eta, 0); -#ifdef TRILIBRARY - /* X and y coordinates. */ - plist[coordindex++] = circumcenter[0]; - plist[coordindex++] = circumcenter[1]; - for (i = 2; i < 2 + m->nextras; i++) { - /* Interpolate the vertex attributes at the circumcenter. */ - palist[attribindex++] = - torg[i] + xi * (tdest[i] - torg[i]) + eta * (tapex[i] - torg[i]); - } -#else /* not TRILIBRARY */ - /* Voronoi vertex number, x and y coordinates. */ - fprintf(outfile, "%4ld %.17g %.17g", vnodenumber, circumcenter[0], - circumcenter[1]); - for (i = 2; i < 2 + m->nextras; i++) { - /* Interpolate the vertex attributes at the circumcenter. */ - fprintf(outfile, " %.17g", - torg[i] + xi * (tdest[i] - torg[i]) + eta * (tapex[i] - torg[i])); - } - fprintf(outfile, "\n"); -#endif /* not TRILIBRARY */ - - *(int *)(triangleloop.tri + 6) = (int)vnodenumber; - triangleloop.tri = triangletraverse(m); - vnodenumber++; - } - -#ifndef TRILIBRARY - finishfile(outfile, argc, argv); -#endif /* not TRILIBRARY */ - -#ifdef TRILIBRARY - if (!b->quiet) { - printf("Writing Voronoi edges.\n"); - } - /* Allocate memory for output Voronoi edges if necessary. */ - if (*vedgelist == (int *)NULL) { - *vedgelist = (int *)trimalloc((int)(m->edges * 2 * sizeof(int))); - } - *vedgemarkerlist = (int *)NULL; - /* Allocate memory for output Voronoi norms if necessary. */ - if (*vnormlist == (REAL *)NULL) { - *vnormlist = (REAL *)trimalloc((int)(m->edges * 2 * sizeof(REAL))); - } - elist = *vedgelist; - normlist = *vnormlist; - coordindex = 0; -#else /* not TRILIBRARY */ - if (!b->quiet) { - printf("Writing %s.\n", vedgefilename); - } - outfile = fopen(vedgefilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", vedgefilename); - triexit(1); - } - /* Number of edges, zero boundary markers. */ - fprintf(outfile, "%ld %d\n", m->edges, 0); -#endif /* not TRILIBRARY */ - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - vedgenumber = b->firstnumber; - /* To loop over the set of edges, loop over all triangles, and look at */ - /* the three edges of each triangle. If there isn't another triangle */ - /* adjacent to the edge, operate on the edge. If there is another */ - /* adjacent triangle, operate on the edge only if the current triangle */ - /* has a smaller pointer than its neighbor. This way, each edge is */ - /* considered only once. */ - while (triangleloop.tri != (triangle *)NULL) { - for (triangleloop.orient = 0; triangleloop.orient < 3; - triangleloop.orient++) { - sym(triangleloop, trisym); - if ((triangleloop.tri < trisym.tri) || (trisym.tri == m->dummytri)) { - /* Find the number of this triangle (and Voronoi vertex). */ - p1 = *(int *)(triangleloop.tri + 6); - if (trisym.tri == m->dummytri) { - org(triangleloop, torg); - dest(triangleloop, tdest); -#ifdef TRILIBRARY - /* Copy an infinite ray. Index of one endpoint, and -1. */ - elist[coordindex] = p1; - normlist[coordindex++] = tdest[1] - torg[1]; - elist[coordindex] = -1; - normlist[coordindex++] = torg[0] - tdest[0]; -#else /* not TRILIBRARY */ - /* Write an infinite ray. Edge number, index of one endpoint, -1, */ - /* and x and y coordinates of a vector representing the */ - /* direction of the ray. */ - fprintf(outfile, "%4ld %d %d %.17g %.17g\n", vedgenumber, p1, - -1, tdest[1] - torg[1], torg[0] - tdest[0]); -#endif /* not TRILIBRARY */ - } else { - /* Find the number of the adjacent triangle (and Voronoi vertex). */ - p2 = *(int *)(trisym.tri + 6); - /* Finite edge. Write indices of two endpoints. */ -#ifdef TRILIBRARY - elist[coordindex] = p1; - normlist[coordindex++] = 0.0; - elist[coordindex] = p2; - normlist[coordindex++] = 0.0; -#else /* not TRILIBRARY */ - fprintf(outfile, "%4ld %d %d\n", vedgenumber, p1, p2); -#endif /* not TRILIBRARY */ - } - vedgenumber++; - } - } - triangleloop.tri = triangletraverse(m); - } - -#ifndef TRILIBRARY - finishfile(outfile, argc, argv); -#endif /* not TRILIBRARY */ -} - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void writeneighbors(struct mesh *m, struct behavior *b, int **neighborlist) -#else /* not ANSI_DECLARATORS */ - void writeneighbors(m, b, neighborlist) struct mesh *m; - struct behavior *b; - int **neighborlist; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -void writeneighbors(struct mesh *m, struct behavior *b, char *neighborfilename, - int argc, char **argv) -#else /* not ANSI_DECLARATORS */ -void writeneighbors(m, b, neighborfilename, argc, argv) struct mesh *m; -struct behavior *b; -char *neighborfilename; -int argc; -char **argv; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ -#ifdef TRILIBRARY - int *nlist; - int index; -#else /* not TRILIBRARY */ - FILE *outfile; -#endif /* not TRILIBRARY */ - struct otri triangleloop, trisym; - long elementnumber; - int neighbor1, neighbor2, neighbor3; - triangle ptr; /* Temporary variable used by sym(). */ - -#ifdef TRILIBRARY - if (!b->quiet) { - printf("Writing neighbors.\n"); - } - /* Allocate memory for neighbors if necessary. */ - if (*neighborlist == (int *)NULL) { - *neighborlist = - (int *)trimalloc((int)(m->triangles.items * 3 * sizeof(int))); - } - nlist = *neighborlist; - index = 0; -#else /* not TRILIBRARY */ - if (!b->quiet) { - printf("Writing %s.\n", neighborfilename); - } - outfile = fopen(neighborfilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", neighborfilename); - triexit(1); - } - /* Number of triangles, three neighbors per triangle. */ - fprintf(outfile, "%ld %d\n", m->triangles.items, 3); -#endif /* not TRILIBRARY */ - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - triangleloop.orient = 0; - elementnumber = b->firstnumber; - while (triangleloop.tri != (triangle *)NULL) { - *(int *)(triangleloop.tri + 6) = (int)elementnumber; - triangleloop.tri = triangletraverse(m); - elementnumber++; - } - *(int *)(m->dummytri + 6) = -1; - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - elementnumber = b->firstnumber; - while (triangleloop.tri != (triangle *)NULL) { - triangleloop.orient = 1; - sym(triangleloop, trisym); - neighbor1 = *(int *)(trisym.tri + 6); - triangleloop.orient = 2; - sym(triangleloop, trisym); - neighbor2 = *(int *)(trisym.tri + 6); - triangleloop.orient = 0; - sym(triangleloop, trisym); - neighbor3 = *(int *)(trisym.tri + 6); -#ifdef TRILIBRARY - nlist[index++] = neighbor1; - nlist[index++] = neighbor2; - nlist[index++] = neighbor3; -#else /* not TRILIBRARY */ - /* Triangle number, neighboring triangle numbers. */ - fprintf(outfile, "%4ld %d %d %d\n", elementnumber, neighbor1, - neighbor2, neighbor3); -#endif /* not TRILIBRARY */ - - triangleloop.tri = triangletraverse(m); - elementnumber++; - } - -#ifndef TRILIBRARY - finishfile(outfile, argc, argv); -#endif /* not TRILIBRARY */ -} - -/*****************************************************************************/ -/* */ -/* writeoff() Write the triangulation to an .off file. */ -/* */ -/* OFF stands for the Object File Format, a format used by the Geometry */ -/* Center's Geomview package. */ -/* */ -/*****************************************************************************/ - -#ifndef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void writeoff(struct mesh *m, struct behavior *b, char *offfilename, int argc, - char **argv) -#else /* not ANSI_DECLARATORS */ - void writeoff(m, b, offfilename, argc, argv) struct mesh *m; - struct behavior *b; - char *offfilename; - int argc; - char **argv; -#endif /* not ANSI_DECLARATORS */ - -{ - FILE *outfile; - struct otri triangleloop; - vertex vertexloop; - vertex p1, p2, p3; - long outvertices; - - if (!b->quiet) { - printf("Writing %s.\n", offfilename); - } - - if (b->jettison) { - outvertices = m->vertices.items - m->undeads; - } else { - outvertices = m->vertices.items; - } - - outfile = fopen(offfilename, "w"); - if (outfile == (FILE *)NULL) { - printf(" Error: Cannot create file %s.\n", offfilename); - triexit(1); - } - /* Number of vertices, triangles, and edges. */ - fprintf(outfile, "OFF\n%ld %ld %ld\n", outvertices, m->triangles.items, - m->edges); - - /* Write the vertices. */ - traversalinit(&m->vertices); - vertexloop = vertextraverse(m); - while (vertexloop != (vertex)NULL) { - if (!b->jettison || (vertextype(vertexloop) != UNDEADVERTEX)) { - /* The "0.0" is here because the OFF format uses 3D coordinates. */ - fprintf(outfile, " %.17g %.17g %.17g\n", vertexloop[0], vertexloop[1], - 0.0); - } - vertexloop = vertextraverse(m); - } - - /* Write the triangles. */ - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - triangleloop.orient = 0; - while (triangleloop.tri != (triangle *)NULL) { - org(triangleloop, p1); - dest(triangleloop, p2); - apex(triangleloop, p3); - /* The "3" means a three-vertex polygon. */ - fprintf(outfile, " 3 %4d %4d %4d\n", vertexmark(p1) - b->firstnumber, - vertexmark(p2) - b->firstnumber, vertexmark(p3) - b->firstnumber); - triangleloop.tri = triangletraverse(m); - } - finishfile(outfile, argc, argv); -} - -#endif /* not TRILIBRARY */ - -/** **/ -/** **/ -/********* File I/O routines end here *********/ - -/*****************************************************************************/ -/* */ -/* quality_statistics() Print statistics about the quality of the mesh. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void quality_statistics(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void quality_statistics(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - struct otri triangleloop; - vertex p[3]; - REAL cossquaretable[8]; - REAL ratiotable[16]; - REAL dx[3], dy[3]; - REAL edgelength[3]; - REAL dotproduct; - REAL cossquare; - REAL triarea; - REAL shortest, longest; - REAL trilongest2; - REAL smallestarea, biggestarea; - REAL triminaltitude2; - REAL minaltitude; - REAL triaspect2; - REAL worstaspect; - REAL smallestangle, biggestangle; - REAL radconst, degconst; - int angletable[18]; - int aspecttable[16]; - int aspectindex; - int tendegree; - int acutebiggest; - int i, ii, j, k; - - printf("Mesh quality statistics:\n\n"); - radconst = PI / 18.0; - degconst = 180.0 / PI; - for (i = 0; i < 8; i++) { - cossquaretable[i] = cos(radconst * (REAL)(i + 1)); - cossquaretable[i] = cossquaretable[i] * cossquaretable[i]; - } - for (i = 0; i < 18; i++) { - angletable[i] = 0; - } - - ratiotable[0] = 1.5; - ratiotable[1] = 2.0; - ratiotable[2] = 2.5; - ratiotable[3] = 3.0; - ratiotable[4] = 4.0; - ratiotable[5] = 6.0; - ratiotable[6] = 10.0; - ratiotable[7] = 15.0; - ratiotable[8] = 25.0; - ratiotable[9] = 50.0; - ratiotable[10] = 100.0; - ratiotable[11] = 300.0; - ratiotable[12] = 1000.0; - ratiotable[13] = 10000.0; - ratiotable[14] = 100000.0; - ratiotable[15] = 0.0; - for (i = 0; i < 16; i++) { - aspecttable[i] = 0; - } - - worstaspect = 0.0; - minaltitude = m->xmax - m->xmin + m->ymax - m->ymin; - minaltitude = minaltitude * minaltitude; - shortest = minaltitude; - longest = 0.0; - smallestarea = minaltitude; - biggestarea = 0.0; - worstaspect = 0.0; - smallestangle = 0.0; - biggestangle = 2.0; - acutebiggest = 1; - - traversalinit(&m->triangles); - triangleloop.tri = triangletraverse(m); - triangleloop.orient = 0; - while (triangleloop.tri != (triangle *)NULL) { - org(triangleloop, p[0]); - dest(triangleloop, p[1]); - apex(triangleloop, p[2]); - trilongest2 = 0.0; - - for (i = 0; i < 3; i++) { - j = plus1mod3[i]; - k = minus1mod3[i]; - dx[i] = p[j][0] - p[k][0]; - dy[i] = p[j][1] - p[k][1]; - edgelength[i] = dx[i] * dx[i] + dy[i] * dy[i]; - if (edgelength[i] > trilongest2) { - trilongest2 = edgelength[i]; - } - if (edgelength[i] > longest) { - longest = edgelength[i]; - } - if (edgelength[i] < shortest) { - shortest = edgelength[i]; - } - } - - triarea = counterclockwise(m, b, p[0], p[1], p[2]); - if (triarea < smallestarea) { - smallestarea = triarea; - } - if (triarea > biggestarea) { - biggestarea = triarea; - } - triminaltitude2 = triarea * triarea / trilongest2; - if (triminaltitude2 < minaltitude) { - minaltitude = triminaltitude2; - } - triaspect2 = trilongest2 / triminaltitude2; - if (triaspect2 > worstaspect) { - worstaspect = triaspect2; - } - aspectindex = 0; - while ((triaspect2 > ratiotable[aspectindex] * ratiotable[aspectindex]) && - (aspectindex < 15)) { - aspectindex++; - } - aspecttable[aspectindex]++; - - for (i = 0; i < 3; i++) { - j = plus1mod3[i]; - k = minus1mod3[i]; - dotproduct = dx[j] * dx[k] + dy[j] * dy[k]; - cossquare = dotproduct * dotproduct / (edgelength[j] * edgelength[k]); - tendegree = 8; - for (ii = 7; ii >= 0; ii--) { - if (cossquare > cossquaretable[ii]) { - tendegree = ii; - } - } - if (dotproduct <= 0.0) { - angletable[tendegree]++; - if (cossquare > smallestangle) { - smallestangle = cossquare; - } - if (acutebiggest && (cossquare < biggestangle)) { - biggestangle = cossquare; - } - } else { - angletable[17 - tendegree]++; - if (acutebiggest || (cossquare > biggestangle)) { - biggestangle = cossquare; - acutebiggest = 0; - } - } - } - triangleloop.tri = triangletraverse(m); - } - - shortest = sqrt(shortest); - longest = sqrt(longest); - minaltitude = sqrt(minaltitude); - worstaspect = sqrt(worstaspect); - smallestarea *= 0.5; - biggestarea *= 0.5; - if (smallestangle >= 1.0) { - smallestangle = 0.0; - } else { - smallestangle = degconst * acos(sqrt(smallestangle)); - } - if (biggestangle >= 1.0) { - biggestangle = 180.0; - } else { - if (acutebiggest) { - biggestangle = degconst * acos(sqrt(biggestangle)); - } else { - biggestangle = 180.0 - degconst * acos(sqrt(biggestangle)); - } - } - - printf(" Smallest area: %16.5g | Largest area: %16.5g\n", smallestarea, - biggestarea); - printf(" Shortest edge: %16.5g | Longest edge: %16.5g\n", shortest, - longest); - printf(" Shortest altitude: %12.5g | Largest aspect ratio: %8.5g\n\n", - minaltitude, worstaspect); - - printf(" Triangle aspect ratio histogram:\n"); - printf(" 1.1547 - %-6.6g : %8d | %6.6g - %-6.6g : %8d\n", - ratiotable[0], aspecttable[0], ratiotable[7], ratiotable[8], - aspecttable[8]); - for (i = 1; i < 7; i++) { - printf(" %6.6g - %-6.6g : %8d | %6.6g - %-6.6g : %8d\n", - ratiotable[i - 1], ratiotable[i], aspecttable[i], ratiotable[i + 7], - ratiotable[i + 8], aspecttable[i + 8]); - } - printf(" %6.6g - %-6.6g : %8d | %6.6g - : %8d\n", - ratiotable[6], ratiotable[7], aspecttable[7], ratiotable[14], - aspecttable[15]); - printf(" (Aspect ratio is longest edge divided by shortest altitude)\n\n"); - - printf(" Smallest angle: %15.5g | Largest angle: %15.5g\n\n", - smallestangle, biggestangle); - - printf(" Angle histogram:\n"); - for (i = 0; i < 9; i++) { - printf(" %3d - %3d degrees: %8d | %3d - %3d degrees: %8d\n", - i * 10, i * 10 + 10, angletable[i], i * 10 + 90, i * 10 + 100, - angletable[i + 9]); - } - printf("\n"); -} - -/*****************************************************************************/ -/* */ -/* statistics() Print all sorts of cool facts. */ -/* */ -/*****************************************************************************/ - -#ifdef ANSI_DECLARATORS -void statistics(struct mesh *m, struct behavior *b) -#else /* not ANSI_DECLARATORS */ -void statistics(m, b) struct mesh *m; -struct behavior *b; -#endif /* not ANSI_DECLARATORS */ - -{ - printf("\nStatistics:\n\n"); - printf(" Input vertices: %d\n", m->invertices); - if (b->refine) { - printf(" Input triangles: %d\n", m->inelements); - } - if (b->poly) { - printf(" Input segments: %d\n", m->insegments); - if (!b->refine) { - printf(" Input holes: %d\n", m->holes); - } - } - - printf("\n Mesh vertices: %ld\n", m->vertices.items - m->undeads); - printf(" Mesh triangles: %ld\n", m->triangles.items); - printf(" Mesh edges: %ld\n", m->edges); - printf(" Mesh exterior boundary edges: %ld\n", m->hullsize); - if (b->poly || b->refine) { - printf(" Mesh interior boundary edges: %ld\n", - m->subsegs.items - m->hullsize); - printf(" Mesh subsegments (constrained edges): %ld\n", m->subsegs.items); - } - printf("\n"); - - if (b->verbose) { - quality_statistics(m, b); - printf("Memory allocation statistics:\n\n"); - printf(" Maximum number of vertices: %ld\n", m->vertices.maxitems); - printf(" Maximum number of triangles: %ld\n", m->triangles.maxitems); - if (m->subsegs.maxitems > 0) { - printf(" Maximum number of subsegments: %ld\n", m->subsegs.maxitems); - } - if (m->viri.maxitems > 0) { - printf(" Maximum number of viri: %ld\n", m->viri.maxitems); - } - if (m->badsubsegs.maxitems > 0) { - printf(" Maximum number of encroached subsegments: %ld\n", - m->badsubsegs.maxitems); - } - if (m->badtriangles.maxitems > 0) { - printf(" Maximum number of bad triangles: %ld\n", - m->badtriangles.maxitems); - } - if (m->flipstackers.maxitems > 0) { - printf(" Maximum number of stacked triangle flips: %ld\n", - m->flipstackers.maxitems); - } - if (m->splaynodes.maxitems > 0) { - printf(" Maximum number of splay tree nodes: %ld\n", - m->splaynodes.maxitems); - } - printf(" Approximate heap memory use (bytes): %ld\n\n", - m->vertices.maxitems * m->vertices.itembytes + - m->triangles.maxitems * m->triangles.itembytes + - m->subsegs.maxitems * m->subsegs.itembytes + - m->viri.maxitems * m->viri.itembytes + - m->badsubsegs.maxitems * m->badsubsegs.itembytes + - m->badtriangles.maxitems * m->badtriangles.itembytes + - m->flipstackers.maxitems * m->flipstackers.itembytes + - m->splaynodes.maxitems * m->splaynodes.itembytes); - - printf("Algorithmic statistics:\n\n"); - if (!b->weighted) { - printf(" Number of incircle tests: %ld\n", m->incirclecount); - } else { - printf(" Number of 3D orientation tests: %ld\n", m->orient3dcount); - } - printf(" Number of 2D orientation tests: %ld\n", m->counterclockcount); - if (m->hyperbolacount > 0) { - printf(" Number of right-of-hyperbola tests: %ld\n", m->hyperbolacount); - } - if (m->circletopcount > 0) { - printf(" Number of circle top computations: %ld\n", m->circletopcount); - } - if (m->circumcentercount > 0) { - printf(" Number of triangle circumcenter computations: %ld\n", - m->circumcentercount); - } - printf("\n"); - } -} - -/*****************************************************************************/ -/* */ -/* main() or triangulate() Gosh, do everything. */ -/* */ -/* The sequence is roughly as follows. Many of these steps can be skipped, */ -/* depending on the command line switches. */ -/* */ -/* - Initialize constants and parse the command line. */ -/* - Read the vertices from a file and either */ -/* - triangulate them (no -r), or */ -/* - read an old mesh from files and reconstruct it (-r). */ -/* - Insert the PSLG segments (-p), and possibly segments on the convex */ -/* hull (-c). */ -/* - Read the holes (-p), regional attributes (-pA), and regional area */ -/* constraints (-pa). Carve the holes and concavities, and spread the */ -/* regional attributes and area constraints. */ -/* - Enforce the constraints on minimum angle (-q) and maximum area (-a). */ -/* Also enforce the conforming Delaunay property (-q and -a). */ -/* - Compute the number of edges in the resulting mesh. */ -/* - Promote the mesh's linear triangles to higher order elements (-o). */ -/* - Write the output files and print the statistics. */ -/* - Check the consistency and Delaunay property of the mesh (-C). */ -/* */ -/*****************************************************************************/ - -#ifdef TRILIBRARY - -#ifdef ANSI_DECLARATORS -void triangulate(char *triswitches, struct triangulateio *in, - struct triangulateio *out, struct triangulateio *vorout) -#else /* not ANSI_DECLARATORS */ - void triangulate(triswitches, in, out, vorout) char *triswitches; - struct triangulateio *in; - struct triangulateio *out; - struct triangulateio *vorout; -#endif /* not ANSI_DECLARATORS */ - -#else /* not TRILIBRARY */ - -#ifdef ANSI_DECLARATORS -int main(int argc, char **argv) -#else /* not ANSI_DECLARATORS */ -int main(argc, argv) -int argc; -char **argv; -#endif /* not ANSI_DECLARATORS */ - -#endif /* not TRILIBRARY */ - -{ - struct mesh m; - struct behavior b; - REAL *holearray; /* Array of holes. */ - REAL *regionarray; /* Array of regional attributes and area constraints. */ -#ifndef TRILIBRARY - FILE *polyfile; -#endif /* not TRILIBRARY */ -#ifndef NO_TIMER - /* Variables for timing the performance of Triangle. The types are */ - /* defined in sys/time.h. */ - struct timeval tv0, tv1, tv2, tv3, tv4, tv5, tv6; - struct timezone tz; -#endif /* not NO_TIMER */ - -#ifndef NO_TIMER - gettimeofday(&tv0, &tz); -#endif /* not NO_TIMER */ - - triangleinit(&m); -#ifdef TRILIBRARY - parsecommandline(1, &triswitches, &b); -#else /* not TRILIBRARY */ - parsecommandline(argc, argv, &b); -#endif /* not TRILIBRARY */ - m.steinerleft = b.steiner; - -#ifdef TRILIBRARY - transfernodes(&m, &b, in->pointlist, in->pointattributelist, - in->pointmarkerlist, in->numberofpoints, - in->numberofpointattributes); -#else /* not TRILIBRARY */ - readnodes(&m, &b, b.innodefilename, b.inpolyfilename, &polyfile); -#endif /* not TRILIBRARY */ - -#ifndef NO_TIMER - if (!b.quiet) { - gettimeofday(&tv1, &tz); - } -#endif /* not NO_TIMER */ - -#ifdef CDT_ONLY - m.hullsize = delaunay(&m, &b); /* Triangulate the vertices. */ -#else /* not CDT_ONLY */ - if (b.refine) { - /* Read and reconstruct a mesh. */ -#ifdef TRILIBRARY - m.hullsize = reconstruct(&m, &b, in->trianglelist, - in->triangleattributelist, in->trianglearealist, - in->numberoftriangles, in->numberofcorners, - in->numberoftriangleattributes, in->segmentlist, - in->segmentmarkerlist, in->numberofsegments); -#else /* not TRILIBRARY */ - m.hullsize = reconstruct(&m, &b, b.inelefilename, b.areafilename, - b.inpolyfilename, polyfile); -#endif /* not TRILIBRARY */ - } else { - m.hullsize = delaunay(&m, &b); /* Triangulate the vertices. */ - } -#endif /* not CDT_ONLY */ - -#ifndef NO_TIMER - if (!b.quiet) { - gettimeofday(&tv2, &tz); - if (b.refine) { - printf("Mesh reconstruction"); - } else { - printf("Delaunay"); - } - printf(" milliseconds: %ld\n", 1000l * (tv2.tv_sec - tv1.tv_sec) + - (tv2.tv_usec - tv1.tv_usec) / 1000l); - } -#endif /* not NO_TIMER */ - - /* Ensure that no vertex can be mistaken for a triangular bounding */ - /* box vertex in insertvertex(). */ - m.infvertex1 = (vertex)NULL; - m.infvertex2 = (vertex)NULL; - m.infvertex3 = (vertex)NULL; - - if (b.usesegments) { - m.checksegments = 1; /* Segments will be introduced next. */ - if (!b.refine) { - /* Insert PSLG segments and/or convex hull segments. */ -#ifdef TRILIBRARY - formskeleton(&m, &b, in->segmentlist, in->segmentmarkerlist, - in->numberofsegments); -#else /* not TRILIBRARY */ - formskeleton(&m, &b, polyfile, b.inpolyfilename); -#endif /* not TRILIBRARY */ - } - } - -#ifndef NO_TIMER - if (!b.quiet) { - gettimeofday(&tv3, &tz); - if (b.usesegments && !b.refine) { - printf("Segment milliseconds: %ld\n", - 1000l * (tv3.tv_sec - tv2.tv_sec) + - (tv3.tv_usec - tv2.tv_usec) / 1000l); - } - } -#endif /* not NO_TIMER */ - - if (b.poly && (m.triangles.items > 0)) { -#ifdef TRILIBRARY - holearray = in->holelist; - m.holes = in->numberofholes; - regionarray = in->regionlist; - m.regions = in->numberofregions; -#else /* not TRILIBRARY */ - readholes(&m, &b, polyfile, b.inpolyfilename, &holearray, &m.holes, - ®ionarray, &m.regions); -#endif /* not TRILIBRARY */ - if (!b.refine) { - /* Carve out holes and concavities. */ - carveholes(&m, &b, holearray, m.holes, regionarray, m.regions); - } - } else { - /* Without a PSLG, there can be no holes or regional attributes */ - /* or area constraints. The following are set to zero to avoid */ - /* an accidental free() later. */ - m.holes = 0; - m.regions = 0; - } - -#ifndef NO_TIMER - if (!b.quiet) { - gettimeofday(&tv4, &tz); - if (b.poly && !b.refine) { - printf("Hole milliseconds: %ld\n", - 1000l * (tv4.tv_sec - tv3.tv_sec) + - (tv4.tv_usec - tv3.tv_usec) / 1000l); - } - } -#endif /* not NO_TIMER */ - -#ifndef CDT_ONLY - if (b.quality && (m.triangles.items > 0)) { - enforcequality(&m, &b); /* Enforce angle and area constraints. */ - } -#endif /* not CDT_ONLY */ - -#ifndef NO_TIMER - if (!b.quiet) { - gettimeofday(&tv5, &tz); -#ifndef CDT_ONLY - if (b.quality) { - printf("Quality milliseconds: %ld\n", - 1000l * (tv5.tv_sec - tv4.tv_sec) + - (tv5.tv_usec - tv4.tv_usec) / 1000l); - } -#endif /* not CDT_ONLY */ - } -#endif /* not NO_TIMER */ - - /* Calculate the number of edges. */ - m.edges = (3l * m.triangles.items + m.hullsize) / 2l; - - if (b.order > 1) { - highorder(&m, &b); /* Promote elements to higher polynomial order. */ - } - if (!b.quiet) { - printf("\n"); - } - -#ifdef TRILIBRARY - if (b.jettison) { - out->numberofpoints = m.vertices.items - m.undeads; - } else { - out->numberofpoints = m.vertices.items; - } - out->numberofpointattributes = m.nextras; - out->numberoftriangles = m.triangles.items; - out->numberofcorners = (b.order + 1) * (b.order + 2) / 2; - out->numberoftriangleattributes = m.eextras; - out->numberofedges = m.edges; - if (b.usesegments) { - out->numberofsegments = m.subsegs.items; - } else { - out->numberofsegments = m.hullsize; - } - if (vorout != (struct triangulateio *)NULL) { - vorout->numberofpoints = m.triangles.items; - vorout->numberofpointattributes = m.nextras; - vorout->numberofedges = m.edges; - } -#endif /* TRILIBRARY */ - /* If not using iteration numbers, don't write a .node file if one was */ - /* read, because the original one would be overwritten! */ - if (b.nonodewritten || (b.noiterationnum && m.readnodefile)) { - if (!b.quiet) { -#ifdef TRILIBRARY - printf("NOT writing vertices.\n"); -#else /* not TRILIBRARY */ - printf("NOT writing a .node file.\n"); -#endif /* not TRILIBRARY */ - } - numbernodes(&m, &b); /* We must remember to number the vertices. */ - } else { - /* writenodes() numbers the vertices too. */ -#ifdef TRILIBRARY - writenodes(&m, &b, &out->pointlist, &out->pointattributelist, - &out->pointmarkerlist); -#else /* not TRILIBRARY */ - writenodes(&m, &b, b.outnodefilename, argc, argv); -#endif /* TRILIBRARY */ - } - if (b.noelewritten) { - if (!b.quiet) { -#ifdef TRILIBRARY - printf("NOT writing triangles.\n"); -#else /* not TRILIBRARY */ - printf("NOT writing an .ele file.\n"); -#endif /* not TRILIBRARY */ - } - } else { -#ifdef TRILIBRARY - writeelements(&m, &b, &out->trianglelist, &out->triangleattributelist); -#else /* not TRILIBRARY */ - writeelements(&m, &b, b.outelefilename, argc, argv); -#endif /* not TRILIBRARY */ - } - /* The -c switch (convex switch) causes a PSLG to be written */ - /* even if none was read. */ - if (b.poly || b.convex) { - /* If not using iteration numbers, don't overwrite the .poly file. */ - if (b.nopolywritten || b.noiterationnum) { - if (!b.quiet) { -#ifdef TRILIBRARY - printf("NOT writing segments.\n"); -#else /* not TRILIBRARY */ - printf("NOT writing a .poly file.\n"); -#endif /* not TRILIBRARY */ - } - } else { -#ifdef TRILIBRARY - writepoly(&m, &b, &out->segmentlist, &out->segmentmarkerlist); - out->numberofholes = m.holes; - out->numberofregions = m.regions; - if (b.poly) { - out->holelist = in->holelist; - out->regionlist = in->regionlist; - } else { - out->holelist = (REAL *)NULL; - out->regionlist = (REAL *)NULL; - } -#else /* not TRILIBRARY */ - writepoly(&m, &b, b.outpolyfilename, holearray, m.holes, regionarray, - m.regions, argc, argv); -#endif /* not TRILIBRARY */ - } - } -#ifndef TRILIBRARY -#ifndef CDT_ONLY - if (m.regions > 0) { - trifree((VOID *)regionarray); - } -#endif /* not CDT_ONLY */ - if (m.holes > 0) { - trifree((VOID *)holearray); - } - if (b.geomview) { - writeoff(&m, &b, b.offfilename, argc, argv); - } -#endif /* not TRILIBRARY */ - if (b.edgesout) { -#ifdef TRILIBRARY - writeedges(&m, &b, &out->edgelist, &out->edgemarkerlist); -#else /* not TRILIBRARY */ - writeedges(&m, &b, b.edgefilename, argc, argv); -#endif /* not TRILIBRARY */ - } - if (b.voronoi) { -#ifdef TRILIBRARY - writevoronoi(&m, &b, &vorout->pointlist, &vorout->pointattributelist, - &vorout->pointmarkerlist, &vorout->edgelist, - &vorout->edgemarkerlist, &vorout->normlist); -#else /* not TRILIBRARY */ - writevoronoi(&m, &b, b.vnodefilename, b.vedgefilename, argc, argv); -#endif /* not TRILIBRARY */ - } - if (b.neighbors) { -#ifdef TRILIBRARY - writeneighbors(&m, &b, &out->neighborlist); -#else /* not TRILIBRARY */ - writeneighbors(&m, &b, b.neighborfilename, argc, argv); -#endif /* not TRILIBRARY */ - } - - if (!b.quiet) { -#ifndef NO_TIMER - gettimeofday(&tv6, &tz); - printf("\nOutput milliseconds: %ld\n", - 1000l * (tv6.tv_sec - tv5.tv_sec) + - (tv6.tv_usec - tv5.tv_usec) / 1000l); - printf("Total running milliseconds: %ld\n", - 1000l * (tv6.tv_sec - tv0.tv_sec) + - (tv6.tv_usec - tv0.tv_usec) / 1000l); -#endif /* not NO_TIMER */ - - statistics(&m, &b); - } - -#ifndef REDUCED - if (b.docheck) { - checkmesh(&m, &b); - checkdelaunay(&m, &b); - } -#endif /* not REDUCED */ - - triangledeinit(&m, &b); -#ifndef TRILIBRARY - return 0; -#endif /* not TRILIBRARY */ -} diff --git a/src/modules/TriangleInterface/src/triangle.h b/src/modules/TriangleInterface/src/triangle.h deleted file mode 100644 index 1d80a5e71..000000000 --- a/src/modules/TriangleInterface/src/triangle.h +++ /dev/null @@ -1,297 +0,0 @@ -/*****************************************************************************/ -/* */ -/* (triangle.h) */ -/* */ -/* Include file for programs that call Triangle. */ -/* */ -/* Accompanies Triangle Version 1.6 */ -/* July 28, 2005 */ -/* */ -/* Copyright 1996, 2005 */ -/* Jonathan Richard Shewchuk */ -/* 2360 Woolsey #H */ -/* Berkeley, California 94705-1927 */ -/* jrs@cs.berkeley.edu */ -/* */ -/*****************************************************************************/ - -/*****************************************************************************/ -/* */ -/* How to call Triangle from another program */ -/* */ -/* */ -/* If you haven't read Triangle's instructions (run "triangle -h" to read */ -/* them), you won't understand what follows. */ -/* */ -/* Triangle must be compiled into an object file (triangle.o) with the */ -/* TRILIBRARY symbol defined (generally by using the -DTRILIBRARY compiler */ -/* switch). The makefile included with Triangle will do this for you if */ -/* you run "make trilibrary". The resulting object file can be called via */ -/* the procedure triangulate(). */ -/* */ -/* If the size of the object file is important to you, you may wish to */ -/* generate a reduced version of triangle.o. The REDUCED symbol gets rid */ -/* of all features that are primarily of research interest. Specifically, */ -/* the -DREDUCED switch eliminates Triangle's -i, -F, -s, and -C switches. */ -/* The CDT_ONLY symbol gets rid of all meshing algorithms above and beyond */ -/* constrained Delaunay triangulation. Specifically, the -DCDT_ONLY switch */ -/* eliminates Triangle's -r, -q, -a, -u, -D, -Y, -S, and -s switches. */ -/* */ -/* IMPORTANT: These definitions (TRILIBRARY, REDUCED, CDT_ONLY) must be */ -/* made in the makefile or in triangle.c itself. Putting these definitions */ -/* in this file (triangle.h) will not create the desired effect. */ -/* */ -/* */ -/* The calling convention for triangulate() follows. */ -/* */ -/* void triangulate(triswitches, in, out, vorout) */ -/* char *triswitches; */ -/* struct triangulateio *in; */ -/* struct triangulateio *out; */ -/* struct triangulateio *vorout; */ -/* */ -/* `triswitches' is a string containing the command line switches you wish */ -/* to invoke. No initial dash is required. Some suggestions: */ -/* */ -/* - You'll probably find it convenient to use the `z' switch so that */ -/* points (and other items) are numbered from zero. This simplifies */ -/* indexing, because the first item of any type always starts at index */ -/* [0] of the corresponding array, whether that item's number is zero or */ -/* one. */ -/* - You'll probably want to use the `Q' (quiet) switch in your final code, */ -/* but you can take advantage of Triangle's printed output (including the */ -/* `V' switch) while debugging. */ -/* - If you are not using the `q', `a', `u', `D', `j', or `s' switches, */ -/* then the output points will be identical to the input points, except */ -/* possibly for the boundary markers. If you don't need the boundary */ -/* markers, you should use the `N' (no nodes output) switch to save */ -/* memory. (If you do need boundary markers, but need to save memory, a */ -/* good nasty trick is to set out->pointlist equal to in->pointlist */ -/* before calling triangulate(), so that Triangle overwrites the input */ -/* points with identical copies.) */ -/* - The `I' (no iteration numbers) and `g' (.off file output) switches */ -/* have no effect when Triangle is compiled with TRILIBRARY defined. */ -/* */ -/* `in', `out', and `vorout' are descriptions of the input, the output, */ -/* and the Voronoi output. If the `v' (Voronoi output) switch is not used, */ -/* `vorout' may be NULL. `in' and `out' may never be NULL. */ -/* */ -/* Certain fields of the input and output structures must be initialized, */ -/* as described below. */ -/* */ -/*****************************************************************************/ - -/*****************************************************************************/ -/* */ -/* The `triangulateio' structure. */ -/* */ -/* Used to pass data into and out of the triangulate() procedure. */ -/* */ -/* */ -/* Arrays are used to store points, triangles, markers, and so forth. In */ -/* all cases, the first item in any array is stored starting at index [0]. */ -/* However, that item is item number `1' unless the `z' switch is used, in */ -/* which case it is item number `0'. Hence, you may find it easier to */ -/* index points (and triangles in the neighbor list) if you use the `z' */ -/* switch. Unless, of course, you're calling Triangle from a Fortran */ -/* program. */ -/* */ -/* Description of fields (except the `numberof' fields, which are obvious): */ -/* */ -/* `pointlist': An array of point coordinates. The first point's x */ -/* coordinate is at index [0] and its y coordinate at index [1], followed */ -/* by the coordinates of the remaining points. Each point occupies two */ -/* REALs. */ -/* `pointattributelist': An array of point attributes. Each point's */ -/* attributes occupy `numberofpointattributes' REALs. */ -/* `pointmarkerlist': An array of point markers; one int per point. */ -/* */ -/* `trianglelist': An array of triangle corners. The first triangle's */ -/* first corner is at index [0], followed by its other two corners in */ -/* counterclockwise order, followed by any other nodes if the triangle */ -/* represents a nonlinear element. Each triangle occupies */ -/* `numberofcorners' ints. */ -/* `triangleattributelist': An array of triangle attributes. Each */ -/* triangle's attributes occupy `numberoftriangleattributes' REALs. */ -/* `trianglearealist': An array of triangle area constraints; one REAL per */ -/* triangle. Input only. */ -/* `neighborlist': An array of triangle neighbors; three ints per */ -/* triangle. Output only. */ -/* */ -/* `segmentlist': An array of segment endpoints. The first segment's */ -/* endpoints are at indices [0] and [1], followed by the remaining */ -/* segments. Two ints per segment. */ -/* `segmentmarkerlist': An array of segment markers; one int per segment. */ -/* */ -/* `holelist': An array of holes. The first hole's x and y coordinates */ -/* are at indices [0] and [1], followed by the remaining holes. Two */ -/* REALs per hole. Input only, although the pointer is copied to the */ -/* output structure for your convenience. */ -/* */ -/* `regionlist': An array of regional attributes and area constraints. */ -/* The first constraint's x and y coordinates are at indices [0] and [1], */ -/* followed by the regional attribute at index [2], followed by the */ -/* maximum area at index [3], followed by the remaining area constraints. */ -/* Four REALs per area constraint. Note that each regional attribute is */ -/* used only if you select the `A' switch, and each area constraint is */ -/* used only if you select the `a' switch (with no number following), but */ -/* omitting one of these switches does not change the memory layout. */ -/* Input only, although the pointer is copied to the output structure for */ -/* your convenience. */ -/* */ -/* `edgelist': An array of edge endpoints. The first edge's endpoints are */ -/* at indices [0] and [1], followed by the remaining edges. Two ints per */ -/* edge. Output only. */ -/* `edgemarkerlist': An array of edge markers; one int per edge. Output */ -/* only. */ -/* `normlist': An array of normal vectors, used for infinite rays in */ -/* Voronoi diagrams. The first normal vector's x and y magnitudes are */ -/* at indices [0] and [1], followed by the remaining vectors. For each */ -/* finite edge in a Voronoi diagram, the normal vector written is the */ -/* zero vector. Two REALs per edge. Output only. */ -/* */ -/* */ -/* Any input fields that Triangle will examine must be initialized. */ -/* Furthermore, for each output array that Triangle will write to, you */ -/* must either provide space by setting the appropriate pointer to point */ -/* to the space you want the data written to, or you must initialize the */ -/* pointer to NULL, which tells Triangle to allocate space for the results. */ -/* The latter option is preferable, because Triangle always knows exactly */ -/* how much space to allocate. The former option is provided mainly for */ -/* people who need to call Triangle from Fortran code, though it also makes */ -/* possible some nasty space-saving tricks, like writing the output to the */ -/* same arrays as the input. */ -/* */ -/* Triangle will not free() any input or output arrays, including those it */ -/* allocates itself; that's up to you. You should free arrays allocated by */ -/* Triangle by calling the trifree() procedure defined below. (By default, */ -/* trifree() just calls the standard free() library procedure, but */ -/* applications that call triangulate() may replace trimalloc() and */ -/* trifree() in triangle.c to use specialized memory allocators.) */ -/* */ -/* Here's a guide to help you decide which fields you must initialize */ -/* before you call triangulate(). */ -/* */ -/* `in': */ -/* */ -/* - `pointlist' must always point to a list of points; `numberofpoints' */ -/* and `numberofpointattributes' must be properly set. */ -/* `pointmarkerlist' must either be set to NULL (in which case all */ -/* markers default to zero), or must point to a list of markers. If */ -/* `numberofpointattributes' is not zero, `pointattributelist' must */ -/* point to a list of point attributes. */ -/* - If the `r' switch is used, `trianglelist' must point to a list of */ -/* triangles, and `numberoftriangles', `numberofcorners', and */ -/* `numberoftriangleattributes' must be properly set. If */ -/* `numberoftriangleattributes' is not zero, `triangleattributelist' */ -/* must point to a list of triangle attributes. If the `a' switch is */ -/* used (with no number following), `trianglearealist' must point to a */ -/* list of triangle area constraints. `neighborlist' may be ignored. */ -/* - If the `p' switch is used, `segmentlist' must point to a list of */ -/* segments, `numberofsegments' must be properly set, and */ -/* `segmentmarkerlist' must either be set to NULL (in which case all */ -/* markers default to zero), or must point to a list of markers. */ -/* - If the `p' switch is used without the `r' switch, then */ -/* `numberofholes' and `numberofregions' must be properly set. If */ -/* `numberofholes' is not zero, `holelist' must point to a list of */ -/* holes. If `numberofregions' is not zero, `regionlist' must point to */ -/* a list of region constraints. */ -/* - If the `p' switch is used, `holelist', `numberofholes', */ -/* `regionlist', and `numberofregions' is copied to `out'. (You can */ -/* nonetheless get away with not initializing them if the `r' switch is */ -/* used.) */ -/* - `edgelist', `edgemarkerlist', `normlist', and `numberofedges' may be */ -/* ignored. */ -/* */ -/* `out': */ -/* */ -/* - `pointlist' must be initialized (NULL or pointing to memory) unless */ -/* the `N' switch is used. `pointmarkerlist' must be initialized */ -/* unless the `N' or `B' switch is used. If `N' is not used and */ -/* `in->numberofpointattributes' is not zero, `pointattributelist' must */ -/* be initialized. */ -/* - `trianglelist' must be initialized unless the `E' switch is used. */ -/* `neighborlist' must be initialized if the `n' switch is used. If */ -/* the `E' switch is not used and (`in->numberofelementattributes' is */ -/* not zero or the `A' switch is used), `elementattributelist' must be */ -/* initialized. `trianglearealist' may be ignored. */ -/* - `segmentlist' must be initialized if the `p' or `c' switch is used, */ -/* and the `P' switch is not used. `segmentmarkerlist' must also be */ -/* initialized under these circumstances unless the `B' switch is used. */ -/* - `edgelist' must be initialized if the `e' switch is used. */ -/* `edgemarkerlist' must be initialized if the `e' switch is used and */ -/* the `B' switch is not. */ -/* - `holelist', `regionlist', `normlist', and all scalars may be ignored.*/ -/* */ -/* `vorout' (only needed if `v' switch is used): */ -/* */ -/* - `pointlist' must be initialized. If `in->numberofpointattributes' */ -/* is not zero, `pointattributelist' must be initialized. */ -/* `pointmarkerlist' may be ignored. */ -/* - `edgelist' and `normlist' must both be initialized. */ -/* `edgemarkerlist' may be ignored. */ -/* - Everything else may be ignored. */ -/* */ -/* After a call to triangulate(), the valid fields of `out' and `vorout' */ -/* will depend, in an obvious way, on the choice of switches used. Note */ -/* that when the `p' switch is used, the pointers `holelist' and */ -/* `regionlist' are copied from `in' to `out', but no new space is */ -/* allocated; be careful that you don't free() the same array twice. On */ -/* the other hand, Triangle will never copy the `pointlist' pointer (or any */ -/* others); new space is allocated for `out->pointlist', or if the `N' */ -/* switch is used, `out->pointlist' remains uninitialized. */ -/* */ -/* All of the meaningful `numberof' fields will be properly set; for */ -/* instance, `numberofedges' will represent the number of edges in the */ -/* triangulation whether or not the edges were written. If segments are */ -/* not used, `numberofsegments' will indicate the number of boundary edges. */ -/* */ -/*****************************************************************************/ - -#ifdef USE_Real64 -#define REAL double -#else -#define REAL float -#endif - -struct triangulateio { - REAL *pointlist; /* In / out */ - REAL *pointattributelist; /* In / out */ - int *pointmarkerlist; /* In / out */ - int numberofpoints; /* In / out */ - int numberofpointattributes; /* In / out */ - - int *trianglelist; /* In / out */ - REAL *triangleattributelist; /* In / out */ - REAL *trianglearealist; /* In only */ - int *neighborlist; /* Out only */ - int numberoftriangles; /* In / out */ - int numberofcorners; /* In / out */ - int numberoftriangleattributes; /* In / out */ - - int *segmentlist; /* In / out */ - int *segmentmarkerlist; /* In / out */ - int numberofsegments; /* In / out */ - - REAL *holelist; /* In / pointer to array copied out */ - int numberofholes; /* In / copied out */ - - REAL *regionlist; /* In / pointer to array copied out */ - int numberofregions; /* In / copied out */ - - int *edgelist; /* Out only */ - int *edgemarkerlist; /* Not used with Voronoi diagram; out only */ - REAL *normlist; /* Used only with Voronoi diagram; out only */ - int numberofedges; /* Out only */ -}; - -#ifdef ANSI_DECLARATORS -void triangulate(char *, struct triangulateio *, struct triangulateio *, - struct triangulateio *); -void trifree(VOID *memptr); -#else /* not ANSI_DECLARATORS */ -void triangulate(); -void trifree(); -#endif /* not ANSI_DECLARATORS */ - -void report(struct triangulateio *, int, int, int, int, int, int); diff --git a/src/modules/Utility/CMakeLists.txt b/src/modules/Utility/CMakeLists.txt deleted file mode 100644 index 3428baa00..000000000 --- a/src/modules/Utility/CMakeLists.txt +++ /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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/MappingUtility.F90 - ${src_path}/BinomUtility.F90 - ${src_path}/AppendUtility.F90 - ${src_path}/ApproxUtility.F90 - ${src_path}/AssertUtility.F90 - ${src_path}/HeadUtility.F90 - ${src_path}/TailUtility.F90 - ${src_path}/SplitUtility.F90 - ${src_path}/ArangeUtility.F90 - ${src_path}/GridPointUtility.F90 - ${src_path}/OnesUtility.F90 - ${src_path}/ZerosUtility.F90 - ${src_path}/EyeUtility.F90 - ${src_path}/DiagUtility.F90 - ${src_path}/HashingUtility.F90 - ${src_path}/InputUtility.F90 - ${src_path}/InvUtility.F90 - ${src_path}/MatmulUtility.F90 - ${src_path}/ContractionUtility.F90 - ${src_path}/MiscUtility.F90 - ${src_path}/ProductUtility.F90 - ${src_path}/ReallocateUtility.F90 - ${src_path}/PartitionUtility.F90 - ${src_path}/MedianUtility.F90 - ${src_path}/SortUtility.F90 - ${src_path}/StringUtility.F90 - ${src_path}/SwapUtility.F90 - ${src_path}/ConvertUtility.F90 - ${src_path}/IntegerUtility.F90 - ${src_path}/PushPopUtility.F90 - ${src_path}/EigenUtility.F90 - ${src_path}/SymUtility.F90 - ${src_path}/TriagUtility.F90 - ${src_path}/LinearAlgebraUtility.F90 - ${src_path}/SafeSizeUtility.F90 - ${src_path}/Utility.F90) diff --git a/src/modules/Utility/src/AppendUtility.F90 b/src/modules/Utility/src/AppendUtility.F90 deleted file mode 100644 index a607a3083..000000000 --- a/src/modules/Utility/src/AppendUtility.F90 +++ /dev/null @@ -1,799 +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: 2024-04-11 -! summary: This module contains method for appending to vectors and martrix -! -!{!|page|/AppendUtility/index.md!} -! -MODULE AppendUtility - -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: ColConcat -PUBLIC :: OPERATOR(.ColConcat.) -PUBLIC :: RowConcat -PUBLIC :: OPERATOR(.RowConcat.) -PUBLIC :: Append -PUBLIC :: OPERATOR(.Append.) -PUBLIC :: Expand - -!---------------------------------------------------------------------------- -! Expand@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 July 2022 -! summary: Expand the vector -! -!# Introduction -! Expand the vector and add an element. -! -! reference -! https://github.com/jacobwilliams/fortran-csv-module/blob/master/src/ -! csv_utilities.f90 -! -!{!|page|/AppendUtility/Expand.md!} - -INTERFACE Expand - MODULE PURE SUBROUTINE expand_int8(vec, n, chunk_size, val, finished) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: vec(:) - INTEGER(I4B), INTENT(INOUT) :: n - !! counter for last element added to `vec`. - !! must be initialized to `size(vec)` - !! (or 0 if not allocated) before first call - INTEGER(I4B), INTENT(IN) :: chunk_size - !! allocate `vec` in blocks of this size (>0) - INTEGER(INT8), OPTIONAL, INTENT(IN) :: val - !! the value to add to `vec` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished - !! set to true to return `vec` - !! as its correct size (`n`) - END SUBROUTINE expand_int8 - - MODULE PURE SUBROUTINE expand_int16(vec, n, chunk_size, val, finished) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: vec(:) - INTEGER(I4B), INTENT(INOUT) :: n - !! counter for last element added to `vec`. - !! must be initialized to `size(vec)` - !! (or 0 if not allocated) before first call - INTEGER(I4B), INTENT(IN) :: chunk_size - !! allocate `vec` in blocks of this size (>0) - INTEGER(INT16), OPTIONAL, INTENT(IN) :: val - !! the value to add to `vec` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished - !! set to true to return `vec` - !! as its correct size (`n`) - END SUBROUTINE expand_int16 - - MODULE PURE SUBROUTINE expand_int32(vec, n, chunk_size, val, finished) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: vec(:) - INTEGER(I4B), INTENT(INOUT) :: n - !! counter for last element added to `vec`. - !! must be initialized to `size(vec)` - !! (or 0 if not allocated) before first call - INTEGER(I4B), INTENT(IN) :: chunk_size - !! allocate `vec` in blocks of this size (>0) - INTEGER(INT32), OPTIONAL, INTENT(IN) :: val - !! the value to add to `vec` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished - !! set to true to return `vec` - !! as its correct size (`n`) - END SUBROUTINE expand_int32 - - MODULE PURE SUBROUTINE expand_int64(vec, n, chunk_size, val, finished) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: vec(:) - INTEGER(I4B), INTENT(INOUT) :: n - !! counter for last element added to `vec`. - !! must be initialized to `size(vec)` - !! (or 0 if not allocated) before first call - INTEGER(I4B), INTENT(IN) :: chunk_size - !! allocate `vec` in blocks of this size (>0) - INTEGER(INT64), OPTIONAL, INTENT(IN) :: val - !! the value to add to `vec` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished - !! set to true to return `vec` - !! as its correct size (`n`) - END SUBROUTINE expand_int64 -END INTERFACE Expand - -!---------------------------------------------------------------------------- -! Expand@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 July 2022 -! summary: Expand the real vector - -INTERFACE Expand - MODULE PURE SUBROUTINE expand_real32(vec, n, chunk_size, val, finished) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: vec(:) - INTEGER(I4B), INTENT(INOUT) :: n - !! counter for last element added to `vec`. - !! must be initialized to `size(vec)` - !! (or 0 if not allocated) before first call - INTEGER(I4B), INTENT(IN) :: chunk_size - !! allocate `vec` in blocks of this size (>0) - REAL(REAL32), OPTIONAL, INTENT(IN) :: val - !! the value to add to `vec` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished - !! set to true to return `vec` - !! as its correct size (`n`) - END SUBROUTINE expand_real32 - - MODULE PURE SUBROUTINE expand_real64(vec, n, chunk_size, val, finished) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: vec(:) - INTEGER(I4B), INTENT(INOUT) :: n - !! counter for last element added to `vec`. - !! must be initialized to `size(vec)` - !! (or 0 if not allocated) before first call - INTEGER(I4B), INTENT(IN) :: chunk_size - !! allocate `vec` in blocks of this size (>0) - REAL(REAL64), OPTIONAL, INTENT(IN) :: val - !! the value to add to `vec` - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished - !! set to true to return `vec` - !! as its correct size (`n`) - END SUBROUTINE expand_real64 -END INTERFACE Expand - -!---------------------------------------------------------------------------- -! Append@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Append a scalar or vector to vector -! -!# Introduction -! -!- Append a scalar integer to an integer vector -!- Append a integer vector and scalar to an integer vector -!- Append a scalar real to an real vector -!- Append a real vector to a real vector - -INTERFACE Append - ! Append a scalar int to a vector of int - MODULE PURE SUBROUTINE Append_1a(A, ENTRY) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), INTENT(IN) :: ENTRY - END SUBROUTINE Append_1a - - ! Append a scalar real to a vector of real - MODULE PURE SUBROUTINE Append_1b(A, ENTRY) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) - REAL(DFP), INTENT(IN) :: ENTRY - END SUBROUTINE Append_1b - - ! Append a scalar and vector int to a vector of int - MODULE PURE SUBROUTINE Append_1c(C, A, B) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) - INTEGER(I4B), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: B - END SUBROUTINE Append_1c - - ! Append a scalar and vector real to a vector of real - MODULE PURE SUBROUTINE Append_1d(C, A, B) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), INTENT(IN) :: B - END SUBROUTINE Append_1d -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Append two vectors of real or int -! -!# Introduction -! -!- Append a vector of int to another vector of int -!- Append a vector of real to another vector of real -!- Append two vectors of int to another vector of int -!- Append two vector of real to another vector of real - -INTERFACE Append - MODULE PURE SUBROUTINE Append_2a(A, ENTRY) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), INTENT(IN) :: ENTRY(:) - END SUBROUTINE Append_2a - - MODULE PURE SUBROUTINE Append_2b(A, ENTRY) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) - REAL(DFP), INTENT(IN) :: ENTRY(:) - END SUBROUTINE Append_2b - - MODULE PURE SUBROUTINE Append_2c(C, A, B) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) - INTEGER(I4B), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: B(:) - END SUBROUTINE Append_2c - - MODULE PURE SUBROUTINE Append_2d(C, A, B) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), INTENT(IN) :: B(:) - END SUBROUTINE Append_2d - - MODULE PURE SUBROUTINE Append_2e(D, C, A, B) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: D(:) - INTEGER(I4B), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: B(:) - INTEGER(I4B), INTENT(IN) :: C(:) - END SUBROUTINE Append_2e - - MODULE PURE SUBROUTINE Append_2f(D, C, A, B) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: D(:) - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), INTENT(IN) :: B(:) - REAL(DFP), INTENT(IN) :: C(:) - END SUBROUTINE Append_2f - -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Masked append -! -!# Introduction -! -!- Append a scalar integer to a vector of int -!- Append a scalar real to a vector of reals -!- Append a scalar and vector of int to another vector of int -!- Append a scalar and vector real to another vector of real - -INTERFACE Append - MODULE PURE SUBROUTINE Append_3a(A, ENTRY, mask) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), INTENT(IN) :: ENTRY - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE Append_3a - - MODULE PURE SUBROUTINE Append_3b(A, ENTRY, mask) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) - REAL(DFP), INTENT(IN) :: ENTRY - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE Append_3b - - MODULE PURE SUBROUTINE Append_3c(C, A, B, mask) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) - INTEGER(I4B), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: B - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE Append_3c - - MODULE PURE SUBROUTINE Append_3d(C, A, B, mask) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), INTENT(IN) :: B - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE Append_3d -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Masked append two vectors to another vector of int/real -! -!# Introduction -! -!- Append a vector of int to another vector of int -!- Append a vector of real to another vector of real - -INTERFACE Append - MODULE PURE SUBROUTINE Append_4a(A, ENTRY, mask) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), INTENT(IN) :: ENTRY(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE Append_4a - - MODULE PURE SUBROUTINE Append_4b(A, ENTRY, mask) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) - REAL(DFP), INTENT(IN) :: ENTRY(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE Append_4b - - MODULE PURE SUBROUTINE Append_4c(C, A, B, mask) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) - INTEGER(I4B), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: B(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE Append_4c - - MODULE PURE SUBROUTINE Append_4d(C, A, B, mask) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), INTENT(IN) :: B(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE Append_4d -END INTERFACE Append - -!---------------------------------------------------------------------------- -! Append@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Append a scalar INTEGER to INTEGER vec tor - -INTERFACE OPERATOR(.Append.) - MODULE PURE FUNCTION func_Append_1a(A, ENTRY) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: ENTRY - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION func_Append_1a - - MODULE PURE FUNCTION func_Append_1b(A, ENTRY) RESULT(ans) - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), INTENT(IN) :: ENTRY - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION func_Append_1b -END INTERFACE - -!---------------------------------------------------------------------------- -! Append@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Append two vectors of INTEGER - -INTERFACE OPERATOR(.APPEND.) - MODULE PURE FUNCTION func_Append_2a(A, ENTRY) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: A(:) - INTEGER(I4B), INTENT(IN) :: ENTRY(:) - INTEGER(I4B), ALLOCATABLE :: ans(:) - END FUNCTION func_Append_2a - - MODULE PURE FUNCTION func_Append_2b(A, ENTRY) RESULT(ans) - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), INTENT(IN) :: ENTRY(:) - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION func_Append_2b - -END INTERFACE - -!---------------------------------------------------------------------------- -! ColConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat columns of two vectors - -INTERFACE ColConcat - MODULE PURE FUNCTION colConcat_1a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:) - REAL(REAL32), INTENT(IN) :: b(:) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_1a - - MODULE PURE FUNCTION colConcat_1b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:) - REAL(REAL64), INTENT(IN) :: b(:) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_1b - - MODULE PURE FUNCTION colConcat_1c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_1c - - MODULE PURE FUNCTION colConcat_1d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_1d - - MODULE PURE FUNCTION colConcat_1e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_1e - - MODULE PURE FUNCTION colConcat_1f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_1f -END INTERFACE ColConcat - -INTERFACE OPERATOR(.ColConcat.) - MODULE PROCEDURE colConcat_1a, colConcat_1b, colConcat_1c, & - & colConcat_1d, colConcat_1e, colConcat_1f -END INTERFACE - -!---------------------------------------------------------------------------- -! ColConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat columns of a matrix and a vector - -INTERFACE ColConcat - MODULE PURE FUNCTION colConcat_2a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:, :) - REAL(REAL32), INTENT(IN) :: b(:) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_2a - - MODULE PURE FUNCTION colConcat_2b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:, :) - REAL(REAL64), INTENT(IN) :: b(:) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_2b - - MODULE PURE FUNCTION colConcat_2c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:, :) - INTEGER(INT64), INTENT(IN) :: b(:) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_2c - - MODULE PURE FUNCTION colConcat_2d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:, :) - INTEGER(INT32), INTENT(IN) :: b(:) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_2d - - MODULE PURE FUNCTION colConcat_2e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:, :) - INTEGER(INT16), INTENT(IN) :: b(:) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_2e - - MODULE PURE FUNCTION colConcat_2f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:, :) - INTEGER(INT8), INTENT(IN) :: b(:) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_2f -END INTERFACE ColConcat - -INTERFACE OPERATOR(.ColConcat.) - MODULE PROCEDURE colConcat_2a, colConcat_2b, colConcat_2c, & - & colConcat_2d, colConcat_2e, colConcat_2f -END INTERFACE - -!---------------------------------------------------------------------------- -! ColConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat columns of rank1 and rank2 array - -INTERFACE ColConcat - MODULE PURE FUNCTION colConcat_3a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:) - REAL(REAL32), INTENT(IN) :: b(:, :) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_3a - - MODULE PURE FUNCTION colConcat_3b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:) - REAL(REAL64), INTENT(IN) :: b(:, :) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_3b - - MODULE PURE FUNCTION colConcat_3c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:, :) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_3c - - MODULE PURE FUNCTION colConcat_3d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:, :) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_3d - - MODULE PURE FUNCTION colConcat_3e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:, :) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_3e - - MODULE PURE FUNCTION colConcat_3f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:, :) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_3f -END INTERFACE ColConcat - -INTERFACE OPERATOR(.ColConcat.) - MODULE PROCEDURE colConcat_3a, colConcat_3b, colConcat_3c, & - & colConcat_3d, colConcat_3e, colConcat_3f -END INTERFACE - -!---------------------------------------------------------------------------- -! ColConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat columns of rank2 and rank2 array - -INTERFACE ColConcat - MODULE PURE FUNCTION colConcat_4a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:, :) - REAL(REAL32), INTENT(IN) :: b(:, :) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_4a - - MODULE PURE FUNCTION colConcat_4b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:, :) - REAL(REAL64), INTENT(IN) :: b(:, :) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_4b - - MODULE PURE FUNCTION colConcat_4c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:, :) - INTEGER(INT64), INTENT(IN) :: b(:, :) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_4c - - MODULE PURE FUNCTION colConcat_4d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:, :) - INTEGER(INT32), INTENT(IN) :: b(:, :) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_4d - - MODULE PURE FUNCTION colConcat_4e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:, :) - INTEGER(INT16), INTENT(IN) :: b(:, :) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_4e - - MODULE PURE FUNCTION colConcat_4f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:, :) - INTEGER(INT8), INTENT(IN) :: b(:, :) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION colConcat_4f -END INTERFACE ColConcat - -INTERFACE OPERATOR(.ColConcat.) - MODULE PROCEDURE colConcat_4a, colConcat_4b, colConcat_4c, & - & colConcat_4d, colConcat_4e, colConcat_4f -END INTERFACE - -!---------------------------------------------------------------------------- -! ColConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat rows of two vectors - -INTERFACE RowConcat - MODULE PURE FUNCTION rowConcat_1a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:) - REAL(REAL32), INTENT(IN) :: b(:) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_1a - - MODULE PURE FUNCTION rowConcat_1b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:) - REAL(REAL64), INTENT(IN) :: b(:) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_1b - - MODULE PURE FUNCTION rowConcat_1c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_1c - - MODULE PURE FUNCTION rowConcat_1d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_1d - - MODULE PURE FUNCTION rowConcat_1e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_1e - - MODULE PURE FUNCTION rowConcat_1f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_1f -END INTERFACE RowConcat - -INTERFACE OPERATOR(.rowConcat.) - MODULE PROCEDURE rowConcat_1a, rowConcat_1b, rowConcat_1c, & - & rowConcat_1d, rowConcat_1e, rowConcat_1f -END INTERFACE - -!---------------------------------------------------------------------------- -! rowConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat rows of a matrix and a vector - -INTERFACE RowConcat - MODULE PURE FUNCTION rowConcat_2a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:, :) - REAL(REAL32), INTENT(IN) :: b(:) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_2a - - MODULE PURE FUNCTION rowConcat_2b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:, :) - REAL(REAL64), INTENT(IN) :: b(:) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_2b - - MODULE PURE FUNCTION rowConcat_2c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:, :) - INTEGER(INT64), INTENT(IN) :: b(:) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_2c - - MODULE PURE FUNCTION rowConcat_2d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:, :) - INTEGER(INT32), INTENT(IN) :: b(:) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_2d - - MODULE PURE FUNCTION rowConcat_2e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:, :) - INTEGER(INT16), INTENT(IN) :: b(:) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_2e - - MODULE PURE FUNCTION rowConcat_2f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:, :) - INTEGER(INT8), INTENT(IN) :: b(:) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_2f -END INTERFACE RowConcat - -INTERFACE OPERATOR(.rowConcat.) - MODULE PROCEDURE rowConcat_2a, rowConcat_2b, rowConcat_2c, & - & rowConcat_2d, rowConcat_2e, rowConcat_2f -END INTERFACE - -!---------------------------------------------------------------------------- -! rowConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat rows of rank1 and rank2 array - -INTERFACE RowConcat - MODULE PURE FUNCTION rowConcat_3a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:) - REAL(REAL32), INTENT(IN) :: b(:, :) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_3a - - MODULE PURE FUNCTION rowConcat_3b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:) - REAL(REAL64), INTENT(IN) :: b(:, :) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_3b - - MODULE PURE FUNCTION rowConcat_3c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:, :) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_3c - - MODULE PURE FUNCTION rowConcat_3d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:, :) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_3d - - MODULE PURE FUNCTION rowConcat_3e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:, :) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_3e - - MODULE PURE FUNCTION rowConcat_3f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:, :) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_3f -END INTERFACE RowConcat - -INTERFACE OPERATOR(.rowConcat.) - MODULE PROCEDURE rowConcat_3a, rowConcat_3b, rowConcat_3c, & - & rowConcat_3d, rowConcat_3e, rowConcat_3f -END INTERFACE - -!---------------------------------------------------------------------------- -! rowConcat@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-24 -! update: 2021-11-24 -! summary: Concat rows of rank2 and rank2 array - -INTERFACE RowConcat - MODULE PURE FUNCTION rowConcat_4a(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a(:, :) - REAL(REAL32), INTENT(IN) :: b(:, :) - REAL(REAL32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_4a - - MODULE PURE FUNCTION rowConcat_4b(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a(:, :) - REAL(REAL64), INTENT(IN) :: b(:, :) - REAL(REAL64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_4b - - MODULE PURE FUNCTION rowConcat_4c(a, b) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: a(:, :) - INTEGER(INT64), INTENT(IN) :: b(:, :) - INTEGER(INT64), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_4c - - MODULE PURE FUNCTION rowConcat_4d(a, b) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: a(:, :) - INTEGER(INT32), INTENT(IN) :: b(:, :) - INTEGER(INT32), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_4d - - MODULE PURE FUNCTION rowConcat_4e(a, b) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: a(:, :) - INTEGER(INT16), INTENT(IN) :: b(:, :) - INTEGER(INT16), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_4e - - MODULE PURE FUNCTION rowConcat_4f(a, b) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: a(:, :) - INTEGER(INT8), INTENT(IN) :: b(:, :) - INTEGER(INT8), ALLOCATABLE :: ans(:, :) - END FUNCTION rowConcat_4f -END INTERFACE RowConcat - -INTERFACE OPERATOR(.rowConcat.) - MODULE PROCEDURE rowConcat_4a, rowConcat_4b, rowConcat_4c, & - & rowConcat_4d, rowConcat_4e, rowConcat_4f -END INTERFACE - -END MODULE AppendUtility diff --git a/src/modules/Utility/src/ApproxUtility.F90 b/src/modules/Utility/src/ApproxUtility.F90 deleted file mode 100644 index 465dd2fbf..000000000 --- a/src/modules/Utility/src/ApproxUtility.F90 +++ /dev/null @@ -1,385 +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 ApproxUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: OPERATOR(.APPROXEQ.) -PUBLIC :: OPERATOR(.APPROXEQA.) -PUBLIC :: OPERATOR(.APPROXEQR.) -PUBLIC :: OPERATOR(.APPROXEQF.) -PUBLIC :: OPERATOR(.APPROXLE.) -PUBLIC :: OPERATOR(.APPROXGE.) -PUBLIC :: SOFTEQ -PUBLIC :: SOFTEQR -PUBLIC :: SOFTLE -PUBLIC :: SOFTLT -PUBLIC :: SOFTGE -PUBLIC :: SOFTGT -PUBLIC :: OPERATOR(==) -PUBLIC :: OPERATOR(/=) -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: isNumeric - -!---------------------------------------------------------------------------- -! APPROXEQ@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Apr 2021 -! summary: returns true if a and b are approximately equal -! -!# Introduction -! -! This routine just does a simple absolute comparison using an epsilon -! that is a compile time constant. -! It should be used whenever possible because it has -! the least overhead. -! However, it is not appropriate to use when a and b -! are either very large or very small. - -INTERFACE OPERATOR(.APPROXEQ.) - MODULE PURE ELEMENTAL FUNCTION approxeq_1(a, b) RESULT(ans) - REAL(REAL64), INTENT(IN) :: a, b - LOGICAL(LGT) :: ans - END FUNCTION approxeq_1 -END INTERFACE OPERATOR(.APPROXEQ.) - -INTERFACE OPERATOR(.APPROXEQ.) - MODULE PURE ELEMENTAL FUNCTION approxeq_2(a, b) RESULT(ans) - REAL(REAL32), INTENT(IN) :: a, b - LOGICAL(LGT) :: ans - END FUNCTION approxeq_2 -END INTERFACE OPERATOR(.APPROXEQ.) - -INTERFACE OPERATOR(.APPROXEQA.) - MODULE PROCEDURE approxeq_1, approxeq_2 -END INTERFACE - -!---------------------------------------------------------------------------- -! APPROXR@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: returns bool logical indicating if a and b are approximately equal -! -!# Introduction -! This performs a relative comparison by scaling the default epsilon value to -! the size of the larger of the two. It should be used when c and b are of -! the same magnitude and very large or very small. If either c a or c b is -! zero (exactly) then this routine is equivalent to an absolute comparison. - -INTERFACE OPERATOR(.APPROXEQR.) - MODULE PURE ELEMENTAL FUNCTION approxeqr_1(a, b) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: a, b - LOGICAL(LGT) :: Ans - END FUNCTION approxeqr_1 - - MODULE PURE ELEMENTAL FUNCTION approxeqr_2(a, b) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: a, b - LOGICAL(LGT) :: Ans - END FUNCTION approxeqr_2 -END INTERFACE OPERATOR(.APPROXEQR.) - -!---------------------------------------------------------------------------- -! APPROXEQF@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Apr 2021 -! summary: returns bool logical indicating if a and b are approximately equal -! -!# Introduction -! This performs a comparison of the binary representation of the two reals -! to compare the binary units in the last place (ULP). If the two reals differ -! on the floating point number line by 10 or less representable floating point -! reals then they are considered equal. In theory, this is the most -! appropriate comparison to use, but will break down near zero. -! -! - TODO change the name to approxeqf_1 -! - TODO add support for the real32 and real64 - -INTERFACE OPERATOR(.APPROXEQF.) - MODULE PURE ELEMENTAL FUNCTION approxeq_ulp_real(a, b) RESULT(Ans) - REAL(DFP), INTENT(IN) :: a, b - LOGICAL(LGT) :: Ans - END FUNCTION approxeq_ulp_real -END INTERFACE - -!---------------------------------------------------------------------------- -! APPROXLE@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 Apr 2021 -! summary: Defines the operator .APPROXLE. - -INTERFACE OPERATOR(.APPROXLE.) - MODULE PURE ELEMENTAL FUNCTION approxle_1(r1, r2) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - LOGICAL(LGT) :: Ans - END FUNCTION approxle_1 - - MODULE PURE ELEMENTAL FUNCTION approxle_2(r1, r2) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - LOGICAL(LGT) :: Ans - END FUNCTION approxle_2 -END INTERFACE - -!---------------------------------------------------------------------------- -! APPROXGE@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Defines the operation when comparing two single precision reals - -INTERFACE OPERATOR(.APPROXGE.) - MODULE PURE ELEMENTAL FUNCTION approxge_1(r1, r2) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - LOGICAL(LGT) :: Ans - END FUNCTION approxge_1 - - MODULE PURE ELEMENTAL FUNCTION approxge_2(r1, r2) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - LOGICAL(LGT) :: Ans - END FUNCTION approxge_2 -END INTERFACE OPERATOR(.APPROXGE.) - -!---------------------------------------------------------------------------- -! SOFTEQ@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Defines the operator SOFTEQ - -INTERFACE softeq - MODULE PURE ELEMENTAL FUNCTION softeq_1(r1, r2, tol) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - REAL(REAL32), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softeq_1 - - MODULE PURE ELEMENTAL FUNCTION softeq_2(r1, r2, tol) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - REAL(REAL64), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softeq_2 -END INTERFACE softeq - -!---------------------------------------------------------------------------- -! SOFTEQR@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Defines the operator SOFTEQR - -INTERFACE SOFTEQR - MODULE PURE ELEMENTAL FUNCTION softeqr_1(r1, r2, tol) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - REAL(REAL32), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softeqr_1 - - MODULE PURE ELEMENTAL FUNCTION softeqr_2(r1, r2, tol) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - REAL(REAL64), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softeqr_2 -END INTERFACE SOFTEQR - -!---------------------------------------------------------------------------- -! SOFTLE@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: SOFTLE - -INTERFACE SOFTLE - MODULE PURE ELEMENTAL FUNCTION softle_1(r1, r2, tol) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - REAL(REAL32), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softle_1 - - MODULE PURE ELEMENTAL FUNCTION softle_2(r1, r2, tol) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - REAL(REAL64), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softle_2 -END INTERFACE SOFTLE - -!---------------------------------------------------------------------------- -! SOFTLT@ApproxMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Defines the operation for SOFTLT - -INTERFACE SOFTLT - MODULE PURE ELEMENTAL FUNCTION softlt_1(r1, r2, tol) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - REAL(REAL32), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softlt_1 - - MODULE PURE ELEMENTAL FUNCTION softlt_2(r1, r2, tol) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - REAL(REAL64), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softlt_2 -END INTERFACE SOFTLT - -!---------------------------------------------------------------------------- -! SOFTGE@ApproxMethods -!---------------------------------------------------------------------------- - -INTERFACE SOFTGE - MODULE PURE ELEMENTAL FUNCTION softge_1(r1, r2, tol) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - REAL(REAL32), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softge_1 - - MODULE PURE ELEMENTAL FUNCTION softge_2(r1, r2, tol) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - REAL(REAL64), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softge_2 -END INTERFACE SOFTGE - -!---------------------------------------------------------------------------- -! SOFTGT@ApproxMethods -!---------------------------------------------------------------------------- - -INTERFACE SOFTGT - MODULE PURE ELEMENTAL FUNCTION softgt_1(r1, r2, tol) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: r1 - REAL(REAL32), INTENT(IN) :: r2 - REAL(REAL32), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softgt_1 - - MODULE PURE ELEMENTAL FUNCTION softgt_2(r1, r2, tol) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: r1 - REAL(REAL64), INTENT(IN) :: r2 - REAL(REAL64), INTENT(IN) :: tol - LOGICAL(LGT) :: Ans - END FUNCTION softgt_2 -END INTERFACE SOFTGT - -!---------------------------------------------------------------------------- -! EQ@ApproxMethods -!---------------------------------------------------------------------------- - -INTERFACE OPERATOR(==) - MODULE PURE ELEMENTAL FUNCTION equalto_logical(l1, l2) RESULT(Ans) - LOGICAL(LGT), INTENT(IN) :: l1 - LOGICAL(LGT), INTENT(IN) :: l2 - LOGICAL(LGT) :: Ans - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! EQ@ApproxMethods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE ELEMENTAL FUNCTION notequalto_logical(l1, l2) RESULT(Ans) - LOGICAL(LGT), INTENT(IN) :: l1 - LOGICAL(LGT), INTENT(IN) :: l2 - LOGICAL(LGT) :: Ans - END FUNCTION -END INTERFACE - -INTERFACE OPERATOR(/=) - MODULE PROCEDURE notequalto_logical -END INTERFACE - -!---------------------------------------------------------------------------- -! ASSIGN@ApproxMethods -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_int8(i, c) - INTEGER(INT8), INTENT(OUT) :: i - CHARACTER(*), INTENT(IN) :: c - END SUBROUTINE assign_char_to_int8 - - MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Int16(i, c) - INTEGER(INT16), INTENT(OUT) :: i - CHARACTER(*), INTENT(IN) :: c - END SUBROUTINE assign_char_to_Int16 - - MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Int32(i, c) - INTEGER(INT32), INTENT(OUT) :: i - CHARACTER(*), INTENT(IN) :: c - END SUBROUTINE assign_char_to_Int32 - - MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Int64(i, c) - INTEGER(INT64), INTENT(OUT) :: i - CHARACTER(*), INTENT(IN) :: c - END SUBROUTINE assign_char_to_Int64 - - MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Real32(s, c) - REAL(REAL32), INTENT(OUT) :: s - CHARACTER(*), INTENT(IN) :: c - END SUBROUTINE assign_char_to_Real32 - - MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Real64(s, c) - REAL(REAL64), INTENT(OUT) :: s - CHARACTER(*), INTENT(IN) :: c - END SUBROUTINE assign_char_to_Real64 - - MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_bool(b, c) - LOGICAL(LGT), INTENT(OUT) :: b - CHARACTER(*), INTENT(IN) :: c - END SUBROUTINE assign_char_to_bool -END INTERFACE - -!---------------------------------------------------------------------------- -! @ApproxMethods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION isNumeric(char_str) RESULT(bool) - CHARACTER(*), INTENT(IN) :: char_str - LOGICAL(LGT) :: bool - END FUNCTION -END INTERFACE - -END MODULE ApproxUtility diff --git a/src/modules/Utility/src/ArangeUtility.F90 b/src/modules/Utility/src/ArangeUtility.F90 deleted file mode 100644 index be366b0ca..000000000 --- a/src/modules/Utility/src/ArangeUtility.F90 +++ /dev/null @@ -1,115 +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 ArangeUtility -USE GlobalData -IMPLICIT NONE -PUBLIC :: arange - -!---------------------------------------------------------------------------- -! arange@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: Returns a vector of reals given `start`, `end`, and `increment` -! values. - -INTERFACE arange - MODULE PURE FUNCTION arange_Real64(istart, iend, increment) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: istart - !! Start value of the array - REAL(REAL64), INTENT(IN) :: iend - !! End value of the array - REAL(REAL64), INTENT(IN), OPTIONAL :: increment - !! Array increment - REAL(REAL64), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION arange_Real64 -END INTERFACE arange - -!---------------------------------------------------------------------------- -! arange@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: Returns a vector of reals given `start`, `end`, and `increment` -! values. - -INTERFACE arange - MODULE PURE FUNCTION arange_Real32(istart, iend, increment) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: istart - !! Start value of the array - REAL(REAL32), INTENT(IN) :: iend - !! End value of the array - REAL(REAL32), INTENT(IN), OPTIONAL :: increment - !! Array increment - REAL(REAL32), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION arange_Real32 -END INTERFACE arange - -!---------------------------------------------------------------------------- -! arange@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: Returns a vector of integer -! -!# Introduction -! Returns an array of integers given `istart`, `iend`, and -! `increment` values. Default value of increment is 1 -! This function belongs to the generic function [[Utility:arange]] -! -!### Usage -! -!```fortran -! arange(1,10,1) -! arange(1,10,2) -!``` - -INTERFACE arange - MODULE PURE FUNCTION arange_Int8(istart, iend, increment) RESULT(Ans) - INTEGER(Int8), INTENT(IN) :: istart - INTEGER(Int8), INTENT(IN) :: iend - INTEGER(Int8), INTENT(IN), OPTIONAL :: increment - INTEGER(Int8), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION arange_Int8 - - MODULE PURE FUNCTION arange_Int16(istart, iend, increment) RESULT(Ans) - INTEGER(Int16), INTENT(IN) :: istart - INTEGER(Int16), INTENT(IN) :: iend - INTEGER(Int16), INTENT(IN), OPTIONAL :: increment - INTEGER(Int16), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION arange_Int16 - - MODULE PURE FUNCTION arange_Int32(istart, iend, increment) RESULT(Ans) - INTEGER(Int32), INTENT(IN) :: istart - INTEGER(Int32), INTENT(IN) :: iend - INTEGER(Int32), INTENT(IN), OPTIONAL :: increment - INTEGER(Int32), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION arange_Int32 - - MODULE PURE FUNCTION arange_Int64(istart, iend, increment) RESULT(Ans) - INTEGER(Int64), INTENT(IN) :: istart - INTEGER(Int64), INTENT(IN) :: iend - INTEGER(Int64), INTENT(IN), OPTIONAL :: increment - INTEGER(Int64), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION arange_Int64 -END INTERFACE arange - -END MODULE ArangeUtility diff --git a/src/modules/Utility/src/AssertUtility.F90 b/src/modules/Utility/src/AssertUtility.F90 deleted file mode 100644 index b2d673b79..000000000 --- a/src/modules/Utility/src/AssertUtility.F90 +++ /dev/null @@ -1,146 +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 AssertUtility -USE GlobalData, ONLY: I4B, DFP -IMPLICIT NONE -PRIVATE -PUBLIC :: ASSERT -PUBLIC :: ASSERT_EQ - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT_EQ - MODULE FUNCTION assert_eq2(n1, n2, string) - INTEGER(I4B), INTENT(IN) :: n1, n2 - CHARACTER(*), INTENT(IN) :: string - INTEGER(I4B) :: assert_eq2 - END FUNCTION -END INTERFACE ASSERT_EQ - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT_EQ - MODULE FUNCTION assert_eq3(n1, n2, n3, string) - INTEGER(I4B), INTENT(IN) :: n1, n2, n3 - CHARACTER(*), INTENT(IN) :: string - INTEGER(I4B) :: assert_eq3 - END FUNCTION -END INTERFACE ASSERT_EQ - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT_EQ - MODULE FUNCTION assert_eq4(n1, n2, n3, n4, string) - INTEGER(I4B), INTENT(IN) :: n1, n2, n3, n4 - CHARACTER(*), INTENT(IN) :: string - INTEGER(I4B) :: assert_eq4 - END FUNCTION -END INTERFACE ASSERT_EQ - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT_EQ - MODULE FUNCTION assert_eqn(nn, string) - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn - CHARACTER(*), INTENT(IN) :: string - INTEGER(I4B) :: assert_eqn - END FUNCTION -END INTERFACE ASSERT_EQ - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT - MODULE SUBROUTINE assert_shape_2(Mat, s, msg, file, line, routine) - REAL(DFP), INTENT(IN) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: s(2) - INTEGER(I4B), INTENT(IN) :: line - CHARACTER(*), INTENT(IN) :: msg, file, routine - END SUBROUTINE -END INTERFACE ASSERT - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT - MODULE SUBROUTINE assert_shape_3(Mat, s, msg, file, line, routine) - REAL(DFP), INTENT(IN) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: s(3) - INTEGER(I4B), INTENT(IN) :: line - CHARACTER(*), INTENT(IN) :: msg, file, routine - END SUBROUTINE -END INTERFACE ASSERT - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT - MODULE SUBROUTINE assert_shape_4(Mat, s, msg, file, line, routine) - REAL(DFP), INTENT(IN) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(4) - INTEGER(I4B), INTENT(IN) :: line - CHARACTER(*), INTENT(IN) :: msg, file, routine - END SUBROUTINE -END INTERFACE ASSERT - -!---------------------------------------------------------------------------- -! Assert@Assert -!---------------------------------------------------------------------------- - -INTERFACE ASSERT - MODULE SUBROUTINE assert_2(n1, n2, msg, file, line, routine) - INTEGER(I4B), INTENT(IN) :: n1, n2 - INTEGER(I4B), INTENT(IN) :: line - CHARACTER(*), INTENT(IN) :: msg, file, routine - END SUBROUTINE assert_2 - - MODULE SUBROUTINE assert_3(n1, n2, n3, msg, file, line, routine) - INTEGER(I4B), INTENT(IN) :: n1, n2, n3 - INTEGER(I4B), INTENT(IN) :: line - CHARACTER(*), INTENT(IN) :: msg, file, routine - END SUBROUTINE assert_3 - - MODULE SUBROUTINE assert_4(n1, n2, n3, n4, msg, file, line, routine) - INTEGER(I4B), INTENT(IN) :: n1, n2, n3, n4 - INTEGER(I4B), INTENT(IN) :: line - CHARACTER(*), INTENT(IN) :: msg, file, routine - END SUBROUTINE assert_4 - - MODULE SUBROUTINE assert_n(nn, msg, file, line, routine) - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn - INTEGER(I4B), INTENT(IN) :: line - CHARACTER(*), INTENT(IN) :: msg, file, routine - END SUBROUTINE assert_n -END INTERFACE ASSERT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE AssertUtility diff --git a/src/modules/Utility/src/BinomUtility.F90 b/src/modules/Utility/src/BinomUtility.F90 deleted file mode 100644 index 4959014f5..000000000 --- a/src/modules/Utility/src/BinomUtility.F90 +++ /dev/null @@ -1,132 +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 BinomUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Binom - -!---------------------------------------------------------------------------- -! Binom -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Compute the Binomial coefficient -! -!# Introduction -! -! This routine calculates the bionomial coefficient $C_{k}^{n}$ -! -! Usages is given below -! -! -!## Usage -! -!```fortran -! ans = Binom( n=10, k=2 ) -!``` - -INTERFACE - MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int8(n, k, kind) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: n - !! n is integer, should be a positive number and greater or equal to k - INTEGER(INT8), INTENT(IN) :: k - REAL(REAL32), INTENT(IN) :: kind - REAL(REAL32) :: ans - END FUNCTION Real32_Binom_Int8 -END INTERFACE - -!---------------------------------------------------------------------------- -! Binom -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int16(n, k, kind) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: n - INTEGER(INT16), INTENT(IN) :: k - REAL(REAL32), INTENT(IN) :: kind - REAL(REAL32) :: ans - END FUNCTION Real32_Binom_Int16 -END INTERFACE - -!---------------------------------------------------------------------------- -! Binom -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int32(n, k, kind) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: n - INTEGER(INT32), INTENT(IN) :: k - REAL(REAL32), INTENT(IN) :: kind - REAL(REAL32) :: ans - END FUNCTION Real32_Binom_Int32 - !! - MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int64(n, k, kind) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: n - INTEGER(INT64), INTENT(IN) :: k - REAL(REAL32), INTENT(IN) :: kind - REAL(REAL32) :: ans - END FUNCTION Real32_Binom_Int64 -END INTERFACE - -INTERFACE Binom - MODULE PROCEDURE Real32_Binom_Int8, Real32_Binom_Int16, & - & Real32_Binom_Int32, Real32_Binom_Int64 -END INTERFACE Binom - -!---------------------------------------------------------------------------- -! Binom -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int8(n, k, kind) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: n - INTEGER(INT8), INTENT(IN) :: k - REAL(REAL64), INTENT(IN) :: kind - REAL(REAL64) :: ans - END FUNCTION Real64_Binom_Int8 - !! - MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int16(n, k, kind) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: n - INTEGER(INT16), INTENT(IN) :: k - REAL(REAL64), INTENT(IN) :: kind - REAL(REAL64) :: ans - END FUNCTION Real64_Binom_Int16 - !! - MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int32(n, k, kind) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: n - INTEGER(INT32), INTENT(IN) :: k - REAL(REAL64), INTENT(IN) :: kind - REAL(REAL64) :: ans - END FUNCTION Real64_Binom_Int32 - !! - MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int64(n, k, kind) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: n - INTEGER(INT64), INTENT(IN) :: k - REAL(REAL64), INTENT(IN) :: kind - REAL(REAL64) :: ans - END FUNCTION Real64_Binom_Int64 -END INTERFACE - -INTERFACE Binom - MODULE PROCEDURE Real64_Binom_Int8, Real64_Binom_Int16, & - & Real64_Binom_Int32, Real64_Binom_Int64 -END INTERFACE Binom - -END MODULE BinomUtility diff --git a/src/modules/Utility/src/ContractionUtility.F90 b/src/modules/Utility/src/ContractionUtility.F90 deleted file mode 100644 index 45f15dce3..000000000 --- a/src/modules/Utility/src/ContractionUtility.F90 +++ /dev/null @@ -1,416 +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 ContractionUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(i,j,k) = a1(i,j,k,l)*a2(l)` - -INTERFACE - MODULE PURE FUNCTION Contraction_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)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r4_r1 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(i,j) = a1(i,j,k,l)*a2(k,l)` - -INTERFACE - MODULE PURE FUNCTION Contraction_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)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r4_r2 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(i) = a1(i,j,k,l)*a2(j,k,l)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r4_r3(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :, :, :) - REAL(DFP), INTENT(IN) :: a2(:, :, :) - REAL(DFP) :: ans(SIZE(a1, 1)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r4_r3 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans = a1(i,j,k,l)*a2(i,j,k,l)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r4_r4(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :, :, :) - REAL(DFP), INTENT(IN) :: a2(:, :, :, :) - REAL(DFP) :: ans - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r4_r4 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank3 and rank1 array -! -!# Introduction -! -! This fuction performs following task -! `ans(i,j) = a1(i,j,k)*a2(k)` - -INTERFACE - MODULE PURE FUNCTION Contraction_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)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r3_r1 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank3 and rank2 -! -!# Introduction -! This fuction performs following task -! `ans(i) = a1(i,j,k)*a2(j,k)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r3_r2(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :, :) - REAL(DFP), INTENT(IN) :: a2(:, :) - REAL(DFP) :: ans(SIZE(a1, 1)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r3_r2 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans = a1(i,j,k) * a2(i,j,k)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r3_r3(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :, :) - REAL(DFP), INTENT(IN) :: a2(:, :, :) - REAL(DFP) :: ans - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r3_r3 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(l) = a1(i,j,k) * a2(i,j,k,l)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r3_r4(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :, :) - REAL(DFP), INTENT(IN) :: a2(:, :, :, :) - REAL(DFP) :: ans(SIZE(a2, 4)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r3_r4 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank3 and rank1 array -! -!# Introduction -! -! This fuction performs following task -! `ans(i) = a1(i,j)*a2(j)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r2_r1(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :) - REAL(DFP), INTENT(IN) :: a2(:) - REAL(DFP) :: ans(SIZE(a1, 1)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r2_r1 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank3 and rank2 -! -!# Introduction -! This fuction performs following task -! `ans = a1(i,j)*a2(i,j)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r2_r2(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :) - REAL(DFP), INTENT(IN) :: a2(:, :) - REAL(DFP) :: ans - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r2_r2 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(k) = a1(i,j) * a2(i,j,k)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r2_r3(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :) - REAL(DFP), INTENT(IN) :: a2(:, :, :) - REAL(DFP) :: ans(SIZE(a2, 3)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r2_r3 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(k,l) = a1(i,j) * a2(i,j,k,l)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r2_r4(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:, :) - REAL(DFP), INTENT(IN) :: a2(:, :, :, :) - REAL(DFP) :: ans(SIZE(a2, 3), SIZE(a2, 4)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r2_r4 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank3 and rank1 array -! -!# Introduction -! -! This fuction performs following task -! `ans = a1(i)*a2(i)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r1_r1(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:) - REAL(DFP), INTENT(IN) :: a2(:) - REAL(DFP) :: ans - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r1_r1 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank3 and rank2 -! -!# Introduction -! This fuction performs following task -! `ans(j) = a1(i)*a2(i,j)` - -INTERFACE - MODULE PURE FUNCTION Contraction_r1_r2(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:) - REAL(DFP), INTENT(IN) :: a2(:, :) - REAL(DFP) :: ans(SIZE(a2, 2)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r1_r2 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(j,k) = a1(i) * a2(i,j,k)` - -INTERFACE - MODULE PURE FUNCTION Contraction_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)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r1_r3 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! Contraction@Contraction -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Contraction for rank4 and rank1 array -! -!# Introduction -! -! `ans(j, k,l) = a1(i) * a2(i,j,k,l)` - -INTERFACE - MODULE PURE FUNCTION Contraction_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)) - END FUNCTION -END INTERFACE - -INTERFACE Contraction - MODULE PROCEDURE Contraction_r1_r4 -END INTERFACE Contraction - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ContractionUtility diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90 deleted file mode 100644 index 9deec4303..000000000 --- a/src/modules/Utility/src/ConvertUtility.F90 +++ /dev/null @@ -1,151 +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 ConvertUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Convert -PUBLIC :: ConvertSafe - -!---------------------------------------------------------------------------- -! Convert@ConvertMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Rearrange the degrees of freedom in a finite element matrix -! -!# Introduction -! -! This subroutine changes the storage pattern of a two-d matrix -! - Usually element matrix in easifem are stored in `FMT_DOF` -! - Global matrices/tanmat, however, are stored in `FMT_Nodes` -! - This subroutine is, therefore, in settings or adding values in -! [[SparseMatrix_]]. -! -! > This subroutine converts changes the storage format of dense matrix. -! Usually, elemental finite element matrix is stored in `DOF_FMT`, and global -! matrix/ tanmat, may be stored in `Nodes_FMT`. -! -!@note -! All dof should have the same order of interpolation, therefore, -! this routine works when matrix is square. -!@endnote - -INTERFACE Convert - MODULE PURE SUBROUTINE convert_1(From, To, Conversion, nns, tdof) - REAL(DFP), INTENT(IN) :: From(:, :) - !! Matrix in one format - 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) :: nns, tdof - END SUBROUTINE convert_1 -END INTERFACE Convert - -!---------------------------------------------------------------------------- -! Convert@ConvertMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Rearrange the degrees of freedom in a finite element matrix -! -!# Introduction -! -! This subroutine changes the storage pattern of a two-d matrix -! - Usually element matrix in easifem are stored in `FMT_DOF` -! - Global matrices/tanmat, however, are stored in `FMT_Nodes` -! - This subroutine is, therefore, in settings or adding values in -! [[SparseMatrix_]]. -! -! > This subroutine converts changes the storage format of dense matrix. -! Usually, elemental finite element matrix is stored in `DOF_FMT`, and global -! matrix/ tanmat, may be stored in `Nodes_FMT`. -! -!@note -! All dof should have the same order of interpolation, therefore, -! this routine works when matrix is square. -!@endnote - -INTERFACE ConvertSafe - MODULE PURE SUBROUTINE convert_1_safe(From, To, Conversion, nns, tdof) - 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 - END SUBROUTINE convert_1_safe -END INTERFACE ConvertSafe - -!---------------------------------------------------------------------------- -! Convert@ConvertMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine converts rank4 matrix to rank2 matrix -! -!# Introduction -! -! 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 -! -! - In this way `From(:, :, a, b)` denotes the `a,b` block 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 -END INTERFACE Convert - -!---------------------------------------------------------------------------- -! Convert@ConvertMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: This subroutine converts rank4 matrix to rank2 matrix -! - -INTERFACE Convert - MODULE PURE SUBROUTINE convert_3(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 convert_3 -END INTERFACE Convert - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ConvertUtility diff --git a/src/modules/Utility/src/DiagUtility.F90 b/src/modules/Utility/src/DiagUtility.F90 deleted file mode 100644 index 84dc81844..000000000 --- a/src/modules/Utility/src/DiagUtility.F90 +++ /dev/null @@ -1,441 +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 DiagUtility -USE GlobalData, ONLY: I4B, INT8, INT16, INT32, INT64, & -& REAL32, REAL64, DFP -#ifdef USE_Int128 -USE GlobaData, ONLY: Int128 -#endif -IMPLICIT NONE -PRIVATE - -PUBLIC :: Diag -PUBLIC :: SetDiag -PUBLIC :: DiagSize -PUBLIC :: DiagIndx -PUBLIC :: TriDiag -PUBLIC :: SetTriDiag - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-11 -! summary: Make a Diagonal matrix from int8 vector - -INTERFACE - MODULE PURE FUNCTION Diag_1(a) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a(:) - REAL(DFP) :: ans(SIZE(a), SIZE(a)) - END FUNCTION Diag_1 - - MODULE PURE FUNCTION Diag_2(a) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a(:) - REAL(DFP) :: ans(SIZE(a), SIZE(a)) - END FUNCTION Diag_2 - - MODULE PURE FUNCTION Diag_3(a) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a(:) - REAL(DFP) :: ans(SIZE(a), SIZE(a)) - END FUNCTION Diag_3 - - MODULE PURE FUNCTION Diag_4(a) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a(:) - REAL(DFP) :: ans(SIZE(a), SIZE(a)) - END FUNCTION Diag_4 - - MODULE PURE FUNCTION Diag_5(a) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: a(:) - REAL(DFP) :: ans(SIZE(a), SIZE(a)) - END FUNCTION Diag_5 - - MODULE PURE FUNCTION Diag_6(a) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: a(:) - REAL(DFP) :: ans(SIZE(a), SIZE(a)) - END FUNCTION Diag_6 -END INTERFACE - -INTERFACE Diag - MODULE PROCEDURE Diag_1, Diag_2, Diag_3, Diag_4, Diag_5, & - & Diag_6 -END INTERFACE Diag - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-11 -! summary: Make diagonal matrix from Int128 vector. - -INTERFACE - MODULE PURE FUNCTION Diag_7(a) RESULT(Ans) - INTEGER(Int128), INTENT(IN) :: a(:) - REAL(DFP) :: ans(SIZE(a), SIZE(a)) - END FUNCTION Diag_7 -END INTERFACE - -INTERFACE Diag - MODULE PROCEDURE Diag_7 -END INTERFACE Diag - -#endif - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-11 -! summary: Get the diagNo of matrix -! -!# Introduction -! -!- This routine returns the diagonal of matrix. -!- `diagNo=0` denotes main diagonal -!- `diagNo>0` denotes the super-diagonal -!- `diagNo<0` denotes the sub-diagonal -!- `d` is a one dimesional vector of default Reals (DFP) - -INTERFACE - MODULE PURE FUNCTION Diag_8(mat, diagNo) RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(:, :) - !! matrix - INTEGER(I4B), INTENT(IN) :: diagNo - !! diagonal number - REAL(DFP), ALLOCATABLE :: ans(:) - !! diagonal - END FUNCTION Diag_8 - -END INTERFACE - -INTERFACE Diag - MODULE PROCEDURE Diag_8 -END INTERFACE Diag - -!---------------------------------------------------------------------------- -! SetDiag -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-11 -! summary: Set the diagNo of matrix -! -!# Introduction -! -!- This routine sets the diagonal of matrix. -! -!- `diagNo=0` denotes main diagonal -!- `diagNo>0` denotes the super-diagonal -!- `diagNo<0` denotes the sub-diagonal -! -!- `d` is a one dimesional vector of (Int or float) -!- if `size(d)=1`, then all entries of the diagonal will be set to this -! value. -!- if `size(d) .ne. 1`, then the size of `d` should be atleast the size of -! diagonal number `diag`. - -INTERFACE - MODULE PURE SUBROUTINE SetDiag1(mat, d, diagNo) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - INTEGER(INT8), INTENT(IN) :: d(:) - INTEGER(I4B), INTENT(IN) :: diagNo - END SUBROUTINE SetDiag1 - MODULE PURE SUBROUTINE SetDiag2(mat, d, diagNo) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - INTEGER(INT16), INTENT(IN) :: d(:) - INTEGER(I4B), INTENT(IN) :: diagNo - END SUBROUTINE SetDiag2 - MODULE PURE SUBROUTINE SetDiag3(mat, d, diagNo) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - INTEGER(INT32), INTENT(IN) :: d(:) - INTEGER(I4B), INTENT(IN) :: diagNo - END SUBROUTINE SetDiag3 - MODULE PURE SUBROUTINE SetDiag4(mat, d, diagNo) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - INTEGER(INT64), INTENT(IN) :: d(:) - INTEGER(I4B), INTENT(IN) :: diagNo - END SUBROUTINE SetDiag4 - MODULE PURE SUBROUTINE SetDiag5(mat, d, diagNo) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - REAL(REAL32), INTENT(IN) :: d(:) - INTEGER(I4B), INTENT(IN) :: diagNo - END SUBROUTINE SetDiag5 - MODULE PURE SUBROUTINE SetDiag6(mat, d, diagNo) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - REAL(REAL64), INTENT(IN) :: d(:) - INTEGER(I4B), INTENT(IN) :: diagNo - END SUBROUTINE SetDiag6 -END INTERFACE - -INTERFACE SetDiag - MODULE PROCEDURE SetDiag1, SetDiag2, SetDiag3, SetDiag4, & - & SetDiag5, SetDiag6 -END INTERFACE SetDiag - -!---------------------------------------------------------------------------- -! DiagSize -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION DiagSize1(n, diagNo) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! size of matrix - INTEGER(I4B), INTENT(IN) :: diagNo - !! diagonal number - INTEGER(I4B) :: ans - !! size of diagonal - END FUNCTION DiagSize1 -END INTERFACE - -INTERFACE DiagSize - MODULE PROCEDURE DiagSize1 -END INTERFACE DiagSize - -!---------------------------------------------------------------------------- -! DiagSize -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION DiagSize2(m, n, diagNo) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - !! number of rows in matrix - INTEGER(I4B), INTENT(IN) :: n - !! number of columns in a matrix - INTEGER(I4B), INTENT(IN) :: diagNo - !! diagonal number - INTEGER(I4B) :: ans - !! size of diagonal - END FUNCTION DiagSize2 -END INTERFACE - -INTERFACE DiagSize - MODULE PROCEDURE DiagSize2 -END INTERFACE DiagSize - -!---------------------------------------------------------------------------- -! DiagSize -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION DiagIndx(m, n, diagNo) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - !! number of rows in matrix - INTEGER(I4B), INTENT(IN) :: n - !! number of columns in a matrix - INTEGER(I4B), INTENT(IN) :: diagNo - !! diagonal number - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - !! size of diagonal - END FUNCTION DiagIndx -END INTERFACE - -!---------------------------------------------------------------------------- -! SetTriDiag -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-11 -! summary: Set the diagNo of tri diagonal matrix -! -!# Introduction -! -!- This routine sets the diagonals of a tridiagonal matrix. -! -!- `d` denotes main diagonal -!- `da` denotes the super-diagonal -!- `db` denotes the sub-diagonal -! -!- `d, da, db` are one dimesional vectors of (Int or float) -!- if `size(d/da/db)=1`, then all entries of the diagonal will be set to this -! value. -!- if `size(d/da/db) .ne. 1`, then the size of `d/da/db` should be atleast -! the size of respective diagonals. - -INTERFACE - MODULE PURE SUBROUTINE SetTriDiag1(mat, d, da, db) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! tri diagonal matrix dense form - INTEGER(INT8), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT8), INTENT(IN) :: da(:) - !! super-diagonal, (a, for above) - INTEGER(INT8), INTENT(IN) :: db(:) - !! sub-diagonal (b for below) - END SUBROUTINE SetTriDiag1 - - MODULE PURE SUBROUTINE SetTriDiag2(mat, d, da, db) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! tri diagonal matrix dense form - INTEGER(INT16), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT16), INTENT(IN) :: da(:) - !! super-diagonal, (a, for above) - INTEGER(INT16), INTENT(IN) :: db(:) - !! sub-diagonal (b for below) - END SUBROUTINE SetTriDiag2 - - MODULE PURE SUBROUTINE SetTriDiag3(mat, d, da, db) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! tri diagonal matrix dense form - INTEGER(INT32), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT32), INTENT(IN) :: da(:) - !! super-diagonal, (a, for above) - INTEGER(INT32), INTENT(IN) :: db(:) - !! sub-diagonal (b for below) - END SUBROUTINE SetTriDiag3 - - MODULE PURE SUBROUTINE SetTriDiag4(mat, d, da, db) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! tri diagonal matrix dense form - INTEGER(INT64), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT64), INTENT(IN) :: da(:) - !! super-diagonal, (a, for above) - INTEGER(INT64), INTENT(IN) :: db(:) - !! sub-diagonal (b for below) - END SUBROUTINE SetTriDiag4 - - MODULE PURE SUBROUTINE SetTriDiag5(mat, d, da, db) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! tri diagonal matrix dense form - REAL(REAL32), INTENT(IN) :: d(:) - !! main diagonal - REAL(REAL32), INTENT(IN) :: da(:) - !! super-diagonal, (a, for above) - REAL(REAL32), INTENT(IN) :: db(:) - !! sub-diagonal (b for below) - END SUBROUTINE SetTriDiag5 - - MODULE PURE SUBROUTINE SetTriDiag6(mat, d, da, db) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! tri diagonal matrix dense form - REAL(REAL64), INTENT(IN) :: d(:) - !! main diagonal - REAL(REAL64), INTENT(IN) :: da(:) - !! super-diagonal, (a, for above) - REAL(REAL64), INTENT(IN) :: db(:) - !! sub-diagonal (b for below) - END SUBROUTINE SetTriDiag6 - -END INTERFACE - -INTERFACE SetTriDiag - MODULE PROCEDURE SetTriDiag1, SetTriDiag2, SetTriDiag3, SetTriDiag4, & - & SetTriDiag5, SetTriDiag6 -END INTERFACE SetTriDiag - -!---------------------------------------------------------------------------- -! Tridiag -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-11 -! summary: Make a Tridiagonal matrix from main, sub, super diagonal - -INTERFACE - MODULE PURE FUNCTION Tridiag_1(d, da, db, diagNo) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT8), INTENT(IN) :: da(:) - !! super diagonal - INTEGER(INT8), INTENT(IN) :: db(:) - !! subdiagonal - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! sub and super diagonal number, default is 1 - !! diagNo should be positive - REAL(DFP) :: ans(SIZE(d), SIZE(d)) - END FUNCTION Tridiag_1 - - MODULE PURE FUNCTION Tridiag_2(d, da, db, diagNo) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT16), INTENT(IN) :: da(:) - !! super diagonal - INTEGER(INT16), INTENT(IN) :: db(:) - !! subdiagonal - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! sub and super diagonal number, default is 1 - !! diagNo should be positive - REAL(DFP) :: ans(SIZE(d), SIZE(d)) - END FUNCTION Tridiag_2 - - MODULE PURE FUNCTION Tridiag_3(d, da, db, diagNo) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT32), INTENT(IN) :: da(:) - !! super diagonal - INTEGER(INT32), INTENT(IN) :: db(:) - !! subdiagonal - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! sub and super diagonal number, default is 1 - !! diagNo should be positive - REAL(DFP) :: ans(SIZE(d), SIZE(d)) - END FUNCTION Tridiag_3 - - MODULE PURE FUNCTION Tridiag_4(d, da, db, diagNo) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: d(:) - !! main diagonal - INTEGER(INT64), INTENT(IN) :: da(:) - !! super diagonal - INTEGER(INT64), INTENT(IN) :: db(:) - !! subdiagonal - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! sub and super diagonal number, default is 1 - !! diagNo should be positive - REAL(DFP) :: ans(SIZE(d), SIZE(d)) - END FUNCTION Tridiag_4 - - MODULE PURE FUNCTION Tridiag_5(d, da, db, diagNo) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: d(:) - !! main diagonal - REAL(REAL32), INTENT(IN) :: da(:) - !! super diagonal - REAL(REAL32), INTENT(IN) :: db(:) - !! subdiagonal - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! sub and super diagonal number, default is 1 - !! diagNo should be positive - REAL(DFP) :: ans(SIZE(d), SIZE(d)) - END FUNCTION Tridiag_5 - - MODULE PURE FUNCTION Tridiag_6(d, da, db, diagNo) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: d(:) - !! main diagonal - REAL(REAL64), INTENT(IN) :: da(:) - !! super diagonal - REAL(REAL64), INTENT(IN) :: db(:) - !! subdiagonal - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! sub and super diagonal number, default is 1 - !! diagNo should be positive - REAL(DFP) :: ans(SIZE(d), SIZE(d)) - END FUNCTION Tridiag_6 - -END INTERFACE - -INTERFACE Tridiag - MODULE PROCEDURE Tridiag_1, Tridiag_2, Tridiag_3, Tridiag_4, Tridiag_5, & - & Tridiag_6 -END INTERFACE Tridiag - -END MODULE DiagUtility diff --git a/src/modules/Utility/src/EigenUtility.F90 b/src/modules/Utility/src/EigenUtility.F90 deleted file mode 100644 index 1995d8b4b..000000000 --- a/src/modules/Utility/src/EigenUtility.F90 +++ /dev/null @@ -1,187 +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 EigenUtility -USE GlobalData -IMPLICIT NONE - -PUBLIC :: SymEigenValues2by2 -PUBLIC :: SymEigenValues3by3 -PUBLIC :: SymEigenValuesUpto3 -PUBLIC :: SymEigenValues -PUBLIC :: GetSymEigenValues -PUBLIC :: GetSymEigenValues_ -PUBLIC :: GetSymEigenJacobi - -!---------------------------------------------------------------------------- -! SymEigen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-26 -! summary: Eigenvalue of 2 by 2 symmetric matrix - -INTERFACE - MODULE PURE FUNCTION SymEigenValues2by2(mat) RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(2, 2) - REAL(DFP) :: ans(2) - END FUNCTION SymEigenValues2by2 -END INTERFACE - -!---------------------------------------------------------------------------- -! SymEigen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-26 -! summary: Eigenvalue of 3 by 3 symmetric matrix - -INTERFACE - MODULE PURE FUNCTION SymEigenValues3by3(mat) RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(3, 3) - REAL(DFP) :: ans(3) - END FUNCTION SymEigenValues3by3 -END INTERFACE - -!---------------------------------------------------------------------------- -! SymEigen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-26 -! summary: Eigenvalue of 3 by 3 or 2 by 2 symmetric matrix - -INTERFACE - MODULE PURE FUNCTION SymEigenValuesUpto3(mat) RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(:, :) - !! size(mat, 1) = [1,2,3] - REAL(DFP) :: ans(SIZE(mat, 1)) - END FUNCTION SymEigenValuesUpto3 -END INTERFACE - -!---------------------------------------------------------------------------- -! SymEigen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Nov 2022 -! summary: Compute eigenvalues of matrix -! -!# Introduction -! -! Calculate eigenvalues of symetric matrix. -! -!- If `n=2` call SymEigenValues2by2 -!- If `n=3` call SymEigenValues3by3 -!- If `n>=4` call SYEV from Lapack, It needs Lapack95 interface - -INTERFACE - MODULE FUNCTION SymEigenValues(mat) RESULT(ans) - REAL(DFP), INTENT(IN) :: mat(:, :) - !! for n=2, we call SymEigenValues2by2 - !! for n=3, we call SymEigenValues3by3 - !! for n>=4, we call Lapack - REAL(DFP) :: ans(SIZE(mat, 1)) - END FUNCTION SymEigenValues -END INTERFACE - -!---------------------------------------------------------------------------- -! GetSymEigen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Nov 2022 -! summary: Compute eigenvalues of matrix -! -!# Introduction -! -! Calculate eigenvalues of symetric matrix. -! -!- If `n=2` call SymEigenValues2by2 -!- If `n=3` call SymEigenValues3by3 -!- If `n>=4` call SYEV from Lapack, It needs Lapack95 interface - -INTERFACE - MODULE SUBROUTINE GetSymEigenValues(mat, eigenValues) - REAL(DFP), INTENT(IN) :: mat(:, :) - REAL(DFP), INTENT(OUT) :: eigenValues(:) - END SUBROUTINE GetSymEigenValues -END INTERFACE - -!---------------------------------------------------------------------------- -! GetSymEigen -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 14 Nov 2022 -! summary: Compute eigenvalues of matrix -! -!# Introduction -! -! Calculate eigenvalues of symetric matrix. -! -!- If `n=2` call SymEigenValues2by2 -!- If `n=3` call SymEigenValues3by3 -!- If `n>=4` call SYEV from Lapack, It needs Lapack95 interface -! -!- mat will be destroyed. - -INTERFACE - MODULE SUBROUTINE GetSymEigenValues_(mat, eigenValues) - REAL(DFP), INTENT(INOUT) :: mat(:, :) - REAL(DFP), INTENT(OUT) :: eigenValues(:) - END SUBROUTINE GetSymEigenValues_ -END INTERFACE - -!---------------------------------------------------------------------------- -! GetSymEigenJacobi@LAPACK -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 6 March 2021 -! summary: Returns all the eigenvalues of symmetric matrix -! -!# Introduction -! -! This subroutine computes all eigenvalues and eigenvectors of a real -! symmetric N × N matrix `Mat`. -! - On output, elements of `Mat` above the diagonal are destroyed. -! - `eigenvalues` is a vector of length N that returns the eigenvalues of -! `Mat`. -! - `EigenVectors` is an `N × N` matrix whose columns contain on output, -! the normalized eigenvectors (directions) of `Mat`. -! - `maxIter` returns the number of Jacobi rotations that were required. -! -! ### Reference:: Numerical Reciepe in Fortran, Page 1225 -! -! TODO: Remove this subroutine, instead call Lapack. - -INTERFACE - MODULE PURE SUBROUTINE GetSymEigenJacobi(mat, eigenValues, eigenVectors, & - & maxIter) - REAL(DFP), INTENT(IN) :: mat(:, :) - REAL(DFP), INTENT(INOUT) :: eigenValues(:) - REAL(DFP), INTENT(INOUT) :: eigenVectors(:, :) - INTEGER(I4B), INTENT(IN) :: maxIter - END SUBROUTINE GetSymEigenJacobi -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE EigenUtility diff --git a/src/modules/Utility/src/EyeUtility.F90 b/src/modules/Utility/src/EyeUtility.F90 deleted file mode 100644 index d9e77b7bd..000000000 --- a/src/modules/Utility/src/EyeUtility.F90 +++ /dev/null @@ -1,140 +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 EyeUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Eye - -!---------------------------------------------------------------------------- -! Eye@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-26 -! summary: Return an identity matrix of an integers - -INTERFACE - MODULE PURE FUNCTION int_eye_1(m, DataType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8) :: ans(m, m) - END FUNCTION int_eye_1 - - MODULE PURE FUNCTION int_eye_2(m, DataType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16) :: ans(m, m) - END FUNCTION int_eye_2 - - MODULE PURE FUNCTION int_eye_3(m, DataType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32) :: ans(m, m) - END FUNCTION int_eye_3 - - MODULE PURE FUNCTION int_eye_4(m, DataType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64) :: ans(m, m) - END FUNCTION int_eye_4 -END INTERFACE - -INTERFACE Eye - MODULE PROCEDURE int_eye_1, int_eye_2, int_eye_3, int_eye_4 -END INTERFACE Eye - -#ifdef USE_Int128 -INTERFACE - MODULE PURE FUNCTION int_eye_5(m, DataType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - INTEGER(Int128), INTENT(IN) :: DataType - INTEGER(Int128) :: ans(m, m) - END FUNCTION int_eye_5 -END INTERFACE - -INTERFACE Eye - MODULE PROCEDURE int_eye_5 -END INTERFACE Eye -#endif - -!---------------------------------------------------------------------------- -! Eye@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-26 -! summary: Return identity matrix of real numbers -INTERFACE - - MODULE PURE FUNCTION real_eye_1(m, DataType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - REAL(REAL64) :: ans(m, m) - REAL(REAL64), INTENT(IN) :: DataType - END FUNCTION real_eye_1 -END INTERFACE - -INTERFACE Eye - MODULE PROCEDURE real_eye_1 -END INTERFACE Eye - -!---------------------------------------------------------------------------- -! Eye@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-26 -! summary: Return identity matrix of real number -INTERFACE - - MODULE PURE FUNCTION real_eye_2(m) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - REAL(DFP) :: ans(m, m) - END FUNCTION real_eye_2 -END INTERFACE - -INTERFACE Eye - MODULE PROCEDURE real_eye_2 -END INTERFACE Eye - -!---------------------------------------------------------------------------- -! Eye@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-26 -! summary: Return identity matrix of real numbers -INTERFACE - - MODULE PURE FUNCTION real_eye_3(m, DataType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - REAL(REAL32) :: ans(m, m) - REAL(REAL32), INTENT(IN) :: DataType - END FUNCTION real_eye_3 -END INTERFACE - -INTERFACE Eye - MODULE PROCEDURE real_eye_3 -END INTERFACE Eye - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE EyeUtility diff --git a/src/modules/Utility/src/GridPointUtility.F90 b/src/modules/Utility/src/GridPointUtility.F90 deleted file mode 100644 index dbc2b8feb..000000000 --- a/src/modules/Utility/src/GridPointUtility.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 -! - -MODULE GridPointUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: ExpMesh -PUBLIC :: Linspace -PUBLIC :: Logspace -PUBLIC :: MeshGrid - -!---------------------------------------------------------------------------- -! ExpMesh@FunctionalFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Sept 2021 -! summary: Exponential mesh - -INTERFACE ExpMesh - MODULE PURE FUNCTION ExpMesh_Real64(rmin, rmax, a, N) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: rmin - !! left end of 1D domain - REAL(REAL64), INTENT(IN) :: rmax - !! right end of 1D domain - REAL(REAL64), INTENT(IN) :: a - !! Ratio of largest to smallest element, a should be positive - !! a = 1, then we get uniform mesh - INTEGER(I4B), INTENT(IN) :: N - !! Number of elements present in mesh - REAL(REAL64) :: ans(N + 1) - !! Number of nodes in mesh - END FUNCTION ExpMesh_Real64 -END INTERFACE ExpMesh - -!---------------------------------------------------------------------------- -! ExpMesh@FunctionalFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Sept 2021 -! summary: Exponential mesh - -INTERFACE ExpMesh - MODULE PURE FUNCTION ExpMesh_Real32(rmin, rmax, a, N) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: rmin - !! left end of 1D domain - REAL(REAL32), INTENT(IN) :: rmax - !! right end of 1D domain - REAL(REAL32), INTENT(IN) :: a - !! Ratio of largest to smallest element, a should be positive - !! a = 1, then we get uniform mesh - INTEGER(I4B), INTENT(IN) :: N - !! Number of elements present in mesh - REAL(REAL32) :: ans(N + 1) - !! Number of nodes in mesh - END FUNCTION ExpMesh_Real32 -END INTERFACE ExpMesh - -!---------------------------------------------------------------------------- -! Linspace@FunctionalFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Sept 2021 -! summary: linspace - -INTERFACE LinSpace - MODULE PURE FUNCTION Linspace_Real64(a, b, N) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: a - !! left end of 1D domain - REAL(REAL64), INTENT(IN) :: b - !! right end of 1D domain - INTEGER(I4B), OPTIONAL, INTENT(IN) :: N - !! Number of points including a and b - REAL(REAL64), ALLOCATABLE :: ans(:) - !! Number of nodes in mesh - END FUNCTION Linspace_Real64 -END INTERFACE LinSpace - -!---------------------------------------------------------------------------- -! Linspace@FunctionalFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Sept 2021 -! summary: Returns a linearly spaced vector -! -!# Introduction -! Returns a linearly spaced vector with n points in [a, b] -! if n is omitted, 100 points will be considered - -INTERFACE LinSpace - MODULE PURE FUNCTION Linspace_Real32(a, b, N) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: a - !! left end of 1D domain - REAL(REAL32), INTENT(IN) :: b - !! right end of 1D domain - INTEGER(I4B), OPTIONAL, INTENT(IN) :: N - !! Number of points including a and b - REAL(REAL32), ALLOCATABLE :: ans(:) - !! Number of nodes in mesh - END FUNCTION Linspace_Real32 -END INTERFACE LinSpace - -!---------------------------------------------------------------------------- -! Logspace@FunctionalFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Sept 2021 -! summary: Logspace - -INTERFACE - MODULE PURE FUNCTION Logspace_Real64(a, b, N, endPoint, base) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: a - !! left end of 1D domain - REAL(REAL64), INTENT(IN) :: b - !! right end of 1D domain - INTEGER(I4B), OPTIONAL, INTENT(IN) :: N - !! Number of points including a and b - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: endPoint - !! default is true, if true then include endpoint - INTEGER(I4B), OPTIONAL, INTENT(IN) :: base - !! default is 10 - REAL(REAL64), ALLOCATABLE :: ans(:) - !! Number of nodes in mesh - END FUNCTION Logspace_Real64 -END INTERFACE - -INTERFACE Logspace - MODULE PROCEDURE Logspace_Real64 -END INTERFACE Logspace - -!---------------------------------------------------------------------------- -! Logspace@FunctionalFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Sept 2021 -! summary: Logspace - -INTERFACE - MODULE PURE FUNCTION Logspace_Real32(a, b, N, endPoint, base) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: a - !! left end of 1D domain - REAL(REAL32), INTENT(IN) :: b - !! right end of 1D domain - INTEGER(I4B), OPTIONAL, INTENT(IN) :: N - !! Number of points including a and b, default is 100 - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: endPoint - !! default is true, if true then include endpoint - INTEGER(I4B), OPTIONAL, INTENT(IN) :: base - !! default is 10 - REAL(REAL32), ALLOCATABLE :: ans(:) - !! Number of nodes in mesh - END FUNCTION Logspace_Real32 -END INTERFACE - -INTERFACE Logspace - MODULE PROCEDURE Logspace_Real32 -END INTERFACE Logspace - -!---------------------------------------------------------------------------- -! MeshGrid@FunctionalFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 16 Sept 2021 -! summary: meshgrid generate mesh grid over a rectangular domain -! -!# Introduction -! -! Meshgrid generate mesh grid over a rectangular domain of -! [xmin xmax, ymin, ymax] -! - xgv, ygv are grid vectors in form of full grid data -! - X and Y are matrix each of size [ny by nx] contains the grid data. -! - The coordinates of point (i,j) is [X(i,j), Y(i,j)] -! -!### Usage -! -!```fortran -! call meshgrid(X, Y, [0.,1.,2.,3.],[5.,6.,7.,8.]) -! -! X = -! [0.0, 1.0, 2.0, 3.0, -! 0.0, 1.0, 2.0, 3.0, -! 0.0, 1.0, 2.0, 3.0, -! 0.0, 1.0, 2.0, 3.0] -! -! Y = -! [ 5.0, 5.0, 5.0, 5.0, -! 6.0, 6.0, 6.0, 6.0, -! 7.0, 7.0, 7.0, 7.0, -! 8.0, 8.0, 8.0, 8.0] -!``` - -INTERFACE - MODULE PURE SUBROUTINE MeshGrid2D_Real64(x, y, xgv, ygv) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: x(:, :) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: y(:, :) - REAL(REAL64), INTENT(IN) :: xgv(:) - REAL(REAL64), INTENT(IN) :: ygv(:) - END SUBROUTINE MeshGrid2D_Real64 -END INTERFACE - -INTERFACE MeshGrid - MODULE PROCEDURE MeshGrid2D_Real64 -END INTERFACE MeshGrid - -!---------------------------------------------------------------------------- -! MeshGrid@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE MeshGrid2D_Real32(x, y, xgv, ygv) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: x(:, :) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: y(:, :) - REAL(REAL32), INTENT(IN) :: xgv(:) - REAL(REAL32), INTENT(IN) :: ygv(:) - END SUBROUTINE MeshGrid2D_Real32 -END INTERFACE - -INTERFACE MeshGrid - MODULE PROCEDURE MeshGrid2D_Real32 -END INTERFACE MeshGrid - -!---------------------------------------------------------------------------- -! MeshGrid@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE MeshGrid3D_Real64(x, y, z, xgv, ygv, zgv) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: x(:, :, :) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: y(:, :, :) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: z(:, :, :) - REAL(REAL64), INTENT(IN) :: xgv(:) - REAL(REAL64), INTENT(IN) :: ygv(:) - REAL(REAL64), INTENT(IN) :: zgv(:) - END SUBROUTINE MeshGrid3D_Real64 -END INTERFACE - -INTERFACE MeshGrid - MODULE PROCEDURE MeshGrid3D_Real64 -END INTERFACE MeshGrid - -!---------------------------------------------------------------------------- -! MeshGrid@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE MeshGrid3D_Real32(x, y, z, xgv, ygv, zgv) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: x(:, :, :) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: y(:, :, :) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: z(:, :, :) - REAL(REAL32), INTENT(IN) :: xgv(:) - REAL(REAL32), INTENT(IN) :: ygv(:) - REAL(REAL32), INTENT(IN) :: zgv(:) - END SUBROUTINE MeshGrid3D_Real32 -END INTERFACE - -INTERFACE MeshGrid - MODULE PROCEDURE MeshGrid3D_Real32 -END INTERFACE MeshGrid - -END MODULE GridPointUtility diff --git a/src/modules/Utility/src/HashingUtility.F90 b/src/modules/Utility/src/HashingUtility.F90 deleted file mode 100644 index dd989eab2..000000000 --- a/src/modules/Utility/src/HashingUtility.F90 +++ /dev/null @@ -1,54 +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 HashingUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! StringToUID@HashingMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 Aug 2021 -! summary: This function returns a unique number for a given string -! -!# Introduction -! This function returns a unique number for a given string -! -! Reference -! https://cp-algorithms.com/string/string-hashing.html - -INTERFACE - MODULE PURE FUNCTION StringToUID_PolyRoll(charVar) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: charVar - INTEGER(I4B) :: ans - END FUNCTION StringToUID_PolyRoll -END INTERFACE - -INTERFACE StringToUID - MODULE PROCEDURE StringToUID_PolyRoll -END INTERFACE StringToUID - -PUBLIC :: StringToUID - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE HashingUtility diff --git a/src/modules/Utility/src/HeadUtility.F90 b/src/modules/Utility/src/HeadUtility.F90 deleted file mode 100644 index 78dec1675..000000000 --- a/src/modules/Utility/src/HeadUtility.F90 +++ /dev/null @@ -1,90 +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 HeadUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: HEAD - -!---------------------------------------------------------------------------- -! Head -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns the first element of array `x`. - -INTERFACE HEAD - MODULE PURE FUNCTION head_Int8(x) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: x(:) - INTEGER(INT8) :: Ans - END FUNCTION head_Int8 - - MODULE PURE FUNCTION head_Int16(x) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: x(:) - INTEGER(INT16) :: Ans - END FUNCTION head_Int16 - - MODULE PURE FUNCTION head_Int32(x) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: x(:) - INTEGER(INT32) :: Ans - END FUNCTION head_Int32 - - MODULE PURE FUNCTION head_Int64(x) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: x(:) - INTEGER(INT64) :: Ans - END FUNCTION head_Int64 -END INTERFACE HEAD - -!---------------------------------------------------------------------------- -! Head -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns the first element of array `x`. - -INTERFACE HEAD - MODULE PURE FUNCTION head_Real32(x) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: x(:) - REAL(REAL32) :: Ans - END FUNCTION head_Real32 - - MODULE PURE FUNCTION head_Real64(x) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: x(:) - REAL(REAL64) :: Ans - END FUNCTION head_Real64 -END INTERFACE HEAD - -!---------------------------------------------------------------------------- -! Head -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns the first element of array `x`. - -INTERFACE HEAD - MODULE PURE FUNCTION head_char(x) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: x - CHARACTER(1) :: Ans - END FUNCTION -END INTERFACE HEAD - -END MODULE HeadUtility diff --git a/src/modules/Utility/src/InputUtility.F90 b/src/modules/Utility/src/InputUtility.F90 deleted file mode 100644 index 253c0408c..000000000 --- a/src/modules/Utility/src/InputUtility.F90 +++ /dev/null @@ -1,266 +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 InputUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_Int8(default, option) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: default - INTEGER(INT8), OPTIONAL, INTENT(IN) :: option - INTEGER(INT8) :: Ans - END FUNCTION input_Int8 - MODULE PURE FUNCTION input_Int16(default, option) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: default - INTEGER(INT16), OPTIONAL, INTENT(IN) :: option - INTEGER(INT16) :: Ans - END FUNCTION input_Int16 - MODULE PURE FUNCTION input_Int32(default, option) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: default - INTEGER(INT32), OPTIONAL, INTENT(IN) :: option - INTEGER(INT32) :: Ans - END FUNCTION input_Int32 - MODULE PURE FUNCTION input_Int64(default, option) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: default - INTEGER(INT64), OPTIONAL, INTENT(IN) :: option - INTEGER(INT64) :: Ans - END FUNCTION input_Int64 -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_Int8, input_Int16, input_Int32, input_Int64 -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_Real32(default, option) RESULT(ans) - REAL(REAL32), INTENT(in) :: default - REAL(REAL32), OPTIONAL, INTENT(in) :: option - REAL(REAL32) :: ans - END FUNCTION input_Real32 - MODULE PURE FUNCTION input_Real64(default, option) RESULT(ans) - REAL(REAL64), INTENT(in) :: default - REAL(REAL64), OPTIONAL, INTENT(in) :: option - REAL(REAL64) :: ans - END FUNCTION input_Real64 -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_Real32, input_Real64 -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_Int8Vec(default, option) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: default(:) - INTEGER(INT8), OPTIONAL, INTENT(IN) :: option(:) - INTEGER(INT8) :: ans(SIZE(default)) - END FUNCTION input_Int8Vec - MODULE PURE FUNCTION input_Int16Vec(default, option) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: default(:) - INTEGER(INT16), OPTIONAL, INTENT(IN) :: option(:) - INTEGER(INT16) :: ans(SIZE(default)) - END FUNCTION input_Int16Vec - MODULE PURE FUNCTION input_Int32Vec(default, option) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: default(:) - INTEGER(INT32), OPTIONAL, INTENT(IN) :: option(:) - INTEGER(INT32) :: ans(SIZE(default)) - END FUNCTION input_Int32Vec - MODULE PURE FUNCTION input_Int64Vec(default, option) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: default(:) - INTEGER(INT64), OPTIONAL, INTENT(IN) :: option(:) - INTEGER(INT64) :: ans(SIZE(default)) - END FUNCTION input_Int64Vec -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_Int8Vec, input_Int16Vec, input_Int32Vec, & - & input_Int64Vec -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_Real32vec(default, option) RESULT(ans) - REAL(REAL32), INTENT(IN) :: default(:) - REAL(REAL32), OPTIONAL, INTENT(IN) :: option(:) - REAL(REAL32) :: ans(SIZE(default)) - END FUNCTION - MODULE PURE FUNCTION input_Real64vec(default, option) RESULT(ans) - REAL(REAL64), INTENT(IN) :: default(:) - REAL(REAL64), OPTIONAL, INTENT(IN) :: option(:) - REAL(REAL64) :: ans(SIZE(default)) - END FUNCTION -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_Real32vec, input_Real64vec -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_Int8Array(default, option) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: default(:, :) - INTEGER(INT8), OPTIONAL, INTENT(IN) :: option(:, :) - INTEGER(INT8) :: ans(SIZE(default, 1), SIZE(default, 2)) - END FUNCTION input_Int8Array - MODULE PURE FUNCTION input_Int16Array(default, option) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: default(:, :) - INTEGER(INT16), OPTIONAL, INTENT(IN) :: option(:, :) - INTEGER(INT16) :: ans(SIZE(default, 1), SIZE(default, 2)) - END FUNCTION input_Int16Array - MODULE PURE FUNCTION input_Int32Array(default, option) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: default(:, :) - INTEGER(INT32), OPTIONAL, INTENT(IN) :: option(:, :) - INTEGER(INT32) :: ans(SIZE(default, 1), SIZE(default, 2)) - END FUNCTION input_Int32Array - MODULE PURE FUNCTION input_Int64Array(default, option) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: default(:, :) - INTEGER(INT64), OPTIONAL, INTENT(IN) :: option(:, :) - INTEGER(INT64) :: ans(SIZE(default, 1), SIZE(default, 2)) - END FUNCTION input_Int64Array -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_Int8Array, input_Int16Array, input_Int32Array, & - & input_Int64Array -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_Real32Array(default, option) RESULT(ans) - REAL(REAL32), INTENT(IN) :: default(:, :) - REAL(REAL32), OPTIONAL, INTENT(IN) :: option(:, :) - REAL(REAL32) :: ans(SIZE(default, 1), SIZE(default, 2)) - END FUNCTION input_Real32Array - MODULE PURE FUNCTION input_Real64Array(default, option) RESULT(ans) - REAL(REAL64), INTENT(IN) :: default(:, :) - REAL(REAL64), OPTIONAL, INTENT(IN) :: option(:, :) - REAL(REAL64) :: ans(SIZE(default, 1), SIZE(default, 2)) - END FUNCTION input_Real64Array -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_Real32Array, input_Real64Array -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_String(default, option) RESULT(ans) - CHARACTER(*), INTENT(IN) :: default - CHARACTER(*), OPTIONAL, INTENT(IN) :: option - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_String -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -! INTERFACE -! MODULE PURE FUNCTION input_StringVec(default, option) RESULT(ans) -! CHARACTER(*), INTENT(IN) :: default(:) -! CHARACTER(*), OPTIONAL, INTENT(IN) :: option(:) -! CHARACTER(:), ALLOCATABLE :: ans(:) -! END FUNCTION input_StringVec -! END INTERFACE - -! INTERFACE Input -! MODULE PROCEDURE input_StringVec -! END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_logical(default, option) RESULT(ans) - LOGICAL(LGT), INTENT(IN) :: default - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: option - LOGICAL(LGT) :: ans - END FUNCTION -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_logical -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_logicalvec(default, option) RESULT(ans) - LOGICAL(LGT), INTENT(IN) :: default(:) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: option(:) - LOGICAL(LGT) :: ans(SIZE(default)) - END FUNCTION -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_logicalvec -END INTERFACE Input - -!---------------------------------------------------------------------------- -! Input@Input -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION input_logicalArray(default, option) RESULT(ans) - LOGICAL(LGT), INTENT(IN) :: default(:, :) - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: option(:, :) - LOGICAL(LGT) :: ans(SIZE(default, 1), SIZE(default, 2)) - END FUNCTION -END INTERFACE - -INTERFACE Input - MODULE PROCEDURE input_logicalArray -END INTERFACE Input - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE InputUtility diff --git a/src/modules/Utility/src/IntegerUtility.F90 b/src/modules/Utility/src/IntegerUtility.F90 deleted file mode 100644 index b52c57a50..000000000 --- a/src/modules/Utility/src/IntegerUtility.F90 +++ /dev/null @@ -1,537 +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 IntegerUtility -USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, & - REAL32, REAL64 -IMPLICIT NONE -PRIVATE - -PUBLIC :: OPERATOR(.in.) -PUBLIC :: OPERATOR(.isin.) -PUBLIC :: RemoveDuplicates -PUBLIC :: RemoveDuplicates_ -PUBLIC :: Repeat -PUBLIC :: SIZE -PUBLIC :: GetMultiIndices -PUBLIC :: GetIndex -PUBLIC :: Get -PUBLIC :: GetIntersection -PUBLIC :: Get1DIndexFortran - -!---------------------------------------------------------------------------- -! Size@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get the number of touples - -INTERFACE Size - MODULE PURE FUNCTION obj_Size1(n, d) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - INTEGER(I4B) :: ans - END FUNCTION obj_Size1 -END INTERFACE Size - -!---------------------------------------------------------------------------- -! Size@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get the number of touples - -INTERFACE Size - MODULE PURE FUNCTION obj_Size2(n, d, upto) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - LOGICAL(LGT), INTENT(IN) :: upto - INTEGER(I4B) :: ans - END FUNCTION obj_Size2 -END INTERFACE Size - -!---------------------------------------------------------------------------- -! GetIndices@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get Indices - -INTERFACE GetMultiIndices - MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices1(n, d) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_GetMultiIndices1 -END INTERFACE GetMultiIndices - -!---------------------------------------------------------------------------- -! GetIndices@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get Indices upto order n - -INTERFACE GetMultiIndices - MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - LOGICAL(LGT), INTENT(IN) :: upto - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_GetMultiIndices2 -END INTERFACE GetMultiIndices - -!---------------------------------------------------------------------------- -! Operator(.in.)@IntegerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another - -INTERFACE OPERATOR(.in.) - MODULE PURE FUNCTION in_1a(a, b) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1a - - MODULE PURE FUNCTION in_1b(a, b) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1b - - MODULE PURE FUNCTION in_1c(a, b) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1c - - MODULE PURE FUNCTION in_1d(a, b) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1d - -END INTERFACE OPERATOR(.in.) - -!---------------------------------------------------------------------------- -! Operator(.in.)@IntegerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another -! -!# Introduction -! -! This function returns a vector of booleans -! if a(i) is inside the b, then ans(i) is true, otherwise false. - -INTERFACE OPERATOR(.isin.) - MODULE PURE FUNCTION isin_1a(a, b) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1a - - MODULE PURE FUNCTION isin_1b(a, b) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1b - - MODULE PURE FUNCTION isin_1c(a, b) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1c - - MODULE PURE FUNCTION isin_1d(a, b) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1d -END INTERFACE OPERATOR(.isin.) - -!---------------------------------------------------------------------------- -! Operator(.in.)@IntegerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another - -INTERFACE OPERATOR(.in.) - - MODULE PURE FUNCTION in_2a(a, b) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a - INTEGER(INT8), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2a - - MODULE PURE FUNCTION in_2b(a, b) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a - INTEGER(INT16), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2b - - MODULE PURE FUNCTION in_2c(a, b) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a - INTEGER(INT32), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2c - - MODULE PURE FUNCTION in_2d(a, b) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a - INTEGER(INT64), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2d - -END INTERFACE OPERATOR(.in.) - -INTERFACE OPERATOR(.isin.) - MODULE PROCEDURE in_2a, in_2b, in_2c, in_2d -END INTERFACE OPERATOR(.isin.) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-12 -! summary: Remove duplicates entries - -INTERFACE RemoveDuplicates - MODULE PURE SUBROUTINE RemoveDuplicates_1a(obj) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1a - MODULE PURE SUBROUTINE RemoveDuplicates_1b(obj) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1b - MODULE PURE SUBROUTINE RemoveDuplicates_1c(obj) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1c - MODULE PURE SUBROUTINE RemoveDuplicates_1d(obj) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1d -END INTERFACE RemoveDuplicates - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-12 -! summary: Remove duplicates with no allocation - -INTERFACE RemoveDuplicates_ - MODULE PURE SUBROUTINE RemoveDuplicates_1a_(obj, tsize, isSorted) - INTEGER(INT8), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1a_ - - MODULE PURE SUBROUTINE RemoveDuplicates_1b_(obj, tsize, isSorted) - INTEGER(INT16), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1b_ - - MODULE PURE SUBROUTINE RemoveDuplicates_1c_(obj, tsize, isSorted) - INTEGER(INT32), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1c_ - - MODULE PURE SUBROUTINE RemoveDuplicates_1d_(obj, tsize, isSorted) - INTEGER(INT64), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1d_ - -END INTERFACE RemoveDuplicates_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE Repeat - MODULE PURE FUNCTION Repeat_1a(Val, rtimes) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT8) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1a - MODULE PURE FUNCTION Repeat_1b(Val, rtimes) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT16) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1b - MODULE PURE FUNCTION Repeat_1c(Val, rtimes) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT32) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1c - MODULE PURE FUNCTION Repeat_1d(Val, rtimes) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT64) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1d - MODULE PURE FUNCTION Repeat_1e(Val, rtimes) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - REAL(REAL32) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1e - MODULE PURE FUNCTION Repeat_1f(Val, rtimes) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - REAL(REAL64) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1f -END INTERFACE Repeat - -!---------------------------------------------------------------------------- -! getIndex@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PURE FUNCTION GetIndex1(obj, val) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: val - INTEGER(I4B) :: ans - END FUNCTION GetIndex1 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! getIndex@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PURE FUNCTION GetIndex2(obj, Val) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: Val(:) - INTEGER(I4B), ALLOCATABLE :: Ans(:) - END FUNCTION GetIndex2 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION Get1_Int8(val, indx) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT8) :: ans - END FUNCTION Get1_Int8 - - MODULE PURE FUNCTION Get1_Int16(val, indx) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT16) :: ans - END FUNCTION Get1_Int16 - - MODULE PURE FUNCTION Get1_Int32(val, indx) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT32) :: ans - END FUNCTION Get1_Int32 - - MODULE PURE FUNCTION Get1_Int64(val, indx) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT64) :: ans - END FUNCTION Get1_Int64 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION Get2_Int8(val, indx) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT8) :: ans(SIZE(indx)) - END FUNCTION Get2_Int8 - - MODULE PURE FUNCTION Get2_Int16(val, indx) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT16) :: ans(SIZE(indx)) - END FUNCTION Get2_Int16 - - MODULE PURE FUNCTION Get2_Int32(val, indx) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT32) :: ans(SIZE(indx)) - END FUNCTION Get2_Int32 - - MODULE PURE FUNCTION Get2_Int64(val, indx) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT64) :: ans(SIZE(indx)) - END FUNCTION Get2_Int64 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION Get3_Int8(val, istart, iend, stride) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT8) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int8 - - MODULE PURE FUNCTION Get3_Int16(val, istart, iend, stride) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT16) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int16 - - MODULE PURE FUNCTION Get3_Int32(val, istart, iend, stride) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT32) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int32 - - MODULE PURE FUNCTION Get3_Int64(val, istart, iend, stride) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT64) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int64 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! GetIntersection -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-22 -! summary: Get the intersection fo two integer vectors - -INTERFACE GetIntersection - MODULE PURE SUBROUTINE GetIntersection1(a, b, c, tsize) - INTEGER(INT8), INTENT(IN) :: a(:), b(:) - INTEGER(INT8), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection1 - - MODULE PURE SUBROUTINE GetIntersection2(a, b, c, tsize) - INTEGER(INT16), INTENT(IN) :: a(:), b(:) - INTEGER(INT16), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection2 - - MODULE PURE SUBROUTINE GetIntersection3(a, b, c, tsize) - INTEGER(INT32), INTENT(IN) :: a(:), b(:) - INTEGER(INT32), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection3 - - MODULE PURE SUBROUTINE GetIntersection4(a, b, c, tsize) - INTEGER(INT64), INTENT(IN) :: a(:), b(:) - INTEGER(INT64), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection4 -END INTERFACE GetIntersection - -!---------------------------------------------------------------------------- -! Get1DIndexFrom2DIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-14 -! summary: Convert (i,j) to ans from Fortran2D array to 1D array - -INTERFACE Get1DIndexFortran - MODULE PURE FUNCTION Get1DIndexFrom2DFortranIndex(i, j, dim1, dim2) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: i - INTEGER(I4B), INTENT(IN) :: j - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B) :: ans - END FUNCTION Get1DIndexFrom2DFortranIndex -END INTERFACE Get1DIndexFortran - -!---------------------------------------------------------------------------- -! Get1DIndexFrom2DIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-14 -! summary: Convert (i,j,k) to ans from Fortran3D array to 1D array - -INTERFACE Get1DIndexFortran - MODULE PURE FUNCTION Get1DIndexFrom3DFortranIndex(i, j, k, dim1, dim2, & - dim3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: i - INTEGER(I4B), INTENT(IN) :: j - INTEGER(I4B), INTENT(IN) :: k - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B) :: ans - END FUNCTION Get1DIndexFrom3DFortranIndex -END INTERFACE Get1DIndexFortran - -!---------------------------------------------------------------------------- -! Get1DIndexFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-14 -! summary: Convert (i,j,k,l) to ans from Fortran4D array to 1D array - -INTERFACE Get1DIndexFortran - MODULE PURE FUNCTION Get1DIndexFrom4DFortranIndex(i, j, k, l, dim1, dim2, & - dim3, dim4) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: i - INTEGER(I4B), INTENT(IN) :: j - INTEGER(I4B), INTENT(IN) :: k - INTEGER(I4B), INTENT(IN) :: l - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(I4B) :: ans - END FUNCTION Get1DIndexFrom4DFortranIndex -END INTERFACE Get1DIndexFortran - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE IntegerUtility diff --git a/src/modules/Utility/src/InvUtility.F90 b/src/modules/Utility/src/InvUtility.F90 deleted file mode 100644 index 0a2f3a961..000000000 --- a/src/modules/Utility/src/InvUtility.F90 +++ /dev/null @@ -1,94 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE InvUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: DET -PUBLIC :: INV - -!---------------------------------------------------------------------------- -! Det@InverseMethods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION det_2D(A) RESULT(Ans) - REAL(DFP), INTENT(IN) :: A(:, :) - REAL(DFP) :: Ans - END FUNCTION det_2D -END INTERFACE - -INTERFACE Det - MODULE PROCEDURE det_2D -END INTERFACE Det - -!---------------------------------------------------------------------------- -! Det@InverseMethods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION det_3D(A) RESULT(Ans) - REAL(DFP), INTENT(IN) :: A(:, :, :) - REAL(DFP), ALLOCATABLE :: Ans(:) - END FUNCTION det_3D -END INTERFACE - -INTERFACE Det - MODULE PROCEDURE det_3D -END INTERFACE Det - -!---------------------------------------------------------------------------- -! INV@InverseMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Inverse of small matrix upto size 4 - -INTERFACE - MODULE PURE SUBROUTINE Inv_2D(invA, A) - REAL(DFP), INTENT(INOUT) :: invA(:, :) - REAL(DFP), INTENT(IN) :: A(:, :) - END SUBROUTINE -END INTERFACE - -INTERFACE Inv - MODULE PROCEDURE Inv_2D -END INTERFACE Inv - -!---------------------------------------------------------------------------- -! INV@InverseMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Oct 2022 -! summary: Inverse of small matrix upto size 4 - -INTERFACE - MODULE PURE SUBROUTINE Inv_3D(invA, A) - REAL(DFP), INTENT(INOUT) :: invA(:, :, :) - REAL(DFP), INTENT(IN) :: A(:, :, :) - END SUBROUTINE -END INTERFACE - -INTERFACE Inv - MODULE PROCEDURE Inv_3D -END INTERFACE Inv - -END MODULE InvUtility diff --git a/src/modules/Utility/src/LinearAlgebraUtility.F90 b/src/modules/Utility/src/LinearAlgebraUtility.F90 deleted file mode 100644 index 0eb48c5df..000000000 --- a/src/modules/Utility/src/LinearAlgebraUtility.F90 +++ /dev/null @@ -1,48 +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 LinearAlgebraUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: InvHilbertMatrix -PUBLIC :: HilbertMatrix - -!---------------------------------------------------------------------------- -! InvHilbertMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION InvHilbertMatrix(n) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: Ans(n, n) - END FUNCTION InvHilbertMatrix -END INTERFACE - -!---------------------------------------------------------------------------- -! HilbertMatrix@Methods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION HilbertMatrix(n) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: n - REAL(DFP) :: Ans(n, n) - END FUNCTION HilbertMatrix -END INTERFACE - -END MODULE LinearAlgebraUtility diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 deleted file mode 100644 index 9ad5c7125..000000000 --- a/src/modules/Utility/src/MappingUtility.F90 +++ /dev/null @@ -1,966 +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: 19 Oct 2022 -! summary: Some methods related to standard mapping are defined -! -!{!pages/MappingUtility_.md!} - -MODULE MappingUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: FromBiunitLine2Segment -PUBLIC :: FromBiUnitLine2UnitLine -PUBLIC :: FromUnitLine2BiUnitLine -PUBLIC :: FromLine2Line_ - -PUBLIC :: FromBiUnitQuadrangle2Quadrangle -PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle -PUBLIC :: FromUnitQuadrangle2BiUnitQuadrangle - -PUBLIC :: FromBiUnitHexahedron2Hexahedron -PUBLIC :: FromBiUnitHexahedron2UnitHexahedron -PUBLIC :: FromUnitHexahedron2BiUnitHexahedron - -PUBLIC :: FromBiUnitTriangle2BiUnitSqr -PUBLIC :: FromBiUnitTriangle2BiUnitQuadrangle - -PUBLIC :: FromBiUnitSqr2BiUnitTriangle -PUBLIC :: FromBiUnitQuadrangle2BiUnitTriangle - -PUBLIC :: FromUnitTriangle2BiUnitSqr -PUBLIC :: FromUnitTriangle2BiUnitQuadrangle - -PUBLIC :: FromBiUnitSqr2UnitTriangle -PUBLIC :: FromBiUnitQuadrangle2UnitTriangle - -PUBLIC :: FromTriangle2Square_ - -PUBLIC :: FromUnitTriangle2Triangle - -PUBLIC :: BarycentricCoordUnitTriangle -!! This is function -PUBLIC :: BarycentricCoordBiUnitTriangle -!! This is function -PUBLIC :: BarycentricCoordTriangle -!! This is function -PUBLIC :: BarycentricCoordTriangle_ -!! This is a subroutine without allocation - -PUBLIC :: FromBiUnitTriangle2UnitTriangle -PUBLIC :: FromUnitTriangle2BiUnitTriangle - -PUBLIC :: FromTriangle2Triangle_ - -PUBLIC :: FromUnitTetrahedron2BiUnitTetrahedron -PUBLIC :: FromBiUnitTetrahedron2UnitTetrahedron -PUBLIC :: FromUnitTetrahedron2Tetrahedron -PUBLIC :: FromBiUnitTetrahedron2Tetrahedron -PUBLIC :: BarycentricCoordUnitTetrahedron -PUBLIC :: BarycentricCoordBiUnitTetrahedron -PUBLIC :: BarycentricCoordTetrahedron -PUBLIC :: FromBiUnitTetrahedron2BiUnitHexahedron -PUBLIC :: FromBiUnitHexahedron2BiUnitTetrahedron -PUBLIC :: FromUnitTetrahedron2BiUnitHexahedron -PUBLIC :: FromBiUnitHexahedron2UnitTetrahedron - -PUBLIC :: JacobianLine -PUBLIC :: JacobianTriangle -PUBLIC :: JacobianQuadrangle -PUBLIC :: JacobianHexahedron -PUBLIC :: JacobianTetrahedron -! PUBLIC :: JacobianPrism -! PUBLIC :: JacobianPyramid - -!---------------------------------------------------------------------------- -! FromBiunitLine2Segment -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to physical space - -INTERFACE - MODULE PURE FUNCTION FromBiunitLine2Segment1(xin, x1, x2) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:) - !! coordinates in [-1,1] - REAL(DFP), INTENT(IN) :: x1 - !! x1 of physical domain - REAL(DFP), INTENT(IN) :: x2 - !! x2 of physical domain - REAL(DFP) :: ans(SIZE(xin)) - !! mapped coordinates of xin in physical domain - END FUNCTION FromBiunitLine2Segment1 -END INTERFACE - -INTERFACE FromBiunitLine2Segment - MODULE PROCEDURE FromBiunitLine2Segment1 -END INTERFACE FromBiunitLine2Segment - -!---------------------------------------------------------------------------- -! FromBiunitLine2Segment -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to physical space - -INTERFACE - MODULE PURE FUNCTION FromBiunitLine2Segment2(xin, x1, x2) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:) - !! coordinates in [-1,1], SIZE(xin) = n - REAL(DFP), INTENT(IN) :: x1(:) - !! x1 of physical domain, SIZE(x1) = nsd - REAL(DFP), INTENT(IN) :: x2(:) - !! x2 of physical domain, SIZE(x2) = nsd - REAL(DFP) :: ans(SIZE(x1), SIZE(xin)) - !! returned coordinates in physical space - !! ans is in xij format - END FUNCTION FromBiunitLine2Segment2 -END INTERFACE - -INTERFACE FromBiunitLine2Segment - MODULE PROCEDURE FromBiunitLine2Segment2 -END INTERFACE FromBiunitLine2Segment - -!---------------------------------------------------------------------------- -! FromUnitTriangle2Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to physical space - -INTERFACE FromUnitTriangle2Triangle - MODULE PURE FUNCTION FromUnitTriangle2Triangle1(xin, x1, x2, x3) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! vertex coordinate of unit triangle - !! (0,0), (1,0), (0,1) - !! shape(xin) = (2,N) - REAL(DFP), INTENT(IN) :: x1(:) - !! x1 of physical domain, size(x1) = nsd - REAL(DFP), INTENT(IN) :: x2(:) - !! x2 of physical domain, size(x2) = nsd - REAL(DFP), INTENT(IN) :: x3(:) - !! x3 of physical domain, size(x3) = nsd - REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) - !! mapped coordinates of xin in physical domain - !! shape(ans) = nsd, N - END FUNCTION FromUnitTriangle2Triangle1 -END INTERFACE FromUnitTriangle2Triangle - -!---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to physical space - -INTERFACE FromBiUnitQuadrangle2UnitQuadrangle - MODULE PURE FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1(xin) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! vertex coordinate of biunit Quadrangle in xij format - !! SIZE(xin,1) = 2 - REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) - !! mapped coordinates of xin in physical domain - !! shape(ans) = nsd, N - END FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1 -END INTERFACE FromBiUnitQuadrangle2UnitQuadrangle - -!---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to physical space - -INTERFACE FromUnitQuadrangle2BiUnitQuadrangle - MODULE PURE FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1(xin) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! vertex coordinate of biunit Quadrangle in xij format - !! SIZE(xin,1) = 2 - REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) - !! mapped coordinates of xin in physical domain - !! shape(ans) = nsd, N - END FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1 -END INTERFACE FromUnitQuadrangle2BiUnitQuadrangle - -!---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to physical space - -INTERFACE FromBiUnitQuadrangle2Quadrangle - MODULE PURE FUNCTION FromBiUnitQuadrangle2Quadrangle1(xin, x1, x2, x3, x4) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! vertex coordinate of biunit Quadrangle in xij format - !! SIZE(xin,1) = 2 - REAL(DFP), INTENT(IN) :: x1(:) - !! vertex x1 of physical domain, size(x1) = nsd - REAL(DFP), INTENT(IN) :: x2(:) - !! vertex x2 of physical domain, size(x2) = nsd - REAL(DFP), INTENT(IN) :: x3(:) - !! vertex x3 of physical domain, size(x3) = nsd - REAL(DFP), INTENT(IN) :: x4(:) - !! vertex x4 of physical domain, size(x4) = nsd - REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) - !! mapped coordinates of xin in physical domain - !! shape(ans) = nsd, N - END FUNCTION FromBiUnitQuadrangle2Quadrangle1 -END INTERFACE FromBiUnitQuadrangle2Quadrangle - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to physical space - -INTERFACE FromBiUnitHexahedron2Hexahedron - MODULE PURE FUNCTION FromBiUnitHexahedron2Hexahedron1(xin, & - & x1, x2, x3, x4, x5, x6, x7, x8) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! vertex coordinate of biunit Hexahedron in xij format - !! SIZE(xin,1) = 3 - REAL(DFP), INTENT(IN) :: x1(:) - !! vertex x1 of physical domain, size(x1) = nsd - REAL(DFP), INTENT(IN) :: x2(:) - !! vertex x2 of physical domain, size(x2) = nsd - REAL(DFP), INTENT(IN) :: x3(:) - !! vertex x3 of physical domain, size(x3) = nsd - REAL(DFP), INTENT(IN) :: x4(:) - !! vertex x4 of physical domain, size(x4) = nsd - REAL(DFP), INTENT(IN) :: x5(:) - !! vertex x5 of physical domain, size(x5) = nsd - REAL(DFP), INTENT(IN) :: x6(:) - !! vertex x6 of physical domain, size(x6) = nsd - REAL(DFP), INTENT(IN) :: x7(:) - !! vertex x7 of physical domain, size(x7) = nsd - REAL(DFP), INTENT(IN) :: x8(:) - !! vertex x8 of physical domain, size(x8) = nsd - REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) - !! mapped coordinates of xin in physical domain - !! shape(ans) = nsd, N - END FUNCTION FromBiUnitHexahedron2Hexahedron1 -END INTERFACE FromBiUnitHexahedron2Hexahedron - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from biunit hexahedron to unit hexahedron - -INTERFACE FromBiUnitHexahedron2UnitHexahedron - MODULE PURE FUNCTION FromBiUnitHexahedron2UnitHexahedron1(xin) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! vertex coordinate of biunit Hexahedron in xij format - !! SIZE(xin,1) = 3 - REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) - !! mapped coordinates of xin in physical domain - !! shape(ans) = nsd, N - END FUNCTION FromBiUnitHexahedron2UnitHexahedron1 -END INTERFACE FromBiUnitHexahedron2UnitHexahedron - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2Hexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit hexahedron to biunit hexahedron - -INTERFACE FromUnitHexahedron2BiUnitHexahedron - MODULE PURE FUNCTION FromUnitHexahedron2BiUnitHexahedron1(xin) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! vertex coordinate of biunit Hexahedron in xij format - !! SIZE(xin,1) = 3 - REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) - !! mapped coordinates of xin in physical domain - !! shape(ans) = nsd, N - END FUNCTION FromUnitHexahedron2BiUnitHexahedron1 -END INTERFACE FromUnitHexahedron2BiUnitHexahedron - -!---------------------------------------------------------------------------- -! FromBiUnitLine2UnitLine -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from biunit line to unit line -! -!# Introduction -! -!- Bi unit line is defined by -1 to 1. -!- Unit line is defined by 0 to 1 - -INTERFACE - MODULE PURE FUNCTION FromBiUnitLine2UnitLine(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:) - !! coordinates in biunit line - REAL(DFP) :: ans(SIZE(xin)) - !! mapped coordinates of xin in unit line - END FUNCTION FromBiUnitLine2UnitLine -END INTERFACE - -!---------------------------------------------------------------------------- -! FromUnitLine2BiUnitLine -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from unit line to biunit line -! -!# Introduction -! -!- Bi unit line is defined by -1 to 1. -!- Unit line is defined by 0 to 1 - -INTERFACE - MODULE PURE FUNCTION FromUnitLine2BiUnitLine(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:) - !! coordinates in unit line - REAL(DFP) :: ans(SIZE(xin)) - !! mapped coordinates of xin in biunit line - END FUNCTION FromUnitLine2BiUnitLine -END INTERFACE - -!---------------------------------------------------------------------------- -! FromLine2Line_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-27 -! summary: Map line to line - -INTERFACE - MODULE PURE SUBROUTINE FromLine2Line_(xin, ans, from, to) - REAL(DFP), INTENT(IN) :: xin(:) - !! coordinates in unit line - REAL(DFP), INTENT(INOUT) :: ans(:) - !! mapped coordinates of xin in biunit line - CHARACTER(*), INTENT(IN) :: from - CHARACTER(*), INTENT(IN) :: to - END SUBROUTINE FromLine2Line_ -END INTERFACE - -!---------------------------------------------------------------------------- -! FromBiUnitTriangle2BiUnitSqr -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from biunit triangle to bi-unit square -! -!# Introduction -! -!- Bi unit triangle is defined by (-1,-1), (1,-1), and (-1,1) -!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) - -INTERFACE FromBiUnitTriangle2BiUnitQuadrangle - MODULE PURE FUNCTION FromBiUnitTriangle2BiUnitSqr(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in biunit triangle in xij format - !! bi unit triangle is defined by - !! (-1,-1), (1,-1), (-1,1) - REAL(DFP) :: ans(2, SIZE(xin, 2)) - !! mapped coordinates of xin in biunit sqr - END FUNCTION FromBiUnitTriangle2BiUnitSqr -END INTERFACE FromBiUnitTriangle2BiUnitQuadrangle - -!---------------------------------------------------------------------------- -! FromBiUnitSqr2BiUnitTriangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from biunit triangle to bi-unit square -! -!# Introduction -! -!- Bi unit triangle is defined by (-1,-1), (1,-1), and (-1,1) -!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) - -INTERFACE FromBiUnitQuadrangle2BiUnitTriangle - MODULE PURE FUNCTION FromBiUnitSqr2BiUnitTriangle(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in bi-unit square in xij coordinate - REAL(DFP) :: ans(2, SIZE(xin, 2)) - !! coordinates in biunit triangle - END FUNCTION FromBiUnitSqr2BiUnitTriangle -END INTERFACE FromBiUnitQuadrangle2BiUnitTriangle - -!---------------------------------------------------------------------------- -! FromUnitTriangle2BiUnitSqr -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from biunit triangle to bi-unit square -! -!# Introduction -! -!- Unit triangle is defined by (0,0), (0,1), and (1,0) -!- Biunit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) - -INTERFACE FromUnitTriangle2BiUnitQuadrangle - MODULE PURE FUNCTION FromUnitTriangle2BiUnitSqr(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in biunit triangle in xij format - !! bi unit triangle is defined by - !! (-1,-1), (1,-1), (-1,1) - REAL(DFP) :: ans(2, SIZE(xin, 2)) - !! mapped coordinates of xin in biunit sqr - END FUNCTION FromUnitTriangle2BiUnitSqr -END INTERFACE FromUnitTriangle2BiUnitQuadrangle - -!---------------------------------------------------------------------------- -! FromBiUnitSqr2UnitTriangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from biunit triangle to bi-unit square -! -!# Introduction -! -!- Unit triangle is defined by (0,0), (0,1), and (1,0) -!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) - -INTERFACE FromBiUnitQuadrangle2UnitTriangle - MODULE PURE FUNCTION FromBiUnitSqr2UnitTriangle(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in bi-unit square in xij coordinate - REAL(DFP) :: ans(2, SIZE(xin, 2)) - !! coordinates in biunit triangle - END FUNCTION FromBiUnitSqr2UnitTriangle -END INTERFACE FromBiUnitQuadrangle2UnitTriangle - -!---------------------------------------------------------------------------- -! FromTriangle2Triangle_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from triangle to square - -INTERFACE - MODULE PURE SUBROUTINE FromTriangle2Triangle_(xin, ans, from, to, x1, x2, x3) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in bi-unit square in xij coordinate - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(2, SIZE(xin, 2)) - !! coordinates in biunit triangle - CHARACTER(*), INTENT(IN) :: from - CHARACTER(*), INTENT(IN) :: to - REAL(DFP), OPTIONAL, INTENT(IN) :: x1(:) - !! x1 of physical domain, size(x1) = nsd - REAL(DFP), OPTIONAL, INTENT(IN) :: x2(:) - !! x2 of physical domain, size(x2) = nsd - REAL(DFP), OPTIONAL, INTENT(IN) :: x3(:) - !! x3 of physical domain, size(x3) = nsd - END SUBROUTINE FromTriangle2Triangle_ -END INTERFACE - -!---------------------------------------------------------------------------- -! FromTriangle2Square_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from triangle to square - -INTERFACE - MODULE PURE SUBROUTINE FromTriangle2Square_(xin, ans, from, to) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in bi-unit square in xij coordinate - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(2, SIZE(xin, 2)) - !! coordinates in biunit triangle - CHARACTER(*), INTENT(IN) :: from - CHARACTER(*), INTENT(IN) :: to - END SUBROUTINE FromTriangle2Square_ -END INTERFACE - -!---------------------------------------------------------------------------- -! FromSquare2Triangle_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 19 Oct 2022 -! summary: Map from triangle to square - -INTERFACE - MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in bi-unit square in xij coordinate - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(2, SIZE(xin, 2)) - !! coordinates in biunit triangle - CHARACTER(*), INTENT(IN) :: from - CHARACTER(*), INTENT(IN) :: to - END SUBROUTINE FromSquare2Triangle_ -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCoordUnitTriangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns barycentric coord of unit triangle - -INTERFACE - MODULE PURE FUNCTION BarycentricCoordUnitTriangle(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(3, SIZE(xin, 2)) - END FUNCTION BarycentricCoordUnitTriangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCoordBiUnitTriangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns barycentric coord of unit triangle - -INTERFACE - MODULE PURE FUNCTION BarycentricCoordBiUnitTriangle(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(3, SIZE(xin, 2)) - END FUNCTION BarycentricCoordBiUnitTriangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCoordTriangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION BarycentricCoordTriangle(xin, refTriangle) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(3, SIZE(xin, 2)) - CHARACTER(*), INTENT(IN) :: refTriangle - !! "UNIT" - !! "BIUNIT" - END FUNCTION BarycentricCoordTriangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCoordTriangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE BarycentricCoordTriangle_(xin, refTriangle, ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(3, SIZE(xin, 2)) - CHARACTER(*), INTENT(IN) :: refTriangle - !! "UNIT" - !! "BIUNIT" - END SUBROUTINE BarycentricCoordTriangle_ -END INTERFACE - -!---------------------------------------------------------------------------- -! FromBiUnitTriangle2UnitTriangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns barycentric coord of unit triangle - -INTERFACE - MODULE PURE FUNCTION FromBiUnitTriangle2UnitTriangle(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(2, SIZE(xin, 2)) - END FUNCTION FromBiUnitTriangle2UnitTriangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FromUnitTriangle2BiUnitTriangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns barycentric coord of unit triangle - -INTERFACE - MODULE PURE FUNCTION FromUnitTriangle2BiUnitTriangle(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(2, SIZE(xin, 2)) - END FUNCTION FromUnitTriangle2BiUnitTriangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FromBiUnitTetrahedron2UnitTetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Biunit Tetrahedron to Unit tetrahedron - -INTERFACE - MODULE PURE FUNCTION FromBiUnitTetrahedron2UnitTetrahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(3, SIZE(xin, 2)) - END FUNCTION FromBiUnitTetrahedron2UnitTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FromUnitTetrahedron2BiUnitTetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Unit Tetrahedron to biunit tetrahedron - -INTERFACE - MODULE PURE FUNCTION FromUnitTetrahedron2BiUnitTetrahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(3, SIZE(xin, 2)) - END FUNCTION FromUnitTetrahedron2BiUnitTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FromBiUnitTetrahedron2Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Biunit Tetrahedron to tetrahedron - -INTERFACE - MODULE PURE FUNCTION FromBiUnitTetrahedron2Tetrahedron( & - & xin, & - & x1, & - & x2, & - & x3, & - & x4) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP), INTENT(IN) :: x1(3) - !! Coordinate of tetrahedron node 1 - REAL(DFP), INTENT(IN) :: x2(3) - !! Coordinate of tetrahedron node 2 - REAL(DFP), INTENT(IN) :: x3(3) - !! Coordinate of tetrahedron node 3 - REAL(DFP), INTENT(IN) :: x4(3) - !! Coordinate of tetrahedron node 4 - REAL(DFP) :: ans(3, SIZE(xin, 2)) - END FUNCTION FromBiUnitTetrahedron2Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FromUnitTetrahedron2Tetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-27 -! summary: Unit Tetrahedron to tetrahedron - -INTERFACE - MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron( & - & xin, & - & x1, & - & x2, & - & x3, & - & x4) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP), INTENT(IN) :: x1(3) - !! Coordinate of tetrahedron node 1 - REAL(DFP), INTENT(IN) :: x2(3) - !! Coordinate of tetrahedron node 2 - REAL(DFP), INTENT(IN) :: x3(3) - !! Coordinate of tetrahedron node 3 - REAL(DFP), INTENT(IN) :: x4(3) - !! Coordinate of tetrahedron node 4 - REAL(DFP) :: ans(3, SIZE(xin, 2)) - END FUNCTION FromUnitTetrahedron2Tetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCoordUnitTetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns barycentric coord of unit triangle - -INTERFACE - MODULE PURE FUNCTION BarycentricCoordUnitTetrahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(4, SIZE(xin, 2)) - END FUNCTION BarycentricCoordUnitTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCoordBiUnitTetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns barycentric coord of unit triangle - -INTERFACE - MODULE PURE FUNCTION BarycentricCoordBiUnitTetrahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(4, SIZE(xin, 2)) - END FUNCTION BarycentricCoordBiUnitTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricCoordTetrahedron -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION BarycentricCoordTetrahedron(xin, refTetrahedron) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - REAL(DFP) :: ans(4, SIZE(xin, 2)) - CHARACTER(*), INTENT(IN) :: refTetrahedron - !! "UNIT" - !! "BIUNIT" - END FUNCTION BarycentricCoordTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FromBiUnitTetrahedron2BiUnitHexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-27 -! summary: Map from biunit tetrahedron to bi-unit Hexahedron - -INTERFACE - MODULE PURE FUNCTION FromBiUnitTetrahedron2BiUnitHexahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in biunit tetrahedron in xij format - REAL(DFP) :: ans(3, SIZE(xin, 2)) - !! mapped coordinates of xin in biunit hexahedron - END FUNCTION FromBiUnitTetrahedron2BiUnitHexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2BiUnitTetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-27 -! summary: Map from biunit hexahedron to biunit tetrahedron - -INTERFACE - MODULE PURE FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in bi-unit hexahedron in xij coordinate - REAL(DFP) :: ans(3, SIZE(xin, 2)) - !! coordinates in biunit tetrahedron - END FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FromUnitTetrahedron2BiUnitHexahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-27 -! summary: Map from unit tetrahedron to bi-unit Hexahedron - -INTERFACE - MODULE PURE FUNCTION FromUnitTetrahedron2BiUnitHexahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in unit tetrahedron in xij format - REAL(DFP) :: ans(3, SIZE(xin, 2)) - !! mapped coordinates of xin in biunit hexahedron - END FUNCTION FromUnitTetrahedron2BiUnitHexahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2BiUnitTetrahedron -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-27 -! summary: Map from unit hexahedron to biunit tetrahedron - -INTERFACE - MODULE PURE FUNCTION FromBiUnitHexahedron2UnitTetrahedron(xin) RESULT(ans) - REAL(DFP), INTENT(IN) :: xin(:, :) - !! coordinates in biunit hexahedron in xij coordinate - REAL(DFP) :: ans(3, SIZE(xin, 2)) - !! coordinates in unit tetrahedron - END FUNCTION FromBiUnitHexahedron2UnitTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobianLine -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION JacobianLine(from, to, xij) RESULT(ans) - CHARACTER(*), INTENT(IN) :: from - !! BIUNIT - !! UNIT - !! LINE - CHARACTER(*), INTENT(IN) :: to - !! BIUNIT - !! UNIT - !! LINE - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of general line (segment) - !! number of rows=1 - !! number of cols=2 - !! xij is needed when from or to are LINE - !! both from and to cannot be LINE - REAL(DFP) :: ans - END FUNCTION JacobianLine -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobianTriangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION JacobianTriangle(from, to, xij) RESULT(ans) - CHARACTER(*), INTENT(IN) :: from - !! BIUNIT - !! UNIT - !! TRIANGLE - CHARACTER(*), INTENT(IN) :: to - !! BIUNIT - !! UNIT - !! TRIANGLE - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of general TRIANGLE - !! number of rows=nsd - !! number of cols=3 - !! xij is needed when `from` or `to` is TRIANGLE - !! both `from` and to `cannot` be TRIANGLE - REAL(DFP) :: ans - END FUNCTION JacobianTriangle -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobianQuadrangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION JacobianQuadrangle(from, to, xij) RESULT(ans) - CHARACTER(*), INTENT(IN) :: from - !! BIUNIT - !! UNIT - !! QUADRANGLE - CHARACTER(*), INTENT(IN) :: to - !! BIUNIT - !! UNIT - !! QUADRANGLE - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of general QUADRANGLE - !! number of rows=nsd - !! number of cols=4 - !! xij is needed when `from` or `to` is QUADRANGLE - !! both `from` and to `cannot` be QUADRANGLE - REAL(DFP) :: ans - END FUNCTION JacobianQuadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobianTetrahedron -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION JacobianTetrahedron(from, to, xij) RESULT(ans) - CHARACTER(*), INTENT(IN) :: from - !! BIUNIT - !! UNIT - !! TETRAHEDRON - CHARACTER(*), INTENT(IN) :: to - !! BIUNIT - !! UNIT - !! TETRAHEDRON - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of general TETRAHEDRON - !! number of rows=nsd - !! number of cols=4 - !! xij is needed when `from` or `to` is TETRAHEDRON - !! both `from` and to `cannot` be TETRAHEDRON - REAL(DFP) :: ans - END FUNCTION JacobianTetrahedron -END INTERFACE - -!---------------------------------------------------------------------------- -! JacobianHexahedron -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION JacobianHexahedron(from, to, xij) RESULT(ans) - CHARACTER(*), INTENT(IN) :: from - !! BIUNIT - !! UNIT - !! HEXAHEDRON - CHARACTER(*), INTENT(IN) :: to - !! BIUNIT - !! UNIT - !! HEXAHEDRON - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! nodal coordinates of general HEXAHEDRON - !! number of rows=nsd - !! number of cols=4 - !! xij is needed when `from` or `to` is HEXAHEDRON - !! both `from` and to `cannot` be HEXAHEDRON - REAL(DFP) :: ans - END FUNCTION JacobianHexahedron -END INTERFACE - -! !---------------------------------------------------------------------------- -! ! JacobianPrism -! !---------------------------------------------------------------------------- -! -! INTERFACE -! MODULE PURE FUNCTION JacobianPrism(from, to) RESULT(ans) -! CHARACTER(*), INTENT(IN) :: from -! CHARACTER(*), INTENT(IN) :: to -! REAL(DFP) :: ans -! END FUNCTION JacobianPrism -! END INTERFACE -! -! !---------------------------------------------------------------------------- -! ! JacobianPyramid -! !---------------------------------------------------------------------------- -! -! INTERFACE -! MODULE PURE FUNCTION JacobianPyramid(from, to) RESULT(ans) -! CHARACTER(*), INTENT(IN) :: from -! CHARACTER(*), INTENT(IN) :: to -! REAL(DFP) :: ans -! END FUNCTION JacobianPyramid -! END INTERFACE - -END MODULE MappingUtility diff --git a/src/modules/Utility/src/MatmulUtility.F90 b/src/modules/Utility/src/MatmulUtility.F90 deleted file mode 100644 index 1fb96640e..000000000 --- a/src/modules/Utility/src/MatmulUtility.F90 +++ /dev/null @@ -1,352 +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 MatmulUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: MATMUL - -!---------------------------------------------------------------------------- -! 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 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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r4_r1 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank4 and rank1 array -! -!# Introduction -! -! `ans(i,j,k,m) = a1(i,j,k,l)*a2(l,m)` - -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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r4_r2 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank4 and rank1 array -! -!# Introduction -! -! `ans(i,j,k,m,n) = a1(i,j,k,l)*a2(l,m,n)` - -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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r4_r3 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank4 and rank1 array -! -!# Introduction -! -! `ans(i,j,k,m,n,o) = a1(i,j,k,l)*a2(l,m,n,o)` - -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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r4_r4 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank3 and rank1 array -! -!# Introduction -! -! This fuction performs following task -! `ans(i,j) = a1(i,j,k)*a2(k)` - -INTERFACE - 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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r3_r1 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank3 and rank2 -! -!# Introduction -! This fuction performs following task -! `ans(i,j,l) = a1(i,j,k)*a2(k,l)` - -INTERFACE - 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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r3_r2 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank4 and rank1 array -! -!# Introduction -! -! `ans(i,j,l,m) = a1(i,j,k) * a2(k,l,m)` - -INTERFACE - MODULE PURE FUNCTION matmul_r3_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(a2, 2), size(a2, 3)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r3_r3 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank4 and rank1 array -! -!# Introduction -! -! `ans(i,j,l,m,n) = a1(i,j,k) * a2(k,l,m,n)` - -INTERFACE - MODULE PURE FUNCTION matmul_r3_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(a2, 2), size(a2, 3), size(a2, 4)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r3_r4 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank2 and rank3 array -! -!# Introduction -! -! This fuction performs following task -! `ans(i,k,l) = a1(i,j)*a2(j,k,l)` - -INTERFACE - 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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r2_r3 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank2 and rank3 array -! -!# Introduction -! -! This fuction performs following task -! `ans(i,k,l,m) = a1(i,j)*a2(j,k,l,m)` - -INTERFACE - 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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r2_r4 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank1 and rank3 array -! -!# Introduction -! -! This fuction performs following task -! `ans = a1(i)*a2(i)` - -INTERFACE - MODULE PURE FUNCTION matmul_r1_r1(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:) - REAL(DFP), INTENT(IN) :: a2(:) - REAL(DFP) :: ans - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r1_r1 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank1 and rank3 array -! -!# Introduction -! -! This fuction performs following task -! `ans(j,k) = a1(i)*a2(i,j,k)` - -INTERFACE - 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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r1_r3 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! Matmul@Matmul -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: matmul for rank4 and rank1 array -! -!# Introduction -! -! `ans(j,k,l) = a1(i) * a2(i,j,k,l)` - -INTERFACE - 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)) - END FUNCTION -END INTERFACE - -INTERFACE MATMUL - MODULE PROCEDURE matmul_r1_r4 -END INTERFACE MATMUL - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE MatmulUtility \ No newline at end of file diff --git a/src/modules/Utility/src/MedianUtility.F90 b/src/modules/Utility/src/MedianUtility.F90 deleted file mode 100644 index e98bf452d..000000000 --- a/src/modules/Utility/src/MedianUtility.F90 +++ /dev/null @@ -1,131 +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 MedianUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: Median -PUBLIC :: ArgMedian - -!---------------------------------------------------------------------------- -! Median -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Given three numbers, find their median and sort at the same time - -INTERFACE Median - MODULE PURE SUBROUTINE Median_Int8(this, left, mid, right) - INTEGER(INT8), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE Median_Int8 - - MODULE PURE SUBROUTINE Median_Int16(this, left, mid, right) - INTEGER(INT16), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE Median_Int16 - - MODULE PURE SUBROUTINE Median_Int32(this, left, mid, right) - INTEGER(INT32), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE Median_Int32 - - MODULE PURE SUBROUTINE Median_Int64(this, left, mid, right) - INTEGER(INT64), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE Median_Int64 - - MODULE PURE SUBROUTINE Median_Real32(this, left, mid, right) - REAL(REAL32), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE Median_Real32 - - MODULE PURE SUBROUTINE Median_Real64(this, left, mid, right) - REAL(REAL64), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE Median_Real64 -END INTERFACE Median - -!---------------------------------------------------------------------------- -! ArgMedian -!---------------------------------------------------------------------------- - -INTERFACE ArgMedian - MODULE PURE SUBROUTINE ArgMedian_Int8(this, indx, left, mid, right) - INTEGER(INT8), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: indx(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE ArgMedian_Int8 - - MODULE PURE SUBROUTINE ArgMedian_Int16(this, indx, left, mid, right) - INTEGER(INT16), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: indx(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE ArgMedian_Int16 - - MODULE PURE SUBROUTINE ArgMedian_Int32(this, indx, left, mid, right) - INTEGER(INT32), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: indx(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE ArgMedian_Int32 - - MODULE PURE SUBROUTINE ArgMedian_Int64(this, indx, left, mid, right) - INTEGER(INT64), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: indx(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE ArgMedian_Int64 - - MODULE PURE SUBROUTINE ArgMedian_Real32(this, indx, left, mid, right) - REAL(REAL32), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: indx(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE ArgMedian_Real32 - - MODULE PURE SUBROUTINE ArgMedian_Real64(this, indx, left, mid, right) - REAL(REAL64), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: indx(:) - INTEGER(I4B), INTENT(IN) :: left - INTEGER(I4B), INTENT(IN) :: mid - INTEGER(I4B), INTENT(IN) :: right - END SUBROUTINE ArgMedian_Real64 -END INTERFACE ArgMedian - -END MODULE MedianUtility diff --git a/src/modules/Utility/src/MiscUtility.F90 b/src/modules/Utility/src/MiscUtility.F90 deleted file mode 100644 index b50d156f3..000000000 --- a/src/modules/Utility/src/MiscUtility.F90 +++ /dev/null @@ -1,384 +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 MiscUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: radian -PUBLIC :: Degrees -PUBLIC :: SearchNearestCoord -PUBLIC :: ExecuteCommand -PUBLIC :: getUnitNo -PUBLIC :: Factorial -PUBLIC :: Int2Str -PUBLIC :: Real2Str -PUBLIC :: ARTH -PUBLIC :: outerdiff -PUBLIC :: IMAXLOC -PUBLIC :: IMINLOC -PUBLIC :: IMG - -!---------------------------------------------------------------------------- -! Radian@MISC -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! Convert degrees into radian - -INTERFACE - MODULE PURE FUNCTION radian_dfp(deg) RESULT(Ans) - REAL(DFP), INTENT(IN) :: deg - REAL(DFP) :: Ans - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! Radian@MISC -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! Converts degrees into radian - -INTERFACE - MODULE PURE FUNCTION radian_int(deg) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: deg - REAL(DFP) :: Ans - END FUNCTION -END INTERFACE - -INTERFACE radian - MODULE PROCEDURE radian_dfp, radian_int -END INTERFACE - -!---------------------------------------------------------------------------- -! Degrees@MISC -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This function converts radian into degrees -! Belongs to `Degrees` - -INTERFACE - MODULE PURE FUNCTION degrees_dfp(rad) RESULT(Ans) - REAL(DFP), INTENT(IN) :: rad - REAL(DFP) :: Ans - END FUNCTION -END INTERFACE - -INTERFACE Degrees - MODULE PROCEDURE degrees_dfp -END INTERFACE Degrees - -!---------------------------------------------------------------------------- -! @MISC -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Search the loc of nearest point to x in the array -! -!# Introduction -! -! This subroutine search the location of nearest point to x in the -! array of coordinates; Array -! -! ## Usage -! ```fortran -! real( dfp ) :: xij( 2, 20 ), x( 2 ) -! integer( i4b ) :: id -! -! call random_number( xij ) -! x = [11.0, 100.0] -! xij( 1:2, 15 ) = x -! id = searchNearestCoord(Array=xij, x=x) -! call display( id==15, "test4:: " ) -!``` - -INTERFACE - MODULE FUNCTION Loc_Nearest_Point(Array, x) RESULT(id) - REAL(DFP), INTENT(IN) :: Array(:, :) - !! Nodal coordinates in XiJ format - REAL(DFP), INTENT(IN) :: x(:) - INTEGER(I4B) :: id - END FUNCTION -END INTERFACE - -INTERFACE LOC_NearestPoint - MODULE PROCEDURE Loc_Nearest_Point -END INTERFACE LOC_NearestPoint - -PUBLIC :: LOC_NearestPoint - -INTERFACE SearchNearestCoord - MODULE PROCEDURE Loc_Nearest_Point -END INTERFACE SearchNearestCoord - -!---------------------------------------------------------------------------- -! ExecuteCommand@MISC -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: This subroutine run a system commoand on terminal - -INTERFACE - MODULE SUBROUTINE exe_cmd(CMD, Str) - CHARACTER(LEN=*), INTENT(IN) :: CMD, Str - END SUBROUTINE -END INTERFACE - -INTERFACE ExecuteCommand - MODULE PROCEDURE exe_cmd -END INTERFACE ExecuteCommand - -!---------------------------------------------------------------------------- -! getUnitNo@MISC -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION getUnitNo_1() RESULT(ans) - INTEGER(I4B) :: ans - END FUNCTION getUnitNo_1 -END INTERFACE - -INTERFACE getUnitNo - MODULE PROCEDURE getUnitNo_1 -END INTERFACE getUnitNo - -!---------------------------------------------------------------------------- -! Factorial@MISC -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: This FUNCTION computes the factorial of an INTEGER - -INTERFACE - MODULE PURE RECURSIVE FUNCTION Factorial(N) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: N - INTEGER(I4B) :: Ans - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! Int2STR@MISC -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 April 2021 -! summary: Convert INTEGER to string - -INTERFACE - MODULE PURE FUNCTION Int2Str(I) - INTEGER(I4B), INTENT(IN) :: I - CHARACTER(LEN=15) :: Int2Str - END FUNCTION -END INTERFACE - -!---------------------------------------------------------------------------- -! Real2Str@MISC -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION SP2Str(I) - REAL(SP), INTENT(IN) :: I - CHARACTER(LEN=20) :: SP2Str - END FUNCTION -END INTERFACE - -INTERFACE - MODULE FUNCTION DP2Str(I) - REAL(DP), INTENT(IN) :: I - CHARACTER(LEN=20) :: DP2Str - END FUNCTION -END INTERFACE - -INTERFACE Real2Str - MODULE PROCEDURE SP2Str, DP2Str -END INTERFACE Real2Str - -!---------------------------------------------------------------------------- -! ARTH -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION arth_r(first, increment, n) - REAL(SP), INTENT(IN) :: first, increment - INTEGER(I4B), INTENT(IN) :: n - REAL(SP) :: arth_r(n) - END FUNCTION -END INTERFACE - -INTERFACE - MODULE PURE FUNCTION arth_d(first, increment, n) - REAL(DP), INTENT(IN) :: first, increment - INTEGER(I4B), INTENT(IN) :: n - REAL(DP) :: arth_d(n) - END FUNCTION -END INTERFACE - -INTERFACE - MODULE PURE FUNCTION arth_i(first, increment, n) - INTEGER(I4B), INTENT(IN) :: first, increment, n - INTEGER(I4B) :: arth_i(n) - END FUNCTION -END INTERFACE - -INTERFACE ARTH - MODULE PROCEDURE arth_d, arth_i, arth_r -END INTERFACE ARTH - -!---------------------------------------------------------------------------- -! outerdiff@MISC -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION outerdiff_r(a, b) - REAL(SP), DIMENSION(:), INTENT(IN) :: a, b - 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 - 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 - END FUNCTION -END INTERFACE - -INTERFACE outerdiff - MODULE PROCEDURE outerdiff_r, outerdiff_i, outerdiff_d -END INTERFACE - -!---------------------------------------------------------------------------- -! IMAXLOC@MISC -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION imaxloc_r(arr) - REAL(DFP), INTENT(IN) :: arr(:) - INTEGER(I4B) :: imaxloc_r - END FUNCTION -END INTERFACE - -INTERFACE - MODULE PURE FUNCTION imaxloc_i(iarr) - INTEGER(I4B), INTENT(IN) :: iarr(:) - INTEGER(I4B) :: imaxloc_i - END FUNCTION -END INTERFACE - -INTERFACE IMAXLOC - MODULE PROCEDURE imaxloc_r, imaxloc_i -END INTERFACE - -!---------------------------------------------------------------------------- -! IMIN@MISC -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION iminloc_r(arr) - REAL(DFP), INTENT(IN) :: arr(:) - INTEGER(I4B) :: iminloc_r - END FUNCTION -END INTERFACE - -INTERFACE IMINLOC - MODULE PROCEDURE iminloc_r -END INTERFACE IMINLOC - -!---------------------------------------------------------------------------- -! IMG -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2022 -! summary: Return imaginary part of complex value - -INTERFACE - MODULE ELEMENTAL FUNCTION IMG_1(x) RESULT(ans) - COMPLEX(Real32), INTENT(IN) :: x - REAL(Real32) :: ans - END FUNCTION IMG_1 -END INTERFACE - -INTERFACE IMG - MODULE PROCEDURE IMG_1 -END INTERFACE IMG - -!---------------------------------------------------------------------------- -! IMG -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2022 -! summary: Return imaginary part of complex value - -INTERFACE - MODULE ELEMENTAL FUNCTION IMG_2(x) RESULT(ans) - COMPLEX(Real64), INTENT(IN) :: x - REAL(Real64) :: ans - END FUNCTION IMG_2 -END INTERFACE - -INTERFACE IMG - MODULE PROCEDURE IMG_2 -END INTERFACE IMG - -!---------------------------------------------------------------------------- -! safe_ACOS -!---------------------------------------------------------------------------- - -INTERFACE - MODULE ELEMENTAL FUNCTION safe_ACOS(c) RESULT(ans) - REAL(DFP), INTENT(IN) :: c - REAL(DFP) :: ans - END FUNCTION safe_ACOS -END INTERFACE - -PUBLIC :: safe_ACOS - -!---------------------------------------------------------------------------- -! safe_ASIN -!---------------------------------------------------------------------------- - -INTERFACE - MODULE ELEMENTAL FUNCTION safe_ASIN(s) RESULT(ans) - REAL(DFP), INTENT(IN) :: s - REAL(DFP) :: ans - END FUNCTION safe_ASIN -END INTERFACE - -PUBLIC :: safe_ASIN - -!---------------------------------------------------------------------------- -! Factorial@MISC -!---------------------------------------------------------------------------- - -END MODULE MiscUtility diff --git a/src/modules/Utility/src/OnesUtility.F90 b/src/modules/Utility/src/OnesUtility.F90 deleted file mode 100644 index 1712606ce..000000000 --- a/src/modules/Utility/src/OnesUtility.F90 +++ /dev/null @@ -1,363 +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 OnesUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: ones -! -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_1( dim1, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(Int8), INTENT(IN) :: datatype - INTEGER(Int8) :: ans(dim1) -END FUNCTION ones_1 -!! -MODULE PURE FUNCTION ones_2( dim1, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(Int16), INTENT(IN) :: datatype - INTEGER(Int16) :: ans(dim1) -END FUNCTION ones_2 -!! -MODULE PURE FUNCTION ones_3( dim1, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(Int32), INTENT(IN) :: datatype - INTEGER(Int32) :: ans(dim1) -END FUNCTION ones_3 -!! -MODULE PURE FUNCTION ones_4( dim1, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(Int64), INTENT(IN) :: datatype - INTEGER(Int64) :: ans(dim1) -END FUNCTION ones_4 - -#ifdef USE_Int128 -!! -MODULE PURE FUNCTION ones_5( dim1, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1) -END FUNCTION ones_5 -#endif -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_1, ones_2, ones_3, ones_4 -END INTERFACE ones - -#ifdef USE_Int128 -INTERFACE ones - MODULE PROCEDURE ones_5 -END INTERFACE ones -#endif - -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_6( dim1, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - REAL(Real32), INTENT(IN) :: datatype - REAL(Real32) :: ans(dim1) -END FUNCTION ones_6 -!! -MODULE PURE FUNCTION ones_7( dim1, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - REAL(Real64), INTENT(IN) :: datatype - REAL(Real64) :: ans(dim1) -END FUNCTION ones_7 -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_6, ones_7 -END INTERFACE ones - -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_8( dim1, dim2, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(Int8), INTENT(IN) :: datatype - INTEGER(Int8) :: ans(dim1, dim2) -END FUNCTION ones_8 -!! -MODULE PURE FUNCTION ones_9( dim1, dim2, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(Int16), INTENT(IN) :: datatype - INTEGER(Int16) :: ans(dim1, dim2) -END FUNCTION ones_9 -!! -MODULE PURE FUNCTION ones_10( dim1, dim2, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(Int32), INTENT(IN) :: datatype - INTEGER(Int32) :: ans(dim1, dim2) -END FUNCTION ones_10 -!! -MODULE PURE FUNCTION ones_11( dim1, dim2, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(Int64), INTENT(IN) :: datatype - INTEGER(Int64) :: ans(dim1, dim2) -END FUNCTION ones_11 -!! -#ifdef USE_Int128 -!! -MODULE PURE FUNCTION ones_12( dim1, dim2, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1, dim2) -END FUNCTION ones_12 -#endif -!! -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_8, ones_9, ones_10, ones_11 -END INTERFACE ones - -#ifdef USE_Int128 -INTERFACE ones - MODULE PROCEDURE ones_12 -END INTERFACE ones -#endif - -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_13( dim1, dim2, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - REAL(Real32), INTENT(IN) :: datatype - REAL(Real32) :: ans(dim1, dim2) -END FUNCTION ones_13 -!! -MODULE PURE FUNCTION ones_14( dim1, dim2, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - REAL(Real64), INTENT(IN) :: datatype - REAL(Real64) :: ans(dim1, dim2) -END FUNCTION ones_14 -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_13, ones_14 -END INTERFACE ones - -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_15( dim1, dim2, dim3, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(Int8), INTENT(IN) :: datatype - INTEGER(Int8) :: ans(dim1, dim2, dim3) -END FUNCTION ones_15 -!! -MODULE PURE FUNCTION ones_16( dim1, dim2, dim3, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(Int16), INTENT(IN) :: datatype - INTEGER(Int16) :: ans(dim1, dim2, dim3) -END FUNCTION ones_16 -!! -MODULE PURE FUNCTION ones_17( dim1, dim2, dim3, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(Int32), INTENT(IN) :: datatype - INTEGER(Int32) :: ans(dim1, dim2, dim3) -END FUNCTION ones_17 -!! -MODULE PURE FUNCTION ones_18( dim1, dim2, dim3, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(Int64), INTENT(IN) :: datatype - INTEGER(Int64) :: ans(dim1, dim2, dim3) -END FUNCTION ones_18 - -#ifdef USE_Int128 - !! -MODULE PURE FUNCTION ones_19( dim1, dim2, dim3, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1, dim2, dim3) -END FUNCTION ones_19 -#endif -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_15, ones_16, ones_17, ones_18 -END INTERFACE ones - -#ifdef USE_Int128 -INTERFACE ones - MODULE PROCEDURE ones_19 -END INTERFACE ones -#endif - -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_20( dim1, dim2, dim3, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - REAL(Real32), INTENT(IN) :: datatype - REAL(Real32) :: ans(dim1, dim2, dim3) -END FUNCTION ones_20 -!! -MODULE PURE FUNCTION ones_21( dim1, dim2, dim3, datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - REAL(Real64), INTENT(IN) :: datatype - REAL(Real64) :: ans(dim1, dim2, dim3) -END FUNCTION ones_21 -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_20, ones_21 -END INTERFACE ones - -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_22( dim1, dim2, dim3, dim4,& - & datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(Int8), INTENT(IN) :: datatype - INTEGER(Int8) :: ans(dim1, dim2, dim3, dim4) -END FUNCTION ones_22 -!! -MODULE PURE FUNCTION ones_23( dim1, dim2, dim3, dim4,& - & datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(Int16), INTENT(IN) :: datatype - INTEGER(Int16) :: ans(dim1, dim2, dim3, dim4) -END FUNCTION ones_23 -!! -MODULE PURE FUNCTION ones_24( dim1, dim2, dim3, dim4,& - & datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(Int32), INTENT(IN) :: datatype - INTEGER(Int32) :: ans(dim1, dim2, dim3, dim4) -END FUNCTION ones_24 -!! -MODULE PURE FUNCTION ones_25( dim1, dim2, dim3, dim4,& - & datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(Int64), INTENT(IN) :: datatype - INTEGER(Int64) :: ans(dim1, dim2, dim3, dim4) -END FUNCTION ones_25 - -#ifdef USE_Int128 -!! -MODULE PURE FUNCTION ones_26( dim1, dim2, dim3, dim4, & - & datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1, dim2, dim3, dim4) -END FUNCTION ones_26 -#endif -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_22, ones_23, ones_24, ones_25 -END INTERFACE ones - -#ifdef USE_Int128 -INTERFACE ones - MODULE PROCEDURE ones_26 -END INTERFACE ones -#endif - -!---------------------------------------------------------------------------- -! Ones@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE FUNCTION ones_27( dim1, dim2, dim3, dim4, & - & datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - REAL(Real32), INTENT(IN) :: datatype - REAL(Real32) :: ans(dim1, dim2, dim3, dim4) -END FUNCTION ones_27 -!! -MODULE PURE FUNCTION ones_28( dim1, dim2, dim3, dim4, & - & datatype ) RESULT( Ans ) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - REAL(Real64), INTENT(IN) :: datatype - REAL(Real64) :: ans(dim1, dim2, dim3, dim4) -END FUNCTION ones_28 -END INTERFACE - -INTERFACE ones - MODULE PROCEDURE ones_27, ones_28 -END INTERFACE ones - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE OnesUtility \ No newline at end of file diff --git a/src/modules/Utility/src/PartitionUtility.F90 b/src/modules/Utility/src/PartitionUtility.F90 deleted file mode 100644 index 3fb18eced..000000000 --- a/src/modules/Utility/src/PartitionUtility.F90 +++ /dev/null @@ -1,174 +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: 2023-06-27 -! summary: Partition methods for quicksorting and quickselect -! -!# Introduction -! -! This module contains Hoare's style partitioning algorithm used -! for quicksorting and quickselect routines. -! -! Reference: -! -! https://github.com/leonfoks/coretran/blob/master/src/core/m_partition.f90 - -MODULE PartitionUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: partition -PUBLIC :: argPartition - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Partitioning used for quickSort and quickSelect routines - -INTERFACE partition - MODULE PURE SUBROUTINE partition_Real32(this, left, right, iPivot) - REAL(REAL32), INTENT(inout) :: this(:) - !! 1D array - INTEGER(I4B), INTENT(in) :: left - !! Left index - INTEGER(I4B), INTENT(in) :: right - !! Right index - INTEGER(I4B), INTENT(inout) :: iPivot - !! Pivoting index - END SUBROUTINE - - MODULE PURE SUBROUTINE partition_Real64(this, left, right, iPivot) - REAL(REAL64), INTENT(inout) :: this(:) - !! 1D array - INTEGER(I4B), INTENT(in) :: left - !! Left index - INTEGER(I4B), INTENT(in) :: right - !! Right index - INTEGER(I4B), INTENT(inout) :: iPivot - !! Pivoting index - END SUBROUTINE - - MODULE PURE SUBROUTINE partition_Int8(this, left, right, iPivot) - INTEGER(INT8), INTENT(inout) :: this(:) - !! 1D array - INTEGER(I4B), INTENT(in) :: left - !! Left index - INTEGER(I4B), INTENT(in) :: right - !! Right index - INTEGER(I4B), INTENT(inout) :: iPivot - !! Pivoting index - END SUBROUTINE - - MODULE PURE SUBROUTINE partition_Int16(this, left, right, iPivot) - INTEGER(INT16), INTENT(inout) :: this(:) - !! 1D array - INTEGER(I4B), INTENT(in) :: left - !! Left index - INTEGER(I4B), INTENT(in) :: right - !! Right index - INTEGER(I4B), INTENT(inout) :: iPivot - !! Pivoting index - END SUBROUTINE - - MODULE PURE SUBROUTINE partition_Int32(this, left, right, iPivot) - INTEGER(INT32), INTENT(inout) :: this(:) - !! 1D array - INTEGER(I4B), INTENT(in) :: left - !! Left index - INTEGER(I4B), INTENT(in) :: right - !! Right index - INTEGER(I4B), INTENT(inout) :: iPivot - !! Pivoting index - END SUBROUTINE - - MODULE PURE SUBROUTINE partition_int64(this, left, right, iPivot) - INTEGER(INT64), INTENT(inout) :: this(:) - !! 1D array - INTEGER(I4B), INTENT(in) :: left - !! Left index - INTEGER(I4B), INTENT(in) :: right - !! Right index - INTEGER(I4B), INTENT(inout) :: iPivot - !! Pivoting index - END SUBROUTINE - -END INTERFACE - -!---------------------------------------------------------------------------- -! argPartition -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Partitioning used for argQuicksort routines - -INTERFACE argPartition - MODULE PURE SUBROUTINE argPartition_Real32(this, idx, left, right, i) - REAL(REAL32), INTENT(in) :: this(:) - INTEGER(I4B), INTENT(inout) :: idx(:) - INTEGER(I4B), INTENT(in) :: left - INTEGER(I4B), INTENT(in) :: right - INTEGER(I4B), INTENT(inout) :: i - END SUBROUTINE - - MODULE PURE SUBROUTINE argPartition_Real64(this, idx, left, right, i) - REAL(REAL64), INTENT(in) :: this(:) - INTEGER(I4B), INTENT(inout) :: idx(:) - INTEGER(I4B), INTENT(in) :: left - INTEGER(I4B), INTENT(in) :: right - INTEGER(I4B), INTENT(inout) :: i - END SUBROUTINE - - MODULE PURE SUBROUTINE argPartition_Int8(this, idx, left, right, i) - INTEGER(INT8), INTENT(in) :: this(:) - INTEGER(I4B), INTENT(inout) :: idx(:) - INTEGER(I4B), INTENT(in) :: left - INTEGER(I4B), INTENT(in) :: right - INTEGER(I4B), INTENT(inout) :: i - END SUBROUTINE - - MODULE PURE SUBROUTINE argPartition_Int16(this, idx, left, right, i) - INTEGER(INT16), INTENT(in) :: this(:) - INTEGER(I4B), INTENT(inout) :: idx(:) - INTEGER(I4B), INTENT(in) :: left - INTEGER(I4B), INTENT(in) :: right - INTEGER(I4B), INTENT(inout) :: i - END SUBROUTINE - - MODULE PURE SUBROUTINE argPartition_Int32(this, idx, left, right, i) - INTEGER(INT32), INTENT(in) :: this(:) - INTEGER(I4B), INTENT(inout) :: idx(:) - INTEGER(I4B), INTENT(in) :: left - INTEGER(I4B), INTENT(in) :: right - INTEGER(I4B), INTENT(inout) :: i - END SUBROUTINE - - MODULE PURE SUBROUTINE argPartition_Int64(this, idx, left, right, i) - INTEGER(INT64), INTENT(in) :: this(:) - INTEGER(I4B), INTENT(inout) :: idx(:) - INTEGER(I4B), INTENT(in) :: left - INTEGER(I4B), INTENT(in) :: right - INTEGER(I4B), INTENT(inout) :: i - END SUBROUTINE - -END INTERFACE argPartition - -END MODULE PartitionUtility diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 deleted file mode 100644 index 8bbe18966..000000000 --- a/src/modules/Utility/src/ProductUtility.F90 +++ /dev/null @@ -1,1413 +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 ProductUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: OUTERPROD -PUBLIC :: Cross_Product -PUBLIC :: Vector_Product -PUBLIC :: VectorProduct - -!---------------------------------------------------------------------------- -! Cross_Product@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This FUNCTION evaluate vectors product -! -!# Introduction -! This FUNCTION evaluate vectors products -! $$\mathbf{ans} = \mathbf{a} \times \mathbf{b}$$ - -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 - -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 Cross_Product - MODULE PROCEDURE vectorProduct_1, vectorProduct_2 -END INTERFACE Cross_Product - -INTERFACE Vector_Product - MODULE PROCEDURE vectorProduct_1, vectorProduct_2 -END INTERFACE Vector_Product - -INTERFACE VectorProduct - MODULE PROCEDURE vectorProduct_1, vectorProduct_2 -END INTERFACE VectorProduct - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This FUNCTION returns outerproduct(matrix) of two vectors -! -!# Introduction -! -! $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ - -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1(a, b) RESULT(ans) - 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 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This FUNCTION returns outerproduct -! -!# Introduction -! -! This FUNCTION returns outerproduct(matrix) of two vectors -! - $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ -! - If `Sym` is .true. THEN symmetric part is returned - -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 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r1r5 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r5 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This FUNCTION returns outerproduct - -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 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -INTERFACE - MODULE PURE FUNCTION outerprod_r2r2(a, b) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :) - REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2)) - END FUNCTION outerprod_r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> 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)) - END FUNCTION outerprod_r2r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r3 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r2r4 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r4 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r3r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r3r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r2 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r3r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r3 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r4r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r4r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r4r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r4r2 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a x b - -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)) - END FUNCTION outerprod_r5r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r5r1 -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 FUNCTION outerprod_r1r1r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1)) - END FUNCTION outerprod_r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1 -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 FUNCTION outerprod_r1r1r2(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2)) - END FUNCTION outerprod_r1r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r2 -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 FUNCTION outerprod_r1r1r3(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3)) - END FUNCTION outerprod_r1r1r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r3 -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 FUNCTION outerprod_r1r1r4(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:, :, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3),& - & SIZE(c, 4)) - END FUNCTION outerprod_r1r1r4 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r4 -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 FUNCTION outerprod_r1r2r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1)) - END FUNCTION outerprod_r1r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r1 -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 FUNCTION outerprod_r1r2r2(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(c, 2)) - END FUNCTION outerprod_r1r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r2 -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 FUNCTION outerprod_r1r2r3(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP), INTENT(IN) :: c(:, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3)) - END FUNCTION outerprod_r1r2r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r3 -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 FUNCTION outerprod_r1r3r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:, :, :) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(c, 1)) - END FUNCTION outerprod_r1r3r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r3r1 -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 FUNCTION outerprod_r1r3r2(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:, :, :) - REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(c, 1),& - & SIZE(c, 2)) - END FUNCTION outerprod_r1r3r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r3r2 -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 FUNCTION outerprod_r1r4r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:) - REAL(DFP), INTENT(IN) :: b(:, :, :, :) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(b, 4),& - & SIZE(c, 1)) - END FUNCTION outerprod_r1r4r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r4r1 -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 FUNCTION outerprod_r2r1r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1)) - END FUNCTION outerprod_r2r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_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 FUNCTION outerprod_r2r1r2(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2)) - END FUNCTION outerprod_r2r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r2 -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 FUNCTION outerprod_r2r1r3(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3)) - END FUNCTION outerprod_r2r1r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r3 -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 FUNCTION outerprod_r2r2r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :) - REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1)) - END FUNCTION outerprod_r2r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2r1 -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 FUNCTION outerprod_r2r2r2(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :) - REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(c, 2)) - END FUNCTION outerprod_r2r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2r2 -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 FUNCTION outerprod_r3r1r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :, :) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(c, 1)) - END FUNCTION outerprod_r3r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1r1 -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 FUNCTION outerprod_r3r1r2(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :, :) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2)) - END FUNCTION outerprod_r3r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1r2 -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 FUNCTION outerprod_r3r2r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :, :) - REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1)) - END FUNCTION outerprod_r3r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r2r1 -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 FUNCTION outerprod_r4r1r1(a, b, c) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(:, :, :, :) - REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(a, 4),& - & SIZE(b, 1),& - & SIZE(c, 1)) - END FUNCTION outerprod_r4r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r4r1r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r1r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1r2 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r1r1r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1r3 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r1r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r2r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r1r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r2r2 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r1r3r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r3r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r2r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r1r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r2r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r1r2 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r2r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r2r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r1r3r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r3r1r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r2r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r1r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r2r1r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r1r2 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r2r1r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r2r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r2r2r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2r1r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! OUTERPROD@PROD -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-19 -! update: 2021-12-19 -! summary: a b c d - -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)) - END FUNCTION outerprod_r3r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1r1r1 -END INTERFACE OUTERPROD - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ProductUtility diff --git a/src/modules/Utility/src/PushPopUtility.F90 b/src/modules/Utility/src/PushPopUtility.F90 deleted file mode 100644 index 3738796ec..000000000 --- a/src/modules/Utility/src/PushPopUtility.F90 +++ /dev/null @@ -1,272 +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 PushPopUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Push -PUBLIC :: Pop - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Push a value - -INTERFACE - MODULE PURE FUNCTION push_int8(vec, pos, value) RESULT(ans) - INTEGER(Int8), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int8), INTENT(IN) :: value - INTEGER(Int8) :: ans(SIZE(vec) + 1) - END FUNCTION push_int8 -END INTERFACE - -INTERFACE Push - MODULE PROCEDURE push_int8 -END INTERFACE Push - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Push a value - -INTERFACE - MODULE PURE FUNCTION push_int16(vec, pos, value) RESULT(ans) - INTEGER(Int16), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int16), INTENT(IN) :: value - INTEGER(Int16) :: ans(SIZE(vec) + 1) - END FUNCTION push_int16 -END INTERFACE - -INTERFACE Push - MODULE PROCEDURE push_int16 -END INTERFACE Push - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Push a value - -INTERFACE - MODULE PURE FUNCTION push_int32(vec, pos, value) RESULT(ans) - INTEGER(Int32), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int32), INTENT(IN) :: value - INTEGER(Int32) :: ans(SIZE(vec) + 1) - END FUNCTION push_int32 -END INTERFACE - -INTERFACE Push - MODULE PROCEDURE push_int32 -END INTERFACE Push - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Push a value - -INTERFACE - MODULE PURE FUNCTION push_int64(vec, pos, value) RESULT(ans) - INTEGER(Int64), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int64), INTENT(IN) :: value - INTEGER(Int64) :: ans(SIZE(vec) + 1) - END FUNCTION push_int64 -END INTERFACE - -INTERFACE Push - MODULE PROCEDURE push_int64 -END INTERFACE Push - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Push a value - -INTERFACE - MODULE PURE FUNCTION push_real32(vec, pos, value) RESULT(ans) - REAL(Real32), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - REAL(Real32), INTENT(IN) :: value - REAL(Real32) :: ans(SIZE(vec) + 1) - END FUNCTION push_real32 -END INTERFACE - -INTERFACE Push - MODULE PROCEDURE push_real32 -END INTERFACE Push - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Push a value - -INTERFACE - MODULE PURE FUNCTION push_real64(vec, pos, value) RESULT(ans) - REAL(Real64), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - REAL(Real64), INTENT(IN) :: value - REAL(Real64) :: ans(SIZE(vec) + 1) - END FUNCTION push_real64 -END INTERFACE - -INTERFACE Push - MODULE PROCEDURE push_real64 -END INTERFACE Push - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Pop a value - -INTERFACE - MODULE PURE FUNCTION Pop_int8(vec, pos) RESULT(ans) - INTEGER(Int8), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int8) :: ans(MAX(SIZE(vec) - 1, 0)) - END FUNCTION Pop_int8 -END INTERFACE - -INTERFACE Pop - MODULE PROCEDURE Pop_int8 -END INTERFACE Pop - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Pop a value - -INTERFACE - MODULE PURE FUNCTION Pop_int16(vec, pos) RESULT(ans) - INTEGER(Int16), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int16) :: ans(MAX(SIZE(vec) - 1, 0)) - END FUNCTION Pop_int16 -END INTERFACE - -INTERFACE Pop - MODULE PROCEDURE Pop_int16 -END INTERFACE Pop - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Pop a value - -INTERFACE - MODULE PURE FUNCTION Pop_int32(vec, pos) RESULT(ans) - INTEGER(Int32), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int32) :: ans(MAX(SIZE(vec) - 1, 0)) - END FUNCTION Pop_int32 -END INTERFACE - -INTERFACE Pop - MODULE PROCEDURE Pop_int32 -END INTERFACE Pop - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Pop a value - -INTERFACE - MODULE PURE FUNCTION Pop_int64(vec, pos) RESULT(ans) - INTEGER(Int64), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - INTEGER(Int64) :: ans(MAX(SIZE(vec) - 1, 0)) - END FUNCTION Pop_int64 -END INTERFACE - -INTERFACE Pop - MODULE PROCEDURE Pop_int64 -END INTERFACE Pop - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Pop a value - -INTERFACE - MODULE PURE FUNCTION Pop_real32(vec, pos) RESULT(ans) - REAL(Real32), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - REAL(Real32) :: ans(MAX(SIZE(vec) - 1, 0)) - END FUNCTION Pop_real32 -END INTERFACE - -INTERFACE Pop - MODULE PROCEDURE Pop_real32 -END INTERFACE Pop - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2022 -! summary: Pop a value - -INTERFACE - MODULE PURE FUNCTION Pop_real64(vec, pos) RESULT(ans) - REAL(Real64), INTENT(IN) :: vec(:) - INTEGER(I4B), INTENT(IN) :: pos - REAL(Real64) :: ans(MAX(SIZE(vec) - 1, 0)) - END FUNCTION Pop_real64 -END INTERFACE - -INTERFACE Pop - MODULE PROCEDURE Pop_real64 -END INTERFACE Pop - -END MODULE PushPopUtility diff --git a/src/modules/Utility/src/ReallocateUtility.F90 b/src/modules/Utility/src/ReallocateUtility.F90 deleted file mode 100644 index 132063cdf..000000000 --- a/src/modules/Utility/src/ReallocateUtility.F90 +++ /dev/null @@ -1,801 +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 ReallocateUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_logical(Mat, row) - LOGICAL(LGT), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE Reallocate_logical -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R1(Mat, row) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE Reallocate_Real64_R1 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R1b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real64_R1b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R1(Mat, row) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE Reallocate_Real32_R1 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R1b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real32_R1b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R2(Mat, row, col) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: row, col - END SUBROUTINE Reallocate_Real64_R2 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R2b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real64_R2b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R2(Mat, row, col) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: row, col - END SUBROUTINE Reallocate_Real32_R2 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R2b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real32_R2b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R3(Mat, i1, i2, i3) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3 - END SUBROUTINE Reallocate_Real64_R3 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R3b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real64_R3b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R3(Mat, i1, i2, i3) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3 - END SUBROUTINE Reallocate_Real32_R3 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R3b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real32_R3b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R4(Mat, i1, i2, i3, i4) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 - END SUBROUTINE Reallocate_Real64_R4 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R4b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real64_R4b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R4(Mat, i1, i2, i3, i4) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 - END SUBROUTINE Reallocate_Real32_R4 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R4b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real32_R4b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R5(Mat, i1, i2, i3, i4, i5) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 - END SUBROUTINE Reallocate_Real64_R5 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R5b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real64_R5b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R5(Mat, i1, i2, i3, i4, i5) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 - END SUBROUTINE Reallocate_Real32_R5 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R5b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real32_R5b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R6(Mat, i1, i2, i3, i4, i5, i6) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 - END SUBROUTINE Reallocate_Real64_R6 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R6b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real64_R6b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R6(Mat, i1, i2, i3, i4, i5, i6) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 - END SUBROUTINE Reallocate_Real32_R6 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R6b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real32_R6b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R7(Mat, i1, i2, i3, i4, i5, & - & i6, i7) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 - END SUBROUTINE Reallocate_Real64_R7 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R7b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real64_R7b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R7(Mat, i1, i2, i3, i4, i5, i6, i7) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 - END SUBROUTINE Reallocate_Real32_R7 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R7b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Real32_R7b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R1(Mat, row) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE Reallocate_Int64_R1 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE Reallocate_Int64_R1b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int64_R1b -END INTERFACE - -INTERFACE Reallocate - MODULE PROCEDURE Reallocate_Int64_R1b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R1(Mat, row) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE Reallocate_Int32_R1 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R1b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int32_R1b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int16_R1(Mat, row) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE Reallocate_Int16_R1 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int16_R1b(Mat, s) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int16_R1b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int8_R1(Mat, row) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE Reallocate_Int8_R1 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int8_R1b(Mat, s) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int8_R1b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R2(Mat, row, col) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: row, col - END SUBROUTINE Reallocate_Int64_R2 - - MODULE PURE SUBROUTINE Reallocate_Int64_R2b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int64_R2b - - MODULE PURE SUBROUTINE Reallocate_Int32_R2(Mat, row, col) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: row, col - END SUBROUTINE Reallocate_Int32_R2 - - MODULE PURE SUBROUTINE Reallocate_Int32_R2b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int32_R2b - - MODULE PURE SUBROUTINE Reallocate_Int16_R2(Mat, row, col) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: row, col - END SUBROUTINE Reallocate_Int16_R2 - - MODULE PURE SUBROUTINE Reallocate_Int16_R2b(Mat, s) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int16_R2b - - MODULE PURE SUBROUTINE Reallocate_Int8_R2(Mat, row, col) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: row, col - END SUBROUTINE Reallocate_Int8_R2 - - MODULE PURE SUBROUTINE Reallocate_Int8_R2b(Mat, s) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int8_R2b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R3(Mat, i1, i2, i3) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3 - END SUBROUTINE Reallocate_Int64_R3 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R3b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int64_R3b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R3(Mat, i1, i2, i3) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3 - END SUBROUTINE Reallocate_Int32_R3 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R3b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int32_R3b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R4(Mat, i1, i2, i3, i4) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 - END SUBROUTINE Reallocate_Int64_R4 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R4b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int64_R4b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R4(Mat, i1, i2, i3, i4) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 - END SUBROUTINE Reallocate_Int32_R4 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R4b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int32_R4b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R5(Mat, i1, i2, i3, i4, i5) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 - END SUBROUTINE Reallocate_Int64_R5 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R5b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int64_R5b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R5(Mat, i1, i2, i3, i4, i5) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 - END SUBROUTINE Reallocate_Int32_R5 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R5b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int32_R5b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R6(Mat, i1, i2, i3, i4, i5, i6) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 - END SUBROUTINE Reallocate_Int64_R6 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R6b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int64_R6b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R6(Mat, i1, i2, i3, i4, i5, i6) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 - END SUBROUTINE Reallocate_Int32_R6 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R6b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int32_R6b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R7(Mat, i1, i2, i3, i4, i5, & - & i6, i7) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 - END SUBROUTINE Reallocate_Int64_R7 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R7b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int64_R7b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R7(Mat, i1, i2, i3, i4, i5, i6, i7) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 - END SUBROUTINE Reallocate_Int32_R7 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R7b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) - INTEGER(I4B), INTENT(IN) :: s(:) - END SUBROUTINE Reallocate_Int32_R7b -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R1_6(Vec1, n1, Vec2, n2, Vec3, & - & n3, Vec4, n4, Vec5, n5, Vec6, n6) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) - INTEGER(I4B), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & - & Vec4(:), Vec5(:), Vec6(:) - INTEGER(I4B), INTENT(IN) :: n1, n2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 - END SUBROUTINE Reallocate_Int32_R1_6 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R1_6(Vec1, n1, Vec2, & - & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) - REAL(REAL64), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & - & Vec4(:), Vec5(:), Vec6(:) - INTEGER(I4B), INTENT(IN) :: n1, n2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 - END SUBROUTINE Reallocate_Real64_R1_6 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R1_6(Vec1, n1, Vec2, & - & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) - REAL(REAL32), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & - & Vec4(:), Vec5(:), Vec6(:) - INTEGER(I4B), INTENT(IN) :: n1, n2 - INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 - END SUBROUTINE Reallocate_Real32_R1_6 -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_AIJ(A, nA, IA, nIA, JA, nJA) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:) - INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA - END SUBROUTINE Reallocate_Real64_AIJ -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_AIJ(A, nA, IA, nIA, JA, nJA) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:) - INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA - END SUBROUTINE Reallocate_Real32_AIJ -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_AI(A, nA, IA, nIA) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:) - INTEGER(I4B), INTENT(IN) :: nA, nIA - END SUBROUTINE Reallocate_Real64_AI -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate@ReallocateMethods -!---------------------------------------------------------------------------- - -INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_AI(A, nA, IA, nIA) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:) - INTEGER(I4B), INTENT(IN) :: nA, nIA - END SUBROUTINE Reallocate_Real32_AI -END INTERFACE Reallocate - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -END MODULE ReallocateUtility diff --git a/src/modules/Utility/src/SafeSizeUtility.F90 b/src/modules/Utility/src/SafeSizeUtility.F90 deleted file mode 100644 index b5f98207a..000000000 --- a/src/modules/Utility/src/SafeSizeUtility.F90 +++ /dev/null @@ -1,64 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE SafeSizeUtility -USE GlobalData, ONLY: INT8, INT16, INT32, REAL32, REAL64, I4B -IMPLICIT NONE - -PRIVATE - -PUBLIC :: SafeSize - -!---------------------------------------------------------------------------- -! SafeSize -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-08 -! summary: Like size but safe for unallocatable - -INTERFACE SafeSize - MODULE PURE FUNCTION SafeSize1(VALUE) RESULT(ans) - INTEGER(INT8), ALLOCATABLE, INTENT(IN) :: VALUE(:) - INTEGER(I4B) :: ans - END FUNCTION SafeSize1 - - MODULE PURE FUNCTION SafeSize2(VALUE) RESULT(ans) - INTEGER(INT16), ALLOCATABLE, INTENT(IN) :: VALUE(:) - INTEGER(I4B) :: ans - END FUNCTION SafeSize2 - - MODULE PURE FUNCTION SafeSize3(VALUE) RESULT(ans) - INTEGER(INT32), ALLOCATABLE, INTENT(IN) :: VALUE(:) - INTEGER(I4B) :: ans - END FUNCTION SafeSize3 - - MODULE PURE FUNCTION SafeSize4(VALUE) RESULT(ans) - REAL(REAL32), ALLOCATABLE, INTENT(IN) :: VALUE(:) - INTEGER(I4B) :: ans - END FUNCTION SafeSize4 - - MODULE PURE FUNCTION SafeSize5(VALUE) RESULT(ans) - REAL(REAL64), ALLOCATABLE, INTENT(IN) :: VALUE(:) - INTEGER(I4B) :: ans - END FUNCTION SafeSize5 - -END INTERFACE SafeSize - -END MODULE SafeSizeUtility diff --git a/src/modules/Utility/src/SortUtility.F90 b/src/modules/Utility/src/SortUtility.F90 deleted file mode 100644 index 392e60538..000000000 --- a/src/modules/Utility/src/SortUtility.F90 +++ /dev/null @@ -1,808 +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 SortUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: ArgHeapSort -PUBLIC :: HeapSort -PUBLIC :: QuickSort -PUBLIC :: Sort -PUBLIC :: ArgSort -PUBLIC :: InsertionSort -PUBLIC :: ArgInsertionSort -PUBLIC :: IntroSort -PUBLIC :: ArgIntroSort - -!---------------------------------------------------------------------------- -! IntroSort -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Sorting by insertion algorithm - -INTERFACE - MODULE PURE SUBROUTINE IntroSort_Int8(array) - INTEGER(INT8), INTENT(INOUT) :: array(:) - END SUBROUTINE IntroSort_Int8 - MODULE PURE SUBROUTINE IntroSort_Int16(array) - INTEGER(INT16), INTENT(INOUT) :: array(:) - END SUBROUTINE IntroSort_Int16 - MODULE PURE SUBROUTINE IntroSort_Int32(array) - INTEGER(INT32), INTENT(INOUT) :: array(:) - END SUBROUTINE IntroSort_Int32 - MODULE PURE SUBROUTINE IntroSort_Int64(array) - INTEGER(INT64), INTENT(INOUT) :: array(:) - END SUBROUTINE IntroSort_Int64 - MODULE PURE SUBROUTINE IntroSort_Real32(array) - REAL(REAL32), INTENT(INOUT) :: array(:) - END SUBROUTINE IntroSort_Real32 - MODULE PURE SUBROUTINE IntroSort_Real64(array) - REAL(REAL64), INTENT(INOUT) :: array(:) - END SUBROUTINE IntroSort_Real64 -END INTERFACE - -INTERFACE IntroSort - MODULE PROCEDURE & - & IntroSort_Int8, & - & IntroSort_Int16, & - & IntroSort_Int32, & - & IntroSort_Int64, & - & IntroSort_Real32, & - & IntroSort_Real64 -END INTERFACE IntroSort - -!---------------------------------------------------------------------------- -! ArgIntroSort -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Indirect sorting by insertion sort - -INTERFACE - MODULE PURE SUBROUTINE ArgIntroSort_Int8(array, arg) - INTEGER(INT8), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - END SUBROUTINE ArgIntroSort_Int8 - - MODULE PURE SUBROUTINE ArgIntroSort_Int16(array, arg) - INTEGER(INT16), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - END SUBROUTINE ArgIntroSort_Int16 - - MODULE PURE SUBROUTINE ArgIntroSort_Int32(array, arg) - INTEGER(INT32), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - END SUBROUTINE ArgIntroSort_Int32 - - MODULE PURE SUBROUTINE ArgIntroSort_Int64(array, arg) - INTEGER(INT64), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - END SUBROUTINE ArgIntroSort_Int64 - - MODULE PURE SUBROUTINE ArgIntroSort_Real32(array, arg) - REAL(REAL32), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - END SUBROUTINE ArgIntroSort_Real32 - - MODULE PURE SUBROUTINE ArgIntroSort_Real64(array, arg) - REAL(REAL64), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - END SUBROUTINE ArgIntroSort_Real64 -END INTERFACE - -INTERFACE ArgIntroSort - MODULE PROCEDURE & - & ArgIntroSort_Int8, & - & ArgIntroSort_Int16, & - & ArgIntroSort_Int32, & - & ArgIntroSort_Int64, & - & ArgIntroSort_Real32, & - & ArgIntroSort_Real64 -END INTERFACE ArgIntroSort - -!---------------------------------------------------------------------------- -! IntroSort -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Sorting by insertion algorithm - -INTERFACE - MODULE PURE SUBROUTINE InsertionSort_Int8(array, low, high) - INTEGER(INT8), INTENT(INOUT) :: array(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE InsertionSort_Int8 - MODULE PURE SUBROUTINE InsertionSort_Int16(array, low, high) - INTEGER(INT16), INTENT(INOUT) :: array(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE InsertionSort_Int16 - MODULE PURE SUBROUTINE InsertionSort_Int32(array, low, high) - INTEGER(INT32), INTENT(INOUT) :: array(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE InsertionSort_Int32 - MODULE PURE SUBROUTINE InsertionSort_Int64(array, low, high) - INTEGER(INT64), INTENT(INOUT) :: array(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE InsertionSort_Int64 - MODULE PURE SUBROUTINE InsertionSort_Real32(array, low, high) - REAL(REAL32), INTENT(INOUT) :: array(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE InsertionSort_Real32 - MODULE PURE SUBROUTINE InsertionSort_Real64(array, low, high) - REAL(REAL64), INTENT(INOUT) :: array(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE InsertionSort_Real64 -END INTERFACE - -INTERFACE InsertionSort - MODULE PROCEDURE & - & InsertionSort_Int8, & - & InsertionSort_Int16, & - & InsertionSort_Int32, & - & InsertionSort_Int64, & - & InsertionSort_Real32, & - & InsertionSort_Real64 -END INTERFACE InsertionSort - -!---------------------------------------------------------------------------- -! ArgInsertionSort -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Indirect sorting by insertion sort - -INTERFACE - MODULE PURE SUBROUTINE ArgInsertionSort_Int8(array, arg, low, high) - INTEGER(INT8), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE ArgInsertionSort_Int8 - - MODULE PURE SUBROUTINE ArgInsertionSort_Int16(array, arg, low, high) - INTEGER(INT16), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE ArgInsertionSort_Int16 - - MODULE PURE SUBROUTINE ArgInsertionSort_Int32(array, arg, low, high) - INTEGER(INT32), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE ArgInsertionSort_Int32 - - MODULE PURE SUBROUTINE ArgInsertionSort_Int64(array, arg, low, high) - INTEGER(INT64), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE ArgInsertionSort_Int64 - - MODULE PURE SUBROUTINE ArgInsertionSort_Real32(array, arg, low, high) - REAL(REAL32), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE ArgInsertionSort_Real32 - - MODULE PURE SUBROUTINE ArgInsertionSort_Real64(array, arg, low, high) - REAL(REAL64), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(INOUT) :: arg(:) - INTEGER(I4B), INTENT(IN) :: low - INTEGER(I4B), INTENT(IN) :: high - END SUBROUTINE ArgInsertionSort_Real64 -END INTERFACE - -INTERFACE ArgInsertionSort - MODULE PROCEDURE & - & ArgInsertionSort_Int8, & - & ArgInsertionSort_Int16, & - & ArgInsertionSort_Int32, & - & ArgInsertionSort_Int64, & - & ArgInsertionSort_Real32, & - & ArgInsertionSort_Real64 -END INTERFACE ArgInsertionSort - -!---------------------------------------------------------------------------- -! HeapSort -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Heap Sort - -INTERFACE - MODULE PURE SUBROUTINE HeapSort_Int8(array) - INTEGER(INT8), INTENT(INOUT) :: array(:) - END SUBROUTINE HeapSort_Int8 - MODULE PURE SUBROUTINE HeapSort_Int16(array) - INTEGER(INT16), INTENT(INOUT) :: array(:) - END SUBROUTINE HeapSort_Int16 - MODULE PURE SUBROUTINE HeapSort_Int32(array) - INTEGER(INT32), INTENT(INOUT) :: array(:) - END SUBROUTINE HeapSort_Int32 - MODULE PURE SUBROUTINE HeapSort_Int64(array) - INTEGER(INT64), INTENT(INOUT) :: array(:) - END SUBROUTINE HeapSort_Int64 - MODULE PURE SUBROUTINE HeapSort_Real32(array) - REAL(REAL32), INTENT(INOUT) :: array(:) - END SUBROUTINE HeapSort_Real32 - MODULE PURE SUBROUTINE HeapSort_Real64(array) - REAL(REAL64), INTENT(INOUT) :: array(:) - END SUBROUTINE HeapSort_Real64 -END INTERFACE - -INTERFACE HeapSort - MODULE PROCEDURE HeapSort_Int8, HeapSort_Int16, HeapSort_Int32, & - & HeapSort_Int64, HeapSort_Real32, HeapSort_Real64 -END INTERFACE HeapSort - -!---------------------------------------------------------------------------- -! ArgHeapSort -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Heap Sort - -INTERFACE - MODULE PURE SUBROUTINE ArgHeapSort_Int8(array, arg) - INTEGER(INT8), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(OUT) :: arg(0:) - END SUBROUTINE ArgHeapSort_Int8 - - MODULE PURE SUBROUTINE ArgHeapSort_Int16(array, arg) - INTEGER(INT16), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(OUT) :: arg(0:) - END SUBROUTINE ArgHeapSort_Int16 - - MODULE PURE SUBROUTINE ArgHeapSort_Int32(array, arg) - INTEGER(INT32), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(OUT) :: arg(0:) - END SUBROUTINE ArgHeapSort_Int32 - - MODULE PURE SUBROUTINE ArgHeapSort_Int64(array, arg) - INTEGER(INT64), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(OUT) :: arg(0:) - END SUBROUTINE ArgHeapSort_Int64 - - MODULE PURE SUBROUTINE ArgHeapSort_Real32(array, arg) - REAL(REAL32), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(OUT) :: arg(0:) - END SUBROUTINE ArgHeapSort_Real32 - - MODULE PURE SUBROUTINE ArgHeapSort_Real64(array, arg) - REAL(REAL64), INTENT(IN) :: array(:) - INTEGER(I4B), INTENT(OUT) :: arg(0:) - END SUBROUTINE ArgHeapSort_Real64 -END INTERFACE - -INTERFACE ArgHeapSort - MODULE PROCEDURE ArgHeapSort_Int8, ArgHeapSort_Int16, ArgHeapSort_Int32, & - & ArgHeapSort_Int64, ArgHeapSort_Real32, ArgHeapSort_Real64 -END INTERFACE ArgHeapSort - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt8(vect1, low, high) - INTEGER(INT8), INTENT(INOUT) :: vect1(:) - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE QuickSort1vectInt8 - MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt16(vect1, low, high) - INTEGER(INT16), INTENT(INOUT) :: vect1(:) - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE QuickSort1vectInt16 - MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt32(vect1, low, high) - INTEGER(INT32), INTENT(INOUT) :: vect1(:) - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE QuickSort1vectInt32 - MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt64(vect1, low, high) - INTEGER(INT64), INTENT(INOUT) :: vect1(:) - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE QuickSort1vectInt64 - MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectReal32(vect1, low, high) - REAL(REAL32), INTENT(INOUT) :: vect1(:) - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE QuickSort1vectReal32 - MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectReal64(vect1, low, high) - REAL(REAL64), INTENT(INOUT) :: vect1(:) - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE QuickSort1vectReal64 -END INTERFACE - -INTERFACE QuickSort - MODULE PROCEDURE QuickSort1vectInt8, QuickSort1vectInt16, & - & QuickSort1vectInt32, QuickSort1vectInt64 - MODULE PROCEDURE QuickSort1vectReal32, QuickSort1vectReal64 -END INTERFACE QuickSort - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE RECURSIVE PURE SUBROUTINE QuickSort2vectIR(vect1, vect2, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectII(vect1, vect2, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRI(vect1, vect2, low, high) - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRR(vect1, vect2, low, high) - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIII(vect1, vect2, vect3, & - & low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIIR(vect1, vect2, vect3, & - & low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRR(vect1, vect2, vect3, & - & low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRI(vect1, vect2, vect3, & - & low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRR(vect1, vect2, vect3, & - & low, high) - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRI(vect1, vect2, vect3, & - & low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRIR(vect1, vect2, vect3, & - & low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRII(vect1, vect2, vect3, & - & low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIII(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIIR(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRI(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRR(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRR(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRI(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect4 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRIR(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRII(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRR(vect1, vect2, vect3, & - & vect4, low, high) - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRI(vect1, vect2, & - & vect3, vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect4 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRIR(vect1, vect2, & - & vect3, vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRII(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3, vect4 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRR(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRI(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect4 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIIR(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect4 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -!---------------------------------------------------------------------------- -! QuickSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIII(vect1, vect2, vect3, & - & vect4, low, high) - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4 - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 - INTEGER(I4B), INTENT(IN) :: low, high - END SUBROUTINE -END INTERFACE - -INTERFACE QuickSort - MODULE PROCEDURE QuickSort2vectII, & - & QuickSort2vectIR, QuickSort2vectRR, QuickSort2vectRI, & - & QuickSort3vectIII, QuickSort3vectIIR, QuickSort3vectIRI, & - & QuickSort3vectIRR, QuickSort3vectRRR, QuickSort3vectRRI, & - & QuickSort3vectRIR, QuickSort3vectRII, QuickSort4vectIIII, & - & QuickSort4vectIIIR, QuickSort4vectIIRI, QuickSort4vectIIRR, & - & QuickSort4vectIRII, QuickSort4vectIRIR, QuickSort4vectIRRI, & - & QuickSort4vectIRRR, QuickSort4vectRIII, QuickSort4vectRIIR, & - & QuickSort4vectRIRI, QuickSort4vectRIRR, QuickSort4vectRRII, & - & QuickSort4vectRRIR, QuickSort4vectRRRI, QuickSort4vectRRRR -END INTERFACE QuickSort - -!---------------------------------------------------------------------------- -! Sort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Sort_Int8(x, name) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(INT8) :: ans(SIZE(x)) - END FUNCTION Sort_Int8 - MODULE PURE FUNCTION Sort_Int16(x, name) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(INT16) :: ans(SIZE(x)) - END FUNCTION Sort_Int16 - MODULE PURE FUNCTION Sort_Int32(x, name) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(INT32) :: ans(SIZE(x)) - END FUNCTION Sort_Int32 - MODULE PURE FUNCTION Sort_Int64(x, name) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(INT64) :: ans(SIZE(x)) - END FUNCTION Sort_Int64 - MODULE PURE FUNCTION Sort_Real32(x, name) RESULT(ans) - REAL(REAL32), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - REAL(REAL32) :: ans(SIZE(x)) - END FUNCTION Sort_Real32 - MODULE PURE FUNCTION Sort_Real64(x, name) RESULT(ans) - REAL(REAL64), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - REAL(REAL64) :: ans(SIZE(x)) - END FUNCTION Sort_Real64 -END INTERFACE - -INTERFACE Sort - MODULE PROCEDURE Sort_Int8, Sort_Int16, Sort_Int32, Sort_Int64 - MODULE PROCEDURE Sort_Real32, Sort_Real64 -END INTERFACE Sort - -!---------------------------------------------------------------------------- -! ArgSort -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION ArgSort_Int8(x, name) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(I4B) :: ans(SIZE(x)) - END FUNCTION ArgSort_Int8 - MODULE PURE FUNCTION ArgSort_Int16(x, name) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(I4B) :: ans(SIZE(x)) - END FUNCTION ArgSort_Int16 - MODULE PURE FUNCTION ArgSort_Int32(x, name) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(I4B) :: ans(SIZE(x)) - END FUNCTION ArgSort_Int32 - MODULE PURE FUNCTION ArgSort_Int64(x, name) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(I4B) :: ans(SIZE(x)) - END FUNCTION ArgSort_Int64 - MODULE PURE FUNCTION ArgSort_Real32(x, name) RESULT(ans) - REAL(REAL32), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(I4B) :: ans(SIZE(x)) - END FUNCTION ArgSort_Real32 - MODULE PURE FUNCTION ArgSort_Real64(x, name) RESULT(ans) - REAL(REAL64), INTENT(IN) :: x(:) - CHARACTER(*), OPTIONAL, INTENT(IN) :: name - INTEGER(I4B) :: ans(SIZE(x)) - END FUNCTION ArgSort_Real64 -END INTERFACE - -INTERFACE ArgSort - MODULE PROCEDURE ArgSort_Int8, ArgSort_Int16, ArgSort_Int32, ArgSort_Int64 - MODULE PROCEDURE ArgSort_Real32, ArgSort_Real64 -END INTERFACE ArgSort - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE SortUtility diff --git a/src/modules/Utility/src/SplitUtility.F90 b/src/modules/Utility/src/SplitUtility.F90 deleted file mode 100644 index 44c40a849..000000000 --- a/src/modules/Utility/src/SplitUtility.F90 +++ /dev/null @@ -1,129 +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 SplitUtility -USE GlobalData -IMPLICIT NONE -PRIVATE -PUBLIC :: SPLIT - -!---------------------------------------------------------------------------- -! SPLIT -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns the first half of the array `x` if `section == 1` -! -!# Introduction -! -! Returns the first half of the array `x` if `section == 1`, the second half -! of the array `x` if `section == 2`, and an empty array otherwise. If `size -! (x) == 1`, `split(x, 1)` returns and empty array, and `split(x, 2)` -! returns `x(1)`. - -INTERFACE SPLIT - MODULE PURE FUNCTION split_Int8(x, section) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: x(:) - !! Input array - INTEGER(I4B), INTENT(IN) :: section - !! Array section to return - INTEGER(INT8), ALLOCATABLE :: Ans(:) - END FUNCTION split_Int8 - - MODULE PURE FUNCTION split_Int16(x, section) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: x(:) - !! Input array - INTEGER(I4B), INTENT(IN) :: section - !! Array section to return - INTEGER(INT16), ALLOCATABLE :: Ans(:) - END FUNCTION split_Int16 - - MODULE PURE FUNCTION split_Int32(x, section) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: x(:) - !! Input array - INTEGER(I4B), INTENT(IN) :: section - !! Array section to return - INTEGER(INT32), ALLOCATABLE :: Ans(:) - END FUNCTION split_Int32 - - MODULE PURE FUNCTION split_Int64(x, section) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: x(:) - !! Input array - INTEGER(I4B), INTENT(IN) :: section - !! Array section to return - INTEGER(INT64), ALLOCATABLE :: Ans(:) - END FUNCTION split_Int64 -END INTERFACE SPLIT - -!---------------------------------------------------------------------------- -! SPLIT -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns the first half of the array `x` if `section == 1`, -! -!# Introduction -! -! Returns the first half of the array `x` if `section == 1`, the second half -! of the array `x` if `section == 2`, and an empty array otherwise. If `size -! (x) == 1`, `split(x, 1)` returns and empty array, and `split(x, 2)` -! returns `x(1)`. - -INTERFACE SPLIT - MODULE PURE FUNCTION split_Real32(x, section) RESULT(Ans) - REAL(REAL32), DIMENSION(:), INTENT(IN) :: x !! Input array - INTEGER(I4B), INTENT(IN) :: section !! Array section to return - REAL(REAL32), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION split_Real32 - - MODULE PURE FUNCTION split_Real64(x, section) RESULT(Ans) - REAL(REAL64), DIMENSION(:), INTENT(IN) :: x !! Input array - INTEGER(I4B), INTENT(IN) :: section !! Array section to return - REAL(REAL64), DIMENSION(:), ALLOCATABLE :: Ans - END FUNCTION split_Real64 -END INTERFACE SPLIT - -!---------------------------------------------------------------------------- -! SPLIT -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Returns the first half of the array `x` if `section == 1`, -! -!# Introduction -! -! Returns the first half of the array `x` if `section == 1`, the second half -! of the array `x` if `section == 2`, and an empty array otherwise. If `size -! (x) == 1`, `split(x, 1)` returns and empty array, and `split(x, 2)` -! returns `x(1)`. - -INTERFACE SPLIT - MODULE PURE FUNCTION split_char(x, section) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: x !! Input array - INTEGER(I4B), INTENT(IN) :: section !! Array section to return - CHARACTER(:), ALLOCATABLE :: Ans - END FUNCTION split_char -END INTERFACE SPLIT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE SplitUtility diff --git a/src/modules/Utility/src/StringUtility.F90 b/src/modules/Utility/src/StringUtility.F90 deleted file mode 100644 index b4ad84c41..000000000 --- a/src/modules/Utility/src/StringUtility.F90 +++ /dev/null @@ -1,448 +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 StringUtility -USE GlobalData, ONLY: I4B, LGT -USE String_Class, ONLY: String - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: FindReplace -PUBLIC :: GetFileParts -PUBLIC :: GetPath -PUBLIC :: GetFileName -PUBLIC :: GetFileNameExt -PUBLIC :: GetExtension -PUBLIC :: GetField -PUBLIC :: LowerCase -PUBLIC :: ToLowerCase -PUBLIC :: IsWhiteChar -PUBLIC :: IsBlank -PUBLIC :: NumStrings -PUBLIC :: NumMatchStr -PUBLIC :: IsPresent -PUBLIC :: StrFind -PUBLIC :: SlashRep -PUBLIC :: ToUpperCase -PUBLIC :: UpperCase - -PUBLIC :: PathJoin -PUBLIC :: PathBase -PUBLIC :: PathDir - -!---------------------------------------------------------------------------- -! PathBase -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-17 -! summary: Returns the base of the path -! -!# Introduction -! -! Base returns the last element of path. -! Trailing slashes are removed before extracting the -! last element. -! If the path is empty, Base returns ".". -! If the path consists entirely of slashes, Base returns "/". -! -! func main() { -! fmt.Println(path.Base("/a/b")) -! fmt.Println(path.Base("/")) -! fmt.Println(path.Base("")) -! } -! b -! / -! . - -INTERFACE - MODULE PURE FUNCTION PathBase(path) RESULT(ans) - CHARACTER(*), INTENT(in) :: path - CHARACTER(LEN=:), ALLOCATABLE :: ans - END FUNCTION PathBase -END INTERFACE - -!---------------------------------------------------------------------------- -! PathJoin -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-17 -! summary: Join two paths - -INTERFACE PathJoin - MODULE PURE FUNCTION PathJoin1(path1, path2) RESULT(ans) - CHARACTER(*), INTENT(in) :: path1 - CHARACTER(*), INTENT(in) :: path2 - CHARACTER(LEN=:), ALLOCATABLE :: ans - END FUNCTION PathJoin1 -END INTERFACE PathJoin - -!---------------------------------------------------------------------------- -! PathJoin -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-17 -! summary: Join two paths - -INTERFACE PathJoin - MODULE PURE FUNCTION PathJoin2(paths) RESULT(ans) - TYPE(String), INTENT(IN) :: paths(:) - CHARACTER(LEN=:), ALLOCATABLE :: ans - END FUNCTION PathJoin2 -END INTERFACE PathJoin - -!---------------------------------------------------------------------------- -! GetPath@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-17 -! summary: Returns the parent directory -! -!# Introduction -! -! Dir returns all but the last element of path, -! typically the path's directory. -! After dropping the final element using Split, -! the path is Cleaned and trailing slashes are removed. -! If the path is empty, Dir returns ".". -! If the path consists entirely of slashes followed by non-slash bytes, -! Dir returns a single slash. -! In any other case, the returned path does not end in a slash. - -INTERFACE - MODULE PURE FUNCTION PathDir(path) RESULT(ans) - CHARACTER(*), INTENT(IN) :: path - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION PathDir -END INTERFACE - -!---------------------------------------------------------------------------- -! GetPath@StringMethods -!---------------------------------------------------------------------------- - -INTERFACE GetPath - MODULE PURE SUBROUTINE GetPath_chars(chars, path) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(OUT) :: path - END SUBROUTINE GetPath_chars -END INTERFACE GetPath - -!---------------------------------------------------------------------------- -! UpperCase@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2021 -! summary: Returns the upperCase version of chars - -INTERFACE UpperCase - MODULE PURE FUNCTION UpperCase_char(chars) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(len=:), ALLOCATABLE :: ans - END FUNCTION UpperCase_char -END INTERFACE UpperCase - -!---------------------------------------------------------------------------- -! ToUpperCase@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2021 -! summary: Returns the upperCase version of chars - -INTERFACE ToUpperCase - MODULE PURE SUBROUTINE ToUpperCase_Char(chars) - CHARACTER(*), INTENT(INOUT) :: chars - END SUBROUTINE ToUpperCase_Char -END INTERFACE ToUpperCase - -!---------------------------------------------------------------------------- -! LowerCase@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2021 -! summary: Returns the LowerCase version of chars - -INTERFACE LowerCase - MODULE PURE FUNCTION LowerCase_char(chars) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION LowerCase_char -END INTERFACE LowerCase - -!---------------------------------------------------------------------------- -! ToLowerCase@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2021 -! summary: Returns the LowerCase version of chars - -INTERFACE ToLowerCase - MODULE PURE SUBROUTINE ToLowerCase_Char(chars) - CHARACTER(*), INTENT(INOUT) :: chars - END SUBROUTINE ToLowerCase_Char -END INTERFACE ToLowerCase - -!---------------------------------------------------------------------------- -! IsWhiteChar@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2021 -! summary: Returns true if the char is a space(32) or a tab(9). - -INTERFACE IsWhiteChar - MODULE PURE FUNCTION IsWhiteChar_char(char) RESULT(Ans) - CHARACTER(1), INTENT(IN) :: char - LOGICAL(LGT) :: ans - END FUNCTION IsWhiteChar_char -END INTERFACE IsWhiteChar - -!---------------------------------------------------------------------------- -! IsBlank@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2021 -! summary: Returns true of the entire string is blank - -INTERFACE IsBlank - MODULE PURE FUNCTION IsBlank_chars(chars) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: chars - LOGICAL(LGT) :: ans - END FUNCTION IsBlank_chars -END INTERFACE IsBlank - -!---------------------------------------------------------------------------- -! numString@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 Sept 2021 -! summary: Returns number of substrings contained in input string 'chars' -! delimited by white space. -! -!# Introduction -! Returns number of substrings contained in input string 'chars' delimited by -! white space. -! This routien has been adopted from -! [https://github.com/CASL/Futility/blob/master/src/IO_Strings.F90] -! (https://github.com/CASL/Futility/blob/master/src/IO_Strings.F90) -! - -INTERFACE NumStrings - MODULE PURE FUNCTION NumStrings_chars(chars) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: chars - INTEGER(I4B) :: ans - END FUNCTION NumStrings_chars -END INTERFACE NumStrings - -!---------------------------------------------------------------------------- -! nmatchstr@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 sept 2021 -! summary: Returns the total number of times the substring pattern is -! found in the main string - -INTERFACE numMatchStr - MODULE PURE FUNCTION numMatchStr_chars(chars, pattern) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(IN) :: pattern - INTEGER(I4B) :: ans - END FUNCTION numMatchStr_chars -END INTERFACE numMatchStr - -!---------------------------------------------------------------------------- -! isPresent@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 sept 2021 -! summary: Returns whether or not a substring pattern is found within string -! -!# Introduction -! Returns whether or not a substring pattern is found within string -! -!@note -! Does not handle trailing spaces that can be eliminated by TRIM() so -! strings should be trimmed when passing into function. -!@endnote - -INTERFACE isPresent - MODULE PURE FUNCTION isPresent_chars(chars, pattern) RESULT(Ans) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(IN) :: pattern - LOGICAL(LGT) :: ans - END FUNCTION isPresent_chars -END INTERFACE isPresent - -!---------------------------------------------------------------------------- -! StrFind@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 sept 2021 -! summary: Function returns the indices in a string where substring pattern - -INTERFACE StrFind - MODULE PURE SUBROUTINE strFind_chars(chars, pattern, indices) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(IN) :: pattern - INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: indices(:) - END SUBROUTINE strFind_chars -END INTERFACE strFind - -!---------------------------------------------------------------------------- -! FindReplace@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 5 sept 2021 -! summary: Replaces a substring pattern with a different substring in a string -! -!# Introduction -! Replaces a substring pattern with a different substring in a string. -! - chars the string which will have substrings replaced. -! - findp the substring pattern to find and replace -! - repp the new substring that will be replace parts of string -! -!@note -! repp can be larger than findp and as long as the size of string can -! accomodate the increased length of all replacements. Trailing and preceding -! spaces are counted in all strings. -!@endnote - -INTERFACE FindReplace - MODULE PURE SUBROUTINE FindReplace_chars(chars, findp, repp) - CHARACTER(*), INTENT(INOUT) :: chars - CHARACTER(*), INTENT(IN) :: findp - CHARACTER(*), INTENT(IN) :: repp - END SUBROUTINE FindReplace_chars -END INTERFACE FindReplace - -!---------------------------------------------------------------------------- -! GetField@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 sept 2021 -! summary: Replaces a substring pattern with a different substring in a string - -INTERFACE GetField - MODULE PURE SUBROUTINE GetField_chars(i, chars, field, ierr) - INTEGER(I4B), INTENT(IN) :: i - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(:), ALLOCATABLE, INTENT(OUT) :: field - INTEGER(I4B), INTENT(OUT), OPTIONAL :: ierr - END SUBROUTINE GetField_chars -END INTERFACE GetField - -!---------------------------------------------------------------------------- -! SlashRep@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 sept 2021 -! summary: routine replaces slash character in file path names with -! the system appropriate file separator slash. -! -!# Introduction -! This routine returns the path, filename, and extension. - -INTERFACE SlashRep - MODULE PURE SUBROUTINE SlashRep_chars(chars) - CHARACTER(*), INTENT(INOUT) :: chars - END SUBROUTINE SlashRep_chars -END INTERFACE SlashRep - -!---------------------------------------------------------------------------- -! GetFileParts@StringMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 8 sept 2021 -! summary: Returns the path,filename, and extension -! -!# Introduction -! This routine returns the path, filename, and extension. - -INTERFACE GetFileParts - MODULE PURE SUBROUTINE GetFileParts_chars(chars, path, fname, ext) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(OUT) :: path - CHARACTER(*), INTENT(OUT) :: fname - CHARACTER(*), INTENT(OUT) :: ext - END SUBROUTINE GetFileParts_chars -END INTERFACE GetFileParts - -!---------------------------------------------------------------------------- -! GetFileName@StringMethods -!---------------------------------------------------------------------------- - -INTERFACE GetFileName - MODULE PURE SUBROUTINE GetFileName_chars(chars, fname) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(OUT) :: fname - END SUBROUTINE GetFileName_chars -END INTERFACE GetFileName - -!---------------------------------------------------------------------------- -! GetFileNameExt@StringMethods -!---------------------------------------------------------------------------- - -INTERFACE GetFileNameExt - MODULE PURE SUBROUTINE GetFileNameExt_chars(chars, ext) - CHARACTER(*), INTENT(IN) :: chars - CHARACTER(*), INTENT(OUT) :: ext - END SUBROUTINE GetFileNameExt_chars -END INTERFACE GetFileNameExt - -!---------------------------------------------------------------------------- -! GetExtension@StringMethods -!---------------------------------------------------------------------------- - -!> author: Dr. Vikas Sharma -! -! This function Get the extension from a file -! -! ## Usage -! ```fortran -! call display( GetExtension("helloworld.F90") .EQ. "f90", & -! & msg="test1:: ") -! ``` - -INTERFACE GetExtension - MODULE FUNCTION GetExtension_chars(char) RESULT(ext) - CHARACTER(*), INTENT(IN) :: char - CHARACTER(:), ALLOCATABLE :: ext - END FUNCTION -END INTERFACE GetExtension - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE StringUtility diff --git a/src/modules/Utility/src/SwapUtility.F90 b/src/modules/Utility/src/SwapUtility.F90 deleted file mode 100644 index 0375e0f00..000000000 --- a/src/modules/Utility/src/SwapUtility.F90 +++ /dev/null @@ -1,830 +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 SwapUtility -USE GlobalData, ONLY: INT8, INT16, INT32, INT64, REAL32, REAL64, & - DFPC, LGT, I4B - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: Swap -PUBLIC :: Swap_ - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Swap two integer - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_Int8(a, b) - INTEGER(INT8), INTENT(INOUT) :: a, b - END SUBROUTINE Swap_Int8 - MODULE PURE SUBROUTINE Swap_Int16(a, b) - INTEGER(INT16), INTENT(INOUT) :: a, b - END SUBROUTINE Swap_Int16 - MODULE PURE SUBROUTINE Swap_Int32(a, b) - INTEGER(INT32), INTENT(INOUT) :: a, b - END SUBROUTINE Swap_Int32 - MODULE PURE SUBROUTINE Swap_Int64(a, b) - INTEGER(INT64), INTENT(INOUT) :: a, b - END SUBROUTINE Swap_Int64 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Swap two real - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_r32(a, b) - REAL(REAL32), INTENT(INOUT) :: a, b - END SUBROUTINE Swap_r32 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Swap two real - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_r64(a, b) - REAL(REAL64), INTENT(INOUT) :: a, b - END SUBROUTINE Swap_r64 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> 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_r32v(a, b) - REAL(REAL32), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_r32v - - MODULE PURE SUBROUTINE Swap_r64v(a, b) - REAL(REAL64), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_r64v -END INTERFACE Swap -#endif - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two integer vectors - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_Int8v(a, b) - INTEGER(INT8), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_Int8v - MODULE PURE SUBROUTINE Swap_Int16v(a, b) - INTEGER(INT16), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_Int16v - MODULE PURE SUBROUTINE Swap_Int32v(a, b) - INTEGER(INT32), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_Int32v - MODULE PURE SUBROUTINE Swap_Int64v(a, b) - INTEGER(INT64), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_Int64v -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_Int128v(a, b) - INTEGER(INT128), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_Int128v -END INTERFACE Swap -#endif - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Subroutine for interchanging two complex numbers - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_c(a, b) - COMPLEX(DFPC), INTENT(INOUT) :: a, b - END SUBROUTINE Swap_c -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -#ifndef USE_BLAS95 -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_cv(a, b) - COMPLEX(DFPC), INTENT(INOUT) :: a(:), b(:) - END SUBROUTINE Swap_cv -END INTERFACE Swap -#endif - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_cm(a, b) - COMPLEX(DFPC), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_cm -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two matrix of real numbers - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_r32m(a, b) - REAL(REAL32), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_r32m -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two real matrix - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_r64m(a, b) - REAL(REAL64), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_r64m -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two integer matrix - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_Int8m(a, b) - INTEGER(INT8), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_Int8m - - MODULE PURE SUBROUTINE Swap_Int16m(a, b) - INTEGER(INT16), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_Int16m - - MODULE PURE SUBROUTINE Swap_Int32m(a, b) - INTEGER(INT32), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_Int32m - - MODULE PURE SUBROUTINE Swap_Int64m(a, b) - INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_Int64m -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_Int128m(a, b) - INTEGER(Int128), INTENT(INOUT) :: a(:, :), b(:, :) - END SUBROUTINE Swap_Int128m -END INTERFACE Swap -#endif - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two scalars with masking - -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_r32s(a, b, mask) - REAL(REAL32), INTENT(INOUT) :: a, b - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE masked_Swap_r32s -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two scalars with masking - -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_r64s(a, b, mask) - REAL(REAL64), INTENT(INOUT) :: a, b - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE masked_Swap_r64s -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two scalars with masking - -INTERFACE Swap - 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 - - 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 - - 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 - - MODULE PURE SUBROUTINE masked_Swap_Int64s(a, b, mask) - INTEGER(INT64), INTENT(INOUT) :: a, b - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE masked_Swap_Int64s -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two scalars with masking - -#ifdef USE_Int128 -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_Int128s(a, b, mask) - INTEGER(Int128), INTENT(INOUT) :: a, b - LOGICAL(LGT), INTENT(IN) :: mask - END SUBROUTINE masked_Swap_Int128s -END INTERFACE Swap -#endif - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two vectors with masking - -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_r32v(a, b, mask) - REAL(REAL32), INTENT(INOUT) :: a(:), b(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE masked_Swap_r32v -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two vectors with masking - -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_r64v(a, b, mask) - REAL(REAL64), INTENT(INOUT) :: a(:), b(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE masked_Swap_r64v -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two vectors with masking - -INTERFACE Swap - 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 - - 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 - - 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 - - MODULE PURE SUBROUTINE masked_Swap_Int64v(a, b, mask) - INTEGER(INT64), INTENT(INOUT) :: a(:), b(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE masked_Swap_Int64v -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two vectors with masking - -#ifdef USE_Int128 -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_Int128v(a, b, mask) - INTEGER(Int128), INTENT(INOUT) :: a(:), b(:) - LOGICAL(LGT), INTENT(IN) :: mask(:) - END SUBROUTINE masked_Swap_Int128v -END INTERFACE Swap -#endif - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two matrices with masking - -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_r32m(a, b, mask) - REAL(REAL32), INTENT(INOUT) :: a(:, :), b(:, :) - LOGICAL(LGT), INTENT(IN) :: mask(:, :) - END SUBROUTINE masked_Swap_r32m -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two matrices with masking - -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_r64m(a, b, mask) - REAL(REAL64), INTENT(INOUT) :: a(:, :), b(:, :) - LOGICAL(LGT), INTENT(IN) :: mask(:, :) - END SUBROUTINE masked_Swap_r64m -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two matrices with masking - -INTERFACE Swap - 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 - - 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 - - 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 - - MODULE PURE SUBROUTINE masked_Swap_Int64m(a, b, mask) - INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :) - LOGICAL(LGT), INTENT(IN) :: mask(:, :) - END SUBROUTINE masked_Swap_Int64m -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two matrices with masking - -#ifdef USE_Int128 -INTERFACE Swap - MODULE PURE SUBROUTINE masked_Swap_Int128m(a, b, mask) - INTEGER(Int128), INTENT(INOUT) :: a(:, :), b(:, :) - LOGICAL(LGT), INTENT(IN) :: mask(:, :) - END SUBROUTINE masked_Swap_Int128m -END INTERFACE Swap -#endif - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-20 -! summary: Swap the index, it is like taking transpose. -! -!# Introduction -! -! - This routine returns an matrix by chaning the dimensions of input matrix -! `b`. -! - This routine does not check the shape, so make sure the shape of -! `a` and `b` are appropriate,. -! - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_index1(a, b, i1, i2) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :) - !! the returned array - REAL(REAL32), INTENT(IN) :: b(:, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 2 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 2 - END SUBROUTINE Swap_index1 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> 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_index2(a, b, i1, i2) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :) - !! the returned array - REAL(REAL64), INTENT(IN) :: b(:, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 2 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 2 - END SUBROUTINE Swap_index2 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-20 -! summary: Swap the index, it is like taking transpose. -! -!# Introduction -! -! - This routine returns an matrix by chaning the dimensions of input matrix -! `b`. -! - This routine does not check the shape, so make sure the shape of -! `a` and `b` are appropriate,. -! - -INTERFACE Swap_ - MODULE PURE SUBROUTINE Swap_index_1(a, b, i1, i2) - REAL(REAL32), INTENT(INOUT) :: a(:, :) - !! the returned array - REAL(REAL32), INTENT(IN) :: b(:, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 2 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 2 - END SUBROUTINE Swap_index_1 - - MODULE PURE SUBROUTINE Swap_index_2(a, b, i1, i2) - REAL(REAL64), INTENT(INOUT) :: a(:, :) - !! the returned array - REAL(REAL64), INTENT(IN) :: b(:, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 2 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 2 - END SUBROUTINE Swap_index_2 -END INTERFACE Swap_ - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> 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_index3(a, b, i1, i2, i3) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :) - !! the returned array - REAL(REAL32), INTENT(IN) :: b(:, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 3 - END SUBROUTINE Swap_index3 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> 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_3(a, b, i1, i2, i3) - REAL(REAL32), INTENT(INOUT) :: a(:, :, :) - !! the returned array - REAL(REAL32), INTENT(IN) :: b(:, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 3 - END SUBROUTINE Swap_index_3 - - MODULE PURE SUBROUTINE Swap_index_4(a, b, i1, i2, i3) - REAL(REAL64), INTENT(INOUT) :: a(:, :, :) - !! the returned array - REAL(REAL64), INTENT(IN) :: b(:, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 3 - END SUBROUTINE Swap_index_4 -END INTERFACE Swap_ - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-20 -! update: 2021-11-20 -! summary: Swap the index, it is like taking transpose. -! -!# Introduction -! -! - This routine returns an matrix by chaning the dimensions of input matrix -! `b`. -! - This routine does not check the shape, so make sure the shape of -! `a` and `b` are appropriate,. -! - -INTERFACE Swap - MODULE PURE SUBROUTINE Swap_index4(a, b, i1, i2, i3) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :) - !! the returned array - REAL(REAL64), INTENT(IN) :: b(:, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 3 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 3 - END SUBROUTINE Swap_index4 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> 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_index5(a, b, i1, i2, i3, i4) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) - !! the returned array - REAL(REAL64), INTENT(IN) :: b(:, :, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i4 - !! index 4 is Swapped with index `i4` - !! make sure i4 is less than or equal to 4 - END SUBROUTINE Swap_index5 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> 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_index6(a, b, i1, i2, i3, i4) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) - !! the returned array - REAL(REAL32), INTENT(IN) :: b(:, :, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i4 - !! index 4 is Swapped with index `i4` - !! make sure i4 is less than or equal to 4 - END SUBROUTINE Swap_index6 -END INTERFACE Swap - -!---------------------------------------------------------------------------- -! Swap@SwapMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-20 -! update: 2021-11-20 -! summary: Swap the index, it is like taking transpose. -! -!# Introduction -! -! - This routine returns an matrix by chaning the dimensions of input matrix -! `b`. -! - This routine does not check the shape, so make sure the shape of -! `a` and `b` are appropriate,. - -INTERFACE Swap_ - MODULE PURE SUBROUTINE Swap_index_5(a, b, i1, i2, i3, i4) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) - !! the returned array - REAL(REAL32), INTENT(IN) :: b(:, :, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i4 - !! index 4 is Swapped with index `i4` - !! make sure i4 is less than or equal to 4 - END SUBROUTINE Swap_index_5 - - MODULE PURE SUBROUTINE Swap_index_6(a, b, i1, i2, i3, i4) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) - !! the returned array - REAL(REAL64), INTENT(IN) :: b(:, :, :, :) - !! input array, it will be untouched - INTEGER(I4B), INTENT(IN) :: i1 - !! index 1 is Swapped with index `i1` - !! make sure i1 is lesser than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i2 - !! index 2 is Swapped with index `i2` - !! make sure i2 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i3 - !! index 3 is Swapped with index `i3` - !! make sure i3 is less than or equal to 4 - INTEGER(I4B), INTENT(IN) :: i4 - !! index 4 is Swapped with index `i4` - !! make sure i4 is less than or equal to 4 - END SUBROUTINE Swap_index_6 -END INTERFACE Swap_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE SwapUtility diff --git a/src/modules/Utility/src/SymUtility.F90 b/src/modules/Utility/src/SymUtility.F90 deleted file mode 100644 index 34eb9062c..000000000 --- a/src/modules/Utility/src/SymUtility.F90 +++ /dev/null @@ -1,163 +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 SymUtility -USE GlobalData, ONLY: DFP, I4B, REAL32, REAL64, INT32, INT64, INT8, INT16 -IMPLICIT NONE -PRIVATE -PUBLIC :: Sym -PUBLIC :: GetSym - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-12 -! summary: Make symmetric matrix form lower or upper triangular matrix -! -!# Introduction -! -! This method returns a symmetric matrix from the lower or upper -! triangular part of a given square dense matrix. -! -! If `from = U`, then upper triangle part of mat is used -! If `from = L`, then lower triangle part of mat is used - -INTERFACE - !! - MODULE PURE FUNCTION Sym_Int8(mat, from) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - INTEGER(INT8) :: ans(SIZE(mat, 1), SIZE(mat, 2)) - END FUNCTION Sym_Int8 - !! - MODULE PURE FUNCTION Sym_Int16(mat, from) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - INTEGER(INT16) :: ans(SIZE(mat, 1), SIZE(mat, 2)) - END FUNCTION Sym_Int16 - !! - MODULE PURE FUNCTION Sym_Int32(mat, from) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - INTEGER(INT32) :: ans(SIZE(mat, 1), SIZE(mat, 2)) - END FUNCTION Sym_Int32 - !! - MODULE PURE FUNCTION Sym_Int64(mat, from) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - INTEGER(INT64) :: ans(SIZE(mat, 1), SIZE(mat, 2)) - END FUNCTION Sym_Int64 - !! - MODULE PURE FUNCTION Sym_Real32(mat, from) RESULT(ans) - REAL(REAL32), INTENT(IN) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - REAL(REAL32) :: ans(SIZE(mat, 1), SIZE(mat, 2)) - END FUNCTION Sym_Real32 - !! - MODULE PURE FUNCTION Sym_Real64(mat, from) RESULT(ans) - REAL(REAL64), INTENT(IN) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - REAL(REAL64) :: ans(SIZE(mat, 1), SIZE(mat, 2)) - END FUNCTION Sym_Real64 - !! -END INTERFACE - -INTERFACE Sym - MODULE PROCEDURE Sym_Int8, Sym_Int16, Sym_Int32, & - & Sym_Int64, Sym_Real32, Sym_Real64 -END INTERFACE Sym - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-12 -! summary: Make symmetric matrix form lower or upper triangular matrix -! -!# Introduction -! -! This method returns a symmetric matrix from the lower or upper -! triangular part of a given square dense matrix. -! -! If `from = U`, then upper triangle part of mat is used -! If `from = L`, then lower triangle part of mat is used - -INTERFACE - MODULE PURE SUBROUTINE GetSym_Int8(mat, from) - INTEGER(INT8), INTENT(INOUT) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - END SUBROUTINE GetSym_Int8 - !! - MODULE PURE SUBROUTINE GetSym_Int16(mat, from) - INTEGER(INT16), INTENT(INOUT) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - END SUBROUTINE GetSym_Int16 - !! - MODULE PURE SUBROUTINE GetSym_Int32(mat, from) - INTEGER(INT32), INTENT(INOUT) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - END SUBROUTINE GetSym_Int32 - !! - MODULE PURE SUBROUTINE GetSym_Int64(mat, from) - INTEGER(INT64), INTENT(INOUT) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - END SUBROUTINE GetSym_Int64 - !! - MODULE PURE SUBROUTINE GetSym_Real32(mat, from) - REAL(REAL32), INTENT(INOUT) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - END SUBROUTINE GetSym_Real32 - !! - MODULE PURE SUBROUTINE GetSym_Real64(mat, from) - REAL(REAL64), INTENT(INOUT) :: mat(:, :) - CHARACTER(1), INTENT(IN) :: from - !! from = "U", then upper triangular part must be provided - !! from = "L", then lower triangular part must be provided - END SUBROUTINE GetSym_Real64 -END INTERFACE - -INTERFACE GetSym - MODULE PROCEDURE GetSym_Int8, GetSym_Int16, GetSym_Int32, & - & GetSym_Int64, GetSym_Real32, GetSym_Real64 -END INTERFACE GetSym - -END MODULE SymUtility diff --git a/src/modules/Utility/src/TailUtility.F90 b/src/modules/Utility/src/TailUtility.F90 deleted file mode 100644 index 957907374..000000000 --- a/src/modules/Utility/src/TailUtility.F90 +++ /dev/null @@ -1,132 +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 TailUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: TAIL -PUBLIC :: LAST - -!---------------------------------------------------------------------------- -! Tail -!---------------------------------------------------------------------------- - -INTERFACE TAIL - MODULE PURE FUNCTION tail_Int8(x) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: x(:) - INTEGER(INT8) :: ans(SIZE(x) - 1) - END FUNCTION tail_Int8 - - MODULE PURE FUNCTION tail_Int16(x) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: x(:) - INTEGER(INT16) :: ans(SIZE(x) - 1) - END FUNCTION tail_Int16 - - MODULE PURE FUNCTION tail_Int32(x) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: x(:) - INTEGER(INT32) :: ans(SIZE(x) - 1) - END FUNCTION tail_Int32 - - MODULE PURE FUNCTION tail_Int64(x) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: x(:) - INTEGER(INT64) :: ans(SIZE(x) - 1) - END FUNCTION tail_Int64 -END INTERFACE TAIL - -!---------------------------------------------------------------------------- -! Tail -!---------------------------------------------------------------------------- - -INTERFACE TAIL - MODULE PURE FUNCTION tail_Real32(x) RESULT(ans) - REAL(REAL32), INTENT(IN) :: x(:) - REAL(REAL32) :: ans(SIZE(x) - 1) - END FUNCTION tail_Real32 - - MODULE PURE FUNCTION tail_Real64(x) RESULT(ans) - REAL(REAL64), INTENT(IN) :: x(:) - REAL(REAL64) :: ans(SIZE(x) - 1) - END FUNCTION tail_Real64 -END INTERFACE TAIL - -!---------------------------------------------------------------------------- -! Tail -!---------------------------------------------------------------------------- - -INTERFACE TAIL - MODULE PURE FUNCTION tail_char(x) RESULT(ans) - CHARACTER(*), INTENT(IN) :: x - CHARACTER(LEN(x) - 1) :: ans - END FUNCTION tail_char -END INTERFACE TAIL - -!---------------------------------------------------------------------------- -! Last -!---------------------------------------------------------------------------- - -INTERFACE LAST - MODULE PURE FUNCTION last_Int8(x) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: x(:) - INTEGER(INT8) :: ans - END FUNCTION last_Int8 - - MODULE PURE FUNCTION last_Int16(x) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: x(:) - INTEGER(INT16) :: ans - END FUNCTION last_Int16 - - MODULE PURE FUNCTION last_Int32(x) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: x(:) - INTEGER(INT32) :: ans - END FUNCTION last_Int32 - - MODULE PURE FUNCTION last_Int64(x) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: x(:) - INTEGER(INT64) :: ans - END FUNCTION last_Int64 -END INTERFACE LAST - -!---------------------------------------------------------------------------- -! Last -!---------------------------------------------------------------------------- - -INTERFACE LAST - MODULE PURE FUNCTION last_Real32(x) RESULT(ans) - REAL(REAL32), INTENT(IN) :: x(:) - REAL(REAL32) :: ans - END FUNCTION last_Real32 - - MODULE PURE FUNCTION last_Real64(x) RESULT(ans) - REAL(REAL64), INTENT(IN) :: x(:) - REAL(REAL64) :: ans - END FUNCTION last_Real64 -END INTERFACE LAST - -!---------------------------------------------------------------------------- -! Last -!---------------------------------------------------------------------------- - -INTERFACE LAST - MODULE PURE FUNCTION last_char(x) RESULT(ans) - CHARACTER(*), INTENT(IN) :: x - CHARACTER(1) :: ans - END FUNCTION last_char -END INTERFACE LAST - -END MODULE TailUtility diff --git a/src/modules/Utility/src/TriagUtility.F90 b/src/modules/Utility/src/TriagUtility.F90 deleted file mode 100644 index fb54e66dc..000000000 --- a/src/modules/Utility/src/TriagUtility.F90 +++ /dev/null @@ -1,1081 +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: 2022-12-21 -! summary: Module for getting triangular parts of matrix -! -!# Introduction -! -! This module provides methods for getting and setting -! lower and upper triangular part of the matrix. -! -! This module is inspired by the same functionality avaiable in -! numpy -! -! Following methods are implemented or planned -! -! - TriuIndx() -! - TrilIndx() -! - Triu() -! - Tril() -! - GetTriu() -! - GetTril() -! - SetTriu() -! - SetTril() -! -!## TriuIndx -! -!```fortran -! TriuIndx(m=3, n=5, k = 0) !! matrix of shape (3,5) , diag = 0 -! TriuIndx(m=3, n=5, k = 1) !! matrix of shape (3,5) , diag = 1 -! TriuIndx(m=3, n=5, k = -1) !! matrix of shape (3,5) , diag = -1 -! TriuIndx(m=4, k = 0) !! square matrix of shape (4,4), diag = 0 -! TriuIndx(A, k=0) !! A is a matrix (square or rectangle) -!``` -!## TrilIndx -! -!```fortran -! TrilIndx(m=3, n=5, k = 0) !! matrix of shape (3,5) , diag = 0 -! TrilIndx(m=4, k = 0) !! square matrix of shape (4,4), diag = 0 -! TrilIndx(A, k=0) !! A is a matrix (square or rectangle) -!``` - -MODULE TriagUtility -USE GlobalData, ONLY: DFP, REAL32, REAL64, I4B, INT8, INT16, INT32, INT64, & - & LGT -IMPLICIT NONE -PRIVATE - -PUBLIC :: TriuIndx -PUBLIC :: TrilIndx -PUBLIC :: Tril -PUBLIC :: Triu -PUBLIC :: GetTril -PUBLIC :: GetTriu -PUBLIC :: SetTril -PUBLIC :: SetTriu - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the indices of upper triangle in an int vector -! -!# Introduction -! -! This function returns the indices of upper triangle in a integer vec -! starting from diag number k. -! -! k denotes the diag number -! k = 0 => main diag -! k > 0 => super diag -! k < 0 => sub diag - -INTERFACE - MODULE PURE FUNCTION TriuIndx_1(m, n, diagNo) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - !! number of rows - INTEGER(I4B), OPTIONAL, INTENT(IN) :: n - !! number of columns, default = m - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION TriuIndx_1 -END INTERFACE - -INTERFACE TriuIndx - MODULE PROCEDURE TriuIndx_1 -END INTERFACE TriuIndx - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the indices of upper triangle in an int vector -! -!# Introduction -! -! This function returns the indices of upper triangle in a integer vec -! starting from diag number k. Please read at TriuIndx_1 -! - -INTERFACE - MODULE PURE FUNCTION TriuIndx_2(A, diagNo) RESULT(ans) - CLASS(*), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION TriuIndx_2 -END INTERFACE - -INTERFACE TriuIndx - MODULE PROCEDURE TriuIndx_2 -END INTERFACE TriuIndx - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the indices of lower triangle part of a matrix - -INTERFACE - MODULE PURE FUNCTION TrilIndx_1(m, n, diagNo) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: m - !! number of rows - INTEGER(I4B), OPTIONAL, INTENT(IN) :: n - !! number of columns, default = m - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - !! ans(:,1) contains the row indices - !! ans(:,2) contains the col indices - END FUNCTION TrilIndx_1 -END INTERFACE - -INTERFACE TrilIndx - MODULE PROCEDURE TrilIndx_1 -END INTERFACE TrilIndx - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the indices of lower triangle part of a matrix - -INTERFACE - MODULE PURE FUNCTION TrilIndx_2(A, diagNo) RESULT(ans) - CLASS(*), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - !! ans(:,1) contains the row indices - !! ans(:,2) contains the col indices - END FUNCTION TrilIndx_2 -END INTERFACE - -INTERFACE TrilIndx - MODULE PROCEDURE TrilIndx_2 -END INTERFACE TrilIndx - -!---------------------------------------------------------------------------- -! Triu -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the upper triangle part of a matrix. - -INTERFACE - MODULE PURE FUNCTION Triu_1(A, diagNo) RESULT(ans) - REAL(REAL32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL32) :: ans(SIZE(A, 1), SIZE(A, 2)) - END FUNCTION Triu_1 - - MODULE PURE FUNCTION Triu_2(A, diagNo) RESULT(ans) - REAL(REAL64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL64) :: ans(SIZE(A, 1), SIZE(A, 2)) - END FUNCTION Triu_2 - - MODULE PURE FUNCTION Triu_3(A, diagNo) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT8) :: ans(SIZE(A, 1), SIZE(A, 2)) - END FUNCTION Triu_3 - - MODULE PURE FUNCTION Triu_4(A, diagNo) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT16) :: ans(SIZE(A, 1), SIZE(A, 2)) - END FUNCTION Triu_4 - - MODULE PURE FUNCTION Triu_5(A, diagNo) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT32) :: ans(SIZE(A, 1), SIZE(A, 2)) - END FUNCTION Triu_5 - - MODULE PURE FUNCTION Triu_6(A, diagNo) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT64) :: ans(SIZE(A, 1), SIZE(A, 2)) - END FUNCTION Triu_6 -END INTERFACE - -INTERFACE Triu - MODULE PROCEDURE Triu_1, Triu_2, Triu_3, Triu_4, Triu_5, Triu_6 -END INTERFACE Triu - -!---------------------------------------------------------------------------- -! Triu -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the lower triangle part of an int vector - -INTERFACE - MODULE PURE FUNCTION Triu_7(A, flate, diagNo) RESULT(ans) - REAL(REAL32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL32), ALLOCATABLE :: ans(:) - END FUNCTION Triu_7 - MODULE PURE FUNCTION Triu_8(A, flate, diagNo) RESULT(ans) - REAL(REAL64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL64), ALLOCATABLE :: ans(:) - END FUNCTION Triu_8 - MODULE PURE FUNCTION Triu_9(A, flate, diagNo) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT8), ALLOCATABLE :: ans(:) - END FUNCTION Triu_9 - MODULE PURE FUNCTION Triu_10(A, flate, diagNo) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT16), ALLOCATABLE :: ans(:) - END FUNCTION Triu_10 - MODULE PURE FUNCTION Triu_11(A, flate, diagNo) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT32), ALLOCATABLE :: ans(:) - END FUNCTION Triu_11 - MODULE PURE FUNCTION Triu_12(A, flate, diagNo) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT64), ALLOCATABLE :: ans(:) - END FUNCTION Triu_12 -END INTERFACE - -INTERFACE Triu - MODULE PROCEDURE Triu_7, Triu_8, Triu_9, Triu_10, Triu_11, Triu_12 -END INTERFACE Triu - -!---------------------------------------------------------------------------- -! Tril -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the lower triangle part of a matrix - -INTERFACE - MODULE PURE FUNCTION Tril_1(A, diagNo) RESULT(ans) - REAL(REAL32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL32) :: ans(SIZE(A, 1), SIZE(A, 2)) - !! Lower trianglular matrix - END FUNCTION Tril_1 - - MODULE PURE FUNCTION Tril_2(A, diagNo) RESULT(ans) - REAL(REAL64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL64) :: ans(SIZE(A, 1), SIZE(A, 2)) - !! Lower trianglular matrix - END FUNCTION Tril_2 - - MODULE PURE FUNCTION Tril_3(A, diagNo) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT8) :: ans(SIZE(A, 1), SIZE(A, 2)) - !! Lower trianglular matrix - END FUNCTION Tril_3 - - MODULE PURE FUNCTION Tril_4(A, diagNo) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT16) :: ans(SIZE(A, 1), SIZE(A, 2)) - !! Lower trianglular matrix - END FUNCTION Tril_4 - - MODULE PURE FUNCTION Tril_5(A, diagNo) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT32) :: ans(SIZE(A, 1), SIZE(A, 2)) - !! Lower trianglular matrix - END FUNCTION Tril_5 - - MODULE PURE FUNCTION Tril_6(A, diagNo) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT64) :: ans(SIZE(A, 1), SIZE(A, 2)) - !! Lower trianglular matrix - END FUNCTION Tril_6 -END INTERFACE - -INTERFACE Tril - MODULE PROCEDURE Tril_1, Tril_2, Tril_3, Tril_4, Tril_5, Tril_6 -END INTERFACE Tril - -!---------------------------------------------------------------------------- -! Tril -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the lower triangle part of a matrix - -INTERFACE - MODULE PURE FUNCTION Tril_7(A, flate, diagNo) RESULT(ans) - REAL(REAL32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL32), ALLOCATABLE :: ans(:) - END FUNCTION Tril_7 - MODULE PURE FUNCTION Tril_8(A, flate, diagNo) RESULT(ans) - REAL(REAL64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - REAL(REAL64), ALLOCATABLE :: ans(:) - END FUNCTION Tril_8 - MODULE PURE FUNCTION Tril_9(A, flate, diagNo) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT8), ALLOCATABLE :: ans(:) - END FUNCTION Tril_9 - MODULE PURE FUNCTION Tril_10(A, flate, diagNo) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT16), ALLOCATABLE :: ans(:) - END FUNCTION Tril_10 - MODULE PURE FUNCTION Tril_11(A, flate, diagNo) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT32), ALLOCATABLE :: ans(:) - END FUNCTION Tril_11 - MODULE PURE FUNCTION Tril_12(A, flate, diagNo) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - !! diagNo>0 means super diagonal - !! diagNo<0 means subdiagonal - INTEGER(INT64), ALLOCATABLE :: ans(:) - END FUNCTION Tril_12 -END INTERFACE - -INTERFACE Tril - MODULE PROCEDURE Tril_7, Tril_8, Tril_9, Tril_10, Tril_11, Tril_12 -END INTERFACE Tril - -!---------------------------------------------------------------------------- -! GetTriu -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the upper triangle part of a matrix - -INTERFACE - MODULE PURE SUBROUTINE GetTriu_1(A, diagNo, lu) - REAL(REAL32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTriu_1 - - MODULE PURE SUBROUTINE GetTriu_2(A, diagNo, lu) - REAL(REAL64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTriu_2 - - MODULE PURE SUBROUTINE GetTriu_3(A, diagNo, lu) - INTEGER(INT8), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTriu_3 - - MODULE PURE SUBROUTINE GetTriu_4(A, diagNo, lu) - INTEGER(INT16), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTriu_4 - - MODULE PURE SUBROUTINE GetTriu_5(A, diagNo, lu) - INTEGER(INT32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTriu_5 - - MODULE PURE SUBROUTINE GetTriu_6(A, diagNo, lu) - INTEGER(INT64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTriu_6 -END INTERFACE - -INTERFACE GetTriu - MODULE PROCEDURE GetTriu_1, GetTriu_2, GetTriu_3, GetTriu_4, & - & GetTriu_5, GetTriu_6 -END INTERFACE GetTriu - -!---------------------------------------------------------------------------- -! GetTriu -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the upper triangle part of an int vector - -INTERFACE - MODULE PURE SUBROUTINE GetTriu_7(A, flate, diagNo, lu) - REAL(REAL32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTriu_7 - MODULE PURE SUBROUTINE GetTriu_8(A, flate, diagNo, lu) - REAL(REAL64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTriu_8 - MODULE PURE SUBROUTINE GetTriu_9(A, flate, diagNo, lu) - INTEGER(INT8), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTriu_9 - MODULE PURE SUBROUTINE GetTriu_10(A, flate, diagNo, lu) - INTEGER(INT16), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTriu_10 - MODULE PURE SUBROUTINE GetTriu_11(A, flate, diagNo, lu) - INTEGER(INT32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTriu_11 - MODULE PURE SUBROUTINE GetTriu_12(A, flate, diagNo, lu) - INTEGER(INT64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTriu_12 -END INTERFACE - -INTERFACE GetTriu - MODULE PROCEDURE GetTriu_7, GetTriu_8, GetTriu_9, GetTriu_10, & - & GetTriu_11, GetTriu_12 -END INTERFACE GetTriu - -!---------------------------------------------------------------------------- -! GetTril -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the lower triangle part of an int vector - -INTERFACE - MODULE PURE SUBROUTINE GetTril_1(A, diagNo, lu) - REAL(REAL32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTril_1 - - MODULE PURE SUBROUTINE GetTril_2(A, diagNo, lu) - REAL(REAL64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTril_2 - - MODULE PURE SUBROUTINE GetTril_3(A, diagNo, lu) - INTEGER(INT8), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTril_3 - - MODULE PURE SUBROUTINE GetTril_4(A, diagNo, lu) - INTEGER(INT16), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTril_4 - - MODULE PURE SUBROUTINE GetTril_5(A, diagNo, lu) - INTEGER(INT32), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTril_5 - - MODULE PURE SUBROUTINE GetTril_6(A, diagNo, lu) - INTEGER(INT64), INTENT(IN) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) - END SUBROUTINE GetTril_6 -END INTERFACE - -INTERFACE GetTril - MODULE PROCEDURE GetTril_1, GetTril_2, GetTril_3, GetTril_4, & - & GetTril_5, GetTril_6 -END INTERFACE GetTril - -!---------------------------------------------------------------------------- -! GetTril -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the lower triangle part of an int vector - -INTERFACE - MODULE PURE SUBROUTINE GetTril_7(A, flate, diagNo, lu) - REAL(REAL32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTril_7 - MODULE PURE SUBROUTINE GetTril_8(A, flate, diagNo, lu) - REAL(REAL64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTril_8 - MODULE PURE SUBROUTINE GetTril_9(A, flate, diagNo, lu) - INTEGER(INT8), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTril_9 - MODULE PURE SUBROUTINE GetTril_10(A, flate, diagNo, lu) - INTEGER(INT16), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTril_10 - MODULE PURE SUBROUTINE GetTril_11(A, flate, diagNo, lu) - INTEGER(INT32), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTril_11 - MODULE PURE SUBROUTINE GetTril_12(A, flate, diagNo, lu) - INTEGER(INT64), INTENT(IN) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), ALLOCATABLE, INTENT(OUT) :: lu(:) - END SUBROUTINE GetTril_12 -END INTERFACE - -INTERFACE GetTril - MODULE PROCEDURE GetTril_7, GetTril_8, GetTril_9, GetTril_10, & - & GetTril_11, GetTril_12 -END INTERFACE GetTril - -!---------------------------------------------------------------------------- -! SetTriu -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the upper triangle part of an int vector - -INTERFACE - MODULE PURE SUBROUTINE SetTriu_1(A, lu, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTriu_1 - - MODULE PURE SUBROUTINE SetTriu_2(A, lu, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTriu_2 - - MODULE PURE SUBROUTINE SetTriu_3(A, lu, diagNo) - INTEGER(INT8), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTriu_3 - - MODULE PURE SUBROUTINE SetTriu_4(A, lu, diagNo) - INTEGER(INT16), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTriu_4 - - MODULE PURE SUBROUTINE SetTriu_5(A, lu, diagNo) - INTEGER(INT32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTriu_5 - - MODULE PURE SUBROUTINE SetTriu_6(A, lu, diagNo) - INTEGER(INT64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTriu_6 -END INTERFACE - -INTERFACE SetTriu - MODULE PROCEDURE SetTriu_1, SetTriu_2, SetTriu_3, SetTriu_4, & - & SetTriu_5, SetTriu_6 -END INTERFACE SetTriu - -!---------------------------------------------------------------------------- -! SetTriu -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the upper triangle part of an int vector - -INTERFACE - MODULE PURE SUBROUTINE SetTriu_7(A, flate, lu, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: lu(:) - END SUBROUTINE SetTriu_7 - MODULE PURE SUBROUTINE SetTriu_8(A, flate, lu, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: lu(:) - END SUBROUTINE SetTriu_8 - MODULE PURE SUBROUTINE SetTriu_9(A, flate, lu, diagNo) - INTEGER(INT8), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), INTENT(IN) :: lu(:) - END SUBROUTINE SetTriu_9 - MODULE PURE SUBROUTINE SetTriu_10(A, flate, lu, diagNo) - INTEGER(INT16), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), INTENT(IN) :: lu(:) - END SUBROUTINE SetTriu_10 - MODULE PURE SUBROUTINE SetTriu_11(A, flate, lu, diagNo) - INTEGER(INT32), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), INTENT(IN) :: lu(:) - END SUBROUTINE SetTriu_11 - MODULE PURE SUBROUTINE SetTriu_12(A, flate, lu, diagNo) - INTEGER(INT64), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), INTENT(IN) :: lu(:) - END SUBROUTINE SetTriu_12 -END INTERFACE - -INTERFACE SetTriu - MODULE PROCEDURE SetTriu_7, SetTriu_8, SetTriu_9, SetTriu_10, & - & SetTriu_11, SetTriu_12 -END INTERFACE SetTriu - -!---------------------------------------------------------------------------- -! SetTriu -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Set the upper triangle part to a scalar value - -INTERFACE - - MODULE PURE SUBROUTINE SetTriu_13(A, val, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: val - END SUBROUTINE SetTriu_13 - - MODULE PURE SUBROUTINE SetTriu_14(A, val, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: val - END SUBROUTINE SetTriu_14 - - MODULE PURE SUBROUTINE SetTriu_15(A, val, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(I4B), INTENT(IN) :: val - END SUBROUTINE SetTriu_15 - - MODULE PURE SUBROUTINE SetTriu_16(A, val, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: val - END SUBROUTINE SetTriu_16 - - MODULE PURE SUBROUTINE SetTriu_17(A, val, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: val - END SUBROUTINE SetTriu_17 - - MODULE PURE SUBROUTINE SetTriu_18(A, val, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(I4B), INTENT(IN) :: val - END SUBROUTINE SetTriu_18 - -END INTERFACE - -INTERFACE SetTriu - MODULE PROCEDURE SetTriu_13, SetTriu_14, SetTriu_15, & - & SetTriu_16, SetTriu_17, SetTriu_18 -END INTERFACE SetTriu - -!---------------------------------------------------------------------------- -! SetTril -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the upper triangle part of an int vector - -INTERFACE - MODULE PURE SUBROUTINE SetTril_1(A, lu, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTril_1 - - MODULE PURE SUBROUTINE SetTril_2(A, lu, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTril_2 - - MODULE PURE SUBROUTINE SetTril_3(A, lu, diagNo) - INTEGER(INT8), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTril_3 - - MODULE PURE SUBROUTINE SetTril_4(A, lu, diagNo) - INTEGER(INT16), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTril_4 - - MODULE PURE SUBROUTINE SetTril_5(A, lu, diagNo) - INTEGER(INT32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTril_5 - - MODULE PURE SUBROUTINE SetTril_6(A, lu, diagNo) - INTEGER(INT64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), INTENT(IN) :: lu(:, :) - END SUBROUTINE SetTril_6 -END INTERFACE - -INTERFACE SetTril - MODULE PROCEDURE SetTril_1, SetTril_2, SetTril_3, SetTril_4, & - & SetTril_5, SetTril_6 -END INTERFACE SetTril - -!---------------------------------------------------------------------------- -! SetTril -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Returns the upper triangle part of an int vector - -INTERFACE - MODULE PURE SUBROUTINE SetTril_7(A, flate, lu, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: lu(:) - END SUBROUTINE SetTril_7 - MODULE PURE SUBROUTINE SetTril_8(A, flate, lu, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: lu(:) - END SUBROUTINE SetTril_8 - MODULE PURE SUBROUTINE SetTril_9(A, flate, lu, diagNo) - INTEGER(INT8), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT8), INTENT(IN) :: lu(:) - END SUBROUTINE SetTril_9 - MODULE PURE SUBROUTINE SetTril_10(A, flate, lu, diagNo) - INTEGER(INT16), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT16), INTENT(IN) :: lu(:) - END SUBROUTINE SetTril_10 - MODULE PURE SUBROUTINE SetTril_11(A, flate, lu, diagNo) - INTEGER(INT32), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT32), INTENT(IN) :: lu(:) - END SUBROUTINE SetTril_11 - MODULE PURE SUBROUTINE SetTril_12(A, flate, lu, diagNo) - INTEGER(INT64), INTENT(INOUT) :: A(:, :) - LOGICAL(LGT), INTENT(IN) :: flate - !! This variable is only for creating unique interface - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(INT64), INTENT(IN) :: lu(:) - END SUBROUTINE SetTril_12 -END INTERFACE - -INTERFACE SetTril - MODULE PROCEDURE SetTril_7, SetTril_8, SetTril_9, SetTril_10, & - & SetTril_11, SetTril_12 -END INTERFACE SetTril - -!---------------------------------------------------------------------------- -! SetTril -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: Set lower triangle part to a scalar value - -INTERFACE - - MODULE PURE SUBROUTINE SetTril_13(A, val, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: val - END SUBROUTINE SetTril_13 - - MODULE PURE SUBROUTINE SetTril_14(A, val, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: val - END SUBROUTINE SetTril_14 - - MODULE PURE SUBROUTINE SetTril_15(A, val, diagNo) - REAL(REAL32), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(I4B), INTENT(IN) :: val - END SUBROUTINE SetTril_15 - - MODULE PURE SUBROUTINE SetTril_16(A, val, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL32), INTENT(IN) :: val - END SUBROUTINE SetTril_16 - - MODULE PURE SUBROUTINE SetTril_17(A, val, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - REAL(REAL64), INTENT(IN) :: val - END SUBROUTINE SetTril_17 - - MODULE PURE SUBROUTINE SetTril_18(A, val, diagNo) - REAL(REAL64), INTENT(INOUT) :: A(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo - !! diagonal number, default = 0 - INTEGER(I4B), INTENT(IN) :: val - END SUBROUTINE SetTril_18 - -END INTERFACE - -INTERFACE SetTril - MODULE PROCEDURE SetTril_13, SetTril_14, SetTril_15, & - & SetTril_16, SetTril_17, SetTril_18 -END INTERFACE SetTril - -END MODULE TriagUtility diff --git a/src/modules/Utility/src/Utility.F90 b/src/modules/Utility/src/Utility.F90 deleted file mode 100755 index 09c856099..000000000 --- a/src/modules/Utility/src/Utility.F90 +++ /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 - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-11 -! summary: This module contains several utility modules -! -!{!pages/Utility/index.md!} - -MODULE Utility -USE AppendUtility -USE ApproxUtility -USE ArangeUtility -USE AssertUtility -USE BinomUtility -USE ContractionUtility -USE ConvertUtility -USE DiagUtility -USE EigenUtility -USE EyeUtility -USE HeadUtility -USE TailUtility -USE SplitUtility -USE GridPointUtility -USE HashingUtility -USE InputUtility -USE IntegerUtility -USE InvUtility -USE LinearAlgebraUtility -USE MappingUtility -USE MatmulUtility -USE MedianUtility -USE MiscUtility -USE OnesUtility -USE PartitionUtility -USE ProductUtility -USE PushPopUtility -USE ReallocateUtility -USE SortUtility -USE StringUtility -USE SwapUtility -USE SymUtility -USE TriagUtility -USE ZerosUtility -USE SafeSizeUtility -END MODULE Utility diff --git a/src/modules/Utility/src/ZerosUtility.F90 b/src/modules/Utility/src/ZerosUtility.F90 deleted file mode 100644 index 606fb4599..000000000 --- a/src/modules/Utility/src/ZerosUtility.F90 +++ /dev/null @@ -1,400 +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 ZerosUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -PUBLIC :: Zeros - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Zeros_1(dim1, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(INT8), INTENT(IN) :: datatype - INTEGER(INT8) :: ans(dim1) - END FUNCTION Zeros_1 - - MODULE PURE FUNCTION Zeros_2(dim1, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(INT16), INTENT(IN) :: datatype - INTEGER(INT16) :: ans(dim1) - END FUNCTION Zeros_2 - - MODULE PURE FUNCTION Zeros_3(dim1, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(INT32), INTENT(IN) :: datatype - INTEGER(INT32) :: ans(dim1) - END FUNCTION Zeros_3 - - MODULE PURE FUNCTION Zeros_4(dim1, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(INT64), INTENT(IN) :: datatype - INTEGER(INT64) :: ans(dim1) - END FUNCTION Zeros_4 - -#ifdef USE_Int128 - MODULE PURE FUNCTION Zeros_5(dim1, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1) - END FUNCTION Zeros_5 -#endif -END INTERFACE - -INTERFACE Zeros - MODULE PROCEDURE Zeros_1, Zeros_2, Zeros_3, Zeros_4 -END INTERFACE Zeros - -#ifdef USE_Int128 -INTERFACE Zeros - MODULE PROCEDURE Zeros_5 -END INTERFACE Zeros -#endif - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Zeros_6(dim1, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - REAL(REAL32), INTENT(IN) :: datatype - REAL(REAL32) :: ans(dim1) - END FUNCTION Zeros_6 -!! - MODULE PURE FUNCTION Zeros_7(dim1, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - REAL(REAL64), INTENT(IN) :: datatype - REAL(REAL64) :: ans(dim1) - END FUNCTION Zeros_7 -END INTERFACE - -INTERFACE Zeros - MODULE PROCEDURE Zeros_6, Zeros_7 -END INTERFACE Zeros - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Zeros_8(dim1, dim2, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(INT8), INTENT(IN) :: datatype - INTEGER(INT8) :: ans(dim1, dim2) - END FUNCTION Zeros_8 -!! - MODULE PURE FUNCTION Zeros_9(dim1, dim2, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(INT16), INTENT(IN) :: datatype - INTEGER(INT16) :: ans(dim1, dim2) - END FUNCTION Zeros_9 -!! - MODULE PURE FUNCTION Zeros_10(dim1, dim2, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(INT32), INTENT(IN) :: datatype - INTEGER(INT32) :: ans(dim1, dim2) - END FUNCTION Zeros_10 -!! - MODULE PURE FUNCTION Zeros_11(dim1, dim2, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(INT64), INTENT(IN) :: datatype - INTEGER(INT64) :: ans(dim1, dim2) - END FUNCTION Zeros_11 -!! -#ifdef USE_Int128 -!! - MODULE PURE FUNCTION Zeros_12(dim1, dim2, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1, dim2) - END FUNCTION Zeros_12 -#endif -!! -END INTERFACE - -INTERFACE Zeros - MODULE PROCEDURE Zeros_8, Zeros_9, Zeros_10, Zeros_11 -END INTERFACE Zeros - -#ifdef USE_Int128 -INTERFACE Zeros - MODULE PROCEDURE Zeros_12 -END INTERFACE Zeros -#endif - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Zeros_13(dim1, dim2, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - REAL(REAL32), INTENT(IN) :: datatype - REAL(REAL32) :: ans(dim1, dim2) - END FUNCTION Zeros_13 -!! - MODULE PURE FUNCTION Zeros_14(dim1, dim2, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - REAL(REAL64), INTENT(IN) :: datatype - REAL(REAL64) :: ans(dim1, dim2) - END FUNCTION Zeros_14 -END INTERFACE - -INTERFACE Zeros - MODULE PROCEDURE Zeros_13, Zeros_14 -END INTERFACE Zeros - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Zeros_15(dim1, dim2, dim3, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(INT8), INTENT(IN) :: datatype - INTEGER(INT8) :: ans(dim1, dim2, dim3) - END FUNCTION Zeros_15 -!! - MODULE PURE FUNCTION Zeros_16(dim1, dim2, dim3, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(INT16), INTENT(IN) :: datatype - INTEGER(INT16) :: ans(dim1, dim2, dim3) - END FUNCTION Zeros_16 -!! - MODULE PURE FUNCTION Zeros_17(dim1, dim2, dim3, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(INT32), INTENT(IN) :: datatype - INTEGER(INT32) :: ans(dim1, dim2, dim3) - END FUNCTION Zeros_17 -!! - MODULE PURE FUNCTION Zeros_18(dim1, dim2, dim3, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(INT64), INTENT(IN) :: datatype - INTEGER(INT64) :: ans(dim1, dim2, dim3) - END FUNCTION Zeros_18 - -#ifdef USE_Int128 - !! - MODULE PURE FUNCTION Zeros_19(dim1, dim2, dim3, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1, dim2, dim3) - END FUNCTION Zeros_19 -#endif -END INTERFACE - -INTERFACE Zeros - MODULE PROCEDURE Zeros_15, Zeros_16, Zeros_17, Zeros_18 -END INTERFACE Zeros - -#ifdef USE_Int128 -INTERFACE Zeros - MODULE PROCEDURE Zeros_19 -END INTERFACE Zeros -#endif - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Zeros_20(dim1, dim2, dim3, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - REAL(REAL32), INTENT(IN) :: datatype - REAL(REAL32) :: ans(dim1, dim2, dim3) - END FUNCTION Zeros_20 -!! - MODULE PURE FUNCTION Zeros_21(dim1, dim2, dim3, datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - REAL(REAL64), INTENT(IN) :: datatype - REAL(REAL64) :: ans(dim1, dim2, dim3) - END FUNCTION Zeros_21 -END INTERFACE - -INTERFACE Zeros - MODULE PROCEDURE Zeros_20, Zeros_21 -END INTERFACE Zeros - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Zeros_22(dim1, dim2, dim3, dim4,& - & datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(INT8), INTENT(IN) :: datatype - INTEGER(INT8) :: ans(dim1, dim2, dim3, dim4) - END FUNCTION Zeros_22 -!! - MODULE PURE FUNCTION Zeros_23(dim1, dim2, dim3, dim4,& - & datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(INT16), INTENT(IN) :: datatype - INTEGER(INT16) :: ans(dim1, dim2, dim3, dim4) - END FUNCTION Zeros_23 -!! - MODULE PURE FUNCTION Zeros_24(dim1, dim2, dim3, dim4,& - & datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(INT32), INTENT(IN) :: datatype - INTEGER(INT32) :: ans(dim1, dim2, dim3, dim4) - END FUNCTION Zeros_24 -!! - MODULE PURE FUNCTION Zeros_25(dim1, dim2, dim3, dim4,& - & datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(INT64), INTENT(IN) :: datatype - INTEGER(INT64) :: ans(dim1, dim2, dim3, dim4) - END FUNCTION Zeros_25 - -#ifdef USE_Int128 -!! - MODULE PURE FUNCTION Zeros_26(dim1, dim2, dim3, dim4, & - & datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(Int128), INTENT(IN) :: datatype - INTEGER(Int128) :: ans(dim1, dim2, dim3, dim4) - END FUNCTION Zeros_26 -#endif -END INTERFACE - -INTERFACE Zeros - MODULE PROCEDURE Zeros_22, Zeros_23, Zeros_24, Zeros_25 -END INTERFACE Zeros - -#ifdef USE_Int128 -INTERFACE Zeros - MODULE PROCEDURE Zeros_26 -END INTERFACE Zeros -#endif - -!---------------------------------------------------------------------------- -! Zeros@FunctionalFortran -!---------------------------------------------------------------------------- - -INTERFACE Zeros - MODULE PURE FUNCTION Zeros_27(dim1, dim2, dim3, dim4, & - & datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - REAL(REAL32), INTENT(IN) :: datatype - REAL(REAL32) :: ans(dim1, dim2, dim3, dim4) - END FUNCTION Zeros_27 -!! - MODULE PURE FUNCTION Zeros_28(dim1, dim2, dim3, dim4, & - & datatype) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - REAL(REAL64), INTENT(IN) :: datatype - REAL(REAL64) :: ans(dim1, dim2, dim3, dim4) - END FUNCTION Zeros_28 -END INTERFACE Zeros - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -INTERFACE Zeros - MODULE PURE FUNCTION Zeros_29_Int8(s, datatype) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: s(:) - INTEGER(INT8), INTENT(IN) :: datatype - INTEGER(INT8) :: ans(s(1), s(2)) - END FUNCTION Zeros_29_Int8 - - MODULE PURE FUNCTION Zeros_29_Int16(s, datatype) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: s(:) - INTEGER(INT16), INTENT(IN) :: datatype - INTEGER(INT16) :: ans(s(1), s(2)) - END FUNCTION Zeros_29_Int16 - - MODULE PURE FUNCTION Zeros_29_Int32(s, datatype) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: s(:) - INTEGER(INT32), INTENT(IN) :: datatype - INTEGER(INT32) :: ans(s(1), s(2)) - END FUNCTION Zeros_29_Int32 - - MODULE PURE FUNCTION Zeros_29_Int64(s, datatype) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: s(:) - INTEGER(INT64), INTENT(IN) :: datatype - INTEGER(INT64) :: ans(s(1), s(2)) - END FUNCTION Zeros_29_Int64 - - MODULE PURE FUNCTION Zeros_29_Real32(s, datatype) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: s(:) - REAL(REAL32), INTENT(IN) :: datatype - REAL(REAL32) :: ans(s(1), s(2)) - END FUNCTION Zeros_29_Real32 - - MODULE PURE FUNCTION Zeros_29_Real64(s, datatype) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: s(:) - REAL(REAL64), INTENT(IN) :: datatype - REAL(REAL64) :: ans(s(1), s(2)) - END FUNCTION Zeros_29_Real64 -END INTERFACE Zeros - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ZerosUtility diff --git a/src/modules/Utility/src/refs/mathPlantFEM.inc b/src/modules/Utility/src/refs/mathPlantFEM.inc deleted file mode 100644 index 03082a63f..000000000 --- a/src/modules/Utility/src/refs/mathPlantFEM.inc +++ /dev/null @@ -1,2713 +0,0 @@ -module MathClass - use, intrinsic :: iso_fortran_env - !use OouraFFT - use StringClass - implicit none - - - integer(int32) :: i_i = 0 - integer(int32) :: j_j = 0 - integer(int32) :: k_k = 0 - - logical :: true = .True. - logical :: False = .False. - !integer(int32) :: i_i = 0 - - type :: Math_ - real(real64) :: PI = 3.141592653589793d0 - real(real64) :: E = 2.718281828459045d0 - complex(kind(0d0)) :: i = (0.0d0, 1.0d0) - complex(kind(0d0)) :: j = (0.0d0, 1.0d0) - end type - - - type :: Real64Ptr_ - real(real64), pointer :: ptr - end type Real64Ptr_ - - integer(int32),parameter :: complex64 = real64 - !real(real64) :: pi=3.141592653589793238d0 - ! - interface nchoosek - module procedure comb - end interface - - interface choose - module procedure comb - end interface - - interface fact - module procedure factorialInt32, factorialReal64 - end interface - - interface imag - module procedure imaginary_partComplex64, imaginary_partComplex32 - end interface - - interface factorial - module procedure factorialInt32, factorialReal64 - end interface factorial - - interface heapsort - module procedure :: heapsortInt32, heapsortReal64,heapsortReal32 - end interface - - interface str - module procedure fstring_Int, fstring_Real,fstring_Real32, & - fstring_complex, fstring_Int_len, fstring_Real_len, fstring_logical, fstring_String,stringFromChar - end interface str - - interface fstring - module procedure fstring_Int, fstring_Real, fstring_Int_len, fstring_Real_len, fstring_logical - end interface fstring - - interface input - module procedure input_Int,input_Real,input_Real32,input_Complex,input_IntVec,& - input_RealVec,input_IntArray,input_RealArray,input_String,input_logical - end interface input - - interface zeroif - module procedure zeroif_Int,zeroif_Real - end interface zeroif - - interface removeWord - module procedure removeWord_String - end interface - - interface radian - module procedure radianreal32,radianreal64, radianint - end interface - - interface array - module procedure arrayDim1Real64,arrayDim2Real64,arrayDim3Real64 - end interface - - interface RickerFunction - module procedure RickerFunctionReal64 - end interface - - interface derivative - module procedure derivative_scalar,derivative_vector - end interface - - interface der - module procedure derivative_scalar,derivative_vector - end interface - - interface d_dx - module procedure derivative_scalar,derivative_vector - end interface -contains - -! ############################################### -function FFT(x,T) result(hatx) - complex(kind(0d0)) ,intent(in) :: x(:) - complex(kind(0d0)) ,allocatable :: hatx(:) - type(Math_) :: Math - real(real64),optional,intent(in) :: T(2) ! range - real(real64) :: Trange(1:2),dt - integer(int32) :: N - - - N = size(x) - if(present(T) )then - dt = abs(T(2) - T(1) )/dble(N) - else - dt = 1.0d0 - endif - - hatx = FFT_core(x) - - hatx = dt*hatx - -end function - -! ############################################### - -! ############################################### -recursive function FFT_core(x) result(hatx) - complex(kind(0d0)) ,intent(in) :: x(:) - !real(real64) ,optional,intent(in) :: T(2) ! range - complex(kind(0d0)) ,allocatable :: hatx(:),W(:),L(:),R(:) - real(real64),allocatable :: a(:), wo(:) - !real(real64) :: Trange(2) ,dt - integer(int32),allocatable :: ip(:) - integer(int32) :: N, i, itr,isgn - integer(int32),allocatable :: k(:) - type(Math_) :: Math - - ! This FFT is - ! Fw(m dw) = T/N \sum_{n=0}^{N-1} f(n dt) e^{-i 2 \pi k/N m n} - - N = size(x) - allocate(hatx(N)) - - - hatx(:) = 0.0d0 - allocate(k(N/2) ) - allocate(W(N/2) ) - allocate(L(N/2) ) - allocate(R(N/2) ) - - do i=1,size(k) - k(i) = i-1 - !print *, exp(-1*Math%i * 2.0d0* Math%PI * k(i)/dble(N)) - W(i) = exp(-1*Math%i * 2.0d0* Math%PI * k(i) /dble(N) ) - enddo - - if(N==2)then - ! butterfly operation - hatx(1) = x(1) + x(2) - hatx(2) = x(1) - x(2) - return - endif - - if(N>=4)then - itr=0 - do i=1, N, 2 - itr=itr+1 - - if(itr > size(L) )then - exit - endif - L(itr) = x(i) - enddo - - itr=0 - do i=2, N, 2 - itr=itr+1 - if(itr > size(R) )then - exit - endif - R(itr) = x(i) - enddo - - L = FFT_core(L) - R = FFT_core(R) - - do i=1,N/2 - hatx(i) = L(i) + W(i)*R(i) - enddo - do i=N/2+1, N - if(i-N/2 > size(L) )then - exit - endif - hatx(i) = L(i-N/2) - W(i-N/2)*R(i-N/2) - enddo - return - endif -end function -! ############################################### -function IFFT(x,T) result(hatx) - complex(kind(0d0)) ,intent(in) :: x(:) - complex(kind(0d0)) ,allocatable :: hatx(:) - type(Math_) :: Math - real(real64) ,optional,intent(in) :: T(2) ! range - real(real64) :: Trange(2) ,TT - integer(int32) :: N - - ! This IFFT is - ! ft(n dt) = 1/T \sum_{n=0}^{N-1} Fw(m dw) e^{i 2 \pi k/N m n} - - N = size(x) - if(present(T) )then - TT = abs(T(2) - T(1) ) - else - TT = dble(N) - endif - - hatx = IFFT_core(x) - - hatx = 1.0d0/TT*hatx - -end function - -! ############################################### -recursive function IFFT_core(x) result(hatx) - complex(kind(0d0)) ,intent(in) :: x(:) - complex(kind(0d0)) ,allocatable :: hatx(:),W(:),L(:),R(:) - real(real64),allocatable :: a(:), wo(:) - integer(int32),allocatable :: ip(:) - integer(int32) :: N, i, itr,isgn - integer(int32),allocatable :: k(:) - type(Math_) :: Math - - !!! call Ooura-FFT - !n = size(x)/2 - !allocate(a(0:2*n-1) ) - !allocate(wo(0:2*n-1) ) - !a(0:2*n-1) = x(1:2*n) - !isgn = n - !call cdft(2*n,isgn,a(0:2*n-1),ip,wo(0:n/2-1) ) - !hatx = a - ! - !return - !!! - N = size(x) - - allocate(hatx(N)) - - hatx(:) = 0.0d0 - allocate(k(N/2) ) - allocate(W(N/2) ) - allocate(L(N/2) ) - allocate(R(N/2) ) - - do i=1,size(k) - k(i) = i-1 - !print *, exp(-1*Math%i * 2.0d0* Math%PI * k(i)/dble(N)) - W(i) = exp(Math%i * 2.0d0* Math%PI * k(i) /dble(N) ) - enddo - - if(N==2)then - ! butterfly operation - hatx(1) = x(1) + x(2) - hatx(2) = x(1) - x(2) - return - endif - - if(N>=4)then - itr=0 - do i=1, N, 2 - itr=itr+1 - - if(itr > size(L) )then - exit - endif - L(itr) = x(i) - enddo - - itr=0 - do i=2, N, 2 - itr=itr+1 - if(itr > size(R) )then - exit - endif - R(itr) = x(i) - enddo - - L = IFFT_core(L) - R = IFFT_core(R) - - do i=1,N/2 - hatx(i) = L(i) + W(i)*R(i) - enddo - do i=N/2+1, N - if(i-N/2 > size(L) )then - exit - endif - hatx(i) = L(i-N/2) - W(i-N/2)*R(i-N/2) - enddo - return - endif - - -end function -! ############################################### - -! ############################################### -function arrayDim1Real64(size1) result(ret) - integer(int32),intent(in) :: size1 - real(real64),allocatable :: ret(:) - - allocate(ret(size1) ) - - ret(:) = 0.0d0 - -end function -! ############################################### - - -! ############################################### -function arrayDim2Real64(size1,size2) result(ret) - integer(int32),intent(in) :: size1,size2 - real(real64),allocatable :: ret(:,:) - - allocate(ret(size1,size2) ) - - ret(:,:) = 0.0d0 - - -end function -! ############################################### - - -! ############################################### -function arrayDim3Real64(size1,size2,size3) result(ret) - integer(int32),intent(in) :: size1,size2,size3 - real(real64),allocatable :: ret(:,:,:) - - allocate(ret(size1,size2,size3) ) - - ret(:,:,:) = 0.0d0 - - -end function -! ############################################### - -! ############################################### -function radianreal32(deg) result(ret) - real(real32),intent(in) :: deg - real(real64) :: ret - ret = deg/180.0d0*3.1415926535d0 -end function -! ############################################### - -! ############################################### -function radianreal64(deg) result(ret) - real(real64),intent(in) :: deg - real(real64) :: ret - ret = deg/180.0d0*3.1415926535d0 -end function -! ############################################### - -! ############################################### -function radianint(deg) result(ret) - integer(int32),intent(in) :: deg - real(real64) :: ret - ret = dble(deg)/180.0d0*3.1415926535d0 -end function -! ############################################### - -! ############################################### -function degrees(rad) result(ret) - real(real64),intent(in) :: rad - real(real64) :: ret - ret = rad/3.1415926535d0*180.0d0 -end function -! ############################################### - - -!######################################## -function norm(vec) result(a) - real(real64),intent(in)::vec(:) - integer(int32) :: n - real(real64) :: a - - n=size(vec) - a=dsqrt(dot_product(vec,vec) ) - -end function -!######################################## - - - - - -!######################################## -pure function SearchNearestValueID(Vector,x) result(id) - real(real64),intent(in) :: Vector(:) - real(real64),intent(in) :: x - integer(int32) :: id,i - - id = 1 - do i=1,size(vector) - if( abs(vector(id)-x) > abs(vector(i)-x) )then - id = i - cycle - endif - enddo - -end function -!######################################## - - -!######################################## -function SearchNearestValueIDs(Vector,x,num) result(id) - real(real64),intent(in) :: Vector(:) - real(real64),intent(in) :: x - integer(int32),intent(in) :: num - integer(int32) :: id(num),i,j - - id(:) = 1 - do j=1,num - do i=1,size(vector) - if(j>=2 )then - if(abs(minval(id(1:j-1) - i ))==0) cycle - endif - if( abs(vector(id(j) )-x) > abs(vector(i)-x) )then - id(j) = i - cycle - endif - enddo - enddo -end function -!######################################## - -!######################################## -function SearchNearestValue(Vector,x) result(val) - real(real64),intent(in) :: Vector(:) - real(real64),intent(in) :: x - integer(int32) :: id, i - real(real64) :: val - - id = 1 - do i=1,size(vector) - if( abs(vector(id)-x) > abs(vector(i)-x) )then - id = i - cycle - endif - enddo - - val = vector(id) -end function -!######################################## - - -!######################################## -function SearchNearestCoord(Array,x) result(id) - real(real64),intent(in) :: Array(:,:) - real(real64),intent(in) :: x(:) - integer(int32),allocatable::xr(:) - - integer(int32) :: i,id,n,m,norm,tr_norm - - n=size(Array,1) - m=size(Array,2) - if(m/=size(x) )then - stop "ERROR :: SearchNearestCoord >> size(Array,2) should be =size(x)" - endif - - allocate(xr(m) ) - do i=1,n - xr(:)=Array(i,:) - tr_norm=dot_product(xr-x,xr-x) - if(i==1)then - norm=tr_norm - id =i - else - if(norm > tr_norm)then - norm=tr_norm - id =i - else - cycle - endif - endif - enddo - - - -end function -!######################################## - -!################################################## -function SearchIDIntVec(Vec,val) result(id_) - integer(int32),intent(in) :: Vec(:) - integer(int32),intent(in) :: val - - integer(int32) :: i,id_ - - do i=1,size(Vec) - if(Vec(i)==val )then - id_=i - return - endif - enddo - -end function -!################################################## - -!################################################## -subroutine heapsortReal64(n,array,val) - integer(int32),intent(in) :: n - real(real64),intent(inout) :: array(1:n)! rearrange order by this array - real(real64),optional,intent(inout) :: val(1:n) ! linked data - real(real64) :: t_real - integer(int32) ::i,k,j,l - real(real64) :: t - - if(n.le.0)then - write(6,*)"Error, at heapsort"; stop - endif - if(n.eq.1)return - - l=n/2+1 - k=n - do while(k.ne.1) - if(l.gt.1)then - l=l-1 - t=array(L) - if(present(val) )then - t_real=val(L) - endif - else - t=array(k) - if(present(val) )then - t_real=val(k) - endif - - array(k)=array(1) - if(present(val) )then - val(k) = val(1) - endif - - k=k-1 - if(k.eq.1) then - array(1)=t - if(present(val) )then - val(1) = t_real - endif - exit - endif - endif - i=l - j=l+l - do while(j.le.k) - if(j.lt.k)then - if(array(j).lt.array(j+1))j=j+1 - - endif - if (t.lt.array(j))then - array(i)=array(j) - if(present(val) )then - val(i)=val(j) - endif - i=j - j=j+j - else - j=k+1 - endif - enddo - array(i)=t - if(present(val) )then - val(i)=t_real - endif - enddo - -end subroutine heapsortReal64 - -!################################################## -subroutine heapsortReal32(n,array,val) - integer(int32),intent(in) :: n - real(real32),intent(inout) :: array(1:n)! rearrange order by this array - real(real32),optional,intent(inout) :: val(1:n) ! linked data - real(real32) :: t_real - integer(int32) ::i,k,j,l - real(real32) :: t - - if(n.le.0)then - write(6,*)"Error, at heapsort"; stop - endif - if(n.eq.1)return - - l=n/2+1 - k=n - do while(k.ne.1) - if(l.gt.1)then - l=l-1 - t=array(L) - if(present(val) )then - t_real=val(L) - endif - else - t=array(k) - if(present(val) )then - t_real=val(k) - endif - - array(k)=array(1) - if(present(val) )then - val(k) = val(1) - endif - - k=k-1 - if(k.eq.1) then - array(1)=t - if(present(val) )then - val(1) = t_real - endif - exit - endif - endif - i=l - j=l+l - do while(j.le.k) - if(j.lt.k)then - if(array(j).lt.array(j+1))j=j+1 - - endif - if (t.lt.array(j))then - array(i)=array(j) - if(present(val) )then - val(i)=val(j) - endif - i=j - j=j+j - else - j=k+1 - endif - enddo - array(i)=t - if(present(val) )then - val(i)=t_real - endif - enddo - -end subroutine heapsortReal32 - - - -!################################################## -subroutine heapsortInt32(n,array,val) - integer(int32),intent(in) :: n - integer(int32),intent(inout) :: array(1:n)! rearrange order by this array - real(real64),optional,intent(inout) :: val(1:n) ! linked data - real(real64) :: t_real - integer(int32) ::i,k,j,l - integer(int32) :: t - - if(n.le.0)then - write(6,*)"Error, at heapsort"; stop - endif - if(n.eq.1)return - - l=n/2+1 - k=n - do while(k.ne.1) - if(l.gt.1)then - l=l-1 - t=array(L) - if(present(val) )then - t_real=val(L) - endif - else - t=array(k) - if(present(val) )then - t_real=val(k) - endif - - array(k)=array(1) - if(present(val) )then - val(k) = val(1) - endif - - k=k-1 - if(k.eq.1) then - array(1)=t - if(present(val) )then - val(1) = t_real - endif - exit - endif - endif - i=l - j=l+l - do while(j.le.k) - if(j.lt.k)then - if(array(j).lt.array(j+1))j=j+1 - - endif - if (t.lt.array(j))then - array(i)=array(j) - if(present(val) )then - val(i)=val(j) - endif - i=j - j=j+j - else - j=k+1 - endif - enddo - array(i)=t - if(present(val) )then - val(i)=t_real - endif - enddo - -end subroutine heapsortInt32 - -!========================================================== -!calculate cross product -!--------------------------- -pure function cross_product(a,b) result (c) - real(real64), intent(in) :: a(:),b(:) - real(real64), allocatable :: c(:) - - if(size(a) /= 3 .or. size(b)/= 3 ) then - !stop "wrong number on size a, b" - return - endif - - allocate(c(size(a,1))) - if(size(c,1)==3) then - c(1) = a(2)*b(3) - a(3)*b(2) - c(2) = a(3)*b(1) - a(1)*b(3) - c(3) = a(1)*b(2) - a(2)*b(1) - else - !stop "wrong number at cross_product" - return - endif - -end function cross_product -!========================================================= -!calculate diadic -!---------------------- -function diadic(a,b) result(c) - real(real64), intent(in) :: a(:), b(:) - real(real64), allocatable :: c(:,:) - - integer(int32) n,i,j - - allocate(c(size(a),size(b) ) ) - do i=1,size(a) - do j=1,size(b) - c(i,j)=a(i)*b(j) - enddo - enddo - -end function diadic -!========================================================== -!========================================================= -!calculate diadic -!---------------------- -function tensor_product(a,b) result(c) - real(real64), intent(in) :: a(:), b(:) - real(real64), allocatable :: c(:,:) - - integer(int32) n,i,j - - allocate(c(size(a),size(b) ) ) - do i=1,size(a) - do j=1,size(b) - c(i,j)=a(i)*b(j) - enddo - enddo - - end function tensor_product - !========================================================== -!calculate gz -!-------------- -subroutine calcgz(x2,x11,x12,nod_coord,gzi) - real(real64), intent(in) :: nod_coord(:,:) - real(real64),intent(out) :: gzi - integer(int32),intent(in):: x2,x11,x12 - real(real64) l - real(real64),allocatable::avec(:) - - allocate(avec(2)) - l = dot_product( nod_coord(x12,1:2) - nod_coord(x11,1:2), & - nod_coord(x12,1:2) - nod_coord(x11,1:2) ) - l=l**(1.0d0/2.0d0) - - avec(1:2) = ( nod_coord(x12,1:2) - nod_coord(x11,1:2) )/l - - if(l==0.0d0)then - print *, "calcgz l=0" - gzi=0.0d0 - else - gzi=1.0d0/l*dot_product( nod_coord(x2,1:2) -nod_coord(x11,1:2),avec(1:2) ) - endif - - deallocate(avec) - -end subroutine calcgz -!========================================================== -function arg(comp) result(theta) - complex,intent(in) :: comp - real(real64) :: theta,re,im - real(real64) ::pi=3.141592653589793d0 - - re = dble(real(comp) ) - im = dble(aimag(comp) ) - - if(re>0.0d0 )then - theta = atan(im/re) - elseif(re<0.0d0 .and. im>=0.0d0)then - theta = atan(im/re+pi) - elseif(re<0.0d0 .and. im<0.0d0)then - theta = atan(im/re-pi) - elseif(re==0.0d0 .and. im>0.0d0)then - theta = pi/2.0d0 - elseif(re==0.0d0 .and. im<0.0d0)then - theta = -pi/2.0d0 - else - print *, "arg :: indeterminate" - stop - endif - - -end function -!========================================================== - - -function cubic_equation(a,b,c,d) result(x) - real(real64),intent(in) :: a,b,c,d - real(real64) :: x(3),theta - real(real64) ::Deq,A_,B_,C_,p,q - real(real64) ::pi=3.141592653589793d0 - complex :: comp - !https://qiita.com/yotapoon/items/42b1749b69c264d6f486 - - A_ = b/a - B_ = c/a - C_ = d/a - p = B_ - A_*A_/3.0d0 - q = 2.0d0*A_*A_*A_/27.0d0 - A_*B_/3.0d0 + C_ - Deq = q*q/4.0d0 + p*p*p/27.0d0 - - if(Deq > 0.0d0)then - print *, "D > 0 :: not implemented now." - elseif(Deq==0)then - print *, "D == 0 " - x(1) = -2.0d0*(p/2.0d0)**(3) - x(2) = (p/2.0d0)**(3) - x(3) = (p/2.0d0)**(3) - return - else - print *, "D < 0 " - comp = cmplx(-q/2.0d0, sqrt(-Deq) ) - theta=arg(comp) - x(1) = 2.0d0*sqrt(-p/3.0d0)*cos(theta) - x(2) = 2.0d0*sqrt(-p/3.0d0)*cos( (theta+2.0d0*pi)/3.0d0 ) - x(3) = 2.0d0*sqrt(-p/3.0d0)*cos( (theta+4.0d0*pi)/3.0d0 ) - endif - - -end function - -!========================================================== -subroutine eigen_2d(Amat,eigenvector) - real(real64),intent(in)::Amat(:,:) - real(real64),allocatable,intent(inout)::eigenvector(:,:) - real(real64)::b,c,phy,eigenvalue(2) - integer(int32) i,j - - eigenvalue=array(size(Amat,1) ) - eigenvector=array(size(Amat,1),size(Amat,1)) - - b=-1.0d0*(Amat(1,1)+Amat(2,2)) - c=Amat(1,1)*Amat(2,2)-Amat(1,2)*Amat(1,2) - - if(Amat(1,2)/=Amat(2,1) )then - stop "input matrice is not symmetric" - endif - - do i=1,2 - eigenvalue(i)=(-1.0d0*b+((-1.0d0)**dble(i))*(b*b-4.0d0*c)**(1.0d0/2.0d0))*(0.50d0) - enddo - - do i=1,2 - if(Amat(1,2)==0 )then - cycle - elseif(Amat(1,2)/=0 )then - phy=atan( (eigenvalue(i)-Amat(1,1))/Amat(1,2) ) - - do j=1,2 - eigenvector(i,1:2)=(/cos(phy),sin(phy)/) - enddo - endif - enddo - - do i=1,2 - eigenvector(i,:)=eigenvalue(i)*eigenvector(i,:) - enddo -end subroutine eigen_2d -!========================================================== -function signmm(a) result(b) - real(real64),intent(in)::a - real(real64) b - - if(a>0)then - b=1.0d0 - elseif(a<0)then - b=-1.0d0 - elseif(a==0)then - b=0.0d0 - else - stop "ERROR: Invalid real(real64) in function_signm" - endif - -end function signmm -!========================================================== - -! ################################################################ -! From 数値計算のためのFortran90/95プログラミング入門 単行本（ソフトカバー） – -! This function is not presented with GPL or any licenses. -! this function will be replaced by LAPACK. - -recursive function det_mat(a,n) result(det) - integer(int32), intent(in) :: n - real(real64), intent(in) :: a(n, n) - real(real64) det, b(n-1, n-1) - integer(int32) i - if (n > 1) then - det = 0.0d0 - do i = 1, n - b(1:i-1, 1:n-1) = a(1:i-1, 2:n) - b(i:n-1, 1:n-1) = a(i+1:n, 2:n) - det = det + (-1.0d0) ** (i + 1) & - * a(i, 1) * det_mat(b, n-1) - - enddo - else - det = a(1,1) - endif -end function det_mat -!===================================================================================== - -!========================================================== -recursive function det(a,n) result(det_v) - integer(int32), intent(in) :: n - real(real64), intent(in) :: a(n, n) - real(real64) det_v, b(n-1, n-1) - integer(int32) i - if (n > 1) then - det_v = 0.0d0 - do i = 1, n - b(1:i-1, 1:n-1) = a(1:i-1, 2:n) - b(i:n-1, 1:n-1) = a(i+1:n, 2:n) - det_v = det_v + (-1.0d0) ** (i + 1) & - * a(i, 1) * det(b, n-1) - - enddo - else - det_v = a(1,1) - endif -end function det -!===================================================================================== -subroutine trans_rank_2(A,A_T) - real(real64),intent(in)::A(:,:) - real(real64),allocatable,intent(out)::A_T(:,:) - integer(int32) n,m,i,j - - n=size(A,1) - m=size(A,2) - if(.not. allocated(A_T) )allocate(A_T(m,n)) - - do i=1,n - do j=1, m - A_T(j,i)=A(i,j) - enddo - enddo - - end subroutine trans_rank_2 -!================================================================================== -function trans1(A) result(A_T) - real(real64),intent(in)::A(:) - real(real64),allocatable::A_T(:,:) - integer(int32) n,m,i,j - - n=size(A) - if(.not. allocated(A_T) )allocate(A_T(1,n)) - - do i=1,n - A_T(1,i)=A(i) - enddo - - end function trans1 -!================================================================================== -function trans2(A) result(A_T) - real(real64),intent(in)::A(:,:) - real(real64),allocatable::A_T(:,:) - integer(int32) n,m,i,j - - n=size(A,1) - m=size(A,2) - if(.not. allocated(A_T) )allocate(A_T(m,n)) - - do i=1,n - do j=1, m - A_T(j,i)=A(i,j) - enddo - enddo - - end function trans2 -!================================================================================== -subroutine inverse_rank_2(A,A_inv) - real(real64),intent(in)::A(:,:) - real(real64),allocatable::A_inv(:,:) - real(real64) detA,detA_1 - integer(int32) m,n - - m=size(A,1) - n=size(A,2) - if(.not. allocated(A_inv) )allocate(A_inv(m,n)) - detA=det_mat(A,n) - if(detA==0.0d0) stop "ERROR: inverse, detA=0" - detA_1=1.0d0/detA - if(n==2)then - A_inv(1,1)=detA_1*A(2,2) - A_inv(1,2)=-detA_1*A(1,2) - A_inv(2,1)=-detA_1*A(2,1) - A_inv(2,2)=detA_1*A(1,1) - elseif(n==3)then - A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) - A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3)) - A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2)) - A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3)) - A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1)) - A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3)) - A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) - A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2)) - A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1)) - else - print *, "ERROR: Aij with i=j=",n,"/=2or3" - endif - - end subroutine inverse_rank_2 -!================================================================================== -!================================================================================== -function inverse(A) result(A_inv) - real(real64),intent(in)::A(:,:) - real(real64),allocatable::A_inv(:,:) - real(real64) detA,detA_1 - integer(int32) m,n - - m=size(A,1) - n=size(A,2) - if(.not. allocated(A_inv) )allocate(A_inv(m,n)) - detA=det_mat(A,n) - if(detA==0.0d0) stop "ERROR: inverse, detA=0" - detA_1=1.0d0/detA - if(n==2)then - A_inv(1,1)=detA_1*A(2,2) - A_inv(1,2)=-detA_1*A(1,2) - A_inv(2,1)=-detA_1*A(2,1) - A_inv(2,2)=detA_1*A(1,1) - elseif(n==3)then - A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) - A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3)) - A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2)) - A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3)) - A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1)) - A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3)) - A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) - A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2)) - A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1)) - else - print *, "ERROR: Aij with i=j=",n,"/=2or3" - endif - - end function inverse -!================================================================================== -subroutine tensor_exponential(A,expA,TOL,itr_tol) - real(real64),intent(in)::A(:,:),TOL - real(real64),allocatable,intent(inout)::expA(:,:) - integer(int32), intent(in)::itr_tol - real(real64),allocatable::increA(:,:) - real(real64) increment,NN - integer(int32) i,j,n - - if(.not. allocated(expA) )allocate(expA(size(A,1),size(A,2) )) - allocate(increA(size(A,1),size(A,2) )) - if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix" - - expA(:,:)=0.0d0 - do n=1,size(expA,1) - expA(n,n)=1.0d0 - enddo - NN=1.0d0 - increA(:,:)=expA(:,:) - do n=1,itr_tol - if(n>1)then - NN = NN*(NN+1.0d0) - endif - increA(:,:)=matmul(increA,A) - expA(:,:)= expA(:,:)+1.0d0/NN*increA(:,:) - - increment=0.0d0 - do i=1,size(A,1) - do j=1,size(A,2) - increment=increment+1.0d0/NN*increA(i,j)*increA(i,j) - enddo - enddo - - if(increment<=TOL)then - exit - else - if(n>=itr_tol)then - stop "tensor exponential is not converged" - endif - cycle - endif - enddo - - deallocate(increA) - -end subroutine tensor_exponential -!================================================================================== -function identity_matrix(n) result(mat) - integer(int32),intent(in) :: n ! rank - real(real64) :: mat(n,n) - integer(int32) :: i - mat(:,:)=0.0d0 - do i=1,n - mat(i,i)=1.0d0 - enddo - -end function -!================================================================================== - -!================================================================================== -function zero_matrix(n) result(mat) - integer(int32),intent(in) :: n ! rank - real(real64) :: mat(n,n) - mat(:,:)=0.0d0 - -end function -!================================================================================== -subroutine tensor_expo_der(A,expA_A,TOL,itr_tol) - real(real64),intent(in)::A(:,:),TOL - real(real64),allocatable,intent(inout)::expA_A(:,:,:,:) - integer(int32), intent(in)::itr_tol - real(real64),allocatable::increA_1(:,:),increA_2(:,:),increA_3(:,:,:,:),I_ij(:,:),A_inv(:,:) - real(real64) increment,NN - integer(int32) i,j,k,l,n,m,o - - if(.not. allocated(expA_A) )allocate(expA_A(size(A,1),size(A,1),size(A,1),size(A,1) )) - allocate(I_ij(size(A,1),size(A,1) )) - allocate(increA_1(size(A,1),size(A,1) )) - allocate(increA_2(size(A,1),size(A,1) )) - allocate(increA_3(size(A,1),size(A,1),size(A,1),size(A,1) ) ) - if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix" - - call inverse_rank_2(A,A_inv) - - I_ij(:,:)=0.0d0 - do n=1,size(expA_A,1) - I_ij(n,n)=1.0d0 - enddo - NN=1.0d0 - - do i=1,size(A,1) - do j=1,size(A,1) - do k=1, size(A,1) - do l=1, size(A,1) - expA_A(i,j,k,l)=I_ij(i,k)*I_ij(l,j) - enddo - enddo - enddo - enddo - - increA_1(:,:)=I_ij(:,:) - increA_2(:,:)=I_ij(:,:) - do n=1,itr_tol - if(n>2)then - NN = NN*(NN+1.0d0) - endif - increA_1(:,:)=A_inv(:,:) - increA_2(:,:)=matmul(increA_2,A) - - increA_3(:,:,:,:)=0.0d0 - do m=1,n - increA_1(:,:)=matmul(increA_1,A ) - - increA_2(:,:)=matmul(increA_2,A_inv) - - do i=1,size(A,1) - do j=1,size(A,1) - do k=1, size(A,1) - do l=1, size(A,1) - increA_3(i,j,k,l)=increA_3(i,j,k,l)+increA_1(i,k)*increA_2(l,j) - expA_A(i,j,k,l)=expA_A(i,j,k,l)+1.0d0/NN*increA_3(i,j,k,l) - enddo - enddo - enddo - enddo - enddo - - do i=1,size(A,1) - do j=1,size(A,1) - do k=1, size(A,1) - do l=1, size(A,1) - increment=increment+1.0d0/NN*increA_3(i,j,k,l)& - *increA_3(i,j,k,l)& - *increA_3(i,j,k,l)& - *increA_3(i,j,k,l) - enddo - enddo - enddo - enddo - - if(increment<=TOL)then - exit - else - if(n>=itr_tol)then - stop "tensor exponential is not converged" - endif - cycle - endif - enddo - - deallocate(increA_1,increA_2,increA_3,I_ij,A_inv) - -end subroutine tensor_expo_der -!================================================================================== - -function GetNormRe(a) result(b) - real(real64),intent(in)::a(:) - real(real64) :: b - b=dot_product(a,a) -end function -!================================================================================== - -function GetNormMatRe(a) result(b) - real(real64),intent(in)::a(:,:) - real(real64) :: b - integer(int32) :: i,j - b=0 - do i=1,size(a,1) - do j=1,size(a,2) - b=b+a(i,j)*a(i,j) - enddo - enddo -end function -!================================================================================== - -function trace(a) result(b) - real(real64),intent(in)::a(:,:) - real(real64) :: b - integer(int32) :: i,j - b=0 - do i=1,size(a,1) - b=b+a(i,i) - enddo -end function - -!================================================================================== -function sym(a,n) result(ret) - real(real64),intent(in) :: a(:,:) - real(real64) :: ret(n,n) - integer(int32) :: i,n - - ret = 0.50d0*(a) + 0.50d0*transpose(a) - -end function -!================================================================================== - -!================================================================================== -function asym(a,n) result(ret) - real(real64),intent(in) :: a(:,:) - real(real64) :: ret(n,n) - integer(int32) :: i,n - - ret = 0.50d0*(a) - 0.50d0*transpose(a) - -end function -!================================================================================== - -function pi_value(n) result(res) - integer(int32),intent(in)::n - real(real64) :: ptr - real(real64) :: an,bn,tn,pn - real(real64) :: atr,btr,ttr - real(real64) :: res - - integer(int32) :: i - - an=1.0d0 - bn=1.0d0/sqrt(2.0d0) - tn=0.250d0 - pn=1.00d0 - do i=1,n - atr=0.50d0*(an+bn) - btr=dsqrt(an*bn) - ttr=tn-pn*(atr-an)*(atr-an) - ptr=2.0d0*pn - - an=atr - bn=btr - tn=ttr - pn=ptr - - res=(atr+btr)*(atr+btr)/4.0d0/ttr - enddo - -end function -!================================================================================== - - - - -!================================================================================== -function fstring_int(x) result(a) - integer(int32),intent(in) :: x - character(len=20):: b - character(len=:),allocatable :: a - - write(b,*) x - a = trim(adjustl(b)) - -end function -!================================================================================== - -!================================================================================== -function fstring_logical(x) result(a) - logical,intent(in) :: x - character(len=5) :: a - - write(a,*) x - -end function -!================================================================================== - - - -!================================================================================== -function fstring_String(x) result(a) - type(String_),intent(in) :: x - character(len=:),allocatable :: a - - a = trim(x%all) -end function -!================================================================================== - - - -!================================================================================== -function fstring_int_len(x,length) result(a) - integer(int32),intent(in) :: x - integer(int32),intent(in) :: length - character(len=length) :: a - - if(x/=x .or. abs(x) >= HUGE(int32) )then - a="" - return - endif - - write(a,*) x - a = adjustl(a) -end function -!================================================================================== - - - -!================================================================================== -function fstring_real(x) result(a) - real(real64),intent(in) :: x - character(len=20):: b - character(len=:),allocatable :: a - - if(x/=x .or. abs(x) >= HUGE(real64) )then - a="" - return - endif - - write(b,'(f0.8)') x - a = trim(adjustl(b)) - - - -end function -!================================================================================== - -!================================================================================== -function fstring_real32(x) result(a) - real(real32),intent(in) :: x - character(len=20):: b - character(len=:),allocatable :: a - - if(x/=x .or. abs(x) >= HUGE(real64) )then - a="" - return - endif - - write(b,'(f0.8)') x - a = trim(adjustl(b)) - - - -end function -!================================================================================== - -!================================================================================== -function fstring_complex(x) result(a) - complex(kind(0d0) ),intent(in) :: x - character(len=30):: b - character(len=:),allocatable :: a - - if(x/=x .or. abs(x) >= HUGE(real64) )then - a="" - return - endif - - write(b,fmt = '(F0.0,SP,F0.0,"i")') x - a = trim(adjustl(b)) -end function -!================================================================================== - - -!================================================================================== -function fstring_real_len(x,length) result(a) - real(real64),intent(in) :: x - integer(int32),intent(in) :: length - character(len=60) :: a - character*40 :: form - - if(x/=x .or. abs(x) >= HUGE(real64))then - a="" - return - endif - - write(a,'(f0.10)') x - a = adjustl(a) -end function -!================================================================================== - - - -!================================================================================== -function fint(ch) result(a) - character(*),intent(in) :: ch - integer(int32) :: a - - read(ch,*,err=1000) a - return -1000 a = 0 - -end function -!================================================================================== - -!================================================================================== -function fint16(ch) result(a) - character(*),intent(in) :: ch - integer(int16) :: a - - read(ch,*,err=1001) a - return -1001 a = 0 - -end function -!================================================================================== - - - -!================================================================================== -function fint32(ch) result(a) - character(*),intent(in) :: ch - integer(int32) :: a - - read(ch,*,err=1002) a - return -1002 a = 0 - -end function -!================================================================================== - - -!================================================================================== -function fint64(ch) result(a) - character(*),intent(in) :: ch - integer(int64) :: a - - read(ch,*,err=1003) a - return -1003 a = 0 - -end function -!================================================================================== - - - - -!================================================================================== -function freal(ch) result(a) - character(*),intent(in) :: ch - real(real64) :: a - - read(ch,*,err=1004) a - return -1004 a = 0.0d0 - -end function -!================================================================================== - - -!================================================================================== -function freal32(ch) result(a) - character(*),intent(in) :: ch - real(real32) :: a - - read(ch,*,err=1005) a - return -1005 a = 0 - -end function -!================================================================================== - - -!================================================================================== -function freal64(ch) result(a) - character(*),intent(in) :: ch - real(real64) :: a - - read(ch,*,err=1006) a - return -1006 a = 0 - -end function -!================================================================================== - - -!================================================================================== -function freal128(ch) result(a) - character(*),intent(in) :: ch - real(real64) :: a - - read(ch,*,err=1007) a - return -1007 a = 0 - -end function -!================================================================================== - - - - - -!================================================================================== -function input_Int(default,option) result(val) - integer(int32),intent(in) :: default - integer(int32),optional,intent(in)::option - integer(int32) :: val - - if(present(option) )then - val=option - else - val=default - endif - -end function -!================================================================================== - - - - -!================================================================================== -function input_Real(default,option) result(val) - real(real64),intent(in) :: default - real(real64),optional,intent(in)::option - real(real64) :: val - - if(present(option) )then - val=option - else - val=default - endif - -end function -!================================================================================== - - - -!================================================================================== -function input_Real32(default,option) result(val) - real(real32),intent(in) :: default - real(real32),optional,intent(in)::option - real(real32) :: val - - if(present(option) )then - val=option - else - val=default - endif - -end function -!================================================================================== - - -!================================================================================== -function input_Complex(default,option) result(val) - complex(real64),intent(in) :: default - complex(real64),optional,intent(in)::option - complex(real64) :: val - - if(present(option) )then - val=option - else - val=default - endif - -end function -!================================================================================== - - - - -!================================================================================== -function input_IntVec(default,option) result(val) - integer(int32),intent(in) :: default(:) - integer(int32),optional,intent(in)::option(:) - integer(int32),allocatable :: val(:) - integer(int32) :: n,m - - if(present(option) )then - n=size(option,1) - allocate(val(n) ) - val(:)=option(:) - else - n=size(default,1) - allocate(val(n) ) - val(:)=default(:) - endif - -end function -!================================================================================== - -!================================================================================== -function input_Realvec(default,option) result(val) - real(real64),intent(in) :: default(:) - real(real64),optional,intent(in)::option(:) - real(real64),allocatable :: val(:) - integer(int32) :: n,m - - if(present(option) )then - n=size(option,1) - allocate(val(n) ) - val(:)=option(:) - else - n=size(default,1) - allocate(val(n) ) - val(:)=default(:) - endif - -end function -!================================================================================== - - - - -!================================================================================== -function input_IntArray(default,option) result(val) - integer(int32),intent(in) :: default(:,:) - integer(int32),optional,intent(in)::option(:,:) - integer(int32),allocatable :: val(:,:) - integer(int32) :: n,m - - if(present(option) )then - n=size(option,1) - m=size(option,2) - allocate(val(n,m) ) - val(:,:)=option(:,:) - else - n=size(default,1) - m=size(default,2) - allocate(val(n,m) ) - val(:,:)=default(:,:) - endif - -end function -!================================================================================== - -!================================================================================== -function input_RealArray(default,option) result(val) - real(real64),intent(in) :: default(:,:) - real(real64),optional,intent(in)::option(:,:) - real(real64),allocatable :: val(:,:) - integer(int32) :: n,m - - if(present(option) )then - n=size(option,1) - m=size(option,2) - allocate(val(n,m) ) - val(:,:)=option(:,:) - else - n=size(default,1) - m=size(default,2) - allocate(val(n,m) ) - val(:,:)=default(:,:) - endif - -end function -!================================================================================== - - -!================================================================================== -function input_String(default,option) result(val) - character(*),intent(in) :: default - character(*),optional,intent(in)::option - character(200 ) :: val - - if(present(option) )then - val=option - else - val=default - endif - -end function -!================================================================================== - -!================================================================================== -function input_logical(default,option) result(val) - logical,intent(in) :: default - logical,optional,intent(in)::option - logical :: val - - if(present(option) )then - val=option - else - val=default - endif - -end function -!================================================================================== - -function zeroif_Int(val,negative,positive) result(retval) - integer(int32),intent(in)::val - integer(int32) :: retval - logical,optional,intent(in) :: negative,positive - - if(val/=val)then - print *, "ERROR :: MAthClass >> zeroif_Int is invalid" - endif - retval=val - if(present(negative) )then - if(negative .eqv. .true.)then - if(val<0)then - retval=0 - endif - endif - endif - - if(present(positive) )then - if(positive .eqv. .true.)then - if(val>0)then - retval=0 - endif - endif - endif - -end function - - -function zeroif_Real(val,negative,positive) result(retval) - real(real64),intent(in)::val - real(real64) :: retval - logical,optional,intent(in) :: negative,positive - - if(val/=val)then - print *, "ERROR :: MAthClass >> zeroif_Int is invalid" - endif - retval=val - if(present(negative) )then - if(negative .eqv. .true.)then - if(val<0.0d0)then - retval=0.0d0 - endif - endif - endif - - if(present(positive) )then - if(positive .eqv. .true.)then - if(val>0.0d0)then - retval=0.0d0 - endif - endif - endif - -end function - -! ######################################################## -subroutine removeWord_String(str,keyword,itr,Compare) - character(*),intent(inout)::str - character(*),intent(in )::keyword - - integer(int32) :: len_total,len_kw,i,j,n,itr_max - integer(int32),optional,intent(in)::itr - logical,optional,intent(in)::Compare - logical :: bk - - - if(present(Compare))then - if(Compare .eqv. .true.)then - print *, "Before :: ",str - endif - endif - - itr_max=input(default=1,option=itr) - bk=.false. - len_total=len(str) - len_kw =len(keyword) - - do i=1,itr_max - n=index(str,keyword) - do j=n,n+len_kw - str(j:j)=" " - enddo - if(n==0)then - exit - endif - enddo - - if(present(Compare))then - if(Compare .eqv. .true.)then - print *, "After :: ",str - endif - endif - - - -end subroutine -! ######################################################## - - -! ######################################################## -function Invariant_I1(sigma) result(I1) - real(real64),intent(in) :: sigma(:,:) - real(real64) :: I1 - integer(int32) :: i,j - - I1=0.0d0 - do i=1,size(sigma,1) - I1=I1+sigma(i,i) - enddo - -end function -! ######################################################## - - -! ######################################################## -function Invariant_J2(sigma) result(J2) - real(real64),intent(in) :: sigma(:,:) - real(real64) :: I1,J2,delta(3,3),M_d(3,3) - integer(int32) :: i,j - - delta(:,:)=0.0d0 - delta(1,1)=1.0d0 - delta(2,2)=1.0d0 - delta(3,3)=1.0d0 - - I1=Invariant_I1(sigma) - M_d(:,:)=sigma(:,:)-I1/3.0d0*delta(:,:) - J2=0.0d0 - do i=1,size(sigma,1) - do j=1,size(sigma,1) - J2=J2+0.50d0*M_d(i,j)*M_d(i,j) - enddo - enddo - -end function -! ######################################################## - - -! ######################################################## -function Invariant_J3(sigma) result(J3) - real(real64),intent(in) :: sigma(:,:) - real(real64) :: I1,J3,delta(3,3),M_d(3,3) - integer(int32) :: i,j,k - - delta(:,:)=0.0d0 - delta(1,1)=1.0d0 - delta(2,2)=1.0d0 - delta(3,3)=1.0d0 - - I1=Invariant_I1(sigma) - M_d(:,:)=sigma(:,:)-I1/3.0d0*delta(:,:) - J3=0.0d0 - - do i=1,size(sigma,1) - do j=1,size(sigma,1) - do k=1,size(sigma,1) - J3=J3+1.0d0/3.0d0*M_d(i,j)*M_d(j,k)*M_d(k,i) - enddo - enddo - enddo - -end function -! ######################################################## - -! ######################################################## -function Invariant_theta(sigma) result(theta) - real(real64),intent(in) :: sigma(:,:) - real(real64) :: I1,J2,J3,delta(3,3),M_d(3,3),theta - integer(int32) :: i,j,k - - delta(:,:)=0.0d0 - delta(1,1)=1.0d0 - delta(2,2)=1.0d0 - delta(3,3)=1.0d0 - J2=Invariant_J2(sigma) - J3=Invariant_J3(sigma) - theta=1.0d0/3.0d0*asin(-3.0d0*sqrt(3.0d0)*0.50d0*J3/J2/sqrt(J2) ) - -end function -! ######################################################## - -! ######################################################## -function inv_mod(a_in,m_in,ItrMax) result(x) - integer(int32),intent(in) :: a_in,m_in - integer(int32),optional,intent(in) :: ItrMax - integer(int32) :: d, q,t, Kmat_n(2,2),Kmat_npp(2,2),k,itr_tol,r0,r1,r2,i,x,y,m0 - integer(int32) :: a,m - - a=a_in - m=m_in - - itr_tol=input(default=10000,option=ItrMax) - ! inverse modula by Extended Euclidean algorithm - ! d = e^-1 (mod (lambda)) - ! d*e = 1 (mod (lambda)) - ! one integer q - ! d*e - q*lambda = 1, e, lambda are known, d, q are unknown. - ! get d, q by extended Euclidean algorithm - ! gcd(e, lambda) = 1 - !Kmat_npp(1,1)=1 - !Kmat_npp(1,2)=0 - !Kmat_npp(2,1)=0 - !Kmat_npp(2,2)=1 - !r0=e - !r1=lambda - !do i=1, itr_tol - ! r2=mod(r0,r1) - ! if(r2==0)then - ! print *, "gcd of ",e," and",lambda,"is", r1 - ! exit - ! endif - ! k=(r0-r2)/r1 - ! Kmat_n(1,1)=0 - ! Kmat_n(1,2)=1 - ! Kmat_n(2,1)=1 - ! Kmat_n(2,2)=-k - ! a=matmul(Kmat_npp,Kmat_n) - ! Kmat_npp=a - ! print *, r0,"=",k,"*",r1,"+",r2 - ! r0=r1 - ! r1=r2 - !enddo - !d = Kmat_npp(1,2) - !print *, "Kmat_npp=",Kmat_npp - ! cited by https://www.geeksforgeeks.org/multiplicative-inverse-under-modulo-m/ - m0=m - y=0 - x=1 - if(gcd(a,m)/=1 )then - a = mod(a,m) - do x=1,m - if( mod(a*x,m)==1)then - return - endif - enddo - endif - if(m==1)then - return - endif - - do i=1,itr_tol - if(a > 1)then - q=(a -mod(a,m))/m - - t=m - - m= mod(a,m) - a=t - t=y - - y=x - q*y - x=t - else - exit - endif - enddo - if(x < 0)then - x = x+m0 - endif - -end function -! ######################################################## - -! ######################################################## -function gcd(a,b,ItrMax) result(c) - integer(int32),intent(in) :: a,b - integer(int32),optional,intent(in) :: ItrMax - integer(int32) :: i,r0,r1,r2,k,itr_tol,c - c=1 - itr_tol=input(default=10000,option=ItrMax) - r0=a - r1=b - do i=1, itr_tol - r2=mod(r0,r1) - if(r2==0)then - !print *, "gcd of ",a," and",b,"is", r1 - exit - endif - k=(r0-r2)/r1 - !print *, r0,"=",k,"*",r1,"+",r2 - r0=r1 - r1=r2 - enddo - c=r1 - -end function -! ######################################################## - - -! ######################################################## -function lcm(a,b,ItrMax) result(c) - integer(int32),intent(in) :: a,b - integer(int32),optional,intent(in) :: ItrMax - integer(int32) :: i,r0,r1,r2,k,itr_tol,c - - itr_tol=input(default=10000,option=ItrMax) - r0=a - r1=b - do i=1, itr_tol - r2=mod(r0,r1) - if(r2==0)then - !print *, "gcd of ",a," and",b,"is", r1 - exit - endif - k=(r0-r2)/r1 - !print *, r0,"=",k,"*",r1,"+",r2 - r0=r1 - r1=r2 - enddo - c=a*b/r1 - - -end function -! ######################################################## - - -! ######################################################## -function convertStringToInteger(message) result(ret) - character(*),intent(in):: message - character(1) :: x - character(2*len(message) ) :: ret - integer(int32) :: i - ret = "" - !allocate(ret(len(message)*2 ) ) - do i=1,len(message) - x = message(i:i) - select case(x) - case(" ") - cycle - case("a","A") - ret(2*i-1:2*i) = "01" - case("b","B") - ret(2*i-1:2*i) = "02" - case("c","C") - ret(2*i-1:2*i) = "03" - case("d","D") - ret(2*i-1:2*i) = "04" - case("e","E") - ret(2*i-1:2*i) = "05" - case("f","F") - ret(2*i-1:2*i) = "06" - case("g","G") - ret(2*i-1:2*i) = "07" - case("h","H") - ret(2*i-1:2*i) = "08" - case("i","I") - ret(2*i-1:2*i) = "09" - case("j","J") - ret(2*i-1:2*i) = "10" - case("k","K") - ret(2*i-1:2*i) = "11" - case("l","L") - ret(2*i-1:2*i) = "12" - case("m","M") - ret(2*i-1:2*i) = "13" - case("n","N") - ret(2*i-1:2*i) = "14" - case("o","O") - ret(2*i-1:2*i) = "15" - case("p","P") - ret(2*i-1:2*i) = "16" - case("q","Q") - ret(2*i-1:2*i) = "17" - case("r","R") - ret(2*i-1:2*i) = "18" - case("s","S") - ret(2*i-1:2*i) = "19" - case("t","T") - ret(2*i-1:2*i) = "20" - case("u","U") - ret(2*i-1:2*i) = "21" - case("v","V") - ret(2*i-1:2*i) = "22" - case("w","W") - ret(2*i-1:2*i) = "23" - case("x","X") - ret(2*i-1:2*i) = "24" - case("y","Y") - ret(2*i-1:2*i) = "25" - case("z","Z") - ret(2*i-1:2*i) = "26" - end select - enddo - -end function -! ######################################################## - - -! ######################################################## -function convertIntegerToString(message) result(ret) - character(*),intent(in):: message - character(2) :: x - character(len(message) ) :: ret - integer(int32) :: i - ret = "" - !allocate(ret(len(message)*2 ) ) - do i=1,len(message) - x(1:2) = message(2*i-1:2*i) - select case(x) - case("99") - cycle - case(" ") - cycle - case("01") - ret(i:i) = "a" - case("02") - ret(i:i) = "b" - case("03") - ret(i:i) = "c" - case("04") - ret(i:i) = "d" - case("05") - ret(i:i) = "e" - case("06") - ret(i:i) = "f" - case("07") - ret(i:i) = "g" - case("08") - ret(i:i) = "h" - case("09") - ret(i:i) = "i" - case("10") - ret(i:i) = "j" - case("11") - ret(i:i) = "k" - case("12") - ret(i:i) = "l" - case("13") - ret(i:i) = "m" - case("14") - ret(i:i) = "n" - case("15") - ret(i:i) = "o" - case("16") - ret(i:i) = "p" - case("17") - ret(i:i) = "q" - case("18") - ret(i:i) = "r" - case("19") - ret(i:i) = "s" - case("20") - ret(i:i) = "t" - case("21") - ret(i:i) = "u" - case("22") - ret(i:i) = "v" - case("23") - ret(i:i) = "w" - case("24") - ret(i:i) = "x" - case("25") - ret(i:i) = "y" - case("26") - ret(i:i) = "z" - end select - enddo - -end function -! ######################################################## -! ######################################################## -subroutine rsa_keygen(prime1,prime2,seed,id_rsa,id_rsa_pub) - integer(int32),intent(in) :: prime1,prime2,seed - integer(int32),intent(out) :: id_rsa(2),id_rsa_pub(2) - integer(int32) :: n,e,lambda,d,p,q - - p=prime1 - q=prime2 - - n=p*q - lambda=(p-1)*(q-1)/gcd(p-1,q-1) - !print *, "lambda=",lambda - - id_rsa_pub(1)=n - id_rsa_pub(2)=seed - - id_rsa(1)=n - id_rsa(2)=inv_mod(seed, lambda) !get d - - print *, "#######################################################" - print *, "Encrypted by RSA algorithm, public keys " - print *, "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^" - print *, "Multiplication of two prime numbers is ",id_rsa_pub(1) - print *, "Seed value (1 < seed < ",id_rsa_pub(1),") is", id_rsa_pub(2) - print *, "Notice:: message should be (1 < seed < ",id_rsa_pub(1),")." - print *, "#######################################################" - - -end subroutine -! ######################################################## - -! ######################################################## -function rsa_encrypt(id_rsa_pub,message) result(ciphertext) - integer(int32),intent(in) ::id_rsa_pub(2),message - integer(int32) :: ciphertext,i - - ciphertext = 1 - do i=1, id_rsa_pub(2) - ciphertext= mod(ciphertext* message, id_rsa_pub(1) ) - enddo - -end function -! ######################################################## - -! ######################################################## -function rsa_decrypt(id_rsa,ciphertext) result(message) - integer(int32),intent(in) ::id_rsa(2),ciphertext - integer(int32) :: d,n,e,message,i - - - message = 1 - do i=1, id_rsa(2) - message= mod(message* ciphertext, id_rsa(1) ) - enddo - -end function -! ######################################################## - -function IsItNumber(char) result(res) - character(*),intent(inout) :: char - logical :: res - integer :: i - character(1) :: firstchar - - res=.false. - ! search all - firstchar=trim(adjustl(char(1:1))) - - if(firstchar == "1" )then - res=.true. - return - elseif(firstchar == "2" )then - res=.true. - return - elseif(firstchar == "3" )then - res=.true. - return - elseif(firstchar == "4" )then - res=.true. - return - elseif(firstchar == "5" )then - res=.true. - return - elseif(firstchar == "6" )then - res=.true. - return - elseif(firstchar == "7" )then - res=.true. - return - elseif(firstchar == "8" )then - res=.true. - return - elseif(firstchar == "9" )then - res=.true. - return - elseif(firstchar == "0" )then - res=.true. - return - elseif(firstchar == "." )then - res=.true. - return - else - return - endif - - -end function IsItNumber - - -! BitInversion -!recursive function BitInversion(i,numBit) result(ret) -! integer(int32),intent(in) :: i -! integer(int32),intent(in) :: numBit -! -! if(numBit==1)then -! ! 1 Bit 0 or 1 -! -! elseif(numBit==2)then -! elseif(numBit==3)then -! if(numBit > 3) then -! endif -! -!end function - -! Window functions - -function RectangularWindow(Width,DataSize) result(ret) - integer(int32),intent(in) :: Width,DataSize - real(real64) :: ret(DataSize) - - ret = 0.0d0 - ret(DataSize/2-Width/2:DataSize/2+Width/2) = 1 - -end function - -function HanningWindow(Width,DataSize) result(ret) - integer(int32),intent(in) :: Width,DataSize - real(real64) :: ret(DataSize) - type(Math_) :: math - integer(int32) :: i - - print *, "[CAUTION] EXPERIMENTAL!" - - ret = 0.0d0 - do i=1,width/2 - ret(DataSize/2-i) & - = 0.50d0 - 0.50d0*cos(2.0d0*Math%PI*i/(Width/2) ) - ret(DataSize/2+i) & - = 0.50d0 - 0.50d0*cos(2.0d0*Math%PI*i/(Width/2) ) - enddo - -end function - - -function HammingWindow(Width,DataSize) result(ret) - integer(int32),intent(in) :: Width,DataSize - real(real64) :: ret(DataSize) - type(Math_) :: math - integer(int32) :: i - - print *, "[CAUTION] EXPERIMENTAL!" - - - ret = 0.0d0 - do i=1,width/2 - ret(DataSize/2-i) & - = 0.540d0 - 0.46d0*cos(2.0d0*Math%PI*i/(Width/2) ) - ret(DataSize/2+i) & - = 0.540d0 - 0.46d0*cos(2.0d0*Math%PI*i/(Width/2) ) - enddo - -end function -! ####################################################################### -function log2(x) result(ret) - real(real64),intent(in) :: x - real(real64) :: ret - - ret = log(x)/log(2.0d0) - -end function -! ####################################################################### - - -! ####################################################################### -pure function day(unit) result(ret) - character(*),intent(in):: unit - real(real64) :: ret - - if(unit(1:1)=="S" .or. unit(1:1)=="s")then - ! day to second - ret = 24.0d0*60.0d0*60.0d0 - return - endif - - if(unit(1:1)=="M" .or. unit(1:1)=="m")then - ! day to minutes - ret = 24.0d0*60.0d0 - return - endif - - if(unit(1:1)=="H" .or. unit(1:1)=="h")then - ! hour to minutes - ret = 24.0d0 - return - endif - - if(unit(1:1)=="D" .or. unit(1:1)=="d")then - ! day to minutes - ret = 1.0d0 - return - endif - - if(unit(1:1)=="Y" .or. unit(1:1)=="y")then - ! day to year - ret = 1.0d0/365.0d0 - return - endif - -end function -! ####################################################################### - -! ####################################################################### -pure recursive function factorialInt32(n) result(ret) - integer(int32),intent(in) :: n - integer(int64) :: i,ret - - ret=1 - do i=1,n - ret = ret*i - enddo - -end function -! ####################################################################### - -! ####################################################################### -pure recursive function factorialReal64(n) result(ret) - real(real64),intent(in) :: n - real(real64) :: ret - integeR(int32) :: i - - ret=1.0d0 - do i=1,int(n) - ret = ret*dble(i) - enddo - -end function -! ####################################################################### - -pure function comb(n,r) result(ret) - integer(int32),intent(in) :: n,r - real(real64) :: ret - integer(int32) :: i - real(real64),allocatable :: buf1(:),buf2(:),buf3(:) - - if(n-r<0)then - ret = 0.0d0 - return - endif - - if(n<=10)then - ret = factorial(n)/(factorial(r)*factorial(n-r)) - else - allocate(buf1(n),buf2(n),buf3(n)) - do concurrent (i=1:n) - buf1(i) = i - end do - do concurrent (i=1:r) - buf2(i) = i - end do - do concurrent (i=1:n-r) - buf3(i) = i - end do - - do concurrent (i=1:r) - buf1(i) = buf1(i)/buf2(i) - end do - do concurrent (i=1:n-r) - buf1(i) = buf1(i)/buf3(i) - end do - - ret=1.0d0 - do i=1,n - ret = ret * buf1(i) - enddo - ret =dble(nint(ret)) - - !by array - endif - -end function - -function stringFromChar(charval) result(ret) - character(*),intent(in):: charval - type(String_) :: ret - - ret = charval - -end function -! ####################################################################### - -function zfill(intval, n) result(ret) - integer(int32),intent(in) :: intval,n - character(n) :: ret - character(:),allocatable :: fmt - - fmt = '(I'//str(n)//'.'//str(n)//')' - write(ret(1:n),fmt) intval - -end function - -! ######################################################################## -pure function imaginary_partComplex64(complexValue) result(imgpart) - complex(real64),intent(in) :: complexValue - real(real64) :: imgpart - type(Math_) :: math - - imgpart = real(complexvalue*math%i) - -end function -! ######################################################################## - -! ######################################################################## -pure function imaginary_partComplex32(complexValue) result(imgpart) - complex(real32),intent(in) :: complexValue - real(real32) :: imgpart - type(Math_) :: math - - imgpart = - real(complexvalue*math%i) - -end function -! ######################################################################## - - -function hilbert(wave) result(h_top_wave) - complex(real64),intent(in) :: wave(:) - complex(real64),allocatable :: h_top_wave(:),spectre(:) - - spectre = fft(wave) - spectre(1:size(spectre)/2 ) = 2.0d0*spectre(1:size(spectre)/2 ) - spectre(size(spectre)/2+1: ) = 0.0d0 - h_top_wave = ifft(spectre) - -end function -! ######################################################################## - -function short_time_FFT(wave,frame) result(spectre) - complex(real64),intent(in) :: wave(:) - complex(real64),allocatable :: spectre(:,:) - integer(int32),intent(in) :: frame - integer(int32) :: i,from,to - - ! short-time FFT for n=frame length - allocate(spectre(size(wave),2*frame)) - !$OMP parallel do private(from,to) - do i=1,size(wave) - from = i-frame - to = i+frame-1 - if(from size(wave)-frame )then - cycle - endif - spectre(i,:) = fft(wave(i-frame:i+frame-1)) - enddo - !$OMP end parallel do - -end function -! ######################################################################## - -pure function RickerFunctionReal64(t, sigma, center) result(ft) - real(real64),intent(in) :: t, sigma - real(real64),optional,intent(in) :: center - type(Math_) :: math - real(real64) ::ft128 - real(real64) :: ft, b - - if(present(center) )then - b=center - else - b=0.0d0 - endif - - ft128 = 2.0d0/(sqrt(3.0d0*sigma)*math%pi**(0.25) )*& - (1.0d0-((t-b)/sigma)*((t-b)/sigma) )*exp(-(t-b)*(t-b)/2.0d0/sigma/sigma) - - ft = dble(ft128) - -end function -! ######################################################################## - - -! ######################################################## -real(real64) function derivative_scalar(func,x,eps) - ! >>> Define func() - interface - real(real64) function func(x) - use iso_fortran_env - real(real64),intent(in) :: x - end function - end interface - - ! <<< - - ! >>> arg - real(real64),intent(in) :: x - real(real64),optional,intent(in) :: eps - ! <<< - - real(real64) :: eps_val =dble(1.0e-4) - if(present(eps) )then - eps_val = eps - endif - - ! >>> operation - ! numerical derivative - - derivative_scalar = (func(x+eps_val) - func(x-eps_val) )/(2.0d0*eps_val) - ! <<< - -end function - -! ######################################################## -function derivative_vector(func,x,dim_num,eps) result(ret) - integer(int32),intent(in) :: dim_num - ! >>> Define func() - interface - function func(x) result(ret) - use iso_fortran_env - real(real64),intent(in) :: x(:) - real(real64),allocatable :: ret(:) - end function - end interface - ! <<< - - ! >>> arg - real(real64),intent(in) :: x(1:dim_num) - real(real64),optional,intent(in) :: eps - ! <<< - - ! >>> output - real(real64),allocatable :: ret(:) - ! <<< - - real(real64) :: x_f(1:dim_num) - real(real64) :: x_b(1:dim_num) - real(real64) :: eps_val =dble(1.0e-4) - - if(present(eps) )then - eps_val = eps - endif - - ret = x - x_f = x - x_f(:) = x_f(:) + eps_val - x_b = x - x_b(:) = x_b(:) - eps_val - - ! >>> operation - ! numerical derivative - - ret = (func(x_f) - func(x_b) )/(2.0d0*eps_val) - ! <<< - -end function -! ######################################################## - -real(real64) function polynomial(x,params) - real(real64),intent(in) :: x - real(real64),intent(in) :: params(:) - integer(int32) :: i , n ,order_ - - n = size(params) - ! (n-1)-order polynomial - polynomial = 0.0d0 - order_ = 0 - do i=n-1,0,-1 - order_ = order_ + 1 - polynomial = polynomial + params(order_) * (x**i) - enddo - -end function - -! ########################################################### -real(real64) function sigmoid(x,params) - real(real64),intent(in) :: x,params(:) - - if(size(params)==0 )then - sigmoid = 1.0d0/(1.0d0 + exp(- (x) ) ) - elseif(size(params)==1 )then - sigmoid = 1.0d0/(1.0d0 + exp(- params(1)*(x) ) ) - elseif(size(params)==2 )then - sigmoid = 1.0d0/(1.0d0 + exp(- params(1)*(x-params(2)) ) ) - else - sigmoid = 1.0d0/(1.0d0 + exp(- params(1)*(x-params(2)) ) )*params(3) - endif - -end function -! ########################################################### - -! ########################################################### -real(real64) function logit(x,params) - real(real64),intent(in) :: x,params(:) - - logit = log(x/(1-x) ) - -end function -! ########################################################### - - - -end module MathClass \ No newline at end of file diff --git a/src/modules/Vector3D/CMakeLists.txt b/src/modules/Vector3D/CMakeLists.txt deleted file mode 100644 index 2441dc0d5..000000000 --- a/src/modules/Vector3D/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Vector3D_Method.F90 -) \ No newline at end of file diff --git a/src/modules/Vector3D/src/Vector3D_Method.F90 b/src/modules/Vector3D/src/Vector3D_Method.F90 deleted file mode 100644 index 205cbf461..000000000 --- a/src/modules/Vector3D/src/Vector3D_Method.F90 +++ /dev/null @@ -1,1019 +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: 24 Feb 2021 -! summary: This module contains method for [[Vector3D_]] data type -! -!# Introduction -!This module contains method for [[Vector3D_]] data type. It contains following submodules: -! -! * `Vector3D_Method@Constructor.F90` -! * `Vector3D_Method@Misc.F90` -! - -MODULE Vector3D_Method -USE GlobalData, ONLY: DFP, I4B, LGT, stdout -USE BaseType, ONLY: Vector3D_ -IMPLICIT NONE - -PRIVATE - -!---------------------------------------------------------------------------- -! Shape@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This function returns the shape of [[Vector3D_]] -! -!# Introduction -! This routine returns the shape of [[Vector3D_]] -! -!### Usage -! -!```fortran -! s = SHAPE(obj) -!``` - -INTERFACE - MODULE PURE FUNCTION get_shape(obj) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj - INTEGER(I4B) :: Ans(1) - END FUNCTION get_shape -END INTERFACE - -INTERFACE Shape - MODULE PROCEDURE get_shape -END INTERFACE Shape - -PUBLIC :: Shape - -!---------------------------------------------------------------------------- -! SIZE@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This routine returns the size of [[Vector3D_]] - -INTERFACE - MODULE PURE FUNCTION get_size(obj, Dims) RESULT(Ans) - TYPE(Vector3D_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims - INTEGER(I4B) :: Ans - END FUNCTION get_size -END INTERFACE - -INTERFACE SIZE - MODULE PROCEDURE get_size -END INTERFACE SIZE - -PUBLIC :: SIZE - -!---------------------------------------------------------------------------- -! TotalDimension@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: Returns the total dimension of an array -! -!# Introduction -! -! This function returns the total dimension (or rank) of an array, - -INTERFACE - MODULE PURE FUNCTION Vec3D_getTotalDimension(obj) RESULT(Ans) - TYPE(Vector3D_), INTENT(IN) :: obj - INTEGER(I4B) :: ans - END FUNCTION Vec3D_getTotalDimension -END INTERFACE - -INTERFACE getTotalDimension - MODULE PROCEDURE Vec3D_getTotalDimension -END INTERFACE getTotalDimension - -PUBLIC :: getTotalDimension - -!---------------------------------------------------------------------------- -! setTotalDimension@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This subroutine set the total dimension (rank) of an array -! -!# Introduction -! -! This subroutine sets the rank(total dimension) of an array - -INTERFACE - MODULE PURE SUBROUTINE Vec3D_setTotalDimension(obj, tDimension) - CLASS(Vector3D_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: tDimension - END SUBROUTINE Vec3D_setTotalDimension -END INTERFACE - -INTERFACE setTotalDimension - MODULE PROCEDURE Vec3D_setTotalDimension -END INTERFACE setTotalDimension - -PUBLIC :: setTotalDimension - -!---------------------------------------------------------------------------- -! Allocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This routine allocate the data for [[Vector3D_]] -! -!# Introduction -! This subroutine reset the instance of [[Vector3D_]] to zero -! - -INTERFACE - MODULE PURE SUBROUTINE Allocate_Data(obj, Dims) - CLASS(Vector3D_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Dims - END SUBROUTINE Allocate_Data -END INTERFACE - -INTERFACE ALLOCATE - MODULE PROCEDURE Allocate_Data -END INTERFACE ALLOCATE - -PUBLIC :: ALLOCATE - -!---------------------------------------------------------------------------- -! Deallocate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This subroutine reset the instance of [[Vector3D_]] - -INTERFACE - MODULE PURE SUBROUTINE Deallocate_Data(obj) - CLASS(Vector3D_), INTENT(INOUT) :: obj - END SUBROUTINE Deallocate_Data -END INTERFACE - -INTERFACE DEALLOCATE - MODULE PROCEDURE Deallocate_Data -END INTERFACE DEALLOCATE - -PUBLIC :: DEALLOCATE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This routine initiate the instance of [[Vector3D_]] -! -!# Introduction -! -! This routine initiate the instance of [[Vector3D_]]. If `Val` is 1D or 2D vector then the rest of the components of instance of [[Vector3D_]] will be set to zero. If `SIZE(Val)>=4` then only first 3 components are used to construct the instance. -! -!### Usage -! -!```fortran -!... -! type( Vector3D_ ) :: obj -! call initiate( obj, [1.0_DFP, 2.0_DFP, 3.0_DFP]) -! call display(obj, "test1=") -! ... -!``` - -INTERFACE - MODULE PURE SUBROUTINE initiate_obj_from_val(obj, Val) - CLASS(Vector3D_), INTENT(INOUT) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - END SUBROUTINE initiate_obj_from_val -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This routine initiate the instance of [[Vector3D_]] from another object, basically it is a copy operation -! -!# Introduction -! This routine initiate the instance of [[Vector3D_]] from another object, basically it is a copy operation. -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj, obj2 -! call initiate( obj, [1.0_DFP, 2.0_DFP, 3.0_DFP]) -! call initiate( obj2, obj ) -! call display(obj2, "test2=") -!``` - -INTERFACE - MODULE PURE SUBROUTINE initiate_obj_from_obj(obj, Anotherobj) - CLASS(Vector3D_), INTENT(INOUT) :: obj - CLASS(Vector3D_), INTENT(IN) :: Anotherobj - END SUBROUTINE initiate_obj_from_obj -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: Generic procedure to initiate the instance of [[Vector3D_]] object - -INTERFACE Initiate - MODULE PROCEDURE initiate_obj_from_val, initiate_obj_from_obj -END INTERFACE Initiate - -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! COPY@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: Generic procedure to copy one instance of [[Vector3D_]] into another instance - -INTERFACE COPY - MODULE PROCEDURE initiate_obj_from_obj -END INTERFACE COPY - -PUBLIC :: COPY - -!---------------------------------------------------------------------------- -! Assignment@Constructor -!---------------------------------------------------------------------------- - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE initiate_obj_from_obj, initiate_obj_from_val -END INTERFACE - -PUBLIC :: ASSIGNMENT(=) - -!---------------------------------------------------------------------------- -! Vector3D@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: Function to create an instance of [[vector3d_]] -! -!# Introduction -! -! This function creates an instance of [[vector3d_]] from given fortran vector of real numbers -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj -! obj = Vector3D([1.0_DFP]) -! call display( obj, "test5=") -!``` - -INTERFACE - MODULE PURE FUNCTION Constructor1(Val) RESULT(Ans) - REAL(DFP), INTENT(IN) :: Val(:) - TYPE(Vector3D_) :: Ans - END FUNCTION Constructor1 -END INTERFACE - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: Generic function to create an instance of [[Vector3D_]] - -INTERFACE Vector3D - MODULE PROCEDURE Constructor1 -END INTERFACE Vector3D - -PUBLIC :: Vector3D - -!---------------------------------------------------------------------------- -! Vector3D_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This function returns the pointer to an instance of [[Vector3D_]] -! -!# Introduction -! -! This function returns pointer to an instance of [[Vector3D_]] -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ), pointer :: obj -! obj => Vector3D_Pointer([1.0_DFP]) -! call display(obj, "test6=") -!``` - -INTERFACE - MODULE FUNCTION Constructor_1(Val) RESULT(Ans) - REAL(DFP), INTENT(IN) :: Val(:) - CLASS(Vector3D_), POINTER :: Ans - END FUNCTION Constructor_1 -END INTERFACE - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This function returns the pointer to an instance of [[Vector3D_]] -! -!### Usage -! -!```fortran -! type( Vector3D_ ), pointer :: obj -! obj => Vector3D_Pointer([1.0_DFP]) -! call display(obj, "test6=") -!``` - -INTERFACE - MODULE FUNCTION Constructor_2(obj) RESULT(Ans) - TYPE(Vector3D_), INTENT(IN) :: obj - CLASS(Vector3D_), POINTER :: Ans - END FUNCTION Constructor_2 -END INTERFACE - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This generic function returns pointer to an instance of [[Vector3D_]] - -INTERFACE Vector3D_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2 -END INTERFACE Vector3D_Pointer - -PUBLIC :: Vector3D_Pointer - -!---------------------------------------------------------------------------- -! Display@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This subroutine display [[Vector3D_]] -! -!### Usage -! -!```fortran -! type( Vector3D_ ), pointer :: obj -! obj => Vector3D_Pointer([1.0_DFP]) -! call display(obj, "test6=") -!``` - -INTERFACE - MODULE SUBROUTINE Display_obj(obj, Msg, UnitNo) - CLASS(Vector3D_), INTENT(IN) :: obj - CHARACTER(LEN=*), INTENT(IN) :: Msg - INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo - END SUBROUTINE Display_obj -END INTERFACE - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: Generic routine to display an object - -INTERFACE Display - MODULE PROCEDURE Display_obj -END INTERFACE Display - -PUBLIC :: Display - -!---------------------------------------------------------------------------- -! DOT_PRODUCT@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This funtion computes dot product of two [[Vector3D_]] object -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj1, obj2 -! obj1 = [1.0_dfp, 2.0_dfp, 3.0_dfp] -! obj2 = [1.0_dfp, 0.0_dfp, 3.0_dfp] -! CALL Equalline() -! CALL Display( "test7" ) -! CALL Display( obj1, "obj1 = " ) -! CALL Display( obj2, "obj2 = " ) -! CALL Display( DOT_PRODUCT( obj1, obj2 ), "dot_product = " ) -! CALL Display( obj1 .DOT. obj2, "dot_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION dot_product_1(obj1, obj2) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj1 - CLASS(Vector3D_), INTENT(IN) :: obj2 - REAL(DFP) :: Ans - END FUNCTION dot_product_1 -END INTERFACE - -!---------------------------------------------------------------------------- -! DOT_PRODUCT@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This funtion computes dot product of a [[Vector3D_]] object and fortran vector -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj -! real( dfp ) :: val(3) -! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] -! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] -! CALL Equalline() -! CALL Display( "test8" ) -! CALL Display( obj, "obj1 = " ) -! CALL Display( val, "val = " ) -! CALL Display( DOT_PRODUCT( obj=obj, val=val ), "dot_product = " ) -! CALL Display( obj.DOT. val, "dot_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION dot_product_2(obj, Val) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - REAL(DFP) :: Ans - END FUNCTION dot_product_2 -END INTERFACE - -!---------------------------------------------------------------------------- -! DOT_PRODUCT@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This funtion computes dot product of a [[Vector3D_]] object and fortran vector -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj -! real( dfp ) :: val(3) -! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] -! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] -! CALL Equalline() -! CALL Display( "test8" ) -! CALL Display( obj, "obj1 = " ) -! CALL Display( val, "val = " ) -! CALL Display( DOT_PRODUCT( obj=obj, val=val ), "dot_product = " ) -! CALL Display( obj.DOT. val, "dot_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION dot_product_3(Val, obj) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - REAL(DFP) :: Ans - END FUNCTION dot_product_3 -END INTERFACE - -!---------------------------------------------------------------------------- -! DOT_PRODUCT@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function returns the box product (triple scalar product) of three vector. -! -!# Introduction -! -! Box product or triple scalar product is defined as: -! -! $$\mathbf{u} \cdot (\mathbf{v} \times \mathbf{w})=[\mathbf{u}, \mathbf{v}, \mathbf{w}]$$ -! -! This function computes the box product. -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj1, obj2, obj3 -! obj1 = [1.0_dfp, 0.0_dfp, 0.0_dfp] -! obj2 = [0.0_dfp, 1.0_dfp, 0.0_dfp] -! obj3 = [1.0_dfp, 2.0_dfp, 1.0_dfp] -! CALL Equalline() -! CALL Display( "test12" ) -! CALL Display( DOT_PRODUCT( obj1, obj2, obj3 ), "dot_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION dot_product_4(u, v, w) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: u - CLASS(Vector3D_), INTENT(IN) :: v - CLASS(Vector3D_), INTENT(IN) :: w - REAL(DFP) :: Ans - END FUNCTION dot_product_4 -END INTERFACE - -!---------------------------------------------------------------------------- -! DOT_PRODUCT@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This Generic function computes dot product of [[Vector3D_]] object. - -INTERFACE DOT_PRODUCT - MODULE PROCEDURE dot_product_1, dot_product_2, dot_product_4 -END INTERFACE DOT_PRODUCT - -PUBLIC :: DOT_PRODUCT - -INTERFACE OPERATOR(.DOT.) - MODULE PROCEDURE dot_product_1, dot_product_2, dot_product_3 -END INTERFACE - -PUBLIC :: OPERATOR(.DOT.) - -!---------------------------------------------------------------------------- -! Vector_Product@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This function computes the vector product -! -!# Introduction -! -! Ths function computes the vector product of two [[Vector3D_]] object and returns another [[Vector3D_]] object. -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj1, obj2, obj3 -! obj1 = [1.0_dfp, 2.0_dfp, 3.0_dfp] -! obj2 = [1.0_dfp, 0.0_dfp, 3.0_dfp] -! CALL Equalline() -! CALL Display( "test9" ) -! CALL Display( obj1, "obj1 = " ) -! CALL Display( obj2, "obj2 = " ) -! CALL Display( VECTOR_PRODUCT( obj1, obj2 ), "vector_product = " ) -! CALL Display( obj1 .X. obj2, "vector_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION vector_product_1(obj1, obj2) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj1 - CLASS(Vector3D_), INTENT(IN) :: obj2 - TYPE(Vector3D_) :: Ans - END FUNCTION vector_product_1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Vector_Product@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This function computes the vector product -! -!# Introduction -! -! Ths function computes the vector product of a [[Vector3D_]] object and a fortran vector, and returns another [[Vector3D_]] object. -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj -! real( dfp ) :: val(3) -! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] -! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] -! CALL Equalline() -! CALL Display( "test10" ) -! CALL Display( obj, "obj1 = " ) -! CALL Display( val, "val = " ) -! CALL Display( Vector_PRODUCT( obj=obj, val=val ), "vector_product = " ) -! CALL Display( obj .X. val, "vector_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION vector_product_2(obj, Val) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - TYPE(Vector3D_) :: Ans - END FUNCTION vector_product_2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Vector_Product@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This function computes the vector product -! -!# Introduction -! -! Ths function computes the vector product of a [[Vector3D_]] object and a fortran vector, and returns another [[Vector3D_]] object. -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj -! real( dfp ) :: val(3) -! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] -! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] -! CALL Equalline() -! CALL Display( "test10" ) -! CALL Display( obj, "obj1 = " ) -! CALL Display( val, "val = " ) -! CALL Display( Vector_PRODUCT( obj=obj, val=val ), "vector_product = " ) -! CALL Display( obj .X. val, "vector_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION vector_product_3(Val, obj) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: Val(:) - TYPE(Vector3D_) :: Ans - END FUNCTION vector_product_3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Vector_Product@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function performs vector triple product -! -!# Introduction -! -! This function performs vector triple product, and returns the resultant [[Vector3D_]] object; -! -! $$\mathbf{u} \times (\mathbf{v} \times \mathbf{w}) = (\mathbf{u} \cdot \mathbf{w}) \mathbf{v} - (\mathbf{u} \cdot \mathbf{v}) \mathbf{w}$$ -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj1, obj2, obj3 -! obj1 = [1.0_dfp, 0.0_dfp, 0.0_dfp] -! obj2 = [0.0_dfp, 1.0_dfp, 0.0_dfp] -! obj3 = [1.0_dfp, 2.0_dfp, 1.0_dfp] -! -! CALL Equalline() -! CALL Display( "test11" ) -! CALL Display( Vector_PRODUCT( obj1, obj2, obj3 ), "vector_product = " ) -! CALL Display( obj1 .X. (obj2 .X. obj3), "vector_product = " ) -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION vector_product_4(u, v, w) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: u - CLASS(Vector3D_), INTENT(IN) :: v - CLASS(Vector3D_), INTENT(IN) :: w - TYPE(Vector3D_) :: Ans - END FUNCTION vector_product_4 -END INTERFACE - -!---------------------------------------------------------------------------- -! Vector_Product@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 24 Feb 2021 -! summary: This generic function computes the vector product - -INTERFACE Vector_Product - MODULE PROCEDURE vector_product_1, vector_product_2, vector_product_4 -END INTERFACE Vector_Product - -PUBLIC :: Vector_Product - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: A generic procedure to perform vector product - -INTERFACE OPERATOR(.X.) - MODULE PROCEDURE vector_product_1, vector_product_2, vector_product_3 -END INTERFACE OPERATOR(.X.) - -PUBLIC :: OPERATOR(.X.) - -!---------------------------------------------------------------------------- -! NORM2@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function creates Norm2 of a vector -! -!# Introduction -! This function computes second norm of [[vector3d_]] object. -! -! $$\vert \mathbf(u) \vert = \sqrt{\matbf{u} \cdot \mathbf{v}}$$ -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj -! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] -! CALL Equalline() -! CALL Display( "test13" ) -! CALL Display( NORM2( obj ), "NORM2 = " ) -! CALL Display( .NORM. obj, ".Norm. obj = ") -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION Norm2_obj(obj) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj - REAL(DFP) :: Ans - END FUNCTION Norm2_obj -END INTERFACE - -INTERFACE OPERATOR(.NORM.) - MODULE PROCEDURE Norm2_obj -END INTERFACE OPERATOR(.NORM.) - -PUBLIC :: OPERATOR(.NORM.) - -INTERFACE Norm2 - MODULE PROCEDURE Norm2_obj -END INTERFACE Norm2 - -PUBLIC :: Norm2 - -!---------------------------------------------------------------------------- -! UnitVector@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Returnt the unit vector from a given vector -! -!### Usage -! -!```fortran -! -!``` - -INTERFACE - MODULE PURE FUNCTION get_unitVector(obj) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: obj - TYPE(Vector3D_) :: Ans - END FUNCTION get_unitVector -END INTERFACE - -INTERFACE UnitVector - MODULE PROCEDURE get_unitVector -END INTERFACE UnitVector - -PUBLIC :: UnitVector - -INTERFACE Hat - MODULE PROCEDURE get_unitVector -END INTERFACE Hat - -PUBLIC :: Hat - -INTERFACE OPERATOR(.HAT.) - MODULE PROCEDURE get_unitVector -END INTERFACE OPERATOR(.HAT.) - -PUBLIC :: OPERATOR(.HAT.) - -!---------------------------------------------------------------------------- -! Angle@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This function returns the angle beteen two vectors -! -!# Introduction -! Angle between two vectors $\mathbf{u}$ and $\mathbf{v}$ is given by: -! -! $$\cos \theta = \frac{\mathbf{u} \cdot \mathbf{v}}{\vert \mathbf{u} \vert \cdot \vert \mathbf{v} \vert}$$ -! -! This function computes the angle between the two vectors and returnt the result in radians. -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj1, obj2 -! obj1 = [0.0_dfp, 2.0_dfp, 3.0_dfp] -! obj2 = [1.0_dfp, 0.0_dfp] -! CALL Equalline() -! CALL Display( "test14" ) -! CALL Display( ANGLE( obj1, obj2), "Angle = " ) -! CALL Display( obj1 .ANGLE. obj2, ".Angle. = ") -! CALL Display( DEGREES( obj1 .ANGLE. obj2 ), "In degrees :: ") -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION get_angle(u, v) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: u - CLASS(Vector3D_), INTENT(IN) :: v - REAL(DFP) :: Ans - END FUNCTION get_angle -END INTERFACE - -INTERFACE OPERATOR(.Angle.) - MODULE PROCEDURE get_angle -END INTERFACE OPERATOR(.Angle.) - -PUBLIC :: OPERATOR(.Angle.) - -INTERFACE Angle - MODULE PROCEDURE get_angle -END INTERFACE Angle - -PUBLIC :: Angle - -!---------------------------------------------------------------------------- -! ProjectionVector@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Returns the vector of projection from u onto v -! -!# Introduction -! Projetion of a vector $\mathbf{u}$ on \mathbf{v} is given by -! -! $$\mathbf{p} =\left( \frac{\bf{u}\cdot \bf{v}}{\bf{v} \cdot \bf{v}} \right) \bf{v}$$ -! -! This function computes $\mathbf{p}$. -! -!@note -! `.PARALLEL.` operator is alias of `.ProjectionVector.` -!@endnote -! -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj1, obj2 -! obj1 = [4.0_dfp, 2.0_dfp, 3.0_dfp] -! obj2 = [2.0_dfp, 0.0_dfp] -! CALL Equalline() -! CALL Display( "test15" ) -! CALL Display( ProjectionVector( obj1, obj2), "PROJECTIONVector = " ) -! CALL Display( obj1 .PROJECTIONVector. obj2, ".PROJECTIONVector. = ") -! CALL Display( PROJECTION(obj1, obj2), "PROJECTION = " ) -! CALL Display( obj1 .PROJECTION. obj2, ".PROJECTION. = ") -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION get_projection_vector_obj(u, v) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: u - CLASS(Vector3D_), INTENT(IN) :: v - TYPE(Vector3D_) :: Ans - END FUNCTION get_projection_vector_obj -END INTERFACE - -INTERFACE ProjectionVector - MODULE PROCEDURE get_projection_vector_obj -END INTERFACE ProjectionVector - -PUBLIC :: ProjectionVector - -INTERFACE OPERATOR(.ProjectionVector.) - MODULE PROCEDURE get_projection_vector_obj -END INTERFACE OPERATOR(.ProjectionVector.) - -PUBLIC :: OPERATOR(.ProjectionVector.) - -INTERFACE OPERATOR(.Parallel.) - MODULE PROCEDURE get_projection_vector_obj -END INTERFACE OPERATOR(.Parallel.) - -PUBLIC :: OPERATOR(.Parallel.) - -!---------------------------------------------------------------------------- -! Normal@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Returns the component of u normal to v. -! -!# Introduction -! -! The component of u normal to v is given by: -! -! $$\bf{n} =\bf{u} -(\bf{u} \cdot \hat{\bf{v} } )\hat{\bf{v} }$$ -! -! This subroutine return the component of u normal to v -! -!### Usage -! -!```fortran -! -!``` - -INTERFACE - MODULE PURE FUNCTION getNormal_Vector(u, v) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: u - CLASS(Vector3D_), INTENT(IN) :: v - TYPE(Vector3D_) :: Ans - END FUNCTION getNormal_Vector -END INTERFACE - -INTERFACE OPERATOR(.Normal.) - MODULE PROCEDURE getNormal_Vector -END INTERFACE OPERATOR(.Normal.) - -PUBLIC :: OPERATOR(.Normal.) - -INTERFACE Normal - MODULE PROCEDURE getNormal_Vector -END INTERFACE Normal - -PUBLIC :: Normal - -!---------------------------------------------------------------------------- -! Projection@Misc -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: Returns the projection from u onto v -! -!# Introduction -! Projetion of a vector $\mathbf{u}$ on \mathbf{v} is given by -! -! $$p = \mathbf{u} \cdot \hat{\mathbf{v}}$$ -! -! This function computes $p$ -! -! -!### Usage -! -!```fortran -! type( Vector3D_ ) :: obj1, obj2 -! obj1 = [4.0_dfp, 2.0_dfp, 3.0_dfp] -! obj2 = [2.0_dfp, 0.0_dfp] -! CALL Equalline() -! CALL Display( "test15" ) -! CALL Display( ProjectionVector( obj1, obj2), "PROJECTIONVector = " ) -! CALL Display( obj1 .PROJECTIONVector. obj2, ".PROJECTIONVector. = ") -! CALL Display( PROJECTION(obj1, obj2), "PROJECTION = " ) -! CALL Display( obj1 .PROJECTION. obj2, ".PROJECTION. = ") -! CALL DotLine() -!``` - -INTERFACE - MODULE PURE FUNCTION get_projection_obj(u, v) RESULT(Ans) - CLASS(Vector3D_), INTENT(IN) :: u - CLASS(Vector3D_), INTENT(IN) :: v - REAL(DFP) :: Ans - END FUNCTION get_projection_obj -END INTERFACE - -INTERFACE Projection - MODULE PROCEDURE get_projection_obj -END INTERFACE Projection - -PUBLIC :: Projection - -INTERFACE OPERATOR(.Projection.) - MODULE PROCEDURE get_projection_obj -END INTERFACE OPERATOR(.Projection.) - -PUBLIC :: OPERATOR(.Projection.) - -END MODULE Vector3D_Method diff --git a/src/modules/VoigtRank2Tensor/CMakeLists.txt b/src/modules/VoigtRank2Tensor/CMakeLists.txt deleted file mode 100644 index d2dcd2ce3..000000000 --- a/src/modules/VoigtRank2Tensor/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/VoigtRank2Tensor_Method.F90 -) \ No newline at end of file diff --git a/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 b/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 deleted file mode 100644 index 0f0665c7f..000000000 --- a/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 +++ /dev/null @@ -1,297 +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: 10 March 2021 -! summary: This module contains methods for [[VoigtRank2Tensor_]] - -MODULE VoigtRank2Tensor_Method -USE GlobalData -USE BaseType -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: Initiate [[VoigtRank2Tensor_]] using Vector -! -!# Introduction -! -! Initiate [[VoigtRank2Tensor_]] from a given vector. -! -! -!### Usage -! -!```fortran -! type( VoigtRank2Tensor_ ) :: obj -! real( dfp ) :: vec( 6 ) -! call random_number( vec ) -! call display( vec, "vec:", orient="row" ) -! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) -! call display( obj, "stress type voigt") -! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) -! call display( obj, "stress type voigt") -!``` - -INTERFACE -MODULE PURE SUBROUTINE init_from_vec( obj, Vec, VoigtType ) - CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Vec( 6 ) - INTEGER( I4B ), INTENT( IN ) :: VoigtType -END SUBROUTINE init_from_vec -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: Initiate [[VoigtRank2Tensor_]] from a rank2 matrix -! -! -!### Usage -! -!```fortran -! type( VoigtRank2Tensor_ ) :: obj -! real( dfp ) :: vec( 6 ) -! call random_number( vec ) -! call display( vec, "vec:", orient="row" ) -! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) -! call display( obj, "stress type voigt") -! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) -! call display( obj, "stress type voigt") -!``` - -INTERFACE -MODULE PURE SUBROUTINE init_from_mat( obj, T, VoigtType ) - CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: T( 3, 3 ) - INTEGER( I4B ), INTENT( IN ) :: VoigtType -END SUBROUTINE init_from_mat -END INTERFACE - -INTERFACE Initiate - MODULE PROCEDURE init_from_vec, init_from_mat -END INTERFACE Initiate - -PUBLIC :: Initiate - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: This function returns an instance of [[VoigtRank2Tensor_]]. -! -!### Usage -! -!```fortran -! type( VoigtRank2Tensor_ ) :: obj -! real( dfp ) :: vec( 6 ) -! call random_number( vec ) -! call display( vec, "vec:", orient="row" ) -! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) -! call display( obj, "stress type voigt") -! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) -! call display( obj, "stress type voigt") -!``` -INTERFACE -MODULE PURE FUNCTION constructor1( Vec, VoigtType ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: Vec( : ) - INTEGER( I4B ), INTENT( IN ) :: VoigtType - TYPE( VoigtRank2Tensor_ ) :: Ans -END FUNCTION constructor1 -END INTERFACE - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: This function returns an instance of [[VoigtRank2Tensor_]]. -! -!### Usage -! -!```fortran -! type( VoigtRank2Tensor_ ) :: obj -! real( dfp ) :: vec( 6 ) -! call random_number( vec ) -! call display( vec, "vec:", orient="row" ) -! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) -! call display( obj, "stress type voigt") -! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) -! call display( obj, "stress type voigt") -!``` - -INTERFACE -MODULE PURE FUNCTION constructor2( T, VoigtType ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: T( 3, 3 ) - INTEGER( I4B ), INTENT( IN ) :: VoigtType - TYPE( VoigtRank2Tensor_ ) :: Ans -END FUNCTION constructor2 -END INTERFACE - -INTERFACE VoigtRank2Tensor - MODULE PROCEDURE constructor1, constructor2 -END INTERFACE VoigtRank2Tensor - -PUBLIC :: VoigtRank2Tensor - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: This function returns an instance of [[VoigtRank2Tensor_]]. -! -!### Usage -! -!```fortran -! type( VoigtRank2Tensor_ ) :: obj -! real( dfp ) :: vec( 6 ) -! call random_number( vec ) -! call display( vec, "vec:", orient="row" ) -! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) -! call display( obj, "stress type voigt") -! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) -! call display( obj, "stress type voigt") -!``` - -INTERFACE -MODULE PURE FUNCTION constructor_1( Vec, VoigtType ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: Vec( : ) - INTEGER( I4B ), INTENT( IN ) :: VoigtType - CLASS( VoigtRank2Tensor_ ), POINTER :: Ans -END FUNCTION constructor_1 -END INTERFACE - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor_Pointer@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: This function returns a pointer to an instance of [[VoigtRank2Tensor_]] -! -!### Usage -! -!```fortran -! type( VoigtRank2Tensor_ ) :: obj -! real( dfp ) :: vec( 6 ) -! call random_number( vec ) -! call display( vec, "vec:", orient="row" ) -! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) -! call display( obj, "stress type voigt") -! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) -! call display( obj, "stress type voigt") -!``` - -INTERFACE -MODULE PURE FUNCTION constructor_2( T, VoigtType ) RESULT( Ans ) - REAL( DFP ), INTENT( IN ) :: T( 3, 3 ) - INTEGER( I4B ), INTENT( IN ) :: VoigtType - CLASS( VoigtRank2Tensor_ ), POINTER :: Ans -END FUNCTION constructor_2 -END INTERFACE - -INTERFACE VoigtRank2Tensor_Pointer - MODULE PROCEDURE constructor_1, constructor_2 -END INTERFACE VoigtRank2Tensor_Pointer - -PUBLIC :: VoigtRank2Tensor_Pointer - -!---------------------------------------------------------------------------- -! Assignment@Constructor -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: This subroutine converts [[VoigtRank2Tensor_]] into Mat(3,3) -! -!### Usage -! -!```fortran -! type( VoigtRank2Tensor_ ) :: obj -! real( dfp ) :: T( 3, 3 ), W( 3, 3 ) -! call random_number( T ) -! T = 0.5*(T + transpose(T)) -! call display( T, "T = " ) -! obj = VoigtRank2Tensor(T, VoigtType=StressTypeVoigt) -! call display( obj, "stress type voigt") -! W = obj -! call display( W, "W=obj (stress type): ") -! obj = VoigtRank2Tensor(T, VoigtType=StrainTypeVoigt) -! call display( obj, "strain type voigt") -! W = obj -! call display( W, "W=obj (strain type): ") -!``` - -INTERFACE -MODULE PURE SUBROUTINE mat_eq_obj( T, obj ) - REAL( DFP ), INTENT( INOUT ) :: T( 3, 3 ) - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj -END SUBROUTINE mat_eq_obj -END INTERFACE - -!---------------------------------------------------------------------------- -! Assignment@Constructor -!---------------------------------------------------------------------------- - -INTERFACE -MODULE PURE SUBROUTINE vec_eq_obj( vec, obj ) - REAL( DFP ), INTENT( INOUT ) :: vec( 6 ) - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj -END SUBROUTINE vec_eq_obj -END INTERFACE - -INTERFACE ASSIGNMENT( = ) - MODULE PROCEDURE mat_eq_obj, vec_eq_obj -END INTERFACE ASSIGNMENT( = ) - -PUBLIC :: ASSIGNMENT( = ) - -!---------------------------------------------------------------------------- -! Display@IO -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 March 2021 -! summary: This routine displays the content of [[VoigtRank2Tensor_]] - -INTERFACE -MODULE SUBROUTINE display_obj( obj, Msg, UnitNo ) - CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: Msg - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo -END SUBROUTINE display_obj -END INTERFACE - -INTERFACE Display - MODULE PROCEDURE display_obj -END INTERFACE Display - -PUBLIC :: Display - -END MODULE VoigtRank2Tensor_Method diff --git a/src/modules/easifemBase/CMakeLists.txt b/src/modules/easifemBase/CMakeLists.txt deleted file mode 100644 index eb73eafac..000000000 --- a/src/modules/easifemBase/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/easifemBase.F90 -) \ No newline at end of file diff --git a/src/modules/easifemBase/src/easifemBase.F90 b/src/modules/easifemBase/src/easifemBase.F90 deleted file mode 100644 index 784b31b2e..000000000 --- a/src/modules/easifemBase/src/easifemBase.F90 +++ /dev/null @@ -1,21 +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 easifemBase -USE BaseType -USE BaseMethod -END MODULE easifemBase \ No newline at end of file diff --git a/src/submodules/ARPACK/CMakeLists.txt b/src/submodules/ARPACK/CMakeLists.txt deleted file mode 100644 index f1d2bb96e..000000000 --- a/src/submodules/ARPACK/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ARPACK_SAUPD@Methods.F90 -) \ No newline at end of file diff --git a/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 b/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 deleted file mode 100644 index e995059f5..000000000 --- a/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 +++ /dev/null @@ -1,617 +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(ARPACK_SAUPD) Methods -USE BaseMethod, ONLY: ErrorMsg, Input, F77_SAUPD, F77_SEUPD, Display, & - & SymGetLU, SymLUSolve, Tostring -USE GlobalData, ONLY: stdout, zero - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -MODULE PROCEDURE SAUPD_ErrorMsg -SELECT CASE (INFO) -CASE (1) - ans = "ERROR [from SAUPD]: : Maximum number of iterations reached" -CASE (2) - ans = "ERROR [from SAUPD]: : No longer an informational error. & - & Deprecated starting with release 2 of ARPACK." -CASE (3) - ans = "ERROR [from SAUPD]: : No shifts could be applied during implicit, & - & Arnoldi update, try increasing NCV." -CASE (-1) - ans = "ERROR [from SAUPD]: : N must be positive." -CASE (-2) - ans = "ERROR [from SAUPD]: : NEV must be positive." -CASE (-3) - ans = "ERROR [from SAUPD]: : NCV must be greater than NEV and less & - & than or equal to N." -CASE (-4) - ans = "ERROR [from SAUPD]: : The maximum number of Arnoldi update & - & iterations allowed must be greater than zero." -CASE (-5) - ans = "ERROR [from SAUPD]: : WHICH must be one of 'LM', 'SM', & - & 'LA', 'SA', 'BE'" -CASE (-6) - ans = "ERROR [from SAUPD]: : BMAT must be one of 'I' or 'G'." -CASE (-7) - ans = "ERROR [from SAUPD]: : Length of private work array WORKL & - & is not sufficient." -CASE (-8) - ans = "ERROR [from SAUPD]: : Error return from trid. & - & eigenvalue calculation. Informatinal & - & error from LAPACK routine SSTEQR." -CASE (-9) - ans = "ERROR [from SAUPD]: : Starting vector is zero." -CASE (-10) - ans = "ERROR [from SAUPD]: : IPARAM(7) must be 1" -CASE (-11) - ans = "ERROR [from SAUPD]: : IPARAM(7) = 1 and BMAT = 'G' & - & are incompatible." -CASE (-12) - ans = "ERROR [from SAUPD]: : IPARAM(1) must be equal to 0 or 1." -CASE (-13) - ans = "ERROR [from SAUPD]: : NEV and WHICH = 'BE' are incompatible." -CASE (-9999) - ans = "ERROR [from SAUPD]: : Could not build an Arnoldi factorization. & - & IPARAM(5) returns the size of the current Arnoldi factorization. & - & The user is advised to check that enough workspace and & - & array storage has been allocated." -CASE DEFAULT - ans = "ERROR [from SAUPD]: : Unknown error has occured!" -END SELECT -END PROCEDURE SAUPD_ErrorMsg - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SEUPD_ErrorMsg -SELECT CASE (INFO) -CASE (-1) - ans = "ERROR [from SEUPD]: : N must be positive." -CASE (-2) - ans = "ERROR [from SEUPD]: : NEV must be positive." -CASE (-3) - ans = "ERROR [from SEUPD]: : NCV must be greater than NEV and less & - & than or equal to N." -CASE (-5) - ans = "ERROR [from SEUPD]: : WHICH must be one of 'LM', 'SM', & - & 'LA', 'SA', 'BE'" -CASE (-6) - ans = "ERROR [from SEUPD]: : BMAT must be one of 'I' or 'G'." -CASE (-7) - ans = "ERROR [from SEUPD]: : Length of private work array WORKL & - & is not sufficient." -CASE (-8) - ans = "ERROR [from SEUPD]: : Error return from trid. & - & eigenvalue calculation. Informatinal & - & error from LAPACK routine SSTEQR." -CASE (-9) - ans = "ERROR [from SEUPD]: : Starting vector is zero." -CASE (-10) - ans = "ERROR [from SEUPD]: : IPARAM(7) must be 1" -CASE (-11) - ans = "ERROR [from SEUPD]: : IPARAM(7) = 1 and BMAT = 'G' & - & are incompatible." -CASE (-12) - ans = "ERROR [from SEUPD]: : NEV and WHICH = 'BE' are incompatible." -CASE (-14) - ans = "ERROR [from SEUPD]: : SSAUPD did not find any eigenvalues & - & to sufficient accuracy." -CASE (-15) - ans = "ERROR [from SEUPD]: : HOWMNY must be one of 'A' or 'S' & - & if RVEC = .true." -CASE (-16) - ans = "ERROR [from SEUPD]: : HOWMNY = 'S' not yet implemented" -CASE (-17) - ans = "ERROR [from SEUPD]: : SSEUPD got a different count of the & - & number of converged Ritz values than SSAUPD got. & - & This indicates the user probably made an error in & - & passing data from SSAUPD to SSEUPD or that the data was & - & modified before entering SSEUPD." -CASE DEFAULT - ans = "ERROR [from SEUPD]: : Unknown error has occured!" -END SELECT -END PROCEDURE SEUPD_ErrorMsg - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLargestEigenVal1 -CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal1" -!! -!! Internal variables -!! -INTEGER(I4B), PARAMETER :: nev = 1 -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0 -CHARACTER(1), PARAMETER :: bmat = "I" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, d(nev), sigma -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -!! -!! int scalar -!! -which0 = INPUT(default="LA", option=which) -n = SIZE(mat, 1) -ncv0 = input(default=MIN(20_I4B, n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -!! -!! iparam -!! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 1 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -!! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - !! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - !! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - !! - !! Perform MatVec Mult - !! y = MATMUL(mat, X) - !! x => WORKD(ipntr(1):ipntr(1)+N-1) - !! y => WORKD(ipntr(2):ipntr(2)+N-1) - !! - workd(ipntr(2):ipntr(2)+n-1) = MATMUL(mat, workd(ipntr(1):ipntr(1)+n-1)) - !! - ELSE - EXIT - END IF -END DO -!! -!! we are not getting rvec, therefore ldz=1, -!! othereise ldz = N -!! -CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=d, z=v, ldz=1, sigma=sigma, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) -!! -IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(INFO) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP -ELSE - ans = d(1) -END IF -!! -END PROCEDURE SymLargestEigenVal1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLargestEigenVal2 -CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal2" -!! -!! Internal variables -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0 -CHARACTER(1), PARAMETER :: bmat = "I" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, sigma -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -!! -!! int scalar -!! -which0 = INPUT(default="LA", option=which) -n = SIZE(mat, 1) -ncv0 = input(default=MIN(MAX(20_I4B, 2 * nev + 1), n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -!! -!! iparam -!! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 1 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -!! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - !! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - !! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - !! - !! Perform MatVec Mult - !! y = MATMUL(mat, X) - !! x => WORKD(ipntr(1):ipntr(1)+N-1) - !! y => WORKD(ipntr(2):ipntr(2)+N-1) - !! - workd(ipntr(2):ipntr(2)+n-1) = MATMUL(mat, workd(ipntr(1):ipntr(1)+n-1)) - !! - ELSE - EXIT - END IF -END DO -!! -!! we are not getting rvec, therefore ldz=1, -!! othereise ldz = N -!! -CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=ans, z=v, ldz=1, sigma=sigma, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) -!! -IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(INFO) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP -END IF -!! -END PROCEDURE SymLargestEigenVal2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymSmallestEigenVal1 -CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal1" -!! -!! Internal variables -!! -INTEGER(I4B), PARAMETER :: nev = 1 -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0, ii -CHARACTER(1), PARAMETER :: bmat = "I", uplo = "U" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, d(nev), sigma0 -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -REAL(DFP) :: mat0(SIZE(mat, 1), SIZE(mat, 2)) -INTEGER(I4B) :: ipiv(SIZE(mat, 1)), info1 -!! -!! int scalar -!! -sigma0 = INPUT(default=0.0_DFP, option=sigma) -!! -!! note to get smallest value, we transform the problem to -!! find largest value. -!! -IF (PRESENT(which)) THEN - which0 = "L"//which(2:2) -ELSE - which0 = "LA" -END IF -!! -n = SIZE(mat, 1) -ncv0 = input(default=MIN(20_I4B, n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -!! -!! iparam -!! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 3 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -!! -!! make a copy of mat in mat0 -!! we will then form mat - sigma*I -!! then we will compute LU decomposition -!! -mat0 = mat -DO CONCURRENT(ii=1:n) - mat0(ii, ii) = mat0(ii, ii) - sigma0 -END DO -!! -CALL SymGetLU(A=mat0, IPIV=ipiv, UPLO=uplo, INFO=info1) -!! -IF (info1 .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymSmallestEigenVal1()") - STOP -END IF -!! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - !! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - !! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - !! - !! LU Solve - !! mat0 * y = x - !! x => WORKD(ipntr(1):ipntr(1)+N-1) - !! y => WORKD(ipntr(2):ipntr(2)+N-1) - !! - WORKD(ipntr(2):ipntr(2) + N - 1) = & - & WORKD(ipntr(1):ipntr(1) + N - 1) - !! - CALL SymLUSolve(A=mat0, B=WORKD(ipntr(2):ipntr(2) + N - 1), & - & IPIV=ipiv, UPLO=uplo, INFO=info1) - !! - IF (info1 .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymSmallestEigenVal1()") - STOP - END IF - !! - ELSE - EXIT - END IF -END DO -!! -!! we are not getting rvec, therefore ldz=1, -!! othereise ldz = N -!! -IF (info .EQ. 0) THEN - CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=d, z=v, ldz=1, sigma=sigma0, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) - !! - IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - STOP - ELSE - ans = d(1) - END IF -END IF -!! -END PROCEDURE SymSmallestEigenVal1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymSmallestEigenVal2 -CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal2" -!! -!! Internal variables -!! -INTEGER(I4B), PARAMETER :: nev = 1 -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0, ii -CHARACTER(1), PARAMETER :: bmat = "I", uplo = "U" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, d(nev), sigma0 -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -REAL(DFP) :: mat0(SIZE(mat, 1), SIZE(mat, 2)) -INTEGER(I4B) :: ipiv0(SIZE(mat, 1)), info1 -!! -!! int scalar -!! -sigma0 = INPUT(default=0.0_DFP, option=sigma) -!! -!! note to get smallest value, we transform the problem to -!! find largest value. -!! -IF (PRESENT(which)) THEN - which0 = "L"//which(2:2) -ELSE - which0 = "LA" -END IF -!! -n = SIZE(mat, 1) -ncv0 = input(default=MIN(20_I4B, n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -!! -!! iparam -!! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 3 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -!! -!! make a copy of mat in mat0 -!! we will then form mat - sigma*I -!! then we will compute LU decomposition -!! -IF (.NOT. isFactor) THEN - !! - DO CONCURRENT(ii=1:n) - mat(ii, ii) = mat(ii, ii) - sigma0 - END DO - !! - CALL SymGetLU(A=mat, IPIV=ipiv0, UPLO=uplo, INFO=info1) - !! - IF (info1 .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymSmallestEigenVal2()") - STOP - END IF - !! -ELSE - !! - IF (.NOT. PRESENT(ipiv)) THEN - CALL ErrorMsg( & - & msg="When isFactor is True, then ipiv should be provided", & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymSmallestEigenVal2()") - STOP - !! - ELSE - ipiv0(1:n) = ipiv(1:n) - END IF - !! -END IF -!! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - !! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - STOP - END IF - !! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - !! - !! LU Solve - !! mat0 * y = x - !! x => WORKD(ipntr(1):ipntr(1)+N-1) - !! y => WORKD(ipntr(2):ipntr(2)+N-1) - !! - WORKD(ipntr(2):ipntr(2) + N - 1) = & - & WORKD(ipntr(1):ipntr(1) + N - 1) - !! - CALL SymLUSolve(A=mat, B=WORKD(ipntr(2):ipntr(2) + N - 1), & - & IPIV=ipiv0, UPLO=uplo, INFO=info1) - !! - IF (info1 .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymSmallestEigenVal2()") - STOP - END IF - !! - ELSE - EXIT - END IF -END DO -!! -!! we are not getting rvec, therefore ldz=1, -!! othereise ldz = N -!! -IF (info .EQ. 0) THEN - CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=d, z=v, ldz=1, sigma=sigma0, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) - !! - IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ELSE - ans = d(1) - END IF -END IF -!! -END PROCEDURE SymSmallestEigenVal2 - -END SUBMODULE Methods diff --git a/src/submodules/BoundingBox/CMakeLists.txt b/src/submodules/BoundingBox/CMakeLists.txt deleted file mode 100644 index b5b155b73..000000000 --- a/src/submodules/BoundingBox/CMakeLists.txt +++ /dev/null @@ -1,26 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/BoundingBox_Method@ConstructorMethods.F90 - ${src_path}/BoundingBox_Method@SetMethods.F90 - ${src_path}/BoundingBox_Method@GetMethods.F90 - ${src_path}/BoundingBox_Method@IOMethods.F90 - ${src_path}/BoundingBox_Method@TomlMethods.F90 -) diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 deleted file mode 100644 index 4d3f08049..000000000 --- a/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,180 +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(BoundingBox_Method) ConstructorMethods -USE Display_Method, ONLY: BlankLines -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_1 -obj%nsd = nsd -obj%box(1, 1) = lim(1) !xmin -obj%box(1, 2) = lim(3) !ymin -obj%box(1, 3) = lim(5) !zmin -obj%box(2, 1) = lim(2) !xmax -obj%box(2, 2) = lim(4) !ymax -obj%box(2, 3) = lim(6) !zmax -obj%l(1) = lim(2) - lim(1) -obj%l(2) = lim(4) - lim(3) -obj%l(3) = lim(6) - lim(5) -END PROCEDURE Initiate_1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_2 -obj%box = anotherobj%box -obj%nsd = anotherobj%nsd -obj%l = anotherobj%l -END PROCEDURE Initiate_2 - -!--------------------------------------------------------------------------- -! Initiate -!--------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_3 -INTEGER(I4B) :: ii, tsize -tsize = SIZE(anotherobj) -DO ii = 1, tsize - obj(ii) = anotherobj(ii) -END DO -END PROCEDURE Initiate_3 - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_1 -INTEGER(I4B) :: tsize1, tsize2 -TYPE(BoundingBox_), ALLOCATABLE :: tempbox(:) - -tsize2 = SIZE(VALUE) -IF (ALLOCATED(obj)) THEN - tsize1 = SIZE(obj) - ALLOCATE (tempbox(tsize1)) - CALL Initiate(obj=tempbox, anotherobj=obj) - CALL DEALLOCATE (obj) - ALLOCATE (obj(tsize1 + tsize2)) - CALL Initiate(obj(1:tsize1), tempbox) - CALL Initiate(obj(tsize1 + 1:), VALUE) - CALL DEALLOCATE (tempbox) - RETURN - -END IF - -tsize1 = 0 -ALLOCATE (obj(tsize1 + tsize2)) -CALL Initiate(obj(tsize1 + 1:), VALUE) -END PROCEDURE Append_1 - -!---------------------------------------------------------------------------- -! BoundingBox -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor1 -CALL Initiate(ans, nsd, lim) -END PROCEDURE Constructor1 - -!---------------------------------------------------------------------------- -! Bounding box -!---------------------------------------------------------------------------- -MODULE PROCEDURE Constructor2 -CALL Initiate(ans, anotherobj) -END PROCEDURE Constructor2 - -!---------------------------------------------------------------------------- -! Bounding box -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor3 -REAL(DFP) :: lim(6) -INTEGER(I4B) :: nsd - -lim = 0.0_DFP -nsd = SIZE(xij, 1) - -SELECT CASE (nsd) -CASE (1) - lim(1) = MINVAL(xij(1, :)) - lim(2) = MAXVAL(xij(1, :)) -CASE (2) - lim(1) = MINVAL(xij(1, :)) - lim(2) = MAXVAL(xij(1, :)) - lim(3) = MINVAL(xij(2, :)) - lim(4) = MAXVAL(xij(2, :)) -CASE (3) - lim(1) = MINVAL(xij(1, :)) - lim(2) = MAXVAL(xij(1, :)) - lim(3) = MINVAL(xij(2, :)) - lim(4) = MAXVAL(xij(2, :)) - lim(5) = MINVAL(xij(3, :)) - lim(6) = MAXVAL(xij(3, :)) -END SELECT - -CALL Initiate(obj=ans, nsd=nsd, lim=lim) -END PROCEDURE Constructor3 - -!---------------------------------------------------------------------------- -! BoundingBox_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor_1 -ALLOCATE (ans) -CALL Initiate(ans, nsd, lim) -END PROCEDURE Constructor_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor_2 -ALLOCATE (ans) -CALL Initiate(ans, anotherobj) -END PROCEDURE Constructor_2 - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BB_Deallocate -obj%nsd = 0 -obj%box = 0.0_DFP -obj%l = 0.0_DFP -END PROCEDURE BB_Deallocate - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE bb_deallocate2 -INTEGER(I4B) :: ii -IF (ALLOCATED(obj)) THEN - DO ii = 1, SIZE(obj) - CALL DEALLOCATE (obj(ii)) - END DO - DEALLOCATE (obj) -END IF -END PROCEDURE bb_deallocate2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -END SUBMODULE ConstructorMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 deleted file mode 100644 index e0955bfac..000000000 --- a/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 +++ /dev/null @@ -1,300 +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(BoundingBox_Method) GetMethods -USE GlobalData, ONLY: zero -USE ApproxUtility -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getXmin -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getXmin -ans = obj%box(1, 1) -END PROCEDURE getXmin - -!---------------------------------------------------------------------------- -! getXmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getXmax -ans = obj%box(2, 1) -END PROCEDURE getXmax - -!---------------------------------------------------------------------------- -! getYmin -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getYmin -ans = obj%box(1, 2) -END PROCEDURE getYmin - -!---------------------------------------------------------------------------- -! getYmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getYmax -ans = obj%box(2, 2) -END PROCEDURE getYmax - -!---------------------------------------------------------------------------- -! getZmin -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getZmin -ans = obj%box(1, 3) -END PROCEDURE getZmin - -!---------------------------------------------------------------------------- -! getZmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getZmax -ans = obj%box(2, 3) -END PROCEDURE getZmax - -!---------------------------------------------------------------------------- -! is_intersect_in_X -!---------------------------------------------------------------------------- - -MODULE PROCEDURE is_intersect_in_X -! Define internal variables -REAL(DFP) :: min1, max1, min2, max2 -LOGICAL(LGT) :: Left, Right - -min1 = .Xmin.obj; max1 = .Xmax.obj -min2 = .Xmin.obj2; max2 = .Xmax.obj2 - -Right = (min2 .GE. min1) .AND. (min2 .LE. max1) -Left = (max2 .GE. min1) .AND. (max2 .LE. max1) - -IF (Left .OR. Right) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF -END PROCEDURE is_intersect_in_X - -!---------------------------------------------------------------------------- -! is_intersect_in_Y -!---------------------------------------------------------------------------- - -MODULE PROCEDURE is_intersect_in_Y -! Define internal variables -REAL(DFP) :: min1, max1, min2, max2 -LOGICAL(LGT) :: Left, Right - -min1 = .Ymin.obj; max1 = .Ymax.obj -min2 = .Ymin.obj2; max2 = .Ymax.obj2 - -Right = (min2 .GE. min1) .AND. (min2 .LE. max1) -Left = (max2 .GE. min1) .AND. (max2 .LE. max1) - -IF (Left .OR. Right) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF -END PROCEDURE is_intersect_in_Y - -!---------------------------------------------------------------------------- -! is_intersect_in_Z -!---------------------------------------------------------------------------- - -MODULE PROCEDURE is_intersect_in_Z -! Define internal variables -REAL(DFP) :: min1, max1, min2, max2 -LOGICAL(LGT) :: Left, Right - -min1 = .Zmin.obj; max1 = .Zmax.obj -min2 = .Zmin.obj2; max2 = .Zmax.obj2 - -Right = (min2 .GE. min1) .AND. (min2 .LE. max1) -Left = (max2 .GE. min1) .AND. (max2 .LE. max1) - -IF (Left .OR. Right) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF -END PROCEDURE is_intersect_in_Z - -!---------------------------------------------------------------------------- -! is_intersect -!---------------------------------------------------------------------------- - -MODULE PROCEDURE is_intersect -ans = isIntersectInX(obj, obj2) & - & .AND. isIntersectInY(obj, obj2) & - & .AND. isIntersectInZ(obj, obj2) -END PROCEDURE is_intersect - -!---------------------------------------------------------------------------- -! isEmpty -!---------------------------------------------------------------------------- - -MODULE PROCEDURE bbox_isEmpty -ans = .TRUE. -IF (ANY(obj%l .GT. zero)) ans = .FALSE. -END PROCEDURE bbox_isEmpty - -!---------------------------------------------------------------------------- -! get_intersection -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_intersection -INTEGER(I4B) :: nsd -REAL(DFP) :: lim(6) - -nsd = MAX(obj%nsd, obj2%nsd) -lim = 0.0_DFP - -lim(1) = MAX(obj%box(1, 1), obj2%box(1, 1)) -lim(2) = MIN(obj%box(2, 1), obj2%box(2, 1)) - -lim(3) = MAX(obj%box(1, 2), obj2%box(1, 2)) -lim(4) = MIN(obj%box(2, 2), obj2%box(2, 2)) - -lim(5) = MAX(obj%box(1, 3), obj2%box(1, 3)) -lim(6) = MIN(obj%box(2, 3), obj2%box(2, 3)) - -CALL Initiate(obj=ans, nsd=nsd, lim=lim) - -END PROCEDURE get_intersection - -!---------------------------------------------------------------------------- -! Union -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_union -! Define Internal variables -INTEGER(I4B) :: nsd -REAL(DFP) :: val(6), val1, val2 - -nsd = MAX(obj%nsd, obj2%nsd) - -val1 = .Xmin.obj; val2 = .Xmin.obj2 -val(1) = MIN(val1, val2) - -val1 = .Xmax.obj; val2 = .Xmax.obj2 -val(2) = MAX(val1, val2) - -val1 = .Ymin.obj; val2 = .Ymin.obj2 -val(3) = MIN(val1, val2) - -val1 = .Ymax.obj; val2 = .Ymax.obj2 -val(4) = MAX(val1, val2) - -val1 = .Zmin.obj; val2 = .Zmin.obj2 -val(5) = MIN(val1, val2) - -val1 = .Zmax.obj; val2 = .Zmax.obj2 -val(6) = MAX(val1, val2) - -CALL Initiate(obj=ans, nsd=nsd, lim=val) -END PROCEDURE get_union - -!---------------------------------------------------------------------------- -! Center -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_Center -ans(1) = SUM(obj%box(:, 1)) / 2.0_DFP -ans(2) = SUM(obj%box(:, 2)) / 2.0_DFP -ans(3) = SUM(obj%box(:, 3)) / 2.0_DFP -END PROCEDURE get_Center - -!---------------------------------------------------------------------------- -! IsInside -!---------------------------------------------------------------------------- - -MODULE PROCEDURE is_Inside -INTEGER(I4B) :: ii - -ans = .FALSE. -DO ii = 1, SIZE(val) - ans = xyz(val(ii), obj%box(1, ii), obj%box(2, ii)) - IF (.NOT. ans) RETURN -END DO - -CONTAINS -PURE ELEMENTAL FUNCTION xyz(x, y, z) RESULT(ans) - REAL(DFP), INTENT(IN) :: x, y, z - LOGICAL(LGT) :: ans - ans = .FALSE. - IF ((x.APPROXGE.y) .AND. (x.APPROXLE.z)) ans = .TRUE. -END FUNCTION xyz -END PROCEDURE is_Inside - -!---------------------------------------------------------------------------- -! getNptrs -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_nptrs -INTEGER(I4B) :: n, i -LOGICAL(LGT), ALLOCATABLE :: msk(:) -INTEGER(I4B), ALLOCATABLE :: Indx(:) - -n = SIZE(xij, 2) -ALLOCATE (msk(n), Indx(n)) -DO i = 1, n - msk(i) = isInside(obj, xij(:, i)) - Indx(i) = i -END DO -ans = PACK(Indx, msk) -DEALLOCATE (msk, Indx) -END PROCEDURE get_nptrs - -!---------------------------------------------------------------------------- -! GetDiameter -!---------------------------------------------------------------------------- - -MODULE PROCEDURE bbox_GetDiameterSqr -ans = obj%l(1)**2 + obj%l(2)**2 + obj%l(3)**2 -END PROCEDURE bbox_GetDiameterSqr - -!---------------------------------------------------------------------------- -! GetDiameter -!---------------------------------------------------------------------------- - -MODULE PROCEDURE bbox_GetDiameter -ans = SQRT(bbox_GetDiameterSqr(obj)) -END PROCEDURE bbox_GetDiameter - -!---------------------------------------------------------------------------- -! GetRadius -!---------------------------------------------------------------------------- - -MODULE PROCEDURE bbox_GetRadius -ans = bbox_GetDiameter(obj) * 0.5_DFP -END PROCEDURE bbox_GetRadius - -!---------------------------------------------------------------------------- -! GetRadius -!---------------------------------------------------------------------------- - -MODULE PROCEDURE bbox_GetRadiusSqr -ans = 0.25_DFP * bbox_GetDiameterSqr(obj) -END PROCEDURE bbox_GetRadiusSqr - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE GetMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 deleted file mode 100644 index 246ab3bd7..000000000 --- a/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 +++ /dev/null @@ -1,41 +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(BoundingBox_Method) IOMethods -USE Display_Method -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE display_obj -CALL Display(msg, unitNo=unitNo) -CALL Display(obj%nsd, msg="NSD :: ", unitNo=unitNo) -CALL Display(.Xmin.obj, msg="Xmin :: ", unitNo=unitNo) -CALL Display(.Xmax.obj, msg="Xmax :: ", unitNo=unitNo) -CALL Display(.Ymin.obj, msg="Ymin :: ", unitNo=unitNo) -CALL Display(.Ymax.obj, msg="Ymax :: ", unitNo=unitNo) -CALL Display(.Zmin.obj, msg="Zmin :: ", unitNo=unitNo) -CALL Display(.Zmax.obj, msg="Zmax :: ", unitNo=unitNo) -CALL Display(obj%l(1), msg="Lx :: ", unitNo=unitNo) -CALL Display(obj%l(2), msg="Ly :: ", unitNo=unitNo) -CALL Display(obj%l(3), msg="Lz :: ", unitNo=unitNo) -END PROCEDURE display_obj - -END SUBMODULE IOMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 deleted file mode 100644 index 8261a4518..000000000 --- a/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 +++ /dev/null @@ -1,70 +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(BoundingBox_Method) SetMethods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setXmin -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setXmin -obj%box(1, 1) = val -END PROCEDURE setXmin - -!---------------------------------------------------------------------------- -! setXmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setXmax -obj%box(2, 1) = val -END PROCEDURE setXmax - -!---------------------------------------------------------------------------- -! setYmin -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setYmin -obj%box(1, 2) = val -END PROCEDURE setYmin - -!---------------------------------------------------------------------------- -! setYmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setYmax -obj%box(2, 2) = val -END PROCEDURE setYmax - -!---------------------------------------------------------------------------- -! setZmin -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setZmin -obj%box(1, 3) = val -END PROCEDURE setZmin - -!---------------------------------------------------------------------------- -! setZmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setZmax -obj%box(2, 3) = val -END PROCEDURE setZmax - -END SUBMODULE SetMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 deleted file mode 100644 index 682a2e1b2..000000000 --- a/src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 +++ /dev/null @@ -1,86 +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(BoundingBox_Method) TomlMethods -USE tomlf, ONLY: & - ! & toml_error, & - ! & toml_load, & - ! & toml_parser_config, & - ! & toml_serialize, & - & toml_get => get_value, & - & toml_len => len, & - ! & toml_context, & - ! & toml_terminal, & - ! & toml_load, & - ! & toml_stat, & - & toml_array -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE toml_get_bbox_r0 -REAL(DFP) :: lim(6) -lim = 0.0 -CALL toml_get(table, "xmin", lim(1), origin=origin, stat=stat) -CALL toml_get(table, "ymin", lim(2), origin=origin, stat=stat) -CALL toml_get(table, "zmin", lim(3), origin=origin, stat=stat) -CALL toml_get(table, "xmax", lim(4), origin=origin, stat=stat) -CALL toml_get(table, "ymax", lim(5), origin=origin, stat=stat) -CALL toml_get(table, "zmax", lim(6), origin=origin, stat=stat) -CALL Initiate(obj=VALUE, nsd=3_I4B, lim=lim) -END PROCEDURE toml_get_bbox_r0 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE toml_get_bbox_r1 -TYPE(toml_array), POINTER :: array -TYPE(toml_table), POINTER :: child -LOGICAL(LGT) :: isFound0 -INTEGER(I4B) :: ii, tsize - -child => NULL() -array => NULL() -isFound0 = .FALSE. -CALL DEALLOCATE (VALUE) - -CALL toml_get(table, key, array, origin=origin, & - & stat=stat, requested=.FALSE.) - -IF (ASSOCIATED(array)) THEN - isFound0 = .TRUE. - tsize = toml_len(array) - ALLOCATE (VALUE(tsize)) - DO ii = 1, tsize - CALL toml_get(array, ii, child) - CALL toml_get_bbox_r0(table=child, key="", VALUE=VALUE(ii), & - & origin=origin, stat=stat) - END DO -END IF - -IF (PRESENT(isFound)) isFound = isFound0 -NULLIFY (array, child) -END PROCEDURE toml_get_bbox_r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE TomlMethods diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt deleted file mode 100644 index c6af0f192..000000000 --- a/src/submodules/CMakeLists.txt +++ /dev/null @@ -1,130 +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 -# - -# TriangleInterface -include(${CMAKE_CURRENT_LIST_DIR}/TriangleInterface/CMakeLists.txt) - -# Hashing -include(${CMAKE_CURRENT_LIST_DIR}/Hashing/CMakeLists.txt) - -# MdEncode -include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) - -# Utility -include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) - -# Polynomial -include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) - -# MultiIndices -include(${CMAKE_CURRENT_LIST_DIR}/MultiIndices/CMakeLists.txt) - -# OpenMP -include(${CMAKE_CURRENT_LIST_DIR}/OpenMP/CMakeLists.txt) - -# Random -include(${CMAKE_CURRENT_LIST_DIR}/Random/CMakeLists.txt) - -# BoundingBox -include(${CMAKE_CURRENT_LIST_DIR}/BoundingBox/CMakeLists.txt) - -# IntVector -include(${CMAKE_CURRENT_LIST_DIR}/IntVector/CMakeLists.txt) - -# IndexValue -include(${CMAKE_CURRENT_LIST_DIR}/IndexValue/CMakeLists.txt) - -# IterationData -include(${CMAKE_CURRENT_LIST_DIR}/IterationData/CMakeLists.txt) - -# KeyValue -include(${CMAKE_CURRENT_LIST_DIR}/KeyValue/CMakeLists.txt) - -# Vector3D -include(${CMAKE_CURRENT_LIST_DIR}/Vector3D/CMakeLists.txt) - -# Lapack -include(${CMAKE_CURRENT_LIST_DIR}/Lapack/CMakeLists.txt) - -# ARPACK -include(${CMAKE_CURRENT_LIST_DIR}/ARPACK/CMakeLists.txt) - -# RealVector -include(${CMAKE_CURRENT_LIST_DIR}/RealVector/CMakeLists.txt) - -# DOF -include(${CMAKE_CURRENT_LIST_DIR}/DOF/CMakeLists.txt) - -# Geometry -include(${CMAKE_CURRENT_LIST_DIR}/Geometry/CMakeLists.txt) - -# QuadraturePoint -include(${CMAKE_CURRENT_LIST_DIR}/QuadraturePoint/CMakeLists.txt) - -# FEVariable -include(${CMAKE_CURRENT_LIST_DIR}/FEVariable/CMakeLists.txt) - -# ElemShapeData -include(${CMAKE_CURRENT_LIST_DIR}/ElemshapeData/CMakeLists.txt) - -# RealMatrix -include(${CMAKE_CURRENT_LIST_DIR}/RealMatrix/CMakeLists.txt) - -# MassMatrix -include(${CMAKE_CURRENT_LIST_DIR}/MassMatrix/CMakeLists.txt) - -# STMassMatrix -include(${CMAKE_CURRENT_LIST_DIR}/STMassMatrix/CMakeLists.txt) - -# DiffusionMatrix -include(${CMAKE_CURRENT_LIST_DIR}/DiffusionMatrix/CMakeLists.txt) - -# STDiffusionMatrix -include(${CMAKE_CURRENT_LIST_DIR}/STDiffusionMatrix/CMakeLists.txt) - -# ConvectiveMatrix -include(${CMAKE_CURRENT_LIST_DIR}/ConvectiveMatrix/CMakeLists.txt) - -# STConvectiveMatrix -include(${CMAKE_CURRENT_LIST_DIR}/STConvectiveMatrix/CMakeLists.txt) - -# StiffnessMatrix -include(${CMAKE_CURRENT_LIST_DIR}/StiffnessMatrix/CMakeLists.txt) - -# ElasticNitscheMatrix -include(${CMAKE_CURRENT_LIST_DIR}/ElasticNitscheMatrix/CMakeLists.txt) - -# FacetMatrix -include(${CMAKE_CURRENT_LIST_DIR}/FacetMatrix/CMakeLists.txt) - -# ForceVector -include(${CMAKE_CURRENT_LIST_DIR}/ForceVector/CMakeLists.txt) - -# STForceVector -include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt) - -# VoigtRank2Tensor -include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt) - -# Rank2Tensor -include(${CMAKE_CURRENT_LIST_DIR}/Rank2Tensor/CMakeLists.txt) - -# CSRSparsity -include(${CMAKE_CURRENT_LIST_DIR}/CSRSparsity/CMakeLists.txt) - -# CSRMatrix -include(${CMAKE_CURRENT_LIST_DIR}/CSRMatrix/CMakeLists.txt) diff --git a/src/submodules/CSRMatrix/CMakeLists.txt b/src/submodules/CSRMatrix/CMakeLists.txt deleted file mode 100644 index 9687b24e2..000000000 --- a/src/submodules/CSRMatrix/CMakeLists.txt +++ /dev/null @@ -1,47 +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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/CSRMatrix_AddMethods@Methods.F90 - ${src_path}/CSRMatrix_ConstructorMethods@Methods.F90 - ${src_path}/CSRMatrix_DiagonalScalingMethods@Methods.F90 - ${src_path}/CSRMatrix_GetBlockColMethods@Methods.F90 - ${src_path}/CSRMatrix_GetColMethods@Methods.F90 - ${src_path}/CSRMatrix_GetMethods@Methods.F90 - ${src_path}/CSRMatrix_GetRowMethods@Methods.F90 - ${src_path}/CSRMatrix_GetSubMatrixMethods@Methods.F90 - ${src_path}/CSRMatrix_ILUMethods@Methods.F90 - ${src_path}/CSRMatrix_IOMethods@Methods.F90 - ${src_path}/CSRMatrix_LUSolveMethods@Methods.F90 - ${src_path}/CSRMatrix_MatVecMethods@Methods.F90 - ${src_path}/CSRMatrix_SymMatmulMethods@Methods.F90 - ${src_path}/CSRMatrix_ReorderingMethods@Methods.F90 - ${src_path}/CSRMatrix_SetBlockColMethods@Methods.F90 - ${src_path}/CSRMatrix_SetBlockRowMethods@Methods.F90 - ${src_path}/CSRMatrix_SetColMethods@Methods.F90 - ${src_path}/CSRMatrix_SetRowMethods@Methods.F90 - ${src_path}/CSRMatrix_SetMethods@Methods.F90 - ${src_path}/CSRMatrix_SparsityMethods@Methods.F90 - ${src_path}/CSRMatrix_UnaryMethods@Methods.F90 - ${src_path}/CSRMatrix_SpectralMethods@Methods.F90 - ${src_path}/CSRMatrix_MatrixMarketIO@Methods.F90 - ${src_path}/CSRMatrix_DBCMethods@Methods.F90 - ${src_path}/CSRMatrix_LinSolveMethods@Methods.F90 - ${src_path}/CSRMatrix_SuperLU@Methods.F90 - ${src_path}/CSRMatrix_SchurMethods@Methods.F90) diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 deleted file mode 100644 index 15664fcb3..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 +++ /dev/null @@ -1,420 +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: 22 March 2021 -! summary: It contains method for setting values in [[CSRMatrix_]] - -SUBMODULE(CSRMatrix_AddMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! AddContribution -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add0 -! Internal variables -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) - -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 -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -END PROCEDURE obj_Add0 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add1 -REAL(DFP), ALLOCATABLE :: m2(:, :) -INTEGER(I4B) :: tdof - -tdof = .tdof.obj%csr%idof -SELECT CASE (storageFMT) -CASE (FMT_NODES) - IF ((obj.StorageFMT.1) .EQ. FMT_NODES) THEN - m2 = VALUE - ELSE - CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, & - & 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) - END IF -END SELECT - -CALL Add(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale) -IF (ALLOCATED(m2)) DEALLOCATE (m2) - -END PROCEDURE obj_Add1 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add2 -obj%A = obj%A + scale * VALUE -END PROCEDURE obj_Add2 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -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 -END DO -END PROCEDURE obj_Add3 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -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) -! -END PROCEDURE obj_Add4 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add5 -REAL(DFP), ALLOCATABLE :: m2(:, :) -INTEGER(I4B) :: tdof1, tdof2 -tdof1 = .tdof.obj%csr%idof -tdof2 = .tdof.obj%csr%jdof -ALLOCATE (m2(tdof1 * SIZE(nodenum), tdof2 * SIZE(nodenum))) -m2 = VALUE -CALL Add(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale) -DEALLOCATE (m2) -END PROCEDURE obj_Add5 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_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) - -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 - -DEALLOCATE (row, col) - -END PROCEDURE obj_Add6 - -!---------------------------------------------------------------------------- -! 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) -! -END PROCEDURE obj_Add7 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -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) - -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 - -DEALLOCATE (row, col) -END PROCEDURE obj_Add8 - -!---------------------------------------------------------------------------- -! 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) -END PROCEDURE obj_Add9 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -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 - -DEALLOCATE (row, col) -END PROCEDURE obj_Add10 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -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 - -DEALLOCATE (row, col) - -END PROCEDURE obj_Add11 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -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) - -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 - -DEALLOCATE (row, col) -END PROCEDURE obj_Add12 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add13 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk - -row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) - -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 - -DEALLOCATE (row, col) - -END PROCEDURE obj_Add13 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add14 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk - -row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) - -col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & - & spacecompo=jspacecompo, timecompo=jtimecompo) - -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 - -DEALLOCATE (row, col) - -END PROCEDURE obj_Add14 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add15 -LOGICAL(LGT) :: sameStructure0, isSorted0 -INTEGER(I4B) :: nrow, ncol, nzmax, ierr - -sameStructure0 = Input(default=.FALSE., option=isSameStructure) - -IF (sameStructure0) THEN - obj%A = obj%A + scale * VALUE%A - RETURN -END IF - -isSorted0 = Input(default=.FALSE., option=isSorted) - -nrow = SIZE(obj, 1) -ncol = SIZE(obj, 2) -nzmax = 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) -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) -END IF - -IF (ierr .EQ. 0) THEN - CALL Errormsg( & - & "Some error occured while calling CSRMarixAPLSB.", & - & __FILE__, & - & "obj_Add15()", & - & __LINE__, & - & stderr) - STOP -END IF -END PROCEDURE obj_Add15 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 deleted file mode 100644 index f16fcdd21..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 +++ /dev/null @@ -1,382 +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: 22 March 2021 -! summary: This submodule contains method for constructing [[CSRMatrix_]] - -SUBMODULE(CSRMatrix_ConstructorMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Shape -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Shape -Ans = [obj%csr%nrow, obj%csr%ncol] -END PROCEDURE obj_Shape - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Size -IF (PRESENT(Dims)) THEN - IF (Dims .EQ. 1) THEN - Ans = obj%csr%nrow - ELSE - Ans = obj%csr%ncol - END IF -ELSE - Ans = obj%csr%nrow * obj%csr%ncol -END IF -END PROCEDURE obj_Size - -!---------------------------------------------------------------------------- -! TotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_TotalDimension -ans = obj%tDimension -END PROCEDURE obj_TotalDimension - -!---------------------------------------------------------------------------- -! SetTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SetTotalDimension -obj%tDimension = tDimension -END PROCEDURE obj_SetTotalDimension - -!---------------------------------------------------------------------------- -! getNNZ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_getNNZ -Ans = obj%csr%nnz -END PROCEDURE obj_getNNZ - -!---------------------------------------------------------------------------- -! Allocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Allocate -CALL Initiate(obj=obj, ncol=dims(2), nrow=dims(1), matrixProp=matrixProp) -END PROCEDURE obj_Allocate - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Deallocate -CALL DEALLOCATE (obj%csr) -obj%csrOwnership = .FALSE. -obj%tDimension = 2 -obj%MatrixProp = 'UNSYM' -IF (ALLOCATED(obj%A)) DEALLOCATE (obj%A) -#ifdef USE_SuperLU -CALL SuperluDeallocate(obj) -#endif -END PROCEDURE obj_Deallocate - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate1 -CALL DEALLOCATE (obj) -obj%csrOwnership = .TRUE. -IF (PRESENT(matrixProp)) obj%matrixProp = TRIM(matrixProp) -CALL Initiate(obj=obj%csr, ncol=ncol, nrow=nrow, idof=idof, jdof=jdof, & -& nnz=nnz) -CALL Reallocate(obj%A, obj%csr%nnz) -CALL SetTotalDimension(obj, 2_I4B) -END PROCEDURE obj_Initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate2 -IF (.NOT. csr%isInitiated) THEN - CALL ErrorMSG( & - & "Instance of CSRSparsity is not Initiated!", & - & __FILE__, & - & "obj_Initiate2()", & - & __LINE__, stderr) - STOP -END IF - -CALL DEALLOCATE (obj) -obj%csrOwnership = .TRUE. -IF (PRESENT(matrixProp)) obj%matrixProp = TRIM(matrixProp) -obj%csr = csr -CALL Reallocate(obj%A, obj%csr%nnz) -CALL SetTotalDimension(obj, 2_I4B) - -END PROCEDURE obj_Initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate3 -CALL Initiate(obj=obj%csr, IA=IA, JA=JA, ncol=ncol) -obj%csrOwnership = .TRUE. -IF (PRESENT(matrixProp)) obj%matrixProp = TRIM(matrixProp) -CALL Reallocate(obj%A, SIZE(A)) -#ifdef USE_BLAS95 -CALL Copy(y=obj%A, x=A) -#else -obj%A = A -#endif -CALL SetTotalDimension(obj, 2_I4B) -CALL SetSparsity(obj) -END PROCEDURE obj_Initiate3 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate4 -CALL DEALLOCATE (obj) -obj%csr = obj2%csr -obj%tDimension = obj2%tDimension -obj%csrOwnership = obj2%csrOwnership -obj%matrixProp = obj2%matrixProp -IF (ALLOCATED(obj2%A)) obj%A = obj2%A -END PROCEDURE obj_Initiate4 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate5 -INTEGER(I4B) :: nrow, ncol, nnz, job -INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) -REAL(DFP), ALLOCATABLE :: A(:) - -job = 1 -nrow = i2 - i1 + 1 -ncol = j2 - j1 + 1 -nnz = obj2%csr%nnz -ALLOCATE (A(nnz), IA(nrow + 1), JA(nnz)) -A = 0.0; IA = 0; JA = 0 -!! calling from Sparsekit -CALL SUBMAT(job, i1, i2, j1, j2, obj2%A, obj2%csr%JA, obj2%csr%IA,& - & nrow, ncol, A, JA, IA) -!! -nnz = IA(nrow + 1) - 1 -CALL Initiate(obj=obj, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -obj%csr%ncol = ncol -DEALLOCATE (IA, JA, A) -END PROCEDURE obj_Initiate5 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate6 -CALL obj_Initiate4(obj=obj, obj2=obj2) -END PROCEDURE obj_Initiate6 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate7 -INTEGER(I4B) :: nzmax, nrow, ncol, ierr -TYPE(DOF_), POINTER :: idof, jdof -LOGICAL(LGT) :: case1, case2, isSorted0 - -nzmax = GetNNZ(obj1=obj1%csr, obj2=obj2%csr, isSorted=isSorted, op="+") - -nrow = SIZE(obj1, 1) -ncol = SIZE(obj2, 2) - -NULLIFY (idof, jdof) -idof => GetDOFPointer(obj1, 1) -jdof => GetDOFPointer(obj1, 2) - -case1 = ASSOCIATED(idof) -case2 = ASSOCIATED(jdof) - -IF (case1 .AND. case2) THEN - CALL Initiate(obj=obj, ncol=ncol, nrow=nrow, idof=idof, & - & jdof=jdof, nnz=nzmax) -ELSEIF (case1 .AND. .NOT. case2) THEN - CALL Initiate(obj=obj, ncol=ncol, nrow=nrow, idof=idof, nnz=nzmax) -ELSEIF (.NOT. case1 .AND. case2) THEN - CALL Initiate(obj=obj, ncol=ncol, nrow=nrow, jdof=jdof, nnz=nzmax) -ELSE - CALL Errormsg( & - & "Some error occured while getting idof and jdof", & - & __FILE__, & - & "obj_Initiate7()", & - & __LINE__, & - & unitno=stderr) - RETURN -END IF - -isSorted0 = Input(default=.FALSE., option=isSorted) - -IF (isSorted0) THEN - CALL obj_aplsb_sorted(nrow=nrow, ncol=ncol, & - & a=obj1%A, ja=obj1%csr%JA, ia=obj1%csr%IA, s=scale, & - & b=obj2%A, jb=obj2%csr%JA, ib=obj2%csr%IA, & - & c=obj%A, jc=obj%csr%JA, ic=obj%csr%IA, nzmax=nzmax, ierr=ierr) -ELSE - CALL obj_aplsb(nrow=nrow, ncol=ncol, & - & a=obj1%A, ja=obj1%csr%JA, ia=obj1%csr%IA, s=scale, & - & b=obj2%A, jb=obj2%csr%JA, ib=obj2%csr%IA, & - & c=obj%A, jc=obj%csr%JA, ic=obj%csr%IA, nzmax=nzmax, ierr=ierr) -END IF - -IF (ierr .NE. 0) THEN - CALL Errormsg( & - & "Some error occured while calling obj_aplsb(_sorted) method", & - & __FILE__, & - & "obj_Initiate7()", & - & __LINE__, & - & unitno=stderr) - RETURN -END IF - -END PROCEDURE obj_Initiate7 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_aplsb -! internal variables -INTEGER(I4B) :: tsize, j, ii, ka, jcol, kb, jpos, iw(ncol), k - -ierr = 0 -tsize = 0 -ic(1) = 1 -iw = 0 - -DO ii = 1, nrow - ! copy row ii to C - DO ka = ia(ii), ia(ii + 1) - 1 - tsize = tsize + 1 - jcol = ja(ka) - IF (tsize .GT. nzmax) THEN - ierr = ii - RETURN - END IF - jc(tsize) = jcol - c(tsize) = a(ka) - iw(jcol) = tsize - END DO - - DO kb = ib(ii), ib(ii + 1) - 1 - jcol = jb(kb) - jpos = iw(jcol) - IF (jpos .EQ. 0) THEN - tsize = tsize + 1 - IF (tsize .GT. nzmax) THEN - ierr = ii - RETURN - END IF - jc(tsize) = jcol - c(tsize) = s * b(kb) - iw(jcol) = tsize - ELSE - c(jpos) = c(jpos) + s * b(kb) - END IF - END DO - DO k = ic(ii), tsize - iw(jc(k)) = 0 - END DO - ic(ii + 1) = tsize + 1 -END DO - -END PROCEDURE obj_aplsb - -!---------------------------------------------------------------------------- -! CSRMatrixAPLSBSorted -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_aplsb_sorted -! internal variables -INTEGER(I4B) :: len, i, ka, kb, kc, & - & kamax, kbmax, j1, jj2 -LOGICAL(LGT) :: isok - -ierr = 0 -kc = 1 -ic(1) = kc - -DO i = 1, nrow - ka = ia(i) - kb = ib(i) - kamax = ia(i + 1) - 1 - kbmax = ib(i + 1) - 1 - - DO - isok = ka .LE. kamax .OR. kb .LE. kbmax - IF (.NOT. isok) THEN - ic(i + 1) = kc - EXIT - END IF - - IF (ka .LE. kamax) THEN - j1 = ja(ka) - ELSE - ! take j1 large enough that always jj2 .lt. j1 - j1 = ncol + 1 - END IF - - IF (kb .LE. kbmax) THEN - jj2 = jb(kb) - ELSE - ! similarly take jj2 large enough that always j1 .lt. jj2 - jj2 = ncol + 1 - END IF - - IF (j1 .EQ. jj2) THEN - c(kc) = a(ka) + s * b(kb) - jc(kc) = j1 - ka = ka + 1 - kb = kb + 1 - kc = kc + 1 - ELSE IF (j1 .LT. jj2) THEN - jc(kc) = j1 - c(kc) = a(ka) - ka = ka + 1 - kc = kc + 1 - ELSE IF (j1 .GT. jj2) THEN - jc(kc) = jj2 - c(kc) = s * b(kb) - kb = kb + 1 - kc = kc + 1 - END IF - - IF (kc .GT. nzmax) THEN - ierr = i - RETURN - END IF - END DO -END DO - -END PROCEDURE obj_aplsb_sorted - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 deleted file mode 100644 index 83e6b7807..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 +++ /dev/null @@ -1,72 +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: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_DBCMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_ApplyDBC -INTEGER(I4B) :: i, ii, nrow -LOGICAL(LGT), ALLOCATABLE :: mask(:) -REAL(DFP), ALLOCATABLE :: diag_entries(:) - -ASSOCIATE (IA => obj%csr%IA, JA => obj%csr%JA, A => obj%A) - - nrow = SIZE(obj, 1) - ALLOCATE (mask(nrow)) - mask = .FALSE. - mask(dbcPtrs) = .TRUE. - - ! make row zeros - - DO CONCURRENT(i=1:SIZE(dbcPtrs)) - ii = dbcPtrs(i) - A(IA(ii):IA(ii + 1) - 1) = 0.0_DFP - END DO - - DO CONCURRENT(i=1:nrow) - DO ii = IA(i), IA(i + 1) - 1 - IF (mask(JA(ii))) THEN - A(ii) = 0.0_DFP - END IF - END DO - END DO - - IF (obj%csr%isDiagStored) THEN - A(obj%csr%idiag(dbcPtrs)) = 1.0_DFP - ELSE - CALL GetDiagonal(obj=obj, diag=diag_entries) - A(obj%csr%idiag(dbcPtrs)) = 1.0_DFP - DEALLOCATE (diag_entries) - END IF - - DEALLOCATE (mask) - -END ASSOCIATE - -END PROCEDURE csrMat_ApplyDBC - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 deleted file mode 100644 index fec9c27a9..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 +++ /dev/null @@ -1,166 +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(CSRMatrix_DiagonalScalingMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! DiagonalScaling -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrmat_DiagonalScaling_1 -REAL(DFP), ALLOCATABLE :: diag_(:) -CALL getDiagonal(obj=obj, diag=diag_) -CALL DiagonalScaling(obj=obj, diag=diag_, OPERATOR=OPERATOR, side=side) -IF (ALLOCATED(diag_)) DEALLOCATE (diag_) -END PROCEDURE csrmat_DiagonalScaling_1 - -!---------------------------------------------------------------------------- -! DiagonalScaling -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrmat_DiagonalScaling_2 -INTEGER(I4B) :: ii, jj -CHARACTER(:), ALLOCATABLE :: op -REAL(DFP) :: avar - -IF (PRESENT(OPERATOR)) THEN - op = OPERATOR -ELSE - op = 'SQRT' -END IF - -SELECT CASE (TRIM(side)) - -CASE ('LEFT', 'Left', 'left') - - SELECT CASE (TRIM(op)) - - CASE ('SQRT') - - DO ii = 1, obj%csr%nrow - - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - IF (ABS(diag(ii)) .GT. zero) THEN - obj%A(jj) = obj%A(jj) / SQRT(ABS(diag(ii))) - END IF - - END DO - END DO - - CASE ('NONE') - ! - DO ii = 1, obj%csr%nrow - ! - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - ! - obj%A(jj) = obj%A(jj) / diag(ii) - ! - END DO - END DO - ! - END SELECT - ! - ! - ! -CASE ('RIGHT', 'Right', 'right') - ! - ! - SELECT CASE (TRIM(op)) - ! - ! - ! - CASE ('SQRT') - ! - DO ii = 1, obj%csr%nrow - ! - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - ! - obj%A(jj) = obj%A(jj) / SQRT(ABS(diag(obj%csr%JA(jj)))) - ! - END DO - END DO - ! - ! - ! - CASE ('NONE') - ! - DO ii = 1, obj%csr%nrow - ! - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - ! - obj%A(jj) = obj%A(jj) / diag(obj%csr%JA(jj)) - ! - END DO - END DO - ! - END SELECT - ! - ! - ! -CASE ('BOTH', 'Both', 'both') - ! - ! - SELECT CASE (TRIM(op)) - ! - ! - ! - CASE ('SQRT') - ! - DO ii = 1, obj%csr%nrow - ! - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - ! - avar = ABS(diag(ii) * diag(obj%csr%JA(jj))) - - IF (avar .GT. zero) THEN - obj%A(jj) = obj%A(jj) / SQRT(avar) - END IF - ! - END DO - END DO - ! - ! - ! - CASE ('NONE') - ! - DO ii = 1, obj%csr%nrow - ! - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - ! - obj%A(jj) = obj%A(jj) / diag(ii) / diag(obj%csr%JA(jj)) - ! - END DO - END DO - ! - END SELECT - ! - ! - ! -END SELECT -! -! -! -END PROCEDURE csrmat_DiagonalScaling_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 deleted file mode 100644 index 44e431b33..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 +++ /dev/null @@ -1,318 +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 -! - -!! authors: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_GetBlockColMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn1 -INTEGER(I4B) :: jj, ii, c(3), row_start, row_end -REAL(DFP) :: alpha - !! -#ifdef DEBUG_VER - !! - !!check - !! -IF (SIZE(VALUE) .LT. obj%csr%nrow) THEN - CALL ErrorMSG( & - & Msg="SIZE of column vector is less than the number of row & - & in sparse matrix", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockColumn1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF (icolumn .GT. SIZE(obj, 2)) THEN - CALL ErrorMSG( & - & Msg="icolumn is out of Bound", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockColumn1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF (ivar .GT. (.tNames.obj%csr%idof)) THEN - CALL ErrorMSG( & - & Msg="ivar is out of Bound", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockColumn1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF ((obj.StorageFMT.ivar) .NE. FMT_DOF) THEN - CALL ErrorMSG( & - & Msg="For this rotuine storage format should FMT_DOF", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockColumn1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! - !! start, end, stride - !! -c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFStartIndex.ivar)) -row_start = c(1) ! start -c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFEndIndex.ivar)) -row_end = c(2) ! end - !! -IF (PRESENT(addContribution)) THEN - !! - !! - !! - alpha = INPUT(Default=1.0_DFP, Option=scale) - !! - DO ii = row_start, row_end - VALUE(ii) = 0.0_DFP - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - IF (obj%csr%JA(jj) .EQ. icolumn) THEN - VALUE(ii) = VALUE(ii) + alpha * obj%A(jj) - EXIT - END IF - END DO - END DO - !! - !! - !! -ELSE - !! - DO ii = row_start, row_end - VALUE(ii) = 0.0_DFP - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - IF (obj%csr%JA(jj) .EQ. icolumn) THEN - VALUE(ii) = obj%A(jj) - EXIT - END IF - END DO - END DO - !! -END IF - !! -END PROCEDURE csrMat_getBlockColumn1 - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn1b -INTEGER(I4B) :: ii, jj, kk, c(3), row_start, row_end -REAL(DFP) :: alpha - !! - !! start, end, stride - !! -c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFStartIndex.ivar)) -row_start = c(1) ! start -c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFEndIndex.ivar)) -row_end = c(2) ! end - !! -IF (PRESENT(addContribution)) THEN - !! - alpha = INPUT(Default=1.0_DFP, Option=scale) - !! - DO ii = row_start, row_end - VALUE(ii) = 0.0_DFP - DO kk = 1, SIZE(icolumn) - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - IF (obj%csr%JA(jj) .EQ. icolumn(kk)) THEN - VALUE(ii) = VALUE(ii) + alpha * obj%A(jj) - EXIT - END IF - END DO - END DO - END DO - !! -ELSE - !! - DO ii = row_start, row_end - VALUE(ii) = 0.0_DFP - DO kk = 1, SIZE(icolumn) - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - IF (obj%csr%JA(jj) .EQ. icolumn(kk)) THEN - VALUE(ii) = obj%A(jj) - EXIT - END IF - END DO - END DO - END DO - !! -END IF - !! -END PROCEDURE csrMat_getBlockColumn1b - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn2 - !! -CALL getBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & idof=idof), & - & VALUE=VALUE, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getBlockColumn2 - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn3 - !! -CALL getBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(& - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & idof=idof), & - & VALUE=VALUE, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getBlockColumn3 - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn4 - !! -CALL getBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(& - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & VALUE=VALUE, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getBlockColumn4 - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn5 - !! -CALL getBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(& - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & VALUE=VALUE, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getBlockColumn5 - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn6 - !! -CALL getBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(& - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & VALUE=VALUE, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getBlockColumn6 - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn7 - !! -CALL getBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(& - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & VALUE=VALUE, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getBlockColumn7 - -!---------------------------------------------------------------------------- -! getBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockColumn8 - !! -CALL getBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(& - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & VALUE=VALUE, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getBlockColumn8 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 deleted file mode 100644 index ad16465ba..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 +++ /dev/null @@ -1,291 +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 -! - -!! authors: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_GetBlockRowMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow1 -INTEGER(I4B) :: jj, c(3), col_start, col_end -REAL(DFP) :: alpha - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (SIZE(value) .LT. obj%csr%ncol) THEN - CALL ErrorMSG( & - & Msg="SIZE of row vector should be less & - & than the number of col & - & in sparse matrix", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockRow1", Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF (irow .GT. SIZE(obj, 1)) THEN - CALL ErrorMSG( & - & Msg="irow is out of Bound", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockRow1", Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF (jvar .GT. (.tNames.obj%csr%jdof)) THEN - CALL ErrorMSG( & - & Msg="jVar is out of Bound", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockRow1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF ((.StorageFMT.obj) .NE. FMT_DOF) THEN - CALL ErrorMSG( & - & Msg="For this rotuine storage format should FMT_DOF", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getBlockRow1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! - !! start, end, stride of idof - !! -c = getNodeLoc(obj=obj%csr%jdof, idof=(obj%csr%jdof.DOFStartIndex.jvar)) -col_start = c(1) ! start -c = getNodeLoc(obj%csr%jdof, (obj%csr%jdof.DOFEndIndex.jvar)) -col_end = c(2) ! end - !! - !! - !! -IF (PRESENT(addContribution)) THEN - !! - alpha = INPUT(Default=1.0_DFP, Option=scale) - !! - DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 - IF ((jj .GE. col_start) .AND. (jj .LE. col_end)) & - & value(obj%csr%JA(jj)) = value(obj%csr%JA(jj)) + alpha * obj%A(jj) - END DO - !! - !! - !! -ELSE - !! - value = 0.0_DFP - !! - DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 - IF ((jj .GE. col_start) .AND. jj .LE. col_end) & - & value(obj%csr%JA(jj)) = obj%A(jj) - END DO - !! -END IF - !! -END PROCEDURE csrMat_getBlockRow1 - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow1b -INTEGER(I4B) :: ii, jj, c(3), col_start, col_end -REAL(DFP) :: alpha - !! - !! start, end, stride of idof - !! -c = getNodeLoc(obj=obj%csr%jdof, idof=(obj%csr%jdof.DOFStartIndex.jvar)) -col_start = c(1) ! start -c = getNodeLoc(obj%csr%jdof, (obj%csr%jdof.DOFEndIndex.jvar)) -col_end = c(2) ! end - !! - !! - !! -IF (PRESENT(addContribution)) THEN - !! - alpha = INPUT(Default=1.0_DFP, Option=scale) - !! - DO ii = 1, size(irow) - DO jj = obj%csr%IA(irow(ii)), obj%csr%IA(irow(ii) + 1) - 1 - IF ((jj .GE. col_start) .AND. (jj .LE. col_end)) & - & value(obj%csr%JA(jj)) = value(obj%csr%JA(jj)) + alpha * obj%A(jj) - END DO - END DO - !! - !! - !! -ELSE - !! - value = 0.0_DFP - !! - DO ii = 1, size(irow) - DO jj = obj%csr%IA(irow(ii)), obj%csr%IA(irow(ii) + 1) - 1 - IF ((jj .GE. col_start) .AND. jj .LE. col_end) & - & value(obj%csr%JA(jj)) = obj%A(jj) - END DO - END DO - !! -END IF - !! -END PROCEDURE csrMat_getBlockRow1b - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow2 -CALL GetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & idof=idof), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getBlockRow2 - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow3 -CALL GetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc(& - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & idof=idof), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getBlockRow3 - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow4 -CALL GetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getBlockRow4 - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow5 -CALL GetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getBlockRow5 - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow6 -CALL GetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getBlockRow6 - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow7 -CALL GetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getBlockRow7 - -!---------------------------------------------------------------------------- -! getBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getBlockRow8 -CALL GetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getBlockRow8 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 deleted file mode 100644 index 59456b075..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 +++ /dev/null @@ -1,238 +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 -! - -!! authors: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_GetColMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn1 -INTEGER(I4B) :: i, j -REAL(DFP) :: alpha - !! -#ifdef DEBUG_VER - !! -IF (SIZE(value) .LT. obj%csr%nrow .OR. iColumn .GT. SIZE(obj, 2)) THEN - CALL ErrorMSG( & - & Msg="SIZE of column vector should be same as number of & - & rows in sparse matrix", & - & File="CSRMatrix_Method@getMethod.F90", & - & Routine="csrMat_getColumn1", Line=__LINE__, UnitNo=stdout) - RETURN -END IF -#endif - !! -IF (PRESENT(addContribution)) THEN - !! - alpha = INPUT(default=1.0_DFP, option=scale) - !! - DO i = 1, obj%csr%nrow - !! - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - !! - IF (obj%csr%JA(j) .EQ. iColumn) THEN - value(i) = value(i) + alpha * obj%A(j) - EXIT - END IF - !! - END DO - !! - END DO - !! -ELSE - !! - DO i = 1, obj%csr%nrow - !! - value(i) = 0.0_DFP - !! - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - IF (obj%csr%JA(j) .EQ. iColumn) THEN - value(i) = obj%A(j) - EXIT - END IF - END DO - !! - END DO - !! -END IF - !! -END PROCEDURE csrMat_getColumn1 - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn1b -INTEGER(I4B) :: i, j, k -REAL(DFP) :: alpha - !! - !! - !! -IF (PRESENT(addContribution)) THEN - !! - alpha = INPUT(default=1.0_DFP, option=scale) - !! - DO i = 1, obj%csr%nrow - DO k = 1, size(iColumn) - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - IF (obj%csr%JA(j) .EQ. iColumn(k)) THEN - value(i) = value(i) + alpha * obj%A(j) - EXIT - END IF - END DO - END DO - END DO - !! -ELSE - !! - DO i = 1, obj%csr%nrow - value(i) = 0.0_DFP - DO k = 1, size(iColumn) - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - IF (obj%csr%JA(j) .EQ. iColumn(k)) THEN - value(i) = obj%A(j) - EXIT - END IF - END DO - END DO - END DO - !! -END IF - !! -END PROCEDURE csrMat_getColumn1b - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn2 -CALL GetColumn(obj=obj, & - & iColumn=getNodeLoc(obj=obj%csr%jdof, idof=idof, nodenum=nodenum), & - & value=value, scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getColumn2 - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn3 -CALL GetColumn(obj=obj, & - & iColumn=getNodeLoc(obj=obj%csr%jdof, & - & ivar=ivar, idof=idof, nodenum=nodenum), & - & value=value, scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getColumn3 - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn4 -CALL GetColumn(obj=obj, & - & iColumn=getNodeLoc(obj=obj%csr%jdof, & - & ivar=ivar, spacecompo=spacecompo, & - & timecompo=timecompo, nodenum=nodenum), & - & value=value, scale=scale, & - & addContribution=addContribution) -END PROCEDURE csrMat_getColumn4 - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn5 - !! -CALL GetColumn(obj=obj, & - & iColumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getColumn5 - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn6 - !! -CALL GetColumn(obj=obj, & - & iColumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getColumn6 - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn7 - !! -CALL GetColumn(obj=obj, & - & iColumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo, & - & nodenum=nodenum), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getColumn7 - -!---------------------------------------------------------------------------- -! getColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getColumn8 - !! -CALL GetColumn(obj=obj, & - & iColumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo, & - & nodenum=nodenum), & - & value=value, & - & scale=scale, & - & addContribution=addContribution) - !! -END PROCEDURE csrMat_getColumn8 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 deleted file mode 100644 index d87d4cf31..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 +++ /dev/null @@ -1,522 +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 -! - -!! authors: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_GetMethods) Methods -USE CSRSparsity_Method -USE ConvertUtility -USE InputUtility -USE BaseType, ONLY: DOF_ -USE DOF_GetMethods -USE CSRMatrix_GetMethods -USE CSRMatrix_SetMethods -USE ErrorHandling -USE GlobalData, ONLY: DofToNodes, NodesToDOF, FMT_NODES, FMT_DOF, stderr -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetIA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIA -ans = GetIA(obj%csr, irow) -END PROCEDURE obj_GetIA - -!---------------------------------------------------------------------------- -! GetJA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetJA -ans = GetJA(obj%csr, indx) -END PROCEDURE obj_GetJA - -!---------------------------------------------------------------------------- -! GetSingleValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSingleValue -ans = obj%A(indx) -END PROCEDURE obj_GetSingleValue - -!---------------------------------------------------------------------------- -! GetSeveralValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSeveralValue -INTEGER(I4B) :: ii, tsize -tsize = SIZE(indx) -DO ii = 1, tsize; ans(ii) = obj%A(indx(ii)); END DO -END PROCEDURE obj_GetSeveralValue - -!---------------------------------------------------------------------------- -! GetStorageFMT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetStorageFMT -IF (i .EQ. 1) THEN - ans = obj%csr%idof%storageFMT -ELSE - ans = obj%csr%jdof%storageFMT -END IF -END PROCEDURE obj_GetStorageFMT - -!---------------------------------------------------------------------------- -! GetMatrixProp -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetMatrixProp -ans = TRIM(obj%matrixProp) -END PROCEDURE obj_GetMatrixProp - -!---------------------------------------------------------------------------- -! GetDOFPointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetDOFPointer -IF (i .EQ. 1) THEN - ans => obj%csr%idof -ELSE - ans => obj%csr%jdof -END IF -END PROCEDURE obj_GetDOFPointer - -!---------------------------------------------------------------------------- -! isSquare -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isSquare -IF (obj%csr%nrow .EQ. obj%csr%ncol) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF -END PROCEDURE obj_isSquare - -!---------------------------------------------------------------------------- -! isRectangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isRectangle -IF (obj%csr%nrow .EQ. obj%csr%ncol) THEN - ans = .FALSE. -ELSE - ans = .TRUE. -END IF -END PROCEDURE obj_isRectangle - -!---------------------------------------------------------------------------- -! GetColNumber -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetColNumber -ans = GetColNumber(obj%csr, indx) -END PROCEDURE obj_GetColNumber - -!---------------------------------------------------------------------------- -! GetColIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetColIndex -ans = GetColIndex(obj%csr, irow) -END PROCEDURE obj_GetColIndex - -!---------------------------------------------------------------------------- -! startColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_startColumn -ans = obj%csr.startColumn.irow -END PROCEDURE obj_startColumn - -!---------------------------------------------------------------------------- -! endColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_endColumn -ans = obj%csr.endColumn.irow -END PROCEDURE obj_endColumn - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get0 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj - -row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum) -col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum) -VALUE = 0.0_DFP -DO ii = 1, SIZE(row) - DO jj = 1, SIZE(col) - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & - & icolumn=col(jj)) - END DO -END DO - -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -END PROCEDURE obj_Get0 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get1 -REAL(DFP) :: m2(SIZE(VALUE, 1), SIZE(VALUE, 2)) -INTEGER(I4B) :: tdof, nns, myfmt - -CALL GetValue(obj=obj, nodenum=nodenum, VALUE=m2, nrow=nrow, ncol=ncol) - -myfmt = GetStorageFMT(obj, 1) - -IF (myfmt .EQ. storageFMT) THEN - VALUE(1:nrow, 1:ncol) = m2(1:nrow, 1:ncol) - RETURN -END IF - -tdof = .tdof. (obj%csr%idof) -nns = SIZE(nodenum) - -SELECT CASE (storageFMT) - -CASE (FMT_NODES) - - CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), & - Conversion=DOFToNodes, nns=nns, tDOF=tdof) - -CASE (FMT_DOF) - - CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), & - Conversion=NodesToDOF, nns=nns, tDOF=tdof) - -END SELECT - -END PROCEDURE obj_Get1 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get2 -INTEGER(I4B) :: j - -! VALUE = 0.0_DFP -DO j = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 - IF (obj%csr%JA(j) .EQ. icolumn) THEN - VALUE = obj%A(j) - EXIT - END IF -END DO - -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 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get3 -INTEGER(I4B) :: irow, icolumn -irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, idof=iDOF) -icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, idof=jDOF) -CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) -END PROCEDURE obj_Get3 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get4 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj - -row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar) -col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar) - -nrow = SIZE(row) -ncol = SIZE(col) - -DO ii = 1, nrow - DO jj = 1, ncol - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & - icolumn=col(jj)) - END DO -END DO - -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -END PROCEDURE obj_Get4 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get5 -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 GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) -END PROCEDURE obj_Get5 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get6 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj - -row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof) -col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof) - -nrow = SIZE(row) -ncol = SIZE(col) - -DO ii = 1, nrow - DO jj = 1, ncol - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & - icolumn=col(jj)) - END DO -END DO - -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -END PROCEDURE obj_Get6 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! 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 -CLASS(DOF_), POINTER :: dof_obj -LOGICAL(LGT) :: problem - -! 1 ivar -! 2 ispacecompo -! 3 itimecompo -! 4 jvar -! 5 jspacecompo -! 6 jtimecompo - -IF (PRESENT(ierr)) ierr = 0 - -myindx(1, 1) = Input(default=1, option=ivar1) -myindx(2, 1) = Input(default=1, option=ispacecompo1) -myindx(3, 1) = Input(default=1, option=itimecompo1) -myindx(4, 1) = Input(default=1, option=jvar1) -myindx(5, 1) = Input(default=1, option=jspacecompo1) -myindx(6, 1) = Input(default=1, option=jtimecompo1) - -myindx(1, 2) = Input(default=1, option=ivar2) -myindx(2, 2) = Input(default=1, option=ispacecompo2) -myindx(3, 2) = Input(default=1, option=itimecompo2) -myindx(4, 2) = Input(default=1, option=jvar2) -myindx(5, 2) = Input(default=1, option=jspacecompo2) -myindx(6, 2) = Input(default=1, option=jtimecompo2) - -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)) -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)) -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)) -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)) -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) - -END PROCEDURE obj_Get8 - -!---------------------------------------------------------------------------- -! CSR2CSRGetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSR2CSR_Get_Master -INTEGER(I4B) :: ii, jj -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) - END DO -END DO - -END PROCEDURE CSR2CSR_Get_Master - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 deleted file mode 100644 index f925c4771..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 +++ /dev/null @@ -1,195 +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 -! - -! authors: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_GetRowMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow1 -INTEGER(I4B) :: a, b -REAL(DFP) :: alpha - -#ifdef DEBUG_VER -IF (SIZE(VALUE) .LT. obj%csr%ncol .OR. irow .GT. SIZE(obj, 1)) THEN - CALL ErrorMSG( & - & Msg="SIZE of row vector should be same as number of col & - & in sparse matrix or irow is out of bound", & - & File="CSRMatrix_Method@GetMethod.F90", & - & Routine="obj_GetRow1", Line=__LINE__, UnitNo=stdout) - RETURN -END IF -#endif - -a = obj%csr%IA(irow) -b = obj%csr%IA(irow + 1) - 1 - -IF (PRESENT(addContribution)) THEN - alpha = INPUT(Default=1.0_DFP, Option=scale) - VALUE(obj%csr%JA(a:b)) = VALUE(obj%csr%JA(a:b)) + alpha * obj%A(a:b) -ELSE - VALUE = 0.0_DFP - VALUE(obj%csr%JA(a:b)) = obj%A(a:b) -END IF - -END PROCEDURE obj_GetRow1 - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow1b -INTEGER(I4B) :: a, b, ii -REAL(DFP) :: alpha - -IF (PRESENT(addContribution)) THEN - alpha = INPUT(Default=1.0_DFP, Option=scale) - DO ii = 1, SIZE(irow) - a = obj%csr%IA(irow(ii)) - b = obj%csr%IA(irow(ii) + 1) - 1 - VALUE(obj%csr%JA(a:b)) = VALUE(obj%csr%JA(a:b)) + alpha * obj%A(a:b) - END DO -ELSE - VALUE = 0.0_DFP - DO ii = 1, SIZE(irow) - a = obj%csr%IA(irow(ii)) - b = obj%csr%IA(irow(ii) + 1) - 1 - VALUE(obj%csr%JA(a:b)) = obj%A(a:b) - END DO -END IF -END PROCEDURE obj_GetRow1b - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow2 -CALL GetRow(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & idof=idof, & - & nodenum=nodenum), & - & VALUE=VALUE, scale=scale, addContribution=addContribution) -END PROCEDURE obj_GetRow2 - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow3 -CALL GetRow(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & ivar=ivar, & - & idof=idof, & - & nodenum=nodenum), & - & VALUE=VALUE, scale=scale, addContribution=addContribution) -END PROCEDURE obj_GetRow3 - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow4 -CALL GetRow(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & ivar=ivar, & - & spacecompo=spacecompo,& - & timecompo=timecompo, & - & nodenum=nodenum), & - & VALUE=VALUE, scale=scale, & - & addContribution=addContribution) -END PROCEDURE obj_GetRow4 - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow5 -CALL GetRow(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & ivar=ivar, & - & spacecompo=spacecompo,& - & timecompo=timecompo, & - & nodenum=nodenum), & - & VALUE=VALUE, scale=scale, & - & addContribution=addContribution) -END PROCEDURE obj_GetRow5 - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow6 -CALL GetRow(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & ivar=ivar, & - & spacecompo=spacecompo,& - & timecompo=timecompo, & - & nodenum=nodenum), & - & VALUE=VALUE, scale=scale, & - & addContribution=addContribution) -END PROCEDURE obj_GetRow6 - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow7 -CALL GetRow(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & ivar=ivar, & - & spacecompo=spacecompo,& - & timecompo=timecompo, & - & nodenum=nodenum), & - & VALUE=VALUE, scale=scale, & - & addContribution=addContribution) -END PROCEDURE obj_GetRow7 - -!---------------------------------------------------------------------------- -! GetRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetRow8 -CALL GetRow(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & ivar=ivar, & - & spacecompo=spacecompo,& - & timecompo=timecompo, & - & nodenum=nodenum), & - & VALUE=VALUE, scale=scale, & - & addContribution=addContribution) -END PROCEDURE obj_GetRow8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 deleted file mode 100644 index 57773f75f..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 +++ /dev/null @@ -1,124 +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(CSRMatrix_GetSubMatrixMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetSubMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSubMatrix1 -LOGICAL(LGT), ALLOCATABLE :: selectCol(:) -INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), & -& icol, jj -REAL(DFP) :: aval -TYPE(String) :: astr - -nnz = GetNNZ(obj=obj) -nrow = SIZE(obj, 1) -ncol = SIZE(obj, 2) - -CALL Reallocate(selectCol, ncol) - -selectCol = .FALSE. - -nn = SIZE(cols) -DO ii = 1, nn - jj = cols(ii) - IF (jj .GT. ncol) THEN - astr = "Error cols( "//tostring(ii)//") is greater than "// & - & "ncol = "//tostring(ncol) - CALL ErrorMSG( & - & astr%chars(), & - & "CSRMatrix_GetSubMatrixMethods@Methods.F90", & - & "obj_GetSubMatrix1()", & - & __LINE__, stderr) - STOP - END IF - selectCol(jj) = .TRUE. -END DO - -submat_nnz = 0 -DO irow = 1, nrow - colIndx = GetColIndex(obj=obj, irow=irow) - DO ii = colIndx(1), colIndx(2) - icol = GetColNumber(obj, ii) - IF (selectCol(icol)) submat_nnz = submat_nnz + 1 - END DO -END DO - -CALL Reallocate(subIndices, submat_nnz) -CALL Initiate(obj=submat, ncol=ncol, nrow=nrow, nnz=submat_nnz) - -submat_nnz = 1 -CALL SetIA(obj=submat, irow=1, VALUE=submat_nnz) - -DO irow = 1, nrow - colIndx = GetColIndex(obj=obj, irow=irow) - jj = 0 - DO ii = colIndx(1), colIndx(2) - icol = 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) - 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) - -END PROCEDURE obj_GetSubMatrix1 - -!---------------------------------------------------------------------------- -! GetSubMatrix1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSubMatrix2 -LOGICAL(LGT) :: isok - -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 - -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) - -END PROCEDURE obj_GetSubMatrix2 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 deleted file mode 100644 index ab770b532..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 +++ /dev/null @@ -1,486 +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: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_ILUMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getILUT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getILUT1 -INTEGER(I4B) :: nnz, s(2), ierr, IWK -INTEGER(I4B), ALLOCATABLE :: JW(:) -REAL(DFP), ALLOCATABLE :: W(:) - -s = SHAPE(obj) -nnz = getNNZ(obj) -ALLOCATE (JW(2 * s(1)), W(s(1) + 1)) -CALL Reallocate(JU, s(1)) -IWK = 2 * (lfil + 1) * s(1) -! -CALL Reallocate(ALU, IWK, JLU, IWK) -! -CALL ILUT(s(1), obj%A, obj%csr%JA, obj%csr%IA, lfil, droptol, & - & ALU, JLU, JU, IWK, W, JW, ierr) -! -SELECT CASE (ierr) -CASE (1:) - CALL ErrorMSG( & - & "zero pivot encountered at step number = "//tostring(ierr), & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUT1()", & - & __LINE__, stderr) - STOP -CASE (-1) - CALL ErrorMSG( & - & "Input matrix may be wrong. (The elimination process has generated a & - & row in L or U whose length is .gt. n.)", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUT1()", & - & __LINE__, stderr) - STOP -CASE (-2) - CALL ErrorMSG( & - & "The matrix L overflows the array ALU", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUT1()", & - & __LINE__, stderr) - STOP -CASE (-3) - CALL ErrorMSG( & - & "The matrix U overflows the array ALU", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUT1()", & - & __LINE__, stderr) - STOP -CASE (-4) - CALL ErrorMSG( & - & "Illegal value for lfil.", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUT1()", & - & __LINE__, stderr) - STOP -CASE (-5) - CALL ErrorMSG( & - & "zero row encountered", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUT1()", & - & __LINE__, stderr) - STOP -END SELECT -DEALLOCATE (JW, W) -END PROCEDURE csrMat_getILUT1 - -!---------------------------------------------------------------------------- -! getILUT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getILUT2 -REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) -INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) -INTEGER(I4B) :: s(2), ii, nnz - -CALL csrMat_getILUT1(obj=obj, ALU=ALU, JLU=JLU, JU=JU, lfil=lfil, & - & droptol=droptol) -s = SHAPE(obj) -DO ii = 1, s(1) - IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE - ALU(ii) = 1.0 / ALU(ii) -END DO -nnz = JLU(s(1) + 1) -CALL Reallocate(WK, s(1), IWK, s(1) + 1) -CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) -CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) -nnz = IA(s(1) + 1) - 1 -CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) -END PROCEDURE csrMat_getILUT2 - -!---------------------------------------------------------------------------- -! getILUTP -!---------------------------------------------------------------------------- - -! subroutine ilutp(n,a,ja,ia,lfil,droptol,permtol,mbloc,alu, -! jlu,ju,iwk,w,jw,iperm,ierr) - -MODULE PROCEDURE csrMat_getILUTP1 -INTEGER(I4B) :: nnz, s(2), ierr, IWK -! INTEGER( I4B ):: k -INTEGER(I4B), ALLOCATABLE :: JW(:) -REAL(DFP), ALLOCATABLE :: W(:) - -s = SHAPE(obj) -nnz = getNNZ(obj) -ALLOCATE (JW(2 * s(1)), W(s(1))) -CALL Reallocate(JU, s(1), IPERM, 2 * s(1)) -IWK = nnz + INT(nnz / 10, kind=I4B) -! -DO - CALL Reallocate(ALU, IWK, JLU, IWK) - CALL ILUTP(s(1), obj%A, obj%csr%JA, obj%csr%IA, lfil, droptol, & - & permtol, mbloc, ALU, JLU, JU, IWK, W, JW, IPERM, ierr) - IF (ierr .EQ. -2 .OR. ierr .EQ. -3) THEN - IWK = IWK + INT(2 * IWK / 10, kind=I4B) - ELSE - EXIT - END IF -END DO -! -SELECT CASE (ierr) -CASE (-1) - CALL ErrorMSG( & - & "Input matrix may be wrong. (The elimination process has generated a & - & row in L or U whose length is .gt. n.)", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUTP1()", & - & __LINE__, stderr) - STOP -CASE (-2) - CALL ErrorMSG( & - & "The matrix L overflows the array AL", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUTP1()", & - & __LINE__, stderr) - STOP -CASE (-3) - CALL ErrorMSG( & - & "The matrix U overflows the array ALU", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUTP1()", & - & __LINE__, stderr) - STOP -CASE (-4) - CALL ErrorMSG( & - & "Illegal value for lfil.", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUTP1()", & - & __LINE__, stderr) - STOP -CASE (-5) - CALL ErrorMSG( & - & "zero row encountered", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUTP1()", & - & __LINE__, stderr) - STOP -END SELECT -! -! DO k=obj%csr%IA(1), obj%csr%IA(s(1)+1)-1 -! obj%csr%JA(k) = IPERM(obj%csr%JA(k)) -! END DO -! -DEALLOCATE (JW, W) -END PROCEDURE csrMat_getILUTP1 - -!---------------------------------------------------------------------------- -! getILUTP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getILUTP2 -REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) -INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) -INTEGER(I4B) :: s(2), ii, nnz - -CALL csrMat_getILUTP1(obj, ALU, JLU, JU, lfil, droptol, permtol, mbloc, & - & IPERM) -s = SHAPE(obj) -DO ii = 1, s(1) - IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE - ALU(ii) = 1.0 / ALU(ii) -END DO -nnz = JLU(s(1) + 1) -CALL Reallocate(WK, s(1), IWK, s(1) + 1) -CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) -CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) -nnz = IA(s(1) + 1) - 1 -CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) -END PROCEDURE csrMat_getILUTP2 - -!---------------------------------------------------------------------------- -! getILUD -!---------------------------------------------------------------------------- - -!> subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr) - -MODULE PROCEDURE csrMat_getILUD1 -INTEGER(I4B) :: nnz, s(2), ierr, IWK, k, iter -INTEGER(I4B), ALLOCATABLE :: JW(:) -REAL(DFP), ALLOCATABLE :: W(:) -INTEGER(I4B), PARAMETER :: maxIter = 5 -! -s = SHAPE(obj) -nnz = getNNZ(obj) -ALLOCATE (JW(2 * s(1)), W(2 * s(1))) -CALL Reallocate(JU, s(1)) -IWK = nnz + INT(nnz / 10, kind=I4B) -! -DO iter = 1, maxIter - CALL Reallocate(ALU, IWK, JLU, IWK) - CALL ILUD(s(1), obj%A, obj%csr%JA, obj%csr%IA, alpha, droptol, & - & ALU, JLU, JU, IWK, W, JW, ierr) - IF (ierr .EQ. -2) THEN - IWK = IWK + INT(IWK / 10, kind=I4B) - ELSE - EXIT - END IF -END DO -! -SELECT CASE (ierr) -CASE (1:) - CALL ErrorMSG( & - & "zero pivot encountered at step number = "//tostring(ierr), & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUD1()", & - & __LINE__, stderr) - STOP -CASE (-1) - CALL ErrorMSG( & - & "Input matrix may be wrong. (The elimination process has generated a & - & row in L or U whose length is .gt. n.)", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUD1()", & - & __LINE__, stderr) - STOP -CASE (-2) - CALL ErrorMSG( & - & "The matrix L overflows the array AL", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUD1()", & - & __LINE__, stderr) - STOP -CASE (-3) - CALL ErrorMSG( & - & "zero row encountered", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUD1()", & - & __LINE__, stderr) - STOP -END SELECT -DEALLOCATE (JW, W) -END PROCEDURE csrMat_getILUD1 - -!---------------------------------------------------------------------------- -! getILUD -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getILUD2 -REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) -INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) -INTEGER(I4B) :: s(2), ii, nnz - -CALL csrMat_getILUD1(obj, ALU, JLU, JU, alpha, droptol) -s = SHAPE(obj) -DO ii = 1, s(1) - IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE - ALU(ii) = 1.0 / ALU(ii) -END DO -nnz = JLU(s(1) + 1) -CALL Reallocate(WK, s(1), IWK, s(1) + 1) -CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) -CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) -nnz = IA(s(1) + 1) - 1 -CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) -END PROCEDURE csrMat_getILUD2 - -!---------------------------------------------------------------------------- -! getILUDP -!---------------------------------------------------------------------------- - -!> subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr) - -MODULE PROCEDURE csrMat_getILUDP1 -INTEGER(I4B) :: nnz, s(2), ierr, IWK, k -INTEGER(I4B), ALLOCATABLE :: JW(:) -REAL(DFP), ALLOCATABLE :: W(:) -! -s = SHAPE(obj) -nnz = getNNZ(obj) -ALLOCATE (JW(2 * s(1)), W(2 * s(1))) -CALL Reallocate(JU, s(1), IPERM, 2 * s(1)) -IWK = 1.1 * nnz -! -DO - CALL Reallocate(ALU, IWK, JLU, IWK) - CALL ILUDP(s(1), obj%A, obj%csr%JA, obj%csr%IA, alpha, droptol, permtol,& - & mbloc, ALU, JLU, JU, IWK, W, JW, IPERM, ierr) - IF (ierr .EQ. -2 .OR. ierr .EQ. -3) THEN - IWK = 1.2 * IWK - ELSE - EXIT - END IF -END DO -! -SELECT CASE (ierr) -CASE (-1) - CALL ErrorMSG( & - & "Input matrix may be wrong. (The elimination process has generated a & - & row in L or U whose length is .gt. n.)", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUDP1()", & - & __LINE__, stderr) - STOP -CASE (-2) - CALL ErrorMSG( & - & "The L/U matrix overflows the arrays ALU,JLU", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUDP1()", & - & __LINE__, stderr) - STOP -CASE (-3) - CALL ErrorMSG( & - & "zero row encountered", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUDP1()", & - & __LINE__, stderr) - STOP -END SELECT -DEALLOCATE (JW, W) -END PROCEDURE csrMat_getILUDP1 - -!---------------------------------------------------------------------------- -! getILUDP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getILUDP2 -REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) -INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) -INTEGER(I4B) :: s(2), ii, nnz - -CALL csrMat_getILUDP1(obj, ALU, JLU, JU, alpha, droptol, permtol, mbloc, & - & IPERM) -s = SHAPE(obj) -DO ii = 1, s(1) - IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE - ALU(ii) = 1.0 / ALU(ii) -END DO -nnz = JLU(s(1) + 1) -CALL Reallocate(WK, s(1), IWK, s(1) + 1) -CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) -CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) -nnz = IA(s(1) + 1) - 1 -CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) -END PROCEDURE csrMat_getILUDP2 - -!---------------------------------------------------------------------------- -! getILUDP -!---------------------------------------------------------------------------- - -!> subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr) -! iluk(n,a,ja,ia,lfil,alu,jlu,ju,levs,iwk,w,jw,ierr) - -MODULE PROCEDURE csrMat_getILUK1 -INTEGER(I4B) :: nnz, s(2), ierr, IWK, k -INTEGER(I4B), ALLOCATABLE :: JW(:) -REAL(DFP), ALLOCATABLE :: W(:) -! -s = SHAPE(obj) -nnz = getNNZ(obj) -ALLOCATE (JW(3 * s(1)), W(s(1))) -CALL Reallocate(JU, s(1)) -IWK = 1.1 * nnz -! -DO - CALL Reallocate(ALU, IWK, JLU, IWK, LEVS, IWK) - CALL ILUK(s(1), obj%A, obj%csr%JA, obj%csr%IA, lfil, ALU, JLU, JU, LEVS,& - & IWK, W, JW, ierr) - IF (ierr .EQ. -2 .OR. ierr .EQ. -3) THEN - IWK = 1.2 * IWK - ELSE - EXIT - END IF -END DO -! -SELECT CASE (ierr) -CASE (-1) - CALL ErrorMSG( & - & "Input matrix may be wrong. (The elimination process has generated a & - & row in L or U whose length is .gt. n.)", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUK1()", & - & __LINE__, stderr) - STOP -CASE (-2) - CALL ErrorMSG( & - & "The matrix L overflows the array AL ", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUK1()", & - & __LINE__, stderr) - STOP -CASE (-3) - CALL ErrorMSG( & - & "The matrix U overflows the array ALU", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUK1()", & - & __LINE__, stderr) - STOP -CASE (-4) - CALL ErrorMSG( & - & "Illegal value for lfil.", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUK1()", & - & __LINE__, stderr) - STOP -CASE (-5) - CALL ErrorMSG( & - & "zero row encountered", & - & "CSRMatrix_Method@ILUMethods.F90", & - & "csrMat_getILUK1()", & - & __LINE__, stderr) - STOP -END SELECT -DEALLOCATE (JW, W) -END PROCEDURE csrMat_getILUK1 - -!---------------------------------------------------------------------------- -! getILUK -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_getILUK2 -REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) -INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) -INTEGER(I4B) :: s(2), ii, nnz - -CALL csrMat_getILUK1(obj, ALU, JLU, JU, lfil, LEVS) -s = SHAPE(obj) -DO ii = 1, s(1) - IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE - ALU(ii) = 1.0 / ALU(ii) -END DO -nnz = JLU(s(1) + 1) -CALL Reallocate(WK, s(1), IWK, s(1) + 1) -CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) -CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) -nnz = IA(s(1) + 1) - 1 -CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) -END PROCEDURE csrMat_getILUK2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 deleted file mode 100644 index 5d7005e3a..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 +++ /dev/null @@ -1,353 +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: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_IOMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Display -INTEGER(I4B) :: I -I = INPUT(Option=UnitNo, Default=stdout) -CALL Display(msg, unitNo=I) -CALL Display(obj%csrOwnership, "CSR OWNERSHIP : ") -CALL Display(obj%tDimension, "TOTAL DIMENSION : ") -CALL Display(obj%MatrixProp, "MATRIX PROPERTY : ") -CALL Display(obj=obj%csr, msg="CSR SPARSITY : ", unitNo=I) -IF (ALLOCATED(obj%A)) THEN - CALL DUMP(1, obj%csr%nrow, .TRUE., obj%A, obj%csr%JA, obj%csr%IA, I) -ELSE - CALL DUMP(1, obj%csr%nrow, .FALSE., obj%A, obj%csr%JA, obj%csr%IA, I) -END IF -END PROCEDURE obj_Display - -!---------------------------------------------------------------------------- -! Spy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SPY -SELECT CASE (TRIM(ext)) -CASE ("gp", ".gp", ".GP", "GP") - CALL obj_SPY_gnuplot(obj, filename) -CASE ("pdf", ".pdf") - CALL obj_SPY_PLPLOT(obj, filename, ext, "pdf") -CASE ("svg", ".svg") - CALL obj_SPY_PLPLOT(obj, filename, ext, "svg") -CASE ("eps", ".eps") - CALL obj_SPY_PLPLOT(obj, filename, ext, "epscairo") -CASE ("png", ".png") - CALL obj_SPY_PLPLOT(obj, filename, ext, "pngcairo") -CASE ("ps", ".ps") - CALL obj_SPY_PLPLOT(obj, filename, ext, "ps") -CASE DEFAULT -END SELECT -END PROCEDURE obj_SPY - -!---------------------------------------------------------------------------- -! obj_SPY_PLPLOT -!---------------------------------------------------------------------------- - -SUBROUTINE obj_SPY_PLPLOT(obj, filename, ext, driver) - TYPE(CSRMatrix_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: filename - CHARACTER(*), INTENT(IN) :: ext - CHARACTER(*), INTENT(IN) :: driver -#ifdef USE_PLPLOT - !> Internal - REAL(DFP), ALLOCATABLE :: X(:), Y(:) !, A( : )! - REAL(DFP) :: xmin, xmax, ymin, ymax - INTEGER(I4B) :: ii, jj, kk - !> main - CALL Reallocate(X, obj%csr%nnz, Y, obj%csr%nnz) - kk = 0 - DO ii = 1, obj%csr%nrow - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - kk = kk + 1 - X(kk) = obj%csr%JA(jj) - Y(kk) = ii - ! A(kk) = obj%A(jj) - END DO - END DO - ! - xmin = 1 - obj%csr%ncol * 0.1 - xmax = obj%csr%ncol + obj%csr%ncol * 0.1 - ymin = obj%csr%nrow + obj%csr%nrow * 0.1 - ymax = 1 - obj%csr%nrow * 0.1 - ! - CALL PLSDEV(TRIM(driver)) - IF (ext(1:1) .EQ. ".") THEN - CALL PLSFNAM(TRIM(filename)//TRIM(ext)) - ELSE - CALL PLSFNAM(TRIM(filename)//"."//TRIM(ext)) - END IF - !> - CALL PLSCOLBG(255, 255, 255) - CALL PLINIT - CALL PLSCOL0(0, 0, 0, 0) - CALL PLCOL0(0) - CALL PLENV(xmin, xmax, ymin, ymax, 1, -1) - ! CALL PLBOX('bcgnst', 0.0_DFP, 2, 'bcgnstv', 0.0_DFP, 2) - ! I am removing grids, if you want them then please activate - ! above line of code, and comment the following line. - ! I am deactivating the numerical labels - ! I am deactivating the subticks - - CALL PLBOX('bcx', 0.0_DFP, 2, 'bcx', 0.0_DFP, 2) - CALL PLLAB("COLUMN", "ROW", "STRUCTURE OF SPARSE MATRIX") - CALL PLSSYM(0.0_DFP, 0.2_DFP) - CALL PLCOL0(9) - CALL PLPOIN(X, Y, 3) - CALL PLEND - IF (ALLOCATED(X)) DEALLOCATE (X) - IF (ALLOCATED(Y)) DEALLOCATE (Y) - ! IF( ALLOCATED(A) ) DEALLOCATE(A) -#endif -END SUBROUTINE obj_SPY_PLPLOT - -!---------------------------------------------------------------------------- -! obj_SPY_gnuplot -!---------------------------------------------------------------------------- - -SUBROUTINE obj_SPY_gnuplot(obj, filename) - TYPE(CSRMatrix_), INTENT(IN) :: obj - CHARACTER(*), INTENT(IN) :: filename - ! internal variable - INTEGER(I4B) :: i, nrow, j, m, ncol, nnz, unitno, a, b, IOSTAT - CHARACTER(256) :: scripFile - LOGICAL(LGT) :: isOpen - !> main - OPEN (FILE=TRIM(filename)//".txt", NEWUNIT=unitno, STATUS="REPLACE", & - & ACTION="WRITE", IOSTAT=IOSTAT) - !> check - IF (IOSTAT .NE. 0) THEN - CALL ErrorMSG(Msg="Error opening "//TRIM(filename)//".txt file", & - & File=__FILE__, Routine="obj_SPY_gnuplot()", & - & LINE=__LINE__) - STOP - END IF - nrow = obj%csr%nrow; ncol = obj%csr%ncol; nnz = obj%csr%nnz - CALL Display("#m = "//TOSTRING(nrow), unitNo=unitNo) - CALL Display("#n = "//TOSTRING(ncol), unitNo=unitNo) - CALL Display("#nnz = "//TOSTRING(nnz), unitNo=unitNo) - !> write data in txt file - !> columns are in x direction - !> rows are in y direction - DO i = 1, nrow - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - WRITE (unitNo, '(I6, 2X, I6, 2X, G14.6)') & - & obj%csr%JA(j), i, obj%A(j) - END DO - END DO - CLOSE (unitno) - !> open gnuplot script file - OPEN (FILE=TRIM(filename)//".gp", NEWUNIT=unitno, STATUS="REPLACE", & - & ACTION="WRITE", IOSTAT=IOSTAT) - !> check - IF (IOSTAT .NE. 0) THEN - CALL ErrorMSG(Msg="Error opening "//TRIM(filename)//".gp file", & - & File=__FILE__, Routine="obj_SPY_gnuplot()", & - & LINE=__LINE__) - STOP - END IF - CALL Display('# Gnuplot script file', unitNo=unitNo) - CALL Display('# Generated by :: EASIFEM', unitNo=unitNo) - CALL Display( & - & "set terminal postscript eps enhance color font 'Helvetica,10'", & - & unitNo=unitNo) - - CALL Display( & - & "set output '"//TRIM(filename)//".eps'", & - & unitNo=unitNo) - - CALL Display( & - & "set xlabel 'Col(J)'", & - & unitNo=unitNo) - - CALL Display( & - & "set ylabel 'Row(I)'", & - & unitNo=unitNo) - - CALL Display( & - & "set size ratio -1", & - & unitNo=unitNo) - - CALL Display( & - & "set title 'NNZ = "//TRIM(INT2STR(nnz))//"'", & - & unitNo=unitNo) - - a = 1 - ncol * 0.1 - b = ncol + ncol * 0.1 - - CALL Display( & - & 'set xrange['//TOSTRING(a)//':' & - & //TOSTRING(b)//"]", & - & unitNo=unitNo) - - a = 1 - nrow * 0.1 - b = nrow + nrow * 0.1 - - CALL Display( & - & 'set yrange['//TOSTRING(b)//':' & - & //TOSTRING(a)//"]", & - & unitNo=unitNo) - - WRITE (unitNo, '(A)') 'set mxtics 5' - WRITE (unitNo, '(A)') 'set mytics 5' - WRITE (unitNo, '(A)') 'set grid xtics ytics mxtics mytics' - WRITE (unitNo, "(A)") & - & "plot"//"'"//TRIM(filename)//".txt"//"' with points pt 7 ps 1.0" - CLOSE (unitno) -END SUBROUTINE obj_SPY_gnuplot - -!---------------------------------------------------------------------------- -! IMPORT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_IMPORT -INTEGER(I4B) :: iostat, unitno, rows, cols, nnz, ii -INTEGER(I4B), ALLOCATABLE :: indx(:), jndx(:), IA(:), JA(:) -REAL(DFP), ALLOCATABLE :: A(:), rval(:) -TYPE(String) :: aline -CHARACTER(1024) :: iomsg -CHARACTER(50) :: rep, field, symm - -! Open file -OPEN (FILE=filename, NEWUNIT=unitno, STATUS="OLD", ACTION="READ", & - & IOSTAT=iostat, iomsg=iomsg) - -IF (iostat .NE. 0) THEN - CALL ErrorMSG(& - & msg="Error in opening file, following msg = "//TRIM(iomsg), & - & file=__FILE__, & - & routine="obj_IMPORT()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -CALL MMRead(unitno=unitno, rep=rep, field=field, symm=symm, rows=rows, & - & cols=cols, nnz=nnz, indx=indx, jndx=jndx, rval=rval) - -CALL toUpperCase(symm) -IF (symm .EQ. "SYMMETRIC") THEN - symm = "SYM" -ELSEIF (symm .EQ. "SKEW-SYMMETRIC") THEN - symm = "SKEWSYM" -ELSE - symm = "UNSYM" -END IF - -ALLOCATE (IA(rows + 1), JA(nnz), A(nnz)) - -! Call COOCSR from sparsekit -CALL COOCSR(rows, nnz, rval, indx, jndx, A, JA, IA) -CALL Initiate(obj=obj, A=A, IA=IA, JA=JA, MatrixProp=symm) - -CLOSE (unitNo) -DEALLOCATE (indx, jndx, rval, IA, JA, A) -END PROCEDURE obj_IMPORT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE deprecated_obj_IMPORT -INTEGER(I4B) :: iostat, unitNo, nrow, ncol, nnz, ii -INTEGER(I4B), ALLOCATABLE :: ROW(:), COL(:), IA(:), JA(:) -REAL(DFP), ALLOCATABLE :: A(:), X(:) -TYPE(String) :: aline -CHARACTER(1024) :: iomsg -! -OPEN (FILE=filename, NEWUNIT=unitNo, STATUS="OLD", ACTION="READ", & - & IOSTAT=iostat, iomsg=iomsg) -! -IF (iostat .NE. 0) THEN - CALL ErrorMSG(& - & msg="Error in opening file, following msg = "//TRIM(iomsg), & - & file=__FILE__, & - & routine="obj_IMPORT()", & - & line=__LINE__, & - & unitno=stderr) -END IF -! -CALL aline%read_line(unit=unitNo, iostat=iostat, iomsg=iomsg) -! -IF (iostat .NE. 0) THEN - CALL ErrorMSG(& - & msg="Error while calling read_line method from String Class, & - & following msg is returned "//TRIM(iomsg), & - & file=__FILE__, & - & routine="obj_IMPORT()", & - & line=__LINE__, & - & unitno=stderr) -END IF -! -iostat = 0 -READ (unitNo, *, iostat=iostat, iomsg=iomsg) nrow, ncol, nnz -! -IF (iostat .NE. 0) THEN - CALL ErrorMSG(& - & msg="Error while reading nrow, ncol, nnz from the given file, & - & following msg is returned "//TRIM(iomsg), & - & file=__FILE__, & - & routine="obj_IMPORT()", & - & line=__LINE__, & - & unitno=stderr) -END IF -! -ALLOCATE (ROW(nnz), COL(nnz), X(nnz)) -! -iostat = 0 -DO ii = 1, nnz - READ (unitNo, *, iostat=iostat, iomsg=iomsg) ROW(ii), COL(ii), X(ii) - IF (iostat .NE. 0) EXIT -END DO -! -IF (iostat .NE. 0) THEN - CALL ErrorMSG(& - & msg="Error while reading row(ii), col(ii), x(ii) from the given file, & - & following msg is returned "//TRIM(iomsg), & - & file=__FILE__, & - & routine="obj_IMPORT()", & - & line=__LINE__, & - & unitno=stderr) -END IF -! -ALLOCATE (IA(nrow + 1), JA(nnz), A(nnz)) -! -! Call COOCSR from sparsekit -! -CALL COOCSR(nrow, nnz, X, ROW, COL, A, JA, IA) -! -CALL Initiate(obj=obj, A=A, IA=IA, JA=JA) -! -DEALLOCATE (ROW, COL, X, IA, JA, A) -CLOSE (unitNo) -END PROCEDURE deprecated_obj_IMPORT - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 deleted file mode 100644 index 8b422c0a5..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 +++ /dev/null @@ -1,51 +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: 14 July 2021 -! summary: This submodule contains methods fors solving LU x = y - -SUBMODULE(CSRMatrix_LUSolveMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! LUSOLVE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_LUSOLVE -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - CALL LUTSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) - ELSE - CALL LUSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) - END IF -ELSE - CALL LUSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) -END IF -END PROCEDURE csrMat_LUSOLVE - -!---------------------------------------------------------------------------- -! LUTSOLVE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_LUTSOLVE -CALL LUTSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) -END PROCEDURE csrMat_LUTSOLVE - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 deleted file mode 100644 index 7212d58aa..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 +++ /dev/null @@ -1,607 +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 _x1 IPAR(8) -#define _x2 IPAR(8) + n - 1 -#define _y1 IPAR(9) -#define _y2 IPAR(9) + n - 1 - -SUBMODULE(CSRMatrix_LinSolveMethods) Methods -! USE BaseMethod -USE GlobalData -USE Display_Method -USE InputUtility -USE CSRMatrix_MatVecMethods -USE CSRMatrix_ConstructorMethods -USE ReallocateUtility -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetLinSolverCodeFromName -SELECT CASE (TRIM(name)) -CASE ("SUPERLU") !1 - ans = LIS_SUPERLU -CASE ("CG") !1 - ans = LIS_CG -CASE ("BICG") !2 - ans = LIS_BICG -CASE ("CGS") !3 - ans = LIS_CGS -CASE ("BICGSTAB") !4 - ans = LIS_BICGSTAB -CASE ("BICGSTABL") !5 - ans = LIS_BICGSTABL -CASE ("GPBICG") !6 - ans = LIS_GPBICG -CASE ("TFQMR") !7 - ans = LIS_TFQMR -CASE ("OMN", "FOM", "ORTHOMIN") !8 - ans = LIS_OMN -CASE ("GMRES", "GMR") !9 - ans = LIS_GMRES -CASE ("JACOBI") !10 - ans = LIS_JACOBI -CASE ("GS") !11 - ans = LIS_GS -CASE ("SOR") !12 - ans = LIS_SOR -CASE ("BICGSAFE") !13 - ans = LIS_BICGSAFE -CASE ("CR") !14 - ans = LIS_CR -CASE ("BICR") !15 - ans = LIS_BICR -CASE ("CRS") !16 - ans = LIS_CRS -CASE ("BICRSTAB") !17 - ans = LIS_BICRSTAB -CASE ("GPBICR") !18 - ans = LIS_GPBICR -CASE ("BICRSAFE") !19 - ans = LIS_BICRSAFE -CASE ("FGMRES") !20 - ans = LIS_FGMRES -CASE ("IDRS") !21 - ans = LIS_IDRS -CASE ("IDR1") !22 - ans = LIS_IDR1 -CASE ("MINRES") !23 - ans = LIS_MINRES -CASE ("COCG") !24 - ans = LIS_COCG -CASE ("COCR") !25 - ans = LIS_COCR -CASE ("CGNR", "CGN") !26 - ans = LIS_CGNR -CASE ("DBICG") !27 - ans = LIS_DBICG -CASE ("DQGMRES") !28 - ans = LIS_DQGMRES -END SELECT -END PROCEDURE GetLinSolverCodeFromName - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetLinSolverNameFromCode -SELECT CASE (name) -CASE (LIS_SUPERLU) - ans = "SUPERLU" !1 -CASE (LIS_CG) - ans = "CG" !1 -CASE (LIS_BICG) - ans = "BICG" !2 -CASE (LIS_CGS) - ans = "CGS" !3 -CASE (LIS_BICGSTAB) - ans = "BICGSTAB" !4 -CASE (LIS_BICGSTABL) - ans = "BICGSTABL" !5 -CASE (LIS_GPBICG) - ans = "GPBICG" !6 -CASE (LIS_TFQMR) - ans = "TFQMR" !7 -CASE (LIS_OMN) - ans = "ORTHOMIN" !8 -CASE (LIS_GMRES) - ans = "GMRES" !9 -CASE (LIS_JACOBI) - ans = "JACOBI" !10 -CASE (LIS_GS) - ans = "GS" !11 -CASE (LIS_SOR) - ans = "SOR" !12 -CASE (LIS_BICGSAFE) - ans = "BICGSAFE" !13 -CASE (LIS_CR) - ans = "CR" !14 -CASE (LIS_BICR) - ans = "BICR" !15 -CASE (LIS_CRS) - ans = "CRS" !16 -CASE (LIS_BICRSTAB) - ans = "BICRSTAB" !17 -CASE (LIS_GPBICR) - ans = "GPBICR" !18 -CASE (LIS_BICRSAFE) - ans = "BICRSAFE" !19 -CASE (LIS_FGMRES) - ans = "FGMRES" !20 -CASE (LIS_IDRS) - ans = "IDRS" !21 -CASE (LIS_IDR1) - ans = "IDR1" !22 -CASE (LIS_MINRES) - ans = "MINRES" !23 -CASE (LIS_COCG) - ans = "COCG" !24 -CASE (LIS_COCR) - ans = "COCR" !25 -CASE (LIS_CGNR) - ans = "CGNR" !26 -CASE (LIS_DBICG) - ans = "DBICG" !27 -CASE (LIS_DQGMRES) - ans = "DQGMRES" !28 -END SELECT -END PROCEDURE GetLinSolverNameFromCode - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE SetPreconditionOption(IPAR, PRECOND_TYPE) - INTEGER(I4B), INTENT(INOUT) :: IPAR(:) - INTEGER(I4B), INTENT(IN) :: PRECOND_TYPE - - SELECT CASE (PRECOND_TYPE) - CASE (NO_PRECONDITION) - IPAR(2) = 0 - CASE (LEFT_PRECONDITION) - IPAR(2) = 1 - CASE (RIGHT_PRECONDITION) - IPAR(2) = 2 - CASE (LEFT_RIGHT_PRECONDITION) - IPAR(2) = 3 - END SELECT -END SUBROUTINE SetPreconditionOption - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE SetKrylovSubspaceSize(IPAR, m) - INTEGER(I4B), INTENT(INOUT) :: IPAR(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: m - IPAR(5) = Input(default=15, option=m) -END SUBROUTINE SetKrylovSubspaceSize - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE SetMaxIter(IPAR, maxIter) - INTEGER(I4B), INTENT(INOUT) :: IPAR(:) - INTEGER(I4B), INTENT(IN) :: maxIter - IPAR(6) = maxIter -END SUBROUTINE SetMaxIter - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE SetConvergenceType(IPAR, convergenceIn, convergenceType, & - & relativeToRHS) - INTEGER(I4B), INTENT(INOUT) :: IPAR(:) - INTEGER(I4B), INTENT(IN) :: convergenceIn - INTEGER(I4B), INTENT(IN) :: convergenceType - LOGICAL(LGT), INTENT(IN) :: relativeToRHS - - IPAR(3) = 1 - SELECT CASE (convergenceType) - - CASE (absoluteConvergence) - IF (convergenceIn .EQ. convergenceInSol) THEN - IPAR(3) = -1 - ELSE IF (convergenceIn .EQ. convergenceInRes) THEN - IPAR(3) = 1 - END IF - - CASE (relativeConvergence) - - IF (convergenceIn .EQ. convergenceInSol) THEN - IF (relativeToRHS) THEN - IPAR(3) = -2 - ELSE - IPAR(3) = -1 - END IF - - ELSE IF (convergenceIn .EQ. convergenceInRes) THEN - IF (relativeToRHS) THEN - IPAR(3) = 2 - ELSE - IPAR(3) = 1 - END IF - END IF - - END SELECT -END SUBROUTINE SetConvergenceType - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE PERFORM_TASK(Amat, y, x, ierr) - ! intent of dummy variables - CLASS(CSRMatrix_), INTENT(INOUT) :: Amat - REAL(DFP), INTENT(INOUT) :: y(:) - REAL(DFP), INTENT(IN) :: x(:) - INTEGER(I4B), INTENT(IN) :: ierr - - SELECT CASE (ierr) - CASE (1) - ! MatVec, y=Ax - CALL Matvec(obj=Amat, y=y, x=x, isTranspose=.FALSE.) - CASE (2) - ! Transposed MatVec - CALL Matvec(obj=Amat, y=y, x=x, isTranspose=.TRUE.) - CASE (3, 5) - ! LEFT/RIGHT PRECONDITIONER SOLVER - ! The preconditioners are inside the Amat - ! CALL Amat%ILUSOLVE(sol=y, rhs=x, isTranspose=.FALSE.) - CALL Display("File = "//__FILE__) - CALL Display("Precondition is not supported yet!!!") - STOP - - CASE (4, 6) - ! LEFT/RIGHT PRECONDITIONER SOLVER - ! The preconditioners are inside the Amat - ! CALL Amat%ILUSOLVE(sol=y, rhs=x, isTranspose=.TRUE.) - CALL Display("File = "//__FILE__) - CALL Display("Precondition is not supported yet!!!") - STOP - END SELECT -END SUBROUTINE PERFORM_TASK - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE CHECKERROR(IPAR, FPAR) - INTEGER(I4B), INTENT(IN) :: IPAR(:) - REAL(DFP), INTENT(IN) :: FPAR(:) - INTEGER(I4B) :: ierr, unitNo - - ierr = IPAR(1) - - SELECT CASE (ierr) - CASE (-1) - unitNo = stdout - CALL EqualLine(unitNo=unitNo) - CALL Display(IPAR(7), "Number of Matrix-Vector Multiplication: ",& - & unitNo=unitNo) - CALL Display(FPAR(3), "Initial residual/error norm: ",& - & unitNo=unitNo) - CALL Display(FPAR(4), "Target residual/error norm: ",& - & unitNo=unitNo) - CALL Display(FPAR(6), "Current residual/error norm: ",& - & unitNo=unitNo) - CALL Display(FPAR(5), "Current residual norm: ",& - & unitNo=unitNo) - CALL Display(FPAR(7), "Convergence rate: ",& - & unitNo=unitNo) - CALL EqualLine(unitNo=unitNo) - CALL Display("Termination because iteration number exceeds the limit", & - & unitno) - CASE (-2) - CALL Display("Return due to insufficient work space", & - & unitno) - CASE (-3) - CALL Display("Return due to anticipated break-down / divide by zero", & - & unitno) - CASE (-4) - CALL Display( & - & "The values of `fpar(1)` and `fpar(2)` are both <= 0"// & - & "the valid ranges are 0 <= fpar(1) < 1, 0 <= fpar(2)"// & - & "and they can not be zero at the same time", unitno) - CASE (-9) - CALL Display( & - & "While trying to detect a break-down, "// & - & "an abnormal number is detected", unitno) - CASE (-10) - CALL Display( & - & "Return due to some non-numerical reasons, "// & - & "e.g. invalid floating-point numbers etc", unitno) - CASE DEFAULT - CALL Display( & - & "Unknown error encountered. Cannot read the error message", & - & unitno) - END SELECT -END SUBROUTINE CHECKERROR - -!---------------------------------------------------------------------------- -! DisplayConvergence -!---------------------------------------------------------------------------- - -SUBROUTINE DisplayConvergence(iter, FPAR) - INTEGER(I4B), INTENT(IN) :: iter - REAL(DFP), INTENT(IN) :: FPAR(:) - INTEGER(I4B) :: unitno - - unitno = stdout - - CALL Display('Convergence is achieved 🎖', unitNo) - CALL Blanklines(nol=2, unitno=unitno) - CALL Display(iter, "Number of Matrix-Vector Multiplication: ",& - & unitno=unitno) - CALL Display(fpar(3), "Initial residual/error norm: ",& - & unitno=unitno) - CALL Display(fpar(4), "Target residual/error norm: ",& - & unitno=unitno) - CALL Display(fpar(6), "Current residual/error norm: ",& - & unitno=unitno) - CALL Display(fpar(5), "Current residual norm: ",& - & unitno=unitno) - CALL Display(fpar(7), "Convergence rate: ",& - & unitno=unitno) -END SUBROUTINE DisplayConvergence - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> authors: Vikas Sharma, Ph. D. -! date: 16 July 2021 -! summary: This subroutine allocates the workspace required for the linear solver -! -! Introduction -! -! This routine allocates the workspace required for the linear solver - -SUBROUTINE AllocateWorkSpace(W, IPAR, solverName, n) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: W(:) - INTEGER(I4B), INTENT(INOUT) :: IPAR(:) - INTEGER(I4B), INTENT(IN) :: solverName - INTEGER(I4B), INTENT(IN) :: n - - INTEGER(I4B) :: i, m - - SELECT CASE (solverName) - CASE (LIS_CG, LIS_CGNR) - i = 5 * n - CASE (LIS_BICG) - i = 7 * n - CASE (LIS_DBICG) - i = 11 * n - CASE (LIS_BICGSTAB) - i = 8 * n - CASE (LIS_TFQMR) - i = 11 * n - CASE (LIS_ORTHOMIN, LIS_GMRES) - m = Input(default=15, option=IPAR(5)) - i = (n + 3) * (m + 2) + (m + 1) * m / 2 - CASE (LIS_FGMRES) - m = Input(default=15, option=IPAR(5)) - i = 2 * n * (m + 1) + (m + 1) * m / 2 + 3 * m + 2 - CASE (LIS_DQGMRES) - m = Input(default=15, option=IPAR(5)) + 1 - i = n + m * (2 * n + 4) - END SELECT - IPAR(4) = i - CALL Reallocate(W, i) -END SUBROUTINE AllocateWorkSpace - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrix_LinSolve_Initiate -INTEGER(I4B), PARAMETER :: default_maxiter = -1_I4B, & - default_preconditionOption = NO_PRECONDITION, & - default_convergenceIn = ConvergenceInRes, & - default_convergenceType = RelativeConvergence, & - default_KrylovSubspaceSize = 5, & - default_solverName = LIS_CG -LOGICAL(LGT), PARAMETER :: default_relativeToRHS = .FALSE. -REAL(DFP), PARAMETER :: default_atol = 1.0E-10, & - default_rtol = 1.0E-10 - -IF (.NOT. ALLOCATED(ipar)) ALLOCATE (ipar(13)) -IF (.NOT. ALLOCATED(fpar)) ALLOCATE (fpar(13)) - -CALL SetPreconditionOption( & - ipar=ipar, & - PRECOND_TYPE=Input(option=preconditionOption, & - default=default_preconditionOption)) - -CALL SetConvergenceType(ipar=ipar, & - convergenceIn=Input(option=convergenceIn, & - default=default_convergenceIn), & - convergenceType=Input(option=convergenceType, & - default=default_convergenceType), & - relativeToRHS=Input(option=relativeToRHS, & - default=default_relativeToRHS)) - -IPAR(5) = Input(option=KrylovSubspaceSize, default=default_KrylovSubspaceSize) - -CALL SetMaxIter(ipar, Input(option=maxIter, default=default_maxiter)) - -fpar = 0.0_DFP - -fpar(1) = Input(option=rtol, default=default_rtol) -fpar(2) = Input(option=atol, default=default_atol) - -IF (.NOT. ALLOCATED(W)) THEN - CALL AllocateWorkSpace(W, ipar, & - Input(default=default_solverName, option=solverName), n) -END IF - -END PROCEDURE CSRMatrix_LinSolve_Initiate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrix_GMRES -INTEGER(I4B) :: n -! REAL(DFP) :: error0, error, tol, normRes -! INTEGER(I4B) :: ierr, iter - -IPAR(1) = 0 -FPAR(11) = 0.0_DFP -n = SIZE(obj, 1) -IPAR(7) = 1 - -DO - CALL GMRES(n, rhs, sol, ipar, fpar, W) - ! obj%RES(ipar(7)) = fpar(6) - - IF (ipar(1) .GT. 0) THEN - CALL PERFORM_TASK(obj, y=W(_y1:_y2), x=W(_x1:_x2), & - & ierr=ipar(1)) - - ELSE IF (ipar(1) .LT. 0) THEN - CALL CHECKERROR(IPAR=ipar, FPAR=fpar) - EXIT - - ELSE IF (ipar(1) .EQ. 0) THEN - ! ierr = ipar(1) - ! iter = ipar(7) - CALL DisplayConvergence(ipar(7), fpar) - EXIT - - END IF -END DO - -! Initial residual/error norm -! error0 = fpar(3) -! Target residual/error norm -! tol = fpar(4) -! Current residual/error norm -! error = fpar(6) -! Current residual norm -! normRes = fpar(5) - -END PROCEDURE CSRMatrix_GMRES - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrix_CG -INTEGER(I4B) :: n -! REAL(DFP) :: error0, error, tol, normRes -! INTEGER(I4B) :: ierr, iter - -IPAR(1) = 0 -FPAR(11) = 0.0_DFP -n = SIZE(obj, 1) -IPAR(7) = 1 - -DO - CALL CG(n, rhs, sol, ipar, fpar, W) - ! obj%RES(ipar(7)) = fpar(6) - - IF (ipar(1) .GT. 0) THEN - CALL PERFORM_TASK(obj, y=W(_y1:_y2), x=W(_x1:_x2), & - & ierr=ipar(1)) - - ELSE IF (ipar(1) .LT. 0) THEN - CALL CHECKERROR(IPAR=ipar, FPAR=fpar) - EXIT - - ELSE IF (ipar(1) .EQ. 0) THEN - ! ierr = ipar(1) - ! iter = ipar(7) - CALL DisplayConvergence(ipar(7), fpar) - EXIT - - END IF -END DO - -! Initial residual/error norm -! error0 = fpar(3) -! Target residual/error norm -! tol = fpar(4) -! Current residual/error norm -! error = fpar(6) -! Current residual norm -! normRes = fpar(5) - -END PROCEDURE CSRMatrix_CG - -!---------------------------------------------------------------------------- -! BiCGStab -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrix_BiCGStab -INTEGER(I4B) :: n -! REAL(DFP) :: error0, error, tol, normRes -! INTEGER(I4B) :: ierr, iter - -IPAR(1) = 0 -FPAR(11) = 0.0_DFP -n = SIZE(obj, 1) -IPAR(7) = 1 - -DO - CALL BCGSTAB(n, rhs, sol, ipar, fpar, W) - ! obj%RES(ipar(7)) = fpar(6) - - IF (ipar(1) .GT. 0) THEN - CALL PERFORM_TASK(obj, y=W(_y1:_y2), x=W(_x1:_x2), & - & ierr=ipar(1)) - - ELSE IF (ipar(1) .LT. 0) THEN - CALL CHECKERROR(IPAR=ipar, FPAR=fpar) - EXIT - - ELSE IF (ipar(1) .EQ. 0) THEN - ! ierr = ipar(1) - ! iter = ipar(7) - CALL DisplayConvergence(ipar(7), fpar) - EXIT - - END IF -END DO - -! Initial residual/error norm -! error0 = fpar(3) -! Target residual/error norm -! tol = fpar(4) -! Current residual/error norm -! error = fpar(6) -! Current residual norm -! normRes = fpar(5) - -END PROCEDURE CSRMatrix_BiCGStab - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods - -#undef _x1 -#undef _x2 -#undef _y1 -#undef _y2 diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 deleted file mode 100644 index ae4631d4d..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 +++ /dev/null @@ -1,265 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> author: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_MatVecMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrixATMUX1 -INTEGER(I4B) :: i, k - -y = 0.0_DFP - -DO i = 1, n - DO k = ia(i), ia(i + 1) - 1 - y(ja(k)) = y(ja(k)) + x(i) * a(k) - END DO -END DO - -END PROCEDURE CSRMatrixATMUX1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrixATMUX2 -INTEGER(I4B) :: i, k - -y = 0.0_DFP - -DO i = 1, n - DO k = ia(i), ia(i + 1) - 1 - y(ja(k)) = y(ja(k)) + x(i) * a(k) * s - END DO -END DO - -END PROCEDURE CSRMatrixATMUX2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrixATMUX_Add_1 -INTEGER(I4B) :: i, k - -DO i = 1, n - DO k = ia(i), ia(i + 1) - 1 - y(ja(k)) = y(ja(k)) + x(i) * a(k) * s - END DO -END DO - -END PROCEDURE CSRMatrixATMUX_Add_1 - -!---------------------------------------------------------------------------- -! CSRMatrixAMUX -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrixAMUX1 -REAL(DFP) :: t -INTEGER(I4B) :: i, k - -DO i = 1, n - ! compute the inner product of row i with vector x - t = 0.0 - DO k = ia(i), ia(i + 1) - 1 - t = t + a(k) * x(ja(k)) - END DO - ! store result in y(i) - y(i) = t -END DO -END PROCEDURE CSRMatrixAMUX1 - -!---------------------------------------------------------------------------- -! CSRMatrixAMUX -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrixAMUX2 -REAL(DFP) :: t -INTEGER(I4B) :: i, k - -DO i = 1, n - ! compute the inner product of row i with vector x - t = 0.0 - DO k = ia(i), ia(i + 1) - 1 - t = t + a(k) * x(ja(k)) - END DO - ! store result in y(i) - y(i) = s * t -END DO -END PROCEDURE CSRMatrixAMUX2 - -!---------------------------------------------------------------------------- -! CSRMatrixAMUX -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CSRMatrixAMUX_Add_1 -REAL(DFP) :: t -INTEGER(I4B) :: i, k - -DO i = 1, n - ! compute the inner product of row i with vector x - t = 0.0 - DO k = ia(i), ia(i + 1) - 1 - t = t + a(k) * x(ja(k)) - END DO - ! store result in y(i) - y(i) = y(i) + s * t -END DO -END PROCEDURE CSRMatrixAMUX_Add_1 - -!---------------------------------------------------------------------------- -! AMatvec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_AMatvec1 -LOGICAL(LGT) :: add0 -REAL(DFP) :: scale0 -INTEGER(I4B) :: tsize - -add0 = input(default=.FALSE., option=addContribution) -scale0 = input(default=1.0_DFP, option=scale) -tsize = SIZE(y) - -IF (add0) THEN - CALL CSRMatrixAMUX_Add(n=tsize, x=x, y=y, a=obj%A, & - & ja=obj%csr%JA, ia=obj%csr%IA, s=scale0) - RETURN -END IF - -CALL CSRMatrixAMUX(n=tsize, x=x, y=y, a=obj%A, & - & ja=obj%csr%JA, ia=obj%csr%IA, s=scale0) - -END PROCEDURE csrMat_AMatvec1 - -!---------------------------------------------------------------------------- -! AMatvec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_AMatvec2 -REAL(DFP) :: y0(SIZE(y)) -LOGICAL(LGT) :: add0 -REAL(DFP) :: scale0 -INTEGER(I4B) :: tsize - -add0 = input(default=.FALSE., option=addContribution) -scale0 = input(default=1.0_DFP, option=scale) -tsize = SIZE(y) - -IF (add0) THEN - CALL AMUXMS(tsize, x, y0, A, JA) - CALL AXPY(X=y0, Y=y, A=scale0) - RETURN -END IF - -CALL AMUXMS(tsize, x, y, A, JA) -CALL SCAL(X=y, A=scale0) -END PROCEDURE csrMat_AMatvec2 - -!---------------------------------------------------------------------------- -! AtMatvec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_AtMatvec -REAL(DFP) :: y0(SIZE(y)) -LOGICAL(LGT) :: add0 -REAL(DFP) :: scale0 -INTEGER(I4B) :: ty, tx, nrow, ncol -LOGICAL(LGT) :: squareCase, problem, rectCase - -add0 = INPUT(default=.FALSE., option=addContribution) -scale0 = input(default=1.0_DFP, option=scale) -ty = SIZE(y) -tx = SIZE(x) -squareCase = isSquare(obj) -rectCase = isRectangle(obj) - -ncol = SIZE(obj, 2) !ncol -nrow = SIZE(obj, 1) !nrow - -problem = tx .NE. nrow .OR. ty .NE. ncol - -IF (add0 .AND. squareCase) THEN - CALL ATMUX(nrow, x, y0, obj%A, obj%csr%JA, obj%csr%IA) - CALL AXPY(X=y0, Y=y, A=scale0) - RETURN -END IF - -IF (add0 .AND. rectCase .AND. problem) THEN - CALL Errormsg( & - & msg="Mismatch in shapes... nrow = "//tostring(nrow)// & - & " ncol = "//tostring(ncol)//" size(x) = "//tostring(tx)// & - & " size(y) = "//tostring(ty), & - & file=__FILE__, & - & routine="csrMat_AtMatvec()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -IF (add0 .AND. rectCase) THEN - CALL ATMUXR(ncol, nrow, x, y0, obj%A, obj%csr%JA, obj%csr%IA) - CALL AXPY(X=y0, Y=y, A=scale0) - RETURN -END IF - -IF (squareCase) THEN - CALL ATMUX(nrow, x, y, obj%A, obj%csr%JA, obj%csr%IA) - CALL SCAL(X=y, A=scale0) - RETURN -END IF - -CALL ATMUXR(ncol, nrow, x, y, obj%A, obj%csr%JA, obj%csr%IA) -CALL SCAL(X=y, A=scale0) -END PROCEDURE csrMat_AtMatvec - -!---------------------------------------------------------------------------- -! MatVec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_MatVec1 -LOGICAL(LGT) :: trans -trans = INPUT(option=isTranspose, default=.FALSE.) - -IF (trans) THEN - CALL AtMatvec(obj=obj, x=x, y=y, addContribution=addContribution, & - & scale=scale) - RETURN -END IF - -CALL AMatvec(obj=obj, x=x, y=y, addContribution=addContribution, & - & scale=scale) -END PROCEDURE csrMat_MatVec1 - -!---------------------------------------------------------------------------- -! MatVec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_MatVec2 -CALL AMatvec(A=A, JA=JA, x=x, y=y, addContribution=addContribution, & - & scale=scale) -END PROCEDURE csrMat_MatVec2 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 deleted file mode 100644 index 32b1fc957..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 +++ /dev/null @@ -1,340 +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(CSRMatrix_MatrixMarketIO) Methods -USE String_Class, ONLY: String -USE BaseMethod, ONLY: Tostring, ErrorMsg, ToUpperCase, Display, Reallocate -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE parse_first_dataline(aline, intvar, ierr, errmsg) - CHARACTER(*), INTENT(IN) :: aline - INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: intvar(:) - INTEGER(I4B), INTENT(OUT) :: ierr - CHARACTER(*), INTENT(OUT) :: errmsg - ! - TYPE(string) :: astr - TYPE(string), ALLOCATABLE :: tokens(:) - INTEGER(I4B) :: n, ii - ! - astr = TRIM(aline) - CALL astr%split(tokens=tokens) - IF (.NOT. ALLOCATED(tokens)) THEN - ierr = -10 - errmsg = "Tokenization failed while parsing first data line" - RETURN - END IF - ! - n = SIZE(tokens) - CALL reallocate(intvar, n) - ! - DO ii = 1, n - intvar(ii) = tokens(ii)%to_number(1_I4B) - END DO - ! - ierr = 0 - errmsg = "" - ! - DEALLOCATE (tokens) - astr = "" -END SUBROUTINE parse_first_dataline - -!---------------------------------------------------------------------------- -! ParseHeader -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ParseHeader -TYPE(String) :: astr -TYPE(String), ALLOCATABLE :: tokens(:) -INTEGER(I4B) :: n, ii - -astr = aline -CALL astr%split(tokens=tokens) - -IF (ALLOCATED(tokens)) THEN - n = SIZE(tokens) -ELSE - ierr = -10 - errmsg = "Cannot create tokens from header" - RETURN -END IF - -IF (n .EQ. 5) THEN - h1 = tokens(1)%chars() - h2 = tokens(2)%chars() - h3 = tokens(3)%chars() - h4 = tokens(4)%chars() - h5 = tokens(5)%chars() - ierr = 0 - errmsg = "" - DEALLOCATE (tokens) - RETURN -ELSE IF (n .GT. 5) THEN - ierr = n - errmsg = "Number of tokens are greater than 5" - DEALLOCATE (tokens) - RETURN -ELSE IF (n .LT. 5) THEN - ierr = n - errmsg = "Number of tokens are "//Tostring(n)//" , which is less than 5; " - DEALLOCATE (tokens) - RETURN -END IF - -END PROCEDURE ParseHeader - -!---------------------------------------------------------------------------- -! MMRead -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MMRead -CHARACTER(1024) :: aline, errmsg, iomsg -INTEGER(I4B) :: ierr, iostat, ii -INTEGER(I4B), ALLOCATABLE :: aint_vec(:) -CHARACTER(15) :: h1 -CHARACTER(6) :: h2 -CHARACTER(10) :: h3 -CHARACTER(7) :: h4 -CHARACTER(19) :: h5 - -READ (unitno, "(A)", iostat=iostat, iomsg=iomsg) aline - -IF (iostat .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error while reading the header of given file", & - & file=__FILE__, line=__LINE__, & - & routine="MMRead()", & - & unitno=stdout) - RETURN -END IF - -CALL ParseHeader(aline, h1, h2, h3, h4, h5, ierr, errmsg) - -IF (ierr .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error while parsing the header: msg = "//TRIM(errmsg), & - & file=__FILE__, line=__LINE__, & - & routine="MMRead()", & - & unitno=stdout) - RETURN -END IF - -CALL ToUpperCase(h2) - -IF (h2 .NE. "MATRIX") THEN - CALL ErrorMsg( & - & msg="The second arg of header is "//TRIM(h2)//" it should be matrix.", & - & file=__FILE__, line=__LINE__, & - & routine="MMRead()", & - & unitno=stdout) - RETURN -END IF - -field = TRIM(h4) -CALL ToUpperCase(h4) -IF (h4 .NE. "REAL" .AND. h4 .NE. "INTEGER" & - & .AND. h4 .NE. "COMPLEX" .AND. h4 .NE. "PATTERN") THEN - CALL ErrorMsg( & - & msg="The fourth arg of header is "//TRIM(h4)//", it should real or & - & INTEGER.", & - & file=__FILE__, line=__LINE__, & - & routine="MMRead() ", & - & unitno=stdout) - RETURN -END IF - -rep = TRIM(h3) -CALL ToUpperCase(h3) - -IF (h3 .NE. "COORDINATE" .AND. h3 .NE. "ARRAY") THEN - CALL ErrorMsg( & - & msg="The third arg of header is "//TRIM(h3)// & - & ", it should coordinate or array.", & - & file=__FILE__, line=__LINE__, & - & routine="MMRead()", & - & unitno=stdout) - RETURN -END IF - -symm = TRIM(h5) -CALL ToUpperCase(h5) - -IF (h5 .NE. 'GENERAL' .AND. h5 .NE. 'SYMMETRIC' & - & .AND. h5 .NE. 'HERMITIAN' & - & .AND. h5 .NE. 'SKEW-SYMMETRIC') THEN - CALL ErrorMsg( & - & msg="The 5th arg of header is "//TRIM(h5)//", & - & it should be ['geneal', 'symmetric', & - & 'skew-symmetric'].", & - & file=__FILE__, line=__LINE__, & - & routine="MMRead()", & - & unitno=stdout) - RETURN -END IF -! -! Read comments -! -DO - READ (unitno, "(A)", iostat=iostat, iomsg=iomsg) aline - - IF (aline(1:1) .NE. "%") THEN - EXIT - END IF - - IF (IS_IOSTAT_END(iostat)) THEN - EXIT - ELSE IF (iostat .NE. 0) THEN - CALL ErrorMsg(& - & msg="Error while reading comments in file; msg = "//TRIM(iomsg), & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - -END DO -! -! Read the main data -! -BACKSPACE (unitno) -READ (unitno, "(A)", iostat=iostat, iomsg=iomsg) aline - -IF (iostat .NE. 0) THEN - CALL ErrorMsg(& - & msg="Error while reading first line of data (after comments); msg = "& - & //TRIM(iomsg), & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN -END IF - -CALL parse_first_dataline(aline, aint_vec, ierr, errmsg) - -IF (ierr .NE. 0) THEN - CALL ErrorMsg(& - & msg="Error while reading first line of data (after comments); msg = " & - & //TRIM(errmsg), & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN -END IF - -IF (h3 .EQ. "COORDINATE") THEN - IF (SIZE(aint_vec) .NE. 3) THEN - CALL ErrorMsg(& - & msg="For sparse matrix three args should be defined & - & in first row of data (below comments)", & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - rows = aint_vec(1) - cols = aint_vec(2) - nnz = aint_vec(3) -ELSEIF (h3 .EQ. "ARRAY") THEN - IF (SIZE(aint_vec) .NE. 2) THEN - CALL ErrorMsg(& - & msg="For dense matrix two args should be defined & - & in first row of data (below comments)", & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - rows = aint_vec(1) - cols = aint_vec(2) - nnz = rows * cols -END IF - -CALL Reallocate(indx, nnz, jndx, nnz) - -IF (h4 .EQ. "REAL") THEN - IF (.NOT. PRESENT(rval)) THEN - CALL ErrorMsg(& - & msg="rval should be present for real field", & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - CALL Reallocate(rval, nnz) - ! - DO ii = 1, nnz - READ (unitno, *, iostat=iostat, iomsg=iomsg) indx(ii), jndx(ii), rval(ii) - IF (IS_IOSTAT_END(iostat)) THEN - EXIT - ELSE IF (iostat .NE. 0) THEN - CALL ErrorMsg(& - & msg="Error while reading "//Tostring(ii)// & - & "th nonzero entry from the file; msg = "//TRIM(iomsg), & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - END DO -ELSEIF (h4 .EQ. "INTEGER") THEN - IF (.NOT. PRESENT(ival)) THEN - CALL ErrorMsg(& - & msg="ival should be present for integer field", & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - CALL Reallocate(ival, nnz) - ! - DO ii = 1, nnz - READ (unitno, *, iostat=iostat, iomsg=iomsg) indx(ii), jndx(ii), ival(ii) - IF (IS_IOSTAT_END(iostat)) THEN - EXIT - ELSE IF (iostat .NE. 0) THEN - CALL ErrorMsg(& - & msg="Error while reading "//Tostring(ii)// & - & "th nonzero entry from the file; msg = "//TRIM(iomsg), & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - END DO -ELSEIF (h4 .EQ. "COMPLEX") THEN - CALL ErrorMsg(& - & msg="Currently complex field is not supported", & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - ! -ELSEIF (h4 .EQ. "pattern") THEN - DO ii = 1, nnz - READ (unitno, *, iostat=iostat, iomsg=iomsg) indx(ii), jndx(ii) - IF (IS_IOSTAT_END(iostat)) THEN - EXIT - ELSE IF (iostat .NE. 0) THEN - CALL ErrorMsg(& - & msg="Error while reading "//Tostring(ii)// & - & "th nonzero entry from the file; msg = "//TRIM(iomsg), & - & file=__FILE__, routine="MMRead()", & - & line=__LINE__, unitno=stdout) - RETURN - END IF - END DO -END IF - -IF (ALLOCATED(aint_vec)) DEALLOCATE (aint_vec) - -END PROCEDURE MMRead - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 deleted file mode 100644 index 83677aef9..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 +++ /dev/null @@ -1,95 +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(CSRMatrix_ReorderingMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! NestedDissect -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_NestedDissect -#ifdef USE_METIS -INTEGER(I4B) :: nrow, ncol, nnz, ii, jj, kk, nbr, ll -INTEGER(I4B), ALLOCATABLE :: XADJ(:), ADJNCY(:) -! -nrow = SIZE(csrMat, 1) -ncol = SIZE(csrMat, 2) -nnz = getNNZ(csrMat) -CALL REALLOCATE(XADJ, nrow + 1, ADJNCY, nnz) -CALL REALLOCATE(reorder%PERM, nrow, reorder%IPERM, nrow) -reorder%name = 'NodeND' -XADJ(1) = 1 -kk = 0 -DO ii = 1, nrow - nbr = 0 - DO jj = csrMat%csr%IA(ii), csrMat%csr%IA(ii + 1) - 1 - ll = csrMat%csr%JA(jj) - IF (ll .NE. ii) THEN - nbr = nbr + 1 - kk = kk + 1 - ADJNCY(kk) = ll - END IF - END DO - XADJ(ii + 1) = XADJ(ii) + nbr -END DO -ll = XADJ(SIZE(xadj)) - 1 -CALL MetisNodeND(XADJ=XADJ, ADJNCY=ADJNCY(1:ll), PERM=reorder%PERM, & - & IPERM=reorder%IPERM) -IF (ALLOCATED(XADJ)) DEALLOCATE (XADJ) -IF (ALLOCATED(ADJNCY)) DEALLOCATE (ADJNCY) -#else -CALL ErrorMSG( & - & Msg="Metis library not installed!", & - & File="CSRMatrix_ReorderingMethods@Methods.F90", & - & Routine="csrMat_NestedDissect()", & - & Line=__LINE__, & - & UnitNo=stdout) -STOP -#endif -END PROCEDURE csrMat_NestedDissect - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_reorderDisplay -INTEGER(I4B) :: I -I = INPUT(Default=stdout, Option=unitNo) -CALL Display(obj%name, "# NAME : ") -CALL DISP(x=obj%PERM, title="PERM=", advance="NO", unit=I, & - & style='left') -CALL DISP(x=obj%IPERM, title="IPERM=", advance="DOUBLE", & - & unit=I, style='left') -END PROCEDURE csrMat_reorderDisplay - -!---------------------------------------------------------------------------- -! Permute -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_Permute2 -ans = Permute(obj=obj, rowPERM=rowPERM%IPERM, colPERM=colPERM%IPERM, & - & isValues=.TRUE.) -END PROCEDURE csrMat_Permute2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 deleted file mode 100644 index 089f37184..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 +++ /dev/null @@ -1,322 +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: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_SchurMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! AMatvec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_AMatvec -REAL(DFP), ALLOCATABLE :: dummyVec(:) -INTEGER(I4B) :: m, n - -n = SIZE(B, 1) -m = SIZE(B, 2) - -IF (n .NE. SIZE(A, 1) & - & .OR. SIZE(A, 2) .NE. n & - & .OR. SIZE(x) .NE. m & - & .OR. SIZE(y) .NE. m) THEN - CALL Errormsg( & - & msg="Shape of A and B are not compatible", & - & file=__FILE__, & - & routine="csrMat_AMatvec()", & - & line=__LINE__, & - & unitno=stderr) - STOP -END IF - -ALLOCATE (dummyVec(n)) - -CALL MatVec(obj=B, x=x, y=dummyVec, isTranspose=.FALSE.) -CALL LinSolve(A=A, B=dummyVec, isTranspose=.FALSE., isFactored=.TRUE.) -CALL MatVec(obj=B, x=dummyVec, y=y, isTranspose=.TRUE.) - -DEALLOCATE (dummyVec) - -END PROCEDURE csrMat_AMatvec - -!---------------------------------------------------------------------------- -! AtMatvec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_AtMatVec -REAL(DFP), ALLOCATABLE :: dummyVec(:) -INTEGER(I4B) :: m, n -LOGICAL(LGT) :: isASym0 - -n = SIZE(B, 1) -m = SIZE(B, 2) - -IF (n .NE. SIZE(A, 1) & - & .OR. SIZE(A, 2) .NE. n & - & .OR. SIZE(x) .NE. m & - & .OR. SIZE(y) .NE. m) THEN - CALL Errormsg( & - & msg="Shape of A and B are not compatible", & - & file=__FILE__, & - & routine="csrMat_AtMatvec()", & - & line=__LINE__, & - & unitno=stderr) - STOP -END IF - -isASym0 = Input(option=isASym, default=.FALSE.) - -ALLOCATE (dummyVec(n)) - -CALL MatVec(obj=B, x=x, y=dummyVec, isTranspose=.FALSE.) - -CALL LinSolve( & - & A=A, & - & B=dummyVec, & - & isTranspose=(.NOT. isASym0), & - & isFactored=.TRUE.) - -CALL MatVec( & - & obj=B, & - & x=dummyVec, & - & y=y, & - & isTranspose=.TRUE.) - -DEALLOCATE (dummyVec) - -END PROCEDURE csrMat_AtMatVec - -!---------------------------------------------------------------------------- -! MatVec -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_SchurMatVec -LOGICAL(LGT) :: trans -trans = INPUT(option=isTranspose, default=.FALSE.) -IF (trans) THEN - CALL csrMat_AtMatvec(A=A, B=B, x=x, y=y, isASym=isASym) -ELSE - CALL csrMat_AMatvec(A=A, B=B, x=x, y=y) -END IF -END PROCEDURE csrMat_SchurMatVec - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymSchurLargestEigenVal1 -CHARACTER(*), PARAMETER :: myName = "SymSchurLargestEigenVal1" -INTEGER(I4B), PARAMETER :: nev = 1 -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0 -CHARACTER(1), PARAMETER :: bmat = "I" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, d(nev), sigma -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -! -! int scalar -! -which0 = INPUT(default="LA", option=which) -n = SIZE(B, 2) -ncv0 = input(default=MIN(20_I4B, n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -! -! iparam -! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 1 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - ! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - ! - ! Perform MatVec Mult - ! y = MATMUL(mat, X) - ! x => WORKD(ipntr(1):ipntr(1)+N-1) - ! y => WORKD(ipntr(2):ipntr(2)+N-1) - ! - CALL SchurMatVec( & - & A=A, & - & B=B, & - & x=workd(ipntr(1):ipntr(1) + n - 1), & - & y=workd(ipntr(2):ipntr(2) + n - 1), & - & isTranspose=.FALSE., & - & isASym=.TRUE.) - ! - ELSE - EXIT - END IF -END DO -! -! we are not getting rvec, therefore ldz=1, -! othereise ldz = N -! -CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=d, z=v, ldz=1, sigma=sigma, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) -! -IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(INFO) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP -ELSE - ans = d(1) -END IF -! -DEALLOCATE (resid, v, workd, workl, SELECT) -! -END PROCEDURE SymSchurLargestEigenVal1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymSchurLargestEigenVal2 -CHARACTER(*), PARAMETER :: myName = "SymSchurLargestEigenVal2" -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0 -CHARACTER(1), PARAMETER :: bmat = "I" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, sigma -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -! -! int scalar -! -which0 = INPUT(default="LA", option=which) -n = SIZE(B, 2) - -ncv0 = input(default=MIN(MAX(20_I4B, 2 * nev + 1), n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -! -! iparam -! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 1 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - ! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - ! - ! Perform MatVec Mult - ! y = MATMUL(mat, X) - ! x => WORKD(ipntr(1):ipntr(1)+N-1) - ! y => WORKD(ipntr(2):ipntr(2)+N-1) - ! - CALL SchurMatVec( & - & A=A, & - & B=B, & - & x=workd(ipntr(1):ipntr(1) + n - 1), & - & y=workd(ipntr(2):ipntr(2) + n - 1), & - & isTranspose=.FALSE., & - & isASym=.TRUE.) - ! - ELSE - EXIT - END IF -END DO -! -! we are not getting rvec, therefore ldz=1, -! othereise ldz = N -! -CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=ans, z=v, ldz=1, sigma=sigma, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) -!! -IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(INFO) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP -END IF -! -DEALLOCATE (resid, v, workd, workl, SELECT) -! -END PROCEDURE SymSchurLargestEigenVal2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 deleted file mode 100644 index eb22c1361..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 +++ /dev/null @@ -1,241 +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 -! - -!! authors: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_SetBlockColMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockColumn1 -INTEGER(I4B) :: ii, jj, c(3), row_start, row_end -CLASS(DOF_), POINTER :: idofobj - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (icolumn .GT. SIZE(obj, 2)) THEN - CALL ErrorMSG( & - & Msg="icolumn is out of Bound", & - & File="CSRMatrix_Method@SetBlockColMethods.F90", & - & Routine="csrMat_setBlockColumn1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! -idofobj => GetDOFPointer(obj, 1) - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (ivar .GT. (.tNames.idofobj)) THEN - CALL ErrorMSG( & - & Msg="ivar is out of Bound", & - & File="CSRMatrix_Method@SetBlockColMethods.F90", & - & Routine="csrMat_setBlockColumn1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF ((obj.StorageFMT.1) .NE. FMT_DOF) THEN - CALL ErrorMSG( & - & Msg="For this rotuine storage format should FMT_DOF", & - & File="CSRMatrix_Method@SetBlockColMethods.F90", & - & Routine="csrMat_setBlockColumn1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! - !! start, end, stride of idof - !! -c = getNodeLoc(obj=idofobj, idof=(idofobj.DOFStartIndex.ivar)) -row_start = c(1) ! start -c = getNodeLoc(idofobj, (idofobj.DOFEndIndex.ivar)) -row_end = c(2) ! end - !! -DO ii = row_start, row_end - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - IF (obj%csr%JA(jj) .EQ. icolumn) & - & obj%A(jj) = value - END DO -END DO - !! -idofobj => NULL() - !! -END PROCEDURE csrMat_setBlockColumn1 - -!---------------------------------------------------------------------------- -! setBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockColumn2 -INTEGER(I4B) :: ii, c(3), row_start, row_end, jj -CLASS(DOF_), POINTER :: idofobj - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (SIZE(value) .LT. obj%csr%ncol) THEN - CALL ErrorMSG( & - & Msg="SIZE of row vector should be less than the number of col & - & in sparse matrix", & - & File="CSRMatrix_Method@SetBlockColMethods.F90", & - & Routine="csrMat_setBlockColumn2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF (icolumn .GT. SIZE(obj, 2)) THEN - CALL ErrorMSG( & - & Msg="icolumn is out of Bound", & - & File="CSRMatrix_Method@SetBlockColMethods.F90", & - & Routine="csrMat_setBlockColumn2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! -idofobj => GetDOFPointer(obj, 1) - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (ivar .GT. (.tNames.idofobj)) THEN - CALL ErrorMSG( & - & Msg="jVar is out of Bound", & - & File="CSRMatrix_Method@SetBlockColMethods.F90", & - & Routine="csrMat_setBlockColumn2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF ((obj.StorageFMT.1) .NE. FMT_DOF) THEN - CALL ErrorMSG( & - & Msg="For this rotuine storage format should FMT_DOF", & - & File="CSRMatrix_Method@SetBlockColMethods.F90", & - & Routine="csrMat_setBlockColumn2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! - !! start, end, stride - !! -c = getNodeLoc(obj=idofobj, idof=(idofobj.DOFStartIndex.ivar)) -row_start = c(1) ! start -c = getNodeLoc(obj=idofobj, idof=(idofobj.DOFEndIndex.ivar)) -row_end = c(2) ! end - !! -DO ii = row_start, row_end - DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 - IF (obj%csr%JA(jj) .EQ. icolumn) & - & obj%A(jj) = value(ii) - END DO -END DO - !! -idofobj => NULL() - !! -END PROCEDURE csrMat_setBlockColumn2 - -!---------------------------------------------------------------------------- -! setBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockColumn3 -CALL SetBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(obj=obj%csr%jdof, nodeNum=nodenum, & - & ivar=jvar, idof=idof), & - & value=value) -END PROCEDURE csrMat_setBlockColumn3 - -!---------------------------------------------------------------------------- -! setBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockColumn4 -CALL SetBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getNodeLoc(obj=obj%csr%jdof, nodeNum=nodenum, & - & ivar=jvar, idof=idof), & - & value=value) -END PROCEDURE csrMat_setBlockColumn4 - -!---------------------------------------------------------------------------- -! setBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockColumn5 -CALL SetBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getIndex( & - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) -END PROCEDURE csrMat_setBlockColumn5 - -!---------------------------------------------------------------------------- -! setBlockColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockColumn6 -CALL SetBlockColumn( & - & obj=obj, & - & ivar=ivar, & - & icolumn=getIndex( & - & obj=obj%csr%jdof, & - & nodeNum=nodenum, & - & ivar=jvar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) -END PROCEDURE csrMat_setBlockColumn6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 deleted file mode 100644 index 36eb0d321..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 +++ /dev/null @@ -1,233 +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 -! - -!! authors: Vikas Sharma, Ph. D. -! date: 14 July 2021 -! summary: This submodule contains the methods for sparse matrix - -SUBMODULE(CSRMatrix_SetBlockRowMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockRow1 -INTEGER(I4B) :: jj, c(3), col_start, col_end -CLASS(DOF_), POINTER :: jdofobj - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (irow .GT. SIZE(obj, 1)) THEN - CALL ErrorMSG( & - & Msg="irow is out of Bound", & - & File="CSRMatrix_Method@SetBlockRowMethods.F90", & - & Routine="csrMat_setBlockRow1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! -jdofobj => GetDOFPointer(obj, 2) - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (jvar .GT. (.tNames.jdofobj)) THEN - CALL ErrorMSG( & - & Msg="jVar is out of Bound", & - & File="CSRMatrix_Method@SetBlockRowMethods.F90", & - & Routine="csrMat_setBlockRow1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF ((obj.StorageFMT.2) .NE. FMT_DOF) THEN - CALL ErrorMSG( & - & Msg="For this rotuine storage format should FMT_DOF", & - & File="CSRMatrix_Method@SetBlockRowMethods.F90", & - & Routine="csrMat_setBlockRow1", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif -!! -!! start, end, stride of idof -!! -c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFStartIndex.jvar)) -col_start = c(1) ! start -c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFEndIndex.jvar)) -col_end = c(2) ! end -!! -DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 - IF ((jj .GE. col_start) .AND. jj .LE. col_end) & - & obj%A(jj) = value -END DO - !! -jdofobj => NULL() - !! -END PROCEDURE csrMat_setBlockRow1 - -!---------------------------------------------------------------------------- -! setBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockRow2 -INTEGER(I4B) :: jj, c(3), col_start, col_end -CLASS(DOF_), POINTER :: jdofobj - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (SIZE(value) .LT. obj%csr%ncol) THEN - CALL ErrorMSG( & - & Msg="SIZE of row vector should be less than the number of col & - & in sparse matrix", & - & File="CSRMatrix_Method@SetBlockRowMethods.F90", & - & Routine="csrMat_setBlockRow2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF (irow .GT. SIZE(obj, 1)) THEN - CALL ErrorMSG( & - & Msg="irow is out of Bound", & - & File="CSRMatrix_Method@SetBlockRowMethods.F90", & - & Routine="csrMat_setBlockRow2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! -jdofobj => GetDOFPointer(obj, 2) - !! -#ifdef DEBUG_VER - !! - !! check - !! -IF (jvar .GT. (.tNames.jdofobj)) THEN - CALL ErrorMSG( & - & Msg="jVar is out of Bound", & - & File="CSRMatrix_Method@SetBlockRowMethods.F90", & - & Routine="csrMat_setBlockRow2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! - !! check - !! -IF ((obj.StorageFMT.2) .NE. FMT_DOF) THEN - CALL ErrorMSG( & - & Msg="For this rotuine storage format should FMT_DOF", & - & File="CSRMatrix_Method@SetBlockRowMethods.F90", & - & Routine="csrMat_setBlockRow2", & - & Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! - !! start, end, stride of idof - !! -c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFStartIndex.jvar)) -col_start = c(1) ! start -c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFEndIndex.jvar)) -col_end = c(2) ! end - !! -DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 - IF ((jj .GE. col_start) .AND. jj .LE. col_end) & - & obj%A(jj) = value(obj%csr%JA(jj)) -END DO -!! -jdofobj => NULL() -!! -END PROCEDURE csrMat_setBlockRow2 - -!---------------------------------------------------------------------------- -! setBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockRow3 -CALL SetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc(obj=obj%csr%idof, nodeNum=nodenum, & - & ivar=ivar, idof=idof), & - & value=value) -END PROCEDURE csrMat_setBlockRow3 - -!---------------------------------------------------------------------------- -! setBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockRow4 -CALL SetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getNodeLoc(obj=obj%csr%idof, nodeNum=nodenum, & - & ivar=ivar, idof=idof), & - & value=value) -END PROCEDURE csrMat_setBlockRow4 - -!---------------------------------------------------------------------------- -! setBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockRow5 -CALL SetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getIndex( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) -END PROCEDURE csrMat_setBlockRow5 - -!---------------------------------------------------------------------------- -! setBlockRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setBlockRow6 -CALL SetBlockRow( & - & obj=obj, & - & jvar=jvar, & - & irow=getIndex( & - & obj=obj%csr%idof, & - & nodeNum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) -END PROCEDURE csrMat_setBlockRow6 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 deleted file mode 100644 index 954e8a246..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 +++ /dev/null @@ -1,351 +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: 22 March 2021 -! summary: It contains method for setting values in [[CSRMatrix_]] - -SUBMODULE(CSRMatrix_SetColMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn1 - !! -INTEGER(I4B) :: i, j - !! -#ifdef DEBUG_VER - !! -IF (SIZE(value) .LT. obj%csr%nrow .OR. icolumn .GT. SIZE(obj, 2)) THEN - CALL ErrorMSG(Msg="SIZE of column vector should be same as number of & - & rows in sparse matrix", & - & File="CSRMatrix_Method@setMethod.F90", & - & Routine="csrMat_setColumn1", Line=__LINE__, UnitNo=stdout) - RETURN -END IF - !! -#endif - !! -DO i = 1, obj%csr%nrow - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - IF (obj%csr%JA(j) .EQ. icolumn) THEN - obj%A(j) = value(i) - EXIT - END IF - END DO -END DO - !! -END PROCEDURE csrMat_setColumn1 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn1b - !! -INTEGER(I4B) :: i, j, k - !! -DO i = 1, obj%csr%nrow - DO k = 1, SIZE(icolumn) - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - IF (obj%csr%JA(j) .EQ. icolumn(k)) THEN - obj%A(j) = value(i) - EXIT - END IF - END DO - END DO -END DO - !! -END PROCEDURE csrMat_setColumn1b - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn2 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & idof=idof), & - & value=value) - !! -END PROCEDURE csrMat_setColumn2 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn3 - !! -INTEGER(I4B) :: i, j - !! -DO i = 1, obj%csr%nrow - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - IF (obj%csr%JA(j) .EQ. icolumn) obj%A(j) = value - END DO -END DO - !! -END PROCEDURE csrMat_setColumn3 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn3b - !! -INTEGER(I4B) :: i, j, k - !! -DO i = 1, obj%csr%nrow - DO k = 1, SIZE(icolumn) - DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 - IF (obj%csr%JA(j) .EQ. icolumn(k)) THEN - obj%A(j) = value - EXIT - END IF - END DO - END DO -END DO - !! -END PROCEDURE csrMat_setColumn3b - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn4 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & idof=idof),& - & value=value) - !! -END PROCEDURE csrMat_setColumn4 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn5 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, idof=idof), & - & value=value) - !! -END PROCEDURE csrMat_setColumn5 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn6 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & idof=idof), & - & value=value) - !! -END PROCEDURE csrMat_setColumn6 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn7 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn7 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn8 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn8 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn9 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn9 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn10 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn10 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn11 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn11 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn12 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn12 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn13 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn13 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn14 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn14 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn15 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn15 - -!---------------------------------------------------------------------------- -! setColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setColumn16 - !! -CALL SetColumn(obj=obj, & - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setColumn16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 deleted file mode 100644 index 8283f5447..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 +++ /dev/null @@ -1,403 +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: 22 March 2021 -! summary: It contains method for setting values in [[CSRMatrix_]] - -SUBMODULE(CSRMatrix_SetMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SetSingleValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SetSingleValue -obj%A(indx) = VALUE -END PROCEDURE obj_SetSingleValue - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set0 -! Internal variables -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) -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) = VALUE(ii, kk) - EXIT - END IF - END DO - END DO -END DO -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -END PROCEDURE obj_set0 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set1 -REAL(DFP), ALLOCATABLE :: m2(:, :) -INTEGER(I4B) :: tdof - -tdof = .tdof.obj%csr%idof -SELECT CASE (storageFMT) -CASE (FMT_NODES) - IF ((obj.StorageFMT.1) .EQ. FMT_NODES) THEN - m2 = VALUE - ELSE - CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, & - & 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) - END IF -END SELECT -CALL Set(obj=obj, nodenum=nodenum, VALUE=m2) -IF (ALLOCATED(m2)) DEALLOCATE (m2) -END PROCEDURE obj_set1 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set2 -obj%A = VALUE -END PROCEDURE obj_set2 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set3 -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) = VALUE -END DO -! -END PROCEDURE obj_set3 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set4 -CALL set(obj=obj, & - & irow=GetNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=iNodeNum, idof=iDOF), & - & icolumn=GetNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=jNodeNum, idof=jDOF), & - & VALUE=VALUE) -END PROCEDURE obj_set4 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set5 -REAL(DFP), ALLOCATABLE :: m2(:, :) -INTEGER(I4B) :: tdof1, tdof2 -! -tdof1 = .tdof. (obj%csr%idof) -tdof2 = .tdof. (obj%csr%jdof) -! -CALL Reallocate(m2, tdof1 * SIZE(nodenum), tdof2 * SIZE(nodenum)) -m2 = VALUE -CALL Set(obj=obj, nodenum=nodenum, VALUE=m2) -! -DEALLOCATE (m2) -END PROCEDURE obj_set5 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set6 -! 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) = VALUE(ii, kk) - EXIT - END IF - END DO - END DO -END DO -! -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -! -END PROCEDURE obj_set6 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set7 -CALL set(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) -END PROCEDURE obj_set7 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set8 -! 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) -! -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) = VALUE(ii, kk) - EXIT - END IF - END DO - END DO -END DO -! -DEALLOCATE (row, col) -! -END PROCEDURE obj_set8 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set9 -CALL set(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) -END PROCEDURE obj_set9 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set10 -! 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) = VALUE - EXIT - END IF - END DO - END DO -END DO -! -DEALLOCATE (row, col) -! -END PROCEDURE obj_set10 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set11 -! 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) = VALUE - EXIT - END IF - END DO - END DO -END DO -! -DEALLOCATE (row, col) -! -END PROCEDURE obj_set11 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set12 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk -! -row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) -col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & - & spacecompo=jspacecompo, timecompo=jtimecompo) -! -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) = VALUE - EXIT - END IF - END DO - END DO -END DO -! -DEALLOCATE (row, col) -! -END PROCEDURE obj_set12 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set13 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk -! -row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) -col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & - & spacecompo=jspacecompo, timecompo=jtimecompo) -! -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) = VALUE - EXIT - END IF - END DO - END DO -END DO -! -DEALLOCATE (row, col) -! -END PROCEDURE obj_set13 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set14 -! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk - -row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) -col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & - & spacecompo=jspacecompo, timecompo=jtimecompo) -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) = VALUE - EXIT - END IF - END DO - END DO -END DO -DEALLOCATE (row, col) -END PROCEDURE obj_set14 - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set15 -CALL COPY(Y=obj%A, X=VALUE%A) -IF (PRESENT(scale)) THEN - CALL SCAL(X=obj%A, A=scale) -END IF -END PROCEDURE obj_set15 - -!---------------------------------------------------------------------------- -! SetIA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SetIA -CALL SetIA(obj%csr, irow, VALUE) -END PROCEDURE obj_SetIA - -!---------------------------------------------------------------------------- -! SetJA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SetJA -CALL SetJA(obj%csr, indx, VALUE) -END PROCEDURE obj_SetJA - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 deleted file mode 100644 index ea518429f..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 +++ /dev/null @@ -1,314 +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: 22 March 2021 -! summary: It contains method for setting values in [[CSRMatrix_]] - -SUBMODULE(CSRMatrix_SetRowMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow1 - !! -#ifdef DEBUG_VER - !! -IF (SIZE(value) .LT. obj%csr%ncol .OR. irow .GT. SIZE(obj, 1)) THEN - CALL ErrorMSG( & - & Msg="SIZE of value vector should be same as number of col & - & in sparse matrix or irow is out of bound", & - & File="CSRMatrix_Method@setMethod.F90", & - & Routine="csrMat_setRow1", Line=__LINE__, UnitNo=stdout) - RETURN -END IF -#endif - !! -obj%A(obj%csr%IA(irow):obj%csr%IA(irow + 1) - 1) = value( & - & obj%csr%JA(obj%csr%IA(irow):obj%csr%IA(irow + 1) - 1)) - !! -END PROCEDURE csrMat_setRow1 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow1b -INTEGER(I4B) :: ii - !! -DO ii = 1, size(irow) - !! - obj%A(obj%csr%IA(irow(ii)):obj%csr%IA(irow(ii) + 1) - 1) & - & = value(obj%csr%JA(obj%csr%IA(irow(ii)) & - & :obj%csr%IA(irow(ii) + 1) - 1)) - !! -END DO - !! -END PROCEDURE csrMat_setRow1b - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow2 -CALL csrMat_setRow1( & - & obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & idof=idof), & - & value=value) -END PROCEDURE csrMat_setRow2 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow3 -obj%A(obj%csr%IA(irow):obj%csr%IA(irow + 1) - 1) = value -END PROCEDURE csrMat_setRow3 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow3b -INTEGER(I4B) :: ii - !! -DO ii = 1, size(irow) - obj%A(obj%csr%IA(irow(ii)):obj%csr%IA(irow(ii) + 1) - 1) = value -END DO - !! -END PROCEDURE csrMat_setRow3b - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow4 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc(obj=obj%csr%idof, nodenum=nodenum, idof=idof),& - & value=value) - !! -END PROCEDURE csrMat_setRow4 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow5 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc(obj=obj%csr%idof, nodenum=nodenum, ivar=ivar, & - & idof=idof), & - & value=value) - !! -END PROCEDURE csrMat_setRow5 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow6 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc(obj=obj%csr%idof, nodenum=nodenum, ivar=ivar, & - & idof=idof), & - & value=value) - !! -END PROCEDURE csrMat_setRow6 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow7 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow7 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow8 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow8 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow9 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow9 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow10 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow10 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow11 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow11 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow12 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow12 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow13 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow13 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow14 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow14 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow15 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow15 - -!---------------------------------------------------------------------------- -! setRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE csrMat_setRow16 - !! -CALL SetRow(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo), & - & value=value) - !! -END PROCEDURE csrMat_setRow16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 deleted file mode 100644 index 339f0bc13..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 +++ /dev/null @@ -1,96 +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: 22 March 2021 -! summary: It contains method for setting values in [[CSRMatrix_]] - -SUBMODULE(CSRMatrix_SparsityMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity1 -CALL setSparsity(obj=obj%csr, row=row, col=col) -END PROCEDURE obj_setSparsity1 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity2 -CALL setSparsity(obj=obj%csr, row=row, col=col) -END PROCEDURE obj_setSparsity2 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity3 -CALL setSparsity(obj=obj%csr, row=row, col=col, ivar=ivar, jvar=jvar) -END PROCEDURE obj_setSparsity3 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity4 -CALL setSparsity(obj=obj%csr, row=row, col=col, ivar=ivar, jvar=jvar) -END PROCEDURE obj_setSparsity4 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity_final -REAL(DFP), ALLOCATABLE :: tempA(:) -INTEGER(I4B) :: m -! -IF (.NOT. obj%csr%isSparsityLock) CALL setSparsity(obj%csr) -IF (ALLOCATED(obj%A)) THEN - m = SIZE(obj%A) - IF (m .EQ. 0) THEN - CALL Reallocate(obj%A, obj%csr%nnz) - ELSE IF (m .NE. obj%csr%nnz) THEN - tempA = obj%A - CALL Reallocate(obj%A, obj%csr%nnz) - IF (SIZE(obj%A) .GE. SIZE(tempA)) THEN - obj%A(1:SIZE(tempA)) = tempA(:) - ELSE - obj%A(1:obj%csr%nnz) = tempA(1:obj%csr%nnz) - END IF - DEALLOCATE (tempA) - END IF -ELSE - CALL Reallocate(obj%A, obj%csr%nnz) -END IF -!> Sort entries according to their column index -CALL CSORT(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, .TRUE.) -obj%csr%isSorted = .TRUE. -obj%csr%isSparsityLock = .FALSE. -CALL setSparsity(obj%csr) -END PROCEDURE obj_setSparsity_final - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 deleted file mode 100644 index 70aed6273..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 +++ /dev/null @@ -1,458 +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(CSRMatrix_SpectralMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SymSmallestEigenVal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLargestEigenVal1 -CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal1" -INTEGER(I4B), PARAMETER :: nev = 1 -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0 -CHARACTER(1), PARAMETER :: bmat = "I" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, d(nev), sigma -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -! -! int scalar -! -which0 = INPUT(default="LA", option=which) -n = SIZE(mat, 1) -ncv0 = input(default=MIN(20_I4B, n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -! -! iparam -! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 1 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - ! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - ! - ! Perform MatVec Mult - ! y = MATMUL(mat, X) - ! x => WORKD(ipntr(1):ipntr(1)+N-1) - ! y => WORKD(ipntr(2):ipntr(2)+N-1) - ! - CALL MatVec( & - & obj=mat, & - & x=workd(ipntr(1):ipntr(1) + n - 1), & - & y=workd(ipntr(2):ipntr(2) + n - 1)) - ! - ELSE - EXIT - END IF -END DO -! -! we are not getting rvec, therefore ldz=1, -! othereise ldz = N -! -CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=d, z=v, ldz=1, sigma=sigma, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) -! -IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(INFO) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP -ELSE - ans = d(1) -END IF -! -DEALLOCATE (resid, v, workd, workl, SELECT) -! -END PROCEDURE SymLargestEigenVal1 - -!---------------------------------------------------------------------------- -! SymLargestEigenVal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLargestEigenVal2 -CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal2" -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0 -CHARACTER(1), PARAMETER :: bmat = "I" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, sigma -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -! -! int scalar -! -which0 = INPUT(default="LA", option=which) -n = SIZE(mat, 1) -ncv0 = input(default=MIN(MAX(20_I4B, 2 * nev + 1), n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -! -! iparam -! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 1 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -! -DO - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - ! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - ! - ! Perform MatVec Mult - ! y = MATMUL(mat, X) - ! x => WORKD(ipntr(1):ipntr(1)+N-1) - ! y => WORKD(ipntr(2):ipntr(2)+N-1) - ! - CALL MatVec( & - & obj=mat, & - & x=workd(ipntr(1):ipntr(1) + n - 1), & - & y=workd(ipntr(2):ipntr(2) + n - 1)) - ! - ELSE - EXIT - END IF -END DO -! -! we are not getting rvec, therefore ldz=1, -! othereise ldz = N -! -CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=ans, z=v, ldz=1, sigma=sigma, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) -!! -IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(INFO) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP -END IF -! -DEALLOCATE (resid, v, workd, workl, SELECT) -! -END PROCEDURE SymLargestEigenVal2 - -!---------------------------------------------------------------------------- -! SymSmallestEigenVal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymSmallestEigenVal1 -CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal1" -INTEGER(I4B), PARAMETER :: nev = 1 -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & - & ncv0, ii -CHARACTER(1), PARAMETER :: bmat = "I", uplo = "U" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, d(nev), sigma0 -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -INTEGER(I4B) :: info1 -! -! int scalar -! -sigma0 = 0.0_DFP -! -! note to get smallest value, we transform the problem to -! find largest value. -! -IF (PRESENT(which)) THEN - which0 = "L"//which(2:2) -ELSE - which0 = "LA" -END IF -! -n = SIZE(mat, 1) -ncv0 = input(default=MIN(20_I4B, n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -! -! iparam -! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 3 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -! -DO - ! - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - EXIT - END IF - ! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - ! - ! LU Solve - ! mat0 * y = x - ! x => WORKD(ipntr(1):ipntr(1)+N-1) - ! y => WORKD(ipntr(2):ipntr(2)+N-1) - ! - CALL LinSolve( & - & A=mat, & - & X=WORKD(ipntr(2):ipntr(2) + N - 1), & - & B=WORKD(ipntr(1):ipntr(1) + N - 1), & - & isTranspose=.FALSE., & - & isFactored=.TRUE., & - & PrintStat=yes_no_t%NO, & - & info=info1) - ! - IF (info1 .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error occured in LinSolve() errorCode="//tostring(info1), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymSmallestEigenVal1()") - STOP - END IF - !! - ELSE - EXIT - END IF -END DO -! -! we are not getting rvec, therefore ldz=1, -! othereise ldz = N -! -IF (info .EQ. 0) THEN - CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=d, z=v, ldz=1, sigma=sigma0, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - STOP - ELSE - ans = d(1) - END IF -END IF -! -DEALLOCATE (resid, v, workd, workl, SELECT) -! -END PROCEDURE SymSmallestEigenVal1 - -!---------------------------------------------------------------------------- -! SymSmallestEigenVal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymSmallestEigenVal2 -CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal2" -INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), & - & ipntr(11), maxIter0, n, ncv0, ii -CHARACTER(1), PARAMETER :: bmat = "I" -CHARACTER(2) :: which0 -REAL(DFP) :: tol0, sigma0 -REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) -TYPE(String) :: err_msg -LOGICAL(LGT), ALLOCATABLE :: SELECT(:) -INTEGER(I4B) :: info1 -! -! int scalar -! -sigma0 = 0.0_DFP -! sigma0 = INPUT(default=0.0_DFP, option=sigma) -! -! note to get smallest value, we transform the problem to -! find largest value. -! -IF (PRESENT(which)) THEN - which0 = "L"//which(2:2) -ELSE - which0 = "LA" -END IF -! -n = SIZE(mat, 1) -ncv0 = input(default=MIN(20_I4B, n), option=ncv) -lworkl = ncv0 * (ncv0 + 8) -ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) -ldv = SIZE(v, 1) -ido = 0 -info = 0 -maxIter0 = INPUT(option=maxIter, default=10 * n) -tol0 = INPUT(option=tol, default=zero) -! -! iparam -! -iparam(1) = 1 !! ishift -iparam(3) = maxIter0 !! maxiter -iparam(4) = 1 !! nb -iparam(7) = 3 !! mode -iparam(2) = 0 !! deprecated -iparam(5) = 0 !! out -iparam(6) = 0 !! iupd, deprecated -iparam(8) = 0 !! np, na -iparam(9:11) = 0 !! OUT -ipntr = 0 -! -DO - ! - CALL F77_SAUPD( & - & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & - & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & - & lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SAUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0_DFP - STOP - END IF - ! - IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN - ! - ! LU Solve - ! mat0 * y = x - ! x => WORKD(ipntr(1):ipntr(1)+N-1) - ! y => WORKD(ipntr(2):ipntr(2)+N-1) - ! - CALL LinSolve( & - & A=mat, & - & X=WORKD(ipntr(2):ipntr(2) + N - 1), & - & B=WORKD(ipntr(1):ipntr(1) + N - 1), & - & isTranspose=.FALSE., & - & isFactored=.TRUE., & - & PrintStat=yes_no_t%NO, & - & info=info1) - ! - IF (info1 .NE. 0) THEN - CALL ErrorMsg( & - & msg="Error occured in LinSolve() errorCode="//tostring(info1), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymSmallestEigenVal2()") - STOP - END IF - !! - ELSE - EXIT - END IF -END DO -! -! we are not getting rvec, therefore ldz=1, -! othereise ldz = N -! -IF (info .EQ. 0) THEN - CALL F77_SEUPD( & - & rvec=.FALSE., howmny='All', SELECT=SELECT, & - & d=ans, z=v, ldz=1, sigma=sigma0, & - & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & - & resid=resid, ncv=ncv0, v=v, ldv=ldv, & - & iparam=iparam, ipntr=ipntr, workd=workd, & - & workl=workl, lworkl=lworkl, info=info) - ! - IF (info .NE. 0) THEN - err_msg = SEUPD_ErrorMsg(info) - CALL Display(err_msg, msg="", unitno=stdout) - ans = 0.0 - END IF -END IF -! -! Cleanup -! -DEALLOCATE (resid, v, workd, workl, SELECT) -! -END PROCEDURE SymSmallestEigenVal2 - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 deleted file mode 100644 index b88889eaf..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 +++ /dev/null @@ -1,1584 +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(CSRMatrix_Superlu) Methods -USE BaseMethod -USE GlobalData, ONLY: stderr -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! CheckErrorCSRMatrix -!---------------------------------------------------------------------------- - -SUBROUTINE CheckErrorCSRMatrix(obj, lineNo, routine) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: lineNo - CHARACTER(*), INTENT(IN) :: routine - ! - IF (.NOT. ALLOCATED(obj%A)) THEN - CALL ErrorMsg(& - & msg="CSRMatrix_::obj%A is not allocated", & - & file=__FILE__, & - & routine=routine, & - & line=lineNo, & - & unitno=stderr & - & ) - STOP - END IF - - IF (.NOT. obj%csr%isInitiated) THEN - CALL ErrorMsg(& - & msg="CSRMatrix_::obj%csr is not initiated", & - & file=__FILE__, & - & routine=routine, & - & line=lineNo, & - & unitno=stderr & - & ) - STOP - END IF - - IF (.NOT. obj%csr%isSparsityLock) THEN - CALL ErrorMsg(& - & msg="CSRMatrix_::obj%csr%isSparsityLock is not True", & - & file=__FILE__, & - & routine=routine, & - & line=lineNo, & - & unitno=stderr & - & ) - STOP - END IF - -END SUBROUTINE CheckErrorCSRMatrix - -!---------------------------------------------------------------------------- -! InitiateSuperluA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InitiateSuperluA -#ifdef USE_SuperLU -! check if csr is initiated -! check if csr sparsity is locked -! check if A is allocated -INTEGER(I4B) :: nnz, m, n, ii -! -CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & -& routine="InitiateSuperluA()") -! -IF (ALLOCATED(obj%slu%nzval) & - & .OR. ALLOCATED(obj%slu%ia) & - & .OR. ALLOCATED(obj%slu%ja)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu nzval, ia, ja are already allocated", & - & file=__FILE__, & - & routine="InitiateSuperluA()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (obj%slu%isAInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%A is already Initiated", & - & file=__FILE__, & - & routine="InitiateSuperluA()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -obj%slu%isAInitiated = .TRUE. - -nnz = SIZE(obj%A) -m = SIZE(obj, 1) -n = SIZE(obj, 2) - -CALL Reallocate(obj%slu%nzval, nnz) -CALL Reallocate(obj%slu%ia, m + 1) -CALL Reallocate(obj%slu%ja, nnz) - -CALL Copy(x=obj%A, y=obj%slu%nzval) - -DO CONCURRENT(ii=1:m + 1) - obj%slu%ia(ii) = obj%csr%ia(ii) - 1 -END DO - -DO CONCURRENT(ii=1:nnz) - obj%slu%ja(ii) = obj%csr%ja(ii) - 1 -END DO - -CALL dCreate_CompCol_Matrix( & - & A=obj%slu%A, & - & m=m, & - & n=n, & - & nnz=nnz, & - & nzval=obj%slu%nzval, & - & rowind=obj%slu%ja, & - & colptr=obj%slu%ia, & - & stype=stype_t%SLU_NC, & - & dtype=dtype_t%SLU_D, & - & mtype=mtype_t%SLU_GE) - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="InitiateSuperluA()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif - -END PROCEDURE InitiateSuperluA - -!---------------------------------------------------------------------------- -! SetSuperluA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetSuperluA -#ifdef USE_SuperLU -! check if csr is initiated -! check if csr sparsity is locked -! check if A is allocated -INTEGER(I4B) :: nnz, m, n -! -CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & -& routine="SetSuperluA()") -! -IF (.NOT. ALLOCATED(obj%slu%nzval) & - & .OR. .NOT. ALLOCATED(obj%slu%ia) & - & .OR. .NOT. ALLOCATED(obj%slu%ja)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu nzval, ia, ja are not allocated", & - & file=__FILE__, & - & routine="SetSuperluA()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. obj%slu%isAInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%A is not Initiated", & - & file=__FILE__, & - & routine="SetSuperluA()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -nnz = SIZE(obj%A) -m = SIZE(obj, 1) -n = SIZE(obj, 2) - -IF (SIZE(obj%slu%nzval) .NE. nnz & - & .OR. SIZE(obj%slu%ia) .NE. m + 1 & - & .OR. SIZE(obj%slu%ja) .NE. nnz) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu nzval, ia, ja are allocated & - & but there is some issue with size and shape", & - & file=__FILE__, & - & routine="SetSuperluA()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL Copy(x=obj%A, y=obj%slu%nzval) - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="SetSuperluA()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif - -END PROCEDURE SetSuperluA - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InitiateSuperluRHS1 -#ifdef USE_SuperLU -INTEGER(I4B) :: nrhs, m, ii - -IF (obj%slu%isBInitiated .OR. obj%slu%isXInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%B or obj%slu%x is already Initiated", & - & file=__FILE__, & - & routine="InitiateSuperluRHS1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -obj%slu%isBInitiated = .TRUE. -obj%slu%isXInitiated = .TRUE. - -IF (ALLOCATED(obj%slu%rhs) .OR. ALLOCATED(obj%slu%sol)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%rhs or obj%slu%sol is already Allocated", & - & file=__FILE__, & - & routine="InitiateSuperluRHS1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & - & routine="InitiateSuperluRHS1()") - -nrhs = 1 -m = SIZE(rhs, 1) - -CALL Reallocate(obj%slu%rhs, m, nrhs) -CALL Reallocate(obj%slu%sol, m, nrhs) - -DO CONCURRENT(ii=1:m) - obj%slu%rhs(ii, 1) = rhs(ii) -END DO - -CALL dCreate_Dense_Matrix( & - & A=obj%slu%B, & - & m=m, & - & n=nrhs, & - & x=obj%slu%rhs, & - & ldx=m, & - & stype=stype_t%SLU_DN, & - & dtype=dtype_t%SLU_D, & - & mtype=mtype_t%SLU_GE) - -CALL dCreate_Dense_Matrix( & - & A=obj%slu%X, & - & m=m, & - & n=nrhs, & - & x=obj%slu%sol, & - & ldx=m, & - & stype=stype_t%SLU_DN, & - & dtype=dtype_t%SLU_D, & - & mtype=mtype_t%SLU_GE) - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="InitiateSuperlu()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif -END PROCEDURE InitiateSuperluRHS1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InitiateSuperluRHS2 -#ifdef USE_SuperLU -INTEGER(I4B) :: nrhs, m, ii, jj - -IF (obj%slu%isBInitiated .OR. obj%slu%isXInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%B is already Initiated", & - & file=__FILE__, & - & routine="InitiateSuperluRHS2()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -obj%slu%isBInitiated = .TRUE. -obj%slu%isXInitiated = .TRUE. - -IF (ALLOCATED(obj%slu%rhs) .OR. ALLOCATED(obj%slu%sol)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%rhs obj%slu%sol is already Allocated", & - & file=__FILE__, & - & routine="InitiateSuperluRHS1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & - & routine="InitiateSuperluRHS2()") - -nrhs = SIZE(rhs, 2) -m = SIZE(rhs, 1) - -CALL Reallocate(obj%slu%rhs, m, nrhs) -CALL Reallocate(obj%slu%sol, m, nrhs) - -DO CONCURRENT(ii=1:m, jj=1:nrhs) - obj%slu%rhs(ii, jj) = rhs(ii, jj) -END DO - -CALL dCreate_Dense_Matrix( & - & A=obj%slu%B, & - & m=m, & - & n=nrhs, & - & x=obj%slu%rhs, & - & ldx=m, & - & stype=stype_t%SLU_DN, & - & dtype=dtype_t%SLU_D, & - & mtype=mtype_t%SLU_GE) - -CALL dCreate_Dense_Matrix( & - & A=obj%slu%X, & - & m=m, & - & n=nrhs, & - & x=obj%slu%sol, & - & ldx=m, & - & stype=stype_t%SLU_DN, & - & dtype=dtype_t%SLU_D, & - & mtype=mtype_t%SLU_GE) - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="InitiateSuperlu()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif - -END PROCEDURE InitiateSuperluRHS2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetSuperluRHS1 -#ifdef USE_SuperLU -INTEGER(I4B) :: nrhs, m, ii - -IF (.NOT. obj%slu%isBInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%B is not Initiated", & - & file=__FILE__, & - & routine="SetSuperluRHS1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%rhs)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%rhs is not Allocated", & - & file=__FILE__, & - & routine="SetSuperluRHS1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL CheckErrorCSRMatrix(& - & obj=obj, & - & lineNo=__LINE__, & - & routine="SetSuperluRHS1()") - -nrhs = 1 -m = SIZE(rhs, 1) - -IF (SIZE(obj%slu%rhs, 1) .NE. m .OR. SIZE(obj%slu%rhs, 2) .NE. nrhs) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%rhs Allocated but shape does not match", & - & file=__FILE__, & - & routine="SetSuperluRHS1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -DO CONCURRENT(ii=1:m) - obj%slu%rhs(ii, 1) = rhs(ii) -END DO - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="InitiateSuperlu()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif -END PROCEDURE SetSuperluRHS1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetSuperluRHS2 -#ifdef USE_SuperLU -INTEGER(I4B) :: nrhs, m, ii, jj - -IF (.NOT. obj%slu%isBInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%B is not Initiated", & - & file=__FILE__, & - & routine="SetSuperluRHS2()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%rhs)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%rhs is not Allocated", & - & file=__FILE__, & - & routine="InitiateSuperluRHS1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & - & routine="SetSuperluRHS2()") - -nrhs = SIZE(rhs, 2) -m = SIZE(rhs, 1) - -IF (SIZE(obj%slu%rhs, 1) .NE. m .OR. SIZE(obj%slu%rhs, 2) .NE. nrhs) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%rhs Allocated but shape does not match", & - & file=__FILE__, & - & routine="SetSuperluRHS2()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -DO CONCURRENT(ii=1:m, jj=1:nrhs) - obj%slu%rhs(ii, jj) = rhs(ii, jj) -END DO - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="InitiateSuperlu()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif - -END PROCEDURE SetSuperluRHS2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetSuperluX1 -#ifdef USE_SuperLU -INTEGER(I4B) :: nrhs, m, ii - -IF (.NOT. obj%slu%isXInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%X is NOT Initiated", & - & file=__FILE__, & - & routine="GetSuperluX1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%sol)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%sol is not Allocated", & - & file=__FILE__, & - & routine="GetSuperluX1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL CheckErrorCSRMatrix( & - & obj=obj, lineNo=__LINE__, & - & routine="GetSuperluX1()") - -nrhs = 1 -m = SIZE(x, 1) - -IF (SIZE(obj%slu%sol, 1) .NE. m .OR. SIZE(obj%slu%sol, 2) .NE. nrhs) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%rhs Allocated but shape does not match", & - & file=__FILE__, & - & routine="GetSuperluX1()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -DO CONCURRENT(ii=1:m) - x(ii) = obj%slu%sol(ii, 1) -END DO - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="GetSuperluX1()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif -END PROCEDURE GetSuperluX1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetSuperluX2 -#ifdef USE_SuperLU -INTEGER(I4B) :: nrhs, m, ii, jj - -IF (.NOT. obj%slu%isXInitiated) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%X is not Initiated", & - & file=__FILE__, & - & routine="GetSuperluX2()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%sol)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%sol is not Allocated", & - & file=__FILE__, & - & routine="GetSuperluX2()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL CheckErrorCSRMatrix( & - & obj=obj, lineNo=__LINE__, & - & routine="GetSuperluX2()") - -m = SIZE(x, 1) -nrhs = SIZE(x, 2) - -IF (SIZE(obj%slu%sol, 1) .NE. m .OR. SIZE(obj%slu%sol, 2) .NE. nrhs) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%sol Allocated but shape does not match", & - & file=__FILE__, & - & routine="GetSuperluX2()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -DO CONCURRENT(ii=1:m, jj=1:nrhs) - x(ii, jj) = obj%slu%sol(ii, jj) -END DO - -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="GetSuperluX2()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif - -END PROCEDURE GetSuperluX2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InitiateSuperLuOptions -#ifdef USE_SuperLU -CALL set_default_options(obj%slu%options) -obj%slu%options%Equil = yes_no_t%YES -obj%slu%options%Trans = Trans_t%TRANS -obj%slu%options%ColPerm = colperm_t%COLAMD -obj%slu%options%Fact = Fact_t%DOFACT -obj%slu%options%IterRefine = IterRefine_t%SLU_DOUBLE -obj%slu%options%PivotGrowth = yes_no_t%YES -obj%slu%options%DiagPivotThresh = 1.0 -obj%slu%options%ConditionNumber = yes_no_t%YES -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="InitiateSuperLuOptions()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif -END PROCEDURE InitiateSuperLuOptions - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetSuperluOptions -#ifdef USE_SuperLU - -IF (PRESENT(Fact)) THEN - obj%slu%options%Fact = Fact -END IF - -IF (PRESENT(Equil)) THEN - obj%slu%options%Equil = Equil -END IF - -IF (PRESENT(ColPerm)) THEN - obj%slu%options%ColPerm = ColPerm -END IF - -IF (PRESENT(Trans)) THEN - obj%slu%options%Trans = Trans -END IF - -IF (PRESENT(IterRefine)) THEN - obj%slu%options%IterRefine = IterRefine -END IF - -IF (PRESENT(DiagPivotThresh)) THEN - obj%slu%options%DiagPivotThresh = DiagPivotThresh -END IF - -IF (PRESENT(SymmetricMode)) THEN - obj%slu%options%SymmetricMode = SymmetricMode -END IF - -IF (PRESENT(PivotGrowth)) THEN - obj%slu%options%PivotGrowth = PivotGrowth -END IF - -IF (PRESENT(ConditionNumber)) THEN - obj%slu%options%ConditionNumber = ConditionNumber -END IF - -IF (PRESENT(RowPerm)) THEN - obj%slu%options%RowPerm = RowPerm -END IF - -IF (PRESENT(ILU_DropRule)) THEN - obj%slu%options%ILU_DropRule = ILU_DropRule -END IF - -IF (PRESENT(ILU_DropTol)) THEN - obj%slu%options%ILU_DropTol = ILU_DropTol -END IF - -IF (PRESENT(ILU_FillFactor)) THEN - obj%slu%options%ILU_FillFactor = ILU_FillFactor -END IF - -IF (PRESENT(ILU_MILU)) THEN - obj%slu%options%ILU_MILU = ILU_MILU -END IF - -IF (PRESENT(PrintStat)) THEN - obj%slu%options%PrintStat = PrintStat -END IF - -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="SetSuperluOptions()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE SetSuperluOptions - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SuperluDGSSVX -#ifdef USE_SuperLU - -! SUBROUTINE dgssvx(options, A, perm_c, perm_r, & -! & etree, equed, R, C, L, U, work, lwork, & -! & B, X, recip_pivot_growth, rcond, ferr, berr, & -! & Glu, mem_usage, stat, info) & - -IF (.NOT. ALLOCATED(obj%slu%perm_c)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%perm_c is not allocated", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%perm_r)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%perm_r is not allocated", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%etree)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%etree is not allocated", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%R)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%R is not allocated", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%C)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%C is not allocated", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%ferr)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%ferr is not allocated", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -IF (.NOT. ALLOCATED(obj%slu%berr)) THEN - CALL ErrorMsg(& - & msg="Superlu_::obj%slu%berr is not allocated", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) - STOP -END IF - -CALL dgssvx(& - & options=obj%slu%options, & - & A=obj%slu%A, & - & perm_c=obj%slu%perm_c, & - & perm_r=obj%slu%perm_r, & - & etree=obj%slu%etree, & - & equed=obj%slu%equed, & - & R=obj%slu%R, & - & C=obj%slu%C, & - & L=obj%slu%L, & - & U=obj%slu%U, & - & Work=obj%slu%Work, & - & B=obj%slu%B, & - & X=obj%slu%X, & - & recip_pivot_growth=obj%slu%recip_pivot_growth, & - & rcond=obj%slu%rcond, & - & ferr=obj%slu%ferr, & - & berr=obj%slu%berr, & - & Glu=obj%slu%Glu, & - & mem_usage=obj%slu%mem_usage, & - & stat=obj%slu%stat, & - & lwork=obj%slu%lwork, & - & info=obj%slu%info) - -obj%slu%isLInitiated = .TRUE. -obj%slu%isUInitiated = .TRUE. -obj%slu%isGluInitiated = .TRUE. - -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="SuperluDGSSVX()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE SuperluDGSSVX - -!---------------------------------------------------------------------------- -! InitiateSuperluDGSSVXParam -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-01-27 -! summary: Initiate Superlu dgssvx variables - -MODULE PROCEDURE InitiateSuperluDGSSVXParam -#ifdef USE_SuperLU -INTEGER(I4B) :: m, n, nnz, nrhs - -m = SIZE(obj, 1) -n = SIZE(obj, 2) -nnz = GetNNZ(obj) -nrhs = SIZE(obj%slu%rhs, 2) - -CALL Reallocate(obj%slu%perm_c, n) -CALL Reallocate(obj%slu%perm_r, m) -CALL Reallocate(obj%slu%etree, n) -CALL Reallocate(obj%slu%R, m) -CALL Reallocate(obj%slu%C, n) -CALL Reallocate(obj%slu%ferr, nrhs) -CALL Reallocate(obj%slu%berr, nrhs) - -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="InitiateSuperluDGSSVXParam()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE InitiateSuperluDGSSVXParam - -!---------------------------------------------------------------------------- -! SuperluDisplayStat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SuperluDisplayStat -#ifdef USE_SuperLU -INTEGER(I4B) :: ii, nrhs - -IF (obj%slu%options%PrintStat .EQ. yes_no_t%YES) THEN - IF (obj%slu%options%PivotGrowth .EQ. yes_no_t%YES) THEN - CALL Display(obj%slu%recip_pivot_growth, "recip_pivot_growth=") - END IF - - IF (obj%slu%options%ConditionNumber .EQ. yes_no_t%YES) THEN - CALL Display(obj%slu%rcond, "rcond=") - END IF - - IF (obj%slu%options%IterRefine .NE. IterRefine_t%NOREFINE) THEN - CALL Display("rhs, Steps, Ferr, Berr") - nrhs = SIZE(obj%slu%rhs, 2) - DO ii = 1, nrhs - CALL Display(& - & [& - & REAL(ii, kind=DFP), & - & REAL(obj%slu%stat%RefineSteps, kind=DFP), & - & obj%slu%Ferr(ii), & - & obj%slu%Berr(ii) & - & ], "", orient="row") - END DO - END IF - CALL StatPrint(obj%slu%stat) - CALL Display(obj%slu%mem_usage%total_needed / 1.0E+6, "total size needed = ") - ! WRITE (*, *) "total needed = ", A%slu%mem_usage%total_needed -END IF - -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="SuperluDisplayStat()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE SuperluDisplayStat - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SuperluDeallocate -#ifdef USE_SuperLU -CHARACTER(LEN=*), PARAMETER :: myName = "SuperluDeallocate()" -IF (ASSOCIATED(obj%slu)) THEN - IF (ALLOCATED(obj%slu%rhs)) DEALLOCATE (obj%slu%rhs) - IF (ALLOCATED(obj%slu%sol)) DEALLOCATE (obj%slu%sol) - IF (ALLOCATED(obj%slu%etree)) DEALLOCATE (obj%slu%etree) - IF (ALLOCATED(obj%slu%perm_r)) DEALLOCATE (obj%slu%perm_r) - IF (ALLOCATED(obj%slu%perm_c)) DEALLOCATE (obj%slu%perm_c) - IF (ALLOCATED(obj%slu%R)) DEALLOCATE (obj%slu%R) - IF (ALLOCATED(obj%slu%C)) DEALLOCATE (obj%slu%C) - IF (ALLOCATED(obj%slu%ferr)) DEALLOCATE (obj%slu%ferr) - IF (ALLOCATED(obj%slu%berr)) DEALLOCATE (obj%slu%berr) - IF (ALLOCATED(obj%slu%ia)) DEALLOCATE (obj%slu%ia) - IF (ALLOCATED(obj%slu%ja)) DEALLOCATE (obj%slu%ja) - IF (ALLOCATED(obj%slu%nzval)) DEALLOCATE (obj%slu%nzval) - IF (obj%slu%isAInitiated) THEN - CALL Destroy_SuperMatrix_Store(obj%slu%A) - END IF - IF (obj%slu%isBInitiated) THEN - CALL Destroy_SuperMatrix_Store(obj%slu%B) - END IF - IF (obj%slu%isXInitiated) THEN - CALL Destroy_SuperMatrix_Store(obj%slu%X) - END IF - IF (obj%slu%isLInitiated) THEN - CALL Destroy_SuperNode_Matrix(obj%slu%L) - END IF - IF (obj%slu%isUInitiated) THEN - CALL Destroy_CompCol_Matrix(obj%slu%U) - END IF - IF (obj%slu%lwork .NE. 0) THEN - CALL Superlu_Free(obj%slu%work) - END IF - IF (obj%slu%isStatInitiated) THEN - CALL StatFree(obj%slu%stat) - END IF - obj%slu%lwork = 0 - obj%slu%info = 0 - obj%slu%recip_pivot_growth = 0.0_DFP - obj%slu%rcond = 0.0_DFP - obj%slu%isAInitiated = .FALSE. - obj%slu%isBInitiated = .FALSE. - obj%slu%isXInitiated = .FALSE. - obj%slu%isLInitiated = .FALSE. - obj%slu%isUInitiated = .FALSE. - obj%slu%isGluInitiated = .FALSE. - obj%slu%isStatInitiated = .FALSE. - DEALLOCATE (obj%slu) - obj%slu => NULL() -END IF -#else -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="SuperluDeallocate()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP -#endif -END PROCEDURE SuperluDeallocate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LinSolve1 -#ifdef USE_SuperLU -LOGICAL(LGT) :: isFactored0, isTranspose0 -INTEGER(I4B) :: Trans0 -REAL(DFP) :: DiagPivotThresh0 -INTEGER(I4B) :: ColPerm0 -INTEGER(I4B) :: IterRefine0 -INTEGER(I4B) :: PivotGrowth0 -INTEGER(I4B) :: ConditionNumber0 -INTEGER(I4B) :: Equil0 -INTEGER(I4B) :: SymmetricMode0 -INTEGER(I4B) :: PrintStat0 - -CALL CheckErrorCSRMatrix( & - & obj=A, & - & lineNo=__LINE__, & - & routine="LinSolve1()") - -isTranspose0 = input(option=isTranspose, default=.FALSE.) - -IF (isTranspose0) THEN - Trans0 = Trans_t%NOTRANS -ELSE - Trans0 = Trans_t%TRANS -END IF - -Equil0 = input(option=Equil, default=yes_no_t%YES) -ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) -IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) -DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) -PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) -ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) -SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) -PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) - -! First call -! if obj%slu%A is not initiated - -IF (.NOT. ASSOCIATED(A%slu)) THEN - ALLOCATE (A%slu) -END IF - -IF (.NOT. A%slu%isAInitiated) THEN - CALL InitiateSuperluA(obj=A) - CALL InitiateSuperluRHS(obj=A, rhs=B) - CALL InitiateSuperLuOptions(obj=A) - CALL SetSuperluOptions( & - & obj=A, & - & Equil=Equil0, & - & Trans=Trans0, & - & ColPerm=ColPerm0, & - & Fact=Fact_t%DOFACT, & - & IterRefine=IterRefine0, & - & PivotGrowth=PivotGrowth0, & - & DiagPivotThresh=DiagPivotThresh0, & - & SymmetricMode=SymmetricMode0, & - & PrintStat=PrintStat0, & - & ConditionNumber=ConditionNumber0 & - & ) - CALL InitiateSuperluDGSSVXParam(obj=A) - CALL StatInit(A%slu%stat) - A%slu%isStatInitiated = .TRUE. - -ELSE - isFactored0 = input(option=isFactored, default=.FALSE.) - IF (isFactored0) THEN - ! - ! WE dont perform factorization - ! - CALL SetSuperluRHS(obj=A, rhs=B) - ! CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & - ! & Trans=Trans0) - CALL SetSuperluOptions( & - & obj=A, & - & Equil=Equil0, & - & Trans=Trans0, & - & ColPerm=ColPerm0, & - & Fact=Fact_t%FACTORED, & - & IterRefine=IterRefine0, & - & PivotGrowth=PivotGrowth0, & - & DiagPivotThresh=DiagPivotThresh0, & - & SymmetricMode=SymmetricMode0, & - & PrintStat=PrintStat0, & - & ConditionNumber=ConditionNumber0 & - & ) - ELSE - ! - ! perform factorization - ! only value has changed, sparsity is the same - ! Because sparsity is the same we do not - ! call InitiateSuperluDGSSVXParam - ! - CALL SetSuperluA(obj=A) - CALL SetSuperluRHS(obj=A, rhs=B) - ! CALL SetSuperluOptions(& - ! & obj=A, & - ! & Fact=Fact_t%SamePattern, & - ! & Trans=Trans0) - ! - CALL SetSuperluOptions( & - & obj=A, & - & Equil=Equil0, & - & Trans=Trans0, & - & ColPerm=ColPerm0, & - & Fact=Fact_t%SamePattern, & - & IterRefine=IterRefine0, & - & PivotGrowth=PivotGrowth0, & - & DiagPivotThresh=DiagPivotThresh0, & - & SymmetricMode=SymmetricMode0, & - & PrintStat=PrintStat0, & - & ConditionNumber=ConditionNumber0 & - & ) - END IF - -END IF - -CALL SuperluDGSSVX(obj=A) -CALL Copy(x=A%slu%sol(:, 1), y=x) -IF (PRESENT(info)) info = A%slu%info -CALL SuperluDisplayStat(obj=A) - -IF (A%slu%lwork .EQ. 0) THEN - IF (A%slu%isLInitiated) THEN - CALL Destroy_SuperNode_Matrix(A%slu%L) - A%slu%isLInitiated = .FALSE. - END IF - IF (A%slu%isUInitiated) THEN - CALL Destroy_CompCol_Matrix(A%slu%U) - A%slu%isUInitiated = .FALSE. - END IF -END IF - -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="LinSolve1()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE LinSolve1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LinSolve2 -#ifdef USE_SuperLU -LOGICAL(LGT) :: isFactored0, isTranspose0 -INTEGER(I4B) :: Trans0 -REAL(DFP) :: DiagPivotThresh0 -INTEGER(I4B) :: ColPerm0 -INTEGER(I4B) :: IterRefine0 -INTEGER(I4B) :: PivotGrowth0 -INTEGER(I4B) :: ConditionNumber0 -INTEGER(I4B) :: Equil0 -INTEGER(I4B) :: SymmetricMode0 -INTEGER(I4B) :: PrintStat0 -INTEGER(I4B) :: ii, nrhs - -CALL CheckErrorCSRMatrix( & - & obj=A, & - & lineNo=__LINE__, & - & routine="LinSolve2()") - -isTranspose0 = input(option=isTranspose, default=.FALSE.) - -IF (isTranspose0) THEN - Trans0 = Trans_t%NOTRANS -ELSE - Trans0 = Trans_t%TRANS -END IF - -Equil0 = input(option=Equil, default=yes_no_t%YES) -ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) -IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) -DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) -PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) -ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) -SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) -PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) - -! First call -! if obj%slu%A is not initiated - -IF (.NOT. ASSOCIATED(A%slu)) THEN - ALLOCATE (A%slu) -END IF - -IF (.NOT. A%slu%isAInitiated) THEN - CALL InitiateSuperluA(obj=A) - CALL InitiateSuperluRHS(obj=A, rhs=B) - CALL InitiateSuperLuOptions(obj=A) - CALL SetSuperluOptions( & - & obj=A, & - & Equil=Equil0, & - & Trans=Trans0, & - & ColPerm=ColPerm0, & - & Fact=Fact_t%DOFACT, & - & IterRefine=IterRefine0, & - & PivotGrowth=PivotGrowth0, & - & DiagPivotThresh=DiagPivotThresh0, & - & SymmetricMode=SymmetricMode0, & - & PrintStat=PrintStat0, & - & ConditionNumber=ConditionNumber0 & - & ) - CALL InitiateSuperluDGSSVXParam(obj=A) - CALL StatInit(A%slu%stat) - A%slu%isStatInitiated = .TRUE. -ELSE - isFactored0 = input(option=isFactored, default=.FALSE.) - IF (isFactored0) THEN - ! - ! WE dont perform factorization - ! - CALL SetSuperluRHS(obj=A, rhs=B) - CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & - & Trans=Trans0) - ELSE - ! - ! perform factorization - ! only value has changed, sparsity is the same - ! Because sparsity is the same we do not - ! call InitiateSuperluDGSSVXParam - ! - CALL SetSuperluA(obj=A) - CALL SetSuperluRHS(obj=A, rhs=B) - CALL SetSuperluOptions(& - & obj=A, & - & Fact=Fact_t%SamePattern, & - & Trans=Trans0) - ! - END IF - -END IF - -CALL SuperluDGSSVX(obj=A) -nrhs = SIZE(x, 2) -DO ii = 1, nrhs - CALL Copy(x=A%slu%sol(:, ii), y=x(:, ii)) -END DO -IF (PRESENT(info)) info = A%slu%info -CALL SuperluDisplayStat(obj=A) - -IF (A%slu%lwork .EQ. 0) THEN - IF (A%slu%isLInitiated) THEN - CALL Destroy_SuperNode_Matrix(A%slu%L) - A%slu%isLInitiated = .FALSE. - END IF - IF (A%slu%isUInitiated) THEN - CALL Destroy_CompCol_Matrix(A%slu%U) - A%slu%isUInitiated = .FALSE. - END IF -END IF - -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="LinSolve2()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE LinSolve2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LinSolve3 -#ifdef USE_SuperLU -LOGICAL(LGT) :: isFactored0, isTranspose0 -INTEGER(I4B) :: Trans0 -REAL(DFP) :: DiagPivotThresh0 -INTEGER(I4B) :: ColPerm0 -INTEGER(I4B) :: IterRefine0 -INTEGER(I4B) :: PivotGrowth0 -INTEGER(I4B) :: ConditionNumber0 -INTEGER(I4B) :: Equil0 -INTEGER(I4B) :: SymmetricMode0 -INTEGER(I4B) :: PrintStat0 - -CALL CheckErrorCSRMatrix( & - & obj=A, & - & lineNo=__LINE__, & - & routine="LinSolve3()") - -isTranspose0 = input(option=isTranspose, default=.FALSE.) - -IF (isTranspose0) THEN - Trans0 = Trans_t%NOTRANS -ELSE - Trans0 = Trans_t%TRANS -END IF - -Equil0 = input(option=Equil, default=yes_no_t%YES) -ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) -IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) -DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) -PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) -ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) -SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) -PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) - -! First call -! if obj%slu%A is not initiated - -IF (.NOT. ASSOCIATED(A%slu)) THEN - ALLOCATE (A%slu) -END IF - -IF (.NOT. A%slu%isAInitiated) THEN - CALL InitiateSuperluA(obj=A) - CALL InitiateSuperluRHS(obj=A, rhs=B) - CALL InitiateSuperLuOptions(obj=A) - CALL SetSuperluOptions( & - & obj=A, & - & Equil=Equil0, & - & Trans=Trans0, & - & ColPerm=ColPerm0, & - & Fact=Fact_t%DOFACT, & - & IterRefine=IterRefine0, & - & PivotGrowth=PivotGrowth0, & - & DiagPivotThresh=DiagPivotThresh0, & - & SymmetricMode=SymmetricMode0, & - & PrintStat=PrintStat0, & - & ConditionNumber=ConditionNumber0 & - & ) - CALL InitiateSuperluDGSSVXParam(obj=A) - CALL StatInit(A%slu%stat) - A%slu%isStatInitiated = .TRUE. -ELSE - isFactored0 = input(option=isFactored, default=.FALSE.) - IF (isFactored0) THEN - ! - ! WE dont perform factorization - ! - CALL SetSuperluRHS(obj=A, rhs=B) - CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & - & Trans=Trans0) - ELSE - ! - ! perform factorization - ! only value has changed, sparsity is the same - ! Because sparsity is the same we do not - ! call InitiateSuperluDGSSVXParam - ! - CALL SetSuperluA(obj=A) - CALL SetSuperluRHS(obj=A, rhs=B) - CALL SetSuperluOptions(& - & obj=A, & - & Fact=Fact_t%SamePattern, & - & Trans=Trans0) - ! - END IF - -END IF - -CALL SuperluDGSSVX(obj=A) -CALL Copy(x=A%slu%sol(:, 1), y=B) -IF (PRESENT(info)) info = A%slu%info -CALL SuperluDisplayStat(obj=A) -IF (A%slu%lwork .EQ. 0) THEN - IF (A%slu%isLInitiated) THEN - CALL Destroy_SuperNode_Matrix(A%slu%L) - A%slu%isLInitiated = .FALSE. - END IF - IF (A%slu%isUInitiated) THEN - CALL Destroy_CompCol_Matrix(A%slu%U) - A%slu%isUInitiated = .FALSE. - END IF -END IF -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="LinSolve3()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE LinSolve3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LinSolve4 -#ifdef USE_SuperLU -LOGICAL(LGT) :: isFactored0, isTranspose0 -INTEGER(I4B) :: Trans0 -REAL(DFP) :: DiagPivotThresh0 -INTEGER(I4B) :: ColPerm0 -INTEGER(I4B) :: IterRefine0 -INTEGER(I4B) :: PivotGrowth0 -INTEGER(I4B) :: ConditionNumber0 -INTEGER(I4B) :: Equil0 -INTEGER(I4B) :: SymmetricMode0 -INTEGER(I4B) :: PrintStat0 -INTEGER(I4B) :: ii, nrhs - -CALL CheckErrorCSRMatrix( & - & obj=A, & - & lineNo=__LINE__, & - & routine="LinSolve4()") - -isTranspose0 = input(option=isTranspose, default=.FALSE.) - -IF (isTranspose0) THEN - Trans0 = Trans_t%NOTRANS -ELSE - Trans0 = Trans_t%TRANS -END IF - -Equil0 = input(option=Equil, default=yes_no_t%YES) -ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) -IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) -DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) -PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) -ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) -SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) -PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) - -! First call -! if obj%slu%A is not initiated - -IF (.NOT. ASSOCIATED(A%slu)) THEN - ALLOCATE (A%slu) -END IF - -IF (.NOT. A%slu%isAInitiated) THEN - CALL InitiateSuperluA(obj=A) - CALL InitiateSuperluRHS(obj=A, rhs=B) - CALL InitiateSuperLuOptions(obj=A) - CALL SetSuperluOptions( & - & obj=A, & - & Equil=Equil0, & - & Trans=Trans0, & - & ColPerm=ColPerm0, & - & Fact=Fact_t%DOFACT, & - & IterRefine=IterRefine0, & - & PivotGrowth=PivotGrowth0, & - & DiagPivotThresh=DiagPivotThresh0, & - & SymmetricMode=SymmetricMode0, & - & PrintStat=PrintStat0, & - & ConditionNumber=ConditionNumber0 & - & ) - CALL InitiateSuperluDGSSVXParam(obj=A) - CALL StatInit(A%slu%stat) - A%slu%isStatInitiated = .TRUE. - - ! new thing here - ! A%slu%lwork = -1 - ! CALL SuperluDGSSVX(obj=A) - ! A%slu%lwork = INT(A%slu%mem_usage%total_needed, kind=C_SIZE_T) - ! A%slu%work = superlu_malloc(A%slu%lwork) - ! STOP - ! new thing stop here -ELSE - isFactored0 = input(option=isFactored, default=.FALSE.) - IF (isFactored0) THEN - ! - ! WE dont perform factorization - ! - CALL SetSuperluRHS(obj=A, rhs=B) - CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & - & Trans=Trans0) - ELSE - ! - ! perform factorization - ! only value has changed, sparsity is the same - ! Because sparsity is the same we do not - ! call InitiateSuperluDGSSVXParam - ! - CALL SetSuperluA(obj=A) - CALL SetSuperluRHS(obj=A, rhs=B) - CALL SetSuperluOptions(& - & obj=A, & - & Fact=Fact_t%SamePattern, & - & Trans=Trans0) - ! - END IF - -END IF - -CALL SuperluDGSSVX(obj=A) -nrhs = SIZE(B, 2) -DO ii = 1, nrhs - CALL Copy(x=A%slu%sol(:, ii), y=B(:, ii)) -END DO -IF (PRESENT(info)) info = A%slu%info -CALL SuperluDisplayStat(obj=A) -IF (A%slu%lwork .EQ. 0) THEN - IF (A%slu%isLInitiated) THEN - CALL Destroy_SuperNode_Matrix(A%slu%L) - A%slu%isLInitiated = .FALSE. - END IF - IF (A%slu%isUInitiated) THEN - CALL Destroy_CompCol_Matrix(A%slu%U) - A%slu%isUInitiated = .FALSE. - END IF -END IF -#else - -CALL ErrorMsg(& - & msg="This routine requires Superlu library, and & - & it seems this library is not linked with the easifemBase", & - & file=__FILE__, & - & routine="LinSolve4()", & - & line=__LINE__, & - & unitno=stderr & - & ) -STOP - -#endif -END PROCEDURE LinSolve4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 deleted file mode 100644 index b80019268..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 +++ /dev/null @@ -1,57 +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(CSRMatrix_SymMatmulMethods) Methods -USE Display_Method -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SymMatSquare -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SymMatSquare -CALL Display("obj_SymMatSquare in "//__FILE__//" is under development.") -STOP - -! INTEGER(I4B) :: ii, jj, nrow, ncol, c1, c2, c, nnz_irow -! REAL(DFP) :: irow(A%max_nnz_row, A%max_nnz_col) -! -! ASSOCIATE (csr2 => obj%csr, csr1 => A%csr, A2 => obj%A, A1 => A%A) -! DO ii = 1, nrow -! c1 = csr1.startColumn.ii -! c2 = csr1.endColumn.ii -! -! ! nnz_row = c2 - c1 -! ! DO jj = 1, nnz_row -! ! tempRow(jj) = A1(c1 + jj - 1) -! ! END DO -! CALL GetCompactRow(obj=obj, VALUE=irow, irow=ii, n=nnz_irow) -! -! DO c = c1, c2 -! jj = csr2%JA(c) -! CALL GetCompactRow(obj=obj, VALUE=jrow, irow=jj, n=nnz_jrow) -! -! A(c) = DOT_PRODUCT() -! -! END DO -! END DO -! END ASSOCIATE - -END PROCEDURE obj_SymMatSquare - -END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 deleted file mode 100644 index 0b07a93f9..000000000 --- a/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 +++ /dev/null @@ -1,855 +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(CSRMatrix_UnaryMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Scal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Scal -CALL SCAL(X=obj%A, A=a) -END PROCEDURE obj_Scal - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Convert1 -INTEGER(I4B) :: i, j, nrow -nrow = SIZE(IA) - 1 -CALL Reallocate(mat, nrow, nrow) -DO i = 1, nrow - DO j = IA(i), IA(i + 1) - 1 - mat(i, JA(j)) = A(j) - END DO -END DO -END PROCEDURE obj_Convert1 - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Convert2 -INTEGER(I4B) :: i, j, nrow, ncol -!! -nrow = SIZE(obj=From, dims=1) -ncol = SIZE(obj=From, dims=2) -!! -CALL Reallocate(To, nrow, ncol) -!! -DO i = 1, nrow - DO j = From%csr%IA(i), From%csr%IA(i + 1) - 1 - To(i, From%csr%JA(j)) = From%A(j) - END DO -END DO -!! -END PROCEDURE obj_Convert2 - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Convert3 -CALL Convert(From=From, To=To%val) -! CALL Convert(A=From%A, IA=From%csr%IA, JA=From%csr%JA, & -! & mat=To%val) -CALL setTotalDimension(To, 2_I4B) -END PROCEDURE obj_Convert3 - -!---------------------------------------------------------------------------- -! ColSORT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ColumnSORT -CALL CSORT(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, & - & INPUT(Option=isValues, Default=.TRUE.)) -obj%csr%isSorted = .TRUE. -END PROCEDURE obj_ColumnSORT - -!---------------------------------------------------------------------------- -! RemoveDuplicates -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_RemoveDuplicates -INTEGER(I4B), ALLOCATABLE :: iwk(:), UT(:) -CALL Reallocate(UT, obj%csr%nrow, iwk, obj%csr%nrow + 1) -CALL CLNCSR(1, 1, obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, UT, iwk) -!> Some entries are removed so fix sparsity -obj%csr%isSparsityLock = .FALSE. -CALL setSparsity(obj) -DEALLOCATE (iwk, UT) -END PROCEDURE obj_RemoveDuplicates - -!---------------------------------------------------------------------------- -! Clean -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Clean -INTEGER(I4B), ALLOCATABLE :: iwk(:), UT(:) -INTEGER(I4B) :: value2 - -IF (INPUT(option=isValues, default=.TRUE.)) THEN - value2 = 1 -ELSE - value2 = 0 -END IF -CALL Reallocate(UT, obj%csr%nrow, iwk, obj%csr%nrow + 1) -CALL CLNCSR(INPUT(option=ExtraOption, default=1), value2, obj%csr%nrow, & - & obj%A, obj%csr%JA, obj%csr%IA, UT, iwk) -!> Some entries are removed so fix sparsity -obj%csr%isSparsityLock = .FALSE. -CALL setSparsity(obj) -DEALLOCATE (iwk, UT) -END PROCEDURE obj_Clean - -!---------------------------------------------------------------------------- -! Copy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Copy -To = From -END PROCEDURE obj_Copy - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get1 -INTERFACE - FUNCTION GETELM(I, J, A, JA, IA, IADD, SORTED) - INTEGER :: I, J, IA(*), JA(*), IADD - LOGICAL :: SORTED - DOUBLE PRECISION :: GETELM, A(*) - END FUNCTION GETELM -END INTERFACE -INTEGER(I4B) :: iadd0 -Ans = GETELM(I, J, obj%A, obj%csr%JA, obj%csr%IA, iadd0, obj%csr%isSorted) -END PROCEDURE obj_Get1 - -!---------------------------------------------------------------------------- -! Filter -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_DropEntry -INTEGER(I4B) :: ierr, nnz -INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) -REAL(DFP), ALLOCATABLE :: A(:) -ALLOCATE (IA(objIn%csr%nrow + 1), JA(objIn%csr%nnz), & - & A(objIn%csr%nnz)) -CALL FILTER(objIn%csr%nrow, INPUT(option=option, default=1), & - & droptol, objIn%A, objIn%csr%JA, objIn%csr%IA, A, JA, IA,& - & objIn%csr%nnz, ierr) -nnz = IA(objIn%csr%nrow + 1) - 1 -CALL Initiate(obj=objOut, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (IA, JA, A) -END PROCEDURE obj_DropEntry - -!---------------------------------------------------------------------------- -! Transpose -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Transpose -INTEGER(I4B), ALLOCATABLE :: iwk(:) -INTEGER(I4B) :: ierr -TYPE(DOF_) :: dofobj -CALL Reallocate(iwk, obj%csr%nnz) -CALL TRANSP(obj%csr%nrow,obj%csr%ncol,obj%A,obj%csr%JA,obj%csr%IA,iwk,ierr) -IF (ierr .NE. 0) THEN - CALL ErrorMSG( & - & msg="Error occured during transposing!", & - & file="CSRMatrix_Method@UnaryMethods.F90", & - & routine="obj_Transpose()", & - & line=__LINE__, & - & unitno=stderr) - STOP -END IF -CALL ColumnSORT(obj) -dofobj = obj%csr%idof -obj%csr%jdof = obj%csr%idof -obj%csr%idof = dofobj -CALL DEALLOCATE (dofobj) -DEALLOCATE (iwk) -END PROCEDURE obj_Transpose - -!---------------------------------------------------------------------------- -! getDiagonal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_getDiagonal1 -CALL getDiagonal(obj=obj%csr, A=obj%A, diag=diag, idiag=idiag, & - & offset=offset) -END PROCEDURE obj_getDiagonal1 - -!---------------------------------------------------------------------------- -! getDiagonal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_getDiagonal2 -CALL getDiagonal(obj=obj%csr, A=obj%A, diag=diag, offset=offset) -END PROCEDURE obj_getDiagonal2 - -!---------------------------------------------------------------------------- -! getLowerTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_getLowerTriangle -REAL(DFP), ALLOCATABLE :: A(:) -INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) -INTEGER(I4B) :: nnz, nrow -nrow = obj%csr%nrow; nnz = obj%csr%nnz -ALLOCATE (A(nnz), JA(nnz), IA(nrow + 1)) -CALL GETL(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, A, JA, IA) -nnz = IA(nrow + 1) - 1 -CALL Initiate(obj=L, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (A, IA, JA) -END PROCEDURE obj_getLowerTriangle - -!---------------------------------------------------------------------------- -! getUpperTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_getUpperTriangle -REAL(DFP), ALLOCATABLE :: A(:) -INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) -INTEGER(I4B) :: nnz, nrow -nrow = obj%csr%nrow; nnz = obj%csr%nnz -ALLOCATE (A(nnz), JA(nnz), IA(nrow + 1)) -CALL GETU(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, A, JA, IA) -nnz = IA(nrow + 1) - 1 -CALL Initiate(obj=U, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) -DEALLOCATE (A, IA, JA) -END PROCEDURE obj_getUpperTriangle - -!---------------------------------------------------------------------------- -! PermuteRow -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_PermuteRow -INTEGER(I4B) :: nrow, job -nrow = SIZE(obj, 1); job = 1 -IF (PRESENT(isValues)) THEN - IF (.NOT. isValues) job = 0 -END IF -CALL initiate(ans, obj, .TRUE.) -CALL RPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, ans%csr%JA, & - & ans%csr%IA, PERM, job) -END PROCEDURE obj_PermuteRow - -!---------------------------------------------------------------------------- -! PermuteColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_PermuteColumn -INTEGER(I4B) :: nrow, job -nrow = SIZE(obj, 1); job = 1 -IF (PRESENT(isValues)) THEN - IF (.NOT. isValues) job = 0 -END IF -CALL initiate(ans, obj, .TRUE.) -CALL CPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, ans%csr%JA, & - & ans%csr%IA, PERM, job) -END PROCEDURE obj_PermuteColumn - -!---------------------------------------------------------------------------- -! Permute -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Permute -INTEGER(I4B) :: nrow, job -LOGICAL(LGT) :: isSymPERM -! -nrow = SIZE(obj, 1) -CALL initiate(ans, obj, .TRUE.) -! -IF (PRESENT(symPERM)) THEN - isSymPERM = symPERM -ELSE - isSymPERM = .FALSE. -END IF -! -IF (PRESENT(rowPERM) .AND. PRESENT(colPERM)) THEN - job = 3 - IF (PRESENT(isValues)) THEN - IF (.NOT. isValues) job = 4 - END IF - CALL DPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, & - & ans%csr%JA, ans%csr%IA, rowPERM, colPERM, job) - RETURN -END IF -! -IF (PRESENT(rowPERM)) THEN - IF (isSymPERM) THEN - job = 1 - IF (PRESENT(isValues)) THEN - IF (.NOT. isValues) job = 2 - END IF - CALL DPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, & - & ans%csr%JA, ans%csr%IA, rowPERM, rowPERM, job) - RETURN - ELSE - ans = PermuteRow(obj=obj, PERM=rowPERM, isValues=isValues) - RETURN - END IF -END IF -! -IF (PRESENT(colPERM)) THEN - IF (isSymPERM) THEN - job = 1 - IF (PRESENT(isValues)) THEN - IF (.NOT. isValues) job = 2 - END IF - CALL DPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, & - & ans%csr%JA, ans%csr%IA, colPERM, colPERM, job) - RETURN - ELSE - ans = PermuteColumn(obj=obj, PERM=colPERM, isValues=isValues) - RETURN - END IF -END IF -END PROCEDURE obj_Permute - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE obj_GetSymU1(obj, symobj, A, symA) - TYPE(CSRSparsity_), INTENT(IN) :: obj - TYPE(CSRSparsity_), INTENT(INOUT) :: symobj - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: symA(:) - ! - INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzU, ncol, & - & nnzD, al, ar, ad - INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & - & JA_csc(:), idiag(:) - REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:) - ! - nnz_parts = GetNNZ(obj, [""]) - nrow = obj%nrow - ncol = obj%ncol - nnzU = nnz_parts(1) - nnzD = nnz_parts(3) - ! - CALL Reallocate(JA_csr, nnzU, IA_csr, nrow + 1) - CALL Reallocate(idiag, nrow) - CALL Reallocate(A_csc, nnzU) - CALL Reallocate(A_csr, nnzU) - ! - indx = 0 - ! - DO ii = 1, nrow - ! - IA_csr(ii) = indx + 1 - IA_csr(ii + 1) = IA_csr(ii) - ! - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - jj = obj%JA(rindx) - IF (ii .LT. jj) THEN - indx = indx + 1 - IA_csr(ii + 1) = IA_csr(ii + 1) + 1 - JA_csr(indx) = jj - A_csr(indx) = A(rindx) - ELSE IF (ii .EQ. jj) THEN - idiag(ii) = rindx - END IF - END DO - ! - END DO - ! - CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzU) - CALL Reallocate(A_csc, nnzU) - ! - CALL csrcsc( & - & nrow, & - & 1, & - & 1, & - & A_csr, & - & JA_csr, & - & IA_csr, & - & A_csc, & - & JA_csc, & - & IA_csc) - ! - symobj%nnz = nnzU * 2 + nnzD - symobj%ncol = ncol - symobj%nrow = nrow - symobj%isSorted = obj%isSorted - symobj%isInitiated = obj%isInitiated - symobj%isSparsityLock = obj%isSparsityLock - symobj%isDiagStored = .TRUE. - symobj%idof = obj%idof - symobj%jdof = obj%jdof - ! - CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) - CALL Reallocate(symobj%JA, symobj%nnz) - CALL Reallocate(symA, symobj%nnz) - ! - indx = 0 - ! - DO ii = 1, symobj%nrow - ar = IA_csr(ii + 1) - IA_csr(ii) - al = IA_csc(ii + 1) - IA_csr(ii) - IF (idiag(ii) .NE. 0) THEN - ad = 1 - ELSE - ad = 0 - END IF - ! - symobj%IA(ii) = indx + 1 - symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad - ! - DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csc(rindx) - symA(indx) = A_csc(rindx) - END DO - ! - IF (idiag(ii) .NE. 0) THEN - indx = indx + 1 - symobj%JA(indx) = ii !!obj%JA(idiag(ii)) - symobj%idiag(ii) = indx - symA(indx) = A(idiag(ii)) - END IF - ! - DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csr(rindx) - symA(indx) = A_csr(rindx) - END DO - ! - END DO - ! - ! Clean up - ! - DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, A_csc) - ! -END SUBROUTINE obj_GetSymU1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE obj_GetSymU2(obj, A) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) - ! - INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzU, ncol, & - & nnzD, al, ar, ad - INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & - & JA_csc(:), idiag(:) - REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:), A_diag(:) - ! - nnz_parts = GetNNZ(obj, [""]) - nrow = obj%nrow - ncol = obj%ncol - nnzU = nnz_parts(1) - nnzD = nnz_parts(3) - ! - CALL Reallocate(JA_csr, nnzU, IA_csr, nrow + 1) - CALL Reallocate(idiag, nrow) - CALL Reallocate(A_csc, nnzU) - CALL Reallocate(A_csr, nnzU) - CALL Reallocate(A_diag, nrow) - ! - indx = 0 - ! - DO ii = 1, nrow - ! - IA_csr(ii) = indx + 1 - IA_csr(ii + 1) = IA_csr(ii) - ! - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - jj = obj%JA(rindx) - IF (ii .LT. jj) THEN - indx = indx + 1 - IA_csr(ii + 1) = IA_csr(ii + 1) + 1 - JA_csr(indx) = jj - A_csr(indx) = A(rindx) - ELSE IF (ii .EQ. jj) THEN - idiag(ii) = rindx - A_diag(ii) = A(rindx) - END IF - END DO - ! - END DO - ! - CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzU) - CALL Reallocate(A_csc, nnzU) - ! - CALL csrcsc( & - & nrow, & - & 1, & - & 1, & - & A_csr, & - & JA_csr, & - & IA_csr, & - & A_csc, & - & JA_csc, & - & IA_csc) - ! - obj%nnz = nnz_parts(1) * 2 + nnz_parts(3) - obj%isDiagStored = .TRUE. - ! - CALL Reallocate(obj%IA, nrow + 1, obj%idiag, nrow) - CALL Reallocate(obj%JA, obj%nnz) - CALL Reallocate(A, obj%nnz) - ! - indx = 0 - ! - DO ii = 1, obj%nrow - ar = IA_csr(ii + 1) - IA_csr(ii) - al = IA_csc(ii + 1) - IA_csr(ii) - IF (idiag(ii) .NE. 0) THEN - ad = 1 - ELSE - ad = 0 - END IF - ! - obj%IA(ii) = indx + 1 - obj%IA(ii + 1) = obj%IA(ii) + ar + al + ad - ! - DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 - indx = indx + 1 - obj%JA(indx) = JA_csc(rindx) - A(indx) = A_csc(rindx) - END DO - ! - IF (idiag(ii) .NE. 0) THEN - indx = indx + 1 - obj%JA(indx) = ii !!obj%JA(idiag(ii)) - obj%idiag(ii) = indx - A(indx) = A_diag(ii) - END IF - ! - DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 - indx = indx + 1 - obj%JA(indx) = JA_csr(rindx) - A(indx) = A_csr(rindx) - END DO - ! - END DO - ! - ! Clean up - ! - DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, & - & A_csc, A_diag) - ! -END SUBROUTINE obj_GetSymU2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE obj_GetSymL1(obj, symobj, A, symA) - TYPE(CSRSparsity_), INTENT(IN) :: obj - TYPE(CSRSparsity_), INTENT(INOUT) :: symobj - REAL(DFP), INTENT(IN) :: A(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: symA(:) - ! - INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzL, ncol, & - & nnzD, al, ar, ad - INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & - & JA_csc(:), idiag(:) - REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:), A_diag(:) - ! - nnz_parts = GetNNZ(obj, [""]) - nrow = obj%nrow - ncol = obj%ncol - nnzL = nnz_parts(2) - nnzD = nnz_parts(3) - ! - CALL Reallocate(JA_csr, nnzL, IA_csr, nrow + 1) - CALL Reallocate(idiag, nrow) - CALL Reallocate(A_csr, nnzL) - CALL Reallocate(A_diag, nrow) - ! - indx = 0 - ! - DO ii = 1, nrow - IA_csr(ii) = indx + 1 - IA_csr(ii + 1) = IA_csr(ii) - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - jj = obj%JA(rindx) - IF (ii .GT. jj) THEN - indx = indx + 1 - IA_csr(ii + 1) = IA_csr(ii + 1) + 1 - JA_csr(indx) = jj - A_csr(indx) = A(rindx) - ELSE IF (ii .EQ. jj) THEN - idiag(ii) = rindx - A_diag(ii) = A(rindx) - END IF - END DO - END DO - ! - CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzL) - CALL Reallocate(A_csc, nnzL) - ! - CALL csrcsc( & - & nrow, & - & 1, & - & 1, & - & A_csr, & - & JA_csr, & - & IA_csr, & - & A_csc, & - & JA_csc, & - & IA_csc) - ! - symobj%nnz = nnzL * 2 + nnzD - symobj%ncol = ncol - symobj%nrow = nrow - symobj%isSorted = obj%isSorted - symobj%isInitiated = obj%isInitiated - symobj%isSparsityLock = obj%isSparsityLock - symobj%isDiagStored = .TRUE. - symobj%idof = obj%idof - symobj%jdof = obj%jdof - ! - CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) - CALL Reallocate(symobj%JA, symobj%nnz) - CALL Reallocate(symA, symobj%nnz) - ! - indx = 0 - ! - DO ii = 1, symobj%nrow - al = IA_csr(ii + 1) - IA_csr(ii) - ar = IA_csc(ii + 1) - IA_csc(ii) - IF (idiag(ii) .NE. 0) THEN - ad = 1 - ELSE - ad = 0 - END IF - ! - symobj%IA(ii) = indx + 1 - symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad - ! - DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csr(rindx) - symA(indx) = A_csr(rindx) - END DO - ! - IF (idiag(ii) .NE. 0) THEN - indx = indx + 1 - symobj%JA(indx) = ii !!obj%JA(idiag(ii)) - symobj%idiag(ii) = indx - symA(indx) = A_diag(ii) - END IF - ! - DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csc(rindx) - symA(indx) = A_csc(rindx) - END DO - ! - END DO - ! - ! Clean up - ! - DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, A_csc, A_diag) - ! -END SUBROUTINE obj_GetSymL1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE obj_GetSymL2(obj, A) - TYPE(CSRSparsity_), INTENT(INOUT) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) - ! - INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzL, ncol, & - & nnzD, al, ar, ad - INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & - & JA_csc(:), idiag(:) - REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:), A_diag(:) - ! - nnz_parts = GetNNZ(obj, [""]) - nrow = obj%nrow - ncol = obj%ncol - nnzL = nnz_parts(2) - nnzD = nnz_parts(3) - ! - CALL Reallocate(JA_csr, nnzL, IA_csr, nrow + 1) - CALL Reallocate(idiag, nrow) - CALL Reallocate(A_csr, nnzL) - CALL Reallocate(A_Diag, nrow) - ! - indx = 0 - ! - DO ii = 1, nrow - IA_csr(ii) = indx + 1 - IA_csr(ii + 1) = IA_csr(ii) - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - jj = obj%JA(rindx) - IF (ii .GT. jj) THEN - indx = indx + 1 - IA_csr(ii + 1) = IA_csr(ii + 1) + 1 - JA_csr(indx) = jj - A_csr(indx) = A(rindx) - ELSE IF (ii .EQ. jj) THEN - idiag(ii) = rindx - A_diag(ii) = A(rindx) - END IF - END DO - END DO - ! - CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzL) - CALL Reallocate(A_csc, nnzL) - ! - CALL csrcsc( & - & nrow, & - & 1, & - & 1, & - & A_csr, & - & JA_csr, & - & IA_csr, & - & A_csc, & - & JA_csc, & - & IA_csc) - ! - obj%nnz = nnzL * 2 + nnzD - obj%ncol = ncol - obj%nrow = nrow - obj%isSorted = obj%isSorted - obj%isInitiated = obj%isInitiated - obj%isSparsityLock = obj%isSparsityLock - obj%isDiagStored = .TRUE. - obj%idof = obj%idof - obj%jdof = obj%jdof - ! - CALL Reallocate(obj%IA, nrow + 1, obj%idiag, nrow) - CALL Reallocate(obj%JA, obj%nnz) - CALL Reallocate(A, obj%nnz) - ! - indx = 0 - ! - DO ii = 1, obj%nrow - al = IA_csr(ii + 1) - IA_csr(ii) - ar = IA_csc(ii + 1) - IA_csc(ii) - ! - IF (idiag(ii) .NE. 0) THEN - ad = 1 - ELSE - ad = 0 - END IF - ! - obj%IA(ii) = indx + 1 - obj%IA(ii + 1) = obj%IA(ii) + ar + al + ad - ! - DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 - indx = indx + 1 - obj%JA(indx) = JA_csr(rindx) - A(indx) = A_csr(rindx) - END DO - ! - IF (idiag(ii) .NE. 0) THEN - indx = indx + 1 - obj%JA(indx) = ii - obj%idiag(ii) = indx - A(indx) = A_diag(ii) - END IF - ! - DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 - indx = indx + 1 - obj%JA(indx) = JA_csc(rindx) - A(indx) = A_csc(rindx) - END DO - ! - END DO - ! - ! Clean up - ! - DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, A_csc, A_diag) - ! -END SUBROUTINE obj_GetSymL2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSym1 -INTEGER(I4B) :: ii, jj, nrow, rindx -REAL(DFP) :: VALUE -! -! Matrix should be square -! -symObj%csrOwnership = obj%csrOwnership -symObj%tDimension = obj%tDimension -symObj%matrixProp = "SYM" - -IF (ALLOCATED(obj%A)) THEN - SELECT CASE (from) - CASE ("U", "u") - CALL obj_GetSymU1(obj=obj%csr, symobj=symobj%csr, A=obj%A, & - & symA=symobj%A) - CASE ("L", "l") - CALL obj_GetSymL1(obj=obj%csr, symobj=symobj%csr, A=obj%A, & - & symA=symobj%A) - CASE DEFAULT - CALL Errormsg(& - & msg="No match found for given from = "//from, & - & file=__FILE__, & - & routine="obj_GetSym1()", & - & line=__LINE__, & - & unitno=stderr) - STOP - END SELECT -END IF - -END PROCEDURE obj_GetSym1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSym2 -INTEGER(I4B) :: ii, jj, nrow, rindx -REAL(DFP) :: VALUE -! -! Matrix should be square -! -obj%matrixProp = "SYM" - -IF (ALLOCATED(obj%A)) THEN - SELECT CASE (from) - CASE ("U", "u") - CALL obj_GetSymU2(obj=obj%csr, A=obj%A) - CASE ("L", "l") - CALL obj_GetSymL2(obj=obj%csr, A=obj%A) - CASE DEFAULT - CALL Errormsg(& - & msg="No match found for given from = "//from, & - & file=__FILE__, & - & routine="obj_GetSym2()", & - & line=__LINE__, & - & unitno=stderr) - STOP - END SELECT -END IF - -END PROCEDURE obj_GetSym2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -END SUBMODULE Methods diff --git a/src/submodules/CSRSparsity/CMakeLists.txt b/src/submodules/CSRSparsity/CMakeLists.txt deleted file mode 100644 index 47a07b4d1..000000000 --- a/src/submodules/CSRSparsity/CMakeLists.txt +++ /dev/null @@ -1,25 +0,0 @@ -# This program is a part of EASIFEM library Copyright (C) 2020-2023 Vikas -# Sharma, Ph.D -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General 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}/CSRSparsity_Method@ConstructorMethods.F90 - ${src_path}/CSRSparsity_Method@IOMethods.F90 - ${src_path}/CSRSparsity_Method@SetMethods.F90 - ${src_path}/CSRSparsity_Method@GetMethods.F90 - ${src_path}/CSRSparsity_Method@SymMethods.F90) diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 deleted file mode 100644 index 4f0a1cf4a..000000000 --- a/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,204 +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: 13 July 2021 -! summary: Methods related to CSR sparsity - -SUBMODULE(CSRSparsity_Method) ConstructorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_initiate1 -#ifdef DEBUG_VER -INTEGER(I4B) :: tNodes1, tNodes2 -LOGICAL(LGT) :: isok, problem -#endif - -#ifdef DEBUG_VER - -problem = PRESENT(idof) .AND. (.NOT. PRESENT(jdof)) -IF (problem) THEN - CALL ErrorMSG( & - & "When idof is present, jdof should be present too.", & - & "CSRSparsity_Method@Constructor.F90", & - & "obj_initiate1()", & - & __LINE__, stderr) - STOP -END IF - -problem = PRESENT(jdof) .AND. (.NOT. PRESENT(idof)) -IF (problem) THEN - CALL ErrorMSG( & - & "When jdof is present, idof should be present too.", & - & "CSRSparsity_Method@Constructor.F90", & - & "obj_initiate1()", & - & __LINE__, stderr) - STOP -END IF - -isok = PRESENT(idof) -IF (isok) THEN - tnodes1 = .tNodes.idof - tnodes2 = .tNodes.jdof - problem = tnodes1 .NE. nrow .OR. tnodes2 .NE. ncol - IF (problem) THEN - CALL ErrorMSG( & - & "Size of the matrix does not conform with the dof data! "// & - & "tNodes1 = "//tostring(tnodes1)//" tNodes2="//tostring(tNodes2), & - & "CSRSparsity_Method@Constructor.F90", & - & "obj_initiate1()", & - & __LINE__, stderr) - STOP - END IF -END IF -#endif - -CALL DEALLOCATE (obj) - -obj%isInitiated = .TRUE. - -obj%nnz = Input(default=0_I4B, option=nnz) -obj%ncol = ncol -obj%nrow = nrow - -IF (PRESENT(idof)) THEN - obj%idof = idof -ELSE - CALL Initiate(obj=obj%idof, tNodes=[nrow], names=['K'], & - & spacecompo=[1], timecompo=[1], storageFMT=NODES_FMT) -END IF - -IF (PRESENT(jdof)) THEN - obj%jdof = jdof -ELSE - CALL Initiate(obj=obj%jdof, tNodes=[ncol], names=['K'], & - & spacecompo=[1], timecompo=[1], storageFMT=NODES_FMT) -END IF - -CALL Reallocate(obj%IA, nrow + 1) -CALL Reallocate(obj%idiag, nrow) - -IF (obj%nnz .GT. 0) THEN - CALL Reallocate(obj%JA, obj%nnz) -END IF - -END PROCEDURE obj_initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_initiate2 -INTEGER(I4B) :: ii, n - -CALL DEALLOCATE (obj) -obj%nnz = obj2%nnz -obj%ncol = obj2%ncol -obj%nrow = obj2%nrow -obj%isSorted = obj2%isSorted -obj%isInitiated = obj2%isInitiated -obj%isSparsityLock = obj2%isSparsityLock -obj%isDiagStored = obj2%isDiagStored -IF (ALLOCATED(obj2%IA)) obj%IA = obj2%IA -IF (ALLOCATED(obj2%JA)) obj%JA = obj2%JA -IF (ALLOCATED(obj2%idiag)) obj%idiag = obj2%idiag -IF (ALLOCATED(obj%row)) THEN - n = SIZE(obj%row) - DO ii = 1, n - obj%row(ii) = obj2%row(ii) - END DO -END IF -obj%idof = obj2%idof -obj%jdof = obj2%jdof -END PROCEDURE obj_initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate3 -INTEGER(I4B) :: nrow, ncol0, nnz - -nrow = SIZE(IA) - 1 -ncol0 = Input(default=nrow, option=ncol) -nnz = SIZE(JA) -CALL Initiate(obj=obj, nrow=nrow, ncol=ncol0, nnz=nnz) -obj%IA = IA -obj%JA = JA -END PROCEDURE obj_Initiate3 - -!---------------------------------------------------------------------------- -! CSRSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_constructor1 -CALL Initiate(obj=ans, ncol=ncol, nrow=nrow, idof=idof, jdof=jdof) -END PROCEDURE obj_constructor1 - -!---------------------------------------------------------------------------- -! CSRSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_constructor2 -CALL Initiate(obj=ans, IA=IA, JA=JA) -END PROCEDURE obj_constructor2 - -!---------------------------------------------------------------------------- -! CSRSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_constructor_1 -ALLOCATE (CSRSparsity_ :: ans) -CALL Initiate(obj=ans, ncol=ncol, nrow=nrow, idof=idof, jdof=jdof) -END PROCEDURE obj_constructor_1 - -!---------------------------------------------------------------------------- -! CSRSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_constructor_2 -ALLOCATE (CSRSparsity_ :: ans) -CALL Initiate(obj=ans, IA=IA, JA=JA) -END PROCEDURE obj_constructor_2 - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Deallocate -IF (ALLOCATED(obj%IA)) DEALLOCATE (obj%IA) -IF (ALLOCATED(obj%JA)) DEALLOCATE (obj%JA) -IF (ALLOCATED(obj%idiag)) DEALLOCATE (obj%idiag) -IF (ALLOCATED(obj%Row)) DEALLOCATE (obj%Row) -CALL DEALLOCATE (obj%idof) -CALL DEALLOCATE (obj%jdof) -obj%nnz = 0 -obj%nrow = 0 -obj%ncol = 0 -obj%isSorted = .FALSE. -obj%isInitiated = .FALSE. -obj%isSparsityLock = .FALSE. -obj%isDiagStored = .FALSE. -END PROCEDURE obj_Deallocate - -END SUBMODULE ConstructorMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 deleted file mode 100644 index 661012ffe..000000000 --- a/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 +++ /dev/null @@ -1,345 +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 -! - -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General 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: 13 Jul 2021 -! summary: Input output related methods - -SUBMODULE(CSRSparsity_Method) GetMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Shape -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_shape -Ans = [obj%nrow, obj%ncol] -END PROCEDURE obj_shape - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_size -IF (PRESENT(Dims)) THEN - IF (Dims .EQ. 1) THEN - Ans = obj%nrow - ELSE - Ans = obj%ncol - END IF -ELSE - Ans = obj%nrow * obj%ncol -END IF -END PROCEDURE obj_size - -!---------------------------------------------------------------------------- -! GetNNZ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNNZ -Ans = obj%nnz -END PROCEDURE obj_GetNNZ - -!---------------------------------------------------------------------------- -! GetNNZ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNNZ_from_operation -INTEGER(I4B) :: nrow, ncol -LOGICAL(LGT) :: isSorted0 - -isSorted0 = Input(default=.FALSE., option=isSorted) - -SELECT CASE (op) -CASE ("+", "-") - nrow = SIZE(obj1, 1) - ncol = SIZE(obj1, 2) - IF (isSorted0) THEN - ans = GetNNZ_Add_Subtract_sorted(nrow=nrow, ncol=ncol, ja=obj1%JA, & - & ia=obj1%IA, jb=obj2%JA, ib=obj2%IA) - ELSE - ans = GetNNZ_Add_Subtract(nrow=nrow, ncol=ncol, ja=obj1%JA, & - & ia=obj1%IA, jb=obj2%JA, ib=obj2%IA) - END IF -END SELECT -END PROCEDURE obj_GetNNZ_from_operation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetNNZ_Add_Subtract -INTEGER(I4B) :: ii, jcol, kb, ka -LOGICAL(LGT) :: iw(ncol) -ans = 0 - -DO ii = 1, nrow - iw = .FALSE. - DO ka = ia(ii), ia(ii + 1) - 1 - ans = ans + 1 - jcol = ja(ka) - iw(jcol) = .TRUE. - END DO - - DO kb = ib(ii), ib(ii + 1) - 1 - jcol = jb(kb) - IF (.NOT. iw(jcol)) THEN - ans = ans + 1 - iw(jcol) = .TRUE. - END IF - END DO -END DO -END PROCEDURE GetNNZ_Add_Subtract - -!---------------------------------------------------------------------------- -! GetNNZ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetNNZ_Add_Subtract_sorted -! internal variables -INTEGER(I4B) :: len, i, ka, kb, kc, & - & kamax, kbmax, j1, jj2 -LOGICAL(LGT) :: isok - -kc = 1 -DO i = 1, nrow - ka = ia(i) - kb = ib(i) - kamax = ia(i + 1) - 1 - kbmax = ib(i + 1) - 1 - - DO - isok = ka .LE. kamax .OR. kb .LE. kbmax - IF (.NOT. isok) EXIT - - IF (ka .LE. kamax) THEN - j1 = ja(ka) - ELSE - ! take j1 large enough that always jj2 .lt. j1 - j1 = ncol + 1 - END IF - - IF (kb .LE. kbmax) THEN - jj2 = jb(kb) - ELSE - ! similarly take jj2 large enough that always j1 .lt. jj2 - jj2 = ncol + 1 - END IF - - IF (j1 .EQ. jj2) THEN - ka = ka + 1 - kb = kb + 1 - kc = kc + 1 - ELSE IF (j1 .LT. jj2) THEN - ka = ka + 1 - kc = kc + 1 - ELSE IF (j1 .GT. jj2) THEN - kb = kb + 1 - kc = kc + 1 - END IF - END DO -END DO - -ans = kc - 1 -END PROCEDURE GetNNZ_Add_Subtract_sorted - -!---------------------------------------------------------------------------- -! GetNNZ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNNZ1 -INTEGER(I4B) :: ii, rindx -IF (obj%isInitiated) THEN - ans = 0 - SELECT CASE (from) - CASE ("L", "l") - DO ii = 1, obj%nrow - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - IF (ii .GT. obj%JA(rindx)) ans = ans + 1 - END DO - END DO - - CASE ("U", "u") - DO ii = 1, obj%nrow - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - IF (ii .LT. obj%JA(rindx)) ans = ans + 1 - END DO - END DO - - CASE ("D", "d") - DO ii = 1, obj%nrow - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - IF (ii .EQ. obj%JA(rindx)) ans = ans + 1 - END DO - END DO - CASE default - ans = obj%nnz - END SELECT -ELSE - ans = 0 -END IF -END PROCEDURE obj_GetNNZ1 - -!---------------------------------------------------------------------------- -! GetNNZ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNNZ2 -INTEGER(I4B) :: ii, rindx -IF (obj%isInitiated) THEN - ans = 0 - - DO ii = 1, obj%nrow - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - IF (ii .LT. obj%JA(rindx)) THEN - ! U - ans(1) = ans(1) + 1 - ELSEIF (ii .GT. obj%JA(rindx)) THEN - ! L - ans(2) = ans(2) + 1 - ELSEIF (ii .EQ. obj%JA(rindx)) THEN - ! D - ans(3) = ans(3) + 1 - END IF - END DO - END DO -ELSE - ans = 0 -END IF -END PROCEDURE obj_GetNNZ2 - -!---------------------------------------------------------------------------- -! GetDiagonal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetDiagonal1 -INTEGER(I4B) :: len0 -CALL Reallocate(diag, obj%nrow, idiag, obj%nrow) -CALL GetDIA( & - & obj%nrow,& - & obj%ncol,& - & 0,& - & A,& - & obj%JA,& - & obj%IA,& - & len0,& - & diag,& - & idiag,& - & INPUT(option=offSet, default=0)) -END PROCEDURE obj_GetDiagonal1 - -!---------------------------------------------------------------------------- -! GetDiagonal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetDiagonal2 -INTEGER(I4B) :: ii - -IF (obj%isDiagStored) THEN - - CALL Reallocate(diag, obj%nrow) - DO ii = 1, SIZE(diag) - diag(ii) = A(obj%idiag(ii)) - END DO - -ELSE - CALL Reallocate(diag, obj%nrow) - CALL GetDIA( & - & obj%nrow,& - & obj%ncol,& - & 0,& - & A,& - & obj%JA,& - & obj%IA,& - & ii,& - & diag,& - & obj%idiag,& - & INPUT(option=offSet, default=0)) - obj%isDiagStored = .TRUE. -END IF - -END PROCEDURE obj_GetDiagonal2 - -!---------------------------------------------------------------------------- -! GetColNumber -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetColNumber1 -ans = obj%JA(indx) -END PROCEDURE obj_GetColNumber1 - -!---------------------------------------------------------------------------- -! GetColIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetColIndex1 -ans(1) = obj%IA(irow) -ans(2) = obj%IA(irow + 1) - 1 -END PROCEDURE obj_GetColIndex1 - -!---------------------------------------------------------------------------- -! startColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_startColumn1 -ans = obj%IA(irow) -END PROCEDURE obj_startColumn1 - -!---------------------------------------------------------------------------- -! endColumn -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_endColumn1 -ans = obj%IA(irow + 1) - 1 -END PROCEDURE obj_endColumn1 - -!---------------------------------------------------------------------------- -! GetIA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIA -ans = obj%IA(irow) -END PROCEDURE obj_GetIA - -!---------------------------------------------------------------------------- -! GetJA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetJA -ans = obj%JA(indx) -END PROCEDURE obj_GetJA - -END SUBMODULE GetMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 deleted file mode 100644 index 752cc138b..000000000 --- a/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 +++ /dev/null @@ -1,65 +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: 13 Jul 2021 -! summary: Input output related methods - -SUBMODULE(CSRSparsity_Method) IOMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Display -CALL Display(Msg, unitNo=unitNo) -CALL Display(obj%nnz, "# NNZ : ", unitNo=unitNo) -CALL Display(obj%ncol, "# NCOL : ", unitNo=unitNo) -CALL Display(obj%nrow, "# NROW : ", unitNo=unitNo) -CALL Display(obj%idof, "# iDOF : ", unitNo=unitNo) -CALL Display(obj%jdof, "# jDOF : ", unitNo=unitNo) -!! -IF (ALLOCATED(obj%IA)) THEN - CALL Display(obj%IA, "# IA : ", unitNo=unitNo, advance="NO") -ELSE - CALL Display("# IA is not allocated", UnitNo=UnitNo) -END IF -!! -IF (ALLOCATED(obj%JA)) THEN - CALL Display(obj%JA, "# JA : ", unitNo=unitNo, advance="NO") -ELSE - CALL Display("# JA is not allocated", UnitNo=UnitNo) -END IF -!! -CALL Display("", unitNo=UnitNo, advance=.TRUE.) -!! -IF (ALLOCATED(obj%idiag)) THEN - CALL Display(obj%idiag, "# idiag : ", unitNo=unitNo) -ELSE - CALL Display("# idiag is not allocated", UnitNo=UnitNo) -END IF -!! -IF (ALLOCATED(obj%row)) THEN - CALL Display(obj%row, "# ROW : ", unitNo=unitNo, orient="ROW") -END IF -!! -END PROCEDURE obj_Display - -END SUBMODULE IOMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 deleted file mode 100644 index 3f7c4c094..000000000 --- a/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 +++ /dev/null @@ -1,341 +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: 13 Jul 2021 -! summary: Input output related methods - -SUBMODULE(CSRSparsity_Method) SetMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity1 -INTEGER(I4B) :: ii !n, a, b, m, tdof -INTEGER(I4B), ALLOCATABLE :: n2ntemp(:), rowIndex(:) -! -#ifdef DEBUG_VER -! -! check -! -IF (.NOT. obj%isInitiated) THEN - CALL ErrorMSG( & - & "Instance of CSRSparsity is not initiated!", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity1()", & - & __LINE__, stderr) - STOP -END IF -! -! check -! -IF (obj%isSparsityLock) THEN - CALL ErrorMSG( & - & "Instance of CSRSparsity is locked for setting sparsity pattern!", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity1()", & - & __LINE__, stderr) - STOP -END IF -#endif -! -IF (.NOT. ALLOCATED(obj%row)) ALLOCATE (obj%row(obj%nrow)) -! -IF (SIZE(Col) .GT. 0) THEN - n2ntemp = SORT(getIndex(obj=obj%jdof, nodeNum=Col)) - rowIndex = SORT(getIndex(obj=obj%idof, nodeNum=Row)) - obj%nnz = obj%nnz + SIZE(Col) * (.tdof.obj%jdof) * SIZE(rowIndex) - ! - DO ii = 1, SIZE(rowIndex) - CALL APPEND(obj%Row(rowIndex(ii)), n2ntemp) - END DO - ! -END IF -! -IF (ALLOCATED(n2ntemp)) DEALLOCATE (n2ntemp) -IF (ALLOCATED(rowIndex)) DEALLOCATE (rowIndex) -! -END PROCEDURE obj_setSparsity1 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity2 -INTEGER(I4B) :: i -DO i = 1, SIZE(Row) - CALL setSparsity(obj, Row(i), Col(i)%Val) -END DO -END PROCEDURE obj_setSparsity2 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity3 -INTEGER(I4B) :: ii -INTEGER(I4B), ALLOCATABLE :: n2ntemp(:), rowIndex(:) -! -#ifdef DEBUG_VER -! -! check -! -IF (.NOT. obj%isInitiated) THEN - CALL ErrorMSG( & - & "Instance of CSRSparsity is not initiated!", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity3()", & - & __LINE__, stderr) - STOP -END IF -! -! check -! -IF (obj%isSparsityLock) THEN - CALL ErrorMSG( & - & "Instance of CSRSparsity is locked for setting sparsity pattern!", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity3()", & - & __LINE__, stderr) - STOP -END IF -! -! check -! -IF (obj%idof%StorageFMT .EQ. NODES_FMT) THEN - CALL ErrorMSG( & - & "This subroutine works for storage format FMT_DOF, only", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity3()", & - & __LINE__, stderr) - STOP -END IF - -IF (obj%jdof%StorageFMT .EQ. NODES_FMT) THEN - CALL ErrorMSG( & - & "This subroutine works for storage format FMT_DOF, only", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity3()", & - & __LINE__, stderr) - STOP -END IF -#endif -! -! cleaning -! -IF (.NOT. ALLOCATED(obj%row)) ALLOCATE (obj%row(obj%nrow)) -! -IF (SIZE(col) .GT. 0) THEN - ! - n2ntemp = SORT(getIndex(obj=obj%jdof, nodeNum=Col, iVar=jvar)) - rowIndex = SORT(getIndex(obj=obj%idof, nodeNum=Row, iVar=ivar)) - obj%nnz = obj%nnz + SIZE(Col) * (obj%jdof.tdof.jvar) * SIZE(rowIndex) - DO ii = 1, SIZE(rowIndex) - CALL APPEND(obj%Row(rowIndex(ii)), n2ntemp) - END DO - ! -END IF -! -IF (ALLOCATED(n2ntemp)) DEALLOCATE (n2ntemp) -IF (ALLOCATED(rowIndex)) DEALLOCATE (rowIndex) -END PROCEDURE obj_setSparsity3 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity4 -INTEGER(I4B) :: i -DO i = 1, SIZE(Row) - CALL setSparsity(obj, Row(i), Col(i)%Val, ivar, jvar) -END DO -END PROCEDURE obj_setSparsity4 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity5 -INTEGER(I4B), ALLOCATABLE :: row(:), graphT(:, :) -TYPE(IntVector_), ALLOCATABLE :: col(:) -INTEGER(I4B) :: ii, jj, kk, nn, nrow, ncol -! -nrow = SIZE(graph, 1) -ncol = SIZE(graph, 2) -graphT = TRANSPOSE(graph) -! -CALL Reallocate(row, nrow) -ALLOCATE (col(nrow)) -! -DO ii = 1, nrow - row(ii) = ii - nn = COUNT(graphT(:, ii) .NE. 0) - CALL ALLOCATE (col(ii), nn) - kk = 0 - DO jj = 1, ncol - IF (graphT(jj, ii) .NE. 0) THEN - kk = kk + 1 - CALL Set(col(ii), indx=kk, VALUE=jj) - END IF - END DO -END DO -! -CALL setSparsity(obj=obj, row=row, col=col) -! -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -IF (ALLOCATED(graphT)) DEALLOCATE (graphT) -! -END PROCEDURE obj_setSparsity5 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity6 -INTEGER(I4B), ALLOCATABLE :: row(:) -LOGICAL(LGT), ALLOCATABLE :: graphT(:, :) -TYPE(IntVector_), ALLOCATABLE :: col(:) -INTEGER(I4B) :: ii, jj, kk, nn, nrow, ncol -! -nrow = SIZE(graph, 1) -ncol = SIZE(graph, 2) -graphT = TRANSPOSE(graph) -! -CALL Reallocate(row, nrow) -ALLOCATE (col(nrow)) -! -DO ii = 1, nrow - row(ii) = ii - nn = COUNT(graphT(:, ii)) - CALL ALLOCATE (col(ii), nn) - kk = 0 - DO jj = 1, ncol - IF (graphT(jj, ii)) THEN - kk = kk + 1 - CALL Set(col(ii), indx=kk, VALUE=jj) - END IF - END DO -END DO -! -CALL setSparsity(obj=obj, row=row, col=col) -! -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) -IF (ALLOCATED(graphT)) DEALLOCATE (graphT) -! -END PROCEDURE obj_setSparsity6 - -!---------------------------------------------------------------------------- -! setSparsity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_setSparsity_final -INTEGER(I4B) :: i, j, k -INTEGER(I4B), ALLOCATABLE :: intvec(:) -! -IF (.NOT. obj%isInitiated) THEN - CALL ErrorMSG( & - & "Instance of CSRSparsity is not initiated!", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity_final()", & - & __LINE__, stderr) - STOP -END IF -! -IF (obj%isSparsityLock) THEN - CALL WarningMSG( & - & "Instance of CSRSparsity is locked for setting sparsity pattern!", & - & "CSRSparsity_Method@SetMethods.F90", & - & "obj_setSparsity_final()", & - & __LINE__, stderr) - RETURN -ELSE - obj%isSparsityLock = .TRUE. -END IF -! -! Remove duplicate entries in obj%Row( irow )%Col -! -IF (ALLOCATED(obj%Row)) THEN - k = 0 - DO i = 1, obj%nrow - CALL RemoveDuplicates(obj%Row(i)) - k = k + SIZE(obj%Row(i)) - END DO - ! - ! update nnz: number of non zeros - ! - obj%nnz = k - ! - ! allocate obj%JA and obj%A - ! - CALL Reallocate(obj%JA, obj%nnz) - ! - ! convert data into IA, JA - ! - obj%IA(1) = 1 - ! - DO i = 1, obj%nrow - ! obj%RowSize( i ) = SIZE( obj%Row( i ) ) - k = SIZE(obj%Row(i)) - obj%IA(i + 1) = obj%IA(i) + k - IF (k .NE. 0) & - & obj%JA(obj%IA(i):obj%IA(i + 1) - 1) = obj%Row(i)%Val - END DO - ! - DEALLOCATE (obj%Row) - ! -END IF -! -j = SIZE(obj%JA) -! -IF (j .GT. obj%nnz) THEN - ! - intvec = obj%JA(1:obj%nnz) - CALL Reallocate(obj%JA, obj%nnz) - obj%JA = intvec - CALL Reallocate(intvec, obj%ncol) - ! -END IF -! -END PROCEDURE obj_setSparsity_final - -!---------------------------------------------------------------------------- -! SetIA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SetIA -obj%IA(irow) = VALUE -END PROCEDURE obj_SetIA - -!---------------------------------------------------------------------------- -! SetJA -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_SetJA -obj%JA(indx) = VALUE -END PROCEDURE obj_SetJA - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE SetMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 deleted file mode 100644 index 0ead15731..000000000 --- a/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 +++ /dev/null @@ -1,263 +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: 13 Jul 2021 -! summary: Input output related methods - -SUBMODULE(CSRSparsity_Method) SymMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE obj_GetSymU1(obj, symobj) - TYPE(CSRSparsity_), INTENT(IN) :: obj - TYPE(CSRSparsity_), INTENT(INOUT) :: symobj - ! - INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzU, ncol, & - & nnzD, al, ar, ad - INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & - & JA_csc(:), idiag(:) - REAL(DFP) :: real_dummy(1) - ! - nnz_parts = GetNNZ(obj, [""]) - nrow = obj%nrow - ncol = obj%ncol - nnzU = nnz_parts(1) - nnzD = nnz_parts(3) - ! - CALL Reallocate(JA_csr, nnzU, IA_csr, nrow + 1) - CALL Reallocate(idiag, nrow) - ! - indx = 0 - ! - DO ii = 1, nrow - IA_csr(ii) = indx + 1 - IA_csr(ii + 1) = IA_csr(ii) - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - jj = obj%JA(rindx) - IF (ii .LT. jj) THEN - indx = indx + 1 - IA_csr(ii + 1) = IA_csr(ii + 1) + 1 - JA_csr(indx) = jj - ELSE IF (ii .EQ. jj) THEN - idiag(ii) = rindx - END IF - END DO - END DO - ! - CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzU) - ! - CALL csrcsc( & - & nrow, & - & 0, & - & 1, & - & real_dummy, & - & JA_csr, & - & IA_csr, & - & real_dummy, & - & JA_csc, & - & IA_csc) - ! - symobj%nnz = nnz_parts(1) * 2 + nnz_parts(3) - symobj%ncol = ncol - symobj%nrow = nrow - symobj%isSorted = obj%isSorted - symobj%isInitiated = obj%isInitiated - symobj%isSparsityLock = obj%isSparsityLock - symobj%isDiagStored = .TRUE. - symobj%idof = obj%idof - symobj%jdof = obj%jdof - ! - CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) - CALL Reallocate(symobj%JA, symobj%nnz) - ! - indx = 0 - ! - DO ii = 1, symobj%nrow - ar = IA_csr(ii + 1) - IA_csr(ii) - al = IA_csc(ii + 1) - IA_csr(ii) - IF (idiag(ii) .NE. 0) THEN - ad = 1 - ELSE - ad = 0 - END IF - ! - symobj%IA(ii) = indx + 1 - symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad - ! - DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csc(rindx) - END DO - ! - IF (idiag(ii) .NE. 0) THEN - indx = indx + 1 - symobj%JA(indx) = obj%JA(idiag(ii)) - symobj%idiag(ii) = indx - END IF - ! - DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csr(rindx) - END DO - ! - END DO - ! - ! Clean up - ! - DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag) - ! -END SUBROUTINE obj_GetSymU1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE obj_GetSymL1(obj, symobj) - TYPE(CSRSparsity_), INTENT(IN) :: obj - TYPE(CSRSparsity_), INTENT(INOUT) :: symobj - ! - INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzL, ncol, & - & nnzD, al, ar, ad - INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & - & JA_csc(:), idiag(:) - REAL(DFP) :: real_dummy(1) - ! - nnz_parts = GetNNZ(obj, [""]) - nrow = obj%nrow - ncol = obj%ncol - nnzL = nnz_parts(2) - nnzD = nnz_parts(3) - ! - CALL Reallocate(JA_csr, nnzL, IA_csr, nrow + 1) - CALL Reallocate(idiag, nrow) - ! - indx = 0 - ! - DO ii = 1, nrow - IA_csr(ii) = indx + 1 - IA_csr(ii + 1) = IA_csr(ii) - DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 - jj = obj%JA(rindx) - IF (ii .GT. jj) THEN - indx = indx + 1 - IA_csr(ii + 1) = IA_csr(ii + 1) + 1 - JA_csr(indx) = jj - ELSE IF (ii .EQ. jj) THEN - idiag(ii) = rindx - END IF - END DO - END DO - ! - CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzL) - ! - CALL csrcsc( & - & nrow, & - & 0, & - & 1, & - & real_dummy, & - & JA_csr, & - & IA_csr, & - & real_dummy, & - & JA_csc, & - & IA_csc) - ! - symobj%nnz = nnzL * 2 + nnzD - symobj%ncol = ncol - symobj%nrow = nrow - symobj%isSorted = obj%isSorted - symobj%isInitiated = obj%isInitiated - symobj%isSparsityLock = obj%isSparsityLock - symobj%isDiagStored = .TRUE. - symobj%idof = obj%idof - symobj%jdof = obj%jdof - ! - CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) - CALL Reallocate(symobj%JA, symobj%nnz) - ! - indx = 0 - ! - DO ii = 1, symobj%nrow - al = IA_csr(ii + 1) - IA_csr(ii) - ar = IA_csc(ii + 1) - IA_csc(ii) - IF (idiag(ii) .NE. 0) THEN - ad = 1 - ELSE - ad = 0 - END IF - ! - symobj%IA(ii) = indx + 1 - symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad - ! - DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csr(rindx) - END DO - ! - IF (idiag(ii) .NE. 0) THEN - indx = indx + 1 - symobj%JA(indx) = obj%JA(idiag(ii)) - symobj%idiag(ii) = indx - END IF - ! - DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 - indx = indx + 1 - symobj%JA(indx) = JA_csc(rindx) - END DO - ! - END DO - ! - ! Clean up - ! - DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag) - ! -END SUBROUTINE obj_GetSymL1 - -!---------------------------------------------------------------------------- -! GetSym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSym1 -SELECT CASE (from) -CASE ("U", "u") - CALL obj_GetSymU1(obj=obj, symobj=symobj) -CASE ("L", "l") - CALL obj_GetSymL1(obj=obj, symobj=symobj) -CASE default - CALL Errormsg( & - & msg="No case found for given from = "//from, & - & file=__FILE__, & - & routine="obj_GetSym1()", & - & line=__LINE__, & - & unitno=stderr) -END SELECT -END PROCEDURE obj_GetSym1 - -!---------------------------------------------------------------------------- -! GetSym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetSym2 - -END PROCEDURE obj_GetSym2 - -END SUBMODULE SymMethods diff --git a/src/submodules/ConvectiveMatrix/CMakeLists.txt b/src/submodules/ConvectiveMatrix/CMakeLists.txt deleted file mode 100644 index 1450545c3..000000000 --- a/src/submodules/ConvectiveMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ConvectiveMatrix_Method@Methods.F90 - ) diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part deleted file mode 100755 index cc963bef2..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part +++ /dev/null @@ -1,99 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Row, Col, NIP ) - -!. . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( Row, Col ); Obj % SD( NIP ) -!. . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( ConvectiveMatrix_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIP - - ALLOCATE( Constructor_1 ) - - ALLOCATE( Constructor_1 % Mat2( row, col ) ) - Constructor_1 % Mat2 = 0.0_DFP - CALL Constructor_1 % Initiate( NIP = NIP ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( ConvectiveMatrix_ ), POINTER :: Constructor_2 - ALLOCATE( Constructor_2 ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Row, Col, NIP ) - -!. . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( Row, Col ); Obj % SD( NIP ) -!. . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( ConvectiveMatrix_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIP - - ALLOCATE( Constructor1 % Mat2( row, col ) ) - Constructor1 % Mat2 = 0.0_DFP - CALL Constructor1 % Initiate( NIP = NIP ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( ConvectiveMatrix_ ) :: Constructor2 - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part deleted file mode 100755 index 9894eeaca..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part +++ /dev/null @@ -1,170 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_10.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ConvectiveMatrix_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getConvectiveMatrix_10 -!------------------------------------------------------------------------------ -! -SUBROUTINE getConvectiveMatrix_10( Obj, A, Term1, Term2, XType, MultiVar ) - - !. . . . . . . . . . . . . . . . - ! 1. A is constant in space - !. . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef SpaceMat - CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M - INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) - REAL( DFP ) :: RealVal - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_10(), Flag-1", & - "ConvectiveMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1 ) % getNNS( ) - NSD = Obj % SD( 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_10()", & - "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) - Error_Flag = .TRUE. - RETURN - END IF - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_10()", & - "XType is dx, therefore, NSD cannot be less than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_10()", & - "XType is dx, therefore, NSD cannot be less than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_10()", & - "XType is dx, therefore, NSD cannot be less than 3" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE DEFAULT - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_10()", & - "No case found for given Xtype, & - & Make sure it is in the set & - & [dx, dX, dx1, dX1, x, X, x1, X1], & - & [dy, dY, dx2, dX2, y, Y, x2, X2], & - & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - - ALLOCATE( RC( M, 2 ) ) - DO i = 1, M - RC( i, 1 ) = ( i - 1 ) * NNS + 1 - RC( i, 2 ) = i * NNS - END DO - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - Indx = 1_I4B - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - Indx = 2_I4B - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - Indx = 3_I4B - CASE DEFAULT - Indx = 0_I4B - END SELECT - - IF( Term1 .EQ. 1 ) THEN - Aij = TRANSPOSE( A ) - ELSE - Aij = A - END IF - - DO IPS = 1, NIPS - - RealVal = Obj % SD( IPS ) % Ws & - & * Obj % SD( IPS ) % Js_Xi2Xt & - & * Obj % SD( IPS ) % Thickness - - IF( Term1 .EQ. 1 ) THEN - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & - & b = Obj % SD( IPS ) % N ) - ELSE - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & - & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) - END IF - - DO j = 1, M - DO i = 1, M - Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & - & RC( j, 1 ) : RC( j, 2 ) ) = & - & Aij( i, j ) * RealVal * Mat2 - END DO - END DO - - END DO - - DEALLOCATE( Mat2, RC, Indx, Aij ) - -END SUBROUTINE getConvectiveMatrix_10 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part deleted file mode 100755 index 852c64c2c..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part +++ /dev/null @@ -1,191 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_11.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_11 -!------------------------------------------------------------------------------ - -SUBROUTINE getConvectiveMatrix_11( Obj, A, A0, Term1, Term2, XType, MultiVar ) - - !. . . . . . . . . . . . . . . . - ! 1. - Returns mass matrix; C is a 2D array of Space Nodal Values - ! The first index is for spatial component and second index is - ! is for spatial nodal values. - !. . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef SpaceMat - CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A, A0 - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M - INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) - REAL( DFP ) :: RealVal - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11(), Flag-1", & - "ConvectiveMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1 ) % getNNS( ) - NSD = Obj % SD( 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - IF( SIZE( A, 3 ) .NE. NIPS ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "SIZE( A, 3 ) should be equal to the NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( A0, 3 ) .NE. NIPS ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "SIZE( A0, 3 ) should be equal to the NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "SIZE( A0, 1 ) should be equal to SIZE( A0, 2 )" ) - Error_Flag = .TRUE. - RETURN - END IF - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "XType is dx, therefore, NSD cannot be less than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "XType is dx, therefore, NSD cannot be less than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "XType is dx, therefore, NSD cannot be less than 3" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE DEFAULT - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "No case found for given Xtype, & - & Make sure it is in the set & - & [dx, dX, dx1, dX1, x, X, x1, X1], & - & [dy, dY, dx2, dX2, y, Y, x2, X2], & - & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - - ALLOCATE( RC( M, 2 ) ) - DO i = 1, M - RC( i, 1 ) = ( i - 1 ) * NNS + 1 - RC( i, 2 ) = i * NNS - END DO - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - Indx = 1_I4B - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - Indx = 2_I4B - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - Indx = 3_I4B - CASE DEFAULT - Indx = 0_I4B - END SELECT - - DO IPS = 1, NIPS - - RealVal = Obj % SD( IPS ) % Ws & - & * Obj % SD( IPS ) % Js_Xi2Xt & - & * Obj % SD( IPS ) % Thickness - - IF( Term1 .EQ. 1 ) THEN - ! A^T A0 - Aij = MATMUL( TRANSPOSE( A( :, :, IPS ) ), A0( :, :, IPS ) ) - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & - & b = Obj % SD( IPS ) % N ) - ELSE - ! A0^T A - Aij = MATMUL( TRANSPOSE( A0( :, :, IPS ) ), A( :, :, IPS ) ) - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & - & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) - END IF - - DO j = 1, M - DO i = 1, M - Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & - & RC( j, 1 ) : RC( j, 2 ) ) = & - & Aij( i, j ) * RealVal * Mat2 - END DO - END DO - - END DO - - DEALLOCATE( Mat2, RC, Indx, Aij ) - -END SUBROUTINE getConvectiveMatrix_11 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part deleted file mode 100755 index cb2e3ca5f..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part +++ /dev/null @@ -1,180 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_12.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_12 -!------------------------------------------------------------------------------ - -SUBROUTINE getConvectiveMatrix_12( Obj, A, A0, Term1, Term2, XType, MultiVar ) - - !------------------------------------------------------------------------------ - ! 1. - Returns mass matrix; C is a 2D array of Space Nodal Values - ! The first index is for spatial component and second index is - ! is for spatial nodal values. - !------------------------------------------------------------------------------ - - ! Define intent of dummy variables -#ifdef SpaceMat - CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, A0 - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M - INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) - REAL( DFP ) :: RealVal - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12(), Flag-1", & - "ConvectiveMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1 ) % getNNS( ) - NSD = Obj % SD( 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "SIZE( A0, 1 ) should be equal to SIZE( A0, 2 )" ) - Error_Flag = .TRUE. - RETURN - END IF - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "XType is dx, therefore, NSD cannot be less than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "XType is dx, therefore, NSD cannot be less than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "XType is dx, therefore, NSD cannot be less than 3" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE DEFAULT - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "No case found for given Xtype, & - & Make sure it is in the set & - & [dx, dX, dx1, dX1, x, X, x1, X1], & - & [dy, dY, dx2, dX2, y, Y, x2, X2], & - & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - - ALLOCATE( RC( M, 2 ) ) - DO i = 1, M - RC( i, 1 ) = ( i - 1 ) * NNS + 1 - RC( i, 2 ) = i * NNS - END DO - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - Indx = 1_I4B - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - Indx = 2_I4B - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - Indx = 3_I4B - CASE DEFAULT - Indx = 0_I4B - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) - Obj % Mat2 = 0.0_DFP - - IF( Term1 .EQ. 1 ) THEN - Aij = MATMUL( TRANSPOSE( A ), A0 ) - ELSE - Aij = MATMUL( TRANSPOSE( A0 ), A ) - END IF - - DO IPS = 1, NIPS - - RealVal = Obj % SD( IPS ) % Ws & - & * Obj % SD( IPS ) % Js_Xi2Xt & - & * Obj % SD( IPS ) % Thickness - - IF( Term1 .EQ. 1 ) THEN - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & - & b = Obj % SD( IPS ) % N ) - ELSE - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & - & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) - END IF - - DO j = 1, M - DO i = 1, M - Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & - & RC( j, 1 ) : RC( j, 2 ) ) = & - & Aij( i, j ) * RealVal * Mat2 - END DO - END DO - - END DO - - DEALLOCATE( Mat2, RC, Indx, Aij ) - -END SUBROUTINE getConvectiveMatrix_12 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part deleted file mode 100755 index f2e1b3623..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part +++ /dev/null @@ -1,173 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_9.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_9 -!------------------------------------------------------------------------------ - -SUBROUTINE getConvectiveMatrix_9( Obj, A, Term1, Term2, XType, MultiVar ) - - !. . . . . . . . . . . . . . . . - ! 1. A changes in space; - !. . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef SpaceMat - CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M - INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) - REAL( DFP ) :: RealVal - -#ifdef DEBU_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9(), Flag-1", & - "ConvectiveMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1 ) % getNNS( ) - NSD = Obj % SD( 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - IF( SIZE( A, 3 ) .NE. NIPS ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "SIZE( A, 3 ) should be equal to the NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) - Error_Flag = .TRUE. - RETURN - END IF - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "XType is dx, therefore, NSD cannot be less than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "XType is dx, therefore, NSD cannot be less than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "XType is dx, therefore, NSD cannot be less than 3" ) - Error_Flag = .TRUE. - RETURN - END IF - CASE DEFAULT - CALL Err_Msg("ConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "No case found for given Xtype, & - & Make sure it is in the set & - & [dx, dX, dx1, dX1, x, X, x1, X1], & - & [dy, dY, dx2, dX2, y, Y, x2, X2], & - & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - - ALLOCATE( RC( M, 2 ) ) - DO i = 1, M - RC( i, 1 ) = ( i - 1 ) * NNS + 1 - RC( i, 2 ) = i * NNS - END DO - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) - Indx = 1_I4B - CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) - Indx = 2_I4B - CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - Indx = 3_I4B - CASE DEFAULT - Indx = 0_I4B - END SELECT - - DO IPS = 1, NIPS - - RealVal = Obj % SD( IPS ) % Ws & - & * Obj % SD( IPS ) % Js_Xi2Xt & - & * Obj % SD( IPS ) % Thickness - - IF( Term1 .EQ. 1 ) THEN - Aij = TRANSPOSE( A( :, :, IPS ) ) - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & - & b = Obj % SD( IPS ) % N ) - ELSE - Aij = A( :, :, IPS ) - Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & - & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) - END IF - - DO j = 1, M - DO i = 1, M - Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & - & RC( j, 1 ) : RC( j, 2 ) ) = & - & Aij( i, j ) * RealVal * Mat2 - END DO - END DO - - END DO - - DEALLOCATE( Mat2, RC, Indx, Aij ) - -END SUBROUTINE getConvectiveMatrix_9 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 deleted file mode 100755 index 5285e3e53..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 +++ /dev/null @@ -1,81 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_Class.f90 -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - ElemShapeData_ Class is extended for computing the Convection or -! Advection matrix. -!============================================================================== - -MODULE ConvectiveMatrix_Class - USE IO - USE GlobalData - USE Utility, ONLY : OUTERPROD - - USE ElemShapeData_Class - USE ShapeData_Class - - IMPLICIT NONE - PRIVATE - PUBLIC :: ConvectiveMatrix_, ConvectiveMatrix, ConvectiveMatrix_Pointer - -!------------------------------------------------------------------------------ -! ElemShapeData_ -!------------------------------------------------------------------------------ - -TYPE, EXTENDS( ElemShapeData_ ) :: ConvectiveMatrix_ - -!. . . . . . . . . . . . . . . . . . . . -! 1. This class for computation of convective matrix -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - PROCEDURE, PUBLIC, PASS( Obj ) :: & -#include "./MethodNames.part" - -END TYPE ConvectiveMatrix_ - -!------------------------------------------------------------------------------ -! Constructor -!------------------------------------------------------------------------------ - - INTERFACE ConvectiveMatrix_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2 - END INTERFACE - - INTERFACE ConvectiveMatrix - MODULE PROCEDURE Constructor1, Constructor2 - END INTERFACE - -!------------------------------------------------------------------------------ -! CONTAINS -!------------------------------------------------------------------------------ - -CONTAINS - -#include "./Constructor.part" -#include "./ConvectiveMatrix_1.part" -#include "./ConvectiveMatrix_2.part" -#include "./ConvectiveMatrix_3.part" -#include "./ConvectiveMatrix_4.part" -#include "./ConvectiveMatrix_5.part" -#include "./ConvectiveMatrix_6.part" -#include "./ConvectiveMatrix_7.part" -#include "./ConvectiveMatrix_8.part" -#include "./ConvectiveMatrix_9.part" -#include "./ConvectiveMatrix_10.part" -#include "./ConvectiveMatrix_11.part" -#include "./ConvectiveMatrix_12.part" - -END MODULE ConvectiveMatrix_Class -! diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md deleted file mode 100755 index e943a33ed..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md +++ /dev/null @@ -1,1036 +0,0 @@ -# Convective Matrix Class - -## Structure - -## Constructor methods - -There are two methods to initiate `ConvectiveMatrix_` object. - -```fortran -ElemSD => ConvectiveMatrix() -``` - -This will just allocate the pointer to the convective matrix object. This will not allocate any arrays in the field of convective matrix object. There is another way to do this where we can descibe the sizes of various array. - -```fortran -ElemSD => ConvectiveMatrix( row = row, col = col, NIP = NIP) -``` - -We can also use the `initiate` method which is inherited from the `ElemShapeData_` object. This will allocate the shapedata object at given number of integration points. The sentence is given below. - -```fortran -CALL ElemSD % initiate( NIP = NIP ) -``` - -## Theory - -Consider the following terms in PDE. - -_scalar unknown_ - -$$\frac{\partial u}{\partial t} + c_k \frac{\partial u}{\partial x_k} + \cdots$$ - -_vector unknown_ - -$$\frac{\partial u_i}{\partial t} + c_k \frac{\partial u_i}{\partial x_k} + \cdots$$ - -In this case we want to compute the following finite element matrices - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ - -> These tasks are performed using the following methods; `getConvectiveMatrix_1()`, `getConvectiveMatrix_2()`, `getConvectiveMatrix_3()`, `getConvectiveMatrix_4()`, `getConvectiveMatrix_5()`, `getConvectiveMatrix_6()`. - -Now consider the following terms in PDE. - -_scalar unknown_ - -$$\frac{\partial u}{\partial t}+\frac{\partial f(u)}{\partial x} + \frac{\partial g(u)}{\partial y} + \frac{\partial h(u)}{\partial z} + \cdots$$ - -_vector unknown_ - -$$\frac{\partial \mathbf{U}}{\partial t} + \frac{\partial \mathbf{f(U)} }{\partial x} + \frac{\partial \mathbf{g(u)}}{\partial y} + \frac{\partial \mathbf{h(u)}}{\partial z} + \cdots$$ - -Now we want to compute the following matrices. - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial x} d{\Omega} \quad f_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad f_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial y} d{\Omega} \quad g_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad g_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial z} d{\Omega} \quad h_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad h_{iJ}$$ - -> These tasks are performed by the following methods; `getConvectiveMatrix_7()`, `getConvectiveMatrix_8()` - -Now consider the following terms in a PDE. - -$$\frac{\partial \mathbf{U}}{\partial t} + [\mathbf{A_1}] \frac{\partial \mathbf{U} }{\partial x} + [\mathbf{A_2}] \frac{\partial \mathbf{U}}{\partial y} + [\mathbf{A_3}] \frac{\partial \mathbf{U}}{\partial z} + \cdots$$ - -where, $\mathbf{U} \in R^m$, and $[\mathbf{A_i}] \in R^{(m\times m)}$. - -For this we may need to compute the following matrices. - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_1}]_{ij} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ji} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_2}]_{ij} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ji} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_3}]_{ij} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ji} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad U_{jJ}$$ - -> This task is performed using the following the methods; `getConvectiveMatrix_9()`, `getConvectiveMatrix_10()` - -Now consider the following terms in the pde. - -$$[\mathbf{B}] \frac{\partial \mathbf{U}}{\partial t} + [\mathbf{A_1}] \frac{\partial \mathbf{U} }{\partial x} + [\mathbf{A_2}] \frac{\partial \mathbf{U}}{\partial y} + [\mathbf{A_3}] \frac{\partial \mathbf{U}}{\partial z} + \cdots$$ - - -We may want to compute following matrices - - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_1}]_{kj} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ki} \frac{\partial N^I}{\partial x} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_2}]_{kj} [\mathbf{B}]_{kj} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ki} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_3}]_{kj} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ki} \frac{\partial N^I}{\partial z} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ - -> This task is performed using the following methods; `getConvectiveMatrix_11()`, `getConvectiveMatrix_12()` - - -## Methods - -### getConvectiveMatrix_1() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_1( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- `C(:,:)` is a two dimensional array. It represents the spatial nodal values of _convective velocity_. The shape of `C` is `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial nodal number. In this case, _convective velocity_ varies in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0 ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) -CALL Check_Error( "Main-Program", " CALL ElemSD % getConvectiveMatrix_1()") - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_1( C = DummyMat2, Term1 = 0, Term2 = 1 )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - -0.6666667 0.1666667 0.3333333 0.1666667 - -0.5000000 0.000000 0.5000000 0.000000 - -0.3333333 -0.1666667 0.6666667 -0.1666667 - -0.5000000 0.000000 0.5000000 0.000000 -``` - -```fortran -CALL ElemSD % getConvectiveMatrix_1( C = DummyMat2, Term1 = 1, & -Term2 = 0 ) -CALL Check_Error( "Main-Program", " CALL ElemSD % getConvectiveMatrix_1()") - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, & -Term2 = 0 )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0 ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.6666667 -0.5000000 -0.3333333 -0.5000000 - 0.1666667 0.000000 -0.1666667 0.000000 - 0.3333333 0.5000000 0.6666667 0.5000000 - 0.1666667 0.000000 -0.1666667 0.000000 -``` - -> These matrices are transpose of each other, therefore we will consider the first one only. - -### getConvectiveMatrix_2() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_2( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- `C(:)` is a vector. It represents the spatial coordinates of _convective velocity_. The shape of `C` is `(NSD)`. The first index of `C` denotes the spatial coordinates. In this case, _convective velocity_ remains constant in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1 ) -CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 1, Term2 = 0 ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, & -Term2 = 1 ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_2( C = DummyVec, Term1 = 0, Term2 = 1 )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1 ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.6666667 0.1666667 0.3333333 0.1666667 - -0.5000000 0.000000 0.5000000 0.000000 - -0.3333333 -0.1666667 0.6666667 -0.1666667 - -0.5000000 0.000000 0.5000000 0.000000 -``` - -### getConvectiveMatrix_3() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_3( Obj, C, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy -``` - -DESCRIPTION - -- `C(:)` is a vector. It represents the spatial coordinates of _convective velocity_. The shape of `C` is `(NSD)`. The first index of `C` denotes the spatial coordinates. In this case, _convective velocity_ remains constant in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `nCopy` is an integer; which copies the matrix to ncopy diagonal. - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0, nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.6666667 0.1666667 0.3333333 0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.3333333 -0.1666667 0.6666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.6666667 0.1666667 0.3333333 0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 -0.1666667 0.6666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 -``` - -### getConvectiveMatrix_4() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_4( Obj, C, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy -``` - -DESCRIPTION - -- `C(:,:)` is a two dimensional array. It represents the spatial nodal values of _convective velocity_. The shape of `C` is `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial nodal number. In this case, _convective velocity_ varies in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `nCopy` is an integer; which copies the matrix to ncopy diagonal. - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 ) -CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 1, Term2 = 0, nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_4( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 )" -CALL ElemSD % DisplayMatrix() -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_4( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.6666667 0.1666667 0.3333333 0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.3333333 -0.1666667 0.6666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.6666667 0.1666667 0.3333333 0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 -0.1666667 0.6666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 -``` - -### getConvectiveMatrix_5() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_5( Obj, C, Term1, Term2, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -- `C(:,:)` is a two dimensional array. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, SpaceNodalValues, Space Nodal Values]` then `C` denotes the spatial nodal values. In this case, its shape should be `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-node number. - - If `CType` is in the set `[Integration IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of convective velocity at the spatial integration points. In this case its shape should be `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-integration points. -- In this case, _convective velocity_ varies in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad' ) -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0, Ctype = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIP ) ) -DummyMat2 = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad' )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad' ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.6666667 0.1666667 0.3333333 0.1666667 - -0.5000000 0.000000 0.5000000 0.000000 - -0.3333333 -0.1666667 0.6666667 -0.1666667 - -0.5000000 0.000000 0.5000000 0.000000 -``` - -### getConvectiveMatrix_6() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_5( Obj, C, Term1, Term2, CType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -- `C(:,:)` is a two dimensional array. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, SpaceNodalValues, Space Nodal Values]` then `C` denotes the spatial nodal values. In this case, its shape should be `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-node number. - - If `CType` is in the set `[Integration IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of convective velocity at the spatial integration points. In this case its shape should be `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-integration points. -- In this case, _convective velocity_ varies in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `nCopy` is an integer; which copies the matrix to ncopy diagonal. - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad', nCopy = 2 ) -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0, Ctype = 'Quad', nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ - -$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIP ) ) -DummyMat2 = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad', nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, & -Term1 = 0, Term2 = 1, CType = 'Quad', nCopy = 2 )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad', nCopy = 2 ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.6666667 0.1666667 0.3333333 0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.3333333 -0.1666667 0.6666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.6666667 0.1666667 0.3333333 0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 -0.1666667 0.6666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 -``` - -### getConvectiveMatrix_7() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_7( Obj, Term1, Term2, XType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType -``` - -DESCRIPTION - -- In this case, _convective velocity_ varies in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `XType` is string type, it denotes the type of spatial gradient. -- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. -- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. -- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. - - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx') -CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx') -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial x} d{\Omega} \quad f_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad f_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial y} d{\Omega} \quad g_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad g_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial z} d{\Omega} \quad h_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad h_{iJ}$$ - -TESTING - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx' ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_7( Term1 = 0, Term2 = 1, XType = 'dx' )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_7( Term1 = 0, Term2 = 1, XType = 'dx' ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.3333333 0.3333333 0.1666667 -0.1666667 - -0.3333333 0.3333333 0.1666667 -0.1666667 - -0.1666667 0.1666667 0.3333333 -0.3333333 - -0.1666667 0.1666667 0.3333333 -0.3333333 -``` - -### getConvectiveMatrix_8() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_8( Obj, Term1, Term2, XType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: XType -``` - -DESCRIPTION - -- In this case, _convective velocity_ varies in the space. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `XType` is string type, it denotes the type of spatial gradient. -- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. -- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. -- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. -- `nCopy` is the number of copies to be placed on the diagonal. - - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx', nCopy = 2) -CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx', nCopy = 2) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial x} d{\Omega} \quad f_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad f_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial y} d{\Omega} \quad g_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad g_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial z} d{\Omega} \quad h_{iJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad h_{iJ}$$ - -TESTING - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_8( Term1 = 0, Term2 = 1, XType = 'dx', nCopy = 2 )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_8( Term1 = 0, Term2 = 1, XType = 'dx', nCopy = 2 ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 -``` - -### getConvectiveMatrix_9() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_9( Obj, A, Term1, Term2, XType, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:,:)` is a three dimensional array. The shape of `A` is `(M,M,NIPS)`. This array is defined at spatial-integration points. This array is responsible for coupling between different unknowns. In this method, `A` varies in the spatial domain. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `XType` is string type, it denotes the type of spatial gradient. -- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. -- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. -- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. -- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. - - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat3) -CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat3) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( 2,2, NIP ) ) -DummyMat3 = 0.0_DFP -DummyMat3( 1, 1, : ) = 1.0_DFP; DummyMat3( 2, 2, : ) = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, MultiVar = .TRUE. ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, & -XType = 'dx', A = DummyMat3, MultiVar = .TRUE. )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, & -XType = 'dx', A = DummyMat3, MultiVar = .TRUE. ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 -``` - -### getConvectiveMatrix_10() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_10( Obj, A, Term1, Term2, XType, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:)` is a two dimensional array. The shape of `A` is `(M,M)`. This array is responsible for coupling between different unknowns. The array is constant in the spatial domain. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `XType` is string type, it denotes the type of spatial gradient. -- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. -- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. -- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. -- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. - - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat2) -CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat2) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_1}]_{ij} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ji} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_2}]_{ij} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ji} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_3}]_{ij} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ji} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad U_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( 2,2 ) ) -DummyMat2 = 0.0_DFP -DummyMat2( 1, 1 ) = 1.0_DFP; DummyMat3( 2, 2 ) = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, MultiVar = .TRUE. ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_10( Term1 = 0, Term2 = 1, & -XType = 'dx', A = DummyMat2, MultiVar = .TRUE. )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat2, MultiVar = .TRUE. ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 -``` - -### getConvectiveMatrix_11() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_11( Obj, A, A0, Term1, Term2, XType, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ) :: A0, A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:,:)` and `A0(:,:,:)` are three dimensional array. The shape of `A` and `A0` is `(M,M,NIPS)`. This array is defined at spatial-integration points. This array is responsible for coupling between different unknowns. In this method, `A` and `A0` vary in the spatial domain. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `XType` is string type, it denotes the type of spatial gradient. -- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. -- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. -- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. -- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. - - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) -CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_1}]_{kj} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ki} \frac{\partial N^I}{\partial x} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_2}]_{kj} [\mathbf{B}]_{kj} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ki} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_3}]_{kj} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ki} \frac{\partial N^I}{\partial z} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( 2,2, NIP ) ) -DummyMat3 = 0.0_DFP -DummyMat3( 1, 1, : ) = 1.0_DFP; DummyMat3( 2, 2, : ) = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', & -A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, & -XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 -``` - -### getConvectiveMatrix_12() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_11( Obj, A, A0, Term1, Term2, XType, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ) :: A0, A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:)` and `A0(:,:)` are two dimensional array. The shape of `A` and `A0` is `(M,M)`. This array is responsible for coupling between different unknowns. In this method, `A` and `A0` do not vary in the spatial domain. -- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. -- `XType` is string type, it denotes the type of spatial gradient. -- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. -- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. -- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. -- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. - - -CODE SNIPPET - -```fortran -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) -CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) -``` - -SYMBOLIC CALCULATION - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_1}]_{kj} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ki} \frac{\partial N^I}{\partial x} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_2}]_{kj} [\mathbf{B}]_{kj} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ki} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_3}]_{kj} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ - -$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ki} \frac{\partial N^I}{\partial z} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( 2,2 ) ) -DummyMat2 = 0.0_DFP -DummyMat2( 1, 1 ) = 1.0_DFP; DummyMat2( 2, 2 ) = 1.0_DFP -CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', & -A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) - -CALL BlankLines( ) -WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, & -XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. )" -CALL ElemSD % DisplayMatrix( ) -``` - -**NIP = 4** - -```fortran -CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) - -MATRIX STORED IN ELEMENT SHAPE DATA :: - -NIPS :: 4 - -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 -``` \ No newline at end of file diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part deleted file mode 100644 index b3652b763..000000000 --- a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part +++ /dev/null @@ -1,12 +0,0 @@ -getConvectiveMatrix_1, & -getConvectiveMatrix_2, & -getConvectiveMatrix_3, & -getConvectiveMatrix_4, & -getConvectiveMatrix_5, & -getConvectiveMatrix_6, & -getConvectiveMatrix_7, & -getConvectiveMatrix_8, & -getConvectiveMatrix_9, & -getConvectiveMatrix_10, & -getConvectiveMatrix_11, & -getConvectiveMatrix_12 \ No newline at end of file diff --git a/src/submodules/ConvectiveMatrix/src/CM_1.inc b/src/submodules/ConvectiveMatrix/src/CM_1.inc deleted file mode 100644 index b72de1350..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_1.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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_1(ans, test, trial, c, term1, term2, opt) - !! Intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: c - !! Vector variable denoting the convective variable - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z, del_x_all - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips - REAL(DFP), ALLOCATABLE :: p(:, :) - REAL(DFP), ALLOCATABLE :: realVal(:) - !! - !! main - !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - !! projection on trial - !! - CALL GetProjectionOfdNdXt(obj=trial, cdNdXt=p, val=c) - !! - DO ips = 1, SIZE(trial%N, 2) - ans = ans + outerprod(a=test%N(:, ips), & - & b=p(:, ips)) * realval(ips) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! cleanup - DEALLOCATE (p, realval) -END SUBROUTINE CM_1 diff --git a/src/submodules/ConvectiveMatrix/src/CM_10.inc b/src/submodules/ConvectiveMatrix/src/CM_10.inc deleted file mode 100644 index 8d647f718..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_10.inc +++ /dev/null @@ -1,76 +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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_10(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - ! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - ! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - ! del_x_all - INTEGER(I4B), INTENT(IN) :: term2 - ! del_none - INTEGER(I4B), INTENT(IN) :: opt - ! - ! Define internal variables - ! - INTEGER(I4B) :: ips, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - ! - ! main - ! - realval = trial%js * trial%ws * trial%thickness - ! - IF (opt .EQ. 1) THEN - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) - ! - DO ips = 1, SIZE(realval) - DO ii = 1, SIZE(m4, 3) - m4(:, :, ii, 1) = m4(:, :, ii, 1) + outerprod( & - & a=test%dNdXt(:, ii, ips), & - & b=trial%N(:, ips)) * realval(ips) - END DO - END DO - ELSE - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) - ! - DO ips = 1, SIZE(realval) - DO ii = 1, SIZE(m4, 4) - m4(:, :, 1, ii) = m4(:, :, 1, ii) + outerprod( & - & a=test%dNdXt(:, ii, ips), & - & b=trial%N(:, ips)) * realval(ips) - END DO - END DO - END IF - ! - CALL Convert(from=m4, to=ans) - ! - DEALLOCATE (realval, m4) - ! -END SUBROUTINE CM_10 diff --git a/src/submodules/ConvectiveMatrix/src/CM_2.inc b/src/submodules/ConvectiveMatrix/src/CM_2.inc deleted file mode 100644 index 345c2a243..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_2.inc +++ /dev/null @@ -1,42 +0,0 @@ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_2(ans, test, trial, c, term1, term2, opt) - !! Intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: c - !! Vector variable denoting the convective variable - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z, del_x_all - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips - REAL(DFP), ALLOCATABLE :: p(:, :), realVal(:) - !! - !! main - !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - !! projection on test - !! - CALL GetProjectionOfdNdXt(obj=test, cdNdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - ans = ans + outerprod(a=p(:, ips), & - & b=trial%N(:, ips)) * realval(ips) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! cleanup - DEALLOCATE (realval, p) -END SUBROUTINE CM_2 diff --git a/src/submodules/ConvectiveMatrix/src/CM_3.inc b/src/submodules/ConvectiveMatrix/src/CM_3.inc deleted file mode 100644 index 4095c3ac6..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_3.inc +++ /dev/null @@ -1,41 +0,0 @@ - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_3(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: c - !! A scalar finite element variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) - !! - realval = trial%js * trial%ws * trial%thickness * realval - !! - DO ips = 1, SIZE(realval) - ans = ans + outerprod(a=test%N(:, ips), & - & b=trial%dNdXt(:, term2, ips)) * realval(ips) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! cleanup - DEALLOCATE (realval) -END SUBROUTINE CM_3 diff --git a/src/submodules/ConvectiveMatrix/src/CM_4.inc b/src/submodules/ConvectiveMatrix/src/CM_4.inc deleted file mode 100644 index 91c1be600..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_4.inc +++ /dev/null @@ -1,42 +0,0 @@ - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_4(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - TYPE(FEVariable_), INTENT(IN) :: c - !! A scalar finite element variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! Define internal variables - !! - INTEGER(I4B) :: ips - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) - !! - realval = trial%js * trial%ws * trial%thickness * realval - !! - !! derivative in test - !! - DO ips = 1, SIZE(realval) - ans = ans + outerprod(a=test%dNdXt(:, term1, ips), & - & b=trial%N(:, ips)) * realval(ips) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! cleanup - DEALLOCATE (realval) -END SUBROUTINE CM_4 diff --git a/src/submodules/ConvectiveMatrix/src/CM_5.inc b/src/submodules/ConvectiveMatrix/src/CM_5.inc deleted file mode 100644 index a4cfc20a8..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_5.inc +++ /dev/null @@ -1,77 +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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all - TYPE(FEVariable_), INTENT(IN) :: c - !! A scalar finite element variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) - !! - realval = trial%js * trial%ws * trial%thickness * realval - !! - if( opt .eq. 1 ) then - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) - !! - !! test: rowConcat - !! - DO ips = 1, SIZE(realval) - m4(:,:,:,1) = m4(:,:,:,1) + outerprod(a=test%N(:, ips), & - & b=trial%dNdXt(:, :, ips)) * realval(ips) - END DO - else - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) - !! - !! test: rowConcat - !! - DO ips = 1, SIZE(realval) - m4(:,:,1, :) = m4(:,:,1, :) + outerprod(a=test%N(:, ips), & - & b=trial%dNdXt(:, :, ips)) * realval(ips) - END DO - end if - !! - CALL Convert(from=m4, to=ans) - !! cleanup - DEALLOCATE (realval, m4) -END SUBROUTINE CM_5 diff --git a/src/submodules/ConvectiveMatrix/src/CM_6.inc b/src/submodules/ConvectiveMatrix/src/CM_6.inc deleted file mode 100644 index 06cfb876f..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_6.inc +++ /dev/null @@ -1,79 +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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - TYPE(FEVariable_), INTENT(IN) :: c - !! A scalar finite element variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) - !! - realval = trial%js * trial%ws * trial%thickness * realval - !! - if( opt .eq. 1 ) then - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) - !! - DO ips = 1, SIZE(realval) - do ii = 1, size(m4, 3) - m4(:,:,ii, 1) = m4(:,:,ii, 1) + outerprod( & - & a=test%dNdXt(:, ii, ips), & - & b=trial%N(:, ips)) * realval(ips) - end do - END DO - else - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) - !! - DO ips = 1, SIZE(realval) - do ii = 1, size(m4, 4) - m4(:,:,1,ii) = m4(:,:,1,ii) + outerprod( & - & a=test%dNdXt(:, ii, ips), & - & b=trial%N(:, ips)) * realval(ips) - end do - END DO - end if - !! - CALL Convert(from=m4, to=ans) - !! - DEALLOCATE (realval, m4) -END SUBROUTINE CM_6 diff --git a/src/submodules/ConvectiveMatrix/src/CM_7.inc b/src/submodules/ConvectiveMatrix/src/CM_7.inc deleted file mode 100644 index f914a0777..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_7.inc +++ /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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_7(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(realval) - ans = ans + outerprod(a=test%N(:, ips), & - & b=trial%dNdXt(:, term2, ips)) * realval(ips) - END DO - !! - IF (PRESENT(opt)) THEN - CALL MakeDiagonalCopies(ans, opt) - END IF - !! cleanup - DEALLOCATE (realval) -END SUBROUTINE CM_7 diff --git a/src/submodules/ConvectiveMatrix/src/CM_8.inc b/src/submodules/ConvectiveMatrix/src/CM_8.inc deleted file mode 100644 index c175db8a3..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_8.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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_8(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - !! derivative in test - !! - DO ips = 1, SIZE(realval) - ans = ans + outerprod(a=test%dNdXt(:, term1, ips), & - & b=trial%N(:, ips)) * realval(ips) - END DO - !! - IF (PRESENT(opt)) THEN - CALL MakeDiagonalCopies(ans, opt) - END IF - !! cleanup - DEALLOCATE (realval) -END SUBROUTINE CM_8 diff --git a/src/submodules/ConvectiveMatrix/src/CM_9.inc b/src/submodules/ConvectiveMatrix/src/CM_9.inc deleted file mode 100644 index d7cb134f9..000000000 --- a/src/submodules/ConvectiveMatrix/src/CM_9.inc +++ /dev/null @@ -1,73 +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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CM_9(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test functions - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial functions - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all - INTEGER( I4B ), INTENT( IN ) :: opt - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - !! - !! main - !! - realval = trial%js * trial%ws * trial%thickness - !! - IF( opt .EQ. 1 ) THEN - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) - !! - DO ips = 1, SIZE(realval) - DO ii = 1, SIZE(m4, 3) - m4(:,:,ii,1) = m4(:,:,ii,1) + outerprod(test%N(:, ips), & - & trial%dNdXt(:, ii, ips)) * realval(ips) - END DO - END DO - ELSE - CALL Reallocate(m4, & - & SIZE(test%N, 1), & - & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) - !! - DO ips = 1, SIZE(realval) - DO ii = 1, SIZE( m4, 4) - m4(:,:,1, ii) = m4(:,:,1, ii) + outerprod(a=test%N(:, ips), & - & b=trial%dNdXt(:, ii, ips)) * realval(ips) - END DO - END DO - END IF - !! - CALL Convert(from=m4, to=ans) - !! - DEALLOCATE (realval, m4) -END SUBROUTINE CM_9 diff --git a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 deleted file mode 100644 index 838cc5b12..000000000 --- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 +++ /dev/null @@ -1,137 +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(ConvectiveMatrix_Method) Methods -USE BaseMethod -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" - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ConvectiveMatrix_1 -IF( term1 .EQ. DEL_NONE ) THEN -!! -!! -!! -!! - IF( term2 .EQ. DEL_X_ALL ) THEN - !! - !! del_none - !! del_x_all - !! - CALL CM_9(ans=ans, test=test, trial=trial, & - & term1=term2, term2=term2, opt=opt) - !! - ELSE - !! - !! del_none - !! del_x, del_y, del_z - !! - CALL CM_7(ans=ans, test=test, trial=trial, & - & term1=term2, term2=term2, opt=opt) - !! - END IF -!! -!! -!! -!! -ELSE - !! - !! term2 .eq. del_none - !! - IF( term1 .EQ. del_x_all ) THEN - !! - !! del_x_all - !! del_none - !! - CALL CM_10(ans=ans, test=test, trial=trial, & - & term1=term2, term2=term2, opt=opt) - !! - ELSE - !! - !! del_x, del_y, del_z - !! del_none - !! - CALL CM_8(ans=ans, test=test, trial=trial, & - & term1=term2, term2=term2, opt=opt) - !! - END IF -END IF -!! -END PROCEDURE ConvectiveMatrix_1 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ConvectiveMatrix_2 - !! - !! scalar - !! - IF( term1 .EQ. del_none ) THEN - IF( term2 .EQ. del_x_all ) THEN - CALL CM_5(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - ELSE - CALL CM_3(ans=ans, test=test, trial=trial, c=c, & - & term1=term2, term2=term2, opt=opt) - END IF - ELSE - IF( term1 .EQ. del_x_all ) THEN - CALL CM_6(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - ELSE - CALL CM_4(ans=ans, test=test, trial=trial, c=c, & - & term1=term2, term2=term2, opt=opt) - END IF - END IF - !! -END PROCEDURE ConvectiveMatrix_2 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ConvectiveMatrix_3 - !! - IF( term1 .EQ. del_none ) THEN - CALL CM_1(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - ELSE - CALL CM_2(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - END IF - !! -END PROCEDURE ConvectiveMatrix_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/DOF/CMakeLists.txt b/src/submodules/DOF/CMakeLists.txt deleted file mode 100644 index 094198779..000000000 --- a/src/submodules/DOF/CMakeLists.txt +++ /dev/null @@ -1,27 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/DOF_ConstructorMethods@Methods.F90 - ${src_path}/DOF_IOMethods@Methods.F90 - ${src_path}/DOF_SetMethods@Methods.F90 - ${src_path}/DOF_AddMethods@Methods.F90 - ${src_path}/DOF_GetMethods@Methods.F90 - ${src_path}/DOF_GetValueMethods@Methods.F90) diff --git a/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 b/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 deleted file mode 100644 index 554acf4bc..000000000 --- a/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 +++ /dev/null @@ -1,433 +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(DOF_AddMethods) Methods -USE DOF_GetMethods, ONLY: GetNodeLoc, & - OPERATOR(.tdof.), & - GetNodeLoc_, & - GetIndex_, & - GetIDOF - -USE GlobalData, ONLY: NodesToDOF, DOFToNodes, NODES_FMT, DOF_FMT - -USE SafeSizeUtility, ONLY: SafeSize - -USE ReallocateUtility, ONLY: Reallocate - -IMPLICIT NONE - -INTEGER(I4B), PARAMETER :: PARAM_EXPAND_FACTOR_TEMP_INTVEC = 2 -INTEGER(I4B), PARAMETER :: PARAM_TEMP_INTVEC_SIZE = 1024 -INTEGER(I4B) :: tempIntVec(PARAM_TEMP_INTVEC_SIZE) -!$OMP THREADPRIVATE(tempIntVec) - -INTEGER(I4B), ALLOCATABLE :: tempAllocIntVec(:) -!$OMP THREADPRIVATE(tempAllocIntVec) - -CONTAINS - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add1 -INTEGER(I4B) :: tdof, idof, i, n, m - -tdof = .tdof.obj -n = SIZE(nodenum) -m = SIZE(VALUE) - -SELECT CASE (obj%StorageFMT) - -CASE (DOF_FMT) - - IF (m .EQ. n) THEN - - DO CONCURRENT(idof=1:tdof, i=1:n) - vec(obj%valmap(idof) - 1 + nodenum(i)) = & - vec(obj%valmap(idof) - 1 + nodenum(i)) + scale * VALUE(i) - END DO - - RETURN - END IF - - ! vec( nodenum ) += scale * value( 1 ) - IF (m .EQ. 1) THEN - - DO CONCURRENT(idof=1:tdof, i=1:n) - vec(obj%valmap(idof) - 1 + nodenum(i)) = & - vec(obj%valmap(idof) - 1 + nodenum(i)) + scale * VALUE(1) - END DO - - RETURN - END IF - - ! Vec_obj_i( nodenum ) += scale * val_obj_i( : ) - ! IF (m .EQ. tdof * n) THEN - IF (conversion(1) .EQ. NodesToDOF) THEN - - DO CONCURRENT(idof=1:tdof, i=1:n) - vec(obj%valmap(idof) - 1 + nodenum(i)) = & - vec(obj%valmap(idof) - 1 + nodenum(i)) & - + scale * VALUE((i - 1) * tdof + idof) - END DO - - RETURN - - END IF - - ! Vec_obj_i( nodenum ) += scale * val_obj_i( : ) - ! IF (m .EQ. tdof * n) THEN - DO CONCURRENT(idof=1:tdof, i=1:n) - - vec(obj%valmap(idof) - 1 + nodenum(i)) = & - vec(obj%valmap(idof) - 1 + nodenum(i)) & - + scale * VALUE((idof - 1) * n + i) - - END DO - - RETURN - -CASE (NODES_FMT) - - IF (m .EQ. n) THEN - - DO CONCURRENT(idof=1:tdof, i=1:n) - - vec((nodenum(i) - 1) * tdof + idof) & - = vec((nodenum(i) - 1) * tdof + idof) & - + scale * VALUE(i) - - END DO - - RETURN - - END IF - - IF (m .EQ. 1) THEN - - DO idof = 1, tdof - vec((nodenum - 1) * tdof + idof) & - & = vec((nodenum - 1) * tdof + idof) & - & + scale * VALUE(1) - END DO - - RETURN - END IF - - ! ELSE IF (m .EQ. tdof * n) THEN - - IF (conversion(1) .EQ. DOFToNodes) THEN - - DO CONCURRENT(idof=1:tdof, i=1:n) - - vec((nodenum(i) - 1) * tdof + idof) & - = vec((nodenum(i) - 1) * tdof + idof) & - + scale * VALUE((idof - 1) * n + i) - - END DO - - RETURN - - END IF - - DO CONCURRENT(idof=1:tdof, i=1:n) - vec((nodenum(i) - 1) * tdof + idof) & - = vec((nodenum(i) - 1) * tdof + idof) & - + scale * VALUE((i - 1) * tdof + idof) - END DO - RETURN - - ! END IF - -END SELECT - -END PROCEDURE obj_Add1 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add2 -INTEGER(I4B) :: tsize -tsize = (.tdof.obj) * SIZE(nodenum) - -IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN - - IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN - CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) - END IF - - CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, tsize=tsize) - CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, indx=tempAllocIntVec) - - RETURN -END IF - -CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempIntVec, tsize=tsize) -CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempIntVec) - -END PROCEDURE obj_Add2 - -!---------------------------------------------------------------------------- -! obj_add_help_1 -!---------------------------------------------------------------------------- - -PURE SUBROUTINE obj_add_help_1(vec, scale, VALUE, tsize, indx) - REAL(DFP), INTENT(INOUT) :: vec(:) - REAL(DFP), INTENT(IN) :: scale - REAL(DFP), INTENT(IN) :: VALUE - INTEGER(I4B), INTENT(IN) :: tsize - INTEGER(I4B), INTENT(IN) :: indx(:) - - INTEGER(I4B) :: ii - - DO CONCURRENT(ii=1:tsize) - vec(indx(ii)) = vec(indx(ii)) + scale * VALUE - END DO - -END SUBROUTINE obj_add_help_1 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add3 -INTEGER(I4B) :: tsize - -tsize = SIZE(nodenum) - -IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN - - IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN - CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) - END IF - - CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, & - tsize=tsize, idof=idof) - - CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempAllocIntVec) - - RETURN -END IF - -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, & - tsize=tsize, idof=idof) -CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempIntVec) - -END PROCEDURE obj_Add3 - -!---------------------------------------------------------------------------- -! obj_add_help_2 -!---------------------------------------------------------------------------- - -PURE SUBROUTINE obj_add_help_2(vec, scale, VALUE, tsize, indx) - REAL(DFP), INTENT(INOUT) :: vec(:) - REAL(DFP), INTENT(IN) :: scale - REAL(DFP), INTENT(IN) :: VALUE(:) - INTEGER(I4B), INTENT(IN) :: tsize - INTEGER(I4B), INTENT(IN) :: indx(:) - - INTEGER(I4B) :: ii, n - - n = SIZE(VALUE) - - IF (n .EQ. 1) THEN - - DO CONCURRENT(ii=1:tsize) - vec(indx(ii)) = vec(indx(ii)) + scale * VALUE(1) - END DO - - RETURN - - END IF - - DO CONCURRENT(ii=1:tsize) - vec(indx(ii)) = vec(indx(ii)) + scale * VALUE(ii) - END DO - -END SUBROUTINE obj_add_help_2 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add4 -INTEGER(I4B) :: global_idof -global_idof = GetIDOF(obj=obj, ivar=ivar, idof=idof) -CALL obj_Add3(vec=vec, obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, & - idof=global_idof) -END PROCEDURE obj_Add4 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add5 -INTEGER(I4B) :: global_idof -global_idof = GetIDOF(obj=obj, ivar=ivar, spaceCompo=spaceCompo, & - timeCompo=timeCompo) -CALL obj_Add3(vec=vec, obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, & - idof=global_idof) -END PROCEDURE obj_Add5 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add6 -INTEGER(I4B) :: tsize - -tsize = SIZE(nodenum) - -IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN - - IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN - CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) - END IF - - CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, & - tsize=tsize, ivar=ivar, spacecompo=spacecompo, & - timecompo=timecompo) - - CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempAllocIntVec) - - RETURN -END IF - -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, & - tsize=tsize, ivar=ivar, spacecompo=spacecompo, & - timecompo=timecompo) -CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempIntVec) - -END PROCEDURE obj_Add6 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add7 -INTEGER(I4B) :: tsize - -tsize = SIZE(nodenum) - -IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN - - IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN - CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) - END IF - - CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, & - tsize=tsize, ivar=ivar, spacecompo=spacecompo, & - timecompo=timecompo) - - CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempAllocIntVec) - - RETURN -END IF - -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, & - tsize=tsize, ivar=ivar, spacecompo=spacecompo, & - timecompo=timecompo) -CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempIntVec) - -END PROCEDURE obj_Add7 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add8 -INTEGER(I4B) :: tsize -CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempIntVec, tsize=tsize) -CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempIntVec) -END PROCEDURE obj_Add8 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add9 -INTEGER(I4B) :: indx -indx = GetNodeLoc(obj=obj, nodenum=nodenum, idof=idof) -vec(indx) = vec(indx) + scale * VALUE -END PROCEDURE obj_Add9 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add10 -INTEGER(I4B) :: indx -indx = GetNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, idof=idof) -vec(indx) = vec(indx) + scale * VALUE -END PROCEDURE obj_Add10 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add11 -INTEGER(I4B) :: indx -indx = GetNodeLoc( obj=obj, nodenum=nodenum, ivar=ivar, spacecompo=spacecompo, & - timecompo=timecompo) -vec(indx) = vec(indx) + scale * VALUE -END PROCEDURE obj_Add11 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add12 -INTEGER(I4B) :: tsize - -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, & - spacecompo=spacecompo, timecompo=timecompo, ans=tempIntVec, tsize=tsize) - -CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempIntVec) - -END PROCEDURE obj_Add12 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add13 -INTEGER(I4B) :: tsize - -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, & - spacecompo=spacecompo, timecompo=timecompo, ans=tempIntVec, tsize=tsize) - -CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & - indx=tempIntVec) - -END PROCEDURE obj_Add13 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 b/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 deleted file mode 100644 index 0209dd6ef..000000000 --- a/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 +++ /dev/null @@ -1,136 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(DOF_ConstructorMethods) Methods -USE ReallocateUtility, ONLY: Reallocate -USE DOF_GetMethods, ONLY: OPERATOR(.tNodes.) - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_initiate1 -INTEGER(I4B) :: n, i, k, j -!> main -obj%StorageFMT = StorageFMT; n = SIZE(Names) -CALL Reallocate(obj%Map, n + 1, 6) -ASSOCIATE (Map => obj%Map) - - !<- Names in ascii code - Map(1:n, 1) = ICHAR(Names(1:n)) - Map(1 + n, 1) = 0 - - !<- Space components; -1 if scalar component like pressure - Map(1:n, 2) = spacecompo - Map(1 + n, 2) = 0 - - ! <- Time component; 1 if time invariant - Map(1:n, 3) = timecompo - Map(1 + n, 3) = 0 - - !<- tDOF for each physical name - DO i = 1, n - IF (spacecompo(i) .LT. 0) THEN - Map(i, 4) = timecompo(i) - ELSE - Map(i, 4) = timecompo(i) * spacecompo(i) - END IF - END DO - Map(n + 1, 4) = SUM(Map(1:n, 4)) - - !<- Here we set Indx - Map(1, 5) = 1 - DO i = 2, n + 1 - Map(i, 5) = Map(i - 1, 5) + Map(i - 1, 4) - END DO - - !<- tNodes - Map(1:n, 6) = tNodes - Map(n + 1, 6) = SUM(Map(1:n, 6) * Map(1:n, 4)) - - !<- ValMap( tDOF + 1, 2 ) - CALL Reallocate(obj%ValMap, Map(n + 1, 4) + 1) - obj%ValMap(1) = 1; k = 1 - DO i = 1, n - DO j = 1, Map(i, 4) - k = k + 1 - obj%ValMap(k) = obj%ValMap(k - 1) + Map(i, 6) - END DO - END DO -END ASSOCIATE -END PROCEDURE obj_initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_initiate2 -CALL Reallocate(Val, .tNodes.obj) -END PROCEDURE obj_initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_initiate3 -CALL Reallocate(Val1, .tNodes.obj, Val2, .tNodes.obj) -END PROCEDURE obj_initiate3 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_initiate4 -obj1%StorageFMT = obj2%StorageFMT -IF (ALLOCATED(obj2%valmap)) obj1%valmap = obj2%valmap -IF (ALLOCATED(obj2%map)) obj1%map = obj2%map -END PROCEDURE obj_initiate4 - -!---------------------------------------------------------------------------- -! DOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor1 -CALL Initiate(obj=obj, Names=Names, tNodes=tNodes, & - & spacecompo=spacecompo, timecompo=timecompo, & - & StorageFMT=StorageFMT) -END PROCEDURE obj_Constructor1 - -!---------------------------------------------------------------------------- -! DOF_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor_1 -ALLOCATE (obj) -CALL Initiate(obj=obj, Names=Names, tNodes=tNodes, & - & spacecompo=spacecompo, timecompo=timecompo, & - & StorageFMT=StorageFMT) -END PROCEDURE obj_Constructor_1 - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Deallocate -IF (ALLOCATED(obj%Map)) DEALLOCATE (obj%Map) -IF (ALLOCATED(obj%ValMap)) DEALLOCATE (obj%ValMap) -END PROCEDURE obj_Deallocate - -END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 deleted file mode 100644 index 1c00e54ca..000000000 --- a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 +++ /dev/null @@ -1,827 +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(DOF_GetMethods) Methods -USE ReallocateUtility, ONLY: Reallocate -USE ArangeUtility, ONLY: Arange -USE GlobalData, ONLY: NODES_FMT, DOF_FMT, FMT_DOF, FMT_NODES - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! DOFStartIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_DOFStartIndex -ans = obj%map(ivar, 5) -END PROCEDURE obj_DOFStartIndex - -!---------------------------------------------------------------------------- -! DOFEndIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_DOFEndIndex -ans = obj%map(ivar + 1, 5) - 1 -END PROCEDURE obj_DOFEndIndex - -!---------------------------------------------------------------------------- -! tNodes -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tNodes1 -ans = 0 -IF (ALLOCATED(obj%map)) ans = obj%map(SIZE(obj%map, 1), 6) -END PROCEDURE obj_tNodes1 - -!---------------------------------------------------------------------------- -! tNodes -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tNodes2 -ans = 0 -IF (ALLOCATED(obj%valmap)) ans = obj%valmap(idof + 1) - obj%valmap(idof) -END PROCEDURE obj_tNodes2 - -!---------------------------------------------------------------------------- -! tNodes -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tNodes3 -ans = obj.tNodes. (NameToIndex(obj, varName)) -END PROCEDURE obj_tNodes3 - -!---------------------------------------------------------------------------- -! tNodes -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tNodes4 -INTEGER(I4B) :: ii -ans = 0 -DO ii = 1, SIZE(idof) - ans = ans + (obj.tNodes.idof(ii)) -END DO -END PROCEDURE obj_tNodes4 - -!---------------------------------------------------------------------------- -! tDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tdof1 - -#ifdef DEBUG_VER - -ans = 0 -IF (ALLOCATED(obj%map)) ans = obj%map(SIZE(obj%map, 1), 4) - -#else - -ans = obj%map(SIZE(obj%map, 1), 4) - -#endif -END PROCEDURE obj_tdof1 - -!---------------------------------------------------------------------------- -! tDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tdof2 -INTEGER(I4B) :: i, k -ans = 0 -IF (ALLOCATED(obj%map)) THEN - k = ICHAR(Name) - DO i = 1, SIZE(obj%map, 1) - 1 - IF (obj%map(i, 1) .EQ. k) ans = obj%map(i, 4) - END DO -END IF -END PROCEDURE obj_tdof2 - -!---------------------------------------------------------------------------- -! tDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tdof3 -#ifdef DEBUG_VER -INTEGER(I4B) :: i -LOGICAL(LGT) :: isok -ans = 0 - -i = SIZE(obj%map, 1) - 1 -isok = ALLOCATED(obj%map) .AND. (ivar .LE. i) -IF (isok) ans = obj%map(ivar, 4) - -#else -ans = obj%map(ivar, 4) -#endif - -END PROCEDURE obj_tdof3 - -!---------------------------------------------------------------------------- -! tDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tdof4 -INTEGER(I4B) :: ii -ans = 0 -DO ii = 1, SIZE(ivar) - ans = ans + obj%map(ii, 4) -END DO -END PROCEDURE obj_tdof4 - -!---------------------------------------------------------------------------- -! tNames -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tNames -ans = 0 -IF (ALLOCATED(obj%map)) ans = SIZE(obj%map, 1) - 1 -END PROCEDURE obj_tNames - -!---------------------------------------------------------------------------- -! Names -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_names1 -INTEGER(I4B) :: ii, n - -n = SIZE(obj%map, 1) - 1 -ALLOCATE (ans(n)) - -DO ii = 1, n - ans(ii) = ACHAR(obj%map(ii, 1)) -END DO -END PROCEDURE obj_names1 - -!---------------------------------------------------------------------------- -! Names -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_names2 -ans = ACHAR(obj%map(ii, 1)) -END PROCEDURE obj_names2 - -!---------------------------------------------------------------------------- -! IndexOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE NameToIndex -INTEGER(I4B) :: n, i, ic -n = SIZE(obj%map, 1) - 1 -ic = ICHAR(Name) -ans = 0 -DO i = 1, n - IF (obj%map(i, 1) .EQ. ic) THEN - ans = i - EXIT - END IF -END DO -END PROCEDURE NameToIndex - -!---------------------------------------------------------------------------- -! tspacecomponents -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_tspacecomponents -INTEGER(I4B) :: n, i -n = SIZE(obj%map, 1) - 1 -ans = 0 -DO i = 1, n - IF (obj%map(i, 2) .GT. 0) ans = ans + 1 -END DO -END PROCEDURE obj_tspacecomponents - -!---------------------------------------------------------------------------- -! spacecomponents -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_spacecomponents1 -INTEGER(I4B) :: n, i -CALL Reallocate(ans, SIZE(obj%map, 1) - 1) -DO i = 1, SIZE(ans) - ans(i) = obj%map(i, 2) -END DO -END PROCEDURE obj_spacecomponents1 - -!---------------------------------------------------------------------------- -! spacecomponents -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_spacecomponents2 -ans = obj%map(ivar, 2) -END PROCEDURE obj_spacecomponents2 - -!---------------------------------------------------------------------------- -! ttimecomponents -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ttimecomponents -INTEGER(I4B) :: n, i -n = SIZE(obj%map, 1) - 1 -ans = 0 -DO i = 1, n - IF (obj%map(i, 3) .GT. 1) ans = ans + 1 -END DO -END PROCEDURE obj_ttimecomponents - -!---------------------------------------------------------------------------- -! timecomponents -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_timecomponents1 -INTEGER(I4B) :: n, i -CALL Reallocate(ans, SIZE(obj%map, 1) - 1) -DO i = 1, SIZE(ans) - ans(i) = obj%map(i, 3) -END DO -END PROCEDURE obj_timecomponents1 - -!---------------------------------------------------------------------------- -! timecomponents -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_timecomponents2 -ans = obj%map(ivar, 3) -END PROCEDURE obj_timecomponents2 - -!---------------------------------------------------------------------------- -! EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isEqual -ans = .TRUE. -IF (obj1%storageFMT .NE. obj2%storageFMT) ans = .FALSE. -IF (ANY(obj1%map(:, 2:) .NE. obj2%map(:, 2:))) ans = .FALSE. -IF (ANY(obj1%valmap .NE. obj2%valmap)) ans = .FALSE. -END PROCEDURE obj_isEqual - -!---------------------------------------------------------------------------- -! NE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isNE -ans = .NOT. (obj_isEqual(obj1, obj2)) -END PROCEDURE obj_isNE - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF1 -ans = spacecompo + (timecompo - 1) * tspacecompo -END PROCEDURE obj_GetIDOF1 - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF2 -ans = (obj.DOFStartIndex.ivar) & - + spacecompo - 1 & - + (timecompo - 1) * (obj.spacecomponents.ivar) -END PROCEDURE obj_GetIDOF2 - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF3 -ans = (obj.DOFStartIndex.ivar) & - + spacecompo - 1 & - + (timecompo - 1) * (obj.spacecomponents.ivar) -END PROCEDURE obj_GetIDOF3 - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF4 -ans = (obj.DOFStartIndex.ivar) & - + spacecompo - 1 & - + (timecompo - 1) * (obj.spacecomponents.ivar) -END PROCEDURE obj_GetIDOF4 - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF5 -ans = spacecompo + (timecompo - 1) * tspacecompo -END PROCEDURE obj_GetIDOF5 - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF6 -ans = spacecompo + (timecompo - 1) * tspacecompo -END PROCEDURE obj_GetIDOF6 - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF7 -ans = (obj.DOFStartIndex.ivar) + idof - 1 -END PROCEDURE obj_GetIDOF7 - -!---------------------------------------------------------------------------- -! GetIDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIDOF8 -ans = (obj.DOFStartIndex.ivar) + Arange(1, obj.tdof.ivar) - 1 -END PROCEDURE obj_GetIDOF8 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc1 -IF (obj%storageFMT .EQ. NODES_FMT) THEN - ans = (nodenum - 1) * (.tdof.obj) + idof -ELSE - ans = obj%valmap(idof) + nodenum - 1 -END IF -END PROCEDURE obj_GetNodeLoc1 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc2 -INTEGER(I4B) :: tsize -CALL obj_getnodeloc_2(obj, nodenum, idof, ans, tsize) -END PROCEDURE obj_GetNodeLoc2 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_2 -tsize = SIZE(nodenum) -IF (obj%storageFMT .EQ. NODES_FMT) THEN - ans(1:tsize) = (nodenum - 1) * (.tdof.obj) + idof -ELSE - ans(1:tsize) = obj%valmap(idof) - 1 + nodenum -END IF -END PROCEDURE obj_GetNodeLoc_2 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc3 -INTEGER(I4B) :: tsize -CALL obj_getnodeloc_3(obj, nodenum, idof, ans, tsize) -END PROCEDURE obj_GetNodeLoc3 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_3 -tsize = SIZE(idof) -IF (obj%storageFMT .EQ. NODES_FMT) THEN - ans(1:tsize) = (nodenum - 1) * (.tdof.obj) + idof -ELSE - ans(1:tsize) = obj%valmap(idof) - 1 + nodenum -END IF -END PROCEDURE obj_GetNodeLoc_3 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc4 -IF (obj%storageFMT .EQ. NODES_FMT) THEN - ans = [idof, .tnodes.obj, .tdof.obj] -ELSE - ans = [obj%valmap(idof), obj%valmap(idof + 1) - 1, 1] -END IF -END PROCEDURE obj_GetNodeLoc4 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc5 -IF (obj%storageFMT .EQ. DOF_FMT) THEN - ans = obj%valmap(obj%map(ivar, 5) - 1 + idof) + nodenum - 1 -ELSE - ans = (nodenum - 1) * (.tdof.obj) + (obj%map(ivar, 5) - 1 + idof) -END IF -END PROCEDURE obj_GetNodeLoc5 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc6 -INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_6(obj, nodenum, ivar, idof, ans, tsize) -END PROCEDURE obj_GetNodeLoc6 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_6 -INTEGER(I4B) :: a, b - -tsize = SIZE(nodenum) -a = obj%map(ivar, 5) - 1 + idof - -IF (obj%storageFMT .EQ. DOF_FMT) THEN - ans(1:tsize) = obj%valmap(a) + nodenum - 1 - RETURN -END IF - -b = .tdof.obj -ans(1:tsize) = (nodenum - 1) * b + a -END PROCEDURE obj_GetNodeLoc_6 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc7 -ans = GetNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, & - idof=GetIDOF(spacecompo=spacecompo, & - timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) -END PROCEDURE obj_GetNodeLoc7 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc8 -INTEGER(I4B) :: tsize -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) -END PROCEDURE obj_GetNodeLoc8 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_8 -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) -END PROCEDURE obj_GetNodeLoc_8 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc9 -INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_9(obj, nodenum, ivar, idof, ans, tsize) -END PROCEDURE obj_GetNodeLoc9 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_9 -INTEGER(I4B) :: ii, a, b - -tsize = SIZE(idof) -a = obj%map(ivar, 5) - 1 -b = nodenum - 1 - -IF (obj%storageFMT .EQ. DOF_FMT) THEN - - DO ii = 1, tsize - ans(ii) = obj%valmap(a + idof(ii)) + b - END DO - -ELSE - - b = b * (.tdof.obj) - b = b + a - - DO ii = 1, tsize - ans(ii) = b + idof(ii) - END DO - -END IF - -END PROCEDURE obj_GetNodeLoc_9 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc10 -INTEGER(I4B) :: tsize -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, & - timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) -END PROCEDURE obj_GetNodeLoc10 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_10 -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) -END PROCEDURE obj_GetNodeLoc_10 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc11 -INTEGER(I4B) :: tsize -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) -END PROCEDURE obj_GetNodeLoc11 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_11 -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) -END PROCEDURE obj_GetNodeLoc_11 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc12 -INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_12(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) -END PROCEDURE obj_GetNodeLoc12 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_12 -INTEGER(I4B) :: idofs(SIZE(timecompo)), ii, tempsize, tnode - -tempsize = SIZE(timecompo) -tnode = SIZE(nodenum) -tsize = tempsize * tnode - -idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar) - -tsize = 1 -DO ii = 1, tnode - CALL GetNodeLoc_(obj=obj, nodenum=nodenum(ii), ivar=ivar, idof=idofs, & - ans=ans(tsize:), tsize=tempsize) - tsize = tsize + tempsize -END DO - -tsize = tsize - 1 - -END PROCEDURE obj_GetNodeLoc_12 - -!---------------------------------------------------------------------------- -! GetNodeLoc -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc13 -INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_13(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) -END PROCEDURE obj_GetNodeLoc13 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_13 -INTEGER(I4B) :: idofs(SIZE(spacecompo)), ii, tempsize, tnode - -tempsize = SIZE(spacecompo) -tnode = SIZE(nodenum) -tsize = tempsize * tnode - -idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar) - -tsize = 1 -DO ii = 1, tnode - CALL GetNodeLoc_(obj=obj, nodenum=nodenum(ii), ivar=ivar, idof=idofs, & - ans=ans(tsize:), tsize=tempsize) - tsize = tsize + tempsize -END DO - -tsize = tsize - 1 - -END PROCEDURE obj_GetNodeLoc_13 - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex1 -INTEGER(I4B) :: tsize -tsize = .tdof.obj -ALLOCATE (ans(tsize)) -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, idof=Arange(1, tsize), & - ans=ans, tsize=tsize) -END PROCEDURE obj_GetIndex1 - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex_1 -tsize = .tdof.obj -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, idof=Arange(1, tsize), & - ans=ans, tsize=tsize) -END PROCEDURE obj_GetIndex_1 - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex2 -INTEGER(I4B) :: tsize -tsize = obj.tdof.ivar -ALLOCATE (ans(tsize)) -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=ans, tsize=tsize, & - idof=Arange(obj.DOFStartIndex.ivar, obj.DOFEndIndex.ivar)) -END PROCEDURE obj_GetIndex2 - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex_2 -CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=ans, tsize=tsize, & - idof=Arange(obj.DOFStartIndex.ivar, obj.DOFEndIndex.ivar)) -END PROCEDURE obj_GetIndex_2 - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex3 -ans = GetIndex(obj=obj, ivar=NameToIndex(obj, varName), nodenum=nodenum) -END PROCEDURE obj_GetIndex3 - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex4 -INTEGER(I4B) :: tsize - -tsize = .tdof.obj -tsize = tsize * SIZE(nodenum) - -ALLOCATE (ans(tsize)) - -CALL obj_GetIndex_4(obj, nodenum, ans, tsize) - -END PROCEDURE obj_GetIndex4 - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex_4 -INTEGER(I4B) :: jj, ii, tdof, nn, tempsize - -nn = SIZE(nodenum) - -IF (obj%storageFMT .EQ. FMT_NODES) THEN - - tsize = 1 - - DO ii = 1, nn - CALL GetIndex_(obj=obj, nodenum=nodenum(ii), & - ans=ans(tsize:), tsize=tempsize) - tsize = tsize + tempsize - END DO - - tsize = tsize - 1 - RETURN - -END IF - -tdof = .tdof.obj -tsize = tdof * nn - -DO jj = 1, tdof - DO ii = 1, nn - ans((jj - 1) * nn + ii) = GetNodeLoc(obj=obj, nodenum=nodenum(ii), idof=jj) - END DO -END DO - -END PROCEDURE obj_GetIndex_4 - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex5 -INTEGER(I4B) :: tsize -tsize = obj.tdof.ivar -tsize = tsize * SIZE(nodenum) -ALLOCATE (ans(tsize)) -CALL obj_GetIndex_5(obj, nodenum, ivar, ans, tsize) -END PROCEDURE obj_GetIndex5 - -!---------------------------------------------------------------------------- -! GetIndex_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex_5 -INTEGER(I4B) :: jj, ii, tdof, nn, tempsize - -tdof = obj.tdof.ivar -nn = SIZE(nodenum) - -IF (obj%storageFMT .EQ. FMT_NODES) THEN - - tsize = 1 - DO ii = 1, nn - CALL GetIndex_(obj=obj, nodenum=nodenum(ii), ivar=ivar, ans=ans(tsize:), & - tsize=tempsize) - tsize = tsize + tempsize - - END DO - tsize = tsize - 1 - - RETURN - -END IF - -tsize = tdof * nn -tdof = 0 ! using tdof as counter -DO jj = (obj.DOFStartIndex.ivar), (obj.DOFEndIndex.ivar) - tdof = tdof + 1 - DO ii = 1, nn - ans((tdof - 1) * nn + ii) = GetNodeLoc(obj=obj, nodenum=nodenum(ii), & - idof=jj) - ! here tdof is local counter - END DO -END DO - -END PROCEDURE obj_GetIndex_5 - -!---------------------------------------------------------------------------- -! GetIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex6 -ans = GetIndex(obj=obj, ivar=NameToIndex(obj, varName), nodenum=nodenum) -END PROCEDURE obj_GetIndex6 - -!---------------------------------------------------------------------------- -! GetNodeLoc_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetNodeLoc_14 -INTEGER(I4B) :: jj - -IF (storageFMT .EQ. NODES_FMT) THEN - - ncol = SIZE(nodenum) - DO jj = 1, ncol - CALL GetNodeLoc_(obj=obj, nodenum=nodenum(jj), idof=idof, & - ans=ans(:, jj), tsize=nrow) - END DO - - RETURN -END IF - -ncol = SIZE(idof) -DO jj = 1, ncol - CALL GetNodeLoc_(obj=obj, nodenum=nodenum, idof=idof(jj), & - ans=ans(:, jj), tsize=nrow) -END DO - -END PROCEDURE obj_GetNodeLoc_14 - -END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 deleted file mode 100644 index bbf0d7a77..000000000 --- a/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 +++ /dev/null @@ -1,368 +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(DOF_GetValueMethods) Methods -USE GlobalData, ONLY: DOF_FMT, NODES_FMT - -USE ReallocateUtility, ONLY: Reallocate - -USE DOF_GetMethods, ONLY: OPERATOR(.tdof.), & - GetNodeLoc, & - GetIndex_, & - GetIDOF, & - OPERATOR(.tNodes.), & - GetNodeLoc - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! getArrayvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue1 -INTEGER(I4B) :: tsize -CALL Reallocate(v, SIZE(idof) * SIZE(nodenum)) -CALL GetValue_(v, tsize, val, obj, idof, storageFMT, & - nodenum) -END PROCEDURE obj_GetValue1 - -!---------------------------------------------------------------------------- -! getArrayvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue2 -INTEGER(I4B) :: m, n, i, k -LOGICAL(LGT) :: abool - -k = obj%valmap(idof(1) + 1) - obj%valmap(idof(1)) -m = SIZE(idof) - -DO i = 1, m - k = MAX(k, obj%valmap(idof(i) + 1) - obj%valmap(idof(i))) -END DO - -abool = PRESENT(force3D) .AND. (m .LT. 3) -IF (abool) m = 3 - -CALL Reallocate(v, m, k) -CALL GetValue_(v, val, m, k, obj, idof, force3D) - -END PROCEDURE obj_GetValue2 - -!---------------------------------------------------------------------------- -! getArrayvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue3 -INTEGER(I4B) :: i, k - -k = 0 -DO i = 1, SIZE(idof) - k = k + obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) -END DO - -CALL Reallocate(v, k) -CALL GetValue_(v, k, val, obj, idof, storageFMT) - -END PROCEDURE obj_GetValue3 - -!---------------------------------------------------------------------------- -! Arrayvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_get1 -CALL GetValue(v=ans, val=val, obj=obj, idof=idof, nodenum=nodenum, & - StorageFMT=StorageFMT) -END PROCEDURE obj_get1 - -!---------------------------------------------------------------------------- -! Arrayvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_get2 -CALL GetValue(v=ans, val=val, obj=obj, idof=idof, StorageFMT=StorageFMT) -END PROCEDURE obj_get2 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_1 -INTEGER(I4B) :: m, n, i, k, tdof -m = SIZE(idof) -n = SIZE(nodenum) - -tsize = m * n - -SELECT CASE (obj%StorageFMT) - -CASE (DOF_FMT) - - ! Returned storage format is NOT same as the storage format of the object - ! that is NODES_FMT - IF (StorageFMT .EQ. NODES_FMT) THEN - - DO CONCURRENT(i=1:m, k=1:n) - v((k - 1) * m + i) = val(nodenum(k) + obj%valmap(idof(i)) - 1) - END DO - - RETURN - - END IF - - ! Returned storage format is same as the storage format of the object - ! that is DOF_FMT - DO CONCURRENT(i=1:m) - v((i - 1) * n + 1:i * n) = val(nodenum + obj%valmap(idof(i)) - 1) - END DO - -CASE (NODES_FMT) - - tdof = .tdof.obj - - ! Returned storage format is NOT same as the storage format of the object - ! that is DOF_FMT - IF (StorageFMT .EQ. DOF_FMT) THEN - - DO CONCURRENT(i=1:n, k=1:m) - v((k - 1) * n + i) = val((nodenum(i) - 1) * tdof + idof(k)) - END DO - - RETURN - - END IF - - ! Returned storage format is same as the storage format of the object - ! that is NODES_FMT - DO CONCURRENT(i=1:n, k=1:m) - v((i - 1) * m + k) = val((nodenum(i) - 1) * tdof + idof(k)) - END DO - -END SELECT - -END PROCEDURE obj_GetValue_1 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_2 -INTEGER(I4B) :: m, n, i, k, tdof -LOGICAL(LGT) :: abool - -k = obj%valmap(idof(1) + 1) - obj%valmap(idof(1)) -m = SIZE(idof) - -DO i = 1, m - k = MAX(k, obj%valmap(idof(i) + 1) - obj%valmap(idof(i))) -END DO -ncol = k - -nrow = m -abool = PRESENT(force3D) .AND. (m .LT. 3) -IF (abool) nrow = 3 - -tdof = .tdof.obj - -SELECT CASE (obj%StorageFMT) - -CASE (DOF_FMT) - - DO i = 1, m - n = obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) - ! length of idof( i ) - DO k = 1, n - v(i, k) = val(k + obj%valmap(idof(i)) - 1) - END DO - END DO - -CASE (NODES_FMT) - - n = obj%valmap(2) - obj%valmap(1) ! size of dof; homogenous - DO i = 1, n - DO k = 1, m - v(k, i) = val((i - 1) * tdof + idof(k)) - END DO - END DO - -END SELECT - -END PROCEDURE obj_GetValue_2 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_3 -INTEGER(I4B) :: m, n, i, k, tdof, tsize_idof - -tsize_idof = SIZE(idof) - -k = 0 -DO i = 1, tsize_idof - k = k + obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) -END DO - -tsize = k - -SELECT CASE (obj%StorageFMT) - -CASE (DOF_FMT) - - IF (StorageFMT .EQ. NODES_FMT) THEN - - tdof = .tdof.obj - m = tsize_idof - DO i = 1, m - n = obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) - DO k = 1, n - v((k - 1) * m + i) = val(k + obj%valmap(idof(i)) - 1) - END DO - END DO - - RETURN - - END IF - - m = 0; n = 0 - DO i = 1, tsize_idof - m = n + 1 - n = n + obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) - v(m:n) = & - val(obj%valmap(idof(i)):obj%valmap(idof(i + 1) - 1)) - END DO - -CASE (Nodes_FMT) - - tdof = .tdof.obj - m = tsize_idof - - IF (StorageFMT .EQ. DOF_FMT) THEN - n = obj%valmap(2) - obj%valmap(1) - DO i = 1, n - DO k = 1, m - v((k - 1) * n + i) = val((i - 1) * tdof + idof(k)) - END DO - END DO - RETURN - END IF - - DO i = 1, obj%valmap(2) - obj%valmap(1) - DO k = 1, m - v((i - 1) * m + k) & - = val((i - 1) * tdof + idof(k)) - END DO - END DO - -END SELECT - -END PROCEDURE obj_GetValue_3 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_4 -INTEGER(I4B) :: ii, jj - -tsize = .tdof.obj - -DO ii = 1, tsize - jj = GetNodeLoc(obj=obj, nodenum=nodenum, idof=ii) - v(ii) = val(jj) -END DO - -END PROCEDURE obj_GetValue_4 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_5 -INTEGER(I4B) :: ii, jj, kk - -tsize = obj.tdof.ivar - -DO ii = 1, tsize - kk = GetIDOF(obj=obj, ivar=ivar, idof=ii) - jj = GetNodeLoc(obj=obj, nodenum=nodenum, idof=kk) - v(ii) = val(jj) -END DO - -END PROCEDURE obj_GetValue_5 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_6 -INTEGER(I4B) :: ii, jj, kk -INTEGER(I4B), ALLOCATABLE :: indx(:) - -tsize = .tdof.obj -tsize = tsize * SIZE(nodenum) -ALLOCATE (indx(tsize)) -CALL GetIndex_(obj=obj, nodenum=nodenum, ans=indx, tsize=tsize) - -DO CONCURRENT(ii=1:tsize) - v(ii) = val(indx(ii)) -END DO - -DEALLOCATE (indx) - -END PROCEDURE obj_GetValue_6 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_7 -INTEGER(I4B) :: ii, jj - -tsize = SIZE(nodenum) - -DO ii = 1, tsize - jj = GetNodeLoc(obj=obj, nodenum=nodenum(ii), idof=idof) - v(ii) = val(jj) -END DO - -END PROCEDURE obj_GetValue_7 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_8 -INTEGER(I4B) :: ii, jj, s(3) - -tsize = obj.tNodes.idof -s = GetNodeLoc(obj=obj, idof=idof) - -DO CONCURRENT(jj=s(1):s(2):s(3)) - ii = INT((jj - s(1) + s(3)) / s(3)) - v(ii) = val(jj) -END DO - -END PROCEDURE obj_GetValue_8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 deleted file mode 100644 index 5fda02d7e..000000000 --- a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 +++ /dev/null @@ -1,94 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This submodule contains IO method for [[DOF_]] - -SUBMODULE(DOF_IOMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dof_Display1 -INTEGER(I4B) :: n, j - -IF (LEN_TRIM(msg) .NE. 0) THEN - CALL Display("# "//TRIM(msg), unitNo=unitNo) -END IF -IF (ALLOCATED(obj%Map)) THEN - ASSOCIATE (Map => obj%Map, ValMap => obj%ValMap) - n = SIZE(Map, 1) - 1 - CALL Display(n, "# Total Physical Variables :", unitNo=unitNo) - DO j = 1, n - CALL Display("# Name : "//CHAR(Map(j, 1)), unitNo=unitNo) - IF (Map(j, 2) .LT. 0) THEN - CALL Display("# Space Components : "//"Scalar", unitNo=unitNo) - ELSE - CALL Display(Map(j, 2), "# Space Components : ", unitNo=unitNo) - END IF - CALL Display(Map(j, 3), "# Time Components : ", unitNo=unitNo) - CALL Display(Map(j, 6), "# Total Nodes : ", unitNo=unitNo) - END DO - SELECT CASE (obj%StorageFMT) - CASE (DOF_FMT) - CALL Display("# Storage Format : DOF", unitNo=unitNo) - CASE (Nodes_FMT) - CALL Display("# Storage Format : Nodes", unitNo=unitNo) - END SELECT - CALL Display(obj%ValMap, "# Value Map : ", unitNo=unitNo) - END ASSOCIATE -ELSE - CALL Display("# obj%Map : NOT ALLOCATED") -END IF -END PROCEDURE dof_Display1 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dof_display2 -INTEGER(I4B) :: jj, tnames, idof, a(3) -!> main -CALL Display(obj, '# DOF data : ', unitNo=unitNo) -tnames = .tNames.obj -DO jj = 1, tnames - 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") - END DO - CALL Display(" ", unitNo=unitNo, advance=.TRUE.) -END DO -END PROCEDURE dof_display2 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -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 SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 deleted file mode 100644 index 7171df3cd..000000000 --- a/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 +++ /dev/null @@ -1,319 +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(DOF_SetMethods) Methods -USE DOF_GetMethods, ONLY: GetIndex, & - GetNodeLoc, & - OPERATOR(.tdof.) -USE GlobalData, ONLY: DOF_FMT, NODES_FMT, NodesToDOF, DOFToNodes -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set1 -INTEGER(I4B) :: tdof, idof, i, n, m - -tdof = .tdof.obj -n = SIZE(nodenum) -m = SIZE(VALUE) - -ASSOCIATE (vm => obj%valmap) - SELECT CASE (obj%StorageFMT) - CASE (DOF_FMT) - IF (m .NE. n) THEN - IF (m .EQ. 1) THEN - DO idof = 1, tdof - Vec(vm(idof) - 1 + nodenum) = VALUE(1) - END DO - ELSE IF (m .EQ. tdof * n) THEN - IF (Conversion(1) .EQ. NodesToDOF) THEN - DO idof = 1, tdof - DO i = 1, n - Vec(vm(idof) - 1 + nodenum(i)) = & - & VALUE((i - 1) * tdof + idof) - END DO - END DO - ELSE - DO idof = 1, tdof - Vec(vm(idof) - 1 + nodenum) = & - & VALUE((idof - 1) * n + 1:idof * n) - END DO - END IF - END IF - ELSE - DO idof = 1, tdof - Vec(vm(idof) - 1 + nodenum) = VALUE(:) - END DO - END IF - - CASE (NODES_FMT) - IF (m .NE. n) THEN - IF (m .EQ. 1) THEN - DO idof = 1, tdof - Vec((nodenum - 1) * tdof + idof) = VALUE(1) - END DO - ELSE IF (m .EQ. tdof * n) THEN - IF (Conversion(1) .EQ. DOFToNodes) THEN - DO idof = 1, tdof - DO i = 1, n - Vec((nodenum(i) - 1) * tdof + idof) & - & = VALUE((idof - 1) * n + i) - END DO - END DO - ELSE - DO idof = 1, tdof - DO i = 1, n - Vec((nodenum(i) - 1) * tdof + idof) & - & = VALUE((i - 1) * tdof + idof) - END DO - END DO - END IF - END IF - ELSE - DO idof = 1, tdof - Vec((nodenum - 1) * tdof + idof) = VALUE(:) - END DO - END IF - END SELECT -END ASSOCIATE -END PROCEDURE obj_set1 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set2 -vec(GetIndex(obj=obj, nodenum=nodenum)) = VALUE -END PROCEDURE obj_set2 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set3 - -IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN - Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & idof=idof)) = VALUE(:) - RETURN -END IF - -Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & idof=idof)) = VALUE(1) - -END PROCEDURE obj_set3 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set4 - -IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN - Vec( & - & GetIndex( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & idof=idof)) & - & = VALUE(:) - RETURN -END IF - -Vec( & - & GetIndex( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & idof=idof)) & - & = VALUE(1) - -END PROCEDURE obj_set4 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set5 - -IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN - - Vec(GetNodeLoc(& - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) & - & = VALUE(:) - RETURN -END IF - -Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) & - & = VALUE(1) - -END PROCEDURE obj_set5 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set6 - -IF (SIZE(nodenum) .EQ. SIZE(VALUE) * SIZE(timecompo)) THEN - Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) & - & = VALUE(:) - RETURN -END IF - -Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) & - & = VALUE(1) - -END PROCEDURE obj_set6 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set7 - -IF (SIZE(nodenum) .EQ. SIZE(VALUE) * SIZE(spacecompo)) THEN - Vec(GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) & - & = VALUE(:) - RETURN -END IF - -Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) & - & = VALUE(1) - -END PROCEDURE obj_set7 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set8 -vec( & - & GetIndex( & - & obj=obj, & - & nodenum=nodenum)) = VALUE -END PROCEDURE obj_set8 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set9 -Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & idof=idof)) = VALUE -END PROCEDURE obj_set9 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set10 -Vec( & - & GetNodeLoc( & - & obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & idof=idof)) = VALUE -END PROCEDURE obj_set10 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set11 -Vec(GetNodeLoc(obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) = VALUE -END PROCEDURE obj_set11 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set12 -Vec(GetNodeLoc(obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) = VALUE -END PROCEDURE obj_set12 - -!---------------------------------------------------------------------------- -! setvalue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_set13 -Vec(GetNodeLoc(obj=obj, & - & nodenum=nodenum, & - & ivar=ivar, & - & spacecompo=spacecompo, & - & timecompo=timecompo)) = VALUE -END PROCEDURE obj_set13 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/DiffusionMatrix/CMakeLists.txt b/src/submodules/DiffusionMatrix/CMakeLists.txt deleted file mode 100644 index 38ed8ff50..000000000 --- a/src/submodules/DiffusionMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/DiffusionMatrix_Method@Methods.F90 - ) diff --git a/src/submodules/DiffusionMatrix/src/DM_1.inc b/src/submodules/DiffusionMatrix/src/DM_1.inc deleted file mode 100644 index 9517abe0d..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_1.inc +++ /dev/null @@ -1,55 +0,0 @@ - -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE DM_1(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! a scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! - !! internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - !! - realval = trial%js * trial%ws * trial%thickness * kbar - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - DO ii = 1, SIZE(realval) - !! - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - !! - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (kbar, realval) -END SUBROUTINE DM_1 diff --git a/src/submodules/DiffusionMatrix/src/DM_10.inc b/src/submodules/DiffusionMatrix/src/DM_10.inc deleted file mode 100644 index 040bbf3c3..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_10.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 -! -!! -!! vector -!! matrix -!! -PURE SUBROUTINE DM_10(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: c1 - !! vector variable - TYPE(FEVariable_), INTENT(IN) :: c2 - !! matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! internal variable - REAL(DFP), ALLOCATABLE :: matbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - TYPE(FEVariable_) :: k - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) - CALL getInterpolation(obj=trial, interpol=matbar, val=c2) - CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) - !! - DO ii = 1, SIZE(c2bar, 2) - c1bar(:,ii) = MATMUL(c2bar(:,ii), matbar(:,:,ii)) - END DO - !! - k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - realval = trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval, matbar) -END SUBROUTINE DM_10 diff --git a/src/submodules/DiffusionMatrix/src/DM_2.inc b/src/submodules/DiffusionMatrix/src/DM_2.inc deleted file mode 100644 index 95eaf72a7..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_2.inc +++ /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 -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE DM_2(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! a vector variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! - !! internal variable - !! - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - !! - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - !! - realval = trial%js * trial%ws * trial%thickness - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval) -END SUBROUTINE DM_2 diff --git a/src/submodules/DiffusionMatrix/src/DM_3.inc b/src/submodules/DiffusionMatrix/src/DM_3.inc deleted file mode 100644 index 5e67de895..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_3.inc +++ /dev/null @@ -1,55 +0,0 @@ - -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE DM_3(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! a matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! - !! internal variable - REAL(DFP), ALLOCATABLE :: kbar(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - !! - realval = trial%js * trial%ws * trial%thickness - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(& - & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (kbar, realval) - !! -END SUBROUTINE DM_3 diff --git a/src/submodules/DiffusionMatrix/src/DM_4.inc b/src/submodules/DiffusionMatrix/src/DM_4.inc deleted file mode 100644 index 6968f1073..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_4.inc +++ /dev/null @@ -1,60 +0,0 @@ - -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- -!! -!! vector -!! vector -!! -PURE SUBROUTINE DM_4(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! a vector variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! a vector variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) - !! - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval) - !! -END SUBROUTINE DM_4 diff --git a/src/submodules/DiffusionMatrix/src/DM_5.inc b/src/submodules/DiffusionMatrix/src/DM_5.inc deleted file mode 100644 index 19137878e..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_5.inc +++ /dev/null @@ -1,60 +0,0 @@ - -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- -!! -!! scalar -!! matrix -!! -PURE SUBROUTINE DM_5(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! a scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! a matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: kbar(:, :,:), realval(:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL getInterpolation(obj=trial, Interpol=realval, val=c1) - !! - CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) - !! - realval = realval * trial%js * trial%ws * trial%thickness - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(& - & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE(realval, kbar) - !! -END SUBROUTINE DM_5 diff --git a/src/submodules/DiffusionMatrix/src/DM_6.inc b/src/submodules/DiffusionMatrix/src/DM_6.inc deleted file mode 100644 index 1219d3a13..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_6.inc +++ /dev/null @@ -1,55 +0,0 @@ - -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- -!! -!! scalar -!! scalar -!! -PURE SUBROUTINE DM_6(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! a scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! a scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, Interpol=realval, val=c2) - realval = realval * trial%js * trial%ws * trial%thickness * cbar - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (cbar, realval) -END SUBROUTINE DM_6 diff --git a/src/submodules/DiffusionMatrix/src/DM_7.inc b/src/submodules/DiffusionMatrix/src/DM_7.inc deleted file mode 100644 index 079844613..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_7.inc +++ /dev/null @@ -1,54 +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 -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- -!! -!! scalar -!! vector -!! -PURE SUBROUTINE DM_7(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! a scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! a vector variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! internal variable - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii - !! main - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) - CALL getInterpolation(obj=trial, interpol=realval, val=c1) - realval = realval * trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval) -END SUBROUTINE DM_7 diff --git a/src/submodules/DiffusionMatrix/src/DM_8.inc b/src/submodules/DiffusionMatrix/src/DM_8.inc deleted file mode 100644 index 9fac7662e..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_8.inc +++ /dev/null @@ -1,63 +0,0 @@ - -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- -!! -!! matrix -!! matrix -!! -PURE SUBROUTINE DM_8(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! a matrix variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! a matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! internal variable - REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) - !! - CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) - !! - realval = trial%js * trial%ws * trial%thickness - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - DO ii = 1, SIZE(realval) - !! - ans = ans + realval(ii) * MATMUL( & - & MATMUL(test%dNdXt(:, :, ii),& - & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - !! - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (k1bar, k2bar, realval) - !! -END SUBROUTINE DM_8 diff --git a/src/submodules/DiffusionMatrix/src/DM_9.inc b/src/submodules/DiffusionMatrix/src/DM_9.inc deleted file mode 100644 index c2367cc8d..000000000 --- a/src/submodules/DiffusionMatrix/src/DM_9.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 -! -!! -!! matrix -!! vector -!! -PURE SUBROUTINE DM_9(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - TYPE(FEVariable_), INTENT(IN) :: c1 - !! matrix variable - TYPE(FEVariable_), INTENT(IN) :: c2 - !! vector variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! internal variable - REAL(DFP), ALLOCATABLE :: matbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - TYPE(FEVariable_) :: k - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, interpol=matbar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) - !! - DO ii = 1, SIZE(c2bar, 2) - c1bar(:,ii) = MATMUL(matbar(:,:,ii), c2bar(:,ii)) - END DO - !! - k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - realval = trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval, matbar) -END SUBROUTINE DM_9 diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 deleted file mode 100644 index 755daed8f..000000000 --- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 +++ /dev/null @@ -1,548 +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(DiffusionMatrix_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_1 - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - realval = trial%js * trial%ws * trial%thickness - DO ii = 1, SIZE(trial%N, 2) - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (realval) - !! -END PROCEDURE DiffusionMatrix_1 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_2 - REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - !! - realval = trial%js * trial%ws * trial%thickness * kbar - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - DO ii = 1, SIZE(realval) - !! - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - !! - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (kbar, realval) -END PROCEDURE DiffusionMatrix_2 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_3 - !! - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - !! - realval = trial%js * trial%ws * trial%thickness - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval) - !! -END PROCEDURE DiffusionMatrix_3 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_4 - ! CALL DM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) - !! internal variable - REAL(DFP), ALLOCATABLE :: kbar(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - !! - realval = trial%js * trial%ws * trial%thickness - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(& - & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (kbar, realval) - !! -END PROCEDURE DiffusionMatrix_4 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_5 - !! scalar - !! scalar - !! CALL DM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, Interpol=realval, val=c2) - realval = realval * trial%js * trial%ws * trial%thickness * cbar - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (cbar, realval) -END PROCEDURE DiffusionMatrix_5 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_6 - !! scalar - !! vector - !! CALL DM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii - !! main - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) - CALL getInterpolation(obj=trial, interpol=realval, val=c1) - realval = realval * trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval) - !! -END PROCEDURE DiffusionMatrix_6 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_7 - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: kbar(:, :,:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL getInterpolation(obj=trial, Interpol=realval, val=c1) - CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) - realval = realval * trial%js * trial%ws * trial%thickness - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(& - & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - DEALLOCATE(realval, kbar) - !! -END PROCEDURE DiffusionMatrix_7 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_8 - !! - ans = DiffusionMatrix( & - & test=test, & - & trial=trial, & - & c1=c2, & - & c2=c1, & - & c1rank=TypeFEVariableScalar, & - & c2rank=TypeFEVariableVector, & - & opt=opt) - !! -END PROCEDURE DiffusionMatrix_8 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_9 - !! Internal variable - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii - !! - !! main - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) - realval = trial%js * trial%ws * trial%thickness - !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - DEALLOCATE (c1bar, c2bar, realval) - !! -END PROCEDURE DiffusionMatrix_9 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_10 - !! internal variable - REAL(DFP), ALLOCATABLE :: matbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - TYPE(FEVariable_) :: k - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) - CALL getInterpolation(obj=trial, interpol=matbar, val=c2) - CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) - !! - DO ii = 1, SIZE(c2bar, 2) - c1bar(:,ii) = MATMUL(c2bar(:,ii), matbar(:,:,ii)) - END DO - !! - k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - realval = trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval, matbar) - !! -END PROCEDURE DiffusionMatrix_10 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_11 - !! - ans = DiffusionMatrix( & - & test=test, & - & trial=trial, & - & c1=c2, c2=c1, & - & c1rank=TypeFEVariableScalar, & - & c2rank=TypeFEVariableMatrix, & - & opt=opt ) - !! -END PROCEDURE DiffusionMatrix_11 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_12 - !! internal variable - REAL(DFP), ALLOCATABLE :: matbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - TYPE(FEVariable_) :: k - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, interpol=matbar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) - !! - DO ii = 1, SIZE(c2bar, 2) - c1bar(:,ii) = MATMUL(matbar(:,:,ii), c2bar(:,ii)) - END DO - !! - k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - realval = trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval, matbar) -END PROCEDURE DiffusionMatrix_12 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_13 - !! internal variable - REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) - INTEGER(I4B) :: ii - !! main - CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) - CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - realval = trial%js * trial%ws * trial%thickness - !! - DO ii = 1, SIZE(realval) - !! - ans = ans + realval(ii) * MATMUL( & - & MATMUL(test%dNdXt(:, :, ii),& - & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - !! - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - DEALLOCATE (k1bar, k2bar, realval) -END PROCEDURE DiffusionMatrix_13 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_14 - !! - SELECT CASE( opt(1) ) - CASE( 1 ) - CALL DiffusionMatrix_14a( test, trial, ans ) - CASE( 2 ) - CALL DiffusionMatrix_14b( test, trial, ans ) - END SELECT - !! -END PROCEDURE DiffusionMatrix_14 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE DiffusionMatrix_14a( test, trial, ans ) - !! - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) - !! - REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : ) - INTEGER(I4B) :: ii, jj, nsd, ips - !! - realval = trial%js * trial%ws * trial%thickness - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) - !! - DO ips = 1, SIZE(trial%N, 2) - DO jj = 1, nsd - DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, ii, ips ), & - & trial%dNdXt(:, jj, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE (realval, m4) - !! -END SUBROUTINE DiffusionMatrix_14a - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE DiffusionMatrix_14b( test, trial, ans ) - !! - CLASS(ElemshapeData_), INTENT(IN) :: test - CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) - !! - REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : ) - INTEGER(I4B) :: ii, jj, nsd, ips - !! - realval = trial%js * trial%ws * trial%thickness - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) - !! - DO ips = 1, SIZE(trial%N, 2) - DO jj = 1, nsd - DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, jj, ips ), & - & trial%dNdXt(:, ii, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE (realval, m4) - !! -END SUBROUTINE DiffusionMatrix_14b - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiffusionMatrix_15 - !! - SELECT CASE( opt(1) ) - CASE( 1 ) - CALL DiffusionMatrix_15a( test, trial, k, ans ) - CASE( 2 ) - CALL DiffusionMatrix_15b( test, trial, k, ans ) - END SELECT - !! -END PROCEDURE DiffusionMatrix_15 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE DiffusionMatrix_15a( test, trial, k, ans ) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! scalar - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) - !! - !! internal variables - !! - REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : ) - INTEGER(I4B) :: ii, jj, nsd, ips - !! - !! main - !! - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - realval = trial%js * trial%ws * trial%thickness * kbar - !! - DO ips = 1, SIZE(trial%N, 2) - DO jj = 1, nsd - DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, ii, ips ), & - & trial%dNdXt(:, jj, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE (kbar, realval, m4) - !! -END SUBROUTINE DiffusionMatrix_15a - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE DiffusionMatrix_15b( test, trial, k, ans ) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! scalar - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) - !! - !! internal variables - !! - REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : ) - INTEGER(I4B) :: ii, jj, nsd, ips - !! - !! main - !! - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - realval = trial%js * trial%ws * trial%thickness * kbar - !! - DO ips = 1, SIZE(trial%N, 2) - DO jj = 1, nsd - DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, jj, ips ), & - & trial%dNdXt(:, ii, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE (kbar, realval, m4) - !! -END SUBROUTINE DiffusionMatrix_15b - -END SUBMODULE Methods diff --git a/src/submodules/ElasticNitscheMatrix/CMakeLists.txt b/src/submodules/ElasticNitscheMatrix/CMakeLists.txt deleted file mode 100644 index 8d42f639f..000000000 --- a/src/submodules/ElasticNitscheMatrix/CMakeLists.txt +++ /dev/null @@ -1,26 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ElasticNitscheMatrix_Method@Matrix1.F90 - ${src_path}/ElasticNitscheMatrix_Method@Matrix2.F90 - ${src_path}/ElasticNitscheMatrix_Method@Matrix3.F90 - ${src_path}/ElasticNitscheMatrix_Method@MatrixNormal.F90 - ${src_path}/ElasticNitscheMatrix_Method@MatrixTangent.F90 - ) diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 deleted file mode 100644 index 8a82a9b17..000000000 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 +++ /dev/null @@ -1,312 +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(ElasticNitscheMatrix_Method) Matrix1 -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! NitscheMatrix -!---------------------------------------------------------------------------- - -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) -DEALLOCATE (lamBar, muBar, evecBar) -END PROCEDURE ElasticNitscheMatrix1a - -!---------------------------------------------------------------------------- -! NitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1b -REAL(DFP), ALLOCATABLE :: evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) -ans = ElasticNitscheMatrix( & -& test=test, & -& trial=trial, & -& lambda=lambda, & -& mu=mu, & -& evec=evecBar) -DEALLOCATE (evecBar) -END PROCEDURE ElasticNitscheMatrix1b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1c -REAL(DFP), ALLOCATABLE :: evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) -ans = ElasticNitscheMatrix(test=test, trial=trial, & - & lambda=lambda, mu=mu, evec=evecBar) -DEALLOCATE (evecBar) -END PROCEDURE ElasticNitscheMatrix1c - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1d -REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i -REAL(DFP) :: dd(3, 3) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -realval = trial%Ws * trial%Js * trial%Thickness -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP - -DO ips = 1, nips - dd(1:nsd, 1:nsd) = & - & lambda(ips) * realval(ips) & - & * DOT_PRODUCT(trial%normal(1:nsd, ips), evec(1:nsd, ips)) & - & * Eye3(1:nsd, 1:nsd) & - & + 2.0 * mu(ips) * realval(ips) & - & * OUTERPROD(a=trial%normal(1:nsd, ips), & - & b=evec(1:nsd, ips), & - & Sym=.TRUE.) - - ff = OUTERPROD( & - & test%N(1:nns1, ips), & - & RESHAPE( & - & MATMUL( & - & trial%dNdXt(1:nns2, 1:nsd, ips), & - & dd(1:nsd, 1:nsd) & - & ), & - & [nsd * nns2] & - & ) & - & ) - - r1 = 0; r2 = 0 - DO i = 1, nsd - r1 = r2 + 1; r2 = i * nns1 - ans(r1:r2, :) = ans(r1:r2, :) + evec(i, ips) * ff - END DO -END DO - -DEALLOCATE (realval, ff) - -END PROCEDURE ElasticNitscheMatrix1d - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1e -REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j -REAL(DFP) :: dd(3, 3) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -realval = trial%Ws * trial%Js * trial%Thickness -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -ans = 0.0_DFP - -DO ips = 1, nips - dd(1:nsd, 1:nsd) = & - & lambda * realval(ips) & - & * DOT_PRODUCT(trial%normal(1:nsd, ips), evec(1:nsd, ips)) & - & * Eye3(1:nsd, 1:nsd) & - & + 2.0 * mu * realval(ips) & - & * OUTERPROD(a=trial%normal(1:nsd, ips), & - & b=evec(1:nsd, ips), & - & Sym=.TRUE.) - - ff = OUTERPROD( & - & test%N(1:nns1, ips), & - & RESHAPE( & - & MATMUL( & - & trial%dNdXt(1:nns2, 1:nsd, ips), & - & dd(1:nsd, 1:nsd) & - & ), & - & [nsd * nns2] & - & ) & - & ) - - r1 = 0; r2 = 0 - DO i = 1, nsd - r1 = r2 + 1; r2 = i * nns1 - ans(r1:r2, :) = ans(r1:r2, :) + evec(i, ips) * ff - END DO -END DO - -DEALLOCATE (realval, ff) - -END PROCEDURE ElasticNitscheMatrix1e - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1f -REAL(DFP), ALLOCATABLE :: evecBar(:, :) -INTEGER(I4B) :: ii, nips -nips = SIZE(trial%N, 2) -ALLOCATE (evecBar(SIZE(evec), nips)) -DO ii = 1, nips - evecBar(:, ii) = evec -END DO -ans = ElasticNitscheMatrix(test=test, trial=trial, & - & lambda=lambda, mu=mu, evec=evecBar) -DEALLOCATE (evecBar) -END PROCEDURE ElasticNitscheMatrix1f - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1g -REAL(DFP), ALLOCATABLE :: evecBar(:, :) -INTEGER(I4B) :: ii, nips -nips = SIZE(trial%N, 2) -ALLOCATE (evecBar(SIZE(evec), nips)) -DO ii = 1, nips - evecBar(:, ii) = evec -END DO -ans = ElasticNitscheMatrix(test=test, trial=trial, & - & lambda=lambda, mu=mu, evec=evecBar) -DEALLOCATE (evecBar) -END PROCEDURE ElasticNitscheMatrix1g - -!---------------------------------------------------------------------------- -! ElasticNitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1h -REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i -REAL(DFP) :: dd(3, 3) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -realval = trial%Ws * trial%Js * trial%Thickness -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -ans = 0.0_DFP - -r1 = 1; r2 = dim * nns1 - -DO ips = 1, nips - - dd(1:nsd, 1:nsd) = & - & lambda(ips) * realval(ips) * trial%normal(dim, ips) & - & * Eye3(1:nsd, 1:nsd) & - & + 2.0 * mu(ips) * realval(ips) & - & * OUTERPROD(a=trial%normal(1:nsd, ips), & - & b=Eye3(1:nsd, dim), & - & Sym=.TRUE.) - - ff = OUTERPROD( & - & test%N(1:nns1, ips), & - & RESHAPE( & - & MATMUL( & - & trial%dNdXt(1:nns2, 1:nsd, ips), & - & dd(1:nsd, 1:nsd) & - & ), & - & [nsd * nns2] & - & ) & - & ) - - ans(r1:r2, :) = ans(r1:r2, :) + ff -END DO - -DEALLOCATE (realval, ff) - -END PROCEDURE ElasticNitscheMatrix1h - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix1i -REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i -REAL(DFP) :: dd(3, 3) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -realval = trial%Ws * trial%Js * trial%Thickness -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -ans = 0.0_DFP - -r1 = 1; r2 = dim * nns1 - -DO ips = 1, nips - - dd(1:nsd, 1:nsd) = & - & lambda * realval(ips) * trial%normal(dim, ips) & - & * Eye3(1:nsd, 1:nsd) & - & + 2.0 * mu * realval(ips) & - & * OUTERPROD(a=trial%normal(1:nsd, ips), & - & b=Eye3(1:nsd, dim), & - & Sym=.TRUE.) - - ff = OUTERPROD( & - & test%N(1:nns1, ips), & - & RESHAPE( & - & MATMUL( & - & trial%dNdXt(1:nns2, 1:nsd, ips), & - & dd(1:nsd, 1:nsd) & - & ), & - & [nsd * nns2] & - & ) & - & ) - - ans(r1:r2, :) = ans(r1:r2, :) + ff -END DO - -DEALLOCATE (realval, ff) - -END PROCEDURE ElasticNitscheMatrix1i - -!---------------------------------------------------------------------------- -! NitscheMatrix -!---------------------------------------------------------------------------- - -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) -DEALLOCATE (lamBar, muBar) -END PROCEDURE ElasticNitscheMatrix1j - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Matrix1 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 deleted file mode 100644 index efb294ac2..000000000 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 +++ /dev/null @@ -1,154 +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(ElasticNitscheMatrix_Method) Matrix2 -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! NitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix2a -REAL(DFP), ALLOCATABLE :: realval(:), SBar(:), cdNdXt(:, :) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2 - -nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd -!<--- make integration parameters -realval = trial%Ws * trial%Thickness * trial%Js -!<--- allocate ans -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP -ALLOCATE (cdNdXt(SIZE(trial%N, 1), SIZE(trial%N, 2))) -DO i = 1, SIZE(trial%N, 2) - cdNdXt(:, i) = MATMUL(trial%dNdXt(:, :, i), trial%Normal(1:nsd, i)) -END DO - -DO ips = 1, nips - c1 = 0; c2 = 0 - DO j = 1, nsd - c1 = c2 + 1; c2 = j * nns2 - r1 = 0; r2 = 0 - DO i = 1, nsd - r1 = r2 + 1; r2 = i * nns1 - IF (i .EQ. j) THEN - SBar = lambda * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & - & + mu * cdNdXt(:, ips) & - & + mu * trial%normal(j, ips) * trial%dNdXt(:, i, ips) - ELSE - SBar = lambda * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & - & + mu * trial%normal(j, ips) * trial%dNdXt(:, i, ips) - END IF - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) & - & + realval(ips) * OUTERPROD(test%N(:, ips), SBar) - END DO - END DO -END DO - -DEALLOCATE (realval, SBar, cdNdXt) -END PROCEDURE ElasticNitscheMatrix2a - -!---------------------------------------------------------------------------- -! NitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix2b -REAL(DFP), ALLOCATABLE :: realval(:), SBar(:), cdNdXt(:, :), & - & lamBar(:), muBar(:) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2 - -nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd - -SELECT CASE (lambda%VarType) -CASE (Constant) - - ALLOCATE (lamBar(nips)) - lamBar = Get(lambda, TypeFEVariableScalar, & - & TypeFEVariableConstant) - -CASE (Space) - - realval = Get(lambda, TypeFEVariableScalar, & - & TypeFEVariableSpace) - - IF (lambda%DefineOn .EQ. Nodal) THEN - lamBar = Interpolation(trial, realval) - ELSE - lamBar = realval - END IF -END SELECT - -SELECT CASE (mu%VarType) -CASE (Constant) - - ALLOCATE (muBar(nips)) - muBar = Get(mu, TypeFEVariableScalar, & - & TypeFEVariableConstant) - -CASE (Space) - - realval = Get(mu, TypeFEVariableScalar, & - & TypeFEVariableSpace) - - IF (mu%DefineOn .EQ. Nodal) THEN - muBar = Interpolation(trial, realval) - ELSE - muBar = realval - END IF -END SELECT - -!<--- make integration parameters -realval = trial%Ws * trial%Thickness * trial%Js -!<--- allocate ans -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP -ALLOCATE (cdNdXt(SIZE(trial%N, 1), SIZE(trial%N, 2))) -DO i = 1, SIZE(trial%N, 2) - cdNdXt(:, i) = MATMUL(trial%dNdXt(:, :, i), trial%Normal(1:nsd, i)) -END DO - -DO ips = 1, nips - c1 = 0; c2 = 0 - DO j = 1, nsd - c1 = c2 + 1; c2 = j * nns2 - r1 = 0; r2 = 0 - DO i = 1, nsd - r1 = r2 + 1; r2 = i * nns1 - IF (i .EQ. j) THEN - SBar = lamBar(ips) * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & - & + muBar(ips) * cdNdXt(:, ips) & - & + muBar(ips) * trial%normal(j, ips) * trial%dNdXt(:, i, ips) - ELSE - SBar = lamBar(ips) * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & - & + muBar(ips) * trial%normal(j, ips) * trial%dNdXt(:, i, ips) - END IF - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) & - & + realval(ips) * OUTERPROD(test%N(:, ips), SBar) - END DO - END DO -END DO - -DEALLOCATE (realval, SBar, cdNdXt, lamBar, muBar) -END PROCEDURE ElasticNitscheMatrix2b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Matrix2 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 deleted file mode 100644 index f18d33209..000000000 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 +++ /dev/null @@ -1,240 +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(ElasticNitscheMatrix_Method) Matrix3 -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! NitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix3a -REAL(DFP), ALLOCATABLE :: alphaBar(:), evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=alphaBar, val=alpha) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) -ans = ElasticNitscheMatrix( & -& test=test, trial=trial, alpha=alphaBar, evec=evecBar) -DEALLOCATE (alphaBar, evecBar) -END PROCEDURE ElasticNitscheMatrix3a - -!---------------------------------------------------------------------------- -! NitscheMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix3b -REAL(DFP), ALLOCATABLE :: evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) -ans = ElasticNitscheMatrix( & -& test=test, trial=trial, alpha=alpha, evec=evecBar) -DEALLOCATE (evecBar) -END PROCEDURE ElasticNitscheMatrix3b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix3c -INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, i, j, r1, r2, c1, c2 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: dd(:, :) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -realval = trial%Ws * trial%Js * trial%Thickness * alpha -ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) -ans = 0.0_DFP - -DO ips = 1, nips - - dd = realval(ips) * & - & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) - - c1 = 0; c2 = 0 - DO j = 1, nsd - c1 = c2 + 1 - c2 = j * nns2 - r1 = 0 - r2 = r1 - DO i = 1, nsd - r1 = r2 + 1 - r2 = i * nns1 - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & - & evec(i, ips) * evec(j, ips) * dd - END DO - END DO -END DO - -DEALLOCATE (realval, dd) - -END PROCEDURE ElasticNitscheMatrix3c - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix3d -INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, i, j, r1, r2, c1, c2 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: dd(:, :) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -realval = trial%Ws * trial%Js * trial%Thickness * alpha -ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) -ans = 0.0_DFP - -DO ips = 1, nips - - dd = realval(ips) * & - & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) - - c1 = 0; c2 = 0 - DO j = 1, nsd - c1 = c2 + 1 - c2 = j * nns2 - r1 = 0 - r2 = r1 - DO i = 1, nsd - r1 = r2 + 1 - r2 = i * nns1 - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & - & evec(i, ips) * evec(j, ips) * dd - END DO - END DO -END DO - -DEALLOCATE (realval, dd) - -END PROCEDURE ElasticNitscheMatrix3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix3e -INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, i, j, r1, r2, c1, c2 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: dd(:, :) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -realval = trial%Ws * trial%Js * trial%Thickness * alpha -ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) -ans = 0.0_DFP - -DO ips = 1, nips - - dd = realval(ips) * & - & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) - - c1 = 0; c2 = 0 - DO j = 1, nsd - c1 = c2 + 1 - c2 = j * nns2 - r1 = 0 - r2 = r1 - DO i = 1, nsd - r1 = r2 + 1 - r2 = i * nns1 - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & - & evec(i) * evec(j) * dd - END DO - END DO -END DO - -DEALLOCATE (realval, dd) - -END PROCEDURE ElasticNitscheMatrix3e - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -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) -DEALLOCATE (alphaBar) -END PROCEDURE ElasticNitscheMatrix3f - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix3g -INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, r1, r2, c1, c2 -REAL(DFP), ALLOCATABLE :: realval(:) -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -realval = trial%Ws * trial%Js * trial%Thickness * alpha -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -ans = 0.0_DFP -r1 = (dim - 1) * nns1 + 1 -r2 = dim * nns1 -c1 = (dim - 1) * nns2 + 1 -c2 = dim * nns2 -DO ips = 1, nips - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & - & realval(ips) * & - & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) -END DO -DEALLOCATE (realval) -END PROCEDURE ElasticNitscheMatrix3g - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrix3h -INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, r1, r2, c1, c2 -REAL(DFP), ALLOCATABLE :: realval(:) -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -realval = trial%Ws * trial%Js * trial%Thickness * alpha -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -ans = 0.0_DFP -r1 = (dim - 1) * nns1 + 1 -r2 = dim * nns1 -c1 = (dim - 1) * nns2 + 1 -c2 = dim * nns2 -DO ips = 1, nips - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & - & realval(ips) * & - & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) -END DO -DEALLOCATE (realval) -END PROCEDURE ElasticNitscheMatrix3h - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Matrix3 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 deleted file mode 100644 index 73d82b6a7..000000000 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 +++ /dev/null @@ -1,137 +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(ElasticNitscheMatrix_Method) MatrixNormal -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! ElasticityNitscheMatrixNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrixNormal1a -REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i -REAL(DFP) :: dd(3, 3) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -realval = trial%Ws * trial%Js * trial%Thickness -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -ans = 0.0_DFP - -DO ips = 1, nips - dd(1:nsd, 1:nsd) = & - & lambda(ips) * realval(ips) & - & * Eye3(1:nsd, 1:nsd) & - & + 2.0 * mu(ips) * realval(ips) & - & * OUTERPROD(a=trial%normal(1:nsd, ips), & - & b=trial%normal(1:nsd, ips)) - - ff = OUTERPROD( & - & test%N(1:nns1, ips), & - & RESHAPE( & - & MATMUL( & - & trial%dNdXt(1:nns2, 1:nsd, ips), & - & dd(1:nsd, 1:nsd) & - & ), & - & [nsd * nns2] & - & ) & - & ) - - r1 = 0; r2 = 0 - DO i = 1, nsd - r1 = r2 + 1; r2 = i * nns1 - ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff - END DO -END DO - -DEALLOCATE (realval, ff) - -END PROCEDURE ElasticNitscheMatrixNormal1a - -!---------------------------------------------------------------------------- -! ElasticityNitscheMatrixNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrixNormal1b -REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i -REAL(DFP) :: dd(3, 3) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd -ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -realval = trial%Ws * trial%Js * trial%Thickness -ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -ans = 0.0_DFP - -DO ips = 1, nips - dd(1:nsd, 1:nsd) = & - & lambda * realval(ips) & - & * Eye3(1:nsd, 1:nsd) & - & + 2.0 * mu * realval(ips) & - & * OUTERPROD(a=trial%normal(1:nsd, ips), & - & b=trial%normal(1:nsd, ips)) - - ff = OUTERPROD( & - & test%N(1:nns1, ips), & - & RESHAPE( & - & MATMUL( & - & trial%dNdXt(1:nns2, 1:nsd, ips), & - & dd(1:nsd, 1:nsd) & - & ), & - & [nsd * nns2] & - & ) & - & ) - - r1 = 0; r2 = 0 - DO i = 1, nsd - r1 = r2 + 1; r2 = i * nns1 - ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff - END DO -END DO - -DEALLOCATE (realval, ff) - -END PROCEDURE ElasticNitscheMatrixNormal1b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElasticNitscheMatrixNormal1c -REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:) -CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda) -CALL getInterpolation(obj=trial, interpol=muBar, val=mu) -ans = ElasticNitscheMatrixNormal( & -& test=test, trial=trial, lambda=lamBar, mu=muBar) -DEALLOCATE (lamBar, muBar) -END PROCEDURE ElasticNitscheMatrixNormal1c - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE MatrixNormal diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 deleted file mode 100644 index 677cb68ab..000000000 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 +++ /dev/null @@ -1,132 +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(ElasticNitscheMatrix_Method) MatrixTangent -USE BaseMethod -IMPLICIT NONE - -CONTAINS -! -! !---------------------------------------------------------------------------- -! ! ElasticityNitscheMatrixTangent -! !---------------------------------------------------------------------------- -! -! MODULE PROCEDURE ElasticNitscheMatrixTangent1a -! REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -! INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i -! REAL(DFP) :: dd(3, 3), s(3) -! -! nns1 = SIZE(test%N, 1) -! nns2 = SIZE(trial%N, 1) -! nips = SIZE(trial%N, 2) -! nsd = trial%refElem%nsd -! ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -! realval = trial%Ws * trial%Js * trial%Thickness -! ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -! ans = 0.0_DFP -! -! DO ips = 1, nips -! dd(1:nsd, 1:nsd) = & -! & 2.0 * mu(ips) * realval(ips) & -! & * OUTERPROD(a=trial%normal(1:nsd, ips), & -! & b=trial%normal(1:nsd, ips)) -! -! ff = OUTERPROD( & -! & test%N(1:nns1, ips), & -! & RESHAPE( & -! & MATMUL( & -! & trial%dNdXt(1:nns2, 1:nsd, ips), & -! & dd(1:nsd, 1:nsd) & -! & ), & -! & [nsd * nns2] & -! & ) & -! & ) -! -! r1 = 0; r2 = 0 -! DO i = 1, nsd -! r1 = r2 + 1; r2 = i * nns1 -! ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff -! END DO -! END DO -! -! DEALLOCATE (realval, ff) -! -! END PROCEDURE ElasticNitscheMatrixTangent1a -! -! !---------------------------------------------------------------------------- -! ! ElasticityNitscheMatrixTangent -! !---------------------------------------------------------------------------- -! -! MODULE PROCEDURE ElasticNitscheMatrixTangent1b -! REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) -! INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i -! REAL(DFP) :: dd(3, 3) -! -! nns1 = SIZE(test%N, 1) -! nns2 = SIZE(trial%N, 1) -! nips = SIZE(trial%N, 2) -! nsd = trial%refElem%nsd -! ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) -! realval = trial%Ws * trial%Js * trial%Thickness -! ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) -! ans = 0.0_DFP -! -! DO ips = 1, nips -! dd(1:nsd, 1:nsd) = & -! & 2.0 * mu * realval(ips) & -! & * OUTERPROD(a=trial%normal(1:nsd, ips), & -! & b=trial%normal(1:nsd, ips)) -! -! ff = OUTERPROD( & -! & test%N(1:nns1, ips), & -! & RESHAPE( & -! & MATMUL( & -! & trial%dNdXt(1:nns2, 1:nsd, ips), & -! & dd(1:nsd, 1:nsd) & -! & ), & -! & [nsd * nns2] & -! & ) & -! & ) -! -! r1 = 0; r2 = 0 -! DO i = 1, nsd -! r1 = r2 + 1; r2 = i * nns1 -! ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff -! END DO -! END DO -! -! DEALLOCATE (realval, ff) -! -! END PROCEDURE ElasticNitscheMatrixTangent1b -! -! !---------------------------------------------------------------------------- -! ! -! !---------------------------------------------------------------------------- -! -! MODULE PROCEDURE ElasticNitscheMatrixTangent1c -! REAL(DFP), ALLOCATABLE :: muBar(:) -! CALL getInterpolation(obj=trial, interpol=muBar, val=mu) -! ans = ElasticNitscheMatrixTangent( & -! & test=test, trial=trial, mu=muBar) -! DEALLOCATE (muBar) -! END PROCEDURE ElasticNitscheMatrixTangent1c -! -! !---------------------------------------------------------------------------- -! ! -! !---------------------------------------------------------------------------- -! -END SUBMODULE MatrixTangent diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt deleted file mode 100644 index ca148d457..000000000 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ElemshapeData_ConstructorMethods@Methods.F90 - ${src_path}/ElemshapeData_DivergenceMethods@Methods.F90 - ${src_path}/ElemshapeData_GetMethods@Methods.F90 - ${src_path}/ElemshapeData_GradientMethods@Methods.F90 - - ${src_path}/H1/ElemshapeData_H1Methods@HermitMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 - - ${src_path}/DG/ElemshapeData_DGMethods@HermitMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 - - ${src_path}/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 - - ${src_path}/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 - - ${src_path}/ElemshapeData_HminHmaxMethods@Methods.F90 - ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90 - ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90 - ${src_path}/ElemshapeData_InterpolMethods@Methods.F90 - ${src_path}/ElemshapeData_IOMethods@Methods.F90 - ${src_path}/ElemshapeData_LocalDivergenceMethods@Methods.F90 - ${src_path}/ElemshapeData_LocalGradientMethods@Methods.F90 - ${src_path}/ElemshapeData_ProjectionMethods@Methods.F90 - ${src_path}/ElemshapeData_SetMethods@Methods.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods@SUGN3.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 - ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90 -) diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 deleted file mode 100644 index 837582c82..000000000 --- a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_DGMethods) HermitMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DG_Hermit1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="DG_Hermit1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE DG_Hermit1 - -END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 deleted file mode 100644 index 6bbaaf471..000000000 --- a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_DGMethods) HierarchyMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DG_Hierarchy1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="DG_Hierarchy1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE DG_Hierarchy1 - -END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 deleted file mode 100644 index 498e21a3c..000000000 --- a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_DGMethods) LagrangeMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DG_Lagrange1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="DG_Lagrange1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE DG_Lagrange1 - -END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 deleted file mode 100644 index 895c90a5b..000000000 --- a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_DGMethods) OrthogonalMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DG_Orthogonal1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="DG_Orthogonal1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE DG_Orthogonal1 - -END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 deleted file mode 100644 index 64b93834d..000000000 --- a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 +++ /dev/null @@ -1,35 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(ElemshapeData_DGMethods) SerendipityMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DG_Serendipity1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="DG_Serendipity1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE DG_Serendipity1 - -END SUBMODULE SerendipityMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 deleted file mode 100755 index 6c88af6d2..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 +++ /dev/null @@ -1,362 +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: 4 March 2021 -! summary: Constructor method for ElemshapeData_ and STElemshapeData_ - -SUBMODULE(ElemshapeData_ConstructorMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Allocate -CALL reallocate(obj%N, nns, nips) -CALL reallocate(obj%dNdXi, nns, xidim, nips) -CALL reallocate(obj%Normal, 3, nips) -CALL reallocate(obj%dNdXt, nns, nsd, nips) -CALL reallocate(obj%Jacobian, nsd, xidim, nips) -CALL reallocate(obj%Js, nips) -CALL reallocate(obj%Thickness, nips) -obj%Thickness = 1.0_DFP -CALL reallocate(obj%Coord, nsd, nips) -END PROCEDURE elemsd_Allocate - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Initiate1 - -CALL ErrorMSG( & - & Msg="[WORK IN PROGRESS]", & - & File=__FILE__, & - & Routine="elemsd_Initiate1()", & - & Line=__LINE__, & - & UnitNo=stdout) -STOP - -! SELECT CASE (TRIM(interpolType)//TRIM(continuityType)) -! CASE ("LagrangeInterpolation"//"H1") -! CALL Initiate( & -! & obj=obj, & -! & quad=quad, & -! & refElem=refElem, & -! & continuityType=TypeH1, & -! & interpolType=TypeLagrangeInterpolation) -! -! CASE ("LagrangeInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: LagrangeInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("LagrangeInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: LagrangeInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("LagrangeInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: LagrangeInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"H1") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: H1", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"H1") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: H1", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"H1") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: H1", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE DEFAULT -! CALL ErrorMSG( & -! & Msg="Unknown child name of BaseInterpolation & -! & and BaseContinuityType", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! END SELECT - -END PROCEDURE elemsd_Initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_initiate2 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -END PROCEDURE elemsd_initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_initiate3 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -END PROCEDURE elemsd_initiate3 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_initiate4 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -END PROCEDURE elemsd_initiate4 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_initiate5 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -obj1%wt = obj2%wt -obj1%theta = obj2%theta -obj1%jt = obj2%jt -IF (ALLOCATED(obj2%T)) obj1%T = obj2%T -IF (ALLOCATED(obj2%dTdTheta)) obj1%dTdTheta = obj2%dTdTheta -IF (ALLOCATED(obj2%dNTdt)) obj1%dNTdt = obj2%dNTdt -IF (ALLOCATED(obj2%dNTdXt)) obj1%dNTdXt = obj2%dNTdXt -END PROCEDURE elemsd_initiate5 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE stsd_initiate -INTEGER(I4B) :: tip, ip -REAL(DFP) :: x(3) - -tip = SIZE(elemsd%N, 2) -IF (ALLOCATED(obj)) THEN - DO ip = 1, SIZE(obj) - CALL DEALLOCATE (obj(ip)) - END DO - DEALLOCATE (obj) -END IF - -ALLOCATE (obj(tip)) -DO ip = 1, tip - obj(ip)%T = elemsd%N(:, ip) - obj(ip)%dTdTheta = elemsd%dNdXi(:, 1, ip) - obj(ip)%Jt = elemsd%Js(ip) - CALL getQuadraturePoints( & - & obj=elemsd%quad, & - & weights=obj(ip)%wt,& - & points=x, & - & num=ip) - obj(ip)%theta = x(1) -END DO -END PROCEDURE stsd_initiate - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Deallocate -IF (ALLOCATED(obj%Normal)) DEALLOCATE (obj%Normal) -IF (ALLOCATED(obj%N)) DEALLOCATE (obj%N) -IF (ALLOCATED(obj%dNdXi)) DEALLOCATE (obj%dNdXi) -IF (ALLOCATED(obj%dNdXt)) DEALLOCATE (obj%dNdXt) -IF (ALLOCATED(obj%Jacobian)) DEALLOCATE (obj%Jacobian) -IF (ALLOCATED(obj%Js)) DEALLOCATE (obj%Js) -IF (ALLOCATED(obj%Ws)) DEALLOCATE (obj%Ws) -IF (ALLOCATED(obj%Thickness)) DEALLOCATE (obj%Thickness) -IF (ALLOCATED(obj%Coord)) DEALLOCATE (obj%Coord) -CALL DEALLOCATE (obj%Quad) -CALL DEALLOCATE (obj%refelem) -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - IF (ALLOCATED(obj%T)) DEALLOCATE (obj%T) - IF (ALLOCATED(obj%dTdTheta)) DEALLOCATE (obj%dTdTheta) - IF (ALLOCATED(obj%dNTdt)) DEALLOCATE (obj%dNTdt) - IF (ALLOCATED(obj%dNTdXt)) DEALLOCATE (obj%dNTdXt) -END SELECT -END PROCEDURE elemsd_Deallocate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 deleted file mode 100644 index 7f245d9b9..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 +++ /dev/null @@ -1,205 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_DivergenceMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_1 -lg = Contraction(a1=TRANSPOSE(val), a2=obj%dNdXt) -END PROCEDURE elemsd_getDivergence_1 - -!---------------------------------------------------------------------------- -! getDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_2 -REAL(DFP), ALLOCATABLE :: r3(:, :, :) -!! main -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1) - lg = Contraction(r3, obj%dNTdXt) - DEALLOCATE (r3) -END SELECT -END PROCEDURE elemsd_getDivergence_2 - -!---------------------------------------------------------------------------- -! getDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_3 -SELECT CASE (val%varType) -CASE (constant) - CALL reallocate(lg, SIZE(obj%N, 2)) -CASE (space) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getDivergence_3 - -!---------------------------------------------------------------------------- -! getDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_4 -INTEGER(I4B) :: ii, n -!! -n = SIZE(obj%N, 2) -CALL reallocate(lg, SIZE(val, 1), n) -DO ii = 1, n - lg(:, ii) = contraction(val, TRANSPOSE(obj%dNdXt(:, :, ii))) -END DO -END PROCEDURE elemsd_getDivergence_4 - -!---------------------------------------------------------------------------- -! getDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_5 -REAL(DFP), ALLOCATABLE :: r4(:, :, :, :) -INTEGER(I4B) :: ii -!! -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - CALL SWAP(a=r4, b=val, i1=3, i2=4, i3=2, i4=1) - CALL Reallocate(lg, size(obj%N, 2), size(val, 1)) - DO ii = 1, SIZE(r4, 4) - lg(:, ii) = Contraction(a1=r4(:, :, :, ii), a2=obj%dNTdXt) - END DO - lg = TRANSPOSE(lg) - Deallocate (r4) -END SELECT -!! -END PROCEDURE elemsd_getDivergence_5 - -!---------------------------------------------------------------------------- -! getDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_6 -INTEGER(I4B) :: s(2) -!! -SELECT CASE (val%varType) -CASE (constant) - s = SHAPE(val) - CALL reallocate(lg, s(1), SIZE(obj%N, 2)) -CASE (space) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getDivergence_6 - -!---------------------------------------------------------------------------- -! getDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_7 -REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :) -!! -SELECT CASE (val%rank) -CASE (vector) - CALL getDivergence(obj=obj, lg=r1, val=val) - lg = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace) - DEALLOCATE (r1) -CASE (matrix) - CALL getDivergence(obj=obj, lg=r2, val=val) - lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - DEALLOCATE (r2) -END SELECT -END PROCEDURE elemsd_getDivergence_7 - -!---------------------------------------------------------------------------- -! Divergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getDivergence_8 -REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :) -INTEGER(I4B) :: ii -!! -SELECT CASE (val%rank) -!! -!! vector -!! -CASE (vector) - DO ii = 1, SIZE(obj) - CALL getDivergence(obj=obj(ii), lg=r1, val=val) - IF (.NOT. ALLOCATED(r2)) THEN - CALL reallocate(r2, SIZE(r1, 1), SIZE(obj)) - END IF - !! - r2(:, ii) = r1 - END DO - lg = QuadratureVariable(r2, typeFEVariableScalar,& - & typeFEVariableSpaceTime) - DEALLOCATE (r2, r1) -!! -!! matrix -!! -CASE (matrix) - DO ii = 1, SIZE(obj) - CALL getDivergence(obj=obj(ii), lg=r2, val=val) - IF (.NOT. ALLOCATED(r3)) THEN - CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) - END IF - !! - r3(:, :, ii) = r2 - END DO - lg = QuadratureVariable(r3, typeFEVariableVector,& - & typeFEVariableSpaceTime) - DEALLOCATE (r2, r3) -END SELECT -END PROCEDURE elemsd_getDivergence_8 - -!---------------------------------------------------------------------------- -! Divergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Divergence_1 -CALL getDivergence(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_Divergence_1 - -!---------------------------------------------------------------------------- -! Divergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Divergence_2 -CALL getDivergence(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_Divergence_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 deleted file mode 100644 index 15a59dba9..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 +++ /dev/null @@ -1,95 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_GetMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getnormal_1 -IF (PRESENT(nsd)) THEN - normal = obj%normal(1:nsd, :) -ELSE - normal = obj%normal -END IF -END PROCEDURE elemsd_GetNormal_1 - -!---------------------------------------------------------------------------- -! getNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getnormal_2 -IF (PRESENT(nsd)) THEN - normal = QuadratureVariable(obj%normal(1:nsd, :), & - & TypeFEVariableVector, & - & TypeFEVariableSpace) -ELSE - normal = QuadratureVariable(obj%normal, & - & TypeFEVariableVector, & - & TypeFEVariableSpace) -END IF -END PROCEDURE elemsd_getnormal_2 - -!---------------------------------------------------------------------------- -! getNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getnormal_3 - !! -REAL(DFP), ALLOCATABLE :: m3(:, :, :) -INTEGER(I4B) :: ii - !! -IF (PRESENT(nsd)) THEN - !! - CALL Reallocate(m3, & - & nsd, & - & SIZE(obj(1)%normal, 2), & - & SIZE(obj)) - !! - DO ii = 1, SIZE(obj) - m3(1:nsd, :, ii) = obj(ii)%normal(1:nsd, :) - END DO - !! -ELSE - !! - CALL Reallocate(m3, & - & SIZE(obj(1)%normal, 1), & - & SIZE(obj(1)%normal, 2), & - & SIZE(obj)) - !! - DO ii = 1, SIZE(obj) - m3(:, :, ii) = obj(ii)%normal - END DO - !! -END IF - !! -normal = QuadratureVariable(m3, TypeFEVariableVector, & - & TypeFEVariableSpaceTime) - !! -DEALLOCATE (m3) - !! -END PROCEDURE elemsd_getnormal_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 deleted file mode 100644 index 62717e546..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 +++ /dev/null @@ -1,284 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_GradientMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_1 -IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN - lg = MATMUL(Val, obj%dNdXt) -ELSE - CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) -END IF -END PROCEDURE elemsd_getSpatialGradient_1 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_2 -IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN - lg = MATMUL(Val, obj%dNdXt) -ELSE - CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, & - & SIZE(obj%N, 2)) -END IF -END PROCEDURE elemsd_getSpatialGradient_2 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_3 -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN - lg = Contraction(val, obj%dNTdXt) - ELSE - CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) - END IF -END SELECT -END PROCEDURE elemsd_getSpatialGradient_3 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_4 -INTEGER(I4B) :: ii, jj, ips -REAL(DFP), ALLOCATABLE :: r3(:, :, :) - !! -CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, & - & SIZE(obj%N, 2)) - !! -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN - CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1) - DO ips = 1, SIZE(lg, 3) - DO jj = 1, SIZE(lg, 2) - DO ii = 1, SIZE(lg, 1) - lg(ii, jj, ips) = contraction(a1=r3(:, :, ii), & - & a2=obj%dNTdXt(:, :, jj, ips)) - END DO - END DO - END DO - DEALLOCATE (r3) - END IF -END SELECT -END PROCEDURE elemsd_getSpatialGradient_4 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_5 -SELECT CASE (val%varType) -CASE (constant) - CALL reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) -CASE (space) - CALL getSpatialGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - CALL getSpatialGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getSpatialGradient_5 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_6 -INTEGER(I4B) :: s(1) -SELECT CASE (val%varType) -CASE (constant) - s = SHAPE(val) - CALL reallocate(lg, s(1), obj%refelem%nsd, & - & SIZE(obj%N, 2)) -CASE (space) - CALL getSpatialGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getSpatialGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getSpatialGradient_6 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_7 -IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN - lg = MATMUL(Val, obj%dNdXt) -ELSE - CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), & - & obj%refelem%nsd, SIZE(obj%N, 2)) -END IF -END PROCEDURE elemsd_getSpatialGradient_7 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_8 -INTEGER(I4B) :: ii, jj - !! -CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%refelem%nsd, & - & SIZE(obj%N, 2)) -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN - DO jj = 1, SIZE(lg, 4) - DO ii = 1, SIZE(lg, 3) - lg(:, :, ii, jj) = contraction(a1=val, & - & a2=obj%dNTdXt(:, :, ii, jj)) - END DO - END DO - END IF -END SELECT -END PROCEDURE elemsd_getSpatialGradient_8 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_9 -INTEGER(I4B) :: s(2) -SELECT CASE (val%varType) -CASE (constant) - s = SHAPE(val) - CALL reallocate(lg, s(1), s(2), & - & obj%refelem%nsd, SIZE(obj%N, 2)) -CASE (space) - CALL getSpatialGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getSpatialGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getSpatialGradient_9 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_10 -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) - !! -SELECT CASE (val%rank) -CASE (scalar) - CALL getSpatialGradient(obj=obj, lg=r2, val=val) - lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - DEALLOCATE (r2) -CASE (vector) - CALL getSpatialGradient(obj=obj, lg=r3, val=val) - lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) - DEALLOCATE (r3) -CASE (matrix) - !! BUG Implement gradient of matrix - !! TODO Extend FEVariable to support r3, which is necessary to keep - !! the gradient of rank02 tensors -END SELECT -END PROCEDURE elemsd_getSpatialGradient_10 - -!---------------------------------------------------------------------------- -! getSpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSpatialGradient_11 -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) -INTEGER(I4B) :: ii - !! -SELECT CASE (val%rank) - !! - !! scalar - !! -CASE (scalar) - DO ii = 1, SIZE(obj) - CALL getSpatialGradient(obj=obj(ii), lg=r2, val=val) - IF (.NOT. ALLOCATED(r3)) THEN - CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) - END IF - !! - r3(:, :, ii) = r2(:, :) - END DO - lg = QuadratureVariable(r3, typeFEVariableVector,& - & typeFEVariableSpaceTime) - DEALLOCATE (r2, r3) - !! - !! vector - !! -CASE (vector) - DO ii = 1, SIZE(obj) - CALL getSpatialGradient(obj=obj(ii), lg=r3, val=val) - IF (.NOT. ALLOCATED(r4)) THEN - CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) - END IF - !! - r4(:, :, :, ii) = r3(:, :, :) - END DO - lg = QuadratureVariable(r4, typeFEVariableMatrix,& - & typeFEVariableSpaceTime) - DEALLOCATE (r3, r4) - !! - !! matrix TODO - !! -CASE (matrix) - !! BUG Implement gradient of matrix - !! TODO Extend FEVariable to support r3, which is necessary to keep - !! the gradient of rank02 tensors -END SELECT -END PROCEDURE elemsd_getSpatialGradient_11 - -!---------------------------------------------------------------------------- -! SpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SpatialGradient_1 -CALL getSpatialGradient(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_SpatialGradient_1 - -!---------------------------------------------------------------------------- -! SpatialGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SpatialGradient_2 -CALL getSpatialGradient(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_SpatialGradient_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 deleted file mode 100644 index 97ba604d5..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 +++ /dev/null @@ -1,217 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_HRGNParamMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getHRGNParam -!---------------------------------------------------------------------------- - -PURE SUBROUTINE elemsd_getHRGNParam_a(obj, h, val, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! define internal variables - !! - INTEGER(I4B) :: ii - REAL(DFP) :: areal - REAL(DFP), ALLOCATABLE :: q(:, :), hmin(:), hmax(:) - !! rdNdXt; (I,ips) => projection of dNdXt on unit normal - TYPE(FEVariable_) :: rvar - !! vector variable for keeping r - !! - !! Main - !! - CALL Reallocate(h, SIZE(obj%N, 2)) - !! - !! Get unitNormal in q - !! - CALL GetUnitNormal(obj=obj, val=val, r=q) - !! - !! Convert unit normal to [[FEVariable_]] - !! - rvar = QuadratureVariable(q, TypeFEVariableVector, TypeFEVariableSpace) - !! - !! Call get projection of dNdXt in q - !! - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) - !! - !! Calculate hmin and hmax - !! - CALL GetHminHmax(obj=obj, hmax=hmax, hmin=hmin) - !! - DO ii = 1, SIZE(h) - areal = SUM(ABS(q(:, ii))) - IF (areal.APPROXEQ.zero) THEN - h(ii) = hmin(ii) - ELSE - h(ii) = 2.0_DFP / areal - END IF - END DO - !! - IF (ALLOCATED(q)) DEALLOCATE (q) - IF (ALLOCATED(hmin)) DEALLOCATE (hmin) - IF (ALLOCATED(hmax)) DEALLOCATE (hmax) - CALL DEALLOCATE (rvar) - !! -END SUBROUTINE elemsd_getHRGNParam_a - -!---------------------------------------------------------------------------- -! getHRGNParam -!---------------------------------------------------------------------------- - -PURE SUBROUTINE elemsd_getHRGNParam_b(obj, h, val, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! internal variables - !! - INTEGER(I4B) :: ii - REAL(DFP) :: areal - REAL(DFP), ALLOCATABLE :: r(:, :), hmin(:), hmax(:) - REAL(DFP), ALLOCATABLE :: q(:, :, :) - !! rdNTdXt; (I,a,ips)m => projection of dNTdXt on unit normal - TYPE(FEVariable_) :: rvar - !! - !! main - !! - CALL Reallocate(h, SIZE(obj%N, 2)) - !! - !! Get unitNormal in r - !! - CALL GetUnitNormal(obj=obj, val=val, r=r) - !! - !! Make [[FEVariable_]] - !! - rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - !! - !! Get Projection of dNTdXt in q - !! - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar) - !! - !! Calculate hmin and hmax - !! - CALL GetHminHmax(obj=obj, hmax=hmax, hmin=hmin) - !! - DO ii = 1, SIZE(h, 1) - areal = SUM(ABS(q(:, :, ii))) - IF (areal.APPROXEQ.zero) THEN - h(ii) = hmin(ii) - ELSE - h(ii) = 2.0_DFP / areal - END IF - END DO - !! - IF (ALLOCATED(r)) DEALLOCATE (r) - IF (ALLOCATED(q)) DEALLOCATE (q) - CALL DEALLOCATE (rvar) - !! -END SUBROUTINE elemsd_getHRGNParam_b - -!---------------------------------------------------------------------------- -! getHRGNParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getHRGNParam1 -SELECT TYPE (obj) -!! -TYPE IS (ElemshapeData_) - !! - CALL elemsd_getHRGNParam_a( & - & obj=obj, & - & h=h, & - & val=val, & - & opt=opt) - !! -CLASS IS (STElemshapeData_) - !! - CALL elemsd_getHRGNParam_b( & - & obj=obj, & - & h=h, & - & val=val, & - & opt=opt) - !! -END SELECT -END PROCEDURE elemsd_getHRGNParam1 - -!---------------------------------------------------------------------------- -! getHRGNParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHRGNParam2 -REAL(DFP), ALLOCATABLE :: ans(:) -!! -CALL GetHRGNParam(obj=obj, h=ans, val=val, opt=opt) -h = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) -IF (ALLOCATED(ans)) DEALLOCATE (ans) -!! -END PROCEDURE elemsd_GetHRGNParam2 - -!---------------------------------------------------------------------------- -! getHRGNParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHRGNParam3 -INTEGER(I4B) :: ii -REAL(DFP), ALLOCATABLE :: avec(:) -!! -!! main -!! -CALL Reallocate(h, SIZE(obj(1)%N, 2), SIZE(obj)) -!! -DO ii = 1, SIZE(obj) - CALL GetHRGNParam( & - & obj=obj(ii), & - & h=avec, & - & val=val, & - & opt=opt) - !! - h(:, ii) = avec(:) -END DO -!! -IF (ALLOCATED(avec)) DEALLOCATE (avec) -END PROCEDURE elemsd_GetHRGNParam3 - -!---------------------------------------------------------------------------- -! getHRGNParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHRGNParam4 -REAL(DFP), ALLOCATABLE :: ans(:, :) -!! -CALL GetHRGNParam(obj=obj, h=ans, val=val, opt=opt) -!! -h = QuadratureVariable( & - & ans, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -IF (ALLOCATED(ans)) DEALLOCATE (ans) -END PROCEDURE elemsd_GetHRGNParam4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 deleted file mode 100644 index 915f5b7f5..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 +++ /dev/null @@ -1,664 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_HRQIParamMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getHRQIParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getHRQIParam1 -INTEGER(I4B) :: ii, nips, nsd -REAL(DFP), ALLOCATABLE :: r0(:, :) -!! unitNormal (nsd, nips) -REAL(DFP), ALLOCATABLE :: G(:, :, :) -!! shape is (nsd, nsd, nips), it contains inverse of FFT -REAL(DFP), ALLOCATABLE :: FFT(:, :) -!! (nsd, nsd) -REAL(DFP), ALLOCATABLE :: rr(:, :) -!! outer product of unitNormal (nsd, nsd) -REAL(DFP) :: areal -LOGICAL(LGT) :: ismin, ismax -!! -!! Main -!! -nips = SIZE(obj%N, 2) -nsd = obj%refelem%nsd -CALL Reallocate(h, nips) -CALL Reallocate(G, nsd, nsd, nips) -CALL Reallocate(FFT, nsd, nsd) -!! -!! hmax -!! -IF (PRESENT(hmax)) THEN - CALL Reallocate(hmax, nips) - ismax = .TRUE. -ELSE - ismax = .FALSE. -END IF -!! -!! hmin -!! -IF (PRESENT(hmin)) THEN - CALL Reallocate(hmin, nips) - ismin = .TRUE. -ELSE - ismin = .FALSE. -END IF -!! -!! r and unitNormal -!! -CALL GetUnitNormal(obj=obj, val=val, r=r0) -IF (PRESENT(r)) r = r0 -!! -!! FFT and G -!! -DO ii = 1, nips - !! - FFT = MATMUL(obj%jacobian(:, :, ii), & - & TRANSPOSE(obj%jacobian(:, :, ii))) - !! - CALL Inv(invA=G(:, :, ii), A=FFT) - !! - rr = OUTERPROD(a=r0(1:nsd, ii), b=r0(1:nsd, ii)) - !! - areal = Contraction(a1=G(:, :, ii), a2=rr) - !! - IF (areal.APPROXEQ.zero) THEN - h(ii) = 0.0_DFP - ELSE - h(ii) = 2.0_DFP / SQRT(areal) - END IF - !! -END DO -!! -!! reset FFT to reuse it -!! -FFT = 0.0_DFP; r0 = 0.0_DFP -!! -IF (ismin .OR. ismax) THEN - DO ii = 1, nips - r0(:, ii) = SymEigenValuesUpto3(G(:, :, ii)) - END DO -END IF -!! -IF (ismax) THEN - DO ii = 1, nips - hmax(ii) = 2.0_DFP / SQRT(MINVAL(r0(:, ii))) - END DO -END IF -!! -IF (ismin) THEN - DO ii = 1, nips - hmin(ii) = 2.0_DFP / SQRT(MAXVAL(r0(:, ii))) - END DO -END IF -!! -DEALLOCATE (r0, G, FFT, rr) -END PROCEDURE elemsd_getHRQIParam1 - -!---------------------------------------------------------------------------- -! getHRQIParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHRQIParam2 - !! -INTEGER(I4B) :: ii -REAL(DFP), ALLOCATABLE :: h0(:), hmax0(:), hmin0(:), r0(:, :) -CHARACTER(LEN=3) :: cod - !! - !! main - !! -cod = "FFF" - !! -IF (PRESENT(hmax)) THEN - cod(1:1) = "T" -END IF - !! -IF (PRESENT(hmin)) THEN - cod(2:2) = "T" -END IF - !! -IF (PRESENT(r)) THEN - cod(3:3) = "T" -END IF - !! -SELECT CASE (cod) -CASE ("FFF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - !! -CASE ("TFF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - !! -CASE ("FTF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmin=hmin0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - !! -CASE ("TTF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & hmin=hmin0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - !! -CASE ("FFT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) - !! -CASE ("TFT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) - !! -CASE ("FTT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmin=hmin0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) - !! -CASE ("TTT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & hmin=hmin0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) - r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) - !! -END SELECT - !! -IF (ALLOCATED(h0)) DEALLOCATE (h0) -IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) -IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) -IF (ALLOCATED(r0)) DEALLOCATE (r0) - !! -END PROCEDURE elemsd_GetHRQIParam2 - -!---------------------------------------------------------------------------- -! getHRQIParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHRQIParam3 - !! -INTEGER(I4B) :: ii, nips, nipt, nsd -REAL(DFP), ALLOCATABLE :: h0(:), hmax0(:), hmin0(:), r0(:, :) -CHARACTER(LEN=3) :: cod - !! - !! main - !! -nips = SIZE(obj(1)%N, 2) -nipt = SIZE(obj) -nsd = obj(1)%refelem%nsd - !! -CALL Reallocate(h, nips, nipt) - !! -cod = "FFF" - !! -IF (PRESENT(hmax)) THEN - CALL Reallocate(hmax, nips, nipt) - cod(1:1) = "T" -END IF - !! -IF (PRESENT(hmin)) THEN - CALL Reallocate(hmin, nips, nipt) - cod(2:2) = "T" -END IF - !! -IF (PRESENT(r)) THEN - CALL Reallocate(r, nsd, nips, nipt) - cod(3:3) = "T" -END IF - !! -SELECT CASE (cod) -CASE ("FFF") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - !! - END DO - !! -CASE ("TFF") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & hmax=hmax0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - hmax(:, ii) = hmax0(:) - !! - END DO - !! -CASE ("FTF") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & hmin=hmin0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - hmin(:, ii) = hmin0(:) - !! - END DO - !! -CASE ("TTF") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & hmax=hmax0, & - & hmin=hmin0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - hmax(:, ii) = hmax0(:) - hmin(:, ii) = hmin0(:) - !! - END DO - !! -CASE ("FFT") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - r(:, :, ii) = r0(:, :) - !! - END DO - !! -CASE ("TFT") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & hmax=hmax0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - hmax(:, ii) = hmax0(:) - r(:, :, ii) = r0(:, :) - !! - END DO - !! -CASE ("FTT") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & hmin=hmin0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - hmin(:, ii) = hmin0(:) - r(:, :, ii) = r0(:, :) - !! - END DO - !! -CASE ("TTT") - !! - DO ii = 1, SIZE(obj) - !! - CALL GetHRQIParam( & - & obj=obj(ii), & - & h=h0, & - & hmax=hmax0, & - & hmin=hmin0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h(:, ii) = h0(:) - hmax(:, ii) = hmax0(:) - hmin(:, ii) = hmin0(:) - r(:, :, ii) = r0(:, :) - !! - END DO - !! -END SELECT - !! -IF (ALLOCATED(h0)) DEALLOCATE (h0) -IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) -IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) -IF (ALLOCATED(r0)) DEALLOCATE (r0) - !! -END PROCEDURE elemsd_GetHRQIParam3 - -!---------------------------------------------------------------------------- -! getHRQIParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHRQIParam4 - !! -REAL(DFP), ALLOCATABLE :: h0(:, :), hmax0(:, :), hmin0(:, :), & - & r0(:, :, :) -CHARACTER(LEN=3) :: cod - !! - !! main - !! -cod = "FFF" - !! -IF (PRESENT(hmax)) THEN - cod(1:1) = "T" -END IF - !! -IF (PRESENT(hmin)) THEN - cod(2:2) = "T" -END IF - !! -IF (PRESENT(r)) THEN - cod(3:3) = "T" -END IF - !! -SELECT CASE (cod) -CASE ("FFF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - !! -CASE ("TFF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - hmax = QuadratureVariable( & - & hmax0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! -CASE ("FTF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmin=hmin0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - hmin = QuadratureVariable( & - & hmin0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! -CASE ("TTF") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & hmin=hmin0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - hmax = QuadratureVariable( & - & hmax0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - hmin = QuadratureVariable( & - & hmin0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! -CASE ("FFT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - r = QuadratureVariable( & - & r0, & - & TypeFEVariableVector, & - & TypeFEVariableSpaceTime) - !! -CASE ("TFT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - hmax = QuadratureVariable( & - & hmax0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - r = QuadratureVariable( & - & r0, & - & TypeFEVariableVector, & - & TypeFEVariableSpaceTime) - !! -CASE ("FTT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmin=hmin0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - hmin = QuadratureVariable( & - & hmin0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - r = QuadratureVariable( & - & r0, & - & TypeFEVariableVector, & - & TypeFEVariableSpaceTime) - !! -CASE ("TTT") - !! - CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & hmax=hmax0, & - & hmin=hmin0, & - & r=r0, & - & val=val, & - & opt=opt) - !! - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - hmin = QuadratureVariable( & - & hmin0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - !! - hmax = QuadratureVariable( & - & hmax0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - r = QuadratureVariable( & - & r0, & - & TypeFEVariableVector, & - & TypeFEVariableSpaceTime) - !! -END SELECT - !! -IF (ALLOCATED(h0)) DEALLOCATE (h0) -IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) -IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) -IF (ALLOCATED(r0)) DEALLOCATE (r0) - !! -END PROCEDURE elemsd_GetHRQIParam4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 deleted file mode 100644 index 3828c6c28..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 +++ /dev/null @@ -1,216 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_HminHmaxMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetHminHmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax1 -INTEGER(I4B) :: ii, nips, nsd -REAL(DFP), ALLOCATABLE :: G(:, :), w(:) -!! shape is (nsd, nsd, nips), it contains inverse of FFT -REAL(DFP) :: areal -!! -!! Main -!! -nips = SIZE(obj%N, 2) -nsd = obj%refelem%nsd -!! -CALL Reallocate(G, nsd, nsd) -CALL Reallocate(w, nsd) -CALL Reallocate(hmax, nips, hmin, nips) -!! -!! FFT and G -!! -DO ii = 1, nips - !! - CALL Inv(invA=G, A=MATMUL(obj%jacobian(:, :, ii), & - & TRANSPOSE(obj%jacobian(:, :, ii)))) - !! - w = SymEigenValuesUpto3(G) - !! - hmax(ii) = 2.0_DFP / SQRT(MINVAL(w)) - hmin(ii) = 2.0_DFP / SQRT(MAXVAL(w)) -END DO -!! -DEALLOCATE (w, G) -!! -END PROCEDURE elemsd_GetHminHmax1 - -!---------------------------------------------------------------------------- -! GetHminHmax -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax2 -INTEGER(I4B) :: ii, nips, nsd -REAL(DFP), ALLOCATABLE :: w(:) -!! shape is (nsd, nsd, nips), it contains inverse of FFT -!! -!! Main -!! -nips = SIZE(obj%N, 2) -nsd = obj%refelem%nsd -!! -CALL Reallocate(w, nsd) -CALL Reallocate(hmax, nips, hmin, nips) -!! -!! FFT and G -!! -DO ii = 1, nips - w = SymEigenValuesUpto3(G(:, :, ii)) - hmax(ii) = 2.0_DFP / SQRT(MINVAL(w)) - hmin(ii) = 2.0_DFP / SQRT(MAXVAL(w)) -END DO -!! -DEALLOCATE (w) -!! -END PROCEDURE elemsd_GetHminHmax2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax3 -REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) -!! -CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0) -!! -hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END PROCEDURE elemsd_GetHminHmax3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax6 -REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) -!! -CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0, G=G) -!! -hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END PROCEDURE elemsd_GetHminHmax6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax4 -INTEGER(I4B) :: ii, nips, nipt -REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) -!! -nips = SIZE(obj(1)%N, 2) -nipt = SIZE(obj) -!! -CALL Reallocate(hmax, nips, nipt) -CALL Reallocate(hmin, nips, nipt) -!! -DO ii = 1, SIZE(obj) - CALL GetHminHmax(obj=obj(ii), hmax=hmax0, hmin=hmin0) - hmax(:, ii) = hmax0(:) - hmin(:, ii) = hmin0(:) -END DO -!! -IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) -IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) -END PROCEDURE elemsd_GetHminHmax4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax7 -INTEGER(I4B) :: ii, nips, nipt -REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) -!! -nips = SIZE(obj(1)%N, 2) -nipt = SIZE(obj) -!! -CALL Reallocate(hmax, nips, nipt) -CALL Reallocate(hmin, nips, nipt) -!! -DO ii = 1, SIZE(obj) - CALL GetHminHmax(obj=obj(ii), hmax=hmax0, hmin=hmin0, G=G(:, :, :, ii)) - hmax(:, ii) = hmax0(:) - hmin(:, ii) = hmin0(:) -END DO -!! -IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) -IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) -END PROCEDURE elemsd_GetHminHmax7 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax5 -REAL(DFP), ALLOCATABLE :: hmax0(:, :), hmin0(:, :) -!! -CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0) -!! -hmin = QuadratureVariable( & - & hmin0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -hmax = QuadratureVariable( & - & hmax0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) -IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) -END PROCEDURE elemsd_GetHminHmax5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetHminHmax8 -REAL(DFP), ALLOCATABLE :: hmax0(:, :), hmin0(:, :) -!! -CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0, G=G) -!! -hmin = QuadratureVariable( & - & hmin0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -hmax = QuadratureVariable( & - & hmax0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) -IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) -END PROCEDURE elemsd_GetHminHmax8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 deleted file mode 100644 index 9b91a6d5a..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 +++ /dev/null @@ -1,270 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: Methods for IO of [[elemshapedata_]] and [[stelemshapedata_]] - -SUBMODULE(ElemshapeData_IOMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElemshapeData_ReactEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElemshapeData_ReactEncode - -END PROCEDURE ElemshapeData_ReactEncode - -!---------------------------------------------------------------------------- -! ElemshapeData_MdEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElemshapeData_MdEncode -INTEGER(I4B) :: ii -TYPE(String), ALLOCATABLE :: rh(:), ch(:) - -ans = MdEncode(obj%quad)//CHAR_LF2 - -IF (ALLOCATED(obj%N)) THEN - CALL Reallocate(rh, SIZE(obj%N, 1)) - CALL Reallocate(ch, SIZE(obj%N, 2)) - DO ii = 1, SIZE(obj%N, 1) - rh(ii) = "$N_{"//tostring(ii)//"}$" - END DO - DO ii = 1, SIZE(obj%N, 2) - ch(ii) = "$ips_{"//tostring(ii)//"}$" - END DO - ans = ans//"**N**"//CHAR_LF2//MdEncode(val=obj%N, rh=rh, ch=ch)//CHAR_LF2 -ELSE - ans = ans//"**N Not ALLOCATED**"//CHAR_LF2 -END IF - -IF (ALLOCATED(obj%dNdXi)) THEN - CALL Reallocate(rh, SIZE(obj%dNdXi, 1)) - CALL Reallocate(ch, SIZE(obj%dNdXi, 2)) - DO ii = 1, SIZE(obj%dNdXi, 1) - rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial \xi}$" - END DO - DO ii = 1, SIZE(obj%dNdXi, 2) - ch(ii) = "$\frac{\partial N}{\partial \xi_{"//tostring(ii)//"}}$" - END DO - DO ii = 1, SIZE(obj%dNdXi, 3) - ans = ans//"**dNdXi(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & - & MdEncode(val=obj%dNdXi(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 - END DO -ELSE - ans = ans//"**dNdXi Not ALLOCATED**"//CHAR_LF2 -END IF - -IF (ALLOCATED(obj%dNdXt)) THEN - CALL Reallocate(rh, SIZE(obj%dNdXt, 1)) - CALL Reallocate(ch, SIZE(obj%dNdXt, 2)) - DO ii = 1, SIZE(obj%dNdXt, 1) - rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial x}$" - END DO - DO ii = 1, SIZE(obj%dNdXt, 2) - ch(ii) = "$\frac{\partial N}{\partial {x}_{"//tostring(ii)//"}}$" - END DO - DO ii = 1, SIZE(obj%dNdXt, 3) - ans = ans//"**dNdXt(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & - & MdEncode(val=obj%dNdXt(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 - END DO -ELSE - ans = ans//"**dNdXt Not ALLOCATED**"//CHAR_LF2 -END IF - -IF (ALLOCATED(obj%jacobian)) THEN - CALL Reallocate(rh, SIZE(obj%jacobian, 1)) - CALL Reallocate(ch, SIZE(obj%jacobian, 2)) - DO ii = 1, SIZE(obj%jacobian, 1) - rh(ii) = "row-"//tostring(ii) - END DO - DO ii = 1, SIZE(obj%jacobian, 2) - ch(ii) = "col-"//tostring(ii) - END DO - DO ii = 1, SIZE(obj%jacobian, 3) - ans = ans//"**jacobian(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & - & MdEncode(val=obj%jacobian(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 - END DO -ELSE - ans = ans//"**jacobian Not ALLOCATED**"//CHAR_LF2 -END IF - -IF (ALLOCATED(obj%js)) THEN - CALL Reallocate(rh, 1) - CALL Reallocate(ch, SIZE(obj%js, 1)) - rh(1) = "js" - DO ii = 1, SIZE(obj%js, 1) - ch(ii) = "$js_{"//tostring(ii)//"}$" - END DO - ans = ans//"**Js**"//CHAR_LF2//MdEncode(val=obj%js, rh=rh, ch=ch)//CHAR_LF2 -ELSE - ans = ans//"**js Not ALLOCATED**"//CHAR_LF2 -END IF - -IF (ALLOCATED(obj%thickness)) THEN - CALL Reallocate(rh, 1) - CALL Reallocate(ch, SIZE(obj%thickness, 1)) - rh(1) = "thickness" - DO ii = 1, SIZE(obj%thickness, 1) - ch(ii) = "thickness${}_{"//tostring(ii)//"}$" - END DO - ans = ans//"**thickness**"//CHAR_LF2// & - & MdEncode(val=obj%thickness, rh=rh, ch=ch)//CHAR_LF2 -ELSE - ans = ans//"**thickness Not ALLOCATED**"//CHAR_LF2 -END IF - -IF (ALLOCATED(obj%normal)) THEN - CALL Reallocate(rh, SIZE(obj%normal, 1)) - CALL Reallocate(ch, SIZE(obj%normal, 2)) - DO ii = 1, SIZE(obj%normal, 1) - rh(ii) = "$n_{"//tostring(ii)//"}$" - END DO - DO ii = 1, SIZE(obj%normal, 2) - ch(ii) = "$ips_{"//tostring(ii)//"}$" - END DO - ans = ans//"**normal**"//CHAR_LF2// & - & MdEncode(val=obj%normal, rh=rh, ch=ch)//CHAR_LF2 -ELSE - ans = ans//"**normal not ALLOCATED**"//CHAR_LF2 -END IF - -! SELECT TYPE (obj); TYPE IS (STElemShapeData_) -! CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno) -! CALL Display(obj%jt, "# jt: ", unitno=unitno) -! CALL Display(obj%theta, "# theta: ", unitno=unitno) -! CALL Display(obj%wt, "# wt: ", unitno=unitno) -! IF (ALLOCATED(obj%T)) THEN -! CALL Display(obj%T, "# T: ", unitno=unitno) -! ELSE -! CALL Display("# T: NOT ALLOCATED", unitno=unitno) -! END IF -! IF (ALLOCATED(obj%dTdTheta)) THEN -! CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno) -! ELSE -! CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno) -! END IF -! IF (ALLOCATED(obj%dNTdt)) THEN -! CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno) -! ELSE -! CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno) -! END IF -! IF (ALLOCATED(obj%dNTdXt)) THEN -! CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno) -! ELSE -! CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno) -! END IF -! END SELECT -END PROCEDURE ElemshapeData_MdEncode - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_display_1 -CALL Display(msg, unitno=unitno) -CALL Display("# SHAPE FUNCTION IN SPACE: ", unitno=unitno) -CALL Display(obj%Quad, "# Quadrature Point: ", unitno=unitno) -IF (ALLOCATED(obj%N)) THEN - CALL Display(obj%N, "# N: ", unitno) -ELSE - CALL Display("# N: NOT ALLOCATED", unitno) -END IF -IF (ALLOCATED(obj%dNdXi)) THEN - CALL Display(obj%dNdXi, "# dNdXi: ", unitno) -ELSE - CALL Display("# dNdXi: NOT ALLOCATED", unitno) -END IF -IF (ALLOCATED(obj%dNdXt)) THEN - CALL Display(obj%dNdXt, "# dNdXt: ", unitno) -ELSE - CALL Display("# dNdXt: NOT ALLOCATED", unitno) -END IF -IF (ALLOCATED(obj%jacobian)) THEN - CALL Display(obj%Jacobian, "# jacobian: ", unitno) -ELSE - CALL Display("# jacobian: NOT ALLOCATED", unitno) -END IF -IF (ALLOCATED(obj%js)) THEN - CALL Display(obj%js, "# js: ", unitno) -ELSE - CALL Display("# js: NOT ALLOCATED", unitno) -END IF -IF (ALLOCATED(obj%thickness)) THEN - CALL Display(obj%thickness, "# thickness: ", unitno) -ELSE - CALL Display("# thickness: NOT ALLOCATED", unitno) -END IF -IF (ALLOCATED(obj%coord)) THEN - CALL Display(obj%coord, "# coord: ", unitno) -ELSE - CALL Display("# coord: NOT ALLOCATED", unitno) -END IF -IF (ALLOCATED(obj%normal)) THEN - CALL Display(obj%normal, "# normal: ", unitno) -ELSE - CALL Display("# normal: NOT ALLOCATED", unitno) -END IF -SELECT TYPE (obj); TYPE IS (STElemShapeData_) - CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno) - CALL Display(obj%jt, "# jt: ", unitno=unitno) - CALL Display(obj%theta, "# theta: ", unitno=unitno) - CALL Display(obj%wt, "# wt: ", unitno=unitno) - IF (ALLOCATED(obj%T)) THEN - CALL Display(obj%T, "# T: ", unitno=unitno) - ELSE - CALL Display("# T: NOT ALLOCATED", unitno=unitno) - END IF - IF (ALLOCATED(obj%dTdTheta)) THEN - CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno) - ELSE - CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno) - END IF - IF (ALLOCATED(obj%dNTdt)) THEN - CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno) - ELSE - CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno) - END IF - IF (ALLOCATED(obj%dNTdXt)) THEN - CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno) - ELSE - CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno) - END IF -END SELECT -END PROCEDURE elemsd_display_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_display_2 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(obj) - CALL Display(obj=obj(ii), msg=TRIM(msg)//"("//tostring(ii)//"): ", & - & unitno=unitno) -END DO -END PROCEDURE elemsd_display_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 deleted file mode 100644 index 3b6cc592c..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ /dev/null @@ -1,594 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_InterpolMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE scalar_getinterpolation_1 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation_5 -INTEGER(I4B) :: ii -! REAL(DFP), ALLOCATABLE :: m1(:) -! !! main -! CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj)) -! DO ii = 1, SIZE(obj) -! CALL getInterpolation(obj=obj(ii), interpol=m1, val=val) -! interpol(:, ii) = m1 -! END DO -! DEALLOCATE (m1) -CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj)) -!! -SELECT CASE (val%vartype) -!! -!! -!! -!! -CASE (Constant) - !! - interpol = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) -!! -!! -!! -!! -CASE (Space) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, ii) = Interpolation(obj(ii), & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) - END DO - !! - ELSE - !! - interpol(:, 1) = Get(val, TypeFEVariableScalar, TypeFEVariableSpace) - !! - DO ii = 2, SIZE(obj) - interpol(:, ii) = interpol(:, 1) - END DO - !! - END IF -!! -!! -!! -!! -CASE (SpaceTime) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, ii) = STinterpolation(obj(ii), & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) - END DO - !! - ELSE - interpol = Get(val, TypeFEVariableScalar, typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE scalar_getinterpolation_5 - -!--------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE vector_getinterpolation_1 - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_2 -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - interpol = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE vector_getinterpolation_2 - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_3 -INTEGER(I4B) :: ipt -!! -CALL reallocate(interpol, SIZE(val, 1), SIZE(obj(1)%N, 2), SIZE(obj)) -DO ipt = 1, SIZE(obj) - interpol(:, :, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N) -END DO -END PROCEDURE vector_getinterpolation_3 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE matrix_getinterpolation_1 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -END PROCEDURE master_getinterpolation_1 - -!---------------------------------------------------------------------------- -! getInterpolation -!---------------------------------------------------------------------------- - -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 -!! -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) -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_LocalDivergenceMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 deleted file mode 100644 index 3f1743805..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 +++ /dev/null @@ -1,200 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_LocalDivergenceMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getLocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalDivergence_1 -lg = Contraction(a1=TRANSPOSE(val), a2=obj%dNdXi) -END PROCEDURE elemsd_getLocalDivergence_1 - -!---------------------------------------------------------------------------- -! getLocalDivergence -!----------------------------------------------------------------------------z - -MODULE PROCEDURE elemsd_getLocalDivergence_2 -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - lg = Contraction(a1=TRANSPOSE(MATMUL(Val, obj%T)), & - & a2=obj%dNdXi) -END SELECT -END PROCEDURE elemsd_getLocalDivergence_2 - -!---------------------------------------------------------------------------- -! getLocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalDivergence_3 -SELECT CASE (val%varType) -CASE (constant) - CALL reallocate(lg, SIZE(obj%N, 2)) -CASE (space) - CALL getLocalDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getLocalDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getLocalDivergence_3 - -!---------------------------------------------------------------------------- -! getLocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalDivergence_4 -INTEGER(I4B) :: ii, n -n = SIZE(obj%N, 2) -CALL reallocate(lg, SIZE(val, 1), n) -DO ii = 1, n - lg(:, ii) = contraction(val, TRANSPOSE(obj%dNdXi(:, :, ii))) -END DO -END PROCEDURE elemsd_getLocalDivergence_4 - -!---------------------------------------------------------------------------- -! getLocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalDivergence_5 -INTEGER(I4B) :: ii, n -REAL(DFP), ALLOCATABLE :: r3(:, :, :) -!! -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - n = SIZE(obj%N, 2) - CALL reallocate(lg, SIZE(val, 1), n) - r3 = MATMUL(val, obj%T) - DO ii = 1, n - lg(:, ii) = contraction(r3, TRANSPOSE(obj%dNdXi(:, :, ii))) - END DO -END SELECT -!! -IF (ALLOCATED(r3)) DEALLOCATE (r3) -END PROCEDURE elemsd_getLocalDivergence_5 - -!---------------------------------------------------------------------------- -! getLocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalDivergence_6 -INTEGER(I4B) :: s(2) -SELECT CASE (val%varType) -CASE (constant) - s = SHAPE(val) - CALL reallocate(lg, s(1), SIZE(obj%N, 2)) -CASE (space) - CALL getLocalDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getLocalDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getLocalDivergence_6 - -!---------------------------------------------------------------------------- -! getLocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalDivergence_7 -REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :) -!! -SELECT CASE (val%rank) -CASE (vector) - CALL getLocalDivergence(obj=obj, lg=r1, val=val) - lg = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace) - DEALLOCATE (r1) -CASE (matrix) - CALL getLocalDivergence(obj=obj, lg=r2, val=val) - lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - DEALLOCATE (r2) -END SELECT -END PROCEDURE elemsd_getLocalDivergence_7 - -!---------------------------------------------------------------------------- -! LocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalDivergence_8 -REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :) -INTEGER(I4B) :: ii -!! -SELECT CASE (val%rank) -!! -!! vector -!! -CASE (vector) - DO ii = 1, SIZE(obj) - CALL getLocalDivergence(obj=obj(ii), lg=r1, val=val) - IF (.NOT. ALLOCATED(r2)) THEN - CALL reallocate(r2, SIZE(r1, 1), SIZE(obj)) - END IF - !! - r2(:, ii) = r1 - END DO - lg = QuadratureVariable(r2, typeFEVariableScalar,& - & typeFEVariableSpaceTime) - DEALLOCATE (r2, r1) -!! -!! matrix -!! -CASE (matrix) - DO ii = 1, SIZE(obj) - CALL getLocalDivergence(obj=obj(ii), lg=r2, val=val) - IF (.NOT. ALLOCATED(r3)) THEN - CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) - END IF - !! - r3(:, :, ii) = r2 - END DO - lg = QuadratureVariable(r3, typeFEVariableVector,& - & typeFEVariableSpaceTime) - DEALLOCATE (r2, r3) -END SELECT -END PROCEDURE elemsd_getLocalDivergence_8 - -!---------------------------------------------------------------------------- -! LocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_LocalDivergence_1 -CALL getLocalDivergence(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_LocalDivergence_1 - -!---------------------------------------------------------------------------- -! LocalDivergence -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_LocalDivergence_2 -CALL getLocalDivergence(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_LocalDivergence_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 deleted file mode 100644 index 82ee7c65f..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 +++ /dev/null @@ -1,244 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_LocalGradientMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_1 -lg = MATMUL(Val, obj%dNdXi) -!! matmul r1 r3 -END PROCEDURE elemsd_getLocalGradient_1 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_2 -lg = MATMUL(Val, obj%dNdXi) -!! matmul r2 r3 -END PROCEDURE elemsd_getLocalGradient_2 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_3 -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) - !! matmul r1 r3 -END SELECT -END PROCEDURE elemsd_getLocalGradient_3 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_4 -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) - !! (r3.r1).r3 => r2.r3 -END SELECT -END PROCEDURE elemsd_getLocalGradient_4 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_5 -SELECT CASE (val%varType) -CASE (constant) - CALL reallocate(lg, obj%refelem%xidimension, SIZE(obj%N, 2)) -CASE (space) - CALL getLocalGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getLocalGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getLocalGradient_5 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_6 -INTEGER(I4B) :: s(1) -!! -SELECT CASE (val%varType) -CASE (constant) - s = SHAPE(val) - CALL reallocate(lg, s(1), obj%refelem%xidimension, SIZE(obj%N, 2)) -CASE (space) - CALL getLocalGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getLocalGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getLocalGradient_6 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_7 -lg = MATMUL(val, obj%dNdXi) -!! r3.r4 -END PROCEDURE elemsd_getLocalGradient_7 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_8 -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) - !! (r4.r1).r3 -END SELECT -END PROCEDURE elemsd_getLocalGradient_8 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_9 -INTEGER(I4B) :: s(2) -SELECT CASE (val%varType) -CASE (constant) - s = SHAPE(val) - CALL reallocate(lg, s(1), s(2), & - & obj%refelem%xidimension, SIZE(obj%N, 2)) -CASE (space) - CALL getLocalGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getLocalGradient(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -END PROCEDURE elemsd_getLocalGradient_9 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_10 -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) -!! -SELECT CASE (val%rank) -CASE (scalar) - CALL getLocalGradient(obj=obj, lg=r2, val=val) - lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - DEALLOCATE (r2) -CASE (vector) - CALL getLocalGradient(obj=obj, lg=r3, val=val) - lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) - DEALLOCATE (r3) -CASE (matrix) - !! BUG Implement gradient of matrix - !! TODO Extend FEVariable to support r3, which is necessary to keep - !! the gradient of rank02 tensors -END SELECT -END PROCEDURE elemsd_getLocalGradient_10 - -!---------------------------------------------------------------------------- -! getLocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getLocalGradient_11 -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) -INTEGER(I4B) :: ii -!! -SELECT CASE (val%rank) -!! -!! scalar -!! -CASE (scalar) - DO ii = 1, SIZE(obj) - CALL getLocalGradient(obj=obj(ii), lg=r2, val=val) - IF (.NOT. ALLOCATED(r3)) THEN - CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) - END IF - !! - r3(:, :, ii) = r2(:, :) - END DO - lg = QuadratureVariable(r3, typeFEVariableVector,& - & typeFEVariableSpaceTime) - DEALLOCATE (r2, r3) -!! -!! vector -!! -CASE (vector) - DO ii = 1, SIZE(obj) - CALL getLocalGradient(obj=obj(ii), lg=r3, val=val) - IF (.NOT. ALLOCATED(r4)) THEN - CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) - END IF - !! - r4(:, :, :, ii) = r3(:, :, :) - END DO - lg = QuadratureVariable(r4, typeFEVariableMatrix,& - & typeFEVariableSpaceTime) - DEALLOCATE (r3, r4) -!! -!! matrix TODO -!! -CASE (matrix) - !! BUG Implement gradient of matrix - !! TODO Extend FEVariable to support r3, which is necessary to keep - !! the gradient of rank02 tensors -END SELECT -END PROCEDURE elemsd_getLocalGradient_11 - -!---------------------------------------------------------------------------- -! LocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_LocalGradient_1 -CALL getLocalGradient(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_LocalGradient_1 - -!---------------------------------------------------------------------------- -! LocalGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_LocalGradient_2 -CALL getLocalGradient(obj=obj, lg=ans, val=val) -END PROCEDURE elemsd_LocalGradient_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 deleted file mode 100644 index 2998cf756..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ /dev/null @@ -1,167 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_ProjectionMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! getProjectionOfdNdXt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getProjectionOfdNdXt_2 -INTEGER(I4B) :: ii, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) -CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3)) -nsd = SIZE(obj%dNdXt, 2) -DO ii = 1, SIZE(cdNdXt, 2) - cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), cbar(1:nsd, ii)) -END DO - !! -DEALLOCATE (cbar) - !! -END PROCEDURE getProjectionOfdNdXt_2 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! getProjectionOfdNTdXt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getProjectionOfdNTdXt_1 -INTEGER(I4B) :: ii, nsd - !! - !! main - !! -CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & - & SIZE(obj%dNTdXt, 4)) -nsd = SIZE(obj%dNTdXt, 3) - !! -DO ii = 1, SIZE(cdNTdXt, 3) - cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), Val(1:nsd)) -END DO - !! -END PROCEDURE getProjectionOfdNTdXt_1 - -!---------------------------------------------------------------------------- -! getProjectionOfdNTdXt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getProjectionOfdNTdXt_2 - !! -INTEGER(I4B) :: ii, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) -CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & - & SIZE(obj%dNTdXt, 4)) -nsd = SIZE(obj%dNTdXt, 3) - !! -DO ii = 1, SIZE(cdNTdXt, 3) - cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), cbar(1:nsd, ii)) -END DO - !! -DEALLOCATE (cbar) -END PROCEDURE getProjectionOfdNTdXt_2 - -!---------------------------------------------------------------------------- -! getProjectionOfdNTdXt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getProjectionOfdNTdXt_3 - !! -INTEGER(I4B) :: ii, jj, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) - !! - !! main - !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) - !! -CALL Reallocate(cdNTdXt, & - & SIZE(obj(1)%dNTdXt, 1), & - & SIZE(obj(1)%dNTdXt, 2), & - & SIZE(obj(1)%dNTdXt, 4), SIZE(obj)) - !! -! CALL Reallocate( & -! & cdNTdXt, & -! & SIZE(obj(1)%N, 1), & -! & SIZE(obj(1)%T), & -! & SIZE(obj(1)%N, 2), & -! & SIZE(obj) ) - !! -nsd = SIZE(obj(1)%dNTdXt, 3) - !! -DO jj = 1, SIZE(cbar, 3) - DO ii = 1, SIZE(cbar, 2) - !! - cdNTdXt(:, :, ii, jj) = MATMUL( & - & obj(jj)%dNTdXt(:, :, :, ii), & - & cbar(1:nsd, ii, jj)) - !! - END DO -END DO - !! -DEALLOCATE (cbar) - !! -END PROCEDURE getProjectionOfdNTdXt_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 deleted file mode 100644 index 2353d3d0f..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ /dev/null @@ -1,285 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_SetMethods) Methods -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! SetThickness -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SetThickness -obj%Thickness = MATMUL(val, N) -END PROCEDURE elemsd_SetThickness - -!---------------------------------------------------------------------------- -! SetThickness -!---------------------------------------------------------------------------- - -MODULE PROCEDURE stsd_SetThickness -CALL SetThickness(obj=obj, val=MATMUL(val, T), N=N) -END PROCEDURE stsd_SetThickness - -!---------------------------------------------------------------------------- -! SetBarycentricCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SetBarycentricCoord -obj%Coord = MATMUL(val, N) -END PROCEDURE elemsd_SetBarycentricCoord - -!---------------------------------------------------------------------------- -! SetBarycentricCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE stsd_SetBarycentricCoord -CALL SetBarycentricCoord(obj=obj, val=MATMUL(val, T), N=N) -END PROCEDURE stsd_SetBarycentricCoord - -!---------------------------------------------------------------------------- -! SetJs -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SetJs -! Define internal variable -INTEGER(I4B) :: xidim, nsd, nips, ips -REAL(DFP) :: aa, bb, ab -! -xidim = obj%RefElem%XiDimension -nsd = obj%RefElem%nsd -nips = SIZE(obj%N, 2) -! -DO ips = 1, nips - IF (nsd .EQ. xidim) THEN - obj%Js(ips) = det(obj%Jacobian(:, :, ips)) - ELSE IF (xidim .EQ. 1 .AND. xidim .NE. nsd) THEN - obj%Js(ips) = & - & SQRT(DOT_PRODUCT(obj%Jacobian(:, 1, ips), & - & obj%Jacobian(:, 1, ips))) - ELSE IF (xidim .EQ. 2 .AND. xidim .NE. nsd) THEN - aa = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 1, ips)) - bb = DOT_PRODUCT(obj%Jacobian(:, 2, ips), obj%Jacobian(:, 2, ips)) - ab = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 2, ips)) - obj%Js(ips) = SQRT(aa * bb - ab * ab) - END IF -END DO -END PROCEDURE elemsd_SetJs - -!---------------------------------------------------------------------------- -! SetdNdXt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SetdNdXt -! Define internal variables -INTEGER(I4B) :: NSD, XiDim, ips, nips -REAL(DFP), ALLOCATABLE :: InvJacobian(:, :, :) - -NSD = obj%RefElem%NSD -XiDim = obj%RefElem%XiDimension -IF (NSD .NE. XiDim) THEN - obj%dNdXt = 0.0_DFP -ELSE - ! Compute inverse of Jacobian - nips = SIZE(obj%N, 2) - ALLOCATE (InvJacobian(NSD, NSD, nips)) - CALL Inv(InvA=InvJacobian, A=obj%Jacobian) - DO ips = 1, nips - obj%dNdXt(:, :, ips) = & - & MATMUL(obj%dNdXi(:, :, ips), InvJacobian(:, :, ips)) - END DO - DEALLOCATE (InvJacobian) -END IF -END PROCEDURE elemsd_SetdNdXt - -!---------------------------------------------------------------------------- -! SetJacobian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SetJacobian -obj%jacobian = MATMUL(val, dNdXi) -END PROCEDURE elemsd_SetJacobian - -!---------------------------------------------------------------------------- -! SetJacobian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE stsd_SetJacobian -obj%jacobian = MATMUL(MATMUL(val, T), dNdXi) -END PROCEDURE stsd_SetJacobian - -!---------------------------------------------------------------------------- -! SetdNTdt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE stsd_SetdNTdt -REAL(DFP), ALLOCATABLE :: v(:, :) -INTEGER(I4B) :: ip - -! get mesh velocity at space integration points -v = MATMUL(MATMUL(val, obj%dTdTheta / obj%Jt), obj%N) -CALL Reallocate(obj%dNTdt, SIZE(obj%N, 1), SIZE(obj%T), & - & SIZE(obj%N, 2)) -DO ip = 1, SIZE(obj%N, 2) - obj%dNTdt(:, :, ip) = OUTERPROD(obj%N(:, ip), obj%dTdTheta / obj%Jt) & - & - MATMUL(obj%dNTdXt(:, :, :, ip), v(:, ip)) -END DO -END PROCEDURE stsd_SetdNTdt - -!---------------------------------------------------------------------------- -! SetdNTdXt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE stsd_SetdNTdXt -! -INTEGER(I4B) :: ip, j -REAL(DFP), ALLOCATABLE :: Q(:, :), Temp(:, :) -! -CALL Reallocate(obj%dNTdXt, SIZE(obj%N, 1), SIZE(obj%T), & - & SIZE(obj%Jacobian, 1), SIZE(obj%N, 2)) -! -IF (obj%RefElem%XiDimension .NE. obj%RefElem%NSD) THEN - RETURN -END IF -! -Q = obj%Jacobian(:, :, 1) -! -DO ip = 1, SIZE(obj%N, 2) - CALL INV(A=obj%Jacobian(:, :, ip), INVA=Q) - Temp = MATMUL(obj%dNdXi(:, :, ip), Q) - DO j = 1, SIZE(Q, 1) - obj%dNTdXt(:, :, j, ip) = OUTERPROD(Temp(:, j), obj%T) - END DO -END DO -! -DEALLOCATE (Q, Temp) -! -END PROCEDURE stsd_SetdNTdXt - -!---------------------------------------------------------------------------- -! SetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Set1 -CALL SetJacobian(obj=obj, val=val, dNdXi=dNdXi) -CALL SetJs(obj=obj) -CALL SetdNdXt(obj=obj) -CALL SetBarycentricCoord(obj=obj, val=val, N=N) -END PROCEDURE elemsd_Set1 - -!---------------------------------------------------------------------------- -! SetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Set2 -INTEGER(I4B), ALLOCATABLE :: facetNptrs(:) - -CALL SetJacobian(obj=cellobj, val=cellVal, dNdXi=celldNdXi) -CALL SetJs(obj=cellobj) -CALL SetdNdXt(obj=cellobj) -CALL SetBarycentricCoord(obj=cellobj, val=cellval, N=cellN) - -facetNptrs = GetConnectivity(facetobj%refelem) - -CALL SetJacobian(obj=facetobj, val=cellVal(:, facetNptrs), & - & dNdXi=facetdNdXi) -CALL SetJs(obj=facetobj) -CALL SetBarycentricCoord(obj=facetobj, val=cellval(:, facetNptrs), & - & 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 - -! I am copying normal Js from facet to cell -! In this way, we can use cellobj to construct the element matrix - -cellobj%normal = facetobj%normal -cellobj%Js = facetobj%Js -cellobj%Ws = facetobj%Ws - -IF (ALLOCATED(facetNptrs)) DEALLOCATE (facetNptrs) -END PROCEDURE elemsd_Set2 - -!---------------------------------------------------------------------------- -! SetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_Set3 -! -CALL Set( & - & facetobj=masterFacetObj, & - & cellobj=masterCellObj, & - & cellVal=masterCellVal, & - & cellN=masterCellN, & - & celldNdXi=masterCelldNdXi, & - & facetN=masterFacetN, & - & facetdNdXi=masterFacetdNdXi) -! -CALL Set( & - & facetobj=slaveFacetObj, & - & cellobj=slaveCellObj, & - & cellVal=slaveCellVal, & - & cellN=slaveCellN, & - & celldNdXi=slaveCelldNdXi, & - & facetN=slaveFacetN, & - & facetdNdXi=slaveFacetdNdXi) -! -END PROCEDURE elemsd_Set3 - -!---------------------------------------------------------------------------- -! SetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE stelemsd_Set1 -CALL SetJacobian(obj=obj, val=val, dNdXi=dNdXi, T=T) -CALL SetJs(obj=obj) -CALL SetdNdXt(obj=obj) -CALL SetBarycentricCoord(obj=obj, val=val, N=N, T=T) -CALL SetdNTdXt(obj=obj) -CALL SetdNTdt(obj=obj, val=val) -END PROCEDURE stelemsd_Set1 - -!---------------------------------------------------------------------------- -! SetNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_SetNormal -REAL(DFP) :: vec(3, 3) -INTEGER(I4B) :: i, xidim, nsd -vec = 0.0_DFP -vec(3, 2) = 1.0_DFP -xidim = obj%RefElem%XiDimension -nsd = obj%refElem%nsd -DO i = 1, SIZE(obj%N, 2) - Vec(1:nsd, 1:xidim) = obj%Jacobian(1:nsd, 1:xidim, i) - obj%Normal(:, i) = & - & VectorProduct(Vec(:, 1), Vec(:, 2)) / obj%Js(i) -END DO -END PROCEDURE elemsd_SetNormal - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 deleted file mode 100644 index a9bda718e..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 +++ /dev/null @@ -1,147 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_StabilizationParamMethods) SUGN3 -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getSUGN3Param -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_1 -REAL(DFP), ALLOCATABLE :: h0(:), nubar(:) -INTEGER(I4B) :: ii -!! -CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) -!! -IF (PRESENT(h)) THEN - h = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -!! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) -!! -DO ii = 1, SIZE(h0) - h0(ii) = h0(ii)**2 / nubar(ii) / 4.0_DFP -END DO -!! -tau = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -!! -DEALLOCATE (h0, nubar) -END PROCEDURE elemsd_GetSUGN3Param_1 - -!---------------------------------------------------------------------------- -! getSUGN3Param -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_2 -INTEGER(I4B) :: ii -REAL(DFP), ALLOCATABLE :: h0(:, :), nubar(:, :) -!! -!! main -!! -CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) -!! -IF (PRESENT(h)) THEN - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -!! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) -!! -DO ii = 1, SIZE(obj) - h0(:, ii) = h0(:, ii)**2 / nubar(:, ii) / 4.0_DFP -END DO -!! -tau = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -IF (ALLOCATED(h0)) DEALLOCATE (h0) -IF (ALLOCATED(nubar)) DEALLOCATE (nubar) -!! -END PROCEDURE elemsd_GetSUGN3Param_2 - -!---------------------------------------------------------------------------- -! getSUGN3Param -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_3 -REAL(DFP), ALLOCATABLE :: h0(:) -INTEGER(I4B) :: ii -!! -CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) -!! -IF (PRESENT(h)) THEN - h = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -!! -DO ii = 1, SIZE(h0) - h0(ii) = h0(ii)**2 / nu / 4.0_DFP -END DO -!! -tau = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -!! -DEALLOCATE (h0) -!! -END PROCEDURE elemsd_GetSUGN3Param_3 - -!---------------------------------------------------------------------------- -! getSUGN3Param -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_4 -INTEGER(I4B) :: ii -REAL(DFP), ALLOCATABLE :: h0(:, :) -!! -!! main -!! -CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) -!! -IF (PRESENT(h)) THEN - h = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -!! -DO ii = 1, SIZE(obj) - h0(:, ii) = h0(:, ii)**2 / nu / 4.0_DFP -END DO -!! -tau = QuadratureVariable( & - & h0, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -IF (ALLOCATED(h0)) DEALLOCATE (h0) -!! -END PROCEDURE elemsd_GetSUGN3Param_4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE SUGN3 diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 deleted file mode 100644 index db36aea62..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 +++ /dev/null @@ -1,567 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -SUBMODULE(ElemshapeData_StabilizationParamMethods) SUPG -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getSUPGParam -!---------------------------------------------------------------------------- - -PURE SUBROUTINE elemsd_getSUPGParam_a(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! element shape data - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! stabilizing parameters - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - !! vector variable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution - TYPE(FEVariable_), INTENT(IN) :: nu - !! diffusivity coefficient - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k - !! permeability - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi - !! porosity - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time step size - !! default value is zero - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default=1 - !! if opt=1, then we use `SQRT(1.0_DFP / (t1**2 + t2**2 + t3**2 + t4**2))` - !! if opt=2, then we use `1.0_DFP / (t1 + t2 + t3 + t4)` - !! - !! - !! define internal variables - !! - INTEGER(I4B) :: ii, opt0 - REAL(DFP) :: t1, t2, t3, t4 - REAL(DFP), ALLOCATABLE :: p(:, :) - !! cdNdXt - REAL(DFP), ALLOCATABLE :: r(:, :) - !! unit normal - REAL(DFP), ALLOCATABLE :: q(:, :) - !! rdNdXt - REAL(DFP), ALLOCATABLE :: ans(:) - !! result - REAL(DFP), ALLOCATABLE :: nubar(:), kbar(:), phibar(:) - !! value of nu at space quadrature points - TYPE(FEVariable_) :: rvar - !! vector variable for keeping r - !! - !! Main - !! - opt0 = INPUT(default=1_I4B, option=opt) - !! - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c) - !! - CALL GetUnitNormal(obj=obj, val=val, r=r) - rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) - !! - CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) - !! - IF (PRESENT(k)) THEN - CALL GetInterpolation(obj=obj, val=k, interpol=kbar) - CALL GetInterpolation(obj=obj, val=phi, interpol=phibar) - ELSE - ALLOCATE (kbar(SIZE(nubar))) - ALLOCATE (phibar(SIZE(nubar))) - kbar = MaxDFP !! very large number - phibar = 1.0_DFP - END IF - !! - t2 = 0.0_DFP - IF (PRESENT(dt)) THEN - IF (dt .GT. zero) t2 = 2.0_DFP / dt - END IF - !! - CALL Reallocate(ans, SIZE(obj%N, 2)) - !! - IF (opt0 .EQ. 1_I4B) THEN - DO ii = 1, SIZE(ans) - t1 = SUM(ABS(p(:, ii))) - t3 = nubar(ii) * (SUM(ABS(q(:, ii))))**2 - t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) - ans(ii) = SQRT(1.0_DFP / (t1**2 + t2**2 + t3**2 + t4**2)) - END DO - ELSE - DO ii = 1, SIZE(ans) - t1 = SUM(ABS(p(:, ii))) - t3 = nubar(ii) * (SUM(ABS(q(:, ii))))**2 - t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) - ans(ii) = 1.0_DFP / (t1 + t2 + t3 + t4) - END DO - END IF - !! - tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) - !! - !! cleanup - IF (ALLOCATED(p)) DEALLOCATE (p) - IF (ALLOCATED(r)) DEALLOCATE (r) - IF (ALLOCATED(q)) DEALLOCATE (q) - IF (ALLOCATED(ans)) DEALLOCATE (ans) - IF (ALLOCATED(nubar)) DEALLOCATE (nubar) - IF (ALLOCATED(kbar)) DEALLOCATE (kbar) - IF (ALLOCATED(phibar)) DEALLOCATE (phibar) - CALL DEALLOCATE (rvar) -END SUBROUTINE elemsd_getSUPGParam_a - -!---------------------------------------------------------------------------- -! getSUPGParam -!---------------------------------------------------------------------------- - -PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj - !! space-time element shape data - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! stabilization parameter - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - !! vector variable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution - !! scalar/vector variable - TYPE(FEVariable_), INTENT(IN) :: nu - !! diffusivity - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k - !! permeability - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi - !! porosity - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time-step size - !! This parameter is not used currently. - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default=1 - !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` - !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` - !! - !! INTERNAL VARIABLES - !! - INTEGER(I4B) :: ii, opt0 - REAL(DFP) :: t12, t3, t4 - REAL(DFP), ALLOCATABLE :: p(:, :, :) - !! cdNTdxt - REAL(DFP), ALLOCATABLE :: r(:, :) - !! vector at space quad points - REAL(DFP), ALLOCATABLE :: q(:, :, :) - !! - REAL(DFP), ALLOCATABLE :: ans(:) - REAL(DFP), ALLOCATABLE :: nubar(:) - REAL(DFP), ALLOCATABLE :: kbar(:) - REAL(DFP), ALLOCATABLE :: phibar(:) - TYPE(FEVariable_) :: rvar - !! - !! MAIN - !! - opt0 = INPUT(option=opt, default=1_I4B) - !! - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c) - !! - !! make cdNTdxt + dNTdt - !! - p = p + obj%dNTdt - !! - 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) - !! - IF (PRESENT(k)) THEN - CALL GetInterpolation(obj=obj, val=k, interpol=kbar) - CALL GetInterpolation(obj=obj, val=phi, interpol=phibar) - ELSE - ALLOCATE (kbar(SIZE(nubar))) - ALLOCATE (phibar(SIZE(nubar))) - kbar = MaxDFP !! very large number - phibar = 1.0_DFP - END IF - !! - CALL reallocate(ans, SIZE(obj%N, 2)) - !! - IF (opt0 .EQ. 1_I4B) THEN - DO ii = 1, SIZE(ans, 1) - t12 = SUM(ABS(p(:, :, ii))) - t3 = nubar(ii) * (SUM(ABS(q(:, :, ii))))**2 - t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) - ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2)) - END DO - ELSE - DO ii = 1, SIZE(ans, 1) - t12 = SUM(ABS(p(:, :, ii))) - t3 = nubar(ii) * (SUM(ABS(q(:, :, ii))))**2 - t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) - ans(ii) = 1.0_DFP / (t12 + t3 + t4) - END DO - END IF - !! - tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) - !! - !! cleanup - !! - IF (ALLOCATED(p)) DEALLOCATE (p) - IF (ALLOCATED(r)) DEALLOCATE (r) - IF (ALLOCATED(q)) DEALLOCATE (q) - IF (ALLOCATED(ans)) DEALLOCATE (ans) - IF (ALLOCATED(nubar)) DEALLOCATE (nubar) - IF (ALLOCATED(kbar)) DEALLOCATE (kbar) - IF (ALLOCATED(phibar)) DEALLOCATE (phibar) - CALL DEALLOCATE (rvar) -END SUBROUTINE elemsd_getSUPGParam_b - -!---------------------------------------------------------------------------- -! getSUPGParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSUPGParam1 -SELECT TYPE (obj) -TYPE IS (ElemshapeData_) - !! - CALL elemsd_getSUPGParam_a( & - & obj=obj, & - & tau=tau, & - & c=c, & - & val=val, & - & nu=nu, & - & k=k, & - & phi=phi, & - & dt=dt, & - & opt=opt) - !! -CLASS IS (STElemshapeData_) - !! - CALL elemsd_getSUPGParam_b( & - & obj=obj, & - & tau=tau, & - & c=c, & - & val=val, & - & nu=nu, & - & k=k, & - & phi=phi, & - & dt=dt, & - & opt=opt) - !! -END SELECT -END PROCEDURE elemsd_getSUPGParam1 - -!---------------------------------------------------------------------------- -! GetSUPGParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUPGParam2 -INTEGER(I4B) :: ii -REAL(DFP), ALLOCATABLE :: ans(:, :) -TYPE(FEVariable_) :: a -!! -!! main -!! -CALL Reallocate(ans, SIZE(obj(1)%N, 2), SIZE(obj)) -!! -DO ii = 1, SIZE(obj) - !! - CALL elemsd_getSUPGParam_b( & - & obj=obj(ii), & - & tau=a, & - & c=c, & - & val=val, & - & nu=nu, & - & k=k, & - & phi=phi, & - & dt=dt, & - & opt=opt) - !! - ans(:, ii) = Get(a, TypeFEVariableScalar, TypeFEVariableSpace) - !! -END DO -!! -tau = QuadratureVariable( & - & ans, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -!! -CALL DEALLOCATE (a); DEALLOCATE (ans) -END PROCEDURE elemsd_GetSUPGParam2 - -!---------------------------------------------------------------------------- -! getSUPGParam -!---------------------------------------------------------------------------- - -PURE SUBROUTINE elemsd_getSUPGParam_c(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(ElemshapeData_), INTENT(IN) :: obj - !! element shape data - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! stabilizing parameters - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - !! vector variable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution - REAL(DFP), INTENT(IN) :: nu - !! diffusivity coefficient - REAL(DFP), OPTIONAL, INTENT(IN) :: k - !! permeability - REAL(DFP), OPTIONAL, INTENT(IN) :: phi - !! porosity - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time step size - !! default value is zero - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default = 1 - !! opt=1 - !! opt=2 - ! - !! - !! internal variables - !! - INTEGER(I4B) :: ii, opt0 - REAL(DFP) :: t1, t2, t3, t4, kbar, phibar - REAL(DFP), ALLOCATABLE :: p(:, :) - !! cdNdXt - REAL(DFP), ALLOCATABLE :: r(:, :) - !! unit normal - REAL(DFP), ALLOCATABLE :: q(:, :) - !! rdNdXt - REAL(DFP), ALLOCATABLE :: ans(:) - !! result - !! value of nu at space quadrature points - TYPE(FEVariable_) :: rvar - !! vector variable for keeping r - !! - !! MAIN - !! - opt0 = INPUT(default=1_I4B, option=opt) - !! - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c) - !! - CALL GetUnitNormal(obj=obj, val=val, r=r) - rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) - !! - IF (PRESENT(k)) THEN - kbar = k - phibar = phi - ELSE - kbar = MaxDFP - phibar = 1.0_DFP - END IF - !! - t2 = 0.0_DFP - IF (PRESENT(dt)) THEN - t2 = 2.0_DFP / dt - END IF - !! - CALL Reallocate(ans, SIZE(obj%N, 2)) - !! - IF (opt0 .EQ. 1_I4B) THEN - DO ii = 1, SIZE(ans) - t1 = SUM(ABS(p(:, ii))) - t3 = nu * (SUM(ABS(q(:, ii))))**2 - t4 = 2.0_DFP * phibar * nu / kbar - ans(ii) = SQRT(1.0_DFP / (t1**2 + t2**2 + t3**2 + t4**2)) - END DO - ELSE - DO ii = 1, SIZE(ans) - t1 = SUM(ABS(p(:, ii))) - t3 = nu * (SUM(ABS(q(:, ii))))**2 - t4 = 2.0_DFP * phibar * nu / kbar - ans(ii) = 1.0_DFP / (t1 + t2 + t3 + t4) - END DO - END IF - !! - tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) - !! - !! cleanup - DEALLOCATE (p, r, q, ans) - CALL DEALLOCATE (rvar) -END SUBROUTINE elemsd_getSUPGParam_c - -!---------------------------------------------------------------------------- -! getSUPGParam -!---------------------------------------------------------------------------- - -PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, & - & phi, dt, opt) - CLASS(STElemshapeData_), INTENT(IN) :: obj - !! space-time element shape data - TYPE(FEVariable_), INTENT(INOUT) :: tau - !! stabilization parameter - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - !! vector variable - TYPE(FEVariable_), INTENT(IN) :: val - !! solution - !! scalar/vector variable - REAL(DFP), INTENT(IN) :: nu - !! diffusivity - REAL(DFP), OPTIONAL, INTENT(IN) :: k - !! permeability - REAL(DFP), OPTIONAL, INTENT(IN) :: phi - !! porosity - REAL(DFP), OPTIONAL, INTENT(IN) :: dt - !! time-step size - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! default=1 - !! opt=1, - !! opt=2 - !! - !! INTERNAL VARIABLES - !! - INTEGER(I4B) :: ii, opt0 - REAL(DFP) :: t12, t3, t4, kbar, phibar - REAL(DFP), ALLOCATABLE :: p(:, :, :) - !! cdNTdxt - REAL(DFP), ALLOCATABLE :: r(:, :) - !! vector at space quad points - REAL(DFP), ALLOCATABLE :: q(:, :, :) - !! - REAL(DFP), ALLOCATABLE :: ans(:) - TYPE(FEVariable_) :: rvar - !! - !! MAIN - !! - opt0 = INPUT(default=1_I4B, option=opt) - !! - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c) - !! - !! make cdNTdxt + dNTdt - !! - p = p + obj%dNTdt - !! - CALL GetUnitNormal(obj=obj, val=val, r=r) - rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar) - !! - IF (PRESENT(k)) THEN - kbar = k - phibar = phi - ELSE - kbar = MaxDFP - phibar = 1.0_DFP - END IF - !! - !! - CALL reallocate(ans, SIZE(obj%N, 2)) - !! - IF (opt0 .EQ. 1_I4B) THEN - DO ii = 1, SIZE(ans, 1) - t12 = SUM(ABS(p(:, :, ii))) - t3 = nu * (SUM(ABS(q(:, :, ii))))**2 - t4 = 2.0_DFP * phibar * nu / kbar - ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2)) - END DO - ELSE - DO ii = 1, SIZE(ans, 1) - t12 = SUM(ABS(p(:, :, ii))) - t3 = nu * (SUM(ABS(q(:, :, ii))))**2 - t4 = 2.0_DFP * phibar * nu / kbar - ans(ii) = 1.0_DFP / (t12 + t3 + t4) - END DO - END IF - !! - tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) - !! - !! cleanup - !! - DEALLOCATE (p, r, q, ans) - CALL DEALLOCATE (rvar) -END SUBROUTINE elemsd_getSUPGParam_d - -!---------------------------------------------------------------------------- -! getSUPGParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_getSUPGParam3 -SELECT TYPE (obj) -TYPE IS (ElemshapeData_) - !! - CALL elemsd_getSUPGParam_c( & - & obj=obj, & - & tau=tau, & - & c=c, & - & val=val, & - & nu=nu, & - & k=k, & - & phi=phi, & - & dt=dt, & - & opt=opt) - !! -CLASS IS (STElemshapeData_) - !! - CALL elemsd_getSUPGParam_d( & - & obj=obj, & - & tau=tau, & - & c=c, & - & val=val, & - & nu=nu, & - & k=k, & - & phi=phi, & - & dt=dt, & - & opt=opt) - !! -END SELECT -END PROCEDURE elemsd_getSUPGParam3 - -!---------------------------------------------------------------------------- -! GetSUPGParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUPGParam4 -INTEGER(I4B) :: ii -REAL(DFP), ALLOCATABLE :: ans(:, :) -TYPE(FEVariable_) :: a - !! - !! main - !! -CALL Reallocate(ans, SIZE(obj(1)%N, 2), SIZE(obj)) - !! -DO ii = 1, SIZE(obj) - !! - CALL elemsd_getSUPGParam_d( & - & obj=obj(ii), & - & tau=a, & - & c=c, & - & val=val, & - & nu=nu, & - & k=k, & - & phi=phi, & - & dt=dt, & - & opt=opt) - !! - ans(:, ii) = Get(a, TypeFEVariableScalar, TypeFEVariableSpace) - !! -END DO - !! -tau = QuadratureVariable( & - & ans, & - & TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) - !! - !! -CALL DEALLOCATE (a) -DEALLOCATE (ans) -END PROCEDURE elemsd_GetSUPGParam4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE SUPG diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 deleted file mode 100644 index 6d5a80042..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 +++ /dev/null @@ -1,284 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -SUBMODULE(ElemshapeData_StabilizationParamMethods) Takizawa2018 -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_1 -! -REAL(DFP), ALLOCATABLE :: nubar(:), h0(:), hmax0(:), hmin0(:), & - & r0(:, :), tau0(:) -INTEGER(I4B) :: ii, nips -REAL(DFP) :: areal, r2 -! -CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & val=val, & - & hmax=hmax0, & - & hmin=hmin0, & - & r=r0, & - & opt=opt) -! -IF (PRESENT(h)) THEN - h = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -! -IF (PRESENT(hmax)) THEN - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -! -IF (PRESENT(hmin)) THEN - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) -CALL Reallocate(tau0, SIZE(h0)) -! -DO ii = 1, SIZE(h0) - ! - r2 = DOT_PRODUCT(r0(:, ii), r0(:, ii)) - ! - IF (h0(ii) .APPROXEQ.zero) THEN - tau0(ii) = 4.0_DFP * nubar(ii) * & - & (1.0_DFP - r2) / hmin0(ii)**2 - ELSE - tau0(ii) = 4.0_DFP * nubar(ii) * & - & ((1.0_DFP - r2) / hmin0(ii)**2 & - & + 1.0_DFP / h0(ii)**2) - END IF - ! - tau0(ii) = 1.0_DFP / tau0(ii) - ! -END DO -! -tau = QuadratureVariable(tau0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -! -DEALLOCATE (nubar, h0, hmax0, hmin0, r0, tau0) -! -END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_1 - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_2 -! -REAL(DFP), ALLOCATABLE :: nubar(:, :), h0(:, :), hmax0(:, :), & - & hmin0(:, :), r0(:, :, :), tau0(:, :) -INTEGER(I4B) :: ii, nipt, nips, ipt -REAL(DFP) :: areal, r2 -! -nipt = SIZE(obj) -! -CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & val=val, & - & hmax=hmax0, & - & hmin=hmin0, & - & r=r0, & - & opt=opt) -! -IF (PRESENT(h)) THEN - h = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -! -IF (PRESENT(hmax)) THEN - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -! -IF (PRESENT(hmin)) THEN - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -! -nips = SIZE(h0, 1) -! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) -CALL Reallocate(tau0, nips, nipt) -! -DO ipt = 1, nipt - DO ii = 1, nips - ! - r2 = DOT_PRODUCT(r0(:, ii, ipt), r0(:, ii, ipt)) - ! - IF (h0(ii, ipt) .APPROXEQ.zero) THEN - tau0(ii, ipt) = 4.0_DFP * nubar(ii, ipt) * & - & (1.0_DFP - r2) / hmin0(ii, ipt)**2 - ELSE - tau0(ii, ipt) = 4.0_DFP * nubar(ii, ipt) * & - & ((1.0_DFP - r2) / hmin0(ii, ipt)**2 & - & + 1.0_DFP / h0(ii, ipt)**2) - END IF - ! - tau0(ii, ipt) = 1.0_DFP / tau0(ii, ipt) - ! - END DO -END DO -! -tau = QuadratureVariable(tau0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -! -DEALLOCATE (nubar, h0, hmax0, hmin0, r0, tau0) -! -END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_2 - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_3 -! -REAL(DFP), ALLOCATABLE :: h0(:), hmax0(:), hmin0(:), & - & r0(:, :), tau0(:) -INTEGER(I4B) :: ii -REAL(DFP) :: areal, r2 -! -CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & val=val, & - & hmax=hmax0, & - & hmin=hmin0, & - & r=r0, & - & opt=opt) -! -IF (PRESENT(h)) THEN - h = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -! -IF (PRESENT(hmax)) THEN - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -! -IF (PRESENT(hmin)) THEN - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -END IF -! -CALL Reallocate(tau0, SIZE(h0)) -! -DO ii = 1, SIZE(h0) - ! - r2 = DOT_PRODUCT(r0(:, ii), r0(:, ii)) - ! - IF (h0(ii) .APPROXEQ.zero) THEN - tau0(ii) = 4.0_DFP * nu * & - & (1.0_DFP - r2) / hmin0(ii)**2 - ELSE - tau0(ii) = 4.0_DFP * nu * & - & ((1.0_DFP - r2) / hmin0(ii)**2 & - & + 1.0_DFP / h0(ii)**2) - END IF - ! - tau0(ii) = 1.0_DFP / tau0(ii) - ! -END DO -! -tau = QuadratureVariable(tau0, TypeFEVariableScalar, & - & TypeFEVariableSpace) -! -DEALLOCATE (h0, hmax0, hmin0, r0, tau0) -! -END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_3 - -!---------------------------------------------------------------------------- -! getSUGN3Param_Takizawa2018 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_4 -! -REAL(DFP), ALLOCATABLE :: h0(:, :), hmax0(:, :), & - & hmin0(:, :), r0(:, :, :), tau0(:, :) -INTEGER(I4B) :: ii, nipt, nips, ipt -REAL(DFP) :: areal, r2 -! -nipt = SIZE(obj) -! -CALL GetHRQIParam( & - & obj=obj, & - & h=h0, & - & val=val, & - & hmax=hmax0, & - & hmin=hmin0, & - & r=r0, & - & opt=opt) -! -IF (PRESENT(h)) THEN - h = QuadratureVariable(h0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -! -IF (PRESENT(hmax)) THEN - hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -! -IF (PRESENT(hmin)) THEN - hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -END IF -! -nips = SIZE(h0, 1) -! -CALL Reallocate(tau0, nips, nipt) -! -DO ipt = 1, nipt - DO ii = 1, nips - ! - r2 = DOT_PRODUCT(r0(:, ii, ipt), r0(:, ii, ipt)) - ! - IF (h0(ii, ipt) .APPROXEQ.zero) THEN - tau0(ii, ipt) = 4.0_DFP * nu * & - & (1.0_DFP - r2) / hmin0(ii, ipt)**2 - ELSE - tau0(ii, ipt) = 4.0_DFP * nu * & - & ((1.0_DFP - r2) / hmin0(ii, ipt)**2 & - & + 1.0_DFP / h0(ii, ipt)**2) - END IF - ! - tau0(ii, ipt) = 1.0_DFP / tau0(ii, ipt) - ! - END DO -END DO -! -tau = QuadratureVariable(tau0, TypeFEVariableScalar, & - & TypeFEVariableSpaceTime) -! -DEALLOCATE (h0, hmax0, hmin0, r0, tau0) -! -END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Takizawa2018 diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 deleted file mode 100644 index 07a7d5fae..000000000 --- a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 +++ /dev/null @@ -1,168 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_UnitNormalMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getUnitNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getUnitNormal_1 -! Define internal variables -REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) -INTEGER(I4B) :: ii -!! main -CALL getInterpolation(obj=obj, Val=val, Interpol=p) -CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) -CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2)) -pnorm = NORM2(dp, DIM=1) -!! -DO ii = 1, SIZE(p) - IF (pnorm(ii) .GT. zero) THEN - IF (p(ii) .GE. 0.0_DFP) THEN - R(:, ii) = dp(:, ii) / pnorm(ii) - ELSE - R(:, ii) = -dp(:, ii) / pnorm(ii) - END IF - END IF -END DO -!! -IF (ALLOCATED(dp)) DEALLOCATE (dp) -IF (ALLOCATED(p)) DEALLOCATE (p) -IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) -END PROCEDURE getUnitNormal_1 - -!---------------------------------------------------------------------------- -! getUnitNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getUnitNormal_2 -REAL(DFP), ALLOCATABLE :: dp(:, :, :) -REAL(DFP), ALLOCATABLE :: p(:, :) -REAL(DFP), ALLOCATABLE :: mv(:) -REAL(DFP), ALLOCATABLE :: pnorm(:) -REAL(DFP) :: nrm -INTEGER(I4B) :: i -!! main -!! interpolate the vector -CALL getInterpolation(obj=obj, Interpol=p, Val=val) -!! get gradient of nodal values -CALL getSpatialGradient(obj=obj, lg=dp, Val=val) -pnorm = NORM2(p, DIM=1) -CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2)) -DO i = 1, SIZE(pnorm) - IF (pnorm(i) .GT. Zero) THEN - p(:, i) = p(:, i) / pnorm(i) - ELSE - p(:, i) = 1.0 - END IF - mv = MATMUL(p(:, i), dp(:, :, i)) - nrm = NORM2(mv) - IF (nrm .GT. Zero) THEN - R(:, i) = mv / nrm - END IF -END DO -IF (ALLOCATED(dp)) DEALLOCATE (dp) -IF (ALLOCATED(p)) DEALLOCATE (p) -IF (ALLOCATED(mv)) DEALLOCATE (mv) -IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) -END PROCEDURE getUnitNormal_2 - -!---------------------------------------------------------------------------- -! getUnitNormal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getUnitNormal_3 - !! -IF (val%rank .EQ. scalar) THEN - CALL scalar_getUnitNormal_3(obj=obj, r=r, val=val) -ELSEIF (val%rank .EQ. vector) THEN - CALL vector_getUnitNormal_3(obj=obj, r=r, val=val) -END IF - !! -CONTAINS - !! -PURE SUBROUTINE scalar_getUnitNormal_3(obj, r, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :) - TYPE(FEVariable_), INTENT(IN) :: val -! Define internal variables -REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) -INTEGER(I4B) :: ii -!! main -CALL getInterpolation(obj=obj, Val=val, Interpol=p) -CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) -CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2)) -pnorm = NORM2(dp, DIM=1) -!! -DO ii = 1, SIZE(p) - IF (pnorm(ii) .GT. zero) THEN - IF (p(ii) .GE. 0.0_DFP) THEN - R(:, ii) = dp(:, ii) / pnorm(ii) - ELSE - R(:, ii) = -dp(:, ii) / pnorm(ii) - END IF - END IF -END DO -!! -IF (ALLOCATED(dp)) DEALLOCATE (dp) -IF (ALLOCATED(p)) DEALLOCATE (p) -IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) -END SUBROUTINE scalar_getUnitNormal_3 - !! -PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :) - TYPE(FEVariable_), INTENT(IN) :: val -!! Define internal variables -REAL(DFP), ALLOCATABLE :: dp(:, :, :) -REAL(DFP), ALLOCATABLE :: p(:, :) -REAL(DFP), ALLOCATABLE :: mv(:) -REAL(DFP), ALLOCATABLE :: pnorm(:) -REAL(DFP) :: nrm -INTEGER(I4B) :: i -!! main -!! interpolate the vector -CALL getInterpolation(obj=obj, Interpol=p, Val=val) -!! get gradient of nodal values -CALL getSpatialGradient(obj=obj, lg=dp, Val=val) -pnorm = NORM2(p, DIM=1) -CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2)) -DO i = 1, SIZE(pnorm) - IF (pnorm(i) .GT. Zero) THEN - p(:, i) = p(:, i) / pnorm(i) - ELSE - p(:, i) = 1.0 - END IF - mv = MATMUL(p(:, i), dp(:, :, i)) - nrm = NORM2(mv) - IF (nrm .GT. Zero) THEN - R(:, i) = mv / nrm - END IF -END DO -IF (ALLOCATED(dp)) DEALLOCATE (dp) -IF (ALLOCATED(p)) DEALLOCATE (p) -IF (ALLOCATED(mv)) DEALLOCATE (mv) -IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) -END SUBROUTINE vector_getUnitNormal_3 - !! -END PROCEDURE getUnitNormal_3 - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 deleted file mode 100644 index 169aefe21..000000000 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 +++ /dev/null @@ -1,33 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(ElemShapeData_H1Methods) HermitMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- -MODULE PROCEDURE H1_Hermit1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="H1_Hermit1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE H1_Hermit1 - -END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 deleted file mode 100644 index 80d203300..000000000 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 +++ /dev/null @@ -1,127 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(ElemShapeData_H1Methods) HierarchyMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE H1_Hierarchy1 -REAL(DFP), ALLOCATABLE :: xij(:, :) -REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) -REAL(DFP), ALLOCATABLE :: N(:, :) -INTEGER(I4B) :: nsd, xidim - -CALL DEALLOCATE (obj) -CALL Initiate(obj%refelem, refelem) -nsd = refelem%nsd -xidim = refelem%xiDimension -CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws) -obj%quad = quad - -CALL ALLOCATE ( & - & obj=obj, & - & nsd=nsd, & - & xidim=xidim, & - & nns=LagrangeDOF(order=order, elemType=refelem%name), & - & nips=SIZE(quad, 2)) - -SELECT CASE (refelem%name) -CASE (Line) - N = HeirarchicalBasis_Line( & - & order=order, & - & xij=xij, & - & refLine=refelem%domainName) - - dNdXi = HeirarchicalGradientBasis_Line( & - & order=order, & - & xij=xij, & - & refLine=refelem%domainName) - -CASE (Triangle) - N = HeirarchicalBasis_Triangle( & - & order=order, & - & pe1=order, & - & pe2=order, & - & pe3=order, & - & xij=xij, & - & refTriangle=refelem%domainName) - - dNdXi = HeirarchicalBasisGradient_Triangle( & - & order=order, & - & pe1=order, & - & pe2=order, & - & pe3=order, & - & xij=xij, & - & refTriangle=refelem%domainName) - -CASE (Quadrangle) - N = HeirarchicalBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=xij) - - dNdXi = HeirarchicalBasisGradient_Quadrangle( & - & p=order, & - & q=order, & - & xij=xij) - -CASE (Tetrahedron) - N = HeirarchicalBasis_Tetrahedron( & - & order=order, & - & xij=xij, & - & refTetrahedron=refelem%domainName) - - dNdXi = HeirarchicalBasisGradient_Tetrahedron( & - & order=order, & - & xij=xij, & - & refTetrahedron=refelem%domainName) - -CASE (Hexahedron) - N = HeirarchicalBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=xij) - - dNdXi = HeirarchicalBasisGradient_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=xij) - -CASE DEFAULT - CALL Errormsg( & - & msg="[NO CASE FOUND] no case found for elemType", & - & unitno=stderr, & - & routine="H1_Hierarchy1()", & - & file=__FILE__, & - & line=__LINE__) -END SELECT - -obj%N = TRANSPOSE(N) -CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) - -IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) -IF (ALLOCATED(N)) DEALLOCATE (N) -IF (ALLOCATED(xij)) DEALLOCATE (xij) -END PROCEDURE H1_Hierarchy1 - -END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 deleted file mode 100644 index 39cc8ade3..000000000 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 +++ /dev/null @@ -1,133 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_H1Methods) LagrangeMethods -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE H1_Lagrange1 -REAL(DFP), ALLOCATABLE :: pt(:, :), xij(:, :), dNdXi(:, :, :), coeff0(:, :) -INTEGER(I4B) :: nsd, xidim, ipType0, basisType0 - -ipType0 = Input(default=Equidistance, option=ipType) -basisType0 = Input(default=Monomial, option=basisType) - -! CALL DEALLOCATE (obj) -CALL Initiate(obj%refelem, refelem) -nsd = refelem%nsd -xidim = refelem%xiDimension -CALL GetQuadraturePoints(obj=quad, points=pt, weights=obj%ws) -obj%quad = quad - -CALL ALLOCATE ( & - & obj=obj, & - & nsd=nsd, & - & xidim=xidim, & - & nns=LagrangeDOF(order=order, elemType=refelem%name), & - & nips=SIZE(quad, 2)) - -xij = InterpolationPoint( & - & order=order, & - & elemType=refelem%name, & - & ipType=ipType0, & - & layout="VEFC", & - & xij=refelem%xij(1:xidim, :), & - & alpha=alpha, beta=beta, lambda=lambda) - -CALL Reallocate(coeff0, SIZE(xij, 2), SIZE(xij, 2)) - -IF (PRESENT(coeff)) THEN - obj%N = TRANSPOSE(LagrangeEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff, & - & firstCall=firstCall)) - - dNdXi = LagrangeGradientEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff, & - & firstCall=.FALSE.) - - CALL SWAP( & - & a=obj%dNdXi, & - & b=dNdXi, & - & i1=2, i2=3, i3=1) - -ELSE - - obj%N = TRANSPOSE(LagrangeEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff0, & - & firstCall=.TRUE.)) - - dNdXi = LagrangeGradientEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff0, & - & firstCall=.FALSE.) - - CALL SWAP( & - & a=obj%dNdXi, & - & b=dNdXi, & - & i1=2, i2=3, i3=1) - -END IF - -IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) -IF (ALLOCATED(xij)) DEALLOCATE (xij) -IF (ALLOCATED(pt)) DEALLOCATE (pt) -IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0) - -END PROCEDURE H1_Lagrange1 - -END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 deleted file mode 100644 index f104a5c00..000000000 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 +++ /dev/null @@ -1,169 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_H1Methods) OrthogonalMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE H1_Orthogonal1 -REAL(DFP), ALLOCATABLE :: xij(:, :) -REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) -REAL(DFP), ALLOCATABLE :: N(:, :) -INTEGER(I4B) :: nsd, xidim, basisType0 - -basisType0 = Input(option=basisType, default=Legendre) -CALL DEALLOCATE (obj) -CALL Initiate(obj%refelem, refelem) -nsd = refelem%nsd -xidim = refelem%xiDimension -CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws) -obj%quad = quad - -CALL ALLOCATE ( & - & obj=obj, & - & nsd=nsd, & - & xidim=xidim, & - & nns=LagrangeDOF(order=order, elemType=refelem%name), & - & nips=SIZE(quad, 2)) - -SELECT CASE (refelem%name) -CASE (Line) - N = OrthogonalBasis_Line( & - & order=order, & - & xij=xij, & - & refLine=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, beta=beta, lambda=lambda) - - dNdXi = OrthogonalBasisGradient_Line( & - & order=order, & - & xij=xij, & - & refLine=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE (Triangle) - N = OrthogonalBasis_Triangle( & - & order=order, & - & xij=xij, & - & refTriangle=refelem%domainName) - - dNdXi = OrthogonalBasisGradient_Triangle( & - & order=order, & - & xij=xij, & - & refTriangle=refelem%domainName) - -CASE (Quadrangle) - N = OrthogonalBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=xij, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda1 = lambda, & - & lambda2 = lambda ) - - dNdXi = OrthogonalBasisGradient_Quadrangle( & - & p=order, & - & q=order, & - & xij=xij, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda1 = lambda, & - & lambda2 = lambda ) - -CASE (Tetrahedron) - N = OrthogonalBasis_Tetrahedron( & - & order=order, & - & xij=xij, & - & refTetrahedron=refelem%domainName) - - dNdXi = OrthogonalBasisGradient_Tetrahedron( & - & order=order, & - & xij=xij, & - & refTetrahedron=refelem%domainName) - -CASE (Hexahedron) - N = OrthogonalBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=xij, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & basisType3=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & lambda1 = lambda, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda2 = lambda, & - & alpha3 = alpha, & - & beta3 = beta, & - & lambda3 = lambda & - & ) - - dNdXi = OrthogonalBasisGradient_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=xij, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & basisType3=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & lambda1 = lambda, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda2 = lambda, & - & alpha3 = alpha, & - & beta3 = beta, & - & lambda3 = lambda & - & ) - -CASE DEFAULT - CALL Errormsg( & - & msg="[NO CASE FOUND] no case found for elemType", & - & unitno=stderr, & - & routine="H1_Hierarchy1()", & - & file=__FILE__, & - & line=__LINE__) -END SELECT - -obj%N = TRANSPOSE(N) -CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) - -IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) -IF (ALLOCATED(N)) DEALLOCATE (N) -IF (ALLOCATED(xij)) DEALLOCATE (xij) -END PROCEDURE H1_Orthogonal1 - -END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 deleted file mode 100644 index 79ed8bb3e..000000000 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_H1Methods) SerendipityMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE H1_Serendipity1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="H1_Serendipity()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE H1_Serendipity1 - -END SUBMODULE SerendipityMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 deleted file mode 100644 index be6cfd29a..000000000 --- a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_HCurlMethods) HermitMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HCurl_Hermit1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HCurl_Hermit1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HCurl_Hermit1 - -END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 deleted file mode 100644 index e468ebc6c..000000000 --- a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_HCurlMethods) HierarchyMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HCurl_Hierarchy1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HCurl_Hierarchy1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HCurl_Hierarchy1 - -END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 deleted file mode 100644 index 427af424f..000000000 --- a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_HCurlMethods) LagrangeMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HCurl_Lagrange1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HCurl_Lagrange1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HCurl_Lagrange1 - -END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 deleted file mode 100644 index b60ebdd09..000000000 --- a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_HCurlMethods) OrthogonalMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HCurl_Orthogonal1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HCurl_Orthogonal1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HCurl_Orthogonal1 - -END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 deleted file mode 100644 index cb555a1dd..000000000 --- a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_HCurlMethods) SerendipityMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HCurl_Serendipity1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HCurl_Serendipity1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HCurl_Serendipity1 - -END SUBMODULE SerendipityMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 deleted file mode 100644 index 7f48189b1..000000000 --- a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_HDivMethods) HermitMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HDiv_Hermit1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HDiv_Hermit1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HDiv_Hermit1 - -END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 deleted file mode 100644 index da0230faf..000000000 --- a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_HDivMethods) HierarchyMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HDiv_Hierarchy1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HDiv_Hierarchy1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HDiv_Hierarchy1 - -END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 deleted file mode 100644 index 6c0f64c3f..000000000 --- a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_HDivMethods) LagrangeMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HDiv_Lagrange1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HDiv_Lagrange1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HDiv_Lagrange1 - -END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 deleted file mode 100644 index 9474719f8..000000000 --- a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemshapeData_HDivMethods) OrthogonalMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HDiv_Orthogonal1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HDiv_Orthogonal1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HDiv_Orthogonal1 - -END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 deleted file mode 100644 index 84a972676..000000000 --- a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 +++ /dev/null @@ -1,35 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(ElemshapeData_HDivMethods) SerendipityMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HDiv_Serendipity1 -CALL Errormsg( & - & msg="[WORK IN PROGRESS] This method is currently not available", & - & line=__LINE__, & - & routine="HDiv_Serendipity1()", & - & unitno=stderr, & - & file=__FILE__) -END PROCEDURE HDiv_Serendipity1 - -END SUBMODULE SerendipityMethods diff --git a/src/submodules/FEMatrix/src/STCM/STCM_1.inc b/src/submodules/FEMatrix/src/STCM/STCM_1.inc deleted file mode 100644 index 9b977f48c..000000000 --- a/src/submodules/FEMatrix/src/STCM/STCM_1.inc +++ /dev/null @@ -1,111 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_1a(ans, test, trial, term1, term2, c, projecton) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! Convective velocity, it can be - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_dx - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & test(ipt)%T, & - & p(:, :, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - !! - DEALLOCATE (IaJb, p, realval) -END SUBROUTINE STCM_1a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_1b(ans, test, trial, term1, term2, c, projecton) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! Convective velocity, it can be - INTEGER(I4B), INTENT(IN) :: term1 - !! del_dx - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & p(:, :, ips), & - & trial(ipt)%N(:, ips), & - & trial(ipt)%T) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - !! - DEALLOCATE (IaJb, p, realval) -END SUBROUTINE STCM_1b diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt deleted file mode 100644 index ebcb11b22..000000000 --- a/src/submodules/FEVariable/CMakeLists.txt +++ /dev/null @@ -1,35 +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 -# - -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 -) 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@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 deleted file mode 100644 index 68d095928..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 +++ /dev/null @@ -1,107 +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) AdditionMethods - -USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & - Scalar, Vector, Matrix, & - Nodal, Quadrature -USE BaseType, ONLY: TypeFEVariableScalar, & - TypeFEVariableVector, & - TypeFEVariableMatrix, & - TypeFEVariableConstant, & - TypeFEVariableSpace, & - TypeFEVariableTime, & - TypeFEVariableSpaceTime - -USE ReallocateUtility, ONLY: Reallocate - -#define _OP_ + - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Addition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_addition1 -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) -INTEGER(I4B) :: jj, kk -SELECT CASE (obj1%rank) -CASE (scalar) - SELECT CASE (obj2%rank) - CASE (scalar) -#include "./include/ScalarOperatorScalar.F90" - CASE (vector) -#include "./include/ScalarOperatorVector.F90" - CASE (matrix) -#include "./include/ScalarOperatorMatrix.F90" - END SELECT -CASE (vector) - SELECT CASE (obj2%rank) - CASE (scalar) -#include "./include/VectorOperatorScalar.F90" - CASE (vector) -#include "./include/VectorOperatorVector.F90" - END SELECT -CASE (matrix) - SELECT CASE (obj2%rank) - CASE (scalar) -#include "./include/MatrixOperatorScalar.F90" - CASE (matrix) -#include "./include/MatrixOperatorMatrix.F90" - END SELECT -END SELECT -END PROCEDURE fevar_addition1 - -!---------------------------------------------------------------------------- -! Addition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_addition2 -SELECT CASE (obj1%rank) -CASE (scalar) -#include "./include/ScalarOperatorReal.F90" -CASE (vector) -#include "./include/VectorOperatorReal.F90" -CASE (matrix) -#include "./include/MatrixOperatorReal.F90" -END SELECT -END PROCEDURE fevar_addition2 - -!---------------------------------------------------------------------------- -! Addition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_addition3 -SELECT CASE (obj1%rank) -CASE (scalar) -#include "./include/RealOperatorScalar.F90" -CASE (vector) -#include "./include/RealOperatorVector.F90" -CASE (matrix) -#include "./include/RealOperatorMatrix.F90" -END SELECT -END PROCEDURE fevar_addition3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE AdditionMethods -#undef _OP_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 deleted file mode 100644 index 4cd019838..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,467 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(FEVariable_Method) ConstructorMethods -USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & - Time, SpaceTime, Nodal, Quadrature - -USE ReallocateUtility, ONLY: Reallocate - -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 -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 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Scalar_Constant -#define _DEFINEON_ Quadrature -#include "./include/scalar_constant.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Scalar_Constant - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Scalar_Space -#define _DEFINEON_ Quadrature -#include "./include/scalar_space.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Scalar_Space - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Scalar_Time -#define _DEFINEON_ Quadrature -#include "./include/scalar_time.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Scalar_Time - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Scalar_SpaceTime -#define _DEFINEON_ Quadrature -#include "./include/scalar_space_time.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Scalar_SpaceTime - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Scalar_SpaceTime2 -#define _DEFINEON_ Quadrature -#include "./include/scalar_space_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Scalar_SpaceTime2 - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Vector_Constant -#define _DEFINEON_ Quadrature -#include "./include/vector_constant.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Vector_Constant - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Vector_Space -#define _DEFINEON_ Quadrature -#include "./include/vector_space.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Vector_Space - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Vector_Space2 -#define _DEFINEON_ Quadrature -#include "./include/vector_space2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Vector_Space2 - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Vector_Time -#define _DEFINEON_ Quadrature -#include "./include/vector_time.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Vector_Time - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Vector_Time2 -#define _DEFINEON_ Quadrature -#include "./include/vector_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Vector_Time2 - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Vector_SpaceTime -#define _DEFINEON_ Quadrature -#include "./include/vector_space_time.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Vector_SpaceTime - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Vector_SpaceTime2 -#define _DEFINEON_ Quadrature -#include "./include/vector_space_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Vector_SpaceTime2 - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_Constant -#define _DEFINEON_ Quadrature -#include "./include/matrix_constant.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_Constant - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_Constant2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_constant2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_Constant2 - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_Space -#define _DEFINEON_ Quadrature -#include "./include/matrix_space.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_Space - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_Space2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_space2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_Space2 - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_Time -#define _DEFINEON_ Quadrature -#include "./include/matrix_time.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_Time - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_Time2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_Time2 - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_SpaceTime -#define _DEFINEON_ Quadrature -#include "./include/matrix_space_time.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_SpaceTime - -!---------------------------------------------------------------------------- -! QuadratureVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrature_Matrix_SpaceTime2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_space_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Quadrature_Matrix_SpaceTime2 - -!---------------------------------------------------------------------------- -! Copy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Copy -obj1%s = obj2%s -obj1%defineOn = obj2%defineOn -obj1%rank = obj2%rank -obj1%varType = obj2%varType -obj1%len = obj2%len - -IF (obj1%capacity .GE. obj1%len) THEN - obj1%val(1:obj1%len) = obj2%val(1:obj1%len) - RETURN -END IF - -obj1%capacity = CAPACITY_EXPAND_FACTOR * obj1%len -CALL Reallocate(obj1%val, obj1%capacity) -obj1%val(1:obj1%len) = obj2%val(1:obj1%len) - -END PROCEDURE obj_Copy - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE ConstructorMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 deleted file mode 100644 index 3046f33bf..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 +++ /dev/null @@ -1,129 +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) DivisionMethods -USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & - Scalar, Vector, Matrix, & - Nodal, Quadrature -USE BaseType, ONLY: TypeFEVariableScalar, & - TypeFEVariableVector, & - TypeFEVariableMatrix, & - TypeFEVariableConstant, & - TypeFEVariableSpace, & - TypeFEVariableTime, & - TypeFEVariableSpaceTime - -USE ReallocateUtility, ONLY: Reallocate - -#define _OP_ / - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! Division -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Division1 -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) -INTEGER(I4B) :: jj, kk -SELECT CASE (obj1%rank) - -CASE (scalar) - - SELECT CASE (obj2%rank) - - CASE (scalar) - -#include "./include/ScalarOperatorScalar.F90" - CASE (vector) - -#include "./include/ScalarOperatorVector.F90" - CASE (matrix) - -#include "./include/ScalarOperatorMatrix.F90" - END SELECT -CASE (vector) - - SELECT CASE (obj2%rank) - - CASE (scalar) - -#include "./include/VectorOperatorScalar.F90" - CASE (vector) - -#include "./include/VectorOperatorVector.F90" - END SELECT -CASE (matrix) - - SELECT CASE (obj2%rank) - - CASE (scalar) - -#include "./include/MatrixOperatorScalar.F90" - CASE (matrix) - -#include "./include/MatrixOperatorMatrix.F90" - END SELECT -END SELECT -END PROCEDURE fevar_Division1 - -!---------------------------------------------------------------------------- -! Division -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Division2 -SELECT CASE (obj1%rank) - -CASE (scalar) - -#include "./include/ScalarOperatorReal.F90" -CASE (vector) - -#include "./include/VectorOperatorReal.F90" -CASE (matrix) - -#include "./include/MatrixOperatorReal.F90" -END SELECT -END PROCEDURE fevar_Division2 - -!---------------------------------------------------------------------------- -! Division -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Division3 -SELECT CASE (obj1%rank) - -CASE (scalar) - -#include "./include/RealOperatorScalar.F90" -CASE (vector) - -#include "./include/RealOperatorVector.F90" -CASE (matrix) - -#include "./include/RealOperatorMatrix.F90" -END SELECT -END PROCEDURE fevar_Division3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#undef _OP_ -END SUBMODULE DivisionMethods 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@EqualMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 deleted file mode 100644 index d7e92e320..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 +++ /dev/null @@ -1,78 +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) EqualMethods -USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! NORM2 -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! NORM2 -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE EqualMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 deleted file mode 100644 index 93c5e0c55..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ /dev/null @@ -1,325 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(FEVariable_Method) GetMethods -USE ReallocateUtility, ONLY: Reallocate -USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & - Time, SpaceTime, Nodal, Quadrature -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetLambdaFromYoungsModulus -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_GetLambdaFromYoungsModulus -INTEGER(I4B) :: ii - -lambda = youngsModulus - -DO CONCURRENT(ii=1:lambda%len) - lambda%val(ii) = shearModulus%val(ii) * & - (youngsModulus%val(ii) - 2.0_DFP * shearModulus%val(ii)) / & - (3.0_DFP * shearModulus%val(ii) - youngsModulus%val(ii)) -END DO - -END PROCEDURE fevar_GetLambdaFromYoungsModulus - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Size -IF (PRESENT(dim)) THEN - ans = obj%s(dim) -ELSE - ans = obj%len -END IF -END PROCEDURE fevar_Size - -!---------------------------------------------------------------------------- -! Shape -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Shape -SELECT CASE (obj%rank) -CASE (Scalar) - SELECT CASE (obj%vartype) - CASE (Constant) - ans = [1] - CASE (Space, Time) - ans = obj%s(1:1) - CASE (SpaceTime) - ans = obj%s(1:2) - END SELECT -CASE (Vector) - SELECT CASE (obj%vartype) - CASE (Constant) - ans = obj%s(1:1) - CASE (Space, Time) - ans = obj%s(1:2) - CASE (SpaceTime) - ans = obj%s(1:3) - END SELECT -CASE (Matrix) - SELECT CASE (obj%vartype) - CASE (Constant) - ans = obj%s(1:2) - CASE (Space, Time) - ans = obj%s(1:3) - CASE (SpaceTime) - ans = obj%s(1:4) - END SELECT -END SELECT -END PROCEDURE fevar_Shape - -!---------------------------------------------------------------------------- -! rank -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_rank -ans = obj%rank -END PROCEDURE fevar_rank - -!---------------------------------------------------------------------------- -! vartype -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_vartype -ans = obj%vartype -END PROCEDURE fevar_vartype - -!---------------------------------------------------------------------------- -! defineon -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_defineon -ans = obj%defineon -END PROCEDURE fevar_defineon - -!---------------------------------------------------------------------------- -! isNodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_isNodalVariable -ans = obj%defineon .EQ. nodal -END PROCEDURE fevar_isNodalVariable - -!---------------------------------------------------------------------------- -! isNodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_isQuadratureVariable -ans = obj%defineon .NE. nodal -END PROCEDURE fevar_isQuadratureVariable - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Scalar_Constant -val = obj%val(1) -END PROCEDURE Scalar_Constant - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Scalar_Space -ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) -END PROCEDURE Scalar_Space - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Scalar_Time -ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) -END PROCEDURE Scalar_Time - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Scalar_SpaceTime -INTEGER(I4B) :: ii, jj, cnt - -ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - - END DO -END DO - -END PROCEDURE Scalar_SpaceTime - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Vector_Constant -ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) -END PROCEDURE Vector_Constant - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Vector_Space -INTEGER(I4B) :: ii, jj, cnt - -ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO - -END PROCEDURE Vector_Space - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Vector_Time -INTEGER(I4B) :: ii, jj, cnt - -ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO -END PROCEDURE Vector_Time - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Vector_SpaceTime -INTEGER(I4B) :: ii, jj, kk, cnt - -ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO -END PROCEDURE Vector_SpaceTime - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Matrix_Constant -INTEGER(I4B) :: ii, jj, cnt - -ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO -END PROCEDURE Matrix_Constant - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Matrix_Space -INTEGER(I4B) :: ii, jj, kk, cnt - -ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO -END PROCEDURE Matrix_Space - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Matrix_Time -INTEGER(I4B) :: ii, jj, kk, cnt - -ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO -END PROCEDURE Matrix_Time - -!---------------------------------------------------------------------------- -! getNodalvalues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Matrix_SpaceTime -INTEGER(I4B) :: ii, jj, kk, ll, cnt - -ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3), obj%s(4))) - -cnt = 0 -DO ll = 1, obj%s(4) - DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk, ll) = obj%val(cnt) - END DO - END DO - END DO -END DO -END PROCEDURE Matrix_SpaceTime - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE GetMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 deleted file mode 100644 index 3ca31c4e0..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 +++ /dev/null @@ -1,121 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(FEVariable_Method) IOMethods -USE Display_Method, ONLY: Util_Display => Display, ToString -USE GlobalData, ONLY: Scalar, Vector, Matrix, & - Constant, Space, Time, SpaceTime, Nodal, Quadrature -USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & - TypeFEVariableTime, TypeFEVariableSpaceTime, & - TypeFEVariableScalar, TypeFEVariableVector, & - TypeFEVariableMatrix -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Display -CALL Util_Display(msg, unitno=unitno) - -SELECT CASE (obj%rank) - -CASE (Scalar) - - CALL Util_Display("RANK :: 0 (Scalar)", unitno=unitno) - - SELECT CASE (obj%varType) - CASE (Constant) - CALL Util_Display("VarType: Constant", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), & - 'VALUE: ', unitno=unitno) - - CASE (Space) - CALL Util_Display("VarType: Space", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpace), & - 'VALUE: ', unitno=unitno) - CASE (Time) - CALL Util_Display("VarType: Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableTime), & - 'VALUE: ', unitno=unitno) - CASE (SpaceTime) - CALL Util_Display("VarType: Space & Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), & - 'VALUE: ', unitno=unitno) - - CASE DEFAULT - CALL Util_Display("VarType: UNKNOWN", unitno=unitno) - END SELECT - -CASE (Vector) - - CALL Util_Display("RANK :: 1 (Vector)", unitno=unitno) - SELECT CASE (obj%varType) - CASE (Constant) - CALL Util_Display("VarType: Constant", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableConstant), & - 'VALUE: ', unitno=unitno) - CASE (Space) - CALL Util_Display("VarType: Space", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpace), & - 'VALUE: ', unitno=unitno) - CASE (Time) - CALL Util_Display("VarType: Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableTime), & - 'VALUE: ', unitno=unitno) - CASE (SpaceTime) - CALL Util_Display("VarType: Space & Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime), & - 'VALUE: ', unitno=unitno) - - CASE DEFAULT - CALL Util_Display("VarType: UNKNOWN", unitno=unitno) - END SELECT - -CASE (Matrix) - - CALL Util_Display("RANK :: 2 (Matrix)", unitno=unitno) - SELECT CASE (obj%varType) - CASE (Constant) - CALL Util_Display("VarType: Constant", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableConstant), & - 'VALUE: ', unitno=unitno) - CASE (Space) - CALL Util_Display("VarType: Space", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpace), & - 'VALUE: ', unitno=unitno) - CASE (Time) - CALL Util_Display("VarType: Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableTime), & - 'VALUE: ', unitno=unitno) - CASE (SpaceTime) - CALL Util_Display("VarType: Space & Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpaceTime), & - 'VALUE: ', unitno=unitno) - - CASE DEFAULT - CALL Util_Display("VarType: UNKNOWN", unitno=unitno) - END SELECT - -CASE DEFAULT - CALL Util_Display("RANK: UNKNOWN", unitno=unitno) - -END SELECT -END PROCEDURE fevar_Display - -END SUBMODULE IOMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 deleted file mode 100644 index e136ab97b..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 +++ /dev/null @@ -1,181 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(FEVariable_Method) MeanMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Addition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Mean1 - REAL( DFP ) :: val0 - REAL( DFP ), ALLOCATABLE :: val1( : ), val2( :, : ) - !! - SELECT CASE (obj%rank) - !! - !! Scalar - !! - CASE (SCALAR) - !! - IF( obj%defineOn .EQ. NODAL ) THEN - ans = NodalVariable( MEAN( obj, TypeFEVariableScalar ), & - & TypeFEVariableScalar, & - & TypeFEVariableConstant ) - ELSE - ans = QuadratureVariable( MEAN( obj, TypeFEVariableScalar ), & - & TypeFEVariableScalar, & - & TypeFEVariableConstant ) - END IF - !! - !! Vector - !! - CASE (VECTOR) - !! - IF( obj%defineOn .EQ. NODAL ) THEN - ans = NodalVariable( MEAN( obj, TypeFEVariableVector ), & - & TypeFEVariableVector, & - & TypeFEVariableConstant ) - ELSE - ans = QuadratureVariable( MEAN( obj, TypeFEVariableVector ), & - & TypeFEVariableVector, & - & TypeFEVariableConstant ) - END IF - !! - CASE (MATRIX) - !! - IF( obj%defineOn .EQ. NODAL ) THEN - ans = NodalVariable( MEAN( obj, TypeFEVariableMatrix ), & - & TypeFEVariableMatrix, & - & TypeFEVariableConstant ) - ELSE - ans = QuadratureVariable( MEAN( obj, TypeFEVariableMatrix ), & - & TypeFEVariableMatrix, & - & TypeFEVariableConstant ) - END IF - !! - END SELECT - !! -END PROCEDURE fevar_Mean1 - -!---------------------------------------------------------------------------- -! Addition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Mean2 - REAL( DFP ) :: val0 - !! - ans = SUM( obj%val( : ) ) / SIZE( obj%val ) - !! -END PROCEDURE fevar_Mean2 - -!---------------------------------------------------------------------------- -! Addition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Mean3 - REAL( DFP ), ALLOCATABLE :: val2( :, : ), val3( :, :, : ) - INTEGER( I4B ) :: ii, jj - !! - CALL Reallocate( ans, obj%s(1) ) - !! - SELECT CASE( obj%varType ) - !! - CASE( Constant ) - !! - ans = obj%val( : ) - !! - CASE( Space, Time ) - !! - val2 = RESHAPE( obj%val, obj%s(1:2) ) - !! - DO ii = 1, obj%s(2) - ans = ans + val2( :, ii ) - END DO - !! - ans = ans / obj%s(2) - !! - CASE( SpaceTime ) - !! - val3 = RESHAPE( obj%val, obj%s(1:3) ) - DO jj = 1, obj%s(3) - DO ii = 1, obj%s(2) - ans = ans + val3( :, ii, jj ) - END DO - END DO - !! - ans = ans / obj%s(2) / obj%s(3) - !! - END SELECT - !! - IF( ALLOCATED( val2 ) ) DEALLOCATE( val2 ) - IF( ALLOCATED( val3 ) ) DEALLOCATE( val3 ) - !! -END PROCEDURE fevar_Mean3 - -!---------------------------------------------------------------------------- -! Addition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Mean4 - REAL( DFP ), ALLOCATABLE :: val3( :, :, : ), val4( :, :, :, : ) - INTEGER( I4B ) :: ii, jj - !! - CALL Reallocate( ans, obj%s(1), obj%s(2) ) - !! - SELECT CASE( obj%varType ) - !! - CASE( Constant ) - !! - ans = RESHAPE( obj%val, obj%s(1:2) ) - !! - CASE( Space, Time ) - !! - val3 = RESHAPE( obj%val, obj%s(1:3) ) - !! - DO ii = 1, obj%s(3) - ans = ans + val3( :, :, ii ) - END DO - !! - ans = ans / obj%s(3) - !! - CASE( SpaceTime ) - !! - val4 = RESHAPE( obj%val, obj%s(1:4) ) - !! - DO jj = 1, obj%s(4) - DO ii = 1, obj%s(3) - ans = ans + val4( :, :, ii, jj ) - END DO - END DO - !! - ans = ans / obj%s(3) / obj%s(4) - !! - END SELECT - !! - IF( ALLOCATED( val3 ) ) DEALLOCATE( val3 ) - IF( ALLOCATED( val4 ) ) DEALLOCATE( val4 ) - !! -END PROCEDURE fevar_Mean4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE MeanMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 deleted file mode 100644 index 610aad3cb..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 +++ /dev/null @@ -1,156 +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 _OP_ * - -SUBMODULE(FEVariable_Method) MultiplicationMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Multiplication -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Multiplication1 -!! -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) -INTEGER(I4B) :: jj, kk -!! -SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) - !! - SELECT CASE (obj2%rank) - !! scalar, scalar - CASE (scalar) -#include "./include/ScalarOperatorScalar.F90" - !! scalar, vector - CASE (vector) -#include "./include/ScalarOperatorVector.F90" - !! scalar, matrix - CASE (matrix) -#include "./include/ScalarOperatorMatrix.F90" - END SELECT -!! -!! -!! -!! -CASE (VECTOR) - !! - SELECT CASE (obj2%rank) - !! vector, scalar - CASE (scalar) -#include "./include/VectorOperatorScalar.F90" - !! vector, vector - CASE (vector) -#include "./include/VectorOperatorVector.F90" - END SELECT -!! -!! -!! -!! -CASE (MATRIX) - !! - SELECT CASE (obj2%rank) - CASE (scalar) - !! matrix, scalar -#include "./include/MatrixOperatorScalar.F90" - CASE (matrix) - !! matrix, matrix -#include "./include/MatrixOperatorMatrix.F90" - END SELECT -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE fevar_Multiplication1 - -!---------------------------------------------------------------------------- -! Multiplication -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Multiplication2 -SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) -#include "./include/ScalarOperatorReal.F90" -!! -!! -!! -!! -CASE (VECTOR) -#include "./include/VectorOperatorReal.F90" -!! -!! -!! -!! -CASE (MATRIX) -#include "./include/MatrixOperatorReal.F90" -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE fevar_Multiplication2 - -!---------------------------------------------------------------------------- -! Multiplication -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Multiplication3 -SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) -#include "./include/RealOperatorScalar.F90" -!! -!! -!! -!! -CASE (VECTOR) -#include "./include/RealOperatorVector.F90" -!! -!! -!! -!! -CASE (MATRIX) -#include "./include/RealOperatorMatrix.F90" -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE fevar_Multiplication3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE MultiplicationMethods -#undef _OP_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 deleted file mode 100644 index 0306feadb..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 +++ /dev/null @@ -1,136 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(FEVariable_Method) Norm2Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! NORM2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_norm2 -!! Internal variable -REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:,:), r3(:, :, :), m3(:,:,:) -INTEGER(I4B) :: jj, kk -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & NORM2(obj%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & NORM2(obj%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - r2 = GET(obj, TypeFEVariableVector, TypeFEVariableSpace) - CALL Reallocate(r1, size(r2,2)) - DO jj = 1, size(r1) - r1(jj) = NORM2(r2(:,jj)) - END DO - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r1, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & r1, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - r2 = GET(obj, TypeFEVariableVector, TypeFEVariableTime) - CALL Reallocate(r1, size(r2,2)) - DO jj = 1, size(r1) - r1(jj) = NORM2(r2(:,jj)) - END DO - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r1, & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & r1, & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - r3 = GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime) - CALL Reallocate( r2, size(r3,2), size(r3,3) ) - !! - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r2(jj, kk) = NORM2(r3(:, jj, kk)) - END DO - END DO - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF - !! -END SELECT -!! -!! -!! -!! -END PROCEDURE fevar_norm2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Norm2Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 deleted file mode 100644 index 1ae2c444a..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 +++ /dev/null @@ -1,47 +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) PowerMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE PowerMethods 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 3c098b459..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 +++ /dev/null @@ -1,51 +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 BaseMethod -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@SubtractionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 deleted file mode 100644 index ff3394e60..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 +++ /dev/null @@ -1,156 +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 _OP_ - - -SUBMODULE(FEVariable_Method) SubtractionMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Subtraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Subtraction1 -!! -REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) -INTEGER(I4B) :: jj, kk -!! -SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) - !! - SELECT CASE (obj2%rank) - !! scalar, scalar - CASE (scalar) -#include "./include/ScalarOperatorScalar.F90" - !! scalar, vector - CASE (vector) -#include "./include/ScalarOperatorVector.F90" - !! scalar, matrix - CASE (matrix) -#include "./include/ScalarOperatorMatrix.F90" - END SELECT -!! -!! -!! -!! -CASE (VECTOR) - !! - SELECT CASE (obj2%rank) - !! vector, scalar - CASE (scalar) -#include "./include/VectorOperatorScalar.F90" - !! vector, vector - CASE (vector) -#include "./include/VectorOperatorVector.F90" - END SELECT -!! -!! -!! -!! -CASE (MATRIX) - !! - SELECT CASE (obj2%rank) - CASE (scalar) - !! matrix, scalar -#include "./include/MatrixOperatorScalar.F90" - CASE (matrix) - !! matrix, matrix -#include "./include/MatrixOperatorMatrix.F90" - END SELECT -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE fevar_Subtraction1 - -!---------------------------------------------------------------------------- -! Subtraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Subtraction2 -SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) -#include "./include/ScalarOperatorReal.F90" -!! -!! -!! -!! -CASE (VECTOR) -#include "./include/VectorOperatorReal.F90" -!! -!! -!! -!! -CASE (MATRIX) -#include "./include/MatrixOperatorReal.F90" -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE fevar_Subtraction2 - -!---------------------------------------------------------------------------- -! Subtraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Subtraction3 -SELECT CASE (obj1%rank) -!! -!! -!! -!! -CASE (SCALAR) -#include "./include/RealOperatorScalar.F90" -!! -!! -!! -!! -CASE (VECTOR) -#include "./include/RealOperatorVector.F90" -!! -!! -!! -!! -CASE (MATRIX) -#include "./include/RealOperatorMatrix.F90" -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE fevar_Subtraction3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE SubtractionMethods -#undef _OP_ diff --git a/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 b/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 deleted file mode 100644 index 0f4640043..000000000 --- a/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 +++ /dev/null @@ -1,50 +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 - -SELECT CASE (obj%vartype) -CASE (constant) - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2)) - ELSE - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2)) - END IF -CASE (space) - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3)) - ELSE - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3)) - END IF -CASE (time) - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3)) - ELSE - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3)) - END IF -CASE (spacetime) - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4)) - ELSE - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4)) - END IF -END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 deleted file mode 100644 index 49ec28c4d..000000000 --- a/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 +++ /dev/null @@ -1,129 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - SELECT CASE (obj2%vartype) - CASE (constant) - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) - END IF - CASE (space) - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) - END DO - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) - ELSE - ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) - END IF - DEALLOCATE (r2, r3) - CASE (time) - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) - END DO - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) - END IF - DEALLOCATE (r2, r3) - CASE (spacetime) - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - r4 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r2(:, :) _OP_ r4(:, :, jj, kk) - END DO - END DO - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r4, TypeFEVariableMatrix, & - TypeFEVariableSpaceTime) - END IF - DEALLOCATE (r2, r4) - END SELECT -CASE (space) - SELECT CASE (obj2%vartype) - CASE (constant) - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) - r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) - END DO - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(r3, & - TypeFEVariableMatrix, TypeFEVariableSpace) - ELSE - ans = QuadratureVariable(r3, & - TypeFEVariableMatrix, TypeFEVariableSpace) - END IF - DEALLOCATE (r2, r3) - CASE (space) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) - END IF - END SELECT -CASE (time) - SELECT CASE (obj2%vartype) - CASE (constant) - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) - r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) - END DO - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(r3, & - TypeFEVariableMatrix, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(r3, & - TypeFEVariableMatrix, TypeFEVariableTime) - END IF - DEALLOCATE (r2, r3) - CASE (time) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) - END IF - END SELECT -CASE (spacetime) - SELECT CASE (obj2%vartype) - CASE (constant) - r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(:, :) - END DO - END DO - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(r4, & - TypeFEVariableMatrix, TypeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r4, & - TypeFEVariableMatrix, TypeFEVariableSpaceTime) - END IF - DEALLOCATE (r2, r4) - CASE (spacetime) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) - END IF - END SELECT -END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 deleted file mode 100644 index 74cb5c110..000000000 --- a/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 +++ /dev/null @@ -1,34 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) - END IF -CASE (space) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) - END IF -CASE (time) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) - END IF -CASE (spacetime) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) - END IF -END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 deleted file mode 100644 index 3b66f3643..000000000 --- a/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 +++ /dev/null @@ -1,164 +0,0 @@ -SELECT CASE (obj1%varType) - -CASE (constant) - - SELECT CASE (obj2%varType) - - CASE (constant) - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) - END IF - - CASE (space) - - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1)) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2 _OP_ obj2%val(jj) - END DO - - IF (obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) - ELSE - ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) - END IF - - DEALLOCATE (r2, r3) - CASE (time) - - r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1)) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r2 _OP_ obj2%val(jj) - END DO - - IF (obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) - END IF - - DEALLOCATE (r2, r3) - CASE (spacetime) - - r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime) - m2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) - CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2)) - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = m2 _OP_ r2(jj, kk) - END DO - - END DO - - IF (obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r4, TypeFEVariableMatrix, & - TypeFEVariableSpaceTime) - END IF - - DEALLOCATE (r2, r4, m2) - END SELECT - -CASE (space) - - SELECT CASE (obj1%varType) - - CASE (constant) - - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) - END IF - - CASE (space) - - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) - ELSE - ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) - END IF - - DEALLOCATE (r3) - END SELECT - -CASE (time) - - SELECT CASE (obj1%varType) - - CASE (constant) - - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) - END IF - - CASE (time) - - r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) - END IF - - DEALLOCATE (r3) - END SELECT - -CASE (spacetime) - - SELECT CASE (obj1%varType) - - CASE (constant) - - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) - END IF - - CASE (spacetime) - - r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime) - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(jj, kk) - END DO - - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r4, TypeFEVariableMatrix, & - TypeFEVariableSpaceTime) - END IF - - DEALLOCATE (r2, r4) - END SELECT - -END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixPower.F90 b/src/submodules/FEVariable/src/include/MatrixPower.F90 deleted file mode 100644 index 1d6c8f911..000000000 --- a/src/submodules/FEVariable/src/include/MatrixPower.F90 +++ /dev/null @@ -1,92 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & - & typeFEVariableMatrix, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & - & typeFEVariableMatrix, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF( obj%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & - & typeFEVariableMatrix, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 deleted file mode 100644 index 9295afd5d..000000000 --- a/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 +++ /dev/null @@ -1,34 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2)) - END IF -CASE (space) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3)) - END IF -CASE (time) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3)) - END IF -CASE (spacetime) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4)) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4)) - END IF -END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 deleted file mode 100644 index 6e0fbc67c..000000000 --- a/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 +++ /dev/null @@ -1,34 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1), & - TypeFEVariableScalar, TypeFEVariableConstant) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1), & - TypeFEVariableScalar, TypeFEVariableConstant) - END IF -CASE (space) - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableScalar, TypeFEVariableSpace) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableScalar, TypeFEVariableSpace) - END IF -CASE (time) - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableScalar, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableScalar, TypeFEVariableTime) - END IF -CASE (spacetime) - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - END IF -END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorVector.F90 b/src/submodules/FEVariable/src/include/RealOperatorVector.F90 deleted file mode 100644 index 69afa2912..000000000 --- a/src/submodules/FEVariable/src/include/RealOperatorVector.F90 +++ /dev/null @@ -1,43 +0,0 @@ -SELECT CASE (obj1%vartype) - -CASE (constant) - - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableVector, TypeFEVariableConstant) - ELSE - ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableVector, TypeFEVariableConstant) - END IF - -CASE (space) - - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & - TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & - TypeFEVariableVector, TypeFEVariableSpace) - END IF - -CASE (time) - - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & - TypeFEVariableVector, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & - TypeFEVariableVector, TypeFEVariableTime) - END IF - -CASE (spacetime) - - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), & - TypeFEVariableVector, TypeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), & - TypeFEVariableVector, TypeFEVariableSpaceTime) - END IF - -END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 b/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 deleted file mode 100644 index 47f10e592..000000000 --- a/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 +++ /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 -! -! -SELECT CASE (obj%vartype) -CASE (constant) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, & - typeFEVariableConstant) - RETURN - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, & - typeFEVariableConstant) -CASE (space) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableScalar, typeFEVariableSpace) - RETURN - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableScalar, typeFEVariableSpace) - -CASE (time) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableScalar, typeFEVariableTime) - RETURN - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableScalar, typeFEVariableTime) - -CASE (spacetime) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2)) - RETURN - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2)) -END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 deleted file mode 100644 index 3692e97ec..000000000 --- a/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 +++ /dev/null @@ -1,186 +0,0 @@ -SELECT CASE (obj1%vartype) - -CASE (constant) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2)) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2)) - - CASE (space) - - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3)) - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3)) - - CASE (time) - - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3)) - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3)) - - CASE (spacetime) - - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4)) - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4)) - - END SELECT - -CASE (space) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1)) - - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r2 - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) - DEALLOCATE (r2, r3) - RETURN - END IF - - ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) - DEALLOCATE (r2, r3) - - CASE (space) - - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) - - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) - DEALLOCATE (r3) - RETURN - END IF - - ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) - DEALLOCATE (r3) - - END SELECT - -CASE (time) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1)) - - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r2 - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime) - DEALLOCATE (r2, r3) - RETURN - END IF - - ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime) - DEALLOCATE (r2, r3) - - CASE (time) - - r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) - DO jj = 1, SIZE(r3, 3) - r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime) - DEALLOCATE (r3) - RETURN - END IF - - ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime) - DEALLOCATE (r3) - - END SELECT - -CASE (spacetime) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - m2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) - CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2)) - - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r2(jj, kk) _OP_ m2 - END DO - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r4, typeFEVariableMatrix, typeFEVariableSpaceTime) - DEALLOCATE (r2, m2, r4) - RETURN - END IF - - ans = QuadratureVariable(r4, typeFEVariableMatrix, & - typeFEVariableSpaceTime) - - DEALLOCATE (r2, m2, r4) - - CASE (spacetime) - - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - r4 = GET(obj2, typeFEVariableMatrix, typeFEVariableSpaceTime) - - DO kk = 1, SIZE(r4, 4) - DO jj = 1, SIZE(r4, 3) - r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:, :, jj, kk) - END DO - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r4, typeFEVariableMatrix, & - typeFEVariableSpaceTime) - DEALLOCATE (r2, r4) - RETURN - END IF - - ans = QuadratureVariable(r4, typeFEVariableMatrix, & - typeFEVariableSpaceTime) - DEALLOCATE (r2, r4) - - END SELECT - -END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 deleted file mode 100644 index fa3e91c56..000000000 --- a/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 +++ /dev/null @@ -1,34 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableConstant) - ELSE - ans = QuadratureVariable(obj1%val(1) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableConstant) - END IF -CASE (space) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableSpace) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableSpace) - END IF -CASE (time) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableTime) - END IF -CASE (spacetime) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - END IF -END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 deleted file mode 100644 index 8e121f01d..000000000 --- a/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 +++ /dev/null @@ -1,148 +0,0 @@ -SELECT CASE (obj1%vartype) - -CASE (constant) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - IF (obj1%defineon .EQ. Nodal) THEN - - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableConstant) - - RETURN - - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableConstant) - - CASE (space) - - IF (obj2%defineon .EQ. Nodal) THEN - - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpace) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpace) - - CASE (time) - - IF (obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableTime) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableTime) - - CASE (spacetime) - - IF (obj2%defineon .EQ. Nodal) THEN - - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2)) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2)) - - END SELECT - -CASE (space) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - IF (obj1%defineon .EQ. Nodal) THEN - - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableSpace) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableSpace) - - CASE (space) - - IF (obj1%defineon .EQ. Nodal) THEN - - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpace) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpace) - - END SELECT - -CASE (time) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - IF (obj1%defineon .EQ. Nodal) THEN - - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableTime) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableTime) - - CASE (time) - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableTime) - RETURN - END IF - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableTime) - - END SELECT - -CASE (spacetime) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - RETURN - END IF - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - - CASE (spacetime) - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - RETURN - END IF - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) - - END SELECT - -END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 deleted file mode 100644 index 594629b64..000000000 --- a/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 +++ /dev/null @@ -1,180 +0,0 @@ -SELECT CASE (obj1%vartype) - -CASE (constant) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableConstant) - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableConstant) - CASE (space) - - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2)) - - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2)) - CASE (time) - - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableTime, obj2%s(1:2)) - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableTime, obj2%s(1:2)) - - CASE (spacetime) - - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3)) - RETURN - END IF - - ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3)) - - END SELECT - -CASE (space) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - CALL Reallocate(r2, obj2%s(1), obj1%s(1)) - - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) - RETURN - END IF - - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - - CASE (space) - - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) - - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) - DEALLOCATE (r2) - RETURN - END IF - - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - DEALLOCATE (r2) - - END SELECT - -CASE (time) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - CALL Reallocate(r2, obj2%s(1), obj1%s(1)) - - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) - DEALLOCATE (r2) - RETURN - END IF - - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) - DEALLOCATE (r2) - - CASE (time) - - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) - - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) - DEALLOCATE (r2) - RETURN - END IF - - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) - DEALLOCATE (r2) - - END SELECT - -CASE (spacetime) - - SELECT CASE (obj2%vartype) - - CASE (constant) - - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - CALL Reallocate(r3, obj2%s(1), SIZE(r2, 1), SIZE(r2, 2)) - - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(1:obj2%len) - END DO - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) - DEALLOCATE (r2, r3) - - RETURN - END IF - - ans = QuadratureVariable(r3, typeFEVariableVector, & - typeFEVariableSpaceTime) - - DEALLOCATE (r2, r3) - - CASE (spacetime) - r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) - r3 = GET(obj2, typeFEVariableVector, typeFEVariableSpaceTime) - - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:, jj, kk) - END DO - END DO - - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) - DEALLOCATE (r2, r3) - RETURN - END IF - - ans = QuadratureVariable(r3, typeFEVariableVector, & - typeFEVariableSpaceTime) - - DEALLOCATE (r2, r3) - - END SELECT - -END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarPower.F90 b/src/submodules/FEVariable/src/include/ScalarPower.F90 deleted file mode 100644 index 48f45c3dc..000000000 --- a/src/submodules/FEVariable/src/include/ScalarPower.F90 +++ /dev/null @@ -1,42 +0,0 @@ -SELECT CASE (obj%vartype) - -CASE (constant) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(obj%val(1)**n, & - TypeFEVariableScalar, TypeFEVariableConstant) - ELSE - ans = QuadratureVariable(obj%val(1)**n, & - TypeFEVariableScalar, TypeFEVariableConstant) - END IF - -CASE (space) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(obj%val(1:obj%len)**n, & - TypeFEVariableScalar, TypeFEVariableSpace) - ELSE - ans = QuadratureVariable(obj%val(1:obj%len)**n, & - TypeFEVariableScalar, TypeFEVariableSpace) - END IF - -CASE (time) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(obj%val(1:obj%len)**n, & - TypeFEVariableScalar, TypeFEVariableTime) - ELSE - ans = QuadratureVariable(obj%val(1:obj%len)**n, & - TypeFEVariableScalar, TypeFEVariableTime) - END IF - -CASE (spacetime) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(obj%val(1:obj%len)**n, & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2)) - ELSE - ans = QuadratureVariable(obj%val(1:obj%len)**n, & - TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2)) - END IF -END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorElemMethod.F90 b/src/submodules/FEVariable/src/include/VectorElemMethod.F90 deleted file mode 100644 index 8dbc238b0..000000000 --- a/src/submodules/FEVariable/src/include/VectorElemMethod.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 -! -SELECT CASE (obj%vartype) -CASE (constant) - - IF (obj%defineon .EQ. nodal) THEN - - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableConstant) - - RETURN - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableConstant) - -CASE (space) - - IF (obj%defineon .EQ. nodal) THEN - - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableSpace, obj%s(1:2)) - RETURN - - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableSpace, obj%s(1:2)) - -CASE (time) - - IF (obj%defineon .EQ. nodal) THEN - - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableTime, obj%s(1:2)) - - RETURN - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableTime, obj%s(1:2)) - -CASE (spacetime) - - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3)) - RETURN - END IF - - ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & - typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3)) - -END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 deleted file mode 100644 index 0aa58c55c..000000000 --- a/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 +++ /dev/null @@ -1,34 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableConstant) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableConstant) - END IF -CASE (space) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) - END IF -CASE (time) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2)) - END IF -CASE (spacetime) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & - TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3)) - END IF -END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 deleted file mode 100644 index 74b2a8ad8..000000000 --- a/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 +++ /dev/null @@ -1,120 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - SELECT CASE (obj2%vartype) - CASE (constant) - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableConstant) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableConstant) - END IF - CASE (space) - CALL Reallocate(r2, obj1%s(1), obj2%s(1)) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj) - END DO - IF (obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) - ELSE - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - END IF - DEALLOCATE (r2) - CASE (time) - CALL Reallocate(r2, obj1%s(1), obj2%s(1)) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj) - END DO - IF (obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) - ELSE - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) - END IF - DEALLOCATE (r2) - CASE (spacetime) - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - CALL Reallocate(r3, obj1%s(1), SIZE(r2, 1), SIZE(r2, 2)) - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r2(jj, kk) - END DO - END DO - IF (obj2%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r3, typeFEVariableVector, & - typeFEVariableSpaceTime) - END IF - DEALLOCATE (r2, r3) - END SELECT -CASE (space) - SELECT CASE (obj1%vartype) - CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) - END IF - CASE (space) - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) - END DO - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) - ELSE - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) - END IF - DEALLOCATE (r2) - END SELECT -CASE (time) - SELECT CASE (obj1%vartype) - CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) - END IF - CASE (time) - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) - END DO - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) - ELSE - ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) - END IF - DEALLOCATE (r2) - END SELECT -CASE (spacetime) - SELECT CASE (obj1%vartype) - CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & - typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) - END IF - CASE (spacetime) - r3 = GET(obj1, typeFEVariableVector, typeFEVariableSpaceTime) - r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r3(:, jj, kk) _OP_ r2(jj, kk) - END DO - END DO - IF (obj1%defineon .EQ. Nodal) THEN - ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r3, typeFEVariableVector, & - typeFEVariableSpaceTime) - END IF - DEALLOCATE (r2, r3) - END SELECT -END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 deleted file mode 100644 index 32e88ebf9..000000000 --- a/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 +++ /dev/null @@ -1,130 +0,0 @@ -SELECT CASE (obj1%vartype) -CASE (constant) - SELECT CASE (obj2%vartype) - CASE (constant) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableConstant) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableConstant) - END IF - CASE (space) - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj) - END DO - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(r2, & - typeFEVariableVector, typeFEVariableSpace) - ELSE - ans = QuadratureVariable(r2, & - typeFEVariableVector, typeFEVariableSpace) - END IF - DEALLOCATE (r2) - CASE (time) - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj) - END DO - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(r2, & - typeFEVariableVector, typeFEVariableTime) - ELSE - ans = QuadratureVariable(r2, & - typeFEVariableVector, typeFEVariableTime) - END IF - DEALLOCATE (r2) - CASE (spacetime) - r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r3(:, jj, kk) - END DO - END DO - IF (obj2%defineon .EQ. nodal) THEN - ans = NodalVariable(r3, & - typeFEVariableVector, typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r3, & - typeFEVariableVector, typeFEVariableSpaceTime) - END IF - DEALLOCATE (r3) - - END SELECT -CASE (space) - SELECT CASE (obj2%vartype) - CASE (constant) - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len) - END DO - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(r2, & - typeFEVariableVector, typeFEVariableSpace) - ELSE - ans = QuadratureVariable(r2, & - typeFEVariableVector, typeFEVariableSpace) - END IF - DEALLOCATE (r2) - CASE (space) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) - END IF - END SELECT -CASE (time) - SELECT CASE (obj2%vartype) - CASE (constant) - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - DO jj = 1, SIZE(r2, 2) - r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len) - END DO - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(r2, & - typeFEVariableVector, typeFEVariableTime) - ELSE - ans = QuadratureVariable(r2, & - typeFEVariableVector, typeFEVariableTime) - END IF - CASE (time) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) - END IF - END SELECT -CASE (spacetime) - SELECT CASE (obj2%vartype) - CASE (constant) - r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(1:obj2%len) - END DO - END DO - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(r3, & - typeFEVariableVector, typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(r3, & - typeFEVariableVector, typeFEVariableSpaceTime) - END IF - DEALLOCATE (r3) - - CASE (spacetime) - IF (obj1%defineon .EQ. nodal) THEN - ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) - ELSE - ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & - typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) - END IF - END SELECT - -END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorPower.F90 b/src/submodules/FEVariable/src/include/VectorPower.F90 deleted file mode 100644 index 83bc64b8d..000000000 --- a/src/submodules/FEVariable/src/include/VectorPower.F90 +++ /dev/null @@ -1,93 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! main -!! -SELECT CASE (obj%vartype) -!! -!! -!! -!! -CASE (constant) - !! - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable( & - & obj%val(:)**n, & - & typeFEVariableVector, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & obj%val(:)**n, & - & typeFEVariableVector, & - & typeFEVariableConstant) - END IF -!! -!! -!! -!! -CASE (space) - !! - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:)**n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:)**n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableSpace) - END IF -!! -!! -!! -!! -CASE (time) - !! - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable( & - & RESHAPE(obj%val(:)**n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & RESHAPE(obj%val(:)**n, obj%s(1:2)), & - & typeFEVariableVector, & - & typeFEVariableTime) - END IF -!! -!! -!! -!! -CASE (spacetime) - !! - IF (obj%defineon .EQ. nodal) THEN - ans = NodalVariable(& - & RESHAPE(obj%val(:)**n, obj%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & RESHAPE(obj%val(:)**n, obj%s(1:3)), & - & typeFEVariableVector, & - & typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT diff --git a/src/submodules/FEVariable/src/include/matrix_constant.F90 b/src/submodules/FEVariable/src/include/matrix_constant.F90 deleted file mode 100644 index bb2d804b9..000000000 --- a/src/submodules/FEVariable/src/include/matrix_constant.F90 +++ /dev/null @@ -1,19 +0,0 @@ -INTEGER(I4B) :: ii, jj, cnt - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -cnt = 0 - -DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - cnt = cnt + 1 - obj%val(cnt) = val(ii, jj) - END DO -END DO - -obj%s(1:2) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/matrix_constant2.F90 b/src/submodules/FEVariable/src/include/matrix_constant2.F90 deleted file mode 100644 index 062b751b9..000000000 --- a/src/submodules/FEVariable/src/include/matrix_constant2.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:2) = s(1:2) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/matrix_space.F90 b/src/submodules/FEVariable/src/include/matrix_space.F90 deleted file mode 100644 index 0cd267920..000000000 --- a/src/submodules/FEVariable/src/include/matrix_space.F90 +++ /dev/null @@ -1,21 +0,0 @@ -INTEGER(I4B) :: ii, jj, kk, cnt - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -cnt = 0 - -DO kk = 1, SIZE(val, 3) - DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - cnt = cnt + 1 - obj%val(cnt) = val(ii, jj, kk) - END DO - END DO -END DO - -obj%s(1:3) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/matrix_space2.F90 b/src/submodules/FEVariable/src/include/matrix_space2.F90 deleted file mode 100644 index d9cd89b84..000000000 --- a/src/submodules/FEVariable/src/include/matrix_space2.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:3) = s(1:3) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/matrix_space_time.F90 b/src/submodules/FEVariable/src/include/matrix_space_time.F90 deleted file mode 100644 index 3a6463630..000000000 --- a/src/submodules/FEVariable/src/include/matrix_space_time.F90 +++ /dev/null @@ -1,23 +0,0 @@ -INTEGER(I4B) :: ii, jj, kk, ll, cnt - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -cnt = 0 - -DO ll = 1, SIZE(val, 4) - DO kk = 1, SIZE(val, 3) - DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - cnt = cnt + 1 - obj%val(cnt) = val(ii, jj, kk, ll) - END DO - END DO - END DO -END DO - -obj%s(1:4) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 deleted file mode 100644 index 416f4d703..000000000 --- a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:4) = s(1:4) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/matrix_time.F90 b/src/submodules/FEVariable/src/include/matrix_time.F90 deleted file mode 100644 index a4b831d86..000000000 --- a/src/submodules/FEVariable/src/include/matrix_time.F90 +++ /dev/null @@ -1,21 +0,0 @@ -INTEGER(I4B) :: ii, jj, kk, cnt - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -cnt = 0 - -DO kk = 1, SIZE(val, 3) - DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - cnt = cnt + 1 - obj%val(cnt) = val(ii, jj, kk) - END DO - END DO -END DO - -obj%s(1:3) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = Time diff --git a/src/submodules/FEVariable/src/include/matrix_time2.F90 b/src/submodules/FEVariable/src/include/matrix_time2.F90 deleted file mode 100644 index aaa1007bb..000000000 --- a/src/submodules/FEVariable/src/include/matrix_time2.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:3) = s(1:3) -obj%defineOn = _DEFINEON_ -obj%rank = Matrix -obj%varType = Time diff --git a/src/submodules/FEVariable/src/include/scalar_constant.F90 b/src/submodules/FEVariable/src/include/scalar_constant.F90 deleted file mode 100644 index 628f7a7b6..000000000 --- a/src/submodules/FEVariable/src/include/scalar_constant.F90 +++ /dev/null @@ -1,8 +0,0 @@ -obj%len = 1 -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) -obj%val(1) = val -obj%s(1) = 1 -obj%defineOn = _DEFINEON_ -obj%rank = Scalar -obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/scalar_space.F90 b/src/submodules/FEVariable/src/include/scalar_space.F90 deleted file mode 100644 index c43d15d52..000000000 --- a/src/submodules/FEVariable/src/include/scalar_space.F90 +++ /dev/null @@ -1,8 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) -obj%val(1:obj%len) = val -obj%s(1) = SIZE(val) -obj%defineOn = _DEFINEON_ -obj%rank = SCALAR -obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/scalar_space_time.F90 b/src/submodules/FEVariable/src/include/scalar_space_time.F90 deleted file mode 100644 index 75ee2a726..000000000 --- a/src/submodules/FEVariable/src/include/scalar_space_time.F90 +++ /dev/null @@ -1,18 +0,0 @@ -INTEGER(I4B) :: ii, jj, kk - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -kk = 0 -DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - kk = kk + 1 - obj%val(kk) = val(ii, jj) - END DO -END DO - -obj%s(1:2) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = SCALAR -obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 deleted file mode 100644 index e85818d99..000000000 --- a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 +++ /dev/null @@ -1,12 +0,0 @@ -INTEGER(I4B) :: ii - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:2) = s(1:2) -obj%defineOn = _DEFINEON_ -obj%rank = SCALAR -obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/scalar_time.F90 b/src/submodules/FEVariable/src/include/scalar_time.F90 deleted file mode 100644 index 1a7b0d3e3..000000000 --- a/src/submodules/FEVariable/src/include/scalar_time.F90 +++ /dev/null @@ -1,8 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) -obj%val(1:obj%len) = val -obj%s(1) = SIZE(val) -obj%defineOn = _DEFINEON_ -obj%rank = SCALAR -obj%varType = Time diff --git a/src/submodules/FEVariable/src/include/vector_constant.F90 b/src/submodules/FEVariable/src/include/vector_constant.F90 deleted file mode 100644 index 42125ac15..000000000 --- a/src/submodules/FEVariable/src/include/vector_constant.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len - -ALLOCATE (obj%val(obj%capacity)) -obj%val(1:obj%len) = val - -obj%s(1:1) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Vector -obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/vector_space.F90 b/src/submodules/FEVariable/src/include/vector_space.F90 deleted file mode 100644 index 2d6a663ef..000000000 --- a/src/submodules/FEVariable/src/include/vector_space.F90 +++ /dev/null @@ -1,18 +0,0 @@ -INTEGER(I4B) :: ii, jj, cnt - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -cnt = 0 -DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - cnt = cnt + 1 - obj%val(cnt) = val(ii, jj) - END DO -END DO - -obj%s(1:2) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Vector -obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/vector_space2.F90 b/src/submodules/FEVariable/src/include/vector_space2.F90 deleted file mode 100644 index a2e7c5cbf..000000000 --- a/src/submodules/FEVariable/src/include/vector_space2.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:2) = s(1:2) -obj%defineOn = _DEFINEON_ -obj%rank = Vector -obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/vector_space_time.F90 b/src/submodules/FEVariable/src/include/vector_space_time.F90 deleted file mode 100644 index e8ee7a797..000000000 --- a/src/submodules/FEVariable/src/include/vector_space_time.F90 +++ /dev/null @@ -1,21 +0,0 @@ -INTEGER(I4B) :: ii, jj, kk, cnt - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -cnt = 0 - -DO kk = 1, SIZE(val, 3) - DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - cnt = cnt + 1 - obj%val(cnt) = val(ii, jj, kk) - END DO - END DO -END DO - -obj%s(1:3) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Vector -obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/vector_space_time2.F90 b/src/submodules/FEVariable/src/include/vector_space_time2.F90 deleted file mode 100644 index a671d1408..000000000 --- a/src/submodules/FEVariable/src/include/vector_space_time2.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:3) = s(1:3) -obj%defineOn = _DEFINEON_ -obj%rank = Vector -obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/vector_time.F90 b/src/submodules/FEVariable/src/include/vector_time.F90 deleted file mode 100644 index 7cc4a4a7f..000000000 --- a/src/submodules/FEVariable/src/include/vector_time.F90 +++ /dev/null @@ -1,18 +0,0 @@ -INTEGER(I4B) :: ii, jj, cnt - -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -cnt = 0 -DO jj = 1, SIZE(val, 2) - DO ii = 1, SIZE(val, 1) - cnt = cnt + 1 - obj%val(cnt) = val(ii, jj) - END DO -END DO - -obj%s(1:2) = SHAPE(val) -obj%defineOn = _DEFINEON_ -obj%rank = Vector -obj%varType = TIME diff --git a/src/submodules/FEVariable/src/include/vector_time2.F90 b/src/submodules/FEVariable/src/include/vector_time2.F90 deleted file mode 100644 index b3e52b512..000000000 --- a/src/submodules/FEVariable/src/include/vector_time2.F90 +++ /dev/null @@ -1,10 +0,0 @@ -obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len -ALLOCATE (obj%val(obj%capacity)) - -obj%val(1:obj%len) = val(1:obj%len) - -obj%s(1:2) = s(1:2) -obj%defineOn = _DEFINEON_ -obj%rank = Vector -obj%varType = TIME diff --git a/src/submodules/FacetMatrix/CMakeLists.txt b/src/submodules/FacetMatrix/CMakeLists.txt deleted file mode 100644 index 4cb301a8c..000000000 --- a/src/submodules/FacetMatrix/CMakeLists.txt +++ /dev/null @@ -1,32 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FacetMatrix_Method@FacetMatrix1Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix2Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix3Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix4Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix5Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix11Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix12Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix13Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix14Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix15Methods.F90 - ${src_path}/FacetMatrix_Method@FacetMatrix21Methods.F90 -) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 deleted file mode 100644 index b9cf81703..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 +++ /dev/null @@ -1,306 +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(FacetMatrix_Method) FacetMatrix11Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix11_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns = nns1 + nns2 - nsd = masterElemSD%refelem%nsd - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - ans = ans + & - & realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - !! - END DO - !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1 ) - !! -END PROCEDURE FacetMatrix11_1 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix11_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), slaveC1(:,:), & - & C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - masterC1 = masterC1 * muMaster - slaveC1 = slaveC1 * muSlave - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - !! - END DO - !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1 ) - !! -END PROCEDURE FacetMatrix11_2 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix11_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), taubar( : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) - !! - masterC1 = masterC1 * muMaster - slaveC1 = slaveC1 * muSlave - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * & - & taubar - !! - DO ips = 1, nips - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - !! - DEALLOCATE( realval, masterC1, slaveC1, taubar, C1 ) - !! -END PROCEDURE FacetMatrix11_3 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix11_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & muMasterBar( : ), muSlaveBar( : ), slaveC1( :, : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1, muMasterBar, muSlaveBar ) - !! -END PROCEDURE FacetMatrix11_4 - -!---------------------------------------------------------------------------- -! FacetMatrix11 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix11_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & muMasterBar( : ), muSlaveBar( : ), tauBar( : ), slaveC1( :, : ), & - & C1(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauBar, & - & val=tauvar ) - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO - !! - realval = masterElemSD%js*masterElemSD%ws*masterElemSD%thickness*tauBar - !! - DO ips = 1, nips - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - !! - DEALLOCATE( realval, masterC1, slaveC1, muMasterBar, & - & muSlaveBar, C1 ) - !! -END PROCEDURE FacetMatrix11_5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE FacetMatrix11Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 deleted file mode 100644 index 85cd9bb10..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 +++ /dev/null @@ -1,157 +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(FacetMatrix_Method) FacetMatrix12Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix12_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns, nsd - !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal ) - realval = elemsd%js * elemsd%ws * elemsd%thickness - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1 ) - !! -END PROCEDURE FacetMatrix12_1 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix12_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns, nsd - !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal ) - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1 ) - !! -END PROCEDURE FacetMatrix12_2 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix12_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), taubar( : ) - INTEGER( I4B ) :: ips, nips, nns, nsd - !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal ) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1, taubar ) - !! -END PROCEDURE FacetMatrix12_3 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix12_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), muBar( : ) - INTEGER( I4B ) :: ips, nips, nns, nsd - !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) - realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1, muBar ) - !! -END PROCEDURE FacetMatrix12_4 - -!---------------------------------------------------------------------------- -! FacetMatrix12 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix12_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), & - & muBar( : ), tauBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns, nsd - !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) - CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar ) - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1, muBar ) - !! -END PROCEDURE FacetMatrix12_5 - -END SUBMODULE FacetMatrix12Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 deleted file mode 100644 index 124c1dc20..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 +++ /dev/null @@ -1,276 +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(FacetMatrix_Method) FacetMatrix13Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix13_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1 ) - !! -END PROCEDURE FacetMatrix13_1 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix13_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1 ) - !! -END PROCEDURE FacetMatrix13_2 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix13_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, taubar ) - !! -END PROCEDURE FacetMatrix13_3 - - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix13_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, mubar ) - !! -END PROCEDURE FacetMatrix13_4 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix13_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, mubar, taubar ) - !! -END PROCEDURE FacetMatrix13_5 - -END SUBMODULE FacetMatrix13Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 deleted file mode 100644 index 805bf3938..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 +++ /dev/null @@ -1,276 +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(FacetMatrix_Method) FacetMatrix14Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix14_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1 ) - !! -END PROCEDURE FacetMatrix14_1 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix14_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1 ) - !! -END PROCEDURE FacetMatrix14_2 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix14_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, taubar ) - !! -END PROCEDURE FacetMatrix14_3 - - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix14_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, mubar ) - !! -END PROCEDURE FacetMatrix14_4 - -!---------------------------------------------------------------------------- -! FacetMatrix14 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix14_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, mubar, taubar ) - !! -END PROCEDURE FacetMatrix14_5 - -END SUBMODULE FacetMatrix14Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 deleted file mode 100644 index 45b5cddd3..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 +++ /dev/null @@ -1,501 +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(FacetMatrix_Method) FacetMatrix15Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix15_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) - !! - C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) - !! -END PROCEDURE FacetMatrix15_1 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix15_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) - !! - C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) - !! -END PROCEDURE FacetMatrix15_2 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix15_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) - !! - C2(1:nns1, :, ips)=(0.5_DFP*tauMaster)*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=(0.5_DFP*tauSlave)*slaveElemSD%dNdXt(:, :, slaveips) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) - !! -END PROCEDURE FacetMatrix15_3 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix15_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) - !! - C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, muMasterBar, & - & muSlaveBar ) - !! -END PROCEDURE FacetMatrix15_4 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix15_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & tauMasterBar( : ), tauSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) - !! - C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) & - & *slaveElemSD%dNdXt(:, :, slaveips) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & - & tauSlaveBar ) - !! -END PROCEDURE FacetMatrix15_5 - -!---------------------------------------------------------------------------- -! FacetMatrix15 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix15_6 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & tauMasterBar( : ), tauSlaveBar( : ), muMasterBar( : ), & - & muSlaveBar( : ), C( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) - !! - C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) & - & *slaveElemSD%dNdXt(:, :, slaveips) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & - & tauSlaveBar, muMasterBar, muSlaveBar ) - !! -END PROCEDURE FacetMatrix15_6 - -END SUBMODULE FacetMatrix15Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 deleted file mode 100644 index eb6aed951..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 +++ /dev/null @@ -1,373 +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(FacetMatrix_Method) FacetMatrix1Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix1_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) - !! - i3 = eye( nsd ) - !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 ) - !! -END PROCEDURE FacetMatrix1_1 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix1_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) - !! - i3 = eye( nsd ) - !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = muMaster*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = muSlave*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 ) - !! -END PROCEDURE FacetMatrix1_2 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix1_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & - & taubar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) - !! - CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) - !! - i3 = eye( nsd ) - !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & - & * taubar - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = muMaster*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = muSlave*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, taubar ) - !! -END PROCEDURE FacetMatrix1_3 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix1_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & - & muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) - !! - CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, & - & val=muMaster ) - CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, & - & val=muSlave ) - !! - i3 = eye( nsd ) - !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & - & muSlaveBar ) - !! -END PROCEDURE FacetMatrix1_4 - -!---------------------------------------------------------------------------- -! FacetMatrix1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix1_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & - & muMasterBar( : ), muSlaveBar( : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) - !! - CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, & - & val=muMaster ) - CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, & - & val=muSlave ) - CALL getInterpolation( obj=masterElemSD, interpol=taubar, val=tauvar ) - !! - i3 = eye( nsd ) - !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & - & * taubar - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & - & muSlaveBar, taubar ) - !! -END PROCEDURE FacetMatrix1_5 - -END SUBMODULE FacetMatrix1Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 deleted file mode 100644 index 275164a2f..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 +++ /dev/null @@ -1,127 +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(FacetMatrix_Method) FacetMatrix21Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix21 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix21_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 - !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - ALLOCATE( ans( nns1, nns2 ) ) - ans = 0.0_DFP - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips )) - END DO - !! - DEALLOCATE( realval, masterC1 ) - !! -END PROCEDURE FacetMatrix21_1 - -!---------------------------------------------------------------------------- -! FacetMatrix21 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix21_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 - !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - ALLOCATE( ans( nns1, nns2 ) ) - ans = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar - !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips )) - END DO - !! - DEALLOCATE( realval, masterC1 ) - !! -END PROCEDURE FacetMatrix21_2 - -!---------------------------------------------------------------------------- -! FacetMatrix21 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix21_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - ALLOCATE( ans( nns1, nns2 ) ) - ans = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar - !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips )) - END DO - !! - DEALLOCATE( realval, masterC1, taubar ) - !! -END PROCEDURE FacetMatrix21_3 - -END SUBMODULE FacetMatrix21Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 deleted file mode 100644 index 0f18edd6e..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 +++ /dev/null @@ -1,127 +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(FacetMatrix_Method) FacetMatrix22Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix22 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix22_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 - !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - ALLOCATE( ans( nns2, nns1 ) ) - ans = 0.0_DFP - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ), & - & elemsd%N( :, ips )) - END DO - !! - DEALLOCATE( realval, masterC1 ) - !! -END PROCEDURE FacetMatrix22_1 - -!---------------------------------------------------------------------------- -! FacetMatrix22 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix22_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 - !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - ALLOCATE( ans( nns2, nns1 ) ) - ans = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar - !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ), & - & elemsd%N( :, ips )) - END DO - !! - DEALLOCATE( realval, masterC1 ) - !! -END PROCEDURE FacetMatrix22_2 - -!---------------------------------------------------------------------------- -! FacetMatrix22 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix22_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - ALLOCATE( ans( nns2, nns ) ) - ans = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar - !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ), & - & elemsd%N( :, ips )) - END DO - !! - DEALLOCATE( realval, masterC1, taubar ) - !! -END PROCEDURE FacetMatrix22_3 - -END SUBMODULE FacetMatrix22Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 deleted file mode 100644 index 37485f0e5..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 +++ /dev/null @@ -1,273 +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(FacetMatrix_Method) FacetMatrix2Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix2_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, G12, m4 ) - !! -END PROCEDURE FacetMatrix2_1 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix2_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, G12, m4 ) - !! -END PROCEDURE FacetMatrix2_2 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix2_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, G12, taubar, m4 ) - !! -END PROCEDURE FacetMatrix2_3 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix2_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), muBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, G12, muBar, m4 ) - !! -END PROCEDURE FacetMatrix2_4 - -!---------------------------------------------------------------------------- -! FacetMatrix2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix2_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), muBar( : ), & - & tauBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) - CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) - !! - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, G12, muBar, taubar, m4 ) - !! -END PROCEDURE FacetMatrix2_5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE FacetMatrix2Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 deleted file mode 100644 index bc9995afb..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 +++ /dev/null @@ -1,324 +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(FacetMatrix_Method) FacetMatrix3Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix3_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, i3 ) - !! -END PROCEDURE FacetMatrix3_1 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix3_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12 ) - !! -END PROCEDURE FacetMatrix3_2 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix3_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 ) - !! -END PROCEDURE FacetMatrix3_3 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix3_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 ) - !! -END PROCEDURE FacetMatrix3_4 - -!---------------------------------------------------------------------------- -! FacetMatrix3 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix3_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar ) - !! -END PROCEDURE FacetMatrix3_5 - -END SUBMODULE FacetMatrix3Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 deleted file mode 100644 index c685e4619..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 +++ /dev/null @@ -1,334 +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(FacetMatrix_Method) FacetMatrix4Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix4_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, i3 ) - !! -END PROCEDURE FacetMatrix4_1 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix4_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, i3 ) - !! -END PROCEDURE FacetMatrix4_2 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix4_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 ) - !! -END PROCEDURE FacetMatrix4_3 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix4_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 ) - !! -END PROCEDURE FacetMatrix4_4 - -!---------------------------------------------------------------------------- -! FacetMatrix4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix4_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3(:,:) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar - !! - DO ips = 1, nips - !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar, i3 ) - !! -END PROCEDURE FacetMatrix4_5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE FacetMatrix4Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 deleted file mode 100644 index ef1f352f7..000000000 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 +++ /dev/null @@ -1,602 +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(FacetMatrix_Method) FacetMatrix5Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix5_1 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) - !! -END PROCEDURE FacetMatrix5_1 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix5_2 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) - !! -END PROCEDURE FacetMatrix5_2 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix5_3 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=(0.5_DFP*tauMaster)*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=(0.5_DFP*tauSlave)*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) - !! -END PROCEDURE FacetMatrix5_3 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix5_4 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:), muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - DO ips = 1, nips - masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips ) - END DO - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=(0.5_DFP)*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=(0.5_DFP)*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & - & muMasterBar, muSlaveBar, G12 ) - !! -END PROCEDURE FacetMatrix5_4 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix5_5 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - !! - C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) - !! - C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & - & tauMasterBar, tauSlaveBar, G12 ) - !! -END PROCEDURE FacetMatrix5_5 - -!---------------------------------------------------------------------------- -! FacetMatrix5 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix5_6 - !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : ), & - & muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) - !! - DO ips = 1, nips - masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips ) - END DO - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - !! - C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) - !! - C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) - !! - END DO - END DO - !! - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & - & tauMasterBar, tauSlaveBar, muMasterBar, muSlaveBar, G12 ) - !! -END PROCEDURE FacetMatrix5_6 - -END SUBMODULE FacetMatrix5Methods \ No newline at end of file diff --git a/src/submodules/ForceVector/CMakeLists.txt b/src/submodules/ForceVector/CMakeLists.txt deleted file mode 100644 index 095ef0197..000000000 --- a/src/submodules/ForceVector/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ForceVector_Method@Methods.F90 - ) diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 deleted file mode 100644 index c090b621c..000000000 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ /dev/null @@ -1,203 +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(ForceVector_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ForceVector_1 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ips - -! main -realval = test%js * test%ws * test%thickness -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_1 - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ForceVector_2 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, interpol=realval, val=c) -realval = test%js * test%ws * test%thickness * realval -CALL Reallocate(ans, SIZE(test%N, 1)) - -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) -END DO - -DEALLOCATE (realval) - -END PROCEDURE ForceVector_2b - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ForceVector_3 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, interpol=cbar, val=c) -realval = test%js * test%ws * test%thickness -CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) - -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 ForceVector_4 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, interpol=cbar, val=c) -realval = test%js * test%ws * test%thickness -CALL Reallocate(ans, SIZE(cbar, 1), SIZE(cbar, 2), 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_4 - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ForceVector_5 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar * c2bar -CALL Reallocate(ans, SIZE(test%N, 1)) - -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) -END DO - -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_5 - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ForceVector_6 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar -CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test%N, 1)) - -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(c2bar(:, ips), test%N(:, ips)) -END DO - -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_6 - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ForceVector_7 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar -CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test%N, 1)) - -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(c2bar(:, :, ips), test%N(:, ips)) -END DO - -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_7 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt deleted file mode 100644 index 74342d10f..000000000 --- a/src/submodules/Geometry/CMakeLists.txt +++ /dev/null @@ -1,39 +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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/ReferenceElement_Method@ConstructorMethods.F90 - ${src_path}/ReferenceElement_Method@IOMethods.F90 - ${src_path}/ReferenceElement_Method@FacetElementMethods.F90 - ${src_path}/ReferenceElement_Method@GeometryMethods.F90 - ${src_path}/ReferenceElement_Method@ElementNameMethods.F90 - ${src_path}/ReferenceElement_Method@LocalNodeCoordsMethods.F90 - ${src_path}/ReferenceElement_Method@EnquireMethods.F90 - ${src_path}/ReferenceElement_Method@VTKMethods.F90 - ${src_path}/ReferencePoint_Method@Methods.F90 - ${src_path}/ReferenceLine_Method@Methods.F90 - ${src_path}/Line_Method@Methods.F90 - ${src_path}/ReferenceTriangle_Method@Methods.F90 - ${src_path}/Triangle_Method@Methods.F90 - ${src_path}/Plane_Method@Methods.F90 - ${src_path}/ReferenceQuadrangle_Method@Methods.F90 - ${src_path}/ReferenceTetrahedron_Method@Methods.F90 - ${src_path}/ReferenceHexahedron_Method@Methods.F90 - ${src_path}/ReferencePrism_Method@Methods.F90 - ${src_path}/ReferencePyramid_Method@Methods.F90) diff --git a/src/submodules/Geometry/src/Line_Method@Methods.F90 b/src/submodules/Geometry/src/Line_Method@Methods.F90 deleted file mode 100644 index 93e5046f8..000000000 --- a/src/submodules/Geometry/src/Line_Method@Methods.F90 +++ /dev/null @@ -1,339 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(Line_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE line_exp_is_degenerate_nd -ans = (all(p1(1:dim_num) == p2(1:dim_num))) -END PROCEDURE line_exp_is_degenerate_nd - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE line_exp2imp_2d -integer(i4b), parameter :: dim_num = 2 -real(dfp) norm -! -! Take care of degenerate cases. -! -if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - return -end if - -a = p2(2) - p1(2) -b = p1(1) - p2(1) -c = p2(1) * p1(2) - p1(1) * p2(2) - -norm = a * a + b * b + c * c - -if (0.0D+00 < norm) then - a = a / norm - b = b / norm - c = c / norm -end if - -if (a < 0.0D+00) then - a = -a - b = -b - c = -c -end if - -END PROCEDURE line_exp2imp_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure line_imp_is_degenerate_2d -ans = (a * a + b * b == 0.0D+00) -end procedure line_imp_is_degenerate_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure lines_imp_int_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) a(dim_num, dim_num + 1) -integer(kind=4) info -! -p(1:dim_num) = 0.0D+00 -! -! Refuse to handle degenerate lines. -! -if (line_imp_is_degenerate_2d(a1, b1, c1)) then - ival = -1 - return -end if -! -if (line_imp_is_degenerate_2d(a2, b2, c2)) then - ival = -2 - return -end if -! -! Set up and solve a linear system. -! -a(1, 1) = a1 -a(1, 2) = b1 -a(1, 3) = -c1 -a(2, 1) = a2 -a(2, 2) = b2 -a(2, 3) = -c2 -! -call r8mat_solve(2, 1, a, info) -! -! If the inverse exists, then the lines intersect at the solution point. -! -if (info == 0) then - - ival = 1 - p(1:dim_num) = a(1:dim_num, 3) -! -! If the inverse does not exist, then the lines are parallel -! or coincident. Check for parallelism by seeing if the -! C entries are in the same ratio as the A or B entries. -! -else - ival = 0 - if (a1 == 0.0D+00) then - if (b2 * c1 == c2 * b1) then - ival = 2 - end if - else - if (a2 * c1 == c2 * a1) then - ival = 2 - end if - end if -end if -! -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure line_exp_perp_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) bot -real(kind=8) t -! -flag = .false. -if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - flag = .true. - p4(1:2) = r8_huge() - return -end if -! -bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) -! -! (P3-P1) dot (P2-P1) = Norm(P3-P1) * Norm(P2-P1) * Cos(Theta). -! -! (P3-P1) dot (P2-P1) / Norm(P3-P1)^2 = normalized coordinate T -! of the projection of (P3-P1) onto (P2-P1). -! -t = sum((p1(1:dim_num) - p3(1:dim_num)) & - * (p1(1:dim_num) - p2(1:dim_num))) / bot -! -p4(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -! -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure lines_exp_int_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) a1 -real(kind=8) a2 -real(kind=8) b1 -real(kind=8) b2 -real(kind=8) c1 -real(kind=8) c2 -logical(kind=4) point_1 -logical(kind=4) point_2 -! -ival = 0 -p(1:dim_num) = 0.0D+00 -! -! Check whether either line is a point. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - point_1 = .true. -else - point_1 = .false. -end if - -if (all(q1(1:dim_num) == q2(1:dim_num))) then - point_2 = .true. -else - point_2 = .false. -end if -! -! Convert the lines to ABC format. -! -if (.not. point_1) then - call line_exp2imp_2d(p1, p2, a1, b1, c1) -end if - -if (.not. point_2) then - call line_exp2imp_2d(q1, q2, a2, b2, c2) -end if -! -! Search for intersection of the lines. -! -if (point_1 .and. point_2) then - if (all(p1(1:dim_num) == q1(1:dim_num))) then - ival = 1 - p(1:dim_num) = p1(1:dim_num) - end if -else if (point_1) then - if (a2 * p1(1) + b2 * p1(2) == c2) then - ival = 1 - p(1:dim_num) = p1(1:dim_num) - end if -else if (point_2) then - if (a1 * q1(1) + b1 * q1(2) == c1) then - ival = 1 - p(1:dim_num) = q1(1:dim_num) - end if -else - call lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) -end if -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure segment_point_dist_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) bot -real(kind=8) pn(dim_num) -real(kind=8) t -! -! If the line segment is actually a point, then the answer is easy. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - t = 0.0D+00 -else - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - t = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) / bot - t = max(t, 0.0D+00) - t = min(t, 1.0D+00) -end if -! -pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure segment_point_dist_3d -integer(i4b), parameter :: dim_num = 3 -real(dfp) bot -real(dfp) pn(dim_num) -real(dfp) t -! -! If the line segment is actually a point, then the answer is easy. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - t = 0.0D+00 -else - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - t = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) / bot - t = max(t, 0.0D+00) - t = min(t, 1.0D+00) -end if - -pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure line_exp_point_dist_signed_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) a -real(kind=8) b -real(kind=8) c -! -! If the explicit line degenerates to a point, the computation is easy. -! -if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - dist_signed = sqrt(sum((p1(1:dim_num) - p(1:dim_num))**2)) -! -! Convert the explicit line to the implicit form A * P(1) + B * P(2) + C = 0. -! This makes the computation of the signed distance to (X,Y) easy. -! -else - a = p2(2) - p1(2) - b = p1(1) - p2(1) - c = p2(1) * p1(2) - p1(1) * p2(2) - dist_signed = (a * p(1) + b * p(2) + c) / sqrt(a * a + b * b) -end if -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure segment_point_near_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) bot -! -! If the line segment is actually a point, then the answer is easy. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - t = 0.0D+00 -else - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - t = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) / bot - t = max(t, 0.0D+00) - t = min(t, 1.0D+00) -end if -! -pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#include "./inc/aux.inc" - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/Plane_Method@Methods.F90 b/src/submodules/Geometry/src/Plane_Method@Methods.F90 deleted file mode 100644 index cfd3f2228..000000000 --- a/src/submodules/Geometry/src/Plane_Method@Methods.F90 +++ /dev/null @@ -1,87 +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(Plane_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE plane_normal_line_exp_int_3d -integer(i4b), parameter :: dim_num = 3 -real(dfp) :: direction(dim_num) -real(dfp) :: temp -! -! Make sure the line is not degenerate. -! -if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - return -end if -! -! Make sure the plane normal vector is a unit vector. -! -temp = sqrt(sum(normal(1:dim_num)**2)) -! -if (temp == 0.0D+00) then - return -end if -! -normal(1:dim_num) = normal(1:dim_num) / temp -! -! Determine the unit direction vector of the line. -! -direction(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) -temp = sqrt(sum(direction(1:dim_num)**2)) -direction(1:dim_num) = direction(1:dim_num) / temp -! -! If the normal and direction vectors are orthogonal, then -! we have a special case to deal with. -! -if (dot_product(normal(1:dim_num), direction(1:dim_num)) == 0.0D+00) then - - temp = dot_product(normal(1:dim_num), p1(1:dim_num) - pp(1:dim_num)) - - if (temp == 0.0D+00) then - ival = 2 - pint(1:dim_num) = p1(1:dim_num) - else - ival = 0 - pint(1:dim_num) = huge(temp) - end if - - return -end if -! -! Determine the distance along the direction vector -! to the intersection point. -! -temp = dot_product(pp(1:dim_num) - p1(1:dim_num), normal(1:dim_num)) & - & / dot_product(direction(1:dim_num), normal(1:dim_num)) - -ival = 1 -pint(1:dim_num) = p1(1:dim_num) + temp * direction(1:dim_num) - -END PROCEDURE plane_normal_line_exp_int_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 deleted file mode 100644 index 9e4b6a457..000000000 --- a/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,367 +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(ReferenceElement_Method) ConstructorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefTopoReallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefTopoReallocate -INTEGER(I4B) :: tsize, ii -LOGICAL(LGT) :: isok - -isok = ALLOCATED(obj) - -IF (isok) THEN - - tsize = SIZE(obj) - - DO ii = 1, tsize - CALL DEALLOCATE (obj(ii)) - END DO - - IF (tsize .NE. n) THEN - DEALLOCATE (obj) - ALLOCATE (obj(n)) - END IF - -ELSE - - ALLOCATE (obj(n)) - -END IF - -END PROCEDURE RefTopoReallocate - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefTopoDeallocate -LOGICAL(LGT) :: isok -INTEGER(I4B) :: ii, tsize - -isok = ALLOCATED(obj) - -IF (isok) THEN - tsize = SIZE(obj) - - DO ii = 1, tsize - CALL DEALLOCATE (obj(ii)) - END DO - - DEALLOCATE (obj) - -END IF - -END PROCEDURE RefTopoDeallocate - -!---------------------------------------------------------------------------- -! ReferenceTopology -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_ReferenceTopology -CALL Reallocate(obj%nptrs, SIZE(nptrs)) -obj%nptrs = nptrs -obj%name = name -obj%xiDimension = XiDimension(name) -END PROCEDURE refelem_ReferenceTopology - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_Deallocate1 -IF (ALLOCATED(obj%nptrs)) DEALLOCATE (obj%nptrs) -obj%name = 0_I4B -obj%XiDimension = 0_I4B -END PROCEDURE refelem_Deallocate1 - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_Deallocate2 -INTEGER(I4B) :: ii -obj%domainName = "GENERAL" -obj%entityCounts = 0 -obj%xiDimension = 0 -obj%name = 0 -obj%order = 0 -obj%nsd = 0 -obj%interpolationPointType = Equidistance -IF (ALLOCATED(obj%topology)) THEN - DO ii = 1, SIZE(obj%topology) - CALL DEALLOCATE (obj%topology(ii)) - END DO - DEALLOCATE (obj%topology) -END IF -IF (ALLOCATED(obj%xiJ)) DEALLOCATE (obj%xiJ) -obj%highOrderElement => NULL() -END PROCEDURE refelem_Deallocate2 - -!---------------------------------------------------------------------------- -! NNE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_NNE1 -IF (ALLOCATED(obj%nptrs)) THEN - ans = SIZE(obj%nptrs) -ELSE - ans = 0 -END IF -END PROCEDURE refelem_NNE1 - -!---------------------------------------------------------------------------- -! NNE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_NNE2 -IF (ALLOCATED(obj%XiJ)) THEN - ans = SIZE(obj%XiJ, 2) -ELSE - ans = 0 -END IF -END PROCEDURE refelem_NNE2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_Initiate1 -obj%domainName = anotherobj%domainName -IF (ALLOCATED(anotherobj%xiJ)) obj%xiJ = anotherobj%xiJ -obj%entityCounts = anotherobj%entityCounts -obj%xiDimension = anotherobj%xiDimension -obj%nsd = anotherobj%nsd -obj%order = anotherobj%order -obj%name = anotherobj%name -obj%interpolationPointType = anotherobj%interpolationPointType -IF (ALLOCATED(anotherobj%topology)) THEN - obj%topology = anotherobj%topology -END IF -obj%highOrderElement => anotherobj%highOrderElement -END PROCEDURE refelem_Initiate1 - -!---------------------------------------------------------------------------- -! ReferenceElement_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_constructor_1 -CLASS(ReferenceElement_), POINTER :: refelem -INTEGER(I4B) :: elemOrder -refelem => NULL() -SELECT CASE (xidim) -CASE (0) - ans => ReferencePoint_Pointer(nsd=nsd) -CASE (1) - elemOrder = ElementOrder(elemType) - IF (elemOrder .NE. 1) THEN - refelem => ReferenceLine_Pointer(nsd=nsd) - ALLOCATE (ReferenceLine_ :: ans) - CALL refelem%highOrderElement( & - & order=elemOrder, & - & ipType=ipType, & - & highOrderObj=ans) - CALL DEALLOCATE (refelem) - DEALLOCATE (refelem) - refelem => NULL() - ELSE - ans => ReferenceLine_Pointer(nsd=nsd) - END IF -CASE (2) - elemOrder = ElementOrder(elemType) - IF (isTriangle(elemType)) THEN - IF (elemOrder .NE. 1) THEN - refelem => ReferenceTriangle_Pointer(nsd=nsd) - ALLOCATE (ReferenceTriangle_ :: ans) - CALL refelem%highOrderElement( & - & order=elemOrder, & - & highOrderObj=ans, & - & ipType=ipType) - CALL DEALLOCATE (refelem) - DEALLOCATE (refelem) - refelem => NULL() - ELSE - ans => ReferenceTriangle_Pointer(nsd=nsd) - END IF - ELSE IF (isQuadrangle(elemType)) THEN - IF (elemOrder .NE. 1) THEN - refelem => ReferenceQuadrangle_Pointer(nsd=nsd) - ALLOCATE (ReferenceQuadrangle_ :: ans) - CALL refelem%highOrderElement( & - & order=elemOrder, & - & highOrderObj=ans, & - & ipType=ipType) - CALL DEALLOCATE (refelem) - DEALLOCATE (refelem) - refelem => NULL() - ELSE - ans => ReferenceQuadrangle_Pointer(nsd=nsd) - END IF - END IF -CASE (3) - elemOrder = ElementOrder(elemType) - IF (isTetrahedron(elemType)) THEN - IF (elemOrder .NE. 1) THEN - refelem => ReferenceTetrahedron_Pointer(nsd=nsd) - ALLOCATE (ReferenceTetrahedron_ :: ans) - CALL refelem%highOrderElement( & - & order=elemOrder, & - & highOrderObj=ans, & - & ipType=ipType) - CALL DEALLOCATE (refelem) - DEALLOCATE (refelem) - refelem => NULL() - ELSE - ans => ReferenceTetrahedron_Pointer(nsd=nsd) - END IF - ELSE IF (isHexahedron(elemType)) THEN - IF (elemOrder .NE. 1) THEN - refelem => ReferenceHexahedron_Pointer(nsd=nsd) - ALLOCATE (ReferenceHexahedron_ :: ans) - CALL refelem%highOrderElement( & - & order=elemOrder, & - & highOrderObj=ans, & - & ipType=ipType) - CALL DEALLOCATE (refelem) - DEALLOCATE (refelem) - refelem => NULL() - ELSE - ans => ReferenceHexahedron_Pointer(nsd=nsd) - END IF - ELSE IF (isPrism(elemType)) THEN - IF (elemOrder .NE. 1) THEN - refelem => ReferencePrism_Pointer(nsd=nsd) - ALLOCATE (ReferencePrism_ :: ans) - CALL refelem%highOrderElement( & - & order=elemOrder, & - & highOrderObj=ans, & - & ipType=ipType) - CALL DEALLOCATE (refelem) - DEALLOCATE (refelem) - refelem => NULL() - ELSE - ans => ReferencePrism_Pointer(nsd=nsd) - END IF - ELSE IF (isPyramid(elemType)) THEN - IF (elemOrder .NE. 1) THEN - refelem => ReferencePyramid_Pointer(nsd=nsd) - ALLOCATE (ReferencePyramid_ :: ans) - CALL refelem%highOrderElement( & - & order=elemOrder, & - & highOrderObj=ans, & - & ipType=ipType) - CALL DEALLOCATE (refelem) - DEALLOCATE (refelem) - refelem => NULL() - ELSE - ans => ReferencePyramid_Pointer(nsd=nsd) - END IF - END IF -END SELECT -ans%interpolationPointType = ipType -END PROCEDURE refelem_constructor_1 - -!---------------------------------------------------------------------------- -! ReferenceElement_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_constructor_2 -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - ALLOCATE (ReferenceLine_ :: ans) -TYPE IS (ReferenceTriangle_) - ALLOCATE (ReferenceTriangle_ :: ans) -TYPE IS (ReferenceQuadrangle_) - ALLOCATE (ReferenceQuadrangle_ :: ans) -TYPE IS (ReferenceTetrahedron_) - ALLOCATE (ReferenceTetrahedron_ :: ans) -TYPE IS (ReferenceHexahedron_) - ALLOCATE (ReferenceHexahedron_ :: ans) -TYPE IS (ReferencePrism_) - ALLOCATE (ReferencePrism_ :: ans) -TYPE IS (ReferencePyramid_) - ALLOCATE (ReferencePyramid_ :: ans) -CLASS DEFAULT - SELECT CASE (refelem%name) - CASE (Line) - ALLOCATE (ReferenceLine_ :: ans) - CASE (Triangle) - ALLOCATE (ReferenceTriangle_ :: ans) - CASE (Quadrangle) - ALLOCATE (ReferenceQuadrangle_ :: ans) - CASE (Tetrahedron) - ALLOCATE (ReferenceTetrahedron_ :: ans) - CASE (Hexahedron) - ALLOCATE (ReferenceHexahedron_ :: ans) - CASE (Prism) - ALLOCATE (ReferencePrism_ :: ans) - CASE (Pyramid) - ALLOCATE (ReferencePyramid_ :: ans) - END SELECT -END SELECT -ans = refelem -END PROCEDURE refelem_constructor_2 - -!---------------------------------------------------------------------------- -! getnptrs -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_getnptrs -INTEGER(I4B) :: ii, tsize -LOGICAL(LGT) :: isok - -#ifdef DEBUG_VER -isok = ALLOCATED(obj%topology) -IF (.NOT. isok) THEN - CALL Reallocate(ans, 0) - RETURN -END IF -#endif - -ii = SUM(obj%entityCounts) - -#ifdef DEBUG_VER -tsize = SIZE(obj%topology) -isok = ii .LE. tsize - -IF (.NOT. isok) THEN - CALL Reallocate(ans, 0) - RETURN -END IF - -isok = ALLOCATED(obj%topology(ii)%nptrs) - -IF (.NOT. isok) THEN - CALL Reallocate(ans, 0) - RETURN -END IF -#endif - -ans = obj%topology(ii)%nptrs -END PROCEDURE refelem_getnptrs - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE ConstructorMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 deleted file mode 100644 index 6f9165be3..000000000 --- a/src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 +++ /dev/null @@ -1,296 +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: 1 March 2021 -! summary: This sumodule contains method for geometry - -SUBMODULE(ReferenceElement_Method) EnquireMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! isVolume -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isVolume1 -SELECT CASE (elemType) -CASE (Tetrahedron4, & - Hexahedron8, & - Prism6, & - Pyramid5, & - Tetrahedron10, & - Hexahedron27, & - Prism18, & - Pyramid14, & - Hexahedron20, & - Prism15, & - Pyramid13, & - Tetrahedron20, & - Tetrahedron35, & - Tetrahedron56, & - Hexahedron64, & - Hexahedron125) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isVolume1 - -!---------------------------------------------------------------------------- -! isVolume -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isVolume2 -ans = isVolume1(obj%name) -END PROCEDURE isVolume2 - -!---------------------------------------------------------------------------- -! isSurface -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isSurface1 -SELECT CASE (elemType) -CASE (Triangle3, & - Triangle6, & - Triangle9, & - Triangle10, & - Triangle12, & - Triangle15a, & - Triangle15b, & - Triangle21, & - Quadrangle4, & - Quadrangle8, & - Quadrangle9, & - Quadrangle16) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isSurface1 - -!---------------------------------------------------------------------------- -! isSurface -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isSurface2 -ans = isSurface1(obj%name) -END PROCEDURE isSurface2 - -!---------------------------------------------------------------------------- -! isLine -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isLine1 -SELECT CASE (elemType) -CASE (Line2, & - & Line3, & - & Line4, & - & Line5, & - & Line6) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isLine1 - -!---------------------------------------------------------------------------- -! isLine -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isLine2 -ans = isLine1(obj%name) -END PROCEDURE isLine2 - -!---------------------------------------------------------------------------- -! isPoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isPoint1 -SELECT CASE (elemType) -CASE (Point1) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isPoint1 - -!---------------------------------------------------------------------------- -! isPoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isPoint2 -ans = isPoint1(obj%name) -END PROCEDURE isPoint2 - -!---------------------------------------------------------------------------- -! isTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isTriangle1 -SELECT CASE (elemType) -CASE (Triangle3, Triangle6, & -& Triangle9, Triangle10, Triangle12, Triangle15a, & -& Triangle15b, Triangle21) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isTriangle1 - -!---------------------------------------------------------------------------- -! isTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isTriangle2 -ans = isTriangle1(obj%name) -END PROCEDURE isTriangle2 - -!---------------------------------------------------------------------------- -! isQuadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isQuadrangle1 -SELECT CASE (elemType) -CASE (Quadrangle4, Quadrangle8, Quadrangle9, Quadrangle16) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isQuadrangle1 - -!---------------------------------------------------------------------------- -! isQuadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isQuadrangle2 -ans = isQuadrangle1(obj%name) -END PROCEDURE isQuadrangle2 - -!---------------------------------------------------------------------------- -! isTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isTetrahedron1 -SELECT CASE (elemType) -CASE (Tetrahedron4, Tetrahedron10, Tetrahedron20, Tetrahedron35, & - & Tetrahedron56) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isTetrahedron1 - -!---------------------------------------------------------------------------- -! isTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isTetrahedron2 -ans = isTetrahedron1(obj%name) -END PROCEDURE isTetrahedron2 - -!---------------------------------------------------------------------------- -! isHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isHexahedron1 -SELECT CASE (elemType) -CASE (Hexahedron8, Hexahedron27, & - & Hexahedron20, Hexahedron64, Hexahedron125) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isHexahedron1 - -!---------------------------------------------------------------------------- -! isHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isHexahedron2 -ans = isHexahedron1(obj%name) -END PROCEDURE isHexahedron2 - -!---------------------------------------------------------------------------- -! isPrism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isPrism1 -SELECT CASE (elemType) -CASE (Prism6, Prism18, Prism15) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isPrism1 - -!---------------------------------------------------------------------------- -! isPrism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isPrism2 -ans = isPrism1(obj%name) -END PROCEDURE isPrism2 - -!---------------------------------------------------------------------------- -! isPyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isPyramid1 -SELECT CASE (elemType) -CASE (Pyramid5, Pyramid13, Pyramid14) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isPyramid1 - -!---------------------------------------------------------------------------- -! isPyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isPyramid2 -ans = isPyramid1(obj%name) -END PROCEDURE isPyramid2 - -!---------------------------------------------------------------------------- -! isSerendipityElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isSerendipityElement1 -SELECT CASE (elemType) -CASE (Triangle9, Triangle12, Triangle15b, Quadrangle8) - ans = .TRUE. -CASE DEFAULT - ans = .FALSE. -END SELECT -END PROCEDURE isSerendipityElement1 - -!---------------------------------------------------------------------------- -! isSerendipityElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isSerendipityElement2 -ans = isSerendipityElement1(obj%name) -END PROCEDURE isSerendipityElement2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE EnquireMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 deleted file mode 100644 index 9e4d46182..000000000 --- a/src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 +++ /dev/null @@ -1,223 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This sumodule contains method for geometry - -SUBMODULE(ReferenceElement_Method) FacetElementMethods -USE ReferenceLine_Method, ONLY: DEFAULT_REF_LINE_COORD, & - & FacetElements_Line, & - & FacetTopology_Line - -USE ReferenceTriangle_Method, ONLY: GetEdgeConnectivity_Triangle, & - & FacetElements_Triangle, & - & FacetTopology_Triangle - -USE ReferenceQuadrangle_Method, ONLY: GetEdgeConnectivity_Quadrangle, & - & FacetElements_Quadrangle, & - & FacetTopology_Quadrangle - -USE ReferenceTetrahedron_Method, ONLY: FacetElements_Tetrahedron, & - & FacetTopology_Tetrahedron - -USE ReferenceTetrahedron_Method, ONLY: FacetElements_Tetrahedron, & - & FacetTopology_Tetrahedron - -USE ReferenceHexahedron_Method, ONLY: FacetElements_Hexahedron, & - & FacetTopology_Hexahedron - -USE ReferencePrism_Method, ONLY: FacetElements_Prism, & - & FacetTopology_Prism - -USE ReferencePyramid_Method, ONLY: FacetElements_Pyramid, & - & FacetTopology_Pyramid - -USE LineInterpolationUtility, ONLY: InterpolationPoint_Line -USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle -USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle -! USE TetrahedronInterpolationUtility -! USE HexahedronInterpolationUtility -! USE PrismInterpolationUtility -! USE PyramidInterpolationUtility - -USE ErrorHandling - -USE ReallocateUtility - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FacetMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Facet_Matrix_refelem -INTEGER(I4B) :: xicell, T(4), i, istart, iend, max_nns, nns, tFacet -T(1) = 0 -DO i = 2, 4 - T(i) = SUM(refelem%entityCounts(1:i - 1)) -END DO - -xicell = refelem%xiDimension - -SELECT CASE (xicell) -CASE (1) - tFacet = 2 - istart = 1 - iend = 2 - max_nns = 2 - ALLOCATE (FM(tFacet, max_nns + 3)) - FM = 0 - DO i = 0, tFacet - 1 - FM(i + 1, 1) = refelem%topology(istart + i)%name - FM(i + 1, 2) = refelem%topology(istart + i)%xiDimension - nns = SIZE(refelem%topology(istart + i)%nptrs) - FM(i + 1, 3) = nns - FM(i + 1, 4:(3 + nns)) = refelem%topology(istart + i)%nptrs - END DO - -CASE (2, 3) - tFacet = refelem%entityCounts(xicell) - istart = T(xicell) + 1 - iend = T(xicell) + tFacet - max_nns = 0 - DO i = istart, iend - nns = SIZE(refelem%topology(i)%nptrs) - IF (max_nns .LT. nns) max_nns = nns - END DO - ALLOCATE (FM(tFacet, max_nns + 3)) - FM = 0 - DO i = 0, tFacet - 1 - FM(i + 1, 1) = refelem%topology(istart + i)%name - FM(i + 1, 2) = refelem%topology(istart + i)%xiDimension - nns = SIZE(refelem%topology(istart + i)%nptrs) - FM(i + 1, 3) = nns - FM(i + 1, 4:(3 + nns)) = refelem%topology(istart + i)%nptrs - END DO -END SELECT - -END PROCEDURE Facet_Matrix_refelem - -!---------------------------------------------------------------------------- -! FacetElements -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_GetFacetElements1 -INTEGER(I4B) :: topo - -topo = ElementTopology(refelem) - -SELECT CASE (topo) -CASE (Line) - CALL FacetElements_Line(refelem=refelem, ans=ans) - -CASE (Triangle) - CALL FacetElements_Triangle(refelem=refelem, ans=ans) - -CASE (Quadrangle) - CALL FacetElements_Quadrangle(refelem=refelem, ans=ans) - -CASE (Tetrahedron) - CALL FacetElements_Tetrahedron(refelem=refelem, ans=ans) - -CASE (Hexahedron) - CALL FacetElements_Hexahedron(refelem=refelem, ans=ans) - -CASE (Prism) - CALL FacetElements_Prism(refelem=refelem, ans=ans) - -CASE (Pyramid) - CALL FacetElements_Pyramid(refelem=refelem, ans=ans) - -END SELECT - -END PROCEDURE refelem_GetFacetElements1 - -!---------------------------------------------------------------------------- -! FacetElements -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_GetFacetElements2 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Line) - CALL FacetElements_Line(elemType=elemType, nsd=nsd, ans=ans) - -CASE (Triangle) - CALL FacetElements_Triangle(elemType=elemType, nsd=nsd, ans=ans) - -CASE (Quadrangle) - CALL FacetElements_Quadrangle(elemType=elemType, nsd=nsd, ans=ans) - -CASE (Tetrahedron) - CALL FacetElements_Tetrahedron(elemType=elemType, nsd=nsd, ans=ans) - -CASE (Hexahedron) - CALL FacetElements_Hexahedron(elemType=elemType, nsd=nsd, ans=ans) - -CASE (Prism) - CALL FacetElements_Prism(elemType=elemType, nsd=nsd, ans=ans) - -CASE (Pyramid) - CALL FacetElements_Pyramid(elemType=elemType, nsd=nsd, ans=ans) - -END SELECT - -END PROCEDURE refelem_GetFacetElements2 - -!---------------------------------------------------------------------------- -! GetFacetTopology -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_GetFacettopology -INTEGER(I4B) :: topo -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Line) - CALL FacetTopology_Line(elemType=elemType, nptrs=nptrs, ans=ans) - -CASE (Triangle) - CALL FacetTopology_Triangle(elemType=elemType, nptrs=nptrs, ans=ans) - -CASE (Quadrangle) - CALL FacetTopology_Quadrangle(elemType=elemType, nptrs=nptrs, ans=ans) - -CASE (Tetrahedron) - CALL FacetTopology_Tetrahedron(elemType=elemType, nptrs=nptrs, ans=ans) - -CASE (Prism) - CALL FacetTopology_Prism(elemType=elemType, nptrs=nptrs, ans=ans) - -CASE (Pyramid) - CALL FacetTopology_Pyramid(elemType=elemType, nptrs=nptrs, ans=ans) - -CASE (Hexahedron) - CALL FacetTopology_Hexahedron(elemType=elemType, nptrs=nptrs, ans=ans) - -END SELECT -END PROCEDURE refelem_GetFacettopology - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE FacetElementMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 deleted file mode 100644 index fac9e0eae..000000000 --- a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 +++ /dev/null @@ -1,560 +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(ReferenceElement_Method) GeometryMethods -USE ErrorHandling, ONLY: Errormsg -USE Display_Method - -USE ReferencePoint_Method, ONLY: Measure_Simplex_Point, Point_quality, & - TotalNodesInElement_Point - -USE ReferenceLine_Method, ONLY: Measure_Simplex_Line, & - Line_quality, & - TotalNodesInElement_Line, & - TotalEntities_Line, & - GetFaceElemType_Line, & - GetEdgeConnectivity_Line, & - GetFaceConnectivity_Line - -USE ReferenceTriangle_Method, ONLY: Measure_Simplex_Triangle, & - Triangle_quality, & - triangle_contains_point, & - GetEdgeConnectivity_Triangle, & - TotalNodesInElement_Triangle, & - TotalEntities_Triangle, & - GetFaceConnectivity_Triangle, & - GetFaceElemType_Triangle - -USE ReferenceQuadrangle_Method, ONLY: Measure_Simplex_Quadrangle, & - Quadrangle_quality, & - GetEdgeConnectivity_Quadrangle, & - TotalNodesInElement_Quadrangle, & - TotalEntities_Quadrangle, & - GetFaceConnectivity_Quadrangle, & - GetFaceElemType_Quadrangle - -USE ReferenceTetrahedron_Method, ONLY: Measure_Simplex_Tetrahedron, & - Tetrahedron_quality, & - GetEdgeConnectivity_Tetrahedron, & - GetFaceConnectivity_Tetrahedron, & - GetFaceElemType_Tetrahedron, & - TotalNodesInElement_Tetrahedron, & - TotalEntities_Tetrahedron - -USE ReferenceHexahedron_Method, ONLY: Measure_Simplex_Hexahedron, & - Hexahedron_quality, & - GetEdgeConnectivity_Hexahedron, & - GetFaceConnectivity_Hexahedron, & - GetFaceElemType_Hexahedron, & - TotalNodesInElement_Hexahedron, & - TotalEntities_Hexahedron - -USE ReferencePrism_Method, ONLY: Measure_Simplex_Prism, & - Prism_quality, & - GetEdgeConnectivity_Prism, & - GetFaceConnectivity_Prism, & - GetFaceElemType_Prism, & - TotalNodesInElement_Prism, & - TotalEntities_Prism - -USE ReferencePyramid_Method, ONLY: Measure_Simplex_Pyramid, & - Pyramid_quality, & - GetEdgeConnectivity_Pyramid, & - GetFaceConnectivity_Pyramid, & - GetFaceElemType_Pyramid, & - TotalNodesInElement_Pyramid, & - TotalEntities_Pyramid - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetElementIndex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetElementIndex -INTEGER(I4B) :: topo - -topo = refelem_ElementTopology1(elemType) - -SELECT CASE (topo) -CASE (Point) - ans = 1 - -CASE (Line) - ans = 2 - -CASE (Triangle) - ans = 3 - -CASE (Quadrangle) - ans = 4 - -CASE (Tetrahedron) - ans = 5 - -CASE (Hexahedron) - ans = 6 - -CASE (Prism) - ans = 7 - -CASE (Pyramid) - ans = 8 - -END SELECT -END PROCEDURE GetElementIndex - -!---------------------------------------------------------------------------- -! RefElemGetGeoParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemGetGeoParam1 -INTEGER(I4B) :: topo - -topo = refelem_ElementTopology1(elemType) - -IF (PRESENT(tCells)) tCells = 1_I4B - -SELECT CASE (topo) - -CASE (Point, Line) - - IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Line(elemType) - IF (PRESENT(tEdges)) tEdges = 0_I4B - IF (PRESENT(tFaces)) tFaces = 2_I4B - - IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Line(con=edgeCon, & - opt=edgeOpt, order=order) - - IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Line(con=faceCon, & - opt=faceOpt, order=order) - - CALL GetFaceElemType_Line(faceElemType=faceElemType, & - tFaceNodes=tFaceNodes, elemType=elemType) - -CASE (Triangle) - - IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Triangle(elemType) - IF (PRESENT(tEdges)) tEdges = 3_I4B - IF (PRESENT(tFaces)) tFaces = 3_I4B - - IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Triangle(con=edgeCon, & - opt=edgeOpt, order=order) - - IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Triangle(con=faceCon, & - opt=faceOpt, order=order) - - CALL GetFaceElemType_Triangle(faceElemType=faceElemType, & - tFaceNodes=tFaceNodes, elemType=elemType) - -CASE (Quadrangle) - - IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Quadrangle(elemType) - IF (PRESENT(tEdges)) tEdges = 4_I4B - IF (PRESENT(tFaces)) tFaces = 4_I4B - - IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, & - opt=edgeOpt, order=order) - - IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Quadrangle(con=faceCon, & - opt=faceOpt, order=order) - - CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, & - tFaceNodes=tFaceNodes, elemType=elemType) - -CASE (Tetrahedron) - - IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Tetrahedron(elemType) - IF (PRESENT(tEdges)) tEdges = 6_I4B - IF (PRESENT(tFaces)) tFaces = 4_I4B - IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Tetrahedron(con=edgeCon, & - opt=edgeOpt, order=order) - IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Tetrahedron(con=faceCon, & - opt=faceOpt, order=order) - - CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & - tFaceNodes=tFaceNodes, elemType=elemType) - -CASE (Hexahedron) - - IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Hexahedron(elemType) - IF (PRESENT(tEdges)) tEdges = 12_I4B - IF (PRESENT(tFaces)) tFaces = 6_I4B - IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Hexahedron(con=edgeCon, & - opt=edgeOpt, order=order) - IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Hexahedron(con=faceCon, & - opt=faceOpt, order=order) - - CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, & - tFaceNodes=tFaceNodes, elemType=elemType) - -CASE (Prism) - - IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Prism(elemType) - IF (PRESENT(tEdges)) tEdges = 9_I4B - IF (PRESENT(tFaces)) tFaces = 5_I4B - IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Prism(con=edgeCon, & - opt=edgeOpt, order=order) - IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Prism(con=faceCon, & - opt=faceOpt, order=order) - - CALL GetFaceElemType_Prism(faceElemType=faceElemType, & - tFaceNodes=tFaceNodes, elemType=elemType) - -CASE (Pyramid) - - IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Pyramid(elemType) - IF (PRESENT(tEdges)) tEdges = 8_I4B - IF (PRESENT(tFaces)) tFaces = 5_I4B - IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Pyramid(con=edgeCon, & - opt=edgeOpt, order=order) - IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Pyramid(con=faceCon, & - opt=faceOpt, order=order) - - CALL GetFaceElemType_Pyramid(faceElemType=faceElemType, & - tFaceNodes=tFaceNodes, elemType=elemType) - -CASE DEFAULT - IF (PRESENT(tNodes)) tNodes = 0_I4B - IF (PRESENT(tEdges)) tEdges = 0_I4B - IF (PRESENT(tFaces)) tFaces = 0_I4B - IF (PRESENT(edgeCon)) edgeCon = 0_I4B - IF (PRESENT(faceCon)) faceCon = 0_I4B - IF (PRESENT(faceElemType)) faceElemType = 0_I4B - IF (PRESENT(tFaceNodes)) tFaceNodes = 0_I4B -END SELECT -END PROCEDURE RefElemGetGeoParam1 - -!---------------------------------------------------------------------------- -! GetTotalNodes -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalNodes1 -CALL RefElemGetGeoParam(tNodes=ans, elemType=elemType) -END PROCEDURE GetTotalNodes1 - -!---------------------------------------------------------------------------- -! GetTotalEdges -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalEdges1 -CALL RefElemGetGeoParam(tEdges=ans, elemType=elemType) -END PROCEDURE GetTotalEdges1 - -!---------------------------------------------------------------------------- -! GetTotalFaces -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalFaces1 -CALL RefElemGetGeoParam(tFaces=ans, elemType=elemType) -END PROCEDURE GetTotalFaces1 - -!---------------------------------------------------------------------------- -! GetTotalCells -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalCells1 -CALL RefElemGetGeoParam(tCells=ans, elemType=elemType) -END PROCEDURE GetTotalCells1 - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity1 -INTEGER(I4B) :: topo - -topo = refelem_ElementTopology1(elemType) - -SELECT CASE (topo) - -CASE (Line) - CALL GetEdgeConnectivity_Line(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Triangle) - - CALL GetEdgeConnectivity_Triangle(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Quadrangle) - - CALL GetEdgeConnectivity_Quadrangle(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Tetrahedron) - - CALL GetEdgeConnectivity_Tetrahedron(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Hexahedron) - - CALL GetEdgeConnectivity_Hexahedron(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Prism) - - CALL GetEdgeConnectivity_Prism(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Pyramid) - - CALL GetEdgeConnectivity_Pyramid(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -END SELECT -END PROCEDURE GetEdgeConnectivity1 - -!---------------------------------------------------------------------------- -! GetFaceConnectivity2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity1 -INTEGER(I4B) :: topo - -topo = refelem_ElementTopology1(elemType) - -SELECT CASE (topo) - -CASE (Line) - CALL GetFaceConnectivity_Line(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Triangle) - - CALL GetFaceConnectivity_Triangle(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Quadrangle) - - CALL GetFaceConnectivity_Quadrangle(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Tetrahedron) - - CALL GetFaceConnectivity_Tetrahedron(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Hexahedron) - - CALL GetFaceConnectivity_Hexahedron(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Prism) - - CALL GetFaceConnectivity_Prism(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -CASE (Pyramid) - - CALL GetFaceConnectivity_Pyramid(con=con, opt=opt, order=order, & - nrow=nrow, ncol=ncol) - -END SELECT -END PROCEDURE GetFaceConnectivity1 - -!---------------------------------------------------------------------------- -! GetFaceElemType -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType1 -INTEGER(I4B) :: topo - -topo = refelem_ElementTopology1(elemType) - -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 - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex -INTEGER(I4B) :: elemType -Ans = 0.0_DFP -SELECT TYPE (refelem) -TYPE IS (ReferencePoint_) - Ans = Measure_Simplex_Point(refelem, xij) -TYPE IS (ReferenceLine_) - Ans = Measure_Simplex_Line(refelem, xij) -TYPE IS (ReferenceTriangle_) - Ans = Measure_Simplex_Triangle(refelem, xij) -TYPE IS (ReferenceQuadrangle_) - Ans = Measure_Simplex_Quadrangle(refelem, xij) -TYPE IS (ReferenceTetrahedron_) - Ans = Measure_Simplex_Tetrahedron(refelem, xij) -TYPE IS (ReferenceHexahedron_) - Ans = Measure_Simplex_Hexahedron(refelem, xij) -TYPE IS (ReferencePrism_) - Ans = Measure_Simplex_Prism(refelem, xij) -TYPE IS (ReferencePyramid_) - Ans = Measure_Simplex_Pyramid(refelem, xij) -CLASS DEFAULT - elemType = refelem%name - IF (isPoint(elemType)) THEN - Ans = Measure_Simplex_Point(refelem, xij) - ELSEIF (isLine(elemType)) THEN - Ans = Measure_Simplex_Line(refelem, xij) - ELSEIF (isTriangle(elemType)) THEN - Ans = Measure_Simplex_Triangle(refelem, xij) - ELSEIF (isQuadrangle(elemType)) THEN - Ans = Measure_Simplex_Quadrangle(refelem, xij) - ELSEIF (isTetrahedron(elemType)) THEN - Ans = Measure_Simplex_Tetrahedron(refelem, xij) - ELSEIF (isHexahedron(elemType)) THEN - Ans = Measure_Simplex_Hexahedron(refelem, xij) - ELSEIF (isPrism(elemType)) THEN - Ans = Measure_Simplex_Prism(refelem, xij) - ELSEIF (isPyramid(elemType)) THEN - Ans = Measure_Simplex_Pyramid(refelem, xij) - END IF -END SELECT -END PROCEDURE Measure_Simplex - -!---------------------------------------------------------------------------- -! ElementQuality -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Element_Quality -SELECT TYPE (refelem) -CLASS IS (ReferencePoint_) - Ans = Point_quality(refelem, xij, measure) -CLASS IS (ReferenceLine_) - Ans = Line_quality(refelem, xij, measure) -CLASS IS (ReferenceTriangle_) - Ans = Triangle_quality(refelem, xij, measure) -CLASS IS (ReferenceQuadrangle_) - Ans = Quadrangle_quality(refelem, xij, measure) -CLASS IS (ReferenceTetrahedron_) - Ans = Tetrahedron_quality(refelem, xij, measure) -CLASS IS (ReferencePrism_) - Ans = Prism_quality(refelem, xij, measure) -CLASS IS (ReferenceHexahedron_) - Ans = Hexahedron_quality(refelem, xij, measure) -CLASS IS (ReferencePyramid_) - Ans = Pyramid_quality(refelem, xij, measure) -END SELECT -END PROCEDURE Element_Quality - -!---------------------------------------------------------------------------- -! ContainsPoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contains_point -SELECT TYPE (refelem) -CLASS IS (ReferenceLine_) - CALL Display("ERROR:: ReferenceElement_Method@Geometry.F90") - CALL Display(" Contains_point()") - CALL Display(" No case found for ReferenceLine_") - CALL Display(" Program stopped!!") - STOP -CLASS IS (ReferenceTriangle_) - Ans = triangle_contains_point(refelem, xij, x) -CLASS IS (ReferenceQuadrangle_) - CALL Display("ERROR:: ReferenceElement_Method@Geometry.F90") - CALL Display(" Contains_point()") - CALL Display(" No case found for Quadrangle_") - CALL Display(" Program stopped!!") - STOP -CLASS DEFAULT - CALL Display("ERROR:: ReferenceElement_Method@Geometry.F90") - CALL Display(" Contains_point()") - CALL Display(" No case found") - CALL Display(" Program stopped!!") - STOP -END SELECT -END PROCEDURE contains_point - -!---------------------------------------------------------------------------- -! TotalEntities -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_TotalEntities -INTEGER(I4B) :: topo - -topo = refelem_ElementTopology1(elemType) - -SELECT CASE (topo) -CASE (Point, Line) - - ans = TotalEntities_Line(elemType) - -CASE (Triangle) - - ans = TotalEntities_Triangle(elemType) - -CASE (Quadrangle) - ans = TotalEntities_Quadrangle(elemType) - -CASE (Tetrahedron) - ans = TotalEntities_Tetrahedron(elemType) - -CASE (Hexahedron) - ans = TotalEntities_Hexahedron(elemType) - -CASE (Prism) - ans = TotalEntities_Prism(elemType) - -CASE (Pyramid) - ans = TotalEntities_Pyramid(elemType) - -END SELECT -END PROCEDURE refelem_TotalEntities - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE GeometryMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 deleted file mode 100644 index 1ebb16046..000000000 --- a/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 +++ /dev/null @@ -1,283 +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: 1 March 2021 -! summary: This submodule contains IO methods for [[ReferenceElement_]] - -SUBMODULE(ReferenceElement_Method) IOMethods -USE BaseMethod -CONTAINS - -!---------------------------------------------------------------------------- -! MDEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE reftopo_MdEncode -TYPE(String), ALLOCATABLE :: astr(:, :) -INTEGER(I4B) :: n, ii, jj -TYPE(String) :: rh(3), ch(1) - -rh(1) = "Element type" -rh(2) = "Xidimension" -rh(3) = "Nptrs" -ch(1) = "" - -IF (ALLOCATED(obj%nptrs)) THEN - n = SIZE(obj%nptrs) - CALL reallocate(astr, 3, n) - astr(1, 1) = ElementName(obj%name) - DO ii = 2, n - astr(1, ii) = "" - END DO - - astr(2, 1) = tostring(obj%xidimension) - DO ii = 2, n - astr(2, ii) = "" - END DO - - DO ii = 1, n - astr(3, ii) = tostring(obj%nptrs(ii)) - END DO - -ELSE - - n = 1 - CALL reallocate(astr, 3, n) - astr(1, 1) = ElementName(obj%name) - astr(2, 1) = tostring(obj%xidimension) - astr(3, 1) = "NOT ALLOCATED" - -END IF - -ans = MdEncode(val=astr, rh=rh, ch=ch) - -IF (ALLOCATED(astr)) DEALLOCATE (astr) - -END PROCEDURE reftopo_MdEncode - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_MdEncode -!! Define internal variable -INTEGER(I4B) :: j, tsize, jj -LOGICAL(LGT) :: notFull0 -TYPE(String) :: astr(20) -CHARACTER(1), PARAMETER, DIMENSION(3) :: xyz = ["x", "y", "z"] -TYPE(String) :: rowTitle(20), colTitle(1) - -colTitle(1) = "" - -rowTitle(1) = "Element type"; astr(1) = ElementName(obj%name) -rowTitle(2) = "Xidimension"; astr(2) = tostring(obj%xiDimension) -rowTitle(3) = "NSD"; astr(3) = tostring(obj%nsd) -rowTitle(4) = "tPoints"; astr(4) = tostring(obj%entityCounts(1)) -rowTitle(5) = "tLines"; astr(5) = tostring(obj%entityCounts(2)) -rowTitle(6) = "tSurfaces"; astr(6) = tostring(obj%entityCounts(3)) -rowTitle(7) = "tVolumes"; astr(7) = tostring(obj%entityCounts(4)) - -tsize = SIZE(obj%xij, 1) -DO j = 1, tsize - rowTitle(7 + j) = xyz(j) -END DO - -ans = MdEncode(val=astr(1:7), rh=rowTitle(1:7), ch=colTitle)// & - & char_lf//"Nodal Coordinates:"//char_lf//char_lf// & - & MdEncode(obj%xij, rh=rowTitle(7 + 1:7 + tsize), ch=colTitle) - -! pointTopology -DO j = 1, obj%entityCounts(1) - ans = ans//"PointTopology( "//tostring(j)//" ) : "// & - & char_lf//char_lf//MdEncode(obj%topology(j)) -END DO - -!! edgeTopology -tsize = obj%entityCounts(1) -DO j = 1, obj%entityCounts(2) - ans = ans//"EdgeTopology( "//tostring(j)//" ) : "// & - & char_lf//char_lf//MdEncode(obj%topology(tsize + j)) -END DO - -!! faceTopology -tsize = tsize + obj%entityCounts(2) -DO j = 1, obj%entityCounts(3) - ans = ans//"FaceTopology( "//tostring(j)//" ) : "// & - & char_lf//char_lf//MdEncode(obj%topology(tsize + j)) -END DO - -!! cellTopology -tsize = tsize + obj%entityCounts(3) -DO j = 1, obj%entityCounts(4) - ans = ans//"CellTopology( "//tostring(j)//" ) : "// & - & char_lf//char_lf//MdEncode(obj%topology(tsize + j)) -END DO -END PROCEDURE refelem_MdEncode - -!---------------------------------------------------------------------------- -! refelem_ReactEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_ReactEncode -!! Define internal variable -INTEGER(I4B) :: j, tsize -LOGICAL(LGT) :: notFull0 -TYPE(String) :: rowTitle(20), colTitle(1) -TYPE(String) :: astr(20) -CHARACTER(1), PARAMETER, DIMENSION(3) :: xyz = ["x", "y", "z"] - -colTitle(1) = "" -rowTitle(1) = "Element type"; astr(1) = ElementName(obj%name) -rowTitle(2) = "Xidimension"; astr(2) = tostring(obj%xiDimension) -rowTitle(3) = "NSD"; astr(3) = tostring(obj%nsd) -rowTitle(4) = "tPoints"; astr(4) = tostring(obj%entityCounts(1)) -rowTitle(5) = "tLines"; astr(5) = tostring(obj%entityCounts(2)) -rowTitle(6) = "tSurfaces"; astr(6) = tostring(obj%entityCounts(3)) -rowTitle(7) = "tVolumes"; astr(7) = tostring(obj%entityCounts(4)) - -tsize = SIZE(obj%xij, 1) -DO j = 1, tsize - rowTitle(7 + j) = xyz(j) -END DO - -ans = MdEncode(val=astr(1:7), rh=rowTitle(1:7), ch=colTitle)// & - & char_lf//"Nodal Coordinates:"//char_lf//char_lf// & - & MdEncode(obj%xij, rh=rowTitle(8:7 + tsize), ch=colTitle) - -IF (obj%entityCounts(1) .GT. 0_I4B) THEN - ans = ans//React_StartTabs()//char_lf - - !! pointTopology - tsize = 0 - DO j = 1, obj%entityCounts(1) - ans = ans//React_StartTabItem( & - & VALUE=tostring(j), & - & label="PointTopology( "//tostring(j)//" ) : ")//char_lf// & - & MdEncode(obj%topology(tsize + j))//char_lf & - & //React_EndTabItem()//char_lf - END DO - - ans = ans//React_EndTabs()//char_lf -END IF - -IF (obj%entityCounts(2) .GT. 0_I4B) THEN - ans = ans//React_StartTabs()//char_lf - - !! edgeTopology - tsize = obj%entityCounts(1) + tsize - DO j = 1, obj%entityCounts(2) - ans = ans//React_StartTabItem( & - & VALUE=tostring(j), & - & label="EdgeTopology( "//tostring(j)//" ) : ")//char_lf// & - & MdEncode(obj%topology(tsize + j))//char_lf & - & //React_EndTabItem()//char_lf - END DO - - ans = ans//React_EndTabs()//char_lf -END IF - -IF (obj%entityCounts(3) .GT. 0_I4B) THEN - ans = ans//React_StartTabs()//char_lf - - !! edgeTopology - tsize = obj%entityCounts(2) + tsize - DO j = 1, obj%entityCounts(3) - ans = ans//React_StartTabItem( & - & VALUE=tostring(j), & - & label="FacetTopology( "//tostring(j)//" ) : ")//char_lf// & - & MdEncode(obj%topology(tsize + j))//char_lf & - & //React_EndTabItem()//char_lf - END DO - - ans = ans//React_EndTabs()//char_lf -END IF - -IF (obj%entityCounts(4) .GT. 0_I4B) THEN - ans = ans//React_StartTabs()//char_lf - - !! edgeTopology - tsize = obj%entityCounts(3) + tsize - DO j = 1, obj%entityCounts(4) - ans = ans//React_StartTabItem( & - & VALUE=tostring(j), & - & label="CellTopology( "//tostring(j)//" ) : ")//char_lf// & - & MdEncode(obj%topology(tsize + j))//char_lf & - & //React_EndTabItem()//char_lf - END DO - - ans = ans//React_EndTabs()//char_lf -END IF - -END PROCEDURE refelem_ReactEncode - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE reftopo_Display -CALL Display(msg, unitno=unitno) -CALL Display("ElemType: "//TRIM(ElementName(obj%Name)), unitno=unitno) -CALL Display("XiDim: "//TRIM(INT2STR(obj%XiDimension)), unitno=unitno) -CALL Display(obj%Nptrs, "Nptrs: ", unitno=unitno) -END PROCEDURE reftopo_Display - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refelem_Display -! Define internal variable -INTEGER(I4B) :: I, j -CALL Display(msg, unitno=unitno) -CALL Display("DomainName : "//TRIM(obj%domainName), & - & unitno=unitno) -CALL Display("ElemType : "//TRIM(ElementName(obj%Name)), & - & unitno=unitno) -CALL Display(obj%XiDimension, "XiDimension :: ", & - & unitno=unitno) -CALL Display(obj%NSD, "NSD : ", & - & unitno=unitno) -CALL Display(obj%Order, "Order : ", & - & unitno=unitno) -CALL Display(obj%EntityCounts(1), "EntityCounts(0) : ", & - & unitno=unitno) -CALL Display(obj%EntityCounts(2), "EntityCounts(1) : ", & - & unitno=unitno) -CALL Display(obj%EntityCounts(3), "EntityCounts(2) : ", & - & unitno=unitno) -CALL Display(obj%EntityCounts(4), "EntityCounts(3) : ", & - & unitno=unitno) - -CALL BlankLines(nol=1, unitNo=unitNo) -DO j = 1, SIZE(obj%XiJ, 2) - CALL EqualLine(unitNo=unitNo) - CALL Display(obj%XiJ(:, j), "Node( "//TRIM(str(j, .TRUE.))//" ) : ", & - & unitno=unitno) - CALL BlankLines(nol=1, unitNo=unitNo) -END DO - -DO j = 1, SIZE(obj%Topology) - CALL EqualLine(unitNo=unitNo) - CALL Display(obj%Topology(j), "Topology( "//TRIM(INT2STR(j))//" ) : ", & - & unitno=unitno) - CALL BlankLines(nol=1, unitNo=unitNo) -END DO - -END PROCEDURE refelem_Display - -END SUBMODULE IOMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 deleted file mode 100644 index 7475d8bf3..000000000 --- a/src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 +++ /dev/null @@ -1,429 +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: 1 March 2021 -! summary: This sumodule contains method for geometry - -SUBMODULE(ReferenceElement_Method) LocalNodeCoordsMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Localnodecoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Local_nodecoord -IF (ALLOCATED(nodecoord)) DEALLOCATE (nodecoord) - -SELECT CASE (ElemType) -CASE (Point1) - ALLOCATE (nodecoord(3, 1)) - nodecoord = 0.0_DFP - -CASE (Line2) - ALLOCATE (nodecoord(3, 2)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [-1.0_DFP, 1.0_DFP] - -CASE (Line3) - ALLOCATE (nodecoord(3, 3)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [-1.0_DFP, 1.0_DFP, 0.0_DFP] - -CASE (Line4) - ALLOCATE (nodecoord(3, 4)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [ & - -1.0_DFP, 1.0_DFP, & - -0.333333333333333_DFP, & - 0.333333333333333_DFP] - -CASE (Line5) - ALLOCATE (nodecoord(3, 5)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [ & - -1.0_DFP, 1.0_DFP, & - -0.5_DFP, 0.0_DFP, & - 0.5_DFP] - -CASE (Line6) - ALLOCATE (nodecoord(3, 6)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [ & - -1.0_DFP, 1.0_DFP, & - -0.666666666666666_DFP, & - -0.333333333333333_DFP, & - 0.666666666666666_DFP, & - 0.333333333333333_DFP] - -CASE (Triangle3) - ALLOCATE (nodecoord(3, 3)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [0.0_DFP, 1.0_DFP, 0.0_DFP] - nodecoord(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP] - -CASE (Triangle6) - ALLOCATE (nodecoord(3, 6)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.5_DFP, 0.5_DFP, 0.0_DFP] - nodecoord(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP, & - & 0.0_DFP, 0.5_DFP, 0.5_DFP] - -CASE (Triangle9) - ALLOCATE (nodecoord(3, 9)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [ & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.33333333333333333333_DFP, & - 0.66666666666666666667_DFP, & - 0.66666666666666666667_DFP, & - 0.33333333333333333333_DFP, & - 0.0_DFP, & - 0.0_DFP] - - nodecoord(2, :) = [ & - 0.0_DFP, & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.33333333333333333333_DFP, & - 0.66666666666666666667_DFP, & - 0.66666666666666666667_DFP, & - 0.33333333333333333333_DFP] - -CASE (Triangle10) - ALLOCATE (nodecoord(3, 10)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [ & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.33333333333333333333_DFP, & - 0.66666666666666666667_DFP, & - 0.66666666666666666667_DFP, & - 0.33333333333333333333_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.33333333333333333333_DFP] - - nodecoord(2, :) = [ & - 0.0_DFP, & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.33333333333333333333_DFP, & - 0.66666666666666666667_DFP, & - 0.66666666666666666667_DFP, & - 0.33333333333333333333_DFP, & - 0.33333333333333333333_DFP] - -CASE (Triangle12) - ! incomplete triangle; all nodes on boundary - ALLOCATE (nodecoord(3, 12)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [ & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.25_DFP, & - 0.5_DFP, & - 0.75_DFP, & - 0.75_DFP, & - 0.5_DFP, & - 0.25_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP] - - nodecoord(2, :) = [ & - 0.0_DFP, & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.25_DFP, & - 0.5_DFP, & - 0.75_DFP, & - 0.75_DFP, & - 0.5_DFP, & - 0.25_DFP] - -CASE (Triangle15a) - ! complete triangle; 12 nodes on boundary and - ! 3 nodes are inside - ALLOCATE (nodecoord(3, 15)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [ & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.25_DFP, & - 0.5_DFP, & - 0.75_DFP, & - 0.75_DFP, & - 0.5_DFP, & - 0.25_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.25_DFP, & - 0.5_DFP, & - 0.25_DFP] - - nodecoord(2, :) = [ & - 0.0_DFP, & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.25_DFP, & - 0.5_DFP, & - 0.75_DFP, & - 0.75_DFP, & - 0.5_DFP, & - 0.25_DFP, & - 0.25_DFP, & - 0.25_DFP, & - 0.5_DFP] - -CASE (Triangle15b) - ! Incomplete triangle - ALLOCATE (nodecoord(3, 15)) - nodecoord = 0.0_DFP - - nodecoord(1, :) = [ & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.2_DFP, & - 0.4_DFP, & - 0.6_DFP, & - 0.8_DFP, & - 0.8_DFP, & - 0.6_DFP, & - 0.4_DFP, & - 0.2_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP] - - nodecoord(2, :) = [ & - 0.0_DFP, & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.2_DFP, & - 0.4_DFP, & - 0.6_DFP, & - 0.8_DFP, & - 0.8_DFP, & - 0.6_DFP, & - 0.4_DFP, & - 0.2_DFP] - -CASE (Triangle21) - ALLOCATE (nodecoord(3, 21)) - nodecoord = 0.0_DFP - - nodecoord(1, :) = [ & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.2_DFP, & - 0.4_DFP, & - 0.6_DFP, & - 0.8_DFP, & - 0.8_DFP, & - 0.6_DFP, & - 0.4_DFP, & - 0.2_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.2_DFP, & - 0.6_DFP, & - 0.2_DFP, & - 0.4_DFP, & - 0.4_DFP, & - 0.2_DFP] - - nodecoord(2, :) = [ & - 0.0_DFP, & - 0.0_DFP, & - 1.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.0_DFP, & - 0.2_DFP, & - 0.4_DFP, & - 0.6_DFP, & - 0.8_DFP, & - 0.8_DFP, & - 0.6_DFP, & - 0.4_DFP, & - 0.2_DFP, & - 0.2_DFP, & - 0.2_DFP, & - 0.6_DFP, & - 0.2_DFP, & - 0.4_DFP, & - 0.4_DFP] - -CASE (Quadrangle4) - ALLOCATE (nodecoord(3, 4)) - nodecoord = 0.0_DFP - nodecoord(1, :) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, 1.0_DFP] - nodecoord(2, :) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP] - -CASE (Quadrangle8) - nodecoord = RESHAPE([ & - -1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_DFP, 1.0_DFP, 0.0_DFP, & - 0.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, 0.0_DFP, 0.0_DFP, & - 0.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 8]) - -CASE (Quadrangle9) - nodecoord = RESHAPE([ & - -1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_DFP, 1.0_DFP, 0.0_DFP, & - 0.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, 0.0_DFP, 0.0_DFP, & - 0.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_DFP, 0.0_DFP, 0.0_DFP, & - 0.0_DFP, 0.0_DFP, 0.0_DFP], [3, 9]) - -CASE (Quadrangle16) - nodecoord = RESHAPE([ & - -1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_dfp/3.0_dfp, -1.0_DFP, 0.0_DFP, & - 1.0_dfp/3.0_dfp, -1.0_DFP, 0.0_DFP, & - 1.0_dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & - 1.0_dfp, 1.0_DFP/3.0_dfp, 0.0_DFP, & - 1.0_dfp/3.0_dfp, 1.0_DFP, 0.0_DFP, & - -1.0_dfp/3.0_dfp, 1.0_DFP, 0.0_DFP, & - -1.0_dfp, 1.0_DFP/3.0_dfp, 0.0_DFP, & - -1.0_dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & - -1.0_dfp/3.0_Dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & - 1.0_dfp/3.0_Dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & - 1.0_dfp/3.0_Dfp, 1.0_DFP/3.0_dfp, 0.0_DFP, & - -1.0_dfp/3.0_Dfp, 1.0_DFP/3.0_dfp, 0.0_DFP], & - [3, 16]) - -CASE (Hexahedron8) - nodecoord = RESHAPE([ & - -1.0_DFP, -1.0_DFP, -1.0_DFP, & - 1.0_DFP, -1.0_DFP, -1.0_DFP, & - 1.0_DFP, 1.0_DFP, -1.0_DFP, & - -1.0_DFP, 1.0_DFP, -1.0_DFP, & - -1.0_DFP, -1.0_DFP, 1.0_DFP, & - 1.0_DFP, -1.0_DFP, 1.0_DFP, & - 1.0_DFP, 1.0_DFP, 1.0_DFP, & - -1.0_DFP, 1.0_DFP, 1.0_DFP], [3, 8]) - -CASE (Hexahedron20) - nodecoord = RESHAPE([ & - -1.0_DFP, -1.0_DFP, -1.0_DFP, & - 1.0_DFP, -1.0_DFP, -1.0_DFP, & - 1.0_DFP, 1.0_DFP, -1.0_DFP, & - -1.0_DFP, 1.0_DFP, -1.0_DFP, & - -1.0_DFP, -1.0_DFP, 1.0_DFP, & - 1.0_DFP, -1.0_DFP, 1.0_DFP, & - 1.0_DFP, 1.0_DFP, 1.0_DFP, & - -1.0_DFP, 1.0_DFP, 1.0_DFP, & - 0.0_DFP, -1.0_DFP, -1.0_DFP, & - -1.0_DFP, 0.0_DFP, -1.0_DFP, & - -1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, 0.0_DFP, -1.0_DFP, & - 1.0_DFP, -1.0_DFP, 0.0_DFP, & - 0.0_DFP, 1.0_DFP, -1.0_DFP, & - 1.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_DFP, 1.0_DFP, 0.0_DFP, & - 0.0_DFP, -1.0_DFP, 1.0_DFP, & - -1.0_DFP, 0.0_DFP, 1.0_DFP, & - 1.0_DFP, 0.0_DFP, 1.0_DFP, & - 0.0_DFP, 1.0_DFP, 1.0_DFP], [3, 20]) - -CASE (Hexahedron27) - nodecoord = RESHAPE([ & - -1.0_DFP, -1.0_DFP, -1.0_DFP, & - 1.0_DFP, -1.0_DFP, -1.0_DFP, & - 1.0_DFP, 1.0_DFP, -1.0_DFP, & - -1.0_DFP, 1.0_DFP, -1.0_DFP, & - -1.0_DFP, -1.0_DFP, 1.0_DFP, & - 1.0_DFP, -1.0_DFP, 1.0_DFP, & - 1.0_DFP, 1.0_DFP, 1.0_DFP, & - -1.0_DFP, 1.0_DFP, 1.0_DFP, & - 0.0_DFP, -1.0_DFP, -1.0_DFP, & - -1.0_DFP, 0.0_DFP, -1.0_DFP, & - -1.0_DFP, -1.0_DFP, 0.0_DFP, & - 1.0_DFP, 0.0_DFP, -1.0_DFP, & - 1.0_DFP, -1.0_DFP, 0.0_DFP, & - 0.0_DFP, 1.0_DFP, -1.0_DFP, & - 1.0_DFP, 1.0_DFP, 0.0_DFP, & - -1.0_DFP, 1.0_DFP, 0.0_DFP, & - 0.0_DFP, -1.0_DFP, 1.0_DFP, & - -1.0_DFP, 0.0_DFP, 1.0_DFP, & - 1.0_DFP, 0.0_DFP, 1.0_DFP, & - 0.0_DFP, 1.0_DFP, 1.0_DFP, & - 0.0_DFP, 0.0_DFP, -1.0_DFP, & - 0.0_DFP, -1.0_DFP, 0.0_DFP, & - -1.0_DFP, 0.0_DFP, 0.0_DFP, & - 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, & - 0.0_DFP, 0.0_DFP, 0.0_DFP], [3, 27]) -END SELECT - -END PROCEDURE Local_nodecoord - -!----------------------------------------------------------------------------- -! FacetMatrix -!----------------------------------------------------------------------------- - -MODULE PROCEDURE Local_nodecoord_refelem -IF (ALLOCATED(refelem%xij)) THEN - nodecoord = refelem%xij -ELSE - ALLOCATE (nodecoord(0, 0)) -END IF -END PROCEDURE Local_nodecoord_refelem - -END SUBMODULE LocalNodeCoordsMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 deleted file mode 100644 index 17ecc9228..000000000 --- a/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 +++ /dev/null @@ -1,154 +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: 2 March 2021 -! summary: VTK format element - -SUBMODULE(ReferenceElement_Method) VTKMethods -USE Utility, ONLY: arange -IMPLICIT NONE - -INTEGER(I4B), PARAMETER :: & - & vtk_point = 1, & - & vtk_line2 = 3, & - & vtk_triangle3 = 5, & - & vtk_quadrangle4 = 9, & - & vtk_tetrahedron4 = 10, & - & vtk_hexahedron8 = 12, & - & vtk_prism6 = 13, & - & vtk_pyramid5 = 14, & - & vtk_line3 = 21, & - & vtk_triangle6 = 22, & - & vtk_quadrangle8 = 23, & - & vtk_quadrangle9 = 28, & - & vtk_tetrahedron10 = 24, & - & vtk_hexahedron20 = 25, & - & vtk_hexahedron27 = 29, & - & vtk_prism15 = 26, & - & vtk_prism18 = 32, & - & vtk_line4 = 35, & - & vtk_pyramid13 = 27, & - & vtk_quadrangle16 = 70 -! VTK_LAGRANGE_QUADRILATERAL -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_vtk_elemType - -SELECT CASE (ElemType) -CASE (Point1) - vtk_type = vtk_point - nptrs = [1] - -CASE (Line2) - vtk_type = vtk_line2 - nptrs = [1, 2] - -CASE (Triangle3) - vtk_type = vtk_triangle3 - nptrs = [1, 2, 3] - -CASE (Quadrangle4) - vtk_type = vtk_quadrangle4 - nptrs = [1, 2, 3, 4] - -CASE (Tetrahedron4) - vtk_type = vtk_Tetrahedron4 - nptrs = [1, 2, 3, 4] - -CASE (Hexahedron8) - vtk_type = vtk_Hexahedron8 - nptrs = [1, 2, 3, 4, 5, 6, 7, 8] - -CASE (Prism6) - vtk_type = vtk_Prism6 - nptrs = [1, 2, 3, 4, 5, 6] - -CASE (Pyramid5) - vtk_type = vtk_Pyramid5 - nptrs = [1, 2, 3, 4, 5] - - !! Order=2 elements -CASE (Line3) - vtk_type = vtk_line3 - nptrs = [1, 2, 3] - -CASE (Triangle6) - vtk_type = vtk_Triangle6 - nptrs = [1, 2, 3, 4, 5, 6] - -CASE (Quadrangle9) - vtk_type = vtk_Quadrangle9 - nptrs = [1, 2, 3, 4, 5, 6, 7, 8, 9] - -CASE (Quadrangle8) - vtk_type = vtk_Quadrangle8 - nptrs = [1, 2, 3, 4, 5, 6, 7, 8] - -CASE (Tetrahedron10) - vtk_type = vtk_Tetrahedron10 - nptrs = 1 + [0, 1, 2, 3, 4, 5, 6, 7, 9, 8] - -CASE (Hexahedron20) - vtk_type = vtk_Hexahedron20 - nptrs = 1 + [0, 1, 2, 3, 4, 5, 6, 7, & - & 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14] - -CASE (Hexahedron27) - vtk_type = vtk_Hexahedron27 - nptrs = 1 + [0, 1, 2, 3, 4, 5, 6, 7, & - & 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14, & - & 24, 22, 20, 21, 23, 25, 26] - -CASE (Prism15) - vtk_type = vtk_Prism15 - nptrs = 1 + [0, 1, 2, 3, 4, 5, & - & 6, 8, 12, 7, 13, 14, 9, 11, 10] - -CASE (Prism18) - vtk_type = vtk_Prism18 - nptrs = 1 + [0, 1, 2, 3, 4, 5, & - & 6, 8, 12, 7, 13, 14, 9, 11, 10, & - & 15, 17, 16] - -CASE (Pyramid13) - vtk_type = vtk_Pyramid13 - nptrs = 1 + [0, 1, 2, 3, 4, 5, & - & 5, 8, 9, 6, 10, 7, 11, 12] - -CASE (Pyramid14) - vtk_type = vtk_Pyramid13 - nptrs = 1 + [0, 1, 2, 3, 4, 5, & - & 5, 8, 9, 6, 10, 7, 11, 12] - - !! order=3 element -CASE (Line4) - vtk_type = vtk_line4 - nptrs = [1, 2, 3, 4] - -CASE (Quadrangle16) - vtk_type = vtk_Quadrangle16 - nptrs = [1, 2, 3, 4, 5, 6, 7, 8, 10, 9, & - 12, 11, 13, 14, 16, 15] -END SELECT -END PROCEDURE get_vtk_elemType - -END SUBMODULE VTKMethods diff --git a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 deleted file mode 100644 index 82e3b9346..000000000 --- a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 +++ /dev/null @@ -1,629 +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: 2 March 2021 -! summary: This module contains method for [[ReferenceHexahedron_]] - -SUBMODULE(ReferenceHexahedron_Method) Methods -USE ReferenceElement_Method -USE ApproxUtility -USE InvUtility -USE InputUtility -USE StringUtility -USE ArangeUtility -USE MiscUtility, ONLY: Int2STR - -USE ReferenceLine_Method, ONLY: ElementType_Line - -USE ReferenceQuadrangle_Method, ONLY: RefQuadrangleCoord, & - & ElementOrder_Quadrangle, & - & TotalEntities_Quadrangle, & - & FacetTopology_Quadrangle - -USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle - -USE HexahedronInterpolationUtility, ONLY: LagrangeDOF_Hexahedron, & - & InterpolationPoint_Hexahedron - -USE ReferencePrism_Method, ONLY: PolyhedronVolume3d -USE ReallocateUtility - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElementName_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementName_Hexahedron -SELECT CASE (elemType) -CASE (Hexahedron8) - ans = "Hexahedron8" - -CASE (Hexahedron27) - ans = "Hexahedron27" - -CASE (Hexahedron20) - ans = "Hexahedron20" - -CASE (Hexahedron64) - ans = "Hexahedron64" - -CASE (Hexahedron125) - ans = "Hexahedron125" - -CASE DEFAULT - ans = "NONE" -END SELECT - -END PROCEDURE ElementName_Hexahedron - -!---------------------------------------------------------------------------- -! FacetElements_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Hexahedron1 -INTEGER(I4B) :: ii, istart, tsize, jj -TYPE(ReferenceTopology_) :: topo - -istart = refelem%entityCounts(1) + refelem%entityCounts(2) -! tPoints + tEdges - -ii = 1 -ans(ii)%nsd = refelem%nsd -ans(ii)%interpolationPointType = refelem%interpolationPointType -ans(ii)%xij = InterpolationPoint_Quadrangle( & - & order=refelem%order, & - & ipType=refelem%interpolationPointType, & - & layout="VEFC") - -DO ii = 2, 4 - ans(ii)%nsd = ans(1)%nsd - ans(ii)%interpolationPointType = ans(1)%interpolationPointType - ans(ii)%xij = ans(1)%xij -END DO - -DO ii = 1, 4 - - topo = refelem%topology(istart + ii) - ans(ii)%xidimension = topo%xidimension - ans(ii)%name = topo%name - - ans(ii)%order = ElementOrder_Quadrangle(topo%name) - ans(ii)%entityCounts = TotalEntities_Quadrangle(topo%name) - - tsize = SUM(ans(ii)%entityCounts) - ! ALLOCATE (ans(ii)%topology(tsize)) - CALL RefTopoReallocate(ans(ii)%topology, tsize) - - ! points - DO jj = 1, ans(ii)%entityCounts(1) - ans(ii)%topology(jj) = ReferenceTopology(nptrs=topo%nptrs(jj:jj), & - & name=Point) - END DO - - ! lines - jj = ans(ii)%entityCounts(1) - CALL FacetTopology_Quadrangle(elemType=topo%name, & - & nptrs=topo%nptrs, ans=ans(ii)%topology(jj + 1:)) - - ! surface - tsize = jj + ans(ii)%entityCounts(2) - ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=topo%nptrs, & - & name=topo%name) - -END DO - -CALL DEALLOCATE (topo) - -END PROCEDURE FacetElements_Hexahedron1 - -!---------------------------------------------------------------------------- -! FacetElements_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Hexahedron2 -INTEGER(I4B), PARAMETER :: tface = 6 -INTEGER(I4B) :: ii, jj, order, entityCounts(4), tsize -INTEGER(I4B), ALLOCATABLE :: edgeCon(:, :), faceCon(:, :) -INTEGER(I4B) :: faceElemType(tface), tFaceNodes(tface) - -CALL GetFaceElemType_Hexahedron( & - & faceElemType=faceElemType, & - & tFaceNodes=tFaceNodes, & - & elemType=elemType) - -entityCounts = TotalEntities_Hexahedron(elemType) -order = ElementOrder_Hexahedron(elemType) - -CALL Reallocate(edgeCon, order + 1, entityCounts(2)) -CALL Reallocate(faceCon, tFaceNodes(1), tface) - -CALL GetEdgeConnectivity_Hexahedron(con=edgeCon, order=order) -CALL GetFaceConnectivity_Hexahedron(con=faceCon, order=order) - -DO ii = 1, tface - - ans(ii)%xiDimension = 2 - ans(ii)%order = order - ans(ii)%name = faceElemType(ii) - ans(ii)%interpolationPointType = Equidistance - - ans(ii)%xij = InterpolationPoint_Quadrangle( & - & order=ans(ii)%order, & - & ipType=ans(ii)%interpolationPointType, & - & layout="VEFC") - - ans(ii)%nsd = nsd - ans(ii)%entityCounts = TotalEntities_Quadrangle(ans(ii)%name) - - tsize = SUM(ans(ii)%entityCounts) - CALL RefTopoReallocate(ans(ii)%topology, tsize) - ! ALLOCATE (ans(ii)%topology(tsize)) - - ! points - DO jj = 1, ans(ii)%entityCounts(1) - ans(ii)%topology(jj) = Referencetopology(nptrs=faceCon(jj:jj, ii), & - & name=Point) - END DO - - ! lines - jj = ans(ii)%entityCounts(1) - CALL FacetTopology_Quadrangle(elemType=ans(ii)%name, & - & nptrs=faceCon(:, ii), ans=ans(ii)%topology(jj + 1:)) - - ! surface - tsize = jj + ans(ii)%entityCounts(2) - ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=faceCon(:, ii), & - & name=ans(ii)%name) - -END DO - -IF (ALLOCATED(edgeCon)) DEALLOCATE (edgeCon) -IF (ALLOCATED(faceCon)) DEALLOCATE (faceCon) -END PROCEDURE FacetElements_Hexahedron2 - -!---------------------------------------------------------------------------- -! FacetTopology_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetTopology_Hexahedron -INTEGER(I4B), PARAMETER :: tface = 6 -INTEGER(I4B) :: ii, faceElemType(tface), tFaceNodes(tface) -INTEGER(I4B), ALLOCATABLE :: con(:, :) - -CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, & - & elemType=elemType, tFaceNodes=tFaceNodes) - -CALL Reallocate(con, tFaceNodes(1), tface) - -ii = ElementOrder_Hexahedron(elemType=elemType) -CALL GetFaceConnectivity_Hexahedron(con=con, order=ii) - -DO ii = 1, tface - ans(ii)%nptrs = nptrs(con(1:tFaceNodes(ii), ii)) - ans(ii)%xiDimension = 2 - ans(ii)%name = faceElemType(ii) -END DO - -IF (ALLOCATED(con)) DEALLOCATE (con) -END PROCEDURE FacetTopology_Hexahedron - -!---------------------------------------------------------------------------- -! TotalEntities_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalEntities_Hexahedron -ans(2:4) = [12, 6, 1] -ans(1) = TotalNodesInElement_Hexahedron(elemType) -END PROCEDURE TotalEntities_Hexahedron - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Hexahedron -SELECT CASE (elemType) -CASE (Hexahedron8) - ans = 8 -CASE (Hexahedron20) - ans = 20 -CASE (Hexahedron27) - ans = 27 -CASE (Hexahedron64) - ans = 64 -CASE (Hexahedron125) - ans = 125 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Hexahedron - -!---------------------------------------------------------------------------- -! ElementType_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementType_Hexahedron -SELECT CASE (elemName) -CASE ("Hexahedron8", "Hexahedron") - ans = Hexahedron8 -CASE ("Hexahedron20") - ans = Hexahedron20 -CASE ("Hexahedron27") - ans = Hexahedron27 -CASE ("Hexahedron64") - ans = Hexahedron64 -CASE ("Hexahedron125") - ans = Hexahedron125 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementType_Hexahedron - -!---------------------------------------------------------------------------- -! ElementOrder_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementOrder_Hexahedron -SELECT CASE (ElemType) -CASE (Hexahedron) - ans = 1 -CASE (Hexahedron20) - ans = 2 -CASE (Hexahedron27) - ans = 2 -CASE (Hexahedron64) - ans = 3 -CASE (Hexahedron125) - ans = 4 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementOrder_Hexahedron - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_Ref_Hexahedron -INTEGER(I4B) :: ii, jj -INTEGER(I4B) :: p1p2(2, 12), lloop(4, 6), vol(8, 1) -REAL(DFP) :: unit_xij(3, 8), biunit_xij(3, 8) - -CALL DEALLOCATE (obj) -unit_xij = RefCoord_Hexahedron("UNIT") -biunit_xij = RefCoord_Hexahedron("BIUNIT") - -IF (PRESENT(xij)) THEN - obj%xij = xij(1:3, 1:8) - IF (ALL(obj%xij(1:3, 1:8) .approxeq.unit_xij)) THEN - obj%domainName = "UNIT" - ELSE IF (ALL(obj%xij(1:3, 1:8) .approxeq.biunit_xij)) THEN - obj%domainName = "BIUNIT" - ELSE - obj%domainName = "GENERAL" - END IF - -ELSE - - IF (PRESENT(domainName)) THEN - obj%domainName = UpperCase(domainName) - IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN - obj%xij = RefCoord_Hexahedron(obj%domainName) - END IF - ELSE - obj%domainName = "BIUNIT" - obj%xij = RefCoord_Hexahedron(obj%domainName) - END IF - -END IF - -CALL GetEdgeConnectivity_Hexahedron(con=p1p2, order=1_I4B) -CALL GetFaceConnectivity_Hexahedron(con=lloop, order=1_I4B) - -vol(:, 1) = arange(1_I4B, 8_I4B) - -obj%entityCounts = TotalEntities_Hexahedron(Hexahedron8) -obj%xidimension = 3 -obj%name = Hexahedron8 -obj%order = 1 -obj%nsd = nsd - -ii = SUM(obj%entityCounts) -CALL RefTopoReallocate(obj%topology, ii) - -! points -DO ii = 1, obj%entityCounts(1) - obj%topology(ii) = ReferenceTopology([ii], Point) -END DO - -! lines -jj = obj%entityCounts(1) -DO ii = 1, obj%entityCounts(2) - obj%topology(jj + ii) = ReferenceTopology(nptrs=p1p2(:, ii), & - & name=Line2) -END DO - -! faces -jj = jj + obj%entityCounts(2) -DO ii = 1, obj%entityCounts(3) - obj%topology(jj + ii) = ReferenceTopology(nptrs=lloop(:, ii), & - & name=Quadrangle4) -END DO - -! cell -jj = jj + obj%entityCounts(3) -obj%topology(jj + 1) = ReferenceTopology(vol(:, 1), Hexahedron8) - -obj%highorderElement => HighorderElement_Hexahedron -END PROCEDURE Initiate_Ref_Hexahedron - -!---------------------------------------------------------------------------- -! ReferenceHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Hexahedron -CALL Initiate_Ref_Hexahedron(obj=obj, nsd=NSD, xij=xij, & - & domainName=domainName) -END PROCEDURE Reference_Hexahedron - -!---------------------------------------------------------------------------- -! ReferenceHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Hexahedron_Pointer -ALLOCATE (obj) -CALL Initiate_Ref_Hexahedron(obj=obj, nsd=NSD, xij=xij, & - & domainName=domainName) -END PROCEDURE Reference_Hexahedron_Pointer - -!---------------------------------------------------------------------------- -! highOrderElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HighorderElement_Hexahedron -INTEGER(I4B) :: ii, tFaceNodes(8), faceElemType(8), jj, & - & edgetype -INTEGER(I4B), ALLOCATABLE :: edgecon(:, :), facecon(:, :) - -CALL DEALLOCATE (obj) - -obj%xij = InterpolationPoint_Hexahedron( & - & xij=refelem%xij(1:3, 1:8), & - & order=order, & - & ipType=ipType, & - & layout="VEFC") - -obj%domainName = refelem%domainName -obj%nsd = refelem%nsd -obj%highOrderElement => refelem%highOrderElement -obj%order = order -obj%xiDimension = refelem%xiDimension - -ii = LagrangeDOF_Hexahedron(order=order) -obj%name = ElementType_Hexahedron("Hexahedron"//INT2STR(ii)) -obj%entityCounts = TotalEntities_Hexahedron(obj%name) - -ii = SUM(obj%entityCounts) -CALL RefTopoReallocate(obj%topology, ii) - -! points -DO ii = 1, obj%entityCounts(1) - obj%topology(ii) = ReferenceTopology([ii], Point) -END DO - -CALL Reallocate(edgecon, order + 1, obj%entityCounts(2)) -CALL GetEdgeConnectivity_Hexahedron(con=edgecon, order=order) -edgetype = ElementType_Line("Line"//Int2STR(order + 1)) - -! lines -jj = obj%entityCounts(1) -DO ii = 1, obj%entityCounts(2) - obj%topology(jj + ii) = ReferenceTopology(nptrs=edgecon(:, ii), & - & name=edgetype) -END DO - -CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, & - & tFaceNodes=tFaceNodes, elemType=obj%name) -CALL Reallocate(facecon, tFaceNodes(1), obj%entityCounts(3)) -CALL GetFaceConnectivity_Hexahedron(con=facecon, order=order) - -! faces -jj = jj + obj%entityCounts(2) -DO ii = 1, obj%entityCounts(3) - obj%topology(jj + ii) = ReferenceTopology( & - & nptrs=facecon(1:tFaceNodes(ii), ii), & - & name=faceElemType(ii)) -END DO - -! cell -jj = jj + obj%entityCounts(3) -obj%topology(jj + 1) = ReferenceTopology( & - & arange(1_I4B, obj%entityCounts(1)), obj%name) - -IF (ALLOCATED(edgecon)) DEALLOCATE (edgecon) -IF (ALLOCATED(facecon)) DEALLOCATE (facecon) - -END PROCEDURE HighorderElement_Hexahedron - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Hexahedron -INTEGER(I4B) :: Order0(6), Node0(6, 4), FM(6, 7), iFace, b -Order0 = [4, 4, 4, 4, 4, 4] -FM = FacetMatrix(RefElem) -DO iFace = 1, 6 - b = FM(iFace, 3) + 3 - Node0(iFace, 1:Order0(iFace)) = FM(iFace, 4:b) -END DO -CALL PolyhedronVolume3d(coord=XiJ(1:3, 1:8), & - & order_max=4, face_num=6, node=node0, node_num=8, & - & order=order0, ans=ans) -END PROCEDURE Measure_Simplex_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Hexahedron_Quality -ans = 0.0_I4B -! TODO Implement Hexahedron_quality -END PROCEDURE Hexahedron_quality - -!---------------------------------------------------------------------------- -! HexahedronVolume3D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HexahedronVolume3D -TYPE(ReferenceHexahedron_) :: refelem -CALL Initiate_Ref_Hexahedron(obj=refelem, nsd=3_I4B) -ans = Measure_Simplex_Hexahedron(refelem=refelem, xij=xij) -CALL DEALLOCATE (refelem) -END PROCEDURE HexahedronVolume3D - -!---------------------------------------------------------------------------- -! RefHexahedronCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefHexahedronCoord -REAL(DFP) :: one, mone -CHARACTER(:), ALLOCATABLE :: astr - -astr = UpperCase(refHexahedron) - -SELECT CASE (astr) -CASE ("UNIT") - one = 1.0_DFP - mone = 0.0_DFP -CASE ("BIUNIT") - one = 1.0_DFP - mone = -1.0_DFP -END SELECT - -astr = "" - -ans(3, 1:4) = mone -ans(3, 5:8) = one -ans(1:2, 1:4) = RefQuadrangleCoord(refHexahedron) -ans(1:2, 5:8) = ans(1:2, 1:4) -END PROCEDURE RefHexahedronCoord - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity_Hexahedron -INTEGER(I4B) :: order0, ii, jj, iface -con(1:2, 1) = [1, 2] -con(1:2, 2) = [1, 4] -con(1:2, 3) = [1, 5] -con(1:2, 4) = [2, 3] -con(1:2, 5) = [2, 6] -con(1:2, 6) = [3, 4] -con(1:2, 7) = [3, 7] -con(1:2, 8) = [4, 8] -con(1:2, 9) = [5, 6] -con(1:2, 10) = [5, 8] -con(1:2, 11) = [6, 7] -con(1:2, 12) = [7, 8] - -order0 = Input(default=1_I4B, option=order) - -IF (PRESENT(ncol)) ncol = 12 -IF (PRESENT(nrow)) nrow = order0 + 1 - -jj = 8 -DO iface = 1, 12 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - END DO - jj = jj + order0 - 1 -END DO - -END PROCEDURE GetEdgeConnectivity_Hexahedron - -!---------------------------------------------------------------------------- -! GetFaceConnectivity_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity_Hexahedron -INTEGER(I4B) :: order0, ii -con(1:4, 1) = [1, 4, 3, 2] ! back -con(1:4, 2) = [5, 6, 7, 8] ! front -con(1:4, 3) = [1, 5, 8, 4] ! left -con(1:4, 4) = [2, 3, 7, 6] ! right -con(1:4, 5) = [1, 2, 6, 5] ! bottom -con(1:4, 6) = [3, 4, 8, 7] ! top - -order0 = Input(default=1_I4B, option=order) - -IF (PRESENT(ncol)) ncol = 6 - -ii = 5 - -SELECT CASE (order0) -CASE (2_I4B) - con(ii:8, 1) = [10, 14, 12, 9, 21] ! back - con(ii:8, 2) = [17, 19, 20, 18, 22] ! front - con(ii:8, 3) = [11, 18, 16, 10, 23] ! left - con(ii:8, 4) = [12, 15, 19, 13, 24] ! right - con(ii:8, 5) = [9, 13, 17, 11, 25] ! bottom - con(ii:8, 6) = [14, 16, 20, 15, 26] ! top - ii = 9 -END SELECT - -IF (PRESENT(nrow)) nrow = ii - 1 - -END PROCEDURE GetFaceConnectivity_Hexahedron - -!---------------------------------------------------------------------------- -! GetFaceElemType_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType_Hexahedron -INTEGER(I4B) :: elemType0 -elemType0 = Input(default=Hexahedron8, option=elemType) - -SELECT CASE (elemType0) -CASE (Hexahedron8) - - IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle4 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 4_I4B - -CASE (Hexahedron20) - IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle8 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 8_I4B - -CASE (Hexahedron27) - IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle9 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 9_I4B - -CASE (Hexahedron64) - IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle16 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 16_I4B - -END SELECT -END PROCEDURE GetFaceElemType_Hexahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 deleted file mode 100644 index 918998090..000000000 --- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 +++ /dev/null @@ -1,376 +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: 2 March 2021 -! summary: This submodule contains methods for [[ReferenceLine_]] - -SUBMODULE(ReferenceLine_Method) Methods -USE ReallocateUtility -USE ReferenceElement_Method -USE StringUtility -USE ApproxUtility -USE String_Class, ONLY: String -USE LineInterpolationUtility -USE Display_Method -USE InputUtility -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElementName_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementName_Line -SELECT CASE (elemType) -CASE (Point1) - ans = "Point1" -CASE (Line2) - ans = "Line2" -CASE (Line3) - ans = "Line3" -CASE (Line4) - ans = "Line4" -CASE (Line5) - ans = "Line5" -CASE (Line6) - ans = "Line6" -CASE DEFAULT - ans = "NONE" -END SELECT -END PROCEDURE ElementName_Line - -!---------------------------------------------------------------------------- -! FacetTopology_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetTopology_Line -ans(1)%nptrs = nptrs([1]) -ans(1)%xiDimension = 0 -ans(1)%name = Point - -ans(2)%nptrs = nptrs([2]) -ans(2)%xiDimension = 0 -ans(2)%name = Point -END PROCEDURE FacetTopology_Line - -!---------------------------------------------------------------------------- -! TotalEntities_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalEntities_Line -ans(1) = TotalNodesInElement_Line(elemType) -ans(2) = 1 -ans(3:4) = 0 -END PROCEDURE TotalEntities_Line - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Line -SELECT CASE (ElemType) -CASE (Line1) - ans = 1 -CASE (Line2) - ans = 2 -CASE (Line3) - ans = 3 -CASE (Line4) - ans = 4 -CASE (Line5) - ans = 5 -CASE (Line6) - ans = 6 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Line - -!---------------------------------------------------------------------------- -! ElementOrder_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementOrder_Line -SELECT CASE (elemType) -CASE (Line2) - ans = 1 -CASE (Line3) - ans = 2 -CASE (Line4) - ans = 3 -CASE (Line5) - ans = 4 -CASE (Line6) - ans = 5 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementOrder_Line - -!---------------------------------------------------------------------------- -! ElementType_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementType_Line -SELECT CASE (elemName) -CASE ("Line1", "Point", "Point1") - ans = Point -CASE ("Line2", "Line") - ans = Line2 -CASE ("Line3") - ans = Line3 -CASE ("Line4") - ans = Line4 -CASE ("Line5") - ans = Line5 -CASE ("Line6") - ans = Line6 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementType_Line - -!---------------------------------------------------------------------------- -! FacetElements_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Line1 -INTEGER(I4B) :: ii -INTEGER(I4B) :: nptrs(1) - -DO ii = 1, 2 - nptrs = refelem%topology(ii)%nptrs - CALL Reallocate(ans(ii)%xij, 3_I4B, 1) - ans(ii)%xij(1:3, 1) = DEFAULT_REF_LINE_COORD(1:3, ii) - ans(ii)%entityCounts = [1, 0, 0, 0] - ans(ii)%xiDimension = 0 - ans(ii)%name = Point - ans(ii)%interpolationPointType = refelem%interpolationPointType - ans(ii)%order = 0 - ans(ii)%nsd = refelem%nsd - ALLOCATE (ans(ii)%topology(1)) - ans(ii)%topology(1) = Referencetopology(nptrs=nptrs, name=Point) - ans(ii)%highOrderElement => NULL() -END DO -END PROCEDURE FacetElements_Line1 - -!---------------------------------------------------------------------------- -! FacetElements_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Line2 -INTEGER(I4B), PARAMETER :: nptrs(2) = [1, 2] -INTEGER(I4B) :: ii - -DO ii = 1, 2 - ans(ii)%xij = RESHAPE(DEFAULT_REF_LINE_COORD(1:3, ii), [3, 1]) - ans(ii)%entityCounts = [1, 0, 0, 0] - ans(ii)%xiDimension = 0 - ans(ii)%name = Point - ans(ii)%interpolationPointType = Equidistance - ans(ii)%order = 0 - ans(ii)%nsd = nsd - ALLOCATE (ans(ii)%topology(1)) - ans(ii)%topology(1) = Referencetopology(nptrs=nptrs(ii:ii), name=Point) - ans(ii)%highOrderElement => NULL() -END DO -END PROCEDURE FacetElements_Line2 - -!---------------------------------------------------------------------------- -! LineName -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LineName1 -SELECT CASE (order) -CASE (1) - ans = Line2 -CASE (2) - ans = Line3 -CASE (3) - ans = Line4 -CASE (4) - ans = Line5 -CASE (5) - ans = Line6 -CASE (6:) - ans = Line6 * 100 + order - 5 -END SELECT -END PROCEDURE LineName1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_ref_Line -REAL(DFP) :: unit_xij(1, 2), biunit_xij(1, 2) - -CALL DEALLOCATE (obj) - -unit_xij = RefCoord_Line("UNIT") -biunit_xij = RefCoord_Line("BIUNIT") - -IF (PRESENT(xij)) THEN - obj%xij = xij(1:1, 1:2) - IF (ALL(obj%xij(1:1, 1:2) .approxeq.unit_xij)) THEN - obj%domainName = "UNIT" - ELSE IF (ALL(obj%xij(1:1, 1:2) .approxeq.biunit_xij)) THEN - obj%domainName = "BIUNIT" - ELSE - obj%domainName = "GENERAL" - END IF -ELSE - IF (PRESENT(domainName)) THEN - obj%domainName = UpperCase(domainName) - IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN - obj%xij = RefCoord_Line(obj%domainName) - END IF - ELSE - obj%domainName = "BIUNIT" - obj%xij = RefCoord_Line(obj%domainName) - END IF -END IF - -obj%entityCounts = [2, 1, 0, 0] -obj%xiDimension = 1 -obj%order = 1 -obj%nsd = nsd -obj%name = Line2 -ALLOCATE (obj%topology(3)) -obj%topology(1) = ReferenceTopology([1], Point) -obj%topology(2) = ReferenceTopology([2], Point) -obj%topology(3) = ReferenceTopology([1, 2], Line2) -obj%highorderElement => highorderElement_Line -END PROCEDURE Initiate_ref_Line - -!---------------------------------------------------------------------------- -! ReferenceLine -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Line -CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) -END PROCEDURE Reference_Line - -!---------------------------------------------------------------------------- -! ReferenceLine_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Line_Pointer_1 -ALLOCATE (obj) -CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) -END PROCEDURE Reference_Line_Pointer_1 - -!---------------------------------------------------------------------------- -! LagrangeElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HighorderElement_Line -INTEGER(I4B) :: nns, i -obj%xij = InterpolationPoint_Line( & - & xij=refelem%xij, & - & order=order, & - & ipType=ipType, & - & layout="VEFC") -obj%domainName = refelem%domainName -obj%nsd = refelem%nsd -nns = SIZE(obj%xij, 2) -obj%entityCounts = [nns, 1, 0, 0] -obj%xiDimension = 1 -obj%order = order -obj%name = ElementType("Line"//ToString(nns)) -ALLOCATE (obj%topology(nns + 1)) -DO CONCURRENT(i=1:nns) - obj%topology(i) = ReferenceTopology([i], Point) -END DO -obj%topology(nns + 1) = ReferenceTopology([(i, i=1, nns)], obj%name) -END PROCEDURE HighorderElement_Line - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Line -SELECT CASE (SIZE(xij, 1)) -CASE (1) - Ans = ABS(xij(1, 1) - xij(1, 2)) -CASE (2) - Ans = SQRT((xij(1, 1) - xij(1, 2))**2 & - & + (xij(2, 1) - xij(2, 2))**2) -CASE default - Ans = SQRT((xij(1, 1) - xij(1, 2))**2 & - & + (xij(2, 1) - xij(2, 2))**2 & - & + (xij(3, 1) - xij(3, 2))**2) -END SELECT -END PROCEDURE Measure_Simplex_Line - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Line_quality -ans = 0.0_DFP -END PROCEDURE Line_quality - -!---------------------------------------------------------------------------- -! RefLineCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefLineCoord -TYPE(String) :: astr -astr = UpperCase(refLine) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans(1, :) = [0.0_DFP, 1.0_DFP] -CASE ("BIUNIT") - ans(1, :) = [-1.0_DFP, 1.0_DFP] -END SELECT -END PROCEDURE RefLineCoord - -!---------------------------------------------------------------------------- -! GetEdgeElemType_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity_Line -IF (PRESENT(nrow)) nrow = 1 -IF (PRESENT(ncol)) ncol = 2 -con(1, 1) = 1 -con(1, 2) = 2 -END PROCEDURE GetEdgeConnectivity_Line - -!---------------------------------------------------------------------------- -! GetFaceElemType_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType_Line -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 - -!---------------------------------------------------------------------------- -! GetFaceConnectivity_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity_Line -IF (PRESENT(nrow)) nrow = 1 -IF (PRESENT(ncol)) ncol = 2 -con(1, 1) = 1 -con(1, 2) = 2 -END PROCEDURE GetFaceConnectivity_Line - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 deleted file mode 100644 index 23d1edaa3..000000000 --- a/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 +++ /dev/null @@ -1,102 +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: 2 March 2021 -! summary: This submodule contains methods for [[ReferencePoint_]] - -SUBMODULE(ReferencePoint_Method) Methods -USE ReallocateUtility -USE ReferenceElement_Method -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refPoint_Initiate -CALL Reallocate(obj%XiJ, 3, 1) -IF (PRESENT(XiJ)) THEN - obj%XiJ = XiJ -END IF -obj%EntityCounts = [1, 0, 0, 0] -obj%XiDimension = 0 -obj%Order = 0 -obj%NSD = NSD -obj%Name = Point1 -IF (ALLOCATED(obj%Topology)) DEALLOCATE (obj%Topology) -ALLOCATE (obj%Topology(1)) -obj%Topology(1) = ReferenceTopology([1], Point) -obj%highOrderElement => HighOrderElement_Point -END PROCEDURE refPoint_Initiate - -!---------------------------------------------------------------------------- -! ReferencePoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refPoint_Constructor1 -CALL refPoint_Initiate(obj, NSD, XiJ) -END PROCEDURE refPoint_Constructor1 - -!---------------------------------------------------------------------------- -! ReferencePoint_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE refPoint_Constructor_1 -ALLOCATE (obj) -CALL refpoint_Initiate(obj, NSD, XiJ) -END PROCEDURE refPoint_Constructor_1 - -!---------------------------------------------------------------------------- -! LagrangeElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HighOrderElement_Point -CALL Initiate(obj=obj, anotherobj=refelem) -END PROCEDURE HighOrderElement_Point - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Point -ans = 0.0_DFP -END PROCEDURE Measure_Simplex_Point - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Point_Quality -ans = 0.0_DFP -END PROCEDURE Point_Quality - -!---------------------------------------------------------------------------- -! TotalNodesInElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Point -SELECT CASE (elemType) -CASE (Point) - ans = 1 -CASE default - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Point - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 deleted file mode 100644 index 281bc250e..000000000 --- a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 +++ /dev/null @@ -1,392 +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: 2 March 2021 -! summary: This submodule defines methods for [[ReferencePrism_]] - -SUBMODULE(ReferencePrism_Method) Methods -USE ArangeUtility -USE ApproxUtility -USE StringUtility -USE ReferenceElement_Method - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElementName_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementName_Prism -SELECT CASE (elemType) -CASE (Prism6) - ans = "Prism6" - -CASE (Prism15) - ans = "Prism15" - -CASE (Prism18) - ans = "Prism18" - -CASE DEFAULT - ans = "NONE" - -END SELECT -END PROCEDURE ElementName_Prism - -!---------------------------------------------------------------------------- -! FaceTopology_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetTopology_Prism -! TODO: -! ! ALLOCATE (ans(5)) -! ans(1)%nptrs = nptrs([5, 4, 1, 2]) -! ans(2)%nptrs = nptrs([4, 6, 3, 1]) -! ans(3)%nptrs = nptrs([2, 3, 6, 5]) -! ans(4)%nptrs = nptrs([1, 3, 2]) -! ans(5)%nptrs = nptrs([4, 5, 6]) -! ans(:)%xiDimension = 2 -! ans(1:3)%name = Quadrangle4 -! ans(4:5)%name = Triangle3 - -! prism 15 -! ! ALLOCATE (ans(5)) -! ans(1)%nptrs = nptrs([5, 4, 1, 2, 13, 9, 7, 11]) -! ans(2)%nptrs = nptrs([4, 6, 3, 1, 14, 12, 8, 9]) -! ans(3)%nptrs = nptrs([2, 3, 6, 5, 10, 12, 15, 11]) -! ans(4)%nptrs = nptrs([1, 3, 2, 8, 10, 7]) -! ans(5)%nptrs = nptrs([4, 5, 6, 13, 15, 14]) -! ans(:)%xiDimension = 2 -! ans(1:3)%name = Quadrangle8 -! ans(4:5)%name = Triangle6 - -! prism 18 -! ! ALLOCATE (ans(5)) -! ans(1)%nptrs = nptrs([5, 4, 1, 2, 13, 9, 7, 11, 16]) -! ans(2)%nptrs = nptrs([4, 6, 3, 1, 14, 12, 8, 9, 17]) -! ans(3)%nptrs = nptrs([2, 3, 6, 5, 10, 12, 15, 11, 18]) -! ans(4)%nptrs = nptrs([1, 3, 2, 8, 10, 7]) -! ans(5)%nptrs = nptrs([4, 5, 6, 13, 15, 14]) -! ans(:)%xiDimension = 2 -! ans(1:3)%name = Quadrangle9 -! ans(4:5)%name = Triangle6 -END PROCEDURE FacetTopology_Prism - -!---------------------------------------------------------------------------- -! TotalEntities_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalEntities_Prism -ans(2:4) = [9, 5, 1] -ans(1) = TotalNodesInElement_Prism(elemType) -END PROCEDURE TotalEntities_Prism - -!---------------------------------------------------------------------------- -! TotalNodesInElements_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Prism -SELECT CASE (elemType) -CASE (Prism6) - ans = 6 -CASE (Prism15) - ans = 15 -CASE (Prism18) - ans = 18 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Prism - -!---------------------------------------------------------------------------- -! ElementType_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementType_Prism -SELECT CASE (elemName) -CASE ("Prism", "Prism6") - ans = Prism6 -CASE ("Prism15") - ans = Prism15 -CASE ("Prism18") - ans = Prism18 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementType_Prism - -!---------------------------------------------------------------------------- -! ElementOrder_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementOrder_Prism -SELECT CASE (elemType) -CASE (Prism6) - ans = 1 -CASE (Prism15) - ans = 2 -CASE (Prism18) - ans = 2 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementOrder_Prism - -!---------------------------------------------------------------------------- -! FacetElements_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Prism1 -! TODO: -END PROCEDURE FacetElements_Prism1 - -!---------------------------------------------------------------------------- -! FacetElements_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Prism2 -! TODO: -END PROCEDURE FacetElements_Prism2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_Ref_Prism -INTEGER(I4B) :: ii, jj -INTEGER(I4B), PARAMETER :: tNodes = 6, tFaces = 5, tEdges = 9, xidim = 3, & - & max_nodes_face = 4, name = Prism -INTEGER(I4B) :: p1p2(2, tEdges), lloop(max_nodes_face + 2, tFaces), & - & vol(tNodes, 1) -REAL(DFP) :: unit_xij(xidim, tNodes), biunit_xij(xidim, tNodes) - -CALL DEALLOCATE (obj) - -CALL GetEdgeConnectivity_Prism(con=p1p2, opt=1_I4B, order=1_I4B) -CALL GetFaceConnectivity_Prism(con=lloop, opt=1_I4B, order=1_I4B) - -vol(:, 1) = arange(1_I4B, tNodes) - -unit_xij = RefCoord_Prism("UNIT") -biunit_xij = RefCoord_Prism("BIUNIT") - -IF (PRESENT(xij)) THEN - obj%xij = xij(:xidim, :tNodes) - - IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.unit_xij)) THEN - obj%domainName = "UNIT" - ELSE IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.biunit_xij)) THEN - obj%domainName = "BIUNIT" - ELSE - obj%domainName = "GENERAL" - END IF - -ELSE - - IF (PRESENT(domainName)) THEN - obj%domainName = UpperCase(domainName) - IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN - obj%xij = RefCoord_Prism(obj%domainName) - END IF - ELSE - obj%domainName = "UNIT" - obj%xij = RefCoord_Prism(obj%domainName) - END IF - -END IF - -obj%entityCounts = [tNodes, tEdges, tFaces, 1_I4B] -obj%xidimension = xidim -obj%name = name -obj%order = 1_I4B -obj%nsd = nsd - -ALLOCATE (obj%topology(SUM(obj%entityCounts))) -DO ii = 1, obj%entityCounts(1) - obj%topology(ii) = ReferenceTopology([ii], Point) -END DO - -jj = obj%entityCounts(1) -DO ii = 1, obj%entityCounts(2) - obj%topology(jj + ii) = ReferenceTopology(p1p2(:, ii), Line2) -END DO - -jj = jj + obj%entityCounts(2) -DO ii = 1, obj%entityCounts(3) - obj%topology(jj + ii) = ReferenceTopology( & - & lloop(2 + 1:2 + lloop(1, ii), ii), lloop(2, ii)) -END DO - -jj = jj + obj%entityCounts(3) -DO ii = 1, obj%entityCounts(4) - obj%topology(jj + ii) = ReferenceTopology(vol(:, ii), name) -END DO - -obj%highorderElement => highorderElement_Prism -END PROCEDURE Initiate_Ref_Prism - -!---------------------------------------------------------------------------- -! ReferencePrism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Prism -CALL Initiate_Ref_Prism(obj=obj, nsd=NSD, xij=xij, domainName=domainName) -END PROCEDURE Reference_Prism - -!---------------------------------------------------------------------------- -! ReferencePrism_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Prism_Pointer -ALLOCATE (obj) -CALL Initiate_Ref_Prism(obj=obj, nsd=NSD, xij=xij, domainName=domainName) -END PROCEDURE Reference_Prism_Pointer - -!---------------------------------------------------------------------------- -! HighOrderElement_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HighOrderElement_Prism -! TODO: -! FIX: #250 Implement HighOrderElement_Prism -END PROCEDURE HighOrderElement_Prism - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Prism -INTEGER(I4B) :: fm(5, 7), node0(5, 4), order0(5), b, iface - -fm = FacetMatrix(refelem) -DO iface = 1, 5 - order0(iface) = fm(iface, 3) - b = order0(iface) + 3 - node0(iface, 1:order0(iface)) = fm(iface, 4:b) -END DO -CALL POLYHEDRONVOLUME3D(coord=XiJ(1:3, 1:6), & - & order_max=4, face_num=5, & - & node=node0, node_num=6, & - & order=order0, & - & ans=ans) -END PROCEDURE Measure_Simplex_Prism - -!---------------------------------------------------------------------------- -! Prism_Quality -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Prism_Quality -! TODO: -ans = 0.0_DFP -END PROCEDURE Prism_Quality - -!---------------------------------------------------------------------------- -! PolyhedronVolume3D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE PolyhedronVolume3D -INTEGER(I4B) :: iFace -INTEGER(I4B) :: n1 -INTEGER(I4B) :: n2 -INTEGER(I4B) :: n3 -INTEGER(I4B) :: v - -ans = 0.0_DFP -! Triangulate each iFace. -DO iface = 1, face_num - n3 = node(iface, order(iface)) - DO v = 1, order(iface) - 2 - n1 = node(iface, v) - n2 = node(iface, v + 1) - ans = ans & - + coord(1, n1) & - * (coord(2, n2) * coord(3, n3) - coord(2, n3) * coord(3, n2)) & - + coord(1, n2) & - * (coord(2, n3) * coord(3, n1) - coord(2, n1) * coord(3, n3)) & - + coord(1, n3) & - * (coord(2, n1) * coord(3, n2) - coord(2, n2) * coord(3, n1)) - END DO -END DO -ans = ans / 6.0_DFP -END PROCEDURE PolyhedronVolume3D - -!---------------------------------------------------------------------------- -! Refcoord_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefCoord_Prism -ans = 0.0_DFP -!TODO: -!FIX: Implement RefCoord_Prism -!ISSUE: #251 -END PROCEDURE RefCoord_Prism - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity_Prism -con(1:2, 1) = [1, 2] -con(1:2, 2) = [1, 3] -con(1:2, 3) = [1, 4] -con(1:2, 4) = [2, 3] -con(1:2, 5) = [2, 5] -con(1:2, 6) = [3, 6] -con(1:2, 7) = [4, 5] -con(1:2, 8) = [4, 6] -con(1:2, 9) = [5, 6] - -IF (PRESENT(ncol)) ncol = 9 -IF (PRESENT(nrow)) nrow = 2 - -END PROCEDURE GetEdgeConnectivity_Prism - -!---------------------------------------------------------------------------- -! GetFaceConnectivity_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity_Prism -con(1:4, 1) = [1, 3, 2, 0] -con(1:4, 2) = [2, 3, 6, 5] -con(1:4, 3) = [1, 2, 5, 4] -con(1:4, 4) = [1, 4, 6, 3] -con(1:4, 5) = [4, 5, 6, 0] - -IF (PRESENT(ncol)) ncol = 5 -IF (PRESENT(nrow)) nrow = 4 - -END PROCEDURE GetFaceConnectivity_Prism - -!---------------------------------------------------------------------------- -! GetFaceElemType_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType_Prism -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 SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 deleted file mode 100644 index d2638525f..000000000 --- a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 +++ /dev/null @@ -1,368 +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: 2 March 2021 -! summary: This submodule contians methods for [[ReferencePyramid_]] - -SUBMODULE(ReferencePyramid_Method) Methods -USE ArangeUtility -USE ApproxUtility -USE StringUtility -USE ReferenceElement_Method -USE ReferencePrism_Method, ONLY: PolyhedronVolume3D - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElementName_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementName_Pyramid -SELECT CASE (elemType) -CASE (Pyramid5) - ans = "Pyramid5" - -CASE (Pyramid13) - ans = "Pyramid13" - -CASE (Pyramid14) - ans = "Pyramid14" - -CASE default - ans = "NONE" -END SELECT -END PROCEDURE ElementName_Pyramid - -!---------------------------------------------------------------------------- -! FaceTopology_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetTopology_Pyramid -! TODO: -! ALLOCATE (ans(5)) -! ans(1)%nptrs = nptrs([1, 2, 5]) -! ans(2)%nptrs = nptrs([2, 3, 5]) -! ans(3)%nptrs = nptrs([3, 4, 5]) -! ans(4)%nptrs = nptrs([1, 5, 4]) -! ans(5)%nptrs = nptrs([4, 3, 2, 1]) -! ans(:)%xiDimension = 2 -! ans(1:4)%name = Triangle3 -! ans(5)%name = Quadrangle4 -! Order=2 elements - -! CASE (Pyramid13) -! ! ALLOCATE (ans(5)) -! ans(1)%nptrs = nptrs([1, 2, 5, 6, 10, 8]) -! ans(2)%nptrs = nptrs([2, 3, 5, 9, 12, 10]) -! ans(3)%nptrs = nptrs([3, 4, 5, 11, 13, 12]) -! ans(4)%nptrs = nptrs([1, 5, 4, 8, 13, 7]) -! ans(5)%nptrs = nptrs([4, 3, 2, 1, 11, 9, 6, 7]) -! ans(:)%xiDimension = 2 -! ans(1:4)%name = Triangle6 -! ans(5)%name = Quadrangle8 -! -! CASE (Pyramid14) -! ! ALLOCATE (ans(5)) -! ans(1)%nptrs = nptrs([1, 2, 5, 6, 10, 8]) -! ans(2)%nptrs = nptrs([2, 3, 5, 9, 12, 10]) -! ans(3)%nptrs = nptrs([3, 4, 5, 11, 13, 12]) -! ans(4)%nptrs = nptrs([1, 5, 4, 8, 13, 7]) -! ans(5)%nptrs = nptrs([4, 3, 2, 1, 11, 9, 6, 7, 13]) -! ans(:)%xiDimension = 2 -! ans(1:4)%name = Triangle6 -! ans(5)%name = Quadrangle9 -END PROCEDURE FacetTopology_Pyramid - -!---------------------------------------------------------------------------- -! TotalEntities_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalEntities_Pyramid -ans(2:4) = [9, 5, 1] -ans(1) = TotalNodesInElement_Pyramid(elemType) -END PROCEDURE TotalEntities_Pyramid - -!---------------------------------------------------------------------------- -! TotalNodesInElements_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Pyramid -SELECT CASE (elemType) -CASE (Pyramid5) - ans = 5 - -CASE (Pyramid13) - ans = 13 - -CASE (Pyramid14) - ans = 14 - -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Pyramid - -!---------------------------------------------------------------------------- -! ElementType_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementType_Pyramid -SELECT CASE (elemName) -CASE ("Pyramid", "Pyramid5") - ans = Pyramid5 -CASE ("Pyramid13") - ans = Pyramid13 -CASE ("Pyramid14") - ans = Pyramid14 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementType_Pyramid - -!---------------------------------------------------------------------------- -! ElementOrder_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementOrder_Pyramid -SELECT CASE (elemType) -CASE (Pyramid5) - ans = 1 - -CASE (Pyramid13) - ans = 2 - -CASE (Pyramid14) - ans = 2 - -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementOrder_Pyramid - -!---------------------------------------------------------------------------- -! FacetElements_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Pyramid1 -! TODO: -END PROCEDURE FacetElements_Pyramid1 - -!---------------------------------------------------------------------------- -! FacetElements_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Pyramid2 -! TODO: -END PROCEDURE FacetElements_Pyramid2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_Ref_Pyramid -INTEGER(I4B) :: ii, jj -INTEGER(I4B), PARAMETER :: tNodes = 5, tFaces = 5, tEdges = 8, xidim = 3, & - & max_nodes_face = 4, name = Pyramid -INTEGER(I4B) :: p1p2(2, tEdges), lloop(max_nodes_face + 2, tFaces), & - & vol(tNodes, 1) -REAL(DFP) :: unit_xij(xidim, tNodes), biunit_xij(xidim, tNodes) - -CALL DEALLOCATE (obj) - -CALL GetEdgeConnectivity_Pyramid(con=p1p2, opt=1_I4B, order=1_I4B) -CALL GetFaceConnectivity_Pyramid(con=lloop, opt=1_I4B, order=1_I4B) - -vol(:, 1) = arange(1_I4B, tNodes) - -unit_xij = RefCoord_Pyramid("UNIT") -biunit_xij = RefCoord_Pyramid("BIUNIT") - -IF (PRESENT(xij)) THEN - - obj%xij = xij(:xidim, :tNodes) - - IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.unit_xij)) THEN - obj%domainName = "UNIT" - ELSE IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.biunit_xij)) THEN - obj%domainName = "BIUNIT" - ELSE - obj%domainName = "GENERAL" - END IF - -ELSE - - IF (PRESENT(domainName)) THEN - obj%domainName = UpperCase(domainName) - IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN - obj%xij = RefCoord_Pyramid(obj%domainName) - END IF - ELSE - obj%domainName = "UNIT" - obj%xij = RefCoord_Pyramid(obj%domainName) - END IF - -END IF - -obj%entityCounts = [tNodes, tEdges, tFaces, 1_I4B] -obj%xidimension = xidim -obj%name = name -obj%order = 1_I4B -obj%nsd = nsd - -ALLOCATE (obj%topology(SUM(obj%entityCounts))) -DO ii = 1, obj%entityCounts(1) - obj%topology(ii) = ReferenceTopology([ii], Point) -END DO - -jj = obj%entityCounts(1) -DO ii = 1, obj%entityCounts(2) - obj%topology(jj + ii) = ReferenceTopology(p1p2(:, ii), Line2) -END DO - -jj = jj + obj%entityCounts(2) -DO ii = 1, obj%entityCounts(3) - obj%topology(jj + ii) = ReferenceTopology( & - & lloop(2 + 1:2 + lloop(1, ii), ii), lloop(2, ii)) -END DO - -jj = jj + obj%entityCounts(3) -DO ii = 1, obj%entityCounts(4) - obj%topology(jj + ii) = ReferenceTopology(vol(:, ii), name) -END DO - -obj%highorderElement => highorderElement_Pyramid -END PROCEDURE Initiate_Ref_Pyramid - -!---------------------------------------------------------------------------- -! ReferencePyramid -!---------------------------------------------------------------------------- -MODULE PROCEDURE Reference_Pyramid -CALL Initiate_Ref_Pyramid(obj=obj, nsd=NSD, xij=xij, domainName=domainName) -END PROCEDURE Reference_Pyramid - -!---------------------------------------------------------------------------- -! ReferencePyramid -!---------------------------------------------------------------------------- -MODULE PROCEDURE Reference_Pyramid_Pointer -ALLOCATE (obj) -CALL Initiate_Ref_Pyramid(obj=obj, nsd=NSD, xij=xij, domainName=domainName) -END PROCEDURE Reference_Pyramid_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HighOrderElement_Pyramid -! FIX: -!TODO: -END PROCEDURE HighOrderElement_Pyramid - -!----------------------------------------------------------------------------- -! MeasureSimplex -!----------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Pyramid -INTEGER(I4B) :: FM(5, 7), Node0(5, 4), Order0(5), iFace, b - -FM = FacetMatrix(RefElem) - -DO iFace = 1, 5 - Order0(iFace) = FM(iFace, 3) - b = Order0(iFace) + 3 - Node0(iFace, 1:Order0(iFace)) = FM(iFace, 4:b) -END DO - -CALL PolyhedronVolume3D(coord=XiJ(1:3, 1:5), & - & order_max=4, face_num=5, & - & node=Node0, node_num=5, & - & order=Order0, & - & ans=ans) - -END PROCEDURE Measure_Simplex_Pyramid - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Pyramid_Quality -ans = 0.0_DFP -!FIX: Implement Pyramid_Quality -!TODO: -END PROCEDURE Pyramid_Quality - -!---------------------------------------------------------------------------- -! Refcoord_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefCoord_Pyramid -!FIX: Implement RefCoord -ans = 0.0_DFP -!TODO: -END PROCEDURE RefCoord_Pyramid - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity_Pyramid -con(1:2, 1) = [1, 2] -con(1:2, 2) = [1, 4] -con(1:2, 3) = [1, 5] -con(1:2, 4) = [2, 3] -con(1:2, 5) = [2, 5] -con(1:2, 6) = [3, 4] -con(1:2, 7) = [3, 5] -con(1:2, 8) = [4, 5] - -IF (PRESENT(nrow)) nrow = 2 -IF (PRESENT(ncol)) ncol = 8 -END PROCEDURE GetEdgeConnectivity_Pyramid - -!---------------------------------------------------------------------------- -! GetFaceConnectivity_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity_Pyramid -con(1:4, 1) = [1, 4, 3, 2] -con(1:4, 2) = [2, 3, 5, 0] -con(1:4, 3) = [3, 4, 5, 0] -con(1:4, 4) = [1, 5, 4, 0] -con(1:4, 5) = [1, 2, 5, 0] -IF (PRESENT(nrow)) nrow = 4 -IF (PRESENT(ncol)) ncol = 5 -END PROCEDURE GetFaceConnectivity_Pyramid - -!---------------------------------------------------------------------------- -! GetFaceElemType_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType_Pyramid - -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 SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 deleted file mode 100644 index 76b697b41..000000000 --- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 +++ /dev/null @@ -1,660 +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: 2 March 2021 -! summary: This submodule contains method for [[ReferenceQuadrangle_]] - -SUBMODULE(ReferenceQuadrangle_Method) Methods -USE ReferenceElement_Method -USE LineInterpolationUtility, ONLY: InterpolationPoint_Line -USE ReferenceLine_Method, ONLY: ElementOrder_Line, ElementName_Line - -USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle, & - & LagrangeDOF_Quadrangle -USE ReferenceTriangle_Method, ONLY: TRIANGLEAREA2D -USE ReferenceLine_Method, ONLY: Linename, ElementType_Line - -USE ApproxUtility -USE AppendUtility -USE StringUtility -USE ArangeUtility -USE InputUtility -USE SortUtility -USE ReallocateUtility -USE Display_Method -USE MiscUtility, ONLY: Int2Str - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElementName_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementName_Quadrangle -SELECT CASE (elemType) -CASE (Quadrangle4) - ans = "Quadrangle4" -CASE (Quadrangle8) - ans = "Quadrangle8" -CASE (Quadrangle9) - ans = "Quadrangle9" -CASE (Quadrangle16) - ans = "Quadrangle16" -CASE default - ans = "" -END SELECT -END PROCEDURE ElementName_Quadrangle - -!---------------------------------------------------------------------------- -! FacetTopology_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetTopology_Quadrangle -INTEGER(I4B) :: order, ii, lineType -INTEGER(I4B), ALLOCATABLE :: con(:, :) - -order = ElementOrder_Quadrangle(elemType) -CALL Reallocate(con, order + 1, 4) -CALL GetEdgeConnectivity_Quadrangle(con=con, & - & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) -lineType = ElementType_Line("Line"//Int2Str(order + 1)) - -DO ii = 1, 4 - ans(ii)%nptrs = nptrs(con(:, ii)) - ans(ii)%xiDimension = 1 - ans(ii)%name = lineType -END DO - -IF (ALLOCATED(con)) DEALLOCATE (con) - -END PROCEDURE FacetTopology_Quadrangle - -!---------------------------------------------------------------------------- -! TotalEntities_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalEntities_Quadrangle -ans(2:4) = [4, 1, 0] -ans(1) = TotalNodesInElement_Quadrangle(elemType) -END PROCEDURE TotalEntities_Quadrangle - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Quadrangle -SELECT CASE (ElemType) -CASE (Quadrangle4) - ans = 4 -CASE (Quadrangle8) - ans = 8 -CASE (Quadrangle9) - ans = 9 -CASE (Quadrangle16) - ans = 16 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Quadrangle - -!---------------------------------------------------------------------------- -! ElementOrder_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementOrder_Quadrangle -SELECT CASE (ElemType) -CASE (Quadrangle4) - ans = 1 -CASE (Quadrangle8) - ans = 2 -CASE (Quadrangle9) - ans = 2 -CASE (Quadrangle16) - ans = 3 -END SELECT -END PROCEDURE ElementOrder_Quadrangle - -!---------------------------------------------------------------------------- -! ElementType_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementType_Quadrangle -SELECT CASE (elemName) -CASE ("Quadrangle4", "Quadrangle") - ans = Quadrangle4 -CASE ("Quadrangle8") - ans = Quadrangle8 -CASE ("Quadrangle9") - ans = Quadrangle9 -CASE ("Quadrangle16") - ans = Quadrangle16 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementType_Quadrangle - -!---------------------------------------------------------------------------- -! FacetElements_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Quadrangle1 -INTEGER(I4B) :: ii, istart, tsize, jj -TYPE(Referencetopology_) :: topo - -istart = refelem%entityCounts(1) - -ans(1)%xij = InterpolationPoint_Line( & - & order=refelem%order, & - & ipType=refelem%interpolationPointType, & - & layout="VEFC") - -ans(1)%interpolationPointType = refelem%interpolationPointType -ans(1)%nsd = refelem%nsd -DO ii = 2, 4 - ans(ii)%xij = ans(1)%xij - ans(ii)%interpolationPointType = ans(1)%interpolationPointType - ans(ii)%nsd = ans(1)%nsd -END DO - -DO ii = 1, 4 - topo = refelem%topology(istart + ii) - tsize = SIZE(topo%nptrs) - ans(ii)%xiDimension = topo%xiDimension - ans(ii)%name = topo%name - ans(ii)%order = ElementOrder_Line(elemType=topo%name) - ans(ii)%entityCounts = [tsize, 1, 0, 0] - - ALLOCATE (ans(ii)%topology(tsize + 1)) - - DO jj = 1, tsize - ans(ii)%topology(jj) = Referencetopology( & - & nptrs=topo%nptrs(jj:jj), name=Point) - END DO - - ans(ii)%topology(tsize + 1) = Referencetopology( & - & nptrs=topo%nptrs, name=topo%name) -END DO - -CALL DEALLOCATE (topo) - -END PROCEDURE FacetElements_Quadrangle1 - -!---------------------------------------------------------------------------- -! FacetElements_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Quadrangle2 -INTEGER(I4B) :: ii, jj, order -INTEGER(I4B), ALLOCATABLE :: edgeCon(:, :) - -order = ElementOrder_Quadrangle(elemType) -CALL Reallocate(edgeCon, order + 1, 4) -CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, & - & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) -!! The edges are accordign to gmsh -!! [1,2], [2,3], [3,4], [4,1] - -DO ii = 1, 4 - - 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)%nsd = nsd - ans(ii)%entityCounts = [order + 1, 1, 0, 0] - ALLOCATE (ans(ii)%topology(order + 2)) - - DO jj = 1, order + 1 - ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), & - & name=Point) - END DO - - ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), & - & name=ans(ii)%name) - -END DO - -IF (ALLOCATED(edgeCon)) DEALLOCATE (edgeCon) - -END PROCEDURE FacetElements_Quadrangle2 - -!---------------------------------------------------------------------------- -! Quadranglename1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadranglename1 -SELECT CASE (order) -CASE (1) - ans = Quadrangle4 -CASE (2) - ans = Quadrangle9 -CASE (3) - ans = Quadrangle16 -CASE (4:) - ans = Quadrangle16 + order - 3_I4B -END SELECT -END PROCEDURE Quadranglename1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_ref_Quadrangle -REAL(DFP) :: unit_xij(2, 4), biunit_xij(2, 4) -CALL DEALLOCATE (obj) - -unit_xij = RefCoord_Quadrangle("UNIT") -biunit_xij = RefCoord_Quadrangle("BIUNIT") - -IF (PRESENT(xij)) THEN - obj%xij = xij(1:2, 1:4) - IF (ALL(obj%xij(1:2, 1:4) .approxeq.unit_xij)) THEN - obj%domainName = "UNIT" - ELSE IF (ALL(obj%xij(1:2, 1:4) .approxeq.biunit_xij)) THEN - obj%domainName = "BIUNIT" - ELSE - obj%domainName = "GENERAL" - END IF - -ELSE - - IF (PRESENT(domainName)) THEN - obj%domainName = UpperCase(domainName) - IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN - obj%xij = RefCoord_Quadrangle(obj%domainName) - END IF - ELSE - obj%domainName = "BIUNIT" - obj%xij = RefCoord_Quadrangle(obj%domainName) - END IF - -END IF - -obj%entityCounts = [4, 4, 1, 0] -obj%xidimension = 2 -obj%name = Quadrangle4 -obj%order = 1 -obj%NSD = NSD -ALLOCATE (obj%topology(9)) -obj%topology(1) = ReferenceTopology([1], Point) -obj%topology(2) = ReferenceTopology([2], Point) -obj%topology(3) = ReferenceTopology([3], Point) -obj%topology(4) = ReferenceTopology([4], Point) -obj%topology(5) = ReferenceTopology([1, 2], Line2) -obj%topology(6) = ReferenceTopology([2, 3], Line2) -obj%topology(7) = ReferenceTopology([3, 4], Line2) -obj%topology(8) = ReferenceTopology([4, 1], Line2) -obj%topology(9) = ReferenceTopology([1, 2, 3, 4], Quadrangle4) -obj%highorderElement => highorderElement_Quadrangle -END PROCEDURE Initiate_ref_Quadrangle - -!---------------------------------------------------------------------------- -! ReferenceQuadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE reference_Quadrangle -CALL initiate_ref_quadrangle(obj=obj, nsd=NSD, xij=xij, domainName=domainName) -END PROCEDURE reference_Quadrangle - -!---------------------------------------------------------------------------- -! ReferenceQuadrangle_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE reference_Quadrangle_Pointer -ALLOCATE (obj) -CALL initiate_ref_quadrangle(obj=obj, nsd=NSD, xij=xij, domainName=domainName) -END PROCEDURE reference_Quadrangle_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE highorderElement_Quadrangle -INTEGER(I4B) :: NNS, I -INTEGER(I4B), ALLOCATABLE :: aintvec(:) - -CALL DEALLOCATE (obj) -SELECT CASE (order) -CASE (1) - CALL Initiate(obj=obj, Anotherobj=refelem) -CASE DEFAULT - obj%xij = InterpolationPoint_Quadrangle( & - & xij=refelem%xij, & - & order=order, & - & ipType=ipType, & - & layout="VEFC") - obj%domainName = refelem%domainName - NNS = LagrangeDOF_Quadrangle(order=order) - obj%entityCounts = [NNS, 4, 1, 0] - obj%xidimension = 2 - obj%name = QuadrangleName(order=order) - obj%order = order - obj%NSD = refelem%NSD - ALLOCATE (obj%topology(SUM(obj%entityCounts))) - DO I = 1, NNS - obj%topology(I) = ReferenceTopology([I], Point) - END DO - aintvec = [1, 2] .append.arange(5_I4B, 3_I4B + order) - obj%topology(NNS + 1) = ReferenceTopology(aintvec, Linename(order=order)) - - aintvec = [2, 3] .append.arange( & - & 3_I4B + order + 1, & - & 3_I4B + order + order - 1_I4B) - obj%topology(NNS + 2) = ReferenceTopology(aintvec, Linename(order=order)) - - aintvec = [3, 4] .append.arange(& - & 2_I4B + 2_I4B * order + 1, & - & 2_I4B + 2_I4B * order + order - 1_I4B) - obj%topology(NNS + 3) = ReferenceTopology(aintvec, Linename(order=order)) - - aintvec = [4, 1] .append.arange( & - & 1_I4B + 3_I4B * order + 1, & - & 1_I4B + 3_I4B * order + order - 1_I4B) - obj%topology(NNS + 4) = ReferenceTopology(aintvec, Linename(order=order)) - - obj%topology(NNS + 5) = ReferenceTopology( & - & arange(1_I4B, NNS, 1_I4B), obj%name) - obj%highOrderElement => refelem%highOrderElement -END SELECT -END PROCEDURE highorderElement_Quadrangle - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Quadrangle -IF (refelem%nsd .EQ. 2) THEN - CALL QuadArea2D(xij(1:2, 1:4), Ans) -ELSE - CALL QuadArea3D(xij(1:3, 1:4), Ans) -END IF -END PROCEDURE Measure_Simplex_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Quadrangle_Quality -ans = 0.0_DFP -END PROCEDURE Quadrangle_Quality - -!---------------------------------------------------------------------------- -! QuadArea3D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadArea3D -REAL(DFP) :: p(3, 4) -! Define a parallelogram by averaging consecutive vertices. -p(1:3, 1:3) = (q(1:3, 1:3) + q(1:3, 2:4)) / 2.0_DFP -p(1:3, 4) = (q(1:3, 4) + q(1:3, 1)) / 2.0_DFP -! Compute the area. -CALL PARALLELOGRAMAREA3D(p, ans) -! The quadrilateral's area is twice that of the parallelogram. -ans = 2.0_DFP * ans -END PROCEDURE QuadArea3D - -!---------------------------------------------------------------------------- -! QuadArea2D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadArea2D -INTEGER(I4B), PARAMETER :: dim_num = 2 -REAL(DFP) :: area_triangle -REAL(DFP) :: t(dim_num, 3) -ans = 0.0_DFP -t(1:dim_num, 1:3) = RESHAPE( & - & [q(1:2, 1), q(1:2, 2), q(1:2, 3)], & - & [dim_num, 3] & - & ) -CALL TRIANGLEAREA2D(t, area_triangle) -ans = ans + area_triangle -t(1:dim_num, 1:3) = RESHAPE( & - & [q(1:2, 3), q(1:2, 4), q(1:2, 1)], & - & [dim_num, 3]) -CALL TRIANGLEAREA2D(t, area_triangle) -ans = ans + area_triangle -END PROCEDURE QuadArea2D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION R8MATDET4D(a) - REAL(DFP), INTENT(IN) :: a(4, 4) - REAL(DFP) :: R8MATDET4D - R8MATDET4D = & - a(1, 1) * ( & - a(2, 2) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & - - a(2, 3) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & - + a(2, 4) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2))) & - - a(1, 2) * ( & - a(2, 1) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & - - a(2, 3) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & - + a(2, 4) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1))) & - + a(1, 3) * ( & - a(2, 1) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & - - a(2, 2) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & - + a(2, 4) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) & - - a(1, 4) * ( & - a(2, 1) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2)) & - - a(2, 2) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1)) & - + a(2, 3) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) -END FUNCTION R8MATDET4D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Computes the area of a parallelogram in 3D -! -!# Introduction -! -! A parallelogram is a polygon having four sides, with the property -! that each pair of opposite sides is paralell. -! A parallelogram in 3D must have the property that it is "really" -! a 2D object, that is, that the four vertices that define it lie -! in some plane. -! Given the first three vertices of the parallelogram (in 2D or 3D), -! P1, P2, and P3, the fourth vertex must satisfy -! P4 = P1 + ( P3 - P2 ) -! This routine uses the fact that the norm of the cross product -! of two vectors is the area of the parallelogram they form: -! Area = ( P3 - P2 ) x ( P1 - P2 ). -! -! P4<-----P3 -! / / -! / / -! P1----->P2 -! - -PURE SUBROUTINE PARALLELOGRAMAREA3D(p, ans) - REAL(DFP), INTENT(IN) :: p(3, 4) - REAL(DFP), INTENT(OUT) :: ans - REAL(DFP) :: cross(3) - ! Compute the cross product vector. - cross(1) = (p(2, 2) - p(2, 1)) * (p(3, 3) - p(3, 1)) & - & - (p(3, 2) - p(3, 1)) * (p(2, 3) - p(2, 1)) - cross(2) = (p(3, 2) - p(3, 1)) * (p(1, 3) - p(1, 1)) & - & - (p(1, 2) - p(1, 1)) * (p(3, 3) - p(3, 1)) - cross(3) = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & - & - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) - ans = SQRT(SUM(cross(1:3)**2)) -END SUBROUTINE PARALLELOGRAMAREA3D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Computes the area of a parallelogram in 2D -! -!# Introduction -! -! A parallelogram is a polygon having four sides, with the property -! that each pair of opposite sides is paralell. -! Given the first three vertices of the parallelogram, -! P1, P2, and P3, the fourth vertex must satisfy -! -! P4 = P1 + ( P3 - P2 ) -! -! This routine uses the fact that the norm of the cross product -! of two vectors is the area of the parallelogram they form: -! -! Area = ( P3 - P2 ) x ( P1 - P2 ). -! -! P4<-----P3 -! / / -! / / -! P1----->P2 - -PURE SUBROUTINE PARALLELOGRAMAREA2D(p, ans) - REAL(DFP), INTENT(IN) :: p(2, 4) - REAL(DFP), INTENT(OUT) :: ans - ans = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & - & - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) -END SUBROUTINE PARALLELOGRAMAREA2D - -!---------------------------------------------------------------------------- -! RefQuadrangleCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefQuadrangleCoord -CHARACTER(:), ALLOCATABLE :: astr -astr = UpperCase(refQuadrangle) -SELECT CASE (astr) -CASE ("UNIT") - ans(1, :) = [0.0_DFP, 1.0_DFP, 1.0_DFP, 0.0_DFP] - ans(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP, 1.0_DFP] -CASE ("BIUNIT") - ans(1, :) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, -1.0_DFP] - ans(2, :) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP] -END SELECT -astr = "" -END PROCEDURE RefQuadrangleCoord - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity_Quadrangle -INTEGER(I4B) :: opt0, order0, ii, jj, iface - -opt0 = Input(default=1_I4B, option=opt) -order0 = Input(default=1_I4B, option=order) - -IF (PRESENT(ncol)) ncol = 4 -IF (PRESENT(nrow)) nrow = 1 + order0 - -SELECT CASE (opt0) -CASE (1_I4B) - con(1:2, 1) = [1, 2] - con(1:2, 2) = [4, 3] - con(1:2, 3) = [1, 4] - con(1:2, 4) = [2, 3] -CASE (2_I4B) - !! For Lagrangian polynomial - con(1:2, 1) = [1, 2] - con(1:2, 2) = [2, 3] - con(1:2, 3) = [3, 4] - con(1:2, 4) = [4, 1] -END SELECT - -jj = 4 -DO iface = 1, 4 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - END DO - jj = jj + order0 - 1 -END DO - -END PROCEDURE GetEdgeConnectivity_Quadrangle - -!---------------------------------------------------------------------------- -! GetFaceConnectivity_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity_Quadrangle -CALL GetEdgeConnectivity_Quadrangle(con=con, opt=2_I4B, order=order, & - nrow=nrow, ncol=ncol) -END PROCEDURE GetFaceConnectivity_Quadrangle - -!---------------------------------------------------------------------------- -! FaceShapeMetaData_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FaceShapeMetaData_Quadrangle -INTEGER(I4B) :: a(4), localFaces0(4) - -a(1) = MINLOC(face, 1) -a(2) = HelpFaceData_Quadrangle(1, a(1)) !b -a(3) = HelpFaceData_Quadrangle(2, a(1)) !c -a(4) = HelpFaceData_Quadrangle(3, a(1)) !d - -localFaces0(1:4) = face(a) -IF (PRESENT(localFaces)) THEN - localFaces(1:4) = localFaces0(1:4) -END IF - -sorted_face(1) = localFaces0(1) -sorted_face(3) = localFaces0(3) - -IF (localFaces0(2) .LT. localFaces0(4)) THEN - sorted_face(2) = localFaces0(2) - sorted_face(4) = localFaces0(4) - - IF (PRESENT(faceOrient)) THEN - faceOrient(3) = 1_INT8 - faceOrient(1) = SIGN(1, localFaces0(2) - localFaces0(1)) - faceOrient(2) = SIGN(1, localFaces0(4) - localFaces0(1)) - END IF - -ELSE - sorted_face(2) = localFaces0(4) - sorted_face(4) = localFaces0(2) - - IF (PRESENT(faceOrient)) THEN - faceOrient(3) = -1_INT8 - faceOrient(1) = SIGN(1, localFaces0(4) - localFaces0(1)) - faceOrient(2) = SIGN(1, localFaces0(2) - localFaces0(1)) - END IF - -END IF - -END PROCEDURE FaceShapeMetaData_Quadrangle - -!---------------------------------------------------------------------------- -! GetFaceElemType_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType_Quadrangle -INTEGER(I4B) :: order -order = ElementOrder_Quadrangle(Input(default=Quadrangle, option=elemType)) -IF (PRESENT(faceElemType)) faceElemType(1:4) = ElementName_Line(order) -IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = order + 1 -END PROCEDURE GetFaceElemType_Quadrangle - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 deleted file mode 100644 index 1e84e2ad5..000000000 --- a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 +++ /dev/null @@ -1,608 +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: 2 March 2021 -! summary: This submodule contains methods for [[ReferenceTetrahedron_]] - -SUBMODULE(ReferenceTetrahedron_Method) Methods -USE ReferenceElement_Method -USE ApproxUtility -USE InvUtility -USE InputUtility -USE StringUtility -USE ArangeUtility -USE Display_Method -USE ReallocateUtility -USE MiscUtility, ONLY: Int2STR - -USE ReferenceLine_Method, ONLY: ElementType_Line - -USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle - -USE ReferenceTriangle_Method, ONLY: ElementOrder_Triangle, & - & TotalEntities_Triangle, FacetTopology_Triangle - -USE TetrahedronInterpolationUtility, ONLY: LagrangeDOF_Tetrahedron, & - & InterpolationPoint_Tetrahedron - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElementName_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementName_Tetrahedron - -SELECT CASE (elemType) -CASE (Tetrahedron4) - ans = "Tetrahedron4" - -CASE (Tetrahedron10) - ans = "Tetrahedron10" - -CASE (Tetrahedron20) - ans = "Tetrahedron20" - -CASE (Tetrahedron35) - ans = "Tetrahedron35" - -CASE (Tetrahedron56) - ans = "Tetrahedron56" - -CASE DEFAULT - ans = "NONE" - -END SELECT - -END PROCEDURE ElementName_Tetrahedron - -!---------------------------------------------------------------------------- -! FacetTopology_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetTopology_Tetrahedron -INTEGER(I4B) :: ii, faceElemType(4), tFaceNodes(4) -INTEGER(I4B), ALLOCATABLE :: con(:, :) - -CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & - & elemType=elemType, tFaceNodes=tFaceNodes) - -CALL Reallocate(con, tFaceNodes(1), 4) - -ii = ElementOrder_Tetrahedron(elemType=elemType) -CALL GetFaceConnectivity_Tetrahedron(con=con, order=ii) - -DO ii = 1, 4 - ans(ii)%nptrs = nptrs(con(:, ii)) - ans(ii)%xiDimension = 2 - ans(ii)%name = faceElemType(ii) -END DO - -IF (ALLOCATED(con)) DEALLOCATE (con) - -END PROCEDURE FacetTopology_Tetrahedron - -!---------------------------------------------------------------------------- -! TotalEntities_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalEntities_Tetrahedron -ans(2:4) = [6, 4, 1] -ans(1) = TotalNodesInElement_Tetrahedron(elemType) -END PROCEDURE TotalEntities_Tetrahedron - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Tetrahedron -SELECT CASE (elemType) -CASE (Tetrahedron4) - ans = 4 -CASE (Tetrahedron10) - ans = 10 -CASE (Tetrahedron20) - ans = 20 -CASE (Tetrahedron35) - ans = 35 -CASE (Tetrahedron56) - ans = 56 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Tetrahedron - -!---------------------------------------------------------------------------- -! ElementOrder_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementOrder_Tetrahedron -SELECT CASE (ElemType) -CASE (Tetrahedron4) - ans = 1 -CASE (Tetrahedron10) - ans = 2 -CASE (Tetrahedron20) - ans = 3 -CASE (Tetrahedron35) - ans = 4 -CASE (Tetrahedron56) - ans = 5 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementOrder_Tetrahedron - -!---------------------------------------------------------------------------- -! ElementType_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementType_Tetrahedron -SELECT CASE (elemName) -CASE ("Tetrahedron4", "Tetrahedron") - ans = Tetrahedron4 -CASE ("Tetrahedron10") - ans = Tetrahedron10 -CASE ("Tetrahedron20") - ans = Tetrahedron20 -CASE ("Tetrahedron35") - ans = Tetrahedron35 -CASE ("Tetrahedron56") - ans = Tetrahedron56 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementType_Tetrahedron - -!---------------------------------------------------------------------------- -! FacetElements_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Tetrahedron1 -INTEGER(I4B) :: ii, istart, tsize, jj -TYPE(ReferenceTopology_) :: topo - -istart = refelem%entityCounts(1) + refelem%entityCounts(2) -! tPoints + tEdges - -ii = 1 -ans(ii)%nsd = refelem%nsd -ans(ii)%interpolationPointType = refelem%interpolationPointType -ans(ii)%xij = InterpolationPoint_Triangle( & - & order=refelem%order, & - & ipType=refelem%interpolationPointType, & - & layout="VEFC") - -DO ii = 2, 4 - ans(ii)%nsd = ans(1)%nsd - ans(ii)%interpolationPointType = ans(1)%interpolationPointType - ans(ii)%xij = ans(1)%xij -END DO - -DO ii = 1, 4 - - topo = refelem%topology(istart + ii) - ans(ii)%xidimension = topo%xidimension - ans(ii)%name = topo%name - - ans(ii)%order = ElementOrder_Triangle(topo%name) - ans(ii)%entityCounts = TotalEntities_Triangle(topo%name) - - tsize = SUM(ans(ii)%entityCounts) - ! ALLOCATE (ans(ii)%topology(tsize)) - CALL RefTopoReallocate(ans(ii)%topology, tsize) - - ! points - DO jj = 1, ans(ii)%entityCounts(1) - ans(ii)%topology(jj) = ReferenceTopology(nptrs=topo%nptrs(jj:jj), & - & name=Point) - END DO - - ! lines - jj = ans(ii)%entityCounts(1) - CALL FacetTopology_Triangle(elemType=topo%name, & - & nptrs=topo%nptrs, ans=ans(ii)%topology(jj + 1:)) - - ! surface - tsize = jj + ans(ii)%entityCounts(2) - ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=topo%nptrs, & - & name=topo%name) - -END DO - -CALL DEALLOCATE (topo) - -END PROCEDURE FacetElements_Tetrahedron1 - -!---------------------------------------------------------------------------- -! FacetElements_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Tetrahedron2 -INTEGER(I4B) :: ii, jj, order, entityCounts(4), tsize -INTEGER(I4B), ALLOCATABLE :: edgeCon(:, :), faceCon(:, :) -INTEGER(I4B) :: faceElemType(4), tFaceNodes(4) - -CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & - & tFaceNodes=tFaceNodes, elemType=elemType) - -entityCounts = TotalEntities_Tetrahedron(elemType) -order = ElementOrder_Tetrahedron(elemType) - -CALL Reallocate(edgeCon, order + 1, entityCounts(2)) -CALL Reallocate(faceCon, tFaceNodes(1), entityCounts(3)) - -CALL GetEdgeConnectivity_Tetrahedron(con=edgeCon, order=order) -CALL GetFaceConnectivity_Tetrahedron(con=faceCon, order=order) - -DO ii = 1, entityCounts(3) - - ans(ii)%xiDimension = 2 - ans(ii)%order = order - ans(ii)%name = faceElemType(ii) - ans(ii)%interpolationPointType = Equidistance - - ans(ii)%xij = InterpolationPoint_Triangle( & - & order=ans(ii)%order, & - & ipType=ans(ii)%interpolationPointType, & - & layout="VEFC") - - ans(ii)%nsd = nsd - ans(ii)%entityCounts = TotalEntities_Triangle(ans(ii)%name) - - tsize = SUM(ans(ii)%entityCounts) - ! ALLOCATE (ans(ii)%topology(tsize)) - CALL RefTopoReallocate(ans(ii)%topology, tsize) - - ! points - DO jj = 1, ans(ii)%entityCounts(1) - ans(ii)%topology(jj) = Referencetopology(nptrs=faceCon(jj:jj, ii), & - & name=Point) - END DO - - ! lines - jj = ans(ii)%entityCounts(1) - CALL FacetTopology_Triangle(elemType=ans(ii)%name, & - & nptrs=faceCon(:, ii), ans=ans(ii)%topology(jj + 1:)) - - ! surface - tsize = jj + ans(ii)%entityCounts(2) - ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=faceCon(:, ii), & - & name=ans(ii)%name) - -END DO - -IF (ALLOCATED(edgeCon)) DEALLOCATE (edgeCon) -IF (ALLOCATED(faceCon)) DEALLOCATE (faceCon) -END PROCEDURE FacetElements_Tetrahedron2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate_Ref_Tetrahedron -INTEGER(I4B), PARAMETER :: tNodes = 4, tFaces = 4, tEdges = 6 -INTEGER(I4B) :: ii, jj, p1p2(2, tEdges), lloop(3, tFaces) -REAL(DFP) :: unit_xij(nsd, tNodes), biunit_xij(nsd, tNodes) - -CALL DEALLOCATE (obj) - -unit_xij = RefCoord_Tetrahedron("UNIT") -biunit_xij = RefCoord_Tetrahedron("BIUNIT") - -IF (PRESENT(xij)) THEN - obj%xij = xij(1:3, 1:4) - - IF (ALL(obj%xij(1:3, 1:4) .approxeq.unit_xij)) THEN - obj%domainName = "UNIT" - ELSE IF (ALL(obj%xij(1:3, 1:4) .approxeq.biunit_xij)) THEN - obj%domainName = "BIUNIT" - ELSE - obj%domainName = "GENERAL" - END IF - -ELSE - - IF (PRESENT(domainName)) THEN - obj%domainName = UpperCase(domainName) - IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN - obj%xij = RefCoord_Tetrahedron(obj%domainName) - END IF - ELSE - obj%domainName = "UNIT" - obj%xij = RefCoord_Tetrahedron(obj%domainName) - END IF - -END IF - -CALL GetEdgeConnectivity_Tetrahedron(con=p1p2, order=1) -CALL GetFaceConnectivity_Tetrahedron(con=lloop, order=1) - -obj%entityCounts = [tNodes, tEdges, tFaces, 1_I4B] -obj%xidimension = nsd -obj%name = Tetrahedron4 -obj%order = 1_I4B -obj%nsd = nsd - -ii = SUM(obj%entityCounts) -CALL RefTopoReallocate(obj%topology, ii) - -! points -DO ii = 1, obj%entityCounts(1) - obj%topology(ii) = ReferenceTopology([ii], Point) -END DO - -! lines -jj = obj%entityCounts(1) -DO ii = 1, obj%entityCounts(2) - obj%topology(jj + ii) = ReferenceTopology(p1p2(:, ii), Line2) -END DO - -! faces -jj = jj + obj%entityCounts(2) -DO ii = 1, obj%entityCounts(3) - obj%topology(jj + ii) = ReferenceTopology(lloop(:, ii), Triangle3) -END DO - -! cell -jj = jj + obj%entityCounts(3) -obj%topology(jj + 1) = ReferenceTopology(arange(1_I4B, tNodes), Tetrahedron4) - -obj%highorderElement => highorderElement_Tetrahedron -END PROCEDURE Initiate_Ref_Tetrahedron - -!---------------------------------------------------------------------------- -! ReferenceTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Tetrahedron -CALL Initiate_Ref_tetrahedron(obj=obj, nsd=nsd, xij=xij, & - & domainName=domainName) -END PROCEDURE Reference_Tetrahedron - -!---------------------------------------------------------------------------- -! ReferenceTetrahedron_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reference_Tetrahedron_Pointer -ALLOCATE (obj) -CALL Initiate_Ref_tetrahedron(obj=obj, nsd=nsd, xij=xij, & - & domainName=domainName) -END PROCEDURE Reference_Tetrahedron_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HighOrderElement_Tetrahedron -INTEGER(I4B), PARAMETER :: tNodes = 4 -INTEGER(I4B) :: ii, tFaceNodes(4), faceElemType(4), jj, & - & edgetype -INTEGER(I4B), ALLOCATABLE :: edgecon(:, :), facecon(:, :) - -CALL DEALLOCATE (obj) - -obj%xij = InterpolationPoint_Tetrahedron( & - & xij=refelem%xij(1:3, 1:tNodes), & - & order=order, & - & ipType=ipType, & - & layout="VEFC") - -obj%domainName = refelem%domainName -obj%nsd = refelem%nsd -obj%highOrderElement => refelem%highOrderElement -obj%order = order -obj%xiDimension = refelem%xiDimension - -ii = LagrangeDOF_Tetrahedron(order=order) -obj%name = ElementType_Tetrahedron("Tetrahedron"//INT2STR(ii)) -obj%entityCounts = TotalEntities_Tetrahedron(obj%name) - -ii = SUM(obj%entityCounts) -CALL RefTopoReallocate(obj%topology, ii) - -! points -DO ii = 1, obj%entityCounts(1) - obj%topology(ii) = ReferenceTopology([ii], Point) -END DO - -CALL Reallocate(edgecon, order + 1, obj%entityCounts(2)) -CALL GetEdgeConnectivity_Tetrahedron(con=edgecon, order=order) -edgetype = ElementType_Line("Line"//Int2STR(order + 1)) - -! lines -jj = obj%entityCounts(1) -DO ii = 1, obj%entityCounts(2) - obj%topology(jj + ii) = ReferenceTopology(nptrs=edgecon(:, ii), & - & name=edgetype) -END DO - -CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & - & tFaceNodes=tFaceNodes, elemType=obj%name) -CALL Reallocate(facecon, tFaceNodes(1), obj%entityCounts(3)) -CALL GetFaceConnectivity_Tetrahedron(con=facecon, order=order) - -! faces -jj = jj + obj%entityCounts(2) -DO ii = 1, obj%entityCounts(3) - obj%topology(jj + ii) = ReferenceTopology( & - & nptrs=facecon(1:tFaceNodes(ii), ii), & - & name=faceElemType(ii)) -END DO - -! cell -jj = jj + obj%entityCounts(3) -obj%topology(jj + 1) = ReferenceTopology( & - & arange(1_I4B, obj%entityCounts(1)), obj%name) - -IF (ALLOCATED(edgecon)) DEALLOCATE (edgecon) -IF (ALLOCATED(facecon)) DEALLOCATE (facecon) - -END PROCEDURE HighOrderElement_Tetrahedron - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Tetrahedron -CALL TetrahedronVolume3D(XiJ(1:3, 1:4), ans) -END PROCEDURE Measure_Simplex_Tetrahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Tetrahedron_Quality -ans = 0.0_DFP -! TODO Implement Tetrahedron_Quality -END PROCEDURE Tetrahedron_Quality - -!---------------------------------------------------------------------------- -! TetrahedronVolume3D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TetrahedronVolume3D -REAL(DFP) :: a(4, 4) -a(1:3, 1:4) = xij(1:3, 1:4) -a(4, 1:4) = 1.0_DFP -ans = ABS(Det(a)) / 6.0_DFP -END PROCEDURE TetrahedronVolume3D - -!---------------------------------------------------------------------------- -! RefCoord_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefCoord_Tetrahedron -CHARACTER(:), ALLOCATABLE :: layout -layout = UpperCase(refTetrahedron) -SELECT CASE (layout) -CASE ("BIUNIT") - ans(:, 1) = [-1.0_DFP, -1.0_DFP, -1.0_DFP] - ans(:, 2) = [1.0_DFP, -1.0_DFP, -1.0_DFP] - ans(:, 3) = [-1.0_DFP, 1.0_DFP, -1.0_DFP] - ans(:, 4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP] -CASE ("UNIT") - ans(:, 1) = [0.0_DFP, 0.0_DFP, 0.0_DFP] - ans(:, 2) = [1.0_DFP, 0.0_DFP, 0.0_DFP] - ans(:, 3) = [0.0_DFP, 1.0_DFP, 0.0_DFP] - ans(:, 4) = [0.0_DFP, 0.0_DFP, 1.0_DFP] -END SELECT -layout = "" -END PROCEDURE RefCoord_Tetrahedron - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity_Tetrahedron -INTEGER(I4B) :: order0, ii, jj, iface -con(1:2, 1) = [1, 2] -con(1:2, 2) = [1, 3] -con(1:2, 3) = [1, 4] -con(1:2, 4) = [2, 3] -con(1:2, 5) = [2, 4] -con(1:2, 6) = [3, 4] - -order0 = Input(default=1_I4B, option=order) - -IF (PRESENT(ncol)) ncol = 6 -IF (PRESENT(nrow)) nrow = order0 + 1 - -jj = 4 -DO iface = 1, 6 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - END DO - jj = jj + order0 - 1 -END DO - -END PROCEDURE GetEdgeConnectivity_Tetrahedron - -!---------------------------------------------------------------------------- -! GetFaceConnectivity_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity_Tetrahedron -INTEGER(I4B) :: order0, jj -con(1:3, 1) = [1, 3, 2] -con(1:3, 2) = [1, 2, 4] -con(1:3, 3) = [1, 4, 3] -con(1:3, 4) = [2, 3, 4] - -order0 = Input(default=1_I4B, option=order) -IF (PRESENT(ncol)) ncol = 4 - -jj = 4_I4B - -SELECT CASE (order0) -CASE (2_I4B) - con(jj:6, 1) = [6, 8, 5] - con(jj:6, 2) = [5, 9, 7] - con(jj:6, 3) = [7, 10, 6] - con(jj:6, 4) = [8, 10, 9] - jj = 7 -END SELECT - -IF (PRESENT(nrow)) nrow = jj - 1 - -END PROCEDURE GetFaceConnectivity_Tetrahedron - -!---------------------------------------------------------------------------- -! GetFaceElemType -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType_Tetrahedron -INTEGER(I4B) :: elemType0 -elemType0 = Input(default=Tetrahedron4, option=elemType) - -SELECT CASE (elemType0) -CASE (Tetrahedron4) - IF (PRESENT(faceElemType)) & - faceElemType(1:4) = Triangle3 - - IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 3_I4B - -CASE (Tetrahedron10) - IF (PRESENT(faceElemType)) & - faceElemType(1:4) = Triangle6 - - IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 6_I4B - -CASE (Tetrahedron20) - IF (PRESENT(faceElemType)) & - faceElemType(1:4) = Triangle10 - - IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 10_I4B - -CASE (Tetrahedron35) - IF (PRESENT(faceElemType)) & - faceElemType(1:4) = Triangle15 - - IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 15_I4B - -CASE (Tetrahedron56) - IF (PRESENT(faceElemType)) & - faceElemType(1:4) = Triangle21 - - IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 21_I4B - -END SELECT -END PROCEDURE GetFaceElemType_Tetrahedron - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 deleted file mode 100644 index c1bfa8f99..000000000 --- a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 +++ /dev/null @@ -1,849 +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: 2 March 2021 -! summary: This submodule contains methods for [[ReferenceTriangle_]] - -SUBMODULE(ReferenceTriangle_Method) Methods -USE BaseType, ONLY: QualityMeasure -USE ReferenceElement_Method -USE StringUtility -USE ApproxUtility -USE ArangeUtility -USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle, & - & LagrangeDOF_Triangle -USE Triangle_Method -USE InputUtility -USE ReferenceLine_Method, ONLY: ElementType_Line, & - & ElementOrder_Line -USE LineInterpolationUtility, ONLY: InterpolationPoint_Line -USE MiscUtility, ONLY: Int2Str -USE Display_Method -USE ReallocateUtility - -! USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ElementName_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementName_Triangle -SELECT CASE (elemType) -CASE (Triangle3) - ans = "Triangle3" -CASE (Triangle6) - ans = "Triangle6" -CASE (Triangle9) - ans = "Triangle9" -CASE (Triangle10) - ans = "Triangle10" -CASE (Triangle12) - ans = "Triangle12" -CASE (Triangle15a) - ans = "Triangle15a" -CASE (Triangle15b) - ans = "Triangle15b" -CASE (Triangle21) - ans = "Triangle21" -CASE DEFAULT - ans = "NONE" -END SELECT -END PROCEDURE ElementName_Triangle - -!---------------------------------------------------------------------------- -! FacetTopology_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetTopology_Triangle -INTEGER(I4B) :: order, ii, lineType -INTEGER(I4B), ALLOCATABLE :: con(:, :) - -order = ElementOrder_Triangle(elemType) -CALL Reallocate(con, order + 1, 3) -CALL GetFaceConnectivity_Triangle(con=con, & - & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, order=order) -lineType = ElementType_Line("Line"//Int2Str(order + 1)) - -DO ii = 1, 3 - ans(ii)%nptrs = nptrs(con(:, ii)) - ans(ii)%xiDimension = 1 - ans(ii)%name = lineType -END DO - -IF (ALLOCATED(con)) DEALLOCATE (con) - -END PROCEDURE FacetTopology_Triangle - -!---------------------------------------------------------------------------- -! TotalEntities_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalEntities_Triangle -ans(2:4) = [3, 1, 0] -ans(1) = TotalNodesInElement_Triangle(elemType) -END PROCEDURE TotalEntities_Triangle - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TotalNodesInElement_Triangle -SELECT CASE (ElemType) -CASE (Triangle3) - ans = 3 -CASE (Triangle6) - ans = 6 -CASE (Triangle9) - ans = 9 -CASE (Triangle10) - ans = 10 -CASE (Triangle12) - ans = 12 -CASE (Triangle15a) - ans = 15 -CASE (Triangle15b) - ans = 15 -CASE (Triangle21) - ans = 21 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE TotalNodesInElement_Triangle - -!---------------------------------------------------------------------------- -! ElementOrder_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementOrder_Triangle -SELECT CASE (ElemType) -CASE (Triangle3) - ans = 1 -CASE (Triangle6) - ans = 2 -CASE (Triangle9) - ans = 3 -CASE (Triangle10) - ans = 3 -CASE (Triangle12) - ans = 4 -CASE (Triangle15a) - ans = 4 -CASE (Triangle15b) - ans = 5 -CASE (Triangle21) - ans = 5 -END SELECT -END PROCEDURE ElementOrder_Triangle - -!---------------------------------------------------------------------------- -! ElementType_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ElementType_Triangle -SELECT CASE (elemName) -CASE ("Triangle3", "Triangle") - ans = Triangle3 -CASE ("Triangle6") - ans = Triangle6 -CASE ("Triangle9") - ans = Triangle9 -CASE ("Triangle10") - ans = Triangle10 -CASE ("Triangle12") - ans = Triangle12 -CASE ("Triangle15a") - ans = Triangle15a -CASE ("Triangle15b") - ans = Triangle15b -CASE ("Triangle21") - ans = Triangle21 -CASE DEFAULT - ans = 0 -END SELECT -END PROCEDURE ElementType_Triangle - -!---------------------------------------------------------------------------- -! FacetElements_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Triangle1 -INTEGER(I4B) :: ii, istart, tsize, jj -TYPE(ReferenceTopology_) :: topo - -istart = refelem%entityCounts(1) - -ans(1)%xij = InterpolationPoint_Line( & - & order=refelem%order, & - & ipType=refelem%interpolationPointType, & - & layout="VEFC") - -ans(1)%interpolationPointType = refelem%interpolationPointType -ans(1)%nsd = refelem%nsd -DO ii = 2, 3 - ans(ii)%xij = ans(1)%xij - ans(ii)%interpolationPointType = ans(1)%interpolationPointType - ans(ii)%nsd = ans(1)%nsd -END DO - -DO ii = 1, 3 - topo = refelem%topology(istart + ii) - tsize = SIZE(topo%nptrs) - ans(ii)%xiDimension = topo%xiDimension - ans(ii)%name = topo%name - ans(ii)%order = ElementOrder_Line(elemType=topo%name) - ans(ii)%entityCounts = [tsize, 1, 0, 0] - - ALLOCATE (ans(ii)%topology(tsize + 1)) - DO jj = 1, tsize - ans(ii)%topology(jj) = Referencetopology( & - & nptrs=topo%nptrs(jj:jj), name=Point) - END DO - - ans(ii)%topology(tsize + 1) = Referencetopology( & - & nptrs=topo%nptrs, name=topo%name) -END DO - -CALL DEALLOCATE (topo) - -END PROCEDURE FacetElements_Triangle1 - -!---------------------------------------------------------------------------- -! FacetElements_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetElements_Triangle2 -INTEGER(I4B) :: ii, jj, order -INTEGER(I4B), ALLOCATABLE :: facecon(:, :) - -order = ElementOrder_Triangle(elemType) -CALL Reallocate(facecon, order + 1, 3) -CALL GetFaceConnectivity_Triangle(con=facecon, & - & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, order=order) -!! The edges are accordign to gmsh -!! [1,2], [2,3], [3,1] - -DO ii = 1, 3 - - 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=ans(ii)%order, & - & ipType=ans(ii)%interpolationPointType, & - & layout="VEFC") - - ans(ii)%nsd = nsd - ans(ii)%entityCounts = [order + 1, 1, 0, 0] - ALLOCATE (ans(ii)%topology(order + 2)) - - DO jj = 1, order + 1 - ans(ii)%topology(jj) = Referencetopology(nptrs=facecon(jj:jj, ii), & - & name=Point) - END DO - - ans(ii)%topology(order + 2) = Referencetopology(nptrs=facecon(1:2, ii), & - & name=ans(ii)%name) - -END DO - -IF (ALLOCATED(facecon)) DEALLOCATE (facecon) - -END PROCEDURE FacetElements_Triangle2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE initiate_ref_Triangle -REAL(DFP) :: unit_xij(2, 3), biunit_xij(2, 3) -INTEGER(I4B) :: facecon(2, 3), ii - -CALL DEALLOCATE (obj) - -unit_xij = RefCoord_Triangle("UNIT") -biunit_xij = RefCoord_Triangle("BIUNIT") - -IF (PRESENT(xij)) THEN - obj%xij = xij(1:2, 1:3) - IF (ALL(obj%xij(1:2, 1:3) .approxeq.unit_xij)) THEN - obj%domainName = "UNIT" - ELSE IF (ALL(obj%xij(1:2, 1:3) .approxeq.biunit_xij)) THEN - obj%domainName = "BIUNIT" - ELSE - obj%domainName = "GENERAL" - END IF - -ELSE - - IF (PRESENT(domainName)) THEN - obj%domainName = UpperCase(domainName) - IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN - obj%xij = RefCoord_Triangle(obj%domainName) - END IF - ELSE - obj%domainName = "UNIT" - obj%xij = RefCoord_Triangle(obj%domainName) - END IF - -END IF - -obj%entityCounts = [3, 3, 1, 0] -obj%xiDimension = 2 -obj%name = Triangle3 -obj%order = 1 -obj%nsd = nsd - -ALLOCATE (obj%topology(7)) -obj%topology(1) = Referencetopology([1], Point) -obj%topology(2) = Referencetopology([2], Point) -obj%topology(3) = Referencetopology([3], Point) - -CALL GetFaceConnectivity_Triangle(con=facecon, & - & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, & - & order=1) - -DO ii = 1, 3 - obj%topology(3 + ii) = Referencetopology(facecon(1:2, ii), Line2) -END DO - -obj%topology(7) = Referencetopology([1, 2, 3], Triangle3) - -obj%highorderElement => highorderElement_Triangle -END PROCEDURE initiate_ref_Triangle - -!---------------------------------------------------------------------------- -! ReferenceTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE reference_Triangle -CALL initiate_ref_triangle(obj=obj, nsd=nsd, xij=xij, domainName=domainName) -END PROCEDURE reference_Triangle - -!---------------------------------------------------------------------------- -! ReferenceTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE reference_Triangle_Pointer -ALLOCATE (obj) -CALL initiate_ref_triangle(obj=obj, nsd=nsd, xij=xij, domainName=domainName) -END PROCEDURE reference_Triangle_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HighorderElement_Triangle -INTEGER(I4B) :: linetype, ii, nns -INTEGER(I4B), ALLOCATABLE :: facecon(:, :) - -CALL DEALLOCATE (obj) - -obj%xij = InterpolationPoint_Triangle( & - & xij=refelem%xij(:, 1:3), & - & order=order, & - & ipType=ipType, & - & layout="VEFC") - -obj%domainName = refelem%domainName -obj%nsd = refelem%nsd -obj%highOrderElement => refelem%highOrderElement -obj%order = order -obj%xidimension = refelem%xidimension -nns = LagrangeDOF_Triangle(order=order) -obj%name = ElementType_Triangle("Triangle"//Int2Str(nns)) -obj%entityCounts = TotalEntities_Triangle(obj%name) -ii = SUM(obj%entityCounts) -CALL RefTopoReallocate(obj%topology, ii) - -DO ii = 1, obj%entityCounts(1) - obj%topology(ii) = ReferenceTopology([ii], Point) -END DO - -CALL Reallocate(facecon, order + 1, obj%entityCounts(2)) -CALL GetFaceConnectivity_Triangle(con=facecon, & - & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, order=order) - -linetype = ElementType_Line("Line"//Int2Str(order + 1)) -ii = obj%entityCounts(1) -obj%topology(ii + 1) = ReferenceTopology(facecon(:, 1), linetype) -obj%topology(ii + 2) = ReferenceTopology(facecon(:, 2), linetype) -obj%topology(ii + 3) = ReferenceTopology(facecon(:, 3), linetype) -obj%topology(ii + 4) = ReferenceTopology(facecon(:, 4), linetype) - -ii = ii + obj%entityCounts(2) -obj%topology(ii + 1) = ReferenceTopology(arange(1_I4B, nns), obj%name) - -IF (ALLOCATED(facecon)) DEALLOCATE (facecon) -END PROCEDURE HighorderElement_Triangle - -!---------------------------------------------------------------------------- -! MeasureSimplex -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Measure_Simplex_Triangle -ans = triangle_area(refelem, xij) -END PROCEDURE Measure_Simplex_Triangle - -!---------------------------------------------------------------------------- -! Triangle_Angles -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_angles -SELECT CASE (refelem%nsd) -CASE (2) - ans = triangle_angles_2d(xij(1:2, 1:3)) -CASE (3) - ans = triangle_angles_3d(xij(1:3, 1:3)) -END SELECT -END PROCEDURE triangle_angles - -!---------------------------------------------------------------------------- -! Triangle_Area -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_area -SELECT CASE (refelem%nsd) -CASE (2) - ans = triangle_area_2d(xij(1:2, 1:3)) -CASE (3) - ans = TRIANGLE_AREA_3D(xij(1:3, 1:3)) -END SELECT -END PROCEDURE triangle_area - -!---------------------------------------------------------------------------- -! Triangle_ArealVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_ArealVector -SELECT CASE (refelem%nsd) -CASE (2) - ans(1:2) = 0.0_DFP - ans(3) = triangle_area_2d(xij(1:2, 1:3)) -CASE (3) - ans = triangle_area_vector_3d(xij(1:3, 1:3)) -END SELECT -END PROCEDURE triangle_ArealVector - -!---------------------------------------------------------------------------- -! Triangle_Barycentric -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_barycentric -ans = triangle_barycentric_2d(xij(1:2, 1:3), x(1:2)) -END PROCEDURE triangle_barycentric - -!---------------------------------------------------------------------------- -! Triangle_Centroid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_centroid -IF (refelem%nsd .EQ. 2) THEN - Ans(3) = 0.0_DFP - ans(1:2) = triangle_centroid_2d(xij) -ELSE - ans = triangle_centroid_3d(xij) -END IF -END PROCEDURE triangle_centroid - -!---------------------------------------------------------------------------- -! triangle_circumcentre -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumcentre -IF (refelem%nsd .EQ. 2) THEN - Ans(3) = 0.0_DFP - ans(1:2) = triangle_circumcenter_2d(xij) -ELSE - ans = triangle_circumcenter(3_I4B, xij) -END IF -END PROCEDURE triangle_circumcentre - -!---------------------------------------------------------------------------- -! triangle_circumcircle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumcircle -Ans(4) = 0.0_DFP -CALL triangle_circumcircle_2d(xij, ans(1), ans(2:3)) -END PROCEDURE triangle_circumcircle - -!---------------------------------------------------------------------------- -! triangle_circumradius -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumradius -ans = triangle_circumradius_2d(xij) -END PROCEDURE triangle_circumradius - -!---------------------------------------------------------------------------- -! triangle_contains_line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_contains_line -IF (parametricLine) THEN - CALL triangle_contains_line_par_3d(xij, x1, x2, & - & inside, xint) -ELSE - CALL triangle_contains_line_exp_3d(xij, x1, x2, & - & inside, xint) -END IF -END PROCEDURE triangle_contains_line - -!---------------------------------------------------------------------------- -! triangle_contains_point -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_contains_point -ans = triangle_contains_point_2d_1(xij(1:2, 1:3), x(1:2)) -END PROCEDURE triangle_contains_point - -!---------------------------------------------------------------------------- -! triangle_diameter -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_diameter -ans = triangle_diameter_2d(xij(1:2, 1:3)) -END PROCEDURE triangle_diameter - -!---------------------------------------------------------------------------- -! triangle_edge_length -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_edge_length -ans = triangle_edge_length_2d(xij(1:2, 1:3)) -END PROCEDURE triangle_edge_length - -!---------------------------------------------------------------------------- -! triangle_incenter -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_incenter -Ans(3) = 0.0_DFP -ans(1:2) = triangle_incenter_2d(xij(1:2, 1:3)) -END PROCEDURE triangle_incenter - -!---------------------------------------------------------------------------- -! triangle_incircle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_incircle -Ans(4) = 0.0_DFP -CALL triangle_incircle_2d(xij(1:2, 1:3), Ans(1), Ans(2:3)) -END PROCEDURE triangle_incircle - -!---------------------------------------------------------------------------- -! triangle_inradius -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_inradius -ans = triangle_inradius_2d(xij(1:2, 1:3)) -END PROCEDURE triangle_inradius - -!---------------------------------------------------------------------------- -! triangle_orthocenter -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_orthocenter -Ans(3) = 0.0_DFP -ans(1:2) = triangle_orthocenter_2d(xij(1:2, 1:3)) -END PROCEDURE triangle_orthocenter - -!---------------------------------------------------------------------------- -! triangle_point_dist -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_point_dist -SELECT CASE (refelem%nsd) -CASE (2) - ans = triangle_point_dist_2d(xij(1:2, 1:3), x(1:2)) -CASE (3) - ans = triangle_point_dist_3d(xij(1:3, 1:3), x(1:3)) -END SELECT -END PROCEDURE triangle_point_dist - -!---------------------------------------------------------------------------- -! triangle_nearest_point -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_get_nearest_point -CALL triangle_point_near_2d(xij(1:2, 1:3), x(1:2), xn(1:2), dist) -END PROCEDURE triangle_get_nearest_point - -!---------------------------------------------------------------------------- -! triangle_random_point -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_random_point -Ans = 0.0_DFP -ans(1:2, 1:n) = triangle_sample(xij(1:2, 1:3), n, seed) -END PROCEDURE triangle_random_point - -!---------------------------------------------------------------------------- -! triangle_quality -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_quality -REAL(DFP) :: rvar(3) - -SELECT CASE (measure) - -CASE (QualityMeasure%area) - Ans = Area(refelem=refelem, xij=xij) - -CASE (QualityMeasure%maxangle) - Ans = MAXVAL(Angles(refelem=refelem, xij=xij)) - -CASE (QualityMeasure%minangle) - Ans = MINVAL(Angles(refelem=refelem, xij=xij)) - -CASE (QualityMeasure%angleratio) - Ans = 3.0_DFP * MINVAL(Angles(refelem=refelem, xij=xij)) / Pi - -CASE (QualityMeasure%radiusRatio) - Ans = 2.0_DFP * InRadius(refelem=refelem, xij=xij) & - & / CircumRadius(refelem=refelem, xij=xij) - -CASE (QualityMeasure%edgeRatio) - rvar = EdgeLength(refelem=refelem, xij=xij) - Ans = MINVAL(rvar) / MAXVAL(rvar) - -CASE (QualityMeasure%aspectRatio) - rvar = EdgeLength(refelem=refelem, xij=xij) - Ans = MAXVAL(rvar) * SUM(rvar) & - & / (4.0_DFP * SQRT(3.0_DFP) * area(refelem=refelem, xij=xij)) -END SELECT -END PROCEDURE triangle_quality - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriangleArea3D -INTEGER(I4B), PARAMETER :: dim_num = 3 -REAL(DFP) :: cross(dim_num) - -! Compute the cross product vector. -cross(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & - - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) -cross(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & - - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) -cross(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) -ans = 0.5_DFP * SQRT(SUM(cross(1:3)**2)) -END PROCEDURE TriangleArea3D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriangleArea2D -ans = 0.5_DFP * ( & - t(1, 1) * (t(2, 2) - t(2, 3)) & - + t(1, 2) * (t(2, 3) - t(2, 1)) & - + t(1, 3) * (t(2, 1) - t(2, 2))) -END PROCEDURE TriangleArea2D - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeConnectivity_Triangle -INTEGER(I4B) :: opt0, order0, ii, jj, iface - -opt0 = Input(default=1_I4B, option=opt) -order0 = Input(default=1_I4B, option=order) -jj = 3 - -IF (PRESENT(ncol)) ncol = 3 -IF (PRESENT(nrow)) nrow = 1 + order0 - -SELECT CASE (opt0) -CASE (1_I4B) - con(1:2, 1) = [1, 2] - con(1:2, 2) = [1, 3] - con(1:2, 3) = [2, 3] - - iface = 1 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - jj = jj + 1 - END DO - - iface = 3 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - jj = jj + 1 - END DO - - iface = 2 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - jj = jj + 1 - END DO - -CASE (2_I4B) - !! For Lagrangian polynomial - con(1:2, 1) = [1, 2] - con(1:2, 2) = [2, 3] - con(1:2, 3) = [3, 1] - - iface = 1 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - jj = jj + 1 - END DO - - iface = 2 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - jj = jj + 1 - END DO - - iface = 3 - DO ii = 1, order0 - 1 - con(2 + ii, iface) = jj + ii - jj = jj + 1 - END DO -END SELECT - -END PROCEDURE GetEdgeConnectivity_Triangle - -!---------------------------------------------------------------------------- -! GetFaceConnectivity_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceConnectivity_Triangle -CALL GetEdgeconnectivity_Triangle(con=con, opt=2_I4B, order=order, & - nrow=nrow, ncol=ncol) -END PROCEDURE GetFaceConnectivity_Triangle - -!---------------------------------------------------------------------------- -! RefTriangleCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefTriangleCoord -CHARACTER(:), ALLOCATABLE :: layout -layout = UpperCase(refTriangle) -SELECT CASE (layout) -CASE ("BIUNIT") - ans(:, 1) = [-1.0_DFP, -1.0_DFP] - ans(:, 2) = [1.0_DFP, -1.0_DFP] - ans(:, 3) = [-1.0_DFP, 1.0_DFP] -CASE ("UNIT") - ans(:, 1) = [0.0_DFP, 0.0_DFP] - ans(:, 2) = [1.0_DFP, 0.0_DFP] - ans(:, 3) = [0.0_DFP, 1.0_DFP] -END SELECT -layout = "" -END PROCEDURE RefTriangleCoord - -!---------------------------------------------------------------------------- -! FaceShapeMetaData_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FaceShapeMetaData_Triangle -INTEGER(I4B), PARAMETER :: HelpFaceData_Triangle(2, 3) = & - & RESHAPE([ & - & 2, 3, & - & 3, 1, & - & 1, 2 & - & ], [2, 3]) - -INTEGER(I4B) :: a(3), localFaces0(3) - -a(1) = MINLOC(face, 1) -a(2) = HelpFaceData_Triangle(1, a(1)) !b -a(3) = HelpFaceData_Triangle(2, a(1)) !c - -localFaces0 = face(a) -IF (PRESENT(localFaces)) THEN - localFaces(1:3) = localFaces0 -END IF - -sorted_face(1) = localFaces0(1) - -IF (localFaces0(2) .LT. localFaces0(3)) THEN - sorted_face(2) = localFaces0(2) - sorted_face(3) = localFaces0(3) - - IF (PRESENT(faceOrient)) THEN - faceOrient(1) = a(1) - 1_I4B - faceOrient(2) = 1_INT8 - END IF - -ELSE - sorted_face(2) = localFaces0(3) - sorted_face(3) = localFaces0(2) - - IF (PRESENT(faceOrient)) THEN - faceOrient(1) = a(1) - 1_I4B - faceOrient(2) = -1_INT8 - END IF - -END IF - -END PROCEDURE FaceShapeMetaData_Triangle - -!---------------------------------------------------------------------------- -! GetFaceElemType_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFaceElemType_Triangle -INTEGER(I4B) :: elemType0 - -elemType0 = input(default=Triangle, option=elemType) - -SELECT CASE (elemType0) - -CASE (Triangle3) - - IF (PRESENT(faceElemType)) faceElemType(1:3) = Line2 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 2_I4B - -CASE (Triangle6) - IF (PRESENT(faceElemType)) faceElemType(1:3) = Line3 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 3_I4B - -CASE (Triangle9, Triangle10) - IF (PRESENT(faceElemType)) faceElemType(1:3) = Line4 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 4_I4B - -CASE (Triangle15) - IF (PRESENT(faceElemType)) faceElemType(1:3) = Line5 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 5_I4B - -CASE (Triangle21a, Triangle21b) - IF (PRESENT(faceElemType)) faceElemType(1:3) = Line6 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 6_I4B - -CASE (Triangle18) - IF (PRESENT(faceElemType)) faceElemType(1:3) = Line7 - IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 7_I4B - -END SELECT - -END PROCEDURE GetFaceElemType_Triangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/Triangle_Method@Methods.F90 b/src/submodules/Geometry/src/Triangle_Method@Methods.F90 deleted file mode 100644 index 70337ee7d..000000000 --- a/src/submodules/Geometry/src/Triangle_Method@Methods.F90 +++ /dev/null @@ -1,1435 +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(Triangle_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_angles_2d -INTEGER(I4B), PARAMETER :: dim_num = 2 -REAL(DFP), PARAMETER :: r8_pi = 3.141592653589793D+00 -REAL(DFP) :: a -REAL(DFP) :: b -REAL(DFP) :: c -! -! Compute the length of each side. -! -a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) -b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) -c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) -! -! Take care of ridiculous special cases. -! -IF (a == 0.0D+00 .AND. b == 0.0D+00 .AND. c == 0.0D+00) THEN - angle(1:3) = 2.0D+00 * r8_pi / 3.0D+00 - RETURN -END IF -! -IF (c == 0.0D+00 .OR. a == 0.0D+00) THEN - angle(1) = r8_pi -ELSE - angle(1) = safe_ACOS((c * c + a * a - b * b) / (2.0D+00 * c * a)) -END IF -! -IF (a == 0.0D+00 .OR. b == 0.0D+00) THEN - angle(2) = r8_pi -ELSE - angle(2) = safe_ACOS((a * a + b * b - c * c) / (2.0D+00 * a * b)) -END IF -! -IF (b == 0.0D+00 .OR. c == 0.0D+00) THEN - angle(3) = r8_pi -ELSE - angle(3) = safe_ACOS((b * b + c * c - a * a) / (2.0D+00 * b * c)) -END IF -END PROCEDURE triangle_angles_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_angles_3d -INTEGER(I4B), PARAMETER :: dim_num = 3 -REAL(DFP) :: a -REAL(DFP) :: b -REAL(DFP) :: c -REAL(DFP), PARAMETER :: r8_pi = 3.141592653589793D+00 -! -! Compute the length of each side. -! -a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) -b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) -c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) -! -! Take care of a ridiculous special case. -! -IF (a == 0.0_DFP .AND. b == 0.0_DFP .AND. c == 0.0_DFP) THEN - angle(1:3) = 2.0_DFP * r8_pi / 3.0_DFP - RETURN -END IF -! -IF (c == 0.0_DFP .OR. a == 0.0_DFP) THEN - angle(1) = r8_pi -ELSE - angle(1) = safe_acos((c * c + a * a - b * b) / (2.0_DFP * c * a)) -END IF -! -IF (a == 0.0_DFP .OR. b == 0.0_DFP) THEN - angle(2) = r8_pi -ELSE - angle(2) = safe_acos((a * a + b * b - c * c) / (2.0_DFP * a * b)) -END IF -! -IF (b == 0.0_DFP .OR. c == 0.0_DFP) THEN - angle(3) = r8_pi -ELSE - angle(3) = safe_acos((b * b + c * c - a * a) / (2.0_DFP * b * c)) -END IF -! -END PROCEDURE triangle_angles_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_area_2d -area = 0.5_DFP * ( & - t(1, 1) * (t(2, 2) - t(2, 3)) & - + t(1, 2) * (t(2, 3) - t(2, 1)) & - + t(1, 3) * (t(2, 1) - t(2, 2))) -END PROCEDURE triangle_area_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_area_3d -INTEGER(I4B), PARAMETER :: dim_num = 3_I4B -REAL(DFP) :: cross(dim_num) -! -! Compute the cross product vector. -! -cross(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & - - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) -! -cross(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & - - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) -! -cross(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) -! -area = 0.5D+00 * SQRT(SUM(cross(1:3)**2)) -END PROCEDURE triangle_area_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_area_3d_2 -INTEGER(I4B), PARAMETER :: dim_num = 3 -REAL(DFP) :: alpha -REAL(DFP) :: base -REAL(DFP) :: dot -REAL(DFP) :: height -! -! Find the projection of (P3-P1) onto (P2-P1). -! -dot = (t(1, 2) - t(1, 1)) * (t(1, 3) - t(1, 1)) & - + (t(2, 2) - t(2, 1)) * (t(2, 3) - t(2, 1)) & - + (t(3, 2) - t(3, 1)) * (t(3, 3) - t(3, 1)) -! -! Find the length of (P2-P1). -! -base = SQRT((t(1, 2) - t(1, 1))**2 & - & + (t(2, 2) - t(2, 1))**2 & - & + (t(3, 2) - t(3, 1))**2) -! -! The height of the triangle is the length of (P3-P1) after its -! projection onto (P2-P1) has been subtracted. -! -IF (base == 0.0_DFP) THEN - height = 0.0_DFP -ELSE - alpha = dot / (base * base) - height = SQRT( & - (t(1, 1) + alpha * (t(1, 2) - t(1, 1)) - t(1, 3))**2 & - + (t(2, 1) + alpha * (t(2, 2) - t(2, 1)) - t(2, 3))**2 & - + (t(3, 1) + alpha * (t(3, 2) - t(3, 1)) - t(3, 3))**2) -END IF -! -area = 0.5_DFP * base * height -! -END PROCEDURE triangle_area_3d_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_area_3d_3 -INTEGER(i4b), PARAMETER :: dim_num = 3 -INTEGER(i4b) :: i -INTEGER(i4b) :: j -INTEGER(i4b) :: jp1 -REAL(dfp) :: s(3) -!! -DO j = 1, 3 - jp1 = MOD(j, 3) + 1 - s(j) = 0.0D+00 - DO i = 1, dim_num - s(j) = s(j) + (t(i, j) - t(i, jp1))**2 - END DO - s(j) = SQRT(s(j)) -END DO -!! -area = (s(1) + s(2) + s(3)) & - * (-s(1) + s(2) + s(3)) & - * (s(1) - s(2) + s(3)) & - * (s(1) + s(2) - s(3)) -!! -IF (area < 0.0D+00) THEN - area = -1.0D+00 - RETURN -END IF -!! -area = 0.25D+00 * SQRT(area) -END PROCEDURE triangle_area_3d_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_area_heron -area = (s(1) + s(2) + s(3)) & - * (-s(1) + s(2) + s(3)) & - * (s(1) - s(2) + s(3)) & - * (s(1) + s(2) - s(3)) -IF (area < 0.0D+00) THEN - area = -1.0D+00 - RETURN -END IF -area = 0.25D+00 * SQRT(area) -END PROCEDURE triangle_area_heron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_area_vector_3d -INTEGER(i4b), PARAMETER :: dim_num = 3 - -area_vector(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & - - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) - -area_vector(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & - - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) - -area_vector(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) -END PROCEDURE triangle_area_vector_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_barycentric_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b), PARAMETER :: rhs_num = 1 -REAL(dfp) :: a(dim_num, dim_num + rhs_num) -INTEGER(i4b) :: info -! -! Set up the linear system -! -! ( X2-X1 X3-X1 ) XSI(1) = X-X1 -! ( Y2-Y1 Y3-Y1 ) XSI(2) Y-Y1 -! -! which is satisfied by the barycentric coordinates of P. -! -a(1, 1) = t(1, 2) - t(1, 1) -a(1, 2) = t(1, 3) - t(1, 1) -a(1, 3) = p(1) - t(1, 1) -! -a(2, 1) = t(2, 2) - t(2, 1) -a(2, 2) = t(2, 3) - t(2, 1) -a(2, 3) = p(2) - t(2, 1) -! -! Solve the linear system. -! -CALL r8mat_solve(n=dim_num, rhs_num=rhs_num, a=a, info=info) -! -xsi(1) = a(1, 3) -xsi(2) = a(2, 3) -xsi(3) = 1.0D+00 - xsi(1) - xsi(2) -END PROCEDURE triangle_barycentric_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_centroid_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b) :: i -DO i = 1, dim_num - centroid(i) = SUM(t(i, 1:3)) / 3.0D+00 -END DO -END PROCEDURE triangle_centroid_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_centroid_3d -INTEGER(i4b), PARAMETER :: dim_num = 3 -INTEGER(i4b) :: i -DO i = 1, dim_num - centroid(i) = SUM(t(i, 1:3)) / 3.0D+00 -END DO -END PROCEDURE triangle_centroid_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumcenter_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: avar -REAL(dfp) :: f(2) -REAL(dfp) :: top(dim_num) - -f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 -f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 - -top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) -top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) - -avar = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) - -pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / avar -END PROCEDURE triangle_circumcenter_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumcenter_2d_2 -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b), PARAMETER :: rhs_num = 1 -REAL(dfp) :: a(dim_num, dim_num + rhs_num) -INTEGER(i4b) :: info -! -! Set up the linear system. -! -a(1, 1) = t(1, 2) - t(1, 1) -a(1, 2) = t(2, 2) - t(2, 1) -a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 -! -a(2, 1) = t(1, 3) - t(1, 1) -a(2, 2) = t(2, 3) - t(2, 1) -a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 -! -! Solve the linear system. -! -CALL r8mat_solve(dim_num, rhs_num, a, info) -! -! Compute the center -! -IF (info /= 0) THEN - pc(1:dim_num) = 0.0D+00 -ELSE - pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) -END IF -END PROCEDURE triangle_circumcenter_2d_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumcenter -REAL(dfp) :: a -REAL(dfp) :: abp -REAL(dfp) :: apc -REAL(dfp) :: b -REAL(dfp) :: c -REAL(dfp) :: pbc -!! -a = r8vec_normsq_affine(n, t(1:n, 2), t(1:n, 3)) -b = r8vec_normsq_affine(n, t(1:n, 3), t(1:n, 1)) -c = r8vec_normsq_affine(n, t(1:n, 1), t(1:n, 2)) -!! -pbc = a * (-a + b + c) -apc = b * (a - b + c) -abp = c * (a + b - c) -!! -p(1:n) = (pbc * t(1:n, 1) + apc * t(1:n, 2) + abp * t(1:n, 3)) & - & / (pbc + apc + abp) -END PROCEDURE triangle_circumcenter - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumcircle_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: a -REAL(dfp) :: b -REAL(dfp) :: bot -REAL(dfp) :: c -REAL(dfp) :: f(2) -REAL(dfp) :: top(dim_num) -REAL(dfp) :: avar -! -! Circumradius. -! -a = SQRT((t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2) -b = SQRT((t(1, 3) - t(1, 2))**2 + (t(2, 3) - t(2, 2))**2) -c = SQRT((t(1, 1) - t(1, 3))**2 + (t(2, 1) - t(2, 3))**2) -! -bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) -! -IF (bot <= 0.0D+00) THEN - r = -1.0D+00 - pc(1:2) = 0.0D+00 - RETURN -END IF -! -r = a * b * c / SQRT(bot) -! -! Circumcenter. -! -f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 -f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 -! -top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) -top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) -! -avar = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & - & - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) -! -pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / avar -! -END PROCEDURE triangle_circumcircle_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumcircle_2d_2 -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b), PARAMETER :: rhs_num = 1 -REAL(dfp) :: a(dim_num, dim_num + rhs_num) -INTEGER(i4b) :: info -! -! Set up the linear system. -! -a(1, 1) = t(1, 2) - t(1, 1) -a(1, 2) = t(2, 2) - t(2, 1) -a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 - -a(2, 1) = t(1, 3) - t(1, 1) -a(2, 2) = t(2, 3) - t(2, 1) -a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 -! -! Solve the linear system. -! -CALL r8mat_solve(dim_num, rhs_num, a, info) - -IF (info /= 0) THEN - r = -1.0D+00 - pc(1:dim_num) = 0.0D+00 -END IF - -r = 0.5D+00 * SQRT(a(1, dim_num + 1) * a(1, dim_num + 1) & - + a(2, dim_num + 1) * a(2, dim_num + 1)) -pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) - -END PROCEDURE triangle_circumcircle_2d_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_circumradius_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: a -REAL(dfp) :: b -REAL(dfp) :: bot -REAL(dfp) :: c -! -! Compute the length of each side. -! -a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) -b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) -c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) -bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) -IF (bot <= 0.0D+00) THEN - r = -1.0D+00 - RETURN -END IF -r = a * b * c / SQRT(bot) -END PROCEDURE triangle_circumradius_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_contains_line_exp_3d -INTEGER(i4b), PARAMETER :: dim_num = 3 -INTEGER(i4b) :: ival -REAL(dfp) :: normal(dim_num) -REAL(dfp) :: normal2(dim_num) -REAL(dfp) :: temp -REAL(dfp) :: v1(dim_num) -REAL(dfp) :: v2(dim_num) -! -! Make sure the line is not degenerate. -! -IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) RETURN -! -! Make sure the triangle is not degenerate. -! -IF (triangle_is_degenerate_nd(dim_num, t)) RETURN -! -! Determine a unit normal vector associated with the plane of -! the triangle. -! -v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) -v2(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 1) -! -normal(1) = v1(2) * v2(3) - v1(3) * v2(2) -normal(2) = v1(3) * v2(1) - v1(1) * v2(3) -normal(3) = v1(1) * v2(2) - v1(2) * v2(1) -! -temp = SQRT(SUM(normal(1:dim_num)**2)) -normal(1:dim_num) = normal(1:dim_num) / temp -! -! 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) -! -IF (ival == 0) THEN - inside = .FALSE. - pint(1:dim_num) = HUGE(temp) - RETURN -ELSE IF (ival == 2) THEN - inside = .FALSE. - pint(1:dim_num) = p1(1:dim_num) - RETURN -END IF -! -! Now, check that all three triangles made by two vertices and -! the intersection point have the same "clock sense" as the -! triangle's normal vector. -! -v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) -v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 1) -! -normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) -normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) -normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) - -IF (DOT_PRODUCT(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) THEN - inside = .FALSE. - RETURN -END IF - -v1(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 2) -v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 2) - -normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) -normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) -normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) - -IF (DOT_PRODUCT(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) THEN - inside = .FALSE. - RETURN -END IF - -v1(1:dim_num) = t(1:dim_num, 1) - t(1:dim_num, 3) -v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 3) - -normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) -normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) -normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) - -IF (DOT_PRODUCT(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) THEN - inside = .FALSE. - RETURN -END IF - -inside = .TRUE. - -END PROCEDURE triangle_contains_line_exp_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_contains_line_par_3d -INTEGER(i4b), PARAMETER :: dim_num = 3 -REAL(dfp) :: a -REAL(dfp) :: angle_sum -REAL(dfp) :: b -REAL(dfp) :: c -REAL(dfp) :: d -REAL(dfp) :: denom -LOGICAL(lgt) :: intersect -REAL(dfp) :: norm -REAL(dfp) :: norm1 -REAL(dfp) :: norm2 -REAL(dfp), PARAMETER :: r8_pi = 3.141592653589793D+00 -REAL(dfp) :: t_int -REAL(dfp), PARAMETER :: tol = 0.00001D+00 -REAL(dfp) :: v1(dim_num) -REAL(dfp) :: v2(dim_num) -REAL(dfp) :: v3(dim_num) -! -! Determine the implicit form (A,B,C,D) of the plane containing the -! triangle. -! -a = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & - - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) - -b = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & - - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) - -c = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & - - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) - -d = -t(1, 2) * a - t(2, 2) * b - t(3, 2) * c -! -! Make sure the plane is well-defined. -! -norm1 = SQRT(a * a + b * b + c * c) - -IF (norm1 == 0.0D+00) THEN - inside = .FALSE. - p(1:dim_num) = 0.0D+00 - RETURN -END IF -! -! Make sure the implicit line is well defined. -! -norm2 = SQRT(SUM(pd(1:dim_num)**2)) - -IF (norm2 == 0.0D+00) THEN - inside = .FALSE. - p(1:dim_num) = 0.0D+00 - RETURN -END IF -! -! Determine the denominator of the parameter in the -! implicit line definition that determines the intersection -! point. -! -denom = a * pd(1) + b * pd(2) + c * pd(3) -! -! If DENOM is zero, or very small, the line and the plane may be -! parallel or almost so. -! -IF (ABS(denom) < tol * norm1 * norm2) THEN -! -! The line may actually lie in the plane. We're not going -! to try to address this possibility. -! - IF (a * p0(1) + b * p0(2) + c * p0(3) + d == 0.0D+00) THEN - - intersect = .TRUE. - inside = .FALSE. - p(1:dim_num) = p0(1:dim_num) -! -! The line and plane are parallel and disjoint. -! - ELSE - - intersect = .FALSE. - inside = .FALSE. - p(1:dim_num) = 0.0D+00 - - END IF -! -! The line and plane intersect at a single point P. -! -ELSE - - intersect = .TRUE. - t_int = -(a * p0(1) + b * p0(2) + c * p0(3) + d) / denom - p(1:dim_num) = p0(1:dim_num) + t_int * pd(1:dim_num) -! -! To see if P is included in the triangle, sum the angles -! formed by P and pairs of the vertices. If the point is in the -! triangle, we get a total 360 degree view. Otherwise, we -! get less than 180 degrees. -! - v1(1:dim_num) = t(1:dim_num, 1) - p(1:dim_num) - v2(1:dim_num) = t(1:dim_num, 2) - p(1:dim_num) - v3(1:dim_num) = t(1:dim_num, 3) - p(1:dim_num) - - norm = SQRT(SUM(v1(1:dim_num)**2)) - - IF (norm == 0.0D+00) THEN - inside = .TRUE. - RETURN - END IF - - v1(1:dim_num) = v1(1:dim_num) / norm - - norm = SQRT(SUM(v2(1:dim_num)**2)) - - IF (norm == 0.0D+00) THEN - inside = .TRUE. - RETURN - END IF - - v2(1:dim_num) = v2(1:dim_num) / norm - - norm = SQRT(SUM(v3(1:dim_num)**2)) - - IF (norm == 0.0D+00) THEN - inside = .TRUE. - RETURN - END IF - - v3(1:dim_num) = v3(1:dim_num) / norm - - angle_sum = safe_acos(DOT_PRODUCT(v1(1:3), v2(1:3))) & - + safe_acos(DOT_PRODUCT(v2(1:3), v3(1:3))) & - + safe_acos(DOT_PRODUCT(v3(1:3), v1(1:3))) - - IF (NINT(angle_sum / r8_pi) == 2) THEN - inside = .TRUE. - ELSE - inside = .FALSE. - END IF - -END IF - -RETURN -END PROCEDURE triangle_contains_line_par_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_contains_point_2d_1 -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: xsi(dim_num + 1) -xsi = triangle_barycentric_2d(t, p) -IF (ANY(xsi(1:3) < 0.0D+00)) THEN - inside = .FALSE. -ELSE - inside = .TRUE. -END IF -END PROCEDURE triangle_contains_point_2d_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_contains_point_2d_2 -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b) :: j -INTEGER(i4b) :: k -DO j = 1, 3 - k = MOD(j, 3) + 1 - IF (0.0D+00 < (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & - - (p(2) - t(2, j)) * (t(1, k) - t(1, j))) THEN - inside = .FALSE. - RETURN - END IF -END DO -inside = .TRUE. -END PROCEDURE triangle_contains_point_2d_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_contains_point_2d_3 -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: dir_new -REAL(dfp) :: dir_old -INTEGER(i4b) :: j -INTEGER(i4b) :: k - -dir_old = 0.0D+00 - -DO j = 1, 3 - k = MOD(j, 3) + 1 - dir_new = (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & - - (p(2) - t(2, j)) * (t(1, k) - t(1, j)) - IF (dir_new * dir_old < 0.0D+00) THEN - inside = .FALSE. - RETURN - END IF - IF (dir_new /= 0.0D+00) THEN - dir_old = dir_new - END IF -END DO -inside = .TRUE. -END PROCEDURE triangle_contains_point_2d_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_diameter_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: a -REAL(dfp) :: asq -REAL(dfp) :: b -REAL(dfp) :: bsq -REAL(dfp) :: c -REAL(dfp) :: csq -! -! Compute the squared length of each side. -! -asq = SUM(t(1:dim_num, 1) - t(1:dim_num, 2))**2 -bsq = SUM(t(1:dim_num, 2) - t(1:dim_num, 3))**2 -csq = SUM(t(1:dim_num, 3) - t(1:dim_num, 1))**2 -! -! Take care of a zero side. -! -IF (asq == 0.0D+00) THEN - diameter = SQRT(bsq) - RETURN -ELSE IF (bsq == 0.0D+00) THEN - diameter = SQRT(csq) - RETURN -ELSE IF (csq == 0.0D+00) THEN - diameter = SQRT(asq) - RETURN -END IF -! -! Make ASQ the largest. -! -IF (asq < bsq) THEN - CALL swap(asq, bsq) -END IF - -IF (asq < csq) THEN - CALL swap(asq, csq) -END IF -! -! If ASQ is very large... -! -IF (bsq + csq < asq) THEN - diameter = SQRT(asq) -ELSE - a = SQRT(asq) - b = SQRT(bsq) - c = SQRT(csq) - diameter = 2.0D+00 * a * b * c / SQRT((a + b + c) * (-a + b + c) & - * (a - b + c) * (a + b - c)) -END IF -END PROCEDURE triangle_diameter_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_edge_length_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b) :: j1, j2 -DO j1 = 1, 3 - j2 = i4_wrap(j1 + 1, 1, 3) - edge_length(j1) = NORM2(t(1:dim_num, j2) - t(1:dim_num, j1)) -END DO -END PROCEDURE triangle_edge_length_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_gridpoints_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b) :: i -INTEGER(i4b) :: j -! -grid_num = 0 -! -! Special case, SUB_NUM = 0. -! -IF (sub_num == 0) THEN - IF (1 <= grid_max) THEN - grid_num = 1 - g(1, 1) = (t(1, 1) + t(1, 2) + t(1, 3)) / 3.0D+00 - g(2, 1) = (t(2, 1) + t(2, 2) + t(2, 3)) / 3.0D+00 - END IF - RETURN -END IF -! -DO i = 0, sub_num - DO j = 0, sub_num - i - IF (grid_num < grid_max) THEN - grid_num = grid_num + 1 - g(1, grid_num) = (REAL(i, kind=8) * t(1, 1) & - & + REAL(j, kind=8) * t(1, 2) & - & + REAL(sub_num - i - j, kind=8) * t(1, 3)) & - & / REAL(sub_num, kind=8) - ! - g(2, grid_num) = (REAL(i, kind=8) * t(2, 1) & - & + REAL(j, kind=8) * t(2, 2) & - & + REAL(sub_num - i - j, kind=8) * t(2, 3)) & - & / REAL(sub_num, kind=8) - END IF - END DO -END DO -! -END PROCEDURE triangle_gridpoints_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_incenter_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: a -REAL(dfp) :: b -REAL(dfp) :: c -REAL(dfp) :: perimeter -! -! Compute the length of each side. -! -a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) -b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) -c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - -perimeter = a + b + c - -IF (perimeter == 0.0D+00) THEN - pc(1:dim_num) = t(1:dim_num, 1) -ELSE - pc(1:dim_num) = (b * t(1:dim_num, 1) & - + c * t(1:dim_num, 2) & - + a * t(1:dim_num, 3)) / perimeter -END IF -END PROCEDURE triangle_incenter_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_incircle_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: a -REAL(dfp) :: b -REAL(dfp) :: c -REAL(dfp) :: perimeter -! -! Compute the length of each side. -! -a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) -b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) -c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - -perimeter = a + b + c - -IF (perimeter == 0.0D+00) THEN - pc(1:dim_num) = t(1:dim_num, 1) - r = 0.0D+00 - RETURN -END IF - -pc(1:dim_num) = ( & - b * t(1:dim_num, 1) & - + c * t(1:dim_num, 2) & - + a * t(1:dim_num, 3)) / perimeter - -r = 0.5D+00 * SQRT( & - (-a + b + c) & - * (+a - b + c) & - * (+a + b - c) / perimeter) -END PROCEDURE triangle_incircle_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_inradius_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) :: a -REAL(dfp) :: b -REAL(dfp) :: c -REAL(dfp) :: perimeter -! -! Compute the length of each side. -! -a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) -b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) -c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) - -perimeter = a + b + c - -IF (perimeter == 0.0D+00) THEN - r = 0.0D+00 - RETURN -END IF - -r = 0.5D+00 * SQRT( & - (-a + b + c) & - * (+a - b + c) & - * (+a + b - c) / perimeter) -END PROCEDURE triangle_inradius_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_is_degenerate_nd -ans = & - & (ALL(t(1:dim_num, 1) == t(1:dim_num, 2)) .OR. & - & ALL(t(1:dim_num, 2) == t(1:dim_num, 3)) .OR. & - & ALL(t(1:dim_num, 3) == t(1:dim_num, 1))) -END PROCEDURE triangle_is_degenerate_nd - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_lattice_layer_point_next -INTEGER(i4b) :: c1n -INTEGER(i4b), PARAMETER :: n = 2 -INTEGER(i4b) :: rhs1 -INTEGER(i4b) :: rhs2 -! -! Treat layer C(N+1) = 0 specially. -! -IF (c(n + 1) == 0) THEN - IF (.NOT. more) THEN - v(1:n) = 0 - more = .TRUE. - ELSE - more = .FALSE. - END IF - RETURN -END IF -! -! Compute first point. -! -IF (.NOT. more) THEN - v(1) = (c(n + 1) - 1) * c(1) + 1 - v(2) = 0 - more = .TRUE. -ELSE - c1n = i4vec_lcm(n, c) - rhs1 = c1n * (c(n + 1) - 1) - rhs2 = c1n * c(n + 1) - IF (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs2) THEN - v(1) = v(1) + 1 - ELSE - v(1) = (rhs1 - c(1) * (v(2) + 1)) / c(2) - v(1) = MAX(v(1), 0) - v(2) = v(2) + 1 - IF (c(2) * v(1) + c(1) * v(2) <= rhs1) THEN - v(1) = v(1) + 1 - END IF - IF (c(2) * v(1) + c(1) * v(2) <= rhs2) THEN - ELSE - v(1:n) = 0 - more = .FALSE. - END IF - END IF -END IF -END PROCEDURE triangle_lattice_layer_point_next - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_lattice_point_next -INTEGER(i4b) c1n -INTEGER(i4b), PARAMETER :: n = 2 -INTEGER(i4b) rhs - -IF (.NOT. more) THEN - - v(1:n) = 0 - more = .TRUE. - -ELSE - - c1n = i4vec_lcm(n, c) - - rhs = c1n * c(n + 1) - - IF (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs) THEN - v(1) = v(1) + 1 - ELSE - v(1) = 0 - IF (c(2) * v(1) + c(1) * (v(2) + 1) <= rhs) THEN - v(2) = v(2) + 1 - ELSE - v(2) = 0 - more = .FALSE. - END IF - END IF -END IF -END PROCEDURE triangle_lattice_point_next - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_line_imp_int_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) a1 -REAL(dfp) b1 -REAL(dfp) c1 -INTEGER(i4b) i -INTEGER(i4b) ival -INTEGER(i4b) j -REAL(dfp) p(dim_num) -REAL(dfp) test1 -REAL(dfp) test2 - -int_num = 0 - -DO i = 1, 3 - j = i4_wrap(i + 1, 1, 3) - ! - ! Get the implicit form of the line through vertices I and I+1. - ! - CALL line_exp2imp_2d(t(1:2, i), t(1:2, j), a1, b1, c1) - ! - ! Seek an intersection with the original line. - ! - CALL lines_imp_int_2d(a, b, c, a1, b1, c1, ival, p) - ! - ! If there is an intersection, determine if it - ! lies between the two vertices. - ! - IF (ival == 1) THEN - test1 = SUM((p(1:dim_num) - t(1:dim_num, i)) & - * (t(1:dim_num, j) - t(1:dim_num, i))) - test2 = SUM((t(1:dim_num, j) - t(1:dim_num, i)) & - * (t(1:dim_num, j) - t(1:dim_num, i))) - ! - IF (0 <= test1 .AND. test1 <= test2) THEN - int_num = int_num + 1 - pint(1:dim_num, int_num) = p(1:dim_num) - END IF - END IF -END DO - -END PROCEDURE triangle_line_imp_int_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_orientation_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) avar - -IF (ALL(t(1:dim_num, 1) == t(1:dim_num, 2)) .OR. & - ALL(t(1:dim_num, 2) == t(1:dim_num, 3)) .OR. & - ALL(t(1:dim_num, 3) == t(1:dim_num, 1))) THEN - ans = 3 - RETURN -END IF - -avar = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & - & - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) - -IF (avar == 0.0D+00) THEN - ans = 2 -ELSE IF (avar < 0.0D+00) THEN - ans = 1 -ELSE IF (0.0D+00 < avar) THEN - ans = 0 -END IF - -END PROCEDURE triangle_orientation_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_orthocenter_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -LOGICAL(lgt) flag -INTEGER(i4b) ival -REAL(dfp) p23(dim_num) -REAL(dfp) p31(dim_num) -! -! Determine a point P23 common to the line (P2,P3) and -! its perpendicular through P1. -! -CALL line_exp_perp_2d(t(1:2, 2), t(1:2, 3), t(1:2, 1), p23, flag) - -IF (flag) THEN - pc(1:2) = r8_huge() - RETURN -END IF -! -! Determine a point P31 common to the line (P3,P1) and -! its perpendicular through P2. -! -CALL line_exp_perp_2d(t(1:2, 3), t(1:2, 1), t(1:2, 2), p31, flag) - -IF (flag) THEN - pc(1:2) = r8_huge() - RETURN -END IF -! -! Determine PC, the intersection of the lines (P1,P23) and (P2,P31). -! -CALL lines_exp_int_2d(t(1:2, 1), p23(1:2), t(1:2, 2), p31(1:2), ival, pc) - -IF (ival /= 1) THEN - pc(1:2) = r8_huge() - flag = .TRUE. - RETURN -END IF - -RETURN -END PROCEDURE triangle_orthocenter_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_point_dist_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b), PARAMETER :: side_num = 3 -REAL(dfp) dist2 -INTEGER(i4b) j -INTEGER(i4b) jp1 -! -! Find the distance to each of the line segments. -! -dist = HUGE(dist) -! -DO j = 1, side_num - jp1 = i4_wrap(j + 1, 1, side_num) - dist2 = segment_point_dist_2d(t(1:dim_num, j), t(1:dim_num, jp1), p) - IF (dist2 < dist) THEN - dist = dist2 - END IF -END DO -END PROCEDURE triangle_point_dist_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_point_dist_3d -INTEGER(i4b), PARAMETER :: dim_num = 3 -REAL(dfp) dist2 -! -! Compute the distances from the point to each of the sides. -! -dist2 = segment_point_dist_3d(t(1:dim_num, 1), t(1:dim_num, 2), p) -dist = dist2 -dist2 = segment_point_dist_3d(t(1:dim_num, 2), t(1:dim_num, 3), p) -dist = MIN(dist, dist2) -dist2 = segment_point_dist_3d(t(1:dim_num, 3), t(1:dim_num, 1), p) -dist = MIN(dist, dist2) -END PROCEDURE triangle_point_dist_3d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_point_dist_signed_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) dis12 -REAL(dfp) dis23 -REAL(dfp) dis31 -! -! Compute the signed line distances to the point. -! -dis12 = line_exp_point_dist_signed_2d(t(1:2, 1), t(1:2, 2), p) -dis23 = line_exp_point_dist_signed_2d(t(1:2, 2), t(1:2, 3), p) -dis31 = line_exp_point_dist_signed_2d(t(1:2, 3), t(1:2, 1), p) -! -! If the point is inside the triangle, all the line distances are negative. -! The largest (negative) line distance has the smallest magnitude, -! and is the signed triangle distance. -! -IF (dis12 <= 0.0D+00 .AND. dis23 <= 0.0D+00 .AND. dis31 <= 0.0D+00) THEN - dist_signed = MAX(dis12, dis23, dis31) -! -! If the point is outside the triangle, then we have to compute -! the (positive) line segment distances and take the minimum. -! -ELSE - dis12 = segment_point_dist_2d(t(1:2, 1), t(1:2, 2), p) - dis23 = segment_point_dist_2d(t(1:2, 2), t(1:2, 3), p) - dis31 = segment_point_dist_2d(t(1:2, 3), t(1:2, 1), p) - dist_signed = MIN(dis12, dis23, dis31) -END IF -! -END PROCEDURE triangle_point_dist_signed_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_point_near_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -INTEGER(i4b), PARAMETER :: side_num = 3 -INTEGER(i4b) j -INTEGER(i4b) jp1 -REAL(dfp) dist2 -REAL(dfp) pn2(dim_num) -REAL(dfp) tval -! -! Find the distance to each of the line segments that make up the edges -! of the triangle. -! -dist = HUGE(dist) -pn(1:dim_num) = 0.0D+00 -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) - IF (dist2 < dist) THEN - dist = dist2 - pn(1:dim_num) = pn2(1:dim_num) - END IF -END DO -END PROCEDURE triangle_point_near_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_quality_2d -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) a -REAL(dfp) b -REAL(dfp) c -! -! Compute the length of each side. -! -a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) -b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) -c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) -IF (a * b * c == 0.0D+00) THEN - quality = 0.0D+00 -ELSE - quality = (-a + b + c) * (a - b + c) * (a + b - c) & - / (a * b * c) -END IF -END PROCEDURE triangle_quality_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_right_lattice_point_num_2d -n = ((a + 1) * (b + 1) + i4_gcd(a, b) + 1) / 2 -END PROCEDURE triangle_right_lattice_point_num_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_sample -INTEGER(i4b), PARAMETER :: dim_num = 2 -REAL(dfp) alpha(n) -INTEGER(i4b) dim -REAL(dfp) p12(dim_num, n) -REAL(dfp) p13(dim_num, n) -! -alpha = rvec_uniform_01(n, seed) -! -! Interpret R as a percentage of the triangle's area. -! -! Imagine a line L, parallel to side 1, so that the area between -! vertex 1 and line L is R percent of the full triangle's area. -! -! The line L will intersect sides 2 and 3 at a fraction -! ALPHA = SQRT ( R ) of the distance from vertex 1 to vertices 2 and 3. -! -alpha(1:n) = SQRT(alpha(1:n)) -! -! Determine the coordinates of the points on sides 2 and 3 intersected -! by line L. -! -DO dim = 1, dim_num - p12(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & - + alpha(1:n) * t(dim, 2) - - p13(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & - + alpha(1:n) * t(dim, 3) -END DO -! -! Now choose, uniformly at random, a point on the line L. -! -alpha = rvec_uniform_01(n, seed) - -DO dim = 1, dim_num - p(dim, 1:n) = (1.0D+00 - alpha(1:n)) * p12(dim, 1:n) & - + alpha(1:n) * p13(dim, 1:n) -END DO - -END PROCEDURE triangle_sample - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle01_lattice_point_num_2d -n = ((s + 2) * (s + 1)) / 2 -END PROCEDURE triangle01_lattice_point_num_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_xsi_to_xy_2d -INTEGER(kind=4), PARAMETER :: dim_num = 2 -p(1:dim_num) = MATMUL(t(1:dim_num, 1:3), xsi(1:dim_num + 1)) -END PROCEDURE triangle_xsi_to_xy_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE triangle_xy_to_xsi_2d -INTEGER(kind=4), PARAMETER :: dim_num = 2 -REAL(kind=8) avar -avar = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & - - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) -xsi(1) = ((t(2, 2) - t(2, 3)) * (p(1) - t(1, 3)) & - - (t(1, 2) - t(1, 3)) * (p(2) - t(2, 3))) / avar - -xsi(2) = (-(t(2, 1) - t(2, 3)) * (p(1) - t(1, 3)) & - + (t(1, 1) - t(1, 3)) * (p(2) - t(2, 3))) / avar - -xsi(3) = 1.0D+00 - xsi(1) - xsi(2) -END PROCEDURE triangle_xy_to_xsi_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#include "./inc/aux.inc" - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/inc/aux.inc b/src/submodules/Geometry/src/inc/aux.inc deleted file mode 100644 index fe70e9a64..000000000 --- a/src/submodules/Geometry/src/inc/aux.inc +++ /dev/null @@ -1,239 +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: 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/Geometry/src/modified_burkardt.inc b/src/submodules/Geometry/src/modified_burkardt.inc deleted file mode 100644 index 8ad0e2dc3..000000000 --- a/src/submodules/Geometry/src/modified_burkardt.inc +++ /dev/null @@ -1,266 +0,0 @@ - -!----------------------------------------------------------------------------- -! -!----------------------------------------------------------------------------- - -PURE FUNCTION R8MATDET4D(a) - !. . . . . . . . . . . . . . . . . . . - !! R8MATDET4D computes the determinant of a 4 by 4 matrix. - ! - ! Licensing: - ! This code is distributed under the GNU LGPL license. - ! Modified: - ! 16 April 1999 - ! Author: - ! John Burkardt - ! Parameters: - ! Input, real ( kind = 8 ) A(4,4), the matrix whose determinant is desired. - ! Output, real ( kind = 8 ) R8MATDET4D, the determinant of the matrix. - !. . . . . . . . . . . . . . . . . . . - - REAL(DFP), INTENT(IN) :: a(4, 4) - REAL(DFP) :: R8MATDET4D - - R8MATDET4D = & - a(1, 1) * ( & - a(2, 2) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & - - a(2, 3) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & - + a(2, 4) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2))) & - - a(1, 2) * ( & - a(2, 1) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & - - a(2, 3) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & - + a(2, 4) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1))) & - + a(1, 3) * ( & - a(2, 1) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & - - a(2, 2) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & - + a(2, 4) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) & - - a(1, 4) * ( & - a(2, 1) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2)) & - - a(2, 2) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1)) & - + a(2, 3) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) - -END FUNCTION R8MATDET4D - -!----------------------------------------------------------------------------- -! -!----------------------------------------------------------------------------- - -PURE SUBROUTINE PARALLELOGRAMAREA3D(p, area) - - !. . . . . . . . . . . . . . . . . . . - !! PARALLELOGRAMAREA3D computes the area of a parallelogram in 3D. - ! - ! Discussion: - ! A parallelogram is a polygon having four sides, with the property - ! that each pair of opposite sides is paralell. - ! A parallelogram in 3D must have the property that it is "really" - ! a 2D object, that is, that the four vertices that define it lie - ! in some plane. - ! Given the first three vertices of the parallelogram (in 2D or 3D), - ! P1, P2, and P3, the fourth vertex must satisfy - ! P4 = P1 + ( P3 - P2 ) - ! This routine uses the fact that the norm of the cross product - ! of two vectors is the area of the parallelogram they form: - ! Area = ( P3 - P2 ) x ( P1 - P2 ). - ! - ! P4<-----P3 - ! / / - ! / / - ! P1----->P2 - ! - ! Licensing: - ! This code is distributed under the GNU LGPL license. - ! Modified: - ! 09 May 2010 - ! Author: - ! John Burkardt - ! Parameters: - ! Input, real ( kind = 8 ) P(3,4), the parallelogram vertices, - ! given in counterclockwise order. The fourth vertex is ignored. - ! Output, real ( kind = 8 ) AREA, the area - !. . . . . . . . . . . . . . . . . . . - - REAL(DFP), INTENT(IN) :: p(3, 4) - REAL(DFP), INTENT(OUT) :: area - REAL(DFP) :: cross(3) - - ! Compute the cross product vector. - - cross(1) = (p(2, 2) - p(2, 1)) * (p(3, 3) - p(3, 1)) & - - (p(3, 2) - p(3, 1)) * (p(2, 3) - p(2, 1)) - - cross(2) = (p(3, 2) - p(3, 1)) * (p(1, 3) - p(1, 1)) & - - (p(1, 2) - p(1, 1)) * (p(3, 3) - p(3, 1)) - - cross(3) = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & - - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) - - area = SQRT(SUM(cross(1:3)**2)) - -END SUBROUTINE PARALLELOGRAMAREA3D - -!----------------------------------------------------------------------------- -! -!----------------------------------------------------------------------------- - -PURE SUBROUTINE PARALLELOGRAMAREA2D(p, area) - - !. . . . . . . . . . . . . . . . . . . - ! - !! PARALLELOGRAMAREA2D computes the area of a parallelogram in 2D. - ! - ! Discussion: - ! A parallelogram is a polygon having four sides, with the property - ! that each pair of opposite sides is paralell. - ! Given the first three vertices of the parallelogram, - ! P1, P2, and P3, the fourth vertex must satisfy - ! - ! P4 = P1 + ( P3 - P2 ) - ! - ! This routine uses the fact that the norm of the cross product - ! of two vectors is the area of the parallelogram they form: - ! - ! Area = ( P3 - P2 ) x ( P1 - P2 ). - ! - ! P4<-----P3 - ! / / - ! / / - ! P1----->P2 - ! - ! Licensing: - ! This code is distributed under the GNU LGPL license. - ! Modified: - ! 09 May 2010 - ! Author: - ! John Burkardt - ! Parameters: - ! Input, real ( kind = 8 ) P(2,4), the parallelogram vertices, - ! given in counterclockwise order. The fourth vertex is ignored. - ! Output, real ( kind = 8 ) AREA, the (signed) area. - !. . . . . . . . . . . . . . . . . . . - - REAL(DFP), INTENT(IN) :: p(2, 4) - REAL(DFP), INTENT(OUT) :: area - - ! Compute the cross product vector, which only has a single - ! nonzero component. - - area = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & - - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) - -END SUBROUTINE PARALLELOGRAMAREA2D - -!----------------------------------------------------------------------------- -! -!----------------------------------------------------------------------------- - -PURE SUBROUTINE TETRAHEDRONVOLUME3D(tetra, volume) - - !. . . . . . . . . . . . . . . . . . . - ! - !! TETRAHEDRONVOLUME3D computes the volume of a tetrahedron in 3D. - ! - ! Licensing: - ! This code is distributed under the GNU LGPL license. - ! Modified: - ! 30 December 2004 - ! Author: - ! John Burkardt - ! Parameters: - ! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. - ! Output, real ( kind = 8 ) VOLUME, the volume of the tetrahedron. - !. . . . . . . . . . . . . . . . . . . - - REAL(DFP), INTENT(IN) :: tetra(3, 4) - REAL(DFP), INTENT(OUT) :: volume - - INTEGER(I4B), PARAMETER :: dim_num = 3 - REAL(DFP) :: a(4, 4) - - a(1:dim_num, 1:4) = tetra(1:dim_num, 1:4) - a(4, 1:4) = 1.0_DFP - - volume = ABS(R8MATDET4D(a)) / 6.0_DFP - -END SUBROUTINE TETRAHEDRONVOLUME3D - -!----------------------------------------------------------------------------- -! -!----------------------------------------------------------------------------- - -PURE SUBROUTINE POLYHEDRONVOLUME3D(coord, order_max, face_num, node, & - & node_num, order, volume) - - !. . . . . . . . . . . . . . . . . . . - ! - !! POLYHEDRONVOLUME3D computes the volume of a polyhedron in 3D. - ! - ! Licensing: - ! This code is distributed under the GNU LGPL license. - ! Modified: - ! 19 August 2003 - ! Author: - ! John Burkardt - ! Parameters: - ! - ! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of - ! the vertices. The vertices may be listed in any order. - ! - ! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices - ! that make up a face of the polyhedron. - ! - ! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the - ! polyhedron. - ! - ! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is - ! defined by - ! the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices - ! are listed in neighboring order. - ! - ! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in - ! COORD. - ! - ! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices - ! making - ! up each face. - ! - ! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. - !. . . . . . . . . . . . . . . . . . . - - INTEGER(I4B), INTENT(IN) :: order_max - INTEGER(I4B), INTENT(IN) :: face_num - INTEGER(I4B), INTENT(IN) :: node(face_num, order_max) - INTEGER(I4B), INTENT(IN) :: node_num - REAL(DFP), INTENT(IN) :: coord(3, node_num) - INTEGER(I4B), INTENT(IN) :: order(face_num) - REAL(DFP), INTENT(OUT) :: volume - - INTEGER(I4B), PARAMETER :: dim_num = 3 - INTEGER(I4B) :: face - INTEGER(I4B) :: n1 - INTEGER(I4B) :: n2 - INTEGER(I4B) :: n3 - INTEGER(I4B) :: v - volume = 0.0_DFP - - ! Triangulate each face. - DO face = 1, face_num - - n3 = node(face, order(face)) - - DO v = 1, order(face) - 2 - n1 = node(face, v) - n2 = node(face, v + 1) - volume = volume & - + coord(1, n1) & - * (coord(2, n2) * coord(3, n3) - coord(2, n3) * coord(3, n2)) & - + coord(1, n2) & - * (coord(2, n3) * coord(3, n1) - coord(2, n1) * coord(3, n3)) & - + coord(1, n3) & - * (coord(2, n1) * coord(3, n2) - coord(2, n2) * coord(3, n1)) - END DO - END DO - - volume = volume / 6.0_DFP - -END SUBROUTINE POLYHEDRONVOLUME3D diff --git a/src/submodules/Hashing/CMakeLists.txt b/src/submodules/Hashing/CMakeLists.txt deleted file mode 100644 index 450d3aebb..000000000 --- a/src/submodules/Hashing/CMakeLists.txt +++ /dev/null @@ -1,24 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Hashing32@fnvMethods.F90 - ${src_path}/Hashing32@nmMethods.F90 - ${src_path}/Hashing32@waterMethods.F90 -) diff --git a/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 b/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 deleted file mode 100644 index ae673e061..000000000 --- a/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 +++ /dev/null @@ -1,121 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -! -! `FNV_1_HASH` and `FNV_1A_Hash` are translations to Fortran 2008 of the -! `FNV-1` and `FNV-1a` hash functions of Glenn Fowler, Landon Curt Noll, -! and Phong Vo, that has been released into the public domain. Permission -! has been granted, by Landon Curt Noll, for the use of these algorithms -! in the Fortran Standard Library. A description of these functions is -! available at https://en.wikipedia.org/wiki/Fowler–Noll–Vo_hash_function. - -SUBMODULE(Hashing32) fnvMethods -IMPLICIT NONE -INTEGER(INT_HASH), PARAMETER :: OFFSET_BASIS = INT(z'811C9DC5', INT_HASH) -INTEGER(INT_HASH), PARAMETER :: PRIME = INT(z'01000193', INT_HASH) -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int8_fnv_1 - INTEGER(Int64) :: ii - !! - ans = OFFSET_BASIS - !! - DO ii = 1_int64, SIZE(key, kind=int64) - ans = ans * prime - IF (little_endian) THEN - ans = IEOR(ans, & - TRANSFER([key(ii), 0_int8, 0_int8, 0_int8], & - & 0_int_hash)) - ELSE - ans = IEOR(ans, & - TRANSFER([0_int8, 0_int8, 0_int8, key(ii)], & - & 0_int_hash)) - END IF - END DO -END PROCEDURE Int8_fnv_1 - -MODULE PROCEDURE Int16_fnv_1 - ans = Int8_fnv_1(TRANSFER(key, 0_int8, & - & BYTES_INT16 * SIZE(key, kind=Int64))) -END PROCEDURE Int16_fnv_1 - -MODULE PROCEDURE Int32_fnv_1 - ans = Int8_fnv_1(TRANSFER(key, 0_int8, & - & BYTES_INT32 * SIZE(key, kind=Int64))) -END PROCEDURE Int32_fnv_1 - -MODULE PROCEDURE Int64_fnv_1 - ans = Int8_fnv_1(TRANSFER(key, 0_int8, & - & BYTES_INT64 * SIZE(key, kind=Int64))) -END PROCEDURE Int64_fnv_1 - -MODULE PROCEDURE Char_fnv_1 - ans = Int8_fnv_1(TRANSFER(key, 0_int8, & - & BYTES_CHAR * LEN(key, kind=Int64))) -END PROCEDURE Char_fnv_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int8_fnv_1a - INTEGER( Int64 ) :: ii - !! - ans = OFFSET_BASIS - !! - DO ii = 1_Int64, SIZE(key, kind=int64) - IF(little_endian) THEN - ans = IEOR(ans, TRANSFER([key(ii), 0_Int8, 0_Int8, 0_Int8], & - & 0_Int_hash)) - ELSE - ans = IEOR(ans, & - & TRANSFER([0_Int8, 0_Int8, 0_Int8, key(ii)], & - & 0_int_hash)) - END IF - ans = ans * prime - END DO - !! -END PROCEDURE Int8_fnv_1a - -MODULE PROCEDURE Int16_fnv_1a - ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & - & BYTES_INT16 * SIZE(key, kind=Int64))) -END PROCEDURE Int16_fnv_1a - -MODULE PROCEDURE Int32_fnv_1a - ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & - & BYTES_INT32 * SIZE(key, kind=Int64))) -END PROCEDURE Int32_fnv_1a - -MODULE PROCEDURE Int64_fnv_1a - ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & - & BYTES_INT64 * SIZE(key, kind=Int64))) -END PROCEDURE Int64_fnv_1a - -MODULE PROCEDURE Char_fnv_1a - ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & - & BYTES_CHAR * LEN(key, kind=Int64))) -END PROCEDURE Char_fnv_1a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE fnvMethods diff --git a/src/submodules/Hashing/src/Hashing32@nmMethods.F90 b/src/submodules/Hashing/src/Hashing32@nmMethods.F90 deleted file mode 100644 index b38b41a70..000000000 --- a/src/submodules/Hashing/src/Hashing32@nmMethods.F90 +++ /dev/null @@ -1,903 +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: 25 July 2021 -! summary: -! -!# Introduction -! -! Reference: https://github.com/fortran-lang/stdlib/tree/master/src -! -! `NM_HASH32` and `NM_HASH32X` are translations to Fortran 2008 and signed -! two's complement arithmetic of the `nmhash32` and `nmhash32x` scalar -! algorithms of James Z. M. Gao, copyright 2021. James Z. M. Gao's original -! C++ code, `nmhash.h`, is available at the URL: -! https://github.com/gzm55/hash-garage/blob/ -! a8913138bdb3b7539c202edee30a7f0794bbd835/nmhash.h -! -! under the BSD 2-Clause License: -! -! https://github.com/gzm55/hash-garage/blob/ -! a8913138bdb3b7539c202edee30a7f0794bbd835/LICENSE -! -! The algorithms come in multiple versions, depending on whether the -! vectorized instructions SSE2 or AVX2 are available. As neither instruction -! is available in portable Fortran 2008, the algorithms that do not use these -! instructions are used. -! -! The BSD 2-Clause license is as follows: -! -! BSD 2-Clause License -! -! Copyright (c) 2021, water hash algorithm. James Z.M. Gao -! All rights reserved. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE -! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. - -SUBMODULE(Hashing32) nmMethods -IMPLICIT NONE -! Primes from XXH -INTEGER(INT32), PARAMETER :: nmh_prime32_1 = INT(Z'9E3779B1', INT32) -INTEGER(INT32), PARAMETER :: nmh_prime32_2 = INT(Z'85EBCA77', INT32) -INTEGER(INT32), PARAMETER :: nmh_prime32_3 = INT(Z'C2B2AE3D', INT32) -INTEGER(INT32), PARAMETER :: nmh_prime32_4 = INT(Z'27D4EB2F', INT32) -INTEGER(INT32), PARAMETER :: nmh_m1 = INT(z'F0D9649B', INT32) -INTEGER(INT32), PARAMETER :: nmh_m2 = INT(z'29A7935D', INT32) -INTEGER(INT32), PARAMETER :: nmh_m3 = INT(z'55D35831', INT32) -INTEGER(INT32), PARAMETER :: nmh_m1_v(0:31) = nmh_m1 -INTEGER(INT32), PARAMETER :: nmh_m2_v(0:31) = nmh_m2 -INTEGER(INT32), PARAMETER :: nmh_m3_v(0:31) = nmh_m3 -LOGICAL(LGT), PARAMETER :: nmh_short32_without_seed2 = .FALSE. -LOGICAL(LGT), PARAMETER :: nmh_short32_with_seed2 = .TRUE. -INTEGER(INT32), PARAMETER :: init_size = 32 -! Pseudorandom secrets taken directly from FARSH. -INTEGER(INT32), PARAMETER :: nmh_acc_init(0:init_size - 1) = [ & - & INT(z'B8FE6C39', INT32), INT(z'23A44BBE', INT32), & - & INT(z'7C01812C', INT32), INT(z'F721AD1C', INT32), & - & INT(z'DED46DE9', INT32), INT(z'839097DB', INT32), & - & INT(z'7240A4A4', INT32), INT(z'B7B3671F', INT32), & - & INT(z'CB79E64E', INT32), INT(z'CCC0E578', INT32), & - & INT(z'825AD07D', INT32), INT(z'CCFF7221', INT32), & - & INT(z'B8084674', INT32), INT(z'F743248E', INT32), & - & INT(z'E03590E6', INT32), INT(z'813A264C', INT32), & - & INT(z'3C2852BB', INT32), INT(z'91C300CB', INT32), & - & INT(z'88D0658B', INT32), INT(z'1B532EA3', INT32), & - & INT(z'71644897', INT32), INT(z'A20DF94E', INT32), & - & INT(z'3819EF46', INT32), INT(z'A9DEACD8', INT32), & - & INT(z'A8FA763F', INT32), INT(z'E39C343F', INT32), & - & INT(z'F9DCBBC7', INT32), INT(z'C70B4F1D', INT32), & - & INT(z'8A51E04B', INT32), INT(z'CDB45931', INT32), & - & INT(z'C89F7EC9', INT32), INT(z'D9787364', INT32)] - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int8_nmhash32x -INTEGER(INT64) :: len -INTEGER(INT32) :: seed2 -INTEGER(INT32) :: u32 -INTEGER(INT16) :: u16(0:1) - -len = SIZE(key, kind=INT64) -IF (len <= 8) THEN - IF (len > 4) THEN - ans = nmhash32x_5to8(key, seed) - RETURN - ELSE ! 0 to 4 bytes - SELECT CASE (len) - CASE (0) - seed2 = seed + nmh_prime32_2 - u32 = 0 - CASE (1) - seed2 = seed + nmh_prime32_2 + ISHFT(1_INT32, 24) + & - ISHFT(1_INT32, 1) - IF (little_endian) THEN - u32 = TRANSFER([key(0), 0_INT8, 0_INT8, 0_INT8], & - & 0_INT32) - ELSE - u32 = TRANSFER([0_INT8, 0_INT8, 0_INT8, key(0)], & - & 0_INT32) - END IF - CASE (2) - seed2 = seed + nmh_prime32_2 + ISHFT(2_INT32, 24) + & - ISHFT(2_INT32, 1) - IF (little_endian) THEN - u32 = TRANSFER([nmh_readle16(key), 0_INT16], 0_INT32) - ELSE - u32 = TRANSFER([0_INT16, nmh_readle16(key)], 0_INT32) - END IF - CASE (3) - seed2 = seed + nmh_prime32_2 + ISHFT(3_INT32, 24) + & - ISHFT(3_INT32, 1) - IF (little_endian) THEN - u16(1) = TRANSFER([key(2), 0_INT8], 0_INT16) - u16(0) = nmh_readle16(key) - ELSE - u16(0) = TRANSFER([0_INT8, key(2)], 0_INT16) - u16(1) = nmh_readle16(key) - END IF - u32 = TRANSFER(u16, 0_INT32) - CASE (4) - seed2 = seed + nmh_prime32_1 - u32 = nmh_readle32(key) - CASE default - ans = 0 - RETURN - END SELECT - ans = nmhash32x_0to4(u32, seed2) - RETURN - END IF -END IF -IF (len < 256) THEN - ans = nmhash32x_9to255(key, seed) - RETURN -END IF -ans = nmhash32x_avalanche32(nmhash32_long(key, seed)) -END PROCEDURE Int8_nmhash32x - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int8_nmhash32 - !! NMHASH32 ans function for rank 1 array keys of kind INT8 -INTEGER(INT64) :: len -INTEGER(INT32) :: u32 -INTEGER(INT16) :: u16(0:1) -INTEGER(INT32) :: x, y -INTEGER(INT32) :: new_seed - !! -len = SIZE(key, kind=INT64) -IF (len <= 32) THEN - IF (len > 8) THEN - ans = nmhash32_9to32(key, seed) - RETURN - ELSE IF (len > 4) THEN - x = nmh_readle32(key) - y = IEOR(nmh_readle32(key(len - 4:)), nmh_prime32_4 + 2 + seed) - x = x + y - x = IEOR(x, ISHFT(x, len + 7)) - ans = nmhash32_0to8(x, ISHFTC(y, 5)) - RETURN - ELSE - SELECT CASE (len) - CASE (0) - new_seed = seed + nmh_prime32_2 - u32 = 0 - CASE (1) - new_seed = seed + nmh_prime32_2 + ISHFT(1_INT32, 24) + & - 2_INT32 - IF (little_endian) THEN - u32 = TRANSFER([key(0), 0_INT8, 0_INT8, 0_INT8], & - 0_INT32) - ELSE - u32 = TRANSFER([0_INT8, 0_INT8, 0_INT8, key(0)], & - 0_INT32) - END IF - CASE (2) - new_seed = seed + nmh_prime32_2 + ISHFT(2_INT32, 24) + & - 4_INT32 - IF (little_endian) THEN - u32 = TRANSFER([nmh_readle16(key), 0_INT16], 0_INT32) - ELSE - u32 = TRANSFER([0_INT16, nmh_readle16(key)], 0_INT32) - END IF - CASE (3) - new_seed = seed + nmh_prime32_2 + ISHFT(3_INT32, 24) + & - 6_INT32 - IF (little_endian) THEN - u16(1) = TRANSFER([key(2), 0_INT8], 0_INT16) - u16(0) = nmh_readle16(key) - ELSE - u16(0) = TRANSFER([0_INT8, key(2)], 0_INT16) - u16(1) = nmh_readle16(key) - END IF - u32 = TRANSFER(u16, 0_INT32) - CASE (4) - new_seed = seed + nmh_prime32_3 - u32 = nmh_readle32(key) - CASE default - ans = 0 - RETURN - END SELECT - ans = nmhash32_0to8(u32 + new_seed, ISHFTC(new_seed, 5)) - RETURN - END IF -ELSE IF (len < 256_INT64) THEN - ans = nmhash32_33to255(key, seed) - RETURN -ELSE - ans = nmhash32_avalanche32(nmhash32_long(key, seed)) - RETURN -END IF - !! -END PROCEDURE Int8_nmhash32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int16_nmhash32 -!! NMHASH32 hash function for rank 1 array keys of kind Int16 -ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & - & bytes_Int16 * SIZE(key, kind=INT64)), seed) -END PROCEDURE Int16_nmhash32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int32_nmhash32 -ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & - & bytes_Int32 * SIZE(key, kind=INT64)), seed) -END PROCEDURE Int32_nmhash32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int64_nmhash32 -ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & - & bytes_Int64 * SIZE(key, kind=INT64)), seed) -END PROCEDURE Int64_nmhash32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Char_nmhash32 -ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & - & bytes_char * LEN(key, kind=INT64)), seed) -END PROCEDURE Char_nmhash32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int16_nmhash32x -ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & - & bytes_Int16 * SIZE(key, kind=INT64)), seed) -END PROCEDURE Int16_nmhash32x - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int32_nmhash32x -ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & - & bytes_Int32 * SIZE(key, kind=INT64)), seed) -END PROCEDURE Int32_nmhash32x - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int64_nmhash32x -ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & - & bytes_Int64 * SIZE(key, kind=INT64)), seed) -END PROCEDURE Int64_nmhash32x - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Char_nmhash32x -ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & - & bytes_char * LEN(key, kind=INT64)), seed) -END PROCEDURE Char_nmhash32x - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE new_nmhash32_seed -! Random SEED generator for NMHASH32 -INTEGER(INT32) :: old_seed -REAL(dp) :: sample -old_seed = seed -find_seed: DO - CALL RANDOM_NUMBER(sample) - seed = INT(FLOOR(sample * 2_INT64**32, INT64) - 2_INT64**31, & - INT32) - IF (seed /= old_seed) RETURN -END DO find_seed -END PROCEDURE new_nmhash32_seed - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE new_nmhash32x_seed -INTEGER(INT32) :: old_seed -REAL(dp) :: sample - -old_seed = seed -find_seed: DO - CALL RANDOM_NUMBER(sample) - seed = INT(FLOOR(sample * 2_INT64**32, INT64) - 2_INT64**31, & - INT32) - IF (seed /= old_seed) RETURN -END DO find_seed -END PROCEDURE new_nmhash32x_seed - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmh_readle32(p) RESULT(v) - INTEGER(INT32) :: v - INTEGER(INT8), INTENT(in) :: p(:) - - IF (little_endian) THEN - v = TRANSFER(p(1:4), 0_INT32) - ELSE - v = TRANSFER([p(4), p(3), p(2), p(1)], 0_INT32) - END IF - -END FUNCTION nmh_readle32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmh_readle16(p) RESULT(v) - INTEGER(INT16) :: v - INTEGER(INT8), INTENT(in) :: p(:) - - IF (little_endian) THEN - v = TRANSFER(p(1:2), 0_INT16) - ELSE - v = TRANSFER([p(2), p(1)], 0_INT16) - END IF - -END FUNCTION nmh_readle16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32_0to8(x, seed) RESULT(vx32) - INTEGER(INT32), INTENT(in) :: x - INTEGER(INT32), INTENT(in) :: seed - INTEGER(INT32) :: vx32 - ! base mixer: [-6 -12 776bf593 -19 11 3fb39c65 -15 -9 e9139917 -11 16] - ! = 0.027071104091278835 - INTEGER(INT32), PARAMETER :: m1 = INT(z'776BF593', INT32) - INTEGER(INT32), PARAMETER :: m2 = INT(z'3FB39C65', INT32) - INTEGER(INT32), PARAMETER :: m3 = INT(z'E9139917', INT32) - - INTEGER(INT16) :: vx16(2) - - vx32 = x - vx32 = IEOR(vx32, IEOR(ISHFT(vx32, -12), ISHFT(vx32, -6))) - vx16 = TRANSFER(vx32, 0_INT16, 2) - vx16 = vx16 * TRANSFER(m1, 0_INT16, 2) - vx32 = TRANSFER(vx16, 0_INT32) - vx32 = IEOR(vx32, IEOR(ISHFT(vx32, 11), ISHFT(vx32, -19))) - vx16 = TRANSFER(vx32, 0_INT16, 2) - vx16 = vx16 * TRANSFER(m2, 0_INT16, 2) - vx32 = TRANSFER(vx16, 0_INT32) - vx32 = IEOR(vx32, seed) - vx32 = IEOR(vx32, IEOR(ISHFT(vx32, -15), ISHFT(vx32, -9))) - vx16 = TRANSFER(vx32, 0_INT16, 2) - vx16 = vx16 * TRANSFER(m3, 0_INT16, 2) - vx32 = TRANSFER(vx16, 0_INT32) - vx32 = IEOR(vx32, IEOR(ISHFT(vx32, 16), ISHFT(vx32, -11))) - -END FUNCTION nmhash32_0to8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32_9to255(p, seed, full_avalanche) RESULT(RESULT) - INTEGER(INT8), INTENT(in) :: p(0:) - INTEGER(INT32), INTENT(in) :: seed - LOGICAL, INTENT(in) :: full_avalanche - INTEGER(INT32) :: RESULT - - INTEGER(INT32) :: xu32(0:3), yu32(0:3) - INTEGER(INT16) :: xu16(0:1) - ! Due to an issue with Intel OneAPI ifort 2021 (see - ! https://community.intel.com/t5/Intel-Fortran-Compiler/ - ! Intrinsic-transfer-with-a-provided-size-un-expected-behavior/m-p/ - ! 1343313#M158733 - ! ), it is not possible to define the following variables as a - ! PARAMETER. - ! INTEGER(int16), PARAMETER :: & - ! nmh_m1_16(0:1) = transfer( nmh_m1, 0_int16, 2 ), & - ! nmh_m2_16(0:1) = transfer( nmh_m2, 0_int16, 2 ), & - ! nmh_m3_16(0:1) = transfer( nmh_m3, 0_int16, 2 ) - INTEGER(INT16) :: nmh_m1_16(0:1), nmh_m2_16(0:1), nmh_m3_16(0:1) - INTEGER(INT32) :: s1 - INTEGER(INT64) :: length - INTEGER(INT32) :: length32(0:1) - INTEGER(INT64) :: i, j, r - - nmh_m1_16(0:1) = TRANSFER(nmh_m1, 0_INT16, 2) - nmh_m2_16(0:1) = TRANSFER(nmh_m2, 0_INT16, 2) - nmh_m3_16(0:1) = TRANSFER(nmh_m3, 0_INT16, 2) - - ! base mixer: [f0d9649b 5 -13 29a7935d -9 11 55d35831 -20 -10 ] = - ! 0.93495901789135362 - - RESULT = 0 - length = SIZE(p, kind=INT64) - length32 = TRANSFER(length, 0_INT32, 2) - IF (little_endian) THEN - s1 = seed + length32(0) - ELSE - s1 = seed + length32(1) - END IF - xu32(0) = nmh_prime32_1 - xu32(1) = nmh_prime32_2 - xu32(2) = nmh_prime32_3 - xu32(3) = nmh_prime32_4 - yu32(:) = s1 - - IF (full_avalanche) THEN - ! 33 to 255 bytes - r = (length - 1) / 32 - DO i = 0, r - 1 - DO j = 0, 3 - xu32(j) = IEOR(xu32(j), nmh_readle32(p(i * 32 + j * 4:))) - yu32(j) = IEOR(yu32(j), & - nmh_readle32(p(i * 32 + j * 4 + 16:))) - xu32(j) = xu32(j) + yu32(j) - xu16 = TRANSFER(xu32(j), 0_INT16, 2) - xu16 = xu16 * nmh_m1_16 - xu32(j) = TRANSFER(xu16, 0_INT32) - xu32(j) = IEOR(xu32(j), & - IEOR(ISHFT(xu32(j), 5), & - ISHFT(xu32(j), -13))) - xu16 = TRANSFER(xu32(j), 0_INT16, 2) - xu16 = xu16 * nmh_m2_16 - xu32(j) = TRANSFER(xu16, 0_INT32) - xu32(j) = IEOR(xu32(j), yu32(j)) - xu32(j) = IEOR(xu32(j), & - IEOR(ISHFT(xu32(j), 11), & - ISHFT(xu32(j), -9))) - xu16 = TRANSFER(xu32(j), 0_INT16, 2) - xu16 = xu16 * nmh_m3_16 - xu32(j) = TRANSFER(xu16, 0_INT32) - xu32(j) = IEOR(xu32(j), & - IEOR(ISHFT(xu32(j), -10), & - ISHFT(xu32(j), -20))) - END DO - END DO - DO j = 0, 3 - xu32(j) = IEOR(xu32(j), & - nmh_readle32(p(length - 32 + j * 4:))) - yu32(j) = IEOR(yu32(j), & - nmh_readle32(p(length - 16 + j * 4:))) - END DO - ELSE - ! 9 to 32 bytes - xu32(0) = IEOR(xu32(0), nmh_readle32(p(0:))) - xu32(1) = IEOR(xu32(1), nmh_readle32(p(ISHFT(ISHFT(length, -4), 3):))) - xu32(2) = IEOR(xu32(2), nmh_readle32(p(length - 8:))) - xu32(3) = IEOR(xu32(3), & - nmh_readle32(p(length - 8 - ISHFT(ISHFT(length, -4), 3):))) - yu32(0) = IEOR(yu32(0), nmh_readle32(p(4:))) - yu32(1) = IEOR(yu32(1), & - nmh_readle32(p(ISHFT(ISHFT(length, -4), 3) + 4:))) - yu32(2) = IEOR(yu32(2), nmh_readle32(p(length - 8 + 4:))) - yu32(3) = IEOR(yu32(3), & - nmh_readle32(p(length - 8 - & - ISHFT(ISHFT(length, -4), 3) + 4:))) - END IF - DO j = 0, 3 - xu32(j) = xu32(j) + yu32(j) - yu32(j) = IEOR(yu32(j), IEOR(ISHFT(yu32(j), 17), & - ISHFT(yu32(j), -6))) - xu16 = TRANSFER(xu32(j), 0_INT16, 2) - xu16 = xu16 * nmh_m1_16 - xu32(j) = TRANSFER(xu16, 0_INT32) - xu32(j) = IEOR(xu32(j), IEOR(ISHFT(xu32(j), 5), & - ISHFT(xu32(j), -13))) - xu16 = TRANSFER(xu32(j), 0_INT16, 2) - xu16 = xu16 * nmh_m2_16 - xu32(j) = TRANSFER(xu16, 0_INT32) - xu32(j) = IEOR(xu32(j), yu32(j)) - xu32(j) = IEOR(xu32(j), IEOR(ISHFT(xu32(j), 11), & - ISHFT(xu32(j), -9))) - xu16 = TRANSFER(xu32(j), 0_INT16, 2) - xu16 = xu16 * nmh_m3_16 - xu32(j) = TRANSFER(xu16, 0_INT32) - xu32(j) = IEOR(xu32(j), IEOR(ISHFT(xu32(j), -10), & - ISHFT(xu32(j), -20))) - END DO - xu32(0) = IEOR(xu32(0), nmh_prime32_1) - xu32(1) = IEOR(xu32(1), nmh_prime32_2) - xu32(2) = IEOR(xu32(2), nmh_prime32_3) - xu32(3) = IEOR(xu32(3), nmh_prime32_4) - DO j = 1, 3 - xu32(0) = xu32(0) + xu32(j) - END DO - xu32(0) = IEOR(xu32(0), s1 + ISHFT(s1, -5)) - xu16 = TRANSFER(xu32(0), 0_INT16, 2) - xu16 = xu16 * nmh_m3_16 - xu32(0) = TRANSFER(xu16, 0_INT32) - xu32(0) = IEOR(xu32(0), & - IEOR(ISHFT(xu32(0), -10), ISHFT(xu32(0), -20))) - RESULT = xu32(0) - -END FUNCTION nmhash32_9to255 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32_9to32(p, seed) RESULT(ans) - INTEGER(INT8), INTENT(in) :: p(0:) - INTEGER(INT32), INTENT(in) :: seed - INTEGER(INT32) :: ans - ans = nmhash32_9to255(p, seed, .FALSE.) -END FUNCTION nmhash32_9to32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32_33to255(p, seed) RESULT(ans) - INTEGER(INT8), INTENT(in) :: p(0:) - INTEGER(INT32), INTENT(in) :: seed - INTEGER(INT32) :: ans - ans = nmhash32_9to255(p, seed, .TRUE.) -END FUNCTION nmhash32_33to255 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE nmhash32_long_round(accx, accy, p) - INTEGER(INT32), INTENT(inout) :: accx(0:) - INTEGER(INT32), INTENT(inout) :: accy(0:) - INTEGER(INT8), INTENT(in) :: p(0:) - - INTEGER(INT64), PARAMETER :: nbgroups = init_size - INTEGER(INT64) :: i - INTEGER(INT16) :: dummy1(0:1) - INTEGER(INT16) :: dummy2(0:1) - - DO i = 0, nbgroups - 1 - accx(i) = IEOR(accx(i), nmh_readle32(p(i * 4:))) - accy(i) = IEOR(accy(i), nmh_readle32(p(i * 4 + nbgroups * 4:))) - accx(i) = accx(i) + accy(i) - accy(i) = IEOR(accy(i), ISHFT(accx(i), -1)) - dummy1 = TRANSFER(accx(i), 0_INT16, 2) - dummy2 = TRANSFER(nmh_m1_v(i), 0_INT16, 2) - dummy1 = dummy1 * dummy2 - accx(i) = TRANSFER(dummy1, 0_INT32) - accx(i) = IEOR(accx(i), IEOR(ISHFT(accx(i), 5), & - ISHFT(accx(i), -13))) - dummy1 = TRANSFER(accx(i), 0_INT16, 2) - dummy2 = TRANSFER(nmh_m2_v(i), 0_INT16, 2) - dummy1 = dummy1 * dummy2 - accx(i) = TRANSFER(dummy1, 0_INT32) - accx(i) = IEOR(accx(i), accy(i)) - accx(i) = IEOR(accx(i), IEOR(ISHFT(accx(i), 11), & - ISHFT(accx(i), -9))) - dummy1 = TRANSFER(accx(i), 0_INT16, 2) - dummy2 = TRANSFER(nmh_m3_v(i), 0_INT16, 2) - dummy1 = dummy1 * dummy2 - accx(i) = TRANSFER(dummy1, 0_INT32) - accx(i) = IEOR(accx(i), IEOR(ISHFT(accx(i), -10), & - ISHFT(accx(i), -20))) - END DO - -END SUBROUTINE nmhash32_long_round - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32_long(p, seed) RESULT(sum) - INTEGER(INT32) :: sum - INTEGER(INT8), INTENT(in) :: p(0:) - INTEGER(INT32), INTENT(in) :: seed - !! - INTEGER(INT32) :: accx(0:SIZE(nmh_acc_init) - 1) - INTEGER(INT32) :: accy(0:SIZE(nmh_acc_init) - 1) - INTEGER(INT64) :: nbrounds - INTEGER(INT64) :: len - INTEGER(INT32) :: len32(0:1) - INTEGER(INT64) :: i - !! - len = SIZE(p, kind=INT64) - nbrounds = (len - 1) / (4 * SIZE(accx, kind=INT64) * 2) - sum = 0 - !! - ! Init - DO i = 0_INT64, SIZE(nmh_acc_init, kind=INT64) - 1 - accx(i) = nmh_acc_init(i) - accy(i) = seed - END DO - !! - ! init - DO i = 0_INT64, nbrounds - 1 - CALL nmhash32_long_round(accx, accy, & - & p(i * 8 * SIZE(accx, kind=INT64):)) - END DO - CALL nmhash32_long_round(accx, accy, & - & p(len - 8 * SIZE(accx, kind=INT64):)) - !! - ! merge acc - DO i = 0, SIZE(accx, kind=INT64) - 1 - accx(i) = IEOR(accx(i), nmh_acc_init(i)) - sum = sum + accx(i) - END DO - !! - len32 = TRANSFER(len, 0_INT32, 2) - IF (little_endian) THEN - sum = sum + len32(1) - sum = IEOR(sum, len32(0)) - ELSE - sum = sum + len32(0) - sum = IEOR(sum, len32(1)) - END IF - !! -END FUNCTION nmhash32_long - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32_avalanche32(x) RESULT(u32) - INTEGER(INT32) :: u32 - INTEGER(INT32), INTENT(in) :: x - !! - INTEGER(INT16) :: u16(0:1) - INTEGER(INT32), PARAMETER :: m1 = INT(z'CCE5196D', INT32) - INTEGER(INT32), PARAMETER :: m2 = INT(z'464BE229', INT32) - ! Due to an issue with Intel OneAPI ifort 2021 (see - ! https://community.intel.com/t5/Intel-Fortran-Compiler/ - ! Intrinsic-transfer-with-a-provided-size-un-expected-behavior/m-p/ - ! 1343313#M158733 - ! ), it is not possible to define the following variables as a PARAMETER. - !INTEGER(int16), PARAMETER:: m1_16(0:1) = transfer(m1, 0_int16, 2) - !INTEGER(int16), PARAMETER:: m2_16(0:1) = transfer(m2, 0_int16, 2) - INTEGER(INT16) :: m1_16(0:1), m2_16(0:1) - ! [-21 -8 cce5196d 12 -7 464be229 -21 -8] = 3.2267098842182733 - !! - m1_16(0:1) = TRANSFER(m1, 0_INT16, 2) - m2_16(0:1) = TRANSFER(m2, 0_INT16, 2) - !! - u32 = x - u32 = IEOR(u32, IEOR(ISHFT(u32, -8), ISHFT(u32, -21))) - u16 = TRANSFER(u32, 0_INT16, 2) - u16(0) = u16(0) * m1_16(0) - u16(1) = u16(1) * m1_16(1) - u32 = TRANSFER(u16, 0_INT32) - u32 = IEOR(u32, IEOR(ISHFT(u32, 12), ISHFT(u32, -7))) - u16 = TRANSFER(u32, 0_INT16, 2) - u16(0) = u16(0) * m2_16(0) - u16(1) = u16(1) * m2_16(1) - u32 = TRANSFER(u16, 0_INT32) - u32 = IEOR(u32, IEOR(ISHFT(u32, -8), ISHFT(u32, -21))) - !! -END FUNCTION nmhash32_avalanche32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32x_0to4(x, seed) RESULT(hash) - INTEGER(INT32), INTENT(in) :: x - INTEGER(INT32), INTENT(in) :: seed - INTEGER(INT32) :: hash - !! - !! [bdab1ea9 18 a7896a1b 12 83796a2d 16] = 0.092922873297662509 - !! - hash = x - hash = IEOR(hash, seed) - hash = hash * INT(z'BDAB1EA9', INT32) - hash = hash + ISHFTC(seed, 31) - hash = IEOR(hash, ISHFT(hash, -18)) - hash = hash * INT(z'A7896A1B', INT32) - hash = IEOR(hash, ISHFT(hash, -12)) - hash = hash * INT(z'83796A2D', INT32) - hash = IEOR(hash, ISHFT(hash, -16)) - !! -END FUNCTION nmhash32x_0to4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32x_5to8(p, seed) RESULT(x) - INTEGER(INT8), INTENT(in) :: p(0:) - INTEGER(INT32), INTENT(in) :: seed - INTEGER(INT32) :: x - !! - !! internal variables - !! - INTEGER(INT64) :: len - INTEGER(INT32) :: y - ! - ! 5 to 9 bytes - ! mixer: [11049a7d 23 bcccdc7b 12 065e9dad 12] = 0.16577596555667246 - ! - len = SIZE(p, kind=INT64) - x = IEOR(nmh_readle32(p), nmh_prime32_3) - y = IEOR(nmh_readle32(p(len - 4:)), seed) - x = x + y - x = IEOR(x, ISHFT(x, -len)) - x = x * INT(z'11049A7D', INT32) - x = IEOR(x, ISHFT(x, -23)) - x = x * INT(z'BCCCDC7B', INT32) - x = IEOR(x, ISHFTC(y, 3)) - x = IEOR(x, ISHFT(x, -12)) - x = x * INT(z'065E9DAD', INT32) - x = IEOR(x, ISHFT(x, -12)) -END FUNCTION nmhash32x_5to8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32x_9to255(p, seed) RESULT(x) - INTEGER(INT8), INTENT(in) :: p(0:) - INTEGER(INT32), INTENT(in) :: seed - INTEGER(INT32) :: x - !! - !! internal variables - !! - INTEGER(INT64) :: len - INTEGER(INT32) :: len32(0:1), len_base - INTEGER(INT32) :: y - INTEGER(INT32) :: a, b - INTEGER(INT64) :: i, r - !! - ! - at least 9 bytes - ! - base mixer: [11049a7d 23 bcccdc7b 12 065e9dad 12] = 0.16577596555667246 - ! - tail mixer: [16 a52fb2cd 15 551e4d49 16] = 0.17162579707098322 - !! - len = SIZE(p, kind=INT64) - len32 = TRANSFER(len, 0_INT32, 2) - IF (little_endian) THEN - len_base = len32(0) - ELSE - len_base = len32(1) - END IF - x = nmh_prime32_3 - y = seed - a = nmh_prime32_4 - b = seed - r = (len - 1) / 16 - !! - DO i = 0, r - 1 - x = IEOR(x, nmh_readle32(p(i * 16 + 0:))) - y = IEOR(y, nmh_readle32(p(i * 16 + 4:))) - x = IEOR(x, y) - x = x * INT(z'11049A7D', INT32) - x = IEOR(x, ISHFT(x, -23)) - x = x * INT(z'BCCCDC7B', INT32) - y = ISHFTC(y, 4) - x = IEOR(x, y) - x = IEOR(x, ISHFT(x, -12)) - x = x * INT(z'065E9DAD', INT32) - x = IEOR(x, ISHFT(x, -12)) - - a = IEOR(a, nmh_readle32(p(i * 16 + 8:))) - b = IEOR(b, nmh_readle32(p(i * 16 + 12:))) - a = IEOR(a, b) - a = a * INT(z'11049A7D', INT32) - a = IEOR(a, ISHFT(a, -23)) - a = a * INT(z'BCCCDC7B', INT32) - b = ISHFTC(b, 3) - a = IEOR(a, b) - a = IEOR(a, ISHFT(a, -12)) - a = a * INT(z'065E9DAD', INT32) - a = IEOR(a, ISHFT(a, -12)) - END DO - !! - IF (IAND(len_base - 1_INT32, 8_INT32) /= 0) THEN - IF (IAND(len_base - 1_INT32, 4_INT32) /= 0) THEN - a = IEOR(a, nmh_readle32(p(r * 16 + 0:))) - b = IEOR(b, nmh_readle32(p(r * 16 + 4:))) - a = IEOR(a, b) - a = a * INT(z'11049A7D', INT32) - a = IEOR(a, ISHFT(a, -23)) - a = a * INT(z'BCCCDC7B', INT32) - a = IEOR(a, ISHFTC(b, 4)) - a = IEOR(a, ISHFT(a, -12)) - a = a * INT(z'065E9DAD', INT32) - ELSE - a = IEOR(a, nmh_readle32(p(r * 16:)) + b) - a = IEOR(a, ISHFT(a, -16)) - a = a * INT(z'A52FB2CD', INT32) - a = IEOR(a, ISHFT(a, -15)) - a = a * INT(z'551E4D49', INT32) - END IF - x = IEOR(x, nmh_readle32(p(len - 8:))) - y = IEOR(y, nmh_readle32(p(len - 4:))) - x = IEOR(x, y) - x = x * INT(z'11049A7D', INT32) - x = IEOR(x, ISHFT(x, -23)) - x = x * INT(z'BCCCDC7B', INT32); - x = IEOR(x, ISHFTC(y, 3)) - x = IEOR(x, ISHFT(x, -12)) - x = x * INT(z'065E9DAD', INT32) - ELSE - IF (IAND(len_base - 1_INT32, 4_INT32) /= 0) THEN - a = IEOR(a, nmh_readle32(p(r * 16:)) + b) - a = IEOR(a, ISHFT(a, -16)) - a = a * INT(z'A52FB2CD', INT32) - a = IEOR(a, ISHFT(a, -15)) - a = a * INT(z'551E4D49', INT32) - END IF - x = IEOR(x, nmh_readle32(p(len - 4:)) + y) - x = IEOR(x, ISHFT(x, -16)) - x = x * INT(z'A52FB2CD', INT32) - x = IEOR(x, ISHFT(x, -15)) - x = x * INT(z'551E4D49', INT32) - END IF - !! - x = IEOR(x, len_base) - x = IEOR(x, ISHFTC(a, 27)) ! rotate one lane to pass Diff test - x = IEOR(x, ISHFT(x, -14)) - x = x * INT(z'141CC535', INT32) - !! -END FUNCTION nmhash32x_9to255 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION nmhash32x_avalanche32(x) RESULT(hash) - INTEGER(INT32) :: hash - INTEGER(INT32), INTENT(in) :: x - ! Mixer with 2 mul from skeeto/hash-prospector: - ! [15 d168aaad 15 af723597 15] = 0.15983776156606694 - hash = x - hash = IEOR(hash, ISHFT(hash, -15)) - hash = hash * INT(z'D168AAAD', INT32) - hash = IEOR(hash, ISHFT(hash, -15)) - hash = hash * INT(z'AF723597', INT32) - hash = IEOR(hash, ISHFT(hash, -15)) -END FUNCTION nmhash32x_avalanche32 - -END SUBMODULE nmMethods diff --git a/src/submodules/Hashing/src/Hashing32@waterMethods.F90 b/src/submodules/Hashing/src/Hashing32@waterMethods.F90 deleted file mode 100644 index d4a0e383d..000000000 --- a/src/submodules/Hashing/src/Hashing32@waterMethods.F90 +++ /dev/null @@ -1,313 +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: 25 July 2021 -! summary: -! -!# Introduction -! -! `WATER_HASH` is a translation to Fortran 2008 of the `waterhash` algorithm -! of Tommy Ettinger. Tommy Ettinger's original C++ code, `waterhash.h`, is -! available at the URL: https://github.com/tommyettinger/waterhash under the -! `unlicense`, https://github.com/tommyettinger/waterhash/blob/master/LICENSE. -! "`waterhash` is a variant on Wang Yi's `wyhash`, with 32 bit output, -! using at most 64 bit arithmetic. `wyhash` is available at the URL: -! `https://github.com/wangyi-fudan/wyhash` also under the unlicense: -! `https://github.com/wangyi-fudan/wyhash/blob/master/LICENSE`. -! Original Author: Wang Yi -! Waterhash Variant Author: Tommy Ettinger -! -! The `unlicense` reads as follows: -! This is free and unencumbered software released into the public domain. -! -! Anyone is free to copy, modify, publish, use, compile, sell, or -! distribute this software, either in source code form or as a compiled -! binary, for any purpose, commercial or non-commercial, and by any -! means. -! -! In jurisdictions that recognize copyright laws, the author or authors -! of this software dedicate any and all copyright interest in the -! software to the public domain. We make this dedication for the benefit -! of the public at large and to the detriment of our heirs and -! successors. We intend this dedication to be an overt act of -! relinquishment in perpetuity of all present and future rights to this -! software under copyright law. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -! IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR -! OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, -! ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR -! OTHER DEALINGS IN THE SOFTWARE. -! -! For more information, please refer to -! -! `WATER_HASH` is distributed as part of the `stdlib_32_bit_hash_functions. -! f90` -! module and its `stdlib_hash_32bit_water.f90` submodule with the Fortran -! Standard Library at URL: https://github.com/fortran-lang/stdlib. -! The Fortran Standard Library, including this code, is distributed under the -! MIT License as described in the `LICENSE` file distributed with the library. -! `WATER_HASH` differs from `waterhash.h` not only in its use of Fortran, -! but also in its use of signed two's complement arithmetic in contrast to -! the unsigned arithmetic of Ettinger and Wang Yi, and in making some of the -! uses of `TRANSFER` endian dependent, in an attempt to make the quality of -! the hash endian independent. The use of signed arithmetic may change with -! the planned introduction of the unsigned BITS datatype in what is currently -! known as Fortran 202X. -! -! To be useful this code must be processed by a processor that implements two -! Fortran 2008 extensions to Fortran 2003: submodules, and 64 bit (`INT64`) -! integers. The processor must also use two's complement integers -! (all Fortran 95+ processors use two's complement arithmetic) with -! wrap around overflow at runtime and for BOZ constants. The latest releases -! of the following processors are known to implement the required Fortran -! 2008 extensions and default to runtime wrap around overflow: FLANG, -! gfortran, ifort, and NAG Fortran. Older versions of gfortran will require -! the compiler flag, `-fno-range-check`, to ensure wrap around semantics -! for BOZ constants, and only versions of the NAG compiler starting with -! version 17, have implemented submodules. The latest releases of Cray -! Fortran and IBM Fortran are known to implement the Fortran 2008 extensions, -! but whether they also implement wrap around overflow is unknown. -! -! This implementation has only been tested on little endian processors. It -! will generate different hashes on big endian processors, but they are -! believed to be of comparable quality to those generated for little endian -! processors. -! -! No version of this hash is suitable as a cryptographic hash. - -SUBMODULE(Hashing32) waterMethods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int8_water_hash - INTEGER(int32) :: dummy(2) - INTEGER(int64) :: h - INTEGER(int64) :: i - INTEGER(int64) :: len - INTEGER(int64), parameter :: & - !! - waterp0 = int(z'a0761d65', kind=int64), & - waterp1 = int(z'e7037ed1', kind=int64), & - waterp2 = int(z'8ebc6af1', kind=int64), & - waterp3 = int(z'589965cd', kind=int64), & - waterp4 = int(z'1d8e4e27', kind=int64), & - waterp5 = int(z'eb44accb', kind=int64) - - len = size(key, kind=int64) - h = seed - do i = 0_int64, len - 16, 16 - h = watermum(watermum(ieor(waterr32(key(i:)), waterp1), & - ieor(waterr32(key(i + 4:)), waterp2)) + h, & - watermum(ieor(waterr32(key(i + 8:)), waterp3), & - ieor(waterr32(key(i + 12:)), waterp4))) - end do - h = h + waterp5 - - select case (iand(len, 15_int64)) - case (1) - h = watermum(ieor(waterp2, h), & - ieor(waterr08(key(i:)), waterp1)) - case (2) - h = watermum(ieor(waterp3, h), & - ieor(waterr16(key(i:)), waterp4)) - case (3) - h = watermum(ieor(waterr16(key(i:)), h), & - ieor(waterr08(key(i + 2:)), waterp2)) - case (4) - h = watermum(ieor(waterr16(key(i:)), h), & - ieor(waterr16(key(i + 2:)), waterp3)) - case (5) - h = watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr08(key(i + 4:)), waterp1)) - case (6) - h = watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr16(key(i + 4:)), waterp1)) - case (7) - h = watermum(ieor(waterr32(key(i:)), h), & - ieor(ior(ishft(waterr16(key(i + 4:)), 8), & - waterr08(key(i + 6:))), waterp1)) - case (8) - h = watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp0)) - case (9) - h = ieor(watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp2)), & - watermum(ieor(h, waterp4), & - ieor(waterr08(key(i + 8:)), waterp3))) - case (10) - h = ieor(watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp2)), & - watermum(h, ieor(waterr16(key(i + 8:)), waterp3))) - case (11) - h = ieor(watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp2)), & - watermum(h, & - ieor(ior(ishft(waterr16(key(i + 8:)), 8), & - waterr08(key(i + 10:))), & - waterp3))) - case (12) - h = ieor(watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp2)), & - watermum(ieor(h, waterr32(key(i + 8:))), & - waterp4)) - case (13) - h = ieor(watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp2)), & - watermum(ieor(h, waterr32(key(i + 8:))), & - ieor(waterr08(key(i + 12:)), waterp4))) - case (14) - h = ieor(watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp2)), & - watermum(ieor(h, waterr32(key(i + 8:))), & - ieor(waterr16(key(i + 12:)), waterp4))) - case (15) - h = ieor(watermum(ieor(waterr32(key(i:)), h), & - ieor(waterr32(key(i + 4:)), waterp2)), & - watermum(ieor(h, waterr32(key(i + 8:))), & - ieor(ior(ishft(waterr16(key(i + 12:)), 8), & - waterr08(key(i + 14:))), & - waterp4))) - end select - - h = ieor(h, ishft(h, 16)) * ieor(len, waterp0) - h = h - ishft(h, -32) - dummy(1:2) = transfer(h, dummy, 2) - if (little_endian) then - ans = dummy(1) - else - ans = dummy(2) - end if - !! - contains - !! - pure function watermum(a, b) result(r) - INTEGER(int64) :: r - INTEGER(int64), intent(in) :: a, b - r = a * b - r = r - ishft(r, -32) - end function watermum - !! - pure function waterr08(p) result(v) - INTEGER(int64) :: v - INTEGER(int8), intent(in) :: p(:) - if (little_endian) then - v = transfer([p(1), 0_int8, 0_int8, 0_int8, & - 0_int8, 0_int8, 0_int8, 0_int8], v) - else - v = transfer([0_int8, 0_int8, 0_int8, 0_int8, & - 0_int8, 0_int8, 0_int8, p(1)], v) - end if - end function waterr08 - !! - pure function waterr16(p) result(v) - INTEGER(int64) :: v - INTEGER(int8), intent(in) :: p(:) - !! - if (little_endian) then - v = transfer([p(1), p(2), 0_int8, 0_int8, & - 0_int8, 0_int8, 0_int8, 0_int8], v) - else - v = transfer([0_int8, 0_int8, 0_int8, 0_int8, & - 0_int8, 0_int8, p(2), p(1)], v) - end if - !! - end function waterr16 - !! - pure function waterr32(p) result(v) - INTEGER(int64) :: v - INTEGER(int8), intent(in) :: p(:) - !! - if (little_endian) then - v = transfer([p(1), p(2), p(3), p(4), & - 0_int8, 0_int8, 0_int8, 0_int8], v) - else - v = transfer([0_int8, 0_int8, 0_int8, 0_int8, & - p(4), p(3), p(2), p(1)], v) - end if - !! - end function waterr32 - !! -END PROCEDURE Int8_water_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE int16_water_hash - ans = int8_water_hash(transfer(key, 0_int8, & - & bytes_int16 * size(key, kind=int64)), seed) -END PROCEDURE int16_water_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE int32_water_hash - ans = int8_water_hash(transfer(key, 0_int8, & - & bytes_int32 * size(key, kind=int64)), seed) -END PROCEDURE int32_water_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE int64_water_hash - ans = int8_water_hash(transfer(key, 0_int8, & - & bytes_int64 * size(key, kind=int64)), seed) -END PROCEDURE int64_water_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Char_water_hash - ans = int8_water_hash(transfer(key, 0_int8, & - & bytes_char * len(key, kind=int64)), seed) -END PROCEDURE Char_water_hash - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE new_water_hash_seed - !! - integer(int64) :: old_seed - real(dp) :: sample(2) - integer(int32) :: part(2) - old_seed = seed - find_seed:do - call random_number( sample ) - part = int( floor( sample * 2_int64**32, int64 ) & - & - 2_int64**31, int32 ) - seed = transfer( part, seed ) - if ( seed /= old_seed ) return - end do find_seed - !! -END PROCEDURE new_water_hash_seed - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE waterMethods diff --git a/src/submodules/Hashing/src/delme.F90 b/src/submodules/Hashing/src/delme.F90 deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/submodules/IndexValue/CMakeLists.txt b/src/submodules/IndexValue/CMakeLists.txt deleted file mode 100644 index 506d7fdbc..000000000 --- a/src/submodules/IndexValue/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/IndexValue_Method@Constructor.F90 -) \ No newline at end of file diff --git a/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 b/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 deleted file mode 100644 index 90caf6cd2..000000000 --- a/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 +++ /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 -! - -SUBMODULE(IndexValue_Method) Constructor -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! IndexValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor1 -obj%Indx = Indx - obj%Val = Val -END PROCEDURE Constructor1 - -!---------------------------------------------------------------------------- -! IndexValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor2 - INTEGER( I4B ) :: n, i - n = SIZE( Indx ) - ALLOCATE( obj( n ) ) - DO i = 1, n - obj( i )%Indx = Indx( i ) - obj( i )%Val = Val( i ) - END DO -END PROCEDURE Constructor2 - -!---------------------------------------------------------------------------- -! IndexValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor3 - INTEGER( I4B ) :: n, i - n = SIZE( Indx ) - ALLOCATE( obj( n ) ) - DO i = 1, n - obj( i )%Indx = Indx( i ) - obj( i )%Val = Val - END DO -END PROCEDURE Constructor3 - -END SUBMODULE Constructor \ No newline at end of file diff --git a/src/submodules/IntVector/CMakeLists.txt b/src/submodules/IntVector/CMakeLists.txt deleted file mode 100644 index 3309c013a..000000000 --- a/src/submodules/IntVector/CMakeLists.txt +++ /dev/null @@ -1,27 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/IntVector_ConstructorMethod@Methods.F90 - ${src_path}/IntVector_IOMethod@Methods.F90 - ${src_path}/IntVector_SetMethod@Methods.F90 - ${src_path}/IntVector_AppendMethod@Methods.F90 - ${src_path}/IntVector_GetMethod@Methods.F90 - ${src_path}/IntVector_EnquireMethod@Methods.F90 -) diff --git a/src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 deleted file mode 100644 index e62cd6115..000000000 --- a/src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 +++ /dev/null @@ -1,102 +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: 25 Feb 2021 -! summary: This submodule implements set methods of [[IntVector_]] - -SUBMODULE(IntVector_AppendMethod) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Append_1 -CALL Append(obj%Val, VALUE) -END PROCEDURE IntVec_Append_1 - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Append_2 -CALL Append(obj%Val, VALUE) -END PROCEDURE IntVec_Append_2 - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Append_3 -CALL Append(obj%Val, Anotherobj%Val) -END PROCEDURE IntVec_Append_3 - -!---------------------------------------------------------------------------- -! H_CONCAT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_H_CONCAT_1 -INTEGER(I4B) :: s1, s2 -s1 = SIZE(vec1) -s2 = SIZE(vec2) -ans(1:s1) = vec1(:) -ans(s1 + 1:) = vec2(:) -END PROCEDURE IntVec_H_CONCAT_1 - -!---------------------------------------------------------------------------- -! H_CONCAT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_H_CONCAT_2 -INTEGER(I4B) :: s1, s2 -s1 = SIZE(obj1) -s2 = SIZE(obj2) -CALL Initiate(ans, s1 + s2) -ans%val(1:s1) = obj1%val(:) -ans%val(s1 + 1:) = obj2%val(:) -END PROCEDURE IntVec_H_CONCAT_2 - -!---------------------------------------------------------------------------- -! H_CONCAT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_H_CONCAT_3 -INTEGER(I4B) :: s1, s2 -s1 = SIZE(vec1) -s2 = SIZE(obj2) -CALL Initiate(ans, s1 + s2) -ans%val(1:s1) = vec1(:) -ans%val(s1 + 1:) = obj2%val(:) -END PROCEDURE IntVec_H_CONCAT_3 - -!---------------------------------------------------------------------------- -! H_CONCAT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_H_CONCAT_4 -INTEGER(I4B) :: s1, s2 -s1 = SIZE(obj1) -s2 = SIZE(vec2) -CALL Initiate(ans, s1 + s2) -ans%val(1:s1) = obj1%val(:) -ans%val(s1 + 1:) = vec2(:) -END PROCEDURE IntVec_H_CONCAT_4 - -END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 deleted file mode 100644 index bcbeb6ae0..000000000 --- a/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 +++ /dev/null @@ -1,244 +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: 25 Feb 2021 -! summary: This submodule contains the contructor methods for [[IntVector_]] - -SUBMODULE(IntVector_ConstructorMethod) Methods -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -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 intVec_Size -IF (ALLOCATED(obj%Val)) THEN - Ans = SIZE(obj%Val) -ELSE - Ans = 0 -END IF -END PROCEDURE intVec_Size - -!---------------------------------------------------------------------------- -! getTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_getTotalDimension -ans = obj%tDimension -END PROCEDURE IntVec_getTotalDimension - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_AllocateData -CALL Reallocate(obj%Val, Dims) -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_AllocateData - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_Reallocate -IF (ALLOCATED(obj)) THEN - IF (SIZE(obj) .NE. row) THEN - DEALLOCATE (obj) - ALLOCATE (obj(row)) - END IF -ELSE - ALLOCATE (obj(row)) -END IF -END PROCEDURE intVec_Reallocate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_Deallocate -IF (ALLOCATED(obj%Val)) DEALLOCATE (obj%Val) -END PROCEDURE intVec_Deallocate - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_initiate1 -CALL ALLOCATE (obj, tSize) -END PROCEDURE intVec_initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_initiate2 -INTEGER(I4B) :: n, i -n = SIZE(tSize) -IF (ALLOCATED(obj)) THEN - IF (SIZE(obj) .NE. n) THEN - DEALLOCATE (obj) - ALLOCATE (obj(n)) - END IF -ELSE - ALLOCATE (obj(n)) -END IF -DO i = 1, n - CALL ALLOCATE (obj(i), tSize(i)) -END DO -END PROCEDURE intVec_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 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_initiate4a -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4a - -MODULE PROCEDURE intVec_initiate4b -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4b - -MODULE PROCEDURE intVec_initiate4c -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4c - -MODULE PROCEDURE intVec_initiate4d -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4d - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_initiate5a -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate5a - -MODULE PROCEDURE intVec_initiate5b -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate5b - -!---------------------------------------------------------------------------- -! Vector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Constructor1 -CALL ALLOCATE (obj, tSize) -END PROCEDURE IntVec_Constructor1 - -!---------------------------------------------------------------------------- -! Vector_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Constructor2 -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor2 - -!---------------------------------------------------------------------------- -! Vector_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Constructor3 -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor3 - -!---------------------------------------------------------------------------- -! Vector_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Constructor_1 -ALLOCATE (obj) -CALL ALLOCATE (obj, tSize) -END PROCEDURE IntVec_Constructor_1 - -!---------------------------------------------------------------------------- -! Vector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Constructor_2 -ALLOCATE (obj) -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor_2 - -!---------------------------------------------------------------------------- -! Vector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Constructor_3 -ALLOCATE (obj) -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor_3 - -!---------------------------------------------------------------------------- -! Assignment -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_assign_a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val -END IF -END PROCEDURE IntVec_assign_a - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_convert_int -IF (ALLOCATED(From%Val)) THEN - To = From%Val -END IF -END PROCEDURE obj_convert_int - -END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 deleted file mode 100644 index 552e6ec2f..000000000 --- a/src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 +++ /dev/null @@ -1,119 +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(IntVector_EnquireMethod) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! intVec_isAllocated -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_isAllocated -IF (ALLOCATED(obj%Val)) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF -END PROCEDURE intVec_isAllocated - -!---------------------------------------------------------------------------- -! IN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_in1 -ans = obj1%val.in.obj2%val -END PROCEDURE intVec_in1 - -!---------------------------------------------------------------------------- -! IN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_in2a -ans = ANY(a .EQ. obj%val) -END PROCEDURE intVec_in2a - -!---------------------------------------------------------------------------- -! IN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_in2b -ans = ANY(a .EQ. obj%val) -END PROCEDURE intVec_in2b - -!---------------------------------------------------------------------------- -! IN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_in2c -ans = ANY(a .EQ. obj%val) -END PROCEDURE intVec_in2c - -!---------------------------------------------------------------------------- -! IN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_in2d -ans = ANY(a .EQ. obj%val) -END PROCEDURE intVec_in2d - -!---------------------------------------------------------------------------- -! isPresent -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_isPresent1 -INTEGER(I4B) :: i -Ans = .FALSE. -DO i = 1, SIZE(obj%Val) - IF (obj%Val(i) .EQ. VALUE) THEN - Ans = .TRUE. - EXIT - END IF -END DO -END PROCEDURE intVec_isPresent1 - -!---------------------------------------------------------------------------- -! isPresent -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_isPresent2 -INTEGER(I4B) :: i, m, j -LOGICAL(LGT), ALLOCATABLE :: Search(:) -m = SIZE(VALUE) -ALLOCATE (Ans(m), Search(m)) -Search = .TRUE. -Ans = .FALSE. - !! -DO i = 1, SIZE(obj%Val) - DO j = 1, m - IF (Search(j)) THEN - IF (VALUE(j) .EQ. obj%Val(i)) THEN - Search(j) = .FALSE. - Ans(j) = .TRUE. - END IF - END IF - END DO -END DO - !! -END PROCEDURE intVec_isPresent2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 deleted file mode 100644 index 48e791fee..000000000 --- a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 +++ /dev/null @@ -1,284 +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: 25 Feb 2021 -! summary: This submodule implements get methods of [[IntVector_]] - -SUBMODULE(IntVector_GetMethod) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_1 -IF (ALLOCATED(obj%Val)) THEN - Val = IntVector(obj%Val) -END IF -END PROCEDURE intVec_get_1 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_2 -IF (ALLOCATED(obj%Val)) THEN - Val = IntVector(obj%Val(Indx)) -END IF -END PROCEDURE intVec_get_2 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_3 -IF (ALLOCATED(obj%Val)) THEN - Val = IntVector(obj%Val( & - & istart:& - & Input(default=SIZE(obj), option=iend):& - & Input(option=stride, default=1))) -END IF -END PROCEDURE intVec_get_3 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_4 -Val = IntVector(get(obj, TypeInt)) -END PROCEDURE intVec_get_4 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_5 -Val = IntVector(get(obj, Indx, TypeInt)) -END PROCEDURE intVec_get_5 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_6 -Val = IntVector(get(obj, iStart, iEnd, Stride, & - & TypeInt)) -END PROCEDURE intVec_get_6 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_7a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val -END IF -END PROCEDURE intVec_get_7a -MODULE PROCEDURE intVec_get_7b -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val -END IF -END PROCEDURE intVec_get_7b -MODULE PROCEDURE intVec_get_7c -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val -END IF -END PROCEDURE intVec_get_7c -MODULE PROCEDURE intVec_get_7d -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val -END IF -END PROCEDURE intVec_get_7d - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_8a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) -END IF -END PROCEDURE intVec_get_8a - -MODULE PROCEDURE intVec_get_8b -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) -END IF -END PROCEDURE intVec_get_8b - -MODULE PROCEDURE intVec_get_8c -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) -END IF -END PROCEDURE intVec_get_8c - -MODULE PROCEDURE intVec_get_8d -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) -END IF -END PROCEDURE intVec_get_8d - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_9a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) -END IF -END PROCEDURE intVec_get_9a - -MODULE PROCEDURE intVec_get_9b -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) -END IF -END PROCEDURE intVec_get_9b - -MODULE PROCEDURE intVec_get_9c -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) -END IF -END PROCEDURE intVec_get_9c - -MODULE PROCEDURE intVec_get_9d -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) -END IF -END PROCEDURE intVec_get_9d - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_10a -#include "./include/intvec_get_10.inc" -END PROCEDURE intVec_get_10a -MODULE PROCEDURE intVec_get_10b -#include "./include/intvec_get_10.inc" -END PROCEDURE intVec_get_10b -MODULE PROCEDURE intVec_get_10c -#include "./include/intvec_get_10.inc" -END PROCEDURE intVec_get_10c -MODULE PROCEDURE intVec_get_10d -#include "./include/intvec_get_10.inc" -END PROCEDURE intVec_get_10d - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_11a -#include "./include/intvec_get_11.inc" -END PROCEDURE intVec_get_11a -MODULE PROCEDURE intVec_get_11b -#include "./include/intvec_get_11.inc" -END PROCEDURE intVec_get_11b -MODULE PROCEDURE intVec_get_11c -#include "./include/intvec_get_11.inc" -END PROCEDURE intVec_get_11c -MODULE PROCEDURE intVec_get_11d -#include "./include/intvec_get_11.inc" -END PROCEDURE intVec_get_11d - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_12a -#include "./include/intvec_get_12.inc" -END PROCEDURE intVec_get_12a -MODULE PROCEDURE intVec_get_12b -#include "./include/intvec_get_12.inc" -END PROCEDURE intVec_get_12b -MODULE PROCEDURE intVec_get_12c -#include "./include/intvec_get_12.inc" -END PROCEDURE intVec_get_12c -MODULE PROCEDURE intVec_get_12d -#include "./include/intvec_get_12.inc" -END PROCEDURE intVec_get_12d - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_get_13a -#include "./include/intvec_get_13.inc" -END PROCEDURE intVec_get_13a -MODULE PROCEDURE intVec_get_13b -#include "./include/intvec_get_13.inc" -END PROCEDURE intVec_get_13b -MODULE PROCEDURE intVec_get_13c -#include "./include/intvec_get_13.inc" -END PROCEDURE intVec_get_13c -MODULE PROCEDURE intVec_get_13d -#include "./include/intvec_get_13.inc" -END PROCEDURE intVec_get_13d - -!---------------------------------------------------------------------------- -! getPointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_getPointer_1 -Val => obj -END PROCEDURE intVec_getPointer_1 - -!---------------------------------------------------------------------------- -! getPointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_getPointer_2 -Val => obj%Val -END PROCEDURE intVec_getPointer_2 - -!---------------------------------------------------------------------------- -! IndexOf -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_getIndex1 -Ans = MINLOC(ABS(obj%Val - val), 1) -END PROCEDURE intVec_getIndex1 - -!---------------------------------------------------------------------------- -! IndexOf -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_getIndex2 -INTEGER(I4B) :: i, j, m -LOGICAL(LGT), ALLOCATABLE :: Search(:) -! -m = SIZE(val) -ALLOCATE (Search(m), Ans(m)) -Search = .TRUE. -Ans = 0 - -DO i = 1, SIZE(obj%Val) - DO j = 1, m - IF (Search(j)) THEN - IF (val(j) .EQ. obj%Val(i)) THEN - Search(j) = .FALSE. - Ans(j) = i - END IF - END IF - END DO -END DO -END PROCEDURE intVec_getIndex2 - -END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_IOMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_IOMethod@Methods.F90 deleted file mode 100644 index f0c43a5e9..000000000 --- a/src/submodules/IntVector/src/IntVector_IOMethod@Methods.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 -! - -!> author: Vikas Sharma, Ph. D. -! date: 28 Feb 2021 -! summary: This contains Input/Output methods for [[IntVector_]] - -SUBMODULE(IntVector_IOMethod) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_Display1 -INTEGER(I4B) :: j -CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) -CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) -DO j = 1, SIZE(obj) - CALL Display(obj(j), & - & msg="# "//TRIM(msg)//"( " & - & //TOSTRING(j)//" ) ", & - & unitNo=UnitNo, orient=orient) -END DO -END PROCEDURE intVec_Display1 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_Display2 -IF (isAllocated(obj)) THEN - CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) - CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) - CALL Display(Val=obj%Val, msg='', unitNo=unitNo, orient=orient) -END IF -END PROCEDURE intVec_Display2 - -END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 deleted file mode 100644 index 859f575d4..000000000 --- a/src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 +++ /dev/null @@ -1,102 +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: 25 Feb 2021 -! summary: This submodule implements set methods of [[IntVector_]] - -SUBMODULE(IntVector_SetMethod) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_setTotalDimension -obj%tDimension = tDimension -END PROCEDURE IntVec_setTotalDimension - -!---------------------------------------------------------------------------- -! setMethod -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_set1 -IF (ALLOCATED(obj%val)) THEN - IF (SIZE(VALUE) .EQ. 1) THEN - obj%val(Indx) = VALUE(1) - ELSE - obj%val(Indx) = VALUE - END IF -END IF -END PROCEDURE intVec_set1 - -!---------------------------------------------------------------------------- -! setMethod -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intVec_set2 -IF (ALLOCATED(obj%val)) THEN - obj%val(Indx) = VALUE -END IF -END PROCEDURE intVec_set2 - -!---------------------------------------------------------------------------- -! RemoveDuplicate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_RemoveDuplicates_1 -! Define internal variables -INTEGER(I4B) :: i, k, j, N -INTEGER(I4B), ALLOCATABLE :: Res(:) -LOGICAL(LGT) :: isok - -isok = ALLOCATED(obj%val) -IF (.NOT. isok) RETURN - -N = SIZE(obj%val) -isok = N .GT. 0 -IF (.NOT. isok) RETURN - -ALLOCATE (Res(N)) -Res = 0 -Res(1) = obj%val(1) -k = 1 -DO i = 2, N - IF (.NOT. ANY(Res .EQ. obj%val(i))) THEN - k = k + 1 - Res(k) = obj%val(i) - END IF -END DO -obj%val = Res(1:k) -DEALLOCATE (Res) -END PROCEDURE IntVec_RemoveDuplicates_1 - -!---------------------------------------------------------------------------- -! Repeat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IntVec_Repeat_1 -Ans = REPEAT(obj%val, rtimes) -END PROCEDURE IntVec_Repeat_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/include/intvec_get_10.inc b/src/submodules/IntVector/src/include/intvec_get_10.inc deleted file mode 100644 index e2b591ab4..000000000 --- a/src/submodules/IntVector/src/include/intvec_get_10.inc +++ /dev/null @@ -1,32 +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 -! -! -INTEGER(I4B) :: N, i, tNodes, r1, r2 -N = SIZE(obj) -tNodes = 0 -DO i = 1, N - tNodes = tNodes + SIZE(obj(i)%Val) -END DO -!! -ALLOCATE (Val(tNodes)) -!! -tNodes = 0; r1 = 0; r2 = 0 -DO i = 1, N - r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%Val) - Val(r1:r2) = obj(i)%Val -END DO -!! \ No newline at end of file diff --git a/src/submodules/IntVector/src/include/intvec_get_11.inc b/src/submodules/IntVector/src/include/intvec_get_11.inc deleted file mode 100644 index fc400ccb9..000000000 --- a/src/submodules/IntVector/src/include/intvec_get_11.inc +++ /dev/null @@ -1,28 +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 -! - -INTEGER(I4B) :: N, i, M -!! -N = SIZE(obj) -M = SIZE(Indx) -!! -ALLOCATE (Val(N * M)) -!! -DO i = 1, N - Val((i - 1) * M + 1:i * M) = obj(i)%Val(Indx) -END DO -!! \ No newline at end of file diff --git a/src/submodules/IntVector/src/include/intvec_get_12.inc b/src/submodules/IntVector/src/include/intvec_get_12.inc deleted file mode 100644 index 7e76c48fe..000000000 --- a/src/submodules/IntVector/src/include/intvec_get_12.inc +++ /dev/null @@ -1,28 +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 -! - -INTEGER(I4B) :: N, i, M -!! -N = SIZE(obj) -M = 1 + (iEnd - iStart) / Stride -!! -ALLOCATE (Val(M * N)) -!! -DO i = 1, N - Val((i - 1) * M + 1:i * M) = obj(i)%Val(iStart:iEnd:Stride) -END DO -!! \ No newline at end of file diff --git a/src/submodules/IntVector/src/include/intvec_get_13.inc b/src/submodules/IntVector/src/include/intvec_get_13.inc deleted file mode 100644 index e2c817f0d..000000000 --- a/src/submodules/IntVector/src/include/intvec_get_13.inc +++ /dev/null @@ -1,18 +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 -! - -val = obj%val(indx) \ No newline at end of file diff --git a/src/submodules/IterationData/CMakeLists.txt b/src/submodules/IterationData/CMakeLists.txt deleted file mode 100644 index 99076a595..000000000 --- a/src/submodules/IterationData/CMakeLists.txt +++ /dev/null @@ -1,23 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/IterationData_Method@ConstructorMethods.F90 - ${src_path}/IterationData_Method@IOMethods.F90 -) \ No newline at end of file diff --git a/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 b/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 deleted file mode 100644 index 4317fb565..000000000 --- a/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,179 +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(IterationData_Method) ConstructorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE iterdata_Initiate - IF( PRESENT( MaxIter ) ) obj%MaxIter = MaxIter - IF( PRESENT( IterationNumber ) ) obj%IterationNumber = IterationNumber - IF( PRESENT( ResidualError0 ) ) obj%ResidualError0 = ResidualError0 - IF( PRESENT( ResidualError ) ) obj%ResidualError = ResidualError - IF( PRESENT( ResidualTolerance ) ) obj%ResidualTolerance = ResidualTolerance - IF( PRESENT( SolutionError0 ) ) obj%SolutionError0 = SolutionError0 - IF( PRESENT( SolutionError ) ) obj%SolutionError = SolutionError - IF( PRESENT( SolutionTolerance ) ) obj%SolutionTolerance = SolutionTolerance - IF( PRESENT( ConvergenceType ) ) obj%ConvergenceType = ConvergenceType - IF( PRESENT( ConvergenceIn ) ) obj%ConvergenceIn = ConvergenceIn - IF( PRESENT( NormType ) ) obj%NormType = NormType - IF( PRESENT( Converged ) ) obj%Converged = Converged - IF( PRESENT( TimeAtStart ) ) obj%TimeAtStart = TimeAtStart - IF( PRESENT( TimeAtEnd ) ) obj%TimeAtEnd = TimeAtEnd -END PROCEDURE iterdata_Initiate - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE iterdata_Deallocate - obj%MaxIter = 0 - obj%IterationNumber = 0 - obj%ResidualError = 0.0 - obj%ResidualError0 = 0.0 - obj%ResidualTolerance = 0.0 - obj%SolutionError = 0.0 - obj%SolutionError0 = 0.0 - obj%SolutionTolerance = 0.0 - obj%ConvergenceType = 0 - obj%ConvergenceIn = 0 - obj%NormType = 0 - obj%Converged = .FALSE. - obj%TimeAtStart = 0.0 - obj%TimeAtEnd = 0.0 - IF( allocated( obj%convergenceData ) ) DEALLOCATE( obj%convergenceData ) - IF( allocated( obj%header ) ) DEALLOCATE( obj%header ) -END PROCEDURE iterdata_Deallocate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE iterdata_isConverged - LOGICAL( LGT ) :: l1, l2 - !! - SELECT CASE( obj%convergenceIn ) - !! - !! Convergence in residual - !! - CASE( ConvergenceInRes ) - ! !! - IF( obj%convergenceType .EQ. RelativeConvergence ) THEN - !! - ans = checkConvergence( & - & errorAtStart=obj%residualError0, & - & errorAtEnd=obj%residualError, & - & tolerance=obj%residualTolerance ) - !! - ELSE - !! - ans = checkConvergence( & - & errorAtStart=1.0_DFP, & - & errorAtEnd=obj%residualError, & - & tolerance=obj%residualTolerance ) - !! - END IF - !! - !! Convergence in sol - !! - CASE( ConvergenceInSol ) - !! - IF( obj%convergenceType .EQ. RelativeConvergence ) THEN - !! - ans = checkConvergence( & - & errorAtStart=obj%solutionError0, & - & errorAtEnd=obj%solutionError, & - & tolerance=obj%solutionTolerance ) - !! - ELSE - !! - ans = checkConvergence( & - & errorAtStart=1.0_DFP, & - & errorAtEnd=obj%solutionError, & - & tolerance=obj%solutionTolerance ) - !! - END IF - !! - !! Convergence in both solution and residual - !! - CASE( ConvergenceInResSol ) - !! - IF( obj%convergenceType .EQ. RelativeConvergence ) THEN - !! - ans = checkConvergence( & - & errorAtStart=obj%residualError0, & - & errorAtEnd=obj%residualError, & - & tolerance=obj%residualTolerance ) & - & .AND. & - & checkConvergence( & - & errorAtStart=obj%solutionError0, & - & errorAtEnd=obj%solutionError, & - & tolerance=obj%solutionTolerance ) - !! - ELSE - !! - ans = checkConvergence( & - & errorAtStart=1.0_DFP, & - & errorAtEnd=obj%residualError, & - & tolerance=obj%residualTolerance ) & - & .AND. & - & checkConvergence( & - & errorAtStart=1.0_DFP, & - & errorAtEnd=obj%solutionError, & - & tolerance=obj%solutionTolerance ) - !! - END IF - !! - !! - !! - END SELECT - !! - !! - !! -END PROCEDURE iterdata_isConverged - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION checkConvergence( errorAtStart, errorAtEnd, tolerance ) & - & RESULT( ans ) - !! - REAL( DFP ), INTENT( IN ) :: errorAtStart - REAL( DFP ), INTENT( IN ) :: errorAtEnd - REAL( DFP ), INTENT( IN ) :: tolerance - LOGICAL( LGT ) :: ans - !! - !! - IF( errorAtEnd .LE. tolerance * errorAtStart ) THEN - Ans = .TRUE. - ELSE - Ans = .FALSE. - END IF - !! -END FUNCTION checkConvergence - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE ConstructorMethods \ No newline at end of file diff --git a/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 b/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 deleted file mode 100644 index d316aa439..000000000 --- a/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 +++ /dev/null @@ -1,44 +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(IterationData_Method) IOMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE iterdata_Display -CALL Display(TRIM(msg), unitno) -CALL Display(obj%maxIter, 'maxIter: ', unitno) -CALL Display(obj%iterationNumber, 'iterationNumber: ', unitno) -CALL Display(obj%residualError0, 'residualError0: ', unitno) -CALL Display(obj%residualError, 'residualError: ', unitno) -CALL Display(obj%residualTolerance, 'residualTolerance: ', unitno) -CALL Display(obj%solutionError0, 'solutionError0: ', unitno) -CALL Display(obj%solutionError, 'solutionError: ', unitno) -CALL Display(obj%solutionTolerance, 'solutionTolerance: ', unitno) -CALL Display(obj%convergenceType, 'convergenceType: ', unitno) -CALL Display(obj%convergenceIn, 'convergenceIn: ', unitno) -CALL Display(obj%normType, 'normType: ', unitno) -CALL Display(obj%converged, 'converged: ', unitno) -CALL Display(obj%timeAtStart, 'timeAtStart: ', unitno) -CALL Display(obj%timeAtEnd, 'timeAtEnd: ', unitno) -END PROCEDURE iterdata_Display - -END SUBMODULE IOMethods diff --git a/src/submodules/KeyValue/CMakeLists.txt b/src/submodules/KeyValue/CMakeLists.txt deleted file mode 100644 index f5e7b9296..000000000 --- a/src/submodules/KeyValue/CMakeLists.txt +++ /dev/null @@ -1,15 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/KeyValue_Method@Constructor.F90 - ${src_path}/KeyValue_Method@getMethod.F90 - ${src_path}/KeyValue_Method@setMethod.F90 -) \ No newline at end of file diff --git a/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 b/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 deleted file mode 100644 index 183bd13ea..000000000 --- a/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 +++ /dev/null @@ -1,505 +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: 4 March 2021 -! summary: This submodule contains implementation of construction methods [[keyvalue_]] - -SUBMODULE(KeyValue_Method) Constructor -USE BaseMethod -IMPLICIT NONE - -CONTAINS -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate1 - obj%DataType = Real_Rank_0 - obj%Key = Key - obj%Value = RESHAPE( [Value], [1,1] ) -END PROCEDURE Initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate2 - obj%DataType = Real_Rank_0 - obj%Key = Key - obj%Value = RESHAPE( [Value], [1,1] ) -END PROCEDURE Initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate3 - obj%DataType = Real_Rank_1 - obj%Key = Key - obj%Value = RESHAPE( Value, [SIZE( Value ), 1] ) -END PROCEDURE Initiate3 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate4 - obj%DataType = Real_Rank_1 - obj%Key = Key - obj%Value = RESHAPE( Value, [SIZE( Value ), 1] ) -END PROCEDURE Initiate4 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate5 - obj%DataType = Real_Rank_2 - obj%Key = Key - obj%Value = Value -END PROCEDURE Initiate5 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate6 - obj%DataType = Real_Rank_2 - obj%Key = Key - obj%Value = Value -END PROCEDURE Initiate6 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate7 - obj%DataType = Int_Rank_0 - obj%Key = Key - obj%Value = RESHAPE( [Value], [1,1] ) -END PROCEDURE Initiate7 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate8 - obj%DataType = Int_Rank_0 - obj%Key = Key - obj%Value = REAL( RESHAPE( [Value], [1,1] ), DFP ) -END PROCEDURE Initiate8 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate9 - obj%DataType = Int_Rank_1 - obj%Key = Key - obj%Value = REAL( RESHAPE( Value, [SIZE( Value ), 1 ] ), DFP ) -END PROCEDURE Initiate9 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate10 - obj%DataType = Int_Rank_1 - obj%Key = Key - obj%Value = REAL( RESHAPE( Value, [SIZE( Value ), 1 ] ), DFP ) -END PROCEDURE Initiate10 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate11 - obj%DataType = Int_Rank_2 - obj%Key = Key - obj%Value = REAL( Value, DFP ) -END PROCEDURE Initiate11 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate12 - obj%DataType = Int_Rank_2 - obj%Key = Key - obj%Value = REAL( Value, DFP ) -END PROCEDURE Initiate12 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Initiate13 - obj%DataType = obj2%DataType - obj%Key = obj2%Key - IF( ALLOCATED( obj2%Value ) ) THEN - obj%Value = obj2%Value - END IF -END PROCEDURE Initiate13 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor1 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor1 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor2 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor2 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor3 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor3 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor4 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor4 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor5 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor5 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor6 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor6 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor7 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor7 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor8 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor8 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor9 - CALL Initiate( Ans, Key, Value ) -END PROCEDURE Constructor9 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor10 - CALL Initiate(Ans, Key, Value ) -END PROCEDURE Constructor10 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor11 - CALL Initiate(Ans, Key, Value ) -END PROCEDURE Constructor11 - -!---------------------------------------------------------------------------- -! KeyValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor12 - CALL Initiate(Ans, Key, Value ) -END PROCEDURE Constructor12 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE keyvalue_display - INTEGER( I4B ) :: I - CHARACTER( LEN = 6 ) :: s - - I = stdout - - IF( PRESENT( UnitNo ) ) I = UnitNo - SELECT CASE( obj%DataType ) - CASE( REAL_RANK_0 ) - s = "Rank0" - CASE( REAL_RANK_1 ) - s = "Rank1" - CASE( REAL_RANK_2 ) - s = "Rank2" - CASE( INT_RANK_0 ) - s = "Rank0" - CASE( INT_RANK_1 ) - s = "Rank1" - CASE( INT_RANK_2 ) - s = "Rank2" - END SELECT - - IF( LEN_TRIM( msg ) .NE. 0 ) CALL Display( msg, I ) - IF( ALLOCATED( obj%Value ) ) THEN - CALL Display( obj%Value, & - & s // " :: " // TRIM( obj%Key%Raw ) // " :: ", UnitNo = I ) - ELSE - CALL Display( s // " :: " // TRIM( obj%Key%Raw ) // " :: ", UnitNo = I ) - END IF -END PROCEDURE keyvalue_display - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mp_display - INTEGER( I4B ) :: n, i, j - - I = stdout - IF( PRESENT( UnitNo ) ) I = UnitNo - n = SIZE( obj ) - CALL BlankLines( UnitNo = I ) - DO j = 1, n - CALL display( obj( j ), msg, UnitNo = I ) - CALL BlankLines( UnitNo = I ) - END DO - -END PROCEDURE mp_display - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Equal1 - Ans = obj%Key .EQ. String( Key ) -END PROCEDURE Equal1 - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Equal2 - Ans = obj%Key .EQ. String( Key ) -END PROCEDURE Equal2 - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Equal3 - Ans = obj%Key .EQ. Key -END PROCEDURE Equal3 - -!---------------------------------------------------------------------------- -! Equal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Equal4 - Ans = obj%Key .EQ. Key -END PROCEDURE Equal4 - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE keyvalue_deallocate - IF( ALLOCATED( obj%Value ) ) DEALLOCATE( obj%Value ) -END PROCEDURE keyvalue_deallocate - -END SUBMODULE Constructor - -! CONTAINS - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_1( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! CHARACTER( LEN = * ), INTENT( IN ) :: Key -! REAL( DFP ), INTENT( IN ) :: Value - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_1 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_2( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! TYPE( String ), INTENT( IN ) :: Key -! REAL( DFP ), INTENT( IN ) :: Value - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_2 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_3( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! CHARACTER( LEN = * ), INTENT( IN ) :: Key -! REAL( DFP ), INTENT( IN ) :: Value( : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_3 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_4( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! TYPE( String ), INTENT( IN ) :: Key -! REAL( DFP ), INTENT( IN ) :: Value( : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_4 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_5( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! CHARACTER( LEN = * ), INTENT( IN ) :: Key -! REAL( DFP ), INTENT( IN ) :: Value( :, : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_5 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_6( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! TYPE( String ), INTENT( IN ) :: Key -! REAL( DFP ), INTENT( IN ) :: Value( :, : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_6 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_7( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! CHARACTER( LEN = * ), INTENT( IN ) :: Key -! INTEGER( I4B ), INTENT( IN ) :: Value - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_7 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_8( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! TYPE( String ), INTENT( IN ) :: Key -! INTEGER( I4B ), INTENT( IN ) :: Value - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_8 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_9( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! CHARACTER( LEN = * ), INTENT( IN ) :: Key -! INTEGER( I4B ), INTENT( IN ) :: Value( : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_9 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_10( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! TYPE( String ), INTENT( IN ) :: Key -! INTEGER( I4B ), INTENT( IN ) :: Value( : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_10 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_11( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! CHARACTER( LEN = * ), INTENT( IN ) :: Key -! INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_11 - -! !---------------------------------------------------------------------------- -! ! KeyValue_Pointer -! !---------------------------------------------------------------------------- - -! FUNCTION Constructor_12( Key, Value ) RESULT( Ans ) -! CLASS( keyValue_ ), POINTER :: Ans -! TYPE( String ), INTENT( IN ) :: Key -! INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) - -! ALLOCATE( Ans ) -! CALL Initiate( Ans, Key, Value ) -! END FUNCTION Constructor_12 \ No newline at end of file diff --git a/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 b/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 deleted file mode 100644 index ceaf46ca5..000000000 --- a/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 +++ /dev/null @@ -1,186 +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(KeyValue_Method) getMethod - !! This submodule includes implementation of method to set values in - !! [[keyvalue_]] -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! getKey -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getKey1 - Key = TRIM( obj%Key%Raw ) -END PROCEDURE getKey1 - -!---------------------------------------------------------------------------- -! getKey -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getKey2 - Key = obj%Key -END PROCEDURE getKey2 - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getValue1 - Value = obj%Value( 1, 1 ) -END PROCEDURE getValue1 - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getValue2 - Value = obj%Value( :, 1 ) -END PROCEDURE getValue2 - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getValue3 - Value = obj%Value -END PROCEDURE getValue3 - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getValue4 - Value = INT( obj%Value( 1, 1 ) ) -END PROCEDURE getValue4 - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getValue5 - Value = INT( obj%Value( :, 1 ) ) -END PROCEDURE getValue5 - -!---------------------------------------------------------------------------- -! getValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getValue6 - Value = INT( obj%Value ) -END PROCEDURE getValue6 - -!---------------------------------------------------------------------------- -! INDEX -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Index1 - INTEGER( I4B ) :: I - Ans = 0 - DO I = 1, SIZE( obj ) - IF( obj( I ) .EQ. Key ) THEN - Ans = I - EXIT - END IF - END DO -END PROCEDURE Index1 - -!---------------------------------------------------------------------------- -! INDEX -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Index2 - INTEGER( I4B ) :: I - Ans = 0 - DO I = 1, SIZE( obj ) - IF( obj( I ) .EQ. Key ) THEN - Ans = I - EXIT - END IF - END DO -END PROCEDURE Index2 - -!---------------------------------------------------------------------------- -! Present -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Present1 - INTEGER( I4B ) :: I - Ans = .FALSE. - DO I = 1, SIZE( obj ) - IF( obj( I ) .EQ. Key ) THEN - Ans = .TRUE. - EXIT - END IF - END DO -END PROCEDURE Present1 - -!---------------------------------------------------------------------------- -! Present -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Present2 - INTEGER( I4B ) :: I - Ans = .FALSE. - DO I = 1, SIZE( obj ) - IF( obj( I ) .EQ. Key ) THEN - Ans = .TRUE. - EXIT - END IF - END DO -END PROCEDURE Present2 - -!---------------------------------------------------------------------------- -! Contains -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Contains1 - INTEGER( I4B ) :: I - - Ans = .FALSE. - DO I = 1, SIZE( obj ) - IF( obj( I ) .EQ. Key ) THEN - Ans = .TRUE. - EXIT - END IF - END DO - -END PROCEDURE Contains1 - -!---------------------------------------------------------------------------- -! Contains -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Contains2 - INTEGER( I4B ) :: I - Ans = .FALSE. - DO I = 1, SIZE( obj ) - IF( obj( I ) .EQ. Key ) THEN - Ans = .TRUE. - EXIT - END IF - END DO -END PROCEDURE Contains2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE getMethod diff --git a/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 b/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 deleted file mode 100644 index 6c0da142e..000000000 --- a/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 +++ /dev/null @@ -1,138 +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(KeyValue_Method) setMethod - !! This submodule includes implementation of method to set values in - !! [[keyvalue_]] -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setKey1 - obj%Key = Key -END PROCEDURE setKey1 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE setKey2 - obj%Key = Key -END PROCEDURE setKey2 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetValue1 - CALL Initiate( obj, obj%Key, Value ) -END PROCEDURE SetValue1 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetValue2 - CALL Initiate( obj, obj%Key, Value ) -END PROCEDURE SetValue2 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetValue3 - CALL Initiate( obj, obj%Key, Value ) -END PROCEDURE SetValue3 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetValue4 - CALL Initiate( obj, obj%Key, Value ) -END PROCEDURE SetValue4 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetValue5 - CALL Initiate( obj, obj%Key, Value ) -END PROCEDURE SetValue5 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetValue6 - CALL Initiate( obj, obj%Key, Value ) -END PROCEDURE SetValue6 - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE keyvalue_append - INTEGER( I4B ) :: I, Indx, tSize - LOGICAL( LGT ) :: isPresent - - IF( .NOT. ALLOCATED( obj ) ) THEN - ALLOCATE( obj( 1 ) ) - obj( 1 ) = KeyValobj - ELSE - tSize = SIZE( obj ) - DO I = 1, tSize - isPresent = obj( I ) .EQ. KeyValobj%Key - IF( isPresent ) THEN - Indx = I - EXIT - END IF - END DO - - IF( isPresent ) THEN - - obj( Indx ) = KeyValobj - - ELSE - - BLOCK - TYPE( keyvalue_ ) :: Dummyobj( tSize ) - - DO I = 1, tSize - Dummyobj( I ) = obj( I ) - END DO - - DEALLOCATE( obj ) - ALLOCATE( obj( tSize + 1 ) ) - - DO I = 1, tSize - obj( I ) = Dummyobj( I ) - END DO - - obj( tSize + 1 ) = KeyValobj - - END BLOCK - END IF - END IF - -END PROCEDURE keyvalue_append - -END SUBMODULE setMethod \ No newline at end of file diff --git a/src/submodules/Lapack/CMakeLists.txt b/src/submodules/Lapack/CMakeLists.txt deleted file mode 100644 index 2ae05b6c4..000000000 --- a/src/submodules/Lapack/CMakeLists.txt +++ /dev/null @@ -1,41 +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 -# - -IF( USE_LAPACK95 ) - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/GE_CompRoutineMethods@Methods.F90 - ${src_path}/GE_EigenValueMethods@Methods.F90 - ${src_path}/GE_LUMethods@Methods.F90 - ${src_path}/GE_LinearSolveMethods@Methods.F90 - ${src_path}/GE_SingularValueMethods@Methods.F90 - ) -ENDIF( ) - -IF( USE_LAPACK95 ) - SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") - TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Sym_CompRoutineMethods@Methods.F90 - ${src_path}/Sym_EigenValueMethods@Methods.F90 - ${src_path}/Sym_LUMethods@Methods.F90 - ${src_path}/Sym_LinearSolveMethods@Methods.F90 - ${src_path}/Sym_SingularValueMethods@Methods.F90 - ) -ENDIF( ) - diff --git a/src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 b/src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 deleted file mode 100644 index f7001e886..000000000 --- a/src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 +++ /dev/null @@ -1,74 +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(GE_CompRoutineMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ConditionNo -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_ConditionNo_1 -REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: tempA -tempA = A -CALL getLU(A=tempA, RCOND=ans, NORM=NORM) -ans = 1.0_DFP / ans -END PROCEDURE ge_ConditionNo_1 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat1 -INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) -invA = A -CALL getLU(A=invA, IPIV=ipiv, info=info) -CALL GETRI(A=invA, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat1 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat2 -INTEGER(I4B) :: info -invA = A -CALL GETRI(A=invA, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat2 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat3 -INTEGER(I4B) :: info -CALL GETRI(A=A, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat3 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat4 -INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) -CALL getLU(A=A, IPIV=ipiv, info=info) -CALL GETRI(A=A, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat4 - -END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 b/src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 deleted file mode 100644 index 66e2098e7..000000000 --- a/src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 +++ /dev/null @@ -1,203 +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 - -! the implementation of deig, zeig, deigvals, and zeigvals are copied from -! linalg.f90 available in https://github.com/certik/fortran-utils -! and are modified to suit the needs of EASIFEM library - -SUBMODULE(GE_EigenValueMethods) Methods -USE BaseMethod, ONLY: ErrorMsg, GEEV, stderr, stdout, tostring, & - Display, Input -USE AssertUtility -IMPLICIT NONE -COMPLEX(DFPC), PARAMETER :: i_ = (0.0_DFP, 1.0_DFP) -CONTAINS - -!---------------------------------------------------------------------------- -! getEig -!---------------------------------------------------------------------------- - -MODULE PROCEDURE deig -! LAPACK variables for DGEEV: -REAL(DFP), ALLOCATABLE :: At(:, :), vr(:, :), wi(:), wr(:) -INTEGER(I4B) :: info, lda, ldvr, n, i -LOGICAL(LGT) :: destroy0 - -CHARACTER(*), PARAMETER :: myName = "deig" - -destroy0 = Input(default=.TRUE., option=destroy) -lda = SIZE(A, 1) -n = SIZE(A, 2) -ldvr = n -! CALL Assert(Mat=A, s=[n, n], msg="[ARG ERROR] :: A should be square", & -! file=__FILE__, line=__LINE__, routine=myName) -! CALL Assert(n1=SIZE(lam), n2=n, msg="[ARG ERROR] :: size of lam should be "// & -! "equal to "//tostring(n), file=__FILE__, line=__LINE__, & -! routine=myName) -! CALL Assert(mat=c, s=[n, n], msg="[ARG ERROR] :: shape of c should be"// & -! "the same as one of A", file=__FILE__, line=__LINE__, & -! routine=myName) - -ALLOCATE (wr(n), wi(n), vr(ldvr, n)) -IF (.NOT. destroy0) THEN - ALLOCATE (At(lda, n)) - At = A - CALL GEEV(A=At, WR=wr, WI=wi, VR=vr, INFO=info) -ELSE - CALL GEEV(A=A, WR=wr, WI=wi, VR=vr, INFO=info) -END IF - -IF (info .NE. 0) CALL GeevErrorMsg(info, n) - -lam = wr + i_ * wi -! as DGEEV has a rather complicated way of returning the eigenvectors, -! it is necessary to build the complex array of eigenvectors from -! two real arrays: -DO i = 1, n - IF (wi(i) > 0.0) THEN ! first of two conjugate eigenvalues - c(:, i) = vr(:, i) + i_ * vr(:, i + 1) - ELSEIF (wi(i) < 0.0_DFP) THEN ! second of two conjugate eigenvalues - c(:, i) = vr(:, i - 1) - i_ * vr(:, i) - ELSE - c(:, i) = vr(:, i) - END IF -END DO - -END PROCEDURE deig - -!---------------------------------------------------------------------------- -! getEig -!---------------------------------------------------------------------------- - -MODULE PROCEDURE zeig -! LAPACK variables: -INTEGER(I4B) :: info, ldvr, n -REAL(DFP), ALLOCATABLE :: rwork(:) -COMPLEX(DFPC), ALLOCATABLE :: vr(:, :) -LOGICAL(LGT) :: destroy0 - -CHARACTER(*), PARAMETER :: myName = "zeig" - -destroy0 = Input(default=.TRUE., option=destroy) -n = SIZE(A, 2) -ldvr = n -! CALL Assert(Mat=A, s=[n, n], msg="[ARG ERROR] :: A should be square", & -! file=__FILE__, line=__LINE__, routine=myName) -! CALL Assert(n1=SIZE(lam), n2=n, msg="[ARG ERROR] :: size of lam should be "// & -! "equal to "//tostring(n), file=__FILE__, line=__LINE__, & -! routine=myName) -! CALL Assert(mat=c, s=[n, n], msg="[ARG ERROR] :: shape of c should be"// & -! "the same as one of A", file=__FILE__, line=__LINE__, & -! routine=myName) -ALLOCATE (vr(ldvr, n)) -IF (.NOT. destroy0) THEN - c = A - CALL GEEV(A=c, W=lam, VR=vr, INFO=info) - c = vr -ELSE - CALL GEEV(A=A, W=lam, VR=c, INFO=info) -END IF - -IF (info .NE. 0) CALL GeevErrorMsg(info, n) - -END PROCEDURE zeig - -!---------------------------------------------------------------------------- -! getEigVals -!---------------------------------------------------------------------------- - -MODULE PROCEDURE deigvals -! LAPACK variables for DGEEV: -REAL(DFP), ALLOCATABLE :: At(:, :), wi(:), wr(:) -INTEGER(I4B) :: info, lda, ldvr, n, i -LOGICAL(LGT) :: destroy0 - -CHARACTER(*), PARAMETER :: myName = "deigvals" - -destroy0 = Input(default=.TRUE., option=destroy) -lda = SIZE(A, 1) -n = SIZE(A, 2) -ldvr = n - -ALLOCATE (wr(n), wi(n)) -IF (.NOT. destroy0) THEN - ALLOCATE (At(lda, n)) - At = A - CALL GEEV(A=At, WR=wr, WI=wi, INFO=info) -ELSE - CALL GEEV(A=A, WR=wr, WI=wi, INFO=info) -END IF - -IF (info .NE. 0) CALL GeevErrorMsg(info, n) - -lam = wr + i_ * wi -END PROCEDURE deigvals - -!---------------------------------------------------------------------------- -! getEigVals_2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE zeigvals -! LAPACK variables: -INTEGER(I4B) :: info, lda, n -COMPLEX(DFPC), ALLOCATABLE :: At(:, :) -LOGICAL(LGT) :: destroy0 - -CHARACTER(*), PARAMETER :: myName = "zeigvals" -destroy0 = Input(default=.TRUE., option=destroy) - -lda = SIZE(A, 1) -n = SIZE(A, 2) -IF (.NOT. destroy0) THEN - ALLOCATE (At(lda, n)) - At = A - CALL GEEV(A=At, W=lam, INFO=info) -ELSE - CALL GEEV(A=A, W=lam, INFO=info) -END IF -IF (info .NE. 0) CALL GeevErrorMsg(info, n) - -END PROCEDURE zeigvals - -!---------------------------------------------------------------------------- -! geevErrorMsg -!---------------------------------------------------------------------------- - -SUBROUTINE GeevErrorMsg(info, n) - INTEGER(I4B), INTENT(IN) :: info, n - - CALL Display(info, "LA_GEEV returned info = ", unitno=stdout) - IF (info .LT. 0) THEN - CALL Display("The "//tostring(-info)//"-th argument "// & - "had an illegal value.", unitno=stderr) - ELSE - CALL Display("The QR algorithm failed to compute all the", unitno=stderr) - CALL Display("eigenvalues, and no eigenvectors have been computed;", & - unitno=stderr) - CALL Display("elements "//tostring(info + 1)//":"//tostring(n)// & - " of WR and WI contain eigenvalues which converged.", & - unitno=stderr) - END IF - CALL ErrorMsg( & - & msg="ERROR IN LA_GEEV", & - & file=__FILE__, & - & line=__LINE__, & - & routine="zeigvals", & - & unitno=stderr) - STOP -END SUBROUTINE GeevErrorMsg - -END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_LUMethods@Methods.F90 b/src/submodules/Lapack/src/GE_LUMethods@Methods.F90 deleted file mode 100644 index a529f9de1..000000000 --- a/src/submodules/Lapack/src/GE_LUMethods@Methods.F90 +++ /dev/null @@ -1,144 +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(GE_LUMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getLU_1 -LU = A -CALL GETRF(A=LU, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) -END PROCEDURE getLU_1 - -!---------------------------------------------------------------------------- -! getLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getLU_2 -CALL GETRF(A=A, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) -END PROCEDURE getLU_2 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_1 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_1 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_2 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_2 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_3 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -X = B -!! -CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_3 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_4 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -X = B -CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_4 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Inv_1 -invA = A -CALL GETRI(A=invA, IPIV=IPIV, info=info) -END PROCEDURE Inv_1 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Inv_2 -CALL GETRI(A=A, IPIV=IPIV, info=info) -END PROCEDURE Inv_2 - -END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 deleted file mode 100644 index 9ef6ff814..000000000 --- a/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 +++ /dev/null @@ -1,74 +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(GE_Lapack_Method) CompRoutineMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ConditionNo -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_ConditionNo_1 -REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: tempA -tempA = A -CALL getLU(A=tempA, RCOND=ans, NORM=NORM) -ans = 1.0_DFP / ans -END PROCEDURE ge_ConditionNo_1 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat1 -INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) -invA = A -CALL getLU(A=invA, IPIV=ipiv, info=info) -CALL GETRI(A=invA, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat1 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat2 -INTEGER(I4B) :: info -invA = A -CALL GETRI(A=invA, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat2 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat3 -INTEGER(I4B) :: info -CALL GETRI(A=A, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat3 - -!---------------------------------------------------------------------------- -! GetInvMat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_GetInvMat4 -INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) -CALL getLU(A=A, IPIV=ipiv, info=info) -CALL GETRI(A=A, IPIV=ipiv, info=info) -END PROCEDURE ge_GetInvMat4 - -END SUBMODULE CompRoutineMethods diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 deleted file mode 100644 index 4888c962f..000000000 --- a/src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 +++ /dev/null @@ -1,29 +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(GE_Lapack_Method) EigenValueMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! DGEES -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dgees_1 -END PROCEDURE dgees_1 -END SUBMODULE EigenValueMethods \ No newline at end of file diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 deleted file mode 100644 index ef6c8a86a..000000000 --- a/src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 +++ /dev/null @@ -1,144 +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(GE_Lapack_Method) LUMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! getLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getLU_1 -LU = A -CALL GETRF(A=LU, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) -END PROCEDURE getLU_1 - -!---------------------------------------------------------------------------- -! getLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getLU_2 -CALL GETRF(A=A, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) -END PROCEDURE getLU_2 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_1 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_1 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_2 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_2 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_3 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -X = B -!! -CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_3 - -!---------------------------------------------------------------------------- -! LUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LUSolve_4 -CHARACTER(1) :: TRANS -!! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF -!! -X = B -CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) -!! -END PROCEDURE LUSolve_4 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Inv_1 -invA = A -CALL GETRI(A=invA, IPIV=IPIV, info=info) -END PROCEDURE Inv_1 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Inv_2 -CALL GETRI(A=A, IPIV=IPIV, info=info) -END PROCEDURE Inv_2 - -END SUBMODULE LUMethods diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 deleted file mode 100644 index 27d562670..000000000 --- a/src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 +++ /dev/null @@ -1,278 +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(GE_Lapack_Method) LinearSolveMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_solve_1 -REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At -CHARACTER(LEN=1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -At = A -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=At, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_solve_1 - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_solve_2 -REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At -CHARACTER(LEN=1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -At = A -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=At, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_solve_2 - -!---------------------------------------------------------------------------- -! LinSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_1 -CHARACTER(LEN=1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_1 - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_2 -CHARACTER(LEN=1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_2 - -!---------------------------------------------------------------------------- -! LinSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_3 -CHARACTER(LEN=1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=B, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_3 - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_4 -CHARACTER(LEN=1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=B, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE LinearSolveMethods diff --git a/src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 b/src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 deleted file mode 100644 index a015d5746..000000000 --- a/src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 +++ /dev/null @@ -1,278 +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(GE_LinearSolveMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_solve_1 -REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At -CHARACTER(1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -At = A -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=At, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_solve_1 - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_solve_2 -REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At -CHARACTER(1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -At = A -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=At, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=At, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_solve_2 - -!---------------------------------------------------------------------------- -! LinSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_1 -CHARACTER(1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_1 - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_2 -CHARACTER(1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -X = B - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=X, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=X, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_2 - -!---------------------------------------------------------------------------- -! LinSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_3 -CHARACTER(1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=B, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_3 - -!---------------------------------------------------------------------------- -! Solve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ge_linsolve_4 -CHARACTER(1) :: TRANS - !! -IF (PRESENT(isTranspose)) THEN - IF (isTranspose) THEN - TRANS = "T" - ELSE - TRANS = "N" - END IF -ELSE - TRANS = "N" -END IF - !! -IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN - CALL GESV(A=A, B=B, IPIV=IPIV, info=info) -ELSE - IF (PRESENT(SolverName)) THEN - SELECT CASE (TRIM(SolverName)) - !! - CASE ("GELS") - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - !! - CASE ("GELSD") - CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - CASE ("GELSS") - CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) - !! - END SELECT - ELSE - CALL GELS(A=A, B=B, TRANS=TRANS, info=info) - END IF -END IF - !! -END PROCEDURE ge_linsolve_4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 b/src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 deleted file mode 100644 index f7c7f1938..000000000 --- a/src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 +++ /dev/null @@ -1,29 +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(GE_SingularValueMethods) Methods -! USE BaseMethod -! IMPLICIT NONE -! CONTAINS -! -! !---------------------------------------------------------------------------- -! ! DGEES -! !---------------------------------------------------------------------------- -! -! ! MODULE PROCEDURE dgees_1 -! ! END PROCEDURE dgees_1 -! END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 deleted file mode 100644 index 63b7886bf..000000000 --- a/src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 +++ /dev/null @@ -1,16 +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 -! diff --git a/src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 deleted file mode 100644 index 63b7886bf..000000000 --- a/src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 +++ /dev/null @@ -1,16 +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 -! diff --git a/src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 deleted file mode 100644 index 10b45b9d8..000000000 --- a/src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 +++ /dev/null @@ -1,507 +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(Sym_LUMethods) Methods -USE GlobalData, ONLY: DFP, I4B, LGT -USE BaseMethod, ONLY: Display, Input, Arange, Zeros, GetTril, & -& GetTriu, ArgSort, tostring -USE F95_LAPACK, ONLY: SYTRF, LACPY, LAPMR, POTRF, SYTRS, SYTRI -USE F77_LAPACK, ONLY: SYCONV => LA_SYCONV -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLU_1 -CALL LACPY(A=A, B=LU, UPLO=UPLO) -CALL SYTRF(A=LU, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -END PROCEDURE SymGetLU_1 - -!---------------------------------------------------------------------------- -! GetLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLU_2 -CALL SYTRF(A=A, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -END PROCEDURE SymGetLU_2 - -!---------------------------------------------------------------------------- -! GetLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLDL_1 -CHARACTER(1) :: luplo -INTEGER(I4B) :: linfo, n -INTEGER(I4B), ALLOCATABLE :: work(:, :) -! -! work(1:n, 1) = ipiv(:) from sytrf -! work(1:n, 2) = swap_(:) block diagonal information -! work(1:n, 3) = pivots(:) cleaned version of ipiv -! work(1:n, 4) = perm cleaned version of ipiv -! -n = SIZE(A, 1) -ALLOCATE (work(n, 4)) -luplo = INPUT(option=UPLO, default="U") -LU = 0.0_DFP -! -! Copy data in LU from A -! -CALL LACPY(A=A, B=LU, UPLO=luplo) -! -! Call SYTRF -! -CALL SYTRF(A=LU, UPLO=luplo, IPIV=work(:, 1), INFO=linfo) -! -! Clean the ipiv0 returned by SYTRF -! -CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & - & swap_=work(:, 2), pivots=work(:, 3), info=linfo) -! -CALL LDL_GET_D_and_L(D=D, E=E, ldu=lu, & - & pivs=work(:, 3), uplo=luplo) -! -CALL LDL_CONSTRUCT_TRI_FACTOR(lu=lu, swap_=work(:, 2), & - & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) -! -IF (PRESENT(info)) info = linfo -IF (PRESENT(IPIV)) IPIV = work(:, 4) -DEALLOCATE (work) -END PROCEDURE SymGetLDL_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: -! -!# Introduction -! -! This helper function takes the rather strangely encoded permutation array -! returned by the LAPACK routines ?(HE/SY)TRF and converts it into -! regularized permutation and diagonal pivot size format. -! Since FORTRAN uses 1-indexing and LAPACK uses different start points for -! upper and lower formats there are certain offsets in the indices used -! below. -! Let's assume a result where the matrix is 6x6 and there are two 2x2 -! and two 1x1 blocks reported by the routine. To ease the coding efforts, -! we still populate a 6-sized array and fill zeros as the following :: -! pivots = [2, 0, 2, 0, 1, 1] -! This denotes a diagonal matrix of the form :: -! [x x ] -! [x x ] -! [ x x ] -! [ x x ] -! [ x ] -! [ x] -! In other words, we write 2 when the 2x2 block is first encountered and -! automatically write 0 to the next entry and skip the next spin of the -! loop. Thus, a separate counter or array appends to keep track of block -! sizes are avoided. If needed, zeros can be filtered out later without -! losing the block structure. -! Parameters -! ---------- -! a : ndarray -! The permutation array ipiv returned by LAPACK -! lower : bool, optional -! The switch to select whether upper or lower triangle is chosen in -! the LAPACK call. -! Returns -! ------- -! swap_ : ndarray -! The array that defines the row/column swap operations. For example, -! if row two is swapped with row four, the result is [0, 3, 2, 3]. -! pivots : ndarray -! The array that defines the block diagonal structure as given above. - -SUBROUTINE LDL_SENITIZE_IPIV(ipiv0, uplo, swap_, pivots, info) - INTEGER(I4B), INTENT(IN) :: ipiv0(:) - CHARACTER(1), INTENT(IN) :: uplo - INTEGER(I4B), INTENT(INOUT) :: swap_(:) - INTEGER(I4B), INTENT(INOUT) :: pivots(:) - INTEGER(I4B), INTENT(OUT) :: info - ! - ! internal variables - ! - INTEGER(I4B) :: n, ind, x, y, rs, re, ri, cur_val - LOGICAL(LGT) :: skip2x2 - ! - info = 0 - n = SIZE(ipiv0) - ! - IF (uplo .EQ. "L") THEN - x = 1 - y = 0 - rs = 1 - re = n - ri = 1 - ELSE - x = -1 - y = -1 - rs = n - re = 1 - ri = -1 - END IF - ! - skip2x2 = .FALSE. - swap_ = arange(1_I4B, n) - pivots = zeros(n, 1_I4B) - ! - DO ind = rs, re, ri - IF (skip2x2) skip2x2 = .FALSE. - cur_val = ipiv0(ind) - ! - IF (cur_val .GT. 0) THEN - IF (cur_val .NE. ind) THEN - swap_(ind) = swap_(cur_val) - END IF - pivots(ind) = 1 - ! - ELSEIF (cur_val < 0 .AND. cur_val == ipiv0(ind + x)) THEN - ! - IF (-cur_val .NE. ind + 1) THEN - swap_(ind + x) = swap_(-cur_val) - END IF - ! - pivots(ind + y) = 2 - skip2x2 = .TRUE. - ! - END IF - END DO - -END SUBROUTINE LDL_SENITIZE_IPIV - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: -! -!# Introduction -! -! Helper function to extract the diagonal and triangular matrices for -! LDL.T factorization. -! -!## Parameters -! -! ldu : ndarray -! The compact output returned by the LAPACK routing -! -! pivs : ndarray -! The sanitized array of {0, 1, 2} denoting the sizes of the pivots. For -! every 2 there is a succeeding 0. -! -! lower : bool, optional -! If set to False, upper triangular part is considered. -! -! hermitian : bool, optional -! If set to False a symmetric complex array is assumed. -! -!## Returns -! -! d : ndarray -! The block diagonal matrix. -! -! lu : ndarray -! The upper/lower triangular matrix - -SUBROUTINE LDL_GET_D_and_L(D, E, ldu, pivs, uplo) - REAL(DFP), INTENT(INOUT) :: D(:) - REAL(DFP), INTENT(INOUT) :: E(:) - REAL(DFP), INTENT(INOUT) :: ldu(:, :) - INTEGER(I4B), INTENT(IN) :: pivs(:) - CHARACTER(1), INTENT(IN) :: uplo - ! - ! internal variables - ! - INTEGER(I4B) :: x, y, ii, n, blk_i, inc - ! - ! extract D from LDU - ! - n = SIZE(ldu, 1) - ! - DO CONCURRENT(ii=1:n) - D(ii) = ldu(ii, ii) - E(ii) = 0.0_DFP - ldu(ii, ii) = 1.0_DFP - END DO - ! - blk_i = 1 - ! - IF (uplo .EQ. "L") THEN - x = 1 - y = 0 - !! - DO ii = 1, n - IF (pivs(ii) .EQ. 0) CYCLE - ! increment the block index and check for 2s - ! if 2 then copy the off diagonals depending on uplo - inc = blk_i + pivs(ii) - ! - IF (pivs(ii) .EQ. 2) THEN - E(blk_i) = ldu(blk_i + x, blk_i + y) - ldu(blk_i + x, blk_i + y) = 0.0 - END IF - ! - blk_i = inc - ! - END DO - !! - ELSE - y = 1 - x = 0 - !! - DO ii = 1, n - IF (pivs(ii) .EQ. 0) CYCLE - ! increment the block index and check for 2s - ! if 2 then copy the off diagonals depending on uplo - inc = blk_i + pivs(ii) - ! - IF (pivs(ii) .EQ. 2) THEN - E(blk_i) = ldu(blk_i + x, blk_i + y) - ldu(blk_i + x, blk_i + y) = 0.0 - END IF - ! - blk_i = inc - ! - END DO - END IF - ! -END SUBROUTINE LDL_GET_D_and_L - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-22 -! summary: Helper -! -!# Introduction -! -! Helper function to construct explicit outer factors of LDL factorization. -! If lower is True the permuted factors are multiplied as L(1)*L(2)*...*L(k). -! Otherwise, the permuted factors are multiplied as L(k)*...*L(2)*L(1). See -! LAPACK documentation for more details. -! -!### Parameters -! lu : ndarray -! The triangular array that is extracted from LAPACK routine call with -! ones on the diagonals. -! swap_ : ndarray -! The array that defines the row swapping indices. If the kth entry is m -! then rows k,m are swapped. Notice that the mth entry is not necessarily -! k to avoid undoing the swapping. -! pivots : ndarray -! The array that defines the block diagonal structure returned by -! _ldl_sanitize_ipiv(). -! lower : bool, optional -! The boolean to switch between lower and upper triangular structure. -! -!### Returns -!lu : ndarray -!The square outer factor which satisfies the L * D * L.T = A -!perm : ndarray -!The permutation vector that brings the lu to the triangular form -! -!@note -!Note that the original argument "lu" is overwritten. -!@endnote - -SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR(lu, swap_, pivots, perm, permTemp, uplo) - REAL(DFP), INTENT(INOUT) :: lu(:, :) - INTEGER(I4B), INTENT(IN) :: swap_(:) - INTEGER(I4B), INTENT(IN) :: pivots(:) - INTEGER(I4B), INTENT(INOUT) :: perm(:) - INTEGER(I4B), INTENT(INOUT) :: permTemp(:) - CHARACTER(1), INTENT(IN) :: uplo - ! - ! internal variables - ! - INTEGER(I4B) :: n, rs, re, ri, ind, s_ind, col_s, col_e, zero_or_two, & - & incr_col_s, incr_col_e - LOGICAL(LGT) :: islower - ! - ! main program - ! - n = SIZE(lu, 1) - permTemp = arange(1_I4B, n, 1_I4B) - ! - IF (uplo .EQ. "L") THEN - rs = n - re = 1 - ri = -1 - islower = .TRUE. - zero_or_two = 0 - incr_col_s = -1 - incr_col_e = 0 - ELSE - rs = 1 - re = n - ri = 1 - islower = .FALSE. - zero_or_two = 2 - incr_col_s = 0 - incr_col_e = 1 - END IF - ! - DO ind = rs, re, ri - s_ind = swap_(ind) - ! - IF (s_ind .NE. ind) THEN - ! Column start and end positions - IF (islower) THEN - col_s = ind - col_e = n - ELSE - col_s = 1 - col_e = ind - END IF - ! - ! If we stumble upon a 2x2 block include both cols in the permTemp. - ! - IF (pivots(ind) .EQ. zero_or_two) THEN - col_s = col_s + incr_col_s - col_e = col_e + incr_col_e - END IF - ! - lu([s_ind, ind], col_s:col_e) = lu([ind, s_ind], col_s:col_e) - permTemp([s_ind, ind]) = permTemp([ind, s_ind]) - ! - END IF - END DO - !! - perm = ArgSort(permTemp) - !! -END SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR - -!---------------------------------------------------------------------------- -! getLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLDL_2 -CHARACTER(1) :: luplo -INTEGER(I4B) :: linfo, n -INTEGER(I4B), ALLOCATABLE :: work(:, :) -! -! work(1:n, 1) = ipiv(:) from sytrf -! work(1:n, 2) = swap_(:) block diagonal information -! work(1:n, 3) = pivots(:) cleaned version of ipiv -! work(1:n, 4) = perm cleaned version of ipiv -! -n = SIZE(A, 1) -ALLOCATE (work(n, 4)) -luplo = INPUT(option=UPLO, default="U") -! -! Call SYTRF -! -CALL SYTRF(A=A, UPLO=luplo, IPIV=work(:, 1), INFO=info) -! -! Clean the ipiv0 returned by SYTRF -! -CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & - & swap_=work(:, 2), pivots=work(:, 3), info=linfo) -! -CALL LDL_GET_D_and_L(D=D, E=E, ldu=A, & - & pivs=work(:, 3), uplo=luplo) -! -CALL LDL_CONSTRUCT_TRI_FACTOR(lu=A, swap_=work(:, 2), & - & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) -! -IF (PRESENT(info)) info = linfo -IF (PRESENT(IPIV)) IPIV = work(:, 4) -DEALLOCATE (work) -END PROCEDURE SymGetLDL_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetCholesky_1 -! -! Make a copy of LU -! -CALL LACPY(A=A, B=LU, UPLO=uplo) -CALL POTRF(A=LU, uplo=uplo, info=info) -! -END PROCEDURE SymGetCholesky_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetCholesky_2 -CALL POTRF(A=A, uplo=uplo, info=info) -END PROCEDURE SymGetCholesky_2 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_1 -CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_1 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_2 -CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_2 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_3 -X = B -CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_3 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_4 -X = B -CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_4 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetInv_1 -CALL LACPY(A=A, B=invA, UPLO=UPLO) -CALL SYTRI(A=invA, IPIV=IPIV, UPLO=UPLO, info=INFO) -END PROCEDURE SymGetInv_1 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetInv_2 -CALL SYTRI(A=A, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymGetInv_2 - -END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 b/src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 deleted file mode 100644 index d8fd80be9..000000000 --- a/src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 +++ /dev/null @@ -1,506 +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(Sym_Lapack_Method) LUMethods -USE BaseMethod, ONLY: Display, Input, Arange, Zeros, GetTril, & -& GetTriu, ArgSort, tostring -USE F95_LAPACK, ONLY: SYTRF, LACPY, LAPMR, POTRF, SYTRS, SYTRI -USE F77_LAPACK, ONLY: SYCONV => LA_SYCONV -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLU_1 -CALL LACPY(A=A, B=LU, UPLO=UPLO) -CALL SYTRF(A=LU, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -END PROCEDURE SymGetLU_1 - -!---------------------------------------------------------------------------- -! GetLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLU_2 -CALL SYTRF(A=A, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -END PROCEDURE SymGetLU_2 - -!---------------------------------------------------------------------------- -! GetLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLDL_1 -CHARACTER(LEN=1) :: luplo -INTEGER(I4B) :: linfo, n -INTEGER(I4B), ALLOCATABLE :: work(:, :) -! -! work(1:n, 1) = ipiv(:) from sytrf -! work(1:n, 2) = swap_(:) block diagonal information -! work(1:n, 3) = pivots(:) cleaned version of ipiv -! work(1:n, 4) = perm cleaned version of ipiv -! -n = SIZE(A, 1) -ALLOCATE (work(n, 4)) -luplo = INPUT(option=UPLO, default="U") -LU = 0.0_DFP -! -! Copy data in LU from A -! -CALL LACPY(A=A, B=LU, UPLO=luplo) -! -! Call SYTRF -! -CALL SYTRF(A=LU, UPLO=luplo, IPIV=work(:, 1), INFO=linfo) -! -! Clean the ipiv0 returned by SYTRF -! -CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & - & swap_=work(:, 2), pivots=work(:, 3), info=linfo) -! -CALL LDL_GET_D_and_L(D=D, E=E, ldu=lu, & - & pivs=work(:, 3), uplo=luplo) -! -CALL LDL_CONSTRUCT_TRI_FACTOR(lu=lu, swap_=work(:, 2), & - & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) -! -IF (PRESENT(info)) info = linfo -IF (PRESENT(IPIV)) IPIV = work(:, 4) -DEALLOCATE (work) -END PROCEDURE SymGetLDL_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: -! -!# Introduction -! -! This helper function takes the rather strangely encoded permutation array -! returned by the LAPACK routines ?(HE/SY)TRF and converts it into -! regularized permutation and diagonal pivot size format. -! Since FORTRAN uses 1-indexing and LAPACK uses different start points for -! upper and lower formats there are certain offsets in the indices used -! below. -! Let's assume a result where the matrix is 6x6 and there are two 2x2 -! and two 1x1 blocks reported by the routine. To ease the coding efforts, -! we still populate a 6-sized array and fill zeros as the following :: -! pivots = [2, 0, 2, 0, 1, 1] -! This denotes a diagonal matrix of the form :: -! [x x ] -! [x x ] -! [ x x ] -! [ x x ] -! [ x ] -! [ x] -! In other words, we write 2 when the 2x2 block is first encountered and -! automatically write 0 to the next entry and skip the next spin of the -! loop. Thus, a separate counter or array appends to keep track of block -! sizes are avoided. If needed, zeros can be filtered out later without -! losing the block structure. -! Parameters -! ---------- -! a : ndarray -! The permutation array ipiv returned by LAPACK -! lower : bool, optional -! The switch to select whether upper or lower triangle is chosen in -! the LAPACK call. -! Returns -! ------- -! swap_ : ndarray -! The array that defines the row/column swap operations. For example, -! if row two is swapped with row four, the result is [0, 3, 2, 3]. -! pivots : ndarray -! The array that defines the block diagonal structure as given above. - -SUBROUTINE LDL_SENITIZE_IPIV(ipiv0, uplo, swap_, pivots, info) - INTEGER(I4B), INTENT(IN) :: ipiv0(:) - CHARACTER(LEN=1), INTENT(IN) :: uplo - INTEGER(I4B), INTENT(INOUT) :: swap_(:) - INTEGER(I4B), INTENT(INOUT) :: pivots(:) - INTEGER(I4B), INTENT(OUT) :: info - ! - ! internal variables - ! - INTEGER(I4B) :: n, ind, x, y, rs, re, ri, cur_val - LOGICAL(LGT) :: skip2x2 - ! - info = 0 - n = SIZE(ipiv0) - ! - IF (uplo .EQ. "L") THEN - x = 1 - y = 0 - rs = 1 - re = n - ri = 1 - ELSE - x = -1 - y = -1 - rs = n - re = 1 - ri = -1 - END IF - ! - skip2x2 = .FALSE. - swap_ = arange(1_I4B, n) - pivots = zeros(n, 1_I4B) - ! - DO ind = rs, re, ri - IF (skip2x2) skip2x2 = .FALSE. - cur_val = ipiv0(ind) - ! - IF (cur_val .GT. 0) THEN - IF (cur_val .NE. ind) THEN - swap_(ind) = swap_(cur_val) - END IF - pivots(ind) = 1 - ! - ELSEIF (cur_val < 0 .AND. cur_val == ipiv0(ind + x)) THEN - ! - IF (-cur_val .NE. ind + 1) THEN - swap_(ind + x) = swap_(-cur_val) - END IF - ! - pivots(ind + y) = 2 - skip2x2 = .TRUE. - ! - END IF - END DO - -END SUBROUTINE LDL_SENITIZE_IPIV - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-21 -! summary: -! -!# Introduction -! -! Helper function to extract the diagonal and triangular matrices for -! LDL.T factorization. -! -!## Parameters -! -! ldu : ndarray -! The compact output returned by the LAPACK routing -! -! pivs : ndarray -! The sanitized array of {0, 1, 2} denoting the sizes of the pivots. For -! every 2 there is a succeeding 0. -! -! lower : bool, optional -! If set to False, upper triangular part is considered. -! -! hermitian : bool, optional -! If set to False a symmetric complex array is assumed. -! -!## Returns -! -! d : ndarray -! The block diagonal matrix. -! -! lu : ndarray -! The upper/lower triangular matrix - -SUBROUTINE LDL_GET_D_and_L(D, E, ldu, pivs, uplo) - REAL(DFP), INTENT(INOUT) :: D(:) - REAL(DFP), INTENT(INOUT) :: E(:) - REAL(DFP), INTENT(INOUT) :: ldu(:, :) - INTEGER(I4B), INTENT(IN) :: pivs(:) - CHARACTER(LEN=1), INTENT(IN) :: uplo - ! - ! internal variables - ! - INTEGER(I4B) :: x, y, ii, n, blk_i, inc - ! - ! extract D from LDU - ! - n = SIZE(ldu, 1) - ! - DO CONCURRENT(ii=1:n) - D(ii) = ldu(ii, ii) - E(ii) = 0.0_DFP - ldu(ii, ii) = 1.0_DFP - END DO - ! - blk_i = 1 - ! - IF (uplo .EQ. "L") THEN - x = 1 - y = 0 - !! - DO ii = 1, n - IF (pivs(ii) .EQ. 0) CYCLE - ! increment the block index and check for 2s - ! if 2 then copy the off diagonals depending on uplo - inc = blk_i + pivs(ii) - ! - IF (pivs(ii) .EQ. 2) THEN - E(blk_i) = ldu(blk_i + x, blk_i + y) - ldu(blk_i + x, blk_i + y) = 0.0 - END IF - ! - blk_i = inc - ! - END DO - !! - ELSE - y = 1 - x = 0 - !! - DO ii = 1, n - IF (pivs(ii) .EQ. 0) CYCLE - ! increment the block index and check for 2s - ! if 2 then copy the off diagonals depending on uplo - inc = blk_i + pivs(ii) - ! - IF (pivs(ii) .EQ. 2) THEN - E(blk_i) = ldu(blk_i + x, blk_i + y) - ldu(blk_i + x, blk_i + y) = 0.0 - END IF - ! - blk_i = inc - ! - END DO - END IF - ! -END SUBROUTINE LDL_GET_D_and_L - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2022-12-22 -! summary: Helper -! -!# Introduction -! -! Helper function to construct explicit outer factors of LDL factorization. -! If lower is True the permuted factors are multiplied as L(1)*L(2)*...*L(k). -! Otherwise, the permuted factors are multiplied as L(k)*...*L(2)*L(1). See -! LAPACK documentation for more details. -! -!### Parameters -! lu : ndarray -! The triangular array that is extracted from LAPACK routine call with -! ones on the diagonals. -! swap_ : ndarray -! The array that defines the row swapping indices. If the kth entry is m -! then rows k,m are swapped. Notice that the mth entry is not necessarily -! k to avoid undoing the swapping. -! pivots : ndarray -! The array that defines the block diagonal structure returned by -! _ldl_sanitize_ipiv(). -! lower : bool, optional -! The boolean to switch between lower and upper triangular structure. -! -!### Returns -!lu : ndarray -!The square outer factor which satisfies the L * D * L.T = A -!perm : ndarray -!The permutation vector that brings the lu to the triangular form -! -!@note -!Note that the original argument "lu" is overwritten. -!@endnote - -SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR(lu, swap_, pivots, perm, permTemp, uplo) - REAL(DFP), INTENT(INOUT) :: lu(:, :) - INTEGER(I4B), INTENT(IN) :: swap_(:) - INTEGER(I4B), INTENT(IN) :: pivots(:) - INTEGER(I4B), INTENT(INOUT) :: perm(:) - INTEGER(I4B), INTENT(INOUT) :: permTemp(:) - CHARACTER(LEN=1), INTENT(IN) :: uplo - ! - ! internal variables - ! - INTEGER(I4B) :: n, rs, re, ri, ind, s_ind, col_s, col_e, zero_or_two, & - & incr_col_s, incr_col_e - LOGICAL(LGT) :: islower - ! - ! main program - ! - n = SIZE(lu, 1) - permTemp = arange(1_I4B, n, 1_I4B) - ! - IF (uplo .EQ. "L") THEN - rs = n - re = 1 - ri = -1 - islower = .TRUE. - zero_or_two = 0 - incr_col_s = -1 - incr_col_e = 0 - ELSE - rs = 1 - re = n - ri = 1 - islower = .FALSE. - zero_or_two = 2 - incr_col_s = 0 - incr_col_e = 1 - END IF - ! - DO ind = rs, re, ri - s_ind = swap_(ind) - ! - IF (s_ind .NE. ind) THEN - ! Column start and end positions - IF (islower) THEN - col_s = ind - col_e = n - ELSE - col_s = 1 - col_e = ind - END IF - ! - ! If we stumble upon a 2x2 block include both cols in the permTemp. - ! - IF (pivots(ind) .EQ. zero_or_two) THEN - col_s = col_s + incr_col_s - col_e = col_e + incr_col_e - END IF - ! - lu([s_ind, ind], col_s:col_e) = lu([ind, s_ind], col_s:col_e) - permTemp([s_ind, ind]) = permTemp([ind, s_ind]) - ! - END IF - END DO - !! - perm = ArgSort(permTemp) - !! -END SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR - -!---------------------------------------------------------------------------- -! getLU -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetLDL_2 -CHARACTER(LEN=1) :: luplo -INTEGER(I4B) :: linfo, n -INTEGER(I4B), ALLOCATABLE :: work(:, :) -! -! work(1:n, 1) = ipiv(:) from sytrf -! work(1:n, 2) = swap_(:) block diagonal information -! work(1:n, 3) = pivots(:) cleaned version of ipiv -! work(1:n, 4) = perm cleaned version of ipiv -! -n = SIZE(A, 1) -ALLOCATE (work(n, 4)) -luplo = INPUT(option=UPLO, default="U") -! -! Call SYTRF -! -CALL SYTRF(A=A, UPLO=luplo, IPIV=work(:, 1), INFO=info) -! -! Clean the ipiv0 returned by SYTRF -! -CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & - & swap_=work(:, 2), pivots=work(:, 3), info=linfo) -! -CALL LDL_GET_D_and_L(D=D, E=E, ldu=A, & - & pivs=work(:, 3), uplo=luplo) -! -CALL LDL_CONSTRUCT_TRI_FACTOR(lu=A, swap_=work(:, 2), & - & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) -! -IF (PRESENT(info)) info = linfo -IF (PRESENT(IPIV)) IPIV = work(:, 4) -DEALLOCATE (work) -END PROCEDURE SymGetLDL_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetCholesky_1 -! -! Make a copy of LU -! -CALL LACPY(A=A, B=LU, UPLO=uplo) -CALL POTRF(A=LU, uplo=uplo, info=info) -! -END PROCEDURE SymGetCholesky_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetCholesky_2 -CALL POTRF(A=A, uplo=uplo, info=info) -END PROCEDURE SymGetCholesky_2 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_1 -CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_1 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_2 -CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_2 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_3 -X = B -CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_3 - -!---------------------------------------------------------------------------- -! SymLUSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLUSolve_4 -X = B -CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymLUSolve_4 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetInv_1 -CALL LACPY(A=A, B=invA, UPLO=UPLO) -CALL SYTRI(A=invA, IPIV=IPIV, UPLO=UPLO, info=INFO) -END PROCEDURE SymGetInv_1 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymGetInv_2 -CALL SYTRI(A=A, IPIV=IPIV, UPLO=UPLO, INFO=INFO) -END PROCEDURE SymGetInv_2 - -END SUBMODULE LUMethods diff --git a/src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 b/src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 deleted file mode 100644 index a3ccd81b1..000000000 --- a/src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 +++ /dev/null @@ -1,215 +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(Sym_Lapack_Method) LinearSolveMethods -USE String_Class -USE BaseMethod, ONLY: UpperCase, ErrorMsg -USE F95_LAPACK, ONLY: LACPY, SYSV -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_1 -REAL(DFP), ALLOCATABLE :: LocalA(:, :) -INTEGER(I4B) :: n -TYPE(String) :: LSolveName -!! -n = SIZE(A, 1) -ALLOCATE (LocalA(n, n)) -!! -CALL LACPY(A=A, B=LocalA, UPLO=UPLO) -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_1", & - & unitno=stderr) - DEALLOCATE (LocalA) - STOP -END SELECT -DEALLOCATE (LocalA) -END PROCEDURE SymLinSolve_1 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_2 -REAL(DFP), ALLOCATABLE :: LocalA(:, :) -INTEGER(I4B) :: n -TYPE(String) :: LSolveName -!! -n = SIZE(A, 1) -ALLOCATE (LocalA(n, n)) -!! -CALL LACPY(A=A, B=LocalA, UPLO=UPLO) -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_2", & - & unitno=stderr) - DEALLOCATE (LocalA) - STOP -END SELECT - -DEALLOCATE (LocalA) -END PROCEDURE SymLinSolve_2 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_3 -TYPE(String) :: LSolveName -!! -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_3", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_3 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_4 -TYPE(String) :: LSolveName -!! -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_4", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_4 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_5 -TYPE(String) :: LSolveName -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_5", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_5 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_6 -TYPE(String) :: LSolveName -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_6", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE LinearSolveMethods diff --git a/src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 deleted file mode 100644 index e983557d0..000000000 --- a/src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 +++ /dev/null @@ -1,216 +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(Sym_LinearSolveMethods) Methods -USE GlobalData, ONLY: DFP, I4B, LGT, stdout, stderr -USE String_Class -USE BaseMethod, ONLY: UpperCase, ErrorMsg -USE F95_LAPACK, ONLY: LACPY, SYSV -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_1 -REAL(DFP), ALLOCATABLE :: LocalA(:, :) -INTEGER(I4B) :: n -TYPE(String) :: LSolveName -!! -n = SIZE(A, 1) -ALLOCATE (LocalA(n, n)) -!! -CALL LACPY(A=A, B=LocalA, UPLO=UPLO) -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_1", & - & unitno=stderr) - DEALLOCATE (LocalA) - STOP -END SELECT -DEALLOCATE (LocalA) -END PROCEDURE SymLinSolve_1 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_2 -REAL(DFP), ALLOCATABLE :: LocalA(:, :) -INTEGER(I4B) :: n -TYPE(String) :: LSolveName -!! -n = SIZE(A, 1) -ALLOCATE (LocalA(n, n)) -!! -CALL LACPY(A=A, B=LocalA, UPLO=UPLO) -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_2", & - & unitno=stderr) - DEALLOCATE (LocalA) - STOP -END SELECT - -DEALLOCATE (LocalA) -END PROCEDURE SymLinSolve_2 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_3 -TYPE(String) :: LSolveName -!! -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_3", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_3 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_4 -TYPE(String) :: LSolveName -!! -X = B -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_4", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_4 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_5 -TYPE(String) :: LSolveName -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_5", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_5 - -!---------------------------------------------------------------------------- -! SymSolve -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymLinSolve_6 -TYPE(String) :: LSolveName -!! -IF (PRESENT(SolverName)) THEN - LSolveName = UpperCase(SolverName) -ELSE - LSolveName = "SYSV" -END IF -!! -SELECT CASE (LSolveName%chars()) -CASE ("SYSV") - CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) -CASE DEFAULT - CALL ErrorMsg( & - & msg="NO CASE FOUND FOR "//LSolveName%chars(), & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymLinSolve_6", & - & unitno=stderr) - STOP -END SELECT -END PROCEDURE SymLinSolve_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 deleted file mode 100644 index 63b7886bf..000000000 --- a/src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 +++ /dev/null @@ -1,16 +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 -! diff --git a/src/submodules/MassMatrix/CMakeLists.txt b/src/submodules/MassMatrix/CMakeLists.txt deleted file mode 100644 index 70e3b6181..000000000 --- a/src/submodules/MassMatrix/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/MassMatrix_Method@Methods.F90 - ) diff --git a/src/submodules/MassMatrix/src/MM_1.inc b/src/submodules/MassMatrix/src/MM_1.inc deleted file mode 100644 index aee971caa..000000000 --- a/src/submodules/MassMatrix/src/MM_1.inc +++ /dev/null @@ -1,52 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_1(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips - !! - !! main - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - CALL getInterpolation(obj=trial, interpol=realval, val=rho) - realval = trial%js * trial%ws * trial%thickness * realval - !! - DO ips = 1, size(realval) - ans = ans + realval(ips) * & - & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - END DO - !! - if( present( opt ) ) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (realval) -END SUBROUTINE MM_1 diff --git a/src/submodules/MassMatrix/src/MM_2a.inc b/src/submodules/MassMatrix/src/MM_2a.inc deleted file mode 100644 index 0c31616c7..000000000 --- a/src/submodules/MassMatrix/src/MM_2a.inc +++ /dev/null @@ -1,58 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2a(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1 - !! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, ips - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, 1) = m4(:, :, ii, 1) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - !! - CALL Convert(From=m4, To=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2a diff --git a/src/submodules/MassMatrix/src/MM_2b.inc b/src/submodules/MassMatrix/src/MM_2b.inc deleted file mode 100644 index 3cbcb268e..000000000 --- a/src/submodules/MassMatrix/src/MM_2b.inc +++ /dev/null @@ -1,61 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2b(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! 2 - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, ips - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, 1, ii) = m4(:, :, 1, ii) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - !! - CALL Convert(From=m4, To=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2b diff --git a/src/submodules/MassMatrix/src/MM_2c.inc b/src/submodules/MassMatrix/src/MM_2c.inc deleted file mode 100644 index edc9450fa..000000000 --- a/src/submodules/MassMatrix/src/MM_2c.inc +++ /dev/null @@ -1,59 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2c(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! 3 - !! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ips, ii - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(vbar, 1), SIZE(vbar, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(vbar, 2) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, ii) = m4(:, :, ii, ii) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - !! - CALL Convert(from=m4, to=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2c diff --git a/src/submodules/MassMatrix/src/MM_2d.inc b/src/submodules/MassMatrix/src/MM_2d.inc deleted file mode 100644 index 00474ec01..000000000 --- a/src/submodules/MassMatrix/src/MM_2d.inc +++ /dev/null @@ -1,61 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2d(ans, test, trial, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - !! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ips, ii, jj - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(vbar, 1), SIZE(vbar, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(vbar, 2) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO jj = 1, SIZE(vbar, 1) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, jj) = m4(:, :, ii, jj) & - & + realval(ips) * vbar(ii, ips) & - & * vbar(jj, ips) * m2 - END DO - END DO - END DO - !! - CALL Convert(from=m4, to=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2d diff --git a/src/submodules/MassMatrix/src/MM_3.inc b/src/submodules/MassMatrix/src/MM_3.inc deleted file mode 100644 index b72f07d7f..000000000 --- a/src/submodules/MassMatrix/src/MM_3.inc +++ /dev/null @@ -1,62 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_3(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! 4 - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, jj, ips - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO jj = 1, SIZE(kbar, 2) - DO ii = 1, SIZE(kbar, 1) - m4(:, :, ii, jj) = m4(:, :, ii, jj) & - & + realval(ips) * kbar(ii, jj, ips) * m2 - END DO - END DO - END DO - !! - CALL Convert(From=m4, To=ans) - !! - DEALLOCATE (realval, m2, kbar, m4) -END SUBROUTINE MM_3 diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 deleted file mode 100644 index 880619fef..000000000 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ /dev/null @@ -1,326 +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(MassMatrix_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2a(ans, test, trial, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - ! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - ! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - ! vector variable - ! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, ips - - ! main - CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) - CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1) - realval = trial%js * trial%ws * trial%thickness - - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, 1) = m4(:, :, ii, 1) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - - CALL Convert(From=m4, To=ans) - DEALLOCATE (realval, m2, vbar, m4) -END SUBROUTINE MM_2a - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2b(ans, test, trial, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - ! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - ! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - ! vector variable - - ! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, ips - - ! main - CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) - CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1)) - realval = trial%js * trial%ws * trial%thickness - - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, 1, ii) = m4(:, :, 1, ii) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - - 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, interpol=vbar, val=rho) - CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(vbar, 1), SIZE(vbar, 1)) - - realval = trial%js * trial%ws * trial%thickness - - DO ips = 1, SIZE(vbar, 2) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, ii) = m4(:, :, ii, ii) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - - CALL Convert(from=m4, to=ans) - - DEALLOCATE (realval, m2, vbar, m4) -END SUBROUTINE MM_2c - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2d(ans, test, trial, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - ! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - ! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - ! vector variable - ! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ips, ii, jj - - ! main - CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) - CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(vbar, 1), SIZE(vbar, 1)) - - realval = trial%js * trial%ws * trial%thickness - - DO ips = 1, SIZE(vbar, 2) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO jj = 1, SIZE(vbar, 1) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, jj) = m4(:, :, ii, jj) & - & + realval(ips) * vbar(ii, ips) & - & * vbar(jj, ips) * m2 - END DO - END DO - END DO - - CALL Convert(from=m4, to=ans) - - DEALLOCATE (realval, m2, vbar, m4) -END SUBROUTINE MM_2d - -!---------------------------------------------------------------------------- -! 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) -END PROCEDURE MassMatrix_1 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -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, interpol=realval, val=rho) -realval = trial%js * trial%ws * trial%thickness * realval - -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * & - & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) -END DO - -IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) -DEALLOCATE (realval) -END PROCEDURE MassMatrix_2 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MassMatrix_3 -SELECT CASE (opt) -CASE (1) - CALL MM_2a(ans=ans, test=test, trial=trial, rho=rho) -CASE (2) - CALL MM_2b(ans=ans, test=test, trial=trial, rho=rho) -CASE (3) - CALL MM_2c(ans=ans, test=test, trial=trial, rho=rho) -CASE (4) - CALL MM_2d(ans=ans, test=test, trial=trial, rho=rho) -END SELECT -END PROCEDURE MassMatrix_3 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MassMatrix_4 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: m2(:, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :) -REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) -INTEGER(I4B) :: ii, jj, ips - -! main -CALL GetInterpolation(obj=trial, interpol=kbar, val=rho) -CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2)) - -realval = trial%js * trial%ws * trial%thickness - -DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO jj = 1, SIZE(kbar, 2) - DO ii = 1, SIZE(kbar, 1) - m4(:, :, ii, jj) = m4(:, :, ii, jj) & - & + realval(ips) * kbar(ii, jj, ips) * m2 - END DO - END DO -END DO - -CALL Convert(From=m4, To=ans) -DEALLOCATE (realval, m2, kbar, m4) -END PROCEDURE MassMatrix_4 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MassMatrix_5 -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 - -! 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) - -ALLOCATE (acoeff(SIZE(lambdaBar, 1)), bcoeff(SIZE(lambdaBar, 1))) - -bcoeff = SQRT(rhoBar * muBar) -acoeff = SQRT(rhoBar * (lambdaBar + 2.0_DFP * muBar)) - bcoeff - -nsd = trial%refelem%nsd -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 MassMatrix_5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/MdEncode/CMakeLists.txt b/src/submodules/MdEncode/CMakeLists.txt deleted file mode 100644 index 97f3c2040..000000000 --- a/src/submodules/MdEncode/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/MdEncode_Method@Methods.F90 -) diff --git a/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 b/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 deleted file mode 100644 index ce52c7ad1..000000000 --- a/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 +++ /dev/null @@ -1,403 +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(MdEncode_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! MdEncode_Method@Methods -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MdEncode_Int8 -ans = Tostring(val) -END PROCEDURE MdEncode_Int8 - -MODULE PROCEDURE MdEncode_Int16 -ans = Tostring(val) -END PROCEDURE MdEncode_Int16 - -MODULE PROCEDURE MdEncode_Int32 -ans = Tostring(val) -END PROCEDURE MdEncode_Int32 - -MODULE PROCEDURE MdEncode_Int64 -ans = Tostring(val) -END PROCEDURE MdEncode_Int64 - -MODULE PROCEDURE MdEncode_Real32 -ans = Tostring(val) -END PROCEDURE MdEncode_Real32 - -MODULE PROCEDURE MdEncode_Real64 -ans = Tostring(val) -END PROCEDURE MdEncode_Real64 - -MODULE PROCEDURE MdEncode_Char -ans = TRIM(val) -END PROCEDURE MdEncode_Char - -MODULE PROCEDURE MdEncode_String -ans = val%chars() -END PROCEDURE MdEncode_String - -!---------------------------------------------------------------------------- -! MdEncode_Method@Methods -!---------------------------------------------------------------------------- - -! MODULE PROCEDURE MdEncode_2 -! INTEGER(I4B) :: ii, n -! -! n = SIZE(val) -! ans = "| " -! DO ii = 1, n -! ans = ans//" | " -! END DO -! ans = ans//CHAR_LF -! -! ans = ans//"| " -! DO ii = 1, n -! ans = ans//" --- | " -! END DO -! ans = ans//CHAR_LF -! -! SELECT TYPE (val) -! TYPE IS (REAL(REAL32)) -! #include "./inc/MdEncode_2.inc" -! TYPE IS (REAL(REAL64)) -! #include "./inc/MdEncode_2.inc" -! TYPE IS (INTEGER(INT8)) -! #include "./inc/MdEncode_2.inc" -! TYPE IS (INTEGER(INT16)) -! #include "./inc/MdEncode_2.inc" -! TYPE IS (INTEGER(INT32)) -! #include "./inc/MdEncode_2.inc" -! TYPE IS (INTEGER(INT64)) -! #include "./inc/MdEncode_2.inc" -! TYPE IS (CHARACTER(LEN=*)) -! ans = ans//"| " -! DO ii = 1, n -! ans = ans//TRIM(val(ii))//" | " -! END DO -! ans = ans//CHAR_LF -! TYPE IS (String) -! ans = ans//"| " -! DO ii = 1, n -! ans = ans//TRIM(val(ii))//" | " -! END DO -! ans = ans//CHAR_LF -! END SELECT -! -! END PROCEDURE MdEncode_2 - -!---------------------------------------------------------------------------- -! MdEncode_Method@Methods -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MdEncode2_Int8 -#include "./inc/MdEncode_2.inc" -END PROCEDURE MdEncode2_Int8 - -MODULE PROCEDURE MdEncode2_Int16 -#include "./inc/MdEncode_2.inc" -END PROCEDURE MdEncode2_Int16 - -MODULE PROCEDURE MdEncode2_Int32 -#include "./inc/MdEncode_2.inc" -END PROCEDURE MdEncode2_Int32 - -MODULE PROCEDURE MdEncode2_Int64 -#include "./inc/MdEncode_2.inc" -END PROCEDURE MdEncode2_Int64 - -MODULE PROCEDURE MdEncode2_Real32 -#include "./inc/MdEncode_2.inc" -END PROCEDURE MdEncode2_Real32 - -MODULE PROCEDURE MdEncode2_Real64 -#include "./inc/MdEncode_2.inc" -END PROCEDURE MdEncode2_Real64 - -MODULE PROCEDURE MdEncode2_String -#include "./inc/MdEncode_2.inc" -END PROCEDURE MdEncode2_String - -!---------------------------------------------------------------------------- -! MdEncode_Method@Methods -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MdEncode3_Int8 -#include "./inc/MdEncode_3.inc" -END PROCEDURE MdEncode3_Int8 - -MODULE PROCEDURE MdEncode3_Int16 -#include "./inc/MdEncode_3.inc" -END PROCEDURE MdEncode3_Int16 - -MODULE PROCEDURE MdEncode3_Int32 -#include "./inc/MdEncode_3.inc" -END PROCEDURE MdEncode3_Int32 - -MODULE PROCEDURE MdEncode3_Int64 -#include "./inc/MdEncode_3.inc" -END PROCEDURE MdEncode3_Int64 - -MODULE PROCEDURE MdEncode3_Real32 -#include "./inc/MdEncode_3.inc" -END PROCEDURE MdEncode3_Real32 - -MODULE PROCEDURE MdEncode3_Real64 -#include "./inc/MdEncode_3.inc" -END PROCEDURE MdEncode3_Real64 - -MODULE PROCEDURE MdEncode3_String -#include "./inc/MdEncode_3.inc" -END PROCEDURE MdEncode3_String - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MdEncode4_Int8 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & - & //MdEncode(val(:, :, ii)) -END DO -END PROCEDURE MdEncode4_Int8 - -MODULE PROCEDURE MdEncode4_Int16 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & - & //MdEncode(val(:, :, ii)) -END DO -END PROCEDURE MdEncode4_Int16 - -MODULE PROCEDURE MdEncode4_Int32 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & - & //MdEncode(val(:, :, ii)) -END DO -END PROCEDURE MdEncode4_Int32 - -MODULE PROCEDURE MdEncode4_Int64 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & - & //MdEncode(val(:, :, ii)) -END DO -END PROCEDURE MdEncode4_Int64 - -MODULE PROCEDURE MdEncode4_Real32 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & - & //MdEncode(val(:, :, ii)) -END DO -END PROCEDURE MdEncode4_Real32 - -MODULE PROCEDURE MdEncode4_Real64 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & - & //MdEncode(val(:, :, ii)) -END DO -END PROCEDURE MdEncode4_Real64 - -MODULE PROCEDURE MdEncode4_String -INTEGER(I4B) :: ii -DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & - & //MdEncode(val(:, :, ii)) -END DO -END PROCEDURE MdEncode4_String - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MdEncode5_Int8 -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(val, 4) - DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & - & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) - END DO -END DO -END PROCEDURE MdEncode5_Int8 - -MODULE PROCEDURE MdEncode5_Int16 -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(val, 4) - DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & - & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) - END DO -END DO -END PROCEDURE MdEncode5_Int16 - -MODULE PROCEDURE MdEncode5_Int32 -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(val, 4) - DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & - & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) - END DO -END DO -END PROCEDURE MdEncode5_Int32 - -MODULE PROCEDURE MdEncode5_Int64 -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(val, 4) - DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & - & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) - END DO -END DO -END PROCEDURE MdEncode5_Int64 - -MODULE PROCEDURE MdEncode5_Real32 -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(val, 4) - DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & - & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) - END DO -END DO -END PROCEDURE MdEncode5_Real32 - -MODULE PROCEDURE MdEncode5_Real64 -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(val, 4) - DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & - & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) - END DO -END DO -END PROCEDURE MdEncode5_Real64 - -MODULE PROCEDURE MdEncode5_String -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(val, 4) - DO ii = 1, SIZE(val, 3) - ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & - & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) - END DO -END DO -END PROCEDURE MdEncode5_String - -!---------------------------------------------------------------------------- -! Mdencode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MdEncode6_Int8 -#include "./inc/MdEncode_6.inc" -END PROCEDURE MdEncode6_Int8 - -MODULE PROCEDURE MdEncode6_Int16 -#include "./inc/MdEncode_6.inc" -END PROCEDURE MdEncode6_Int16 - -MODULE PROCEDURE MdEncode6_Int32 -#include "./inc/MdEncode_6.inc" -END PROCEDURE MdEncode6_Int32 - -MODULE PROCEDURE MdEncode6_Int64 -#include "./inc/MdEncode_6.inc" -END PROCEDURE MdEncode6_Int64 - -MODULE PROCEDURE MdEncode6_Real32 -#include "./inc/MdEncode_6.inc" -END PROCEDURE MdEncode6_Real32 - -MODULE PROCEDURE MdEncode6_Real64 -#include "./inc/MdEncode_6.inc" -END PROCEDURE MdEncode6_Real64 - -MODULE PROCEDURE MdEncode6_String -#include "./inc/MdEncode_6.inc" -END PROCEDURE MdEncode6_String - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MdEncode7_Int8 -#include "./inc/MdEncode_7.inc" -END PROCEDURE MdEncode7_Int8 - -MODULE PROCEDURE MdEncode7_Int16 -#include "./inc/MdEncode_7.inc" -END PROCEDURE MdEncode7_Int16 - -MODULE PROCEDURE MdEncode7_Int32 -#include "./inc/MdEncode_7.inc" -END PROCEDURE MdEncode7_Int32 - -MODULE PROCEDURE MdEncode7_Int64 -#include "./inc/MdEncode_7.inc" -END PROCEDURE MdEncode7_Int64 - -MODULE PROCEDURE MdEncode7_Real32 -#include "./inc/MdEncode_7.inc" -END PROCEDURE MdEncode7_Real32 - -MODULE PROCEDURE MdEncode7_Real64 -#include "./inc/MdEncode_7.inc" -END PROCEDURE MdEncode7_Real64 - -MODULE PROCEDURE MdEncode7_String -#include "./inc/MdEncode_7.inc" -END PROCEDURE MdEncode7_String - -!---------------------------------------------------------------------------- -! StartTab -!---------------------------------------------------------------------------- - -MODULE PROCEDURE React_StartTabs -ans = ""//char_lf -END PROCEDURE React_StartTabs - -!---------------------------------------------------------------------------- -! EndTabs -!---------------------------------------------------------------------------- - -MODULE PROCEDURE React_EndTabs -ans = ""//char_lf -END PROCEDURE React_EndTabs - -!---------------------------------------------------------------------------- -! StartTabItem -!---------------------------------------------------------------------------- - -MODULE PROCEDURE React_StartTabItem -ans = "'//char_lf -END PROCEDURE React_StartTabItem - -!---------------------------------------------------------------------------- -! StartTabItem -!---------------------------------------------------------------------------- - -MODULE PROCEDURE React_EndTabItem -ans = ""//char_lf -END PROCEDURE React_EndTabItem - -END SUBMODULE Methods diff --git a/src/submodules/MdEncode/src/inc/MdEncode_2.inc b/src/submodules/MdEncode/src/inc/MdEncode_2.inc deleted file mode 100644 index 6b51c65b5..000000000 --- a/src/submodules/MdEncode/src/inc/MdEncode_2.inc +++ /dev/null @@ -1,35 +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 -! - -INTEGER(I4B) :: ii, n -n = SIZE(val) -ans = "| " -DO ii = 1, n - ans = ans//" | " -END DO -ans = ans//CHAR_LF -ans = ans//"| " -DO ii = 1, n - ans = ans//" --- | " -END DO -ans = ans//CHAR_LF - -ans = ans//"| " -DO ii = 1, n - ans = ans//MdEncode(val(ii))//" | " -END DO -ans = ans//CHAR_LF diff --git a/src/submodules/MdEncode/src/inc/MdEncode_3.inc b/src/submodules/MdEncode/src/inc/MdEncode_3.inc deleted file mode 100644 index 8e91a8894..000000000 --- a/src/submodules/MdEncode/src/inc/MdEncode_3.inc +++ /dev/null @@ -1,39 +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 -! - -INTEGER(I4B) :: ii, jj, m, n -m = SIZE(val, 1) -n = SIZE(val, 2) -ans = "| " -DO ii = 1, n - ans = ans//" | " -END DO -ans = ans//CHAR_LF - -ans = ans//"| " -DO ii = 1, n - ans = ans//" --- | " -END DO -ans = ans//CHAR_LF - -DO ii = 1, m - ans = ans // "| " - DO jj = 1, n - ans = ans // MdEncode( val( ii, jj ) ) // " | " - END DO - ans = ans // CHAR_LF -END DO diff --git a/src/submodules/MdEncode/src/inc/MdEncode_3b.inc b/src/submodules/MdEncode/src/inc/MdEncode_3b.inc deleted file mode 100644 index 2cafdbb74..000000000 --- a/src/submodules/MdEncode/src/inc/MdEncode_3b.inc +++ /dev/null @@ -1,25 +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 -! - - -DO ii = 1, m - ans = ans // " | " - DO jj = 1, n - ans = ans // TRIM( val( ii, jj ) ) // " | " - END DO - ans = ans // CHAR_LF -END DO \ No newline at end of file diff --git a/src/submodules/MdEncode/src/inc/MdEncode_6.inc b/src/submodules/MdEncode/src/inc/MdEncode_6.inc deleted file mode 100644 index efc061d54..000000000 --- a/src/submodules/MdEncode/src/inc/MdEncode_6.inc +++ /dev/null @@ -1,109 +0,0 @@ - -INTEGER(I4B) :: nc, nr, n, ii -nc = SIZE(ch) -nr = SIZE(rh) -n = SIZE(val) - -SELECT CASE (nc) -CASE (1) - - IF (nr .EQ. n) THEN - - ans = ivert//avert//ch(1)%chars()//evert//abr - ans = ans// & - & ivert//adash//avert//adash//evert//abr - - DO ii = 1, n - ans = ans// & - & ivert//rh(ii)%chars()//avert//mdencode(val(ii))//evert//abr - END DO - ans = ans//abr - - ELSE - - IF (ch(1)%LEN_TRIM() .EQ. 0_I4B) THEN - - ans = ivert//avert - - DO ii = 1, n - ans = ans//ablank//evert - END DO - ans = ans//abr - - ans = ans//ivert//adash//evert - DO ii = 1, n - ans = ans//adash//evert - END DO - ans = ans//abr - - ans = ans//ivert//rh(1)%chars()//evert - - DO ii = 1, n - ans = ans//mdencode(val(ii))//evert - END DO - ans = ans//abr - ELSE - - ans = ivert//ch(1)%chars()//evert//abr - ans = ans// & - & ivert//adash//evert//abr - - DO ii = 1, n - ans = ans// & - & ivert//mdencode(val(ii))//evert//abr - END DO - ans = ans//abr - END IF - - END IF - -CASE default - - IF (nc .EQ. n) THEN - - ans = ivert//avert - - DO ii = 1, n - ans = ans//ch(ii)%chars()//evert - END DO - ans = ans//abr - - ans = ans//ivert//adash//evert - DO ii = 1, n - ans = ans//adash//evert - END DO - ans = ans//abr - - ans = ans//ivert//rh(1)%chars()//evert - - DO ii = 1, n - ans = ans//mdencode(val(ii))//evert - END DO - ans = ans//abr - - ELSE - - ans = ivert//avert - - DO ii = 1, n - ans = ans//ablank//evert - END DO - ans = ans//abr - - ans = ans//ivert//adash//evert - DO ii = 1, n - ans = ans//adash//evert - END DO - ans = ans//abr - - ans = ans//ivert//rh(1)%chars()//evert - - DO ii = 1, n - ans = ans//mdencode(val(ii))//evert - END DO - ans = ans//abr - - END IF - -END SELECT - diff --git a/src/submodules/MdEncode/src/inc/MdEncode_7.inc b/src/submodules/MdEncode/src/inc/MdEncode_7.inc deleted file mode 100644 index e02cd8349..000000000 --- a/src/submodules/MdEncode/src/inc/MdEncode_7.inc +++ /dev/null @@ -1,121 +0,0 @@ -INTEGER(I4B) :: nc, nr, n, ii, m, jj -LOGICAL(LGT) :: norow, nocol -nc = SIZE(ch) -nr = SIZE(rh) -m = SIZE(val, 1) -n = SIZE(val, 2) - -IF (m .EQ. 1) THEN - ans = MdEncode(val=val(1, :), rh=rh, ch=ch) - RETURN -END IF - -IF (n .EQ. 1) THEN - ans = MdEncode(val=val(:, 1), rh=rh, ch=ch) - RETURN -END IF - -IF (nc .LT. n) THEN - nocol = .TRUE. -ELSE - nocol = .FALSE. -END IF - -IF (nr .LT. m) THEN - norow = .TRUE. -ELSE - norow = .FALSE. -END IF - -IF (nocol .AND. norow) THEN - ans = MdEncode(val) - RETURN -END IF - -IF (norow .AND. (.NOT. nocol)) THEN - ! | col-1 | col-2 | col-3 | - ! | ---- | ----- | ----- | - ! | 1 | 2 | 3 | - - ans = ivert - - DO ii = 1, n - ans = ans//ch(ii)%chars()//avert - END DO - ans = ans//abr - - ans = ans//ivert - DO ii = 1, n - ans = ans//adash//avert - END DO - ans = ans//abr - - ans = ans//ivert - - DO ii = 1, m - DO jj = 1, n - ans = ans//mdencode(val(ii, jj))//avert - END DO - ans = ans//abr - END DO - ans = ans//abr - RETURN -END IF - -IF (nocol .AND. (.NOT. norow)) THEN - ! | | | | | - ! | ----- | ---- | ----- | ----- | - ! | row-1 | 1 | 2 | 3 | - ! | row-2 | 1 | 2 | 3 | - ! | row-3 | 1 | 2 | 3 | - - ans = ivert//avert - DO ii = 1, n - ans = ans//ablank//avert - END DO - ans = ans//abr - - ans = ans//ivert//adash//avert - DO ii = 1, n - ans = ans//adash//avert - END DO - ans = ans//abr - - DO ii = 1, m - ans = ans//ivert//rh(ii)%chars()//avert - DO jj = 1, n - ans = ans//mdencode(val(ii, jj))//avert - END DO - ans = ans//abr - END DO - ans = ans//abr - RETURN -END IF - -! | | col-1 | col-2 | col-3 | -! | ----- | ---- | ----- | ----- | -! | row-1 | 1 | 2 | 3 | -! | row-2 | 1 | 2 | 3 | -! | row-3 | 1 | 2 | 3 | - -ans = ivert//avert -DO ii = 1, n - ans = ans//ch(ii)%chars()//avert -END DO -ans = ans//abr - -ans = ans//ivert//adash//avert -DO ii = 1, n - ans = ans//adash//avert -END DO -ans = ans//abr - -DO ii = 1, m - ans = ans//ivert//rh(ii)%chars()//avert - DO jj = 1, n - ans = ans//mdencode(val(ii, jj))//avert - END DO - ans = ans//abr -END DO -ans = ans//abr - diff --git a/src/submodules/MultiIndices/CMakeLists.txt b/src/submodules/MultiIndices/CMakeLists.txt deleted file mode 100644 index 76b424d30..000000000 --- a/src/submodules/MultiIndices/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/MultiIndices_Method@Methods.F90 -) diff --git a/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 b/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 deleted file mode 100644 index fff8eab4d..000000000 --- a/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 +++ /dev/null @@ -1,96 +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(MultiIndices_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate1 -obj%n = n -obj%d = d -END PROCEDURE obj_Initiate1 - -!---------------------------------------------------------------------------- -! MultiIndices -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_MultiIndices -ans%n = n -ans%d = d -END PROCEDURE obj_MultiIndices - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Deallocate -obj%n = 0 -obj%d = 0 -END PROCEDURE obj_Deallocate - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Display -CALL Display(msg, unitno=unitno) -CALL Display(obj%n, "n = ", unitno=unitno) -CALL Display(obj%d, "d = ", unitno=unitno) -END PROCEDURE obj_Display - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Size1 -ans = INT(Binom(obj%n + obj%d, obj%d, 1.0_DFP), KIND=I4B) -END PROCEDURE obj_Size1 - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Size2 -INTEGER(I4B) :: ii -ans = 0_I4B -DO ii = 0, obj%n - ans = ans + Size(n=ii, d=obj%d) -END DO -END PROCEDURE obj_Size2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetMultiIndices1 -ans = GetMultiIndices(n=obj%n, d=obj%d) -END PROCEDURE obj_GetMultiIndices1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetMultiIndices2 -ans = GetMultiIndices(n=obj%n, d=obj%d, upto=.true.) -END PROCEDURE obj_GetMultiIndices2 - -END SUBMODULE Methods diff --git a/src/submodules/OpenMP/CMakeLists.txt b/src/submodules/OpenMP/CMakeLists.txt deleted file mode 100644 index 162383e14..000000000 --- a/src/submodules/OpenMP/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 9/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/OpenMP_Method@Constructor.F90 -) diff --git a/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 b/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 deleted file mode 100644 index 393120f01..000000000 --- a/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 +++ /dev/null @@ -1,72 +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(OpenMP_Method) Constructor -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_initiate - OMP%State = OMP_THREADS_FORKED - OMP%IS_INIT = .TRUE. - OMP%DID_I_INIT = .TRUE. - !$ OMP%MAX_THREADS = omp_get_max_threads() - !$ OMP%NUM_THREADS = omp_get_num_threads() - !$ OMP%Rank = omp_get_thread_num() -END PROCEDURE obj_initiate - -!---------------------------------------------------------------------------- -! Finalize -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_finalize - OMP%State = OMP_THREADS_JOINED - OMP%IS_INIT = .FALSE. - OMP%DID_I_INIT = .FALSE. - OMP%MAX_THREADS = 1 - OMP%NUM_THREADS = 1 - OMP%Rank = 0 -END PROCEDURE obj_finalize - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_partition_vec - INTEGER( I4B ) :: chunck - chunck = INT( N/OMP_NUM_THREADS, KIND=I4B ) - - IF( chunck .NE. 0 ) THEN - IF( OMP%RANK .EQ. OMP_NUM_THREADS-1 ) THEN - Ans = [(chunck*OMP%RANK) + 1, N, 1, N-chunck*OMP%RANK] - ELSE - Ans = [(chunck*OMP%RANK) + 1, chunck*(OMP%RANK + 1), 1, chunck] - END IF - ELSE - IF( OMP%RANK .EQ. 0 ) THEN - Ans = [1, N, 1, N] - ELSE - Ans = [0,0,1,0] - END IF - END IF -END PROCEDURE obj_partition_vec - -END SUBMODULE Constructor \ No newline at end of file diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt deleted file mode 100644 index 90b4a65e5..000000000 --- a/src/submodules/Polynomial/CMakeLists.txt +++ /dev/null @@ -1,43 +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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/LineInterpolationUtility@Methods.F90 - ${src_path}/QuadraturePoint_Triangle_Solin.F90 - ${src_path}/QuadraturePoint_Tetrahedron_Solin.F90 - ${src_path}/TriangleInterpolationUtility@Methods.F90 - ${src_path}/TriangleInterpolationUtility@QuadratureMethods.F90 - ${src_path}/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 - ${src_path}/TriangleInterpolationUtility@LagrangeBasisMethods.F90 - ${src_path}/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 - ${src_path}/QuadrangleInterpolationUtility@Methods.F90 - ${src_path}/TetrahedronInterpolationUtility@Methods.F90 - ${src_path}/HexahedronInterpolationUtility@Methods.F90 - ${src_path}/PrismInterpolationUtility@Methods.F90 - ${src_path}/PyramidInterpolationUtility@Methods.F90 - ${src_path}/InterpolationUtility@Methods.F90 - ${src_path}/LagrangePolynomialUtility@Methods.F90 - ${src_path}/JacobiPolynomialUtility@Methods.F90 - ${src_path}/UltrasphericalPolynomialUtility@Methods.F90 - ${src_path}/LegendrePolynomialUtility@Methods.F90 - ${src_path}/LobattoPolynomialUtility@Methods.F90 - ${src_path}/UnscaledLobattoPolynomialUtility@Methods.F90 - ${src_path}/Chebyshev1PolynomialUtility@Methods.F90 - ${src_path}/OrthogonalPolynomialUtility@Methods.F90 - ${src_path}/RecursiveNodesUtility@Methods.F90) diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 deleted file mode 100644 index 8c905ad17..000000000 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ /dev/null @@ -1,1150 +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(Chebyshev1PolynomialUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Chebyshev1Alpha -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Alpha -ans = 0.0_DFP -END PROCEDURE Chebyshev1Alpha - -!---------------------------------------------------------------------------- -! Chebyshev1Beta -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Beta -SELECT CASE (n) -CASE (0_I4B) - ans = pi -CASE (1_I4B) - ans = 0.5_DFP -CASE DEFAULT - ans = 0.25_DFP -END SELECT -END PROCEDURE Chebyshev1Beta - -!---------------------------------------------------------------------------- -! GetChebyshev1RecurrenceCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetChebyshev1RecurrenceCoeff -IF (n .LE. 0) RETURN -alphaCoeff = 0.0_DFP -betaCoeff(0) = pi -IF (n .EQ. 1) RETURN -betaCoeff(1) = 0.5_DFP -IF (n .EQ. 2) RETURN -betaCoeff(2:) = 0.25_DFP -END PROCEDURE GetChebyshev1RecurrenceCoeff - -!---------------------------------------------------------------------------- -! GetChebyshev1RecurrenceCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetChebyshev1RecurrenceCoeff2 -IF (n .LE. 0) RETURN -A = 2.0_DFP -B = 0.0_DFP -C = 1.0_DFP -END PROCEDURE GetChebyshev1RecurrenceCoeff2 - -!---------------------------------------------------------------------------- -! Chebyshev1LeadingCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1LeadingCoeff -IF (n .EQ. 0_I4B) THEN - ans = 1.0_DFP -ELSE - ans = 2.0_DFP**(n - 1_I4B) -END IF -END PROCEDURE Chebyshev1LeadingCoeff - -!---------------------------------------------------------------------------- -! Chebyshev1LeadingCoeffRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1LeadingCoeffRatio -IF (n .EQ. 0_I4B) THEN - ans = 1.0_DFP -ELSE - ans = 2.0_DFP -END IF -END PROCEDURE Chebyshev1LeadingCoeffRatio - -!---------------------------------------------------------------------------- -! Chebyshev1NormSQR -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1NormSQR -IF (n .EQ. 0_I4B) THEN - ans = pi -ELSE - ans = pi / 2.0_DFP -END IF -END PROCEDURE Chebyshev1NormSQR - -!---------------------------------------------------------------------------- -! Chebyshev1NormSQR2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1NormSQR2 -ans(0) = pi -IF (n .EQ. 0) RETURN -ans(1:) = 0.5_DFP * pi -END PROCEDURE Chebyshev1NormSQR2 - -!---------------------------------------------------------------------------- -! Chebyshev1NormSQRRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1NormSQRRatio -ans = 1.0_DFP -END PROCEDURE Chebyshev1NormSQRRatio - -!---------------------------------------------------------------------------- -! Chebyshev1JacobiMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1JacobiMatrix -CALL JacobiJacobiMatrix(n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & - & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -END PROCEDURE Chebyshev1JacobiMatrix - -!---------------------------------------------------------------------------- -! Chebyshev1GaussQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GaussQuadrature -pt = Chebyshev1Zeros(n=n) -IF (PRESENT(wt)) wt = pi / n -END PROCEDURE Chebyshev1GaussQuadrature - -!---------------------------------------------------------------------------- -! Chebyshev1JacobiRadauMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1JacobiRadauMatrix -CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & - & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -END PROCEDURE Chebyshev1JacobiRadauMatrix - -!---------------------------------------------------------------------------- -! Chebyshev1GaussRadauQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GaussRadauQuadrature -INTEGER(I4B) :: ii, c -REAL(DFP) :: avar, avar2 -!! -IF (a .LT. 0.0_DFP) THEN - c = 0_I4B -ELSE - c = 1_I4B -END IF -!! -avar = pi / (2.0_DFP * n + 1.0_DFP) -!! -avar2 = pi / (2.0_DFP * n + 1.0_DFP) -!! -IF (PRESENT(wt)) THEN - DO ii = 0, n - pt(ii + 1) = -COS(avar * (2 * ii + c)) - wt(ii + 1) = avar2 - END DO -!! - wt(1) = wt(1) / 2.0_DFP -ELSE - DO ii = 0, n - pt(ii + 1) = -COS(avar * (2 * ii + c)) - END DO -END IF -!! -END PROCEDURE Chebyshev1GaussRadauQuadrature - -!---------------------------------------------------------------------------- -! Chebyshev1JacobiLobattoMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1JacobiLobattoMatrix -CALL JacobiJacobiLobattoMatrix(n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & - & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -END PROCEDURE Chebyshev1JacobiLobattoMatrix - -!---------------------------------------------------------------------------- -! Chebyshev1GaussLobattoQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GaussLobattoQuadrature -INTEGER(I4B) :: ii -REAL(DFP) :: avar -!! -avar = pi / (n + 1.0_DFP) -!! -IF (PRESENT(wt)) THEN - wt = avar - wt(1) = wt(1) / 2.0_DFP - wt(n + 2) = wt(n + 2) / 2.0_DFP -END IF -!! -DO ii = 0, n + 1 - pt(ii + 1) = -COS(avar * ii) -END DO -!! -END PROCEDURE Chebyshev1GaussLobattoQuadrature - -!---------------------------------------------------------------------------- -! Chebyshev1Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Zeros -INTEGER(I4B) :: ii -REAL(DFP) :: aval -aval = pi * 0.5_DFP / REAL(n, KIND=DFP) -DO ii = 1, n - ans(ii) = -COS((2.0_DFP * ii - 1.0_DFP) * aval) -END DO -END PROCEDURE Chebyshev1Zeros - -!---------------------------------------------------------------------------- -! Chebyshev1Quadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Quadrature -INTEGER(I4B) :: order -REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP -REAL(DFP), ALLOCATABLE :: p(:), w(:) -LOGICAL(LGT) :: inside -!! -IF (PRESENT(onlyInside)) THEN - inside = onlyInside -ELSE - inside = .FALSE. -END IF -!! -SELECT CASE (QuadType) -CASE (Gauss) - !! - order = n - CALL Chebyshev1GaussQuadrature(n=order, pt=pt, wt=wt) - !! -CASE (GaussRadau, GaussRadauLeft) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 1), w(n + 1)) - CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=p, wt=w) - pt = p(2:); wt = w(2:) - DEALLOCATE (p, w) - ELSE - order = n - 1 - CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) - END IF - !! -CASE (GaussRadauRight) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 1), w(n + 1)) - CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=p, wt=w) - pt = p(1:n); wt = w(1:n) - ELSE - order = n - 1 - CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) - END IF - !! -CASE (GaussLobatto) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 2), w(n + 2)) - CALL Chebyshev1GaussLobattoQuadrature(n=order, pt=p, wt=w) - pt = p(2:n + 1); wt = w(2:n + 1) - ELSE - order = n - 2 - CALL Chebyshev1GaussLobattoQuadrature(n=order, pt=pt, wt=wt) - END IF -END SELECT - !! -END PROCEDURE Chebyshev1Quadrature - -!---------------------------------------------------------------------------- -! Chebyshev1Eval1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Eval1 -INTEGER(I4B) :: i -REAL(DFP) :: ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans = x -!! -DO i = 1, n - 1 - !! - ans_1 = ans - ans = (2.0_DFP * x) * ans - ans_2 - ans_2 = ans_1 - !! -END DO -END PROCEDURE Chebyshev1Eval1 - -!---------------------------------------------------------------------------- -! Chebyshev1Eval2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Eval2 -INTEGER(I4B) :: i -REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans = x -!! -DO i = 1, n - 1 - !! - ans_1 = ans - ans = (2.0_DFP * x) * ans - ans_2 - ans_2 = ans_1 - !! -END DO -END PROCEDURE Chebyshev1Eval2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1EvalAll1 -INTEGER(I4B) :: i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(2) = x -!! -DO i = 2, n - ans(i + 1) = (2.0_DFP * x) * ans(i) - ans(i - 1) -END DO -!! -END PROCEDURE Chebyshev1EvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1EvalAll2 -INTEGER(I4B) :: i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(:, 1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(:, 2) = x -!! -DO i = 2, n - ans(:, i + 1) = (2.0_DFP * x) * ans(:, i) - ans(:, i - 1) -END DO -!! -END PROCEDURE Chebyshev1EvalAll2 - -!---------------------------------------------------------------------------- -! Chebyshev1MonomialExpansionAll -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1MonomialExpansionAll -INTEGER(I4B), PARAMETER :: rk = 1.0_DFP -INTEGER(I4B) :: ii -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 0.0_DFP -ans(1, 1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(2, 2) = 1.0_DFP -!! -DO ii = 2, n - !! - ! ans(ii + 1, 1) = -ans(ii - 1, 1) - ans(1, ii + 1) = -ans(1, ii - 1) - !! - ! ans(ii + 1, 2:ii - 1) = 2.0_DFP*ans(ii, 1:ii - 2) - ans(ii - 1, 2:ii - 1) - ans(2:ii - 1, ii + 1) = 2.0_DFP * ans(1:ii - 2, ii) - ans(2:ii - 1, ii - 1) - !! - ! ans(ii + 1, ii) = 2.0_DFP * ans(ii, ii - 1) - ans(ii, ii + 1) = 2.0_DFP * ans(ii - 1, ii) - !! - ! ans(ii + 1, ii + 1) = 2.0_DFP * ans(ii, ii) - ans(ii + 1, ii + 1) = 2.0_DFP * ans(ii, ii) - !! -END DO -!! -END PROCEDURE Chebyshev1MonomialExpansionAll - -!---------------------------------------------------------------------------- -! Chebyshev1MonomialExpansion -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1MonomialExpansion -REAL(DFP) :: coeff(n + 1, n + 1) -coeff = Chebyshev1MonomialExpansionAll(n) -ans = coeff(:, n + 1) -END PROCEDURE Chebyshev1MonomialExpansion - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalAll1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEvalAll1 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: p(1:n + 1), r_ii -!! -IF (n < 0) THEN - RETURN -END IF -!! -p(1) = 1.0_DFP -ans(1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -IF (n .EQ. 0_I4B) RETURN -!! -p(2) = x -ans(2) = 1.0_DFP -!! -IF (n .EQ. 1_I4B) RETURN -!! -p(3) = 2.0_DFP * x**2 - 1.0_DFP -ans(3) = 4.0_DFP * x -!! -DO ii = 3, n - !! - r_ii = REAL(ii, KIND=DFP) - p(ii + 1) = (2.0_DFP * x) * p(ii) - p(ii - 1) - ans(ii + 1) = 2.0_DFP * r_ii * p(ii) & - & + r_ii * ans(ii - 1) / (r_ii - 2.0_DFP) - !! -END DO -!! -END PROCEDURE Chebyshev1GradientEvalAll1 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalAll2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEvalAll2 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: p(1:SIZE(x), 1:n + 1), r_ii -!! -IF (n < 0) THEN - RETURN -END IF -!! -p(:, 1) = 1.0_DFP -ans(:, 1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -IF (n .EQ. 0_I4B) RETURN -!! -p(:, 2) = x -ans(:, 2) = 1.0_DFP -!! -IF (n .EQ. 1_I4B) RETURN -!! -p(:, 3) = 2.0_DFP * x**2 - 1.0_DFP -ans(:, 3) = 4.0_DFP * x -!! -DO ii = 3, n - !! - r_ii = REAL(ii, KIND=DFP) - p(:, ii + 1) = (2.0_DFP * x) * p(:, ii) - p(:, ii - 1) - ans(:, ii + 1) = 2.0_DFP * r_ii * p(:, ii) & - & + r_ii * ans(:, ii - 1) / (r_ii - 2.0_DFP) - !! -END DO -!! -END PROCEDURE Chebyshev1GradientEvalAll2 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEval1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEval1 -! -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii, p, p_1, p_2, ans_1, ans_2 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p = 1.0_DFP -ans = 0.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n < 1) THEN - RETURN -END IF -!! -IF (n .EQ. 0_I4B) RETURN -!! -p = x -ans = 1.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n .EQ. 1_I4B) RETURN -!! -p = 2.0_DFP * x**2 - 1.0_DFP -ans = 4.0_DFP * x -!! -DO ii = 3, n - !! - r_ii = REAL(ii, KIND=DFP) - p_1 = p - p = (2.0_DFP * x) * p - p_2 - p_2 = p_1 - !! - ans_1 = ans - ans = 2.0_DFP * r_ii * p_1 & - & + r_ii * ans_2 / (r_ii - 2.0_DFP) - ans_2 = ans_1 - !! -END DO -!! -END PROCEDURE Chebyshev1GradientEval1 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEval2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEval2 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2, ans_1, ans_2 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p = 1.0_DFP -ans = 0.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n < 1) THEN - RETURN -END IF -!! -IF (n .EQ. 0_I4B) RETURN -!! -p = x -ans = 1.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n .EQ. 1_I4B) RETURN -!! -p = 2.0_DFP * x**2 - 1.0_DFP -ans = 4.0_DFP * x -!! -DO ii = 3, n - !! - r_ii = REAL(ii, KIND=DFP) - p_1 = p - p = (2.0_DFP * x) * p - p_2 - p_2 = p_1 - !! - ans_1 = ans - ans = 2.0_DFP * r_ii * p_1 & - & + r_ii * ans_2 / (r_ii - 2.0_DFP) - ans_2 = ans_1 - !! -END DO -!! -END PROCEDURE Chebyshev1GradientEval2 - -!---------------------------------------------------------------------------- -! Chebyshev1EvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1EvalSum1 -REAL(DFP) :: xx, t, b1, b2 -INTEGER(I4B) :: i -!! -IF (n .LT. 0) RETURN -b1 = 0.0_DFP -b2 = 0.0_DFP -xx = 2.0_DFP * x -!! -DO i = n, 1, -1 - t = xx * b1 - b2 + coeff(i) - b2 = b1 - b1 = t -END DO -ans = x * b1 - b2 + coeff(0) -END PROCEDURE Chebyshev1EvalSum1 - -!---------------------------------------------------------------------------- -! Chebyshev1EvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1EvalSum2 -REAL(DFP), DIMENSION(SIZE(x)) :: xx, t, b1, b2 -INTEGER(I4B) :: i -!! -IF (n .LT. 0) RETURN -b1 = 0.0_DFP -b2 = 0.0_DFP -xx = 2.0_DFP * x -!! -DO i = n, 1, -1 - t = xx * b1 - b2 + coeff(i) - b2 = b1 - b1 = t -END DO -ans = x * b1 - b2 + coeff(0) -END PROCEDURE Chebyshev1EvalSum2 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEvalSum1 -REAL(DFP) :: xx, t, b1, b2 -INTEGER(I4B) :: i -IF (n .LT. 0) RETURN -b1 = 0.0_DFP -b2 = 0.0_DFP -xx = 2.0_DFP * x -!! -DO i = n - 1, 0, -1 - t = xx * b1 - b2 + (i + 1) * coeff(i + 1); - b2 = b1; - b1 = t; -END DO -!! -ans = b1 -END PROCEDURE Chebyshev1GradientEvalSum1 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEvalSum2 -REAL(DFP), DIMENSION(SIZE(x)) :: xx, t, b1, b2 -INTEGER(I4B) :: i -IF (n .LT. 0) RETURN -b1 = 0.0_DFP -b2 = 0.0_DFP -xx = 2.0_DFP * x -!! -DO i = n - 1, 0, -1 - t = xx * b1 - b2 + (i + 1) * coeff(i + 1); - b2 = b1; - b1 = t; -END DO -!! -ans = b1 -END PROCEDURE Chebyshev1GradientEvalSum2 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEvalSum3 -REAL(DFP) :: s, t, b1, b2 -INTEGER(I4B) :: i -REAL(DFP) :: j -!! -IF (n .LT. 0) RETURN -!! -IF (k .EQ. 0) THEN - !! - ans = Chebyshev1EvalSum(coeff=coeff, n=n, x=x) - !! -ELSE - !! - b1 = 0.0_DFP - b2 = 0.0_DFP - s = 1.0_DFP - !! - DO i = k - 1, 1, -1 - s = 2.0_DFP * s * i - END DO - !! - DO i = n - k, 0, -1 - j = REAL(i, KIND=DFP) - t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & - & / (j + 2) * b2 + (j + k) * coeff(i + k); - b2 = b1; - b1 = t; - END DO - !! - ans = s * b1 -END IF -END PROCEDURE Chebyshev1GradientEvalSum3 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientEvalSum4 -REAL(DFP) :: s -REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 -INTEGER(I4B) :: i -REAL(DFP) :: j -!! -IF (n .LT. 0) RETURN -!! -IF (k .EQ. 0) THEN - !! - ans = Chebyshev1EvalSum(coeff=coeff, n=n, x=x) - !! -ELSE - !! - b1 = 0.0_DFP - b2 = 0.0_DFP - s = 1.0_DFP - !! - DO i = k - 1, 1, -1 - s = 2.0_DFP * s * i - END DO - !! - DO i = n - k, 0, -1 - j = REAL(i, KIND=DFP) - t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & - & / (j + 2) * b2 + (j + k) * coeff(i + k); - b2 = b1; - b1 = t; - END DO - !! - ans = s * b1 -END IF - -END PROCEDURE Chebyshev1GradientEvalSum4 - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Transform1 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -REAL(DFP) :: rn -!! -nrmsqr = Chebyshev1NormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = pi -END IF -!! -PP = Chebyshev1EvalAll(n=n, x=x) -!! -DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / nrmsqr(jj) -END DO -!! -END PROCEDURE Chebyshev1Transform1 - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Transform2 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -REAL(DFP) :: rn -!! -nrmsqr = Chebyshev1NormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = pi -END IF -!! -PP = Chebyshev1EvalAll(n=n, x=x) -!! -DO kk = 1, SIZE(coeff, 2) - DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / nrmsqr(jj) - END DO -END DO -!! -END PROCEDURE Chebyshev1Transform2 - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Transform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) -INTEGER(I4B) :: ii -!! -CALL Chebyshev1Quadrature(n=n + 1, pt=pt, wt=wt,& - & quadType=quadType) -!! -DO ii = 0, n - coeff(ii) = f(pt(ii)) -END DO -!! -ans = Chebyshev1Transform(n=n, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) -!! -END PROCEDURE Chebyshev1Transform3 - -!---------------------------------------------------------------------------- -! Chebyshev1Transform4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Transform4 -INTEGER(I4B) :: ii, jj -REAL(DFP) :: avar -!! -ans = 0.0_DFP -!! -IF (quadType .EQ. GaussLobatto) THEN - !! - DO jj = 0, n - !! - ans(jj) = coeff(0) * 0.5_DFP + coeff(n) * 0.5_DFP * (-1.0)**jj - !! - DO ii = 1, n - 1 - ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi * ii / n) - END DO - !! - ans(jj) = ans(jj) * 2.0_DFP / n - !! - END DO - !! - ans(0) = ans(0) * 0.5_DFP - ans(n) = ans(n) * 0.5_DFP - !! -ELSE - !! - DO jj = 0, n - !! - avar = jj * pi * 0.5_DFP / (n + 1.0_DFP) - !! - DO ii = 0, n - ans(jj) = ans(jj) + coeff(ii) * COS((2.0 * ii + 1.0) * avar) - END DO - !! - ans(jj) = ans(jj) * 2.0_DFP / (n + 1.0) - !! - END DO - !! - ans(0) = ans(0) * 0.5_DFP - !! -END IF -!! -END PROCEDURE Chebyshev1Transform4 - -!---------------------------------------------------------------------------- -! Chebyshev1InvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1InvTransform1 -ans = Chebyshev1EvalSum(n=n, coeff=coeff, x=x) -END PROCEDURE Chebyshev1InvTransform1 - -!---------------------------------------------------------------------------- -! Chebyshev1InvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1InvTransform2 -ans = Chebyshev1EvalSum(n=n, coeff=coeff, x=x) -END PROCEDURE Chebyshev1InvTransform2 - -!---------------------------------------------------------------------------- -! Chebyshev1GradientCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1GradientCoeff1 -REAL(DFP) :: a, b, c -INTEGER(I4B) :: ii -REAL(DFP) :: jj -!! -ans(n) = 0.0_DFP -IF (n .EQ. 0) RETURN -!! -IF (n .EQ. 1) THEN - c = 2.0_DFP -ELSE - c = 1.0_DFP -END IF -!! -ans(n - 1) = 2.0_DFP * n * coeff(n) / c -!! -DO ii = n - 1, 1, -1 - jj = REAL(ii, KIND=DFP) - ans(ii - 1) = 2.0_DFP * jj * coeff(ii) + ans(ii + 1) -END DO -!! -ans(0) = 0.5_DFP * ans(0) -!! -END PROCEDURE Chebyshev1GradientCoeff1 - -!---------------------------------------------------------------------------- -! Chebyshev1DMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1DMatrix1 -SELECT CASE (quadType) -CASE (GaussLobatto) - CALL Chebyshev1DMatrixGL2(n=n, x=x, D=ans) -CASE (Gauss) - CALL Chebyshev1DMatrixG2(n=n, x=x, D=ans) -END SELECT -END PROCEDURE Chebyshev1DMatrix1 - -!---------------------------------------------------------------------------- -! Chebyshev1DMatrixGL -!---------------------------------------------------------------------------- - -PURE SUBROUTINE Chebyshev1DMatrixGL2(n, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: rn, j1, j2 - INTEGER(I4B) :: ii, jj, nb2 - !! - nb2 = int(n / 2) - rn = REAL(n, KIND=DFP) - !! - D = 0.0_DFP - !! - DO jj = 0, n - DO ii = 0, nb2 - j1 = SIN(0.5 * (ii + jj) * pi / rn) - j2 = SIN(0.5 * (ii - jj) * pi / rn) - IF (ii .NE. jj) & - & D(ii, jj) = 0.5 * (-1)**(ii + jj) / j1 / j2 - END DO - END DO - !! - D(0, :) = D(0, :) * 2.0_DFP - D(:, 0) = D(:, 0) * 0.5_DFP - D(:, n) = D(:, n) * 0.5_DFP - !! - !! correct diagonal entries - !! - D(0, 0) = -(2.0_DFP * rn**2 + 1.0_DFP) / 6.0_DFP - !! - DO ii = 1, nb2 - D(ii, ii) = -x(ii) * 0.5_DFP / (SIN(pi * ii / rn))**2 - END DO - !! - !! copy - !! - DO jj = 0, n - DO ii = 0, nb2 - D(n - ii, n - jj) = -D(ii, jj) - END DO - END DO - !! -END SUBROUTINE Chebyshev1DMatrixGL2 - -!---------------------------------------------------------------------------- -! Chebyshev1DMatrixG -!---------------------------------------------------------------------------- - -PURE SUBROUTINE Chebyshev1DMatrixG(n, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! internal variables - !! - REAL(DFP) :: rn, j3, j4 - INTEGER(I4B) :: ii, jj, nb2 - !! - !! main - !! - rn = REAL(n, KIND=DFP) - nb2 = int(n / 2) - D = 0.0_DFP - !! - DO jj = 0, n - j4 = (rn + 1.0) * SIN((2.0 * jj + 1) * 0.5 * pi) & - & / SIN((2.0 * jj + 1) * 0.5 * pi / (rn + 1.0)) - DO ii = 0, nb2 - j3 = (rn + 1.0) * SIN((2.0 * ii + 1) * 0.5 * pi) & - & / SIN((2.0 * ii + 1) * 0.5 * pi / (rn + 1.0)) - IF (ii .NE. jj) & - & D(ii, jj) = j3 / j4 / (x(ii) - x(jj)) - END DO - END DO - !! - !! correct diagonal entries - !! - DO ii = 0, nb2 - D(ii, ii) = x(ii) * 0.5_DFP / (1.0_DFP - x(ii)**2) - END DO - !! - !! copy - !! - DO jj = 0, n - DO ii = 0, nb2 - D(n - ii, n - jj) = -D(ii, jj) - END DO - END DO - !! -END SUBROUTINE Chebyshev1DMatrixG - -!---------------------------------------------------------------------------- -! Chebyshev1DMatrixG -!---------------------------------------------------------------------------- - -PURE SUBROUTINE Chebyshev1DMatrixG2(n, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! internal variables - !! - REAL(DFP) :: rn - REAL(DFP) :: J(0:n) - INTEGER(I4B) :: ii, jj, nb2 - !! - !! main - !! - rn = REAL(n, KIND=DFP) - nb2 = int(n / 2) - D = 0.0_DFP - !! - J = Chebyshev1GradientEval(n=n + 1, x=x) - !! - DO jj = 0, n - DO ii = 0, nb2 - IF (ii .NE. jj) & - & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END DO - END DO - !! - !! correct diagonal entries - !! - DO ii = 0, nb2 - D(ii, ii) = x(ii) * 0.5_DFP / (1.0_DFP - x(ii)**2) - END DO - !! - !! copy - !! - DO jj = 0, n - DO ii = 0, nb2 - D(n - ii, n - jj) = -D(ii, jj) - END DO - END DO - !! -END SUBROUTINE Chebyshev1DMatrixG2 - -!---------------------------------------------------------------------------- -! Chebyshev1DMatEvenOdd -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1DMatEvenOdd1 -CALL UltrasphericalDMatEvenOdd(n=n, D=D, o=o, e=e) -END PROCEDURE Chebyshev1DMatEvenOdd1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc b/src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc deleted file mode 100644 index c14367e25..000000000 --- a/src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc +++ /dev/null @@ -1,267 +0,0 @@ - -!---------------------------------------------------------------------------- -! EquidistanceLIP_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceLIP_Tetrahedron - !! -SELECT CASE (order) -CASE (1) - !! - !! tetra4 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0], [3, 4]) - !! -CASE (2) - !! - !! tetra10 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.5, 0.0, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.0, 0.5, & - & 0.0, 0.5, 0.5, & - & 0.5, 0.0, 0.5], [3, 10]) - !! -CASE (3) - !! - !! tetra20 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.0, 0.66666666666666666667, & - & 0.0, 0.0, 0.33333333333333333333, & - & 0.0, 0.33333333333333333333, 0.66666666666666666667, & - & 0.0, 0.66666666666666666667, 0.33333333333333333333, & - & 0.33333333333333333333, 0.0, 0.66666666666666666667, & - & 0.66666666666666666667, 0.0, 0.33333333333333333333, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.0, 0.33333333333333333333, & - & 0.0, 0.33333333333333333333, 0.33333333333333333333, & - & 0.33333333333333333333, 0.33333333333333333333, & - & 0.33333333333333333333], [3, 20]) - !! -CASE (4) - !! - !! tetra35 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.25, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.75, 0.0, 0.0, & - & 0.75, 0.25, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.25, 0.75, 0.0, & - & 0.0, 0.75, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.25, 0.0, & - & 0.0, 0.0, 0.75, & - & 0.0, 0.0, 0.5, & - & 0.0, 0.0, 0.25, & - & 0.0, 0.25, 0.75, & - & 0.0, 0.5, 0.5, & - & 0.0, 0.75, 0.25, & - & 0.25, 0.0, 0.75, & - & 0.5, 0.0, 0.5, & - & 0.75, 0.0, 0.25, & - & 0.25, 0.25, 0.0, & - & 0.25, 0.5, 0.0, & - & 0.5, 0.25, 0.0, & - & 0.25, 0.0, 0.25, & - & 0.5, 0.0, 0.25, & - & 0.25, 0.0, 0.5, & - & 0.0, 0.25, 0.25, & - & 0.0, 0.25, 0.5, & - & 0.0, 0.5, 0.25, & - & 0.25, 0.25, 0.5, & - & 0.5, 0.25, 0.25, & - & 0.25, 0.5, 0.25, & - & 0.25, 0.25, 0.25], [3, 35]) - !! -CASE (5) - !! - !! tetra56 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.2, 0.0, 0.0, & - & 0.4, 0.0, 0.0, & - & 0.6, 0.0, 0.0, & - & 0.8, 0.0, 0.0, & - & 0.8, 0.2, 0.0, & - & 0.6, 0.4, 0.0, & - & 0.4, 0.6, 0.0, & - & 0.2, 0.8, 0.0, & - & 0.0, 0.8, 0.0, & - & 0.0, 0.6, 0.0, & - & 0.0, 0.4, 0.0, & - & 0.0, 0.2, 0.0, & - & 0.0, 0.0, 0.8, & - & 0.0, 0.0, 0.6, & - & 0.0, 0.0, 0.4, & - & 0.0, 0.0, 0.2, & - & 0.0, 0.2, 0.8, & - & 0.0, 0.4, 0.6, & - & 0.0, 0.6, 0.4, & - & 0.0, 0.8, 0.2, & - & 0.2, 0.0, 0.8, & - & 0.4, 0.0, 0.6, & - & 0.6, 0.0, 0.4, & - & 0.8, 0.0, 0.2, & - & 0.2, 0.2, 0.0, & - & 0.2, 0.6, 0.0, & - & 0.6, 0.2, 0.0, & - & 0.2, 0.4, 0.0, & - & 0.4, 0.4, 0.0, & - & 0.4, 0.2, 0.0, & - & 0.2, 0.0, 0.2, & - & 0.6, 0.0, 0.2, & - & 0.2, 0.0, 0.6, & - & 0.4, 0.0, 0.2, & - & 0.4, 0.0, 0.4, & - & 0.2, 0.0, 0.4, & - & 0.0, 0.2, 0.2, & - & 0.0, 0.2, 0.6, & - & 0.0, 0.6, 0.2, & - & 0.0, 0.2, 0.4, & - & 0.0, 0.4, 0.4, & - & 0.0, 0.4, 0.2, & - & 0.2, 0.2, 0.6, & - & 0.6, 0.2, 0.2, & - & 0.2, 0.6, 0.2, & - & 0.4, 0.2, 0.4, & - & 0.4, 0.4, 0.2, & - & 0.2, 0.4, 0.4, & - & 0.2, 0.2, 0.2, & - & 0.4, 0.2, 0.2, & - & 0.2, 0.4, 0.2, & - & 0.2, 0.2, 0.4], [3, 56]) - !! -CASE (6) - !! - !! - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.16666666666666666667, 0.0, 0.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.83333333333333333333, 0.0, 0.0, & - & 0.83333333333333333333, 0.16666666666666666667, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.16666666666666666667, 0.83333333333333333333, 0.0, & - & 0.0, 0.83333333333333333333, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.16666666666666666667, 0.0, & - & 0.0, 0.0, 0.83333333333333333333, & - & 0.0, 0.0, 0.66666666666666666667, & - & 0.0, 0.0, 0.5, & - & 0.0, 0.0, 0.33333333333333333333, & - & 0.0, 0.0, 0.16666666666666666667, & - & 0.0, 0.16666666666666666667, 0.83333333333333333333, & - & 0.0, 0.33333333333333333333, 0.66666666666666666667, & - & 0.0, 0.5, 0.5, & - & 0.0, 0.66666666666666666667, 0.33333333333333333333, & - & 0.0, 0.83333333333333333333, 0.16666666666666666667, & - & 0.16666666666666666667, 0.0, 0.83333333333333333333, & - & 0.33333333333333333333, 0.0, 0.66666666666666666667, & - & 0.5, 0.0, 0.5, & - & 0.66666666666666666667, 0.0, 0.33333333333333333333, & - & 0.83333333333333333333, 0.0, 0.16666666666666666667, & - & 0.16666666666666666667, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.66666666666666666667, 0.0, & - & 0.66666666666666666667, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.33333333333333333333, 0.0, & - & 0.16666666666666666667, 0.5, 0.0, & - & 0.33333333333333333333, 0.5, 0.0, & - & 0.5, 0.33333333333333333333, 0.0, & - & 0.5, 0.16666666666666666667, 0.0, & - & 0.33333333333333333333, 0.16666666666666666667, 0.0, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0, & - & 0.16666666666666666667, 0.0, 0.16666666666666666667, & - & 0.66666666666666666667, 0.0, 0.16666666666666666667, & - & 0.16666666666666666667, 0.0, 0.66666666666666666667, & - & 0.33333333333333333333, 0.0, 0.16666666666666666667, & - & 0.5, 0.0, 0.16666666666666666667, & - & 0.5, 0.0, 0.33333333333333333333, & - & 0.33333333333333333333, 0.0, 0.5, & - & 0.16666666666666666667, 0.0, 0.5, & - & 0.16666666666666666667, 0.0, 0.33333333333333333333, & - & 0.33333333333333333333, 0.0, 0.33333333333333333333, & - & 0.0, 0.16666666666666666667, 0.16666666666666666667, & - & 0.0, 0.16666666666666666667, 0.66666666666666666667, & - & 0.0, 0.66666666666666666667, 0.16666666666666666667, & - & 0.0, 0.16666666666666666667, 0.33333333333333333333, & - & 0.0, 0.16666666666666666667, 0.5, & - & 0.0, 0.33333333333333333333, 0.5, & - & 0.0, 0.5, 0.33333333333333333333, & - & 0.0, 0.5, 0.16666666666666666667, & - & 0.0, 0.33333333333333333333, 0.16666666666666666667, & - & 0.0, 0.33333333333333333333, 0.33333333333333333333, & - & 0.16666666666666666667, 0.16666666666666666667, & - & 0.66666666666666666667, & - & 0.66666666666666666667, 0.16666666666666666667, & - & 0.16666666666666666667, & - & 0.16666666666666666667, 0.66666666666666666667, & - & 0.16666666666666666667, & - & 0.33333333333333333333, 0.16666666666666666667, 0.5, & - & 0.5, 0.16666666666666666667, 0.33333333333333333333, & - & 0.5, 0.33333333333333333333, 0.16666666666666666667, & - & 0.33333333333333333333, 0.5, 0.16666666666666666667, & - & 0.16666666666666666667, 0.5, 0.33333333333333333333, & - & 0.16666666666666666667, 0.33333333333333333333, 0.5, & - & 0.33333333333333333333, 0.33333333333333333333, & - & 0.33333333333333333333, & - & 0.16666666666666666667, 0.16666666666666666667, & - & 0.16666666666666666667, & - & 0.5, 0.16666666666666666667, 0.16666666666666666667, & - & 0.16666666666666666667, 0.5, 0.16666666666666666667, & - & 0.16666666666666666667, 0.16666666666666666667, 0.5, & - & 0.33333333333333333333, 0.16666666666666666667, & - & 0.16666666666666666667, & - & 0.33333333333333333333, 0.33333333333333333333, & - & 0.16666666666666666667, & - & 0.16666666666666666667, 0.33333333333333333333, & - & 0.16666666666666666667, & - & 0.16666666666666666667, 0.16666666666666666667, & - & 0.33333333333333333333, & - & 0.16666666666666666667, 0.33333333333333333333, & - & 0.33333333333333333333, & - & 0.33333333333333333333, 0.16666666666666666667, & - & 0.33333333333333333333], [3, 84]) -END SELECT - !! -END PROCEDURE EquidistanceLIP_Tetrahedron diff --git a/src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc b/src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc deleted file mode 100644 index 8b5bb1a8d..000000000 --- a/src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc +++ /dev/null @@ -1,403 +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 PROCEDURE EquidistanceLIP_Triangle - !! - !! Define internal variables - !! - INTEGER( I4B ) :: i - REAL( DFP ) :: x( 3 ), y( 3 ) - REAL( DFP ), ALLOCATABLE :: xi( : ), eta( : ) - !! - !! - !! - SELECT CASE( Order ) - !! - CASE( 1 ) - !! - !! order 1; Triangle3 - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP], [3, 3] ) - !! - CASE( 2 ) - !! - !! order 2, Triangle6 - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.5_DFP, 0.0_DFP, 0.0_DFP, & - & 0.5_DFP, 0.5_DFP, 0.0_DFP, & - & 0.0_DFP, 0.5_DFP, 0.0_DFP ], & - & [3, 6]) - !! - CASE( 3 ) - !! - !! order 3, Triangle10 - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.33333333333333333333_DFP, 0.0_DFP, 0.0_DFP, & - & 0.66666666666666666667_DFP, 0.0_DFP, 0.0_DFP, & - & 0.66666666666666666667_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & - & 0.33333333333333333333_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & - & 0.0_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & - & 0.0_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & - & 0.33333333333333333333_DFP, 0.33333333333333333333_DFP, 0.0_DFP], & - & [3, 10]) - !! - CASE( 4 ) - !! - !! order 4 Includes bubble nodes also - !! Trianagle15a - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.25_DFP, 0.0_DFP, 0.0_DFP, & - & 0.5_DFP, 0.0_DFP, 0.0_DFP, & - & 0.75_DFP, 0.0_DFP, 0.0_DFP, & - & 0.75_DFP, 0.25_DFP, 0.0_DFP, & - & 0.5_DFP, 0.5_DFP, 0.0_DFP, & - & 0.25_DFP, 0.75_DFP, 0.0_DFP, & - & 0.0_DFP, 0.75_DFP, 0.0_DFP, & - & 0.0_DFP, 0.5_DFP, 0.0_DFP, & - & 0.0_DFP, 0.25_DFP, 0.0_DFP, & - & 0.25_DFP, 0.25_DFP, 0.0_DFP, & - & 0.5_DFP, 0.25_DFP, 0.0_DFP, & - & 0.25_DFP, 0.5_DFP, 0.0_DFP], & - & [3, 15]) - !! - CASE( 5 ) - !! - !! This is fifth order triangle - !! 3 nodes on vertex, 12 nodes on edge, and 6 on the face - !! Triangle21 - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.2, 0.0, 0.0, & - & 0.4, 0.0, 0.0, & - & 0.6, 0.0, 0.0, & - & 0.8, 0.0, 0.0, & - & 0.8, 0.2, 0.0, & - & 0.6, 0.4, 0.0, & - & 0.4, 0.6, 0.0, & - & 0.2, 0.8, 0.0, & - & 0.0, 0.8, 0.0, & - & 0.0, 0.6, 0.0, & - & 0.0, 0.4, 0.0, & - & 0.0, 0.2, 0.0, & - & 0.2, 0.2, 0.0, & - & 0.6, 0.2, 0.0, & - & 0.2, 0.6, 0.0, & - & 0.4, 0.2, 0.0, & - & 0.4, 0.4, 0.0, & - & 0.2, 0.4, 0.0], [3, 21]) - !! - CASE( 6 ) - !! - !! Triangle28 - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.16666666666666666667, 0.0, 0.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.83333333333333333333, 0.0, 0.0, & - & 0.83333333333333333333, 0.16666666666666666667, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.16666666666666666667, 0.83333333333333333333, 0.0, & - & 0.0, 0.83333333333333333333, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.16666666666666666667, 0.0, & - & 0.66666666666666666667, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.66666666666666666667, 0.0, & - & 0.33333333333333333333, 0.16666666666666666667, 0.0, & - & 0.5, 0.16666666666666666667, 0.0, & - & 0.5, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.5, 0.0, & - & 0.16666666666666666667, 0.5, 0.0, & - & 0.16666666666666666667, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0], [3, 28] ) - !! - CASE( 7 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.14285714285714285714, 0.0, 0.0, & - & 0.28571428571428571429, 0.0, 0.0, & - & 0.42857142857142857143, 0.0, 0.0, & - & 0.57142857142857142857, 0.0, 0.0, & - & 0.71428571428571428571, 0.0, 0.0, & - & 0.85714285714285714286, 0.0, 0.0, & - & 0.85714285714285714286, 0.14285714285714285714, 0.0, & - & 0.71428571428571428571, 0.28571428571428571429, 0.0, & - & 0.57142857142857142857, 0.42857142857142857143, 0.0, & - & 0.42857142857142857143, 0.57142857142857142857, 0.0, & - & 0.28571428571428571429, 0.71428571428571428571, 0.0, & - & 0.14285714285714285714, 0.85714285714285714286, 0.0, & - & 0.0, 0.85714285714285714286, 0.0, & - & 0.0, 0.71428571428571428571, 0.0, & - & 0.0, 0.57142857142857142857, 0.0, & - & 0.0, 0.42857142857142857143, 0.0, & - & 0.0, 0.28571428571428571429, 0.0, & - & 0.0, 0.14285714285714285714, 0.0, & - & 0.14285714285714285714, 0.14285714285714285714, 0.0, & - & 0.71428571428571428571, 0.14285714285714285714, 0.0, & - & 0.14285714285714285714, 0.71428571428571428571, 0.0, & - & 0.28571428571428571429, 0.14285714285714285714, 0.0, & - & 0.42857142857142857143, 0.14285714285714285714, 0.0, & - & 0.57142857142857142857, 0.14285714285714285714, 0.0, & - & 0.57142857142857142857, 0.28571428571428571429, 0.0, & - & 0.42857142857142857143, 0.42857142857142857143, 0.0, & - & 0.28571428571428571429, 0.57142857142857142857, 0.0, & - & 0.14285714285714285714, 0.57142857142857142857, 0.0, & - & 0.14285714285714285714, 0.42857142857142857143, 0.0, & - & 0.14285714285714285714, 0.28571428571428571429, 0.0, & - & 0.28571428571428571429, 0.28571428571428571429, 0.0, & - & 0.42857142857142857143, 0.28571428571428571429, 0.0, & - & 0.28571428571428571429, 0.42857142857142857143, 0.0 ], [3,36]) - !! - CASE( 8 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.125, 0.0, 0.0, & - & 0.25, 0.0, 0.0, & - & 0.375, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.625, 0.0, 0.0, & - & 0.75, 0.0, 0.0, & - & 0.875, 0.0, 0.0, & - & 0.875, 0.125, 0.0, & - & 0.75, 0.25, 0.0, & - & 0.625, 0.375, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.375, 0.625, 0.0, & - & 0.25, 0.75, 0.0, & - & 0.125, 0.875, 0.0, & - & 0.0, 0.875, 0.0, & - & 0.0, 0.75, 0.0, & - & 0.0, 0.625, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.375, 0.0, & - & 0.0, 0.25, 0.0, & - & 0.0, 0.125, 0.0, & - & 0.125, 0.125, 0.0, & - & 0.75, 0.125, 0.0, & - & 0.125, 0.75, 0.0, & - & 0.25, 0.125, 0.0, & - & 0.375, 0.125, 0.0, & - & 0.5, 0.125, 0.0, & - & 0.625, 0.125, 0.0, & - & 0.625, 0.25, 0.0, & - & 0.5, 0.375, 0.0, & - & 0.375, 0.5, 0.0, & - & 0.25, 0.625, 0.0, & - & 0.125, 0.625, 0.0, & - & 0.125, 0.5, 0.0, & - & 0.125, 0.375, 0.0, & - & 0.125, 0.25, 0.0, & - & 0.25, 0.25, 0.0, & - & 0.5, 0.25, 0.0, & - & 0.25, 0.5, 0.0, & - & 0.375, 0.25, 0.0, & - & 0.375, 0.375, 0.0, & - & 0.25, 0.375, 0.0 ], [3, 45]) - !! - CASE( 9 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.11111111111111111111, 0.0, 0.0, & - & 0.22222222222222222222, 0.0, 0.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.44444444444444444444, 0.0, 0.0, & - & 0.55555555555555555556, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.77777777777777777778, 0.0, 0.0, & - & 0.88888888888888888889, 0.0, 0.0, & - & 0.88888888888888888889, 0.11111111111111111111, 0.0, & - & 0.77777777777777777778, 0.22222222222222222222, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.55555555555555555556, 0.44444444444444444444, 0.0, & - & 0.44444444444444444444, 0.55555555555555555556, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.22222222222222222222, 0.77777777777777777778, 0.0, & - & 0.11111111111111111111, 0.88888888888888888889, 0.0, & - & 0.0, 0.88888888888888888889, 0.0, & - & 0.0, 0.77777777777777777778, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.55555555555555555556, 0.0, & - & 0.0, 0.44444444444444444444, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.22222222222222222222, 0.0, & - & 0.0, 0.11111111111111111111, 0.0, & - & 0.11111111111111111111, 0.11111111111111111111, 0.0, & - & 0.77777777777777777778, 0.11111111111111111111, 0.0, & - & 0.11111111111111111111, 0.77777777777777777778, 0.0, & - & 0.22222222222222222222, 0.11111111111111111111, 0.0, & - & 0.33333333333333333333, 0.11111111111111111111, 0.0, & - & 0.44444444444444444444, 0.11111111111111111111, 0.0, & - & 0.55555555555555555556, 0.11111111111111111111, 0.0, & - & 0.66666666666666666667, 0.11111111111111111111, 0.0, & - & 0.66666666666666666667, 0.22222222222222222222, 0.0, & - & 0.55555555555555555556, 0.33333333333333333333, 0.0, & - & 0.44444444444444444444, 0.44444444444444444444, 0.0, & - & 0.33333333333333333333, 0.55555555555555555556, 0.0, & - & 0.22222222222222222222, 0.66666666666666666667, 0.0, & - & 0.11111111111111111111, 0.66666666666666666667, 0.0, & - & 0.11111111111111111111, 0.55555555555555555556, 0.0, & - & 0.11111111111111111111, 0.44444444444444444444, 0.0, & - & 0.11111111111111111111, 0.33333333333333333333, 0.0, & - & 0.11111111111111111111, 0.22222222222222222222, 0.0, & - & 0.22222222222222222222, 0.22222222222222222222, 0.0, & - & 0.55555555555555555556, 0.22222222222222222222, 0.0, & - & 0.22222222222222222222, 0.55555555555555555556, 0.0, & - & 0.33333333333333333333, 0.22222222222222222222, 0.0, & - & 0.44444444444444444444, 0.22222222222222222222, 0.0, & - & 0.44444444444444444444, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.44444444444444444444, 0.0, & - & 0.22222222222222222222, 0.44444444444444444444, 0.0, & - & 0.22222222222222222222, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0 ], [3,55] ) - !! - CASE( 10 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.1, 0.0, 0.0, & - & 0.2, 0.0, 0.0, & - & 0.3, 0.0, 0.0, & - & 0.4, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.6, 0.0, 0.0, & - & 0.7, 0.0, 0.0, & - & 0.8, 0.0, 0.0, & - & 0.9, 0.0, 0.0, & - & 0.9, 0.1, 0.0, & - & 0.8, 0.2, 0.0, & - & 0.7, 0.3, 0.0, & - & 0.6, 0.4, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.4, 0.6, 0.0, & - & 0.3, 0.7, 0.0, & - & 0.2, 0.8, 0.0, & - & 0.1, 0.9, 0.0, & - & 0.0, 0.9, 0.0, & - & 0.0, 0.8, 0.0, & - & 0.0, 0.7, 0.0, & - & 0.0, 0.6, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.4, 0.0, & - & 0.0, 0.3, 0.0, & - & 0.0, 0.2, 0.0, & - & 0.0, 0.1, 0.0, & - & 0.1, 0.1, 0.0, & - & 0.8, 0.1, 0.0, & - & 0.1, 0.8, 0.0, & - & 0.2, 0.1, 0.0, & - & 0.3, 0.1, 0.0, & - & 0.4, 0.1, 0.0, & - & 0.5, 0.1, 0.0, & - & 0.6, 0.1, 0.0, & - & 0.7, 0.1, 0.0, & - & 0.7, 0.2, 0.0, & - & 0.6, 0.3, 0.0, & - & 0.5, 0.4, 0.0, & - & 0.4, 0.5, 0.0, & - & 0.3, 0.6, 0.0, & - & 0.2, 0.7, 0.0, & - & 0.1, 0.7, 0.0, & - & 0.1, 0.6, 0.0, & - & 0.1, 0.5, 0.0, & - & 0.1, 0.4, 0.0, & - & 0.1, 0.3, 0.0, & - & 0.1, 0.2, 0.0, & - & 0.2, 0.2, 0.0, & - & 0.6, 0.2, 0.0, & - & 0.2, 0.6, 0.0, & - & 0.3, 0.2, 0.0, & - & 0.4, 0.2, 0.0, & - & 0.5, 0.2, 0.0, & - & 0.5, 0.3, 0.0, & - & 0.4, 0.4, 0.0, & - & 0.3, 0.5, 0.0, & - & 0.2, 0.5, 0.0, & - & 0.2, 0.4, 0.0, & - & 0.2, 0.3, 0.0, & - & 0.3, 0.3, 0.0, & - & 0.4, 0.3, 0.0, & - & 0.3, 0.4, 0.0 ], [3,66] ) - END SELECT - !! - !! - !! - IF( PRESENT( xij ) ) THEN - !! - ALLOCATE( xi( SIZE( nodecoord, 2 ) ), eta( SIZE( nodecoord, 2 ) ) ) - xi( : ) = nodecoord( 1, : ) - eta( : ) = nodecoord( 2, : ) - !! - x = xij( 1, 1:3 ) - y = xij( 2, 1:3 ) - !! - nodecoord( 1, : ) = x( 1 ) + ( x( 2 ) - x( 1 ) ) * xi & - & + ( x( 3 ) - x( 1 ) ) * eta - !! - nodecoord( 2, : ) = y( 1 ) + ( y( 2 ) - y( 1 ) ) * xi & - & + ( y( 3 ) - y( 1 ) ) * eta - !! - DEALLOCATE( xi, eta ) - !! - END IF - !! -END PROCEDURE EquidistanceLIP_Triangle \ No newline at end of file diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 deleted file mode 100644 index 4e1eb13d0..000000000 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,2950 +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(HexahedronInterpolationUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefElemDomain_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Hexahedron -ans = "BIUNIT" -END PROCEDURE RefElemDomain_Hexahedron - -!---------------------------------------------------------------------------- -! GetVertexDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetVertexDOF_Hexahedron -ans = 8_I4B -END PROCEDURE GetVertexDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeDOF_Hexahedron1 -ans = MAX(pe1 + pe2 + pe3 + pe4 - 4_I4B, 0_I4B) -END PROCEDURE GetEdgeDOF_Hexahedron1 - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeDOF_Hexahedron2 -ans = GetEdgeDOF_Hexahedron(p, p, p, p) & - & + GetEdgeDOF_Hexahedron(q, q, q, q) & - & + GetEdgeDOF_Hexahedron(r, r, r, r) -END PROCEDURE GetEdgeDOF_Hexahedron2 - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeDOF_Hexahedron3 -ans = GetEdgeDOF_Hexahedron(p, p, p) -END PROCEDURE GetEdgeDOF_Hexahedron3 - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeDOF_Hexahedron4 -ans = GetEdgeDOF_Hexahedron(px1, px2, px3, px4) & - & + GetEdgeDOF_Hexahedron(py1, py2, py3, py4) & - & + GetEdgeDOF_Hexahedron(pz1, pz2, pz3, pz4) -END PROCEDURE GetEdgeDOF_Hexahedron4 - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFacetDOF_Hexahedron1 -ans = GetFacetDOF_Hexahedron(pxy1, pxy2) & - & + GetFacetDOF_Hexahedron(pxz1, pxz2) & - & + GetFacetDOF_Hexahedron(pyz1, pyz2) -ans = 2_I4B * ans -END PROCEDURE GetFacetDOF_Hexahedron1 - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFacetDOF_Hexahedron2 -ans = GetFacetDOF_Hexahedron(p, q) & - & + GetFacetDOF_Hexahedron(p, r) & - & + GetFacetDOF_Hexahedron(q, r) -ans = ans * 2_I4B -END PROCEDURE GetFacetDOF_Hexahedron2 - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFacetDOF_Hexahedron3 -ans = (p - 1) * (q - 1) -END PROCEDURE GetFacetDOF_Hexahedron3 - -!---------------------------------------------------------------------------- -! GetFacetDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFacetDOF_Hexahedron4 -ans = GetFacetDOF_Hexahedron(p, p) * 6_I4B -END PROCEDURE GetFacetDOF_Hexahedron4 - -!---------------------------------------------------------------------------- -! GetCellDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetCellDOF_Hexahedron1 -ans = (p - 1) * (q - 1) * (r - 1) -END PROCEDURE GetCellDOF_Hexahedron1 - -!---------------------------------------------------------------------------- -! GetCellDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetCellDOF_Hexahedron2 -ans = GetCellDOF_Hexahedron(p, p, p) -END PROCEDURE GetCellDOF_Hexahedron2 - -!---------------------------------------------------------------------------- -! QuadratureNumber_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadratureNumber_Hexahedron -ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1) -ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2) -ans(3) = QuadratureNumber_Line(order=r, quadType=quadType3) -END PROCEDURE QuadratureNumber_Hexahedron - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeConnectivity_Hexahedron -CALL GetEdgeConnectivity_Hexahedron(con=ans) -END PROCEDURE EdgeConnectivity_Hexahedron - -!---------------------------------------------------------------------------- -! FacetConnectivity_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetConnectivity_Hexahedron -TYPE(String) :: baseInterpol0 -TYPE(String) :: baseContinuity0 - -baseInterpol0 = UpperCase(baseInterpol) -baseContinuity0 = UpperCase(baseContinuity) - -SELECT CASE (baseInterpol0%chars()) -CASE ( & - & "HIERARCHYPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHYPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION", & - & "ORTHOGONALPOLYNOMIAL", & - & "ORTHOGONAL", & - & "ORTHOGONALINTERPOLATION") - ans(:, 1) = [1, 2, 3, 4] ! back - ans(:, 2) = [5, 6, 7, 8] ! front - ans(:, 3) = [1, 4, 8, 5] ! left - ans(:, 4) = [2, 3, 7, 6] ! right - ans(:, 5) = [1, 2, 6, 5] ! bottom - ans(:, 6) = [4, 3, 7, 8] ! top -CASE DEFAULT - ans(:, 1) = [1, 4, 3, 2] ! back - ans(:, 2) = [5, 6, 7, 8] ! front - ans(:, 3) = [1, 5, 8, 4] ! left - ans(:, 4) = [2, 3, 7, 6] ! right - ans(:, 5) = [1, 2, 6, 5] ! bottom - ans(:, 6) = [3, 4, 8, 7] ! top -END SELECT - -END PROCEDURE FacetConnectivity_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeDegree_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Hexahedron1 -INTEGER(I4B) :: n, ii, jj, kk, indx -n = LagrangeDOF_Hexahedron(order=order) -ALLOCATE (ans(n, 3)) -indx = 0 -DO kk = 0, order - DO jj = 0, order - DO ii = 0, order - indx = indx + 1 - ans(indx, 1) = ii - ans(indx, 2) = jj - ans(indx, 3) = kk - END DO - END DO -END DO -END PROCEDURE LagrangeDegree_Hexahedron1 - -!---------------------------------------------------------------------------- -! LagrangeDegree_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Hexahedron2 -INTEGER(I4B) :: n, ii, jj, kk, indx -n = LagrangeDOF_Hexahedron(p=p, q=q, r=r) -ALLOCATE (ans(n, 3)) -indx = 0 -DO kk = 0, r - DO jj = 0, q - DO ii = 0, p - indx = indx + 1 - ans(indx, 1) = ii - ans(indx, 2) = jj - ans(indx, 3) = kk - END DO - END DO -END DO -END PROCEDURE LagrangeDegree_Hexahedron2 - -!---------------------------------------------------------------------------- -! GetTotalDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Hexahedron -ans = (order + 1)**3 -END PROCEDURE GetTotalDOF_Hexahedron - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Hexahedron -ans = (order - 1)**3 -END PROCEDURE GetTotalInDOF_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Hexahedron1 -ans = (order + 1)**3 -END PROCEDURE LagrangeDOF_Hexahedron1 - -!---------------------------------------------------------------------------- -! LagrangeDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Hexahedron2 -ans = (p + 1) * (q + 1) * (r + 1) -END PROCEDURE LagrangeDOF_Hexahedron2 - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Hexahedron1 -ans = (order - 1)**3 -END PROCEDURE LagrangeInDOF_Hexahedron1 - -!---------------------------------------------------------------------------- -! LagrangeDOF_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Hexahedron2 -ans = (p - 1) * (q - 1) * (r - 1) -END PROCEDURE LagrangeInDOF_Hexahedron2 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Hexahedron1 -ans = EquidistancePoint_Hexahedron2(p=order, q=order, r=order, xij=xij) -END PROCEDURE EquidistancePoint_Hexahedron1 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Hexahedron2 -! internal variables -REAL(DFP) :: x(p + 1), y(q + 1), z(r + 1), temp0 -REAL(DFP), DIMENSION(p + 1, q + 1, r + 1) :: xi, eta, zeta -REAL(DFP) :: temp(3, (p + 1) * (q + 1) * (r + 1)) -INTEGER(I4B) :: ii, jj, kk, nsd - -x = EquidistancePoint_Line(order=p, xij=[-1.0_DFP, 1.0_DFP]) -y = EquidistancePoint_Line(order=q, xij=[-1.0_DFP, 1.0_DFP]) -z = EquidistancePoint_Line(order=r, xij=[-1.0_DFP, 1.0_DFP]) -IF (p .GT. 0_I4B) THEN - temp0 = x(2) -END IF -DO ii = 2, p - x(ii) = x(ii + 1) -END DO -x(p + 1) = temp0 - -IF (q .GT. 0_I4B) THEN - temp0 = y(2) -END IF -DO ii = 2, q - y(ii) = y(ii + 1) -END DO -y(q + 1) = temp0 - -IF (r .GT. 0_I4B) THEN - temp0 = z(2) -END IF -DO ii = 2, r - z(ii) = z(ii + 1) -END DO -z(r + 1) = temp0 - -nsd = 3 -CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1)) - -DO ii = 1, p + 1 - DO jj = 1, q + 1 - DO kk = 1, r + 1 - xi(ii, jj, kk) = x(ii) - eta(ii, jj, kk) = y(jj) - zeta(ii, jj, kk) = z(kk) - END DO - END DO -END DO - -CALL IJK2VEFC_Hexahedron( & - & xi=xi, & - & eta=eta, & - & zeta=zeta, & - & temp=temp, & - & p=p, & - & q=q, & - & r=r) - -IF (PRESENT(xij)) THEN - ans = FromBiUnitHexahedron2Hexahedron( & - & xin=temp, & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8) & - & ) -ELSE - ans = temp -END IF - -END PROCEDURE EquidistancePoint_Hexahedron2 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Hexahedron1 -ans = EquidistanceInPoint_Hexahedron2(p=order, q=order, r=order, xij=xij) -END PROCEDURE EquidistanceInPoint_Hexahedron1 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Hexahedron2 -INTEGER(I4B) :: i1, i2, ii -REAL(DFP), ALLOCATABLE :: ans0(:, :) - -ans0 = EquidistancePoint_Hexahedron(p=p, q=q, r=r, xij=xij) -i1 = LagrangeDOF_Hexahedron(p=p, q=q, r=r) -i2 = LagrangeInDOF_Hexahedron(p=p, q=q, r=r) -CALL reallocate(ans, 3, i2) -ii = i1 - i2 -IF (ii + 1 .LE. SIZE(ans0, 2)) ans = ans0(:, ii + 1:) -IF (ALLOCATED(ans0)) DEALLOCATE (ans0) -END PROCEDURE EquidistanceInPoint_Hexahedron2 - -!---------------------------------------------------------------------------- -! InterpolationPoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Hexahedron1 -ans = InterpolationPoint_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & layout=layout, & - & ipType1=ipType, & - & ipType2=ipType, & - & ipType3=ipType, & - & alpha1=alpha, & - & alpha2=alpha, & - & alpha3=alpha, & - & beta1=beta, & - & beta2=beta, & - & beta3=beta, & - & lambda1=lambda, & - & lambda2=lambda, & - & lambda3=lambda, & - & xij=xij) -END PROCEDURE InterpolationPoint_Hexahedron1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Hexahedron2 -! internal variables -REAL(DFP) :: x(p + 1), y(q + 1), z(r + 1) -REAL(DFP), DIMENSION(p + 1, q + 1, r + 1) :: xi, eta, zeta -REAL(DFP), ALLOCATABLE :: temp(:, :) -INTEGER(I4B) :: ii, jj, kk, nsd, cnt -TYPE(String) :: astr - -astr = TRIM(UpperCase(layout)) - -x = InterpolationPoint_Line(order=p, ipType=ipType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, beta=beta1, lambda=lambda1 & - & ) - -y = InterpolationPoint_Line(order=q, ipType=ipType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, beta=beta2, lambda=lambda2 & - & ) - -z = InterpolationPoint_Line(order=r, ipType=ipType3, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha3, beta=beta3, lambda=lambda3 & - & ) - -nsd = 3 - -CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1)) -CALL Reallocate(temp, nsd, (p + 1) * (q + 1) * (r + 1)) - -xi = 0.0_DFP -eta = 0.0_DFP -zeta = 0.0_DFP - -DO ii = 1, p + 1 - DO jj = 1, q + 1 - DO kk = 1, r + 1 - xi(ii, jj, kk) = x(ii) - eta(ii, jj, kk) = y(jj) - zeta(ii, jj, kk) = z(kk) - END DO - END DO -END DO - -IF (astr%chars() .EQ. "VEFC") THEN - CALL IJK2VEFC_Hexahedron( & - & xi=xi, & - & eta=eta, & - & zeta=zeta, & - & temp=temp, & - & p=p, & - & q=q, & - & r=r) -ELSE - cnt = 0 - DO ii = 1, p + 1 - DO jj = 1, q + 1 - DO kk = 1, r + 1 - cnt = cnt + 1 - temp(1, cnt) = x(ii) - temp(2, cnt) = y(ii) - temp(3, cnt) = z(ii) - END DO - END DO - END DO -END IF - -IF (PRESENT(xij)) THEN - ans = FromBiUnitHexahedron2Hexahedron( & - & xin=temp, & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8) & - & ) -ELSE - ans = temp -END IF -END PROCEDURE InterpolationPoint_Hexahedron2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJK2VEFC_Hexahedron -! internal variables -INTEGER(I4B) :: cnt, ii, jj, kk, ll, N, & - & ii1, ii2, jj1, jj2, kk1, kk2, ijk(3, 8), & - & iedge, iface, p1, p2, dii, djj, dkk, startNode -INTEGER(I4B), PARAMETER :: tPoints = 8, tEdges = 12, tFacets = 6 -INTEGER(I4B) :: edgeConnectivity(2, tEdges) -INTEGER(I4B) :: facetConnectivity(4, tFacets) -REAL(DFP), ALLOCATABLE :: temp2d(:, :), temp_in(:, :) -REAL(DFP), ALLOCATABLE :: xi_in(:, :, :), eta_in(:, :, :), zeta_in(:, :, :) - -! vertices -IF (ALL([p, q, r] .EQ. 0_I4B)) THEN - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - RETURN -END IF - -N = (p + 1) * (q + 1) * (r + 1) -cnt = 0 - -ijk(:, 1) = [1, 1, 1] -ijk(:, 2) = [p + 1, 1, 1] -ijk(:, 3) = [p + 1, q + 1, 1] -ijk(:, 4) = [1, q + 1, 1] -ijk(:, 5) = [1, 1, r + 1] -ijk(:, 6) = [p + 1, 1, r + 1] -ijk(:, 7) = [p + 1, q + 1, r + 1] -ijk(:, 8) = [1, q + 1, r + 1] - -edgeConnectivity = EdgeConnectivity_Hexahedron( & - & baseInterpol="Lagrange", & - & baseContinuity="H1") - -facetConnectivity = FacetConnectivity_Hexahedron( & - & baseInterpol="Lagrange", & - & baseContinuity="H1") - -IF (ALL([p, q, r] .GE. 1_I4B)) THEN - DO ii = 1, 8 - cnt = cnt + 1 - temp(:, ii) = [& - & xi(ijk(1, ii), ijk(2, ii), ijk(3, ii)), & - & eta(ijk(1, ii), ijk(2, ii), ijk(3, ii)), & - & zeta(ijk(1, ii), ijk(2, ii), ijk(3, ii))] - END DO - - IF (ALL([p, q, r] .EQ. 1_I4B)) RETURN - -ELSE - - DO ii = 1, p + 1 - DO jj = 1, q + 1 - DO kk = 1, r + 1 - cnt = cnt + 1 - temp(:, cnt) = & - & [ & - & xi(ii, jj, kk), & - & eta(ii, jj, kk), & - & zeta(ii, jj, kk) & - & ] - END DO - END DO - END DO - -END IF - -IF (ALL([p, q, r] .GE. 1_I4B)) THEN - DO iedge = 1, tEdges - p1 = edgeConnectivity(1, iedge) - p2 = edgeConnectivity(2, iedge) - - IF (ijk(1, p1) .EQ. ijk(1, p2)) THEN - ii1 = ijk(1, p1) - ii2 = ii1 - dii = 1 - ELSE IF (ijk(1, p1) .LT. ijk(1, p2)) THEN - ii1 = ijk(1, p1) + 1 - ii2 = ijk(1, p2) - 1 - dii = 1 - ELSE IF (ijk(1, p1) .GT. ijk(1, p2)) THEN - ii1 = ijk(1, p1) - 1 - ii2 = ijk(1, p2) + 1 - dii = -1 - END IF - - IF (ijk(2, p1) .EQ. ijk(2, p2)) THEN - jj1 = ijk(2, p1) - jj2 = jj1 - djj = 1 - ELSE IF (ijk(2, p1) .LT. ijk(2, p2)) THEN - jj1 = ijk(2, p1) + 1 - jj2 = ijk(2, p2) - 1 - djj = 1 - ELSE IF (ijk(2, p1) .GT. ijk(2, p2)) THEN - jj1 = ijk(2, p1) - 1 - jj2 = ijk(2, p2) + 1 - djj = -1 - END IF - - IF (ijk(3, p1) .EQ. ijk(3, p2)) THEN - kk1 = ijk(3, p1) - kk2 = kk1 - dkk = 1 - ELSE IF (ijk(3, p1) .LT. ijk(3, p2)) THEN - kk1 = ijk(3, p1) + 1 - kk2 = ijk(3, p2) - 1 - dkk = 1 - ELSE IF (ijk(3, p1) .GT. ijk(3, p2)) THEN - kk1 = ijk(3, p1) - 1 - kk2 = ijk(3, p2) + 1 - dkk = -1 - END IF - - DO ii = ii1, ii2, dii - DO jj = jj1, jj2, djj - DO kk = kk1, kk2, dkk - cnt = cnt + 1 - temp(:, cnt) = [ & - & xi(ii, jj, kk), & - & eta(ii, jj, kk), & - & zeta(ii, jj, kk)] - END DO - END DO - END DO - END DO - - ! face 1, x-y, clockwise, startNode - kk = 1 - startNode = 1 - CALL Reallocate(temp2d, 2, (p + 1) * (q + 1)) - CALL IJ2VEFC_Quadrangle_Clockwise( & - & xi=xi(:, :, kk), & - & eta=eta(:, :, kk), & - & temp=temp2d, & - & p=p, & - & q=q, & - & startNode=startNode) - - IF ((p + 1) * (q + 1) .GE. 2 * (p + q) + 1) THEN - ii1 = cnt + 1 - ii2 = cnt + (p - 1) * (q - 1) - cnt = ii2 - temp(1:2, ii1:ii2) = temp2d(1:2, 2 * (p + q) + 1:) - temp(3, ii1:ii2) = zeta(1, 1, kk) !!-1.0_DFP ! TODO - END IF - - ! face 2, x-y, anticlockwise - kk = r + 1 - startNode = 1 - CALL IJ2VEFC_Quadrangle_AntiClockwise( & - & xi=xi(:, :, kk), & - & eta=eta(:, :, kk), & - & temp=temp2d, & - & p=p, & - & q=q, & - & startNode=startNode) - - IF ((p + 1) * (q + 1) .GE. 2 * (p + q) + 1) THEN - ii1 = cnt + 1 - ii2 = cnt + (p - 1) * (q - 1) - cnt = ii2 - temp(1:2, ii1:ii2) = temp2d(1:2, 2 * (p + q) + 1:) - temp(3, ii1:ii2) = zeta(1, 1, kk) !! 1.0_DFP ! TODO - END IF - - ! face-3 - ! z-y - ! clockwise - ii = 1 - startNode = 1 - CALL Reallocate(temp2d, 2, (r + 1) * (q + 1)) - CALL IJ2VEFC_Quadrangle_AntiClockwise( & - & xi=TRANSPOSE(zeta(ii, :, :)), & - & eta=TRANSPOSE(eta(ii, :, :)), & - & temp=temp2d, & - & p=r, & - & q=q, & - & startNode=startNode) - - IF ((r + 1) * (q + 1) .GE. 2 * (r + q) + 1) THEN - ii1 = cnt + 1 - ii2 = cnt + (r - 1) * (q - 1) - cnt = ii2 - temp(1, ii1:ii2) = xi(ii, 1, 1) !!-1.0_DFP - temp(2, ii1:ii2) = temp2d(2, 2 * (r + q) + 1:) - temp(3, ii1:ii2) = temp2d(1, 2 * (r + q) + 1:) - END IF - - ! face 4 - ! z-y - ! anticlockwise - ii = p + 1 - startNode = 1 - CALL IJ2VEFC_Quadrangle_Clockwise( & - & xi=TRANSPOSE(zeta(ii, :, :)), & - & eta=TRANSPOSE(eta(ii, :, :)), & - & temp=temp2d, & - & p=r, & - & q=q, & - & startNode=startNode) - - IF ((r + 1) * (q + 1) .GE. 2 * (r + q) + 1) THEN - ii1 = cnt + 1 - ii2 = cnt + (r - 1) * (q - 1) - cnt = ii2 - temp(1, ii1:ii2) = xi(ii, 1, 1) !!1.0_DFP ! TODO - temp(2, ii1:ii2) = temp2d(2, 2 * (r + q) + 1:) - temp(3, ii1:ii2) = temp2d(1, 2 * (r + q) + 1:) - END IF - - ! face 5 - ! z-x - ! anticlockwise - jj = q + 1 - startNode = 4 - CALL Reallocate(temp2d, 2, (r + 1) * (p + 1)) - CALL IJ2VEFC_Quadrangle_AntiClockwise( & - & xi=TRANSPOSE(zeta(:, jj, :)), & - & eta=TRANSPOSE(xi(:, jj, :)), & - & temp=temp2d, & - & p=r, & - & q=p, & - & startNode=startNode) - - IF ((r + 1) * (p + 1) .GE. 2 * (r + p) + 1) THEN - ii1 = cnt + 1 - ii2 = cnt + (r - 1) * (p - 1) - cnt = ii2 - temp(1, ii1:ii2) = temp2d(2, 2 * (r + p) + 1:) - temp(2, ii1:ii2) = eta(1, jj, 1) - temp(3, ii1:ii2) = temp2d(1, 2 * (r + p) + 1:) - END IF - - ! face 6 - ! z-x - ! clockwise - jj = 1 - startNode = 1 - CALL IJ2VEFC_Quadrangle_Clockwise( & - & xi=TRANSPOSE(zeta(:, jj, :)), & - & eta=TRANSPOSE(xi(:, jj, :)), & - & temp=temp2d, & - & p=r, & - & q=p, & - & startNode=startNode) - - IF ((r + 1) * (p + 1) .GE. 2 * (r + p) + 1) THEN - ii1 = cnt + 1 - ii2 = cnt + (r - 1) * (p - 1) - cnt = ii2 - temp(1, ii1:ii2) = temp2d(2, 2 * (r + p) + 1:) - temp(2, ii1:ii2) = eta(1, jj, 1) - temp(3, ii1:ii2) = temp2d(1, 2 * (r + p) + 1:) - END IF - - ! internal nodes - IF (ALL([p, q, r] .GE. 2_I4B)) THEN - - CALL Reallocate( & - & xi_in, & - & MAX(p - 1, 1_I4B), & - & MAX(q - 1_I4B, 1_I4B), & - & MAX(r - 1_I4B, 1_I4B)) - CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2), SIZE(xi_in, 3)) - CALL Reallocate(zeta_in, SIZE(xi_in, 1), SIZE(xi_in, 2), SIZE(xi_in, 3)) - CALL Reallocate(temp_in, 3, 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 - - IF (r .LE. 1_I4B) THEN - kk1 = 1 - kk2 = 1 - ELSE - kk1 = 2 - kk2 = r - END IF - - xi_in = xi(ii1:p, jj1:q, kk1:r) - eta_in = eta(ii1:p, jj1:q, kk1:r) - zeta_in = zeta(ii1:p, jj1:q, kk1:r) - - CALL IJK2VEFC_Hexahedron( & - & xi=xi_in, & - & eta=eta_in, & - & zeta=zeta_in, & - & temp=temp_in, & - & p=MAX(p - 2, 0_I4B), & - & q=MAX(q - 2, 0_I4B), & - & r=MAX(r - 2, 0_I4B)) - - ii1 = cnt + 1 - ii2 = ii1 + SIZE(temp_in, 2) - 1 - temp(1:3, ii1:ii2) = temp_in - END IF - -END IF - -END PROCEDURE IJK2VEFC_Hexahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Hexahedron1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info - -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) - -END PROCEDURE LagrangeCoeff_Hexahedron1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Hexahedron2 -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Hexahedron2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Hexahedron3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Hexahedron3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Hexahedron4 -INTEGER(I4B) :: basisType0, ii, jj, kk, indx -REAL(DFP) :: ans1(SIZE(xij, 2), 0:order) -REAL(DFP) :: ans2(SIZE(xij, 2), 0:order) -REAL(DFP) :: ans3(SIZE(xij, 2), 0:order) - -basisType0 = Input(default=Monomial, option=basisType) - -SELECT CASE (basisType0) -CASE (Monomial) - ans = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) - -CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) - - IF (basisType0 .EQ. Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron4", & - & line=__LINE__, & - & unitno=stderr) - STOP - END IF - END IF - - IF (basisType0 .EQ. Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron4", & - & line=__LINE__, & - & unitno=stderr) - STOP - END IF - END IF - - ans1 = EvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - - ans2 = EvalAllOrthopol( & - & n=order, & - & x=xij(2, :), & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - - ans3 = EvalAllOrthopol( & - & n=order, & - & x=xij(3, :), & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - - indx = 0 - DO kk = 0, order - DO jj = 0, order - DO ii = 0, order - indx = indx + 1 - ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk) - END DO - END DO - END DO - -CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType = "//tostring(basisType0), & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron4()", & - & line=__LINE__, & - & unitno=stderr) - STOP -END SELECT -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Hexahedron4 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Hexahedron5 -INTEGER(I4B) :: basisType0, ii, jj, kk, indx, basisType(3) -REAL(DFP) :: ans1(SIZE(xij, 2), 0:p) -REAL(DFP) :: ans2(SIZE(xij, 2), 0:q) -REAL(DFP) :: ans3(SIZE(xij, 2), 0:r) - -basisType(1) = input(default=Monomial, option=basisType1) -basisType(2) = input(default=Monomial, option=basisType2) -basisType(3) = input(default=Monomial, option=basisType3) - -basisType0 = basisType(1) -SELECT CASE (basisType0) -CASE (Monomial) - ans1 = LagrangeVandermonde(order=p, xij=xij(1:1, :), elemType=Line) - -CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) - - ans1 = EvalAllOrthopol( & - & n=p, & - & x=xij(1, :), & - & orthopol=basisType0, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType1", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron5", & - & line=__LINE__, & - & unitno=stderr) -END SELECT - -basisType0 = basisType(2) -SELECT CASE (basisType0) -CASE (Monomial) - ans2 = LagrangeVandermonde(order=q, xij=xij(2:2, :), elemType=Line) - -CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) - - ans2 = EvalAllOrthopol( & - & n=q, & - & x=xij(2, :), & - & orthopol=basisType0, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType2", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron5", & - & line=__LINE__, & - & unitno=stderr) -END SELECT - -basisType0 = basisType(3) -SELECT CASE (basisType0) -CASE (Monomial) - ans3 = LagrangeVandermonde(order=r, xij=xij(3:3, :), elemType=Line) - -CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) - - ans3 = EvalAllOrthopol( & - & n=r, & - & x=xij(3, :), & - & orthopol=basisType0, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) - -CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType3", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron5", & - & line=__LINE__, & - & unitno=stderr) -END SELECT - -indx = 0 -DO kk = 0, r - DO jj = 0, q - DO ii = 0, p - indx = indx + 1 - ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk) - END DO - END DO -END DO - -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Hexahedron5 - -!---------------------------------------------------------------------------- -! TensorProdBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Hexahedron1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), p + 1) -REAL(DFP) :: Q1(SIZE(xij, 2), q + 1) -REAL(DFP) :: R1(SIZE(xij, 2), r + 1) -INTEGER(I4B) :: ii, k1, k2, k3, cnt - -x = xij(1, :) -y = xij(2, :) -z = xij(3, :) - -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -Q1 = BasisEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -R1 = BasisEvalAll_Line( & - & order=r, & - & x=z, & - & refLine="BIUNIT", & - & basisType=basisType3, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) - -cnt = 0 - -DO k3 = 1, r + 1 - DO k2 = 1, q + 1 - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(:, cnt) = P1(:, k1) * Q1(:, k2) * R1(:, k3) - END DO - END DO -END DO - -END PROCEDURE TensorProdBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! TensorProdBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Hexahedron2 -REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z)) -INTEGER(I4B) :: ii, jj, cnt, kk - -xij = 0.0_DFP -cnt = 0 -DO ii = 1, SIZE(x) - DO jj = 1, SIZE(y) - DO kk = 1, SIZE(z) - cnt = cnt + 1 - xij(1, cnt) = x(ii) - xij(2, cnt) = y(jj) - xij(3, cnt) = z(kk) - END DO - END DO -END DO - -ans = TensorProdBasis_Hexahedron1( & - & p=p, & - & q=q, & - & r=r, & - & xij=xij, & - & basisType1=basisType1, & - & basisType2=basisType2, & - & basisType3=basisType3, & - & alpha1=alpha1, & - & alpha2=alpha2, & - & alpha3=alpha3, & - & beta1=beta1, & - & beta2=beta2, & - & beta3=beta3, & - & lambda1=lambda1, & - & lambda2=lambda2, & - & lambda3=lambda3) - -END PROCEDURE TensorProdBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! VertexBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Hexahedron1 -ans(:, 1) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP - y) * (1.0_DFP - z) -ans(:, 2) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP - y) * (1.0_DFP - z) -ans(:, 3) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP + y) * (1.0_DFP - z) -ans(:, 4) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP + y) * (1.0_DFP - z) -ans(:, 5) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP - y) * (1.0_DFP + z) -ans(:, 6) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP - y) * (1.0_DFP + z) -ans(:, 7) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP + y) * (1.0_DFP + z) -ans(:, 8) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP + y) * (1.0_DFP + z) -END PROCEDURE VertexBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! VertexBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Hexahedron2 -ans(:, 1) = L1(:, 0) * L2(:, 0) * L3(:, 0) -ans(:, 2) = L1(:, 1) * L2(:, 0) * L3(:, 0) -ans(:, 3) = L1(:, 1) * L2(:, 1) * L3(:, 0) -ans(:, 4) = L1(:, 0) * L2(:, 1) * L3(:, 0) -ans(:, 5) = L1(:, 0) * L2(:, 0) * L3(:, 1) -ans(:, 6) = L1(:, 1) * L2(:, 0) * L3(:, 1) -ans(:, 7) = L1(:, 1) * L2(:, 1) * L3(:, 1) -ans(:, 8) = L1(:, 0) * L2(:, 1) * L3(:, 1) -END PROCEDURE VertexBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! VertexBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Hexahedron3 -ans = VertexBasis_Hexahedron1( & - & x=xij(1, :), & - & y=xij(2, :), & - & z=xij(3, :) & - & ) -END PROCEDURE VertexBasis_Hexahedron3 - -!---------------------------------------------------------------------------- -! VertexBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasisGradient_Hexahedron2 -ans(:, 1, 1) = dL1(:, 0) * L2(:, 0) * L3(:, 0) -ans(:, 2, 1) = dL1(:, 1) * L2(:, 0) * L3(:, 0) -ans(:, 3, 1) = dL1(:, 1) * L2(:, 1) * L3(:, 0) -ans(:, 4, 1) = dL1(:, 0) * L2(:, 1) * L3(:, 0) -ans(:, 5, 1) = dL1(:, 0) * L2(:, 0) * L3(:, 1) -ans(:, 6, 1) = dL1(:, 1) * L2(:, 0) * L3(:, 1) -ans(:, 7, 1) = dL1(:, 1) * L2(:, 1) * L3(:, 1) -ans(:, 8, 1) = dL1(:, 0) * L2(:, 1) * L3(:, 1) - -ans(:, 1, 2) = L1(:, 0) * dL2(:, 0) * L3(:, 0) -ans(:, 2, 2) = L1(:, 1) * dL2(:, 0) * L3(:, 0) -ans(:, 3, 2) = L1(:, 1) * dL2(:, 1) * L3(:, 0) -ans(:, 4, 2) = L1(:, 0) * dL2(:, 1) * L3(:, 0) -ans(:, 5, 2) = L1(:, 0) * dL2(:, 0) * L3(:, 1) -ans(:, 6, 2) = L1(:, 1) * dL2(:, 0) * L3(:, 1) -ans(:, 7, 2) = L1(:, 1) * dL2(:, 1) * L3(:, 1) -ans(:, 8, 2) = L1(:, 0) * dL2(:, 1) * L3(:, 1) - -ans(:, 1, 3) = L1(:, 0) * L2(:, 0) * dL3(:, 0) -ans(:, 2, 3) = L1(:, 1) * L2(:, 0) * dL3(:, 0) -ans(:, 3, 3) = L1(:, 1) * L2(:, 1) * dL3(:, 0) -ans(:, 4, 3) = L1(:, 0) * L2(:, 1) * dL3(:, 0) -ans(:, 5, 3) = L1(:, 0) * L2(:, 0) * dL3(:, 1) -ans(:, 6, 3) = L1(:, 1) * L2(:, 0) * dL3(:, 1) -ans(:, 7, 3) = L1(:, 1) * L2(:, 1) * dL3(:, 1) -ans(:, 8, 3) = L1(:, 0) * L2(:, 1) * dL3(:, 1) -END PROCEDURE VertexBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! xEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xEdgeBasis_Hexahedron1 -REAL(DFP) :: L1(1:SIZE(x), 0:MAXVAL([pe1, pe2, pe3, pe4])) -INTEGER(I4B) :: maxP, k1, cnt - -maxP = SIZE(L1, 2) - 1_I4B -L1 = LobattoEvalAll(n=maxP, x=x) - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP - y) * (1.0_DFP - z) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP + y) * (1.0_DFP - z) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP - y) * (1.0_DFP + z) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP + y) * (1.0_DFP + z) -END DO - -END PROCEDURE xEdgeBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! xEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xEdgeBasis_Hexahedron2 -INTEGER(I4B) :: cnt, k1 - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 0) * L3(:, 0) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 1) * L3(:, 0) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 0) * L3(:, 1) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 1) * L3(:, 1) -END DO -END PROCEDURE xEdgeBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! xEdgeBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xEdgeBasisGradient_Hexahedron2 -INTEGER(I4B) :: cnt, k1 - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) * L3(:, 0) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) * L3(:, 0) - ans(:, cnt, 3) = L1(:, k1) * L2(:, 0) * dL3(:, 0) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) * L3(:, 0) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) * L3(:, 0) - ans(:, cnt, 3) = L1(:, k1) * L2(:, 1) * dL3(:, 0) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) * L3(:, 1) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) * L3(:, 1) - ans(:, cnt, 3) = L1(:, k1) * L2(:, 0) * dL3(:, 1) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) * L3(:, 1) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) * L3(:, 1) - ans(:, cnt, 3) = L1(:, k1) * L2(:, 1) * dL3(:, 1) -END DO -END PROCEDURE xEdgeBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! yEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE yEdgeBasis_Hexahedron1 -REAL(DFP) :: L2(1:SIZE(y), 0:MAXVAL([pe1, pe2, pe3, pe4])) -INTEGER(I4B) :: maxP, k1, cnt - -maxP = SIZE(L2, 2) - 1_I4B -L2 = LobattoEvalAll(n=maxP, x=y) - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP - x) * (1.0_DFP - z) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP + x) * (1.0_DFP - z) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP - x) * (1.0_DFP + z) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP + x) * (1.0_DFP + z) -END DO - -END PROCEDURE yEdgeBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! yEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE yEdgeBasis_Hexahedron2 -INTEGER(I4B) :: cnt, k1 - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L1(:, 0) * L3(:, 0) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L1(:, 1) * L3(:, 0) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L1(:, 0) * L3(:, 1) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L1(:, 1) * L3(:, 1) -END DO -END PROCEDURE yEdgeBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! yEdgeBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE yEdgeBasisGradient_Hexahedron2 -INTEGER(I4B) :: cnt, k1 - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 0) * L2(:, k1) * L3(:, 0) - ans(:, cnt, 2) = L1(:, 0) * dL2(:, k1) * L3(:, 0) - ans(:, cnt, 3) = L1(:, 0) * L2(:, k1) * dL3(:, 0) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 1) * L2(:, k1) * L3(:, 0) - ans(:, cnt, 2) = L1(:, 1) * dL2(:, k1) * L3(:, 0) - ans(:, cnt, 3) = L1(:, 1) * L2(:, k1) * dL3(:, 0) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 0) * L2(:, k1) * L3(:, 1) - ans(:, cnt, 2) = L1(:, 0) * dL2(:, k1) * L3(:, 1) - ans(:, cnt, 3) = L1(:, 0) * L2(:, k1) * dL3(:, 1) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 1) * L2(:, k1) * L3(:, 1) - ans(:, cnt, 2) = L1(:, 1) * dL2(:, k1) * L3(:, 1) - ans(:, cnt, 3) = L1(:, 1) * L2(:, k1) * dL3(:, 1) -END DO -END PROCEDURE yEdgeBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! zEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE zEdgeBasis_Hexahedron1 -REAL(DFP) :: L3(1:SIZE(y), 0:MAXVAL([pe1, pe2, pe3, pe4])) -INTEGER(I4B) :: maxP, k1, cnt - -maxP = SIZE(L3, 2) - 1_I4B -L3 = LobattoEvalAll(n=maxP, x=z) - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP - x) * (1.0_DFP - y) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP + x) * (1.0_DFP - y) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP - x) * (1.0_DFP + y) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP + x) * (1.0_DFP + y) -END DO -END PROCEDURE zEdgeBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! zEdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE zEdgeBasis_Hexahedron2 -INTEGER(I4B) :: cnt, k1 - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt) = L3(:, k1) * L1(:, 0) * L2(:, 0) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt) = L3(:, k1) * L1(:, 1) * L2(:, 0) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = L3(:, k1) * L1(:, 0) * L2(:, 1) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = L3(:, k1) * L1(:, 1) * L2(:, 1) -END DO -END PROCEDURE zEdgeBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! zEdgeBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE zEdgeBasisGradient_Hexahedron2 -INTEGER(I4B) :: cnt, k1 - -cnt = 0 -DO k1 = 2, pe1 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 0) * L2(:, 0) * L3(:, k1) - ans(:, cnt, 2) = L1(:, 0) * dL2(:, 0) * L3(:, k1) - ans(:, cnt, 3) = L1(:, 0) * L2(:, 0) * dL3(:, k1) -END DO - -DO k1 = 2, pe2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 1) * L2(:, 0) * L3(:, k1) - ans(:, cnt, 2) = L1(:, 1) * dL2(:, 0) * L3(:, k1) - ans(:, cnt, 3) = L1(:, 1) * L2(:, 0) * dL3(:, k1) -END DO - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 0) * L2(:, 1) * L3(:, k1) - ans(:, cnt, 2) = L1(:, 0) * dL2(:, 1) * L3(:, k1) - ans(:, cnt, 3) = L1(:, 0) * L2(:, 1) * dL3(:, k1) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 1) * L2(:, 1) * L3(:, k1) - ans(:, cnt, 2) = L1(:, 1) * dL2(:, 1) * L3(:, k1) - ans(:, cnt, 3) = L1(:, 1) * L2(:, 1) * dL3(:, k1) -END DO -END PROCEDURE zEdgeBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! EdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeBasis_Hexahedron1 -SELECT CASE (dim) -CASE (1_I4B) - ans = xEdgeBasis_Hexahedron1(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & - & x=x, y=y, z=z) -CASE (2_I4B) - ans = yEdgeBasis_Hexahedron1(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & - & x=x, y=y, z=z) -CASE (3_I4B) - ans = zEdgeBasis_Hexahedron1(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & - & x=x, y=y, z=z) -END SELECT -END PROCEDURE EdgeBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! EdgeBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeBasis_Hexahedron2 -SELECT CASE (dim) -CASE (1_I4B) - ans = xEdgeBasis_Hexahedron2(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & - & L1=L1, L2=L2, L3=L3) -CASE (2_I4B) - ans = yEdgeBasis_Hexahedron2(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & - & L1=L1, L2=L2, L3=L3) -CASE (3_I4B) - ans = zEdgeBasis_Hexahedron2(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & - & L1=L1, L2=L2, L3=L3) -END SELECT -END PROCEDURE EdgeBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! EdgeBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeBasisGradient_Hexahedron2 -SELECT CASE (dim) -CASE (1_I4B) - ans = xEdgeBasisGradient_Hexahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -CASE (2_I4B) - ans = yEdgeBasisGradient_Hexahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -CASE (3_I4B) - ans = zEdgeBasisGradient_Hexahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END SELECT -END PROCEDURE EdgeBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! xyFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xyFacetBasis_Hexahedron1 -REAL(DFP) :: L1(1:SIZE(x), 0:n1) -REAL(DFP) :: L2(1:SIZE(y), 0:n2) -INTEGER(I4B) :: k1, cnt, k2 - -L1 = LobattoEvalAll(n=n1, x=x) -L2 = LobattoEvalAll(n=n2, x=y) - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) * 0.5_DFP * (1.0_DFP - z) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) * 0.5_DFP * (1.0_DFP + z) - END DO -END DO -END PROCEDURE xyFacetBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! xyFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xyFacetBasis_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2 - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, 0) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, 1) - END DO -END DO -END PROCEDURE xyFacetBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! xyFacetBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xyFacetBasisGradient_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2 - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) * L3(:, 0) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) * L3(:, 0) - ans(:, cnt, 3) = L1(:, k1) * L2(:, k2) * dL3(:, 0) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) * L3(:, 1) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) * L3(:, 1) - ans(:, cnt, 3) = L1(:, k1) * L2(:, k2) * dL3(:, 1) - END DO -END DO -END PROCEDURE xyFacetBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! yzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE yzFacetBasis_Hexahedron1 -REAL(DFP) :: L2(1:SIZE(y), 0:n1) -REAL(DFP) :: L3(1:SIZE(z), 0:n2) -INTEGER(I4B) :: k1, cnt, k2 - -L2 = LobattoEvalAll(n=n1, x=y) -L3 = LobattoEvalAll(n=n2, x=z) - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP - x) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP + x) - END DO -END DO -END PROCEDURE yzFacetBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! yzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE yzFacetBasis_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2 - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L3(:, k2) * L1(:, 0) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L2(:, k1) * L3(:, k2) * L1(:, 1) - END DO -END DO -END PROCEDURE yzFacetBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! yzFacetBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE yzFacetBasisGradient_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2 - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 0) * L2(:, k1) * L3(:, k2) - ans(:, cnt, 2) = L1(:, 0) * dL2(:, k1) * L3(:, k2) - ans(:, cnt, 3) = L1(:, 0) * L2(:, k1) * dL3(:, k2) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 1) * L2(:, k1) * L3(:, k2) - ans(:, cnt, 2) = L1(:, 1) * dL2(:, k1) * L3(:, k2) - ans(:, cnt, 3) = L1(:, 1) * L2(:, k1) * dL3(:, k2) - END DO -END DO -END PROCEDURE yzFacetBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! xzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xzFacetBasis_Hexahedron1 -REAL(DFP) :: L1(1:SIZE(x), 0:n1) -REAL(DFP) :: L3(1:SIZE(z), 0:n2) -INTEGER(I4B) :: k1, cnt, k2 - -L1 = LobattoEvalAll(n=n1, x=x) -L3 = LobattoEvalAll(n=n2, x=z) - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP - y) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP + y) - END DO -END DO -END PROCEDURE xzFacetBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! xzFacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xzFacetBasis_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2 - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L3(:, k2) * L2(:, 0) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L3(:, k2) * L2(:, 1) - END DO -END DO -END PROCEDURE xzFacetBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! xzFacetBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE xzFacetBasisGradient_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2 - -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) * L3(:, k2) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) * L3(:, k2) - ans(:, cnt, 3) = L1(:, k1) * L2(:, 0) * dL3(:, k2) - END DO -END DO - -DO k1 = 2, n1 - DO k2 = 2, n2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) * L3(:, k2) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) * L3(:, k2) - ans(:, cnt, 3) = L1(:, k1) * L2(:, 1) * dL3(:, k2) - END DO -END DO -END PROCEDURE xzFacetBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! FacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetBasis_Hexahedron1 - -SELECT CASE (dim1) -CASE (1_I4B) - SELECT CASE (dim2) - CASE (2_I4B) - ans = xyFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) - CASE (3_I4B) - ans = xzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) - END SELECT -CASE (2_I4B) - SELECT CASE (dim2) - CASE (1_I4B) - ans = xyFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) - CASE (3_I4B) - ans = yzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) - END SELECT -CASE (3_I4B) - SELECT CASE (dim2) - CASE (1_I4B) - ans = xzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) - CASE (2_I4B) - ans = yzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) - END SELECT -END SELECT - -END PROCEDURE FacetBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! FacetBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetBasis_Hexahedron2 - -SELECT CASE (dim1) -CASE (1_I4B) - SELECT CASE (dim2) - CASE (2_I4B) - ans = xyFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) - CASE (3_I4B) - ans = xzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) - END SELECT -CASE (2_I4B) - SELECT CASE (dim2) - CASE (1_I4B) - ans = xyFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) - CASE (3_I4B) - ans = yzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) - END SELECT -CASE (3_I4B) - SELECT CASE (dim2) - CASE (1_I4B) - ans = xzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) - CASE (2_I4B) - ans = yzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) - END SELECT -END SELECT -END PROCEDURE FacetBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! FacetBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetBasisGradient_Hexahedron2 - -SELECT CASE (dim1) -CASE (1_I4B) - SELECT CASE (dim2) - CASE (2_I4B) - ans = xyFacetBasisGradient_Hexahedron2( & - & n1=n1, & - & n2=n2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) - CASE (3_I4B) - ans = xzFacetBasisGradient_Hexahedron2( & - & n1=n1, & - & n2=n2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) - END SELECT -CASE (2_I4B) - SELECT CASE (dim2) - CASE (1_I4B) - ans = xyFacetBasisGradient_Hexahedron2( & - & n1=n1, & - & n2=n2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) - CASE (3_I4B) - ans = yzFacetBasisGradient_Hexahedron2( & - & n1=n1, & - & n2=n2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) - END SELECT -CASE (3_I4B) - SELECT CASE (dim2) - CASE (1_I4B) - ans = xzFacetBasisGradient_Hexahedron2( & - & n1=n1, & - & n2=n2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) - CASE (2_I4B) - ans = yzFacetBasisGradient_Hexahedron2( & - & n1=n1, & - & n2=n2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) - END SELECT -END SELECT -END PROCEDURE FacetBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! CellBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Hexahedron1 -REAL(DFP) :: L1(1:SIZE(x), 0:n1) -REAL(DFP) :: L2(1:SIZE(y), 0:n2) -REAL(DFP) :: L3(1:SIZE(z), 0:n3) -INTEGER(I4B) :: k1, cnt, k2, k3 -L1 = LobattoEvalAll(n=n1, x=x) -L2 = LobattoEvalAll(n=n2, x=y) -L3 = LobattoEvalAll(n=n3, x=z) -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - DO k3 = 2, n3 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, k3) - END DO - END DO -END DO -END PROCEDURE CellBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! CellBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2, k3 -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - DO k3 = 2, n3 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, k3) - END DO - END DO -END DO -END PROCEDURE CellBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! CellBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasisGradient_Hexahedron2 -INTEGER(I4B) :: k1, cnt, k2, k3 -cnt = 0 -DO k1 = 2, n1 - DO k2 = 2, n2 - DO k3 = 2, n3 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) * L3(:, k3) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) * L3(:, k3) - ans(:, cnt, 3) = L1(:, k1) * L2(:, k2) * dL3(:, k3) - END DO - END DO -END DO -END PROCEDURE CellBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Hexahedron1 - -#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1]) -#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1]) -#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2]) - -INTEGER(I4B) :: a, b, maxP, maxQ, maxR -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_) -REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_) - -#undef _maxP_ -#undef _maxQ_ -#undef _maxR_ - -maxP = SIZE(L1, 2) - 1 -maxQ = SIZE(L2, 2) - 1 -maxR = SIZE(L3, 2) - 1 - -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) -L3 = LobattoEvalAll(n=maxR, x=xij(3, :)) - -! Vertex basis function - -ans(:, 1:8) = VertexBasis_Hexahedron2(L1=L1, L2=L2, L3=L3) - -! Edge basis function - -b = 8 - -IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + px1 + px2 + px3 + px4 - 4 - ans(:, a:b) = xEdgeBasis_Hexahedron2( & - & pe1=px1, pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3) -END IF - -IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + py1 + py2 + py3 + py4 - 4 - ans(:, a:b) = yEdgeBasis_Hexahedron2( & - & pe1=py1, pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3) -END IF - -IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4 - ans(:, a:b) = zEdgeBasis_Hexahedron2( & - & pe1=pz1, pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3) -END IF - -! Facet basis function - -IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1) - ans(:, a:b) = xyFacetBasis_Hexahedron2( & - & n1=pxy1, n2=pxy2, L1=L1, L2=L2, L3=L3) -END IF - -IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1) - ans(:, a:b) = xzFacetBasis_Hexahedron2( & - & n1=pxz1, n2=pxz2, L1=L1, L2=L2, L3=L3) -END IF - -IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1) - ans(:, a:b) = yzFacetBasis_Hexahedron2( & - & n1=pyz1, n2=pyz2, L1=L1, L2=L2, L3=L3) -END IF - -IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1) - ans(:, a:b) = cellBasis_Hexahedron2( & - & n1=pb1, n2=pb2, n3=pb3, L1=L1, L2=L2, L3=L3) -END IF -END PROCEDURE HeirarchicalBasis_Hexahedron1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Hexahedron2 -ans = HeirarchicalBasis_Hexahedron1(& - & pb1=p, pb2=q, pb3=r, & - & pxy1=p, pxy2=q, & - & pxz1=p, pxz2=r, & - & pyz1=q, pyz2=r, & - & px1=p, px2=p, px3=p, px4=p, & - & py1=q, py2=q, py3=q, py4=q, & - & pz1=r, pz2=r, pz3=r, pz4=r, & - & xij=xij) -END PROCEDURE HeirarchicalBasis_Hexahedron2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Hexahedron1 -ans = QuadraturePoint_Hexahedron2( & - & p=order, & - & q=order, & - & r=order, & - & quadType1=quadType, & - & quadType2=quadType, & - & quadType3=quadType, & - & refHexahedron=refHexahedron, & - & xij=xij, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda & - & ) -END PROCEDURE QuadraturePoint_Hexahedron1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Hexahedron2 -! internal variables -REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), z(:, :), temp(:, :) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt -TYPE(String) :: astr - -astr = UpperCase(refHexahedron) - -x = QuadraturePoint_Line( & - & order=p, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) -np = SIZE(x, 2) - -y = QuadraturePoint_Line( & - & order=q, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) -nq = SIZE(y, 2) - -z = QuadraturePoint_Line( & - & order=r, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) -nr = SIZE(z, 2) - -nsd = 3 -CALL Reallocate(ans, 4_I4B, np * nq * nr) -CALL Reallocate(temp, 4_I4B, np * nq * nr) - -cnt = 0 -DO ii = 1, np - DO jj = 1, nq - DO kk = 1, nr - cnt = cnt + 1 - temp(1, cnt) = x(1, ii) - temp(2, cnt) = y(1, jj) - temp(3, cnt) = z(1, kk) - temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk) - END DO - END DO -END DO - -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( & - & xin=temp(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8) & - & ) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="HEXAHEDRON", xij=xij) - -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( & - & xin=temp(1:3, :)) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF -END IF - -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(x)) DEALLOCATE (x) -IF (ALLOCATED(y)) DEALLOCATE (y) -IF (ALLOCATED(z)) DEALLOCATE (z) - -END PROCEDURE QuadraturePoint_Hexahedron2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Hexahedron3 -ans = QuadraturePoint_Hexahedron4( & - & nipsx=nips, & - & nipsy=nips, & - & nipsz=nips, & - & quadType1=quadType, & - & quadType2=quadType, & - & quadType3=quadType, & - & refHexahedron=refHexahedron, & - & xij=xij, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda & - & ) -END PROCEDURE QuadraturePoint_Hexahedron3 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Hexahedron4 -! internal variables -REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), z(2, nipsz(1)), & -& temp(4, nipsy(1) * nipsx(1) * nipsz(1)) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt -TYPE(String) :: astr - -astr = UpperCase(refHexahedron) - -x = QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) -np = SIZE(x, 2) - -y = QuadraturePoint_Line( & - & nips=nipsy, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) -nq = SIZE(y, 2) - -z = QuadraturePoint_Line( & - & nips=nipsz, & - & quadType=quadType3, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) -nr = SIZE(z, 2) - -nsd = 3 -CALL Reallocate(ans, 4_I4B, np * nq * nr) - -cnt = 0 -DO ii = 1, np - DO jj = 1, nq - DO kk = 1, nr - cnt = cnt + 1 - temp(1, cnt) = x(1, ii) - temp(2, cnt) = y(1, jj) - temp(3, cnt) = z(1, kk) - temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk) - END DO - END DO -END DO - -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( & - & xin=temp(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8) & - & ) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="HEXAHEDRON", xij=xij) - -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( & - & xin=temp(1:3, :)) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF -END IF - -END PROCEDURE QuadraturePoint_Hexahedron4 - -!---------------------------------------------------------------------------- -! LagrangeEvallAll_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Hexahedron1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = TRANSPOSE(coeff) - ELSE - coeff0 = TRANSPOSE(coeff) - END IF -ELSE - coeff0 = TRANSPOSE( & - & LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & )) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Hexahedron(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Hexahedron1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 1, tdof - xx(1, ii) = x(1)**degree(ii, 1) & - & * x(2)**degree(ii, 2) & - & * x(3)**degree(ii, 3) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=RESHAPE(x, [3, 1])) - -CASE DEFAULT - - xx = TensorProdBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=RESHAPE(x, [3, 1]), & - & basisType1=basisType0, & - & basisType2=basisType0, & - & basisType3=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda & - & ) - -END SELECT - -ans = MATMUL(coeff0, xx(1, :)) - -END PROCEDURE LagrangeEvalAll_Hexahedron1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Hexahedron2 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) -REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = coeff - ELSE - coeff0 = coeff - END IF -ELSE - coeff0 = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Hexahedron(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Hexahedron1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 1, tdof - xx(:, ii) = x(1, :)**degree(ii, 1) & - & * x(2, :)**degree(ii, 2) & - & * x(3, :)**degree(ii, 3) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=x) - -CASE DEFAULT - - xx = TensorProdBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=x, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & basisType3=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda) - -END SELECT - -ans = MATMUL(xx, coeff0) - -END PROCEDURE LagrangeEvalAll_Hexahedron2 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Hexahedron1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci -INTEGER(I4B) :: degree(SIZE(xij, 2), 3), d1, d2, d3 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - END IF - coeff0 = coeff -ELSE - coeff0 = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - degree = LagrangeDegree_Hexahedron(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Hexahedron1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 1, tdof - d1 = degree(ii, 1) - d2 = degree(ii, 2) - d3 = degree(ii, 3) - - ai = MAX(d1 - 1_I4B, 0_I4B) - bi = MAX(d2 - 1_I4B, 0_I4B) - ci = MAX(d3 - 1_I4B, 0_I4B) - - ar = REAL(d1, DFP) - br = REAL(d2, DFP) - cr = REAL(d3, DFP) - - xx(:, ii, 1) = (ar * x(1, :)**ai) * & - & x(2, :)**d2 * & - & x(3, :)**d3 - - xx(:, ii, 2) = x(1, :)**d1 * & - & (br * x(2, :)**bi) * & - & x(3, :)**d3 - - xx(:, ii, 3) = x(1, :)**d1 * & - & x(2, :)**d2 * & - & (cr * x(3, :)**ci) - - END DO - -CASE (Heirarchical) - xx = HeirarchicalBasisGradient_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=x) - -CASE DEFAULT - xx = OrthogonalBasisGradient_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=x, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & basisType3=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda) - -END SELECT - -DO ii = 1, 3 - ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) -END DO - -END PROCEDURE LagrangeGradientEvalAll_Hexahedron1 - -!---------------------------------------------------------------------------- -! TensorProdBasisGradient_Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), p + 1) -REAL(DFP) :: Q1(SIZE(xij, 2), q + 1) -REAL(DFP) :: R1(SIZE(xij, 2), r + 1) -REAL(DFP) :: dP1(SIZE(xij, 2), p + 1) -REAL(DFP) :: dQ1(SIZE(xij, 2), q + 1) -REAL(DFP) :: dR1(SIZE(xij, 2), r + 1) - -INTEGER(I4B) :: ii, k1, k2, k3, cnt - -x = xij(1, :) -y = xij(2, :) -z = xij(3, :) - -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -Q1 = BasisEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -R1 = BasisEvalAll_Line( & - & order=r, & - & x=z, & - & refLine="BIUNIT", & - & basisType=basisType3, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) - -dP1 = BasisGradientEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -dQ1 = BasisGradientEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -dR1 = BasisGradientEvalAll_Line( & - & order=r, & - & x=z, & - & refLine="BIUNIT", & - & basisType=basisType3, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) - -cnt = 0 - -DO k3 = 1, r + 1 - DO k2 = 1, q + 1 - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2) * R1(:, k3) - ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2) * R1(:, k3) - ans(:, cnt, 3) = P1(:, k1) * Q1(:, k2) * dR1(:, k3) - END DO - END DO -END DO -END PROCEDURE TensorProdBasisGradient_Hexahedron1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Hexahedron1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron1 -#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1]) -#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1]) -#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2]) - -INTEGER(I4B) :: a, b, maxP, maxQ, maxR -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_) -REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_) -REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:_maxP_) -REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:_maxQ_) -REAL(DFP) :: dL3(1:SIZE(xij, 2), 0:_maxR_) - -#undef _maxP_ -#undef _maxQ_ -#undef _maxR_ - -maxP = SIZE(L1, 2) - 1 -maxQ = SIZE(L2, 2) - 1 -maxR = SIZE(L3, 2) - 1 - -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) -L3 = LobattoEvalAll(n=maxR, x=xij(3, :)) - -dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :)) -dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :)) -dL3 = LobattoGradientEvalAll(n=maxR, x=xij(3, :)) - -! Vertex basis function -ans(:, 1:8, :) = VertexBasisGradient_Hexahedron2( & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) - -! Edge basis function -b = 8 - -IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + px1 + px2 + px3 + px4 - 4 - ans(:, a:b, :) = xEdgeBasisGradient_Hexahedron2( & - & pe1=px1, & - & pe2=px2, & - & pe3=px3, & - & pe4=px4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END IF - -IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + py1 + py2 + py3 + py4 - 4 - ans(:, a:b, :) = yEdgeBasisGradient_Hexahedron2( & - & pe1=py1, & - & pe2=py2, & - & pe3=py3, & - & pe4=py4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END IF - -IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4 - ans(:, a:b, :) = zEdgeBasisGradient_Hexahedron2( & - & pe1=pz1, & - & pe2=pz2, & - & pe3=pz3, & - & pe4=pz4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END IF - -! Facet basis function - -IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1) - ans(:, a:b, :) = xyFacetBasisGradient_Hexahedron2( & - & n1=pxy1, & - & n2=pxy2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END IF - -IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1) - ans(:, a:b, :) = xzFacetBasisGradient_Hexahedron2( & - & n1=pxz1, & - & n2=pxz2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END IF - -IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1) - ans(:, a:b, :) = yzFacetBasisGradient_Hexahedron2( & - & n1=pyz1, & - & n2=pyz2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END IF - -IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1) - ans(:, a:b, :) = cellBasisGradient_Hexahedron2( & - & n1=pb1, & - & n2=pb2, & - & n3=pb3, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) -END IF -END PROCEDURE HeirarchicalBasisGradient_Hexahedron1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Hexahedron2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron2 -ans = HeirarchicalBasisGradient_Hexahedron1(& - & pb1=p, pb2=q, pb3=r, & - & pxy1=p, pxy2=q, & - & pxz1=p, pxz2=r, & - & pyz1=q, pyz2=r, & - & px1=p, px2=p, px3=p, px4=p, & - & py1=q, py2=q, py3=q, py4=q, & - & pz1=r, pz2=r, pz3=r, pz4=r, & - & xij=xij) -END PROCEDURE HeirarchicalBasisGradient_Hexahedron2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 deleted file mode 100644 index 93e179fd5..000000000 --- a/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 +++ /dev/null @@ -1,149 +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(InterpolationUtility) Methods -USE GlobalData, ONLY: Point, Line, Triangle, Quadrangle, & - Tetrahedron, Hexahedron, Prism, Pyramid - -USE ReferenceElement_Method, ONLY: ElementTopology -USE LineInterpolationUtility, ONLY: GetTotalDOF_Line, & - GetTotalInDOF_Line -USE TriangleInterpolationUtility, ONLY: GetTotalDOF_Triangle, & - GetTotalInDOF_Triangle -USE QuadrangleInterpolationUtility, ONLY: GetTotalDOF_Quadrangle, & - GetTotalInDOF_Quadrangle -USE TetrahedronInterpolationUtility, ONLY: GetTotalDOF_Tetrahedron, & - GetTotalInDOF_Tetrahedron -USE HexahedronInterpolationUtility, ONLY: GetTotalDOF_Hexahedron, & - GetTotalInDOF_Hexahedron -USE PrismInterpolationUtility, ONLY: GetTotalDOF_Prism, & - GetTotalInDOF_Prism -USE PyramidInterpolationUtility, ONLY: GetTotalDOF_Pyramid, & - GetTotalInDOF_Pyramid - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! VandermondeMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VandermondeMatrix_Real32 -INTEGER(I4B) :: ii -ans(:, 1) = 1.0_REAL32 -DO ii = 2, order + 1 - ans(:, ii) = x**(ii - 1) -END DO -END PROCEDURE VandermondeMatrix_Real32 - -!---------------------------------------------------------------------------- -! VandermondeMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VandermondeMatrix_Real64 -INTEGER(I4B) :: ii -ans(:, 1) = 1.0_REAL64 -DO ii = 2, order + 1 - ans(:, ii) = x**(ii - 1) -END DO -END PROCEDURE VandermondeMatrix_Real64 - -!---------------------------------------------------------------------------- -! VandermondeMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF1 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - ans = 0 -CASE (Line) - ans = GetTotalDOF_Line(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Triangle) - ans = GetTotalDOF_Triangle(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Quadrangle) - ans = GetTotalDOF_Quadrangle(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Tetrahedron) - ans = GetTotalDOF_Tetrahedron(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) -CASE (Hexahedron) - ans = GetTotalDOF_Hexahedron(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Prism) - ans = GetTotalDOF_Prism(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Pyramid) - ans = GetTotalDOF_Pyramid(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) -END SELECT - -END PROCEDURE GetTotalDOF1 - -!---------------------------------------------------------------------------- -! VandermondeMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF1 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - ans = 0 -CASE (Line) - ans = GetTotalInDOF_Line(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Triangle) - ans = GetTotalInDOF_Triangle(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Quadrangle) - ans = GetTotalInDOF_Quadrangle(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Tetrahedron) - ans = GetTotalInDOF_Tetrahedron(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) -CASE (Hexahedron) - ans = GetTotalInDOF_Hexahedron(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Prism) - ans = GetTotalInDOF_Prism(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) - -CASE (Pyramid) - ans = GetTotalInDOF_Pyramid(order=order, baseContinuity=baseContinuity, & - baseInterpolation=baseInterpolation) -END SELECT - -END PROCEDURE GetTotalInDOF1 - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 deleted file mode 100644 index 676683b43..000000000 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ /dev/null @@ -1,1415 +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(JacobiPolynomialUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! JacobiAlpha -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiAlpha -IF (n .EQ. 0) THEN - ans = (beta - alpha) / (alpha + beta + 2.0_DFP) -ELSE - ans = (beta**2 - alpha**2) / (alpha + beta + 2.0_DFP * n) & - & / (alpha + beta + 2.0_DFP + 2.0_DFP * n) -END IF -END PROCEDURE JacobiAlpha - -!---------------------------------------------------------------------------- -! JacobiBeta -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiBeta -IF (n .EQ. 0) THEN - ans = 2.0_DFP**(alpha + beta + 1.0_DFP) * GAMMA(alpha + 1.0_DFP) & - & * GAMMA(beta + 1.0_DFP) & - & / GAMMA(alpha + beta + 2.0_DFP) -ELSEIF (n .EQ. 1) THEN - ans = 4.0_DFP * (1.0_DFP + alpha) * (1.0_DFP + beta) / & - & (alpha + beta + 2.0_DFP)**2 / (alpha + beta + 3.0_DFP) -ELSE - ans = 4.0_DFP * n * (n + alpha) * (n + beta) * (n + alpha + beta) & - & / (alpha + beta + 2.0_DFP * n)**2 / (alpha + beta + 1.0_DFP + 2.0 * n) & - & / (alpha + beta - 1.0_DFP + 2.0 * n) -END IF -END PROCEDURE JacobiBeta - -!---------------------------------------------------------------------------- -! GetJacobiRecurrenceCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetJacobiRecurrenceCoeff -REAL(DFP), PARAMETER :: two = 2.0_DFP, four = 4.0_DFP -REAL(DFP) :: ab1, ab, ab2, abm1, bma, ab3, b2ma2, ab4 -INTEGER(I4B) :: ii - !! -IF (n .LE. 0) RETURN - !! -ab = alpha + beta -ab1 = ab + 1.0_DFP -abm1 = ab - 1.0_DFP -bma = beta - alpha -ab2 = ab1 + 1.0_DFP -ab3 = ab2 + 1.0_DFP -ab4 = ab3 + 1.0_DFP -b2ma2 = beta * beta - alpha * alpha - !! - !! beta 0 - !! -betaCoeff(0) = two**(ab1) * GAMMA(alpha + 1.0_DFP) & - & * GAMMA(beta + 1.0_DFP) & - & / GAMMA(ab1 + 1.0_DFP) - !! - !! alpha 0 - !! -alphaCoeff(0) = bma / ab2 - !! - !! RETURN IF n = 1 - !! -IF (n .EQ. 1) RETURN - !! -betaCoeff(1) = four * (1.0_DFP + alpha) * (1.0_DFP + beta) / (ab2 * ab2 * ab3) -alphaCoeff(1) = b2ma2 / (ab2 * ab4) - !! - !! Now it safe to compute other coefficients - !! -DO ii = 2, n - 1 - !! - betaCoeff(ii) = four * ii * (ii + alpha) * (ii + beta) * (ii + ab) & - & / (ab + 2.0 * ii)**2 / (ab1 + 2.0 * ii) / (abm1 + 2.0 * ii) - !! - alphaCoeff(ii) = b2ma2 / (ab + 2.0 * ii) / (ab2 + 2.0 * ii) - !! -END DO - !! -END PROCEDURE GetJacobiRecurrenceCoeff - -!---------------------------------------------------------------------------- -! GetJacobiRecurrenceCoeff2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetJacobiRecurrenceCoeff2 -REAL(DFP) :: j -INTEGER(I4B) :: ii -!! -IF (n .LT. 1) RETURN -A(0) = 0.5_DFP * (alpha + beta + 2.0_DFP) -B(0) = -A(0) * JacobiAlpha(n=0_I4B, alpha=alpha, beta=beta) -j = JacobiBeta(n=0_I4B, alpha=alpha, beta=beta) -C(0) = SQRT(j) * A(0) -!! -IF (n .EQ. 1) RETURN -!! -DO ii = 2, n - j = REAL(ii, KIND=DFP) - A(ii-1) = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); - B(ii - 1) = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - C(ii - 1) = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); -END DO -!! -END PROCEDURE GetJacobiRecurrenceCoeff2 - -!---------------------------------------------------------------------------- -! JacobiLeadingCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiLeadingCoeff -ans = GAMMA(2.0_DFP * n + alpha + beta + 1.0_DFP) / GAMMA(n + 1.0_DFP) / & - & GAMMA(n + alpha + beta + 1.0_DFP) / 2.0_DFP**n -END PROCEDURE JacobiLeadingCoeff - -!---------------------------------------------------------------------------- -! JacobiLeadingCoeffRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiLeadingCoeffRatio -REAL(DFP) :: a1, a2, rn -IF (n .EQ. 0) THEN - ans = 0.5_DFP * (alpha + beta + 2.0_DFP) -ELSE - rn = REAL(n, KIND=DFP) - a1 = 2.0_DFP * rn + alpha + beta + 1.0_DFP - ans = 0.5_DFP * a1 * (a1 + 1.0_DFP) / (rn + 1.0_DFP) / (a1 - rn) -END IF -END PROCEDURE JacobiLeadingCoeffRatio - -!---------------------------------------------------------------------------- -! JacobiNormSqr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiNormSqr -REAL(DFP) :: a1, a2, a3, b1, b2, b3 -a1 = 2.0**(alpha + beta + 1.0_DFP) -a2 = GAMMA(n + alpha + 1.0_DFP) -a3 = GAMMA(n + beta + 1.0_DFP) -b1 = 2.0_DFP * n + alpha + beta + 1.0_DFP -b2 = Factorial(n) -b3 = GAMMA(n + alpha + beta + 1.0_DFP) -ans = a1 * a2 * a3 / b1 / b2 / b3 -END PROCEDURE JacobiNormSqr - -!---------------------------------------------------------------------------- -! JacobiNormSqr2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiNormSqr2 -REAL(DFP) :: rn, s -INTEGER(I4B) :: ii -!! -ans(0) = JacobiNormSQR(n=0_I4B, alpha=alpha, beta=beta) -!! -IF (n .EQ. 0) RETURN -!! -s = JacobiNormSQRRatio(n=0_I4B, alpha=alpha, beta=beta) -ans(1) = ans(0) * s -!! -DO ii = 1, n - 1 - rn = REAL(ii, KIND=DFP) - s = (rn + alpha + 1.0_DFP) * (rn + beta + 1.0_DFP) * & - & (2.0_DFP * rn + alpha + beta + 1.0_DFP) / (rn + 1.0_DFP) & - & / (2.0_DFP * rn + alpha + beta + 3.0_DFP) & - & / (rn + alpha + beta + 1.0_DFP) - ans(ii + 1) = s * ans(ii) -END DO -END PROCEDURE JacobiNormSqr2 - -!---------------------------------------------------------------------------- -! JacobiNormSqrRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiNormSqrRatio -REAL(DFP) :: rn -IF (n .EQ. 0) THEN - ans = (1.0_DFP + alpha) * (1.0_DFP + beta) / (3.0_DFP + alpha + beta) -ELSE - rn = REAL(n, KIND=DFP) - ans = (rn + alpha + 1.0_DFP) * (rn + beta + 1.0_DFP) * & - & (2.0_DFP * rn + alpha + beta + 1.0_DFP) / (rn + 1.0_DFP) & - & / (2.0_DFP * rn + alpha + beta + 3.0_DFP) & - & / (rn + alpha + beta + 1.0_DFP) -END IF -END PROCEDURE JacobiNormSqrRatio - -!---------------------------------------------------------------------------- -! JacobiJacobiMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiJacobiMatrix -REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0 - !! -IF (n .LT. 1) RETURN - !! -CALL GetJacobiRecurrenceCoeff(n=n, alpha=alpha, beta=beta, & - & alphaCoeff=alphaCoeff0, betaCoeff=betaCoeff0) -IF (PRESENT(alphaCoeff)) alphaCoeff(0:n - 1) = alphaCoeff0 -IF (PRESENT(betaCoeff)) betaCoeff(0:n - 1) = betaCoeff0 -CALL JacobiMatrix(alphaCoeff=alphaCoeff0, & - & betaCoeff=betaCoeff0, D=D, E=E) - !! -END PROCEDURE JacobiJacobiMatrix - -!---------------------------------------------------------------------------- -! JacobiGaussQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGaussQuadrature -REAL(DFP) :: beta0, Z(n, n), betaCoeff(0:n - 1), pn(n) -INTEGER(I4B) :: ii - !! -CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=beta, D=pt, & - & E=pn, betaCoeff=betaCoeff) - !! -#ifdef USE_LAPACK95 -IF (PRESENT(wt)) THEN - wt = pn - CALL STEV(D=pt, E=wt, Z=Z) - DO ii = 1, n - wt(ii) = betaCoeff(0) * Z(1, ii)**2 - END DO -ELSE - CALL STEV(D=pt, E=pn) -END IF - !! -#else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="JacobiGaussQuadrature", & - & line=__LINE__, & - & unitno=stdout) -#endif - !! -END PROCEDURE JacobiGaussQuadrature - -!---------------------------------------------------------------------------- -! JacobiJacobiRadauMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiJacobiRadauMatrix -REAL(DFP) :: avar, r1, r2, r3, ab, ab2 - !! -IF (n .LT. 1) RETURN - !! -CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=beta, & - & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) - !! -r1 = (1.0 - a) * n * (n + alpha) - (1.0 + a) * n * (n + beta) -r2 = 2.0 * n + alpha + beta -r3 = r2 + 1.0 -avar = a + r1 / r2 / r3 -D(n + 1) = avar - !! -ab = alpha + beta -ab2 = ab + 2.0_DFP -IF (n .EQ. 1) THEN - avar = 4.0_DFP * (1.0_DFP+alpha) * (1.0_DFP+beta) / (ab2*ab2*(ab2+1.0)) -ELSE - avar = 4.0_DFP * n * (n + alpha) * (n + beta) * (n + ab) & - & / (ab + 2.0 * n)**2 / (ab + 1.0 + 2.0 * n) / (ab - 1.0 + 2.0 * n) -END IF - !! -E(n) = SQRT(avar) - !! -END PROCEDURE JacobiJacobiRadauMatrix - -!---------------------------------------------------------------------------- -! JacobiGaussRadauQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGaussRadauQuadrature - !! -REAL(DFP) :: beta0, Z(n + 1, n + 1), betaCoeff(0:n), pn(n + 1) -INTEGER(I4B) :: ii - !! -CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=alpha, beta=beta, D=pt, & - & E=pn, betaCoeff=betaCoeff) - !! -#ifdef USE_LAPACK95 - !! -IF (PRESENT(wt)) THEN - wt = pn - CALL STEV(D=pt, E=wt, Z=Z) - DO ii = 1, n + 1 - wt(ii) = betaCoeff(0) * Z(1, ii)**2 - END DO -ELSE - CALL STEV(D=pt, E=pn) -END IF - !! -#else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="JacobiGaussRadauQuadrature", & - & line=__LINE__, & - & unitno=stdout) -#endif - !! -END PROCEDURE JacobiGaussRadauQuadrature - -!---------------------------------------------------------------------------- -! JacobiJacobiLobattoMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiJacobiLobattoMatrix - !! -REAL(DFP) :: avar, r1, r2, r3, ab - !! -IF (n .LT. 0) RETURN - !! -CALL JacobiJacobiMatrix( & - & n=n + 1, & - & alpha=alpha, & - & beta=beta, & - & D=D, & - & E=E, & - & alphaCoeff=alphaCoeff, & - & betaCoeff=betaCoeff) - !! -r1 = alpha - beta -r2 = 2.0 * n + alpha + beta + 2.0_DFP -r3 = 1.0 -avar = r1 / r2 / r3 -D(n + 2) = avar - !! -ab = alpha + beta -r1 = 4.0_DFP * (n + alpha + 1.0) * (n + beta + 1.0) * (n + ab + 1.0) -r2 = 2.0 * n + ab + 1.0 -r3 = (r2 + 1.0)**2 - !! -E(n + 1) = SQRT(r1 / r2 / r3) - !! -END PROCEDURE JacobiJacobiLobattoMatrix - -!---------------------------------------------------------------------------- -! JacobiGaussLobattoQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGaussLobattoQuadrature - !! -REAL(DFP) :: beta0, Z(n + 2, n + 2), betaCoeff(0:n + 1), pn(n + 2) -INTEGER(I4B) :: ii - !! -CALL JacobiJacobiLobattoMatrix(n=n, alpha=alpha, beta=beta, D=pt, & - & E=pn, betaCoeff=betaCoeff) -!! -#ifdef USE_LAPACK95 -IF (PRESENT(wt)) THEN - wt = pn - CALL STEV(D=pt, E=wt, Z=Z) - DO ii = 1, n + 2 - wt(ii) = betaCoeff(0) * Z(1, ii)**2 - END DO -ELSE - CALL STEV(D=pt, E=pn) -END IF - !! -#else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="JacobiGaussLobattoQuadrature", & - & line=__LINE__, & - & unitno=stdout) -#endif - !! -END PROCEDURE JacobiGaussLobattoQuadrature - -!---------------------------------------------------------------------------- -! JacobiZeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiZeros - !! -REAL(DFP) :: E(n) - !! -CALL JacobiJacobiMatrix( & - & n=n, & - & alpha=alpha, & - & beta=beta, & - & D=ans, & - & E=E) - !! -#ifdef USE_LAPACK95 - !! -CALL STEV(D=ans, E=E) - !! -#else - !! -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="JacobiZeros", & - & line=__LINE__, & - & unitno=stdout) - !! -#endif - !! -END PROCEDURE JacobiZeros - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiQuadrature -INTEGER(I4B) :: order -REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP - !! -SELECT CASE (quadType) -CASE (Gauss) - order = n - CALL JacobiGaussQuadrature(n=order, alpha=alpha, beta=beta, & - & pt=pt, wt=wt) -CASE (GaussRadau, GaussRadauLeft) - order = n - 1 - CALL JacobiGaussRadauQuadrature(a=left, n=order, alpha=alpha, beta=beta, & - & pt=pt, wt=wt) -CASE (GaussRadauRight) - order = n - 1 - CALL JacobiGaussRadauQuadrature(a=right, n=order, alpha=alpha, beta=beta, & - & pt=pt, wt=wt) -CASE (GaussLobatto) - order = n - 2 - CALL JacobiGaussLobattoQuadrature(n=order, alpha=alpha, beta=beta, & - & pt=pt, wt=wt) -END SELECT -END PROCEDURE JacobiQuadrature - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiEvalAll1 -INTEGER(I4B) :: i -REAL(DFP) :: c1 -REAL(DFP) :: c2 -REAL(DFP) :: c3 -REAL(DFP) :: c4 -REAL(DFP) :: r_i -!! -ans = 0.0_DFP -!! -IF (alpha <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (beta <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & - & + 0.5_DFP * (alpha - beta) -!! -DO i = 2, n - !! - r_i = real(i, kind=DFP) - !! - c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (2.0_DFP * r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (alpha + beta) * (alpha - beta) - !! - c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & - & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) - !! - ans(i + 1) = ((c3 + c2 * x) * ans(i) + c4 * ans(i - 1)) / c1 - !! -END DO - -END PROCEDURE JacobiEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiEvalAll2 -INTEGER(I4B) :: i -REAL(DFP) :: c1 -REAL(DFP) :: c2 -REAL(DFP) :: c3 -REAL(DFP) :: c4 -REAL(DFP) :: r_i -!! -ans = 0.0_DFP -!! -IF (alpha <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (beta <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(:, 1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(:, 2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & - & + 0.5_DFP * (alpha - beta) -!! -DO i = 2, n - !! - r_i = real(i, kind=DFP) - !! - c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (2.0_DFP * r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (alpha + beta) * (alpha - beta) - !! - c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & - & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) - !! - ans(:, i + 1) = ((c3 + c2 * x(:)) & - & * ans(:, i) + c4 * ans(:, i - 1)) / c1 - !! -END DO - !! -END PROCEDURE JacobiEvalAll2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiEval1 -INTEGER(I4B) :: i -REAL(DFP) :: c1, c2, c3, c4, r_i, ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (alpha <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (beta <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & - & + 0.5_DFP * (alpha - beta) -!! -DO i = 2, n - !! - r_i = real(i, kind=DFP) - !! - c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (2.0_DFP * r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (alpha + beta) * (alpha - beta) - !! - c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & - & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) - !! - ans_1 = ans - ans = ((c3 + c2 * x) * ans + c4 * ans_2) / c1 - ans_2 = ans_1 - !! -END DO -END PROCEDURE JacobiEval1 - -!---------------------------------------------------------------------------- -! JacobiEval -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiEval2 -INTEGER(I4B) :: i -REAL(DFP) :: c1, c2, c3, c4, r_i -REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (alpha <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (beta <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & - & + 0.5_DFP * (alpha - beta) -!! -DO i = 2, n - !! - r_i = real(i, kind=DFP) - !! - c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (2.0_DFP * r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (alpha + beta) * (alpha - beta) - !! - c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & - & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) - !! - ans_1 = ans - ans = ((c3 + c2 * x) * ans + c4 * ans_2) / c1 - ans_2 = ans_1 - !! -END DO -END PROCEDURE JacobiEval2 - -!---------------------------------------------------------------------------- -! JacobiEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiEvalSum1 -REAL(DFP) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP), DIMENSION(0:n + 1) :: A, B, C -!! -IF (n .LT. 0) RETURN -IF (alpha .LE. -1.0_DFP) RETURN -IF (beta .LE. -1.0_DFP) RETURN -!! -CALL GetJacobiRecurrenceCoeff2(n=n + 2, alpha=alpha, beta=beta, A=A, B=B, C=C) -!! -b1 = 0.0_DFP -b2 = 0.0_DFP -!! -DO j = n, 0, -1 - t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); - b2 = b1 - b1 = t -END DO -!! -ans = b1 -!! -END PROCEDURE JacobiEvalSum1 - -!---------------------------------------------------------------------------- -! JacobiEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiEvalSum2 -REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP), DIMENSION(0:n + 1) :: A, B, C -!! -IF (n .LT. 0) RETURN -IF (alpha .LE. -1.0_DFP) RETURN -IF (beta .LE. -1.0_DFP) RETURN -!! -CALL GetJacobiRecurrenceCoeff2(n=n + 2, alpha=alpha, beta=beta, A=A, B=B, C=C) -!! -b1 = 0.0_DFP -b2 = 0.0_DFP -!! -DO j = n, 0, -1 - t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); - b2 = b1 - b1 = t -END DO -!! -ans = b1 -!! -END PROCEDURE JacobiEvalSum2 - -!---------------------------------------------------------------------------- -! JacobiGradientEval -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEval1 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: j -REAL(DFP) :: p, p_1, p_2 -REAL(DFP) :: ans_1, ans_2 -REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p = 1.0_DFP -ans = 0.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n < 1) THEN - RETURN -END IF -!! -!! -ab = alpha + beta -amb = alpha - beta -p = 0.5 * (ab + 2.0) * x + 0.5 * amb -ans = 0.5 * (ab + 2.0) -!! -DO ii = 2, n - !! - j = REAL(ii, KIND=DFP) - !! - p_1 = p - !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); - a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - !! - p = (a1 * x + a2) * p - a3 * p_2 - !! - p_2 = p_1 - !! - ans_1 = ans - !! - j = j - 1.0 - b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) - b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) - b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) - !! - ans = (p_1 - b1 * ans_2 - b2 * ans_1) / b3 - ans_2 = ans_1 - !! -END DO -!! -END PROCEDURE JacobiGradientEval1 - -!---------------------------------------------------------------------------- -! JacobiGradientEval -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEval2 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: j -REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2, ans_1, ans_2 -REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p = 1.0_DFP -ans = 0.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n < 1) THEN - RETURN -END IF -!! -!! -ab = alpha + beta -amb = alpha - beta -p = 0.5 * (ab + 2.0) * x + 0.5 * amb -ans = 0.5 * (ab + 2.0) -!! -DO ii = 2, n - !! - j = REAL(ii, KIND=DFP) - !! - p_1 = p - !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); - a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - !! - p = (a1 * x + a2) * p - a3 * p_2 - !! - p_2 = p_1 - !! - ans_1 = ans - !! - j = j - 1.0 - b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) - b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) - b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) - !! - ans = (p_1 - b1 * ans_2 - b2 * ans_1) / b3 - ans_2 = ans_1 - !! -END DO -!! -END PROCEDURE JacobiGradientEval2 - -!---------------------------------------------------------------------------- -! JacobiGradientEvalAll -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEvalAll1 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: j -REAL(DFP), DIMENSION(n + 1) :: p -REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p(1) = 1.0_DFP -ans(1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -!! -ab = alpha + beta -amb = alpha - beta -p(2) = 0.5 * (ab + 2.0) * x + 0.5 * amb -ans(2) = 0.5 * (ab + 2.0) -!! -DO ii = 2, n - !! - j = REAL(ii, KIND=DFP) - !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); - a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - !! - p(ii + 1) = (a1 * x + a2) * p(ii) - a3 * p(ii - 1) - !! - j = j - 1.0 - b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) - b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) - b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) - !! - ans(ii + 1) = (p(ii) - b1 * ans(ii - 1) - b2 * ans(ii)) / b3 - !! -END DO -!! -END PROCEDURE JacobiGradientEvalAll1 - -!---------------------------------------------------------------------------- -! JacobiGradientEvalAll -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEvalAll2 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: j -REAL(DFP), DIMENSION(SIZE(x), n + 1) :: p -REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p(:, 1) = 1.0_DFP -ans(:, 1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -ab = alpha + beta -amb = alpha - beta -p(:, 2) = 0.5 * (ab + 2.0) * x + 0.5 * amb -ans(:, 2) = 0.5 * (ab + 2.0) -!! -DO ii = 2, n - !! - j = REAL(ii, KIND=DFP) - !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); - a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - !! - p(:, ii + 1) = (a1 * x + a2) * p(:, ii) - a3 * p(:, ii - 1) - !! - j = j - 1.0 - b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) - b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) - b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) - !! - ans(:, ii + 1) = (p(:, ii) - b1 * ans(:, ii - 1) - b2 * ans(:, ii)) / b3 - !! -END DO -!! -END PROCEDURE JacobiGradientEvalAll2 - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEvalSum1 -REAL(DFP) :: t, b1, b2, Ac, A1, A2, a10, a11, a12, a20, a21, j -REAL(DFP), PARAMETER :: c = 0.5_DFP -INTEGER(I4B) :: i -!! -IF (n .LT. 0) RETURN -IF (alpha .LE. -1.0_DFP) RETURN -IF (beta .LE. -1.0_DFP) RETURN -!! -b1 = 0 -b2 = 0 -!! -DO i = n - 1, 0, -1 - j = REAL(i, KIND=DFP) - !! - !! Recurrence coeff - !! - Ac = j + 2 + alpha + beta; - a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); - a11 = (2 * j + 4 + alpha + beta) * x; - a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); - A1 = a10 * (a11 + a12); - a20 = -(j + 2 + alpha) * (j + 2 + beta) & - & / ((j + 2) * (alpha + beta + j + 4)); - a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); - b2 = b1; - b1 = t; -END DO - -ans = c * b1 - -END PROCEDURE JacobiGradientEvalSum1 - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEvalSum2 -REAL(DFP) :: Ac, A2, a10, a12, a20, a21, j -REAL(DFP), DIMENSION(SIZE(x)) :: a11, A1, t, b1, b2 -REAL(DFP), PARAMETER :: c = 0.5_DFP -INTEGER(I4B) :: i -!! -IF (n .LT. 0) RETURN -IF (alpha .LE. -1.0_DFP) RETURN -IF (beta .LE. -1.0_DFP) RETURN -!! -b1 = 0 -b2 = 0 -!! -DO i = n - 1, 0, -1 - j = REAL(i, KIND=DFP) - !! - !! Recurrence coeff - !! - Ac = j + 2 + alpha + beta; - a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); - a11 = (2 * j + 4 + alpha + beta) * x; - a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); - A1 = a10 * (a11 + a12); - a20 = -(j + 2 + alpha) * (j + 2 + beta) & - & / ((j + 2) * (alpha + beta + j + 4)); - a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); - b2 = b1; - b1 = t; -END DO - -ans = c * b1 -END PROCEDURE JacobiGradientEvalSum2 - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEvalSum3 -REAL(DFP) :: t, b1, b2, Ac, A1, A2, a10, a11, a12, a20, a21, c, s -INTEGER(I4B) :: i, j -!! -IF (n .LT. 0) RETURN -IF (alpha .LE. -1.0_DFP) RETURN -IF (beta .LE. -1.0_DFP) RETURN -!! -b1 = 0 -b2 = 0 -c = 1.0_DFP -!! -DO i = k, 1, -1 - c = c / 2.0_DFP -END DO -!! -DO i = n - k, 0, -1 - !! - s = 1.0_DFP - !! - DO j = 1, k - s = s * (alpha + beta + i + k + j) - END DO - !! - a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); - a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; - a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); - A1 = a10 * (a11 + a12); - a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); - a21 = (alpha + beta + 2 * i + 4 + 2 * k) & - & / (alpha + beta + 2 * i + 2 + 2 * k); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + s * coeff(i + k); - b2 = b1; - b1 = t; -END DO - -ans = c * b1 - -END PROCEDURE JacobiGradientEvalSum3 - -!---------------------------------------------------------------------------- -! JacobiGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientEvalSum4 -REAL(DFP) :: Ac, A2, a10, a12, a20, a21, c, s -REAL(DFP), DIMENSION(SIZE(x)) :: a11, A1, t, b1, b2 -INTEGER(I4B) :: i, j -!! -IF (n .LT. 0) RETURN -IF (alpha .LE. -1.0_DFP) RETURN -IF (beta .LE. -1.0_DFP) RETURN -!! -b1 = 0 -b2 = 0 -c = 1.0_DFP -!! -DO i = k, 1, -1 - c = c / 2.0_DFP -END DO -!! -DO i = n - k, 0, -1 - !! - s = 1.0_DFP - !! - DO j = 1, k - s = s * (alpha + beta + i + k + j) - END DO - !! - a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); - a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; - a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); - A1 = a10 * (a11 + a12); - a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); - a21 = (alpha + beta + 2 * i + 4 + 2 * k) & - & / (alpha + beta + 2 * i + 2 + 2 * k); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + s * coeff(i + k); - b2 = b1; - b1 = t; -END DO - -ans = c * b1 - -END PROCEDURE JacobiGradientEvalSum4 - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform1 -REAL(DFP), DIMENSION(0:n) :: Gamma, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -!! -Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) -!! -!! Correct Gamma(n) -!! -IF (quadType .EQ. GaussLobatto) THEN - Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & - & * Gamma(n) -END IF -!! -PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) -!! -DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / Gamma(jj) -END DO -!! -END PROCEDURE JacobiTransform1 - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform2 -REAL(DFP), DIMENSION(0:n) :: Gamma, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -!! -Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) -!! -!! Correct Gamma(n) -!! -IF (quadType .EQ. GaussLobatto) THEN - Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & - & * Gamma(n) -END IF -!! -PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) -!! -DO kk = 1, SIZE(coeff, 2) - DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / Gamma(jj) - END DO -END DO -!! -END PROCEDURE JacobiTransform2 - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) -INTEGER(I4B) :: ii -!! -CALL JacobiQuadrature(n=n + 1, alpha=alpha, beta=beta, pt=pt, wt=wt,& - & quadType=quadType) -!! -DO ii = 0, n - coeff(ii) = f(pt(ii)) -END DO -!! -ans = JacobiTransform(n=n, alpha=alpha, beta=beta, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) -END PROCEDURE JacobiTransform3 - -!---------------------------------------------------------------------------- -! JacobiInvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiInvTransform1 -ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & - & x=x) -END PROCEDURE JacobiInvTransform1 - -!---------------------------------------------------------------------------- -! JacobiInvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiInvTransform2 -ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & - & x=x) -END PROCEDURE JacobiInvTransform2 - -!---------------------------------------------------------------------------- -! JacobiGradientCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiGradientCoeff1 -REAL(DFP) :: a, b, c, ab, amb, tnab, nab -INTEGER(I4B) :: ii -REAL(DFP) :: jj - -ans(n) = 0.0_DFP -IF (n .EQ. 0) RETURN -!! -!! c(n-1) -!! -ab = alpha + beta -amb = alpha - beta -tnab = 2.0 * n + ab -nab = n + ab -!! -IF (n .EQ. 1) THEN - c = 2.0_DFP / (ab + 2.0_DFP) -ELSE - c = 2.0 * (n + ab) / (tnab - 1.0) / tnab -END IF -!! -ans(n - 1) = coeff(n) / c -!! -DO ii = n - 1, 1, -1 - jj = REAL(ii, KIND=DFP) - tnab = 2.0 * jj + ab - nab = jj + ab - c = 2.0 * (jj + ab) / (tnab - 1.0) / tnab - b = 2.0 * amb / tnab / (tnab + 2.0) - a = -2.0 * (jj+alpha+1.0)*(jj+beta+1.0) / (nab+1.0) / (tnab+2.0)/(tnab+3.0) - ans(ii - 1) = (coeff(ii) - b * ans(ii) - a * ans(ii + 1)) / c -END DO -!! -END PROCEDURE JacobiGradientCoeff1 - -!---------------------------------------------------------------------------- -! JacobiDMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiDMatrix1 -SELECT CASE (quadType) -CASE (GaussLobatto) - CALL JacobiDMatrixGL(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType,& - & D=ans) -CASE (Gauss) - CALL JacobiDMatrixG(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType, & - & D=ans) -END SELECT -END PROCEDURE JacobiDMatrix1 - -!---------------------------------------------------------------------------- -! JacobiDMatrixGL -!---------------------------------------------------------------------------- - -PURE SUBROUTINE JacobiDMatrixGL(n, alpha, beta, x, quadType, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha > -1.0 - REAL(DFP), INTENT(IN) :: beta - !! beta > -1.0 - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss and GaussLobatto - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - REAL(DFP) :: ab, rn - INTEGER(I4B) :: ii, jj - REAL(DFP) :: gb2, gna1, gnb1, ga2, sgn, gn, ga1, temp - !! - !! Compute dJ_{N-1}(a+1,b+1) - !! - J = JacobiGradientEval(n=n - 1, alpha=alpha + 1.0_DFP, & - & beta=beta + 1.0_DFP, x=x) - !! - !! zeroth column - !! - ab = alpha + beta - rn = REAL(n, KIND=DFP) - !! - D(0, 0) = 0.5 * (alpha - rn * (rn + ab + 1.0)) / (beta + 2.0) - !! - !! - gb2 = GAMMA(beta + 2.0_DFP) - gna1 = GAMMA(rn + alpha + 1.0_DFP) - gnb1 = GAMMA(rn + beta + 1.0_DFP) - ga1 = GAMMA(alpha + 1.0_DFP) - ga2 = ga1 * (alpha + 1.0_DFP) - gn = GAMMA(rn) - sgn = (-1.0)**n - !! - D(n, 0) = sgn * 0.5 * gb2 * gna1 / gnb1 / ga2 - !! - sgn = (-1.0)**(n - 1) - !! - DO ii = 1, n - 1 - D(ii, 0) = sgn * 0.5 * gn * gb2 * (1.0 - x(ii)) * J(ii) / gnb1 - END DO - !! - !! last column - !! - sgn = (-1.0)**(n + 1) - !! - D(0, n) = sgn * 0.5 * ga2 * gnb1 / gna1 / gb2 - !! - D(n, n) = 0.5 * (-beta + rn * (rn + ab + 1.0)) / (alpha + 2.0) - !! - D(1:n - 1, n) = (gn * ga2 * 0.5 / gna1) * (1.0_DFP + x(1:n - 1)) & - & * J(1:n - 1) - !! - !! internal columns - !! - sgn = (-1.0)**(n) - DO ii = 1, n - 1 - temp = J(ii) * (1.0 - x(ii)) * (1.0 + x(ii))**2 - D(0, ii) = 2.0 * sgn * gnb1 / gn / gb2 / temp - !! - temp = J(ii) * (1.0 + x(ii)) * (1.0 - x(ii))**2 - D(n, ii) = -2.0 * gna1 / gn / ga2 / temp - END DO - !! - DO jj = 1, n - 1 - DO ii = 1, n - 1 - IF (ii .EQ. jj) THEN - D(ii, ii) = (alpha - beta + ab * x(ii)) / 2.0 / (1.0 - x(ii)**2) - ELSE - D(ii, jj) = (1.0 - x(ii)**2) * J(ii) / (1.0 - x(jj)**2) / J(jj) & - & / (x(ii) - x(jj)) - END IF - END DO - END DO -END SUBROUTINE JacobiDMatrixGL - -!---------------------------------------------------------------------------- -! JacobiDMatrixG -!---------------------------------------------------------------------------- - -PURE SUBROUTINE JacobiDMatrixG(n, alpha, beta, x, quadType, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha > -1.0 - REAL(DFP), INTENT(IN) :: beta - !! beta > -1.0 - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - INTEGER(I4B), INTENT(IN) :: quadType - !! Gauss and GaussLobatto - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - REAL(DFP) :: ab, amb - INTEGER(I4B) :: ii, jj - !! - !! Compute dJ_{N-1}(a+1,b+1) - !! - J = JacobiGradientEval(n=n + 1, alpha=alpha, beta=beta, x=x) - !! - !! zeroth column - !! - ab = alpha + beta - ab = alpha - beta - !! - DO jj = 0, n - DO ii = 0, n - IF (ii .EQ. jj) THEN - D(ii, ii) = (amb + (ab + 2.0) * x(ii)) / 2.0 / (1.0 - x(ii)**2) - ELSE - D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END IF - END DO - END DO -!! -END SUBROUTINE JacobiDMatrixG - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 deleted file mode 100644 index d08340e69..000000000 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ /dev/null @@ -1,927 +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(LagrangePolynomialUtility) Methods -USE GlobalData, ONLY: stdout, stderr, Point, Line, Triangle, Quadrangle, & - Tetrahedron, Hexahedron, Prism, Pyramid - -USE ErrorHandling, ONLY: Errormsg - -USE ReferenceElement_Method, ONLY: ElementTopology - -USE ReferenceLine_Method, ONLY: RefCoord_Line -USE ReferenceTriangle_Method, ONLY: RefCoord_Triangle -USE ReferenceQuadrangle_Method, ONLY: RefCoord_Quadrangle -USE ReferenceTetrahedron_Method, ONLY: RefCoord_Tetrahedron -USE ReferenceHexahedron_Method, ONLY: RefCoord_Hexahedron -USE ReferencePrism_Method, ONLY: RefCoord_Prism -USE ReferencePyramid_Method, ONLY: RefCoord_Pyramid - -USE LineInterpolationUtility, ONLY: RefElemDomain_Line, & - LagrangeDOF_Line, & - LagrangeInDOF_Line, & - LagrangeDegree_Line, & - EquidistancePoint_Line, & - InterpolationPoint_Line, & - LagrangeCoeff_Line, & - LagrangeEvalAll_Line, & - LagrangeGradientEvalAll_Line - -USE TriangleInterpolationUtility, ONLY: RefElemDomain_Triangle, & - LagrangeDOF_Triangle, & - LagrangeInDOF_Triangle, & - LagrangeDegree_Triangle, & - EquidistancePoint_Triangle, & - InterpolationPoint_Triangle, & - LagrangeCoeff_Triangle, & - LagrangeEvalAll_Triangle, & - LagrangeGradientEvalAll_Triangle - -USE QuadrangleInterpolationUtility, ONLY: RefElemDomain_Quadrangle, & - LagrangeDOF_Quadrangle, & - LagrangeInDOF_Quadrangle, & - LagrangeDegree_Quadrangle, & - EquidistancePoint_Quadrangle, & - InterpolationPoint_Quadrangle, & - LagrangeCoeff_Quadrangle, & - LagrangeEvalAll_Quadrangle, & - LagrangeGradientEvalAll_Quadrangle - -USE TetrahedronInterpolationUtility, ONLY: RefElemDomain_Tetrahedron, & - LagrangeDOF_Tetrahedron, & - LagrangeInDOF_Tetrahedron, & - LagrangeDegree_Tetrahedron, & - EquidistancePoint_Tetrahedron, & - InterpolationPoint_Tetrahedron, & - LagrangeCoeff_Tetrahedron, & - LagrangeEvalAll_Tetrahedron, & - LagrangeGradientEvalAll_Tetrahedron - -USE HexahedronInterpolationUtility, ONLY: RefElemDomain_Hexahedron, & - LagrangeDOF_Hexahedron, & - LagrangeInDOF_Hexahedron, & - LagrangeDegree_Hexahedron, & - EquidistancePoint_Hexahedron, & - InterpolationPoint_Hexahedron, & - LagrangeCoeff_Hexahedron, & - LagrangeEvalAll_Hexahedron, & - LagrangeGradientEvalAll_Hexahedron - -USE PrismInterpolationUtility, ONLY: RefElemDomain_Prism, & - LagrangeDOF_Prism, & - LagrangeInDOF_Prism, & - LagrangeDegree_Prism, & - EquidistancePoint_Prism, & - InterpolationPoint_Prism, & - LagrangeCoeff_Prism, & - LagrangeEvalAll_Prism, & - LagrangeGradientEvalAll_Prism - -USE PyramidInterpolationUtility, ONLY: RefElemDomain_Pyramid, & - LagrangeDOF_Pyramid, & - LagrangeInDOF_Pyramid, & - LagrangeDegree_Pyramid, & - EquidistancePoint_Pyramid, & - InterpolationPoint_Pyramid, & - LagrangeCoeff_Pyramid, & - LagrangeEvalAll_Pyramid, & - LagrangeGradientEvalAll_Pyramid - -USE ReallocateUtility, ONLY: Reallocate - -USE Display_Method, ONLY: ToString - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefElemDomain -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - ans = "" - -CASE (Line) - ans = RefElemDomain_Line(baseContinuity, baseInterpol) - -CASE (Triangle) - ans = RefElemDomain_Triangle(baseContinuity, baseInterpol) - -CASE (Quadrangle) - ans = RefElemDomain_Quadrangle(baseContinuity, baseInterpol) - -CASE (Tetrahedron) - ans = RefElemDomain_Tetrahedron(baseContinuity, baseInterpol) - -CASE (Hexahedron) - ans = RefElemDomain_Hexahedron(baseContinuity, baseInterpol) - -CASE (Prism) - ans = RefElemDomain_Prism(baseContinuity, baseInterpol) - -CASE (Pyramid) - ans = RefElemDomain_Pyramid(baseContinuity, baseInterpol) -END SELECT - -END PROCEDURE RefElemDomain - -!---------------------------------------------------------------------------- -! RefCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefCoord -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) - -CASE (Point) - CALL Reallocate(ans, 3_I4B, 1_I4B) - -CASE (Line) - ans = RefCoord_Line(refElem) - -CASE (Triangle) - ans = RefCoord_Triangle(refElem) - -CASE (Quadrangle) - ans = RefCoord_Quadrangle(refElem) - -CASE (Tetrahedron) - ans = RefCoord_Tetrahedron(refElem) - -CASE (Hexahedron) - ans = RefCoord_Hexahedron(refElem) - -CASE (Prism) - ans = RefCoord_Prism(refElem) - -CASE (Pyramid) - ans = RefCoord_Pyramid(refElem) - -END SELECT -END PROCEDURE RefCoord - -!---------------------------------------------------------------------------- -! LagrangeDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - ans = 1 -CASE (Line) - ans = LagrangeDOF_Line(order=order) -CASE (Triangle) - ans = LagrangeDOF_Triangle(order=order) -CASE (Quadrangle) - ans = LagrangeDOF_Quadrangle(order=order) -CASE (Tetrahedron) - ans = LagrangeDOF_Tetrahedron(order=order) -CASE (Hexahedron) - ans = LagrangeDOF_Hexahedron(order=order) -CASE (Prism) - ans = LagrangeDOF_Prism(order=order) -CASE (Pyramid) - ans = LagrangeDOF_Pyramid(order=order) -END SELECT -END PROCEDURE LagrangeDOF - -!---------------------------------------------------------------------------- -! LagrangeInDOF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - ans = 0 -CASE (Line) - ans = LagrangeInDOF_Line(order=order) -CASE (Triangle) - ans = LagrangeInDOF_Triangle(order=order) -CASE (Quadrangle) - ans = LagrangeInDOF_Quadrangle(order=order) -CASE (Tetrahedron) - ans = LagrangeInDOF_Tetrahedron(order=order) -CASE (Hexahedron) - ans = LagrangeInDOF_Hexahedron(order=order) -CASE (Prism) - ans = LagrangeInDOF_Prism(order=order) -CASE (Pyramid) - ans = LagrangeInDOF_Pyramid(order=order) -END SELECT - -END PROCEDURE LagrangeInDOF - -!---------------------------------------------------------------------------- -! LagrangeDegree -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree -INTEGER(I4B) :: topo -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - ALLOCATE (ans(0, 0)) -CASE (Line) - ans = LagrangeDegree_Line(order=order) -CASE (Triangle) - ans = LagrangeDegree_Triangle(order=order) -CASE (Quadrangle) - ans = LagrangeDegree_Quadrangle(order=order) -CASE (Tetrahedron) - ans = LagrangeDegree_Tetrahedron(order=order) -CASE (Hexahedron) - ans = LagrangeDegree_Hexahedron(order=order) -CASE (Prism) - ans = LagrangeDegree_Prism(order=order) -CASE (Pyramid) - ans = LagrangeDegree_Pyramid(order=order) -END SELECT -END PROCEDURE LagrangeDegree - -!---------------------------------------------------------------------------- -! LagrangeVandermonde -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeVandermonde -INTEGER(I4B) :: nrow, ncol -nrow = SIZE(xij, 2) -ncol = LagrangeDOF(order=order, elemType=elemType) -CALL Reallocate(ans, nrow, ncol) -CALL LagrangeVandermonde_(xij=xij, order=order, elemType=elemType, ans=ans, & - nrow=nrow, ncol=ncol) -END PROCEDURE LagrangeVandermonde - -!---------------------------------------------------------------------------- -! LagrangeVandermonde_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeVandermonde_ -INTEGER(I4B), ALLOCATABLE :: degree(:, :) -INTEGER(I4B) :: jj, nsd, ii - -degree = LagrangeDegree(order=order, elemType=elemType) -nrow = SIZE(xij, 2) -nsd = SIZE(degree, 2) -ncol = SIZE(degree, 1) - -SELECT CASE (nsd) -CASE (1) - - DO CONCURRENT(ii=1:nrow, jj=1:ncol) - ans(ii, jj) = xij(1, ii)**degree(jj, 1) - END DO - -CASE (2) - - 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 - -CASE (3) - - DO CONCURRENT(jj=1:ncol, ii=1:nrow) - ans(ii, jj) = (xij(1, ii)**degree(jj, 1)) * (xij(2, ii)**degree(jj, 2)) & - & * (xij(3, ii)**degree(jj, 3)) - END DO - -END SELECT - -IF (ALLOCATED(degree)) DEALLOCATE (degree) -END PROCEDURE LagrangeVandermonde_ - -!---------------------------------------------------------------------------- -! EquidistancePoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) - -CASE (Point) - IF (PRESENT(xij)) THEN - ans = xij - ELSE - ALLOCATE (ans(0, 0)) - END IF - -CASE (Line) - ans = EquidistancePoint_Line(order=order, xij=xij) - -CASE (Triangle) - ans = EquidistancePoint_Triangle(order=order, xij=xij) - -CASE (Quadrangle) - ans = EquidistancePoint_Quadrangle(order=order, xij=xij) - -CASE (Tetrahedron) - ans = EquidistancePoint_Tetrahedron(order=order, xij=xij) - -CASE (Hexahedron) - ans = EquidistancePoint_Hexahedron(order=order, xij=xij) - -CASE (Prism) - ans = EquidistancePoint_Prism(order=order, xij=xij) - -CASE (Pyramid) - ans = EquidistancePoint_Pyramid(order=order, xij=xij) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="EquidistancePoint()", & - & file=__FILE__) -END SELECT -END PROCEDURE EquidistancePoint - -!---------------------------------------------------------------------------- -! InterpolationPoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) - -CASE (Point) - IF (PRESENT(xij)) THEN - ans = xij - ELSE - ALLOCATE (ans(0, 0)) - END IF - -CASE (Line) - ans = InterpolationPoint_Line(& - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE (Triangle) - ans = InterpolationPoint_Triangle( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE (Quadrangle) - ans = InterpolationPoint_Quadrangle( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE (Tetrahedron) - ans = InterpolationPoint_Tetrahedron( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE (Hexahedron) - ans = InterpolationPoint_Hexahedron( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE (Prism) - ans = InterpolationPoint_Prism( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE (Pyramid) - ans = InterpolationPoint_Pyramid( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="InterpolationPoint()", & - & file=__FILE__) - RETURN -END SELECT - -END PROCEDURE InterpolationPoint - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff1 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) - -CASE (Point) -CASE (Line) - ans = LagrangeCoeff_Line(order=order, xij=xij, i=i) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, xij=xij, i=i) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, xij=xij, i=i) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij, i=i) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, xij=xij, i=i) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, xij=xij, i=i) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, xij=xij, i=i) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff1()", & - & file=__FILE__) -END SELECT - -END PROCEDURE LagrangeCoeff1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff2 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - ans = LagrangeCoeff_Line(order=order, xij=xij) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, xij=xij) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, xij=xij) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, xij=xij) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, xij=xij) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, xij=xij) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff2()", & - & file=__FILE__) -END SELECT -END PROCEDURE LagrangeCoeff2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff3 -INTEGER(I4B) :: topo -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - ans = LagrangeCoeff_Line(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff2()", & - & file=__FILE__) -END SELECT -END PROCEDURE LagrangeCoeff3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff4 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - ans = LagrangeCoeff_Line(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, ipiv=ipiv) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff2()", & - & file=__FILE__) -END SELECT -END PROCEDURE LagrangeCoeff4 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll1 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - ans = LagrangeEvalAll_Line( & - & order=order, & - & xij=xij, & - & x=x, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Triangle) - ans = LagrangeEvalAll_Triangle( & - & order=order, & - & x=x, & - & xij=xij, & - & refTriangle=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Quadrangle) - ans = LagrangeEvalAll_Quadrangle( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Tetrahedron) - ans = LagrangeEvalAll_Tetrahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & refTetrahedron=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Hexahedron) - ans = LagrangeEvalAll_Hexahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Prism) - ans = LagrangeEvalAll_Prism( & - & order=order, & - & x=x, & - & xij=xij, & - & refPrism=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Pyramid) - ans = LagrangeEvalAll_Pyramid( & - & order=order, & - & x=x, & - & xij=xij, & - & refPyramid=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeEvalAll2()", & - & file=__FILE__) -END SELECT -END PROCEDURE LagrangeEvalAll1 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll1 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - IF (SIZE(x, 1) .NE. 1 .OR. SIZE(xij, 1) .NE. 1) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 1", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) - RETURN - END IF - - ans(:, :, 1:1) = LagrangeGradientEvalAll_Line( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Triangle) - - IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) - RETURN - END IF - - ans(:, :, 1:2) = LagrangeGradientEvalAll_Triangle( & - & order=order, & - & x=x, & - & xij=xij, & - & refTriangle=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Quadrangle) - - IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) - RETURN - END IF - ans(:, :, 1:2) = LagrangeGradientEvalAll_Quadrangle( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Tetrahedron) - - IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) - RETURN - END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Tetrahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & refTetrahedron=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Hexahedron) - - IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) - RETURN - END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Hexahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Prism) - - IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) - RETURN - END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Prism( & - & order=order, & - & x=x, & - & xij=xij, & - & refPrism=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE (Pyramid) - - IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) - RETURN - END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Pyramid( & - & order=order, & - & x=x, & - & xij=xij, & - & refPyramid=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1()", & - & file=__FILE__) - RETURN -END SELECT -END PROCEDURE LagrangeGradientEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 deleted file mode 100644 index f91273474..000000000 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ /dev/null @@ -1,1182 +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(LegendrePolynomialUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! LegendreAlpha -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreAlpha -ans = 0.0_DFP -END PROCEDURE LegendreAlpha - -!---------------------------------------------------------------------------- -! LegendreBeta -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreBeta -REAL(DFP) :: avar -!! -IF (n .EQ. 0_I4B) THEN - ans = 2.0_DFP -ELSE - avar = REAL(n**2, KIND=DFP) - ans = avar / (4.0_DFP * avar - 1.0_DFP) -END IF -END PROCEDURE LegendreBeta - -!---------------------------------------------------------------------------- -! GetLegendreRecurrenceCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetLegendreRecurrenceCoeff -REAL(DFP), PARAMETER :: one = 1.0_DFP, two = 2.0_DFP, four = 4.0_DFP -REAL(DFP) :: avar -INTEGER(I4B) :: ii -!! -IF (n .LE. 0) RETURN -!! -alphaCoeff = 0.0_DFP -betaCoeff(0) = two -IF (n .EQ. 1) RETURN -!! -DO ii = 1, n - 1 - avar = REAL(ii**2, KIND=DFP) - betaCoeff(ii) = avar / (four * avar - one) -END DO -!! -END PROCEDURE GetLegendreRecurrenceCoeff - -!---------------------------------------------------------------------------- -! GetLegendreRecurrenceCoeff2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetLegendreRecurrenceCoeff2 -REAL(DFP) :: j -INTEGER(I4B) :: ii -!! -IF (n .LT. 1) RETURN -B = 0.0_DFP -!! -DO ii = 1, n - j = REAL(ii, KIND=DFP) - A(ii - 1) = (2.0_DFP * j - 1.0_DFP) / j; - C(ii - 1) = (j - 1.0_DFP) / j; -END DO -!! -END PROCEDURE GetLegendreRecurrenceCoeff2 - -!---------------------------------------------------------------------------- -! LegendreLeadingCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreLeadingCoeff -REAL(DFP) :: a1, a2, a3 -a1 = REAL(Factorial(2 * n), KIND=DFP) -a2 = REAL(Factorial(n)**2, KIND=DFP) -a3 = REAL(2**n, KIND=DFP) -ans = a1 / a2 / a3 -END PROCEDURE LegendreLeadingCoeff - -!---------------------------------------------------------------------------- -! LegendreLeadingCoeffRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreLeadingCoeffRatio -ans = (2.0 * n + 1) / (n + 1.0_DFP) -END PROCEDURE LegendreLeadingCoeffRatio - -!---------------------------------------------------------------------------- -! LegendreNormSqr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreNormSqr -ans = 2.0_DFP / (2.0_DFP * n + 1.0_DFP) -END PROCEDURE LegendreNormSqr - -!---------------------------------------------------------------------------- -! LegendreNormSqrRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreNormSqrRatio -ans = (2.0_DFP * n + 1.0_DFP) / (2.0_DFP * n + 3.0_DFP) -END PROCEDURE LegendreNormSqrRatio - -!---------------------------------------------------------------------------- -! LegendreNormSqr2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreNormSqr2 -INTEGER(I4B) :: ii -DO ii = 0, n - ans(ii) = 2.0_DFP / (2.0_DFP * ii + 1.0_DFP) -END DO -END PROCEDURE LegendreNormSqr2 - -!---------------------------------------------------------------------------- -! LegendreJacobiMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreJacobiMatrix -REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0 -!! -IF (n .LT. 1) RETURN -!! -CALL GetLegendreRecurrenceCoeff(n=n, alphaCoeff=alphaCoeff0, & - & betaCoeff=betaCoeff0) -IF (PRESENT(alphaCoeff)) alphaCoeff(0:n - 1) = alphaCoeff0 -IF (PRESENT(betaCoeff)) betaCoeff(0:n - 1) = betaCoeff0 -!! -CALL JacobiMatrix(alphaCoeff=alphaCoeff0, & - & betaCoeff=betaCoeff0, D=D, E=E) -!! -END PROCEDURE LegendreJacobiMatrix - -!---------------------------------------------------------------------------- -! LegendreGaussQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGaussQuadrature -REAL(DFP) :: pn(n), fixvar -INTEGER(I4B) :: ii -!! -CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) -!! -#ifdef USE_LAPACK95 -CALL STEV(D=pt, E=pn) -!! -IF (PRESENT(wt)) THEN - wt = pn - pn = LegendreEval(n=n - 1, x=pt) - fixvar = 2.0_DFP / REAL(n**2, KIND=DFP) - DO ii = 1, n - wt(ii) = fixvar * (1.0_DFP - pt(ii)**2) / (pn(ii)**2) - END DO -END IF - !! -#else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="LegendreGaussQuadrature", & - & line=__LINE__, & - & unitno=stdout) -#endif - !! -END PROCEDURE LegendreGaussQuadrature - -!---------------------------------------------------------------------------- -! LegendreJacobiRadauMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreJacobiRadauMatrix -REAL(DFP) :: avar, r1, r2 -!! -IF (n .LT. 1) RETURN -!! -CALL LegendreJacobiMatrix(n=n, D=D, E=E, & - & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -!! -r1 = a * REAL(n + 1, KIND=DFP) -r2 = REAL(2 * n + 1, KIND=DFP) -D(n + 1) = r1 / r2 -!! -r1 = REAL(n**2, KIND=DFP) -r2 = 4.0_DFP * r1 - 1.0_DFP -!! -E(n) = SQRT(r1 / r2) -!! -END PROCEDURE LegendreJacobiRadauMatrix - -!---------------------------------------------------------------------------- -! LegendreGaussRadauQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGaussRadauQuadrature -REAL(DFP) :: pn(n + 1), fixvar -INTEGER(I4B) :: ii - !! -CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=pn) -!! -#ifdef USE_LAPACK95 -!! -CALL STEV(D=pt, E=pn) -!! -IF (PRESENT(wt)) THEN - wt = pn - pn = LegendreEval(n=n, x=pt) - fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) - !! - DO ii = 1, n + 1 - wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) - END DO -END IF - !! -#else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="LegendreGaussRadauQuadrature", & - & line=__LINE__, & - & unitno=stdout) -#endif - !! -END PROCEDURE LegendreGaussRadauQuadrature - -!---------------------------------------------------------------------------- -! LegendreJacobiLobattoMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreJacobiLobattoMatrix - !! -REAL(DFP) :: r1, r2 - !! -IF (n .LT. 0) RETURN - !! -CALL LegendreJacobiMatrix( & - & n=n + 1, & - & D=D, & - & E=E, & - & alphaCoeff=alphaCoeff, & - & betaCoeff=betaCoeff) - !! -D(n + 2) = 0.0_DFP -r1 = REAL(n + 1, KIND=DFP) -r2 = REAL(2 * n + 1, KIND=DFP) - !! -E(n + 1) = SQRT(r1 / r2) - !! -END PROCEDURE LegendreJacobiLobattoMatrix - -!---------------------------------------------------------------------------- -! LegendreGaussLobattoQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGaussLobattoQuadrature -REAL(DFP) :: pn(n + 2), fixvar -INTEGER(I4B) :: ii -!! -CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=pn) -!! -#ifdef USE_LAPACK95 -!! -CALL STEV(D=pt, E=pn) -!! -IF (PRESENT(wt)) THEN - wt = pn - pn = LegendreEval(n=n + 1, x=pt) - fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) - !! - DO ii = 1, n + 2 - wt(ii) = fixvar / (pn(ii)**2) - END DO -END IF - !! -#else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="LegendreGaussLobattoQuadrature", & - & line=__LINE__, & - & unitno=stdout) -#endif - !! -END PROCEDURE LegendreGaussLobattoQuadrature - -!---------------------------------------------------------------------------- -! LegendreZeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreZeros -ans = JacobiZeros(alpha=0.0_DFP, beta=0.0_DFP, n=n) -END PROCEDURE LegendreZeros - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreQuadrature -INTEGER(I4B) :: order -REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP -REAL(DFP), ALLOCATABLE :: p(:), w(:) -LOGICAL(LGT) :: inside -!! -IF (PRESENT(onlyInside)) THEN - inside = onlyInside -ELSE - inside = .FALSE. -END IF -!! -SELECT CASE (QuadType) -CASE (Gauss) - !! - order = n - CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt) - !! -CASE (GaussRadau, GaussRadauLeft) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 1), w(n + 1)) - CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=p, wt=w) - pt = p(2:); wt = w(2:) - DEALLOCATE (p, w) - ELSE - order = n - 1 - CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) - END IF - !! -CASE (GaussRadauRight) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 1), w(n + 1)) - CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=p, wt=w) - pt = p(1:n); wt = w(1:n) - ELSE - order = n - 1 - CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) - END IF - !! -CASE (GaussLobatto) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 2), w(n + 2)) - CALL LegendreGaussLobattoQuadrature(n=order, pt=p, wt=w) - pt = p(2:n + 1); wt = w(2:n + 1) - ELSE - order = n - 2 - CALL LegendreGaussLobattoQuadrature(n=order, pt=pt, wt=wt) - END IF -END SELECT -END PROCEDURE LegendreQuadrature - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreEval1 -INTEGER(I4B) :: i -REAL(DFP) :: c1, c2, c3, r_i, ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans = x -!! -DO i = 1, n - 1 - !! - r_i = REAL(i, kind=DFP) - c1 = r_i + 1.0_DFP - c2 = 2.0_DFP * r_i + 1.0_DFP - c3 = -r_i - !! - ans_1 = ans - ans = ((c2 * x) * ans + c3 * ans_2) / c1 - ans_2 = ans_1 - !! -END DO -END PROCEDURE LegendreEval1 - -!---------------------------------------------------------------------------- -! LegendreEval -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreEval2 -INTEGER(I4B) :: i -REAL(DFP) :: c1, c2, c3, r_i -REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans = x -!! -DO i = 1, n - 1 - !! - r_i = REAL(i, kind=DFP) - c1 = r_i + 1.0_DFP - c2 = 2.0_DFP * r_i + 1.0_DFP - c3 = -r_i - !! - ans_1 = ans - ans = ((c2 * x) * ans + c3 * ans_2) / c1 - ans_2 = ans_1 - !! -END DO -END PROCEDURE LegendreEval2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreEvalAll1 -INTEGER(I4B) :: i -REAL(DFP) :: c1, c2, c3, r_i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(2) = x -!! -DO i = 2, n - !! - r_i = REAL(i, kind=DFP) - c1 = r_i - c2 = 2.0_DFP * r_i - 1.0_DFP - c3 = -r_i + 1.0_DFP - !! - ans(i + 1) = ((c2 * x) * ans(i) + c3 * ans(i - 1)) / c1 - !! -END DO - -END PROCEDURE LegendreEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreEvalAll2 -INTEGER(I4B) :: i -REAL(DFP) :: c1, c2, c3, r_i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(:, 1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(:, 2) = x -!! -DO i = 2, n - !! - r_i = REAL(i, kind=DFP) - c1 = r_i - c2 = 2.0_DFP * r_i - 1.0_DFP - c3 = -r_i + 1.0_DFP - !! - ans(:, i + 1) = ((c2 * x) * ans(:, i) + c3 * ans(:, i - 1)) / c1 - !! -END DO - -END PROCEDURE LegendreEvalAll2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreMonomialExpansionAll -REAL(DFP) :: r_i -INTEGER(I4B) :: ii - !! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 0.0_DFP -ans(1, 1) = 1.0_DFP - !! -IF (n .EQ. 0) THEN - RETURN -END IF - !! -ans(2, 2) = 1.0_DFP - !! -DO ii = 2, n - !! - r_i = REAL(ii, KIND=DFP) - !! - ans(1:ii - 1, ii + 1) = & - & (-r_i + 1.0) * ans(1:ii - 1, ii - 1) / r_i - !! - ans(2:ii + 1, ii + 1) = ans(2:ii + 1, ii + 1) & - & + (2.0 * r_i - 1.0) * ans(1:ii, ii) / r_i - !! -END DO -END PROCEDURE LegendreMonomialExpansionAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreMonomialExpansion -REAL(DFP) :: coeff(n + 1, n + 1) -coeff = LegendreMonomialExpansionAll(n) -ans = coeff(:, n + 1) -END PROCEDURE LegendreMonomialExpansion - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEvalAll1 - !! -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP) :: p(1:n + 1) - !! -IF (n < 0) THEN - RETURN -END IF -!! -p(1) = 1.0_DFP -ans(1) = 0.0_DFP - !! -IF (n < 1) THEN - RETURN -END IF -!! -p(2) = x -ans(2) = 1.0_DFP - !! -DO ii = 2, n - !! - r_ii = REAL(ii, KIND=DFP) - !! - p(ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(ii) & - & - (r_ii - 1.0_DFP) * p(ii - 1)) & - & / r_ii - !! - ans(ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(ii) + ans(ii - 1) - !! -END DO -!! -END PROCEDURE LegendreGradientEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEvalAll2 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP) :: p(1:SIZE(x), 1:n + 1) -!! -IF (n < 0) THEN - RETURN -END IF -!! -p(:, 1) = 1.0_DFP -ans(:, 1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -p(:, 2) = x -ans(:, 2) = 1.0_DFP -!! -DO ii = 2, n - !! - r_ii = REAL(ii, KIND=DFP) - !! - p(:, ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(:, ii) & - & - (r_ii - 1.0_DFP) * p(:, ii - 1)) & - & / r_ii - !! - ans(:, ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(:, ii) + ans(:, ii - 1) - !! -END DO -!! -END PROCEDURE LegendreGradientEvalAll2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEval1 - !! -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP) :: p, p_1, p_2 -REAL(DFP) :: ans_1, ans_2 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p = 1.0_DFP -ans = 0.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n < 1) THEN - RETURN -END IF -!! -p = x -ans = 1.0_DFP -!! -DO ii = 2, n - !! - r_ii = REAL(ii, KIND=DFP) - !! - p_1 = p - !! - p = ((2.0_DFP * r_ii - 1) * x * p & - & - (r_ii - 1.0_DFP) * p_2) & - & / r_ii - !! - p_2 = p_1 - !! - ans_1 = ans - ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 - ans_2 = ans_1 - !! -END DO -!! -END PROCEDURE LegendreGradientEval1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEval2 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 -REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p = 1.0_DFP -ans = 0.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n < 1) THEN - RETURN -END IF -!! -p = x -ans = 1.0_DFP -!! -DO ii = 2, n - !! - r_ii = REAL(ii, KIND=DFP) - !! - p_1 = p - !! - p = ((2.0_DFP * r_ii - 1) * x * p & - & - (r_ii - 1.0_DFP) * p_2) & - & / r_ii - !! - p_2 = p_1 - !! - ans_1 = ans - ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 - ans_2 = ans_1 - !! -END DO -!! -END PROCEDURE LegendreGradientEval2 - -!---------------------------------------------------------------------------- -! LegendreEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreEvalSum1 -REAL(DFP) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP) :: i -!! -IF (n .LT. 0) RETURN -!! -b1 = 0.0_DFP -b2 = 0.0_DFP -!! -DO j = n, 1, -1 - i = REAL(j, KIND=DFP) - t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) - b2 = b1 - b1 = t -END DO -!! -ans = x * b1 - b2 / 2.0_DFP + coeff(0) -!! -END PROCEDURE LegendreEvalSum1 - -!---------------------------------------------------------------------------- -! LegendreEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreEvalSum2 -REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP) :: i -!! -IF (n .LT. 0) RETURN -!! -b1 = 0.0_DFP -b2 = 0.0_DFP -!! -DO j = n, 1, -1 - i = REAL(j, KIND=DFP) - t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) - b2 = b1 - b1 = t -END DO -!! -ans = x * b1 - b2 / 2.0_DFP + coeff(0) -!! -END PROCEDURE LegendreEvalSum2 - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEvalSum1 -REAL(DFP) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP) :: i -!! -IF (n .LT. 0) RETURN -!! -b1 = 0 -b2 = 0 -!! -DO j = n - 1, 0, -1 - i = REAL(j, KIND=DFP) - t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); - b2 = b1; - b1 = t; -END DO -ans = b1 -END PROCEDURE LegendreGradientEvalSum1 - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEvalSum2 -REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP) :: i -!! -IF (n .LT. 0) RETURN -!! -b1 = 0 -b2 = 0 -!! -DO j = n - 1, 0, -1 - i = REAL(j, KIND=DFP) - t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); - b2 = b1; - b1 = t; -END DO -ans = b1 -END PROCEDURE LegendreGradientEvalSum2 - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEvalSum3 -REAL(DFP) :: t, b1, b2 -REAL(DFP) :: s, A1, A2 -INTEGER(I4B) :: j -REAL(DFP) :: i -!! -IF (n .LT. 0) RETURN -!! -b1 = 0 -b2 = 0 -s = 1.0_DFP -!! -DO j = 2 * k - 1, 1, -2 - s = j * s -END DO -!! -DO j = n - k, 0, -1 - i = REAL(j, KIND=DFP) - A1 = (2 * i + 2 * k + 1) / (i + 1) * x; - A2 = -(i + 2 * k + 1) / (i + 2); - t = A1 * b1 + A2 * b2 + coeff(j + k); - b2 = b1; - b1 = t; -END DO -ans = s * b1 -END PROCEDURE LegendreGradientEvalSum3 - -!---------------------------------------------------------------------------- -! LegendreGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientEvalSum4 -REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2, A1 -REAL(DFP) :: s, A2 -INTEGER(I4B) :: j -REAL(DFP) :: i -!! -IF (n .LT. 0) RETURN -!! -b1 = 0 -b2 = 0 -s = 1.0_DFP -!! -DO j = 2 * k - 1, 1, -2 - s = j * s -END DO -!! -DO j = n - k, 0, -1 - i = REAL(j, KIND=DFP) - A1 = (2 * i + 2 * k + 1) / (i + 1) * x; - A2 = -(i + 2 * k + 1) / (i + 2); - t = A1 * b1 + A2 * b2 + coeff(j + k); - b2 = b1; - b1 = t; -END DO -!! -ans = s * b1 -END PROCEDURE LegendreGradientEvalSum4 - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform1 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -REAL(DFP) :: rn -!! -nrmsqr = LegendreNormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP / rn -END IF -!! -PP = LegendreEvalAll(n=n, x=x) -!! -DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / nrmsqr(jj) -END DO -!! -END PROCEDURE LegendreTransform1 - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform2 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -REAL(DFP) :: rn -!! -nrmsqr = LegendreNormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP / rn -END IF -!! -PP = LegendreEvalAll(n=n, x=x) -!! -DO kk = 1, SIZE(coeff, 2) - DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / nrmsqr(jj) - END DO -END DO -!! -END PROCEDURE LegendreTransform2 - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) -INTEGER(I4B) :: ii -!! -CALL LegendreQuadrature(n=n + 1, pt=pt, wt=wt,& - & quadType=quadType) -!! -DO ii = 0, n - coeff(ii) = f(pt(ii)) -END DO -!! -ans = LegendreTransform(n=n, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) -!! -END PROCEDURE LegendreTransform3 - -!---------------------------------------------------------------------------- -! LegendreInvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreInvTransform1 -ans = LegendreEvalSum(n=n, coeff=coeff, x=x) -END PROCEDURE LegendreInvTransform1 - -!---------------------------------------------------------------------------- -! LegendreInvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreInvTransform2 -ans = LegendreEvalSum(n=n, coeff=coeff, x=x) -END PROCEDURE LegendreInvTransform2 - -!---------------------------------------------------------------------------- -! LegendreGradientCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreGradientCoeff1 -ans = UltrasphericalGradientCoeff(n=n, lambda=0.5_DFP, coeff=coeff) -END PROCEDURE LegendreGradientCoeff1 - -!---------------------------------------------------------------------------- -! LegendreDMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreDMatrix1 -SELECT CASE (quadType) -CASE (GaussLobatto) - CALL LegendreDMatrixGL2(n=n, x=x, D=ans) -CASE (Gauss) - CALL LegendreDMatrixG2(n=n, x=x, D=ans) -END SELECT -END PROCEDURE LegendreDMatrix1 - -!---------------------------------------------------------------------------- -! LegendreDMatrixGL -!---------------------------------------------------------------------------- - -PURE SUBROUTINE LegendreDMatrixGL(n, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - REAL(DFP) :: rn - INTEGER(I4B) :: ii, jj - !! - rn = REAL(n, KIND=DFP) - !! - J = LegendreEval(n=n, x=x) - !! - D = 0.0_DFP - D(0, 0) = 0.125_DFP * rn * (rn + 1.0_DFP) - D(n, n) = -D(0, 0) - !! - DO jj = 0, n - DO ii = 0, n - IF (ii .NE. jj) & - & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END DO - END DO - !! -END SUBROUTINE LegendreDMatrixGL - -!---------------------------------------------------------------------------- -! LegendreDMatrixGL -!---------------------------------------------------------------------------- - -PURE SUBROUTINE LegendreDMatrixGL2(n, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - REAL(DFP) :: rn - INTEGER(I4B) :: ii, jj, nb2 - !! - nb2 = INT(n / 2) - rn = REAL(n, KIND=DFP) - !! - J = LegendreEval(n=n, x=x) - D = 0.0_DFP - !! - DO jj = 0, n - DO ii = 0, nb2 - IF (ii .NE. jj) & - & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END DO - END DO - !! - !! correct diagonal entries - !! - DO ii = 0, nb2 - D(ii, ii) = -SUM(D(ii, :)) - END DO - !! - !! copy - !! - DO jj = 0, n - DO ii = 0, nb2 - D(n - ii, n - jj) = -D(ii, jj) - END DO - END DO - !! -END SUBROUTINE LegendreDMatrixGL2 - -!---------------------------------------------------------------------------- -! LegendreDMatrixG -!---------------------------------------------------------------------------- - -PURE SUBROUTINE LegendreDMatrixG(n, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - INTEGER(I4B) :: ii, jj - !! - !! Compute dJ_{N-1}(a+1,b+1) - !! - J = LegendreGradientEval(n=n + 1, x=x) - !! - DO jj = 0, n - DO ii = 0, n - IF (ii .EQ. jj) THEN - D(ii, ii) = x(ii) / (1.0 - x(ii)**2) - ELSE - D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END IF - END DO - END DO -!! -END SUBROUTINE LegendreDMatrixG - -!---------------------------------------------------------------------------- -! LegendreDMatrixG -!---------------------------------------------------------------------------- - -PURE SUBROUTINE LegendreDMatrixG2(n, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! internal variables - !! - REAL(DFP) :: J(0:n) - INTEGER(I4B) :: ii, jj, nb2 - !! - !! main - !! - nb2 = INT(n / 2) - D = 0.0_DFP - !! - J = LegendreGradientEval(n=n + 1, x=x) - !! - DO jj = 0, n - DO ii = 0, nb2 - IF (ii .NE. jj) & - & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END DO - END DO - !! - !! correct diagonal entries - !! - DO ii = 0, nb2 - D(ii, ii) = -SUM(D(ii, :)) - END DO - !! - !! copy - !! - DO jj = 0, n - DO ii = 0, nb2 - D(n - ii, n - jj) = -D(ii, jj) - END DO - END DO - !! -END SUBROUTINE LegendreDMatrixG2 - -!---------------------------------------------------------------------------- -! LegendreDMatEvenOdd -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreDMatEvenOdd1 -CALL UltrasphericalDMatEvenOdd(n=n, D=D, o=o, e=e) -END PROCEDURE LegendreDMatEvenOdd1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 deleted file mode 100644 index ba2d7102b..000000000 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,1404 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(LineInterpolationUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefElemDomain_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Line -ans = "BIUNIT" -END PROCEDURE RefElemDomain_Line - -!---------------------------------------------------------------------------- -! QuadratureNumber_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadratureNumber_Line -SELECT CASE (quadType) -CASE (GaussLegendre, GaussChebyshev, GaussJacobi, GaussUltraspherical) - ans = 1_I4B + INT(order / 2, kind=I4B) -CASE DEFAULT - ans = 2_I4B + INT(order / 2, kind=I4B) -END SELECT -END PROCEDURE QuadratureNumber_Line - -!---------------------------------------------------------------------------- -! ToVEFC_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ToVEFC_Line -REAL(DFP) :: t1 -INTEGER(I4B) :: np -np = SIZE(pt) -t1 = pt(np) -IF (np .GT. 2) THEN - pt(3:np) = pt(2:np - 1) - pt(2) = t1 -END IF -END PROCEDURE ToVEFC_Line - -!---------------------------------------------------------------------------- -! LagrangeDegree_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Line -INTEGER(I4B) :: ii, n -n = LagrangeDOF_Line(order=order) -ALLOCATE (ans(n, 1)) -DO ii = 1, n - ans(ii, 1) = ii - 1 -END DO -END PROCEDURE LagrangeDegree_Line - -!---------------------------------------------------------------------------- -! LagrangeDOF_Point -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Point -ans = 1_I4B -END PROCEDURE LagrangeDOF_Point - -!---------------------------------------------------------------------------- -! LagrangeDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Line -ans = order + 1 -END PROCEDURE LagrangeDOF_Line - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Line -ans = order - 1_I4B -END PROCEDURE LagrangeInDOF_Line - -!---------------------------------------------------------------------------- -! GetTotalDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Line -ans = order + 1 -END PROCEDURE GetTotalDOF_Line - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Line -ans = order - 1_I4B -END PROCEDURE GetTotalInDOF_Line - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Line1 -INTEGER(I4B) :: n, ii -REAL(DFP) :: avar -IF (order .LE. 1_I4B) THEN - ALLOCATE (ans(0)) - RETURN -END IF -n = LagrangeInDOF_Line(order=order) -ALLOCATE (ans(n)) -avar = (xij(2) - xij(1)) / order -DO ii = 1, n - ans(ii) = xij(1) + ii * avar -END DO -END PROCEDURE EquidistanceInPoint_Line1 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Line2 -INTEGER(I4B) :: n, ii, nsd -REAL(DFP) :: x0(3, 2) -REAL(DFP) :: avar(3) -IF (order .LE. 1_I4B) THEN - ALLOCATE (ans(0, 0)) - RETURN -END IF -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x0(1:nsd, 1) = xij(1:nsd, 1) - x0(1:nsd, 2) = xij(1:nsd, 2) -ELSE - nsd = 1_I4B - x0(1:nsd, 1) = [-1.0] - x0(1:nsd, 2) = [1.0] -END IF -n = LagrangeInDOF_Line(order=order) -ALLOCATE (ans(nsd, n)) -avar(1:nsd) = (x0(1:nsd, 2) - x0(1:nsd, 1)) / order -DO ii = 1, n - ans(1:nsd, ii) = x0(1:nsd, 1) + ii * avar(1:nsd) -END DO -END PROCEDURE EquidistanceInPoint_Line2 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Line1 -CALL Reallocate(ans, order + 1) -IF (order .EQ. 0_I4B) THEN - ans(1) = 0.5_DFP * (xij(1) + xij(2)) - RETURN -END IF -ans(1) = xij(1) -ans(2) = xij(2) -IF (order .GE. 2) THEN - ans(3:) = EquidistanceInPoint_Line(order=order, xij=xij) -END IF -END PROCEDURE EquidistancePoint_Line1 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Line2 -INTEGER(I4B) :: nsd - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - CALL Reallocate(ans, nsd, order + 1) - IF (order .EQ. 0_I4B) THEN - ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) - RETURN - END IF - ans(1:nsd, 1) = xij(1:nsd, 1) - ans(1:nsd, 2) = xij(1:nsd, 2) -ELSE - nsd = 1_I4B - CALL Reallocate(ans, nsd, order + 1) - IF (order .EQ. 0_I4B) THEN - ans(1:nsd, 1) = 0.0_DFP - RETURN - END IF - ans(1:nsd, 1) = [-1.0] - ans(1:nsd, 2) = [1.0] -END IF -IF (order .GE. 2) THEN - ans(1:nsd, 3:) = EquidistanceInPoint_Line(order=order, xij=xij) -END IF -END PROCEDURE EquidistancePoint_Line2 - -!---------------------------------------------------------------------------- -! InterpolationPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Line1 -CHARACTER(20) :: astr -INTEGER(I4B) :: nsd, ii -REAL(DFP) :: temp(order + 1), t1 - -IF (order .EQ. 0_I4B) THEN - IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - CALL Reallocate(ans, nsd, 1) - ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) - ELSE - CALL Reallocate(ans, 1, 1) - ans = 0.0_DFP - END IF - RETURN -END IF - -astr = TRIM(UpperCase(layout)) - -SELECT CASE (ipType) - -CASE (Equidistance) - ans = EquidistancePoint_Line(xij=xij, order=order) - IF (astr .EQ. "INCREASING") THEN - DO ii = 1, SIZE(ans, 1) - ans(ii, :) = SORT(ans(ii, :)) - END DO - END IF - RETURN -CASE (GaussLegendre) - CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=Gauss) -CASE (GaussLegendreLobatto) - CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:) = temp(2:order) - END IF - temp(2) = t1 - END IF - -CASE (GaussChebyshev) - CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=Gauss) - -CASE (GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:) = temp(2:order) - END IF - temp(2) = t1 - END IF - -CASE (GaussJacobi) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobi", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=Gauss, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiLobatto) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobi", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=GaussLobatto, & - & alpha=alpha, & - & beta=beta) - - IF (layout .EQ. "VEFC") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:) = temp(2:order) - END IF - temp(2) = t1 - END IF - -CASE (GaussUltraspherical) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltraspherical", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=Gauss, & - & lambda=lambda) - -CASE (GaussUltrasphericalLobatto) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=GaussLobatto, & - & lambda=lambda) - - IF (layout .EQ. "VEFC") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:) = temp(2:order) - END IF - temp(2) = t1 - END IF - -CASE DEFAULT - CALL ErrorMsg(& - & msg="Unknown iptype", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) -END SELECT - -IF (ipType .NE. Equidistance) THEN - IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - CALL Reallocate(ans, nsd, order + 1) - ans = FromBiunitLine2Segment(xin=temp, x1=xij(:, 1), & - & x2=xij(:, 2)) - ELSE - CALL Reallocate(ans, 1, order + 1) - ans(1, :) = temp - END IF -END IF -END PROCEDURE InterpolationPoint_Line1 - -!---------------------------------------------------------------------------- -! InterpolationPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Line2 -CHARACTER(20) :: astr -REAL(DFP) :: t1 - -IF (order .EQ. 0_I4B) THEN - ans = [0.5_DFP * (xij(1) + xij(2))] - RETURN -END IF - -CALL Reallocate(ans, order + 1) -astr = TRIM(UpperCase(layout)) - -SELECT CASE (ipType) -CASE (Equidistance) - ans = EquidistancePoint_Line(xij=xij, order=order) - IF (astr .EQ. "INCREASING") ans = SORT(ans) - RETURN - -CASE (GaussLegendre) - CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=Gauss) - -CASE (GaussLegendreLobatto) - CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) - END IF - ans(2) = t1 - END IF - -CASE (GaussChebyshev) - CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=Gauss) - -CASE (GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) - END IF - ans(2) = t1 - END IF - -CASE (GaussJacobi) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobi", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=Gauss, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiLobatto) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobiLobatto", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=GaussLobatto, & - & alpha=alpha, & - & beta=beta) - - IF (layout .EQ. "VEFC") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) - END IF - ans(2) = t1 - END IF - -CASE (GaussUltraspherical) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltraspherical", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=Gauss, & - & lambda=lambda) - -CASE (GaussUltrasphericalLobatto) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=GaussLobatto, & - & lambda=lambda) - - IF (layout .EQ. "VEFC") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) - END IF - ans(2) = t1 - END IF - -CASE DEFAULT - CALL ErrorMsg(& - & msg="Unknown iptype", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) -END SELECT - -IF (ipType .NE. Equidistance) THEN - ans = FromBiunitLine2Segment(xin=ans, x1=xij(1), x2=xij(2)) -END IF -END PROCEDURE InterpolationPoint_Line2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line1 -REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -v = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) -CALL getLU(A=v, IPIV=ipiv, info=info) -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Line1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line2 -REAL(DFP) :: vtemp(SIZE(v, 1), SIZE(v, 2)) -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ipiv = 0 -CALL getLU(A=vtemp, IPIV=ipiv, info=info) -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Line2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Line3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line4 -ans = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Line4 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line5 -SELECT CASE (basisType) -CASE (Monomial) - ans = LagrangeCoeff_Line(order=order, xij=xij) -CASE DEFAULT - ans = EvalAllOrthopol(& - & n=order, & - & x=xij(1, :), & - & orthopol=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - CALL GetInvMat(ans) -END SELECT -END PROCEDURE LagrangeCoeff_Line5 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Line1 -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) -INTEGER(I4B) :: ii, orthopol0 - -IF (SIZE(xij, 2) .NE. order + 1) THEN - CALL Errormsg(& - & msg="Size(xij, 1) .NE. order+1 ", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -orthopol0 = input(default=Monomial, option=basisType) -firstCall0 = input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - END IF - coeff0 = TRANSPOSE(coeff) -ELSE - coeff0 = TRANSPOSE(LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & )) -END IF - -SELECT CASE (orthopol0) -CASE (Monomial) - xx(1, 1) = 1.0_DFP - DO ii = 1, order - xx(1, ii + 1) = xx(1, ii) * x - END DO -CASE DEFAULT - xx = EvalAllOrthopol(& - & n=order, & - & x=[x], & - & orthopol=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT - -ans = MATMUL(coeff0, xx(1, :)) - -END PROCEDURE LagrangeEvalAll_Line1 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Line2 -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) -INTEGER(I4B) :: ii, orthopol0 - -IF (SIZE(xij, 2) .NE. order + 1) THEN - CALL Errormsg(& - & msg="Size(xij, 1) .NE. order+1 ", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -orthopol0 = Input(default=Monomial, option=basisType) -firstCall0 = Input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - END IF - coeff0 = coeff -ELSE - coeff0 = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) -END IF - -SELECT CASE (orthopol0) -CASE (Monomial) - xx(:, 1) = 1.0_DFP - DO ii = 1, order - xx(:, ii + 1) = xx(:, ii) * x(1, :) - END DO -CASE DEFAULT - xx = EvalAllOrthopol(& - & n=order, & - & x=x(1, :), & - & orthopol=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT - -ans = MATMUL(xx, coeff0) - -END PROCEDURE LagrangeEvalAll_Line2 - -!---------------------------------------------------------------------------- -! EvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line1 -INTEGER(I4B) :: ii, basisType0 -TYPE(String) :: astr -astr = UpperCase(refLine) - -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -basisType0 = input(default=Monomial, option=basisType) -SELECT CASE (basisType0) -CASE (Monomial) - ans(1) = 1.0_DFP - DO ii = 1, order - ans(ii + 1) = ans(ii) * x - END DO -CASE DEFAULT - - IF (basisType0 .EQ. Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - ans = RESHAPE(EvalAllOrthopol(& - & n=order, & - & x=[x], & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda), [order + 1]) -END SELECT - -END PROCEDURE BasisEvalAll_Line1 - -!---------------------------------------------------------------------------- -! BasisGradientEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line1 -INTEGER(I4B) :: ii, basisType0 -TYPE(String) :: astr -astr = UpperCase(refLine) - -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -basisType0 = input(default=Monomial, option=basisType) -SELECT CASE (basisType0) -CASE (Monomial) - ans(1) = 0.0_DFP - DO ii = 1, order - ans(ii + 1) = REAL(ii, dfp) * x**(ii - 1) - END DO -CASE DEFAULT - - IF (basisType0 .EQ. Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - ans = RESHAPE(GradientEvalAllOrthopol(& - & n=order, & - & x=[x], & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda), [order + 1]) -END SELECT - -END PROCEDURE BasisGradientEvalAll_Line1 - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line2 -INTEGER(I4B) :: ii, basisType0 -TYPE(String) :: astr -astr = UpperCase(refLine) - -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -basisType0 = input(default=Monomial, option=basisType) -SELECT CASE (basisType0) -CASE (Monomial) - ans(:, 1) = 1.0_DFP - DO ii = 1, order - ans(:, ii + 1) = ans(:, ii) * x - END DO -CASE DEFAULT - - IF (basisType0 .EQ. Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - ans = EvalAllOrthopol(& - & n=order, & - & x=x, & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT - -END PROCEDURE BasisEvalAll_Line2 - -!---------------------------------------------------------------------------- -! BasisGradientEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line2 -INTEGER(I4B) :: ii, basisType0 -TYPE(String) :: astr -astr = UpperCase(refLine) - -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -basisType0 = input(default=Monomial, option=basisType) -SELECT CASE (basisType0) -CASE (Monomial) - ans(:, 1) = 0.0_DFP - DO ii = 1, order - ans(:, ii + 1) = REAL(ii, dfp) * x**(ii - 1) - END DO -CASE DEFAULT - - IF (basisType0 .EQ. Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - ans = GradientEvalAllOrthopol(& - & n=order, & - & x=x, & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT - -END PROCEDURE BasisGradientEvalAll_Line2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line1 -INTEGER(I4B) :: nips(1) -nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) -ans = QuadraturePoint_Line3(nips=nips, quadType=quadType, & -& layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE QuadraturePoint_Line1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line2 -ans = QuadraturePoint_Line1(& - & order=order, & - & quadType=quadType, & - & layout=layout, & - & xij=RESHAPE(xij, [1, 2]), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END PROCEDURE QuadraturePoint_Line2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line4 -ans = QuadraturePoint_Line3(& - & nips=nips, & - & quadType=quadType, & - & layout=layout, & - & xij=RESHAPE(xij, [1, 2]), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END PROCEDURE QuadraturePoint_Line4 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line3 -CHARACTER(20) :: astr -INTEGER(I4B) :: np, nsd, ii -REAL(DFP) :: pt(nips(1)), wt(nips(1)) -REAL(DFP) :: t1 -LOGICAL(LGT) :: changeLayout - -IF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for quadType=GaussJacobi", & - & file=__FILE__, & - & routine="QuadraturePoint_Line3", & - & line=__LINE__, & - & unitno=stderr) - END IF - RETURN -ELSEIF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for quadType=GaussUltraspherical", & - & file=__FILE__, & - & routine="QuadraturePoint_Line3", & - & line=__LINE__, & - & unitno=stderr) - END IF - RETURN -END IF - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 1 -END IF - -astr = TRIM(UpperCase(layout)) -np = nips(1) -CALL Reallocate(ans, nsd + 1_I4B, np) -changeLayout = .FALSE. - -SELECT CASE (quadType) - -CASE (GaussLegendre) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss) - -CASE (GaussLegendreRadauLeft) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) - -CASE (GaussLegendreRadauRight) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) - -CASE (GaussLegendreLobatto) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. - -CASE (GaussChebyshev) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=Gauss) - -CASE (GaussChebyshevRadauLeft) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) - -CASE (GaussChebyshevRadauRight) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) - -CASE (GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. - -CASE (GaussJacobi) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=Gauss, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiRadauLeft) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauLeft, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiRadauRight) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauRight, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiLobatto) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussLobatto, & - & alpha=alpha, & - & beta=beta) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. - -CASE (GaussUltraspherical) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=Gauss, & - & lambda=lambda) - -CASE (GaussUltrasphericalRadauLeft) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauLeft, & - & lambda=lambda) - -CASE (GaussUltrasphericalRadauRight) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauRight, & - & lambda=lambda) - -CASE (GaussUltrasphericalLobatto) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussLobatto, & - & lambda=lambda) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. - -CASE DEFAULT - CALL ErrorMsg(& - & msg="Unknown iptype", & - & file=__FILE__, & - & routine="QuadraturePoint_Line3", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -IF (changeLayout) THEN - CALL ToVEFC_Line(pt) - CALL ToVEFC_Line(wt) -END IF - -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiunitLine2Segment( & - & xin=pt, & - & x1=xij(:, 1), & - & x2=xij(:, 2)) - ans(nsd + 1, :) = wt * NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP -ELSE - ans(1, :) = pt - ans(nsd + 1, :) = wt -END IF -END PROCEDURE QuadraturePoint_Line3 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Line1 -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1) -INTEGER(I4B) :: ii, orthopol0 - -orthopol0 = input(default=Monomial, option=basisType) -firstCall0 = input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - END IF - coeff0 = coeff -ELSE - coeff0 = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) -END IF - -SELECT CASE (orthopol0) -CASE (Monomial) - - IF (SIZE(xij, 2) .NE. order + 1) THEN - CALL Errormsg(& - & msg="size(xij, 2) is not same as order+1", & - & file=__FILE__, & - & routine="LagrangeGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 0, order - xx(:, ii + 1) = REAL(ii, kind=DFP) * x(1, :)**(MAX(ii - 1_I4B, 0_I4B)) - END DO - -CASE DEFAULT - xx = GradientEvalAllOrthopol(& - & n=order, & - & x=x(1, :), & - & orthopol=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT - -ans(:, :, 1) = MATMUL(xx, coeff0) - -END PROCEDURE LagrangeGradientEvalAll_Line1 - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Line1 -TYPE(String) :: astr -astr = UpperCase(refLine) - -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = EvalAllOrthopol( & - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=Lobatto) -CASE ("BIUNIT") - ans = EvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=Lobatto) -CASE DEFAULT - ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refline.", & - & file=__FILE__, & - & routine="HeirarchicalBasis_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE HeirarchicalBasis_Line1 - -!---------------------------------------------------------------------------- -! HeirarchicalGradientBasis_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalGradientBasis_Line1 -TYPE(String) :: astr -astr = UpperCase(refLine) - -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=Lobatto) - ans = ans * 2.0_DFP -CASE ("BIUNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=Lobatto) -CASE DEFAULT - ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refline.", & - & file=__FILE__, & - & routine="HeirarchicalGradientBasis_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE HeirarchicalGradientBasis_Line1 - -!---------------------------------------------------------------------------- -! OrthogonalBasis_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasis_Line1 -INTEGER(I4B) :: ii -TYPE(String) :: astr - -ans = 0.0_DFP -astr = UpperCase(refLine) - -IF (basisType .EQ. Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF -END IF - -IF (basisType .EQ. Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF -END IF - -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = EvalAllOrthopol(& - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE ("BIUNIT") - ans = EvalAllOrthopol(& - & n=order, & - & x=xij(1, :), & - & orthopol=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -CASE DEFAULT - ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refLine.", & - & file=__FILE__, & - & routine="OrthogonalBasis_Line1()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE OrthogonalBasis_Line1 - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Line1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasisGradient_Line1 -TYPE(String) :: astr -astr = UpperCase(refLine) - -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=basisType) - ans = ans * 2.0_DFP -CASE ("BIUNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=basisType) -CASE DEFAULT - ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refline.", & - & file=__FILE__, & - & routine=" OrthogonalBasisGradient_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT -END PROCEDURE OrthogonalBasisGradient_Line1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 deleted file mode 100644 index 2278c25d1..000000000 --- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 +++ /dev/null @@ -1,453 +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(LobattoPolynomialUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! LobattoLeadingCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoLeadingCoeff -REAL(DFP) :: avar, m - !! -SELECT CASE (n) -CASE (0) - ans = 0.5_DFP -CASE (1) - ans = -0.5_DFP -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - m = LegendreLeadingCoeff(n=n) - ans = m * avar -END SELECT -END PROCEDURE LobattoLeadingCoeff - -!---------------------------------------------------------------------------- -! LobattoNormSqr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoNormSqr -REAL(DFP) :: m, a1, a2 -SELECT CASE (n) -CASE (0, 1) - ans = 2.0_DFP / 3.0_DFP -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - a1 = (2.0_DFP * m + 1) - a2 = (2.0_DFP * m + 5) - ans = 2.0_DFP / a1 / a2 -END SELECT -END PROCEDURE LobattoNormSqr - -!---------------------------------------------------------------------------- -! LobattoZeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoZeros -SELECT CASE (n) -CASE (1) - ans(1) = 1.0_DFP -CASE (2) - ans(1) = -1.0_DFP - ans(2) = 1.0_DFP -CASE DEFAULT - ans(1) = -1.0_DFP - ans(n) = 1.0_DFP - ans(2:n - 1) = JacobiZeros(alpha=1.0_DFP, beta=1.0_DFP, n=n - 2_I4B) -END SELECT -END PROCEDURE LobattoZeros - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoEval1 -REAL(DFP) :: avar, m -SELECT CASE (n) -CASE (0) - ans = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) -END SELECT -END PROCEDURE LobattoEval1 - -!---------------------------------------------------------------------------- -! LobattoEval -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoEval2 -REAL(DFP) :: avar, m - !! -SELECT CASE (n) -CASE (0) - ans = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) -END SELECT -END PROCEDURE LobattoEval2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoEvalAll1 -REAL(DFP) :: avar, m -REAL(DFP) :: p(n + 1) -INTEGER(I4B) :: ii - !! -SELECT CASE (n) -CASE (0) - ans(1) = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans(1) = 0.5_DFP * (1.0_DFP - x) - ans(2) = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - ans(1) = 0.5_DFP * (1.0_DFP - x) - ans(2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) - DO ii = 1, n - 1 - m = REAL(ii - 1, KIND=DFP) - avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - ans(2 + ii) = avar * (p(ii + 2) - p(ii)) - END DO -END SELECT -END PROCEDURE LobattoEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoEvalAll2 -REAL(DFP) :: avar, m -REAL(DFP) :: p(SIZE(x), n + 1) -INTEGER(I4B) :: ii -SELECT CASE (n) -CASE (0) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) - DO ii = 1, n - 1 - m = REAL(ii - 1, KIND=DFP) - avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) - END DO -END SELECT -END PROCEDURE LobattoEvalAll2 - -!---------------------------------------------------------------------------- -! LobattoKernelEvalAll -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoKernelEvalAll1 -INTEGER(I4B) :: nrow, ncol -CALL LobattoKernelEvalAll1_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE LobattoKernelEvalAll1 - -!---------------------------------------------------------------------------- -! LobattoKernelEvalAll -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoKernelEvalAll1_ -REAL(DFP) :: m, avar -INTEGER(I4B) :: ii - -CALL UltrasphericalEvalAll_(n=n, x=x, lambda=1.5_DFP, ans=ans, nrow=nrow, & - ncol=ncol) - -DO ii = 0, n - m = REAL(ii, KIND=DFP) - avar = -SQRT(8.0_DFP*(2.0_DFP*m+3.0_DFP))/(m+1.0_DFP)/(m+2.0_DFP) - ans(1:nrow, ii) = avar * ans(1:nrow, ii) -END DO -END PROCEDURE LobattoKernelEvalAll1_ - -!---------------------------------------------------------------------------- -! LobattoKernelGradientEvalAll1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoKernelGradientEvalAll1 -REAL(DFP) :: m, avar -INTEGER(I4B) :: ii - -ans = UltrasphericalGradientEvalAll(n=n, x=x, lambda=1.5_DFP) -DO ii = 0, n - m = REAL(ii, KIND=DFP) - avar = -SQRT(8.0_DFP*(2.0_DFP*m+3.0_DFP))/(m+1.0_DFP)/(m+2.0_DFP) - ans(:, ii) = avar * ans(:, ii) -END DO -END PROCEDURE LobattoKernelGradientEvalAll1 - -!---------------------------------------------------------------------------- -! LobattoKernelGradientEvalAll1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoKernelGradientEvalAll1_ -REAL(DFP) :: m, avar -INTEGER(I4B) :: ii - -CALL UltrasphericalGradientEvalAll_(n=n, x=x, lambda=1.5_DFP, nrow=nrow, & - ncol=ncol, ans=ans) -DO CONCURRENT(ii=0:n) - m = REAL(ii, KIND=DFP) - avar = -SQRT(8.0_DFP*(2.0_DFP*m+3.0_DFP))/(m+1.0_DFP)/(m+2.0_DFP) - ans(1:nrow, ii) = avar * ans(1:nrow, ii) -END DO -END PROCEDURE LobattoKernelGradientEvalAll1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoMonomialExpansionAll -REAL(DFP) :: avar, m -REAL(DFP) :: p(n + 1, n + 1) -INTEGER(I4B) :: ii -!! -ans = 0.0_DFP -!! -SELECT CASE (n) -CASE (0) - ans(1, 1) = 0.5_DFP -CASE (1) - ans(1, 1) = 0.5_DFP - ans(2, 1) = -0.5_DFP - ans(1, 2) = 0.5_DFP - ans(2, 2) = 0.5_DFP -CASE DEFAULT - ans(1, 1) = 0.5_DFP - ans(2, 1) = -0.5_DFP - ans(1, 2) = 0.5_DFP - ans(2, 2) = 0.5_DFP - !! - p = LegendreMonomialExpansionAll(n=n) - !! - DO ii = 1, n - 1 - m = REAL(ii - 1, KIND=DFP) - avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - ans(:, ii + 2) = avar * (p(:, ii + 2) - p(:, ii)) - END DO - !! -END SELECT -END PROCEDURE LobattoMonomialExpansionAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoMonomialExpansion -REAL(DFP) :: coeff(n + 1, n + 1) -coeff = LobattoMonomialExpansionAll(n) -ans = coeff(:, n + 1) -END PROCEDURE LobattoMonomialExpansion - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoGradientEvalAll1 -REAL(DFP) :: p(n), avar, m -INTEGER(I4B) :: ii - !! -SELECT CASE (n) -CASE (0) - ans(1) = -0.5_DFP -CASE (1) - ans(1) = -0.5_DFP - ans(2) = 0.5_DFP -CASE DEFAULT - ans(1) = -0.5_DFP - ans(2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! - DO ii = 1, n - 1 - m = REAL(ii - 1, DFP) - avar = SQRT((2.0_DFP * m + 3.0) / 2.0) - ans(ii + 2) = avar * p(ii + 1) - ! ans(3:) = p(2:) - END DO - !! -END SELECT -END PROCEDURE LobattoGradientEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoGradientEvalAll2 -REAL(DFP) :: p(SIZE(x), n), avar, m -INTEGER(I4B) :: ii - !! -SELECT CASE (n) -CASE (0) - ans(:, 1) = -0.5_DFP -CASE (1) - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP -CASE DEFAULT - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! - DO ii = 1, n - 1 - m = REAL(ii - 1, DFP) - avar = SQRT((2.0_DFP * m + 3.0) / 2.0) - ans(:, ii + 2) = avar * p(:, ii + 1) - ! ans(3:) = p(2:) - END DO - !! -END SELECT -END PROCEDURE LobattoGradientEvalAll2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoGradientEval1 -REAL(DFP) :: p, avar, m - !! -SELECT CASE (n) -CASE (0) - ans = -0.5_DFP -CASE (1) - ans = 0.5_DFP -CASE DEFAULT - !! - p = LegendreEval(n=n - 1_I4B, x=x) - m = REAL(n - 2, DFP) - avar = SQRT((2.0_DFP * m + 3.0) / 2.0) - ans = avar * p -END SELECT -END PROCEDURE LobattoGradientEval1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoGradientEval2 -REAL(DFP) :: p(SIZE(x)), avar, m - !! -SELECT CASE (n) -CASE (0) - ans = -0.5_DFP -CASE (1) - ans = 0.5_DFP -CASE DEFAULT - !! - p = LegendreEval(n=n - 1_I4B, x=x) - m = REAL(n - 2, DFP) - avar = SQRT((2.0_DFP * m + 3.0) / 2.0) - ans = avar * p -END SELECT -END PROCEDURE LobattoGradientEval2 - -!---------------------------------------------------------------------------- -! LobattoMassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoMassMatrix -INTEGER(I4B) :: ii -REAL(DFP) :: m -!! -ans = 0.0_DFP -!! -DO ii = 1, n + 1 - ans(ii, ii) = LobattoNormSQR(n=ii - 1_I4B) -END DO -!! -IF (n .EQ. 0_I4B) RETURN -!! -ans(1, 2) = 1.0_DFP / 3.0_DFP -ans(2, 1) = ans(1, 2) -!! -IF (n .EQ. 1_I4B) RETURN -!! -ans(1, 3) = -1.0_DFP / SQRT(6.0_DFP) -ans(3, 1) = ans(1, 3) -ans(2, 3) = ans(1, 3) -ans(3, 2) = ans(2, 3) -!! -IF (n .EQ. 2_I4B) RETURN -!! -ans(1, 4) = 1.0_DFP / SQRT(90.0_DFP) -ans(4, 1) = ans(1, 4) -ans(2, 4) = -ans(1, 4) -ans(4, 2) = ans(2, 4) -!! -IF (n .EQ. 3_I4B) RETURN -!! -DO ii = 3, n + 1 - !! - m = REAL(ii - 3, DFP) - !! - IF (ii + 2 .LE. n + 1) THEN - ans(ii, ii + 2) = -1.0_DFP / (2.0_DFP * m + 5.0_DFP) / & - & SQRT((2.0_DFP * m + 7.0_DFP) * (2.0_DFP * m + 3.0_DFP)) - !! - ans(ii + 2, ii) = ans(ii, ii + 2) - END IF - !! -END DO -!! -END PROCEDURE LobattoMassMatrix - -!---------------------------------------------------------------------------- -! LobattoStiffnessMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoStiffnessMatrix -INTEGER(I4B) :: ii - -ans = 0.0_DFP - -DO ii = 1, n + 1 - ans(ii, ii) = 1.0_DFP -END DO - -ans(1, 1) = 0.5_DFP - -IF (n .EQ. 0_I4B) RETURN - -ans(2, 2) = 0.5_DFP -ans(1, 2) = -0.5_DFP -ans(2, 1) = ans(1, 2) - -END PROCEDURE LobattoStiffnessMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 deleted file mode 100644 index 207d2760c..000000000 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ /dev/null @@ -1,159 +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(OrthogonalPolynomialUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Clenshaw_1 -REAL(DFP), DIMENSION(0:SIZE(c)) :: u -INTEGER(I4B) :: ii, n -REAL(DFP) :: y00, ym10 - -y00 = INPUT(default=1.0_DFP, option=y0) -ym10 = INPUT(default=0.0_DFP, option=ym1) - -!! The size of c, alpha, beta should be same n+1: 0 to n -!! The size of u is n+2, 0 to n+1 -n = SIZE(c) - 1 -u(n) = c(n) -u(n + 1) = 0.0_DFP -DO ii = n - 1, 0, -1 - u(ii) = (x - alpha(ii)) * u(ii + 1) - beta(ii + 1) * u(ii + 2) + c(ii) -END DO -ans = u(0) * y00 - beta(0) * u(1) * ym10 -END PROCEDURE Clenshaw_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Clenshaw_2 -REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c)) :: u -INTEGER(I4B) :: ii, n -REAL(DFP) :: y00, ym10 -y00 = INPUT(default=1.0_DFP, option=y0) -ym10 = INPUT(default=0.0_DFP, option=ym1) -!! The size of c, alpha, beta should be same n+1: 0 to n -!! The size of u is n+2, 0 to n+1 -n = SIZE(c) - 1 -u(:, n) = c(n) -u(:, n + 1) = 0.0_DFP -DO ii = n - 1, 0, -1 - u(:, ii) = (x - alpha(ii)) * u(:, ii + 1) & - & - beta(ii + 1) * u(:, ii + 2) + c(ii) -END DO -ans = u(:, 0) * y00 - beta(0) * u(:, 1) * ym10 -END PROCEDURE Clenshaw_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ChebClenshaw_1 -REAL(DFP), DIMENSION(0:SIZE(c) + 2) :: u -INTEGER(I4B) :: ii, n -!! The size of c is n+1: 0 to n -!! The size of u is n+3, 0 to n+2 -n = SIZE(c) - 1 -u(n) = c(n) -u(n + 1) = 0.0_DFP -u(n + 2) = 0.0_DFP -DO ii = n - 1, 0, -1 - u(ii) = 2.0_DFP * x * u(ii + 1) - u(ii + 2) + c(ii) -END DO -ans = 0.5_DFP * (u(0) - u(2)) -END PROCEDURE ChebClenshaw_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ChebClenshaw_2 -REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c) + 2) :: u -INTEGER(I4B) :: ii, n -!! The size of c is n+1: 0 to n -!! The size of u is n+3, 0 to n+2 -n = SIZE(c) - 1 -u(:, n) = c(n) -u(:, n + 1) = 0.0_DFP -u(:, n + 2) = 0.0_DFP -DO ii = n - 1, 0, -1 - u(:, ii) = 2.0_DFP * x * u(:, ii + 1) - u(:, ii + 2) + c(ii) -END DO -ans = 0.5_DFP * (u(:, 0) - u(:, 2)) -END PROCEDURE ChebClenshaw_2 - -!---------------------------------------------------------------------------- -! JacobiMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiMatrix_1 -INTEGER(I4B) :: n -n = SIZE(alphaCoeff) -D(1:n) = alphaCoeff(0:n - 1) -E(1:n - 1) = SQRT(betaCoeff(1:n - 1)) -END PROCEDURE JacobiMatrix_1 - -!---------------------------------------------------------------------------- -! EvalAllOrthopol -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EvalAllOrthopol -SELECT CASE (orthopol) -CASE (Jacobi) - ans = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) -CASE (Ultraspherical) - ans = UltraSphericalEvalAll(n=n, lambda=lambda, x=x) -CASE (Legendre) - ans = LegendreEvalAll(n=n, x=x) -CASE (Chebyshev) - ans = Chebyshev1EvalAll(n=n, x=x) -CASE (Lobatto) - ans = LobattoEvalAll(n=n, x=x) -CASE (UnscaledLobatto) - ans = UnscaledLobattoEvalAll(n=n, x=x) -END SELECT -END PROCEDURE EvalAllOrthopol - -!---------------------------------------------------------------------------- -! GradientEvalAllOrthopol -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GradientEvalAllOrthopol -SELECT CASE (orthopol) -CASE (Jacobi) - ans = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) -CASE (Ultraspherical) - ans = UltraSphericalGradientEvalAll(n=n, lambda=lambda, x=x) -CASE (Legendre) - ans = LegendreGradientEvalAll(n=n, x=x) -CASE (Chebyshev) - ans = Chebyshev1GradientEvalAll(n=n, x=x) -CASE (Lobatto) - ans = LobattoGradientEvalAll(n=n, x=x) -CASE (UnscaledLobatto) - ans = UnscaledLobattoGradientEvalAll(n=n, x=x) -END SELECT -END PROCEDURE GradientEvalAllOrthopol - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 deleted file mode 100644 index 89c49dfe6..000000000 --- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,285 +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(PrismInterpolationUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeConnectivity_Prism -CALL GetEdgeConnectivity_Prism(con=ans) -END PROCEDURE EdgeConnectivity_Prism - -!---------------------------------------------------------------------------- -! FacetConnectivity_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetConnectivity_Prism -!! ans -ans(:, 1) = [3, Triangle3, 1, 3, 2, 0] -ans(:, 2) = [4, Quadrangle4, 2, 3, 6, 5] -ans(:, 3) = [4, Quadrangle4, 1, 2, 5, 4] -ans(:, 4) = [4, Quadrangle4, 1, 4, 6, 3] -ans(:, 5) = [3, Triangle3, 4, 5, 6, 0] -END PROCEDURE FacetConnectivity_Prism - -!---------------------------------------------------------------------------- -! RefElemDomain_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Prism -!FIX: Implement RefElemDomain_Prism -CALL Errormsg(& - & msg="[WORK IN PROGRESS] We are working on it", & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Prism()", & - & unitno=stderr) -END PROCEDURE RefElemDomain_Prism - -!---------------------------------------------------------------------------- -! LagrangeDegree_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Prism - -!ISSUE: #164 Implement LagrangeDegree_Prism - -END PROCEDURE LagrangeDegree_Prism - -!---------------------------------------------------------------------------- -! LagrangeDOF_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Prism -ans = (order + 1)**2 * (order + 2) / 2_I4B -END PROCEDURE LagrangeDOF_Prism - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Prism -ans = (order - 1)**2 * (order - 2) / 2_I4B -END PROCEDURE LagrangeInDOF_Prism - -!---------------------------------------------------------------------------- -! GetTotalDOF_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Prism -ans = (order + 1)**2 * (order + 2) / 2_I4B -END PROCEDURE GetTotalDOF_Prism - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Prism -ans = (order - 1)**2 * (order - 2) / 2_I4B -END PROCEDURE GetTotalInDOF_Prism - -!---------------------------------------------------------------------------- -! EquidistancePoint_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Prism -! nodecoord( :, 1 ) = [0,0,-1] -! nodecoord( :, 2 ) = [1,0,-1] -! nodecoord( :, 3 ) = [0,1,-1] -! nodecoord( :, 4 ) = [0,0,1] -! nodecoord( :, 5 ) = [1,0,1] -! nodecoord( :, 6 ) = [0,1,1] -!ISSUE: #160 Implement EquidistancePoint_Prism routine -END PROCEDURE EquidistancePoint_Prism - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Prism -!FIX: Implement EquidistanceInPoint_Prism routine -END PROCEDURE EquidistanceInPoint_Prism - -!---------------------------------------------------------------------------- -! InterpolationPoint_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Prism -SELECT CASE (ipType) -CASE (Equidistance) - nodecoord = EquidistancePoint_Prism(xij=xij, order=order) -CASE (GaussLegendre) -CASE (GaussLegendreLobatto) -CASE (GaussChebyshev) -CASE (GaussChebyshevLobatto) -END SELECT -END PROCEDURE InterpolationPoint_Prism - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Prism1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Prism1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Prism2 -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Prism2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Prism3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Prism3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Prism4 -ans = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Prism4 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Prism1 -! FIX: Implement QuadraturePoint_Prism1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="QuadraturePoint_Prism1()", & -& file=__FILE__) -END PROCEDURE QuadraturePoint_Prism1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Prism2 -! FIX: Implement QuadraturePoint_Prism2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="QuadraturePoint_Prism2()", & -& file=__FILE__) -END PROCEDURE QuadraturePoint_Prism2 - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Prism1 -!FIX: Implement TensorQuadraturePoint_Prism1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="TensorQuadraturePoint_Prism1()", & -& file=__FILE__) -END PROCEDURE TensorQuadraturePoint_Prism1 - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Prism2 -!FIX: Implement TensorQuadraturePoint_Prism2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="TensorQuadraturePoint_Prism2()", & -& file=__FILE__) -END PROCEDURE TensorQuadraturePoint_Prism2 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Prism1 -! FIX: Implement LagrangeEvalAll_Prism1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Prism1()", & -& file=__FILE__) -END PROCEDURE LagrangeEvalAll_Prism1 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Prism2 -! FIX: Implement LagrangeEvalAll_Prism2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Prism2()", & -& file=__FILE__) -END PROCEDURE LagrangeEvalAll_Prism2 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Prism -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Prism1 -!FIX: Implement LagrangeGradientEvalAll_Prism1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeGradientEvalAll_Prism1()", & -& file=__FILE__) -END PROCEDURE LagrangeGradientEvalAll_Prism1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 deleted file mode 100644 index ccbdb15b7..000000000 --- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,288 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This programris free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General 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(PyramidInterpolationUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeConnectivity_Pyramid -ans(:, 1) = [1, 2] -ans(:, 2) = [1, 4] -ans(:, 3) = [1, 5] -ans(:, 4) = [2, 3] -ans(:, 5) = [2, 5] -ans(:, 6) = [3, 4] -ans(:, 7) = [3, 5] -ans(:, 8) = [4, 5] -END PROCEDURE EdgeConnectivity_Pyramid - -!---------------------------------------------------------------------------- -! FacetConnectivity_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetConnectivity_Pyramid -ans(:, 1) = [4, Quadrangle4, 1, 4, 3, 2] -ans(:, 2) = [3, Triangle3, 2, 3, 5, 0] -ans(:, 3) = [3, Triangle3, 3, 4, 5, 0] -ans(:, 4) = [3, Triangle3, 1, 5, 4, 0] -ans(:, 5) = [3, Triangle3, 1, 2, 5, 0] -END PROCEDURE FacetConnectivity_Pyramid - -!---------------------------------------------------------------------------- -! RefElemDomain_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Pyramid -!FIX: Implement RefElemDomain -CALL Errormsg(& - & msg="[WORK IN PROGRESS] We are working on it", & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Pyramid()", & - & unitno=stderr) -END PROCEDURE RefElemDomain_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeDegree_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Pyramid -! ISSUE: #165 Implement LagrangeDegree_Pyramid -END PROCEDURE LagrangeDegree_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeDOF_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Pyramid -ans = (order + 1) * (order + 2) * (2 * order + 3) / 6 -END PROCEDURE LagrangeDOF_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Pyramid -ans = (order - 1) * (order - 2) * (2 * order - 3) / 6 -END PROCEDURE LagrangeInDOF_Pyramid - -!---------------------------------------------------------------------------- -! GetTotalDOF_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Pyramid -ans = (order + 1) * (order + 2) * (2 * order + 3) / 6 -END PROCEDURE GetTotalDOF_Pyramid - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Pyramid -ans = (order - 1) * (order - 2) * (2 * order - 3) / 6 -END PROCEDURE GetTotalInDOF_Pyramid - -!---------------------------------------------------------------------------- -! EquidistancePoint_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Pyramid -!FIX: Implement EquidistancePoint_Pyramid -!ISSUE: #161 Implement EquidistancePoint_Pyramid routine -! nodecoord(:, 1) = [-1, -1, 0] -! nodecoord(:, 2) = [1, -1, 0] -! nodecoord(:, 3) = [1, 1, 0] -! nodecoord(:, 4) = [-1, 1, 0] -! nodecoord(:, 5) = [0, 0, 1] -END PROCEDURE EquidistancePoint_Pyramid - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Pyramid -! FIX: Implement EquidistanceInPoint_Pyramid -! ISSUE: #161 Implement EquidistanceInPoint_Pyramid routine - -END PROCEDURE EquidistanceInPoint_Pyramid - -!---------------------------------------------------------------------------- -! InterpolationPoint_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Pyramid -! FIX: Implement EquidistancePoint_Pyramid -SELECT CASE (ipType) -CASE (Equidistance) - nodecoord = EquidistancePoint_Pyramid(xij=xij, order=order) -CASE (GaussLegendre) -CASE (GaussLegendreLobatto) -CASE (GaussChebyshev) -CASE (GaussChebyshevLobatto) -END SELECT -END PROCEDURE InterpolationPoint_Pyramid - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Pyramid1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Pyramid1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Pyramid2 -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Pyramid2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Pyramid3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Pyramid3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Pyramid4 -ans = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Pyramid4 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Pyramid1 -!FIX: QuadraturePoint_Pyramid1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="QuadraturePoint_Pyramid1()", & -& file=__FILE__) -END PROCEDURE QuadraturePoint_Pyramid1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Pyramid2 -!FIX: QuadraturePoint_Pyramid2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="QuadraturePoint_Pyramid2()", & -& file=__FILE__) -END PROCEDURE QuadraturePoint_Pyramid2 - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Pyramid1 -!FIX: TensorQuadraturePoint_Pyramid1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="TensorQuadraturePoint_Pyramid1()", & -& file=__FILE__) -END PROCEDURE TensorQuadraturePoint_Pyramid1 - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Pyramid2 -!FIX: TensorQuadraturePoint_Pyramid2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="TensorQuadraturePoint_Pyramid2()", & -& file=__FILE__) -END PROCEDURE TensorQuadraturePoint_Pyramid2 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Pyramid1 -!FIX: LagrangeEvalAll_Pyramid1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Pyramid1()", & -& file=__FILE__) -END PROCEDURE LagrangeEvalAll_Pyramid1 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Pyramid2 -!FIX: LagrangeEvalAll_Pyramid2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Pyramid2()", & -& file=__FILE__) -END PROCEDURE LagrangeEvalAll_Pyramid2 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Pyramid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Pyramid1 -!FIX: LagrangeGradientEvalAll_Pyramid1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeGradientEvalAll_Pyramid1()", & -& file=__FILE__) -END PROCEDURE LagrangeGradientEvalAll_Pyramid1 - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 deleted file mode 100644 index 31abd7661..000000000 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,2023 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(QuadrangleInterpolationUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefElemDomain_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Quadrangle -ans = "BIUNIT" -END PROCEDURE RefElemDomain_Quadrangle - -!---------------------------------------------------------------------------- -! FacetConnectivity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetConnectivity_Quadrangle -CHARACTER(:), ALLOCATABLE :: baseInterpol0 -! TYPE(String) :: baseContinuity0 - -baseInterpol0 = UpperCase(baseInterpol) -! baseContinuity0 = UpperCase(baseContinuity) - -SELECT CASE (baseInterpol0) -CASE ( & - & "HIERARCHYPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHYPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION", & - & "ORTHOGONALPOLYNOMIAL", & - & "ORTHOGONAL", & - & "ORTHOGONALINTERPOLATION") - ans(:, 1) = [1, 2] - ans(:, 2) = [4, 3] - ans(:, 3) = [1, 4] - ans(:, 4) = [2, 3] -CASE DEFAULT - ans(:, 1) = [1, 2] - ans(:, 2) = [2, 3] - ans(:, 3) = [3, 4] - ans(:, 4) = [4, 1] -END SELECT -END PROCEDURE FacetConnectivity_Quadrangle - -!---------------------------------------------------------------------------- -! QuadratureNumber_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadratureNumber_Quadrangle -ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1) -ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2) -END PROCEDURE QuadratureNumber_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeDegree_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle1 -INTEGER(I4B) :: n, ii, jj, kk -n = LagrangeDOF_Quadrangle(order=order) -ALLOCATE (ans(n, 2)) -kk = 0 -DO jj = 0, order - DO ii = 0, order - kk = kk + 1 - ans(kk, 1) = ii - ans(kk, 2) = jj - END DO -END DO -END PROCEDURE LagrangeDegree_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeDegree_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle2 -INTEGER(I4B) :: n, ii, jj, kk -n = LagrangeDOF_Quadrangle(p=p, q=q) -ALLOCATE (ans(n, 2)) -kk = 0 -DO jj = 0, q - DO ii = 0, p - kk = kk + 1 - ans(kk, 1) = ii - ans(kk, 2) = jj - END DO -END DO -END PROCEDURE LagrangeDegree_Quadrangle2 - -!---------------------------------------------------------------------------- -! GetTotalDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Quadrangle -ans = (order + 1)**2 -END PROCEDURE GetTotalDOF_Quadrangle - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Quadrangle -ans = (order - 1)**2 -END PROCEDURE GetTotalInDOF_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Quadrangle1 -ans = (order + 1)**2 -END PROCEDURE LagrangeDOF_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Quadrangle2 -ans = (p + 1) * (q + 1) -END PROCEDURE LagrangeDOF_Quadrangle2 - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Quadrangle1 -ans = (order - 1)**2 -END PROCEDURE LagrangeInDOF_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Quadrangle2 -ans = (p - 1) * (q - 1) -END PROCEDURE LagrangeInDOF_Quadrangle2 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Quadrangle1 -INTEGER(I4B) :: nsd, n, ne, i1, i2 -REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu - -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:4) = xij(1:nsd, 1:4) -ELSE - nsd = 2_I4B - x = 0.0_DFP - x(1:2, :) = RefQuadrangleCoord("BIUNIT") -END IF - -n = LagrangeDOF_Quadrangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP - -! points on vertex -ans(1:nsd, 1:4) = x(1:nsd, 1:4) - -! points on edge -ne = LagrangeInDOF_Line(order=order) - -i2 = 4 -IF (order .GT. 1_I4B) THEN - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [1, 2])) - - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [2, 3])) - - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [3, 4])) - - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [4, 1])) - -END IF - -! points on face -IF (order .GT. 1_I4B) THEN - - IF (order .EQ. 2_I4B) THEN - i1 = i2 + 1 - ans(1:nsd, i1) = SUM(x(1:nsd, :), dim=2_I4B) / 4.0_DFP - ELSE - - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 2) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 4) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 4) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd) - - i1 = i2 + 1 - ans(1:nsd, i1:) = EquidistancePoint_Quadrangle( & - & order=order - 2, & - & xij=xin(1:nsd, 1:4)) - - END IF -END IF -END PROCEDURE EquidistancePoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Quadrangle2 -ans = InterpolationPoint_Quadrangle2( & - & p=p, & - & q=q, & - & xij=xij, & - & ipType1=Equidistance, & - & ipType2=Equidistance, & - & layout="VEFC") -END PROCEDURE EquidistancePoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Quadrangle1 -INTEGER(I4B) :: nsd, n, ne, i1, i2 -REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu - -IF (order .LT. 2_I4B) THEN - ALLOCATE (ans(0, 0)) - RETURN -END IF - -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:4) = xij(1:nsd, 1:4) -ELSE - nsd = 2_I4B - x(1:nsd, 1) = [-1.0, -1.0] - x(1:nsd, 2) = [1.0, -1.0] - x(1:nsd, 3) = [1.0, 1.0] - x(1:nsd, 4) = [-1.0, 1.0] -END IF - -n = LagrangeInDOF_Quadrangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP - -! points on face -IF (order .EQ. 2_I4B) THEN - ans(1:nsd, 1) = SUM(x, dim=2_I4B) / 4.0_DFP -ELSE - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 2) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 4) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 4) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd) - - ans(1:nsd, 1:) = EquidistancePoint_Quadrangle1( & - & order=order - 2, & - & xij=xin(1:nsd, 1:4)) - -END IF -END PROCEDURE EquidistanceInPoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Quadrangle2 -END PROCEDURE EquidistanceInPoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Quadrangle -CALL IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, temp, p, q, 1_I4B) -END PROCEDURE IJ2VEFC_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise -! internal variables -INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2 -INTEGER(I4B), PARAMETER :: tEdges = 4 -INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & -& pointsOrder(4) -REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & - & temp_in(:, :) - -! vertices -N = (p + 1) * (q + 1) -cnt = 0 -ll = -1 - -SELECT CASE (startNode) -CASE (1) - edgeConnectivity(:, 1) = [1, 4] - edgeConnectivity(:, 2) = [4, 3] - edgeConnectivity(:, 3) = [3, 2] - edgeConnectivity(:, 4) = [2, 1] - pointsOrder = [1, 4, 3, 2] -CASE (2) - edgeConnectivity(:, 1) = [2, 1] - edgeConnectivity(:, 2) = [1, 4] - edgeConnectivity(:, 3) = [4, 3] - edgeConnectivity(:, 4) = [3, 2] - pointsOrder = [2, 1, 4, 3] -CASE (3) - edgeConnectivity(:, 1) = [3, 2] - edgeConnectivity(:, 2) = [2, 1] - edgeConnectivity(:, 3) = [1, 4] - edgeConnectivity(:, 4) = [4, 3] - pointsOrder = [3, 2, 1, 4] -CASE (4) - edgeConnectivity(:, 1) = [4, 3] - edgeConnectivity(:, 2) = [3, 2] - edgeConnectivity(:, 3) = [2, 1] - edgeConnectivity(:, 4) = [1, 4] - pointsOrder = [4, 3, 2, 1] -END SELECT - -IF (ALL([p, q] .EQ. 0_I4B)) THEN - temp(:, 1) = [xi(1, 1), eta(1, 1)] - RETURN -END IF - -ij(:, 1) = [1, 1] -ij(:, 2) = [p + 1, 1] -ij(:, 3) = [p + 1, q + 1] -ij(:, 4) = [1, q + 1] - -IF (ALL([p, q] .GE. 1_I4B)) THEN - DO ii = 1, 4 - cnt = cnt + 1 - jj = pointsOrder(ii) - temp(1:2, ii) = [ & - & xi(ij(1, jj), ij(2, jj)), & - & eta(ij(1, jj), ij(2, jj)) & - & ] - END DO - IF (ALL([p, q] .EQ. 1_I4B)) RETURN - -ELSE - IF (p .EQ. 0_I4B) THEN - DO jj = 1, q + 1 - cnt = cnt + 1 - temp(1:2, jj) = [xi(1, jj), eta(1, jj)] - END DO - END IF - - IF (q .EQ. 0_I4B) THEN - DO ii = 1, p + 1 - cnt = cnt + 1 - temp(1:2, ii) = [xi(ii, 1), eta(ii, 1)] - END DO - END IF - -END IF - -IF (ALL([p, q] .GE. 1_I4B)) THEN - DO iedge = 1, tEdges - p1 = edgeConnectivity(1, iedge) - p2 = edgeConnectivity(2, iedge) - - IF (ij(1, p1) .EQ. ij(1, p2)) THEN - ii1 = ij(1, p1) - ii2 = ii1 - dii = 1 - ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN - ii1 = ij(1, p1) + 1 - ii2 = ij(1, p2) - 1 - dii = 1 - ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN - ii1 = ij(1, p1) - 1 - ii2 = ij(1, p2) + 1 - dii = -1 - END IF - - IF (ij(2, p1) .EQ. ij(2, p2)) THEN - jj1 = ij(2, p1) - jj2 = jj1 - djj = 1 - ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN - jj1 = ij(2, p1) + 1 - jj2 = ij(2, p2) - 1 - djj = 1 - ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN - jj1 = ij(2, p1) - 1 - jj2 = ij(2, p2) + 1 - djj = -1 - END IF - - DO ii = ii1, ii2, dii - DO jj = jj1, jj2, djj - cnt = cnt + 1 - temp(:, cnt) = [xi(ii, jj), eta(ii, jj)] - END DO - END DO - END DO - - ! internal nodes - IF (ALL([p, q] .GE. 2_I4B)) THEN - - CALL Reallocate( & - & xi_in, & - & MAX(p - 1, 1_I4B), & - & MAX(q - 1_I4B, 1_I4B)) - CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) - CALL Reallocate(temp_in, 2, SIZE(xi_in)) - - IF (p .LE. 1_I4B) THEN - ii1 = 1 - ii2 = 1 - ELSE - ii1 = 2 - ii2 = p - END IF - - IF (q .LE. 1_I4B) THEN - jj1 = 1 - jj2 = 1 - ELSE - jj1 = 2 - jj2 = q - END IF - - xi_in = xi(ii1:ii2, jj1:jj2) - eta_in = eta(ii1:ii2, jj1:jj2) - - CALL IJ2VEFC_Quadrangle_Clockwise( & - & xi=xi_in, & - & eta=eta_in, & - & temp=temp_in, & - & p=MAX(p - 2, 0_I4B), & - & q=MAX(q - 2, 0_I4B), & - & startNode=startNode) - - ii1 = cnt + 1 - ii2 = ii1 + SIZE(temp_in, 2) - 1 - temp(1:2, ii1:ii2) = temp_in - END IF - -END IF - -IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) -IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) -IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) - -END PROCEDURE IJ2VEFC_Quadrangle_Clockwise - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise -! internal variables -INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2 -INTEGER(I4B), PARAMETER :: tEdges = 4 -INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & -& pointsOrder(4) -REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & - & temp_in(:, :) - -! vertices -N = (p + 1) * (q + 1) -cnt = 0 -ll = -1 - -SELECT CASE (startNode) -CASE (1) - edgeConnectivity(:, 1) = [1, 2] - edgeConnectivity(:, 2) = [2, 3] - edgeConnectivity(:, 3) = [3, 4] - edgeConnectivity(:, 4) = [4, 1] - pointsOrder = [1, 2, 3, 4] -CASE (2) - edgeConnectivity(:, 1) = [2, 3] - edgeConnectivity(:, 2) = [3, 4] - edgeConnectivity(:, 3) = [4, 1] - edgeConnectivity(:, 4) = [1, 2] - pointsOrder = [2, 3, 4, 1] -CASE (3) - edgeConnectivity(:, 1) = [3, 4] - edgeConnectivity(:, 2) = [4, 1] - edgeConnectivity(:, 3) = [1, 2] - edgeConnectivity(:, 4) = [2, 3] - pointsOrder = [3, 4, 1, 2] -CASE (4) - edgeConnectivity(:, 1) = [4, 1] - edgeConnectivity(:, 2) = [1, 2] - edgeConnectivity(:, 3) = [2, 3] - edgeConnectivity(:, 4) = [3, 4] - pointsOrder = [4, 1, 2, 3] -END SELECT - -IF (ALL([p, q] .EQ. 0_I4B)) THEN - temp(:, 1) = [xi(1, 1), eta(1, 1)] - RETURN -END IF - -ij(:, 1) = [1, 1] -ij(:, 2) = [p + 1, 1] -ij(:, 3) = [p + 1, q + 1] -ij(:, 4) = [1, q + 1] - -IF (ALL([p, q] .GE. 1_I4B)) THEN - DO ii = 1, 4 - cnt = cnt + 1 - jj = pointsOrder(ii) - temp(1:2, ii) = [& - & xi(ij(1, jj), ij(2, jj)), & - & eta(ij(1, jj), ij(2, jj)) & - & ] - END DO - IF (ALL([p, q] .EQ. 1_I4B)) RETURN - -ELSE - DO ii = 1, MIN(p, 1) + 1 - DO jj = 1, MIN(q, 1) + 1 - cnt = cnt + 1 - temp(1:2, cnt) = [& - & xi(ij(1, cnt), ij(2, cnt)), & - & eta(ij(1, cnt), ij(2, cnt))] - END DO - END DO -END IF - -IF (ALL([p, q] .GE. 1_I4B)) THEN - DO iedge = 1, tEdges - p1 = edgeConnectivity(1, iedge) - p2 = edgeConnectivity(2, iedge) - - IF (ij(1, p1) .EQ. ij(1, p2)) THEN - ii1 = ij(1, p1) - ii2 = ii1 - dii = 1 - ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN - ii1 = ij(1, p1) + 1 - ii2 = ij(1, p2) - 1 - dii = 1 - ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN - ii1 = ij(1, p1) - 1 - ii2 = ij(1, p2) + 1 - dii = -1 - END IF - - IF (ij(2, p1) .EQ. ij(2, p2)) THEN - jj1 = ij(2, p1) - jj2 = jj1 - djj = 1 - ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN - jj1 = ij(2, p1) + 1 - jj2 = ij(2, p2) - 1 - djj = 1 - ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN - jj1 = ij(2, p1) - 1 - jj2 = ij(2, p2) + 1 - djj = -1 - END IF - - DO ii = ii1, ii2, dii - DO jj = jj1, jj2, djj - cnt = cnt + 1 - temp(:, cnt) = [xi(ii, jj), eta(ii, jj)] - END DO - END DO - END DO - - ! internal nodes - IF (ALL([p, q] .GE. 2_I4B)) THEN - - CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B)) - CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) - CALL Reallocate(temp_in, 2, SIZE(xi_in)) - - IF (p .LE. 1_I4B) THEN - ii1 = 1 - ii2 = 1 - ELSE - ii1 = 2 - ii2 = p - END IF - - IF (q .LE. 1_I4B) THEN - jj1 = 1 - jj2 = 1 - ELSE - jj1 = 2 - jj2 = q - END IF - - xi_in = xi(ii1:ii2, jj1:jj2) - eta_in = eta(ii1:ii2, jj1:jj2) - - CALL IJ2VEFC_Quadrangle_AntiClockwise( & - & xi=xi_in, & - & eta=eta_in, & - & temp=temp_in, & - & p=MAX(p - 2, 0_I4B), & - & q=MAX(q - 2, 0_I4B), & - & startNode=startNode) - - ii1 = cnt + 1 - ii2 = ii1 + SIZE(temp_in, 2) - 1 - temp(1:2, ii1:ii2) = temp_in - END IF - -END IF - -IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) -IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) -IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) - -END PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise - -!---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Quadrangle1 -ans = InterpolationPoint_Quadrangle2( & - & p=order, & - & q=order, & - & ipType1=ipType, & - & ipType2=ipType, & - & xij=xij, & - & layout=layout, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda & - & ) -END PROCEDURE InterpolationPoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Quadrangle2 -! internal variables -REAL(DFP) :: x(p + 1), y(q + 1), & - & xi(p + 1, q + 1), eta(p + 1, q + 1) -REAL(DFP), ALLOCATABLE :: temp(:, :) -INTEGER(I4B) :: ii, jj, kk, nsd - -x = InterpolationPoint_Line( & - & order=p, & - & ipType=ipType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -y = InterpolationPoint_Line( & - & order=q, & - & ipType=ipType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2 -END IF - -CALL Reallocate(ans, nsd, (p + 1) * (q + 1)) -CALL Reallocate(temp, 2, (p + 1) * (q + 1)) - -xi = 0.0_DFP -eta = 0.0_DFP - -DO ii = 1, p + 1 - DO jj = 1, q + 1 - xi(ii, jj) = x(ii) - eta(ii, jj) = y(jj) - END DO -END DO - -IF (layout .EQ. "VEFC") THEN - CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=temp, p=p, q=q) -ELSE - kk = 0 - DO ii = 1, p + 1 - DO jj = 1, q + 1 - kk = kk + 1 - temp(1, kk) = xi(ii, jj) - temp(2, kk) = eta(ii, jj) - END DO - END DO -END IF - -IF (PRESENT(xij)) THEN - ans = FromBiUnitQuadrangle2Quadrangle(xin=temp, x1=xij(:, 1), & - & x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4)) -ELSE - ans = temp -END IF -END PROCEDURE InterpolationPoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle2 - -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle4 -INTEGER(I4B) :: basisType0, ii, jj, indx -REAL(DFP) :: ans1(SIZE(xij, 2), 0:order) -REAL(DFP) :: ans2(SIZE(xij, 2), 0:order) - -basisType0 = input(default=Monomial, option=basisType) - -IF (basisType0 .EQ. Heirarchical) THEN - ans = HeirarchicalBasis_Quadrangle2(p=order, q=order, xij=xij) -ELSE - ans = TensorProdBasis_Quadrangle1( & - & p=order, & - & q=order, & - & xij=xij, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) -END IF - -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Quadrangle4 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle5 -INTEGER(I4B) :: ii, jj, kk, indx, basisType(2) -REAL(DFP) :: ans1(SIZE(xij, 2), 0:p) -REAL(DFP) :: ans2(SIZE(xij, 2), 0:q) - -basisType(1) = input(default=Monomial, option=basisType1) -basisType(2) = input(default=Monomial, option=basisType2) - -IF (ALL(basisType .EQ. Heirarchical)) THEN - ans = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij) -ELSE - ans = TensorProdBasis_Quadrangle1( & - & p=p, & - & q=q, & - & xij=xij, & - & basisType1=basisType(1), & - & basisType2=basisType(2), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2) -END IF - -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Quadrangle5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle1 -INTEGER(I4B) :: nrow, ncol -CALL Dubiner_Quadrangle1_(xij=xij, order=order, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE Dubiner_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle1_ -REAL(DFP) :: P1(SIZE(xij, 2), order + 1), P2(SIZE(xij, 2), order + 1) -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) -REAL(DFP) :: avec(SIZE(xij, 2)), alpha, beta -INTEGER(I4B) :: k1, k2, max_k2, cnt - -x = xij(1, :) -y = xij(2, :) -nrow = SIZE(xij, 2) -ncol = (order + 1) * (order + 2) / 2 - -P1 = LegendreEvalAll(n=order, x=x) - -! we do not need x now, so let store (1-y)/2 in x -x = 0.5_DFP * (1.0_DFP - y) -alpha = 0.0_DFP -beta = 0.0_DFP -cnt = 0 - -DO k1 = 0, order - - avec = (x)**k1 ! note here x = 0.5_DFP*(1-y) - alpha = 2.0_DFP * k1 + 1.0_DFP - - max_k2 = order - k1 - - P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta) - - DO k2 = 0, max_k2 - cnt = cnt + 1 - ans(:, cnt) = P1(:, k1 + 1) * avec * P2(:, k2 + 1) - END DO - -END DO - -END PROCEDURE Dubiner_Quadrangle1_ - -!---------------------------------------------------------------------------- -! DubinerGradient_Quadrangle1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DubinerGradient_Quadrangle1 -INTEGER(I4B) :: s(3) -CALL DubinerGradient_Quadrangle1_(xij=xij, order=order, ans=ans, & - tsize1=s(1), tsize2=s(2), tsize3=s(3)) -END PROCEDURE DubinerGradient_Quadrangle1 - -!---------------------------------------------------------------------------- -! DubinerGradient_Quadrangle1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DubinerGradient_Quadrangle1_ -REAL(DFP), DIMENSION(SIZE(xij, 2), order + 1) :: P1, P2, dP1, dP2 -REAL(DFP), DIMENSION(SIZE(xij, 2)) :: avec, bvec, x, y -REAL(DFP) :: alpha, beta -INTEGER(I4B) :: k1, k2, max_k2, cnt - -tsize1 = SIZE(xij, 2) -tsize2 = (order + 1) * (order + 2) / 2 -tsize3 = 2 - -x = xij(1, :) -y = xij(2, :) -P1 = LegendreEvalAll(n=order, x=x) -dP1 = LegendreGradientEvalAll(n=order, x=x) - -! we do not need x now, so let store (1-y)/2 in x -x = 0.5_DFP * (1.0_DFP - y) -alpha = 1.0_DFP -beta = 0.0_DFP -cnt = 0 - -DO k1 = 0, order - bvec = x**(MAX(k1 - 1_I4B, 0_I4B)) - avec = x * bvec - alpha = 2.0_DFP * k1 + 1.0_DFP - - max_k2 = order - k1 - - P2(:, 1:max_k2 + 1) = JacobiEvalAll( & - & n=max_k2, & - & x=y, & - & alpha=alpha, & - & beta=beta) - - dP2(:, 1:max_k2 + 1) = JacobiGradientEvalAll( & - & n=max_k2, & - & x=y, & - & alpha=alpha, & - & beta=beta) - - DO k2 = 0, max_k2 - cnt = cnt + 1 - ans(:, cnt, 1) = dP1(:, k1 + 1) * avec * P2(:, k2 + 1) - ans(:, cnt, 2) = P1(:, k1 + 1) * bvec * & - & (x * dP2(:, k2 + 1) - 0.5_DFP * REAL(k1, DFP) * P2(:, k2 + 1)) - END DO -END DO -END PROCEDURE DubinerGradient_Quadrangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL Dubiner_Quadrangle2_(x=x, y=y, order=order, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE Dubiner_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle2_ -REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) -INTEGER(I4B) :: ii, jj, cnt - -xij = 0.0_DFP -cnt = 0 -DO ii = 1, SIZE(x) - DO jj = 1, SIZE(y) - cnt = cnt + 1 - xij(1, cnt) = x(ii) - xij(2, cnt) = y(jj) - END DO -END DO -CALL Dubiner_Quadrangle1_(order=order, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE Dubiner_Quadrangle2_ - -!---------------------------------------------------------------------------- -! TensorProdOrthoPol_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: ii, k1, k2, cnt - -x = xij(1, :) -y = xij(2, :) - -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -Q1 = BasisEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -cnt = 0 - -DO k2 = 1, q + 1 - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(:, cnt) = P1(:, k1) * Q1(:, k2) - END DO -END DO - -END PROCEDURE TensorProdBasis_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle2 -REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) -INTEGER(I4B) :: ii, jj, cnt - -xij = 0.0_DFP -cnt = 0 -DO ii = 1, SIZE(x) - DO jj = 1, SIZE(y) - cnt = cnt + 1 - xij(1, cnt) = x(ii) - xij(2, cnt) = y(jj) - END DO -END DO - -ans = TensorProdBasis_Quadrangle1( & - & p=p, & - & q=q, & - & xij=xij, & - & basisType1=basisType1, & - & basisType2=basisType2, & - & alpha1=alpha1, & - & alpha2=alpha2, & - & beta1=beta1, & - & beta2=beta2, & - & lambda1=lambda1, & - & lambda2=lambda2) - -END PROCEDURE TensorProdBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle1 -ans(:, 1) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP - y) -ans(:, 2) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP - y) -ans(:, 3) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP + y) -ans(:, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y) -END PROCEDURE VertexBasis_Quadrangle1 - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle2 -ans(:, 1) = L1(:, 0) * L2(:, 0) -ans(:, 2) = L1(:, 1) * L2(:, 0) -ans(:, 3) = L1(:, 1) * L2(:, 1) -ans(:, 4) = L1(:, 0) * L2(:, 1) -END PROCEDURE VertexBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! VertexBasisGradient_Quadrangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasisGradient_Quadrangle2 -ans(:, 1, 1) = dL1(:, 0) * L2(:, 0) -ans(:, 2, 1) = dL1(:, 1) * L2(:, 0) -ans(:, 3, 1) = dL1(:, 1) * L2(:, 1) -ans(:, 4, 1) = dL1(:, 0) * L2(:, 1) -ans(:, 1, 2) = L1(:, 0) * dL2(:, 0) -ans(:, 2, 2) = L1(:, 1) * dL2(:, 0) -ans(:, 3, 2) = L1(:, 1) * dL2(:, 1) -ans(:, 4, 2) = L1(:, 0) * dL2(:, 1) -END PROCEDURE VertexBasisGradient_Quadrangle2 - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle3 -ans = VertexBasis_Quadrangle1( & - & x=xij(1, :), & - & y=xij(2, :)) -END PROCEDURE VertexBasis_Quadrangle3 - -!---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VerticalEdgeBasis_Quadrangle -REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) -INTEGER(I4B) :: maxQ, k2, cnt - -maxQ = MAX(qe1, qe2) - -L2 = LobattoEvalAll(n=maxQ, x=y) - -cnt = 0 - -DO k2 = 2, qe1 - cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP - x) * L2(:, k2) -END DO - -DO k2 = 2, qe2 - cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP + x) * L2(:, k2) -END DO - -END PROCEDURE VerticalEdgeBasis_Quadrangle - -!---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2 -INTEGER(I4B) :: k2, cnt - -cnt = 0 -DO k2 = 2, qe1 - cnt = cnt + 1 - ans(:, cnt) = L1(:, 0) * L2(:, k2) -END DO -DO k2 = 2, qe2 - cnt = cnt + 1 - ans(:, cnt) = L1(:, 1) * L2(:, k2) -END DO - -END PROCEDURE VerticalEdgeBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! VerticalEdgeBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VerticalEdgeBasisGradient_Quadrangle2 -INTEGER(I4B) :: k2, cnt -cnt = 0 -DO k2 = 2, qe1 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 0) * L2(:, k2) - ans(:, cnt, 2) = L1(:, 0) * dL2(:, k2) -END DO -DO k2 = 2, qe2 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 1) * L2(:, k2) - ans(:, cnt, 2) = L1(:, 1) * dL2(:, k2) -END DO -END PROCEDURE VerticalEdgeBasisGradient_Quadrangle2 - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle -REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4)) -INTEGER(I4B) :: maxP, k1, cnt - -maxP = MAX(pe3, pe4) - -L1 = LobattoEvalAll(n=maxP, x=x) - -cnt = 0 - -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP - y) * L1(:, k1) -END DO - -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP + y) * L1(:, k1) -END DO - -END PROCEDURE HorizontalEdgeBasis_Quadrangle - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2 -INTEGER(I4B) :: k1, cnt -cnt = 0 -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 0) -END DO -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 1) -END DO -END PROCEDURE HorizontalEdgeBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2 -INTEGER(I4B) :: k1, cnt -cnt = 0 -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) -END DO -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) -END DO -END PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2 - -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Quadrangle -REAL(DFP) :: L1(1:SIZE(x), 0:pb) -REAL(DFP) :: L2(1:SIZE(y), 0:qb) -INTEGER(I4B) :: k1, k2, cnt - -L1 = LobattoEvalAll(n=pb, x=x) -L2 = LobattoEvalAll(n=qb, x=y) - -cnt = 0 - -DO k1 = 2, pb - DO k2 = 2, qb - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) - END DO -END DO - -END PROCEDURE CellBasis_Quadrangle - -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Quadrangle2 -INTEGER(I4B) :: k1, k2, cnt -cnt = 0 -DO k1 = 2, pb - DO k2 = 2, qb - cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) - END DO -END DO -END PROCEDURE CellBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! CellBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasisGradient_Quadrangle2 -INTEGER(I4B) :: k1, k2, cnt -cnt = 0 -DO k1 = 2, pb - DO k2 = 2, qb - cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) - END DO -END DO -END PROCEDURE CellBasisGradient_Quadrangle2 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 -INTEGER(I4B) :: a, b, maxP, maxQ -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) - -maxP = MAX(pe3, pe4, pb) -maxQ = MAX(qe1, qe2, qb) - -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) - -! Vertex basis function - -ans(:, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) - -! Edge basis function - -b = 4 -! -IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 - ans(:, a:b) = VerticalEdgeBasis_Quadrangle2( & - & qe1=qe1, qe2=qe2, L1=L1, L2=L2) -END IF - -! Edge basis function - -IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 - ans(:, a:b) = HorizontalEdgeBasis_Quadrangle2( & - & pe3=pe3, pe4=pe4, L1=L1, L2=L2) -END IF - -! Cell basis function - -IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + (pb - 1) * (qb - 1) - ans(:, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) -END IF -END PROCEDURE HeirarchicalBasis_Quadrangle1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 -ans = HeirarchicalBasis_Quadrangle1(pb=p, pe3=p, pe4=p, & - & qb=q, qe1=q, qe2=q, xij=xij) -END PROCEDURE HeirarchicalBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! LagrangeEvallAll_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = TRANSPOSE(coeff) - ELSE - coeff0 = TRANSPOSE(coeff) - END IF -ELSE - coeff0 = TRANSPOSE(LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & )) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Quadrangle(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Quadrangle1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - DO ii = 1, tdof - xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=RESHAPE(x, [2, 1])) - -CASE DEFAULT - - xx = TensorProdBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=RESHAPE(x, [2, 1]), & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) - -END SELECT - -ans = MATMUL(coeff0, xx(1, :)) - -END PROCEDURE LagrangeEvalAll_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Quadrangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle2 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) -REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = coeff - ELSE - coeff0 = coeff - END IF -ELSE - coeff0 = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Quadrangle(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Quadrangle1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - DO ii = 1, tdof - xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=x) - -CASE DEFAULT - - xx = TensorProdBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=x, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) - -END SELECT - -ans = MATMUL(xx, coeff0) - -END PROCEDURE LagrangeEvalAll_Quadrangle2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle1 -ans = QuadraturePoint_Quadrangle2( & - & p=order, & - & q=order, & - & quadType1=quadType, & - & quadType2=quadType, & - & xij=xij, & - & refQuadrangle=refQuadrangle, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda & - & ) -END PROCEDURE QuadraturePoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle2 -! internal variables -REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), temp(:, :) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq -TYPE(String) :: astr - -astr = TRIM(UpperCase(refQuadrangle)) - -x = QuadraturePoint_Line( & - & order=p, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -np = SIZE(x, 2) - -y = QuadraturePoint_Line( & - & order=q, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -nq = SIZE(y, 2) - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2 -END IF - -CALL Reallocate(ans, nsd + 1_I4B, np * nq) -CALL Reallocate(temp, 3_I4B, np * nq) - -kk = 0 -DO ii = 1, np - DO jj = 1, nq - kk = kk + 1 - temp(1, kk) = x(1, ii) - temp(2, kk) = y(1, jj) - temp(3, kk) = x(2, ii) * y(2, jj) - END DO -END DO - -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( & - & xin=temp(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="QUADRANGLE", xij=xij) -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( & - & xin=temp(1:2, :)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF -END IF - -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(x)) DEALLOCATE (x) -IF (ALLOCATED(y)) DEALLOCATE (y) - -END PROCEDURE QuadraturePoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle3 -ans = QuadraturePoint_Quadrangle4( & - & nipsx=nips, & - & nipsy=nips, & - & quadType1=quadType, & - & quadType2=quadType, & - & refQuadrangle=refQuadrangle, & - & xij=xij, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda & - & ) -END PROCEDURE QuadraturePoint_Quadrangle3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle4 -! internal variables -REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), temp(3, nipsy(1) * nipsx(1)) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq -TYPE(String) :: astr - -astr = TRIM(UpperCase(refQuadrangle)) - -x = QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -np = SIZE(x, 2) - -y = QuadraturePoint_Line( & - & nips=nipsy, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -nq = SIZE(y, 2) - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2 -END IF - -CALL Reallocate(ans, nsd + 1_I4B, np * nq) - -kk = 0 -DO ii = 1, np - DO jj = 1, nq - kk = kk + 1 - temp(1, kk) = x(1, ii) - temp(2, kk) = y(1, jj) - temp(3, kk) = x(2, ii) * y(2, jj) - END DO -END DO - -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( & - & xin=temp(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="QUADRANGLE", xij=xij) -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( & - & xin=temp(1:2, :)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF -END IF - -END PROCEDURE QuadraturePoint_Quadrangle4 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ai, bi -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = coeff - ELSE - coeff0 = coeff - END IF -ELSE - coeff0 = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Quadrangle(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Quadrangle1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - DO ii = 1, tdof - ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) - bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) - ar = REAL(degree(ii, 1_I4B), DFP) - br = REAL(degree(ii, 2_I4B), DFP) - xx(:, ii, 1) = (ar * x(1, :)**ai) * x(2, :)**degree(ii, 2) - xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasisGradient_Quadrangle( & - & p=order, & - & q=order, & - & xij=x) - -CASE DEFAULT - - xx = OrthogonalBasisGradient_Quadrangle( & - & p=order, & - & q=order, & - & xij=x, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) - -END SELECT - -DO ii = 1, 2 - ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) -END DO - -END PROCEDURE LagrangeGradientEvalAll_Quadrangle1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1 -INTEGER(I4B) :: a, b, maxP, maxQ -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) -REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) -REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) - -maxP = MAX(pe3, pe4, pb) -maxQ = MAX(qe1, qe2, qb) - -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) -dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :)) -dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :)) - -! Vertex basis function -ans(:, 1:4, 1:2) = VertexBasisGradient_Quadrangle2( & -& L1=L1, & -& L2=L2, & -& dL1=dL1, & -& dL2=dL2 & -& ) - -! Edge basis function -b = 4 -IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 - ans(:, a:b, 1:2) = VerticalEdgeBasisGradient_Quadrangle2( & - & qe1=qe1, & - & qe2=qe2, & - & L1=L1, & - & L2=L2, & - & dL1=dL1, & - & dL2=dL2 & - & ) -END IF - -! Edge basis function -IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 - ans(:, a:b, 1:2) = HorizontalEdgeBasisGradient_Quadrangle2( & - & pe3=pe3, & - & pe4=pe4, & - & L1=L1, & - & L2=L2, & - & dL1=dL1, & - & dL2=dL2 & - & ) -END IF - -! Cell basis function -IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + (pb - 1) * (qb - 1) - ans(:, a:b, 1:2) = CellBasisGradient_Quadrangle2( & - & pb=pb, & - & qb=qb, & - & L1=L1, & - & L2=L2, & - & dL1=dL1, & - & dL2=dL2 & - & ) -END IF -END PROCEDURE HeirarchicalBasisGradient_Quadrangle1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2 -ans = HeirarchicalBasisGradient_Quadrangle1( & - & pb=p, & - & pe3=p, & - & pe4=p, & - & qb=q, & - & qe1=q, & - & qe2=q, & - & xij=xij) -END PROCEDURE HeirarchicalBasisGradient_Quadrangle2 - -!---------------------------------------------------------------------------- -! TensorProdBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) -REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: ii, k1, k2, cnt - -x = xij(1, :) -y = xij(2, :) - -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -Q1 = BasisEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -dP1 = BasisGradientEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -dQ1 = BasisGradientEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -cnt = 0 - -DO k2 = 1, q + 1 - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2) - ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2) - END DO -END DO - -END PROCEDURE TensorProdBasisGradient_Quadrangle1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle3 -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 deleted file mode 100644 index 810e3c6cb..000000000 --- a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 +++ /dev/null @@ -1,3449 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE QuadraturePoint_Tetrahedron_Solin -USE GlobalData, ONLY: DFP, I4B, LGT -IMPLICIT NONE -PRIVATE -PUBLIC :: QuadraturePointTetrahedronSolin -PUBLIC :: QuadratureOrderTetrahedronSolin -PUBLIC :: QuadratureNumberTetrahedronSolin -INTEGER( I4B ), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN=21 - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nips - INTEGER(I4B) :: ans - ans = -1 - SELECT CASE (nips) - CASE (1) - ans = 1 - CASE (4) - ans = 2 - CASE (5) - ans = 3 - CASE (11) - ans = 4 - CASE (14) - ans = 5 - CASE (24) - ans = 6 - CASE (31) - ans = 7 - CASE (43) - ans = 8 - CASE (53) - ans = 9 - CASE (126) - ans = 11 - CASE (210) - ans = 13 - CASE (330) - ans = 15 - CASE (495) - ans = 17 - CASE (715) - ans = 19 - CASE (1001) - ans = 21 - END SELECT -END FUNCTION QuadratureOrderTetrahedronSolin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - ans = -1 - SELECT CASE (order) - CASE (0, 1) - ans = 1 - CASE (2) - ans = 4 - CASE (3) - ans = 5 - CASE (4) - ans = 11 - CASE (5) - ans = 14 - CASE (6) - ans = 24 - CASE (7) - ans = 31 - CASE (8) - ans = 43 - CASE (9) - ans = 53 - CASE (10) - ans = 126 - CASE (11) - ans = 126 - CASE (12) - ans = 210 - CASE (13) - ans = 210 - CASE (14) - ans = 330 - CASE (15) - ans = 330 - CASE (16) - ans = 495 - CASE (17) - ans = 495 - CASE (18) - ans = 715 - CASE (19) - ans = 715 - CASE (20) - ans = 1001 - CASE (21) - ans = 1001 - END SELECT -END FUNCTION QuadratureNumberTetrahedronSolin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QuadraturePointTetrahedronSolin(order) RESULT(ans) - REAL(DFP), ALLOCATABLE :: ans(:, :) - INTEGER(I4B), INTENT(IN) :: order - SELECT CASE (order) - CASE (0, 1) - ans = QP_Tetrahedron_Order1() - CASE (2) - ans = QP_Tetrahedron_Order2() - CASE (3) - ans = QP_Tetrahedron_Order3() - CASE (4) - ans = QP_Tetrahedron_Order4() - CASE (5) - ans = QP_Tetrahedron_Order5() - CASE (6) - ans = QP_Tetrahedron_Order6() - CASE (7) - ans = QP_Tetrahedron_Order7() - CASE (8) - ans = QP_Tetrahedron_Order8() - CASE (9) - ans = QP_Tetrahedron_Order9() - CASE (10) - ans = QP_Tetrahedron_Order10() - CASE (11) - ans = QP_Tetrahedron_Order11() - CASE (12) - ans = QP_Tetrahedron_Order12() - CASE (13) - ans = QP_Tetrahedron_Order13() - CASE (14) - ans = QP_Tetrahedron_Order14() - CASE (15) - ans = QP_Tetrahedron_Order15() - CASE (16) - ans = QP_Tetrahedron_Order16() - CASE (17) - ans = QP_Tetrahedron_Order17() - CASE (18) - ans = QP_Tetrahedron_Order18() - CASE (19) - ans = QP_Tetrahedron_Order19() - CASE (20) - ans = QP_Tetrahedron_Order20() - CASE (21) - ans = QP_Tetrahedron_Order21() - END SELECT -END FUNCTION QuadraturePointTetrahedronSolin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order1() RESULT(ans) - REAL(DFP) :: ans(4, 1) - ans = RESHAPE([ & - & 0.250000000000000, 0.250000000000000, 0.250000000000000, 0.166666666666667 & - & ], [4, 1]) -END FUNCTION QP_Tetrahedron_Order1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order2() RESULT(ans) - REAL(DFP) :: ans(4, 4) - ans = RESHAPE([ & - & 0.585410196624969, 0.138196601125011, 0.138196601125011, 0.041666666666667, & - & 0.138196601125011, 0.138196601125011, 0.138196601125011, 0.041666666666667, & - & 0.138196601125011, 0.138196601125011, 0.585410196624969, 0.041666666666667, & - & 0.138196601125011, 0.585410196624969, 0.138196601125011, 0.041666666666667 & - & ], [4, 4]) -END FUNCTION QP_Tetrahedron_Order2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order3() RESULT(ans) - REAL(DFP) :: ans(4, 5) - ans = RESHAPE([ & - & 0.250000000000000, 0.250000000000000, 0.250000000000000, -0.133333333333333, & - & 0.500000000000000, 0.166666666666667, 0.166666666666667, 0.075000000000000, & - & 0.166666666666667, 0.166666666666667, 0.166666666666667, 0.075000000000000, & - & 0.166666666666667, 0.166666666666667, 0.500000000000000, 0.075000000000000, & - & 0.166666666666667, 0.500000000000000, 0.166666666666667, 0.075000000000000 & - & ], [4, 5]) -END FUNCTION QP_Tetrahedron_Order3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order4() RESULT(ans) - REAL(DFP) :: ans(4, 11) - ans = RESHAPE([ & - & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222, & - & 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888, & - & 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888, & - & 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888, & - & 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888, & - & 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888, & - & 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 & - & ], [4, 11]) -END FUNCTION QP_Tetrahedron_Order4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order5() RESULT(ans) - REAL(DFP) :: ans(4, 14) - ans = RESHAPE([ & - & 0.0927352503109, 0.0927352503109, 0.0927352503109 , 0.01224884051940, & - & 0.7217942490670, 0.0927352503109, 0.0927352503109 , 0.01224884051940, & - & 0.0927352503109, 0.7217942490670, 0.0927352503109 , 0.01224884051940, & - & 0.0927352503109, 0.0927352503109, 0.7217942490670 , 0.01224884051940, & - & 0.3108859192630, 0.3108859192630, 0.3108859192630 , 0.01878132095300, & - & 0.0673422422101, 0.3108859192630, 0.3108859192630 , 0.01878132095300, & - & 0.3108859192630, 0.0673422422101, 0.3108859192630 , 0.01878132095300, & - & 0.3108859192630, 0.3108859192630, 0.0673422422101 , 0.01878132095300, & - & 0.4544962958740, 0.4544962958740, 0.0455037041256 , 0.00709100346285, & - & 0.4544962958740, 0.0455037041256, 0.4544962958740 , 0.00709100346285, & - & 0.0455037041256, 0.4544962958740, 0.4544962958740 , 0.00709100346285, & - & 0.4544962958740, 0.0455037041256, 0.0455037041256 , 0.00709100346285, & - & 0.0455037041256, 0.4544962958740, 0.0455037041256 , 0.00709100346285, & - & 0.0455037041256, 0.0455037041256, 0.4544962958740 , 0.00709100346285 & - & ], [4, 14]) -END FUNCTION QP_Tetrahedron_Order5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order6() RESULT(ans) - REAL(DFP) :: ans(4, 24) - ans = RESHAPE([ & - & 0.2146028712590, 0.2146028712590, 0.2146028712590 , 0.006653791709700, & - & 0.3561913862230, 0.2146028712590, 0.2146028712590 , 0.006653791709700, & - & 0.2146028712590, 0.3561913862230, 0.2146028712590 , 0.006653791709700, & - & 0.2146028712590, 0.2146028712590, 0.3561913862230 , 0.006653791709700, & - & 0.0406739585346, 0.0406739585346, 0.0406739585346 , 0.001679535175883, & - & 0.8779781243960, 0.0406739585346, 0.0406739585346 , 0.001679535175883, & - & 0.0406739585346, 0.8779781243960, 0.0406739585346 , 0.001679535175883, & - & 0.0406739585346, 0.0406739585346, 0.8779781243960 , 0.001679535175883, & - & 0.3223378901420, 0.3223378901420, 0.3223378901420 , 0.009226196923950, & - & 0.0329863295732, 0.3223378901420, 0.3223378901420 , 0.009226196923950, & - & 0.3223378901420, 0.0329863295732, 0.3223378901420 , 0.009226196923950, & - & 0.3223378901420, 0.3223378901420, 0.0329863295732 , 0.009226196923950, & - & 0.0636610018750, 0.0636610018750, 0.2696723314580 , 0.008035714285717, & - & 0.0636610018750, 0.2696723314580, 0.0636610018750 , 0.008035714285717, & - & 0.0636610018750, 0.0636610018750, 0.6030056647920 , 0.008035714285717, & - & 0.0636610018750, 0.6030056647920, 0.0636610018750 , 0.008035714285717, & - & 0.0636610018750, 0.2696723314580, 0.6030056647920 , 0.008035714285717, & - & 0.0636610018750, 0.6030056647920, 0.2696723314580 , 0.008035714285717, & - & 0.2696723314580, 0.0636610018750, 0.0636610018750 , 0.008035714285717, & - & 0.2696723314580, 0.0636610018750, 0.6030056647920 , 0.008035714285717, & - & 0.2696723314580, 0.6030056647920, 0.0636610018750 , 0.008035714285717, & - & 0.6030056647920, 0.0636610018750, 0.2696723314580 , 0.008035714285717, & - & 0.6030056647920, 0.0636610018750, 0.0636610018750 , 0.008035714285717, & - & 0.6030056647920, 0.2696723314580, 0.0636610018750 , 0.008035714285717 & - & ], [4, 24]) -END FUNCTION QP_Tetrahedron_Order6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order7() RESULT(ans) - REAL(DFP) :: ans(4, 31) - ans = RESHAPE([ & - & 0.50000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, & - & 0.50000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, & - & 0.00000000000000, 0.50000000000000, 0.50000000000000 , +0.000970017636685, & - & 0.00000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, & - & 0.00000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, & - & 0.50000000000000, 0.00000000000000, 0.00000000000000 , +0.000970017636685, & - & 0.25000000000000, 0.25000000000000, 0.25000000000000 , +0.018264223466167, & - & 0.07821319233030, 0.07821319233030, 0.07821319233030 , +0.010599941524417, & - & 0.07821319233030, 0.07821319233030, 0.76536042300900 , +0.010599941524417, & - & 0.07821319233030, 0.76536042300900, 0.07821319233030 , +0.010599941524417, & - & 0.76536042300900, 0.07821319233030, 0.07821319233030 , +0.010599941524417, & - & 0.12184321666400, 0.12184321666400, 0.12184321666400 , -0.062517740114333, & - & 0.12184321666400, 0.12184321666400, 0.63447035000800 , -0.062517740114333, & - & 0.12184321666400, 0.63447035000800, 0.12184321666400 , -0.062517740114333, & - & 0.63447035000800, 0.12184321666400, 0.12184321666400 , -0.062517740114333, & - & 0.33253916444600, 0.33253916444600, 0.33253916444600 , +0.004891425263067, & - & 0.33253916444600, 0.33253916444600, 0.00238250666074 , +0.004891425263067, & - & 0.33253916444600, 0.00238250666074, 0.33253916444600 , +0.004891425263067, & - & 0.00238250666074, 0.33253916444600, 0.33253916444600 , +0.004891425263067, & - & 0.10000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.20000000000000, 0.60000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.60000000000000, 0.20000000000000 , +0.027557319224000, & - & 0.20000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.20000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, & - & 0.20000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.60000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, & - & 0.60000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.60000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000 & - & ], [4, 31]) -END FUNCTION QP_Tetrahedron_Order7 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order8() RESULT(ans) - REAL(DFP) :: ans(4, 43) - ans = RESHAPE([ & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.020500188658667, & - & 0.2068299316110, 0.2068299316110, 0.2068299316110 , +0.014250305822867, & - & 0.2068299316110, 0.2068299316110, 0.3795102051680 , +0.014250305822867, & - & 0.2068299316110, 0.3795102051680, 0.2068299316110 , +0.014250305822867, & - & 0.3795102051680, 0.2068299316110, 0.2068299316110 , +0.014250305822867, & - & 0.0821035883105, 0.0821035883105, 0.0821035883105 , +0.001967033313133, & - & 0.0821035883105, 0.0821035883105, 0.7536892350680 , +0.001967033313133, & - & 0.0821035883105, 0.7536892350680, 0.0821035883105 , +0.001967033313133, & - & 0.7536892350680, 0.0821035883105, 0.0821035883105 , +0.001967033313133, & - & 0.0057819505052, 0.0057819505052, 0.0057819505052 , +0.000169834109093, & - & 0.0057819505052, 0.0057819505052, 0.9826541484840 , +0.000169834109093, & - & 0.0057819505052, 0.9826541484840, 0.0057819505052 , +0.000169834109093, & - & 0.9826541484840, 0.0057819505052, 0.0057819505052 , +0.000169834109093, & - & 0.0505327400189, 0.0505327400189, 0.4494672599810 , +0.004579683824467, & - & 0.0505327400189, 0.4494672599810, 0.0505327400189 , +0.004579683824467, & - & 0.4494672599810, 0.0505327400189, 0.0505327400189 , +0.004579683824467, & - & 0.0505327400189, 0.4494672599810, 0.4494672599810 , +0.004579683824467, & - & 0.4494672599810, 0.0505327400189, 0.4494672599810 , +0.004579683824467, & - & 0.4494672599810, 0.4494672599810, 0.0505327400189 , +0.004579683824467, & - & 0.2290665361170, 0.2290665361170, 0.0356395827885 , +0.005704485808683, & - & 0.2290665361170, 0.0356395827885, 0.2290665361170 , +0.005704485808683, & - & 0.2290665361170, 0.2290665361170, 0.5062273449780 , +0.005704485808683, & - & 0.2290665361170, 0.5062273449780, 0.2290665361170 , +0.005704485808683, & - & 0.2290665361170, 0.0356395827885, 0.5062273449780 , +0.005704485808683, & - & 0.2290665361170, 0.5062273449780, 0.0356395827885 , +0.005704485808683, & - & 0.0356395827885, 0.2290665361170, 0.2290665361170 , +0.005704485808683, & - & 0.0356395827885, 0.2290665361170, 0.5062273449780 , +0.005704485808683, & - & 0.0356395827885, 0.5062273449780, 0.2290665361170 , +0.005704485808683, & - & 0.5062273449780, 0.2290665361170, 0.0356395827885 , +0.005704485808683, & - & 0.5062273449780, 0.2290665361170, 0.2290665361170 , +0.005704485808683, & - & 0.5062273449780, 0.0356395827885, 0.2290665361170 , +0.005704485808683, & - & 0.0366077495532, 0.0366077495532, 0.1904860419350 , +0.002140519141167, & - & 0.0366077495532, 0.1904860419350, 0.0366077495532 , +0.002140519141167, & - & 0.0366077495532, 0.0366077495532, 0.7362984589590 , +0.002140519141167, & - & 0.0366077495532, 0.7362984589590, 0.0366077495532 , +0.002140519141167, & - & 0.0366077495532, 0.1904860419350, 0.7362984589590 , +0.002140519141167, & - & 0.0366077495532, 0.7362984589590, 0.1904860419350 , +0.002140519141167, & - & 0.1904860419350, 0.0366077495532, 0.0366077495532 , +0.002140519141167, & - & 0.1904860419350, 0.0366077495532, 0.7362984589590 , +0.002140519141167, & - & 0.1904860419350, 0.7362984589590, 0.0366077495532 , +0.002140519141167, & - & 0.7362984589590, 0.0366077495532, 0.1904860419350 , +0.002140519141167, & - & 0.7362984589590, 0.0366077495532, 0.0366077495532 , +0.002140519141167, & - & 0.7362984589590, 0.1904860419350, 0.0366077495532 , +0.002140519141167 & - & ], [4, 43]) -END FUNCTION QP_Tetrahedron_Order8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order9() RESULT(ans) - REAL(DFP) :: ans(4, 53) - ans = RESHAPE([ & - & +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167, & - & +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & - & +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083, & - & +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083, & - & +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & - & +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & - & +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500, & - & +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500, & - & +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & - & +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & - & +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167, & - & +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167, & - & +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & - & +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & - & +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500, & - & +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500, & - & +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & - & +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & - & +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & - & +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & - & +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & - & +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500, & - & +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500, & - & +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & - & +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & - & +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & - & +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & - & +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & - & +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & - & +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & - & +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & - & +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & - & +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & - & +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667, & - & +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667, & - & +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & - & +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & - & +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & - & +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & - & +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & - & +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & - & -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & - & -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557, & - & -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & - & -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & - & -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557, & - & -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557, & - & +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & - & +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & - & +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & - & +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & - & +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & - & +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 & - & ], [4, 53]) -END FUNCTION QP_Tetrahedron_Order9 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order10() RESULT(ans) - REAL(DFP) :: ans(4, 126) - ans = QP_Tetrahedron_Order11() -END FUNCTION QP_Tetrahedron_Order10 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order11() RESULT(ans) - REAL(DFP) :: ans(4, 126) - ans = RESHAPE([ & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.4062316284e-05 & - & ], [4, 126]) -END FUNCTION QP_Tetrahedron_Order11 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order12() RESULT(ans) - REAL(DFP) :: ans(4, 210) - ans = QP_Tetrahedron_Order13() -END FUNCTION QP_Tetrahedron_Order12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order13() RESULT(ans) - REAL(DFP) :: ans(4, 210) - ans = RESHAPE([ & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 & - & ], [4, 210]) -END FUNCTION - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order14() RESULT(ans) - REAL(DFP) :: ans(4, 330) - ans = QP_Tetrahedron_Order15() -END FUNCTION - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order15() RESULT(ans) - REAL(DFP) :: ans(4, 330) - ans = RESHAPE([ & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 & - & ], [4, 330]) -END FUNCTION QP_Tetrahedron_Order15 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order16() RESULT(ans) - REAL(DFP) :: ans(4, 495) - ans = QP_Tetrahedron_Order17() -END FUNCTION QP_Tetrahedron_Order16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order17() RESULT(ans) - REAL(DFP) :: ans(4, 495) - ans = RESHAPE([ & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3573205875e-08 & - & ], [4, 495]) -END FUNCTION QP_Tetrahedron_Order17 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order18() RESULT(ans) - REAL(DFP) :: ans(4, 715) - ans = QP_Tetrahedron_Order19() -END FUNCTION QP_Tetrahedron_Order18 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order19() RESULT(ans) - REAL(DFP) :: ans(4, 715) - ans = RESHAPE([ & - & 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 & - & ], [4, 715]) -END FUNCTION QP_Tetrahedron_Order19 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order20() RESULT(ans) - REAL(DFP) :: ans(4, 1001) - ans = QP_Tetrahedron_Order21() -END FUNCTION QP_Tetrahedron_Order20 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order21() RESULT(ans) - REAL(DFP) :: ans(4, 1001) - ans = RESHAPE([ & - & 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 & - & ], [4, 1001]) -END FUNCTION QP_Tetrahedron_Order21 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE QuadraturePoint_Tetrahedron_Solin diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 deleted file mode 100644 index 58f5d1310..000000000 --- a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 +++ /dev/null @@ -1,477 +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 -! - -! reference -! http://people.sc.fsu.edu/~jburkardt/datasets/quadrature_rules_tri/quadrature_rules_tri.html -! -! Jarle Berntsen, Terje Espelid, -! Algorithm 706, -! DCUTRI: an algorithm for adaptive cubature over a collection of triangles, -! ACM Transactions on Mathematical Software, -! Volume 18, Number 3, September 1992, pages 329-342. -! -! -! Elise deDoncker, Ian Robinson, -! Algorithm 612: Integration over a Triangle Using Nonlinear Extrapolation, -! ACM Transactions on Mathematical Software, -! Volume 10, Number 1, March 1984, pages 17-22. -! -! -! Dirk Laurie, -! Algorithm 584, CUBTRI, Automatic Cubature Over a Triangle, -! ACM Transactions on Mathematical Software, -! Volume 8, Number 2, 1982, pages 210-218. -! -! -! James Lyness, Dennis Jespersen, -! Moderate Degree Symmetric Quadrature Rules for the Triangle, -! Journal of the Institute of Mathematics and its Applications, -! Volume 15, Number 1, February 1975, pages 19-32. -! -! -! Hans Rudolf Schwarz, -! Finite Element Methods, -! Academic Press, 1988, -! ISBN: 0126330107, -! LC: TA347.F5.S3313. -! -! -! Gilbert Strang, George Fix, -! An Analysis of the Finite Element Method, -! Cambridge, 1973, -! ISBN: 096140888X, -! LC: TA335.S77. -! -! -! Arthur Stroud, -! Approximate Calculation of Multiple Integrals, -! Prentice Hall, 1971, -! ISBN: 0130438936, -! LC: QA311.S85. -! -! -! Olgierd Zienkiewicz, -! The Finite Element Method, -! Sixth Edition, -! Butterworth-Heinemann, 2005, -! ISBN: 0750663200, -! LC: TA640.2.Z54 - -module QuadraturePoint_Triangle_InternalUseOnly -USE GlobalData, only: DFP -implicit none -private - -REAL(DFP), DIMENSION(3, 1), PUBLIC, PARAMETER :: TPW1 = & - & TRANSPOSE(RESHAPE([ & - & 0.3333333333333333_DFP, 0.3333333333333333_DFP, 0.5_DFP], & - & [1, 3])) -!! TPW1 has accuracy 1 - -REAL(DFP), DIMENSION(3, 3), PUBLIC, PARAMETER :: TPW3 = & - & TRANSPOSE(RESHAPE([ & - & 0.66666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP, & - & 0.16666666666666666_DFP, 0.66666666666666666_DFP, 0.16666666666666666_DFP, & - & 0.16666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP],& - & [3, 3])) -!! TPW3 has accuracy 2, Strang1 - -REAL(DFP), DIMENSION(3, 4), PUBLIC, PARAMETER :: TPW4 = & - & TRANSPOSE(RESHAPE([ & - & 0.3333333333333333_DFP, 0.2_DFP, 0.2_DFP, & - & 0.6_DFP, 0.3333333333333333_DFP, 0.2_DFP, & - & 0.6_DFP, 0.2_DFP, -0.28125_DFP, & - & 0.2604166666666667_DFP, 0.2604166666666667_DFP, 0.2604166666666667_DFP], [4, 3])) -!! TPW4 has accuracy 3, Strang3 - -REAL(DFP), DIMENSION(3, 6), PUBLIC, PARAMETER :: TPW6 = & - & TRANSPOSE(RESHAPE([0.091576213509771_DFP, & - & 0.816847572980458_DFP, 0.091576213509771_DFP, & - & 0.445948490915965_DFP, 0.445948490915965_DFP, & - & 0.10810301816807_DFP, 0.091576213509771_DFP, & - & 0.091576213509771_DFP, 0.816847572980458_DFP, & - & 0.10810301816807_DFP, 0.445948490915965_DFP, & - & 0.445948490915965_DFP, 0.0549758718227661_DFP, & - & 0.0549758718227661_DFP, 0.0549758718227661_DFP, & - & 0.11169079483905_DFP, 0.11169079483905_DFP, & - & 0.11169079483905_DFP], [6, 3])) -!! TPW6 has accuracy 4, Strang5 - -REAL(DFP), DIMENSION(3, 7), PUBLIC, PARAMETER :: TPW7 = & - & TRANSPOSE(RESHAPE([ & - & 0.3333333333333333_DFP, & - & 0.470142064105115_DFP, 0.05971587178977_DFP, & - & 0.470142064105115_DFP, 0.101286507323456_DFP, & - & 0.797426985353088_DFP, 0.101286507323456_DFP, & - & 0.3333333333333333_DFP, 0.470142064105115_DFP, & - & 0.470142064105115_DFP, 0.05971587178977_DFP, & - & 0.101286507323456_DFP, 0.101286507323456_DFP, & - & 0.797426985353088_DFP, 0.1125_DFP, & - & 0.066197076394253_DFP, 0.066197076394253_DFP, & - & 0.066197076394253_DFP, 0.062969590272413_DFP, & - & 0.062969590272413_DFP, 0.062969590272413_DFP], & - & [7, 3])) -!! TPW7 has accuracy 5, Strang7 - -REAL(DFP), DIMENSION(3, 9), PUBLIC, PARAMETER :: TPW9 = & -& transpose(reshape( [ & - 0.124949503233232_DFP ,& - 0.437525248383384_DFP ,& - 0.437525248383384_DFP ,& - 0.797112651860071_DFP ,& - 0.797112651860071_DFP ,& - 0.165409927389841_DFP ,& - 0.165409927389841_DFP ,& - 0.037477420750088_DFP ,& - 0.037477420750088_DFP ,& - 0.437525248383384_DFP ,& - 0.124949503233232_DFP ,& - 0.437525248383384_DFP ,& - 0.165409927389841_DFP ,& - 0.037477420750088_DFP ,& - 0.797112651860071_DFP ,& - 0.037477420750088_DFP ,& - 0.797112651860071_DFP ,& - 0.165409927389841_DFP ,& - 0.205950504760887_DFP/2.0_DFP ,& - 0.205950504760887_DFP/2.0_DFP ,& - 0.205950504760887_DFP/2.0_DFP ,& - 0.063691414286223_DFP/2.0_DFP ,& - 0.063691414286223_DFP/2.0_DFP ,& - 0.063691414286223_DFP/2.0_DFP ,& - 0.063691414286223_DFP/2.0_DFP ,& - 0.063691414286223_DFP/2.0_DFP ,& - 0.063691414286223_DFP/2.0_DFP], & -& [9,3])) - -!! TPw9 has accuracy 6, Strang8 -!! Do not use this rule - -REAL(DFP), DIMENSION(3, 12), PUBLIC, PARAMETER :: TPW12 = & - & TRANSPOSE(RESHAPE([ & - & 0.063089014491502_DFP, & - & 0.873821971016996_DFP, 0.063089014491502_DFP, & - & 0.24928674517091_DFP, 0.50142650965818_DFP, & - & 0.24928674517091_DFP, 0.310352451033785_DFP, & - & 0.053145049844816_DFP, 0.636502499121399_DFP, & - & 0.636502499121399_DFP, 0.310352451033785_DFP, & - & 0.053145049844816_DFP, 0.063089014491502_DFP, & - & 0.063089014491502_DFP, 0.873821971016996_DFP, & - & 0.24928674517091_DFP, 0.24928674517091_DFP, & - & 0.50142650965818_DFP, 0.053145049844816_DFP, & - & 0.310352451033785_DFP, 0.310352451033785_DFP, & - & 0.053145049844816_DFP, 0.636502499121399_DFP, & - & 0.636502499121399_DFP, 0.025422453185103_DFP, & - & 0.025422453185103_DFP, 0.025422453185103_DFP, & - & 0.058393137863189_DFP, 0.058393137863189_DFP, & - & 0.058393137863189_DFP, 0.041425537809187_DFP, & - & 0.041425537809187_DFP, 0.041425537809187_DFP, & - & 0.041425537809187_DFP, 0.041425537809187_DFP, & - & 0.041425537809187_DFP], [12, 3])) -!! STRANG9, order 12, degree of precision 6. - -REAL(DFP), DIMENSION(3, 13), PUBLIC, PARAMETER :: TPW13 = & -& TRANSPOSE(RESHAPE([ & -0.333333333333333_DFP, & -0.260345966079040_DFP, & -0.260345966079040_DFP, & -0.479308067841920_DFP, & -0.065130102902216_DFP, & -0.065130102902216_DFP, & -0.869739794195568_DFP, & -0.312865496004874_DFP, & -0.638444188569810_DFP, & -0.048690315425316_DFP, & -0.312865496004874_DFP, & -0.638444188569810_DFP, & -0.048690315425316_DFP, & -0.333333333333333_DFP, & -0.260345966079040_DFP, & -0.479308067841920_DFP, & -0.260345966079040_DFP, & -0.065130102902216_DFP, & -0.869739794195568_DFP, & -0.065130102902216_DFP, & -0.638444188569810_DFP, & -0.048690315425316_DFP, & -0.312865496004874_DFP, & -0.048690315425316_DFP, & -0.312865496004874_DFP, & -0.638444188569810_DFP, & --0.074785022233841_DFP, & -0.087807628716604_DFP, & -0.087807628716604_DFP, & -0.087807628716604_DFP, & -0.026673617804419_DFP, & -0.026673617804419_DFP, & -0.026673617804419_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP & -& ], & -& [13, 3])) -!! STRANG10, order 13, degree of precision 7. - -REAL(DFP), DIMENSION(3, 19), PUBLIC, PARAMETER :: TPW19b = & - & TRANSPOSE(RESHAPE( & -& [0.3333333333333333_DFP, 0.7974269853530872_DFP, & -& 0.1012865073234563_DFP, 0.1012865073234563_DFP, & -& 0.0597158717897698_DFP, 0.4701420641051151_DFP, & -& 0.4701420641051151_DFP, 0.5357953464498992_DFP, & -& 0.2321023267750504_DFP, 0.2321023267750504_DFP, & -& 0.9410382782311209_DFP, 0.0294808608844396_DFP, & -& 0.0294808608844396_DFP, 0.7384168123405100_DFP, & -& 0.7384168123405100_DFP, 0.2321023267750504_DFP, & -& 0.2321023267750504_DFP, 0.0294808608844396_DFP, & -& 0.0294808608844396_DFP, & -& 0.3333333333333333_DFP, 0.1012865073234563_DFP, & -& 0.7974269853530872_DFP, 0.1012865073234563_DFP, & -& 0.4701420641051151_DFP, 0.0597158717897698_DFP, & -& 0.4701420641051151_DFP, 0.2321023267750504_DFP, & -& 0.5357953464498992_DFP, 0.2321023267750504_DFP, & -& 0.0294808608844396_DFP, 0.9410382782311209_DFP, & -& 0.0294808608844396_DFP, 0.2321023267750504_DFP, & -& 0.0294808608844396_DFP, 0.7384168123405100_DFP, & -& 0.0294808608844396_DFP, 0.7384168123405100_DFP, & -& 0.2321023267750504_DFP, & -& 0.5_DFP * 0.0378610912003147_DFP, 0.5_DFP * 0.0376204254131829_DFP, & -& 0.5_DFP * 0.0376204254131829_DFP, & -& 0.5_DFP * 0.0376204254131829_DFP, 0.5_DFP * 0.0783573522441174_DFP, & -& 0.5_DFP * 0.0783573522441174_DFP, & -& 0.5_DFP * 0.0783573522441174_DFP, 0.5_DFP * 0.1162714796569659_DFP, & -& 0.5_DFP * 0.1162714796569659_DFP, & -& 0.5_DFP * 0.1162714796569659_DFP, 0.5_DFP * 0.0134442673751655_DFP, & -& 0.5_DFP * 0.0134442673751655_DFP, & -& 0.5_DFP * 0.0134442673751655_DFP, 0.5_DFP * 0.0375097224552317_DFP, & -& 0.5_DFP * 0.0375097224552317_DFP, & -& 0.5_DFP * 0.0375097224552317_DFP, 0.5_DFP * 0.0375097224552317_DFP, & -& 0.5_DFP * 0.0375097224552317_DFP, & -& 0.5_DFP * 0.0375097224552317_DFP & -& ], & -& [19, 3])) - -!! TOMS584_19, order 19, degree of precision 8, a rule from ACM TOMS algorithm 584. - - -REAL(DFP), DIMENSION(3, 19), PUBLIC, PARAMETER :: TPW19 = & - & TRANSPOSE(RESHAPE( & -& [0.33333333333333331, 2.06349616025259287E-002, 0.48968251919873701, & -& 0.48968251919873701, 0.12582081701412900, 0.43708959149293553, & -& 0.43708959149293553, 0.62359292876193562, 0.18820353561903219, & -& 0.18820353561903219, 0.91054097321109406, 4.47295133944529688E-002, & -& 4.47295133944529688E-002, 0.74119859878449801, 0.74119859878449801, & -& 3.68384120547362581E-002, 3.68384120547362581E-002, 0.22196298916076573, & -& 0.22196298916076573, & -& 0.33333333333333331, 0.48968251919873701, & -& 2.06349616025259287E-002, 0.48968251919873701, & -& 0.43708959149293553, 0.12582081701412900, & -& 0.43708959149293553, 0.18820353561903219, & -& 0.62359292876193562, 0.18820353561903219, & -& 4.47295133944529688E-002, 0.91054097321109406, & -& 4.47295133944529688E-002, 3.68384120547362581E-002, & -& 0.22196298916076573, 0.74119859878449801, 0.22196298916076573, & -& 0.74119859878449801, 3.68384120547362581E-002, & -& 0.5 * 9.71357962827961025E-002, 0.5 * 3.13347002271398278E-002, & -& 0.5 * 3.13347002271398278E-002, 0.5 * 3.13347002271398278E-002, & -& 0.5 * 7.78275410047754301E-002, 0.5 * 7.78275410047754301E-002, & -& 0.5 * 7.78275410047754301E-002, 0.5 * 7.96477389272090969E-002, & -& 0.5 * 7.96477389272090969E-002, 0.5 * 7.96477389272090969E-002, & -& 0.5 * 2.55776756586981006E-002, 0.5 * 2.55776756586981006E-002, & -& 0.5 * 2.55776756586981006E-002, 0.5 * 4.32835393772893970E-002, & -& 0.5 * 4.32835393772893970E-002, 0.5 * 4.32835393772893970E-002, & -& 0.5 * 4.32835393772893970E-002, 0.5 * 4.32835393772893970E-002, & -& 0.5 * 4.32835393772893970E-002], & -& [19, 3])) - -!! TOMS612_19, order 19, degree of precision 9, a rule from ACM TOMS algorithm 612 - -REAL(DFP), DIMENSION(3, 28), PUBLIC, PARAMETER :: TPW28 = & - & TRANSPOSE(RESHAPE( & -&[0.33333333333333333_DFP, 0.9480217181434233_DFP, & -& 0.02598914092828833_DFP, 0.02598914092828833_DFP, & -& 0.8114249947041546_DFP, 0.09428750264792270_DFP, & -& 0.09428750264792270_DFP, 0.01072644996557060_DFP, & -& 0.4946367750172147_DFP, 0.4946367750172147_DFP, & -& 0.5853132347709715_DFP, 0.2073433826145142_DFP, & -& 0.2073433826145142_DFP, 0.1221843885990187_DFP, & -& 0.4389078057004907_DFP, 0.4389078057004907_DFP, & -& 0.6779376548825902_DFP, 0.6779376548825902_DFP, & -& 0.04484167758913055_DFP, 0.04484167758913055_DFP, & -& 0.27722066752827925_DFP, 0.27722066752827925_DFP, & -& 0.8588702812826364_DFP, 0.8588702812826364_DFP, & -& 0.0000000000000000_DFP, 0.0000000000000000_DFP, & -& 0.1411297187173636_DFP, 0.1411297187173636_DFP, & -& 0.333333333333333333_DFP, 0.02598914092828833_DFP, & -& 0.9480217181434233_DFP, 0.02598914092828833_DFP, & -& 0.09428750264792270_DFP, 0.8114249947041546_DFP, & -& 0.09428750264792270_DFP, 0.4946367750172147_DFP, & -& 0.01072644996557060_DFP, 0.4946367750172147_DFP, & -& 0.2073433826145142_DFP, 0.5853132347709715_DFP, & -& 0.2073433826145142_DFP, 0.4389078057004907_DFP, & -& 0.1221843885990187_DFP, 0.4389078057004907_DFP, & -& 0.04484167758913055_DFP, 0.27722066752827925_DFP, & -& 0.6779376548825902_DFP, 0.27722066752827925_DFP, & -& 0.6779376548825902_DFP, 0.04484167758913055_DFP, & -& 0.00000000000000000_DFP, 0.1411297187173636_DFP, & -& 0.8588702812826364_DFP, 0.1411297187173636_DFP, & -& 0.8588702812826364_DFP, 0.0000000000000000_DFP, & -& 0.5_DFP * 0.08797730116222190_DFP, 0.5_DFP * 0.008744311553736190_DFP, & -& 0.5_DFP * 0.008744311553736190_DFP, & -& 0.5_DFP * 0.008744311553736190_DFP, 0.5_DFP * 0.03808157199393533_DFP, & -& 0.5_DFP * 0.03808157199393533_DFP, & -& 0.5_DFP * 0.03808157199393533_DFP, 0.5_DFP * 0.01885544805613125_DFP, & -& 0.5_DFP * 0.01885544805613125_DFP, & -& 0.5_DFP * 0.01885544805613125_DFP, 0.5_DFP * 0.07215969754474100_DFP, & -& 0.5_DFP * 0.07215969754474100_DFP, & -& 0.5_DFP * 0.07215969754474100_DFP, 0.5_DFP * 0.06932913870553720_DFP, & -& 0.5_DFP * 0.06932913870553720_DFP, & -& 0.5_DFP * 0.06932913870553720_DFP, 0.5_DFP * 0.04105631542928860_DFP, & -& 0.5_DFP * 0.04105631542928860_DFP, & -& 0.5_DFP * 0.04105631542928860_DFP, 0.5_DFP * 0.04105631542928860_DFP, & -& 0.5_DFP * 0.04105631542928860_DFP, & -& 0.5_DFP * 0.04105631542928860_DFP, 0.5_DFP * 0.007362383783300573_DFP, & -& 0.5_DFP * 0.007362383783300573_DFP, & -& 0.5_DFP * 0.007362383783300573_DFP, 0.5_DFP * 0.007362383783300573_DFP, & -& 0.5_DFP * 0.007362383783300573_DFP, & -& 0.5_DFP * 0.007362383783300573_DFP], & -& [28, 3])) - -!! TOMS612_28, order 28, degree of precision 11, a rule from ACM TOMS algorithm 612. - -REAL(DFP), DIMENSION(3, 37), PUBLIC, PARAMETER :: TPW37 = & - & TRANSPOSE(RESHAPE([ & -0.333333333333333333333333333333_DFP, & -0.950275662924105565450352089520_DFP, & -0.024862168537947217274823955239_DFP, & -0.024862168537947217274823955239_DFP, & -0.171614914923835347556304795551_DFP, & -0.414192542538082326221847602214_DFP, & -0.414192542538082326221847602214_DFP, & -0.539412243677190440263092985511_DFP, & -0.230293878161404779868453507244_DFP, & -0.230293878161404779868453507244_DFP, & -0.772160036676532561750285570113_DFP, & -0.113919981661733719124857214943_DFP, & -0.113919981661733719124857214943_DFP, & -0.009085399949835353883572964740_DFP, & -0.495457300025082323058213517632_DFP, & -0.495457300025082323058213517632_DFP, & -0.062277290305886993497083640527_DFP, & -0.468861354847056503251458179727_DFP, & -0.468861354847056503251458179727_DFP, & -0.022076289653624405142446876931_DFP, & -0.022076289653624405142446876931_DFP, & -0.851306504174348550389457672223_DFP, & -0.851306504174348550389457672223_DFP, & -0.126617206172027096933163647918_DFP, & -0.126617206172027096933163647918_DFP, & -0.018620522802520968955913511549_DFP, & -0.018620522802520968955913511549_DFP, & -0.689441970728591295496647976487_DFP, & -0.689441970728591295496647976487_DFP, & -0.291937506468887771754472382212_DFP, & -0.291937506468887771754472382212_DFP, & -0.096506481292159228736516560903_DFP, & -0.096506481292159228736516560903_DFP, & -0.635867859433872768286976979827_DFP, & -0.635867859433872768286976979827_DFP, & -0.267625659273967961282458816185_DFP, & -0.267625659273967961282458816185_DFP, & -0.333333333333333333333333333333_DFP, & -0.024862168537947217274823955239_DFP, & -0.950275662924105565450352089520_DFP, & -0.024862168537947217274823955239_DFP, & -0.414192542538082326221847602214_DFP, & -0.171614914923835347556304795551_DFP, & -0.414192542538082326221847602214_DFP, & -0.230293878161404779868453507244_DFP, & -0.539412243677190440263092985511_DFP, & -0.230293878161404779868453507244_DFP, & -0.113919981661733719124857214943_DFP, & -0.772160036676532561750285570113_DFP, & -0.113919981661733719124857214943_DFP, & -0.495457300025082323058213517632_DFP, & -0.009085399949835353883572964740_DFP, & -0.495457300025082323058213517632_DFP, & -0.468861354847056503251458179727_DFP, & -0.062277290305886993497083640527_DFP, & -0.468861354847056503251458179727_DFP, & -0.851306504174348550389457672223_DFP, & -0.126617206172027096933163647918_DFP, & -0.022076289653624405142446876931_DFP, & -0.126617206172027096933163647918_DFP, & -0.022076289653624405142446876931_DFP, & -0.851306504174348550389457672223_DFP, & -0.689441970728591295496647976487_DFP, & -0.291937506468887771754472382212_DFP, & -0.018620522802520968955913511549_DFP, & -0.291937506468887771754472382212_DFP, & -0.018620522802520968955913511549_DFP, & -0.689441970728591295496647976487_DFP, & -0.635867859433872768286976979827_DFP, & -0.267625659273967961282458816185_DFP, & -0.096506481292159228736516560903_DFP, & -0.267625659273967961282458816185_DFP, & -0.096506481292159228736516560903_DFP, & -0.635867859433872768286976979827_DFP, & -0.5_DFP * 0.051739766065744133555179145422_DFP, & -0.5_DFP * 0.008007799555564801597804123460_DFP, & -0.5_DFP * 0.008007799555564801597804123460_DFP, & -0.5_DFP * 0.008007799555564801597804123460_DFP, & -0.5_DFP * 0.046868898981821644823226732071_DFP, & -0.5_DFP * 0.046868898981821644823226732071_DFP, & -0.5_DFP * 0.046868898981821644823226732071_DFP, & -0.5_DFP * 0.046590940183976487960361770070_DFP, & -0.5_DFP * 0.046590940183976487960361770070_DFP, & -0.5_DFP * 0.046590940183976487960361770070_DFP, & -0.5_DFP * 0.031016943313796381407646220131_DFP, & -0.5_DFP * 0.031016943313796381407646220131_DFP, & -0.5_DFP * 0.031016943313796381407646220131_DFP, & -0.5_DFP * 0.010791612736631273623178240136_DFP, & -0.5_DFP * 0.010791612736631273623178240136_DFP, & -0.5_DFP * 0.010791612736631273623178240136_DFP, & -0.5_DFP * 0.032195534242431618819414482205_DFP, & -0.5_DFP * 0.032195534242431618819414482205_DFP, & -0.5_DFP * 0.032195534242431618819414482205_DFP, & -0.5_DFP * 0.015445834210701583817692900053_DFP, & -0.5_DFP * 0.015445834210701583817692900053_DFP, & -0.5_DFP * 0.015445834210701583817692900053_DFP, & -0.5_DFP * 0.015445834210701583817692900053_DFP, & -0.5_DFP * 0.015445834210701583817692900053_DFP, & -0.5_DFP * 0.015445834210701583817692900053_DFP, & -0.5_DFP * 0.017822989923178661888748319485_DFP, & -0.5_DFP * 0.017822989923178661888748319485_DFP, & -0.5_DFP * 0.017822989923178661888748319485_DFP, & -0.5_DFP * 0.017822989923178661888748319485_DFP, & -0.5_DFP * 0.017822989923178661888748319485_DFP, & -0.5_DFP * 0.017822989923178661888748319485_DFP, & -0.5_DFP * 0.037038683681384627918546472190_DFP, & -0.5_DFP * 0.037038683681384627918546472190_DFP, & -0.5_DFP * 0.037038683681384627918546472190_DFP, & -0.5_DFP * 0.037038683681384627918546472190_DFP, & -0.5_DFP * 0.037038683681384627918546472190_DFP, & -0.5_DFP * 0.037038683681384627918546472190_DFP], & -[37, 3])) - -!!TOMS706_37, order 37, degree of precision 13, a rule from ACM TOMS algorithm 706. - - - -end module QuadraturePoint_Triangle_InternalUseOnly diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 deleted file mode 100644 index 9e154630b..000000000 --- a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 +++ /dev/null @@ -1,2170 +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 -! - -! reference -! 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 -USE GlobalData, only: DFP, I4B -implicit none -private -public :: QuadratureNumberTriangleSolin -public :: QuadraturePointTriangleSolin -public :: QuadraturePointTriangleSolin_ - -REAL(DFP), DIMENSION(3, 1), PUBLIC, PARAMETER :: triSolin1 = & - & TRANSPOSE(RESHAPE([ & - & 0.3333333333333333_DFP, 0.3333333333333333_DFP, 0.5_DFP], & - & [1, 3])) -!! triSolin1 has accuracy 1 - -REAL(DFP), DIMENSION(3, 3), PUBLIC, PARAMETER :: triSolin3 = & - & TRANSPOSE(RESHAPE([ & - & 0.66666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP, & - & 0.16666666666666666_DFP, 0.66666666666666666_DFP, 0.16666666666666666_DFP, & - & 0.16666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP],& - & [3, 3])) -!! triSolin3 has accuracy 2, Strang1 - -REAL(DFP), DIMENSION(3, 4), PUBLIC, PARAMETER :: triSolin4 = & - & TRANSPOSE(RESHAPE([ & - & 0.3333333333333333_DFP, 0.2_DFP, 0.2_DFP, & - & 0.6_DFP, 0.3333333333333333_DFP, 0.2_DFP, & - & 0.6_DFP, 0.2_DFP, -0.28125_DFP, & - & 0.2604166666666667_DFP, 0.2604166666666667_DFP, 0.2604166666666667_DFP], [4, 3])) -!! triSolin4 has accuracy 3, Strang3 -!! 1 negative weight, 0 points outside of the triangle, total sum of the -!! weights is 0.5 - -REAL(DFP), DIMENSION(3, 6), PUBLIC, PARAMETER :: triSolin6 = & - & TRANSPOSE(RESHAPE([0.091576213509771_DFP, & - & 0.816847572980458_DFP, 0.091576213509771_DFP, & - & 0.445948490915965_DFP, 0.445948490915965_DFP, & - & 0.10810301816807_DFP, 0.091576213509771_DFP, & - & 0.091576213509771_DFP, 0.816847572980458_DFP, & - & 0.10810301816807_DFP, 0.445948490915965_DFP, & - & 0.445948490915965_DFP, 0.0549758718227661_DFP, & - & 0.0549758718227661_DFP, 0.0549758718227661_DFP, & - & 0.11169079483905_DFP, 0.11169079483905_DFP, & - & 0.11169079483905_DFP], [6, 3])) -!! triSolin6 has accuracy 4, Strang5 -!! 0 negative weights, 0 points outside of the triangle, total sum of the -!! weights is 0.5 - -REAL(DFP), DIMENSION(3, 7), PUBLIC, PARAMETER :: triSolin7 = & - & TRANSPOSE(RESHAPE([ & - & 0.3333333333333333_DFP, & - & 0.470142064105115_DFP, 0.05971587178977_DFP, & - & 0.470142064105115_DFP, 0.101286507323456_DFP, & - & 0.797426985353088_DFP, 0.101286507323456_DFP, & - & 0.3333333333333333_DFP, 0.470142064105115_DFP, & - & 0.470142064105115_DFP, 0.05971587178977_DFP, & - & 0.101286507323456_DFP, 0.101286507323456_DFP, & - & 0.797426985353088_DFP, 0.1125_DFP, & - & 0.066197076394253_DFP, 0.066197076394253_DFP, & - & 0.066197076394253_DFP, 0.062969590272413_DFP, & - & 0.062969590272413_DFP, 0.062969590272413_DFP], & - & [7, 3])) -!! triSolin7 has accuracy 5, Strang7 -!! 0 negative weights, 0 points outside of the triangle, total sum of the -!! weights is 0.5 - -REAL(DFP), DIMENSION(3, 12), PUBLIC, PARAMETER :: triSolin12 = & -& transpose(reshape( [ & -0.249286745170910_DFP, & -0.249286745170910_DFP, & -0.501426509658179_DFP, & -0.063089014491502_DFP, & -0.063089014491502_DFP, & -0.873821971016996_DFP, & -0.310352451033785_DFP, & -0.636502499121399_DFP, & -0.053145049844816_DFP, & -0.310352451033785_DFP, & -0.636502499121399_DFP, & -0.053145049844816_DFP, & -0.249286745170910_DFP, & -0.501426509658179_DFP, & -0.249286745170910_DFP, & -0.063089014491502_DFP, & -0.873821971016996_DFP, & -0.063089014491502_DFP, & -0.636502499121399_DFP, & -0.053145049844816_DFP, & -0.310352451033785_DFP, & -0.053145049844816_DFP, & -0.310352451033785_DFP, & -0.636502499121399_DFP, & -0.058393137863189_DFP, & -0.058393137863189_DFP, & -0.058393137863189_DFP, & -0.025422453185104_DFP, & -0.025422453185104_DFP, & -0.025422453185104_DFP, & -0.041425537809187_DFP, & -0.041425537809187_DFP, & -0.041425537809187_DFP, & -0.041425537809187_DFP, & -0.041425537809187_DFP, & -0.041425537809187_DFP & -& ], & -& [12,3])) - -!! accuracy = 6 -!! 0 negative weights, 0 points outside of the triangle, total sum of the -!! weights is 0.5 - -REAL(DFP), DIMENSION(3, 13), PUBLIC, PARAMETER :: triSolin13 = & -& TRANSPOSE(RESHAPE([ & -0.333333333333333_DFP, & -0.260345966079040_DFP, & -0.260345966079040_DFP, & -0.479308067841920_DFP, & -0.065130102902216_DFP, & -0.065130102902216_DFP, & -0.869739794195568_DFP, & -0.312865496004874_DFP, & -0.638444188569810_DFP, & -0.048690315425316_DFP, & -0.312865496004874_DFP, & -0.638444188569810_DFP, & -0.048690315425316_DFP, & -0.333333333333333_DFP, & -0.260345966079040_DFP, & -0.479308067841920_DFP, & -0.260345966079040_DFP, & -0.065130102902216_DFP, & -0.869739794195568_DFP, & -0.065130102902216_DFP, & -0.638444188569810_DFP, & -0.048690315425316_DFP, & -0.312865496004874_DFP, & -0.048690315425316_DFP, & -0.312865496004874_DFP, & -0.638444188569810_DFP, & --0.074785022233841_DFP, & -0.087807628716604_DFP, & -0.087807628716604_DFP, & -0.087807628716604_DFP, & -0.026673617804419_DFP, & -0.026673617804419_DFP, & -0.026673617804419_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP, & -0.038556880445128_DFP & -& ], & -& [13, 3])) -!! STRANG10, order 13, degree of precision 7. -!! 1 negative weight, 0 points outside of the triangle, total sum of the -!! weights is 0.5 - -REAL(DFP), DIMENSION(3, 16), PUBLIC, PARAMETER :: triSolin16 = & -& TRANSPOSE(RESHAPE([ & -0.333333333333333_DFP, & -0.459292588292723_DFP, & -0.459292588292723_DFP, & -0.081414823414554_DFP, & -0.170569307751760_DFP, & -0.170569307751760_DFP, & -0.658861384496480_DFP, & -0.050547228317031_DFP, & -0.050547228317031_DFP, & -0.898905543365938_DFP, & -0.263112829634638_DFP, & -0.728492392955404_DFP, & -0.008394777409958_DFP, & -0.263112829634638_DFP, & -0.728492392955404_DFP, & -0.008394777409958_DFP, & -0.333333333333333_DFP, & -0.459292588292723_DFP, & -0.081414823414554_DFP, & -0.459292588292723_DFP, & -0.170569307751760_DFP, & -0.658861384496480_DFP, & -0.170569307751760_DFP, & -0.050547228317031_DFP, & -0.898905543365938_DFP, & -0.050547228317031_DFP, & -0.728492392955404_DFP, & -0.008394777409958_DFP, & -0.263112829634638_DFP, & -0.008394777409958_DFP, & -0.263112829634638_DFP, & -0.728492392955404_DFP, & -0.072157803838894_DFP, & -0.047545817133643_DFP, & -0.047545817133643_DFP, & -0.047545817133643_DFP, & -0.051608685267359_DFP, & -0.051608685267359_DFP, & -0.051608685267359_DFP, & -0.016229248811599_DFP, & -0.016229248811599_DFP, & -0.016229248811599_DFP, & -0.013615157087217_DFP, & -0.013615157087217_DFP, & -0.013615157087217_DFP, & -0.013615157087217_DFP, & -0.013615157087217_DFP, & -0.013615157087217_DFP & -& ], & -& [16, 3])) -!! degree of precision 16. -!! 0 negative weights, 0 points outside of the triangle, total sum of the -!! weights is 0.5 - -REAL(DFP), DIMENSION(3, 19), PUBLIC, PARAMETER :: triSolin19 = & -& TRANSPOSE(RESHAPE([ & -0.3333333333330_DFP, & -0.4896825191990_DFP, & -0.4896825191990_DFP, & -0.0206349616025_DFP, & -0.4370895914930_DFP, & -0.4370895914930_DFP, & -0.1258208170140_DFP, & -0.1882035356190_DFP, & -0.1882035356190_DFP, & -0.6235929287620_DFP, & -0.0447295133945_DFP, & -0.0447295133945_DFP, & -0.9105409732110_DFP, & -0.2219629891610_DFP, & -0.7411985987840_DFP, & -0.0368384120547_DFP, & -0.2219629891610_DFP, & -0.7411985987840_DFP, & -0.0368384120547_DFP, & -0.3333333333333_DFP, & -0.4896825191990_DFP, & -0.0206349616025_DFP, & -0.4896825191990_DFP, & -0.4370895914930_DFP, & -0.1258208170140_DFP, & -0.4370895914930_DFP, & -0.1882035356190_DFP, & -0.6235929287620_DFP, & -0.1882035356190_DFP, & -0.0447295133945_DFP, & -0.9105409732110_DFP, & -0.0447295133945_DFP, & -0.7411985987840_DFP, & -0.0368384120547_DFP, & -0.2219629891610_DFP, & -0.0368384120547_DFP, & -0.2219629891610_DFP, & -0.7411985987840_DFP, & -0.04856789814140_DFP, & -0.01566735011355_DFP, & -0.01566735011355_DFP, & -0.01566735011355_DFP, & -0.03891377050240_DFP, & -0.03891377050240_DFP, & -0.03891377050240_DFP, & -0.03982386946360_DFP, & -0.03982386946360_DFP, & -0.03982386946360_DFP, & -0.01278883782935_DFP, & -0.01278883782935_DFP, & -0.01278883782935_DFP, & -0.02164176968865_DFP, & -0.02164176968865_DFP, & -0.02164176968865_DFP, & -0.02164176968865_DFP, & -0.02164176968865_DFP, & -0.02164176968865_DFP & -], [19, 3])) - -!! TOMS612_19, order 19, degree of precision 9, a rule from ACM TOMS algorithm 612 - - -REAL(DFP), DIMENSION(3, 25), PUBLIC, PARAMETER :: triSolin25 = & -& TRANSPOSE(RESHAPE([ & -0.3333333333330_DFP, & -0.4855776333840_DFP, & -0.4855776333840_DFP, & -0.0288447332327_DFP, & -0.1094815754850_DFP, & -0.1094815754850_DFP, & -0.7810368490300_DFP, & -0.3079398387640_DFP, & -0.5503529418210_DFP, & -0.1417072194150_DFP, & -0.3079398387640_DFP, & -0.5503529418210_DFP, & -0.1417072194150_DFP, & -0.2466725606400_DFP, & -0.7283239045970_DFP, & -0.0250035347627_DFP, & -0.2466725606400_DFP, & -0.7283239045970_DFP, & -0.0250035347627_DFP, & -0.0668032510122_DFP, & -0.9236559335870_DFP, & -0.0095408154003_DFP, & -0.0668032510122_DFP, & -0.9236559335870_DFP, & -0.0095408154003_DFP, & -0.3333333333330_DFP, & -0.4855776333840_DFP, & -0.0288447332327_DFP, & -0.4855776333840_DFP, & -0.1094815754850_DFP, & -0.7810368490300_DFP, & -0.1094815754850_DFP, & -0.5503529418210_DFP, & -0.1417072194150_DFP, & -0.3079398387640_DFP, & -0.1417072194150_DFP, & -0.3079398387640_DFP, & -0.5503529418210_DFP, & -0.7283239045970_DFP, & -0.0250035347627_DFP, & -0.2466725606400_DFP, & -0.0250035347627_DFP, & -0.2466725606400_DFP, & -0.7283239045970_DFP, & -0.9236559335870_DFP, & -0.0095408154003_DFP, & -0.0668032510122_DFP, & -0.0095408154003_DFP, & -0.0668032510122_DFP, & -0.9236559335870_DFP, & -0.04540899519140_DFP, & -0.01836297887825_DFP, & -0.01836297887825_DFP, & -0.01836297887825_DFP, & -0.02266052971775_DFP, & -0.02266052971775_DFP, & -0.02266052971775_DFP, & -0.03637895842270_DFP, & -0.03637895842270_DFP, & -0.03637895842270_DFP, & -0.03637895842270_DFP, & -0.03637895842270_DFP, & -0.03637895842270_DFP, & -0.01416362126555_DFP, & -0.01416362126555_DFP, & -0.01416362126555_DFP, & -0.01416362126555_DFP, & -0.01416362126555_DFP, & -0.01416362126555_DFP, & -0.00471083348185_DFP, & -0.00471083348185_DFP, & -0.00471083348185_DFP, & -0.00471083348185_DFP, & -0.00471083348185_DFP, & -0.00471083348185_DFP & -], [25, 3])) - -REAL(DFP), DIMENSION(3, 27), PUBLIC, PARAMETER :: triSolin27 = & -& TRANSPOSE(RESHAPE([ & -+0.5346110482710_DFP, & --0.0692220965415_DFP, & -+0.5346110482710_DFP, & -+0.3989693029660_DFP, & -+0.2020613940680_DFP, & -+0.3989693029660_DFP, & -+0.2033099004310_DFP, & -+0.5933801991370_DFP, & -+0.2033099004310_DFP, & -+0.1193509122830_DFP, & -+0.7612981754350_DFP, & -+0.1193509122830_DFP, & -+0.0323649481113_DFP, & -+0.9352701037770_DFP, & -+0.0323649481113_DFP, & -+0.5932012134280_DFP, & -+0.0501781383105_DFP, & -+0.3566206482610_DFP, & -+0.0501781383105_DFP, & -+0.3566206482610_DFP, & -+0.5932012134280_DFP, & -+0.8074890031600_DFP, & -+0.0210220165362_DFP, & -+0.1714889803040_DFP, & -+0.0210220165362_DFP, & -+0.1714889803040_DFP, & -+0.8074890031600_DFP, & -+0.5346110482710_DFP, & -+0.5346110482710_DFP, & --0.0692220965415_DFP, & -+0.3989693029660_DFP, & -+0.3989693029660_DFP, & -+0.2020613940680_DFP, & -+0.2033099004310_DFP, & -+0.2033099004310_DFP, & -+0.5933801991370_DFP, & -+0.1193509122830_DFP, & -+0.1193509122830_DFP, & -+0.7612981754350_DFP, & -+0.0323649481113_DFP, & -+0.0323649481113_DFP, & -+0.9352701037770_DFP, & -+0.3566206482610_DFP, & -+0.5932012134280_DFP, & -+0.0501781383105_DFP, & -+0.3566206482610_DFP, & -+0.5932012134280_DFP, & -+0.0501781383105_DFP, & -+0.1714889803040_DFP, & -+0.8074890031600_DFP, & -+0.0210220165362_DFP, & -+0.1714889803040_DFP, & -+0.8074890031600_DFP, & -+0.0210220165362_DFP, & -0.00046350316448_DFP, & -0.00046350316448_DFP, & -0.00046350316448_DFP, & -0.03857476745740_DFP, & -0.03857476745740_DFP, & -0.03857476745740_DFP, & -0.02966148869040_DFP, & -0.02966148869040_DFP, & -0.02966148869040_DFP, & -0.01809227025170_DFP, & -0.01809227025170_DFP, & -0.01809227025170_DFP, & -0.00682986550135_DFP, & -0.00682986550135_DFP, & -0.00682986550135_DFP, & -0.02616855598110_DFP, & -0.02616855598110_DFP, & -0.02616855598110_DFP, & -0.02616855598110_DFP, & -0.02616855598110_DFP, & -0.02616855598110_DFP, & -0.01035382981955_DFP, & -0.01035382981955_DFP, & -0.01035382981955_DFP, & -0.01035382981955_DFP, & -0.01035382981955_DFP, & -0.01035382981955_DFP & -], [27, 3])) - -REAL(DFP), DIMENSION(3, 33), PUBLIC, PARAMETER :: triSolin33 = & -& TRANSPOSE(RESHAPE([ & -0.4882173897740_DFP, & -0.4882173897740_DFP, & -0.0235652204524_DFP, & -0.4397243922940_DFP, & -0.4397243922940_DFP, & -0.1205512154110_DFP, & -0.2712103850120_DFP, & -0.2712103850120_DFP, & -0.4575792299760_DFP, & -0.1275761455420_DFP, & -0.1275761455420_DFP, & -0.7448477089170_DFP, & -0.0213173504532_DFP, & -0.0213173504532_DFP, & -0.9573652990940_DFP, & -0.2757132696860_DFP, & -0.6089432357800_DFP, & -0.1153434945350_DFP, & -0.2757132696860_DFP, & -0.6089432357800_DFP, & -0.1153434945350_DFP, & -0.2813255809900_DFP, & -0.6958360867880_DFP, & -0.0228383322223_DFP, & -0.2813255809900_DFP, & -0.6958360867880_DFP, & -0.0228383322223_DFP, & -0.1162519159080_DFP, & -0.8580140335440_DFP, & -0.0257340505483_DFP, & -0.1162519159080_DFP, & -0.8580140335440_DFP, & -0.0257340505483_DFP, & -0.4882173897740_DFP, & -0.0235652204524_DFP, & -0.4882173897740_DFP, & -0.4397243922940_DFP, & -0.1205512154110_DFP, & -0.4397243922940_DFP, & -0.2712103850120_DFP, & -0.4575792299760_DFP, & -0.2712103850120_DFP, & -0.1275761455420_DFP, & -0.7448477089170_DFP, & -0.1275761455420_DFP, & -0.0213173504532_DFP, & -0.9573652990940_DFP, & -0.0213173504532_DFP, & -0.6089432357800_DFP, & -0.1153434945350_DFP, & -0.2757132696860_DFP, & -0.1153434945350_DFP, & -0.2757132696860_DFP, & -0.6089432357800_DFP, & -0.6958360867880_DFP, & -0.0228383322223_DFP, & -0.2813255809900_DFP, & -0.0228383322223_DFP, & -0.2813255809900_DFP, & -0.6958360867880_DFP, & -0.8580140335440_DFP, & -0.0257340505483_DFP, & -0.1162519159080_DFP, & -0.0257340505483_DFP, & -0.1162519159080_DFP, & -0.8580140335440_DFP, & -0.01286553322025_DFP, & -0.01286553322025_DFP, & -0.01286553322025_DFP, & -0.02184627226900_DFP, & -0.02184627226900_DFP, & -0.02184627226900_DFP, & -0.03142911210895_DFP, & -0.03142911210895_DFP, & -0.03142911210895_DFP, & -0.01739805646535_DFP, & -0.01739805646535_DFP, & -0.01739805646535_DFP, & -0.00308313052578_DFP, & -0.00308313052578_DFP, & -0.00308313052578_DFP, & -0.02018577888320_DFP, & -0.02018577888320_DFP, & -0.02018577888320_DFP, & -0.02018577888320_DFP, & -0.02018577888320_DFP, & -0.02018577888320_DFP, & -0.01117838660115_DFP, & -0.01117838660115_DFP, & -0.01117838660115_DFP, & -0.01117838660115_DFP, & -0.01117838660115_DFP, & -0.01117838660115_DFP, & -0.00865811555435_DFP, & -0.00865811555435_DFP, & -0.00865811555435_DFP, & -0.00865811555435_DFP, & -0.00865811555435_DFP, & -0.00865811555435_DFP & -], [33, 3])) - - -REAL(DFP), DIMENSION(3, 37), PUBLIC, PARAMETER :: triSolin37 = & -& TRANSPOSE(RESHAPE([ & -0.33333333333330_DFP, & -0.49504818494000_DFP, & -0.00990363012059_DFP, & -0.49504818494000_DFP, & -0.46871663511000_DFP, & -0.06256672978090_DFP, & -0.46871663511000_DFP, & -0.41452133680100_DFP, & -0.17095732639700_DFP, & -0.41452133680100_DFP, & -0.22939957204300_DFP, & -0.54120085591400_DFP, & -0.22939957204300_DFP, & -0.11442449519600_DFP, & -0.77115100960700_DFP, & -0.11442449519600_DFP, & -0.02481139136350_DFP, & -0.95037721727300_DFP, & -0.02481139136350_DFP, & -0.63635117456200_DFP, & -0.09485382837960_DFP, & -0.26879499705900_DFP, & -0.09485382837960_DFP, & -0.26879499705900_DFP, & -0.63635117456200_DFP, & -0.69016915998700_DFP, & -0.01810077327880_DFP, & -0.29173006673400_DFP, & -0.01810077327880_DFP, & -0.29173006673400_DFP, & -0.69016915998700_DFP, & -0.85140953783400_DFP, & -0.02223307667410_DFP, & -0.12635738549200_DFP, & -0.02223307667410_DFP, & -0.12635738549200_DFP, & -0.85140953783400_DFP, & -0.33333333333330_DFP, & -0.49504818494000_DFP, & -0.49504818494000_DFP, & -0.00990363012059_DFP, & -0.46871663511000_DFP, & -0.46871663511000_DFP, & -0.06256672978090_DFP, & -0.41452133680100_DFP, & -0.41452133680100_DFP, & -0.17095732639700_DFP, & -0.22939957204300_DFP, & -0.22939957204300_DFP, & -0.54120085591400_DFP, & -0.11442449519600_DFP, & -0.11442449519600_DFP, & -0.77115100960700_DFP, & -0.02481139136350_DFP, & -0.02481139136350_DFP, & -0.95037721727300_DFP, & -0.26879499705900_DFP, & -0.63635117456200_DFP, & -0.09485382837960_DFP, & -0.26879499705900_DFP, & -0.63635117456200_DFP, & -0.09485382837960_DFP, & -0.29173006673400_DFP, & -0.69016915998700_DFP, & -0.01810077327880_DFP, & -0.29173006673400_DFP, & -0.69016915998700_DFP, & -0.01810077327880_DFP, & -0.12635738549200_DFP, & -0.85140953783400_DFP, & -0.02223307667410_DFP, & -0.12635738549200_DFP, & -0.85140953783400_DFP, & -0.02223307667410_DFP, & -0.026260461700400_DFP, & -0.005640072604650_DFP, & -0.005640072604650_DFP, & -0.005640072604650_DFP, & -0.015711759181250_DFP, & -0.015711759181250_DFP, & -0.015711759181250_DFP, & -0.023536251252100_DFP, & -0.023536251252100_DFP, & -0.023536251252100_DFP, & -0.023681793268200_DFP, & -0.023681793268200_DFP, & -0.023681793268200_DFP, & -0.015583764522900_DFP, & -0.015583764522900_DFP, & -0.015583764522900_DFP, & -0.003987885732535_DFP, & -0.003987885732535_DFP, & -0.003987885732535_DFP, & -0.018424201364350_DFP, & -0.018424201364350_DFP, & -0.018424201364350_DFP, & -0.018424201364350_DFP, & -0.018424201364350_DFP, & -0.018424201364350_DFP, & -0.008700731651900_DFP, & -0.008700731651900_DFP, & -0.008700731651900_DFP, & -0.008700731651900_DFP, & -0.008700731651900_DFP, & -0.008700731651900_DFP, & -0.007760893419500_DFP, & -0.007760893419500_DFP, & -0.007760893419500_DFP, & -0.007760893419500_DFP, & -0.007760893419500_DFP, & -0.007760893419500_DFP & -], [37, 3])) - - -REAL(DFP), DIMENSION(3, 42), PUBLIC, PARAMETER :: triSolin42 = & -& TRANSPOSE(RESHAPE([ & -0.48896391036200_DFP, & -0.02207217927560_DFP, & -0.48896391036200_DFP, & -0.41764471934000_DFP, & -0.16471056131900_DFP, & -0.41764471934000_DFP, & -0.27347752830900_DFP, & -0.45304494338200_DFP, & -0.27347752830900_DFP, & -0.17720553241300_DFP, & -0.64558893517500_DFP, & -0.17720553241300_DFP, & -0.06179988309090_DFP, & -0.87640023381800_DFP, & -0.06179988309090_DFP, & -0.01939096124870_DFP, & -0.96121807750300_DFP, & -0.01939096124870_DFP, & -0.77060855477500_DFP, & -0.05712475740360_DFP, & -0.17226668782100_DFP, & -0.05712475740360_DFP, & -0.17226668782100_DFP, & -0.77060855477500_DFP, & -0.57022229084700_DFP, & -0.09291624935700_DFP, & -0.33686145979600_DFP, & -0.09291624935700_DFP, & -0.33686145979600_DFP, & -0.57022229084700_DFP, & -0.68698016780800_DFP, & -0.01464695005570_DFP, & -0.29837288213600_DFP, & -0.01464695005570_DFP, & -0.29837288213600_DFP, & -0.68698016780800_DFP, & -0.87975717137000_DFP, & -0.00126833093287_DFP, & -0.11897449769700_DFP, & -0.00126833093287_DFP, & -0.11897449769700_DFP, & -0.87975717137000_DFP, & -0.48896391036200_DFP, & -0.48896391036200_DFP, & -0.02207217927560_DFP, & -0.41764471934000_DFP, & -0.41764471934000_DFP, & -0.16471056131900_DFP, & -0.27347752830900_DFP, & -0.27347752830900_DFP, & -0.45304494338200_DFP, & -0.17720553241300_DFP, & -0.17720553241300_DFP, & -0.64558893517500_DFP, & -0.06179988309090_DFP, & -0.06179988309090_DFP, & -0.87640023381800_DFP, & -0.01939096124870_DFP, & -0.01939096124870_DFP, & -0.96121807750300_DFP, & -0.17226668782100_DFP, & -0.77060855477500_DFP, & -0.05712475740360_DFP, & -0.17226668782100_DFP, & -0.77060855477500_DFP, & -0.05712475740360_DFP, & -0.33686145979600_DFP, & -0.57022229084700_DFP, & -0.09291624935700_DFP, & -0.33686145979600_DFP, & -0.57022229084700_DFP, & -0.09291624935700_DFP, & -0.29837288213600_DFP, & -0.68698016780800_DFP, & -0.01464695005570_DFP, & -0.29837288213600_DFP, & -0.68698016780800_DFP, & -0.01464695005570_DFP, & -0.11897449769700_DFP, & -0.87975717137000_DFP, & -0.00126833093287_DFP, & -0.11897449769700_DFP, & -0.87975717137000_DFP, & -0.00126833093287_DFP, & -0.01094179068470_DFP, & -0.01094179068470_DFP, & -0.01094179068470_DFP, & -0.01639417677205_DFP, & -0.01639417677205_DFP, & -0.01639417677205_DFP, & -0.02588705225365_DFP, & -0.02588705225365_DFP, & -0.02588705225365_DFP, & -0.02108129436850_DFP, & -0.02108129436850_DFP, & -0.02108129436850_DFP, & -0.00721684983490_DFP, & -0.00721684983490_DFP, & -0.00721684983490_DFP, & -0.00246170180120_DFP, & -0.00246170180120_DFP, & -0.00246170180120_DFP, & -0.01233287660630_DFP, & -0.01233287660630_DFP, & -0.01233287660630_DFP, & -0.01233287660630_DFP, & -0.01233287660630_DFP, & -0.01233287660630_DFP, & -0.01928575539355_DFP, & -0.01928575539355_DFP, & -0.01928575539355_DFP, & -0.01928575539355_DFP, & -0.01928575539355_DFP, & -0.01928575539355_DFP, & -0.00721815405675_DFP, & -0.00721815405675_DFP, & -0.00721815405675_DFP, & -0.00721815405675_DFP, & -0.00721815405675_DFP, & -0.00721815405675_DFP, & -0.00250511441925_DFP, & -0.00250511441925_DFP, & -0.00250511441925_DFP, & -0.00250511441925_DFP, & -0.00250511441925_DFP, & -0.00250511441925_DFP & -], [42, 3])) - - -REAL(DFP), DIMENSION(3, 48), PUBLIC, PARAMETER :: triSolin48 = & -& TRANSPOSE(RESHAPE([ & -+0.5069729168580_DFP, & --0.0139458337165_DFP, & -+0.5069729168580_DFP, & -+0.4314063542830_DFP, & -+0.1371872914340_DFP, & -+0.4314063542830_DFP, & -+0.2776936448470_DFP, & -+0.4446127103060_DFP, & -+0.2776936448470_DFP, & -+0.1264648910410_DFP, & -+0.7470702179170_DFP, & -+0.1264648910410_DFP, & -+0.0708083859747_DFP, & -+0.8583832280510_DFP, & -+0.0708083859747_DFP, & -+0.0189651702411_DFP, & -+0.9620696595180_DFP, & -+0.0189651702411_DFP, & -+0.6049544668930_DFP, & -+0.1337341619670_DFP, & -+0.2613113711400_DFP, & -+0.1337341619670_DFP, & -+0.2613113711400_DFP, & -+0.6049544668930_DFP, & -+0.5755865555130_DFP, & -+0.0363666773969_DFP, & -+0.3880467670900_DFP, & -+0.0363666773969_DFP, & -+0.3880467670900_DFP, & -+0.5755865555130_DFP, & -+0.7244626630770_DFP, & --0.0101748831266_DFP, & -+0.2857122200500_DFP, & --0.0101748831266_DFP, & -+0.2857122200500_DFP, & -+0.7244626630770_DFP, & -+0.7475564660520_DFP, & -+0.0368438698759_DFP, & -+0.2155996640720_DFP, & -+0.0368438698759_DFP, & -+0.2155996640720_DFP, & -+0.7475564660520_DFP, & -+0.8839645740920_DFP, & -+0.0124598093312_DFP, & -+0.1035756165760_DFP, & -+0.0124598093312_DFP, & -+0.1035756165760_DFP, & -+0.8839645740920_DFP, & -+0.5069729168580_DFP, & -+0.5069729168580_DFP, & --0.0139458337165_DFP, & -+0.4314063542830_DFP, & -+0.4314063542830_DFP, & -+0.1371872914340_DFP, & -+0.2776936448470_DFP, & -+0.2776936448470_DFP, & -+0.4446127103060_DFP, & -+0.1264648910410_DFP, & -+0.1264648910410_DFP, & -+0.7470702179170_DFP, & -+0.0708083859747_DFP, & -+0.0708083859747_DFP, & -+0.8583832280510_DFP, & -+0.0189651702411_DFP, & -+0.0189651702411_DFP, & -+0.9620696595180_DFP, & -+0.2613113711400_DFP, & -+0.6049544668930_DFP, & -+0.1337341619670_DFP, & -+0.2613113711400_DFP, & -+0.6049544668930_DFP, & -+0.1337341619670_DFP, & -+0.3880467670900_DFP, & -+0.5755865555130_DFP, & -+0.0363666773969_DFP, & -+0.3880467670900_DFP, & -+0.5755865555130_DFP, & -+0.0363666773969_DFP, & -+0.2857122200500_DFP, & -+0.7244626630770_DFP, & --0.0101748831266_DFP, & -+0.2857122200500_DFP, & -+0.7244626630770_DFP, & --0.0101748831266_DFP, & -+0.2155996640720_DFP, & -+0.7475564660520_DFP, & -+0.0368438698759_DFP, & -+0.2155996640720_DFP, & -+0.7475564660520_DFP, & -+0.0368438698759_DFP, & -+0.1035756165760_DFP, & -+0.8839645740920_DFP, & -+0.0124598093312_DFP, & -+0.1035756165760_DFP, & -+0.8839645740920_DFP, & -+0.0124598093312_DFP, & -0.000958437821425_DFP, & -0.000958437821425_DFP, & -0.000958437821425_DFP, & -0.022124513635550_DFP, & -0.022124513635550_DFP, & -0.022124513635550_DFP, & -0.025593274359450_DFP, & -0.025593274359450_DFP, & -0.025593274359450_DFP, & -0.011843867935350_DFP, & -0.011843867935350_DFP, & -0.011843867935350_DFP, & -0.006644887845000_DFP, & -0.006644887845000_DFP, & -0.006644887845000_DFP, & -0.002374458304095_DFP, & -0.002374458304095_DFP, & -0.002374458304095_DFP, & -0.019275036299800_DFP, & -0.019275036299800_DFP, & -0.019275036299800_DFP, & -0.019275036299800_DFP, & -0.019275036299800_DFP, & -0.019275036299800_DFP, & -0.013607907160300_DFP, & -0.013607907160300_DFP, & -0.013607907160300_DFP, & -0.013607907160300_DFP, & -0.013607907160300_DFP, & -0.013607907160300_DFP, & -0.001091038683400_DFP, & -0.001091038683400_DFP, & -0.001091038683400_DFP, & -0.001091038683400_DFP, & -0.001091038683400_DFP, & -0.001091038683400_DFP, & -0.010752659923850_DFP, & -0.010752659923850_DFP, & -0.010752659923850_DFP, & -0.010752659923850_DFP, & -0.010752659923850_DFP, & -0.010752659923850_DFP, & -0.003836971315525_DFP, & -0.003836971315525_DFP, & -0.003836971315525_DFP, & -0.003836971315525_DFP, & -0.003836971315525_DFP, & -0.003836971315525_DFP & -], [48, 3])) - -REAL(DFP), DIMENSION(3, 52), PUBLIC, PARAMETER :: triSolin52 = & -& TRANSPOSE(RESHAPE([ & -+0.33333333333330_DFP, & -+0.49738054194800_DFP, & -+0.00523891610312_DFP, & -+0.49738054194800_DFP, & -+0.41346943854900_DFP, & -+0.17306112290100_DFP, & -+0.41346943854900_DFP, & -+0.47045859906700_DFP, & -+0.05908280186600_DFP, & -+0.47045859906700_DFP, & -+0.24055374997000_DFP, & -+0.51889250006100_DFP, & -+0.24055374997000_DFP, & -+0.14796579422300_DFP, & -+0.70406841155500_DFP, & -+0.14796579422300_DFP, & -+0.07546518765750_DFP, & -+0.84906962468500_DFP, & -+0.07546518765750_DFP, & -+0.01659640262300_DFP, & -+0.96680719475400_DFP, & -+0.01659640262300_DFP, & -+0.59986871117500_DFP, & -+0.10357569224500_DFP, & -+0.29655559658000_DFP, & -+0.10357569224500_DFP, & -+0.29655559658000_DFP, & -+0.59986871117500_DFP, & -+0.64219352494200_DFP, & -+0.02008341165540_DFP, & -+0.33772306340300_DFP, & -+0.02008341165540_DFP, & -+0.33772306340300_DFP, & -+0.64219352494200_DFP, & -+0.79959272097100_DFP, & --0.00434100261414_DFP, & -+0.20474828164300_DFP, & --0.00434100261414_DFP, & -+0.20474828164300_DFP, & -+0.79959272097100_DFP, & -+0.76869972140100_DFP, & -+0.04194178646800_DFP, & -+0.18935849213100_DFP, & -+0.04194178646800_DFP, & -+0.18935849213100_DFP, & -+0.76869972140100_DFP, & -+0.90039906408700_DFP, & -+0.01431732023070_DFP, & -+0.08528361568270_DFP, & -+0.01431732023070_DFP, & -+0.08528361568270_DFP, & -+0.90039906408700_DFP, & -+0.33333333333330_DFP, & -+0.49738054194800_DFP, & -+0.49738054194800_DFP, & -+0.00523891610312_DFP, & -+0.41346943854900_DFP, & -+0.41346943854900_DFP, & -+0.17306112290100_DFP, & -+0.47045859906700_DFP, & -+0.47045859906700_DFP, & -+0.05908280186600_DFP, & -+0.24055374997000_DFP, & -+0.24055374997000_DFP, & -+0.51889250006100_DFP, & -+0.14796579422300_DFP, & -+0.14796579422300_DFP, & -+0.70406841155500_DFP, & -+0.07546518765750_DFP, & -+0.07546518765750_DFP, & -+0.84906962468500_DFP, & -+0.01659640262300_DFP, & -+0.01659640262300_DFP, & -+0.96680719475400_DFP, & -+0.29655559658000_DFP, & -+0.59986871117500_DFP, & -+0.10357569224500_DFP, & -+0.29655559658000_DFP, & -+0.59986871117500_DFP, & -+0.10357569224500_DFP, & -+0.33772306340300_DFP, & -+0.64219352494200_DFP, & -+0.02008341165540_DFP, & -+0.33772306340300_DFP, & -+0.64219352494200_DFP, & -+0.02008341165540_DFP, & -+0.20474828164300_DFP, & -+0.79959272097100_DFP, & --0.00434100261414_DFP, & -+0.20474828164300_DFP, & -+0.79959272097100_DFP, & --0.00434100261414_DFP, & -+0.18935849213100_DFP, & -+0.76869972140100_DFP, & -+0.04194178646800_DFP, & -+0.18935849213100_DFP, & -+0.76869972140100_DFP, & -+0.04194178646800_DFP, & -+0.08528361568270_DFP, & -+0.90039906408700_DFP, & -+0.01431732023070_DFP, & -+0.08528361568270_DFP, & -+0.90039906408700_DFP, & -+0.01431732023070_DFP, & -0.023437848713800_DFP, & -0.003202939289290_DFP, & -0.003202939289290_DFP, & -0.003202939289290_DFP, & -0.020855148369700_DFP, & -0.020855148369700_DFP, & -0.020855148369700_DFP, & -0.013445742125050_DFP, & -0.013445742125050_DFP, & -0.013445742125050_DFP, & -0.021066261380800_DFP, & -0.021066261380800_DFP, & -0.021066261380800_DFP, & -0.015000133421400_DFP, & -0.015000133421400_DFP, & -0.015000133421400_DFP, & -0.007100049462500_DFP, & -0.007100049462500_DFP, & -0.007100049462500_DFP, & -0.001791231175635_DFP, & -0.001791231175635_DFP, & -0.001791231175635_DFP, & -0.016386573730300_DFP, & -0.016386573730300_DFP, & -0.016386573730300_DFP, & -0.016386573730300_DFP, & -0.016386573730300_DFP, & -0.016386573730300_DFP, & -0.007649153124200_DFP, & -0.007649153124200_DFP, & -0.007649153124200_DFP, & -0.007649153124200_DFP, & -0.007649153124200_DFP, & -0.007649153124200_DFP, & -0.001193122096420_DFP, & -0.001193122096420_DFP, & -0.001193122096420_DFP, & -0.001193122096420_DFP, & -0.001193122096420_DFP, & -0.001193122096420_DFP, & -0.009542396377950_DFP, & -0.009542396377950_DFP, & -0.009542396377950_DFP, & -0.009542396377950_DFP, & -0.009542396377950_DFP, & -0.009542396377950_DFP, & -0.003425027273270_DFP, & -0.003425027273270_DFP, & -0.003425027273270_DFP, & -0.003425027273270_DFP, & -0.003425027273270_DFP, & -0.003425027273270_DFP & -], [52, 3])) - -REAL(DFP), DIMENSION(3, 61), PUBLIC, PARAMETER :: triSolin61 = & -& TRANSPOSE(RESHAPE([ & -0.33333333333330_DFP, & -0.49717054055700_DFP, & -0.00565891888645_DFP, & -0.49717054055700_DFP, & -0.48217632262500_DFP, & -0.03564735475080_DFP, & -0.48217632262500_DFP, & -0.45023996902100_DFP, & -0.09952006195840_DFP, & -0.45023996902100_DFP, & -0.40026623937700_DFP, & -0.19946752124500_DFP, & -0.40026623937700_DFP, & -0.25214126797100_DFP, & -0.49571746405800_DFP, & -0.25214126797100_DFP, & -0.16204700465800_DFP, & -0.67590599068300_DFP, & -0.16204700465800_DFP, & -0.07587588226070_DFP, & -0.84824823547900_DFP, & -0.07587588226070_DFP, & -0.01565472696780_DFP, & -0.96869054606400_DFP, & -0.01565472696780_DFP, & -0.65549320380900_DFP, & -0.01018692882690_DFP, & -0.33431986736400_DFP, & -0.01018692882690_DFP, & -0.33431986736400_DFP, & -0.65549320380900_DFP, & -0.57233759053200_DFP, & -0.13544087167100_DFP, & -0.29222153779700_DFP, & -0.13544087167100_DFP, & -0.29222153779700_DFP, & -0.57233759053200_DFP, & -0.62600119028600_DFP, & -0.05442392429060_DFP, & -0.31957488542300_DFP, & -0.05442392429060_DFP, & -0.31957488542300_DFP, & -0.62600119028600_DFP, & -0.79642721497400_DFP, & -0.01286856083360_DFP, & -0.19070422419200_DFP, & -0.01286856083360_DFP, & -0.19070422419200_DFP, & -0.79642721497400_DFP, & -0.75235100593800_DFP, & -0.06716578241350_DFP, & -0.18048321164900_DFP, & -0.06716578241350_DFP, & -0.18048321164900_DFP, & -0.75235100593800_DFP, & -0.90462550409600_DFP, & -0.01466318222480_DFP, & -0.08071131367960_DFP, & -0.01466318222480_DFP, & -0.08071131367960_DFP, & -0.90462550409600_DFP, & -0.33333333333330_DFP, & -0.49717054055700_DFP, & -0.49717054055700_DFP, & -0.00565891888645_DFP, & -0.48217632262500_DFP, & -0.48217632262500_DFP, & -0.03564735475080_DFP, & -0.45023996902100_DFP, & -0.45023996902100_DFP, & -0.09952006195840_DFP, & -0.40026623937700_DFP, & -0.40026623937700_DFP, & -0.19946752124500_DFP, & -0.25214126797100_DFP, & -0.25214126797100_DFP, & -0.49571746405800_DFP, & -0.16204700465800_DFP, & -0.16204700465800_DFP, & -0.67590599068300_DFP, & -0.07587588226070_DFP, & -0.07587588226070_DFP, & -0.84824823547900_DFP, & -0.01565472696780_DFP, & -0.01565472696780_DFP, & -0.96869054606400_DFP, & -0.33431986736400_DFP, & -0.65549320380900_DFP, & -0.01018692882690_DFP, & -0.33431986736400_DFP, & -0.65549320380900_DFP, & -0.01018692882690_DFP, & -0.29222153779700_DFP, & -0.57233759053200_DFP, & -0.13544087167100_DFP, & -0.29222153779700_DFP, & -0.57233759053200_DFP, & -0.13544087167100_DFP, & -0.31957488542300_DFP, & -0.62600119028600_DFP, & -0.05442392429060_DFP, & -0.31957488542300_DFP, & -0.62600119028600_DFP, & -0.05442392429060_DFP, & -0.19070422419200_DFP, & -0.79642721497400_DFP, & -0.01286856083360_DFP, & -0.19070422419200_DFP, & -0.79642721497400_DFP, & -0.01286856083360_DFP, & -0.18048321164900_DFP, & -0.75235100593800_DFP, & -0.06716578241350_DFP, & -0.18048321164900_DFP, & -0.75235100593800_DFP, & -0.06716578241350_DFP, & -0.08071131367960_DFP, & -0.90462550409600_DFP, & -0.01466318222480_DFP, & -0.08071131367960_DFP, & -0.90462550409600_DFP, & -0.01466318222480_DFP, & -0.016718599645400_DFP, & -0.002546707720255_DFP, & -0.002546707720255_DFP, & -0.002546707720255_DFP, & -0.007335432263800_DFP, & -0.007335432263800_DFP, & -0.007335432263800_DFP, & -0.012175439176850_DFP, & -0.012175439176850_DFP, & -0.012175439176850_DFP, & -0.015553775434500_DFP, & -0.015553775434500_DFP, & -0.015553775434500_DFP, & -0.015628555609300_DFP, & -0.015628555609300_DFP, & -0.015628555609300_DFP, & -0.012407827169850_DFP, & -0.012407827169850_DFP, & -0.012407827169850_DFP, & -0.007028036535300_DFP, & -0.007028036535300_DFP, & -0.007028036535300_DFP, & -0.001597338086890_DFP, & -0.001597338086890_DFP, & -0.001597338086890_DFP, & -0.004059827659495_DFP, & -0.004059827659495_DFP, & -0.004059827659495_DFP, & -0.004059827659495_DFP, & -0.004059827659495_DFP, & -0.004059827659495_DFP, & -0.013402871141600_DFP, & -0.013402871141600_DFP, & -0.013402871141600_DFP, & -0.013402871141600_DFP, & -0.013402871141600_DFP, & -0.013402871141600_DFP, & -0.009229996605400_DFP, & -0.009229996605400_DFP, & -0.009229996605400_DFP, & -0.009229996605400_DFP, & -0.009229996605400_DFP, & -0.009229996605400_DFP, & -0.004238434267165_DFP, & -0.004238434267165_DFP, & -0.004238434267165_DFP, & -0.004238434267165_DFP, & -0.004238434267165_DFP, & -0.004238434267165_DFP, & -0.009146398385000_DFP, & -0.009146398385000_DFP, & -0.009146398385000_DFP, & -0.009146398385000_DFP, & -0.009146398385000_DFP, & -0.009146398385000_DFP, & -0.003332816002085_DFP, & -0.003332816002085_DFP, & -0.003332816002085_DFP, & -0.003332816002085_DFP, & -0.003332816002085_DFP, & -0.003332816002085_DFP & -], [61, 3])) - - -REAL(DFP), DIMENSION(3, 70), PUBLIC, PARAMETER :: triSolin70 = & -& TRANSPOSE(RESHAPE([ & -+0.33333333333330_DFP, & -+0.49334480863100_DFP, & -+0.01331038273820_DFP, & -+0.49334480863100_DFP, & -+0.46921059424200_DFP, & -+0.06157881151610_DFP, & -+0.46921059424200_DFP, & -+0.43628139588700_DFP, & -+0.12743720822600_DFP, & -+0.43628139588700_DFP, & -+0.39484617067300_DFP, & -+0.21030765865300_DFP, & -+0.39484617067300_DFP, & -+0.24979456880300_DFP, & -+0.50041086239400_DFP, & -+0.24979456880300_DFP, & -+0.16143219374400_DFP, & -+0.67713561251200_DFP, & -+0.16143219374400_DFP, & -+0.07659822748540_DFP, & -+0.84680354502900_DFP, & -+0.07659822748540_DFP, & -+0.02425243935350_DFP, & -+0.95149512129300_DFP, & -+0.02425243935350_DFP, & -+0.04314636721700_DFP, & -+0.91370726556600_DFP, & -+0.04314636721700_DFP, & -+0.63265796885700_DFP, & -+0.00843053620242_DFP, & -+0.35891149494100_DFP, & -+0.00843053620242_DFP, & -+0.35891149494100_DFP, & -+0.63265796885700_DFP, & -+0.57441097151100_DFP, & -+0.13118655173700_DFP, & -+0.29440247675200_DFP, & -+0.13118655173700_DFP, & -+0.29440247675200_DFP, & -+0.57441097151100_DFP, & -+0.62477904679300_DFP, & -+0.05020315156570_DFP, & -+0.32501780164200_DFP, & -+0.05020315156570_DFP, & -+0.32501780164200_DFP, & -+0.62477904679300_DFP, & -+0.74893317652300_DFP, & -+0.06632926381090_DFP, & -+0.18473755966600_DFP, & -+0.06632926381090_DFP, & -+0.18473755966600_DFP, & -+0.74893317652300_DFP, & -+0.76920700542000_DFP, & -+0.01199619456620_DFP, & -+0.21879680001300_DFP, & -+0.01199619456620_DFP, & -+0.21879680001300_DFP, & -+0.76920700542000_DFP, & -+0.88396230227300_DFP, & -+0.01485810059010_DFP, & -+0.10117959713600_DFP, & -+0.01485810059010_DFP, & -+0.10117959713600_DFP, & -+0.88396230227300_DFP, & -+1.01434726001000_DFP, & --0.03522201528790_DFP, & -+0.02087475528260_DFP, & --0.03522201528790_DFP, & -+0.02087475528260_DFP, & -+1.01434726001000_DFP, & -+0.33333333333330_DFP, & -+0.49334480863100_DFP, & -+0.49334480863100_DFP, & -+0.01331038273820_DFP, & -+0.46921059424200_DFP, & -+0.46921059424200_DFP, & -+0.06157881151610_DFP, & -+0.43628139588700_DFP, & -+0.43628139588700_DFP, & -+0.12743720822600_DFP, & -+0.39484617067300_DFP, & -+0.39484617067300_DFP, & -+0.21030765865300_DFP, & -+0.24979456880300_DFP, & -+0.24979456880300_DFP, & -+0.50041086239400_DFP, & -+0.16143219374400_DFP, & -+0.16143219374400_DFP, & -+0.67713561251200_DFP, & -+0.07659822748540_DFP, & -+0.07659822748540_DFP, & -+0.84680354502900_DFP, & -+0.02425243935350_DFP, & -+0.02425243935350_DFP, & -+0.95149512129300_DFP, & -+0.04314636721700_DFP, & -+0.04314636721700_DFP, & -+0.91370726556600_DFP, & -+0.35891149494100_DFP, & -+0.63265796885700_DFP, & -+0.00843053620242_DFP, & -+0.35891149494100_DFP, & -+0.63265796885700_DFP, & -+0.00843053620242_DFP, & -+0.29440247675200_DFP, & -+0.57441097151100_DFP, & -+0.13118655173700_DFP, & -+0.29440247675200_DFP, & -+0.57441097151100_DFP, & -+0.13118655173700_DFP, & -+0.32501780164200_DFP, & -+0.62477904679300_DFP, & -+0.05020315156570_DFP, & -+0.32501780164200_DFP, & -+0.62477904679300_DFP, & -+0.05020315156570_DFP, & -+0.18473755966600_DFP, & -+0.74893317652300_DFP, & -+0.06632926381090_DFP, & -+0.18473755966600_DFP, & -+0.74893317652300_DFP, & -+0.06632926381090_DFP, & -+0.21879680001300_DFP, & -+0.76920700542000_DFP, & -+0.01199619456620_DFP, & -+0.21879680001300_DFP, & -+0.76920700542000_DFP, & -+0.01199619456620_DFP, & -+0.10117959713600_DFP, & -+0.88396230227300_DFP, & -+0.01485810059010_DFP, & -+0.10117959713600_DFP, & -+0.88396230227300_DFP, & -+0.01485810059010_DFP, & -+0.02087475528260_DFP, & -+1.01434726001000_DFP, & --0.03522201528790_DFP, & -+0.02087475528260_DFP, & -+1.01434726001000_DFP, & --0.03522201528790_DFP, & -+0.015404969968800_DFP, & -+0.004536218339700_DFP, & -+0.004536218339700_DFP, & -+0.004536218339700_DFP, & -+0.009380658469800_DFP, & -+0.009380658469800_DFP, & -+0.009380658469800_DFP, & -+0.009720548992750_DFP, & -+0.009720548992750_DFP, & -+0.009720548992750_DFP, & -+0.013876974305400_DFP, & -+0.013876974305400_DFP, & -+0.013876974305400_DFP, & -+0.016128112675750_DFP, & -+0.016128112675750_DFP, & -+0.016128112675750_DFP, & -+0.012537016308450_DFP, & -+0.012537016308450_DFP, & -+0.012537016308450_DFP, & -+0.007635963985900_DFP, & -+0.007635963985900_DFP, & -+0.007635963985900_DFP, & -+0.003396961011480_DFP, & -+0.003396961011480_DFP, & -+0.003396961011480_DFP, & --0.001111549364960_DFP, & --0.001111549364960_DFP, & --0.001111549364960_DFP, & -+0.003165957038205_DFP, & -+0.003165957038205_DFP, & -+0.003165957038205_DFP, & -+0.003165957038205_DFP, & -+0.003165957038205_DFP, & -+0.003165957038205_DFP, & -+0.013628769024550_DFP, & -+0.013628769024550_DFP, & -+0.013628769024550_DFP, & -+0.013628769024550_DFP, & -+0.013628769024550_DFP, & -+0.013628769024550_DFP, & -+0.008838392824750_DFP, & -+0.008838392824750_DFP, & -+0.008838392824750_DFP, & -+0.008838392824750_DFP, & -+0.008838392824750_DFP, & -+0.008838392824750_DFP, & -+0.009189742319050_DFP, & -+0.009189742319050_DFP, & -+0.009189742319050_DFP, & -+0.009189742319050_DFP, & -+0.009189742319050_DFP, & -+0.009189742319050_DFP, & -+0.004052366404095_DFP, & -+0.004052366404095_DFP, & -+0.004052366404095_DFP, & -+0.004052366404095_DFP, & -+0.004052366404095_DFP, & -+0.004052366404095_DFP, & -+0.003817064535365_DFP, & -+0.003817064535365_DFP, & -+0.003817064535365_DFP, & -+0.003817064535365_DFP, & -+0.003817064535365_DFP, & -+0.003817064535365_DFP, & -real(+2.3093830397e-05, kind=DFP), & -real(+2.3093830397e-05, kind=DFP), & -real(+2.3093830397e-05, kind=DFP), & -real(+2.3093830397e-05, kind=DFP), & -real(+2.3093830397e-05, kind=DFP), & -real(+2.3093830397e-05, kind=DFP) & -], [70, 3])) - - -REAL(DFP), DIMENSION(3, 73), PUBLIC, PARAMETER :: triSolin73 = & -& TRANSPOSE(RESHAPE([ & -0.33333333333330_DFP, & -0.48960998707300_DFP, & -0.02078002585400_DFP, & -0.48960998707300_DFP, & -0.45453689269800_DFP, & -0.09092621460420_DFP, & -0.45453689269800_DFP, & -0.40141668064900_DFP, & -0.19716663870100_DFP, & -0.40141668064900_DFP, & -0.25555165440300_DFP, & -0.48889669119400_DFP, & -0.25555165440300_DFP, & -0.17707794215200_DFP, & -0.64584411569600_DFP, & -0.17707794215200_DFP, & -0.11006105322800_DFP, & -0.77987789354400_DFP, & -0.11006105322800_DFP, & -0.05552862425180_DFP, & -0.88894275149600_DFP, & -0.05552862425180_DFP, & -0.01262186377720_DFP, & -0.97475627244600_DFP, & -0.01262186377720_DFP, & -0.60063379479500_DFP, & -0.00361141784841_DFP, & -0.39575478735700_DFP, & -0.00361141784841_DFP, & -0.39575478735700_DFP, & -0.60063379479500_DFP, & -0.55760326158900_DFP, & -0.13446675453100_DFP, & -0.30792998388000_DFP, & -0.13446675453100_DFP, & -0.30792998388000_DFP, & -0.55760326158900_DFP, & -0.72098702581700_DFP, & -0.01444602577610_DFP, & -0.26456694840700_DFP, & -0.01444602577610_DFP, & -0.26456694840700_DFP, & -0.72098702581700_DFP, & -0.59452706895600_DFP, & -0.04693357883820_DFP, & -0.35853935220600_DFP, & -0.04693357883820_DFP, & -0.35853935220600_DFP, & -0.59452706895600_DFP, & -0.83933147368100_DFP, & -0.00286112035057_DFP, & -0.15780740596900_DFP, & -0.00286112035057_DFP, & -0.15780740596900_DFP, & -0.83933147368100_DFP, & -0.70108797892600_DFP, & -0.22386142409800_DFP, & -0.07505059697590_DFP, & -0.22386142409800_DFP, & -0.07505059697590_DFP, & -0.70108797892600_DFP, & -0.82293132407000_DFP, & -0.03464707481680_DFP, & -0.14242160111300_DFP, & -0.03464707481680_DFP, & -0.14242160111300_DFP, & -0.82293132407000_DFP, & -0.92434425262100_DFP, & -0.01016111929630_DFP, & -0.06549462808290_DFP, & -0.01016111929630_DFP, & -0.06549462808290_DFP, & -0.92434425262100_DFP, & -0.33333333333330_DFP, & -0.48960998707300_DFP, & -0.48960998707300_DFP, & -0.02078002585400_DFP, & -0.45453689269800_DFP, & -0.45453689269800_DFP, & -0.09092621460420_DFP, & -0.40141668064900_DFP, & -0.40141668064900_DFP, & -0.19716663870100_DFP, & -0.25555165440300_DFP, & -0.25555165440300_DFP, & -0.48889669119400_DFP, & -0.17707794215200_DFP, & -0.17707794215200_DFP, & -0.64584411569600_DFP, & -0.11006105322800_DFP, & -0.11006105322800_DFP, & -0.77987789354400_DFP, & -0.05552862425180_DFP, & -0.05552862425180_DFP, & -0.88894275149600_DFP, & -0.01262186377720_DFP, & -0.01262186377720_DFP, & -0.97475627244600_DFP, & -0.39575478735700_DFP, & -0.60063379479500_DFP, & -0.00361141784841_DFP, & -0.39575478735700_DFP, & -0.60063379479500_DFP, & -0.00361141784841_DFP, & -0.30792998388000_DFP, & -0.55760326158900_DFP, & -0.13446675453100_DFP, & -0.30792998388000_DFP, & -0.55760326158900_DFP, & -0.13446675453100_DFP, & -0.26456694840700_DFP, & -0.72098702581700_DFP, & -0.01444602577610_DFP, & -0.26456694840700_DFP, & -0.72098702581700_DFP, & -0.01444602577610_DFP, & -0.35853935220600_DFP, & -0.59452706895600_DFP, & -0.04693357883820_DFP, & -0.35853935220600_DFP, & -0.59452706895600_DFP, & -0.04693357883820_DFP, & -0.15780740596900_DFP, & -0.83933147368100_DFP, & -0.00286112035057_DFP, & -0.15780740596900_DFP, & -0.83933147368100_DFP, & -0.00286112035057_DFP, & -0.07505059697590_DFP, & -0.70108797892600_DFP, & -0.22386142409800_DFP, & -0.07505059697590_DFP, & -0.70108797892600_DFP, & -0.22386142409800_DFP, & -0.14242160111300_DFP, & -0.82293132407000_DFP, & -0.03464707481680_DFP, & -0.14242160111300_DFP, & -0.82293132407000_DFP, & -0.03464707481680_DFP, & -0.06549462808290_DFP, & -0.92434425262100_DFP, & -0.01016111929630_DFP, & -0.06549462808290_DFP, & -0.92434425262100_DFP, & -0.01016111929630_DFP, & -0.016453165694450_DFP, & -0.005165365945650_DFP, & -0.005165365945650_DFP, & -0.005165365945650_DFP, & -0.011193623631500_DFP, & -0.011193623631500_DFP, & -0.011193623631500_DFP, & -0.015133062934750_DFP, & -0.015133062934750_DFP, & -0.015133062934750_DFP, & -0.015245483901100_DFP, & -0.015245483901100_DFP, & -0.015245483901100_DFP, & -0.012079606370800_DFP, & -0.012079606370800_DFP, & -0.012079606370800_DFP, & -0.008025401793400_DFP, & -0.008025401793400_DFP, & -0.008025401793400_DFP, & -0.004042290130890_DFP, & -0.004042290130890_DFP, & -0.004042290130890_DFP, & -0.001039681013740_DFP, & -0.001039681013740_DFP, & -0.001039681013740_DFP, & -0.001942438452490_DFP, & -0.001942438452490_DFP, & -0.001942438452490_DFP, & -0.001942438452490_DFP, & -0.001942438452490_DFP, & -0.001942438452490_DFP, & -0.012787080306000_DFP, & -0.012787080306000_DFP, & -0.012787080306000_DFP, & -0.012787080306000_DFP, & -0.012787080306000_DFP, & -0.012787080306000_DFP, & -0.004440451786670_DFP, & -0.004440451786670_DFP, & -0.004440451786670_DFP, & -0.004440451786670_DFP, & -0.004440451786670_DFP, & -0.004440451786670_DFP, & -0.008062273380850_DFP, & -0.008062273380850_DFP, & -0.008062273380850_DFP, & -0.008062273380850_DFP, & -0.008062273380850_DFP, & -0.008062273380850_DFP, & -0.001245970908745_DFP, & -0.001245970908745_DFP, & -0.001245970908745_DFP, & -0.001245970908745_DFP, & -0.001245970908745_DFP, & -0.001245970908745_DFP, & -0.009121420059500_DFP, & -0.009121420059500_DFP, & -0.009121420059500_DFP, & -0.009121420059500_DFP, & -0.009121420059500_DFP, & -0.009121420059500_DFP, & -0.005129281868100_DFP, & -0.005129281868100_DFP, & -0.005129281868100_DFP, & -0.005129281868100_DFP, & -0.005129281868100_DFP, & -0.005129281868100_DFP, & -0.001899964427650_DFP, & -0.001899964427650_DFP, & -0.001899964427650_DFP, & -0.001899964427650_DFP, & -0.001899964427650_DFP, & -0.001899964427650_DFP & -], [73, 3])) - - -REAL(DFP), DIMENSION(3, 79), PUBLIC, PARAMETER :: triSolin79 = & -& TRANSPOSE(RESHAPE([ & -+0.3333333333333_DFP, & -+0.5009504643520_DFP, & --0.0019009287044_DFP, & -+0.5009504643520_DFP, & -+0.4882129579350_DFP, & -+0.0235740841305_DFP, & -+0.4882129579350_DFP, & -+0.4551366869500_DFP, & -+0.0897266360994_DFP, & -+0.4551366869500_DFP, & -+0.4019962593180_DFP, & -+0.1960074813630_DFP, & -+0.4019962593180_DFP, & -+0.2558929097590_DFP, & -+0.4882141804810_DFP, & -+0.2558929097590_DFP, & -+0.1764882559950_DFP, & -+0.6470234880100_DFP, & -+0.1764882559950_DFP, & -+0.1041708553370_DFP, & -+0.7916582893260_DFP, & -+0.1041708553370_DFP, & -+0.0530689638409_DFP, & -+0.8938620723180_DFP, & -+0.0530689638409_DFP, & -+0.0416187151960_DFP, & -+0.9167625696080_DFP, & -+0.0416187151960_DFP, & -+0.0115819214068_DFP, & -+0.9768361571860_DFP, & -+0.0115819214068_DFP, & -+0.6064026461060_DFP, & -+0.0487415836648_DFP, & -+0.3448557702290_DFP, & -+0.0487415836648_DFP, & -+0.3448557702290_DFP, & -+0.6064026461060_DFP, & -+0.6158426144570_DFP, & -+0.0063141159486_DFP, & -+0.3778432695950_DFP, & -+0.0063141159486_DFP, & -+0.3778432695950_DFP, & -+0.6158426144570_DFP, & -+0.5590480003900_DFP, & -+0.1343165205470_DFP, & -+0.3066354790620_DFP, & -+0.1343165205470_DFP, & -+0.3066354790620_DFP, & -+0.5590480003900_DFP, & -+0.7366067432630_DFP, & -+0.0139738939624_DFP, & -+0.2494193627750_DFP, & -+0.0139738939624_DFP, & -+0.2494193627750_DFP, & -+0.7366067432630_DFP, & -+0.7116751422870_DFP, & -+0.0755491329098_DFP, & -+0.2127757248030_DFP, & -+0.0755491329098_DFP, & -+0.2127757248030_DFP, & -+0.7116751422870_DFP, & -+0.8614027171550_DFP, & --0.0083681532082_DFP, & -+0.1469654360530_DFP, & --0.0083681532082_DFP, & -+0.1469654360530_DFP, & -+0.8614027171550_DFP, & -+0.8355869579120_DFP, & -+0.0266860632587_DFP, & -+0.1377269788290_DFP, & -+0.0266860632587_DFP, & -+0.1377269788290_DFP, & -+0.8355869579120_DFP, & -+0.9297561715570_DFP, & -+0.0105477192941_DFP, & -+0.0596961091490_DFP, & -+0.0105477192941_DFP, & -+0.0596961091490_DFP, & -+0.9297561715570_DFP, & -+0.3333333333333_DFP, & -+0.5009504643520_DFP, & -+0.5009504643520_DFP, & --0.0019009287044_DFP, & -+0.4882129579350_DFP, & -+0.4882129579350_DFP, & -+0.0235740841305_DFP, & -+0.4551366869500_DFP, & -+0.4551366869500_DFP, & -+0.0897266360994_DFP, & -+0.4019962593180_DFP, & -+0.4019962593180_DFP, & -+0.1960074813630_DFP, & -+0.2558929097590_DFP, & -+0.2558929097590_DFP, & -+0.4882141804810_DFP, & -+0.1764882559950_DFP, & -+0.1764882559950_DFP, & -+0.6470234880100_DFP, & -+0.1041708553370_DFP, & -+0.1041708553370_DFP, & -+0.7916582893260_DFP, & -+0.0530689638409_DFP, & -+0.0530689638409_DFP, & -+0.8938620723180_DFP, & -+0.0416187151960_DFP, & -+0.0416187151960_DFP, & -+0.9167625696080_DFP, & -+0.0115819214068_DFP, & -+0.0115819214068_DFP, & -+0.9768361571860_DFP, & -+0.3448557702290_DFP, & -+0.6064026461060_DFP, & -+0.0487415836648_DFP, & -+0.3448557702290_DFP, & -+0.6064026461060_DFP, & -+0.0487415836648_DFP, & -+0.3778432695950_DFP, & -+0.6158426144570_DFP, & -+0.0063141159486_DFP, & -+0.3778432695950_DFP, & -+0.6158426144570_DFP, & -+0.0063141159486_DFP, & -+0.3066354790620_DFP, & -+0.5590480003900_DFP, & -+0.1343165205470_DFP, & -+0.3066354790620_DFP, & -+0.5590480003900_DFP, & -+0.1343165205470_DFP, & -+0.2494193627750_DFP, & -+0.7366067432630_DFP, & -+0.0139738939624_DFP, & -+0.2494193627750_DFP, & -+0.7366067432630_DFP, & -+0.0139738939624_DFP, & -+0.2127757248030_DFP, & -+0.7116751422870_DFP, & -+0.0755491329098_DFP, & -+0.2127757248030_DFP, & -+0.7116751422870_DFP, & -+0.0755491329098_DFP, & -+0.1469654360530_DFP, & -+0.8614027171550_DFP, & --0.0083681532082_DFP, & -+0.1469654360530_DFP, & -+0.8614027171550_DFP, & --0.0083681532082_DFP, & -+0.1377269788290_DFP, & -+0.8355869579120_DFP, & -+0.0266860632587_DFP, & -+0.1377269788290_DFP, & -+0.8355869579120_DFP, & -+0.0266860632587_DFP, & -+0.0596961091490_DFP, & -+0.9297561715570_DFP, & -+0.0105477192941_DFP, & -+0.0596961091490_DFP, & -+0.9297561715570_DFP, & -+0.0105477192941_DFP, & -+0.016528527770800_DFP, & -+0.000433509592831_DFP, & -+0.000433509592831_DFP, & -+0.000433509592831_DFP, & -+0.005830026358200_DFP, & -+0.005830026358200_DFP, & -+0.005830026358200_DFP, & -+0.011438468178200_DFP, & -+0.011438468178200_DFP, & -+0.011438468178200_DFP, & -+0.015224491336950_DFP, & -+0.015224491336950_DFP, & -+0.015224491336950_DFP, & -+0.015312445862700_DFP, & -+0.015312445862700_DFP, & -+0.015312445862700_DFP, & -+0.012184028838400_DFP, & -+0.012184028838400_DFP, & -+0.012184028838400_DFP, & -+0.007998716016000_DFP, & -+0.007998716016000_DFP, & -+0.007998716016000_DFP, & -+0.003849150907800_DFP, & -+0.003849150907800_DFP, & -+0.003849150907800_DFP, & --0.000316030248744_DFP, & --0.000316030248744_DFP, & --0.000316030248744_DFP, & -+0.000875567150595_DFP, & -+0.000875567150595_DFP, & -+0.000875567150595_DFP, & -+0.008232919594800_DFP, & -+0.008232919594800_DFP, & -+0.008232919594800_DFP, & -+0.008232919594800_DFP, & -+0.008232919594800_DFP, & -+0.008232919594800_DFP, & -+0.002419516770245_DFP, & -+0.002419516770245_DFP, & -+0.002419516770245_DFP, & -+0.002419516770245_DFP, & -+0.002419516770245_DFP, & -+0.002419516770245_DFP, & -+0.012902453267350_DFP, & -+0.012902453267350_DFP, & -+0.012902453267350_DFP, & -+0.012902453267350_DFP, & -+0.012902453267350_DFP, & -+0.012902453267350_DFP, & -+0.004235545527220_DFP, & -+0.004235545527220_DFP, & -+0.004235545527220_DFP, & -+0.004235545527220_DFP, & -+0.004235545527220_DFP, & -+0.004235545527220_DFP, & -+0.009177457053150_DFP, & -+0.009177457053150_DFP, & -+0.009177457053150_DFP, & -+0.009177457053150_DFP, & -+0.009177457053150_DFP, & -+0.009177457053150_DFP, & -+0.000352202338954_DFP, & -+0.000352202338954_DFP, & -+0.000352202338954_DFP, & -+0.000352202338954_DFP, & -+0.000352202338954_DFP, & -+0.000352202338954_DFP, & -+0.005056342463750_DFP, & -+0.005056342463750_DFP, & -+0.005056342463750_DFP, & -+0.005056342463750_DFP, & -+0.005056342463750_DFP, & -+0.005056342463750_DFP, & -+0.001786954692975_DFP, & -+0.001786954692975_DFP, & -+0.001786954692975_DFP, & -+0.001786954692975_DFP, & -+0.001786954692975_DFP, & -+0.001786954692975_DFP & -], [79, 3])) - -contains - -pure function QuadratureNumberTriangleSolin(order) result(ans) -INTEGER( I4B ), INTENT( IN ) :: order -INTEGER( I4B ) :: ans -select case(order) -case(1) -ans = 1 -case(2) -ans = 3 -case(3) -ans = 4 -case(4) -ans = 6 -case(5) -ans = 7 -case(6) -ans = 12 -case(7) -ans = 13 -case(8) -ans = 16 -case(9) -ans = 19 -case(10) -ans = 25 -case(11) -ans = 27 -case(12) -ans = 33 -case(13) -ans = 37 -case(14) -ans = 42 -case(15) -ans = 48 -case(16) -ans = 52 -case(17) -ans = 61 -case(18) -ans = 70 -case(19) -ans = 73 -case(20) -ans = 79 -case default -ans = -1 -end select -end function QuadratureNumberTriangleSolin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -pure function QuadraturePointTriangleSolin1(order) result(ans) - INTEGER( I4B ), INTENT( IN ) :: order - REAL( DFP ), ALLOCATABLE :: ans(:, :) - INTEGER(I4B) :: nips(1) - nips(1) = QuadratureNumberTriangleSolin(order=order) - if( nips(1) .gt. 0_I4B ) then - ans = QuadraturePointTriangleSolin(nips=nips) - end if -end function QuadraturePointTriangleSolin1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -pure subroutine QuadraturePointTriangleSolin1_(order, ans, nrow, ncol) - INTEGER( I4B ), INTENT( IN ) :: order - REAL( DFP ), INTENT(INOUT) :: ans(:, :) - INTEGER( I4B ), INTENT(OUT) :: nrow, ncol - - INTEGER(I4B) :: nips(1) - - nips(1) = QuadratureNumberTriangleSolin(order=order) - nrow = 0 - ncol = 0 - - if( nips(1) .gt. 0_I4B ) & - CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=nrow, & - ncol=ncol) - -end subroutine QuadraturePointTriangleSolin1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -pure function QuadraturePointTriangleSolin(nips) result(ans) - INTEGER( I4B ), INTENT( IN ) :: nips(1) - REAL( DFP ), ALLOCATABLE :: ans(:, :) - - INTEGER(I4B) :: nrow, ncol - - nrow = 3 - ncol = nips(1) - - ALLOCATE(ans(nrow, ncol)) - CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=nrow, ncol=ncol) - -end function QuadraturePointTriangleSolin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -pure subroutine QuadraturePointTriangleSolin_(nips, ans, nrow, ncol) - INTEGER( I4B ), INTENT( IN ) :: nips(1) - REAL( DFP ), INTENT(INOUT) :: ans(:, :) - INTEGER( I4B ), INTENT(OUT) :: nrow, ncol - - nrow = 3 - ncol = nips(1) - - select case(nips(1)) - case(1) - ans(1:nrow, 1:ncol) = triSolin1 - - case(3) - ans(1:nrow, 1:ncol) = triSolin3 - - case(4) - ans(1:nrow, 1:ncol) = triSolin4 - - case(6) - ans(1:nrow, 1:ncol) = triSolin6 - - case(7) - ans(1:nrow, 1:ncol) = triSolin7 - - case(12) - ans(1:nrow, 1:ncol) = triSolin12 - - case(13) - ans(1:nrow, 1:ncol) = triSolin13 - - case(16) - ans(1:nrow, 1:ncol) = triSolin16 - - case(19) - ans(1:nrow, 1:ncol) = triSolin19 - - case(25) - ans(1:nrow, 1:ncol) = triSolin25 - - case(27) - ans(1:nrow, 1:ncol) = triSolin27 - - case(33) - ans(1:nrow, 1:ncol) = triSolin33 - - case(37) - ans(1:nrow, 1:ncol) = triSolin37 - - case(42) - ans(1:nrow, 1:ncol) = triSolin42 - - case(48) - ans(1:nrow, 1:ncol) = triSolin48 - - case(52) - ans(1:nrow, 1:ncol) = triSolin52 - - case(61) - ans(1:nrow, 1:ncol) = triSolin61 - - case(70) - ans(1:nrow, 1:ncol) = triSolin70 - - case(73) - ans(1:nrow, 1:ncol) = triSolin73 - - case(79) - ans(1:nrow, 1:ncol) = triSolin79 - - end select -end subroutine QuadraturePointTriangleSolin_ - -END MODULE QuadraturePoint_Triangle_Solin diff --git a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 deleted file mode 100644 index cb6c67770..000000000 --- a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 +++ /dev/null @@ -1,346 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(RecursiveNodesUtility) Methods -USE BaseMethod -CONTAINS - -!---------------------------------------------------------------------------- -! RecursiveNode1D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RecursiveNode1D -INTEGER(I4B) :: n, jj -INTEGER(I4B), PARAMETER :: d = 1_I4B -INTEGER(I4B) :: aindx(d + 1) -REAL(DFP) :: avar -REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] -INTEGER(I4B), ALLOCATABLE :: indices(:, :) -REAL(DFP), ALLOCATABLE :: x(:) - -n = order -x = InterpolationPoint_Line( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout="INCREASING", & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -indices = GetMultiIndices(n=n, d=d) -CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) - -DO jj = 1, SIZE(ans, 2) - aindx = indices(:, jj) + 1 - avar = x(aindx(1)) + x(aindx(2)) - ans(1, jj) = x(aindx(1)) / avar - ans(2, jj) = x(aindx(2)) / avar -END DO - -IF (PRESENT(domain)) THEN - ans = Coord_Map(x=ans, from="BaryCentric", to=domain) -END IF - -IF (ALLOCATED(indices)) DEALLOCATE (indices) -IF (ALLOCATED(x)) DEALLOCATE (x) -END PROCEDURE RecursiveNode1D - -!---------------------------------------------------------------------------- -! RecursiveNode2D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RecursiveNode2D -INTEGER(I4B) :: n, jj, ii -INTEGER(I4B), PARAMETER :: d = 2_I4B -INTEGER(I4B) :: aindx(d + 1), indx(d) -REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) -REAL(DFP) :: BX(2, order + 1, order + 1) -INTEGER(I4B), ALLOCATABLE :: indices(:, :) - -n = order -CALL BarycentericNodeFamily1D( & - & order=order, & - & ipType=ipType, & - & ans=BX, & - & Xn=Xn, & - & alpha=alpha, beta=beta, lambda=lambda) - -indices = GetMultiIndices(n=n, d=d) -CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) - -DO jj = 1, SIZE(ans, 2) - aindx = indices(:, jj) - xt = 0.0_DFP - - DO ii = 1, d + 1 - indx = Pop(aindx, ii) - bs = BX(:, indx(1) + 1, indx(2) + 1) - b = Push(vec=bs, VALUE=0.0_DFP, pos=ii) - xi = Xn(SUM(indx) + 1) - xt = xt + xi - ans(1:d + 1, jj) = ans(1:d + 1, jj) + xi * b - END DO - ans(:, jj) = ans(:, jj) / xt -END DO - -IF (PRESENT(domain)) THEN - ans = Coord_Map(x=ans, from="BaryCentric", to=domain) -END IF - -IF (ALLOCATED(indices)) DEALLOCATE (indices) -END PROCEDURE RecursiveNode2D - -!---------------------------------------------------------------------------- -! RecursiveNode3D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RecursiveNode3D -INTEGER(I4B) :: n, jj, ii -INTEGER(I4B), PARAMETER :: d = 3_I4B -INTEGER(I4B) :: aindx(d + 1), indx(d) -REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) -REAL(DFP) :: BX(3, order + 1, order + 1, order + 1) -INTEGER(I4B), ALLOCATABLE :: indices(:, :) - -n = order -CALL BarycentericNodeFamily2D(order=order, ipType=ipType, ans=BX, Xn=Xn, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -indices = GetMultiIndices(n=n, d=d) -CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) -ans = 0.0_DFP - -DO jj = 1, SIZE(ans, 2) - - aindx = indices(:, jj) - xt = 0.0_DFP - - DO ii = 1, d + 1 - - indx = Pop(aindx, ii) - bs = BX(:, indx(1) + 1, indx(2) + 1, indx(3) + 1) - b = Push(vec=bs, VALUE=0.0_DFP, pos=ii) - xi = Xn(SUM(indx) + 1) - xt = xt + xi - ans(:, jj) = ans(:, jj) + xi * b - - END DO - - ans(:, jj) = ans(:, jj) / xt - -END DO - -IF (PRESENT(domain)) THEN - ans = Coord_Map(x=ans, from="BaryCentric", to=domain) -END IF - -IF (ALLOCATED(indices)) DEALLOCATE (indices) - -END PROCEDURE RecursiveNode3D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn, alpha, & - & beta, lambda) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: ipType - REAL(DFP), INTENT(OUT) :: ans(2, order + 1, order + 1) - REAL(DFP), INTENT(OUT) :: Xn(order + 1) - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - ! - INTEGER(I4B) :: ii, jj, n - INTEGER(I4B), PARAMETER :: d = 1_I4B - REAL(DFP), ALLOCATABLE :: BXn(:, :) - INTEGER(I4B), ALLOCATABLE :: indices(:, :) - !! - DO ii = 0, order - n = ii - indices = GetMultiIndices(n=n, d=d) - BXn = RecursiveNode1D(order=n, ipType=ipType, & - & alpha=alpha, beta=beta, lambda=lambda) - !! - DO jj = 1, n + 1 - ans(1:d + 1, indices(1, jj) + 1, indices(2, jj) + 1) = BXn(1:d + 1, jj) - END DO - !! - END DO - !! - Xn = BXn(1, :) - !! - IF (ALLOCATED(BXn)) DEALLOCATE (BXn) - IF (ALLOCATED(indices)) DEALLOCATE (indices) - !! -END SUBROUTINE BarycentericNodeFamily1D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn, alpha, beta, lambda) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: ipType - REAL(DFP), INTENT(OUT) :: ans(3, order + 1, order + 1, order + 1) - REAL(DFP), INTENT(OUT) :: Xn(order + 1) - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - !! - INTEGER(I4B) :: ii, jj, n - INTEGER(I4B), PARAMETER :: d = 2_I4B - REAL(DFP), ALLOCATABLE :: BXn(:, :) - INTEGER(I4B), ALLOCATABLE :: indices(:, :) - REAL(DFP) :: avar - REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] - !! - DO ii = 0, order - n = ii - indices = GetMultiIndices(n=n, d=d) - BXn = RecursiveNode2D(order=n, ipType=ipType, alpha=alpha, beta=beta, lambda=lambda ) - !! - DO jj = 1, SIZE(BXn, 2) - ans(1:3, & - & indices(1, jj) + 1, & - & indices(2, jj) + 1, & - & indices(3, jj) + 1) = BXn(1:3, jj) - END DO - !! - END DO - !! - Xn = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij, & - & layout="INCREASING", alpha=alpha, beta=beta, lambda=lambda) - !! - ! IF (order .GT. 1) THEN - ! avar = Xn(2) - ! Xn(2:order) = Xn(3:) - ! Xn(order + 1) = avar - ! END IF - !! - IF (ALLOCATED(BXn)) DEALLOCATE (BXn) - IF (ALLOCATED(indices)) DEALLOCATE (indices) - !! -END SUBROUTINE BarycentericNodeFamily2D - -!---------------------------------------------------------------------------- -! Unit2Equilateral -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Unit2Equilateral -INTEGER(I4B) :: ii -!! -IF (d .GT. 1_I4B) THEN - ! Move the top vertex over the centroid - DO ii = 1, d - 1 - x(ii, :) = x(ii, :) + x(d, :) / d - END DO - ! Make the projection onto the lesser dimensions equilateral - CALL Unit2Equilateral(d - 1, x(1:d - 1, :)) - ! scale the vertical dimension - x(d, :) = x(d, :) * SQRT((d + 1.0_DFP) / (2.0_DFP * d)) -END IF -END PROCEDURE Unit2Equilateral - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Equilateral2Unit -INTEGER(I4B) :: ii -!! -IF (d .GT. 1_I4B) THEN - x(d, :) = x(d, :) / SQRT((d + 1.0_DFP) / (2.0_DFP * d)) - CALL Equilateral2Unit(d=d - 1, x=x(1:d - 1, :)) - DO ii = 1, d - 1 - x(ii, :) = x(ii, :) - x(d, :) / d - END DO -END IF -END PROCEDURE Equilateral2Unit - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ToUnit -TYPE(String) :: astr -INTEGER(I4B) :: d -astr = UpperCase(TRIM(domain)) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = x -CASE ("BIUNIT") - ans = 0.5_DFP * (x + 1.0_DFP) -CASE ("BARYCENTRIC") - d = SIZE(x, 1) - ans = x(1:d - 1, :) -CASE ("EQUILATERAL") - d = SIZE(x, 1) - ans = x - ans = ans / 2.0_DFP - CALL Equilateral2Unit(d=d, x=ans) - ans = ans + 1.0_DFP / (d + 1.0_DFP) -END SELECT -END PROCEDURE ToUnit - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnit -TYPE(String) :: astr -INTEGER(I4B) :: d -astr = UpperCase(TRIM(domain)) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = x -CASE ("BIUNIT") - ans = 2.0_DFP * x - 1 -CASE ("BARYCENTRIC") - ans = x.ROWCONCAT. (1.0_DFP - SUM(x, dim=1)) -CASE ("EQUILATERAL") - d = SIZE(x, 1) - ans = x - ans = ans - 1.0_DFP / (d + 1.0_DFP) - CALL Unit2Equilateral(d=d, x=ans) - ans = ans * 2.0_DFP -END SELECT -END PROCEDURE FromUnit - -!---------------------------------------------------------------------------- -! Coord_Map -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Coord_Map -ans = FromUnit(x=(ToUnit(x=x, domain=from)), domain=to) -END PROCEDURE Coord_Map - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 deleted file mode 100644 index 0c0fcc3b2..000000000 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,2587 +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(TetrahedronInterpolationUtility) Methods -USE BaseMethod -USE QuadraturePoint_Tetrahedron_Solin, ONLY: & -& QuadratureNumberTetrahedronSolin, & -& QuadratureOrderTetrahedronSolin, & -& QuadraturePointTetrahedronSolin, & -& MAX_ORDER_TETRAHEDRON_SOLIN -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefElemDomain_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Tetrahedron -SELECT CASE (UpperCase(baseContinuity)) -CASE ("H1") - SELECT CASE (UpperCase(baseInterpol)) - CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") - ans = "UNIT" - CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") - ans = "UNIT" - CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") - ans = "UNIT" - CASE ( & - & "HIERARCHICALPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHICALPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION") - ans = "BIUNIT" - CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") - ans = "BIUNIT" - CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given baseInterpol="//TRIM(baseInterpol), & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Tetrahedron()", & - & unitno=stderr) - END SELECT -CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given baseContinuity="//TRIM(baseContinuity), & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Tetrahedron()", & - & unitno=stderr) -END SELECT -END PROCEDURE RefElemDomain_Tetrahedron - -!---------------------------------------------------------------------------- -! GetVertexDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetVertexDOF_Tetrahedron -ans = 4 -END PROCEDURE GetVertexDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeDOF_Tetrahedron1 -ans = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6_I4B -END PROCEDURE GetEdgeDOF_Tetrahedron1 - -!---------------------------------------------------------------------------- -! GetEdgeDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetEdgeDOF_Tetrahedron2 -ans = GetEdgeDOF_Tetrahedron1(p, p, p, p, p, p) -END PROCEDURE GetEdgeDOF_Tetrahedron2 - -!---------------------------------------------------------------------------- -! GetFacetDOF_Tetrahedron1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFacetDOF_Tetrahedron1 -ans = (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2 -END PROCEDURE GetFacetDOF_Tetrahedron1 - -!---------------------------------------------------------------------------- -! GetFacetDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetFacetDOF_Tetrahedron2 -ans = GetFacetDOF_Tetrahedron1(p, p, p, p) -END PROCEDURE GetFacetDOF_Tetrahedron2 - -!---------------------------------------------------------------------------- -! GetCellDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetCellDOF_Tetrahedron1 -ans = (p - 1) * (p - 2) * (p - 3) / 6_I4B -END PROCEDURE GetCellDOF_Tetrahedron1 - -!---------------------------------------------------------------------------- -! EdgeConnectivity_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeConnectivity_Tetrahedron -ans(:, 1) = [1, 2] -ans(:, 2) = [1, 3] -ans(:, 3) = [1, 4] -ans(:, 4) = [2, 3] -ans(:, 5) = [2, 4] -ans(:, 6) = [3, 4] -END PROCEDURE EdgeConnectivity_Tetrahedron - -!---------------------------------------------------------------------------- -! FacetConnectivity_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetConnectivity_Tetrahedron -TYPE(String) :: baseInterpol0 -TYPE(String) :: baseContinuity0 - -baseInterpol0 = UpperCase(baseInterpol) -baseContinuity0 = UpperCase(baseContinuity) - -SELECT CASE (baseInterpol0%chars()) -CASE ( & - & "HIERARCHYPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHYPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION", & - & "ORTHOGONALPOLYNOMIAL", & - & "ORTHOGONAL", & - & "ORTHOGONALINTERPOLATION") - ans(:, 1) = [1, 2, 3] - ans(:, 2) = [1, 2, 4] - ans(:, 3) = [1, 3, 4] - ans(:, 4) = [2, 3, 4] -CASE DEFAULT - ans(:, 1) = [1, 3, 2] - ans(:, 2) = [1, 2, 4] - ans(:, 3) = [1, 4, 3] - ans(:, 4) = [2, 3, 4] -END SELECT - -END PROCEDURE FacetConnectivity_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeDegree_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Tetrahedron -INTEGER(I4B) :: n, ii, jj, kk, ll -n = LagrangeDOF_Tetrahedron(order=order) -ALLOCATE (ans(n, 3)) -ll = 0 -DO kk = 0, order - DO jj = 0, order - DO ii = 0, order - IF (ii + jj + kk .LE. order) THEN - ll = ll + 1 - ans(ll, 1) = ii - ans(ll, 2) = jj - ans(ll, 3) = kk - END IF - END DO - END DO -END DO -END PROCEDURE LagrangeDegree_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Tetrahedron -ans = (order + 1) * (order + 2) * (order + 3) / 6_I4B -END PROCEDURE LagrangeDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetTotalDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Tetrahedron -ans = (order + 1) * (order + 2) * (order + 3) / 6_I4B -END PROCEDURE GetTotalDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Tetrahedron -ans = (order - 1) * (order - 2) * (order - 3) / 6_I4B -END PROCEDURE GetTotalInDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Tetrahedron -ans = (order - 1) * (order - 2) * (order - 3) / 6_I4B -END PROCEDURE LagrangeInDOF_Tetrahedron - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Tetrahedron_old -INTEGER(I4B), PARAMETER :: nv = 4_I4B -INTEGER(I4B) :: nsd, n, ne, nf, nc, i1, i2, ii -REAL(DFP) :: x(3, nv), xin(3, nv), e1(3), e2(3), e3(3), lam, & - & avar, mu, delta -INTEGER(I4B), PARAMETER :: edges(6, 2) = RESHAPE( & - & [1, 1, 1, 2, 2, 3, 2, 3, 4, 3, 4, 4], [6, 2]) -INTEGER(I4B), PARAMETER :: faces(4, 3) = RESHAPE( & - & [1, 1, 1, 2, 3, 2, 4, 3, 2, 4, 3, 4], [4, 3]) - -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:nv) = xij(1:nsd, 1:nv) -ELSE - nsd = 3_I4B - x(1:nsd, 1) = [0.0, 0.0, 0.0] - x(1:nsd, 2) = [1.0, 0.0, 0.0] - x(1:nsd, 3) = [0.0, 1.0, 0.0] - x(1:nsd, 4) = [0.0, 0.0, 1.0] -END IF - -n = LagrangeDOF_Tetrahedron(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP - -! points on vertex -ans(1:nsd, 1:nv) = x(1:nsd, 1:nv) - -! points on edge -ne = LagrangeInDOF_Line(order=order) -nf = LagrangeInDOF_Triangle(order=order) -nc = LagrangeInDOF_Tetrahedron(order=order) - -i2 = nv -IF (order .GT. 1_I4B) THEN - DO ii = 1, SIZE(edges, 1) - i1 = i2 + 1; i2 = i2 + ne - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, edges(ii, 1:2))) - END DO -END IF - -! points on face -IF (order .GT. 2_I4B) THEN - DO ii = 1, SIZE(faces, 1) - i1 = i2 + 1; i2 = i2 + nf - ans(1:nsd, i1:i2) = EquidistanceInPoint_Triangle( & - & order=order, & - & xij=x(1:nsd, faces(ii, 1:3))) - END DO -END IF - -! points on cell -IF (order .GT. 3_I4B) THEN - IF (order .EQ. 4_I4B) THEN - ans(1:nsd, i2 + 1) = SUM(x(1:nsd, :), dim=2_I4B) / nv - ELSE - e1 = x(:, 2) - x(:, 1); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 1); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 4) - x(:, 1); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - - e1 = x(:, 1) - x(:, 2); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 2); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 4) - x(:, 2); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - - e1 = x(:, 1) - x(:, 3); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 3); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 4) - x(:, 3); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - - e1 = x(:, 1) - x(:, 4); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 4); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 3) - x(:, 4); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 4) = x(1:nsd, 4) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - - i1 = i2 + 1 - ans(1:nsd, i1:) = EquidistancePoint_Tetrahedron( & - & order=order - 4, & - & xij=xin(1:nsd, 1:4)) - END IF -END IF -END PROCEDURE EquidistancePoint_Tetrahedron_old - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Tetrahedron_old -INTEGER(I4B), PARAMETER :: nv = 4_I4B -INTEGER(I4B) :: nsd, n, ne, nf, nc, i1, i2, ii -REAL(DFP) :: x(3, nv), xin(3, nv), e1(3), e2(3), e3(3), lam, & - & avar, mu, delta -INTEGER(I4B), PARAMETER :: edges(6, 2) = RESHAPE( & - & [1, 1, 1, 2, 2, 3, 2, 3, 4, 3, 4, 4], [6, 2]) -INTEGER(I4B), PARAMETER :: faces(4, 3) = RESHAPE( & - & [1, 1, 1, 2, 3, 2, 4, 3, 2, 4, 3, 4], [4, 3]) - -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:nv) = xij(1:nsd, 1:nv) -ELSE - nsd = 3_I4B - x(1:nsd, 1) = [0.0, 0.0, 0.0] - x(1:nsd, 2) = [1.0, 0.0, 0.0] - x(1:nsd, 3) = [0.0, 1.0, 0.0] - x(1:nsd, 4) = [0.0, 0.0, 1.0] -END IF -! -n = LagrangeInDOF_Tetrahedron(order=order) -! -! points on cell -! -IF (order .GT. 3_I4B) THEN - ALLOCATE (ans(nsd, n)) - ans = 0.0_DFP - IF (order .EQ. 4_I4B) THEN - ans(1:nsd, i2 + 1) = SUM(x(1:nsd, :), dim=2_I4B) / nv - ELSE - ! - e1 = x(:, 2) - x(:, 1); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 1); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 4) - x(:, 1); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - ! - e1 = x(:, 1) - x(:, 2); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 2); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 4) - x(:, 2); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - ! - e1 = x(:, 1) - x(:, 3); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 3); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 4) - x(:, 3); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - ! - e1 = x(:, 1) - x(:, 4); avar = NORM2(e1); e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 4); avar = NORM2(e2); e2 = e2 / avar - mu = avar / order - e3 = x(:, 3) - x(:, 4); avar = NORM2(e3); e3 = e3 / avar - delta = avar / order - xin(1:nsd, 4) = x(1:nsd, 4) & - & + lam * e1(1:nsd) & - & + mu * e2(1:nsd) & - & + delta * e3(1:nsd) - ! - i1 = i2 + 1 - ans(1:nsd, i1:) = EquidistancePoint_Tetrahedron( & - & order=order - 4, & - & xij=xin(1:nsd, 1:4)) - ! - END IF -ELSE - ALLOCATE (ans(0, 0)) -END IF -END PROCEDURE EquidistanceInPoint_Tetrahedron_old - -!---------------------------------------------------------------------------- -! EquidistancePoint_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Tetrahedron -ans = InterpolationPoint_Tetrahedron( & - & order=order, & - & ipType=Equidistance, & - & layout="VEFC", & - & xij=xij & - &) -END PROCEDURE EquidistancePoint_Tetrahedron - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Tetrahedron -INTEGER(I4B) :: ii, jj -REAL(DFP), ALLOCATABLE :: ans0(:, :) -ans0 = EquidistancePoint_Tetrahedron(order=order, xij=xij) -ii = LagrangeDOF_Tetrahedron(order) -jj = LagrangeInDOF_Tetrahedron(order) -CALL Reallocate(ans, 3, jj) -ans = ans0(1:3, ii - jj + 1:) -IF (ALLOCATED(ans0)) DEALLOCATE (ans0) -END PROCEDURE EquidistanceInPoint_Tetrahedron - -!---------------------------------------------------------------------------- -! InterpolationPoint_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Tetrahedron -ans = Isaac_Tetrahedron( & - & order=order, & - & ipType=ipType, & - & layout=layout, & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END PROCEDURE InterpolationPoint_Tetrahedron - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Tetrahedron1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Tetrahedron1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Tetrahedron2 -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Tetrahedron2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Tetrahedron3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Tetrahedron3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Tetrahedron4 -INTEGER(I4B) :: basisType0 -basisType0 = input(default=Monomial, option=basisType) - -SELECT CASE (basisType0) -CASE (Monomial) - ans = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron) -CASE (Heirarchical) - IF (PRESENT(refTetrahedron)) THEN - ans = HeirarchicalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron=refTetrahedron & - & ) - ELSE - ans = HeirarchicalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron="UNIT" & - & ) - END IF -CASE DEFAULT - IF (PRESENT(refTetrahedron)) THEN - ans = OrthogonalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron=refTetrahedron & - & ) - ELSE - ans = OrthogonalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron="UNIT" & - & ) - END IF -END SELECT -CALL GetInvMat(ans) - -END PROCEDURE LagrangeCoeff_Tetrahedron4 - -!---------------------------------------------------------------------------- -! Isaac_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Isaac_Tetrahedron -REAL(DFP), DIMENSION(order + 1, order + 1, order + 1) :: xi, eta, zeta -REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) -INTEGER(I4B) :: nsd, N, cnt, ii, jj, kk -CHARACTER(*), PARAMETER :: myName = "Isaac_Tetrahedron" - -rPoints = RecursiveNode3D( & - & order=order, & - & ipType=ipType, & - & domain="UNIT", & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -N = SIZE(rPoints, 2) - -nsd = 3 -CALL Reallocate(ans, nsd, N) -CALL Reallocate(temp, nsd, N) - -!! convert from rPoints to xi and eta -cnt = 0 -xi = 0.0_DFP -eta = 0.0_DFP -zeta = 0.0_DFP - -DO ii = 0, order - DO jj = 0, order - DO kk = 0, order - IF (ii + jj + kk .LE. order) THEN - cnt = cnt + 1 - xi(ii + 1, jj + 1, kk + 1) = rPoints(1, cnt) - eta(ii + 1, jj + 1, kk + 1) = rPoints(2, cnt) - zeta(ii + 1, jj + 1, kk + 1) = rPoints(3, cnt) - END IF - END DO - END DO -END DO - -IF (layout .EQ. "VEFC") THEN - CALL IJK2VEFC_Tetrahedron( & - & xi=xi, & - & eta=eta, & - & zeta=zeta, & - & temp=temp, & - & order=order, & - & N=N) -ELSE - temp = rPoints -END IF - -IF (PRESENT(xij)) THEN - ans = FromUnitTetrahedron2Tetrahedron( & - & xin=temp, & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4)) -ELSE - ans = temp -END IF - -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints) -END PROCEDURE Isaac_Tetrahedron - -!---------------------------------------------------------------------------- -! BlythPozrikidis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BlythPozrikidis_Tetrahedron -CALL ErrorMsg( & - & msg="This method is under development, please use Isaac_Tetrahedron()", & - & file=__FILE__, & - & routine="BlythPozrikidis_Tetrahedron()", & - & line=__LINE__, & - & unitno=stderr) -RETURN -END PROCEDURE BlythPozrikidis_Tetrahedron - -!---------------------------------------------------------------------------- -! IJK2VEFC_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJK2VEFC_Tetrahedron -INTEGER(I4B) :: indof, ii, cnt, jj, kk, ll -REAL(DFP), DIMENSION(3, (order + 1)*(order + 2)/2) :: temp_face_in -REAL(DFP), DIMENSION(order + 1, order + 1) :: xi2, eta2, zeta2 - -SELECT CASE (order) -CASE (0) - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] -CASE (1) - ! | 0 | 0 | 0 | - ! | 0 | 0 | 1 | - ! | 0 | 1 | 0 | - ! | 1 | 0 | 0 | - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] -CASE (2) - ! | 0 | 0 | 0 | - ! | 0 | 0 | 0.5 | - ! | 0 | 0 | 1 | - ! | 0 | 0.5 | 0 | - ! | 0 | 0.5 | 0.5 | - ! | 0 | 1 | 0 | - ! | 0.5 | 0 | 0 | - ! | 0.5 | 0 | 0.5 | - ! | 0.5 | 0.5 | 0 | - ! | 1 | 0 | 0 | - - ! four vertex - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] - - ! edge1 x - temp(:, 5) = [xi(2, 1, 1), eta(2, 1, 1), zeta(2, 1, 1)] - ! edge2 y - temp(:, 6) = [xi(1, 2, 1), eta(1, 2, 1), zeta(1, 2, 1)] - ! edge3 z - temp(:, 7) = [xi(1, 1, 2), eta(1, 1, 2), zeta(1, 1, 2)] - ! edge4 xy - temp(:, 8) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] - ! edge5, xz - temp(:, 9) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] - ! edge6, yz - temp(:, 10) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] - -CASE (3) - ! | 0 | 0 | 0 | - ! | 0 | 0 | 0.33333 | - ! | 0 | 0 | 0.66667 | - ! | 0 | 0 | 1 | - ! | 0 | 0.33333 | 0 | - ! | 0 | 0.33333 | 0.33333 | - ! | 0 | 0.33333 | 0.66667 | - ! | 0 | 0.66667 | 0 | - ! | 0 | 0.66667 | 0.33333 | - ! | 0 | 1 | 0 | - ! | 0.33333 | 0 | 0 | - ! | 0.33333 | 0 | 0.33333 | - ! | 0.33333 | 0 | 0.66667 | - ! | 0.33333 | 0.33333 | 0 | - ! | 0.33333 | 0.33333 | 0.33333 | - ! | 0.33333 | 0.66667 | 0 | - ! | 0.66667 | 0 | 0 | - ! | 0.66667 | 0 | 0.33333 | - ! | 0.66667 | 0.33333 | 0 | - ! | 1 | 0 | 0 | - - ! four vertex - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] - - cnt = 4 - ! edge1 x - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] - END DO - ! edge2 y - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] - END DO - ! edge3 z - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] - END DO - ! edge4 xy - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(4-ii, 1+ii, 1), eta(4-ii, 1+ii, 1), zeta(4-ii, 1+ii, 1)] - END DO - ! edge5, xz - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(4-ii, 1, ii+1), eta(4-ii, 1, ii+1), zeta(4-ii, 1, ii+1)] - END DO - ! edge6, yz - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(1, 4-ii, ii+1), eta(1, 4-ii, ii+1), zeta(1, 4-ii, ii+1)] - END DO - - ! facet xy - cnt = cnt + 1 - temp(:, cnt) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] - - ! facet xz - cnt = cnt + 1 - temp(:, cnt) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] - - ! facet yz - cnt = cnt + 1 - temp(:, cnt) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] - - ! facet 4 - cnt = cnt + 1 - temp(:, cnt) = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)] - -CASE DEFAULT - - ! four vertex - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] - - cnt = 4 - ! edge1 x - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] - END DO - ! edge2 y - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] - END DO - ! edge3 z - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] - END DO - ! edge4 xy - jj = order + 1 - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [ & - & xi(jj - ii, 1 + ii, 1), & - & eta(jj - ii, 1 + ii, 1), & - & zeta(jj - ii, 1 + ii, 1)] - END DO - ! edge5, xz - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [ & - & xi(jj - ii, 1, ii + 1), & - & eta(jj - ii, 1, ii + 1), & - & zeta(jj - ii, 1, ii + 1)] - END DO - ! edge6, yz - DO ii = 1, order - 1 - cnt = cnt + 1 - temp(:, cnt) = [ & - & xi(1, jj - ii, ii + 1), & - & eta(1, jj - ii, ii + 1), & - & zeta(1, jj - ii, ii + 1)] - END DO - - ! facet xy - jj = LagrangeDOF_Triangle(order) - CALL IJ2VEFC_Triangle( & - & xi=xi(:, :, 1), & - & eta=eta(:, :, 1), & - & temp=temp_face_in, & - & order=order, & - & N=jj) - kk = LagrangeInDOF_Triangle(order) - DO ii = jj - kk + 1, jj - cnt = cnt + 1 - temp(:, cnt) = [temp_face_in(1, ii), temp_face_in(2, ii), zeta(1, 1, 1)] - END DO - - ! facet xz - ! jj = LagrangeDOF_Triangle(order) - CALL IJ2VEFC_Triangle( & - & xi=xi(:, 1, :), & - & eta=zeta(:, 1, :), & - & temp=temp_face_in, & - & order=order, & - & N=jj) - ! kk = LagrangeInDOF_Triangle(order) - DO ii = jj - kk + 1, jj - cnt = cnt + 1 - temp(:, cnt) = [temp_face_in(1, ii), eta(1, 1, 1), temp_face_in(2, ii)] - END DO - - ! facet yz - ! jj = LagrangeDOF_Triangle(order) - CALL IJ2VEFC_Triangle( & - & xi=eta(1, :, :), & - & eta=zeta(1, :, :), & - & temp=temp_face_in, & - & order=order, & - & N=jj) - ! kk = LagrangeInDOF_Triangle(order) - DO ii = jj - kk + 1, jj - cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1, 1), temp_face_in(1, ii), temp_face_in(2, ii)] - END DO - - ! ! facet 4 - ! cnt = cnt + 1 - ! temp(:, cnt) = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)] - xi2 = 0.0_DFP - eta2 = 0.0_DFP - zeta2 = 0.0_DFP - DO ii = 0, order - ll = 0 - DO jj = 0, order - DO kk = 0, order - IF (ii + jj + kk .EQ. order) THEN - ll = ll + 1 - xi2(ii + 1, ll) = xi(ii + 1, jj + 1, kk + 1) - eta2(ii + 1, ll) = eta(ii + 1, jj + 1, kk + 1) - zeta2(ii + 1, ll) = zeta(ii + 1, jj + 1, kk + 1) - END IF - END DO - END DO - END DO - - temp_face_in = 0.0_DFP - CALL IJK2VEFC_Triangle( & - & xi=xi2, & - & eta=eta2, & - & zeta=zeta2, & - & temp=temp_face_in, & - & order=order, & - & N=SIZE(temp_face_in, 2)) - - ! facet 4 - jj = LagrangeDOF_Triangle(order) - CALL IJK2VEFC_Triangle( & - & xi=xi2, & - & eta=eta2, & - & zeta=zeta2, & - & temp=temp_face_in, & - & order=order, & - & N=jj) - kk = LagrangeInDOF_Triangle(order) - DO ii = jj - kk + 1, jj - cnt = cnt + 1 - temp(:, cnt) = temp_face_in(1:3, ii) - END DO - - jj = LagrangeDOF_Tetrahedron(order) - kk = LagrangeInDOF_Tetrahedron(order=order) - CALL IJK2VEFC_Tetrahedron( & - & xi(2:order - 2, 2:order - 2, 2:order - 2), & - & eta(2:order - 2, 2:order - 2, 2:order - 2), & - & zeta(2:order - 2, 2:order - 2, 2:order - 2), & - & temp(:, cnt + 1:), & - & order - 4, kk) -END SELECT - -END PROCEDURE IJK2VEFC_Tetrahedron - -!---------------------------------------------------------------------------- -! IJ2VEFC_Triangle -!---------------------------------------------------------------------------- - -SUBROUTINE IJK2VEFC_Triangle( & - & xi, & - & eta, & - & zeta, & - & temp, & - & order, & - & N) - REAL(DFP), INTENT(IN) :: xi(:, :) - REAL(DFP), INTENT(IN) :: eta(:, :) - REAL(DFP), INTENT(IN) :: zeta(:, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: N - - INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, llt, llr - - cnt = 0 - m = order - llt = INT((m - 1) / 3) - llr = MOD(m - 1, 3) - DO ll = 0, llt - ! v1 - cnt = cnt + 1 - ii = 1 + ll; jj = 1 + ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - temp(3, cnt) = zeta(ii, jj) - ! v2 - cnt = cnt + 1 - ii = m + 1 - 2 * ll; jj = 1 + ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - temp(3, cnt) = zeta(ii, jj) - ! v3 - cnt = cnt + 1 - ii = 1 + ll; jj = m + 1 - 2 * ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - temp(3, cnt) = zeta(ii, jj) - ! nodes on edge 12 - jj = ll + 1 - DO ii = 2 + ll, m - 2 * ll - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - temp(3, cnt) = zeta(ii, jj) - END DO - ! nodes on edge 23 - DO jj = 2 + ll, m - 2 * ll - cnt = cnt + 1 - ii = m - ll + 2 - jj - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - temp(3, cnt) = zeta(ii, jj) - END DO - ! nodes on edge 31 - ii = ll + 1 - DO jj = m - 2 * ll, 2 + ll, -1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - temp(3, cnt) = zeta(ii, jj) - END DO - ! internal nodes - END DO - - IF (llr .EQ. 2_I4B) THEN - ! a internal point - cnt = cnt + 1 - ll = llt + 1 - ii = 1 + ll; jj = 1 + ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - temp(3, cnt) = zeta(ii, jj) - END IF - - IF (cnt .NE. N) THEN - CALL ErrorMsg( & - & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" & - & //tostring(N), & - & file=__FILE__, & - & routine="IJ2VEFC_Triangle()", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF -END SUBROUTINE IJK2VEFC_Triangle - -!---------------------------------------------------------------------------- -! OrthogonalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasis_Tetrahedron1 -CHARACTER(20) :: layout -REAL(DFP) :: x(1:3, 1:SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), 0:order) -REAL(DFP) :: Q1(SIZE(xij, 2), 0:order) -REAL(DFP) :: R1(SIZE(xij, 2), 0:order) -REAL(DFP) :: x2(SIZE(xij, 2), 0:order) -REAL(DFP) :: x3(SIZE(xij, 2), 0:order) -INTEGER(I4B) :: cnt -INTEGER(I4B) :: p, q, r - -layout = TRIM(UpperCase(refTetrahedron)) -SELECT CASE (TRIM(layout)) -CASE ("BIUNIT") - x = FromBiUnitTetrahedron2BiUnitHexahedron(xin=xij) -CASE ("UNIT") - x = FromUnitTetrahedron2BiUnitHexahedron(xin=xij) -END SELECT - -DO p = 0, order - x2(:, p) = 0.5_DFP * (1.0_DFP - x(2, :)) - x3(:, p) = 0.5_DFP * (1.0_DFP - x(3, :)) -END DO - -P1 = LegendreEvalAll(n=order, x=x(1, :)) - -cnt = 0 - -DO p = 0, order - - Q1 = (x2**p) * JacobiEvalAll( & - & n=order, & - & x=x(2, :), & - & alpha=REAL(2 * p + 1, DFP), & - & beta=0.0_DFP) - - DO q = 0, order - p - - R1 = (x3**(p + q)) * JacobiEvalAll( & - & n=order, & - & x=x(3, :), & - & alpha=REAL(2 * p + 2 * q + 2, DFP), & - & beta=0.0_DFP) - - DO r = 0, order - p - q - cnt = cnt + 1 - ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r) - END DO - END DO -END DO - -END PROCEDURE OrthogonalBasis_Tetrahedron1 - -!---------------------------------------------------------------------------- -! OrthogonalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasis_Tetrahedron2 -CHARACTER(20) :: layout -REAL(DFP) :: x0(SIZE(x)), y0(SIZE(y)), z0(SIZE(z)) -REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z)) -INTEGER(I4B) :: ii, jj, cnt, kk -REAL(DFP) :: P1(1:3, 0:order) -REAL(DFP) :: Q1(1:3, 0:order) -REAL(DFP) :: R1(1:3, 0:order) -REAL(DFP) :: x2(SIZE(xij, 2), 0:order) -REAL(DFP) :: x3(SIZE(xij, 2), 0:order) -INTEGER(I4B) :: p, q, r - -layout = TRIM(UpperCase(refTetrahedron)) - -SELECT CASE (TRIM(layout)) -CASE ("BIUNIT") - x0 = x - y0 = y - z0 = z -CASE ("UNIT") - x0 = FromUnitLine2BiUnitLine(xin=x) - y0 = FromUnitLine2BiUnitLine(xin=y) - z0 = FromUnitLine2BiUnitLine(xin=z) -END SELECT - -xij = 0.0_DFP -cnt = 0 -DO ii = 1, SIZE(x0) - DO jj = 1, SIZE(y0) - DO kk = 1, SIZE(z0) - cnt = cnt + 1 - xij(1, cnt) = x0(ii) - xij(2, cnt) = y0(jj) - xij(3, cnt) = z0(kk) - END DO - END DO -END DO - -DO p = 0, order - x2(:, p) = 0.5_DFP * (1.0_DFP - xij(2, :)) - x3(:, p) = 0.5_DFP * (1.0_DFP - xij(3, :)) -END DO - -P1 = LegendreEvalAll(n=order, x=xij(1, :)) - -cnt = 0 - -DO p = 0, order - - Q1 = (x2**p) * JacobiEvalAll( & - & n=order, & - & x=xij(2, :), & - & alpha=REAL(2 * p + 1, DFP), & - & beta=0.0_DFP) - - DO q = 0, order - p - - R1 = (x3**(p + q)) * JacobiEvalAll( & - & n=order, & - & x=xij(3, :), & - & alpha=REAL(2 * p + 2 * q + 2, DFP), & - & beta=0.0_DFP) - - DO r = 0, order - p - q - cnt = cnt + 1 - ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r) - END DO - END DO -END DO - -END PROCEDURE OrthogonalBasis_Tetrahedron2 - -!---------------------------------------------------------------------------- -! BarycentricVertexBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricVertexBasis_Tetrahedron -ans = TRANSPOSE(lambda(1:4, :)) -END PROCEDURE BarycentricVertexBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricVertexBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricVertexBasisGradient_Tetrahedron -INTEGER(I4B) :: ii -REAL(DFP) :: eye4_(4, 4) -eye4_ = eye(4_I4B, 1.0_DFP) -DO CONCURRENT(ii=1:SIZE(ans, 1)) - ans(ii, :, :) = eye4_ -END DO -END PROCEDURE BarycentricVertexBasisGradient_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron -REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) -REAL(DFP) :: phi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & pe1 - 2, & - & pe2 - 2, & - & pe3 - 2, & - & pe4 - 2, & - & pe5 - 2, & - & pe6 - 2)) -INTEGER(I4B) :: maxP, tPoints, i1, i2 - -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1 - -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) - -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) - -ans = BarycentricEdgeBasis_Tetrahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & lambda=lambda, & - & phi=phi & - & ) - -END PROCEDURE BarycentricEdgeBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Tetrahedron2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron2 -INTEGER(I4B) :: tPoints, a, ii, i1, i2 -REAL(DFP) :: temp(SIZE(lambda, 2)) - -ans = 0.0_DFP -tPoints = SIZE(temp) - -!! edge(1) = (v1, v2) -a = 0 -temp = lambda(1, :) * lambda(2, :) -i1 = 1 -i2 = i1 + tPoints - 1 -DO ii = 1, pe1 - 1 - a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) -END DO - -!! edge(2) = (v1, v3) -temp = lambda(1, :) * lambda(3, :) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -DO ii = 1, pe2 - 1 - a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) -END DO - -!! edge(3) = (v1, v4) -temp = lambda(1, :) * lambda(4, :) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -DO ii = 1, pe3 - 1 - a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) -END DO - -!! edge(4) = (v2, v3) -temp = lambda(2, :) * lambda(3, :) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -DO ii = 1, pe4 - 1 - a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) -END DO - -!! edge(5) = (v2, v4) -temp = lambda(2, :) * lambda(4, :) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -DO ii = 1, pe5 - 1 - a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) -END DO - -!! edge(5) = (v3, v4) -temp = lambda(3, :) * lambda(4, :) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -DO ii = 1, pe6 - 1 - a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) -END DO - -END PROCEDURE BarycentricEdgeBasis_Tetrahedron2 - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasisGradient_Tetrahedron2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricEdgeBasisGradient_Tetrahedron2 -INTEGER(I4B) :: a, ii, i1, i2, edges(2, 6), orders(6), iedge, v1, v2, & - & tPoints -REAL(DFP) :: temp(SIZE(lambda, 2), 6) - -tPoints = SIZE(lambda, 2) -ans = 0.0_DFP -a = 0 -i2 = 0 -temp(:, 1) = lambda(1, :) -temp(:, 2) = lambda(2, :) -temp(:, 3) = lambda(3, :) -temp(:, 4) = lambda(4, :) - -edges = EdgeConnectivity_Tetrahedron( & - & baseinterpol="Lagrange", & - & basecontinuity="H1") -orders = [pe1, pe2, pe3, pe4, pe5, pe6] - -DO iedge = 1, SIZE(edges, 2) - v1 = edges(1, iedge); v2 = edges(2, iedge) - temp(:, 5) = temp(:, v1) * temp(:, v2) - i1 = i2 + 1; i2 = i1 + tPoints - 1 - DO ii = 1, orders(iedge) - 1 - a = a + 1 - temp(:, 6) = temp(:, 5) * dphi(i1:i2, ii - 1) - ans(:, a, v1) = temp(:, v2) * phi(i1:i2, ii - 1) - temp(:, 6) - ans(:, a, v2) = temp(:, v1) * phi(i1:i2, ii - 1) + temp(:, 6) - END DO -END DO -END PROCEDURE BarycentricEdgeBasisGradient_Tetrahedron2 - -!---------------------------------------------------------------------------- -! BarycentricFacetBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron -REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) -REAL(DFP) :: phi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & ps1 - 1, & - & ps2 - 1, & - & ps3 - 1, & - & ps4 - 1)) -INTEGER(I4B) :: maxP, tPoints, i1, i2 - -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1 - -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) - -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) -ans = BarycentricFacetBasis_Tetrahedron2( & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4, & - & lambda=lambda, & - & phi=phi) - -END PROCEDURE BarycentricFacetBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricFacetBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron2 -REAL(DFP) :: temp(SIZE(lambda, 2)) -INTEGER(I4B) :: tPoints, i1, i2, ii, a -INTEGER(I4B) :: i21(2), i31(2), i41(2), i32(2), i42(2), i43(2) -INTEGER(I4B) :: facetConn(3, 4), fid, n1, n2, cnt, indx1(2, 4), indx2(2, 4) - -tPoints = SIZE(temp) - -i21 = [1, tPoints] -i31 = i21 + tPoints -i41 = i31 + tPoints -i32 = i41 + tPoints -i42 = i32 + tPoints -i43 = i42 + tPoints -facetConn = FacetConnectivity_Tetrahedron( & - & baseInterpol="HIERARCHY", & - & baseContinuity="H1") -indx1 = ((i21.rowconcat.i21) .rowconcat.i31) .rowconcat.i32 -indx2 = ((i31.rowconcat.i41) .rowconcat.i41) .rowconcat.i42 - -ans = 0.0_DFP -i2 = 0 -cnt = 0 - -!! Face1 -DO fid = 1, SIZE(facetConn, 2) - temp = lambda(facetConn(1, fid), :) & - & * lambda(facetConn(2, fid), :) & - & * lambda(facetConn(3, fid), :) - DO n1 = 1, ps1 - 1 - DO n2 = 1, ps1 - 1 - n1 - cnt = cnt + 1 - ans(:, cnt) = temp & - & * phi(indx1(1, fid):indx1(2, fid), n1 - 1) & - & * phi(indx2(1, fid):indx2(2, fid), n2 - 1) - END DO - END DO -END DO - -END PROCEDURE BarycentricFacetBasis_Tetrahedron2 - -!---------------------------------------------------------------------------- -! BarycentricFacetBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricFacetBasisGradient_Tetrahedron2 -REAL(DFP) :: temp(SIZE(lambda, 2), 8) -INTEGER(I4B) :: tPoints, i1, i2, ii, a, v1, v2, v3 -INTEGER(I4B) :: i21(2), i31(2), i41(2), i32(2), i42(2), i43(2) -INTEGER(I4B) :: facetConn(3, 4), fid, n1, n2, cnt, indx1(2, 4), indx2(2, 4) - -tPoints = SIZE(lambda, 2) -i21 = [1, tPoints] -i31 = i21 + tPoints -i41 = i31 + tPoints -i32 = i41 + tPoints -i42 = i32 + tPoints -i43 = i42 + tPoints -facetConn = FacetConnectivity_Tetrahedron( & - & baseInterpol="HIERARCHY", & - & baseContinuity="H1") -indx1 = ((i21.rowconcat.i21) .rowconcat.i31) .rowconcat.i32 -indx2 = ((i31.rowconcat.i41) .rowconcat.i41) .rowconcat.i42 - -ans = 0.0_DFP -cnt = 0 -temp(:, 1) = lambda(1, :) -temp(:, 2) = lambda(2, :) -temp(:, 3) = lambda(3, :) -temp(:, 4) = lambda(4, :) - -DO fid = 1, SIZE(facetConn, 2) - v1 = facetConn(1, fid) - v2 = facetConn(2, fid) - v3 = facetConn(3, fid) - i1 = indx1(1, fid) - i2 = indx1(1, fid) - temp(:, 5) = temp(:, v1) * temp(:, v2) * temp(:, v3) - - DO n1 = 1, ps1 - 1 - DO n2 = 1, ps1 - 1 - n1 - cnt = cnt + 1 - temp(:, 6) = phi(i1:i2, n1 - 1) * phi(i1:i2, n2 - 1) - temp(:, 7) = temp(:, 5) * dphi(i1:i2, n1 - 1) * phi(i1:i2, n2 - 1) - temp(:, 8) = temp(:, 5) * phi(i1:i2, n1 - 1) * dphi(i1:i2, n2 - 1) - - ans(:, cnt, v1) = temp(:, v2) * temp(:, v3) * temp(:, 6) & - & - temp(:, 7) - temp(:, 8) - - ans(:, cnt, v2) = temp(:, v1) * temp(:, v3) * temp(:, 6) & - & + temp(:, 7) - - ans(:, cnt, v3) = temp(:, v1) * temp(:, v2) * temp(:, 6) & - & + temp(:, 8) - END DO - END DO -END DO -END PROCEDURE BarycentricFacetBasisGradient_Tetrahedron2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCellBasis_Tetrahedron -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:pb) -INTEGER(I4B) :: maxP, tPoints, i1, i2 - -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1 - -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) - -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) -ans = BarycentricCellBasis_Tetrahedron2( & - & pb=pb, & - & lambda=lambda, & - & phi=phi) - -END PROCEDURE BarycentricCellBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricCellBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCellBasis_Tetrahedron2 -REAL(DFP) :: temp(SIZE(lambda, 2)) -INTEGER(I4B) :: tPoints -INTEGER(I4B) :: i21(2), i31(2), i41(2) -INTEGER(I4B) :: n1, n2, n3, cnt - -tPoints = SIZE(temp) - -i21 = [1, tPoints] -i31 = i21 + tPoints -i41 = i31 + tPoints - -ans = 0.0_DFP -cnt = 0 - -temp = lambda(1, :) & - & * lambda(2, :) & - & * lambda(3, :) & - & * lambda(4, :) - -DO n1 = 1, pb - 1 - DO n2 = 1, pb - 1 - n1 - DO n3 = 1, pb - 1 - n1 - n2 - cnt = cnt + 1 - ans(:, cnt) = temp & - & * phi(i21(1):i21(2), n1 - 1) & - & * phi(i31(1):i31(2), n2 - 1) & - & * phi(i41(1):i41(2), n3 - 1) - END DO - END DO -END DO - -END PROCEDURE BarycentricCellBasis_Tetrahedron2 - -!---------------------------------------------------------------------------- -! BarycentricCellBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCellBasisGradient_Tetrahedron2 -REAL(DFP) :: temp(SIZE(lambda, 2), 13) -INTEGER(I4B) :: tPoints -INTEGER(I4B) :: i21(2), i31(2), i41(2) -INTEGER(I4B) :: n1, n2, n3, cnt - -tPoints = SIZE(lambda, 2) -i21 = [1, tPoints] -i31 = i21 + tPoints -i41 = i31 + tPoints -ans = 0.0_DFP -cnt = 0 - -temp(:, 1) = lambda(1, :) -temp(:, 2) = lambda(2, :) -temp(:, 3) = lambda(3, :) -temp(:, 4) = lambda(4, :) -temp(:, 5) = PRODUCT(temp(:, 1:4), dim=2) -temp(:, 6) = PRODUCT(temp(:, [2, 3, 4]), dim=2) -temp(:, 7) = PRODUCT(temp(:, [1, 3, 4]), dim=2) -temp(:, 8) = PRODUCT(temp(:, [1, 2, 4]), dim=2) -temp(:, 9) = PRODUCT(temp(:, [1, 2, 3]), dim=2) - -DO n1 = 1, pb - 1 - DO n2 = 1, pb - 1 - n1 - DO n3 = 1, pb - 1 - n1 - n2 - cnt = cnt + 1 - temp(:, 10) = phi(i21(1):i21(2), n1 - 1) & - & * phi(i31(1):i31(2), n2 - 1) & - & * phi(i41(1):i41(2), n3 - 1) - - temp(:, 11) = temp(:, 5) * dphi(i21(1):i21(2), n1 - 1) & - & * phi(i31(1):i31(2), n2 - 1) & - & * phi(i41(1):i41(2), n3 - 1) - - temp(:, 12) = temp(:, 5) * phi(i21(1):i21(2), n1 - 1) & - & * dphi(i31(1):i31(2), n2 - 1) & - & * phi(i41(1):i41(2), n3 - 1) - - temp(:, 13) = temp(:, 5) * phi(i21(1):i21(2), n1 - 1) & - & * phi(i31(1):i31(2), n2 - 1) & - & * dphi(i41(1):i41(2), n3 - 1) - - ans(:, cnt, 1) = temp(:, 6) * temp(:, 10) & - &- temp(:, 11) - temp(:, 12) - temp(:, 13) - - ans(:, cnt, 2) = temp(:, 7) * temp(:, 10) + temp(:, 11) - ans(:, cnt, 3) = temp(:, 8) * temp(:, 10) + temp(:, 12) - ans(:, cnt, 4) = temp(:, 9) * temp(:, 10) + temp(:, 13) - END DO - END DO -END DO - -END PROCEDURE BarycentricCellBasisGradient_Tetrahedron2 - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1 -REAL(DFP) :: phi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & pe1 - 2, & - & pe2 - 2, & - & pe3 - 2, & - & pe4 - 2, & - & pe5 - 2, & - & pe6 - 2, & - & ps1 - 1, & - & ps2 - 1, & - & ps3 - 1, & - & ps4 - 1, & - & order & - & )) -REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) -INTEGER(I4B) :: a, b, maxP, tPoints, i1, i2 - -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1_I4B - -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) - -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) - -!! Vertex basis function -ans = 0.0_DFP -ans(:, 1:4) = BarycentricVertexBasis_Tetrahedron(lambda=lambda) -b = 4 - -!! Edge basis function -IF (ANY([pe1, pe2, pe3, pe4, pe5, pe6] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 - ans(:, a:b) = BarycentricEdgeBasis_Tetrahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & lambda=lambda, & - & phi=phi & - & ) -END IF - -!! Facet basis function -IF (ANY([ps1, ps2, ps3, ps4] .GE. 3_I4B)) THEN - a = b + 1 - b = a - 1 & - & + (ps1 - 1_I4B) * (ps1 - 2_I4B) / 2_I4B & - & + (ps2 - 1_I4B) * (ps2 - 2_I4B) / 2_I4B & - & + (ps3 - 1_I4B) * (ps3 - 2_I4B) / 2_I4B & - & + (ps4 - 1_I4B) * (ps4 - 2_I4B) / 2_I4B - - ans(:, a:b) = BarycentricFacetBasis_Tetrahedron2( & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4, & - & lambda=lambda, & - & phi=phi & - & ) -END IF - -!! Cell basis function -IF (order .GE. 4_I4B) THEN - a = b + 1 - b = a - 1 & - & + (order - 1_I4B) * (order - 2_I4B) * (order - 3_I4B) / 6_I4B - - ans(:, a:b) = BarycentricCellBasis_Tetrahedron2( & - & pb=order, & - & lambda=lambda, & - & phi=phi) -END IF -END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1 - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2 -ans = BarycentricHeirarchicalBasis_Tetrahedron( & - & order=order, & - & pe1=order, & - & pe2=order, & - & pe3=order, & - & pe4=order, & - & pe5=order, & - & pe6=order, & - & ps1=order, & - & ps2=order, & - & ps3=order, & - & ps4=order, & - & lambda=lambda & - & ) -END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2 - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron1 -REAL(DFP) :: phi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & pe1 - 2, & - & pe2 - 2, & - & pe3 - 2, & - & pe4 - 2, & - & pe5 - 2, & - & pe6 - 2, & - & ps1 - 1, & - & ps2 - 1, & - & ps3 - 1, & - & ps4 - 1, & - & order & - & )) -REAL(DFP) :: dphi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & pe1 - 2, & - & pe2 - 2, & - & pe3 - 2, & - & pe4 - 2, & - & pe5 - 2, & - & pe6 - 2, & - & ps1 - 1, & - & ps2 - 1, & - & ps3 - 1, & - & ps4 - 1, & - & order & - & )) -REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) -INTEGER(I4B) :: a, b, maxP, tPoints, i1, i2 - -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1_I4B - -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) - -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) - -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) -dphi = LobattoKernelGradientEvalAll(n=maxP, x=d_lambda) - -!! Vertex basis function -ans = 0.0_DFP -ans(:, 1:4, :) = BarycentricVertexBasisGradient_Tetrahedron(lambda=lambda) -b = 4 - -!! Edge basis function -IF (ANY([pe1, pe2, pe3, pe4, pe5, pe6] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 - ans(:, a:b, :) = BarycentricEdgeBasisGradient_Tetrahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & lambda=lambda, & - & phi=phi, & - & dphi=dphi & - & ) -END IF - -!! Facet basis function -IF (ANY([ps1, ps2, ps3, ps4] .GE. 3_I4B)) THEN - a = b + 1 - b = a - 1 & - & + (ps1 - 1_I4B) * (ps1 - 2_I4B) / 2_I4B & - & + (ps2 - 1_I4B) * (ps2 - 2_I4B) / 2_I4B & - & + (ps3 - 1_I4B) * (ps3 - 2_I4B) / 2_I4B & - & + (ps4 - 1_I4B) * (ps4 - 2_I4B) / 2_I4B - - ans(:, a:b, :) = BarycentricFacetBasisGradient_Tetrahedron2( & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4, & - & lambda=lambda, & - & phi=phi, & - & dphi=dphi & - & ) -END IF - -!! Cell basis function -IF (order .GE. 4_I4B) THEN - a = b + 1 - b = a - 1 & - & + (order - 1_I4B) * (order - 2_I4B) * (order - 3_I4B) / 6_I4B - - ans(:, a:b, :) = BarycentricCellBasisGradient_Tetrahedron2( & - & pb=order, & - & lambda=lambda, & - & phi=phi, dphi=dphi) -END IF -END PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron1 - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron2 -ans = BarycentricHeirarchicalBasisGradient_Tetrahedron( & - & order=order, & - & pe1=order, & - & pe2=order, & - & pe3=order, & - & pe4=order, & - & pe5=order, & - & pe6=order, & - & ps1=order, & - & ps2=order, & - & ps3=order, & - & ps4=order, & - & lambda=lambda & - & ) -END PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron2 - -!---------------------------------------------------------------------------- -! VertexBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Tetrahedron -ans = BarycentricVertexBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron)) -END PROCEDURE VertexBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! EdgeBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeBasis_Tetrahedron -ans = BarycentricEdgeBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6) -END PROCEDURE EdgeBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! FacetBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetBasis_Tetrahedron -ans = BarycentricFacetBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4) -END PROCEDURE FacetBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! CellBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Tetrahedron -ans = BarycentricCellBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & pb=pb) -END PROCEDURE CellBasis_Tetrahedron - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Tetrahedron1 -ans = BarycentricHeirarchicalBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & order=order, & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4) -END PROCEDURE HeirarchicalBasis_Tetrahedron1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Tetrahedron2 -ans = BarycentricHeirarchicalBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & order=order) -END PROCEDURE HeirarchicalBasis_Tetrahedron2 - -!---------------------------------------------------------------------------- -! LagrangeEvallAll_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Tetrahedron1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) -TYPE(String) :: ref0 - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) -ref0 = INPUT(default="UNIT", option=refTetrahedron) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) - coeff0 = TRANSPOSE(coeff) - ELSE - coeff0 = TRANSPOSE(coeff) - END IF -ELSE - coeff0 = TRANSPOSE( & - & LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & )) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Tetrahedron(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Tetrahedron1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 1, tdof - xx(1, ii) = x(1)**degree(ii, 1) & - & * x(2)**degree(ii, 2) & - & * x(3)**degree(ii, 3) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasis_Tetrahedron( & - & order=order, & - & xij=RESHAPE(x, [3, 1]), & - & refTetrahedron=ref0%chars()) - -CASE DEFAULT - xx = OrthogonalBasis_Tetrahedron( & - & order=order, & - & xij=RESHAPE(x, [3, 1]), & - & refTetrahedron=ref0%chars() & - & ) - -END SELECT - -ans = MATMUL(coeff0, xx(1, :)) - -END PROCEDURE LagrangeEvalAll_Tetrahedron1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Tetrahedron2 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) -REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) -TYPE(String) :: ref0 - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) -ref0 = INPUT(default="UNIT", option=refTetrahedron) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) - END IF - coeff0 = coeff -ELSE - coeff0 = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Tetrahedron(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Tetrahedron1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 1, tdof - xx(:, ii) = x(1, :)**degree(ii, 1) & - & * x(2, :)**degree(ii, 2) & - & * x(3, :)**degree(ii, 3) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasis_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars()) - -CASE DEFAULT - - xx = OrthogonalBasis_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars() & - & ) - -END SELECT - -ans = MATMUL(xx, coeff0) - -END PROCEDURE LagrangeEvalAll_Tetrahedron2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Tetrahedron1 -REAL(DFP), ALLOCATABLE :: temp_t(:, :) -TYPE(string) :: astr - -IF (order .LE. MAX_ORDER_TETRAHEDRON_SOLIN) THEN - astr = TRIM(UpperCase(refTetrahedron)) - temp_t = QuadraturePointTetrahedronSolin(order=order) - CALL Reallocate(ans, 4_I4B, SIZE(temp_t, 2, kind=I4B)) - - IF (PRESENT(xij)) THEN - ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & - & xin=temp_t(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4) & - & ) - - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="TETRAHEDRON", & - & xij=xij) - - ELSE - - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :)) - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="BIUNIT") - - ELSE - ans = temp_t - END IF - END IF - - IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) -ELSE - ans = TensorQuadraturepoint_Tetrahedron( & - & order=order, & - & quadtype=quadtype, & - & refTetrahedron=refTetrahedron, & - & xij=xij) -END IF -END PROCEDURE QuadraturePoint_Tetrahedron1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Tetrahedron2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Tetrahedron2 -INTEGER(I4B) :: order -order = QuadratureOrderTetrahedronSolin(nips(1)) -IF (order .LT. 0) THEN - ans = Quadraturepoint_Tetrahedron1( & - & order=order, & - & quadtype=quadType, & - & refTetrahedron=refTetrahedron, & - & xij=xij) -ELSE - CALL Errormsg(& - & msg="This routine is available for nips = [ & - & 1, 4, 5, 11, 14, 24, 31, 43, 53, 126, 210, 330, 495, 715, 1001] & - & TRY CALLING TensorQuadraturePoint_Tetrahedron() instead.", & - & file=__FILE__, & - & routine="QuadraturePoint_Tetrahedron2()", & - & line=__LINE__, & - & unitno=stderr) -END IF -END PROCEDURE QuadraturePoint_Tetrahedron2 - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron1 -INTEGER(I4B) :: n(4) -n = 1_I4B + INT(order / 2, kind=I4B) -n(2) = n(2) + 1 -ans = TensorQuadraturePoint_Tetrahedron2( & - & nipsx=n(1), & - & nipsy=n(2), & - & nipsz=n(3), & - & quadType=quadType, & - & refTetrahedron=refTetrahedron, & - & xij=xij) -END PROCEDURE TensorQuadraturePoint_Tetrahedron1 - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron2 -INTEGER(I4B) :: n(3), nsd -REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :) -TYPE(String) :: astr - -astr = TRIM(UpperCase(refTetrahedron)) -n(1) = nipsx(1) -n(2) = nipsy(1) -n(3) = nipsz(1) - -temp_q = QuadraturePoint_Hexahedron(& - & nipsx=n(1:1), & - & nipsy=n(2:2), & - & nipsz=n(3:3), & - & quadType1=GaussLegendreLobatto, & - & quadType2=GaussJacobiRadauLeft, & - & quadType3=GaussJacobiRadauLeft, & - & refHexahedron="BIUNIT", & - & alpha2=1.0_DFP, & - & beta2=0.0_DFP, & - & alpha3=2.0_DFP, & - & beta3=0.0_DFP) - -CALL Reallocate(temp_t, SIZE(temp_q, 1, KIND=I4B), SIZE(temp_q, 2, KIND=I4B)) -temp_t(1:3, :) = FromBiUnitHexahedron2UnitTetrahedron(xin=temp_q(1:3, :)) -temp_t(4, :) = temp_q(4, :) / 8.0_DFP -nsd = 3_I4B -CALL Reallocate(ans, 4_I4B, SIZE(temp_q, 2, KIND=I4B)) - -IF (PRESENT(xij)) THEN - ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & - & xin=temp_t(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4) & - & ) - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="TETRAHEDRON", & - & xij=xij) -ELSE - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :)) - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="BIUNIT") - ELSE - ans = temp_t - END IF -END IF - -IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q) -IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) -END PROCEDURE TensorQuadraturePoint_Tetrahedron2 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Tetrahedron1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci -INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr -TYPE(String) :: ref0 - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) -ref0 = INPUT(default="UNIT", option=refTetrahedron) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) - END IF - coeff0 = coeff -ELSE - coeff0 = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - degree = LagrangeDegree_Tetrahedron(order=order) - tdof = SIZE(xij, 2) - - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Tetrahedron1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 1, tdof - ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) - bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) - ci = MAX(degree(ii, 3_I4B) - 1_I4B, 0_I4B) - - ar = REAL(degree(ii, 1_I4B), DFP) - br = REAL(degree(ii, 2_I4B), DFP) - cr = REAL(degree(ii, 3_I4B), DFP) - - xx(:, ii, 1) = (ar * x(1, :)**ai) * & - & x(2, :)**degree(ii, 2) * & - & x(3, :)**degree(ii, 3) - - xx(:, ii, 2) = x(1, :)**degree(ii, 1) * & - & (br * x(2, :)**bi) * & - & x(3, :)**degree(ii, 3) - - xx(:, ii, 3) = x(1, :)**degree(ii, 1) * & - & x(2, :)**degree(ii, 2) * & - & (cr * x(2, :)**ci) - END DO - -CASE (Heirarchical) - - xx = HeirarchicalBasisGradient_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars()) - -CASE DEFAULT - - xx = OrthogonalBasisGradient_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars() & - & ) - -END SELECT - -DO ii = 1, 3 - ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) -END DO - -END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1 - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasisGradient_Tetrahedron1 -CHARACTER(20) :: layout -REAL(DFP) :: x(1:3, 1:SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), 0:order) -REAL(DFP) :: Q1(SIZE(xij, 2), 0:order) -REAL(DFP) :: R1(SIZE(xij, 2), 0:order) -REAL(DFP) :: dP1(SIZE(xij, 2), 0:order) -REAL(DFP) :: dQ1(SIZE(xij, 2), 0:order) -REAL(DFP) :: dR1(SIZE(xij, 2), 0:order) -REAL(DFP) :: temp(SIZE(xij, 2), 10), areal, breal -INTEGER(I4B) :: cnt -INTEGER(I4B) :: p, q, r -LOGICAL(LGT) :: isBiunit -REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), SIZE(ans, 3)) - -ans0 = 0.0_DFP -layout = TRIM(UpperCase(refTetrahedron)) -SELECT CASE (TRIM(layout)) -CASE ("BIUNIT") - x = FromBiUnitTetrahedron2BiUnitHexahedron(xin=xij) - isBiunit = .TRUE. -CASE ("UNIT") - x = FromUnitTetrahedron2BiUnitHexahedron(xin=xij) - isBiunit = .FALSE. -END SELECT - -temp(:, 1) = 0.5_DFP * (1.0_DFP - x(2, :)) -temp(:, 2) = 0.5_DFP * (1.0_DFP - x(3, :)) - -P1 = LegendreEvalAll(n=order, x=x(1, :)) -dP1 = LegendreGradientEvalAll(n=order, x=x(1, :)) -cnt = 0 - -DO p = 0, order - areal = -0.5_DFP * REAL(p, DFP) - - Q1 = JacobiEvalAll( & - & n=order, & - & x=x(2, :), & - & alpha=REAL(2 * p + 1, DFP), & - & beta=0.0_DFP & - & ) - - dQ1 = JacobiGradientEvalAll( & - & n=order, & - & x=x(2, :), & - & alpha=REAL(2 * p + 1, DFP), & - & beta=0.0_DFP & - & ) - - temp(:, 3) = temp(:, 1)**MAX(p - 1_I4B, 0_I4B) - temp(:, 4) = temp(:, 3) * temp(:, 1) - - DO q = 0, order - p - - breal = -0.5_DFP * REAL(p + q, DFP) - - R1 = JacobiEvalAll( & - & n=order, & - & x=x(3, :), & - & alpha=REAL(2 * p + 2 * q + 2, DFP), & - & beta=0.0_DFP & - & ) - - dR1 = JacobiGradientEvalAll( & - & n=order, & - & x=x(3, :), & - & alpha=REAL(2 * p + 2 * q + 2, DFP), & - & beta=0.0_DFP & - & ) - - temp(:, 5) = P1(:, p) * Q1(:, q) - temp(:, 6) = P1(:, p) * dQ1(:, q) - temp(:, 7) = dP1(:, p) * Q1(:, q) - temp(:, 9) = temp(:, 2)**MAX(p + q - 1_I4B, 0_I4B) - temp(:, 10) = temp(:, 9) * temp(:, 2) - - DO r = 0, order - p - q - temp(:, 8) = temp(:, 5) * R1(:, r) - cnt = cnt + 1 - ans0(:, cnt, 1) = temp(:, 7) * R1(:, r) * temp(:, 4) * temp(:, 10) - ans0(:, cnt, 2) = temp(:, 8) * areal * temp(:, 3) * temp(:, 10) & - & + temp(:, 6) * R1(:, r) * temp(:, 4) * temp(:, 10) - ans0(:, cnt, 2) = temp(:, 8) * breal * temp(:, 4) * temp(:, 9) & - & + temp(:, 5) * dR1(:, r) * temp(:, 4) * temp(:, 10) - END DO - END DO -END DO - -IF (isBiunit) THEN - temp(:, 1) = x(1, :) - temp(:, 2) = x(2, :) - temp(:, 3) = x(3, :) - - temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3)) - temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3)) - temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3)) - temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2 - - DO CONCURRENT(p=1:SIZE(ans, 2)) - ans(:, p, 1) = -temp(:, 4) * ans0(:, p, 1) - ans(:, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2) - ans(:, p, 3) = temp(:, 5) * ans0(:, p, 1) & - & + temp(:, 7) * ans0(:, p, 2) & - & + ans0(:, p, 3) - END DO - -ELSE - - temp(:, 1:3) = FromUnitTetrahedron2BiUnitTetrahedron(x) - - temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3)) - temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3)) - temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3)) - temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2 - - DO CONCURRENT(p=1:SIZE(ans, 2)) - ans(:, p, 1) = -temp(:, 4) * ans0(:, p, 1) - ans(:, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2) - ans(:, p, 3) = temp(:, 5) * ans0(:, p, 1) & - & + temp(:, 7) * ans0(:, p, 2) & - & + ans0(:, p, 3) - END DO - - ans = 2.0_DFP * ans - -END IF - -END PROCEDURE OrthogonalBasisGradient_Tetrahedron1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron1 -TYPE(String) :: name -REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), 4) -ans0 = BarycentricHeirarchicalBasisGradient_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & order=order, & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4) - -ans(:, :, 1) = ans0(:, :, 2) - ans0(:, :, 1) -ans(:, :, 2) = ans0(:, :, 3) - ans0(:, :, 1) -ans(:, :, 3) = ans0(:, :, 4) - ans0(:, :, 1) - -name = UpperCase(refTetrahedron) -IF (name == "BIUNIT") THEN - ans = 0.5_DFP * ans -END IF -END PROCEDURE HeirarchicalBasisGradient_Tetrahedron1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron2 -ans = HeirarchicalBasisGradient_Tetrahedron1( & - & order=order, & - & pe1=order, & - & pe2=order, & - & pe3=order, & - & pe4=order, & - & pe5=order, & - & pe6=order, & - & ps1=order, & - & ps2=order, & - & ps3=order, & - & ps4=order, & - & xij=xij, & - & refTetrahedron=refTetrahedron) -END PROCEDURE HeirarchicalBasisGradient_Tetrahedron2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -! -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 deleted file mode 100644 index df48713f1..000000000 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 +++ /dev/null @@ -1,666 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(TriangleInterpolationUtility) HeirarchicalBasisMethods -USE LobattoPolynomialUtility, ONLY: LobattoKernelEvalAll_, & - LobattoKernelGradientEvalAll_ -USE MappingUtility, ONLY: BarycentricCoordTriangle_ - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! BarycentricVertexBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricVertexBasis_Triangle -INTEGER(I4B) :: a(2) -a = SHAPE(lambda) -ans(1:a(2), 1:a(1)) = TRANSPOSE(lambda) -END PROCEDURE BarycentricVertexBasis_Triangle - -!---------------------------------------------------------------------------- -! VertexBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Triangle -REAL(DFP) :: lambda(3, SIZE(xij, 2)) -CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans) -END PROCEDURE VertexBasis_Triangle - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricEdgeBasis_Triangle -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) -INTEGER(I4B) :: maxP, tPoints, ii, jj - -tPoints = SIZE(lambda, 2) -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) - -DO CONCURRENT(ii=1:tpoints) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) -END DO - -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=ii, ncol=jj) - -CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, ans=ans) - -END PROCEDURE BarycentricEdgeBasis_Triangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 30 Oct 2022 -! summary: Evaluate the edge basis on triangle using barycentric coordinate -! (internal only) - -MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & - lambda, phi, ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP), INTENT(INOUT) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) - - INTEGER(I4B) :: tPoints, a, ii - REAL(DFP) :: temp(SIZE(lambda, 2)) - !FIXME: Remove this temp, I want no allocation in this routine - - ans = 0.0_DFP - tPoints = SIZE(lambda, 2) - a = 0 - - !FIXME: Make these loop parallel - - ! edge(1) = 1 -> 2 - temp = lambda(1, :) * lambda(2, :) - DO ii = 1, pe1 - 1 - ans(:, a + ii) = temp * phi(1:tPoints, ii - 1) - END DO - - ! edge(2) = 2 -> 3 - a = pe1 - 1 - temp = lambda(2, :) * lambda(3, :) - DO ii = 1, pe2 - 1 - ans(:, a + ii) = temp & - * phi(1 + tPoints:2 * tPoints, ii - 1) - END DO - - ! edge(3) = 3 -> 1 - a = pe1 - 1 + pe2 - 1 - temp = lambda(3, :) * lambda(1, :) - DO ii = 1, pe3 - 1 - ans(:, a + ii) = temp & - * phi(1 + 2 * tPoints:3 * tPoints, ii - 1) - END DO -END SUBROUTINE BarycentricEdgeBasis_Triangle2 - -!---------------------------------------------------------------------------- -! EdgeBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EdgeBasis_Triangle -REAL(DFP) :: lambda(3, SIZE(xij, 2)) -CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricEdgeBasis_Triangle(lambda=lambda, ans=ans, pe1=pe1, & - pe2=pe2, pe3=pe3) -END PROCEDURE EdgeBasis_Triangle - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCellBasis_Triangle -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:order - 2) -INTEGER(I4B) :: maxP, tPoints, ii, nrow, ncol - -tPoints = SIZE(lambda, 2) -maxP = order - 2 - -DO CONCURRENT(ii=1:tpoints) - ! Cell 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! Cell 2 -> 3 - d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) - ! Cell 3 -> 1 - d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) -END DO - -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=ans, nrow=nrow, ncol=ncol) - -CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & - ans=ans) - -END PROCEDURE BarycentricCellBasis_Triangle - -!---------------------------------------------------------------------------- -! BarycentricCellBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis in the cell of reference triangle (internal only) - -PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barcentric coordinates - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points - !! (lambda2-lambda1), - !! (lambda3-lambda2), - !! (lambda1-lambda3) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) - - INTEGER(I4B) :: tp, k1, k2, cnt - REAL(DFP) :: temp(SIZE(lambda, 2)) - !! FIXME: Remove this temp from there, no allocation is our goal - - tp = SIZE(lambda, 2) - temp = lambda(1, :) * lambda(2, :) * lambda(3, :) - cnt = 0 - - ! FIXME: Make this loop parallel - - DO k1 = 1, order - 2 - DO k2 = 1, order - 1 - k1 - cnt = cnt + 1 - ans(:, cnt) = temp * phi(1:tp, k1 - 1) * & - & phi(1 + 2 * tp:3 * tp, k2 - 1) - END DO - END DO - -END SUBROUTINE BarycentricCellBasis_Triangle2 - -!---------------------------------------------------------------------------- -! CellBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Triangle -REAL(DFP) :: lambda(3, SIZE(xij, 2)) -CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricCellBasis_Triangle(lambda=lambda, ans=ans, order=order) -END PROCEDURE CellBasis_Triangle - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle1 -INTEGER(I4B) :: a, b, ii -INTEGER(I4B) :: maxP -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), & - 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)) -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -LOGICAL(LGT) :: isok - -nrow = SIZE(lambda, 2) -ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) - -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) - -DO CONCURRENT(ii=1:nrow) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii) -END DO - -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) - -! Vertex basis function -ans = 0.0_DFP -CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3)) - -! Edge basis function -b = 3 - -isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) -IF (isok) THEN - a = b + 1 - b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 - CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, ans=ans(:, a:b)) -END IF - -! Cell basis function -IF (order .GT. 2_I4B) THEN - a = b + 1 - b = a - 1 + INT((order - 1) * (order - 2) / 2) - CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & - ans=ans(:, a:b)) -END IF - -END PROCEDURE BarycentricHeirarchicalBasis_Triangle1 - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2 -CALL BarycentricHeirarchicalBasis_Triangle1(order=order, pe1=order, & - pe2=order, pe3=order, lambda=lambda, & - refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE BarycentricHeirarchicalBasis_Triangle2 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Triangle1 -INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Triangle1_(order=order, pe1=pe1, pe2=pe2, pe3=pe3, & - xij=xij, refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Triangle1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Triangle1_ -REAL(DFP) :: lambda(3, SIZE(xij, 2)) -CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricHeirarchicalBasis_Triangle(order=order, pe1=pe1, pe2=pe2, & - pe3=pe3, lambda=lambda, refTriangle=refTriangle, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE HeirarchicalBasis_Triangle1_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Triangle2 -INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Triangle2_(order=order, xij=xij, & - refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Triangle2 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Triangle2_ -REAL(DFP) :: lambda(3, SIZE(xij, 2)) -CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricHeirarchicalBasis_Triangle(order=order, lambda=lambda, & - refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Triangle2_ - -!---------------------------------------------------------------------------- -! BarycentricVertexBasisGradient_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricVertexBasisGradient_Triangle -INTEGER(I4B) :: ii, tp - -tp = SIZE(lambda, 2) -ans(1:tp, 1:3, 1:3) = 0.0_DFP -DO CONCURRENT(ii=1:3) - ans(1:tp, ii, ii) = 1.0_DFP -END DO - -END PROCEDURE BarycentricVertexBasisGradient_Triangle - -!---------------------------------------------------------------------------- -! BarycentricEdgeBasisGradient_Triangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricEdgeBasisGradient_Triangle -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) -REAL(DFP) :: gradientPhi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) -INTEGER(I4B) :: maxP, tPoints, ii, a, b - -tPoints = SIZE(lambda, 2) -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) - -DO CONCURRENT(ii=1:tpoints) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) -END DO - -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) - -CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & - nrow=a, ncol=b) - -CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans) - -END PROCEDURE BarycentricEdgeBasisGradient_Triangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu and Vikas Sharma, Ph. D. -! date: 2024-04-21 -! summary: Evaluate the gradient of the edge basis on triangle -! using barycentric coordinate - -PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle2(pe1, pe2, pe3, & - lambda, phi, gradientPhi, ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:) - !! gradients of lobatto kernel functions - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) - - INTEGER(I4B) :: tp, a, ii - REAL(DFP) :: temp(SIZE(lambda, 2)) - ! FIXME: Remove this temp - - tp = SIZE(lambda, 2) - - !FIXME: Make these loop parallel - - a = 0 - ! edge(1) = 1 -> 2 - temp = lambda(1, :) * lambda(2, :) - DO ii = 1, pe1 - 1 - ans(1:tp, a + ii, 1) = lambda(2, :) * phi(1:tp, ii - 1) - & - temp * gradientPhi(1:tp, ii - 1) - ans(1:tp, a + ii, 2) = lambda(1, :) * phi(1:tp, ii - 1) + & - temp * gradientPhi(1:tp, ii - 1) - ans(1:tp, a + ii, 3) = 0.0_DFP - END DO - - ! edge(2) = 2 -> 3 - a = pe1 - 1 - temp = lambda(2, :) * lambda(3, :) - DO ii = 1, pe2 - 1 - ans(1:tp, a + ii, 1) = 0.0_DFP - - ans(1:tp, a + ii, 2) = lambda(3, :) * & - phi(1 + tp:2 * tp, ii - 1) - & - temp * gradientPhi(1 + tp:2 * tp, ii - 1) - - ans(1:tp, a + ii, 3) = lambda(2, :) * & - phi(1 + tp:2 * tp, ii - 1) + & - temp * gradientPhi(1 + tp:2 * tp, ii - 1) - END DO - - ! edge(3) = 3 -> 1 - a = pe1 - 1 + pe2 - 1 - temp = lambda(3, :) * lambda(1, :) - DO ii = 1, pe3 - 1 - ans(1:tp, a + ii, 1) = lambda(3, :) * & - phi(1 + 2 * tp:3 * tp, ii - 1) + & - temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1) - - ans(1:tp, a + ii, 2) = 0.0_DFP - - ans(1:tp, a + ii, 3) = lambda(1, :) * & - phi(1 + 2 * tp:3 * tp, ii - 1) - & - temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1) - END DO -END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2 - -!---------------------------------------------------------------------------- -! BarycentricVertexBasisGradient_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCellBasisGradient_Triangle -INTEGER(I4B) :: a, b, ii, maxP, tp -REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) - -tp = SIZE(lambda, 2) -maxP = order - 2 - -a = 3 * tp; b = maxP -ALLOCATE (phi(a, b), gradientPhi(a, b), d_lambda(a)) - -DO CONCURRENT(ii=1:tp) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii) -END DO - -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) - -CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & - nrow=a, ncol=b) - -CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & - phi=phi, gradientPhi=gradientPhi, ans=ans) -END PROCEDURE BarycentricCellBasisGradient_Triangle - -!---------------------------------------------------------------------------- -! BarycentricCellBasisGradient_Triangle -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-04-21 -! summary: Evaluate the gradient of the cell basis on triangle - -PURE SUBROUTINE BarycentricCellBasisGradient_Triangle2(order, lambda, phi, & - gradientPhi, ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation - REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 - REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:) - !! gradients of lobatto kernel functions - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2), 3) - - ! internal variables - INTEGER(I4B) :: tPoints, k1, k2, cnt - REAL(DFP) :: temp1(SIZE(lambda, 2)), temp2(SIZE(lambda, 2)) - REAL(DFP) :: temp3(SIZE(lambda, 2)), temp4(SIZE(lambda, 2)) - - ! FIXME: Remove these temps - - tPoints = SIZE(lambda, 2) - temp1 = lambda(1, :) * lambda(2, :) * lambda(3, :) - temp2 = lambda(2, :) * lambda(3, :) - temp3 = lambda(1, :) * lambda(3, :) - temp4 = lambda(1, :) * lambda(2, :) - cnt = 0 - - ! FIXME: make these loop parallel - - DO k1 = 1, order - 2 - DO k2 = 1, order - 1 - k1 - cnt = cnt + 1 - ans(:, cnt, 1) = temp2 * phi(1:tPoints, k1 - 1) * & - phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & - temp1 * (gradientPhi(1:tPoints, k1 - 1) * & - phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & - phi(1:tPoints, k1 - 1) * & - gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1)) - ans(:, cnt, 2) = (temp3 * phi(1:tPoints, k1 - 1) + & - temp1 * gradientPhi(1:tPoints, k1 - 1)) * & - phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - ans(:, cnt, 3) = (temp4 * phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & - temp1 * gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1)) * & - phi(1:tPoints, k1 - 1) - END DO - END DO -END SUBROUTINE BarycentricCellBasisGradient_Triangle2 - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1 -INTEGER(I4B) :: a, b, ii, maxP, tp -REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) -LOGICAL(LGT) :: isok - -tp = SIZE(lambda, 2) -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) - -a = 3 * tp; b = maxP -ALLOCATE (phi(a, 0:b), gradientPhi(a, 0:b), d_lambda(a)) - -DO CONCURRENT(ii=1:tp) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii) -END DO - -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) - -CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & - nrow=a, ncol=b) - -! gradient of vertex basis -ans(1:tp, 1:3, 1:3) = 0.0_DFP -DO CONCURRENT(ii=1:3) - ans(1:tp, ii, ii) = 1.0_DFP -END DO - -! gradient of Edge basis function -b = 3 -isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) -IF (isok) THEN - a = b + 1 - b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 - CALL BarycentricEdgeBasisGradient_Triangle2( & - pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, & - phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :)) -END IF - -! gradient of Cell basis function -IF (order .GT. 2_I4B) THEN - a = b + 1 - b = a - 1 + INT((order - 1) * (order - 2) / 2) - CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & - phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :)) -END IF - -DEALLOCATE (phi, gradientPhi, d_lambda) -END PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1 -INTEGER(I4B) :: s(3) -CALL HeirarchicalBasisGradient_Triangle1_(order=order, pe1=pe1, & - pe2=pe2, pe3=pe3, xij=xij, refTriangle=refTriangle, ans=ans, tsize1=s(1), & - tsize2=s(2), tsize3=s(3)) -END PROCEDURE HeirarchicalBasisGradient_Triangle1 - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1_ -REAL(DFP) :: jac(3, 2) -REAL(DFP), ALLOCATABLE :: lambda(:, :), dPhi(:, :, :) -INTEGER(I4B) :: ii, jj, kk - -ii = SIZE(xij, 2) -jj = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) -ALLOCATE (lambda(3, ii), dPhi(ii, jj, 3)) -tsize1 = SIZE(xij, 2) -tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) -tsize3 = 2 - -CALL BarycentricCoordTriangle_(xin=xij, refTriangle=refTriangle, ans=lambda) -CALL BarycentricHeirarchicalBasisGradient_Triangle( & - order=order, pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, & - refTriangle=refTriangle, ans=dPhi) - -SELECT CASE (refTriangle(1:1)) -CASE ("B", "b") - jac(1, :) = [-0.50_DFP, -0.50_DFP] - jac(2, :) = [0.50_DFP, 0.0_DFP] - jac(3, :) = [0.0_DFP, 0.50_DFP] -CASE ("U", "u") - jac(1, :) = [-1.0_DFP, -1.0_DFP] - jac(2, :) = [1.0_DFP, 0.0_DFP] - jac(3, :) = [0.0_DFP, 1.0_DFP] -END SELECT - -DO CONCURRENT(ii=1:tsize1, jj=1:tsize2, kk=1:tsize3) - ans(ii, jj, kk) = dPhi(ii, jj, 1) * jac(1, kk) & - + dPhi(ii, jj, 2) * jac(2, kk) & - + dPhi(ii, jj, 3) * jac(3, kk) -END DO - -DEALLOCATE (lambda, dPhi) - -END PROCEDURE HeirarchicalBasisGradient_Triangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE HeirarchicalBasisMethods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 deleted file mode 100644 index 50fd1448c..000000000 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ /dev/null @@ -1,346 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(TriangleInterpolationUtility) LagrangeBasisMethods -USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_ -USE ErrorHandling, ONLY: Errormsg -USE InputUtility, ONLY: Input -USE GE_CompRoutineMethods, ONLY: GetInvMat -USE GE_LUMethods, ONLY: LUSolve, GetLU - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! LagrangeDegree_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Triangle -INTEGER(I4B) :: nrow, ncol -nrow = (order + 1) * (order + 2) / 2_I4B -ncol = 2 -ALLOCATE (ans(nrow, ncol)) -CALL LagrangeDegree_Triangle_(order=order, ans=ans, ncol=ncol, nrow=nrow) -END PROCEDURE LagrangeDegree_Triangle - -!---------------------------------------------------------------------------- -! LagrangeDegree_Triangle_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Triangle_ -INTEGER(I4B) :: ii, jj, kk - -nrow = (order + 1) * (order + 2) / 2_I4B -ncol = 2 - -kk = 0 -DO jj = 0, order - DO ii = 0, order - jj - kk = kk + 1 - ans(kk, 1) = ii - ans(kk, 2) = jj - END DO -END DO - -END PROCEDURE LagrangeDegree_Triangle_ - -!---------------------------------------------------------------------------- -! LagrangeDOF_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Triangle -ans = (order + 1) * (order + 2) / 2_I4B -END PROCEDURE LagrangeDOF_Triangle - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Triangle -ans = (order - 1) * (order - 2) / 2_I4B -END PROCEDURE LagrangeInDOF_Triangle - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Triangle1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info, nrow, ncol - -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP - -CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, ans=V, & - nrow=nrow, ncol=ncol) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Triangle1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Triangle2 -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info - -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Triangle2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Triangle3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Triangle3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Triangle4 -INTEGER(I4B) :: basisType0, nrow, ncol -CHARACTER(:), ALLOCATABLE :: ref0 - -basisType0 = Input(default=Monomial, option=basisType) -ref0 = Input(default="UNIT", option=refTriangle) -CALL LagrangeCoeff_Triangle4_(order=order, xij=xij, basisType=basisType0, & - refTriangle=ref0, ans=ans, nrow=nrow, ncol=ncol) -ref0 = "" -END PROCEDURE LagrangeCoeff_Triangle4 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Triangle4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Triangle4_ - -SELECT CASE (basisType) - -CASE (Monomial) - CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, & - ans=ans, nrow=nrow, ncol=ncol) - -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) - - CALL Dubiner_Triangle_(order=order, xij=xij, refTriangle=refTriangle, & - ans=ans, nrow=nrow, ncol=ncol) - -CASE (Heirarchical) - - CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=xij, refTriangle=refTriangle, & - ans=ans, nrow=nrow, ncol=ncol) -END SELECT - -CALL GetInvMat(ans(1:nrow, 1:ncol)) - -END PROCEDURE LagrangeCoeff_Triangle4_ - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Triangle1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) - -basisType0 = Input(default=Monomial, option=basisType) -firstCall0 = Input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - - IF (firstCall0) THEN - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, & - basisType=basisType0, refTriangle=refTriangle, & - ans=coeff, nrow=nrow, ncol=ncol) - coeff0 = TRANSPOSE(coeff) - ELSE - coeff0 = TRANSPOSE(coeff) - END IF - -ELSE - - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, & - basisType=basisType0, refTriangle=refTriangle, & - ans=coeff0, nrow=nrow, ncol=ncol) - coeff0 = TRANSPOSE(coeff0) - -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) - - tdof = SIZE(xij, 2) - - DO ii = 1, tdof - xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) - END DO - -CASE (Heirarchical) - - CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, & - pe2=order, pe3=order, xij=RESHAPE(x, [2, 1]), & - refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) - -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) - - CALL Dubiner_Triangle_(order=order, xij=RESHAPE(x, [2, 1]), & - refTriangle=refTriangle, ans=xx, nrow=nrow, ncol=ncol) - -END SELECT - -ans = MATMUL(coeff0, xx(1, :)) -END PROCEDURE LagrangeEvalAll_Triangle1 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Triangle2 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) - -basisType0 = Input(default=Monomial, option=basisType) -firstCall0 = Input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff, nrow=nrow, ncol=ncol) - coeff0 = coeff - - ELSE - - coeff0 = coeff - - END IF -ELSE - - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff0, nrow=nrow, ncol=ncol) - -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) - tdof = SIZE(xij, 2) - - DO ii = 1, tdof - xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2) - END DO - -CASE (Heirarchical) - - CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=x, refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) - -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) - - CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, & - ans=xx, nrow=nrow, ncol=ncol) - -END SELECT - -ans = MATMUL(xx, coeff0) -END PROCEDURE LagrangeEvalAll_Triangle2 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Triangle1 -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, s(3) -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br - -basisType0 = Input(default=Monomial, option=basisType) -firstCall0 = Input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff, nrow=s(1), ncol=s(2)) - END IF - - coeff0 = coeff -ELSE - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff0, nrow=s(1), ncol=s(2)) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=s(1), ncol=s(2)) - - tdof = SIZE(xij, 2) - - DO ii = 1, tdof - ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) - bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) - ar = REAL(degree(ii, 1_I4B), DFP) - br = REAL(degree(ii, 2_I4B), DFP) - xx(:, ii, 1) = (ar * x(1, :)**ai) * x(2, :)**degree(ii, 2) - xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi) - END DO - -CASE (Heirarchical) - - CALL HeirarchicalBasisGradient_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=x, refTriangle=refTriangle, ans=xx, tsize1=s(1), & - tsize2=s(2), tsize3=s(3)) - -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) - - CALL OrthogonalBasisGradient_Triangle_(order=order, xij=x, & - refTriangle=refTriangle, ans=xx, tsize1=s(1), tsize2=s(2), tsize3=s(3)) - -END SELECT - -DO ii = 1, 2 - ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) -END DO - -END PROCEDURE LagrangeGradientEvalAll_Triangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE LagrangeBasisMethods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 deleted file mode 100644 index 9e50e8c6a..000000000 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,549 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(TriangleInterpolationUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetTotalDOF_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Triangle -ans = (order + 1) * (order + 2) / 2_I4B -END PROCEDURE GetTotalDOF_Triangle - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Triangle -ans = (order - 1) * (order - 2) / 2_I4B -END PROCEDURE GetTotalInDOF_Triangle - -!---------------------------------------------------------------------------- -! RefElemDomain_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Triangle -SELECT CASE (UpperCase(baseContinuity)) -CASE ("H1") - SELECT CASE (UpperCase(baseInterpol)) - CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") - ans = "UNIT" - CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") - ans = "UNIT" - CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") - ans = "UNIT" - CASE ( & - & "HIERARCHICALPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHICALPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION") - ans = "BIUNIT" - CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") - ans = "BIUNIT" - CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given baseInterpol="//TRIM(baseInterpol), & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Triangle()", & - & unitno=stderr) - END SELECT -CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given baseContinuity="//TRIM(baseContinuity), & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Triangle()", & - & unitno=stderr) -END SELECT -END PROCEDURE RefElemDomain_Triangle - -!---------------------------------------------------------------------------- -! FacetConnectivity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetConnectivity_Triangle -TYPE(String) :: baseInterpol0 -TYPE(String) :: baseContinuity0 - -baseInterpol0 = UpperCase(baseInterpol) -baseContinuity0 = UpperCase(baseContinuity) - -SELECT CASE (baseInterpol0%chars()) -CASE ( & - & "HIERARCHYPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHYPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION", & - & "ORTHOGONALPOLYNOMIAL", & - & "ORTHOGONAL", & - & "ORTHOGONALINTERPOLATION") - ans(:, 1) = [1, 2] - ans(:, 2) = [1, 3] - ans(:, 3) = [2, 3] -CASE DEFAULT - ans(:, 1) = [1, 2] - ans(:, 2) = [2, 3] - ans(:, 3) = [3, 1] -END SELECT -END PROCEDURE FacetConnectivity_Triangle - -!---------------------------------------------------------------------------- -! EquidistancePoint_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Triangle -INTEGER(I4B) :: nsd, n, ne, i1, i2 -REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu - -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:3) = xij(1:nsd, 1:3) -ELSE - nsd = 2_I4B - x(1:nsd, 1) = [0.0, 0.0] - x(1:nsd, 2) = [1.0, 0.0] - x(1:nsd, 3) = [0.0, 1.0] -END IF - -n = LagrangeDOF_Triangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP - -!! points on vertex -ans(1:nsd, 1:3) = x(1:nsd, 1:3) - -!! points on edge -ne = LagrangeInDOF_Line(order=order) -i2 = 3 -IF (order .GT. 1_I4B) THEN - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [1, 2])) - !! - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [2, 3])) - !! - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [3, 1])) - !! -END IF - -!! points on face -IF (order .GT. 2_I4B) THEN - !! - IF (order .EQ. 3_I4B) THEN - i1 = i2 + 1 - ans(1:nsd, i1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP - ELSE - !! - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 1) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - i1 = i2 + 1 - ans(1:nsd, i1:) = EquidistancePoint_Triangle( & - & order=order - 3, & - & xij=xin(1:nsd, 1:3)) - !! - END IF -END IF - -END PROCEDURE EquidistancePoint_Triangle - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Triangle -INTEGER(I4B) :: nsd, n -REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu - -IF (order .LT. 3_I4B) THEN - ALLOCATE (ans(0, 0)) - RETURN -END IF - -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:3) = xij(1:nsd, 1:3) -ELSE - nsd = 2_I4B - x(1:nsd, 1) = [0.0, 0.0] - x(1:nsd, 2) = [1.0, 0.0] - x(1:nsd, 3) = [0.0, 1.0] -END IF - -n = LagrangeInDOF_Triangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP - -!! points on face -IF (order .EQ. 3_I4B) THEN - ans(1:nsd, 1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP -ELSE - !! - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 1) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - ans(1:nsd, 1:) = EquidistancePoint_Triangle( & - & order=order - 3, & - & xij=xin(1:nsd, 1:3)) - !! -END IF - -END PROCEDURE EquidistanceInPoint_Triangle - -!---------------------------------------------------------------------------- -! BlythPozrikidis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BlythPozrikidis_Triangle -REAL(DFP) :: v(order + 1), xi(order + 1, order + 1), eta(order + 1, order + 1) -REAL(DFP), ALLOCATABLE :: temp(:, :) -INTEGER(I4B) :: nsd, N, ii, jj, kk -CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle" - -v = InterpolationPoint_Line( & - & order=order, & - & ipType=ipType, & - & xij=[0.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & lambda=lambda, & - & beta=beta, & - & alpha=alpha) - -N = LagrangeDOF_Triangle(order=order) - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2 -END IF - -CALL Reallocate(ans, nsd, N) -CALL Reallocate(temp, 2, N) - -xi = 0.0_DFP -eta = 0.0_DFP - -DO ii = 1, order + 1 - DO jj = 1, order + 2 - ii - kk = order + 3 - ii - jj - xi(ii, jj) = (1.0 + 2.0 * v(ii) - v(jj) - v(kk)) / 3.0_DFP - eta(ii, jj) = (1.0 + 2.0 * v(jj) - v(ii) - v(kk)) / 3.0_DFP - END DO -END DO - -IF (layout .EQ. "VEFC") THEN - - CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N) - - IF (PRESENT(xij)) THEN - ans = FromUnitTriangle2Triangle(xin=temp, & - & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) - ELSE - ans = temp - END IF - -ELSE - CALL ErrorMsg( & - & msg="Only layout=VEFC is allowed, given layout is " & - & //TRIM(layout), & - & file=__FILE__, & - & routine=myname, & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -IF (ALLOCATED(temp)) DEALLOCATE (temp) - -END PROCEDURE BlythPozrikidis_Triangle - -!---------------------------------------------------------------------------- -! Isaac_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Isaac_Triangle -REAL(DFP) :: xi(order + 1, order + 1), eta(order + 1, order + 1) -REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) -INTEGER(I4B) :: nsd, N, cnt, ii, jj -CHARACTER(*), PARAMETER :: myName = "Isaac_Triangle" - -rPoints = RecursiveNode2D(order=order, ipType=ipType, domain="UNIT", & - & alpha=alpha, beta=beta, lambda=lambda) - -N = SIZE(rPoints, 2) - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2 -END IF - -CALL Reallocate(ans, nsd, N) - -!! convert from rPoints to xi and eta -cnt = 0 -xi = 0.0_DFP -eta = 0.0_DFP - -DO ii = 1, order + 1 - DO jj = 1, order + 2 - ii - cnt = cnt + 1 - xi(ii, jj) = rPoints(1, cnt) - eta(ii, jj) = rPoints(2, cnt) - END DO -END DO - -IF (layout .EQ. "VEFC") THEN - CALL Reallocate(temp, 2, N) - CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N) - IF (PRESENT(xij)) THEN - ans = FromUnitTriangle2Triangle(xin=temp, & - & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) - ELSE - ans = temp - END IF -ELSE - CALL ErrorMsg( & - & msg="Only layout=VEFC is allowed, given layout is " & - & //TRIM(layout), & - & file=__FILE__, & - & routine=myname, & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints) -END PROCEDURE Isaac_Triangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Triangle -INTEGER(I4B) :: cnt, m, ii, jj, ll, llt, llr - -cnt = 0 -m = order -llt = INT((m - 1) / 3) -llr = MOD(m - 1, 3) -DO ll = 0, llt - !! v1 - cnt = cnt + 1 - ii = 1 + ll; jj = 1 + ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - !! v2 - cnt = cnt + 1 - ii = m + 1 - 2 * ll; jj = 1 + ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - !! v3 - cnt = cnt + 1 - ii = 1 + ll; jj = m + 1 - 2 * ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - !! nodes on edge 12 - jj = ll + 1 - DO ii = 2 + ll, m - 2 * ll - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - !! nodes on edge 23 - DO jj = 2 + ll, m - 2 * ll - cnt = cnt + 1 - ii = m - ll + 2 - jj - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - !! nodes on edge 31 - ii = ll + 1 - DO jj = m - 2 * ll, 2 + ll, -1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - !! internal nodes -END DO - -IF (llr .EQ. 2_I4B) THEN - !! a internal point - cnt = cnt + 1 - ll = llt + 1 - ii = 1 + ll; jj = 1 + ll - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) -END IF - -IF (cnt .NE. N) THEN - CALL ErrorMsg( & - & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" & - & //tostring(N), & - & file=__FILE__, & - & routine="IJ2VEFC_Triangle()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF -END PROCEDURE IJ2VEFC_Triangle - -!---------------------------------------------------------------------------- -! InterpolationPoint_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Triangle -CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle" - -SELECT CASE (ipType) -CASE (Equidistance) - ans = EquidistancePoint_Triangle(xij=xij, order=order) -CASE (Feket, Hesthaven, ChenBabuska) - CALL ErrorMsg( & - & msg="Feket, Hesthaven, ChenBabuska nodes not available", & - & file=__FILE__, & - & routine=myname, & - & line=__LINE__, & - & unitno=stderr) - RETURN -CASE (BlythPozLegendre) - ans = BlythPozrikidis_Triangle( & - & order=order, & - & ipType=GaussLegendreLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE (BlythPozChebyshev) - ans = BlythPozrikidis_Triangle( & - & order=order, & - & ipType=GaussChebyshevLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE (IsaacLegendre, GaussLegendreLobatto) - ans = Isaac_Triangle( & - & order=order, & - & ipType=GaussLegendreLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE (IsaacChebyshev, GaussChebyshevLobatto) - ans = Isaac_Triangle( & - & order=order, & - & ipType=GaussChebyshevLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE DEFAULT - ans = Isaac_Triangle( & - & order=order, & - & ipType=ipType, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT -END PROCEDURE InterpolationPoint_Triangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 deleted file mode 100644 index edc3b5850..000000000 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 +++ /dev/null @@ -1,116 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(TriangleInterpolationUtility) OrthogonalBasisMethods -USE MappingUtility, ONLY: FromTriangle2Square_, & - FromLine2Line_ - -USE QuadrangleInterpolationUtility, ONLY: Dubiner_Quadrangle_, & - DubinerGradient_Quadrangle_ -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Dubiner_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Triangle1 -INTEGER(I4B) :: nrow, ncol -CALL Dubiner_Triangle1_(order=order, xij=xij, reftriangle=reftriangle, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE Dubiner_Triangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Triangle1_ -REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) -CALL FromTriangle2Square_(xin=xij, ans=x, from=reftriangle, to="B") -CALL Dubiner_Quadrangle_(order=order, xij=x, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE Dubiner_Triangle1_ - -!---------------------------------------------------------------------------- -! Dubiner_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Triangle2 -INTEGER(I4B) :: nrow, ncol -CALL Dubiner_Triangle2_(order=order, x=x, y=y, reftriangle=reftriangle, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE Dubiner_Triangle2 - -!---------------------------------------------------------------------------- -! Dubiner_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Triangle2_ -REAL(DFP), ALLOCATABLE :: x0(:), y0(:) -INTEGER(I4B) :: ii, jj - -ii = SIZE(x) -jj = SIZE(y) -ALLOCATE (x0(ii), y0(jj)) - -CALL FromLine2Line_(xin=x, ans=x0, from=refTriangle, to="B") -CALL FromLine2Line_(xin=y, ans=y0, from=refTriangle, to="B") - -CALL Dubiner_Quadrangle_(order=order, x=x0, y=y0, ans=ans, nrow=nrow, & - ncol=ncol) -DEALLOCATE (x0, y0) -END PROCEDURE Dubiner_Triangle2_ - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasisGradient_Triangle1 -INTEGER(I4B) :: s(3) -CALL OrthogonalBasisGradient_Triangle1_(order=order, xij=xij, & - reftriangle=reftriangle, ans=ans, tsize1=s(1), tsize2=s(2), tsize3=s(3)) -END PROCEDURE OrthogonalBasisGradient_Triangle1 - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasisGradient_Triangle1_ -INTEGER(I4B) :: ii, s(2), jj -REAL(DFP), ALLOCATABLE :: x(:, :) - -s = SHAPE(xij) -ALLOCATE (x(s(1), s(2))) - -CALL FromTriangle2Square_(xin=xij, ans=x, from=reftriangle, to="B") -CALL DubinerGradient_Quadrangle_(order=order, xij=x, ans=ans, tsize1=tsize1, & - tsize2=tsize2, tsize3=tsize3) - -DO CONCURRENT(ii=1:tsize2, jj=1:tsize1) - - ans(jj, ii, 1) = ans(jj, ii, 1) * 4.0_DFP / (1.0_DFP - x(2, jj)) - ans(jj, ii, 2) = ans(jj, ii, 1) * (1.0_DFP + x(1, jj)) * 0.5_DFP & - + 2.0_DFP * ans(jj, ii, 2) -END DO - -DEALLOCATE (x) - -END PROCEDURE OrthogonalBasisGradient_Triangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE OrthogonalBasisMethods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 deleted file mode 100644 index 26a49cb99..000000000 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ /dev/null @@ -1,219 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(TriangleInterpolationUtility) QuadratureMethods -USE BaseMethod -USE QuadraturePoint_Triangle_Solin, ONLY: QuadraturePointTriangleSolin, & - QuadraturePointTriangleSolin_, & - QuadratureNumberTriangleSolin -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Triangle1 -INTEGER(I4B) :: np(1), nq(1), n -n = 1_I4B + INT(order / 2, kind=I4B) -np(1) = n + 1 -nq(1) = n -ans = TensorQuadraturePoint_Triangle2( & - & nipsx=np, & - & nipsy=nq, & - & quadType=quadType, & - & refTriangle=refTriangle, & - & xij=xij) -END PROCEDURE TensorQuadraturePoint_Triangle1 - -!---------------------------------------------------------------------------- -! TensorQuadraturePoint_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorQuadraturePoint_Triangle2 -INTEGER(I4B) :: np(1), nq(1), nsd -REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :) -TYPE(String) :: astr - -astr = TRIM(UpperCase(refTriangle)) -np(1) = nipsx(1) -nq(1) = nipsy(1) - -temp_q = QuadraturePoint_Quadrangle(& - & nipsx=np, & - & nipsy=nq, & - & quadType1=GaussLegendreLobatto, & - & quadType2=GaussJacobiRadauLeft, & - & refQuadrangle="BIUNIT", & - & alpha2=1.0_DFP, & - & beta2=0.0_DFP) - -CALL Reallocate(temp_t, SIZE(temp_q, 1, kind=I4B), SIZE(temp_q, 2, kind=I4B)) -temp_t(1:2, :) = FromBiUnitSqr2UnitTriangle(xin=temp_q(1:2, :)) -temp_t(3, :) = temp_q(3, :) / 8.0_DFP - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2_I4B -END IF - -CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_q, 2, kind=I4B)) - -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromUnitTriangle2Triangle( & - & xin=temp_t(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="TRIANGLE", & - & xij=xij) -ELSE - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) - - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="BIUNIT") - - ELSE - ans = temp_t - END IF -END IF - -IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q) -IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) - -END PROCEDURE TensorQuadraturePoint_Triangle2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Triangle1 -INTEGER(I4B) :: nips(1), nsd, ii, jj -REAL(DFP), ALLOCATABLE :: temp_t(:, :) -LOGICAL(LGT) :: abool - -nips(1) = QuadratureNumberTriangleSolin(order=order) - -IF (nips(1) .LE. 0) THEN - ans = TensorQuadraturepoint_Triangle(order=order, quadtype=quadtype, & - reftriangle=reftriangle, xij=xij) - RETURN -END IF - -ALLOCATE (temp_t(3, nips(1))) -CALL QuadraturePointTriangleSolin_(nips=nips, ans=temp_t, nrow=ii, & - ncol=jj) - -nsd = 2_I4B -abool = PRESENT(xij) -IF (abool) nsd = SIZE(xij, 1) - -ii = nsd + 1 -ALLOCATE (ans(ii, jj)) - -IF (abool) THEN - - CALL FromTriangle2Triangle_(xin=temp_t(1:2, :), x1=xij(1:nsd, 1), & - x2=xij(1:nsd, 2), x3=xij(1:nsd, 3), ans=ans(1:nsd, :), & - from="U", to="T") - - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", & - to="TRIANGLE", xij=xij) - - RETURN - -END IF - -abool = reftriangle(1:1) == "B" .OR. reftriangle(1:1) == "b" - -IF (abool) THEN - ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", to="BIUNIT") - RETURN -END IF - -ans = temp_t - -IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) - -END PROCEDURE QuadraturePoint_Triangle1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Triangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Triangle2 -INTEGER(I4B) :: nsd -REAL(DFP), ALLOCATABLE :: temp_t(:, :) -TYPE(string) :: astr - -IF (nips(1) .LE. QuadratureNumberTriangleSolin(order=20_I4B)) THEN - astr = TRIM(UpperCase(refTriangle)) - temp_t = QuadraturePointTriangleSolin(nips=nips) - - IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - ELSE - nsd = 2_I4B - END IF - - CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_t, 2, kind=I4B)) - - IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromUnitTriangle2Triangle( & - & xin=temp_t(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="TRIANGLE", & - & xij=xij) - ELSE - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="BIUNIT") - - ELSE - ans = temp_t - END IF - END IF - - IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) -ELSE - CALL Errormsg( & - & msg="This routine should be called for economical"// & - & " quadrature points only, otherwise call QuadraturePoint_Triangle1()", & - & file=__FILE__, & - & line=__LINE__, & - & routine="QuadraturePoint_Triangle2()", & - & unitNo=stdout) - RETURN -END IF -END PROCEDURE QuadraturePoint_Triangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE QuadratureMethods diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 deleted file mode 100644 index 2c5e7e9d8..000000000 --- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 +++ /dev/null @@ -1,1221 +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(UltrasphericalPolynomialUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! UltrasphericalAlpha -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalAlpha -ans = 0.0_DFP -END PROCEDURE UltrasphericalAlpha - -!---------------------------------------------------------------------------- -! UltrasphericalBeta -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalBeta -REAL(DFP) :: avar, bvar -!! -SELECT CASE (n) -CASE (0_I4B) - avar = pi * GAMMA(2.0_DFP * lambda) - bvar = (GAMMA(lambda))**2 * lambda * 2.0_DFP**(2.0_DFP * lambda - 1.0_DFP) - ans = avar / bvar -CASE (1_I4B) - ans = 0.5_DFP / (1.0_DFP + lambda) -CASE DEFAULT - avar = n * (2.0_DFP * lambda + n - 1.0_DFP) - bvar = 4.0_DFP * (n + lambda) * (n + lambda - 1.0_DFP) - ans = avar / bvar -END SELECT -END PROCEDURE UltrasphericalBeta - -!---------------------------------------------------------------------------- -! GetUltrasphericalRecurrenceCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetUltrasphericalRecurrenceCoeff -REAL(DFP) :: avar, bvar -INTEGER(I4B) :: ii -!! -IF (n .LE. 0) RETURN -!! -alphaCoeff = 0.0_DFP -!! -avar = pi * GAMMA(2.0_DFP * lambda) -bvar = (GAMMA(lambda))**2 * lambda * 2.0_DFP**(2.0_DFP * lambda - 1.0_DFP) -betaCoeff(0) = avar / bvar -!! -IF (n .EQ. 1) RETURN -!! -betaCoeff(1) = 0.5_DFP / (1.0_DFP + lambda) -!! -IF (n .EQ. 2) RETURN -!! -DO ii = 2, n - 1 - avar = ii * (2.0_DFP * lambda + ii - 1.0_DFP) - bvar = 4.0_DFP * (ii + lambda) * (ii + lambda - 1.0_DFP) - betaCoeff(ii) = avar / bvar -END DO -!! -END PROCEDURE GetUltrasphericalRecurrenceCoeff - -!---------------------------------------------------------------------------- -! GetUltrasphericalRecurrenceCoeff2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetUltrasphericalRecurrenceCoeff2 -REAL(DFP) :: j -INTEGER(I4B) :: ii -!! -IF (n .LT. 1) RETURN -B = 0.0_DFP -!! -DO ii = 1, n - j = REAL(ii, KIND=DFP) - A(ii - 1) = 2 * (j + lambda - 1) / j; - C(ii - 1) = (j + 2 * lambda - 2) / j; -END DO -!! -END PROCEDURE GetUltrasphericalRecurrenceCoeff2 - -!---------------------------------------------------------------------------- -! UltrasphericalLeadingCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalLeadingCoeff -REAL(DFP) :: a1, a2 -a1 = (2.0_DFP**n) * GAMMA(n + lambda) -a2 = Factorial(n) * GAMMA(lambda) -ans = a1 / a2 -END PROCEDURE UltrasphericalLeadingCoeff - -!---------------------------------------------------------------------------- -! UltrasphericalLeadingCoeffRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalLeadingCoeffRatio -ans = 2.0_DFP * (n + lambda) / (n + 1.0_DFP) -END PROCEDURE UltrasphericalLeadingCoeffRatio - -!---------------------------------------------------------------------------- -! UltrasphericalNormSqr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalNormSqr -REAL(DFP) :: a1, a2 -a1 = 2.0_DFP**(1.0_DFP - 2.0_DFP * lambda) * pi * GAMMA(n + 2.0_DFP * lambda) -a2 = GAMMA(lambda)**2 * (n + lambda) * Factorial(n) -ans = a1 / a2 -END PROCEDURE UltrasphericalNormSqr - -!---------------------------------------------------------------------------- -! UltrasphericalNormSqrRatio -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalNormSqrRatio -REAL(DFP) :: a1, a2 -a1 = (n + lambda) * (n + 2.0_DFP * lambda) -a2 = (n + 1.0_DFP) * (n + lambda + 1.0_DFP) -ans = a1 / a2 -END PROCEDURE UltrasphericalNormSqrRatio - -!---------------------------------------------------------------------------- -! UltrasphericalNormSqr2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalNormSqr2 -REAL(DFP) :: rn, s -INTEGER(I4B) :: ii -!! -ans(0) = UltrasphericalNormSQR(n=0_I4B, lambda=lambda) -!! -IF (n .EQ. 0) RETURN -!! -s = UltrasphericalNormSQRRatio(n=0_I4B, lambda=lambda) -ans(1) = ans(0) * s -!! -DO ii = 1, n - 1 - rn = REAL(ii, KIND=DFP) - s = (rn + lambda) * (rn + 2.0_DFP * lambda) / (rn + 1.0_DFP) & - & / (rn + lambda + 1.0_DFP) - ans(ii + 1) = s * ans(ii) -END DO -END PROCEDURE UltrasphericalNormSqr2 - -!---------------------------------------------------------------------------- -! UltrasphericalJacobiMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalJacobiMatrix -REAL(DFP) :: alpha -alpha = lambda - 0.5_DFP -CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=alpha, D=D, E=E, & - & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -END PROCEDURE UltrasphericalJacobiMatrix - -!---------------------------------------------------------------------------- -! UltrasphericalGaussQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGaussQuadrature -REAL(DFP) :: alpha -alpha = lambda - 0.5_DFP -CALL JacobiGaussQuadrature(n=n, alpha=alpha, beta=alpha, pt=pt, wt=wt) -END PROCEDURE UltrasphericalGaussQuadrature - -!---------------------------------------------------------------------------- -! UltrasphericalJacobiRadauMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalJacobiRadauMatrix -REAL(DFP) :: alpha -alpha = lambda - 0.5_DFP -CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=alpha, beta=alpha, D=D, E=E, & - & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -END PROCEDURE UltrasphericalJacobiRadauMatrix - -!---------------------------------------------------------------------------- -! UltrasphericalGaussRadauQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGaussRadauQuadrature -REAL(DFP) :: alpha -alpha = lambda - 0.5_DFP -CALL JacobiGaussRadauQuadrature(a=a, n=n, alpha=alpha, beta=alpha, & - & pt=pt, wt=wt) -END PROCEDURE UltrasphericalGaussRadauQuadrature - -!---------------------------------------------------------------------------- -! UltrasphericalJacobiLobattoMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalJacobiLobattoMatrix -REAL(DFP) :: alpha -alpha = lambda - 0.5_DFP -CALL JacobiJacobiLobattoMatrix(n=n, alpha=alpha, beta=alpha, D=D, E=E, & - & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -END PROCEDURE UltrasphericalJacobiLobattoMatrix - -!---------------------------------------------------------------------------- -! UltrasphericalGaussLobattoQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGaussLobattoQuadrature -REAL(DFP) :: alpha -alpha = lambda - 0.5_DFP -CALL JacobiGaussLobattoQuadrature(n=n, alpha=alpha, beta=alpha, & - & pt=pt, wt=wt) -END PROCEDURE UltrasphericalGaussLobattoQuadrature - -!---------------------------------------------------------------------------- -! UltrasphericalZeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalZeros -REAL(DFP) :: alpha -alpha = lambda - 0.5_DFP -ans = JacobiZeros(alpha=alpha, beta=alpha, n=n) -END PROCEDURE UltrasphericalZeros - -!---------------------------------------------------------------------------- -! UltrasphericalQuadrature -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalQuadrature -INTEGER(I4B) :: order -REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP -REAL(DFP), ALLOCATABLE :: p(:), w(:) -LOGICAL(LGT) :: inside -!! -IF (PRESENT(onlyInside)) THEN - inside = onlyInside -ELSE - inside = .FALSE. -END IF -!! -SELECT CASE (QuadType) -CASE (Gauss) - !! - order = n - CALL UltrasphericalGaussQuadrature(n=order, lambda=lambda, pt=pt, wt=wt) - !! -CASE (GaussRadau, GaussRadauLeft) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 1), w(n + 1)) - CALL UltrasphericalGaussRadauQuadrature(a=left, lambda=lambda, & - & n=order, pt=p, wt=w) - pt = p(2:); wt = w(2:) - DEALLOCATE (p, w) - ELSE - order = n - 1 - CALL UltrasphericalGaussRadauQuadrature(a=left, lambda=lambda, & - & n=order, pt=pt, wt=wt) - END IF - !! -CASE (GaussRadauRight) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 1), w(n + 1)) - CALL UltrasphericalGaussRadauQuadrature(a=right, lambda=lambda, & - & n=order, pt=p, wt=w) - pt = p(1:n); wt = w(1:n) - ELSE - order = n - 1 - CALL UltrasphericalGaussRadauQuadrature(a=right, lambda=lambda, & - & n=order, pt=pt, wt=wt) - END IF - !! -CASE (GaussLobatto) - !! - IF (inside) THEN - order = n - ALLOCATE (p(n + 2), w(n + 2)) - CALL UltrasphericalGaussLobattoQuadrature(n=order, lambda=lambda, & - & pt=p, wt=w) - pt = p(2:n + 1); wt = w(2:n + 1) - ELSE - order = n - 2 - CALL UltrasphericalGaussLobattoQuadrature(n=order, lambda=lambda, & - & pt=pt, wt=wt) - END IF -END SELECT -END PROCEDURE UltrasphericalQuadrature - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEval1 -INTEGER(I4B) :: ii -REAL(DFP) :: c1, c2, c3, r_ii, ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans = 2.0_DFP * lambda * x -IF (n .EQ. 1) RETURN -!! -DO ii = 1, n - 1 - !! - r_ii = REAL(ii, kind=DFP) - c1 = r_ii + 1.0_DFP - c2 = 2.0_DFP * (r_ii + lambda) - c3 = -(2.0_DFP * lambda + r_ii - 1.0_DFP) - !! - ans_1 = ans - ans = ((c2 * x) * ans + c3 * ans_2) / c1 - ans_2 = ans_1 - !! -END DO -END PROCEDURE UltrasphericalEval1 - -!---------------------------------------------------------------------------- -! UltrasphericalEval -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEval2 -INTEGER(I4B) :: ii -REAL(DFP) :: c1, c2, c3, r_ii -REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans = 1.0_DFP -ans_2 = ans -!! -IF (n .EQ. 0) RETURN -!! -ans = 2.0_DFP * lambda * x -!! -IF (n .EQ. 1) RETURN -!! -DO ii = 1, n - 1 - !! - r_ii = REAL(ii, kind=DFP) - c1 = r_ii + 1.0_DFP - c2 = 2.0_DFP * (r_ii + lambda) - c3 = -(2.0_DFP * lambda + r_ii - 1.0_DFP) - !! - ans_1 = ans - ans = ((c2 * x) * ans + c3 * ans_2) / c1 - ans_2 = ans_1 - !! -END DO -END PROCEDURE UltrasphericalEval2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEvalAll1 -INTEGER(I4B) :: a -CALL UltrasphericalEvalAll1_(n=n, lambda=lambda, x=x, ans=ans, tsize=a) -END PROCEDURE UltrasphericalEvalAll1 - -!---------------------------------------------------------------------------- -! UltrasphericalEvalAll_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEvalAll1_ -INTEGER(I4B) :: ii -REAL(DFP) :: c1, c2, c3, r_ii - -tsize = 0 -IF (n < 0) RETURN - -tsize = 1 -ans(1) = 1.0_DFP -IF (n .EQ. 0) RETURN - -tsize = n + 1 -ans(2) = 2.0_DFP * lambda * x - -DO ii = 2, n - r_ii = REAL(ii, kind=DFP) - c1 = 1.0_DFP / r_ii - c2 = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * c1 * x - c3 = -(2.0_DFP * lambda + r_ii - 2.0_DFP) * c1 - ans(ii + 1) = c2 * ans(ii) + c3 * ans(ii - 1) -END DO - -END PROCEDURE UltrasphericalEvalAll1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEvalAll2 -INTEGER(I4B) :: a, b -CALL UltrasphericalEvalAll2_(n=n, lambda=lambda, x=x, ans=ans, nrow=a, ncol=b) -END PROCEDURE UltrasphericalEvalAll2 - -!---------------------------------------------------------------------------- -! UltrasphericalEvalAll_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEvalAll2_ -INTEGER(I4B) :: ii, jj -REAL(DFP) :: c1, c2, c3, r_ii - -nrow = 0; ncol = 0 -IF (n < 0) RETURN - -! FIXME: What is this? -ans = 0.0_DFP - -nrow = SIZE(x) -ncol = n + 1 -ans(1:nrow, 1) = 1.0_DFP - -IF (n .EQ. 0) RETURN - -DO CONCURRENT(jj=1:nrow) - - ans(jj, 2) = 2.0_DFP * lambda * x(jj) - - DO ii = 2, n - - r_ii = REAL(ii, kind=DFP) - c1 = 1.0_DFP / r_ii - c2 = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * c1 * x(jj) - c3 = -(2.0_DFP * lambda + r_ii - 2.0_DFP) * c1 - - ans(1:jj, ii + 1) = c2 * ans(1:jj, ii) + c3 * ans(1:jj, ii - 1) - - END DO -END DO - -END PROCEDURE UltrasphericalEvalAll2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalAll1 -INTEGER(I4B) :: tsize -CALL UltrasphericalGradientEvalAll1_(n=n, lambda=lambda, x=x, ans=ans, & - tsize=tsize) -END PROCEDURE UltrasphericalGradientEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalAll2 -INTEGER(I4B) :: nrow, ncol -CALL UltrasphericalGradientEvalAll2_(n=n, lambda=lambda, x=x, ans=ans, & - nrow=nrow, ncol=ncol) -END PROCEDURE UltrasphericalGradientEvalAll2 - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalAll_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalAll1_ -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP) :: p(1:n + 1) - -tsize = 0 -IF (n < 0) RETURN - -tsize = n + 1 -p(1) = 1.0_DFP -ans(1) = 0.0_DFP - -IF (n < 1) RETURN - -p(2) = 2.0_DFP * lambda * x -ans(2) = 2.0_DFP * lambda - -DO ii = 2, n - - r_ii = REAL(ii, KIND=DFP) - - p(ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(ii) & - & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(ii - 1)) & - & / r_ii - - ans(ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(ii) + ans(ii - 1) - -END DO - -END PROCEDURE UltrasphericalGradientEvalAll1_ - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalAll_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalAll2_ -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP) :: p(1:SIZE(x), 1:n + 1) - -nrow = 0; ncol = 0 -IF (n < 0) RETURN - -nrow = SIZE(x) -ncol = n + 1 - -p(1:nrow, 1) = 1.0_DFP -ans(1:nrow, 1) = 0.0_DFP - -IF (n < 1) RETURN - -p(1:nrow, 2) = 2.0_DFP * lambda * x -ans(1:nrow, 2) = 2.0_DFP * lambda - -DO ii = 2, n - - r_ii = REAL(ii, KIND=DFP) - -p(1:nrow, ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(1:nrow, ii) & - & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(1:nrow, ii - 1)) & - & / r_ii - - ans(1:nrow, ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(1:nrow, ii) & - & + ans(1:nrow, ii - 1) - -END DO - -END PROCEDURE UltrasphericalGradientEvalAll2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEval1 - -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP) :: p, p_1, p_2 -REAL(DFP) :: ans_1, ans_2 - -ans = 0.0_DFP - -IF (n < 0) THEN - RETURN -END IF - -p = 1.0_DFP -p_2 = p -ans_2 = ans - -IF (n < 1) THEN - RETURN -END IF - -p = 2.0_DFP * lambda * x -ans = 2.0_DFP * lambda - -DO ii = 2, n - - r_ii = REAL(ii, KIND=DFP) - - p_1 = p - - p = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p & - & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p_2) & - & / r_ii - - p_2 = p_1 - - ans_1 = ans - ans = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p_1 + ans_2 - ans_2 = ans_1 - -END DO - -END PROCEDURE UltrasphericalGradientEval1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEval2 -!! -INTEGER(I4B) :: ii -REAL(DFP) :: r_ii -REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 -REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! -IF (n < 0) THEN - RETURN -END IF -!! -p = 1.0_DFP -ans = 0.0_DFP -p_2 = p -ans_2 = ans -!! -IF (n < 1) THEN - RETURN -END IF -!! -p = 2.0_DFP * lambda * x -ans = 2.0_DFP * lambda -!! -DO ii = 2, n - !! - r_ii = REAL(ii, KIND=DFP) - !! - p_1 = p - !! - p = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p & - & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p_2) & - & / r_ii - !! - p_2 = p_1 - !! - ans_1 = ans - ans = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p_1 + ans_2 - ans_2 = ans_1 - !! -END DO -!! -END PROCEDURE UltrasphericalGradientEval2 - -!---------------------------------------------------------------------------- -! UltrasphericalEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEvalSum1 -REAL(DFP) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP), DIMENSION(0:n + 1) :: A, B, C - -! IF (n .LT. 0) RETURN -! IF (lambda .LE. -0.5_DFP) RETURN -! IF (lambda .EQ. 0.0_DFP) RETURN - -CALL GetUltrasphericalRecurrenceCoeff2(n=n + 2, lambda=lambda, A=A, B=B, C=C) - -b1 = 0.0_DFP -b2 = 0.0_DFP - -DO j = n, 0, -1 - t = (A(j) * x) * b1 - C(j + 1) * b2 + coeff(j); - b2 = b1 - b1 = t -END DO - -ans = b1 - -END PROCEDURE UltrasphericalEvalSum1 - -!---------------------------------------------------------------------------- -! UltrasphericalEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalEvalSum2 -REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 -INTEGER(I4B) :: j -REAL(DFP), DIMENSION(0:n + 1) :: A, B, C - -! IF (n .LT. 0) RETURN -! IF (lambda .LE. -0.5_DFP) RETURN -! IF (lambda .EQ. 0.0_DFP) RETURN - -CALL GetUltrasphericalRecurrenceCoeff2(n=n + 2, lambda=lambda, A=A, B=B, C=C) - -b1 = 0.0_DFP -b2 = 0.0_DFP - -DO j = n, 0, -1 - t = (A(j) * x) * b1 - C(j + 1) * b2 + coeff(j); - b2 = b1 - b1 = t -END DO - -ans = b1 - -END PROCEDURE UltrasphericalEvalSum2 - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalSum1 -REAL(DFP) :: t, b1, b2 -REAL(DFP) :: A1, A2 -INTEGER(I4B) :: i -REAL(DFP) :: j -REAL(DFP) :: c - -! IF (n .LT. 0) RETURN -! IF (lambda .LE. -0.5_DFP) RETURN -! IF (lambda .EQ. 0.0_DFP) RETURN - -c = 2 * lambda; -b1 = 0 -b2 = 0 - -DO i = n - 1, 0, -1 - j = REAL(i, KIND=DFP) - A1 = 2 * (j + 1 + lambda) * x / (j + 1) - A2 = -(j + 2 * lambda + 2) / (j + 2) - t = A1 * b1 + A2 * b2 + coeff(i + 1) - b2 = b1 - b1 = t -END DO -ans = C * b1 -END PROCEDURE UltrasphericalGradientEvalSum1 - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalSum2 -REAL(DFP) :: A2 -REAL(DFP), DIMENSION(SIZE(x)) :: A1, t, b1, b2 -INTEGER(I4B) :: i -REAL(DFP) :: j -REAL(DFP) :: c - -! IF (n .LT. 0) RETURN -! IF (lambda .LE. -0.5_DFP) RETURN -! IF (lambda .EQ. 0.0_DFP) RETURN - -c = 2 * lambda; -b1 = 0 -b2 = 0 - -DO i = n - 1, 0, -1 - j = REAL(i, KIND=DFP) - A1 = 2 * (j + 1 + lambda) * x / (j + 1) - A2 = -(j + 2 * lambda + 2) / (j + 2) - t = A1 * b1 + A2 * b2 + coeff(i + 1) - b2 = b1 - b1 = t -END DO -ans = C * b1 -END PROCEDURE UltrasphericalGradientEvalSum2 - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalSum3 -REAL(DFP) :: t, b1, b2, s -REAL(DFP) :: A1, A2 -INTEGER(I4B) :: i -REAL(DFP) :: j - -! IF (n .LT. 0) RETURN -! IF (lambda .LE. -0.5_DFP) RETURN -! IF (lambda .EQ. 0.0_DFP) RETURN - -s = 1.0_DFP -DO i = 1, k - s = 2 * s * (lambda + i - 1); -END DO - -b1 = 0 -b2 = 0 - -DO i = n - k, 0, -1 - j = REAL(i, KIND=DFP) - A1 = 2 * (j + k + lambda) * x / (j + 1); - A2 = -(j + 2 * lambda + 2 * k) / (j + 2); - t = A1 * b1 + A2 * b2 + coeff(i + k); - b2 = b1; - b1 = t; -END DO -ans = s * b1 -END PROCEDURE UltrasphericalGradientEvalSum3 - -!---------------------------------------------------------------------------- -! UltrasphericalGradientEvalSum -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientEvalSum4 -REAL(DFP) :: A2, s -REAL(DFP), DIMENSION(SIZE(x)) :: A1, b1, b2, t -INTEGER(I4B) :: i -REAL(DFP) :: j - -! IF (n .LT. 0) RETURN -! IF (lambda .LE. -0.5_DFP) RETURN -! IF (lambda .EQ. 0.0_DFP) RETURN - -s = 1.0_DFP -DO i = 1, k - s = 2 * s * (lambda + i - 1); -END DO - -b1 = 0 -b2 = 0 - -DO i = n - k, 0, -1 - j = REAL(i, KIND=DFP) - A1 = 2 * (j + k + lambda) * x / (j + 1); - A2 = -(j + 2 * lambda + 2 * k) / (j + 2); - t = A1 * b1 + A2 * b2 + coeff(i + k); - b2 = b1; - b1 = t; -END DO -ans = s * b1 -END PROCEDURE UltrasphericalGradientEvalSum4 - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalTransform1 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -REAL(DFP) :: rn -!! -nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) -END IF -!! -PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) -!! -DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / nrmsqr(jj) -END DO -!! -END PROCEDURE UltrasphericalTransform1 - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalTransform2 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -REAL(DFP) :: rn -!! -nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) -END IF -!! -PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) -!! -DO kk = 1, SIZE(coeff, 2) - DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / nrmsqr(jj) - END DO -END DO -!! -END PROCEDURE UltrasphericalTransform2 - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalTransform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) -INTEGER(I4B) :: ii - -CALL UltrasphericalQuadrature(n=n + 1, lambda=lambda, pt=pt, wt=wt,& - & quadType=quadType) - -DO ii = 0, n - coeff(ii) = f(pt(ii)) -END DO - -ans = UltrasphericalTransform(n=n, lambda=lambda, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) - -END PROCEDURE UltrasphericalTransform3 - -!---------------------------------------------------------------------------- -! UltrasphericalInvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalInvTransform1 -ans = UltrasphericalEvalSum(n=n, lambda=lambda, coeff=coeff, & - & x=x) -END PROCEDURE UltrasphericalInvTransform1 - -!---------------------------------------------------------------------------- -! UltrasphericalInvTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalInvTransform2 -ans = UltrasphericalEvalSum(n=n, lambda=lambda, coeff=coeff, & - & x=x) -END PROCEDURE UltrasphericalInvTransform2 - -!---------------------------------------------------------------------------- -! UltrasphericalGradientCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalGradientCoeff1 -REAL(DFP) :: a, b, c -INTEGER(I4B) :: ii -REAL(DFP) :: jj -!! -ans(n) = 0.0_DFP -IF (n .EQ. 0) RETURN -!! -ans(n - 1) = 2.0 * (n + lambda - 1.0_DFP) * coeff(n) -!! -DO ii = n - 1, 1, -1 - jj = REAL(ii, KIND=DFP) - a = jj + lambda - 1.0_DFP - b = jj + lambda + 1.0_DFP - c = a / b - ans(ii - 1) = 2.0_DFP * a * coeff(ii) + c * ans(ii + 1) -END DO -!! -END PROCEDURE UltrasphericalGradientCoeff1 - -!---------------------------------------------------------------------------- -! UltrasphericalDMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalDMatrix1 -SELECT CASE (quadType) -CASE (GaussLobatto) - CALL UltrasphericalDMatrixGL2(n=n, lambda=lambda, x=x,& - & D=ans) -CASE (Gauss) - CALL UltrasphericalDMatrixG2(n=n, lambda=lambda, x=x, & - & D=ans) -END SELECT -END PROCEDURE UltrasphericalDMatrix1 - -!---------------------------------------------------------------------------- -! UltrasphericalDMatrixGL -!---------------------------------------------------------------------------- - -PURE SUBROUTINE UltrasphericalDMatrixGL(n, lambda, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - REAL(DFP) :: rn - INTEGER(I4B) :: ii, jj, nb2 - !! - nb2 = INT(n / 2) - rn = REAL(n, KIND=DFP) - !! - J = UltrasphericalEval(n=n, lambda=lambda, x=x) - !! - !! first col - !! - D(0, 0) = (lambda - 0.5_DFP - rn * (rn + 2.0 * lambda)) / & - & (2.0 * lambda + 3.0) - DO ii = 1, n - D(ii, 0) = (lambda + 0.5) * J(ii) / (x(ii) + 1.0) / J(0) - END DO - !! - !! last col - !! - DO ii = 0, n - 1 - D(ii, n) = (lambda + 0.5) * J(ii) / (x(ii) - 1.0) / J(n) - END DO - D(n, n) = -D(0, 0) - !! - !! internal column - !! - DO jj = 1, n - 1 - DO ii = 0, n - IF (ii .EQ. jj) THEN - D(ii, ii) = (lambda - 0.5) * x(ii) / (1.0 - x(ii)**2) - ELSE - D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END IF - END DO - END DO - !! -END SUBROUTINE UltrasphericalDMatrixGL - -!---------------------------------------------------------------------------- -! UltrasphericalDMatrixGL -!---------------------------------------------------------------------------- - -PURE SUBROUTINE UltrasphericalDMatrixGL2(n, lambda, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - REAL(DFP) :: rn - INTEGER(I4B) :: ii, jj, nb2 - !! - nb2 = INT(n / 2) - rn = REAL(n, KIND=DFP) - !! - J = UltrasphericalEval(n=n, lambda=lambda, x=x) - D = 0.0_DFP - !! - !! first col - !! - !D(0, 0) = (lambda - 0.5_DFP - rn * (rn + 2.0 * lambda)) / & - ! & (2.0 * lambda + 3.0) - DO ii = 1, nb2 - D(ii, 0) = (lambda + 0.5) * J(ii) / (x(ii) + 1.0) / J(0) - END DO - !! - !! last col - !! - DO ii = 0, nb2 - D(ii, n) = (lambda + 0.5) * J(ii) / (x(ii) - 1.0) / J(n) - END DO - !! - !! internal column - !! - DO jj = 1, n - 1 - DO ii = 0, nb2 - IF (ii .NE. jj) & !THEN - & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - ! ELSE - ! D(ii, ii) = (lambda - 0.5) * x(ii) / (1.0 - x(ii)**2) - !END IF - END DO - END DO - !! - !! correct diagonal entries - !! - DO ii = 0, nb2 - D(ii, ii) = -SUM(D(ii, :)) - END DO - !! - !! copy - !! - DO jj = 0, n - DO ii = 0, nb2 - D(n - ii, n - jj) = -D(ii, jj) - END DO - END DO - !! -END SUBROUTINE UltrasphericalDMatrixGL2 - -!---------------------------------------------------------------------------- -! UltrasphericalDMatrixG -!---------------------------------------------------------------------------- - -PURE SUBROUTINE UltrasphericalDMatrixG(n, lambda, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - INTEGER(I4B) :: ii, jj - !! - !! Compute dJ_{N-1}(a+1,b+1) - !! - J = UltrasphericalGradientEval(n=n + 1, lambda=lambda, x=x) - !! - DO jj = 0, n - DO ii = 0, n - IF (ii .EQ. jj) THEN - D(ii, ii) = (lambda + 0.5_DFP) * x(ii) / (1.0 - x(ii)**2) - ELSE - D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END IF - END DO - END DO -!! -END SUBROUTINE UltrasphericalDMatrixG - -!---------------------------------------------------------------------------- -! UltrasphericalDMatrixG -!---------------------------------------------------------------------------- - -PURE SUBROUTINE UltrasphericalDMatrixG2(n, lambda, x, D) - INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! - REAL(DFP) :: J(0:n) - INTEGER(I4B) :: ii, jj, nb2 - !! - !! Compute dJ_{N-1}(a+1,b+1) - !! - nb2 = INT(n / 2) - !! - J = UltrasphericalGradientEval(n=n + 1, lambda=lambda, x=x) - !! - DO jj = 0, n - DO ii = 0, nb2 - IF (ii .NE. jj) & - & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) - END DO - END DO - !! - !! correct diagonal entries - !! - DO ii = 0, nb2 - D(ii, ii) = -SUM(D(ii, :)) - END DO - !! - !! copy - !! - DO jj = 0, n - DO ii = 0, nb2 - D(n - ii, n - jj) = -D(ii, jj) - END DO - END DO - !! -END SUBROUTINE UltrasphericalDMatrixG2 - -!---------------------------------------------------------------------------- -! UltrasphericalDMatEvenOdd -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UltrasphericalDMatEvenOdd1 -INTEGER(I4B) :: ii, jj, n1, n2 - !! -IF (MOD(N, 2) .EQ. 0) THEN - !! even - !! - n1 = INT(n / 2) - 1 - !! - DO jj = 0, n1 - DO ii = 0, n1 - e(ii, jj) = D(ii, jj) + D(ii, n - jj) - o(ii, jj) = D(ii, jj) - D(ii, n - jj) - END DO - END DO - !! - n2 = n1 + 1 - e(1:n1, n2) = D(1:n1, n2) - o(n2, 1:n1) = D(n2, 1:n1) - D(n2, 1:n1) - !! -ELSE - !! odd - n2 = (n - 1) / 2 - n1 = n2 - !! - DO jj = 0, n2 - DO ii = 0, n1 - e(ii, jj) = D(ii, jj) + D(ii, n - jj) - o(ii, jj) = D(ii, jj) - D(ii, n - jj) - END DO - END DO - !! -END IF -END PROCEDURE UltrasphericalDMatEvenOdd1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 deleted file mode 100644 index 9092e9e12..000000000 --- a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 +++ /dev/null @@ -1,381 +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(UnscaledLobattoPolynomialUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! UnscaledLobattoLeadingCoeff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoLeadingCoeff -REAL(DFP) :: avar, m - !! -SELECT CASE (n) -CASE (0) - ans = 0.5_DFP -CASE (1) - ans = -0.5_DFP -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) - m = LegendreLeadingCoeff(n=n) - ans = m * avar -END SELECT -END PROCEDURE UnscaledLobattoLeadingCoeff - -!---------------------------------------------------------------------------- -! UnscaledLobattoNormSqr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoNormSqr -REAL(DFP) :: m, a1, a2, a3 -SELECT CASE (n) -CASE (0, 1) - ans = 2.0_DFP / 3.0_DFP -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - a1 = (2.0_DFP * m + 1) - a2 = (2.0_DFP * m + 3) - a3 = (2.0_DFP * m + 5) - ans = 4.0_DFP / a1 / a2 / a3 -END SELECT -END PROCEDURE UnscaledLobattoNormSqr - -!---------------------------------------------------------------------------- -! UnscaledLobattoZeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoZeros -SELECT CASE (n) -CASE (1) - ans(1) = 1.0_DFP -CASE (2) - ans(1) = -1.0_DFP - ans(2) = 1.0_DFP -CASE DEFAULT - ans(1) = -1.0_DFP - ans(n) = 1.0_DFP - ans(2:n - 1) = JacobiZeros(alpha=1.0_DFP, beta=1.0_DFP, n=n - 2_I4B) -END SELECT -END PROCEDURE UnscaledLobattoZeros - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoEval1 -REAL(DFP) :: avar, m -SELECT CASE (n) -CASE (0) - ans = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) - ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) -END SELECT -END PROCEDURE UnscaledLobattoEval1 - -!---------------------------------------------------------------------------- -! UnscaledLobattoEval -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoEval2 -REAL(DFP) :: avar, m - !! -SELECT CASE (n) -CASE (0) - ans = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - m = REAL(n, KIND=DFP) - 2.0_DFP - avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) - ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) -END SELECT -END PROCEDURE UnscaledLobattoEval2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoEvalAll1 -REAL(DFP) :: avar, m -REAL(DFP) :: p(n + 1) -INTEGER(I4B) :: ii - !! -SELECT CASE (n) -CASE (0) - ans(1) = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans(1) = 0.5_DFP * (1.0_DFP - x) - ans(2) = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - ans(1) = 0.5_DFP * (1.0_DFP - x) - ans(2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) - DO ii = 1, n - 1 - m = REAL(ii - 1, KIND=DFP) - avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) - ans(2 + ii) = avar * (p(ii + 2) - p(ii)) - END DO -END SELECT -END PROCEDURE UnscaledLobattoEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoEvalAll2 -REAL(DFP) :: avar, m -REAL(DFP) :: p(SIZE(x), n + 1) -INTEGER(I4B) :: ii - !! -SELECT CASE (n) -CASE (0) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) -CASE (1) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) -CASE DEFAULT - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) - DO ii = 1, n - 1 - m = REAL(ii - 1, KIND=DFP) - avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) - ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) - END DO -END SELECT -END PROCEDURE UnscaledLobattoEvalAll2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoMonomialExpansionAll -REAL(DFP) :: avar, m -REAL(DFP) :: p(n + 1, n + 1) -INTEGER(I4B) :: ii -!! -ans = 0.0_DFP -!! -SELECT CASE (n) -CASE (0) - ans(1, 1) = 0.5_DFP -CASE (1) - ans(1, 1) = 0.5_DFP - ans(2, 1) = -0.5_DFP - ans(1, 2) = 0.5_DFP - ans(2, 2) = 0.5_DFP -CASE DEFAULT - ans(1, 1) = 0.5_DFP - ans(2, 1) = -0.5_DFP - ans(1, 2) = 0.5_DFP - ans(2, 2) = 0.5_DFP - !! - p = LegendreMonomialExpansionAll(n=n) - !! - DO ii = 1, n - 1 - m = REAL(ii - 1, KIND=DFP) - avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) - ans(:, ii + 2) = avar * (p(:, ii + 2) - p(:, ii)) - END DO - !! -END SELECT -END PROCEDURE UnscaledLobattoMonomialExpansionAll - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoMonomialExpansion -REAL(DFP) :: coeff(n + 1, n + 1) -coeff = UnscaledLobattoMonomialExpansionAll(n) -ans = coeff(:, n + 1) -END PROCEDURE UnscaledLobattoMonomialExpansion - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 -REAL(DFP) :: p(n) -INTEGER(I4B) :: ii - !! -SELECT CASE (n) -CASE (0) - ans(1) = -0.5_DFP -CASE (1) - ans(1) = -0.5_DFP - ans(2) = 0.5_DFP -CASE DEFAULT - ans(1) = -0.5_DFP - ans(2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! - DO ii = 1, n - 1 - ans(ii + 2) = p(ii + 1) - ! ans(3:) = p(2:) - END DO - !! -END SELECT -END PROCEDURE UnscaledLobattoGradientEvalAll1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 -REAL(DFP) :: p(SIZE(x), n) -INTEGER(I4B) :: ii - !! -SELECT CASE (n) -CASE (0) - ans(:, 1) = -0.5_DFP -CASE (1) - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP -CASE DEFAULT - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! - DO ii = 1, n - 1 - ans(:, ii + 2) = p(:, ii + 1) - ! ans(3:) = p(2:) - END DO - !! -END SELECT -END PROCEDURE UnscaledLobattoGradientEvalAll2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoGradientEval1 - !! -SELECT CASE (n) -CASE (0) - ans = -0.5_DFP -CASE (1) - ans = 0.5_DFP -CASE DEFAULT - ans = LegendreEval(n=n - 1_I4B, x=x) -END SELECT -END PROCEDURE UnscaledLobattoGradientEval1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoGradientEval2 -SELECT CASE (n) -CASE (0) - ans = -0.5_DFP -CASE (1) - ans = 0.5_DFP -CASE DEFAULT - ans = LegendreEval(n=n - 1_I4B, x=x) -END SELECT -END PROCEDURE UnscaledLobattoGradientEval2 - -!---------------------------------------------------------------------------- -! UnscaledLobattoMassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoMassMatrix -INTEGER(I4B) :: ii -REAL(DFP) :: m -!! -ans = 0.0_DFP -!! -DO ii = 1, n + 1 - ans(ii, ii) = UnscaledLobattoNormSQR(n=ii - 1_I4B) -END DO -!! -IF (n .EQ. 0_I4B) RETURN -!! -ans(1, 2) = 1.0_DFP / 3.0_DFP -ans(2, 1) = ans(1, 2) -!! -IF (n .EQ. 1_I4B) RETURN -!! -ans(1, 3) = -1.0_DFP / 3.0_DFP -ans(3, 1) = ans(1, 3) -ans(2, 3) = ans(1, 3) -ans(3, 2) = ans(2, 3) -!! -IF (n .EQ. 2_I4B) RETURN -!! -ans(1, 4) = 1.0_DFP / 15.0_DFP -ans(4, 1) = ans(1, 4) -ans(2, 4) = -ans(1, 4) -ans(4, 2) = ans(2, 4) -!! -IF (n .EQ. 3_I4B) RETURN -!! -DO ii = 3, n + 1 - !! - m = REAL(ii - 3, DFP) - !! - IF (ii + 2 .LE. n + 1) THEN - ans(ii, ii + 2) = -2.0_DFP / (2.0_DFP * m + 3.0_DFP) / & - & (2.0_DFP * m + 5.0_DFP) / (2.0_DFP * m + 7.0_DFP) - !! - ans(ii + 2, ii) = ans(ii, ii + 2) - END IF - !! -END DO -!! -END PROCEDURE UnscaledLobattoMassMatrix - -!---------------------------------------------------------------------------- -! UnscaledLobattoStiffnessMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UnscaledLobattoStiffnessMatrix -INTEGER(I4B) :: ii -REAL(DFP) :: m -!! -ans = 0.0_DFP -!! -ans(1, 1) = 0.5_DFP -!! -IF (n .EQ. 0_I4B) RETURN -!! -ans(2, 2) = 0.5_DFP -ans(1, 2) = -0.5_DFP -ans(2, 1) = ans(1, 2) -!! -DO ii = 3, n + 1 - m = REAL(ii - 3, DFP) - ans(ii, ii) = 2.0_DFP / (2.0_DFP * m + 3.0_DFP) -END DO -END PROCEDURE UnscaledLobattoStiffnessMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods 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/Polynomial/src/include/Quadrangle/edge_12.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_12.inc deleted file mode 100644 index e3f826e6b..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_12.inc +++ /dev/null @@ -1,10 +0,0 @@ - - ! nodes on edge 12 - jj = ll + 1 - IF (cnt .LT. N) THEN - DO ii = 2 + ll, p - ll - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc deleted file mode 100644 index 9f83df9f4..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc +++ /dev/null @@ -1,9 +0,0 @@ - - ii = ll + 1 - IF (cnt .LT. N) THEN - DO jj = 2 + ll, q - ll, 1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc deleted file mode 100644 index 254a740be..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc +++ /dev/null @@ -1,9 +0,0 @@ - ! nodes on edge 21 - jj = ll + 1 - IF (cnt .LT. N) THEN - DO ii = p - ll, 2 + ll, -1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc deleted file mode 100644 index 8c06958ac..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc +++ /dev/null @@ -1,10 +0,0 @@ - - ! nodes on edge 23 - ii = p + 1 - ll - IF (cnt .LT. N) THEN - DO jj = 2 + ll, q - ll - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc deleted file mode 100644 index eecb89c4d..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc +++ /dev/null @@ -1,10 +0,0 @@ - - ! nodes on edge 32 - ii = p + 1 - ll - IF (cnt .LT. N) THEN - DO jj = q - ll, 2 + ll, -1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc deleted file mode 100644 index b926206d8..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc +++ /dev/null @@ -1,10 +0,0 @@ - - ! nodes on edge 34 - jj = q + 1 - ll - IF (cnt .LT. N) THEN - DO ii = p - ll, 2 + ll, -1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc deleted file mode 100644 index e30df2070..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc +++ /dev/null @@ -1,10 +0,0 @@ - - ! nodes on edge 41 - ii = ll + 1 - IF (cnt .LT. N) THEN - DO jj = q - ll, 2 + ll, -1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc deleted file mode 100644 index 89adc3ea4..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc +++ /dev/null @@ -1,10 +0,0 @@ - - ! nodes on edge 43 - jj = q + 1 - ll - IF (cnt .LT. N) THEN - DO ii = 2 + ll, p - ll, +1 - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc deleted file mode 100644 index 227ecf65f..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc +++ /dev/null @@ -1,8 +0,0 @@ - ! v1 - ii = 1 + ll - jj = 1 + ll - IF (cnt .LT. N) THEN - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc deleted file mode 100644 index 28160d0c3..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc +++ /dev/null @@ -1,8 +0,0 @@ - ! v2 - ii = p + 1 - ll - jj = 1 + ll - IF (cnt .LT. N) THEN - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc deleted file mode 100644 index 7fcbe3930..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc +++ /dev/null @@ -1,8 +0,0 @@ - ! v3 - ii = p + 1 - ll - jj = q + 1 - ll - IF (cnt .LT. N) THEN - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc deleted file mode 100644 index 89b7e95ce..000000000 --- a/src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc +++ /dev/null @@ -1,8 +0,0 @@ - ! v4 - ii = 1 + ll - jj = q + 1 - ll - IF (cnt .LT. N) THEN - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END IF diff --git a/src/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt deleted file mode 100644 index 69ce7a34f..000000000 --- a/src/submodules/QuadraturePoint/CMakeLists.txt +++ /dev/null @@ -1,25 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/QuadraturePoint_Method@IOMethods.F90 - ${src_path}/QuadraturePoint_Method@GetMethods.F90 - ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90 -) - diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 deleted file mode 100755 index 9387b1aab..000000000 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,964 +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: 3 March 2021 -! summary: Constructor methods for [[QuadraturePoint_]] - -SUBMODULE(QuadraturePoint_Method) ConstructorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! QuadraturePointIDToName -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePointIDToName -ans = BaseInterpolation_ToString(name) -END PROCEDURE QuadraturePointIDToName - -!---------------------------------------------------------------------------- -! QuadraturePointNameToID -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePointNameToID -ans = BaseInterpolation_ToInteger(name) -END PROCEDURE QuadraturePointNameToID - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate1 -obj%points = points -obj%tXi = SIZE(points, 1) - 1 -! No of row minus one -END PROCEDURE quad_initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate2 -obj%tXi = tXi -CALL Reallocate(obj%points, tXi + 1, tpoints) -END PROCEDURE quad_initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate3 -INTEGER(I4B) :: quadType -quadType = QuadraturePointNameToId(quadratureType) -CALL Initiate( & - & obj=obj, & - & refElem=refElem, & - & order=order, & - & quadratureType=quadType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END PROCEDURE quad_initiate3 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate4 -INTEGER(I4B) :: quadType -quadType = QuadraturePointNameToId(quadratureType) -CALL Initiate( & - & obj=obj, & - & refElem=refElem, & - & nips=nips, & - & quadratureType=quadType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END PROCEDURE quad_initiate4 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate5 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=order, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=order, & - & quadType=quadratureType, & - & refTriangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & order=order, & - & quadType=quadratureType, & - & refQuadrangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=order, & - & quadType=quadratureType, & - & refTetrahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & order=order, & - & quadType=quadratureType, & - & refHexahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=order, & - & quadType=quadratureType, & - & refPrism=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=order, & - & quadType=quadratureType, & - & refPyramid=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=order, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=order, & - & quadType=quadratureType, & - & refTriangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & order=order, & - & quadType=quadratureType, & - & refQuadrangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=order, & - & quadType=quadratureType, & - & refTetrahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & order=order, & - & quadType=quadratureType, & - & refHexahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=order, & - & quadType=quadratureType, & - & refPrism=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=order, & - & quadType=quadratureType, & - & refPyramid=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="[NO CASE FOUND] for the type of refelem", & - & file=__FILE__, & - & routine="quad_initiate5()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate5 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate6 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nips, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nips, & - & quadType=quadratureType, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nips=nips, & - & quadType=quadratureType, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nips, & - & quadType=quadratureType, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nips, & - & quadType=quadratureType, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nips, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nips, & - & quadType=quadratureType, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nips=nips, & - & quadType=quadratureType, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nips, & - & quadType=quadratureType, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nips, & - & quadType=quadratureType, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="No case found", & - & file=__FILE__, & - & routine="quad_initiate6()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate6 - -!---------------------------------------------------------------------------- -! QuadraturePoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate7 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=p, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=p, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & p=p, & - & q=q, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=p, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & p=p, & - & q=q, & - & r=r, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=p, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=p, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=p, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=p, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & p=p, & - & q=q, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=p, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & p=p, & - & q=q, & - & r=r, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=p, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=p, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="No case found", & - & file=__FILE__, & - & routine="quad_initiate7()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate7 - -!---------------------------------------------------------------------------- -! QuadraturePoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_initiate8 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & nipsz=nipsz, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & nipsz=nipsz, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="No case found", & - & file=__FILE__, & - & routine="quad_initiate7()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate8 - -!---------------------------------------------------------------------------- -! QuadraturePoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Constructor1 -obj%points = points -obj%tXi = SIZE(points, 1) - 1 -END PROCEDURE quad_Constructor1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Constructor_1 -ALLOCATE (obj) -obj%points = points -obj%tXi = SIZE(points, 1) - 1 -END PROCEDURE quad_Constructor_1 - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Deallocate -IF (ALLOCATED(obj%points)) DEALLOCATE (obj%points) -obj%tXi = -1 -END PROCEDURE quad_Deallocate - -END SUBMODULE ConstructorMethods diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 deleted file mode 100755 index 126af77a7..000000000 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 +++ /dev/null @@ -1,91 +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: 3 March 2021 -! summary: Constructor methods for [[Quadraturepoints_]] - -SUBMODULE(QuadraturePoint_Method) GetMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SIZE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Size -ans = SIZE(obj%points, dims) -END PROCEDURE quad_Size - -!---------------------------------------------------------------------------- -! getTotalQuadraturepoints -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_getTotalQuadraturepoints -ans = SIZE(obj, 2) -END PROCEDURE quad_getTotalQuadraturepoints - -!---------------------------------------------------------------------------- -! getQuadraturepoints -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_GetQuadraturePoints1 -points = 0.0_DFP -points(1:obj%tXi) = obj%points(1:obj%tXi, Num) -weights = obj%points(obj%tXi + 1, Num) -END PROCEDURE quad_GetQuadraturePoints1 - -!---------------------------------------------------------------------------- -! getQuadraturepoints -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_GetQuadraturePoints2 -INTEGER(I4B) :: n -n = SIZE(obj%points, 2) !#column -CALL Reallocate(points, 3, n) -points(1:obj%tXi, 1:n) = obj%points(1:obj%tXi, 1:n) -weights = obj%points(obj%tXi + 1, 1:n) -END PROCEDURE quad_GetQuadraturePoints2 - -!---------------------------------------------------------------------------- -! Outerprod -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Outerprod -REAL(DFP), ALLOCATABLE :: points(:, :) -INTEGER(I4B) :: n1, n2, n -INTEGER(I4B) :: ii, a, b - -n1 = SIZE(obj1, 2) -n2 = SIZE(obj2, 2) -n = n1 * n2 - -CALL Reallocate(points, 3, n) -DO ii = 1, n1 - a = (ii - 1) * n2 + 1 - b = ii * n2 - points(1, a:b) = obj1%points(1, ii) - points(2, a:b) = obj2%points(1, :) - points(3, a:b) = obj1%points(2, ii) * obj2%points(2, :) -END DO - -CALL Initiate(obj=ans, points=points) -IF (ALLOCATED(points)) DEALLOCATE (points) -END PROCEDURE quad_Outerprod - -END SUBMODULE GetMethods diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 deleted file mode 100644 index 698838d8d..000000000 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 +++ /dev/null @@ -1,70 +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: 3 March 2021 -! summary: This submodule contains the IO method for [[QuadraturePoint_]] - -SUBMODULE(QuadraturePoint_Method) IOMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Display -CALL Display(msg, unitno=unitno) -IF (.NOT. ALLOCATED(obj%points)) THEN - RETURN -END IF -CALL Display(obj%points, msg="# points :", unitno=unitno) -CALL Display(obj%txi, msg="# txi :", unitno=unitno) -END PROCEDURE quad_Display - -!---------------------------------------------------------------------------- -! MdEncode -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_MdEncode -INTEGER(I4B) :: ii, n, jj -TYPE(String), ALLOCATABLE :: rh(:), ch(:) - -IF (.NOT. ALLOCATED(obj%points)) THEN - ans = "" - RETURN -END IF - -n = SIZE(obj%points, 2) -CALL Reallocate(rh, SIZE(obj, 1)) -CALL Reallocate(ch, SIZE(obj, 2)) - -DO ii = 1, SIZE(rh) - 1 - rh(ii) = "`x"//tostring(ii)//"`" -END DO -rh(obj%txi + 1) = "w" - -DO ii = 1, SIZE(ch) - ch(ii) = "`p"//tostring(ii)//"`" -END DO - -ans = MdEncode(obj%points, rh=rh, ch=ch) - -END PROCEDURE QuadraturePoint_MdEncode - -END SUBMODULE IOMethods diff --git a/src/submodules/Random/CMakeLists.txt b/src/submodules/Random/CMakeLists.txt deleted file mode 100644 index 627e36426..000000000 --- a/src/submodules/Random/CMakeLists.txt +++ /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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Random_Method@Methods.F90 -) diff --git a/src/submodules/Random/src/Random_Method@Methods.F90 b/src/submodules/Random/src/Random_Method@Methods.F90 deleted file mode 100644 index a0b369b08..000000000 --- a/src/submodules/Random/src/Random_Method@Methods.F90 +++ /dev/null @@ -1,382 +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(Random_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE initRandom -INTEGER(I4B) :: SeedSize - -CALL RANDOM_SEED(size=SeedSize) -IF (.NOT. ALLOCATED(obj%random_int_seed)) THEN - ALLOCATE (obj%random_int_seed(SeedSize)) -END IF -call RANDOM_SEED(get=obj%random_int_seed) -END PROCEDURE initRandom - -!---------------------------------------------------------------------------- -! getRandom -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getRandom -REAL(DFP) :: val, y -INTEGER(I4B) :: i - -IF (PRESENT(distribution)) THEN - SELECT CASE (TRIM(distribution)) - CASE ("Binomial", "binomial") - val = 0.0d0 - DO i = 1, 20 - CALL RANDOM_NUMBER(y) - val = val + y - END DO - Ans = val - 10.0_DFP - CASE DEFAULT - CALL RANDOM_NUMBER(Ans) - END SELECT -ELSE - CALL RANDOM_NUMBER(Ans) -END IF - -END PROCEDURE getRandom - -!---------------------------------------------------------------------------- -! SaveRandom -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SaveRandom -CALL RANDOM_SEED(put=obj%Random_INT_SEED) -END PROCEDURE SaveRandom - -!---------------------------------------------------------------------------- -! UniformRandom -!---------------------------------------------------------------------------- - -MODULE PROCEDURE uniformRandom -REAL(DFP) :: a, diff, val(2) - -val(1) = From -val(2) = To -diff = abs(From - To) -CALL RANDOM_NUMBER(a) -Ans = a * diff + minval(val) -END PROCEDURE uniformRandom - -!---------------------------------------------------------------------------- -! getRandomInteger -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getRandomInteger -REAL(DFP) :: xr, a, diff, val(2) - -val(1) = From -val(2) = To -diff = abs(dble(from) - dble(to)) - -call random_number(a) -xr = a * diff + minval(val) -Ans = nint(xr) -if (Ans == From - 1) then - Ans = From -end if -if (Ans == To + 1) then - Ans = To -end if -END PROCEDURE getRandomInteger - -!---------------------------------------------------------------------------- -! RandomValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE select_random_int_from_vec -INTEGER(I4B) :: posi -posi = getRandomInteger(obj, From=1, To=size(Val)) -Ans = Val(posi) -END PROCEDURE select_random_int_from_vec - -!---------------------------------------------------------------------------- -! RandomValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE select_random_int_from_array -INTEGER(I4B) :: i1, i2 -i1 = getRandomInteger(obj, From=1, To=SIZE(Val, 1)) -i2 = getRandomInteger(obj, From=1, To=SIZE(Val, 2)) -Ans = Val(i1, i2) -END PROCEDURE select_random_int_from_array - -!---------------------------------------------------------------------------- -! RandomValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE select_random_real_from_vec -INTEGER(I4B) :: posi -posi = getRandomInteger(obj, From=1, To=size(Val)) -Ans = Val(posi) -END PROCEDURE select_random_real_from_vec - -!---------------------------------------------------------------------------- -! RandomValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE select_random_real_from_array -INTEGER(I4B) :: i1, i2 -i1 = getRandomInteger(obj, From=1, To=SIZE(Val, 1)) -i2 = getRandomInteger(obj, From=1, To=SIZE(Val, 2)) -Ans = Val(i1, i2) -END PROCEDURE select_random_real_from_array - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure rvec_uniform_01 -integer(i4b) i -integer(i4b) k -integer(i4b) seed0 -! -seed0 = INPUT(option=seed, default=1_I4B) -! -if (seed0 == 0) then - r = 0.0 - return -end if -! -do i = 1, n - k = seed0 / 127773 - seed0 = 16807 * (seed0 - k * 127773) - k * 2836 - if (seed0 < 0) then - seed0 = seed0 + 2147483647 - end if - r(i) = real(seed0, kind=8) * 4.656612875D-10 -end do -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE rvec_uniform_ab -integer(i4b) i -integer(i4b) k -integer(i4b) seed0 -! -seed0 = INPUT(option=seed, default=1_I4B) -! -if (seed0 == 0) then - r = 0.0 - return -end if -! -do i = 1, n - k = seed0 / 127773 - seed0 = 16807 * (seed0 - k * 127773) - k * 2836 - if (seed0 < 0) then - seed0 = seed0 + 2147483647 - end if - r(i) = a + (b - a) * real(seed0, kind=8) * 4.656612875D-10 -end do -! -END PROCEDURE rvec_uniform_ab - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE rvec_uniform_unit -real(kind=8) norm -! -! Get M values from a standard normal distribution. -! -w = rvec_normal_01(m, seed) -! -! Compute the length of the vector. -! -norm = sqrt(sum(w(1:m)**2)) -! -! Normalize the vector. -! -w(1:m) = w(1:m) / norm - -return -END PROCEDURE rvec_uniform_unit - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure rvec_normal_01 -integer(i4b) m -real(dfp) r(n + 1) -real(dfp), parameter :: r8_pi = 3.141592653589793D+00 -integer(i4b) x_hi_index -integer(i4b) x_lo_index -! integer(i4b), save :: made = 0 -! real(dfp), save :: y = 0.0D+00 -! integer(i4b), save :: saved = 0 -integer(i4b) :: saved -integer(i4b) :: made -real(dfp) :: y -! -made = 0 -y = 0.0_DFP -saved = 0 -! -! I'd like to allow the user to reset the internal data. -! But this won't work properly if we have a saved value Y. -! I'm making a crock option that allows the user to signal -! explicitly that any internal memory should be flushed, -! by passing in a negative value for N. -! -if (n < 0) then - ! n = made - made = 0 - saved = 0 - y = 0.0D+00 - return -else if (n == 0) then - return -end if -! -! Record the range of X we need to fill in. -! -x_lo_index = 1 -x_hi_index = n -! -! Use up the old value, if we have it. -! -if (saved == 1) then - x(1) = y - saved = 0 - x_lo_index = 2 -end if -! -! Maybe we don't need any more values. -! -if (x_hi_index - x_lo_index + 1 == 0) then -! -! If we need just one new value, do that here to avoid null arrays. -! -else if (x_hi_index - x_lo_index + 1 == 1) then - - r(1) = r8_uniform_01(seed) - - if (r(1) == 0.0D+00) then - ! write (*, '(a)') ' ' - ! write (*, '(a)') 'rvec_NORMAL_01 - Fatal error!' - ! write (*, '(a)') ' R8_UNIFORM_01 returned a value of 0.' - ! stop 1 - return - end if - - r(2) = r8_uniform_01(seed) - - x(x_hi_index) = & - sqrt(-2.0D+00 * log(r(1))) * cos(2.0D+00 * r8_pi * r(2)) - y = sqrt(-2.0D+00 * log(r(1))) * sin(2.0D+00 * r8_pi * r(2)) - - saved = 1 - - made = made + 2 -! -! If we require an even number of values, that's easy. -! -else if (mod(x_hi_index - x_lo_index + 1, 2) == 0) then - - m = (x_hi_index - x_lo_index + 1) / 2 - - r = rvec_uniform_01(2 * m, seed) - - x(x_lo_index:x_hi_index - 1:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & - * cos(2.0D+00 * r8_pi * r(2:2 * m:2)) - - x(x_lo_index + 1:x_hi_index:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & - * sin(2.0D+00 * r8_pi * r(2:2 * m:2)) - - made = made + x_hi_index - x_lo_index + 1 -! -! If we require an odd number of values, we generate an even number, -! and handle the last pair specially, storing one in X(N), and -! saving the other for later. -! -else - - x_hi_index = x_hi_index - 1 - - m = (x_hi_index - x_lo_index + 1) / 2 + 1 - - r = rvec_uniform_01(2 * m, seed) - - x(x_lo_index:x_hi_index - 1:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & - * cos(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) - - x(x_lo_index + 1:x_hi_index:2) = & - sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & - * sin(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) - - x(n) = sqrt(-2.0E+00 * log(r(2 * m - 1))) & - * cos(2.0D+00 * r8_pi * r(2 * m)) - - y = sqrt(-2.0D+00 * log(r(2 * m - 1))) & - * sin(2.0D+00 * r8_pi * r(2 * m)) - - saved = 1 - - made = made + x_hi_index - x_lo_index + 2 - -end if -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure r8_uniform_01 -integer(i4b) seed0 -integer(i4b) k -! -seed0 = INPUT(option=seed, default=1_I4B) -! -if (seed0 == 0) then - ans = 0.0 - return -end if -! -k = seed0 / 127773 - -seed0 = 16807 * (seed0 - k * 127773) - k * 2836 - -if (seed0 < 0) then - seed0 = seed0 + 2147483647 -end if -! -! Although SEED can be represented exactly as a 32 bit integer, -! it generally cannot be represented exactly as a 32 bit real number! -! -ans = real(seed0, kind=8) * 4.656612875D-10 -end procedure - -END SUBMODULE Methods diff --git a/src/submodules/Rank2Tensor/CMakeLists.txt b/src/submodules/Rank2Tensor/CMakeLists.txt deleted file mode 100644 index fa0079d1e..000000000 --- a/src/submodules/Rank2Tensor/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 4/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Rank2Tensor_Method@ConstructorMethods.F90 - ${src_path}/Rank2Tensor_Method@IOMethods.F90 - ${src_path}/Rank2Tensor_Method@ContractionMethods.F90 - ${src_path}/Rank2Tensor_Method@InvarMethods.F90 - ${src_path}/Rank2Tensor_Method@OperatorMethods.F90 - ${src_path}/Rank2Tensor_Method@PullbackMethods.F90 - ${src_path}/Rank2Tensor_Method@PushForwardMethods.F90 -) diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 deleted file mode 100644 index 417034404..000000000 --- a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,275 +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(Rank2Tensor_Method) ConstructorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE init_by_rank2 - obj%T = obj2%T - obj%isSym = obj2%isSym -END PROCEDURE init_by_rank2 -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE init_by_mat - obj%T = Mat - IF( PRESENT( isSym ) ) THEN - obj%isSym = isSym - ELSE - obj%isSym = .FALSE. - END IF -END PROCEDURE init_by_mat - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE init_by_voigt - obj%T = V - obj%isSym = .TRUE. -END PROCEDURE init_by_voigt - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE init_voigt_from_r2tensor - CALL Initiate( obj, T=T%T, VoigtType=VoigtType) -END PROCEDURE init_voigt_from_r2tensor - -!---------------------------------------------------------------------------- -! Rank2Tensor -!---------------------------------------------------------------------------- - -MODULE PROCEDURE r2t_by_mat - CALL Initiate( obj=Ans, Mat=Mat, isSym=isSym ) -END PROCEDURE r2t_by_mat - -!---------------------------------------------------------------------------- -! Rank2Tensor -!---------------------------------------------------------------------------- - -MODULE PROCEDURE r2t_by_voigt - CALL Initiate( obj=Ans, V=V ) -END PROCEDURE r2t_by_voigt - -!---------------------------------------------------------------------------- -! Rank2Tensor_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ptr_r2t_by_mat - ALLOCATE( Ans ) - CALL Initiate( obj=Ans, Mat=Mat, isSym=isSym ) -END PROCEDURE ptr_r2t_by_mat - -!---------------------------------------------------------------------------- -! Rank2Tensor_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ptr_r2t_by_voigt - ALLOCATE( Ans ) - CALL Initiate( obj=Ans, V=V ) -END PROCEDURE ptr_r2t_by_voigt - -!---------------------------------------------------------------------------- -! Assignment -!---------------------------------------------------------------------------- - -MODULE PROCEDURE r2tensor_eq_mat - CALL Initiate( obj=obj, Mat=Mat ) -END PROCEDURE r2tensor_eq_mat - -!---------------------------------------------------------------------------- -! Assignment -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat_eq_r2tensor - Mat = obj%T -END PROCEDURE mat_eq_r2tensor - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE voigt_eq_r2tensor - CALL Initiate( obj=V, T=obj%T, VoigtType=StressTypeVoigt) -END PROCEDURE voigt_eq_r2tensor - -!---------------------------------------------------------------------------- -! Identity -!---------------------------------------------------------------------------- - -MODULE PROCEDURE identity_rank2 - CALL Initiate( obj=obj, Mat=Eye3, isSym=.TRUE. ) -END PROCEDURE identity_rank2 - -!---------------------------------------------------------------------------- -! ones -!---------------------------------------------------------------------------- - -MODULE PROCEDURE rank2_getOnes - REAL( DFP ) :: T( 3, 3 ) - T = 1.0_DFP - CALL Initiate( obj=obj, Mat=T, isSym=.TRUE. ) -END PROCEDURE rank2_getOnes - -!---------------------------------------------------------------------------- -! zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE rank2_getZeros - REAL( DFP ) :: T( 3, 3 ) - T = 0.0_DFP - CALL Initiate( obj=obj, Mat=T, isSym=.TRUE. ) -END PROCEDURE rank2_getZeros - -!---------------------------------------------------------------------------- -! IsotropicTensor -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isotropic_rank2 - CALL Initiate( obj=obj, Mat=Lambda*Eye3, isSym=.TRUE. ) -END PROCEDURE isotropic_rank2 - -!---------------------------------------------------------------------------- -! Sym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE sym_r2t - IF( obj%isSym ) THEN - CALL Initiate( obj=Ans, Mat=obj%T, isSym = .TRUE. ) - ELSE - CALL Initiate( obj=Ans, Mat=SYM( obj%T ), isSym = .TRUE. ) - END IF -END PROCEDURE sym_r2t - -!---------------------------------------------------------------------------- -! SkewSym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE skewsym_r2t - CALL Initiate( obj=Ans, Mat=SkewSym(obj%T), isSym=.FALSE. ) -END PROCEDURE skewsym_r2t - -!---------------------------------------------------------------------------- -! Transpose -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_transpose - CALL Initiate( Ans, Mat = TRANSPOSE(obj%T), isSym=obj%isSym ) -END PROCEDURE obj_transpose - -!---------------------------------------------------------------------------- -! isSym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isSym_rank2 - Ans = obj%isSym -END PROCEDURE isSym_rank2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isDeviatoric_rank2 - Ans = ABS( obj%T(1,1)+obj%T(2,2)+obj%T(3,3) ) .LE. 1.0E-12 -END PROCEDURE isDeviatoric_rank2 - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE inv_rank2 - CALL INV( A=obj%T, InvA=Invobj%T ) - Invobj%isSym = obj%isSym -END PROCEDURE inv_rank2 - -!---------------------------------------------------------------------------- -! DeformationGradient -!---------------------------------------------------------------------------- - -MODULE PROCEDURE F_constructor1 - IF( PRESENT( obj ) ) THEN - CALL initiate( Ans, obj ) - END IF -END PROCEDURE F_constructor1 - -!---------------------------------------------------------------------------- -! DeformationGradient_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE F_constructor_1 - ALLOCATE( Ans ) - Ans = DeformationGradient( obj ) -END PROCEDURE F_constructor_1 - -!---------------------------------------------------------------------------- -! LeftCauchyGreen -!---------------------------------------------------------------------------- - -MODULE PROCEDURE b_constructor1 - IF( PRESENT( F ) ) THEN - Ans = MATMUL( F, TRANSPOSE( F ) ) - ELSE IF( PRESENT( V ) ) THEN - Ans = MATMUL( V, V ) - END IF - Ans%isSym = .TRUE. -END PROCEDURE b_constructor1 - -!---------------------------------------------------------------------------- -! LeftCauchyGreen_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE b_constructor_1 - ALLOCATE( Ans ) - Ans = LeftCauchyGreen( F=F, V=V ) -END PROCEDURE b_constructor_1 - -!---------------------------------------------------------------------------- -! RightCauchyGreen -!---------------------------------------------------------------------------- - -MODULE PROCEDURE C_constructor1 - IF( PRESENT( F ) ) THEN - Ans = MATMUL( TRANSPOSE( F ), F ) - ELSE IF( PRESENT( U ) ) THEN - Ans = MATMUL( U, U ) - END IF - Ans%isSym = .TRUE. -END PROCEDURE C_constructor1 - -!---------------------------------------------------------------------------- -! RightCauchyGreen_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE C_constructor_1 - ALLOCATE( Ans ) - Ans = RightCauchyGreen( F=F, U=U ) -END PROCEDURE C_constructor_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE ConstructorMethods diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 deleted file mode 100644 index b9e7c549c..000000000 --- a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 +++ /dev/null @@ -1,89 +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: 17 March 2021 -! summary: Submodules for computing the contraction - -#define T_11 T( 1, 1 ) -#define T_12 T( 1, 2 ) -#define T_13 T( 1, 3 ) -#define T_21 T( 2, 1 ) -#define T_22 T( 2, 2 ) -#define T_23 T( 2, 3 ) -#define T_31 T( 3, 1 ) -#define T_32 T( 3, 2 ) -#define T_33 T( 3, 3 ) - -SUBMODULE(Rank2Tensor_Method) ContractionMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE r2_contract_r2 - Ans = SUM( obj1%T * obj2%T ) -END PROCEDURE r2_contract_r2 - -!---------------------------------------------------------------------------- -! Contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE r2_contract_voigt_r2 - ASSOCIATE( T => obj1%T, V => obj2%V, Scale => obj2%Scale ) - Ans = T_11 * V( 1 ) & - & + T_22 * V( 2 ) & - & + T_33 * V( 3 ) & - & + (T_12 + T_21) * V( 4 ) * Scale & - & + (T_23 + T_32) * V( 5 ) * Scale & - & + (T_13 + T_31) * V( 6 ) * Scale - END ASSOCIATE -END PROCEDURE r2_contract_voigt_r2 - -!---------------------------------------------------------------------------- -! Contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE voigt_r2_contract_r2 - Ans = r2_contract_voigt_r2( obj1=obj2, obj2=obj1 ) -END PROCEDURE voigt_r2_contract_r2 - -!---------------------------------------------------------------------------- -! Contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE voigt_r2_contract_voigt_r2 - ASSOCIATE( A => obj1%V, B => obj2%V, S1 => obj1%Scale, S2 => obj2%Scale ) - Ans = A( 1 ) * B( 1 ) + A( 2 ) * B( 2 ) + A( 3 ) * B( 3 ) & - & + 2.0 * S1 * S2 * ( A( 4 ) * B( 4 ) & - & + A( 5 ) * B( 5 ) + A( 6 ) * B( 6 ) ) - END ASSOCIATE -END PROCEDURE voigt_r2_contract_voigt_r2 - -#undef T_11 -#undef T_12 -#undef T_13 -#undef T_21 -#undef T_22 -#undef T_23 -#undef T_31 -#undef T_32 -#undef T_33 -END SUBMODULE ContractionMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 deleted file mode 100644 index a0c8439af..000000000 --- a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 +++ /dev/null @@ -1,32 +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(Rank2Tensor_Method) IOMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display@constructor -!---------------------------------------------------------------------------- - -MODULE PROCEDURE display_obj - CALL Display( obj%T, MSG=MSG, & - & UnitNo=INPUT( default = stdout, option=UnitNo ) ) -END PROCEDURE display_obj - -END SUBMODULE IOMethods diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 deleted file mode 100644 index 3c3a6847e..000000000 --- a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 +++ /dev/null @@ -1,335 +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(Rank2Tensor_Method) InvarMethods -USE BaseMethod -#define T_11 T( 1, 1 ) -#define T_12 T( 1, 2 ) -#define T_13 T( 1, 3 ) -#define T_21 T( 2, 1 ) -#define T_22 T( 2, 2 ) -#define T_23 T( 2, 3 ) -#define T_31 T( 3, 1 ) -#define T_32 T( 3, 2 ) -#define T_33 T( 3, 3 ) -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE trace_obj -ASSOCIATE (T => obj%T) - IF (PRESENT(Power)) THEN - SELECT CASE (Power) - CASE (1) - Ans = T_11 + T_22 + T_33 - CASE (2) - Ans = SUM(T * TRANSPOSE(T)) - CASE (3) - Ans = SUM(MATMUL(T, T) * TRANSPOSE(T)) - END SELECT - ELSE - Ans = T_11 + T_22 + T_33 - END IF -END ASSOCIATE -END PROCEDURE trace_obj - -!---------------------------------------------------------------------------- -! J2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE j2_obj -LOGICAL(LGT) :: isDev -isDev = INPUT(default=.FALSE., option=isDeviatoric) -IF (isDev) THEN - Ans = 0.5_DFP * Trace(obj=obj, Power=2) -ELSE - ASSOCIATE (T => obj%T) - Ans = (T_11 - T_22)**2 & - & + (T_22 - T_33)**2 & - & + (T_33 - T_11)**2 & - & + 6.0_DFP * (T_12 * T_21 + T_23 * T_32 + T_13 * T_31) - Ans = Ans / 6.0_DFP - END ASSOCIATE -END IF -END PROCEDURE j2_obj - -!---------------------------------------------------------------------------- -! J3 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE j3_obj -LOGICAL(LGT) :: isDev -isDev = INPUT(default=.FALSE., option=isDeviatoric) -IF (isDev) THEN - Ans = det(obj) -ELSE - Ans = det(Deviatoric(obj)) -END IF -END PROCEDURE j3_obj - -!---------------------------------------------------------------------------- -! Det -!---------------------------------------------------------------------------- - -MODULE PROCEDURE det_obj -ASSOCIATE (T => obj%T) - Ans = T(1, 1) * (T(2, 2) * T(3, 3) - T(2, 3) * T(3, 2)) & - & - T(1, 2) * (T(2, 1) * T(3, 3) - T(2, 3) * T(3, 1)) & - & + T(1, 3) * (T(2, 1) * T(3, 2) - T(3, 1) * T(2, 2)) -END ASSOCIATE -END PROCEDURE det_obj - -!---------------------------------------------------------------------------- -! LodeAngle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE theta_obj_j2j3 -REAL(DFP) :: J_2, J_3, Dummy -J_2 = J2; J_3 = J3 -IF (J_2 .EQ. 0.0_DFP) THEN - Ans = 0.0_DFP -ELSE - Dummy = 1.5_DFP * SQRT(3.0_DFP) * J_3 / (J_2 * SQRT(J_2)) - IF (Dummy .GE. 1.0_DFP) Dummy = 1.0_DFP - IF (Dummy .LE. -1.0_DFP) Dummy = -1.0_DFP - IF (LodeType .EQ. SineLode) Ans = ASIN(-Dummy) / 3.0_DFP - IF (LodeType .EQ. CosineLode) Ans = ACOS(Dummy) / 3.0_DFP -END IF -END PROCEDURE theta_obj_j2j3 - -!---------------------------------------------------------------------------- -! LodeAngle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE theta_obj -Ans = LodeAngle(LodeType=LodeType, & - & J2=J2(obj, isDeviatoric), & - & J3=J3(obj, isDeviatoric)) -END PROCEDURE theta_obj - -!---------------------------------------------------------------------------- -! Isotropic -!---------------------------------------------------------------------------- - -MODULE PROCEDURE iso_part_obj -CALL IsotropicTensor(obj=Ans, Lambda=Trace(obj) / 3.0_DFP) -END PROCEDURE iso_part_obj - -!---------------------------------------------------------------------------- -! Deviatoric -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dev_part_obj -REAL(DFP) :: a -ASSOCIATE (T => Ans%T) - a = Trace(obj) / 3.0_DFP - T = 0.0_DFP - T_11 = a - T_22 = a - T_33 = a - T = -T + obj%T -END ASSOCIATE -END PROCEDURE dev_part_obj - -!---------------------------------------------------------------------------- -! Invariants -!---------------------------------------------------------------------------- - -MODULE PROCEDURE invariants_rank2 -LOGICAL(LGT) :: isDev - -isDev = INPUT(default=.FALSE., option=isDeviatoric) -IF (isDev) THEN - Ans(1) = 0.0 - Ans(2) = 0.5_DFP * Contraction(obj, TRANSPOSE(obj)) - Ans(3) = Det(obj) -ELSE - Ans(1) = Trace(obj) - Ans(2) = 0.5_DFP * (Ans(1)**2 - Trace(obj, Power=2)) - Ans(3) = Det(obj) -END IF -END PROCEDURE invariants_rank2 - -!---------------------------------------------------------------------------- -! Spectral -!---------------------------------------------------------------------------- - -MODULE PROCEDURE eigen_r2t -REAL(DFP) :: Mat(3, 3) -Mat = obj%T -IF (obj%isSym) THEN - CALL GetSymEigenJacobi(Mat=Mat, EigenValues=WR, EigenVectors=QR, MaxIter=100) -ELSE - CALL spectral_r2t(obj%T, QR=QR, WR=WR, QI=QI, WI=WI) -END IF -END PROCEDURE eigen_r2t - -!---------------------------------------------------------------------------- -! Spectral -!---------------------------------------------------------------------------- - -SUBROUTINE spectral_r2t(T, QR, WR, QI, WI) - REAL(DFP), INTENT(IN) :: T(3, 3) - REAL(DFP), INTENT(INOUT) :: QR(3, 3), QI(3, 3) - REAL(DFP), INTENT(OUT) :: WR(3), WI(3) - - ! Define internal varuables - REAL(DFP) :: EigenVec(3, 3) - REAL(DFP) :: Mat(3, 3) - - Mat = T - CALL GEEV(A=Mat, WR=WR, WI=WI, VR=EigenVec) - - ! First two eigen value is complex - IF (ABS(WI(1)) .GT. Zero) THEN - QR(:, 1) = EigenVec(:, 1) - QI(:, 1) = EigenVec(:, 2) - QR(:, 2) = EigenVec(:, 1) - QI(:, 2) = -EigenVec(:, 2) - QR(:, 3) = EigenVec(:, 3) - QI(:, 3) = 0.0_DFP - ! Last two eigen value is complex - ELSE IF (ABS(WI(2)) .GT. Zero) THEN - QR(:, 1) = EigenVec(:, 1) - QI(:, 1) = 0.0_DFP - QR(:, 2) = EigenVec(:, 2) - QI(:, 2) = EigenVec(:, 3) - QR(:, 3) = EigenVec(:, 2) - QI(:, 3) = -EigenVec(:, 3) - ! no complex eigen value - ELSE - QI = 0.0_DFP - QR(:, 1) = EigenVec(:, 1) - QR(:, 2) = EigenVec(:, 2) - QR(:, 3) = EigenVec(:, 3) - END IF -END SUBROUTINE spectral_r2t - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pd_r2t -CALL PD(Mat=obj%T, R=R%T, U=U%T, V=V%T) -U%isSym = .TRUE. -V%isSym = .TRUE. -END PROCEDURE pd_r2t - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 17 March 2021 -! summary: Polar decomposition -! -!# Introduction -! This subroutine calculates the polar decomposition -! * Ref: Higham and Noferini, 2015 Algorithm 3.1 for NSD = 3 -! * PDType = 1 for F = RU; and 2 for F = VR -! * Mat = RU = VR, Therefore H denotes either U or V - -SUBROUTINE PD(Mat, R, U, V) - ! Define intent of dummy variables - REAL(DFP), INTENT(IN) :: Mat(3, 3) - REAL(DFP), INTENT(INOUT) :: R(3, 3) - REAL(DFP), INTENT(INOUT) :: U(3, 3) - REAL(DFP), INTENT(INOUT) :: V(3, 3) - - ! Define internal variables - REAL(DFP) :: RT(3, 3) - REAL(DFP) :: B(4, 4) - REAL(DFP) :: EigenVecs(4, 4) - REAL(DFP) :: EigenVals(4) - REAL(DFP) :: Vmax(4) - INTEGER(I4B) :: MAX_LOC(1) - - B(1, 1) = Mat(1, 1) + Mat(2, 2) + Mat(3, 3) - B(1, 2) = Mat(2, 3) - Mat(3, 2) - B(1, 3) = Mat(3, 1) - Mat(1, 3) - B(1, 4) = Mat(1, 2) - Mat(2, 1) - B(2, 1) = Mat(1, 2) - B(2, 2) = Mat(1, 1) - Mat(2, 2) - Mat(3, 3) - B(2, 3) = Mat(1, 2) + Mat(2, 1) - B(2, 4) = Mat(1, 3) + Mat(3, 1) - B(3, 1) = B(1, 3) - B(3, 2) = B(2, 3) - B(3, 3) = -Mat(1, 1) + Mat(2, 2) - Mat(3, 3) - B(3, 4) = Mat(2, 3) + Mat(3, 2) - B(4, 1) = B(1, 4) - B(4, 2) = B(2, 4) - B(4, 3) = B(3, 4) - B(4, 4) = -Mat(1, 1) - Mat(2, 2) + Mat(3, 3) - - CALL GetSymEigenJacobi( & - & Mat=B, EigenValues=EigenVals, & - & EigenVectors=EigenVecs, MaxIter=100) - - ! Get Dominating eigen value and corresponding eigen vectors - MAX_LOC = MAXLOC(ABS(EigenVals)) - Vmax = EigenVecs(:, MAX_LOC(1)) - - ! Compute R matrix from Vmax Vector - R(1, 1) = 1.0_DFP - 2.0_DFP * (Vmax(3) * Vmax(3) + Vmax(4) * Vmax(4)) - RT(1, 1) = R(1, 1) - - R(1, 2) = 2.0_DFP * (Vmax(2) * Vmax(3) + Vmax(1) * Vmax(4)) - RT(2, 1) = R(1, 2) - - R(1, 3) = 2.0_DFP * (Vmax(2) * Vmax(4) - Vmax(1) * Vmax(3)) - RT(3, 1) = R(1, 3) - - R(2, 1) = 2.0_DFP * (Vmax(2) * Vmax(3) - Vmax(1) * Vmax(4)) - RT(1, 2) = R(2, 1) - - R(2, 2) = 1.0_DFP - 2.0_DFP * (Vmax(2) * Vmax(2) + Vmax(4) * Vmax(4)) - RT(2, 2) = R(2, 2) - - R(2, 3) = 2.0_DFP * (Vmax(3) * Vmax(4) + Vmax(1) * Vmax(2)) - RT(3, 2) = R(2, 3) - - R(3, 1) = 2.0_DFP * (Vmax(2) * Vmax(4) + Vmax(1) * Vmax(3)) - RT(1, 3) = R(3, 1) - - R(3, 2) = 2.0_DFP * (Vmax(3) * Vmax(4) - Vmax(1) * Vmax(2)) - RT(2, 3) = R(3, 2) - - R(3, 3) = 1.0_DFP - 2.0_DFP * (Vmax(3) * Vmax(3) + Vmax(2) * Vmax(2)) - RT(3, 3) = R(3, 3) - - U = MATMUL(RT, Mat) - V = MATMUL(Mat, RT) -END SUBROUTINE PD - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#undef T_11 -#undef T_12 -#undef T_13 -#undef T_21 -#undef T_22 -#undef T_23 -#undef T_31 -#undef T_32 -#undef T_33 - -END SUBMODULE InvarMethods diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 deleted file mode 100644 index 1ab8f27ff..000000000 --- a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 +++ /dev/null @@ -1,163 +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: 17 March 2021 -! summary: This subroutine contains algebraic operator - -SUBMODULE(Rank2Tensor_Method) OperatorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_add_obj - Ans%T = obj1%T + obj2%T - IF( obj1%isSym .AND. obj2%isSym ) Ans%isSym = .TRUE. -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_add_Scalar - Ans%T = obj1%T + obj2 - Ans%isSym = obj1%isSym -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Scalar_add_obj - Ans%T = obj1 + obj2%T - Ans%isSym = obj2%isSym -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_minus_obj - Ans%T = obj1%T - obj2%T - IF( obj1%isSym .AND. obj2%isSym ) Ans%isSym = .TRUE. - -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_minus_Scalar - Ans%T = obj1%T - obj2 - Ans%isSym = obj1%isSym -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Scalar_minus_obj - Ans%T = obj1 - obj2%T - Ans%isSym = obj2%isSym -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_times_obj - Ans%T = obj1%T * obj2%T -END PROCEDURE obj_times_obj - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_times_scalar - Ans%T = obj1%T * obj2 - Ans%isSym = obj1%isSym -END PROCEDURE obj_times_scalar - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_times_obj - Ans%T = obj1 * obj2%T - Ans%isSym = obj2%isSym -END PROCEDURE scalar_times_obj - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_div_obj - Ans%T = obj1%T / obj2%T -END PROCEDURE obj_div_obj - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_div_scalar - Ans%T = obj1%T / obj2 - Ans%isSym = obj1%isSym -END PROCEDURE obj_div_scalar - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_div_obj - Ans%T = obj1 / obj2%T - Ans%isSym = obj2%isSym -END PROCEDURE scalar_div_obj - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_matmul_obj - Ans%T = MATMUL( obj1%T, obj2%T ) -END PROCEDURE obj_matmul_obj - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_matmul_vec - Ans = MATMUL( obj1%T, obj2 ) -END PROCEDURE obj_matmul_vec - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vec_matmul_obj - Ans = MATMUL( obj1, obj2%T ) -END PROCEDURE vec_matmul_obj - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE OperatorMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 deleted file mode 100644 index 15fd67e8c..000000000 --- a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 +++ /dev/null @@ -1,90 +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: 17 March 2021 -! summary: Methods for pull back of rank2 tensor - -SUBMODULE(Rank2Tensor_Method) PullBackMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pullback_rank2 - TYPE( Rank2Tensor_ ) :: InvF - - SELECT CASE ( TRIM( indx1 ) ) - CASE( "NA" ) - SELECT CASE( TRIM( indx2 ) ) - CASE( "CONTRAVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL ( T, TRANSPOSE(InvF) ) - CASE( "COVAR" ) - Ans = MATMUL ( T, F ) - CASE( "NA" ) - Ans = T - END SELECT - - CASE( "CONTRAVAR" ) - SELECT CASE( TRIM( indx2 ) ) - CASE( "CONTRAVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( InvF, MATMUL (T, TRANSPOSE(InvF)) ) - CASE( "COVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( InvF, MATMUL ( T, F ) ) - CASE( "NA" ) - CALL INV( F, InvF ) - Ans = MATMUL( InvF, T ) - END SELECT - - CASE( "COVAR" ) - SELECT CASE( TRIM( indx2 ) ) - CASE( "CONTRAVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( TRANSPOSE(F), MATMUL(T, TRANSPOSE(InvF)) ) - CASE( "COVAR" ) - Ans = MATMUL( TRANSPOSE(F), MATMUL(T, F) ) - CASE( "NA" ) - Ans = MATMUL( TRANSPOSE(F), T ) - END SELECT - END SELECT - -END PROCEDURE pullback_rank2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pullback_vec - TYPE( Rank2Tensor_ ) :: InvF - SELECT CASE ( TRIM( indx1 ) ) - CASE( "NA" ) - Ans = Vec - CASE( "CONTRAVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( InvF, Vec ) - CASE( "COVAR" ) - Ans = MATMUL( TRANSPOSE(F), Vec ) - END SELECT -END PROCEDURE pullback_vec - -END SUBMODULE PullBackMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 deleted file mode 100644 index 2f3daf517..000000000 --- a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 +++ /dev/null @@ -1,90 +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: 17 March 2021 -! summary: Methods for pull back of rank2 tensor - -SUBMODULE(Rank2Tensor_Method) PushForwardMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE PushForward_rank2 - TYPE( Rank2Tensor_ ) :: InvF - - SELECT CASE ( TRIM( indx1 ) ) - CASE( "NA" ) - SELECT CASE( TRIM( indx2 ) ) - CASE( "CONTRAVAR" ) - Ans = MATMUL( T, TRANSPOSE(F) ) - CASE( "COVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( T, InvF ) - CASE( "NA" ) - Ans = T - END SELECT - - CASE( "CONTRAVAR" ) - SELECT CASE( TRIM( indx2 ) ) - CASE( "CONTRAVAR" ) - Ans = MATMUL( F, MATMUL(T, TRANSPOSE(F)) ) - CASE( "COVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( F, MATMUL ( T, InvF ) ) - CASE( "NA" ) - Ans = MATMUL( F, T ) - END SELECT - - CASE( "COVAR" ) - SELECT CASE( TRIM( indx2 ) ) - CASE( "CONTRAVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( TRANSPOSE(InvF), MATMUL(T, TRANSPOSE(F)) ) - CASE( "COVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( TRANSPOSE(InvF), MATMUL(T, InvF) ) - CASE( "NA" ) - CALL INV( F, InvF ) - Ans = MATMUL( TRANSPOSE( InvF ), T ) - END SELECT - END SELECT - -END PROCEDURE PushForward_rank2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE PushForward_vec - TYPE( Rank2Tensor_ ) :: InvF - SELECT CASE ( TRIM( indx1 ) ) - CASE( "NA" ) - Ans = Vec - CASE( "CONTRAVAR" ) - Ans = MATMUL( F, Vec ) - CASE( "COVAR" ) - CALL INV( F, InvF ) - Ans = MATMUL( TRANSPOSE(InvF), Vec ) - END SELECT -END PROCEDURE PushForward_vec - -END SUBMODULE PushForwardMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/matrix_exponential.F90 b/src/submodules/Rank2Tensor/src/matrix_exponential.F90 deleted file mode 100644 index 765b9b9d4..000000000 --- a/src/submodules/Rank2Tensor/src/matrix_exponential.F90 +++ /dev/null @@ -1,502 +0,0 @@ -subroutine c8mat_expm1 ( n, a, e ) - -!*****************************************************************************80 -! -!! C8MAT_EXPM1 is essentially MATLAB's built-in matrix exponential algorithm. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 01 March 2013 -! -! Author: -! -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! Cleve Moler, Charles VanLoan, -! Nineteen Dubious Ways to Compute the Exponential of a Matrix, -! Twenty-Five Years Later, -! SIAM Review, -! Volume 45, Number 1, March 2003, pages 3-49. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the dimension of the matrix. -! -! Input, complex ( kind = 8 ) A(N,N), the matrix. -! -! Output, complex ( kind = 8 ) E(N,N), the estimate for exp(A). -! - implicit none - - integer ( kind = 4 ) n - - complex ( kind = 8 ) a(n,n) - complex ( kind = 8 ) a2(n,n) - real ( kind = 8 ) a_norm - real ( kind = 8 ) c - real ( kind = 8 ) c8mat_norm_li - complex ( kind = 8 ) d(n,n) - complex ( kind = 8 ) e(n,n) - integer ( kind = 4 ) ee - integer ( kind = 4 ) k - logical p - integer ( kind = 4 ) , parameter :: q = 6 - real ( kind = 8 ) r8_log_2 - integer ( kind = 4 ) s - complex ( kind = 8 ) x(n,n) -! -! Make a copy of the matrix. -! - a2(1:n,1:n) = a(1:n,1:n) -! -! Compute the L-infinity norm. -! - a_norm = c8mat_norm_li ( n, n, a2 ) -! -! Determine a scaling factor for the matrix. -! - ee = int ( r8_log_2 ( a_norm ) ) + 1 - - s = max ( 0, ee + 1 ) - - a2(1:n,1:n) = a2(1:n,1:n) / 2.0D+00 ** s - - x(1:n,1:n) = a2(1:n,1:n) - - c = 0.5D+00 - - call c8mat_identity ( n, e ) - e(1:n,1:n) = e(1:n,1:n) + c * a2(1:n,1:n) - - call c8mat_identity ( n, d ) - d(1:n,1:n) = d(1:n,1:n) - c * a2(1:n,1:n) - - p = .true. - - do k = 2, q - - c = c * real ( q - k + 1, kind = 8 ) & - / real ( k * ( 2 * q - k + 1 ), kind = 8 ) - - x(1:n,1:n) = matmul ( a2(1:n,1:n), x(1:n,1:n) ) - - e(1:n,1:n) = e(1:n,1:n) + c * x(1:n,1:n) - - if ( p ) then - d(1:n,1:n) = d(1:n,1:n) + c * x(1:n,1:n) - else - d(1:n,1:n) = d(1:n,1:n) - c * x(1:n,1:n) - end if - - p = .not. p - - end do -! -! E -> inverse(D) * E -! - call c8mat_minvm ( n, n, d, e, e ) -! -! E -> E^(2*S) -! - do k = 1, s - e(1:n,1:n) = matmul ( e(1:n,1:n), e(1:n,1:n) ) - end do - - return -end - -subroutine r8mat_expm1 ( n, a, e ) - -!*****************************************************************************80 -! -!! R8MAT_EXPM1 is essentially MATLAB's built-in matrix exponential algorithm. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 November 2011 -! -! Author: -! -! Cleve Moler, Charles Van Loan -! -! Reference: -! -! Cleve Moler, Charles VanLoan, -! Nineteen Dubious Ways to Compute the Exponential of a Matrix, -! Twenty-Five Years Later, -! SIAM Review, -! Volume 45, Number 1, March 2003, pages 3-49. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the dimension of the matrix. -! -! Input, real ( kind = 8 ) A(N,N), the matrix. -! -! Output, real ( kind = 8 ) E(N,N), the estimate for exp(A). -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n,n) - real ( kind = 8 ) a2(n,n) - real ( kind = 8 ) a_norm - real ( kind = 8 ) c - real ( kind = 8 ) d(n,n) - real ( kind = 8 ) e(n,n) - integer ( kind = 4 ) ee - integer ( kind = 4 ) k - logical p - integer ( kind = 4 ) , parameter :: q = 6 - real ( kind = 8 ) r8_log_2 - real ( kind = 8 ) r8mat_norm_li - integer ( kind = 4 ) s - real ( kind = 8 ) x(n,n) - - a2(1:n,1:n) = a(1:n,1:n) - - a_norm = r8mat_norm_li ( n, n, a2 ) - - ee = int ( r8_log_2 ( a_norm ) ) + 1 - - s = max ( 0, ee + 1 ) - - a2(1:n,1:n) = a2(1:n,1:n) / 2.0D+00**s - - x(1:n,1:n) = a2(1:n,1:n) - - c = 0.5D+00 - - call r8mat_identity ( n, e ) - e(1:n,1:n) = e(1:n,1:n) + c * a2(1:n,1:n) - - call r8mat_identity ( n, d ) - d(1:n,1:n) = d(1:n,1:n) - c * a2(1:n,1:n) - - p = .true. - - do k = 2, q - - c = c * real ( q - k + 1, kind = 8 ) & - / real ( k * ( 2 * q - k + 1 ), kind = 8 ) - - x(1:n,1:n) = matmul ( a2(1:n,1:n), x(1:n,1:n) ) - - e(1:n,1:n) = e(1:n,1:n) + c * x(1:n,1:n) - - if ( p ) then - d(1:n,1:n) = d(1:n,1:n) + c * x(1:n,1:n) - else - d(1:n,1:n) = d(1:n,1:n) - c * x(1:n,1:n) - end if - - p = .not. p - - end do -! -! E -> inverse(D) * E -! - call r8mat_minvm ( n, n, d, e, e ) -! -! E -> E^(2*S) -! - do k = 1, s - e(1:n,1:n) = matmul ( e(1:n,1:n), e(1:n,1:n) ) - end do - - return -end - -subroutine r8mat_expm2 ( n, a, e ) - -!*****************************************************************************80 -! -!! R8MAT_EXPM2 uses the Taylor series for the matrix exponential. -! -! Discussion: -! -! Formally, -! -! exp ( A ) = I + A + 1/2 A^2 + 1/3! A^3 + ... -! -! This function sums the series until a tolerance is satisfied. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 November 2011 -! -! Author: -! -! Cleve Moler, Charles Van Loan -! -! Reference: -! -! Cleve Moler, Charles VanLoan, -! Nineteen Dubious Ways to Compute the Exponential of a Matrix, -! Twenty-Five Years Later, -! SIAM Review, -! Volume 45, Number 1, March 2003, pages 3-49. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the dimension of the matrix. -! -! Input, real ( kind = 8 ) A(N,N), the matrix. -! -! Output, real ( kind = 8 ) E(N,N), the estimate for exp(A). -! - implicit none - - integer ( kind = 4 ) n - - real ( kind = 8 ) a(n,n) - real ( kind = 8 ) e(n,n) - real ( kind = 8 ) f(n,n) - real ( kind = 8 ) g(n,n) - integer ( kind = 4 ) k - logical r8mat_insignificant - - e(1:n,1:n) = 0.0D+00 - - call r8mat_identity ( n, f ) - - k = 1 - - do - - if ( r8mat_insignificant ( n, n, e, f ) ) then - exit - end if - - e(1:n,1:n) = e(1:n,1:n) + f(1:n,1:n) - - f(1:n,1:n) = matmul ( a(1:n,1:n), f(1:n,1:n) ) / real ( k, kind = 8 ) - k = k + 1 - - end do - - return -end - -subroutine r8mat_expm3 ( n, a, e ) - -!*****************************************************************************80 -! -!! R8MAT_EXPM3 approximates the matrix exponential using an eigenvalue approach. -! -! Discussion: -! -! exp(A) = V * D * V -! -! where V is the matrix of eigenvectors of A, and D is the diagonal matrix -! whose i-th diagonal entry is exp(lambda(i)), for lambda(i) an eigenvalue -! of A. -! -! This function is accurate for matrices which are symmetric, orthogonal, -! or normal. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 26 November 2011 -! -! Author: -! -! Cleve Moler, Charles Van Loan -! -! Reference: -! -! Cleve Moler, Charles VanLoan, -! Nineteen Dubious Ways to Compute the Exponential of a Matrix, -! Twenty-Five Years Later, -! SIAM Review, -! Volume 45, Number 1, March 2003, pages 3-49. -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the dimension of the matrix. -! -! Input, real ( kind = 8 ) A(N,N), the matrix. -! -! Output, real ( kind = 8 ) E(N,N), the estimate for exp(A). -! -! [ V, D ] = eig ( A ); -! E = V * diag ( exp ( diag ( D ) ) ) / V; - - return -end - - -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: TensorFunctions.part -! Last Update : Dec-16-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of module -! -! DESCRIPTION :: -! - This part contains subroutines for computing various -! Tensor valued Tensor functions -! -! HOSTING FILE -! - Rank2Tensor_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! TensorPower -!------------------------------------------------------------------------------ - -! RECURSIVE FUNCTION TensorPower( N, T, TSquare, I1, I2, I3 ) RESULT( TP ) - -! ! Description -! !. . . . . . . . . . . . . . . . . . . . -! ! 1. - T^n is computed using Cayley-Hamilton theorem -! !. . . . . . . . . . . . . . . . . . . . - -! USE Utility, ONLY : Eye - -! ! Define Intent of dummy variables -! REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: T, TSquare -! REAL( DFP ), DIMENSION( SIZE( T, 1 ), SIZE( T, 2 ) ) :: TP -! REAL( DFP ), INTENT( IN ) :: I1, I2, I3 -! INTEGER( I4B ), INTENT( IN ) :: N - -! ! Define internal variables -! INTEGER( I4B ) :: I -! Error_Flag = .FALSE. - -! SELECT CASE( N ) - -! CASE( 0 ) -! TP = Eye( SIZE( T, 1 ) ) -! CASE( 1 ) -! TP = T -! CASE( 2 ) -! TP = TSquare -! CASE DEFAULT -! TP = I1 * TensorPower( N-1, T, TSquare, I1, I2, I3 ) & -! - I2 * TensorPower( N-2, T, TSquare, I1, I2, I3 ) & -! + I3 * TensorPower( N-3, T, TSquare, I1, I2, I3 ) -! END SELECT -! ! -! END FUNCTION TensorPower - -!------------------------------------------------------------------------------ -! f_TensorEXP_1 -!------------------------------------------------------------------------------ - - FUNCTION f_TensorEXP_1( Mat, t, m ) - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. - compute exp( T ) using time-series -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY: Factorial, Eye, INT2STR - - ! Define Intent of dummy variables - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: f_TensorEXP_1 - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: m - REAL( DFP ), INTENT( IN ) :: t - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Dummy( :, : ) - INTEGER( I4B ) :: N = 20, I - - IF( PRESENT( m ) ) N = m - - IF( N .GE. 40 ) THEN - - CALL Err_Msg( "Rank2Tensor_Class.F90>>TensorFunctions.part", & - "Tensor_Exp()", & - "m is too large to compute the factorial; Program Stopped!") - STOP - - END IF - - Dummy = Eye( SIZE( Mat, 1 ) ) - f_TensorEXP_1 = Dummy - - DO I = 1, N - - - Dummy = MATMUL( Mat, Dummy ) - f_TensorEXP_1 = f_TensorEXP_1 + ( t**I ) * Dummy / REAL( Factorial( I ), KIND = DFP ) - - END DO - - - DEALLOCATE( Dummy ) - - END FUNCTION f_TensorEXP_1 - -!------------------------------------------------------------------------------ -! m_TensorEXP_1 -!------------------------------------------------------------------------------ - - FUNCTION m_TensorEXP_1( obj, t, m ) - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. - compute exp( T ) using time-series -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY: Factorial, Eye - - ! Define Intent of dummy variables - - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_TensorEXP_1 - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: m - REAL( DFP ), INTENT( IN ) :: t - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Mat( :, : ) - - Mat = obj - - IF( PRESENT( m ) ) THEN - - m_TensorEXP_1 = f_TensorEXP_1( Mat, t, m ) - - ELSE - - m_TensorEXP_1 = f_TensorEXP_1( Mat, t ) - - END IF - - DEALLOCATE( Mat ) - - END FUNCTION m_TensorEXP_1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 b/src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 deleted file mode 100755 index f14867496..000000000 --- a/src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 +++ /dev/null @@ -1,137 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ContinuumSpin_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define ContinuumSpin Class -!============================================================================== - - MODULE ContinuumSpin_Class - USE GlobalData - USE IO - USE Rank2Tensor_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: ContinuumSpin_, ContinuumSpin, ContinuumSpin_Pointer - -!------------------------------------------------------------------------------ -! ContinuumSpin_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Rank2Tensor_ ) :: ContinuumSpin_ - - END TYPE ContinuumSpin_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE ContinuumSpin - MODULE PROCEDURE Constructor1, Constructor2 - END INTERFACE - - INTERFACE ContinuumSpin_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy varialbes - CLASS( ContinuumSpin_ ), POINTER :: Constructor_1 - - ALLOCATE( Constructor_1 ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( L ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - USE VelocityGradient_Class - - ! Define intent of dummy varialbes - CLASS( ContinuumSpin_ ), POINTER :: Constructor_2 - TYPE( VelocityGradient_ ), INTENT( IN ) :: L - - ALLOCATE( Constructor_2 ) - Constructor_2 = .Anti. L - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( ContinuumSpin_ ) :: Constructor1 - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( L ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - USE VelocityGradient_Class - - ! Define intent of dummy varialbes - TYPE( ContinuumSpin_ ) :: Constructor2 - TYPE( VelocityGradient_ ), INTENT( IN ) :: L - - Constructor2 = .Anti. L - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - - END MODULE ContinuumSpin_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 deleted file mode 100755 index 3ec397469..000000000 --- a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 +++ /dev/null @@ -1,218 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DeformationGradient_Class.F90 -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to deformation gradient -!============================================================================== - - MODULE DeformationGradient_Class - USE GlobalData - USE IO - USE Rank2Tensor_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: DeformationGradient_, DeformationGradient_Pointer, & - DeformationGradient - -!------------------------------------------------------------------------------ -! DeformationGradient_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Rank2Tensor_ ) :: DeformationGradient_ - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. - DeformationGradient -!. . . . . . . . . . . . . . . . . . . . - - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: R - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: U - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: V - REAL( DFP ), ALLOCATABLE, DIMENSION( : ) :: EigenVal - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_U - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_V - - CONTAINS - - ! Constructor.part - - PROCEDURE, PUBLIC, PASS :: Initiate2, Initiate5 - PROCEDURE, PUBLIC, PASS :: Deallocate - - ! Component.part - - PROCEDURE, PUBLIC, PASS :: m_RightStretch - PROCEDURE, PUBLIC, PASS :: m_Rotation - PROCEDURE, PUBLIC, PASS :: m_LeftStretch - PROCEDURE, PUBLIC, PASS :: m_EigenValues - PROCEDURE, PUBLIC, PASS :: m_EigenVectors_U - PROCEDURE, PUBLIC, PASS :: m_EigenVectors_V - PROCEDURE, PUBLIC, PASS :: m_Jacobian - - GENERIC, PUBLIC :: OPERATOR( .R. ) => m_Rotation - GENERIC, PUBLIC :: OPERATOR( .U. ) => m_RightStretch - GENERIC, PUBLIC :: OPERATOR( .V. ) => m_LeftStretch - GENERIC, PUBLIC :: OPERATOR( .EigenValues. ) => m_EigenValues - GENERIC, PUBLIC :: OPERATOR( .EigenVectorsU. ) => m_EigenVectors_U - GENERIC, PUBLIC :: OPERATOR( .EigenVectorsV. ) => m_EigenVectors_V - GENERIC, PUBLIC :: OPERATOR( .J. ) => m_Jacobian - - ! DeformationTensor.part - - PROCEDURE, PUBLIC, PASS :: m_RightCauchyGreen - GENERIC, PUBLIC :: RightCauchyGreen => m_RightCauchyGreen - GENERIC, PUBLIC :: OPERATOR( .C. ) => m_RightCauchyGreen - - PROCEDURE, PUBLIC, PASS :: m_LeftCauchyGreen - GENERIC, PUBLIC :: LeftCauchyGreen => m_LeftCauchyGreen - GENERIC, PUBLIC :: OPERATOR( .B. ) => m_LeftCauchyGreen - - ! StrainTensor.part - - PROCEDURE, PUBLIC, PASS :: m_GreenStrain - GENERIC, PUBLIC :: OPERATOR( .GreenStrain. ) => m_GreenStrain - GENERIC, PUBLIC :: GreenStrain => m_GreenStrain - - - PROCEDURE, PUBLIC, PASS :: m_AlmansiStrain - GENERIC, PUBLIC :: OPERATOR( .AlmansiStrain. ) => m_AlmansiStrain - GENERIC, PUBLIC :: AlmansiStrain => m_AlmansiStrain - - ! Display.part - - PROCEDURE, PUBLIC, PASS :: Display - - END TYPE DeformationGradient_ - - -!. . . . . . . . . . . . . . . . . . . . -! DeformationGradient_Pointer -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE DeformationGradient_Pointer - MODULE PROCEDURE Constructor1, Constructor2, Constructor3 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! DeformationGradient -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE DeformationGradient - MODULE PROCEDURE Constructor4, Constructor5, Constructor6 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! OPERATOR( .C. ) -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE OPERATOR( .C. ) - MODULE PROCEDURE m_RightCauchyGreen, f_RightCauchyGreen - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! RightCauchyGreen -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE RightCauchyGreen - MODULE PROCEDURE m_RightCauchyGreen, f_RightCauchyGreen - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! OPERATOR( .B. ) -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE OPERATOR( .B. ) - MODULE PROCEDURE m_LeftCauchyGreen, f_LeftCauchyGreen - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! LeftCauchyGreen -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE LeftCauchyGreen - MODULE PROCEDURE m_LeftCauchyGreen, f_LeftCauchyGreen - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! GreenTensor -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE GreenTensor - MODULE PROCEDURE m_GreenStrain, f_GreenStrain - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! GreenTensor -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE OPERATOR( .GreenTensor. ) - - MODULE PROCEDURE m_GreenStrain, f_GreenStrain - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! AlmansiTensor -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE AlmansiTensor - - MODULE PROCEDURE m_AlmansiStrain, f_AlmansiStrain - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! AlmansiTensor -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE OPERATOR( .AlmansiTensor. ) - - MODULE PROCEDURE m_AlmansiStrain, f_AlmansiStrain - - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - - CONTAINS - -#include "./Constructor.part" -#include "./Display.part" -#include "./Components.part" -#include "./StrainTensor.part" -#include "./DeformationTensor.part" - - END MODULE DeformationGradient_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part deleted file mode 100755 index c51686371..000000000 --- a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part +++ /dev/null @@ -1,100 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DeformationTensor.part -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Deformation Gradient class is defined -! HOSTING FILE -! - DeformationGradient_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! m_RightCauchyGreen -!------------------------------------------------------------------------------ - - FUNCTION m_RightCauchyGreen( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. m_RightCauchyGreen = F^T F -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( DeformationGradient_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_RightCauchyGreen - - ! Define internal variables - - m_RightCauchyGreen = ( .transpose. obj ) .matmul. obj - - END FUNCTION m_RightCauchyGreen - -!------------------------------------------------------------------------------ -! f_RightCauchyGreen -!------------------------------------------------------------------------------ - - FUNCTION f_RightCauchyGreen( Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. f_RightCauchyGreen = F^T F -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), DIMENSION( 3, 3 ) :: f_RightCauchyGreen - - ! Define internal variables - - f_RightCauchyGreen = ( .transpose. Mat ) .matmul. Mat - - END FUNCTION f_RightCauchyGreen - -!------------------------------------------------------------------------------ -! m_LeftCauchyGreen -!------------------------------------------------------------------------------ - - FUNCTION m_LeftCauchyGreen( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. m_LeftCauchyGreen = FF^T -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( DeformationGradient_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_LeftCauchyGreen - - ! Define internal variables - - m_LeftCauchyGreen = obj .matmul. ( .transpose. obj ) - - END FUNCTION m_LeftCauchyGreen - -!------------------------------------------------------------------------------ -! f_LeftCauchyGreen -!------------------------------------------------------------------------------ - - FUNCTION f_LeftCauchyGreen( Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. f_LeftCauchyGreen = FF^T -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), DIMENSION( 3, 3 ) :: f_LeftCauchyGreen - - ! Define internal variables - - f_LeftCauchyGreen = MATMUL( Mat, TRANSPOSE( Mat ) ) - - END FUNCTION f_LeftCauchyGreen \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part deleted file mode 100755 index c9bc327ab..000000000 --- a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part +++ /dev/null @@ -1,120 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Display.part -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Display DeformationGradinet object -! HOSTING FILE -! - DeformationGradient_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Display -!------------------------------------------------------------------------------ - - SUBROUTINE Display( obj, UnitNo ) - - USE Utility, ONLY: Display_Array - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. - Display the content -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( DeformationGradient_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo - - ! Define internal variables - INTEGER( I4B ) :: I, j - - IF( PRESENT( UnitNo ) ) THEN - I = UnitNo - ELSE - I = 6 - END IF - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL BlankLines( UnitNo = I ) - WRITE( I, "(A)" ) "DeformationGradient_ object is not initiated " - WRITE( I, "(A)" ) "Nothing to show " - CALL BlankLines( UnitNo = I ) - RETURN - - END IF - - CALL BlankLines( UnitNo = I ) - CALL EqualLine( UnitNo = I ) - WRITE( I, "(5X, A)" ) "|||| Deformation Gradient obj Data ||||" - CALL EqualLine( UnitNo = I ) - CALL BlankLines( UnitNo = I ) - - - - CALL BlankLines( UnitNo = I ) - WRITE( I, "(A)" ) "F = " - CALL BlankLines( UnitNo = I ) - - DO j = 1, 3 - - WRITE( I, "(4x, 3G17.7)" ) obj%T( j, : ) - - END DO - CALL BlankLines( UnitNo = I ) - - WRITE( I, "(A, I2 )" ) "NSD = ", obj%NSD - CALL BlankLines( UnitNo = I ) - - IF( ALLOCATED( obj%R ) ) THEN - - CALL Display_Array( obj%R, " R ", I ) - - END IF - - IF( ALLOCATED( obj%U ) ) THEN - - CALL Display_Array( obj%U, " U ", I ) - - END IF - - IF( ALLOCATED( obj%V ) ) THEN - - CALL Display_Array( obj%V, " V ", I ) - - END IF - - IF( ALLOCATED( obj%EigenVal ) ) THEN - - CALL Display_Array( obj%EigenVal, " EigenValues ", I ) - - END IF - - IF( ALLOCATED( obj%EigenVec_U ) ) THEN - - CALL Display_Array( obj%EigenVec_U, " Eigen Vectors of U ", I ) - - END IF - - IF( ALLOCATED( obj%EigenVec_V ) ) THEN - - CALL Display_Array( obj%EigenVec_V, " Eigen Vectors of V ", I ) - - END IF - - CALL DashLine( UnitNo = I ) - CALL BlankLines( UnitNo = I ) - - END SUBROUTINE Display -! \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md deleted file mode 100755 index 2280d6841..000000000 --- a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md +++ /dev/null @@ -1,128 +0,0 @@ -# Deformation Gradient Class - -## Structure - -```fortran - TYPE, PUBLIC, EXTENDS( Rank2Tensor_ ) :: DeformationGradient_ - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: R - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: U - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: V - REAL( DFP ), ALLOCATABLE, DIMENSION( : ) :: EigenVal - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_U - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_V -``` - -## Description - -## Getting Started - -### Constructing the object - -The subroutine `Initiate()` can be used to create the `DeformationGradient_` class. - -```fortran -CALL obj%Initiate( ) -CALL obj%Initiate( Mat2( :, : ) ) -CALL obj%Initiate( Scalar ) -CALL obj%Initiate( VoigtVec, VoigtType ) -CALL obj%Initiate( obj2 ) -``` - -In addition we can use the function `DeformationGradient()` which returns the `DeformationGradient_` type. - -```fortran -obj = DeformationGradient( ) -obj = DeformationGradient( Mat2, FULL ) -obj = DeformationGradient( Mat2 ) -``` - -We have also defined function `DeformationGradient_Pointer()` that returns the pointer to the `DeformationGradient_` pointer. - -```fortran -obj = DeformationGradient_Pointer( ) -obj = DeformationGradient_Pointer( Mat2, FULL ) -obj = DeformationGradient_Pointer( Mat2 ) -``` - -Here `Full` can be `True` or `False`. If `True` then `R, U, V, EigenVal, EigenVec_U, EigenVec_V` all will be computed. - -We can also use `Assignment Operator( = )` - -```fortran -obj = Mat2( :, : ) -``` - -### Deallocating the object - -We can call `obj%Deallocate()` - -### Getting the Rotation part - -```fortran -R = .R. obj -``` - -### Getting the Right Stretch Tensor - -```fortran -U = .U. obj -``` - -### Getting the Left Stretch Tensor - -```fortran -V = .V. obj -``` - -### Getting the EigenValues of F, U, V - -Not that U and V are similar tensor, therefore, F, U, V all have same eigenvalues. - -```fortran -Val = .EigenValues. obj -``` - -### Getting the EigenVectors of U and V - -```fortran -P( :, : ) = .EigenVectorsU. obj -P( :, : ) = .EigenVectorsV. obj -``` - -### Getting the Jacobian - -```fortran -J = .J. obj -``` - -### Getting Right and Left Cauchy Green Deformation Tensor - -```fortran -C = RightCauchyGreen( obj ) -C = RightCauchyGreen( Mat ) -C = .C. obj -C = .C. Mat -``` - -```fortran -B = LeftCauchyGreen( obj ) -B = LeftCauchyGreen( Mat ) -B = .B. obj -B = .B. Mat -``` - -### Getting the Strain - -```fortran -E = GreenStrain( obj ) -E = GreenStrain( Mat ) -E = .GreenStrain. obj -E = .GreenStrain. Mat -``` - -```fortran -e = AlmansiStrain( obj ) -e = AlmansiStrain( Mat ) -e = .AlmansiStrain. obj -e = .AlmansiStrain. Mat -``` \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part deleted file mode 100755 index 612e80c54..000000000 --- a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part +++ /dev/null @@ -1,112 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DeformationTensor.part -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Deformation Gradient class is defined -! HOSTING FILE -! - DeformationGradient_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! m_GreenStrain -!------------------------------------------------------------------------------ - - FUNCTION m_GreenStrain( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. m_GreenStrain = 0.5 * ( F^T F - I ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( DeformationGradient_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_GreenStrain - - ! Define internal variables - - m_GreenStrain = 0.5_DFP * ( (( .transpose. obj ) .matmul. obj) - Eye3 ) - - END FUNCTION m_GreenStrain - -!------------------------------------------------------------------------------ -! f_GreenStrain -!------------------------------------------------------------------------------ - - FUNCTION f_GreenStrain( Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. f_GreenStrain = 0.5 * ( F^T F - I ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), DIMENSION( 3, 3 ) :: f_GreenStrain - - ! Define internal variables - - f_GreenStrain = 0.5_DFP * ( (( .transpose. Mat ) .matmul. Mat) - Eye3 ) - - END FUNCTION f_GreenStrain - -!------------------------------------------------------------------------------ -! m_AlmansiStrain -!------------------------------------------------------------------------------ - - FUNCTION m_AlmansiStrain( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. m_AlmansiStrain -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( DeformationGradient_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_AlmansiStrain - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: B( :, : ), InvB( :, : ) - - B = .B. obj - InvB = .Inv. B - - m_AlmansiStrain = 0.5_DFP * ( Eye3 - InvB ) - - DEALLOCATE( B, InvB ) - - END FUNCTION m_AlmansiStrain - -!------------------------------------------------------------------------------ -! f_AlmansiStrain -!------------------------------------------------------------------------------ - - FUNCTION f_AlmansiStrain( Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. f_AlmansiStrain -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), DIMENSION( 3, 3 ) :: f_AlmansiStrain - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: B( :, : ), InvB( :, :) - - B = .B. Mat - InvB = .Inv. B - - f_AlmansiStrain = 0.5_DFP * ( Eye3 - InvB ) - - DEALLOCATE( B, InvB ) - - END FUNCTION f_AlmansiStrain diff --git a/src/submodules/Rank2Tensor/src/old data/Interface.part b/src/submodules/Rank2Tensor/src/old data/Interface.part deleted file mode 100755 index a0dc41a75..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Interface.part +++ /dev/null @@ -1,314 +0,0 @@ - - INTERFACE Rank2Tensor_Pointer - - MODULE PROCEDURE :: Constructor1, Constructor2, Constructor3, & - Constructor4, Constructor10 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Rank2Tensor - - MODULE PROCEDURE :: Constructor5, Constructor6, Constructor7, & - Constructor8, Constructor9 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE VectorProduct - - MODULE PROCEDURE VectorProduct2, VectorProduct3 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Box - - MODULE PROCEDURE BoxProduct - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE getParallelComponent - - MODULE PROCEDURE getProjection - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Trace - - MODULE PROCEDURE Trace_2, Trace_1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE isSymmetric - - MODULE PROCEDURE isSymmetric_1, isSymmetric_2 - - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE isDeviatoric - - MODULE PROCEDURE isDeviatoric_1, isDeviatoric_2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE DoubleDot_Product - - MODULE PROCEDURE DoubleDot_Product1, DoubleDot_Product2, & - DoubleDot_Product3, DoubleDot_Product4,& - DoubleDot_Product5, DoubleDot_Product6 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Invariant_I1 - - MODULE PROCEDURE f_Invariant_I1, m_Invariant_I1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Invariant_I2 - - MODULE PROCEDURE f_Invariant_I2, m_Invariant_I2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Invariant_I3 - - MODULE PROCEDURE f_Invariant_I3, m_Invariant_I3 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Invariant_J2 - - MODULE PROCEDURE f_Invariant_J2, m_Invariant_J2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Invariant_J3 - - MODULE PROCEDURE f_Invariant_J3, m_Invariant_J3 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE LodeAngle - - MODULE PROCEDURE f_LodeAngle_1, f_LodeAngle_2, m_LodeAngle - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE SymmetricPart - - MODULE PROCEDURE f_SymmetricPart, m_SymmetricPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE AntiSymmetricPart - - MODULE PROCEDURE f_AntiSymmetricPart, m_AntiSymmetricPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE HydrostaticPart - - MODULE PROCEDURE f_HydrostaticPart, m_HydrostaticPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE SphericalPart - - MODULE PROCEDURE f_HydrostaticPart, m_HydrostaticPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE DeviatoricPart - - MODULE PROCEDURE f_DeviatoricPart, m_DeviatoricPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Pullback - - MODULE PROCEDURE m_Rank2PullBack_1, m_Rank2PullBack_2, & - f_Rank2PullBack_1, f_Rank2PullBack_2, & - f_VecPullBack_1, f_VecPullBack_2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE PushForward - - MODULE PROCEDURE m_Rank2PushForward_1, m_Rank2PushForward_2, & - f_Rank2PushForward_1, f_Rank2PushForward_2, & - f_VecPushForward_1, f_VecPushForward_2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Tensor_Eigens - - MODULE PROCEDURE m_Eigens_1, m_Eigens_2, f_Eigens_1, f_Eigens_2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Tensor_PrincipalValue - - MODULE PROCEDURE m_PrincipalValue_1, f_PrincipalValue_1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Tensor_SpectralRadius - - MODULE PROCEDURE m_SpectralRadius_1, f_SpectralRadius_1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE PolarDecomposition - - MODULE PROCEDURE m_getPolarDecomp_1, f_getPolarDecomp_1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE RotationPart - - MODULE PROCEDURE f_getRotationPart, m_getRotationPart - - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Tensor_Exp - - MODULE PROCEDURE m_TensorEXP_1, f_TensorEXP_1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 b/src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 deleted file mode 100755 index b6a95242c..000000000 --- a/src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 +++ /dev/null @@ -1,100 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: LeftCauchyGreen_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Left Cauchy green tensor -!============================================================================== - - MODULE LeftCauchyGreen_Class - USE GlobalData - USE IO - USE Rank2Tensor_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: LeftCauchyGreen_, LeftCauchyGreen, LeftCauchyGreen_Pointer - -!------------------------------------------------------------------------------ -! LeftCauchyGreen_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Rank2Tensor_ ) :: LeftCauchyGreen_ - - END TYPE LeftCauchyGreen_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE LeftCauchyGreen - MODULE PROCEDURE Constructor1 - END INTERFACE - - INTERFACE LeftCauchyGreen_Pointer - MODULE PROCEDURE Constructor_1 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy varialbes - CLASS( LeftCauchyGreen_ ), POINTER :: Constructor_1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - ALLOCATE( Constructor_1 ) - Constructor_1 = F .matmul. (.transpose. F) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy variables - TYPE( LeftCauchyGreen_ ) :: Constructor1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - Constructor1 = F .matmul. (.transpose. F) - - END FUNCTION Constructor1 - - END MODULE LeftCauchyGreen_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part deleted file mode 100755 index b46b380cf..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part +++ /dev/null @@ -1,71 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Display.part -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Material Jacobian class is defined -! HOSTING FILE -! - MaterialJacobian_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Display -!------------------------------------------------------------------------------ - - SUBROUTINE Display( obj, UnitNo ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Display the content -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo - - ! Define internal variables - INTEGER( I4B ) :: I, j - - IF( PRESENT( UnitNo ) ) THEN - I = UnitNo - ELSE - I = 6 - END IF - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL BlankLines( UnitNo = I ) - WRITE( I, "(A)" ) "MaterialJacobian_ object is Empty" - CALL BlankLines( UnitNo = I ) - RETURN - - END IF - - CALL BlankLines( UnitNo = I ) - CALL EqualLine( UnitNo = I ) - WRITE( I, "(12X, A)" ) "|||| Material Jacobian Data ||||" - CALL EqualLine( UnitNo = I ) - CALL BlankLines( UnitNo = I ) - - CALL Display_Array( obj%C, "C" ) - - WRITE( I, "(A)" ) "Stress Type" - CALL obj%StressType%Display( I ) - - WRITE( I, "(A)" ) "Strain Type" - CALL obj%StrainType%Display( I ) - - WRITE( I, "(A)" ) "Rate Type" - CALL obj%RateType%Display( ) - - END SUBROUTINE Display diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part deleted file mode 100755 index 33dc00bff..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part +++ /dev/null @@ -1,257 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Initiate.part -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - MaterialJacobian class is defined -! HOSTING FILE -! - MaterialJacobian_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getSize -!------------------------------------------------------------------------------ - - INTEGER( I4B ) FUNCTION getSize( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the size of obj%C -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Initiate.part", & - "getSize(), .Size. obj", & - "obj%C is not allocated, Program Stopped!!!"& - ) - - STOP - - END IF - - getSize = SIZE( obj%C, 1 ) - - END FUNCTION getSize - -!------------------------------------------------------------------------------ -! Deallocate -!------------------------------------------------------------------------------ - - SUBROUTINE Deallocate( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Deallocate Data -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - - END SUBROUTINE Deallocate - -!------------------------------------------------------------------------------ -! Initiate1 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate1( obj, N ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the obj%C( N, N ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: N - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - ALLOCATE( obj%C( N, N ) ) - obj%C = 0.0_DFP - - END SUBROUTINE Initiate1 - -!------------------------------------------------------------------------------ -! Initiate2 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate2( obj, N, Fill ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the obj%C( N, N ) with all entries fill -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), INTENT( IN ) :: Fill - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - ALLOCATE( obj%C( N, N ) ) - obj%C = Fill - - END SUBROUTINE Initiate2 - -!------------------------------------------------------------------------------ -! Initiate3 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate3( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the obj%C( :, : ) = Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - obj%C = Mat - - END SUBROUTINE Initiate3 - -!------------------------------------------------------------------------------ -! Initiate4 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate4( obj, N, StressType, StrainType, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of obj%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: N - TYPE( String_ ), INTENT( IN ) :: StressType, StrainType, RateType - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - ALLOCATE( obj%C( N, N ) ) - obj%C = 0.0_DFP - - obj%StressType = StressType - obj%StrainType = StrainType - obj%RateType = RateType - - END SUBROUTINE Initiate4 - -!------------------------------------------------------------------------------ -! Initiate5 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate5( obj, N, StressType, StrainType, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of obj%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: N - CHARACTER( LEN = * ), INTENT( IN ) :: StressType, StrainType, RateType - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - ALLOCATE( obj%C( N, N ) ) - obj%C = 0.0_DFP - - obj%StressType = StressType - obj%StrainType = StrainType - obj%RateType = RateType - - END SUBROUTINE Initiate5 - -!------------------------------------------------------------------------------ -! Initiate6 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate6( obj, N, Names ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of obj%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: N - TYPE( String_ ), INTENT( IN ) :: Names( 3 ) - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - ALLOCATE( obj%C( N, N ) ) - obj%C = 0.0_DFP - - obj%StressType = Names( 1 ) - obj%StrainType = Names( 2 ) - obj%RateType = Names( 3 ) - - END SUBROUTINE Initiate6 - -!------------------------------------------------------------------------------ -! Initiate7 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate7( obj, N, Names ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the obj%C( N, N ) with all entries fill -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: N - CHARACTER( LEN = * ), INTENT( IN ) :: Names( 3 ) - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - ALLOCATE( obj%C( N, N ) ) - obj%C = 0.0_DFP - - obj%StressType = Names( 1 ) - obj%StrainType = Names( 2 ) - obj%RateType = Names( 3 ) - - END SUBROUTINE Initiate7 - -!------------------------------------------------------------------------------ -! Initiate8 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate8( obj, obj2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Copy obj2 into obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj2 - - IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) - - IF( ALLOCATED( obj2%C ) ) THEN - - obj%C = obj2%C - - END IF - - obj%StressType = obj2%StressType - obj%StrainType = obj2%StrainType - obj%RateType = obj2%RateType - - END SUBROUTINE Initiate8 - - - diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part deleted file mode 100755 index 51452ba5c..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part +++ /dev/null @@ -1,153 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MaterialJacobian_Pointer.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - MaterialJacobian class is defined -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( N ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor1%C( N, N ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( MaterialJacobian_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: N - - CALL Constructor1%Initiate( N ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( N, Fill ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor2%C( N, N ) with all entries fill -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( MaterialJacobian_ ) :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), INTENT( IN ) :: Fill - - CALL Constructor2%Initiate( N, Fill ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor3%C( :, : ) = Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( MaterialJacobian_ ) :: Constructor3 - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - - CALL Constructor3%Initiate( Mat ) - - END FUNCTION Constructor3 - -!------------------------------------------------------------------------------ -! Constructor4 -!------------------------------------------------------------------------------ - - FUNCTION Constructor4( N, StressType, StrainType, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of Constructor4%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( MaterialJacobian_ ) :: Constructor4 - INTEGER( I4B ), INTENT( IN ) :: N - TYPE( String_ ), INTENT( IN ) :: StressType, StrainType, RateType - - CALL Constructor4%Initiate( N, StressType, StrainType, RateType ) - - END FUNCTION Constructor4 - -!------------------------------------------------------------------------------ -! Constructor5 -!------------------------------------------------------------------------------ - - FUNCTION Constructor5( N, StressType, StrainType, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of Constructor5%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( MaterialJacobian_ ) :: Constructor5 - INTEGER( I4B ), INTENT( IN ) :: N - CHARACTER( LEN = * ), INTENT( IN ) :: StressType, StrainType, RateType - - CALL Constructor5%Initiate( N, StressType, StrainType, RateType ) - - END FUNCTION Constructor5 - -!------------------------------------------------------------------------------ -! Constructor6 -!------------------------------------------------------------------------------ - - FUNCTION Constructor6( N, Names ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of Constructor6%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( MaterialJacobian_ ) :: Constructor6 - INTEGER( I4B ), INTENT( IN ) :: N - TYPE( String_ ), INTENT( IN ) :: Names( 3 ) - - CALL Constructor6%Initiate( N, Names ) - - END FUNCTION Constructor6 - -!------------------------------------------------------------------------------ -! Constructor7 -!------------------------------------------------------------------------------ - - FUNCTION Constructor7( N, Names ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor7%C( N, N ) with all entries fill -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( MaterialJacobian_ ) :: Constructor7 - INTEGER( I4B ), INTENT( IN ) :: N - CHARACTER( LEN = * ), INTENT( IN ) :: Names( 3 ) - - CALL Constructor7%Initiate( N, Names ) - - END FUNCTION Constructor7 - - - diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 deleted file mode 100755 index b8b2ded20..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 +++ /dev/null @@ -1,177 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MaterialJacobian_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define MaterialJacobian Class -!============================================================================== - - MODULE MaterialJacobian_Class - USE GlobalData - USE IO - USE String_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: MaterialJacobian_, MaterialJacobian, MaterialJacobian_Pointer - -!------------------------------------------------------------------------------ -! MaterialJacobian_ -!------------------------------------------------------------------------------ - - TYPE :: MaterialJacobian_ -!. . . . . . . . . . . . . . . . . . . . -! Material Jacobian Class -!. . . . . . . . . . . . . . . . . . . . - - REAL( DFP ), ALLOCATABLE :: C( :, : ) - TYPE( String_ ) :: StressType, StrainType, RateType - - CONTAINS - - ! Constructor.part - - PROCEDURE, PUBLIC, PASS( obj ) :: Initiate1, Initiate2, & - Initiate3, Initiate4, Initiate5, Initiate6, & - Initiate7, getSize, Deallocate, Initiate8 - - GENERIC, PUBLIC :: Initiate => Initiate1, Initiate2, & - Initiate3, Initiate4, Initiate5, Initiate6, & - Initiate7, Initiate8 - - GENERIC, PUBLIC :: ASSIGNMENT( = ) => Initiate3, Initiate8 - GENERIC, PUBLIC :: OPERATOR( .SIZE. ) => getSize - - ! Names.part - - PROCEDURE, PUBLIC, PASS( obj ) :: setStressType1, setStressType2,& - setStrainType1, setStrainType2, setRateType1, setRateType2, & - getStressType, getStrainType, getRateType - - GENERIC, PUBLIC :: setStressType => setStressType1, setStressType2 - GENERIC, PUBLIC :: setStrainType => setStrainType1, setStrainType2 - GENERIC, PUBLIC :: setRateType => setRateType1, setRateType2 - - GENERIC, PUBLIC :: OPERATOR( .StressType. ) => getStressType - GENERIC, PUBLIC :: OPERATOR( .StrainType. ) => getStrainType - GENERIC, PUBLIC :: OPERATOR( .RateType. ) => getRateType - - - ! getCijkl.part - - PROCEDURE, PUBLIC, PASS( obj ) :: getCijkl, obj2Mat, & - getCijkl_Pointer, Cijkl_Pointer - - GENERIC, PUBLIC :: ASSIGNMENT( = ) => obj2Mat - - - ! OperatorOverloading/ .Cijkl. - - PROCEDURE, PUBLIC, PASS( obj ) :: Cijkl_1, Cijkl_2, & - Cijkl_4, Cijkl, Cijkl_5 - - GENERIC, PUBLIC :: OPERATOR( .Cijkl. ) => Cijkl_1, Cijkl, & - Cijkl_5 - - GENERIC, PUBLIC :: OPERATOR( .Shape. ) => Cijkl_5 - - ! OperatorOverloading/Contraction - - PROCEDURE, PUBLIC, PASS( obj ) :: Contraction_1, Contraction_2, & - Contraction_3, Contraction_4 - - GENERIC, PUBLIC :: OPERATOR( .Contraction. ) => & - Contraction_1, Contraction_2, Contraction_3, Contraction_4 - - ! OperatorOverloading/Asterics - - PROCEDURE, PUBLIC, PASS( obj ) :: obj_Times_Scalar, Scalar_Times_obj - - GENERIC, PUBLIC :: OPERATOR( * ) => obj_Times_Scalar, & - Scalar_Times_obj - - - ! OperatorOverloading/Matmul - - PROCEDURE, PUBLIC, PASS( obj ) :: obj_Matmul_Vec, Vec_Matmul_obj - - GENERIC, PUBLIC :: OPERATOR( .matmul. ) => obj_Matmul_Vec, & - Vec_Matmul_obj - - - ! OperatorOverloading/Addition - - PROCEDURE, PUBLIC, PASS( obj ) :: obj_Add_obj, obj_Add_Mat, & - Mat_Add_obj, obj_Add_Scalar, Scalar_Add_obj - - GENERIC, PUBLIC :: OPERATOR( + ) => obj_Add_obj, obj_Add_Mat, & - Mat_Add_obj, obj_Add_Scalar, Scalar_Add_obj - - - ! OperatorOverloading/Subtraction - - PROCEDURE, PUBLIC, PASS( obj ) :: obj_Minus_obj, obj_Minus_Mat, & - Mat_Minus_obj, obj_Minus_Scalar, Scalar_Minus_obj - - GENERIC, PUBLIC :: OPERATOR( - ) => obj_Minus_obj, obj_Minus_Mat, & - Mat_Minus_obj, obj_Minus_Scalar, Scalar_Minus_obj - - - ! Display.part - - PROCEDURE, PUBLIC, PASS :: Display - - END TYPE MaterialJacobian_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE MaterialJacobian - MODULE PROCEDURE Constructor1, Constructor2, Constructor3, & - Constructor4, Constructor5, Constructor6, Constructor7 - END INTERFACE - - INTERFACE MaterialJacobian_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3, & - Constructor_4, Constructor_5, Constructor_6, Constructor_7 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - - INCLUDE "./Initiate.part" - INCLUDE "./MaterialJacobian_Pointer.part" - INCLUDE "./MaterialJacobian.part" - INCLUDE "./getCijkl.part" - INCLUDE "./Names.part" - - INCLUDE "./OperatorOverloading/Cijkl.part" - INCLUDE "./OperatorOverloading/Contraction.part" - INCLUDE "./OperatorOverloading/Asterics.part" - INCLUDE "./OperatorOverloading/Matmul.part" - INCLUDE "./OperatorOverloading/Addition.part" - INCLUDE "./OperatorOverloading/Subtraction.part" - - INCLUDE "./Display.part" - - - END MODULE MaterialJacobian_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part deleted file mode 100755 index 5febb23e7..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part +++ /dev/null @@ -1,160 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MaterialJacobian_Pointer.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - MaterialJacobian class is defined -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( N ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor_1%C( N, N ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: N - - ALLOCATE( Constructor_1 ) - CALL Constructor_1%Initiate( N ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( N, Fill ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor_2%C( N, N ) with all entries fill -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), POINTER :: Constructor_2 - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), INTENT( IN ) :: Fill - - ALLOCATE( Constructor_2 ) - CALL Constructor_2%Initiate( N, Fill ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor_3%C( :, : ) = Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), POINTER :: Constructor_3 - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - - ALLOCATE( Constructor_3 ) - CALL Constructor_3%Initiate( Mat ) - - END FUNCTION Constructor_3 - -!------------------------------------------------------------------------------ -! Constructor_4 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_4( N, StressType, StrainType, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of Constructor_4%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), POINTER :: Constructor_4 - INTEGER( I4B ), INTENT( IN ) :: N - TYPE( String_ ), INTENT( IN ) :: StressType, StrainType, RateType - - ALLOCATE( Constructor_4 ) - CALL Constructor_4%Initiate( N, StressType, StrainType, RateType ) - - END FUNCTION Constructor_4 - -!------------------------------------------------------------------------------ -! Constructor_5 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_5( N, StressType, StrainType, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of Constructor_5%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), POINTER :: Constructor_5 - INTEGER( I4B ), INTENT( IN ) :: N - CHARACTER( LEN = * ), INTENT( IN ) :: StressType, StrainType, RateType - - ALLOCATE( Constructor_5 ) - CALL Constructor_5%Initiate( N, StressType, StrainType, RateType ) - - END FUNCTION Constructor_5 - -!------------------------------------------------------------------------------ -! Constructor_6 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_6( N, Names ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Size of Constructor_6%C is N, with other details -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), POINTER :: Constructor_6 - INTEGER( I4B ), INTENT( IN ) :: N - TYPE( String_ ), INTENT( IN ) :: Names( 3 ) - - ALLOCATE( Constructor_6 ) - CALL Constructor_6%Initiate( N, Names ) - - END FUNCTION Constructor_6 - -!------------------------------------------------------------------------------ -! Constructor_7 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_7( N, Names ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate the Constructor_7%C( N, N ) with all entries fill -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), POINTER :: Constructor_7 - INTEGER( I4B ), INTENT( IN ) :: N - CHARACTER( LEN = * ), INTENT( IN ) :: Names( 3 ) - - ALLOCATE( Constructor_7 ) - CALL Constructor_7%Initiate( N, Names ) - - END FUNCTION Constructor_7 - - - diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md deleted file mode 100755 index 274c67a3f..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md +++ /dev/null @@ -1,230 +0,0 @@ -# Material Jacobian - -## Structure - -```fortran -TYPE, PUBLIC :: MaterialJacobian_ - REAL( DFP ), ALLOCATABLE :: C( :, : ) - TYPE( String_ ) :: StressType, StrainType, RateType -END TYPE MaterialJacobian_ -``` - -## Description - -`MaterialJacobian_` class is defined as constitutive data. Material jacobian relates the change in flux with the changes in gradient of some field. If the field is scalar then the flux is vector. If the field is vector then the flux is rank-2 tensor. When the material tangent is Rank-4 tensor then we assume that it has atleast minor-symmetery, therefore, we can use Voigt notation for Rank-4 tensor. - -## Getting Started - -### Initiating the `MaterialJacobian_` object - -We can construct the object using the routine called `Initiate()`. - -```fortran -CALL obj%Initiate( N ) -CALL obj%Initiate( N, Fill ) -CALL obj%Initiate( Mat ) -CALL obj%Initiate( N, StressType, StrainType, RateType ) -CALL obj%Initiate( N, [StressType, StrainType, RateType] ) -``` - -We can also initiate the `MaterialJacobian_` using the function called `MaterialJacobian()` or `MaterialJacobian_Pointer()` - -```fortran -obj = MaterialJacobian( N ) -obj = MaterialJacobian( N, Fill ) -obj = MaterialJacobian( Mat ) -obj = MaterialJacobian( N, StressType, StrainType, RateType ) -obj = MaterialJacobian( N, [StressType, StrainType, RateType] ) -``` - -```fortran -obj => MaterialJacobian_Pointer( N ) -obj => MaterialJacobian_Pointer( N, Fill ) -obj => MaterialJacobian_Pointer( Mat ) -obj => MaterialJacobian_Pointer( N, StressType, StrainType, RateType ) -obj => MaterialJacobian_Pointer( N, [StressType, StrainType, RateType] ) -``` - -```fortran -CALL obj%Initiate( N ) -obj = MaterialJacobian( N ) -obj => MaterialJacobian_Pointer( N ) -``` - -The above call allocate `obj%C( N, N )` with all zero entries. - -```fortran -CALL obj%Initiate( N, Fill ) -obj = MaterialJacobian( N, Fill ) -obj => MaterialJacobian_Pointer( N, Fill ) -``` - -The above call allocates `obj%C(N,N)` with all entries equal to `Fill`. - -```fortran -CALL obj%Initiate( Mat ) -obj = MaterialJacobian( Mat ) -obj => MaterialJacobian_Pointer( Mat ) -``` - -The above call allocates `obj%C` with `Mat`. - -```fortran -CALL obj%Initiate( N, StressType, StrainType, RateType ) -obj = MaterialJacobian( N, StressType, StrainType, RateType ) -obj => MaterialJacobian_Pointer( N, StressType, StrainType, RateType ) -``` - -The above call allocates `obj%C` with size `N`. `StressType`, `StrainType`, and `RateType` can be `String_` object or character object. - -```fortran -CALL obj%Initiate( N, [StressType, StrainType, RateType] ) -obj = MaterialJacobian( N, [StressType, StrainType, RateType] ) -obj => MaterialJacobian_Pointer( N, [StressType, StrainType, RateType] ) -``` - -The above call allocates `obj%C` with size `N`. The size-3 rank-1 array can be can be `String_` object or character object. - -### Setting the value of Names - -We can set the values of `obj%StressType` `obj%StrainType`, and `obj%RateType` using the subroutine. - -```Fortran -CALL obj%setStressType( StressType ) -CALL obj%setStrainType( StrainType ) -CALL obj%setRateType( RateType ) -``` - ->The argument can be `Character` type or `String_` type. - -### Getting the values of Names - -```fortran -StressType = .StressType. obj -StrainType = .StrainType. obj -RateType = .RateType. obj -``` - -### Geting the values of `obj%C` - -We can get the size of `obj%C` using the operator called `.SIZE.` and we can deallocate the data using the routine called `obj%Deallocate()`. - -We can access the values using both subroutines and functions. - -Subroutines to access the hardcopy and pointer to `obj%C` are given below. - -```fortran -CALL obj%getCijkl( Mat ) -CALL obj%getCijkl_Pointer( Mat ) -``` - -Functions to access the hardcopy and pointer to `obj%C` are given below. - -```fortran -Mat => obj%Cijkl_Pointer( ) -Mat = obj -``` - -The Operator `.Cijkl.` and `.At.` can also be used to access the hardcopies of Cijkl. - -```fortran -Mat = .Cijkl. obj -Mat = obj .Cijkl. [Indx1, Indx2] -Mat = obj .Cijkl. [i,j,k,l] -``` - -```fortran -CALL obj%getCijkl( Mat ) -Mat = obj -``` - -The above call reallocates `Mat` with the `obj%C`. - -```fortran -CALL obj%getCijkl_Pointer( Mat ) -Mat => obj%Cijkl_Pointer( ) -``` - -The above call returns the Pointer to the `obj%C`. - -```fortran -Mat = .Cijkl. obj -``` - -The above call will return the `obj%C` hardcopy. - -```fortran -Mat = obj .Cijkl. [Indx1, Indx2] -``` - -The above call will return the `obj%C( i,j)` - -```fortran -Mat = obj .Cijkl. [i,j,k,l] -``` - -The above call will return the `C(i,j,k,l)`. In this case `[i,j,k,l]` are convered into voigt index then value of `obj%C` correspoding to those voigt-indices are returned. - -There is another interesting way to use `.Cijkl.`. Suppose you want to obtain 6 by 6 jacobian matrix then we can call `obj .Cijkl. 6`. In this case, even if `obj%C` is not 6 by 6 we will get 6 by 6 form. - -```fortran -C = obj .Cijkl. 6 -C = obj .Cijkl. 4 -C = obj .Cijkl. 3 -C = obj .Cijkl. 2 -C = obj .Cijkl. 1 -``` - -Alternatively you can also use `obj .Shape. 6` or `obj .Shape. M` for getting the M by M matrix. - -### Assignment Operator (=) - -```fortran -obj = Mat -Mat = obj -obj = obj2 -``` - -### Contraction Operator - -Contraction of Material Jacobian with the Tensor and matrix is defined. It will return a 3 by 3 matrix. If you want to convert it into voigt vector then use `VoigtVec()` function from the `Voigt` module. - -```fortran -Mat = obj .Contraction. Rank2Tensorobj -Mat = Rank2Tensorobj .Contraction. obj -Mat = obj .Contraction. Mat -Mat = Mat .Contraction. obj -``` - -### Matmul Operator - -Matmul operator is defined so that we can operate `MaterialJacobian_` object directly with the `VoigtVec`. Using `matmul` operator we can do matrix multiplication of obj with voigt vector. - -```fortran -Vec = obj .matmul. Vec -Vec = Vec .matmul. obj -``` - -### Addition Operator - -We have defined the addition operator for material jacobian class. We can add `obj + obj` `obj + Mat` `obj +Scalar`. Note that in first two cases the shape should be compatible. Suppose if the shapes are not identical then we can use `obj .Cijkl. N + obj .Cijkl. N`. A Rank-2 fortran array is returned. - -```fortran -Mat = obj + obj -Mat = obj + Mat -Mat = Mat + obj -Mat = obj + Scalar -Mat = Scalar + obj -``` - -### Subtraction Operator - -```fortran -Mat = obj - obj -Mat = obj - Mat -Mat = Mat - obj -Mat = obj - Scalar -Mat = Scalar - obj -``` - -### Asterics Operator \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part deleted file mode 100755 index 6eb636600..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part +++ /dev/null @@ -1,174 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Names.part -! Last Update : Jan-01-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Methods to access the obj%stressType obj%StrainType -! obj%RateType -! HOSTING FILE -! - MaterialJacobian_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! setStressType1 -!------------------------------------------------------------------------------ - - SUBROUTINE setStressType1( obj, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. set the obj%StressType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - obj%StressType = StressType - - END SUBROUTINE setStressType1 - -!------------------------------------------------------------------------------ -! setStressType2 -!------------------------------------------------------------------------------ - - SUBROUTINE setStressType2( obj, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. set the obj%StressType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - TYPE( String_ ), INTENT( IN ) :: StressType - - obj%StressType = StressType - - END SUBROUTINE setStressType2 - -!------------------------------------------------------------------------------ -! setStrainType1 -!------------------------------------------------------------------------------ - - SUBROUTINE setStrainType1( obj, StrainType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. set the obj%StrainType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: StrainType - - obj%StrainType = StrainType - - END SUBROUTINE setStrainType1 - -!------------------------------------------------------------------------------ -! setStrainType2 -!------------------------------------------------------------------------------ - - SUBROUTINE setStrainType2( obj, StrainType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. set the obj%StrainType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - TYPE( String_ ), INTENT( IN ) :: StrainType - - obj%StrainType = StrainType - - END SUBROUTINE setStrainType2 - -!------------------------------------------------------------------------------ -! setRateType1 -!------------------------------------------------------------------------------ - - SUBROUTINE setRateType1( obj, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. set the obj%RateType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: RateType - - obj%RateType = RateType - - END SUBROUTINE setRateType1 - -!------------------------------------------------------------------------------ -! setRateType2 -!------------------------------------------------------------------------------ - - SUBROUTINE setRateType2( obj, RateType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. set the obj%RateType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj - TYPE( String_ ), INTENT( IN ) :: RateType - - obj%RateType = RateType - - END SUBROUTINE setRateType2 - -!------------------------------------------------------------------------------ -! getStressType -!------------------------------------------------------------------------------ - - FUNCTION getStressType( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. get the obj%StressType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - TYPE( String_ ) :: getStressType - - getStressType = obj%StressType - - END FUNCTION getStressType - -!------------------------------------------------------------------------------ -! getStrainType -!------------------------------------------------------------------------------ - - FUNCTION getStrainType( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. get the obj%StrainType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - TYPE( String_ ) :: getStrainType - - getStrainType = obj%StrainType - - END FUNCTION getStrainType - -!------------------------------------------------------------------------------ -! getRateType -!------------------------------------------------------------------------------ - - FUNCTION getRateType( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. get the obj%RateType -!. . . . . . . . . . . . . . . . . . . . - - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - TYPE( String_ ) :: getRateType - - getRateType = obj%RateType - - END FUNCTION getRateType \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part deleted file mode 100755 index f8d1d1606..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part +++ /dev/null @@ -1,193 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Addition.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Addition Operator is defined -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_obj( obj, obj2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj2 - REAL( DFP ), ALLOCATABLE :: obj_Add_obj( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: N1, N2 - - IF( .NOT. ALLOCATED( obj%C ) & - .OR. .NOT. ALLOCATED( obj2%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Addition.part", & - "obj + obj2", & - "obj or obj2 is/are not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N1 = .SIZE. obj - N2 = .SIZE. obj2 - - IF( N1 .NE. N2 ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Addition.part", & - "obj + obj2", & - "The Shape of obj%C and obj2%C are not Compatible, & - Program Stopped!!!"& - ) - STOP - - END IF - - ALLOCATE( obj_Add_obj( N1, N1 ) ) - - obj_Add_obj = obj%C + obj2%C - - END FUNCTION obj_Add_obj - -!------------------------------------------------------------------------------ -! obj_Add_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_Mat( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), ALLOCATABLE :: obj_Add_Mat( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: N1, N2 - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Addition.part", & - "obj + Mat", & - "obj is not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N1 = .SIZE. obj - N2 = SIZE( Mat, 1 ) - - IF( N1 .NE. N2 ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Addition.part", & - "obj + Mat", & - "The Shape of obj%C and Mat are not Compatible, & - Program Stopped!!!"& - ) - STOP - - END IF - - ALLOCATE( obj_Add_Mat( N1, N1 ) ) - - obj_Add_Mat = obj%C + Mat - - END FUNCTION obj_Add_Mat - -!------------------------------------------------------------------------------ -! Mat_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_Add_obj( Mat, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat + obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), ALLOCATABLE :: Mat_Add_obj( :, : ) - - Mat_Add_obj = obj_Add_Mat( obj, Mat ) - - END FUNCTION Mat_Add_obj - -!------------------------------------------------------------------------------ -! obj_Add_Scalar -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_Scalar( obj, Scalar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Scalar -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), ALLOCATABLE :: obj_Add_Scalar( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Addition.part", & - "obj + Mat", & - "obj is not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N = .SIZE. obj - ALLOCATE( obj_Add_Scalar( N, N ) ) - obj_Add_Scalar = obj%C + Scalar - - END FUNCTION obj_Add_Scalar - -!------------------------------------------------------------------------------ -! Scalar_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION Scalar_Add_obj( Scalar, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Scalar + obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), ALLOCATABLE :: Scalar_Add_obj( :, : ) - - Scalar_Add_obj = obj_Add_Scalar( obj, Scalar ) - - END FUNCTION Scalar_Add_obj \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part deleted file mode 100755 index 25b191038..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part +++ /dev/null @@ -1,75 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Asterics.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Asterics Operator is defined for Material Jacobian and -! tensor -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_Times_Scalar -!------------------------------------------------------------------------------ - - FUNCTION obj_Times_Scalar( obj, Scalar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Contraction. Tensor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), ALLOCATABLE :: obj_Times_Scalar( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Asterics.part", & - "obj * Scalar", & - "obj is not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N = .SIZE. obj - ALLOCATE( obj_Times_Scalar( N, N ) ) - obj_Times_Scalar = obj%C * Scalar - - END FUNCTION obj_Times_Scalar - -!------------------------------------------------------------------------------ -! Scalar_Times_obj -!------------------------------------------------------------------------------ - - FUNCTION Scalar_Times_obj( Scalar, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Contraction. Tensor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), ALLOCATABLE :: Scalar_Times_obj( :, : ) - - Scalar_Times_obj = obj_Times_Scalar( obj, Scalar ) - - END FUNCTION Scalar_Times_obj - diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part deleted file mode 100755 index 5ddfabde6..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part +++ /dev/null @@ -1,424 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Cijkl.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Operators to access the obj%C are defined -! - .Cijkl. -! - .AT. -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! Cijkl_1 -!------------------------------------------------------------------------------ - - FUNCTION Cijkl_1( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Operator .Cijkl. , Mat = .Cijkl. obj returns obj%C -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE :: Cijkl_1( :, : ) - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " .Cijkl. obj", & - "obj%C is not allocated, Program Stopped!!!"& - ) - - STOP - - END IF - - IF( ALLOCATED( Cijkl_1 ) ) DEALLOCATE( Cijkl_1 ) - Cijkl_1 = obj%C - - END FUNCTION Cijkl_1 - -!------------------------------------------------------------------------------ -! Cijkl_2 -!------------------------------------------------------------------------------ - - FUNCTION Cijkl_2( obj, Indx ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Indx( 2 ) - REAL( DFP ) :: Cijkl_2 - - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " obj .Cijkl. Index", & - "obj%C is not allocated, Program Stopped!!!"& - ) - - STOP - - END IF - - N = .SIZE. obj - - IF( ANY( Indx .GT. N ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " obj .Cijkl. Index", & - "Indx is out of bound, Program Stopped!!!"& - ) - - STOP - - END IF - - Cijkl_2 = obj%C( Indx( 1 ), Indx( 2 ) ) - - END FUNCTION Cijkl_2 - -!------------------------------------------------------------------------------ -! Cijkl_4 -!------------------------------------------------------------------------------ - - FUNCTION Cijkl_4( obj, Indx ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) -!. . . . . . . . . . . . . . . . . . . . - - USE Voigt - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Indx( 4 ) - REAL( DFP ) :: Cijkl_4 - - INTEGER( I4B ) :: NSD, N, i, j, k, l - INTEGER( I4B ), ALLOCATABLE :: IndxMat( :, : ) - REAL( DFP ), ALLOCATABLE :: C( :, : ) - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " obj .Cijkl. Index", & - "obj%C is not allocated, Program Stopped!!!"& - ) - - STOP - - END IF - - N = .SIZE. obj - - NSD = 3 - - IF( ANY( Indx .GT. NSD ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " obj .Cijkl. Index", & - "Indx should be less than NSD = 3, Program Stopped!!!"& - ) - - STOP - - END IF - - ALLOCATE( IndxMat( NSD, NSD ) ) - - IndxMat( 1, 1 ) = 1 - IndxMat( 2, 2 ) = 2 - IndxMat( 3, 3 ) = 3 - IndxMat( 1, 2 ) = 4 - IndxMat( 2, 1 ) = 4 - IndxMat( 2, 3 ) = 5 - IndxMat( 3, 2 ) = 5 - IndxMat( 1, 3 ) = 6 - IndxMat( 3, 1 ) = 6 - - i = Indx( 1 ) - j = Indx( 2 ) - k = Indx( 3 ) - l = Indx( 4 ) - - SELECT CASE( N ) - - CASE( 6 ) - - Cijkl_4 = obj%C( IndxMat( i, j ), IndxMat( k, l ) ) - - CASE( 4 ) - - C = Mat6_From_Mat4( obj%C ) - Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) - - CASE( 3 ) - - C = Mat6_From_Mat3( obj%C ) - Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) - - CASE( 2 ) - - C = Mat6_From_Mat2( obj%C ) - Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) - - - CASE( 1 ) - C = Mat6_From_Mat1( obj%C ) - Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) - - CASE DEFAULT - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " obj .Cijkl. Index", & - "No Case Found for shape of Stored obj%C, Program Stopped!!!"& - ) - STOP - - END SELECT - - - IF( ALLOCATED( C ) ) DEALLOCATE( C ) - IF( ALLOCATED( IndxMat ) ) DEALLOCATE( IndxMat ) - - END FUNCTION Cijkl_4 - -!------------------------------------------------------------------------------ -! Cijkl -!------------------------------------------------------------------------------ - - FUNCTION Cijkl( obj, Indx ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Indx( : ) - REAL( DFP ) :: Cijkl - - SELECT CASE( SIZE( Indx ) ) - - CASE( 2 ) - - Cijkl = Cijkl_2( obj, Indx ) - - CASE( 4 ) - - Cijkl = Cijkl_4( obj, Indx ) - - CASE DEFAULT - - Cijkl = 0.0_DFP - - END SELECT - - END FUNCTION Cijkl - -!------------------------------------------------------------------------------ -! Cijkl_5 -!------------------------------------------------------------------------------ - - FUNCTION Cijkl_5( obj, M ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) -!. . . . . . . . . . . . . . . . . . . . - - USE Voigt - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: M - REAL( DFP ) :: Cijkl_5( M , M ) - - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " obj .Cijkl. Index", & - "obj%C is not allocated, Program Stopped!!!"& - ) - - STOP - - END IF - - N = .SIZE. obj - - SELECT CASE( N ) - - CASE( 6 ) - - SELECT CASE( M ) - - CASE( 6 ) - - Cijkl_5 = obj%C - - CASE( 4 ) - - Cijkl_5 = Mat4_From_Mat6( obj%C ) - - CASE( 3 ) - - Cijkl_5 = Mat3_From_Mat6( obj%C ) - - CASE( 2 ) - - Cijkl_5 = Mat2_From_Mat6( obj%C ) - - CASE( 1 ) - - Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) - - - END SELECT - - CASE( 4 ) - - SELECT CASE( M ) - - CASE( 6 ) - - Cijkl_5 = Mat6_From_Mat4( obj%C ) - - CASE( 4 ) - - Cijkl_5 = obj%C - - CASE( 3 ) - - Cijkl_5 = Mat3_From_Mat4( obj%C ) - - CASE( 2 ) - - Cijkl_5 = Mat2_From_Mat4( obj%C ) - - CASE( 1 ) - - Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) - - - END SELECT - - CASE( 3 ) - - SELECT CASE( M ) - - CASE( 6 ) - - Cijkl_5 = Mat6_From_Mat3( obj%C ) - - CASE( 4 ) - - Cijkl_5 = Mat4_From_Mat3( obj%C ) - - CASE( 3 ) - - Cijkl_5 = obj%C - - CASE( 2 ) - - Cijkl_5 = Mat2_From_Mat3( obj%C ) - - CASE( 1 ) - - Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) - - - END SELECT - - CASE( 2 ) - - SELECT CASE( M ) - - CASE( 6 ) - - Cijkl_5 = Mat6_From_Mat2( obj%C ) - - CASE( 4 ) - - Cijkl_5 = Mat4_From_Mat2( obj%C ) - - CASE( 3 ) - - Cijkl_5 = Mat3_From_Mat2( obj%C ) - - CASE( 2 ) - - Cijkl_5 = obj%C - - CASE( 1 ) - - Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) - - - END SELECT - - CASE( 1 ) - - SELECT CASE( M ) - - CASE( 6 ) - - Cijkl_5 = Mat6_From_Mat1( obj%C ) - - CASE( 4 ) - - Cijkl_5 = Mat4_From_Mat1( obj%C ) - - CASE( 3 ) - - Cijkl_5 = Mat3_From_Mat1( obj%C ) - - CASE( 2 ) - - Cijkl_5 = Mat2_From_Mat1( obj%C ) - - CASE( 1 ) - - Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) - - - END SELECT - - CASE DEFAULT - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & - " obj .Cijkl. Index", & - "No Case Found for shape of Stored obj%C, Program Stopped!!!"& - ) - STOP - - END SELECT - - END FUNCTION Cijkl_5 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part deleted file mode 100755 index 5583aff19..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part +++ /dev/null @@ -1,130 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Contraction.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Contraction Operator is defined for Material Jacobian and -! tensor -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! Contraction_1 -!------------------------------------------------------------------------------ - - FUNCTION Contraction_1( obj, Tensorobj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Contraction. Tensor -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE Voigt - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ) :: Contraction_1( 3, 3 ) - - ! Define intent of dummy variables - REAL( DFP ), ALLOCATABLE :: Vec( : ) - - CALL Tensorobj%getTensor( Vec, "Strain" ) - Vec = MATMUL( obj .Cijkl. SIZE(Vec), Vec ) - Contraction_1 = MatFromVoigtVec( Vec, "Stress" ) - DEALLOCATE( Vec ) - - END FUNCTION Contraction_1 - -!------------------------------------------------------------------------------ -! Contraction_2 -!------------------------------------------------------------------------------ - - FUNCTION Contraction_2( Tensorobj, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Tensor .Contraction. obj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE Voigt - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ) :: Contraction_2( 3, 3 ) - - ! Define intent of dummy variables - REAL( DFP ), ALLOCATABLE :: Vec( : ) - - CALL Tensorobj%getTensor( Vec, "Strain" ) - Vec = MATMUL( TRANSPOSE( obj .Cijkl. SIZE( Vec ) ), Vec ) - Contraction_2 = MatFromVoigtVec( Vec, "Stress" ) - DEALLOCATE( Vec ) - - END FUNCTION Contraction_2 - -!------------------------------------------------------------------------------ -! Contraction_3 -!------------------------------------------------------------------------------ - - FUNCTION Contraction_3( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Contraction. Mat -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE Voigt - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ) :: Contraction_3( 3, 3 ) - - ! Define intent of dummy variables - TYPE( Rank2Tensor_ ) :: Tensorobj - - Tensorobj = Mat - Contraction_3 = Contraction_1( obj, Tensorobj ) - CALL Tensorobj%Deallocate( ) - - END FUNCTION Contraction_3 - -!------------------------------------------------------------------------------ -! Contraction_4 -!------------------------------------------------------------------------------ - - FUNCTION Contraction_4( Mat, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat .Contraction. obj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE Voigt - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ) :: Contraction_4( 3, 3 ) - - ! Define intent of dummy variables - TYPE( Rank2Tensor_ ) :: Tensorobj - - Tensorobj = Mat - Contraction_4 = Contraction_2( Tensorobj, obj ) - CALL Tensorobj%Deallocate( ) - - END FUNCTION Contraction_4 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part deleted file mode 100755 index fe56704b4..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part +++ /dev/null @@ -1,91 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Matmul.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - matmul Operator is defined for defining matrix multiplication -! of Material Jacobian and voigt vector. -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_matmul_Vec -!------------------------------------------------------------------------------ - - FUNCTION obj_matmul_Vec( obj, Vec ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .matmul. Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Vec( : ) - REAL( DFP ), ALLOCATABLE :: obj_matmul_Vec( : ) - - ! Define internal variables - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>matmul.part", & - "obj .matmul. Vec", & - "obj is not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N = SIZE( Vec ) - ALLOCATE( obj_matmul_Vec( N ) ) - obj_matmul_Vec = MATMUL( obj .Cijkl. N, Vec ) - - END FUNCTION obj_matmul_Vec - -!------------------------------------------------------------------------------ -! Vec_matmul_obj -!------------------------------------------------------------------------------ - - FUNCTION Vec_matmul_obj( Vec, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Vec .matmul. obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Vec( : ) - REAL( DFP ), ALLOCATABLE :: Vec_matmul_obj( : ) - - ! Define internal variables - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>matmul.part", & - "obj .matmul. Vec", & - "obj is not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N = SIZE( Vec ) - ALLOCATE( Vec_matmul_obj( N ) ) - - Vec_matmul_obj = MATMUL( TRANSPOSE( obj .Cijkl. N ), Vec ) - - END FUNCTION Vec_matmul_obj diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part deleted file mode 100755 index a27579299..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part +++ /dev/null @@ -1,193 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Subtraction.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Subtraction Operator is defined -! HOSTING FILE -! - MaterialJacobian_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_obj( obj, obj2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj - obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj2 - REAL( DFP ), ALLOCATABLE :: obj_Minus_obj( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: N1, N2 - - IF( .NOT. ALLOCATED( obj%C ) & - .OR. .NOT. ALLOCATED( obj2%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Subtraction.part", & - "obj - obj2", & - "obj or obj2 is/are not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N1 = .SIZE. obj - N2 = .SIZE. obj2 - - IF( N1 .NE. N2 ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Subtraction.part", & - "obj - obj2", & - "The Shape of obj%C and obj2%C are not Compatible, & - Program Stopped!!!"& - ) - STOP - - END IF - - ALLOCATE( obj_Minus_obj( N1, N1 ) ) - - obj_Minus_obj = obj%C - obj2%C - - END FUNCTION obj_Minus_obj - -!------------------------------------------------------------------------------ -! obj_Minus_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_Mat( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj - Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), ALLOCATABLE :: obj_Minus_Mat( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: N1, N2 - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Subtraction.part", & - "obj - Mat", & - "obj is not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N1 = .SIZE. obj - N2 = SIZE( Mat, 1 ) - - IF( N1 .NE. N2 ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Subtraction.part", & - "obj - Mat", & - "The Shape of obj%C and Mat are not Compatible, & - Program Stopped!!!"& - ) - STOP - - END IF - - ALLOCATE( obj_Minus_Mat( N1, N1 ) ) - - obj_Minus_Mat = obj%C - Mat - - END FUNCTION obj_Minus_Mat - -!------------------------------------------------------------------------------ -! Mat_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_Minus_obj( Mat, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat - obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - REAL( DFP ), ALLOCATABLE :: Mat_Minus_obj( :, : ) - - Mat_Minus_obj = -obj_Minus_Mat( obj, Mat ) - - END FUNCTION Mat_Minus_obj - -!------------------------------------------------------------------------------ -! obj_Minus_Scalar -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_Scalar( obj, Scalar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj - Scalar -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), ALLOCATABLE :: obj_Minus_Scalar( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>Subtraction.part", & - "obj - Mat", & - "obj is not initiated, Program Stopped!!!"& - ) - STOP - - END IF - - N = .SIZE. obj - ALLOCATE( obj_Minus_Scalar( N, N ) ) - obj_Minus_Scalar = obj%C - Scalar - - END FUNCTION obj_Minus_Scalar - -!------------------------------------------------------------------------------ -! Scalar_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION Scalar_Minus_obj( Scalar, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Scalar - obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), ALLOCATABLE :: Scalar_Minus_obj( :, : ) - - Scalar_Minus_obj = -obj_Minus_Scalar( obj, Scalar ) - - END FUNCTION Scalar_Minus_obj \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part deleted file mode 100755 index cd42bafe1..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part +++ /dev/null @@ -1,146 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: getCijkl.part -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Methods to access the obj%C -! HOSTING FILE -! - MaterialJacobian_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getCijkl -!------------------------------------------------------------------------------ - - SUBROUTINE getCijkl( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Reallcoate Mat with obj%C -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: Mat( :, : ) - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>getCijkl.part", & - "getCijkl(obj, Mat)", & - "obj%C is not allocated."& - ) - - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED( Mat ) ) DEALLOCATE( Mat ) - Mat = obj%C - - END SUBROUTINE getCijkl - -!------------------------------------------------------------------------------ -! getCijkl_Pointer -!------------------------------------------------------------------------------ - - SUBROUTINE getCijkl_Pointer( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat => obj%C, Returns pointer to obj%C -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ), TARGET :: obj - REAL( DFP ), POINTER, INTENT( OUT ) :: Mat( :, : ) - - Error_Flag = .FALSE. - - IF( ASSOCIATED( Mat ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>getCijkl_Pointer.part", & - "getCijkl_Pointer(obj, Mat)", & - "Mat is already associated, Nullify first."& - ) - - Error_Flag = .TRUE. - RETURN - - END IF - - IF( .NOT. ALLOCATED( obj%C ) ) THEN - - CALL Err_Msg( & - "MaterialJacobian_Class.F90>>getCijkl_Pointer.part", & - "getCijkl_Pointer(obj, Mat)", & - "obj%C is not allocated."& - ) - - Error_Flag = .TRUE. - RETURN - - END IF - - Mat => obj%C - - END SUBROUTINE getCijkl_Pointer - -!------------------------------------------------------------------------------ -! Cijkl_Pointer -!------------------------------------------------------------------------------ - - FUNCTION Cijkl_Pointer( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Cijkl_Pointer => obj%C, Function Returns pointer to obj%C -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ), TARGET :: obj - REAL( DFP ), POINTER :: Cijkl_Pointer( :, : ) - - Cijkl_Pointer => NULL( ) - - CALL obj%getCijkl_Pointer( Cijkl_Pointer ) - CALL Check_Error( & - "MaterialJacobian_Class.F90>>getCijkl.part>> Mat => obj%Cijkl_Pointer()", & - "Traceback ---> CALL obj%getCijkl_Pointer( Cijkl_Pointer )"& - ) - - END FUNCTION Cijkl_Pointer - -!------------------------------------------------------------------------------ -! obj2Mat -!------------------------------------------------------------------------------ - - SUBROUTINE obj2Mat( Mat, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat = obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: Mat( :, : ) - - CALL obj%getCijkl( Mat ) - CALL Check_Error( & - "MaterialJacobian_Class.F90>>getCijkl.part>> Mat = obj", & - "Traceback ---> CALL obj%getCijkl( Mat )"& - ) - - END SUBROUTINE obj2Mat \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md b/src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md deleted file mode 100755 index 1f6e6f7f6..000000000 --- a/src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md +++ /dev/null @@ -1,2288 +0,0 @@ -# Rank2Tensor Class is defined - -## Notice - -On 13-July-2018, when I tried to compile this module using ifort then there was an error related to .matmul. I think it is due to the fact that this operator was defined as an method as well as the module generic operator. So I have removed it as a method, and i have kept it only as module generic operator. - - -## ToDO - --Extend to `VelocityGradient_` --Extend to `RightCauchyGreen_` --Extend to `LeftCauchyGreen_` --Extend to `StrainRate_` --Extend to `SpinTensor_` --Extend to `ContinuumSpin_` --Extend to `MaterialJacobian_` a Rank-4 tensor but in Voigt form --Add methods for getting derivative of invariants and Tensor. --Add methods for Convective Rates --Add methods so that T = Mat2 --Add EigenProjection methods. --Add robust tensor-exponentatial function. --Add method for getting the isochoric and volumetric part - -## Structure - -```fortran - TYPE, PUBLIC :: Tensor_ - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: T - INTEGER( I4B ) :: NSD -``` - -## Description - -`NSD` stands for number of spatial dimension. Rank2Tensor `T` is always (3,3), but NSD helps us to identify which components are meaningful. - -## Getting Started - -### Initiating the `Tensor_` object - -The subroutine `Initiate()` can be used to create the `Tensor_` class. - -```fortran -CALL obj%Initiate( ) -CALL obj%Initiate( Mat2( :, : ) ) -CALL obj%Initiate( Scalar ) -CALL obj%Initiate( VoigtVec, VoigtType ) -CALL obj%Initiate( obj2 ) -``` - -In addition we can use the function `Rank2Tensor()` which returns the `Rank2Tensor_` type. - -```fortran -obj = Rank2Tensor( ) -obj = Rank2Tensor( Mat2 ) -obj = Rank2Tensor( Scalar ) -obj = Rank2Tensor( VoigtVec, VoigtType ) -obj = Rank2Tensor( obj2 ) -``` - -We have also defined function `Rank2Tensor_Pointer()` that returns the pointer to the `Rank2Tensor_` pointer. - -```fortran -obj => Rank2Tensor_Pointer( ) -obj => Rank2Tensor_Pointer( Mat2 ) -obj => Rank2Tensor_Pointer( Scalar ) -obj => Rank2Tensor_Pointer( VoigtVec, VoigtType ) -obj => Rank2Tensor_Pointer( obj2 ) -``` - -We can also use `Assignment Operator( = )` - -```fortran -obj = Mat2( :, : ) -``` - -```fortran -CALL obj%Initiate( ) -obj = Rank2Tensor( ) -obj => Rank2Tensor_Pointer( ) -``` - -The above call will create the `Tensor_` object with all zero entries and NSD = 3. - -```fortran -CALL obj%Initiate( Mat2 ) -obj = Rank2Tensor( Mat2 ) -obj => Rank2Tensor_Pointer( Mat2 ) -``` - -The above call will create the `Tensor_` object. Depending upon the size of `Mat2(:,:)` NSD is decided. - -```fortran -CALL obj%Initiate( Scalar ) -obj = Rank2Tensor( Scalar ) -obj => Rank2Tensor_Pointer( Scalar ) -``` - -The above call will fill all entries with the scalar, and `NSD` will be set to 3. - -```fortran -CALL obj%Initiate( VoigtVec, VoigtType ) -obj = Rank2Tensor( VoigtVec, VoigtType ) -obj => Rank2Tensor_Pointer( VoigtVec, VoigtType ) -``` - -The above call will make tensor object from the voigt vector. `VoigtType` can be `Stress` or `Strain`. - -```fortran -CALL obj%Initiate( obj2 ) -obj = Rank2Tensor( obj2 ) -obj => Rank2Tensor_Pointer( obj2 ) -``` - -The above call will make tensor object from other tensor object. - -### Checking the status and deallocating the data - -```fortran -CALL obj%isInitiated( ) -CALL obj%Deallocate( ) -``` - -### Setting and getting the NSD - -```fortran -NSD = obj%getNSD( ) -NSD = .NSD. obj -CALL obj%setNSD( NSD ) -``` - -### Getting the tensor - -We can get the Tensor in a matrix as well as voigt vector. To get tensor in voigt vector we need to call `getTensor()` - -```fortran -CALL obj%getTensor( Mat ) -CALL obj%getTensor( VoigtVec, VoigtType ) -``` - -Both `Mat` and `VoigtVec` must be allocatable as they are reallocated by the method. - -We can use assignment operator. - -```fortran -Mat = obj -``` - -### Logical Functions for Tensor - -We have defined the function `isSymmetric()` and `isDeviatoric()` - -```fortran -L = isSymmetric( obj ) -L = isSymmetric( Mat2 ) -L = isDeviatoric( obj ) -L = isDeviatoric( Mat2 ) -``` - -### Invariants - -**Trace Of Tensor or Matrix** - -```fortran -t = Trace( obj ) -t = Trace( Mat ) -t = .Trace. obj -t = .Trace. Mat -``` - -**Contraction of Tensors** - -```fortran -s = DoubleDot_Product( obj, obj2 ) -s = DoubleDot_Product( obj, Mat ) -s = DoubleDot_Product( obj, VoigtVec, VoigtType ) -s = DoubleDot_Product( A, B ) -s = DoubleDot_Product( A, VoigtType_A, B, VoigtType_B ) -s = DoubleDot_Product( Mat, VoigtVec, VoigtType ) -``` - -We also defined the `DoubleDot` operator. This operator works only on matrices and Rank2Tensor_ objects. - -```fortran -s = obj .doubledot. obj -s = obj .doubledot. mat -s = mat .doubledot. obj -s = mat .doubledot. mat -``` - -**Invariant_I1** - -$$I_1 = Trace( T ) $$ - -```fortran -I1 = Invarinant_I1( obj ) -I1 = Invarinant_I1( Mat ) -``` - -**Invariant_I2** - -`I2 = 0.5( ( Tr( T )**2 - Tr( T*T ) ) )` - -```fortran -I2 = Invarinant_I2( obj ) -I2 = Invarinant_I2( Mat ) -``` - -**Invariant_I3** - -`I3 = det( Tensor )` - -```fortran -I3 = Invarinant_I3( obj ) -I3 = Invarinant_I3( Mat ) -``` - -**Invariant_J2** - -`I2 = 0.5 * Dev( T ): Dev( T )` - -```fortran -J2 = Invarinant_J2( obj ) -J2 = Invarinant_J2( Mat ) -``` - -**Invariant_J3** - -`J3 = det( Dev( T ) )` - -```fortran -J3 = Invarinant_J3( obj ) -J3 = Invarinant_J3( Mat ) -``` - -**LodeAngle** - - -```fortran -theta = LodeAngle( J2, J3, LodeAngleType ) -theta = LodeAngle( obj, LodeAngleType ) -theta = LodeAngle( Mat, LodeAngleType ) -``` - -`LodeAngleType` can be `Sine` or `Cosine`. - - -### Tensor Decomposition - -**Getting Symmetric and Skew Symmetric Part** - -```fortran -Dummy = SymmetricPart( obj ) -Dummy = SymmetricPart( Mat ) -Dummy = AntiSymmetricPart( obj ) -Dummy = AntiSymmetricPart( Mat ) -``` - -We can also use the operator `.Sym.` and `.Anti.` - -```fortran -Dummy = .Sym. obj -Dummy = .Sym. Mat -Dummy = .Anti. obj -Dummy = .Anti. Mat -``` - -**getting the Hydrostatic Part** - -`Trace( T ) / 3` - -```fortran -Dummy = HydrostaticPart( obj ) -Dummy = HydrostaticPart( Mat ) -Dummy = SphericalPart( obj ) -Dummy = Spherical( Mat ) -``` - -We can also use `.Hydro.` operator. - -```fortran -Dummy = .Hydro. obj -Dummy = .Hydro. Mat -``` - -**Getting the Deviatoric Part** - -```fortran -Dummy = DeviatoricPart( obj ) -Dummy = DeviatoricPart( Mat ) -Dummy = .Dev.( obj ) -Dummy = .Dev.( Mat ) -``` - -### Pull-Back operation - -```fortran -Dummy = Pullback( T, F, indx1, indx2 ) -``` - -`T` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. `F` can be a `Rank2Tensor_` or Matrix of (3,3) shape. Indx1, and Indx2 should be `Contra`, `CoVar`. - -We can also use `Pullback` of vector using the same functions. - -```fortran -Dummy = Pullback( Vec, F, indx1 ) -``` - -`F` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. - -### Push-Forward operation - -```fortran -Dummy = PushForward( T, F, indx1, indx2 ) -``` - -`T` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. `F` can be a `Rank2Tensor_` or Matrix of (3,3) shape. Indx1, and Indx2 should be `Contra`, `CoVar`. - -We can also use `Pullback` of vector using the same functions. - -```fortran -Dummy = PushForward( Vec, F, indx1 ) -``` - -`F` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. - -## Spectral Decomposition of tensor - -**Getting the EigenValues and EigenVectors** - -We have defined the routine called `Tensor_Eigens` for getting the eigen values and eigen-vectors. - -```fortran -CALL Tensor_Eigens( Mat, EigenValues, EigenVectors ) -``` - -EigenValues can be Rank-2 or Rank-1 fortran array. If Rank-1 then only real parts of eigen-values will be returned. - -**Getting the PrincipalValue** - -Principal values is defined by the maximum eigen value. - -```fortran -dummy = Tensor_PrincipalValue( obj ) -dummy = Tensor_PrincipalValue( Mat ) -``` - -**Getting the SpectralRadius** - -```fortran -dummy = Tensor_SpectralRadius( obj ) -dummy = Tensor_SpectralRadius( Mat ) -``` - -### Polar Decomposition - -```fortran -CALL PolarDecomposition( Mat, R, H, PDType ) -CALL PolarDecomposition( obj, R, H, PDType ) -``` - -```fortran -R = RotationPart( Mat ) -R = RotationPart( obj ) -``` - -### Vector Operations - -**VectorProduct** - -We have defined `VectorProduct()` function for computing the cross product( also known as vector product ), It returns a length 3 vector. `VectorProduct(u,v)` is $u \times v$. `VectorProduct(u,v,w)` is equivalent to $u \times ( v \times w )$ - -```fortran -Vec = VectorProduct( u, v ) -Vec = u .X. v -Vec = VectorProduct( u, v, w ) -``` - -**BoxProduct** - -The `BoxProduct(u,v,w)` is equivalent to $[u,v,w] = u \cdot ( v \times w )$ - -```fortran -Dummy = BoxProduct( u, v, w) -``` - -**getAngle** - -Returns the angle (in radians) betrween two vectors - -```fortran -theta = getAngle( u, v ) -theta = u .Angle. v -``` - -**getProjection** - -`getProjection(u,v)` project vector u on v and returns the projection vector in the direction of v. - -```fortran -P = u .ProjectOn. v -``` - -**UnitVector** - -Returns the unit vector - -```fortran -uhat = UnitVector( u ) -uhat = .UnitVector. u -``` - -**Dot Product** - -```fortran -s = DOT_PRODUCT( u, v ) -s = u .dot. v -``` - -**Normal and Parallel components** - -We have defined two operators to decompose a vector in the direction along and perpendicular to some vector. - -```fortran -p = u .ComponentParallelTo. v -n = u .ComponentNormalTo. v -``` - -**Vector2D** - -`Vector2D` converts any vector in two 2D vector format. - -**Vector3D** - -`vector3D` converts any vector in 3D vector format. - -**Vector1D** - -`vector1D` converts any vector in 1D vector format. - - -### Operator Overloading - -**Contraction** - -```fortran -obj .Contraction. MaterialJacobianobj -MaterialJaconbianobj .Contraction. obj -``` - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -## Construction Methods - -```fortran -CALL obj%initiate( ) -CALL obj%Initiate( Mat ) -CALL obj%Initiate( Scalar ) -CALL obj%Initiate( VoigtVec, VoigtType ) -CALL obj%Initiate( obj2 ) -``` - -```fortran -obj => Tensor_Pointer( ) -obj => Tensor_Pointer( Mat ) -obj => Tensor_Pointer( Scalar ) -obj => Tensor_Pointer( VoigtVec, VoigtType ) -obj => Tensor_Pointer( obj2 ) -``` - -```fortran -obj = Rank2Tensor( ) -obj = Rank2Tensor( Mat ) -obj = Rank2Tensor( Scalar ) -obj = Rank2Tensor( VoigtVec, VoigtType ) -obj = Rank2Tensor( obj2 ) -``` - -### Initiate() - -Type-1 - -Interface - -```fortran - SUBROUTINE Initiate1( obj ) - CLASS( Tensor_ ), INTENT( INOUT ) :: obj - IF( ALLOCATED( obj%T ) ) DEALLOCATE( obj%T ) - ALLOCATE( obj%T( 3, 3 ) ) - obj%NSD = 3 - obj%T = 0.0_DFP - END SUBROUTINE Initiate1 -``` - -Description - -See the above code. - -Type-2 - -Interface - -```fortran - SUBROUTINE Initiate2( obj, A ) - CLASS( Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A -``` - -Description - -Here `A` should be a square matrix of the size in the list {1,2,3}. - -Type-3 - -Interface - -```fortran - SUBROUTINE Initiate3( obj, A ) - CLASS( Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: A - - IF( ALLOCATED( obj%T ) ) DEALLOCATE( obj%T ) - ALLOCATE( obj%T( 3, 3 ) ) - obj%T = A - END SUBROUTINE Initiate3 -``` - -Description - -See the code above - -Type-4 - -Interface - -```fortran - SUBROUTINE Initiate4( obj, A, VoigtType ) - USE Voigt - CLASS( Tensor_ ), INTENT( INOUT ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType -``` - -Description - -Coverts a Voigt vector into a tensor. - -Type-5 - -Interface - -```fortran - SUBROUTINE Initiate5( obj, obj2 ) - CLASS( Tensor_ ), INTENT( INOUT ) :: obj - CLASS( Tensor_ ), INTENT( IN ) :: obj2 -``` - -Description - -Coverts a Voigt vector into a tensor. - -### Tensor_Pointer( ) - -Type-1 - -Interface - -```fortran - FUNCTION Constructor1( ) - CLASS( Tensor_ ), POINTER :: Constructor1 - - ALLOCATE( Tensor_ :: Constructor1 ) - CALL Constructor1%Initiate( ) - END FUNCTION Constructor1 -``` - -Description - -Type-2 - -Interface - -```fortran - FUNCTION Constructor2( A ) - CLASS( Tensor_ ), POINTER :: Constructor2 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A - Error_Flag = .FALSE. - ALLOCATE( Tensor_ :: Constructor2 ) - CALL Constructor2%Initiate( A ) - END FUNCTION Constructor2 -``` - -Description - -Type-3 - -Interface - -```fortran - FUNCTION Constructor3( A ) - CLASS( Tensor_ ), POINTER :: Constructor3 - REAL( DFP ), INTENT( IN ) :: A - - Error_Flag = .FALSE. - - ALLOCATE( Tensor_ :: Constructor3 ) - CALL Constructor3%Initiate( A ) - END FUNCTION Constructor3 -``` - -Description - -Type-4 - -Interface - -```fortran - FUNCTION Constructor4( A, VoigtType ) - USE Voigt - CLASS( Tensor_ ), POINTER :: Constructor4 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType - - Error_Flag = .FALSE. - ALLOCATE( Tensor_ :: Constructor4 ) - CALL Constructor4%Initiate( A, VoigtType ) - END FUNCTION Constructor4 -``` - -Description - -Type-5 - -Interface - -```fortran - FUNCTION Constructor10( obj ) - CLASS( Tensor_ ), POINTER :: Constructor10 - CLASS( Tensor_ ), INTENT( IN ) :: obj - - ALLOCATE( Constructor10 ) - CALL Constructor10%Initiate( obj ) - END FUNCTION Constructor10 -``` - -Description - -### Rank2Tensor( ) - -Type-1 - -Interface - -```fortran - FUNCTION Constructor5( ) - TYPE( Tensor_ ) :: Constructor5 - - CALL Constructor5%Initiate( ) - END FUNCTION Constructor5 -``` - -Description - -Type-2 - -Interface - -```fortran - FUNCTION Constructor6( A ) - TYPE( Tensor_ ) :: Constructor6 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A - - Error_Flag = .FALSE. - CALL Constructor6%Initiate( A ) - END FUNCTION Constructor6 -``` - -Description - -Type-3 - -Interface - -```fortran - FUNCTION Constructor7( A ) - TYPE( Tensor_ ) :: Constructor7 - REAL( DFP ), INTENT( IN ) :: A - - Error_Flag = .FALSE. - - CALL Constructor7%Initiate( A ) - END FUNCTION Constructor7 -``` - -Description - -Type-4 - -Interface - -```fortran - FUNCTION Constructor8( A, VoigtType ) - USE Voigt - TYPE( Tensor_ ) :: Constructor8 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType - - - Error_Flag = .FALSE. - CALL Constructor8%Initiate( A, VoigtType ) - - CALL Check_Error( & - "Tensor_Class.F90>>Constructor.part>>Constructor8()", & - "TraceBack ---> CALL Constructor8%Initiate( A, VoigtType )" & - ) - END FUNCTION Constructor8 -``` - -Description - -Type-5 - -Interface - -```fortran - FUNCTION Constructor9( obj ) - TYPE( Tensor_ ) :: Constructor9 - CLASS( Tensor_ ), INTENT( IN ) :: obj - - CALL Constructor9%Initiate( obj ) - END FUNCTION Constructor9 -``` - -Description - -### getNSD( ) - -Interface - -```fortran - INTEGER( I4B ) FUNCTION getNSD( obj ) - CLASS( Tensor_ ), INTENT( IN ) :: obj - getNSD = obj%NSD - END FUNCTION getNSD -``` - -### getTensor - -Type-1 - -```fortran - SUBROUTINE getTensor_1( obj, T ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( INOUT ) :: T - - Error_Flag = .FALSE. - - IF( .NOT. obj%isInitiated( ) ) THEN - CALL Err_Msg( & - "Tensor_Class.F90>>getTensor_1.part", & - "getTensor_1()", & - "Tensor obj is Not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED( T ) ) DEALLOCATE( T ) - T = obj%T - -END SUBROUTINE getTensor_1 -``` - -Type-2 - -```fortran - SUBROUTINE getTensor_2( obj, Vec, VoigtType ) - USE Voigt - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, DIMENSION( : ), INTENT( INOUT ) :: Vec - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType -``` - -Description - -If `obj%NSD` is 2 then `Vec` has length 4. Note that `Vec` is reallocated by the routine. - -Type-3 - -```fortran - SUBROUTINE getTensor_3( T, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: T -``` - -> This subroutine is used for overloading the assignment operator. Now we can obtain the value using `Mat = obj`. - -## Operator Overloading ( * ) - -Type-1 - -```fortran - FUNCTION TensorTimesScalar_1( obj, Scalar ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_1 -``` - -`obj * 2.0_DFP` returns a (3,3) matrix. - -Type-2 - -```fortran - FUNCTION TensorTimesScalar_2( Scalar, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_2 -``` - -`2.0_DFP * obj` returns a (3,3) matrix. - -Type-3 - -```fortran - FUNCTION TensorTimesScalar_3( obj, Scalar ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_3 -``` - -`obj * 2` returns a (3,3) matrix. - -Type-4 - -```fortran - FUNCTION TensorTimesScalar_4( Scalar, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_4 -``` - -`2 * obj` returns a (3,3) matrix. - -Type-5 - -```fortran - FUNCTION TensorTimesTensor( obj, obj2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesTensor -``` - -`obj1 * obj2` perfoms element wise multiplication - -Type-6 - -```fortran - FUNCTION TensorTimesVector( obj, Vec ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: TensorTimesVector -``` - -`obj * Vec` returns array of length-3 after performing matrix vector multiplication. Symbolically, $w = T \cdot v$ - -Example - -```fortran -TENSOR = - - 1.000000 1.000000 1.000000 - 1.000000 1.000000 1.000000 - 1.000000 1.000000 1.000000 - -NSD = 3 - -Vec2 = T * Vec1 - 6.0000 6.0000 6.0000 - -Vec2 = T * [1.d0, 2.d0, 3.d0] - 6.0000 6.0000 6.0000 - -Vec1 = T * Vec1 - 6.0000 6.0000 6.0000 - -Vec2 = T * [1.d0, 2.d0] - 3.0000 3.0000 0.0000 - -Vec2 = T * [1.d0] - 1.0000 0.0000 0.0000 -``` - -Type-7 - -```fortran - FUNCTION VectorTimesTensor( Vec, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: VectorTimesTensor -``` - -`Vec * obj` returns array of length-3 after performing matrix vector multiplication. Symbolically $w = v \cdot T$ - -Example - -```fortran -TENSOR = - - 1.000000 2.000000 3.000000 - 1.000000 2.000000 3.000000 - 1.000000 2.000000 3.000000 - -NSD = 3 - -Vec2 = Vec1 * T - 6.0000 12.000 18.000 - -Vec2 = [1.d0, 2.d0, 3.d0] * T - 6.0000 12.000 18.000 - -Vec1 = Vec1 * T - 6.0000 12.000 18.000 - -Vec2 = [1.d0, 2.d0] * T - 3.0000 6.0000 0.0000 - -Vec2 = [1.d0] * T - 1.0000 0.0000 0.0000 -``` - -Type-8 - -```fortran - FUNCTION TensorTimesMat( obj, Mat ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesMat -``` - -Type-9 - -```fortran - FUNCTION MatTimesTensor( Mat, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: MatTimesTensor -``` - -### MatMul - -Type-1 - -```fortran - FUNCTION MatMul_1( obj, obj2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_1 -``` - -Type-2 - -```fortran - FUNCTION MatMul_2( obj, Mat2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_2 - -``` - -Type-3 - -```fortran - FUNCTION MatMul_3( Mat2, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_3 -``` - -Type-4 - -```fortran - FUNCTION VectorTimesTensor( Vec, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: VectorTimesTensor -``` - -Type-5 - -```fortran - FUNCTION TensorTimesVector( obj, Vec ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: TensorTimesVector -``` - -### Dyadic Product/Otimes - -Type-1 - -```fortran - FUNCTION Tensor_Dyadic_Tensor( obj, obj2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Tensor -``` - -Type-2 - -```fortran - FUNCTION Tensor_Dyadic_Mat( obj, Mat ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Mat -``` - -Type-3 - -```fortran - FUNCTION Mat_Dyadic_Tensor( Mat, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Dyadic_Tensor -``` - -> Note that .Otimes. always return a (6,6) matrix. If you want to use (4,4) or (3,3) matrix then use `Mat4_From_Mat6`, and `Mat3_From_Mat6` function. -> For Voigt represent of rank-2 tensor dyadic product both tensor must be symmetric. - -Examples - -```fortran - CALL T%FreeThePointer( T ) - - T => Rank2Tensor_Pointer( RESHAPE( [ & - 1.d0, 1.d0, 1.d0, & - 1.d0, 2.d0, 3.d0, & - 1.d0, 3.d0, 3.d0 & - ], & - [3,3] & - ) & - ) - - CALL T%Display( ) - - DummyMat = T .Otimes. T - - CALL Display_Array( DummyMat, "T .Otimes. T" ) - - DummyMat = T - CALL Display_Array( ( T .Otimes. DummyMat ), "T .Otimes. DummyMat " ) - - DummyMat = T .Otimes. DummyMat - CALL Display_Array( DummyMat, "DummyMat = T .Otimes. DummyMat " ) - - DummyMat = T - CALL Display_Array( ( DummyMat .Otimes. T ), "DummyMat .Otimes. T " ) -``` - -Resutls - -```fortran -TENSOR = - - 1.000000 1.000000 1.000000 - 1.000000 2.000000 3.000000 - 1.000000 3.000000 3.000000 - -NSD = 3 - - -T .Otimes. T= - - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - - -T .Otimes. DummyMat= - - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - - -DummyMat = T .Otimes. DummyMat= - - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - -DummyMat .Otimes. T= - - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 - 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 - 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 -``` - -Example of getting (4,4) array from (6,6) array - -```fortran - DummyMat = Mat4_From_Mat6( DummyMat .Otimes. T ) - CALL Display_Array( DummyMat, "DummyMat = Mat4_From_Mat6( DummyMat .Otimes. T ) ") -``` - -Result - -```fortran -DummyMat = Mat4_From_Mat6( DummyMat .Otimes. T )= - - 1.000000 2.000000 1.000000 3.000000 - 2.000000 4.000000 2.000000 6.000000 - 1.000000 2.000000 1.000000 3.000000 - 3.000000 6.000000 3.000000 9.000000 -``` - -### Transpose - -```fortran - FUNCTION Transpose_1( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: Transpose_1 -``` - -> Returns a (3,3) matrix. - -### Addition - -Type-1 - -```fortran - FUNCTION obj_Add_obj( obj, obj2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_obj - obj_Add_obj = obj%T + obj2%T - END FUNCTION obj_Add_obj -``` - -Example : `obj + obj2` - -Type-2 - -```fortran - FUNCTION obj_Add_Mat( obj, Mat ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Mat - obj_Add_Mat = obj%T + Mat - END FUNCTION obj_Add_Mat -``` - -Example: `obj + Mat` - -Type-3 - -```fortran - FUNCTION Mat_Add_obj( Mat, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Add_obj - Mat_Add_obj = obj%T + Mat - END FUNCTION Mat_Add_obj -``` - -Example: `Mat + obj` - -### Subtraction - -Type-1 - -```fortran - FUNCTION obj_Minus_obj( obj, obj2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_obj - obj_Minus_obj = obj%T - obj2%T - END FUNCTION obj_Minus_obj -``` - -Example : `obj - obj2` - -Type-2 - -```fortran - FUNCTION obj_Minus_Mat( obj, Mat ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Mat - obj_Minus_Mat = obj%T - Mat - END FUNCTION obj_Minus_Mat -``` - -Example: `obj - Mat` - -Type-3 - -```fortran - FUNCTION Mat_Minus_obj( Mat, obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Minus_obj - Mat_Minus_obj = obj%T - Mat - END FUNCTION Mat_Minus_obj -``` - -Example: `Mat - obj` - -## Vector Methods - -### VectorProduct - -Type-1 - -```fortran - FUNCTION VectorProduct2( u, v ) - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v - REAL( DFP ), DIMENSION( 3 ) :: VectorProduct2 -``` - -Description - -Computes $u \times v$ - -Type-2 - -```fortran - FUNCTION VectorProduct3( u, v, w ) - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w - REAL( DFP ), DIMENSION( 3 ) :: VectorProduct3 -``` - -Description - -Computes $u \times ( v \times w )$ - -### BoxProduct - -```fortran - REAL( DFP ) FUNCTION BoxProduct( u, v, w ) - USE Utility, ONLY: Det - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w -``` - -Description - -Computes $[u,v,w] = u \cdot (v \times w)$ - -Example - -```fortran - Vec1 = [1.d0, 2.d0, 0.d0] - Vec2 = [1.d0, 1.d0, 0.d0] - Vec3 = Vec1 .X. Vec2 - CALL Display_Array( Vec3, "Vec3 = Vec1 .X. Vec2 ") - CALL Display_Array( & - VectorProduct( Vec1, Vec2, Vec3 ), & - "VectorProduct( Vec1, Vec2, Vec3 )" & - ) - - CALL Display_Array( & - -Vec2 .x. Vec3 .x. Vec1, & - "-Vec2 .x. Vec3 .x. Vec1" & - ) - CALL Display_Array( [Box(Vec1, Vec2, Vec3)], "Box[V1, V2, V3] ") -``` - -### getAngle - -```Fortran - REAL( DFP ) FUNCTION getAngle( u, v ) - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v -``` - -Returns angle between two vectors - -Example - -```fortran - Vec1 = [1.d0, 0.d0, 0.d0] - Vec2 = [1.d0, 1.d0, 0.d0] - - CALL Display_Array( [Vec1.Angle.Vec2], "Vec1.Angle.Vec2") -``` - -### getProjection - -```fortran - FUNCTION getProjection( u, v ) - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v - REAL( DFP ), DIMENSION( 3 ) :: getProjection -``` - -Project u on v. New Operator is defined `u .ProjectOn. v`. - -Example - -```fortran - Vec1 = [1.d0, 0.d0, 0.d0] - Vec2 = [-1.d0, 1.d0, 0.d0] - - CALL T%FreeThePointer( T ) - T => Rank2Tensor_Pointer( RESHAPE( [ & - 1.d0, 1.d0, 1.d0, & - 2.d0, 2.d0, 2.d0, & - 3.d0, 3.d0, 3.d0 & - ], & - [3,3] & - ) & - ) - - CALL Display_Array( T*Vec2 .ProjectOn. Vec1, "T*Vec2 .ProjectOn. Vec1") -``` - -### UnitVector - -```fortran - FUNCTION UnitVector( u ) - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( 3 ) :: UnitVector -``` - -Returns the unit vector. - -### DotProduct - -```fortran - FUNCTION DotProduct( u, v ) - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v - REAL( DFP ) :: DotProduct - DotProduct = DOT_PRODUCT( u, v ) - END FUNCTION DotProduct -``` - -Returns the dot product, used for defining the operator `u .dot. v` - -Example - -```fortran - Vec1 = [1.d0, -1.d0, 0.d0] - Vec2 = [-1.d0, 1.d0, 0.d0] - dp = Vec1 .dot. Vec2 -``` - -### getNormalComponent - -```fortran - FUNCTION getNormalComponent( u, v ) - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v - REAL( DFP ), DIMENSION( 3 ) :: getNormalComponent - getNormalComponent = u - ( u .ProjectOn. v ) - END FUNCTION getNormalComponent -``` - -Returns component of `u` that is normal to `v`. New operator is defined `u .ComponentNormalTo. v` - -### getParallelComponent - -Alias of `getProjection` method. it is used to define a new operator `u .ComponentParallelTo. v`. - - -Example - -```fortran - Vec1 = [1.d0, 1.d0, 1.d0] - CALL Display_Array( Vec1, "Vec1 ") - - Vec2 = [1.d0, 0.d0, 0.d0] - CALL Display_Array( Vec2, "Vec2 ") - - Vec3 = Vec1 .ComponentParallelTo. Vec2 - CALL Display_Array( Vec3, "Vec3 = Vec1 .ComponentParallelTo. Vec2 ") - - Vec3 = Vec1 .ComponentNormalTo. Vec2 - CALL Display_Array( Vec3, "Vec3 = Vec1 .ComponentNormalTo. Vec2 ") - - Vec3 = (Vec1 .ComponentNormalTo. Vec2) + (Vec1 .ComponentParallelTo. Vec2) - CALL Display_Array( Vec3, & - " Vec3 = Vec1 .ComponentNormalTo. Vec2 + Vec1 .ComponentParallelTo. Vec2 ") -``` - -### Vector3D - -```fortran - FUNCTION Vector3D( u ) - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( 3 ) :: Vector3D - - Vector3D = 0.0_DFP - SELECT CASE( SIZE( u ) ) - CASE( 1 ) - Vector3D( 1 ) = u( 1 ) - CASE( 2 ) - Vector3D( 1 : 2 ) = u( 1 : 2 ) - CASE DEFAULT - Vector3D( 1: 3 ) = u( 1 : 3 ) - END SELECT - END FUNCTION Vector3D -``` - -### Vector2D - -```fortran - FUNCTION Vector2D( u ) - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( 2 ) :: Vector2D - Vector2D = 0.0_DFP - SELECT CASE( SIZE( U ) ) - CASE( 1 ) - Vector2D( 1 ) = U( 1 ) - CASE DEFAULT - Vector2D( 1: 2 ) = U( 1: 2 ) - END SELECT - END FUNCTION Vector2D -``` - -### Vector1D - -```fortran - FUNCTION Vector1D( u ) - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( 1 ) :: Vector1D - Vector1D( 1 ) = u( 1 ) - END FUNCTION Vector1D -``` - -> We have made BoxProduct, VectorProduct, Box, getAngle, getProjection, UnitVector, getParallelComponent, getNormalComponent, Vector2D, Vector3D, Vector1D public. These functions can be used as vector functions. -> In addition we have defined the OPERATOR( .X. ), OPERATOR( .Angle. ), OPERATOR( .ProjectOn. ), OPERATOR( .dot. ), OPERATOR( .ComponentParallelTo. ), OPERATOR( .ComponentNormalTo. ). - -## Tensor Decomposition - -### Symmetric Part - -Method - -```fortran - -``` - -Function - -```fortran - -``` - -### Symmetric Part - -Method - -```fortran - FUNCTION m_SymmetricPart( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_SymmetricPart - m_SymmetricPart = 0.5_DFP * ( obj%T + TRANSPOSE( obj%T ) ) - END FUNCTION m_SymmetricPart -``` - -Function - -```fortran - FUNCTION f_SymmetricPart( Mat ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: f_SymmetricPart - f_SymmetricPart = 0.5_DFP * ( Mat + TRANSPOSE( Mat ) ) - END FUNCTION f_SymmetricPart -``` - -### AntiSymmetric Part - -Method - -```fortran - FUNCTION m_AntiSymmetricPart( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_AntiSymmetricPart - m_AntiSymmetricPart = 0.5_DFP * ( obj%T - TRANSPOSE( obj%T ) ) - END FUNCTION m_AntiSymmetricPart -``` - -Function - -```fortran - FUNCTION f_AntiSymmetricPart( Mat ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: & - f_AntiSymmetricPart - f_AntiSymmetricPart = 0.5_DFP * ( Mat - TRANSPOSE( Mat ) ) - END FUNCTION f_AntiSymmetricPart -``` - -### Hydrostatic Part - -Method - -```fortran - FUNCTION m_HydrostaticPart( obj ) - USE Utility, ONLY : Eye - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_HydrostaticPart - m_HydrostaticPart = Trace( obj ) * Eye( 3 ) / 3 - END FUNCTION m_HydrostaticPart -``` - -Function - -```fortran - FUNCTION f_HydrostaticPart( Mat ) - USE Utility, ONLY : Eye - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: f_HydrostaticPart - f_HydrostaticPart = Trace( Mat ) * Eye( 3 ) / 3 - END FUNCTION f_HydrostaticPart -``` - -### Deviatoric Part - -Method - -```fortran - FUNCTION m_DeviatoricPart( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_DeviatoricPart - - m_DeviatoricPart = obj%T - HydrostaticPart( obj ) -``` - -Function - -```fortran - FUNCTION f_DeviatoricPart( Mat ) - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: f_DeviatoricPart - f_DeviatoricPart = Mat - HydrostaticPart( Mat ) - END FUNCTION f_DeviatoricPart -``` - -## Invariants - -### Trace - -Method - -```fortran -I = obj%Trace( ) -``` - -Returns the trace of Tensor object. - -Module Function - -```fortran -I = Trace( T ) -``` - -Returns the trace of fortran array `T`. - -### Double_DotProduct - -There is a generic method _Double\_DotProduct_ and module-function called _Double\_DotProduct_. Therefore you can use this function e.g. `real_val = obj%Double_DotProduct( ... )` as a method as well as a module-function `real_val = Double_DotProduct()`. - -Type-1 - -```fortran - REAL( DFP ) FUNCTION DoubleDot_Product1( obj, obj2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - DoubleDot_Product1 = SUM( obj * obj2 ) - END FUNCTION DoubleDot_Product1 -``` - -Type-2 - -```fortran - REAL( DFP ) FUNCTION DoubleDot_Product2( obj, A ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A - DoubleDot_Product2 = SUM( obj * A ) - END FUNCTION DoubleDot_Product2 -``` - -Type-3 - -```fortran - REAL( DFP ) FUNCTION DoubleDot_Product3( A, B ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, B - DoubleDot_Product3 = SUM( A * B ) - END FUNCTION DoubleDot_Product3 -``` - -Type-4 - -```fortran - REAL( DFP ) FUNCTION DoubleDot_Product4( obj, A, VoigtType ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType - - TYPE( Rank2Tensor_ ) :: T - T = Rank2Tensor( A, VoigtType ) - DoubleDot_Product4 = SUM( T*obj ) - - CALL T%Deallocate( ) - - END FUNCTION DoubleDot_Product4 -``` - -Type-5 - -```fortran - REAL( DFP ) FUNCTION DoubleDot_Product5( A, B, VoigtType ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: B - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType - - TYPE( Rank2Tensor_ ) :: T - T = Rank2Tensor( B, VoigtType ) - DoubleDot_Product5 = SUM( T * A ) - CALL T%Deallocate( ) - END FUNCTION DoubleDot_Product5 -``` - -Type-6 - -```fortran - REAL( DFP ) FUNCTION DoubleDot_Product6( A, VoigtType_A, B, VoigtType_B ) - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A, B - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType_A, VoigtType_B - TYPE( Rank2Tensor_ ) :: T1, T2 - T1 = Rank2Tensor( A, VoigtType_A ) - T2 = Rank2Tensor( B, VoigtType_B ) - DoubleDot_Product6 = SUM( T1 * T2 ) - CALL T1%Deallocate( ) - CALL T2%Deallocate( ) - END FUNCTION DoubleDot_Product6 -``` - -We have also defined two operators called `.DoubleDot.` and `.Contraction.` - -Use of `.DoubleDot.` operator. - -- `obj .DoubleDot. obj` returns scalar -- `obj .DoubleDot. Mat` returns scalar -- `Mat .DoubleDot. obj` returns scalar -- `Mat .DoubleDot. Mat` returns scalar - -Use of `.Contraction.` operator. - -- `obj .Contraction. obj` returns scalar -- `obj .Contraction. Mat` returns scalar -- `Mat .Contraction. obj` returns scalar -- `Mat .Contraction. Mat` returns scalar -- `Mat .Contraction. Mat` returns scalar -- `Mat .Contraction. Vec` returns vector -- `Mat .Contraction. Vec` returns vector $T \cdot v$ -- `Vec .Contraction. Mat` returns vector $T^T \cdot v$ - -### Invariant I1 - -$$I_1 = Trace( T )$$ - -There are methods as well as module-function for this. - -Method - -```fortran -obj%Invariant_I1( ) -``` - -Module-function - -```fortran -Invariant_I1( obj ) -Invariant_I1( Mat ) -``` - -### Invariant I2 - -$$I_2 = \frac{1}{2} \Big [ Trace^2( T ) - Trace( T^2 ) \Big ]$$ - -There are methods as well as module-function for this. - -Method - -```fortran -obj%Invariant_I2( ) -``` - -Module-function - -```fortran -Invariant_I2( obj ) -Invariant_I2( Mat ) -``` - -### Invariant I3 - -$$I_3 = \det{T}$$ - -There are methods as well as module-function for this. - -Method - -```fortran -obj%Invaria3t_I2( ) -``` - -Module-function - -```fortran -Invariant_I3( obj ) -Invariant_I3( Mat ) -``` - -### Invariant J2 - -$$J_2 = \frac{1}{2} dev(T):dev(T)$$ - -Method - -```fortran - REAL( DFP ) FUNCTION m_Invariant_J2( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE :: S( :, : ) - IF( isDeviatoric( obj ) ) THEN - m_Invariant_J2 = 0.5_DFP * ( obj .Contraction. obj ) - ELSE - S = DeviatoricPart( obj ) - m_Invariant_J2 = 0.5_DFP * ( S .Contraction. S ) - END IF - IF( ALLOCATED( S ) ) DEALLOCATE( S ) - END FUNCTION m_Invariant_J2 -``` - -Module Function - -```fortran - REAL( DFP ) FUNCTION f_Invariant_J2( Mat ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), ALLOCATABLE :: S( :, : ) - IF( isDeviatoric( Mat ) ) THEN - f_Invariant_J2 = 0.5_DFP * ( Mat .Contraction. Mat ) - ELSE - S = DeviatoricPart( Mat ) - f_Invariant_J2 = 0.5_DFP * ( S .Contraction. S ) - END IF - IF( ALLOCATED( S ) ) DEALLOCATE( S ) - END FUNCTION f_Invariant_J2 -``` - -### Invariant J3 - -$$J_3 = \det( dev( T ) )$$ - -Method - -```fortran - REAL( DFP ) FUNCTION m_Invariant_J3( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE :: S( :, : ) - IF( isDeviatoric( obj ) ) THEN - m_Invariant_J3 = Invariant_I3( obj ) - ELSE - S = DeviatoricPart( obj ) - m_Invariant_J3 = Invariant_I3( S ) - END IF - IF( ALLOCATED( S ) ) DEALLOCATE( S ) - END FUNCTION m_Invariant_J3 -``` - -Module Function - -```fortran - REAL( DFP ) FUNCTION f_Invariant_J3( Mat ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), ALLOCATABLE :: S( :, : ) - IF( isDeviatoric( Mat ) ) THEN - f_Invariant_J3 = Invariant_I3( Mat ) - ELSE - S = DeviatoricPart( Mat ) - f_Invariant_J3 = Invariant_I3( S ) - END IF - IF( ALLOCATED( S ) ) DEALLOCATE( S ) - END FUNCTION f_Invariant_J3 -``` - -### LodeAngle - -Type-1 - -```fortran - REAL( DFP ) f_LodeAngle_1( J2, J3, LodeAngleType ) - REAL( DFP ), INTENT( IN ) :: J2, J3 - CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType - REAL( DFP ) :: Dummy - - IF( J2 .EQ. 0.0_DFP ) THEN - f_LodeAngle_1 = 0.0_DFP - RETURN - END IF - - Dummy = 1.5_DFP * SQRT( 3.0_DFP ) * J3 / J2 / SQRT( J2 ) - - IF( Dummy .GE. 1.0_DFP ) Dummy = 1.0_DFP - IF( Dummy .LE. -1.0_DFP ) Dummy = -1.0_DFP - - SELECT CASE( TRIM( LodeAngleType ) ) - CASE( "SIN", "SINE", "Sin", "Sine", "sine", "sin" ) - f_LodeAngle_1 = ASIN( -Dummy ) / 3.0_DFP - CASE DEFAULT - f_LodeAngle_1 = ACOS( Dummy ) / 3.0_DFP - END SELECT - END FUNCTION f_LodeAngle_1 - -``` - -Type-2 - -```fortran - REAL( DFP ) m_LodeAngle( obj, LodeAngleType ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType - - REAL( DFP ) :: J2, J3 - J2 = Invariant_J2( obj ) - J3 = Invariant_J3( obj ) - m_LodeAngle = f_LodeAngle_1( J2, J3, LodeAngleType ) - END FUNCTION m_LodeAngle -``` - -Type-3 - -```fortran - REAL( DFP ) f_LodeAngle_2( Mat, LodeAngleType ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType - - REAL( DFP ) :: J2, J3 - J2 = Invariant_J2( Mat ) - J3 = Invariant_J3( Mat ) - f_LodeAngle_2 = f_LodeAngle_1( J2, J3, LodeAngleType ) - END FUNCTION f_LodeAngle_2 -``` - -## PullBack - -Type-1 - -```fortran - FUNCTION f_Rank2PullBack_1( T, F, indx1, indx2 ) - USE Utility, ONLY: det, INV - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: T, F - REAL( DFP ), DIMENSION( SIZE( T, 1 ), SIZE( T, 2 ) ) :: f_Rank2PullBack_1 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 -``` - -Description - -To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. - -Type-2 - -```fortran - FUNCTION f_Rank2PullBack_2( T, obj, indx1, indx2 ) - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: T - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: f_Rank2PullBack_2 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - - REAL( DFP ), ALLOCATABLE :: F( :, :) - - F = obj - - f_Rank2PullBack_2 = f_Rank2PullBack_1( T, F, indx1, indx2 ) - - DEALLOCATE( F ) - - END FUNCTION f_Rank2PullBack_2 -``` - -Type-3 - -```fortran - FUNCTION m_Rank2PullBack_1( obj, F, indx1, indx2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: F - REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PullBack_1 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - - REAL( DFP ), ALLOCATABLE :: T( :, : ) - T = obj - m_Rank2PullBack_1 = f_Rank2PullBack_1( T, F, indx1, indx2 ) - END FUNCTION m_Rank2PullBack_1 -``` - -Description - -To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. - -Type-4 - -```fortran - FUNCTION m_Rank2PullBack_2( obj, obj2, indx1, indx2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PullBack_2 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - - REAL( DFP ), ALLOCATABLE :: T( :, : ), F - T = obj - F = obj2 - m_Rank2PullBack_2 = f_Rank2PullBack_1( T, F, indx1, indx2 ) - END FUNCTION m_Rank2PullBack_2 -``` - -Description - -To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. - -Type-5 - -```fortran - FUNCTION f_VecPullBack_1( Vec, F, indx1 ) - USE Utility, ONLY: det, INV - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F - REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: f_VecPullBack_1 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1 -``` - -Type-6 - -```fortran - FUNCTION f_VecPullBack_2( Vec, obj, indx1 ) - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: Vec - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3 ) :: f_VecPullBack_2 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1 - - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: F - - F = obj - f_VecPullBack_2 = f_VecPullBack_1( Vec, F, indx1 ) - DEALLOCATE( F ) - - END FUNCTION f_VecPullBack_2 -``` - -## PushForward - -Type-1 - -```fortran - FUNCTION f_Rank2PushForward_1( T, F, indx1, indx2 ) - USE Utility, ONLY: det, INV - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: T, F - REAL( DFP ), DIMENSION( SIZE( T, 1 ), SIZE( T, 2 ) ) :: f_Rank2PushForward_1 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 -``` - -Description - -To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. - -Type-2 - -```fortran - FUNCTION f_Rank2PushForward_2( T, obj, indx1, indx2 ) - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: T - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: f_Rank2PushForward_2 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - - REAL( DFP ), ALLOCATABLE :: F( :, :) - - F = obj - - f_Rank2PushForward_2 = f_Rank2PushForward_1( T, F, indx1, indx2 ) - - DEALLOCATE( F ) - - END FUNCTION f_Rank2PushForward_2 -``` - -Type-3 - -```fortran - FUNCTION m_Rank2PushForward_1( obj, F, indx1, indx2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: F - REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PushForward_1 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - - REAL( DFP ), ALLOCATABLE :: T( :, : ) - T = obj - m_Rank2PushForward_1 = f_Rank2PushForward_1( T, F, indx1, indx2 ) - END FUNCTION m_Rank2PushForward_1 -``` - -Description - -To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. - -Type-4 - -```fortran - FUNCTION m_Rank2PushForward_2( obj, obj2, indx1, indx2 ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PushForward_2 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 - - REAL( DFP ), ALLOCATABLE :: T( :, : ), F - T = obj - F = obj2 - m_Rank2PushForward_2 = f_Rank2PushForward_1( T, F, indx1, indx2 ) - END FUNCTION m_Rank2PushForward_2 -``` - -Description - -To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. - -Type-5 - -```fortran - FUNCTION f_VecPushForward_1( Vec, F, indx1 ) - USE Utility, ONLY: det, INV - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F - REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: f_VecPushForward_1 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1 -``` - -Type-6 - -```fortran - FUNCTION f_VecPushForward_2( Vec, obj, indx1 ) - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: Vec - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3 ) :: f_VecPushForward_2 - CHARACTER( LEN = * ), INTENT( IN ) :: indx1 - - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: F - - F = obj - f_VecPushForward_2 = f_VecPushForward_1( Vec, F, indx1 ) - DEALLOCATE( F ) - - END FUNCTION f_VecPushForward_2 -``` - -## Spectral Decomposition - -### Eigens - -Type-1 - -```fortran - SUBROUTINE f_Eigens( Mat, EigenVectors, EigenValues ) -!. . . . . . . . . . . . . . . . . . . . -! 1. Eigen values are computed using DGEEV( ) subroutine of -! lapack libarary. -! 2. EigenValues( :, 2 ) has two columns, the first column denotes -! the real value of eigen value and second column denotes the -! imaginary/complex value of eigenvalue. The conjugate values -! are put next to each other. With positive imaginary value -! put first. -! 3. If j-th eigen value is imaginary then j-th and j+1 th Eigenvectors -! are given by -! v(j) = EigenVectors( :, j ) + i * EigenVectors( :, j +1 ) -! v(j+1) = EigenVectors( :, j ) - i * EigenVectors( :, j +1 ) -! -! 4. DGEEV function from lapack library has been used. -!. . . . . . . . . . . . . . . . . . . . - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: EigenValues( :, : ), & - EigenVectors( :, : ) -``` - -Type-2 - -```fortran - SUBROUTINE m_Eigens( obj, EigenVectors, EigenValues ) -!. . . . . . . . . . . . . . . . . . . . -! 1. Eigen values are computed using DGEEV( ) subroutine of -! lapack libarary. -! 2. EigenValues( :, 2 ) has two columns, the first column denotes -! the real value of eigen value and second column denotes the -! imaginary/complex value of eigenvalue. The conjugate values -! are put next to each other. With positive imaginary value -! put first. -! 3. If j-th eigen value is imaginary then j-th and j+1 th Eigenvectors -! are given by -! v(j) = EigenVectors( :, j ) + i * EigenVectors( :, j +1 ) -! v(j+1) = EigenVectors( :, j ) - i * EigenVectors( :, j +1 ) -!. . . . . . . . . . . . . . . . . . . . - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: EigenValues( :, : ), & - EigenVectors( :, : ) -``` - -Example - -```fortran -CALL Tensor_Eigens( Mat, EigenVectors, EigenValues ) -CALL Tensor_Eigens( obj, EigenVectors, EigenValues ) -CALL obj%Eigens( EigenVectors, EigenValues ) -``` - -### Principal Value - -Type-1 - -```fortran -REAL( DFP ) FUNCTION f_PrincipalValue_1( Mat ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), ALLOCATABLE :: EigenVectors( :, : ), EigenValues( :, : ) - CALL f_Eigens( Mat, EigenVectors, EigenValues ) - f_PrincipalValue_1 = MAXVAL( EigenValues( :, 1 ) ) - DEALLOCATE( EigenValues, EigenVectors ) -END FUNCTION f_PrincipalValue_1 -``` - -Description - -Returns the max( Real( eigenvalue ) ) - -Type-2 - -```fortran -REAL( DFP ) FUNCTION m_PrincipalValue_1( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE :: EigenVectors( :, : ), EigenValues( :, : ) - CALL m_Eigens( obj, EigenVectors, EigenValues ) - m_PrincipalValue_1 = MAXVAL( Eigenvalues( :, 1 ) ) - DEALLOCATE( EigenValues, EigenVectors ) -END FUNCTION m_PrincipalValue_1 -``` - -Exam - -### Spectral Radius - -Type-1 - -```fortran -REAL( DFP ) FUNCTION f_SpectralRadius_1( Mat ) - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - - REAL( DFP ), ALLOCATABLE :: EigenVectors( :, : ), EigenValues( :, : ) - COMPLEX( DFP ), ALLOCATABLE :: Lambda( :, : ) - INTEGER( I4B ) :: N - - CALL f_Eigens( Mat, EigenVectors, EigenValues ) - f_SpectralRadius_1 = MAXVAL( EigenValues( :, 1 ) ) - N = SIZE( Eigenvalues, 1 ) - ALLOCATE( Lambda( N ) ) - Lambda( 1 : N ) = CMPLX( EigenValues( 1 : N, 1 ), EigenValues( 1 : N, 2 ) ) - EigenValues = MAXVAL( ABS( Lambda ) ) - DEALLOCATE( EigenValues, EigenVectors, Lambda ) - -END FUNCTION f_SpectralRadius_1 -``` - -Description - -Returns the max( Real( eigenvalue ) ) - -Type-2 - -```fortran -REAL( DFP ) FUNCTION m_SpectralRadius_1( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - - REAL( DFP ), ALLOCATABLE :: Mat( :, : ) - Mat = obj - m_SpectralRadius_1 = f_SpectralRadius_1( Mat ) - DEALLOCATE( Mat ) -END FUNCTION m_SpectralRadius_1 -``` - -Description - -Returns the max( Real( eigenvalue ) ) - -## Polar Decomposition - -Type-1 - -```fortran - SUBROUTINE f_getPolarDecomp_1( Mat, R, H, PDType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Ref: Higham and Noferini, 2015 Algorithm 3.1 for NSD = 3 -! 2. PDType = "Right", "U", "Left", "V", "RU", "VR" -! 3. Mat = RU = VR, Therefore H denotes either U or V -! 4. RU is called "Right" polar decomposition and VR is called left -! polar decomposition -!. . . . . . . . . . . . . . . . . . . . - - USE LinearAlgebra, ONLY: GetSymEigenJacobiacobi - USE Utility, ONLY: IMAXLOC, INV - - ! Define intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: R - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: H - CHARACTER( LEN = * ), INTENT( IN ) :: PDType -``` - -Type-2 - -```fortran - SUBROUTINE m_getPolarDecomp_1( obj, R, H, PDType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Ref: Higham and Noferini, 2015 Algorithm 3.1 for NSD = 3 -! 2. PDType = "Right", "U", "Left", "V", "RU", "VR" -! 3. Mat = RU = VR, Therefore H denotes either U or V -! 4. RU is called "Right" polar decomposition and VR is called left -! polar decomposition -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: R - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: H - CHARACTER( LEN = * ), INTENT( IN ) :: PDType -``` - -### Rotation Part - -Type-1 - -```fortran - FUNCTION f_getRotationPart( Mat ) - USE LinearAlgebra, ONLY: GetSymEigenJacobi - USE Utility, ONLY: IMAXLOC, INV - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: f_getRotationPart -``` - -Type-2 - -```fortran - FUNCTION m_getRotationPart( obj ) - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_getRotationPart - REAL( DFP ), ALLOCATABLE :: Mat( :, : ) - Mat = obj - m_getRotationPart = f_getRotationPart( Mat ) - DEALLOCATE( Mat ) - END FUNCTION m_getRotationPart -``` - diff --git a/src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part b/src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part deleted file mode 100755 index 608afbb28..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part +++ /dev/null @@ -1,518 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Rank4Tensors.part -! Last Update : September-10-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of module -! -! Info:: - This part contains isotropic tensors of Rank-1, Rank-2, Rank-3 -! and Rank-4 -! -! Hosting File - Tensor.F90 -! -!============================================================================== -! -! List of items -! -!------------------------------------------------------------------------------ -! DiracDelta -!------------------------------------------------------------------------------ -! - INTEGER(I4B) FUNCTION DiracDelta( i, j ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-2 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j -! - Error_Flag = .FALSE. - - IF( i .EQ. j ) THEN - DiracDelta = 1 - ELSE - DiracDelta = 0 - END IF -! - END FUNCTION DiracDelta -! -!------------------------------------------------------------------------------ -! LeviCivita -!------------------------------------------------------------------------------ -! - INTEGER(I4B) FUNCTION LeviCivita( i, j, k ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-3 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j, k -! - Error_Flag = .FALSE. - - LeviCivita = ( i - j ) * ( j - k ) * ( k - i ) / 2 -! - END FUNCTION LeviCivita -! -!------------------------------------------------------------------------------ -! ISO4 -!------------------------------------------------------------------------------ -! - REAL(DFP) FUNCTION ISO4( lambda, mu, i, j, k, l ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-4 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j, k, l - REAL( DFP ), INTENT( IN ) :: lambda, mu -! - Error_Flag = .FALSE. - - ISO4 = lambda * DiracDelta( i, j ) * DiracDelta( k, l ) & - + mu * ( DiracDelta( i, k ) * DiracDelta( j, l ) & - + DiracDelta( i, l ) * DiracDelta( j, k ) ) -! - END FUNCTION ISO4 -! -!------------------------------------------------------------------------------ -! TraceISO4 -!------------------------------------------------------------------------------ -! - REAL(DFP) FUNCTION TraceISO4( i, j, k, l ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-3 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j, k, l -! - Error_Flag = .FALSE. - TraceISO4 = DiracDelta( i, j ) * DiracDelta( k, l ) -! - END FUNCTION TraceISO4 -! -!------------------------------------------------------------------------------ -! IdentityISO4 -!------------------------------------------------------------------------------ -! - REAL(DFP) FUNCTION IdentityISO4( i, j, k, l ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-3 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j, k, l -! - Error_Flag = .FALSE. - IdentityISO4 = DiracDelta( i, k ) * DiracDelta( j, l ) -! - END FUNCTION IdentityISO4 -! -!------------------------------------------------------------------------------ -! TransposeISO4 -!------------------------------------------------------------------------------ -! - REAL(DFP) FUNCTION TransposeISO4( i, j, k, l ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-3 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j, k, l -! - Error_Flag = .FALSE. - TransposeISO4 = DiracDelta( i, l ) * DiracDelta( j, k ) -! - END FUNCTION TransposeISO4 -! -!------------------------------------------------------------------------------ -! SymISO4 -!------------------------------------------------------------------------------ -! - REAL(DFP) FUNCTION SymISO4( i, j, k, l ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-3 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j, k, l -! - Error_Flag = .FALSE. - SymISO4 = 0.5_DFP * ( IdentityISO4( i, j, k, l ) + TransposeISO4( i,j,k,l )) -! - END FUNCTION SymISO4 -! -!------------------------------------------------------------------------------ -! AntiSymISO4 -!------------------------------------------------------------------------------ -! - REAL(DFP) FUNCTION AntiSymISO4( i, j, k, l ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - IsotropicTensors Rank-3 -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: i, j, k, l -! - Error_Flag = .FALSE. - AntiSymISO4 = 0.5_DFP * ( IdentityISO4( i, j, k, l ) & - - TransposeISO4( i, j, k, l ) ) -! - END FUNCTION AntiSymISO4 -! -!------------------------------------------------------------------------------ -! VoigtMatTraceISO4 -!------------------------------------------------------------------------------ -! - FUNCTION VoigtMatTraceISO4( N ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), DIMENSION( N, N ) :: VoigtMatTraceISO4 -! - Error_Flag = .FALSE. - VoigtMatTraceISO4 = 0.0_DFP - SELECT CASE( N ) - CASE( 6 ) - VoigtMatTraceISO4( 1 : 3, 1 : 3 ) = 1.0_DFP - CASE( 4 ) - VoigtMatTraceISO4( 1 : 2, 1 : 2 ) = 1.0_DFP - VoigtMatTraceISO4( 4, 4 ) = 1.0_DFP - VoigtMatTraceISO4( 1, 4 ) = 1.0_DFP - VoigtMatTraceISO4( 4, 1 ) = 1.0_DFP - VoigtMatTraceISO4( 4, 2 ) = 1.0_DFP - CASE( 3 ) - VoigtMatTraceISO4( 1 : 2, 1 : 2 ) = 1.0_DFP - CASE( 1 ) - VoigtMatTraceISO4( 1, 1 ) =1.0_DFP - CASE DEFAULT - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "VoigtMatTraceISO4(), Flag-1", "Unknown N" ) - Error_Flag = .TRUE. - RETURN - END SELECT -! - END FUNCTION VoigtMatTraceISO4 -! -!------------------------------------------------------------------------------ -! VoigtMatIdentityISO4 -!------------------------------------------------------------------------------ -! - FUNCTION VoigtMatIdentityISO4( N ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), DIMENSION( N, N ) :: VoigtMatIdentityISO4 -! - VoigtMatIdentityISO4 = 0.0_DFP - Error_Flag = .FALSE. - SELECT CASE( N ) - CASE( 6 ) - VoigtMatIdentityISO4( 1, 1 ) = 1.0_DFP - VoigtMatIdentityISO4( 2, 2 ) = 1.0_DFP - VoigtMatIdentityISO4( 3, 3 ) = 1.0_DFP - VoigtMatIdentityISO4( 4, 4 ) = 1.0_DFP - VoigtMatIdentityISO4( 5, 5 ) = 1.0_DFP - VoigtMatIdentityISO4( 6, 6 ) = 1.0_DFP - CASE( 4 ) - VoigtMatIdentityISO4( 1, 1 ) = 1.0_DFP - VoigtMatIdentityISO4( 2, 2 ) = 1.0_DFP - VoigtMatIdentityISO4( 3, 3 ) = 1.0_DFP - VoigtMatIdentityISO4( 4, 4 ) = 1.0_DFP - CASE( 3 ) - VoigtMatIdentityISO4( 1, 1 ) = 1.0_DFP - VoigtMatIdentityISO4( 2, 2 ) = 1.0_DFP - VoigtMatIdentityISO4( 3, 3 ) = 1.0_DFP - CASE( 1 ) - VoigtMatIdentityISO4( 1, 1 ) =1.0_DFP - CASE DEFAULT - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "VoigtMatIdentityISO4(), Flag-1", "Unknown N" ) - Error_Flag = .TRUE. - RETURN - END SELECT -! - END FUNCTION VoigtMatIdentityISO4 -! -!------------------------------------------------------------------------------ -! VoigtMatTransposeISO4 -!------------------------------------------------------------------------------ -! - FUNCTION VoigtMatTransposeISO4( N ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), DIMENSION( N, N ) :: VoigtMatTransposeISO4 -! - VoigtMatTransposeISO4 = 0.0_DFP - Error_Flag = .FALSE. - SELECT CASE( N ) - CASE( 6 ) - VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP - VoigtMatTransposeISO4( 2, 2 ) = 1.0_DFP - VoigtMatTransposeISO4( 3, 3 ) = 1.0_DFP - CASE( 4 ) - VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP - VoigtMatTransposeISO4( 2, 2 ) = 1.0_DFP - VoigtMatTransposeISO4( 4, 4 ) = 1.0_DFP - CASE( 3 ) - VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP - VoigtMatTransposeISO4( 2, 2 ) = 1.0_DFP - CASE( 1 ) - VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP - CASE DEFAULT - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "VoigtMatTransposeISO4(), Flag-1", "Unknown N" ) - Error_Flag = .TRUE. - RETURN - END SELECT -! - END FUNCTION VoigtMatTransposeISO4 -! -!------------------------------------------------------------------------------ -! VoigtMatSymISO4 -!------------------------------------------------------------------------------ -! - FUNCTION VoigtMatSymISO4( N ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), DIMENSION( N, N ) :: VoigtMatSymISO4 -! - VoigtMatSymISO4 = 0.0_DFP - Error_Flag = .FALSE. - SELECT CASE( N ) - CASE( 6 ) - VoigtMatSymISO4( 1, 1 ) = 1.0_DFP - VoigtMatSymISO4( 2, 2 ) = 1.0_DFP - VoigtMatSymISO4( 3, 3 ) = 1.0_DFP - VoigtMatSymISO4( 4, 4 ) = 0.5_DFP - VoigtMatSymISO4( 5, 5 ) = 0.5_DFP - VoigtMatSymISO4( 6, 6 ) = 0.5_DFP - CASE( 4 ) - VoigtMatSymISO4( 1, 1 ) = 1.0_DFP - VoigtMatSymISO4( 2, 2 ) = 1.0_DFP - VoigtMatSymISO4( 4, 4 ) = 1.0_DFP - VoigtMatSymISO4( 3, 3 ) = 0.5_DFP - CASE( 3 ) - VoigtMatSymISO4( 1, 1 ) = 1.0_DFP - VoigtMatSymISO4( 2, 2 ) = 1.0_DFP - VoigtMatSymISO4( 3, 3 ) = 0.5_DFP - CASE( 1 ) - VoigtMatSymISO4( 1, 1 ) = 1.0_DFP - CASE DEFAULT - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "VoigtMatSymISO4(), Flag-1", "Unknown N" ) - Error_Flag = .TRUE. - RETURN - END SELECT -! - END FUNCTION VoigtMatSymISO4 -! -!------------------------------------------------------------------------------ -! VoigtMatAntiSymISO4 -!------------------------------------------------------------------------------ -! - FUNCTION VoigtMatAntiSymISO4( N ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - -! -!------------------------------------------------------------------------------ -! -! Define Intent of dummy variables - INTEGER( I4B ), INTENT( IN ) :: N - REAL( DFP ), DIMENSION( N, N ) :: VoigtMatAntiSymISO4 -! - VoigtMatAntiSymISO4 = 0.0_DFP - Error_Flag = .FALSE. -! - SELECT CASE( N ) - CASE( 6 ) - VoigtMatAntiSymISO4( 4, 4 ) = 0.5_DFP - VoigtMatAntiSymISO4( 5, 5 ) = 0.5_DFP - VoigtMatAntiSymISO4( 6, 6 ) = 0.5_DFP - CASE( 4 ) - VoigtMatAntiSymISO4( 3, 3 ) = 0.5_DFP - CASE( 3 ) - - CASE( 1 ) - - CASE DEFAULT - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "VoigtMatAntiSymISO4(), Flag-1", "Unknown N" ) - Error_Flag = .TRUE. - RETURN - END SELECT -! - END FUNCTION VoigtMatAntiSymISO4 -! -!------------------------------------------------------------------------------ -! MatTriadMat -!------------------------------------------------------------------------------ -! -SUBROUTINE MatTriadMat( C, A, B, TriadType ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - C = A Triad B -! - TriadType = "NA", "UPBar", "DownBar", "UpTilde", "DownTilde" -! -!------------------------------------------------------------------------------ -! - USE Utility, ONLY : Assert_Eq -! Define Intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, B - REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: TriadType -! -! Define internal variables - INTEGER( I4B ) :: N, II, JJ, i, j, k, l - INTEGER( I4B ), ALLOCATABLE, DIMENSION( :, : ) :: Indx - Error_Flag = .FALSE. - N = Assert_Eq( (/SIZE( A, 1 ), SIZE( A, 2 ), SIZE( B, 1 ), SIZE( B, 2 )/), & - "Tensor.F90>>Rank4Tensors.part>>MatTriadMat()") -! - SELECT CASE( N ) - CASE( 3 ) -! - ALLOCATE( Indx( 6, 2 ) ) - IndX( 1, 1 ) = 1; IndX( 1, 2 ) = 1 - IndX( 2, 1 ) = 2; IndX( 2, 2 ) = 2 - IndX( 3, 1 ) = 3; IndX( 3, 2 ) = 3 - IndX( 4, 1 ) = 1; IndX( 4, 2 ) = 2 - IndX( 5, 1 ) = 2; IndX( 5, 2 ) = 3 - IndX( 6, 1 ) = 1; IndX( 6, 2 ) = 3 -! - DO II = 1, 6 - i = Indx( II, 1 ); j = Indx( II, 2 ) - DO JJ = 1, 6 - k = Indx( JJ, 1 ); l = Indx( JJ, 2 ) - SELECT CASE( TRIM( TriadType ) ) - CASE( "NA", "Na", "na", "Default", "DEFAULT", " " ) - C( II, JJ ) = A( i, j ) * B( k, l ) - CASE( "BarUp", "UpBar", "BARUP", "UPBAR", "Bar_Up", "Up_Bar" ) - C( II, JJ ) = A( i, k ) * B( j, l ) - CASE( "BarDown", "DownBar", "BARDOWN", "DOWNBAR", "Bar_Down", & - "Down_Bar") - C( II, JJ ) = A( i, l ) * B( j, k ) - CASE DEFAULT -! Flag-1 - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "MatTriadMat( ), Flag-2", "Unknown TriadType" ) - Error_Flag = .TRUE. - RETURN - END SELECT - END DO - END DO - DEALLOCATE( Indx ) -! - CASE( 2 ) -! - ALLOCATE( Indx( 4, 2 ) ) - IndX( 1, 1 ) = 1; IndX( 1, 2 ) = 1 - IndX( 2, 1 ) = 2; IndX( 2, 2 ) = 2 - IndX( 3, 1 ) = 1; IndX( 3, 2 ) = 2 - IndX( 4, 1 ) = 3; IndX( 4, 2 ) = 3 -! - DO II = 1, 4 - i = Indx( II, 1 ); j = Indx( II, 2 ) - DO JJ = 1, 4 - k = Indx( JJ, 1 ); l = Indx( JJ, 2 ) - SELECT CASE( TRIM( TriadType ) ) - CASE( "NA", "Na", "na", "Default", "DEFAULT", " " ) - C( II, JJ ) = A( i, j ) * B( k, l ) - CASE( "BarUp", "UpBar", "BARUP", "UPBAR", "Bar_Up", "Up_Bar" ) - C( II, JJ ) = A( i, k ) * B( j, l ) - CASE( "BarDown", "DownBar", "BARDOWN", "DOWNBAR", "Bar_Down", & - "Down_Bar") - C( II, JJ ) = A( i, l ) * B( j, k ) - CASE( "TildeDown", "DownTilde", "TILDEDOWN", "DOWNTILDE", & - "Tilde_Down", "Down_Tilde") - C( II, JJ ) = A( i, l ) * B( k, j ) - CASE( "TildeUp", "UpTilde", "TILDEUP", "UPTILDE", & - "Tilde_Up", "Up_Tilde") - C( II, JJ ) = A( i, k ) * B( l, j ) - CASE DEFAULT -! Flag-2 - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "MatTriadMat( ), Flag-2", "Unknown TriadType" ) - Error_Flag = .TRUE. - RETURN - END SELECT - END DO - END DO - DEALLOCATE( Indx ) -! - CASE DEFAULT -! Flag-3 - CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & - "MatTriadMat( ), Flag-1", "Unknown N" ) - Error_Flag = .TRUE. - RETURN - END SELECT -! -END SUBROUTINE MatTriadMat -! -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part b/src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part deleted file mode 100755 index 985b4fbc3..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part +++ /dev/null @@ -1,349 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StrainMeasures.part -! Last Update : September-03-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Module -! -! Info:: - This module includes subroutine for computing various strain -! Measures -! -!============================================================================== -! -! List of items -! -! To Do:: Add subroutine for Seth-Hill General Strain Measures -! -! -!------------------------------------------------------------------------------ -! -! -!------------------------------------------------------------------------------ -! DeformationTensor -!------------------------------------------------------------------------------ -! - FUNCTION DeformationTensor( F, DefTensorType ) - ! - ! Description - !------------------------------------------------------------------------------ - ! 1. - This subroutine computes deformation tensor - ! - Right Cauchy Green Deformation Tensor C = F^T F - ! - Left Cauchy Green Deformation Tensro b = F F^T - ! - !------------------------------------------------------------------------------ - ! - USE Utility, ONLY: Inv - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F - REAL( DFP ), DIMENSION( SIZE( F, 1 ), SIZE( F, 2 ) ) :: DeformationTensor - CHARACTER( LEN = * ), INTENT( IN ) :: DefTensorType -! -! Define internal variables - REAL( DFP ), DIMENSION( SIZE( F, 1 ), SIZE( F, 2 ) ) :: DummyMat - Error_Flag = .FALSE. -! - SELECT CASE( TRIM( DefTensorType ) ) - CASE( "Right", "C", "right", "c" ) - DeformationTensor = MATMUL( TRANSPOSE( F ), F ) - CASE( "Left", "left", "b", "B" ) - DeformationTensor = MATMUL( F, TRANSPOSE( F ) ) - CASE( "BInv", "bInv", "binv", "Binv" ) - DummyMat = MATMUL( F, TRANSPOSE( F ) ) - CALL Inv( A = DummyMat, InvA = DeformationTensor ) -! Flag-1 - CASE DEFAULT - CALL Err_Msg( "Tensor.F90>>StrainMeasures.part", & - "DeformationTensor(), Flag-1", "Unknown Deformation Tensor Type" ) - Error_Flag = .TRUE. - RETURN - END SELECT -! - END FUNCTION DeformationTensor -! -!------------------------------------------------------------------------------ -! GreenStrainTensor -!------------------------------------------------------------------------------ -! - SUBROUTINE GreenStrainTensor( E, F, C, U ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - This subroutine computes deformation tensor -! - Right Cauchy Green Deformation Tensor C = F^T F -! - Left Cauchy Green Deformation Tensro b = F F^T -! -!------------------------------------------------------------------------------ -! - USE Utility, ONLY: Assert_Eq, Eye -! Define Intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F, C, U - REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: E - ! - ! Internal varible - INTEGER( I4B ) :: N - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: I - - Error_Flag = .FALSE. - - N = Assert_Eq( SIZE( E, 1 ), SIZE( E, 2 ), & - "Tensor.F90>>StrainMeasures.part" ) - - ALLOCATE( I( N, N ) ) - I = Eye( N ) - - IF( PRESENT( F ) ) THEN - E = 0.5_DFP * ( DeformationTensor( F, "C" ) - I ) - DEALLOCATE( I ) - RETURN - ELSE IF( PRESENT( C ) ) THEN - E = 0.5_DFP * ( C - I ) - DEALLOCATE( I ) - RETURN - ELSE IF( PRESENT( U ) ) THEN - E = 0.5*( MATMUL( U, U ) - I ) - DEALLOCATE( I ) - RETURN - ELSE -! Flag-1 - CALL Err_Msg( " Tensor.F90 >> StrainMeasures.part", & - "GreenStrainTensor(), Flag-1" , " Both C and F cannot be present") - Error_Flag = .TRUE. - DEALLOCATE( I ) - RETURN - END IF -! - END SUBROUTINE GreenStrainTensor -! -!------------------------------------------------------------------------------ -! AlmansiStrainTensor -!------------------------------------------------------------------------------ -! - SUBROUTINE AlmansiStrainTensor( e, F, B, bInv, V ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - This subroutine computes deformation tensor -! - Right Cauchy Green Deformation Tensor C = F^T F -! - Left Cauchy Green Deformation Tensro b = F F^T -! -!------------------------------------------------------------------------------ -! -USE Utility, ONLY: Assert_Eq, Eye, Inv -! Define Intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F, B, bInv, V - REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: e -! -! Internal varible - INTEGER( I4B ) :: N - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: I - - Error_Flag = .FALSE. - - N = Assert_Eq( SIZE( e, 1 ), SIZE( e, 2 ), & - "Tensor.F90>>StrainMeasures.part" ) - - ALLOCATE( I( N, N ) ) - - IF( PRESENT( F ) ) THEN - e = 0.5_DFP * ( I - DeformationTensor( F, "bInv" ) ) - DEALLOCATE( I ) - RETURN - ELSE IF ( PRESENT( B ) ) THEN - CALL INV ( A = B, INVA = I ) - e = -0.5_DFP * I - I = Eye( N ) - e = e + 0.5_DFP * I - DEALLOCATE( I ) - RETURN - ELSE IF ( PRESENT( bInv ) ) THEN - I = Eye( N ) - e = 0.5_DFP * ( I - bInv ) - DEALLOCATE( I ) - RETURN - ELSE IF( PRESENT( V ) ) THEN - CALL INV( A = V, INVA = I ) - e = -0.5_DFP*MATMUL( I, I ) - I = Eye( N ) - e = e + 0.5_DFP * I - DEALLOCATE( I ) - RETURN - ELSE -! Flag-1 - CALL Err_Msg( " Tensor.F90 >> StrainMeasures.part", & - "AlmansiStrainTensor(), Flag-1" , " Both B and F cannot be present") - Error_Flag = .TRUE. - DEALLOCATE( I ) - RETURN - END IF -! -END SUBROUTINE AlmansiStrainTensor -! -!------------------------------------------------------------------------------ -! StretchTensor -!------------------------------------------------------------------------------ -! - SUBROUTINE StretchTensor( C, B, F, U, V ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - This subroutine computes deformation tensor -! - Right Cauchy Green Deformation Tensor C = F^T F -! - Left Cauchy Green Deformation Tensro b = F F^T -! -!------------------------------------------------------------------------------ -! -USE LinearAlgebra, ONLY: GetSymEigenJacobi -USE Utility, ONLY: Put_Diag -! Define Intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( INOUT ), OPTIONAL :: F, B, C - REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ), OPTIONAL :: U, V -! -! Internal varible - REAL( DFP ), ALLOCATABLE :: EigenVals( : ), EigenVecs( :, : ), DummyMat(:,:) - - Error_Flag = .FALSE. -! - IF( PRESENT( U ) ) THEN -! - IF( PRESENT( F ) ) THEN - ALLOCATE( DummyMat( SIZE( F, 1 ), SIZE( F, 2 ) ) ) - DummyMat = 0.0_DFP - CALL getPolarDecomp( T = F, R = DummyMat, H = U, PDType = "U" ) - DEALLOCATE( DummyMat ) -! - ELSE IF( PRESENT( C ) ) THEN - ALLOCATE( DummyMat( SIZE( C, 1 ), SIZE( C, 2 ) ) ) - ALLOCATE( EigenVals( SIZE( C, 1 ) ) ) - ALLOCATE( EigenVecs( SIZE( C, 1 ), SIZE( C, 2 ) ) ) - DummyMat = 0.0_DFP -! Flag-1 - CALL GetSymEigenJacobi( Mat = C, EigenVals = EigenVals, & - EigenVecs = EigenVecs, MaxIter = 20 ) - CALL Check_Error( "Tensor.F90>>StrainMeasures.part", & - "StretchTensor(), Flag-1" ) -! - EigenVals( : ) = SQRT( EigenVals ( : ) ) -! - CALL Put_Diag( EigenVals, DummyMat ) -! - U = MATMUL( EigenVecs, & - MATMUL( DummyMat, TRANSPOSE( EigenVecs) ) ) - - DEALLOCATE( DummyMat, EigenVals, EigenVecs ) -! - ELSE - CALL Err_Msg( "Tensor.F90>>StrainMeasures.part", & - "StretchTensor(), Flag-2", & - "To Find U either F or C should be present") - END IF - END IF -! - IF( PRESENT( V ) ) THEN - IF( PRESENT( F ) ) THEN - ALLOCATE( DummyMat( SIZE( F, 1 ), SIZE( F, 2 ) ) ) - DummyMat = 0.0_DFP - CALL getPolarDecomp( T = F, R = DummyMat, H = V, PDType = "V" ) - DEALLOCATE( DummyMat ) -! - ELSE IF( PRESENT( B ) ) THEN - ALLOCATE( DummyMat( SIZE( B, 1 ), SIZE( B, 2 ) ) ) - ALLOCATE( EigenVals( SIZE( B, 1 ) ) ) - ALLOCATE( EigenVecs( SIZE( B, 1 ), SIZE( B, 2 ) ) ) - DummyMat = 0.0_DFP -! Flag-2 - CALL GetSymEigenJacobi( Mat = B, EigenVals = EigenVals, & - EigenVecs = EigenVecs, MaxIter = 20 ) - CALL Check_Error( " Tensor.F90>>StrainMeasures.part", & - "StretchTensor(), Flag-2" ) -! - EigenVals( : ) = SQRT( EigenVals ( : ) ) -! - CALL Put_Diag( EigenVals, DummyMat ) -! - V = MATMUL( EigenVecs, & - MATMUL( DummyMat, TRANSPOSE( EigenVecs) ) ) -! - DEALLOCATE( DummyMat, EigenVals, EigenVecs ) -!Flag-3 - ELSE - CALL Err_Msg( "Tensor.F90>>StrainMeasures.part", & - "StretchTensor(), Flag-3", & - "To Find V either F or B should be present") - END IF -! - END IF -! - END SUBROUTINE StretchTensor -! -!------------------------------------------------------------------------------ -! F_Distortional -!------------------------------------------------------------------------------ -! - FUNCTION F_Distortional( F, J ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - This subroutine computes Distortional part of Deformation -! gradient tensor -! -!------------------------------------------------------------------------------ -! -USE Utility, ONLY: det -! Define Intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F - REAL( DFP ), DIMENSION( SIZE( F, 1 ), SIZE( F, 2 ) ) :: F_Distortional - REAL( DFP ), INTENT( IN ), OPTIONAL :: J -! Define internal variables - REAL( DFP ) :: DetF - - Error_Flag = .FALSE. - - IF( PRESENT( J ) ) THEN - DetF = J - ELSE - DetF = det( F ) - END IF -! - F_Distortional = ( DetF ** ( -1.0_DFP / 3.0_DFP ) ) * F -! -END FUNCTION F_Distortional -! -!------------------------------------------------------------------------------ -! StretchTensor -!------------------------------------------------------------------------------ -! - FUNCTION C_Distortional( C, J ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - This subroutine computes Distortional part of the Right -! Cauchy deformation tensor -! -!------------------------------------------------------------------------------ -! - USE Utility, ONLY: det -! Define Intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( SIZE( C, 1 ), SIZE( C, 2 ) ) :: C_Distortional - REAL( DFP ), INTENT( IN ), OPTIONAL :: J -! Define internal variables - REAL( DFP ) :: DetC - - Error_Flag = .FALSE. - - IF( PRESENT( J ) ) THEN - DetC = J*J - ELSE - DetC = det( C ) - END IF - - C_Distortional = ( DetC ** ( -1.0_DFP / 3.0_DFP ) ) * C -! - END FUNCTION C_Distortional diff --git a/src/submodules/Rank2Tensor/src/old data/Old_getCDash.part b/src/submodules/Rank2Tensor/src/old data/Old_getCDash.part deleted file mode 100755 index 768e40479..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Old_getCDash.part +++ /dev/null @@ -1,151 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: getCDash.part -! Last Update : August-27-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Module -! -! Info:: - This part includes subroutine for getting C-Dash Matrix -! C-Dash is a matrix for 4th order tensor which has both major -! and Minor symmetry. C-dash is only the funciton of Cauchy Stress -! C_dash : d = Sigma . d + d . Sigma -! -! -!============================================================================== -! -! List of items -! -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! getCSigmaTruesdell -!------------------------------------------------------------------------------ -! - SUBROUTINE getCDash( C, Stress, StressType, F, J ) -! -! Description -!------------------------------------------------------------------------------ -! 1. This Function computes "CDash" which is frequently appeared -! in computing CsigmaTruesdell. -! StressType is for Stress Tensor -! 2. C has INTENT(OUT) -! 3. F and J are Optional arguments which are needed incase StressType -! is not Cauchy Stress. It will be used for conversion -! -!------------------------------------------------------------------------------ -! Define arguments of dummy argument - REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Stress - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F - REAL( DFP ), INTENT( IN ), OPTIONAL :: J - CHARACTER( LEN = * ), INTENT( IN ) :: StressType -! -! Define internal variables - REAL( DFP ), DIMENSION( :, : ), ALLOCATABLE :: Sigma - REAL( DFP ) :: d2 = 2.0_DFP, pt5 = 0.5_DFP -! - Error_Flag = .FALSE. -! -! get Cauchy Stress - ALLOCATE( Sigma( SIZE( Stress, 1 ), SIZE( Stress, 2 ) ) ) -! Flag-1 - CALL getCauchyStress( Sigma = Sigma, Stress = Stress, & - StressType = StressType ) - CALL Check_Error( "Utility>>Tensor.F90>>getCDash.part", & - "getCDash() >> Flag-1" ) -! - C = 0.0_DFP -! -SELECT CASE( SIZE( C, 1 ) ) - CASE( 6 ) - C ( 1, 1 ) = d2 * Sigma( 1, 1 ) - !C ( 1, 2 ) = C ( 1, 2 ) - 0.0_DFP - !C ( 1, 3 ) = C ( 1, 3 ) - 0.0_DFP - C ( 1, 4 ) = Sigma( 1, 2 ) - !C ( 1, 5 ) = C ( 1, 5 ) - 0.0_DFP - C ( 1, 6 ) = Sigma( 1, 3 ) - - !C ( 2, 1 ) = C ( 2, 1 ) - 0.0_DFP - C ( 2, 2 ) = d2 * Sigma( 2, 2 ) - !C ( 2, 3 ) = C ( 2, 3 ) - 0.0_DFP - C ( 2, 4 ) = Sigma( 2, 1 ) - C ( 2, 5 ) = Sigma( 2, 3 ) - !C ( 2, 6 ) = C ( 2, 6 ) - 0.0_DFP - - !C ( 3, 1 ) = C ( 3, 1 ) - 0.0_DFP - !C ( 3, 2 ) = C ( 3, 2 ) - 0.0_DFP - C ( 3, 3 ) = d2 * Sigma( 3, 3 ) - !C ( 3, 4 ) = C ( 3, 4 ) - 0.0_DFP - C ( 3, 5 ) = Sigma( 2, 3 ) - C ( 3, 6 ) = Sigma( 1, 3 ) - - C ( 4, 1 ) = Sigma( 1, 2 ) - C ( 4, 2 ) = Sigma( 1, 2 ) - !C ( 4, 3 ) = C ( 4, 3 ) - 0.0_DFP - C ( 4, 4 ) = pt5 * Sigma( 1, 1 ) + pt5 * Sigma( 2, 2 ) - C ( 4, 5 ) = pt5 * Sigma( 1, 3 ) - C ( 4, 6 ) = pt5 * Sigma( 2, 3 ) - - !C ( 5, 1 ) = C ( 5, 1 ) - 0.0_DFP - C ( 5, 2 ) = Sigma( 2, 3 ) - C ( 5, 3 ) = Sigma( 2, 3 ) - C ( 5, 4 ) = pt5 * Sigma( 1, 3 ) - C ( 5, 5 ) = pt5 * Sigma( 2, 2 ) + pt5 * Sigma( 3, 3 ) - C ( 5, 6 ) = pt5 * Sigma( 2, 1 ) - - - C ( 6, 1 ) = Sigma( 1, 3 ) - !C ( 6, 2 ) = C ( 6, 2 ) - 0.0_DFP - C ( 6, 3 ) = Sigma( 1, 3 ) - C ( 6, 4 ) = pt5 * Sigma( 2, 3 ) - C ( 6, 5 ) = pt5 * Sigma( 2, 1 ) - C ( 6, 6 ) = pt5 * Sigma( 1, 1 ) + pt5 * Sigma( 3, 3 ) - - CASE( 4 ) - - C ( 1, 1 ) = d2 * Sigma( 1, 1 ) - !C ( 1, 2 ) = C ( 1, 2 ) - 0.0_DFP - C ( 1, 3 ) = Sigma( 1, 2 ) - !C ( 1, 4 ) = C ( 1, 4 ) - 0.0_DFP - - !C ( 2, 1 ) = C ( 2, 1 ) - 0.0_DFP - C ( 2, 2 ) = d2 * Sigma( 2, 2 ) - C ( 2, 3 ) = Sigma( 1, 2 ) - !C ( 2, 4 ) = C ( 2, 4 ) - 0.0_DFP - - C ( 3, 1 ) = Sigma( 1, 2 ) - C ( 3, 2 ) = Sigma( 1, 2 ) - C ( 3, 3 ) = pt5 * Sigma( 1, 1 ) + pt5 * Sigma( 2, 2 ) - !C ( 3, 4 ) = C ( 3, 4 ) - 0.0_DFP - - !C ( 4, 1 ) = C ( 4, 1 ) - 0.0_DFP - !C ( 4, 2 ) = C ( 4, 2 ) - 0.0_DFP - !C ( 4, 3 ) = C ( 4, 3 ) - 0.0_DFP - IF ( SIZE( Sigma, 1 ) .EQ. 3 ) THEN - C ( 4, 4 ) = d2 * Sigma( 3, 3 ) - END IF - - CASE ( 1 ) - C ( 1, 1 ) = d2 * Sigma( 1, 1 ) -! Flag-2 - CASE DEFAULT - CALL Err_Msg( "Utility>>Tensor.F90>>getCDash.part", & - "getCDash(), Flag-2", " Unknown Shape of C matrix " ) - END SELECT -! - DEALLOCATE( Sigma ) -! - END SUBROUTINE getCDash -! -!------------------------------------------------------------------------------ -! getCSigmaTruesdell -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part b/src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part deleted file mode 100755 index 12c794e0a..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part +++ /dev/null @@ -1,237 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: getCSigmaTruesdell.part -! Last Update : August-27-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Module -! -! Info:: - This module includes subroutine for tensor operations -! -! Hosting File :- Tensor.F90 -! -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getCSigmaTruesdell -!------------------------------------------------------------------------------ -! - SUBROUTINE getCSigmaTruesdell( C, Stress, StressType, StressRateType, F, J ) - USE Utility, ONLY : OUTERPROD - USE Voigt -! -! Description -!------------------------------------------------------------------------------ -! 1. This Function computes "CsigmaTruesdell" which is used in -! Linearization of virtual work. -! StressType is for Stress Tensor -! 2. C has INTENT(INOUT ) -! 3. Stress Rate Type provides information to the program about the -! type of C matrix. Sigma( StressRateType ) = C:d -! 4. Note Changes will appear in C -! 5. F and J are Optional arguments which are needed incase StressType -! is not Cauchy Stress. -! It will be used for conversion -! -!------------------------------------------------------------------------------ -! Define arguments of dummy argument - REAL( DFP ), DIMENSION( :, : ), INTENT( INOUT ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: Stress - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F - REAL( DFP ), INTENT( IN ), OPTIONAL :: J - CHARACTER( LEN = * ), INTENT( IN ), OPTIONAL :: StressType - CHARACTER( LEN = * ), INTENT( IN ) :: StressRateType -! Define internal variables - REAL( DFP ), DIMENSION( :, : ), ALLOCATABLE :: Sigma, DummyMat, B - INTEGER( I4B ), DIMENSION( :, : ), ALLOCATABLE :: Indx - REAL( DFP ) :: d2 = 2.0_DFP, pt5 = 0.5_DFP - INTEGER( I4B ) :: ii, jj, M -! -! get Cauchy Stress - IF( PRESENT( Stress ) ) THEN - ALLOCATE( Sigma( SIZE( Stress, 1 ), SIZE( Stress, 2 ) ) ) -! Flag-1 - CALL getCauchyStress( Sigma = Sigma, Stress = Stress, & - StressType = StressType ) - CALL Check_Error( "Utility>>Tensor.F90>>getCSigmaTruesdell.part", & - "getCSigmaTruesdell() >> Flag-1" ) - END IF -! -! Build case based on Stress Rate Type - SELECT CASE( TRIM( StressRateType ) ) -! -!------------------------------------------------------------------------------- -! Jaumann Stress Rate -!------------------------------------------------------------------------------- -! - CASE( "Jaumann", "JaumannZaremba", "JZ" ) - SELECT CASE( SIZE( C, 1 ) ) - CASE( 6 ) - C ( 1, 1 ) = C ( 1, 1 ) - Sigma( 1, 1 ) - C ( 1, 2 ) = C ( 1, 2 ) + Sigma( 1, 1 ) - C ( 1, 3 ) = C ( 1, 3 ) + Sigma( 1, 1 ) - C ( 1, 4 ) = C ( 1, 4 ) - Sigma( 1, 2 ) - !C ( 1, 5 ) = C ( 1, 5 ) - 0.0_DFP - C ( 1, 6 ) = C ( 1, 6 ) - Sigma( 1, 3 ) - - C ( 2, 1 ) = C ( 2, 1 ) + Sigma( 2, 2 ) - C ( 2, 2 ) = C ( 2, 2 ) - Sigma( 2, 2 ) - C ( 2, 3 ) = C ( 2, 3 ) + Sigma( 2, 2 ) - C ( 2, 4 ) = C ( 2, 4 ) - Sigma( 2, 1 ) - C ( 2, 5 ) = C ( 2, 5 ) - Sigma( 2, 3 ) - !C ( 2, 6 ) = C ( 2, 6 ) - 0.0_DFP - - C ( 3, 1 ) = C ( 3, 1 ) + Sigma( 3, 3 ) - C ( 3, 2 ) = C ( 3, 2 ) + Sigma( 3, 3 ) - C ( 3, 3 ) = C ( 3, 3 ) - Sigma( 3, 3 ) - !C ( 3, 4 ) = C ( 3, 4 ) - 0.0_DFP - C ( 3, 5 ) = C ( 3, 5 ) - Sigma( 2, 3 ) - C ( 3, 6 ) = C ( 3, 6 ) - Sigma( 1, 3 ) - - !C ( 4, 1 ) = C ( 4, 1 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) - !C ( 4, 2 ) = C ( 4, 2 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) - C ( 4, 3 ) = C ( 4, 3 ) + Sigma( 1, 2 ) - C ( 4, 4 ) = C ( 4, 4 ) - pt5 * Sigma( 1, 1 ) - pt5 * Sigma( 2, 2 ) - C ( 4, 5 ) = C ( 4, 5 ) - pt5 * Sigma( 1, 3 ) - C ( 4, 6 ) = C ( 4, 6 ) - pt5 * Sigma( 2, 3 ) - - C ( 5, 1 ) = C ( 5, 1 ) + Sigma( 2, 3 ) - !C ( 5, 2 ) = C ( 5, 2 ) - Sigma( 2, 3 ) + Sigma( 2, 3 ) - !C ( 5, 3 ) = C ( 5, 3 ) - Sigma( 2, 3 ) + Sigma( 2, 3 ) - C ( 5, 4 ) = C ( 5, 4 ) - pt5 * Sigma( 1, 3 ) - C ( 5, 5 ) = C ( 5, 5 ) - pt5 * Sigma( 2, 2 ) - pt5 * Sigma( 3, 3 ) - C ( 5, 6 ) = C ( 5, 6 ) - pt5 * Sigma( 2, 1 ) - - - !C ( 6, 1 ) = C ( 6, 1 ) - Sigma( 1, 3 ) + Sigma( 1, 3 ) - C ( 6, 2 ) = C ( 6, 2 ) + Sigma( 1, 3 ) - !C ( 6, 3 ) = C ( 6, 3 ) - Sigma( 1, 3 ) + Sigma( 1, 3 ) - C ( 6, 4 ) = C ( 6, 4 ) - pt5 * Sigma( 2, 3 ) - C ( 6, 5 ) = C ( 6, 5 ) - pt5 * Sigma( 2, 1 ) - C ( 6, 6 ) = C ( 6, 6 ) - pt5 * Sigma( 1, 1 ) - pt5 * Sigma( 3, 3 ) - - CASE( 4 ) - - C ( 1, 1 ) = C ( 1, 1 ) - Sigma( 1, 1 ) - C ( 1, 2 ) = C ( 1, 2 ) + Sigma( 1, 1 ) - C ( 1, 3 ) = C ( 1, 3 ) - Sigma( 1, 2 ) - C ( 1, 4 ) = C ( 1, 4 ) + Sigma( 1, 1 ) - - C ( 2, 1 ) = C ( 2, 1 ) + Sigma( 2, 2 ) - C ( 2, 2 ) = C ( 2, 2 ) - Sigma( 2, 2 ) - C ( 2, 3 ) = C ( 2, 3 ) - Sigma( 1, 2 ) - C ( 2, 4 ) = C ( 2, 4 ) + Sigma( 2, 2 ) - - !C ( 3, 1 ) = C ( 3, 1 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) - !C ( 3, 2 ) = C ( 3, 2 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) - C ( 3, 3 ) = C ( 3, 3 ) - pt5 * Sigma( 1, 1 ) - pt5 * Sigma( 2, 2 ) - C ( 3, 4 ) = C ( 3, 4 ) + Sigma( 1, 2 ) - - IF ( SIZE ( Sigma, 1 ) .EQ. 3 ) THEN - C ( 4, 1 ) = C ( 4, 1 ) + Sigma( 3, 3 ) - C ( 4, 2 ) = C ( 4, 2 ) + Sigma( 3, 3 ) - !C ( 4, 3 ) = C ( 4, 3 ) - 0.0_DFP - C ( 4, 4 ) = C ( 4, 4 ) - Sigma( 3, 3 ) - END IF - - CASE ( 1 ) - C ( 1, 1 ) = C ( 1 , 1 ) - Sigma( 1, 1 ) - END SELECT -! -!------------------------------------------------------------------------------- -! Jaumann Stress Rate -!------------------------------------------------------------------------------- -! - CASE( "Truesdell", "truesdell" ) - RETURN ! Do nothing and return -! -!------------------------------------------------------------------------------- -! SE -!------------------------------------------------------------------------------- -! - CASE( "SE", "se", "NA" ) -! Flag-2 - IF( .NOT. PRESENT( F ) .OR. .NOT. PRESENT( J ) ) THEN - CALL Err_Msg( "Utility>>Tensor.part>>getCSigmaTruesdell.part", & - " getCSigmaTruesdell(), Flag-2 ", & - " F and J are missing in arguments ") - Error_Flag = .TRUE. - RETURN - END IF -! - ALLOCATE( B( SIZE( C, 1 ), SIZE( C, 2 ) ) ) - ALLOCATE( DummyMat( SIZE( F, 2 ), SIZE( F, 2 ) ) ) - ALLOCATE( Indx( SIZE( C, 1 ), 2 ) ) - - SELECT CASE( SIZE( Indx, 1 ) ) - CASE( 6 ) - Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 - Indx( 2, 1 ) = 2; Indx( 2, 2 ) = 2 - Indx( 3, 1 ) = 3; Indx( 3, 2 ) = 3 - Indx( 4, 1 ) = 1; Indx( 4, 2 ) = 2 - Indx( 5, 1 ) = 2; Indx( 5, 2 ) = 3 - Indx( 6, 1 ) = 1; Indx( 6, 2 ) = 3 - CASE(4) - Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 - Indx( 2, 1 ) = 2; Indx( 2, 2 ) = 2 - Indx( 3, 1 ) = 1; Indx( 3, 2 ) = 2 - Indx( 4, 1 ) = 3; Indx( 4, 2 ) = 3 - CASE(3) - Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 - Indx( 2, 1 ) = 2; Indx( 2, 2 ) = 2 - Indx( 3, 1 ) = 1; Indx( 3, 2 ) = 2 - CASE(1) - Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 -! Flag-3 - CASE DEFAULT - CALL Err_Msg( "Utility>>Tensor.part", & - " getCSigmaTruesdell(), Flag-3 ", & - "No case found for given Size of C") - Error_Flag = .TRUE. - RETURN - END SELECT - - DO M = 1, SIZE( Indx, 1 ) - ii = Indx( M, 1); jj = Indx( M, 2 ) - DummyMat = 0.0_DFP - DummyMat = OUTERPROD( a = F( ii, : ), b = F( jj, : ) ) -! Flag-4 - CALL Matrix2Voigt( Mat = DummyMat, VoigtVec = B( :, M ), & - VoigtType = "Strain" ) - CALL Check_Error( "Utility>>Tensor.F90>>getCSigmaTruesdell.part", & - "getCSigmaTruesdell() >> Flag-4" ) - END DO - - IF( ALLOCATED( DummyMat ) ) DEALLOCATE( DummyMat ) - ALLOCATE( DummyMat( SIZE( C, 1), SIZE( C, 2 ) ) ) - DummyMat = MATMUL( TRANSPOSE( B ), MATMUL( C, B ) ) - C = DummyMat / J -! Flag-5 - CASE DEFAULT - CALL Err_Msg( "Utility>>Tensor.part", & - " getCSigmaTruesdell(), Flag-5 ", & - "Unknown Stress Rate Type") - Error_Flag = .TRUE. - RETURN -! - END SELECT -! - IF( ALLOCATED( Sigma ) ) DEALLOCATE( Sigma ) - IF( ALLOCATED( B ) ) DEALLOCATE( B ) - IF( ALLOCATED( DummyMat ) ) DEALLOCATE( DummyMat ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) -! - END SUBROUTINE getCSigmaTruesdell - ! - ! - !------------------------------------------------------------------------------ - ! getCSigmaTruesdell - !------------------------------------------------------------------------------ - ! diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorInterface.part b/src/submodules/Rank2Tensor/src/old data/OperatorInterface.part deleted file mode 100755 index 25a3dce88..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorInterface.part +++ /dev/null @@ -1,217 +0,0 @@ - - INTERFACE OPERATOR( .X. ) - - MODULE PROCEDURE VectorProduct2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Angle. ) - - MODULE PROCEDURE getAngle - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .ProjectOn. ) - - MODULE PROCEDURE getProjection - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .UnitVector. ) - - MODULE PROCEDURE UnitVector - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .dot. ) - - MODULE PROCEDURE DotProduct - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .ComponentNormalTo. ) - - MODULE PROCEDURE getNormalComponent - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .ComponentParallelTo. ) - - MODULE PROCEDURE getProjection - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Trace. ) - - MODULE PROCEDURE Trace_1, Trace_2 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .DoubleDot. ) - - MODULE PROCEDURE DoubleDot_Product1, DoubleDot_Product2, & - DoubleDot_Product3, DoubleDot_Product7 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Sym. ) - - MODULE PROCEDURE f_SymmetricPart, m_SymmetricPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Anti. ) - - MODULE PROCEDURE f_AntiSymmetricPart, m_AntiSymmetricPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Hydro. ) - - MODULE PROCEDURE f_HydrostaticPart, m_HydrostaticPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Dev. ) - - MODULE PROCEDURE f_DeviatoricPart, m_DeviatoricPart - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Contraction. ) - - MODULE PROCEDURE DoubleDot_Product1, DoubleDot_Product2, & - DoubleDot_Product3, DoubleDot_Product7, TensorTimesVector, & - VectorTimesTensor, MatVec, VecMat, VecVec - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .matmul. ) - - MODULE PROCEDURE MatVec, VecMat, MatMat, MatMul_1, MatMul_2, & - MatMul_3, TensorTimesVector, VectorTimesTensor - - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .det. ) - - MODULE PROCEDURE f_Det_1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .Otimes. ) - - MODULE PROCEDURE Mat_Dyadic_Mat - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .inverse. ) - - MODULE PROCEDURE f_inverse_1 - - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .inv. ) - - MODULE PROCEDURE f_inverse_1, m_inverse_1 - - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE OPERATOR( .transpose. ) - - MODULE PROCEDURE Transpose_2, Transpose_1 - - END INTERFACE diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part deleted file mode 100755 index a33d44be1..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part +++ /dev/null @@ -1,220 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Addition.part -! Last Update : Dec-13-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Tensor class is defined -! HOSTING FILE -! - Rank2Tensor_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_obj( obj, obj2 ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_obj - - obj_Add_obj = obj%T + obj2%T - - END FUNCTION obj_Add_obj - -!------------------------------------------------------------------------------ -! obj_Add_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_Mat( obj, Mat ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Mat - - obj_Add_Mat = obj%T + Mat - - END FUNCTION obj_Add_Mat - -!------------------------------------------------------------------------------ -! Mat_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_Add_obj( Mat, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Add_obj - - Mat_Add_obj = obj%T + Mat - - END FUNCTION Mat_Add_obj - - -!------------------------------------------------------------------------------ -! obj_Add_Scalar -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_Scalar( obj, S ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Scalar - - obj_Add_Scalar = obj%T + S - - END FUNCTION obj_Add_Scalar - -!------------------------------------------------------------------------------ -! obj_Add_Scalar -!------------------------------------------------------------------------------ - - FUNCTION Scalar_Add_obj( S, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Add_obj - - Scalar_Add_obj = obj_Add_Scalar( obj, S ) - - END FUNCTION Scalar_Add_obj - -!------------------------------------------------------------------------------ -! obj_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_obj( obj, obj2 ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_obj - - obj_Minus_obj = obj%T - obj2%T - - END FUNCTION obj_Minus_obj - -!------------------------------------------------------------------------------ -! obj_Minus_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_Mat( obj, Mat ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Mat - - obj_Minus_Mat = obj%T - Mat - - END FUNCTION obj_Minus_Mat - -!------------------------------------------------------------------------------ -! Mat_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_Minus_obj( Mat, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Minus_obj - - Mat_Minus_obj = Mat - obj%T - - END FUNCTION Mat_Minus_obj - -!------------------------------------------------------------------------------ -! obj_Minus_Scalar -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_Scalar( obj, S ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Scalar - - obj_Minus_Scalar = obj%T - S - - END FUNCTION obj_Minus_Scalar - -!------------------------------------------------------------------------------ -! Scalar_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION Scalar_Minus_obj( S, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Minus_obj - - Scalar_Minus_obj = -obj_Minus_Scalar( obj, S ) - - END FUNCTION Scalar_Minus_obj - - diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part deleted file mode 100755 index e07111d7b..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part +++ /dev/null @@ -1,373 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Asterics.part -! Last Update : Dec-13-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Tensor class is defined -! HOSTING FILE -! - Rank2Tensor_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! TensorTimesScalar_1 -!------------------------------------------------------------------------------ -! - FUNCTION TensorTimesScalar_1( obj, Scalar ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_1 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "TensorTimesScalar_1()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - TensorTimesScalar_1 = obj%T * Scalar - - END FUNCTION TensorTimesScalar_1 -! -!------------------------------------------------------------------------------ -! TensorTimesScalar_2 -!------------------------------------------------------------------------------ -! - FUNCTION TensorTimesScalar_2( Scalar, obj ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_2 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "TensorTimesScalar_2()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - TensorTimesScalar_2 = obj%T * Scalar - - END FUNCTION TensorTimesScalar_2 -! -!------------------------------------------------------------------------------ -! TensorTimesScalar_3 -!------------------------------------------------------------------------------ -! - FUNCTION TensorTimesScalar_3( obj, Scalar ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_3 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "TensorTimesScalar_3()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - TensorTimesScalar_3 = obj%T * Scalar - - END FUNCTION TensorTimesScalar_3 -! -!------------------------------------------------------------------------------ -! TensorTimesScalar_4 -!------------------------------------------------------------------------------ -! - FUNCTION TensorTimesScalar_4( Scalar, obj ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_4 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "TensorTimesScalar_4()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - TensorTimesScalar_4 = obj%T * Scalar - - END FUNCTION TensorTimesScalar_4 -! -!------------------------------------------------------------------------------ -! TensorTimesTensor -!------------------------------------------------------------------------------ -! - FUNCTION TensorTimesTensor( obj, obj2 ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesTensor - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) & - .OR. .NOT. ALLOCATED( obj2%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "TensorTimesTensor()", & - "Tensor_ obj is/are not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - TensorTimesTensor = obj%T * obj2%T - - END FUNCTION TensorTimesTensor -! -!------------------------------------------------------------------------------ -! TensorTimesVector -!------------------------------------------------------------------------------ -! - FUNCTION TensorTimesVector( obj, Vec ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. Vec = [T] * {v} -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: TensorTimesVector - -! Define internal variables - - Error_Flag = .FALSE. - - TensorTimesVector = 0.0_DFP - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "TensorTimesVector()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - SELECT CASE( SIZE( Vec ) ) - - CASE( 1 ) - - TensorTimesVector( 1 ) = obj%T( 1, 1 ) * Vec( 1 ) - - CASE( 2 ) - - TensorTimesVector( 1 : 2 ) = MATMUL( obj%T( 1:2, 1:2 ), Vec( 1:2 ) ) - - CASE( 3 ) - - TensorTimesVector = MATMUL( obj%T, Vec ) - - END SELECT - - - END FUNCTION TensorTimesVector -! -!------------------------------------------------------------------------------ -! VectorTimesTensor -!------------------------------------------------------------------------------ -! - FUNCTION VectorTimesTensor( Vec, obj ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. Vec = {v}*[T] = [T]^T {v} -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: VectorTimesTensor - -! Define internal variables - - Error_Flag = .FALSE. - - VectorTimesTensor = 0.0_DFP - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "VectorTimesTensor()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - SELECT CASE( SIZE( Vec ) ) - - CASE( 1 ) - - VectorTimesTensor( 1 ) = obj%T( 1, 1 ) * Vec( 1 ) - - CASE( 2 ) - - VectorTimesTensor( 1 : 2 ) = MATMUL( TRANSPOSE( obj%T( 1:2, 1:2 ) ), Vec( 1:2 ) ) - - CASE( 3 ) - - VectorTimesTensor = MATMUL( TRANSPOSE( obj%T ), Vec ) - - END SELECT - - END FUNCTION VectorTimesTensor -! -!------------------------------------------------------------------------------ -! TensorTimesMat -!------------------------------------------------------------------------------ -! - FUNCTION TensorTimesMat( obj, Mat ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesMat - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "TensorTimesMat()", & - "Tensor_ obj not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - TensorTimesMat = obj%T * Mat - - END FUNCTION TensorTimesMat -! -!------------------------------------------------------------------------------ -! MatTimesTensor -!------------------------------------------------------------------------------ -! - FUNCTION MatTimesTensor( Mat, obj ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: MatTimesTensor - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Asterics.part", & - "MatTimesTensor()", & - "Tensor_ obj not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - MatTimesTensor = obj%T * Mat - - END FUNCTION MatTimesTensor -! \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part deleted file mode 100755 index 1c82bc891..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part +++ /dev/null @@ -1,60 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Determinant.part -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Tensor class is defined -! HOSTING FILE -! - Rank2Tensor_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! f_Det_1 -!------------------------------------------------------------------------------ - - FUNCTION f_Det_1( Mat ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . -! 1. - determinent -!. . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : Det - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ) :: f_Det_1 - - f_Det_1 = Det( Mat ) - - END FUNCTION f_Det_1 - -!------------------------------------------------------------------------------ -! m_Det_1 -!------------------------------------------------------------------------------ - - FUNCTION m_Det_1( obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . -! 1. - determinent -!. . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : Det - - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ) :: m_Det_1 - - m_Det_1 = Det( obj%T ) - - END FUNCTION m_Det_1 - diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part deleted file mode 100755 index e6a63ccc8..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part +++ /dev/null @@ -1,65 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Inverse.part -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Tensor class is defined -! HOSTING FILE -! - Rank2Tensor_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! f_inverse_1 -!------------------------------------------------------------------------------ - -FUNCTION f_inverse_1( Mat ) - - USE Utility, ONLY : INV - - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( SIZE( Mat,1 ), SIZE( Mat, 2 ) ) :: f_inverse_1 - - - Error_Flag = .FALSE. - - CALL INV( A = Mat, INVA = f_inverse_1 ) - - CALL Check_Error( & - "Rank2Tensor_Class.F90>>Inverse.part>>f_inverse_1()", & - "Traceback ---> CALL INV( A = Mat, INVA = Mat )" & - ) - -END FUNCTION f_inverse_1 - -!------------------------------------------------------------------------------ -! m_inverse_1 -!------------------------------------------------------------------------------ - -FUNCTION m_inverse_1( obj ) - - USE Utility, ONLY : INV - - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_inverse_1 - - - Error_Flag = .FALSE. - - CALL INV( A = obj%T, INVA = m_inverse_1 ) - - CALL Check_Error( & - "Rank2Tensor_Class.F90>>Inverse.part>>m_inverse_1()", & - "Traceback ---> CALL INV( A = Mat, INVA = Mat )" & - ) - -END FUNCTION m_inverse_1 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part deleted file mode 100755 index 386b715f3..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part +++ /dev/null @@ -1,257 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MatMul.part -! Last Update : Dec-13-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Tensor class is defined -! HOSTING FILE -! - Rank2Tensor_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! MatMul_1 -!------------------------------------------------------------------------------ -! - FUNCTION MatMul_1( obj, obj2 ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Tensor Class -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_1 - - Error_Flag = .FALSE. - -#ifdef DEBUG_VER - IF( .NOT. ALLOCATED( obj%T ) & - .OR. .NOT. ALLOCATED( obj2%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>OperatorOverloading.part", & - "MatMul_1()", & - "Tensor_ obj is/are not allocated. Program Stopped"& - ) - Error_Flag = .TRUE. - - STOP - - END IF -#endif - MatMul_1 = MATMUL( obj%T, obj2%T ) - - END FUNCTION MatMul_1 -! -!------------------------------------------------------------------------------ -! MatMul_2 -!------------------------------------------------------------------------------ -! - FUNCTION MatMul_2( obj, Mat2 ) -! -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. - obj .matmul. Mat -!. . . . . . . . . . . . . . . . . . . . -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_2 - - ! Define internal variables - INTEGER( I4B ) :: N - Error_Flag = .FALSE. - -#ifdef DEBUG_VER - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>OperatorOverloading.part", & - "MatMul_2()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF -#endif - - N = SIZE( Mat2, 1 ) - MatMul_2 = 0.0_DFP - - SELECT CASE( N ) - - CASE( 1 ) - - MatMul_2( 1, 1 ) = obj%T( 1, 1 ) * Mat2( 1, 1 ) - - CASE( 2 ) - - MatMul_2( 1:2, 1:2 ) = MATMUL(obj%T( 1:2, 1:2 ), Mat2( 1:2, 1:2 )) - - CASE DEFAULT - - MatMul_2( 1:3, 1:3 ) = MATMUL(obj%T( 1:3, 1:3 ), Mat2( 1:3, 1:3 )) - - END SELECT - - END FUNCTION MatMul_2 -! -!------------------------------------------------------------------------------ -! MatMul_3 -!------------------------------------------------------------------------------ -! - FUNCTION MatMul_3( Mat2, obj ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Mat .matmul. obj -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_3 - - ! Define internal variables - INTEGER( I4B ) :: N - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>OperatorOverloading.part", & - "MatMul_3()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - N = SIZE( Mat2, 1 ) - MatMul_3 = 0.0_DFP - - SELECT CASE( N ) - - CASE( 1 ) - - MatMul_3( 1, 1 ) = obj%T( 1, 1 ) * Mat2( 1, 1 ) - - CASE( 2 ) - - MatMul_3( 1:2, 1:2 ) = MATMUL( Mat2( 1:2, 1:2 ), obj%T( 1:2, 1:2 ) ) - - CASE DEFAULT - - MatMul_3( 1:3, 1:3 ) = MATMUL( Mat2( 1:3, 1:3 ), obj%T( 1:3, 1:3 ) ) - - END SELECT - - END FUNCTION MatMul_3 - -!------------------------------------------------------------------------------ -! MatVec -!------------------------------------------------------------------------------ - - FUNCTION MatVec( Mat2, Vec ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . -! 1. - Used for defining the contraction operator -!. . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: MatVec - - MatVec = MATMUL( Mat2, Vec ) - - END FUNCTION MatVec - -!------------------------------------------------------------------------------ -! VecMat -!------------------------------------------------------------------------------ - - FUNCTION VecMat( Vec, Mat2 ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . -! 1. - used for defining the contraction operator -!. . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: VecMat - - VecMat = MATMUL( TRANSPOSE( Mat2 ), Vec ) - - END FUNCTION VecMat - -!------------------------------------------------------------------------------ -! VecVec -!------------------------------------------------------------------------------ - - FUNCTION VecVec( Vec, Vec2 ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . -! 1. - used for defining the contraction operator -!. . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ) :: VecVec - - VecVec = DOT_PRODUCT( Vec, Vec2 ) - - END FUNCTION VecVec - -!------------------------------------------------------------------------------ -! MatMat -!------------------------------------------------------------------------------ - - FUNCTION MatMat( Mat1, Mat2 ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . -! 1. - used for defining the contraction operator -!. . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat1 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( SIZE( Mat1, 1 ), SIZE( Mat2, 2) ) :: MatMat - - IF( SIZE( Mat1, 2 ) .NE. SIZE( Mat2, 1 ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>MatMul.part>", & - "Mat .matmul. Mat", & - "Matrix multiplication is not compatible, Program Stopped!!!" & - ) - STOP - END IF - - MatMat = MATMUL( Mat1, Mat2 ) - - END FUNCTION MatMat diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part deleted file mode 100755 index c966472e8..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part +++ /dev/null @@ -1,292 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Otimes.part -! Last Update : Dec-13-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPsTION -! - Otimes operator is defined -! HOSTING FILE -! - Rank2Tensor_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Tensor_Dyadic_Tensor -!------------------------------------------------------------------------------ - - FUNCTION Tensor_Dyadic_Tensor( obj, obj2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Tensor - - ! Define internal variables - - INTEGER( I4B ) :: Index( 6, 2 ), I, J - - Error_Flag = .FALSE. - - Tensor_Dyadic_Tensor = 0.0_DFP - - IF( .NOT. ALLOCATED( obj%T ) .OR. .NOT. ALLOCATED( obj2%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Otimes.part", & - ".Otimes.()", & - "Tensor_ obj is/are not allocated. Program Stopped"& - ) - Error_Flag = .TRUE. - - STOP - - END IF - - IF( .NOT. obj%isSymmetric( ) .OR. .NOT. obj2%isSymmetric( ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Otimes.part", & - ".Otimes.()", & - "Tensor_ obj is/are not symmmetric.Program Stopped"& - ) - Error_Flag = .TRUE. - - STOP - - END IF - - Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 - Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 - Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 - Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 - Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 - Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 - - - DO I = 1, SIZE( Index, 1 ) - - DO J = 1, SIZE( Index, 1 ) - - Tensor_Dyadic_Tensor( I, J ) = & - obj%T( Index( I, 1 ), Index( I, 2 ) ) & - * obj2%T( Index( J, 1 ), Index( J, 2 ) ) - - END DO - - END DO - - END FUNCTION Tensor_Dyadic_Tensor - -!------------------------------------------------------------------------------ -! Tensor_Dyadic_Mat -!------------------------------------------------------------------------------ - - FUNCTION Tensor_Dyadic_Mat( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Mat - - ! Define internal variables - - INTEGER( I4B ) :: Index( 6, 2 ), I, J - - Error_Flag = .FALSE. - - Tensor_Dyadic_Mat = 0.0_DFP - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Otimes.part", & - ".Otimes.()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - IF( .NOT. obj%isSymmetric( ) .OR. .NOT. isSymmetric( Mat ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Otimes.part", & - ".Otimes.()", & - "Tensor_ obj is/are not symmmetric.Program Stopped"& - ) - Error_Flag = .TRUE. - - STOP - - END IF - - Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 - Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 - Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 - Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 - Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 - Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 - - - DO I = 1, SIZE( Index, 1 ) - - DO J = 1, SIZE( Index, 1 ) - - Tensor_Dyadic_Mat( I, J ) = & - obj%T( Index( I, 1 ), Index( I, 2 ) ) & - * Mat( Index( J, 1 ), Index( J, 2 ) ) - - END DO - - END DO - - END FUNCTION Tensor_Dyadic_Mat -! -!------------------------------------------------------------------------------ -! Mat_Dyadic_Tensor -!------------------------------------------------------------------------------ -! - FUNCTION Mat_Dyadic_Tensor( Mat, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat .otimes. obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Dyadic_Tensor - - ! Define internal variables - - INTEGER( I4B ) :: Index( 6, 2 ), I, J - - Error_Flag = .FALSE. - - Mat_Dyadic_Tensor = 0.0_DFP - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Otimes.part", & - ".Otimes.", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - IF( .NOT. obj%isSymmetric( ) .OR. .NOT. isSymmetric( Mat ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Otimes.part", & - ".Otimes.", & - "Tensor_ obj is/are not symmmetric.Program Stopped"& - ) - Error_Flag = .TRUE. - - STOP - - END IF - - Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 - Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 - Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 - Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 - Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 - Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 - - - DO I = 1, SIZE( Index, 1 ) - - DO J = 1, SIZE( Index, 1 ) - - Mat_Dyadic_Tensor( I, J ) = & - Mat( Index( I, 1 ), Index( I, 2 ) ) & - * obj%T( Index( J, 1 ), Index( J, 2 ) ) - - END DO - - END DO - - END FUNCTION Mat_Dyadic_Tensor - -!------------------------------------------------------------------------------ -! Mat_Dyadic_Mat -!------------------------------------------------------------------------------ - - FUNCTION Mat_Dyadic_Mat( Mat, Mat2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat .otimes. obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat, Mat2 - REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Dyadic_Mat - - ! Define internal variables - - INTEGER( I4B ) :: Index( 6, 2 ), I, J - - Error_Flag = .FALSE. - - Mat_Dyadic_Mat = 0.0_DFP - - IF( .NOT. isSymmetric( Mat2 ) .OR. .NOT. isSymmetric( Mat ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>Otimes.part", & - ".Otimes.", & - "Matrix is/are not symmmetric.Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 - Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 - Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 - Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 - Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 - Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 - - - DO I = 1, SIZE( Index, 1 ) - - DO J = 1, SIZE( Index, 1 ) - - Mat_Dyadic_Mat( I, J ) = & - Mat( Index( I, 1 ), Index( I, 2 ) ) & - * Mat2( Index( J, 1 ), Index( J, 2 ) ) - - END DO - - END DO - - END FUNCTION Mat_Dyadic_Mat diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part deleted file mode 100755 index 6bceb1624..000000000 --- a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part +++ /dev/null @@ -1,72 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Transpose.part -! Last Update : Dec-13-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Tensor class is defined -! HOSTING FILE -! - Rank2Tensor_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! Transpose_1 -!------------------------------------------------------------------------------ - - FUNCTION Transpose_1( obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. transpose of obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: Transpose_1 - - IF( .NOT. ALLOCATED( obj%T ) ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>OperatorOverloading.part", & - ".Transpose.()", & - "Tensor_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - - Transpose_1 = TRANSPOSE( obj%T ) - - END FUNCTION Transpose_1 - -!------------------------------------------------------------------------------ -! Transpose_2 -!------------------------------------------------------------------------------ - - FUNCTION Transpose_2( Mat ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. transpose -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: Transpose_2 - - Transpose_2 = TRANSPOSE( Mat ) - - END FUNCTION Transpose_2 -! diff --git a/src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 b/src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 deleted file mode 100755 index 7858f0ea9..000000000 --- a/src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 +++ /dev/null @@ -1,100 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: RightCauchyGreen_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Left Cauchy green tensor -!============================================================================== - - MODULE RightCauchyGreen_Class - USE GlobalData - USE IO - USE Rank2Tensor_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: RightCauchyGreen_, RightCauchyGreen, RightCauchyGreen_Pointer - -!------------------------------------------------------------------------------ -! RightCauchyGreen_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Rank2Tensor_ ) :: RightCauchyGreen_ - - END TYPE RightCauchyGreen_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE RightCauchyGreen - MODULE PROCEDURE Constructor1 - END INTERFACE - - INTERFACE RightCauchyGreen_Pointer - MODULE PROCEDURE Constructor_1 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy varialbes - CLASS( RightCauchyGreen_ ), POINTER :: Constructor_1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - ALLOCATE( Constructor_1 ) - Constructor_1 = ( .transpose. F ) .matmul. F - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy variables - TYPE( RightCauchyGreen_ ) :: Constructor1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - Constructor1 = ( .transpose. F ) .matmul. F - - END FUNCTION Constructor1 - - END MODULE RightCauchyGreen_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 deleted file mode 100755 index 94ec4aa5e..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 +++ /dev/null @@ -1,145 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: AlmansiStrain_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define AlmansiStrain Class -!============================================================================== - - MODULE AlmansiStrain_Class - USE GlobalData - USE IO - USE Strain_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: AlmansiStrain_, AlmansiStrain, AlmansiStrain_Pointer - -!------------------------------------------------------------------------------ -! AlmansiStrain_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Strain_ ) :: AlmansiStrain_ - - END TYPE AlmansiStrain_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE AlmansiStrain - MODULE PROCEDURE Constructor1, Constructor2 - END INTERFACE - - INTERFACE AlmansiStrain_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy varialbes - CLASS( AlmansiStrain_ ), POINTER :: Constructor_1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - ALLOCATE( Constructor_1 ) - Constructor_1 = .AlmansiStrain. F - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( B ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using Right Cauchy Green tensor -!. . . . . . . . . . . . . . . . . . . . - - USE LeftCauchyGreen_Class - - ! Define intent of dummy varialbes - CLASS( AlmansiStrain_ ), POINTER :: Constructor_2 - TYPE( LeftCauchyGreen_ ), INTENT( IN ) :: B - - ALLOCATE( Constructor_2 ) - Constructor_2 = 0.5_DFP*( Eye3 - ( .inv. B ) ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy variables - TYPE( AlmansiStrain_ ) :: Constructor1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - Constructor1 = .AlmansiStrain. F - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( B ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using Right Cauchy Green tensor -!. . . . . . . . . . . . . . . . . . . . - - USE LeftCauchyGreen_Class - - ! Define intent of dummy varialbes - TYPE( AlmansiStrain_ ) :: Constructor2 - TYPE( LeftCauchyGreen_ ), INTENT( IN ) :: B - - Constructor2 = 0.5_DFP*( Eye3 - ( .inv. B ) ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - - END MODULE AlmansiStrain_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 deleted file mode 100755 index c6cd51c99..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 +++ /dev/null @@ -1,142 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: GreenStrain_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define GreenStrain Class -!============================================================================== - - MODULE GreenStrain_Class - USE GlobalData - USE IO - USE Strain_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: GreenStrain_, GreenStrain, GreenStrain_Pointer - -!------------------------------------------------------------------------------ -! GreenStrain_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Strain_ ) :: GreenStrain_ - - END TYPE GreenStrain_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE GreenStrain - MODULE PROCEDURE Constructor1, Constructor2 - END INTERFACE - - INTERFACE GreenStrain_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy varialbes - CLASS( GreenStrain_ ), POINTER :: Constructor_1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - ALLOCATE( Constructor_1 ) - Constructor_1 = .GreenStrain. F - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( C ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using Right Cauchy Green tensor -!. . . . . . . . . . . . . . . . . . . . - - USE RightCauchyGreen_Class - - ! Define intent of dummy varialbes - CLASS( GreenStrain_ ), POINTER :: Constructor_2 - TYPE( RightCauchyGreen_ ), INTENT( IN ) :: C - - ALLOCATE( Constructor_2 ) - Constructor_2 = 0.5_DFP*( C - Eye3 ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using deformation gradient tensor -!. . . . . . . . . . . . . . . . . . . . - - USE DeformationGradient_Class - - ! Define intent of dummy variables - TYPE( GreenStrain_ ) :: Constructor1 - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - - Constructor1 = .GreenStrain. F - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( C ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Constructing using Right Cauchy Green tensor -!. . . . . . . . . . . . . . . . . . . . - - USE RightCauchyGreen_Class - - ! Define intent of dummy varialbes - TYPE( GreenStrain_ ) :: Constructor2 - TYPE( RightCauchyGreen_ ), INTENT( IN ) :: C - - - Constructor2 = 0.5_DFP*( C - Eye3 ) - - END FUNCTION Constructor2 - - END MODULE GreenStrain_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 deleted file mode 100755 index 256be7fbd..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 +++ /dev/null @@ -1,88 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SmallStrain_Class.F90 -! Last Update : Dec-30-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define SmallStrain Class -!============================================================================== - - MODULE SmallStrain_Class - USE GlobalData - USE IO - USE Strain_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: SmallStrain_, SmallStrain, SmallStrain_Pointer - -!------------------------------------------------------------------------------ -! SmallStrain_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Strain_ ) :: SmallStrain_ - - END TYPE SmallStrain_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE SmallStrain - MODULE PROCEDURE Constructor1 - END INTERFACE - - INTERFACE SmallStrain_Pointer - MODULE PROCEDURE Constructor_1 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Construction -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy varialbes - CLASS( SmallStrain_ ), POINTER :: Constructor_1 - ALLOCATE( Constructor_1 ) - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Construction -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( SmallStrain_ ) :: Constructor1 - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - - END MODULE SmallStrain_Class - diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 deleted file mode 100755 index 1da7b4374..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 +++ /dev/null @@ -1,96 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Strain_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define Strain Class -!============================================================================== - - MODULE Strain_Class - USE GlobalData - USE IO - USE Rank2Tensor_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: Strain_, Strain, Strain_Pointer - -!------------------------------------------------------------------------------ -! Strain_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Rank2Tensor_ ) :: Strain_ - - END TYPE Strain_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE Strain - MODULE PROCEDURE Constructor1 - END INTERFACE - - INTERFACE Strain_Pointer - MODULE PROCEDURE Constructor_1 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty strain constructor -!. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy varialbes - CLASS( Strain_ ), POINTER :: Constructor_1 - - ALLOCATE( Constructor_1 ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty strain constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( Strain_ ) :: Constructor1 - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - - END MODULE Strain_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 b/src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 deleted file mode 100755 index bd237c8da..000000000 --- a/src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 +++ /dev/null @@ -1,137 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StrainRate_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define StrainRate Class -!============================================================================== - - MODULE StrainRate_Class - USE GlobalData - USE IO - USE Rank2Tensor_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: StrainRate_, StrainRate, StrainRate_Pointer - -!------------------------------------------------------------------------------ -! StrainRate_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Rank2Tensor_ ) :: StrainRate_ - - END TYPE StrainRate_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE StrainRate - MODULE PROCEDURE Constructor1, Constructor2 - END INTERFACE - - INTERFACE StrainRate_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy varialbes - CLASS( StrainRate_ ), POINTER :: Constructor_1 - - ALLOCATE( Constructor_1 ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( L ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - USE VelocityGradient_Class - - ! Define intent of dummy varialbes - CLASS( StrainRate_ ), POINTER :: Constructor_2 - TYPE( VelocityGradient_ ), INTENT( IN ) :: L - - ALLOCATE( Constructor_2 ) - Constructor_2 = .Sym. L - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( StrainRate_ ) :: Constructor1 - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( L ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - USE VelocityGradient_Class - - ! Define intent of dummy varialbes - TYPE( StrainRate_ ) :: Constructor2 - TYPE( VelocityGradient_ ), INTENT( IN ) :: L - - Constructor2 = .Sym. L - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - - END MODULE StrainRate_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part deleted file mode 100755 index de1fbbd70..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part +++ /dev/null @@ -1,109 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: CauchyStress.part -! Last Update : Dec-28-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of Module -! -! Description :: -! - This part includes subroutine for getting Cauchy Stress from -! any other Stress Measures -! Hosting File :: -! - Stress_Class -!============================================================================== - -!------------------------------------------------------------------------------ -! getCauchyStress -!------------------------------------------------------------------------------ - - FUNCTION getCauchyStress( obj, F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. This subroutine computes the Cauchy stress from given stress type -! 2. Fobj is Deformation Gradient object. -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE DeformationGradient_Class - - ! Define arguments of dummy argument - CLASS( Stress_ ), INTENT( IN ) :: obj - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - REAL( DFP ), ALLOCATABLE :: getCauchyStress( :, : ) - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - REAL( DFP ) :: J - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>CauchyStress.part", & - "getCauchyStress()", & - "Stress_ object is not initiated. & - Program Stopped !!!" & - ) - STOP - - END IF - - T = obj - - SELECT CASE( TRIM( obj%StressType ) ) - - CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) - - getCauchyStress = T - - CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) - - J = .det. F - - getCauchyStress = T * ( 1.0_DFP / J ) - - CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) - - J = .det. F - getCauchyStress = ( F .matmul. T ) .matmul. ( .transpose. F ) - getCauchyStress = getCauchyStress * ( 1.0_DFP / J ) - - CASE( "PK1", "Pk1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) - - J = .det. F - getCauchyStress = T .matmul. ( .transpose. F ) - getCauchyStress = getCauchyStress * ( 1.0_DFP / J ) - - CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) - - J = .det. F - getCauchyStress = ( ( .transpose. ( .inv. F ) ) .matmul. T ) .matmul. ( .transpose. F ) - getCauchyStress = getCauchyStress * ( 1.0_DFP / J ) - - - CASE DEFAULT - - CALL Err_Msg( & - "Stress_Class.F90>>CauchyStress.part", & - "getCauchyStress( obj, F )", & - "No case found for obj%StressType. & - Program Stopped!!!" & - ) - STOP - - END SELECT - - CALL T%Deallocate( ) - - END FUNCTION getCauchyStress - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part b/src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part deleted file mode 100755 index afb503a15..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part +++ /dev/null @@ -1,563 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Deformation Gradient class is defined -! HOSTING FILE -! - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Deallocate -!------------------------------------------------------------------------------ - - SUBROUTINE Deallocate( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Deallocate the data -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - IF( ALLOCATED( obj%V ) ) DEALLOCATE( obj%V ) - - END SUBROUTINE Deallocate - -!------------------------------------------------------------------------------ -! isInitiated -!------------------------------------------------------------------------------ - - LOGICAL( LGT ) FUNCTION isInitiated( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Tensor Class -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - isInitiated = .FALSE. - - IF( ALLOCATED( obj%V ) ) THEN - isInitiated = .TRUE. - END IF - - END FUNCTION isInitiated - -!------------------------------------------------------------------------------ -! getNSD -!------------------------------------------------------------------------------ - - INTEGER( I4B ) FUNCTION getNSD( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Tensor Class -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - getNSD = obj%NSD - - END FUNCTION getNSD - -!------------------------------------------------------------------------------ -! getVoigtLen -!------------------------------------------------------------------------------ - - INTEGER( I4B ) FUNCTION getVoigtLen( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Tensor Class -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - IF( ALLOCATED( obj%V ) ) THEN - - getVoigtLen = SIZE( obj%V ) - - ELSE - - CALL Err_Msg( & - "Stress_Class.F90>>Constructor.part", & - ".Size. obj", & - "obj%V is not allocated, Program Stopped!!!"& - ) - - STOP - - END IF - - END FUNCTION getVoigtLen - -!------------------------------------------------------------------------------ -! getNSD -!------------------------------------------------------------------------------ - - SUBROUTINE setNSD( obj, NSD ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Tensor Class -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - INTEGER( I4B ), INTENT( IN ) :: NSD - - obj%NSD = NSD - - END SUBROUTINE setNSD - -!------------------------------------------------------------------------------ -! Initiate1 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate1( obj, Vec, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - ! Define internal variables - INTEGER( I4B ) :: N - - N = SIZE( Vec ) - IF( ALLOCATED( obj%V ) ) DEALLOCATE( obj%V ) - ALLOCATE( obj%V( N ) ) - - obj%V = Vec - - obj%StressType = TRIM( StressType ) - - SELECT CASE( N ) - - CASE( 1 ) - obj%NSD = 1 - CASE( 3 ) - obj%NSD = 2 - CASE( 4 ) - obj%NSD = 2 - CASE( 6 ) - obj%NSD = 3 - - END SELECT - - END SUBROUTINE Initiate1 - -!------------------------------------------------------------------------------ -! Initiate2 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate2( obj, Mat, VoigtLen, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - INTEGER( I4B ), INTENT( IN ) :: VoigtLen - - ! Define internal variable - REAL( DFP ), ALLOCATABLE :: Vec( : ) - - Vec = VoigtVec( Mat, VoigtLen, "Stress") - - CALL Check_Error( & - "Stress_Class.F90>>Constructor.F90>>Initiate()", & - "Traceback ---> obj%V = VoigtVec( Mat, VoigtLen,'Stress') " ) - - CALL obj%Initiate1( Vec = Vec, StressType = StressType ) - - DEALLOCATE( Vec ) - - END SUBROUTINE Initiate2 - -!------------------------------------------------------------------------------ -! Initiate3 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate3( obj, obj2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj Stress obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - CLASS( Stress_ ), INTENT( IN ) :: obj2 - - - IF( ALLOCATED( obj%V ) ) DEALLOCATE( obj%V ) - - IF( ALLOCATED( obj2%V ) ) THEN - - obj%V = obj2%V - - END IF - - obj%StressType = TRIM( obj2%StressType ) - obj%NSD = obj2%NSD - - END SUBROUTINE Initiate3 - -!------------------------------------------------------------------------------ -! Initiate4 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate4( obj, Tensorobj, VoigtLen, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Rank2Tensor object -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - INTEGER( I4B ), INTENT( IN ) :: VoigtLen - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - REAL( DFP ), ALLOCATABLE :: Mat( :, : ) - - Mat = Tensorobj - - CALL obj%Initiate2( Mat = Mat, VoigtLen = VoigtLen, & - StressType = StressType ) - - DEALLOCATE( Mat ) - - END SUBROUTINE Initiate4 - -!------------------------------------------------------------------------------ -! Initiate5 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate5( obj, Mat, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - CALL obj%Initiate2( & - Mat = Mat, & - VoigtLen = 6, & - StressType = StressType & - ) - - END SUBROUTINE Initiate5 - -!------------------------------------------------------------------------------ -! Initiate6 -!------------------------------------------------------------------------------ - - SUBROUTINE Initiate6( obj, Tensorobj, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Rank2Tensor object -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - CALL obj%Initiate4( & - Tensorobj = Tensorobj, & - VoigtLen = 6, & - StressType = StressType & - ) - - END SUBROUTINE Initiate6 - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Vec, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), POINTER :: Constructor_1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - ALLOCATE( Stress_ :: Constructor_1 ) - - CALL Constructor_1%Initiate( Vec = Vec, StressType = StressType ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( Mat, VoigtLen, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), POINTER :: Constructor_2 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - INTEGER( I4B ), INTENT( IN ) :: VoigtLen - - ALLOCATE( Stress_ :: Constructor_2 ) - - CALL Constructor_2%Initiate( Mat = Mat, & - VoigtLen = VoigtLen, StressType = StressType ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), POINTER :: Constructor_3 - CLASS( Stress_ ), INTENT( IN ) :: obj - - ALLOCATE( Stress_ :: Constructor_3 ) - - CALL Constructor_3%Initiate( obj ) - - END FUNCTION Constructor_3 - -!------------------------------------------------------------------------------ -! Constructor_4 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_4( Tensorobj, VoigtLen, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), POINTER :: Constructor_4 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - INTEGER( I4B ), INTENT( IN ) :: VoigtLen - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - ALLOCATE( Stress_ :: Constructor_4 ) - - CALL Constructor_4%Initiate( Tensorobj = Tensorobj, & - VoigtLen = VoigtLen, StressType = StressType ) - - END FUNCTION Constructor_4 - -!------------------------------------------------------------------------------ -! Constructor_5 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_5( Mat, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), POINTER :: Constructor_5 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - ALLOCATE( Stress_ :: Constructor_5 ) - - CALL Constructor_5%Initiate( Mat = Mat, StressType = StressType ) - - END FUNCTION Constructor_5 - -!------------------------------------------------------------------------------ -! Constructor_6 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_6( Tensorobj, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), POINTER :: Constructor_6 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - ALLOCATE( Stress_ :: Constructor_6 ) - - CALL Constructor_6%Initiate( & - Tensorobj = Tensorobj, & - StressType = StressType & - ) - - END FUNCTION Constructor_6 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Vec, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( Stress_ ) :: Constructor1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - CALL Constructor1%Initiate( Vec = Vec, StressType = StressType ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( Mat, VoigtLen, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( Stress_ ) :: Constructor2 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - INTEGER( I4B ), INTENT( IN ) :: VoigtLen - - CALL Constructor2%Initiate( Mat = Mat, & - VoigtLen = VoigtLen, StressType = StressType ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( Stress_ ) :: Constructor3 - CLASS( Stress_ ), INTENT( IN ) :: obj - - CALL Constructor3%Initiate( obj ) - - END FUNCTION Constructor3 - -!------------------------------------------------------------------------------ -! Constructor4 -!------------------------------------------------------------------------------ - - FUNCTION Constructor4( Tensorobj, VoigtLen, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - TYPE( Stress_ ) :: Constructor4 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - INTEGER( I4B ), INTENT( IN ) :: VoigtLen - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - CALL Constructor4%Initiate( Tensorobj = Tensorobj, & - VoigtLen = VoigtLen, StressType = StressType ) - - END FUNCTION Constructor4 - -!------------------------------------------------------------------------------ -! Constructor5 -!------------------------------------------------------------------------------ - - FUNCTION Constructor5( Mat, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( Stress_ ) :: Constructor5 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - CALL Constructor5%Initiate( & - Mat = Mat, & - StressType = StressType & - ) - - END FUNCTION Constructor5 - -!------------------------------------------------------------------------------ -! Constructor6 -!------------------------------------------------------------------------------ - - FUNCTION Constructor6( Tensorobj, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate obj using Voigt vector -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - TYPE( Stress_ ) :: Constructor6 - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - CALL Constructor6%Initiate( & - Tensorobj = Tensorobj, & - StressType = StressType & - ) - - END FUNCTION Constructor6 diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Display.part b/src/submodules/Rank2Tensor/src/old data/Stress/Display.part deleted file mode 100755 index 566926b7c..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/Display.part +++ /dev/null @@ -1,71 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Display.part -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Display Stress Tensor -! HOSTING FILE -! - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Display -!------------------------------------------------------------------------------ - - SUBROUTINE Display( obj, UnitNo ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Display Stress Tensor -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : Display_Array - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo - - ! Define internal variables - INTEGER( I4B ) :: I, j - - IF( PRESENT( UnitNo ) ) THEN - I = UnitNo - ELSE - I = 6 - END IF - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL BlankLines( UnitNo = I ) - WRITE( I, "(A)" ) "Stress_ object is not initiated " - WRITE( I, "(A)" ) "Nothing to show " - CALL BlankLines( UnitNo = I ) - RETURN - - END IF - - CALL BlankLines( UnitNo = I ) - CALL EqualLine( UnitNo = I ) - WRITE( I, "(12X, A)" ) "|||| Stress obj Data ||||" - CALL EqualLine( UnitNo = I ) - CALL BlankLines( UnitNo = I ) - - WRITE( I, "(A, I2)" ) "NSD = ", obj%NSD - CALL BlankLines( UnitNo = I ) - WRITE( I, "(A, A)" ) "Stress Type = ", TRIM( obj%StressType ) - - CALL Display_Array( MatFromVoigtVec( obj%V, "Stress" ), "Stress " ) - - CALL DashLine( UnitNo = I ) - - END SUBROUTINE Display \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part deleted file mode 100755 index ebbbbfbd0..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part +++ /dev/null @@ -1,106 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: EshelbyStress.part -! Last Update : Dec-28-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of Module -! -! Description :: -! - This part includes subroutine for getting Eshelby Stress from -! any other Stress Measures -! Hosting File :: -! - Stress_Class -!============================================================================== - -!------------------------------------------------------------------------------ -! getEshelbyStress -!------------------------------------------------------------------------------ - - FUNCTION getEshelbyStress( obj, F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. This subroutine computes the Cauchy stress from given stress type -! 2. Fobj is Deformation Gradient object. -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE DeformationGradient_Class - - ! Define arguments of dummy argument - CLASS( Stress_ ), INTENT( IN ) :: obj - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - REAL( DFP ), ALLOCATABLE :: getEshelbyStress( :, : ) - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - REAL( DFP ), ALLOCATABLE :: InvF( :, : ) - REAL( DFP ) :: J - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>EshelbyStress.part", & - "getEshelbyStress()", & - "Stress_ object is not initiated. & - Program Stopped !!!" & - ) - STOP - - END IF - - T = obj - - SELECT CASE( TRIM( obj%StressType ) ) - - CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) - - J = .det. F - InvF = .Inv. F - getEshelbyStress = (.transpose. F ) .matmul. ( T .matmul. TRANSPOSE( InvF ) ) - getEshelbyStress = J * getEshelbyStress - - CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) - - InvF = .Inv. F - getEshelbyStress = (.transpose. F ) .matmul. ( T .matmul. TRANSPOSE( InvF ) ) - - CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) - - getEshelbyStress = ( (.transpose. F ) .matmul. F ) .matmul. T - - CASE( "PK1", "Pk1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) - - getEshelbyStress = ( .transpose. F ) .matmul. T - - CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) - - getEshelbyStress = T - - CASE DEFAULT - - CALL Err_Msg( & - "Stress_Class.F90>>EshelbyStress.part", & - "getEshelbyStress( obj, F )", & - "No case found for obj%StressType. & - Program Stopped!!!" & - ) - STOP - - END SELECT - - CALL T%Deallocate( ) - IF( ALLOCATED( InvF ) ) DEALLOCATE( InvF ) - - END FUNCTION getEshelbyStress - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Interface.part b/src/submodules/Rank2Tensor/src/old data/Stress/Interface.part deleted file mode 100755 index e69de29bb..000000000 diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part deleted file mode 100755 index f6b566b8f..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part +++ /dev/null @@ -1,101 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: KirchhoffStress.part -! Last Update : Dec-28-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of Module -! -! Description :: -! - This part includes subroutine for getting Kirchhoff Stress from -! any other Stress Measures -! Hosting File :: -! - Stress_Class -!============================================================================== - -!------------------------------------------------------------------------------ -! getKirchhoffStress -!------------------------------------------------------------------------------ - - FUNCTION getKirchhoffStress( obj, F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. This subroutine computes the Cauchy stress from given stress type -! 2. Fobj is Deformation Gradient object. -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE DeformationGradient_Class - - ! Define arguments of dummy argument - CLASS( Stress_ ), INTENT( IN ) :: obj - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - REAL( DFP ), ALLOCATABLE :: getKirchhoffStress( :, : ) - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - REAL( DFP ) :: J - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>KirchhoffStress.part", & - "getKirchhoffStress()", & - "Stress_ object is not initiated. & - Program Stopped !!!" & - ) - STOP - - END IF - - T = obj - - SELECT CASE( TRIM( obj%StressType ) ) - - CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) - - J = .det. F - getKirchhoffStress = T * J - - CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) - - getKirchhoffStress = T - - CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) - - getKirchhoffStress = ( F .matmul. T ) .matmul. ( .transpose. F ) - - CASE( "PK1", "Pk1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) - - getKirchhoffStress = T .matmul. ( .transpose. F ) - - CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) - - getKirchhoffStress = ( ( .transpose. ( .inv. F ) ) .matmul. T ) .matmul. ( .transpose. F ) - - CASE DEFAULT - - CALL Err_Msg( & - "Stress_Class.F90>>KirchhoffStress.part", & - "getKirchhoffStress( obj, F )", & - "No case found for obj%StressType. & - Program Stopped!!!" & - ) - STOP - - END SELECT - - CALL T%Deallocate( ) - - END FUNCTION getKirchhoffStress - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md b/src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md deleted file mode 100755 index 79e2678af..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md +++ /dev/null @@ -1,128 +0,0 @@ -# Stress Class - -## ToDo - -* Extend Assignment operator for `obj = Mat`. This should not change the stress type -* Extend Assignment operator for `obj = Vec`. This should not change the stress type - -## Structure - -```fortran - TYPE, PUBLIC :: Stress_ - REAL( DFP ), ALLOCATABLE :: V( : ) - INTEGER( I4B ) :: NSD - CHARACTER( LEN = 50 ) :: StressType = "" -``` - -## Description - -## Getting Started - -### Constructing the object - -**Initiate** subroutine - -```fortran -CALL obj%Initiate( Vec, StresType ) -CALL obj%Initiate( Mat, VoigtLen, StressType ) -CALL obj%Initiate( Mat, StressType ) -CALL obj%Initiate( obj2 ) -CALL obj%Initiate( Tensorobj, VoigtLen, StressType ) -CALL obj%Initiate( Tensorobj, StressType ) -``` - -**Stress** function - -```fortran -obj = Stress( Vec, StresType ) -obj = Stress( Mat, VoigtLen, StressType ) -obj = Stress( Mat, StressType ) -obj = Stress( obj2 ) -obj = Stress( Tensorobj, VoigtLen, StressType ) -obj = Stress( Tensorobj, StressType ) -``` - -**Stress_Pointer** function - -```fortran -obj => Stress_Pointer( Vec, StresType ) -obj => Stress_Pointer( Mat, VoigtLen, StressType ) -obj => Stress_Pointer( Mat, StressType ) -obj => Stress_Pointer( obj2 ) -obj => Stress_Pointer( Tensorobj, VoigtLen, StressType ) -obj => Stress_Pointer( Tensorobj, StressType ) -``` - -### Getting the length of `obj%V` - -```fortran -tSize = .SIZE. obj -``` - -The program stops if the `obj%V` is not allocated. - -### Getting the Stress Tensor in Voigt Form - -Many times we need to get the stress tensor in voigt vector form with appropriate length. When we use `obj = Mat` then the voigt vector length will be 6 even if the Mat retpresent the 2D, Rank-2 tensor. Therefore, it is very important to get voigt vector of correct length. For this we have designed the operator called `.Shape.`. `obj .Shape. M` will return voigt vector of length M. - -```fortran -Vec = obj .Shape. M -``` - -Note that M should belong to the list {1,2,3,4,6}. - - -### Assignment Operator - -```fortran -obj = obj2 -Tensorobj = obj -Mat = obj -Vec = obj -obj = Mat -obj = Tensorobj -obj = Vec -``` - -```fortran -obj = obj2 -``` - -The above call we copy `obj2` into `obj` - - -```fortran -Tensorobj = obj -``` - -The above call copies the content of `obj` into Rank2Tensor_ class object `Tensorobj` - -```fortran -Mat = obj -``` - -The above call copies the content of `obj` into the 3 by 3 array. - -```fortran -Vec = obj -``` - -The above call copies the content of the `obj` into the vector. The length of the returned vector is same as the length of `obj%V` - -```fortran -obj = Mat -``` - -The above call copies the content of `Mat` into the stress object `obj`. The `StressType` remains unchanged. - -```fortran -obj = Vec -``` - -The above call copies the content of the `Vec` into the stress object `obj`. The `StressType` remains unchanged. - -```fortran -obj = Tensorobj -``` - -The above call copies the content of the `Rank2Tensor_` object into the stress object `obj`. The `StressType` remains unchanged. \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part deleted file mode 100755 index 9d90a8a89..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part +++ /dev/null @@ -1,372 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Addition.part -! Last Update : Dec-18-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Addition of Stress tensor, returns (3,3) array -! HOSTING FILE -! - Rank2Tensor_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_obj( obj, obj2 ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_obj - - obj_Add_obj = MatFromVoigtVec(obj%V + obj2%V, "Stress") - - END FUNCTION obj_Add_obj - -!------------------------------------------------------------------------------ -! obj_Add_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_Mat( obj, Mat ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Mat - - ! Define internal variables - INTEGER( I4B ) :: N - - N = SIZE( Mat, 1 ) - - obj_Add_Mat = MatFromVoigtVec( obj%V, "Stress" ) - - SELECT CASE( N ) - - CASE( 1 ) - - obj_Add_Mat( 1, 1 ) = obj_Add_Mat( 1, 1 ) + Mat( 1, 1 ) - - CASE( 2 ) - - obj_Add_Mat( 1:2, 1:2 ) = obj_Add_Mat( 1:2, 1:2 ) & - + Mat( 1:2, 1:2 ) - - CASE DEFAULT - - obj_Add_Mat( 1:3, 1:3 ) = obj_Add_Mat( 1:3, 1:3 ) & - + Mat( 1:3, 1:3 ) - - END SELECT - - END FUNCTION obj_Add_Mat - -!------------------------------------------------------------------------------ -! Mat_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_Add_obj( Mat, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat + obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Add_obj - - Mat_Add_obj = obj_Add_Mat( obj, Mat ) - - END FUNCTION Mat_Add_obj - -!------------------------------------------------------------------------------ -! obj_Add_Vec -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_Vec( obj, Vec ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Vec - - ! Define internal variables - INTEGER( I4B ) :: N - REAL( DFP ), ALLOCATABLE :: DummyVec( : ) - - - DummyVec = obj%V - - N = MINVAL( [SIZE( Vec ), SIZE( DummyVec ) ]) - - DummyVec( 1:N ) = DummyVec( 1:N ) + Vec( 1:N ) - - obj_Add_Vec = MatFromVoigtVec( DummyVec, "Stress" ) - - DEALLOCATE( DummyVec ) - - END FUNCTION obj_Add_Vec - -!------------------------------------------------------------------------------ -! obj_Add_Scalar -!------------------------------------------------------------------------------ - - FUNCTION obj_Add_Scalar( obj, S ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Scalar - - obj_Add_Scalar = MatFromVoigtVec( obj%V + S, "Stress" ) - - END FUNCTION obj_Add_Scalar - -!------------------------------------------------------------------------------ -! obj_Add_Scalar -!------------------------------------------------------------------------------ - - FUNCTION Scalar_Add_obj( S, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Add_obj - - Scalar_Add_obj = obj_Add_Scalar( obj, S ) - - END FUNCTION Scalar_Add_obj - -!------------------------------------------------------------------------------ -! Vec_Add_obj -!------------------------------------------------------------------------------ - - FUNCTION Vec_Add_obj( Vec, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3, 3 ) :: Vec_Add_obj - - Vec_Add_obj = obj_Add_Vec( obj, Vec ) - - END FUNCTION Vec_Add_obj - - -!------------------------------------------------------------------------------ -! obj_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_obj( obj, obj2 ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_obj - - obj_Minus_obj = MatFromVoigtVec( obj%V - obj2%V, "Stress" ) - - END FUNCTION obj_Minus_obj - -!------------------------------------------------------------------------------ -! obj_Minus_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_Mat( obj, Mat ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Mat - - ! Define internal variables - INTEGER( I4B ) :: N - - N = SIZE( Mat, 1 ) - - obj_Minus_Mat = MatFromVoigtVec( obj%V, "Stress" ) - - SELECT CASE( N ) - - CASE( 1 ) - - obj_Minus_Mat( 1, 1 ) = obj_Minus_Mat( 1, 1 ) - Mat( 1, 1 ) - - CASE( 2 ) - - obj_Minus_Mat( 1:2, 1:2 ) = obj_Minus_Mat( 1:2, 1:2 ) & - - Mat( 1:2, 1:2 ) - - CASE DEFAULT - - obj_Minus_Mat( 1:3, 1:3 ) = obj_Minus_Mat( 1:3, 1:3 ) & - - Mat( 1:3, 1:3 ) - - END SELECT - - END FUNCTION obj_Minus_Mat - -!------------------------------------------------------------------------------ -! Mat_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_Minus_obj( Mat, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat + obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Minus_obj - - Mat_Minus_obj = -obj_Minus_Mat( obj, Mat ) - - END FUNCTION Mat_Minus_obj - -!------------------------------------------------------------------------------ -! obj_Minus_Vec -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_Vec( obj, Vec ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Vec - - ! Define internal variables - INTEGER( I4B ) :: N - REAL( DFP ), ALLOCATABLE :: DummyVec( : ) - - DummyVec = obj%V - - N = MINVAL( [SIZE( Vec ), SIZE( DummyVec ) ]) - - DummyVec( 1:N ) = DummyVec( 1:N ) - Vec( 1:N ) - - obj_Minus_Vec = MatFromVoigtVec( DummyVec, "Stress" ) - - DEALLOCATE( DummyVec ) - - END FUNCTION obj_Minus_Vec - -!------------------------------------------------------------------------------ -! Vec_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION Vec_Minus_obj( Vec, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3, 3 ) :: Vec_Minus_obj - - Vec_Minus_obj = -obj_Minus_Vec( obj, Vec ) - - END FUNCTION Vec_Minus_obj - -!------------------------------------------------------------------------------ -! obj_Minus_Scalar -!------------------------------------------------------------------------------ - - FUNCTION obj_Minus_Scalar( obj, S ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Scalar - - obj_Minus_Scalar = MatFromVoigtVec( obj%V - S, "Stress" ) - - END FUNCTION obj_Minus_Scalar - -!------------------------------------------------------------------------------ -! Scalar_Minus_obj -!------------------------------------------------------------------------------ - - FUNCTION Scalar_Minus_obj( S, obj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj + Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: S - REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Minus_obj - - Scalar_Minus_obj = -obj_Minus_Scalar( obj, S ) - - END FUNCTION Scalar_Minus_obj - - - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part deleted file mode 100755 index 7480473a5..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part +++ /dev/null @@ -1,94 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Assignment.part -! Last Update : Jan-1-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - Assignment operator is overloaded -! HOSTING FILE -! - Stress_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_From_Tensor -!------------------------------------------------------------------------------ - - SUBROUTINE obj_From_Tensor( obj, Tensorobj ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj = Tensorobj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - - ! Define internal variables - CHARACTER( LEN = 50 ) :: Str - - Str = .StressType. obj - - CALL obj%Initiate( Tensorobj, Str ) - - END SUBROUTINE obj_From_Tensor - -!------------------------------------------------------------------------------ -! obj_From_Mat -!------------------------------------------------------------------------------ - - SUBROUTINE obj_From_Mat( obj, Mat ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj = Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Mat( :, : ) - - ! Define internal variables - CHARACTER( LEN = 50 ) :: Str - - Str = .StressType. obj - - CALL obj%Initiate( Mat, Str ) - - END SUBROUTINE obj_From_Mat - -!------------------------------------------------------------------------------ -! obj_From_Vec -!------------------------------------------------------------------------------ - - SUBROUTINE obj_From_Vec( obj, Vec ) - -! DESCRIPTION -!. . . . . . . . . . . . . . . . . . . . -! 1. obj = Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - REAL( DFP ), INTENT( IN ) :: Vec( : ) - - ! Define internal variables - CHARACTER( LEN = 50 ) :: Str - - Str = .StressType. obj - - CALL obj%Initiate( Vec, Str ) - - END SUBROUTINE obj_From_Vec - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part deleted file mode 100755 index e793a83f1..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part +++ /dev/null @@ -1,445 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Asterics.part -! Last Update : Dec-13-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION :: -! - Tensor class is defined -! HOSTING FILE -! - Stress_Class.F90 -!============================================================================== - -!------------------------------------------------------------------------------ -! objTimesScalar_1 -!------------------------------------------------------------------------------ - - FUNCTION objTimesScalar_1( obj, Scalar ) - -!. . . . . . . . . . . . . . . . . . . . -! obj * Scalar -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesScalar_1 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * Real", & - "Stress_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - objTimesScalar_1 = MatFromVoigtVec(obj%V * Scalar, "Stress") - - CALL Check_Error( & - "Stress_Class.F90>>Asterics.part>>obj*Scalar", & - "Traceback ---> & - objTimesScalar_1 = MatFromVoigtVec(obj%V * Scalar,") - - END FUNCTION objTimesScalar_1 - -!------------------------------------------------------------------------------ -! ScalarTimesobj_1 -!------------------------------------------------------------------------------ - - FUNCTION ScalarTimesobj_1( Scalar, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! Scalar*obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: ScalarTimesobj_1 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "Real * obj",& - "Stress_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - ScalarTimesobj_1 = MatFromVoigtVec(obj%V * Scalar, "Stress") - - CALL Check_Error( & - "Stress_Class.F90>>Asterics.part>>obj*Scalar", & - "Traceback ---> & - ScalarTimesobj_1 = MatFromVoigtVec(obj%V * Scalar,") - - END FUNCTION ScalarTimesobj_1 -! -!------------------------------------------------------------------------------ -! objTimesScalar_2 -!------------------------------------------------------------------------------ -! - FUNCTION objTimesScalar_2( obj, Scalar ) -! -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . -! - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesScalar_2 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * Integer", & - "Stress_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - objTimesScalar_2 = MatFromVoigtVec(obj%V * Scalar, "Stress") - - CALL Check_Error( & - "Stress_Class.F90>>Asterics.part>>obj*Scalar", & - "Traceback ---> & - objTimesScalar_2 = MatFromVoigtVec(obj%V * Scalar,") - - END FUNCTION objTimesScalar_2 - -!------------------------------------------------------------------------------ -! ScalarTimesobj_2 -!------------------------------------------------------------------------------ - - FUNCTION ScalarTimesobj_2( Scalar, obj ) -! -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . -! - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: Scalar - REAL( DFP ), DIMENSION( 3, 3 ) :: ScalarTimesobj_2 - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "Integer * obj", & - "Stress_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - ScalarTimesobj_2 = MatFromVoigtVec(obj%V * Scalar, "Stress") - - CALL Check_Error( & - "Stress_Class.F90>>Asterics.part>>obj*Scalar", & - "Traceback ---> & - ScalarTimesobj_2 = MatFromVoigtVec(obj%V * Scalar,") - - END FUNCTION ScalarTimesobj_2 - -!------------------------------------------------------------------------------ -! objTimesobj -!------------------------------------------------------------------------------ - - FUNCTION objTimesobj( obj, obj2 ) - -!. . . . . . . . . . . . . . . . . . . . -! obj%V * obj%V -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesobj - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) & - .OR. .NOT. ALLOCATED( obj2%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * obj", & - "Stress_ obj is/are not allocated. & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - IF( SIZE( obj%V ) .NE. SIZE( obj2%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * obj2 ", & - "The size of obj%V and obj2%V must be the same. & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - objTimesobj = MatFromVoigtVec( obj%V * obj2%V, "Stress" ) - - CALL Check_Error( & - "Stress_Class.F90>>Asterics.part>>obj*Scalar", & - "Traceback ---> & - objTimesobj = MatFromVoigtVec( obj%V * obj2%V,") - - END FUNCTION objTimesobj - -!------------------------------------------------------------------------------ -! objTimesMat -!------------------------------------------------------------------------------ - - FUNCTION objTimesMat( obj, Mat ) - -!. . . . . . . . . . . . . . . . . . . . -! obj * Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesMat - - ! Define internal variables - INTEGER( I4B ) :: m, n - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * Mat", & - "Stress_ obj not allocated. & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - m = SIZE( Mat, 1 ) - - IF( SIZE( Mat, 2 ) .NE. m .OR. m .GT. 3 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * Mat", & - "Mat should be a square matrix of shape & - (3,3), (2,2), (1,1). & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - objTimesMat = MatFromVoigtVec( obj%V, "Stress" ) - - CALL Check_Error( & - "Stress_Class.F90>>Asterics.part>>obj*Scalar", & - "Traceback ---> & - objTimesMat = MatFromVoigtVec( obj%V,") - - n = MIN( m, 3 ) - - objTimesMat( 1:n, 1:n ) = objTimesMat( 1:n, 1:n ) * Mat( 1:n, 1:n ) - - END FUNCTION objTimesMat - -!------------------------------------------------------------------------------ -! MatTimesobj -!------------------------------------------------------------------------------ - - FUNCTION MatTimesobj( Mat, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! Mat * obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 3, 3 ) :: MatTimesobj - - MatTimesobj = objTimesMat( obj, Mat ) - - END FUNCTION MatTimesobj - -!------------------------------------------------------------------------------ -! objTimesTensor -!------------------------------------------------------------------------------ - - FUNCTION objTimesTensor( obj, Tensorobj ) - -!. . . . . . . . . . . . . . . . . . . . -! obj * Tensorobj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesTensor - - REAL( DFP ), ALLOCATABLE :: Mat( :, : ) - - Mat = Tensorobj - - objTimesTensor = objTimesMat( obj, Mat ) - - DEALLOCATE( Mat ) - - END FUNCTION objTimesTensor - -!------------------------------------------------------------------------------ -! TensorTimesobj -!------------------------------------------------------------------------------ - - FUNCTION TensorTimesobj( Tensorobj, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! obj * Tensorobj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesobj - - REAL( DFP ), ALLOCATABLE :: Mat( :, : ) - - Mat = Tensorobj - - TensorTimesobj = objTimesMat( obj, Mat ) - - DEALLOCATE( Mat ) - - END FUNCTION TensorTimesobj - -!------------------------------------------------------------------------------ -! objTimesVector -!------------------------------------------------------------------------------ - - FUNCTION objTimesVector( obj, Vec ) - -!. . . . . . . . . . . . . . . . . . . . -! obj * VoigtVec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesVector - - ! Define internal variables - INTEGER( I4B ) :: m - REAL( DFP ) :: DummyVec( 6 ) - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * Vector", & - "Stress_ obj is not allocated. & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - m = SIZE( Vec ) - - IF( m .GT. 6 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Asterics.part", & - "obj * Vector", & - "The Length of Vec should be less than or equal to 6. & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - DummyVec = 1.0_DFP - DummyVec( 1 : m ) = Vec( 1 : m ) - - objTimesVector = objTimesMat( obj, MatFromVoigtVec( DummyVec, "Stress" ) ) - - END FUNCTION objTimesVector - -!------------------------------------------------------------------------------ -! VectorTimesobj -!------------------------------------------------------------------------------ - - FUNCTION VectorTimesobj( Vec, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! VoigtVec * obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3, 3 ) :: VectorTimesobj - - ! Define internal variables - - VectorTimesobj = objTimesVector( obj, Vec ) - - END FUNCTION VectorTimesobj diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part deleted file mode 100755 index 573d02353..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part +++ /dev/null @@ -1,346 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Invariants.part -! Last Update : Dec-18-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of module -! -! Info:: - This part contains the subroutines related to -! the tensor invariants. - -! Hosting File - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Invar_I1 -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_I1( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. - Returns the trace of a tensor -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - TYPE( Rank2Tensor_ ) :: T - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Invariant.part", & - "Invar_I1()", & - "Stress_ object is not allocated. & - Program Stopped !!!") - - STOP - - END IF - - T = obj - Invar_I1 = Trace( T ) - CALL T%Deallocate( ) - - END FUNCTION Invar_I1 - -!------------------------------------------------------------------------------ -! Invar_I2 -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_I2( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. - Returns I2 invariant -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Invariant.part", & - "Invar_I2()", & - "Stress_ object is not allocated. & - Program Stopped !!!") - - STOP - - END IF - - T = obj - Invar_I2 = Invariant_I2( T ) - CALL T%Deallocate( ) - - END FUNCTION Invar_I2 - -!------------------------------------------------------------------------------ -! Invar_I3 -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_I3( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns I3 invariant -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Invariant.part", & - "Invar_I3()", & - "Stress_ object is not allocated. & - Program Stopped !!!") - - STOP - - END IF - - T = obj - Invar_I3 = Invariant_I3( T ) - CALL T%Deallocate( ) - - END FUNCTION Invar_I3 - -!------------------------------------------------------------------------------ -! Invar_J2 -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_J2( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns J2 = 0.5*Dev( Sigma ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Invariant.part", & - "Invar_J2()", & - "Stress_ object is not allocated. & - Program Stopped !!!") - - STOP - - END IF - - T = obj - Invar_J2 = Invariant_J2( T ) - CALL T%Deallocate( ) - - END FUNCTION Invar_J2 - -!------------------------------------------------------------------------------ -! Invar_J3 -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_J3( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns Det( Dev( Sigma )) -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Invariant.part", & - "Invar_J3()", & - "Stress_ object is not allocated. & - Program Stopped !!!") - - STOP - - END IF - - T = obj - Invar_J3 = Invariant_J3( T ) - CALL T%Deallocate( ) - - END FUNCTION Invar_J3 - -!------------------------------------------------------------------------------ -! Sigma_m -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Sigma_m( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns Det( Dev( Sigma )) -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - - Sigma_m = Invar_I1( obj ) / 3.0_DFP - - END FUNCTION Sigma_m - -!------------------------------------------------------------------------------ -! Sigma_Bar -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Sigma_Bar( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. Sigma_Bar = SQRT( 3 * J2 ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - - Sigma_Bar = SQRT( Invar_J2( obj ) * 3.0_DFP ) - - END FUNCTION Sigma_Bar - -!------------------------------------------------------------------------------ -! Invar_Z -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_Z( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. Invar_Z = Sigma_m / SQRT( 3 ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - - Invar_Z = Sigma_m( obj ) / SQRT( 3.0_DFP ) - - END FUNCTION Invar_Z - -!------------------------------------------------------------------------------ -! Invar_r -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_r( obj ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. Invar_r = SQRT( 2 * J2 ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variabless - - Invar_r = SQRT( 2.0_DFP * Invar_J2( obj ) ) - - END FUNCTION Invar_r - -!------------------------------------------------------------------------------ -! m_Invar_LodeAngle -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION m_Invar_LodeAngle( obj, LodeAngleType ) - - USE Rank2Tensor_Class - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. LodeAngleType "Sine", "Cosine" -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType - - TYPE( Rank2Tensor_ ) :: T - -! Check the existence of obj - T = obj - m_Invar_LodeAngle = LodeAngle( T, LodeAngleType ) - - CALL T%Deallocate( ) - - END FUNCTION m_Invar_LodeAngle - -!------------------------------------------------------------------------------ -! Invar_LodeAngle -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION Invar_LodeAngle( obj ) - -! Description -!. . . . . . . . . . . . . . . . . . . . -! 1. In this case Lode angle is "Sine" type. -! This method will be used for defining the operator -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - - Invar_LodeAngle = m_Invar_LodeAngle( obj, "Sine" ) - - END FUNCTION Invar_LodeAngle - - - - - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part deleted file mode 100755 index a3860a8f4..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part +++ /dev/null @@ -1,334 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MatMul.part -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESsCRIPTION -! - Matrix multiplication operator -! HOSTING FILE -! - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_matmul_obj -!------------------------------------------------------------------------------ -! - FUNCTION obj_matmul_obj( obj, obj2 ) - -!. . . . . . . . . . . . . . . . . . . . -! obj .matmul. obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_matmul_obj - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Mat1( :, : ), Mat2( :, : ) - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) & - .OR. .NOT. ALLOCATED( obj2%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "obj_matmul_obj()", & - "Stress_ obj is/are not allocated. Program Stopped"& - ) - Error_Flag = .TRUE. - - STOP - - END IF - - CALL obj%getStress( Mat1 ) - CALL obj%getStress( Mat2 ) - - CALL Display_Array( Mat1, "Debug:: obj_matmul_obj :: Mat1 =") - - obj_matmul_obj = MATMUL( Mat1, Mat2 ) - - DEALLOCATE( Mat1, Mat2 ) - - END FUNCTION obj_matmul_obj - -!------------------------------------------------------------------------------ -! obj_matmul_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_matmul_Mat( obj, Mat2 ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. - obj .matmul. Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_matmul_Mat - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "obj_matmul_Mat()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - T = obj - - obj_matmul_Mat = T .matmul. Mat2 - - CALL T%Deallocate( ) - - END FUNCTION obj_matmul_Mat - -!------------------------------------------------------------------------------ -! obj_matmul_Vec -!------------------------------------------------------------------------------ - - FUNCTION obj_matmul_Vec( obj, Vec ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. - obj .matmul. Vec -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: obj_matmul_Vec - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "obj_matmul_Vec()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - - IF( SIZE( Vec ) .GT. 3 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "obj_matmul_Vec()", & - "The size of Vec should be less than or equal to 3. & - Program Stopped" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - T = obj - - obj_matmul_Vec = T .matmul. Vec - - CALL T%Deallocate( ) - - END FUNCTION obj_matmul_Vec - -!------------------------------------------------------------------------------ -! Vec_matmul_obj -!------------------------------------------------------------------------------ - - FUNCTION Vec_matmul_obj( Vec, obj ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Vec .matmul. obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 3 ) :: Vec_matmul_obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "Vec_matmul_obj()", & - "Stress_ obj is not allocated. & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - IF( SIZE( Vec ) .GT. 3 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "Vec_matmul_obj()", & - "The size of Vec should be less than or equal to 3. & - Program Stopped !!!" & - ) - Error_Flag = .TRUE. - - STOP - - END IF - - T = obj - - Vec_matmul_obj = Vec .matmul. T - - CALL T%Deallocate( ) - - END FUNCTION Vec_matmul_obj - -!------------------------------------------------------------------------------ -! Mat_matmul_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_matmul_obj( Mat2, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat .matmul. obj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 - REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_matmul_obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "Mat_matmul_obj()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - - END IF - - T = obj - Mat_matmul_obj = Mat2 .matmul. T - CALL T%Deallocate( ) - - END FUNCTION Mat_matmul_obj - -!------------------------------------------------------------------------------ -! obj_matmul_Tensor -!------------------------------------------------------------------------------ - - FUNCTION obj_matmul_Tensor( obj, Tensorobj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .matmul. Tensorobj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ), DIMENSION( 3, 3 ) :: obj_matmul_Tensor - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "obj_matmul_Tensor()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - - END IF - - T = obj - obj_matmul_Tensor = T .matmul. Tensorobj - CALL T%Deallocate( ) - - END FUNCTION obj_matmul_Tensor - -!------------------------------------------------------------------------------ -! Tensor_matmul_obj -!------------------------------------------------------------------------------ - - FUNCTION Tensor_matmul_obj( Tensorobj, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Tensor .matmul. obj -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ), DIMENSION( 3, 3 ) :: Tensor_matmul_obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Matmul.part", & - "Tensor_matmul_obj()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - - END IF - - T = obj - Tensor_matmul_obj = Tensorobj .matmul. T - CALL T%Deallocate( ) - - END FUNCTION Tensor_matmul_obj diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part deleted file mode 100755 index a7fd38983..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part +++ /dev/null @@ -1,422 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Otimes.part -! Last Update : Dec-18-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION :: -! - Dyadic product for stress class is defined -! HOSTING FILE -! - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! obj_Otimes_obj -!------------------------------------------------------------------------------ - - FUNCTION obj_Otimes_obj( obj, obj2 ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. obj2 -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - - CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 - REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T1, T2 - - IF( .NOT. ALLOCATED( obj%V ) & - .OR. .NOT. ALLOCATED( obj2%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "obj_Otimes_obj()", & - "Stress_ obj is/are not allocated. Program Stopped"& - ) - Error_Flag = .TRUE. - - STOP - - END IF - - T1 = obj - T2 = obj2 - - obj_Otimes_obj = T1 .otimes. T2 - - CALL T1%Deallocate( ) - CALL T2%Deallocate( ) - - END FUNCTION obj_Otimes_obj - -!------------------------------------------------------------------------------ -! obj_Otimes_Mat -!------------------------------------------------------------------------------ - - FUNCTION obj_Otimes_Mat( obj, Mat ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. Mat -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_Mat - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - INTEGER( I4B ) :: N - REAL ( DFP ) :: DummyMat( 3, 3 ) - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "obj_Otimes_Mat()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - END IF - - N = SIZE( Mat, 1 ) - - IF( SIZE( Mat, 2 ) .NE. N .OR. N .GT. 3 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "obj_Otimes_Mat()", & - "Mat should be square matrix, & - and Size should be less than equal to 3, & - Program Stopped!!!" & - ) - STOP - - END IF - - DummyMat = 0.0_DFP - DummyMat( 1:N, 1:N ) = Mat( 1:N, 1:N ) - - T = obj - - obj_Otimes_Mat = T .Otimes. DummyMat - - CALL T%Deallocate( ) - - END FUNCTION obj_Otimes_Mat - -!------------------------------------------------------------------------------ -! Mat_Otimes_obj -!------------------------------------------------------------------------------ - - FUNCTION Mat_Otimes_obj( Mat, obj ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. Mat .otimes. obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat - REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Otimes_obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - INTEGER( I4B ) :: N - REAL ( DFP ) :: DummyMat( 3, 3 ) - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "Mat_Otimes_obj()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - END IF - - N = SIZE( Mat, 1 ) - - IF( SIZE( Mat, 2 ) .NE. N .OR. N .GT. 3 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "Mat_Otimes_obj()", & - "Mat should be square matrix, & - and Size should be less than equal to 3, & - Program Stopped!!!" & - ) - STOP - - END IF - - DummyMat = 0.0_DFP - DummyMat( 1:N, 1:N ) = Mat( 1:N, 1:N ) - - T = obj - - Mat_Otimes_obj = DummyMat .Otimes. T - - CALL T%Deallocate( ) - - END FUNCTION Mat_Otimes_obj - -!------------------------------------------------------------------------------ -! obj_Otimes_Tensor -!------------------------------------------------------------------------------ - - FUNCTION obj_Otimes_Tensor( obj, Tensorobj ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. Tensor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_Tensor - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "obj_Otimes_Tensor()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - END IF - - T = obj - - obj_Otimes_Tensor = T .Otimes. Tensorobj - - CALL T%Deallocate( ) - - END FUNCTION obj_Otimes_Tensor - -!------------------------------------------------------------------------------ -! Tensor_Otimes_obj -!------------------------------------------------------------------------------ - - FUNCTION Tensor_Otimes_obj( Tensorobj, obj ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. Tensor .otimes. obj -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj - REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Otimes_obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "Tensor_Otimes_obj()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - END IF - - T = obj - - Tensor_Otimes_obj = Tensorobj .Otimes. T - - CALL T%Deallocate( ) - - END FUNCTION Tensor_Otimes_obj - -!------------------------------------------------------------------------------ -! obj_Otimes_Vec -!------------------------------------------------------------------------------ - - FUNCTION obj_Otimes_Vec( obj, Vec ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. Vec -! 2. Vec is voigt vector of type stress -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_Vec - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T1, T2 - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "obj_Otimes_Vec()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - - END IF - - IF( SIZE( Vec ) .GT. 6 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "obj_Otimes_Vec()", & - "The length of Vec must be less than or equal to 6. & - Program Stopped !!! " & - ) - STOP - - END IF - - T1 = obj - T2 = Rank2Tensor( Vec, "Stress") - - obj_Otimes_Vec = T1 .Otimes. T2 - - CALL T1%Deallocate( ) - CALL T2%Deallocate( ) - - END FUNCTION obj_Otimes_Vec - -!------------------------------------------------------------------------------ -! Vec_Otimes_obj -!------------------------------------------------------------------------------ - - FUNCTION Vec_Otimes_obj( Vec, obj ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. Vec .otimes. obj -! 2. Vec is voigt vector of type stress -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - REAL( DFP ), DIMENSION( 6, 6 ) :: Vec_Otimes_obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T1, T2 - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "Vec_Otimes_obj()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - - END IF - - IF( SIZE( Vec ) .GT. 6 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "Vec_Otimes_obj()", & - "The length of Vec must be less than or equal to 6. & - Program Stopped !!! " & - ) - STOP - - END IF - - T1 = obj - T2 = Rank2Tensor( Vec, "Stress") - - Vec_Otimes_obj = T2 .Otimes. T1 - - CALL T1%Deallocate( ) - CALL T2%Deallocate( ) - - END FUNCTION Vec_Otimes_obj - -!------------------------------------------------------------------------------ -! m_obj_Otimes_Vec -!------------------------------------------------------------------------------ - - FUNCTION m_obj_Otimes_Vec( obj, Vec, VoigtType ) - - USE Rank2Tensor_Class - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .otimes. Vec -! 2. Vec is voigt vector of type stress -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec - CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType - REAL( DFP ), DIMENSION( 6, 6 ) :: m_obj_Otimes_Vec - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T1, T2 - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "m_obj_Otimes_Vec()", & - "Stress_ obj is not allocated. Program Stopped" & - ) - STOP - - END IF - - IF( SIZE( Vec ) .GT. 6 ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Otimes.part", & - "m_obj_Otimes_Vec()", & - "The length of Vec must be less than or equal to 6. & - Program Stopped !!! " & - ) - STOP - - END IF - - T1 = obj - T2 = Rank2Tensor( Vec, VoigtType ) - - m_obj_Otimes_Vec = T1 .Otimes. T2 - - CALL T1%Deallocate( ) - CALL T2%Deallocate( ) - - END FUNCTION m_obj_Otimes_Vec \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part deleted file mode 100755 index f9d924258..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part +++ /dev/null @@ -1,205 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Shape.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION :: -! - .Shape. operator is defined, That returns the VoigtVector -! -! HOSTING FILE -! - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! VoigtVector_1 -!------------------------------------------------------------------------------ - - FUNCTION VoigtVector_1( obj, M ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. obj .Shape. M, Returns obj%S in Voigt vector -! form of length M -!. . . . . . . . . . . . . . . . . . . . - - USE Voigt - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - INTEGER( I4B ), INTENT( IN ) :: M - REAL( DFP ) :: VoigtVector_1( M ) - - INTEGER( I4B ) :: N - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>OperatorOverloading/Shape.part", & - " obj .Shape. M", & - "obj%V is not allocated, Program Stopped!!!"& - ) - - STOP - - END IF - - N = .SIZE. obj - - SELECT CASE( N ) - - CASE( 6 ) - - SELECT CASE( M ) - - CASE( 6 ) - - VoigtVector_1 = obj%V - - CASE( 4 ) - - VoigtVector_1 = Vec4_From_Vec6( obj%V ) - - CASE( 3 ) - - VoigtVector_1 = Vec3_From_Vec6( obj%V ) - - CASE( 2 ) - - VoigtVector_1 = Vec2_From_Vec6( obj%V ) - - CASE( 1 ) - - VoigtVector_1( 1 ) = obj%V( 1 ) - - - END SELECT - - CASE( 4 ) - - SELECT CASE( M ) - - CASE( 6 ) - - VoigtVector_1 = Vec6_From_Vec4( obj%V ) - - CASE( 4 ) - - VoigtVector_1 = obj%V - - CASE( 3 ) - - VoigtVector_1 = Vec3_From_Vec4( obj%V ) - - CASE( 2 ) - - VoigtVector_1 = Vec2_From_Vec4( obj%V ) - - CASE( 1 ) - - VoigtVector_1( 1 ) = obj%V( 1 ) - - - END SELECT - - CASE( 3 ) - - SELECT CASE( M ) - - CASE( 6 ) - - VoigtVector_1 = Vec6_From_Vec3( obj%V ) - - CASE( 4 ) - - VoigtVector_1 = Vec4_From_Vec3( obj%V ) - - CASE( 3 ) - - VoigtVector_1 = obj%V - - CASE( 2 ) - - VoigtVector_1 = Vec2_From_Vec3( obj%V ) - - CASE( 1 ) - - VoigtVector_1( 1 ) = obj%V( 1 ) - - - END SELECT - - CASE( 2 ) - - SELECT CASE( M ) - - CASE( 6 ) - - VoigtVector_1 = Vec6_From_Vec2( obj%V ) - - CASE( 4 ) - - VoigtVector_1 = Vec4_From_Vec2( obj%V ) - - CASE( 3 ) - - VoigtVector_1 = Vec3_From_Vec2( obj%V ) - - CASE( 2 ) - - VoigtVector_1 = obj%V - - CASE( 1 ) - - VoigtVector_1( 1 ) = obj%V( 1 ) - - - END SELECT - - CASE( 1 ) - - SELECT CASE( M ) - - CASE( 6 ) - - VoigtVector_1 = Vec6_From_Vec1( obj%V ) - - CASE( 4 ) - - VoigtVector_1 = Vec4_From_Vec1( obj%V ) - - CASE( 3 ) - - VoigtVector_1 = Vec3_From_Vec1( obj%V ) - - CASE( 2 ) - - VoigtVector_1 = Vec2_From_Vec1( obj%V ) - - CASE( 1 ) - - VoigtVector_1( 1 ) = obj%V( 1 ) - - - END SELECT - - CASE DEFAULT - - CALL Err_Msg( & - "Stress_Class.F90>>OperatorOverloading/Shape.part", & - " obj .Shape. M", & - "No Case Found for shape of obj%V, Program Stopped!!!"& - ) - STOP - - END SELECT - - END FUNCTION VoigtVector_1 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part b/src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part deleted file mode 100755 index d69bc8cb0..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part +++ /dev/null @@ -1,108 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Pk1Stress.part -! Last Update : Dec-28-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of Module -! -! Description :: -! - This part includes subroutine for getting Pk1 Stress from -! any other Stress Measures -! Hosting File :: -! - Stress_Class -!============================================================================== - -!------------------------------------------------------------------------------ -! getPk1Stress -!------------------------------------------------------------------------------ - - FUNCTION getPk1Stress( obj, F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. This subroutine computes the Pk1 stress ( PI )from given stress type -! 2. Fobj is Deformation Gradient object. -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE DeformationGradient_Class - - ! Define arguments of dummy argument - CLASS( Stress_ ), INTENT( IN ) :: obj - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - REAL( DFP ), ALLOCATABLE :: getPk1Stress( :, : ) - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - REAL( DFP ) :: J - REAL( DFP ), ALLOCATABLE :: InvF( :, : ) - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Pk1Stress.part", & - "getPk1Stress(), obj .pkOne. F, obj .PI. F", & - "Stress_ object is not initiated. & - Program Stopped !!!" & - ) - STOP - - END IF - - T = obj - - SELECT CASE( TRIM( obj%StressType ) ) - - CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) - - J = .det. F - InvF = .INV. F - getPk1Stress = T .matmul. TRANSPOSE( InvF ) - getPk1Stress = J * getPk1Stress - - CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) - - InvF = .INV. F - getPk1Stress = T .matmul. TRANSPOSE( InvF ) - - CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) - - getPk1Stress = F .matmul. T - - CASE( "PK1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) - - getPk1Stress = T - - CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) - - InvF = .INV. F - getPk1Stress = TRANSPOSE( InvF ) .matmul. T - - - CASE DEFAULT - - CALL Err_Msg( & - "Stress_Class.F90>>Pk1Stress.part", & - "getPk1Stress( obj, F ), obj .pkOne. F, obj .PI. F", & - "No case found for obj%StressType. & - Program Stopped!!!" & - ) - STOP - - END SELECT - - CALL T%Deallocate( ) - IF( ALLOCATED( InvF ) ) DEALLOCATE( InvF ) - - END FUNCTION getPk1Stress - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part b/src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part deleted file mode 100755 index 8c7947c11..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part +++ /dev/null @@ -1,109 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: PK2Stress.part -! Last Update : Dec-28-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of Module -! -! Description :: -! - This part includes subroutine for getting PK2 Stress from -! any other Stress Measures -! Hosting File :: -! - Stress_Class -!============================================================================== - -!------------------------------------------------------------------------------ -! getPK2Stress -!------------------------------------------------------------------------------ - - FUNCTION getPK2Stress( obj, F ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. This subroutine computes the Cauchy stress from given stress type -! 2. Fobj is Deformation Gradient object. -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - USE DeformationGradient_Class - - ! Define arguments of dummy argument - CLASS( Stress_ ), INTENT( IN ) :: obj - TYPE( DeformationGradient_ ), INTENT( IN ) :: F - REAL( DFP ), ALLOCATABLE :: getPK2Stress( :, : ) - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - REAL( DFP ) :: J - REAL( DFP ), ALLOCATABLE :: InvF( :, : ) - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>Pk2Stress.part", & - "getPK2Stress(), obj.pkTwo.F, obj.S.F", & - "Stress_ object is not initiated. & - Program Stopped !!!" & - ) - STOP - - END IF - - T = obj - - SELECT CASE( TRIM( obj%StressType ) ) - - CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) - - J = .det. F - InvF = .INV. F - getPK2Stress = ( InvF .matmul. T ) .matmul. TRANSPOSE( InvF ) - getPK2Stress = J * getPK2Stress - - CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) - - InvF = .INV. F - getPK2Stress = ( InvF .matmul. T ) .matmul. TRANSPOSE( InvF ) - - CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) - - getPK2Stress = T - - CASE( "PK1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) - - InvF = .INV. F - getPK2Stress = InvF .matmul. T - - CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) - - InvF = .INV. F - getPK2Stress = InvF .matmul. ( TRANSPOSE( InvF ) .matmul. T ) - - - CASE DEFAULT - - CALL Err_Msg( & - "Stress_Class.F90>>Pk2Stress.part", & - "getPK2Stress( obj, F ), obj .pkTwo. F, obj .S. F", & - "No case found for obj%StressType. & - Program Stopped!!!" & - ) - STOP - - END SELECT - - CALL T%Deallocate( ) - IF( ALLOCATED( InvF ) ) DEALLOCATE( InvF ) - - END FUNCTION getPK2Stress - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part b/src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part deleted file mode 100755 index fbc0512bf..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part +++ /dev/null @@ -1,193 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SpectralDecomposition.part -! Last Update : Dec-16-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of module -! -! Info:: - This is part of the code. -! - Contains subroutines related to the spectral decomposition of -! a tensor. -! Hosting File - -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Eigens -!------------------------------------------------------------------------------ - - SUBROUTINE Eigens( obj, EigenValues, EigenVectors ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the eigen values and Eigen Vectors -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: EigenValues( : ), & - EigenVectors( :, : ) - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>SpectralDecomposition.part", & - "Eigens()", & - "Stress_ object is not allocated. & - Program Stopped !!!") - - STOP - - END IF - - T = obj - - CALL T%Eigens( EigenValues = Eigenvalues, EigenVectors = EigenVectors ) - - CALL Check_Error( & - "Stress_Class.F90>>SpectralDecomposition.part>>m_Eigen_1()", & - "Traceback ---> & - CALL T%Eigens( EigenValues = Eigenvalues, EigenVectors = EigenVectors )"& - ) - - CALL T%Deallocate( ) - - END SUBROUTINE Eigens - -!------------------------------------------------------------------------------ -! PrincipalValue -!------------------------------------------------------------------------------ - -REAL( DFP ) FUNCTION PrincipalValue( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! - Returns the max( Real( eigenvalue ) ) -! - m_Eigens_1 is used in this routine -!. . . . . . . . . . . . . . . . . . . . - - - USE Rank2Tensor_Class - - ! Define intent of dummy arguments - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>SpectralDecomposition.part", & - "PrincipalValue()", & - "Stress_ object is not allocated. & - Program Stopped !!!") - - STOP - - END IF - - T = obj - - PrincipalValue = Tensor_PrincipalValue( T ) - - CALL T%Deallocate( ) - -END FUNCTION PrincipalValue - -!------------------------------------------------------------------------------ -! SpectralRadius -!------------------------------------------------------------------------------ - -REAL( DFP ) FUNCTION SpectralRadius( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! - Returns the max( Real( eigenvalue ) ) -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy arguments - CLASS( Stress_ ), INTENT( IN ) :: obj - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - - T = obj - - SpectralRadius = Tensor_SpectralRadius( T ) - - CALL T%Deallocate( ) - -END FUNCTION SpectralRadius - -!------------------------------------------------------------------------------ -! EigenValues -!------------------------------------------------------------------------------ - - FUNCTION EigenValues( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! - Returns EigenValues -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy arguments - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3 ) :: EigenValues - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: EigVals( : ), EigVecs( :, : ) - - CALL Eigens( obj, EigVals, EigVecs ) - CALL Check_Error( & - "Stress_Class.F90>>SpectralDecomposition.part>>EigenValues()", & - "Traceback ---> CALL Eigens( obj, EigVals, EigVecs ) "& - ) - - EigenValues( 1 : 3 ) = EigVals( 1 : 3 ) - - DEALLOCATE( EigVals, EigVecs ) - - -END FUNCTION EigenValues - -!------------------------------------------------------------------------------ -! EigenVectors -!------------------------------------------------------------------------------ - - FUNCTION EigenVectors( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! - Returns EigenVectors -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy arguments - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: EigenVectors - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: EigVals( : ), EigVecs( :, : ) - - CALL Eigens( obj, EigVals, EigVecs ) - CALL Check_Error( & - "Stress_Class.F90>>SpectralDecomposition.part>>EigenVectors()", & - "Traceback ---> CALL Eigens( obj, EigVals, EigVecs ) "& - ) - - EigenVectors( :, : ) = EigVecs( :, : ) - - DEALLOCATE( EigVals, EigVecs ) - -END FUNCTION EigenVectors - diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/StressType.part b/src/submodules/Rank2Tensor/src/old data/Stress/StressType.part deleted file mode 100755 index 2a2539c77..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/StressType.part +++ /dev/null @@ -1,57 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StressType.part -! Last Update : Dec-28-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DESCRIPTION -! - method to access obj%stress field -! HOSTING FILE -! - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStressType -!------------------------------------------------------------------------------ - - FUNCTION getStressType( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the obj%StressType -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CHARACTER( LEN = 50 ) :: getStressType - - - getStressType = TRIM( obj%StressType ) - - END FUNCTION getStressType - -!------------------------------------------------------------------------------ -! setStressType -!------------------------------------------------------------------------------ - - SUBROUTINE setStressType( obj, StressType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the obj%StressType -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( INOUT ) :: obj - CHARACTER( LEN = * ), INTENT( IN ) :: StressType - - obj%StressType = TRIM( StressType ) - - END SUBROUTINE setStressType \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 deleted file mode 100755 index d093d5ee6..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 +++ /dev/null @@ -1,355 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Stress_Class.F90 -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Stress_ Class is defined -!============================================================================== - - MODULE Stress_Class - USE GlobalData - USE IO - USE Voigt - IMPLICIT NONE - - PRIVATE - - PUBLIC :: Stress_, Stress, Stress_Pointer - - -!------------------------------------------------------------------------------ -! Stress_ -!------------------------------------------------------------------------------ - - TYPE :: Stress_ - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Stress class is defined -!. . . . . . . . . . . . . . . . . . . . - - REAL( DFP ), ALLOCATABLE :: V( : ) - INTEGER( I4B ) :: NSD - CHARACTER( LEN = 50 ) :: StressType = "" - - CONTAINS - - - ! Constructor.part - - PROCEDURE, PUBLIC, PASS :: Initiate1, Initiate2, Initiate3, & - Initiate4, Initiate5, Initiate6 - - GENERIC, PUBLIC :: Initiate => Initiate1, Initiate2, Initiate3, & - Initiate4, Initiate5, Initiate6 - - GENERIC, PUBLIC :: ASSIGNMENT( = ) => Initiate3 - - PROCEDURE, PUBLIC, PASS :: isInitiated - PROCEDURE, PUBLIC, PASS :: Deallocate - PROCEDURE, PUBLIC, PASS :: getVoigtLen - GENERIC, PUBLIC :: OPERATOR( .SIZE. ) => getVoigtLen - PROCEDURE, PUBLIC, PASS :: getNSD, setNSD - - - ! StressType.part - - PROCEDURE, PUBLIC, PASS( obj ) :: getStressType, setStressType - GENERIC, PUBLIC :: OPERATOR( .StressType. ) => getStressType - GENERIC, PUBLIC :: ASSIGNMENT( = ) => setStressType - - - ! getStress.part - - PROCEDURE, PUBLIC, PASS :: s_getStress_1 - PROCEDURE, PUBLIC, PASS :: s_getStress_2 - PROCEDURE, PUBLIC, PASS :: s_getStress_5 - GENERIC, PUBLIC :: getStress => s_getStress_1, s_getStress_2, & - s_getStress_5 - - PROCEDURE, PUBLIC, PASS( obj ) :: s_getStress_3, s_getStress_4, & - s_getStress_6 - GENERIC, PUBLIC :: ASSIGNMENT( = ) => s_getStress_3, s_getStress_4, & - s_getStress_6 - - ! OperatorOverloading/Addition.part - - PROCEDURE, PUBLIC, PASS :: obj_Add_obj - PROCEDURE, PUBLIC, PASS :: obj_Add_Mat - PROCEDURE, PUBLIC, PASS :: obj_Add_Vec - PROCEDURE, PUBLIC, PASS :: obj_Add_Scalar - PROCEDURE, PUBLIC, PASS( obj ) :: Mat_Add_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Vec_Add_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Scalar_Add_obj - - GENERIC, PUBLIC :: OPERATOR( + ) => obj_Add_Mat, obj_Add_obj, & - Mat_Add_obj, obj_Add_Vec, Vec_Add_obj, Scalar_Add_obj, & - obj_Add_Scalar - - PROCEDURE, PUBLIC, PASS :: obj_Minus_obj - PROCEDURE, PUBLIC, PASS :: obj_Minus_Mat - PROCEDURE, PUBLIC, PASS :: obj_Minus_Vec - PROCEDURE, PUBLIC, PASS :: obj_Minus_Scalar - PROCEDURE, PUBLIC, PASS( obj ) :: Mat_Minus_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Vec_Minus_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Scalar_Minus_obj - - GENERIC, PUBLIC :: OPERATOR( - ) => obj_Minus_Mat, obj_Minus_obj, & - Mat_Minus_obj, obj_Minus_Vec, Vec_Minus_obj, Scalar_Minus_obj, & - obj_Minus_Scalar - - - ! OperatorOverloading/Assignment.part - - PROCEDURE, PUBLIC, PASS( obj ) :: obj_From_Tensor, & - obj_From_Mat, obj_From_Vec - - GENERIC, PUBLIC :: ASSIGNMENT( = ) => obj_From_Tensor, & - obj_From_Mat, obj_From_Vec - - - ! OperatorOverLoading/Asterics.part - - PROCEDURE, PUBLIC, PASS :: objTimesScalar_1 - PROCEDURE, PUBLIC, PASS :: objTimesScalar_2 - PROCEDURE, PUBLIC, PASS :: objTimesobj - PROCEDURE, PUBLIC, PASS :: objTimesMat - PROCEDURE, PUBLIC, PASS :: objTimesVector - PROCEDURE, PUBLIC, PASS :: objTimesTensor - PROCEDURE, PUBLIC, PASS( obj ) :: ScalarTimesobj_1 - PROCEDURE, PUBLIC, PASS( obj ) :: ScalarTimesobj_2 - PROCEDURE, PUBLIC, PASS( obj ) :: MatTimesobj - PROCEDURE, PUBLIC, PASS( obj ) :: VectorTimesobj - PROCEDURE, PUBLIC, PASS( obj ) :: TensorTimesobj - - GENERIC, PUBLIC :: OPERATOR( * ) => objTimesScalar_1, & - objTimesScalar_2, objTimesobj, objTimesMat, ScalarTimesobj_1, & - ScalarTimesobj_2, MatTimesobj, objTimesVector, VectorTimesobj, & - TensorTimesobj, objTimesTensor - - - ! OperatorOverLoading/Matmul.part - - PROCEDURE, PUBLIC, PASS :: obj_matmul_obj - PROCEDURE, PUBLIC, PASS :: obj_matmul_Mat - PROCEDURE, PUBLIC, PASS :: obj_matmul_Tensor - PROCEDURE, PUBLIC, PASS :: obj_matmul_Vec - PROCEDURE, PUBLIC, PASS( obj ) :: Mat_matmul_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Tensor_matmul_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Vec_matmul_obj - - GENERIC, PUBLIC :: OPERATOR( .matmul. ) => obj_matmul_obj , & - obj_matmul_Mat, obj_matmul_Tensor, Mat_matmul_obj, & - Tensor_matmul_obj, obj_matmul_Vec, Vec_matmul_obj - - - ! OperatorOverLoading/Otimes.part - - PROCEDURE, PUBLIC, PASS :: obj_Otimes_obj - PROCEDURE, PUBLIC, PASS :: obj_Otimes_Mat - PROCEDURE, PUBLIC, PASS :: obj_Otimes_Tensor - PROCEDURE, PUBLIC, PASS :: obj_Otimes_Vec - PROCEDURE, PUBLIC, PASS :: m_obj_Otimes_Vec - PROCEDURE, PUBLIC, PASS( obj ) :: Mat_Otimes_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Tensor_Otimes_obj - PROCEDURE, PUBLIC, PASS( obj ) :: Vec_Otimes_obj - - GENERIC, PUBLIC :: OPERATOR( .Otimes. ) => obj_Otimes_obj, & - obj_Otimes_Mat, obj_Otimes_Tensor, Mat_Otimes_obj, & - Tensor_Otimes_obj, Vec_Otimes_obj, obj_Otimes_Vec - - GENERIC, PUBLIC :: Otimes => obj_Otimes_obj, & - obj_Otimes_Mat, obj_Otimes_Tensor, obj_Otimes_Vec, & - m_obj_Otimes_Vec - - - ! OperatorOverLoading/Invariant.part - - PROCEDURE, PUBLIC, PASS :: Invar_I1 - GENERIC, PUBLIC :: Invariant_I1 => Invar_I1 - GENERIC, PUBLIC :: OPERATOR( .Ione. ) => Invar_I1 - - PROCEDURE, PUBLIC, PASS :: Invar_I2 - GENERIC, PUBLIC :: Invariant_I2 => Invar_I2 - GENERIC, PUBLIC :: OPERATOR( .Itwo. ) => Invar_I2 - - PROCEDURE, PUBLIC, PASS :: Invar_I3 - GENERIC, PUBLIC :: Invariant_I3 => Invar_I3 - GENERIC, PUBLIC :: OPERATOR( .Ithree. ) => Invar_I3 - - PROCEDURE, PUBLIC, PASS :: Invar_J2 - GENERIC, PUBLIC :: Invariant_J2 => Invar_J2 - GENERIC, PUBLIC :: OPERATOR( .Jtwo. ) => Invar_J2 - - PROCEDURE, PUBLIC, PASS :: Invar_J3 - GENERIC, PUBLIC :: Invariant_J3 => Invar_J3 - GENERIC, PUBLIC :: OPERATOR( .Jthree. ) => Invar_J3 - - PROCEDURE, PUBLIC, PASS :: Sigma_m - GENERIC, PUBLIC :: OPERATOR( .sigmaM. ) => Sigma_m - - PROCEDURE, PUBLIC, PASS :: Sigma_Bar - GENERIC, PUBLIC :: OPERATOR( .sigmaBAR. ) => Sigma_Bar - - PROCEDURE, PUBLIC, PASS :: Invar_Z - GENERIC, PUBLIC :: Invariant_Z => Invar_Z - GENERIC, PUBLIC :: OPERATOR( .z. ) => Invar_Z - - PROCEDURE, PUBLIC, PASS :: Invar_r - GENERIC, PUBLIC :: OPERATOR( .r. ) => Invar_r - - PROCEDURE, PUBLIC, PASS :: m_Invar_LodeAngle - GENERIC, PUBLIC :: LodeAngle => m_Invar_LodeAngle - - PROCEDURE, PUBLIC, PASS :: Invar_LodeAngle - GENERIC, PUBLIC :: OPERATOR( .LodeAngle. ) => Invar_LodeAngle - GENERIC, PUBLIC :: OPERATOR( .theta. ) => Invar_LodeAngle - - - ! OperatorOverLoading/Shape.part - - PROCEDURE, PUBLIC, PASS( obj ) :: VoigtVector_1 - GENERIC, PUBLIC :: OPERATOR( .Shape. ) => VoigtVector_1 - - - ! SpectralDecomposition.part - PROCEDURE, PUBLIC, PASS :: Eigens - - PROCEDURE, PUBLIC, PASS :: EigenVectors - GENERIC, PUBLIC :: OPERATOR( .EigenVectors. ) => EigenVectors - - PROCEDURE, PUBLIC, PASS :: EigenValues - GENERIC, PUBLIC :: OPERATOR( .EigenValues. ) => EigenValues - - PROCEDURE, PUBLIC, PASS :: PrincipalValue - GENERIC, PUBLIC :: OPERATOR( .PrincipalValue. ) => PrincipalValue - - PROCEDURE, PUBLIC, PASS :: SpectralRadius - GENERIC, PUBLIC :: OPERATOR( .SpectralRadius. ) => SpectralRadius - - - ! TensorDecomposition.part - - PROCEDURE, PUBLIC, PASS :: m_SymmetricPart - GENERIC, PUBLIC :: SymmetricPart => m_SymmetricPart - - GENERIC, PUBLIC :: OPERATOR( .sym. ) => m_SymmetricPart - GENERIC, PUBLIC :: OPERATOR( .SymmetricPart. ) => m_SymmetricPart - - PROCEDURE, PUBLIC, PASS :: m_AntiSymmetricPart - GENERIC, PUBLIC :: AntiSymmetricPart => m_AntiSymmetricPart - - GENERIC, PUBLIC :: OPERATOR( .AntiSym. ) => m_AntiSymmetricPart - GENERIC, PUBLIC :: OPERATOR( .AntiSymmetricPart. ) => m_AntiSymmetricPart - - PROCEDURE, PUBLIC, PASS :: m_HydrostaticPart - GENERIC, PUBLIC :: HydrostaticPart => m_HydrostaticPart - - GENERIC, PUBLIC :: OPERATOR( .HydrostaticPart. ) => m_HydrostaticPart - GENERIC, PUBLIC :: OPERATOR( .Hydro. ) => m_HydrostaticPart - - GENERIC, PUBLIC :: SphericalPart => m_HydrostaticPart - - - PROCEDURE, PUBLIC, PASS :: m_DeviatoricPart - GENERIC, PUBLIC :: DeviatoricPart => m_DeviatoricPart - - GENERIC, PUBLIC :: OPERATOR( .Dev. ) => m_DeviatoricPart - GENERIC, PUBLIC :: OPERATOR( .DeviatoricPart. ) => m_DeviatoricPart - - - ! CauchyStress.part - - PROCEDURE, PUBLIC, PASS( obj ) :: getCauchyStress - GENERIC, PUBLIC :: OPERATOR( .Cauchy.) => getCauchyStress - GENERIC, PUBLIC :: OPERATOR( .Sigma.) => getCauchyStress - - ! Pk2Stress.part - - PROCEDURE, PUBLIC, PASS( obj ) :: getPK2Stress - GENERIC, PUBLIC :: OPERATOR( .pkTWO. ) => getPK2Stress - GENERIC, PUBLIC :: OPERATOR( .S. ) => getPK2Stress - - ! Pk1Stress.part - - PROCEDURE, PUBLIC, PASS( obj ) :: getPK1Stress - GENERIC, PUBLIC :: OPERATOR( .pkONE. ) => getPK1Stress - GENERIC, PUBLIC :: OPERATOR( .PI. ) => getPK1Stress - - ! KirchhoffStress.part - - PROCEDURE, PUBLIC, PASS( obj ) :: getKirchhoffStress - GENERIC, PUBLIC :: OPERATOR( .Kirchhoff. ) => getKirchhoffStress - GENERIC, PUBLIC :: OPERATOR( .Tau. ) => getKirchhoffStress - - ! EshelbyStress.part - - PROCEDURE, PUBLIC, PASS( obj ) :: getEshelbyStress - GENERIC, PUBLIC :: OPERATOR( .Eshelby. ) => getEshelbyStress - GENERIC, PUBLIC :: OPERATOR( .M. ) => getEshelbyStress - - ! Display.part - - PROCEDURE, PUBLIC, PASS :: Display - - END TYPE Stress_ - - -!. . . . . . . . . . . . . . . . . . . . -! Interfaces -!. . . . . . . . . . . . . . . . . . . . - - - INTERFACE Stress_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3, & - Constructor_4, Constructor_5, Constructor_6 - END INTERFACE - - INTERFACE Stress - MODULE PROCEDURE Constructor1, Constructor2, Constructor3, & - Constructor4, Constructor5, Constructor6 - END INTERFACE - - -!. . . . . . . . . . . . . . . . . . . . -! Contains -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -#include "./Constructor.part" -#include "./StressType.part" -#include "./Display.part" -#include "./getStress.part" - -#include "./OperatorOverloading/Assignment.part" -#include "./OperatorOverloading/Addition.part" -#include "./OperatorOverloading/Asterics.part" -#include "./OperatorOverloading/Matmul.part" -#include "./OperatorOverloading/Otimes.part" -#include "./OperatorOverloading/Invariant.part" -#include "./OperatorOverloading/Shape.part" - -#include "./SpectralDecomposition.part" -#include "./TensorDecomposition.part" - -#include "./CauchyStress.part" -#include "./Pk2Stress.part" -#include "./Pk1Stress.part" -#include "./KirchhoffStress.part" -#include "./EshelbyStress.part" - - END MODULE Stress_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part b/src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part deleted file mode 100755 index d33877549..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part +++ /dev/null @@ -1,126 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Invariants.part -! Last Update : Dec-14-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of module -! -! Info:: - This part contains the subroutines related to -! the stress decomposition. - -! Hosting File - Rank2Tensor_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! m_SymmetricPart -!------------------------------------------------------------------------------ -! - FUNCTION m_SymmetricPart( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Symmetric part of Tensor, method -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_SymmetricPart - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - T = obj - m_SymmetricPart = SymmetricPart( T ) - - CALL T%Deallocate( ) - - END FUNCTION m_SymmetricPart - -!------------------------------------------------------------------------------ -! m_AntiSymmetricPart -!------------------------------------------------------------------------------ -! - FUNCTION m_AntiSymmetricPart( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - AntiSymmetric part of Tensor, method -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_AntiSymmetricPart - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - T = obj - m_AntiSymmetricPart = AntiSymmetricPart( T ) - - CALL T%Deallocate( ) - - END FUNCTION m_AntiSymmetricPart - -!------------------------------------------------------------------------------ -! m_HydrostaticPart -!------------------------------------------------------------------------------ - - FUNCTION m_HydrostaticPart( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Hydrostatic part of Tensor :: Trace( T ) / 3 -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_HydrostaticPart - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - T = obj - - m_HydrostaticPart = HydrostaticPart( T ) - - CALL T%Deallocate( ) - - END FUNCTION m_HydrostaticPart - -!------------------------------------------------------------------------------ -! m_DeviatoricPart -!------------------------------------------------------------------------------ - - FUNCTION m_DeviatoricPart( obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Deviatoric part of stress -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define Intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ) :: m_DeviatoricPart - - ! Define internal variables - TYPE( Rank2Tensor_ ) :: T - T = obj - - m_DeviatoricPart = DeviatoricPart( T ) - - CALL T%Deallocate( ) - - END FUNCTION m_DeviatoricPart - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/getStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/getStress.part deleted file mode 100755 index ec38e7198..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress/getStress.part +++ /dev/null @@ -1,228 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: getStress.part -! Last Update : Dec-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the program -! -! DEsSCRIPTION -! - Returns the values stored in the tensor -! HOSTING FILE -! - Stress_Class.F90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! s_getStress_1 -!------------------------------------------------------------------------------ - - SUBROUTINE s_getStress_1( obj, T ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. T = obj%T -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( INOUT ) :: T - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>getStress.part",& - "s_getStress_1()",& - "Stress obj is Not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED( T ) ) DEALLOCATE( T ) - T = MatFromVoigtVec( obj%V, "Stress" ) - -END SUBROUTINE s_getStress_1 - -!------------------------------------------------------------------------------ -! s_getStress_2 -!------------------------------------------------------------------------------ - - SUBROUTINE s_getStress_2( obj, Vec ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Vec = obj%V -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, DIMENSION( : ), INTENT( INOUT ) :: Vec - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>getStress.part",& - "s_getStress_2()",& - "Stress obj is Not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED( Vec ) ) DEALLOCATE( Vec ) - - Vec = obj%V - - END SUBROUTINE s_getStress_2 - -!------------------------------------------------------------------------------ -! s_getStress_3 -!------------------------------------------------------------------------------ - - SUBROUTINE s_getStress_3( T, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - For overloading the Assignment operator -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), DIMENSION( 3, 3 ), INTENT( OUT ) :: T - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>getStress.part",& - "Assignement Operator( = )",& - "Stress obj is Not Initiated, & - Program Stopped !!!" & - ) - STOP - - END IF - - T = MatFromVoigtVec( obj%V, "Stress" ) - - CALL Check_Error( & - "Stress_Class.F90>>getStress.part>>Assignemnt Operator", & - "Traceback ---> T = MatFromVoigtVec( obj%V " & - ) - - END SUBROUTINE s_getStress_3 - -!------------------------------------------------------------------------------ -! s_getStress_4 -!------------------------------------------------------------------------------ - - SUBROUTINE s_getStress_4( Vec, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - For overloading the Assignment operator -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - REAL( DFP ), ALLOCATABLE, DIMENSION( : ), INTENT( OUT ) :: Vec - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>getStress.part",& - "Assignement Operator( = )",& - "Stress obj is Not Initiated, & - Program Stopped !!!" & - ) - STOP - - END IF - - IF( ALLOCATED( Vec ) ) DEALLOCATE( Vec ) - - Vec = obj%V - - END SUBROUTINE s_getStress_4 - -!------------------------------------------------------------------------------ -! s_getStress_5 -!------------------------------------------------------------------------------ - - SUBROUTINE s_getStress_5( obj, Tensorobj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Returns the tensor object -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: Tensorobj - - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>getStress.part",& - "s_getStress_5",& - "Stress obj is Not Initiated, & - Program Stopped !!!" & - ) - STOP - - END IF - - CALL Tensorobj%Initiate( obj%V, "Stress" ) - - END SUBROUTINE s_getStress_5 - -!------------------------------------------------------------------------------ -! s_getStress_6 -!------------------------------------------------------------------------------ - - SUBROUTINE s_getStress_6( Tensorobj, obj ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Returns the tensor object -!. . . . . . . . . . . . . . . . . . . . - - USE Rank2Tensor_Class - - ! Define intent of dummy variables - CLASS( Stress_ ), INTENT( IN ) :: obj - CLASS( Rank2Tensor_ ), INTENT( OUT ) :: Tensorobj - - Error_Flag = .FALSE. - - IF( .NOT. ALLOCATED( obj%V ) ) THEN - - CALL Err_Msg( & - "Stress_Class.F90>>getStress.part",& - "Assignment Operator( = )",& - "Stress obj is Not Initiated, & - Program Stopped !!!" & - ) - STOP - - END IF - - CALL Tensorobj%Initiate( obj%V, "Stress" ) - - END SUBROUTINE s_getStress_6 diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part deleted file mode 100755 index dacd9c5a3..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part +++ /dev/null @@ -1,48 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Initiate.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; Initiate the Sigma object -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! - SUBROUTINE Initiate( Stress, n ) -! -! Description -!------------------------------------------------------------------------------ -! 1. - Initiate the Sigma object -! -!------------------------------------------------------------------------------ -! Define arguments of dummy argument - CLASS(Stress_) :: Stress - INTEGER(I4B), INTENT(IN) :: n - - IF( ALLOCATED( Stress%Sigma ) ) DEALLOCATE( Stress%Sigma ) - - ALLOCATE( Stress%Sigma( n ) ) - - Stress%Sigma( : ) = 0.0_DFP - - END SUBROUTINE Initiate -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part deleted file mode 100755 index ffd5a3114..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part +++ /dev/null @@ -1,252 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Invariants.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; Initiate the Sigma object -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSigma_m -!------------------------------------------------------------------------------ -! - FUNCTION getSigma_m(Stress) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! Sigma_m = tr(sigma)/3 -! trSigma = -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP) :: getSigma_m -! - INTEGER(I4B) :: n - n = Stress%getLength() -! - SELECT CASE(n) - CASE(4) - getSigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) & - + Stress%Sigma(4) ) / 3.0_DFP - - CASE(6) - getSigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) & - + Stress%Sigma(3) ) / 3.0_DFP - END SELECT -! - END FUNCTION getSigma_m -! -!------------------------------------------------------------------------------ -! getSigma_bar -!------------------------------------------------------------------------------ -! - FUNCTION getSigma_bar(Stress) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! Sigma_bar = tr(sigma)/3 -! trSigma = -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP) :: getSigma_bar -! - INTEGER(I4B) :: n - n = Stress%getLength() -! - SELECT CASE(n) - CASE(4) - getSigma_bar = SQRT(( (Stress%Sigma(1)-Stress%Sigma(2))**2 & - +(Stress%Sigma(2)-Stress%Sigma(4))**2 & - +(Stress%Sigma(4)-Stress%Sigma(1))**2 & - + 6.0_DFP*Stress%Sigma(3)*Stress%Sigma(3)) / 2.0_DFP) - - CASE(6) - getSigma_bar = SQRT( ( ( Stress%Sigma(1) - Stress%Sigma(2) )**2 & - +( Stress%Sigma(2) - Stress%Sigma(3) )**2 & - +( Stress%Sigma(3) - Stress%Sigma(1) )**2 & - + 6.0_DFP * ( Stress%Sigma(4) * Stress%Sigma(4) & - + Stress%Sigma(5) * Stress%Sigma(5) & - + Stress%Sigma(6) * Stress%Sigma(6) ) & - ) / 2.0_DFP ) - END SELECT -! - END FUNCTION getSigma_bar -! -!------------------------------------------------------------------------------ -! getJ2 -!------------------------------------------------------------------------------ -! - FUNCTION getJ2(Stress) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! Sigma_bar = -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP) :: getJ2 -! - getJ2 = Stress%getSigma_bar()**2 / 3.0_DFP -! - END FUNCTION getJ2 -! -!------------------------------------------------------------------------------ -! getLodeAngle -!------------------------------------------------------------------------------ -! - FUNCTION getLodeAngle(Stress) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! Sigma_bar = -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP) :: getLodeAngle -! - REAL(DFP) :: s1,s2,s3, J3,small=1.0E-10_DFP, sine, Sigma_m, Sigma_bar - INTEGER(I4B):: n - - n = Stress%getLength() - - SELECT CASE(n) - CASE(4) - Sigma_m = Stress%getSigma_m() - Sigma_bar = Stress%getSigma_bar() - - IF(sigma_bar .LT. small) THEN - getLodeAngle = 0.0_DFP - ELSE - s1 = Stress%Sigma(1) - Sigma_m - s2 = Stress%Sigma(2) - Sigma_m - s3 = Stress%Sigma(4) - Sigma_m - J3 = s1*s2*s3 - s3*(Stress%Sigma(3)*Stress%Sigma(3)) - - sine = -13.5_DFP * J3 / Sigma_bar**3 - - IF( sine .GE. 1.0_DFP ) THEN - sine = 1.0_DFP - END IF - IF(sine .LT. -1.0_DFP)THEN - sine = -1.0_DFP - END IF - getLodeAngle = ASIN(sine)/3.0_DFP - END IF - - CASE(6) - Sigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) + Stress%Sigma(3) ) / 3.0_DFP - Sigma_bar = Stress%getSigma_bar() - - s1 = Stress%Sigma(1) - Sigma_m - s2 = Stress%Sigma(2) - Sigma_m - s3 = Stress%Sigma(3) - Sigma_m - - J3 = s1*( s2 * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & - - Stress%Sigma(4) * ( Stress%Sigma(4) * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & - + Stress%Sigma(6) * ( Stress%Sigma(4) * Stress%Sigma(5) - s2 * Stress%Sigma(6) ) - - sine = -13.5_DFP * J3 / Sigma_bar**3 - - IF( sine .GE. 1.0_DFP ) THEN - sine = 1.0_DFP - END IF - IF(sine .LT. -1.0_DFP)THEN - sine = -1.0_DFP - END IF - getLodeAngle = ASIN(sine)/3.0_DFP - - END SELECT -! - END FUNCTION getLodeAngle -! -!------------------------------------------------------------------------------ -! getJ3 -!------------------------------------------------------------------------------ -! - FUNCTION getJ3(Stress) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP) :: getJ3 -! - REAL(DFP) :: s1,s2,s3,small=1.0E-10_DFP, Sigma_m - INTEGER(I4B):: n - - n = Stress%getLength() - - SELECT CASE(n) - CASE(4) - Sigma_m = Stress%getSigma_m() - s1 = Stress%Sigma(1) - Sigma_m - s2 = Stress%Sigma(2) - Sigma_m - s3 = Stress%Sigma(4) - Sigma_m - getJ3 = s1*s2*s3 - s3*(Stress%Sigma(3)*Stress%Sigma(3)) - CASE(6) - Sigma_m = Stress%getSigma_m() - s1 = Stress%Sigma(1) - Sigma_m - s2 = Stress%Sigma(2) - Sigma_m - s3 = Stress%Sigma(3) - Sigma_m - getJ3 = s1*( s2 * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & - - Stress%Sigma(4) * ( Stress%Sigma(4) * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & - + Stress%Sigma(6) * ( Stress%Sigma(4) * Stress%Sigma(5) - s2 * Stress%Sigma(6) ) - END SELECT -! - END FUNCTION getJ3 -! -!------------------------------------------------------------------------------ -! getStressInvariants -!------------------------------------------------------------------------------ -! - SUBROUTINE getStressInvariants(Stress, Sigma_m, Sigma_bar, theta) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! Sigma_m = tr(sigma)/3 -! Sigma_bar = sqrt(3/2)||S|| -! theta = Lode angle -! Sigma = (sigma11, sigma22, sigma12, sigma33) -! -! 2 - Input is Sigma which is a vector using Voigt -! notation for plane strain -! -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP), INTENT(OUT) :: Sigma_m, Sigma_bar, theta - - Sigma_m = Stress%getSigma_m() - Sigma_bar = Stress%getSigma_bar() - theta = Stress%getLodeAngle() -! - END SUBROUTINE getStressInvariants -! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part deleted file mode 100755 index 61d2eaa33..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part +++ /dev/null @@ -1,66 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StressDecomposition.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSigma_m -!------------------------------------------------------------------------------ -! - SUBROUTINE getDeviatoricPart(Stress, S) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! Sigma_m = tr(sigma)/3 -! trSigma = -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(OUT) :: S -! - INTEGER(I4B) :: n - REAL(DFP) :: Sigma_m - Error_flag = .FALSE. - - n = Stress%getLength() -! - SELECT CASE(n) - CASE(4) - Sigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) + Stress%Sigma(4) ) / 3.0_DFP - S(1) = Stress%Sigma(1) - Sigma_m - S(2) = Stress%Sigma(2) - Sigma_m - S(4) = Stress%Sigma(4) - Sigma_m - S(3) = Stress%Sigma(3) - - CASE(6) - Sigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) + Stress%Sigma(3) ) / 3.0_DFP - S(:) = Stress%Sigma(:) - S(1) = Stress%Sigma(1) - Sigma_m - S(2) = Stress%Sigma(2) - Sigma_m - S(3) = Stress%Sigma(3) - Sigma_m - END SELECT -! - END SUBROUTINE getDeviatoricPart -! -!------------------------------------------------------------------------------ -! getSigma_bar -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part deleted file mode 100755 index b1a985cf4..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part +++ /dev/null @@ -1,201 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StressDerivatives.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getDsigma_mDsigma -!------------------------------------------------------------------------------ -! - SUBROUTINE getDsigma_mDsigma(Stress, Dsigma_m) -! -! Description -!------------------------------------------------------------------------------ -! 1 - This subroutine Makes Stress Invariants -! Sigma_m = tr(sigma)/3 -! trSigma = -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(OUT) :: Dsigma_m -! - INTEGER(I4B) :: n - REAL(DFP) :: one3 , zro = 0.0_DFP - Error_flag = .FALSE. - n = Stress%getLength() - one3 = 1.0_DFP / 3.0_DFP -! - SELECT CASE(n) - CASE(4) - Dsigma_m(:) = one3 - Dsigma_m(3) = zro - - CASE(6) - Dsigma_m (1:3) = one3 - Dsigma_m (4:6) = zro - END SELECT -! - END SUBROUTINE getDsigma_mDsigma -! -!------------------------------------------------------------------------------ -! getDJ2Dsigma -!------------------------------------------------------------------------------ -! -! - SUBROUTINE getDJ2Dsigma(Stress, DJ2, Voigt) -! Description -!------------------------------------------------------------------------------ -! 1 - If voigt is true then Kinematic-Voigt notatio is followed -! If Voigt is true then -! DJ2 = [s11, s22, s33, 2*s12, 2*s23, 2*s13] -! -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(OUT) :: DJ2 - LOGICAL(LGT), INTENT(IN), OPTIONAL :: Voigt -! Define internal variables - LOGICAL(LGT) :: isVoigt = .TRUE. - INTEGER(I4B) :: n -! - n = Stress%getLength() -! - IF( PRESENT( Voigt ) ) isVoigt = Voigt -! - CALL Stress%getDeviatoricPart( S = DJ2 ) - - IF( isVoigt ) THEN - SELECT CASE(n) - CASE(4) - DJ2( 3 ) = 2.0_DFP * DJ2( 3 ) - CASE(6) - DJ2( 4 : 6 ) = 2.0_DFP * DJ2( 4 : 6 ) - END SELECT - END IF -! - END SUBROUTINE getDJ2Dsigma -! -! -!------------------------------------------------------------------------------ -! getDsigma_barDJ2 -!------------------------------------------------------------------------------ -! - FUNCTION getDsigma_barDJ2(Stress) -! -! Description -!------------------------------------------------------------------------------ -! 1 - -! -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP) :: getDsigma_barDJ2 -! Define internal variables - REAL(DFP) :: Sigma_bar -! - Sigma_bar = Stress%getSigma_bar() - - getDsigma_barDJ2 = 3.0_DFP / Sigma_bar / 2.0_DFP -! - END FUNCTION getDsigma_barDJ2 -! -!------------------------------------------------------------------------------ -! getDsigma_barDsigma -!------------------------------------------------------------------------------ -! - SUBROUTINE getDsigma_barDsigma(Stress, Dsigma_bar, Voigt) -! -! Description -!------------------------------------------------------------------------------ -! 1 - If voigt is true then Kinematic-Voigt notation is followed -! -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(OUT) :: Dsigma_bar - LOGICAL(LGT), INTENT(IN), OPTIONAL :: Voigt -! Define internal variables - REAL( DFP ), ALLOCATABLE :: DJ2(:) - REAL(DFP) :: a - INTEGER(I4B) :: n -! - n = Stress%getLength() - - ALLOCATE(DJ2(n)) - - IF( PRESENT( Voigt ) ) THEN - CALL Stress%getDJ2Dsigma( DJ2 = DJ2, Voigt = Voigt) - ELSE - CALL Stress%getDJ2Dsigma( DJ2 = DJ2 ) - END IF - - a = Stress%getDsigma_barDJ2() - - Dsigma_bar (:) = a * DJ2 (:) - - DEALLOCATE(DJ2) -! - END SUBROUTINE getDsigma_barDsigma -! -!------------------------------------------------------------------------------ -! getDJ3Dsigma -!------------------------------------------------------------------------------ -! - SUBROUTINE getDJ3Dsigma(Stress, DJ3, Voigt) -! -! Description -!------------------------------------------------------------------------------ -! 1 - -! -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(OUT) :: DJ3 - LOGICAL(LGT), INTENT(IN), OPTIONAL :: Voigt -! Define internal variables - LOGICAL(LGT) :: isVoigt = .TRUE. - INTEGER(I4B) :: n -! - n = Stress%getLength() - - IF(PRESENT(Voigt)) isVoigt = Voigt - - - CALL Stress%getHillTensor(H = DJ3) - - IF(isVoigt) THEN - SELECT CASE(n) - CASE(4) - DJ3( 3 ) = 2.0_DFP * DJ3 (3) - CASE(6) - DJ3( 4 : 6 ) = 2.0_DFP * DJ3( 4 : 6 ) - END SELECT - END IF -! - END SUBROUTINE getDJ3Dsigma -! -!------------------------------------------------------------------------------ -! getDJ3Dsigma -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 deleted file mode 100755 index c7e69be61..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 +++ /dev/null @@ -1,126 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Stress_Class.F90 -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Module -! -! Info:: - Defines a Stress Class -! -! -!============================================================================== -! -! List of items -! -! -!------------------------------------------------------------------------------ -! -! ----------------------- -! USE ASSOCIATION -! ----------------------- -! - MODULE Stress_Class - USE GlobalData - USE IO -! - IMPLICIT NONE -! -!------------------------------------------------------------------------------ -! IterativeLinearSolver -!------------------------------------------------------------------------------ -! - TYPE :: Stress_ -! -! Description -!------------------------------------------------------------------------------ -! 1. - Stress Class is defined -! -!------------------------------------------------------------------------------ -! Instance variable - REAL(DFP), ALLOCATABLE, DIMENSION(:) :: Sigma -! -! Type bound procedures - CONTAINS -! ------- - PROCEDURE, PUBLIC, PASS :: Initiate - PROCEDURE, PUBLIC, PASS :: setSigma - PROCEDURE, PUBLIC, PASS :: getSigma - PROCEDURE, PUBLIC, PASS :: getLength - PROCEDURE, PUBLIC, PASS :: getSigma_m - PROCEDURE, PUBLIC, PASS :: getSigma_bar - PROCEDURE, PUBLIC, PASS :: getJ2, getJ3 - PROCEDURE, PUBLIC, PASS :: getLodeAngle - PROCEDURE, PUBLIC, PASS :: getDeviatoricPart - PROCEDURE, PUBLIC, PASS :: getHillTensor - PROCEDURE, PUBLIC, PASS :: getDsigma_mDsigma - PROCEDURE, PUBLIC, PASS :: getDJ2Dsigma - PROCEDURE, PUBLIC, PASS :: getDsigma_barDJ2 - PROCEDURE, PUBLIC, PASS :: getDsigma_barDsigma - PROCEDURE, PUBLIC, PASS :: getDJ3Dsigma - PROCEDURE, PUBLIC, PASS :: getStressInvariants -! - END TYPE Stress_ -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! -! --------------- -! PUBLIC/PRIVATE -! --------------- - PRIVATE :: Initiate - PRIVATE :: setSigma - PRIVATE :: getSigma - PRIVATE :: getLength - PRIVATE :: getSigma_m - PRIVATE :: getSigma_bar - PRIVATE :: getJ2, getJ3 - PRIVATE :: getLodeAngle - PRIVATE :: getDeviatoricPart - PRIVATE :: getHillTensor - PRIVATE :: getDsigma_mDsigma - PRIVATE :: getDJ2Dsigma - PRIVATE :: getDsigma_barDJ2 - PRIVATE :: getDsigma_barDsigma - PRIVATE :: getDJ3Dsigma - PRIVATE :: getStressInvariants - - -! ----------- -! CONTAINS -! ----------- - CONTAINS -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! - INCLUDE "./Initiate.part" - - INCLUDE "./setSigma.part" - - INCLUDE "./getSigma.part" - - INCLUDE "./getLength.part" - - INCLUDE "./Invariants.part" - - INCLUDE "./StressDecomposition.part" - - INCLUDE "./getHillTensor.part" - - INCLUDE "./StressDerivatives.part" - -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! -END MODULE Stress_Class diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part deleted file mode 100755 index f72bfb90b..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part +++ /dev/null @@ -1,88 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: getHillTensor.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! - SUBROUTINE getHillTensor(Stress, H) -! -! Description -!------------------------------------------------------------------------------ -! 1 - Hill tensor is dev(S**2) -!------------------------------------------------------------------------------ -! Define intent of dummy variables -! - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(OUT) :: H -! - REAL(DFP), ALLOCATABLE :: S(:, :), Smat(: , :) - REAL(DFP) :: trS - INTEGER(I4B):: n - - n = Stress%getLength() - - ALLOCATE(S(n,1), Smat(3,3)) - Smat = 0.0_DFP - - CALL Stress%getDeviatoricPart(S = S(:,1)) - - SELECT CASE(n) - CASE(4) - Smat(1, 1) = S(1,1) - Smat(1, 2) = S(3,1) - Smat(2, 1) = S(3,1) - Smat(2, 2) = S(2,1) - Smat(3, 3) = S(4,1) - CASE(6) - Smat = RESHAPE ((/ S(1,1), S(4,1), S(6,1), & - S(4,1), S(2,1), S(5,1), & - S(6,1), S(5,1), S(3,1) & - /), (/ 3, 3/) ) - END SELECT - - DEALLOCATE(S) - ALLOCATE(S(3,3)) - S = MATMUL(Smat, Smat) - trS = S(1,1) + S(2,2) + S(3,3) - S(1,1) = S(1,1) - trS / 3.0_DFP - S(2,2) = S(2,2) - trS / 3.0_DFP - S(3,3) = S(3,3) - trS / 3.0_DFP - - SELECT CASE(n) - CASE(4) - H(1) = S(1,1) - H(2) = S(2,2) - H(3) = S(1,2) - H(4) = S(3,3) - CASE(6) - H(1) = S(1,1) - H(2) = S(2,2) - H(3) = S(3,3) - H(4) = S(1,2) - H(5) = S(2,3) - H(6) = S(1,3) - END SELECT - - DEALLOCATE(S, Smat) -! - END SUBROUTINE getHillTensor -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part deleted file mode 100755 index d1c98c3ca..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part +++ /dev/null @@ -1,44 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: getLength.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! -! - INTEGER(I4B) FUNCTION getLength(Stress) -! -! Description -!------------------------------------------------------------------------------ -! 1. - get the Sigma object -! -!------------------------------------------------------------------------------ -! Define arguments of dummy argument - CLASS(Stress_) :: Stress -! - getLength = SIZE(Stress%Sigma) - - END FUNCTION getLength -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part deleted file mode 100755 index aa974428c..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part +++ /dev/null @@ -1,60 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: getSigma.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; Initiate the Sigma object -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! -! - SUBROUTINE getSigma(Stress, Sigma) -! -! Description -!------------------------------------------------------------------------------ -! 1. - get the Sigma object -! -!------------------------------------------------------------------------------ -! Define arguments of dummy argument - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(OUT) :: Sigma -! - IF(.NOT. ALLOCATED(Stress%Sigma)) THEN - CALL Err_msg("Stress_Class.F90", "getSigma", & - "Stress%Sigma is not allocated first use initiate") - - Error_Flag = .TRUE. - RETURN - END IF - - IF(SIZE(Stress%Sigma) .NE. SIZE(Sigma)) THEN - CALL Err_msg("Stress_Class.F90", "getSigma", & - "The size of Stress%Sigma is not same as Sigma") - Error_Flag = .TRUE. - STOP - END IF -! - Sigma(:) = Stress%Sigma(:) -! - END SUBROUTINE getSigma -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part deleted file mode 100755 index d4cbd0b4b..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part +++ /dev/null @@ -1,50 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: setSigma.part -! Last Update : March-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type :: Part of the Code -! -! Info :: - Part of the code; Initiate the Sigma object -! -! Hosting File -! :: - Stress_Class.F90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! -! - SUBROUTINE setSigma(Stress, Sigma) -! -! Description -!------------------------------------------------------------------------------ -! 1. - set the Sigma object -! -!------------------------------------------------------------------------------ -! Define arguments of dummy argument - CLASS(Stress_) :: Stress - REAL(DFP), DIMENSION(:), INTENT(IN):: Sigma -! - INTEGER(I4B) :: n -! - n = SIZE(Sigma, 1) - CALL Stress%Initiate(n) -! - Stress%Sigma(:) = Sigma(:) - - END SUBROUTINE setSigma -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/Rank2Tensor/src/old data/Tensor.F90 b/src/submodules/Rank2Tensor/src/old data/Tensor.F90 deleted file mode 100755 index a82a060d2..000000000 --- a/src/submodules/Rank2Tensor/src/old data/Tensor.F90 +++ /dev/null @@ -1,33 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Tensor.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Module -! -! Info:: - This module includes all the tensor related classes -!============================================================================== - -MODULE Tensor - USE Rank2Tensor_Class - USE DeformationGradient_Class - USE Stress_Class - USE LeftCauchyGreen_Class - USE RightCauchyGreen_Class - USE Strain_Class - USE SmallStrain_Class - USE GreenStrain_Class - USE AlmansiStrain_Class - USE VelocityGradient_Class - USE StrainRate_Class - USE ContinuumSpin_Class - USE MaterialJacobian_Class - USE ConstitutiveData_Class -END MODULE Tensor \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 b/src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 deleted file mode 100755 index 3dd4c9ef1..000000000 --- a/src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 +++ /dev/null @@ -1,96 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: VelocityGradient_Class.F90 -! Last Update : Dec-29-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Rank2Tensor class is extended to Define VelocityGradient Class -!============================================================================== - - MODULE VelocityGradient_Class - USE GlobalData - USE IO - USE Rank2Tensor_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: VelocityGradient_, VelocityGradient, VelocityGradient_Pointer - -!------------------------------------------------------------------------------ -! VelocityGradient_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( Rank2Tensor_ ) :: VelocityGradient_ - - END TYPE VelocityGradient_ - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - INTERFACE VelocityGradient - MODULE PROCEDURE Constructor1 - END INTERFACE - - INTERFACE VelocityGradient_Pointer - MODULE PROCEDURE Constructor_1 - END INTERFACE - -!. . . . . . . . . . . . . . . . . . . . -! -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy varialbes - CLASS( VelocityGradient_ ), POINTER :: Constructor_1 - - ALLOCATE( Constructor_1 ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Velocity Gradient constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( VelocityGradient_ ) :: Constructor1 - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - - END MODULE VelocityGradient_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/RealMatrix/CMakeLists.txt b/src/submodules/RealMatrix/CMakeLists.txt deleted file mode 100644 index 569d8a922..000000000 --- a/src/submodules/RealMatrix/CMakeLists.txt +++ /dev/null @@ -1,28 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/RealMatrix_Method@IOMethods.F90 - ${src_path}/RealMatrix_Method@ConstructorMethods.F90 - ${src_path}/RealMatrix_Method@GetValuesMethods.F90 - ${src_path}/RealMatrix_Method@SetValuesMethods.F90 - ${src_path}/RealMatrix_Method@MatmulMethods.F90 - ${src_path}/RealMatrix_Method@LAPACKMethods.F90 - ${src_path}/RealMatrix_Method@IterativeSolverMethods.F90 -) diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 deleted file mode 100644 index 57d84d14a..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 +++ /dev/null @@ -1,17 +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 -! - diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 deleted file mode 100644 index 32bae5ad0..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 +++ /dev/null @@ -1,295 +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 (RealMatrix_Method) ConstructorMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Shape -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_shape - IF( ALLOCATED( obj%val ) ) THEN - Ans = SHAPE( obj%val ) - ELSE - Ans = 0 - END IF -END PROCEDURE get_shape - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_size - !Define internal variables - INTEGER( I4B ) :: S( 2 ) - IF( ALLOCATED( obj%val ) ) THEN - S = SHAPE( obj%val ) - IF( PRESENT( Dims ) ) THEN - Ans = S( Dims ) - ELSE - Ans = S( 1 ) * S( 2 ) - END IF - ELSE - Ans = 0 - END IF -END PROCEDURE get_size - -!---------------------------------------------------------------------------- -! getTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_tdimension - ans = obj%tDimension -END PROCEDURE get_tdimension - -!---------------------------------------------------------------------------- -! setTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE set_tdimension - obj%tDimension = tDimension -END PROCEDURE set_tdimension - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE allocate_data - CALL Reallocate( obj%val, Dims(1), Dims(2) ) - CALL setTotalDimension( obj, 2_I4B ) -END PROCEDURE allocate_data - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Deallocate_Data - IF( ALLOCATED( obj%val ) ) DEALLOCATE( obj%val ) - CALL setTotalDimension( obj, 0 ) -END PROCEDURE Deallocate_Data - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_initiate1 - CALL Allocate( obj, Dims ) -END PROCEDURE realmat_initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_initiate2 - CALL Allocate( obj, [nrow, ncol] ) -END PROCEDURE realmat_initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_initiate3 - INTEGER( I4B ) :: j - DO j = 1, SIZE( obj ) - CALL Allocate( obj( j ), Dims ) - END DO -END PROCEDURE realmat_initiate3 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_initiate4 - INTEGER( I4B ) :: j - DO j = 1, SIZE( obj ) - CALL Allocate( obj( j ), Dims( j, : ) ) - END DO -END PROCEDURE realmat_initiate4 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_initiate5 - obj%val = val - CALL setTotalDimension( obj, 2_I4B ) -END PROCEDURE realmat_initiate5 - -!---------------------------------------------------------------------------- -! Matrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor1 - CALL Initiate( obj, Dims ) -END PROCEDURE Constructor1 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realMat_eye1 - INTEGER( I4B ) :: i - CALL Initiate( Ans, [m,m] ) - DO i = 1, m - Ans%val ( i, i ) = 1.0 - END DO -END PROCEDURE realMat_eye1 - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_convert_1 - CALL Convert( From=From%val, To=To%val, Conversion=Conversion, nns=nns, & - & tdof=tdof ) -END PROCEDURE realmat_convert_1 - -!---------------------------------------------------------------------------- -! Sym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE sym_array - Ans = 0.5_DFP * ( obj + TRANSPOSE( obj ) ) -END PROCEDURE sym_array - -!---------------------------------------------------------------------------- -! Sym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE sym_obj - Ans%val = 0.5_DFP * ( obj%val + TRANSPOSE( obj%val ) ) -END PROCEDURE sym_obj - -!---------------------------------------------------------------------------- -! SkewSym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SkewSym_array - Ans = 0.5_DFP * ( obj - TRANSPOSE( obj ) ) -END PROCEDURE SkewSym_array - -!---------------------------------------------------------------------------- -! SkewSym -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SkewSym_obj - Ans%val = 0.5_DFP * ( obj%val - TRANSPOSE( obj%val ) ) -END PROCEDURE SkewSym_obj - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_make_diag_copy1 - INTEGER( I4B ) :: I, s( 2 ) - REAL( DFP ), ALLOCATABLE :: DummyMat2( :, : ) - - IF( ALLOCATED( mat ) ) THEN - s = SHAPE( mat ) - DummyMat2 = mat - CALL Reallocate( mat, s( 1 )*nCopy, s( 2 )*nCopy ) - DO I = 1, nCopy - mat( ( I - 1 ) * s( 1 ) + 1 : I * s( 1 ), & - & ( I - 1 ) * s( 2 ) + 1 : I * s( 2 ) ) & - & = DummyMat2( :, : ) - END DO - DEALLOCATE( DummyMat2 ) - END IF -END PROCEDURE realmat_make_diag_copy1 - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_make_diag_copy2 - INTEGER( I4B ) :: I, S( 2 ) - S = SHAPE( From ) - CALL Reallocate( To, S( 1 )*nCopy, S( 2 )*nCopy ) - To = 0.0_DFP - DO I = 1, nCopy - To( ( I - 1 ) * S( 1 ) + 1 : I * S( 1 ), & - & ( I - 1 ) * S( 2 ) + 1 : I * S( 2 ) ) & - & = From( :, : ) - END DO -END PROCEDURE realmat_make_diag_copy2 - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_make_diag_copy3 - CALL realmat_make_diag_copy1( Mat = Mat%val, nCopy = nCopy ) -END PROCEDURE realmat_make_diag_copy3 - -!---------------------------------------------------------------------------- -! MakeDiagonalCopies -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_make_diag_copy4 - CALL realmat_make_diag_copy2( From = From%val, To = To%val, & - & nCopy = nCopy ) -END PROCEDURE realmat_make_diag_copy4 - -!---------------------------------------------------------------------------- -! Random_Number -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_random_number - IF( PRESENT( m ) .AND. PRESENT( n ) ) THEN - CALL Reallocate( obj%val, m, n ) - CALL RANDOM_NUMBER( obj%val ) - RETURN - END IF - - IF( PRESENT( m ) ) THEN - CALL Reallocate( obj%val, m, m ) - CALL RANDOM_NUMBER( obj%val ) - RETURN - END IF - - IF( PRESENT( n ) ) THEN - CALL Reallocate( obj%val, n, n ) - CALL RANDOM_NUMBER( obj%val ) - RETURN - END IF - - CALL RANDOM_NUMBER( obj%val ) - -END PROCEDURE realmat_random_number - -!---------------------------------------------------------------------------- -! testMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TestMatrix - SELECT CASE( matNo ) - CASE( 1 ) - ALLOCATE( Ans( 4, 4 ) ) - Ans( :, 1 ) = [3.0, -3.0, 6.0, -9.0] - Ans( :, 2 ) = [-7.0, 5.0, -4.0, 5.0] - Ans( :, 3 ) = [-2.0, 1.0, 0.0, -5.0] - Ans( :, 4 ) = [2.0, 0.0, -5.0, 12.0] - END SELECT -END PROCEDURE TestMatrix - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -END SUBMODULE ConstructorMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 deleted file mode 100644 index 028a1c84d..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 +++ /dev/null @@ -1,174 +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(RealMatrix_Method) GetvaluesMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get1 -IF (ALLOCATED(obj%val)) THEN - CALL reallocate(ans, SIZE(obj, 1), SIZE(obj, 2)) - ans = obj%val -ELSE - CALL reallocate(ans, 0, 0) -END IF -END PROCEDURE realmat_Get1 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get1b -ans = realmat_get1(obj=obj, datatype=1.0_DFP) -END PROCEDURE realmat_Get1b - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get2 -ans = obj%val(RIndx, CIndx) -END PROCEDURE realmat_Get2 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get3 -#define Indx iStart:iEnd:Stride -ans = obj%val(Indx, Indx) -#undef Indx -END PROCEDURE realmat_Get3 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get4 -ans%val = obj%val -CALL SetTotalDimension(ans, 2_I4B) -END PROCEDURE realmat_Get4 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get5 -ans%val = obj%val(RIndx, CIndx) -CALL SetTotalDimension(ans, 2_I4B) -END PROCEDURE realmat_Get5 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get6 -#define Indx iStart:iEnd:Stride -ans%val = obj%val(Indx, Indx) -#undef Indx -CALL SetTotalDimension(ans, 2_I4B) -END PROCEDURE realmat_Get6 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get7 -INTEGER(I4B) :: s(2), i, j, r1, r2, c1, c2 -INTEGER(I4B), ALLOCATABLE :: rc(:, :) - !! - !! main - !! -s = SHAPE(obj) -ALLOCATE (rc(0:2, 0:(s(1) * s(2)))) -rc = 0 - !! -DO j = 1, s(2) - DO i = 1, s(1) - rc(1:2, i + (j - 1) * s(1)) = SHAPE(obj(i, j)) - END DO -END DO - !! -i = MAXVAL(SUM(RESHAPE(rc(1, 1:), SHAPE(obj)), 1)) -j = MAXVAL(SUM(RESHAPE(rc(2, 1:), SHAPE(obj)), 2)) - !! -ALLOCATE (ans(i, j)); ans = 0.0_DFP - !! -c1 = 0; c2 = 0 - !! -DO j = 1, s(2) - c1 = 1 + c2 - c2 = c1 + rc(2, j) - 1 - r1 = 0; r2 = 0 - DO i = 1, s(1) - r1 = 1 + r2 - r2 = r1 + rc(1, i) - 1 - ans(r1:r2, c1:c2) = obj(i, j)%val - END DO -END DO - !! -END PROCEDURE realmat_Get7 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Get8 -ans%val = Get(obj, TypeDFP) -CALL SetTotalDimension(ans, 2_I4B) -END PROCEDURE realmat_Get8 - -!---------------------------------------------------------------------------- -! Copy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Copy1 -To = from%val -END PROCEDURE realmat_Copy1 - -!---------------------------------------------------------------------------- -! Copy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Copy2 -to%val = from%val -CALL SetTotalDimension(To, 2_I4B) -END PROCEDURE realmat_Copy2 - -!---------------------------------------------------------------------------- -! Copy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Copy3 -to%val = from -CALL SetTotalDimension(To, 2_I4B) -END PROCEDURE realmat_Copy3 - -!---------------------------------------------------------------------------- -! ArrayPointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_GetPointer -ans => obj%val -END PROCEDURE realmat_GetPointer - -END SUBMODULE GetvaluesMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 deleted file mode 100644 index 61f17d819..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.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 -! - -!> author: Vikas Sharma, Ph. D. -! date: 7 March 2021 -! summary: This module contains IO methods for [[RealMatrix_]] - -SUBMODULE(RealMatrix_Method) IOMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Display1 - CALL Display( obj%Val, msg, UnitNo=UnitNo ) -END PROCEDURE realmat_Display1 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_Display2 - INTEGER( I4B ) :: j - !! - DO j = 1, SIZE( obj ) - !! - CALL Display( & - & obj( j )%Val, & - & trim(msg)// ' (' // tostring(j) // '): ', & - & UnitNo=UnitNo ) - !! - CALL Blanklines( UnitNo = UnitNo, NOL = 2 ) - !! - END DO - !! -END PROCEDURE realmat_Display2 - -END SUBMODULE IOMethods \ No newline at end of file diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 deleted file mode 100644 index 654426487..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 +++ /dev/null @@ -1,151 +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(RealMatrix_Method) IterativeSolverMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! CG -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_CG_1 -REAL(DFP) :: alpha, beta, tol, pap, error0, error, rr1, rr2 -REAL(DFP) :: w(SIZE(rhs), 3) -REAL(DFP), PARAMETER :: default_atol = 0.0_DFP -REAL(DFP), PARAMETER :: default_rtol = 1.0E-6 -INTEGER(I4B), PARAMETER :: default_maxiter = 10 -! 1=r 2=p 3=Ap -INTEGER(I4B) :: maxiter0 -INTEGER(I4B) :: ii -INTEGER(I4B) :: convIn -LOGICAL(LGT) :: recomputeRes - -! temp storage of Ax0 -w(:, 2) = MATMUL(mat, sol) ! BLAS - -! r0=b-Ax0 -w(:, 1) = rhs - w(:, 2) ! BLAS - -! p0=r0 -w(:, 2) = w(:, 1) ! BLAS - -convIn = INPUT(option=convergenceIn, default=convergenceInRes) - -! tol -IF (INPUT(option=relativeToRHS, default=.FALSE.)) THEN - - ! rto*||b||+atol - tol = NORM2(rhs) ! BLAS - -ELSE - IF (convIn .EQ. convergenceInRes) THEN - - ! rtol*r0+atol - tol = NORM2(w(:, 1)) ! BLAS - error0 = tol - - ELSE - - ! rtol*dx0+atol - rr1 = DOT_PRODUCT(w(:, 1), w(:, 1)) ! BLAS - w(:, 3) = MATMUL(mat, w(:, 1)) ! BLAS - pap = DOT_PRODUCT(w(:, 1), w(:, 3)) ! BLAS - alpha = rr1 / pap - ! dx0=alpha||p0|| - error0 = SQRT(rr1) - tol = ABS(alpha) * error0 - END IF -END IF - -tol = INPUT(default=default_rtol, option=rtol) * tol & - & + INPUT(default=default_atol, option=atol) - -! Check convergence -IF (convIn .EQ. convergenceInRes) THEN - IF (error0 .LE. tol) THEN - RETURN - END IF -END IF - -! maxiter0 -IF (PRESENT(maxiter)) THEN - - IF (maxiter .LT. 0) THEN - maxiter0 = maxI4B - ELSE - maxiter0 = maxiter - END IF - -ELSE - maxiter0 = MIN(SIZE(rhs), default_maxiter) -END IF - -! recomputeRes -IF (PRESENT(restartAfter)) THEN - recomputeRes = .TRUE. -ELSE - recomputeRes = .FALSE. -END IF - -ii = 0 - -! Start iteration -DO - rr1 = DOT_PRODUCT(w(:, 1), w(:, 1)) ! BLAS - w(:, 3) = MATMUL(mat, w(:, 2)) ! BLAS - pap = DOT_PRODUCT(w(:, 2), w(:, 3)) ! BLAS - alpha = rr1 / pap - - ! increse the iteration - ii = ii + 1 - - ! update solution - sol = sol + alpha * w(:, 2) ! BLAS - - IF (recomputeRes) THEN - IF (MOD(ii, restartAfter) .EQ. 0) THEN - ! temp storage of Ax - w(:, 3) = MATMUL(mat, sol) ! BLAS - w(:, 1) = rhs - w(:, 3) ! BLAS - END IF - ELSE - w(:, 1) = w(:, 1) - alpha * w(:, 3) ! BLAS - END IF - - rr2 = DOT_PRODUCT(w(:, 1), w(:, 1)) ! BLAS - - ! check convergence - IF (convIn .EQ. convergenceInRes) THEN - error = SQRT(rr2) - IF ((error .LE. tol) .OR. (ii .GT. maxiter0)) EXIT - ELSE - error = alpha * NORM2(w(:, 2)) - ! BLAS - IF ((error .LE. tol) .OR. (ii .GT. maxiter0)) EXIT - END IF - - ! beta - beta = rr2 / rr1 - - ! update p - w(:, 2) = w(:, 1) + beta * w(:, 2) ! BLAS -END DO - -END PROCEDURE realmat_CG_1 - -END SUBMODULE IterativeSolverMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 deleted file mode 100644 index 3126b5ce2..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.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 -! - -SUBMODULE(RealMatrix_Method) LAPACKMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS -END SUBMODULE LAPACKMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 deleted file mode 100644 index 58675e338..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 +++ /dev/null @@ -1,49 +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(RealMatrix_Method) MatmulMethods -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_MatMul1 - Ans%Val = MATMUL( obj1%Val, obj2%Val ) - CALL SetTotalDimension( Ans, 2_I4B ) -END PROCEDURE realmat_MatMul1 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_MatMul2 - Ans = MATMUL( obj%Val, Vec ) -END PROCEDURE realmat_MatMul2 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_MatMul3 - Ans = RealVector( MATMUL( obj%Val, Vec%Val ) ) -END PROCEDURE realmat_MatMul3 - -END SUBMODULE MatmulMethods \ No newline at end of file diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 deleted file mode 100644 index 5323683ac..000000000 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 +++ /dev/null @@ -1,427 +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(RealMatrix_Method) SetValuesMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! setValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_set_1 - obj%Val = Val -END PROCEDURE realmat_set_1 - -!---------------------------------------------------------------------------- -! setValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_set_2 - obj%Val( Row, Col ) = Val -END PROCEDURE realmat_set_2 - -!---------------------------------------------------------------------------- -! setValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_set_3 - obj%Val( Row, Col ) = Val -END PROCEDURE realmat_set_3 - -!---------------------------------------------------------------------------- -! setValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_set_4 - INTEGER( I4B ) :: i - ! - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - IF( Indx .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx - obj%Val( i-Indx, i ) = Val( i ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx - obj%Val( i, i+Indx ) = Val( i ) - END DO - END IF - CASE( MATRIX_ROW ) - ! row - IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN - obj%Val( Indx, 1:SIZE( Val ) ) = Val - END IF - CASE( MATRIX_COLUMN ) - IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN - obj%Val( 1:SIZE( Val ), Indx ) = Val - END IF - END SELECT -END PROCEDURE realmat_set_4 - -!---------------------------------------------------------------------------- -! setValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_set_5 - INTEGER( I4B ) :: i, j - ! - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - DO j = 1, SIZE( Indx ) - IF( Indx( j ) .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) - obj%Val( i-Indx( j ), i ) = Val( i, j ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) - obj%Val( i, i+Indx( j ) ) = Val( i, j ) - END DO - END IF - END DO - CASE( MATRIX_ROW ) - ! row - DO j = 1, SIZE( Indx ) - obj%Val( Indx( j ), : ) = Val( j, : ) - END DO - CASE( MATRIX_COLUMN ) - ! col - DO j = 1, SIZE( Indx ) - obj%Val( :, Indx( j ) ) = Val( :, j ) - END DO - END SELECT -END PROCEDURE realmat_set_5 - -!---------------------------------------------------------------------------- -! setValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_set_6 - obj%Val=1.0_DFP -END PROCEDURE realmat_set_6 - -!---------------------------------------------------------------------------- -! addContribution -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_add_1 - SELECT CASE( IACHAR( Op ) ) - CASE( 43 ) - ! + - obj%Val = obj%Val + Scale * Val - CASE( 45 ) - ! - - obj%Val = obj%Val - Scale * Val - CASE( 42 ) - ! * - obj%Val = Scale * (obj%Val * Val) - CASE( 47 ) - ! / - obj%Val = ( obj%Val / Val ) / Scale - END SELECT -END PROCEDURE realmat_add_1 - -!---------------------------------------------------------------------------- -! addContribution -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_add_2 - SELECT CASE( IACHAR( Op ) ) - CASE( 43 ) - ! + - obj%Val( Row, Col ) = obj%Val( Row, Col ) + Scale * Val - CASE( 45 ) - ! - - obj%Val( Row, Col ) = obj%Val( Row, Col ) - Scale * Val - CASE( 42 ) - ! * - obj%Val( Row, Col ) = Scale * obj%Val( Row, Col ) * Val - CASE( 47 ) - ! / - obj%Val( Row, Col ) = obj%Val( Row, Col ) / Val / Scale - END SELECT -END PROCEDURE realmat_add_2 - -!---------------------------------------------------------------------------- -! realmat_add_3 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_add_3 - SELECT CASE( IACHAR( Op ) ) - CASE( 43 ) - ! + - obj%Val( Row, Col ) = obj%Val( Row, Col ) + Scale * Val - CASE( 45 ) - ! - - obj%Val( Row, Col ) = obj%Val( Row, Col ) - Scale * Val - CASE( 42 ) - ! * - obj%Val( Row, Col ) = Scale * obj%Val( Row, Col ) * Val - CASE( 47 ) - ! / - obj%Val( Row, Col ) = obj%Val( Row, Col ) / Val / Scale - END SELECT -END PROCEDURE realmat_add_3 - -!---------------------------------------------------------------------------- -! realmat_add_4 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_add_4 - INTEGER( I4B ) :: i - SELECT CASE( IACHAR( Op ) ) - CASE( 43 ) - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - IF( Indx .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx - obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) + Scale * Val( i ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx - obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) + Scale * Val( i ) - END DO - END IF - CASE( MATRIX_ROW ) - ! row - IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN - obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & - & + Scale * Val - END IF - CASE( MATRIX_COLUMN ) - IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN - obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & - & + Scale * Val - END IF - END SELECT - CASE( 45 ) - SELECT CASE( ExtraOption ) - CASE( 0 ) - ! diagonal - IF( Indx .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx - obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) - Scale * Val( i ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx - obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) - Scale * Val( i ) - END DO - END IF - CASE( 1 ) - ! row - IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN - obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & - & - Scale * Val - END IF - CASE( 2 ) - IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN - obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & - & - Scale * Val - END IF - END SELECT - CASE( 42 ) - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - IF( Indx .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx - obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) * Scale * Val( i ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx - obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) * Scale * Val( i ) - END DO - END IF - CASE( MATRIX_ROW ) - ! row - IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN - obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & - & * Scale * Val - END IF - CASE( MATRIX_COLUMN ) - IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN - obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & - & * Scale * Val - END IF - END SELECT - CASE( 47 ) - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - IF( Indx .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx - obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) / Scale / Val( i ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx - obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) / Scale / Val( i ) - END DO - END IF - CASE( MATRIX_ROW ) - ! row - IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN - obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & - & / Scale / Val - END IF - CASE( MATRIX_COLUMN ) - IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN - obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & - & / Scale / Val - END IF - END SELECT - END SELECT -END PROCEDURE realmat_add_4 - -!---------------------------------------------------------------------------- -! addContribution -!---------------------------------------------------------------------------- - -MODULE PROCEDURE realmat_add_5 - INTEGER( I4B ) :: i, j - ! - SELECT CASE( IACHAR( Op ) ) - CASE( 43 ) - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - DO j = 1, SIZE( Indx ) - IF( Indx( j ) .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) - obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) & - & + Scale * Val( i, j ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) - obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) + & - & Scale * Val( i, j ) - END DO - END IF - END DO - CASE( MATRIX_ROW ) - ! row - DO j = 1, SIZE( Indx ) - obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) + & - & Scale * Val( j, : ) - END DO - CASE( MATRIX_COLUMN ) - ! col - DO j = 1, SIZE( Indx ) - obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) + & - & Scale * Val( :, j ) - END DO - END SELECT - CASE( 45 ) - ! - - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - DO j = 1, SIZE( Indx ) - IF( Indx( j ) .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) - obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) & - & - Scale * Val( i, j ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) - obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) - & - & Scale * Val( i, j ) - END DO - END IF - END DO - CASE( MATRIX_ROW ) - ! row - DO j = 1, SIZE( Indx ) - obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) - & - & Scale * Val( j, : ) - END DO - CASE( MATRIX_COLUMN ) - ! col - DO j = 1, SIZE( Indx ) - obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) - & - & Scale * Val( :, j ) - END DO - END SELECT - CASE( 42 ) - ! * - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - DO j = 1, SIZE( Indx ) - IF( Indx( j ) .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) - obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) * & - & Scale * Val( i, j ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) - obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) * & - & Scale * Val( i, j ) - END DO - END IF - END DO - CASE( MATRIX_ROW ) - ! row - DO j = 1, SIZE( Indx ) - obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) * & - & Scale * Val( j, : ) - END DO - CASE( MATRIX_COLUMN ) - ! col - DO j = 1, SIZE( Indx ) - obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) * & - & Scale * Val( :, j ) - END DO - END SELECT - CASE( 47 ) - ! / - SELECT CASE( ExtraOption ) - CASE( MATRIX_DIAGONAL ) - ! diagonal - DO j = 1, SIZE( Indx ) - IF( Indx( j ) .LT. 0 ) THEN - DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) - obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) / & - & Scale / Val( i, j ) - END DO - ELSE - DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) - obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) / & - & Scale / Val( i, j ) - END DO - END IF - END DO - CASE( MATRIX_ROW ) - ! row - DO j = 1, SIZE( Indx ) - obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) / & - & Scale / Val( j, : ) - END DO - CASE( MATRIX_COLUMN ) - ! col - DO j = 1, SIZE( Indx ) - obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) / & - & Scale / Val( :, j ) - END DO - END SELECT - END SELECT -END PROCEDURE realmat_add_5 - -END SUBMODULE SetValuesMethods \ No newline at end of file diff --git a/src/submodules/RealVector/CMakeLists.txt b/src/submodules/RealVector/CMakeLists.txt deleted file mode 100644 index 67b6dee0f..000000000 --- a/src/submodules/RealVector/CMakeLists.txt +++ /dev/null @@ -1,34 +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 -# - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/RealVector_AddMethods@Methods.F90 - ${src_path}/RealVector_AppendMethods@Methods.F90 - ${src_path}/RealVector_AssignMethods@Methods.F90 - ${src_path}/RealVector_Blas1Methods@Methods.F90 - ${src_path}/RealVector_ComparisonMethods@Methods.F90 - ${src_path}/RealVector_ConstructorMethods@Methods.F90 - ${src_path}/RealVector_GetMethods@Methods.F90 - ${src_path}/RealVector_GetValueMethods@Methods.F90 - ${src_path}/RealVector_IOMethods@Methods.F90 - ${src_path}/RealVector_Norm2ErrorMethods@Methods.F90 - ${src_path}/RealVector_Norm2Methods@Methods.F90 - ${src_path}/RealVector_SetMethods@Methods.F90 - ${src_path}/RealVector_ShallowCopyMethods@Methods.F90 -) diff --git a/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 deleted file mode 100644 index 21482901d..000000000 --- a/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 +++ /dev/null @@ -1,370 +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(RealVector_AddMethods) Methods -USE GlobalData, ONLY: DOF_FMT, NODES_FMT - -USE DOF_Method, ONLY: DOF_Add => Add, & - OPERATOR(.tdof.), & - GetNodeLoc - -USE F77_BLAS, ONLY: F77_AXPY - -USE F95_BLAS, ONLY: F95_AXPY => AXPY - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add1 -! obj%val = obj%val + scale * VALUE -REAL(DFP) :: aval(1) -INTEGER(I4B) :: N -aval(1) = VALUE -N = SIZE(obj%val) -CALL F77_AXPY(N=N, A=scale, X=aval, INCX=0_I4B, Y=obj%val, INCY=1_I4B) -END PROCEDURE obj_Add1 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add2 -! obj%val = obj%val + scale * VALUE -CALL F95_AXPY(A=scale, X=VALUE, Y=obj%val) -END PROCEDURE obj_Add2 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add3 -obj%val(nodenum) = obj%val(nodenum) + scale * VALUE -END PROCEDURE obj_Add3 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add4 -obj%val(nodenum) = obj%val(nodenum) + scale * VALUE -END PROCEDURE obj_Add4 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add5 -IF (SIZE(VALUE) .EQ. 1) THEN - obj%val(nodenum) = obj%val(nodenum) + scale * VALUE(1) - RETURN -END IF - -obj%val(nodenum) = obj%val(nodenum) + scale * VALUE -END PROCEDURE obj_Add5 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add6 -! obj%val(istart:iend:stride) = obj%val(istart:iend:stride) + scale * VALUE -REAL(DFP) :: aval(1) -INTEGER(I4B) :: N -aval(1) = VALUE -N = INT((iend - istart + stride) / stride) -CALL F77_AXPY(N=N, A=scale, X=aval, INCX=0_I4B, Y=obj%val(istart:), & - INCY=stride) -END PROCEDURE obj_Add6 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add7 -! obj%val(istart:iend:stride) = obj%val(istart:iend:stride) + scale * VALUE -INTEGER(I4B) :: N - -N = SIZE(VALUE) -CALL F77_AXPY(N=N, A=scale, X=VALUE, INCX=1_I4B, Y=obj%val(istart:), & - INCY=stride) -END PROCEDURE obj_Add7 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add8 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, conversion=conversion) -END PROCEDURE obj_Add8 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add9 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale) -END PROCEDURE obj_Add9 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add10 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, idof=idof) -END PROCEDURE obj_Add10 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add11 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - scale=scale, idof=idof) -END PROCEDURE obj_Add11 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add12 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, idof=idof, ivar=ivar) -END PROCEDURE obj_Add12 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add13 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - scale=scale, idof=idof, ivar=ivar) -END PROCEDURE obj_Add13 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add14 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add14 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add15 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add15 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add16 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add16 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add17 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add17 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add18 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add18 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add19 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add19 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add20 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale) -END PROCEDURE obj_Add20 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add21 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, idof=idof) -END PROCEDURE obj_Add21 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add22 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, ivar=ivar, idof=idof) -END PROCEDURE obj_Add22 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add23 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add23 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add24 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add24 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add25 -CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Add25 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add26 -! obj%val = obj%val + scale * VALUE%val -CALL F95_AXPY(A=scale, X=VALUE%val, Y=obj%val) -END PROCEDURE obj_Add26 - -!---------------------------------------------------------------------------- -! add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add27 -INTEGER(I4B) :: tdof, s(3), idof - -tdof = .tdof.dofobj - -DO idof = 1, tdof - s = GetNodeLoc(obj=dofobj, idof=idof) - CALL obj_Add7(obj=obj, istart=s(1), iend=s(2), stride=s(3), scale=scale, & - VALUE=VALUE(:, idof)) -END DO - -END PROCEDURE obj_Add27 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add28 -INTEGER(I4B) :: s(3) -s = GetNodeLoc(obj=dofobj, idof=idof) -CALL obj_Add7(obj=obj, istart=s(1), iend=s(2), stride=s(3), scale=scale, & - VALUE=VALUE) -END PROCEDURE obj_Add28 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add29 -INTEGER(I4B) :: s1(3), s2(3) -INTEGER(I4B) :: N - -s1 = GetNodeLoc(obj=dofobj1, idof=idof1) -s2 = GetNodeLoc(obj=dofobj2, idof=idof2) - -N = (s1(2) - s1(1) + s1(3)) / s1(3) - -CALL F77_AXPY(N=N, A=scale, X=obj2%val(s2(1):), INCX=s2(3), & - Y=obj1%val(s1(1):), INCY=s1(3)) -END PROCEDURE obj_Add29 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add30 -INTEGER(I4B) :: ii, jj -DO ii = istart, iend, stride - jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) - obj%val(jj) = obj%val(jj) + scale * VALUE -END DO -END PROCEDURE obj_Add30 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add31 -INTEGER(I4B) :: ii, jj -DO ii = istart, iend, stride - jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) - obj%val(jj) = obj%val(jj) + scale * VALUE((ii - istart + stride) / stride) -END DO -END PROCEDURE obj_Add31 - -!---------------------------------------------------------------------------- -! Add -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Add32 -INTEGER(I4B) :: tsize -tsize = (iend - istart + stride) / stride -CALL F77_AXPY(N=tsize, A=scale, X=VALUE(istart_value:), INCX=stride_value, & - Y=obj%val(istart:), INCY=stride) -! !$OMP PARALLEL DO PRIVATE(ii) -! DO ii = 1, tsize -! obj%val(istart+(stride-1)*ii) = value(istart_value+(stride_value-1)*ii) -! END DO -! !$OMP END PARALLEL DO -END PROCEDURE obj_Add32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 deleted file mode 100644 index 73f42c297..000000000 --- a/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.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 -! - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This submodule contains set methods of [[RealVector_]] - -SUBMODULE(RealVector_AppendMethods) Methods -USE AppendUtility, ONLY: Util_Append => Append -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Append1 -CALL Util_Append(obj%val, VALUE) -END PROCEDURE obj_Append1 - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Append2 -CALL Util_Append(obj%val, VALUE) -END PROCEDURE obj_Append2 - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Append3 -CALL Util_Append(obj%val, Anotherobj%val) -END PROCEDURE obj_Append3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 deleted file mode 100644 index c7830bacb..000000000 --- a/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 +++ /dev/null @@ -1,160 +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(RealVector_AssignMethods) Methods -USE RealVector_ShallowCopyMethods, ONLY: ShallowCopy -USE F95_BLAS, ONLY: COPY -USE RealVector_ConstructorMethods, ONLY: SetTotalDimension, & - Size - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign1 -CALL ShallowCopy(Y=lhs, X=rhs) -CALL SetTotalDimension(lhs, 1_I4B) -CALL COPY(Y=lhs%val, X=rhs%val) -END PROCEDURE obj_assign1 - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign2 -INTEGER(I4B) :: m, ii, aa -CALL ShallowCopy(Y=lhs, X=rhs) -CALL SetTotalDimension(lhs, 1_I4B) -m = 0 -DO ii = 1, SIZE(rhs) - aa = m + 1 - m = m + SIZE(rhs(ii)) - CALL COPY(Y=lhs%val(aa:m), X=rhs(ii)%val) -END DO -END PROCEDURE obj_assign2 - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign3a -CALL ShallowCopy(Y=lhs, X=rhs) -CALL SetTotalDimension(lhs, 1_I4B) -lhs%val = rhs -END PROCEDURE obj_assign3a - -MODULE PROCEDURE obj_assign3b -CALL ShallowCopy(Y=lhs, X=rhs) -CALL SetTotalDimension(lhs, 1_I4B) -lhs%val = rhs -END PROCEDURE obj_assign3b - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign4a -#ifdef USE_Real64 -lhs = rhs%val -#else -CALL ShallowCopy(Y=lhs, X=rhs) -CALL COPY(Y=lhs, X=rhs%val) -#endif -END PROCEDURE obj_assign4a -MODULE PROCEDURE obj_assign4b -CALL ShallowCopy(Y=lhs, X=rhs) -#ifdef USE_Real64 -CALL COPY(Y=lhs, X=rhs%val) -#else -lhs = rhs%val -#endif -END PROCEDURE obj_assign4b - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign5a -INTEGER(I4B) :: m, ii, aa -CALL ShallowCopy(Y=lhs, X=rhs) -m = 0 -DO ii = 1, SIZE(rhs) - aa = m + 1 - m = m + SIZE(rhs(ii)) -#ifndef USE_Real64 - CALL COPY(Y=lhs(aa:m), X=rhs(ii)%val) -#else - lhs(aa:m) = rhs(ii)%val(:) -#endif -END DO -END PROCEDURE obj_assign5a - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign5b -INTEGER(I4B) :: m, ii, aa - !! -CALL ShallowCopy(Y=lhs, X=rhs) -m = 0 -DO ii = 1, SIZE(rhs) - aa = m + 1 - m = m + SIZE(rhs(ii)) -#ifdef USE_Real64 - CALL COPY(Y=lhs(aa:m), X=rhs(ii)%val) -#else - lhs(aa:m) = rhs(ii)%val(:) -#endif -END DO -END PROCEDURE obj_assign5b - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign6 -lhs = REAL(rhs, DFP) -END PROCEDURE obj_assign6 - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign7 -REAL(DFP), ALLOCATABLE :: dummy(:) -dummy = rhs -lhs = INT(dummy, I4B) -IF (ALLOCATED(dummy)) DEALLOCATE (dummy) -END PROCEDURE obj_assign7 - -!---------------------------------------------------------------------------- -! Assign -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_assign8 -REAL(DFP), ALLOCATABLE :: dummy(:) -dummy = rhs -lhs = INT(dummy, I4B) -IF (ALLOCATED(dummy)) DEALLOCATE (dummy) -END PROCEDURE obj_assign8 - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 b/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 deleted file mode 100644 index eb9ad5131..000000000 --- a/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 +++ /dev/null @@ -1,426 +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(RealVector_Blas1Methods) Methods - -USE F95_BLAS, ONLY: BLAS_AXPY => AXPY, & - BLAS_COPY => COPY, & - BLAS_DOT => DOT, & - BLAS_NRM2 => NRM2, & - BLAS_SCAL => SCAL, & - BLAS_SWAP => SWAP, & - BLAS_ASUM => ASUM - -USE RealVector_ShallowCopyMethods, ONLY: ShallowCopy -USE RealVector_ConstructorMethods, ONLY: SetTotalDimension, Size -USE InputUtility, ONLY: Input - -USE ReallocateUtility, ONLY: Reallocate - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ASUM -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ASUMscalar -ans = BLAS_ASUM(obj%Val) -END PROCEDURE ASUMscalar - -!---------------------------------------------------------------------------- -! ASUM -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ASUMvector -INTEGER(I4B) :: i -DO i = 1, SIZE(obj) - ans = ans + BLAS_ASUM(obj(i)%Val) -END DO -END PROCEDURE ASUMvector - -!---------------------------------------------------------------------------- -! AXPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarAXPYscalar -CALL BLAS_AXPY(X=X%Val, Y=Y%Val, A=A) -END PROCEDURE scalarAXPYscalar - -!---------------------------------------------------------------------------- -! AXPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarAXPYintrinsic -CALL BLAS_AXPY(X=X, Y=Y%Val, A=A) -END PROCEDURE scalarAXPYintrinsic - -!---------------------------------------------------------------------------- -! AXPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vectorAXPYvector -INTEGER(I4B) :: i -DO i = 1, SIZE(X) - CALL BLAS_AXPY(Y=Y(i)%Val, A=A(i), X=X(i)%Val) -END DO -END PROCEDURE vectorAXPYvector - -!---------------------------------------------------------------------------- -! COPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarCOPYscalar -CALL SHALLOWCOPY(Y=Y%Val, X=X%Val) -CALL SetTotalDimension(Y, 1_I4B) -CALL BLAS_COPY(Y=Y%Val, X=X%Val) -END PROCEDURE scalarCOPYscalar - -!---------------------------------------------------------------------------- -! COPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarCOPYintrinsic_1a -CALL SHALLOWCOPY(Y=Y%Val, X=X) -CALL SetTotalDimension(Y, 1_I4B) -Y%Val = X -END PROCEDURE scalarCOPYintrinsic_1a - -!---------------------------------------------------------------------------- -! COPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarCOPYintrinsic_1b -CALL SHALLOWCOPY(Y=Y%Val, X=X) -CALL SetTotalDimension(Y, 1_I4B) -CALL BLAS_COPY(Y=Y%Val, X=X) -! Y%Val = X -END PROCEDURE scalarCOPYintrinsic_1b - -!---------------------------------------------------------------------------- -! COPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intrinsicCOPYscalar_1a -CALL SHALLOWCOPY(Y=Y, X=X%Val) -Y = X%Val -! CALL COPY(Y=Y, X=X%Val) -END PROCEDURE intrinsicCOPYscalar_1a - -!---------------------------------------------------------------------------- -! COPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE intrinsicCOPYscalar_1b -CALL SHALLOWCOPY(Y=Y, X=X%Val) -! Y = X%Val -CALL BLAS_COPY(Y=Y, X=X%Val) -END PROCEDURE intrinsicCOPYscalar_1b - -!---------------------------------------------------------------------------- -! COPY -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vectorCOPYvector -INTEGER(I4B) :: i -CALL SHALLOWCOPY(Y=Y, X=X) -DO i = 1, SIZE(X) - CALL BLAS_COPY(Y=Y(i)%Val, X=X(i)%Val) - CALL SetTotalDimension(Y(i), 1_I4B) -END DO -END PROCEDURE vectorCOPYvector - -!---------------------------------------------------------------------------- -! COPY -!---------------------------------------------------------------------------- - -!Y=X(:)%Val -MODULE PROCEDURE scalarCOPYvector -INTEGER(I4B) :: i, r1, r2 -CALL SHALLOWCOPY(Y=Y, X=X) -CALL SetTotalDimension(Y, 1_I4B) -r1 = 0; r2 = 0 -DO i = 1, SIZE(X) - r1 = r2 + 1 - r2 = r2 + SIZE(X(i)%Val) - Y%Val(r1:r2) = X(i)%Val -END DO -END PROCEDURE scalarCOPYvector - -!---------------------------------------------------------------------------- -! Compact -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Compact_real_1 -INTEGER(I4B) :: m -REAL(DFP), ALLOCATABLE :: Temp_Val(:) -m = SIZE(Val) -IF (m .GT. row) THEN - CALL Reallocate(Temp_Val, m) - CALL BLAS_COPY(Y=Temp_Val, X=Val) - CALL Reallocate(Val, row) - CALL BLAS_COPY(Y=Val, X=Temp_Val(1:row)) - DEALLOCATE (Temp_Val) -END IF -END PROCEDURE Compact_real_1 - -!---------------------------------------------------------------------------- -! Compact -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Compact_Int_1 -INTEGER(I4B) :: m -INTEGER(I4B), ALLOCATABLE :: Temp_Val(:) -m = SIZE(Val) -IF (m .GT. row) THEN - Temp_Val = Val - CALL Reallocate(Val, row) - Val = Temp_Val(1:row) - DEALLOCATE (Temp_Val) -END IF -END PROCEDURE Compact_Int_1 - -!---------------------------------------------------------------------------- -! DOT -!---------------------------------------------------------------------------- - -PURE FUNCTION inner_dot(obj1, obj2) RESULT(ans) - REAL(DFP), INTENT(IN) :: obj1(:) - REAL(DFP), INTENT(IN) :: obj2(:) - REAL(DFP) :: ans - ans = BLAS_DOT(obj1, obj2) -END FUNCTION inner_dot - -!---------------------------------------------------------------------------- -! DOT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarDOTscalar -ans = inner_dot(obj1%Val, obj2%Val) -END PROCEDURE scalarDOTscalar - -!---------------------------------------------------------------------------- -! DOT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarDOTintrinsic -ans = inner_dot(obj%val, val) -END PROCEDURE scalarDOTintrinsic - -!---------------------------------------------------------------------------- -! DOT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vectorDOTvector -INTEGER(I4B) :: i -ans = 0.0 -DO i = 1, SIZE(obj1) - ans = ans + DOT_PRODUCT(obj1(i), obj2(i)) -END DO -END PROCEDURE vectorDOTvector - -!---------------------------------------------------------------------------- -! DOT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vectorDOTscalar -INTEGER(I4B) :: i -ans = 0.0 -DO i = 1, SIZE(obj1) - ans = ans + DOT_PRODUCT(obj1(i)%Val, obj2%Val) -END DO -END PROCEDURE vectorDOTscalar - -!---------------------------------------------------------------------------- -! DOT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarDOTvector -INTEGER(I4B) :: i -ans = 0.0 -DO i = 1, SIZE(obj2) - ans = ans + DOT_PRODUCT(obj1%Val, obj2(i)%Val) -END DO -END PROCEDURE scalarDOTvector - -!---------------------------------------------------------------------------- -! NRM2 -!---------------------------------------------------------------------------- - -PURE FUNCTION inner_nrm2(X) RESULT(ans) - REAL(DFP), INTENT(IN) :: X(:) - REAL(DFP) :: ans - ans = BLAS_NRM2(X) ! blas -END FUNCTION inner_nrm2 - -!---------------------------------------------------------------------------- -! NORM2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE NRM2scalar -ans = inner_nrm2(obj%Val) -END PROCEDURE NRM2scalar - -!---------------------------------------------------------------------------- -! NORM2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE NRM2vector -ans = SQRT(DOT_PRODUCT(obj, obj)) -END PROCEDURE NRM2vector - -!---------------------------------------------------------------------------- -! NORM2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Norm1 -ans = ASUM(obj) -END PROCEDURE obj_Norm1 - -!---------------------------------------------------------------------------- -! NORM2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Normi -ans = MAXVAL(ABS(obj%val)) -END PROCEDURE obj_Normi - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarSWAPscalar -CALL BLAS_SWAP(X=X%Val, Y=Y%Val) -END PROCEDURE scalarSWAPscalar - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vectorSWAPvector -INTEGER(I4B) :: i -DO i = 1, SIZE(X) - CALL BLAS_SWAP(X=X(i)%Val, Y=Y(i)%Val) -END DO -END PROCEDURE vectorSWAPvector - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalarSWAPintrinsic -CALL BLAS_SWAP(X=X%Val, Y=Y) -END PROCEDURE scalarSWAPintrinsic - -!---------------------------------------------------------------------------- -! SCAL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SCALscalar -CALL BLAS_SCAL(A=A, X=X%Val) -END PROCEDURE SCALscalar - -!---------------------------------------------------------------------------- -! SCAL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SCALvector -INTEGER(I4B) :: i -DO i = 1, SIZE(X) - CALL BLAS_SCAL(A=A, X=X(i)%Val) -END DO -END PROCEDURE SCALvector - -!---------------------------------------------------------------------------- -! PMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_PMUL1 -INTEGER(I4B) :: ii, tsize - -tsize = SIZE(obj) -ASSOCIATE (z => obj%val, x => obj1%val, y => obj2%val) - DO CONCURRENT(ii=1:tsize) - z(ii) = x(ii) * y(ii) - END DO -END ASSOCIATE - -END PROCEDURE obj_PMUL1 - -!---------------------------------------------------------------------------- -! PDIV -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_PDIV1 -INTEGER(I4B) :: ii, tsize -LOGICAL(LGT) :: check0 - -check0 = Input(default=.FALSE., option=check_divide_by_zero) -tsize = SIZE(obj) - -ASSOCIATE (z => obj%val, x => obj1%val, y => obj2%val) - - IF (check0) THEN - - DO CONCURRENT(ii=1:tsize, y(ii) .NE. 0.0_DFP) - z(ii) = x(ii) / y(ii) - END DO - - ELSE - - DO CONCURRENT(ii=1:tsize) - z(ii) = x(ii) / y(ii) - END DO - - END IF - -END ASSOCIATE - -END PROCEDURE obj_PDIV1 - -!---------------------------------------------------------------------------- -! Reciprocal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Reciprocal1 -INTEGER(I4B) :: ii, tsize -LOGICAL(LGT) :: check0 - -check0 = Input(default=.FALSE., option=check_divide_by_zero) -tsize = SIZE(obj1) - -ASSOCIATE (x => obj1%val, y => obj2%val) - - IF (check0) THEN - - DO CONCURRENT(ii=1:tsize, y(ii) .NE. 0.0_DFP) - x(ii) = 1.0_DFP / y(ii) - END DO - - ELSE - - DO CONCURRENT(ii=1:tsize) - x(ii) = 1.0_DFP / y(ii) - END DO - - END IF - -END ASSOCIATE - -END PROCEDURE obj_Reciprocal1 - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 deleted file mode 100644 index f6b833baa..000000000 --- a/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 +++ /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 -! - -SUBMODULE(RealVector_ComparisonMethods) Methods -USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! isEqual -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isEqual -IF (.NOT. ALLOCATED(obj%val)) THEN - ans = .FALSE. - RETURN -END IF - -IF (.NOT. ALLOCATED(obj2%val)) THEN - ans = .FALSE. - RETURN -END IF - -IF (SIZE(obj%val) .NE. SIZE(obj2%val)) THEN - ans = .FALSE. - RETURN -END IF - -IF (ALL(obj%val.APPROXEQ.obj2%val)) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF -END PROCEDURE obj_isEqual - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 deleted file mode 100644 index 748e25b04..000000000 --- a/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 +++ /dev/null @@ -1,265 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> author: Vikas Sharma, Ph. D. -! date: 25 Feb 2021 -! summary: This module contains constructor methods of [[RealVector_]] - -SUBMODULE(RealVector_ConstructorMethods) Methods -USE SafeSizeUtility, ONLY: SafeSize - -USE F95_BLAS, ONLY: COPY - -USE DOF_Method, ONLY: OPERATOR(.tnodes.), & - OPERATOR(.tDOF.) - -USE ReallocateUtility, ONLY: Util_Reallocate => Reallocate - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! isAllocated -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isAllocated -ans = ALLOCATED(obj%val) -END PROCEDURE obj_isAllocated - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Shape -ans(1) = SafeSize(obj%val) -END PROCEDURE obj_Shape - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Size -ans = SafeSize(obj%val) -END PROCEDURE obj_Size - -!---------------------------------------------------------------------------- -! getTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RealVec_getTotalDimension -ans = obj%tDimension -END PROCEDURE RealVec_getTotalDimension - -!---------------------------------------------------------------------------- -! setTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RealVec_setTotalDimension -obj%tDimension = tDimension -END PROCEDURE RealVec_setTotalDimension - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Allocate -CALL Util_Reallocate(obj%val, Dims) -CALL SetTotalDimension(obj, 1_I4B) -END PROCEDURE obj_Allocate - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Reallocate -LOGICAL(LGT) :: isok - -isok = ALLOCATED(obj) - -IF (.NOT. isok) THEN - ALLOCATE (obj(row)) - RETURN -END IF - -isok = SIZE(obj) .NE. row -IF (isok) THEN - DEALLOCATE (obj) - ALLOCATE (obj(row)) -END IF - -END PROCEDURE obj_Reallocate - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Deallocate -IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) -END PROCEDURE obj_Deallocate - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate1 -CALL ALLOCATE (obj, tSize) -END PROCEDURE obj_Initiate1 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate2 -INTEGER(I4B) :: n, i -n = SIZE(tSize) - -IF (ALLOCATED(obj)) THEN - IF (SIZE(obj) .NE. n) THEN - DEALLOCATE (obj) - ALLOCATE (obj(n)) - END IF -ELSE - ALLOCATE (obj(n)) -END IF - -DO i = 1, n - CALL ALLOCATE (obj(i), tSize(i)) -END DO -END PROCEDURE obj_Initiate2 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate3 -IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) -ALLOCATE (obj%val(a:b)) -obj%val = 0.0_DFP -CALL SetTotalDimension(obj, 1_I4B) -END PROCEDURE obj_Initiate3 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate4 -CALL Initiate(obj=obj, tSize=(.tNodes.dofobj)) -END PROCEDURE obj_Initiate4 - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Initiate5 -INTEGER(I4B) :: ii -INTEGER(I4B), ALLOCATABLE :: tsize(:) -ASSOCIATE (Map => dofobj%Map) - ALLOCATE (tsize(.tDOF.dofobj)) - DO ii = 1, SIZE(Map, 1) - 1 - tsize(Map(ii, 5):Map(ii + 1, 5) - 1) = Map(ii, 6) - END DO - CALL Initiate(obj=obj, tsize=tsize) - DEALLOCATE (tsize) -END ASSOCIATE -END PROCEDURE obj_Initiate5 - -!---------------------------------------------------------------------------- -! Random_Number -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Random_Number1 -CALL Initiate(obj=obj, tSize=tSize) -CALL RANDOM_NUMBER(obj%val) -END PROCEDURE obj_Random_Number1 - -!---------------------------------------------------------------------------- -! Random_Number -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Random_Number2 -INTEGER(I4B) :: ii, n -n = SIZE(tSize) -IF (ALLOCATED(obj)) THEN - IF (SIZE(obj) .NE. n) THEN - DEALLOCATE (obj) - ALLOCATE (obj(n)) - END IF -ELSE - ALLOCATE (obj(n)) -END IF -DO ii = 1, n - CALL Initiate(obj=obj(ii), tSize=tSize(ii)) - CALL RANDOM_NUMBER(obj(ii)%val) -END DO -END PROCEDURE obj_Random_Number2 - -!---------------------------------------------------------------------------- -! Vector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor1 -CALL ALLOCATE (obj, tSize) -END PROCEDURE obj_Constructor1 - -!---------------------------------------------------------------------------- -! Vector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor2 -CALL ALLOCATE (obj, SIZE(val)) -CALL COPY(Y=obj%val, X=REAL(val, DFP)) -END PROCEDURE obj_Constructor2 - -!---------------------------------------------------------------------------- -! Vector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor3 -CALL ALLOCATE (obj, SIZE(val)) -CALL COPY(Y=obj%val, X=val) -END PROCEDURE obj_Constructor3 - -!---------------------------------------------------------------------------- -! Vector_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor_1 -ALLOCATE (obj) -CALL ALLOCATE (obj, tSize) -END PROCEDURE obj_Constructor_1 - -!---------------------------------------------------------------------------- -! Vector_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor_2 -ALLOCATE (obj) -CALL ALLOCATE (obj, SIZE(val)) -CALL COPY(Y=obj%val, X=REAL(val, DFP)) -END PROCEDURE obj_Constructor_2 - -!---------------------------------------------------------------------------- -! Vector_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Constructor_3 -ALLOCATE (obj) -CALL ALLOCATE (obj, SIZE(val)) -CALL COPY(Y=obj%val, X=REAL(val, DFP)) -END PROCEDURE obj_Constructor_3 - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 deleted file mode 100644 index 071dd5fe3..000000000 --- a/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 +++ /dev/null @@ -1,598 +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: 25 Feb 2021 -! summary: This submodule contains Get methods of [[RealVector_]] - -SUBMODULE(RealVector_GetMethods) Methods -USE DOF_Method, ONLY: GetNodeLoc, DOF_GetIndex => GetIndex - -USE InputUtility, ONLY: INPUT - -USE ReallocateUtility, ONLY: Reallocate - -USE F95_BLAS, ONLY: COPY - -USE RealVector_AssignMethods, ONLY: ASSIGNMENT(=) - -USE RealVector_ConstructorMethods, ONLY: RealVector_Size => Size - -USE SafeSizeUtility, ONLY: SafeSize - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! GetPointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetPointer1 -val => obj%val -END PROCEDURE obj_GetPointer1 - -!---------------------------------------------------------------------------- -! GetPointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetPointer2 -INTEGER(I4B) :: s(3) -s = GetNodeLoc(obj=dofobj, idof=idof) -val => obj%val(s(1):s(2):s(3)) -END PROCEDURE obj_GetPointer2 - -!---------------------------------------------------------------------------- -! IndexOf -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex1 -Ans = MINLOC(ABS(obj%val - VALUE), 1) -END PROCEDURE obj_GetIndex1 - -!---------------------------------------------------------------------------- -! IndexOf -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetIndex2 -! Ans = MINLOC( ABS( obj%val - Value ), 1 ) -INTEGER(I4B) :: i, j, m -LOGICAL(LGT), ALLOCATABLE :: Search(:) -REAL(DFP) :: tol0 - -tol0 = INPUT(default=REAL(1.0E-10, DFP), option=tol) -m = SIZE(VALUE) -ALLOCATE (Search(m), Ans(m)) -Search = .TRUE. -Ans = 0 -DO i = 1, SIZE(obj%val) - DO j = 1, m - IF (Search(j)) THEN - IF (ABS(VALUE(j) - obj%val(i)) .LE. tol0) THEN - Search(j) = .FALSE. - Ans(j) = i - END IF - END IF - END DO -END DO -END PROCEDURE obj_GetIndex2 - -!---------------------------------------------------------------------------- -! isPresent -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isPresent1 -INTEGER(I4B) :: i -REAL(DFP) :: tol0 -Ans = .FALSE. -tol0 = INPUT(default=REAL(1.0E-10, DFP), option=tol) -DO i = 1, SIZE(obj%val) - IF (ABS(obj%val(i) - VALUE) .LE. tol0) THEN - Ans = .TRUE. - EXIT - END IF -END DO -END PROCEDURE obj_isPresent1 - -!---------------------------------------------------------------------------- -! isPresent -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_isPresent2 -INTEGER(I4B) :: i, m, j -REAL(DFP) :: tol0 -LOGICAL(LGT), ALLOCATABLE :: Search(:) - -tol0 = INPUT(default=REAL(1.0E-10, DFP), option=tol) -m = SIZE(VALUE) -ALLOCATE (Ans(m), Search(m)) -Search = .TRUE. -Ans = .FALSE. -DO i = 1, SIZE(obj%val) - DO j = 1, m - IF (Search(j)) THEN - IF (ABS(VALUE(j) - obj%val(i)) .LE. tol0) THEN - Search(j) = .FALSE. - Ans(j) = .TRUE. - END IF - END IF - END DO -END DO -END PROCEDURE obj_isPresent2 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get1 -INTEGER(I4B) :: tsize, ii -tsize = SafeSize(obj%val) -ALLOCATE (ans(tsize)) - -DO CONCURRENT(ii=1:tsize) - ans(ii) = INT(obj%val(ii), kind=I4B) -END DO -END PROCEDURE obj_Get1 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get2 -INTEGER(I4B) :: tsize, ii - -tsize = SIZE(nodenum) -ALLOCATE (ans(tsize)) - -DO CONCURRENT(ii=1:tsize) - ans(ii) = INT(obj%val(nodenum(ii)), kind=I4B) -END DO -END PROCEDURE obj_Get2 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get3 -INTEGER(I4B) :: tsize, ii, jj - -tsize = 1_I4B + (iend - istart) / stride -ALLOCATE (ans(tsize)) - -jj = 0 - -DO ii = istart, iend, stride - jj = jj + 1 - ans(jj) = INT(obj%val(ii), kind=I4B) -END DO -END PROCEDURE obj_Get3 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get4a -INTEGER(I4B) :: tsize, ii -tsize = SafeSize(obj%val) -ALLOCATE (ans(tsize)) - -DO CONCURRENT(ii=1:tsize) - ans(ii) = REAL(obj%val(ii), kind=REAL32) -END DO - -END PROCEDURE obj_Get4a - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get4b -INTEGER(I4B) :: tsize, ii -tsize = SafeSize(obj%val) -ALLOCATE (ans(tsize)) - -DO CONCURRENT(ii=1:tsize) - ans(ii) = REAL(obj%val(ii), kind=REAL64) -END DO -END PROCEDURE obj_Get4b - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get5a -INTEGER(I4B) :: tsize, ii - -tsize = SIZE(nodenum) -ALLOCATE (ans(tsize)) - -DO ii = 1, tsize - ans(ii) = REAL(obj%val(nodenum(ii)), kind=REAL32) -END DO - -END PROCEDURE obj_Get5a - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get5b -INTEGER(I4B) :: tsize, ii - -tsize = SIZE(nodenum) -ALLOCATE (ans(tsize)) - -DO ii = 1, tsize - ans(ii) = REAL(obj%val(nodenum(ii)), kind=REAL64) -END DO -END PROCEDURE obj_Get5b - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get6 -INTEGER(I4B) :: tsize, ii, jj - -tsize = 1_I4B + (iend - istart) / stride -ALLOCATE (ans(tsize)) - -jj = 0 - -DO ii = istart, iend, stride - jj = jj + 1 - ans(jj) = obj%val(ii) -END DO - -END PROCEDURE obj_Get6 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get7 -INTEGER(I4B) :: N, i, tNodes, r1, r2 - -N = SIZE(obj) -tNodes = 0 -DO i = 1, N - tNodes = tNodes + RealVector_SIZE(obj(i)) -END DO - -ALLOCATE (val(tNodes)) -tNodes = 0 -r1 = 0 -r2 = 0 - -DO i = 1, N - r1 = r2 + 1 - r2 = r2 + RealVector_SIZE(obj(i)) - val(r1:r2) = obj(i)%val -END DO - -END PROCEDURE obj_Get7 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get8 -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = SIZE(nodenum) -ALLOCATE (val(N * M)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) -END DO -END PROCEDURE obj_Get8 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get9 -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = 1 + (iend - istart) / stride -ALLOCATE (val(M * N)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) -END DO -END PROCEDURE obj_Get9 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get10a -INTEGER(I4B) :: N, i, tNodes, r1, r2 -N = SIZE(obj) -tNodes = 0 -DO i = 1, N - tNodes = tNodes + SIZE(obj(i)%val) -END DO -ALLOCATE (val(tNodes)) -tNodes = 0; r1 = 0; r2 = 0 -DO i = 1, N - r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val) - val(r1:r2) = obj(i)%val -END DO -END PROCEDURE obj_Get10a - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get10b -INTEGER(I4B) :: N, i, tNodes, r1, r2 -N = SIZE(obj) -tNodes = 0 -DO i = 1, N - tNodes = tNodes + SIZE(obj(i)%val) -END DO -ALLOCATE (val(tNodes)) -tNodes = 0; r1 = 0; r2 = 0 -DO i = 1, N - r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val) - val(r1:r2) = obj(i)%val -END DO -END PROCEDURE obj_Get10b - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get11a -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = SIZE(nodenum) -ALLOCATE (val(M * N)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) -END DO -END PROCEDURE obj_Get11a - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get11b -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = SIZE(nodenum) -ALLOCATE (val(M * N)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) -END DO -END PROCEDURE obj_Get11b - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get12a -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = 1 + (iend - istart) / stride -ALLOCATE (val(M * N)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) -END DO -END PROCEDURE obj_Get12a - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get12b -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = 1 + (iend - istart) / stride -ALLOCATE (val(M * N)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) -END DO -END PROCEDURE obj_Get12b - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get13 -val = Get(obj=obj, dataType=1.0_DFP) -END PROCEDURE obj_Get13 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get14 -val = Get(obj=obj, nodenum=nodenum, dataType=1.0_DFP) -END PROCEDURE obj_Get14 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get15 -val = Get(obj=obj, istart=istart, iend=iend, stride=stride, & - & dataType=1.0_DFP) -END PROCEDURE obj_Get15 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get16 -val = Get(obj=obj, nodenum=nodenum, dataType=1.0_DFP) -END PROCEDURE obj_Get16 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get17 -val = Get(obj=obj, istart=istart, iend=iend, stride=stride, & - & dataType=1.0_DFP) -END PROCEDURE obj_Get17 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get18a -val = obj%val(nodenum) -END PROCEDURE obj_Get18a - -MODULE PROCEDURE obj_Get18b -val = obj%val(nodenum) -END PROCEDURE obj_Get18b - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get19 -IF (ALLOCATED(obj%val)) THEN - ans = obj -ELSE - ALLOCATE (ans(0)) -END IF -END PROCEDURE obj_Get19 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get20 -IF (ALLOCATED(obj%val)) THEN - CALL Reallocate(ans, SIZE(nodenum)) - CALL COPY(Y=ans, X=obj%val(nodenum)) -ELSE - ALLOCATE (ans(0)) -END IF -END PROCEDURE obj_Get20 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get21 -IF (ALLOCATED(obj%val)) THEN - ans = obj%val(istart:iend:stride) -ELSE - ALLOCATE (ans(0)) -END IF -END PROCEDURE obj_Get21 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get22 -INTEGER(I4B) :: N, i, tNodes, r1, r2 -N = SIZE(obj) -tNodes = 0 -DO i = 1, N - tNodes = tNodes + SIZE(obj(i)%val) -END DO -ALLOCATE (val(tNodes)) -tNodes = 0; r1 = 0; r2 = 0 -DO i = 1, N - r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val) - val(r1:r2) = obj(i)%val -END DO -END PROCEDURE obj_Get22 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get23 -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = SIZE(nodenum) -ALLOCATE (val(M * N)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) -END DO -END PROCEDURE obj_Get23 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get24 -INTEGER(I4B) :: N, i, M -N = SIZE(obj) -M = 1 + (iend - istart) / stride -ALLOCATE (val(M * N)) -DO i = 1, N - val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) -END DO -END PROCEDURE obj_Get24 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get25 -ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, & - ivar=ivar, idof=idof)) -END PROCEDURE obj_Get25 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get26 -ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, & - ivar=ivar, idof=idof)) -END PROCEDURE obj_Get26 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get27 -ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar)) -END PROCEDURE obj_Get27 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get28 -ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, & - spacecompo=spacecompo, timecompo=timecompo)) -END PROCEDURE obj_Get28 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get29 -INTEGER(I4B) :: s(3) -s = GetNodeLoc(obj=dofobj, idof=idof) -ans = Get(obj=obj, istart=s(1), iend=s(2), stride=s(3), dataType=1.0_DFP) -END PROCEDURE obj_Get29 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 deleted file mode 100644 index 9ca4e0181..000000000 --- a/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 +++ /dev/null @@ -1,526 +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(RealVector_GetValueMethods) Methods -USE GlobalData, ONLY: DOF_FMT, NODES_FMT - -USE DOF_Method, ONLY: GetIDOF, & - GetNodeLoc, & - GetIndex, & - OPERATOR(.tdof.), & - OPERATOR(.tnodes.), & - DOF_GetValue => GetValue, & - DOF_GetValue_ => GetValue_ - -USE ReallocateUtility, ONLY: Reallocate - -USE F95_BLAS, ONLY: COPY - -USE F77_BLAS, ONLY: F77_Copy - -USE RealVector_SetMethods, ONLY: Set - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue1 -CALL Set(obj=VALUE, VALUE=obj%val, istart=istart, iend=iend, stride=stride) -END PROCEDURE obj_GetValue1 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue2 -INTEGER(I4B) :: s(3) -s = GetNodeLoc(obj=dofobj, idof=idof) -CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3)) -END PROCEDURE obj_GetValue2 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue3 -INTEGER(I4B) :: s(3) -s = GetNodeLoc(obj=dofobj, & - idof=GetIDOF(obj=dofobj, ivar=ivar, idof=idof)) -CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3)) -END PROCEDURE obj_GetValue3 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue4 -INTEGER(I4B) :: s(3) - -s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, & - ivar=ivar, & - spaceCompo=spaceCompo, & - timeCompo=timeCompo)) - -CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3)) -END PROCEDURE obj_GetValue4 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue5 -CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=idofvalue, & - obj2=obj, dofobj2=dofobj, idof2=idofobj) -END PROCEDURE obj_GetValue5 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue6 -INTEGER(I4B) :: ii - -DO ii = 1, SIZE(idofobj) - CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=idofvalue(ii), & - obj2=obj, dofobj2=dofobj, idof2=idofobj(ii)) -END DO - -END PROCEDURE obj_GetValue6 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue7 -INTEGER(I4B) :: global_idofobj, global_idofvalue -global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, idof=idofobj) -global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, idof=idofvalue) -CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & - obj2=obj, dofobj2=dofobj, idof2=global_idofobj) -END PROCEDURE obj_GetValue7 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue8 -INTEGER(I4B) :: global_idofobj, global_idofvalue, ii - -DO ii = 1, SIZE(idofobj) - global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, idof=idofobj(ii)) - global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, idof=idofvalue(ii)) - CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & - obj2=obj, dofobj2=dofobj, idof2=global_idofobj) -END DO - -END PROCEDURE obj_GetValue8 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue9 -INTEGER(I4B) :: global_idofobj, global_idofvalue - -global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, spaceCompo=spaceCompoObj, & - timeCompo=timeCompoObj) - -global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, & - spaceCompo=spaceCompoValue, timeCompo=timeCompoValue) - -CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & - obj2=obj, dofobj2=dofobj, idof2=global_idofobj) - -END PROCEDURE obj_GetValue9 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue10 -INTEGER(I4B) :: global_idofobj, global_idofvalue, ii - -DO ii = 1, SIZE(timeCompoObj) - global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, & - spaceCompo=spaceCompoObj, timeCompo=timeCompoObj(ii)) - - global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, & - spaceCompo=spaceCompoValue, timeCompo=timeCompoValue(ii)) - - CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & - obj2=obj, dofobj2=dofobj, idof2=global_idofobj) -END DO - -END PROCEDURE obj_GetValue10 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue11 -INTEGER(I4B) :: global_idofobj, global_idofvalue, ii - -DO ii = 1, SIZE(spaceCompoObj) - - global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, & - spaceCompo=spaceCompoObj(ii), timeCompo=timeCompoObj) - - global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, & - spaceCompo=spaceCompoValue(ii), timeCompo=timeCompoValue) - - CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & - obj2=obj, dofobj2=dofobj, idof2=global_idofobj) - -END DO - -END PROCEDURE obj_GetValue11 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue12 -CALL DOF_GetValue(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & - storageFMT=storageFMT, nodenum=nodenum) -END PROCEDURE obj_GetValue12 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_12 -CALL DOF_GetValue_(v=VALUE, tsize=tsize, val=obj%val, obj=dofobj, idof=idof, & - storageFMT=storageFMT, nodenum=nodenum) -END PROCEDURE obj_GetValue_12 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue13 -CALL DOF_GetValue(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & - storageFMT=storageFMT) -END PROCEDURE obj_GetValue13 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_13 -CALL DOF_GetValue_(v=VALUE, tsize=tsize, val=obj%val, obj=dofobj, idof=idof, & - storageFMT=storageFMT) -END PROCEDURE obj_GetValue_13 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue14 -CALL DOF_GetValue(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & - force3D=force3D) -END PROCEDURE obj_GetValue14 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_14 -CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & - force3D=force3D, nrow=nrow, ncol=ncol) -END PROCEDURE obj_GetValue_14 - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue15 -VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, & - idof=idof)) -END PROCEDURE obj_GetValue15 - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue16 -VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, idof=idof)) -END PROCEDURE obj_GetValue16 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_16 -INTEGER(I4B) :: global_idof -global_idof = GetIDOF(obj=dofobj, ivar=ivar, idof=idof) -CALL DOF_GetValue_(obj=dofobj, nodenum=nodenum, idof=global_idof, & - v=VALUE, tsize=tsize, val=obj%val) -END PROCEDURE obj_GetValue_16 - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue17 -VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar)) -END PROCEDURE obj_GetValue17 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_17 -INTEGER(I4B), ALLOCATABLE :: idof(:) -idof = GetIDOF(obj=dofobj, ivar=ivar) -CALL GetValue_(obj=obj, dofobj=dofobj, nodenum=nodenum, idof=idof, & - VALUE=VALUE, tsize=tsize, & - storageFMT=dofobj%storageFMT) -END PROCEDURE obj_GetValue_17 - -!---------------------------------------------------------------------------- -! get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue18 -VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, & - spaceCompo=spaceCompo, timeCompo=timeCompo)) -END PROCEDURE obj_GetValue18 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_18 -INTEGER(I4B) :: idof -idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, & - timeCompo=timeCompo) -CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & - nodenum=nodenum, tsize=tsize) -END PROCEDURE obj_GetValue_18 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue19 -INTEGER(I4B) :: s(3), tsize - -tsize = dofobj.tNodes.idof -CALL Reallocate(VALUE, tsize) -CALL obj_GetValue_19(obj=obj, dofobj=dofobj, VALUE=VALUE, tsize=tsize, & - idof=idof) - -END PROCEDURE obj_GetValue19 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_19 -CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & - tsize=tsize, isidof=.TRUE.) -END PROCEDURE obj_GetValue_19 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue20 -INTEGER(I4B) :: global_idof -global_idof = GetIDOF(obj=dofobj, ivar=ivar, idof=idof) -CALL GetValue(obj=obj, dofobj=dofobj, idof=global_idof, & - VALUE=VALUE) -END PROCEDURE obj_GetValue20 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_20 -INTEGER(I4B) :: global_idof -global_idof = GetIDOF(obj=dofobj, ivar=ivar, idof=idof) -CALL GetValue_(obj=obj, dofobj=dofobj, idof=global_idof, & - VALUE=VALUE, tsize=tsize) -END PROCEDURE obj_GetValue_20 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue21 -INTEGER(I4B) :: global_idof -global_idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, & - timeCompo=timeCompo) -CALL GetValue(obj=obj, dofobj=dofobj, idof=global_idof, & - VALUE=VALUE) -END PROCEDURE obj_GetValue21 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_21 -INTEGER(I4B) :: global_idof -global_idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, & - timeCompo=timeCompo) -CALL GetValue_(obj=obj, dofobj=dofobj, idof=global_idof, & - VALUE=VALUE, tsize=tsize) -END PROCEDURE obj_GetValue_21 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue22 -INTEGER(I4B) :: tsize -tsize = SIZE(idof) * SIZE(nodenum) -CALL Reallocate(VALUE, tsize) -CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, VALUE=VALUE, tsize=tsize, & - nodenum=nodenum) -END PROCEDURE obj_GetValue22 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_22 -CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & - tsize=tsize, nodenum=nodenum, storageFMT=dofobj%storageFMT) -END PROCEDURE obj_GetValue_22 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue23 -INTEGER(I4B) :: tsize -tsize = dofobj.tNodes.idof -CALL Reallocate(VALUE, tsize) -CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, VALUE=VALUE, tsize=tsize) -END PROCEDURE obj_GetValue23 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_23 -CALL DOF_GetValue_(obj=dofobj, val=obj%val, v=VALUE, idof=idof, tsize=tsize, & - storageFMT=dofobj%StorageFMT) -END PROCEDURE obj_GetValue_23 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_24 -INTEGER(I4B) :: jj - -SELECT CASE (storageFMT) - -CASE (DOF_FMT) - ncol = SIZE(idof) - - DO jj = 1, ncol - CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof(jj:jj), nodenum=nodenum, & - VALUE=VALUE(:, jj), tsize=nrow, storageFMT=dofobj%storageFMT) - END DO - -CASE (NODES_FMT) - ncol = SIZE(nodenum) - - DO jj = 1, ncol - CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, nodenum=nodenum(jj:jj), & - VALUE=VALUE(:, jj), tsize=nrow, storageFMT=dofobj%storageFMT) - END DO - -END SELECT - -END PROCEDURE obj_GetValue_24 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue24 -CALL COPY(Y=VALUE%val, X=obj%val) -END PROCEDURE obj_GetValue24 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_25 -INTEGER(I4B) :: jj - -SELECT CASE (storageFMT) - -CASE (DOF_FMT) - ncol = SIZE(idof) - - DO jj = 1, ncol - CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof(jj), & - VALUE=VALUE(:, jj), tsize=nrow) - END DO - -CASE (NODES_FMT) - CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, VALUE=VALUE, & - nrow=nrow, ncol=ncol) - -END SELECT - -END PROCEDURE obj_GetValue_25 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_26 -INTEGER(I4B) :: ii -tsize = SIZE(nodenum) -DO ii = 1, tsize - VALUE(ii) = obj%val(nodenum(ii)) -END DO -END PROCEDURE obj_GetValue_26 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_27 -tsize = (iend - istart + stride) / stride -CALL F77_Copy(N=tsize, X=obj%val(istart:), INCX=stride, & - Y=VALUE, INCY=1_I4B) -END PROCEDURE obj_GetValue_27 - -!---------------------------------------------------------------------------- -! GetValue_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetValue_28 -tsize = (iend - istart + stride) / stride -CALL F77_Copy(N=tsize, X=obj%val(istart:), INCX=stride, & - Y=VALUE(istart_value:), INCY=stride_value) -END PROCEDURE obj_GetValue_28 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 deleted file mode 100644 index dd6b6b51c..000000000 --- a/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 +++ /dev/null @@ -1,65 +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: 25 Feb 2021 -! summary: This submodule implements IO methods of [[RealVector_]] - -SUBMODULE(RealVector_IOMethods) Methods -USE Display_Method, ONLY: Util_Display => Display, & - tostring - -USE RealVector_ConstructorMethods, ONLY: size - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_display1 -INTEGER(I4B) :: tsize -CALL Util_Display(msg=msg, unitno=unitno) -tsize = SIZE(obj) -CALL Util_Display(msg="size: "//tostring(tsize), unitno=unitno) -CALL Util_Display(val=obj%val, msg='', unitno=unitno, orient='col', & - full=.TRUE.) -END PROCEDURE obj_display1 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_display2 -INTEGER(I4B) :: j, tsize - -tsize = SIZE(obj) -CALL Util_Display(msg=msg, unitno=unitno) -CALL Util_Display(msg="size : "//tostring(tsize), unitno=unitno) - -DO j = 1, tsize - CALL Display(obj(j), msg="("//tostring(j)//"): ", unitno=unitno) -END DO - -END PROCEDURE obj_display2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 deleted file mode 100644 index 135b0d65a..000000000 --- a/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 +++ /dev/null @@ -1,183 +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(RealVector_Norm2ErrorMethods) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2error_1 -INTEGER(I4B) :: p(3), s(3), ii, jj -s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & - idof=idofobj)) - -p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & - idof=idofobj2)) - -jj = 0; ans = 0.0_DFP - -DO ii = s(1), s(2), s(3) - jj = jj + 1 - ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 -END DO - -ans = SQRT(ans) -END PROCEDURE obj_norm2error_1 - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2error_2 -INTEGER(I4B) :: p(3), s(3), ii, jj, kk -ans = 0.0_DFP -DO kk = 1, SIZE(idofobj) - s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & - idof=idofobj(kk))) - - p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & - idof=idofobj2(kk))) - - jj = 0 - - DO ii = s(1), s(2), s(3) - jj = jj + 1 - ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 - END DO - -END DO - -ans = SQRT(ans) - -END PROCEDURE obj_norm2error_2 - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2error_3 -INTEGER(I4B) :: p(3), s(3), ii, jj - -s = GetNodeLoc(obj=dofobj, idof=idofobj) -p = GetNodeLoc(obj=dofobj2, idof=idofobj2) - -jj = 0; ans = 0.0_DFP - -DO ii = s(1), s(2), s(3) - jj = jj + 1 - ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 -END DO - -ans = SQRT(ans) - -END PROCEDURE obj_norm2error_3 - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2error_4 -INTEGER(I4B) :: p(3), s(3), ii, jj, kk - -ans = 0.0_DFP - -DO kk = 1, SIZE(idofobj) - - s = GetNodeLoc(obj=dofobj, idof=idofobj(kk)) - p = GetNodeLoc(obj=dofobj2, idof=idofobj2(kk)) - - jj = 0 - - DO ii = s(1), s(2), s(3) - jj = jj + 1 - ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 - END DO - -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2error_4 - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2error_5 -INTEGER(I4B) :: p(3), s(3), ii, jj -s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & - spaceCompo=spaceCompoObj, timeCompo=timeCompoObj)) - -p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & - spaceCompo=spaceCompoobj2, timeCompo=timeCompoobj2)) - -jj = 0; ans = 0.0_DFP -DO ii = s(1), s(2), s(3) - jj = jj + 1 - ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2error_5 - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2error_6 -INTEGER(I4B) :: p(3), s(3), ii, jj, kk -ans = 0.0_DFP -DO kk = 1, SIZE(timeCompoObj) - s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & - spaceCompo=spaceCompoObj, timeCompo=timeCompoObj(kk))) - - p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & - spaceCompo=spaceCompoobj2, timeCompo=timeCompoobj2(kk))) - - jj = 0 - DO ii = s(1), s(2), s(3) - jj = jj + 1 - ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 - END DO -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2error_6 - -!---------------------------------------------------------------------------- -! Norm2Error -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2error_7 -INTEGER(I4B) :: p(3), s(3), ii, jj, kk -ans = 0.0_DFP -DO kk = 1, SIZE(spaceCompoObj) - s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & - spaceCompo=spaceCompoObj(kk), timeCompo=timeCompoObj)) - p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, & - ivar=ivarobj2, spaceCompo=spaceCompoobj2(kk), timeCompo=timeCompoobj2)) - - jj = 0 - DO ii = s(1), s(2), s(3) - jj = jj + 1 - ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 - END DO -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2error_7 - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 b/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 deleted file mode 100644 index 4e6eb55d5..000000000 --- a/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 +++ /dev/null @@ -1,139 +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(RealVector_Norm2Methods) Methods -USE DOF_Method, ONLY: GetNodeLoc, GetIDOF - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2_1 -INTEGER(I4B) :: s(3), ii - -ii = GetIDOF(obj=dof, ivar=ivar, idof=idof) -s = GetNodeLoc(obj=dof, idof=ii) -ans = 0.0_DFP -DO ii = s(1), s(2), s(3) - ans = ans + obj%val(ii)**2 -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2_1 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2_2 -INTEGER(I4B) :: s(3), ii, kk -ans = 0.0_DFP -DO kk = 1, SIZE(idof) - ii = GetIDOF(obj=dof, ivar=ivar, idof=idof(kk)) - s = GetNodeLoc(obj=dof, idof=ii) - DO ii = s(1), s(2), s(3) - ans = ans + obj%val(ii)**2 - END DO -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2_2 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2_3 -INTEGER(I4B) :: s(3), ii -s = GetNodeLoc(obj=dof, idof=idof) -ans = 0.0_DFP -DO ii = s(1), s(2), s(3) - ans = ans + obj%val(ii)**2 -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2_3 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2_4 -INTEGER(I4B) :: s(3), ii, kk -ans = 0.0_DFP -DO kk = 1, SIZE(idof) - s = GetNodeLoc(obj=dof, idof=idof(kk)) - DO ii = s(1), s(2), s(3) - ans = ans + obj%val(ii)**2 - END DO -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2_4 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2_5 -INTEGER(I4B) :: s(3), ii - -ii = GetIDOF(obj=dof, ivar=ivar, spaceCompo=spaceCompo, timeCompo=timeCompo) -s = GetNodeLoc(obj=dof, idof=ii) -ans = 0.0_DFP -DO ii = s(1), s(2), s(3) - ans = ans + obj%val(ii)**2 -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2_5 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2_6 -INTEGER(I4B) :: s(3), ii, kk -ans = 0.0_DFP -DO kk = 1, SIZE(timeCompo) - ii = GetIDOF(obj=dof, ivar=ivar, spaceCompo=spaceCompo, & - timeCompo=timeCompo(kk)) - s = GetNodeLoc(obj=dof, idof=ii) - DO ii = s(1), s(2), s(3) - ans = ans + obj%val(ii)**2 - END DO -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2_6 - -!---------------------------------------------------------------------------- -! norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_norm2_7 -INTEGER(I4B) :: s(3), ii, kk -ans = 0.0_DFP -DO kk = 1, SIZE(spaceCompo) - ii = GetIDOF(obj=dof, ivar=ivar, spaceCompo=spaceCompo(kk), & - timeCompo=timeCompo) - s = GetNodeLoc(obj=dof, idof=ii) - DO ii = s(1), s(2), s(3) - ans = ans + obj%val(ii)**2 - END DO -END DO -ans = SQRT(ans) -END PROCEDURE obj_norm2_7 - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 deleted file mode 100644 index 1e8678589..000000000 --- a/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 +++ /dev/null @@ -1,362 +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(RealVector_SetMethods) Methods -USE DOF_Method, ONLY: DOF_Set => Set, & - OPERATOR(.tdof.), & - GetNodeLoc -USE F77_Blas, ONLY: F77_Copy -USE F95_Blas, ONLY: F95_Copy => Copy -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set1 -REAL(DFP) :: aval(1) -INTEGER(I4B) :: N -aval(1) = VALUE -N = SIZE(obj%val) -CALL F77_Copy(N=N, X=aval, INCX=0_I4B, Y=obj%val, INCY=1_I4B) -END PROCEDURE obj_Set1 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set2 -CALL F95_Copy(X=VALUE, Y=obj%val) -END PROCEDURE obj_Set2 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set3 -obj%val(nodenum) = VALUE -END PROCEDURE obj_Set3 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set4 -obj%val(nodenum) = VALUE -END PROCEDURE obj_Set4 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set5 -IF (SIZE(VALUE) .EQ. 1) THEN - obj%val(nodenum) = VALUE(1) - RETURN -END IF - -obj%val(nodenum) = VALUE -END PROCEDURE obj_Set5 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set6 -REAL(DFP) :: aval(1) -INTEGER(I4B) :: N -aval(1) = VALUE -N = INT((iend - istart + stride) / stride) -CALL F77_Copy(N=N, X=aval, INCX=0_I4B, Y=obj%val(istart:), & - INCY=stride) -END PROCEDURE obj_Set6 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set7 -INTEGER(I4B) :: N - -N = SIZE(VALUE) -CALL F77_Copy(N=N, X=VALUE, INCX=1_I4B, Y=obj%val(istart:), & - INCY=stride) -END PROCEDURE obj_Set7 - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set8 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - conversion=conversion) -END PROCEDURE obj_Set8 - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set9 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE) -END PROCEDURE obj_Set9 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set10 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - idof=idof) -END PROCEDURE obj_Set10 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set11 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - idof=idof) -END PROCEDURE obj_Set11 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set12 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - idof=idof, ivar=ivar) -END PROCEDURE obj_Set12 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set13 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - idof=idof, ivar=ivar) -END PROCEDURE obj_Set13 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set14 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set14 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set15 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set15 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set16 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set16 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set17 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set17 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set18 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set18 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set19 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set19 - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set20 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE) -END PROCEDURE obj_Set20 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set21 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - idof=idof) -END PROCEDURE obj_Set21 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set22 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - ivar=ivar, idof=idof) -END PROCEDURE obj_Set22 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set23 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set23 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set24 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set24 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set25 -CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & - ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) -END PROCEDURE obj_Set25 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set26 -! obj%val = VALUE%val -CALL F95_Copy(X=VALUE%val, Y=obj%val) -END PROCEDURE obj_Set26 - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set27 -INTEGER(I4B) :: tdof, s(3), idof - -tdof = .tdof.dofobj - -DO idof = 1, tdof - s = GetNodeLoc(obj=dofobj, idof=idof) - CALL obj_Set7(obj=obj, istart=s(1), iend=s(2), stride=s(3), & - VALUE=VALUE(:, idof)) -END DO - -END PROCEDURE obj_Set27 - -!---------------------------------------------------------------------------- -! Set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set28 -INTEGER(I4B) :: s(3) -s = GetNodeLoc(obj=dofobj, idof=idof) -CALL obj_Set7(obj=obj, istart=s(1), iend=s(2), stride=s(3), VALUE=VALUE) -END PROCEDURE obj_Set28 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set29 -INTEGER(I4B) :: s1(3), s2(3) -INTEGER(I4B) :: N - -s1 = GetNodeLoc(obj=dofobj1, idof=idof1) -s2 = GetNodeLoc(obj=dofobj2, idof=idof2) - -N = (s1(2) - s1(1) + s1(3)) / s1(3) - -CALL F77_Copy(N=N, X=obj2%val(s2(1):), INCX=s2(3), Y=obj1%val(s1(1):), & - INCY=s1(3)) -END PROCEDURE obj_Set29 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set30 -INTEGER(I4B) :: ii, jj -!$OMP PARALLEL DO PRIVATE(ii, jj) -DO ii = istart, iend, stride - jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) - obj%val(jj) = VALUE -END DO -!$OMP END PARALLEL DO -END PROCEDURE obj_Set30 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set31 -INTEGER(I4B) :: ii, jj -!$OMP PARALLEL DO PRIVATE(ii, jj) -DO ii = istart, iend, stride - jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) - obj%val(jj) = VALUE((ii - istart + stride) / stride) -END DO -!$OMP END PARALLEL DO -END PROCEDURE obj_Set31 - -!---------------------------------------------------------------------------- -! set -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Set32 -INTEGER(I4B) :: tsize -tsize = (iend - istart + stride) / stride -CALL F77_Copy(N=tsize, X=VALUE(istart_value:), INCX=stride_value, & - Y=obj%val(istart:), INCY=stride) -! !$OMP PARALLEL DO PRIVATE(ii) -! DO ii = 1, tsize -! obj%val(istart+(stride-1)*ii) = value(istart_value+(stride_value-1)*ii) -! END DO -! !$OMP END PARALLEL DO -END PROCEDURE obj_Set32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 deleted file mode 100644 index cefda8f30..000000000 --- a/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 +++ /dev/null @@ -1,156 +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(RealVector_ShallowCopyMethods) Methods -USE ReallocateUtility, ONLY: Reallocate -USE RealVector_ConstructorMethods, ONLY: Size - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy1a -CALL Reallocate(Y, SIZE(X)) -END PROCEDURE obj_ShallowCopy1a - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy1b -CALL Reallocate(Y, SIZE(X)) -END PROCEDURE obj_ShallowCopy1b - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy1c -CALL Reallocate(Y, SIZE(X)) -END PROCEDURE obj_ShallowCopy1c - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy1d -CALL Reallocate(Y, SIZE(X)) -END PROCEDURE obj_ShallowCopy1d - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy2 -CALL ShallowCopy(Y=Y%Val, X=X%Val) -END PROCEDURE obj_ShallowCopy2 - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy3 -INTEGER(I4B) :: i -IF (ALLOCATED(Y)) THEN - IF (SIZE(Y) .NE. SIZE(X)) THEN - DEALLOCATE (Y) - ALLOCATE (Y(SIZE(X))) - END IF -ELSE - ALLOCATE (Y(SIZE(X))) -END IF -DO i = 1, SIZE(Y) - CALL ShallowCopy(Y=Y(i)%Val, X=X(i)%Val) -END DO -END PROCEDURE obj_ShallowCopy3 - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy4 -INTEGER(I4B) :: i, tNodes -tNodes = 0 -DO i = 1, SIZE(X) - tNodes = tNodes + SIZE(X(i)%Val) -END DO -CALL Reallocate(Y%Val, tNodes) -END PROCEDURE obj_ShallowCopy4 - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy5a -CALL ShallowCopy(Y=Y%Val, X=X) -END PROCEDURE obj_ShallowCopy5a - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy5b -CALL ShallowCopy(Y=Y%Val, X=X) -END PROCEDURE obj_ShallowCopy5b - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy6a -CALL ShallowCopy(Y=Y, X=X%Val) -END PROCEDURE obj_ShallowCopy6a - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy6b -CALL ShallowCopy(Y=Y, X=X%Val) -END PROCEDURE obj_ShallowCopy6b - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy7a -INTEGER(I4B) :: ii, m -m = 0 -DO ii = 1, SIZE(X) - m = m + SIZE(X(ii)) -END DO -CALL Reallocate(Y, m) -END PROCEDURE obj_ShallowCopy7a - -!---------------------------------------------------------------------------- -! ShallowCopy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_ShallowCopy7b -INTEGER(I4B) :: ii, m -m = 0 -DO ii = 1, SIZE(X) - m = m + SIZE(X(ii)) -END DO -CALL Reallocate(Y, m) -END PROCEDURE obj_ShallowCopy7b - -END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/Save_hdf5.F90 b/src/submodules/RealVector/src/Save_hdf5.F90 deleted file mode 100644 index c8f6427da..000000000 --- a/src/submodules/RealVector/src/Save_hdf5.F90 +++ /dev/null @@ -1,151 +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: 25 Feb 2021 -! summary: This submodule implements IO methods of [[RealVector_]] - -SUBMODULE(RealVector_Method) IO -USE BaseMethod -USE h5fortran -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RealVectorDisplay - INTEGER( I4B ) :: i, max_size - type(hdf5_file) :: h5f - type(File_) :: aFile - INTEGER( I4B ) :: sizes(SIZE(obj)) - REAL( DFP ) :: val( SIZE( obj ) ) - - DO i = 1, SIZE( obj ) - sizes(i) = SIZE(obj(i)) - END DO - - max_size = MAXVAL( sizes ) - - IF( PRESENT( UnitNo ) ) THEN - CALL Write_data( UnitNo ) - RETURN - END IF - - IF( PRESENT( filename ) ) THEN - SELECT CASE( TRIM( extension ) ) - CASE( '.hdf5' ) - call ExecuteCommand( 'mkdir -p '//trim(path), & - & __FILE__ // "Line num :: " // TRIM(INT2STR(__LINE__)) & - & // " RealVectorDisplay()" ) - - call h5f%initialize( & - & filename= trim(path)//trim(filename)//trim(extension), & - & status='new', action='w', comp_lvl=1) - - DO i = 1, SIZE(obj) - call h5f%write( '/' // TRIM(msg) // '/comp[' & - & // TRIM(INT2STR(i)) // ']', obj(i)%Val ) - END DO - call h5f%finalize() - - CASE( '.txt' ) - CALL OpenFileToWrite(obj=afile, filename=filename, path=path, & - & extension='.txt') - CALL Write_data( afile%UnitNo ) - CALL CloseFile(afile) - - CASE( '.md' ) - CALL Display( __FILE__, 'ERROR in File :: ' ) - CALL Display( __LINE__, ' in LINE :: ' ) - CALL Display( ' Message :: Cannot write to .txt file') - STOP - END SELECT - - RETURN - - END IF - - CALL Write_data( stdout ) - - CONTAINS - SUBROUTINE Write_data( unitno ) - INTEGER( I4B ), INTENT( IN ) :: unitno - INTEGER( I4B ) :: i, j - - DO i = 1, max_size - val = 0.0_DFP - DO j = 1, SIZE( obj ) - IF( i .LE. sizes( j ) ) val( j ) = obj(j)%Val(i) - END DO - - WRITE( UnitNo, * ) val - - END DO - END SUBROUTINE - -END PROCEDURE RealVectorDisplay - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RealscalarDisplay - IF( PRESENT( UnitNo ) ) THEN - CALL Display( obj%Val, UnitNo = UnitNo, msg=msg ) - RETURN - END IF - - IF( PRESENT( filename ) ) THEN - CALL Display( obj%Val, msg=msg, filename=filename, & - & extension=extension, path=path ) - RETURN - END IF - - CALL Display( obj%Val, msg=msg, unitNo = stdout) - -END PROCEDURE RealscalarDisplay - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Display_Vector_Real - INTEGER( I4B ) :: i - type(hdf5_file) :: h5f - - SELECT CASE( TRIM( extension ) ) - CASE( '.hdf5' ) - call ExecuteCommand( 'mkdir -p ' // trim(path), & - & __FILE__ // "Line num :: " // TRIM(INT2STR(__LINE__)) & - & // " Display_Vector_Real()" ) - call h5f%initialize( & - & filename= trim(path)//trim(filename)//trim(extension), & - & status='new', action='w', comp_lvl=1) - call h5f%write( '/' // TRIM(msg), Vec ) - call h5f%finalize() - CASE DEFAULT - CALL Display( Val=__FILE__, msg="Error: In file :: ", unitNo = stdout ) - CALL Display( Val=__LINE__, msg="In line number :: ", UnitNo = stdout ) - CALL Display( Msg= "No match found for given extension", UnitNo=stdout ) - STOP - END SELECT - -END PROCEDURE Display_Vector_Real - -END SUBMODULE IO \ No newline at end of file diff --git a/src/submodules/STConvectiveMatrix/CMakeLists.txt b/src/submodules/STConvectiveMatrix/CMakeLists.txt deleted file mode 100644 index 7db91df8e..000000000 --- a/src/submodules/STConvectiveMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STConvectiveMatrix_Method@Methods.F90 - ) diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part deleted file mode 100755 index 291a5a8e8..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part +++ /dev/null @@ -1,139 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate Convective Matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STConvectiveMatrix_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor_1 ) - ALLOCATE( Constructor_1 % Mat2( row, col ) ) - Constructor_1 % Mat2 = 0.0_DFP - CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate the Space Time Convective Matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STConvectiveMatrix_ ), POINTER :: Constructor_2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor_2 ) - ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) - Constructor_2 % Mat4 = 0.0_DFP - CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Returns mass matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STConvectiveMatrix_ ), POINTER :: Constructor_3 - ALLOCATE( Constructor_3 ) - - END FUNCTION Constructor_3 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate Convective Matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STConvectiveMatrix_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor1 % Mat2( row, col ) ) - Constructor1 % Mat2 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Initiate the Space Time Convective Matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STConvectiveMatrix_ ) :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) - Constructor2 % Mat4 = 0.0_DFP - CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Returns mass matrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STConvectiveMatrix_ ) :: Constructor3 - - END FUNCTION Constructor3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part deleted file mode 100755 index 4f685eeaf..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part +++ /dev/null @@ -1,52 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_10.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_10 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_10( Obj, Term1, Term2, Xtype, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. getting the Convective matrix -! 2. Term1, Term2 0, 1 -! 3. XType X, Y, Z -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: XType - - CALL Obj % getConvectiveMatrix( Term1 = Term1, Term2 = Term2, XType = XType ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getConvectiveMatrix_10 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part deleted file mode 100755 index 96fcba280..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part +++ /dev/null @@ -1,199 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_11.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getConvectiveMatrix_11 -!------------------------------------------------------------------------------ -! - SUBROUTINE getConvectiveMatrix_11( Obj, C, Term1, Term2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( :, :, : ) -! 2. Term1 and Term2 `dx` `dt` -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & - DummyVec2( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - - ! Flag-1 -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL(Term1) ) ) - - CASE( "dt", "DT", "Dt", "dT" ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dt, dx ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( STNodalValues = C, & - cdNTdXt = cdNTdXt) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()" & - ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & - b = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "Unknown value of Term2; It should be dx or dy or dz" & - ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - -#ifdef DEBUG_VER - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) -#else - CASE DEFAULT -#endif - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dx, dt ) - CASE( "dt", "DT", "Dt", "dT" ) -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( STNodalValues = C, & - cdNTdXt = cdNTdXt ) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()" & - ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & - a = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "Unknown value of Term2; It should be 'dt' " & - ) - Error_Flag = .TRUE. - RETURN - END SELECT - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_11()", & - "Unknown value of Term1; It should be 'dt' or 'dx'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat4FromMat2( NNT, NNT ) - NULLIFY( SD ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - - END SUBROUTINE getConvectiveMatrix_11 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part deleted file mode 100755 index b67dc189b..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part +++ /dev/null @@ -1,200 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_12.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix12 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_12( Obj, C, Term1, Term2 ) - -!. . . . . . . . . . . . . . . . . . . . -! `1. C( :, : ) -! 2. Term1 and Term2 "dx", "dt" -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & - DummyVec2( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - - ! Flag-1 -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL(Term1) ) ) - - CASE( "dt", "DT", "Dt", "dT" ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dt, dx ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( SpaceNodalValues = C, & - cdNTdXt = cdNTdXt) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()" & - ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & - b = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "Unknown value of Term2; It should be dx or dy or dz" & - ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - -#ifdef DEBUG_VER - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) -#else - CASE DEFAULT -#endif - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dx, dt ) - CASE( "dt", "DT", "Dt", "dT" ) -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( SpaceNodalValues = C, & - cdNTdXt = cdNTdXt ) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()" & - ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & - a = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "Unknown value of Term2; It should be 'dt' " & - ) - Error_Flag = .TRUE. - RETURN - END SELECT - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_12()", & - "Unknown value of Term1; It should be 'dt' or 'dx'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat4FromMat2( NNT, NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - - END SUBROUTINE getConvectiveMatrix_12 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part deleted file mode 100755 index 5338a8aac..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part +++ /dev/null @@ -1,239 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_13.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_13 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_13( Obj, C, Term1, Term2, CType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( :, : ) -! 2. Term1, Term2 dt and dx -! 3. CType `NodalValues` `QuadPoints` -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & - DummyVec2( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( "Nodal", "Nodal Values", "NodalValues", & - "SpaceNodalValues", "Space Nodal Values" ) - - CALL Obj % getConvectiveMatrix_12( Term1 = Term1, & - Term2 = Term2, C = C ) - -#ifdef DEBUG_VER - IF( Error_Flag ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()", & - "TraceBack >> & - & CALL Obj % getConvectiveMatrix_12( Term1 = Term1, & - & Term2 = Term2, C = C ) " ) - - END IF - CASE( "Integration", "Integration Points", & - "IntegrationPoints", "Quad", "Quad Points", "QuadPoints" ) -#else - CASE DEFAULT -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL(Term1) ) ) - - CASE( "dt", "DT", "Dt", "dT" ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dt, dx ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS ), & - cdNTdXt = cdNTdXt) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()" & - ) -#endif - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & - b = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()", & - "Unknown value of Term2; & - & It should be dx or dy or dz" ) - Error_Flag = .TRUE. - RETURN - END SELECT - - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dx, dt ) - CASE( "dt", "DT", "Dt", "dT" ) -#else - CASE DEFAULT -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS ), & - cdNTdXt = cdNTdXt ) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()" ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & - a = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()", & - "Unknown value of Term2; It should be 'dt' " & - ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()", & - "Unknown value of Term1; It should be 'dt' or 'dx'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_13()", & - "No case found for given CType; It should be & - & 'Nodal', 'NodalValues', 'Nodal Values', 'SpaceNodalValues', & - & 'Space Nodal Values', 'Integation Points', 'Integration', & - & 'IntegrationPoints', 'Quad', 'Quad Points', 'QuadPoints'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat4FromMat2( NNT, NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - - END SUBROUTINE getConvectiveMatrix_13 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part deleted file mode 100755 index 7cd462542..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part +++ /dev/null @@ -1,238 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_14.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_14 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_14( Obj, C, Term1, Term2, CType ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C(:,:,:) -! 2. Term1, Term2 "dx", "dt" -! 3. Ctype "NodalValues", "QuadPoints" -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & - DummyVec2( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()", & - "STMassMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( "Nodal", "Nodal Values", "NodalValues", & - "STNodalValues", "ST Nodal Values" ) - - CALL Obj % getConvectiveMatrix_11( Term1 = Term1, & - Term2 = Term2, C = C ) - -#ifdef DEBUG_VER - IF( Error_Flag ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()", & - "TraceBack >> & - & CALL Obj % getConvectiveMatrix_11( Term1 = Term1, & - & Term2 = Term2, C = C ) " & - ) - - END IF -#endif - - CASE( "Integration", "Integration Points", & - "IntegrationPoints", "Quad", "Quad Points", "QuadPoints" ) - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL(Term1) ) ) - - CASE( "dt", "DT", "Dt", "dT" ) - - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dt, dx ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS, IPT ), & - cdNTdXt = cdNTdXt ) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()" & - ) -#endif - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & - b = DummyVec2( :, 1 ) ) - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()", & - "Unknown value of Term2; It should be dx or dy or dz" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) - - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dx, dt ) - CASE( "dt", "DT", "Dt", "dT" ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS, IPT ), & - cdNTdXt = cdNTdXt ) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()" & - ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & - a = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()", & - "Unknown value of Term2; It should be 'dt'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()", & - "Unknown value of Term1; It should be 'dt' or 'dx'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_14()", & - "No case found for given CType; It should be & - & 'Nodal', 'NodalValues', 'Nodal Values', 'STNodalValues', & - & 'ST Nodal Values', 'Integation Points', 'Integration', & - & 'IntegrationPoints', 'Quad', 'Quad Points', 'QuadPoints'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat4FromMat2( NNT, NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - - END SUBROUTINE getConvectiveMatrix_14 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part deleted file mode 100755 index fe1487a7d..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_15.part -! Last Update : Nov-18-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_15 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_15( Obj, C, Term1, Term2, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( :, :, : ) -! 2. Term1, Term2 "dx", "dt" -! 3. nCopy -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getConvectiveMatrix_15 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part deleted file mode 100755 index f7175bbd4..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part +++ /dev/null @@ -1,51 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_16.part -! Last Update : Nov-18-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_16 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_16( Obj, C, Term1, Term2, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( :, : ) -! 2. Term1, Term2 { dx, dt } -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getConvectiveMatrix_16 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part deleted file mode 100755 index 095bcc92a..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_17.part -! Last Update : Nov-18-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_17 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_17( Obj, C, Term1, Term2, CType, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( :, : ) -! 2. Term1, Term2 {dx, dt} -! 3. CType "NodalValues", "QuadPoints" -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getConvectiveMatrix_17 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part deleted file mode 100755 index ae658547f..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_18.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_18 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_18( Obj, C, Term1, Term2, CType, nCopy) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( :, :, : ) -! 2. Term1, Term2 "dx", "dt" -! 3. CType "NodalValues", "QuadPoints" -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getConvectiveMatrix_18 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part deleted file mode 100755 index b69749b79..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part +++ /dev/null @@ -1,347 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_19.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getConvectiveMatrix_19 -!------------------------------------------------------------------------------ -! - SUBROUTINE getConvectiveMatrix_19( Obj, A, Term1, Term2, Xtype, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A( :, :, :, : ) -! 2. Term1, Term2 1, or 0 -! 3. Xtype x, y, z -! 4. MultiVar is just to create another interface -!. . . . . . . . . . . . . . . . . . . . - - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, :, : ), Mat4( :, :, :, : ) - REAL( DFP ) :: RealVal, RealVal1, Aij - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( A, 3 ) .NE. NIPS .OR. SIZE( A, 4 ) .NE. NIPT ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19()", & - "The Shape of A matrix must be ( *, *, NIPS, NIPT)" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19()", & - "XType is X therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19(), Flag-1", & - "XType is Y therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19(), Flag-1", & - "XType is Z therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Mat3( NNS, NNS, NNT ) ) - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - Mat2 = A( :, :, IPS, IPT ) - - DO aa = 1, NNT - - Mat3( :, :, aa ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), b = SD % N ) - - END DO - - DO b = 1, NNT - - RealVal = SD % T( b ) * RealVal1 - - Mat4( :, :, :, b ) = Mat3 * RealVal - - END DO - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( j, i ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - - !( 0, 1 ) - CASE( 1 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - Mat2 = A( :, :, IPS, IPT ) - - DO b = 1, NNT - - Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) - - END DO - - DO aa = 1, NNT - - RealVal = SD % T( aa ) * RealVal1 - - Mat4( :, :, aa, : ) = Mat3 * RealVal - - END DO - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( i, j ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_19()", & - "Unknown value of Term1; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - - END SUBROUTINE getConvectiveMatrix_19 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part deleted file mode 100755 index d69b69094..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part +++ /dev/null @@ -1,345 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_20.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_20 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_20( Obj, A, Term1, Term2, Xtype, MultiVar ) - -!------------------------------------------------------------------------------ -! 1. - Returns mass matrix; A is 3D array; Spatial-integration points -!------------------------------------------------------------------------------ - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, :, : ), & - & Mat4( :, :, :, : ) - REAL( DFP ) :: RealVal, RealVal1, Aij - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( A, 3 ) .NE. NIPS ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20()", & - "The Shape of A matrix must be ( *, *, NIPS)" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20()", & - "XType is X therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20(), Flag-1", & - "XType is Y therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20(), Flag-1", & - "XType is Z therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - ! CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - ! XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - -! - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Mat3( NNS, NNS, NNT ) ) - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - Mat2 = A( :, :, IPS ) - - DO aa = 1, NNT - - Mat3( :, :, aa ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), b = SD % N ) - - END DO - - DO b = 1, NNT - - RealVal = SD % T( b ) * RealVal1 - - Mat4( :, :, :, b ) = Mat3 * RealVal - - END DO - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( j, i ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - - !( 0, 1 ) - CASE( 1 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - Mat2 = A( :, :, IPS ) - - DO b = 1, NNT - - Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) - - END DO - - DO aa = 1, NNT - - RealVal = SD % T( aa ) * RealVal1 - - Mat4( :, :, aa, : ) = Mat3 * RealVal - - END DO - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( i, j ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_20()", & - "Unknown value of Term1; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - - END SUBROUTINE getConvectiveMatrix_20 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part deleted file mode 100755 index 316ddf82a..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part +++ /dev/null @@ -1,316 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_21.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_21 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_21( Obj, A, Term1, Term2, Xtype, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A( :, : ) -! 2. Term1, Term2 "dx" "dt" -! 3. XType "x, y, z" -! 4. Multivar is for -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ), ALLOCATABLE :: Mat3( :, :, : ), Mat4( :, :, :, : ) - REAL( DFP ) :: RealVal, RealVal1, Aij - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER -! Flag-3 - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21()", & - "XType is X therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - END IF - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21(), Flag-1", & - "XType is Y therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21(), Flag-1", & - "XType is Z therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - END IF - END SELECT -#endif - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Mat3( NNS, NNS, NNT ) ) - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DO aa = 1, NNT - - Mat3( :, :, aa ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), b = SD % N ) - - END DO - - DO b = 1, NNT - - RealVal = SD % T( b ) * RealVal1 - - Mat4( :, :, :, b ) = Mat3 * RealVal - - END DO - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = A( j, i ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - - !( 0, 1 ) - CASE( 1 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DO b = 1, NNT - - Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) - - END DO - - DO aa = 1, NNT - - RealVal = SD % T( aa ) * RealVal1 - - Mat4( :, :, aa, : ) = Mat3 * RealVal - - END DO - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = A( i, j ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_21()", & - "Unknown value of Term1; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - - END SUBROUTINE getConvectiveMatrix_21 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ \ No newline at end of file diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part deleted file mode 100755 index 0457b3a55..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part +++ /dev/null @@ -1,258 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_22.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_22 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_22( Obj, Term1, Term2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Term1 and Term2 = {dt, dx, dy, dz} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - -! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ) :: RealVal - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - REAL( DFP ), ALLOCATABLE :: DummyVec1( :, : ), DummyVec2( :, : ) - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_22()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_22()", & - "Term1 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_22()", & - "Term1 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_22()", & - "Term1 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_22()", & - "Term2 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_22()", & - "Term2 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_22()", & - "Term2 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL(Term1) ) ) - - CASE( "dt", "DT", "Dt", "dT" ) - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RealVal * RESHAPE( SD % dNTdXt( :, XIndex, : ), (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + & - OUTERPROD( a = DummyVec1( :, 1 ), b = DummyVec2( :, 1 ) ) - - END DO - - END DO - - CASE DEFAULT - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RealVal * RESHAPE( SD % dNTdXt( :, XIndex, : ), (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + & - OUTERPROD( b = DummyVec1( :, 1 ), a = DummyVec2( :, 1 ) ) - - END DO - - END DO - - END SELECT - - CALL Obj % Mat4FromMat2( NNT, NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - - - END SUBROUTINE getConvectiveMatrix_22 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part deleted file mode 100755 index 029e075f0..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part +++ /dev/null @@ -1,50 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_23.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_23 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_23( Obj, Term1, Term2, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Term1 and Term2 = { dt, dx, dy, dz } -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getConvectiveMatrix( Term1 = Term1, Term2 = Term2 ) - CALL Obj % MakeDiagonalCopies(nCopy) - - END SUBROUTINE getConvectiveMatrix_23 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part deleted file mode 100755 index e542b57e4..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part +++ /dev/null @@ -1,351 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_24.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_24 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_24( Obj, A, Term1, Term2, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A( :, :, :, : ) -! 2. Term1, Term2 {dt, dx, dy, dx} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) - REAL( DFP ) :: RealVal, Aij - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - -NIPT = SIZE( Obj % SD, 2 ) -NNS = SIZE( Obj % SD( 1,1 ) % N ) -NNT = SIZE( Obj % SD( 1,1 ) % T ) -NIPS = SIZE( Obj % SD, 1 ) -NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( A, 3 ) .NE. NIPS .OR. SIZE( A, 4 ) .NE. NIPT ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "The Shape of A matrix must be ( *, *, NIPS, NIPT)" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "Term1 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "Term1 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "Term1 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg("STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "Term2 is dx therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "Term2 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_24()", & - "Term2 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dt", "DT", "dT", "t" ) - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - ! XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - Mat2 = A( :, :, IPS, IPT ) - - DO b = 1, NNT - - DO aa = 1, NNT - - Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdt( :, aa ), & - b = SD % dNTdXt( :, XIndex, b ) ) - - END DO - - END DO - - Mat4 = Mat4 * RealVal - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( i, j ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - - CASE DEFAULT - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - ! XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - Mat2 = A( :, :, IPS, IPT ) - - DO b = 1, NNT - - DO aa = 1, NNT - - Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), & - b = SD % dNTdt( :, b ) ) - - END DO - - END DO - - Mat4 = Mat4 * RealVal - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( j, i ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - - END SUBROUTINE getConvectiveMatrix_24 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part deleted file mode 100755 index 9872cc2d8..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part +++ /dev/null @@ -1,347 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_25.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_25 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_25( Obj, A, Term1, Term2, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A(:,:,:) -! 2. Term1, Term2 {dt, dx, dy, dz} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) - REAL( DFP ) :: RealVal, Aij - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - -NIPT = SIZE( Obj % SD, 2 ) -NNS = SIZE( Obj % SD( 1,1 ) % N ) -NNT = SIZE( Obj % SD( 1,1 ) % T ) -NIPS = SIZE( Obj % SD, 1 ) -NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( A, 3 ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "The Shape of A matrix must be ( *, *, NIPS)" & - ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "Term1 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "Term1 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "Term1 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg("STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "Term2 is dx therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "Term2 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_25()", & - "Term2 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dt", "DT", "dT", "t" ) - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - ! XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - Mat2 = A( :, :, IPS ) - - DO b = 1, NNT - - DO aa = 1, NNT - - Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdt( :, aa ), & - b = SD % dNTdXt( :, XIndex, b ) ) - - END DO - - END DO - - Mat4 = Mat4 * RealVal - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( i, j ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - - CASE DEFAULT - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - ! XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - Mat2 = A( :, :, IPS ) - - DO b = 1, NNT - - DO aa = 1, NNT - - Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), & - b = SD % dNTdt( :, b ) ) - - END DO - - END DO - - Mat4 = Mat4 * RealVal - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = Mat2( j, i ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - - END SUBROUTINE getConvectiveMatrix_25 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part deleted file mode 100755 index 093ce3ded..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part +++ /dev/null @@ -1,338 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_25.part -! Last Update : Nov-19-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_26 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_26( Obj, A, Term1, Term2, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A( :, : ) -! 2. Term1 and Term2 {dt,dx,dy,dz} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ), ALLOCATABLE :: Mat4( :, :, :, : ) - REAL( DFP ) :: RealVal, Aij - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - -NIPT = SIZE( Obj % SD, 2 ) -NNS = SIZE( Obj % SD( 1,1 ) % N ) -NNT = SIZE( Obj % SD( 1,1 ) % T ) -NIPS = SIZE( Obj % SD, 1 ) -NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - M = SIZE( A, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "Term1 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "Term1 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "Term1 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg("STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "Term2 is dx therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "Term2 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_26()", & - "Term2 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dt", "DT", "dT", "t" ) - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - ! XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - ! Mat2 = A( :, :, IPS, IPT ) - - DO b = 1, NNT - - DO aa = 1, NNT - - Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdt( :, aa ), & - b = SD % dNTdXt( :, XIndex, b ) ) - - END DO - - END DO - - Mat4 = Mat4 * RealVal - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = A( i, j ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - - CASE DEFAULT - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - ! XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - ! Mat2 = A( :, :, IPS, IPT ) - - DO b = 1, NNT - - DO aa = 1, NNT - - Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), & - b = SD % dNTdt( :, b ) ) - - END DO - - END DO - - Mat4 = Mat4 * RealVal - - DO j = 1, M - - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - - DO i = 1, M - - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - - Aij = A( j, i ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4( :, :, :, : ) * Aij - - END DO - - END DO - - END DO - - END DO - - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - - END SUBROUTINE getConvectiveMatrix_26 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part deleted file mode 100755 index 26e5b2361..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part +++ /dev/null @@ -1,200 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_27.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix12 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_27( Obj, C, Term1, Term2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( : ) -! 2. Term1, Term2 {dt, dx, dy, dz} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & - DummyVec2( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - - ! Flag-1 -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_27()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL(Term1) ) ) - - CASE( "dt", "DT", "Dt", "dT" ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dt, dx ) - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( VectorValues = C, & - cdNTdXt = cdNTdXt) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_27()" & - ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & - b = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_27()", & - "Unknown value of Term2; It should be dx or dy or dz" & - ) - Error_Flag = .TRUE. - RETURN - END SELECT -#endif - -#ifdef DEBUG_VER - CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & - "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & - "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) -#else - CASE DEFAULT -#endif - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL(Term2) ) ) - - !( dx, dt ) - CASE( "dt", "DT", "Dt", "dT" ) -#endif - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( VectorValues = C, & - cdNTdXt = cdNTdXt ) -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_27()" & - ) -#endif - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) - DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & - a = DummyVec2( :, 1 ) ) - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_27()", & - "Unknown value of Term2; It should be 'dt' " & - ) - Error_Flag = .TRUE. - RETURN - END SELECT - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_27()", & - "Unknown value of Term1; It should be 'dt' or 'dx'" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat4FromMat2( NNT, NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - - END SUBROUTINE getConvectiveMatrix_27 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part deleted file mode 100755 index 8979b227a..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_28.part -! Last Update : Nov-18-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_28 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_28( Obj, C, Term1, Term2, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( : ) -! 2. Term1, Term2 {dt, dx, dy, dz} -!. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getConvectiveMatrix_28 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part deleted file mode 100755 index f59eef7a6..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part +++ /dev/null @@ -1,208 +0,0 @@ - -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_29.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_29 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_29( Obj, C, Term1, Term2 ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. C( : ) -! 2. Term1, Term2 = {0,1} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, b - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Mat3( :, :, : ) - REAL( DFP ) :: RealVal1, RealVal - CLASS( STShapeData_ ), POINTER :: SD - - ! Flag-1 -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_1()", & - "Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Mat3( NNS, NNS, NNT ) ) - -SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - CALL SD % getProjectionOfdNTdXt( VectorValues = C, cdNTdXt = cdNTdXt ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DO a = 1, NNT - - Mat3( :, :, a ) = OUTERPROD( a = cdNTdXt( :, a ), b = SD % N ) - - END DO - - DO b = 1, NNT - - RealVal = SD % T( b ) * RealVal1 - - Obj % Mat4( :, :, :, b ) = Obj % Mat4( :, :, :, b ) + & - Mat3 * RealVal - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_1()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - - !( 0, 1 ) - CASE( 1 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - CALL SD % getProjectionOfdNTdXt( VectorValues = C, & - cdNTdXt = cdNTdXt ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - -#ifdef DEBUG_VER - CALL Check_Error( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_1()" ) -#endif - - DO b = 1, NNT - - Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = cdNTdXt( :, b ) ) - - END DO - - - DO a = 1, NNT - - RealVal = SD % T( a ) * RealVal1 - - Obj % Mat4( :, :, a, : ) = Obj % Mat4( :, :, a, : ) + & - Mat3 * RealVal - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_1()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_1()", & - "Unknown value of Term1; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - - END SUBROUTINE getConvectiveMatrix_29 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part deleted file mode 100755 index bdc4bc5aa..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part +++ /dev/null @@ -1,231 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_30.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_30 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_30( Obj, A, A0, Term1, Term2, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A, A0 ( :, :, :, : ) -! 2. Term1, Term2 {dt, dx, dy, dz} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: A, A0 - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables -#ifdef DEBUG_VER - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, NSD -#endif - INTEGER( I4B ) :: IPS, IPT - REAL( DFP ), ALLOCATABLE :: Mat4( :, :, :, : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - IF( SIZE( A, 3 ) .NE. NIPS .OR. SIZE( A, 4 ) .NE. NIPT ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "The Shape of A matrix must be ( *, *, NIPS, NIPT)" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A0, 3 ) .NE. NIPS .OR. SIZE( A0, 4 ) .NE. NIPT ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "The Shape of A0 matrix must be ( *, *, NIPS, NIPT)" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "The size of first and second dimension of A0 must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "Term1 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "Term1 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "Term1 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "Term2 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "Term2 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_30()", & - "Term2 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - -#endif - - ALLOCATE( Mat4( SIZE( A, 1 ), SIZE( A, 2 ), SIZE( A, 3 ), SIZE( A, 4 ) ) ) - - DO IPT = 1, SIZE( A, 4 ) - DO IPS = 1, SIZE( A, 3 ) - Mat4( :, :, IPS, IPT ) = MATMUL( TRANSPOSE( A0( :,:,IPS, IPT ) ), A( :, :, IPS, IPT ) ) - END DO - END DO - - CALL Obj % getConvectiveMatrix( A = Mat4, Term1 = Term1, Term2 = Term2, MultiVar = MultiVar ) - DEALLOCATE( Mat4 ) - - END SUBROUTINE getConvectiveMatrix_30 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part deleted file mode 100755 index 837ff34f4..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part +++ /dev/null @@ -1,229 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_31.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_31 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_31( Obj, A, A0, Term1, Term2, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A, A0 ( :, :, : ) -! 2. Term1, Term2 {dt, dx, dy, dz} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A, A0 - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables -#ifdef DEBUG_VER - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, NSD -#endif - INTEGER( I4B ) :: IPS - REAL( DFP ), ALLOCATABLE :: Mat3( :, :, : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - IF( SIZE( A, 3 ) .NE. NIPS ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "The Shape of A matrix must be ( *, *, NIPS)" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A0, 3 ) .NE. NIPS ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "The Shape of A0 matrix must be ( *, *, NIPS )" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "The size of first and second dimension of A0 must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "Term1 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "Term1 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "Term1 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "Term2 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "Term2 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_31()", & - "Term2 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - ALLOCATE( Mat3( SIZE( A, 1 ), SIZE( A, 2 ), SIZE( A, 3 ) ) ) - - DO IPS = 1, SIZE( A, 3 ) - Mat3( :, :, IPS ) = MATMUL( TRANSPOSE( A0( :,:,IPS ) ), A( :, :, IPS ) ) - END DO - - CALL Obj % getConvectiveMatrix( A = Mat3, Term1 = Term1, Term2 = Term2, MultiVar = MultiVar ) - - DEALLOCATE( Mat3 ) - - END SUBROUTINE getConvectiveMatrix_31 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part deleted file mode 100755 index e9f637d6c..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part +++ /dev/null @@ -1,198 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_32.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_32 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_32( Obj, A, A0, Term1, Term2, MultiVar ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. A, A0 ( :, : ) -! 2. Term1, Term2 {dt, dx, dy, dz} -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, A0 - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar - - ! Define internal variables -#ifdef DEBUG_VER - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, NSD -#endif - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "The size of first and second dimension of A must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "The size of first and second dimension of A0 must be same" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "Term1 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "Term1 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "Term1 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "Term2 is dx therefore NSD should be & - & greater than or equal to 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "Term2 is dy therefore NSD should be greater than 1" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_32()", & - "Term2 is dz therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - Mat2 = MATMUL( TRANSPOSE( A0 ), A ) - CALL Obj % getConvectiveMatrix( A = Mat2, Term1 = Term1, Term2 = Term2, MultiVar = MultiVar ) - DEALLOCATE( Mat2 ) - - END SUBROUTINE getConvectiveMatrix_32 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part deleted file mode 100755 index 4d14c9a87..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part +++ /dev/null @@ -1,238 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_33.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_33 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns Space time convective matrix -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, :, : ) - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & - Mat3( :, : ), dUdt( : ) - REAL( DFP ) :: RealVal, RealVal1, RealVal2 - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - LOGICAL( LGT ) :: dCdU_Nodal - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - ! Flag-1 - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_33(), Flag-1", & - "STConvectiveMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - a = SIZE( dCdU, 3 ) - b = SIZE( dCdU, 4 ) - -#ifdef DEBUG_VER - IF( a .NE. NNS .AND. a .NE. NIPS ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of third index of dCdU must be equal to the NNS or NIPS" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( b .NE. NNT .AND. b .NE. NIPT ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of fourth index of dCdU must be equal to the NNT or NIPT" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( tSize .NE. NSD ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - ! Check the type of dCdU - - SELECT CASE( TRIM( dCdU_Type ) ) - - CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & - "Space Nodal Values" ) - - dCdU_Nodal = .TRUE. - - CASE( "Integration", "Integration Points", & - "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) - - dCdU_Nodal = .FALSE. - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "dCdU_Type should be either NodalValues or QuadPoints" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - - Obj % Mat4 = 0.0_DFP; - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - IF( dCdU_Nodal ) THEN - - CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ ) -#ifdef DEBUG_VER - CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_33()", & - "CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ )" ) -#endif - - ELSE - - dCdU_ = dCdU( :, :, IPS, IPT ) - - END IF - - ! Compute dUdt - dUdt = SD .dVdt. U - - DO a = 1, NNT - - Mat3 = MATMUL( SD % dNTdXt( :, :, a ), dCdU_ ) - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) - - DO b = 1, NNT - - RealVal2 = RealVal1 * SD % T( b ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - RealVal = RealVal2 * dUdt( p ) - - Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & - Obj % Mat4( r1 : r2, c1 : c2, a, b ) & - + RealVal * Mat2 - - END DO - - END DO - - END DO - - - END DO - - - END DO - - END DO - - CALL Obj % Mat2FromMat4( ) - - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) - - END SUBROUTINE getConvectiveMatrix_33 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part deleted file mode 100755 index b72196cc7..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part +++ /dev/null @@ -1,222 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_34.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_34 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns Space time convective matrix -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, : ) - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & - Mat3( :, : ), dUdt( : ) - REAL( DFP ) :: RealVal, RealVal1, RealVal2 - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - LOGICAL( LGT ) :: dCdU_Nodal - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_34(), Flag-1", & - "STConvectiveMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - a = SIZE( dCdU, 3 ) - -#ifdef DEBUG_VER - IF( a .NE. NNS .AND. a .NE. NIPS ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of third index of dCdU must be equal to the NNS or NIPS" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( tSize .NE. NSD ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - ! Check the type of dCdU - - SELECT CASE( TRIM( dCdU_Type ) ) - - CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & - "Space Nodal Values" ) - - dCdU_Nodal = .TRUE. - - CASE( "Integration", "Integration Points", & - "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) - - dCdU_Nodal = .FALSE. - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "dCdU_Type should be either NodalValues or QuadPoints" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - - Obj % Mat4 = 0.0_DFP; - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - IF( dCdU_Nodal ) THEN - - CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) -#ifdef DEBUG_VER - CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_34()", & - "CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ )" ) -#endif - ELSE - - dCdU_ = dCdU( :, :, IPS ) - - END IF - - ! Compute dUdt - dUdt = SD .dVdt. U - - DO a = 1, NNT - - Mat3 = MATMUL( SD % dNTdXt( :, :, a ), dCdU_ ) - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) - - DO b = 1, NNT - - RealVal2 = RealVal1 * SD % T( b ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - RealVal = RealVal2 * dUdt( p ) - - Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & - Obj % Mat4( r1 : r2, c1 : c2, a, b ) & - + RealVal * Mat2 - - END DO - - END DO - - END DO - - - END DO - - - END DO - - END DO - - CALL Obj % Mat2FromMat4( ) - - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) - - END SUBROUTINE getConvectiveMatrix_34 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part deleted file mode 100755 index fe13f5936..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part +++ /dev/null @@ -1,163 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_35.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_35 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_35( Obj, U, dCdU, dCdU_Type ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, : ) - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, : ), dUdt( : ) - REAL( DFP ) :: RealVal, RealVal1, RealVal2 - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_35(), Flag-1", & - "STConvectiveMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - -#ifdef DEBUG_VER - IF( tSize .NE. NSD ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_35( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - - Obj % Mat4 = 0.0_DFP; - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - ! Compute dUdt - dUdt = SD .dVdt. U - - DO a = 1, NNT - - Mat3 = MATMUL( SD % dNTdXt( :, :, a ), dCdU ) - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) - - DO b = 1, NNT - - RealVal2 = RealVal1 * SD % T( b ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - RealVal = RealVal2 * dUdt( p ) - - Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & - Obj % Mat4( r1 : r2, c1 : c2, a, b ) & - + RealVal * Mat2 - - END DO - - END DO - - END DO - - - END DO - - - END DO - - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) - - END SUBROUTINE getConvectiveMatrix_35 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part deleted file mode 100755 index 1daff9d9b..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part +++ /dev/null @@ -1,148 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_36.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_36 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_36( Obj, U ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: U( :, :, : ) - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, : ), dUdt( : ) - REAL( DFP ) :: RealVal, RealVal1, RealVal2 - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_36(), Flag-1", & - "STConvectiveMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - ! Make Indx - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - - Obj % Mat4 = 0.0_DFP; - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - ! Compute dUdt - dUdt = SD .dVdt. U - - DO a = 1, NNT - - Mat3 = SD % dNTdXt( :, :, a ) - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) - - DO b = 1, NNT - - RealVal2 = RealVal1 * SD % T( b ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - RealVal = RealVal2 * dUdt( p ) - - Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & - Obj % Mat4( r1 : r2, c1 : c2, a, b ) & - + RealVal * Mat2 - - END DO - - END DO - - END DO - - - END DO - - - END DO - - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) - - END SUBROUTINE getConvectiveMatrix_36 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part deleted file mode 100755 index bc337a38e..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part +++ /dev/null @@ -1,248 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_37.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_37 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_37( Obj, U, C, dCdU, dCdU_Type ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix -! 2. C is function of U -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, :, : ), C( :,:,:) - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & - Mat3( :, : ), Mat4(:,:), dUdX( :, : ), & - CBar( : ), dUdU( :, : ), cdUdX( : ) - REAL( DFP ) :: RealVal, RealVal1 - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - LOGICAL( LGT ) :: dCdU_Nodal - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_37(), Flag-1", & - "STConvectiveMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - a = SIZE( dCdU, 3 ) - b = SIZE( dCdU, 4 ) - -#ifdef DEBUG_VER - IF( a .NE. NNS .AND. a .NE. NIPS ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of third index of dCdU must be equal to the NNS or NIPS" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( b .NE. NNT .AND. b .NE. NIPT ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of fourth index of dCdU must be equal to the NNT or NIPT" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( tSize .NE. NSD ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - ! Check the type of dCdU - - SELECT CASE( TRIM( dCdU_Type ) ) - - CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & - "Space Nodal Values" ) - - dCdU_Nodal = .TRUE. - - CASE( "Integration", "Integration Points", & - "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) - - dCdU_Nodal = .FALSE. - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "dCdU_Type should be either NodalValues or QuadPoints" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - ALLOCATE( CBar( NSD ) ) - Obj % Mat4 = 0.0_DFP; - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - IF( dCdU_Nodal ) THEN - - CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ ) - -#ifdef DEBUG_VER - CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_37()", & - "CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ )" ) -#endif - - ELSE - - dCdU_ = dCdU( :, :, IPS, IPT ) - - END IF - - CALL SD % getInterpolationOfVector( CBar, C ) -#ifdef DEBUG_VER - CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_37()", & - "CALL SD % getInterpolationOfVector( CBar, C )" ) -#endif - ! Compute dUdt - dUdX = SD .dVdXt. U - dUdU = MATMUL( dUdX, dCdU_ ) - - cdUdX = MATMUL( dUdX, CBar ) - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - Mat4 = OUTERPROD( a = dCdU_( :, q ), b = cdUdX ) & - + OUTERPROD( a = CBar, b = dUdU( :, q ) ) - - DO a = 1, NNT - - Mat3 = MATMUL( SD % dNTdXt( :, :, a ), Mat4 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Mat2 = OUTERPROD( a = Mat3( :, p ), b = SD % N ) - - DO b = 1, NNT - - RealVal = RealVal1 * SD % T( b ) - Obj % Mat4( r1:r2, c1:c2, a, b ) = Obj % Mat4( r1:r2, c1:c2, a, b ) & - + RealVal * Mat2 - - END DO - - END DO - - END DO - - END DO - - END DO - - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) - IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) - IF( ALLOCATED( cdUdX ) ) DEALLOCATE( cdUdX ) - IF( ALLOCATED( CBar ) ) DEALLOCATE( CBar ) - - END SUBROUTINE getConvectiveMatrix_37 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part deleted file mode 100755 index 5155f2bf6..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part +++ /dev/null @@ -1,231 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_38.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_38 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_38( Obj, U, C, dCdU, dCdU_Type ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix -! 2. C is function of U -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, : ), C( :,:,:) - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & - Mat3( :, : ), Mat4(:,:), dUdX( :, : ), & - CBar( : ), dUdU( :, : ), cdUdX( : ) - REAL( DFP ) :: RealVal, RealVal1 - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - LOGICAL( LGT ) :: dCdU_Nodal - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_38(), Flag-1", & - "STConvectiveMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - a = SIZE( dCdU, 3 ) - -#ifdef DEBUG_VER - IF( a .NE. NNS .AND. a .NE. NIPS ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_38( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of third index of dCdU must be equal to the NNS or NIPS" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( tSize .NE. NSD ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_38( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - ! Check the type of dCdU - - SELECT CASE( TRIM( dCdU_Type ) ) - - CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & - "Space Nodal Values" ) - - dCdU_Nodal = .TRUE. - - CASE( "Integration", "Integration Points", & - "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) - - dCdU_Nodal = .FALSE. -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_38( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "dCdU_Type should be either NodalValues or QuadPoints" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - ALLOCATE( CBar( NSD ) ) - Obj % Mat4 = 0.0_DFP; - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - IF( dCdU_Nodal ) THEN - - CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) -#ifdef DEBUG_VER - CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_38()", & - "CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ )" ) -#endif - ELSE - - dCdU_ = dCdU( :, :, IPS ) - - END IF - - CALL SD % getInterpolationOfVector( CBar, C ) -#ifdef DEBUG_VER - CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_38()", & - "CALL SD % getInterpolationOfVector( CBar, C )" ) -#endif - ! Compute dUdt - dUdX = SD .dVdXt. U - dUdU = MATMUL( dUdX, dCdU_ ) - - cdUdX = MATMUL( dUdX, CBar ) - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - Mat4 = OUTERPROD( a = dCdU_( :, q ), b = cdUdX ) & - + OUTERPROD( a = CBar, b = dUdU( :, q ) ) - - DO a = 1, NNT - - Mat3 = MATMUL( SD % dNTdXt( :, :, a ), Mat4 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Mat2 = OUTERPROD( a = Mat3( :, p ), b = SD % N ) - - DO b = 1, NNT - - RealVal = RealVal1 * SD % T( b ) - Obj % Mat4( r1:r2, c1:c2, a, b ) = Obj % Mat4( r1:r2, c1:c2, a, b ) & - + RealVal * Mat2 - - END DO - - END DO - - END DO - - END DO - - END DO - - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) - IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) - IF( ALLOCATED( cdUdX ) ) DEALLOCATE( cdUdX ) - IF( ALLOCATED( CBar ) ) DEALLOCATE( CBar ) - - END SUBROUTINE getConvectiveMatrix_38 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part deleted file mode 100755 index eb0feadaf..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part +++ /dev/null @@ -1,177 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_39.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_39 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_39( Obj, U, C, dCdU, dCdU_Type ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix -! 2. C is function of U -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, : ), C( :,:,:) - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), & - Mat3( :, : ), Mat4(:,:), dUdX( :, : ), & - CBar( : ), dUdU( :, : ), cdUdX( : ) - REAL( DFP ) :: RealVal, RealVal1 - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_39(), Flag-1", & - "STConvectiveMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - -#ifdef DEBUG_VER - IF( tSize .NE. NSD ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_39( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - ALLOCATE( CBar( NSD ) ) - Obj % Mat4 = 0.0_DFP; - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - CALL SD % getInterpolationOfVector( CBar, C ) - -#ifdef DEBUG_VER - CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_39()", & - "CALL SD % getInterpolationOfVector( CBar, C )" ) -#endif - ! Compute dUdt - dUdX = SD .dVdXt. U - dUdU = MATMUL( dUdX, dCdU ) - - cdUdX = MATMUL( dUdX, CBar ) - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - Mat4 = OUTERPROD( a = dCdU( :, q ), b = cdUdX ) & - + OUTERPROD( a = CBar, b = dUdU( :, q ) ) - - DO a = 1, NNT - - Mat3 = MATMUL( SD % dNTdXt( :, :, a ), Mat4 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Mat2 = OUTERPROD( a = Mat3( :, p ), b = SD % N ) - - DO b = 1, NNT - - RealVal = RealVal1 * SD % T( b ) - Obj % Mat4( r1:r2, c1:c2, a, b ) = Obj % Mat4( r1:r2, c1:c2, a, b ) & - + RealVal * Mat2 - - END DO - - END DO - - END DO - - END DO - - END DO - - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) - IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) - IF( ALLOCATED( cdUdX ) ) DEALLOCATE( cdUdX ) - IF( ALLOCATED( CBar ) ) DEALLOCATE( CBar ) - - END SUBROUTINE getConvectiveMatrix_39 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part deleted file mode 100755 index 6cb9840f7..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part +++ /dev/null @@ -1,253 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ConvectiveMatrix_9.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STConvectiveMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getConvectiveMatrix_9 -!------------------------------------------------------------------------------ - - SUBROUTINE getConvectiveMatrix_9( Obj, Term1, Term2, Xtype ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - Returns mass matrix; C is a 2D array of STNodal Values -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, b, NSD - REAL( DFP ), ALLOCATABLE :: Mat3( :, :, : ) - REAL( DFP ) :: RealVal, RealVal1 - INTEGER( I4B ) :: XIndex - CLASS( STShapeData_ ), POINTER :: SD - - XIndex = 1 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9(), Flag-1", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPT = SIZE( Obj % SD, 2 ) - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - IF( NSD .LT. 1 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9(), Flag-1", & - "XType is 'dX' therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - IF( NSD .LT. 2 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "XType is 'dY' therefore NSD should be greater than 1" ) - Error_Flag = .TRUE. - RETURN - - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - IF( NSD .LT. 3 ) THEN - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "XType is Z therefore NSD should be greater than 2" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - END SELECT -#endif - - SELECT CASE( TRIM( ADJUSTL( XType ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - - XIndex = 1 - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - - XIndex = 2 - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - - XIndex = 3 - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - ALLOCATE( Mat3( NNS, NNS, NNT ) ) - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DO a = 1, NNT - - Mat3( :, :, a ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, a ), b = SD % N ) - - END DO - - DO b = 1, NNT - - RealVal = RealVal1 * SD % T( b ) - Obj % Mat4( :, :, :, b ) = Obj % Mat4( :, :, :, b ) + & - Mat3 * RealVal - - END DO - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - - SELECT CASE( Term2 ) - - !( 0, 1 ) - CASE( 1 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - DO b = 1, NNT - - Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) - - END DO - - DO a = 1, NNT - - RealVal = RealVal1 * SD % T( a ) - Obj % Mat4( :, :, a, : ) = Obj % Mat4( :, :, a, : ) + & - Mat3 * RealVal - - END DO - - END DO - - END DO -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getConvectiveMatrix_9()", & - "Unknown value of Term1; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - - END SUBROUTINE getConvectiveMatrix_9 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md deleted file mode 100755 index 44d3ddc23..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md +++ /dev/null @@ -1,4393 +0,0 @@ -# Space-Time Convective Matrix - -## ToDO - -## Stucture - -```fortran - TYPE, PUBLIC, EXTENDS( STElemShapeData_ ) :: STConvectiveMatrix_ - END TYPE -``` - -## Getting Started - -### Making the object - -```fortran -Obj = STConvectiveMatrix( Row, Col, NIPS, NIPT ) -Obj = STConvectiveMatrix( I1, I2, I3, I4, NIPS, NIPT ) -Obj = STConvectiveMatrix( ) -``` - -```fortran -Obj => STConvectiveMatrix_Pointer( Row, Col, NIPS, NIPT ) -Obj => STConvectiveMatrix_Pointer( I1, I2, I3, I4, NIPS, NIPT ) -Obj => STConvectiveMatrix_Pointer( ) -``` - -### Getting Convective Matrix - -- Currently, there are 39 interfaces for space-time convective matrix. - -- The generic subroutine for getting the convective matrix is `getConvectiveMatrix()`. A summary of different interfaces are given below. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2 ) -CALL Obj % getConvectiveMatrix( C, Term1, Term2, nCopy ) -CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType ) -CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType, nCopy ) -CALL Obj % getConvectiveMatrix( U, dCdU, dCdU_Type ) -CALL Obj % getConvectiveMatrix( U ) -CALL Obj % getConvectiveMatrix( U, C, dCdU, dCdU_Type ) -``` - -The description of each interface is provided below. - -#### Type-1 - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } -$$ - -The above two matrix can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2 ) -``` - -- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. - - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. - - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. - - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. - -#### Type-2 - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } {\delta _{pq}} -$$ - -The above two matrix can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2, nCopy ) -``` - -- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. - - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. - - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. - - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. - -#### Type-3 - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } -$$ - -In the above case if `C` is defined at integration points then we can use the following interface. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType ) -``` - -- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. -- `CType` can be `NodalValues` or `QuadPoints`. - -#### Type-4 - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } {\delta _{pq}} -$$ - -In the above case if `C` is defined at integration points then we can use the following interface. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType, nCopy ) -``` - -- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. -- `CType` can be `NodalValues` or `QuadPoints`. - -#### Type-5 - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -The above two matrices can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2 ) -``` - -- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. - - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. - - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. - - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. - -#### Type-6 - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -The above two matrices can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2, nCopy ) -``` - -- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. - - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. - - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. - - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. - -#### Type-7 - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -In the above two matrices if `C` matrix is defined at integration points then we can use the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType ) -``` - -- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. - -#### Type-8 - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -In the above two matrices if `C` matrix is defined at integration points then we can use the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType, nCopy ) -``` - -- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. -- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. -- `CType` can be `NodalValues` or `QuadPoints`. - ---- - -In case of the following terms in partial differntial equation - -$$ -\frac{{\partial {\bf{U}}}}{{\partial t}} + \frac{{\partial {\bf{f}}({\bf{U}})}}{{\partial x}} + \frac{{\partial {\bf{g}}({\bf{U}})}}{{\partial y}} + \frac{{\partial {\bf{h}}({\bf{U}})}}{{\partial z}} + \cdots -$$ - -following matrices may appear.The next few interfaces deals with these terms. - -#### Type-9 - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}} \cdot {N^J}{T_b}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}} \cdot {N^J}{T_b}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}} \cdot {N^J}{T_b}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] -$$ - -$$ -M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] -$$ - -The above six matrices can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( Term1, Term2, XType ) -``` - -- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1 at the same time. -- `XType` can be `dx`, `dy`, and `dz`. - -#### Type-10 - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}} \cdot {N^J}{T_b}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}} \cdot {N^J}{T_b}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}} \cdot {N^J}{T_b}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -$$ -{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] {\delta_{pq}} -$$ - -The above six matrices can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( Term1, Term2, XType, nCopy ) -``` - -- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1 at the same time. -- `XType` can be `dx`, `dy`, and `dz`. - -#### Type-11 - -$$ -M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] -$$ - -$$ -M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] -$$ - -$$ -M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] -$$ - -$$ -M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -$$ -M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -$$ -M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -The above six matrices can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( Term1, Term2 ) -``` - -#### Type-12 - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right]{\delta _{pq}} -$$ - -The above six matrices can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( Term1, Term2, nCopy ) -``` - ---- - -Now we want to compute the space-time convective finite element matrix for following PDE. - -$$ -\frac{\partial \textbf{U}}{\partial t} + \mathbf{A_1} \frac{\partial \textbf{U}}{\partial x} + \mathbf{A_2} \frac{\partial \textbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial \textbf{U}}{\partial z} + \cdots -$$ - -#### Type-13 - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}{{[{{\bf{A}}_{\bf{1}}}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial x}}{N^J}{T_b}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial y}}{N^J}{T_b}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial z}}{N^J}{T_b}d\Omega dt} } } \right] -$$ - -The above matrices can be computed using the following subroutine. - -```fortran -CALL Obj % getConvectiveMatrix( A, Term1, Term2, Xtype, MultiVar ) -``` - -- In the above call `A` can be Rank-4 `A(:,:,:,:)`, Rank-3 `A(:,:,:)` or Rank-2 `A(:,:)` fortran array. -- `Term-1` and `Term-2` are integers which can be 1 or 0. -- `XType` is character and it can be `dx, dy, dz`. -- `MultiVar` has no effect it is just for interface uniqness. - -#### Type-14 - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}{{[{{\bf{A}}_{\bf{1}}}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial x}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial y}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] -$$ - -$$ -{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial z}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] -$$ - -The above matrices can be computed using the following subrouine. - -```fortran -CALL Obj % getConvectiveMatrix( A, Term1, Term2, MultiVar ) -``` - -- In above case `A` can be rank-4 `A(:,:,:,:)`, rank-3 `A( :, :, : )` or rank-2 `A(:,:)`. -- In the above case `Term1` and `Term2` are characters, and it can be `dt, dx, dy, dz`. - ---- - -```fortran -CALL Obj % getConvectiveMatrix( A, A0, Term1, Term2, MultiVar ) -``` - -In the above case `A` and `A0` can be Rank-4, Rank-3, Rank-2. Term1 and Term2 are `dt, dx, dy, dz`. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -## Code used for testing the methods - -```fortran -PROGRAM MAIN -USE GlobalData -USE IO -USE ElementData_Class -USE STElement_Class -USE STSlab_Classx -USE STElemShapeData_Class -USE STConvectiveMatrix_Class - -CLASS( STElement_ ), POINTER :: Elem -CLASS( ElementData_ ), POINTER :: Data -CLASS( STSlab_ ), POINTER :: STSlabs -CLASS( STElemShapeData_ ), POINTER :: STElemSD -INTEGER( I4B ) :: Int1, NIPS, NIPT, IPS, IPT, I, a, b, J, & - NNS, NSD, NNT, XiDimension - -INTEGER( I4B ), ALLOCATABLE :: Nptrs( : ), Mat4Shape( : ) - -REAL ( DFP ), ALLOCATABLE :: DummyMat2(:,:), TimeVec( : ), & -DummyVec( : ), DummyMat3( :, :, : ), DummyMat4( :, :, :, :) - -! MAKING SPACE-TIME ELEMENT - -NSD = 2; XiDimension = 2; NNS = 4; NNT = 2 -WRITE( *, * ) "Making Space-Time Element" -CALL BlankLines( ) - -Data => ElementData( ) -CALL Data % setNSD( NSD ) -CALL Data % setNNE( NNS ) -CALL Data % setNNS( NNS ) -CALL Data % setNNT( NNT ) -CALL Data % setMatType( 1 ) -CALL Data % setElemTopology( "Quad4") -CALL Data % setSpaceElemTopology( "Quad4" ) -CALL Data % setTimeElemTopology( "Line2" ) -CALL Data % setElemType( "SpaceTimeContinuum" ) -CALL Data % setXiDimension( 2 ) - -Nptrs = (/1,2,3,4/) - -Elem => STElement( Nptrs, Data ) -CALL BlankLines( ) -CALL Elem % Display( ) - - -! MAKING SPACE-TIME SLAB - -STSlabs => STSLAB( tSTSlabs = 2, tNodes = (/4,4/)) - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( 2, 4 ) ) - -DummyMat2 = ReSHAPE( [-1.0, -1.0, 1.0, & - -1.0, 1.0, 1.0, -1.0, 1.0],[2,4]) - -CALL STSlabs % addNodes( Val = DummyMat2, STSlabNum = 1, & -NodeNum =(/1,2,3,4/) ) - -CALL STSlabs % addNodes( Val = DummyMat2, STSlabNum = 2, & -NodeNum = [1,2,3,4] ) - -! MAKING ST-CONVECTIVE-MATRIX - -ALLOCATE( TimeVec( 2 ) ) -TimeVec = [-1.0, 1.0] - -ALLOCATE( STConvectiveMatrix_ :: STElemSD ) - -! Ask for NIPS and NIPT - -WRITE( *, "(A)" ) "TESTING SPACE-TIME CONVECTIVE MATRIX :: " -CALL BlankLines( ) - -WRITE( *, "(A)") "ENTER NIPS :: " -READ( *, * ) NIPS - -WRITE( *, "(A)") "ENTER NIPT :: " -READ( *, * ) NIPT - -!NIPS = 4; NIPT = 2 - -CALL Elem % getSTElemShapeData( STElemSD_Obj = STElemSD,& -TimeVec = TimeVec, NIPS = NIPS, NIPT = NIPT, STSlab_Obj = STSlabs ) -``` - -## Structure - -## Theory - -Now we want to compute the space-time convective finite element matrix for following PDE. - -$$\frac{\partial u_i}{\partial t} + c_k \frac{\partial u_i}{\partial x_k} + \cdots $$ - -We would like to compute the following matrices. - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -> These tasks are performed by following methods; `getConvectiveMatrix_1`, `getConvectiveMatrix_2`, `getConvectiveMatrix_3`, `getConvectiveMatrix_4`, `getConvectiveMatrix_5`, `getConvectiveMatrix_6`, `getConvectiveMatrix_7`, `getConvectiveMatrix_8`, and `getConvectiveMatrix_28`. - -Now we want to compute the space-time convective finite element matrix for following PDE. - -$$\frac{\partial \textbf{U}}{\partial t} + \frac{\partial \textbf{f(U)}}{\partial x} + \frac{\partial \textbf{g(U)}}{\partial y} + \frac{\partial \textbf{h(U)}}{\partial z} + \cdots $$ - -where $\textbf{U}, \textbf{f}, \textbf{g}, \textbf{h} \in R^m$. In this case we wish to compute the following matrices. - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}g_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}g_{iJ}$$ - - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}h_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}h_{iJ}$$ - -> These tasks are performed by following methods; `getConvectiveMatrix_9`, `getConvectiveMatrix_10`. - -Now we want to compute the space-time convective finite element matrix for following PDE. - -$$\frac{\partial u_i}{\partial t} + c_k \frac{\partial u_i}{\partial x_k} + \cdots $$ - -We would like to compute the following matrices. - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -> These tasks are performed by methods `getConvectiveMatrix_11()`, `getConvectiveMatrix_12()`, `getConvectiveMatrix_13()`, `getConvectiveMatrix_14()`, `getConvectiveMatrix_15()`, `getConvectiveMatrix_16()`, `getConvectiveMatrix_17()`, `getConvectiveMatrix_18()`, `getConvectiveMatrix_27()`, and `getConvectiveMatrix_28()`. - -Now we want to compute the space-time convective finite element matrix for following PDE. - -$$\frac{\partial \textbf{U}}{\partial t} + \frac{\partial \textbf{f(U)}}{\partial x} + \frac{\partial \textbf{g(U)}}{\partial y} + \frac{\partial \textbf{h(U)}}{\partial z} + \cdots $$ - -where $\textbf{U}, \textbf{f}, \textbf{g}, \textbf{h} \in R^m$. In this case we wish to compute the following matrices. - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{iJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{iJ}$$ - -> These tasks are performed by `getConvectiveMatrix_22()` and `getConvectiveMatrix_23()` - -Now we want to compute the space-time convective finite element matrix for following PDE. - -$$\frac{\partial \textbf{U}}{\partial t} + \mathbf{A_1} \frac{\partial \textbf{U}}{\partial x} + \mathbf{A_2} \frac{\partial \textbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial \textbf{U}}{\partial z} + \cdots$$ - -where $\textbf{U} \in R^m$, $\mathbf{A_i} \in R^{m \times m}$. In this case we wish to compute the following matrices. - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ - -The shape of each ${}^{4}M(:,:,a,b)$ is $(N_{NS} \times m, N_{NS} \times m)$. In this case there will be coupling between different components of $\mathbf{U}$. This coupling is due to $\mathbf{A_i}$. The structure of any of the above ${}^{4}\mathbf{M}$ is given as - -$${}^{4}\mathbf{M}(:,:,a,b) = -\begin{bmatrix} -\mathbf{M_{11}} & \cdots & \mathbf{M_{1m}} \\ -\vdots & \ddots & \vdots \\ -\mathbf{M_{m1}} & \cdots & \mathbf{M_{mm}} \\ -\end{bmatrix}$$ - -Each $\mathbf{M_{ij}}$ has shape $(N_{ns} \times N_{ns})$. - -> These tasks are performed by methods `getConvectiveMatrix_19` to `getConvectiveMatrix_21` - -Now we want to compute the space-time convective finite element matrix for following PDE. - -$$\frac{\partial \textbf{U}}{\partial t} + \mathbf{A_1} \frac{\partial \textbf{U}}{\partial x} + \mathbf{A_2} \frac{\partial \textbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial \textbf{U}}{\partial z} + \cdots $$ - -where $\textbf{U} \in R^m$, $\mathbf{A_i} \in R^{m \times m}$. In this case we wish to compute the following matrices. - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - -The shape of each ${}^{4}M(:,:,a,b)$ is $(N_{NS} \times m, N_{NS} \times m)$. In this case there will be coupling between different components of $\mathbf{U}$. This coupling is due to $\mathbf{A_i}$. The structure of any of the above ${}^{4}\mathbf{M}$ is given as - -$${}^{4}\mathbf{M}(:,:,a,b) = -\begin{bmatrix} -\mathbf{M_{11}} & \cdots & \mathbf{M_{1m}} \\ -\vdots & \ddots & \vdots \\ -\mathbf{M_{m1}} & \cdots & \mathbf{M_{mm}} \\ -\end{bmatrix}$$ - -Each $\mathbf{M_{ij}}$ has shape $(N_{ns} \times N_{ns})$. - -> These tasks are performed by methods `getConvectiveMatrix_24()`, `getConvectiveMatrix_25()`, `getConvectiveMatrix_26()`. - -Now consider the following terms in a pde. - -$$\mathbf{A_0} \frac{\partial U}{\partial t} + \mathbf{A_1} \frac{\partial U}{\partial x} + \mathbf{A_2} \frac{\partial \mathbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial U}{\partial t} + \cdots$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - - - -## Methods - -### getConvectiveMatrix_1() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_1( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- `C(:,:,:)` is a three dimension array. It represents the space-time nodal values of convective velocity $c(x,t)$. The shape of `C` is `(NSD, NNS, NNT)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-node. The third index of `C` denotes the temporal node. In this case `C` varies with both space-time. - -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat3, Term1 = 0, Term2 = 1 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_1( C, Term1 = 0, Term2 = 1 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_1( C, Term1 = 0, Term2 = 1 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 -``` - -> As expected `NIPS = 4, NIPT = 1` is not sufficient for integration as the integrand is quadratic in time. Therefore we need atleast `NIPT = 2`. Note that this may be different incase mesh is moving, then additional time dependent terms may appear in the integrand. - -### getConvectiveMatrix_2() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_2( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- `C(:,:)` is a two dimension array. It represents the spatial nodal values of convective velocity $c(x,t)$. The shape of `C` is `(NSD, NNS)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-node. In this case, `C` varies in space but remains constant in time. - -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_1( C = DummyMat2, Term1 = 0, Term2 = 1 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 -``` - -### getConvectiveMatrix_29() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_29( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- `C(:)` is a vector array. It represents the spatial components of the convective velocity $c(x,t)$. The shape of `C` is `(NSD)`. The first index of `C` denotes the spatial coordinate. In this case, `C` remains constant in both space and time domain. - -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) - -DummyVec = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1 ) - -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_28( C = DummyMat2, Term1 = 0, Term2 = 1 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - ``` - -### getConvectiveMatrix_3() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_3( Obj, C, Term1, Term2, Ctype ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -- `C(:,:)` is a two dimension array. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the spatial nodal values, and the shape of `C` will be `(NSD, NNS)`. In this case first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. - - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at spatial-integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. - - In this method, `C` varies only in spatial dimension and remains constant in the temporal domain. -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = "Quad" ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 -``` - -### getConvectiveMatrix_4() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_4( Obj, C, Term1, Term2, Ctype ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -- `C(:,:)` is a two dimension array. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the space-time nodal values, and the shape of `C` will be `(NSD, NNS, NNT)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. The third index denotes the temporal-node. - - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at space-time integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS, NIPT)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. The third index of `C` denotes the temporal-integration point. - - In this method, `C` varies both in spatial and temporal dimension. -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = "Quad" ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.3333333 0.000000 0.3333333 0.000000 -``` - -### getConvectiveMatrix_5() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_5( Obj, C, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy -``` - -DESCRIPTION - -- `C(:,:,:)` is a three dimension array. `C` denotes the space-time nodal values of _convective velocity_, and the shape of `C` will be `(NSD, NNS, NNT)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. The third index denotes the temporal nodes. In this method, `C` varies in both spatial and temporal dimension. -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. -- `nCopy` is the number of copies that should be placed on diagonals. - -> For more details see the notes. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) - -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_5( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 -``` - -### getConvectiveMatrix_6() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_6( Obj, C, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy -``` - -DESCRIPTION - -- `C(:,:,:)` is a two dimension array. `C` denotes the space-time nodal values of _convective velocity_, and the shape of `C` will be `(NSD, NNS)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. In this method, `C` varies in only in spatial dimension, and remains constant in temporal dimension. -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. -- `nCopy` is the number of copies that should be placed on diagonals. - -> For more details see the notes. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_6( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 -``` - -### getConvectiveMatrix_7() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_7( Obj, C, Term1, Term2, CType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -- `C(:,:)` is a two dimension array. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the spatial nodal values, and the shape of `C` will be `(NSD, NNS)`. In this case first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. - - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at spatial-integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. - - In this method, `C` varies only in spatial dimension and remains constant in the temporal domain. -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. -- `nCopy` is the number of copies that should be placed on diagonals. - -> For more details see the notes. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_7( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2, CType = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 -``` - -### getConvectiveMatrix_8() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_8( Obj, C, Term1, Term2, CType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -- `C(:,:)` is a two dimension array. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the space-time nodal values, and the shape of `C` will be `(NSD, NNS, NNT)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. The third index denotes the temporal-node. - - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at space-time integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS, NIPT)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. The third index of `C` denotes the temporal-integration point. - - In this method, `C` varies both in spatial and temporal dimension. -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. -- `nCopy` is the number of copies that should be placed on diagonals. - -> For more details see the notes. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) - -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2, CType = "Quad" ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_8( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2, CType = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 -``` - -### getConvectiveMatrix_9() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_9( Obj, Term1, Term2, Xtype ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType -``` - -DESCRIPTION - -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. -- `XType` is a string which denotes the spatial gradient type. - - If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it denotes the spatial gradient with respect to `x` coordinate. - - If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it denotes the spatial gradient with respect to `y` coordinate. - - If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it denotes the spatial gradient with respect to `z` coordinate. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}g_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}g_{iJ}$$ - - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}h_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}h_{iJ}$$ - - -TESTING - -```fortran -CALL STElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = "dx" ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, XType = 'dx' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -Mat4( :, :, 1, 2 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 1 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 2 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 -``` - -### getConvectiveMatrix_10() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_10( Obj, Term1, Term2, Xtype, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: XType -``` - -DESCRIPTION - -- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. -- `XType` is a string which denotes the spatial gradient type. - - If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it denotes the spatial gradient with respect to `x` coordinate. - - If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it denotes the spatial gradient with respect to `y` coordinate. - - If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it denotes the spatial gradient with respect to `z` coordinate. -- `nCopy` is the number of copies that should be placed on diagonals. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}g_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}g_{iJ}$$ - - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}h_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}h_{iJ}$$ - -TESTING - -```fortran -CALL STElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = "X", nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_10( Term1 = 0, Term2 = 1, XType = 'X', nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 - -Mat4( :, :, 1, 2 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 1 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 2 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 -``` - -### getConvectiveMatrix_11() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_11( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- Here `C(:,:,:)` is the 3D array which denotes the **space-time** nodal values of *convection velocity* $c(x,t)$. The shape of `C` must be `C(NSD, NNS, NNT)`. Where `NSD` is number of spatial dimentsion. `NNS` number of nodes in spatial-element. `NNT` is number of nodes in time-element. -- `Term1` and `Term2` are `string`, and should not be identical. They can take following values `[dx, dy, dz, dx1, dx2, dx3, x1, x2, x3, x, y, z] [dt]`. Thesevalues represent the time derivative or spatial derivatives. -- The first set denotes the gradient. `dt` denotes the time derivative. Symbolically following matrix is computed. - - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - - -TESTING - -For all the tests `C(:,:,:) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) - -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat3 ) - -CALL STElemSD % getConvectiveMatrix( Term1 = "dx", Term2 = "dt", C = DummyMat3 ) -``` - -**`NIPS = 1`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -```fortran -CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dx', Term2 = 'dt', C = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.2500000 0.2500000 0.2500000 0.2500000 - 0.000000 0.000000 0.000000 0.000000 - -0.2500000 -0.2500000 -0.2500000 -0.2500000 - 0.000000 0.000000 0.000000 0.000000 - -Mat4( :, :, 1, 2 ) - - -0.2500000 -0.2500000 -0.2500000 -0.2500000 - 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.2500000 0.2500000 0.2500000 - 0.000000 0.000000 0.000000 0.000000 - -Mat4( :, :, 2, 1 ) - - 0.2500000 0.2500000 0.2500000 0.2500000 - 0.000000 0.000000 0.000000 0.000000 - -0.2500000 -0.2500000 -0.2500000 -0.2500000 - 0.000000 0.000000 0.000000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.2500000 -0.2500000 -0.2500000 -0.2500000 - 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.2500000 0.2500000 0.2500000 - 0.000000 0.000000 0.000000 0.000000 - -``` - -> As expected the matrices are transpose of each other, i.e. ${}^{4}M(I,J,a,b) = {}^{4}M(J,I,b,a)$. Therefore, we will consider only the first one. - -**`NIPS = 1`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -> The matrix is rank deficient, and there is no effect of increasing the `NIPT`. Therefore, we must increase the `NIPS` - -**`NIPS = 4, NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -**`NIPS = 4, NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -> `NIPS = 4, NIPT = 1` results same as `NIPS = 4, NIPT = 2`, because in the present case mesh is not moving so the integrand is linear in time therefore we need only one integration point for exact integration. Note that this may vary when mesh is also moving. - -**`NIPS = 9, NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 9 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 -``` - -Once again the results are the same. Therefore, lets stop here and move to next method. - -### getConvectiveMatrix_12() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_12( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- This subroutine perform the same task as `getConvectiveMatrix_11()` -- In this case, `C(:,:)` is a two-dimensional array. `C` denotes the spatial-nodal values of *convective velocity*. This case means that `convective velocity` does not change with time, however it changes with spatial coordiantes. The shape of `C` should be `(NSD, NNS)`. The first index denotes the spatial coordinate, and the second index denotes the spatial-node. - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx") -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt") -``` -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:,:) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat2 ) - -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_12( Term1 = 'dt', Term2 = 'dx', C = DummyMat2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - - _4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_27() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_27( Obj, C, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- This subroutine perform the same task as `getConvectiveMatrix_11()`. -- In this case `C(:)` is a one-dimensional array. `C` denotes the components of *convective velocity*. This case means that `convective velocity` is constant inside the element and does not change in space-time domain. The shape of `C` should be `(NSD)` - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx") -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt") -``` -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) - -DummyVec = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyVec ) - -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_27( Term1 = 'dt', Term2 = 'dx', C = DummyVec ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_13() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_13( Obj, C, Term1, Term2, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -- This subroutine perform the same task as `getConvectiveMatrix_11()`. -- In this case, `C(:, :)` is a 2-dimensional array. -- `Ctype` variable is an important parameter. If the value of `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaeNodalValues]` then this subroutine calls the `getConvectiveMatrix_12()`. -- If the value of `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of *convective velocity* at spatial-integration (quadrature) points. -- This case means that `convective velocity` is constant in time domain but varying in the space domain. The shape of `C` should be `(NSD, NIPS)` - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", CType = "Quad") -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", Ctype = "Quad") -``` -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:, :) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat2, CType = "Quad" ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_13( Term1 = 'dt', Term2 = 'dx', C = DummyMat2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_14() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_14( Obj, C, Term1, Term2, CType) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION - -This subroutien performs the same task as `getConvectiveMatrix_11()`, but in this case `C(:, :, :)` is a 3-dimensional array. `Ctype` variable is an important parameter. If the value of `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then this subroutine calls the `getConvectiveMatrix_11()`. If the value of `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of *convective velocity* at space-time integration (quadrature) points. This case means that `convective velocity` is changes in both space and time domain. The shape of `C` should be `(NSD, NIPS, NIPT)` - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", CType = "Quad") -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", Ctype = "Quad") -``` - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:, :, :) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) - -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat3, CType = "Quad" ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_14( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_15() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_15( Obj, C, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -Symbolically, this subroutine does the following, - -**`Term1 = dt, Term2 = dx`** - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k}{dQ} ({}^{b}u_{iJ})$$ - -**`Term1 = dx, Term2 = dt`** - -$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} ({}^{b}u_{iJ})$$ - -Here `C(:, :, :)` is a 3-dimensional array that represents the space-time nodal values of *convective velocity* $c(x,t)$. The shape of `C` array should be `(NSD, NNS, NNT)`. `Term1` and `Term2` has same meaning as defined in above methods. `nCopy` here defines the number of unknowns i.e. $u_i, i=1 \cdots nCopy$. In this case, the shape of ${}^{4}M(:,:,:,:)$ will be $(nCopy \times NNS, nCopy \times NNS, NNT, NNT)$. The structure of ${}^{4}M(:,:,a,b)$ is shown below. - -$$ -{}^{4}M(:,:,a,b)=\begin{bmatrix} - \textbf{M} & \textbf{0} & \cdots & \textbf{0} \\ - \textbf{0} & \textbf{M} & \cdots & \textbf{0} \\ - \vdots & \vdots & \ddots & \vdots \\ - \textbf{0} & \textbf{0} & \cdots & \textbf{M} \\ -\end{bmatrix}$$ - -> Here all $\textbf{M}$ are identical, and has shape `(NNS, NNS)`. For more details see the notes. - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2 ) -``` - -TESTING - -For all the tests `C(:, :, :) = 1.0`. The following code is used for testing. - -```fortran - -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) - -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat3, nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_15( Term1 = 'dt', Term2 = 'dx', C = DummyMat3, nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_16() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_16( Obj, C, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -The subroutine performs the same task as `getConvectiveMatrix_15()`. However here `C(:,:)` is a two dimensional array, and represents the spatial-nodal values. In this case the *convective velocity* $c(x,t)$ does not chage with time, and change only in space domain. For details see the notes or `getConvectiveMatrix_15()`. The shape of `C(:,:)` should be `(NSD, NNS)` - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:, :) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat2, nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_16( Term1 = 'dt', Term2 = 'dx', C = DummyMat2, nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_28() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_28( Obj, C, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - INTEGER( I4B ), INTENT( IN ) :: nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -The subroutine performs the same task as `getConvectiveMatrix_15()`. However here `C(:)` is a vector in this case, and represents the component of convective velocity. In this case the *convective velocity* $c(x,t)$ does not chage in space and time domain. For details see the notes or `getConvectiveMatrix_15()`. The shape of `C(:,:)` should be `(NSD, NNS)` - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2 ) -``` -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:, :) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) - -DummyVec = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyVec, nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_28( Term1 = 'dt', Term2 = 'dx', C = DummyVec, nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_17() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_17( Obj, C, Term1, Term2, CType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -DESCRIPTION - -The subroutine performs the same task as `getConvectiveMatrix_15()`. However, in this case, `C(:, :)` is a 2D array. If `Ctype` is `Nodal` then `C` denotes the spatial-nodal values and shape of `C` must be `(NSD, NNS)`. If `Ctype` is defined as `Quad` then `C(:,:)` represents the convective velocities at *spatial-integration* points. In this method, the *convective velocity* $c(x,t)$ does not chage in time, but varies only in space domain. The shape of `C` array should be `(NSD, NIPS)`. the second index of `C` denotes the spatial-integration points. For details see the notes or `getConvectiveMatrix_15()`. - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2, Ctype = 'Quad' ) -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2, Ctype = 'Quad' ) -``` -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:, :) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) - -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", & -C = DummyMat2, CType = "Quad", nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_17( Term1 = 'dt', Term2 = 'dx', C = DummyMat2, Ctype = 'Quad', nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_18() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_18( Obj, C, Term1, Term2, CType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -DESCRIPTION - -The subroutine performs the same task as `getConvectiveMatrix_15()`. However, in this case, `C(:, :, :)` is a 3D array. If `Ctype` is `Nodal` then `C` denotes the space-time nodal values and shape of `C` must be `(NSD, NNS, NNT)`. If `Ctype` is defined as `Quad` then `C(:,:,:)` represents the convective velocities at *space-time integration* points. In this method, the *convective velocity* $c(x,t)$ chages in both space and time domain. The shape of `C` array should be `(NSD, NIPS, NIPT)`. the second index of `C` denotes the spatial-integration points, and third index denotes the temporal integration points. For details see the notes or `getConvectiveMatrix_15()`. - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2, Ctype = 'Quad' ) -CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2, Ctype = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ - -$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ - -TESTING - -For all the tests `C(:, :, :) = 1.0`. The following code is used for testing. - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) - -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", & -C = DummyMat3, CType = "Quad", nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_18( Term1 = 'dt', Term2 = 'dx', C = DummyMat3, Ctype = 'Quad', nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 1, 2 ) - - 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 - -Mat4( :, :, 2, 1 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - -Mat4( :, :, 2, 2 ) - - -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 -``` - -### getConvectiveMatrix_22() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_22( Obj, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -- `Term1` and `Term2` are strings. They represent the time derivative and/or space-derivative. -- If `Term1` or `Term2` is in the set`[dt, Dt, dT, DT]` then it means the time derivative. -- If `Term1` or `Term2` is in the set `[dx, dx1, dX, x, X, x1, X1]` then it means deriavative with respect to `x` coordinate. -- If `Term1` or `Term2` is in the set `[dy, dx2, dY, y, Y, x2, X2]` then it means deriavative with respect to `y` coordinate. -- If `Term1` or `Term2` is in the set `[dz, dx3, dZ, z, Z, x3, X3]` then it means deriavative with respect to `z` coordinate. - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dx") -CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dy") -CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dz") -CALL Obj % getConvectiveMatrix( Term1 = "dx", Term2 = "dt") -CALL Obj % getConvectiveMatrix( Term1 = "dy", Term2 = "dt") -CALL Obj % getConvectiveMatrix( Term1 = "dz", Term2 = "dt") -``` - -> `Term1` and `Term2` should not be the same. Why?, because it does not make sense in case of convective terms. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{iJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{iJ}$$ - - -TESTING - -```fortran -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx") -CALL STElemSD % DISPLAYMATRIX4( ) - -CALL STElemSD % getConvectiveMatrix( Term1 = "dx", Term2 = "dt") -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 1`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - -Mat4( :, :, 1, 2 ) - - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - -Mat4( :, :, 2, 1 ) - - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -Mat4( :, :, 2, 2 ) - - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 -``` - -```fortran -CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dx', Term2 = 'dt') - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1250000 0.1250000 0.1250000 0.1250000 - -0.1250000 -0.1250000 -0.1250000 -0.1250000 - -0.1250000 -0.1250000 -0.1250000 -0.1250000 - 0.1250000 0.1250000 0.1250000 0.1250000 - -Mat4( :, :, 1, 2 ) - - -0.1250000 -0.1250000 -0.1250000 -0.1250000 - 0.1250000 0.1250000 0.1250000 0.1250000 - 0.1250000 0.1250000 0.1250000 0.1250000 - -0.1250000 -0.1250000 -0.1250000 -0.1250000 - -Mat4( :, :, 2, 1 ) - - 0.1250000 0.1250000 0.1250000 0.1250000 - -0.1250000 -0.1250000 -0.1250000 -0.1250000 - -0.1250000 -0.1250000 -0.1250000 -0.1250000 - 0.1250000 0.1250000 0.1250000 0.1250000 - -Mat4( :, :, 2, 2 ) - - -0.1250000 -0.1250000 -0.1250000 -0.1250000 - 0.1250000 0.1250000 0.1250000 0.1250000 - 0.1250000 0.1250000 0.1250000 0.1250000 - -0.1250000 -0.1250000 -0.1250000 -0.1250000 -``` - -> As expected the matrices are transpose of each other, i.e. ${}^{4}M(I,J,a,b) = {}^{4}M(J,I,b,a)$. Therefore, we will consider only the first one. - -**`NIPS = 1`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - -Mat4( :, :, 1, 2 ) - - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - 0.1250000 -0.1250000 -0.1250000 0.1250000 - -Mat4( :, :, 2, 1 ) - - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -Mat4( :, :, 2, 2 ) - - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 - -0.1250000 0.1250000 0.1250000 -0.1250000 -``` - -> The matrix is rank deficient, and there is no effect of increasing the `NIPT`. Therefore, we must increase the `NIPS` - -**`NIPS = 4, NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -**`NIPS = 4, NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -> `NIPS = 4, NIPT = 1` results same as `NIPS = 4, NIPT = 2`, because in the present case mesh is not moving so the integrand is linear in time therefore we need only one integration point for exact integration. Note that this may vary when mesh is also moving. - -**`NIPS = 9, NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 9 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -Once again the results are the same. Therefore, lets stop here and move to next method. - -### getConvectiveMatrix_23() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_23( Obj, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -DESCRIPTION - -- This method will create the `nCopy` of the convective matrix defined in the previous routine. - -The following code snippet can be used to perform this task. - -```fortran -CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dy", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dz", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( Term1 = "dx", Term2 = "dt", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( Term1 = "dy", Term2 = "dt", nCopy = 2 ) -CALL Obj % getConvectiveMatrix( Term1 = "dz", Term2 = "dt", nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{iJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{iJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{iJ}$$ - - -TESTING - -```fortran -CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", nCopy = 2 ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 1`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_23( Term1 = 'dt', Term2 = 'dx', nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -### getConvectiveMatrix_19() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_19( Obj, A, Term1, Term2, Xtype, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, :, : ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:,:,:)` is a four dimensional array. The shape of `A` is `(M,M,NIPS, NIPT)`. The thrid index denotes the spatial-integation point. The fourth index represent the temporal integration point. In this case, `A` changes with both space and time. -- `Term1` and `Term2` are integers, and can take values 0 or 1. If They are 1 then it means first order spatial derivative. If they are 0 then it means no spatial-derivative. -- `Xtype` is a string, which stands for the type of spatial gradient. If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) -ALLOCATE( DummyMat4( 1, 1, NIPS, NIPT ) ) -DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP; !DummyMat4( 2, 2, :, : ) = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( A = DummyMat4, Term1 = 0, Term2 = 1, XType = "dx", MultiVar = .TRUE. ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_19( A = DummyMat4, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 1, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_19( A = DummyMat4, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -Mat4( :, :, 1, 2 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 1 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 2 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 -``` - -**`NIPS = 9`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_19( A = DummyMat4, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 9 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -Mat4( :, :, 1, 2 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 1 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 2 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 - ``` - - > `NIPS = 4, NIPT = 1` is not sufficient, because the integrand is quadratic in time therefore, we need atleast `2` integration points in time domain. `NIPS = 4, NIPT = 2` will compute the integration accurately. Note that this case may change when mesh is moving. Because then additional time dependent terms may appear in the integrand. - -### getConvectiveMatrix_20() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_20( Obj, A, Term1, Term2, Xtype, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:,:)` is a three dimensional array. The shape of `A` is `(M,M,NIPS)`. The thrid index denotes the spatial-integation point. In this case, `A` changes with space, but it is constant in time. -- `Term1` and `Term2` are integers, and can take values 0 or 1. If They are 1 then it means first order spatial derivative. If they are 0 then it means no spatial-derivative. -- `Xtype` is a string, which stands for the type of spatial gradient. If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( 1, 1, NIPS ) ) -DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( A = DummyMat3, Term1 = 0, Term2 = 1, XType = "dx", MultiVar = .TRUE. ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_20( A = DummyMat3, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -Mat4( :, :, 1, 2 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 1 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 2 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 - ``` - -### getConvectiveMatrix_21() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_21( Obj, A, Term1, Term2, Xtype, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ) :: A - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: XType - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:)` is a two dimensional array. The shape of `A` is `(M,M)`. In this case, `A` does not change in space and time domain. -- `Term1` and `Term2` are integers, and can take values 0 or 1. If they are 1 then it means first order spatial derivative. If they are 0 then it means no spatial-derivative. -- `Xtype` is a string, which stands for the type of spatial gradient. If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( 1, 1 ) ) -DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( A = DummyMat2, Term1 = 0, Term2 = 1, XType = "dx", MultiVar = .TRUE. ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran -CALL STElemSD % getConvectiveMatrix_21( A = DummyMat2, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -Mat4( :, :, 1, 2 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 1 ) - - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 - -Mat4( :, :, 2, 2 ) - - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.2222222 0.2222222 0.1111111 -0.1111111 - -0.1111111 0.1111111 0.2222222 -0.2222222 - -0.1111111 0.1111111 0.2222222 -0.2222222 -``` - -### getConvectiveMatrix_24() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_24( Obj, A, Term1, Term2, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, :, : ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:, :, :)` is a four-dimensional array. The shape of `A` is `(M,M, NIPS, NIPT)`. The third index of `A` denotes the spatial-integration point. The fourth index of A denotes the temporal integration point. In this case, `A` changes in both space and time domain. -- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. - - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. - - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. - - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. - - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) -ALLOCATE( DummyMat4( 1, 1, NIPS, NIPT ) ) -DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( A = DummyMat4, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix_24( A = DummyMat4, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -**`NIPS = 4`, `NIPT = 2`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_24( A = DummyMat4, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - - > As expected `NIPS = 4, NIPT = 1` is enough for the present case, as the integrand is linear in time. However, this situation may change when the mesh is moving and new time dependent terms may appear. - -### getConvectiveMatrix_25() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_25( Obj, A, Term1, Term2, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:, :)` is a three-dimensional array. The shape of `A` is `(M,M, NIPS)`. The third index of `A` denotes the spatial-integration point. In this case, `A` changes in spatial domain but does not change with time. -- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. - - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. - - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. - - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. - - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( 1, 1, NIPS ) ) -DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( A = DummyMat3, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_25( A = DummyMat3, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -### getConvectiveMatrix_26() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_26( Obj, A, Term1, Term2, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ) :: A - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:)` is a two-dimensional array. The shape of `A` is `(M,M)`. In this case, `A` does not changes in space-time domain. -- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. - - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. - - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. - - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. - - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). - -SYMBOLIC CALCULATION - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( 1, 1 ) ) -DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( A = DummyMat2, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) -CALL STElemSD % DISPLAYMATRIX4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran - -CALL STElemSD % getConvectiveMatrix_25( A = DummyMat2, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -### getConvectiveMatrix_30() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_30( Obj, A, A0, Term1, Term2, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, :, : ) :: A, A0 - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:,:,:)` and `A0(:,:,:,:)` is a four-dimensional array. The shape of `A` and `A0` is `(M, M, NIPS, NIPT)`. The third index denotes the spatial-integration point and the fourth index denotes the temporal integration point. In this case, `A` and `A0` changes in space-time domain. -- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. - - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. - - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. - - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. - - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). - -SYMBOLIC CALCULATION - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat4 )) DEALLOCATE( DummyMat4 ) -ALLOCATE( DummyMat4( 1, 1, NIPS, NIPT ) ) -DummyMat4 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat4, & -A0 = DummyMat4, Multivar = .TRUE. ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat4, & -A0 = DummyMat4, Multivar = .TRUE. )" - -CALL STElemSD % DisplayMatrix4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat4, A0 = DummyMat4, Multivar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -### getConvectiveMatrix_31() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_31( Obj, A, A0, Term1, Term2, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ) :: A, A0 - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:,:)` and `A0(:,:,:)` is a three-dimensional array. The shape of `A` and `A0` is `(M, M, NIPS)`. The third index denotes the spatial-integration point. In this case, `A` and `A0` changes in spatial dimension but remain constant in time domain. -- `Term1` and `Term2` are strings, and denote either the temporal derivative or spatial derivative. - - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. - - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. - - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. - - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). - -SYMBOLIC CALCULATION - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 )) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( 1, 1, NIPS) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat3, & -A0 = DummyMat3, Multivar = .TRUE. ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat3, & -A0 = DummyMat3, Multivar = .TRUE. )" - -CALL STElemSD % DisplayMatrix4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat3, A0 = DummyMat3, Multivar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` - -### getConvectiveMatrix_32() - -INTERFACE - -```fortran - SUBROUTINE getConvectiveMatrix_31( Obj, A, A0, Term1, Term2, MultiVar ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ) :: A, A0 - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - LOGICAL( LGT ), INTENT( IN ) :: MultiVar -``` - -DESCRIPTION - -- `A(:,:)` and `A0(:,:)` is a two-dimensional array. The shape of `A` and `A0` is `(M, M)`. In this case, `A` and `A0` does not change in spatial and temporal domain. -- `Term1` and `Term2` are strings, and denote either the temporal derivative or spatial derivative. - - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. - - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. - - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. - - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. -- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. - -> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). - -SYMBOLIC CALCULATION - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ - - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ - -$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 )) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( 1, 1) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat2, & -A0 = DummyMat2, Multivar = .TRUE. ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat2, & -A0 = DummyMat2, Multivar = .TRUE. )" - -CALL STElemSD % DisplayMatrix4( ) -``` - -**`NIPS = 4`, `NIPT = 1`** - -```fortran -CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat2, A0 = DummyMat2, Multivar = .TRUE. ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 1 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 1, 2 ) - - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 - -Mat4( :, :, 2, 1 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -Mat4( :, :, 2, 2 ) - - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 - -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 -``` diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part deleted file mode 100644 index 784a97c99..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part +++ /dev/null @@ -1,39 +0,0 @@ -getConvectiveMatrix_1, & -getConvectiveMatrix_2, & -getConvectiveMatrix_3, & -getConvectiveMatrix_4, & -getConvectiveMatrix_5, & -getConvectiveMatrix_6, & -getConvectiveMatrix_7, & -getConvectiveMatrix_8, & -getConvectiveMatrix_9, & -getConvectiveMatrix_10, & -getConvectiveMatrix_11, & -getConvectiveMatrix_12, & -getConvectiveMatrix_13, & -getConvectiveMatrix_14, & -getConvectiveMatrix_15, & -getConvectiveMatrix_16, & -getConvectiveMatrix_17, & -getConvectiveMatrix_18, & -getConvectiveMatrix_19, & -getConvectiveMatrix_20, & -getConvectiveMatrix_21, & -getConvectiveMatrix_22, & -getConvectiveMatrix_23, & -getConvectiveMatrix_24, & -getConvectiveMatrix_25, & -getConvectiveMatrix_26, & -getConvectiveMatrix_27, & -getConvectiveMatrix_28, & -getConvectiveMatrix_29, & -getConvectiveMatrix_30, & -getConvectiveMatrix_31, & -getConvectiveMatrix_32, & -getConvectiveMatrix_33, & -getConvectiveMatrix_34, & -getConvectiveMatrix_35, & -getConvectiveMatrix_36, & -getConvectiveMatrix_37, & -getConvectiveMatrix_38, & -getConvectiveMatrix_39 diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 deleted file mode 100755 index 702abc13c..000000000 --- a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 +++ /dev/null @@ -1,112 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: STConvectiveMatrix_Class.f90 -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - STElemShapeData_ Class is extended for computing the Convection or -! Advection matrix. -! -!============================================================================== - -!------------------------------------------------------------------------------ -! USE ASSOCIATION -!------------------------------------------------------------------------------ - - MODULE STConvectiveMatrix_Class - USE IO - USE GlobalData - USE ShapeData_Class - USE STShapeData_Class - USE STElemShapeData_Class - - PRIVATE - PUBLIC :: STConvectiveMatrix_, STConvectiveMatrix_Pointer, & - STConvectiveMatrix - -!------------------------------------------------------------------------------ -! STConvectiveMatrix_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( STElemShapeData_ ) :: STConvectiveMatrix_ - -!. . . . . . . . . . . . . . . . . . . . -! 1. - This class for computation of mass matrix -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - PROCEDURE, PUBLIC, PASS :: & -#include "./MethodNames.part" - - END TYPE STConvectiveMatrix_ - -!------------------------------------------------------------------------------ -! INTERFACES -!------------------------------------------------------------------------------ - - INTERFACE STConvectiveMatrix_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 - END INTERFACE - - INTERFACE STConvectiveMatrix - MODULE PROCEDURE Constructor1, Constructor2, Constructor3 - END INTERFACE - -!------------------------------------------------------------------------------ -! CONTAINS -!------------------------------------------------------------------------------ - - CONTAINS - -#include "./Constructor.part" -#include "./ConvectiveMatrix_1.part" -#include "./ConvectiveMatrix_2.part" -#include "./ConvectiveMatrix_3.part" -#include "./ConvectiveMatrix_4.part" -#include "./ConvectiveMatrix_5.part" -#include "./ConvectiveMatrix_6.part" -#include "./ConvectiveMatrix_7.part" -#include "./ConvectiveMatrix_8.part" -#include "./ConvectiveMatrix_9.part" -#include "./ConvectiveMatrix_10.part" -#include "./ConvectiveMatrix_11.part" -#include "./ConvectiveMatrix_12.part" -#include "./ConvectiveMatrix_13.part" -#include "./ConvectiveMatrix_14.part" -#include "./ConvectiveMatrix_15.part" -#include "./ConvectiveMatrix_16.part" -#include "./ConvectiveMatrix_17.part" -#include "./ConvectiveMatrix_18.part" -#include "./ConvectiveMatrix_19.part" -#include "./ConvectiveMatrix_20.part" -#include "./ConvectiveMatrix_21.part" -#include "./ConvectiveMatrix_22.part" -#include "./ConvectiveMatrix_23.part" -#include "./ConvectiveMatrix_24.part" -#include "./ConvectiveMatrix_25.part" -#include "./ConvectiveMatrix_26.part" -#include "./ConvectiveMatrix_27.part" -#include "./ConvectiveMatrix_28.part" -#include "./ConvectiveMatrix_29.part" -#include "./ConvectiveMatrix_30.part" -#include "./ConvectiveMatrix_31.part" -#include "./ConvectiveMatrix_32.part" -#include "./ConvectiveMatrix_33.part" -#include "./ConvectiveMatrix_34.part" -#include "./ConvectiveMatrix_35.part" -#include "./ConvectiveMatrix_36.part" -#include "./ConvectiveMatrix_37.part" -#include "./ConvectiveMatrix_38.part" -#include "./ConvectiveMatrix_39.part" - - END MODULE STConvectiveMatrix_Class - diff --git a/src/submodules/STConvectiveMatrix/src/STCM_1.inc b/src/submodules/STConvectiveMatrix/src/STCM_1.inc deleted file mode 100644 index 83bace805..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_1.inc +++ /dev/null @@ -1,115 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_1a(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! Convective velocity, it can be - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_dx - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & test(ipt)%T, & - & p(:, :, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - !! - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, realval) -END SUBROUTINE STCM_1a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_1b(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - !! Convective velocity, it can be - INTEGER(I4B), INTENT(IN) :: term1 - !! del_dx - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & p(:, :, ips), & - & trial(ipt)%N(:, ips), & - & trial(ipt)%T) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - !! - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, realval) -END SUBROUTINE STCM_1b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_10.inc b/src/submodules/STConvectiveMatrix/src/STCM_10.inc deleted file mode 100644 index 7f4492b77..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_10.inc +++ /dev/null @@ -1,125 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_10a(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! dx, dy, dz - INTEGER(I4B), INTENT(IN) :: term2 - !! dx, dy, dz - TYPE(FEVariable_), INTENT(IN) :: c - !! vector variable - TYPE(FEVariable_), INTENT(IN) :: rho - !! Scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! projecton-->trial - !! - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - !! - !! 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, val=rho, interpol=rhobar) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, :, term1, ips), & - & p(:, :, ips)) - END DO - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, p, rhobar) - !! -END SUBROUTINE STCM_10a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_10b(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! dx, dy, dz - INTEGER(I4B), INTENT(IN) :: term2 - !! dx, dy, dz - TYPE(FEVariable_), INTENT(IN) :: c - !! vector variable - TYPE(FEVariable_), INTENT(IN) :: rho - !! Scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! projecton --> "test" - !! - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - !! - !! 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, val=rho, interpol=rhobar) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & p(:, :, ips), & - & trial(ipt)%dNTdXt(:, :, term2, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, p, rhobar) -END SUBROUTINE STCM_10b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc deleted file mode 100644 index afe947737..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_11.inc +++ /dev/null @@ -1,215 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, or (del_x, del_y, del_z) - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar varible - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1, 2 - !! - !! projecton --> trial - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, nsd - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) - !! - if( opt .eq. 1 ) then - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) & - & * outerprod(& - & test(ipt)%dNTdXt(:, a, ii, ips), & - & p(:,b,ips)) - END DO - END DO - END DO - END DO - !! - END DO - else - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) & - & * outerprod(& - & test(ipt)%dNTdXt(:, a, ii, ips), & - & p(:,b,ips)) - END DO - END DO - END DO - END DO - !! - END DO - end if - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, p, rhobar) - !! -END SUBROUTINE STCM_11a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, or (del_x, del_y, del_z) - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar varible - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1, 2 - !! - !! projecton-->test - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, nsd - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) - !! - if( opt .eq. 1 ) then - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) & - & * outerprod( & - & p(:,a,ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - else - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) & - & * outerprod( & - & p(:,a,ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - end if - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, p, rhobar) - !! -END SUBROUTINE STCM_11b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_12.inc b/src/submodules/STConvectiveMatrix/src/STCM_12.inc deleted file mode 100644 index ffb27a1d8..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_12.inc +++ /dev/null @@ -1,122 +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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_12a(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! not used - INTEGER(I4B), INTENT(IN) :: term2 - !! not used - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar fe variable - TYPE(FEVariable_), INTENT(IN) :: c - !! vector fe variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! projecton --> trial - !! - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:,:) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! 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, val=rho, interpol=rhobar) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( test(ipt)%dNTdt(:,:,ips), p(:, :, ips)) - END DO - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, rhobar, realval) - !! -END SUBROUTINE STCM_12a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_12b(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! not used - INTEGER(I4B), INTENT(IN) :: term2 - !! not used - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar fe variable - TYPE(FEVariable_), INTENT(IN) :: c - !! vector fe variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! projecton --> test - !! - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:,:) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! 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, val=rho, interpol=rhobar) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( p(:, :, ips), trial(ipt)%dNTdt(:, :,ips)) - END DO - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, rhobar, realval) - !! -END SUBROUTINE STCM_12b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_13.inc b/src/submodules/STConvectiveMatrix/src/STCM_13.inc deleted file mode 100644 index 6e5dfa2e7..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_13.inc +++ /dev/null @@ -1,272 +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 - -!---------------------------------------------------------------------------- -! STCM_13a -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_13a(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * test(ipt)%T(a) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar) - !! -END SUBROUTINE STCM_13a - -!---------------------------------------------------------------------------- -! STCM_13b -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_13b(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 2 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * test(ipt)%T(a) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar) - !! -END SUBROUTINE STCM_13b - -!---------------------------------------------------------------------------- -! STCM_13c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_13c(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * trial(ipt)%T(b) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%N(:, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar) - !! -END SUBROUTINE STCM_13c - -!---------------------------------------------------------------------------- -! STCM_13c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * trial(ipt)%T(b) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%N(:, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - 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 deleted file mode 100644 index 20a7621fe..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_14.inc +++ /dev/null @@ -1,272 +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 - -!---------------------------------------------------------------------------- -! STCM_14a -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_14a(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar) - !! -END SUBROUTINE STCM_14a - -!---------------------------------------------------------------------------- -! STCM_14b -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_14b(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 2 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar) - !! -END SUBROUTINE STCM_14b - -!---------------------------------------------------------------------------- -! STCM_14c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_14c(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%dNTdt(:, b, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar) - !! -END SUBROUTINE STCM_14c - -!---------------------------------------------------------------------------- -! STCM_14c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdt(:, b, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - 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 deleted file mode 100644 index 6b86dda81..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_15.inc +++ /dev/null @@ -1,292 +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 - -!---------------------------------------------------------------------------- -! STCM_15a -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_15a(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * test(ipt)%T(a) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar) - !! -END SUBROUTINE STCM_15a - -!---------------------------------------------------------------------------- -! STCM_15b -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_15b(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 2 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * test(ipt)%T(a) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar) - !! -END SUBROUTINE STCM_15b - -!---------------------------------------------------------------------------- -! STCM_15c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_15c(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * trial(ipt)%T(b) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%N(:, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar) - !! -END SUBROUTINE STCM_15c - -!---------------------------------------------------------------------------- -! STCM_15c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * trial(ipt)%T(b) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%N(:, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - 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 deleted file mode 100644 index 06ac2870a..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_16.inc +++ /dev/null @@ -1,292 +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 - -!---------------------------------------------------------------------------- -! STCM_16a -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_16a(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar) - !! -END SUBROUTINE STCM_16a - -!---------------------------------------------------------------------------- -! STCM_16b -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_16b(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: rho - !! - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 2 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar) - !! -END SUBROUTINE STCM_16b - -!---------------------------------------------------------------------------- -! STCM_16c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_16c(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), INTENT(IN) :: rho - !! - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%dNTdt(:, b, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar) - !! -END SUBROUTINE STCM_16c - -!---------------------------------------------------------------------------- -! STCM_16c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), INTENT(IN) :: rho - !! - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdt(:, b, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - 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 deleted file mode 100644 index 3f52946a9..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_17.inc +++ /dev/null @@ -1,311 +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 - -!---------------------------------------------------------------------------- -! STCM_17a -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! projecton test - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(ii, ips, ipt) & - & * outerprod( & - & p(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar, p) - !! -END SUBROUTINE STCM_17a - -!---------------------------------------------------------------------------- -! STCM_17b -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: rho - !! - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 2 - !! projecton test - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(jj, ips, ipt) & - & * outerprod( & - & p(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar, p) - !! -END SUBROUTINE STCM_17b - -!---------------------------------------------------------------------------- -! STCM_17c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), INTENT(IN) :: rho - !! - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 1 - !! projecton trial - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(ii, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & p(:, b, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, vbar, rhobar, p) - !! -END SUBROUTINE STCM_17c - -!---------------------------------------------------------------------------- -! STCM_17c -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, & - & opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all, del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), INTENT(IN) :: rho - !! - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER(I4B), INTENT(IN) :: opt - !! opt = 2 - !! projecton trial - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii, jj - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, SIZE(m6, 4) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * vbar(jj, ips, ipt) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & p(:, b, ips)) - END DO - END DO - END DO - END DO - END DO - !! - END DO - !! - CALL Convert(from=m6, to=ans) - !! - 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 deleted file mode 100644 index cb5ec15db..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_2.inc +++ /dev/null @@ -1,134 +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 -! - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_2a(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! - !! make c bar at ips and ipt - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - !! term1 .eq. del_none - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), test(ipt)%T, & - & trial(ipt)%dNTdXt(:, :, term2, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, cbar) - !! -END SUBROUTINE STCM_2a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_2b(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! - !! make c bar at ips and ipt - !! - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - !! term2 .eq. del_none - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, :, term1, ips), & - & trial(ipt)%N(:, ips), trial(ipt)%T) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, cbar) - !! -END SUBROUTINE STCM_2b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_3.inc b/src/submodules/STConvectiveMatrix/src/STCM_3.inc deleted file mode 100644 index 7ff2ee6e7..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_3.inc +++ /dev/null @@ -1,231 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_3a(ans, test, trial, term1, & - & term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar varible - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1 Mi1 - !! 2 M1i - !! - INTEGER(I4B) :: ips, ipt, a, b, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - !! make c bar at ips and ipt - !! - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - IF( opt .EQ. 1 ) THEN - !! - !! Mi1(:,:,:,:) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) * test(ipt)%T(a) & - & * outerprod( & - & test(ipt)%N(:,ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - !! - !! - !! - !! - ELSE - !! - !! M1i(:,:,:,:) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) * test(ipt)%T(a) & - & * outerprod( & - & test(ipt)%N(:,ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - END IF - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, cbar) - !! -END SUBROUTINE STCM_3a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_3b(ans, test, trial, term1, & - & term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all - INTEGER(I4B), INTENT(IN) :: term2 - !! none - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar varible - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1 --> Mi1 - !! 2 --> M1i - !! - INTEGER(I4B) :: ips, ipt, a, b, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - !! make c bar at ips and ipt - !! - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - !! - !! - IF( opt .EQ. 1 ) THEN - !! - !! Mi1 - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) * trial(ipt)%T(b) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%N(:,ips)) - END DO - END DO - END DO - END DO - !! - END DO - ELSE - !! - !! M1i - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) * trial(ipt)%T(b) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%N(:,ips)) - END DO - END DO - END DO - END DO - !! - END DO - END IF - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, cbar) - !! -END SUBROUTINE STCM_3b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_4.inc b/src/submodules/STConvectiveMatrix/src/STCM_4.inc deleted file mode 100644 index 24aeacc50..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_4.inc +++ /dev/null @@ -1,128 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_4a(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x, del_y, del_z - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! - !! make c bar at ips and ipt - !! - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:,:,ips), & - & trial(ipt)%dNTdXt(:, :, term2, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, cbar) - !! -END SUBROUTINE STCM_4a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_4b(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! - !! make c bar at ips and ipt - !! - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, :, term1, ips), & - & trial(ipt)%dNTdt(:,:,ips) & - & ) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, cbar) - !! -END SUBROUTINE STCM_4b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_5.inc b/src/submodules/STConvectiveMatrix/src/STCM_5.inc deleted file mode 100644 index 6eb81e2d8..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_5.inc +++ /dev/null @@ -1,217 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar varible - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1 - !! 2 - !! - !! Define internal variables - !! - !! - INTEGER(I4B) :: ips, ipt, a, b, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - !! make c bar at ips and ipt - !! - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - IF( opt .EQ. 1 ) THEN - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdT(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - !! - ELSE - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdT(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - !! - END IF - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, cbar) - !! -END SUBROUTINE STCM_5a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c - !! Scalar variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1 - !! 2 - !! Define internal variables - INTEGER(I4B) :: ips, ipt, a, b, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - !! make c bar at ips and ipt - !! - IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) - ELSE - CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) - cbar = 1.0_DFP - END IF - !! - IF( opt .EQ. 1 ) THEN - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdt(:, b, ips)) - END DO - END DO - END DO - END DO - !! - END DO - ELSE - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdt(:, b, ips)) - END DO - END DO - END DO - END DO - !! - END DO - END IF - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, cbar) - !! -END SUBROUTINE STCM_5b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_6.inc b/src/submodules/STConvectiveMatrix/src/STCM_6.inc deleted file mode 100644 index 700f7db54..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_6.inc +++ /dev/null @@ -1,119 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_6a(ans, test, trial, term1, term2, c, projecton, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! dx, dy, dz - INTEGER(I4B), INTENT(IN) :: term2 - !! dx, dy, dz - TYPE(FEVariable_), INTENT(IN) :: c - !! vector variable - CHARACTER(LEN=*), INTENT(IN) :: projecton - !! trial - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, :, term1, ips), & - & p(:, :, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, p) - !! -END SUBROUTINE STCM_6a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_6b(ans, test, trial, term1, term2, c, projecton, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! dx, dy, dz - INTEGER(I4B), INTENT(IN) :: term2 - !! dx, dy, dz - TYPE(FEVariable_), INTENT(IN) :: c - !! vector variable - CHARACTER(LEN=*), INTENT(IN) :: projecton - !! test - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Define internal variables - INTEGER(I4B) :: ipt, ips - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & p(:, :, ips), & - & trial(ipt)%dNTdXt(:, :, term2, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! cleanup - DEALLOCATE (IaJb, realval, p) - !! -END SUBROUTINE STCM_6b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_7.inc b/src/submodules/STConvectiveMatrix/src/STCM_7.inc deleted file mode 100644 index ac7faec21..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_7.inc +++ /dev/null @@ -1,201 +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 - -!---------------------------------------------------------------------------- -! STCM_7a -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x_all - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all, del_x, del_y, del_z - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1 - !! 2 - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - if( opt .eq. 1 ) then - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & p(:, b, ips)) - END DO - END DO - END DO - END DO - !! - END DO - else - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & p(:, b, ips)) - END DO - END DO - END DO - END DO - !! - END DO - end if - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, p) -END SUBROUTINE STCM_7a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_x, del_y, del_z - INTEGER(I4B), INTENT(IN) :: term2 - !! del_x_all - TYPE(FEVariable_), INTENT(IN) :: c - !! vector varible - INTEGER( I4B ), INTENT( IN ) :: opt - !! - !! Define internal variables - !! - INTEGER(I4B) :: ips, ipt, a, b, ii - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - !! - !! main - !! - if( opt .eq. 1 ) then - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 3) - m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & - & + realval(ips) & - & * outerprod( & - & p(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - else - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO ii = 1, SIZE(m6, 4) - m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & - & + realval(ips) & - & * outerprod( & - & p(:, a, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - END DO - END DO - END DO - END DO - !! - END DO - end if - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, realval, p) -END SUBROUTINE STCM_7b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_8.inc b/src/submodules/STConvectiveMatrix/src/STCM_8.inc deleted file mode 100644 index 5aac726a1..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_8.inc +++ /dev/null @@ -1,112 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_8a(ans, test, trial, c, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - INTEGER( I4B ), INTENT( IN ) :: term1 - INTEGER( I4B ), INTENT( IN ) :: term2 - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! vector fe variable - !! term1 = del_t - !! term2 = del_x, del_y, del_z - !! projecton = trial - !! - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( test(ipt)%dNTdt(:,:,ips), p(:, :, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, realval) -END SUBROUTINE STCM_8a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_8b(ans, test, trial, c, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: c - INTEGER( I4B ), INTENT( IN ) :: term1 - INTEGER( I4B ), INTENT( IN ) :: term2 - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! vector fe variable - !! term1 = del_x, del_y, del_z - !! term2 = del_t - !! projecton = test - !! - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - 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) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( p(:, :, ips), trial(ipt)%dNTdt(:, :,ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, realval) - !! -END SUBROUTINE STCM_8b \ No newline at end of file diff --git a/src/submodules/STConvectiveMatrix/src/STCM_9.inc b/src/submodules/STConvectiveMatrix/src/STCM_9.inc deleted file mode 100644 index 301ffc2e9..000000000 --- a/src/submodules/STConvectiveMatrix/src/STCM_9.inc +++ /dev/null @@ -1,122 +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 - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_9a(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar variable - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_dx - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: rhobar(:,:) - !! 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, val=rho, interpol=rhobar) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), test(ipt)%T, & - & p(:, :, ips)) - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, realval, rhobar) - !! -END SUBROUTINE STCM_9a - -!---------------------------------------------------------------------------- -! ConvectiveMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STCM_9b(ans, test, trial, term1, term2, rho, c, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - TYPE(FEVariable_), INTENT(IN) :: rho - !! scalar variable - TYPE(FEVariable_), INTENT(IN) :: c - !! convective velocity - INTEGER(I4B), INTENT(IN) :: term1 - !! del_dx - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - ! Define internal variables - INTEGER(I4B) :: ips, ipt - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: rhobar(:,:) - !! 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, val=rho, interpol=rhobar) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) - !! - DO ips = 1, SIZE(realval) - !! - IaJb = IaJb + realval(ips) & - & * outerprod( & - & p(:, :, ips), & - & trial(ipt)%N(:, ips), trial(ipt)%T) - !! - END DO - !! - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (IaJb, p, realval, rhobar) - !! -END SUBROUTINE STCM_9b diff --git a/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 b/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 deleted file mode 100644 index 8d8a13284..000000000 --- a/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 +++ /dev/null @@ -1,805 +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(STConvectiveMatrix_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -#include "./STCM_1.inc" -#include "./STCM_2.inc" -#include "./STCM_3.inc" -#include "./STCM_4.inc" -#include "./STCM_5.inc" -#include "./STCM_6.inc" -#include "./STCM_7.inc" -#include "./STCM_8.inc" -#include "./STCM_9.inc" -#include "./STCM_10.inc" -#include "./STCM_11.inc" -#include "./STCM_12.inc" -#include "./STCM_13.inc" -#include "./STCM_14.inc" -#include "./STCM_15.inc" -#include "./STCM_16.inc" -#include "./STCM_17.inc" - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MakeDiagonalCopiesIJab(ans, ncopy) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: ncopy - !! - REAL(DFP), ALLOCATABLE :: m2(:, :), m4(:, :, :, :) - INTEGER(I4B) :: a, b - !! - m4 = ans - !! - CALL Reallocate(ans, & - & ncopy * SIZE(m4, 1), & - & ncopy * SIZE(m4, 2), & - & SIZE(m4, 3), & - & SIZE(m4, 4)) - !! - DO b = 1, SIZE(m4, 4) - DO a = 1, SIZE(m4, 3) - CALL MakeDiagonalCopies(from=m4(:, :, a, b), to=m2, ncopy=ncopy) - ans(:, :, a, b) = m2 - END DO - END DO - !! - DEALLOCATE (m2, m4) -END SUBROUTINE MakeDiagonalCopiesIJab - -!---------------------------------------------------------------------------- -! STConvectiveMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Mat4_STConvectiveMatrix_1 -!! -SELECT CASE (term1) -!! -!! -!! -!! -CASE (DEL_NONE) - !! - SELECT CASE( term2 ) - CASE( DEL_X_ALL ) - !! - !! term1 = none - !! term2 = del_x_all - !! - CALL STCM_3a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = none - !! term2 = dx/dy/dz - !! - CALL STCM_2a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - END SELECT -!! -!! -!! -!! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - SELECT CASE( term2 ) - CASE( DEL_NONE ) - !! - !! term1 = dx/dy/dz - !! term2 = none - !! - CALL STCM_2b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = dx/dy/dz - !! term2 = DEL_X, DEL_Y, DEL_Z - !! TODO - !! - CASE( DEL_X_ALL ) - !! - !! term1 = dx/dy/dz - !! term2 = DEL_X_ALL - !! TODO - !! - CASE( DEL_T ) - !! - !! term1 = dx/dy/dz - !! term2 = dt - !! - CALL STCM_4b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - END SELECT -!! -!! -!! -!! -CASE (DEL_X_ALL) - !! - SELECT CASE( term2 ) - CASE( DEL_NONE ) - !! - !! term1 = del_x_all - !! term2 = del_none - !! - CALL STCM_3b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = del_x_all - !! term2 = del_x, del_y, del_z - !! TODO - !! - CASE( DEL_X_ALL ) - !! - !! term1 = del_x_all - !! term2 = del_x_all - !! TODO - !! - CASE( DEL_T ) - !! - !! term1 = del_x_all - !! term2 = del_t - !! - CALL STCM_5b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - END SELECT -!! -!! -!! -!! -CASE (DEL_T) - !! - SELECT CASE( term2 ) - !!case( DEL_NONE ) - !! - !! term1 = del_t - !! term2 = del_none - !! NOT POSSIBLE - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = del_t - !! term2 = del_x, del_y, del_z - CALL STCM_4a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - CASE( DEL_X_ALL ) - !! - !! term1 = del_t - !! term2 = del_x_all - !! - CALL STCM_5a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - !! case( DEL_T ) - !! - !! term1 = del_t - !! term2 = del_t - !! NOT POSSIBLE - !! - END SELECT -!! -END SELECT -!! -!! -!! -!! -END PROCEDURE Mat4_STConvectiveMatrix_1 - -!---------------------------------------------------------------------------- -! STConvectiveMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Mat4_STConvectiveMatrix_2 -!! -SELECT CASE (term1) -!! -!! -!! -!! -CASE (DEL_NONE) - !! - SELECT CASE( term2 ) - CASE( DEL_X_ALL ) - !! - !! term1 = none - !! term2 = del_x_all - !! - CALL STCM_3a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = none - !! term2 = dx/dy/dz - !! - CALL STCM_2a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - END SELECT -!! -!! -!! -!! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - SELECT CASE( term2 ) - CASE( DEL_NONE ) - !! - !! term1 = dx/dy/dz - !! term2 = none - !! - CALL STCM_2b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = dx/dy/dz - !! term2 = DEL_X, DEL_Y, DEL_Z - !! TODO - !! - CASE( DEL_X_ALL ) - !! - !! term1 = dx/dy/dz - !! term2 = DEL_X_ALL - !! TODO - !! - CASE( DEL_T ) - !! - !! term1 = dx/dy/dz - !! term2 = dt - !! - CALL STCM_4b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - END SELECT -!! -!! -!! -!! -CASE (DEL_X_ALL) - !! - SELECT CASE( term2 ) - CASE( DEL_NONE ) - !! - !! term1 = del_x_all - !! term2 = del_none - !! - CALL STCM_3b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = del_x_all - !! term2 = del_x, del_y, del_z - !! TODO - !! - CASE( DEL_X_ALL ) - !! - !! term1 = del_x_all - !! term2 = del_x_all - !! TODO - !! - CASE( DEL_T ) - !! - !! term1 = del_x_all - !! term2 = del_t - !! - CALL STCM_5b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - END SELECT -!! -!! -!! -!! -CASE (DEL_T) - !! - SELECT CASE( term2 ) - !!case( DEL_NONE ) - !! - !! term1 = del_t - !! term2 = del_none - !! NOT POSSIBLE - !! - CASE( DEL_X, DEL_Y, DEL_Z ) - !! - !! term1 = del_t - !! term2 = del_x, del_y, del_z - !! - CALL STCM_4a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - CASE( DEL_X_ALL ) - !! - !! term1 = del_t - !! term2 = del_x_all - !! - CALL STCM_5a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - !! case( DEL_T ) - !! - !! term1 = del_t - !! term2 = del_t - !! NOT POSSIBLE - !! - END SELECT -!! -END SELECT -!! -!! -!! -!! -END PROCEDURE Mat4_STConvectiveMatrix_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Mat4_STConvectiveMatrix_3 - !! -SELECT CASE (term1) -CASE (DEL_NONE) - !! - !! term1 = none - !! term2 = del_x, del_y, del_z, del_x_all - !! projecton = trial (not needed) - !! - CALL STCM_1a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - SELECT CASE (term2) - !! - CASE (DEL_NONE) - !! - !! term1 = dx/dy/dz - !! term2 = none - !! c = vector - !! - CALL STCM_1b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - CASE (DEL_t) - !! - !! term1 = dx/dy/dz - !! term2 = dt - !! c = vector - !! - CALL STCM_8b(ans=ans, test=test, trial=trial, c=c, term1=term1, & - & term2=term2, opt=opt) - !! - CASE (DEL_x, DEL_y, DEL_z) - !! - !! term1 = dx/dy/dz - !! term2 = dx/dy/dz - !! c = vector - !! - IF (TRIM(projecton) .EQ. "trial") THEN - CALL STCM_6a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, & - & projecton=projecton, opt=opt) - ELSE - CALL STCM_6b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, & - & projecton=projecton, opt=opt) - END IF - !! - CASE (DEL_x_all) - !! - !! term1 = dx/dy/dz - !! term2 = del_x_all - !! - CALL STCM_7b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=opt) - !! - END SELECT - !! - !! - !! - !! -CASE (DEL_X_ALL) - !! - SELECT CASE (term2) - CASE (DEL_NONE) - !! - !! term1 = del_x_all - !! term2 = del_none - !! - CALL STCM_1b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - CASE (DEL_T) - !! - !! term1 = del_x_all - !! term2 = del_t - !! - CALL STCM_8b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, c=c, opt=opt) - !! - CASE (DEL_X, DEL_Y, DEL_Z) - !! - !! term1 = del_x_all - !! term2 = del_x, del_y, del_z - !! - CALL STCM_7a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=opt) - !! - END SELECT - !! - !! - !! - !! -CASE (DEL_t) - !! - CALL STCM_8a(ans=ans, test=test, trial=trial, c=c, term1=term1, & - & term2=term2, opt=opt) - !! -END SELECT - !! - !! - !! - !! -END PROCEDURE Mat4_STConvectiveMatrix_3 - -!---------------------------------------------------------------------------- -! STConvectiveMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Mat4_STConvectiveMatrix_4 - !! -SELECT CASE (term1) -!! -!! -!! -!! -CASE (DEL_NONE) - !! - !! term1 = del_none - !! term2 = del_x/del_y/del_z - !! term2 = del_x_all - !! - CALL STCM_9a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) -!! -!! -!! -!! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - SELECT CASE (term2) - !! - CASE (DEL_NONE) - !! - !! term1 = del_x, del_y, del_z - !! term2 = del_none - !! - CALL STCM_9b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) - !! - CASE (DEL_t) - !! - !! term1 = del_x, del_y, del_z - !! term2 = del_t - !! - CALL STCM_12b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) - !! - CASE (DEL_x, DEL_y, DEL_z) - !! - !! term1 = del_x, del_y, del_z - !! term2 = del_x, del_y, del_z - !! - IF (TRIM(projecton) .EQ. "trial") THEN - CALL STCM_10a(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, rho=c1, c=c2, opt=opt) - ELSE - CALL STCM_10b(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, rho=c1, c=c2, opt=opt) - END IF - !! - CASE (DEL_x_all) - !! - !! term1 = del_x, del_y, del_z - !! term2 = del_x_all - !! - CALL STCM_11b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) - !! - END SELECT - !! - !! - !! - !! -CASE (DEL_X_ALL) - !! - SELECT CASE (term2) - CASE (DEL_NONE) - !! - !! term1 = del_x_all - !! term2 = del_none - !! - CALL STCM_9b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) - !! - CASE (DEL_t) - !! - !! term1 = del_x_all - !! term2 = del_t - !! - CALL STCM_12b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) - !! - CASE (DEL_x, DEL_y, DEL_z) - !! - !! term1 = del_x_all - !! term2 = del_x, del_y, del_z - !! - CALL STCM_11a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) - !! - CASE (DEL_x_all) - !! - !! term1 = del_x_all - !! term2 = del_x_all - !! - IF (TRIM(projecton) .EQ. "trial") THEN - CALL STCM_11a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=del_x, rho=c1, c=c2, opt=opt) - ELSE - CALL STCM_11b(ans=ans, test=test, trial=trial, & - & term1=del_x, term2=term2, rho=c1, c=c2, opt=opt) - END IF - !! - END SELECT - !! - !! - !! - !! -CASE (DEL_t) - !! - !! term1 = del_t - !! term2 = del_x, del_y, del_z - !! term2 = del_x_all - !! - CALL STCM_12a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) - !! -END SELECT - !! -END PROCEDURE Mat4_STConvectiveMatrix_4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Mat4_STConvectiveMatrix_5 -SELECT CASE (term1) -CASE (del_none) - !! - !! term1 = del_none - !! term2 = del_x,y,z,x_all - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_13a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=1) - ELSE - CALL STCM_13b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=2) - END IF - !! -CASE (del_t) - !! - !! term1 = del_t - !! term2 = del_x,y,z,x_all - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_14a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=1) - ELSE - CALL STCM_14b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=2) - END IF - !! -CASE DEFAULT - !! - SELECT CASE (term2) - CASE (del_none) - !! - !! term2 = del_x,y,z,x_all - !! term1 = del_none - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_13c(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=1) - ELSE - CALL STCM_13d(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=2) - END IF - !! - CASE (del_t) - !! - !! term2 = del_x,y,z,x_all - !! term1 = del_t - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_14c(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=1) - ELSE - CALL STCM_14d(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, c=c, opt=2) - END IF - !! - END SELECT -END SELECT -!! -END PROCEDURE Mat4_STConvectiveMatrix_5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Mat4_STConvectiveMatrix_6 - !! - SELECT CASE (term1) - !! - !! - !! - !! - CASE (del_none) - !! - SELECT CASE( term2 ) - !! - CASE( del_none ) - !! - !! not possible - !! - CASE( del_t ) - !! - !! not possible - !! - CASE( del_x, del_y, del_z ) - !! - !! term1 = del_none - !! term2 = del_x, del_y, del_z, del_x_all - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_15a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=1) - ELSE - CALL STCM_15b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=2) - END IF - !! - END SELECT - !! - !! - !! - !! - CASE (del_t) - !! - SELECT CASE( term2 ) - !! - CASE( del_none ) - !! - !! not possible - !! - CASE( del_t ) - !! - !! not possible - !! - CASE( del_x, del_y, del_z ) - !! - !! term1 = del_t - !! term2 = del_x, del_y, del_z - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_16a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=1) - ELSE - CALL STCM_16b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=2) - END IF - !! - END SELECT - !! - !! - !! - !! - CASE (del_x, del_y, del_z) - !! - SELECT CASE ( term2 ) - !! - CASE( del_none ) - !! - !! term1 = del_x, del_y, del_z - !! term2 = del_none - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_15c(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=1) - ELSE - CALL STCM_15d(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=2) - END IF - !! - CASE( del_t ) - !! - !! term1 = del_x, del_y, del_z, del_x_all - !! term2 = del_t - !! - IF (opt(1) .EQ. 1) THEN - CALL STCM_16c(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=1) - ELSE - CALL STCM_16d(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=2) - END IF - !! - !! - CASE( del_x, del_y, del_z ) - !! - !! term1 = del_x, del_y, del_z, del_x_all - !! term2 = del_x, del_y, del_z, del_x_all - !! - IF( TRIM(projecton) .EQ. 'test' ) THEN - IF (opt(1) .EQ. 1) THEN - CALL STCM_17a(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=1) - ELSE - CALL STCM_17b(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=2) - END IF - ELSE - IF (opt(1) .EQ. 1) THEN - CALL STCM_17c(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=1) - ELSE - CALL STCM_17d(ans=ans, test=test, trial=trial, & - & term1=term1, term2=term2, rho=c1, c=c2, opt=2) - END IF - END IF - !! - END SELECT - !! - END SELECT - !! -END PROCEDURE Mat4_STConvectiveMatrix_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/STDiffusionMatrix/CMakeLists.txt b/src/submodules/STDiffusionMatrix/CMakeLists.txt deleted file mode 100644 index cd489b9cd..000000000 --- a/src/submodules/STDiffusionMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STDiffusionMatrix_Method@Methods.F90 - ) diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part deleted file mode 100755 index 47a48a34e..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part +++ /dev/null @@ -1,138 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( Row, Col ), Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STDiffusionMatrix_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor_1 ) - ALLOCATE( Constructor_1 % Mat2( row, col ) ) - Constructor_1 % Mat2 = 0.0_DFP - CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat4( I1, I2, I3, I4 ), Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STDiffusionMatrix_ ), POINTER :: Constructor_2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor_2 ) - ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) - Constructor_2 % Mat4 = 0.0_DFP - CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty contructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STDiffusionMatrix_ ), POINTER :: Constructor_3 - ALLOCATE( Constructor_3 ) - - END FUNCTION Constructor_3 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( Row, Col ), Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STDiffusionMatrix_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor1 % Mat2( row, col ) ) - Constructor1 % Mat2 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat4( I1, I2, I3, I4 ), Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STDiffusionMatrix_ ) :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) - Constructor2 % Mat4 = 0.0_DFP - CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty contructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STDiffusionMatrix_ ) :: Constructor3 - - END FUNCTION Constructor3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part deleted file mode 100755 index 70c205a44..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part +++ /dev/null @@ -1,93 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_1.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! Ver-2 => 3Loops -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_1 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_1( Obj ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. SpaceTime Diffusion matrix - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, & - NSD, i - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - REAL( DFP ), ALLOCATABLE :: DummyVec1( : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_1(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS * NNT ) ) - Obj % Mat2 = 0.0_DFP - - ALLOCATE( DummyVec1( NNS*NNT ) ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - DO i = 1, NSD - DummyVec1 = RESHAPE( SD % dNTdXt( :, i, : ), (/NNS*NNT/) ) - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & - & + OUTERPROD( a = DummyVec1*RealVal, b = DummyVec1 ) - END DO - END DO - END DO - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - NULLIFY( SD ) - DEALLOCATE( DummyVec1 ) - -END SUBROUTINE getDiffusionMatrix_1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part deleted file mode 100755 index d0e29605f..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part +++ /dev/null @@ -1,175 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_10.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_10 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_10( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns diffusion matrix - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - - LOGICAL( LGT ) :: isC1Nodal, isC2Nodal - - isC1Nodal = .TRUE. - isC2Nodal = .TRUE. - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_10(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_10()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_10()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_10()", & - "The SIZE(C1, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_10()", & - "The SIZE(C2, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC1Nodal = .FALSE. - END SELECT - - SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC2Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD ( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - ! Make c1dNTdXt based on the CType - IF( isC1Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - SpaceNodalValues = C1 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - VectorValues = C1( :, IPS ) ) - END IF - - IF( isC2Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - SpaceNodalValues = C2 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - VectorValues = C2( :, IPS ) ) - END IF - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_10 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part deleted file mode 100755 index e78c2f728..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part +++ /dev/null @@ -1,126 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_11.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_11 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_11( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1, c2 ( : ) - ! 2. c1Type, c2Type "NodalValues" "QuapPoints" - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_11(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_11()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_11()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD ( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - ! Make c1dNTdXt based on the CType - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1 ) - - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2 ) - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_11 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part deleted file mode 100755 index 7c6714f6c..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part +++ /dev/null @@ -1,187 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_12.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_12 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1( :, :, : ) - ! 2. c2( :, : ) - ! 3. c1Type, c2Type "NodalValues", "QuadPoints" - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isC1Nodal, isC2Nodal - - isC1Nodal = .TRUE. - isC2Nodal = .TRUE. - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_12(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_12()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_12()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_12()", & - "The SIZE(C1, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 3 ) .NE. NIPT .AND. SIZE( C1, 3 ) .NE. NNT ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_12()", & - "The SIZE(C1, 3) should be equal to either NIPT, & - & or NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_12()", & - "The SIZE(C2, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC1Nodal = .FALSE. - END SELECT - - SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC2Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - IF( isC1Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & STNodalValues = C1 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1( :, IPS, IPT ) ) - END IF - - IF( isC2Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & SpaceNodalValues = C2 ) - ELSE - CALL Obj % SD( IPS, IPT ) % & - & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2( :, IPS ) ) - END IF - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_12 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part deleted file mode 100755 index a3bea5229..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part +++ /dev/null @@ -1,183 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_13.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_13 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_13( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1( :, : ), c2( :, :, : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isC1Nodal, isC2Nodal - - isC1Nodal = .TRUE. - isC2Nodal = .TRUE. - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_13(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_13()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_13()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_13()", & - "The SIZE(C1, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_13()", & - "The SIZE(C2, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 3 ) .NE. NIPT .AND. SIZE( C2, 3 ) .NE. NNT ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_13()", & - "The SIZE(C2, 3) should be equal to either NIPT, & - & or NNT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC1Nodal = .FALSE. - END SELECT - - SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC2Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - IF( isC1Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & SpaceNodalValues = C1 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1( :, IPS ) ) - END IF - - IF( isC2Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & STNodalValues = C2 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2( :, IPS, IPT ) ) - END IF - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_13 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part deleted file mode 100755 index 20716262b..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part +++ /dev/null @@ -1,161 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_14.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_14 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_14( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1( :, :, : ), c2( : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isC1Nodal - - isC1Nodal = .TRUE. - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_14(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_14()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_14()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_14()", & - "The SIZE(C1, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 3 ) .NE. NIPT .AND. SIZE( C1, 3 ) .NE. NNT ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_14()", & - "The SIZE(C1, 3) should be equal to either NIPT, & - & or NNT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - & "Integration", "Integration Points", & - & "IntegrationPoints" ) - isC1Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - IF( isC1Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & STNodalValues = C1 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1( :, IPS, IPT ) ) - END IF - - CALL Obj % SD( IPS, IPT ) % & - & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2 ) - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_14 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part deleted file mode 100755 index 3ee53dd5b..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part +++ /dev/null @@ -1,160 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_15.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_15 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_15( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1( : ), c2( :, :, : ) - !. . . . . . . . . . . . . . . . . . . .-- - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isC2Nodal - - isC2Nodal = .TRUE. - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_15(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_15()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_15()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_15()", & - "The SIZE(C2, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 3 ) .NE. NIPT .AND. SIZE( C2, 3 ) .NE. NNT ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_15()", & - "The SIZE(C2, 3) should be equal to either NIPT, & - & or NNT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC2Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1 ) - - IF( isC2Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & STNodalValues = C2 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2( :, IPS, IPT ) ) - END IF - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_15 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part deleted file mode 100755 index 3a734cb40..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part +++ /dev/null @@ -1,152 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_16.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_16 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_16( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1( :, : ), c2( : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isC1Nodal - - isC1Nodal = .TRUE. - -#ifdef DEBUG_VER - ! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_16(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_16()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_16()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_16()", & - "The SIZE(C1, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC1Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - IF( isC1Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & SpaceNodalValues = C1 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1( :, IPS ) ) - END IF - - CALL Obj % SD( IPS, IPT ) % & - & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2 ) - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_16 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part deleted file mode 100755 index a3dc066e9..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part +++ /dev/null @@ -1,150 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_17.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_17 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_17( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1( : ), c2( :, : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isC2Nodal - - isC2Nodal = .TRUE. - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_17(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_17()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_17()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STConvectiveMatrix_Class.f90", & - "getDiffusionMatrix_17()", & - "The SIZE(C2, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC2Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1 ) - - IF( isC2Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & SpaceNodalValues = C2 ) - ELSE - CALL Obj % SD( IPS, IPT ) % & - & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2( :, IPS ) ) - END IF - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) -END SUBROUTINE getDiffusionMatrix_17 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part deleted file mode 100755 index 16a02d0c4..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_18.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_18 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_18( Obj, c1, c2, c1Type, c2Type, nCopy ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1( :, :, : ), c2( :, :, : ) - ! 2. c1Type, c2Type "NodalValues", "QuadPoints" - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - -END SUBROUTINE getDiffusionMatrix_18 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part deleted file mode 100755 index 0a707d1b8..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part +++ /dev/null @@ -1,52 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_19.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_19 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_19( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c1( :, : ), c2( :, : ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_19 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part deleted file mode 100755 index 9234e6212..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part +++ /dev/null @@ -1,50 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_2.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_2 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_2( Obj, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns mass matrix; C is a 2D array of STNodal Values -!. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part deleted file mode 100755 index f69aa9d5e..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_20.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_20 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_20( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c1( : ), c2( : ) -!. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_20 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part deleted file mode 100755 index b03a273e6..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_21.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_21 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_21( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c1( :, :, : ), c2( :, : ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_21 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part deleted file mode 100755 index 7f0b08b6d..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part +++ /dev/null @@ -1,53 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_22.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_22 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_22( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c2( :, :, : ), c1( :, : ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_22 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part deleted file mode 100755 index 5640683c6..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part +++ /dev/null @@ -1,54 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_23.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_23 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_23( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c1( :, :, : ) -! 2. c2( : ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_23 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part deleted file mode 100755 index 5f7940012..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part +++ /dev/null @@ -1,55 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_24.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_24 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_24( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c1( : ) -! 2. c2( :, :, : ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_24 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part deleted file mode 100755 index 619d340e4..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part +++ /dev/null @@ -1,54 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_25.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_25 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_25( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c1( :, : ) -! 2. c2( : ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_25 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part deleted file mode 100755 index 79e86275e..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part +++ /dev/null @@ -1,54 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_26.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_26 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_26( Obj, c1, c2, c1Type, c2Type, nCopy ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. c1( : ) -! 2. c2( :, : ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & - & c1Type = c1Type, c2Type = c2Type ) - CALL Obj % MakeDiagonalCopies( nCopy ) - - END SUBROUTINE getDiffusionMatrix_26 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part deleted file mode 100755 index b5043456f..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part +++ /dev/null @@ -1,234 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_27.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_27 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_27( Obj, K, Term1, Term2 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, :, : ) - ! 2. Term1, Term2 {dx, dy, dz} - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ) :: RealVal1, RealVal - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - INTEGER( I4B ) :: XIndx1, XIndx2 - - CLASS( STShapeData_ ), POINTER :: SD - - XIndx1 = 1 - XIndx2 = 1 - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( K, 3 ) .NE. NIPS .OR. SIZE( K, 4 ) .NE. NIPT ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27(), Flag-2", & - "The SIZE( K, 3 ) should be NIPS, & - & SIZE( K, 4 ) should be NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27(), Flag-3", & - "The size of first and second dimension of K must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( K, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27()", & - "Term1 is 'x' or 'dx' therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27()", & - "Term1 is 'dy' or 'y', & - & therefore NSD should be greater than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27()", & - "Term1 is 'dz' or 'z', therefore, & - & NSD should be greater than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27()", & - "Term2 is 'x' or 'dx' therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27()", & - "Term2 is 'dy' or 'y', & - & therefore NSD should be greater than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_27()", & - "Term2 is 'dz' or 'z', therefore, & - & NSD should be greater than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - END SELECT -#endif - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - XIndx1 = 1 - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - XIndx1 = 2 - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - XIndx1 = 3 - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - XIndx2 = 1 - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - XIndx2 = 2 - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - XIndx2 = 3 - END SELECT - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - DO b = 1, NNT - DO aa = 1, NNT - Mat4( :, :, aa, b ) = & - & OUTERPROD( a = SD % dNTdXt( :, XIndx1, aa ), & - & b = SD % dNTdXt( :, XIndx2, b ) ) - END DO - END DO - - Mat2 = K( :, :, IPS, IPT ) - - DO j = 1, M - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - DO i = 1, M - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - RealVal = Mat2( i, j ) * RealVal1 - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) + Mat4*RealVal - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - -END SUBROUTINE getDiffusionMatrix_27 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part deleted file mode 100755 index 01a7c7dd6..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part +++ /dev/null @@ -1,234 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_28.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_28 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_28( Obj, K, Term1, Term2 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, :, : ) - ! 2. Term1, Term2 {dx, dy, dz} - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ) :: RealVal1, RealVal - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - INTEGER( I4B ) :: XIndx1, XIndx2 - - CLASS( STShapeData_ ), POINTER :: SD - - XIndx1 = 1 - XIndx2 = 1 - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( K, 3 ) .NE. NIPS ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28(), Flag-2", & - "The SIZE( K, 3 ) should be NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28(), Flag-3", & - "The size of first and second dimension of K must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( K, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term1 is 'x' or 'dx' therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term1 is 'dy' or 'y', & - & therefore NSD should be greater than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term1 is 'dz' or 'z', therefore, & - & NSD should be greater than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term2 is 'x' or 'dx' therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term2 is 'dy' or 'y', & - & therefore NSD should be greater than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term2 is 'dz' or 'z', therefore, & - & NSD should be greater than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - - END SELECT -#endif - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - XIndx1 = 1 - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - XIndx1 = 2 - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - XIndx1 = 3 - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - XIndx2 = 1 - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - XIndx2 = 2 - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - XIndx2 = 3 - END SELECT - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - DO b = 1, NNT - DO aa = 1, NNT - Mat4( :, :, aa, b ) = & - & OUTERPROD( a = SD % dNTdXt( :, XIndx1, aa ), & - & b = SD % dNTdXt( :, XIndx2, b ) ) - END DO - END DO - - Mat2 = K( :, :, IPS ) - - DO j = 1, M - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - DO i = 1, M - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - RealVal = Mat2( i, j ) * RealVal1 - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) + Mat4*RealVal - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - -END SUBROUTINE getDiffusionMatrix_28 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part deleted file mode 100755 index 1de30542c..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part +++ /dev/null @@ -1,222 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_29.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_29 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_29( Obj, K, Term1, Term2 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M - REAL( DFP ) :: RealVal1, RealVal - REAL( DFP ), ALLOCATABLE :: Mat4( :, :, :, : ) - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - INTEGER( I4B ) :: XIndx1, XIndx2 - - CLASS( STShapeData_ ), POINTER :: SD - - XIndx1 = 1 - XIndx2 = 1 - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28(), Flag-3", & - "The size of first and second dimension of K must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( K, 1 ) - -#ifdef DEBUG_VER - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term1 is 'x' or 'dx' therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term1 is 'dy' or 'y', & - & therefore NSD should be greater than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term1 is 'dz' or 'z', therefore, & - & NSD should be greater than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - IF( NSD .LT. 1 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term2 is 'x' or 'dx' therefore NSD should be & - & greater than or equal to 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - IF( NSD .LT. 2 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term2 is 'dy' or 'y', & - & therefore NSD should be greater than 1" ) - Error_Flag = .TRUE. - RETURN - END IF - - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - IF( NSD .LT. 3 ) THEN - CALL Err_Msg("STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_28()", & - "Term2 is 'dz' or 'z', therefore, & - & NSD should be greater than 2" ) - Error_Flag = .TRUE. - RETURN - END IF - - END SELECT -#endif - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - ALLOCATE( Indx( M, 2 ) ) - Indx = 0 - DO i = 1, M - Indx( i, 1 ) = (i-1)*NNS + 1 - Indx( i, 2 ) = i*NNS - END DO - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - XIndx1 = 1 - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - XIndx1 = 2 - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - XIndx1 = 3 - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) - - CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) - XIndx2 = 1 - CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) - XIndx2 = 2 - CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) - XIndx2 = 3 - END SELECT - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - DO b = 1, NNT - DO aa = 1, NNT - Mat4( :, :, aa, b ) = & - & OUTERPROD( a = SD % dNTdXt( :, XIndx1, aa ), & - & b = SD % dNTdXt( :, XIndx2, b ) ) - END DO - END DO - DO j = 1, M - c1 = Indx( j, 1 ) - c2 = Indx( j, 2 ) - DO i = 1, M - r1 = Indx( i, 1 ) - r2 = Indx( i, 2 ) - RealVal = K( i, j ) * RealVal1 - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - & Obj % Mat4( r1:r2, c1:c2, :, : ) + Mat4*RealVal - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - -END SUBROUTINE getDiffusionMatrix_29 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part deleted file mode 100755 index 2e84b8673..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part +++ /dev/null @@ -1,136 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_3.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_3 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_3( Obj, K ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, :, :, : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, & - NSD, j - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), DummyMat3( :,:,: ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - & "STDiffusionMatrix_Class.f90", & - & "getDiffusionMatrix_3(), Flag-1", & - & "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN - CALL Err_Msg( & - & "STDiffusionMatrix_Class.f90", & - & "getDiffusionMatrix_3()", & - & "The SIZE(K, 1) should be equal to SIZE(K, 2)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( K, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - & "STDiffusionMatrix_Class.f90", & - & "getDiffusionMatrix_3()", & - & "The SIZE(K, 1) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( K, 3 ) .NE. NIPS .OR. SIZE( K, 4 ) .NE. NIPT ) THEN - CALL Err_Msg( & - & "STDiffusionMatrix_Class.f90", & - & "getDiffusionMatrix_3()", & - & "The SIZE(K, 3) should be equal to NIPS, & - & and SIZE(K,4) should be equal to NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - ALLOCATE( DummyMat3( NNS, NSD, NNT ) ) - ALLOCATE( DummyVec1( NNT*NNS ), DummyVec2( NNT*NNS ) ) - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - Mat2 = K( :, :, IPS, IPT ) - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - DO a = 1, NNT - DummyMat3( :, :, a ) = MATMUL( SD % dNTdXt( :, :, a ), Mat2 ) - END DO - - DO j = 1, NSD - DummyVec1 = RESHAPE( SD % dNTdXt( :, j, : ), (/NNS*NNT/) ) - DummyVec2 = RealVal*RESHAPE( DummyMat3( :, j, : ), (/NNS*NNT/) ) - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & - + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - NULLIFY( SD ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2) ) DEALLOCATE( DummyVec2) - IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) - -END SUBROUTINE getDiffusionMatrix_3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part deleted file mode 100755 index 17f5985f7..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part +++ /dev/null @@ -1,180 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_30.part -! Last Update : March-05-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_30 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_30( Obj, TimeVector, IntegrationSide ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns Diffusion matrix for acoustic wave equation -! 2. Time Integration is character "Right", "Left", "Both" -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, M, p, q - REAL( DFP ), ALLOCATABLE :: dNTdXt( :, :, : ), T( : ), dNTdXt2( :, :, : ) - REAL( DFP ) :: Ws, Js, thick, RealVal, Jt, Wt, Kij, t1, t2, Theta - TYPE( STElemShapeData_ ), TARGET :: STElemSD - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_30()", & - "STDiffusionMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - M = NSD - - t1 = TimeVector( 1 ) - t2 = TimeVector( 2 ) - - ! Make copy of Obj - CALL STElemSD % Initiate( Obj ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => STElemSD .SDPointer. [IPS, IPT] - Theta = .Theta. SD - T = SD .TimeIntegration. [t1, t2, Theta] - - CALL SD % setT( T ) - CALL Check_Error( & - "STDiffusionMatrix_Class.f90>>DiffusionMatrix_30.part", & - "Traceback ---> CALL SD % setT( T )"& - ) - - CALL SD % setdNTdXt( ) - CALL Check_Error( & - "STDiffusionMatrix_Class.f90>>DiffusionMatrix_30.part", & - "Traceback ---> CALL SD % setdNTdXT( )"& - ) - SD => NULL( ) - - END DO - - END DO - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - CALL STElemSD % SD( IPS, IPT ) % getdNTdXt( dNTdXt2 ) - - RealVal = Ws * Wt * Js * Jt * thick - - DO aa = 1, NNT - - DO b = 1, NNT - - DO p = 1, NSD - - SELECT CASE( TRIM( IntegrationSide ) ) - - CASE( "Right", "RIGHT", "right" ) - Obj % Mat4( :, :, aa, b ) = & - Obj % Mat4( :, :, aa, b ) + & - OUTERPROD( a = dNTdXt( :, p, aa ), & - b = dNTdXt2( :, p, b ) ) * RealVal - - CASE( "Left", "LEFT", "left" ) - Obj % Mat4( :, :, aa, b ) = & - Obj % Mat4( :, :, aa, b ) + & - OUTERPROD( a = dNTdXt2( :, p, aa ), & - b = dNTdXt( :, p, b ) ) * RealVal - - CASE( "Both", "BOTH", "both" ) - Obj % Mat4( :, :, aa, b ) = & - Obj % Mat4( :, :, aa, b ) + & - OUTERPROD( a = dNTdXt2( :, p, aa ), & - b = dNTdXt2( :, p, b ) ) * RealVal - - CASE DEFAULT - Obj % Mat4( :, :, aa, b ) = & - Obj % Mat4( :, :, aa, b ) + & - OUTERPROD( a = dNTdXt( :, p, aa ), & - b = dNTdXt( :, p, b ) ) * RealVal - - END SELECT - - END DO - - END DO - - END DO - - END DO - - END DO - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( dNTdXt ) ) DEALLOCATE( dNTdXt ) - IF( ALLOCATED( dNTdXt2 ) ) DEALLOCATE( dNTdXt2 ) - IF( ALLOCATED( T ) ) DEALLOCATE( T ) - CALL STElemSD % DeallocateData( ) - SD => NULL( ) - - END SUBROUTINE getDiffusionMatrix_30 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part deleted file mode 100755 index aa56524ac..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part +++ /dev/null @@ -1,211 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_31.part -! Last Update : March-27-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Diffusion matrix for pressure wave equation for -! alpha-beta-v-STFEM -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_31 -!------------------------------------------------------------------------------ - - SUBROUTINE getDiffusionMatrix_31( Obj, TimeVector, IntegrationSide, Beta_STFEM ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns Diffusion matrix for acoustic wave equation -! 2. Time Integration is character "Right", "Left", "Both" -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ), Beta_STFEM - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, M, p, q - - REAL( DFP ), ALLOCATABLE :: dNTdXt( :, :, : ), T( : ), dNTdXt2( :, :, : ), & - dNTdXt3( :, :, : ) - REAL( DFP ) :: Beta, Ws, Js, thick, RealVal, Jt, Wt, Kij, t1, t2, Theta - TYPE( STElemShapeData_ ), TARGET :: STElemSD, STElemSD2 - CLASS( STShapeData_ ), POINTER :: SD => NULL( ), SD2 => NULL( ) - - Error_Flag = .FALSE. - - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_31()", & - "STDiffusionMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - M = NSD - - t1 = TimeVector( 1 ) - t2 = TimeVector( 2 ) - - Beta = Beta_STFEM * ( t2 - t1 ) - - ! Make copy of Obj - CALL STElemSD % Initiate( Obj ) - CALL STElemSD2 % Initiate( Obj ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => STElemSD .SDPointer. [IPS, IPT] - Theta = .Theta. SD - T = SD .TimeIntegration. [t1, t2, Theta] - - CALL SD % setT( T ) - CALL Check_Error( & - "STDiffusionMatrix_Class.f90>>DiffusionMatrix_31.part", & - "Traceback ---> CALL SD % setT( T )"& - ) - - CALL SD % setdNTdXt( ) - CALL Check_Error( & - "STDiffusionMatrix_Class.f90>>DiffusionMatrix_31.part", & - "Traceback ---> CALL SD % setdNTdXT( )"& - ) - - SD2 => STElemSD2 % SD( IPS, IPT ) - T = SD2 % dTdTheta / SD2 % Jt - - CALL SD2 % setT( T ) - CALL Check_Error( & - "STStiffnessMatrix_Class.f90>>StiffnessMatrix_13.part", & - "Traceback ---> CALL SD2 % setT( T )"& - ) - - CALL SD2 % setdNTdXt( ) - CALL Check_Error( & - "STStiffnessMatrix_Class.f90>>StiffnessMatrix_13.part", & - "Traceback ---> CALL SD2 % setdNTdXT( )"& - ) - - END DO - - END DO - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - CALL STElemSD % SD( IPS, IPT ) % getdNTdXt( dNTdXt2 ) - CALL STElemSD2 % SD( IPS, IPT ) % getdNTdXt( dNTdXt3 ) - - RealVal = Ws * Wt * Js * Jt * thick * Beta - - DO aa = 1, NNT - - DO b = 1, NNT - - DO p = 1, NSD - - SELECT CASE( TRIM( IntegrationSide ) ) - - CASE( "Right", "RIGHT", "right" ) - Obj % Mat4( :, :, aa, b ) = & - Obj % Mat4( :, :, aa, b ) + & - OUTERPROD( a = dNTdXt3( :, p, aa ), & - b = dNTdXt2( :, p, b ) ) * RealVal - - CASE( "Left", "LEFT", "left" ) - Obj % Mat4( :, :, aa, b ) = & - Obj % Mat4( :, :, aa, b ) + & - OUTERPROD( a = dNTdXt2( :, p, aa ), & - b = dNTdXt3( :, p, b ) ) * RealVal - - CASE( "None", "NONE", "none" ) - Obj % Mat4( :, :, aa, b ) = & - Obj % Mat4( :, :, aa, b ) + & - OUTERPROD( a = dNTdXt3( :, p, aa ), & - b = dNTdXt( :, p, b ) ) * RealVal - - CASE DEFAULT - - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getStiffnessMatrix_31()", & - "No case found for given integration side" & - ) - Error_Flag = .TRUE. - RETURN - - END SELECT - - END DO - - END DO - - END DO - - END DO - - END DO - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( dNTdXt ) ) DEALLOCATE( dNTdXt ) - IF( ALLOCATED( dNTdXt2 ) ) DEALLOCATE( dNTdXt2 ) - IF( ALLOCATED( dNTdXt3 ) ) DEALLOCATE( dNTdXt3 ) - IF( ALLOCATED( T ) ) DEALLOCATE( T ) - CALL STElemSD % DeallocateData( ) - CALL STElemSD2 % DeallocateData( ) - SD => NULL( ) - SD2 => NULL( ) - - END SUBROUTINE getDiffusionMatrix_31 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part deleted file mode 100755 index aacf1b0ea..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part +++ /dev/null @@ -1,137 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_4.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_4 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_4( Obj, K ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, :, : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, & - NSD, j - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), DummyMat3( :,:,: ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - & "STDiffusionMatrix_Class.f90", & - & "getDiffusionMatrix_4(), Flag-1", & - & "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_4()", & - "The SIZE(K, 1) should be equal to SIZE(K, 2)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( K, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_4()", & - "The SIZE(K, 1) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( K, 3 ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_4()", & - "The SIZE(K, 3) should be equal to NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - ALLOCATE( DummyMat3( NNS, NSD, NNT ) ) - ALLOCATE( DummyVec1( NNT*NNS ), DummyVec2( NNT*NNS ) ) - - DO IPS = 1, NIPS - Mat2 = K( :, :, IPS ) - DO IPT = 1, NIPT - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - DO a = 1, NNT - DummyMat3( :, :, a ) = MATMUL( SD % dNTdXt( :, :, a ), Mat2 ) - END DO - DO j = 1, NSD - DummyVec1 = RESHAPE( SD % dNTdXt( :, j, : ), (/NNS*NNT/) ) - DummyVec2 = RealVal*RESHAPE( DummyMat3(:,j,:), (/NNS*NNT/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & - + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2) ) DEALLOCATE( DummyVec2) - IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) - -END SUBROUTINE getDiffusionMatrix_4 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part deleted file mode 100755 index cf3bd5a8a..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part +++ /dev/null @@ -1,128 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_5.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_5 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_5( Obj, K ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, : ) - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, & - NSD, j - REAL( DFP ), ALLOCATABLE :: DummyMat3( :,:,: ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_4(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_4()", & - "The SIZE(K, 1) should be equal to SIZE(K, 2)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( K, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_4()", & - "The SIZE(K, 1) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - ALLOCATE( DummyMat3( NNS, NSD, NNT ) ) - ALLOCATE( DummyVec1( NNT*NNS ), DummyVec2( NNT*NNS ) ) - - DO IPS = 1, NIPS - DO IPT = 1, NIPT - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - DO a = 1, NNT - DummyMat3( :, :, a ) = MATMUL( SD % dNTdXt( :, :, a ), K ) - END DO - - DO j = 1, NSD - DummyVec1 = RESHAPE( SD % dNTdXt( :, j, : ), (/NNS*NNT/) ) - DummyVec2 = RealVal*RESHAPE( DummyMat3( :, j, : ), (/NNS*NNT/) ) - - Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - - NULLIFY( SD ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2) ) DEALLOCATE( DummyVec2) - IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) - -END SUBROUTINE getDiffusionMatrix_5 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part deleted file mode 100755 index 785089aa3..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part +++ /dev/null @@ -1,50 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_6.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_6 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_6( Obj, K, nCopy ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns mass matrix; C is a 2D array of STNodal Values - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( K = K ) - CALL Obj % MakeDiagonalCopies( nCopy ) - -END SUBROUTINE getDiffusionMatrix_6 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part deleted file mode 100755 index 9893d4867..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part +++ /dev/null @@ -1,51 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_7.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_7 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_7( Obj, K, nCopy ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, :, : ) - !. . . . . . . . . . . . . . . . . . . . - - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( K = K ) - CALL Obj % MakeDiagonalCopies( nCopy ) - -END SUBROUTINE getDiffusionMatrix_7 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part deleted file mode 100755 index 92357d92a..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part +++ /dev/null @@ -1,50 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_8.part -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_8 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_8( Obj, K, nCopy ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. K( :, : ) - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K - INTEGER( I4B ), INTENT( IN ) :: nCopy - - CALL Obj % getDiffusionMatrix( K = K ) - CALL Obj % MakeDiagonalCopies( nCopy ) - -END SUBROUTINE getDiffusionMatrix_8 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part deleted file mode 100755 index ff390d6b8..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part +++ /dev/null @@ -1,194 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: DiffusionMatrix_9.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STDiffusionMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getDiffusionMatrix_9 -!------------------------------------------------------------------------------ - -SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. c1, c2 ( :, :, : ) - ! 2. c1Type, c2Type NodalValues, QuadPoints - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD - REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & - DummyVec1( : ), DummyVec2( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isC1Nodal, isC2Nodal - - isC1Nodal = .TRUE. - isC2Nodal = .TRUE. - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_9(), Flag-1", & - "STDiffusionMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - -#ifdef DEBUG_VER - IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_9()", & - "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 1 ) .NE. NSD ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_9()", & - "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_9()", & - "The SIZE(C1, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C1, 3 ) .NE. NIPT .AND. SIZE( C1, 3 ) .NE. NNT ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_9()", & - "The SIZE(C1, 3) should be equal to either NIPT, & - & or NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_9()", & - "The SIZE(C2, 2) should be equal to either NIPS, & - & or NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( C2, 3 ) .NE. NIPT .AND. SIZE( C2, 3 ) .NE. NNT ) THEN - CALL Err_Msg( & - "STDiffusionMatrix_Class.f90", & - "getDiffusionMatrix_9()", & - "The SIZE(C2, 3) should be equal to either NIPT, & - & or NNT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC1Nodal = .FALSE. - END SELECT - - SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) - CASE( "Quad", "QuadPoints", "Quad Points", & - "Integration", "Integration Points", & - "IntegrationPoints" ) - isC2Nodal = .FALSE. - END SELECT - - IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isC1Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & STNodalValues = C1 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & - & VectorValues = C1( :, IPS, IPT ) ) - END IF - - IF( isC2Nodal ) THEN - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & STNodalValues = C2 ) - ELSE - CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & - & VectorValues = C2( :, IPS, IPT ) ) - END IF - - DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) - DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) - - Obj % Mat2 = Obj % Mat2 & - & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) - END DO - END DO - - CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) - NULLIFY( SD ) - IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) - IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) - IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) - IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) - -END SUBROUTINE getDiffusionMatrix_9 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part deleted file mode 100644 index 9f920588f..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part +++ /dev/null @@ -1,31 +0,0 @@ -getDiffusionMatrix_1, & -getDiffusionMatrix_2 , & -getDiffusionMatrix_3 , & -getDiffusionMatrix_4 , & -getDiffusionMatrix_5 , & -getDiffusionMatrix_6 , & -getDiffusionMatrix_7 , & -getDiffusionMatrix_8 , & -getDiffusionMatrix_9 , & -getDiffusionMatrix_10 , & -getDiffusionMatrix_11 , & -getDiffusionMatrix_12 , & -getDiffusionMatrix_13 , & -getDiffusionMatrix_14 , & -getDiffusionMatrix_15 , & -getDiffusionMatrix_16 , & -getDiffusionMatrix_17 , & -getDiffusionMatrix_18 , & -getDiffusionMatrix_19 , & -getDiffusionMatrix_20 , & -getDiffusionMatrix_21 , & -getDiffusionMatrix_22 , & -getDiffusionMatrix_23 , & -getDiffusionMatrix_24 , & -getDiffusionMatrix_25 , & -getDiffusionMatrix_26 , & -getDiffusionMatrix_27 , & -getDiffusionMatrix_28 , & -getDiffusionMatrix_29 , & -getDiffusionMatrix_30 , & -getDiffusionMatrix_31 \ No newline at end of file diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 deleted file mode 100755 index 75fa6cf23..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 +++ /dev/null @@ -1,100 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: STDiffusionMatrix_Class.f90 -! Last Update : Nov-20-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Diffusion matrices for space-time elements -! -!============================================================================== - - MODULE STDiffusionMatrix_Class - USE GlobalData - USE IO - USE STElemShapeData_Class - USE STShapeData_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: STDiffusionMatrix_, STDiffusionMatrix, & - STDiffusionMatrix_Pointer - -!------------------------------------------------------------------------------ -! STElemShapeData_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( STElemShapeData_ ) :: STDiffusionMatrix_ - -!. . . . . . . . . . . . . . . . . . . . -! 1. Diffusion matrices for the space-time element. -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - - PROCEDURE, PUBLIC, PASS( Obj ) :: & -#include "./MethodNames.part" - - END TYPE STDiffusionMatrix_ - -!------------------------------------------------------------------------------ -! INTERFACES -!------------------------------------------------------------------------------ - - INTERFACE STDiffusionMatrix_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 - END INTERFACE - - INTERFACE STDiffusionMatrix - MODULE PROCEDURE Constructor1, Constructor2, Constructor3 - END INTERFACE - -!------------------------------------------------------------------------------ -! CONTAINS -!------------------------------------------------------------------------------ - - CONTAINS - -#include "./Constructor.part" -#include "./DiffusionMatrix_1.part" -#include "./DiffusionMatrix_2.part" -#include "./DiffusionMatrix_3.part" -#include "./DiffusionMatrix_4.part" -#include "./DiffusionMatrix_5.part" -#include "./DiffusionMatrix_6.part" -#include "./DiffusionMatrix_7.part" -#include "./DiffusionMatrix_8.part" -#include "./DiffusionMatrix_9.part" -#include "./DiffusionMatrix_10.part" -#include "./DiffusionMatrix_11.part" -#include "./DiffusionMatrix_12.part" -#include "./DiffusionMatrix_13.part" -#include "./DiffusionMatrix_14.part" -#include "./DiffusionMatrix_15.part" -#include "./DiffusionMatrix_16.part" -#include "./DiffusionMatrix_17.part" -#include "./DiffusionMatrix_18.part" -#include "./DiffusionMatrix_19.part" -#include "./DiffusionMatrix_20.part" -#include "./DiffusionMatrix_21.part" -#include "./DiffusionMatrix_22.part" -#include "./DiffusionMatrix_23.part" -#include "./DiffusionMatrix_24.part" -#include "./DiffusionMatrix_25.part" -#include "./DiffusionMatrix_26.part" -#include "./DiffusionMatrix_27.part" -#include "./DiffusionMatrix_28.part" -#include "./DiffusionMatrix_29.part" -#include "./DiffusionMatrix_30.part" -#include "./DiffusionMatrix_31.part" - - END MODULE STDiffusionMatrix_Class - diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md deleted file mode 100755 index 6fe667b09..000000000 --- a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md +++ /dev/null @@ -1,1971 +0,0 @@ -# Space Time Diffusion Matrix Class - -## ToDo - -## Structure - -## Description - -`STDiffusionMatrix_` object is child of `STElemShapeData_` class. It can be initiated using following commands. - -## Getting Started - -### Making The Object - -We can make the object using the `Initiate` method. - -```fortran -CALL Obj % Initiate( NIPS = NIPS, NIPT = NIPT) -CALL Obj % InitiateMatrix( row= row, col = col) -CALL Obj % InitiateMatrix( I1 = I1, I2 = I2, I3 = I3, I4= I4) -``` - -We can also use the `STDiffusionMatrix()` function - -```fortran -STElemSD = STDiffusionMatrix( ) -STElemSD = STDiffusionMatrix( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) -STElemSD = STDiffusionMatrix( I1, I2, I3, I4, I5, NIPS, NIPT) -``` - -We can also use the `STDiffusionMatrix_Pointer()` function - -```fortran -STElemSD => STDiffusionMatrix_Pointer( ) -STElemSD => STDiffusionMatrix_Pointer( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) -STElemSD => STDiffusionMatrix_Pointer( I1, I2, I3, I4, I5, NIPS, NIPT) -``` - -### Getting The Diffusion Matrix - -To compute the following matrix - -$$\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta u\,}}{{\partial {\bf{x}}}} \cdot \frac{{\partial u}}{{\partial {\bf{x}}}}d\Omega dt} } = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_i}}}\,\frac{{\partial {N^J}{T_b}}}{{\partial {x_i}}}d\Omega dt} } } \right]\,{}^b{u_J}$$ - -we can use the following command - -```fortran -CALL Obj % getDiffusionMatrix( ) -``` - -To compute the following matrix - -$$ -\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta {u_i}\,}}{{\partial {\bf{x}}}} \cdot \frac{{\partial {u_i}}}{{\partial {\bf{x}}}}d\Omega dt} } = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_p}}}\,\frac{{\partial {N^J}{T_b}}}{{\partial {x_p}}}d\Omega dt} } } \right]\,{}^b{u_{iJ}} -$$ - -we can call following fortran command. - - -```fortran -CALL Obj % getDiffusionMatrix( nCopy ) -``` - -To compute the following matrix - -$$ -\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta u\,}}{{\partial {x_i}}}{K_{ij}}\frac{{\partial u}}{{\partial {x_j}}}d\Omega dt} } = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_i}}}\,{K_{ij}}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right]\,{}^b{u_J} -$$ - -We can call following command. - -```fortran -CALL Obj % getDiffusionMatrix( K ) -``` - -To compute the following matrix - -$$ -\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta {u_i}\,}}{{\partial {x_p}}}{K_{pq}}\frac{{\partial {u_i}}}{{\partial {x_q}}}d\Omega dt} } = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_p}}}\,{K_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial {x_q}}}d\Omega dt} } } \right]\,{}^b{u_{iJ}} -$$ - -we can call following fortran command. - -```fortran -CALL Obj % getDiffusionMatrix( K, nCopy ) -``` - -In the above two calls `K` can be rank-4 `K(:,:,:,:)`, rank-3 `K(:,:,:)`, rank-2 `K(:,:)`. If `K` is varying in both space and time then it is given by space-time matrix. If `K` is changing only with the space then it is given by the Rank-3, and if `K` is constant in both space and time then it is given by the Rank-2 matrix. `K` is defined at the integration points. - -To compute the following matrix - -$$ -\[\int_{{I_n}}^{} {\int_\Omega ^{} {{{\bf{c}}_1} \cdot \frac{{\partial \delta u}}{{\partial {\bf{x}}}}{{\bf{c}}_2} \cdot \frac{{\partial u}}{{\partial {\bf{x}}}}d\Omega dt} } = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{\bf{c}}_1} \cdot \frac{{\partial {N^I}{T_a}}}{{\partial {\bf{x}}}}{{\bf{c}}_2} \cdot \frac{{\partial {N^J}{T_b}}}{{\partial {\bf{x}}}}d\Omega dt} } } \right]{}^b{u_J}\] -$$ - -```fortran -CALL Obj % getDiffusionMatrix( c1, c2, c1Type, c2Type ) -CALL Obj % getDiffusionMatrix( c1, c2, c1Type, c2Type, nCopy ) -``` - -In the above call `c1, c2` can be rank-3 `(:,:,:)`, rank-2 `(:,:)`, rank-1 `(:)`. `c1Type, c2Type` can be `NodalValues` or `QuadPoints`. `c1, c2` denotes the convective velocity. - -- If convective velocity is changing in space and time then it must be given by Rank-3 matrix. -- If convective velocity is changing in only space then it must be given by Rank-2 matrix. -- If convective velocity is constant in both space and time then it must be given by Rank-1 matrix. - - - -```fortran -CALL Obj % getDiffusionMatrix( K, Term1, Term2 ) -``` - -In the above call `K` can be rank-4 `K(:,:,:,:)`, rank-3 `K(:,:,:)`, rank-2 `K(:,:)`. `Term1` and `Term2` can be `dx, dy, dz`. - - - - - - - - - - - - - - - - - - - - - - - - - - - - -## Theory - -Consider the following _scalar_ term present in the pde - -$${\nabla}^2 u + \cdots $$ - -then we may need to compute the following matrices. - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -Note here, $u \in R$. - -> These tasks are performed by following methods; `getDiffusionMatrix_1()`, `getDiffusionMatrix_2()` - -Now consider the following terms in a pde. - -$${\nabla} \cdot \Big( -{}^{2}\mathbf{K}{\nabla}u \Big) + \cdots $$ -or -$$\frac{\partial}{\partial x_i} \cdot \Big( -{}^{2}K_{ij} \frac{\partial u}{\partial x_j} \Big) + \cdots $$ - -> These tasks are performed by following methods; `getDiffusionMatrix_3()`, `getDiffusionMatrix_4()`, `getDiffusionMatrix_5()`, `getDiffusionMatrix_6()`, `getDiffusionMatrix_7()`, and `getDiffusionMatrix_8()` - - - -## Methods - -### getDiffusionMatrix_1() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_1( Obj ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. This is the simplest form possible. No arguments are required. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -CALL STElemSD % getDiffusionMatrix( ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_1( )" -CALL STElemSD % DisplayMatrix4 -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_1( ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` -> Note that in this case integrad is quadratic in time, therefore we need atleast 2 integration points in the time. This condition may change when the mesh is moving. Note that the row sum and column sum is zero as expected. - -### getDiffusionMatrix_2() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_2( Obj, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. This is the simplest form possible. No arguments are required. -- `nCopy` is an integer, which decides how many copies need to be placed on the diagonal. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -CALL STElemSD % getDiffusionMatrix( nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_2( nCopy = 2 )" -CALL STElemSD % DisplayMatrix4 -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_2( nCopy = 2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111 -0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111 -0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getDiffusionMatrix_3() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_3( Obj, K ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `K(:,:,:,:)` is a four dimensional array. The shape of `K` should be `(NSD, NSD, NIPS, NIPT)`. The third index denotes the spatial-integration points. The fourth index denotes the temporal integration points. In this case, `K` matrix varies in both space and time. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( K = DummyMat4 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) -ALLOCATE( DummyMat4( NSD, NSD, NIPS, NIPT ) ) -DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP -DummyMat4( 2, 2, :, : ) = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( K = DummyMat4 ) -cALL Check_Error( " " , " " ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_3( K = DummyMat4 )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_3( K = DummyMat4 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getDiffusionMatrix_4() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_4( Obj, K ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `K(:,:,:)` is a three dimensional array. The shape of `K` should be `(NSD, NSD, NIPS)`. The third index denotes the spatial-integration points. In this case, `K` matrix varies in only in space and remains constant in time. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( K = DummyMat3 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NSD, NIPS ) ) -DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP -DummyMat3( 2, 2, : ) = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( K = DummyMat3 ) -cALL Check_Error( " " , " " ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_4( K = DummyMat3 )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_4( K = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getDiffusionMatrix_5() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_5( Obj, K ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `K(:,:)` is a two dimensional array. The shape of `K` should be `(NSD, NSD)`. In this case, `K` matrix remains constant in both space and time. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( K = DummyMat2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NSD ) ) -DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP -DummyMat2( 2, 2 ) = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( K = DummyMat2 ) -cALL Check_Error( " " , " " ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.2222222 -0.1111111 0.4444444 -0.1111111 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getDiffusionMatrix_6() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_6( Obj, K, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `K(:,:,:,:)` is a four dimensional array. The shape of `K` should be `(NSD, NSD, NIPS, NIPT)`. The third index denotes the spatial-integration points. The fourth index denotes the temporal integration points. In this case, `K` matrix varies in both space and time. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( K = DummyMat4, nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) -ALLOCATE( DummyMat4( NSD, NSD, NIPS, NIPT ) ) -DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP -DummyMat4( 2, 2, :, : ) = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( K = DummyMat4, nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_6( K = DummyMat4 )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_6( K = DummyMat4 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getDiffusionMatrix_7() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_7( Obj, K, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `K(:,:,:)` is a three dimensional array. The shape of `K` should be `(NSD, NSD, NIPS)`. The third index denotes the spatial-integration points. In this case, `K` matrix varies in only in space and remains constant in time. -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( K = DummyMat3, nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NSD, NIPS ) ) -DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP -DummyMat3( 2, 2, : ) = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( K = DummyMat3, nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_7( K = DummyMat3 )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_7( K = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getDiffusionMatrix_8() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_8( Obj, K, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `K(:,:)` is a two dimensional array. The shape of `K` should be `(NSD, NSD)`. In this case, `K` matrix remains constant in both space and time. - -```fortran -CALL STElemSD % getDiffusionMatrix( K = DummyMat2, nCopy = 2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NSD ) ) -DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP -DummyMat2( 2, 2 ) = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( K = DummyMat2, nCopy = 2 ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 - 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 - -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 - -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 - 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 - 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 - 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getDiffusionMatrix_9() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c1(:,:,:)` and `c2(:,:,:)` are three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` or `C2Type` are in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` and/or `c2` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `C1Type` or `C2Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` and/or `c2` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Nodal' ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_9( c1 = & -DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_9( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_10() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c1(:,:)` and `c2(:,:)` are two dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` or `C2Type` are in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` and/or `c2` denotes the spatial nodal values. In this case, their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. -- `C1Type` or `C2Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` and/or `c2` denotes the values at spatial integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_10( c1 = & -DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_10( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_11() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c1(:)` and `c2(:)` are vectors. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` or `C2Type` are string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_11( c1 = & -DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_11( c1 = DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_12() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c1(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `C1Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `c2(:,:)` are two dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c2` denotes the spatial nodal values. In this case, their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. -- `C2Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at spatial integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. - - - - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_12( c1 = & -DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_12( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_13() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c2(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `C2Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `c1(:,:)` are two dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the spatial nodal values. In this case, their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. -- `C1Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at spatial integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. - - - - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_12( c1 = & -DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_13( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_14() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c1(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `C1Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `c2(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C2Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. - - - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_14( c1 = & -DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_14( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_15() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c2(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c2` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `C2Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `c1(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. - - - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_15( c1 = & -DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_15( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_16() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c1(:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space nodal values. In this case their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. -- `C1Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at space integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. -- `c2(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C2Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. - - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) -DummyMat2 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_16( c1 = & -DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_16( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_17() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type -``` - -DESCRIPTION - -- This methods computes the diffusion matrix for a scalar variable. -- `c2(:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c2` denotes the space nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. -- `C2Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at space integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. -- `c1(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. -- `C1Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. - - - -CODE SNIPPET - -```fortran -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Nodal' ) -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Quad' ) -``` - -SYMBOLIC CALCULATION - -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) -DummyMat2 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2,& -C1Type = 'Quad', C2Type = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_17( c1 = & -DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' )" -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getDiffusionMatrix_17( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -Mat4( :, :, 1, 2 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 1 ) - - 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 - -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 - -Mat4( :, :, 2, 2 ) - - 0.7777778 -0.1111111 -0.5555556 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 - -0.5555556 -0.1111111 0.7777778 -0.1111111 - -0.1111111 0.1111111 -0.1111111 0.1111111 -``` - -### getDiffusionMatrix_18() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_18( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_19() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_19( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_20() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_20( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_21() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_21( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_22() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_22( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_23() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_23( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_24() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_24( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_25() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_25( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_26() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_26( Obj, c1, c2, c1Type, c2Type, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 - CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type - INTEGER( I4B ), INTENT( IN ) :: nCopy -``` - -### getDiffusionMatrix_27() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_27( Obj, K, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -### getDiffusionMatrix_28() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_28( Obj, K, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - -### getDiffusionMatrix_29() - -INTERFACE - -```fortran - SUBROUTINE getDiffusionMatrix_29( Obj, K, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K - CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 -``` - - diff --git a/src/submodules/STDiffusionMatrix/src/STDM_1.inc b/src/submodules/STDiffusionMatrix/src/STDM_1.inc deleted file mode 100644 index 62ab2a90f..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_1.inc +++ /dev/null @@ -1,64 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -PURE SUBROUTINE STDM_1(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! a scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) & - & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& - & trial(ipt)%dNTdXt(:, :, ii, ips)) - !! - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, kbar) -END SUBROUTINE STDM_1 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_11.inc b/src/submodules/STDiffusionMatrix/src/STDM_11.inc deleted file mode 100644 index 45d6b94cf..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_11.inc +++ /dev/null @@ -1,147 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: kbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, kbar) - !! -END SUBROUTINE STDM_11a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! 2 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: kbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, kbar) - !! -END SUBROUTINE STDM_11b diff --git a/src/submodules/STDiffusionMatrix/src/STDM_12.inc b/src/submodules/STDiffusionMatrix/src/STDM_12.inc deleted file mode 100644 index 8c8e1ee34..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_12.inc +++ /dev/null @@ -1,181 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - INTEGER(I4B) :: ips, ipt, ii, nsd - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), & - & 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 3) - m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - END DO - !! - CALL Convert( from=m6, to=ans) - !! - DEALLOCATE (realval, IJab, vbar, m6) - !! -END SUBROUTINE STDM_12a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! opt=2 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - INTEGER(I4B) :: ips, ipt, ii, nsd - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, & - & SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 4) - m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m6, to=ans) - !! - 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 deleted file mode 100644 index 07e8c1420..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_13.inc +++ /dev/null @@ -1,155 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, c1bar, c2bar) - !! -END SUBROUTINE STDM_13a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! 2 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:,ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, c1bar, c2bar) - !! -END SUBROUTINE STDM_13b diff --git a/src/submodules/STDiffusionMatrix/src/STDM_14.inc b/src/submodules/STDiffusionMatrix/src/STDM_14.inc deleted file mode 100644 index b4415905a..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_14.inc +++ /dev/null @@ -1,188 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), & - & 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 3) - m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - END DO - !! - CALL Convert( from=m6, to=ans) - !! - DEALLOCATE (realval, IJab, vbar, m6, cbar) - !! -END SUBROUTINE STDM_14a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector variable - INTEGER(I4B), INTENT(IN) :: opt - !! opt=2 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, & - & SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * cbar(:,ipt) - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 4) - m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m6, to=ans) - !! - DEALLOCATE (realval, IJab, vbar, m6) - !! -END SUBROUTINE STDM_14b diff --git a/src/submodules/STDiffusionMatrix/src/STDM_2.inc b/src/submodules/STDiffusionMatrix/src/STDM_2.inc deleted file mode 100644 index 6131ed31d..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_2.inc +++ /dev/null @@ -1,60 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -PURE SUBROUTINE STDM_2(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Vector variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=k) - !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k) - !! - DO ips = 1, SIZE(realval) - !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) - !! - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, p1, p2) -END SUBROUTINE STDM_2 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_3.inc b/src/submodules/STDiffusionMatrix/src/STDM_3.inc deleted file mode 100644 index e753853ac..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_3.inc +++ /dev/null @@ -1,66 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -PURE SUBROUTINE STDM_3(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd - !! - !! main - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) - !! - END DO - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, KBar, IaJb) -END SUBROUTINE STDM_3 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_4.inc b/src/submodules/STDiffusionMatrix/src/STDM_4.inc deleted file mode 100644 index c45591f3a..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_4.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! vector -!! vector -!! -PURE SUBROUTINE STDM_4(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Vector variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) - !! - DO ips = 1, SIZE(realval) - !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) - !! - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, p1, p2) -END SUBROUTINE STDM_4 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_5.inc b/src/submodules/STDiffusionMatrix/src/STDM_5.inc deleted file mode 100644 index 392dec893..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_5.inc +++ /dev/null @@ -1,79 +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 -! - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- -! -! scalar -! matrix -! -PURE SUBROUTINE STDM_5(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! sclar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd - !! - !! 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=rhobar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) - !! - END DO - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, rhobar, kbar) -END SUBROUTINE STDM_5 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_6.inc b/src/submodules/STDiffusionMatrix/src/STDM_6.inc deleted file mode 100644 index abb4efdb8..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_6.inc +++ /dev/null @@ -1,71 +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 -! -! scalar -! scalar -! -PURE SUBROUTINE STDM_6(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! a scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! a scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & - & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) & - & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& - & trial(ipt)%dNTdXt(:, :, ii, ips)) - !! - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, c1bar, c2bar) -END SUBROUTINE STDM_6 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_7.inc b/src/submodules/STDiffusionMatrix/src/STDM_7.inc deleted file mode 100644 index 60a248dc0..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_7.inc +++ /dev/null @@ -1,64 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -! -! Scalar -! Vector -! -PURE SUBROUTINE STDM_7(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:,:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! 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) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) - !! - DO ips = 1, SIZE(realval) - !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) - !! - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, c1bar, iajb, p1, p2) -END SUBROUTINE STDM_7 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_8.inc b/src/submodules/STDiffusionMatrix/src/STDM_8.inc deleted file mode 100644 index 3e4c46518..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDM_8.inc +++ /dev/null @@ -1,73 +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 -! -! matrix -! matrix -! -PURE SUBROUTINE STDM_8(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Matrix variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd - !! - !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt)) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) * m2(ii, jj) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) - !! - END DO - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, m2, iajb, k1bar, k2bar) -END SUBROUTINE STDM_8 diff --git a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 deleted file mode 100644 index 03386ddca..000000000 --- a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 +++ /dev/null @@ -1,1180 +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(STDiffusionMatrix_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: kbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, kbar) - !! -END SUBROUTINE STDM_11a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! 2 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: kbar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, kbar) - !! -END SUBROUTINE STDM_11b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - INTEGER(I4B) :: ips, ipt, ii, nsd, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), & - & 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 3) - m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - END DO - !! - CALL Convert( from=m6, to=ans) - !! - DEALLOCATE (realval, IJab, vbar, m6) - !! -END SUBROUTINE STDM_12a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: k - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! opt=2 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - INTEGER(I4B) :: ips, ipt, ii, nsd, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, & - & SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 4) - m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m6, to=ans) - !! - DEALLOCATE (realval, IJab, vbar, m6) - !! -END SUBROUTINE STDM_12b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, jj, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, c1bar, c2bar) - !! -END SUBROUTINE STDM_13a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar variable - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Scalar variable - INTEGER(I4B), INTENT(IN) :: opt - !! 2 - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b - !! - !! main - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:,ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - DO jj = 1, nsd - DO ii = 1, nsd - !! - m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & - & + realval(ips) * & - & OUTERPROD( & - & test(ipt)%dNTdXt(:, a, jj, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (realval, m6, c1bar, c2bar) - !! -END SUBROUTINE STDM_13b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector - INTEGER(I4B), INTENT(IN) :: opt - !! opt=1 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), & - & 1, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 3) - m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - END DO - !! - CALL Convert( from=m6, to=ans) - !! - DEALLOCATE (realval, IJab, vbar, m6, cbar) - !! -END SUBROUTINE STDM_14a - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - !! test function - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - !! trial function - CLASS(FEVariable_), INTENT(IN) :: c1 - !! Scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! Vector variable - INTEGER(I4B), INTENT(IN) :: opt - !! opt=2 - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) - !! - CALL Reallocate( & - & IJab, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - CALL Reallocate( & - & m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & 1, & - & SIZE(vbar, 1), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * cbar(:,ipt) - !! - DO ips = 1, SIZE(realval) - !! - IJab = 0.0_DFP - !! - DO ii = 1, nsd - DO b = 1, SIZE(IJab, 4) - DO a = 1, SIZE(IJab, 3) - !! - IJab(:,:,a,b) = IJab(:,:,a,b) & - & + OUTERPROD( & - & test(ipt)%dNTdXt(:, a, ii, ips), & - & trial(ipt)%dNTdXt(:, b, ii, ips)) - !! - END DO - END DO - END DO - !! - DO ii = 1, SIZE(m6, 4) - m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & - & * IJab - END DO - !! - END DO - !! - END DO - !! - CALL Convert( from=m6, to=ans) - !! - DEALLOCATE (realval, IJab, vbar, m6) - !! -END SUBROUTINE STDM_14b - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MakeDiagonalCopiesIJab(ans, ncopy) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: ncopy - !! - REAL(DFP), ALLOCATABLE :: m2(:, :), m4(:, :, :, :) - INTEGER(I4B) :: a, b - !! - m4 = ans - !! - CALL Reallocate(ans, & - & ncopy * SIZE(m4, 1), & - & ncopy * SIZE(m4, 2), & - & SIZE(m4, 3), & - & SIZE(m4, 4)) - !! - DO b = 1, SIZE(m4, 4) - DO a = 1, SIZE(m4, 3) - CALL MakeDiagonalCopies(from=m4(:, :, a, b), to=m2, ncopy=ncopy) - ans(:, :, a, b) = m2 - END DO - END DO - !! - DEALLOCATE (m2, m4) -END SUBROUTINE MakeDiagonalCopiesIJab - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_1 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) -INTEGER(I4B) :: ips, ipt, ii, nsd -!! -!! main -!! -CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) -nsd = trial(1)%refelem%nsd -!! -DO ipt = 1, SIZE(trial) - realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & - & * trial(ipt)%Wt * trial(ipt)%Jt - DO ips = 1, SIZE(trial(1)%N, 2) - DO ii = 1, nsd - iajb = iajb + realval(ips) & - & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& - & trial(ipt)%dNTdXt(:, :, ii, ips)) - END DO - END DO -END DO -!! -CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) -!! -if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) -!! -DEALLOCATE (realval, iajb) -END PROCEDURE mat4_STDiffusionMatrix_1 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_2 - ! CALL STDM_1(ans=ans, test=test, trial=trial, k=k, opt=opt) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) & - & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& - & trial(ipt)%dNTdXt(:, :, ii, ips)) - !! - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, kbar) -END PROCEDURE mat4_STDiffusionMatrix_2 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_3 - ! CALL STDM_2(ans=ans, test=test, trial=trial, k=k, opt=opt) - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - !! - DO ipt = 1, SIZE(trial) - !! - 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=trial(ipt), cdNTdXt=p2, val=k) - !! - DO ips = 1, SIZE(realval) - !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) - !! - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, p1, p2) -END PROCEDURE mat4_STDiffusionMatrix_3 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_4 - ! CALL STDM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd - !! - !! 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=kbar, val=k) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) - !! - END DO - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, KBar, IaJb) -END PROCEDURE mat4_STDiffusionMatrix_4 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_5 - !! - !! scalar - !! scalar - !! - ! CALL STDM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & - & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) & - & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& - & trial(ipt)%dNTdXt(:, :, ii, ips)) - !! - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, c1bar, c2bar) -END PROCEDURE mat4_STDiffusionMatrix_5 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_6 - !! - !! scalar - !! vector - !! - ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:,:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! 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) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) - !! - DO ips = 1, SIZE(realval) - !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) - !! - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, c1bar, iajb, p1, p2) - !! -END PROCEDURE mat4_STDiffusionMatrix_6 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_7 - !! - !! scalar - !! matrix - !! - ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd - !! - !! 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=rhobar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) - !! - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) - !! - END DO - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, rhobar, kbar) -END PROCEDURE mat4_STDiffusionMatrix_7 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_8 - !! - !! vector - !! scalar - !! - ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) - !! - ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & - & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableVector, opt=opt ) -END PROCEDURE mat4_STDiffusionMatrix_8 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_9 - !! - !! vector - !! vector - !! - ! CALL STDM_4(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) - !! - DO ips = 1, SIZE(realval) - !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) - !! - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, iajb, p1, p2) -END PROCEDURE mat4_STDiffusionMatrix_9 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_10 - !! - !! vector - !! matrix - !! - !! CALL STDM_10(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! -END PROCEDURE mat4_STDiffusionMatrix_10 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_11 - !! - !! matrix - !! scalar - !! - ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) - !! - ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & - & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableMatrix, opt=opt) - !! -END PROCEDURE mat4_STDiffusionMatrix_11 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_12 - !! - !! matrix - !! vector - !! - !!CALL STDM_9(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! -END PROCEDURE mat4_STDiffusionMatrix_12 - -!---------------------------------------------------------------------------- -! DiffusionMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_13 - !! - !! matrix - !! matrix - !! - ! CALL STDM_8(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd - !! - !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) - nsd = trial(1)%refelem%nsd - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt)) - !! - DO jj = 1, nsd - !! - DO ii = 1, nsd - !! - iajb = iajb + realval(ips) * m2(ii, jj) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) - !! - END DO - END DO - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (realval, m2, iajb, k1bar, k2bar) - !! -END PROCEDURE mat4_STDiffusionMatrix_13 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_14 -IF (opt(1) .EQ. 1) THEN - CALL STDM_11a(ans=ans, test=test, trial=trial, k=k, opt=1) -ELSE - CALL STDM_11b(ans=ans, test=test, trial=trial, k=k, opt=2) -END IF -END PROCEDURE mat4_STDiffusionMatrix_14 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_15 -IF (opt(1) .EQ. 1) THEN - CALL STDM_12a(ans=ans, test=test, trial=trial, k=k, opt=1) -ELSE - CALL STDM_12b(ans=ans, test=test, trial=trial, k=k, opt=2) -END IF -END PROCEDURE mat4_STDiffusionMatrix_15 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_16 -IF (opt(1) .EQ. 1) THEN - CALL STDM_13a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=1) -ELSE - CALL STDM_13b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=2) -END IF -END PROCEDURE mat4_STDiffusionMatrix_16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STDiffusionMatrix_17 -IF (opt(1) .EQ. 1) THEN - CALL STDM_14a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=1) -ELSE - CALL STDM_14b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=2) -END IF -END PROCEDURE mat4_STDiffusionMatrix_17 - -END SUBMODULE Methods diff --git a/src/submodules/STFextVector/Constructor.part b/src/submodules/STFextVector/Constructor.part deleted file mode 100755 index 10c3d85be..000000000 --- a/src/submodules/STFextVector/Constructor.part +++ /dev/null @@ -1,152 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Nov-24-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Row, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFextVector_ pointer -! Allocates the Obj % Vec1( row ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STFextVector_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT - - ALLOCATE( Constructor_1 ) - ALLOCATE( Constructor_1 % Vec1( row ) ) - Constructor_1 % Vec1 = 0.0_DFP - CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( I1, I2, I3, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFextVector_ pointer -! Allocates the Obj % Vec3( I1, I2, I3 ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STFextVector_ ), POINTER :: Constructor_2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT - - ALLOCATE( Constructor_2 ) - ALLOCATE( Constructor_2 % Vec3( I1, I2, I3 ) ) - Constructor_2 % Vec3 = 0.0_DFP - CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFextVector_ pointer -! Empty constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STFextVector_ ), POINTER :: Constructor_3 - - ALLOCATE( Constructor_3 ) - - END FUNCTION Constructor_3 - - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Row, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFextVector_ object -! Allocates the Obj % Vec1( row ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STFextVector_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT - - ALLOCATE( Constructor1 % Vec1( row ) ) - Constructor1 % Vec1 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( I1, I2, I3, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFextVector_ object -! Allocates the Obj % Vec3( I1, I2, I3 ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STFextVector_ ) :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT - - ALLOCATE( Constructor2 % Vec3( I1, I2, I3 ) ) - Constructor2 % Vec3 = 0.0_DFP - CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFextVector_ object -! Empty constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STFextVector_ ) :: Constructor3 - - END FUNCTION Constructor3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_1.part b/src/submodules/STFextVector/FextVector_1.part deleted file mode 100755 index f1abbb7c2..000000000 --- a/src/submodules/STFextVector/FextVector_1.part +++ /dev/null @@ -1,111 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_1.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_1 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_1( Obj, Fext ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes the space-time nodal values - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY:OUTERPROD - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, I, M - REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat(:,:) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - & "STFextVector_Class.f90", & - & "getFextVector_1(Obj, Fext)", & - & "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .OR. SIZE( Fext, 3 ) .NE. NNT ) THEN - CALL Err_Msg( & - & "STFextVector_Class.f90", & - & "getFextVector_1(Obj, Fext)", & - & "The SIZE( Fext, 2 ) should be equal to NNS, & - & The SIZE( Fext, 3 ) should be equal to NNT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - DummyMat = OUTERPROD( Fbar, SD % N ) - - DO a = 1, NNT - Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & - & DummyMat * RealVal * SD % T( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, DummyMat ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_10.part b/src/submodules/STFextVector/FextVector_10.part deleted file mode 100755 index 652853944..000000000 --- a/src/submodules/STFextVector/FextVector_10.part +++ /dev/null @@ -1,141 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_10.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_10 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_10( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes space-time nodal value, C denotes constant value - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isFNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_10(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - & "getFextVector_10(), Flag-2", & - & "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - & "getFextVector_10(), Flag-3", & - & "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - & "getFextVector_10(), Flag-4", & - & "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C, cdNTdXt = cdNTdXt ) - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS, IPT ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_10 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_11.part b/src/submodules/STFextVector/FextVector_11.part deleted file mode 100755 index c6e7561bd..000000000 --- a/src/submodules/STFextVector/FextVector_11.part +++ /dev/null @@ -1,161 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_11.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_11 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_11( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Spacetime nodal values C; Fext Space nodal values - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isCNodal, isFNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_11(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_11(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_11(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_11(), Flag-4", & - "The SIZE( C, 3 ) should be equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_11(), Flag-5", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - isCNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isCNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isCNodal ) THEN - CALL SD % getProjectionOfdNTdXt( & - & STNodalValues = C, cdNTdXt = cdNTdXt ) - ELSE - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C(:,IPS,IPT), cdNTdXt = cdNTdXt ) - END IF - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_11 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_12.part b/src/submodules/STFextVector/FextVector_12.part deleted file mode 100755 index 49f81b10d..000000000 --- a/src/submodules/STFextVector/FextVector_12.part +++ /dev/null @@ -1,138 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_12.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_12 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_12( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. C :: SpaceTime Nodal values; Fext:: Constant in space and time - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isCNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_12(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_12(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_12(), Flag-4", & - "The SIZE( C, 3 ) should be equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_12(), Flag-5", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isCNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isCNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isCNodal ) THEN - CALL SD % getProjectionOfdNTdXt( & - & STNodalValues = C, cdNTdXt = cdNTdXt ) - ELSE - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C(:,IPS,IPT), cdNTdXt = cdNTdXt ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fext( a ) - END DO - END DO - END DO - - DEALLOCATE( cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_12 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_13.part b/src/submodules/STFextVector/FextVector_13.part deleted file mode 100755 index 7c69d4072..000000000 --- a/src/submodules/STFextVector/FextVector_13.part +++ /dev/null @@ -1,133 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_13.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_13 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_13( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext :: SpaceNodal Values; C :: Constant values - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isFNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_13(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_13(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_13(), Flag-3", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C, cdNTdXt = cdNTdXt ) - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_13 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_14.part b/src/submodules/STFextVector/FextVector_14.part deleted file mode 100755 index b37dfc730..000000000 --- a/src/submodules/STFextVector/FextVector_14.part +++ /dev/null @@ -1,131 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_12.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_14 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_14( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext :: Constant in space and time, C :: space nodal values - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isCNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_14(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_14(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_14(), Flag-4", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isCNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isCNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isCNodal ) THEN - CALL SD % getProjectionOfdNTdXt( & - & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) - ELSE - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C(:,IPS), cdNTdXt = cdNTdXt ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fext( a ) - END DO - END DO - END DO - - DEALLOCATE( cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_14 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/STFextVector/FextVector_15.part b/src/submodules/STFextVector/FextVector_15.part deleted file mode 100755 index 8dd91f205..000000000 --- a/src/submodules/STFextVector/FextVector_15.part +++ /dev/null @@ -1,136 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_15.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_15 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_15( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext and C are space-time nodal values - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_15(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_15(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Fext, 3 ) .NE. NNT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_15(), Flag-3", & - "The SIZE( Fext, 3 ) should be equal to NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_15(), Flag-4", & - "The SIZE( C, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 3 ) .NE. NNT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_15(), Flag-5", & - "The SIZE( C, 3 ) should be equal to NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_15(), Flag-6", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & STNodalValues = C, cdNTdXt = cdNTdXt ) - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_15 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_16.part b/src/submodules/STFextVector/FextVector_16.part deleted file mode 100755 index de6cd022a..000000000 --- a/src/submodules/STFextVector/FextVector_16.part +++ /dev/null @@ -1,122 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_16.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_16 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_16( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext and C denotes the space nodal values - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_16(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_16(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_16(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_16(), Flag-4", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_16 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_17.part b/src/submodules/STFextVector/FextVector_17.part deleted file mode 100755 index a0684e21a..000000000 --- a/src/submodules/STFextVector/FextVector_17.part +++ /dev/null @@ -1,104 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_17.part -! Last Update : Nov-24-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_17 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_17( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Both Fext and C are constant in space and time - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_17(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_17(), Flag-2", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C, cdNTdXt = cdNTdXt ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fext( a ) - END DO - - END DO - END DO - - DEALLOCATE( cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_17 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_18.part b/src/submodules/STFextVector/FextVector_18.part deleted file mode 100755 index 7aa6d7e95..000000000 --- a/src/submodules/STFextVector/FextVector_18.part +++ /dev/null @@ -1,131 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_18.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_18 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_18( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes the space time nodal values; C denotes the space nodal - ! values. - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_18(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_18(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Fext, 3 ) .NE. NNT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_18(), Flag-3", & - "The SIZE( Fext, 3 ) should be equal to NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_18(), Flag-4", & - "The SIZE( C, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_18(), Flag-5", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_18 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/STFextVector/FextVector_19.part b/src/submodules/STFextVector/FextVector_19.part deleted file mode 100755 index f3e41d84f..000000000 --- a/src/submodules/STFextVector/FextVector_19.part +++ /dev/null @@ -1,124 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_19.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_19 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_19( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes space time nodal values; C is constant in space and - ! time domain - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_19(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_19(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Fext, 3 ) .NE. NNT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_19(), Flag-3", & - "The SIZE( Fext, 3 ) should be equal to NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_19(), Flag-4", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C, cdNTdXt = cdNTdXt ) - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_19 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_2.part b/src/submodules/STFextVector/FextVector_2.part deleted file mode 100755 index be55cfb7d..000000000 --- a/src/submodules/STFextVector/FextVector_2.part +++ /dev/null @@ -1,112 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_2.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_2 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_2( Obj, Fext ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Space Nodal Values of Fext - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, I, M - REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat(:,:) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - & "STFextVector_Class.f90", & - & "getFextVector_1(Obj, Fext)", & - & "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS ) THEN - CALL Err_Msg( & - & "STFextVector_Class.f90", & - & "getFextVector_1(Obj, Fext)", & - & "The SIZE( Fext, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNT = Obj % SD( 1,1 ) % getNNT( ) - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - DummyMat = OUTERPROD( Fbar, SD % N ) - - DO a = 1, NNT - Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & - & DummyMat * RealVal * SD % T( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, DummyMat ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_20.part b/src/submodules/STFextVector/FextVector_20.part deleted file mode 100755 index 715e9c276..000000000 --- a/src/submodules/STFextVector/FextVector_20.part +++ /dev/null @@ -1,131 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_20.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_20 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_20( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes Space nodal values, C denotes space time nodal values - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_20(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_20(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_20(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 3 ) .NE. NNT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_20(), Flag-4", & - "The SIZE( C, 3 ) should be equal to NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_20(), Flag-5", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & STNodalValues = C, cdNTdXt = cdNTdXt ) - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_20 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_21.part b/src/submodules/STFextVector/FextVector_21.part deleted file mode 100755 index cdc1956ae..000000000 --- a/src/submodules/STFextVector/FextVector_21.part +++ /dev/null @@ -1,121 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_21.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_21 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_21( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext is constant in space and time; C is space-time nodal values - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_21(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - ! Flag-3 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_21(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 3 ) .NE. NNT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_21(), Flag-4", & - "The SIZE( C, 3 ) should be equal to NNT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_21(), Flag-5", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & STNodalValues = C, cdNTdXt = cdNTdXt ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fext( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_21 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_22.part b/src/submodules/STFextVector/FextVector_22.part deleted file mode 100755 index f524de13b..000000000 --- a/src/submodules/STFextVector/FextVector_22.part +++ /dev/null @@ -1,116 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_22.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_22 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_22( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext :: denotes the space nodal values; C is constant in space and time - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_22(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_22(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_22(), Flag-3", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C, cdNTdXt = cdNTdXt ) - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_22 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_23.part b/src/submodules/STFextVector/FextVector_23.part deleted file mode 100755 index 1ff56d55a..000000000 --- a/src/submodules/STFextVector/FextVector_23.part +++ /dev/null @@ -1,113 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_23.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_23 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_23( Obj, Fext, C ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext constant in space and time and C is space nodal values - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_23(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( C, 2 ) .NE. NNS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_23(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_23(), Flag-4", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - CALL SD % getProjectionOfdNTdXt( & - & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fext( a ) - END DO - - END DO - END DO - - DEALLOCATE( cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_23 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_24.part b/src/submodules/STFextVector/FextVector_24.part deleted file mode 100755 index 29137c63f..000000000 --- a/src/submodules/STFextVector/FextVector_24.part +++ /dev/null @@ -1,149 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_24.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_24 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_24( Obj, Fext, FextType, Term1 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes the space time nodal values - ! 2. FextType can be Nodal or Quad, and Term1 can be dx, dy, dz, dt - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, Indx, M - REAL( DFP ), ALLOCATABLE :: Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isFNodal - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - ! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_24(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_24(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_24(), Flag-3", & - "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) - Indx = 1_I4B - - CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) - Indx = 2_I4B - - CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) - Indx = 3_I4B - - CASE DEFAULT - Indx = 0_I4B - - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt & - & * SD % Thickness - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS, IPT ) - END IF - - IF( Indx .EQ. 0 ) THEN - DO a = 1, M - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * Fbar( a ) * SD % dNTdt - END DO - ELSE - DO a = 1, M - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * Fbar( a ) * SD % dNTdXt( :, Indx, : ) - END DO - END IF - - END DO - END DO - - DEALLOCATE( Fbar ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_24 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_25.part b/src/submodules/STFextVector/FextVector_25.part deleted file mode 100755 index 00fb4f85e..000000000 --- a/src/submodules/STFextVector/FextVector_25.part +++ /dev/null @@ -1,142 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_25.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_25 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_25( Obj, Fext, FextType, Term1 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext Space nodal values - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, Indx, M - REAL( DFP ), ALLOCATABLE :: Fbar( : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - LOGICAL( LGT ) :: isFNodal - - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_25(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_25(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) - Indx = 1_I4B - - CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) - Indx = 2_I4B - - CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) - Indx = 3_I4B - - CASE DEFAULT - Indx = 0_I4B - - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt & - & * SD % Thickness - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS ) - END IF - - IF( Indx .EQ. 0 ) THEN - DO a = 1, M - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * Fbar( a ) * SD % dNTdt - END DO - ELSE - DO a = 1, M - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * Fbar( a ) * SD % dNTdXt( :, Indx, : ) - END DO - END IF - - END DO - END DO - - DEALLOCATE( Fbar ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_25 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/STFextVector/FextVector_26.part b/src/submodules/STFextVector/FextVector_26.part deleted file mode 100755 index 1aa8206c4..000000000 --- a/src/submodules/STFextVector/FextVector_26.part +++ /dev/null @@ -1,113 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_26.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_26 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_26( Obj, Fext, FextType, Term1 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns element Fext; - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, Indx, M - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_26(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) - Indx = 1_I4B - - CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) - Indx = 2_I4B - - CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) - Indx = 3_I4B - - CASE DEFAULT - Indx = 0_I4B - - END SELECT - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt & - & * SD % Thickness - - IF( Indx .EQ. 0 ) THEN - DO a = 1, M - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * Fext( a ) * SD % dNTdt - END DO - ELSE - DO a = 1, M - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * Fext( a ) * SD % dNTdXt( :, Indx, : ) - END DO - END IF - - END DO - END DO - - NULLIFY( SD ) - -END SUBROUTINE getFextVector_26 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_3.part b/src/submodules/STFextVector/FextVector_3.part deleted file mode 100755 index 1c1a8c5b4..000000000 --- a/src/submodules/STFextVector/FextVector_3.part +++ /dev/null @@ -1,97 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_3.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== -! -! -!------------------------------------------------------------------------------ -! getFextVector_3 -!------------------------------------------------------------------------------ -! -SUBROUTINE getFextVector_3( Obj, Fext ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext is constant in both space and time domain - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M - REAL( DFP ), ALLOCATABLE :: DummyMat(:,:) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - & "STFextVector_Class.f90", & - & "getFextVector_1(Obj, Fext)", & - & "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - DummyMat = OUTERPROD( Fext, SD % N ) - - DO a = 1, NNT - Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & - & DummyMat * RealVal * SD % T( a ) - END DO - END DO - END DO - - DEALLOCATE( DummyMat ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_4.part b/src/submodules/STFextVector/FextVector_4.part deleted file mode 100755 index 67e70f3f3..000000000 --- a/src/submodules/STFextVector/FextVector_4.part +++ /dev/null @@ -1,135 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_4.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_4 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_4( Obj, Fext, FextType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. FextType can be Nodal or Quad - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M - REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat( :, : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - ! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_4(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NIPS = Obj % getNIPS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - & "getFextVector_4(), Flag-2", & - & "The SIZE( Fext, 2 ) should be & - & equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - & "getFextVector_4(), Flag-3", & - & "The SIZE( Fext, 3 ) should be & - & equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints') - isNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isNodal ) THEN - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS, IPT ) - END IF - - DummyMat = OUTERPROD( Fbar, SD % N ) - - DO a = 1, NNT - Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & - & DummyMat * RealVal * SD % T( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, DummyMat ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_4 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_5.part b/src/submodules/STFextVector/FextVector_5.part deleted file mode 100755 index 76ffaabf9..000000000 --- a/src/submodules/STFextVector/FextVector_5.part +++ /dev/null @@ -1,127 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_5.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_5 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_5( Obj, Fext, FextType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext is space nodal values and FextType can be nodal or quad - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M - REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat( :, : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - ! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_5(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NIPS = Obj % getNIPS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - & "getFextVector_5(), Flag-2", & - & "The SIZE( Fext, 2 ) should be & - & equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints') - isNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isNodal ) THEN - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS ) - END IF - - DummyMat = OUTERPROD( Fbar, SD % N ) - - DO a = 1, NNT - Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & - & DummyMat * RealVal * SD % T( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, DummyMat ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_5 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_6.part b/src/submodules/STFextVector/FextVector_6.part deleted file mode 100755 index 79917bf73..000000000 --- a/src/submodules/STFextVector/FextVector_6.part +++ /dev/null @@ -1,169 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_6.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_6 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_6( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes the space and time nodal values and C also denotes the - ! space-time nodal values - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isCNodal, isFNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - & "getFextVector_6(), Flag-1", & - & "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_6(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_6(), Flag-3", & - "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_6(), Flag-4", & - "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_6(), Flag-5", & - "The SIZE( C, 3 ) should be equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_6(), Flag-6", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - isCNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isCNodal = .FALSE. - END SELECT - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD=>Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isCNodal ) THEN - CALL SD % getProjectionOfdNTdXt( & - & STNodalValues = C, cdNTdXt = cdNTdXt ) - ELSE - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C(:,IPS,IPT), cdNTdXt = cdNTdXt ) - END IF - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS, IPT ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_6 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/FextVector_7.part b/src/submodules/STFextVector/FextVector_7.part deleted file mode 100755 index e5d99f6b2..000000000 --- a/src/submodules/STFextVector/FextVector_7.part +++ /dev/null @@ -1,154 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_7.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_7 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_7( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext and C denotes the space nodal values - ! 2. FextType and CType can be Nodal and Quad - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isCNodal, isFNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_7(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_7(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_7(), Flag-3", & - "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_7(), Flag-4", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - isCNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isCNodal = .FALSE. - END SELECT - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD=>Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isCNodal ) THEN - CALL SD % getProjectionOfdNTdXt( & - & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) - ELSE - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C(:,IPS), cdNTdXt = cdNTdXt ) - END IF - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & SpaceNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_7 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/STFextVector/FextVector_8.part b/src/submodules/STFextVector/FextVector_8.part deleted file mode 100755 index e9e9c680d..000000000 --- a/src/submodules/STFextVector/FextVector_8.part +++ /dev/null @@ -1,109 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_8.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_8 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_8( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns element Fext; - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_8(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - -#ifdef DEBUG_VER - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_8(), Flag-2", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - M = SIZE( Fext, 1 ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD=>Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C, cdNTdXt = cdNTdXt ) - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fext( a ) - END DO - - END DO - END DO - - DEALLOCATE( cdNTdXt ) - NULLIFY( SD ) - -END SUBROUTINE getFextVector_8 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_9.part b/src/submodules/STFextVector/FextVector_9.part deleted file mode 100755 index 50b98d8b7..000000000 --- a/src/submodules/STFextVector/FextVector_9.part +++ /dev/null @@ -1,161 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FextVector_9.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STFextVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFextVector_9 -!------------------------------------------------------------------------------ - -SUBROUTINE getFextVector_9( Obj, Fext, C, FextType, CType ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Fext denotes space and time nodal values; C denotes the space - ! nodal values; FextType and Ctype are Quad or NodalValues - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) - REAL( DFP ) :: RealVal - LOGICAL( LGT ) :: isCNodal, isFNodal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_9(), Flag-1", & - "STFextVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_9(), Flag-2", & - "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_9(), Flag-3", & - "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_9(), Flag-4", & - "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( C, 1 ) .NE. NSD ) THEN - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_9(), Flag-5", & - "The SIZE( C, 1 ) should be equal to NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - isFNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isFNodal = .FALSE. - END SELECT - - isCNodal = .TRUE. - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - CASE( 'Quad', 'QuadPoints', 'Quad Points', & - & 'Integration', 'Integration Points', & - & 'IntegrationPoints' ) - isCNodal = .FALSE. - END SELECT - - M = SIZE( Fext, 1 ) - ALLOCATE( Fbar( M ) ) - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => Obj%SD(IPS,IPT) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - IF( isCNodal ) THEN - CALL SD % getProjectionOfdNTdXt( & - & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) - ELSE - CALL SD % getProjectionOfdNTdXt( & - & VectorValues = C(:,IPS), cdNTdXt = cdNTdXt ) - END IF - - IF( isFNodal ) THEN - CALL SD % getInterpolationOfVector( & - & STNodalValues = Fext, Val = Fbar ) - ELSE - Fbar = Fext( :, IPS, IPT ) - END IF - - DO a = 1, NSD - Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & - & RealVal * cdNTdXt * Fbar( a ) - END DO - END DO - END DO - - DEALLOCATE( Fbar, cdNTdXt ) - NULLIFY( SD ) -END SUBROUTINE getFextVector_9 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFextVector/MdFiles/STFextVector_Class.md b/src/submodules/STFextVector/MdFiles/STFextVector_Class.md deleted file mode 100755 index 260c8973d..000000000 --- a/src/submodules/STFextVector/MdFiles/STFextVector_Class.md +++ /dev/null @@ -1,1845 +0,0 @@ -# Space Time Fext Vector Class - -## ToDo - -- External force due to function -- External force due to line load or point load -- External force due to impact load, dirac delta function - -[toc] - -## Getting Started - -### Making the object - -`STFextVector_` class is subclass of `STElemShapeData_` class. The object of this class can be initiated using following commands. - -- Calling the inherited method `initiate` - -```fortran -CALL STElemSD % Initiate( NIPS = NIPS, NIPT = NIPT) -``` - -- We can use the `STFextVector()` function - -```fortran -CLASS( STELemShapeData_ ), POINTER :: STElemSD -STElemSD => STFextVector( ) -STElemSD => STFextVector( row = row, NIPS = NIPS, NIPT = NIPT ) -STElemSD => STFextVector( I1, I2, I3, NIPS, NIPT) -``` - -### Getting the Space time Fext Vector - -$$ -J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}\mathop {{f_i}}\limits_{ext} d\Omega dt} } -$$ - -We can compute the above integral using the following fortran command - -```fortran -CALL Obj % getFextVector( Fext ) -``` - -In the above call the argument `Fext` can be a Rank-1, Rank-2, or Rank-3 matrix. - -- If Fext is changing with both space and time then it must be described by the Rank-3 matrix. -- If Fext is changing only in space then it must be described by the Rank-2 matrix. -- If Fext is not changing with space and time then it must be described by the Rnak-1 array. - -In case `Fext` is defined at the quadrature points then we can use the following fortran command. - -```fortran -CALL Obj % getFextVector(Fext, FextType) -``` - -Here `FextType` can be `NodalValues` or `QuadPoints`. Once again `Fext` can be a rank-1, rank-2, or rank-3 array. - -To compute the following integral - -$$ -J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {{\bf{c}} \cdot \frac{{\partial {N^I}{T_a}}}{{d{\bf{x}}}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } -$$ - -we can use the following fortran command - -```fortran -CALL Obj % getFextVector(Fext, C, FextType, CType) -``` - -> In the above call `C` denotes the convective matrix, `Fext` denotes external force vector. `FextType` and `CType` can be `NodalValues` and/or `QuadPoints`. Moreover, `C` and `Fext` can be rank-1, rank-2, rank-3 fortran arrays. - -IF both `Fext` and `C` can be given by nodal-values instead of quadrature point values then we can use the following fortran command. - -```fortran -CALL Obj % getFextVector( Fext, C ) -``` - -> Note that in above call Fext and C can be rank-1, rank-2, and/or rank-3 fortran array. - -To compute the following integral - -$$ -J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dt}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } -$$ - -we can call the following fortran command - -```fortran -CALL Obj % getFextVector( Fext, FextType, "dt") -``` - -To compute the following integral - -$$ -J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dx}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } -$$ - -we can call the following fortran command - -```fortran -CALL Obj % getFextVector( Fext, FextType, "dx") -``` - -To compute the following integral - -$$ -J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dy}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } -$$ - -we can call the following fortran command - -```fortran -CALL Obj % getFextVector( Fext, FextType, "dy") -``` - -To compute the following integral - -$$ -J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dz}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } -$$ - -we can call the following fortran command - -```fortran -CALL Obj % getFextVector( Fext, FextType, "dz") -``` - - - -## Theory - -Very often we need to compute the following matrices. - -$${}^{3}Vec(i, I, a) = {}^{a}\delta u_{iI} \int_{Q_n} N^I T_a f_i {dQ}$$ - -> These tasks are performed by following methods; `getFextVector_1()`, `getFextVector_2()`, `getFextVector_3()`, `getFextVector_4()`, and `getFextVector_5()` - -Now consider the following space-time finite element matrices. - -$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -> These tasks are performed by following methods; `getFextVector_6()`, `getFextVector_7()`, `getFextVector_8()`, `getFextVector_9()`, `getFextVector_10()`, `getFextVector_10()`, `getFextVector_11()`, `getFextVector_12()`, `getFextVector_13()`, `getFextVector_14()`, `getFextVector_15()`, `getFextVector_16()`, `getFextVector_17()`, `getFextVector_18()`, `getFextVector_19()`, `getFextVector_20()`, `getFextVector_21()`, `getFextVector_22()`, and `getFextVector_23()`. - -Now consider the following space-time finite element matrices. - -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ - -> These tasks are performed by following methods; `getFextVector_24()`, `getFextVector_25()`, `getFextVector_26()`. - -## Methods - -### getFextVector_1() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_1( Obj, Fext ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat3 ) -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat3 ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_1( Fext = DummyMat3 )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_1( Fext = DummyMat3 ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -### getFextVector_2() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_2( Obj, Fext ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the space nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case, `Fext` varies only in space and remains constant in time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat2 ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_2( Fext = DummyMat2 )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_2( Fext = DummyMat2 ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -### getFextVector_3() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_3( Obj, Fext ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- `Fext(:)` is a vector of shape `(M)`. It denotes the spatial components of external force. The first index denotes the componenets of a vector. In this case, `Fext` does not change in both space and time. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyVec ) -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyVec ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_3( Fext = DummyVec )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_3( Fext = DummyVec ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -### getFextVector_4() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_4( Obj, Fext, FextType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- `FextType` is a string. - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_4( Fext = DummyMat3, & -& FextType = "Quad" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_4( Fext = DummyMat3, FextType = "Quad" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -### getFextVector_5() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_5( Obj, Fext, FextType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- `FextType` is a string. - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies only in space, and remains constant in time domain. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at spatial integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in spatial domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = 'Quad' ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_5( Fext = DummyMat2, & -& FextType = "Quad" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_5( Fext = DummyMat2, FextType = "Quad" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -### getFextVector_6() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_6( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- `FextType` is a string. - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. -- `Ctype` is a string. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. - - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", & -C = DummyMat3, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_6( Fext = DummyMat3, FextType = "Quad", & -C = DummyMat3, CType = "Quad" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_6( Fext = DummyMat3, FextType = "Quad", C = DummyMat3, CType = "Quad" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_7() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_7( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- `FextType` is a string. - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies in space-domain, but remains constant in time. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in space, but remains constant in time domain. -- `Ctype` is a string. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the space-nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `C` varies in space-time domain. - - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:)` is a three dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `C` varies in space-domain, but remains constant in time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NIPS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", & -C = DummyMat2, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_7( Fext = DummyMat2, FextType = "Quad", & -C = DummyMat2, CType = "Quad" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_7( Fext = DummyMat2, FextType = "Quad", C = DummyMat2, CType = "Quad" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_8() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_8( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- This methods computes the space-time element vector for external force. -- There is no effect of `Ctype` or `FextType`. -- Both `Fext` and `C` are constant in space and time. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", & -C = DummyVec, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_7( Fext = DummyVec, FextType = "Quad", & -C = DummyVec, CType = "Quad" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_8( Fext = DummyVec, FextType = "Quad", C =DummyVec, CType = "Quad" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_9() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_9( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- `FextType` is a string. - - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. -- `Ctype` is a string. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the space-nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `C` varies in space-time domain. - - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:)` is a three dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `C` varies in space-domain, but remains constant in time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_25( Fext = DummyMat3, & -C = DummyMat2, FextType = "Nodal", CType = "Nodal" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_25( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_10() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_10( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- `FextType` is a string. - - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. -- There is no effect of `Ctype`, `C` is constant in space and time. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_10( Fext = DummyMat3, & -C = DummyVec, FextType = "Nodal", CType = "Nodal" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_10( Fext = DummyMat3, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_11() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_11( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- `FextType` is a string. - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies in space-domain, but remains constant in time. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in space, but remains constant in time domain. - -- `Ctype` is a string. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. - - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEAL[LOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_11( Fext = DummyMat3, & -C = DummyMat2, FextType = "Nodal", CType = "Nodal" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_11( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_12() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_12( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- There is no effect of `FextType`, and `Fext` is constant in space and time. - -- `Ctype` is a string. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. - - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = "Nodal", CType = "Nodal" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_12( Fext = DummyVec, & -C = DummyMat3, FextType = "Nodal", CType = "Nodal" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_12( Fext = DummyVec, C = DummyMat3, FextType = "Nodal", CType = "Nodal" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_13() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_13( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- There is no effect of `CType`, and `C` is constant in space and time. - -- `FextType` is a string. - - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies in space-domain, but remains constant in time. - - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in space, but remains constant in time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_12( Fext = DummyMat2, & -C = DummyVec, FextType = "Nodal", CType = "Nodal" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_12( Fext = DummyMat2, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_14() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_14( Obj, Fext, C, FextType, CType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType -``` - -DESCRIPTION - -- There is no effect of `FextType`, and `Fext` is constant in space and time. - -- `Ctype` is a string. - - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. - - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Nodal', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Quad', Ctype = 'Quad') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Quad', Ctype = 'Nodal') -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Nodal', Ctype = 'Quad') -``` - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_14( Fext = DummyVec, & -C = DummyMat2, FextType = "Nodal", CType = "Nodal" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 1, NIPT = 1__ - -```fortran -CALL STElemSD % getFextVector_14( Fext = DummyVec, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 1 NIPT :: 1 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 - -Vec3( :, :, 2 ) - - -2.000000 -2.000000 - 0.000000 0.000000 - 2.000000 2.000000 - 0.000000 0.000000 -``` - -### getFextVector_15() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_15( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_16() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_16( Obj, Fext, C ) - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_17() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_17( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_18() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_18( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C -``` - -### getFextVector_19() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_19( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_20() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_20( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_21() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_21( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_22() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_22( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_23() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_23( Obj, Fext, C ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C -``` - -DESCRIPTION - -SYNTAX - -SYMBOLIC CALCULATION - -$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ - -### getFextVector_24() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_24( Obj, Fext, FextType, Term1 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 -``` - -DESCRIPTION - -SYMBOLIC CALCULATION - -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dx" ) -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dy" ) -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dz" ) -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dt" ) -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dx" ) -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dy" ) -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dz" ) -CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dt" ) -``` - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat3, & -FextType = "Nodal", Term1 = "dx" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_24( Fext = DummyMat3, & -FextType = "Nodal", Term1 = "dx" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 4, NIPS = 2__ - -```fortran -CALL STElemSD % getFextVector_24( Fext = DummyMat3, FextType = "Nodal", Term1 = "dx" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 - -Vec3( :, :, 2 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 -``` - -```fortran -CALL STElemSD % getFextVector_24( Fext = DummyMat3, FextType = "Nodal", Term1 = "dy" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -Vec3( :, :, 2 ) - - -1.000000 -1.000000 - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -```fortran -CALL STElemSD % getFextVector_24( Fext = DummyMat3, FextType = "Nodal", Term1 = "dt" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - -1.000000 -1.000000 - -1.000000 -1.000000 - -1.000000 -1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - - -### getFextVector_25() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_25( Obj, Fext, FextType, Term1 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 -``` - -DESCRIPTION - -SYMBOLIC CALCULATION - -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dx" ) -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dy" ) -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dz" ) -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dt" ) -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dx" ) -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dy" ) -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dz" ) -CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dt" ) -``` - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyMat2, & - FextType = "Nodal", Term1 = "dx" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_25( Fext = DummyMat2, & -FextType = "Nodal", Term1 = "dx" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 4, NIPT =2__ - -```fortran -CALL STElemSD % getFextVector_25( Fext = DummyMat2, FextType = "Nodal", Term1 = "dx" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 - -Vec3( :, :, 2 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 -``` - -```fortran -CALL STElemSD % getFextVector_25( Fext = DummyMat2, FextType = "Nodal", Term1 = "dx" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 - -Vec3( :, :, 2 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 -``` - -```fortran -CALL STElemSD % getFextVector_25( Fext = DummyMat2, FextType = "Nodal", Term1 = "dt" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - -1.000000 -1.000000 - -1.000000 -1.000000 - -1.000000 -1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -### getFextVector_26() - -INTERFACE - -```fortran - SUBROUTINE getFextVector_26( Obj, Fext, FextType, Term1 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext - CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 -``` - -DESCRIPTION - -SYMBOLIC CALCULATION - -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ -$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ - -SYNTAX - -```fortran -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dx" ) -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dy" ) -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dz" ) -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dt" ) -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dx" ) -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dy" ) -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dz" ) -CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dt" ) -``` - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getFextVector( Fext = DummyVec, & - FextType = "Nodal", Term1 = "dx" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getFextVector_25( Fext = DummyVec, & -FextType = "Nodal", Term1 = "dx" )' - -CALL STElemSD % DisplayVector3( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getFextVector_25( Fext = DummyVec, FextType = "Nodal", Term1 = "dx" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 - -Vec3( :, :, 2 ) - - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -1.000000 -1.000000 -``` - -```fortran -CALL STElemSD % getFextVector_25( Fext = DummyVec, FextType = "Nodal", Term1 = "dy" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - -Vec3( :, :, 2 ) - - -1.000000 -1.000000 - -1.000000 -1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` - -```fortran -CALL STElemSD % getFextVector_25( Fext = DummyVec, FextType = "Nodal", Term1 = "dt" ) - -VECTOR STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 -------------------------------------------------- - -Vec3(:,:,:) :: - -Vec3( :, :, 1 ) - - -1.000000 -1.000000 - -1.000000 -1.000000 - -1.000000 -1.000000 - -1.000000 -1.000000 - -Vec3( :, :, 2 ) - - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 - 1.000000 1.000000 -``` \ No newline at end of file diff --git a/src/submodules/STFextVector/MethodNames.part b/src/submodules/STFextVector/MethodNames.part deleted file mode 100644 index 370ddaa3d..000000000 --- a/src/submodules/STFextVector/MethodNames.part +++ /dev/null @@ -1,26 +0,0 @@ -getFextVector_1, & -getFextVector_2, & -getFextVector_3, & -getFextVector_4, & -getFextVector_5, & -getFextVector_6, & -getFextVector_7, & -getFextVector_8, & -getFextVector_9, & -getFextVector_10, & -getFextVector_11, & -getFextVector_12, & -getFextVector_13, & -getFextVector_14, & -getFextVector_15, & -getFextVector_16, & -getFextVector_17, & -getFextVector_18, & -getFextVector_19, & -getFextVector_20, & -getFextVector_21, & -getFextVector_22, & -getFextVector_23, & -getFextVector_24, & -getFextVector_25, & -getFextVector_26 diff --git a/src/submodules/STFextVector/STFextVector_Class.f90 b/src/submodules/STFextVector/STFextVector_Class.f90 deleted file mode 100755 index 604cbe68a..000000000 --- a/src/submodules/STFextVector/STFextVector_Class.f90 +++ /dev/null @@ -1,102 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: STFextVector_Class.f90 -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - STElemShapeData_ Class is extended for computing the STFextVector. -! Updates -! - Nov-23-2017 -! - Jan-04-2018 Added STFextVector_Pointer -!============================================================================== - - MODULE STFextVector_Class - USE IO - USE GlobalData - USE STElemShapeData_Class - USE STShapeData_Class - USE ShapeData_Class - - IMPLICIT NONE - - PRIVATE - PUBLIC :: STFextVector, STFextVector_, STFextVector_Pointer - -!------------------------------------------------------------------------------ -! STFextVector_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( STElemShapeData_ ) :: STFextVector_ - -!. . . . . . . . . . . . . . . . . . . . -! 1. This class computes the Space-Time External Force vector -! for space-time element. -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - - PROCEDURE, PUBLIC, PASS :: & -#include "./MethodNames.part" - - END TYPE STFextVector_ - -!------------------------------------------------------------------------------ -! INTERFACES -!------------------------------------------------------------------------------ - - INTERFACE STFextVector - MODULE PROCEDURE Constructor1, Constructor2, Constructor3 - END INTERFACE - - INTERFACE STFextVector_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 - END INTERFACE - -!------------------------------------------------------------------------------ -! CONTAINS -!------------------------------------------------------------------------------ - - CONTAINS - -#include "./Constructor.part" -#include "./FextVector_1.part" -#include "./FextVector_2.part" -#include "./FextVector_3.part" -#include "./FextVector_4.part" -#include "./FextVector_5.part" -#include "./FextVector_6.part" -#include "./FextVector_7.part" -#include "./FextVector_8.part" -#include "./FextVector_9.part" -#include "./FextVector_10.part" -#include "./FextVector_11.part" -#include "./FextVector_12.part" -#include "./FextVector_13.part" -#include "./FextVector_14.part" -#include "./FextVector_15.part" -#include "./FextVector_16.part" -#include "./FextVector_17.part" -#include "./FextVector_18.part" -#include "./FextVector_19.part" -#include "./FextVector_20.part" -#include "./FextVector_21.part" -#include "./FextVector_22.part" -#include "./FextVector_23.part" -#include "./FextVector_24.part" -#include "./FextVector_25.part" -#include "./FextVector_26.part" - - END MODULE STFextVector_Class - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/delme.f90 b/src/submodules/STFextVector/delme.f90 deleted file mode 100644 index a7971671a..000000000 --- a/src/submodules/STFextVector/delme.f90 +++ /dev/null @@ -1,338 +0,0 @@ - - SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'STNodalValues', 'ST Nodal Values' ) - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & - STNodalValues = Fext, Val = Fbar ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 1, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & - STNodalValues = Fext, Val = Fbar ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 2, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & - STNodalValues = Fext, Val = Fbar ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 3, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE( 'dt', 'dT', 'Dt', 't' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & - STNodalValues = Fext, Val = Fbar ) - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdt( I, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( 'STFextVector_Class.f90>>FextVector_24.part', & - & 'getFextVector_24()', & - & 'No case found for Term1, It should be, & - & [dx, dx1, dX, dX1, x, X, x1, X1], & - & [dy, dx2, dY, dX2, y, Y, x2, X2], & - & [dz, dx3, dZ, dX3, z, Z, x3, X3], & - & [dt, dT, t, Dt]' ) - Error_Flag = .TRUE. - RETURN - - END SELECT - - - - CASE( 'Integration', 'Integration Points', 'IntegrationPoints', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) - - CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - Fbar = Fext( :, IPS, IPT ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 1, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - Fbar = Fext( :, IPS, IPT ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 2, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - Fbar = Fext( :, IPS, IPT ) - - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 3, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE( 'dt', 'dT', 'Dt', 't' ) - - DO a = 1, NNT - - DO I = 1, NNS - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - - thick = Obj % SD( IPS, IPT ) % getThickness( ) - - Fbar = Fext( :, IPS, IPT ) - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - RealVal = Ws * Wt * Js * Jt * thick * dNTdt( I, a ) - - Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & - Fbar * RealVal - - END DO - - END DO - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( 'STFextVector_Class.f90>>FextVector_24.part', & - & 'getFextVector_24()', & - & 'No case found for Term1, It should be, & - & [dx, dx1, dX, dX1, x, X, x1, X1], & - & [dy, dx2, dY, dX2, y, Y, x2, X2], & - & [dz, dx3, dZ, dX3, z, Z, x3, X3], & - & [dt, dT, t, Dt]' ) - Error_Flag = .TRUE. - RETURN - - END SELECT - - CASE DEFAULT - - CALL Err_Msg("STFextVector_Class.f90", & - "getFextVector_24(), Flag-1", & - "No case found for FextType, It should be & - 'Nodal', 'Nodal Values', 'NodalValues', 'STNodalValues', 'ST Nodal Values', & - & 'Integration', 'Integration Points', 'IntegrationPoints', 'Quad', 'QuadPoints', & - & 'Quad Points'" ) - Error_Flag = .TRUE. - RETURN - - END SELECT \ No newline at end of file diff --git a/src/submodules/STFintVector/Constructor.part b/src/submodules/STFintVector/Constructor.part deleted file mode 100755 index 79975bb1f..000000000 --- a/src/submodules/STFintVector/Constructor.part +++ /dev/null @@ -1,152 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Construction method for STFintVector_ Object -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Row, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFintVector_ pointer -! Allocates the Obj % Vec1( row ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STFintVector_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT - - ALLOCATE( Constructor_1 ) - ALLOCATE( Constructor_1 % Vec1( row ) ) - Constructor_1 % Vec1 = 0.0_DFP - CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( I1, I2, I3, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFintVector_ pointer -! Allocates the Obj % Vec3( I1, I2, I3 ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STFintVector_ ), POINTER :: Constructor_2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT - - ALLOCATE( Constructor_2 ) - ALLOCATE( Constructor_2 % Vec3( I1, I2, I3 ) ) - Constructor_2 % Vec3 = 0.0_DFP - CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFintVector_ pointer -! Empty constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STFintVector_ ), POINTER :: Constructor_3 - - ALLOCATE( Constructor_3 ) - - END FUNCTION Constructor_3 - - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Row, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFintVector_ object -! Allocates the Obj % Vec1( row ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STFintVector_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT - - ALLOCATE( Constructor1 % Vec1( row ) ) - Constructor1 % Vec1 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( I1, I2, I3, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFintVector_ object -! Allocates the Obj % Vec3( I1, I2, I3 ) -! Allocates the Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STFintVector_ ) :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT - - ALLOCATE( Constructor2 % Vec3( I1, I2, I3 ) ) - Constructor2 % Vec3 = 0.0_DFP - CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the STFintVector_ object -! Empty constructor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STFintVector_ ) :: Constructor3 - - END FUNCTION Constructor3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_1.part b/src/submodules/STFintVector/FintVector_1.part deleted file mode 100755 index 40e223494..000000000 --- a/src/submodules/STFintVector/FintVector_1.part +++ /dev/null @@ -1,113 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_1.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_1 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_1( Obj, Sigma ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Fint; - ! 2. Sigma( :, :, : ) depends upon space and time - ! 3. First index of Sigma is related to the voigt components - ! 4. Second index denotes the spatial-integration point and - ! 5. Third index denotes the temporal integration point - !. . . . . . . . . . . . . . . . . . . . - - USE Voigt, ONLY : MatFromVoigtVec - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Sigma - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J - REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_1(Obj, Sigma)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Sigma, 2 ) .NE. NIPS .OR. SIZE( Sigma, 3 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_1(Obj, Sigma)", & - "The SIZE( Sigma, 2 ) should be equal to NIPS, & - & The SIZE( Sigma, 3 ) should be equal to NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD%Thickness - S = MatFromVoigtVec( Sigma( :, IPS, IPT ), "Stress" ) - DO i = 1, NSD - Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) - DO j = 2, NSD - Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) - END DO - Obj % Vec3( i, :, : ) = Obj % Vec3( i, :, : ) + RealVal * Mat - END DO - END DO - END DO - - DEALLOCATE( S, Mat ) - NULLIFY( SD ) - -END SUBROUTINE getFintVector_1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_2.part b/src/submodules/STFintVector/FintVector_2.part deleted file mode 100755 index ad71d4df1..000000000 --- a/src/submodules/STFintVector/FintVector_2.part +++ /dev/null @@ -1,112 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_2.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_2 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_2( Obj, Sigma ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Fint; - ! 2. Sigma( :, : ) does not change with time - ! 3. First index of Sigma is related to the voigt components - ! 4. Second index denotes the spatial-integration point - !. . . . . . . . . . . . . . . . . . . . - - USE Voigt, ONLY : MatFromVoigtVec - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Sigma - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J - REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_2(Obj, Sigma)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - -#ifdef DEBUG_VER - IF( SIZE( Sigma, 2 ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_2(Obj, Sigma)", & - "The SIZE( Sigma, 2 ) should be equal to NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPT = Obj % getNIPT( ) - - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - DO IPS = 1, NIPS - S = MatFromVoigtVec( Sigma( :, IPS ), "Stress" ) - DO IPT = 1, NIPT - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD%Thickness - DO i = 1, NSD - Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) - DO j = 2, NSD - Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) - END DO - Obj % Vec3( i, :, : ) = Obj % Vec3( i, :, : ) + RealVal * Mat - END DO - END DO - END DO - - DEALLOCATE( S, Mat ) - NULLIFY( SD ) - -END SUBROUTINE getFintVector_2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_3.part b/src/submodules/STFintVector/FintVector_3.part deleted file mode 100755 index 0c33a819d..000000000 --- a/src/submodules/STFintVector/FintVector_3.part +++ /dev/null @@ -1,100 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_3.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_3 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_3( Obj, Sigma ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Fint; - ! 2. Sigma( : ) does not change with space and time. - ! 3. First index of Sigma is related to the voigt components - !. . . . . . . . . . . . . . . . . . . . - - USE Voigt, ONLY : MatFromVoigtVec - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Sigma - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J - REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ) - REAL( DFP ) :: RealVal - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_3(Obj, Sigma)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - ! Make Stress Tensor ( 3 by 3 ) - S = MatFromVoigtVec( Sigma, "Stress" ) - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD%Thickness - DO i = 1, NSD - Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) - DO j = 2, NSD - Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) - END DO - Obj % Vec3( i, :, : ) = Obj % Vec3( i, :, : ) + RealVal * Mat - END DO - END DO - END DO - - DEALLOCATE( S, Mat ) - NULLIFY( SD ) - -END SUBROUTINE getFintVector_3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_4.part b/src/submodules/STFintVector/FintVector_4.part deleted file mode 100755 index 50e1e22dd..000000000 --- a/src/submodules/STFintVector/FintVector_4.part +++ /dev/null @@ -1,100 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_4.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_4 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_4( Obj, CData ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Sigma; - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE Stress_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) - - ! Define internal variables - INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, N, NSD - REAL( DFP ), ALLOCATABLE :: Sigma( :, :, : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_4(Obj, CData)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_4(Obj, CData)", & - "The Shape of CData is not compatible" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ALLOCATE( Sigma( N, NIPS, NIPT ) ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - Sigma( :, IPS, IPT ) = CData( IPS, IPT ) % S .Shape. N - END DO - END DO - CALL Obj % getFintVector( Sigma ) - DEALLOCATE( Sigma ) - -END SUBROUTINE getFintVector_4 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_5.part b/src/submodules/STFintVector/FintVector_5.part deleted file mode 100755 index 1af81e412..000000000 --- a/src/submodules/STFintVector/FintVector_5.part +++ /dev/null @@ -1,96 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_5.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_5 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_5( Obj, CData ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Fint vector for space time element; - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE Stress_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( : ) - - ! Define internal variables - INTEGER( I4B ) :: NIPS, IPS, N, NSD - REAL( DFP ), ALLOCATABLE :: Sigma( :, : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_5(Obj, CData)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - -#ifdef DEBUG_VER - IF( SIZE( CData ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_5(Obj, CData)", & - "The Shape of CData is not compatible" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - ALLOCATE( Sigma( N, NIPS ) ) - DO IPS = 1, NIPS - Sigma( :, IPS ) = CData( IPS ) % S .Shape. N - END DO - CALL Obj % getFintVector( Sigma ) - DEALLOCATE( Sigma ) - -END SUBROUTINE getFintVector_5 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_6.part b/src/submodules/STFintVector/FintVector_6.part deleted file mode 100755 index adf3cc488..000000000 --- a/src/submodules/STFintVector/FintVector_6.part +++ /dev/null @@ -1,81 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_6.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_6 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_6( Obj, CData ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Fint vector for space time element; - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE Stress_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData - - ! Define internal variables - INTEGER( I4B ) :: N, NSD - REAL( DFP ), ALLOCATABLE :: Sigma( : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_6(Obj, CData)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1,1 ) % getNSD( ) - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - ALLOCATE( Sigma( N ) ) - Sigma( : ) = CData % S .Shape. N - CALL Obj % getFintVector_3( Sigma ) - DEALLOCATE( Sigma ) - -END SUBROUTINE getFintVector_6 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_7.part b/src/submodules/STFintVector/FintVector_7.part deleted file mode 100755 index 533e87f98..000000000 --- a/src/submodules/STFintVector/FintVector_7.part +++ /dev/null @@ -1,138 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_1.part -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! - Internal force vector for alpha-beta v-STFEM -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_7 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_7( Obj, Sigma, TimeVector, beta_STFEM ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Sigma; - !. . . . . . . . . . . . . . . . . . . . - - USE Voigt, ONLY : MatFromVoigtVec - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Sigma - REAL( DFP ), INTENT( IN ) :: beta_STFEM, TimeVector( 2 ) - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J - - REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ), T( : ) - REAL( DFP ) :: RealVal, beta, t1, t2 - TYPE( STElemShapeData_ ), TARGET :: STElemSD2 - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_7(Obj, Sigma)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Sigma, 2 ) .NE. NIPS .OR. SIZE( Sigma, 3 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_7(Obj, Sigma)", & - "The SIZE( Sigma, 2 ) should be equal to NIPS, & - & The SIZE( Sigma, 3 ) should be equal to NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) - ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) - Obj % Vec3 = 0.0_DFP - - t1 = TimeVector( 1 ) - t2 = TimeVector( 2 ) - beta = beta_STFEM * ( t2 - t1 ) - - CALL STElemSD2 % Initiate( Obj ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => STElemSD2 % SD( IPS, IPT ) - T = SD % dTdTheta / SD % Jt - CALL SD % setT( T ) - CALL SD % setdNTdXt( ) - END DO - END DO - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SD => STElemSD2 % SD( IPS, IPT ) - - RealVal = Obj % SD( IPS, IPT ) % Ws & - & * Obj % SD( IPS, IPT ) % Wt & - & * Obj % SD( IPS, IPT ) % Js_Xi2Xt & - & * Obj % SD( IPS, IPT ) % Jt & - & * Obj % SD( IPS, IPT ) % Thickness & - & * beta - - S = MatFromVoigtVec( Sigma( :, IPS, IPT ), "Stress" ) - - DO i = 1, NSD - Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) - DO j = 2, NSD - Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) - END DO - Obj % Vec3(i, :, : ) = Obj % Vec3( i, :, : ) & - & + Mat * RealVal - END DO - - END DO - - END DO - - NULLIFY( SD ) - DEALLOCATE( Mat, T, S, STElemSD2 % SD ) - -END SUBROUTINE getFintVector_7 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/FintVector_8.part b/src/submodules/STFintVector/FintVector_8.part deleted file mode 100755 index 169a854a6..000000000 --- a/src/submodules/STFintVector/FintVector_8.part +++ /dev/null @@ -1,103 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: FintVector_8.part -! Last Update : March-25-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Method for computing the Spacetime Fint vector -! - Internal force vector for alpha-beta v-STFEM -! -! HOSTING FILE -! - STFintVector_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getFintVector_8 -!------------------------------------------------------------------------------ - -SUBROUTINE getFintVector_8( Obj, CData, TimeVector, beta_STFEM ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns element Sigma; - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE Stress_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) - REAL( DFP ), INTENT( IN ) :: beta_STFEM, TimeVector( 2 ) - - ! Define internal variables - INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, N, NSD - REAL( DFP ), ALLOCATABLE :: Sigma( :, :, : ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_8(Obj, CData)", & - "STFintVector_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1,1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STFintVector_Class.f90", & - "getFintVector_8(Obj, CData)", & - "The Shape of CData is not compatible" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ALLOCATE( Sigma( N, NIPS, NIPT ) ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - Sigma( :, IPS, IPT ) = CData( IPS, IPT ) % S .Shape. N - END DO - END DO - - CALL Obj % getFintVector( Sigma, TimeVector, beta_STFEM ) - DEALLOCATE( Sigma ) - -END SUBROUTINE getFintVector_8 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STFintVector/MdFiles/STFintVector_Class.md b/src/submodules/STFintVector/MdFiles/STFintVector_Class.md deleted file mode 100755 index 781dac88e..000000000 --- a/src/submodules/STFintVector/MdFiles/STFintVector_Class.md +++ /dev/null @@ -1,61 +0,0 @@ -# Space Time Internal Force Vector - -## ToDo - -- Make construction method like `STFintVector(S1, S2)` where the S1 and S2 are Integer vectors. The size of S2 is two. and it contains `NIPS` and `NIPT`. The size of S1 should be either 1 or 3. If One allocates `Obj % Vec1(S1(1))`, If 3 then allocate `Obj % Vec3()`. - -## Description - -The class `STFintVector_Class` is the subclass of `STElemShapeData_` class. It is designed to compute the internal force vector for `SolidMechanics` applications. - -## Getting Started - -### Making the Object - -We have defined the function called `STFintVector_Pointer` that will return the pointer to the object. We have also defined the function `STFintVector()` that will return the object of `STFintVector_` type. - -```fortran -Obj => STFintVector_Pointer( ) -Obj => STFintVector_Pointer( Row, NIPS, NIPT ) -Obj => STFintVector_Pointer( I1, I2, I3, NIPS, NIPT ) -``` - -- The first call, above, is empty contructor. -- The second call, above, allocates `Obj % Vec1(row)` and `Obj%SD(NIPS, NIPT)` -- The third call, above, allocates `Obj%Vec3(I1, I2, I3)` and `Obj%SD(NIPS, NIPT)` - -```fortran -Obj = STFintVector( ) -Obj = STFintVector( Row, NIPS, NIPT ) -Obj = STFintVector( I1, I2, I3, NIPS, NIPT ) -``` - -- The first call, above, is empty contructor. -- The second call, above, allocates `Obj % Vec1(row)` and `Obj%SD(NIPS, NIPT)` -- The third call, above, allocates `Obj%Vec3(I1, I2, I3)` and `Obj%SD(NIPS, NIPT)` - -### Getting the Fint vector - -```fortran -CALL Obj % getFintVector( Sigma( :, :, : ) ) -``` - -```fortran -CALL Obj % getFintVector( Sigma( :, : ) ) -``` - -```fortran -CALL Obj % getFintVector( Sigma( : ) ) -``` - -```fortran -CALL Obj % getFintVector( CData( :, : ) ) -``` - -```fortran -CALL Obj % getFintVector( CData( : ) ) -``` - -```fortran -CALL Obj % getFintVector( CData ) -``` \ No newline at end of file diff --git a/src/submodules/STFintVector/MethodNames.part b/src/submodules/STFintVector/MethodNames.part deleted file mode 100644 index 0d90034a4..000000000 --- a/src/submodules/STFintVector/MethodNames.part +++ /dev/null @@ -1,8 +0,0 @@ -getFintVector_1, & -getFintVector_2, & -getFintVector_3, & -getFintVector_4, & -getFintVector_5, & -getFintVector_6, & -getFintVector_7, & -getFintVector_8 \ No newline at end of file diff --git a/src/submodules/STFintVector/STFintVector_Class.f90 b/src/submodules/STFintVector/STFintVector_Class.f90 deleted file mode 100755 index 08e3a0524..000000000 --- a/src/submodules/STFintVector/STFintVector_Class.f90 +++ /dev/null @@ -1,80 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: STFintVector_Class.f90 -! Last Update : Jan-04-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - STElemShapeData_ Class is extended for computing the STFintVector. -!============================================================================== - -MODULE STFintVector_Class - USE IO - USE GlobalData - USE STElemShapeData_Class - USE STShapeData_Class - USE ShapeData_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: STFintVector, STFintVector_, STFintVector_Pointer - - !------------------------------------------------------------------------------ - ! STFintVector_ - !------------------------------------------------------------------------------ - - TYPE, EXTENDS( STElemShapeData_ ) :: STFintVector_ - - !. . . . . . . . . . . . . . . . . . . . - ! 1. This class computes the Space-Time Internal Force vector - ! for space-time element. - !. . . . . . . . . . . . . . . . . . . . - - CONTAINS - - PROCEDURE, PUBLIC, PASS :: & -#include "./MethodNames.part" - - END TYPE STFintVector_ - - !------------------------------------------------------------------------------ - ! INTERFACES - !------------------------------------------------------------------------------ - - INTERFACE STFintVector - MODULE PROCEDURE Constructor1, Constructor2, Constructor3 - END INTERFACE STFintVector - - INTERFACE STFintVector_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 - END INTERFACE STFintVector_Pointer - - !------------------------------------------------------------------------------ - ! CONTAINS - !------------------------------------------------------------------------------ - - CONTAINS - -#include "./Constructor.part" -#include "./FintVector_1.part" -#include "./FintVector_2.part" -#include "./FintVector_3.part" -#include "./FintVector_4.part" -#include "./FintVector_5.part" -#include "./FintVector_6.part" -#include "./FintVector_7.part" -#include "./FintVector_8.part" - - END MODULE STFintVector_Class - - !------------------------------------------------------------------------------ - ! - !------------------------------------------------------------------------------ diff --git a/src/submodules/STForceVector/CMakeLists.txt b/src/submodules/STForceVector/CMakeLists.txt deleted file mode 100644 index d3b0f733a..000000000 --- a/src/submodules/STForceVector/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STForceVector_Method@Methods.F90 - ) diff --git a/src/submodules/STForceVector/src/STFV_1.inc b/src/submodules/STForceVector/src/STFV_1.inc deleted file mode 100644 index 545c440c8..000000000 --- a/src/submodules/STForceVector/src/STFV_1.inc +++ /dev/null @@ -1,55 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_1(ans, test, term1) - !! intent of dummy variable - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_NONE - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! - END DO - !! - DEALLOCATE (realval) - !! -END SUBROUTINE STFV_1 diff --git a/src/submodules/STForceVector/src/STFV_10.inc b/src/submodules/STForceVector/src/STFV_10.inc deleted file mode 100644 index 4d1d43572..000000000 --- a/src/submodules/STForceVector/src/STFV_10.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_10(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableVector_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & cbar(:, ips, ipt), & - & test(ipt)%dNTdt(:, :, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_10 diff --git a/src/submodules/STForceVector/src/STFV_11.inc b/src/submodules/STForceVector/src/STFV_11.inc deleted file mode 100644 index a8dd461fd..000000000 --- a/src/submodules/STForceVector/src/STFV_11.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_11(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableMatrix_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(cbar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & cbar(:, :, ips, ipt), & - & test(ipt)%dNTdt(:, :, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_11 diff --git a/src/submodules/STForceVector/src/STFV_12.inc b/src/submodules/STForceVector/src/STFV_12.inc deleted file mode 100644 index 30f70caa6..000000000 --- a/src/submodules/STForceVector/src/STFV_12.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_12(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableScalar_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_12 diff --git a/src/submodules/STForceVector/src/STFV_13.inc b/src/submodules/STForceVector/src/STFV_13.inc deleted file mode 100644 index 46c60fca7..000000000 --- a/src/submodules/STForceVector/src/STFV_13.inc +++ /dev/null @@ -1,68 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_13(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & c2bar(:, ips, ipt), & - & test(ipt)%dNTdt(:, :, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_13 diff --git a/src/submodules/STForceVector/src/STFV_14.inc b/src/submodules/STForceVector/src/STFV_14.inc deleted file mode 100644 index 2a15e9e59..000000000 --- a/src/submodules/STForceVector/src/STFV_14.inc +++ /dev/null @@ -1,68 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_14(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & c2bar(:, :, ips, ipt), & - & test(ipt)%dNTdt(:, :, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_14 diff --git a/src/submodules/STForceVector/src/STFV_15.inc b/src/submodules/STForceVector/src/STFV_15.inc deleted file mode 100644 index a38e8e233..000000000 --- a/src/submodules/STForceVector/src/STFV_15.inc +++ /dev/null @@ -1,53 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_15(ans, test, term1) - !! intent of dummy variable - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_x, DEL_y, DEL_z - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips) - END DO - !! - END DO - !! - DEALLOCATE (realval) - !! -END SUBROUTINE STFV_15 diff --git a/src/submodules/STForceVector/src/STFV_16.inc b/src/submodules/STForceVector/src/STFV_16.inc deleted file mode 100644 index 1e7d142a4..000000000 --- a/src/submodules/STForceVector/src/STFV_16.inc +++ /dev/null @@ -1,58 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_16(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_x, DEL_y, DEL_z - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableScalar_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_16 diff --git a/src/submodules/STForceVector/src/STFV_17.inc b/src/submodules/STForceVector/src/STFV_17.inc deleted file mode 100644 index 4bca8d65d..000000000 --- a/src/submodules/STForceVector/src/STFV_17.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_17(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableVector_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & cbar(:, ips, ipt), & - & test(ipt)%dNTdXt(:, :, term1, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_17 diff --git a/src/submodules/STForceVector/src/STFV_18.inc b/src/submodules/STForceVector/src/STFV_18.inc deleted file mode 100644 index 1e6718d30..000000000 --- a/src/submodules/STForceVector/src/STFV_18.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_18(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_X, DEL_Y, DEL_Z - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableMatrix_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(cbar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & cbar(:, :, ips, ipt), & - & test(ipt)%dNTdXt(:, :, term1, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_18 diff --git a/src/submodules/STForceVector/src/STFV_19.inc b/src/submodules/STForceVector/src/STFV_19.inc deleted file mode 100644 index a25da34d2..000000000 --- a/src/submodules/STForceVector/src/STFV_19.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_19(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_X, DEL_Y, DEL_Z - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableScalar_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_19 diff --git a/src/submodules/STForceVector/src/STFV_2.inc b/src/submodules/STForceVector/src/STFV_2.inc deleted file mode 100644 index 324e24d1b..000000000 --- a/src/submodules/STForceVector/src/STFV_2.inc +++ /dev/null @@ -1,60 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_2(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_NONE - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableScalar_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_2 diff --git a/src/submodules/STForceVector/src/STFV_20.inc b/src/submodules/STForceVector/src/STFV_20.inc deleted file mode 100644 index 9808f017c..000000000 --- a/src/submodules/STForceVector/src/STFV_20.inc +++ /dev/null @@ -1,68 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_20(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_X, DEL_Y, DEL_Z - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & c2bar(:, ips, ipt), & - & test(ipt)%dNTdXt(:, :, term1, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_20 diff --git a/src/submodules/STForceVector/src/STFV_21.inc b/src/submodules/STForceVector/src/STFV_21.inc deleted file mode 100644 index 23b796789..000000000 --- a/src/submodules/STForceVector/src/STFV_21.inc +++ /dev/null @@ -1,68 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_21(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & c2bar(:, :, ips, ipt), & - & test(ipt)%dNTdXt(:, :, term1, ips)) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_21 diff --git a/src/submodules/STForceVector/src/STFV_3.inc b/src/submodules/STForceVector/src/STFV_3.inc deleted file mode 100644 index 76603c036..000000000 --- a/src/submodules/STForceVector/src/STFV_3.inc +++ /dev/null @@ -1,64 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_3(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_NONE - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableVector_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & cbar(:, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_3 diff --git a/src/submodules/STForceVector/src/STFV_4.inc b/src/submodules/STForceVector/src/STFV_4.inc deleted file mode 100644 index 9035f097f..000000000 --- a/src/submodules/STForceVector/src/STFV_4.inc +++ /dev/null @@ -1,64 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_4(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_NONE - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableMatrix_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(cbar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & cbar(:, :, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_4 diff --git a/src/submodules/STForceVector/src/STFV_5.inc b/src/submodules/STForceVector/src/STFV_5.inc deleted file mode 100644 index 297e0089e..000000000 --- a/src/submodules/STForceVector/src/STFV_5.inc +++ /dev/null @@ -1,66 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_5(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_NONE - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableScalar_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_5 diff --git a/src/submodules/STForceVector/src/STFV_6.inc b/src/submodules/STForceVector/src/STFV_6.inc deleted file mode 100644 index 9d1f365b2..000000000 --- a/src/submodules/STForceVector/src/STFV_6.inc +++ /dev/null @@ -1,69 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_6(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_NONE - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableVector_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & c2bar(:, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_6 diff --git a/src/submodules/STForceVector/src/STFV_7.inc b/src/submodules/STForceVector/src/STFV_7.inc deleted file mode 100644 index ed62cd905..000000000 --- a/src/submodules/STForceVector/src/STFV_7.inc +++ /dev/null @@ -1,69 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_7(ans, test, term1, c1, c1rank, c2, c2rank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_NONE - TYPE(FEVariable_), INTENT(IN) :: c1 - TYPE(FEVariable_), INTENT(IN) :: c2 - TYPE(FEVariableScalar_), INTENT(IN) :: c1rank - TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! - CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & c2bar(:, :, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! - END DO - !! - DEALLOCATE (realval, c1bar, c2bar) - !! -END SUBROUTINE STFV_7 diff --git a/src/submodules/STForceVector/src/STFV_8.inc b/src/submodules/STForceVector/src/STFV_8.inc deleted file mode 100644 index dfe340b3f..000000000 --- a/src/submodules/STForceVector/src/STFV_8.inc +++ /dev/null @@ -1,53 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_8(ans, test, term1) - !! intent of dummy variable - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips) - END DO - !! - END DO - !! - DEALLOCATE (realval) - !! -END SUBROUTINE STFV_8 diff --git a/src/submodules/STForceVector/src/STFV_9.inc b/src/submodules/STForceVector/src/STFV_9.inc deleted file mode 100644 index 2ec1de665..000000000 --- a/src/submodules/STForceVector/src/STFV_9.inc +++ /dev/null @@ -1,58 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_9(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableScalar_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_9 diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 deleted file mode 100644 index aced7d296..000000000 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ /dev/null @@ -1,865 +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(STForceVector_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -#include "./STFV_1.inc" -#include "./STFV_2.inc" -#include "./STFV_3.inc" -#include "./STFV_4.inc" -#include "./STFV_5.inc" -#include "./STFV_6.inc" -#include "./STFV_7.inc" - -#include "./STFV_8.inc" -#include "./STFV_9.inc" -#include "./STFV_10.inc" -#include "./STFV_11.inc" -#include "./STFV_12.inc" -#include "./STFV_13.inc" -#include "./STFV_14.inc" - -#include "./STFV_15.inc" -#include "./STFV_16.inc" -#include "./STFV_17.inc" -#include "./STFV_18.inc" -#include "./STFV_19.inc" -#include "./STFV_20.inc" -#include "./STFV_21.inc" - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_1 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * & - & test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval) - !! -END PROCEDURE STForceVector_1 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_2 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * cbar(:, ipt) * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval, cbar) - !! -END PROCEDURE STForceVector_2 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_3 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & cbar(:, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval, cbar) - !! -END PROCEDURE STForceVector_3 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_4 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(cbar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & cbar(:, :, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval, cbar) - !! -END PROCEDURE STForceVector_4 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_5 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval, c1bar, c2bar) - !! -END PROCEDURE STForceVector_5 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_6 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & c2bar(:, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval, c1bar, c2bar) - !! -END PROCEDURE STForceVector_6 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_7 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & c2bar(:, :, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval, c1bar, c2bar) - !! -END PROCEDURE STForceVector_7 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -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 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 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 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 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 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 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 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_15 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * p1(:, :, ips, ipt) - END DO - !! -END DO - !! -DEALLOCATE (realval, p1) - !! -END PROCEDURE STForceVector_15 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_16 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * p1(:, :, ips, ipt) - END DO - !! -END DO - !! -DEALLOCATE (realval, p1, c2bar) - !! - -END PROCEDURE STForceVector_16 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_17 - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & c2bar(:, ips, ipt), & - & p1(:, :, ips, ipt)) - END DO - !! -END DO - !! -DEALLOCATE (realval, p1, c2bar) - !! -END PROCEDURE STForceVector_17 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_18 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD(c2bar(:, :, ips, ipt), p1(:, :, ips, ipt)) - END DO - !! -END DO - !! -DEALLOCATE (realval, p1, c2bar) - !! -END PROCEDURE STForceVector_18 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_19 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) -CALL getInterpolation(obj=test, interpol=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js & - & * test(ipt)%ws & - & * test(ipt)%thickness & - & * c2bar(:, ipt) & - & * c3bar(:, ipt) - !! - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * p1(:, :, ips, ipt) - END DO - !! -END DO - !! -DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_19 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_20 - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) -CALL getInterpolation(obj=test, interpol=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(c3bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD(c3bar(:, ips, ipt), p1(:, :, ips, ipt)) - END DO - !! -END DO - !! -DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_20 - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE STForceVector_21 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) -CALL getInterpolation(obj=test, interpol=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(c3bar, 1), & - & SIZE(c3bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * & - & c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - ans = ans + realval(ips) * OUTERPROD( & - & c3bar(:, :, ips, ipt), & - & p1(:, :, ips, ipt)) - !! - END DO -END DO - !! -DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_21 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/STMassMatrix/CMakeLists.txt b/src/submodules/STMassMatrix/CMakeLists.txt deleted file mode 100644 index b4bb52f6d..000000000 --- a/src/submodules/STMassMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/STMassMatrix_Method@Methods.F90 - ) diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part b/src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part deleted file mode 100755 index 8d7c9598e..000000000 --- a/src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part +++ /dev/null @@ -1,144 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Nov-05-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - STMassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( Row, Col ) -! 2. Allocate Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STMassMatrix_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor_1 ) - ALLOCATE( Constructor_1 % Mat2( row, col ) ) - Constructor_1 % Mat2 = 0.0_DFP - CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( I1, I2, I3, I4 ) -! 2. Allocate Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STMassMatrix_ ), POINTER :: Constructor_2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor_2 ) - ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) - Constructor_2 % Mat4 = 0.0_DFP - CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Contractor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STMassMatrix_ ), POINTER :: Constructor_3 - - ALLOCATE( Constructor_3 ) - - END FUNCTION Constructor_3 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( Row, Col ) -! 2. Allocate Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STMassMatrix_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor1 % Mat2( row, col ) ) - Constructor1 % Mat2 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Allocate Obj % Mat2( I1, I2, I3, I4 ) -! 2. Allocate Obj % SD( NIPS, NIPT ) -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STMassMatrix_ ) :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) - Constructor2 % Mat4 = 0.0_DFP - CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Empty Contractor -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STMassMatrix_ ) :: Constructor3 - - END FUNCTION Constructor3 -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part deleted file mode 100755 index 46e4c0364..000000000 --- a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part +++ /dev/null @@ -1,284 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MassMatrix_15.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space time mass matrix due to linearization of convective term -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getMassMatrix_15 -!------------------------------------------------------------------------------ - -SUBROUTINE getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns mass matrix - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, :, : ) - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), dUdX( :, : ), & - dUdU( :, : ), Mat4( :, :, :, : ), Mat3( :, :, : ) - REAL( DFP ) :: RealVal - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - LOGICAL( LGT ) :: dCdU_Nodal - CLASS( STShapeData_ ), POINTER :: SD - - dCdU_Nodal = .TRUE. - - ! Flag-1 -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_15(), Flag-1", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - a = SIZE( dCdU, 3 ) - b = SIZE( dCdU, 4 ) - -#ifdef DEBUG_VER - IF( a .NE. NNS .AND. a .NE. NIPS ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - & "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & - & "The size of third index of dCdU must be equal to & - & the NNS or NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( b .NE. NNT .AND. b .NE. NIPT ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - & "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & - & "The size of fourth index of dCdU must be equal & - & to the NNT or NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - - IF( tSize .NE. NSD ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & - & "The size of first two indices of dCdU must be & - & equal to the NSD" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - ! Check the type of dCdU - - SELECT CASE( TRIM( dCdU_Type ) ) - -#ifdef DEBUG_VER - CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & - & "Space Nodal Values" ) - dCdU_Nodal = .TRUE. -#endif - CASE( "QuadPoints", "Quad", "Integration", "Integration Points", & - & "IntegrationPoints", "Quad Points") - dCdU_Nodal = .FALSE. - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & - & "dCdU_Type should be either NodalValues or QuadPoints" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP; - - SELECT CASE( Term1 ) - CASE( 1 ) - SELECT CASE( Term2 ) - !( 1, 0 ) - CASE( 0 ) - ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) - DO IPT= 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - IF( dCdU_Nodal ) THEN - CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, & - & Val = dCdU_ ) - ELSE - dCdU_ = dCdU( :, :, IPS, IPT ) - END IF - - ! Compute dUdx - dUdx = SD .dVdXt. U - ! Compute dUdU - dUdU = MATMUL( dUdx, dCdU_ ) - DO a = 1, NNT - Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) - END DO - - DO b = 1, NNT - Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) - END DO - - DO q = 1, NSD - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - DO p = 1, NSD - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) & - & + Mat4 * dUdU( p, q ) - END DO - END DO - END DO - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - & "STMassMatrix_Class.f90", & - & "getMassMatrix_15(), Flag-1", & - & "Unknown value of Term2; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - SELECT CASE( Term2 ) - !( 0, 0 ) - CASE( 0 ) - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - DO IPT= 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - IF( dCdU_Nodal ) THEN - CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, & - & Val = dCdU_ ) - ELSE - dCdU_ = dCdU( :, :, IPS, IPT ) - END IF - - ! Compute dUdx - dUdx = SD .dVdXt. U - ! Compute dUdU - dUdU = MATMUL( dUdx, dCdU_ ) - - Mat2 = OUTERPROD( SD % N, SD % N ) - DO b = 1, NNT - DO a = 1, NNT - Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & - & * SD % T(b) * RealVal ) - END DO - END DO - - DO q = 1, NSD - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - DO p = 1, NSD - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - & Obj % Mat4( r1:r2, c1:c2, :, : ) & - & + Mat4 * dUdU( p, q ) - END DO - END DO - END DO - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - & "STMassMatrix_Class.f90", & - & "getMassMatrix_15(), Flag-1", & - & "Unknown value of Term2; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_15(), Flag-1", & - "Unknown value of Term1; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) - IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) - IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) - -END SUBROUTINE getMassMatrix_15 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part deleted file mode 100755 index fa6f51bc7..000000000 --- a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part +++ /dev/null @@ -1,343 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MassMatrix_16.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getMassMatrix_16 -!------------------------------------------------------------------------------ - -SUBROUTINE getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns mass matrix - ! 2. dCdU( :, :, : ) changes only in space - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, : ) - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), dUdX( :, : ), & - dUdU( :, : ), Mat4( :, :, :, : ), Mat3( :, :, : ) - REAL( DFP ) :: RealVal - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - LOGICAL( LGT ) :: dCdU_Nodal - - CLASS( STShapeData_ ), POINTER :: SD - - dCdU_Nodal = .TRUE. - - ! Flag-1 -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - a = SIZE( dCdU, 3 ) - -#ifdef DEBUG_VER - IF( a .NE. NNS .AND. a .NE. NIPS ) THEN - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & - "The size of third index of dCdU must be equal to the NNS or NIPS" & - ) - Error_Flag = .TRUE. - RETURN - - END IF - - IF( tSize .NE. NSD ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - ! Check the type of dCdU - - SELECT CASE( TRIM( dCdU_Type ) ) - -#ifdef DEBUG_VER - CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & - "Space Nodal Values" ) - dCdU_Nodal = .TRUE. -#endif - - CASE( "QuadPoints", "Quad", "Integration", "Integration Points", & - "IntegrationPoints", "Quad Points") - dCdU_Nodal = .FALSE. - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & - "dCdU_Type should be either NodalValues or QuadPoints" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP; - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - IF( dCdU_Nodal ) THEN - - CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) -#ifdef DEBUG_VER - CALL Check_Error( "STMassMatrix_Class.f90>>getMassMatrix_16()", & - "CALL SD % getInterpolationOfScalar( SpaceNodalValues = dCdU, Val = dCdU_ )" ) -#endif - ELSE - - dCdU_ = dCdU( :, :, IPS ) - - END IF - - ! Compute dUdx - dUdx = SD .dVdXt. U - - ! Compute dUdU - dUdU = MATMUL( dUdx, dCdU_ ) - - - DO a = 1, NNT - - Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) - - END DO - - DO b = 1, NNT - - Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) - - END DO - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4 * dUdU( p, q ) - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - - !( 0, 0 ) - CASE( 0 ) - - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - IF( dCdU_Nodal ) THEN - - CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) -#ifdef DEBUG_VER - CALL Check_Error( "STMassMatrix_Class.f90>>getMassMatrix_16()", & - "CALL SD % getInterpolationOfScalar( SpaceNodalValues = dCdU, Val = dCdU_ )" ) -#endif - ELSE - - dCdU_ = dCdU( :, :, IPS ) - - END IF - - ! Compute dUdx - dUdx = SD .dVdXt. U; - - ! Compute dUdU - dUdU = MATMUL( dUdx, dCdU_ ) - - Mat2 = OUTERPROD( SD % N, SD % N ) - - DO b = 1, NNT - DO a = 1, NNT - - Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & - * SD % T(b) * RealVal ) - - END DO - - END DO - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4 * dUdU( p, q ) - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "Unknown value of Term1; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) - IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) - IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) - - -END SUBROUTINE getMassMatrix_16 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part deleted file mode 100755 index 5df87703b..000000000 --- a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part +++ /dev/null @@ -1,305 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MassMatrix_17.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getMassMatrix_17 -!------------------------------------------------------------------------------ - -SUBROUTINE getMassMatrix_17( Obj, U, dCdU, Term1, Term2, dCdU_Type ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns mass matrix - ! 2. dCdU( :, : ) does not changes in space and time - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, : ) - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q, tSize - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dUdX( :, : ), & - dUdU( :, : ), Mat4( :, :, :, : ), & - Mat3( :, :, : ) - REAL( DFP ) :: RealVal - - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - LOGICAL( LGT ) :: dCdU_Nodal - - CLASS( STShapeData_ ), POINTER :: SD - - dCdU_Nodal = .TRUE. - - ! Flag-1 -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - ! Make Indx - tSize = SIZE( dCdU, 1 ) - -#ifdef DEBUG_VER - IF( tSize .NE. NSD ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & - "The size of first two indices of dCdU must be equal to the NSD" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - ALLOCATE( Indx( NSD, 2 ) ) - ! - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - ! Check the type of dCdU - - SELECT CASE( TRIM( dCdU_Type ) ) - -#ifdef DEBUG_VER - CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & - "Space Nodal Values" ) - - dCdU_Nodal = .TRUE. -#endif - - CASE( "QuadPoints", "Quad", "Integration", "Integration Points", & - "IntegrationPoints", "Quad Points") - - dCdU_Nodal = .FALSE. - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & - "dCdU_Type should be either NodalValues or QuadPoints" & - ) - Error_Flag = .TRUE. - RETURN -#endif - - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP; - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - ! Compute dUdx - dUdx = SD .dVdXt. U - - ! Compute dUdU - dUdU = MATMUL( dUdx, dCdU ) - - - DO a = 1, NNT - - Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) - - END DO - - DO b = 1, NNT - - Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) - - END DO - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4 * dUdU( p, q ) - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - - !( 0, 0 ) - CASE( 0 ) - - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - ! Compute dUdx - dUdx = SD .dVdXt. U; - - ! Compute dUdU - dUdU = MATMUL( dUdx, dCdU ) - - Mat2 = OUTERPROD( SD % N, SD % N ) - - DO b = 1, NNT - DO a = 1, NNT - - Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & - * SD % T(b) * RealVal ) - - END DO - - END DO - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4 * dUdU( p, q ) - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_16(), Flag-1", & - "Unknown value of Term1; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) - IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) - -END SUBROUTINE getMassMatrix_17 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part deleted file mode 100755 index 7335bf1be..000000000 --- a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part +++ /dev/null @@ -1,241 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MassMatrix_18.part -! Last Update : Feb-09-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space Interpolation of scalar and vector -! -! HOSTING FILE -! - MassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getMassMatrix_18 -!------------------------------------------------------------------------------ - -SUBROUTINE getMassMatrix_18( Obj, U, Term1, Term2 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns mass matrix - ! 2. dCdU( :, : ) does not changes in space and time - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), INTENT( IN ) :: U( :, :, : ) - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & - a, b, r1, r2, c1, c2, p, q - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dUdX( :, : ), & - Mat4( :, :, :, : ), Mat3( :, :, : ) - REAL( DFP ) :: RealVal - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_18(), Flag-1", & - "STMassMatrix_ Object is not Initiated" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - ALLOCATE( Indx( NSD, 2 ) ) - - DO p = 1, NSD - Indx( p, 1 ) = ( p - 1 ) * NNS + 1 - Indx( p, 2 ) = p * NNS - END DO - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP; - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 0 ) - CASE( 0 ) - - ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - ! Compute dUdx - dUdx = SD .dVdXt. U - - DO a = 1, NNT - - Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) - - END DO - - DO b = 1, NNT - - Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) - - END DO - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4 * dUdX( p, q ) - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_18(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" & - ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - - !( 0, 0 ) - CASE( 0 ) - - ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) - - DO IPT= 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness - - ! Compute dUdx - dUdx = SD .dVdXt. U; - - Mat2 = OUTERPROD( SD % N, SD % N ) - - DO b = 1, NNT - DO a = 1, NNT - - Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & - * SD % T(b) * RealVal ) - - END DO - - END DO - - DO q = 1, NSD - - c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) - - DO p = 1, NSD - - r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) - - Obj % Mat4( r1:r2, c1:c2, :, : ) = & - Obj % Mat4( r1:r2, c1:c2, :, : ) & - + Mat4 * dUdX( p, q ) - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - - CASE DEFAULT - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_18(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_18(), Flag-1", & - "Unknown value of Term1; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) - IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) - IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) - -END SUBROUTINE getMassMatrix_18 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part deleted file mode 100755 index 2dc5e87f5..000000000 --- a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part +++ /dev/null @@ -1,236 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: MassMatrix_3.part -! Last Update : Nov-16-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STMassMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getMassMatrix_3 -!------------------------------------------------------------------------------ - -SUBROUTINE getMassMatrix_3( Obj, rho, Term1, Term2 ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns mass matrix; rho is a vector - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), INTENT( IN ) :: rho( : ) - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, b - REAL( DFP ) :: RealVal1, RealVal, RhoBar - REAL( DFP ), ALLOCATABLE :: Mat2( :, : ) - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg("STMassMatrix_Class.f90", & - "getMassMatrix_3(), Flag-1", & - "STMassMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = SIZE( Obj % SD( 1,1 ) % N ) - NNT = SIZE( Obj % SD( 1,1 ) % T ) - NIPS = SIZE( Obj % SD, 1 ) - NIPT = SIZE( Obj % SD, 2 ) - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - SELECT CASE( Term1 ) - - CASE( 1 ) - - SELECT CASE( Term2 ) - - !( 1, 1 ) - CASE( 1 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - CALL SD % getInterpolationOfScalar( RhoBar, rho ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar - - DO b = 1, NNT - - DO a = 1, NNT - - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) + & - OUTERPROD( a = SD % dNTdt( :, a ), b = SD % dNTdt( :, b ) ) * RealVal - - END DO - - END DO - - END DO - - END DO - - !( 1, 0 ) - CASE( 0 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - CALL SD % getInterpolationOfScalar( RhoBar, rho ) -#ifdef DEBUG_VER - CALL Check_Error("STMassMatrix_Class.f90 >> getMassMatrix_3()", & - "CALL SD % getInterpolationOfScalar( RhoBar, rho )" ) -#endif - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar - - DO a = 1, NNT - - Mat2 = OUTERPROD( a = SD % dNTdt( :, a ), b = SD % N ) - - DO b = 1, NNT - - RealVal = SD % T( b ) * RealVal1 - - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & - + Mat2 * RealVal - - END DO - - END DO - - END DO - - END DO - -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_3(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CASE( 0 ) - - SELECT CASE( Term2 ) - !( 0, 1 ) - CASE( 1 ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - CALL SD % getInterpolationOfScalar( RhoBar, rho ) -#ifdef DEBUG_VER - CALL Check_Error("STMassMatrix_Class.f90 >> getMassMatrix_3()", & - "CALL SD % getInterpolationOfScalar( RhoBar, rho )" ) -#endif - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar - - DO b = 1, NNT - - Mat2 = OUTERPROD( a = SD % N, b = SD % dNTdt( :, b ) ) - - DO a = 1, NNT - - RealVal = SD % T( a ) * RealVal1 - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & - + Mat2 * RealVal - - END DO - - END DO - - END DO - - END DO - - !( 0, 0 ) - CASE( 0 ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - CALL SD % getInterpolationOfScalar( RhoBar, rho ) -#ifdef DEBUG_VER - CALL Check_Error("STMassMatrix_Class.f90 >> getMassMatrix_3()", & - "CALL SD % getInterpolationOfScalar( RhoBar, rho )" ) -#endif - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar - Mat2 = OUTERPROD( a = SD % N, b = SD % N ) - - DO b = 1, NNT - DO a = 1, NNT - RealVal = SD % T( a ) * SD % T( b ) * RealVal1 - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & - + Mat2 * RealVal - END DO - END DO - END DO - END DO -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_3(), Flag-1", & - "Unknown value of Term2; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT -#ifdef DEBUG_VER - CASE DEFAULT - CALL Err_Msg( & - "STMassMatrix_Class.f90", & - "getMassMatrix_3(), Flag-1", & - "Unknown value of Term1; It should be 1 or 0" ) - Error_Flag = .TRUE. - RETURN -#endif - END SELECT - - CALL Obj % Mat2FromMat4( ) - NULLIFY( SD ) - ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) - -END SUBROUTINE getMassMatrix_3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md b/src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md deleted file mode 100755 index 27b84843b..000000000 --- a/src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md +++ /dev/null @@ -1,596 +0,0 @@ -# Space Time Mass Matrix - -## ToDo - -## Description - -The mass matrix in case of space-time finite element involves time derivative. The following four forms are possible. - -## Structure - -1. Term1 = 0, and Term2 = 0 implies following form - -$$\int_{Q_n}{N^I T_a N^J T_b}\ d\Omega dt$$ - -2. Term1 = 1, and Term2 = 0 implies following form - -$$\int_{Q_n} \frac{\partial N^I T_a}{\partial t} {N^J T_b}\ d\Omega dt$$ - -3. Term1 = 0, and Term2 = 1 implies following form - -$$\int_{Q_n} {N^I T_a} \frac{\partial N^J T_b}{\partial t} \ d\Omega dt$$ - -4. Term1 = 1, and Term2 = 1 implies following form - -$$\int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial t} \ d\Omega dt$$ - -## Getting Started - -### Making the object - -Using the `STMassMatrix()` - -```fortran -Obj = STMassMatrix( ) -Obj = STMassMatrix( Row, Col, NIPS, NIPT ) -Obj = STMassMatrix( I1, I2, I3, I4, NIPS, NIPT ) -``` - -Using the `STMassMatrix_Pointer()` - -```fortran -Obj => STMassMatrix_Pointer( ) -Obj => STMassMatrix_Pointer( Row, Col, NIPS, NIPT ) -Obj => STMassMatrix_Pointer( I1, I2, I3, I4, NIPS, NIPT ) -``` - -### Getting the mass matrix - -We can compute the following matrices - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right): = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} -$$ - -using the following fortran command - -```fortran -CALL Obj % getMassMatrix( Term1, Term2 ) -``` - -The following loop has been implemented to compute these matrices - -- For **(1,1)** following loop have been implemented - -```fortran -DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho - - DO b = 1, NNT - - DO a = 1, NNT - - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) + & - OUTERPROD( a = SD % dNTdt( :, a ), b = SD % dNTdt( :, b ) ) * RealVal - - END DO - - END DO - - END DO - -END DO -``` - -- For **(1,0)** following loop have been implemented - -```fortran -DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho - - DO a = 1, NNT - - Mat2 = OUTERPROD( a = SD % dNTdt( :, a ), b = SD % N ) - - DO b = 1, NNT - - RealVal = SD % T( b ) * RealVal1 - - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & - + Mat2 * RealVal - - END DO - - END DO - - END DO - -END DO -``` - -- For **(0,1)** following loop have been implemented - -```fortran -DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho - - DO b = 1, NNT - - Mat2 = OUTERPROD( a = SD % N, b = SD % dNTdt( :, b ) ) - - DO a = 1, NNT - - RealVal = SD % T( a ) * RealVal1 - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & - + Mat2 * RealVal - - END DO - - END DO - - END DO - -END DO -``` - -- For **(0,0)** following loop have been implmented - -```fortran -DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho - Mat2 = OUTERPROD( a = SD % N, b = SD % N ) - - DO b = 1, NNT - - DO a = 1, NNT - - RealVal = SD % T( a ) * SD % T( b ) * RealVal1 - Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & - + Mat2 * RealVal - - END DO - - END DO - - END DO - -END DO -``` - ---- - -The space-time mass matrices - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right): = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST} ^{ii} \left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST}^{ii} \left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -can be computed using the following fortran command. - -```fortran -CALL Obj % getMassMatrix( Term1, Term2, nCopy ) -``` - -We can compute the following space-time mass matrices - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right): = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho(\mathbf{x},t) {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho(\mathbf{x},t) {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho(\mathbf{x},t) \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} -$$ - -$$ -\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho(\mathbf{x},t) \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} -$$ - - -```fortran -CALL Obj % getMassMatrix( rho, Term1, Term2 ) -``` - -In above case `rho` can be Rank-0, Rank-1, Rank-2. - -- `rho`, Rank-0, denotes the constant value of $\rho$ in both space and time -- `rho(:)`, Rank-1, denotes the space nodal values; $\rho := \rho(\mathbf{x})$ changes only in space -- `rho(:,:)`, Rank-2, denotes the space-time nodal values; $\rho := \rho(\mathbf{x}, t)$ changes in both space and time. - -If the $\rho$ is defined on the integration points then we can use the following command. - -```fortran -CALL Obj % getMassMatrix( rho, Term1, Term2, rhoType ) -``` - -In the above case, `rhoType` can be `"NodalValues"` or `"QuadPoints"`. In this case, we `rho` can be Rank-0, Rank-1, Rank-2. - -We can compute the following matrices - -$$ -\mathop {{{\bf{M}}^{ii}}}\limits_{ST} \left( {I,J,a,b} \right): = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho ({\bf{x}},t){N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho ({\bf{x}},t){N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho ({\bf{x}},t)\frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho ({\bf{x}},t)\frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} -$$ - -the above intergrals can be computed using the following fortran command. - -```fortran -CALL Obj % getMassMatrix( rho, Term1, Term2, nCopy ) -``` - -If $\rho$ is defined on integral points then we can use following fortran command. - -In the above case, `rho` can be Rank-0, Rank-1, Rank-2. - -```fortran -CALL Obj % getMassMatrix( rho, Term1, Term2, RhoType, nCopy ) -``` - -In the above case, `rho` can be Rank-0, Rank-1, Rank-2. - -We can compute the following matrices - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{pq}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_r}}}\frac{{\partial {c_r}}}{{\partial {u_q}}}} d\Omega dt} \right]\Delta {}^b{u_{qJ}} -$$ - -using the foloowing fortran command - -```fortran -CALL Obj % getMassMatrix( U, dCdU, 0, 0, dCdU_Type) -``` - -- In the above call `dCdU` denotes the jacobian matrix for the mapping from $u \rightarrow c$ and it can be given by Rank-2, Rank-3, Rank-4. -- `dCdU_Type` can be `NodalValues` or `QuadPoints`. -- If $\frac{\partial c}{\partial u}$ changes in space and time then we must represent it using Rank-4 array. -- If $\frac{\partial c}{\partial u}$ changes only in space, and remains contant in time then we must represent it using Rank-3 array. -- If $\frac{\partial c}{\partial u}$ does not change in space and time then we must represent it using Rank-2 array. -- `U` is a space-time nodal values of velocity, and it is represented by Rank-3 array. - -We can compute the following matrices - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{pq}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_r}}}\frac{{\partial {c_r}}}{{\partial {u_q}}}} d\Omega dt} \right]\Delta {}^b{u_{qJ}} -$$ - -using the foloowing fortran command - -```fortran -CALL Obj % getMassMatrix( U, dCdU, 1, 0, dCdU_Type) -``` - -- In the above call `dCdU` denotes the jacobian matrix for the mapping from $u \rightarrow c$ and it can be given by Rank-2, Rank-3, Rank-4. -- `dCdU_Type` can be `NodalValues` or `QuadPoints`. -- If $\frac{\partial c}{\partial u}$ changes in space and time then we must represent it using Rank-4 array. -- If $\frac{\partial c}{\partial u}$ changes only in space, and remains contant in time then we must represent it using Rank-3 array. -- If $\frac{\partial c}{\partial u}$ does not change in space and time then we must represent it using Rank-2 array. -- `U` is a space-time nodal values of velocity, and it is represented by Rank-3 array. - -In case of _Naviar-Stokes_ equation or _Burgers_ Equation the jacobian $\frac{\partial c_p}{\partial u_q}$ is identity (i.e. $c(\mathbf{x},t) = u(\mathbf{x},t)$) in such case we get following matrices - -$$ -{\mathop {\bf{M}}\limits_{ST} ^{pq}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_q}}}} d\Omega dt} \right]\Delta {}^b{u_{qJ}} -$$ - -the above matrix can be computed using following fortran command. - -```fortran -CALL Obj % getMassMatrix( U, 0, 0 ) -``` - -In case of _Naviar-Stokes_ equation or _Burgers_ Equation the jacobian $\frac{\partial c_p}{\partial u_q}$ is identity (i.e. $c(\mathbf{x},t) = u(\mathbf{x},t)$) in such case we get following matrices - -$$ -\mathop {\bf{M}}\limits_{ST}^{pq} \left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_q}}}} d\Omega dt} \right]{\Delta ^b}{u_{qJ}} -$$ - -The above matrix can be computed using following fortran command. - -```fortran -CALL Obj % getMassMatrix( U, 1, 0 ) -``` - -## Methods - -### _Constructor1()_ - -INTERFACE - -```fortran - FUNCTION Constructor1( Row, Col, NIPS, NIPT ) - - CLASS( STMassMatrix_ ), POINTER :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - ALLOCATE( Constructor1 ) - ALLOCATE( Constructor1 % Mat2( row, col ) ) - Constructor1 % Mat2 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) -END FUNCTION Constructor1 -``` - -DESCRIPTION - This function allocated `Obj % Mat2`, and also allocated `Obj % SD`. - -### _Constructor2()_ - -INTERFACE - -```fortran - FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) - - CLASS( STMassMatrix_ ), POINTER :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - ALLOCATE( Constructor2 ) - ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) - Constructor2 % Mat4 = 0.0_DFP - CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - END FUNCTION Constructor2 -``` - -DESCRIPTION - This function allocated `Obj % Mat4`, and also allocated `Obj % SD`. - - -### _getMassMatrix\_1()_ - -INTERFACE - -```fortran -SUBROUTINE getMassMatrix_1( Obj, rho, Term1, Term2 ) - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -This subroutine computes the mass matrix. `rho` is constant in this case which can be used as a scale. - -### _getMassMatrix\_2()_ - -INTERFACE - -```fortran - SUBROUTINE getMassMatrix_2( Obj, Term1, Term2 ) - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -In this case `rho` $\rho$ is absent. - -### _getMAssMatrix\_3()_ - -INTERFACE - -```fortran - SUBROUTINE getMassMatrix_3( Obj, rho, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -In this case `rho` $\rho$ is a vector, i.e. it is the spatial nodal values of scalar variable `rho`. In this case, `rho` $rho$ does not change with time, but only varies in space. - -### _getMAssMatrix\_4()_ - -INTERFACE - -```fortran -SUBROUTINE getMassMatrix_4( Obj, rho, Term1, Term2 ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 -``` - -DESCRIPTION - -In this case `rho` $\rho$ is a two dimensional array, i.e. it is the space-time nodal values of scalar variable `rho`. The first index of `rho` denotes the spatial node, and second index of `rho` denotes the temporal node. In this case, `rho` $rho$ changes in both space and time domain. - -### _getMAssMatrix\_5()_ - -INTERFACE - -```fortran - SUBROUTINE getMassMatrix_5( Obj, rho, Term1, Term2, rhoType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: RhoType -``` - -DESCRIPTION - -In this case `rho` $\rho$ is a two dimensional array. If `rhotype` is `[Integration Points, IntegrationPoints, Quad Points, QuadPoints, Quad]` then it is defined at space-time integation points. In this case the number of rows in `rho` must be equal to `NIPS` and number of columns in `rho` must be equal to the `NIPT`. The first index of `rho` denotes the spatial integation point, and second index of `rho` denotes the temporal integration points. In this case, `rho` $rho$ changes in both space and time domain. This method will be useful in forming the *stabilized* matrices. If `rhotype` is `[Nodal, Nodal Values, NodalValues, STNodalValues]` then `rho` is defined at space-time nodal values and the methods call the `getMassMatrix_4()` for computation. - -### _getMassMatrix\_6()_ - -INTERFACE - -```fortran - SUBROUTINE getMassMatrix_6( Obj, rho, Term1, Term2, rhoType ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 - CHARACTER( LEN = * ), INTENT( IN ) :: RhoType -``` - -DESCRIPTION - -In this case `rho` $\rho$ is a one dimensional array. If `rhotype` is `[Integration Points, IntegrationPoints, Quad Points, QuadPoints, Quad]` then it is defined at space integation points. In this case the size of `rho` must be equal to `NIPS`. The elements of `rho` denotes the spatial integation pointIn this case, `rho` $rho$ changes in only in space, and not in time domain. This method will be useful in forming the *stabilized* matrices. If `rhotype` is `[Nodal, Nodal Values, NodalValues, STNodalValues]` then `rho` is defined at space nodal values and the methods call the `getMassMatrix_3()` for computation. - -### _getMassMatrix\_7()_ - -INTERFACE - -```fortran - SUBROUTINE getMassMatrix_7( Obj, rho, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: nCopy, Term1, Term2 -``` - -DESCRIPTION - -In this case `rho` $\rho$ is a real scalar. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** - -### _getMassMatrix\_8()_ - -INTERFACE - -```fortran - SUBROUTINE getMassMatrix_8( Obj, Term1, Term2, nCopy ) - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - INTEGER( I4B ), INTENT( IN ) :: nCopy, Term1, Term2 -``` - -DESCRIPTION - -In this case `rho` is absent. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** - -### _getMassMatrix\_9()_ - -INTERFACE - -```fortran - SUBROUTINE getMassMatrix_9( Obj, rho, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy -``` - -DESCRIPTION - -In this case `rho` is a vector, and represent the spatial nodal values. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** - -### _getMassMatrix\_10()_ - -INTERFACE - -```fortran -SUBROUTINE getMassMatrix_10( Obj, rho, Term1, Term2, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy -``` - -DESCRIPTION - -In this case `rho` is a 2D array, and represent the space-time nodal values. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** - -### _getMassMatrix\_11()_ - -INTERFACE - -```fortran -SUBROUTINE getMassMatrix_11( Obj, rho, Term1, Term2, rhoType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: RhoType -``` - -DESCRIPTION - -In this case `rho` is a 2D array, and can represent the space-time nodal values, or space-time integation point values. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** - -### _getMassMatrix\_12()_ - -INTERFACE - -```fortran -SUBROUTINE getMassMatrix_12( Obj, rho, Term1, Term2, rhoType, nCopy ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho - INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy - CHARACTER( LEN = * ), INTENT( IN ) :: RhoType -``` - -DESCRIPTION - -In this case `rho` is a vector, and can represent the space-nodal values or space-integration value. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** diff --git a/src/submodules/STMassMatrix/src/STMM_1.inc b/src/submodules/STMassMatrix/src/STMM_1.inc deleted file mode 100644 index 78b3c1818..000000000 --- a/src/submodules/STMassMatrix/src/STMM_1.inc +++ /dev/null @@ -1,57 +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 _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) - -PURE SUBROUTINE STMM_1(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER( I4B ) :: ips, ipt - !! - !! main - !! - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - !! - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE(IaJb, realval) - !! -END SUBROUTINE STMM_1 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_10.inc b/src/submodules/STMassMatrix/src/STMM_10.inc deleted file mode 100644 index 5fcce6471..000000000 --- a/src/submodules/STMassMatrix/src/STMM_10.inc +++ /dev/null @@ -1,80 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) -REAL(DFP), ALLOCATABLE :: vbar(:, :, :) -REAL(DFP), ALLOCATABLE :: Jij(:, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6,3), SIZE(m6,4), & - & SIZE(test(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD( trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -!! -DEALLOCATE (m6, IJija, vbar, Jij, realval) -!! -!END SUBROUTINE STMM_10a diff --git a/src/submodules/STMassMatrix/src/STMM_10a.inc b/src/submodules/STMassMatrix/src/STMM_10a.inc deleted file mode 100644 index 0979a4ad1..000000000 --- a/src/submodules/STMassMatrix/src/STMM_10a.inc +++ /dev/null @@ -1,32 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) -#include "./STMM_10.inc" -END SUBROUTINE STMM_10a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_10b.inc b/src/submodules/STMassMatrix/src/STMM_10b.inc deleted file mode 100644 index f11b6859a..000000000 --- a/src/submodules/STMassMatrix/src/STMM_10b.inc +++ /dev/null @@ -1,32 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_10b(ans, test, trial, term1, term2, rho) -#include "./STMM_10.inc" -END SUBROUTINE STMM_10b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_10c.inc b/src/submodules/STMassMatrix/src/STMM_10c.inc deleted file mode 100644 index 8ae76e2d0..000000000 --- a/src/submodules/STMassMatrix/src/STMM_10c.inc +++ /dev/null @@ -1,32 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_10c(ans, test, trial, term1, term2, rho) -#include "./STMM_10.inc" -END SUBROUTINE STMM_10c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_10d.inc b/src/submodules/STMassMatrix/src/STMM_10d.inc deleted file mode 100644 index 48a4c4925..000000000 --- a/src/submodules/STMassMatrix/src/STMM_10d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_10d(ans, test, trial, term1, term2, rho) -#include "./STMM_10.inc" -END SUBROUTINE STMM_10d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11.inc b/src/submodules/STMassMatrix/src/STMM_11.inc deleted file mode 100644 index dd37d0b9d..000000000 --- a/src/submodules/STMassMatrix/src/STMM_11.inc +++ /dev/null @@ -1,79 +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 - -! 11a, 11b, 11c -! ij = outerprod(vbar(:,ips, ipt), [1.0_DFP]) -! ij = diag(vbar(:,ips, ipt)) -! ij = outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, ij, vbar, realval) - !! -!END SUBROUTINE STMM_11a diff --git a/src/submodules/STMassMatrix/src/STMM_11a.inc b/src/submodules/STMassMatrix/src/STMM_11a.inc deleted file mode 100644 index 378e06b24..000000000 --- a/src/submodules/STMassMatrix/src/STMM_11a.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho) -#include "./STMM_11.inc" -END SUBROUTINE STMM_11a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11b.inc b/src/submodules/STMassMatrix/src/STMM_11b.inc deleted file mode 100644 index 3f5a41f50..000000000 --- a/src/submodules/STMassMatrix/src/STMM_11b.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_11b(ans, test, trial, term1, term2, rho) -#include "./STMM_11.inc" -END SUBROUTINE STMM_11b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11c.inc b/src/submodules/STMassMatrix/src/STMM_11c.inc deleted file mode 100644 index 828532a8e..000000000 --- a/src/submodules/STMassMatrix/src/STMM_11c.inc +++ /dev/null @@ -1,31 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_11c(ans, test, trial, term1, term2, rho) -#include "./STMM_11.inc" -END SUBROUTINE STMM_11c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11d.inc b/src/submodules/STMassMatrix/src/STMM_11d.inc deleted file mode 100644 index f2324013d..000000000 --- a/src/submodules/STMassMatrix/src/STMM_11d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_11d(ans, test, trial, term1, term2, rho) -#include "./STMM_11.inc" -END SUBROUTINE STMM_11d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12.inc b/src/submodules/STMassMatrix/src/STMM_12.inc deleted file mode 100644 index fae4e434d..000000000 --- a/src/submodules/STMassMatrix/src/STMM_12.inc +++ /dev/null @@ -1,77 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_t -CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: vbar(:, :, :) -REAL(DFP), ALLOCATABLE :: ij(:, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:,a, ips), & - & trial(ipt)%dNTdt(:,b, ips), & - & ij ) - END DO - END DO - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, ij, vbar, realval) -!! -!END SUBROUTINE STMM_12c diff --git a/src/submodules/STMassMatrix/src/STMM_12a.inc b/src/submodules/STMassMatrix/src/STMM_12a.inc deleted file mode 100644 index 81e82b880..000000000 --- a/src/submodules/STMassMatrix/src/STMM_12a.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_12a(ans, test, trial, term1, term2, rho) -#include "./STMM_12.inc" -END SUBROUTINE STMM_12a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12b.inc b/src/submodules/STMassMatrix/src/STMM_12b.inc deleted file mode 100644 index 8257c7e17..000000000 --- a/src/submodules/STMassMatrix/src/STMM_12b.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_12b(ans, test, trial, term1, term2, rho) -#include "./STMM_12.inc" -END SUBROUTINE STMM_12b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12c.inc b/src/submodules/STMassMatrix/src/STMM_12c.inc deleted file mode 100644 index c525ec0fc..000000000 --- a/src/submodules/STMassMatrix/src/STMM_12c.inc +++ /dev/null @@ -1,31 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho) -#include "./STMM_12.inc" -END SUBROUTINE STMM_12c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12d.inc b/src/submodules/STMassMatrix/src/STMM_12d.inc deleted file mode 100644 index e09ea6718..000000000 --- a/src/submodules/STMassMatrix/src/STMM_12d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_12d(ans, test, trial, term1, term2, rho) -#include "./STMM_12.inc" -END SUBROUTINE STMM_12d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_13.inc b/src/submodules/STMassMatrix/src/STMM_13.inc deleted file mode 100644 index f5b9512b2..000000000 --- a/src/submodules/STMassMatrix/src/STMM_13.inc +++ /dev/null @@ -1,69 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_13(ans, test, trial, term1, term2, rho) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_none -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: rho -!! matrix -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=kbar, val=rho) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), SIZE(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval( ips ) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & kbar(:,:,ips, ipt) , & - & test(ipt)%T, & - & trial(ipt)%T) - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, kbar, realval) -!! -END SUBROUTINE STMM_13 diff --git a/src/submodules/STMassMatrix/src/STMM_14.inc b/src/submodules/STMassMatrix/src/STMM_14.inc deleted file mode 100644 index 93e435df6..000000000 --- a/src/submodules/STMassMatrix/src/STMM_14.inc +++ /dev/null @@ -1,79 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -PURE SUBROUTINE STMM_14(ans, test, trial, term1, term2, rho) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: rho -!! matrix -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: Jij(:, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=kbar, val=rho) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), SIZE(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6,3), SIZE(m6,4), & - & SIZE(test(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD( trial(ipt)%N(:, ips), kbar(:,:,ips,ipt) ) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -!! -DEALLOCATE (m6, IJija, kbar, Jij, realval) - !! -END SUBROUTINE STMM_14 diff --git a/src/submodules/STMassMatrix/src/STMM_15.inc b/src/submodules/STMassMatrix/src/STMM_15.inc deleted file mode 100644 index a3cca6c48..000000000 --- a/src/submodules/STMassMatrix/src/STMM_15.inc +++ /dev/null @@ -1,71 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), SIZE(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6,6) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:,ips), & - & trial(ipt)%dNTdt(:,b,ips), & - & kbar(:,:,ips, ipt), test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, kbar, realval) - !! -END SUBROUTINE STMM_15 diff --git a/src/submodules/STMassMatrix/src/STMM_16.inc b/src/submodules/STMassMatrix/src/STMM_16.inc deleted file mode 100644 index f2f7934f4..000000000 --- a/src/submodules/STMassMatrix/src/STMM_16.inc +++ /dev/null @@ -1,74 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_16(ans, test, trial, term1, term2, rho) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_t -CLASS(FEVariable_), INTENT(IN) :: rho -!! matrix -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=kbar, val=rho) - -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), size(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:,a, ips), & - & trial(ipt)%dNTdt(:,b, ips), & - & kbar(:,:,ips, ipt) ) - END DO - END DO - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, kbar, realval) - !! -END SUBROUTINE STMM_16 diff --git a/src/submodules/STMassMatrix/src/STMM_17.inc b/src/submodules/STMassMatrix/src/STMM_17.inc deleted file mode 100644 index 4afc80018..000000000 --- a/src/submodules/STMassMatrix/src/STMM_17.inc +++ /dev/null @@ -1,24 +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 _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) -PURE SUBROUTINE STMM_17(ans, test, trial, term1, term2, c1, c2, opt) -#include "./STMM_17_20.inc" -END SUBROUTINE STMM_17 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_17_20.inc b/src/submodules/STMassMatrix/src/STMM_17_20.inc deleted file mode 100644 index 79fa78f10..000000000 --- a/src/submodules/STMassMatrix/src/STMM_17_20.inc +++ /dev/null @@ -1,65 +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 -! - -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_none -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! scalar -INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) -REAL(DFP), ALLOCATABLE :: m2(:, :) -REAL(DFP), ALLOCATABLE :: m2b(:, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips -!! -!! 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=m2, val=c1) -CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * & - & trial(ipt)%thickness * trial(ipt)%wt * & - & trial(ipt)%jt * m2(:, ipt) * m2b(:,ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) * OUTERPROD( _NT1_, _NT2_ ) - END DO - !! -END DO -!! -CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) -!! -IF(PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) -!! -DEALLOCATE (IaJb, m2, m2b, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_18.inc b/src/submodules/STMassMatrix/src/STMM_18.inc deleted file mode 100644 index 1407d84b2..000000000 --- a/src/submodules/STMassMatrix/src/STMM_18.inc +++ /dev/null @@ -1,24 +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 _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) -PURE SUBROUTINE STMM_18(ans, test, trial, term1, term2, c1, c2, opt) -#include "./STMM_17_20.inc" -END SUBROUTINE STMM_18 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_19.inc b/src/submodules/STMassMatrix/src/STMM_19.inc deleted file mode 100644 index 9296ef514..000000000 --- a/src/submodules/STMassMatrix/src/STMM_19.inc +++ /dev/null @@ -1,24 +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 _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) -PURE SUBROUTINE STMM_19(ans, test, trial, term1, term2, c1, c2, opt) -#include "./STMM_17_20.inc" -END SUBROUTINE STMM_19 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_2.inc b/src/submodules/STMassMatrix/src/STMM_2.inc deleted file mode 100644 index d84cddf82..000000000 --- a/src/submodules/STMassMatrix/src/STMM_2.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 -! - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) - -PURE SUBROUTINE STMM_2(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER( I4B ) :: ips, ipt - !! - !! main - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE(iajb, realval) - !! -END SUBROUTINE STMM_2 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_20.inc b/src/submodules/STMassMatrix/src/STMM_20.inc deleted file mode 100644 index 0ec551b6e..000000000 --- a/src/submodules/STMassMatrix/src/STMM_20.inc +++ /dev/null @@ -1,24 +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 _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) -PURE SUBROUTINE STMM_20(ans, test, trial, term1, term2, c1, c2, opt) -#include "./STMM_17_20.inc" -END SUBROUTINE STMM_20 -#undef _NT1_ -#undef _NT2_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21.inc b/src/submodules/STMassMatrix/src/STMM_21.inc deleted file mode 100644 index 7d80f5c6f..000000000 --- a/src/submodules/STMassMatrix/src/STMM_21.inc +++ /dev/null @@ -1,70 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_none -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: vbar(:, :, :) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval( ips ) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, vbar, c1bar, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_21a.inc b/src/submodules/STMassMatrix/src/STMM_21a.inc deleted file mode 100644 index 68df5ffea..000000000 --- a/src/submodules/STMassMatrix/src/STMM_21a.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_21a(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_21.inc" -END SUBROUTINE STMM_21a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21b.inc b/src/submodules/STMassMatrix/src/STMM_21b.inc deleted file mode 100644 index 54d57e74c..000000000 --- a/src/submodules/STMassMatrix/src/STMM_21b.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_21b(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_21.inc" -END SUBROUTINE STMM_21b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21c.inc b/src/submodules/STMassMatrix/src/STMM_21c.inc deleted file mode 100644 index 68f1b8758..000000000 --- a/src/submodules/STMassMatrix/src/STMM_21c.inc +++ /dev/null @@ -1,31 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_21c(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_21.inc" -END SUBROUTINE STMM_21c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21d.inc b/src/submodules/STMassMatrix/src/STMM_21d.inc deleted file mode 100644 index e0f1d53c9..000000000 --- a/src/submodules/STMassMatrix/src/STMM_21d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_21d(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_21.inc" -END SUBROUTINE STMM_21d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22.inc b/src/submodules/STMassMatrix/src/STMM_22.inc deleted file mode 100644 index 8b90d56fd..000000000 --- a/src/submodules/STMassMatrix/src/STMM_22.inc +++ /dev/null @@ -1,81 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: vbar(:, :, :) -REAL(DFP), ALLOCATABLE :: Jij(:, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6,3), SIZE(m6,4), & - & SIZE(test(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD( trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -!! -DEALLOCATE (m6, IJija, vbar, Jij, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_22a.inc b/src/submodules/STMassMatrix/src/STMM_22a.inc deleted file mode 100644 index 4d6212951..000000000 --- a/src/submodules/STMassMatrix/src/STMM_22a.inc +++ /dev/null @@ -1,32 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_22a(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_22.inc" -END SUBROUTINE STMM_22a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22b.inc b/src/submodules/STMassMatrix/src/STMM_22b.inc deleted file mode 100644 index 09dc7ccb2..000000000 --- a/src/submodules/STMassMatrix/src/STMM_22b.inc +++ /dev/null @@ -1,32 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_22b(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_22.inc" -END SUBROUTINE STMM_22b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22c.inc b/src/submodules/STMassMatrix/src/STMM_22c.inc deleted file mode 100644 index d552c33f2..000000000 --- a/src/submodules/STMassMatrix/src/STMM_22c.inc +++ /dev/null @@ -1,32 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_22c(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_22.inc" -END SUBROUTINE STMM_22c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22d.inc b/src/submodules/STMassMatrix/src/STMM_22d.inc deleted file mode 100644 index af54f9ece..000000000 --- a/src/submodules/STMassMatrix/src/STMM_22d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_22d(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_22.inc" -END SUBROUTINE STMM_22d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23.inc b/src/submodules/STMassMatrix/src/STMM_23.inc deleted file mode 100644 index 392086dc1..000000000 --- a/src/submodules/STMassMatrix/src/STMM_23.inc +++ /dev/null @@ -1,80 +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 - -! 11a, 11b, 11c -! ij = outerprod(vbar(:,ips, ipt), [1.0_DFP]) -! ij = diag(vbar(:,ips, ipt)) -! ij = outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_none -INTEGER(I4B), INTENT(IN) :: term2 -!! del_t -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: vbar(:, :, :) -REAL(DFP), ALLOCATABLE :: ij(:, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -!! -DEALLOCATE (m6, ij, c1bar, vbar, realval) \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23a.inc b/src/submodules/STMassMatrix/src/STMM_23a.inc deleted file mode 100644 index fc06e9bb3..000000000 --- a/src/submodules/STMassMatrix/src/STMM_23a.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_23a(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_23.inc" -END SUBROUTINE STMM_23a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23b.inc b/src/submodules/STMassMatrix/src/STMM_23b.inc deleted file mode 100644 index 95334e747..000000000 --- a/src/submodules/STMassMatrix/src/STMM_23b.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_23b(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_23.inc" -END SUBROUTINE STMM_23b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23c.inc b/src/submodules/STMassMatrix/src/STMM_23c.inc deleted file mode 100644 index 1a82dcb1a..000000000 --- a/src/submodules/STMassMatrix/src/STMM_23c.inc +++ /dev/null @@ -1,31 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_23c(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_23.inc" -END SUBROUTINE STMM_23c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23d.inc b/src/submodules/STMassMatrix/src/STMM_23d.inc deleted file mode 100644 index 36f29346e..000000000 --- a/src/submodules/STMassMatrix/src/STMM_23d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_23d(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_23.inc" -END SUBROUTINE STMM_23d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24.inc b/src/submodules/STMassMatrix/src/STMM_24.inc deleted file mode 100644 index 864486652..000000000 --- a/src/submodules/STMassMatrix/src/STMM_24.inc +++ /dev/null @@ -1,77 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_t -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: vbar(:, :, :) -REAL(DFP), ALLOCATABLE :: ij(:, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar( :, ipt ) - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:,a, ips), & - & trial(ipt)%dNTdt(:,b, ips), & - & ij ) - END DO - END DO - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, ij, vbar, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_24a.inc b/src/submodules/STMassMatrix/src/STMM_24a.inc deleted file mode 100644 index a558659e5..000000000 --- a/src/submodules/STMassMatrix/src/STMM_24a.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_24a(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24b.inc b/src/submodules/STMassMatrix/src/STMM_24b.inc deleted file mode 100644 index 4bd8e0aac..000000000 --- a/src/submodules/STMassMatrix/src/STMM_24b.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_24b(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24c.inc b/src/submodules/STMassMatrix/src/STMM_24c.inc deleted file mode 100644 index 9bf563a93..000000000 --- a/src/submodules/STMassMatrix/src/STMM_24c.inc +++ /dev/null @@ -1,31 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_24c(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24d.inc b/src/submodules/STMassMatrix/src/STMM_24d.inc deleted file mode 100644 index edce1b039..000000000 --- a/src/submodules/STMassMatrix/src/STMM_24d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_24d(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_25.inc b/src/submodules/STMassMatrix/src/STMM_25.inc deleted file mode 100644 index 5c3c7a257..000000000 --- a/src/submodules/STMassMatrix/src/STMM_25.inc +++ /dev/null @@ -1,73 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_25(ans, test, trial, term1, term2, c1, c2) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_none -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! matrix -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=kbar, val=c2) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), SIZE(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar( :, ipt ) - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval( ips ) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & kbar(:,:,ips, ipt) , & - & test(ipt)%T, & - & trial(ipt)%T) - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, kbar, c1bar, realval) -!! -END SUBROUTINE STMM_25 diff --git a/src/submodules/STMassMatrix/src/STMM_26.inc b/src/submodules/STMassMatrix/src/STMM_26.inc deleted file mode 100644 index cfff28b2b..000000000 --- a/src/submodules/STMassMatrix/src/STMM_26.inc +++ /dev/null @@ -1,84 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_26(ans, test, trial, term1, term2, c1, c2) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! matrix -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: Jij(:, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=kbar, val=c2) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), SIZE(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6,3), SIZE(m6,4), & - & SIZE(test(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD( trial(ipt)%N(:, ips), kbar(:,:,ips,ipt) ) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -!! -DEALLOCATE (m6, IJija, kbar, Jij, realval) - !! -END SUBROUTINE STMM_26 diff --git a/src/submodules/STMassMatrix/src/STMM_27.inc b/src/submodules/STMassMatrix/src/STMM_27.inc deleted file mode 100644 index 5e54e6983..000000000 --- a/src/submodules/STMassMatrix/src/STMM_27.inc +++ /dev/null @@ -1,75 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: c1 - !! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), SIZE(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6,6) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:,ips), & - & trial(ipt)%dNTdt(:,b,ips), & - & kbar(:,:,ips, ipt), test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, kbar, c1bar, realval) - !! -END SUBROUTINE STMM_27 diff --git a/src/submodules/STMassMatrix/src/STMM_28.inc b/src/submodules/STMassMatrix/src/STMM_28.inc deleted file mode 100644 index 6bd0c9393..000000000 --- a/src/submodules/STMassMatrix/src/STMM_28.inc +++ /dev/null @@ -1,77 +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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_28(ans, test, trial, term1, term2, c1, c2) -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_t -INTEGER(I4B), INTENT(IN) :: term2 -!! del_t -CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar -CLASS(FEVariable_), INTENT(IN) :: c2 -!! matrix -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=kbar, val=c2) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar,1), size(kbar,2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:,a, ips), & - & trial(ipt)%dNTdt(:,b, ips), & - & kbar(:,:,ips, ipt) ) - END DO - END DO - !! - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, kbar, c1bar, realval) - !! -END SUBROUTINE STMM_28 diff --git a/src/submodules/STMassMatrix/src/STMM_3.inc b/src/submodules/STMassMatrix/src/STMM_3.inc deleted file mode 100644 index ad25c2b4e..000000000 --- a/src/submodules/STMassMatrix/src/STMM_3.inc +++ /dev/null @@ -1,57 +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 _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) - -PURE SUBROUTINE STMM_3(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER( I4B ) :: ips, ipt - !! - !! main - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE(iajb, realval) - !! -END SUBROUTINE STMM_3 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_4.inc b/src/submodules/STMassMatrix/src/STMM_4.inc deleted file mode 100644 index 9d24d98f2..000000000 --- a/src/submodules/STMassMatrix/src/STMM_4.inc +++ /dev/null @@ -1,57 +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 _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) - -PURE SUBROUTINE STMM_4(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! main - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE(iajb, realval) - !! -END SUBROUTINE STMM_4 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_5.inc b/src/submodules/STMassMatrix/src/STMM_5.inc deleted file mode 100644 index b536a0c53..000000000 --- a/src/submodules/STMassMatrix/src/STMM_5.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 -! - -#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) - -PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, rhobar, realval) - !! -END SUBROUTINE STMM_5 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_6.inc b/src/submodules/STMassMatrix/src/STMM_6.inc deleted file mode 100644 index 9424215c7..000000000 --- a/src/submodules/STMassMatrix/src/STMM_6.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 -! - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) - -PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, realval) - !! -END SUBROUTINE STMM_6 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_7.inc b/src/submodules/STMassMatrix/src/STMM_7.inc deleted file mode 100644 index 8474fde1e..000000000 --- a/src/submodules/STMassMatrix/src/STMM_7.inc +++ /dev/null @@ -1,66 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) - -PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - IF(present(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, rhobar, realval) - !! -END SUBROUTINE STMM_7 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_8.inc b/src/submodules/STMassMatrix/src/STMM_8.inc deleted file mode 100644 index 326e32b62..000000000 --- a/src/submodules/STMassMatrix/src/STMM_8.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 -! - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) - -PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, rhobar, realval) - !! -END SUBROUTINE STMM_8 -#undef _NT1_ -#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_9.inc b/src/submodules/STMassMatrix/src/STMM_9.inc deleted file mode 100644 index 9d6980288..000000000 --- a/src/submodules/STMassMatrix/src/STMM_9.inc +++ /dev/null @@ -1,67 +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 -! - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) -CLASS(STElemshapeData_), INTENT(IN) :: test(:) -CLASS(STElemshapeData_), INTENT(IN) :: trial(:) -INTEGER(I4B), INTENT(IN) :: term1 -!! del_none -INTEGER(I4B), INTENT(IN) :: term2 -!! del_none -CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable -REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) -REAL(DFP), ALLOCATABLE :: vbar(:, :, :) -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! -CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! -CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! -DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval( ips ) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO -END DO -!! -CALL Convert(from=m6, to=ans) -DEALLOCATE (m6, vbar, realval) -!! diff --git a/src/submodules/STMassMatrix/src/STMM_9a.inc b/src/submodules/STMassMatrix/src/STMM_9a.inc deleted file mode 100644 index 73c430e5f..000000000 --- a/src/submodules/STMassMatrix/src/STMM_9a.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_9a(ans, test, trial, term1, term2, rho) -#include "./STMM_9.inc" -END SUBROUTINE STMM_9a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ diff --git a/src/submodules/STMassMatrix/src/STMM_9b.inc b/src/submodules/STMassMatrix/src/STMM_9b.inc deleted file mode 100644 index f33bfbf85..000000000 --- a/src/submodules/STMassMatrix/src/STMM_9b.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_9b(ans, test, trial, term1, term2, rho) -#include "./STMM_9.inc" -END SUBROUTINE STMM_9b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_9c.inc b/src/submodules/STMassMatrix/src/STMM_9c.inc deleted file mode 100644 index 591c35093..000000000 --- a/src/submodules/STMassMatrix/src/STMM_9c.inc +++ /dev/null @@ -1,31 +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 _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_9c(ans, test, trial, term1, term2, rho) -#include "./STMM_9.inc" -END SUBROUTINE STMM_9c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ diff --git a/src/submodules/STMassMatrix/src/STMM_9d.inc b/src/submodules/STMassMatrix/src/STMM_9d.inc deleted file mode 100644 index e29329c72..000000000 --- a/src/submodules/STMassMatrix/src/STMM_9d.inc +++ /dev/null @@ -1,31 +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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_9d(ans, test, trial, term1, term2, rho) -#include "./STMM_9.inc" -END SUBROUTINE STMM_9d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 b/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 deleted file mode 100644 index 78aa30ae6..000000000 --- a/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 +++ /dev/null @@ -1,3653 +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(STMassMatrix_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_1(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - - !! Internal variable - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips, ipt - - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) * OUTERPROD( & - & OUTERPROD(test(ipt)%N(:, ips), test(ipt)%T), & - & OUTERPROD(trial(ipt)%N(:, ips), trial(ipt)%T)) - END DO - END DO - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - DEALLOCATE (IaJb, realval) - -END SUBROUTINE STMM_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_2(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips, ipt - - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD( & - & test(ipt)%dNTdt(:, :, ips), & - & OUTERPROD(trial(ipt)%N(:, ips), trial(ipt)%T)) - END DO - END DO - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - DEALLOCATE (iajb, realval) - -END SUBROUTINE STMM_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_3(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips, ipt - - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD( & - & OUTERPROD(test(ipt)%N(:, ips), test(ipt)%T), & - & trial(ipt)%dNTdt(:, :, ips)) - END DO - END DO - - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - - DEALLOCATE (iajb, realval) - -END SUBROUTINE STMM_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) - -PURE SUBROUTINE STMM_4(ans, test, trial, term1, term2, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_t - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! main - !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, realval) - !! -END SUBROUTINE STMM_4 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) - -PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, rhobar, realval) - !! -END SUBROUTINE STMM_5 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) - -PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, realval) - !! -END SUBROUTINE STMM_6 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) - -PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, rhobar, realval) - !! -END SUBROUTINE STMM_7 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) - -PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_none - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips - !! - !! 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=rhobar, val=rho) - !! - DO ipt = 1, SIZE(trial) - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) - DO ips = 1, SIZE(realval) - iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - END DO - !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) - !! - DEALLOCATE (iajb, rhobar, realval) - !! -END SUBROUTINE STMM_8 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_9a(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, realval) -!! -END SUBROUTINE STMM_9a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_9b(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, realval) -!! -END SUBROUTINE STMM_9b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_9c(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, realval) -!! -END SUBROUTINE STMM_9c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_9d(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, realval) -!! -END SUBROUTINE STMM_9d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -!! -!END SUBROUTINE STMM_10a -END SUBROUTINE STMM_10a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_10b(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -!! -!END SUBROUTINE STMM_10a -END SUBROUTINE STMM_10b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_10c(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -!! -!END SUBROUTINE STMM_10a -END SUBROUTINE STMM_10c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_10d(ans, test, trial, term1, term2, rho) -!PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -!! -!END SUBROUTINE STMM_10a -END SUBROUTINE STMM_10d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, ij, vbar, realval) - !! -END SUBROUTINE STMM_11a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_11b(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, ij, vbar, realval) -END SUBROUTINE STMM_11b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_11c(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, ij, vbar, realval) - !! -!END SUBROUTINE STMM_11a -END SUBROUTINE STMM_11c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_11d(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, ij, vbar, realval) - !! -END SUBROUTINE STMM_11d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_12a(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij) - END DO - END DO - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, ij, vbar, realval) -END SUBROUTINE STMM_12a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_12b(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij) - END DO - END DO - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, ij, vbar, realval) -END SUBROUTINE STMM_12b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij) - END DO - END DO - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, ij, vbar, realval) -END SUBROUTINE STMM_12c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_12d(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: rho -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij) - END DO - END DO - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, ij, vbar, realval) -END SUBROUTINE STMM_12d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_13(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! matrix -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & kbar(:, :, ips, ipt), & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, kbar, realval) -!! -END SUBROUTINE STMM_13 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -PURE SUBROUTINE STMM_14(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: rho -!! matrix -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), kbar(:, :, ips, ipt)) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, kbar, Jij, realval) - !! -END SUBROUTINE STMM_14 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & kbar(:, :, ips, ipt), test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, kbar, realval) - !! -END SUBROUTINE STMM_15 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_16(ans, test, trial, term1, term2, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: rho -!! matrix -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) - -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & kbar(:, :, ips, ipt)) - END DO - END DO - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, kbar, realval) - !! -END SUBROUTINE STMM_16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) -PURE SUBROUTINE STMM_17(ans, test, trial, term1, term2, c1, c2, opt) - - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: m2b(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips -!! -!! 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=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * & - & trial(ipt)%thickness * trial(ipt)%wt * & - & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - !! - END DO -!! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) -!! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) -!! - DEALLOCATE (IaJb, m2, m2b, realval) -END SUBROUTINE STMM_17 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) -PURE SUBROUTINE STMM_18(ans, test, trial, term1, term2, c1, c2, opt) - - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: m2b(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips -!! -!! 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=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * & - & trial(ipt)%thickness * trial(ipt)%wt * & - & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - !! - END DO -!! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) -!! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) -!! - DEALLOCATE (IaJb, m2, m2b, realval) -END SUBROUTINE STMM_18 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) -PURE SUBROUTINE STMM_19(ans, test, trial, term1, term2, c1, c2, opt) - - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: m2b(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips -!! -!! 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=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * & - & trial(ipt)%thickness * trial(ipt)%wt * & - & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - !! - END DO -!! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) -!! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) -!! - DEALLOCATE (IaJb, m2, m2b, realval) -END SUBROUTINE STMM_19 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _NT1_ test(ipt)%dNTdt(:,:,ips) -#define _NT2_ trial(ipt)%dNTdt(:,:,ips) -PURE SUBROUTINE STMM_20(ans, test, trial, term1, term2, c1, c2, opt) - - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! scalar - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: m2b(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips -!! -!! 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=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * & - & trial(ipt)%thickness * trial(ipt)%wt * & - & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) - !! - DO ips = 1, SIZE(realval) - IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) - END DO - !! - END DO -!! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) -!! - IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) -!! - DEALLOCATE (IaJb, m2, m2b, realval) -END SUBROUTINE STMM_20 -#undef _NT1_ -#undef _NT2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_21a(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, c1bar, realval) -END SUBROUTINE STMM_21a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_21b(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, c1bar, realval) -END SUBROUTINE STMM_21b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_21c(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, c1bar, realval) -END SUBROUTINE STMM_21c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_21d(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & _KIJ_, & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, vbar, c1bar, realval) -END SUBROUTINE STMM_21d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_22a(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -END SUBROUTINE STMM_22a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_22b(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -END SUBROUTINE STMM_22b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_22c(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -END SUBROUTINE STMM_22c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_22d(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, vbar, Jij, realval) -END SUBROUTINE STMM_22d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_23a(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, ij, c1bar, vbar, realval) -END SUBROUTINE STMM_23a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_23b(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, ij, c1bar, vbar, realval) -END SUBROUTINE STMM_23b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_23c(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, ij, c1bar, vbar, realval) -END SUBROUTINE STMM_23c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_23d(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! vector -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :, :) - REAL(DFP), ALLOCATABLE :: ij(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & _DIM1_, _DIM2_, & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - ij = _KIJ_ - !! - DO b = 1, SIZE(trial(1)%T) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & ij, test(ipt)%T) - END DO - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, ij, c1bar, vbar, realval) -END SUBROUTINE STMM_23d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ 1 - -PURE SUBROUTINE STMM_24a(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24a - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) -#define _DIM1_ 1 -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_24b(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24b - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ diag(vbar(:,ips, ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_24c(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24c - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) -#define _DIM1_ SIZE(vbar, 1) -#define _DIM2_ SIZE(vbar, 1) - -PURE SUBROUTINE STMM_24d(ans, test, trial, term1, term2, c1, c2) -#include "./STMM_24.inc" -END SUBROUTINE STMM_24d - -#undef _DIM1_ -#undef _DIM2_ -#undef _KIJ_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_25(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_none - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! matrix -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - m6 = m6 + realval(ips) * outerprod( & - & outerprod(test(ipt)%N(:, ips), & - & trial(ipt)%N(:, ips)), & - & kbar(:, :, ips, ipt), & - & test(ipt)%T, & - & trial(ipt)%T) - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, kbar, c1bar, realval) -!! -END SUBROUTINE STMM_25 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_26(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_none - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! matrix -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: Jij(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - CALL Reallocate(IJija, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(m6, 3), SIZE(m6, 4), & - & SIZE(test(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - Jij = OUTERPROD(trial(ipt)%N(:, ips), kbar(:, :, ips, ipt)) - !! - DO a = 1, SIZE(m6, 5) - IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) - END DO - !! - m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) -!! - DEALLOCATE (m6, IJija, kbar, Jij, realval) - !! -END SUBROUTINE STMM_26 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! del_none - INTEGER(I4B), INTENT(IN) :: term2 - !! del_t - CLASS(FEVariable_), INTENT(IN) :: c1 - !! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 - !! vector - !! - !! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) - !! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) - !! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%N(:, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & kbar(:, :, ips, ipt), test(ipt)%T) - END DO - END DO - END DO - !! - CALL Convert(from=m6, to=ans) - !! - DEALLOCATE (m6, kbar, c1bar, realval) - !! -END SUBROUTINE STMM_27 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STMM_28(ans, test, trial, term1, term2, c1, c2) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CLASS(STElemshapeData_), INTENT(IN) :: trial(:) - INTEGER(I4B), INTENT(IN) :: term1 -!! del_t - INTEGER(I4B), INTENT(IN) :: term2 -!! del_t - CLASS(FEVariable_), INTENT(IN) :: c1 -!! scalar - CLASS(FEVariable_), INTENT(IN) :: c2 -!! matrix -!! -!! Internal variable - REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ipt, ips, a, b -!! -!! main -!! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) -!! - CALL Reallocate(m6, & - & SIZE(test(1)%N, 1), & - & SIZE(trial(1)%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2), & - & SIZE(test(1)%T), & - & SIZE(trial(1)%T)) -!! - DO ipt = 1, SIZE(trial) - !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & - & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - DO b = 1, SIZE(m6, 6) - DO a = 1, SIZE(m6, 5) - m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & - & + realval(ips) & - & * outerprod( & - & test(ipt)%dNTdt(:, a, ips), & - & trial(ipt)%dNTdt(:, b, ips), & - & kbar(:, :, ips, ipt)) - END DO - END DO - !! - END DO - END DO -!! - CALL Convert(from=m6, to=ans) - DEALLOCATE (m6, kbar, c1bar, realval) - !! -END SUBROUTINE STMM_28 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MakeDiagonalCopiesIJab(ans, ncopy) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) - INTEGER(I4B), INTENT(IN) :: ncopy - !! - REAL(DFP), ALLOCATABLE :: m2(:, :), m4(:, :, :, :) - INTEGER(I4B) :: a, b - !! - m4 = ans - !! - CALL Reallocate(ans, & - & ncopy * SIZE(m4, 1), & - & ncopy * SIZE(m4, 2), & - & SIZE(m4, 3), & - & SIZE(m4, 4)) - !! - DO b = 1, SIZE(m4, 4) - DO a = 1, SIZE(m4, 3) - CALL MakeDiagonalCopies(from=m4(:, :, a, b), to=m2, ncopy=ncopy) - ans(:, :, a, b) = m2 - END DO - END DO - !! - DEALLOCATE (m2, m4) -END SUBROUTINE MakeDiagonalCopiesIJab - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STMassMatrix_1 -SELECT CASE (term1) - !! - !! - !! - !! -CASE (del_t) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! del_t - !! del_t - CALL STMM_4(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - CASE (del_none) - !! del_t - !! del_none - CALL STMM_2(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - END SELECT - !! - !! - !! - !! -CASE (del_none) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! del_none - !! del_t - CALL STMM_3(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - CASE (del_none) - !! del_none - !! del_none - CALL STMM_1(ans=ans, test=test, trial=trial, term1=term1, & - & term2=term2, opt=opt) - !! - END SELECT -END SELECT - !! -END PROCEDURE mat4_STMassMatrix_1 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STMassMatrix_2 - !! -SELECT CASE (term1) - !! - !! - !! - !! -CASE (del_t) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! del_t - !! del_t - !! - CALL STMM_8(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2, opt=opt) - !! - CASE (del_none) - !! - !! del_t - !! del_none - !! - CALL STMM_6(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2, opt=opt) - !! - END SELECT - !! - !! - !! - !! -CASE (del_none) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! del_none - !! del_t - !! - CALL STMM_7(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2, opt=opt) - !! - CASE (del_none) - !! - !! del_none - !! del_none - !! - CALL STMM_5(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2, opt=opt) - !! - END SELECT -END SELECT - !! -END PROCEDURE mat4_STMassMatrix_2 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STMassMatrix_3 - !! - !! main - !! -SELECT CASE (term1) - !! - !! - !! - !! -CASE (del_t) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! del_t - !! del_t - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_12a(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_12b(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_12c(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_12d(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - END SELECT - !! - CASE (del_none) - !! - !! del_t - !! del_none - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_10a(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_10b(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_10c(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_10d(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - END SELECT - !! - END SELECT - !! - !! - !! - !! -CASE (del_none) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! del_none - !! del_t - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_11a(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_11b(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_11c(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_11d(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - END SELECT - !! - CASE (del_none) - !! - !! del_none - !! del_none - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_9a(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_9b(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_9c(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_9d(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - END SELECT - !! - END SELECT -END SELECT - !! -END PROCEDURE mat4_STMassMatrix_3 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STMassMatrix_4 - !! - !! main - !! -SELECT CASE (term1) - !! - !! - !! - !! -CASE (del_t) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! del_t - !! del_t - !! - CALL STMM_16(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - !! - CASE (del_none) - !! - !! del_t, - !! del_none - !! - CALL STMM_14(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - !! - END SELECT - !! - !! - !! - !! -CASE (del_none) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! del_none, - !! del_t - !! - CALL STMM_15(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - !! - CASE (del_none) - !! - !! del_none, - !! del_none, - !! - CALL STMM_13(ans=ans, test=test, trial=trial, rho=rho, & - & term1=term1, term2=term2) - !! - END SELECT -END SELECT -END PROCEDURE mat4_STMassMatrix_4 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STMassMatrix_5 -SELECT CASE (term1) - !! - !! - !! - !! -CASE (del_t) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! scalar - !! scalar - !! del_t - !! del_t - !! - CALL STMM_20(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2, opt=opt) - !! - CASE (del_none) - !! - !! scalar - !! scalar - !! del_t - !! del_none - !! - CALL STMM_18(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2, opt=opt) - !! - END SELECT - !! -CASE (del_none) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! scalar - !! scalar - !! del_none - !! del_t - !! - CALL STMM_19(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2, opt=opt) - !! - CASE (del_none) - !! - !! scalar - !! scalar - !! del_none - !! del_none - !! - CALL STMM_17(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2, opt=opt) - !! - END SELECT -END SELECT - !! -END PROCEDURE mat4_STMassMatrix_5 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STMassMatrix_6 - !! -SELECT CASE (term1) - !! - !! - !! - !! -CASE (del_t) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! scalar - !! vector - !! del_t - !! del_t - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_24a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_24b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_24c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_24d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - END SELECT - !! - CASE (del_none) - !! - !! scalar - !! vector - !! del_t - !! del_none - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_22a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_22b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_22c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_22d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - END SELECT - !! - END SELECT - !! - !! - !! - !! -CASE (del_none) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! scalar - !! vector - !! del_none - !! del_t - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_23a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_23b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_23c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_23d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - END SELECT - !! - CASE (del_none) - !! - !! scalar - !! vector - !! del_none - !! del_none - !! - SELECT CASE (opt) - CASE (1) - CALL STMM_21a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (2) - CALL STMM_21b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (3) - CALL STMM_21c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - CASE (4) - CALL STMM_21d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - END SELECT - !! - END SELECT -END SELECT - !! -END PROCEDURE mat4_STMassMatrix_6 - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat4_STMassMatrix_7 -SELECT CASE (term1) - !! - !! - !! - !! -CASE (del_t) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! scalar - !! matrix - !! del_t - !! del_t - !! - CALL STMM_28(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - !! - CASE (del_none) - !! - !! scalar - !! matrix - !! del_t - !! del_none - !! - CALL STMM_26(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - !! - END SELECT - !! -CASE (del_none) - !! - SELECT CASE (term2) - !! - CASE (del_t) - !! - !! scalar - !! matrix - !! del_none - !! del_t - !! - CALL STMM_27(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - !! - CASE (del_none) - !! - !! scalar - !! matrix - !! del_none - !! del_none - !! - CALL STMM_25(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & - & term1=term1, term2=term2) - !! - END SELECT -END SELECT -END PROCEDURE mat4_STMassMatrix_7 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/STStiffnessMatrix/Constructor.part b/src/submodules/STStiffnessMatrix/Constructor.part deleted file mode 100755 index 088f03b8e..000000000 --- a/src/submodules/STStiffnessMatrix/Constructor.part +++ /dev/null @@ -1,142 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construct the STStiffnessMatrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STStiffnessMatrix_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor_1 ) - - ALLOCATE( Constructor_1 % Mat2( row, col ) ) - - Constructor_1 % Mat2 = 0.0_DFP - - CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construct the STStiffnessMatrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STStiffnessMatrix_ ), POINTER :: Constructor_2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor_2 ) - - ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) - - Constructor_2 % Mat4 = 0.0_DFP - - CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor_3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construct the STStiffnessMatrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( STStiffnessMatrix_ ), POINTER :: Constructor_3 - ALLOCATE( Constructor_3 ) - END FUNCTION Constructor_3 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor1( Row, Col, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construct the STStiffnessMatrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STStiffnessMatrix_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT - - ALLOCATE( Constructor1 % Mat2( row, col ) ) - Constructor1 % Mat2 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construct the STStiffnessMatrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STStiffnessMatrix_ ) :: Constructor2 - INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT - - ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) - Constructor2 % Mat4 = 0.0_DFP - CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! Constructor3 -!------------------------------------------------------------------------------ - - FUNCTION Constructor3( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construct the STStiffnessMatrix -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( STStiffnessMatrix_ ) :: Constructor3 - - END FUNCTION Constructor3 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md b/src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md deleted file mode 100755 index 777b05c6c..000000000 --- a/src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md +++ /dev/null @@ -1,421 +0,0 @@ -# Space Time Stiffness Matrix Class - -## Description - -## Getting Started - -### Making the Object - -`STStiffnessMatrix_` object is child of `STElemShapeData_` class. This class is designed for _solid mechanics_ applications. The object of this class can be initiated using following commands. - -Calling the inherited method `initiate` - -```fortran -CALL STElemSD % Initiate( NIPS = NIPS, NIPT = NIPT) -CALL STElemSD % InitiateMatrix( row= row, col = col) -CALL STElemSD % InitiateMatrix( I1 = I1, I2 = I2, I3 = I3, I4= I4) -``` - -We can use the `STStiffnessMatrix_Pointer()` function, which returns the pointer to the object - -```fortran -CLASS( STELemShapeData_ ), POINTER :: STElemSD - -STElemSD => STStiffnessMatrix_Pointer( ) -STElemSD => STStiffnessMatrix_Pointer( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) -STElemSD => STStiffnessMatrix_Pointer( I1, I2, I3, I4, I5, NIPS, NIPT) -``` - -We can also use the function `STStiffnessMatrix()` function, which returns the object - -```fortran -STElemSD = STStiffnessMatrix( ) -STElemSD = STStiffnessMatrix( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) -STElemSD = STStiffnessMatrix( I1, I2, I3, I4, I5, NIPS, NIPT) -``` - -### Getting the Stiffness Matrix - -We have devided the Stiffness matrix into three basic categories. See the next section Theory for the explanation. - -```fortran -CALL Obj % getStiffnessMatrix( Cijkl ) -``` - -In above case Cijkl is a fortran array. It can be Rank-4, Rank-3, Rank-2. - -```fortran -CALL Obj % getStiffnessMatrix( CData ) -``` - -In above case `CData` is `ConstitutiveData_` object. It can be Rank-2, Rank-1 or Rank-0. - -```fortran -CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) -``` - -In above case Cijkl is a fortran array. It can be Rank-4, Rank-3, Rank-2. Inaddition, TimeVec is a length-2 rank-0 fortran array. It contains the starting and ending time i.e. t1, and t2. `IntegrationSide` is the character. It can be `Left`, `Right`, `Both`, or `NA`. See the Next section for more details - -```fortran -CALL Obj % getStiffnessMatrix( CData, TimeVector, IntegrationSide ) -``` - -In above case `CData` is `ConstitutiveData_` object. It can be Rank-2, Rank-1 or Rank-0. Inaddition, TimeVec is a length-2 rank-0 fortran array. It contains the starting and ending time i.e. t1, and t2. `IntegrationSide` is the character. It can be `Left`, `Right`, `Both`, or `NA`. See the Next section for more details. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -## Theory - -Very often we need to compute the following matrices in solid-mechanics applications. - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ - -Note here, $u \in R^{nsd}$. Generally, `Cijkl` has minor symmetry. - -$$C_{ijkl} = C_{jikl}$$ -$$C_{ijkl} = C_{ijlk}$$ - -The shape of ${}^{4}Mat(:, :, a, b)$ will be `(NSD*NNS, NSD*NNS)`. It will be a block matrix, and shape of each block will be `(NNS, NNS)`. For more details see the notes (_page 55_) - - -> These tasks are performed by following methods; `getStiffnessMatrix_1()`, `getStiffnessMatrix_2()`, and `getStiffnessMatrix_3()` - - -## Methods - -### getStiffnessMatrix_1() - -INTERFACE - -```fortran - SUBROUTINE getStiffnessMatrix_1( Obj, Cijkl ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl -``` - -DESCRIPTION - -- This methods computes the Stiffness matrix. -- `Cijkl(:,:,:,:)` is a four dimensional array of shape `(M,M,NIPS, NIPT)`. In two dimensional case it `M` should be either 3 or 4. In case of three dimensional it should be 6. See _page 55_ in the notes for maore details. In this case Cijkl may change in space and time domain. The third index denotes the spatial integration point and fourth index denotes the temporal integration points. - -CODE SNIPPET - -```fortran -CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat4 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) -ALLOCATE( DummyMat4( 3, 3, NIPS, NIPT ) ) -DummyMat4 = 0.0_DFP; DummyMat4( 1,1, :, : ) = 1.0_DFP; -DummyMat4( 2,2, :, : ) = 1.0_DFP; DummyMat4( 3,3, :, : ) = 1.0_DFP - -CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat4 ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getStiffnessMatrix_1( Cijkl = DummyMat4 )' -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getStiffnessMatrix_1( Cijkl = DummyMat4 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 - 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 - 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` -> Note that in this case integrad is quadratic in time, therefore we need atleast 2 integration points in the time. This condition may change when the mesh is moving. Note that the row sum and column sum is zero as expected. - -### getStiffnessMatrix_2() - -INTERFACE - -```fortran - SUBROUTINE getStiffnessMatrix_2( Obj, Cijkl ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Cijkl -``` - -DESCRIPTION - -- This methods computes the Stiffness matrix. -- `Cijkl(:,:,:)` is a three dimensional array of shape `(M,M,NIPS)`. In two dimensional case it `M` should be either 3 or 4. In case of three dimensional it should be 6. See _page 55_ in the notes for more details. In this case, Cijkl changes only in space, and remains constant in time domain. The third index, denotes the spatial integration point. - -CODE SNIPPET - -```fortran -CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat3 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( 3, 3, NIPS ) ) -DummyMat3 = 0.0_DFP; DummyMat3( 1,1, : ) = 1.0_DFP; -DummyMat3( 2,2, : ) = 1.0_DFP; DummyMat3( 3,3, : ) = 1.0_DFP - -CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat3 ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getStiffnessMatrix_2( Cijkl = DummyMat3 )' -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getStiffnessMatrix_2( Cijkl = DummyMat3 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 - 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 - 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` - -### getStiffnessMatrix_3() - -INTERFACE - -```fortran - SUBROUTINE getStiffnessMatrix_3( Obj, Cijkl ) - - USE Utility, ONLY : OUTERPROD - - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Cijkl -``` - -DESCRIPTION - -- This methods computes the Stiffness matrix. -- `Cijkl(:,:)` is a three dimensional array of shape `(M,M)`. In two dimensional case it `M` should be either 3 or 4. In case of three dimensional it should be 6. See _page 55_ in the notes for more details. In this case, Cijkl does not change in both space and time. - -CODE SNIPPET - -```fortran -CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat2 ) -``` - -SYMBOLIC CALCULATION - -$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( 3, 3 ) ) -DummyMat2 = 0.0_DFP; DummyMat2( 1,1 ) = 1.0_DFP; -DummyMat2( 2,2 ) = 1.0_DFP; DummyMat2( 3,3 ) = 1.0_DFP - -CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat2 ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getStiffnessMatrix_3( Cijkl = DummyMat2 )' -CALL STElemSD % DisplayMatrix4( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getStiffnessMatrix_3( Cijkl = DummyMat2 ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -4D MATRIX, MAT4(:,:,:,:) :: - -Mat4( :, :, 1, 1 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 - 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 - -Mat4( :, :, 1, 2 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 1 ) - - 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 - -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 - -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 - 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 - -Mat4( :, :, 2, 2 ) - - 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 - -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 - -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 - 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 - -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 - 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 -``` \ No newline at end of file diff --git a/src/submodules/STStiffnessMatrix/MethodNames.part b/src/submodules/STStiffnessMatrix/MethodNames.part deleted file mode 100644 index 5f0902822..000000000 --- a/src/submodules/STStiffnessMatrix/MethodNames.part +++ /dev/null @@ -1,14 +0,0 @@ -getStiffnessMatrix_1, & -getStiffnessMatrix_2, & -getStiffnessMatrix_3, & -getStiffnessMatrix_4, & -getStiffnessMatrix_5, & -getStiffnessMatrix_6, & -getStiffnessMatrix_7, & -getStiffnessMatrix_8, & -getStiffnessMatrix_9, & -getStiffnessMatrix_10, & -getStiffnessMatrix_11, & -getStiffnessMatrix_12, & -getStiffnessMatrix_13, & -getStiffnessMatrix_14 diff --git a/src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 b/src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 deleted file mode 100755 index 15bf11953..000000000 --- a/src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 +++ /dev/null @@ -1,85 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: STStiffnessMatrix_Class.f90 -! Last Update : Nov-21-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - Stiffness matrices for space-time elements -! -!============================================================================== - - MODULE STStiffnessMatrix_Class - USE GlobalData - USE IO - USE STElemShapeData_Class - USE STShapeData_Class - USE ShapeData_Class - IMPLICIT NONE - - PRIVATE - PUBLIC :: STStiffnessMatrix_, STStiffnessMatrix_POINTER, STStiffnessMatrix - -!------------------------------------------------------------------------------ -! STElemShapeData_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( STElemShapeData_ ) :: STStiffnessMatrix_ - -!. . . . . . . . . . . . . . . . . . . . -! 1. Stiffness matrices for the space-time element for & -! solid mechanics application -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - - PROCEDURE, PUBLIC, PASS :: & -#include "./MethodNames.part" - - END TYPE STStiffnessMatrix_ - -!------------------------------------------------------------------------------ -! INTERFACES -!------------------------------------------------------------------------------ - - - INTERFACE STStiffnessMatrix_POINTER - MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 - END INTERFACE - - INTERFACE STStiffnessMatrix - MODULE PROCEDURE Constructor1, Constructor2, Constructor3 - END INTERFACE - -!------------------------------------------------------------------------------ -! CONTAINS -!------------------------------------------------------------------------------ - - CONTAINS - -#include "./Constructor.part" -#include "./StiffnessMatrix_1.part" -#include "./StiffnessMatrix_2.part" -#include "./StiffnessMatrix_3.part" -#include "./StiffnessMatrix_4.part" -#include "./StiffnessMatrix_5.part" -#include "./StiffnessMatrix_6.part" -#include "./StiffnessMatrix_7.part" -#include "./StiffnessMatrix_8.part" -#include "./StiffnessMatrix_9.part" -#include "./StiffnessMatrix_10.part" -#include "./StiffnessMatrix_11.part" -#include "./StiffnessMatrix_12.part" -#include "./StiffnessMatrix_13.part" -#include "./StiffnessMatrix_14.part" - - END MODULE STStiffnessMatrix_Class - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part deleted file mode 100755 index c75a6ab4c..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part +++ /dev/null @@ -1,176 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_1.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_1 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_1( Obj, Cijkl ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns Stiffness matrix - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - & i, j, sizeOFC - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - REAL( DFP ) :: RealVal - REAL( DFP ), ALLOCATABLE :: Ce( :, : ), BMat( :, : ), BTMat( :, : ) - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - Error_Flag = .FALSE. - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_1()", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Cijkl, 3 ) .NE. NIPS .OR. SIZE( Cijkl, 4 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_1()", & - "The SIZE( Cijkl, 3 ) should be NIPS, & - & SIZE( Cijkl, 4 ) should be NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_1()", & - "The size of first and second dimension of Cijkl must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SizeOfC = SIZE( Cijkl, 1 ) - -#ifdef DEBUG_VER - IF( NSD .EQ. 2 ) THEN - IF( SizeOfC .NE. 4 & - .AND. SizeOfC .NE. 3 ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_1()", & - "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & - & either 3, 4" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF - IF( NSD .EQ. 3 ) THEN - IF( SizeOfC .NE. 6 ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_1(), Flag-5", & - "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & - & equal to 6" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF -#endif - - ! Make Indx - SELECT CASE( NSD ) - CASE( 1 ) - ALLOCATE( Indx( 1, 1 ) ) - Indx = 1 - CASE( 2 ) - Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) - CASE( 3 ) - Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) - END SELECT - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) - ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) - BMat = 0.0_DFP - BTMat = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - DO j = 1, NSD - DO i = 1, NSD - Ce( (i-1) * NSD + 1 : i * NSD, (j-1) * NSD + 1 : j * NSD ) & - & = Cijkl( Indx( :, i ), Indx( :, j ), IPS, IPT ) - END DO - END DO - - DO b = 1, NNT - DO i = 1, NSD - BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & - & TRANSPOSE( SD % dNTdXt( :, :, b ) ) - END DO - DO aa = 1, NNT - DO i = 1, NSD - BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & - & SD % dNTdXt( :, :, aa ) - END DO - Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & - & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - DEALLOCATE( Ce, Indx, BMat, BTMat ) - -END SUBROUTINE getStiffnessMatrix_1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part deleted file mode 100755 index 4d5f05e3f..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part +++ /dev/null @@ -1,106 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_10.part -! Last Update : Jan-06-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_10 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_10( Obj, CData, TimeVector, IntegrationSide ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns Stiffness matrix - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE MaterialJacobian_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - TYPE( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, :, : ) - INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, NSD, N - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix(Obj, CData)", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix(Obj, CData)", & - "The Shape Of CData is not compatible" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ! Make Cijkl - ALLOCATE( Cijkl( N, N, NIPS, NIPT ) ) - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - Cijkl( :, :, IPS, IPT ) = CData( IPS, IPT ) % C .Cijkl. N - END DO - END DO - - CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) - - DEALLOCATE( Cijkl ) - -END SUBROUTINE getStiffnessMatrix_10 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part deleted file mode 100755 index 6a6a76002..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part +++ /dev/null @@ -1,104 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_11.part -! Last Update : Jan-06-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_11 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_11( Obj, CData, TimeVector, IntegrationSide ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. CData is the one dimensional array - ! 3. In this case material tangent doesnot vary with the time. - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE MaterialJacobian_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - TYPE( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( : ) - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, : ) - INTEGER( I4B ) :: NIPS, IPS, NSD, N - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_11(Obj, CData)", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - -#ifdef DEBUG_VER - IF( SIZE( CData ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_11(Obj, CData)", & - "The Shape Of CData is not compatible" & - ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ALLOCATE( Cijkl( N, N, NIPS ) ) - - DO IPS = 1, NIPS - Cijkl( :, :, IPS ) = CData( IPS ) % C .Cijkl. N - END DO - - CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) - - DEALLOCATE( Cijkl ) - -END SUBROUTINE getStiffnessMatrix_11 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part deleted file mode 100755 index aab4cd54c..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part +++ /dev/null @@ -1,85 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_12.part -! Last Update : Jan-06-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_12 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_12( Obj, CData, TimeVector, IntegrationSide ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. CData is constant - ! 3. In this case material tangent doesnot vary with the space-time. - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE MaterialJacobian_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Cijkl( :, : ) - INTEGER( I4B ) :: NSD, N - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_12(Obj, CData)", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ! Make Cijkl - ALLOCATE( Cijkl( N, N ) ) - Cijkl( :, : ) = CData % C .Cijkl. N - CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) - DEALLOCATE( Cijkl ) - -END SUBROUTINE getStiffnessMatrix_12 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part deleted file mode 100755 index 1d201a323..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part +++ /dev/null @@ -1,240 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_13.part -! Last Update : March-15-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space time stiffness matrix for alpha-beta v-ST/FEM -! - beta_STFEM is beta => -! - Effective coefficient will be beta_STFEM * dt -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_13 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_13( Obj, Cijkl, TimeVector, IntegrationSide, & - & beta_STFEM ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. Time Integration is character it should be "left", "right" - !. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY : OUTERPROD - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - REAL( DFP ), INTENT( IN ) :: beta_STFEM - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, r1, r2, c1, c2, M, sizeOFC, p, q - REAL( DFP ), ALLOCATABLE :: dNTdXt( :, :, : ), T( : ), dNTdXt2( :, :, : ), & - dNTdXt3( :, :, : ) - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - REAL( DFP ) :: Ws, Js, thick, RealVal, Jt, Wt, Kij, t1, t2, Theta, beta - TYPE( STElemShapeData_ ), TARGET :: STElemSD, STElemSD2 - CLASS( STShapeData_ ), POINTER :: SD => NULL( ), SD2 => NULL( ) - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_13()", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Cijkl, 3 ) .NE. NIPS .OR. SIZE( Cijkl, 4 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_13()", & - "The SIZE( Cijkl, 3 ) should be NIPS, & - & SIZE( Cijkl, 4 ) should be NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_13()", & - "The size of first and second dimension of Cijkl must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SizeOfC = SIZE( Cijkl, 1 ) - -#ifdef DEBUG_VER - IF( NSD .EQ. 2 ) THEN - IF( SizeOfC .NE. 4 & - & .AND. SizeOfC .NE. 3 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_13()", & - & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & - & either 3, 4" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF - IF( NSD .EQ. 3 ) THEN - IF( SizeOfC .NE. 6 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_13(), Flag-5", & - & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & - & equal to 6" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF -#endif - - ! Make Indx - SELECT CASE( NSD ) - CASE( 1 ) - ALLOCATE( Indx( 1, 1 ) ) - Indx = 1 - CASE( 2 ) - Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) - CASE( 3 ) - Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) - END SELECT - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - t1 = TimeVector( 1 ) - t2 = TimeVector( 2 ) - - beta = beta_STFEM * ( t2 - t1 ) - - ! Make copy of Obj - CALL STElemSD % Initiate( Obj ) - CALL STElemSD2 % Initiate( Obj ) - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => STElemSD % SD( IPS, IPT ) - Theta = SD % Theta - T = SD .TimeIntegration. [t1, t2, Theta] - - CALL SD % setT( T ) - CALL SD % setdNTdXt( ) - SD2 => STElemSD2 % SD( IPS, IPT ) - T = SD2 % dTdTheta / SD2 % Jt - CALL SD2 % setT( T ) - CALL SD2 % setdNTdXt( ) - END DO - END DO - - SD => NULL( ) - - DO p = 1, NSD - DO q = 1, NSD - DO aa = 1, NNT - DO b = 1, NNT - DO i = 1, M - DO j = 1, M - r1 = ( i - 1_I4B ) * NNS + 1_I4B - r2 = i*NNS - c1 = ( j - 1_I4B ) * NNS + 1_I4B - c2 = j*NNS - DO IPT = 1, NIPT - DO IPS = 1, NIPS - Kij = Cijkl( Indx( p, i ), Indx( q, j ), IPS, IPT ) - Ws = Obj % SD( IPS, IPT ) % getWs( ) - Wt = Obj % SD( IPS, IPT ) % getWt( ) - Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) - Jt = Obj % SD( IPS, IPT ) % getJt( ) - thick = Obj % SD( IPS, IPT ) % getThickness( ) - CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) - CALL STElemSD % SD( IPS, IPT ) % getdNTdXt( dNTdXt2 ) - CALL STElemSD2 % SD( IPS, IPT ) % getdNTdXt( dNTdXt3 ) - RealVal = Ws * Wt * Js * Jt * thick * Kij*beta - - SELECT CASE( TRIM( IntegrationSide ) ) - CASE( "Right", "RIGHT", "right" ) - Obj % Mat4( r1:r2, c1:c2, aa, b ) = & - Obj % Mat4( r1:r2, c1:c2, aa, b ) + & - OUTERPROD( a = dNTdXt3( :, p, aa ), b = dNTdXt2( :, q, b ) ) * RealVal - - CASE( "Left", "LEFT", "left" ) - Obj % Mat4( r1:r2, c1:c2, aa, b ) = & - Obj % Mat4( r1:r2, c1:c2, aa, b ) + & - OUTERPROD( a = dNTdXt2( :, p, aa ), b = dNTdXt3( :, q, b ) ) * RealVal - - CASE( "None", "NONE", "none" ) - Obj % Mat4( r1:r2, c1:c2, aa, b ) = & - Obj % Mat4( r1:r2, c1:c2, aa, b ) + & - OUTERPROD( a = dNTdXt3( :, p, aa ), b = dNTdXt( :, q, b ) ) * RealVal - - CASE DEFAULT - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_13()", & - "No case found for given integration side" & - ) - Error_Flag = .TRUE. - RETURN - END SELECT - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - IF( ALLOCATED( dNTdXt ) ) DEALLOCATE( dNTdXt ) - IF( ALLOCATED( dNTdXt2 ) ) DEALLOCATE( dNTdXt2 ) - IF( ALLOCATED( dNTdXt3 ) ) DEALLOCATE( dNTdXt3 ) - IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) - IF( ALLOCATED( T ) ) DEALLOCATE( T ) - CALL STElemSD % DeallocateData( ) - CALL STElemSD2 % DeallocateData( ) - SD => NULL( ) - SD2 => NULL( ) - -END SUBROUTINE getStiffnessMatrix_13 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part deleted file mode 100755 index e4f887eec..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part +++ /dev/null @@ -1,106 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_14.part -! Last Update : Jan-06-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! - Space time stiffness matrix for alpha-beta v-ST/FEM -! - beta_STFEM is beta => -! - Effective coefficient will be beta_STFEM * dt -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_14 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_14( Obj, CData, TimeVector, IntegrationSide, & - & beta_STFEM ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns Stiffness matrix - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE MaterialJacobian_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - TYPE( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ), beta_STFEM - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, :, : ) - INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, NSD, N - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix(Obj, CData)", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = .NIPS. Obj - NIPT = .NIPT. Obj - -#ifdef DEBUG_VER - IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix(Obj, CData)", & - "The Shape Of CData is not compatible" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ! Make Cijkl - ALLOCATE( Cijkl( N, N, NIPS, NIPT ) ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - Cijkl( :, :, IPS, IPT ) = CData( IPS, IPT ) % C .Cijkl. N - END DO - END DO - CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide, beta_STFEM ) - DEALLOCATE( Cijkl ) - -END SUBROUTINE getStiffnessMatrix_14 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part deleted file mode 100755 index e4cf95e13..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part +++ /dev/null @@ -1,176 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_2.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_2 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_2( Obj, Cijkl ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness Matrix - ! 2. Cijkl is constant in time - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Cijkl - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, sizeOFC - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - REAL( DFP ) :: RealVal - REAL( DFP ), ALLOCATABLE :: Ce( :, : ), BMat( :, : ), BTMat( :, : ) - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - Error_Flag = .FALSE. - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2()", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Cijkl, 3 ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2()", & - "The SIZE( Cijkl, 3 ) should be NIPS" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2()", & - "The size of first and second dimension of Cijkl must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SizeOfC = SIZE( Cijkl, 1 ) - -#ifdef DEBUG_VER - IF( NSD .EQ. 2 ) THEN - IF( SizeOfC .NE. 4 & - .AND. SizeOfC .NE. 3 ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2()", & - "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & - & either 3, 4" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF - IF( NSD .EQ. 3 ) THEN - IF( SizeOfC .NE. 6 ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2(), Flag-5", & - "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & - & equal to 6" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF -#endif - - ! Make Indx - SELECT CASE( NSD ) - CASE( 1 ) - ALLOCATE( Indx( 1, 1 ) ) - Indx = 1 - CASE( 2 ) - Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) - CASE( 3 ) - Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) - END SELECT - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) - ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) - BMat = 0.0_DFP - BTMat = 0.0_DFP - - DO IPS = 1, NIPS - - DO j = 1, NSD - DO i = 1, NSD - Ce( (i-1) * NSD + 1 : i * NSD, (j-1) * NSD + 1 : j * NSD ) & - & = Cijkl( Indx( :, i ), Indx( :, j ), IPS ) - END DO - END DO - - DO IPT = 1, NIPT - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - DO b = 1, NNT - DO i = 1, NSD - BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & - & TRANSPOSE( SD % dNTdXt( :, :, b ) ) - END DO - DO aa = 1, NNT - DO i = 1, NSD - BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & - & SD % dNTdXt( :, :, aa ) - END DO - Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & - & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - DEALLOCATE( Ce, Indx, BMat, BTMat ) - -END SUBROUTINE getStiffnessMatrix_2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part deleted file mode 100755 index 4e53feba0..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part +++ /dev/null @@ -1,171 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_3.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_3 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_3( Obj, Cijkl ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Cijkl - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, sizeOFC - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - REAL( DFP ) :: RealVal - REAL( DFP ), ALLOCATABLE :: Ce( :, : ), BMat( :, : ), BTMat( :, : ) - - CLASS( STShapeData_ ), POINTER :: SD - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - Error_Flag = .FALSE. - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2()", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2()", & - "The size of first and second dimension of Cijkl must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SizeOfC = SIZE( Cijkl, 1 ) - -#ifdef DEBUG_VER - IF( NSD .EQ. 2 ) THEN - IF( SizeOfC .NE. 4 & - .AND. SizeOfC .NE. 3 ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2()", & - "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & - & either 3, 4" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF - IF( NSD .EQ. 3 ) THEN - IF( SizeOfC .NE. 6 ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_2(), Flag-5", & - "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & - & equal to 6" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF -#endif - - ! Make Indx - SELECT CASE( NSD ) - CASE( 1 ) - ALLOCATE( Indx( 1, 1 ) ) - Indx = 1 - CASE( 2 ) - Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) - CASE( 3 ) - Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) - END SELECT - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) - ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) - BMat = 0.0_DFP - BTMat = 0.0_DFP - - DO j = 1, NSD - DO i = 1, NSD - Ce( (i-1) * NSD + 1 : i * NSD, (j-1) * NSD + 1 : j * NSD ) & - & = Cijkl( Indx( :, i ), Indx( :, j ) ) - END DO - END DO - - DO IPS = 1, NIPS - DO IPT = 1, NIPT - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - DO b = 1, NNT - - DO i = 1, NSD - BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & - & TRANSPOSE( SD % dNTdXt( :, :, b ) ) - END DO - - DO aa = 1, NNT - - DO i = 1, NSD - BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & - & SD % dNTdXt( :, :, aa ) - END DO - - Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & - & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - DEALLOCATE( Ce, Indx, BMat, BTMat ) - -END SUBROUTINE getStiffnessMatrix_3 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part deleted file mode 100755 index 31847cef2..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part +++ /dev/null @@ -1,98 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_4.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_4 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_4( Obj, CData ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. - Returns Stiffness matrix - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE MaterialJacobian_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, :, : ) - INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, NSD, N - -#ifdef DEBUG_VER - IF( .NOT. Obj % isInitiated( ) ) THEN - Error_Flag = .FALSE. - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix(Obj, CData)", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix(Obj, CData)", & - "The Shape Of CData is not compatible" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ! Make Cijkl - ALLOCATE( Cijkl( N, N, NIPS, NIPT ) ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - Cijkl( :, :, IPS, IPT ) = CData( IPS, IPT ) % C .Cijkl. N - END DO - END DO - CALL Obj % getStiffnessMatrix( Cijkl ) - DEALLOCATE( Cijkl ) - -END SUBROUTINE getStiffnessMatrix_4 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part deleted file mode 100755 index 42f34d8d7..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part +++ /dev/null @@ -1,98 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_5.part -! Last Update : Nov-23-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_5 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_5( Obj, CData ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. CData is the one dimensional array - ! 3. In this case material tangent doesnot vary with the time. - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE MaterialJacobian_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( : ) - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, : ) - INTEGER( I4B ) :: NIPS, IPS, NSD, N - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_5(Obj, CData)", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NIPS = Obj % getNIPS( ) - -#ifdef DEBUG_VER - IF( SIZE( CData ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_5(Obj, CData)", & - "The Shape Of CData is not compatible" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - ! Make Cijkl - ALLOCATE( Cijkl( N, N, NIPS ) ) - DO IPS = 1, NIPS - Cijkl( :, :, IPS ) = CData( IPS ) % C .Cijkl. N - END DO - CALL Obj % getStiffnessMatrix( Cijkl ) - DEALLOCATE( Cijkl ) - -END SUBROUTINE getStiffnessMatrix_5 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part deleted file mode 100755 index 0b8069e1c..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part +++ /dev/null @@ -1,82 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_6.part -! Last Update : Jan-03-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_6 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_6( Obj, CData ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. CData is constant - ! 3. In this case material tangent doesnot vary with the space-time. - !. . . . . . . . . . . . . . . . . . . . - - USE ConstitutiveData_Class - USE MaterialJacobian_Class - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData - - ! Define internal variables - REAL( DFP ), ALLOCATABLE :: Cijkl( :, : ) - INTEGER( I4B ) :: NSD, N - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_6(Obj, CData)", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - - SELECT CASE( NSD ) - CASE( 3 ) - N = 6 - CASE( 2 ) - N = 4 - CASE( 1 ) - N = 1 - END SELECT - - Cijkl = CData % C .Cijkl. N - CALL Obj % getStiffnessMatrix( Cijkl ) - DEALLOCATE( Cijkl ) - -END SUBROUTINE getStiffnessMatrix_6 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part deleted file mode 100755 index 3601ed278..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part +++ /dev/null @@ -1,229 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_7.part -! Last Update : Jan-06-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_7 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_7( Obj, Cijkl, TimeVector, IntegrationSide ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. Time Integration is character "Right", "Left", "Both" - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, sizeOFC - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - REAL( DFP ) :: RealVal, t1, t2, Theta - REAL( DFP ), ALLOCATABLE :: T( : ), Ce( :, : ), BMat( :, : ), BTMat( :, : ) - - TYPE( STElemShapeData_ ), TARGET :: STElemSD - CLASS( STShapeData_ ), POINTER :: SD, SD2 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_7()", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Cijkl, 3 ) .NE. NIPS .OR. SIZE( Cijkl, 4 ) .NE. NIPT ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_7()", & - "The SIZE( Cijkl, 3 ) should be NIPS, & - & SIZE( Cijkl, 4 ) should be NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_7()", & - "The size of first and second dimension of Cijkl must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SizeOfC = SIZE( Cijkl, 1 ) - -#ifdef DEBUG_VER - IF( NSD .EQ. 2 ) THEN - IF( SizeOfC .NE. 4 & - & .AND. SizeOfC .NE. 3 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_7()", & - & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & - & either 3, 4" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF - IF( NSD .EQ. 3 ) THEN - IF( SizeOfC .NE. 6 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_7(), Flag-5", & - & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & - & equal to 6" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF -#endif - - ! Make Indx - SELECT CASE( NSD ) - CASE( 1 ) - ALLOCATE( Indx( 1, 1 ) ) - Indx = 1 - CASE( 2 ) - Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) - CASE( 3 ) - Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) - END SELECT - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - - t1 = TimeVector( 1 ) - t2 = TimeVector( 2 ) - - ! Make copy of Obj - CALL STElemSD % Initiate( Obj ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => STElemSD % SD( IPS, IPT ) - Theta = SD % Theta - T = SD .TimeIntegration. [t1, t2, Theta] - CALL SD % setT( T ) - CALL SD % setdNTdXt( ) - END DO - END DO - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) - ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) - BMat = 0.0_DFP - BTMat = 0.0_DFP - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SELECT CASE( TRIM( IntegrationSide ) ) - - CASE( "Right", "RIGHT", "right" ) - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - SD2 => STElemSD % SD( IPS, IPT ) - - CASE( "Left", "LEFT", "left" ) - - SD => STElemSD % SD( IPS, IPT ) - SD2 => Obj % SD( IPS, IPT ) - RealVal = SD2 % Ws * SD2 % Wt * SD2 % Js_Xi2Xt & - & * SD2 % Jt * SD2 % Thickness - - CASE( "Both", "BOTH", "both" ) - - SD => STElemSD % SD( IPS, IPT ) - SD2 => STElemSD % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CASE DEFAULT - - SD => Obj % SD( IPS, IPT ) - SD2 => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - END SELECT - - DO j = 1, NSD - DO i = 1, NSD - Ce( (i-1)*NSD + 1:i*NSD, (j-1)*NSD + 1:j*NSD ) & - & = Cijkl( Indx( :, i ), Indx( :, j ), IPS, IPT ) - END DO - END DO - - DO b = 1, NNT - DO i = 1, NSD - BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & - & TRANSPOSE( SD2 % dNTdXt( :, :, b ) ) - END DO - - DO aa = 1, NNT - DO i = 1, NSD - BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & - & SD % dNTdXt( :, :, aa ) - END DO - - Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & - & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) - - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - DEALLOCATE( Indx, T, Ce, BMat, BTMat ) - CALL STElemSD % DeallocateData( ) - SD => NULL( ) - SD2 => NULL( ) - -END SUBROUTINE getStiffnessMatrix_7 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part deleted file mode 100755 index 0be3f38bc..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part +++ /dev/null @@ -1,230 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_8.part -! Last Update : Jan-06-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_8 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_8( Obj, Cijkl, TimeVector, IntegrationSide ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. Time Integration is character "Right", "Left", "Both" - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Cijkl - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, sizeOFC - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - REAL( DFP ) :: RealVal, t1, t2, Theta - REAL( DFP ), ALLOCATABLE :: T( : ), Ce( :, : ), BMat( :, : ), BTMat( :, : ) - - TYPE( STElemShapeData_ ), TARGET :: STElemSD - CLASS( STShapeData_ ), POINTER :: SD, SD2 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_7()", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Cijkl, 3 ) .NE. NIPS ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_7()", & - "The SIZE( Cijkl, 3 ) should be NIPS, & - & SIZE( Cijkl, 4 ) should be NIPT" ) - Error_Flag = .TRUE. - RETURN - END IF - IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_7()", & - "The size of first and second dimension of Cijkl must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SizeOfC = SIZE( Cijkl, 1 ) - -#ifdef DEBUG_VER - IF( NSD .EQ. 2 ) THEN - IF( SizeOfC .NE. 4 & - & .AND. SizeOfC .NE. 3 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_7()", & - & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & - & either 3, 4" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF - IF( NSD .EQ. 3 ) THEN - IF( SizeOfC .NE. 6 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_7(), Flag-5", & - & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & - & equal to 6" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF -#endif - - ! Make Indx - SELECT CASE( NSD ) - CASE( 1 ) - ALLOCATE( Indx( 1, 1 ) ) - Indx = 1 - CASE( 2 ) - Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) - CASE( 3 ) - Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) - END SELECT - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - - t1 = TimeVector( 1 ) - t2 = TimeVector( 2 ) - - ! Make copy of Obj - CALL STElemSD % Initiate( Obj ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => STElemSD % SD( IPS, IPT ) - Theta = SD % Theta - T = SD .TimeIntegration. [t1, t2, Theta] - CALL SD % setT( T ) - CALL SD % setdNTdXt( ) - END DO - END DO - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) - ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) - BMat = 0.0_DFP - BTMat = 0.0_DFP - - DO IPS = 1, NIPS - - DO j = 1, NSD - DO i = 1, NSD - Ce( (i-1)*NSD + 1:i*NSD, (j-1)*NSD + 1:j*NSD ) & - & = Cijkl( Indx( :, i ), Indx( :, j ), IPS ) - END DO - END DO - - DO IPT = 1, NIPT - - SELECT CASE( TRIM( IntegrationSide ) ) - - CASE( "Right", "RIGHT", "right" ) - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - SD2 => STElemSD % SD( IPS, IPT ) - - CASE( "Left", "LEFT", "left" ) - - SD => STElemSD % SD( IPS, IPT ) - SD2 => Obj % SD( IPS, IPT ) - RealVal = SD2 % Ws * SD2 % Wt * SD2 % Js_Xi2Xt & - & * SD2 % Jt * SD2 % Thickness - - CASE( "Both", "BOTH", "both" ) - - SD => STElemSD % SD( IPS, IPT ) - SD2 => STElemSD % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CASE DEFAULT - - SD => Obj % SD( IPS, IPT ) - SD2 => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - END SELECT - - DO b = 1, NNT - DO i = 1, NSD - BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & - & TRANSPOSE( SD2 % dNTdXt( :, :, b ) ) - END DO - - DO aa = 1, NNT - DO i = 1, NSD - BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & - & SD % dNTdXt( :, :, aa ) - END DO - - Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & - & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) - - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - DEALLOCATE( Indx, T, Ce, BMat, BTMat ) - CALL STElemSD % DeallocateData( ) - SD => NULL( ) - SD2 => NULL( ) - -END SUBROUTINE getStiffnessMatrix_8 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part deleted file mode 100755 index 553ce2c8f..000000000 --- a/src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part +++ /dev/null @@ -1,221 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: StiffnessMatrix_9.part -! Last Update : Jan-06-2018 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - STStiffnessMatrix_Class.f90 -!============================================================================== - -!------------------------------------------------------------------------------ -! getStiffnessMatrix_9 -!------------------------------------------------------------------------------ - -SUBROUTINE getStiffnessMatrix_9( Obj, Cijkl, TimeVector, IntegrationSide ) - - !. . . . . . . . . . . . . . . . . . . . - ! 1. Returns Stiffness matrix - ! 2. Time Integration is character "Right", "Left", "Both" - !. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Cijkl - REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) - CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide - - - ! Define internal variables - INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & - i, j, sizeOFC - INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) - - REAL( DFP ) :: RealVal, t1, t2, Theta - REAL( DFP ), ALLOCATABLE :: T( : ), Ce( :, : ), BMat( :, : ), BTMat( :, : ) - - TYPE( STElemShapeData_ ), TARGET :: STElemSD - CLASS( STShapeData_ ), POINTER :: SD, SD2 - -#ifdef DEBUG_VER - Error_Flag = .FALSE. - IF( .NOT. Obj % isInitiated( ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_9()", & - "STStiffnessMatrix_ Object is not Initiated" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN - CALL Err_Msg( & - "STStiffnessMatrix_Class.f90", & - "getStiffnessMatrix_9()", & - "The size of first and second dimension of Cijkl must be same" ) - Error_Flag = .TRUE. - RETURN - END IF -#endif - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - SizeOfC = SIZE( Cijkl, 1 ) - -#ifdef DEBUG_VER - IF( NSD .EQ. 2 ) THEN - IF( SizeOfC .NE. 4 & - & .AND. SizeOfC .NE. 3 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_9()", & - & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & - & either 3, 4" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF - IF( NSD .EQ. 3 ) THEN - IF( SizeOfC .NE. 6 ) THEN - CALL Err_Msg( & - & "STStiffnessMatrix_Class.f90", & - & "getStiffnessMatrix_9(), Flag-5", & - & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & - & equal to 6" ) - Error_Flag = .TRUE. - RETURN - END IF - END IF -#endif - - ! Make Indx - SELECT CASE( NSD ) - CASE( 1 ) - ALLOCATE( Indx( 1, 1 ) ) - Indx = 1 - CASE( 2 ) - Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) - CASE( 3 ) - Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) - END SELECT - - NNS = Obj % SD( 1,1 ) % getNNS( ) - NNT = Obj % SD( 1,1 ) % getNNT( ) - - t1 = TimeVector( 1 ) - t2 = TimeVector( 2 ) - - ! Make copy of Obj - CALL STElemSD % Initiate( Obj ) - DO IPT = 1, NIPT - DO IPS = 1, NIPS - SD => STElemSD % SD( IPS, IPT ) - Theta = SD % Theta - T = SD .TimeIntegration. [t1, t2, Theta] - CALL SD % setT( T ) - CALL SD % setdNTdXt( ) - END DO - END DO - - IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) - ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) - Obj % Mat4 = 0.0_DFP - - ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) - ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) - BMat = 0.0_DFP - BTMat = 0.0_DFP - - DO j = 1, NSD - DO i = 1, NSD - Ce( (i-1)*NSD + 1:i*NSD, (j-1)*NSD + 1:j*NSD ) & - & = Cijkl( Indx( :, i ), Indx( :, j ) ) - END DO - END DO - - DO IPT = 1, NIPT - DO IPS = 1, NIPS - - SELECT CASE( TRIM( IntegrationSide ) ) - - CASE( "Right", "RIGHT", "right" ) - - SD => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - SD2 => STElemSD % SD( IPS, IPT ) - - CASE( "Left", "LEFT", "left" ) - - SD => STElemSD % SD( IPS, IPT ) - SD2 => Obj % SD( IPS, IPT ) - RealVal = SD2 % Ws * SD2 % Wt * SD2 % Js_Xi2Xt & - & * SD2 % Jt * SD2 % Thickness - - CASE( "Both", "BOTH", "both" ) - - SD => STElemSD % SD( IPS, IPT ) - SD2 => STElemSD % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - CASE DEFAULT - - SD => Obj % SD( IPS, IPT ) - SD2 => Obj % SD( IPS, IPT ) - RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & - & * SD % Jt * SD % Thickness - - END SELECT - - DO b = 1, NNT - DO i = 1, NSD - BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & - & TRANSPOSE( SD2 % dNTdXt( :, :, b ) ) - END DO - - DO aa = 1, NNT - DO i = 1, NSD - BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & - & SD % dNTdXt( :, :, aa ) - END DO - - Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & - & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) - - END DO - END DO - END DO - END DO - - CALL Obj % Mat2FromMat4( ) - DEALLOCATE( Indx, T, Ce, BMat, BTMat ) - CALL STElemSD % DeallocateData( ) - SD => NULL( ) - SD2 => NULL( ) - -END SUBROUTINE getStiffnessMatrix_9 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ST_Tau_SUPG_RGN/Constructor.part b/src/submodules/ST_Tau_SUPG_RGN/Constructor.part deleted file mode 100755 index 39dd6a339..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/Constructor.part +++ /dev/null @@ -1,101 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: Constructor.part -! Last Update : Nov-17-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! Constructor_1 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_1( NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construtor function -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( ST_Tau_SUPG_RGN_ ), POINTER :: Constructor_1 - INTEGER( I4B ), INTENT( IN ) :: NIPS, NIPT - - ALLOCATE( Constructor_1 ) - - ALLOCATE( Constructor_1 % Mat2( NIPS, NIPT ) ) - - Constructor_1 % Mat2 = 0.0_DFP - - CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor_1 - -!------------------------------------------------------------------------------ -! Constructor_2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor_2( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construtor function -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - CLASS( ST_Tau_SUPG_RGN_ ), POINTER :: Constructor_2 - ALLOCATE( Constructor_2 ) - - END FUNCTION Constructor_2 - -!------------------------------------------------------------------------------ -! Constructor1 -!------------------------------------------------------------------------------ -! - FUNCTION Constructor1( NIPS, NIPT ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construtor function -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( ST_Tau_SUPG_RGN_ ) :: Constructor1 - INTEGER( I4B ), INTENT( IN ) :: NIPS, NIPT - - ALLOCATE( Constructor1 % Mat2( NIPS, NIPT ) ) - Constructor1 % Mat2 = 0.0_DFP - CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) - - END FUNCTION Constructor1 - -!------------------------------------------------------------------------------ -! Constructor2 -!------------------------------------------------------------------------------ - - FUNCTION Constructor2( ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Construtor function -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables - TYPE( ST_Tau_SUPG_RGN_ ) :: Constructor2 - - END FUNCTION Constructor2 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ST_Tau_SUPG_RGN/MdFiles/._ST_TAU_SUPG_RGN_Class.md b/src/submodules/ST_Tau_SUPG_RGN/MdFiles/._ST_TAU_SUPG_RGN_Class.md deleted file mode 100644 index 18e5cd827d6324657aca6added3aa781df6fb72e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 299 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@lPNI@)@;(G!eitBqRu;46I`hke!dF z4P-hFR`SgC^M ST_Tau_SUPG_RGN( ) -STElemSD => ST_Tau_SUPG_RGN( NIPS, NIPT ) -``` - - - -## Theory - -We are intended to compute the following. - -## Methods - -### getSUPG\_For\_Scalar\_1( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_1( Obj, Phi, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NNS, NNT ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_1( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_1( C = DummyMat3, Phi = DummyMat2, Mu= 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_2( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_2( Obj, Phi, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NNS, NNT ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3( :, :, 1), Phi = DummyMat2, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_2( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_2( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_3( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_3( Obj, Phi, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NSD ) ) -DummyVec = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NNS, NNT ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_3( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_3(C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_4( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_4( Obj, Phi, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NNS ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_4( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_4(C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_5( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_5( Obj, Phi, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NNS ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_5( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_4(C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_6( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_6( Obj, Phi, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NSD, NNS ) ) -DummyMat2 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NNS ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat2(:,1), Phi = DummyVec, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_6( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_6( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP ) -MATRIX STORED IN ST-ELEMENT-SHAPEDATA -NIPS :: 4 NIPT :: 2 -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_7( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_7( Obj, Phi, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NNS, NNT ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_7( C = DummyMat3,& - Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_7( C = DummyMat3,Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) -MATRIX STORED IN ST-ELEMENT-SHAPEDATA -NIPS :: 4 NIPT :: 2 -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_8( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_8( Obj, Phi, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NNS, NNT ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3( :, :, 1), Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_8( C = DummyMat2,& - Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_8( C = DummyMat2,Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) -MATRIX STORED IN ST-ELEMENT-SHAPEDATA -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_9( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_9( Obj, Phi, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) -ALLOCATE( DummyMat2( NNS, NNT ) ) -DummyMat2 = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3( :, 1, 1), Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_9( C = DummyVec,& -Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_9( C = DummyVec,Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_10( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_10( Obj, Phi, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NNS ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_10( C = DummyMat3,& -Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_10( C = DummyMat3,Phi = DummyVec, Mu =1.0_DFP, CType = "Quad" ) -MATRIX STORED IN ST-ELEMENT-SHAPEDATA -NIPS :: 4 NIPT :: 2 -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_11( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_11( Obj, Phi, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NNS ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3(:,:,1), Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_11( C = DummyMat2,& - Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_11( C = DummyMat2,Phi = DummyVec, Mu =1.0_DFP, CType = "Quad" ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Scalar\_12( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Scalar_12( Obj, Phi, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) -DummyMat3 = 1.0_DFP - -IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) -ALLOCATE( DummyVec( NNS ) ) -DummyVec = 1.0_DFP - -CALL STElemSD % getSUPGForScalar( C = DummyMat3(:,1,1), Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_12( C = DummyVec,& -Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Scalar_11( C = DummyVec,Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Vector\_1( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_1( Obj, U, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_1( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Vector_1( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP ) -MATRIX STORED IN ST-ELEMENT-SHAPEDATA -NIPS :: 4 NIPT :: 2 -------------------------------------------------- -2D MATRIX, Mat2(:, :) :: - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Vector\_2( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_2( Obj, U, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForVector( C = DummyMat2, U = DummyMat3, Mu = 1.0_DFP ) - -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getSUPGForVector( C = DummyMat3(:,:,1), U = DummyMat3, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_2( C = DummyMat2, U = DummyMat3, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Vector_2( C = DummyMat2, U = DummyMat3, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Vector\_3( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_3( Obj, U, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForVector( C = DummyVec, U = DummyMat3, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getSUPGForVector( C = DummyMat3(:,1,1), U = DummyMat3, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_3( C = DummyVec, U = DummyMat3, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran - -CALL STElemSD % getSUPG_For_Vector_3( C = DummyVec, U = DummyMat3, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Vector\_4( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_4( Obj, U, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat2, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat3(:,:,1), Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_4( C = DummyMat3, U = DummyMat2, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Vector_4( C = DummyMat3, U = DummyMat2, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Vector\_5( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_5( Obj, U, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -CALL STElemSD % getSUPGForVector( C = DummyMat2, U = DummyMat2, Mu = 1.0_DFP ) -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getSUPGForVector( C = DummyMat3( :, :, 1 ), U = DummyMat3(:,:,1), Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_5( C = DummyMat2, U = DummyMat2, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Vector_5( C = DummyMat2, U = DummyMat2, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Vector\_6( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_6( Obj, U, C, Mu ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -? -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) -ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) -DummyMat3 = 1.0_DFP - -CALL STElemSD % getSUPGForVector( C = DummyVec, U = DummyMat2, Mu = 1.0_DFP ) - -CALL BlankLines( ) -WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_6( C = DummyVec, U = DummyMat2, Mu = 1.0_DFP )' - -CALL STElemSD % DisplayMatrix2( ) -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -CALL STElemSD % getSUPG_For_Vector_6( C = DummyVec, U = DummyMat2, Mu = 1.0_DFP ) - -MATRIX STORED IN ST-ELEMENT-SHAPEDATA - -NIPS :: 4 NIPT :: 2 - -------------------------------------------------- - -2D MATRIX, Mat2(:, :) :: - - 0.5358984 0.6000000 - 0.6000000 0.6000000 - 0.6000000 0.5358984 - 0.6000000 0.6000000 -``` - -### getSUPG\_For\_Vector\_7( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_7( Obj, U, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -? -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -? -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -? -``` - -### getSUPG\_For\_Vector\_8( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_7( Obj, U, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -? -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -? -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -? -``` - -### getSUPG\_For\_Vector\_9( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_9( Obj, U, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -? -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -? -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -? -``` - -### getSUPG\_For\_Vector\_10( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_10( Obj, U, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -? -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -? -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -? -``` - -### getSUPG\_For\_Vector\_11( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_11( Obj, U, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -? -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -? -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -? -``` - -### getSUPG\_For\_Vector\_12( ) - -INTERFACE - -```fortran - SUBROUTINE getSUPG_For_Vector_12( Obj, U, C, Mu, CType ) - - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -``` - -DESCRIPTION -? - -SYNTAX - -```fortran -? -``` - -SYMBOLIC CALCULATION -? - -TESTING - -```fortran -? -``` - -__NIPS = 4, NIPT = 2__ - -```fortran -? -``` \ No newline at end of file diff --git a/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part b/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part deleted file mode 100644 index 72e8fa5b8..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part +++ /dev/null @@ -1,12 +0,0 @@ -getSUPG_For_Scalar_1, & -getSUPG_For_Scalar_2, & -getSUPG_For_Scalar_3, & -getSUPG_For_Scalar_4, & -getSUPG_For_Scalar_5, & -getSUPG_For_Scalar_6, & -getSUPG_For_Scalar_7, & -getSUPG_For_Scalar_8, & -getSUPG_For_Scalar_9, & -getSUPG_For_Scalar_10, & -getSUPG_For_Scalar_11, & -getSUPG_For_Scalar_12 diff --git a/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part b/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part deleted file mode 100644 index cb81f8860..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part +++ /dev/null @@ -1,12 +0,0 @@ -getSUPG_For_Vector_1, & -getSUPG_For_Vector_2, & -getSUPG_For_Vector_3, & -getSUPG_For_Vector_4, & -getSUPG_For_Vector_5, & -getSUPG_For_Vector_6, & -getSUPG_For_Vector_7, & -getSUPG_For_Vector_8, & -getSUPG_For_Vector_9, & -getSUPG_For_Vector_10, & -getSUPG_For_Vector_11, & -getSUPG_For_Vector_12 \ No newline at end of file diff --git a/src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 b/src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 deleted file mode 100755 index 2a3fb046e..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 +++ /dev/null @@ -1,100 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: ST_Tau_SUPG_RGN_Class.f90 -! Last Update : Nov-15-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Module -! -! DESCRIPTION -! - STElemShapeData_ Class is extended to define the supg stabilization -! parameter. -! -!============================================================================== - - MODULE ST_Tau_SUPG_RGN_Class - USE GlobalData - USE IO - USE STElemShapeData_Class - USE STShapeData_Class - - IMPLICIT NONE - - PRIVATE - PUBLIC :: ST_Tau_SUPG_RGN_, ST_Tau_SUPG_RGN, ST_Tau_SUPG_RGN_Pointer - -!------------------------------------------------------------------------------ -! ST_Tau_SUPG_RGN_WTSA_ -!------------------------------------------------------------------------------ - - TYPE, EXTENDS( STElemShapeData_ ) :: ST_Tau_SUPG_RGN_ - -!. . . . . . . . . . . . . . . . . . . . -! 1. This class for computation of mass matrix -!. . . . . . . . . . . . . . . . . . . . - - CONTAINS - - PROCEDURE, PUBLIC, PASS( Obj ) :: & -#include "./MethodNamesForScalar.part" - PROCEDURE, PUBLIC, PASS( Obj ) :: & -#include "./MethodNamesForVector.part" - - END TYPE ST_Tau_SUPG_RGN_ - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - - ! INTERFACES - INTERFACE ST_Tau_SUPG_RGN_Pointer - MODULE PROCEDURE Constructor_1, Constructor_2 - END INTERFACE - - INTERFACE ST_Tau_SUPG_RGN - MODULE PROCEDURE Constructor1, Constructor2 - END INTERFACE - -!------------------------------------------------------------------------------ -! CONTAINS -!------------------------------------------------------------------------------ - - CONTAINS - -#undef STMat - -#include "./Constructor.part" -#include "./SUPG_Scalar_1.part" -#include "./SUPG_Scalar_2.part" -#include "./SUPG_Scalar_3.part" -#include "./SUPG_Scalar_4.part" -#include "./SUPG_Scalar_5.part" -#include "./SUPG_Scalar_6.part" -#include "./SUPG_Scalar_7.part" -#include "./SUPG_Scalar_8.part" -#include "./SUPG_Scalar_9.part" -#include "./SUPG_Scalar_10.part" -#include "./SUPG_Scalar_11.part" -#include "./SUPG_Scalar_12.part" - -#include "./SUPG_Vector_1.part" -#include "./SUPG_Vector_2.part" -#include "./SUPG_Vector_3.part" -#include "./SUPG_Vector_4.part" -#include "./SUPG_Vector_5.part" -#include "./SUPG_Vector_6.part" -#include "./SUPG_Vector_7.part" -#include "./SUPG_Vector_8.part" -#include "./SUPG_Vector_9.part" -#include "./SUPG_Vector_10.part" -#include "./SUPG_Vector_11.part" -#include "./SUPG_Vector_12.part" - - END MODULE ST_Tau_SUPG_RGN_Class - diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part deleted file mode 100755 index 5a88e0ce9..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part +++ /dev/null @@ -1,211 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_1 -!------------------------------------------------------------------------------ - - SUBROUTINE getSUPG_For_Scalar_1( Obj, Phi, C, Mu ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!. . . . . . . . . . . . . . . . . . . . - - ! Define intent of dummy variables -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - - ! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT -#ifdef DEBUG_VER - INTEGER( I4B ) :: NSD, NNS, NNT -#endif - - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - CLASS( STShapeData_ ), POINTER :: SD => NULL( ) - Error_Flag = .FALSE. - -#ifdef DEBUG_VER -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & - "getSUPG_For_Scalar_1()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - - ! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & - "getSUPG_For_Scalar_1()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - - ! Flag-3 - IF( SIZE( Phi, 2 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & - "getSUPG_For_Scalar_1()", & - "SIZE( Phi, 2 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - - ! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & - "getSUPG_For_Scalar_1()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - - ! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & - "getSUPG_For_Scalar_1()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - - ! Flag-6 - IF( SIZE( C, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & - "getSUPG_For_Scalar_1()", & - "SIZE( C, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, STNodalValues = C ) - - CALL SD % getUnitNormalOfScalar( & - STNodalValues = Phi, R = R ) - - CALL SD % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( SD % dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - - Tau12 = 0.0_DFP - - ELSE - - Tau12 = d1 / DummyReal - - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - NULLIFY( SD ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) - - END SUBROUTINE getSUPG_For_Scalar_1 - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part deleted file mode 100755 index 6c2f461fb..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part +++ /dev/null @@ -1,223 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_10.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_10 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_10( Obj, Phi, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & - "getSUPG_For_Scalar_10()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & - "getSUPG_For_Scalar_10()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & - "getSUPG_For_Scalar_10()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & - "getSUPG_For_Scalar_10()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & - "getSUPG_For_Scalar_10()", & - "SIZE( C, 3 ) should be equal to the NNT or NIPT") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'STNodalValues', 'ST Nodal Values') - - CALL Obj % getSUPG_For_Scalar_4( Phi = Phi, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & - "getSUPG_For_Scalar_10()", & - "Traceback ---> CALL Obj % getSUPG_For_Scalar_4( Phi = Phi, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - SpaceNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & - "getSUPG_For_Scalar_10()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'STNodalValues', 'ST Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_10 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part deleted file mode 100755 index 0a3477a80..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part +++ /dev/null @@ -1,212 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_11.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_11 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_11( Obj, Phi, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & - "getSUPG_For_Scalar_11()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & - "getSUPG_For_Scalar_11()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & - "getSUPG_For_Scalar_11()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & - "getSUPG_For_Scalar_11()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'SpaceNodalValues', 'Space Nodal Values') - - CALL Obj % getSUPG_For_Scalar_5( Phi = Phi, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & - "getSUPG_For_Scalar_11()", & - "Traceback ---> CALL Obj % getSUPG_For_Scalar_5( Phi = Phi, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - SpaceNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & - "getSUPG_For_Scalar_11()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'SpaceNodalValues', 'Space Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_11 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part deleted file mode 100755 index 40d632aaf..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part +++ /dev/null @@ -1,64 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_12.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_12 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_12( Obj, Phi, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - - Error_Flag = .FALSE. - - CALL Obj % getSUPG_For_Scalar_6( Phi = Phi, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_12.part", & - "getSUPG_For_Scalar_12()", & - "Traceback ---> CALL Obj % getSUPG_For_Scalar_6( Phi = Phi, C = C )") - - END IF -! -END SUBROUTINE getSUPG_For_Scalar_12 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk deleted file mode 100755 index 38becdf74..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk +++ /dev/null @@ -1,190 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_2.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_2 -!------------------------------------------------------------------------------ - - SUBROUTINE getSUPG_For_Scalar_2( Obj, Phi, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C is space-nodal values, and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( Phi, 2 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( Phi, 2 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPS = 1, NIPS - - DO IPT = 1, NIPT - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, SpaceNodalValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - STNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_2 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part deleted file mode 100755 index c663ea3a0..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part +++ /dev/null @@ -1,204 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_2.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== - -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_2 -!------------------------------------------------------------------------------ - - SUBROUTINE getSUPG_For_Scalar_2( Obj, Phi, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C is space-nodal values, and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - - ! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT -#ifdef DEBUG_VER - INTEGER( I4B ) :: NSD, NNS, NNT -#endif - - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - CLASS( STShapeData_ ), POINTER :: SD => NULL( ) - - - Error_Flag = .FALSE. - -#ifdef DEBUG_VER - ! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - -#ifdef DEBUG_VER - ! Flag-2 - - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - - ! Flag-3 - IF( SIZE( Phi, 2 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( Phi, 2 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - - ! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - - ! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & - "getSUPG_For_Scalar_2()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF -#endif - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - SD => Obj % SD( IPS, IPT ) - - CALL SD % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, SpaceNodalValues = C ) - - CALL SD % getUnitNormalOfScalar( & - STNodalValues = Phi, R = R ) - - CALL SD % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( SD % dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - - Tau12 = 0.0_DFP - - ELSE - - Tau12 = d1 / DummyReal - - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - NULLIFY( SD ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_2 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part deleted file mode 100755 index 6390b1b9f..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part +++ /dev/null @@ -1,178 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_3.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_3 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_3( Obj, Phi, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C is constant, and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & - "getSUPG_For_Scalar_3()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & - "getSUPG_For_Scalar_3()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( Phi, 2 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & - "getSUPG_For_Scalar_3()", & - "SIZE( Phi, 2 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & - "getSUPG_For_Scalar_3()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPS = 1, NIPS - - DO IPT = 1, NIPT - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - STNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_3 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part deleted file mode 100755 index 150ec9ff3..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part +++ /dev/null @@ -1,189 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_4.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_4 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_4( Obj, Phi, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C is space-time nodal values, Phi is space-nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & - "getSUPG_For_Scalar_4()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & - "getSUPG_For_Scalar_4()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & - "getSUPG_For_Scalar_4()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & - "getSUPG_For_Scalar_4()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & - "getSUPG_For_Scalar_4()", & - "SIZE( C, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPS = 1, NIPS - - DO IPT = 1, NIPT - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, STNodalValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - SpaceNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_4 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part deleted file mode 100755 index 8668e6382..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part +++ /dev/null @@ -1,178 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_5.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_5 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_5( Obj, Phi, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C is space-nodal values, and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & - "getSUPG_For_Scalar_5()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & - "getSUPG_For_Scalar_5()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & - "getSUPG_For_Scalar_5()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & - "getSUPG_For_Scalar_5()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPS = 1, NIPS - - DO IPT = 1, NIPT - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, SpaceNodalValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - SpaceNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_5 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part deleted file mode 100755 index d1de8bc07..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part +++ /dev/null @@ -1,166 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_6.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_6 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_6( Obj, Phi, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C is constant, and Phi is space-nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_6.part", & - "getSUPG_For_Scalar_6()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_6.part", & - "getSUPG_For_Scalar_6()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_6.part", & - "getSUPG_For_Scalar_6()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPS = 1, NIPS - - DO IPT = 1, NIPT - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - SpaceNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_6 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part deleted file mode 100755 index 7bae30eb1..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part +++ /dev/null @@ -1,234 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_7.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_7 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_7( Obj, Phi, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( Phi, 2 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "SIZE( Phi, 2 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "SIZE( C, 3 ) should be equal to the NNT or NIPT") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'STNodalValues', 'ST Nodal Values') - - CALL Obj % getSUPG_For_Scalar_1( Phi = Phi, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "Traceback ---> CALL Obj % getSUPG_For_Scalar_1( Phi = Phi, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - STNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & - "getSUPG_For_Scalar_7()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'STNodalValues', 'ST Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_7 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part deleted file mode 100755 index 5106188a3..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part +++ /dev/null @@ -1,222 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_8.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_8 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_8( Obj, Phi, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & - "getSUPG_For_Scalar_8()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( Phi, 1 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & - "getSUPG_For_Scalar_8()", & - "SIZE( Phi, 1 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( Phi, 2 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & - "getSUPG_For_Scalar_8()", & - "SIZE( Phi, 2 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & - "getSUPG_For_Scalar_8()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & - "getSUPG_For_Scalar_8()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'SpaceNodalValues', 'Space Nodal Values') - - CALL Obj % getSUPG_For_Scalar_2( Phi = Phi, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & - "getSUPG_For_Scalar_8()", & - "Traceback ---> CALL Obj % getSUPG_For_Scalar_2( Phi = Phi, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & - STNodalValues = Phi, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & - "getSUPG_For_Scalar_8()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'SpaceNodalValues', 'Space Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Scalar_8 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part deleted file mode 100755 index cd4b4c30f..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part +++ /dev/null @@ -1,64 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Scalar_9.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Scalar_9 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Scalar_9( Obj, Phi, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - - Error_Flag = .FALSE. - - CALL Obj % getSUPG_For_Scalar_3( Phi = Phi, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_9.part", & - "getSUPG_For_Scalar_9()", & - "Traceback ---> CALL Obj % getSUPG_For_Scalar_3( Phi = Phi, C = C )") - - END IF -! -END SUBROUTINE getSUPG_For_Scalar_9 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part deleted file mode 100755 index bfe2c1ba5..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part +++ /dev/null @@ -1,211 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_1.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_1 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_1( Obj, U, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & - "getSUPG_For_Vector_1()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & - "getSUPG_For_Vector_1()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & - "getSUPG_For_Vector_1()", & - "SIZE( U, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( U, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & - "getSUPG_For_Vector_1()", & - "SIZE( U, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & - "getSUPG_For_Vector_1()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & - "getSUPG_For_Vector_1()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-7 - IF( SIZE( C, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & - "getSUPG_For_Vector_1()", & - "SIZE( C, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, STNodalValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - STNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_1 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part deleted file mode 100755 index 7e7e030e9..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part +++ /dev/null @@ -1,234 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_10.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_10 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_10( Obj, U, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "SIZE( U, 2 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "SIZE( C, 3 ) should be equal to the NNT or NIPT") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'STNodalValues', 'ST Nodal Values') - - CALL Obj % getSUPG_For_Vector_4( U = U, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "Traceback ---> CALL Obj % getSUPG_For_Vector_4( U = U, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - SpaceNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & - "getSUPG_For_Vector_10()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'STNodalValues', 'ST Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_10 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part deleted file mode 100755 index 19b473bfa..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part +++ /dev/null @@ -1,222 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_11.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_11 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_11( Obj, U, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & - "getSUPG_For_Vector_11()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & - "getSUPG_For_Vector_11()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & - "getSUPG_For_Vector_11()", & - "SIZE( U, 2 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & - "getSUPG_For_Vector_11()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & - "getSUPG_For_Vector_11()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'SpaceNodalValues', 'Space Nodal Values') - - CALL Obj % getSUPG_For_Vector_5( U = U, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & - "getSUPG_For_Vector_11()", & - "Traceback ---> CALL Obj % getSUPG_For_Vector_5( U = U, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - SpaceNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & - "getSUPG_For_Vector_11()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'SpaceNodalValues', 'Space Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_11 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part deleted file mode 100755 index d4459e20e..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part +++ /dev/null @@ -1,62 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_12.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_12 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_12( Obj, U, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType -! - CALL Obj % getSUPG_For_Vector_6( U = U, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_12.part", & - "getSUPG_For_Vector_12()", & - "Traceback ---> CALL Obj % getSUPG_For_Vector_6( U = U, C = C )") - - END IF -! -END SUBROUTINE getSUPG_For_Vector_12 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part deleted file mode 100755 index d096d2910..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part +++ /dev/null @@ -1,199 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_2.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_2 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_2( Obj, U, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & - "getSUPG_For_Vector_2()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & - "getSUPG_For_Vector_2()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & - "getSUPG_For_Vector_2()", & - "SIZE( U, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( U, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & - "getSUPG_For_Vector_2()", & - "SIZE( U, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & - "getSUPG_For_Vector_2()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & - "getSUPG_For_Vector_2()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, SpaceNodalValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - STNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_2 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part deleted file mode 100755 index 7f9769305..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part +++ /dev/null @@ -1,188 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_3.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_3 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_3( Obj, U, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & - "getSUPG_For_Vector_3()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & - "getSUPG_For_Vector_3()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & - "getSUPG_For_Vector_3()", & - "SIZE( U, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( U, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & - "getSUPG_For_Vector_3()", & - "SIZE( U, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & - "getSUPG_For_Vector_3()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - STNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_3 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part deleted file mode 100755 index 08b17fbfe..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part +++ /dev/null @@ -1,200 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_4.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_4 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_4( Obj, U, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & - "getSUPG_For_Vector_4()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & - "getSUPG_For_Vector_4()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & - "getSUPG_For_Vector_4()", & - "SIZE( U, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & - "getSUPG_For_Vector_4()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & - "getSUPG_For_Vector_4()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & - "getSUPG_For_Vector_4()", & - "SIZE( C, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, STNodalValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - SpaceNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_4 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part deleted file mode 100755 index 85b2e8f98..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part +++ /dev/null @@ -1,189 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_5.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_5 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_5( Obj, U, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & - "getSUPG_For_Vector_5()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & - "getSUPG_For_Vector_5()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & - "getSUPG_For_Vector_5()", & - "SIZE( U, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & - "getSUPG_For_Vector_5()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & - "getSUPG_For_Vector_5()", & - "SIZE( C, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, SpaceNodalValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - SpaceNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_5 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part deleted file mode 100755 index 23798386c..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part +++ /dev/null @@ -1,177 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_6.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_6 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_6( Obj, U, C, Mu ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & - "getSUPG_For_Vector_6()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & - "getSUPG_For_Vector_6()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & - "getSUPG_For_Vector_6()", & - "SIZE( U, 2 ) should be equal to the NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & - "getSUPG_For_Vector_6()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - SpaceNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_6 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part deleted file mode 100755 index 385c17f23..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part +++ /dev/null @@ -1,245 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_7.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_7 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_7( Obj, U, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "SIZE( U, 2 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "SIZE( U, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-6 - IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "SIZE( C, 3 ) should be equal to the NNT or NIPT") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'STNodalValues', 'ST Nodal Values') - - CALL Obj % getSUPG_For_Vector_1( U = U, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "Traceback ---> CALL Obj % getSUPG_For_Vector_1( U = U, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - STNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & - "getSUPG_For_Vector_7()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'STNodalValues', 'ST Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_7 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part deleted file mode 100755 index bd8dab7f7..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part +++ /dev/null @@ -1,234 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_8.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_8 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_8( Obj, U, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! Define internal variables - INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT - REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & - dNTdt( :, : ) - REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & - pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP - - - Error_Flag = .FALSE. - -! Flag-1 - IF( .NOT. Obj % isInitiated( ) ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "ST_Tau_SUPG_RGN_ Object is not initiated") - Error_Flag = .TRUE. - RETURN - - END IF - - NIPS = Obj % getNIPS( ) - NIPT = Obj % getNIPT( ) - NSD = Obj % SD( 1, 1 ) % getNSD( ) - NNS = Obj % SD( 1, 1 ) % getNNS( ) - NNT = Obj % SD( 1, 1 ) % getNNT( ) - -! Flag-2 - IF( SIZE( U, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "SIZE( U, 1 ) Should be equal to NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 2 ) .NE. NNS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "SIZE( U, 2 ) Should be equal to NNS") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-3 - IF( SIZE( U, 3 ) .NE. NNT ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "SIZE( U, 3 ) should be equal to the NNT") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-4 - IF( SIZE( C, 1 ) .NE. NSD ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "SIZE( C, 1 ) should be equal to the NSD") - Error_Flag = .TRUE. - RETURN - - END IF - -! Flag-5 - IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "SIZE( C, 2 ) should be equal to the NNS or NIPS") - Error_Flag = .TRUE. - RETURN - - END IF - - - IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) - ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) - Obj % Mat2 = 0.0_DFP - - SELECT CASE( TRIM( ADJUSTL( CType ) ) ) - - CASE( 'Nodal', 'Nodal Values', 'NodalValues', & - 'SpaceNodalValues', 'Space Nodal Values') - - CALL Obj % getSUPG_For_Vector_2( U = U, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "Traceback ---> CALL Obj % getSUPG_For_Vector_2( U = U, C = C )") - - END IF - - CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & - 'Quad', 'QuadPoints', 'Quad Points' ) - - DO IPT = 1, NIPT - - DO IPS = 1, NIPS - - CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) - - CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & - STNodalValues = U, R = R ) - - CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & - cdNTdXt = rdNTdXt, VectorValues = R ) - - ! Make Tau3 - - DummyReal = SUM( ABS( rdNTdXt ) ) - IF( DummyReal .LE. zero ) THEN - h = 0.0_DFP - ELSE - h = d2 / DummyReal - END IF - - Tau3 = h * h / d4 / mu - - ! Make Tau12 - - DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) - - IF( DummyReal .LE. zero ) THEN - Tau12 = 0.0_DFP - ELSE - Tau12 = d1 / DummyReal - END IF - - ! Make Tau SUPG - - TauSUPG = 0.0_DFP - - IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN - - TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) - - ELSE - - TauSUPG = MAXVAL( (/Tau12, Tau3/) ) - - END IF - - ! Set the value in Mat2 - Obj % Mat2( IPS, IPT ) = TauSUPG - - END DO - - END DO - - CASE DEFAULT - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & - "getSUPG_For_Vector_8()", & - "No case found for given CType it should be & - & 'Nodal', 'Nodal Values', 'NodalValues', & - & 'SpaceNodalValues', 'Space Nodal Values', & - & 'Integration', 'IntegrationPoints', 'Integration Points', & - & 'Quad', 'QuadPoints', 'Quad Points' ") - Error_Flag = .TRUE. - RETURN - - - END SELECT - - IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) - IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) - IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) - IF( ALLOCATED( R ) ) DEALLOCATE( R ) -! -END SUBROUTINE getSUPG_For_Vector_8 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part deleted file mode 100755 index deeb5d367..000000000 --- a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part +++ /dev/null @@ -1,63 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: SUPG_Vector_9.part -! Last Update : Nov-25-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! TYPE :: Part of the Code -! -! DESCRIPTION -! - This code is part of the code -! -! HOSTING FILE -! - ST_Tau_SUPG_RGN_Class.f90 -! -!============================================================================== -! -!------------------------------------------------------------------------------ -! getSUPG_For_Vector_9 -!------------------------------------------------------------------------------ -! - SUBROUTINE getSUPG_For_Vector_9( Obj, U, C, Mu, CType ) -! -! DESCRIPTION -!------------------------------------------------------------------------------ -! 1. - Returns Tau SUPG for scalar unknown; & -! C and Phi are space-time nodal values -!------------------------------------------------------------------------------ -! -! Define intent of dummy variables - -#ifdef STMat - CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj -#else - CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj -#endif - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C - REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U - REAL( DFP ), INTENT( IN ) :: Mu - CHARACTER( LEN = * ), INTENT( IN ) :: CType - -! - CALL Obj % getSUPG_For_Vector_3( U = U, C = C, Mu = Mu ) - - IF( Error_Flag ) THEN - - CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_9.part", & - "getSUPG_For_Vector_9()", & - "Traceback ---> CALL Obj % getSUPG_For_Vector_3( U = U, C = C )") - - END IF -! -END SUBROUTINE getSUPG_For_Vector_9 -! -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -! diff --git a/src/submodules/StiffnessMatrix/CMakeLists.txt b/src/submodules/StiffnessMatrix/CMakeLists.txt deleted file mode 100644 index 931cf6240..000000000 --- a/src/submodules/StiffnessMatrix/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 1/03/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/StiffnessMatrix_Method@Methods.F90 - ) diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 deleted file mode 100644 index 11e983a30..000000000 --- a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 +++ /dev/null @@ -1,338 +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(StiffnessMatrix_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! StiffnessMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_StiffnessMatrix1 -REAL(DFP), ALLOCATABLE :: realval(:), CBar(:, :, :), & - & Ce(:, :), BMat1(:, :), BMat2(:, :) -INTEGER(I4B) :: nips, nns1, nns2, i, j, ips, nsd -INTEGER(I4B), ALLOCATABLE :: indx(:, :) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = SIZE(trial%dNdXt, 2) - -CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) -CALL GetInterpolation(obj=test, interpol=CBar, val=Cijkl) - -SELECT CASE (nsd) -CASE (1) - ALLOCATE (indx(1, 1)) - indx = 1 -CASE (2) - ALLOCATE (indx(2, 2)) - indx = RESHAPE([1, 3, 3, 2], [2, 2]) -CASE (3) - ALLOCATE (indx(3, 3)) - indx = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3]) -END SELECT - -ALLOCATE (Ce(nsd * nsd, nsd * nsd), BMat1(nsd * nns1, nsd * nsd), & - & BMat2(nsd * nns2, nsd * nsd)) - -BMat1 = 0.0_DFP -BMat2 = 0.0_DFP - -CALL Reallocate(realval, nips) -realval = trial%ws * trial%js * trial%thickness - -DO ips = 1, nips - - DO j = 1, nsd - DO i = 1, nsd - Ce((i - 1) * nsd + 1:i * nsd, (j - 1) * nsd + 1:j * nsd) & - & = CBar(indx(:, i), indx(:, j), ips) - END DO - END DO - - DO i = 1, nsd - BMat1((i - 1) * nns1 + 1:i * nns1, (i - 1) * nsd + 1:i * nsd) = & - & test%dNdXt(:, :, ips) - BMat2((i - 1) * nns2 + 1:i * nns2, (i - 1) * nsd + 1:i * nsd) = & - & trial%dNdXt(:, :, ips) - END DO - - ans = ans + realval(ips) * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2)) - -END DO - -DEALLOCATE (BMat1, BMat2, indx, Ce, CBar, realval) - -END PROCEDURE obj_StiffnessMatrix1 - -!---------------------------------------------------------------------------- -! StiffnessMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_StiffnessMatrix2 -! Define internal variable -REAL(DFP), ALLOCATABLE :: lambdaBar(:), muBar(:), & - & realval(:), Ke11(:, :) -REAL(DFP) :: real1, real2, real3 -INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, i, j, r1, r2, ips -LOGICAL(LGT) :: case1 -TYPE(FEVariable_) :: lambda0 - -IF (PRESENT(isLambdaYoungsModulus)) THEN - case1 = isLambdaYoungsModulus -ELSE - case1 = .FALSE. -END IF - -IF (case1) THEN - CALL GetLambdaFromYoungsModulus(lambda=lambda0, & - & youngsModulus=lambda, shearModulus=mu) -ELSE - lambda0 = lambda -END IF - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = SIZE(trial%dNdXt, 2) - -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 Reallocate(realval, nips) -realval = trial%ws * trial%js * trial%thickness - -DO ips = 1, nips - real1 = muBar(ips) * realval(ips) - real2 = (lambdaBar(ips) + muBar(ips)) * realval(ips) - real3 = lambdaBar(ips) * realval(ips) - c1 = 0 - c2 = 0 - DO j = 1, nsd - c1 = c2 + 1 - c2 = j * nns2 - r1 = 0 - r2 = 0 - DO i = 1, nsd - r1 = r2 + 1 - r2 = i * nns1 - IF (i .EQ. j) THEN - Ke11 = real1 * MATMUL( & - & test%dNdXt(:, :, ips), & - & TRANSPOSE(trial%dNdXt(:, :, ips))) & - & + real2 * OUTERPROD( & - & test%dNdXt(:, i, ips), & - & trial%dNdXt(:, i, ips)) - ELSE - Ke11 = real3 * OUTERPROD( & - & test%dNdXt(:, i, ips), & - & trial%dNdXt(:, j, ips)) & - + real1 * & - & OUTERPROD( & - & test%dNdXt(:, j, ips), & - & trial%dNdXt(:, i, ips)) - END IF - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11 - END DO - END DO -END DO - -DEALLOCATE (realval, Ke11, lambdaBar, muBar) -CALL DEALLOCATE (lambda0) - -END PROCEDURE obj_StiffnessMatrix2 - -!---------------------------------------------------------------------------- -! Stiffnessmatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_StiffnessMatrix3 -INTEGER(I4B) :: nns1, nns2, nips, ips, nsd, c1, c2, r1, r2, i, j -REAL(DFP), ALLOCATABLE :: realval(:), Ke11(:, :) -REAL(DFP) :: real1, real2, real3 -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = SIZE(trial%dNdXt, 2) - -CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) -CALL Reallocate(realval, nips) -realval = trial%ws * trial%thickness * trial%js - -DO ips = 1, nips - real1 = mu * realval(ips) - real2 = (lambda + mu) * realval(ips) - real3 = lambda * realval(ips) - c1 = 0; c2 = 0; - DO j = 1, nsd - c1 = c2 + 1; c2 = j * nns2; r1 = 0; r2 = 0 - DO i = 1, nsd - r1 = r2 + 1; r2 = i * nns1 - IF (i .EQ. j) THEN - Ke11 = real1 * MATMUL(test%dNdXt(:, :, ips), & - & TRANSPOSE(trial%dNdXt(:, :, ips))) & - & + real2 * OUTERPROD(test%dNdXt(:, i, ips), & - & trial%dNdXt(:, i, ips)) - ELSE - Ke11 = real3 * OUTERPROD(test%dNdXt(:, i, ips), & - & trial%dNdXt(:, j, ips)) & - + real1 * & - & OUTERPROD(test%dNdXt(:, j, ips), & - & trial%dNdXt(:, i, ips)) - END IF - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11 - END DO - END DO -END DO - -DEALLOCATE (realval, Ke11) -END PROCEDURE obj_StiffnessMatrix3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_StiffnessMatrix4 -REAL(DFP), ALLOCATABLE :: realval(:), Ce(:, :), BMat1(:, :), BMat2(:, :) -INTEGER(I4B) :: nips, nns1, nns2, i, j, ips, nsd -INTEGER(I4B), ALLOCATABLE :: indx(:, :) - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = SIZE(trial%dNdXt, 2) - -CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) - -SELECT CASE (nsd) -CASE (1) - ALLOCATE (indx(1, 1)) - indx = 1 -CASE (2) - ALLOCATE (indx(2, 2)) - indx = RESHAPE([1, 3, 3, 2], [2, 2]) -CASE (3) - ALLOCATE (indx(3, 3)) - indx = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3]) -END SELECT - -ALLOCATE (Ce(nsd * nsd, nsd * nsd), & - & BMat1(nsd * nns1, nsd * nsd), & - & BMat2(nsd * nns2, nsd * nsd)) - -BMat1 = 0.0_DFP -BMat2 = 0.0_DFP - -CALL Reallocate(realval, nips) -realval = trial%ws * trial%js * trial%thickness - -DO ips = 1, nips - - DO j = 1, nsd - DO i = 1, nsd - Ce((i - 1) * nsd + 1:i * nsd, (j - 1) * nsd + 1:j * nsd) & - & = Cijkl(indx(:, i), indx(:, j)) - END DO - END DO - - DO i = 1, nsd - BMat1((i - 1) * nns1 + 1:i * nns1, (i - 1) * nsd + 1:i * nsd) = & - & test%dNdXt(:, :, ips) - BMat2((i - 1) * nns2 + 1:i * nns2, (i - 1) * nsd + 1:i * nsd) = & - & trial%dNdXt(:, :, ips) - END DO - - ans = ans + realval(ips) * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2)) - -END DO - -DEALLOCATE (BMat1, BMat2, indx, Ce, realval) - -END PROCEDURE obj_StiffnessMatrix4 - -!---------------------------------------------------------------------------- -! StiffnessMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_StiffnessMatrix5 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:), Ke11(:, :) -REAL(DFP) :: real1, real2, real3 -INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, i, j, r1, r2, ips - -nns1 = SIZE(test%N, 1) -nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2) -nsd = SIZE(trial%dNdXt, 2) - -CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) -ans = 0.0_DFP - -CALL Reallocate(realval, nips) -realval = trial%ws * trial%js * trial%thickness - -DO ips = 1, nips - real1 = mu(ips) * realval(ips) - real2 = (lambda(ips) + mu(ips)) * realval(ips) - real3 = lambda(ips) * realval(ips) - c1 = 0 - c2 = 0 - DO j = 1, nsd - c1 = c2 + 1 - c2 = j * nns2 - r1 = 0 - r2 = 0 - DO i = 1, nsd - r1 = r2 + 1 - r2 = i * nns1 - IF (i .EQ. j) THEN - Ke11 = real1 * MATMUL( & - & test%dNdXt(:, :, ips), & - & TRANSPOSE(trial%dNdXt(:, :, ips))) & - & + real2 * OUTERPROD( & - & test%dNdXt(:, i, ips), & - & trial%dNdXt(:, i, ips)) - ELSE - Ke11 = real3 * OUTERPROD( & - & test%dNdXt(:, i, ips), & - & trial%dNdXt(:, j, ips)) & - + real1 * & - & OUTERPROD( & - & test%dNdXt(:, j, ips), & - & trial%dNdXt(:, i, ips)) - END IF - ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11 - END DO - END DO -END DO - -DEALLOCATE (realval, Ke11) - -END PROCEDURE obj_StiffnessMatrix5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/TriangleInterface/CMakeLists.txt b/src/submodules/TriangleInterface/CMakeLists.txt deleted file mode 100644 index d8f4bc2fd..000000000 --- a/src/submodules/TriangleInterface/CMakeLists.txt +++ /dev/null @@ -1,21 +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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/TriangleInterface@Methods.F90) diff --git a/src/submodules/TriangleInterface/src/TriangleInterface@Methods.F90 b/src/submodules/TriangleInterface/src/TriangleInterface@Methods.F90 deleted file mode 100644 index 4e4f44939..000000000 --- a/src/submodules/TriangleInterface/src/TriangleInterface@Methods.F90 +++ /dev/null @@ -1,179 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(TriangleInterface) Methods -USE ISO_C_BINDING, ONLY: C_LOC, C_F_POINTER, C_ASSOCIATED -USE Display_Method, ONLY: MyDisplay => Display -IMPLICIT NONE - -#include "./definemacro.h" - -CONTAINS - -!---------------------------------------------------------------------------- -! TriangleReport -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriangleDeallocate -CALL TriangleFree(obj) -CALL TriangleNullify(obj) -END PROCEDURE TriangleDeallocate - -!---------------------------------------------------------------------------- -! TriangleSetParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriangleSetParam -IF (PRESENT(pointlist)) obj%pointlist = C_LOC(pointlist) -IF (PRESENT(pointattributelist)) obj%pointattributelist = & - C_LOC(pointattributelist) -IF (PRESENT(pointmarkerlist)) obj%pointmarkerlist = C_LOC(pointmarkerlist) -IF (PRESENT(numberofpoints)) obj%numberofpoints = numberofpoints -IF (PRESENT(numberofpointattributes)) obj%numberofpointattributes = & - numberofpointattributes -IF (PRESENT(trianglelist)) obj%trianglelist = C_LOC(trianglelist) -IF (PRESENT(triangleattributelist)) obj%triangleattributelist = & - C_LOC(triangleattributelist) -IF (PRESENT(trianglearealist)) obj%trianglearealist = C_LOC(trianglearealist) -IF (PRESENT(neighborlist)) obj%neighborlist = C_LOC(neighborlist) -IF (PRESENT(numberoftriangles)) obj%numberoftriangles = numberoftriangles -IF (PRESENT(numberofcorners)) obj%numberofcorners = numberofcorners -IF (PRESENT(numberoftriangleattributes)) obj%numberoftriangleattributes = & - numberoftriangleattributes -IF (PRESENT(segmentlist)) obj%segmentlist = C_LOC(segmentlist) -IF (PRESENT(segmentmarkerlist)) obj%segmentmarkerlist = & - C_LOC(segmentmarkerlist) -IF (PRESENT(numberofsegments)) obj%numberofsegments = numberofsegments -IF (PRESENT(holelist)) obj%holelist = C_LOC(holelist) -IF (PRESENT(numberofholes)) obj%numberofholes = numberofholes -IF (PRESENT(regionlist)) obj%regionlist = C_LOC(regionlist) -IF (PRESENT(numberofregions)) obj%numberofregions = numberofregions -IF (PRESENT(edgelist)) obj%edgelist = C_LOC(edgelist) -IF (PRESENT(edgemarkerlist)) obj%edgemarkerlist = C_LOC(edgemarkerlist) -IF (PRESENT(numberofedges)) obj%numberofedges = numberofedges -IF (PRESENT(normlist)) obj%normlist = C_LOC(normlist) -END PROCEDURE TriangleSetParam - -!---------------------------------------------------------------------------- -! TriangleGetParam -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriangleGetParam -C2F(pointlist, obj%numberofpoints) -C2F(pointattributelist, obj%numberofpointattributes * obj%numberofpoints) -C2F(pointmarkerlist, obj%numberofpoints) -SimpleSet(numberofpoints) -SimpleSet(numberofpointattributes) -C2F(trianglelist, obj%numberofcorners * obj%numberoftriangles) -C2F(triangleattributelist, obj%numberoftriangleattributes * obj%numberoftriangles) -C2F(trianglearealist, obj%numberoftriangles) -C2F(neighborlist, 3 * obj%numberoftriangles) -SimpleSet(numberoftriangles) -SimpleSet(numberofcorners) -SimpleSet(numberoftriangleattributes) -C2F(segmentlist, 2 * obj%numberofsegments) -C2F(segmentmarkerlist, obj%numberofsegments) -SimpleSet(numberofsegments) -C2F(holelist, 2 * obj%numberofholes) -SimpleSet(numberofholes) -C2F(regionlist, 4 * obj%numberofregions) -SimpleSet(numberofregions) -C2F(edgelist, 2 * obj%numberofedges) -C2F(edgemarkerlist, obj%numberofedges) -C2F(normlist, 2 * obj%numberofedges) -SimpleSet(numberofedges) -END PROCEDURE TriangleGetParam - -!---------------------------------------------------------------------------- -! TriangleNullify -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriangleNullify -MyNullify(pointlist) -MyNullify(pointattributelist) -MyNullify(pointmarkerlist) -MyNullify(trianglelist) -MyNullify(triangleattributelist) -MyNullify(trianglearealist) -MyNullify(neighborlist) -MyNullify(segmentlist) -MyNullify(segmentmarkerlist) -MyNullify(holelist) -MyNullify(regionlist) -MyNullify(edgelist) -MyNullify(edgemarkerlist) -MyNullify(normlist) -SimpleNull(numberofpoints) -SimpleNull(numberofpointattributes) -SimpleNull(numberoftriangles) -SimpleNull(numberofcorners) -SimpleNull(numberoftriangleattributes) -SimpleNull(numberofsegments) -SimpleNull(numberofholes) -SimpleNull(numberofregions) -SimpleNull(numberofedges) -END PROCEDURE TriangleNullify - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriangleDisplay - -CALL DisplayPtr("pointlist", obj%pointlist) -CALL DisplayPtr("pointattributelist", obj%pointattributelist) -CALL DisplayPtr("pointmarkerlist", obj%pointmarkerlist) -CALL DisplayPtr("trianglelist", obj%trianglelist) -CALL DisplayPtr("triangleattributelist", obj%triangleattributelist) -CALL DisplayPtr("trianglearealist", obj%trianglearealist) -CALL DisplayPtr("neighborlist", obj%neighborlist) -CALL DisplayPtr("segmentlist", obj%segmentlist) -CALL DisplayPtr("segmentmarkerlist", obj%segmentmarkerlist) -CALL DisplayPtr("holelist", obj%holelist) -CALL DisplayPtr("regionlist", obj%regionlist) -CALL DisplayPtr("edgelist", obj%edgelist) -CALL DisplayPtr("edgemarkerlist", obj%edgemarkerlist) -CALL DisplayPtr("normlist", obj%normlist) - -CALL MyDisplay(obj%numberofpoints, "numberofpoints: ", unitno=unitno) -CALL MyDisplay(obj%numberofpointattributes,"numberofpointattributes: ",unitno=unitno) -CALL MyDisplay(obj%numberoftriangles, "numberoftriangles: ", unitno=unitno) -CALL MyDisplay(obj%numberofcorners, "numberofcorners: ", unitno=unitno) -CALL MyDisplay(obj%numberoftriangleattributes,"numberoftriangleattributes: ",unitno=unitno) -CALL MyDisplay(obj%numberofsegments, "numberofsegments: ", unitno=unitno) -CALL MyDisplay(obj%numberofholes, "numberofholes: ", unitno=unitno) -CALL MyDisplay(obj%numberofregions, "numberofregions: ", unitno=unitno) -CALL MyDisplay(obj%numberofedges, "numberofedges: ", unitno=unitno) - -CONTAINS - -SUBROUTINE DisplayPtr(myname, cptr) - CHARACTER(*), INTENT(in) :: myname - TYPE(C_PTR), INTENT(in) :: cptr - - LOGICAL(LGT) :: abool - abool = C_ASSOCIATED(cptr) - CALL MyDisplay(abool, myname//" ASSOCIATED: ", unitno=unitno) -END SUBROUTINE DisplayPtr - -END PROCEDURE TriangleDisplay - -#include "./undefinemacro.h" - -END SUBMODULE Methods diff --git a/src/submodules/TriangleInterface/src/definemacro.h b/src/submodules/TriangleInterface/src/definemacro.h deleted file mode 100644 index 95f27126b..000000000 --- a/src/submodules/TriangleInterface/src/definemacro.h +++ /dev/null @@ -1,4 +0,0 @@ -#define C2F(a, c) IF(PRESENT(a)) CALL C_F_POINTER(obj % a, a, [c]) -#define MyNullify(a) obj % a = C_NULL_PTR -#define SimpleSet(a) IF(PRESENT(a)) a = obj % a -#define SimpleNull(a) obj % a = 0 diff --git a/src/submodules/TriangleInterface/src/undefinemacro.h b/src/submodules/TriangleInterface/src/undefinemacro.h deleted file mode 100644 index d7c0433ae..000000000 --- a/src/submodules/TriangleInterface/src/undefinemacro.h +++ /dev/null @@ -1,4 +0,0 @@ -#undef C2F -#undef SimpleSet -#undef SimpleNull -#undef MyNullify diff --git a/src/submodules/Utility/CMakeLists.txt b/src/submodules/Utility/CMakeLists.txt deleted file mode 100644 index c67eb1a0d..000000000 --- a/src/submodules/Utility/CMakeLists.txt +++ /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 -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources( - ${PROJECT_NAME} - PRIVATE ${src_path}/MappingUtility@Methods.F90 - ${src_path}/BinomUtility@Methods.F90 - ${src_path}/MedianUtility@Methods.F90 - ${src_path}/PartitionUtility@Methods.F90 - ${src_path}/SortUtility@Methods.F90 - ${src_path}/SwapUtility@Methods.F90 - ${src_path}/ConvertUtility@Methods.F90 - ${src_path}/ReallocateUtility@Methods.F90 - ${src_path}/ProductUtility@Methods.F90 - ${src_path}/ArangeUtility@Methods.F90 - ${src_path}/GridPointUtility@Methods.F90 - ${src_path}/HeadUtility@Methods.F90 - ${src_path}/TailUtility@Methods.F90 - ${src_path}/SplitUtility@Methods.F90 - ${src_path}/OnesUtility@Methods.F90 - ${src_path}/ZerosUtility@Methods.F90 - ${src_path}/EyeUtility@Methods.F90 - ${src_path}/DiagUtility@Methods.F90 - ${src_path}/AppendUtility@Methods.F90 - ${src_path}/InputUtility@Methods.F90 - ${src_path}/InvUtility@Methods.F90 - ${src_path}/MatmulUtility@Methods.F90 - ${src_path}/ContractionUtility@Methods.F90 - ${src_path}/AssertUtility@Methods.F90 - ${src_path}/ApproxUtility@Methods.F90 - ${src_path}/HashingUtility@Methods.F90 - ${src_path}/MiscUtility@Methods.F90 - ${src_path}/StringUtility@Methods.F90 - ${src_path}/IntegerUtility@Methods.F90 - ${src_path}/PushPopUtility@Methods.F90 - ${src_path}/EigenUtility@Methods.F90 - ${src_path}/SymUtility@Methods.F90 - ${src_path}/TriagUtility@Methods.F90 - ${src_path}/LinearAlgebraUtility@Methods.F90 - ${src_path}/SafeSizeUtility@Methods.F90) diff --git a/src/submodules/Utility/src/Append/Append_1.inc b/src/submodules/Utility/src/Append/Append_1.inc deleted file mode 100644 index 4b1b512c0..000000000 --- a/src/submodules/Utility/src/Append/Append_1.inc +++ /dev/null @@ -1,23 +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 - -IF (.NOT. ALLOCATED(A)) THEN - A = [Entry] -ELSE - n = SIZE(A); ALLOCATE (Dummy(n + 1)) - Dummy(1:n) = A; Dummy(1 + n) = Entry - CALL MOVE_ALLOC(From=Dummy, TO=A) -END IF diff --git a/src/submodules/Utility/src/Append/Append_1cd.inc b/src/submodules/Utility/src/Append/Append_1cd.inc deleted file mode 100644 index a49942938..000000000 --- a/src/submodules/Utility/src/Append/Append_1cd.inc +++ /dev/null @@ -1,27 +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 -! -INTEGER(I4B) :: n -!! -n = SIZE(A) -!! -IF( n .NE. 0 ) THEN - CALL Reallocate( C, n+1 ) - C(1:n) = A; C(1 + n) = B -ELSE - C = [B] -END IF -!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Append/Append_2.inc b/src/submodules/Utility/src/Append/Append_2.inc deleted file mode 100644 index c293643fb..000000000 --- a/src/submodules/Utility/src/Append/Append_2.inc +++ /dev/null @@ -1,40 +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 -! - - -IF (.NOT. ALLOCATED(A)) THEN - IF (SIZE(ENTRY) .NE. 0) THEN - A = ENTRY - ELSE - ALLOCATE (A(0)) - END IF -ELSE - IF( SIZE( A ) .NE. 0 ) THEN - IF (SIZE(ENTRY) .NE. 0) THEN - m = SIZE(ENTRY); n = SIZE(A) - ALLOCATE (Dummy(n + m)); Dummy(1:n) = A; Dummy(n + 1:) = ENTRY - CALL MOVE_ALLOC(From=Dummy, To=A) - END IF - ELSE - IF (SIZE(ENTRY) .NE. 0) THEN - m = SIZE(ENTRY) - ALLOCATE (Dummy(m)) - Dummy(1:) = ENTRY - CALL MOVE_ALLOC(From=Dummy, To=A) - END IF - END IF -END IF diff --git a/src/submodules/Utility/src/Append/Append_2abcd.inc b/src/submodules/Utility/src/Append/Append_2abcd.inc deleted file mode 100644 index 79093c57f..000000000 --- a/src/submodules/Utility/src/Append/Append_2abcd.inc +++ /dev/null @@ -1,29 +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 -! - -INTEGER(I4B) :: na, nb, nc - -na = SIZE( A ) -nb = SIZE( B ) -nc = SIZE( C ) - -CALL Reallocate( D, na+nb+nc ) -IF(na .gt. 0) D(1:na) = A -IF(nb .gt. 0) D(na + 1: na+nb) = B -IF(nc .gt. 0) D(na + nb + 1:) = C - - diff --git a/src/submodules/Utility/src/Append/Append_2cd.inc b/src/submodules/Utility/src/Append/Append_2cd.inc deleted file mode 100644 index 041e9b253..000000000 --- a/src/submodules/Utility/src/Append/Append_2cd.inc +++ /dev/null @@ -1,53 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -INTEGER(I4B) :: na, nb -!! -nb = SIZE( B ) -na = SIZE( A ) -!! -IF( na .NE. 0 ) THEN - !! - !! na not zero - !! - IF ( nb .NE. 0) THEN - !! - !! nb not zero - !! - CALL Reallocate( C, na+nb ) - C(1:na) = A - C(na + 1:) = B - !! - ELSE - C = A - END IF - !! -ELSE - !! - !! na is zero - !! - IF (nb .NE. 0) THEN - !! - !! nb is zero - !! - C = B - ELSE - CALL Reallocate( C, 0 ) - END IF - !! -END IF -!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Append/Append_3.inc b/src/submodules/Utility/src/Append/Append_3.inc deleted file mode 100644 index 18fe71c13..000000000 --- a/src/submodules/Utility/src/Append/Append_3.inc +++ /dev/null @@ -1,27 +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 - -IF( mask ) THEN - IF (.NOT. ALLOCATED(A)) THEN - A = [Entry] - ELSE - n = SIZE(A); ALLOCATE (Dummy(n + 1)) - Dummy(1:n) = A; Dummy(1 + n) = Entry - CALL MOVE_ALLOC(From=Dummy, TO=A) - END IF -ELSE - IF (.NOT. ALLOCATED(A)) ALLOCATE( A( 0 ) ) -END IF diff --git a/src/submodules/Utility/src/Append/Append_3cd.inc b/src/submodules/Utility/src/Append/Append_3cd.inc deleted file mode 100644 index 90dc7ad51..000000000 --- a/src/submodules/Utility/src/Append/Append_3cd.inc +++ /dev/null @@ -1,38 +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 -! - -INTEGER(I4B) :: n -!! -n = SIZE(A) -!! -IF( n .NE. 0 ) THEN - !! - IF( mask ) THEN - CALL Reallocate( C, n+1 ) - C(1:n) = A; C(1 + n) = B - ELSE - CALL Reallocate( C, n ) - C = A - END IF -ELSE - IF( mask ) THEN - C = [B] - ELSE - CALL Reallocate( C, 0 ) - END IF -END IF -!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Append/Append_4.inc b/src/submodules/Utility/src/Append/Append_4.inc deleted file mode 100644 index a7c68b784..000000000 --- a/src/submodules/Utility/src/Append/Append_4.inc +++ /dev/null @@ -1,45 +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 -! - -IF (.NOT. ALLOCATED(A)) THEN - !! - IF (SIZE(ENTRY) .NE. 0) THEN - m = COUNT( mask ) - IF( m .NE. 0 ) THEN - A = PACK( ENTRY, mask ) - ELSE - ALLOCATE( A(0) ) - END IF - ELSE - ALLOCATE (A(0)) - END IF - !! -ELSE - !! - IF (SIZE(ENTRY) .NE. 0) THEN - m = COUNT( mask ) - IF( m .NE. 0 ) THEN - n = SIZE(A) - ALLOCATE (Dummy(n + m)) - Dummy(1:n) = A - Dummy(n + 1:) = PACK( ENTRY, mask ) - CALL MOVE_ALLOC(From=Dummy, To=A) - END IF - END IF -END IF -!! - diff --git a/src/submodules/Utility/src/Append/Append_4cd.inc b/src/submodules/Utility/src/Append/Append_4cd.inc deleted file mode 100644 index 7c84a635b..000000000 --- a/src/submodules/Utility/src/Append/Append_4cd.inc +++ /dev/null @@ -1,63 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -INTEGER(I4B) :: n, m, na, nb, nm -!! -na = SIZE( A ) -nb = SIZE( B ) -!! -IF( na .EQ. 0 ) THEN - !! - !! na zero - !! - IF ( nb .EQ. 0 ) THEN - !! - !! nb is zero - !! - CALL REALLOCATE( C, 0 ) - !! - ELSE - !! - !! nb is not zero - !! - nm = COUNT(mask) - !! - IF( nm .EQ. 0 ) THEN - CALL REALLOCATE( C, 0 ) - ELSE - C = PACK( B, mask ) - END IF - END IF - !! -ELSE - !! - !! na is not zero - !! - IF ( nb .EQ. 0 ) THEN - C = A - ELSE - nm = COUNT(mask) - IF( nm .EQ. 0 ) THEN - C = A - ELSE - CALL Reallocate( C, na + nm ) - C(1:na) = A - C(na + 1:) = PACK( B, mask ) - END IF - END IF -END IF -!! \ No newline at end of file diff --git a/src/submodules/Utility/src/AppendUtility@Methods.F90 b/src/submodules/Utility/src/AppendUtility@Methods.F90 deleted file mode 100644 index 6a8c90211..000000000 --- a/src/submodules/Utility/src/AppendUtility@Methods.F90 +++ /dev/null @@ -1,485 +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(AppendUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE expand_int8 -INTEGER(INT8), ALLOCATABLE :: tmp(:) -#include "./Expand/Expand.inc" -END PROCEDURE expand_int8 - -MODULE PROCEDURE expand_int16 -INTEGER(INT16), ALLOCATABLE :: tmp(:) -#include "./Expand/Expand.inc" -END PROCEDURE expand_int16 - -MODULE PROCEDURE expand_int32 -INTEGER(INT32), ALLOCATABLE :: tmp(:) -#include "./Expand/Expand.inc" -END PROCEDURE expand_int32 - -MODULE PROCEDURE expand_int64 -INTEGER(INT64), ALLOCATABLE :: tmp(:) -#include "./Expand/Expand.inc" -END PROCEDURE expand_int64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE expand_real32 -REAL(REAL32), ALLOCATABLE :: tmp(:) -#include "./Expand/Expand.inc" -END PROCEDURE expand_real32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE expand_real64 -REAL(REAL64), ALLOCATABLE :: tmp(:) -#include "./Expand/Expand.inc" -END PROCEDURE expand_real64 - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_1a -INTEGER(I4B), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n -#include "./Append/Append_1.inc" -END PROCEDURE Append_1a - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_1b -REAL(DFP), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n -#include "./Append/Append_1.inc" -END PROCEDURE Append_1b - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_1c -#include "./Append/Append_1cd.inc" -END PROCEDURE Append_1c - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_1d -#include "./Append/Append_1cd.inc" -END PROCEDURE Append_1d - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_2a -INTEGER(I4B), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n, m -#include "./Append/Append_2.inc" -END PROCEDURE Append_2a - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_2b -REAL(DFP), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n, m -#include "./Append/Append_2.inc" -END PROCEDURE Append_2b - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_2c -#include "./Append/Append_2cd.inc" -END PROCEDURE Append_2c - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_2d -#include "./Append/Append_2cd.inc" -END PROCEDURE Append_2d - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_2e -#include "./Append/Append_2abcd.inc" -END PROCEDURE Append_2e - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_2f -#include "./Append/Append_2abcd.inc" -END PROCEDURE Append_2f - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_3a -INTEGER(I4B), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n -#include "./Append/Append_3.inc" -END PROCEDURE Append_3a - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_3b -REAL(DFP), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n -#include "./Append/Append_3.inc" -END PROCEDURE Append_3b - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_3c -#include "./Append/Append_3cd.inc" -END PROCEDURE Append_3c - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_3d -#include "./Append/Append_3cd.inc" -END PROCEDURE Append_3d - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_4a -INTEGER(I4B), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n, m -#include "./Append/Append_4.inc" -END PROCEDURE Append_4a - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_4b -REAL(DFP), ALLOCATABLE :: Dummy(:) -INTEGER(I4B) :: n, m -#include "./Append/Append_4.inc" -END PROCEDURE Append_4b - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_4c -#include "./Append/Append_4cd.inc" -END PROCEDURE Append_4c - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Append_4d -#include "./Append/Append_4cd.inc" -END PROCEDURE Append_4d - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE func_Append_1a -CALL Append(ans, A, ENTRY) -END PROCEDURE func_Append_1a - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE func_Append_1b -CALL Append(ans, A, ENTRY) -END PROCEDURE func_Append_1b - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE func_Append_2a -CALL Append(ans, A, ENTRY) -END PROCEDURE func_Append_2a - -!---------------------------------------------------------------------------- -! Append -!---------------------------------------------------------------------------- - -MODULE PROCEDURE func_Append_2b -CALL Append(ans, A, ENTRY) -END PROCEDURE func_Append_2b - -!---------------------------------------------------------------------------- -! colConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE colconcat_1a -#include "./ColConcat/ColConcat_1.inc" -END PROCEDURE colconcat_1a - -MODULE PROCEDURE colconcat_1b -#include "./ColConcat/ColConcat_1.inc" -END PROCEDURE colconcat_1b - -MODULE PROCEDURE colconcat_1c -#include "./ColConcat/ColConcat_1.inc" -END PROCEDURE colconcat_1c - -MODULE PROCEDURE colconcat_1d -#include "./ColConcat/ColConcat_1.inc" -END PROCEDURE colconcat_1d - -MODULE PROCEDURE colconcat_1e -#include "./ColConcat/ColConcat_1.inc" -END PROCEDURE colconcat_1e - -MODULE PROCEDURE colconcat_1f -#include "./ColConcat/ColConcat_1.inc" -END PROCEDURE colconcat_1f - -!---------------------------------------------------------------------------- -! colConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE colconcat_2a -#include "./ColConcat/ColConcat_2.inc" -END PROCEDURE colconcat_2a - -MODULE PROCEDURE colconcat_2b -#include "./ColConcat/ColConcat_2.inc" -END PROCEDURE colconcat_2b - -MODULE PROCEDURE colconcat_2c -#include "./ColConcat/ColConcat_2.inc" -END PROCEDURE colconcat_2c - -MODULE PROCEDURE colconcat_2d -#include "./ColConcat/ColConcat_2.inc" -END PROCEDURE colconcat_2d - -MODULE PROCEDURE colconcat_2e -#include "./ColConcat/ColConcat_2.inc" -END PROCEDURE colconcat_2e - -MODULE PROCEDURE colconcat_2f -#include "./ColConcat/ColConcat_2.inc" -END PROCEDURE colconcat_2f - -!---------------------------------------------------------------------------- -! colConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE colconcat_3a -#include "./ColConcat/ColConcat_3.inc" -END PROCEDURE colconcat_3a - -MODULE PROCEDURE colconcat_3b -#include "./ColConcat/ColConcat_3.inc" -END PROCEDURE colconcat_3b - -MODULE PROCEDURE colconcat_3c -#include "./ColConcat/ColConcat_3.inc" -END PROCEDURE colconcat_3c - -MODULE PROCEDURE colconcat_3d -#include "./ColConcat/ColConcat_3.inc" -END PROCEDURE colconcat_3d - -MODULE PROCEDURE colconcat_3e -#include "./ColConcat/ColConcat_3.inc" -END PROCEDURE colconcat_3e - -MODULE PROCEDURE colconcat_3f -#include "./ColConcat/ColConcat_3.inc" -END PROCEDURE colconcat_3f - -!---------------------------------------------------------------------------- -! colConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE colconcat_4a -#include "./ColConcat/ColConcat_4.inc" -END PROCEDURE colconcat_4a - -MODULE PROCEDURE colconcat_4b -#include "./ColConcat/ColConcat_4.inc" -END PROCEDURE colconcat_4b - -MODULE PROCEDURE colconcat_4c -#include "./ColConcat/ColConcat_4.inc" -END PROCEDURE colconcat_4c - -MODULE PROCEDURE colconcat_4d -#include "./ColConcat/ColConcat_4.inc" -END PROCEDURE colconcat_4d - -MODULE PROCEDURE colconcat_4e -#include "./ColConcat/ColConcat_4.inc" -END PROCEDURE colconcat_4e - -MODULE PROCEDURE colconcat_4f -#include "./ColConcat/ColConcat_4.inc" -END PROCEDURE colconcat_4f - -!---------------------------------------------------------------------------- -! colConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Rowconcat_1a -#include "./RowConcat/RowConcat_1.inc" -END PROCEDURE Rowconcat_1a - -MODULE PROCEDURE Rowconcat_1b -#include "./RowConcat/RowConcat_1.inc" -END PROCEDURE Rowconcat_1b - -MODULE PROCEDURE Rowconcat_1c -#include "./RowConcat/RowConcat_1.inc" -END PROCEDURE Rowconcat_1c - -MODULE PROCEDURE Rowconcat_1d -#include "./RowConcat/RowConcat_1.inc" -END PROCEDURE Rowconcat_1d - -MODULE PROCEDURE Rowconcat_1e -#include "./RowConcat/RowConcat_1.inc" -END PROCEDURE Rowconcat_1e - -MODULE PROCEDURE Rowconcat_1f -#include "./RowConcat/RowConcat_1.inc" -END PROCEDURE Rowconcat_1f - -!---------------------------------------------------------------------------- -! RowConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Rowconcat_2a -#include "./RowConcat/RowConcat_2.inc" -END PROCEDURE Rowconcat_2a - -MODULE PROCEDURE Rowconcat_2b -#include "./RowConcat/RowConcat_2.inc" -END PROCEDURE Rowconcat_2b - -MODULE PROCEDURE Rowconcat_2c -#include "./RowConcat/RowConcat_2.inc" -END PROCEDURE Rowconcat_2c - -MODULE PROCEDURE Rowconcat_2d -#include "./RowConcat/RowConcat_2.inc" -END PROCEDURE Rowconcat_2d - -MODULE PROCEDURE Rowconcat_2e -#include "./RowConcat/RowConcat_2.inc" -END PROCEDURE Rowconcat_2e - -MODULE PROCEDURE Rowconcat_2f -#include "./RowConcat/RowConcat_2.inc" -END PROCEDURE Rowconcat_2f - -!---------------------------------------------------------------------------- -! RowConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Rowconcat_3a -#include "./RowConcat/RowConcat_3.inc" -END PROCEDURE Rowconcat_3a - -MODULE PROCEDURE Rowconcat_3b -#include "./RowConcat/RowConcat_3.inc" -END PROCEDURE Rowconcat_3b - -MODULE PROCEDURE Rowconcat_3c -#include "./RowConcat/RowConcat_3.inc" -END PROCEDURE Rowconcat_3c - -MODULE PROCEDURE Rowconcat_3d -#include "./RowConcat/RowConcat_3.inc" -END PROCEDURE Rowconcat_3d - -MODULE PROCEDURE Rowconcat_3e -#include "./RowConcat/RowConcat_3.inc" -END PROCEDURE Rowconcat_3e - -MODULE PROCEDURE Rowconcat_3f -#include "./RowConcat/RowConcat_3.inc" -END PROCEDURE Rowconcat_3f - -!---------------------------------------------------------------------------- -! RowConcat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Rowconcat_4a -#include "./RowConcat/RowConcat_4.inc" -END PROCEDURE Rowconcat_4a - -MODULE PROCEDURE Rowconcat_4b -#include "./RowConcat/RowConcat_4.inc" -END PROCEDURE Rowconcat_4b - -MODULE PROCEDURE Rowconcat_4c -#include "./RowConcat/RowConcat_4.inc" -END PROCEDURE Rowconcat_4c - -MODULE PROCEDURE Rowconcat_4d -#include "./RowConcat/RowConcat_4.inc" -END PROCEDURE Rowconcat_4d - -MODULE PROCEDURE Rowconcat_4e -#include "./RowConcat/RowConcat_4.inc" -END PROCEDURE Rowconcat_4e - -MODULE PROCEDURE Rowconcat_4f -#include "./RowConcat/RowConcat_4.inc" -END PROCEDURE Rowconcat_4f - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ApproxUtility@Methods.F90 b/src/submodules/Utility/src/ApproxUtility@Methods.F90 deleted file mode 100644 index 07d58718f..000000000 --- a/src/submodules/Utility/src/ApproxUtility@Methods.F90 +++ /dev/null @@ -1,323 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(ApproxUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! APPROX -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxeq_1 -REAL(REAL64), PARAMETER :: my_zero = 1.0E-10 -ans = (ABS(a - b) .LE. my_zero) -END PROCEDURE approxeq_1 - -!---------------------------------------------------------------------------- -! APPROX -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxeq_2 -REAL(REAL64), PARAMETER :: my_zero = 1.0E-10 -ans = (ABS(a - b) .LE. my_zero) -END PROCEDURE approxeq_2 - -!---------------------------------------------------------------------------- -! APPROXR -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxeqr_1 -REAL(REAL32) :: eps -REAL(REAL32), PARAMETER :: my_zero = REAL(Zero, REAL32) -eps = my_zero + MAX(ABS(a), ABS(b)) * my_zero -ans = (ABS(a - b) .LE. eps) -END PROCEDURE approxeqr_1 - -!---------------------------------------------------------------------------- -! APPROXR -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxeqr_2 -REAL(REAL64) :: eps -REAL(REAL64), PARAMETER :: my_zero = REAL(Zero, REAL64) -eps = my_zero + MAX(ABS(a), ABS(b)) * my_zero -ans = (ABS(a - b) .LE. eps) -END PROCEDURE approxeqr_2 - -!---------------------------------------------------------------------------- -! APPROXEQF -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxeq_ulp_real -LOGICAL(LGT) :: isok - -isok = (a > 0._DFP .AND. b < 0._DFP) .OR. (a < 0._DFP .AND. b > 0._DFP) - -IF (isok) THEN - ans = approxeq_1(a, b) -ELSE - ans = (ABS(TRANSFER(a, 1_I4B) - TRANSFER(b, 1_I4B)) <= 10_I4B) -END IF -END PROCEDURE approxeq_ulp_real - -!---------------------------------------------------------------------------- -! APPROXLE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxle_1 -REAL(DFP), PARAMETER :: my_zero = 1.0E-10 -ans = (r1 - r2 .LE. my_zero) -END PROCEDURE approxle_1 - -!---------------------------------------------------------------------------- -! APPROXLE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxle_2 -REAL(DFP), PARAMETER :: my_zero = 1.0E-10 -ans = (r1 - r2 .LE. my_zero) -END PROCEDURE approxle_2 - -!---------------------------------------------------------------------------- -! APPROXGE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxge_1 -REAL(DFP), PARAMETER :: my_zero = 1.0E-10 -ans = (my_zero .GE. r2 - r1) -END PROCEDURE approxge_1 - -!---------------------------------------------------------------------------- -! APPROXGE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE approxge_2 -REAL(DFP), PARAMETER :: my_zero = 1.0E-10 -ans = (my_zero .GE. r2 - r1) -END PROCEDURE approxge_2 - -!---------------------------------------------------------------------------- -! SOFTEQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softeq_1 -ans = (ABS(r1 - r2) .LE. tol) -END PROCEDURE softeq_1 - -!---------------------------------------------------------------------------- -! SOFTEQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softeq_2 -ans = (ABS(r1 - r2) .LE. tol) -END PROCEDURE softeq_2 - -!---------------------------------------------------------------------------- -! SOFTEQR -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softeqr_1 -REAL(REAL32) :: eps -eps = REAL(Zero, REAL32) + MAX(ABS(r1), ABS(r2)) * tol -ans = (ABS(r1 - r2) .LE. eps) -END PROCEDURE softeqr_1 - -!---------------------------------------------------------------------------- -! SOFTEQR -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softeqr_2 -REAL(REAL64) :: eps -eps = REAL(Zero, REAL64) + MAX(ABS(r1), ABS(r2)) * tol -ans = (ABS(r1 - r2) .LE. eps) -END PROCEDURE softeqr_2 - -!---------------------------------------------------------------------------- -! SOFTLE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softle_1 -ans = (r1 .LE. r2 + tol) -END PROCEDURE softle_1 - -!---------------------------------------------------------------------------- -! SOFTLE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softle_2 -ans = (r1 .LE. r2 + tol) -END PROCEDURE softle_2 - -!---------------------------------------------------------------------------- -! SOFTLT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softlt_1 -ans = (r1 < r2 - tol) -END PROCEDURE softlt_1 - -!---------------------------------------------------------------------------- -! SOFTLT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softlt_2 -ans = (r1 < r2 - tol) -END PROCEDURE softlt_2 - -!---------------------------------------------------------------------------- -! SOFTGE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softge_1 -ans = (r1 + tol .GE. r2) -END PROCEDURE softge_1 - -!---------------------------------------------------------------------------- -! SOFTGE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softge_2 -ans = (r1 + tol .GE. r2) -END PROCEDURE softge_2 - -!---------------------------------------------------------------------------- -! SOFTGT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softgt_1 -ans = (r1 > r2 + tol) -END PROCEDURE softgt_1 - -!---------------------------------------------------------------------------- -! SOFTGT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE softgt_2 -ans = (r1 > r2 + tol) -END PROCEDURE softgt_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE equalto_logical -ans = (l1 .EQV. l2) -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE notequalto_logical -ans = (l1 .NEQV. l2) -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assign_char_to_Int8 -INTEGER(I4B) :: tmpInt -CHARACTER(4) :: fmt -tmpInt = LEN(c) -WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) -READ (c, '(I'//TRIM(fmt)//')') i -END PROCEDURE assign_char_to_Int8 - -MODULE PROCEDURE assign_char_to_Int16 -INTEGER(I4B) :: tmpInt -CHARACTER(4) :: fmt -tmpInt = LEN(c) -WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) -READ (c, '(I'//TRIM(fmt)//')') i -END PROCEDURE assign_char_to_Int16 - -MODULE PROCEDURE assign_char_to_Int32 -INTEGER(I4B) :: tmpInt -CHARACTER(4) :: fmt -tmpInt = LEN(c) -WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) -READ (c, '(I'//TRIM(fmt)//')') i -END PROCEDURE assign_char_to_Int32 - -MODULE PROCEDURE assign_char_to_Int64 -INTEGER(I4B) :: tmpInt -CHARACTER(4) :: fmt -tmpInt = LEN(c) -WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) -READ (c, '(I'//TRIM(fmt)//')') i -END PROCEDURE assign_char_to_Int64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assign_char_to_bool -IF (c == 'true') THEN - b = .TRUE. -ELSE - b = .FALSE. -END IF -END PROCEDURE assign_char_to_bool - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assign_char_to_real32 -INTEGER(I4B) :: tmpInt -CHARACTER(4) :: fmt -tmpInt = LEN(c) -WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) -READ (c, '(f'//TRIM(fmt)//'.0)') s -END PROCEDURE assign_char_to_real32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assign_char_to_real64 -INTEGER(I4B) :: tmpInt -CHARACTER(4) :: fmt -tmpInt = LEN(c) -WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) -READ (c, '(f'//TRIM(fmt)//'.0)') s -END PROCEDURE assign_char_to_real64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isNumeric -INTEGER(I4B) :: i, val -bool = .FALSE. -IF (LEN(char_str) < 1) THEN - RETURN -ELSE - DO i = 1, LEN(char_str) - ! 0-9 are represented by ASCII codes 48-57 - val = IACHAR(char_str(i:i)) - IF (.NOT. (val > 47 .AND. val < 58)) THEN - ! If any character isn't between those codes, it isn't an integer - RETURN - END IF - END DO -END IF -bool = .TRUE. -END PROCEDURE - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ArangeUtility@Methods.F90 b/src/submodules/Utility/src/ArangeUtility@Methods.F90 deleted file mode 100644 index 89c4e4b05..000000000 --- a/src/submodules/Utility/src/ArangeUtility@Methods.F90 +++ /dev/null @@ -1,128 +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(ArangeUtility) Methods -USE BaseMethod, ONLY: INPUT -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! arange -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arange_Int8 -! Internal var -INTEGER(INT8) :: incr -INTEGER(INT8) :: i -INTEGER(INT8) :: n -incr = INPUT(default=1_Int8, option=increment) -n = (iend - istart) / incr + 1 -ALLOCATE (Ans(n)) -DO CONCURRENT(i=1:n) - Ans(i) = istart + (i - 1) * incr -END DO -END PROCEDURE arange_Int8 - -!---------------------------------------------------------------------------- -! arange -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arange_Int16 -! Internal var -INTEGER(INT16) :: incr -INTEGER(INT16) :: i -INTEGER(INT16) :: n -incr = INPUT(default=1_Int16, option=increment) -n = (iend - istart) / incr + 1 -ALLOCATE (Ans(n)) -DO CONCURRENT(i=1:n) - Ans(i) = istart + (i - 1) * incr -END DO -END PROCEDURE arange_Int16 - -!---------------------------------------------------------------------------- -! arange -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arange_Int32 -! Internal var -INTEGER(INT32) :: incr -INTEGER(INT32) :: i -INTEGER(INT32) :: n -incr = INPUT(default=1_Int32, option=increment) -n = (iend - istart) / incr + 1 -ALLOCATE (Ans(n)) -DO CONCURRENT(i=1:n) - Ans(i) = istart + (i - 1) * incr -END DO -END PROCEDURE arange_Int32 -!---------------------------------------------------------------------------- -! arange -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arange_Int64 -! Internal var -INTEGER(INT64) :: incr -INTEGER(INT64) :: i -INTEGER(INT64) :: n -incr = INPUT(default=1_Int64, option=increment) -n = (iend - istart) / incr + 1 -ALLOCATE (Ans(n)) -DO CONCURRENT(i=1:n) - Ans(i) = istart + (i - 1) * incr -END DO -END PROCEDURE arange_Int64 - -!---------------------------------------------------------------------------- -! arange -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arange_real64 -! internal var -REAL(REAL64) :: incr -INTEGER(I4B) :: i -INTEGER(I4B) :: n - !! -incr = INPUT(Default=1.0_REAL64, Option=increment) - !! -n = (iend - istart + 0.5_REAL64 * incr) / incr + 1 -ALLOCATE (Ans(n)) -DO CONCURRENT(i=1:n) - Ans(i) = istart + (i - 1) * incr -END DO -END PROCEDURE arange_real64 - -!---------------------------------------------------------------------------- -! arange -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arange_real32 -! internal var -REAL(REAL32) :: incr -INTEGER(I4B) :: i -INTEGER(I4B) :: n - !! -incr = INPUT(Default=1.0_REAL32, Option=increment) - !! -n = (iend - istart + 0.5_REAL32 * incr) / incr + 1 -ALLOCATE (Ans(n)) -DO CONCURRENT(i=1:n) - Ans(i) = istart + (i - 1) * incr -END DO -END PROCEDURE arange_real32 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/AssertUtility@Methods.F90 b/src/submodules/Utility/src/AssertUtility@Methods.F90 deleted file mode 100644 index aad9ad691..000000000 --- a/src/submodules/Utility/src/AssertUtility@Methods.F90 +++ /dev/null @@ -1,214 +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: 3 April 2021 -! summary: Assert functions - -SUBMODULE(AssertUtility) Methods -USE BaseMethod, ONLY: ErrorMsg -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Assert_EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_eq2 -IF (n1 .EQ. n2) THEN - assert_eq2 = n1 -ELSE - CALL ErrorMsg( & - & File=__FILE__, & - & Routine="Assert_Eq()", & - & Line=__LINE__, & - & MSG=" Sizes of Matrices are not the same; Program Stopped ") - STOP -END IF -END PROCEDURE assert_eq2 - -!---------------------------------------------------------------------------- -! Assert_EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_eq3 -IF (n1 == n2 .AND. n2 == n3) THEN - assert_eq3 = n1 -ELSE - CALL ErrorMsg( & - & File=__FILE__, & - & Routine="Assert_Eq()", & - & Line=__LINE__, & - & MSG=" Sizes of Matrices are not the same; Program Stopped ") - STOP -END IF -END PROCEDURE assert_eq3 - -!---------------------------------------------------------------------------- -! Assert_EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_eq4 -IF (n1 == n2 .AND. n2 == n3 .AND. n3 == n4) THEN - assert_eq4 = n1 -ELSE - CALL ErrorMsg( & - & File=__FILE__, & - & Routine="Assert_Eq()", & - & Line=__LINE__, & - & MSG=" Sizes of Matrices are not the same; Program Stopped ") - STOP -END IF -END PROCEDURE assert_eq4 - -!---------------------------------------------------------------------------- -! Assert_EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_eqn -IF (ALL(nn(2:) == nn(1))) THEN - assert_eqn = nn(1) -ELSE - CALL ErrorMsg( & - & File=__FILE__, & - & Routine="Assert_Eq()", & - & Line=__LINE__, & - & MSG=" Sizes of Matrices are not the same; Program Stopped ") - STOP -END IF -END PROCEDURE assert_eqn - -!---------------------------------------------------------------------------- -! ASSERT_SHAPE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_shape_2 -INTEGER(I4B) :: shape_mat(2) -shape_mat = SHAPE(Mat) -IF (ALL(shape_mat == s)) THEN - RETURN -ELSE - CALL ErrorMsg( & - & File=file, & - & Routine=routine, & - & Line=line, & - & MSG=msg) - STOP -END IF -END PROCEDURE assert_shape_2 - -!---------------------------------------------------------------------------- -! ASSERT_SHAPE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_shape_3 -INTEGER(I4B) :: shape_mat(3) -shape_mat = SHAPE(Mat) -IF (ALL(shape_mat == s)) THEN - RETURN -ELSE - CALL ErrorMsg(File=file, Routine=routine, Line=line, & - & MSG=msg) - STOP -END IF -END PROCEDURE assert_shape_3 - -!---------------------------------------------------------------------------- -! ASSERT_SHAPE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_shape_4 -INTEGER(I4B) :: shape_mat(4) -shape_mat = SHAPE(Mat) -IF (ALL(shape_mat == s)) THEN - RETURN -ELSE - CALL ErrorMsg(File=file, Routine=routine, Line=line, & - & MSG=msg) - STOP -END IF -END PROCEDURE assert_shape_4 - -!---------------------------------------------------------------------------- -! Assert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_2 -IF (n1 .EQ. n2) THEN - RETURN -ELSE - CALL ErrorMsg( & - & File=file, & - & Routine=routine, & - & Line=line, & - & MSG=msg) - STOP -END IF -END PROCEDURE assert_2 - -!---------------------------------------------------------------------------- -! Assert_EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_3 -IF (n1 == n2 .AND. n2 == n3) THEN - RETURN -ELSE - CALL ErrorMsg( & - & File=file, & - & Routine=routine, & - & Line=line, & - & MSG=msg) - STOP -END IF -END PROCEDURE assert_3 - -!---------------------------------------------------------------------------- -! Assert_EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_4 -IF (n1 == n2 .AND. n2 == n3 .AND. n3 == n4) THEN - RETURN -ELSE - CALL ErrorMsg( & - & File=file, & - & Routine=routine, & - & Line=line, & - & MSG=msg) - STOP -END IF -END PROCEDURE assert_4 - -!---------------------------------------------------------------------------- -! Assert_EQ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE assert_n -IF (ALL(nn(2:) == nn(1))) THEN - RETURN -ELSE - CALL ErrorMsg( & - & File=file, & - & Routine=routine, & - & Line=line, & - & MSG=msg) - STOP -END IF -END PROCEDURE assert_n - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/BinomUtility@Methods.F90 b/src/submodules/Utility/src/BinomUtility@Methods.F90 deleted file mode 100644 index 77fc27774..000000000 --- a/src/submodules/Utility/src/BinomUtility@Methods.F90 +++ /dev/null @@ -1,142 +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(BinomUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real32_Binom_Int8 - !! - IF( k .EQ. 0_Int8 ) THEN - ans = 1.0_Real32 - ELSE - ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & - & Real32_Binom_Int8( n=n, k=k-1_Int8, kind=kind ) - END IF - !! -END PROCEDURE Real32_Binom_Int8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real32_Binom_Int16 - !! - IF( k .EQ. 0_Int16 ) THEN - ans = 1.0_Real32 - ELSE - ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & - & Real32_Binom_Int16( n=n, k=k-1_Int16, kind=kind ) - END IF - !! -END PROCEDURE Real32_Binom_Int16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real32_Binom_Int32 - !! - IF( k .EQ. 0_Int32 ) THEN - ans = 1.0_Real32 - ELSE - ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & - & Real32_Binom_Int32( n=n, k=k-1_Int32, kind=kind ) - END IF - !! -END PROCEDURE Real32_Binom_Int32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real32_Binom_Int64 - !! - IF( k .EQ. 0_Int64 ) THEN - ans = 1.0_Real32 - ELSE - ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & - & Real32_Binom_Int64( n=n, k=k-1_Int64, kind=kind ) - END IF - !! -END PROCEDURE Real32_Binom_Int64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real64_Binom_Int8 - !! - IF( k .EQ. 0_Int8 ) THEN - ans = 1.0_Real64 - ELSE - ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & - & Real64_Binom_Int8( n=n, k=k-1_Int8, kind=kind ) - END IF - !! -END PROCEDURE Real64_Binom_Int8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real64_Binom_Int16 - !! - IF( k .EQ. 0_Int16 ) THEN - ans = 1.0_Real64 - ELSE - ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & - & Real64_Binom_Int16( n=n, k=k-1_Int16, kind=kind ) - END IF - !! -END PROCEDURE Real64_Binom_Int16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real64_Binom_Int32 - !! - IF( k .EQ. 0_Int32 ) THEN - ans = 1.0_Real64 - ELSE - ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & - & Real64_Binom_Int32( n=n, k=k-1_Int32, kind=kind ) - END IF - !! -END PROCEDURE Real64_Binom_Int32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Real64_Binom_Int64 - !! - IF( k .EQ. 0_Int64 ) THEN - ans = 1.0_Real64 - ELSE - ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & - & Real64_Binom_Int64( n=n, k=k-1_Int64, kind=kind ) - END IF - !! -END PROCEDURE Real64_Binom_Int64 - -END SUBMODULE Methods \ No newline at end of file diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_1.inc b/src/submodules/Utility/src/ColConcat/ColConcat_1.inc deleted file mode 100644 index e0ebbf859..000000000 --- a/src/submodules/Utility/src/ColConcat/ColConcat_1.inc +++ /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 -! - -INTEGER(I4B) :: n -n = MAX(SIZE(a), SIZE(b)) -CALL reallocate(ans, n, 2) -ans(1:SIZE(a), 1) = a -ans(1:SIZE(b), 2) = b diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_2.inc b/src/submodules/Utility/src/ColConcat/ColConcat_2.inc deleted file mode 100644 index 4c0407718..000000000 --- a/src/submodules/Utility/src/ColConcat/ColConcat_2.inc +++ /dev/null @@ -1,24 +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 -! - - INTEGER(I4B) :: nrow, ncol - - nrow = MAX(SIZE(a,1), SIZE(b)) - ncol = SIZE(a,2) + 1 - CALL reallocate(ans, nrow, ncol) - ans(1:SIZE(a,1), 1:size(a,2) ) = a - ans(1:SIZE(b), ncol) = b diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_3.inc b/src/submodules/Utility/src/ColConcat/ColConcat_3.inc deleted file mode 100644 index 2854c5473..000000000 --- a/src/submodules/Utility/src/ColConcat/ColConcat_3.inc +++ /dev/null @@ -1,24 +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 -! - - INTEGER(I4B) :: nrow, ncol - - nrow = MAX(SIZE(b,1), SIZE(a)) - ncol = SIZE(b,2) + 1 - CALL reallocate(ans, nrow, ncol) - ans(1:SIZE(a), 1) = a - ans(1:SIZE(b,1), 2:) = b diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_4.inc b/src/submodules/Utility/src/ColConcat/ColConcat_4.inc deleted file mode 100644 index c3d463251..000000000 --- a/src/submodules/Utility/src/ColConcat/ColConcat_4.inc +++ /dev/null @@ -1,27 +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 -! - - INTEGER(I4B) :: nrow, ncol - - nrow = MAX(SIZE(a, 1), SIZE(b, 1)) - ncol = SIZE(a, 2) + SIZE(b, 2) - - CALL reallocate(ans, nrow, ncol) - - ans(1:SIZE(a, 1), 1:SIZE(a, 2)) = a - - ans(1:SIZE(b, 1), SIZE(a, 2) + 1:) = b diff --git a/src/submodules/Utility/src/ContractionUtility@Methods.F90 b/src/submodules/Utility/src/ContractionUtility@Methods.F90 deleted file mode 100644 index 6fbe200b9..000000000 --- a/src/submodules/Utility/src/ContractionUtility@Methods.F90 +++ /dev/null @@ -1,183 +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: 3 April 2021 -! summary: Methods for matrix multiplication - -SUBMODULE(ContractionUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r4_r1 -ans = MATMUL(a1, a2) -END PROCEDURE contraction_r4_r1 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r4_r2 -INTEGER(I4B) :: ii -!! -ans = 0.0_DFP -DO ii = 1, SIZE(a2, 2) - ans = ans + MATMUL(a1(:, :, :, ii), a2(:, ii)) -END DO -END PROCEDURE contraction_r4_r2 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r4_r3 -INTEGER(I4B) :: ii, jj -!! -ans = 0.0_DFP -DO jj = 1, SIZE(a2, 3) - DO ii = 1, SIZE(a2, 2) - ans = ans + MATMUL(a1(:, :, ii, jj), a2(:, ii, jj)) - END DO -END DO -END PROCEDURE contraction_r4_r3 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r4_r4 -ans = SUM(a1 * a2) -END PROCEDURE contraction_r4_r4 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r3_r1 -ans = MATMUL(a1, a2) -END PROCEDURE contraction_r3_r1 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r3_r2 -INTEGER(I4B) :: ii -!! -ans = 0.0_DFP -DO ii = 1, SIZE(a2, 2) - ans = ans + MATMUL(a1(:, :, ii), a2(:, ii)) -END DO -END PROCEDURE contraction_r3_r2 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r3_r3 -ans = SUM(a1 * a2) -END PROCEDURE contraction_r3_r3 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r3_r4 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 4) - ans(ii) = Contraction(a1, a2(:, :, :, ii)) -END DO -END PROCEDURE contraction_r3_r4 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r2_r1 - ans = matmul(a1, a2) -END PROCEDURE contraction_r2_r1 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r2_r2 - ans = sum(a1*a2) -END PROCEDURE contraction_r2_r2 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r2_r3 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 3) - ans(ii) = Contraction(a1, a2(:, :, ii)) -END DO -END PROCEDURE contraction_r2_r3 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r2_r4 -INTEGER(I4B) :: ii, jj -DO jj = 1, SIZE(a2, 4) - DO ii = 1, SIZE(a2, 3) - ans(ii, jj) = Contraction(a1, a2(:, :, ii, jj)) - END DO -END DO -END PROCEDURE contraction_r2_r4 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r1_r1 -ans = DOT_PRODUCT(a1, a2) -END PROCEDURE contraction_r1_r1 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r1_r2 -ans = MATMUL(a1, a2) -END PROCEDURE contraction_r1_r2 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r1_r3 -ans = matmul(a1, a2) -END PROCEDURE contraction_r1_r3 - -!---------------------------------------------------------------------------- -! contraction -!---------------------------------------------------------------------------- - -MODULE PROCEDURE contraction_r1_r4 -ans = matmul(a1,a2) -END PROCEDURE contraction_r1_r4 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90 deleted file mode 100644 index 658b358e7..000000000 --- a/src/submodules/Utility/src/ConvertUtility@Methods.F90 +++ /dev/null @@ -1,123 +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: 22 March 2021 -! summary: This submodule contains method for swaping - -SUBMODULE(ConvertUtility) Methods -USE ReallocateUtility -USE EyeUtility -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE 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 - -!---------------------------------------------------------------------------- -! ConvertSafe -!---------------------------------------------------------------------------- - -MODULE PROCEDURE convert_1_safe -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) -CASE (DofToNodes) - - DO inode = 1, nns - DO idof = 1, tdof - j = (inode - 1) * tdof + idof - T(j, j) = 0 - i = (idof - 1) * nns + inode - T(i, j) = 1 - END DO - END DO - -CASE (NodesToDOF) - - DO idof = 1, tdof - DO inode = 1, nns - j = (idof - 1) * nns + inode - T(j, j) = 0 - i = (inode - 1) * tdof + idof - T(i, j) = 1 - END DO - END DO - -END SELECT - -to = MATMUL(TRANSPOSE(T), MATMUL(from, T)) -END PROCEDURE convert_1_safe - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE convert_2 -! Define internal variables -INTEGER(I4B) :: a, b, I(4), r1, r2, c1, c2 -I = SHAPE(From) -CALL Reallocate(To, I(1) * I(3), I(2) * I(4)) -c1 = 0; c2 = 0 -DO b = 1, I(4) - c1 = c2 + 1 - c2 = b * I(2) - r1 = 0; r2 = 0 - DO a = 1, I(3) - r1 = r2 + 1; - r2 = a * I(1) - To(r1:r2, c1:c2) = From(:, :, a, b) - END DO -END DO -END PROCEDURE convert_2 - -!---------------------------------------------------------------------------- -! Convert -!---------------------------------------------------------------------------- - -MODULE PROCEDURE convert_3 -INTEGER(I4B) :: a, b, s(6) -REAL(DFP), ALLOCATABLE :: m2(:, :) - !! -s = SHAPE(from) -CALL Reallocate(to, s(1) * s(3), s(2) * s(4), s(5), s(6)) - !! -DO b = 1, s(6) - DO a = 1, s(5) - CALL Convert(from=from(:, :, :, :, a, b), to=m2) - to(:, :, a, b) = m2 - END DO -END DO -DEALLOCATE (m2) -END PROCEDURE convert_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Diag/SetDiag.inc b/src/submodules/Utility/src/Diag/SetDiag.inc deleted file mode 100644 index 1495021f0..000000000 --- a/src/submodules/Utility/src/Diag/SetDiag.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 -! - -INTEGER(I4B) :: m, n, ii -!! -n = SIZE(mat, 1) -!! -IF (diagNo .EQ. 0) THEN - !! - IF (SIZE(d) .EQ. 1) THEN - DO CONCURRENT(ii=1:n) - mat(ii, ii) = REAL(d(1), kind=DFP) - END DO - ELSE - DO CONCURRENT(ii=1:n) - mat(ii, ii) = REAL(d(ii), kind=DFP) - END DO - END IF - !! -ELSEIF (diagNo .GT. 0) THEN - !! - m = n - diagNo - !! - IF (SIZE(d) .EQ. 1) THEN - DO CONCURRENT(ii=1:m) - mat(ii, ii + diagNo) = REAL(d(1), kind=DFP) - END DO - ELSE - DO CONCURRENT(ii=1:m) - mat(ii, ii + diagNo) = REAL(d(ii), kind=DFP) - END DO - END IF - !! -ELSE - !! - m = n + diagNo - !! - IF (SIZE(d) .EQ. 1) THEN - DO CONCURRENT(ii=1:m) - mat(ii - diagNo, ii) = REAL(d(1), kind=DFP) - END DO - ELSE - DO CONCURRENT(ii=1:m) - mat(ii - diagNo, ii) = REAL(d(ii), kind=DFP) - END DO - END IF - !! -END IF diff --git a/src/submodules/Utility/src/Diag/SetTriDiag.inc b/src/submodules/Utility/src/Diag/SetTriDiag.inc deleted file mode 100644 index dc658326e..000000000 --- a/src/submodules/Utility/src/Diag/SetTriDiag.inc +++ /dev/null @@ -1,55 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -INTEGER(I4B) :: m, n, ii -!! -n = SIZE(mat, 1) -!! -IF (SIZE(d) .EQ. 1) THEN - DO CONCURRENT(ii=1:n) - mat(ii, ii) = REAL(d(1), kind=DFP) - END DO -ELSE - DO CONCURRENT(ii=1:n) - mat(ii, ii) = REAL(d(ii), kind=DFP) - END DO -END IF -!! -m = n - 1 -!! -IF (SIZE(da) .EQ. 1) THEN - DO CONCURRENT(ii=1:m) - mat(ii, ii + 1) = REAL(da(1), kind=DFP) - END DO -ELSE - DO CONCURRENT(ii=1:m) - mat(ii, ii + 1) = REAL(da(ii), kind=DFP) - END DO -END IF -!! -m = n - 1 -!! -IF (SIZE(db) .EQ. 1) THEN - DO CONCURRENT(ii=1:m) - mat(ii + 1, ii) = REAL(db(1), kind=DFP) - END DO -ELSE - DO CONCURRENT(ii=1:m) - mat(ii + 1, ii) = REAL(db(ii), kind=DFP) - END DO -END IF -!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Diag/Tridiag.inc b/src/submodules/Utility/src/Diag/Tridiag.inc deleted file mode 100644 index 12eeb9dee..000000000 --- a/src/submodules/Utility/src/Diag/Tridiag.inc +++ /dev/null @@ -1,23 +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 -! - -INTEGER(I4B) :: da_No, db_No -ans = Diag(d) -da_No = ABS(INPUT(option=diagNo, default=1)) -db_No = -da_No -CALL SetDiag(mat=ans, d=da, diagNo=da_No) -CALL SetDiag(mat=ans, d=db, diagNo=db_No) diff --git a/src/submodules/Utility/src/DiagUtility@Methods.F90 b/src/submodules/Utility/src/DiagUtility@Methods.F90 deleted file mode 100644 index 0e921b2b5..000000000 --- a/src/submodules/Utility/src/DiagUtility@Methods.F90 +++ /dev/null @@ -1,273 +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(DiagUtility) Methods -USE BaseMethod, ONLY: Reallocate, Input -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Diag_1 -INTEGER(I4B) :: ii -ans = 0.0_DFP -DO ii = 1, SIZE(a) - ans(ii, ii) = REAL(a(ii), kind=DFP) -END DO -END PROCEDURE Diag_1 - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Diag_2 -INTEGER(I4B) :: ii -ans = 0.0_DFP -DO ii = 1, SIZE(a) - ans(ii, ii) = REAL(a(ii), kind=DFP) -END DO -END PROCEDURE Diag_2 - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Diag_3 -INTEGER(I4B) :: ii -ans = 0.0_DFP -DO ii = 1, SIZE(a) - ans(ii, ii) = REAL(a(ii), kind=DFP) -END DO -END PROCEDURE Diag_3 - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Diag_4 -INTEGER(I4B) :: ii -ans = 0.0_DFP -DO ii = 1, SIZE(a) - ans(ii, ii) = REAL(a(ii), kind=DFP) -END DO -END PROCEDURE Diag_4 - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Diag_5 -INTEGER(I4B) :: ii -ans = 0.0_DFP -DO ii = 1, SIZE(a) - ans(ii, ii) = REAL(a(ii), kind=DFP) -END DO -END PROCEDURE Diag_5 - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Diag_6 -INTEGER(I4B) :: ii -ans = 0.0_DFP -DO ii = 1, SIZE(a) - ans(ii, ii) = REAL(a(ii), kind=DFP) -END DO -END PROCEDURE Diag_6 - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE Diag_7 -INTEGER(I4B) :: ii -ans = 0.0_DFP -DO ii = 1, SIZE(a) - ans(ii, ii) = REAL(a(ii), kind=DFP) -END DO -END PROCEDURE Diag_7 -#endif - -!---------------------------------------------------------------------------- -! Diag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Diag_8 -INTEGER(I4B) :: n, m, ii -n = SIZE(mat, 1) -IF (diagNo .EQ. 0) THEN - !! - CALL Reallocate(ans, n) - DO CONCURRENT(ii=1:n) - ans(ii) = mat(ii, ii) - END DO - !! -ELSEIF (diagNo .GT. 0) THEN - !! - m = n - diagNo - CALL Reallocate(ans, m) - DO CONCURRENT(ii=1:m) - ans(ii) = mat(ii, ii + diagNo) - END DO - !! -ELSE - !! - m = n + diagNo - CALL Reallocate(ans, m) - DO CONCURRENT(ii=1:m) - ans(ii) = mat(ii - diagNo, ii) - END DO - !! -END IF - !! -END PROCEDURE Diag_8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetDiag1 -#include "./Diag/SetDiag.inc" -END PROCEDURE SetDiag1 - -MODULE PROCEDURE SetDiag2 -#include "./Diag/SetDiag.inc" -END PROCEDURE SetDiag2 - -MODULE PROCEDURE SetDiag3 -#include "./Diag/SetDiag.inc" -END PROCEDURE SetDiag3 - -MODULE PROCEDURE SetDiag4 -#include "./Diag/SetDiag.inc" -END PROCEDURE SetDiag4 - -MODULE PROCEDURE SetDiag5 -#include "./Diag/SetDiag.inc" -END PROCEDURE SetDiag5 - -MODULE PROCEDURE SetDiag6 -#include "./Diag/SetDiag.inc" -END PROCEDURE SetDiag6 - -!---------------------------------------------------------------------------- -! SetTriDiag -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetTriDiag1 -#include "./Diag/SetTriDiag.inc" -END PROCEDURE SetTriDiag1 - -MODULE PROCEDURE SetTriDiag2 -#include "./Diag/SetTriDiag.inc" -END PROCEDURE SetTriDiag2 - -MODULE PROCEDURE SetTriDiag3 -#include "./Diag/SetTriDiag.inc" -END PROCEDURE SetTriDiag3 - -MODULE PROCEDURE SetTriDiag4 -#include "./Diag/SetTriDiag.inc" -END PROCEDURE SetTriDiag4 - -MODULE PROCEDURE SetTriDiag5 -#include "./Diag/SetTriDiag.inc" -END PROCEDURE SetTriDiag5 - -MODULE PROCEDURE SetTriDiag6 -#include "./Diag/SetTriDiag.inc" -END PROCEDURE SetTriDiag6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiagSize1 -ans = DiagSize(m=n, n=n, diagNo=diagNo) -END PROCEDURE DiagSize1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiagSize2 -IF (diagNo .GE. 0 .AND. diagNo .LE. n) THEN - ans = MIN(m, n - diagNo) -ELSE IF (diagNo .LT. 0 .AND. -diagNo .LE. m) THEN - ans = MIN(n, m + diagNo) -ELSE - ans = 0 -END IF -END PROCEDURE DiagSize2 - -!---------------------------------------------------------------------------- -! DiagIndx -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DiagIndx -INTEGER(I4B) :: tsize, ii -! -tsize = DiagSize(m, n, diagNo) -! -ALLOCATE (ans(tsize, 2)) -! -IF (diagNo .GE. 0 .AND. diagNo .LE. n) THEN - DO CONCURRENT(ii=1:tsize) - ans(ii, 1) = ii - ans(ii, 2) = ii + diagNo - END DO -ELSE IF (diagNo .LT. 0 .AND. -diagNo .LE. m) THEN - DO CONCURRENT(ii=1:tsize) - ans(ii, 2) = ii - ans(ii, 1) = ii - diagNo - END DO -END IF -END PROCEDURE DiagIndx - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Tridiag_1 -#include "./Diag/Tridiag.inc" -END PROCEDURE Tridiag_1 - -MODULE PROCEDURE Tridiag_2 -#include "./Diag/Tridiag.inc" -END PROCEDURE Tridiag_2 - -MODULE PROCEDURE Tridiag_3 -#include "./Diag/Tridiag.inc" -END PROCEDURE Tridiag_3 - -MODULE PROCEDURE Tridiag_4 -#include "./Diag/Tridiag.inc" -END PROCEDURE Tridiag_4 - -MODULE PROCEDURE Tridiag_5 -#include "./Diag/Tridiag.inc" -END PROCEDURE Tridiag_5 - -MODULE PROCEDURE Tridiag_6 -#include "./Diag/Tridiag.inc" -END PROCEDURE Tridiag_6 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/EigenUtility@Methods.F90 b/src/submodules/Utility/src/EigenUtility@Methods.F90 deleted file mode 100644 index 075472fce..000000000 --- a/src/submodules/Utility/src/EigenUtility@Methods.F90 +++ /dev/null @@ -1,335 +0,0 @@ -! This program is mat part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR mat PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received mat copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(EigenUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymEigenValues2by2 -REAL(DFP) :: i1, i2, a, b -i1 = mat(1, 1) + mat(2, 2) -i2 = (mat(1, 1) - mat(2, 2))**2 + 4.0_DFP * (mat(1, 2)**2) -a = 0.5_DFP * i1 -! b = SQRT(a**2 - i2) -b = 0.5_DFP * SQRT(i2) -ans(1) = a - b -ans(2) = a + b -END PROCEDURE SymEigenValues2by2 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymEigenValues3by3 -REAL(DFP) :: q, p, r -REAL(DFP), PARAMETER :: twothirdpi = 2.0_DFP * pi / 3.0_DFP -!! -r = mat(1, 2) * mat(1, 2) + mat(1, 3) * mat(1, 3) + mat(2, 3) * mat(2, 3) -q = (mat(1, 1) + mat(2, 2) + mat(3, 3)) / 3.0_DFP -!! -ans(1) = mat(1, 1) - q -ans(2) = mat(2, 2) - q -ans(3) = mat(3, 3) - q -!! -p = SQRT((ans(1) * ans(1) + ans(2) * ans(2) + ans(3) * ans(3) + 2 * r) & - & / 6.0_DFP) -!! -r = (ans(1) * (ans(2) * ans(3) - mat(2, 3) * mat(2, 3)) & - & - mat(1, 2) * (mat(1, 2) * ans(3) - mat(2, 3) * mat(1, 3)) & - & + mat(1, 3) * (mat(1, 2) * mat(2, 3) - ans(2) * mat(1, 3))) & - & / (p * p * p) * 0.5_DFP -!! -IF (r <= -1.0_DFP) THEN - r = 0.5_DFP * twothirdpi -ELSE IF (r >= 1.0_DFP) THEN - r = 0.0_DFP -ELSE - r = acos(r) / 3.0_DFP -END IF -!! -ans(3) = q + 2 * p * cos(r) -ans(1) = q + 2 * p * cos(r + twothirdpi) -ans(2) = 3 * q - ans(1) - ans(3) -!! -END PROCEDURE SymEigenValues3by3 - -!---------------------------------------------------------------------------- -! SymEigenValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymEigenValuesUpto3 -!! -SELECT CASE (SIZE(mat, 1)) -CASE (1) - ans(1) = mat(1, 1) -CASE (2) - ans = SymEigenValues2by2(mat=mat) -CASE (3) - ans = SymEigenValues3by3(mat=mat) -END SELECT -END PROCEDURE SymEigenValuesUpto3 - -!---------------------------------------------------------------------------- -! SymEigenValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SymEigenValues -INTEGER(I4B) :: n -REAL(DFP), DIMENSION(SIZE(mat, 1), SIZE(mat, 2)) :: temp -!! -n = SIZE(mat, 1) -!! -SELECT CASE (n) -CASE (1) - ans(1) = mat(1, 1) -CASE (2) - ans = SymEigenValues2by2(mat=mat) -CASE (3) - ans = SymEigenValues3by3(mat=mat) -CASE DEFAULT -#ifdef USE_LAPACK95 - temp = mat - CALL SYEV(A=temp, W=ans, JOBZ="N") -#else - CALL ErrorMsg( & - & msg="This routine requires Lapack95 interface", & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymEigenValues()", & - & unitno=stderr) -#endif - !! -END SELECT -END PROCEDURE SymEigenValues - -!---------------------------------------------------------------------------- -! SymEigenValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetSymEigenValues_ -INTEGER(I4B) :: n -!! -n = SIZE(mat, 1) -!! -SELECT CASE (n) -CASE (1) - eigenValues(1) = mat(1, 1) -CASE (2) - eigenValues = SymEigenValues2by2(mat=mat) -CASE (3) - eigenValues = SymEigenValues3by3(mat=mat) -CASE DEFAULT -#ifdef USE_LAPACK95 - CALL SYEV(A=mat, W=eigenValues, JOBZ="N") -#else - CALL ErrorMsg( & - & msg="This routine requires Lapack95 interface", & - & file=__FILE__, & - & line=__LINE__, & - & routine="SymEigenValues_()", & - & unitno=stderr) -#endif - !! -END SELECT -END PROCEDURE GetSymEigenValues_ - -!---------------------------------------------------------------------------- -! SymEigenValues -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetSymEigenValues -REAL(DFP), DIMENSION(SIZE(mat, 1), SIZE(mat, 2)) :: temp -temp = mat -CALL GetSymEigenValues_(mat=temp, eigenValues=eigenValues) -END PROCEDURE GetSymEigenValues - -!---------------------------------------------------------------------------- -! GetSymEigenJacobi -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetSymEigenJacobi -INTEGER(I4B) :: i, ip, iq, n, ii, jj, tRot -REAL(DFP) :: c, g, h, s, sm, t, tau, theta, tresh -REAL(DFP), DIMENSION(SIZE(EigenValues)) :: b, z -REAL(DFP), DIMENSION(SIZE(mat, 1), SIZE(mat, 2)) :: tempMat -REAL(DFP), PARAMETER :: tol = 1.0E-10 - -tempMat = mat - -n = SIZE(mat, 1) - -!---- Initialize v to the identity matrix. -CALL unit_matrix(EigenVectors(:, :)) - -!---- Initialize b and d to the diagonal of A -!---- This vector will accumulate terms of the -!---- form tapq as in eq. (11.1.14). -b(:) = get_diag(tempMat(:, :)) -EigenValues(:) = b(:) -z(:) = 0.0_DFP -tRot = 0 - -DO i = 1, MaxIter - - !---- SUM off-diagonal elements. - sm = SUM(ABS(tempMat), mask=upper_triangle(n, n)) - IF (SOFTEQ(sm, 0.0_DFP, tol)) THEN - - !---- Restore the upper diagonal part - DO jj = 1, n - DO ii = 1, jj - 1 - tempMat(ii, jj) = tempMat(jj, ii) - END DO - END DO - - !---- Sort the Eigen vector and Eigen values in decreasing order - CALL SortEigenValues(EigenValues=EigenValues, & - & EigenVectors=EigenVectors) - RETURN - - END IF - - !---- The normal return, which relies on quadratic convergence - !---- to machine underflow. - tresh = MERGE(0.2_DFP * sm / n**2, 0.0_DFP, i < 4) - - !---- On the first three sweeps, we will rotate only IF tresh exceeded. - DO ip = 1, n - 1 - DO iq = ip + 1, n - g = 100.0_DFP * ABS(tempMat(ip, iq)) - !---- After four sweeps, skip the rotation IF the off-diagonal - !---- element is small. - IF ((i > 4) .AND. (ABS(EigenValues(ip)) + g .EQ. & - & ABS(EigenValues(ip))) .AND. (ABS(EigenValues(iq)) & - & + g .EQ. ABS(EigenValues(iq)))) THEN - - tempMat(ip, iq) = 0.0_DFP - - ELSE IF (ABS(tempMat(ip, iq)) .GT. tresh) THEN - - h = EigenValues(iq) - EigenValues(ip) - - IF (ABS(h) + g .EQ. ABS(h)) THEN - t = tempMat(ip, iq) / h - ELSE - theta = 0.5_DFP * h / tempMat(ip, iq) - t = 1.0_DFP / (ABS(theta) + SQRT(1.0_DFP + theta**2)) - IF (theta .LT. 0.0_DFP) t = -t - END IF - - c = 1.0_DFP / SQRT(1 + t**2) - s = t * c - tau = s / (1.0_DFP + c) - h = t * tempMat(ip, iq) - z(ip) = z(ip) - h - z(iq) = z(iq) + h - EigenValues(ip) = EigenValues(ip) - h - EigenValues(iq) = EigenValues(iq) + h - tempMat(ip, iq) = 0.0_DFP - - CALL jrotate(tempMat(1:ip - 1, ip), tempMat(1:ip - 1, iq)) - ! Case of rotations 1 ≤ j < p. - CALL jrotate(tempMat(ip, ip + 1:iq - 1), tempMat(ip + 1:iq - 1, iq)) - ! Case of rotations p < j < q. - CALL jrotate(tempMat(ip, iq + 1:n), tempMat(iq, iq + 1:n)) - ! Case of rotations q < j ≤ n. - CALL jrotate(EigenVectors(:, ip), EigenVectors(:, iq)) - tRot = tRot + 1 - END IF - END DO - END DO - - b(:) = b(:) + z(:) - ! Update d with the SUM of tapq, and reinitialize z. - EigenValues(:) = b(:) - z(:) = 0.0_DFP -END DO - -CONTAINS - -PURE SUBROUTINE jrotate(a1, a2) - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: a1, a2 - REAL(DFP), DIMENSION(SIZE(a1)) :: wk1 - wk1(:) = a1(:) - a1(:) = a1(:) - s * (a2(:) + a1(:) * tau) - a2(:) = a2(:) + s * (wk1(:) - a2(:) * tau) -END SUBROUTINE jrotate - -PURE FUNCTION get_diag(mat) - REAL(DFP), DIMENSION(:, :), INTENT(IN) :: mat - REAL(DFP), DIMENSION(SIZE(mat, 1)) :: get_diag - INTEGER(I4B) :: j - j = size(mat, 1) - DO j = 1, size(mat, 1) - get_diag(j) = mat(j, j) - END DO -END FUNCTION get_diag - -PURE SUBROUTINE unit_matrix(mat) - REAL(DFP), DIMENSION(:, :), INTENT(OUT) :: mat - INTEGER(I4B) :: i, n - n = min(size(mat, 1), size(mat, 2)) - mat(:, :) = 0.0_sp - DO i = 1, n - mat(i, i) = 1.0_sp - END DO -END SUBROUTINE unit_matrix - -PURE SUBROUTINE SortEigenValues(EigenValues, EigenVectors) - REAL(DFP), DIMENSION(:), INTENT(INOUT) :: EigenValues - REAL(DFP), DIMENSION(:, :), INTENT(INOUT) :: EigenVectors - INTEGER(I4B) :: i, j, n - - n = SIZE(EigenValues) - - DO i = 1, n - 1 - j = ImaxLoc(EigenValues(i:n)) - j = j + i - 1 - IF (j .NE. i) THEN - CALL SWAP(EigenValues(i), EigenValues(j)) - CALL SWAP(EigenVectors(:, i), EigenVectors(:, j)) - END IF - END DO -END SUBROUTINE SortEigenValues - -PURE FUNCTION upper_triangle(j, k, extra) - INTEGER(I4B), INTENT(IN) :: j, k - INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra - LOGICAL(LGT), DIMENSION(j, k) :: upper_triangle - INTEGER(I4B) :: n - n = 0 - IF (PRESENT(extra)) n = extra - upper_triangle = (outerDiff(arth(1, 1, j), arth(1, 1, k)) < n) -END FUNCTION upper_triangle - -! PURE FUNCTION lower_triangle(j,k,extra) -! INTEGER(I4B), INTENT(IN) :: j,k -! INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra -! LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle -! INTEGER(I4B) :: n -! n=0 -! IF (PRESENT(extra)) n=extra -! lower_triangle=(outerdIFf(arth_i(1,1,j),arth_i(1,1,k)) > -n) -! END FUNCTION lower_triangle -END PROCEDURE GetSymEigenJacobi - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Expand/Expand.inc b/src/submodules/Utility/src/Expand/Expand.inc deleted file mode 100644 index 520cd21bb..000000000 --- a/src/submodules/Utility/src/Expand/Expand.inc +++ /dev/null @@ -1,47 +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 -! -!! -!! temporary array -!! -IF( PRESENT(val) ) THEN - IF( ALLOCATED(vec) ) THEN - IF( n .EQ. SIZE(vec)) THEN - ! have to add another chunk: - ALLOCATE(tmp(SIZE(vec)+chunk_size)) - tmp(1:SIZE(vec)) = vec - CALL MOVE_ALLOC(tmp,vec) - END IF - n = n + 1 - ELSE - ! the first element: - ALLOCATE(vec(chunk_size)) - n = 1 - END IF - vec(n) = val -END IF -!! -!! -!! -IF (PRESENT(finished)) THEN - IF (finished) THEN - ! set vec to actual size (n): - IF (ALLOCATED(tmp)) DEALLOCATE(tmp) - ALLOCATE(tmp(n)) - tmp = vec(1:n) - CALL MOVE_ALLOC(tmp,vec) - END IF -END IF \ No newline at end of file diff --git a/src/submodules/Utility/src/Expand/ExpandMatrix.inc b/src/submodules/Utility/src/Expand/ExpandMatrix.inc deleted file mode 100644 index 511cf0f09..000000000 --- a/src/submodules/Utility/src/Expand/ExpandMatrix.inc +++ /dev/null @@ -1,55 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -!! -!! temporary array -!! - -INTEGER( I4B ) :: dimSize1, dimSize2, otherdim - - -IF (PRESENT(val)) THEN - IF (dim .EQ. 1) THEN - ELSE - END IF - - IF (ALLOCATED(mat)) THEN - IF (n .EQ. SIZE(mat, dim)) THEN - ! have to add another chunk: - ALLOCATE (tmp(SIZE(mat, dim) + chunk_size, SIZE(mat, otherdim))) - tmp(1:SIZE(mat, 1), 1:SIZE(mat, 2) ) = mat - CALL MOVE_ALLOC(tmp, mat) - END IF - n = n + 1 - ELSE - ! the first element: - ALLOCATE (mat(chunk_size)) - n = 1 - END IF - mat(n) = val -END IF -!! -!! -!! -IF (PRESENT(finished)) THEN - IF (finished) THEN - ! set mat to actual size (n): - IF (ALLOCATED(tmp)) DEALLOCATE (tmp) - ALLOCATE (tmp(n)) - tmp = mat(1:n) - CALL MOVE_ALLOC(tmp, mat) - END IF -END IF diff --git a/src/submodules/Utility/src/EyeUtility@Methods.F90 b/src/submodules/Utility/src/EyeUtility@Methods.F90 deleted file mode 100644 index 9337cd5e8..000000000 --- a/src/submodules/Utility/src/EyeUtility@Methods.F90 +++ /dev/null @@ -1,120 +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(EyeUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE int_eye_1 -INTEGER(I4B) :: i -Ans = 0_INT8 -DO i = 1, m - Ans(i, i) = 1 -END DO -END PROCEDURE int_eye_1 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE int_eye_2 -INTEGER(I4B) :: i -Ans = 0_INT16 -DO i = 1, m - Ans(i, i) = 1 -END DO -END PROCEDURE int_eye_2 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE int_eye_3 -INTEGER(I4B) :: i -Ans = 0_INT32 -DO i = 1, m - Ans(i, i) = 1 -END DO -END PROCEDURE int_eye_3 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE int_eye_4 -INTEGER(I4B) :: i -Ans = 0_INT64 -DO i = 1, m - Ans(i, i) = 1 -END DO -END PROCEDURE int_eye_4 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE int_eye_5 -INTEGER(I4B) :: i -Ans = 0_INT128 -DO i = 1, m - Ans(i, i) = 1 -END DO -END PROCEDURE int_eye_5 -#endif - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE real_eye_1 -INTEGER(I4B) :: i -Ans = 0.0 -DO i = 1, m - Ans(i, i) = 1.0 -END DO -END PROCEDURE real_eye_1 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE real_eye_2 -INTEGER(I4B) :: i -Ans = 0.0 -DO i = 1, m - Ans(i, i) = 1.0 -END DO -END PROCEDURE real_eye_2 - -!---------------------------------------------------------------------------- -! Eye -!---------------------------------------------------------------------------- - -MODULE PROCEDURE real_eye_3 -INTEGER(I4B) :: i -Ans = 0.0 -DO i = 1, m - Ans(i, i) = 1.0 -END DO -END PROCEDURE real_eye_3 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/GridPointUtility@Methods.F90 b/src/submodules/Utility/src/GridPointUtility@Methods.F90 deleted file mode 100644 index a01b11291..000000000 --- a/src/submodules/Utility/src/GridPointUtility@Methods.F90 +++ /dev/null @@ -1,239 +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(GridPointUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! ExpMesh -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ExpMesh_Real64 -INTEGER(I4B) :: i -REAL(DFP) :: alpha, beta - !! -IF (ABS(a - 1) .LT. TINY(1.0_DFP)) THEN - alpha = (rmax - rmin) / N - DO i = 1, N + 1 - ans(i) = alpha * (i - 1.0_DFP) + rmin - END DO -ELSE - IF (N .GT. 1) THEN - beta = LOG(a) / (N - 1) - alpha = (rmax - rmin) / (EXP(beta * N) - 1) - DO i = 1, N + 1 - ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin - END DO - ELSE IF (N .EQ. 1) THEN - ans(1) = rmin - ans(2) = rmax - END IF -END IF - !! -END PROCEDURE ExpMesh_Real64 - -!---------------------------------------------------------------------------- -! ExpMesh -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ExpMesh_Real32 -INTEGER(I4B) :: i -REAL(Real32) :: alpha, beta - !! -IF (ABS(a - 1) .LT. TINY(1.0_DFP)) THEN - alpha = (rmax - rmin) / N - DO i = 1, N + 1 - ans(i) = alpha * (i - 1.0_Real32) + rmin - END DO -ELSE - IF (N .GT. 1) THEN - beta = LOG(a) / (N - 1) - alpha = (rmax - rmin) / (EXP(beta * N) - 1) - DO i = 1, N + 1 - ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin - END DO - ELSE IF (N .EQ. 1) THEN - ans(1) = rmin - ans(2) = rmax - END IF -END IF - !! -END PROCEDURE ExpMesh_Real32 - -!---------------------------------------------------------------------------- -! Linspace -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LinSpace_Real32 -! Local vars -REAL(Real32) :: dx -INTEGER(I4B) :: i -INTEGER(I4B) :: nn - !! main -nn = INPUT(option=n, default=100) -IF (nn .EQ. 1) THEN - ans = [a] -ELSE - ALLOCATE (ans(nn)) - dx = (b - a) / REAL((nn - 1), Real32) - ans = [(i * dx + a, i=0, nn - 1)] -END IF -END PROCEDURE LinSpace_Real32 - -!---------------------------------------------------------------------------- -! LinSpace -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LinSpace_Real64 -! Local vars -REAL(Real64) :: dx -INTEGER(I4B) :: i -INTEGER(I4B) :: nn -!> main -nn = INPUT(option=n, default=100) -IF (nn .EQ. 1) THEN - ans = [a] -ELSE - ALLOCATE (ans(nn)) - dx = (b - a) / REAL((nn - 1), Real64) - ans = [(i * dx + a, i=0, nn - 1)] -END IF -END PROCEDURE LinSpace_Real64 - -!---------------------------------------------------------------------------- -! Linspace -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LogSpace_Real32 -INTEGER(I4B) :: base0, n0 -LOGICAL(LGT) :: endpoint0 -REAL(Real32), ALLOCATABLE :: ans0(:) - !! -endpoint0 = INPUT(option=endPoint, default=.TRUE.) -base0 = INPUT(option=base, default=10) -n0 = INPUT(option=n, default=100_I4B) - !! -IF (endpoint0) THEN - ans0 = Linspace(a=a, b=b, n=n0) - ans = base0**(ans0) -ELSE - ans0 = Linspace(a=a, b=b, n=n0 + 1) - ans = base0**(ans0(1:n0)) -END IF - !! -IF (ALLOCATED(ans0)) DEALLOCATE (ans0) -END PROCEDURE LogSpace_Real32 - -!---------------------------------------------------------------------------- -! Linspace -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LogSpace_Real64 -INTEGER(I4B) :: base0, n0 -LOGICAL(LGT) :: endpoint0 -REAL(Real64), ALLOCATABLE :: ans0(:) - !! -endpoint0 = INPUT(option=endPoint, default=.TRUE.) -base0 = INPUT(option=base, default=10) -n0 = INPUT(option=n, default=100_I4B) - !! -IF (endpoint0) THEN - ans0 = Linspace(a=a, b=b, n=n0) - ans = base0**(ans0) -ELSE - ans0 = Linspace(a=a, b=b, n=n0 + 1) - ans = base0**(ans0(1:n0)) -END IF - !! -IF (ALLOCATED(ans0)) DEALLOCATE (ans0) -END PROCEDURE LogSpace_Real64 - -!---------------------------------------------------------------------------- -! MeshGrid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MeshGrid2D_Real64 -! Local variables -INTEGER(I4B) :: nx -INTEGER(I4B) :: ny -! Initial setting -nx = SIZE(xgv, dim=1) -ny = SIZE(ygv, dim=1) -CALL Reallocate(x, ny, nx) -CALL Reallocate(y, ny, nx) -x(:, :) = SPREAD(xgv, dim=2, ncopies=ny) -y(:, :) = SPREAD(ygv, dim=1, ncopies=nx) -END PROCEDURE MeshGrid2D_Real64 - -!---------------------------------------------------------------------------- -! MeshGrid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MeshGrid2D_Real32 -! Local variables -INTEGER(I4B) :: nx -INTEGER(I4B) :: ny -! Initial setting -nx = SIZE(xgv, dim=1) -ny = SIZE(ygv, dim=1) -CALL Reallocate(x, ny, nx) -CALL Reallocate(y, ny, nx) -x(:, :) = SPREAD(xgv, dim=2, ncopies=ny) -y(:, :) = SPREAD(ygv, dim=1, ncopies=nx) -END PROCEDURE MeshGrid2D_Real32 - -!---------------------------------------------------------------------------- -! MeshGrid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MeshGrid3D_Real64 -integer :: nx, ny, nz, i -nx = size(xgv); ny = size(ygv); nz = size(zgv) -CALL Reallocate(x, nx, ny, nz) -CALL Reallocate(y, nx, ny, nz) -CALL Reallocate(z, nx, ny, nz) -DO i = 1, nz - x(:, :, i) = SPREAD(xgv, dim=2, ncopies=ny) - y(:, :, i) = SPREAD(ygv, dim=1, ncopies=nx) -END DO -DO i = 1, nx - z(i, :, :) = SPREAD(zgv, dim=1, ncopies=ny) -END DO -END PROCEDURE MeshGrid3D_Real64 - -!---------------------------------------------------------------------------- -! MeshGrid -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MeshGrid3D_Real32 -integer :: nx, ny, nz, i -nx = size(xgv); ny = size(ygv); nz = size(zgv) -CALL Reallocate(x, ny, nx, nz) -CALL Reallocate(y, ny, nx, nz) -CALL Reallocate(z, ny, nx, nz) -DO i = 1, nz - x(:, :, i) = SPREAD(xgv, dim=2, ncopies=ny) - y(:, :, i) = SPREAD(ygv, dim=1, ncopies=nx) -END DO -DO i = 1, nx - z(i, :, :) = SPREAD(zgv, dim=1, ncopies=ny) -END DO -END PROCEDURE MeshGrid3D_Real32 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/HashingUtility@Methods.F90 b/src/submodules/Utility/src/HashingUtility@Methods.F90 deleted file mode 100644 index 3a814257a..000000000 --- a/src/submodules/Utility/src/HashingUtility@Methods.F90 +++ /dev/null @@ -1,54 +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(HashingUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! C code from the refer to -! https://cp-algorithms.com/string/string-hashing.html -! long long compute_hash(string const& s) { -! const int p = 31; -! const int m = 1e9 + 9; -! long long hash_value = 0; -! long long p_pow = 1; -! for (char c : s) { -! hash_value = (hash_value + (c - 'a' + 1) * p_pow) % m; -! p_pow = (p_pow * p) % m; -! } -! return hash_value; -! } - -MODULE PROCEDURE StringToUID_PolyRoll - INTEGER( I4B ), PARAMETER :: p = 53 - INTEGER( I4B ), PARAMETER :: m = 1e6 + 9 - INTEGER( I4B ) :: p_pow, ii - !! - p_pow = 1 - ans = 0 - !! - DO ii = 1, LEN_TRIM( charVar ) - ans = MOD( (ans + (ICHAR(charVar(ii:ii)) - ICHAR('A') + 1) * p_pow ), m ) - p_pow = MOD( (p_pow * p), m ) - END DO -END PROCEDURE StringToUID_PolyRoll - -END SUBMODULE Methods \ No newline at end of file diff --git a/src/submodules/Utility/src/HeadUtility@Methods.F90 b/src/submodules/Utility/src/HeadUtility@Methods.F90 deleted file mode 100644 index 488b773f5..000000000 --- a/src/submodules/Utility/src/HeadUtility@Methods.F90 +++ /dev/null @@ -1,67 +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(HeadUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Head -!---------------------------------------------------------------------------- - -MODULE PROCEDURE head_Int8 -ans = x(1) -END PROCEDURE head_Int8 - -MODULE PROCEDURE head_Int16 -ans = x(1) -END PROCEDURE head_Int16 - -MODULE PROCEDURE head_Int32 -ans = x(1) -END PROCEDURE head_Int32 - -MODULE PROCEDURE head_Int64 -ans = x(1) -END PROCEDURE head_Int64 - -!---------------------------------------------------------------------------- -! Head -!---------------------------------------------------------------------------- - -MODULE PROCEDURE head_Real32 -ans = x(1) -END PROCEDURE head_Real32 - -MODULE PROCEDURE head_Real64 -ans = x(1) -END PROCEDURE head_Real64 - -!---------------------------------------------------------------------------- -! Head -!---------------------------------------------------------------------------- - -MODULE PROCEDURE head_char -ans(1:1) = x(1:1) -END PROCEDURE head_char - -!---------------------------------------------------------------------------- -! Tail -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/HeapSort/ArgHeapSort.inc b/src/submodules/Utility/src/HeapSort/ArgHeapSort.inc deleted file mode 100644 index 761097bae..000000000 --- a/src/submodules/Utility/src/HeapSort/ArgHeapSort.inc +++ /dev/null @@ -1,76 +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 array program. If not, see -! - -INTEGER(I4B) :: start, bottom -INTEGER(I4B) :: N - -N = SIZE(arg) -arg = arange(1_I4B, n, 1_I4B) - -DO start = ((n - 2) / 2), 0, -1 - CALL argSiftdown(arg, start, n); -END DO - -DO bottom = n - 1, 1, -1 - CALL Swap(arg(0), arg(bottom)) - CALL argSiftdown(arg, 0, bottom) -END DO - -CONTAINS - -PURE SUBROUTINE argSiftdown(arg, start, bottom) - INTEGER(I4B), INTENT(INOUT) :: arg(0:) - INTEGER(I4B), INTENT(IN) :: start - INTEGER(I4B), INTENT(IN) :: bottom - ! - INTEGER(I4B) :: i, j - i = start - DO WHILE ((i * 2) + 1 < bottom) - j = (i * 2) + 1 - IF (j + 1 < bottom) THEN - IF (array(arg(j)) < array(arg(j + 1))) j = j + 1 - END IF - IF (array(arg(i)) < array(arg(j))) THEN - CALL Swap(arg(i), arg(j)) - i = j - ELSE - EXIT - END IF - END DO - -END SUBROUTINE - -! subroutine argSiftdown(array, arg, start, bottom) -! real(Real32) :: array(:) -! INTEGER(Int32) :: arg(0:) -! INTEGER(Int32) :: start -! INTEGER(Int32) :: bottom -! INTEGER(Int32) :: i, j -! i = start -! DO WHILE ((i * 2) + 1 < bottom) -! j = (i * 2) + 1 -! IF (j + 1 < bottom) THEN -! IF (array(arg(j)) < array(arg(j + 1))) j = j + 1 -! END IF -! IF (array(arg(i)) < array(arg(j))) THEN -! CALL swap(arg(i), arg(j)) -! i = j -! ELSE -! RETURN -! END IF -! END DO -! END subroutine diff --git a/src/submodules/Utility/src/HeapSort/HeapSort.inc b/src/submodules/Utility/src/HeapSort/HeapSort.inc deleted file mode 100644 index 5516423ef..000000000 --- a/src/submodules/Utility/src/HeapSort/HeapSort.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 -! - -INTEGER(I4B) :: n, i, k, j, l - -n = SIZE(array) -IF (n .LE. 1) RETURN -l = n / 2 + 1 -k = n -DO WHILE (k .NE. 1) - IF (l .GT. 1) THEN - l = l - 1 - t = array(L) - ELSE - t = array(k) - array(k) = array(1) - k = k - 1 - IF (k .EQ. 1) THEN - array(1) = t - EXIT - END IF - END IF - i = l - j = l + l - DO WHILE (j .LE. k) - IF (j .LT. k) THEN - IF (array(j) .LT. array(j + 1)) j = j + 1 - END IF - IF (t .LT. array(j)) THEN - array(i) = array(j) - i = j - j = j + j - ELSE - j = k + 1 - END IF - END DO - array(i) = t -END DO diff --git a/src/submodules/Utility/src/In/In_1.inc b/src/submodules/Utility/src/In/In_1.inc deleted file mode 100644 index 1bbf7c7cf..000000000 --- a/src/submodules/Utility/src/In/In_1.inc +++ /dev/null @@ -1,32 +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 -! - - -INTEGER(I4B) :: ii - -ans = .TRUE. -IF (SIZE(a) .GT. SIZE(b)) THEN - ans = .FALSE. - RETURN -END IF - -DO ii = 1, SIZE(a) - IF (.NOT. ANY(a(ii) .EQ. b)) THEN - ans = .FALSE. - EXIT - END IF -END DO diff --git a/src/submodules/Utility/src/In/IsIn_1.inc b/src/submodules/Utility/src/In/IsIn_1.inc deleted file mode 100644 index 125ac6262..000000000 --- a/src/submodules/Utility/src/In/IsIn_1.inc +++ /dev/null @@ -1,23 +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 -! - -!! -INTEGER(I4B) :: ii -!! -DO ii = 1, SIZE(a) - ans( ii ) = ANY(a(ii) .EQ. b) -END DO \ No newline at end of file diff --git a/src/submodules/Utility/src/Input/Input1.inc b/src/submodules/Utility/src/Input/Input1.inc deleted file mode 100644 index 233d59e61..000000000 --- a/src/submodules/Utility/src/Input/Input1.inc +++ /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 -! - -IF(PRESENT(option) )THEN - ans=option -ELSE - ans=default -ENDIF \ No newline at end of file diff --git a/src/submodules/Utility/src/InputUtility@Methods.F90 b/src/submodules/Utility/src/InputUtility@Methods.F90 deleted file mode 100644 index dea94390b..000000000 --- a/src/submodules/Utility/src/InputUtility@Methods.F90 +++ /dev/null @@ -1,150 +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: 3 April 2021 -! summary: This method contains the input method - -SUBMODULE(InputUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_Int8 -#include "./Input/Input1.inc" -END PROCEDURE input_Int8 -MODULE PROCEDURE input_Int16 -#include "./Input/Input1.inc" -END PROCEDURE input_Int16 -MODULE PROCEDURE input_Int32 -#include "./Input/Input1.inc" -END PROCEDURE input_Int32 -MODULE PROCEDURE input_Int64 -#include "./Input/Input1.inc" -END PROCEDURE input_Int64 - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_Real32 -#include "./Input/Input1.inc" -END PROCEDURE input_Real32 -MODULE PROCEDURE input_Real64 -#include "./Input/Input1.inc" -END PROCEDURE input_Real64 - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_Int8Vec -#include "./Input/Input1.inc" -END PROCEDURE input_Int8Vec -MODULE PROCEDURE input_Int16Vec -#include "./Input/Input1.inc" -END PROCEDURE input_Int16Vec -MODULE PROCEDURE input_Int32Vec -#include "./Input/Input1.inc" -END PROCEDURE input_Int32Vec -MODULE PROCEDURE input_Int64Vec -#include "./Input/Input1.inc" -END PROCEDURE input_Int64Vec - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_Real32vec -#include "./Input/Input1.inc" -END PROCEDURE input_Real32vec -MODULE PROCEDURE input_Real64vec -#include "./Input/Input1.inc" -END PROCEDURE input_Real64vec - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_Int8Array -#include "./Input/Input1.inc" -END PROCEDURE input_Int8Array -MODULE PROCEDURE input_Int16Array -#include "./Input/Input1.inc" -END PROCEDURE input_Int16Array -MODULE PROCEDURE input_Int32Array -#include "./Input/Input1.inc" -END PROCEDURE input_Int32Array -MODULE PROCEDURE input_Int64Array -#include "./Input/Input1.inc" -END PROCEDURE input_Int64Array - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_Real32Array -#include "./Input/Input1.inc" -END PROCEDURE input_Real32Array -MODULE PROCEDURE input_Real64Array -#include "./Input/Input1.inc" -END PROCEDURE input_Real64Array - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_String -#include "./Input/Input1.inc" -END PROCEDURE input_String - -! MODULE PROCEDURE input_StringVec -! #include "./Input/Input1.inc" -! END PROCEDURE input_StringVec - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_logical -#include "./Input/Input1.inc" -END PROCEDURE input_logical - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_logicalvec -#include "./Input/Input1.inc" -END PROCEDURE input_logicalvec - -!---------------------------------------------------------------------------- -! Input -!---------------------------------------------------------------------------- - -MODULE PROCEDURE input_logicalArray -#include "./Input/Input1.inc" -END PROCEDURE input_logicalArray - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc b/src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc deleted file mode 100644 index 78ed3fe96..000000000 --- a/src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc +++ /dev/null @@ -1,28 +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 -! - -INTEGER(I4B) :: ii, jj - -DO ii = low, high - DO jj = ii, low + 1, -1 - IF (array(arg(jj)) < array(arg(jj - 1))) THEN - CALL SWAP(arg(jj), arg(jj - 1)) - ELSE - EXIT - END IF - END DO -END DO diff --git a/src/submodules/Utility/src/InsertionSort/InsertionSort.inc b/src/submodules/Utility/src/InsertionSort/InsertionSort.inc deleted file mode 100644 index 76778c5c8..000000000 --- a/src/submodules/Utility/src/InsertionSort/InsertionSort.inc +++ /dev/null @@ -1,28 +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 -! - -INTEGER(I4B) :: ii, jj - -DO ii = low, high - DO jj = ii, low + 1, -1 - IF (array(jj) < array(jj - 1)) THEN - CALL SWAP(array(jj), array(jj - 1)) - ELSE - EXIT - END IF - END DO -END DO diff --git a/src/submodules/Utility/src/IntegerUtility@Methods.F90 b/src/submodules/Utility/src/IntegerUtility@Methods.F90 deleted file mode 100644 index ae4879e44..000000000 --- a/src/submodules/Utility/src/IntegerUtility@Methods.F90 +++ /dev/null @@ -1,361 +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(IntegerUtility) Methods -USE AppendUtility, ONLY: OPERATOR(.ROWCONCAT.), & - OPERATOR(.COLCONCAT.), & - Expand -USE SortUtility, ONLY: QuickSort -USE BinomUtility, ONLY: Binom -USE OnesUtility, ONLY: ones - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Size1 -ans = INT(Binom(n + d, d, 1.0_DFP), KIND=I4B) -END PROCEDURE obj_Size1 - -!---------------------------------------------------------------------------- -! Size -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Size2 -INTEGER(I4B) :: ii -ans = 0_I4B -DO ii = 0, n - ans = ans + SIZE(n=ii, d=d) -END DO -END PROCEDURE obj_Size2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetMultiIndices1 -INTEGER(I4B) :: ii, m -INTEGER(I4B), ALLOCATABLE :: indx(:, :), acol(:), indx2(:, :) - -SELECT CASE (d) -CASE (1_I4B) - - ALLOCATE (ans(2, n + 1)) - DO ii = 0, n - ans(1:2, ii + 1) = [ii, n - ii] - END DO - -CASE DEFAULT - - ALLOCATE (ans(d + 1, 1)) - ans = 0; ans(1, 1) = n - - DO ii = n - 1, 0_I4B, -1_I4B - - indx = GetMultiIndices(n=n - ii, d=d - 1) - m = SIZE(indx, 2) - acol = ii * ones(m, 1_I4B) - indx2 = acol.ROWCONCAT.indx - ans = indx2.COLCONCAT.ans - - END DO - -END SELECT - -IF (ALLOCATED(indx)) DEALLOCATE (indx) -IF (ALLOCATED(acol)) DEALLOCATE (acol) -IF (ALLOCATED(indx2)) DEALLOCATE (indx2) - -END PROCEDURE obj_GetMultiIndices1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_GetMultiIndices2 -INTEGER(I4B) :: ii, m, r1, r2 - -m = SIZE(n, d, .TRUE.) -ALLOCATE (ans(d + 1, m)) - -r1 = 0; r2 = 0 -DO ii = 0, n - m = SIZE(n=ii, d=d) - r1 = r2 + 1_I4B - r2 = r1 + m - 1 - ans(:, r1:r2) = GetMultiIndices(n=ii, d=d) -END DO - -END PROCEDURE obj_GetMultiIndices2 - -!---------------------------------------------------------------------------- -! IN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE in_1a -#include "./In/In_1.inc" -END PROCEDURE in_1a - -MODULE PROCEDURE in_1b -#include "./In/In_1.inc" -END PROCEDURE in_1b - -MODULE PROCEDURE in_1c -#include "./In/In_1.inc" -END PROCEDURE in_1c - -MODULE PROCEDURE in_1d -#include "./In/In_1.inc" -END PROCEDURE in_1d - -!---------------------------------------------------------------------------- -! isIN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IsIn_1a -#include "./In/IsIn_1.inc" -END PROCEDURE IsIn_1a - -MODULE PROCEDURE IsIn_1b -#include "./In/IsIn_1.inc" -END PROCEDURE IsIn_1b - -MODULE PROCEDURE IsIn_1c -#include "./In/IsIn_1.inc" -END PROCEDURE IsIn_1c - -MODULE PROCEDURE IsIn_1d -#include "./In/IsIn_1.inc" -END PROCEDURE IsIn_1d - -!---------------------------------------------------------------------------- -! IN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE in_2a -ans = ANY(a .EQ. b) -END PROCEDURE in_2a - -MODULE PROCEDURE in_2b -ans = ANY(a .EQ. b) -END PROCEDURE in_2b - -MODULE PROCEDURE in_2c -ans = ANY(a .EQ. b) -END PROCEDURE in_2c - -MODULE PROCEDURE in_2d -ans = ANY(a .EQ. b) -END PROCEDURE in_2d - -!---------------------------------------------------------------------------- -! RemoveDuplicate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RemoveDuplicates_1a -INTEGER(INT8) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_1.inc" -END PROCEDURE RemoveDuplicates_1a - -MODULE PROCEDURE RemoveDuplicates_1b -INTEGER(INT16) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_1.inc" -END PROCEDURE RemoveDuplicates_1b - -MODULE PROCEDURE RemoveDuplicates_1c -INTEGER(INT32) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_1.inc" -END PROCEDURE RemoveDuplicates_1c - -MODULE PROCEDURE RemoveDuplicates_1d -INTEGER(INT64) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_1.inc" -END PROCEDURE RemoveDuplicates_1d - -!---------------------------------------------------------------------------- -! RemoveDuplicate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RemoveDuplicates_1a_ -INTEGER(INT8) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_2.inc" -END PROCEDURE RemoveDuplicates_1a_ - -MODULE PROCEDURE RemoveDuplicates_1b_ -INTEGER(INT16) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_2.inc" -END PROCEDURE RemoveDuplicates_1b_ - -MODULE PROCEDURE RemoveDuplicates_1c_ -INTEGER(INT32) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_2.inc" -END PROCEDURE RemoveDuplicates_1c_ - -MODULE PROCEDURE RemoveDuplicates_1d_ -INTEGER(INT64) :: temp(SIZE(obj)) -#include "./RemoveDuplicates/RemoveDuplicates_2.inc" -END PROCEDURE RemoveDuplicates_1d_ - -!---------------------------------------------------------------------------- -! Repeat -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Repeat_1a -#include "./Repeat/Repeat_1.inc" -END PROCEDURE Repeat_1a - -MODULE PROCEDURE Repeat_1b -#include "./Repeat/Repeat_1.inc" -END PROCEDURE Repeat_1b - -MODULE PROCEDURE Repeat_1c -#include "./Repeat/Repeat_1.inc" -END PROCEDURE Repeat_1c - -MODULE PROCEDURE Repeat_1d -#include "./Repeat/Repeat_1.inc" -END PROCEDURE Repeat_1d - -MODULE PROCEDURE Repeat_1e -#include "./Repeat/Repeat_1.inc" -END PROCEDURE Repeat_1e - -MODULE PROCEDURE Repeat_1f -#include "./Repeat/Repeat_1.inc" -END PROCEDURE Repeat_1f - -!---------------------------------------------------------------------------- -! IndexOf -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetIndex1 -Ans = MINLOC(ABS(obj - val), 1) -END PROCEDURE GetIndex1 - -!---------------------------------------------------------------------------- -! IndexOf -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetIndex2 -INTEGER(I4B) :: i, j, m -LOGICAL(LGT), ALLOCATABLE :: Search(:) - -m = SIZE(val) -ALLOCATE (Search(m), Ans(m)) -Search = .TRUE. -Ans = 0 - -DO i = 1, SIZE(obj) - DO j = 1, m - IF (Search(j)) THEN - IF (val(j) .EQ. obj(i)) THEN - Search(j) = .FALSE. - Ans(j) = i - END IF - END IF - END DO -END DO -END PROCEDURE GetIndex2 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Get1_Int8 -ans = 0 -IF (indx .LE. SIZE(val)) ans = val(indx) -END PROCEDURE Get1_Int8 - -MODULE PROCEDURE Get1_Int16 -ans = 0 -IF (indx .LE. SIZE(val)) ans = val(indx) -END PROCEDURE Get1_Int16 - -MODULE PROCEDURE Get1_Int32 -ans = 0 -IF (indx .LE. SIZE(val)) ans = val(indx) -END PROCEDURE Get1_Int32 - -MODULE PROCEDURE Get1_Int64 -ans = 0 -IF (indx .LE. SIZE(val)) ans = val(indx) -END PROCEDURE Get1_Int64 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Get2_Int8 -ans = val(indx) -END PROCEDURE Get2_Int8 - -MODULE PROCEDURE Get2_Int16 -ans = val(indx) -END PROCEDURE Get2_Int16 - -MODULE PROCEDURE Get2_Int32 -ans = val(indx) -END PROCEDURE Get2_Int32 - -MODULE PROCEDURE Get2_Int64 -ans = val(indx) -END PROCEDURE Get2_Int64 - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Get3_Int8 -ans = val(istart:iend:stride) -END PROCEDURE Get3_Int8 - -MODULE PROCEDURE Get3_Int16 -ans = val(istart:iend:stride) -END PROCEDURE Get3_Int16 - -MODULE PROCEDURE Get3_Int32 -ans = val(istart:iend:stride) -END PROCEDURE Get3_Int32 - -MODULE PROCEDURE Get3_Int64 -ans = val(istart:iend:stride) -END PROCEDURE Get3_Int64 - -!---------------------------------------------------------------------------- -! GetIntersection -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetIntersection1 -#include "./Intersection/Intersection.inc" -END PROCEDURE GetIntersection1 - -MODULE PROCEDURE GetIntersection2 -#include "./Intersection/Intersection.inc" -END PROCEDURE GetIntersection2 - -MODULE PROCEDURE GetIntersection3 -#include "./Intersection/Intersection.inc" -END PROCEDURE GetIntersection3 - -MODULE PROCEDURE GetIntersection4 -#include "./Intersection/Intersection.inc" -END PROCEDURE GetIntersection4 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Intersection/Intersection.inc b/src/submodules/Utility/src/Intersection/Intersection.inc deleted file mode 100644 index 926c381d5..000000000 --- a/src/submodules/Utility/src/Intersection/Intersection.inc +++ /dev/null @@ -1,22 +0,0 @@ -INTEGER(I4B) :: tsize1, tsize2, ii - -tsize1 = SIZE(a) -tsize2 = SIZE(b) -tsize = 0 - -IF (tsize1 .LE. tsize2) THEN - DO ii = 1, tsize1 - IF (ANY(a(ii) .EQ. b)) THEN - tsize = tsize + 1 - c(tsize) = a(ii) - END IF - END DO - RETURN -END IF - -DO ii = 1, tsize2 - IF (ANY(b(ii) .EQ. a)) THEN - tsize = tsize + 1 - c(tsize) = b(ii) - END IF -END DO diff --git a/src/submodules/Utility/src/IntroSort/ArgIntroSort.inc b/src/submodules/Utility/src/IntroSort/ArgIntroSort.inc deleted file mode 100644 index 63b7886bf..000000000 --- a/src/submodules/Utility/src/IntroSort/ArgIntroSort.inc +++ /dev/null @@ -1,16 +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 -! diff --git a/src/submodules/Utility/src/IntroSort/IntroSort.inc b/src/submodules/Utility/src/IntroSort/IntroSort.inc deleted file mode 100644 index 63b7886bf..000000000 --- a/src/submodules/Utility/src/IntroSort/IntroSort.inc +++ /dev/null @@ -1,16 +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 -! diff --git a/src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc b/src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc deleted file mode 100644 index 980800478..000000000 --- a/src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc +++ /dev/null @@ -1,31 +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 -! - -N = right - left + 1 -IF (N < minimumLengthForInsertion) THEN - CALL argInsertionSort(this, idx, left, right) - RETURN -END IF -IF (maxDepth == 0) THEN - CALL argHeapsort(this, idx(left:right)) - RETURN -END IF -imid = left + N / 2 -CALL argMedian(this, idx, left, imid, right) -CALL argPartition(this, idx, left, right, iPivot) -CALL _Recursive_ArgIntroSort_(this, idx, left, iPivot - 1, maxDepth - 1) -CALL _Recursive_ArgIntroSort_(this, idx, iPivot + 1, right, maxDepth - 1) diff --git a/src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc b/src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc deleted file mode 100644 index d2ab39821..000000000 --- a/src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc +++ /dev/null @@ -1,32 +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 -! - -N = right - left + 1 -IF (N < minimumLengthForInsertion) THEN - CALL InsertionSort(this, left, right) - RETURN -END IF -IF (maxDepth .EQ. 0) THEN - CALL Heapsort(this(left:right)) - RETURN -END IF -imid = left + N / 2 -CALL Median(this, left, imid, right) -CALL swap(this(left), this(imid)) -CALL partition(this, left, right, iPivot) -CALL _Recursive_IntroSort_(this, left, iPivot - 1, maxDepth - 1) -CALL _Recursive_IntroSort_(this, iPivot + 1, right, maxDepth - 1) diff --git a/src/submodules/Utility/src/InvUtility@Methods.F90 b/src/submodules/Utility/src/InvUtility@Methods.F90 deleted file mode 100644 index 6a89a8ccc..000000000 --- a/src/submodules/Utility/src/InvUtility@Methods.F90 +++ /dev/null @@ -1,225 +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: 3 April 2021 -! summary: Methods for determining determinent and inverse of small matrix - -SUBMODULE(InvUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS -!---------------------------------------------------------------------------- -! DET -!---------------------------------------------------------------------------- - -MODULE PROCEDURE det_2D -SELECT CASE (SIZE(A, 1)) -CASE (1) - Ans = A(1, 1) -CASE (2) - Ans = A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1) -CASE (3) - Ans = A(1, 1) * (A(2, 2) * A(3, 3) - A(2, 3) * A(3, 2)) & - & - A(1, 2) * (A(2, 1) * A(3, 3) - A(2, 3) * A(3, 1)) & - & + A(1, 3) * (A(2, 1) * A(3, 2) - A(3, 1) * A(2, 2)) -CASE (4) - Ans = A(1, 1) * (A(2, 2) * (A(3, 3) * A(4, 4) - A(3, 4) * A(4, 3))& - & + A(2, 3) * (A(3, 4) * A(4, 2) - A(3, 2) * A(4, 4)) & - & + A(2, 4) * (A(3, 2) * A(4, 3) & - & - A(3, 3) * A(4, 2))) - A(1, 2) * (A(2, 1) * (A(3, 3) * A(4, 4) & -& - A(3, 4) * A(4, 3)) + A(2, 3) * (A(3, 4) * A(4, 1) - A(3, 1) * A(4, 4)) & - & + A(2, 4) * (A(3, 1) * A(4, 3) - A(3, 3) * A(4, 1))) & - & + A(1, 3) * (A(2, 1) * (A(3, 2) * A(4, 4) - A(3, 4) * A(4, 2)) & - & + A(2, 2) * (A(3, 4) * A(4, 1) & -& - A(3, 1) * A(4, 4)) + A(2, 4) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1))) & - & - A(1, 4) * (A(2, 1) * (A(3, 2) * A(4, 3) - A(3, 3) * A(4, 2)) & - & + A(2, 2) * (A(3, 3) * A(4, 1) - A(3, 1) * A(4, 3)) & - & + A(2, 3) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1))) -CASE (5) - Ans = det_2d_5(a) -END SELECT -END PROCEDURE det_2D - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION det_2d_5(a) RESULT(ans) - REAL(DFP), INTENT(IN) :: a(5, 5) - REAL(DFP) :: ans - !! - REAL(DFP) :: b(4, 4) - INTEGER(I4B) :: i - INTEGER(I4B) :: inc - INTEGER(I4B) :: j - INTEGER(I4B) :: k - ! - ! Expand the determinant into the sum of the determinants of the - ! five 4 by 4 matrices created by dropping row 1, and column k. - ! - ans = 0.0D+00 - ! - DO k = 1, 5 - DO i = 1, 4 - DO j = 1, 4 - IF (j < k) THEN - inc = 0 - ELSE - inc = 1 - END IF - b(i, j) = a(i + 1, j + inc) - END DO - END DO - !! - ans = ans + (-1)**(k + 1) * a(1, k) * det_2D(b) - !! - END DO -END FUNCTION det_2d_5 - -!---------------------------------------------------------------------------- -! DET -!---------------------------------------------------------------------------- - -MODULE PROCEDURE det_3D -INTEGER(I4B) :: i, n -n = SIZE(A, 3) -ALLOCATE (Ans(n)) -DO i = 1, n - Ans(i) = Det(A(:, :, i)) -END DO -END PROCEDURE det_3D - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Inv_2D -!Define internal variables -REAL(DFP) :: d, co(4, 4) - -SELECT CASE (SIZE(A, 1)) -CASE (1) - d = det(A) - IF (ABS(d) .LT. ZERO) THEN - invA = 0.0_DFP - ELSE - invA = 1.0 / d - END IF - -CASE (2) - d = det(A) - IF (ABS(d) .LT. ZERO) THEN - invA = 0.0_DFP - ELSE - invA(1, 1) = A(2, 2) / d - invA(1, 2) = -A(1, 2) / d - invA(2, 1) = -A(2, 1) / d - invA(2, 2) = A(1, 1) / d - END IF -CASE (3) - d = det(A) - IF (ABS(d) .LT. ZERO) THEN - invA = 0.0_DFP - ELSE - co(1, 1) = (A(2, 2) * A(3, 3) - A(2, 3) * A(3, 2)) - co(1, 2) = -(A(2, 1) * A(3, 3) - A(2, 3) * A(3, 1)) - co(1, 3) = +(A(2, 1) * A(3, 2) - A(2, 2) * A(3, 1)) - co(2, 1) = -(A(1, 2) * A(3, 3) - A(1, 3) * A(3, 2)) - co(2, 2) = +(A(1, 1) * A(3, 3) - A(1, 3) * A(3, 1)) - co(2, 3) = -(A(1, 1) * A(3, 2) - A(1, 2) * A(3, 1)) - co(3, 1) = +(A(1, 2) * A(2, 3) - A(1, 3) * A(2, 2)) - co(3, 2) = -(A(1, 1) * A(2, 3) - A(1, 3) * A(2, 1)) - co(3, 3) = +(A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1)) - invA = TRANSPOSE(co(1:3, 1:3)) / d - END IF - -CASE (4) - - d = det(A) - IF (ABS(d) .LT. ZERO) THEN - invA = 0.0_DFP - ELSE - co(1, 1) = A(2, 2) * (A(3, 3) * A(4, 4) - A(3, 4) * A(4, 3)) + & - A(2, 3) * (A(3, 4) * A(4, 2) - A(3, 2) * A(4, 4)) + & - A(2, 4) * (A(3, 2) * A(4, 3) - A(3, 3) * A(4, 2)) - co(1, 2) = A(2, 1) * (A(3, 4) * A(4, 3) - A(3, 3) * A(4, 4)) + & - A(2, 3) * (A(3, 1) * A(4, 4) - A(3, 4) * A(4, 1)) + & - A(2, 4) * (A(3, 3) * A(4, 1) - A(3, 1) * A(4, 3)) - co(1, 3) = A(2, 1) * (A(3, 2) * A(4, 4) - A(3, 4) * A(4, 2)) + & - A(2, 2) * (A(3, 4) * A(4, 1) - A(3, 1) * A(4, 4)) + & - A(2, 4) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1)) - co(1, 4) = A(2, 1) * (A(3, 3) * A(4, 2) - A(3, 2) * A(4, 3)) + & - A(2, 2) * (A(3, 1) * A(4, 3) - A(3, 3) * A(4, 1)) + & - A(2, 3) * (A(3, 2) * A(4, 1) - A(3, 1) * A(4, 2)) - co(2, 1) = A(1, 2) * (A(3, 4) * A(4, 3) - A(3, 3) * A(4, 4)) + & - A(1, 3) * (A(3, 2) * A(4, 4) - A(3, 4) * A(4, 2)) + & - A(1, 4) * (A(3, 3) * A(4, 2) - A(3, 2) * A(4, 3)) - co(2, 2) = A(1, 1) * (A(3, 3) * A(4, 4) - A(3, 4) * A(4, 3)) + & - A(1, 3) * (A(3, 4) * A(4, 1) - A(3, 1) * A(4, 4)) + & - A(1, 4) * (A(3, 1) * A(4, 3) - A(3, 3) * A(4, 1)) - co(2, 3) = A(1, 1) * (A(3, 4) * A(4, 2) - A(3, 2) * A(4, 4)) + & - A(1, 2) * (A(3, 1) * A(4, 4) - A(3, 4) * A(4, 1)) + & - A(1, 4) * (A(3, 2) * A(4, 1) - A(3, 1) * A(4, 2)) - co(2, 4) = A(1, 1) * (A(3, 2) * A(4, 3) - A(3, 3) * A(4, 2)) + & - A(1, 2) * (A(3, 3) * A(4, 1) - A(3, 1) * A(4, 3)) + & - A(1, 3) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1)) - co(3, 1) = A(1, 2) * (A(2, 3) * A(4, 4) - A(2, 4) * A(4, 3)) + & - A(1, 3) * (A(2, 4) * A(4, 2) - A(2, 2) * A(4, 4)) + & - A(1, 4) * (A(2, 2) * A(4, 3) - A(2, 3) * A(4, 2)) - co(3, 2) = A(1, 1) * (A(2, 4) * A(4, 3) - A(2, 3) * A(4, 4)) + & - A(1, 3) * (A(2, 1) * A(4, 4) - A(2, 4) * A(4, 1)) + & - A(1, 4) * (A(2, 3) * A(4, 1) - A(2, 1) * A(4, 3)) - co(3, 3) = A(1, 1) * (A(2, 2) * A(4, 4) - A(2, 4) * A(4, 2)) + & - A(1, 2) * (A(2, 4) * A(4, 1) - A(2, 1) * A(4, 4)) + & - A(1, 4) * (A(2, 1) * A(4, 2) - A(2, 2) * A(4, 1)) - co(3, 4) = A(1, 1) * (A(2, 3) * A(4, 2) - A(2, 2) * A(4, 3)) + & - A(1, 2) * (A(2, 1) * A(4, 3) - A(2, 3) * A(4, 1)) + & - A(1, 3) * (A(2, 2) * A(4, 1) - A(2, 1) * A(4, 2)) - co(4, 1) = A(1, 2) * (A(2, 4) * A(3, 3) - A(2, 3) * A(3, 4)) + & - A(1, 3) * (A(2, 2) * A(3, 4) - A(2, 4) * A(3, 2)) + & - A(1, 4) * (A(2, 3) * A(3, 2) - A(2, 2) * A(3, 3)) - co(4, 2) = A(1, 1) * (A(2, 3) * A(3, 4) - A(2, 4) * A(3, 3)) + & - A(1, 3) * (A(2, 4) * A(3, 1) - A(2, 1) * A(3, 4)) + & - A(1, 4) * (A(2, 1) * A(3, 3) - A(2, 3) * A(3, 1)) - co(4, 3) = A(1, 1) * (A(2, 4) * A(3, 2) - A(2, 2) * A(3, 4)) + & - A(1, 2) * (A(2, 1) * A(3, 4) - A(2, 4) * A(3, 1)) + & - A(1, 4) * (A(2, 2) * A(3, 1) - A(2, 1) * A(3, 2)) - co(4, 4) = A(1, 1) * (A(2, 2) * A(3, 3) - A(2, 3) * A(3, 2)) + & - A(1, 2) * (A(2, 3) * A(3, 1) - A(2, 1) * A(3, 3)) + & - A(1, 3) * (A(2, 1) * A(3, 2) - A(2, 2) * A(3, 1)) - invA = TRANSPOSE(co) / d - END IF - -END SELECT - -END PROCEDURE Inv_2D - -!---------------------------------------------------------------------------- -! Inv -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Inv_3D -! define internal variables -INTEGER(I4B) :: i, n -n = SIZE(A, 3) -DO i = 1, n - CALL Inv(invA=invA(:, :, i), A=A(:, :, i)) -END DO -END PROCEDURE Inv_3D - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 b/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 deleted file mode 100644 index 8d9d1e4ee..000000000 --- a/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 +++ /dev/null @@ -1,65 +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(LinearAlgebraUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! IntHilbertMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InvHilbertMatrix -REAL(DFP) :: p -REAL(DFP) :: r -INTEGER(I4B) :: i -INTEGER(I4B) :: j -INTEGER(I4B) :: ip1 - -p = REAL(n, kind=DFP) - -DO i = 1, n -IF (i .NE. 1) p = (REAL(n - i + 1, DFP) * p * REAL(n + i - 1, DFP)) / REAL(i - 1, DFP)**2 - r = p * p - ans(i, i) = r / REAL(2 * i - 1, DFP) - IF (i .EQ. n) CYCLE - ip1 = i + 1 - DO j = ip1, n - r = (-1) * (REAL(n - j + 1, DFP) * r * (n + j - 1)) / REAL(j - 1, DFP)**2 - ans(i, j) = r / REAL(i + j - 1, DFP) - ans(j, i) = ans(i, j) - END DO -END DO -END PROCEDURE InvHilbertMatrix - -!---------------------------------------------------------------------------- -! HilbertMatrix -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HilbertMatrix -INTEGER(I4B) :: ii, jj -REAL(DFP) :: avar - -DO jj = 1, n - DO ii = 1, n - avar = REAL(ii + jj - 1, KIND=DFP) - ans(ii, jj) = 1.0_DFP / avar - END DO -END DO -END PROCEDURE HilbertMatrix - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 deleted file mode 100644 index c5dbf2273..000000000 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ /dev/null @@ -1,826 +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(MappingUtility) Methods -USE BaseMethod, ONLY: UpperCase, & - & SOFTLE, & - & RefCoord_Tetrahedron, & - & RefCoord_Hexahedron, & - & TriangleArea2D, & - & TriangleArea3D, & - & QuadrangleArea2D, & - & QuadrangleArea3D, & - & TetrahedronVolume3D, & - & HexahedronVolume3D -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! FromBiunitLine2Segment -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiunitLine2Segment1 -ans = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin -END PROCEDURE FromBiunitLine2Segment1 - -!---------------------------------------------------------------------------- -! FromBiunitLine2Segment -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiunitLine2Segment2 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(xin) - ans(:, ii) = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin(ii) -END DO -END PROCEDURE FromBiunitLine2Segment2 - -!---------------------------------------------------------------------------- -! FromBiUnitLine2UnitLine -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitLine2UnitLine -ans = 0.5_DFP * (1.0_DFP + xin) -END PROCEDURE FromBiUnitLine2UnitLine - -!---------------------------------------------------------------------------- -! FromUnitLine2BiUnitLine -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitLine2BiUnitLine -ans = 2.0_DFP * xin - 1.0_DFP -END PROCEDURE FromUnitLine2BiUnitLine - -!---------------------------------------------------------------------------- -! FromLine2Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromLine2Line_ -CHARACTER(2) :: acase -INTEGER(I4B) :: ii, n - -acase = from(1:1)//to(1:1) -n = SIZE(xin) - -SELECT CASE (acase) - -CASE ("BU", "bu", "bU", "Bu") - - DO CONCURRENT(ii=1:n) - ans(ii) = 0.5_DFP * (1.0_DFP + xin(ii)) - END DO - -CASE ("BB", "UU", "bb", "uu") - - DO CONCURRENT(ii=1:n) - ans(ii) = xin(ii) - END DO - -CASE ("UB", "ub", "uB", "Ub") - - DO CONCURRENT(ii=1:n) - ans(ii) = 2.0_DFP * xin(ii) - 1.0_DFP - END DO - -END SELECT -END PROCEDURE FromLine2Line_ - -!---------------------------------------------------------------------------- -! FromUnitTriangle2Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitTriangle2Triangle1 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(ans, 2) - ans(:, ii) = x1 + (x2 - x1) * xin(1, ii) + (x3 - x1) * xin(2, ii) -END DO -END PROCEDURE FromUnitTriangle2Triangle1 - -!---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2UnitQuadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1 -ans = FromBiUnitQuadrangle2Quadrangle(& - & xin=xin, & - & x1=[0.0_DFP, 0.0_DFP], & - & x2=[1.0_DFP, 0.0_DFP], & - & x3=[1.0_DFP, 1.0_DFP], & - & x4=[0.0_DFP, 1.0_DFP]) -END PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1 - -!---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2UnitQuadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitQuadrangle2BiUnitQuadrangle1 -INTEGER(I4B) :: ii -REAL(DFP) :: xi, eta, p1, p2, p3, p4 - -DO ii = 1, SIZE(ans, 2) - xi = xin(1, ii) - eta = xin(2, ii) - p1 = (1.0 - xi) * (1.0 - eta) - p2 = xi * (1.0 - eta) - p3 = xi * eta - p4 = (1.0 - xi) * eta - ans(1:2, ii) = & - & [-1.0_DFP, -1.0_DFP] * p1 & - & + [1.0_DFP, -1.0_DFP] * p2 & - & + [1.0_DFP, 1.0_DFP] * p3 & - & + [-1.0_DFP, 1.0_DFP] * p4 -END DO -END PROCEDURE FromUnitQuadrangle2BiUnitQuadrangle1 - -!---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitQuadrangle2Quadrangle1 -INTEGER(I4B) :: ii -REAL(DFP) :: xi, eta, p1, p2, p3, p4 -!! -DO ii = 1, SIZE(ans, 2) - xi = xin(1, ii) - eta = xin(2, ii) - p1 = 0.25 * (1.0 - xi) * (1.0 - eta) - p2 = 0.25 * (1.0 + xi) * (1.0 - eta) - p3 = 0.25 * (1.0 + xi) * (1.0 + eta) - p4 = 0.25 * (1.0 - xi) * (1.0 + eta) - ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 -END DO -END PROCEDURE FromBiUnitQuadrangle2Quadrangle1 - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitHexahedron2Hexahedron1 -INTEGER(I4B) :: ii -REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta -REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP - -DO ii = 1, SIZE(ans, 2) - xi = xin(1, ii) - eta = xin(2, ii) - zeta = xin(3, ii) - p1 = p125 * (one - xi) * (one - eta) * (one - zeta) - p2 = p125 * (one + xi) * (one - eta) * (one - zeta) - p3 = p125 * (one + xi) * (one + eta) * (one - zeta) - p4 = p125 * (one - xi) * (one + eta) * (one - zeta) - p5 = p125 * (one - xi) * (one - eta) * (one + zeta) - p6 = p125 * (one + xi) * (one - eta) * (one + zeta) - p7 = p125 * (one + xi) * (one + eta) * (one + zeta) - p8 = p125 * (one - xi) * (one + eta) * (one + zeta) - ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 + & - & x5 * p5 + x6 * p6 + x7 * p7 + x8 * p8 -END DO -END PROCEDURE FromBiUnitHexahedron2Hexahedron1 - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2UnitHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitHexahedron2UnitHexahedron1 -REAL(DFP) :: xij(3, 8) -xij = RefCoord_Hexahedron(refHexahedron="UNIT") -ans = FromBiUnitHexahedron2Hexahedron(& - & xin=xin, & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8)) -END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1 - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2Hexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitHexahedron2BiUnitHexahedron1 -INTEGER(I4B) :: ii -REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta -REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP -REAL(DFP) :: x(3, 8) - -x = RefCoord_Hexahedron(refHexahedron="BIUNIT") - -DO ii = 1, SIZE(ans, 2) - xi = xin(1, ii) - eta = xin(2, ii) - zeta = xin(3, ii) - p1 = (one - xi) * (one - eta) * (one - zeta) - p2 = (xi) * (one - eta) * (one - zeta) - p3 = (xi) * (eta) * (one - zeta) - p4 = (one - xi) * (eta) * (one - zeta) - p5 = (one - xi) * (one - eta) * (zeta) - p6 = (xi) * (one - eta) * (zeta) - p7 = (xi) * (eta) * (zeta) - p8 = (one - xi) * (eta) * (zeta) - ans(:, ii) = x(:, 1) * p1 + x(:, 2) * p2 + x(:, 3) * p3 + x(:, 4) * p4 + & - & x(:, 5) * p5 + x(:, 6) * p6 + x(:, 7) * p7 + x(:, 8) * p8 -END DO -END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1 - -!---------------------------------------------------------------------------- -! FromTriangle2Square_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromTriangle2Square_ -CHARACTER(2) :: acase -acase = from(1:1)//to(1:1) - -SELECT CASE (acase) - -CASE ("BB", "bb") - - ans(1, :) = (1.0_DFP + zero + 2.0_DFP * xin(1, :) + xin(2, :)) & - / (1.0_DFP + zero - xin(2, :)) - ans(2, :) = xin(2, :) - -CASE ("UB", "ub") - - ans(1, :) = (2.0_DFP * xin(1, :) + xin(2, :) - 1.0_DFP + zero) & - / (1.0_DFP + zero - xin(2, :)) - ans(2, :) = 2.0_DFP * xin(2, :) - 1.0_DFP - -END SELECT -END PROCEDURE FromTriangle2Square_ - -!---------------------------------------------------------------------------- -! FromBiUnitTriangle2BiUnitSqr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitTriangle2BiUnitSqr -CALL FromTriangle2Square_(xin=xin, ans=ans, from="B", to="B") -END PROCEDURE FromBiUnitTriangle2BiUnitSqr - -!---------------------------------------------------------------------------- -! FromUnitTriangle2BiUnitSqr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitTriangle2BiUnitSqr -CALL FromTriangle2Square_(xin=xin, ans=ans, from="U", to="B") -END PROCEDURE FromUnitTriangle2BiUnitSqr - -!---------------------------------------------------------------------------- -! FromSquare2Triangle_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromSquare2Triangle_ -CHARACTER(2) :: acase -acase = from(1:1)//to(1:1) - -SELECT CASE (acase) - -CASE ("BB", "bb", "Bb", "bB") - - ans(1, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) & - - 1.0_DFP - ans(2, :) = xin(2, :) - -CASE ("BU", "bu", "Bu", "bU") - - ans(1, :) = 0.25_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) - ans(2, :) = 0.5_DFP * (xin(2, :) + 1.0_DFP) - -END SELECT -END PROCEDURE FromSquare2Triangle_ - -!---------------------------------------------------------------------------- -! FromBiUnitSqr2BiUnitTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitSqr2BiUnitTriangle -CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="B") -END PROCEDURE FromBiUnitSqr2BiUnitTriangle - -!---------------------------------------------------------------------------- -! FromBiUnitSqr2UnitTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitSqr2UnitTriangle -CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="U") -END PROCEDURE FromBiUnitSqr2UnitTriangle - -!---------------------------------------------------------------------------- -! BarycentricCoordUnitTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCoordUnitTriangle -CALL BaryCentricCoordTriangle_(xin, "U", ans) -END PROCEDURE BarycentricCoordUnitTriangle - -!---------------------------------------------------------------------------- -! BarycentricCoordBiUnitTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCoordBiUnitTriangle -CALL BaryCentricCoordTriangle_(xin, "B", ans) -END PROCEDURE BarycentricCoordBiUnitTriangle - -!---------------------------------------------------------------------------- -! BarycentricCoordTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCoordTriangle -CALL BaryCentricCoordTriangle_(xin, refTriangle, ans) -END PROCEDURE BarycentricCoordTriangle - -!---------------------------------------------------------------------------- -! BarycentricCoordTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCoordTriangle_ -SELECT CASE (refTriangle(1:1)) -CASE ("B", "b") - ans(1, :) = -0.5_DFP * (xin(1, :) + xin(2, :)) - ans(2, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) - ans(3, :) = 0.5_DFP * (1.0_DFP + xin(2, :)) - -CASE ("U", "u") - ans(1, :) = 1.0_DFP - xin(1, :) - xin(2, :) - ans(2, :) = xin(1, :) - ans(3, :) = xin(2, :) -END SELECT -END PROCEDURE BarycentricCoordTriangle_ - -!---------------------------------------------------------------------------- -! FromTriangle2Triangle_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromTriangle2Triangle_ -CHARACTER(2) :: acase -INTEGER(I4B) :: ii, n - -acase = from(1:1)//to(1:1) - -SELECT CASE (acase) - -CASE ("BU", "bu", "bU", "Bu") - - ans = 0.5_DFP * (1.0_DFP + xin) - -CASE ("UB", "ub", "Ub", "uB") - - ans = -1.0_DFP + 2.0_DFP * xin - -CASE ("UT", "ut", "Ut", "uT") - - n = SIZE(xin, 2) - DO CONCURRENT(ii=1:n) - ans(:, ii) = x1 + (x2 - x1) * xin(1, ii) + (x3 - x1) * xin(2, ii) - END DO - -END SELECT -END PROCEDURE FromTriangle2Triangle_ - -!---------------------------------------------------------------------------- -! FromBiUnitTriangle2UnitTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitTriangle2UnitTriangle -CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="B", to="U") -END PROCEDURE FromBiUnitTriangle2UnitTriangle - -!---------------------------------------------------------------------------- -! FromBiUnitTriangle2UnitTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitTriangle2BiUnitTriangle -CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="U", to="B") -END PROCEDURE FromUnitTriangle2BiUnitTriangle - -!---------------------------------------------------------------------------- -! FromBiUnitTetrahedron2UnitTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron -ans = 0.5_DFP * (1.0_DFP + xin) -END PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron - -!---------------------------------------------------------------------------- -! FromUnitTetrahedron2BiUnitTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron -ans = -1.0_DFP + 2.0_DFP * xin -END PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron - -!---------------------------------------------------------------------------- -! FromBiUnitTetrahedron2Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitTetrahedron2Tetrahedron -INTEGER(I4B) :: ii -DO ii = 1, SIZE(xin, 2) - ans(:, ii) = & - -0.5_DFP * (1.0_DFP + xin(1, ii) + xin(2, ii) + xin(3, ii)) * x1(:) & - + 0.5_DFP * (1.0_DFP + xin(1, ii)) * x2(:) & - + 0.5_DFP * (1.0_DFP + xin(2, ii)) * x3(:) & - + 0.5_DFP * (1.0_DFP + xin(3, ii)) * x4(:) -END DO -END PROCEDURE FromBiUnitTetrahedron2Tetrahedron - -!---------------------------------------------------------------------------- -! FromUnitTetrahedron2Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitTetrahedron2Tetrahedron -INTEGER(I4B) :: ii -DO ii = 1, SIZE(xin, 2) - ans(:, ii) = & - (1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii)) * x1(:) & - + xin(1, ii) * x2(:) & - + xin(2, ii) * x3(:) & - + xin(3, ii) * x4(:) -END DO -END PROCEDURE FromUnitTetrahedron2Tetrahedron - -!---------------------------------------------------------------------------- -! BarycentricCoordUnitTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCoordUnitTetrahedron -ans(1, :) = 1.0_DFP - xin(1, :) - xin(2, :) - xin(3, :) -ans(2, :) = xin(1, :) -ans(3, :) = xin(2, :) -ans(4, :) = xin(3, :) -END PROCEDURE BarycentricCoordUnitTetrahedron - -!---------------------------------------------------------------------------- -! BarycentricCoordBiUnitTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCoordBiUnitTetrahedron -ans(1, :) = -0.5_DFP * (1.0_DFP + xin(1, :) + xin(2, :) + xin(3, :)) -ans(2, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) -ans(3, :) = 0.5_DFP * (1.0_DFP + xin(2, :)) -ans(4, :) = 0.5_DFP * (1.0_DFP + xin(3, :)) -END PROCEDURE BarycentricCoordBiUnitTetrahedron - -!---------------------------------------------------------------------------- -! BarycentricCoordTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricCoordTetrahedron -SELECT CASE (refTetrahedron(1:1)) -CASE ("B", "b") - ans = BarycentricCoordBiUnitTetrahedron(xin) -CASE ("U", "u") - ans = BarycentricCoordUnitTetrahedron(xin) -END SELECT -END PROCEDURE BarycentricCoordTetrahedron - -!---------------------------------------------------------------------------- -! FromBiUnitTetrahedron2BiUnitHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitTetrahedron2BiUnitHexahedron -INTEGER(I4B) :: ii -REAL(DFP) :: tol, alpha, beta - -tol = 1.0E-12 - -DO ii = 1, SIZE(xin, 2) - alpha = xin(2, ii) + xin(3, ii) - beta = 1.0_DFP - xin(3, ii) - - IF (SOFTLE(ABS(alpha), zero, tol)) THEN - ans(1, ii) = -1.0_DFP - ELSE - ans(1, ii) = -(2.0_DFP + 2.0_DFP * xin(1, ii) + alpha) / alpha - END IF - - IF (SOFTLE(ABS(beta), zero, tol)) THEN - ans(2, ii) = -1.0_DFP - ELSE - ans(2, ii) = (1.0_DFP + 2.0_DFP * xin(2, ii) + xin(3, ii)) / beta - END IF - - ans(3, ii) = xin(3, ii) -END DO - -END PROCEDURE FromBiUnitTetrahedron2BiUnitHexahedron - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2BiUnitTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron -ans(1, :) = 0.25_DFP & - & * (1.0_DFP + xin(1, :)) & - & * (1.0_DFP - xin(2, :)) & - & * (1.0_DFP - xin(3, :)) - 1.0_DFP - -ans(2, :) = 0.5_DFP & - & * (1.0_DFP + xin(2, :)) & - & * (1.0_DFP - xin(3, :)) - 1.0_DFP - -ans(3, :) = xin(3, :) -END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron - -!---------------------------------------------------------------------------- -! FromUnitTetrahedron2BiUnitHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromUnitTetrahedron2BiUnitHexahedron -ans = FromBiUnitTetrahedron2BiUnitHexahedron(& - & FromUnitTetrahedron2BiUnitTetrahedron(xin)) -END PROCEDURE FromUnitTetrahedron2BiUnitHexahedron - -!---------------------------------------------------------------------------- -! FromBiUnitHexahedron2UnitTetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FromBiUnitHexahedron2UnitTetrahedron -ans = FromBiUnitTetrahedron2UnitTetrahedron( & - & FromBiUnitHexahedron2BiUnitTetrahedron(xin)) -END PROCEDURE FromBiUnitHexahedron2UnitTetrahedron - -!---------------------------------------------------------------------------- -! JacobianLine -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobianLine -SELECT CASE (TRIM(from)) -CASE ("BIUNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 1.0_DFP - CASE ("UNIT") - ans = 0.5_DFP - CASE ("LINE") - ans = NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP - END SELECT -CASE ("UNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 2.0_DFP - CASE ("UNIT") - ans = 1.0_DFP - CASE ("LINE") - ans = NORM2(xij(:, 2) - xij(:, 1)) - END SELECT -CASE ("LINE") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 2.0_DFP / NORM2(xij(:, 2) - xij(:, 1)) - CASE ("UNIT") - ans = 1.0_DFP / NORM2(xij(:, 2) - xij(:, 1)) - CASE ("LINE") - ans = 1.0_DFP - END SELECT -END SELECT -END PROCEDURE JacobianLine - -!---------------------------------------------------------------------------- -! JacobianTriangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobianTriangle -ans = 1.0_DFP -SELECT CASE (TRIM(from)) -CASE ("BIUNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 1.0_DFP - CASE ("UNIT") - ans = 0.25_DFP - CASE ("TRIANGLE") - IF (PRESENT(xij)) THEN - - IF (SIZE(xij, 1) .EQ. 2_I4B) THEN - CALL TriangleArea2D(xij(1:2, 1:3), ans) - ELSE - CALL TriangleArea3D(xij(1:3, 1:3), ans) - END IF - - ans = ans / 2.0_DFP - - END IF - END SELECT -CASE ("UNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 4.0_DFP - CASE ("UNIT") - ans = 1.0_DFP - - CASE ("TRIANGLE") - IF (PRESENT(xij)) THEN - IF (SIZE(xij, 1) .EQ. 2_I4B) THEN - CALL TriangleArea2D(xij(1:2, 1:3), ans) - ELSE - CALL TriangleArea3D(xij(1:3, 1:3), ans) - END IF - ans = ans / 0.5_DFP - END IF - END SELECT - -CASE ("TRIANGLE") - - IF (PRESENT(xij)) THEN - IF (SIZE(xij, 1) .EQ. 2_I4B) THEN - CALL TriangleArea2D(xij(1:2, 1:3), ans) - ELSE IF (SIZE(xij, 1) .EQ. 3_I4B) THEN - CALL TriangleArea3D(xij(1:3, 1:3), ans) - END IF - ELSE - RETURN - END IF - - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 2.0_DFP / ans - CASE ("UNIT") - ans = 0.5_DFP / ans - END SELECT - -END SELECT -END PROCEDURE JacobianTriangle - -!---------------------------------------------------------------------------- -! JacobianQuadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobianQuadrangle -ans = 1.0_DFP -SELECT CASE (TRIM(from)) -CASE ("BIUNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 1.0_DFP - CASE ("UNIT") - ans = 0.25_DFP - - CASE ("QUADRANGLE") - IF (PRESENT(xij)) THEN - IF (SIZE(xij, 1) .EQ. 2_I4B) THEN - CALL QuadrangleArea2D(xij(1:2, 1:4), ans) - ELSE - CALL QuadrangleArea3D(xij(1:3, 1:4), ans) - END IF - ans = ans / 4.0_DFP - END IF - END SELECT - -CASE ("UNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 4.0_DFP - CASE ("UNIT") - ans = 1.0_DFP - - CASE ("QUADRANGLE") - IF (PRESENT(xij)) THEN - IF (SIZE(xij, 1) .EQ. 2_I4B) THEN - CALL QuadrangleArea2D(xij(1:2, 1:4), ans) - ELSE - CALL QuadrangleArea3D(xij(1:3, 1:4), ans) - END IF - END IF - END SELECT - -CASE ("QUADRANGLE") - - IF (PRESENT(xij)) THEN - IF (SIZE(xij, 1) .EQ. 2_I4B) THEN - CALL QuadrangleArea2D(xij(1:2, 1:4), ans) - ELSE - CALL QuadrangleArea3D(xij(1:3, 1:4), ans) - END IF - ELSE - RETURN - END IF - - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 4.0_DFP / ans - CASE ("UNIT") - ans = 1.0_DFP / ans - END SELECT - -END SELECT -END PROCEDURE JacobianQuadrangle - -!---------------------------------------------------------------------------- -! JacobianHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobianHexahedron -REAL(DFP) :: ans0 -ans = 1.0_DFP -SELECT CASE (TRIM(from)) -CASE ("BIUNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 1.0_DFP - CASE ("UNIT") - ans = 0.125_DFP - CASE ("HEXAHEDRON") - IF (PRESENT(xij)) THEN - CALL HexahedronVolume3D(xij(1:3, 1:8), ans) - CALL HexahedronVolume3D(RefCoord_Hexahedron(from), ans0) - ans = ans / ans0 - END IF - END SELECT - -CASE ("UNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 8.0_DFP - CASE ("UNIT") - ans = 1.0_DFP - CASE ("HEXAHEDRON") - IF (PRESENT(xij)) THEN - CALL HexahedronVolume3D(xij(1:3, 1:8), ans) - CALL HexahedronVolume3D(RefCoord_Hexahedron(from), ans0) - ans = ans / ans0 - END IF - END SELECT - -CASE ("HEXAHEDRON") - IF (PRESENT(xij)) THEN - CALL HexahedronVolume3D(xij(1:3, 1:8), ans0) - ELSE - RETURN - END IF - - SELECT CASE (TRIM(to)) - CASE ("BIUNIT", "UNIT") - CALL HexahedronVolume3D(RefCoord_Hexahedron(to), ans) - ans = ans / ans0 - END SELECT - -END SELECT -END PROCEDURE JacobianHexahedron - -!---------------------------------------------------------------------------- -! JacobianHexahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobianTetrahedron -REAL(DFP) :: ans0 -ans = 1.0_DFP -SELECT CASE (TRIM(from)) -CASE ("BIUNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 1.0_DFP - CASE ("UNIT") - ans = 0.125_DFP - CASE ("TETRAHEDRON") - IF (PRESENT(xij)) THEN - CALL TetrahedronVolume3D(xij(1:3, 1:4), ans) - CALL TetrahedronVolume3D(RefCoord_Tetrahedron(from), ans0) - ans = ans / ans0 - END IF - END SELECT - -CASE ("UNIT") - SELECT CASE (TRIM(to)) - CASE ("BIUNIT") - ans = 8.0_DFP - CASE ("UNIT") - ans = 1.0_DFP - CASE ("TETRAHEDRON") - IF (PRESENT(xij)) THEN - CALL TetrahedronVolume3D(xij(1:3, 1:4), ans) - CALL TetrahedronVolume3D(RefCoord_Tetrahedron(from), ans0) - ans = ans / ans0 - END IF - END SELECT - -CASE ("TETRAHEDRON") - IF (PRESENT(xij)) THEN - CALL TetrahedronVolume3D(xij(1:3, 1:4), ans0) - ELSE - RETURN - END IF - - SELECT CASE (TRIM(to)) - CASE ("BIUNIT", "UNIT") - CALL TetrahedronVolume3D(RefCoord_Tetrahedron(to), ans) - ans = ans / ans0 - END SELECT - -END SELECT -END PROCEDURE JacobianTetrahedron - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/MatmulUtility@Methods.F90 b/src/submodules/Utility/src/MatmulUtility@Methods.F90 deleted file mode 100644 index 1cc31c999..000000000 --- a/src/submodules/Utility/src/MatmulUtility@Methods.F90 +++ /dev/null @@ -1,173 +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: 3 April 2021 -! summary: Methods for matrix multiplication - -SUBMODULE(MatmulUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -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 -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)) -END DO -END PROCEDURE matmul_r4_r2 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r4_r3 -INTEGER(I4B) :: ii -!! -DO ii = 1, SIZE(a2, 3) - ans(:,:,:,:,ii) = matmul(a1, a2(:,:,ii)) -END DO -END PROCEDURE matmul_r4_r3 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r4_r4 -INTEGER(I4B) :: ii -!! -DO ii = 1, SIZE(a2, 4) - ans(:,:,:,:,:,ii) = matmul(a1, a2(:,:,:,ii)) -END DO -END PROCEDURE matmul_r4_r4 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r3_r1 -INTEGER(I4B) :: ii -ans = a2(1) * a1(:, :, 1) -DO ii = 2, SIZE(a2) - ans = ans + a2(ii) * a1(:, :, ii) -END DO -END PROCEDURE matmul_r3_r1 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r3_r2 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 2) - ans(:, :, ii) = MATMUL(a1, a2(:, ii)) -END DO -END PROCEDURE matmul_r3_r2 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r3_r3 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 3) - ans(:,:,:,ii) = matmul(a1, a2(:, :, ii)) -END DO -END PROCEDURE matmul_r3_r3 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r3_r4 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 4) - ans(:,:,:,:,ii) = matmul(a1, a2(:, :, :,ii)) -END DO -END PROCEDURE matmul_r3_r4 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r2_r3 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 3) - ans(:, :, ii) = MATMUL(a1, a2(:, :, ii)) -END DO -END PROCEDURE matmul_r2_r3 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r2_r4 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 4) - ans(:, :, :, ii) = MATMUL(a1, a2(:, :, :, ii)) -END DO -END PROCEDURE matmul_r2_r4 - -!---------------------------------------------------------------------------- -! 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 -END PROCEDURE matmul_r1_r3 - -!---------------------------------------------------------------------------- -! MATMUL -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matmul_r1_r4 -INTEGER(I4B) :: ii -ans = a1(1) * a2(1, :, :, :) -DO ii = 2, SIZE(a1) - ans = ans + a1(ii) * a2(ii, :, :, :) -END DO -END PROCEDURE matmul_r1_r4 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Median/ArgMedian.inc b/src/submodules/Utility/src/Median/ArgMedian.inc deleted file mode 100644 index ddc929849..000000000 --- a/src/submodules/Utility/src/Median/ArgMedian.inc +++ /dev/null @@ -1,20 +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 -! - -IF (this(indx(right)) < this(indx(left))) CALL swap(indx(left), indx(right)) -IF (this(indx(mid)) < this(indx(left))) CALL swap(indx(mid), indx(left)) -IF (this(indx(right)) < this(indx(mid))) CALL swap(indx(right), indx(mid)) diff --git a/src/submodules/Utility/src/Median/Median.inc b/src/submodules/Utility/src/Median/Median.inc deleted file mode 100644 index 0ff1cd794..000000000 --- a/src/submodules/Utility/src/Median/Median.inc +++ /dev/null @@ -1,20 +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 -! - -if (this(right) < this(left)) call swap(this(left), this(right)) -if (this(mid) < this(left)) call swap(this(mid), this(left)) -if (this(right) < this(mid)) call swap(this(right), this(mid)) diff --git a/src/submodules/Utility/src/MedianUtility@Methods.F90 b/src/submodules/Utility/src/MedianUtility@Methods.F90 deleted file mode 100644 index f4d4a922e..000000000 --- a/src/submodules/Utility/src/MedianUtility@Methods.F90 +++ /dev/null @@ -1,119 +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(MedianUtility) Methods -USE BaseMethod, ONLY: SWAP -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Median -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Median_Real32 -#include "./Median/Median.inc" -END PROCEDURE Median_Real32 - -!---------------------------------------------------------------------------- -! Median -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Median_Real64 -#include "./Median/Median.inc" -END PROCEDURE Median_Real64 - -!---------------------------------------------------------------------------- -! Median -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Median_Int8 -#include "./Median/Median.inc" -END PROCEDURE Median_Int8 - -!---------------------------------------------------------------------------- -! Median -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Median_Int16 -#include "./Median/Median.inc" -END PROCEDURE Median_Int16 - -!---------------------------------------------------------------------------- -! Median -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Median_Int32 -#include "./Median/Median.inc" -END PROCEDURE Median_Int32 - -!---------------------------------------------------------------------------- -! Median -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Median_Int64 -#include "./Median/Median.inc" -END PROCEDURE Median_Int64 - -!---------------------------------------------------------------------------- -! ArgMedian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgMedian_Real32 -#include "./Median/ArgMedian.inc" -END PROCEDURE ArgMedian_Real32 - -!---------------------------------------------------------------------------- -! ArgMedian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgMedian_Real64 -#include "./Median/ArgMedian.inc" -END PROCEDURE ArgMedian_Real64 - -!---------------------------------------------------------------------------- -! ArgMedian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgMedian_Int8 -#include "./Median/ArgMedian.inc" -END PROCEDURE ArgMedian_Int8 - -!---------------------------------------------------------------------------- -! ArgMedian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgMedian_Int16 -#include "./Median/ArgMedian.inc" -END PROCEDURE ArgMedian_Int16 - -!---------------------------------------------------------------------------- -! ArgMedian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgMedian_Int32 -#include "./Median/ArgMedian.inc" -END PROCEDURE ArgMedian_Int32 - -!---------------------------------------------------------------------------- -! ArgMedian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgMedian_Int64 -#include "./Median/ArgMedian.inc" -END PROCEDURE ArgMedian_Int64 - -END SUBMODULE diff --git a/src/submodules/Utility/src/MiscUtility@Methods.F90 b/src/submodules/Utility/src/MiscUtility@Methods.F90 deleted file mode 100644 index 705af9600..000000000 --- a/src/submodules/Utility/src/MiscUtility@Methods.F90 +++ /dev/null @@ -1,366 +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(MiscUtility) Methods -USE BaseMethod -IMPLICIT NONE -INTEGER(I4B), PARAMETER :: NPAR_ARTH = 16, NPAR2_ARTH = 8 -INTEGER(I4B), PARAMETER :: NPAR_GEOP = 4, NPAR2_GEOP = 2 -INTEGER(I4B), PARAMETER :: NPAR_CUMSUM = 16 -INTEGER(I4B), PARAMETER :: NPAR_CUMPROD = 8 -INTEGER(I4B), PARAMETER :: NPAR_POLY = 8 -INTEGER(I4B), PARAMETER :: NPAR_POLYTERM = 8 -CONTAINS - -!---------------------------------------------------------------------------- -! Radian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE radian_dfp -Ans = deg / 180.0_DFP * 3.1415926535_DFP -END PROCEDURE - -!---------------------------------------------------------------------------- -! Radian -!---------------------------------------------------------------------------- - -MODULE PROCEDURE radian_int -Ans = REAL(deg, KIND=DFP) / 180.0_DFP * 3.1415926535_DFP -END PROCEDURE - -!---------------------------------------------------------------------------- -! Degrees -!---------------------------------------------------------------------------- - -MODULE PROCEDURE degrees_dfp -Ans = rad / 3.1415926535_DFP * 180.0_DFP -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Loc_Nearest_Point -! Define internal variables -REAL(DFP) :: xr(3) -INTEGER(I4B) :: i, n, m, norm, tr_norm - -n = SIZE(Array, 1) -m = SIZE(Array, 2) -IF (n .NE. SIZE(x)) THEN - CALL ErrorMSG(& - & Msg="SearchNearestCoord >> size(Array,1) should be =size(x)", & - & File=__FILE__, & - & Line=__LINE__, & - & Routine="Loc_Nearest_Point(Array, x)") - STOP -END IF -! -DO i = 1, m - xr(1:n) = Array(1:n, i) - tr_norm = NORM2(xr(1:n) - x(1:n)) - IF (i .EQ. 1) THEN - norm = tr_norm - id = i - ELSE - IF (norm .GT. tr_norm) THEN - norm = tr_norm - id = i - ELSE - CYCLE - END IF - END IF -END DO -END PROCEDURE - -!---------------------------------------------------------------------------- -! ExecuteCommand -!---------------------------------------------------------------------------- - -MODULE PROCEDURE exe_cmd -! Define internal variables -INTEGER(I4B) :: CMDSTAT, EXITSTAT -LOGICAL(LGT) :: WAIT = .TRUE. -CHARACTER(LEN=300) :: CMDMSG = "" - -CALL EXECUTE_COMMAND_LINE(TRIM(CMD), CMDSTAT=CMDSTAT, & - & EXITSTAT=EXITSTAT, WAIT=WAIT, CMDMSG=CMDMSG) - -IF (CMDSTAT .NE. 0) THEN - IF (CMDSTAT .EQ. -1) THEN - CALL ErrorMsg( & - & File=__FILE__, & - & Routine="exe_cmd()", & - & Line=__LINE__, & - & MSG="following command failed "//TRIM(CMDMSG)) - END IF - - CALL ErrorMsg( & - & File=__FILE__, & - & Routine="exe_cmd()", & - & Line=__LINE__, & - & MSG="following command failed "//TRIM(CMDMSG)) - STOP -END IF -END PROCEDURE - -!---------------------------------------------------------------------------- -! getUnitNo -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getUnitNo_1 -! Define internal variables -LOGICAL(LGT) :: isOpen, isExist -INTEGER(I4B) :: Imin, Imax, I - -Imin = 10 -Imax = 1000 - -DO I = Imin, Imax, 1 - INQUIRE (UNIT=I, OPENED=isOpen, EXIST=isExist) - IF (isExist .AND. .NOT. isOpen) EXIT -END DO -IF (isOpen .OR. .NOT. isExist) THEN - CALL ErrorMsg( & - & File=__FILE__, & - & Routine="getUnitNo_1()", & - & Line=__LINE__, & - & MSG=" cannot find a valid unit number; Program Stopped") - STOP -END IF -ans = I -END PROCEDURE getUnitNo_1 - -!---------------------------------------------------------------------------- -! Factorial -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Factorial -IF (N .EQ. 0) THEN - Ans = 1 -ELSE - Ans = N * Factorial(N - 1) -END IF -END PROCEDURE - -!---------------------------------------------------------------------------- -! Int2Str -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Int2Str -CHARACTER(LEN=15) :: Str -WRITE (Str, "(I15)") I -Int2Str = TRIM(ADJUSTL(Str)) -END PROCEDURE - -!---------------------------------------------------------------------------- -! Real2Str -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SP2Str -CHARACTER(LEN=20) :: Str -WRITE (Str, "(G17.7)") I -SP2Str = TRIM(ADJUSTL(Str)) -END PROCEDURE - -!---------------------------------------------------------------------------- -! Real2Str -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DP2Str -CHARACTER(LEN=20) :: Str -WRITE (Str, "(G17.7)") I -DP2Str = TRIM(ADJUSTL(Str)) -END PROCEDURE - -!---------------------------------------------------------------------------- -! ARTH -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arth_r -INTEGER(I4B) :: k, k2 -REAL(SP) :: temp -IF (n > 0) arth_r(1) = first -IF (n <= NPAR_ARTH) THEN - DO k = 2, n - arth_r(k) = arth_r(k - 1) + increment - END DO -ELSE - DO k = 2, NPAR2_ARTH - arth_r(k) = arth_r(k - 1) + increment - END DO - temp = increment * NPAR2_ARTH - k = NPAR2_ARTH - DO - IF (k >= n) exit - k2 = k + k - arth_r(k + 1:min(k2, n)) = temp + arth_r(1:min(k, n - k)) - temp = temp + temp - k = k2 - END DO -END IF -END PROCEDURE arth_r - -!---------------------------------------------------------------------------- -! ARTH -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arth_d -INTEGER(I4B) :: k, k2 -REAL(DP) :: temp -IF (n > 0) arth_d(1) = first -IF (n <= NPAR_ARTH) THEN - DO k = 2, n - arth_d(k) = arth_d(k - 1) + increment - END DO -ELSE - DO k = 2, NPAR2_ARTH - arth_d(k) = arth_d(k - 1) + increment - END DO - temp = increment * NPAR2_ARTH - k = NPAR2_ARTH - DO - IF (k >= n) exit - k2 = k + k - arth_d(k + 1:min(k2, n)) = temp + arth_d(1:min(k, n - k)) - temp = temp + temp - k = k2 - END DO -END IF -END PROCEDURE arth_d - -!---------------------------------------------------------------------------- -! ARTH -!---------------------------------------------------------------------------- - -MODULE PROCEDURE arth_i -INTEGER(I4B) :: k, k2, temp -IF (n > 0) arth_i(1) = first -IF (n <= NPAR_ARTH) THEN - DO k = 2, n - arth_i(k) = arth_i(k - 1) + increment - END DO -ELSE - DO k = 2, NPAR2_ARTH - arth_i(k) = arth_i(k - 1) + increment - END DO - temp = increment * NPAR2_ARTH - k = NPAR2_ARTH - DO - IF (k >= n) exit - k2 = k + k - arth_i(k + 1:min(k2, n)) = temp + arth_i(1:min(k, n - k)) - temp = temp + temp - k = k2 - END DO -END IF -END PROCEDURE arth_i - -!---------------------------------------------------------------------------- -! OuterDiff -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerdIFf_r -outerdIFf_r = SPREAD(a, dim=2, ncopies=size(b)) - & - SPREAD(b, dim=1, ncopies=size(a)) -END PROCEDURE outerdIFf_r - -MODULE PROCEDURE outerdIFf_d -outerdIFf_d = SPREAD(a, dim=2, ncopies=size(b)) - & - SPREAD(b, dim=1, ncopies=size(a)) -END PROCEDURE outerdIFf_d - -MODULE PROCEDURE outerdIFf_i -outerdIFf_i = SPREAD(a, dim=2, ncopies=size(b)) - & - SPREAD(b, dim=1, ncopies=size(a)) -END PROCEDURE outerdIFf_i - -!---------------------------------------------------------------------------- -! IMAXLOC -!---------------------------------------------------------------------------- - -MODULE PROCEDURE imaxloc_r -INTEGER(I4B), DIMENSION(1) :: imax -imax = MAXLOC(arr(:)) -imaxloc_r = imax(1) -END PROCEDURE imaxloc_r - -!---------------------------------------------------------------------------- -! IMAXLOC -!---------------------------------------------------------------------------- - -MODULE PROCEDURE imaxloc_i -INTEGER(I4B), DIMENSION(1) :: imax -imax = MAXLOC(iarr(:)) -imaxloc_i = imax(1) -END PROCEDURE imaxloc_i - -!---------------------------------------------------------------------------- -! IMINLOC -!---------------------------------------------------------------------------- - -MODULE PROCEDURE iminloc_r -INTEGER(I4B), DIMENSION(1) :: imin -imin = MINLOC(arr(:)) -iminloc_r = imin(1) -END PROCEDURE iminloc_r - -!---------------------------------------------------------------------------- -! IMG -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IMG_1 -COMPLEX(Real32), PARAMETER :: i = (0.0_Real32, 1.0_Real32) -ans = REAL(x * i, KIND=Real32) -END PROCEDURE IMG_1 - -!---------------------------------------------------------------------------- -! IMG -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IMG_2 -COMPLEX(Real64), PARAMETER :: i = (0.0_Real64, 1.0_Real64) -ans = REAL(x * i, KIND=Real64) -END PROCEDURE IMG_2 - -!---------------------------------------------------------------------------- -! Safe_ACOS -!---------------------------------------------------------------------------- - -MODULE PROCEDURE safe_ACOS -REAL(DFP) :: c2 -!! -c2 = c -c2 = MAX(c2, -1.0_DFP) -c2 = MIN(c2, +1.0_DFP) -!! -ans = acos(c2) -END PROCEDURE safe_ACOS - -!---------------------------------------------------------------------------- -! Safe_ASIN -!---------------------------------------------------------------------------- - -MODULE PROCEDURE safe_ASIN -REAL(DFP) :: s2 -s2 = s -s2 = MAX(s2, -1.0D+00) -s2 = MIN(s2, +1.0D+00) -ans = asin(s2) -END PROCEDURE safe_ASIN - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/OnesUtility@Methods.F90 b/src/submodules/Utility/src/OnesUtility@Methods.F90 deleted file mode 100644 index 285e84680..000000000 --- a/src/submodules/Utility/src/OnesUtility@Methods.F90 +++ /dev/null @@ -1,253 +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(OnesUtility) Methods -implicit none -contains - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_1 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_2 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_3 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_4 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- -#ifdef USE_Int128 -module procedure ones_5 - ans = 1 -end procedure -#endif - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_6 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_7 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_8 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_9 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_10 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_11 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -module procedure ones_12 - ans = 1 -end procedure -#endif - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_13 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_14 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_15 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_16 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_17 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_18 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -module procedure ones_19 - ans = 1 -end procedure -#endif - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_20 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_21 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_22 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_23 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_24 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_25 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -module procedure ones_26 - ans = 1 -end procedure -#endif - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_27 - ans = 1 -end procedure - -!---------------------------------------------------------------------------- -! Ones -!---------------------------------------------------------------------------- - -module procedure ones_28 - ans = 1 -end procedure - -end submodule Methods diff --git a/src/submodules/Utility/src/Partition/ArgPartition.inc b/src/submodules/Utility/src/Partition/ArgPartition.inc deleted file mode 100644 index 09bde4203..000000000 --- a/src/submodules/Utility/src/Partition/ArgPartition.inc +++ /dev/null @@ -1,34 +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 -! - - -pivot = this(idx(left)) -lo = left + 1; hi = right -DO WHILE (lo <= hi) - DO WHILE (this(idx(hi)) > pivot) - hi = hi - 1 - END DO - DO WHILE (lo <= hi .AND. this(idx(lo)) <= pivot) - lo = lo + 1 - END DO - IF (lo <= hi) THEN - CALL swap(idx(lo), idx(hi)) - lo = lo + 1; hi = hi - 1 - END IF -END DO -CALL swap(idx(left), idx(hi)) -i = hi diff --git a/src/submodules/Utility/src/Partition/Partition.inc b/src/submodules/Utility/src/Partition/Partition.inc deleted file mode 100644 index 9a78557fb..000000000 --- a/src/submodules/Utility/src/Partition/Partition.inc +++ /dev/null @@ -1,35 +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 -! - - -pivot = this(left) -lo = left; hi = right -DO WHILE (lo <= hi) - DO WHILE (this(hi) > pivot) - hi = hi - 1 - END DO - - DO WHILE (lo <= hi .AND. this(lo) <= pivot) - lo = lo + 1 - END DO - IF (lo <= hi) THEN - CALL swap(this(lo), this(hi)) - lo = lo + 1; hi = hi - 1 - END IF -END DO -CALL swap(this(left), this(hi)) -iPivot = hi diff --git a/src/submodules/Utility/src/PartitionUtility@Methods.F90 b/src/submodules/Utility/src/PartitionUtility@Methods.F90 deleted file mode 100644 index c9597bbdd..000000000 --- a/src/submodules/Utility/src/PartitionUtility@Methods.F90 +++ /dev/null @@ -1,143 +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(PartitionUtility) Methods -USE BaseMethod, ONLY: SWAP -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE partition_Real32 -INTEGER(I4B) :: lo, hi -REAL(REAL32) :: pivot -#include "./Partition/Partition.inc" -END PROCEDURE partition_Real32 - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE partition_Real64 -INTEGER(I4B) :: lo, hi -REAL(REAL64) :: pivot -#include "./Partition/Partition.inc" -END PROCEDURE partition_Real64 - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE partition_Int8 -INTEGER(I4B) :: lo, hi -INTEGER(INT8) :: pivot -#include "./Partition/Partition.inc" -END PROCEDURE partition_Int8 - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE partition_Int16 -INTEGER(I4B) :: lo, hi -INTEGER(INT16) :: pivot -#include "./Partition/Partition.inc" -END PROCEDURE partition_Int16 - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE partition_Int32 -INTEGER(I4B) :: lo, hi -INTEGER(INT32) :: pivot -#include "./Partition/Partition.inc" -END PROCEDURE partition_Int32 - -!---------------------------------------------------------------------------- -! Partition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE partition_Int64 -INTEGER(I4B) :: lo, hi -INTEGER(INT64) :: pivot -#include "./Partition/Partition.inc" -END PROCEDURE partition_Int64 - -!---------------------------------------------------------------------------- -! ArgPartition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE argPartition_Int8 -INTEGER(I4B) :: lo, hi -INTEGER(INT8) :: pivot -#include "./Partition/ArgPartition.inc" -END PROCEDURE argPartition_Int8 - -!---------------------------------------------------------------------------- -! ArgPartition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE argPartition_Int16 -INTEGER(I4B) :: lo, hi -INTEGER(INT16) :: pivot -#include "./Partition/ArgPartition.inc" -END PROCEDURE argPartition_Int16 - -!---------------------------------------------------------------------------- -! ArgPartition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE argPartition_Int32 -INTEGER(I4B) :: lo, hi -INTEGER(INT32) :: pivot -#include "./Partition/ArgPartition.inc" -END PROCEDURE argPartition_Int32 - -!---------------------------------------------------------------------------- -! ArgPartition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE argPartition_Int64 -INTEGER(I4B) :: lo, hi -INTEGER(INT64) :: pivot -#include "./Partition/ArgPartition.inc" -END PROCEDURE argPartition_Int64 - -!---------------------------------------------------------------------------- -! ArgPartition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE argPartition_Real32 -INTEGER(I4B) :: lo, hi -REAL(REAL32) :: pivot -#include "./Partition/ArgPartition.inc" -END PROCEDURE argPartition_Real32 - -!---------------------------------------------------------------------------- -! ArgPartition -!---------------------------------------------------------------------------- - -MODULE PROCEDURE argPartition_Real64 -INTEGER(I4B) :: lo, hi -REAL(REAL64) :: pivot -#include "./Partition/ArgPartition.inc" -END PROCEDURE argPartition_Real64 - -END SUBMODULE diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 deleted file mode 100644 index e68c7588c..000000000 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ /dev/null @@ -1,500 +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: 22 March 2021 -! summary: This submodule contains outerprod - -SUBMODULE(ProductUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! VectorProd -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vectorProduct_1 -c(1) = a(2) * b(3) - a(3) * b(2) -c(2) = a(3) * b(1) - a(1) * b(3) -c(3) = a(1) * b(2) - a(2) * b(1) -END PROCEDURE vectorProduct_1 - -!---------------------------------------------------------------------------- -! VectorProd -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vectorProduct_2 -c(1) = a(2) * b(3) - a(3) * b(2) -c(2) = a(3) * b(1) - a(1) * b(3) -c(3) = a(1) * b(2) - a(2) * b(1) -END PROCEDURE vectorProduct_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1 -ans = 0.0_DFP -ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * & - & SPREAD(b, dim=1, ncopies=SIZE(a)) -END PROCEDURE outerprod_r1r1 - -!-------------------------------------------------------------------- -! -!-------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1s -ans = 0.0_DFP -IF (Sym) THEN - ans = SPREAD(0.5_DFP * a, dim=2, ncopies=SIZE(b)) & - & * SPREAD(b, dim=1, ncopies=SIZE(a)) & - & + SPREAD(0.5_DFP * b, dim=2, ncopies=SIZE(a)) & - & * SPREAD(a, dim=1, ncopies=SIZE(b)) -ELSE - ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * & - & SPREAD(b, dim=1, ncopies=SIZE(a)) -END IF -END PROCEDURE outerprod_r1r1s - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r2 -INTEGER(I4B) :: ii -do ii = 1, size(b, 2) - ans(:, :, ii) = outerprod(a, b(:, ii)) -end do -END PROCEDURE outerprod_r1r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r3 -INTEGER(I4B) :: ii -do ii = 1, size(b, 3) - ans(:, :, :, ii) = outerprod(a, b(:, :, ii)) -end do -END PROCEDURE outerprod_r1r3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r4 -INTEGER(I4B) :: ii -do ii = 1, size(b, 4) - ans(:, :, :, :, ii) = outerprod(a, b(:, :, :, ii)) -end do -END PROCEDURE outerprod_r1r4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r5 -INTEGER(I4B) :: ii -do ii = 1, size(b, 5) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, :, ii)) -end do -END PROCEDURE outerprod_r1r5 - -!-------------------------------------------------------------------- -! -!-------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r1 -INTEGER(I4B) :: ii -do ii = 1, size(b, 1) - ans(:, :, ii) = a * b(ii) -end do -END PROCEDURE outerprod_r2r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r2 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 2) - ans(:, :, :, ii) = outerprod(a, b(:, ii)) -END DO -END PROCEDURE outerprod_r2r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r3 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 3) - ans(:, :, :, :, ii) = outerprod(a, b(:, :, ii)) -END DO -END PROCEDURE outerprod_r2r3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r4 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 4) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, ii)) -END DO -END PROCEDURE outerprod_r2r4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r3r1 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 1) - ans(:, :, :, ii) = a(:, :, :) * b(ii) -END DO -END PROCEDURE outerprod_r3r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r3r2 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 2) - ans(:, :, :, :, ii) = outerprod(a, b(:, ii)) -END DO -END PROCEDURE outerprod_r3r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r3r3 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 3) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, ii)) -END DO -END PROCEDURE outerprod_r3r3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r4r1 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 1) - ans(:, :, :, :, ii) = a * b(ii) -END DO -END PROCEDURE outerprod_r4r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r4r2 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b, 2) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, ii)) -END DO -END PROCEDURE outerprod_r4r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r5r1 -INTEGER(I4B) :: ii -DO ii = 1, SIZE(b) - ans(:, :, :, :, :, ii) = a * b(ii) -END DO -END PROCEDURE outerprod_r5r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r3 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r4 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r2r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r2r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r2r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r2r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r2r3 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r2r3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r3r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r3r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r3r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r3r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r4r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r4r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r1r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r1r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r1r3 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r1r3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r2r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r2r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r2r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r2r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r3r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r3r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r3r1r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r3r1r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r3r2r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r3r2r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r4r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r4r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r1r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r1r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r1r3 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r1r3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r2r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r2r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r2r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r2r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r1r3r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r3r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r2r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r2r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r2r1r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r2r1r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r2r2r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r2r2r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r1r3r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r3r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r1r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r1r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r1r1r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r1r1r2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r1r2r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r1r2r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r2r2r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r2r1r1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE outerprod_r3r1r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r3r1r1r1 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/PushPop/Pop_Scalar.inc b/src/submodules/Utility/src/PushPop/Pop_Scalar.inc deleted file mode 100644 index 3e54cf768..000000000 --- a/src/submodules/Utility/src/PushPop/Pop_Scalar.inc +++ /dev/null @@ -1,40 +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 -! - -INTEGER(I4B) :: n, ii - !! -n = SIZE(vec) -!! -IF (n .EQ. 1) RETURN -!! -IF (pos .GT. n) THEN - ans = vec(1:n - 1) - RETURN -END IF -!! -IF (pos .LT. 1_I4B) THEN - ans = vec(2:n) - RETURN -END IF -!! -DO ii = 1, pos - 1 - ans(ii) = vec(ii) -END DO - -DO ii = pos, n - 1 - ans(ii) = vec(ii + 1) -END DO diff --git a/src/submodules/Utility/src/PushPop/Push_Scalar.inc b/src/submodules/Utility/src/PushPop/Push_Scalar.inc deleted file mode 100644 index 7cfd66cec..000000000 --- a/src/submodules/Utility/src/PushPop/Push_Scalar.inc +++ /dev/null @@ -1,41 +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 -! - -INTEGER(I4B) :: n, ii - !! -n = SIZE(vec) - !! -IF (pos .GT. n) THEN - ans(1:n) = vec - ans(n + 1) = value - RETURN -END IF - !! -IF (pos .LT. 1_I4B) THEN - ans(1) = value - ans(2:n + 1) = vec - RETURN -END IF - !! -ans(pos) = value -DO ii = 1, pos - 1 - ans(ii) = vec(ii) -END DO - -DO ii = pos, n - ans(ii + 1) = vec(ii) -END DO diff --git a/src/submodules/Utility/src/PushPopUtility@Methods.F90 b/src/submodules/Utility/src/PushPopUtility@Methods.F90 deleted file mode 100644 index 0f820b5ef..000000000 --- a/src/submodules/Utility/src/PushPopUtility@Methods.F90 +++ /dev/null @@ -1,118 +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(PushPopUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE push_int8 -#include "./PushPop/Push_Scalar.inc" -END PROCEDURE push_int8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE push_int16 -#include "./PushPop/Push_Scalar.inc" -END PROCEDURE push_int16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE push_int32 -#include "./PushPop/Push_Scalar.inc" -END PROCEDURE push_int32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE push_int64 -#include "./PushPop/Push_Scalar.inc" -END PROCEDURE push_int64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE push_real32 -#include "./PushPop/Push_Scalar.inc" -END PROCEDURE push_real32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE push_real64 -#include "./PushPop/Push_Scalar.inc" -END PROCEDURE push_real64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pop_int8 -#include "./PushPop/Pop_Scalar.inc" -END PROCEDURE pop_int8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pop_int16 -#include "./PushPop/Pop_Scalar.inc" -END PROCEDURE pop_int16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pop_int32 -#include "./PushPop/Pop_Scalar.inc" -END PROCEDURE pop_int32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pop_int64 -#include "./PushPop/Pop_Scalar.inc" -END PROCEDURE pop_int64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pop_real32 -#include "./PushPop/Pop_Scalar.inc" -END PROCEDURE pop_real32 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE pop_real64 -#include "./PushPop/Pop_Scalar.inc" -END PROCEDURE pop_real64 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc deleted file mode 100644 index 42e8eec30..000000000 --- a/src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc +++ /dev/null @@ -1,34 +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 -! - -INTEGER(I4B) i, iPivot - -iPivot = high -i = low -DO WHILE (iPivot > i) - IF (vect1(i) > vect1(iPivot)) THEN - CALL Swap(vect1(i), vect1(iPivot - 1)) - CALL Swap(vect1(iPivot - 1), vect1(iPivot)) - iPivot = iPivot - 1 - ELSE - i = i + 1 - END IF -END DO -IF (low < high) THEN - CALL QuickSort(vect1, low, iPivot - 1) - CALL QuickSort(vect1, iPivot + 1, high) -END IF diff --git a/src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc deleted file mode 100644 index 4bc273972..000000000 --- a/src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc +++ /dev/null @@ -1,36 +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 -! - -INTEGER(I4B) i, iPivot - -iPivot = high -i = low -DO WHILE (iPivot > i) - IF (vect1(i) > vect1(iPivot)) THEN - CALL Swap(vect1(i), vect1(iPivot - 1)) - CALL Swap(vect2(i), vect2(iPivot - 1)) - CALL Swap(vect1(iPivot - 1), vect1(iPivot)) - CALL Swap(vect2(iPivot - 1), vect2(iPivot)) - iPivot = iPivot - 1 - ELSE - i = i + 1 - END IF -END DO -IF (low < high) THEN - CALL QuickSort(vect1, vect2, low, iPivot - 1) - CALL QuickSort(vect1, vect2, iPivot + 1, high) -END IF diff --git a/src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc deleted file mode 100644 index 36df532c1..000000000 --- a/src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc +++ /dev/null @@ -1,38 +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 -! - -INTEGER(I4B) i, iPivot - -iPivot = high -i = low -DO WHILE (iPivot > i) - IF (vect1(i) > vect1(iPivot)) THEN - CALL Swap(vect1(i), vect1(iPivot - 1)) - CALL Swap(vect2(i), vect2(iPivot - 1)) - CALL Swap(vect3(i), vect3(iPivot - 1)) - CALL Swap(vect1(iPivot - 1), vect1(iPivot)) - CALL Swap(vect2(iPivot - 1), vect2(iPivot)) - CALL Swap(vect3(iPivot - 1), vect3(iPivot)) - iPivot = iPivot - 1 - ELSE - i = i + 1 - END IF -END DO -IF (low < high) THEN - CALL QuickSort(vect1, vect2, vect3, low, iPivot - 1) - CALL QuickSort(vect1, vect2, vect3, iPivot + 1, high) -END IF diff --git a/src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc deleted file mode 100644 index 85b7eec3c..000000000 --- a/src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc +++ /dev/null @@ -1,40 +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 -! - -INTEGER(I4B) i, iPivot - -iPivot = high -i = low -DO WHILE (iPivot > i) - IF (vect1(i) > vect1(iPivot)) THEN - CALL Swap(vect1(i), vect1(iPivot - 1)) - CALL Swap(vect2(i), vect2(iPivot - 1)) - CALL Swap(vect3(i), vect3(iPivot - 1)) - CALL Swap(vect4(i), vect4(iPivot - 1)) - CALL Swap(vect1(iPivot - 1), vect1(iPivot)) - CALL Swap(vect2(iPivot - 1), vect2(iPivot)) - CALL Swap(vect3(iPivot - 1), vect3(iPivot)) - CALL Swap(vect4(iPivot - 1), vect4(iPivot)) - iPivot = iPivot - 1 - ELSE - i = i + 1 - END IF -END DO -IF (low < high) THEN - CALL QuickSort(vect1, vect2, vect3, vect4, low, iPivot - 1) - CALL QuickSort(vect1, vect2, vect3, vect4, iPivot + 1, high) -END IF diff --git a/src/submodules/Utility/src/ReallocateUtility@Methods.F90 b/src/submodules/Utility/src/ReallocateUtility@Methods.F90 deleted file mode 100644 index a468f09db..000000000 --- a/src/submodules/Utility/src/ReallocateUtility@Methods.F90 +++ /dev/null @@ -1,1186 +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: 22 March 2021 -! summary: Methods for reallocating arrays - -SUBMODULE(ReallocateUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Reallocate2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_logical -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = .FALSE. -END PROCEDURE Reallocate_logical - -!---------------------------------------------------------------------------- -! Reallocate2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0.0_DFP -END PROCEDURE Reallocate_Real64_R1 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R1b -CALL Reallocate_Real64_R1(mat, s(1)) -END PROCEDURE Reallocate_Real64_R1b - -!---------------------------------------------------------------------------- -! Reallocate2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real32_R1 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R1b -CALL Reallocate_Real32_R1(mat, s(1)) -END PROCEDURE Reallocate_Real32_R1b - -!---------------------------------------------------------------------------- -! Reallocate1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0.0_DFP -END PROCEDURE Reallocate_Real64_R2 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R2b -CALL Reallocate_Real64_R2(mat, s(1), s(2)) -END PROCEDURE Reallocate_Real64_R2b - -!---------------------------------------------------------------------------- -! Reallocate1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real32_R2 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R2b -CALL Reallocate_Real32_R2(mat, s(1), s(2)) -END PROCEDURE Reallocate_Real32_R2b - -!--------------------------------------------------------------------------- -! Reallocate -!--------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0.0_DFP -END PROCEDURE Reallocate_Real64_R3 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R3b -CALL Reallocate_Real64_R3(mat, s(1), s(2), s(3)) -END PROCEDURE Reallocate_Real64_R3b - -!--------------------------------------------------------------------------- -! Reallocate -!--------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real32_R3 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R3b -CALL Reallocate_Real32_R3(mat, s(1), s(2), s(3)) -END PROCEDURE Reallocate_Real32_R3b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real64_R4 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R4b -CALL Reallocate_Real64_R4(mat, s(1), s(2), s(3), s(4)) -END PROCEDURE Reallocate_Real64_R4b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real32_R4 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R4b -CALL Reallocate_Real32_R4(mat, s(1), s(2), s(3), s(4)) -END PROCEDURE Reallocate_Real32_R4b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real64_R5 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R5b -CALL Reallocate_Real64_R5(mat, s(1), s(2), s(3), s(4), s(5)) -END PROCEDURE Reallocate_Real64_R5b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real32_R5 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R5b -CALL Reallocate_Real32_R5(mat, s(1), s(2), s(3), s(4), s(5)) -END PROCEDURE Reallocate_Real32_R5b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real64_R6 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R6b -CALL Reallocate_Real64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) -END PROCEDURE Reallocate_Real64_R6b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real32_R6 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R6b -CALL Reallocate_Real32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) -END PROCEDURE Reallocate_Real32_R6b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real64_R7 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R7b -CALL Reallocate_Real64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) -END PROCEDURE Reallocate_Real64_R7b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0.0 -END PROCEDURE Reallocate_Real32_R7 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R7b -CALL Reallocate_Real32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) -END PROCEDURE Reallocate_Real32_R7b - -!---------------------------------------------------------------------------- -! Reallocate2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int64_R1 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R1b -CALL Reallocate_Int64_R1(mat, s(1)) -END PROCEDURE Reallocate_Int64_R1b - -!---------------------------------------------------------------------------- -! Reallocate2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int32_R1 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R1b -CALL Reallocate_Int32_R1(mat, s(1)) -END PROCEDURE Reallocate_Int32_R1b - -!---------------------------------------------------------------------------- -! Reallocate2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int16_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int16_R1 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int16_R1b -CALL Reallocate_Int16_R1(mat, s(1)) -END PROCEDURE Reallocate_Int16_R1b - -!---------------------------------------------------------------------------- -! Reallocate2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int8_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int8_R1 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int8_R1b -CALL Reallocate_Int8_R1(mat, s(1)) -END PROCEDURE Reallocate_Int8_R1b - -!---------------------------------------------------------------------------- -! Reallocate1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0_DFP -END PROCEDURE Reallocate_Int64_R2 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R2b -CALL Reallocate_Int64_R2(mat, s(1), s(2)) -END PROCEDURE Reallocate_Int64_R2b - -!---------------------------------------------------------------------------- -! Reallocate1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int32_R2 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R2b -CALL Reallocate_Int32_R2(mat, s(1), s(2)) -END PROCEDURE Reallocate_Int32_R2b - -!---------------------------------------------------------------------------- -! Reallocate1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int16_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int16_R2 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int16_R2b -CALL Reallocate_Int16_R2(mat, s(1), s(2)) -END PROCEDURE Reallocate_Int16_R2b - -!---------------------------------------------------------------------------- -! Reallocate1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int8_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int8_R2 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int8_R2b -CALL Reallocate_Int8_R2(mat, s(1), s(2)) -END PROCEDURE Reallocate_Int8_R2b - -!--------------------------------------------------------------------------- -! Reallocate -!--------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0_DFP -END PROCEDURE Reallocate_Int64_R3 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R3b -CALL Reallocate_Int64_R3(mat, s(1), s(2), s(3)) -END PROCEDURE Reallocate_Int64_R3b - -!--------------------------------------------------------------------------- -! Reallocate -!--------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int32_R3 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R3b -CALL Reallocate_Int32_R3(mat, s(1), s(2), s(3)) -END PROCEDURE Reallocate_Int32_R3b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int64_R4 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R4b -CALL Reallocate_Int64_R4(mat, s(1), s(2), s(3), s(4)) -END PROCEDURE Reallocate_Int64_R4b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int32_R4 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R4b -CALL Reallocate_Int32_R4(mat, s(1), s(2), s(3), s(4)) -END PROCEDURE Reallocate_Int32_R4b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int64_R5 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R5b -CALL Reallocate_Int64_R5(mat, s(1), s(2), s(3), s(4), s(5)) -END PROCEDURE Reallocate_Int64_R5b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int32_R5 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R5b -CALL Reallocate_Int32_R5(mat, s(1), s(2), s(3), s(4), s(5)) -END PROCEDURE Reallocate_Int32_R5b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int64_R6 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R6b -CALL Reallocate_Int64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) -END PROCEDURE Reallocate_Int64_R6b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int32_R6 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R6b -CALL Reallocate_Int32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) -END PROCEDURE Reallocate_Int32_R6b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int64_R7 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int64_R7b -CALL Reallocate_Int64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) -END PROCEDURE Reallocate_Int64_R7b - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0 -END PROCEDURE Reallocate_Int32_R7 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R7b -CALL Reallocate_Int32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) -END PROCEDURE Reallocate_Int32_R7b - -!---------------------------------------------------------------------------- -! Reallocate6 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Int32_R1_6 -IF (ALLOCATED(Vec1)) THEN - IF (SIZE(Vec1) .NE. n1) THEN - DEALLOCATE (Vec1) - ALLOCATE (Vec1(n1)) - END IF -ELSE - ALLOCATE (Vec1(n1)) -END IF -Vec1 = 0 - -IF (ALLOCATED(Vec2)) THEN - IF (SIZE(Vec2) .NE. n2) THEN - DEALLOCATE (Vec2) - ALLOCATE (Vec2(n2)) - END IF -ELSE - ALLOCATE (Vec2(n2)) -END IF -Vec2 = 0 - -IF (PRESENT(Vec3)) THEN - IF (ALLOCATED(Vec3)) THEN - IF (SIZE(Vec3) .NE. n3) THEN - DEALLOCATE (Vec3) - ALLOCATE (Vec3(n3)) - END IF - ELSE - ALLOCATE (Vec3(n3)) - END IF - Vec3 = 0 -END IF - -IF (PRESENT(Vec4)) THEN - IF (ALLOCATED(Vec4)) THEN - IF (SIZE(Vec4) .NE. n4) THEN - DEALLOCATE (Vec4) - ALLOCATE (Vec4(n4)) - END IF - ELSE - ALLOCATE (Vec4(n4)) - END IF - Vec4 = 0 -END IF - -IF (PRESENT(Vec5)) THEN - IF (ALLOCATED(Vec5)) THEN - IF (SIZE(Vec5) .NE. n5) THEN - DEALLOCATE (Vec5) - ALLOCATE (Vec5(n5)) - END IF - ELSE - ALLOCATE (Vec5(n5)) - END IF - Vec5 = 0 -END IF - -IF (PRESENT(Vec6)) THEN - IF (ALLOCATED(Vec6)) THEN - IF (SIZE(Vec6) .NE. n6) THEN - DEALLOCATE (Vec6) - ALLOCATE (Vec6(n6)) - END IF - ELSE - ALLOCATE (Vec6(n6)) - END IF - Vec6 = 0 -END IF - -END PROCEDURE Reallocate_Int32_R1_6 - -!---------------------------------------------------------------------------- -! Reallocate7 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_R1_6 -IF (ALLOCATED(Vec1)) THEN - IF (SIZE(Vec1) .NE. n1) THEN - DEALLOCATE (Vec1) - ALLOCATE (Vec1(n1)) - END IF -ELSE - ALLOCATE (Vec1(n1)) -END IF -Vec1 = 0.0 - -IF (ALLOCATED(Vec2)) THEN - IF (SIZE(Vec2) .NE. n2) THEN - DEALLOCATE (Vec2) - ALLOCATE (Vec2(n2)) - END IF -ELSE - ALLOCATE (Vec2(n2)) -END IF -Vec2 = 0.0 - -IF (PRESENT(Vec3)) THEN - IF (ALLOCATED(Vec3)) THEN - IF (SIZE(Vec3) .NE. n3) THEN - DEALLOCATE (Vec3) - ALLOCATE (Vec3(n3)) - END IF - ELSE - ALLOCATE (Vec3(n3)) - END IF - Vec3 = 0.0 -END IF - -IF (PRESENT(Vec4)) THEN - IF (ALLOCATED(Vec4)) THEN - IF (SIZE(Vec4) .NE. n4) THEN - DEALLOCATE (Vec4) - ALLOCATE (Vec4(n4)) - END IF - ELSE - ALLOCATE (Vec4(n4)) - END IF - Vec4 = 0.0 -END IF - -IF (PRESENT(Vec5)) THEN - IF (ALLOCATED(Vec5)) THEN - IF (SIZE(Vec5) .NE. n5) THEN - DEALLOCATE (Vec5) - ALLOCATE (Vec5(n5)) - END IF - ELSE - ALLOCATE (Vec5(n5)) - END IF - Vec5 = 0.0 -END IF - -IF (PRESENT(Vec6)) THEN - IF (ALLOCATED(Vec6)) THEN - IF (SIZE(Vec6) .NE. n6) THEN - DEALLOCATE (Vec6) - ALLOCATE (Vec6(n6)) - END IF - ELSE - ALLOCATE (Vec6(n6)) - END IF - Vec6 = 0.0 -END IF -END PROCEDURE Reallocate_Real64_R1_6 - -!---------------------------------------------------------------------------- -! Reallocate7 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_R1_6 -IF (ALLOCATED(Vec1)) THEN - IF (SIZE(Vec1) .NE. n1) THEN - DEALLOCATE (Vec1) - ALLOCATE (Vec1(n1)) - END IF -ELSE - ALLOCATE (Vec1(n1)) -END IF -Vec1 = 0.0 - -IF (ALLOCATED(Vec2)) THEN - IF (SIZE(Vec2) .NE. n2) THEN - DEALLOCATE (Vec2) - ALLOCATE (Vec2(n2)) - END IF -ELSE - ALLOCATE (Vec2(n2)) -END IF -Vec2 = 0.0 - -IF (PRESENT(Vec3)) THEN - IF (ALLOCATED(Vec3)) THEN - IF (SIZE(Vec3) .NE. n3) THEN - DEALLOCATE (Vec3) - ALLOCATE (Vec3(n3)) - END IF - ELSE - ALLOCATE (Vec3(n3)) - END IF - Vec3 = 0.0 -END IF - -IF (PRESENT(Vec4)) THEN - IF (ALLOCATED(Vec4)) THEN - IF (SIZE(Vec4) .NE. n4) THEN - DEALLOCATE (Vec4) - ALLOCATE (Vec4(n4)) - END IF - ELSE - ALLOCATE (Vec4(n4)) - END IF - Vec4 = 0.0 -END IF - -IF (PRESENT(Vec5)) THEN - IF (ALLOCATED(Vec5)) THEN - IF (SIZE(Vec5) .NE. n5) THEN - DEALLOCATE (Vec5) - ALLOCATE (Vec5(n5)) - END IF - ELSE - ALLOCATE (Vec5(n5)) - END IF - Vec5 = 0.0 -END IF - -IF (PRESENT(Vec6)) THEN - IF (ALLOCATED(Vec6)) THEN - IF (SIZE(Vec6) .NE. n6) THEN - DEALLOCATE (Vec6) - ALLOCATE (Vec6(n6)) - END IF - ELSE - ALLOCATE (Vec6(n6)) - END IF - Vec6 = 0.0 -END IF -END PROCEDURE Reallocate_Real32_R1_6 - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_AIJ -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 - -IF (ALLOCATED(JA)) THEN - IF (SIZE(JA) .NE. nJA) THEN - DEALLOCATE (JA) - ALLOCATE (JA(nJA)) - END IF -ELSE - ALLOCATE (JA(nJA)) -END IF -JA = 0 -END PROCEDURE Reallocate_Real64_AIJ - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_AIJ -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 - -IF (ALLOCATED(JA)) THEN - IF (SIZE(JA) .NE. nJA) THEN - DEALLOCATE (JA) - ALLOCATE (JA(nJA)) - END IF -ELSE - ALLOCATE (JA(nJA)) -END IF -JA = 0 -END PROCEDURE Reallocate_Real32_AIJ - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real64_AI -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 -END PROCEDURE Reallocate_Real64_AI - -!---------------------------------------------------------------------------- -! Reallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Reallocate_Real32_AI -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 -END PROCEDURE Reallocate_Real32_AI - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc b/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc deleted file mode 100644 index 046a6bd6b..000000000 --- a/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc +++ /dev/null @@ -1,46 +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 internal variables -INTEGER(I4B) :: ii, n, tsize - -IF (.NOT. ALLOCATED(obj)) THEN - RETURN -END IF - -tsize = SIZE(obj) - -if(tsize .LE. 1) RETURN - - -CALL QUICKSORT(obj, 1_I4B, tsize) - -temp = obj -DEALLOCATE (obj) - -n = 1 -obj = [temp(1)] - -DO ii = 2, tsize - IF (temp(ii) .NE. temp(ii - 1)) THEN - CALL Expand(vec=obj, n=n, chunk_size=tsize, & - & val=temp(ii)) - END IF -END DO - -CALL Expand(vec=obj, n=n, chunk_size=tsize, finished=.TRUE.) - diff --git a/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc b/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc deleted file mode 100644 index 6c0d03e1f..000000000 --- a/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc +++ /dev/null @@ -1,24 +0,0 @@ -! Define internal variables -INTEGER(I4B) :: ii, n - -tsize = SIZE(obj) -IF (tsize .LE. 1) RETURN - -IF (.NOT. isSorted) CALL QUICKSORT(obj, 1_I4B, tsize) - -DO CONCURRENT(ii=1:tsize) - temp(ii) = obj(ii) - obj(ii) = 0 -END DO - -obj(1) = temp(1) - -n = 1 -DO ii = 2, tsize - IF (temp(ii) .NE. temp(ii - 1)) THEN - n = n + 1 - obj(n) = temp(ii) - END IF -END DO - -tsize = n diff --git a/src/submodules/Utility/src/Repeat/Repeat_1.inc b/src/submodules/Utility/src/Repeat/Repeat_1.inc deleted file mode 100644 index 968e97111..000000000 --- a/src/submodules/Utility/src/Repeat/Repeat_1.inc +++ /dev/null @@ -1,23 +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 -! - -INTEGER(I4B) :: n, i -n = SIZE(Val) -Ans(1:n) = Val -DO i = 1, rtimes - 1 - Ans(i * n + 1:(i + 1) * n) = Val -END DO diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_1.inc b/src/submodules/Utility/src/RowConcat/RowConcat_1.inc deleted file mode 100644 index 9e32ef339..000000000 --- a/src/submodules/Utility/src/RowConcat/RowConcat_1.inc +++ /dev/null @@ -1,27 +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 -! - -INTEGER(I4B) :: ncol, nrow - -nrow = 2 -ncol = MAX(SIZE(a), SIZE(b)) - -CALL reallocate(ans, nrow, ncol) - -ans(1, 1:SIZE(a)) = a - -ans(2, 1:SIZE(b)) = b diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_2.inc b/src/submodules/Utility/src/RowConcat/RowConcat_2.inc deleted file mode 100644 index fe528ff1b..000000000 --- a/src/submodules/Utility/src/RowConcat/RowConcat_2.inc +++ /dev/null @@ -1,28 +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 -! - - INTEGER(I4B) :: nrow, ncol - - nrow = SIZE(a,1) + 1 - - ncol = MAX(SIZE(a,2), SIZE(b)) - - CALL reallocate(ans, nrow, ncol) - - ans(1:SIZE(a,1), 1:size(a,2) ) = a - - ans(nrow, 1:SIZE(b) ) = b diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_3.inc b/src/submodules/Utility/src/RowConcat/RowConcat_3.inc deleted file mode 100644 index 42461a24b..000000000 --- a/src/submodules/Utility/src/RowConcat/RowConcat_3.inc +++ /dev/null @@ -1,27 +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 -! - - INTEGER(I4B) :: nrow, ncol - - nrow = SIZE(b,1) + 1 - ncol = MAX(SIZE(b,2), SIZE(a)) - - CALL reallocate(ans, nrow, ncol) - - ans(1, 1:SIZE(a)) = a - - ans(2:, 1:SIZE(b,2)) = b diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_4.inc b/src/submodules/Utility/src/RowConcat/RowConcat_4.inc deleted file mode 100644 index ac6f77a52..000000000 --- a/src/submodules/Utility/src/RowConcat/RowConcat_4.inc +++ /dev/null @@ -1,28 +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 -! - - INTEGER(I4B) :: nrow, ncol - - ncol = MAX(SIZE(a, 2), SIZE(b, 2)) - - nrow = SIZE(a, 1) + SIZE(b, 1) - - CALL reallocate(ans, nrow, ncol) - - ans(1:SIZE(a, 1), 1:SIZE(a, 2)) = a - - ans(SIZE(a, 1) + 1:, 1:SIZE(b, 2)) = b diff --git a/src/submodules/Utility/src/SafeSizeUtility@Methods.F90 b/src/submodules/Utility/src/SafeSizeUtility@Methods.F90 deleted file mode 100644 index 287b6589f..000000000 --- a/src/submodules/Utility/src/SafeSizeUtility@Methods.F90 +++ /dev/null @@ -1,64 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! Vikas Sharma, Ph.D., vickysharma0812@gmail.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(SafeSizeUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SafeSize -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SafeSize1 -ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) -END PROCEDURE SafeSize1 - -!---------------------------------------------------------------------------- -! SafeSize -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SafeSize2 -ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) -END PROCEDURE SafeSize2 - -!---------------------------------------------------------------------------- -! SafeSize -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SafeSize3 -ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) -END PROCEDURE SafeSize3 - -!---------------------------------------------------------------------------- -! SafeSize -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SafeSize4 -ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) -END PROCEDURE SafeSize4 - -!---------------------------------------------------------------------------- -! SafeSize -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SafeSize5 -ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) -END PROCEDURE SafeSize5 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Sort/ArgSort.inc b/src/submodules/Utility/src/Sort/ArgSort.inc deleted file mode 100644 index a9763bcde..000000000 --- a/src/submodules/Utility/src/Sort/ArgSort.inc +++ /dev/null @@ -1,35 +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 -! - -CHARACTER(LEN=120) :: name0 - -IF (PRESENT(name)) THEN - name0 = UpperCase(name) -ELSE - name0 = "INTROSORT" -END IF - -ans = arange(1_I4B, SIZE(x, kind=I4B), 1_I4B) - -SELECT CASE (TRIM(name0)) -CASE ("HEAPSORT") - CALL ArgHeapSort(array=x, arg=ans) -CASE ("INTROSORT", "QUICKSORT") - CALL ArgIntroSort(array=x, arg=ans) -CASE ("INSERTION") - CALL ArgInsertionSort(array=x, arg=ans, low=1_I4B, high=SIZE(x, kind=I4B)) -END SELECT diff --git a/src/submodules/Utility/src/Sort/Sort.inc b/src/submodules/Utility/src/Sort/Sort.inc deleted file mode 100644 index ef78bbfbd..000000000 --- a/src/submodules/Utility/src/Sort/Sort.inc +++ /dev/null @@ -1,37 +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 -! - -CHARACTER(LEN=120) :: name0 - -IF (PRESENT(name)) THEN - name0 = UpperCase(name) -ELSE - name0 = "INTROSORT" -END IF - -ans = x - -SELECT CASE (TRIM(name0)) -CASE ("QUICKSORT") - CALL QuickSort(vect1=ans, low=1_I4B, high=SIZE(ans, kind=I4B)) -CASE ("HEAPSORT") - CALL HeapSort(array=ans) -CASE ("INTROSORT") - CALL IntroSort(array=ans) -CASE ("INSERTIONSORT") - CALL InsertionSort(array=ans, low=1_I4B, high=SIZE(ans, kind=I4B)) -END SELECT diff --git a/src/submodules/Utility/src/SortUtility@Methods.F90 b/src/submodules/Utility/src/SortUtility@Methods.F90 deleted file mode 100644 index e4e198cf1..000000000 --- a/src/submodules/Utility/src/SortUtility@Methods.F90 +++ /dev/null @@ -1,615 +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: 22 March 2021 -! summary: This submodule contains the sorting routine - -SUBMODULE(SortUtility) Methods -USE BaseMethod, ONLY: Swap, UpperCase, arange, Median, Partition, & -& ArgPartition, ArgMedian -IMPLICIT NONE - -INTEGER(I4B), PARAMETER :: minimumLengthForInsertion = 16 - -CONTAINS - -!---------------------------------------------------------------------------- -! IntroSort_Int8 -!---------------------------------------------------------------------------- - -#define _Recursive_IntroSort_ Recursive_IntroSort_Int8 -MODULE PROCEDURE IntroSort_Int8 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_IntroSort_(array, low, high, maxDepth) -END PROCEDURE IntroSort_Int8 -RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) - INTEGER(INT8), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_IntroSort.inc" -END SUBROUTINE _Recursive_IntroSort_ -#undef _Recursive_IntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Int16 -!---------------------------------------------------------------------------- - -#define _Recursive_IntroSort_ Recursive_IntroSort_Int16 -MODULE PROCEDURE IntroSort_Int16 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_IntroSort_(array, low, high, maxDepth) -END PROCEDURE IntroSort_Int16 -RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) - INTEGER(INT16), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_IntroSort.inc" -END SUBROUTINE _Recursive_IntroSort_ -#undef _Recursive_IntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Int32 -!---------------------------------------------------------------------------- - -#define _Recursive_IntroSort_ Recursive_IntroSort_Int32 -MODULE PROCEDURE IntroSort_Int32 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_IntroSort_(array, low, high, maxDepth) -END PROCEDURE IntroSort_Int32 -RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) - INTEGER(INT32), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_IntroSort.inc" -END SUBROUTINE _Recursive_IntroSort_ -#undef _Recursive_IntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Int8 -!---------------------------------------------------------------------------- - -#define _Recursive_IntroSort_ Recursive_IntroSort_Int64 -MODULE PROCEDURE IntroSort_Int64 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_IntroSort_(array, low, high, maxDepth) -END PROCEDURE IntroSort_Int64 -RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) - INTEGER(INT64), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_IntroSort.inc" -END SUBROUTINE _Recursive_IntroSort_ -#undef _Recursive_IntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Real32 -!---------------------------------------------------------------------------- - -#define _Recursive_IntroSort_ Recursive_IntroSort_Real32 -MODULE PROCEDURE IntroSort_Real32 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_IntroSort_(array, low, high, maxDepth) -END PROCEDURE IntroSort_Real32 -RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) - REAL(REAL32), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_IntroSort.inc" -END SUBROUTINE _Recursive_IntroSort_ -#undef _Recursive_IntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Real64 -!---------------------------------------------------------------------------- - -#define _Recursive_IntroSort_ Recursive_IntroSort_Real64 -MODULE PROCEDURE IntroSort_Real64 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_IntroSort_(array, low, high, maxDepth) -END PROCEDURE IntroSort_Real64 -RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) - REAL(REAL64), INTENT(INOUT) :: this(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_IntroSort.inc" -END SUBROUTINE _Recursive_IntroSort_ -#undef _Recursive_IntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Int8 -!---------------------------------------------------------------------------- - -#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int8 -MODULE PROCEDURE ArgIntroSort_Int8 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) -END PROCEDURE ArgIntroSort_Int8 -RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & - & left, right, maxDepth) - INTEGER(INT8), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: idx(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_ArgIntroSort.inc" -END SUBROUTINE _Recursive_ArgIntroSort_ -#undef _Recursive_ArgIntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Int16 -!---------------------------------------------------------------------------- - -#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int16 -MODULE PROCEDURE ArgIntroSort_Int16 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) -END PROCEDURE ArgIntroSort_Int16 -RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & - & left, right, maxDepth) - INTEGER(INT16), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: idx(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_ArgIntroSort.inc" -END SUBROUTINE _Recursive_ArgIntroSort_ -#undef _Recursive_ArgIntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Int32 -!---------------------------------------------------------------------------- - -#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int32 -MODULE PROCEDURE ArgIntroSort_Int32 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) -END PROCEDURE ArgIntroSort_Int32 -RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & - & left, right, maxDepth) - INTEGER(INT32), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: idx(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_ArgIntroSort.inc" -END SUBROUTINE _Recursive_ArgIntroSort_ -#undef _Recursive_ArgIntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Int64 -!---------------------------------------------------------------------------- - -#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int64 -MODULE PROCEDURE ArgIntroSort_Int64 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) -END PROCEDURE ArgIntroSort_Int64 -RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & - & left, right, maxDepth) - INTEGER(INT64), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: idx(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_ArgIntroSort.inc" -END SUBROUTINE _Recursive_ArgIntroSort_ -#undef _Recursive_ArgIntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Real32 -!---------------------------------------------------------------------------- - -#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Real32 -MODULE PROCEDURE ArgIntroSort_Real32 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) -END PROCEDURE ArgIntroSort_Real32 -RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & - & left, right, maxDepth) - REAL(REAL32), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: idx(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_ArgIntroSort.inc" -END SUBROUTINE _Recursive_ArgIntroSort_ -#undef _Recursive_ArgIntroSort_ - -!---------------------------------------------------------------------------- -! IntroSort_Real32 -!---------------------------------------------------------------------------- - -#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Real64 -MODULE PROCEDURE ArgIntroSort_Real64 -INTEGER(I4B) :: low, high -INTEGER(I4B) :: maxDepth -low = 1 -high = SIZE(array) -maxDepth = 2 * idnint(LOG(DBLE(high))) -CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) -END PROCEDURE ArgIntroSort_Real64 -RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & - & left, right, maxDepth) - REAL(REAL64), INTENT(IN) :: this(:) - INTEGER(I4B), INTENT(INOUT) :: idx(:) - INTEGER(I4B), INTENT(IN) :: left, right, maxDepth - INTEGER(I4B) :: imid, iPivot, N -#include "./IntroSort/Recursive_ArgIntroSort.inc" -END SUBROUTINE _Recursive_ArgIntroSort_ -#undef _Recursive_ArgIntroSort_ - -!---------------------------------------------------------------------------- -! InsertionSort -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InsertionSort_Int8 -#include "./InsertionSort/InsertionSort.inc" -END PROCEDURE InsertionSort_Int8 - -MODULE PROCEDURE InsertionSort_Int16 -#include "./InsertionSort/InsertionSort.inc" -END PROCEDURE InsertionSort_Int16 - -MODULE PROCEDURE InsertionSort_Int32 -#include "./InsertionSort/InsertionSort.inc" -END PROCEDURE InsertionSort_Int32 - -MODULE PROCEDURE InsertionSort_Int64 -#include "./InsertionSort/InsertionSort.inc" -END PROCEDURE InsertionSort_Int64 - -MODULE PROCEDURE InsertionSort_Real32 -#include "./InsertionSort/InsertionSort.inc" -END PROCEDURE InsertionSort_Real32 - -MODULE PROCEDURE InsertionSort_Real64 -#include "./InsertionSort/InsertionSort.inc" -END PROCEDURE InsertionSort_Real64 - -!---------------------------------------------------------------------------- -! ArgInsertionSort -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgInsertionSort_Int8 -#include "./InsertionSort/ArgInsertionSort.inc" -END PROCEDURE ArgInsertionSort_Int8 - -MODULE PROCEDURE ArgInsertionSort_Int16 -#include "./InsertionSort/ArgInsertionSort.inc" -END PROCEDURE ArgInsertionSort_Int16 - -MODULE PROCEDURE ArgInsertionSort_Int32 -#include "./InsertionSort/ArgInsertionSort.inc" -END PROCEDURE ArgInsertionSort_Int32 - -MODULE PROCEDURE ArgInsertionSort_Int64 -#include "./InsertionSort/ArgInsertionSort.inc" -END PROCEDURE ArgInsertionSort_Int64 - -MODULE PROCEDURE ArgInsertionSort_Real32 -#include "./InsertionSort/ArgInsertionSort.inc" -END PROCEDURE ArgInsertionSort_Real32 - -MODULE PROCEDURE ArgInsertionSort_Real64 -#include "./InsertionSort/ArgInsertionSort.inc" -END PROCEDURE ArgInsertionSort_Real64 - -!---------------------------------------------------------------------------- -! HeapSort -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeapSort_Int8 -INTEGER(INT8) :: t -#include "./HeapSort/HeapSort.inc" -END PROCEDURE HeapSort_Int8 - -MODULE PROCEDURE HeapSort_Int16 -INTEGER(INT16) :: t -#include "./HeapSort/HeapSort.inc" -END PROCEDURE HeapSort_Int16 - -MODULE PROCEDURE HeapSort_Int32 -INTEGER(INT32) :: t -#include "./HeapSort/HeapSort.inc" -END PROCEDURE HeapSort_Int32 - -MODULE PROCEDURE HeapSort_Int64 -INTEGER(INT64) :: t -#include "./HeapSort/HeapSort.inc" -END PROCEDURE HeapSort_Int64 - -MODULE PROCEDURE HeapSort_Real32 -REAL(REAL32) :: t -#include "./HeapSort/HeapSort.inc" -END PROCEDURE HeapSort_Real32 - -MODULE PROCEDURE HeapSort_Real64 -REAL(REAL64) :: t -#include "./HeapSort/HeapSort.inc" -END PROCEDURE HeapSort_Real64 - -!---------------------------------------------------------------------------- -! ArgHeapSort -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgHeapSort_Int8 -#include "./HeapSort/ArgHeapSort.inc" -END PROCEDURE ArgHeapSort_Int8 - -MODULE PROCEDURE ArgHeapSort_Int16 -#include "./HeapSort/ArgHeapSort.inc" -END PROCEDURE ArgHeapSort_Int16 - -MODULE PROCEDURE ArgHeapSort_Int32 -#include "./HeapSort/ArgHeapSort.inc" -END PROCEDURE ArgHeapSort_Int32 - -MODULE PROCEDURE ArgHeapSort_Int64 -#include "./HeapSort/ArgHeapSort.inc" -END PROCEDURE ArgHeapSort_Int64 - -MODULE PROCEDURE ArgHeapSort_Real32 -#include "./HeapSort/ArgHeapSort.inc" -END PROCEDURE ArgHeapSort_Real32 - -MODULE PROCEDURE ArgHeapSort_Real64 -#include "./HeapSort/ArgHeapSort.inc" -END PROCEDURE ArgHeapSort_Real64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuickSort1vectReal32 -#include "./QuickSort/QuickSort1Vec.inc" -END PROCEDURE QuickSort1vectReal32 - -MODULE PROCEDURE QuickSort1vectReal64 -#include "./QuickSort/QuickSort1Vec.inc" -END PROCEDURE QuickSort1vectReal64 - -MODULE PROCEDURE QuickSort1vectInt8 -#include "./QuickSort/QuickSort1Vec.inc" -END PROCEDURE QuickSort1vectInt8 - -MODULE PROCEDURE QuickSort1vectInt16 -#include "./QuickSort/QuickSort1Vec.inc" -END PROCEDURE QuickSort1vectInt16 - -MODULE PROCEDURE QuickSort1vectInt32 -#include "./QuickSort/QuickSort1Vec.inc" -END PROCEDURE QuickSort1vectInt32 - -MODULE PROCEDURE QuickSort1vectInt64 -#include "./QuickSort/QuickSort1Vec.inc" -END PROCEDURE QuickSort1vectInt64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuickSort2vectIR -#include "./QuickSort/QuickSort2Vec.inc" -END PROCEDURE QuickSort2vectIR - -MODULE PROCEDURE QuickSort2vectII -#include "./QuickSort/QuickSort2Vec.inc" -END PROCEDURE QuickSort2vectII - -MODULE PROCEDURE QuickSort2vectRI -#include "./QuickSort/QuickSort2Vec.inc" -END PROCEDURE QuickSort2vectRI - -MODULE PROCEDURE QuickSort2vectRR -#include "./QuickSort/QuickSort2Vec.inc" -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuickSort3vectIII -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE QuickSort3vectIII - -MODULE PROCEDURE QuickSort3vectIIR -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort3vectIRR -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort3vectIRI -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort3vectRRR -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort3vectRRI -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort3vectRIR -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort3vectRII -#include "./QuickSort/QuickSort3Vec.inc" -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuickSort4vectIIII -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectIIIR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectIIRI -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectIIRR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectIRRR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectIRRI -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectIRIR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectIRII -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRRRR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRRRI -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRRIR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRRII -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRIRR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRIRI -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRIIR -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -MODULE PROCEDURE QuickSort4vectRIII -#include "./QuickSort/QuickSort4Vec.inc" -END PROCEDURE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Sort_Int8 -#include "./Sort/Sort.inc" -END PROCEDURE Sort_Int8 -MODULE PROCEDURE Sort_Int16 -#include "./Sort/Sort.inc" -END PROCEDURE Sort_Int16 -MODULE PROCEDURE Sort_Int32 -#include "./Sort/Sort.inc" -END PROCEDURE Sort_Int32 -MODULE PROCEDURE Sort_Int64 -#include "./Sort/Sort.inc" -END PROCEDURE Sort_Int64 -MODULE PROCEDURE Sort_Real32 -#include "./Sort/Sort.inc" -END PROCEDURE Sort_Real32 -MODULE PROCEDURE Sort_Real64 -#include "./Sort/Sort.inc" -END PROCEDURE Sort_Real64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ArgSort_Int8 -#include "./Sort/ArgSort.inc" -END PROCEDURE ArgSort_Int8 -MODULE PROCEDURE ArgSort_Int16 -#include "./Sort/ArgSort.inc" -END PROCEDURE ArgSort_Int16 -MODULE PROCEDURE ArgSort_Int32 -#include "./Sort/ArgSort.inc" -END PROCEDURE ArgSort_Int32 -MODULE PROCEDURE ArgSort_Int64 -#include "./Sort/ArgSort.inc" -END PROCEDURE ArgSort_Int64 -MODULE PROCEDURE ArgSort_Real32 -#include "./Sort/ArgSort.inc" -END PROCEDURE ArgSort_Real32 -MODULE PROCEDURE ArgSort_Real64 -#include "./Sort/ArgSort.inc" -END PROCEDURE ArgSort_Real64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/SplitUtility@Methods.F90 b/src/submodules/Utility/src/SplitUtility@Methods.F90 deleted file mode 100644 index bab5645f5..000000000 --- a/src/submodules/Utility/src/SplitUtility@Methods.F90 +++ /dev/null @@ -1,93 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(SplitUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SPLIT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE split_Int8 -IF (section == 1) THEN - Ans = x(1:SIZE(x) / 2) -ELSEIF (section == 2) THEN - Ans = x(SIZE(x) / 2 + 1:) -END IF -END PROCEDURE split_Int8 - -MODULE PROCEDURE split_Int16 -IF (section == 1) THEN - Ans = x(1:SIZE(x) / 2) -ELSEIF (section == 2) THEN - Ans = x(SIZE(x) / 2 + 1:) -END IF -END PROCEDURE split_Int16 - -MODULE PROCEDURE split_Int32 -IF (section == 1) THEN - Ans = x(1:SIZE(x) / 2) -ELSEIF (section == 2) THEN - Ans = x(SIZE(x) / 2 + 1:) -END IF -END PROCEDURE split_Int32 - -MODULE PROCEDURE split_Int64 -IF (section == 1) THEN - Ans = x(1:SIZE(x) / 2) -ELSEIF (section == 2) THEN - Ans = x(SIZE(x) / 2 + 1:) -END IF -END PROCEDURE split_Int64 - -!---------------------------------------------------------------------------- -! SPLIT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE split_Real32 -IF (section == 1) THEN - Ans = x(1:SIZE(x) / 2) -ELSEIF (section == 2) THEN - Ans = x(SIZE(x) / 2 + 1:) -END IF -END PROCEDURE split_Real32 - -MODULE PROCEDURE split_Real64 -IF (section == 1) THEN - Ans = x(1:SIZE(x) / 2) -ELSEIF (section == 2) THEN - Ans = x(SIZE(x) / 2 + 1:) -END IF -END PROCEDURE split_Real64 - -!---------------------------------------------------------------------------- -! SPLIT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE split_char -IF (section == 1) THEN - Ans = x(1:LEN(x) / 2) -ELSE IF (section == 2) THEN - Ans = x(LEN(x) / 2 + 1:) -ELSE - Ans = '' -END IF -END PROCEDURE split_char - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/StringUtility@Methods.F90 b/src/submodules/Utility/src/StringUtility@Methods.F90 deleted file mode 100644 index 593866362..000000000 --- a/src/submodules/Utility/src/StringUtility@Methods.F90 +++ /dev/null @@ -1,401 +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(StringUtility) Methods -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_END -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! UpperCase -!---------------------------------------------------------------------------- - -MODULE PROCEDURE UpperCase_Char -ans = chars -CALL ToUpperCase_Char(ans) -END PROCEDURE UpperCase_Char - -!---------------------------------------------------------------------------- -! ToUpperCase -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ToUpperCase_Char -INTEGER(I4B) :: i, diff -CHARACTER(1) :: c - -diff = ICHAR('A') - ICHAR('a') -DO i = 1, LEN(chars) - c = chars(i:i) - IF (ICHAR(c) .GE. ICHAR('a') .AND. ICHAR(c) <= ICHAR('z')) THEN - chars(i:i) = CHAR(ICHAR(c) + diff) - END IF -END DO -END PROCEDURE ToUpperCase_Char - -!---------------------------------------------------------------------------- -! LowerCase -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LowerCase_Char -ans = chars -CALL ToLowerCase_Char(ans) -END PROCEDURE LowerCase_Char - -!---------------------------------------------------------------------------- -! ToLowerCase -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ToLowerCase_Char -INTEGER(I4B) :: i, diff -CHARACTER(1) :: c -!> -diff = ICHAR('A') - ICHAR('a') -DO i = 1, LEN(chars) - c = chars(i:i) - IF (ICHAR(c) .GE. ICHAR('A') .AND. ICHAR(c) .LE. ICHAR('Z')) THEN - chars(i:i) = CHAR(ICHAR(c) - diff) - END IF -END DO -END PROCEDURE ToLowerCase_Char - -!---------------------------------------------------------------------------- -! isWhiteChar -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isWhiteChar_char -INTEGER(I4B) :: ia -ia = IACHAR(char) -IF (ia .EQ. 32 .OR. ia .EQ. 9) THEN - ans = .TRUE. -ELSE - ans = .FALSE. -END IF -END PROCEDURE isWhiteChar_char - -!---------------------------------------------------------------------------- -! isBlank -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isBlank_chars -INTEGER(I4B) :: i, j -j = 0 -ans = .TRUE. -DO i = 1, LEN(chars) - IF (.NOT. isWhiteChar(chars(i:i))) THEN - ans = .FALSE. - EXIT - END IF -END DO -END PROCEDURE isBlank_chars - -!---------------------------------------------------------------------------- -! numMatchStr -!---------------------------------------------------------------------------- - -MODULE PROCEDURE numMatchStr_chars -INTEGER(I4B) :: i -ans = 0 -DO i = 1, LEN(chars) - IF (i + LEN(pattern) - 1 > LEN(chars)) EXIT - IF (chars(i:i + LEN(pattern) - 1) == pattern) ans = ans + 1 -END DO -END PROCEDURE numMatchStr_chars - -!---------------------------------------------------------------------------- -! numStrings -!---------------------------------------------------------------------------- - -MODULE PROCEDURE numStrings_chars -INTEGER(I4B) :: i, multidcol, n, ncol, nmult, ioerr -LOGICAL(LGT) :: nonblankd, nonblank, multidata, inQuotes - -!Check for single-quoted strings, if the number of single quotes is odd -!then return with a value of -1 to signal an error -IF (MOD(numMatchStr(TRIM(chars), "'"), 2) /= 0) THEN - ans = -1 - RETURN -END IF - -!Check for double-quoted strings, if the number of double quotes is odd -!then return with a value of -2 to signal an error -IF (MOD(numMatchStr(TRIM(chars), '"'), 2) /= 0) THEN - ans = -2 - RETURN -END IF - -nonblankd = .FALSE. -multidata = .FALSE. -inQuotes = .FALSE. -ncol = LEN_TRIM(chars) -IF (ncol > 2) THEN - ans = 1 -ELSE - ans = 0 -END IF - -n = 0 -DO i = ncol, 1, -1 - IF (chars(i:i) == "'" .OR. chars(i:i) == '"') THEN - IF (inQuotes) THEN - inQuotes = .FALSE. - n = n + 2 - CYCLE - ELSE - inQuotes = .TRUE. - END IF - END IF - !Process the spaces and multiplier characters if not in a quoted string - IF (.NOT. inQuotes) THEN - IF (chars(i:i) == ' ' .OR. ICHAR(chars(i:i)) == 9) THEN !ichar(tab)=9 - nonblank = .FALSE. - ELSE - IF (chars(i:i) == '*') THEN - multidata = .TRUE. - multidcol = i - END IF - nonblank = .TRUE. - END IF - IF ((.NOT. nonblankd .AND. nonblank) .OR. & - (nonblankd .AND. .NOT. nonblank)) THEN - n = n + 1 - END IF - IF (multidata .AND. (nonblankd .AND. .NOT. nonblank)) THEN - !ioerr will be non-zero if the sub-string is not an integer - READ (chars(i + 1:multidcol - 1), *, IOSTAT=ioerr) nmult - IF (ioerr /= 0) nmult = 1 - n = n + (nmult - 1) * 2 - - !If we are multiplying a quoted string need to subtract 1. - IF (multidcol < ncol) THEN - IF (chars(multidcol + 1:multidcol + 1) == '"' .OR. & - chars(multidcol + 1:multidcol + 1) == "'") & - n = n - 1 - END IF - - multidata = .FALSE. - END IF - nonblankd = nonblank - END IF -END DO -IF (MOD(n, 2) /= 0) THEN - ans = n / 2 + 1 -ELSE - ans = n / 2 -END IF -END PROCEDURE numStrings_chars - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE isPresent_chars -ans = MERGE(INDEX(chars, pattern) > 0, .FALSE., & - & (LEN(pattern) > 0 .AND. LEN(chars) > 0)) -END PROCEDURE isPresent_chars - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE strFind_chars -INTEGER(I4B) :: i, n -n = 0 -ALLOCATE (indices(numMatchStr(chars, pattern))) -DO i = 1, LEN(chars) - IF (i + LEN(pattern) - 1 > LEN(chars)) EXIT - IF (chars(i:i + LEN(pattern) - 1) == pattern) THEN - n = n + 1 - indices(n) = i - END IF -END DO -END PROCEDURE strFind_chars - -!---------------------------------------------------------------------------- -! FindReplace -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FindReplace_chars -CHARACTER(LEN(chars)) :: string2 -INTEGER(I4B), ALLOCATABLE :: indices(:) -INTEGER(I4B) :: i, n, stt, stp, dlen, slen, rlen, flen, tlen -!> -slen = LEN(chars) -tlen = LEN_TRIM(chars) -rlen = LEN(repp) -flen = LEN(findp) -dlen = rlen - flen -string2 = chars -n = numMatchStr(chars, findp) -CALL strfind(chars, findp, indices) -IF (slen >= tlen + n * dlen) THEN - DO i = 1, n - stt = indices(i) - stp = stt + rlen - 1 - chars(stt:stp) = repp - chars(stp + 1:slen) = string2(stt + flen - (i - 1) * dlen:slen) - IF (i < n) indices(i + 1) = indices(i + 1) + dlen * i - END DO -END IF -DEALLOCATE (indices) -END PROCEDURE FindReplace_chars - -!---------------------------------------------------------------------------- -! getField -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getField_chars -INTEGER(I4B) :: j, ioerr, nf -CHARACTER(LEN(chars)) :: temp, temp2 - -temp = chars -temp2 = '' -nf = numStrings(temp) -IF (0 < i .AND. i <= nf) THEN - !The fortran READ(*,*) parses at the '/' character - !we don't want this to occur. We only want it to parse for '*' - !and ' ' characters. So if slashes are present we treat things - !differently. - IF (isPresent(temp, CHAR_FSLASH)) THEN - !Temporarily change the CHAR_FSLASH character to a BSLASH character - !to get correct parsing behavior - CALL FindReplace(temp, CHAR_FSLASH, CHAR_BSLASH) - READ (temp, *, IOSTAT=ioerr) (temp2, j=1, i) - CALL FindReplace(temp, CHAR_BSLASH, CHAR_FSLASH) - CALL FindReplace(temp2, CHAR_BSLASH, CHAR_FSLASH) - ELSE - READ (temp, *, IOSTAT=ioerr) (temp2, j=1, i) - END IF - field = TRIM(temp2) - IF (PRESENT(ierr)) ierr = ioerr -ELSE - IF (PRESENT(ierr)) ierr = IOSTAT_END -END IF -END PROCEDURE getField_chars - -!---------------------------------------------------------------------------- -! SlashRep -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SlashRep_chars -INTEGER(I4B) :: i -DO i = 1, LEN_TRIM(chars) -#ifdef WIN32 - IF (chars(i:i) == CHAR_FSLASH) chars(i:i) = CHAR_SLASH -#else - IF (chars(i:i) == CHAR_BSLASH) chars(i:i) = CHAR_SLASH -#endif -END DO -END PROCEDURE SlashRep_chars - -!---------------------------------------------------------------------------- -! getFileParts -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getFileParts_chars -INTEGER(I4B) :: i -CALL getPath_chars(chars, path) -CALL getFileName_chars(chars, fname) -DO i = LEN_TRIM(fname), 1, -1 - IF (fname(i:i) .EQ. CHAR_DOT) THEN - fname = fname(1:i - 1) - EXIT - END IF -END DO -CALL getFileNameExt_chars(chars, ext) -END PROCEDURE getFileParts_chars - -!---------------------------------------------------------------------------- -! getPath -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getPath_chars -CHARACTER(LEN(chars)) :: chars2 -INTEGER(I4B) :: i -!> -chars2 = chars -CALL SlashRep(chars2) -path = '' -DO i = LEN_TRIM(chars2), 1, -1 - IF (chars2(i:i) .EQ. CHAR_SLASH) THEN - path = chars2(1:i) - EXIT - END IF -END DO -END PROCEDURE getPath_chars - -!---------------------------------------------------------------------------- -! getExtension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getExtension_chars -! Define internal variables -INTEGER(I4B) :: n, m -n = 0 -n = INDEX(char, ".", back=.TRUE.) -IF (n .EQ. 0) THEN - ext = "" -ELSE - m = LEN(char) - ext = CHAR(n + 1:m) -END IF -END PROCEDURE getExtension_chars - -!---------------------------------------------------------------------------- -! getFileName -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getFileName_chars -CHARACTER(LEN(chars)) :: chars2 -INTEGER(I4B) :: i -chars2 = chars -CALL SlashRep(chars2) -fname = chars -DO i = LEN_TRIM(chars2), 1, -1 - IF (chars2(i:i) .EQ. CHAR_SLASH) THEN - fname = chars2(i + 1:LEN_TRIM(chars2)) - EXIT - END IF -END DO -END PROCEDURE getFileName_chars - -!---------------------------------------------------------------------------- -! getFileNameExt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getFileNameExt_chars -CHARACTER(:), ALLOCATABLE :: chars2 -INTEGER(I4B) :: i, SLASHloc - -chars2 = TRIM(chars) -CALL SlashRep(chars2) -ext = '' -SLASHloc = 1 -DO i = LEN_TRIM(chars2), 1, -1 - IF (chars2(i:i) == CHAR_SLASH) THEN - SLASHloc = i - EXIT - END IF -END DO -DO i = LEN_TRIM(chars2), SLASHloc, -1 - IF (chars2(i:i) == CHAR_DOT) THEN - ext = chars2(i:LEN_TRIM(chars2)) - EXIT - END IF -END DO -END PROCEDURE getFileNameExt_chars - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/SwapUtility@Methods.F90 b/src/submodules/Utility/src/SwapUtility@Methods.F90 deleted file mode 100644 index c891eb817..000000000 --- a/src/submodules/Utility/src/SwapUtility@Methods.F90 +++ /dev/null @@ -1,817 +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: 22 March 2021 -! summary: This submodule contains method for swaping - -SUBMODULE(SwapUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int8 -INTEGER(INT8) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int8 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int16 -INTEGER(INT16) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int16 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int32 -INTEGER(INT32) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int32 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int64 -INTEGER(INT64) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int64 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_r32 -REAL(REAL32) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_r32 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_r64 -REAL(REAL64) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_r64 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -#ifndef USE_BLAS95 -MODULE PROCEDURE swap_r32v -REAL(REAL32), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_r32v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_r64v -REAL(REAL64), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_r64v -#endif - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int8v -INTEGER(INT8), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int8v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int16v -INTEGER(INT16), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int16v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int32v -INTEGER(INT32), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int32v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int64v -INTEGER(INT64), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int64v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE swap_Int128v -INTEGER(Int128), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int128v -#endif - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_c -COMPLEX(DFPC) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_c - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -#ifndef USE_BLAS95 -MODULE PROCEDURE swap_cv -COMPLEX(DFPC), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_cv -#endif - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_cm -COMPLEX(DFPC), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_cm - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_r32m -REAL(REAL32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_r32m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_r64m -REAL(REAL64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_r64m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int8m -INTEGER(INT8), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int8m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int16m -INTEGER(INT16), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int16m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int32m -INTEGER(INT32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int32m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_Int64m -INTEGER(INT64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int64m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE swap_Int128m -INTEGER(Int128), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum -END PROCEDURE swap_Int128m -#endif - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_r32s -REAL(REAL32) :: swp -IF (mask) THEN - swp = a - a = b - b = swp -END IF -END PROCEDURE masked_swap_r32s - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_r64s -REAL(REAL64) :: swp -IF (mask) THEN - swp = a - a = b - b = swp -END IF -END PROCEDURE masked_swap_r64s - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int8s -INTEGER(INT8) :: swp -IF (mask) THEN - swp = a - a = b - b = swp -END IF -END PROCEDURE masked_swap_Int8s - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int16s -INTEGER(INT16) :: swp -IF (mask) THEN - swp = a - a = b - b = swp -END IF -END PROCEDURE masked_swap_Int16s - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int32s -INTEGER(INT32) :: swp -IF (mask) THEN - swp = a - a = b - b = swp -END IF -END PROCEDURE masked_swap_Int32s - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int64s -INTEGER(INT64) :: swp -IF (mask) THEN - swp = a - a = b - b = swp -END IF -END PROCEDURE masked_swap_Int64s - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE masked_swap_Int128s -INTEGER(Int128) :: swp -IF (mask) THEN - swp = a - a = b - b = swp -END IF -END PROCEDURE masked_swap_Int128s -#endif - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_r32v -REAL(REAL32), DIMENSION(SIZE(a)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_r32v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_r64v -REAL(REAL64), DIMENSION(SIZE(a)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_r64v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int8v -INTEGER(INT8), DIMENSION(SIZE(a)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int8v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int16v -INTEGER(INT16), DIMENSION(SIZE(a)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int16v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int32v -INTEGER(INT32), DIMENSION(SIZE(a)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int32v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int64v -INTEGER(INT64), DIMENSION(SIZE(a)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int64v - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE masked_swap_Int128v -INTEGER(Int128), DIMENSION(SIZE(a)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int128v -#endif - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_r32m -REAL(REAL32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_r32m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_r64m -REAL(REAL64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_r64m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int8m -INTEGER(INT8), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int8m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int16m -INTEGER(INT16), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int16m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int32m -INTEGER(INT32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int32m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE masked_swap_Int64m -INTEGER(INT64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int64m - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE masked_swap_Int128m -INTEGER(Int128), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp -WHERE (mask) - swp = a - a = b - b = swp -END WHERE -END PROCEDURE masked_swap_Int128m -#endif - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index1 -INTEGER(I4B) :: IJ(2), s(2), i, j -!! main -IF (ANY([i1, i2] .GT. 2) .OR. ANY([i1, i2] .LE. 0) .OR. i1 .EQ. i2) THEN - s = SHAPE(b) - CALL Reallocate(a, s(1), s(2)) - a = b -ELSE - s = SHAPE(b) - CALL Reallocate(a, s(i1), s(i2)) - DO j = 1, s(2) - DO i = 1, s(1) - ij = [i, j] - a(ij(i1), ij(i2)) = b(i, j) - END DO - END DO -END IF -END PROCEDURE swap_index1 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index_1 -INTEGER(I4B) :: ij(2), s(2), i, j -!! main -s = SHAPE(b) -DO j = 1, s(2) - DO i = 1, s(1) - ij(1) = i; ij(2) = j - a(ij(i1), ij(i2)) = b(i, j) - END DO -END DO -END PROCEDURE swap_index_1 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index_2 -INTEGER(I4B) :: ij(2), s(2), i, j -!! main -s = SHAPE(b) -DO j = 1, s(2) - DO i = 1, s(1) - ij(1) = i; ij(2) = j - a(ij(i1), ij(i2)) = b(i, j) - END DO -END DO -END PROCEDURE swap_index_2 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index2 -INTEGER(I4B) :: IJ(2), s(2), i, j -!! main -IF (ANY([i1, i2] .GT. 2) .OR. ANY([i1, i2] .LE. 0) .OR. i1 .EQ. i2) THEN - s = SHAPE(b) - CALL Reallocate(a, s(1), s(2)) - a = b -ELSE - s = SHAPE(b) - CALL Reallocate(a, s(i1), s(i2)) - DO j = 1, s(2) - DO i = 1, s(1) - ij = [i, j] - a(ij(i1), ij(i2)) = b(i, j) - END DO - END DO -END IF -END PROCEDURE swap_index2 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index3 -INTEGER(I4B) :: ijk(3), s(3), i, j, k -!! main -IF (ANY([i1, i2, i3] .GT. 3) .OR. ANY([i1, i2, i3] .LE. 0)) THEN - s = SHAPE(b) - CALL Reallocate(a, s(1), s(2), s(3)) - a = b -ELSE - s = SHAPE(b) - CALL Reallocate(a, s(i1), s(i2), s(i3)) - DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - ijk = [i, j, k] - a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) - END DO - END DO - END DO -END IF -END PROCEDURE swap_index3 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index4 -INTEGER(I4B) :: ijk(3), s(3), i, j, k -!! main -IF (ANY([i1, i2, i3] .GT. 3) .OR. ANY([i1, i2, i3] .LE. 0)) THEN - s = SHAPE(b) - CALL Reallocate(a, s(1), s(2), s(3)) - a = b -ELSE - s = SHAPE(b) - CALL Reallocate(a, s(i1), s(i2), s(i3)) - DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - ijk = [i, j, k] - a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) - END DO - END DO - END DO -END IF -END PROCEDURE swap_index4 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index_3 -INTEGER(I4B) :: ijk(3), s(3), i, j, k -!! main -s = SHAPE(b) -DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - ijk = [i, j, k] - a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) - END DO - END DO -END DO -END PROCEDURE swap_index_3 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index_4 -INTEGER(I4B) :: ijk(3), s(3), i, j, k -!! main -s = SHAPE(b) -DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - ijk = [i, j, k] - a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) - END DO - END DO -END DO -END PROCEDURE swap_index_4 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index5 -INTEGER(I4B) :: indx(4), s(4), i, j, k, l -!! main -s = SHAPE(b) -CALL Reallocate(a, s(i1), s(i2), s(i3), s(i4)) -DO l = 1, s(4) - DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - indx = [i, j, k, l] - a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) - END DO - END DO - END DO -END DO -END PROCEDURE swap_index5 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index6 -INTEGER(I4B) :: indx(4), s(4), i, j, k, l -!! main -s = SHAPE(b) -CALL Reallocate(a, s(i1), s(i2), s(i3), s(i4)) -DO l = 1, s(4) - DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - indx = [i, j, k, l] - a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) - END DO - END DO - END DO -END DO -END PROCEDURE swap_index6 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index_5 -INTEGER(I4B) :: indx(4), s(4), i, j, k, l -!! main -s = SHAPE(b) -DO l = 1, s(4) - DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - indx = [i, j, k, l] - a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) - END DO - END DO - END DO -END DO -END PROCEDURE swap_index_5 - -!---------------------------------------------------------------------------- -! SWAP -!---------------------------------------------------------------------------- - -MODULE PROCEDURE swap_index_6 -INTEGER(I4B) :: indx(4), s(4), i, j, k, l -!! main -s = SHAPE(b) -DO l = 1, s(4) - DO k = 1, s(3) - DO j = 1, s(2) - DO i = 1, s(1) - indx = [i, j, k, l] - a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) - END DO - END DO - END DO -END DO -END PROCEDURE swap_index_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Sym/GetSym.inc b/src/submodules/Utility/src/Sym/GetSym.inc deleted file mode 100644 index 9dd641a01..000000000 --- a/src/submodules/Utility/src/Sym/GetSym.inc +++ /dev/null @@ -1,28 +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 -! - -INTEGER(I4B) :: ii, jj -SELECT CASE (from) -CASE ("L", "l") - DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) - IF (ii .GE. jj) mat(jj, ii) = mat(ii, jj) - END DO -CASE ("u", "U") - DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) - IF (ii .GE. jj) mat(ii, jj) = mat(jj, ii) - END DO -END SELECT diff --git a/src/submodules/Utility/src/Sym/Sym.inc b/src/submodules/Utility/src/Sym/Sym.inc deleted file mode 100644 index 5404c877b..000000000 --- a/src/submodules/Utility/src/Sym/Sym.inc +++ /dev/null @@ -1,36 +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 -! - -INTEGER(I4B) :: ii, jj -SELECT CASE (from) -CASE ("L", "l") - DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) - IF (ii .GE. jj) THEN - ans(jj, ii) = mat(ii, jj) - ELSE - ans(jj, ii) = mat(jj, ii) - END IF - END DO -CASE ("u", "U") - DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) - IF (ii .GE. jj) THEN - ans(ii, jj) = mat(jj, ii) - ELSE - ans(ii, jj) = mat(ii, jj) - END IF - END DO -END SELECT diff --git a/src/submodules/Utility/src/SymUtility@Methods.F90 b/src/submodules/Utility/src/SymUtility@Methods.F90 deleted file mode 100644 index ba817fb04..000000000 --- a/src/submodules/Utility/src/SymUtility@Methods.F90 +++ /dev/null @@ -1,78 +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(SymUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Sym_Int8 -#include "./Sym/Sym.inc" -END PROCEDURE Sym_Int8 - -MODULE PROCEDURE Sym_Int16 -#include "./Sym/Sym.inc" -END PROCEDURE Sym_Int16 - -MODULE PROCEDURE Sym_Int32 -#include "./Sym/Sym.inc" -END PROCEDURE Sym_Int32 - -MODULE PROCEDURE Sym_Int64 -#include "./Sym/Sym.inc" -END PROCEDURE Sym_Int64 - -MODULE PROCEDURE Sym_Real32 -#include "./Sym/Sym.inc" -END PROCEDURE Sym_Real32 - -MODULE PROCEDURE Sym_Real64 -#include "./Sym/Sym.inc" -END PROCEDURE Sym_Real64 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetSym_Int8 -#include "./Sym/GetSym.inc" -END PROCEDURE GetSym_Int8 - -MODULE PROCEDURE GetSym_Int16 -#include "./Sym/GetSym.inc" -END PROCEDURE GetSym_Int16 - -MODULE PROCEDURE GetSym_Int32 -#include "./Sym/GetSym.inc" -END PROCEDURE GetSym_Int32 - -MODULE PROCEDURE GetSym_Int64 -#include "./Sym/GetSym.inc" -END PROCEDURE GetSym_Int64 - -MODULE PROCEDURE GetSym_Real32 -#include "./Sym/GetSym.inc" -END PROCEDURE GetSym_Real32 - -MODULE PROCEDURE GetSym_Real64 -#include "./Sym/GetSym.inc" -END PROCEDURE GetSym_Real64 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/TailUtility@Methods.F90 b/src/submodules/Utility/src/TailUtility@Methods.F90 deleted file mode 100644 index 8ef119bf4..000000000 --- a/src/submodules/Utility/src/TailUtility@Methods.F90 +++ /dev/null @@ -1,103 +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(TailUtility) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Tail -!---------------------------------------------------------------------------- - -MODULE PROCEDURE tail_Int8 -ans = x(2:) -END PROCEDURE tail_Int8 - -MODULE PROCEDURE tail_Int16 -ans = x(2:) -END PROCEDURE tail_Int16 - -MODULE PROCEDURE tail_Int32 -ans = x(2:) -END PROCEDURE tail_Int32 - -MODULE PROCEDURE tail_Int64 -ans = x(2:) -END PROCEDURE tail_Int64 - -!---------------------------------------------------------------------------- -! Tail -!---------------------------------------------------------------------------- - -MODULE PROCEDURE tail_Real32 -ans = x(2:) -END PROCEDURE tail_Real32 - -MODULE PROCEDURE tail_Real64 -ans = x(2:) -END PROCEDURE tail_Real64 - -!---------------------------------------------------------------------------- -! Tail -!---------------------------------------------------------------------------- - -MODULE PROCEDURE tail_char -ans = x(2:) -END PROCEDURE tail_char - -!---------------------------------------------------------------------------- -! last -!---------------------------------------------------------------------------- - -MODULE PROCEDURE last_Int8 -ans = x(SIZE(x)) -END PROCEDURE last_Int8 - -MODULE PROCEDURE last_Int16 -ans = x(SIZE(x)) -END PROCEDURE last_Int16 - -MODULE PROCEDURE last_Int32 -ans = x(SIZE(x)) -END PROCEDURE last_Int32 - -MODULE PROCEDURE last_Int64 -ans = x(SIZE(x)) -END PROCEDURE last_Int64 - -!---------------------------------------------------------------------------- -! last -!---------------------------------------------------------------------------- - -MODULE PROCEDURE last_Real32 -ans = x(SIZE(x)) -END PROCEDURE last_Real32 - -MODULE PROCEDURE last_Real64 -ans = x(SIZE(x)) -END PROCEDURE last_Real64 - -!---------------------------------------------------------------------------- -! last -!---------------------------------------------------------------------------- - -MODULE PROCEDURE last_char -ans = x(LEN(x):LEN(x)) -END PROCEDURE last_char - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Triag/GetTril1.inc b/src/submodules/Utility/src/Triag/GetTril1.inc deleted file mode 100644 index 31006c131..000000000 --- a/src/submodules/Utility/src/Triag/GetTril1.inc +++ /dev/null @@ -1,26 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -lu = 0.0_DFP -indx = TrilIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - lu(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) -END DO -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/GetTril2.inc b/src/submodules/Utility/src/Triag/GetTril2.inc deleted file mode 100644 index fb7100513..000000000 --- a/src/submodules/Utility/src/Triag/GetTril2.inc +++ /dev/null @@ -1,34 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: tsize, ii, jj -! -indx = TrilIndx(A, diagNo) -tsize = SIZE(indx, 1) -! -CALL Reallocate(lu, tsize) -! -jj = 0 -! -DO ii = 1, tsize - jj = jj + 1 - lu(jj) = A(indx(ii, 1), indx(ii, 2)) -END DO -! -DEALLOCATE (indx) - diff --git a/src/submodules/Utility/src/Triag/GetTriu1.inc b/src/submodules/Utility/src/Triag/GetTriu1.inc deleted file mode 100644 index a064c5da6..000000000 --- a/src/submodules/Utility/src/Triag/GetTriu1.inc +++ /dev/null @@ -1,26 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -lu = 0.0_DFP -indx = TriuIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - lu(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) -END DO -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/GetTriu2.inc b/src/submodules/Utility/src/Triag/GetTriu2.inc deleted file mode 100644 index c9a18bc77..000000000 --- a/src/submodules/Utility/src/Triag/GetTriu2.inc +++ /dev/null @@ -1,33 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: tsize, ii, jj -! -indx = TriuIndx(A, diagNo) -tsize = SIZE(indx, 1) -! -CALL REALLOCATE(lu, tsize) -! -jj = 0 -! -DO ii = 1, tsize - jj = jj + 1 - lu(jj) = A(indx(ii, 1), indx(ii, 2)) -END DO -! -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTril1.inc b/src/submodules/Utility/src/Triag/SetTril1.inc deleted file mode 100644 index 22a7c93b5..000000000 --- a/src/submodules/Utility/src/Triag/SetTril1.inc +++ /dev/null @@ -1,25 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -indx = TrilIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - A(indx(ii, 1), indx(ii, 2)) = lu(indx(ii, 1), indx(ii, 2)) -END DO -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTril2.inc b/src/submodules/Utility/src/Triag/SetTril2.inc deleted file mode 100644 index c072b35a5..000000000 --- a/src/submodules/Utility/src/Triag/SetTril2.inc +++ /dev/null @@ -1,32 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: tsize, ii, jj -! -indx = TrilIndx(A, diagNo) -tsize = SIZE(indx, 1) -! -jj = 0 -! -DO ii = 1, tsize - jj = jj + 1 - A(indx(ii, 1), indx(ii, 2)) = lu(jj) -END DO -! -DEALLOCATE (indx) - diff --git a/src/submodules/Utility/src/Triag/SetTril3.inc b/src/submodules/Utility/src/Triag/SetTril3.inc deleted file mode 100644 index 3cd3ee755..000000000 --- a/src/submodules/Utility/src/Triag/SetTril3.inc +++ /dev/null @@ -1,25 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -indx = TrilIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - A(indx(ii, 1), indx(ii, 2)) = val -END DO -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTriu1.inc b/src/submodules/Utility/src/Triag/SetTriu1.inc deleted file mode 100644 index d963b1318..000000000 --- a/src/submodules/Utility/src/Triag/SetTriu1.inc +++ /dev/null @@ -1,25 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -indx = TriuIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - A(indx(ii, 1), indx(ii, 2)) = lu(indx(ii, 1), indx(ii, 2)) -END DO -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTriu2.inc b/src/submodules/Utility/src/Triag/SetTriu2.inc deleted file mode 100644 index 02aeb9eb9..000000000 --- a/src/submodules/Utility/src/Triag/SetTriu2.inc +++ /dev/null @@ -1,31 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: tsize, ii, jj -! -indx = TriuIndx(A, diagNo) -tsize = SIZE(indx, 1) -! -jj = 0 -! -DO ii = 1, tsize - jj = jj + 1 - A(indx(ii, 1), indx(ii, 2)) = lu(jj) -END DO -! -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTriu3.inc b/src/submodules/Utility/src/Triag/SetTriu3.inc deleted file mode 100644 index c000b6540..000000000 --- a/src/submodules/Utility/src/Triag/SetTriu3.inc +++ /dev/null @@ -1,25 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -indx = TriuIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - A(indx(ii, 1), indx(ii, 2)) = val -END DO -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/Tril1.inc b/src/submodules/Utility/src/Triag/Tril1.inc deleted file mode 100644 index 8671972b9..000000000 --- a/src/submodules/Utility/src/Triag/Tril1.inc +++ /dev/null @@ -1,26 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -ans = 0.0_DFP -indx = TrilIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - ans(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) -END DO -DEALLOCATE (indx) \ No newline at end of file diff --git a/src/submodules/Utility/src/Triag/Tril2.inc b/src/submodules/Utility/src/Triag/Tril2.inc deleted file mode 100644 index b0020c1f7..000000000 --- a/src/submodules/Utility/src/Triag/Tril2.inc +++ /dev/null @@ -1,34 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: tsize, ii, jj -! -indx = TrilIndx(A, diagNo) -tsize = SIZE(indx, 1) -! -ALLOCATE (ans(tsize)) -! -jj = 0 -! -DO ii = 1, tsize - jj = jj + 1 - ans(jj) = A(indx(ii, 1), indx(ii, 2)) -END DO -! -DEALLOCATE (indx) - diff --git a/src/submodules/Utility/src/Triag/Triu1.inc b/src/submodules/Utility/src/Triag/Triu1.inc deleted file mode 100644 index e9b9694eb..000000000 --- a/src/submodules/Utility/src/Triag/Triu1.inc +++ /dev/null @@ -1,26 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: ii -! -ans = 0.0_DFP -indx = TriuIndx(A, diagNo) -DO CONCURRENT(ii=1:SIZE(indx, 1)) - ans(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) -END DO -DEALLOCATE (indx) \ No newline at end of file diff --git a/src/submodules/Utility/src/Triag/Triu2.inc b/src/submodules/Utility/src/Triag/Triu2.inc deleted file mode 100644 index 27d4e574d..000000000 --- a/src/submodules/Utility/src/Triag/Triu2.inc +++ /dev/null @@ -1,33 +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 -! - -INTEGER(I4B), ALLOCATABLE :: indx(:, :) -INTEGER(I4B) :: tsize, ii, jj -! -indx = TriuIndx(A, diagNo) -tsize = SIZE(indx, 1) -! -ALLOCATE (ans(tsize)) -! -jj = 0 -! -DO ii = 1, tsize - jj = jj + 1 - ans(jj) = A(indx(ii, 1), indx(ii, 2)) -END DO -! -DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/TriagUtility@Methods.F90 b/src/submodules/Utility/src/TriagUtility@Methods.F90 deleted file mode 100644 index 0a8df9988..000000000 --- a/src/submodules/Utility/src/TriagUtility@Methods.F90 +++ /dev/null @@ -1,434 +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(TriagUtility) Methods -USE BaseMethod, ONLY: Input, DiagIndx, Append, Reallocate, DiagSize -CONTAINS - -!---------------------------------------------------------------------------- -! TriuIndx -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriuIndx_1 -INTEGER(I4B) :: m0, n0, diagNo0, tsize, tdiag, idiag, i1, i2 -! -m0 = m -n0 = INPUT(default=m, option=n) -diagNo0 = INPUT(default=0_I4B, option=diagNo) -! -tsize = 0 -tdiag = 0 -idiag = diagNo0 -! -DO - IF (idiag .GT. n0) EXIT - tsize = tsize + DiagSize(m0, n0, idiag) - idiag = idiag + 1 -END DO -! -ALLOCATE (ans(tsize, 2)) -! -idiag = diagNo0 -! -i1 = 0 -i2 = 0 -! -DO - IF (idiag .GT. n0) EXIT - i1 = i2 + 1 - i2 = i2 + DiagSize(m0, n0, idiag) - ans(i1:i2, 1:2) = DiagIndx(m0, n0, idiag) - idiag = idiag + 1 -END DO -! -END PROCEDURE TriuIndx_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TriuIndx_2 -ans = TriuIndx(SIZE(A, 1), SIZE(A, 2), diagNo) -END PROCEDURE TriuIndx_2 - -!---------------------------------------------------------------------------- -! TrilIndx -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TrilIndx_1 -INTEGER(I4B) :: m0, n0, diagNo0, tsize, idiag, i1, i2 -! -m0 = m -n0 = INPUT(default=m, option=n) -diagNo0 = INPUT(default=0_I4B, option=diagNo) -! -tsize = 0 -idiag = diagNo0 -! -DO - IF (-idiag .GT. m0) EXIT - tsize = tsize + DiagSize(m0, n0, idiag) - idiag = idiag - 1 -END DO -! -ALLOCATE (ans(tsize, 2)) -! -i1 = 0 -i2 = 0 -idiag = diagNo0 -! -DO - IF (-idiag .GT. m0) EXIT - i1 = i2 + 1 - i2 = i2 + DiagSize(m0, n0, idiag) - ans(i1:i2, 1:2) = DiagIndx(m0, n0, idiag) - idiag = idiag - 1 -END DO -! -END PROCEDURE TrilIndx_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TrilIndx_2 -ans = TrilIndx(SIZE(A, 1), SIZE(A, 2), diagNo) -END PROCEDURE TrilIndx_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Tril_1 -#include "./Triag/Tril1.inc" -END PROCEDURE Tril_1 -MODULE PROCEDURE Tril_2 -#include "./Triag/Tril1.inc" -END PROCEDURE Tril_2 -MODULE PROCEDURE Tril_3 -#include "./Triag/Tril1.inc" -END PROCEDURE Tril_3 -MODULE PROCEDURE Tril_4 -#include "./Triag/Tril1.inc" -END PROCEDURE Tril_4 -MODULE PROCEDURE Tril_5 -#include "./Triag/Tril1.inc" -END PROCEDURE Tril_5 -MODULE PROCEDURE Tril_6 -#include "./Triag/Tril1.inc" -END PROCEDURE Tril_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Tril_7 -#include "./Triag/Tril2.inc" -END PROCEDURE Tril_7 -MODULE PROCEDURE Tril_8 -#include "./Triag/Tril2.inc" -END PROCEDURE Tril_8 -MODULE PROCEDURE Tril_9 -#include "./Triag/Tril2.inc" -END PROCEDURE Tril_9 -MODULE PROCEDURE Tril_10 -#include "./Triag/Tril2.inc" -END PROCEDURE Tril_10 -MODULE PROCEDURE Tril_11 -#include "./Triag/Tril2.inc" -END PROCEDURE Tril_11 -MODULE PROCEDURE Tril_12 -#include "./Triag/Tril2.inc" -END PROCEDURE Tril_12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Triu_1 -#include "./Triag/Triu1.inc" -END PROCEDURE Triu_1 -MODULE PROCEDURE Triu_2 -#include "./Triag/Triu1.inc" -END PROCEDURE Triu_2 -MODULE PROCEDURE Triu_3 -#include "./Triag/Triu1.inc" -END PROCEDURE Triu_3 -MODULE PROCEDURE Triu_4 -#include "./Triag/Triu1.inc" -END PROCEDURE Triu_4 -MODULE PROCEDURE Triu_5 -#include "./Triag/Triu1.inc" -END PROCEDURE Triu_5 -MODULE PROCEDURE Triu_6 -#include "./Triag/Triu1.inc" -END PROCEDURE Triu_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Triu_7 -#include "./Triag/Triu2.inc" -END PROCEDURE Triu_7 -MODULE PROCEDURE Triu_8 -#include "./Triag/Triu2.inc" -END PROCEDURE Triu_8 -MODULE PROCEDURE Triu_9 -#include "./Triag/Triu2.inc" -END PROCEDURE Triu_9 -MODULE PROCEDURE Triu_10 -#include "./Triag/Triu2.inc" -END PROCEDURE Triu_10 -MODULE PROCEDURE Triu_11 -#include "./Triag/Triu2.inc" -END PROCEDURE Triu_11 -MODULE PROCEDURE Triu_12 -#include "./Triag/Triu2.inc" -END PROCEDURE Triu_12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTril_1 -#include "./Triag/GetTril1.inc" -END PROCEDURE GetTril_1 -MODULE PROCEDURE GetTril_2 -#include "./Triag/GetTril1.inc" -END PROCEDURE GetTril_2 -MODULE PROCEDURE GetTril_3 -#include "./Triag/GetTril1.inc" -END PROCEDURE GetTril_3 -MODULE PROCEDURE GetTril_4 -#include "./Triag/GetTril1.inc" -END PROCEDURE GetTril_4 -MODULE PROCEDURE GetTril_5 -#include "./Triag/GetTril1.inc" -END PROCEDURE GetTril_5 -MODULE PROCEDURE GetTril_6 -#include "./Triag/GetTril1.inc" -END PROCEDURE GetTril_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTril_7 -#include "./Triag/GetTril2.inc" -END PROCEDURE GetTril_7 -MODULE PROCEDURE GetTril_8 -#include "./Triag/GetTril2.inc" -END PROCEDURE GetTril_8 -MODULE PROCEDURE GetTril_9 -#include "./Triag/GetTril2.inc" -END PROCEDURE GetTril_9 -MODULE PROCEDURE GetTril_10 -#include "./Triag/GetTril2.inc" -END PROCEDURE GetTril_10 -MODULE PROCEDURE GetTril_11 -#include "./Triag/GetTril2.inc" -END PROCEDURE GetTril_11 -MODULE PROCEDURE GetTril_12 -#include "./Triag/GetTril2.inc" -END PROCEDURE GetTril_12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTriu_1 -#include "./Triag/GetTriu1.inc" -END PROCEDURE GetTriu_1 -MODULE PROCEDURE GetTriu_2 -#include "./Triag/GetTriu1.inc" -END PROCEDURE GetTriu_2 -MODULE PROCEDURE GetTriu_3 -#include "./Triag/GetTriu1.inc" -END PROCEDURE GetTriu_3 -MODULE PROCEDURE GetTriu_4 -#include "./Triag/GetTriu1.inc" -END PROCEDURE GetTriu_4 -MODULE PROCEDURE GetTriu_5 -#include "./Triag/GetTriu1.inc" -END PROCEDURE GetTriu_5 -MODULE PROCEDURE GetTriu_6 -#include "./Triag/GetTriu1.inc" -END PROCEDURE GetTriu_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTriu_7 -#include "./Triag/GetTriu2.inc" -END PROCEDURE GetTriu_7 -MODULE PROCEDURE GetTriu_8 -#include "./Triag/GetTriu2.inc" -END PROCEDURE GetTriu_8 -MODULE PROCEDURE GetTriu_9 -#include "./Triag/GetTriu2.inc" -END PROCEDURE GetTriu_9 -MODULE PROCEDURE GetTriu_10 -#include "./Triag/GetTriu2.inc" -END PROCEDURE GetTriu_10 -MODULE PROCEDURE GetTriu_11 -#include "./Triag/GetTriu2.inc" -END PROCEDURE GetTriu_11 -MODULE PROCEDURE GetTriu_12 -#include "./Triag/GetTriu2.inc" -END PROCEDURE GetTriu_12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetTriu_1 -#include "./Triag/SetTriu1.inc" -END PROCEDURE SetTriu_1 -MODULE PROCEDURE SetTriu_2 -#include "./Triag/SetTriu1.inc" -END PROCEDURE SetTriu_2 -MODULE PROCEDURE SetTriu_3 -#include "./Triag/SetTriu1.inc" -END PROCEDURE SetTriu_3 -MODULE PROCEDURE SetTriu_4 -#include "./Triag/SetTriu1.inc" -END PROCEDURE SetTriu_4 -MODULE PROCEDURE SetTriu_5 -#include "./Triag/SetTriu1.inc" -END PROCEDURE SetTriu_5 -MODULE PROCEDURE SetTriu_6 -#include "./Triag/SetTriu1.inc" -END PROCEDURE SetTriu_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetTriu_7 -#include "./Triag/SetTriu2.inc" -END PROCEDURE SetTriu_7 -MODULE PROCEDURE SetTriu_8 -#include "./Triag/SetTriu2.inc" -END PROCEDURE SetTriu_8 -MODULE PROCEDURE SetTriu_9 -#include "./Triag/SetTriu2.inc" -END PROCEDURE SetTriu_9 -MODULE PROCEDURE SetTriu_10 -#include "./Triag/SetTriu2.inc" -END PROCEDURE SetTriu_10 -MODULE PROCEDURE SetTriu_11 -#include "./Triag/SetTriu2.inc" -END PROCEDURE SetTriu_11 -MODULE PROCEDURE SetTriu_12 -#include "./Triag/SetTriu2.inc" -END PROCEDURE SetTriu_12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetTriu_13 -#include "./Triag/SetTriu3.inc" -END PROCEDURE SetTriu_13 -MODULE PROCEDURE SetTriu_14 -#include "./Triag/SetTriu3.inc" -END PROCEDURE SetTriu_14 -MODULE PROCEDURE SetTriu_15 -#include "./Triag/SetTriu3.inc" -END PROCEDURE SetTriu_15 -MODULE PROCEDURE SetTriu_16 -#include "./Triag/SetTriu3.inc" -END PROCEDURE SetTriu_16 -MODULE PROCEDURE SetTriu_17 -#include "./Triag/SetTriu3.inc" -END PROCEDURE SetTriu_17 -MODULE PROCEDURE SetTriu_18 -#include "./Triag/SetTriu3.inc" -END PROCEDURE SetTriu_18 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetTril_1 -#include "./Triag/SetTril1.inc" -END PROCEDURE SetTril_1 -MODULE PROCEDURE SetTril_2 -#include "./Triag/SetTril1.inc" -END PROCEDURE SetTril_2 -MODULE PROCEDURE SetTril_3 -#include "./Triag/SetTril1.inc" -END PROCEDURE SetTril_3 -MODULE PROCEDURE SetTril_4 -#include "./Triag/SetTril1.inc" -END PROCEDURE SetTril_4 -MODULE PROCEDURE SetTril_5 -#include "./Triag/SetTril1.inc" -END PROCEDURE SetTril_5 -MODULE PROCEDURE SetTril_6 -#include "./Triag/SetTril1.inc" -END PROCEDURE SetTril_6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetTril_7 -#include "./Triag/SetTril2.inc" -END PROCEDURE SetTril_7 -MODULE PROCEDURE SetTril_8 -#include "./Triag/SetTril2.inc" -END PROCEDURE SetTril_8 -MODULE PROCEDURE SetTril_9 -#include "./Triag/SetTril2.inc" -END PROCEDURE SetTril_9 -MODULE PROCEDURE SetTril_10 -#include "./Triag/SetTril2.inc" -END PROCEDURE SetTril_10 -MODULE PROCEDURE SetTril_11 -#include "./Triag/SetTril2.inc" -END PROCEDURE SetTril_11 -MODULE PROCEDURE SetTril_12 -#include "./Triag/SetTril2.inc" -END PROCEDURE SetTril_12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE SetTril_13 -#include "./Triag/SetTril3.inc" -END PROCEDURE SetTril_13 -MODULE PROCEDURE SetTril_14 -#include "./Triag/SetTril3.inc" -END PROCEDURE SetTril_14 -MODULE PROCEDURE SetTril_15 -#include "./Triag/SetTril3.inc" -END PROCEDURE SetTril_15 -MODULE PROCEDURE SetTril_16 -#include "./Triag/SetTril3.inc" -END PROCEDURE SetTril_16 -MODULE PROCEDURE SetTril_17 -#include "./Triag/SetTril3.inc" -END PROCEDURE SetTril_17 -MODULE PROCEDURE SetTril_18 -#include "./Triag/SetTril3.inc" -END PROCEDURE SetTril_18 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ZerosUtility@Methods.F90 b/src/submodules/Utility/src/ZerosUtility@Methods.F90 deleted file mode 100644 index 7b9e1724b..000000000 --- a/src/submodules/Utility/src/ZerosUtility@Methods.F90 +++ /dev/null @@ -1,281 +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(ZerosUtility) Methods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_1 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_2 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_3 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_4 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- -#ifdef USE_Int128 -MODULE PROCEDURE Zeros_5 -ans = 0 -END PROCEDURE -#endif - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_6 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_7 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_8 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_9 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_10 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_11 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE Zeros_12 -ans = 0 -END PROCEDURE -#endif - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_13 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_14 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_15 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_16 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_17 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_18 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE Zeros_19 -ans = 0 -END PROCEDURE -#endif - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_20 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_21 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_22 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_23 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_24 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_25 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -#ifdef USE_Int128 -MODULE PROCEDURE Zeros_26 -ans = 0 -END PROCEDURE -#endif - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_27 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_28 -ans = 0 -END PROCEDURE - -!---------------------------------------------------------------------------- -! Zeros -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Zeros_29_Int8 -ans = 0_INT8 -END PROCEDURE Zeros_29_Int8 - -MODULE PROCEDURE Zeros_29_Int16 -ans = 0_INT16 -END PROCEDURE Zeros_29_Int16 - -MODULE PROCEDURE Zeros_29_Int32 -ans = 0_INT32 -END PROCEDURE Zeros_29_Int32 - -MODULE PROCEDURE Zeros_29_Int64 -ans = 0_INT64 -END PROCEDURE Zeros_29_Int64 - -MODULE PROCEDURE Zeros_29_Real32 -ans = 0.0_REAL32 -END PROCEDURE Zeros_29_Real32 - -MODULE PROCEDURE Zeros_29_Real64 -ans = 0.0_REAL64 -END PROCEDURE Zeros_29_Real64 - -END SUBMODULE Methods diff --git a/src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc b/src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc deleted file mode 100644 index c14367e25..000000000 --- a/src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc +++ /dev/null @@ -1,267 +0,0 @@ - -!---------------------------------------------------------------------------- -! EquidistanceLIP_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceLIP_Tetrahedron - !! -SELECT CASE (order) -CASE (1) - !! - !! tetra4 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0], [3, 4]) - !! -CASE (2) - !! - !! tetra10 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.5, 0.0, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.0, 0.5, & - & 0.0, 0.5, 0.5, & - & 0.5, 0.0, 0.5], [3, 10]) - !! -CASE (3) - !! - !! tetra20 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.0, 0.66666666666666666667, & - & 0.0, 0.0, 0.33333333333333333333, & - & 0.0, 0.33333333333333333333, 0.66666666666666666667, & - & 0.0, 0.66666666666666666667, 0.33333333333333333333, & - & 0.33333333333333333333, 0.0, 0.66666666666666666667, & - & 0.66666666666666666667, 0.0, 0.33333333333333333333, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.0, 0.33333333333333333333, & - & 0.0, 0.33333333333333333333, 0.33333333333333333333, & - & 0.33333333333333333333, 0.33333333333333333333, & - & 0.33333333333333333333], [3, 20]) - !! -CASE (4) - !! - !! tetra35 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.25, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.75, 0.0, 0.0, & - & 0.75, 0.25, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.25, 0.75, 0.0, & - & 0.0, 0.75, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.25, 0.0, & - & 0.0, 0.0, 0.75, & - & 0.0, 0.0, 0.5, & - & 0.0, 0.0, 0.25, & - & 0.0, 0.25, 0.75, & - & 0.0, 0.5, 0.5, & - & 0.0, 0.75, 0.25, & - & 0.25, 0.0, 0.75, & - & 0.5, 0.0, 0.5, & - & 0.75, 0.0, 0.25, & - & 0.25, 0.25, 0.0, & - & 0.25, 0.5, 0.0, & - & 0.5, 0.25, 0.0, & - & 0.25, 0.0, 0.25, & - & 0.5, 0.0, 0.25, & - & 0.25, 0.0, 0.5, & - & 0.0, 0.25, 0.25, & - & 0.0, 0.25, 0.5, & - & 0.0, 0.5, 0.25, & - & 0.25, 0.25, 0.5, & - & 0.5, 0.25, 0.25, & - & 0.25, 0.5, 0.25, & - & 0.25, 0.25, 0.25], [3, 35]) - !! -CASE (5) - !! - !! tetra56 - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.2, 0.0, 0.0, & - & 0.4, 0.0, 0.0, & - & 0.6, 0.0, 0.0, & - & 0.8, 0.0, 0.0, & - & 0.8, 0.2, 0.0, & - & 0.6, 0.4, 0.0, & - & 0.4, 0.6, 0.0, & - & 0.2, 0.8, 0.0, & - & 0.0, 0.8, 0.0, & - & 0.0, 0.6, 0.0, & - & 0.0, 0.4, 0.0, & - & 0.0, 0.2, 0.0, & - & 0.0, 0.0, 0.8, & - & 0.0, 0.0, 0.6, & - & 0.0, 0.0, 0.4, & - & 0.0, 0.0, 0.2, & - & 0.0, 0.2, 0.8, & - & 0.0, 0.4, 0.6, & - & 0.0, 0.6, 0.4, & - & 0.0, 0.8, 0.2, & - & 0.2, 0.0, 0.8, & - & 0.4, 0.0, 0.6, & - & 0.6, 0.0, 0.4, & - & 0.8, 0.0, 0.2, & - & 0.2, 0.2, 0.0, & - & 0.2, 0.6, 0.0, & - & 0.6, 0.2, 0.0, & - & 0.2, 0.4, 0.0, & - & 0.4, 0.4, 0.0, & - & 0.4, 0.2, 0.0, & - & 0.2, 0.0, 0.2, & - & 0.6, 0.0, 0.2, & - & 0.2, 0.0, 0.6, & - & 0.4, 0.0, 0.2, & - & 0.4, 0.0, 0.4, & - & 0.2, 0.0, 0.4, & - & 0.0, 0.2, 0.2, & - & 0.0, 0.2, 0.6, & - & 0.0, 0.6, 0.2, & - & 0.0, 0.2, 0.4, & - & 0.0, 0.4, 0.4, & - & 0.0, 0.4, 0.2, & - & 0.2, 0.2, 0.6, & - & 0.6, 0.2, 0.2, & - & 0.2, 0.6, 0.2, & - & 0.4, 0.2, 0.4, & - & 0.4, 0.4, 0.2, & - & 0.2, 0.4, 0.4, & - & 0.2, 0.2, 0.2, & - & 0.4, 0.2, 0.2, & - & 0.2, 0.4, 0.2, & - & 0.2, 0.2, 0.4], [3, 56]) - !! -CASE (6) - !! - !! - !! - nodecoord = reshape([ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.0, 0.0, 1.0, & - & 0.16666666666666666667, 0.0, 0.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.83333333333333333333, 0.0, 0.0, & - & 0.83333333333333333333, 0.16666666666666666667, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.16666666666666666667, 0.83333333333333333333, 0.0, & - & 0.0, 0.83333333333333333333, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.16666666666666666667, 0.0, & - & 0.0, 0.0, 0.83333333333333333333, & - & 0.0, 0.0, 0.66666666666666666667, & - & 0.0, 0.0, 0.5, & - & 0.0, 0.0, 0.33333333333333333333, & - & 0.0, 0.0, 0.16666666666666666667, & - & 0.0, 0.16666666666666666667, 0.83333333333333333333, & - & 0.0, 0.33333333333333333333, 0.66666666666666666667, & - & 0.0, 0.5, 0.5, & - & 0.0, 0.66666666666666666667, 0.33333333333333333333, & - & 0.0, 0.83333333333333333333, 0.16666666666666666667, & - & 0.16666666666666666667, 0.0, 0.83333333333333333333, & - & 0.33333333333333333333, 0.0, 0.66666666666666666667, & - & 0.5, 0.0, 0.5, & - & 0.66666666666666666667, 0.0, 0.33333333333333333333, & - & 0.83333333333333333333, 0.0, 0.16666666666666666667, & - & 0.16666666666666666667, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.66666666666666666667, 0.0, & - & 0.66666666666666666667, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.33333333333333333333, 0.0, & - & 0.16666666666666666667, 0.5, 0.0, & - & 0.33333333333333333333, 0.5, 0.0, & - & 0.5, 0.33333333333333333333, 0.0, & - & 0.5, 0.16666666666666666667, 0.0, & - & 0.33333333333333333333, 0.16666666666666666667, 0.0, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0, & - & 0.16666666666666666667, 0.0, 0.16666666666666666667, & - & 0.66666666666666666667, 0.0, 0.16666666666666666667, & - & 0.16666666666666666667, 0.0, 0.66666666666666666667, & - & 0.33333333333333333333, 0.0, 0.16666666666666666667, & - & 0.5, 0.0, 0.16666666666666666667, & - & 0.5, 0.0, 0.33333333333333333333, & - & 0.33333333333333333333, 0.0, 0.5, & - & 0.16666666666666666667, 0.0, 0.5, & - & 0.16666666666666666667, 0.0, 0.33333333333333333333, & - & 0.33333333333333333333, 0.0, 0.33333333333333333333, & - & 0.0, 0.16666666666666666667, 0.16666666666666666667, & - & 0.0, 0.16666666666666666667, 0.66666666666666666667, & - & 0.0, 0.66666666666666666667, 0.16666666666666666667, & - & 0.0, 0.16666666666666666667, 0.33333333333333333333, & - & 0.0, 0.16666666666666666667, 0.5, & - & 0.0, 0.33333333333333333333, 0.5, & - & 0.0, 0.5, 0.33333333333333333333, & - & 0.0, 0.5, 0.16666666666666666667, & - & 0.0, 0.33333333333333333333, 0.16666666666666666667, & - & 0.0, 0.33333333333333333333, 0.33333333333333333333, & - & 0.16666666666666666667, 0.16666666666666666667, & - & 0.66666666666666666667, & - & 0.66666666666666666667, 0.16666666666666666667, & - & 0.16666666666666666667, & - & 0.16666666666666666667, 0.66666666666666666667, & - & 0.16666666666666666667, & - & 0.33333333333333333333, 0.16666666666666666667, 0.5, & - & 0.5, 0.16666666666666666667, 0.33333333333333333333, & - & 0.5, 0.33333333333333333333, 0.16666666666666666667, & - & 0.33333333333333333333, 0.5, 0.16666666666666666667, & - & 0.16666666666666666667, 0.5, 0.33333333333333333333, & - & 0.16666666666666666667, 0.33333333333333333333, 0.5, & - & 0.33333333333333333333, 0.33333333333333333333, & - & 0.33333333333333333333, & - & 0.16666666666666666667, 0.16666666666666666667, & - & 0.16666666666666666667, & - & 0.5, 0.16666666666666666667, 0.16666666666666666667, & - & 0.16666666666666666667, 0.5, 0.16666666666666666667, & - & 0.16666666666666666667, 0.16666666666666666667, 0.5, & - & 0.33333333333333333333, 0.16666666666666666667, & - & 0.16666666666666666667, & - & 0.33333333333333333333, 0.33333333333333333333, & - & 0.16666666666666666667, & - & 0.16666666666666666667, 0.33333333333333333333, & - & 0.16666666666666666667, & - & 0.16666666666666666667, 0.16666666666666666667, & - & 0.33333333333333333333, & - & 0.16666666666666666667, 0.33333333333333333333, & - & 0.33333333333333333333, & - & 0.33333333333333333333, 0.16666666666666666667, & - & 0.33333333333333333333], [3, 84]) -END SELECT - !! -END PROCEDURE EquidistanceLIP_Tetrahedron diff --git a/src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc b/src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc deleted file mode 100644 index 8b5bb1a8d..000000000 --- a/src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc +++ /dev/null @@ -1,403 +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 PROCEDURE EquidistanceLIP_Triangle - !! - !! Define internal variables - !! - INTEGER( I4B ) :: i - REAL( DFP ) :: x( 3 ), y( 3 ) - REAL( DFP ), ALLOCATABLE :: xi( : ), eta( : ) - !! - !! - !! - SELECT CASE( Order ) - !! - CASE( 1 ) - !! - !! order 1; Triangle3 - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP], [3, 3] ) - !! - CASE( 2 ) - !! - !! order 2, Triangle6 - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.5_DFP, 0.0_DFP, 0.0_DFP, & - & 0.5_DFP, 0.5_DFP, 0.0_DFP, & - & 0.0_DFP, 0.5_DFP, 0.0_DFP ], & - & [3, 6]) - !! - CASE( 3 ) - !! - !! order 3, Triangle10 - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.33333333333333333333_DFP, 0.0_DFP, 0.0_DFP, & - & 0.66666666666666666667_DFP, 0.0_DFP, 0.0_DFP, & - & 0.66666666666666666667_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & - & 0.33333333333333333333_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & - & 0.0_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & - & 0.0_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & - & 0.33333333333333333333_DFP, 0.33333333333333333333_DFP, 0.0_DFP], & - & [3, 10]) - !! - CASE( 4 ) - !! - !! order 4 Includes bubble nodes also - !! Trianagle15a - !! - nodecoord = RESHAPE( [ & - & 0.0_DFP, 0.0_DFP, 0.0_DFP, & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.25_DFP, 0.0_DFP, 0.0_DFP, & - & 0.5_DFP, 0.0_DFP, 0.0_DFP, & - & 0.75_DFP, 0.0_DFP, 0.0_DFP, & - & 0.75_DFP, 0.25_DFP, 0.0_DFP, & - & 0.5_DFP, 0.5_DFP, 0.0_DFP, & - & 0.25_DFP, 0.75_DFP, 0.0_DFP, & - & 0.0_DFP, 0.75_DFP, 0.0_DFP, & - & 0.0_DFP, 0.5_DFP, 0.0_DFP, & - & 0.0_DFP, 0.25_DFP, 0.0_DFP, & - & 0.25_DFP, 0.25_DFP, 0.0_DFP, & - & 0.5_DFP, 0.25_DFP, 0.0_DFP, & - & 0.25_DFP, 0.5_DFP, 0.0_DFP], & - & [3, 15]) - !! - CASE( 5 ) - !! - !! This is fifth order triangle - !! 3 nodes on vertex, 12 nodes on edge, and 6 on the face - !! Triangle21 - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.2, 0.0, 0.0, & - & 0.4, 0.0, 0.0, & - & 0.6, 0.0, 0.0, & - & 0.8, 0.0, 0.0, & - & 0.8, 0.2, 0.0, & - & 0.6, 0.4, 0.0, & - & 0.4, 0.6, 0.0, & - & 0.2, 0.8, 0.0, & - & 0.0, 0.8, 0.0, & - & 0.0, 0.6, 0.0, & - & 0.0, 0.4, 0.0, & - & 0.0, 0.2, 0.0, & - & 0.2, 0.2, 0.0, & - & 0.6, 0.2, 0.0, & - & 0.2, 0.6, 0.0, & - & 0.4, 0.2, 0.0, & - & 0.4, 0.4, 0.0, & - & 0.2, 0.4, 0.0], [3, 21]) - !! - CASE( 6 ) - !! - !! Triangle28 - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.16666666666666666667, 0.0, 0.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.83333333333333333333, 0.0, 0.0, & - & 0.83333333333333333333, 0.16666666666666666667, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.16666666666666666667, 0.83333333333333333333, 0.0, & - & 0.0, 0.83333333333333333333, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.16666666666666666667, 0.0, & - & 0.66666666666666666667, 0.16666666666666666667, 0.0, & - & 0.16666666666666666667, 0.66666666666666666667, 0.0, & - & 0.33333333333333333333, 0.16666666666666666667, 0.0, & - & 0.5, 0.16666666666666666667, 0.0, & - & 0.5, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.5, 0.0, & - & 0.16666666666666666667, 0.5, 0.0, & - & 0.16666666666666666667, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0], [3, 28] ) - !! - CASE( 7 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.14285714285714285714, 0.0, 0.0, & - & 0.28571428571428571429, 0.0, 0.0, & - & 0.42857142857142857143, 0.0, 0.0, & - & 0.57142857142857142857, 0.0, 0.0, & - & 0.71428571428571428571, 0.0, 0.0, & - & 0.85714285714285714286, 0.0, 0.0, & - & 0.85714285714285714286, 0.14285714285714285714, 0.0, & - & 0.71428571428571428571, 0.28571428571428571429, 0.0, & - & 0.57142857142857142857, 0.42857142857142857143, 0.0, & - & 0.42857142857142857143, 0.57142857142857142857, 0.0, & - & 0.28571428571428571429, 0.71428571428571428571, 0.0, & - & 0.14285714285714285714, 0.85714285714285714286, 0.0, & - & 0.0, 0.85714285714285714286, 0.0, & - & 0.0, 0.71428571428571428571, 0.0, & - & 0.0, 0.57142857142857142857, 0.0, & - & 0.0, 0.42857142857142857143, 0.0, & - & 0.0, 0.28571428571428571429, 0.0, & - & 0.0, 0.14285714285714285714, 0.0, & - & 0.14285714285714285714, 0.14285714285714285714, 0.0, & - & 0.71428571428571428571, 0.14285714285714285714, 0.0, & - & 0.14285714285714285714, 0.71428571428571428571, 0.0, & - & 0.28571428571428571429, 0.14285714285714285714, 0.0, & - & 0.42857142857142857143, 0.14285714285714285714, 0.0, & - & 0.57142857142857142857, 0.14285714285714285714, 0.0, & - & 0.57142857142857142857, 0.28571428571428571429, 0.0, & - & 0.42857142857142857143, 0.42857142857142857143, 0.0, & - & 0.28571428571428571429, 0.57142857142857142857, 0.0, & - & 0.14285714285714285714, 0.57142857142857142857, 0.0, & - & 0.14285714285714285714, 0.42857142857142857143, 0.0, & - & 0.14285714285714285714, 0.28571428571428571429, 0.0, & - & 0.28571428571428571429, 0.28571428571428571429, 0.0, & - & 0.42857142857142857143, 0.28571428571428571429, 0.0, & - & 0.28571428571428571429, 0.42857142857142857143, 0.0 ], [3,36]) - !! - CASE( 8 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.125, 0.0, 0.0, & - & 0.25, 0.0, 0.0, & - & 0.375, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.625, 0.0, 0.0, & - & 0.75, 0.0, 0.0, & - & 0.875, 0.0, 0.0, & - & 0.875, 0.125, 0.0, & - & 0.75, 0.25, 0.0, & - & 0.625, 0.375, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.375, 0.625, 0.0, & - & 0.25, 0.75, 0.0, & - & 0.125, 0.875, 0.0, & - & 0.0, 0.875, 0.0, & - & 0.0, 0.75, 0.0, & - & 0.0, 0.625, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.375, 0.0, & - & 0.0, 0.25, 0.0, & - & 0.0, 0.125, 0.0, & - & 0.125, 0.125, 0.0, & - & 0.75, 0.125, 0.0, & - & 0.125, 0.75, 0.0, & - & 0.25, 0.125, 0.0, & - & 0.375, 0.125, 0.0, & - & 0.5, 0.125, 0.0, & - & 0.625, 0.125, 0.0, & - & 0.625, 0.25, 0.0, & - & 0.5, 0.375, 0.0, & - & 0.375, 0.5, 0.0, & - & 0.25, 0.625, 0.0, & - & 0.125, 0.625, 0.0, & - & 0.125, 0.5, 0.0, & - & 0.125, 0.375, 0.0, & - & 0.125, 0.25, 0.0, & - & 0.25, 0.25, 0.0, & - & 0.5, 0.25, 0.0, & - & 0.25, 0.5, 0.0, & - & 0.375, 0.25, 0.0, & - & 0.375, 0.375, 0.0, & - & 0.25, 0.375, 0.0 ], [3, 45]) - !! - CASE( 9 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.11111111111111111111, 0.0, 0.0, & - & 0.22222222222222222222, 0.0, 0.0, & - & 0.33333333333333333333, 0.0, 0.0, & - & 0.44444444444444444444, 0.0, 0.0, & - & 0.55555555555555555556, 0.0, 0.0, & - & 0.66666666666666666667, 0.0, 0.0, & - & 0.77777777777777777778, 0.0, 0.0, & - & 0.88888888888888888889, 0.0, 0.0, & - & 0.88888888888888888889, 0.11111111111111111111, 0.0, & - & 0.77777777777777777778, 0.22222222222222222222, 0.0, & - & 0.66666666666666666667, 0.33333333333333333333, 0.0, & - & 0.55555555555555555556, 0.44444444444444444444, 0.0, & - & 0.44444444444444444444, 0.55555555555555555556, 0.0, & - & 0.33333333333333333333, 0.66666666666666666667, 0.0, & - & 0.22222222222222222222, 0.77777777777777777778, 0.0, & - & 0.11111111111111111111, 0.88888888888888888889, 0.0, & - & 0.0, 0.88888888888888888889, 0.0, & - & 0.0, 0.77777777777777777778, 0.0, & - & 0.0, 0.66666666666666666667, 0.0, & - & 0.0, 0.55555555555555555556, 0.0, & - & 0.0, 0.44444444444444444444, 0.0, & - & 0.0, 0.33333333333333333333, 0.0, & - & 0.0, 0.22222222222222222222, 0.0, & - & 0.0, 0.11111111111111111111, 0.0, & - & 0.11111111111111111111, 0.11111111111111111111, 0.0, & - & 0.77777777777777777778, 0.11111111111111111111, 0.0, & - & 0.11111111111111111111, 0.77777777777777777778, 0.0, & - & 0.22222222222222222222, 0.11111111111111111111, 0.0, & - & 0.33333333333333333333, 0.11111111111111111111, 0.0, & - & 0.44444444444444444444, 0.11111111111111111111, 0.0, & - & 0.55555555555555555556, 0.11111111111111111111, 0.0, & - & 0.66666666666666666667, 0.11111111111111111111, 0.0, & - & 0.66666666666666666667, 0.22222222222222222222, 0.0, & - & 0.55555555555555555556, 0.33333333333333333333, 0.0, & - & 0.44444444444444444444, 0.44444444444444444444, 0.0, & - & 0.33333333333333333333, 0.55555555555555555556, 0.0, & - & 0.22222222222222222222, 0.66666666666666666667, 0.0, & - & 0.11111111111111111111, 0.66666666666666666667, 0.0, & - & 0.11111111111111111111, 0.55555555555555555556, 0.0, & - & 0.11111111111111111111, 0.44444444444444444444, 0.0, & - & 0.11111111111111111111, 0.33333333333333333333, 0.0, & - & 0.11111111111111111111, 0.22222222222222222222, 0.0, & - & 0.22222222222222222222, 0.22222222222222222222, 0.0, & - & 0.55555555555555555556, 0.22222222222222222222, 0.0, & - & 0.22222222222222222222, 0.55555555555555555556, 0.0, & - & 0.33333333333333333333, 0.22222222222222222222, 0.0, & - & 0.44444444444444444444, 0.22222222222222222222, 0.0, & - & 0.44444444444444444444, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.44444444444444444444, 0.0, & - & 0.22222222222222222222, 0.44444444444444444444, 0.0, & - & 0.22222222222222222222, 0.33333333333333333333, 0.0, & - & 0.33333333333333333333, 0.33333333333333333333, 0.0 ], [3,55] ) - !! - CASE( 10 ) - !! - !! - !! - nodecoord = RESHAPE( [ & - & 0.0, 0.0, 0.0, & - & 1.0, 0.0, 0.0, & - & 0.0, 1.0, 0.0, & - & 0.1, 0.0, 0.0, & - & 0.2, 0.0, 0.0, & - & 0.3, 0.0, 0.0, & - & 0.4, 0.0, 0.0, & - & 0.5, 0.0, 0.0, & - & 0.6, 0.0, 0.0, & - & 0.7, 0.0, 0.0, & - & 0.8, 0.0, 0.0, & - & 0.9, 0.0, 0.0, & - & 0.9, 0.1, 0.0, & - & 0.8, 0.2, 0.0, & - & 0.7, 0.3, 0.0, & - & 0.6, 0.4, 0.0, & - & 0.5, 0.5, 0.0, & - & 0.4, 0.6, 0.0, & - & 0.3, 0.7, 0.0, & - & 0.2, 0.8, 0.0, & - & 0.1, 0.9, 0.0, & - & 0.0, 0.9, 0.0, & - & 0.0, 0.8, 0.0, & - & 0.0, 0.7, 0.0, & - & 0.0, 0.6, 0.0, & - & 0.0, 0.5, 0.0, & - & 0.0, 0.4, 0.0, & - & 0.0, 0.3, 0.0, & - & 0.0, 0.2, 0.0, & - & 0.0, 0.1, 0.0, & - & 0.1, 0.1, 0.0, & - & 0.8, 0.1, 0.0, & - & 0.1, 0.8, 0.0, & - & 0.2, 0.1, 0.0, & - & 0.3, 0.1, 0.0, & - & 0.4, 0.1, 0.0, & - & 0.5, 0.1, 0.0, & - & 0.6, 0.1, 0.0, & - & 0.7, 0.1, 0.0, & - & 0.7, 0.2, 0.0, & - & 0.6, 0.3, 0.0, & - & 0.5, 0.4, 0.0, & - & 0.4, 0.5, 0.0, & - & 0.3, 0.6, 0.0, & - & 0.2, 0.7, 0.0, & - & 0.1, 0.7, 0.0, & - & 0.1, 0.6, 0.0, & - & 0.1, 0.5, 0.0, & - & 0.1, 0.4, 0.0, & - & 0.1, 0.3, 0.0, & - & 0.1, 0.2, 0.0, & - & 0.2, 0.2, 0.0, & - & 0.6, 0.2, 0.0, & - & 0.2, 0.6, 0.0, & - & 0.3, 0.2, 0.0, & - & 0.4, 0.2, 0.0, & - & 0.5, 0.2, 0.0, & - & 0.5, 0.3, 0.0, & - & 0.4, 0.4, 0.0, & - & 0.3, 0.5, 0.0, & - & 0.2, 0.5, 0.0, & - & 0.2, 0.4, 0.0, & - & 0.2, 0.3, 0.0, & - & 0.3, 0.3, 0.0, & - & 0.4, 0.3, 0.0, & - & 0.3, 0.4, 0.0 ], [3,66] ) - END SELECT - !! - !! - !! - IF( PRESENT( xij ) ) THEN - !! - ALLOCATE( xi( SIZE( nodecoord, 2 ) ), eta( SIZE( nodecoord, 2 ) ) ) - xi( : ) = nodecoord( 1, : ) - eta( : ) = nodecoord( 2, : ) - !! - x = xij( 1, 1:3 ) - y = xij( 2, 1:3 ) - !! - nodecoord( 1, : ) = x( 1 ) + ( x( 2 ) - x( 1 ) ) * xi & - & + ( x( 3 ) - x( 1 ) ) * eta - !! - nodecoord( 2, : ) = y( 1 ) + ( y( 2 ) - y( 1 ) ) * xi & - & + ( y( 3 ) - y( 1 ) ) * eta - !! - DEALLOCATE( xi, eta ) - !! - END IF - !! -END PROCEDURE EquidistanceLIP_Triangle \ No newline at end of file diff --git a/src/submodules/Vector/ToDo/VectorOperations.part b/src/submodules/Vector/ToDo/VectorOperations.part deleted file mode 100755 index 85b1036af..000000000 --- a/src/submodules/Vector/ToDo/VectorOperations.part +++ /dev/null @@ -1,366 +0,0 @@ -! -!------------------------------------------------------------------------------ -! Author : Vikas sharma -! Position : Doctral Student -! Institute : Kyoto Univeristy, Japan -! Program name: VectorOperations.part -! Last Update : September-06-2017 -! -!------------------------------------------------------------------------------ -! Details of Program -!============================================================================== -! -! Type:: Part of module -! -! Info:: - This contains some vector operations - -! Hosting File - -! -!============================================================================== - -!------------------------------------------------------------------------------ -! VectorProduct2 -!------------------------------------------------------------------------------ - - FUNCTION VectorProduct2( u, v ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Vector product; u x v -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v - REAL( DFP ), DIMENSION( 3 ) :: VectorProduct2 - - ! Define internal variables - INTEGER( I4B ) :: N - - - Error_Flag = .FALSE. - - IF( SIZE( u ) .NE. SIZE( v ) ) THEN - - CALL Err_Msg( & - "Tensor_Class.F90>>VectorOperations.part", & - "VectorProduct( u, v )", & - "The size of u and v must be same; & - & it should be either 2 or 3; PROGRAM STOPPED!!") - Error_Flag = .TRUE. - STOP - - END IF - - N = SIZE( u ) - - SELECT CASE( N ) - - CASE( 3 ) - - VectorProduct2( 1 ) = U( 2 ) * V( 3 ) - U( 3 ) * V( 2 ) - VectorProduct2( 2 ) = U( 3 ) * V( 1 ) - U( 1 ) * V( 3 ) - VectorProduct2( 3 ) = U( 1 ) * V( 2 ) - U( 2 ) * V( 1 ) - - CASE( 2 ) - - VectorProduct2( 1 ) = 0.0_DFP - VectorProduct2( 2 ) = 0.0_DFP - VectorProduct2( 3 ) = U( 1 ) * V( 2 ) - U( 2 ) * V( 1 ) - - CASE DEFAULT - - CALL Err_Msg( & - "Tensor_Class.F90>>VectorOperations.part", & - "VectorProduct()", & - "No case found for the size of u and v; & - & it should be either 2 or 3; PROGRAM STOPPED!!") - Error_Flag = .TRUE. - STOP - - END SELECT - - END FUNCTION VectorProduct2 - -!------------------------------------------------------------------------------ -! VectorProduct3 -!------------------------------------------------------------------------------ - - FUNCTION VectorProduct3( u, v, w ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Triple Vector product u x ( v x w ) -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY: Assert_Eq - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w - REAL( DFP ), DIMENSION( 3 ) :: VectorProduct3 - - ! Define internal variables - INTEGER( I4B ) :: N - - - Error_Flag = .FALSE. - - VectorProduct3 = DOT_PRODUCT( u, w ) * v - DOT_PRODUCT( u, v ) * w - - END FUNCTION VectorProduct3 - -!------------------------------------------------------------------------------ -! BoxProduct -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION BoxProduct( u, v, w ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Triple Scalar product u.( v x w ) = [u,v,w] = [v,w,u] = [w,u,v] -! -!. . . . . . . . . . . . . . . . . . . . - - USE Utility, ONLY: Det - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w - - ! Define internal variables - REAL( DFP ), DIMENSION( 3, 3 ) :: DummyMat - Error_Flag = .FALSE. - - DummyMat = RESHAPE((/u(1), v(1), w(1),& - u(2), v(2), w(2),& - u(3), v(3), w(3)/),(/3,3/)) - - BoxProduct = Det( DummyMat ) - - END FUNCTION BoxProduct - -!------------------------------------------------------------------------------ -! getAngle -!------------------------------------------------------------------------------ - - REAL( DFP ) FUNCTION getAngle( u, v ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. Returns the angle between two vectors -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v - - ! Define internal variables - REAL( DFP ) :: Norm_u, Norm_v, CosTheta - - Norm_u = SQRT( DOT_PRODUCT( u, u ) ) - Norm_v = SQRT( DOT_PRODUCT( v, v ) ) - - IF( Norm_u .EQ. 0.0_DFP .OR. Norm_v .EQ. 0.0_DFP ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>VectorOperations.part", & - "getAngle()", & - "Either u or v is/are zero, Angle Not Defined, Program Stopped!") - STOP - - END IF - - CosTheta = DOT_PRODUCT( u, v ) / Norm_u / Norm_v - - getAngle = ACOS( CosTheta ) - - END FUNCTION getAngle - -!------------------------------------------------------------------------------ -! getProjection -!------------------------------------------------------------------------------ - - FUNCTION getProjection( u, v ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. project u on v and return the projection vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v - REAL( DFP ), DIMENSION( SIZE( u ) ) :: getProjection - - ! Define internal variables - REAL( DFP ) :: Norm_u, Norm_v, CosTheta - - Norm_u = SQRT( DOT_PRODUCT( u, u ) ) - Norm_v = SQRT( DOT_PRODUCT( v, v ) ) - - IF( Norm_u .EQ. 0.0_DFP .OR. Norm_v .EQ. 0.0_DFP ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>VectorOperations.part", & - "getProjection()", & - "Either u or v is/are zero, projection is not defined, & - Program Stopped!") - STOP - - END IF - - CosTheta = DOT_PRODUCT( u, v ) / Norm_u / Norm_v - - getProjection = ( Norm_u * CosTheta / Norm_v ) * v - - END FUNCTION getProjection - -!------------------------------------------------------------------------------ -! UnitVector -!------------------------------------------------------------------------------ - - FUNCTION UnitVector( u ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. - returns unit vector -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( SIZE( u ) ) :: UnitVector - - ! Define internal variables - REAL( DFP ) :: Norm_u - - Norm_u = SQRT( DOT_PRODUCT( u, u ) ) - - IF( Norm_u .EQ. 0.0_DFP ) THEN - - CALL Err_Msg( & - "Rank2Tensor_Class.F90>>VectorOperations.part", & - "UnitVector()", & - "U vector is zero, projection is not defined, & - Program Stopped!") - STOP - - END IF - - UnitVector = ( 1.0_DFP / Norm_u ) * u - - END FUNCTION UnitVector - -!------------------------------------------------------------------------------ -! DotProduct -!------------------------------------------------------------------------------ - - FUNCTION DotProduct( u, v ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. returns u.v -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v - REAL( DFP ) :: DotProduct - - DotProduct = DOT_PRODUCT( u, v) - - END FUNCTION DotProduct - -!------------------------------------------------------------------------------ -! getNormalComponent -!------------------------------------------------------------------------------ - - FUNCTION getNormalComponent( u, v ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. returns component of u that is normal to v -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v - REAL( DFP ), DIMENSION( SIZE( u ) ) :: getNormalComponent - - getNormalComponent = u - ( u .ProjectOn. v ) - - END FUNCTION getNormalComponent - -!------------------------------------------------------------------------------ -! Vector2D -!------------------------------------------------------------------------------ - - FUNCTION Vector2D( u ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. converts any vector in 2D vector format. -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( 2 ) :: Vector2D - - - Vector2D = 0.0_DFP - SELECT CASE( SIZE( U ) ) - - CASE( 1 ) - - Vector2D( 1 ) = U( 1 ) - - CASE DEFAULT - - Vector2D( 1: 2 ) = U( 1: 2 ) - - END SELECT - - END FUNCTION Vector2D - -!------------------------------------------------------------------------------ -! Vector3D -!------------------------------------------------------------------------------ - - FUNCTION Vector3D( u ) - -!. . . . . . . . . . . . . . . . . . . . -! 1. converts any vector in 3D vector format. -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( 3 ) :: Vector3D - - - Vector3D = 0.0_DFP - - SELECT CASE( SIZE( u ) ) - - CASE( 1 ) - - Vector3D( 1 ) = u( 1 ) - - CASE( 2 ) - - Vector3D( 1 : 2 ) = u( 1 : 2 ) - - CASE DEFAULT - - Vector3D( 1: 3 ) = u( 1 : 3 ) - - END SELECT - - END FUNCTION Vector3D - -!------------------------------------------------------------------------------ -! Vector1D -!------------------------------------------------------------------------------ - - FUNCTION Vector1D( u ) - - -!. . . . . . . . . . . . . . . . . . . . -! 1. converts any vector in 1D vector format. -!. . . . . . . . . . . . . . . . . . . . - - ! Define Intent of dummy variables - REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u - REAL( DFP ), DIMENSION( 1 ) :: Vector1D - - Vector1D( 1 ) = u( 1 ) - - END FUNCTION Vector1D - -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ - diff --git a/src/submodules/Vector3D/CMakeLists.txt b/src/submodules/Vector3D/CMakeLists.txt deleted file mode 100644 index 41e532c3d..000000000 --- a/src/submodules/Vector3D/CMakeLists.txt +++ /dev/null @@ -1,14 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 23/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/Vector3D_Method@Constructor.F90 - ${src_path}/Vector3D_Method@Misc.F90 -) \ No newline at end of file diff --git a/src/submodules/Vector3D/Vector3D_Method@Misc.F90 b/src/submodules/Vector3D/Vector3D_Method@Misc.F90 deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 b/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 deleted file mode 100644 index 9333de0b8..000000000 --- a/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 +++ /dev/null @@ -1,143 +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: 24 Feb 2021 -! summary: This submodule contains the implementation of construction relted methods defined inside [[Vector3D_Method]] module. -! - -SUBMODULE(Vector3D_Method) Constructor -USE BaseMethod -IMPLICIT NONE -CONTAINS - - -!---------------------------------------------------------------------------- -! SHAPE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_shape - Ans = 3_I4B -END PROCEDURE get_shape - -!---------------------------------------------------------------------------- -! SIZE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_size - Ans = 3_I4B -END PROCEDURE get_size - -!---------------------------------------------------------------------------- -! getTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Vec3D_getTotalDimension - ans = obj%tDimension -END PROCEDURE Vec3D_getTotalDimension - -!---------------------------------------------------------------------------- -! setTotalDimension -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Vec3D_setTotalDimension - obj%tDimension = tDimension -END PROCEDURE Vec3D_setTotalDimension - -!---------------------------------------------------------------------------- -! ALLOCATE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE allocate_data - obj%Val=0.0_DFP - CALL setTotalDimension( obj, 1_I4B ) -END PROCEDURE allocate_data - -!---------------------------------------------------------------------------- -! DEALLOCATE -!---------------------------------------------------------------------------- - -MODULE PROCEDURE deallocate_data - obj%Val=0.0_DFP - CALL setTotalDimension( obj, 1_I4B ) -END PROCEDURE deallocate_data - - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE initiate_obj_from_val - SELECT CASE( SIZE( Val ) ) - CASE( 1 ) - obj%Val(1) = Val(1) - obj%Val(2) = 0.0_DFP - obj%Val(3) = 0.0_DFP - CASE( 2 ) - obj%Val(1) = Val(1) - obj%Val(2) = Val(2) - obj%Val(3) = 0.0_DFP - CASE DEFAULT - obj%Val = Val( 1:3 ) - END SELECT -END PROCEDURE initiate_obj_from_val - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE initiate_obj_from_obj - obj%Val = Anotherobj%Val -END PROCEDURE initiate_obj_from_obj - -!---------------------------------------------------------------------------- -! Vector3D -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor1 - Ans = Val -END PROCEDURE Constructor1 - -!---------------------------------------------------------------------------- -! Vector3D_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor_1 - ALLOCATE( Ans ) - CALL Initiate(obj=Ans, Val=Val) -END PROCEDURE Constructor_1 - -!---------------------------------------------------------------------------- -! Vector3D_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Constructor_2 - ALLOCATE( Ans ) - CALL Initiate( obj=Ans, Anotherobj=obj ) -END PROCEDURE Constructor_2 - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Display_obj - INTEGER( I4B ) :: i - i = Input(default=stdout, option=unitNo) - CALL Display( Val=obj%Val, msg=msg, UnitNo = i) -END PROCEDURE Display_obj - -END SUBMODULE Constructor diff --git a/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 b/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 deleted file mode 100644 index 5bfa06525..000000000 --- a/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 +++ /dev/null @@ -1,152 +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: 24 Feb 2021 -! summary: This submodule implements the methods of [[Vector3D_]] which are defined in [[Vector3D_Method]] module. - -SUBMODULE(Vector3D_Method) Misc -USE BaseMethod -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! DOT_PRODUCT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dot_product_1 - Ans = DOT_PRODUCT( obj1%Val, obj2%Val ) -END PROCEDURE dot_product_1 - -!---------------------------------------------------------------------------- -! DOT_PRODUCT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dot_product_2 - IF( SIZE( Val ) .LT. 3 ) THEN - Ans = DOT_PRODUCT( obj, Vector3D( Val ) ) - ELSE - Ans = DOT_PRODUCT( obj%Val, Val(1:3) ) - END IF -END PROCEDURE dot_product_2 - -!---------------------------------------------------------------------------- -! DOT_PRODUCT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dot_product_3 - Ans = DOT_PRODUCT(obj=obj, Val=Val) -END PROCEDURE dot_product_3 - -!---------------------------------------------------------------------------- -! DOT_PRODUCT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE dot_product_4 - Ans = DOT_PRODUCT(VECTOR_PRODUCT(v, w), u) -END PROCEDURE dot_product_4 - -!---------------------------------------------------------------------------- -! Vector_Product -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_product_1 - Ans = Vector_Product(obj1%val, obj2%val) -END PROCEDURE vector_product_1 - -!---------------------------------------------------------------------------- -! Vector_Product -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_product_2 - IF( SIZE( Val ) .LT. 3 ) THEN - Ans = VECTOR_PRODUCT( obj, Vector3D( Val ) ) - ELSE - Ans = VECTOR_PRODUCT( obj%Val, Val(1:3) ) - END IF -END PROCEDURE vector_product_2 - -!---------------------------------------------------------------------------- -! Vector_Product -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_product_3 - Ans = VECTOR_PRODUCT(obj=obj, Val=Val) -END PROCEDURE vector_product_3 - -!---------------------------------------------------------------------------- -! Vector_Product -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_product_4 - Ans = DOT_PRODUCT( u%val, w%val ) * v%val- DOT_PRODUCT( u%val, v%val ) * w%val -END PROCEDURE vector_product_4 - -!---------------------------------------------------------------------------- -! Norm2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Norm2_obj - Ans = SQRT( DOT_PRODUCT( obj%Val, obj%Val ) ) -END PROCEDURE Norm2_obj - -!---------------------------------------------------------------------------- -! UnitVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_UnitVector - Ans = obj%Val / NORM2( obj%Val ) -END PROCEDURE get_UnitVector - -!---------------------------------------------------------------------------- -! Angle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_angle - Ans = ACOS( DOT_PRODUCT( u, v ) / NORM2(u) / NORM2(v) ) -END PROCEDURE get_angle - -!---------------------------------------------------------------------------- -! ProjectionVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_projection_vector_obj - Ans = (DOT_PRODUCT( u, v ) / DOT_PRODUCT( v, v )) * v%val -END PROCEDURE get_projection_vector_obj - -!---------------------------------------------------------------------------- -! Normal -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getNormal_Vector - Ans = u%val - (DOT_PRODUCT( u, v ) / DOT_PRODUCT( v, v )) * v%val -END PROCEDURE getNormal_Vector - -!---------------------------------------------------------------------------- -! Projection -!---------------------------------------------------------------------------- - -MODULE PROCEDURE get_projection_obj - Ans = DOT_PRODUCT( u, v ) / NORM2( v ) -END PROCEDURE get_projection_obj - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Misc \ No newline at end of file diff --git a/src/submodules/VoigtRank2Tensor/CMakeLists.txt b/src/submodules/VoigtRank2Tensor/CMakeLists.txt deleted file mode 100644 index 7353ba725..000000000 --- a/src/submodules/VoigtRank2Tensor/CMakeLists.txt +++ /dev/null @@ -1,14 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 23/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/VoigtRank2Tensor_Method@Constructor.F90 - ${src_path}/VoigtRank2Tensor_Method@IO.F90 -) diff --git a/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 b/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 deleted file mode 100644 index f715326d6..000000000 --- a/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 +++ /dev/null @@ -1,125 +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(VoigtRank2Tensor_Method) Constructor -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE init_from_vec -ASSOCIATE( V => obj%V, Scale => obj%Scale ) - V = 0.0_DFP - obj%VoigtType = VoigtType - V( 1:6 ) = Vec( 1:6 ) - SELECT CASE( VoigtType ) - CASE( StrainTypeVoigt ) - Scale = 0.5_DFP - CASE( StressTypeVoigt ) - Scale = 1.0_DFP - END SELECT -END ASSOCIATE -END PROCEDURE init_from_vec - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE init_from_mat -ASSOCIATE( V => obj%V, Scale => obj%Scale ) - obj%VoigtType = VoigtType - V( 1 ) = T( 1, 1 ) - V( 2 ) = T( 2, 2 ) - V( 3 ) = T( 3, 3 ) - V( 4 ) = T( 1, 2 ) + T( 2, 1 ) - V( 5 ) = T( 2, 3 ) + T( 3, 2 ) - V( 6 ) = T( 1, 3 ) + T( 3, 1 ) - SELECT CASE( VoigtType ) - CASE( StressTypeVoigt ) - Scale = 1.0_DFP - V( 4 : 6 ) = 0.5_DFP * V( 4 : 6 ) - CASE( StrainTypeVoigt ) - Scale = 0.5_DFP - END SELECT -END ASSOCIATE -END PROCEDURE init_from_mat - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor -!---------------------------------------------------------------------------- - -MODULE PROCEDURE constructor1 - CALL Initiate( Ans, Vec, VoigtType ) -END PROCEDURE constructor1 - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor -!---------------------------------------------------------------------------- - -MODULE PROCEDURE constructor2 - CALL Initiate( obj=Ans, T=T, VoigtType=VoigtType ) -END PROCEDURE constructor2 - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE constructor_1 - ALLOCATE( Ans ) - CALL Initiate( obj=Ans, Vec=Vec, VoigtType = VoigtType ) -END PROCEDURE constructor_1 - -!---------------------------------------------------------------------------- -! VoigtRank2Tensor_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE constructor_2 - ALLOCATE( Ans ) - CALL Initiate( obj=Ans, T=T, VoigtType=VoigtType ) -END PROCEDURE constructor_2 - -!---------------------------------------------------------------------------- -! Assignment -!---------------------------------------------------------------------------- - -MODULE PROCEDURE mat_eq_obj - ASSOCIATE( V => obj%V, Scale => obj%Scale ) - T = 0.0_DFP - T( 1, 1 ) = V( 1 ) - T( 2, 2 ) = V( 2 ) - T( 3, 3 ) = V( 3 ) - T( 1, 2 ) = Scale * V( 4 ) - T( 2, 1 ) = T( 1, 2 ) - T( 2, 3 ) = Scale * V( 5 ) - T( 3, 2 ) = T( 2, 3 ) - T( 1, 3 ) = Scale * V( 6 ) - T( 3, 1 ) = T( 1, 3 ) - END ASSOCIATE -END PROCEDURE mat_eq_obj - -!---------------------------------------------------------------------------- -! Assignment -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vec_eq_obj - vec = obj%V -END PROCEDURE vec_eq_obj - -END SUBMODULE Constructor diff --git a/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 b/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 deleted file mode 100644 index 39c2df052..000000000 --- a/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 +++ /dev/null @@ -1,42 +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(VoigtRank2Tensor_Method) IO -Use BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! Display -!---------------------------------------------------------------------------- - -MODULE PROCEDURE display_obj - INTEGER( I4B ) :: I, j - ASSOCIATE( V => obj%V ) - I = INPUT( option=UnitNo, Default=StdOut ) - WRITE( I, "(A)" ) "# " // TRIM( Msg ) - SELECT CASE( obj%VoigtType ) - CASE( StressTypeVoigt ) - WRITE( I, "(A)" ) "Stress Like Voigt Type" - CASE( StrainTypeVoigt ) - WRITE( I, "(A)" ) "Strain Like Voigt Type" - END SELECT - CALL Display( Val = V, UnitNo=I, Msg="", orient = "row") - END ASSOCIATE -END PROCEDURE display_obj - -END SUBMODULE IO From f0a70be4fb49e3b3e95565d9c7c641bc965a34d5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 01:35:30 +0900 Subject: [PATCH 049/359] Updates in ReferenceElement methods --- .fortls | 28 + .gitattributes | 2 + .gitconfig | 5 + .github/.pr-labeler.yml | 4 + .github/ISSUE_TEMPLATE/bug_report.md | 39 + .github/ISSUE_TEMPLATE/feature_request.md | 21 + .github/ISSUE_TEMPLATE/inspiration.md | 23 + .github/workflows/pr-labeler.yml | 18 + .gitignore | 29 + .vscode/settings.json | 7 + .vscode/tasks.json | 112 + CMakeLists.txt | 334 + CMakePresets.json | 81 + FORDsetup.md | 45 + LICENSE | 94 + LICENSE.gpl3.md | 596 + README.md | 205 + Workspaces/BLAS.code-workspace | 13 + Workspaces/OpenMP.code-workspace | 13 + Workspaces/Polynomial | 0 Workspaces/SparseMatrix.code-workspace | 16 + Workspaces/Tensor.code-workspace | 10 + Workspaces/Utility.code-workspace | 10 + Workspaces/refelem.code-workspace | 25 + base.code-workspace | 10 + build.py | 53 + cmake/Config.cmake.in | 75 + cmake/Modules/FindLAPACK.cmake | 563 + cmake/addARPACK.cmake | 30 + cmake/addFFTW.cmake | 33 + cmake/addGTKFortran.cmake | 49 + cmake/addLIS.cmake | 37 + cmake/addLapack95.cmake | 33 + cmake/addLua.cmake | 41 + cmake/addMetis.cmake | 28 + cmake/addOpenBLAS.cmake | 45 + cmake/addOpenMP.cmake | 70 + cmake/addPLPLOT.cmake | 47 + cmake/addRaylib.cmake | 31 + cmake/addSparsekit.cmake | 28 + cmake/addSuperLU.cmake | 25 + cmake/addToml.cmake | 28 + cmake/packaging.cmake | 195 + compile_commands.json | 2812 ++ easifemBase.py | 0 easifemvar.sh | 0 figures/banner.jpeg | Bin 0 -> 79230 bytes figures/favicon.ico | 88 + figures/figure-1.svg | 4 + figures/figure-2.svg | 4 + figures/logo_hero.svg | 105 + figures/what-is-easifem.svg | 780 + fortran.json | 237 + install.py | 53 + neovim.json | 1 + package-lock.json | 64 + package.json | 5 + package.py | 49 + pages/BaseMethods.md | 58 + pages/BaseType.md | 66 + pages/Environment.md | 152 + pages/Extpkgs.md | 20 + pages/Install_Linux.md | 149 + pages/Install_MacOSX.md | 21 + pages/Install_Windows.md | 3 + pages/IntVector_.md | 106 + release_install.py | 52 + selected | 0 setup.py | 76 + setup/install_pkgs_Darwin.sh | 40 + setup/install_pkgs_Ubuntu.sh | 58 + setup/requirements.txt | 11 + setup/set_envvar_CentOS.sh | 0 setup/set_envvar_Darwin.sh | 72 + setup/set_envvar_Ubuntu.sh | 70 + src/modules/ARPACK/CMakeLists.txt | 24 + src/modules/ARPACK/src/ARPACK_SAUPD.F90 | 253 + src/modules/ARPACK/src/EASIFEM_ARPACK.F90 | 25 + src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 | 158 + src/modules/BLAS95/CMakeLists.txt | 26 + src/modules/BLAS95/aux/blas95.lst | 219 + src/modules/BLAS95/aux/test.F90 | 21 + src/modules/BLAS95/src/F77_BLAS.F90 | 2590 ++ src/modules/BLAS95/src/F95_BLAS.F90 | 422 + src/modules/BLAS95/src/blas95_src/caxpby.F90 | 66 + src/modules/BLAS95/src/blas95_src/caxpy.F90 | 58 + src/modules/BLAS95/src/blas95_src/caxpyi.F90 | 55 + src/modules/BLAS95/src/blas95_src/ccopy.F90 | 49 + src/modules/BLAS95/src/blas95_src/cdotc.F90 | 50 + src/modules/BLAS95/src/blas95_src/cdotci.F90 | 47 + src/modules/BLAS95/src/blas95_src/cdotu.F90 | 50 + src/modules/BLAS95/src/blas95_src/cdotui.F90 | 47 + src/modules/BLAS95/src/blas95_src/cgbmv.F90 | 94 + src/modules/BLAS95/src/blas95_src/cgem2vc.F90 | 78 + src/modules/BLAS95/src/blas95_src/cgemm.F90 | 94 + src/modules/BLAS95/src/blas95_src/cgemm3m.F90 | 94 + .../BLAS95/src/blas95_src/cgemm3m_batch.F90 | 190 + .../BLAS95/src/blas95_src/cgemm_batch.F90 | 190 + src/modules/BLAS95/src/blas95_src/cgemmt.F90 | 100 + src/modules/BLAS95/src/blas95_src/cgemv.F90 | 79 + src/modules/BLAS95/src/blas95_src/cgerc.F90 | 63 + src/modules/BLAS95/src/blas95_src/cgeru.F90 | 63 + src/modules/BLAS95/src/blas95_src/cgthr.F90 | 46 + src/modules/BLAS95/src/blas95_src/cgthrz.F90 | 46 + src/modules/BLAS95/src/blas95_src/chbmv.F90 | 79 + src/modules/BLAS95/src/blas95_src/chemm.F90 | 87 + src/modules/BLAS95/src/blas95_src/chemv.F90 | 77 + src/modules/BLAS95/src/blas95_src/cher.F90 | 66 + src/modules/BLAS95/src/blas95_src/cher2.F90 | 69 + src/modules/BLAS95/src/blas95_src/cher2k.F90 | 91 + src/modules/BLAS95/src/blas95_src/cherk.F90 | 88 + src/modules/BLAS95/src/blas95_src/chpmv.F90 | 75 + src/modules/BLAS95/src/blas95_src/chpr.F90 | 64 + src/modules/BLAS95/src/blas95_src/chpr2.F90 | 67 + src/modules/BLAS95/src/blas95_src/crotg.F90 | 40 + src/modules/BLAS95/src/blas95_src/cscal.F90 | 48 + src/modules/BLAS95/src/blas95_src/csctr.F90 | 46 + src/modules/BLAS95/src/blas95_src/csrot.F90 | 52 + src/modules/BLAS95/src/blas95_src/csscal.F90 | 48 + src/modules/BLAS95/src/blas95_src/cswap.F90 | 49 + src/modules/BLAS95/src/blas95_src/csymm.F90 | 87 + src/modules/BLAS95/src/blas95_src/csyr2k.F90 | 91 + src/modules/BLAS95/src/blas95_src/csyrk.F90 | 88 + src/modules/BLAS95/src/blas95_src/ctbmv.F90 | 76 + src/modules/BLAS95/src/blas95_src/ctbsv.F90 | 76 + src/modules/BLAS95/src/blas95_src/ctpmv.F90 | 72 + src/modules/BLAS95/src/blas95_src/ctpsv.F90 | 72 + src/modules/BLAS95/src/blas95_src/ctrmm.F90 | 92 + src/modules/BLAS95/src/blas95_src/ctrmv.F90 | 74 + src/modules/BLAS95/src/blas95_src/ctrsm.F90 | 92 + .../BLAS95/src/blas95_src/ctrsm_batch.F90 | 191 + src/modules/BLAS95/src/blas95_src/ctrsv.F90 | 74 + src/modules/BLAS95/src/blas95_src/dasum.F90 | 47 + src/modules/BLAS95/src/blas95_src/daxpby.F90 | 66 + src/modules/BLAS95/src/blas95_src/daxpy.F90 | 58 + src/modules/BLAS95/src/blas95_src/daxpyi.F90 | 55 + src/modules/BLAS95/src/blas95_src/dcabs1.F90 | 37 + src/modules/BLAS95/src/blas95_src/dcopy.F90 | 49 + src/modules/BLAS95/src/blas95_src/ddot.F90 | 50 + src/modules/BLAS95/src/blas95_src/ddoti.F90 | 47 + src/modules/BLAS95/src/blas95_src/dgbmv.F90 | 94 + src/modules/BLAS95/src/blas95_src/dgem2vu.F90 | 78 + src/modules/BLAS95/src/blas95_src/dgemm.F90 | 94 + .../BLAS95/src/blas95_src/dgemm_batch.F90 | 190 + src/modules/BLAS95/src/blas95_src/dgemmt.F90 | 100 + src/modules/BLAS95/src/blas95_src/dgemv.F90 | 79 + src/modules/BLAS95/src/blas95_src/dger.F90 | 63 + src/modules/BLAS95/src/blas95_src/dgthr.F90 | 46 + src/modules/BLAS95/src/blas95_src/dgthrz.F90 | 46 + src/modules/BLAS95/src/blas95_src/dnrm2.F90 | 47 + src/modules/BLAS95/src/blas95_src/drot.F90 | 52 + src/modules/BLAS95/src/blas95_src/drotg.F90 | 40 + src/modules/BLAS95/src/blas95_src/droti.F90 | 51 + src/modules/BLAS95/src/blas95_src/drotm.F90 | 50 + src/modules/BLAS95/src/blas95_src/drotmg.F90 | 45 + src/modules/BLAS95/src/blas95_src/dsbmv.F90 | 79 + src/modules/BLAS95/src/blas95_src/dscal.F90 | 48 + src/modules/BLAS95/src/blas95_src/dsctr.F90 | 46 + src/modules/BLAS95/src/blas95_src/dsdot.F90 | 51 + src/modules/BLAS95/src/blas95_src/dspmv.F90 | 75 + src/modules/BLAS95/src/blas95_src/dspr.F90 | 64 + src/modules/BLAS95/src/blas95_src/dspr2.F90 | 67 + src/modules/BLAS95/src/blas95_src/dswap.F90 | 49 + src/modules/BLAS95/src/blas95_src/dsymm.F90 | 87 + src/modules/BLAS95/src/blas95_src/dsymv.F90 | 77 + src/modules/BLAS95/src/blas95_src/dsyr.F90 | 66 + src/modules/BLAS95/src/blas95_src/dsyr2.F90 | 69 + src/modules/BLAS95/src/blas95_src/dsyr2k.F90 | 91 + src/modules/BLAS95/src/blas95_src/dsyrk.F90 | 88 + src/modules/BLAS95/src/blas95_src/dtbmv.F90 | 76 + src/modules/BLAS95/src/blas95_src/dtbsv.F90 | 76 + src/modules/BLAS95/src/blas95_src/dtpmv.F90 | 72 + src/modules/BLAS95/src/blas95_src/dtpsv.F90 | 72 + src/modules/BLAS95/src/blas95_src/dtrmm.F90 | 92 + src/modules/BLAS95/src/blas95_src/dtrmv.F90 | 74 + src/modules/BLAS95/src/blas95_src/dtrsm.F90 | 92 + .../BLAS95/src/blas95_src/dtrsm_batch.F90 | 191 + src/modules/BLAS95/src/blas95_src/dtrsv.F90 | 74 + src/modules/BLAS95/src/blas95_src/dzasum.F90 | 47 + src/modules/BLAS95/src/blas95_src/dzgemm.F90 | 94 + src/modules/BLAS95/src/blas95_src/dzgemv.F90 | 79 + src/modules/BLAS95/src/blas95_src/dznrm2.F90 | 47 + src/modules/BLAS95/src/blas95_src/icamax.F90 | 47 + src/modules/BLAS95/src/blas95_src/icamin.F90 | 47 + src/modules/BLAS95/src/blas95_src/idamax.F90 | 47 + src/modules/BLAS95/src/blas95_src/idamin.F90 | 47 + src/modules/BLAS95/src/blas95_src/isamax.F90 | 47 + src/modules/BLAS95/src/blas95_src/isamin.F90 | 47 + src/modules/BLAS95/src/blas95_src/izamax.F90 | 47 + src/modules/BLAS95/src/blas95_src/izamin.F90 | 47 + src/modules/BLAS95/src/blas95_src/sasum.F90 | 47 + src/modules/BLAS95/src/blas95_src/saxpby.F90 | 66 + src/modules/BLAS95/src/blas95_src/saxpy.F90 | 58 + src/modules/BLAS95/src/blas95_src/saxpyi.F90 | 55 + src/modules/BLAS95/src/blas95_src/scabs1.F90 | 37 + src/modules/BLAS95/src/blas95_src/scasum.F90 | 47 + src/modules/BLAS95/src/blas95_src/scgemm.F90 | 94 + src/modules/BLAS95/src/blas95_src/scgemv.F90 | 79 + src/modules/BLAS95/src/blas95_src/scnrm2.F90 | 47 + src/modules/BLAS95/src/blas95_src/scopy.F90 | 49 + src/modules/BLAS95/src/blas95_src/sdot.F90 | 50 + src/modules/BLAS95/src/blas95_src/sdoti.F90 | 47 + src/modules/BLAS95/src/blas95_src/sdsdot.F90 | 52 + src/modules/BLAS95/src/blas95_src/sgbmv.F90 | 94 + src/modules/BLAS95/src/blas95_src/sgem2vu.F90 | 78 + src/modules/BLAS95/src/blas95_src/sgemm.F90 | 94 + .../BLAS95/src/blas95_src/sgemm_batch.F90 | 190 + src/modules/BLAS95/src/blas95_src/sgemmt.F90 | 100 + src/modules/BLAS95/src/blas95_src/sgemv.F90 | 79 + src/modules/BLAS95/src/blas95_src/sger.F90 | 63 + src/modules/BLAS95/src/blas95_src/sgthr.F90 | 46 + src/modules/BLAS95/src/blas95_src/sgthrz.F90 | 46 + src/modules/BLAS95/src/blas95_src/snrm2.F90 | 47 + src/modules/BLAS95/src/blas95_src/srot.F90 | 52 + src/modules/BLAS95/src/blas95_src/srotg.F90 | 40 + src/modules/BLAS95/src/blas95_src/sroti.F90 | 51 + src/modules/BLAS95/src/blas95_src/srotm.F90 | 50 + src/modules/BLAS95/src/blas95_src/srotmg.F90 | 45 + src/modules/BLAS95/src/blas95_src/ssbmv.F90 | 79 + src/modules/BLAS95/src/blas95_src/sscal.F90 | 48 + src/modules/BLAS95/src/blas95_src/ssctr.F90 | 46 + src/modules/BLAS95/src/blas95_src/sspmv.F90 | 75 + src/modules/BLAS95/src/blas95_src/sspr.F90 | 64 + src/modules/BLAS95/src/blas95_src/sspr2.F90 | 67 + src/modules/BLAS95/src/blas95_src/sswap.F90 | 49 + src/modules/BLAS95/src/blas95_src/ssymm.F90 | 87 + src/modules/BLAS95/src/blas95_src/ssymv.F90 | 77 + src/modules/BLAS95/src/blas95_src/ssyr.F90 | 66 + src/modules/BLAS95/src/blas95_src/ssyr2.F90 | 69 + src/modules/BLAS95/src/blas95_src/ssyr2k.F90 | 91 + src/modules/BLAS95/src/blas95_src/ssyrk.F90 | 88 + src/modules/BLAS95/src/blas95_src/stbmv.F90 | 76 + src/modules/BLAS95/src/blas95_src/stbsv.F90 | 76 + src/modules/BLAS95/src/blas95_src/stpmv.F90 | 72 + src/modules/BLAS95/src/blas95_src/stpsv.F90 | 72 + src/modules/BLAS95/src/blas95_src/strmm.F90 | 92 + src/modules/BLAS95/src/blas95_src/strmv.F90 | 74 + src/modules/BLAS95/src/blas95_src/strsm.F90 | 92 + .../BLAS95/src/blas95_src/strsm_batch.F90 | 191 + src/modules/BLAS95/src/blas95_src/strsv.F90 | 74 + src/modules/BLAS95/src/blas95_src/zaxpby.F90 | 66 + src/modules/BLAS95/src/blas95_src/zaxpy.F90 | 58 + src/modules/BLAS95/src/blas95_src/zaxpyi.F90 | 55 + src/modules/BLAS95/src/blas95_src/zcopy.F90 | 49 + src/modules/BLAS95/src/blas95_src/zdotc.F90 | 50 + src/modules/BLAS95/src/blas95_src/zdotci.F90 | 47 + src/modules/BLAS95/src/blas95_src/zdotu.F90 | 50 + src/modules/BLAS95/src/blas95_src/zdotui.F90 | 47 + src/modules/BLAS95/src/blas95_src/zdrot.F90 | 52 + src/modules/BLAS95/src/blas95_src/zdscal.F90 | 48 + src/modules/BLAS95/src/blas95_src/zgbmv.F90 | 94 + src/modules/BLAS95/src/blas95_src/zgem2vc.F90 | 78 + src/modules/BLAS95/src/blas95_src/zgemm.F90 | 94 + src/modules/BLAS95/src/blas95_src/zgemm3m.F90 | 94 + .../BLAS95/src/blas95_src/zgemm3m_batch.F90 | 190 + .../BLAS95/src/blas95_src/zgemm_batch.F90 | 190 + src/modules/BLAS95/src/blas95_src/zgemmt.F90 | 100 + src/modules/BLAS95/src/blas95_src/zgemv.F90 | 79 + src/modules/BLAS95/src/blas95_src/zgerc.F90 | 63 + src/modules/BLAS95/src/blas95_src/zgeru.F90 | 63 + src/modules/BLAS95/src/blas95_src/zgthr.F90 | 46 + src/modules/BLAS95/src/blas95_src/zgthrz.F90 | 46 + src/modules/BLAS95/src/blas95_src/zhbmv.F90 | 79 + src/modules/BLAS95/src/blas95_src/zhemm.F90 | 87 + src/modules/BLAS95/src/blas95_src/zhemv.F90 | 77 + src/modules/BLAS95/src/blas95_src/zher.F90 | 66 + src/modules/BLAS95/src/blas95_src/zher2.F90 | 69 + src/modules/BLAS95/src/blas95_src/zher2k.F90 | 91 + src/modules/BLAS95/src/blas95_src/zherk.F90 | 88 + src/modules/BLAS95/src/blas95_src/zhpmv.F90 | 75 + src/modules/BLAS95/src/blas95_src/zhpr.F90 | 64 + src/modules/BLAS95/src/blas95_src/zhpr2.F90 | 67 + src/modules/BLAS95/src/blas95_src/zrotg.F90 | 40 + src/modules/BLAS95/src/blas95_src/zscal.F90 | 48 + src/modules/BLAS95/src/blas95_src/zsctr.F90 | 46 + src/modules/BLAS95/src/blas95_src/zswap.F90 | 49 + src/modules/BLAS95/src/blas95_src/zsymm.F90 | 87 + src/modules/BLAS95/src/blas95_src/zsyr2k.F90 | 91 + src/modules/BLAS95/src/blas95_src/zsyrk.F90 | 88 + src/modules/BLAS95/src/blas95_src/ztbmv.F90 | 76 + src/modules/BLAS95/src/blas95_src/ztbsv.F90 | 76 + src/modules/BLAS95/src/blas95_src/ztpmv.F90 | 72 + src/modules/BLAS95/src/blas95_src/ztpsv.F90 | 72 + src/modules/BLAS95/src/blas95_src/ztrmm.F90 | 92 + src/modules/BLAS95/src/blas95_src/ztrmv.F90 | 74 + src/modules/BLAS95/src/blas95_src/ztrsm.F90 | 92 + .../BLAS95/src/blas95_src/ztrsm_batch.F90 | 191 + src/modules/BLAS95/src/blas95_src/ztrsv.F90 | 74 + .../BLAS95/src/easifem_blas_interface.inc | 1870 + src/modules/BaseContinuity/CMakeLists.txt | 23 + .../src/BaseContinuity_Method.F90 | 177 + src/modules/BaseInterpolation/CMakeLists.txt | 22 + .../src/BaseInterpolation_Method.F90 | 449 + src/modules/BaseMethod/CMakeLists.txt | 13 + src/modules/BaseMethod/src/BaseMethod.F90 | 120 + src/modules/BaseType/CMakeLists.txt | 22 + src/modules/BaseType/src/BaseType.F90 | 1748 + src/modules/BeFoR64/CMakeLists.txt | 64 + src/modules/BeFoR64/src/befor64.F90 | 1122 + .../BeFoR64/src/befor64_pack_data_m.F90 | 848 + src/modules/BoundingBox/CMakeLists.txt | 13 + .../BoundingBox/src/BoundingBox_Method.F90 | 934 + src/modules/CInterface/CMakeLists.txt | 13 + src/modules/CInterface/src/CInterface.F90 | 1214 + src/modules/CMakeLists.txt | 211 + src/modules/CSRMatrix/CMakeLists.txt | 51 + .../CSRMatrix/src/CSRMatrix_AddMethods.F90 | 505 + .../src/CSRMatrix_ConstructorMethods.F90 | 391 + .../CSRMatrix/src/CSRMatrix_DBCMethods.F90 | 36 + .../src/CSRMatrix_DiagonalScalingMethods.F90 | 75 + .../src/CSRMatrix_GetBlockColMethods.F90 | 380 + .../src/CSRMatrix_GetBlockRowMethods.F90 | 385 + .../CSRMatrix/src/CSRMatrix_GetColMethods.F90 | 394 + .../CSRMatrix/src/CSRMatrix_GetMethods.F90 | 680 + .../CSRMatrix/src/CSRMatrix_GetRowMethods.F90 | 348 + .../src/CSRMatrix_GetSubMatrixMethods.F90 | 63 + .../CSRMatrix/src/CSRMatrix_ILUMethods.F90 | 513 + .../CSRMatrix/src/CSRMatrix_IOMethods.F90 | 110 + .../src/CSRMatrix_LUSolveMethods.F90 | 140 + .../src/CSRMatrix_LinSolveMethods.F90 | 162 + .../CSRMatrix/src/CSRMatrix_MatVecMethods.F90 | 257 + .../src/CSRMatrix_MatrixMarketIO.F90 | 97 + .../CSRMatrix/src/CSRMatrix_Method.F90 | 50 + .../src/CSRMatrix_ReorderingMethods.F90 | 81 + .../CSRMatrix/src/CSRMatrix_SchurMethods.F90 | 187 + .../src/CSRMatrix_SetBlockColMethods.F90 | 166 + .../src/CSRMatrix_SetBlockRowMethods.F90 | 166 + .../CSRMatrix/src/CSRMatrix_SetColMethods.F90 | 485 + .../CSRMatrix/src/CSRMatrix_SetMethods.F90 | 580 + .../CSRMatrix/src/CSRMatrix_SetRowMethods.F90 | 476 + .../src/CSRMatrix_SparsityMethods.F90 | 153 + .../src/CSRMatrix_SpectralMethods.F90 | 209 + .../CSRMatrix/src/CSRMatrix_SuperLU.F90 | 503 + .../src/CSRMatrix_SymMatmulMethods.F90 | 41 + .../CSRMatrix/src/CSRMatrix_UnaryMethods.F90 | 512 + src/modules/CSRSparsity/CMakeLists.txt | 13 + .../CSRSparsity/src/CSRSparsity_Method.F90 | 821 + src/modules/ConvectiveMatrix/CMakeLists.txt | 22 + .../src/ConvectiveMatrix_Method.F90 | 125 + src/modules/DOF/CMakeLists.txt | 27 + src/modules/DOF/src/DOF_AddMethods.F90 | 451 + .../DOF/src/DOF_ConstructorMethods.F90 | 220 + src/modules/DOF/src/DOF_GetMethods.F90 | 1595 + src/modules/DOF/src/DOF_GetValueMethods.F90 | 384 + src/modules/DOF/src/DOF_IOMethods.F90 | 111 + src/modules/DOF/src/DOF_Method.F90 | 31 + src/modules/DOF/src/DOF_SetMethods.F90 | 464 + src/modules/DiffusionMatrix/CMakeLists.txt | 22 + .../src/DiffusionMatrix_Method.F90 | 577 + src/modules/Display/CMakeLists.txt | 26 + src/modules/Display/src/Display_Mat2.inc | 68 + src/modules/Display/src/Display_Mat3.inc | 24 + src/modules/Display/src/Display_Mat4.inc | 31 + src/modules/Display/src/Display_Method.F90 | 1712 + src/modules/Display/src/Display_Scalar.inc | 29 + src/modules/Display/src/Display_Vector.inc | 73 + .../src/References/dispmodule-userman.pdf | Bin 0 -> 162230 bytes src/modules/Display/src/disp/disp_charmod.F90 | 178 + src/modules/Display/src/disp/disp_i1mod.F90 | 266 + src/modules/Display/src/disp/disp_i2mod.F90 | 276 + src/modules/Display/src/disp/disp_i4mod.F90 | 270 + src/modules/Display/src/disp/disp_i8mod.F90 | 270 + src/modules/Display/src/disp/disp_l1mod.F90 | 202 + src/modules/Display/src/disp/disp_r16mod.F90 | 553 + src/modules/Display/src/disp/disp_r4mod.F90 | 549 + src/modules/Display/src/disp/disp_r8mod.F90 | 666 + src/modules/Display/src/disp/dispmodule.F90 | 189 + .../Display/src/disp/dispmodule_util.F90 | 955 + src/modules/Display/src/disp/putstrmodule.F90 | 25 + .../ElasticNitscheMatrix/CMakeLists.txt | 22 + .../src/ElasticNitscheMatrix_Method.F90 | 552 + src/modules/ElemshapeData/CMakeLists.txt | 43 + .../src/ElemshapeData_ConstructorMethods.F90 | 224 + .../src/ElemshapeData_DGHermitMethods.F90 | 53 + .../src/ElemshapeData_DGHierarchyMethods.F90 | 53 + .../src/ElemshapeData_DGLagrangeMethods.F90 | 53 + .../src/ElemshapeData_DGMethods.F90 | 252 + .../ElemshapeData_DGSerendipityMethods.F90 | 54 + .../src/ElemshapeData_DivergenceMethods.F90 | 245 + .../src/ElemshapeData_GetMethods.F90 | 94 + .../src/ElemshapeData_GradientMethods.F90 | 323 + .../src/ElemshapeData_H1Methods.F90 | 252 + .../src/ElemshapeData_HCurlMethods.F90 | 253 + .../src/ElemshapeData_HDivMethods.F90 | 253 + .../src/ElemshapeData_HRGNParamMethods.F90 | 141 + .../src/ElemshapeData_HRQIParamMethods.F90 | 147 + .../src/ElemshapeData_HminHmaxMethods.F90 | 228 + .../src/ElemshapeData_IOMethods.F90 | 92 + .../src/ElemshapeData_InterpolMethods.F90 | 695 + .../ElemshapeData_LocalDivergenceMethods.F90 | 264 + .../ElemshapeData_LocalGradientMethods.F90 | 367 + .../src/ElemshapeData_Method.F90 | 37 + .../src/ElemshapeData_ProjectionMethods.F90 | 214 + .../src/ElemshapeData_SetMethods.F90 | 482 + ...lemshapeData_StabilizationParamMethods.F90 | 481 + .../src/ElemshapeData_UnitNormalMethods.F90 | 129 + src/modules/ErrorHandling/CMakeLists.txt | 13 + .../ErrorHandling/src/ErrorHandling.F90 | 195 + src/modules/FACE/CMakeLists.txt | 68 + src/modules/FACE/src/face.F90 | 287 + src/modules/FEMatrix/CMakeLists.txt | 13 + src/modules/FEMatrix/src/FEMatrix_Method.F90 | 28 + src/modules/FEVariable/CMakeLists.txt | 13 + .../FEVariable/src/FEVariable_Method.F90 | 1626 + src/modules/FEVector/CMakeLists.txt | 22 + src/modules/FEVector/src/FEVector_Method.F90 | 21 + src/modules/FFTW/CMakeLists.txt | 22 + src/modules/FFTW/src/FFTW3.F90 | 2231 + src/modules/FPL/CMakeLists.txt | 17 + src/modules/FPL/LICENSE | 165 + src/modules/FPL/src/ErrorMessages.F90 | 123 + src/modules/FPL/src/FPL.F90 | 54 + src/modules/FPL/src/FPL_utils.F90 | 45 + src/modules/FPL/src/ParameterEntry.F90 | 381 + .../FPL/src/ParameterEntryDictionary.F90 | 336 + src/modules/FPL/src/ParameterList.F90 | 2742 ++ src/modules/FPL/src/ParameterRootEntry.F90 | 350 + .../FPL/src/Wrapper/DimensionsWrapper.F90 | 126 + .../DimensionsWrapper0D.F90 | 64 + .../DimensionsWrapper0D_DLCA.F90 | 219 + .../DimensionsWrapper0D_I1P.F90 | 218 + .../DimensionsWrapper0D_I2P.F90 | 217 + .../DimensionsWrapper0D_I4P.F90 | 216 + .../DimensionsWrapper0D_I8P.F90 | 217 + .../DimensionsWrapper0D_L.F90 | 218 + .../DimensionsWrapper0D_R4P.F90 | 216 + .../DimensionsWrapper0D_R8P.F90 | 217 + .../DimensionsWrapper1D.F90 | 64 + .../DimensionsWrapper1D_DLCA.F90 | 251 + .../DimensionsWrapper1D_I1P.F90 | 227 + .../DimensionsWrapper1D_I2P.F90 | 225 + .../DimensionsWrapper1D_I4P.F90 | 226 + .../DimensionsWrapper1D_I8P.F90 | 225 + .../DimensionsWrapper1D_L.F90 | 235 + .../DimensionsWrapper1D_R4P.F90 | 225 + .../DimensionsWrapper1D_R8P.F90 | 225 + .../DimensionsWrapper2D.F90 | 64 + .../DimensionsWrapper2D_DLCA.F90 | 257 + .../DimensionsWrapper2D_I1P.F90 | 241 + .../DimensionsWrapper2D_I2P.F90 | 241 + .../DimensionsWrapper2D_I4P.F90 | 240 + .../DimensionsWrapper2D_I8P.F90 | 241 + .../DimensionsWrapper2D_L.F90 | 243 + .../DimensionsWrapper2D_R4P.F90 | 241 + .../DimensionsWrapper2D_R8P.F90 | 241 + .../DimensionsWrapper3D.F90 | 64 + .../DimensionsWrapper3D_DLCA.F90 | 261 + .../DimensionsWrapper3D_I1P.F90 | 246 + .../DimensionsWrapper3D_I2P.F90 | 245 + .../DimensionsWrapper3D_I4P.F90 | 245 + .../DimensionsWrapper3D_I8P.F90 | 245 + .../DimensionsWrapper3D_L.F90 | 247 + .../DimensionsWrapper3D_R4P.F90 | 244 + .../DimensionsWrapper3D_R8P.F90 | 245 + .../DimensionsWrapper4D.F90 | 64 + .../DimensionsWrapper4D_DLCA.F90 | 265 + .../DimensionsWrapper4D_I1P.F90 | 249 + .../DimensionsWrapper4D_I2P.F90 | 249 + .../DimensionsWrapper4D_I4P.F90 | 249 + .../DimensionsWrapper4D_I8P.F90 | 250 + .../DimensionsWrapper4D_L.F90 | 252 + .../DimensionsWrapper4D_R4P.F90 | 249 + .../DimensionsWrapper4D_R8P.F90 | 249 + .../DimensionsWrapper5D.F90 | 64 + .../DimensionsWrapper5D_DLCA.F90 | 269 + .../DimensionsWrapper5D_I1P.F90 | 254 + .../DimensionsWrapper5D_I2P.F90 | 253 + .../DimensionsWrapper5D_I4P.F90 | 252 + .../DimensionsWrapper5D_I8P.F90 | 252 + .../DimensionsWrapper5D_L.F90 | 256 + .../DimensionsWrapper5D_R4P.F90 | 253 + .../DimensionsWrapper5D_R8P.F90 | 253 + .../DimensionsWrapper6D.F90 | 64 + .../DimensionsWrapper6D_DLCA.F90 | 273 + .../DimensionsWrapper6D_I1P.F90 | 257 + .../DimensionsWrapper6D_I2P.F90 | 257 + .../DimensionsWrapper6D_I4P.F90 | 257 + .../DimensionsWrapper6D_I8P.F90 | 258 + .../DimensionsWrapper6D_L.F90 | 260 + .../DimensionsWrapper6D_R4P.F90 | 257 + .../DimensionsWrapper6D_R8P.F90 | 257 + .../DimensionsWrapper7D.F90 | 64 + .../DimensionsWrapper7D_DLCA.F90 | 276 + .../DimensionsWrapper7D_I1P.F90 | 260 + .../DimensionsWrapper7D_I2P.F90 | 260 + .../DimensionsWrapper7D_I4P.F90 | 260 + .../DimensionsWrapper7D_I8P.F90 | 260 + .../DimensionsWrapper7D_L.F90 | 262 + .../DimensionsWrapper7D_R4P.F90 | 260 + .../DimensionsWrapper7D_R8P.F90 | 259 + .../WrapperFactory/DLACWrapperFactory.F90 | 354 + .../WrapperFactory/I1PWrapperFactory.F90 | 354 + .../WrapperFactory/I2PWrapperFactory.F90 | 353 + .../WrapperFactory/I4PWrapperFactory.F90 | 353 + .../WrapperFactory/I8PWrapperFactory.F90 | 353 + .../WrapperFactory/LWrapperFactory.F90 | 353 + .../WrapperFactory/R4PWrapperFactory.F90 | 353 + .../WrapperFactory/R8PWrapperFactory.F90 | 353 + .../Wrapper/WrapperFactory/WrapperFactory.F90 | 172 + .../FPL/src/Wrapper/WrapperFactoryList.F90 | 418 + .../Wrapper/WrapperFactoryListSingleton.F90 | 60 + src/modules/FacetMatrix/CMakeLists.txt | 22 + src/modules/FacetMatrix/src/FacetMatrix1.inc | 175 + src/modules/FacetMatrix/src/FacetMatrix11.inc | 178 + src/modules/FacetMatrix/src/FacetMatrix12.inc | 166 + src/modules/FacetMatrix/src/FacetMatrix13.inc | 187 + src/modules/FacetMatrix/src/FacetMatrix14.inc | 187 + src/modules/FacetMatrix/src/FacetMatrix15.inc | 214 + src/modules/FacetMatrix/src/FacetMatrix2.inc | 159 + src/modules/FacetMatrix/src/FacetMatrix21.inc | 103 + src/modules/FacetMatrix/src/FacetMatrix22.inc | 103 + src/modules/FacetMatrix/src/FacetMatrix3.inc | 154 + src/modules/FacetMatrix/src/FacetMatrix4.inc | 154 + src/modules/FacetMatrix/src/FacetMatrix5.inc | 214 + .../FacetMatrix/src/FacetMatrix_Method.F90 | 37 + src/modules/ForceVector/CMakeLists.txt | 22 + .../ForceVector/src/ForceVector_Method.F90 | 229 + src/modules/Geometry/CMakeLists.txt | 34 + src/modules/Geometry/src/Geometry_Method.F90 | 31 + src/modules/Geometry/src/Line_Method.F90 | 431 + src/modules/Geometry/src/Plane_Method.F90 | 69 + .../Geometry/src/ReferenceElement_Method.F90 | 1347 + .../src/ReferenceHexahedron_Method.F90 | 375 + .../Geometry/src/ReferenceLine_Method.F90 | 518 + .../Geometry/src/ReferencePrism_Method.F90 | 407 + .../Geometry/src/ReferencePyramid_Method.F90 | 354 + .../src/ReferenceQuadrangle_Method.F90 | 484 + .../src/ReferenceTetrahedron_Method.F90 | 368 + .../Geometry/src/ReferenceTriangle_Method.F90 | 825 + src/modules/Geometry/src/Triangle_Method.F90 | 1505 + .../src/assets/geometry_burkardt_line.inc | 2991 ++ .../src/assets/geometry_burkardt_triangle.inc | 3469 ++ .../src/assets/geometry_by_burkardt.inc | 34798 ++++++++++++++++ src/modules/GlobalData/CMakeLists.txt | 23 + src/modules/GlobalData/src/ElementNames.txt | 138 + src/modules/GlobalData/src/GlobalData.F90 | 617 + src/modules/Gnuplot/CMakeLists.txt | 13 + src/modules/Gnuplot/src/ogpf.F90 | 2662 ++ src/modules/Hashing/CMakeLists.txt | 23 + src/modules/Hashing/src/Hashing32.F90 | 315 + src/modules/IndexValue/CMakeLists.txt | 13 + .../IndexValue/src/IndexValue_Method.F90 | 70 + src/modules/IntVector/CMakeLists.txt | 29 + .../IntVector/src/IntVector_AppendMethod.F90 | 124 + .../src/IntVector_ConstructorMethod.F90 | 374 + .../IntVector/src/IntVector_EnquireMethod.F90 | 127 + .../IntVector/src/IntVector_GetMethod.F90 | 421 + .../IntVector/src/IntVector_IOMethod.F90 | 57 + .../IntVector/src/IntVector_Method.F90 | 38 + .../IntVector/src/IntVector_SetMethod.F90 | 101 + src/modules/IterationData/CMakeLists.txt | 13 + .../src/IterationData_Method.F90 | 108 + src/modules/Kdtree2/CMakeLists.txt | 23 + src/modules/Kdtree2/src/Kd2PQueue_Module.F90 | 448 + src/modules/Kdtree2/src/Kdtree2_Module.F90 | 1329 + src/modules/KeyValue/CMakeLists.txt | 13 + src/modules/KeyValue/src/KeyValue_Method.F90 | 1227 + src/modules/LISInterface/CMakeLists.txt | 27 + src/modules/LISInterface/src/LISBasic.F90 | 63 + src/modules/LISInterface/src/LISInterface.F90 | 22 + src/modules/LISInterface/src/LISParam.F90 | 128 + src/modules/LISInterface/src/LISVector.F90 | 434 + src/modules/Lapack/CMakeLists.txt | 37 + .../Lapack/src/GE_CompRoutineMethods.F90 | 158 + .../Lapack/src/GE_EigenValueMethods.F90 | 188 + src/modules/Lapack/src/GE_LUMethods.F90 | 251 + src/modules/Lapack/src/GE_Lapack_Method.F90 | 39 + .../Lapack/src/GE_LinearSolveMethods.F90 | 488 + .../Lapack/src/GE_SingularValueMethods.F90 | 22 + src/modules/Lapack/src/Lapack_Method.F90 | 21 + .../Lapack/src/Sym_CompRoutineMethods.F90 | 20 + .../Lapack/src/Sym_EigenValueMethods.F90 | 20 + src/modules/Lapack/src/Sym_LUMethods.F90 | 488 + src/modules/Lapack/src/Sym_Lapack_Method.F90 | 40 + .../Lapack/src/Sym_LinearSolveMethods.F90 | 290 + .../Lapack/src/Sym_SingularValueMethods.F90 | 20 + src/modules/LuaInterface/CMakeLists.txt | 30 + src/modules/LuaInterface/src/LuaInterface.F90 | 1499 + .../LuaInterface/src/No_LuaInterface.F90 | 21 + src/modules/Macro/vectorclass.inc | 46 + src/modules/MassMatrix/CMakeLists.txt | 22 + .../MassMatrix/src/MassMatrix_Method.F90 | 158 + src/modules/MdEncode/CMakeLists.txt | 22 + src/modules/MdEncode/src/MdEncode_Method.F90 | 427 + src/modules/MetisInterface/CMakeLists.txt | 25 + .../MetisInterface/src/MetisInterface.F90 | 650 + .../MetisInterface/src/MetisInterface.inc | 881 + src/modules/MultiIndices/CMakeLists.txt | 22 + .../MultiIndices/src/MultiIndices_Method.F90 | 154 + src/modules/OpenMP/CMakeLists.txt | 13 + src/modules/OpenMP/src/OpenMP_Method.F90 | 82 + src/modules/PENF/CMakeLists.txt | 85 + src/modules/PENF/LICENSE.gpl3.md | 596 + src/modules/PENF/src/BCTON.inc | 128 + src/modules/PENF/src/BSTR.inc | 136 + src/modules/PENF/src/COMPACT_REAL_STRING.inc | 84 + src/modules/PENF/src/CTOA.inc | 212 + src/modules/PENF/src/STR.inc | 1039 + src/modules/PENF/src/STRZ.inc | 108 + src/modules/PENF/src/STR_ASCII.inc | 68 + src/modules/PENF/src/STR_UCS4.inc | 68 + src/modules/PENF/src/penf.F90 | 239 + src/modules/PENF/src/penf_b_size.F90 | 227 + .../src/penf_global_parameters_variables.F90 | 213 + src/modules/PENF/src/penf_stringify.F90 | 193 + src/modules/Polynomial/CMakeLists.txt | 39 + .../src/Chebyshev1PolynomialUtility.F90 | 1098 + .../src/HexahedronInterpolationUtility.F90 | 2636 ++ .../Polynomial/src/InterpolationUtility.F90 | 96 + .../src/JacobiPolynomialUtility.F90 | 1089 + .../src/LagrangePolynomialUtility.F90 | 456 + .../src/LegendrePolynomialUtility.F90 | 1150 + .../src/LineInterpolationUtility.F90 | 1179 + .../src/LobattoPolynomialUtility.F90 | 495 + .../src/OrthogonalPolynomialUtility.F90 | 226 + .../Polynomial/src/PolynomialUtility.F90 | 36 + .../src/PrismInterpolationUtility.F90 | 690 + .../src/PyramidInterpolationUtility.F90 | 701 + .../src/QuadrangleInterpolationUtility.F90 | 2042 + .../Polynomial/src/RecursiveNodesUtility.F90 | 215 + .../src/TetrahedronInterpolationUtility.F90 | 1998 + .../src/TriangleInterpolationUtility.F90 | 1633 + .../src/UltrasphericalPolynomialUtility.F90 | 1251 + .../src/UnscaledLobattoPolynomialUtility.F90 | 411 + src/modules/QuadraturePoint/CMakeLists.txt | 13 + .../src/QuadraturePoint_Method.F90 | 779 + src/modules/Random/CMakeLists.txt | 13 + src/modules/Random/src/Random_Method.F90 | 338 + src/modules/Rank2Tensor/CMakeLists.txt | 13 + .../Rank2Tensor/src/Rank2Tensor_Method.F90 | 1719 + src/modules/RaylibInterface/CMakeLists.txt | 38 + src/modules/RaylibInterface/src/Raylib.F90 | 22 + .../RaylibInterface/src/RaylibCamera.F90 | 130 + .../src/RaylibCheckMethods.F90 | 157 + .../RaylibInterface/src/RaylibDrawMethods.F90 | 1144 + .../RaylibInterface/src/RaylibEnums.F90 | 403 + .../RaylibInterface/src/RaylibGenMethods.F90 | 283 + .../RaylibInterface/src/RaylibGetMethods.F90 | 794 + .../src/RaylibImageMethods.F90 | 477 + .../RaylibInterface/src/RaylibIsMethods.F90 | 419 + .../RaylibInterface/src/RaylibLoadMethods.F90 | 450 + .../RaylibInterface/src/RaylibMath.F90 | 1140 + .../RaylibInterface/src/RaylibMethods.F90 | 1060 + .../RaylibInterface/src/RaylibSetMethods.F90 | 503 + .../RaylibInterface/src/RaylibTypes.F90 | 380 + .../src/RaylibUnloadMethods.F90 | 237 + .../RaylibInterface/src/RaylibUtil.F90 | 48 + src/modules/RaylibInterface/src/__Raylib.F90 | 5913 +++ src/modules/RealMatrix/CMakeLists.txt | 13 + .../RealMatrix/src/RealMatrix_Method.F90 | 1360 + src/modules/RealVector/CMakeLists.txt | 35 + .../RealVector/src/RealVector_AddMethods.F90 | 717 + .../src/RealVector_AppendMethods.F90 | 72 + .../src/RealVector_AssignMethods.F90 | 129 + .../src/RealVector_Blas1Methods.F90 | 810 + .../src/RealVector_ComparisonMethods.F90 | 40 + .../src/RealVector_ConstructorMethods.F90 | 453 + .../RealVector/src/RealVector_GetMethods.F90 | 708 + .../src/RealVector_GetValueMethods.F90 | 1168 + .../RealVector/src/RealVector_IOMethods.F90 | 52 + .../RealVector/src/RealVector_Method.F90 | 45 + .../src/RealVector_Norm2ErrorMethods.F90 | 165 + .../src/RealVector_Norm2Methods.F90 | 153 + .../RealVector/src/RealVector_SetMethods.F90 | 772 + .../src/RealVector_ShallowCopyMethods.F90 | 159 + src/modules/STConvectiveMatrix/CMakeLists.txt | 22 + .../src/STConvectiveMatrix_Method.F90 | 294 + src/modules/STConvectiveMatrix/src/del.inc | 540 + src/modules/STDiffusionMatrix/CMakeLists.txt | 22 + .../src/STDiffusionMatrix_Method.F90 | 449 + src/modules/STForceVector/CMakeLists.txt | 22 + .../src/STForceVector_Method.F90 | 533 + src/modules/STMassMatrix/CMakeLists.txt | 22 + .../STMassMatrix/src/STMassMatrix_Method.F90 | 218 + src/modules/StiffnessMatrix/CMakeLists.txt | 22 + .../src/StiffnessMatrix_Method.F90 | 104 + src/modules/String/CMakeLists.txt | 38 + src/modules/String/src/String_Class.F90 | 5680 +++ src/modules/String/src/String_Method.F90 | 255 + src/modules/SuperLUInterface/CMakeLists.txt | 38 + .../SuperLUInterface/src/SuperLUInterface.F90 | 34 + .../SuperLUInterface/src/SuperLU_Enums.F90 | 320 + .../SuperLUInterface/src/SuperLU_Types.F90 | 668 + .../src/SuperLU_Util_Methods.F90 | 556 + .../src/SuperLU_dUtil_Methods.F90 | 470 + .../src/SuperLU_dgscon_Methods.F90 | 95 + .../src/SuperLU_dgsequ_Methods.F90 | 108 + .../src/SuperLU_dgsisx_Methods.F90 | 446 + .../src/SuperLU_dgsitrf_Methods.F90 | 196 + .../src/SuperLU_dgsrfs_Methods.F90 | 165 + .../src/SuperLU_dgssv_Methods.F90 | 150 + .../src/SuperLU_dgssvx_Methods.F90 | 375 + .../src/SuperLU_dgstrf_Methods.F90 | 302 + .../src/SuperLU_dgstrs_Methods.F90 | 101 + .../src/SuperLU_dlaqgs_Methods.F90 | 101 + .../SuperLUInterface/src/include/macros.inc | 18 + src/modules/System/CMakeLists.txt | 43 + src/modules/System/src/System_Method.F90 | 5427 +++ src/modules/System/src/System_Method.c | 641 + src/modules/Test/CMakeLists.txt | 26 + src/modules/Test/src/README.txt | 486 + src/modules/Test/src/Test_Base.F90 | 170 + src/modules/Test/src/Test_Is.F90 | 130 + src/modules/Test/src/Test_Method.F90 | 27 + src/modules/Test/src/Test_More.F90 | 154 + src/modules/Test/src/Test_Planning.F90 | 77 + src/modules/Test/src/is_i.inc | 24 + src/modules/Test/src/is_r.inc | 83 + src/modules/TriangleInterface/CMakeLists.txt | 63 + .../src/TriangleInterface.F90 | 257 + src/modules/TriangleInterface/src/report.c | 126 + src/modules/TriangleInterface/src/triangle.c | 15737 +++++++ src/modules/TriangleInterface/src/triangle.h | 297 + src/modules/Utility/CMakeLists.txt | 56 + src/modules/Utility/src/AppendUtility.F90 | 799 + src/modules/Utility/src/ApproxUtility.F90 | 385 + src/modules/Utility/src/ArangeUtility.F90 | 115 + src/modules/Utility/src/AssertUtility.F90 | 146 + src/modules/Utility/src/BinomUtility.F90 | 132 + .../Utility/src/ContractionUtility.F90 | 416 + src/modules/Utility/src/ConvertUtility.F90 | 151 + src/modules/Utility/src/DiagUtility.F90 | 441 + src/modules/Utility/src/EigenUtility.F90 | 187 + src/modules/Utility/src/EyeUtility.F90 | 140 + src/modules/Utility/src/GridPointUtility.F90 | 282 + src/modules/Utility/src/HashingUtility.F90 | 54 + src/modules/Utility/src/HeadUtility.F90 | 90 + src/modules/Utility/src/InputUtility.F90 | 266 + src/modules/Utility/src/IntegerUtility.F90 | 537 + src/modules/Utility/src/InvUtility.F90 | 94 + .../Utility/src/LinearAlgebraUtility.F90 | 48 + src/modules/Utility/src/MappingUtility.F90 | 966 + src/modules/Utility/src/MatmulUtility.F90 | 352 + src/modules/Utility/src/MedianUtility.F90 | 131 + src/modules/Utility/src/MiscUtility.F90 | 384 + src/modules/Utility/src/OnesUtility.F90 | 363 + src/modules/Utility/src/PartitionUtility.F90 | 174 + src/modules/Utility/src/ProductUtility.F90 | 1413 + src/modules/Utility/src/PushPopUtility.F90 | 272 + src/modules/Utility/src/ReallocateUtility.F90 | 801 + src/modules/Utility/src/SafeSizeUtility.F90 | 64 + src/modules/Utility/src/SortUtility.F90 | 808 + src/modules/Utility/src/SplitUtility.F90 | 129 + src/modules/Utility/src/StringUtility.F90 | 448 + src/modules/Utility/src/SwapUtility.F90 | 830 + src/modules/Utility/src/SymUtility.F90 | 163 + src/modules/Utility/src/TailUtility.F90 | 132 + src/modules/Utility/src/TriagUtility.F90 | 1081 + src/modules/Utility/src/Utility.F90 | 59 + src/modules/Utility/src/ZerosUtility.F90 | 400 + src/modules/Utility/src/refs/mathPlantFEM.inc | 2713 ++ src/modules/Vector3D/CMakeLists.txt | 13 + src/modules/Vector3D/src/Vector3D_Method.F90 | 1019 + src/modules/VoigtRank2Tensor/CMakeLists.txt | 13 + .../src/VoigtRank2Tensor_Method.F90 | 297 + src/modules/easifemBase/CMakeLists.txt | 13 + src/modules/easifemBase/src/easifemBase.F90 | 21 + src/submodules/ARPACK/CMakeLists.txt | 22 + .../ARPACK/src/ARPACK_SAUPD@Methods.F90 | 617 + src/submodules/BoundingBox/CMakeLists.txt | 26 + .../BoundingBox_Method@ConstructorMethods.F90 | 180 + .../src/BoundingBox_Method@GetMethods.F90 | 300 + .../src/BoundingBox_Method@IOMethods.F90 | 41 + .../src/BoundingBox_Method@SetMethods.F90 | 70 + .../src/BoundingBox_Method@TomlMethods.F90 | 86 + src/submodules/CMakeLists.txt | 130 + src/submodules/CSRMatrix/CMakeLists.txt | 47 + .../src/CSRMatrix_AddMethods@Methods.F90 | 420 + .../CSRMatrix_ConstructorMethods@Methods.F90 | 382 + .../src/CSRMatrix_DBCMethods@Methods.F90 | 72 + ...RMatrix_DiagonalScalingMethods@Methods.F90 | 166 + .../CSRMatrix_GetBlockColMethods@Methods.F90 | 318 + .../CSRMatrix_GetBlockRowMethods@Methods.F90 | 291 + .../src/CSRMatrix_GetColMethods@Methods.F90 | 238 + .../src/CSRMatrix_GetMethods@Methods.F90 | 522 + .../src/CSRMatrix_GetRowMethods@Methods.F90 | 195 + .../CSRMatrix_GetSubMatrixMethods@Methods.F90 | 124 + .../src/CSRMatrix_ILUMethods@Methods.F90 | 486 + .../src/CSRMatrix_IOMethods@Methods.F90 | 353 + .../src/CSRMatrix_LUSolveMethods@Methods.F90 | 51 + .../src/CSRMatrix_LinSolveMethods@Methods.F90 | 607 + .../src/CSRMatrix_MatVecMethods@Methods.F90 | 265 + .../src/CSRMatrix_MatrixMarketIO@Methods.F90 | 340 + .../CSRMatrix_ReorderingMethods@Methods.F90 | 95 + .../src/CSRMatrix_SchurMethods@Methods.F90 | 322 + .../CSRMatrix_SetBlockColMethods@Methods.F90 | 241 + .../CSRMatrix_SetBlockRowMethods@Methods.F90 | 233 + .../src/CSRMatrix_SetColMethods@Methods.F90 | 351 + .../src/CSRMatrix_SetMethods@Methods.F90 | 403 + .../src/CSRMatrix_SetRowMethods@Methods.F90 | 314 + .../src/CSRMatrix_SparsityMethods@Methods.F90 | 96 + .../src/CSRMatrix_SpectralMethods@Methods.F90 | 458 + .../src/CSRMatrix_SuperLU@Methods.F90 | 1584 + .../CSRMatrix_SymMatmulMethods@Methods.F90 | 57 + .../src/CSRMatrix_UnaryMethods@Methods.F90 | 855 + src/submodules/CSRSparsity/CMakeLists.txt | 25 + .../CSRSparsity_Method@ConstructorMethods.F90 | 204 + .../src/CSRSparsity_Method@GetMethods.F90 | 345 + .../src/CSRSparsity_Method@IOMethods.F90 | 65 + .../src/CSRSparsity_Method@SetMethods.F90 | 341 + .../src/CSRSparsity_Method@SymMethods.F90 | 263 + .../ConvectiveMatrix/CMakeLists.txt | 13 + .../ConvectiveMatrix-old/Constructor.part | 99 + .../ConvectiveMatrix_10.part | 170 + .../ConvectiveMatrix_11.part | 191 + .../ConvectiveMatrix_12.part | 180 + .../ConvectiveMatrix_9.part | 173 + .../ConvectiveMatrix_Class.f90 | 81 + .../MdFiles/ConvectiveMatrix_Class.md | 1036 + .../ConvectiveMatrix-old/MethodNames.part | 12 + src/submodules/ConvectiveMatrix/src/CM_1.inc | 59 + src/submodules/ConvectiveMatrix/src/CM_10.inc | 76 + src/submodules/ConvectiveMatrix/src/CM_2.inc | 42 + src/submodules/ConvectiveMatrix/src/CM_3.inc | 41 + src/submodules/ConvectiveMatrix/src/CM_4.inc | 42 + src/submodules/ConvectiveMatrix/src/CM_5.inc | 77 + src/submodules/ConvectiveMatrix/src/CM_6.inc | 79 + src/submodules/ConvectiveMatrix/src/CM_7.inc | 56 + src/submodules/ConvectiveMatrix/src/CM_8.inc | 58 + src/submodules/ConvectiveMatrix/src/CM_9.inc | 73 + .../src/ConvectiveMatrix_Method@Methods.F90 | 137 + src/submodules/DOF/CMakeLists.txt | 27 + .../DOF/src/DOF_AddMethods@Methods.F90 | 433 + .../src/DOF_ConstructorMethods@Methods.F90 | 136 + .../DOF/src/DOF_GetMethods@Methods.F90 | 827 + .../DOF/src/DOF_GetValueMethods@Methods.F90 | 368 + .../DOF/src/DOF_IOMethods@Methods.F90 | 94 + .../DOF/src/DOF_SetMethods@Methods.F90 | 319 + src/submodules/DiffusionMatrix/CMakeLists.txt | 13 + src/submodules/DiffusionMatrix/src/DM_1.inc | 55 + src/submodules/DiffusionMatrix/src/DM_10.inc | 59 + src/submodules/DiffusionMatrix/src/DM_2.inc | 56 + src/submodules/DiffusionMatrix/src/DM_3.inc | 55 + src/submodules/DiffusionMatrix/src/DM_4.inc | 60 + src/submodules/DiffusionMatrix/src/DM_5.inc | 60 + src/submodules/DiffusionMatrix/src/DM_6.inc | 55 + src/submodules/DiffusionMatrix/src/DM_7.inc | 54 + src/submodules/DiffusionMatrix/src/DM_8.inc | 63 + src/submodules/DiffusionMatrix/src/DM_9.inc | 59 + .../src/DiffusionMatrix_Method@Methods.F90 | 548 + .../ElasticNitscheMatrix/CMakeLists.txt | 26 + .../ElasticNitscheMatrix_Method@Matrix1.F90 | 312 + .../ElasticNitscheMatrix_Method@Matrix2.F90 | 154 + .../ElasticNitscheMatrix_Method@Matrix3.F90 | 240 + ...asticNitscheMatrix_Method@MatrixNormal.F90 | 137 + ...sticNitscheMatrix_Method@MatrixTangent.F90 | 132 + src/submodules/ElemshapeData/CMakeLists.txt | 63 + .../ElemshapeData_DGMethods@HermitMethods.F90 | 36 + ...emshapeData_DGMethods@HierarchyMethods.F90 | 36 + ...lemshapeData_DGMethods@LagrangeMethods.F90 | 36 + ...mshapeData_DGMethods@OrthogonalMethods.F90 | 36 + ...shapeData_DGMethods@SerendipityMethods.F90 | 35 + ...emshapeData_ConstructorMethods@Methods.F90 | 362 + ...lemshapeData_DivergenceMethods@Methods.F90 | 205 + .../src/ElemshapeData_GetMethods@Methods.F90 | 95 + .../ElemshapeData_GradientMethods@Methods.F90 | 284 + ...ElemshapeData_HRGNParamMethods@Methods.F90 | 217 + ...ElemshapeData_HRQIParamMethods@Methods.F90 | 664 + .../ElemshapeData_HminHmaxMethods@Methods.F90 | 216 + .../src/ElemshapeData_IOMethods@Methods.F90 | 270 + .../ElemshapeData_InterpolMethods@Methods.F90 | 594 + ...apeData_LocalDivergenceMethods@Methods.F90 | 200 + ...shapeData_LocalGradientMethods@Methods.F90 | 244 + ...lemshapeData_ProjectionMethods@Methods.F90 | 167 + .../src/ElemshapeData_SetMethods@Methods.F90 | 285 + ...peData_StabilizationParamMethods@SUGN3.F90 | 147 + ...apeData_StabilizationParamMethods@SUPG.F90 | 567 + ...StabilizationParamMethods@Takizawa2018.F90 | 284 + ...lemshapeData_UnitNormalMethods@Methods.F90 | 168 + .../ElemshapeData_H1Methods@HermitMethods.F90 | 33 + ...emshapeData_H1Methods@HierarchyMethods.F90 | 127 + ...lemshapeData_H1Methods@LagrangeMethods.F90 | 133 + ...mshapeData_H1Methods@OrthogonalMethods.F90 | 169 + ...shapeData_H1Methods@SerendipityMethods.F90 | 36 + ...emshapeData_HCurlMethods@HermitMethods.F90 | 36 + ...hapeData_HCurlMethods@HierarchyMethods.F90 | 36 + ...shapeData_HCurlMethods@LagrangeMethods.F90 | 36 + ...apeData_HCurlMethods@OrthogonalMethods.F90 | 36 + ...peData_HCurlMethods@SerendipityMethods.F90 | 36 + ...lemshapeData_HDivMethods@HermitMethods.F90 | 36 + ...shapeData_HDivMethods@HierarchyMethods.F90 | 36 + ...mshapeData_HDivMethods@LagrangeMethods.F90 | 36 + ...hapeData_HDivMethods@OrthogonalMethods.F90 | 36 + ...apeData_HDivMethods@SerendipityMethods.F90 | 35 + src/submodules/FEMatrix/src/STCM/STCM_1.inc | 111 + src/submodules/FEVariable/CMakeLists.txt | 35 + .../src/FEVariable_Method@AbsMethods.F90 | 64 + .../src/FEVariable_Method@AdditionMethods.F90 | 107 + .../FEVariable_Method@ConstructorMethods.F90 | 467 + .../src/FEVariable_Method@DivisionMethods.F90 | 129 + .../FEVariable_Method@DotProductMethods.F90 | 282 + .../src/FEVariable_Method@EqualMethods.F90 | 78 + .../src/FEVariable_Method@GetMethods.F90 | 328 + .../src/FEVariable_Method@IOMethods.F90 | 138 + .../src/FEVariable_Method@MeanMethods.F90 | 176 + ...EVariable_Method@MultiplicationMethods.F90 | 108 + .../src/FEVariable_Method@Norm2Methods.F90 | 123 + .../src/FEVariable_Method@PowerMethods.F90 | 52 + .../src/FEVariable_Method@SqrtMethods.F90 | 56 + .../FEVariable_Method@SubtractionMethods.F90 | 142 + .../src/include/MatrixElemMethod.F90 | 50 + .../src/include/MatrixOperatorMatrix.F90 | 129 + .../src/include/MatrixOperatorReal.F90 | 34 + .../src/include/MatrixOperatorScalar.F90 | 164 + .../FEVariable/src/include/MatrixPower.F90 | 92 + .../src/include/RealOperatorMatrix.F90 | 34 + .../src/include/RealOperatorScalar.F90 | 34 + .../src/include/RealOperatorVector.F90 | 43 + .../src/include/ScalarElemMethod.F90 | 61 + .../src/include/ScalarOperatorMatrix.F90 | 186 + .../src/include/ScalarOperatorReal.F90 | 34 + .../src/include/ScalarOperatorScalar.F90 | 148 + .../src/include/ScalarOperatorVector.F90 | 180 + .../FEVariable/src/include/ScalarPower.F90 | 42 + .../src/include/VectorElemMethod.F90 | 68 + .../src/include/VectorOperatorReal.F90 | 34 + .../src/include/VectorOperatorScalar.F90 | 120 + .../src/include/VectorOperatorVector.F90 | 130 + .../FEVariable/src/include/VectorPower.F90 | 93 + .../src/include/matrix_constant.F90 | 19 + .../src/include/matrix_constant2.F90 | 10 + .../FEVariable/src/include/matrix_space.F90 | 21 + .../FEVariable/src/include/matrix_space2.F90 | 10 + .../src/include/matrix_space_time.F90 | 23 + .../src/include/matrix_space_time2.F90 | 10 + .../FEVariable/src/include/matrix_time.F90 | 21 + .../FEVariable/src/include/matrix_time2.F90 | 10 + .../src/include/scalar_constant.F90 | 8 + .../FEVariable/src/include/scalar_space.F90 | 8 + .../src/include/scalar_space_time.F90 | 18 + .../src/include/scalar_space_time2.F90 | 12 + .../FEVariable/src/include/scalar_time.F90 | 8 + .../src/include/vector_constant.F90 | 10 + .../FEVariable/src/include/vector_space.F90 | 18 + .../FEVariable/src/include/vector_space2.F90 | 10 + .../src/include/vector_space_time.F90 | 21 + .../src/include/vector_space_time2.F90 | 10 + .../FEVariable/src/include/vector_time.F90 | 18 + .../FEVariable/src/include/vector_time2.F90 | 10 + src/submodules/FacetMatrix/CMakeLists.txt | 32 + ...acetMatrix_Method@FacetMatrix11Methods.F90 | 306 + ...acetMatrix_Method@FacetMatrix12Methods.F90 | 157 + ...acetMatrix_Method@FacetMatrix13Methods.F90 | 276 + ...acetMatrix_Method@FacetMatrix14Methods.F90 | 276 + ...acetMatrix_Method@FacetMatrix15Methods.F90 | 501 + ...FacetMatrix_Method@FacetMatrix1Methods.F90 | 373 + ...acetMatrix_Method@FacetMatrix21Methods.F90 | 127 + ...acetMatrix_Method@FacetMatrix22Methods.F90 | 127 + ...FacetMatrix_Method@FacetMatrix2Methods.F90 | 273 + ...FacetMatrix_Method@FacetMatrix3Methods.F90 | 324 + ...FacetMatrix_Method@FacetMatrix4Methods.F90 | 334 + ...FacetMatrix_Method@FacetMatrix5Methods.F90 | 602 + src/submodules/ForceVector/CMakeLists.txt | 13 + .../src/ForceVector_Method@Methods.F90 | 203 + src/submodules/Geometry/CMakeLists.txt | 39 + .../Geometry/src/Line_Method@Methods.F90 | 339 + .../Geometry/src/Plane_Method@Methods.F90 | 87 + ...renceElement_Method@ConstructorMethods.F90 | 367 + ...ReferenceElement_Method@EnquireMethods.F90 | 296 + ...enceElement_Method@FacetElementMethods.F90 | 223 + ...eferenceElement_Method@GeometryMethods.F90 | 560 + .../src/ReferenceElement_Method@IOMethods.F90 | 283 + ...eElement_Method@LocalNodeCoordsMethods.F90 | 429 + .../ReferenceElement_Method@VTKMethods.F90 | 154 + .../ReferenceHexahedron_Method@Methods.F90 | 629 + .../src/ReferenceLine_Method@Methods.F90 | 376 + .../src/ReferencePoint_Method@Methods.F90 | 102 + .../src/ReferencePrism_Method@Methods.F90 | 392 + .../src/ReferencePyramid_Method@Methods.F90 | 368 + .../ReferenceQuadrangle_Method@Methods.F90 | 660 + .../ReferenceTetrahedron_Method@Methods.F90 | 608 + .../src/ReferenceTriangle_Method@Methods.F90 | 849 + .../Geometry/src/Triangle_Method@Methods.F90 | 1435 + src/submodules/Geometry/src/inc/aux.inc | 239 + .../Geometry/src/modified_burkardt.inc | 266 + src/submodules/Hashing/CMakeLists.txt | 24 + .../Hashing/src/Hashing32@fnvMethods.F90 | 121 + .../Hashing/src/Hashing32@nmMethods.F90 | 903 + .../Hashing/src/Hashing32@waterMethods.F90 | 313 + src/submodules/Hashing/src/delme.F90 | 0 src/submodules/IndexValue/CMakeLists.txt | 13 + .../src/IndexValue_Method@Constructor.F90 | 59 + src/submodules/IntVector/CMakeLists.txt | 27 + .../src/IntVector_AppendMethod@Methods.F90 | 102 + .../IntVector_ConstructorMethod@Methods.F90 | 244 + .../src/IntVector_EnquireMethod@Methods.F90 | 119 + .../src/IntVector_GetMethod@Methods.F90 | 284 + .../src/IntVector_IOMethod@Methods.F90 | 55 + .../src/IntVector_SetMethod@Methods.F90 | 102 + .../IntVector/src/include/intvec_get_10.inc | 32 + .../IntVector/src/include/intvec_get_11.inc | 28 + .../IntVector/src/include/intvec_get_12.inc | 28 + .../IntVector/src/include/intvec_get_13.inc | 18 + src/submodules/IterationData/CMakeLists.txt | 23 + ...terationData_Method@ConstructorMethods.F90 | 179 + .../src/IterationData_Method@IOMethods.F90 | 44 + src/submodules/KeyValue/CMakeLists.txt | 15 + .../src/KeyValue_Method@Constructor.F90 | 505 + .../src/KeyValue_Method@getMethod.F90 | 186 + .../src/KeyValue_Method@setMethod.F90 | 138 + src/submodules/Lapack/CMakeLists.txt | 41 + .../src/GE_CompRoutineMethods@Methods.F90 | 74 + .../src/GE_EigenValueMethods@Methods.F90 | 203 + .../Lapack/src/GE_LUMethods@Methods.F90 | 144 + .../GE_Lapack_Method@CompRoutineMethods.F90 | 74 + .../GE_Lapack_Method@EigenvalueMethods.F90 | 29 + .../Lapack/src/GE_Lapack_Method@LUMethods.F90 | 144 + .../GE_Lapack_Method@LinearSolveMethods.F90 | 278 + .../src/GE_LinearSolveMethods@Methods.F90 | 278 + .../src/GE_SingularValueMethods@Methods.F90 | 29 + .../src/Sym_CompRoutineMethods@Methods.F90 | 16 + .../src/Sym_EigenValueMethods@Methods.F90 | 16 + .../Lapack/src/Sym_LUMethods@Methods.F90 | 507 + .../src/Sym_Lapack_Method@LUMethods.F90 | 506 + .../Sym_Lapack_Method@LinearSolveMethods.F90 | 215 + .../src/Sym_LinearSolveMethods@Methods.F90 | 216 + .../src/Sym_SingularValueMethods@Methods.F90 | 16 + src/submodules/MassMatrix/CMakeLists.txt | 22 + 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 | 326 + src/submodules/MdEncode/CMakeLists.txt | 22 + .../MdEncode/src/MdEncode_Method@Methods.F90 | 403 + .../MdEncode/src/inc/MdEncode_2.inc | 35 + .../MdEncode/src/inc/MdEncode_3.inc | 39 + .../MdEncode/src/inc/MdEncode_3b.inc | 25 + .../MdEncode/src/inc/MdEncode_6.inc | 109 + .../MdEncode/src/inc/MdEncode_7.inc | 121 + src/submodules/MultiIndices/CMakeLists.txt | 22 + .../src/MultiIndices_Method@Methods.F90 | 96 + src/submodules/OpenMP/CMakeLists.txt | 13 + .../OpenMP/src/OpenMP_Method@Constructor.F90 | 72 + src/submodules/Polynomial/CMakeLists.txt | 43 + .../Chebyshev1PolynomialUtility@Methods.F90 | 1150 + .../src/EquidistanceLIP_Tetrahedron.inc | 267 + .../src/EquidistanceLIP_Triangle.inc | 403 + ...HexahedronInterpolationUtility@Methods.F90 | 2950 ++ .../src/InterpolationUtility@Methods.F90 | 149 + .../src/JacobiPolynomialUtility@Methods.F90 | 1415 + .../src/LagrangePolynomialUtility@Methods.F90 | 927 + .../src/LegendrePolynomialUtility@Methods.F90 | 1182 + .../src/LineInterpolationUtility@Methods.F90 | 1404 + .../src/LobattoPolynomialUtility@Methods.F90 | 453 + .../OrthogonalPolynomialUtility@Methods.F90 | 159 + .../src/PrismInterpolationUtility@Methods.F90 | 285 + .../PyramidInterpolationUtility@Methods.F90 | 288 + ...QuadrangleInterpolationUtility@Methods.F90 | 2023 + .../src/QuadraturePoint_Tetrahedron_Solin.F90 | 3449 ++ ...adraturePoint_Triangle_InternalUseOnly.F90 | 477 + .../src/QuadraturePoint_Triangle_Solin.F90 | 2170 + .../src/RecursiveNodesUtility@Methods.F90 | 346 + ...etrahedronInterpolationUtility@Methods.F90 | 2587 ++ ...lationUtility@HeirarchicalBasisMethods.F90 | 666 + ...erpolationUtility@LagrangeBasisMethods.F90 | 346 + .../TriangleInterpolationUtility@Methods.F90 | 549 + ...polationUtility@OrthogonalBasisMethods.F90 | 116 + ...InterpolationUtility@QuadratureMethods.F90 | 219 + ...ltrasphericalPolynomialUtility@Methods.F90 | 1221 + ...scaledLobattoPolynomialUtility@Methods.F90 | 381 + .../TriangleInterpolationUtility@Methods.F90 | 376 + .../src/include/Quadrangle/edge_12.inc | 10 + .../src/include/Quadrangle/edge_14.inc | 9 + .../src/include/Quadrangle/edge_21.inc | 9 + .../src/include/Quadrangle/edge_23.inc | 10 + .../src/include/Quadrangle/edge_32.inc | 10 + .../src/include/Quadrangle/edge_34.inc | 10 + .../src/include/Quadrangle/edge_41.inc | 10 + .../src/include/Quadrangle/edge_43.inc | 10 + .../src/include/Quadrangle/vertex_1.inc | 8 + .../src/include/Quadrangle/vertex_2.inc | 8 + .../src/include/Quadrangle/vertex_3.inc | 8 + .../src/include/Quadrangle/vertex_4.inc | 8 + src/submodules/QuadraturePoint/CMakeLists.txt | 25 + ...draturePoint_Method@ConstructorMethods.F90 | 964 + .../src/QuadraturePoint_Method@GetMethods.F90 | 91 + .../src/QuadraturePoint_Method@IOMethods.F90 | 70 + src/submodules/Random/CMakeLists.txt | 22 + .../Random/src/Random_Method@Methods.F90 | 382 + src/submodules/Rank2Tensor/CMakeLists.txt | 19 + .../Rank2Tensor_Method@ConstructorMethods.F90 | 275 + .../Rank2Tensor_Method@ContractionMethods.F90 | 89 + .../src/Rank2Tensor_Method@IOMethods.F90 | 32 + .../src/Rank2Tensor_Method@InvarMethods.F90 | 335 + .../Rank2Tensor_Method@OperatorMethods.F90 | 163 + .../Rank2Tensor_Method@PullbackMethods.F90 | 90 + .../Rank2Tensor_Method@PushForwardMethods.F90 | 90 + .../Rank2Tensor/src/matrix_exponential.F90 | 502 + .../ContinuumSpin/ContinuumSpin_Class.F90 | 137 + .../DeformationGradient_Class.F90 | 218 + .../DeformationTensor.part | 100 + .../old data/DeformationGradient/Display.part | 120 + .../MdFiles/DeformationGradient_Class.md | 128 + .../DeformationGradient/StrainTensor.part | 112 + .../Rank2Tensor/src/old data/Interface.part | 314 + .../LeftCauchyGreen/LeftCauchyGreen_Class.F90 | 100 + .../old data/MaterialJacobian/Display.part | 71 + .../old data/MaterialJacobian/Initiate.part | 257 + .../MaterialJacobian/MaterialJacobian.part | 153 + .../MaterialJacobian_Class.F90 | 177 + .../MaterialJacobian_Pointer.part | 160 + .../MdFiles/MaterialJacobian_Class.md | 230 + .../src/old data/MaterialJacobian/Names.part | 174 + .../OperatorOverloading/Addition.part | 193 + .../OperatorOverloading/Asterics.part | 75 + .../OperatorOverloading/Cijkl.part | 424 + .../OperatorOverloading/Contraction.part | 130 + .../OperatorOverloading/Matmul.part | 91 + .../OperatorOverloading/Subtraction.part | 193 + .../old data/MaterialJacobian/getCijkl.part | 146 + .../src/old data/MdFiles/Tensor_Class.md | 2288 + .../src/old data/Old_Rank4Tensors.part | 518 + .../src/old data/Old_StrainMeasures.part | 349 + .../src/old data/Old_getCDash.part | 151 + .../src/old data/Old_getCSigmaTruesdell.part | 237 + .../src/old data/OperatorInterface.part | 217 + .../OperatorOverloading/Addition.part | 220 + .../OperatorOverloading/Asterics.part | 373 + .../OperatorOverloading/Determinant.part | 60 + .../old data/OperatorOverloading/Inverse.part | 65 + .../old data/OperatorOverloading/MatMul.part | 257 + .../old data/OperatorOverloading/Otimes.part | 292 + .../OperatorOverloading/Transpose.part | 72 + .../RightCauchyGreen_Class.F90 | 100 + .../old data/Strain/AlmansiStrain_Class.F90 | 145 + .../src/old data/Strain/GreenStrain_Class.F90 | 142 + .../src/old data/Strain/SmallStrain_Class.F90 | 88 + .../src/old data/Strain/Strain_Class.F90 | 96 + .../old data/StrainRate/StrainRate_Class.F90 | 137 + .../src/old data/Stress/CauchyStress.part | 109 + .../src/old data/Stress/Constructor.part | 563 + .../src/old data/Stress/Display.part | 71 + .../src/old data/Stress/EshelbyStress.part | 106 + .../src/old data/Stress/Interface.part | 0 .../src/old data/Stress/KirchhoffStress.part | 101 + .../old data/Stress/MdFiles/Stress_Class.md | 128 + .../Stress/OperatorOverloading/Addition.part | 372 + .../OperatorOverloading/Assignment.part | 94 + .../Stress/OperatorOverloading/Asterics.part | 445 + .../Stress/OperatorOverloading/Invariant.part | 346 + .../Stress/OperatorOverloading/Matmul.part | 334 + .../Stress/OperatorOverloading/Otimes.part | 422 + .../Stress/OperatorOverloading/Shape.part | 205 + .../src/old data/Stress/Pk1Stress.part | 108 + .../src/old data/Stress/Pk2Stress.part | 109 + .../Stress/SpectralDecomposition.part | 193 + .../src/old data/Stress/StressType.part | 57 + .../src/old data/Stress/Stress_Class.F90 | 355 + .../old data/Stress/TensorDecomposition.part | 126 + .../src/old data/Stress/getStress.part | 228 + .../src/old data/Stress_Old/Initiate.part | 48 + .../src/old data/Stress_Old/Invariants.part | 252 + .../Stress_Old/StressDecomposition.part | 66 + .../Stress_Old/StressDerivatives.part | 201 + .../src/old data/Stress_Old/Stress_Class.F90 | 126 + .../old data/Stress_Old/getHillTensor.part | 88 + .../src/old data/Stress_Old/getLength.part | 44 + .../src/old data/Stress_Old/getSigma.part | 60 + .../src/old data/Stress_Old/setSigma.part | 50 + .../Rank2Tensor/src/old data/Tensor.F90 | 33 + .../VelocityGradient_Class.F90 | 96 + src/submodules/RealMatrix/CMakeLists.txt | 28 + .../src/RealMatrix_Method@BLASMethods.F90 | 17 + .../RealMatrix_Method@ConstructorMethods.F90 | 295 + .../RealMatrix_Method@GetValuesMethods.F90 | 174 + .../src/RealMatrix_Method@IOMethods.F90 | 55 + ...alMatrix_Method@IterativeSolverMethods.F90 | 151 + .../src/RealMatrix_Method@LAPACKMethods.F90 | 22 + .../src/RealMatrix_Method@MatmulMethods.F90 | 49 + .../RealMatrix_Method@SetValuesMethods.F90 | 427 + src/submodules/RealVector/CMakeLists.txt | 34 + .../src/RealVector_AddMethods@Methods.F90 | 370 + .../src/RealVector_AppendMethods@Methods.F90 | 55 + .../src/RealVector_AssignMethods@Methods.F90 | 160 + .../src/RealVector_Blas1Methods@Methods.F90 | 426 + .../RealVector_ComparisonMethods@Methods.F90 | 52 + .../RealVector_ConstructorMethods@Methods.F90 | 265 + .../src/RealVector_GetMethods@Methods.F90 | 598 + .../RealVector_GetValueMethods@Methods.F90 | 526 + .../src/RealVector_IOMethods@Methods.F90 | 65 + .../RealVector_Norm2ErrorMethods@Methods.F90 | 183 + .../src/RealVector_Norm2Methods@Methods.F90 | 139 + .../src/RealVector_SetMethods@Methods.F90 | 362 + .../RealVector_ShallowCopyMethods@Methods.F90 | 156 + src/submodules/RealVector/src/Save_hdf5.F90 | 151 + .../STConvectiveMatrix/CMakeLists.txt | 13 + .../STConvectiveMatrix-old/Constructor.part | 139 + .../ConvectiveMatrix_10.part | 52 + .../ConvectiveMatrix_11.part | 199 + .../ConvectiveMatrix_12.part | 200 + .../ConvectiveMatrix_13.part | 239 + .../ConvectiveMatrix_14.part | 238 + .../ConvectiveMatrix_15.part | 53 + .../ConvectiveMatrix_16.part | 51 + .../ConvectiveMatrix_17.part | 53 + .../ConvectiveMatrix_18.part | 53 + .../ConvectiveMatrix_19.part | 347 + .../ConvectiveMatrix_20.part | 345 + .../ConvectiveMatrix_21.part | 316 + .../ConvectiveMatrix_22.part | 258 + .../ConvectiveMatrix_23.part | 50 + .../ConvectiveMatrix_24.part | 351 + .../ConvectiveMatrix_25.part | 347 + .../ConvectiveMatrix_26.part | 338 + .../ConvectiveMatrix_27.part | 200 + .../ConvectiveMatrix_28.part | 53 + .../ConvectiveMatrix_29.part | 208 + .../ConvectiveMatrix_30.part | 231 + .../ConvectiveMatrix_31.part | 229 + .../ConvectiveMatrix_32.part | 198 + .../ConvectiveMatrix_33.part | 238 + .../ConvectiveMatrix_34.part | 222 + .../ConvectiveMatrix_35.part | 163 + .../ConvectiveMatrix_36.part | 148 + .../ConvectiveMatrix_37.part | 248 + .../ConvectiveMatrix_38.part | 231 + .../ConvectiveMatrix_39.part | 177 + .../ConvectiveMatrix_9.part | 253 + .../MdFiles/STConvectiveMatrix_Class.md | 4393 ++ .../STConvectiveMatrix-old/MethodNames.part | 39 + .../STConvectiveMatrix_Class.f90 | 112 + .../STConvectiveMatrix/src/STCM_1.inc | 115 + .../STConvectiveMatrix/src/STCM_10.inc | 125 + .../STConvectiveMatrix/src/STCM_11.inc | 215 + .../STConvectiveMatrix/src/STCM_12.inc | 122 + .../STConvectiveMatrix/src/STCM_13.inc | 272 + .../STConvectiveMatrix/src/STCM_14.inc | 272 + .../STConvectiveMatrix/src/STCM_15.inc | 292 + .../STConvectiveMatrix/src/STCM_16.inc | 292 + .../STConvectiveMatrix/src/STCM_17.inc | 311 + .../STConvectiveMatrix/src/STCM_2.inc | 134 + .../STConvectiveMatrix/src/STCM_3.inc | 231 + .../STConvectiveMatrix/src/STCM_4.inc | 128 + .../STConvectiveMatrix/src/STCM_5.inc | 217 + .../STConvectiveMatrix/src/STCM_6.inc | 119 + .../STConvectiveMatrix/src/STCM_7.inc | 201 + .../STConvectiveMatrix/src/STCM_8.inc | 112 + .../STConvectiveMatrix/src/STCM_9.inc | 122 + .../src/STConvectiveMatrix_Method@Methods.F90 | 805 + .../STDiffusionMatrix/CMakeLists.txt | 13 + .../STDiffusionMatrix-old/Constructor.part | 138 + .../DiffusionMatrix_1.part | 93 + .../DiffusionMatrix_10.part | 175 + .../DiffusionMatrix_11.part | 126 + .../DiffusionMatrix_12.part | 187 + .../DiffusionMatrix_13.part | 183 + .../DiffusionMatrix_14.part | 161 + .../DiffusionMatrix_15.part | 160 + .../DiffusionMatrix_16.part | 152 + .../DiffusionMatrix_17.part | 150 + .../DiffusionMatrix_18.part | 53 + .../DiffusionMatrix_19.part | 52 + .../DiffusionMatrix_2.part | 50 + .../DiffusionMatrix_20.part | 53 + .../DiffusionMatrix_21.part | 53 + .../DiffusionMatrix_22.part | 53 + .../DiffusionMatrix_23.part | 54 + .../DiffusionMatrix_24.part | 55 + .../DiffusionMatrix_25.part | 54 + .../DiffusionMatrix_26.part | 54 + .../DiffusionMatrix_27.part | 234 + .../DiffusionMatrix_28.part | 234 + .../DiffusionMatrix_29.part | 222 + .../DiffusionMatrix_3.part | 136 + .../DiffusionMatrix_30.part | 180 + .../DiffusionMatrix_31.part | 211 + .../DiffusionMatrix_4.part | 137 + .../DiffusionMatrix_5.part | 128 + .../DiffusionMatrix_6.part | 50 + .../DiffusionMatrix_7.part | 51 + .../DiffusionMatrix_8.part | 50 + .../DiffusionMatrix_9.part | 194 + .../STDiffusionMatrix-old/MethodNames.part | 31 + .../STDiffusionMatrix_Class.f90 | 100 + .../STDiffusionMatrix_Class.md | 1971 + .../STDiffusionMatrix/src/STDM_1.inc | 64 + .../STDiffusionMatrix/src/STDM_11.inc | 147 + .../STDiffusionMatrix/src/STDM_12.inc | 181 + .../STDiffusionMatrix/src/STDM_13.inc | 155 + .../STDiffusionMatrix/src/STDM_14.inc | 188 + .../STDiffusionMatrix/src/STDM_2.inc | 60 + .../STDiffusionMatrix/src/STDM_3.inc | 66 + .../STDiffusionMatrix/src/STDM_4.inc | 63 + .../STDiffusionMatrix/src/STDM_5.inc | 79 + .../STDiffusionMatrix/src/STDM_6.inc | 71 + .../STDiffusionMatrix/src/STDM_7.inc | 64 + .../STDiffusionMatrix/src/STDM_8.inc | 73 + .../src/STDiffusionMatrix_Method@Methods.F90 | 1180 + src/submodules/STFextVector/Constructor.part | 152 + src/submodules/STFextVector/FextVector_1.part | 111 + .../STFextVector/FextVector_10.part | 141 + .../STFextVector/FextVector_11.part | 161 + .../STFextVector/FextVector_12.part | 138 + .../STFextVector/FextVector_13.part | 133 + .../STFextVector/FextVector_14.part | 131 + .../STFextVector/FextVector_15.part | 136 + .../STFextVector/FextVector_16.part | 122 + .../STFextVector/FextVector_17.part | 104 + .../STFextVector/FextVector_18.part | 131 + .../STFextVector/FextVector_19.part | 124 + src/submodules/STFextVector/FextVector_2.part | 112 + .../STFextVector/FextVector_20.part | 131 + .../STFextVector/FextVector_21.part | 121 + .../STFextVector/FextVector_22.part | 116 + .../STFextVector/FextVector_23.part | 113 + .../STFextVector/FextVector_24.part | 149 + .../STFextVector/FextVector_25.part | 142 + .../STFextVector/FextVector_26.part | 113 + src/submodules/STFextVector/FextVector_3.part | 97 + src/submodules/STFextVector/FextVector_4.part | 135 + src/submodules/STFextVector/FextVector_5.part | 127 + src/submodules/STFextVector/FextVector_6.part | 169 + src/submodules/STFextVector/FextVector_7.part | 154 + src/submodules/STFextVector/FextVector_8.part | 109 + src/submodules/STFextVector/FextVector_9.part | 161 + .../MdFiles/STFextVector_Class.md | 1845 + src/submodules/STFextVector/MethodNames.part | 26 + .../STFextVector/STFextVector_Class.f90 | 102 + src/submodules/STFextVector/delme.f90 | 338 + src/submodules/STFintVector/Constructor.part | 152 + src/submodules/STFintVector/FintVector_1.part | 113 + src/submodules/STFintVector/FintVector_2.part | 112 + src/submodules/STFintVector/FintVector_3.part | 100 + src/submodules/STFintVector/FintVector_4.part | 100 + src/submodules/STFintVector/FintVector_5.part | 96 + src/submodules/STFintVector/FintVector_6.part | 81 + src/submodules/STFintVector/FintVector_7.part | 138 + src/submodules/STFintVector/FintVector_8.part | 103 + .../MdFiles/STFintVector_Class.md | 61 + src/submodules/STFintVector/MethodNames.part | 8 + .../STFintVector/STFintVector_Class.f90 | 80 + src/submodules/STForceVector/CMakeLists.txt | 13 + src/submodules/STForceVector/src/STFV_1.inc | 55 + src/submodules/STForceVector/src/STFV_10.inc | 63 + src/submodules/STForceVector/src/STFV_11.inc | 63 + src/submodules/STForceVector/src/STFV_12.inc | 63 + src/submodules/STForceVector/src/STFV_13.inc | 68 + src/submodules/STForceVector/src/STFV_14.inc | 68 + src/submodules/STForceVector/src/STFV_15.inc | 53 + src/submodules/STForceVector/src/STFV_16.inc | 58 + src/submodules/STForceVector/src/STFV_17.inc | 63 + src/submodules/STForceVector/src/STFV_18.inc | 63 + src/submodules/STForceVector/src/STFV_19.inc | 63 + src/submodules/STForceVector/src/STFV_2.inc | 60 + src/submodules/STForceVector/src/STFV_20.inc | 68 + src/submodules/STForceVector/src/STFV_21.inc | 68 + src/submodules/STForceVector/src/STFV_3.inc | 64 + src/submodules/STForceVector/src/STFV_4.inc | 64 + src/submodules/STForceVector/src/STFV_5.inc | 66 + src/submodules/STForceVector/src/STFV_6.inc | 69 + src/submodules/STForceVector/src/STFV_7.inc | 69 + src/submodules/STForceVector/src/STFV_8.inc | 53 + src/submodules/STForceVector/src/STFV_9.inc | 58 + .../src/STForceVector_Method@Methods.F90 | 865 + src/submodules/STMassMatrix/CMakeLists.txt | 13 + .../STMassMatrix-old/Constructor.part | 144 + .../STMassMatrix-old/MassMatrix_15.part | 284 + .../STMassMatrix-old/MassMatrix_16.part | 343 + .../STMassMatrix-old/MassMatrix_17.part | 305 + .../STMassMatrix-old/MassMatrix_18.part | 241 + .../STMassMatrix-old/MassMatrix_3.part | 236 + .../STMassMatrix-old/STMassMatrix_Class.md | 596 + src/submodules/STMassMatrix/src/STMM_1.inc | 57 + src/submodules/STMassMatrix/src/STMM_10.inc | 80 + src/submodules/STMassMatrix/src/STMM_10a.inc | 32 + src/submodules/STMassMatrix/src/STMM_10b.inc | 32 + src/submodules/STMassMatrix/src/STMM_10c.inc | 32 + src/submodules/STMassMatrix/src/STMM_10d.inc | 31 + src/submodules/STMassMatrix/src/STMM_11.inc | 79 + src/submodules/STMassMatrix/src/STMM_11a.inc | 31 + src/submodules/STMassMatrix/src/STMM_11b.inc | 31 + src/submodules/STMassMatrix/src/STMM_11c.inc | 31 + src/submodules/STMassMatrix/src/STMM_11d.inc | 31 + src/submodules/STMassMatrix/src/STMM_12.inc | 77 + src/submodules/STMassMatrix/src/STMM_12a.inc | 31 + src/submodules/STMassMatrix/src/STMM_12b.inc | 31 + src/submodules/STMassMatrix/src/STMM_12c.inc | 31 + src/submodules/STMassMatrix/src/STMM_12d.inc | 31 + src/submodules/STMassMatrix/src/STMM_13.inc | 69 + src/submodules/STMassMatrix/src/STMM_14.inc | 79 + src/submodules/STMassMatrix/src/STMM_15.inc | 71 + src/submodules/STMassMatrix/src/STMM_16.inc | 74 + src/submodules/STMassMatrix/src/STMM_17.inc | 24 + .../STMassMatrix/src/STMM_17_20.inc | 65 + src/submodules/STMassMatrix/src/STMM_18.inc | 24 + src/submodules/STMassMatrix/src/STMM_19.inc | 24 + src/submodules/STMassMatrix/src/STMM_2.inc | 58 + src/submodules/STMassMatrix/src/STMM_20.inc | 24 + src/submodules/STMassMatrix/src/STMM_21.inc | 70 + src/submodules/STMassMatrix/src/STMM_21a.inc | 31 + src/submodules/STMassMatrix/src/STMM_21b.inc | 31 + src/submodules/STMassMatrix/src/STMM_21c.inc | 31 + src/submodules/STMassMatrix/src/STMM_21d.inc | 31 + src/submodules/STMassMatrix/src/STMM_22.inc | 81 + src/submodules/STMassMatrix/src/STMM_22a.inc | 32 + src/submodules/STMassMatrix/src/STMM_22b.inc | 32 + src/submodules/STMassMatrix/src/STMM_22c.inc | 32 + src/submodules/STMassMatrix/src/STMM_22d.inc | 31 + src/submodules/STMassMatrix/src/STMM_23.inc | 80 + src/submodules/STMassMatrix/src/STMM_23a.inc | 31 + src/submodules/STMassMatrix/src/STMM_23b.inc | 31 + src/submodules/STMassMatrix/src/STMM_23c.inc | 31 + src/submodules/STMassMatrix/src/STMM_23d.inc | 31 + src/submodules/STMassMatrix/src/STMM_24.inc | 77 + src/submodules/STMassMatrix/src/STMM_24a.inc | 31 + src/submodules/STMassMatrix/src/STMM_24b.inc | 31 + src/submodules/STMassMatrix/src/STMM_24c.inc | 31 + src/submodules/STMassMatrix/src/STMM_24d.inc | 31 + src/submodules/STMassMatrix/src/STMM_25.inc | 73 + src/submodules/STMassMatrix/src/STMM_26.inc | 84 + src/submodules/STMassMatrix/src/STMM_27.inc | 75 + src/submodules/STMassMatrix/src/STMM_28.inc | 77 + src/submodules/STMassMatrix/src/STMM_3.inc | 57 + src/submodules/STMassMatrix/src/STMM_4.inc | 57 + src/submodules/STMassMatrix/src/STMM_5.inc | 61 + src/submodules/STMassMatrix/src/STMM_6.inc | 61 + src/submodules/STMassMatrix/src/STMM_7.inc | 66 + src/submodules/STMassMatrix/src/STMM_8.inc | 61 + src/submodules/STMassMatrix/src/STMM_9.inc | 67 + src/submodules/STMassMatrix/src/STMM_9a.inc | 31 + src/submodules/STMassMatrix/src/STMM_9b.inc | 31 + src/submodules/STMassMatrix/src/STMM_9c.inc | 31 + src/submodules/STMassMatrix/src/STMM_9d.inc | 31 + .../src/STMassMatrix_Method@Methods.F90 | 3653 ++ .../STStiffnessMatrix/Constructor.part | 142 + .../MdFiles/STStiffnessMatrix_Class.md | 421 + .../STStiffnessMatrix/MethodNames.part | 14 + .../STStiffnessMatrix_Class.f90 | 85 + .../STStiffnessMatrix/StiffnessMatrix_1.part | 176 + .../STStiffnessMatrix/StiffnessMatrix_10.part | 106 + .../STStiffnessMatrix/StiffnessMatrix_11.part | 104 + .../STStiffnessMatrix/StiffnessMatrix_12.part | 85 + .../STStiffnessMatrix/StiffnessMatrix_13.part | 240 + .../STStiffnessMatrix/StiffnessMatrix_14.part | 106 + .../STStiffnessMatrix/StiffnessMatrix_2.part | 176 + .../STStiffnessMatrix/StiffnessMatrix_3.part | 171 + .../STStiffnessMatrix/StiffnessMatrix_4.part | 98 + .../STStiffnessMatrix/StiffnessMatrix_5.part | 98 + .../STStiffnessMatrix/StiffnessMatrix_6.part | 82 + .../STStiffnessMatrix/StiffnessMatrix_7.part | 229 + .../STStiffnessMatrix/StiffnessMatrix_8.part | 230 + .../STStiffnessMatrix/StiffnessMatrix_9.part | 221 + .../ST_Tau_SUPG_RGN/Constructor.part | 101 + .../MdFiles/._ST_TAU_SUPG_RGN_Class.md | Bin 0 -> 299 bytes .../MdFiles/ST_TAU_SUPG_RGN_Class.md | 1358 + .../ST_Tau_SUPG_RGN/MethodNamesForScalar.part | 12 + .../ST_Tau_SUPG_RGN/MethodNamesForVector.part | 12 + .../ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 | 100 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_1.part | 211 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_10.part | 223 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_11.part | 212 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_12.part | 64 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk | 190 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_2.part | 204 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_3.part | 178 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_4.part | 189 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_5.part | 178 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_6.part | 166 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_7.part | 234 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_8.part | 222 + .../ST_Tau_SUPG_RGN/SUPG_Scalar_9.part | 64 + .../ST_Tau_SUPG_RGN/SUPG_Vector_1.part | 211 + .../ST_Tau_SUPG_RGN/SUPG_Vector_10.part | 234 + .../ST_Tau_SUPG_RGN/SUPG_Vector_11.part | 222 + .../ST_Tau_SUPG_RGN/SUPG_Vector_12.part | 62 + .../ST_Tau_SUPG_RGN/SUPG_Vector_2.part | 199 + .../ST_Tau_SUPG_RGN/SUPG_Vector_3.part | 188 + .../ST_Tau_SUPG_RGN/SUPG_Vector_4.part | 200 + .../ST_Tau_SUPG_RGN/SUPG_Vector_5.part | 189 + .../ST_Tau_SUPG_RGN/SUPG_Vector_6.part | 177 + .../ST_Tau_SUPG_RGN/SUPG_Vector_7.part | 245 + .../ST_Tau_SUPG_RGN/SUPG_Vector_8.part | 234 + .../ST_Tau_SUPG_RGN/SUPG_Vector_9.part | 63 + src/submodules/StiffnessMatrix/CMakeLists.txt | 13 + .../src/StiffnessMatrix_Method@Methods.F90 | 338 + .../TriangleInterface/CMakeLists.txt | 21 + .../src/TriangleInterface@Methods.F90 | 179 + .../TriangleInterface/src/definemacro.h | 4 + .../TriangleInterface/src/undefinemacro.h | 4 + src/submodules/Utility/CMakeLists.txt | 55 + .../Utility/src/Append/Append_1.inc | 23 + .../Utility/src/Append/Append_1cd.inc | 27 + .../Utility/src/Append/Append_2.inc | 40 + .../Utility/src/Append/Append_2abcd.inc | 29 + .../Utility/src/Append/Append_2cd.inc | 53 + .../Utility/src/Append/Append_3.inc | 27 + .../Utility/src/Append/Append_3cd.inc | 38 + .../Utility/src/Append/Append_4.inc | 45 + .../Utility/src/Append/Append_4cd.inc | 63 + .../Utility/src/AppendUtility@Methods.F90 | 485 + .../Utility/src/ApproxUtility@Methods.F90 | 323 + .../Utility/src/ArangeUtility@Methods.F90 | 128 + .../Utility/src/AssertUtility@Methods.F90 | 214 + .../Utility/src/BinomUtility@Methods.F90 | 142 + .../Utility/src/ColConcat/ColConcat_1.inc | 22 + .../Utility/src/ColConcat/ColConcat_2.inc | 24 + .../Utility/src/ColConcat/ColConcat_3.inc | 24 + .../Utility/src/ColConcat/ColConcat_4.inc | 27 + .../src/ContractionUtility@Methods.F90 | 183 + .../Utility/src/ConvertUtility@Methods.F90 | 123 + src/submodules/Utility/src/Diag/SetDiag.inc | 62 + .../Utility/src/Diag/SetTriDiag.inc | 55 + src/submodules/Utility/src/Diag/Tridiag.inc | 23 + .../Utility/src/DiagUtility@Methods.F90 | 273 + .../Utility/src/EigenUtility@Methods.F90 | 335 + src/submodules/Utility/src/Expand/Expand.inc | 47 + .../Utility/src/Expand/ExpandMatrix.inc | 55 + .../Utility/src/EyeUtility@Methods.F90 | 120 + .../Utility/src/GridPointUtility@Methods.F90 | 239 + .../Utility/src/HashingUtility@Methods.F90 | 54 + .../Utility/src/HeadUtility@Methods.F90 | 67 + .../Utility/src/HeapSort/ArgHeapSort.inc | 76 + .../Utility/src/HeapSort/HeapSort.inc | 52 + src/submodules/Utility/src/In/In_1.inc | 32 + src/submodules/Utility/src/In/IsIn_1.inc | 23 + src/submodules/Utility/src/Input/Input1.inc | 22 + .../Utility/src/InputUtility@Methods.F90 | 150 + .../src/InsertionSort/ArgInsertionSort.inc | 28 + .../src/InsertionSort/InsertionSort.inc | 28 + .../Utility/src/IntegerUtility@Methods.F90 | 386 + .../Utility/src/Intersection/Intersection.inc | 22 + .../Utility/src/IntroSort/ArgIntroSort.inc | 16 + .../Utility/src/IntroSort/IntroSort.inc | 16 + .../src/IntroSort/Recursive_ArgIntroSort.inc | 31 + .../src/IntroSort/Recursive_IntroSort.inc | 32 + .../Utility/src/InvUtility@Methods.F90 | 225 + .../src/LinearAlgebraUtility@Methods.F90 | 65 + .../Utility/src/MappingUtility@Methods.F90 | 826 + .../Utility/src/MatmulUtility@Methods.F90 | 173 + .../Utility/src/Median/ArgMedian.inc | 20 + src/submodules/Utility/src/Median/Median.inc | 20 + .../Utility/src/MedianUtility@Methods.F90 | 119 + .../Utility/src/MiscUtility@Methods.F90 | 366 + .../Utility/src/OnesUtility@Methods.F90 | 253 + .../Utility/src/Partition/ArgPartition.inc | 34 + .../Utility/src/Partition/Partition.inc | 35 + .../Utility/src/PartitionUtility@Methods.F90 | 143 + .../Utility/src/ProductUtility@Methods.F90 | 500 + .../Utility/src/PushPop/Pop_Scalar.inc | 40 + .../Utility/src/PushPop/Push_Scalar.inc | 41 + .../Utility/src/PushPopUtility@Methods.F90 | 118 + .../Utility/src/QuickSort/QuickSort1Vec.inc | 34 + .../Utility/src/QuickSort/QuickSort2Vec.inc | 36 + .../Utility/src/QuickSort/QuickSort3Vec.inc | 38 + .../Utility/src/QuickSort/QuickSort4Vec.inc | 40 + .../Utility/src/ReallocateUtility@Methods.F90 | 1186 + .../RemoveDuplicates/RemoveDuplicates_1.inc | 46 + .../RemoveDuplicates/RemoveDuplicates_2.inc | 24 + .../Utility/src/Repeat/Repeat_1.inc | 23 + .../Utility/src/RowConcat/RowConcat_1.inc | 27 + .../Utility/src/RowConcat/RowConcat_2.inc | 28 + .../Utility/src/RowConcat/RowConcat_3.inc | 27 + .../Utility/src/RowConcat/RowConcat_4.inc | 28 + .../Utility/src/SafeSizeUtility@Methods.F90 | 64 + src/submodules/Utility/src/Sort/ArgSort.inc | 35 + src/submodules/Utility/src/Sort/Sort.inc | 37 + .../Utility/src/SortUtility@Methods.F90 | 615 + .../Utility/src/SplitUtility@Methods.F90 | 93 + .../Utility/src/StringUtility@Methods.F90 | 547 + .../Utility/src/SwapUtility@Methods.F90 | 817 + src/submodules/Utility/src/Sym/GetSym.inc | 28 + src/submodules/Utility/src/Sym/Sym.inc | 36 + .../Utility/src/SymUtility@Methods.F90 | 78 + .../Utility/src/TailUtility@Methods.F90 | 103 + src/submodules/Utility/src/Triag/GetTril1.inc | 26 + src/submodules/Utility/src/Triag/GetTril2.inc | 34 + src/submodules/Utility/src/Triag/GetTriu1.inc | 26 + src/submodules/Utility/src/Triag/GetTriu2.inc | 33 + src/submodules/Utility/src/Triag/SetTril1.inc | 25 + src/submodules/Utility/src/Triag/SetTril2.inc | 32 + src/submodules/Utility/src/Triag/SetTril3.inc | 25 + src/submodules/Utility/src/Triag/SetTriu1.inc | 25 + src/submodules/Utility/src/Triag/SetTriu2.inc | 31 + src/submodules/Utility/src/Triag/SetTriu3.inc | 25 + src/submodules/Utility/src/Triag/Tril1.inc | 26 + src/submodules/Utility/src/Triag/Tril2.inc | 34 + src/submodules/Utility/src/Triag/Triu1.inc | 26 + src/submodules/Utility/src/Triag/Triu2.inc | 33 + .../Utility/src/TriagUtility@Methods.F90 | 434 + .../Utility/src/ZerosUtility@Methods.F90 | 281 + .../src/inc/EquidistanceLIP_Tetrahedron.inc | 267 + .../src/inc/EquidistanceLIP_Triangle.inc | 403 + .../Vector/ToDo/VectorOperations.part | 366 + src/submodules/Vector3D/CMakeLists.txt | 14 + .../Vector3D/Vector3D_Method@Misc.F90 | 0 .../src/Vector3D_Method@Constructor.F90 | 143 + .../Vector3D/src/Vector3D_Method@Misc.F90 | 152 + .../VoigtRank2Tensor/CMakeLists.txt | 14 + .../VoigtRank2Tensor_Method@Constructor.F90 | 125 + .../src/VoigtRank2Tensor_Method@IO.F90 | 42 + 1593 files changed, 417344 insertions(+) create mode 100644 .fortls create mode 100644 .gitattributes create mode 100644 .gitconfig create mode 100644 .github/.pr-labeler.yml create mode 100644 .github/ISSUE_TEMPLATE/bug_report.md create mode 100644 .github/ISSUE_TEMPLATE/feature_request.md create mode 100644 .github/ISSUE_TEMPLATE/inspiration.md create mode 100644 .github/workflows/pr-labeler.yml create mode 100644 .gitignore create mode 100644 .vscode/settings.json create mode 100644 .vscode/tasks.json create mode 100644 CMakeLists.txt create mode 100644 CMakePresets.json create mode 100644 FORDsetup.md create mode 100644 LICENSE create mode 100644 LICENSE.gpl3.md create mode 100644 README.md create mode 100644 Workspaces/BLAS.code-workspace create mode 100644 Workspaces/OpenMP.code-workspace create mode 100644 Workspaces/Polynomial create mode 100644 Workspaces/SparseMatrix.code-workspace create mode 100644 Workspaces/Tensor.code-workspace create mode 100644 Workspaces/Utility.code-workspace create mode 100644 Workspaces/refelem.code-workspace create mode 100644 base.code-workspace create mode 100755 build.py create mode 100644 cmake/Config.cmake.in create mode 100644 cmake/Modules/FindLAPACK.cmake create mode 100644 cmake/addARPACK.cmake create mode 100644 cmake/addFFTW.cmake create mode 100644 cmake/addGTKFortran.cmake create mode 100644 cmake/addLIS.cmake create mode 100644 cmake/addLapack95.cmake create mode 100644 cmake/addLua.cmake create mode 100644 cmake/addMetis.cmake create mode 100644 cmake/addOpenBLAS.cmake create mode 100644 cmake/addOpenMP.cmake create mode 100644 cmake/addPLPLOT.cmake create mode 100644 cmake/addRaylib.cmake create mode 100644 cmake/addSparsekit.cmake create mode 100644 cmake/addSuperLU.cmake create mode 100644 cmake/addToml.cmake create mode 100644 cmake/packaging.cmake create mode 100644 compile_commands.json create mode 100644 easifemBase.py create mode 100644 easifemvar.sh create mode 100644 figures/banner.jpeg create mode 100644 figures/favicon.ico create mode 100644 figures/figure-1.svg create mode 100644 figures/figure-2.svg create mode 100644 figures/logo_hero.svg create mode 100644 figures/what-is-easifem.svg create mode 100644 fortran.json create mode 100755 install.py create mode 100644 neovim.json create mode 100644 package-lock.json create mode 100644 package.json create mode 100644 package.py create mode 100644 pages/BaseMethods.md create mode 100644 pages/BaseType.md create mode 100644 pages/Environment.md create mode 100644 pages/Extpkgs.md create mode 100644 pages/Install_Linux.md create mode 100644 pages/Install_MacOSX.md create mode 100644 pages/Install_Windows.md create mode 100644 pages/IntVector_.md create mode 100755 release_install.py create mode 100644 selected create mode 100644 setup.py create mode 100644 setup/install_pkgs_Darwin.sh create mode 100644 setup/install_pkgs_Ubuntu.sh create mode 100644 setup/requirements.txt create mode 100644 setup/set_envvar_CentOS.sh create mode 100644 setup/set_envvar_Darwin.sh create mode 100644 setup/set_envvar_Ubuntu.sh create mode 100644 src/modules/ARPACK/CMakeLists.txt create mode 100644 src/modules/ARPACK/src/ARPACK_SAUPD.F90 create mode 100644 src/modules/ARPACK/src/EASIFEM_ARPACK.F90 create mode 100644 src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 create mode 100644 src/modules/BLAS95/CMakeLists.txt create mode 100755 src/modules/BLAS95/aux/blas95.lst create mode 100644 src/modules/BLAS95/aux/test.F90 create mode 100755 src/modules/BLAS95/src/F77_BLAS.F90 create mode 100644 src/modules/BLAS95/src/F95_BLAS.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/caxpby.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/caxpy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/caxpyi.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ccopy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cdotc.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cdotci.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cdotu.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cdotui.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgem2vc.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgemm3m.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgemmt.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgerc.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgeru.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgthr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cgthrz.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/chbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/chemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/chemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cher.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cher2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cher2k.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cherk.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/chpmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/chpr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/chpr2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/crotg.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cscal.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/csctr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/csrot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/csscal.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/cswap.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/csymm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/csyr2k.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/csyrk.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctbsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctpmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctpsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctrmm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctrmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctrsm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ctrsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dasum.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/daxpby.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/daxpy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/daxpyi.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dcabs1.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dcopy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ddot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ddoti.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgem2vu.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgemmt.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dger.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgthr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dgthrz.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dnrm2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/drot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/drotg.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/droti.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/drotm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/drotmg.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dscal.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsctr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsdot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dspmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dspr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dspr2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dswap.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsymm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsymv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsyr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsyr2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsyr2k.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dsyrk.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtbsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtpmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtpsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtrmm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtrmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtrsm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dtrsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dzasum.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dzgemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dzgemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/dznrm2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/icamax.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/icamin.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/idamax.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/idamin.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/isamax.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/isamin.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/izamax.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/izamin.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sasum.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/saxpby.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/saxpy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/saxpyi.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/scabs1.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/scasum.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/scgemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/scgemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/scnrm2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/scopy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sdot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sdoti.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sdsdot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgem2vu.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgemmt.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sger.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgthr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sgthrz.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/snrm2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/srot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/srotg.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sroti.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/srotm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/srotmg.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sscal.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssctr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sspmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sspr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sspr2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/sswap.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssymm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssymv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssyr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssyr2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssyr2k.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ssyrk.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/stbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/stbsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/stpmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/stpsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/strmm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/strmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/strsm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/strsm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/strsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zaxpby.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zaxpy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zaxpyi.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zcopy.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zdotc.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zdotci.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zdotu.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zdotui.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zdrot.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zdscal.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgem2vc.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgemm3m.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgemmt.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgerc.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgeru.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgthr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zgthrz.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zhbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zhemm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zhemv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zher.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zher2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zher2k.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zherk.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zhpmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zhpr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zhpr2.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zrotg.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zscal.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zsctr.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zswap.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zsymm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zsyr2k.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/zsyrk.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztbmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztbsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztpmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztpsv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztrmm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztrmv.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztrsm.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 create mode 100755 src/modules/BLAS95/src/blas95_src/ztrsv.F90 create mode 100644 src/modules/BLAS95/src/easifem_blas_interface.inc create mode 100644 src/modules/BaseContinuity/CMakeLists.txt create mode 100644 src/modules/BaseContinuity/src/BaseContinuity_Method.F90 create mode 100644 src/modules/BaseInterpolation/CMakeLists.txt create mode 100644 src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 create mode 100644 src/modules/BaseMethod/CMakeLists.txt create mode 100644 src/modules/BaseMethod/src/BaseMethod.F90 create mode 100644 src/modules/BaseType/CMakeLists.txt create mode 100644 src/modules/BaseType/src/BaseType.F90 create mode 100644 src/modules/BeFoR64/CMakeLists.txt create mode 100644 src/modules/BeFoR64/src/befor64.F90 create mode 100644 src/modules/BeFoR64/src/befor64_pack_data_m.F90 create mode 100644 src/modules/BoundingBox/CMakeLists.txt create mode 100644 src/modules/BoundingBox/src/BoundingBox_Method.F90 create mode 100644 src/modules/CInterface/CMakeLists.txt create mode 100644 src/modules/CInterface/src/CInterface.F90 create mode 100644 src/modules/CMakeLists.txt create mode 100644 src/modules/CSRMatrix/CMakeLists.txt create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_Method.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 create mode 100644 src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 create mode 100644 src/modules/CSRSparsity/CMakeLists.txt create mode 100644 src/modules/CSRSparsity/src/CSRSparsity_Method.F90 create mode 100644 src/modules/ConvectiveMatrix/CMakeLists.txt create mode 100644 src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 create mode 100644 src/modules/DOF/CMakeLists.txt create mode 100644 src/modules/DOF/src/DOF_AddMethods.F90 create mode 100644 src/modules/DOF/src/DOF_ConstructorMethods.F90 create mode 100644 src/modules/DOF/src/DOF_GetMethods.F90 create mode 100644 src/modules/DOF/src/DOF_GetValueMethods.F90 create mode 100644 src/modules/DOF/src/DOF_IOMethods.F90 create mode 100644 src/modules/DOF/src/DOF_Method.F90 create mode 100644 src/modules/DOF/src/DOF_SetMethods.F90 create mode 100644 src/modules/DiffusionMatrix/CMakeLists.txt create mode 100644 src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 create mode 100644 src/modules/Display/CMakeLists.txt create mode 100644 src/modules/Display/src/Display_Mat2.inc create mode 100644 src/modules/Display/src/Display_Mat3.inc create mode 100644 src/modules/Display/src/Display_Mat4.inc create mode 100755 src/modules/Display/src/Display_Method.F90 create mode 100644 src/modules/Display/src/Display_Scalar.inc create mode 100644 src/modules/Display/src/Display_Vector.inc create mode 100755 src/modules/Display/src/References/dispmodule-userman.pdf create mode 100755 src/modules/Display/src/disp/disp_charmod.F90 create mode 100755 src/modules/Display/src/disp/disp_i1mod.F90 create mode 100755 src/modules/Display/src/disp/disp_i2mod.F90 create mode 100755 src/modules/Display/src/disp/disp_i4mod.F90 create mode 100755 src/modules/Display/src/disp/disp_i8mod.F90 create mode 100755 src/modules/Display/src/disp/disp_l1mod.F90 create mode 100755 src/modules/Display/src/disp/disp_r16mod.F90 create mode 100755 src/modules/Display/src/disp/disp_r4mod.F90 create mode 100755 src/modules/Display/src/disp/disp_r8mod.F90 create mode 100755 src/modules/Display/src/disp/dispmodule.F90 create mode 100644 src/modules/Display/src/disp/dispmodule_util.F90 create mode 100644 src/modules/Display/src/disp/putstrmodule.F90 create mode 100644 src/modules/ElasticNitscheMatrix/CMakeLists.txt create mode 100644 src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 create mode 100644 src/modules/ElemshapeData/CMakeLists.txt create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_Method.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 create mode 100644 src/modules/ErrorHandling/CMakeLists.txt create mode 100644 src/modules/ErrorHandling/src/ErrorHandling.F90 create mode 100644 src/modules/FACE/CMakeLists.txt create mode 100644 src/modules/FACE/src/face.F90 create mode 100644 src/modules/FEMatrix/CMakeLists.txt create mode 100644 src/modules/FEMatrix/src/FEMatrix_Method.F90 create mode 100644 src/modules/FEVariable/CMakeLists.txt create mode 100644 src/modules/FEVariable/src/FEVariable_Method.F90 create mode 100644 src/modules/FEVector/CMakeLists.txt create mode 100644 src/modules/FEVector/src/FEVector_Method.F90 create mode 100644 src/modules/FFTW/CMakeLists.txt create mode 100644 src/modules/FFTW/src/FFTW3.F90 create mode 100644 src/modules/FPL/CMakeLists.txt create mode 100644 src/modules/FPL/LICENSE create mode 100644 src/modules/FPL/src/ErrorMessages.F90 create mode 100644 src/modules/FPL/src/FPL.F90 create mode 100644 src/modules/FPL/src/FPL_utils.F90 create mode 100644 src/modules/FPL/src/ParameterEntry.F90 create mode 100644 src/modules/FPL/src/ParameterEntryDictionary.F90 create mode 100644 src/modules/FPL/src/ParameterList.F90 create mode 100644 src/modules/FPL/src/ParameterRootEntry.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 create mode 100644 src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 create mode 100644 src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 create mode 100644 src/modules/FacetMatrix/CMakeLists.txt create mode 100644 src/modules/FacetMatrix/src/FacetMatrix1.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix11.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix12.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix13.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix14.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix15.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix2.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix21.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix22.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix3.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix4.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix5.inc create mode 100644 src/modules/FacetMatrix/src/FacetMatrix_Method.F90 create mode 100644 src/modules/ForceVector/CMakeLists.txt create mode 100644 src/modules/ForceVector/src/ForceVector_Method.F90 create mode 100644 src/modules/Geometry/CMakeLists.txt create mode 100644 src/modules/Geometry/src/Geometry_Method.F90 create mode 100644 src/modules/Geometry/src/Line_Method.F90 create mode 100644 src/modules/Geometry/src/Plane_Method.F90 create mode 100644 src/modules/Geometry/src/ReferenceElement_Method.F90 create mode 100644 src/modules/Geometry/src/ReferenceHexahedron_Method.F90 create mode 100644 src/modules/Geometry/src/ReferenceLine_Method.F90 create mode 100644 src/modules/Geometry/src/ReferencePrism_Method.F90 create mode 100644 src/modules/Geometry/src/ReferencePyramid_Method.F90 create mode 100644 src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 create mode 100644 src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 create mode 100644 src/modules/Geometry/src/ReferenceTriangle_Method.F90 create mode 100644 src/modules/Geometry/src/Triangle_Method.F90 create mode 100644 src/modules/Geometry/src/assets/geometry_burkardt_line.inc create mode 100644 src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc create mode 100644 src/modules/Geometry/src/assets/geometry_by_burkardt.inc create mode 100644 src/modules/GlobalData/CMakeLists.txt create mode 100644 src/modules/GlobalData/src/ElementNames.txt create mode 100755 src/modules/GlobalData/src/GlobalData.F90 create mode 100644 src/modules/Gnuplot/CMakeLists.txt create mode 100644 src/modules/Gnuplot/src/ogpf.F90 create mode 100644 src/modules/Hashing/CMakeLists.txt create mode 100644 src/modules/Hashing/src/Hashing32.F90 create mode 100644 src/modules/IndexValue/CMakeLists.txt create mode 100644 src/modules/IndexValue/src/IndexValue_Method.F90 create mode 100644 src/modules/IntVector/CMakeLists.txt create mode 100644 src/modules/IntVector/src/IntVector_AppendMethod.F90 create mode 100644 src/modules/IntVector/src/IntVector_ConstructorMethod.F90 create mode 100644 src/modules/IntVector/src/IntVector_EnquireMethod.F90 create mode 100644 src/modules/IntVector/src/IntVector_GetMethod.F90 create mode 100644 src/modules/IntVector/src/IntVector_IOMethod.F90 create mode 100644 src/modules/IntVector/src/IntVector_Method.F90 create mode 100644 src/modules/IntVector/src/IntVector_SetMethod.F90 create mode 100644 src/modules/IterationData/CMakeLists.txt create mode 100644 src/modules/IterationData/src/IterationData_Method.F90 create mode 100644 src/modules/Kdtree2/CMakeLists.txt create mode 100644 src/modules/Kdtree2/src/Kd2PQueue_Module.F90 create mode 100644 src/modules/Kdtree2/src/Kdtree2_Module.F90 create mode 100644 src/modules/KeyValue/CMakeLists.txt create mode 100644 src/modules/KeyValue/src/KeyValue_Method.F90 create mode 100644 src/modules/LISInterface/CMakeLists.txt create mode 100644 src/modules/LISInterface/src/LISBasic.F90 create mode 100644 src/modules/LISInterface/src/LISInterface.F90 create mode 100644 src/modules/LISInterface/src/LISParam.F90 create mode 100644 src/modules/LISInterface/src/LISVector.F90 create mode 100644 src/modules/Lapack/CMakeLists.txt create mode 100644 src/modules/Lapack/src/GE_CompRoutineMethods.F90 create mode 100644 src/modules/Lapack/src/GE_EigenValueMethods.F90 create mode 100644 src/modules/Lapack/src/GE_LUMethods.F90 create mode 100644 src/modules/Lapack/src/GE_Lapack_Method.F90 create mode 100644 src/modules/Lapack/src/GE_LinearSolveMethods.F90 create mode 100644 src/modules/Lapack/src/GE_SingularValueMethods.F90 create mode 100644 src/modules/Lapack/src/Lapack_Method.F90 create mode 100644 src/modules/Lapack/src/Sym_CompRoutineMethods.F90 create mode 100644 src/modules/Lapack/src/Sym_EigenValueMethods.F90 create mode 100644 src/modules/Lapack/src/Sym_LUMethods.F90 create mode 100644 src/modules/Lapack/src/Sym_Lapack_Method.F90 create mode 100644 src/modules/Lapack/src/Sym_LinearSolveMethods.F90 create mode 100644 src/modules/Lapack/src/Sym_SingularValueMethods.F90 create mode 100644 src/modules/LuaInterface/CMakeLists.txt create mode 100644 src/modules/LuaInterface/src/LuaInterface.F90 create mode 100644 src/modules/LuaInterface/src/No_LuaInterface.F90 create mode 100644 src/modules/Macro/vectorclass.inc create mode 100644 src/modules/MassMatrix/CMakeLists.txt create mode 100644 src/modules/MassMatrix/src/MassMatrix_Method.F90 create mode 100644 src/modules/MdEncode/CMakeLists.txt create mode 100644 src/modules/MdEncode/src/MdEncode_Method.F90 create mode 100644 src/modules/MetisInterface/CMakeLists.txt create mode 100644 src/modules/MetisInterface/src/MetisInterface.F90 create mode 100644 src/modules/MetisInterface/src/MetisInterface.inc create mode 100644 src/modules/MultiIndices/CMakeLists.txt create mode 100644 src/modules/MultiIndices/src/MultiIndices_Method.F90 create mode 100644 src/modules/OpenMP/CMakeLists.txt create mode 100644 src/modules/OpenMP/src/OpenMP_Method.F90 create mode 100644 src/modules/PENF/CMakeLists.txt create mode 100644 src/modules/PENF/LICENSE.gpl3.md create mode 100644 src/modules/PENF/src/BCTON.inc create mode 100644 src/modules/PENF/src/BSTR.inc create mode 100644 src/modules/PENF/src/COMPACT_REAL_STRING.inc create mode 100644 src/modules/PENF/src/CTOA.inc create mode 100644 src/modules/PENF/src/STR.inc create mode 100644 src/modules/PENF/src/STRZ.inc create mode 100644 src/modules/PENF/src/STR_ASCII.inc create mode 100644 src/modules/PENF/src/STR_UCS4.inc create mode 100644 src/modules/PENF/src/penf.F90 create mode 100644 src/modules/PENF/src/penf_b_size.F90 create mode 100644 src/modules/PENF/src/penf_global_parameters_variables.F90 create mode 100644 src/modules/PENF/src/penf_stringify.F90 create mode 100644 src/modules/Polynomial/CMakeLists.txt create mode 100644 src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/InterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/JacobiPolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/LagrangePolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/LegendrePolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/LineInterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/LobattoPolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/PolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/PrismInterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/PyramidInterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/RecursiveNodesUtility.F90 create mode 100644 src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/TriangleInterpolationUtility.F90 create mode 100644 src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 create mode 100644 src/modules/QuadraturePoint/CMakeLists.txt create mode 100755 src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 create mode 100644 src/modules/Random/CMakeLists.txt create mode 100644 src/modules/Random/src/Random_Method.F90 create mode 100644 src/modules/Rank2Tensor/CMakeLists.txt create mode 100644 src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 create mode 100644 src/modules/RaylibInterface/CMakeLists.txt create mode 100644 src/modules/RaylibInterface/src/Raylib.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibCamera.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibCheckMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibDrawMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibEnums.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibGenMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibGetMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibImageMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibIsMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibLoadMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibMath.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibSetMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibTypes.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 create mode 100644 src/modules/RaylibInterface/src/RaylibUtil.F90 create mode 100644 src/modules/RaylibInterface/src/__Raylib.F90 create mode 100644 src/modules/RealMatrix/CMakeLists.txt create mode 100644 src/modules/RealMatrix/src/RealMatrix_Method.F90 create mode 100644 src/modules/RealVector/CMakeLists.txt create mode 100644 src/modules/RealVector/src/RealVector_AddMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_AppendMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_AssignMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_Blas1Methods.F90 create mode 100644 src/modules/RealVector/src/RealVector_ComparisonMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_ConstructorMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_GetMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_GetValueMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_IOMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_Method.F90 create mode 100644 src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_Norm2Methods.F90 create mode 100644 src/modules/RealVector/src/RealVector_SetMethods.F90 create mode 100644 src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 create mode 100644 src/modules/STConvectiveMatrix/CMakeLists.txt create mode 100644 src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 create mode 100644 src/modules/STConvectiveMatrix/src/del.inc create mode 100644 src/modules/STDiffusionMatrix/CMakeLists.txt create mode 100644 src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 create mode 100644 src/modules/STForceVector/CMakeLists.txt create mode 100644 src/modules/STForceVector/src/STForceVector_Method.F90 create mode 100644 src/modules/STMassMatrix/CMakeLists.txt create mode 100644 src/modules/STMassMatrix/src/STMassMatrix_Method.F90 create mode 100644 src/modules/StiffnessMatrix/CMakeLists.txt create mode 100644 src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 create mode 100644 src/modules/String/CMakeLists.txt create mode 100644 src/modules/String/src/String_Class.F90 create mode 100644 src/modules/String/src/String_Method.F90 create mode 100644 src/modules/SuperLUInterface/CMakeLists.txt create mode 100644 src/modules/SuperLUInterface/src/SuperLUInterface.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_Enums.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_Types.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_Util_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsitrf_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 create mode 100644 src/modules/SuperLUInterface/src/include/macros.inc create mode 100644 src/modules/System/CMakeLists.txt create mode 100755 src/modules/System/src/System_Method.F90 create mode 100755 src/modules/System/src/System_Method.c create mode 100644 src/modules/Test/CMakeLists.txt create mode 100644 src/modules/Test/src/README.txt create mode 100644 src/modules/Test/src/Test_Base.F90 create mode 100644 src/modules/Test/src/Test_Is.F90 create mode 100644 src/modules/Test/src/Test_Method.F90 create mode 100644 src/modules/Test/src/Test_More.F90 create mode 100644 src/modules/Test/src/Test_Planning.F90 create mode 100644 src/modules/Test/src/is_i.inc create mode 100644 src/modules/Test/src/is_r.inc create mode 100644 src/modules/TriangleInterface/CMakeLists.txt create mode 100644 src/modules/TriangleInterface/src/TriangleInterface.F90 create mode 100644 src/modules/TriangleInterface/src/report.c create mode 100644 src/modules/TriangleInterface/src/triangle.c create mode 100644 src/modules/TriangleInterface/src/triangle.h create mode 100644 src/modules/Utility/CMakeLists.txt create mode 100644 src/modules/Utility/src/AppendUtility.F90 create mode 100644 src/modules/Utility/src/ApproxUtility.F90 create mode 100644 src/modules/Utility/src/ArangeUtility.F90 create mode 100644 src/modules/Utility/src/AssertUtility.F90 create mode 100644 src/modules/Utility/src/BinomUtility.F90 create mode 100644 src/modules/Utility/src/ContractionUtility.F90 create mode 100644 src/modules/Utility/src/ConvertUtility.F90 create mode 100644 src/modules/Utility/src/DiagUtility.F90 create mode 100644 src/modules/Utility/src/EigenUtility.F90 create mode 100644 src/modules/Utility/src/EyeUtility.F90 create mode 100644 src/modules/Utility/src/GridPointUtility.F90 create mode 100644 src/modules/Utility/src/HashingUtility.F90 create mode 100644 src/modules/Utility/src/HeadUtility.F90 create mode 100644 src/modules/Utility/src/InputUtility.F90 create mode 100644 src/modules/Utility/src/IntegerUtility.F90 create mode 100644 src/modules/Utility/src/InvUtility.F90 create mode 100644 src/modules/Utility/src/LinearAlgebraUtility.F90 create mode 100644 src/modules/Utility/src/MappingUtility.F90 create mode 100644 src/modules/Utility/src/MatmulUtility.F90 create mode 100644 src/modules/Utility/src/MedianUtility.F90 create mode 100644 src/modules/Utility/src/MiscUtility.F90 create mode 100644 src/modules/Utility/src/OnesUtility.F90 create mode 100644 src/modules/Utility/src/PartitionUtility.F90 create mode 100644 src/modules/Utility/src/ProductUtility.F90 create mode 100644 src/modules/Utility/src/PushPopUtility.F90 create mode 100644 src/modules/Utility/src/ReallocateUtility.F90 create mode 100644 src/modules/Utility/src/SafeSizeUtility.F90 create mode 100644 src/modules/Utility/src/SortUtility.F90 create mode 100644 src/modules/Utility/src/SplitUtility.F90 create mode 100644 src/modules/Utility/src/StringUtility.F90 create mode 100644 src/modules/Utility/src/SwapUtility.F90 create mode 100644 src/modules/Utility/src/SymUtility.F90 create mode 100644 src/modules/Utility/src/TailUtility.F90 create mode 100644 src/modules/Utility/src/TriagUtility.F90 create mode 100755 src/modules/Utility/src/Utility.F90 create mode 100644 src/modules/Utility/src/ZerosUtility.F90 create mode 100644 src/modules/Utility/src/refs/mathPlantFEM.inc create mode 100644 src/modules/Vector3D/CMakeLists.txt create mode 100644 src/modules/Vector3D/src/Vector3D_Method.F90 create mode 100644 src/modules/VoigtRank2Tensor/CMakeLists.txt create mode 100644 src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 create mode 100644 src/modules/easifemBase/CMakeLists.txt create mode 100644 src/modules/easifemBase/src/easifemBase.F90 create mode 100644 src/submodules/ARPACK/CMakeLists.txt create mode 100644 src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 create mode 100644 src/submodules/BoundingBox/CMakeLists.txt create mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 create mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 create mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 create mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 create mode 100644 src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 create mode 100644 src/submodules/CMakeLists.txt create mode 100644 src/submodules/CSRMatrix/CMakeLists.txt create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 create mode 100644 src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 create mode 100644 src/submodules/CSRSparsity/CMakeLists.txt create mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 create mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 create mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 create mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 create mode 100644 src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 create mode 100644 src/submodules/ConvectiveMatrix/CMakeLists.txt create mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part create mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part create mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part create mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part create mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part create mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 create mode 100755 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md create mode 100644 src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part create mode 100644 src/submodules/ConvectiveMatrix/src/CM_1.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_10.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_2.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_3.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_4.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_5.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_6.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_7.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_8.inc create mode 100644 src/submodules/ConvectiveMatrix/src/CM_9.inc create mode 100644 src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 create mode 100644 src/submodules/DOF/CMakeLists.txt create mode 100644 src/submodules/DOF/src/DOF_AddMethods@Methods.F90 create mode 100644 src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 create mode 100644 src/submodules/DOF/src/DOF_GetMethods@Methods.F90 create mode 100644 src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 create mode 100644 src/submodules/DOF/src/DOF_IOMethods@Methods.F90 create mode 100644 src/submodules/DOF/src/DOF_SetMethods@Methods.F90 create mode 100644 src/submodules/DiffusionMatrix/CMakeLists.txt create mode 100644 src/submodules/DiffusionMatrix/src/DM_1.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_10.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_2.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_3.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_4.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_5.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_6.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_7.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_8.inc create mode 100644 src/submodules/DiffusionMatrix/src/DM_9.inc create mode 100644 src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 create mode 100644 src/submodules/ElasticNitscheMatrix/CMakeLists.txt create mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 create mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 create mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 create mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 create mode 100644 src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 create mode 100644 src/submodules/ElemshapeData/CMakeLists.txt create mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 create mode 100755 src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 create mode 100644 src/submodules/FEMatrix/src/STCM/STCM_1.inc create mode 100644 src/submodules/FEVariable/CMakeLists.txt create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 create mode 100644 src/submodules/FEVariable/src/include/MatrixElemMethod.F90 create mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 create mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 create mode 100644 src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 create mode 100644 src/submodules/FEVariable/src/include/MatrixPower.F90 create mode 100644 src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 create mode 100644 src/submodules/FEVariable/src/include/RealOperatorScalar.F90 create mode 100644 src/submodules/FEVariable/src/include/RealOperatorVector.F90 create mode 100644 src/submodules/FEVariable/src/include/ScalarElemMethod.F90 create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 create mode 100644 src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 create mode 100644 src/submodules/FEVariable/src/include/ScalarPower.F90 create mode 100644 src/submodules/FEVariable/src/include/VectorElemMethod.F90 create mode 100644 src/submodules/FEVariable/src/include/VectorOperatorReal.F90 create mode 100644 src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 create mode 100644 src/submodules/FEVariable/src/include/VectorOperatorVector.F90 create mode 100644 src/submodules/FEVariable/src/include/VectorPower.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_constant.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_constant2.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_space.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_space2.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_space_time.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_space_time2.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_time.F90 create mode 100644 src/submodules/FEVariable/src/include/matrix_time2.F90 create mode 100644 src/submodules/FEVariable/src/include/scalar_constant.F90 create mode 100644 src/submodules/FEVariable/src/include/scalar_space.F90 create mode 100644 src/submodules/FEVariable/src/include/scalar_space_time.F90 create mode 100644 src/submodules/FEVariable/src/include/scalar_space_time2.F90 create mode 100644 src/submodules/FEVariable/src/include/scalar_time.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_constant.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space2.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space_time.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_space_time2.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_time.F90 create mode 100644 src/submodules/FEVariable/src/include/vector_time2.F90 create mode 100644 src/submodules/FacetMatrix/CMakeLists.txt create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 create mode 100644 src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 create mode 100644 src/submodules/ForceVector/CMakeLists.txt create mode 100644 src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 create mode 100644 src/submodules/Geometry/CMakeLists.txt create mode 100644 src/submodules/Geometry/src/Line_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/Plane_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/Triangle_Method@Methods.F90 create mode 100644 src/submodules/Geometry/src/inc/aux.inc create mode 100644 src/submodules/Geometry/src/modified_burkardt.inc create mode 100644 src/submodules/Hashing/CMakeLists.txt create mode 100644 src/submodules/Hashing/src/Hashing32@fnvMethods.F90 create mode 100644 src/submodules/Hashing/src/Hashing32@nmMethods.F90 create mode 100644 src/submodules/Hashing/src/Hashing32@waterMethods.F90 create mode 100644 src/submodules/Hashing/src/delme.F90 create mode 100644 src/submodules/IndexValue/CMakeLists.txt create mode 100644 src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 create mode 100644 src/submodules/IntVector/CMakeLists.txt create mode 100644 src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 create mode 100644 src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 create mode 100644 src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 create mode 100644 src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 create mode 100644 src/submodules/IntVector/src/IntVector_IOMethod@Methods.F90 create mode 100644 src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 create mode 100644 src/submodules/IntVector/src/include/intvec_get_10.inc create mode 100644 src/submodules/IntVector/src/include/intvec_get_11.inc create mode 100644 src/submodules/IntVector/src/include/intvec_get_12.inc create mode 100644 src/submodules/IntVector/src/include/intvec_get_13.inc create mode 100644 src/submodules/IterationData/CMakeLists.txt create mode 100644 src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 create mode 100644 src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 create mode 100644 src/submodules/KeyValue/CMakeLists.txt create mode 100644 src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 create mode 100644 src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 create mode 100644 src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 create mode 100644 src/submodules/Lapack/CMakeLists.txt create mode 100644 src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/GE_LUMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 create mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 create mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 create mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 create mode 100644 src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 create mode 100644 src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 create mode 100644 src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 create mode 100644 src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 create mode 100644 src/submodules/MassMatrix/CMakeLists.txt create mode 100644 src/submodules/MassMatrix/src/MM_1.inc create mode 100644 src/submodules/MassMatrix/src/MM_2a.inc create mode 100644 src/submodules/MassMatrix/src/MM_2b.inc create mode 100644 src/submodules/MassMatrix/src/MM_2c.inc create mode 100644 src/submodules/MassMatrix/src/MM_2d.inc create mode 100644 src/submodules/MassMatrix/src/MM_3.inc create mode 100644 src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 create mode 100644 src/submodules/MdEncode/CMakeLists.txt create mode 100644 src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 create mode 100644 src/submodules/MdEncode/src/inc/MdEncode_2.inc create mode 100644 src/submodules/MdEncode/src/inc/MdEncode_3.inc create mode 100644 src/submodules/MdEncode/src/inc/MdEncode_3b.inc create mode 100644 src/submodules/MdEncode/src/inc/MdEncode_6.inc create mode 100644 src/submodules/MdEncode/src/inc/MdEncode_7.inc create mode 100644 src/submodules/MultiIndices/CMakeLists.txt create mode 100644 src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 create mode 100644 src/submodules/OpenMP/CMakeLists.txt create mode 100644 src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 create mode 100644 src/submodules/Polynomial/CMakeLists.txt create mode 100644 src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc create mode 100644 src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc create mode 100644 src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 create mode 100644 src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 create mode 100644 src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 create mode 100644 src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 create mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 create mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 create mode 100644 src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 create mode 100644 src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_12.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc create mode 100644 src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc create mode 100644 src/submodules/QuadraturePoint/CMakeLists.txt create mode 100755 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 create mode 100755 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 create mode 100644 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 create mode 100644 src/submodules/Random/CMakeLists.txt create mode 100644 src/submodules/Random/src/Random_Method@Methods.F90 create mode 100644 src/submodules/Rank2Tensor/CMakeLists.txt create mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 create mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 create mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 create mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 create mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 create mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 create mode 100644 src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 create mode 100644 src/submodules/Rank2Tensor/src/matrix_exponential.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part create mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part create mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md create mode 100755 src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Interface.part create mode 100755 src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part create mode 100755 src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md create mode 100755 src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Old_getCDash.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorInterface.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part create mode 100755 src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part create mode 100755 src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Display.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Interface.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/StressType.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress/getStress.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part create mode 100755 src/submodules/Rank2Tensor/src/old data/Tensor.F90 create mode 100755 src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 create mode 100644 src/submodules/RealMatrix/CMakeLists.txt create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 create mode 100644 src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 create mode 100644 src/submodules/RealVector/CMakeLists.txt create mode 100644 src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 create mode 100644 src/submodules/RealVector/src/Save_hdf5.F90 create mode 100644 src/submodules/STConvectiveMatrix/CMakeLists.txt create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md create mode 100644 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part create mode 100755 src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_1.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_10.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_11.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_12.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_13.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_14.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_15.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_16.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_17.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_2.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_3.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_4.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_5.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_6.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_7.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_8.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STCM_9.inc create mode 100644 src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 create mode 100644 src/submodules/STDiffusionMatrix/CMakeLists.txt create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part create mode 100644 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 create mode 100755 src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_1.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_11.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_12.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_13.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_14.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_2.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_3.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_4.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_5.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_6.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_7.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDM_8.inc create mode 100644 src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 create mode 100755 src/submodules/STFextVector/Constructor.part create mode 100755 src/submodules/STFextVector/FextVector_1.part create mode 100755 src/submodules/STFextVector/FextVector_10.part create mode 100755 src/submodules/STFextVector/FextVector_11.part create mode 100755 src/submodules/STFextVector/FextVector_12.part create mode 100755 src/submodules/STFextVector/FextVector_13.part create mode 100755 src/submodules/STFextVector/FextVector_14.part create mode 100755 src/submodules/STFextVector/FextVector_15.part create mode 100755 src/submodules/STFextVector/FextVector_16.part create mode 100755 src/submodules/STFextVector/FextVector_17.part create mode 100755 src/submodules/STFextVector/FextVector_18.part create mode 100755 src/submodules/STFextVector/FextVector_19.part create mode 100755 src/submodules/STFextVector/FextVector_2.part create mode 100755 src/submodules/STFextVector/FextVector_20.part create mode 100755 src/submodules/STFextVector/FextVector_21.part create mode 100755 src/submodules/STFextVector/FextVector_22.part create mode 100755 src/submodules/STFextVector/FextVector_23.part create mode 100755 src/submodules/STFextVector/FextVector_24.part create mode 100755 src/submodules/STFextVector/FextVector_25.part create mode 100755 src/submodules/STFextVector/FextVector_26.part create mode 100755 src/submodules/STFextVector/FextVector_3.part create mode 100755 src/submodules/STFextVector/FextVector_4.part create mode 100755 src/submodules/STFextVector/FextVector_5.part create mode 100755 src/submodules/STFextVector/FextVector_6.part create mode 100755 src/submodules/STFextVector/FextVector_7.part create mode 100755 src/submodules/STFextVector/FextVector_8.part create mode 100755 src/submodules/STFextVector/FextVector_9.part create mode 100755 src/submodules/STFextVector/MdFiles/STFextVector_Class.md create mode 100644 src/submodules/STFextVector/MethodNames.part create mode 100755 src/submodules/STFextVector/STFextVector_Class.f90 create mode 100644 src/submodules/STFextVector/delme.f90 create mode 100755 src/submodules/STFintVector/Constructor.part create mode 100755 src/submodules/STFintVector/FintVector_1.part create mode 100755 src/submodules/STFintVector/FintVector_2.part create mode 100755 src/submodules/STFintVector/FintVector_3.part create mode 100755 src/submodules/STFintVector/FintVector_4.part create mode 100755 src/submodules/STFintVector/FintVector_5.part create mode 100755 src/submodules/STFintVector/FintVector_6.part create mode 100755 src/submodules/STFintVector/FintVector_7.part create mode 100755 src/submodules/STFintVector/FintVector_8.part create mode 100755 src/submodules/STFintVector/MdFiles/STFintVector_Class.md create mode 100644 src/submodules/STFintVector/MethodNames.part create mode 100755 src/submodules/STFintVector/STFintVector_Class.f90 create mode 100644 src/submodules/STForceVector/CMakeLists.txt create mode 100644 src/submodules/STForceVector/src/STFV_1.inc create mode 100644 src/submodules/STForceVector/src/STFV_10.inc create mode 100644 src/submodules/STForceVector/src/STFV_11.inc create mode 100644 src/submodules/STForceVector/src/STFV_12.inc create mode 100644 src/submodules/STForceVector/src/STFV_13.inc create mode 100644 src/submodules/STForceVector/src/STFV_14.inc create mode 100644 src/submodules/STForceVector/src/STFV_15.inc create mode 100644 src/submodules/STForceVector/src/STFV_16.inc create mode 100644 src/submodules/STForceVector/src/STFV_17.inc create mode 100644 src/submodules/STForceVector/src/STFV_18.inc create mode 100644 src/submodules/STForceVector/src/STFV_19.inc create mode 100644 src/submodules/STForceVector/src/STFV_2.inc create mode 100644 src/submodules/STForceVector/src/STFV_20.inc create mode 100644 src/submodules/STForceVector/src/STFV_21.inc create mode 100644 src/submodules/STForceVector/src/STFV_3.inc create mode 100644 src/submodules/STForceVector/src/STFV_4.inc create mode 100644 src/submodules/STForceVector/src/STFV_5.inc create mode 100644 src/submodules/STForceVector/src/STFV_6.inc create mode 100644 src/submodules/STForceVector/src/STFV_7.inc create mode 100644 src/submodules/STForceVector/src/STFV_8.inc create mode 100644 src/submodules/STForceVector/src/STFV_9.inc create mode 100644 src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 create mode 100644 src/submodules/STMassMatrix/CMakeLists.txt create mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part create mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part create mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part create mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part create mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part create mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part create mode 100755 src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md create mode 100644 src/submodules/STMassMatrix/src/STMM_1.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_10.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_10a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_10b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_10c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_10d.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_11.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_11a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_11b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_11c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_11d.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_12.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_12a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_12b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_12c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_12d.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_13.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_14.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_15.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_16.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_17.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_17_20.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_18.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_19.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_2.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_20.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_21.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_21a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_21b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_21c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_21d.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_22.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_22a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_22b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_22c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_22d.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_23.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_23a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_23b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_23c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_23d.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_24.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_24a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_24b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_24c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_24d.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_25.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_26.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_27.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_28.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_3.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_4.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_5.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_6.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_7.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_8.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_9.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_9a.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_9b.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_9c.inc create mode 100644 src/submodules/STMassMatrix/src/STMM_9d.inc create mode 100644 src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 create mode 100755 src/submodules/STStiffnessMatrix/Constructor.part create mode 100755 src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md create mode 100644 src/submodules/STStiffnessMatrix/MethodNames.part create mode 100755 src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part create mode 100755 src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/Constructor.part create mode 100644 src/submodules/ST_Tau_SUPG_RGN/MdFiles/._ST_TAU_SUPG_RGN_Class.md create mode 100644 src/submodules/ST_Tau_SUPG_RGN/MdFiles/ST_TAU_SUPG_RGN_Class.md create mode 100644 src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part create mode 100644 src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part create mode 100755 src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part create mode 100644 src/submodules/StiffnessMatrix/CMakeLists.txt create mode 100644 src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 create mode 100644 src/submodules/TriangleInterface/CMakeLists.txt create mode 100644 src/submodules/TriangleInterface/src/TriangleInterface@Methods.F90 create mode 100644 src/submodules/TriangleInterface/src/definemacro.h create mode 100644 src/submodules/TriangleInterface/src/undefinemacro.h create mode 100644 src/submodules/Utility/CMakeLists.txt create mode 100644 src/submodules/Utility/src/Append/Append_1.inc create mode 100644 src/submodules/Utility/src/Append/Append_1cd.inc create mode 100644 src/submodules/Utility/src/Append/Append_2.inc create mode 100644 src/submodules/Utility/src/Append/Append_2abcd.inc create mode 100644 src/submodules/Utility/src/Append/Append_2cd.inc create mode 100644 src/submodules/Utility/src/Append/Append_3.inc create mode 100644 src/submodules/Utility/src/Append/Append_3cd.inc create mode 100644 src/submodules/Utility/src/Append/Append_4.inc create mode 100644 src/submodules/Utility/src/Append/Append_4cd.inc create mode 100644 src/submodules/Utility/src/AppendUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/ApproxUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/ArangeUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/AssertUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/BinomUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_1.inc create mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_2.inc create mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_3.inc create mode 100644 src/submodules/Utility/src/ColConcat/ColConcat_4.inc create mode 100644 src/submodules/Utility/src/ContractionUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/ConvertUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Diag/SetDiag.inc create mode 100644 src/submodules/Utility/src/Diag/SetTriDiag.inc create mode 100644 src/submodules/Utility/src/Diag/Tridiag.inc create mode 100644 src/submodules/Utility/src/DiagUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/EigenUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Expand/Expand.inc create mode 100644 src/submodules/Utility/src/Expand/ExpandMatrix.inc create mode 100644 src/submodules/Utility/src/EyeUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/GridPointUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/HashingUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/HeadUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/HeapSort/ArgHeapSort.inc create mode 100644 src/submodules/Utility/src/HeapSort/HeapSort.inc create mode 100644 src/submodules/Utility/src/In/In_1.inc create mode 100644 src/submodules/Utility/src/In/IsIn_1.inc create mode 100644 src/submodules/Utility/src/Input/Input1.inc create mode 100644 src/submodules/Utility/src/InputUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc create mode 100644 src/submodules/Utility/src/InsertionSort/InsertionSort.inc create mode 100644 src/submodules/Utility/src/IntegerUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Intersection/Intersection.inc create mode 100644 src/submodules/Utility/src/IntroSort/ArgIntroSort.inc create mode 100644 src/submodules/Utility/src/IntroSort/IntroSort.inc create mode 100644 src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc create mode 100644 src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc create mode 100644 src/submodules/Utility/src/InvUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/MappingUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/MatmulUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Median/ArgMedian.inc create mode 100644 src/submodules/Utility/src/Median/Median.inc create mode 100644 src/submodules/Utility/src/MedianUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/MiscUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/OnesUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Partition/ArgPartition.inc create mode 100644 src/submodules/Utility/src/Partition/Partition.inc create mode 100644 src/submodules/Utility/src/PartitionUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/ProductUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/PushPop/Pop_Scalar.inc create mode 100644 src/submodules/Utility/src/PushPop/Push_Scalar.inc create mode 100644 src/submodules/Utility/src/PushPopUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc create mode 100644 src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc create mode 100644 src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc create mode 100644 src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc create mode 100644 src/submodules/Utility/src/ReallocateUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc create mode 100644 src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc create mode 100644 src/submodules/Utility/src/Repeat/Repeat_1.inc create mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_1.inc create mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_2.inc create mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_3.inc create mode 100644 src/submodules/Utility/src/RowConcat/RowConcat_4.inc create mode 100644 src/submodules/Utility/src/SafeSizeUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Sort/ArgSort.inc create mode 100644 src/submodules/Utility/src/Sort/Sort.inc create mode 100644 src/submodules/Utility/src/SortUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/SplitUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/StringUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/SwapUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Sym/GetSym.inc create mode 100644 src/submodules/Utility/src/Sym/Sym.inc create mode 100644 src/submodules/Utility/src/SymUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/TailUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/Triag/GetTril1.inc create mode 100644 src/submodules/Utility/src/Triag/GetTril2.inc create mode 100644 src/submodules/Utility/src/Triag/GetTriu1.inc create mode 100644 src/submodules/Utility/src/Triag/GetTriu2.inc create mode 100644 src/submodules/Utility/src/Triag/SetTril1.inc create mode 100644 src/submodules/Utility/src/Triag/SetTril2.inc create mode 100644 src/submodules/Utility/src/Triag/SetTril3.inc create mode 100644 src/submodules/Utility/src/Triag/SetTriu1.inc create mode 100644 src/submodules/Utility/src/Triag/SetTriu2.inc create mode 100644 src/submodules/Utility/src/Triag/SetTriu3.inc create mode 100644 src/submodules/Utility/src/Triag/Tril1.inc create mode 100644 src/submodules/Utility/src/Triag/Tril2.inc create mode 100644 src/submodules/Utility/src/Triag/Triu1.inc create mode 100644 src/submodules/Utility/src/Triag/Triu2.inc create mode 100644 src/submodules/Utility/src/TriagUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/ZerosUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc create mode 100644 src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc create mode 100755 src/submodules/Vector/ToDo/VectorOperations.part create mode 100644 src/submodules/Vector3D/CMakeLists.txt create mode 100644 src/submodules/Vector3D/Vector3D_Method@Misc.F90 create mode 100644 src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 create mode 100644 src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 create mode 100644 src/submodules/VoigtRank2Tensor/CMakeLists.txt create mode 100644 src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 create mode 100644 src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 diff --git a/.fortls b/.fortls new file mode 100644 index 000000000..20162a203 --- /dev/null +++ b/.fortls @@ -0,0 +1,28 @@ +{ + "source_dirs": [ + "src/**" + ], + "excl_suffixes": [ + "_skip.F90", + ".bk", + ".ignore" + ], + "pp_suffixes": [ + ".F90", + ".inc", + ".part", + ".f90" + ], + "pp_defs": {}, + "include_dirs": [], + "ext_source_dirs": [], + "lowercase_intrinsics": false, + "debug_log": false, + "disable_diagnostics": false, + "sort_keywords": false, + "use_signature_help": true, + "hover_signature": true, + "hover_language": "fortran", + "enable_code_actions": false, + "symbol_skip_mem": false +} diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 000000000..dfe077042 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,2 @@ +# Auto detect text files and perform LF normalization +* text=auto diff --git a/.gitconfig b/.gitconfig new file mode 100644 index 000000000..c65769c48 --- /dev/null +++ b/.gitconfig @@ -0,0 +1,5 @@ +# This is Git's per-user configuration file. +[user] +# Please adapt and uncomment the following lines: + name = Vikas Sharma + email = vickysharma0812@gmail.com diff --git a/.github/.pr-labeler.yml b/.github/.pr-labeler.yml new file mode 100644 index 000000000..c0922df6a --- /dev/null +++ b/.github/.pr-labeler.yml @@ -0,0 +1,4 @@ +utility: utility/* +sparsematrix: sparsematrix/* +working: ['working/*', 'work/*'] +linalg: ['sparsematrix/*', 'sparse/*', 'monolish/*', 'blas/*', 'lapack/*'] diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 000000000..9f425977c --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,39 @@ +--- +name: Bug report +about: Create a report to help us improve +title: '' +labels: 'wishlist' + 'inspiration' +assignees: '' + +--- + +**Describe the bug** +A clear and concise description of what the bug is. + +**To Reproduce** +Steps to reproduce the behavior: +1. Go to '...' +2. Click on '....' +3. Scroll down to '....' +4. See error + +**Expected behavior** +A clear and concise description of what you expected to happen. + +**Screenshots** +If applicable, add screenshots to help explain your problem. + +**Desktop (please complete the following information):** + - OS: [e.g. iOS] + - Browser [e.g. chrome, safari] + - Version [e.g. 22] + +**Smartphone (please complete the following information):** + - Device: [e.g. iPhone6] + - OS: [e.g. iOS8.1] + - Browser [e.g. stock browser, safari] + - Version [e.g. 22] + +**Additional context** +Add any other context about the problem here. diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md new file mode 100644 index 000000000..8f3bcfb53 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/feature_request.md @@ -0,0 +1,21 @@ +--- +name: Feature request +about: Suggest an idea for this project +title: '' +labels: 'wishlist' + 'inspiration' +assignees: '' + +--- + +**Is your feature request related to a problem? Please describe.** +A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] + +**Describe the solution you'd like** +A clear and concise description of what you want to happen. + +**Describe alternatives you've considered** +A clear and concise description of any alternative solutions or features you've considered. + +**Additional context** +Add any other context or screenshots about the feature request here. diff --git a/.github/ISSUE_TEMPLATE/inspiration.md b/.github/ISSUE_TEMPLATE/inspiration.md new file mode 100644 index 000000000..159dad60b --- /dev/null +++ b/.github/ISSUE_TEMPLATE/inspiration.md @@ -0,0 +1,23 @@ +--- +name: Inspiration +about: Tell us about other projects so that we can use it in easifemBase +title: "[Inspiration]" +labels: 'Inspiration' + 'wishlist' +assignees: vickysharma0812 + +--- + +# EASIFEM-INSPIRATION + +## Project name + +### Developer + +### Age + +### Field of application + +### Activity status + +## Why should it be covered in easifemBase diff --git a/.github/workflows/pr-labeler.yml b/.github/workflows/pr-labeler.yml new file mode 100644 index 000000000..1bb104852 --- /dev/null +++ b/.github/workflows/pr-labeler.yml @@ -0,0 +1,18 @@ +name: PR Labeler +on: + pull_request: + types: [opened] + +jobs: + pr-labeler: + runs-on: ubuntu-latest + steps: + - uses: TimonVS/pr-labeler-action@v3 + with: + configuration-path: .github/pr-labeler.yml # optional, .github/pr-labeler.yml is the default value + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + + +# Reference +# https://github.com/marketplace/actions/pr-labeler \ No newline at end of file diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..7d5481641 --- /dev/null +++ b/.gitignore @@ -0,0 +1,29 @@ +# ignore following extesions +# added by vikas +# 2-Dec-2018 +*.a +*.mod +*.smod +*.o +*.out +*.i90 +*.if90 +*.DS_Store +*.cache +*.prj +*.drawio +*.log +*.pdf +vscode-settings +docs/ +media/ +*/build/ +build/ +src/build/ +src/modules/build/ +src/submodules/build/ +_packages/ +compile_commands.json +compile_commands.json +neovim.json +selected diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 000000000..8605764fb --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "C_Cpp.default.configurationProvider": "ms-vscode.cmake-tools", + "cmake.buildDirectory": "/home/vikassharma/temp/easifem-base/build", + "cmake.generator": "", + "cmake.installPrefix": "/home/vikassharma/.easifem/base", + "cmake.configureOnOpen": false +} \ No newline at end of file diff --git a/.vscode/tasks.json b/.vscode/tasks.json new file mode 100644 index 000000000..ad530b010 --- /dev/null +++ b/.vscode/tasks.json @@ -0,0 +1,112 @@ +{ + "version": "2.0.0", + "tasks": [ + { + "label": "clean", + "type": "shell", + "command": "easifem", + "args": [ + "clean", + "base" + ], + "problemMatcher": [] + }, + { + "label": "build", + "type": "shell", + "command": "python3 ${workspaceFolder}/build.py", + "problemMatcher": [], + "group": { + "kind": "build", + "isDefault": true + } + }, + { + "label": "install", + "type": "shell", + "command": "python3 ${workspaceFolder}/install.py", + "problemMatcher": [], + "group": { + "kind": "build" + } + }, + { + "label": "dev", + "type": "shell", + "command": "gfortran", + "args": [ + "-DDEBUG_VER", + "-DAPPLE", + "-DASCII_SUPPORTED", + "-DDarwin_SYSTEM", + "-DUCS4_SUPPORTED", + "-DUSE_APPLE_NativeBLAS", + "-DUSE_ARPACK", + "-DUSE_BLAS95", + "-DUSE_CMAKE", + "-DUSE_FFTW", + "-DUSE_Int32", + "-DUSE_LAPACK95", + "-DUSE_LIS", + "-DUSE_NativeBLAS", + "-DUSE_OpenMP", + "-DUSE_PLPLOT", + "-DUSE_Real64", + "-DUSE_SuperLU", + "-D_ASCII_SUPPORTED", + "-D_R16P", + "-D_UCS4_SUPPORTED", + "-DeasifemBase_EXPORTS", + "-I/opt/homebrew/include", + "-I/opt/homebrew/Cellar/plplot/5.15.0_4/lib/fortran/modules/plplot", + "-I/Users/easifem/.easifem/install/easifem/extpkgs/include/arpack", + "-I/Users/easifem/.easifem/install/easifem/extpkgs/include", + "-I/Users/easifem/.easifem/install/easifem/base/include", + "-J/Users/easifem/.easifem/ide/include", + "-ffree-form", + "-ffree-line-length-none", + "-std=f2018", + "-fimplicit-none", + "-Waliasing", + "-Wall", + "-Wampersand", + "-Warray-bounds", + "-Wc-binding-type", + "-Wcharacter-truncation", + "-Wconversion", + "-Wdo-subscript", + "-Wfunction-elimination", + "-Wimplicit-interface", + "-Wimplicit-procedure", + "-Wintrinsic-shadow", + "-Wuse-without-only", + "-Wintrinsics-std", + "-Wline-truncation", + "-Wno-align-commons", + "-Wno-overwrite-recursive", + "-Wno-tabs", + "-Wreal-q-constant", + "-Wsurprising", + "-Wunderflow", + "-Wunused-parameter", + "-Wrealloc-lhs", + "-Wrealloc-lhs-all", + "-Wtarget-lifetime", + "-pedantic", + "-pedantic-errors", + "-c", + "${file}", + "-o", + "/Users/easifem/.easifem/ide/include/${fileBasenameNoExtension}.F90.o" + ], + "options": { + "cwd": "${fileDirname}" + }, + "problemMatcher": "$gcc", + "group": { + "kind": "build", + "isDefault": true + } + } + ] +} diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 000000000..d5bd3362b --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,334 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +cmake_minimum_required(VERSION 3.28.0 FATAL_ERROR) + +set(PROJECT_NAME "easifemBase") +project(${PROJECT_NAME}) + +enable_language(C Fortran CXX) + +set(VERSION_MAJOR "24") +set(VERSION_MINOR "4") +set(VERSION_BugFix "5") + +set(PROJECT_VERSION ${VERSION_MAJOR}.${VERSION_MINOR}.${VERSION_BugFix}) + +set(CMAKE_PROJECT_DESCRIPTION + "${PROJECT_NAME} is part of EASIFEM platform. + EASIFEM: Expandable and Scalable Infrastructure for Finite Element Methods. + ") + +set(CMAKE_PROJECT_HOMEPAGE_URL "https://www.easifem.com") + +set(TARGETS_EXPORT_NAME "${PROJECT_NAME}Targets") + +set(namespace "${PROJECT_NAME}") + +include(CMakePrintHelpers) +include(FortranCInterface) + +FortranCInterface_VERIFY() + +list(APPEND TARGET_COMPILE_DEF "-DUSE_CMAKE") + +# find my cmake modules here... +list(APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) + +# check error +if(" ${CMAKE_CURRENT_SOURCE_DIR}" STREQUAL " ${CMAKE_CURRENT_BINARY_DIR}") + message( + FATAL_ERROR + "[ERROR] :: Build directory and Source directory cannot be same.") +endif() + +# make directories + +include(GNUInstallDirs) + +set(CMAKE_Fortran_MODULE_DIRECTORY + ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_INCLUDEDIR}) + +set(CMAKE_LIBRARY_OUTPUT_DIRECTORY + ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_LIBDIR}) + +set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY + ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_LIBDIR}) + +set(CMAKE_RUNTIME_OUTPUT_DIRECTORY + ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_BINDIR}) + +set(INSTALL_LIBDIR + ${CMAKE_INSTALL_LIBDIR} + CACHE PATH "Installation location of lib") + +set(INSTALL_INCLUDEDIR + ${CMAKE_INSTALL_INCLUDEDIR} + CACHE PATH "Installation location of module files") + +set(INSTALL_BINDIR + ${CMAKE_INSTALL_BINDIR} + CACHE PATH "Installation location of binary files") + +if(WIN32 AND NOT CYGWIN) + set(DEF_INSTALL_CMAKEDIR CMake) +else() + set(DEF_INSTALL_CMAKEDIR share/cmake/${PROJECT_NAME}) +endif() + +set(INSTALL_CMAKEDIR + ${DEF_INSTALL_CMAKEDIR} + CACHE PATH "Installation directory for CMake files") + +foreach(p LIB BIN INCLUDE CMAKE) + file(TO_NATIVE_PATH ${CMAKE_INSTALL_PREFIX}/${INSTALL_${p}DIR} _path) + message(STATUS "Installing ${p} componenets to ${_path}") +endforeach() + +option(BUILD_SHARED_LIBS "Build shared library" ON) + +if(BUILD_SHARED_LIBS) + message(STATUS "${PROJECT_NAME} will be built as a shared library.") + add_library(${PROJECT_NAME} SHARED "") + set_property(TARGET ${PROJECT_NAME} PROPERTY POSITION_INDEPENDENT_CODE TRUE) +else() + message(STATUS "${PROJECT_NAME} will be built as a static library.") + add_library(${PROJECT_NAME} STATIC "") +endif() + +# include(${PROJECT_SOURCE_DIR}/cmake/Compiler.cmake) + +message( + STATUS + "[INFO] :: Is the Fortran compiler loaded? ${CMAKE_Fortran_COMPILER_LOADED}" +) + +if(CMAKE_Fortran_COMPILER_LOADED) + message(STATUS "[INFO] :: Fortran compiler: ${CMAKE_Fortran_COMPILER_ID}") + message( + STATUS + "[INFO] :: Fortran compiler version is: ${CMAKE_Fortran_COMPILER_VERSION}" + ) +endif() + +if(NOT CMAKE_BUILD_TYPE) + set(CMAKE_BUILD_TYPE + Release + CACHE STRING "Build type" FORCE) +endif() + +if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU" OR Fortran_COMPILER_NAME MATCHES + "gfortran*") + + list( + APPEND + FORTRAN_FLAGS + "-ffree-form" + "-ffree-line-length-none" + "-std=f2018" + "-fimplicit-none" + "-fno-range-check") + + list(APPEND FORTRAN_FLAGS_RELEASE "-O3") + + if(APPLE) + list( + APPEND + FORTRAN_FLAGS_DEBUG + "-fbounds-check" + "-g" + "-fbacktrace" + "-Wextra" + "-Wall" + # "-fprofile-arcs" + "-ftest-coverage" + "-Wimplicit-interface") + + else() + list( + APPEND + FORTRAN_FLAGS_DEBUG + "-fbounds-check" + "-g" + "-fbacktrace" + "-Wextra" + "-Wall" + # "-fprofile-arcs" + "-ftest-coverage" + "-Wimplicit-interface") + endif() + +elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel" OR Fortran_COMPILER_NAME + MATCHES "ifort*") + list(APPEND FORTRAN_FLAGS "-r8" "-W1") + list(APPEND FORTRAN_FLAGS_RELEASE "-O3") + list( + APPEND + FORTRAN_FLAGS_DEBUG + "-O0" + "-traceback" + "-g" + "-debug all" + "-check all" + "-ftrapuv" + "-warn" + "nointerfaces") + +elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL "XL" OR Fortran_COMPILER_NAME + MATCHES "xlf*") + + list(APPEND FORTRAN_FLAGS "-q64" "-qrealsize=8" "-qsuffix=f=f90:cpp=f90") + list(APPEND FORTRAN_FLAGS_RELEASE "-O3" "-qstrict") + list(APPEND FORTRAN_FLAGS_DEBUG "-O0" "-g" "-qfullpath" "-qkeepparm") + +else() + message(ERROR "[ERROR] :: No optimized Fortran compiler flags are known") +endif() + +cmake_print_variables(FORTRAN_FLAGS) +cmake_print_variables(FORTRAN_FLAGS_RELEASE) +cmake_print_variables(FORTRAN_FLAGS_DEBUG) + +target_compile_options( + ${PROJECT_NAME} + PRIVATE ${TARGET_COMPILE_OPT} ${FORTRAN_FLAGS} + "$<$:${FORTRAN_FLAGS_DEBUG}>" + "$<$:${FORTRAN_FLAGS_RELEASE}>") + +target_include_directories( + ${PROJECT_NAME} + PUBLIC $ + $ + # "${EASIFEM_EXTPKGS}/include" +) + +# target properties +set_target_properties( + ${PROJECT_NAME} + PROPERTIES POSITION_INDEPENDENT_CODE 1 + SOVERSION ${VERSION_MAJOR} + OUTPUT_NAME ${PROJECT_NAME} + LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + MACOSX_RPATH ON + WINDOWS_EXPORT_ALL_SYMBOLS ON) + +# some options for easifem +option(USE_REAL32 OFF) +option(USE_REAL64 ON) + +if(USE_REAL32) + list(APPEND TARGET_COMPILE_DEF "-DUSE_Real32") +endif() + +if(USE_REAL64) + list(APPEND TARGET_COMPILE_DEF "-DUSE_Real64") +endif() + +option(USE_INT32 ON) +if(USE_INT32) + list(APPEND TARGET_COMPILE_DEF "-DUSE_Int32") +endif() + +option(USE_INT64 OFF) +if(USE_INT64) + list(APPEND TARGET_COMPILE_DEF "-DUSE_Int64") +endif() + +list(APPEND TARGET_COMPILE_DEF "-D${CMAKE_HOST_SYSTEM_NAME}_SYSTEM") + +# DEFINE DEBUG +if(${CMAKE_BUILD_TYPE} STREQUAL "Debug") + list(APPEND TARGET_COMPILE_DEF "-DDEBUG_VER") +endif() + +option(USE_COLORDISP ON) +if(USE_COLORDISP) + list(APPEND TARGET_COMPILE_DEF "-DCOLOR_DISP") +endif() + +# include(${PROJECT_SOURCE_DIR}/cmake/install.cmake) Installation +install( + DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY} + DESTINATION "./" + COMPONENT "${PROJECT_NAME}") + +install( + EXPORT ${TARGETS_EXPORT_NAME} + FILE "${TARGETS_EXPORT_NAME}.cmake" + NAMESPACE ${namespace}:: + DESTINATION ${INSTALL_CMAKEDIR} + COMPONENT "${PROJECT_NAME}") + +include(CMakePackageConfigHelpers) + +write_basic_package_version_file( + "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}ConfigVersion.cmake" + VERSION "${PROJECT_VERSION}" + COMPATIBILITY AnyNewerVersion) + +configure_package_config_file( + ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Config.cmake.in + ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}Config.cmake + INSTALL_DESTINATION ${INSTALL_CMAKEDIR} + PATH_VARS INSTALL_INCLUDEDIR) + +install( + FILES "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}Config.cmake" + "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}ConfigVersion.cmake" + DESTINATION ${INSTALL_CMAKEDIR} + COMPONENT "${PROJECT_NAME}-dev") + +# Find external dependency of the project FIXME: +if(NOT CMAKE_PREFIX_PATH) + list(APPEND CMAKE_PREFIX_PATH "$ENV{EASIFEM_EXTPKGS}") +endif() + +include(${PROJECT_SOURCE_DIR}/cmake/addRaylib.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addOpenBLAS.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addLapack95.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addSparsekit.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addToml.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addOpenMP.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addSuperLU.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addLIS.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addMetis.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addARPACK.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addPLPLOT.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addFFTW.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addGTKFortran.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addLua.cmake) + +# Add source files +include(src/modules/CMakeLists.txt) +include(src/submodules/CMakeLists.txt) + +# this should be in the end. +target_compile_definitions(${PROJECT_NAME} PUBLIC ${TARGET_COMPILE_DEF}) +message(STATUS "[INFO] :: Compiler definition : ${TARGET_COMPILE_DEF}") + +install( + TARGETS ${PROJECT_NAME} ${C_PROJECTS} + EXPORT ${TARGETS_EXPORT_NAME} + COMPONENT "${PROJECT_NAME}" + ARCHIVE DESTINATION ${INSTALL_LIBDIR} + RUNTIME DESTINATION ${INSTALL_BINDIR} + LIBRARY DESTINATION ${INSTALL_LIBDIR}) + +include(${PROJECT_SOURCE_DIR}/cmake/packaging.cmake) diff --git a/CMakePresets.json b/CMakePresets.json new file mode 100644 index 000000000..ac86cde6a --- /dev/null +++ b/CMakePresets.json @@ -0,0 +1,81 @@ +{ + "version": 7, + "cmakeMinimumRequired": { + "major": 3, + "minor": 23, + "patch": 0 + }, + "configurePresets": [ + { + "name": "default", + "displayName": "Default Config", + "description": "Default build using Ninja generator", + "generator": "Ninja", + "binaryDir": "$env{EASIFEM_BUILD_DIR}/easifem/base/build/default/", + "installDir": "$env{EASIFEM_BASE}", + "cacheVariables": { + "CMAKE_BUILD_TYPE": { "type": "STRING", "value": "Debug" }, + "BUILD_SHARED_LIBS": { "type": "BOOL", "value": "ON" }, + "CMAKE_EXPORT_COMPILE_COMMANDS": { "type": "BOOL", "value": "ON" }, + "USE_OPENMP": { "type": "BOOL", "value": "ON" }, + "USE_PLPLOT": { "type": "BOOL", "value": "ON" }, + "USE_BLAS95": { "type": "BOOL", "value": "ON" }, + "USE_LAPACK95": { "type": "BOOL", "value": "ON" }, + "USE_FFTW": { "type": "BOOL", "value": "ON" }, + "USE_GTK": { "type": "BOOL", "value": "OFF" }, + "USE_ARPACK": { "type": "BOOL", "value": "ON" }, + "USE_PARPACK": { "type": "BOOL", "value": "OFF" }, + "USE_SUPERLU": { "type": "BOOL", "value": "ON" }, + "USE_LIS": { "type": "BOOL", "value": "ON" }, + "USE_METIS": { "type": "BOOL", "value": "ON" }, + "USE_LUA": { "type": "BOOL", "value": "ON" }, + "USE_Int32": { "type": "BOOL", "value": "ON" }, + "USE_Real64": { "type": "BOOL", "value": "ON" }, + "USE_COLORDISP": { "type": "BOOL", "value": "OFF" } + } + }, + { + "name": "neovim-debug", + "inherits": "default", + "displayName": "Neovim Debug Dev", + "description": "Default build using Ninja generator for dev in neovim", + "binaryDir": "/home/easifem/.easifem/build/easifem/base/neovim/debug" + }, + { + "name": "ninja-multi", + "inherits": "default", + "displayName": "Ninja Multi-Config", + "description": "Default build using Ninja Multi-Config generator", + "generator": "Ninja Multi-Config" + } + ], + "buildPresets": [ + { + "name": "default", + "displayName": "Default build", + "description": "Default build", + "configurePreset": "default" + }, + { + "name": "neovim-debug", + "displayName": "Neovim debug build", + "description": "Default build", + "configurePreset": "neovim-debug" + } + ], + "workflowPresets": [ + { + "name": "default", + "steps": [ + { + "type": "configure", + "name": "default" + }, + { + "type": "build", + "name": "default" + } + ] + } + ] +} diff --git a/FORDsetup.md b/FORDsetup.md new file mode 100644 index 000000000..ffa9af860 --- /dev/null +++ b/FORDsetup.md @@ -0,0 +1,45 @@ +--- +project: easifemBase +summary: easifemBase is part of easifem library, which is a framework for Expandable And Scalable Infrastructure for Finite Element Methods. +project_download: https://github.com/vickysharma0812/easifem-base +project_github: https://github.com/vickysharma0812/easifem-base +project_website: https://www.easifem.com +license: gfdl +project_dir: ./src/modules/Utility +media_dir: ./media +page_dir: ./pages +output_dir: ${HOME}/temp/ford +exclude_dir: ./src/submodules/ + ./src/modules/BLAS95/ +author: Vikas Sharma +author_description: Graduate School of Agriculture, Kyoto University, + Kyoto, Japan +email: vickysharma0812@gmail.com +github: https://vickysharma0812.github.io/ +author_pic: ./media/vikas.png +twitter: https://twitter.com/vickysharma0812 +website: http://vikas.easifem.com +graph: false +source: false +display: public + protected + private +page: false +sort: alpha +coloured_edges: true +extra_filetypes: inc ! +print_creation_date: true +creation_date: %Y-%m-%d %H:%M %z +md_extensions: markdown.extensions.toc + markdown.extensions.smarty +predocmark_alt: > +predocmark: < +docmark_alt: * +docmark: ! +fpp_extensions: F90 +preprocesses: true +--- + +{!./README.md!} + + diff --git a/LICENSE b/LICENSE new file mode 100644 index 000000000..049e2e019 --- /dev/null +++ b/LICENSE @@ -0,0 +1,94 @@ +EASIFEM, Expandable And Scalable Infrastructure for Finite Element Methods, +is a framework for implementing finite element methods in Modern Fortran. +easifemBase is a part of EASIFEM library. +Copyright(C) 2020-2023 +Vikas Sharma +Ph.D. (Kyoto University, Japan) +B. Tech. (IIT Bombay, India) +vickysharma0812@gmail.com +https://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 + +=========================================================================== + +EASIFEM depends upon following fortran-libraries. +It is worth noting that some of these libraries have been +modified by EASIFEM depending upon necessary needs. + +(1) PENF +PENF is developed by [Mr. Szaghi](https://github.com/szaghi). +This library tries to exploit code portability for modern (2003+) Fortran projects. +It is a pure Fortran library for achieving portable codes for modern Fortran projects. +It provides many number-to-string and vice-versa facilities. +[Read more](https://github.com/szaghi/PENF/tree/master/src) + +(2) BeFoR64 + +This library is also a fortran project of [Mr. Szaghi](https://github.com/szaghi). +It is for *base64* encoding/decoding for modern Fortran projects. +[Read more](https://github.com/szaghi/BeFoR64) + +(3) StringiFor + +This library is also a fortran project of [Mr. Szaghi](https://github.com/szaghi). +This library makes an attempt to define string data type for handling characters in an object oriented way. +[Read more](https://github.com/szaghi/StringiFor) + +(4)) FoXy + +This is a fortran library which is designed to handle XML files. +[Read more](https://github.com/Fortran-FOSS-Programmers/FoXy) + +(5) vtkFortran + +This fortran library handles IO with vtk files. +[Read more](https://github.com/szaghi/VTKFortran) + +(6) H5Fortran + +This fortran project, which is developed by [Michael Hirsch](https://github.com/scivision), can handle IO with hdf5 files. +[Read more](https://github.com/geospace-code/h5fortran.git). + +(7) OGPF +This is program creates an interface between modern fortran and gnuplot. +This is a useful library for visualising fortran data using gnuplot. [Read more](https://github.com/kookma/ogpf). +In easifem this is renamed as `Gnuplot_Method.F90`. + +(8) Sparsekit + +Sparsekit is a legacy fortran code written by the great [Yusef Saad](https://en.wikipedia.org/wiki/Yousef_Saad) for +peforming linear algebra with sparse matrices. [Read more](https://www-users.cs.umn.edu/~saad/software/SPARSKIT/). +Some of these programs have been rewritten from F77 to Modern fortran. + +(9) M_SYSTEM + +This is Fortran interface to C system interface. It is taken from . +The original name of the program has been changed from M_SYSTEM to System_Method. +This is to confirm to the coding sytles of easifem. + +(10) FACE + +Fortran ANSI Color. Source: + +(11) ExceptionHandlerType + +This is libray can handle exceptions in fortran. Source: . +This library is modified as per the needs. + +(12) Fortran-TestAnything + +It is a library for testing fortran program. Source : . +The original name of the program is changed from Test.F90 to Test_Method.F90 to confirm the coding standards of easifem. diff --git a/LICENSE.gpl3.md b/LICENSE.gpl3.md new file mode 100644 index 000000000..98ec59e7c --- /dev/null +++ b/LICENSE.gpl3.md @@ -0,0 +1,596 @@ +GNU GENERAL PUBLIC LICENSE +========================== + +Version 3, 29 June 2007 + +Copyright © 2007 Free Software Foundation, Inc. <> + +Everyone is permitted to copy and distribute verbatim copies of this license +document, but changing it is not allowed. + +## Preamble + +The GNU General Public License is a free, copyleft license for software and other +kinds of works. + +The licenses for most software and other practical works are designed to take away +your freedom to share and change the works. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change all versions of a +program--to make sure it remains free software for all its users. We, the Free +Software Foundation, use the GNU General Public License for most of our software; it +applies also to any other work released this way by its authors. You can apply it to +your programs, too. + +When we speak of free software, we are referring to freedom, not price. Our General +Public Licenses are designed to make sure that you have the freedom to distribute +copies of free software (and charge for them if you wish), that you receive source +code or can get it if you want it, that you can change the software or use pieces of +it in new free programs, and that you know you can do these things. + +To protect your rights, we need to prevent others from denying you these rights or +asking you to surrender the rights. Therefore, you have certain responsibilities if +you distribute copies of the software, or if you modify it: responsibilities to +respect the freedom of others. + +For example, if you distribute copies of such a program, whether gratis or for a fee, +you must pass on to the recipients the same freedoms that you received. You must make +sure that they, too, receive or can get the source code. And you must show them these +terms so they know their rights. + +Developers that use the GNU GPL protect your rights with two steps: (1) assert +copyright on the software, and (2) offer you this License giving you legal permission +to copy, distribute and/or modify it. + +For the developers' and authors' protection, the GPL clearly explains that there is +no warranty for this free software. For both users' and authors' sake, the GPL +requires that modified versions be marked as changed, so that their problems will not +be attributed erroneously to authors of previous versions. + +Some devices are designed to deny users access to install or run modified versions of +the software inside them, although the manufacturer can do so. This is fundamentally +incompatible with the aim of protecting users' freedom to change the software. The +systematic pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we have designed +this version of the GPL to prohibit the practice for those products. If such problems +arise substantially in other domains, we stand ready to extend this provision to +those domains in future versions of the GPL, as needed to protect the freedom of +users. + +Finally, every program is threatened constantly by software patents. States should +not allow patents to restrict development and use of software on general-purpose +computers, but in those that do, we wish to avoid the special danger that patents +applied to a free program could make it effectively proprietary. To prevent this, the +GPL assures that patents cannot be used to render the program non-free. + +The precise terms and conditions for copying, distribution and modification follow. + +## TERMS AND CONDITIONS + +### 0. Definitions. + +“This License” refers to version 3 of the GNU General Public License. + +“Copyright” also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + +“The Program” refers to any copyrightable work licensed under this +License. Each licensee is addressed as “you”. “Licensees” and +“recipients” may be individuals or organizations. + +To “modify” a work means to copy from or adapt all or part of the work in +a fashion requiring copyright permission, other than the making of an exact copy. The +resulting work is called a “modified version” of the earlier work or a +work “based on” the earlier work. + +A “covered work” means either the unmodified Program or a work based on +the Program. + +To “propagate” a work means to do anything with it that, without +permission, would make you directly or secondarily liable for infringement under +applicable copyright law, except executing it on a computer or modifying a private +copy. Propagation includes copying, distribution (with or without modification), +making available to the public, and in some countries other activities as well. + +To “convey” a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through a computer +network, with no transfer of a copy, is not conveying. + +An interactive user interface displays “Appropriate Legal Notices” to the +extent that it includes a convenient and prominently visible feature that (1) +displays an appropriate copyright notice, and (2) tells the user that there is no +warranty for the work (except to the extent that warranties are provided), that +licensees may convey the work under this License, and how to view a copy of this +License. If the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + +### 1. Source Code. + +The “source code” for a work means the preferred form of the work for +making modifications to it. “object code” means any non-source form of a +work. + +A “Standard Interface” means an interface that either is an official +standard defined by a recognized standards body, or, in the case of interfaces +specified for a particular programming language, one that is widely used among +developers working in that language. + +The “System Libraries” of an executable work include anything, other than +the work as a whole, that (a) is included in the normal form of packaging a Major +Component, but which is not part of that Major Component, and (b) serves only to +enable use of the work with that Major Component, or to implement a Standard +Interface for which an implementation is available to the public in source code form. +A “Major Component”, in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system (if any) on which +the executable work runs, or a compiler used to produce the work, or an object code +interpreter used to run it. + +The “Corresponding Source” for a work in object code form means all the +source code needed to generate, install, and (for an executable work) run the object +code and to modify the work, including scripts to control those activities. However, +it does not include the work's System Libraries, or general-purpose tools or +generally available free programs which are used unmodified in performing those +activities but which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for the work, and +the source code for shared libraries and dynamically linked subprograms that the work +is specifically designed to require, such as by intimate data communication or +control flow between those subprograms and other parts of the work. + +The Corresponding Source need not include anything that users can regenerate +automatically from other parts of the Corresponding Source. + +The Corresponding Source for a work in source code form is that same work. + +### 2. Basic Permissions. + +All rights granted under this License are granted for the term of copyright on the +Program, and are irrevocable provided the stated conditions are met. This License +explicitly affirms your unlimited permission to run the unmodified Program. The +output from running a covered work is covered by this License only if the output, +given its content, constitutes a covered work. This License acknowledges your rights +of fair use or other equivalent, as provided by copyright law. + +You may make, run and propagate covered works that you do not convey, without +conditions so long as your license otherwise remains in force. You may convey covered +works to others for the sole purpose of having them make modifications exclusively +for you, or provide you with facilities for running those works, provided that you +comply with the terms of this License in conveying all material for which you do not +control copyright. Those thus making or running the covered works for you must do so +exclusively on your behalf, under your direction and control, on terms that prohibit +them from making any copies of your copyrighted material outside their relationship +with you. + +Conveying under any other circumstances is permitted solely under the conditions +stated below. Sublicensing is not allowed; section 10 makes it unnecessary. + +### 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + +No covered work shall be deemed part of an effective technological measure under any +applicable law fulfilling obligations under article 11 of the WIPO copyright treaty +adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention +of such measures. + +When you convey a covered work, you waive any legal power to forbid circumvention of +technological measures to the extent such circumvention is effected by exercising +rights under this License with respect to the covered work, and you disclaim any +intention to limit operation or modification of the work as a means of enforcing, +against the work's users, your or third parties' legal rights to forbid circumvention +of technological measures. + +### 4. Conveying Verbatim Copies. + +You may convey verbatim copies of the Program's source code as you receive it, in any +medium, provided that you conspicuously and appropriately publish on each copy an +appropriate copyright notice; keep intact all notices stating that this License and +any non-permissive terms added in accord with section 7 apply to the code; keep +intact all notices of the absence of any warranty; and give all recipients a copy of +this License along with the Program. + +You may charge any price or no price for each copy that you convey, and you may offer +support or warranty protection for a fee. + +### 5. Conveying Modified Source Versions. + +You may convey a work based on the Program, or the modifications to produce it from +the Program, in the form of source code under the terms of section 4, provided that +you also meet all of these conditions: + +* **a)** The work must carry prominent notices stating that you modified it, and giving a +relevant date. +* **b)** The work must carry prominent notices stating that it is released under this +License and any conditions added under section 7. This requirement modifies the +requirement in section 4 to “keep intact all notices”. +* **c)** You must license the entire work, as a whole, under this License to anyone who +comes into possession of a copy. This License will therefore apply, along with any +applicable section 7 additional terms, to the whole of the work, and all its parts, +regardless of how they are packaged. This License gives no permission to license the +work in any other way, but it does not invalidate such permission if you have +separately received it. +* **d)** If the work has interactive user interfaces, each must display Appropriate Legal +Notices; however, if the Program has interactive interfaces that do not display +Appropriate Legal Notices, your work need not make them do so. + +A compilation of a covered work with other separate and independent works, which are +not by their nature extensions of the covered work, and which are not combined with +it such as to form a larger program, in or on a volume of a storage or distribution +medium, is called an “aggregate” if the compilation and its resulting +copyright are not used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work in an aggregate +does not cause this License to apply to the other parts of the aggregate. + +### 6. Conveying Non-Source Forms. + +You may convey a covered work in object code form under the terms of sections 4 and +5, provided that you also convey the machine-readable Corresponding Source under the +terms of this License, in one of these ways: + +* **a)** Convey the object code in, or embodied in, a physical product (including a +physical distribution medium), accompanied by the Corresponding Source fixed on a +durable physical medium customarily used for software interchange. +* **b)** Convey the object code in, or embodied in, a physical product (including a +physical distribution medium), accompanied by a written offer, valid for at least +three years and valid for as long as you offer spare parts or customer support for +that product model, to give anyone who possesses the object code either (1) a copy of +the Corresponding Source for all the software in the product that is covered by this +License, on a durable physical medium customarily used for software interchange, for +a price no more than your reasonable cost of physically performing this conveying of +source, or (2) access to copy the Corresponding Source from a network server at no +charge. +* **c)** Convey individual copies of the object code with a copy of the written offer to +provide the Corresponding Source. This alternative is allowed only occasionally and +noncommercially, and only if you received the object code with such an offer, in +accord with subsection 6b. +* **d)** Convey the object code by offering access from a designated place (gratis or for +a charge), and offer equivalent access to the Corresponding Source in the same way +through the same place at no further charge. You need not require recipients to copy +the Corresponding Source along with the object code. If the place to copy the object +code is a network server, the Corresponding Source may be on a different server +(operated by you or a third party) that supports equivalent copying facilities, +provided you maintain clear directions next to the object code saying where to find +the Corresponding Source. Regardless of what server hosts the Corresponding Source, +you remain obligated to ensure that it is available for as long as needed to satisfy +these requirements. +* **e)** Convey the object code using peer-to-peer transmission, provided you inform +other peers where the object code and Corresponding Source of the work are being +offered to the general public at no charge under subsection 6d. + +A separable portion of the object code, whose source code is excluded from the +Corresponding Source as a System Library, need not be included in conveying the +object code work. + +A “User Product” is either (1) a “consumer product”, which +means any tangible personal property which is normally used for personal, family, or +household purposes, or (2) anything designed or sold for incorporation into a +dwelling. In determining whether a product is a consumer product, doubtful cases +shall be resolved in favor of coverage. For a particular product received by a +particular user, “normally used” refers to a typical or common use of +that class of product, regardless of the status of the particular user or of the way +in which the particular user actually uses, or expects or is expected to use, the +product. A product is a consumer product regardless of whether the product has +substantial commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + +“Installation Information” for a User Product means any methods, +procedures, authorization keys, or other information required to install and execute +modified versions of a covered work in that User Product from a modified version of +its Corresponding Source. The information must suffice to ensure that the continued +functioning of the modified object code is in no case prevented or interfered with +solely because modification has been made. + +If you convey an object code work under this section in, or with, or specifically for +use in, a User Product, and the conveying occurs as part of a transaction in which +the right of possession and use of the User Product is transferred to the recipient +in perpetuity or for a fixed term (regardless of how the transaction is +characterized), the Corresponding Source conveyed under this section must be +accompanied by the Installation Information. But this requirement does not apply if +neither you nor any third party retains the ability to install modified object code +on the User Product (for example, the work has been installed in ROM). + +The requirement to provide Installation Information does not include a requirement to +continue to provide support service, warranty, or updates for a work that has been +modified or installed by the recipient, or for the User Product in which it has been +modified or installed. Access to a network may be denied when the modification itself +materially and adversely affects the operation of the network or violates the rules +and protocols for communication across the network. + +Corresponding Source conveyed, and Installation Information provided, in accord with +this section must be in a format that is publicly documented (and with an +implementation available to the public in source code form), and must require no +special password or key for unpacking, reading or copying. + +### 7. Additional Terms. + +“Additional permissions” are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. Additional +permissions that are applicable to the entire Program shall be treated as though they +were included in this License, to the extent that they are valid under applicable +law. If additional permissions apply only to part of the Program, that part may be +used separately under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + +When you convey a copy of a covered work, you may at your option remove any +additional permissions from that copy, or from any part of it. (Additional +permissions may be written to require their own removal in certain cases when you +modify the work.) You may place additional permissions on material, added by you to a +covered work, for which you have or can give appropriate copyright permission. + +Notwithstanding any other provision of this License, for material you add to a +covered work, you may (if authorized by the copyright holders of that material) +supplement the terms of this License with terms: + +* **a)** Disclaiming warranty or limiting liability differently from the terms of +sections 15 and 16 of this License; or +* **b)** Requiring preservation of specified reasonable legal notices or author +attributions in that material or in the Appropriate Legal Notices displayed by works +containing it; or +* **c)** Prohibiting misrepresentation of the origin of that material, or requiring that +modified versions of such material be marked in reasonable ways as different from the +original version; or +* **d)** Limiting the use for publicity purposes of names of licensors or authors of the +material; or +* **e)** Declining to grant rights under trademark law for use of some trade names, +trademarks, or service marks; or +* **f)** Requiring indemnification of licensors and authors of that material by anyone +who conveys the material (or modified versions of it) with contractual assumptions of +liability to the recipient, for any liability that these contractual assumptions +directly impose on those licensors and authors. + +All other non-permissive additional terms are considered “further +restrictions” within the meaning of section 10. If the Program as you received +it, or any part of it, contains a notice stating that it is governed by this License +along with a term that is a further restriction, you may remove that term. If a +license document contains a further restriction but permits relicensing or conveying +under this License, you may add to a covered work material governed by the terms of +that license document, provided that the further restriction does not survive such +relicensing or conveying. + +If you add terms to a covered work in accord with this section, you must place, in +the relevant source files, a statement of the additional terms that apply to those +files, or a notice indicating where to find the applicable terms. + +Additional terms, permissive or non-permissive, may be stated in the form of a +separately written license, or stated as exceptions; the above requirements apply +either way. + +### 8. Termination. + +You may not propagate or modify a covered work except as expressly provided under +this License. Any attempt otherwise to propagate or modify it is void, and will +automatically terminate your rights under this License (including any patent licenses +granted under the third paragraph of section 11). + +However, if you cease all violation of this License, then your license from a +particular copyright holder is reinstated (a) provisionally, unless and until the +copyright holder explicitly and finally terminates your license, and (b) permanently, +if the copyright holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + +Moreover, your license from a particular copyright holder is reinstated permanently +if the copyright holder notifies you of the violation by some reasonable means, this +is the first time you have received notice of violation of this License (for any +work) from that copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + +Termination of your rights under this section does not terminate the licenses of +parties who have received copies or rights from you under this License. If your +rights have been terminated and not permanently reinstated, you do not qualify to +receive new licenses for the same material under section 10. + +### 9. Acceptance Not Required for Having Copies. + +You are not required to accept this License in order to receive or run a copy of the +Program. Ancillary propagation of a covered work occurring solely as a consequence of +using peer-to-peer transmission to receive a copy likewise does not require +acceptance. However, nothing other than this License grants you permission to +propagate or modify any covered work. These actions infringe copyright if you do not +accept this License. Therefore, by modifying or propagating a covered work, you +indicate your acceptance of this License to do so. + +### 10. Automatic Licensing of Downstream Recipients. + +Each time you convey a covered work, the recipient automatically receives a license +from the original licensors, to run, modify and propagate that work, subject to this +License. You are not responsible for enforcing compliance by third parties with this +License. + +An “entity transaction” is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an organization, or +merging organizations. If propagation of a covered work results from an entity +transaction, each party to that transaction who receives a copy of the work also +receives whatever licenses to the work the party's predecessor in interest had or +could give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if the predecessor +has it or can get it with reasonable efforts. + +You may not impose any further restrictions on the exercise of the rights granted or +affirmed under this License. For example, you may not impose a license fee, royalty, +or other charge for exercise of rights granted under this License, and you may not +initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging +that any patent claim is infringed by making, using, selling, offering for sale, or +importing the Program or any portion of it. + +### 11. Patents. + +A “contributor” is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The work thus +licensed is called the contributor's “contributor version”. + +A contributor's “essential patent claims” are all patent claims owned or +controlled by the contributor, whether already acquired or hereafter acquired, that +would be infringed by some manner, permitted by this License, of making, using, or +selling its contributor version, but do not include claims that would be infringed +only as a consequence of further modification of the contributor version. For +purposes of this definition, “control” includes the right to grant patent +sublicenses in a manner consistent with the requirements of this License. + +Each contributor grants you a non-exclusive, worldwide, royalty-free patent license +under the contributor's essential patent claims, to make, use, sell, offer for sale, +import and otherwise run, modify and propagate the contents of its contributor +version. + +In the following three paragraphs, a “patent license” is any express +agreement or commitment, however denominated, not to enforce a patent (such as an +express permission to practice a patent or covenant not to sue for patent +infringement). To “grant” such a patent license to a party means to make +such an agreement or commitment not to enforce a patent against the party. + +If you convey a covered work, knowingly relying on a patent license, and the +Corresponding Source of the work is not available for anyone to copy, free of charge +and under the terms of this License, through a publicly available network server or +other readily accessible means, then you must either (1) cause the Corresponding +Source to be so available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner consistent with +the requirements of this License, to extend the patent license to downstream +recipients. “Knowingly relying” means you have actual knowledge that, but +for the patent license, your conveying the covered work in a country, or your +recipient's use of the covered work in a country, would infringe one or more +identifiable patents in that country that you have reason to believe are valid. + +If, pursuant to or in connection with a single transaction or arrangement, you +convey, or propagate by procuring conveyance of, a covered work, and grant a patent +license to some of the parties receiving the covered work authorizing them to use, +propagate, modify or convey a specific copy of the covered work, then the patent +license you grant is automatically extended to all recipients of the covered work and +works based on it. + +A patent license is “discriminatory” if it does not include within the +scope of its coverage, prohibits the exercise of, or is conditioned on the +non-exercise of one or more of the rights that are specifically granted under this +License. You may not convey a covered work if you are a party to an arrangement with +a third party that is in the business of distributing software, under which you make +payment to the third party based on the extent of your activity of conveying the +work, and under which the third party grants, to any of the parties who would receive +the covered work from you, a discriminatory patent license (a) in connection with +copies of the covered work conveyed by you (or copies made from those copies), or (b) +primarily for and in connection with specific products or compilations that contain +the covered work, unless you entered into that arrangement, or that patent license +was granted, prior to 28 March 2007. + +Nothing in this License shall be construed as excluding or limiting any implied +license or other defenses to infringement that may otherwise be available to you +under applicable patent law. + +### 12. No Surrender of Others' Freedom. + +If conditions are imposed on you (whether by court order, agreement or otherwise) +that contradict the conditions of this License, they do not excuse you from the +conditions of this License. If you cannot convey a covered work so as to satisfy +simultaneously your obligations under this License and any other pertinent +obligations, then as a consequence you may not convey it at all. For example, if you +agree to terms that obligate you to collect a royalty for further conveying from +those to whom you convey the Program, the only way you could satisfy both those terms +and this License would be to refrain entirely from conveying the Program. + +### 13. Use with the GNU Affero General Public License. + +Notwithstanding any other provision of this License, you have permission to link or +combine any covered work with a work licensed under version 3 of the GNU Affero +General Public License into a single combined work, and to convey the resulting work. +The terms of this License will continue to apply to the part which is the covered +work, but the special requirements of the GNU Affero General Public License, section +13, concerning interaction through a network will apply to the combination as such. + +### 14. Revised Versions of this License. + +The Free Software Foundation may publish revised and/or new versions of the GNU +General Public License from time to time. Such new versions will be similar in spirit +to the present version, but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Program specifies that +a certain numbered version of the GNU General Public License “or any later +version” applies to it, you have the option of following the terms and +conditions either of that numbered version or of any later version published by the +Free Software Foundation. If the Program does not specify a version number of the GNU +General Public License, you may choose any version ever published by the Free +Software Foundation. + +If the Program specifies that a proxy can decide which future versions of the GNU +General Public License can be used, that proxy's public statement of acceptance of a +version permanently authorizes you to choose that version for the Program. + +Later license versions may give you additional or different permissions. However, no +additional obligations are imposed on any author or copyright holder as a result of +your choosing to follow a later version. + +### 15. Disclaimer of Warranty. + +THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM “AS IS” WITHOUT WARRANTY OF ANY KIND, EITHER +EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE +QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE +DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + +### 16. Limitation of Liability. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY +COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS +PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, +INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE +OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE +WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + +### 17. Interpretation of Sections 15 and 16. + +If the disclaimer of warranty and limitation of liability provided above cannot be +given local legal effect according to their terms, reviewing courts shall apply local +law that most closely approximates an absolute waiver of all civil liability in +connection with the Program, unless a warranty or assumption of liability accompanies +a copy of the Program in return for a fee. + +END OF TERMS AND CONDITIONS + +## How to Apply These Terms to Your New Programs + +If you develop a new program, and you want it to be of the greatest possible use to +the public, the best way to achieve this is to make it free software which everyone +can redistribute and change under these terms. + +To do so, attach the following notices to the program. It is safest to attach them +to the start of each source file to most effectively state the exclusion of warranty; +and each file should have at least the “copyright” line and a pointer to +where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + +If the program does terminal interaction, make it output a short notice like this +when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type 'show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type 'show c' for details. + +The hypothetical commands 'show w' and 'show c' should show the appropriate parts of +the General Public License. Of course, your program's commands might be different; +for a GUI interface, you would use an “about box”. + +You should also get your employer (if you work as a programmer) or school, if any, to +sign a “copyright disclaimer” for the program, if necessary. For more +information on this, and how to apply and follow the GNU GPL, see +<>. + +The GNU General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may consider it +more useful to permit linking proprietary applications with the library. If this is +what you want to do, use the GNU Lesser General Public License instead of this +License. But first, please read +<>. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 000000000..344387fc0 --- /dev/null +++ b/README.md @@ -0,0 +1,205 @@ +# 𑗕 easifemBase + + +![](./figures/what-is-easifem.svg) + +![](./figures/banner.jpeg) + +easifemBase (or, Base) library is the low level component in easifem. It contains routines and derived types which are helpful for implementing numerical methods for solving differential equation.| + +In Base library, we do not use object-oriented programming concepts and mainly use [multiple dispatch approach](https://en.wikipedia.org/wiki/Multiple_dispatch). This approach improves the flexibility and speed of easifemBase. All user-defined datatypes are declared in the `BaseType` module, and all methods are exposed through `BaseMethods` modules. In the Base library `string_class` is the only exception, wherein Object-oriented paradigm has been used. Currently, easifemBase has interface with BLAS95, Lapack95, Sparsekit, Metis, PlPlot, SuperLU, ARPACK, etc. + +## Usage + +### Use association + +```fortran +USE easifemBase +``` + +or + +```fortran +USE BaseType +USE BaseMethods +``` + +## System requirements + +EASIFEM requires following software packages to be installed on the system. + +| Component | Version | Latest tested version | Comment | +|:--- | :---: | :---: | :--- | +| **Gfortran**| >=9.0 | 12.0 | GNU Fortran compiler | +| **GCC**| >=9.0 | 12.0 | GNU-compiler collection| +| **OpenMP**| >= 4.5 | | Multithread shared memory parallelisation| +| **Curl**| >=7.87 | 7.87 | A command-line utility for transferring data from or to a remote server| +| **Git**| >=2.34 | 2.34.1 | A version control system and command-line utility for downloading packages from GitHub | +| **Cmake** | >=3.19 | 3.22.4 | Cross-platform family of tools designed to build, test and package software | +| **Ninja-build** | >=1.10 | 1.11.0 | Build system | +| **Python3** | >=3.7 | 3.11.0 | Scripting language | +| **Pip** | >=20 | 23.1.0 | Command line tool for downloading python packages | +| **LAPACK** | >=3.11.0 | 3.11.0 | Linear algebra package | +| **OpenBlas** | >= 0.3.20| 0.3.30 | Optimize BLAS library | +| **HDF5** | >=1.10 | 1.10.7 | High-performance data software-library and file-format | +| **PlPlot** | >=5.15.0 | 5.15.0 | Cross-platform, scientific graphics plotting library | +| **Boost** | | | | +| **Gnuplot** | >=5.0 | 5.4 | Portable command-line driven graphing utility | +| **Doxygen** | >=1.9.1 | 1.9.1 | documentation generation | +| **GTK-4** | | | n | + + +## External packages + +EASIFEM depends upon the following external packages (extpkgs) that are not shipped with the source-code. + +| extpkg| description | command | +|:--- | :--- | :--- | +| [OpenBlas](https://www.openblas.net/) | Highly optimized BLAS | easifem install openblas | +| [SuperLU](https://github.com/xiaoyeli/superlu.git) | Direct solution of large, sparse, nonsymmetric systems of linear equations | easifem install superlu | +| [LIS](https://github.com/anishida/lis.git) | Linear interative solver | easifem install lis| +| [METIS](https://github.com/KarypisLab/METIS) | Mesh partitioning library | easifem install metis | +| [SCOTCH](https://gitlab.inria.fr/scotch/scotch) | Mesh partitioning library | easifem install scotch | +| [ARPACK](https://github.com/opencollab/arpack-ng) | Eigensolver for sparse matrices | easifem install arpack | +| [FFTW](https://www.fftw.org/) | Fast Fourier Transform| easifem install fftw | +| [GTK-Fortran](https://github.com/vmagnin/gtk-fortran) | Fortran bindings for GTK-4 library | easifem install gtk-fortran | +| [LAPACK95](https://github.com/vickysharma0812/LAPACK95.git) | Fortran 95 interface for Lapack library | easifem install lapack95 | +| [Sparsekit](https://github.com/vickysharma0812/Sparsekit.git) | Fortran library for sparse matrices | easifem install sparsekit | +| [Gmsh](https://gmsh.info/) | Finite element mesh generator| easifem install gmsh | + + +## Installation + +You can use following instructions to install easifemBase depending upon your system. + +- [Linux](./pages/Install_Linux.md) +- [MacOSX](./pages/Install_MacOSX.md) +- [Windows](./pages/Install_Windows.md) + +## Structure + +The Base library consists two components: + +1. BaseType `BaseType.F90`, which contains the user-defined data-type. You can see the list of user-defined data type [here](./pages/BaseType.md) +2. BaseMethods `BaseMethods.F90`, contains the modules (each module defines the routines for data-types defined in `BaseType.F90`.) The list of modules defined in BaseMethods can be found [here](./pages/BaseMethods.md) + +The source directory is shown in figure given below. The source directory has two directories + +1. 📁 `modules` +2. 📁 `submodules` + +The `modules` directory mainly contains header and interface of methods. The implementation is given in submodules directory. + +:::info +Both `BaseType.F90` and `BaseMethods.F90` are included in `modules` directory. +::: + +Let us understand the structure of the Base library by an example of `CSRSparsity_` data type. + +1. First, we define `CSRSparsity_` in `BaseType.F90` as + + +```fortran +TYPE :: CSRSparsity_ + INTEGER(I4B) :: nnz = 0 + INTEGER(I4B) :: ncol = 0 + INTEGER(I4B) :: nrow = 0 + LOGICAL(LGT) :: isSorted = .FALSE. + LOGICAL(LGT) :: isInitiated = .FALSE. + LOGICAL(LGT) :: isSparsityLock = .FALSE. + LOGICAL(LGT) :: isDiagStored = .FALSE. + INTEGER(I4B), ALLOCATABLE :: IA(:) + INTEGER(I4B), ALLOCATABLE :: JA(:) + INTEGER(I4B), ALLOCATABLE :: idiag(:) + TYPE(IntVector_), ALLOCATABLE :: row(:) + TYPE(DOF_) :: idof + !! DOF for row + TYPE(DOF_) :: jdof + !! DOF for columns +END TYPE CSRSparsity_ +``` + + +2. Then we create a directory called `CSRSparsity` in both `modules` and `submodules` directory. +3. In `modules/CSRSparsity` we create `CSRSparsity_Method.F90` file. +4. In `modules/CSRSparsity/CSRSparsity_Method.F90` we define a module `CSRSparsity_Method` (same name as file). +5. In `CSRSparsity_Method` module, we only define interface of methods. In this way, this file can be considered as header file. See, the example given below: +6. In `submodules/CSRSparsity`, we create `CSRSparsity_Method@ConstructorMethods.F90`, which contains the contruction related routines. +7. Also, we create `CSRSparsity_Method@IOMethods.F90`, which include methods related to input and output. + + +```fortran +MODULE CSRSparsity_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +INTERFACE Initiate + MODULE SUBROUTINE csr_initiate1(obj, ncol, nrow, idof, jdof) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ncol, nrow + TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof + !! DOF for row + TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof + !! DOF for column + END SUBROUTINE csr_initiate1 +END INTERFACE Initiate + +INTERFACE Display + MODULE SUBROUTINE csr_Display(obj, Msg, UnitNo) + TYPE(CSRSparsity_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: Msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + END SUBROUTINE csr_Display +END INTERFACE Display + +END MODULE CSRSparsity_Method +``` + +CSRSparsity_Method@ConstructorMethods.F90 + +```fortran +SUBMODULE(CSRSparsity_Method) ConstructorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +MODULE PROCEDURE csr_initiate1 +obj%nnz = 0 +obj%ncol = ncol +obj%nrow = nrow +END PROCEDURE csr_initiate1 + +END SUBMODULE ConstructorMethods +``` + +CSRSparsity_Method@IOMethods.F90 + +```fortran +SUBMODULE(CSRSparsity_Method) IOMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +MODULE PROCEDURE csr_Display +CALL Display(Msg, unitNo=unitNo) +CALL Display(obj%nnz, "# NNZ : ", unitNo=unitNo) +END PROCEDURE csr_Display + +END SUBMODULE IOMethods +``` + +![](./figures/figure-2.svg) + +## Run on Cloud + +Coming soon. + +## Contributing + +## Credits + +## License + +[License](LICENSE) diff --git a/Workspaces/BLAS.code-workspace b/Workspaces/BLAS.code-workspace new file mode 100644 index 000000000..13b53c2e3 --- /dev/null +++ b/Workspaces/BLAS.code-workspace @@ -0,0 +1,13 @@ +{ + "folders": [ + { + "path": "../src/modules/BLAS" + }, + { + "path": "../src/submodules/BLAS" + }, + { + "path": "../tests/BLAS" + } + ] +} \ No newline at end of file diff --git a/Workspaces/OpenMP.code-workspace b/Workspaces/OpenMP.code-workspace new file mode 100644 index 000000000..a14db76ea --- /dev/null +++ b/Workspaces/OpenMP.code-workspace @@ -0,0 +1,13 @@ +{ + "folders": [ + { + "path": "../src/modules/BLAS" + }, + { + "path": "../src/submodules/BLAS" + }, + { + "path": "../tests/BLAS" + } + ] +} diff --git a/Workspaces/Polynomial b/Workspaces/Polynomial new file mode 100644 index 000000000..e69de29bb diff --git a/Workspaces/SparseMatrix.code-workspace b/Workspaces/SparseMatrix.code-workspace new file mode 100644 index 000000000..685515171 --- /dev/null +++ b/Workspaces/SparseMatrix.code-workspace @@ -0,0 +1,16 @@ +{ + "folders": [ + { + "path": "../src/modules/CSRMatrix" + }, + { + "path": "../src/modules/CSRSparsity" + }, + { + "path": "../src/submodules/CSRMatrix" + }, + { + "path": "../src/submodules/CSRSparsity" + } + ] +} \ No newline at end of file diff --git a/Workspaces/Tensor.code-workspace b/Workspaces/Tensor.code-workspace new file mode 100644 index 000000000..35b00a876 --- /dev/null +++ b/Workspaces/Tensor.code-workspace @@ -0,0 +1,10 @@ +{ + "folders": [ + { + "path": "../src/modules/Rank2Tensor" + }, + { + "path": "../src/submodules/Rank2Tensor" + } + ] +} \ No newline at end of file diff --git a/Workspaces/Utility.code-workspace b/Workspaces/Utility.code-workspace new file mode 100644 index 000000000..8ecd86e8d --- /dev/null +++ b/Workspaces/Utility.code-workspace @@ -0,0 +1,10 @@ +{ + "folders": [ + { + "path": "../src/modules/Utility" + }, + { + "path": "../src/submodules/Utility" + } + ] +} \ No newline at end of file diff --git a/Workspaces/refelem.code-workspace b/Workspaces/refelem.code-workspace new file mode 100644 index 000000000..ad3ce4813 --- /dev/null +++ b/Workspaces/refelem.code-workspace @@ -0,0 +1,25 @@ +{ + "folders": [ + { + "path": "../src/modules/ElemshapeData" + }, + { + "path": "../src/modules/Geometry" + }, + { + "path": "../src/modules/QuadraturePoint" + }, + { + "path": "../src/modules/ReferenceElement" + }, + { + "path": "../src/submodules/ElemshapeData" + }, + { + "path": "../src/submodules/QuadraturePoint" + }, + { + "path": "../src/submodules/ReferenceElement" + } + ] +} \ No newline at end of file diff --git a/base.code-workspace b/base.code-workspace new file mode 100644 index 000000000..cc9258653 --- /dev/null +++ b/base.code-workspace @@ -0,0 +1,10 @@ +{ + "folders": [ + { + "path": "." + } + ], + "settings": { + "cmake.installPrefix": "~/.easifem/base" + } +} \ No newline at end of file diff --git a/build.py b/build.py new file mode 100755 index 000000000..2e1495c8f --- /dev/null +++ b/build.py @@ -0,0 +1,53 @@ +#!/usr/bin/env python3 +#!/Users/easifem/anaconda3/envs/easifem/bin/python3 + +# This program is a part of EASIFEM library. +# See. www.easifem.com +# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. +# + +import os +import platform + +print("Detecting OS type...") +_os = platform.system() +if _os == "Windows": + print("ERROR: INSTALLATION on windows is work in progress") + exit + # print("Please use Windows Subsystem Linux(WSL) ") + # print("Installation DONE!!") +else: + cmake_def = "" + cmake_def += ' -G "Ninja"' # Unix Makefiles, Ninja, Ninja Multi-Config + cmake_def += " -D USE_OPENMP:BOOL=ON" # OFF + cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Debug" # Release + cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" + cmake_def += " -D CMAKE_EXPORT_COMPILE_COMMANDS:BOOL=ON" + cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" + cmake_def += " -D USE_PLPLOT:BOOL=ON" + cmake_def += " -D USE_BLAS95:BOOL=ON" + cmake_def += " -D USE_LAPACK95:BOOL=ON" + cmake_def += " -D USE_FFTW:BOOL=ON" + cmake_def += " -D USE_GTK:BOOL=OFF" + cmake_def += " -D USE_ARPACK:BOOL=ON" + cmake_def += " -D USE_SUPERLU:BOOL=ON" + cmake_def += " -D USE_LIS:BOOL=ON" + cmake_def += " -D USE_PARPACK:BOOL=OFF" + cmake_def += " -D USE_METIS:BOOL=OFF" + cmake_def += " -D USE_LUA:BOOL=ON" + cmake_def += " -D USE_INT32:BOOL=ON" + cmake_def += " -D USE_REAL64:BOOL=ON" + cmake_def += " -D USE_RAYLIB:BOOL=ON" + cmake_def += " -D USE_COLORDISP:BOOL=OFF" + + print("CMAKE DEF : ", cmake_def) + + _build0 = os.path.join(os.environ["HOME"], "temp") + build_dir = os.path.join( + os.environ.get("EASIFEM_BUILD_DIR", _build0), "easifem", "base", "build" + ) + # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" + os.makedirs(build_dir, exist_ok=True) + os.system(f"cmake {cmake_def} -S ./ -B {build_dir}") + os.system(f"cmake --build {build_dir}") + print("Build DONE!!") diff --git a/cmake/Config.cmake.in b/cmake/Config.cmake.in new file mode 100644 index 000000000..3758fb80e --- /dev/null +++ b/cmake/Config.cmake.in @@ -0,0 +1,75 @@ +@PACKAGE_INIT@ + +LIST( + APPEND + ExternalLibs + Sparsekit + toml-f +) + +IF( @USE_LAPACK95@ ) + LIST(APPEND + ExternalLibs + LAPACK95 + ) +ENDIF() + +IF( @USE_ARPACK@ ) + LIST(APPEND + ExternalLibs + arpackng + ) +ENDIF() + +IF( @USE_RAYLIB@ ) + LIST(APPEND + ExternalLibs + raylib + ) +ENDIF() + +FOREACH(LIB ${ExternalLibs}) + FIND_PACKAGE(${LIB} REQUIRED) +ENDFOREACH() + +IF( @USE_OPENMP@ ) + IF(APPLE) + IF(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES "AppleClang") + SET(OpenMP_C "${CMAKE_C_COMPILER}" CACHE STRING "" FORCE) + SET(OpenMP_C_FLAGS + "-fopenmp=libomp -Wno-unused-command-line-argument" + CACHE STRING + "" + FORCE + ) + SET(OpenMP_C_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE) + SET(OpenMP_libomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) + SET(OpenMP_libgomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) + SET(OpenMP_libiomp5_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) + + SET(OpenMP_CXX "${CMAKE_CXX_COMPILER}" CACHE STRING "" FORCE) + SET( + OpenMP_CXX_FLAGS + "-fopenmp=libomp -Wno-unused-command-line-argument" + CACHE STRING + "" + FORCE + ) + + SET(OpenMP_CXX_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE) + ENDIF() + ENDIF() + + FIND_PACKAGE(OpenMP REQUIRED) +ENDIF() + + +set_and_check( + "@PROJECT_NAME@_INCLUDE_DIR" "@PACKAGE_INSTALL_INCLUDEDIR@") + +include( + "${CMAKE_CURRENT_LIST_DIR}/@TARGETS_EXPORT_NAME@.cmake") + +check_required_components( + "@PROJECT_NAME@" + ) diff --git a/cmake/Modules/FindLAPACK.cmake b/cmake/Modules/FindLAPACK.cmake new file mode 100644 index 000000000..9f2f0e93e --- /dev/null +++ b/cmake/Modules/FindLAPACK.cmake @@ -0,0 +1,563 @@ +# Distributed under the OSI-approved BSD 3-Clause License. See accompanying +# file Copyright.txt or https://cmake.org/licensing for details. + +#[=======================================================================[.rst: +FindLAPACK +---------- + +Find Linear Algebra PACKage (LAPACK) library + +This module finds an installed Fortran library that implements the +LAPACK linear-algebra interface (see http://www.netlib.org/lapack/). + +The approach follows that taken for the ``autoconf`` macro file, +``acx_lapack.m4`` (distributed at +http://ac-archive.sourceforge.net/ac-archive/acx_lapack.html). + +Input Variables +^^^^^^^^^^^^^^^ + +The following variables may be set to influence this module's behavior: + +``BLA_STATIC`` + if ``ON`` use static linkage + +``BLA_VENDOR`` + If set, checks only the specified vendor, if not set checks all the + possibilities. List of vendors valid in this module: + + * ``FlexiBLAS`` + * ``OpenBLAS`` + * ``FLAME`` + * ``Intel10_32`` (intel mkl v10 32 bit, threaded code) + * ``Intel10_64lp`` (intel mkl v10+ 64 bit, threaded code, lp64 model) + * ``Intel10_64lp_seq`` (intel mkl v10+ 64 bit, sequential code, lp64 model) + * ``Intel10_64ilp`` (intel mkl v10+ 64 bit, threaded code, ilp64 model) + * ``Intel10_64ilp_seq`` (intel mkl v10+ 64 bit, sequential code, ilp64 model) + * ``Intel10_64_dyn`` (intel mkl v10+ 64 bit, single dynamic library) + * ``Intel`` (obsolete versions of mkl 32 and 64 bit) + * ``ACML`` + * ``Apple`` + * ``NAS`` + * ``Arm`` + * ``Arm_mp`` + * ``Arm_ilp64`` + * ``Arm_ilp64_mp`` + * ``Generic`` + +``BLA_F95`` + if ``ON`` tries to find the BLAS95/LAPACK95 interfaces + +Imported targets +^^^^^^^^^^^^^^^^ + +This module defines the following :prop_tgt:`IMPORTED` target: + +``LAPACK::LAPACK`` + The libraries to use for LAPACK, if found. + +Result Variables +^^^^^^^^^^^^^^^^ + +This module defines the following variables: + +``LAPACK_FOUND`` + library implementing the LAPACK interface is found +``LAPACK_LINKER_FLAGS`` + uncached list of required linker flags (excluding ``-l`` and ``-L``). +``LAPACK_LIBRARIES`` + uncached list of libraries (using full path name) to link against + to use LAPACK +``LAPACK95_LIBRARIES`` + uncached list of libraries (using full path name) to link against + to use LAPACK95 +``LAPACK95_FOUND`` + library implementing the LAPACK95 interface is found + +.. note:: + + C, CXX or Fortran must be enabled to detect a BLAS/LAPACK library. + C or CXX must be enabled to use Intel Math Kernel Library (MKL). + + For example, to use Intel MKL libraries and/or Intel compiler: + + .. code-block:: cmake + + set(BLA_VENDOR Intel10_64lp) + find_package(LAPACK) +#]=======================================================================] + +if(CMAKE_Fortran_COMPILER_LOADED) + include(CheckFortranFunctionExists) + # include(${CMAKE_CURRENT_LIST_DIR}/CheckFortranFunctionExists.cmake) +else() + include(CheckFunctionExists) +endif() +include(CMakePushCheckState) +include(FindPackageHandleStandardArgs) + +macro(_lapack_find_library_setup) + cmake_push_check_state() + set(CMAKE_REQUIRED_QUIET ${LAPACK_FIND_QUIETLY}) + + set(_lapack_ORIG_CMAKE_FIND_LIBRARY_SUFFIXES ${CMAKE_FIND_LIBRARY_SUFFIXES}) + if(BLA_STATIC) + if(WIN32) + set(CMAKE_FIND_LIBRARY_SUFFIXES .lib ${CMAKE_FIND_LIBRARY_SUFFIXES}) + else() + set(CMAKE_FIND_LIBRARY_SUFFIXES .a ${CMAKE_FIND_LIBRARY_SUFFIXES}) + endif() + else() + if(CMAKE_SYSTEM_NAME STREQUAL "Linux") + # for ubuntu's libblas3gf and liblapack3gf packages + set(CMAKE_FIND_LIBRARY_SUFFIXES ${CMAKE_FIND_LIBRARY_SUFFIXES} .so.3gf) + endif() + endif() +endmacro() + +macro(_lapack_find_library_teardown) + set(CMAKE_FIND_LIBRARY_SUFFIXES ${_lapack_ORIG_CMAKE_FIND_LIBRARY_SUFFIXES}) + unset(_lapack_ORIG_CMAKE_FIND_LIBRARY_SUFFIXES) + cmake_pop_check_state() +endmacro() + +# TODO: move this stuff to a separate module + +macro( + CHECK_LAPACK_LIBRARIES + LIBRARIES + _prefix + _name + _flags + _list + _threadlibs + _addlibdir + _subdirs + _blas) + # This macro checks for the existence of the combination of fortran libraries + # given by _list. If the combination is found, this macro checks (using the + # Check_Fortran_Function_Exists macro) whether can link against that library + # combination using the name of a routine given by _name using the linker + # flags given by _flags. If the combination of libraries is found and passes + # the link test, LIBRARIES is set to the list of complete library paths that + # have been found. Otherwise, LIBRARIES is set to FALSE. + + # N.B. _prefix is the prefix applied to the names of all cached variables that + # are generated internally and marked advanced by this macro. _addlibdir is a + # list of additional search paths. _subdirs is a list of path suffixes to be + # used by find_library(). + + set(_libraries_work TRUE) + set(${LIBRARIES}) + set(_combined_name) + + set(_extaddlibdir "${_addlibdir}") + if(WIN32) + list(APPEND _extaddlibdir ENV LIB) + elseif(APPLE) + list(APPEND _extaddlibdir ENV DYLD_LIBRARY_PATH) + else() + list(APPEND _extaddlibdir ENV LD_LIBRARY_PATH) + endif() + list(APPEND _extaddlibdir "${CMAKE_C_IMPLICIT_LINK_DIRECTORIES}") + + foreach(_library ${_list}) + if(_library MATCHES "^-Wl,--(start|end)-group$") + # Respect linker flags like --start/end-group (required by MKL) + set(${LIBRARIES} ${${LIBRARIES}} "${_library}") + else() + set(_combined_name ${_combined_name}_${_library}) + if(_libraries_work) + find_library( + ${_prefix}_${_library}_LIBRARY + NAMES ${_library} NAMES_PER_DIR + PATHS ${_extaddlibdir} + PATH_SUFFIXES ${_subdirs}) + # message("DEBUG: find_library(${_library}) got + # ${${_prefix}_${_library}_LIBRARY}") + mark_as_advanced(${_prefix}_${_library}_LIBRARY) + set(${LIBRARIES} ${${LIBRARIES}} ${${_prefix}_${_library}_LIBRARY}) + set(_libraries_work ${${_prefix}_${_library}_LIBRARY}) + endif() + endif() + endforeach() + unset(_library) + + if(_libraries_work) + # Test this combination of libraries. + set(CMAKE_REQUIRED_LIBRARIES ${_flags} ${${LIBRARIES}} ${_blas} + ${_threadlibs}) + # message("DEBUG: CMAKE_REQUIRED_LIBRARIES = ${CMAKE_REQUIRED_LIBRARIES}") + if(CMAKE_Fortran_COMPILER_LOADED) + check_fortran_function_exists("${_name}" + ${_prefix}${_combined_name}_WORKS) + else() + check_function_exists("${_name}_" ${_prefix}${_combined_name}_WORKS) + endif() + set(CMAKE_REQUIRED_LIBRARIES) + set(_libraries_work ${${_prefix}${_combined_name}_WORKS}) + endif() + + if(_libraries_work) + if("${_list}${_blas}" STREQUAL "") + set(${LIBRARIES} "${LIBRARIES}-PLACEHOLDER-FOR-EMPTY-LIBRARIES") + else() + set(${LIBRARIES} ${${LIBRARIES}} ${_blas} ${_threadlibs}) + endif() + else() + set(${LIBRARIES} FALSE) + endif() + + unset(_extaddlibdir) + unset(_libraries_work) + unset(_combined_name) + # message("DEBUG: ${LIBRARIES} = ${${LIBRARIES}}") +endmacro() + +macro(_lapack_find_dependency dep) + set(_lapack_quiet_arg) + if(LAPACK_FIND_QUIETLY) + set(_lapack_quiet_arg QUIET) + endif() + set(_lapack_required_arg) + if(LAPACK_FIND_REQUIRED) + set(_lapack_required_arg REQUIRED) + endif() + find_package(${dep} ${ARGN} ${_lapack_quiet_arg} ${_lapack_required_arg}) + if(NOT ${dep}_FOUND) + set(LAPACK_NOT_FOUND_MESSAGE + "LAPACK could not be found because dependency ${dep} could not be found." + ) + endif() + + set(_lapack_required_arg) + set(_lapack_quiet_arg) +endmacro() + +_lapack_find_library_setup() + +set(LAPACK_LINKER_FLAGS) +set(LAPACK_LIBRARIES) +set(LAPACK95_LIBRARIES) + +# Check the language being used +if(NOT + (CMAKE_C_COMPILER_LOADED + OR CMAKE_CXX_COMPILER_LOADED + OR CMAKE_Fortran_COMPILER_LOADED)) + set(LAPACK_NOT_FOUND_MESSAGE + "FindLAPACK requires Fortran, C, or C++ to be enabled.") +endif() + +# Load BLAS +if(NOT LAPACK_NOT_FOUND_MESSAGE) + _lapack_find_dependency(BLAS) +endif() + +# Search for different LAPACK distributions if BLAS is found +if(NOT LAPACK_NOT_FOUND_MESSAGE) + set(LAPACK_LINKER_FLAGS ${BLAS_LINKER_FLAGS}) + if(NOT $ENV{BLA_VENDOR} STREQUAL "") + set(BLA_VENDOR $ENV{BLA_VENDOR}) + elseif(NOT BLA_VENDOR) + set(BLA_VENDOR "All") + endif() + + # LAPACK in the Intel MKL 10+ library? + if(NOT LAPACK_LIBRARIES + AND (BLA_VENDOR MATCHES "Intel" OR BLA_VENDOR STREQUAL "All") + AND (CMAKE_C_COMPILER_LOADED OR CMAKE_CXX_COMPILER_LOADED)) + # System-specific settings + if(NOT WIN32) + set(LAPACK_mkl_LM "-lm") + set(LAPACK_mkl_LDL "-ldl") + endif() + + _lapack_find_dependency(Threads) + + if(BLA_VENDOR MATCHES "_64ilp") + set(LAPACK_mkl_ILP_MODE "ilp64") + else() + set(LAPACK_mkl_ILP_MODE "lp64") + endif() + + set(LAPACK_SEARCH_LIBS "") + + if(BLA_F95) + set(LAPACK_mkl_SEARCH_SYMBOL "cheev_f95") + set(_LIBRARIES LAPACK95_LIBRARIES) + set(_BLAS_LIBRARIES ${BLAS95_LIBRARIES}) + + # old + list(APPEND LAPACK_SEARCH_LIBS "mkl_lapack95") + # new >= 10.3 + list(APPEND LAPACK_SEARCH_LIBS "mkl_intel_c") + list(APPEND LAPACK_SEARCH_LIBS "mkl_lapack95_${LAPACK_mkl_ILP_MODE}") + else() + set(LAPACK_mkl_SEARCH_SYMBOL "cheev") + set(_LIBRARIES LAPACK_LIBRARIES) + set(_BLAS_LIBRARIES ${BLAS_LIBRARIES}) + + # old and new >= 10.3 + list(APPEND LAPACK_SEARCH_LIBS "mkl_lapack") + endif() + + # MKL uses a multitude of partially platform-specific subdirectories: + if(BLA_VENDOR STREQUAL "Intel10_32") + set(LAPACK_mkl_ARCH_NAME "ia32") + else() + set(LAPACK_mkl_ARCH_NAME "intel64") + endif() + if(WIN32) + set(LAPACK_mkl_OS_NAME "win") + elseif(APPLE) + set(LAPACK_mkl_OS_NAME "mac") + else() + set(LAPACK_mkl_OS_NAME "lin") + endif() + if(DEFINED ENV{MKLROOT}) + file(TO_CMAKE_PATH "$ENV{MKLROOT}" LAPACK_mkl_MKLROOT) + # If MKLROOT points to the subdirectory 'mkl', use the parent directory + # instead so we can better detect other relevant libraries in 'compiler' + # or 'tbb': + get_filename_component(LAPACK_mkl_MKLROOT_LAST_DIR + "${LAPACK_mkl_MKLROOT}" NAME) + if(LAPACK_mkl_MKLROOT_LAST_DIR STREQUAL "mkl") + get_filename_component(LAPACK_mkl_MKLROOT "${LAPACK_mkl_MKLROOT}" + DIRECTORY) + endif() + endif() + set(LAPACK_mkl_LIB_PATH_SUFFIXES + "compiler/lib" + "compiler/lib/${LAPACK_mkl_ARCH_NAME}_${LAPACK_mkl_OS_NAME}" + "compiler/lib/${LAPACK_mkl_ARCH_NAME}" + "mkl/lib" + "mkl/lib/${LAPACK_mkl_ARCH_NAME}_${LAPACK_mkl_OS_NAME}" + "mkl/lib/${LAPACK_mkl_ARCH_NAME}" + "lib/${LAPACK_mkl_ARCH_NAME}_${LAPACK_mkl_OS_NAME}") + + # First try empty lapack libs + if(NOT ${_LIBRARIES}) + Check_Lapack_Libraries( + ${_LIBRARIES} + LAPACK + ${LAPACK_mkl_SEARCH_SYMBOL} + "" + "" + "${CMAKE_THREAD_LIBS_INIT};${LAPACK_mkl_LM};${LAPACK_mkl_LDL}" + "${LAPACK_mkl_MKLROOT}" + "${LAPACK_mkl_LIB_PATH_SUFFIXES}" + "${_BLAS_LIBRARIES}") + endif() + + # Then try the search libs + foreach(IT ${LAPACK_SEARCH_LIBS}) + string(REPLACE " " ";" SEARCH_LIBS ${IT}) + if(NOT ${_LIBRARIES}) + Check_Lapack_Libraries( + ${_LIBRARIES} + LAPACK + ${LAPACK_mkl_SEARCH_SYMBOL} + "" + "${SEARCH_LIBS}" + "${CMAKE_THREAD_LIBS_INIT};${LAPACK_mkl_LM};${LAPACK_mkl_LDL}" + "${LAPACK_mkl_MKLROOT}" + "${LAPACK_mkl_LIB_PATH_SUFFIXES}" + "${_BLAS_LIBRARIES}") + endif() + endforeach() + + unset(LAPACK_mkl_ILP_MODE) + unset(LAPACK_mkl_SEARCH_SYMBOL) + unset(LAPACK_mkl_LM) + unset(LAPACK_mkl_LDL) + unset(LAPACK_mkl_MKLROOT) + unset(LAPACK_mkl_ARCH_NAME) + unset(LAPACK_mkl_OS_NAME) + unset(LAPACK_mkl_LIB_PATH_SUFFIXES) + endif() + + # gotoblas? (http://www.tacc.utexas.edu/tacc-projects/gotoblas2) + if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "Goto" OR BLA_VENDOR STREQUAL + "All")) + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "goto2" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() + + # FlexiBLAS? (http://www.mpi-magdeburg.mpg.de/mpcsc/software/FlexiBLAS/) + if(NOT LAPACK_LIBRARIES + AND (BLA_VENDOR STREQUAL "FlexiBLAS" OR BLA_VENDOR STREQUAL "All")) + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "flexiblas" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() + + # OpenBLAS? (http://www.openblas.net) + if(NOT LAPACK_LIBRARIES + AND (BLA_VENDOR STREQUAL "OpenBLAS" OR BLA_VENDOR STREQUAL "All")) + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "openblas" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() + + # ArmPL? + # (https://developer.arm.com/tools-and-software/server-and-hpc/compile/arm-compiler-for-linux/arm-performance-libraries) + if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR MATCHES "Arm" OR BLA_VENDOR STREQUAL + "All")) + # Check for 64bit Integer support + if(BLA_VENDOR MATCHES "_ilp64") + set(LAPACK_armpl_LIB "armpl_ilp64") + else() + set(LAPACK_armpl_LIB "armpl_lp64") + endif() + + # Check for OpenMP support, VIA BLA_VENDOR of Arm_mp or Arm_ipl64_mp + if(BLA_VENDOR MATCHES "_mp") + set(LAPACK_armpl_LIB "${LAPACK_armpl_LIB}_mp") + endif() + + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "${LAPACK_armpl_LIB}" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() + + # FLAME's blis library? (https://github.com/flame/blis) + if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "FLAME" OR BLA_VENDOR + STREQUAL "All")) + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "flame" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() + + # BLAS in acml library? + if(BLA_VENDOR MATCHES "ACML" OR BLA_VENDOR STREQUAL "All") + if(BLAS_LIBRARIES MATCHES ".+acml.+") + set(LAPACK_LIBRARIES ${BLAS_LIBRARIES}) + endif() + endif() + + # Apple LAPACK library? + if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "Apple" OR BLA_VENDOR + STREQUAL "All")) + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "Accelerate" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() + + # Apple NAS (vecLib) library? + if(NOT LAPACK_LIBRARIES AND (BLA_VENDOR STREQUAL "NAS" OR BLA_VENDOR STREQUAL + "All")) + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "vecLib" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() + + # Generic LAPACK library? + if(NOT LAPACK_LIBRARIES + AND (BLA_VENDOR STREQUAL "Generic" + OR BLA_VENDOR STREQUAL "ATLAS" + OR BLA_VENDOR STREQUAL "All")) + Check_Lapack_Libraries( + LAPACK_LIBRARIES + LAPACK + cheev + "" + "lapack" + "" + "" + "" + "${BLAS_LIBRARIES}") + endif() +endif() + +if(BLA_F95) + set(LAPACK_LIBRARIES "${LAPACK95_LIBRARIES}") +endif() + +if(LAPACK_NOT_FOUND_MESSAGE) + set(LAPACK_NOT_FOUND_MESSAGE REASON_FAILURE_MESSAGE + ${LAPACK_NOT_FOUND_MESSAGE}) +endif() +find_package_handle_standard_args( + LAPACK REQUIRED_VARS LAPACK_LIBRARIES ${LAPACK_NOT_FOUND_MESSAGE}) +unset(LAPACK_NOT_FOUND_MESSAGE) + +if(BLA_F95) + set(LAPACK95_FOUND ${LAPACK_FOUND}) +endif() + +# On compilers that implicitly link LAPACK (such as ftn, cc, and CC on Cray HPC +# machines) we used a placeholder for empty LAPACK_LIBRARIES to get through our +# logic above. +if(LAPACK_LIBRARIES STREQUAL "LAPACK_LIBRARIES-PLACEHOLDER-FOR-EMPTY-LIBRARIES") + set(LAPACK_LIBRARIES "") +endif() + +if(LAPACK_FOUND AND NOT TARGET LAPACK::LAPACK) + add_library(LAPACK::LAPACK INTERFACE IMPORTED) + set(_lapack_libs "${LAPACK_LIBRARIES}") + if(_lapack_libs AND TARGET BLAS::BLAS) + # remove the ${BLAS_LIBRARIES} from the interface and replace it with the + # BLAS::BLAS target + list(REMOVE_ITEM _lapack_libs "${BLAS_LIBRARIES}") + endif() + + if(_lapack_libs) + set_target_properties(LAPACK::LAPACK PROPERTIES INTERFACE_LINK_LIBRARIES + "${_lapack_libs}") + endif() + unset(_lapack_libs) +endif() + +_lapack_find_library_teardown() + diff --git a/cmake/addARPACK.cmake b/cmake/addARPACK.cmake new file mode 100644 index 000000000..93a013037 --- /dev/null +++ b/cmake/addARPACK.cmake @@ -0,0 +1,30 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_ARPACK OFF) +if(USE_ARPACK) + find_package(arpackng REQUIRED) + if(arpackng_FOUND) + message(STATUS "FOUND ARPACK-NG") + list(APPEND TARGET_COMPILE_DEF "-DUSE_ARPACK") + list(APPEND TARGET_COMPILE_OPT ${arpackng_Fortran_FLAGS}) + target_link_libraries(${PROJECT_NAME} PUBLIC ARPACK::ARPACK) + else() + message(ERROR "NOT FOUND ARPACK-NG") + endif() +endif() diff --git a/cmake/addFFTW.cmake b/cmake/addFFTW.cmake new file mode 100644 index 000000000..0632ce4eb --- /dev/null +++ b/cmake/addFFTW.cmake @@ -0,0 +1,33 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_FFTW OFF) +if(USE_FFTW) + + list(APPEND TARGET_COMPILE_DEF "-DUSE_FFTW") + + find_library(FFTW_LIBRARIES NAMES fftw fftw3 REQUIRED) + + target_link_libraries(${PROJECT_NAME} PUBLIC ${FFTW_LIBRARIES}) + message(STATUS "FFTW_LIBRARY : ${FFTW_LIBRARIES}") + +else() + + message(STATUS "NOT USING FFTW LIBRARIES") + +endif() diff --git a/cmake/addGTKFortran.cmake b/cmake/addGTKFortran.cmake new file mode 100644 index 000000000..7a10381c3 --- /dev/null +++ b/cmake/addGTKFortran.cmake @@ -0,0 +1,49 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_GTK OFF) + +if(USE_GTK) + + list(APPEND TARGET_COMPILE_DEF "-DUSE_GTK") + + find_package(PkgConfig) + pkg_check_modules(GTKFORTRAN REQUIRED gtk-4-fortran) + find_path( + GTKFORTRAN_MODULE_DIRS + NAMES gtk.mod + PATHS ${GTKFORTRAN_INCLUDE_DIRS}) + find_library(GTKFORTRAN_LIBRARY NAMES gtk-4-fortran) + + message(STATUS "GTKFORTRAN_CFLAGS : ${GTKFORTRAN_CFLAGS}") + message(STATUS "GTKFORTRAN_LIBRARY : ${GTKFORTRAN_LIBRARY}") + message(STATUS "GTKFORTRAN_LIBRARIES : ${GTKFORTRAN_LIBRARIES}") + message(STATUS "GTKFORTRAN_LIBRARY_DIRS : ${GTKFORTRAN_LIBRARY_DIRS}") + message(STATUS "GTKFORTRAN_INCLUDE_DIRS : ${GTKFORTRAN_INCLUDE_DIRS}") + message(STATUS "GTKFORTRAN_MODULE_DIRS : ${GTKFORTRAN_MODULE_DIRS}") + + target_link_libraries(${PROJECT_NAME} PUBLIC ${GTKFORTRAN_LIBRARY} + ${GTKFORTRAN_LIBRARIES}) + target_include_directories(${PROJECT_NAME} PUBLIC ${GTKFORTRAN_INCLUDE_DIRS} + ${GTKFORTRAN_MODULE_DIRS}) + +else() + + message(STATUS "NOT USING GTK-Fortran") + +endif() diff --git a/cmake/addLIS.cmake b/cmake/addLIS.cmake new file mode 100644 index 000000000..9ad7dd5f9 --- /dev/null +++ b/cmake/addLIS.cmake @@ -0,0 +1,37 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_LIS OFF) +if(USE_LIS) + + list(APPEND TARGET_COMPILE_DEF "-DUSE_LIS") + + find_library(LIS_LIBRARIES NAME lis REQUIRED) + find_path(LIS_INCLUDE_DIR NAMES lis_config.h lisf.h lis.h) + + target_link_libraries(${PROJECT_NAME} PUBLIC ${LIS_LIBRARIES}) + message(STATUS "LIS_LIBRARIES : ${LIS_LIBRARIES}") + + target_include_directories(${PROJECT_NAME} PUBLIC ${LIS_INCLUDE_DIR}) + message(STATUS "LIS_INCLUDE_DIR : ${LIS_INCLUDE_DIR}") + +else() + + message(STATUS "NOT USING LIS LIBRARIES") + +endif() diff --git a/cmake/addLapack95.cmake b/cmake/addLapack95.cmake new file mode 100644 index 000000000..756c98588 --- /dev/null +++ b/cmake/addLapack95.cmake @@ -0,0 +1,33 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +if(USE_LAPACK95) + + find_package(LAPACK95 REQUIRED) + + if(LAPACK95_FOUND) + message(STATUS "[INFO] :: FOUND LAPACK95") + target_link_libraries(${PROJECT_NAME} PUBLIC LAPACK95::LAPACK95) + list(APPEND TARGET_COMPILE_DEF "-DUSE_LAPACK95") + + else() + message(ERROR "[ERROR] :: NOT FOUND LAPACK95") + + endif() + +endif() diff --git a/cmake/addLua.cmake b/cmake/addLua.cmake new file mode 100644 index 000000000..3c0fee1b2 --- /dev/null +++ b/cmake/addLua.cmake @@ -0,0 +1,41 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_LUA OFF) +if(USE_LUA) + list(APPEND TARGET_COMPILE_DEF "-DUSE_LUA") + find_package(Lua 5.4 EXACT) + + if(NOT LUA_FOUND) + find_package(PkgConfig REQUIRED) + pkg_check_modules(LUA REQUIRED lua) + find_library(LUA_LIBRARY NAMES lua lua5.4) + set(LUA_LIBRARIES ${LUA_LIBRARY}) + find_path(LUA_INCLUDE_DIR NAMES lua5.4/lua.h lua5.4/lualib.h lua/lua.h + lua/lualib.h) + endif() + + target_link_libraries(${PROJECT_NAME} PUBLIC ${LUA_LIBRARIES}) + target_include_directories(${PROJECT_NAME} PUBLIC ${LUA_INCLUDE_DIR}) + + message(STATUS "LUA LIBRARIES :: ${LUA_LIBRARIES}") + message(STATUS "LUA INCLUDE DIR :: ${LUA_INCLUDE_DIR}") + +else() + message(STATUS "NOT USING LUA LIBRARIES") +endif() diff --git a/cmake/addMetis.cmake b/cmake/addMetis.cmake new file mode 100644 index 000000000..b968fc4de --- /dev/null +++ b/cmake/addMetis.cmake @@ -0,0 +1,28 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_METIS ON) +if(USE_METIS) + find_library(METIS_LIB metis) + list(APPEND TARGET_COMPILE_DEF "-DUSE_METIS") + message(STATUS "FOUND ${METIS_LIB}") + message(STATUS "METIS_LIB = ${METIS_LIB}") + target_link_libraries(${PROJECT_NAME} PUBLIC ${METIS_LIB}) +else() + message(STATUS "NOT USING METIS") +endif() diff --git a/cmake/addOpenBLAS.cmake b/cmake/addOpenBLAS.cmake new file mode 100644 index 000000000..cd8600199 --- /dev/null +++ b/cmake/addOpenBLAS.cmake @@ -0,0 +1,45 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +# SET(BLA_VENDOR "OpenBLAS") +find_package(LAPACK REQUIRED) +if(LAPACK_FOUND) + message(STATUS "FOUND LAPACK") +endif() +if(BLA_VENDOR MATCHES "MKL") + message(STATUS "BLA_VENDOR : MKL") + list(APPEND TARGET_COMPILE_DEF "-DUSE_INTEL_MKL") +elseif(BLA_VENDOR MATCHES "OpenBLAS") + message(STATUS "BLA_VENDOR : OpenBLAS") + list(APPEND TARGET_COMPILE_DEF "-DUSE_OpenBLAS") +else() + message(STATUS "BLA_VENDOR : ${BLA_VENDOR}") + message(STATUS "BLA_VENDOR : System provided") + list(APPEND TARGET_COMPILE_DEF "-DUSE_NativeBLAS") + + if(APPLE) + list(APPEND TARGET_COMPILE_DEF "-DUSE_APPLE_NativeBLAS") + endif() + +endif() + +message(STATUS "BLAS_LIBRARIES: ${BLAS_LIBRARIES}") +message(STATUS "LAPACK_LIBRARIES: ${LAPACK_LIBRARIES}") + +target_link_libraries(${PROJECT_NAME} PUBLIC ${LAPACK_LIBRARIES} + ${BLAS_LIBRARIES}) diff --git a/cmake/addOpenMP.cmake b/cmake/addOpenMP.cmake new file mode 100644 index 000000000..1d61a1054 --- /dev/null +++ b/cmake/addOpenMP.cmake @@ -0,0 +1,70 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_OPENMP OFF) +if(USE_OPENMP) + + if(APPLE) + if(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES + "AppleClang") + set(OpenMP_C + "${CMAKE_C_COMPILER}" + CACHE STRING "" FORCE) + set(OpenMP_C_FLAGS + "-fopenmp=libomp -Wno-unused-command-line-argument" + CACHE STRING "" FORCE) + set(OpenMP_C_LIB_NAMES + "libomp" "libgomp" "libiomp5" + CACHE STRING "" FORCE) + set(OpenMP_libomp_LIBRARY + ${OpenMP_C_LIB_NAMES} + CACHE STRING "" FORCE) + set(OpenMP_libgomp_LIBRARY + ${OpenMP_C_LIB_NAMES} + CACHE STRING "" FORCE) + set(OpenMP_libiomp5_LIBRARY + ${OpenMP_C_LIB_NAMES} + CACHE STRING "" FORCE) + + set(OpenMP_CXX + "${CMAKE_CXX_COMPILER}" + CACHE STRING "" FORCE) + set(OpenMP_CXX_FLAGS + "-fopenmp=libomp -Wno-unused-command-line-argument" + CACHE STRING "" FORCE) + + set(OpenMP_CXX_LIB_NAMES + "libomp" "libgomp" "libiomp5" + CACHE STRING "" FORCE) + endif() + endif() + + find_package(OpenMP REQUIRED) + +endif() + +if(OpenMP_FOUND) + message(STATUS "FOUND OpenMP") + message(STATUS "OpenMP_Fortran_LIBRARIES: ${OpenMP_Fortran_LIBRARIES}") + list(APPEND TARGET_COMPILE_DEF "-DUSE_OpenMP") + list(APPEND TARGET_COMPILE_OPT ${OpenMP_Fortran_FLAGS}) + # TARGET_LINK_LIBRARIES(${PROJECT_NAME} PUBLIC ${OpenMP_Fortran_LIBRARIES}) + target_link_libraries(${PROJECT_NAME} PUBLIC OpenMP::OpenMP_Fortran) +else() + message(ERROR "NOT FOUND OpenMP") +endif() diff --git a/cmake/addPLPLOT.cmake b/cmake/addPLPLOT.cmake new file mode 100644 index 000000000..821413d8e --- /dev/null +++ b/cmake/addPLPLOT.cmake @@ -0,0 +1,47 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see + +option(USE_PLPLOT OFF) +if(USE_PLPLOT) + list(APPEND TARGET_COMPILE_DEF "-DUSE_PLPLOT") + + find_package(PkgConfig REQUIRED) + pkg_check_modules(PLPLOT-FORTRAN REQUIRED plplot-fortran) + pkg_check_modules(PLPLOT REQUIRED plplot) + find_library(PLPLOT_LIBRARY NAMES plplot) + find_library(PLPLOT-FORTRAN_LIBRARY NAMES plplotfortran) + set(PLPLOT_LIBRARIES ${PLPLOT_LIBRARY} ${PLPLOT-FORTRAN_LIBRARY}) + find_path(PLPLOT_INCLUDE_DIR NAMES plplot/plplot.h) + find_path( + PLPLOT_MODULE_DIR + NAMES plplot.mod + PATHS ${PLPLOT-FORTRAN_INCLUDE_DIRS}) + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(PLPLOT DEFAULT_MSG PLPLOT_LIBRARIES + PLPLOT_INCLUDE_DIR) + + set(PLPLOT_FORTRAN_INCLUDE_DIR "${PLPLOT_MODULE_DIR}") + + target_link_libraries(${PROJECT_NAME} PUBLIC ${PLPLOT_LIBRARIES}) + target_include_directories( + ${PROJECT_NAME} PUBLIC ${PLPLOT_INCLUDE_DIR} ${PLPLOT_FORTRAN_INCLUDE_DIR}) + message(STATUS "PLPLOT_LIBRARIES : ${PLPLOT_LIBRARIES}") + message(STATUS "PLPLOT_FORTRAN_LIBRARY : ${PLPLOT_FORTRAN_LIBRARY}") + message(STATUS "PLPLOT_INCLUDE_DIR : ${PLPLOT_INCLUDE_DIR}") +else() + message(STATUS "NOT USING PLPLOT LIBRARIES") +endif() diff --git a/cmake/addRaylib.cmake b/cmake/addRaylib.cmake new file mode 100644 index 000000000..9c9961c82 --- /dev/null +++ b/cmake/addRaylib.cmake @@ -0,0 +1,31 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_RAYLIB OFF) +if(USE_RAYLIB) + list(APPEND TARGET_COMPILE_DEF "-DUSE_RAYLIB") + find_package(raylib REQUIRED) + target_link_libraries(${PROJECT_NAME} PUBLIC raylib) + # target_link_libraries(${PROJECT_NAME} PUBLIC ${raylib_LIBRARIES}) + # target_include_directories(${PROJECT_NAME} PUBLIC ${raylib_INCLUDE_DIRS}) + message(STATUS "RAYLIB_LIBRARIES FOUND") + # message(STATUS "RAYLIB_INCLUDE_DIRS FOUND: ${raylib_INCLUDE_DIRS}") + +else() + message(STATUS "NOT USING RAYLIB_LIBRARIES") +endif() diff --git a/cmake/addSparsekit.cmake b/cmake/addSparsekit.cmake new file mode 100644 index 000000000..0ba985998 --- /dev/null +++ b/cmake/addSparsekit.cmake @@ -0,0 +1,28 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +find_package(Sparsekit REQUIRED) + +if(Sparsekit_FOUND) + message(STATUS "[INFO] :: FOUND Sparsekit") + target_link_libraries(${PROJECT_NAME} PUBLIC Sparsekit::Sparsekit) + +else() + message(ERROR "[ERROR] :: NOT FOUND Sparsekit") + +endif() diff --git a/cmake/addSuperLU.cmake b/cmake/addSuperLU.cmake new file mode 100644 index 000000000..844fab01d --- /dev/null +++ b/cmake/addSuperLU.cmake @@ -0,0 +1,25 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +option(USE_SUPERLU ON) +if(USE_SUPERLU) + find_library(SuperLU_Libs superlu) + list(APPEND TARGET_COMPILE_DEF "-DUSE_SuperLU") + message(STATUS "[INFO] :: SuperLU_Libs = ${SuperLU_Libs}") +endif() +target_link_libraries(${PROJECT_NAME} PUBLIC ${SuperLU_Libs}) diff --git a/cmake/addToml.cmake b/cmake/addToml.cmake new file mode 100644 index 000000000..295bf1efd --- /dev/null +++ b/cmake/addToml.cmake @@ -0,0 +1,28 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +find_package(toml-f REQUIRED) + +if(Sparsekit_FOUND) + message(STATUS "[INFO] :: FOUND toml-f") + target_link_libraries(${PROJECT_NAME} PUBLIC toml-f::toml-f) + +else() + message(ERROR "[ERROR] :: NOT FOUND toml-f") + +endif() diff --git a/cmake/packaging.cmake b/cmake/packaging.cmake new file mode 100644 index 000000000..3cf7148aa --- /dev/null +++ b/cmake/packaging.cmake @@ -0,0 +1,195 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(CPACK_PACKAGE_NAME ${PROJECT_NAME}) +set(CPACK_PACKAGE_VENDOR "easifem.com") +set(CPACK_PACKAGE_HOMEPAGE_URL "https://www.easifem.com") +set(CPACK_PACKAGE_CONTACT "vickysharma0812@gmail.com") + +set(CPACK_VERBATIM_VARIABLES YES) +# If set to TRUE, values of variables prefixed with CPACK_ will be escaped +# before being written to the configuration files, so that the cpack program +# receives them exactly as they were specified. If not, characters like quotes +# and backslashes can cause parsing errors or alter the value received by the +# cpack program. Defaults to FALSE for backwards compatibility. + +set(CPACK_PACKAGE_DESCRIPTION + " +Expandable And Scalable Infrastructure for Finite Element Methods, +EASIFEM, is a computational framework for FEM written in Modern-Fortran. +easifemBase is a critical part of EASIFEM framework. It contains many +useful components which are necessary for building higher level classes +of finite element code. +") + +# CPACK_PACKAGE_DESCRIPTION_FILE A text file used to describe the project when +# CPACK_PACKAGE_DESCRIPTION is not explicitly set. The default value for +# CPACK_PACKAGE_DESCRIPTION_FILE points to a built-in template file +# Templates/CPack.GenericDescription.txt. + +set(CPACK_PACKAGE_DESCRIPTION_SUMMARY + " +Expandable And Scalable Infrastructure for Finite Element Methods, +EASIFEM, is a computational framework for FEM written in Modern-Fortran. +easifemBase is a critical part of EASIFEM framework. +======================================================================= +") + +# A description of the project, used in places such as the introduction screen +# of CPack-generated Windows installers. If not set, the value of this variable +# is populated from the file named by CPACK_PACKAGE_DESCRIPTION_FILE. + +set(CPACK_PACKAGE_VERSION "${PROJECT_VERSION}") + +set(CPACK_PACKAGE_VERSION_MAJOR "${VERSION_MAJOR}") +# Package major version. This variable will always be set, but its default value +# depends on whether or not version details were given to the project() command +# in the top level CMakeLists.txt file. If version details were given, the +# default value will be CMAKE_PROJECT_VERSION_MAJOR. If no version details were +# given, a default version of 0.1.1 will be assumed, leading to +# CPACK_PACKAGE_VERSION_MAJOR having a default value of 0. + +set(CPACK_PACKAGE_VERSION_MINOR "${VERSION_MINOR}") +# Package minor version. The default value is determined based on whether or not +# version details were given to the project() command in the top level +# CMakeLists.txt file. If version details were given, the default value willbe +# CMAKE_PROJECT_VERSION_MINOR, but if no minor version component was specified +# then CPACK_PACKAGE_VERSION_MINOR will be left unset. If no project version was +# given at all, a default version of 0.1.1 will be assumed, leading to +# CPACK_PACKAGE_VERSION_MINOR having a default value of 1. + +set(CPACK_PACKAGE_VERSION_PATCH "${VERSION_BugFix}") +# Package patch version. The default value is determined based on whether or not +# version details were given to the project() command in the top level +# CMakeLists.txt file. If version details were given, the default value will be +# CMAKE_PROJECT_VERSION_PATCH, but if no patch version component was specified +# then CPACK_PACKAGE_VERSION_PATCH will be left unset. If no project version was +# given at all, a default version of 0.1.1 will be assumed, leading to +# CPACK_PACKAGE_VERSION_PATCH having a default value of 1. + +# CPACK_PACKAGE_ICON A branding image that will be displayed inside the +# installer (used by GUI installers). + +set(CPACK_RESOURCE_FILE_LICENSE "${CMAKE_CURRENT_SOURCE_DIR}/LICENSE") +# License to be embedded in the installer. It will typically be displayed to the +# user by the produced installer (often with an explicit "Accept" button, for +# graphical installers) prior to installation. This license file is NOT added to +# the installed files but is used by some CPack generators like NSIS. If you +# want to use UTF-8 characters, the file needs to be encoded in UTF-8 BOM. If +# you want to install a license file (may be the same as this one) along with +# your project, you must add an appropriate CMake install() command in your +# CMakeLists.txt. + +# CPACK_RESOURCE_FILE_README +set(CPACK_RESOURCE_FILE_README "${CMAKE_CURRENT_SOURCE_DIR}/README.md") +# ReadMe file to be embedded in the installer. It typically describes in some +# detail the purpose of the project during the installation. Not all CPack +# generators use this file. + +# CPACK_RESOURCE_FILE_WELCOME Welcome file to be embedded in the installer. It +# welcomes users to this installer. Typically used in the graphical installers +# on Windows and Mac OS X. + +# CPACK_MONOLITHIC_INSTALL¶ Disables the component-based installation mechanism. +# When set, the component specification is ignored and all installed items are +# put in a single "MONOLITHIC" package. Some CPack generators do monolithic +# packaging by default and may be asked to do component packaging by setting +# CPACK__COMPONENT_INSTALL to TRUE. + +# CPACK_PACKAGE_CHECKSUM¶ An algorithm that will be used to generate an +# additional file with the checksum of the package. The output file name will +# be: + +set(CPACK_PACKAGE_DIRECTORY ${PROJECT_BINARY_DIR}/package) +# The directory in which CPack is doing its packaging. If it is not set then +# this will default (internally) to the build dir. This variable may be defined +# in a CPack config file or from the cpack command line option -B. If set, the +# command line option overrides the value found in the config file. + +set(CPACK_PACKAGE_INSTALL_DIRECTORY ${CPACK_PACKAGE_NAME}) +# Installation directory on the target system. This may be used by some CPack +# generators like NSIS to create an installation directory e.g., "CMake 2.5" +# below the installation prefix. All installed elements will be put inside this +# directory. + +list(APPEND CpackGen DEB) +# TGZ +set(CPACK_GENERATOR "${CpackGen}") +# SET(CPACK_SOURCE_GENERATOR "TGZ DEB") + +# List of CPack generators to use. If not specified, CPack will create a set of +# options following the naming pattern CPACK_BINARY_ (e.g. +# CPACK_BINARY_NSIS) allowing the user to enable/disable individual generators. +# If the -G option is given on the cpack command line, it will override this +# variable and any CPACK_BINARY_ options. + +set(CPACK_SOURCE_IGNORE_FILES + .git/ + .github/ + .vscode/ + .mypy_cache/ + _CPack_Packages/ + ${CMAKE_BINARY_DIR}/ + ${PROJECT_BINARY_DIR}/ + ".*~$") + +set(CPACK_STRIP_FILES YES) +# List of files to be stripped. Starting with CMake 2.6.0, CPACK_STRIP_FILES +# will be a boolean variable which enables stripping of all files (a list of +# files evaluates to TRUE in CMake, so this change is compatible). + +set(CPACK_OUTPUT_FILE_PREFIX "${CMAKE_SOURCE_DIR}/_packages") + +set(CPACK_PACKAGING_INSTALL_PREFIX "/opt/easifem/base/") +# /${CMAKE_PROJECT_VERSION}") + +set(CPACK_INSTALL_DEFAULT_DIRECTORY_PERMISSIONS + OWNER_READ + OWNER_WRITE + OWNER_EXECUTE + GROUP_READ + GROUP_EXECUTE + WORLD_READ + WORLD_EXECUTE) + +# CPACK_OUTPUT_CONFIG_FILE The name of the CPack binary configuration file. This +# file is the CPack configuration generated by the CPack module for binary +# installers. Defaults to CPackConfig.cmake. + +# CPACK_SOURCE_OUTPUT_CONFIG_FILE¶ The name of the CPack source configuration +# file. This file is the CPack configuration generated by the CPack module for +# source installers. Defaults to CPackSourceConfig.cmake. + +# CPACK_PACKAGE_EXECUTABLES¶ Lists each of the executables and associated text +# label to be used to create Start Menu shortcuts. For example, setting this to +# the list ccmake;CMake will create a shortcut named "CMake" that will execute +# the installed executable ccmake. Not all CPack generators use it (at least +# NSIS, and WIX do). + +set(CPACK_DEBIAN_FILE_NAME DEB-DEFAULT) +set(CPACK_COMPONENTS_GROUPING ALL_COMPONENTS_IN_ONE) +set(CPACK_DEB_COMPONENT_INSTALL YES) +set(CPACK_DEBIAN_PACKAGE_NAME, "${CPACK_PACKAGE_NAME}") +# SET(CPACK_DEBIAN_PACKAGE_ARCHITECTURE, "i386") +set(CPACK_DEBIAN_PACKAGE_SHLIBDEPS OFF) # ON +set(CPACK_DEBIAN_PACKAGE_MAINTAINER "Vikas Sharma <${CPACK_PACKAGE_CONTACT}>") +set(CPACK_DEBIAN_PACKAGE_SECTION, "devl") +set(CPACK_DEBIAN_PACKAGE_PRIORITY, "optional") + +include(CPack) +message(STATUS "Components to pack: ${CPACK_COMPONENTS_ALL}") diff --git a/compile_commands.json b/compile_commands.json new file mode 100644 index 000000000..0e56b6948 --- /dev/null +++ b/compile_commands.json @@ -0,0 +1,2812 @@ +[ +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FFTW/src/FFTW3.F90 -o CMakeFiles/easifemBase.dir/src/modules/FFTW/src/FFTW3.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FFTW/src/FFTW3.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_b_size.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf_b_size.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_b_size.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_global_parameters_variables.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf_global_parameters_variables.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_global_parameters_variables.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_stringify.F90 -o CMakeFiles/easifemBase.dir/src/modules/PENF/src/penf_stringify.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/PENF/src/penf_stringify.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64.F90 -o CMakeFiles/easifemBase.dir/src/modules/BeFoR64/src/befor64.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64_pack_data_m.F90 -o CMakeFiles/easifemBase.dir/src/modules/BeFoR64/src/befor64_pack_data_m.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BeFoR64/src/befor64_pack_data_m.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Class.F90 -o CMakeFiles/easifemBase.dir/src/modules/String/src/String_Class.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Class.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/String/src/String_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/String/src/String_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FACE/src/face.F90 -o CMakeFiles/easifemBase.dir/src/modules/FACE/src/face.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FACE/src/face.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ErrorMessages.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ErrorMessages.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ErrorMessages.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL_utils.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/FPL_utils.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL_utils.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/FPL.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/FPL.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntry.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterEntry.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntry.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntryDictionary.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterEntryDictionary.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterEntryDictionary.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterList.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterList.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterList.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterRootEntry.F90 -o CMakeFiles/easifemBase.dir/src/modules/FPL/src/ParameterRootEntry.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FPL/src/ParameterRootEntry.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/System/src/System_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Test/src/Test_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Test/src/Test_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Test/src/Test_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/GlobalData/src/GlobalData.F90 -o CMakeFiles/easifemBase.dir/src/modules/GlobalData/src/GlobalData.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/GlobalData/src/GlobalData.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 -o CMakeFiles/easifemBase.dir/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/ARPACK_SAUPD.F90 -o CMakeFiles/easifemBase.dir/src/modules/ARPACK/src/ARPACK_SAUPD.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/ARPACK_SAUPD.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 -o CMakeFiles/easifemBase.dir/src/modules/ARPACK/src/EASIFEM_ARPACK.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ARPACK/src/EASIFEM_ARPACK.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Hashing/src/Hashing32.F90 -o CMakeFiles/easifemBase.dir/src/modules/Hashing/src/Hashing32.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Hashing/src/Hashing32.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Gnuplot/src/ogpf.F90 -o CMakeFiles/easifemBase.dir/src/modules/Gnuplot/src/ogpf.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Gnuplot/src/ogpf.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CInterface/src/CInterface.F90 -o CMakeFiles/easifemBase.dir/src/modules/CInterface/src/CInterface.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CInterface/src/CInterface.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i1mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i1mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i1mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i2mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i2mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i2mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i4mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i4mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i4mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i8mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_i8mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_i8mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_l1mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_l1mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_l1mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r4mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_r4mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r4mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r8mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_r8mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r8mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r16mod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_r16mod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_r16mod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_charmod.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/disp_charmod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/disp_charmod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule_util.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/dispmodule_util.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule_util.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/dispmodule.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/dispmodule.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/putstrmodule.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/disp/putstrmodule.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/disp/putstrmodule.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/Display_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Display/src/Display_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Display/src/Display_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/MdEncode/src/MdEncode_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/MdEncode/src/MdEncode_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/MdEncode/src/MdEncode_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ErrorHandling/src/ErrorHandling.F90 -o CMakeFiles/easifemBase.dir/src/modules/ErrorHandling/src/ErrorHandling.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ErrorHandling/src/ErrorHandling.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MappingUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MappingUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MappingUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/BinomUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/BinomUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/BinomUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AppendUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/AppendUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AppendUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ApproxUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ApproxUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ApproxUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AssertUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/AssertUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/AssertUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HeadUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/HeadUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HeadUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TailUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/TailUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TailUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SplitUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SplitUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SplitUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ArangeUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ArangeUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ArangeUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/GridPointUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/GridPointUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/GridPointUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/OnesUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/OnesUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/OnesUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ZerosUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ZerosUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ZerosUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EyeUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/EyeUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EyeUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/DiagUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/DiagUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/DiagUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HashingUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/HashingUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/HashingUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InputUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/InputUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InputUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InvUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/InvUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/InvUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MatmulUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MatmulUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MatmulUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ContractionUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ContractionUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ContractionUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MiscUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MiscUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MiscUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ProductUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ProductUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ProductUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ReallocateUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ReallocateUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ReallocateUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PartitionUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/PartitionUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PartitionUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MedianUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/MedianUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/MedianUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SortUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SortUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SortUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/StringUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/StringUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/StringUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SwapUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SwapUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SwapUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ConvertUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/ConvertUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/ConvertUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/IntegerUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/IntegerUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/IntegerUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PushPopUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/PushPopUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/PushPopUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EigenUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/EigenUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/EigenUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SymUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/SymUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/SymUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TriagUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/TriagUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/TriagUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/LinearAlgebraUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/LinearAlgebraUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/LinearAlgebraUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/Utility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Utility/src/Utility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Utility/src/Utility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/InterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/InterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/InterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LagrangePolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LagrangePolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/JacobiPolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/JacobiPolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LegendrePolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LegendrePolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LobattoPolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LobattoPolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LineInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/LineInterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/LineInterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/TriangleInterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TriangleInterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PrismInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/PrismInterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PrismInterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/PyramidInterpolationUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PyramidInterpolationUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/RecursiveNodesUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/RecursiveNodesUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/RecursiveNodesUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PolynomialUtility.F90 -o CMakeFiles/easifemBase.dir/src/modules/Polynomial/src/PolynomialUtility.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Polynomial/src/PolynomialUtility.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseType/src/BaseType.F90 -o CMakeFiles/easifemBase.dir/src/modules/BaseType/src/BaseType.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseType/src/BaseType.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/MultiIndices/src/MultiIndices_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/MultiIndices/src/MultiIndices_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/MultiIndices/src/MultiIndices_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/OpenMP/src/OpenMP_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/OpenMP/src/OpenMP_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/OpenMP/src/OpenMP_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Random/src/Random_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Random/src/Random_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Random/src/Random_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BoundingBox/src/BoundingBox_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/BoundingBox/src/BoundingBox_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BoundingBox/src/BoundingBox_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/IntVector/src/IntVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/IntVector/src/IntVector_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/IntVector/src/IntVector_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/IndexValue/src/IndexValue_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/IndexValue/src/IndexValue_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/IndexValue/src/IndexValue_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/IterationData/src/IterationData_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/IterationData/src/IterationData_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/IterationData/src/IterationData_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/KeyValue/src/KeyValue_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/KeyValue/src/KeyValue_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/KeyValue/src/KeyValue_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Vector3D/src/Vector3D_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Vector3D/src/Vector3D_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Vector3D/src/Vector3D_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AddMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_AddMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AddMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AppendMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_AppendMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AppendMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AssignMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_AssignMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_AssignMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Blas1Methods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Blas1Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Blas1Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_ComparisonMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ComparisonMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetValueMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_GetValueMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_GetValueMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2Methods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_Norm2Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_Norm2Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_SetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_SetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetValueMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_GetValueMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_GetValueMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_SetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_SetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_AddMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/DOF/src/DOF_AddMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DOF/src/DOF_AddMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceElement_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceElement_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceElement_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePoint_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferencePoint_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePoint_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Line_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Line_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Line_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceLine_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceLine_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceLine_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Triangle_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Triangle_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Triangle_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Plane_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Plane_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Plane_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTriangle_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceTriangle_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTriangle_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferenceHexahedron_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferenceHexahedron_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePrism_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferencePrism_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePrism_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePyramid_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/ReferencePyramid_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/ReferencePyramid_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Geometry_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Geometry/src/Geometry_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Geometry/src/Geometry_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVariable/src/FEVariable_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FEVariable/src/FEVariable_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVariable/src/FEVariable_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HermitMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1HermitMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HermitMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/RealMatrix/src/RealMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/RealMatrix/src/RealMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/RealMatrix/src/RealMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/MassMatrix/src/MassMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/MassMatrix/src/MassMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/MassMatrix/src/MassMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STMassMatrix/src/STMassMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STMassMatrix/src/STMassMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FacetMatrix/src/FacetMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FacetMatrix/src/FacetMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FEMatrix/src/FEMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FEMatrix/src/FEMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FEMatrix/src/FEMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/ForceVector/src/ForceVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/ForceVector/src/ForceVector_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/ForceVector/src/ForceVector_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/STForceVector/src/STForceVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/STForceVector/src/STForceVector_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/STForceVector/src/STForceVector_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVector/src/FEVector_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/FEVector/src/FEVector_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/FEVector/src/FEVector_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRSparsity/src/CSRSparsity_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRSparsity/src/CSRSparsity_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatmulMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_MatmulMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatmulMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_Method.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_Method.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 -o CMakeFiles/easifemBase.dir/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseMethod/src/BaseMethod.F90 -o CMakeFiles/easifemBase.dir/src/modules/BaseMethod/src/BaseMethod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/BaseMethod/src/BaseMethod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/easifemBase/src/easifemBase.F90 -o CMakeFiles/easifemBase.dir/src/modules/easifemBase/src/easifemBase.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/easifemBase/src/easifemBase.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Hashing/src/Hashing32@fnvMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@fnvMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@nmMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Hashing/src/Hashing32@nmMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@nmMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@waterMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Hashing/src/Hashing32@waterMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Hashing/src/Hashing32@waterMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MappingUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MappingUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MappingUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/BinomUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/BinomUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/BinomUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MedianUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MedianUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MedianUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PartitionUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/PartitionUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PartitionUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SortUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SortUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SortUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SwapUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SwapUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SwapUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ConvertUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ConvertUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ConvertUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ReallocateUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ReallocateUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ReallocateUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ProductUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ProductUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ProductUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ArangeUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ArangeUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ArangeUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/GridPointUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/GridPointUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/GridPointUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HeadUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/HeadUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HeadUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TailUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/TailUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TailUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SplitUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SplitUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SplitUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/OnesUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/OnesUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/OnesUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ZerosUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ZerosUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ZerosUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EyeUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/EyeUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EyeUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/DiagUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/DiagUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/DiagUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AppendUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/AppendUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AppendUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InputUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/InputUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InputUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InvUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/InvUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/InvUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MatmulUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MatmulUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MatmulUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ContractionUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ContractionUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ContractionUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AssertUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/AssertUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/AssertUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ApproxUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/ApproxUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/ApproxUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HashingUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/HashingUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/HashingUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MiscUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/MiscUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/MiscUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/StringUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/StringUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/StringUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/IntegerUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/IntegerUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/IntegerUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PushPopUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/PushPopUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/PushPopUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EigenUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/EigenUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/EigenUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SymUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/SymUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/SymUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TriagUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/TriagUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/TriagUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Random/src/Random_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Random/src/Random_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Random/src/Random_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@SetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@SetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@AppendMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@AppendMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@AppendMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@EnquireMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IntVector/src/IntVector_Method@EnquireMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IntVector/src/IntVector_Method@EnquireMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 -o CMakeFiles/easifemBase.dir/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 -o CMakeFiles/easifemBase.dir/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_IOMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_IOMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_SetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_SetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_AddMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_AddMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_GetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Line_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/Line_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Line_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Triangle_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/Triangle_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Triangle_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Plane_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/Plane_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/Plane_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/QuadraturePoint_Method@GaussLegendre.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/QuadraturePoint_Method@GaussLegendre.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/QuadraturePoint_Method@GaussLegendre.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Line_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Line_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Line_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Triangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Triangle_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Triangle_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Quadrangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Quadrangle_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Quadrangle_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Tetrahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Tetrahedron_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Tetrahedron_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Hexahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Hexahedron_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Hexahedron_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Prism_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Prism_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Prism_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Pyramid_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Pyramid_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendre/GaussLegendre_Pyramid_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/QuadraturePoint_Method@GaussLegendreLobatto.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/QuadraturePoint_Method@GaussLegendreLobatto.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/QuadraturePoint_Method@GaussLegendreLobatto.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Line_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Line_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Line_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Triangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Triangle_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Triangle_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Quadrangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Quadrangle_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Quadrangle_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Tetrahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Tetrahedron_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Tetrahedron_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Hexahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Hexahedron_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Hexahedron_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Prism_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Prism_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Prism_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Pyramid_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Pyramid_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreLobatto/GaussLegendreLobatto_Pyramid_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauLeft/QuadraturePoint_Method@GaussLegendreRadauLeft.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreRadauLeft/QuadraturePoint_Method@GaussLegendreRadauLeft.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauLeft/QuadraturePoint_Method@GaussLegendreRadauLeft.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauRight/QuadraturePoint_Method@GaussLegendreRadauRight.F90 -o CMakeFiles/easifemBase.dir/src/submodules/QuadraturePoint/src/GaussLegendreRadauRight/QuadraturePoint_Method@GaussLegendreRadauRight.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/QuadraturePoint/src/GaussLegendreRadauRight/QuadraturePoint_Method@GaussLegendreRadauRight.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGHermitMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHermitMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHermitMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlHierarchyMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlLagrangeMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1CurlSerendipityMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHermitMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivHierarchyMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivLagrangeMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1DivSerendipityMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HermitMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1HermitMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HermitMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1HierarchyMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1LagrangeMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Line_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Line_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Line_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Triangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Triangle_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Triangle_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Quadrangle_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Quadrangle_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Quadrangle_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Prism_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Prism_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Prism_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Pyramid_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Pyramid_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Pyramid_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Tetrahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Tetrahedron_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Tetrahedron_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Hexahedron_Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Hexahedron_Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/H1Lagrange/H1Lagrange_Hexahedron_Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_H1SerendipityMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 -o CMakeFiles/easifemBase.dir/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 -o CMakeFiles/easifemBase.dir/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/gfortran -DASCII_SUPPORTED -DLinux_SYSTEM -DUCS4_SUPPORTED -DUSE_CMAKE -DUSE_Int32 -DUSE_NativeBLAS -DUSE_Real64 -D_ASCII_SUPPORTED -D_R16P -D_UCS4_SUPPORTED -DeasifemBase_EXPORTS -I/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug/include -I/home/easifem/.easifem/easifem/extpkgs/include -g -Jinclude -fPIC -ffree-form -ffree-line-length-none -std=f2018 -fimplicit-none -fbounds-check -g -fbacktrace -Wextra -Wall -fprofile-arcs -ftest-coverage -Wimplicit-interface -c /home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 -o CMakeFiles/easifemBase.dir/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90.o", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90" +}, +{ + "directory": "/home/easifem/Dropbox/easifem/easifem-base/build/linux-debug", + "command": "/usr/bin/cc -g -fPIC -o CMakeFiles/easifemSystemMethodC.dir/src/modules/System/src/System_Method.c.o -c /home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.c", + "file": "/home/easifem/Dropbox/easifem/easifem-base/src/modules/System/src/System_Method.c" +} +] \ No newline at end of file diff --git a/easifemBase.py b/easifemBase.py new file mode 100644 index 000000000..e69de29bb diff --git a/easifemvar.sh b/easifemvar.sh new file mode 100644 index 000000000..e69de29bb diff --git a/figures/banner.jpeg b/figures/banner.jpeg new file mode 100644 index 0000000000000000000000000000000000000000..19cd1e23380fdaab96028ecf0032237d59fc6988 GIT binary patch literal 79230 zcmd42XIK;K_xBq`MVg^^hz&uiG-(00A|N0jy%PcH(m?`*M3D}GEnTWg6Oi6(Bncp0 zx*!4x0wN#@D2x!o$==WNe@=OEuJivrZ_ebpX70=+lUaA}S@-&U*P7GMrz;>j{(1v@ufk1|aAaM`~bP;s+3_FO9);dFbf#N(t=l*SjKsRVx5a{gd zv;Vc{?6cQ&|J6S8*FOhOcR)Yy+Zj5xGpBeEgmx9@&-}am`!(9?%vri~ z=P%G-WME{XeW00@cDZzPXV1}{KmX6qoQb3z2c2U(&wfSr&IJw=C;F=aoN~`!zPWhq zZhbG8=>+MzymMd_10y#NFCV|i4Nsu<|?*=LNP|6goQKmBi94_yp^CTkLwu@J^(V40YT?vh`DFnGQ=k#Qtj z*18vOZr!x>sJ@)FXN_Jv8S6JtR~_}0*>ycDVBlHiie5KMzPhF&*5~`B;S?0No%Q}u zIW!g?m(*ylp@;n=?ONpaIr}*Of<<(7GG4hXqjHSXMaK1Rkz7bUSAi<0)9!4Q5yMA{ z0T6Qvq6Z;IseC|oIo$ihDTqbmGDQ~%U>RwliU673irKN!QD@It6*7|?JN<-CLGe-- zuMeJr7;coVc-L7(KWz}xgT&gzD5~kOXQ&Pnko8HOC?$?#SX|FD5Xed-LTA~(iU~16`WQ9zHMq*` zeXWt+p`BiM`O|K*#{ExJQ!*F}V?{`gXuRoPR7@RmF)gVe$cvm$9BdSDD1SCuw=_i; zpB{CPhO4aN(P4+#;3o3?QzyA9{(O9R=CAW0PSAgC=x?qX3&G_H197zoo7H8`?;4j# zOZlC(iWoMpr@59z9IOxglaktI02w@Rop}@*wF;@}UEh5wZr@;#=yj$3q8aR7pvn4M^ z(T+_upu(|M0?n+h5&nDQxI^KG;X4Bf0;UfZdkW&AsDTryyuci8N$Hb_IQpFjf3i~1 zVe9D^ z5k`3#5FP4xQ7BN6}D=GWMV>pn)lxw8wQxKXe3QXY~&yuoo z+Pmi{7FF{e3xW5CM!DXbIU4XR)Yd%ZY@FKRj@X*7XDMykmlJtV&MWOXs2!UA&uz4~ zwWmHNOsKg+T$}=@`S%;Va-VOxxsXC9-aFe*bmg4Pv@t7YI9BESS!%~-F;%R?Q(#*c z6{yLsaq|?^8>Z>5++|Zi(F8nQRwrINdM?Di@*$seU2%WE=_ok2{^ioETF+%hMYId{ z=rE~E&9nPwEvl)xi1A0_qj~SwULOe}ghD5ypSMh#t9Mj<(|^8R@R3o`_4Y2-Y*DuR zevPQGmwy|DZ{CB{PT-x$ippo)e%Haf2F@^zb3DTbID*f=T9HfcZxt`q`T;zcVw~PJ zyVX0Wf+LL|Gy;CdRum7_>>c_lgwrV~_7ebebInBFL?}-0Dprer;8wC};}1>j;gBlK zuB9;hiCir_d@$VwdHbD7jn1di%V^mH$yi^dHWPF}roublNl(V6WS6!_sQAhJlwoK~ z$EGkHwZ?rm0@ECXY#&$qWdN4oKV4_tMeXLSIB}66&RKChTa6hVHA;~H=dT9*WID{T zWzfk--QLQfrfC$NPMm^Rn+dC!=cFwpQzJlf(tc!j1)*OdOb23AsfT)kFX6Hme5 z3sp$VadqG;s|hPXmGf&#S_~h4HH`l*QYUIeyd#k8C1P=_vN_+4ytBVd<8;sKKMf%( zTy0-H-Xv{MnRE%L`Kfy(3=W(`yT0GGUv%*Ys)=8KapEq{@1ixF=P%NFrr-toDTG=i z@n*31a&m4=%=Be2>k{Bi7_F)Bx!K9z-zh5sf}-2oJs(+;{1`!t|6qKWd>NNLB7>^5c2@n&12*D>k4u|tcL`J;%fE% zs2rPa2yH7CQ^xe(l}Ftfn!cwXcfWn$YXn&9J zB@15f9`@ z?JN@%Bz?6tQO}0G<5ru!(e0*NzytLshGCeenf!qjO3nXxO>ye4qE4Bfqx-rv!cwy6xQvXc?1Ca%Lbf+Im1ppGObc$>{;rg&ww7>|u5CX$1+DxnK0%tLnM?a~PC4b!;sp650bSN3D;q4q2$ zMO;TBJC1A)giQ9`!72;(qZcvxkR*(dh7<)(W`gGt$5Vdq^8N6d%v1g?@KQLvWI*m^K$x#*O}$8-)047C^f0gX z$dUF{it$i3{3{HzJ7<__zpL_4j=ODcw$cnag9H8q$!-ek>UDWXyp`EfrEj2hbnPSo zv-0*7#N8vdDGy0G1u?s{kThO!=+;mt4wO`lqY&pynr=ox?R&&}CJ}1V#nsb7E}HV4s1SbEyktNf?=( zBpk_}$WrdCcJ)+|t)i~z#_Z+#s?;U}w(}@v|1y}kN#iNV+A=J0crQF>D6O@r9GA1{ zqEc?8?8}!gkdLy|5JXr2e&h(;Cb1}1<2Gp{MS(kjV;P7rYsGM<|82LOi|)A9IVE#9 zYSi`Jmj#DPr(DqcGK@z58nD>Xh+8E!lQOGA7^l}Rxl%s)eXW4(_717@m>qw4p?vrP zsx{uQeV{L8M5Anj{vyx2?w?)NAxf<*phgsXZ z+r&-Bu%8Vh!fsz_YAtj#ugEAq_fOax;yX+gJOCnMffq^g4>a^}D!2a$dCR@{kQOhh z(fCn^o94mab&Lx55knSLGvEH1s=fY>%2);J$ud-?qT|~zcpM(aLgn5>7RBU#SBoI~%#E(Qt9Ph?)7hWSR3*3e&3ad7R(rFqLJ8#wO82<_^H|)AS^3Din%<# z{#D?MK-?#yYP+v14tO%W(6-DZzK65GRrI>^O5P)=!k#U+xJR9Wo}>!cr=}F~XQdVWy#$gqfj_qJ8Nml7&2 z+}>^Go$(n;4_E^#g93FVjwgMtcQs>N_B6Sb^RVwPSqKY}g;VVC>|+YU@SCow3Cc-o zc-w%|lO$Z5s&)QY*%gCa&LBq4x?iMB+x+^^Zrvp)EyZ#4DTrj`0W~3j0S{wFxYa=v zKybS8u16KvAc+!E8dvH4UTpHw>Z9R~6e55`K&te-B(mMEAVvmZsSv=>oj9sE z%j-0^HyZNkhf_`WTMKcS#8PGDDU8nQDA?1zs>!pg>9E;-e~dm#<7Lp$eku^xUgJ$T z1)X!g78Axp7cj@MvOlI8dx5LHz70{F;PnlmOD&dkb0owL`>T{`CT_V}XKbjr9!1C$ zoPxYgK^LeqC~k^$5t{-mp2~kxda+L51sVQ7 z#T35V9))bKeEq^%?$AA-KFLe;mk*S?97E&tONH%kfawyeo|bM;+D}m9dw6IwILrs* ziecDW{cyZ0Xfi(_Ge+9KPgJs$iWKhWbc76G!2ytNYy=`k1=U4~FFl(2hWh$l8MzPgP2$81%-S z7cnYWRC7^d`A)>K8g(X|=U};4CLtV>=zF=vpa6!Qy1!tIra*ZsZ_Ob@Dwuq{#?BR> zJG?x-HPHV;t;EM?nVl6@r8dZ)dOcO1GS;1#+^4@kQKiTnSQ%D|#K4IGy3JcC)9l~C ztmJBa*bOJ|CXz}E-*m5K{_E~yoN8UaNp$wCf79c|Yrm?!kWV1Dlt>+AT|io`0lu#q({k&q^d<3JU3s4Y~aS2vF<*IjvA z!y&3P_|N4nT0j2=5Bm5Ks`nnniqzVhRe1HJkjgKLPrbO6 zRnG)Vt&VUd8po(Qtlm+s}dC;#k%1o@$uDmPU}UrV2YLU9P5 zxDi>?;{4SmdJY}qJkf`l%-9m=Q&0lpo(sK>o`X3~@}4VwwZ3Vq4Cxd!DY2PQM1rt5 z?WbOZ-++4J=1Up9!NjRPr^cEyABf&}m3ohbA^k*Ih5c~$if#AjM0;JZRdI6Z^#;oD zrTlUVf#L}4l0#R=;|1``++CqHz_5u`#=O=$`}n3vVU>6}yYIFv8BZ6a6Q1C2!h?sI zEHbl4a-gLJm?y)5$*p3=+j83?f(nxD`Pagm`R8Y=rM;R0X%}@NO$g8Y=8^nQHu2L87e)oVChqrWUV0n++M^4J<<*-Cjh|KX2`={et!uT^N_}FQae>@)Q zPRd7)w{}1|hHH?Mg=gaKlLoe_GFQ z!8!jR1~9%Qg#R6w;Yz0O)r{3_G=3Ibl!%0o?w>SV?`};AAm0_psnK*po%KQ=29E~e z9Jyy|x?F0!TTC+(SB-%5kQH^|m0?x~CX+7;`tR0rDEmBSGS!KvAj>d2*u#K;@qpk{ zP$3$jEk^J(O`9>MW45qf_*tzskoRC2CrnQ=j&7i;4JkWCUKdR)X2fibs!nggMX;YY zz3Obr^!{GwO}RcA^gw|&=It2z;VJCHmHSgBL*x|s=VYZm;}jTYkNlF2F`2$EG`y^+ zMD!(Lnb}6m^9>-6ZF#P*>q_vW|6XSe54zKmB2;$@!gm_Qdai0K1=-(cnwwtxV+70W zH=vJ0t4xPh$LD3*TVA#5EWE~HG1l#=RJ$v#kay_9Sq)j2hLR0ZDEfFpCHW~Te!xi% zIF>BBhMjtoNt)G)Gf3mLPl}UUu(r>;SM8^rlnd4B71YZk^#|M?bP3FNeV|Y| zWoimXIEWxL)EI7OH}|f3I^W97%Ji^sB%H7y@tP!)Q&19$`%(4-V2aed3zZ@OSRnl% z=2OXJ*Oe6%OCSH02u!>T(R=3__Nf^cs>x_cc(%HBEjcXQ>ViG%&e7EMRfsw^dg+9ZU8JAG%0n>NPuTe4+p5Nk@h6qWpo{!t? zyx>MZbEWkqA;Oa^*5t5yK^SzGMufb!XoH36Fb#KIE>ns0GdSy4YP!Eu33GkM{|J8y znt+}LAAA|-s4~Ir;-^T{c7A(1=t)UiJ@xS;Mrj30;cgC5MFEI0e`kUn7J0z4-36y)Qt%keGWEVD8N z{lL*6=VAW<*amjU+Ywy4Qx~$GpUG^YYLPExqLpS6xVx2n^y$AT&Yw>G2M7V+4kk~^ zno{RCdToU>A$Xc{cM7_Qyh1T;oB0Kf6;=dV2^eKG%b2P)Ak1XI z`KEC?gKehOP6bK`)oK-^>1#=LEl)*xJ6QEWSc4;d3So2Rw7^hT9#1u#UnQ%)u)e|&N=pTNioFnheci{m2ZiJT50X5?au7%**gU} zA(%$HSZoaKhQ()VhO63b|K zuxwzIN$LlSF(f6j;#d&wa)3+6hqoqU+@y5z8VnP^;t@shFt!jw7ei8cuaBrUQ(lr^ z;=*Bap-dcqN^;hI*B;ytKjF0p>+Aaby|pnK-SW1|VJMTB-KWmUPCZV4*xaGE+%iDy zk#j2q>q=q2Er~icPw!U__{_0>yAl z+|P_7eoQ{`b1uaoxr|qem9Giag-q@mMZVdVA7t@oB z9qJWZVE3=2ozTLYB#q(#!Z3t+^WL9U9!ELylR4Ya*k54gp_a7}da`e+=j*R{v`^^9 zH3gY!v6;YbE@{_URl6~xO%bZ7pIuQdyfhE)kWKpfKq;|VIlM+YHM`+WraL@5EajSf zA4OsF@%)3E&hnB-cOH{SM-?Of8r6(%l_tU8+Q%oyIpG^rhGXG!!nuUsumwCuc> zviqh>qwq^sh|I1k<3#J>LV#K5^1R60A-Z{(GL`uab)SLIm;jeGQ(aj)Q+Rg%g5m0I zCtX>h@slbos-B>RjP%%k3h#$VQ;yQ-xPUP=IkakesZs{PV{j}k1v#B-yrWH~C-n7~ zld}6D;GXNqep_bDlLpfG_Vdz3xC^2D`5V7qNnuDS3M5Jmm7pO+RtUJ)8oF=_>f16z z1_WJ4d#^Hmd+AVC+nnLY!}rj3A+hNiRoPRyTP8eVx1?2f9&VRJ!o&e7g#t-|HJ1q( zzWRv+#eGel`iCPxI<$gh9>)+6{nbcdBye8eH+dwB#H}1Wrd$lN$yMnC0v?&8s7sZLp7L#={C7;x{R9z^2)1+i8QeB(NvQ(=$ zQ;?YtbkCRDMaOqNqlGE2btd{MYiEJ!n8KNyh{i7K37~M`*?nyfO*|vCs#k zpdqqJS_gKV1#MQ2uCmHLRMrpno~u?U*2&lyO5HX)0H3_pP^NhcRq*!Au{$ChxU-5` zU~;UR7A3XfQ0H*8RHAO5AA>azs@pjmlGCFApTf%3;zrd>8mFE>JEdf+Z;&sQOKze9 zh%EMlx02>@)9-Ri9ZN(^mOdqRt-6Mei}l>wX=ut@+5q-fYe6I(*X&h_9?AV#8}2IU zm<|SJ9#4>Or}4CZjSoz=Zvy+MwD;9*KjRZ8ywjGmtl&(&c#|AO^5!tuSO#m$o^5s< zj9fyo(e!k6`EA-9LS^ zu_j%cddHYm@MO`ZT|biLQFkgG+#5aS-_|V7+4W#lND_6%DIk9jH-mM;)Ya!C=H!pF zB%q&2J-88q{^&K)?^OBjk-Vfr*cxRP@d(%_N31T#gAo3cTlKi(* z(q8tkF#XkF7s;djysqbQxKB)ZzST(EzN_TUajad2Yr8hYDck9$)9anFmG;VM?`qqr z^(u>l5K(D|V%IlRad;BV?;<7Lc2&vrG=2DbU%wgLR=IL0%Z`R3hZU|iI{yg74e1RV zu}mzw3(ezJg}!E4?l_rbO%9Dq-t1dNEC`n>!1m`)nMSXymNeau<_80QlZP(wkH>}`?gV}SHPe?nWuCcFdGW$1}o&=*mxhA(br7{Y?gk)N6=uoV3>yaXj+zJbg3c^pm zC=%uT2ECKB)}|rcPZV_0Lsi(!*v-}MxL}cE-wMS53DUrU14$!+EIsgH=NM-1HT%if zovb5~vvHDz5Um{ItjT`oxx_i++hs;fWwl;Zn*SN>7tgZcQ z&&aFd>ztkzxPTeePgN_r;MMiaI^_}JJE?g0_Md(+)!~YJOVWM*DeP5G!!&M-duehb z%z+KE!K(U9Mvo@hVz#)YC>FX@lPIO=yYk%w?*TLb~5TPxi=*`(aXOYgVe>uc$spmwOcj;5IjI{;bgx_D|ohQCQ zMI2>EDZ9i_(}IJTbs`9BFs6O`j*K7f!g3@X$e9edNpuBokOA8OMWt}Hp$0POWuCe# zPE^)a8zw8~HaqA;VPG2aarz-DQm{w;%}0Uoh{c4pVqA=0wlRd9D$&vuKxaP3ykC4sch98-$>)n zDC(~61XNrPN2|cBgdYoB;%@BlUz7L%mFTaf`MH_Xj|8^1DwKwn4YR-fLE4Nvfy2Bh*Ka&q_4A_YXbe@Q6oP)&ZVv?!2F-e zj+^f~?Q&UaJPdFAac8(2uqm@ff~%##ak%aER92EPyBkF||6xOll32e5cC1=aL^Q5% zDk)gDO|PlD2F$0+7W2M)p~;a>Y#Es%;+pcZf|`{XIA0(l@#&uWY@JYv5U*eWBhX^><$|3l`gT5Hc@Z>liM@E251stD1X{}ud_`~JLx zkj2Eri)+QqRT9z`na|H#3$lG2^WMKuT|80E9|`_dCYQX*cURve%{2M#RPx)I>9;de zhH7O6xigNd?|A*v}PgZ8K!x6Aa#CJrl|-7ZK}`r#}j`<;l?giC6-J3YV+wk z_Kns&UY6NRYe%T*bcP&{N*^m zC2``224*{s^e#|Vd>7XKj9DJq74^G5Ai6%aPtUn{s9qw$70+H6X_i*0Up})2&E@hF zyq0XLyI~Oonb4ipY!E~>4qzaRZ%@A~DysuBQ`6n(IOXW) zgmOjgZlYk$xxYI!3rMU-23@Vnv|=E~{anPwO()C@03U$X1Et&Q4e&l3JN|B|xOt&4 zd6*|5rAAiU^k9f_OykV4!@#lqB1JvQN7WCsMD6!qa>uS7Xt0)VPk2f@d7Od>(hZ-^ z0x45{L}Rh9tpoSR(HGv%F}AYj=Z>|utQ~6%l-E;v#uoNbbHn3glVe(h?n)4nzEZ*b zK>mk@yiqnqT$5L2Il;okb078CYM?c1c1SR+J8{MRB=xteVVlT%l=M~x^{x8UL2%MR zTsE;V3e#{zG0^1JqG_bBDUzx~z;mCj&pp$Au>07uXT}+dFW$?2*K}P}d@}zhs;PWO zWv*dkV{_{8^5CMwuir+lMZi=E#mdE!n1AfJW zH9)HYa0>DybZeRdBE|4=>s$l7$DO3U@>q)YI}u7~Rn^xpEBQNLw<`t>wiv~mT*Olp z97g2~4(afO`wjPsS znY_QhbZB=?$ZWr<{V>i0VR{M@GEOvJtK6+PQNp2gk&sw#tt6Z)HpIo%Xf>lFJ5(Y&@RjOzOuwA%G)RC5k-DWxO!1v#MY>6hxK^k1i zE}R)ITzI~4J(0(0mb6uqrMfOHDAVoReGY3<8hC{ig7@qjO)A2YFdWy&;1|Ees(&xj z!QU>xc)f2e+5)Lq{w}Lr?swVTU#e}1b|TYPqV%}O4ra!VsI70(*4kSPG9-QZ4k!t%P+@if*+6ldDv@yV@ zyu^pOwCXuA3b%v4(YQKNG5aQ;^wWh|$07yo#q&md3OB%`pYg5kbFN&rLWF}fYF_uC zbo$p0`zZ*wj~s&VQ?w#I%RD=ZqPAry79{$<1!`%4P<27`#*2|gcroGqLguf7gWKhQ zb<9GQ%5^4}mOd1JtFe7a6pYIMfo&iP)+CFV29wQVAxb!tsKAUj36rrZX3_TFDl082 z)$YnoAKA0OKwVG!SN296P0T((ID(QbA#_m#{$m_GMQ{VWO3&>kF{gJ#<)8)gakzMy z5|?Ex5BMY<21#2Xi09-RiharWg-R@HM8#-2vxpBkl0&i8-Ulzqk4xXA_8*m)E+B_{ zxaO*V3Xg5*w!OfGXHZ4Rn0SS1%cTvYu8A(!ckm1SHm@@wxQ-}o@i}f-0a3ZKWYejU z(MDLvit$$R2cUASJCR9o_bdP%IoTxN=5K|L?(S^miETm)4c+w zil%+@m5U*aIjFOH%nO;GPFt=s@4mGSwQq2&1I&@kI!qi{>=$H_=z-SAh_s=n~xEL2J_|D41aI7vHr;66S@%eMzXwn_j`|e>n~q zr~Du)nuP@fT$Wz8$zD@tZje7J6uwnqWeen{Wj=AdYS->8Yhk}N>rNm_E;+j)=D9s$jZt26iiW6bo8H#q-F?8i1g$?}-NhK`4&UiP2u1tn&q z&G56;YGXD<%ssad4*-?-!!;B|a!NhHZuni#XvLTLVWIxint4`2(=Ho;JW{I$<82=& zT}x2d@iW3S_~7#bm*tk!q-Y^srXY=nuCgIM1zA?;JBaGMxA&TOmup!dp0QqC((Gjq zWh2T60DiBG6<2DmjRXoBh9d`rbXiQf8n)+{r%Zb{RCL6-_PRFcL~h<(X@m;PutQ#wxWDElPZ7!Yk8gdEO09@j;zfGj#q&p`Mbj{iUlh;xhpW zN-fgSxh75ZiJL`JT|8Lmm0#(_ImG&|GcfFfEvaJDo*-H|-$U#Qg@?uz2Pw4zk8KV# zrH0`~)z)Iv;~4qxI@Pw5Ra!BkybEUV)D=VxMJSun{-!xvK}1B+MHZ}FsDMwdyZfwJZMcJ^Kto=SUiYS zp2h`8>n5*}AaV7Ji*>ylIonBmb_x57voRh63$A?lHc=)^MfJ=FG+g)BP@@gdL)rk< ztg`_I@ODtyx2{n66)?-^dBBda93$0F7Q)0qx!!2Gy!PxDTg3Wl=XaEj(3t4>m6BSd zG%S5ZZY<2{9gk;lC~6hLs*^cokF>PR3;F=pYk9{ z@-R??ZP35%Nz#ipWa9e6;xy8jg)vjcN_YPC%`ScHxR4`1u^yh#{$Rc5pL#hoDb7*& z2H?Fa6x6%WoBFZ6=zix-p9)*Vm!=c%2RR0%TOE({@@Sx*r?#Vkc&XUvuGpg{)9Yp) z8LP%(z@dMbSOE#o#}sC2du4b@c$#Jq6en#9MK1*G^1;LMBzOPi^pQc_yk%83QP9K1 z|7hPy9?D{2btZS^e zYHS9yeU!4?lxVex8p2yV3%W6s+rlDgKQ>HBG6@PyorC-~K3!LkA6;tGM*`p}98pz* zvsr5NGK4joYEJ{Xe+q&e(53u2iAT-6Q+Gv0c96^LEh2+RbME9x z@bV>_Uf*-Iw!L@PPjS=-W)CX?X%xT9o+2Ld@+? z*AJ&3gnIAu=}r}s_WQkVoaILPO~^1{@YoUI3=EX?tqj)ws*S@iKA}%9MnC|EGVK*i zTzE)j4?rl=oq~$4T!-7h2GH^%ObG!*xVnfI^D&(^r6z9U=D z5B^*=^%NH$n=R&bRMi_BEJ}sH{1rzQz$1E!SZ4ZGlr^9EC(W<*2>DAh3M%$~R%NvR zRBk2Rt7ksyR(d?{okx_dQOy7G5X~h@cdSMlpd>j8pMvUy(@#Mq+`lP(FyJ?4YsdIR zs_567m#3hQ*9=`Rt|f23<$c< zpm)e;G=zZie*TT5_Xw#cxizh29&<;xGrcdBgX4BeB7-a%V!iG?uW1jed;BCZV6djP02(eDf5R1@%>93jE?wrN&I12tP*5fg}EY{p( zEz$aO$;&|j(BM^N@$Vnx>MlRK!?g<8`X$Q$GMOMY#*vsWdZCoBU!R=uxTcivMy}_4 zc}OI0Kdl{d>$G7-esa^INjBu2uF#UthCS&d!7lYr5qd|{FTQ%PH)0TbPAo- z=)?F`F}T;MvcfzgGCe8L`&FfB#-DcIX;(2Fa%js-2kQ8~s4xxr?)xzXJ&D8h2oZIO zmK+InHvOL2?u~@5PA(!+_iz8{y|w&_H(DI8*1A;s_?n>_?y-fignmLLk=*PQZ&4SN zSCX2G@<~7T0_1TE?k^~j1Rr`r>oyK0XHU_Xz_@+!7C_B=<6HJ`r45+Zla-=<{i>m% z?;Yc{e|SOIes|mTkBl735BPMIy4rmy$w))r*yS<+WJZ<0>UBEqXOwQ%A6Z3t_u6mV z!f)_h@=PTfbG*AVIZp1mK3!|pC)iRVT}AMAebueX6(}jfBdSLLg3iYdzO6Rm61SDh zURMu-OvO!{f*N+?F`g$pL?3kac5wii9~R#+f^yBi14O!pR^Pys#?GtPCP5Vs>`v(H zN%*^gM;XFWQ$HzcejJMZuj}#Xt6O?Arp>~>?xn@mbB9?KHI#*rr;Y9#!eVPnye@FJ zZa=OH(l>Z0y^J?Aiq)z(DvOSDPCf}+@bmsLl@`1Rp^grxvqjv1abrlFkA z!xeB_+gNItJc%PJr;FhuB()iNy>co)r5|7lF>I%xmAAqgevHcq(UWWh7oqkuZBO;5 zJ!y&(Da)=1utrKpDZ<~j(VlEf+;Jh-CWg?ROZze^(%hfw7vz4k0TWB*w5;)Tb{!tn z7e{NZ#nEav`ZN=I^1Pbn%#Ju>sVRRLM?C`E6IGVniKig`N#tafOW(^DjS<(XKy;4R%R4-5EOit~=?I)|%}pV{y4UQa{zLYfT*uhoaXT*hWe z{@lhls>w=@;M4T3rv>Ri!j})gG#7DS6@f^0iY6g%B__M9Zp4@*JEtW(H`;FM+_br# z)}Uu2#q}O>-hN|uV8@ukM!&MrCuMwqCF%A{Xr2LHQn}&o_kg&vEn&?(qpWdky;p8| z)bCO0Vg1ILU1*Xa%rfFje43B^{j?+M82e#%)+d`j5$w|yCs9Xv6GXkKk>#N;ai+F0 z^n1-*Sv^(q$d{bTXbgCKa$>8KQaf^zvOl|&r?VRbd#T&)f%Z*GbF3glN=;)I@hecOXDOsp!*nt^^ z?i5tvm~QKa*^?N-Y}4`4rn}!@O&s`-ilZ=UJ_rjt!VHg>_J~kFE%Q*%BWEy8i_4dw zP7!6E;pGFh$tJ)HtZnquqm3x2v5#mfMVqCsHlA{&sxR#Ij|%mcEz3ghE2wkq_a%3w z3cB#5I=dHz4|*0*_#l|qXog9BItixc07ym&kP&e?Nsrfj-e;-<2aFWkW8VC*(I z4sXmzi6mpoF9ZmS(mfjh>WNT!B&7dtiYJb5je-0$K);!JBQA*7Iq*Hg>r*$qZ5h9E zhk3b3EdEpaMpi*#@$n7hl-1LYr>(CCk8e<%XMGg@^;Q4}1c;K!T>1Tm}VPwRUptbi#g4!>2%t~znF4^d*=x2%h<2HE1O{{!* zYeT{4hlzpNEojxLr^&9JsZRy?ej&-Ul4bf=Yi389@YI~y@;KZ&LN>Z@V~O2;KI?{8 zfjGQ}f1{$%-<}Lln82BYsUvWry}i?Y&K^~P!g*w^13Oadwr;UCJe}x{L$OjPs1j{b zf~tMBUufl1aoF5xC9v0mCFcG2>}&lOFwo=3uCBdyHUT2>wzNvYky9V z;#I1=f+2$GV4+QeteVL9lF96*V*N^Md#Rgutt>VrgR?v4t~F{bryv+UB9m?0I8;}C znZ}?V<6A0s3tjIxH|)~EQS#-s@UTbnh+)Z^w(NwUC(?4!o92W23?xVX+FehJH|XRW zXDU-iA$pVRR_1aCxVbC9pY}^Msfimg!>l=g2F;1#~7}xm`5(?5uHEP z?lZm*=^{`eSKR$7hxZT|sh~oBG?^=;7F~POS+*@9B&6QLRduR!F8!5R>gQ;)dJ1Ns zM~b{0zr_$ulq8sb3>*)=PGC-Di2Vpxx?Iwpaq}@nKGO{6YOQ7kC*0!xQ}yJj!}E~}ab;Rz~3-$2`Eu;}k_Cg#$8(Z{mmclbNSW%A-ba!Mh~?_7UpYskqa!X%12fyn1c)E*& z=&cs^IL)TIi%t1%=3aZOJP)>>CgnA4x>>6<^V_(&TF^AhVGAxn43|#+4;TJ)K-T=m zWJ8v;TG7-Z9TqC_>kXb*2P3mILM|z{vgnsS8OEb7HGI}&ys6Lm)sxt^6|)a@W0E28 z4rMBt!k2i)Z#8)tg?O0|61%#d6E&k@4Yk{m)jw2a23XupPs)%=9vtyCNOm}*p;_-T zBSH~XFD*qRx27sGsrj*PP4bpRZ5^xOIzl?$xKI6#aN+p#-ed&+BEj=+jfD{(w}p+P zN{WY|$E`#4ZO$zJ4Diqu{C&1JPc>v|wrUh}aPOLEQK$h?mwK%gGR4h4?Pc zxejAoQS`xOTrou$uq)H0QAi8-o7U@AwvM^jRagdVLl^aO=X8CbV}!?!L4#F&mj9An z)-=3EKWDK&e0rpjF_jCQ-`QVsvLHS-Xp$WH_4?QD-H%h;WlD)(!YSxLVF>j*chES6%Vyq!vr(3@@^zM* z=oxe7G(BYybNYud@6GXzbNRW+W*H@u$)=q?-_!JWT7KzCA;x!uaQef9(KFUut`iES zu8*`Nm@b|*a->sPNKeXVyhHQ3tKbed>s7Lk#P_ zJw}zvaDBD+h3_^r$7en<#c5p+uQE$g>#O4NV^t>45c|%lB&i|6(sxAsE9?_UEV5C| za&56iyXyxVM+(2778A*lD))BDCz@h-vEqA03V zSh$>JUtN8b^D7+_>yWIeaW&yV{*6|-rS*|?MMN>pXsa-|8rh}YZts2~2b+NSK{#)p zxWNL+**$<`U!~Tk$bgE81KjG-3kuXpv_AzCKO1dY>*I8oUE!PO-qtwcIko-c>A#8!6S+Syk(V`p9EU3S=G%KOA3>A$sYqk4DqeE42}62F zhIGNBdwhNMsGObeFR!*5gl7MqqLxc?qUvrMyTFSc(ue6Xlja*b9Ao&eMQ5u8rAFhR zc*o+L1;+JHl?;j4vU)}N+4zfXtDe;dJq8h+7C=7^ezEl$ z{bCD2y`&{DN{yly4-M&c0J5jPq(Dz0{ZQ$khQ!V>mN@-0aj7sAj!>Z6QbakSA`CfN zYAM|rK#+7EH`9(wl`d0A3^!_ zcJfkXUM=8w@s5y&VX8}ge`}RA#$KA-UR15THZjmJf4U?Uz4hp5owPaJ$uT@ykxWX9#a|4xK`1`9Ynk0b!K(V(5kNdT(WrBe#!Ax3)riwdg9^6q zsk&g_?)Hs`o_Y>Xgj#YW(iHfd3NMFQhZca-S(hNwi-!S6V3A^;IeqdnnlTKy*x2FR z4QjB6Klq&m;bCa)Rl@^m-dm#)A4G}b8xn%lp51C~ACmqTXa75EV>3}cKQnwY5SF9X zn>3x;^=}|&WLdMsxfOeOG4z%!{0rp~!3lPv#j3y7qgx4UJGn<}?F!Bl)-6wMfaZZB58&xGchxX2EZyxlU^u0V3lj}gm*m}bG!jfW3b=IRS`MocrDWUHih z-J09z#L;A2C-)LhNv^Ov-T6As^C0+b3+KdOgGokJ8c`$VHd(RL8lV>z^vY#42RDZU ztXF%;m4r)~HYMk@gpVOT#MuT@AWVZvLh)dIuT3G_Cl|j+uk7D;nyEV}TUz-FIZ2{k9gWR*=9qVKs7w=)XV8={bq68U zW=}3$XnF$1B=yt6yc5dg`a3U_V#BOTMs2BMWjYHM8D@YRBO(1F1O9mxafP;X4z~FD z2%0#rogLgF=&7rH(cM)-l%^3^KQE1ZL;3)N=Ozc~JZiWn_*<6E`|k|XxWS;NZ+bRT ziN%I;1nfT|L}<60K0TkhNm#7!?J?6P=OmZV_qvV`+o(8#kp)$y7jka>a`>ypO{QTK z>cWC6(w)A7yIYr7j-3MYRJfLaGH!~CsaN%`(hH>7MPtcaov`ywL2vRjgXwN?JL|*> zJ&jm?KSSl(OJUO6=N;Y~eX1BAcnRkq{g9_1xXJ0KT7RDDjqq~rf$QdbwR7W9)}%mw zdX#e4sxa8?M$MCaURO`Jb?m^0#xi@Myr53Kc4zp9&v($mjE)nBE-mb~(aBw-V6G2$ z5&8`0H`hnn1KitaKRSW~W$n)sbhnq2V2=nh?isosifPpgKQA=Wk&-^;*n0Jer#sa_ zPi=Btt!bM7X~N}Raw3V3IXDrw65A^ zO?|Q|AX#yD8xIT`i2q{i`xjM(nPvcte`DWL!ztMLI@BTOE8r(<1JM}dcMJ)7BBu^v zI+83J4YUzou|l0^5Yv#xo?aYMc+tlx08Inr1c0NAQz?mYrrIZNm(sZRHD&=(Sg$=i z??R2(;oSDUpMqzP&s`7pj_}=*==6~93z=Vxua~8K_*!9A& z-!Wgi?5rbEw|%L=@MC-YjxhL7YSp>`#Xo?Pe9sLU-3xn7xHweLW#i)o*C@JQ6qsCQ z7axk7i47L9b3fmx`(CdpXwj+6B-G)_9T9_&6sM`J^pm>-;w_1dH<%d)N*kB1Tf#Cw zABO?iNfsL{)21-`?+G~X3XvR`z#XoC+wb?H%O5A&Z=!owp+IcqTGi9m^y}s}3dm~5 zr+fkN@Nw3PcS*IL z`GZqDIoZlP2JXbHFi?U&7~2NRyx-9Cj%JDY)Te$5T?{zsJ|%>Dj%ysGA;rHZ zemwk3#M+7`K&Y#z#z;z$tFkdr7I*J`UpzdA-Cw@FVUP>m&2R$} zwlnvCu^qU+FwkeKJO6is+CO-~f{jhxSmp)W>OyB0E5x|(eb0?K383*+yo4dn6GL8)tR^HG12errnDY5*#M zc$ooLJdkON0uM&PP};L_mI8)jjrAvso$ewG9x;+m@T{ii$vOcV1V?y5(+=_>MMDJ% zA)NSHK(`7y#&Mn%Nabs2^&XEyv&#CiKd?vfNzWiW2sLU#f-woqzSNWD^>i$@-IlW9 zh~%Xw*x5B;a7R&S`#8FQmi%96a23bf)u-$IJj@4&uR|bp={#migqOucaJu5&+VP_? zQ%S)L$4B)qzrUXT-tei;>ml%>44WY}CynhYGwN-nGn}uNj+%~u_5-tQDxBr|H*E_l zZL4x0RN7Q%N0^sV$IEp4KDEdhx7}E%S+suGaP#7S5bERkHT6G1Y5%DOGFyJv;@}?h zI#nhW45j{Laa2VCeDNuI30{JWW(QP2oH;{%PRJ&!aBloO7HmQfLcF13za8fN8{D0l zlDm?2zuwSES779=-#evV9$1TDRh8z})Q^QBe`Yu&KXg7-OAKDfqF)nRja1~ohxY*0Y!JWETdhyVU)gNQS@QISfdpYK@IeE*%^VuijK zlvO^zI+RORdt+=9WYuMu;^J{|A@M}+Uw|MPxb2Io-@zAZA7ZFGNi0d$aHrguBK#ET zTO^L$60eCmi^ca&ZL_Yy6ZvLI zfm-gJJS>UxJ7u5HTApp1AEuYh58c%om$gtYa2x z7?c$#Vrc0@Fb0&tC{z?{5WDNONVNi;$UqtrSdHlDs&~0mH3+Hf7aRH^f}I@BC{ig& zU}hCv`^C1|I&AS`vw%rwJ_4|A1e}eYO@YKgnsXDqM*pS){xc!gz{j1JjXTM}b*|(C z^pyX>5kdy8H7S#{Lx_y4tA{l*Rc=iLhDncETjq@T+p)jIC~wsS=u!94vXjr2V@fGR zm1jb$G4$#~%kcVxI!57sJcT9N*NW+aHy6oA?C^eP$t;BqTAT~|ezhRj_TKL>?^o2n zvK8}rZ0%EM!qv|N(?lM6Cd7GLj$7OK*j1SJU`bb)saUVY%x=9a%tiy{S>)gxWk}ne zirg9^72biQ|3Qyh^%ohsczo>znx$XpESoGs{!=f&xcA{q0+K)IH?IUHdO|(^*^&x~@;otF2tZ z{ApR9WnO^6)QJ{i1S(7=3DXHA^Q|j^Awb{nw*=`ZqPi{WSNmBcHBgOvX$0xak zJC7L_i3staz=Wf~*nJ&fo?lX+fRWVta__v!!Y7ER0{aNUwSVUM6+KwWltztSZUx*; zzS><*%TTlUvC*zq8_%Z30g`pD_!pZTCmmp?9`^P?nD&Tkwe377gEs-Oyj0`JXuS$x z1CDwihnl27=Hrk((ZlFpY#BdkSXTc}JcfDipprGvhy8Amjht=)$hP;5>5MJ78^F3X zkQ0~%=32klCUZ69;oLb62rb5y9FgluHuU19OBsJ|Wn2Z2ca`z7>s?Qs>yJRgRX2>6 zBQkt6slr1NRm=r+D5`rlvkVxoY~_ZZu1e^UWJJ2n`I1=+0|$UD-F)^ji)rzx6M~qy zY~Ds&r6k~>v!?s(4DFS z(|c1r5JzijE1l4b2+4a)Q<*c7yUMIVKK`DgotRF5NSFxz`N%_zb)_RugzW)`vHNSO z#NL7H0U1|iKetqLZySjBDUJaz|NONvS6kuo4r?<5qItp!$oR22YLt`UFdnX}XE)3PE&CE*m_{H|G77TkV_Iq9*cI#~J24a05;489H zXfdn-Fb>c`-@#FV{0+q4FB)ARGt&&d&2@LwRIy&?E+tLtOp#HD0Pi1O57~bIOJU8~ z_{OZU^jtunRMkIo9bjj^O}(sI=rmq27Q10nVOJnG7VENV6`GfF^<0mxNk}Fjspk8a zW(M?btZrwYXf7-w#*v~1QVciRVjPQ|p*Y#@t+kR+3(KB!qM=h2Nn?#CJ}A;EPU*5e z4U%XX;Gv52T~v-C#fIGLylR%-viC!TC@B`B@OioQo}piQSzLYs{&B^=)~`jL;32}pLF18V?!!7#bDo6DcJ zNbUjJqIQxs3{(RcSBsB?49?QsfWfavIo$&TE0T3mhdVV$+t0HIgcY|#Wa?ofl+mxg zZiDmeLn=$Rd`ceFYG`u2k87?u@Ty*>$IudD+Vw0rmyFIxiYLa&}R*8i}~ z$|~Q|MLSbVU?}R2>#V{ZL_SD(Y8*7={j-gfek9lqq*5OIb4K1(+B~|1rEMaoW>Lq^ zkWD_xUu>_HErHXt9ShV%%86#b-uO={V3Gf$4rPWh@DV-1fMqVBULelgsbFXTvRuq( zmKH4`c^`Wj#!f~i*xQXY=__yx8Rw1e+?sk)R!>uj0UNs?RyCB-lW}>4Wkb~sKicAt z`JE$4y*A%dAyD>%!%%zyr;1C3A2yx(3a9$)3TN&?9k%-mwJX zWdIq?mhFS3lb2=m_^xfl+@r+?Vj4NwdSvIXf%46~oA}ozIUfnh5y&!EO)E~nnP!72 z9rGe_LU6F}#}UkroAzNV1-WlY)LxOG7V+njyMsStHMTyzQm-sJ<+aah%C%30dbq+8 zUJpAw@nj!J{7jJ}1ZTTQ06m1ZQnDYjN{09mPE&GB6U1LYh)|st4xCQYriY(t;Vq^xQP*2i0+a1?Xz_6J^RfndBlZa z`-HtB?a#xiMaI!7Wp?QJ0-t~6nhP>-+e~t-6SJM(0`SqKw4i)7ha3zuw#eW)ZIbfj zc`8-r(12=JcA}1$qcQ}Um54L+9l(0J_&bBQv5wXPv>c$~^jdJX)ZShYCk*2Nx(t`Z z%(-qDaNm8J%!wauQqpscGN+jxR5`6#4Tat8Xz({rag}FeSM;l=LLx0Pb0+wh-`(mu z3ad*C8v{1;X$$(a7=0Z5?NSPTth-b9OKWbtMyFN{^m?DFCLP0p$EYtAjLCNa#*c{3 z-)a;MLgn9l-1khvJ(PTbU(S-RY+dWl)*Vmp#ZuoQ@Su9)k4`bV2TRnCqLmAxen7~r z9Vf&gy|7#x#;66l2gx4AlZ23A=H1q6_y*g#KiUq7yfkM$w%>Alc@jJ>2UnOQ9+lUa zsPu~xCruW=g}0rsA8Mzv8a#Qh%(tYn!%%bi??sL{iAk|+ zNz-e^NrST5_MC}5axxlYEH2jQFE-I%Y>#)&Ar_okdUik?Ea?~%W)j1gCjqVnn%PJG zPB$4sC^N+4MR_=2Du(emoPl^#{ESBvK#Y04{r%^~9?+ajTQ;2V-nPQlJ~Z>$-&>vi zO(xD#?~YUoI*Eh9sQ3b2(s1z74Zc`)E@?+=0g9n3xK};5k>Ksv;oS{~0%O*k9>KiR z^UXw|qdDfpT)Ipzw163>rwUK_{yYRUxw>Y=;KSV;Z^B$cOw1ajq8EKRHCqyVKc$U|2l(hZa+d2ueBT$sD{v)sk`c7@O4*{2H57Gek>{o9cJ`yp)( zuGjo2!Ga#@_Z}~m#2rpXRJ@a_>GsdO^N}QM!+&#Q@6a#o%#LktV5qtCX7w_t=vB3S z>YD{cyj?$>m*mU3`mkaG$N&=@jt04in zG3+()-EooAk5`Tk6+}}C<>b0^F26I^1&P!kAMK=Ig$)$eKE_Q}ov1Ku8UWZ?qttF1 zDvhRKqb0P*s~MJ+PK6fGmQ*Pk3g>U_*k+q|ykl;0iEcNPM_#UOTr=-sq57Bcj$Y2W zwy{2|GjOVoNl~`}kt2_E6?{`SN>3fR)w=QY-L~-12;QV0JciiEk~8s@5&*ADRsjLi zKK&QlY1mJ0Lc8tDoG>@of*ci_q}B@m3HpQ5;H#QyF11ws%+nRO&(Q#CJJDPU_c^oWM&A3lJ1(c>@**64>ROo(W7^o-DA=;mh5P3aU z?@vt7d!hs?LMf;A6-VnB=}O%GhIhm>pPZE}>Op~;%?Dv(;7fcr>`B(RDDCF4&h8E8q3J1#Vgg*sDb*yaa*X^W z>FLI3LB%*)XXTB($gSYUlIsUn$sgA}_R|mZneX?XTO20R7lE>eWV$_x2srY17}_*b z0t-ZK?s(M9;-ur2xCM!L?XN&I!hn{de->-3=|W@1pE0WHPLi0 z{9#pOn(eXc(%osFf_c$BiMPt8IR>a#zwhaHND*+yz}x?Z~pJ&-ZGLWw+TS# zE@VDD#Z88)ol!!u{p-t#a z+65u?Zu=~```Nzy*GfQw^~@}W3Qg~D0FSLV!p~VG9Ue|S`$%k@{mmxh^-;O#XK-?wn$DA*wV%Dh2uO($?`_c(>Q15{PdwP6 z@56XycN5T9-Q<}S{9H_2c#j-w~DOMuQx zEpel<>fY0%?oTcP;^`}d{)gLKh877xt#qT~oZAE`BJ&Gta$@oJ$b*Fz>Ep)&RbNOy zu9`{$j3N5;tD(K~I(jynw=xce6|etn)&SYcYtFj;Y$&gs$f;X4tA$Q>{$=pnFg6t- z4aC7*eEx!2f7Zna0?7@O&|Bh(cZyCG2gsYF~mA#x*P~u4T z9kn(Z-Z{As*Qcx3l(N2HxvaY*D=V7wDT_T0Pf;R_$DJ2CU0NhW>-{1aBGi6eN`(7k z2E^n2Mh!>O?b@D@vdvl6XM$I%4H+DTx9XU*%>CHvQh(Fm&1FC!4RF>w-7haKtkC&n z3UCd%>@eRV=zhc!?2+((;rUL*;B7^0BG{y-!i}#cgXC$_!X5Ode7AKuDa&20Ee5@{ zvZohDUU`V@x+PPDoYSTp75R9n!M^?>l4JB&@9%mya$etx8{kip67@(8dets_I&LZ^ z!$mD~MhdR+v=^F44 zvG$5rYJ_VpHKnKet*5V0_G5s&tT@e{61ZJQn=_$%FAZ7akq;)H${p0W{;3xp57+eq z3y@}joCdyAc0#HF7~vAON)oSU5vzO!tFD!t3vaavOd!qAsr0wn%T}b}$4ZFi^<@^0 zQy7(+DHDEK>y;WOvl*uXsm}I~ZAfqW5h+lDj@mDv*`MkX(@G!ita$5b8>-kP4+CdP z<7$Qb&|tgpB1)xueM$-U`QU6Ldr->XXklaP)r{rzB4oGRi9Caixtb2Y15^>4(e$P= zmn`CEYjzS?>}&P_6{Xm2O4IL4#!Kj{<`^S-mrS|!?-o+>h68!kFCBb4NV_tu*){Tu z&7KMbIp4I0=}Zp!-R|Hz+ZdEP5lUXwOD5Y0WEenBPJf1S++-;YBgx?49-gBzm;xxV zAFSL@Q^U3u(s~=>{d?SoT5XP7&Xa;7!tBqt`o0|`AC)kp*VLYBB|74xd|7cOje_XNfU;08S z{pN`&4D}g8HRC*Dgpp93tgjNB4b1v>ZR$K+mp&m;K?a(kI?rM0SIN&26f>&p)M3hH z>keM3})$rTsKK~0PzV(bp&~0u$>-6DK z_#b8Z;vY6<#Scr$&5`5Z49+=yFVqtlCzFrXcBbeb(G70Cn^a3Gn$RxOi_oRZ6b2!X zIkdCR1{Y{<>X=-zq!lc(R_qE3lZrFV6v!o$n}9_%Mm&kp^fkija$yK+ymt}Rpu%|D z!r)I}^%1v7zu0QzmMYiE7+e-~ALRNp>IEIBWROW-1ODPE^9p3!H?n%}VDZt9_4ATY(sd^^bPB-ofvEo#M8M1dEv0&NI`~vqoAI-^O>2p<%^S?lMG79PF*|wl#ZPj}Vn+WkkN*4tstFX0^+ZO`27V^;(47xenI&L%G{bg6 zD+(om7)4yA$;5+|{G}6XeX*Cm`W&)&qeb6dn|MdXym;CHx?49<-170ntyrn1eZA>& zo!g{l#jez?D(ip)XUmbjwUWw?65*;e5 zsS2!Mev0cReQ<~r1`A5W^KrzNo!5DyESL&50Pz?W*!YYV-^y|~$(Fq%+g+$*$eUz* zy&CZzs7m06EMG;QM{YUL(ZAR#cks4TFMqK`B$NVHvv{Q9b1mdDNC(X#6et0=<^?wo z#8>F98w*I3&bZOD0kB=v1f7Y{W+d)nP6U^b2ZFDEu@$B#FYZ2r0~&opA_03my5e2R z>RS{;$TJk^m?bm5E(wi^rx19*tV6%G$Qf@`pQYuCYC|jFjL6s$g z9UB4W1&0MLF0T)Z*kEP7?d-kta@o}0OBAYz%0-&@h2^6kf7p)oQd$1-gcZ7&60-LD zn`2l?bFGwRei}&P1Fe@N<@@HI+4zG7(r6s*2N`sJc1UW1;&c2&nHLPs zak-uQ=*TS6vaHDSKz;CxZCtuEpGMbMkzf`xMSkZcm+3J2siC^mov6b7}CRTEz-P~deabMeiHIuuZ%PJs$l~-ZW1xElY87B4h8TG z)u7GmgV{Se@lI5#+`{wfk@cTD?p2l1-ed2&=6>AP9{{58dN~pe=%lhZygZ%jo>Y9V z`)rARWvg$cmgc5T=-6`^B_e*0=M3Xt)TyLa4K-qY9&AB)5SDu_LR*x&pq{`RWFBD> zQ7d9ql@l!OC_l|%(xQ;13afArJ;VRaMO@!W6Y^x|NFOq*&l=FigP6uD8vsjVJfF$x zc>`f;oK9Z{*k8HR6m4cf5nu$Fm{g=fxaQ|)V445=)X-Wq`eV*%bhY_obIx65rPZWE z_N2$si5YjxQa?Y+(6%=`l@+ZpjS=pTd)y~yXj3U?Xspw?H1>}V+_0$dCq%kWVG`%9 zYc9#{R14z0t?_xH#4XNvw8pSn&8F;pR%I9A>BcQ%6OGss*~UDdQsR4LU~+ywW=`lZ z+Alxx$7Rqfz3fIMaQ(f9%`Neh3Q@4Zl;tbYTD-VR+iBPDzpDKEJQa3JEuH((e4S`>cY3(rv%C8*_nn2b0^VkIxmWCNcY|w6Lify9RX6bU*($r_A^3BPAxWvLiA1 znW^&kP59RdUt_IOtV~9Zcnyw$rV#9KX9_DKp%+9m+JhJZVnsAaz~BaJ9@=RBno8`- z!z8-(5{L$Mm4bS3cFHR#=tq=p8I?%lx=sY?0UG(>%J2HV3k0nQhE$AhHHDJ%o=Y6BIv1 z>-d2R2RQM=fTt(chot@l#Z^DZwVXV>H|T%Qz&gv_kPNB9}q%SnqE3b5g1K@3AvcOY0A+352WBWQlwY<4|czR#Mk@C*QQ*w*J&x347Tj zdh&E8&|mWg?YaW)^N}6YNcyvvTK8CvUWa_=n2^D1B3t?IZ|&4!)xF#=rV_La`E60&B`Gj zVaE3m0C${|# z#o{826EDF&esD7o*zz~Btr+I7$8Bm`A5ZuJ;(e@*^2&7>yB@zFcyZcKPkc+`+LzoR zk(>oLxS{yNYnhqJ$pK2fwI{Vzs~|jc?lV-p0reX!L3L<%D_@29L1aOc`{i)RmZuZ_ z-kp0l1RFO;bD-%Z+mbPOLYQ=+3H_eG$Sre~3#Ak*&==x1kcj`imstgQR6ZVt5uhuz zhf+s}N?#ku!SzhB7hzrtL&ge_ME^65PCGIER}%xIX=n4jOPCd`A@t_uoDmJ!K~U5C zZ~fq}EZ9cpbC12TcN@r>1%9S9L!Rd8PIYt(saKY&E)nWx{JFNIA)j58CgLCH2fh$c zkX5MjKut@ns4wcCAs;8=Rw0`4jtE>%1B;r#YG_GaNB(z?-0A;_k<-t9fFL36z$X-H z*1m_u&wPRP*+jl_0;)MrNQ*B!Wm&@#pb;Rp>zV05(~j9sWhX$W4J9;gOx!cyXCF~9 zfp69#T~|^oV3E6D*Yau#oKkBVjHTx7#j`4#Zq;YlUMn+}HUA+8@rjD+>shOw9D1@f z!-yc~#|HZa3Uw_>84(9ac2|2E= zHBWf(hPxqp>O*!}LY19bs+<*-NVh`OL$}pf*(Wy`fG!meqnAbOA#q^VNaxkKcF`)R zaSXGN+Hm+%aB}v^$@j`iXtwuhCx(IR6L58B?R;Ucj{uPJX>@AC3M8k+n-w7XnX@F_vqKo zNl|MEMY%Z!3Jq;bYk!)ATCUqaN|x_a7OlGj@g3eTJ$IWA#q8L&|FRIH=U?QiOU{ea8r9{!Whxfjh) zZETO`VVm8Mt)J_`Ff7Iy`rN7g6}fjitlrbMbhR)LFYN263D5O20soNR;^7?`1`R@# zXEI53TD!>KTcNyUKfFBZaoIsqv5(dB~SYPZeGm%9!5v9u~caUu;ZB40~^I9j^8D z+W5iZD^;ZTdZ*BbOpD2Y+RSc=v!j|r(l|T8*=VTSf}@j5Pm^AqW%Ya9%@IMv-e>a~{%7d2&Yv;5q}U)}#f= zULxm{9k#AH~Zse_$J+Jn2%4XG7ZG>C9 zZ8+6dMEn~}e~;ZQaoz4gI=;ZzEy@$q zMXI=!CdwIC@(*qrDR28{>`wXbv0KfgPXQFh`i$JY#Ka)Cx{$s|=AT;%B|II0C+vVB zq7)PdW3skM>`c_+dBEf9{|YR5h+t*|hMRFWfE|tnDz$OIsX6&rCQ01cDf;&hR8&H2 zzJoDYMbOv6=kLd>eI8)D7W;K%)MY)N$=uL0i4ACzGJD_PkROu+6KlCc7=`&0;zh8{ z5)bF@&bG2P*##?|LXsn?S{KxbG`kOk4FC;Kp7x;RpEVp4Wq**?+GJkU+!A`r6k`F0 zhXwFP1-`3@`hdg`+Hg+^J^DfEP+DR4$f0F51g>3xf9mCznAs=}EDB=;fvZ*jco#-EC6sLZSDJXkUlN2W#HJ$i1 z@GoH4NG~I9;b}i#&~ua9Z!gVjsa$IH024!tuHi@eeDriz9QK~z_})zX{Xt7!$4m3E z#l^Le?91b!iZ(Tub^qL2g(Mm9`RJ9$(N;-_^qTdL@u^koSOEs7&--bE`K>gglv3~+Fwe-RyJJD+Vm7YZmhgjqq|IR10rdLK?QCSH9(sQ zE#vv+X9tiWEYB_jVN1sTw%k_EDU`D!tPCN!7-*bI$JupJg0k0XXHVG_Cw7ysns=NZ zU&ut;@fNscBt?p%{(p*w9T+fcT;ob-;g7so#g;drAjtP)7+^p0_QnS?pJ>Eb90meg zi=ZT)G&lrJ=OgH)z5N@Oi=P!pNNksSrgV_b4oe%|vuJ0+#kZ|o9e~g6MV)0t zym#`;&7s)P%wpBFlUd@vvyEhpi0ALhv7{)E!{qhGO@9C6J;&ea2`YW+mHWj&eeuQv z)h0nfdEt9Rb`GoLLs&$c;*A@HTGZ~U;#WC;*-Dki5P(@?jdi zbY)%gy-pX4#3Gd>hBmp~3#5r3JwALMi#De5uzQKb+45AA>!(*{1lYIhY*k^84el}m zDLXTt$i%Kf3!D=%NmKN>^XFqiO*!fU+yapE{V1S#gmm0aiG%bA!}DDe;q8ixzgN2X zIMiZNz~*T72}}x+&tAAZQ>eH9;h+#~D<5{V^Rxhmd)@fun2#0lRl?(qf!$@P6H$axg7+~IazjlO0;U*u-y6ylD zeOE(gGj`l0$7TKe4(R=c#AtQG@QGDBJXvdCw^p!EozRgFyAAjoz+ovdn{*IR1N1+X9BDg zvDyO_Kn#DJN(I0Bvg5ua4p{CY9_EY&UTXC3h?J0drID&?1Noq;KDPNb4j|6udk%2R z>nDmTHt3WJxzh28Gt}PC>D+W~l46O0IuSzFrFC$q&~bD=RZKSBC!1`|l0fz@^oyV_ zo!p@4y6YHmByAi`3`~B}D;w`|T^cVaYy@sqZD+3&S-F}P0zBjPkU?s}g7&EGQ z%7@1YP}`gJThys;ln0vEn4&vA8^7PWZ6 zOT711MTWv4kY_bY{fd_v_w_BjWX01j6b2E`$U?3dPDj@^^m{V`0%iPF}}ZO zd}Yz3lqReG-J}U%L$n)gYl=H}6j!~YUKr7j2JV#99&2nviCwmou+d&*=R8ZrV33J@ zmxG*>q}cr15=iFZ>ETk7G*+zdTiW3&4eq@hO_Xdq{|bnIu>E#dV3#2_N=m6|&am-o zo~t*0SjXMGkSO&DSM=Qv7fY3Rpv|5->he9n1IyI52iY#jV| z_sB<=S?OZoX_i|!`GQ&Y-bgoO`<_cco9dn^H;2m6QPOgj>!9G_lNM|8@R19jG@&~Ib){HVc2|G=Sx&Q zt6FnY3-Bh2-xM!371ejveEpgG+HCh<3Lk_|y)hJip_WNdRX92fSuI$ZC|H)${1|#; zn~vJ?;^7tp=-k-Y0!ke48D$t^Y!X~-qM22ilh}7_TS<9;y3Oio-2ZF8{Qm{={ckrN z@_)1}N%mBA<;Itd+O#rP;j?yj!k(VGT-6-E^G56FuDmQKkH4D*a?sCwYOKv1%Zn<| zKOGp$%qry4+r{6oj~8P)uL9kFqJ9=Hrt}u^pLkNN{6IYI`eo(mNE(kBwX=mJ+yuEu zH+JgoJ|5k>I~4##d?+IU?Yi%w&>p|{78S>wMd)-ltR-tyfF*C3=i1en8}QLY;0or*@H$$`A(1YuF^_ zbvAbbom%q7eeHgs3s|-C5?UVAZ}e{ji32YB-w2W)rq&(-AjqrYxt_u_@U^viHAyqAmkUu0jJ_Ql{b zWy!$P=2@X@o-P7!SLkO7#!9x8u?-)PucRF0P96u19OW2e7)QN4+@T>Y%@m*@AwKaSB_3*0K^=wMOafkCn z%Q&l{+g-JlON&d8ojalH0kyICHg{|{kiiBFM`JFHYhQ~ERm)7Wu4TEK7f7Bfdz4}H z4O(Z!$VAQkWDU09QOB(Y7bf=+Vn$3D@;Kx*-98n$YXv(E3^pi$k(@M2PCrXOb)v|C zGvC7j>g5~}X!DIPx=L%pYupj6s&@WYj)VYpcOd=}J-H_`b9U{rsv4i>eK%j;g@t$O zK8G!#0%`9G<+EKYdIml@tJuGT-e|{!?!bVGD&987LJU+`CsJ80$5V8K@n zLWJ_e5tKmj1-h>*K*h3fTo2|44+kfiQ)McNfKk1(!N)6&s&cEYo}lHbAv zU!Q4zy&l<7;eNfBb#b%G)$0Ctw;9*FKMoibWKgP06h+$U!vcG-*J-70i}TpV)=SYY zy5!i6D1EX=Ob@v(JE)B%prt#OaL$8zl-rO|lK6SbACDTS$^>(N> ztzflz(c6tKQkmXEz8VDcpd6LcPQ$955r)l|l(mbUvL0pu6>&;ooC?52IL+>kS;a>P z9?#v6hpD`4lX+Sd#@%0r56yWv%3%wYQJPX>MXl)E!<|m+A!$6hq0RpGE5=HA>xPG6 zCrI3gZ)nI)=cCRW9IrW6Bj8<)@c2r2PVFu$rh5{I8tnT$sQikFtuR;NvFFqaQ{5}` z`(va~Mm_}nD9c4OwbAwL^qkv*o3qpU2Uk~LKC{b?bJIPVKQrb9C9It91YC}gR!UcT zcxJ#O@QTfn>NG&-aK;U&(%bFa-8yt0e4qo962Zdz8tyQ6(<8ipO=Ji)&NO|BJNmjB0XSx7FoBq)YFh0@8a6 z7+@;`(t`930#ZV+5+IVLK?|shR=Z|l@2>|b?|B?mxBcB+pUvq4;q9|)d(6>lzk~z13R*f zINClkSPEl)!_W%HX8(DGJP6k>#}HOL#9oyomg&U$A1A&30FfT3@`m1@z&mVrB%cyyH_EU0CQ&1!pA;-mQDnT8Q@XxYHwPdYo!eo%8(pW6dhx}ztSSq#-Gy7 z$A7~Bpza7gRZ0tu0D@hPhOoAaPR)5Z)uxVbGrE9ApnJH5xnMXH*oj*In2=42xr258 zsURnM33Z9LiIn=3sA>r{4iiU-7UAZYvU0m0 z97IG=I{9A$)!@tl(l-Mfq-j!3Gidij3&V1qkG-|I3aOj6XorwounOa1v5>kSnL_1Q zq@{fY#IdN5aZ1sil9(0Ua-<8gF(d28 z1%SY{ihYFgk9PNxVtA&J@*`?CO*`f#d50%1My%-@`JYzP16XA+oDZ1%=;Dj-8JtF4 zQVWp)&qBP02Y(WRsupY?;c_^Qy#&ux1A#WbddS+s5V-GYIwxU{<|K;DS9E`n)LYg1 zeT8N_A1)Q_zQ^0@|9acSk@DpcyaQ>J=_Z5IhV5$u&A$niTQ*Im9VfxA#={FHx<{44 zVRz>7d5u}0iwqpu0LV}!h2s4fNIaVH*h7d`A8d(3onxq2Q*=m{^;Y>zriL=kb*Apm zE6X`(o9ekjr+j_x_@pgQMNw1ZGXAkQXM2}Nz|T0-Boq005Pke3XWS>33A#N#3@H;h z?qP{;@X_l8L8xG+u0pk_325@Zd#Lk&E$VE;)X+H2dp?47p+IVrxtM+Hq##1)xg-G~ z<9=+wvJSB5+Xp;mVWoodKW1%_l5TUXnxwy(apAzU?AI**or(9HM3X=KWa4Z+hiEuO z(AM}x8F7!QsP8nRWc~9boOyd`m+?oOc}Y8o<&wVz_Qp0(zWmnF^3d4%-v%3M!a=$S zPv?!0L1eC#hyG+35*%3{%aQH;7EEMdAoNE=Pf5zCHKTxj>{WpUq@Pl z?X8~3kkW6*przgQ^h`6f_X4$4zZ4qQdWn`FP;m1fu<5K9A+0I7+|>n~V3tyN(p*G5 zI=-Kz?rONLl0h{I+!`!|^kKH$slkdWCANGZ5mTSWqHB|+=w&akDn6)T@xQS(iCp=E z;Xi7R0lx8<-xxFOt$8)Yf2pdv3Q&Bpcbhlw-+C!?zjw^=nqg_Kj{;CU*Ze#O8k2{{*n3ysX<|LESZQ^pmWZUZKfYwRD z{^!%B_m|O!8#@96oy>i3A-u}AH1mL!`psTN zZM?8MEZI>bSSHfYy&P_g!JX^dW-=f_s9=AU7@Kj3K_lb11ijy=khH52MO>lEbV?Kc zN!|QbrsMwbpI7es01M`~fqdDZGZ11=4JY2-^bM~))a2W7 zPPn`j$Mk8Vu&cX)uhfHg%qkBcQua%W;ayBWnztf~{s{P<0Hz=yZ7<6D&-Jr5)61yF zX`(U4^P}>Vbc8HdE05U`+1lKR{7;WFxFpLQszo9OzIvUB0;ZFDk@S&$stovu+NC_A zdK$^4UxV$Emp`^pj4Zw`@@4sNjfdaH*Lt@CNS>TJ_D*X&bnKzm%g z&J6EoAv-d^GV@7@QI;jOoJ9JPBky1jKU$w6PszzSzhs=1seBm zDnBfP-9}g7{E(zEFs4izkRfycnNM@l(G3tLqV%^YASLEj28WB68_UuDfM`rONLZiq zMTuS^zdXLjDK>0O$ihrquZFJQUwyxaRIvSay-WVxT0;p;hcF+dP_5=OO^}Wbj$pV7 zn;QuW>qyZ>QVC3bOLTj3EDuxPU9-pwI153Kpgyk+Mc#(Z4|L1AVrbSw*`CO)NE{}f z>A&z0!WD`@${M@xf+QS-*==bG38p3mAmAy5AvZ!r%qpMv*;2}el@u@5m2*`XObX8o z!iUX?GwmX3RJ!FE@nALUW1FP<)O2IwiG5-%j`b*QetUtIp-g?-@<2`rD zHDv#WY__+OttM;2h`42$5oPSVscJ_~%bS~B=`u6rqLvl*W2<8dY2{nK_9lFP=c57U z|HenfBaSet$)?E)wIkazK5s4Czjd0bXT7d2I*<>0v-@n)iggmKA;)X9;q$vJTO-?P zO;L!SdX!6N6>@$c^!VK%X9BPA=Yz{`v`v`9qdG_3eK+G=r}A|kId%S8%3LzxWtXr7 zkN;weV-jxuy$sKoJj~(VNC1l~S7d*t$pJfmpD;zzK*uHX<9>qJI8&ihj%jM|Aw`6t z*ykDsX1!|g0JGP?vi}KN!NaX_u-6RJuB48ZE&pQScil<%+&<^ICjEjA_x>)e5yzc) zzuH}P)B9Cc?G`!SopceU5O%7&zi$@c0~CTJQbGJB^vWWG;-k2yOK z2d{9X>rU~Q*fAOAfDDgy7&~X?e3B2O#?*W;y26Mi8?2M4Alr5tOp*$VRL@cp2a+C( zzSGy(#-ORQCG-sM&l9;gI(*J1`mrkmgW(x9C9a52FU+#TlBfUpoi$s}$K!qo)J??ZRw@-|oBML{G)lID+dZ#>B<{Mt7$6?D_jB_`jf%`y@I-RUl{hk_pc4WEF+BD> zW=?T2p`t-%<|SMx!*~3 J^$4=NwEzU6~!o z#c9~(sDh|Bhx_+V^qOL9*)5s=eulKo%lxS{aX___3)(-WUxlSsAn#H_s=S5Z17y3QR+?x&EhXqZOYV!jJa$ZydT~j43^Is$0 zN^0s(&cR;g>5=0rKkQUA3n4YOOrS4qyWsb@o|kMmlJK0 zQNJ{h9d)x?{+wrT%<3D6PH&kr0wIsUe0z)uM_9zN=frOEH+BdP)~q2{jwuA!s)=Q2Pdh(<+G zCsOrMI|BP0?$}t`PSUXG5k&OWmLm42NC0et=9ACO*U#^A;~~66gYQa2J2wWw=<<&$ zW{nc&c0S=OhZ)<1?1?{iL8j?qgdp07`B0~Z5zVAZ{bL9(zXdR2POMh2kI`QZ{yLWfTP-I00*r)z>6QP%goG*!EB5cP18*S zyIg5h4_el~xQf&^ax7LLnyiIi@^L%`2NaPrVh9F3%ma2h+2eBkfESW7#|>n2goZ>r zrFGh3bncdMDU=uvOQ2(FZIrDln`=_SYj0iH{Y6;+SJe30e^h_*&);*E(>xt>W#}D7 z{EB&c(qAdHFK_hn@JuKGlkaH=a5s3l6=~-jUGF;kHF8k>mR~#;5yi(db)YV91A`0` zQ5l5zW+Q5kZn@arNV)0GuwwP%67sV%!|4Oxfp~@YQqB4oV#`L|^Uh%h&3SpB&{t() z;nGDb`b)M2;%F)BAn`X-5Fog`%dhzK^RfCt(+`^q!$t!8F zEPs=npU6{3?i^r<$D6%5+Bev7@^G%4FMg3*W=a8x-WUs$PW(70`Bl6&X00LrlH$-W z>YV*E#;C0%IYZNbX?pfmx z3p7vGaLUJ)^6{X8?WqG^YG^cb+iMS9exA2%?P{7K6l!(1&Nvs+kZbgP)9w3$EBw=b z&gL?nN(8RtxBdVkXM!Zy{z-+PKdI2+V#Z%o$TaKkREX!Hc)PM#LX)|UsDq{N$FFm2 zEo|Lf$=<9staWK+?6H`b0@ZBjq~1iZyHZj9f&ZpA~=1mu+HD3#~ zr^J8hxEtl4TygHxc>T_tmsbV!`?Gm2I^;o(PiI*9xUYqV7_acFx2LDco;hy1wER;D z&U7~`Ju6C{lv{YLbrA}rC}y_+A_ReZSYz>sHUW7p}Hwue{;*$F}s>rl$F3njD{Rw(Lt&)mbm372X!K=>}KOu)Z$5i*!lVq4@fw z-<4D9Zp&5EaXD|tyS5uhCuQB|fgA>ZUXjJm;oKIe+J>t9?I@FmWyQcvd#>iLqCre( zQ<{{JbL-;dfhpweVd;TMBi45u9>L@?0!l6|G+p+0U4Efmi;j$p ziw`xmei6`0O>iQ@uR;?Dy|HKeAo4b0$Alm(q5tTv`R|Rc?J9nocH=ZTPa0|6*g-%e zZca6i7I1`q6!2)#VlzdDb1VCe`?NXYoO#fr#uiDQDtbq=tpF3ssLM`Lq+Z}^3tv!~ zPQ;mGAq55spU}gU4}xvcVo-6N#co@1aVyjq&D%UoM8pkWUum~og{GHdDsCN_>vcz| zt0J0u$Ls@{^}lS@x8_?|sd9{1NYlj*eAZ~gkou6_$7t)lD9krKgvi+5tyt465JVYuIjr>aH24h3EXb*Gd;@!fdFEQ;ngQjWHC<^(2VCNMQ# z)!cvKhb74ksm%X?0|mc+j{$CU#i?X8T$(Y{sY1J(nUT93taEd+-?*oX_9@e&AIhf9 zGyBan!}e~gr_<&M#QVTW>H~8{hibLzNfA5D+N_6}rox6A*t}cqT91^V(IbZ{D0!L! zr+Tu%Qs$l4BQihGKTlGjm`Pw|eR{ny@($|?den4TTagDH=DD180Mc79(B_Kqrn6J? z=Gg&iya>XOQm)`sK$uMizS((`nj#ROYwfKGrT8#9+trn%%+B6u$n&gjNk_2NWJUfe zlWpG(xy}(XW7U&(Z=YXDR_mXfNmfl2vB$Wn*Jukg z6f%?#6;>7(*>m2TDbY)|$%KVCEaF4EwQ@1S+&_r4Byrr@T%e;1d zZ!D9aF@Y#*ej1}tfkn|XnY&y@JipVOjL<21V+c0XbKsFUj+cuY>TFv>5{&NPwrD6X zr-d%MIHs(6+*!rGHmpcDzjG0b_*PDQ+LiNtJ{p)>*S;uZAm&CTJ2_RkhPq#G zYI~hik>nX2sfe|4pnS>j1#bvHo?fC_lQFhJRq>N~8Qwa&Vz$I0FIg|-wji1cYYcR8 z<$8WRRmP_8%&lK?p>6Vk%1d0Bf|zN=jj@79`Vu(N2mTowpg|=xr?|rYmx>(+4l+g< zRoldW9d140-F<7(ll}BrtP@c`hueU(8ZG_#byI?uBa2P{cdm3cKr#u|&Asl?Z+)B! ziM!%B4YTY^$d5=NTvCyOVh`1CuQy8IB;Pk&-o?*kS`M^R4-j{re44|OAWUiaZ5Uk9 zKxfYLNl=GMbU@(C7`?-nTk59D>!19$xn;-Oq~-Abqi`v1)@xqBq;xI-uT)*ya8bgJ9((bJ|vZP(gGP$F_~OBzh@D`9iTHIaVM!KVd? zBNUuQS2v!?v!)Zpp9Db(jo!q7LXEo_1`3!5U^*~b5oBCQ!)Rd=9my>*3f<6XJVvm| z74F*W2GhbB(QTVT-Gh-tIn+TYdVhr@y7Tz)W?sxY~oG zWvkZi=Gi-KzdJ7P8XH|N=AHDJN_=0F;mfq%==;0D>jwjpsX>l7>q2(rsi4>a zCwUvIghUzKc5ncTJhfGslqZH$pOu5?6c?D5p=Bdhl3pv`vUqVVx;nZRS!{XDlEIcz zH2~(>raM)EEMTer7qB$T$f%0*x%IZaqxB`0JN}Dnu0k_%O2xG!laPHQbrp0!W7~a6 z!0JWd!V=ZHs=8oVSiS`}!*3<=co&RCnGuyHC8XNU-0op%hKN&z@lVbL?*?X1c?JK9 zmZmr?QwDTC{kFD3>h}-UW=#SV+{Y^2wti2a2lxQ}N{PI+2l63rcG(ygUcL5Eet(+M zzijT2Xq`x>Y1Gl$HQ}vHNbX5dq-+%D&!A6Tw5Z)XSG3c%PBq0o7p@P3IAu-0Q%rpd z`eYfw^&-3qykG-g!-de;wY`J z1_P~*(lt)xHvaHBmzZOFrm!T=G#M^+N7?u<;uW(TOnR)p`s1G2-|^B1z{`2_gfNPW z?lM+9fR{pl;idUM@KR8yVNo#mQhQVeFtW<_I|Ws#Yf$Bx;LWU&{0iu};_T@@l^}Dg zA*=EMW**J-{K^QAN|Z@w&9eIehu(r7*^||u)&E;vP#HV2BKjwLH`bdtVSfEV*ibM% zj9*M|Xzo@Ma+kQhO2bhj+?naI@$)PRwP!wiaz`IVpc5Y%Z_=)R2@tPb9F-<}e4o=H znG2Mpt<>xpeAwilzH8oRj@Q#QLGop=?2a{+xk41C0p4XA&Sg=dox#;C%M1wE+oBc~ zHjiUCOm&Zks!C`6I!etfwa+pZPrf6;^3`_GQ^09#uttugV=%UjV4z)q6&^(_n*m?EvVdBLk_FTGvD7R7~eQLDLb5B!Xq(oDi z0H05QL`Hk`lut57%|pC)+h-a7F-;&g$F1%u}B= z8BaDuj_kT|Sei2DIm^XBQhsTh0A4A8G00TE&Y4oT=tMLc5(XA=#sn!Faf;Shhpi=c z3tPkQ&VvotjiOfB>kpI1qALafD8XKM4HI~VE*S3xY zgJISOAiF5a#0;vQ%B^fGeLbs$5SixoV*c_$kaiE3>klKwfU$tMF`#Kkg3T+6Fd|lH zi(BAu5i#kTi1C)>s%dd?0Log|oH2@#;X%osPOAbC3p|WjCMXCz=stFT;#zx_P%xsZwCz- z{9M0_tfGTYRF{FaFr#V)#tdpb_GU}?_1o6Br}TbE+!L~w5_bLYt4y0Gr;-ab2(Bpd zxLA*d(q^Je4{#?jIu3L6Nf&IL?KpnDj>s$iUo3F_mz$5}%45nu|C6lbe?xaBbWP)oO^FmeLb6R=|aKK znpdehdT`^sV5JRpjtyTKB6wV=R*GjF)Dthe=y!8nSYK|?OOvx;!*d!pJ0fFRtx1_} z8Wb$PweT^vf2tNzt*mvVqJMUVTNQoZ=p7|EbeMhWr7(PCP|J`wEX!EP&JQt@VYw~# zI}XTx&p4biK1nBmLM);y#+XhpdFjVJSAb5`@9VW^+;9~jjW<#3d=EGNLz>KgIZV&_ zbHDV)X`~Pky&4p!v9Aj}^X*>0HBT-EpY*V)-&t8Ul=3aq51-SvD;r&!A zbP{IZjtng-33vwm^(I~Ts_1-e49O1>vXb+31=17ZsuwtXUS%$HdRgs z6sZ25Y7$Kl8Isd2%{3qrsDtc}Fc0)W5g1`WS#p1++OwF)wCDGLhcNQx8|FQG^z ztn^NxRU2dAg-x>(ih8eN8;}B5!3yOSD%$yPmQxyFQ8=bgQ(lE^7r7xC45bx>vjWTe zB>QX^S5oEYFS_l8IE&N)^VucE&dF7M7deJ&E$L(rV(J{!eiGqHKMmv@ z9)Oo)>#b|<_hl;zN0HvLCk@GhlCJxJulwXf@&j_fyH2h)G%pHGl{rlTmG4l6zDAH6 zS>hmXEe<4d7>vQdLnsE>K}=ia`892%QicSC&e`9Jy92bvHN^Di6)W|2nhJ=b(~Z6X zqMFIPS>ueKWHTn>%-%*k{(7-rrB=XCBIEpbB4e>$FDab=`oU=Cpy2%Bm{-iGj5SJ` zu7E%y+pYc-YyLmb5?ZwVfLPo9Db@l|cR}%b5OcN8e~ymm>06k(*<$P{>=eCOcJ31@ zorLvDxy($O)S^GN>P{Q$0i%>4;z^PeRus!ve|3A^^1y?^! z);kBoAc6<6o+Dq4mQF$o?rJl$L+~ItnUvnGxnl|x<9z*8VP5c;Rx4A!C$c;01xZ#l z7jqVd6x?_KFr29*sCKSpex;tzUs5e?OFsfr1SJP)%|30I3a(vpIJ?gU`J-h{oqOv1 zfs}Nl{DXPa?K)Mp{tU6ba7eC{pphcj1-#^~mv}HUJS{lyxG2Y%NpXu zqjU`!SaZiJ$uHT=H95B=tFwqXeHIy(zLm&qLR|$KXLOWAb9v?t^Vn>iGbjwK6XN~)q8#Ee&+&_;Z$o@F<5)M<6fx4cLw5@_)Lu( z-^Q89%uUieor5^o{a(rd!?i2>Yr^5A8db+RN&SxjrsG+WYh9P z?;B+(ed|OaxHJc>;J3r5|3Vv~#P>no%gAHLoASCQM0(ZH-L347AJ3#(7-ajL2vLM{ zJ~1-5ivoD`6I;h|JLkchC`Wm*)OKv0xaTDY&H(E~~8JF!NIcQn3r;Nxd)@P3xTILd@ zO}hUA8$*n+SXx?xzG2Elqn#8t1um?HoiY{(;hP*h<}k(qdu%b(kF8Yal2y%SoNm-i z>OSAj>Sy>N?#P1Je@$KnB7W^5T}GT5o1cFMN4Rq*_k2T-j6neBajJB*#(owMSaM-T zpks*crXV>cbXxwg_9<6!bS$fc9HrGU+Z>-{VWU()%avSJdopTqq91X??J0j-voc+1 zAYRAk*9JLsC|T=WzI9)|?e8u};5_E|p(EehgR<7$LDo~fPuqRCI5XL*F5B~5++*LF z)QU*2IH}i5xQQ8>VhMXQsV_$R^R?2RE-JYoM`ULzoJotm>L`Y5M!DVhSXHxa>Qd@@ zCz1^e*7Gj5e6_UG{luDYvn-yKIewwKg#9Zx{)-9*pz{Cy75{$}BKz+^s`w>tRrZj* zPdeU@Q0*3Bt3S>|Zda7#+Y;!R2=T~s=+V7Bt6;nEak|#x(J^DH6)mZMC3#A4>uV(c9EUQA3;^Md==6h&T}snETx)Wh8*!Xwf5yQE@bA9%>bKIa-N;n zRaOk?s-|yepx*W_)nXa=V6E7B7m16KM^M7fl0c@cDMPY+%p|nB(EECY%EJ%TKL%od zTqRY>5#KGSe}xe+%RrW{IDOW-TGQw@E1zR?%Ydi5Eu+1fOedDFPwp=$GZv?iy;P=U&jp=jV5FA)DZfQwWimBlOa zay>iTZr_k*c7(3ps)IF4@;&UDmv+^Me%UYd@DAa~8DZxNIksKZ3Sg=KA$a@Q4?k!bPM3_1 zLt7NpdGZX@6Xsbqt;-mms#vh|8@lC0YNZo^JUk&I8dOrKy8=;yA*fg)e%co9NX`oIQ)u~q6aI*lUpG#h!ZI<;AK!de_f7_{q2FqE9r6;wcx9i5(> zZnX)xo2Cp>d+o45tS-jJ9AtSrMlVEw6YHO88Vzt7!3~i?rTnM4K*mP-7qAK`(2-*t z@XQd$Ubv9hA#XbxrX)hn25k*VbI7bv#$_#`6ri+OIdq~|aLpriz&hnI>R>`gaFEaI z3(T)?cf~z!5T?;L#{Z6-l1U`Nc#5v#IffdBVaIn+(u_uQdZmTX%%){of8?Es!@M|9$#0!^2rKNAvw&Oy0EF*e zpBXZ2U~%SX#UB2a)d3k2U#u6);3SJmESi;*pl1r$ik=gbH+ePq%D>M+ZaA>;&W6EQ zcPQ-uB~ZHBsirM`6_?FHET6_tmYH7D3#!POdtGU}?8dsMZPPmypj#+Pzzlb3_FwXL z^>nm%cXg1|lNColY#sp-LI$VkiZJ)KoXt!qM}AZ4J$XJ|@WHtbQnqbm0M+Klo9#>j z?fZ%+H0UiC0WlN%xHhQY@5jAWzz?>F z-!QuHXcQPduP4jXvKM^qXWt+@nQ?9`zgEErSNR*EY=Z=Z)iBj+Y z;@i2YnyJ0N9csjWu2J0ku{3NV`zZHgf?x2Dl(Z1mswJfqfvQ*4qvyBoT~-iL!q`X# zk~AJXz!=j{F6djR0TD;MkMf_&+G)J&yqAb~U)cR}El1V7;^T@XYIsk>C9x!?I`!$S zFjx9U{D_E<%6Tl6$%e$27??YaUNb%OAk_cT@V<*jhf3B>w_vF2f~RLUBSczy@RReC z_D^F?vgA+wkJHe|qPP6_n#u9RaW3+BFWc$ZYk?^VxbYu!;<#}0PA(l}a9n@2C!3n` zgXxXd>4PDRxAJvPX(7jN-&=c6-ljxHTT&?!v@N;QEW}5{eDew0CwwE=O)LSV07H8JHyq&8} z_R2E1bj6&nRTYkDm*`pg&1}|cGU}37MDTUw=KNU|qOkWr7Q2)GK{3$3VKhazc&}P3 zFyV-MwW2A(#LrDGHRhS@G};=kUNfY9!6WXSE6QY5#QijRc3$jVE18)%$JY%YI%9>i zhXro-&nphF%E~f_^c}Mk^W%{aPem0mfU`Dp{SI`rZdE}1D=0+<^&CH~T{kbYjD|S` zS3aoHm_0A#nfb^$kXz^&8}sN`doPzcsTkDd0&05;YH}k}Uh4EvAQqMh;}>9S%RIuz z^Q?0K3|wPr0YupQH6%d#JT3n|kdALK57hC>Qoe!Z5v7yh6eM?IbRp+lSyS^{()Xk^ zlPTdxwO=J|*huuRQ#C6+S}{rm;i+2Lt;4=<$()@zuU$HN^oV{;AfS=ej-*#c>u!~F zmz|SH$)zbbNMbBYc^~9yLgX1@71_?YtHj!{A1r3lC9K-S8}6T;!PSI@@{6Y*c5C7D zS+R_xbu4@4B{*wl>;_bYaLmIqXC0I79zF0lm}DlzdA9SQvP@KP*EH8c)sNb9?FKl4 zm_ldgsS3Q|QiGjyFO$KceB3QX7Khi{!}v;k?ko@g(K%WPbMP8`_^joi%x-nZVmUV= zj`9BT*A?MBvdX}@InF9+ShSWP&54VX^ZZHzE5_F5k)Id3h;D64bm6Fd=gx3V~q!v_juABLATefL^8ZAs9gZtpnl(p zsC694Y*lVCQm~0c(>(I|9K3w&7sfhbs_pzFZ|~#f??Am`5k2|E0NglxGvgypc7r;Wj*Co=Vr|$vK+R}N~qh$mWj=HSeku|$BybOP4zit*f0Z;-zSMV50CtA zAl@$$5N8}sMi(kJ^P6xWom>b3BvLHuz5VAgbw(-P&beSnTC%bJdijwIj<& z5yax(NQld#FMGRS51@^vhnRJdFC`0X#YM@0QNIGxKsXw)pF61W%@!$rewQ4w!OsCp z(Vl5C@1nkQO85Pz+LklqHM=$YYS08>%n~)e6T&M`A7LK{S&u z+6oOjb?>7|iBV@FXOJk3J6gH`=gM#q7rB(wl$h~$0?bG_tN8YIC%Ldp(2wseF>#qH zE@78OMZxEe4wH6kZnQu|WF9e780&kJB#)OEX8r4KZ>v!zR(UtT%>sbCeMKz+?+)7? zr^p2g*oy)zl&@N!Ntn~}+T{sXD4OI4z)r;r5yDuOwqaEQgbO=`i6wwDQJU$Gt#%#C!9k!7$|IZPha9ntjI<8 zxg3#Ai5?0F+MOGUwol^AJf6`|BuP~E(GBB-_JIW^es+1~QODc~l0YJCISD3AlkX;5 z0*r-9ZdqH>J|%l{D${J;w65XKXHm^0Mc1nC$}*bGc6yy6 zi+2QjgGd3<5eIpt{@DuDD9}%(+Bwzd#*t%&H#33iFIK)PWvt{B2r`3ZZ( zwl7g4PURMO%OaLdDHadY0?)?HQJKafN!5V#t>GI(flZDQ0;2Z>7eC-LL?;RRM`)Yh z(GV4Fmr>Q!q}$vCu|5YAPq8CUu`d==mfjaXQ-5(KRlc(+Tdrg+Np&P7?6BlxYEBx@Z9v^lW0t?CA7AhJ4!=l z(oCik26*`0P>e@^UP*?BZcy0i@CFRf!qRX#esL@ESph|?Pviz&wvWc72>Yx&XZ(<4 zdVb=Bd=V0 z3po#4nMkqJ?hecWF+58kKtwju`duTz55p*VwifK9pfPx7*OzG+p0tDtr@F6|^B7AJ z{6v4Cwy3LTNr1Q-v2#uA{c%1e=hL*_p>FeRr@Hg|sg*xc7>HgLy|ZPymU`0s>5yvO z{(Prov>4Ak!fwk_rH9ecGq>g~#*1qvP^Z!>JZ7#nV*CDyi{L4KyaK#K|9ii{&j1pN z{jEv*&)!$#z%!{E6_DENhi@v(Vjk7-4no^a)7{c{wiZ0hq5^zGrz?Qm_VE6IbQ?oO z?w_BISJPPj69pIo*a4Z#SU>z9(l8thkbpZpUoQJNvo4G0)b#s`7~wAK(n#@B4oY} zS1lvD2VoAv+!=)SvN*gGfxG<2Vhv3)*-Lz+f*||*1~_?LHhoJ|5kt$*^h9Ks&O{0g z9+I^(SY>hEvUn2^Tu$5tw()jb-?Ux|ubtmIbi}9ddz$Qg?_q(vhiphQtq!7hjaNJz zem(rKdD^!*>WW|ql&U3SM%7K6+LMK*zk0o_sXYFJcI`e9rO`WfgCvfp9jkFnCYdG& z*tz2umU0~2jTm3~v(s+Ka*oM0)qzeGDs@zdBfj=F5TsavYP+w#eMP^btV}}w`6?4G zpdW$lRE|d8jiuaF2n1socpR9_8uj}^A<=noY-fh;Q%+O+l(C!Kik32 z%e`vv5y?v6fex&=^rp-2&u59eBS~rUV2}-!EP*JF!5tk1Y-Mo6O5#;6D=zgR>Baue zo!P!2>e&ERn?UtG|4c1h4j=G%ObJMHF#t9c`^^fKmHI~s;wnafLxP9Is#4UsQ=y&Y z*sI50pYnf+O6LD5DtlfaHWLU8XLkdoFD#r4q<^`uHlBQb`|pr(cjDwP$Y?cbdA7_Y zF7Kn|<}He?5Wd3fz;N|(ZTtp`p%__W$!G&NdKG94#5Goqr^#c-?3&imqJdbs{HlTy zcH!6VC3thusrT|78J-U^KwB!Y3cGqT(SFew)-c_2OiSw9*`|zT^%vxv!)e@-G9D4f zCqORVpz&kaIW0@>w8TJxHKfIs`SZ|f=={>Rix26+@mCl5 zU!wg!A(%Vm2qSs;qMNX+K6P2_;fZ~2Ko9Hoq9qluQA(oZ`xy4@o;t8|VLnG);J07H z4HynHD(0~pLFZ;-AfOw{Rq;zC6brY`b!oFjHgw;7zvpI^fA@acllq)7uYvrVymf4F`7~(BCF$j#*gqoMAl>}8ECiXBRdk_^2aXmeu-1C<<&Gv zxQ~IY**E2xHlsY65v=wPTY;-w{J6W|wPvZ!Lx)E}U>z?QSbpP|VNe#59Eu&|dPfd@ z5)4A=YqF>^CmZiQD^H68I>+faXE6edJG zs+yJ~o=-F47h`B!`Qva-?)(-0m-aRsdQ)W*Y)0CFXp3s$&jai!6$!QKR%0{UU2BWs zzgoSq(fBLCjRy_L@xb72KC$O3Fqg9=Qxc2L^S?0ud1b#7cs9N82x7kA zBQX3BBs*RXuA~72kTz3(EE}6mZ6a72y=#&A{qz}{D9MC-T>mykN>bXpR#DtG0;69p zWRc(%ku3;wM`{5nw@*XF9sy_cGS zBfIF5K1M6}aga;&CZDt$zX6DVs(s;G1O++^2{$Ukx3)a9@E>4#c4~j*scM6xwHSo5 zP!}U$q-*`u&7FVSSY-#Qu#UzV+Z?4fBBh3p#t*2#t%;zBYnpNLT){Hu_xcvZ5KA21 z>Re)c!%`#AZEHUvv0yeX7U%IXve!!|dM?7qa?G)TBdr^`h94-~?!gEp4jxNr8MM-f zWyphb-<~$>H9uW06sG|ziRT8E@9O!jRuhbn-RvZd1h^vRT!a*CQ??j#!F6){?ov8+ z{648GxvRUxM`62PQ!t!A;q^-nbgr%fV3YkKX^v>XCz-dk8R4W@i6}8b{sz`T2Az9h z87JrcO#TH73j;@?WH{i!%Ry}%j5-y=lLD}YPtzD1v_ToOCingZ2asGJp))LbjFK3W zODa)(M=I0>^S2BKEQIrDrfPS);K;en{>{+oQ@ojL_S54E6XR%?B(zDa;@Vt0JGgUv zLy&p-+?Jf5b#wSyPs+KIDo`bFFkuIadR(~bYDsNiio0V-`i{7CJILF~VI59AQK$Ed-NFCVt|TqGPbTs*7{;pgnxtT}%SET6vkd3H6{ z=4W7&Ku|rRPx=gG=K^GfUw;zDL-pqsL8BXhYE(=`?6%Sdb>DayQN&4x(0I7EzC0OlYwh7CXg$N$DK3}x`mTr+DNWsJFW11{Z~gnuU^mbEIFK> zUHZ?fw_ge}{HU+>XHr{2P63>ml5n*$&qxK5ItER)#g#4t#TIj4&p!B`><+osqx|;A>6aaC-Z$Dh z?0q*@r&oWsSy}tlGJ%id@WhB{83)!U7I6?@L6Rfn<%A$_Objf50E1)6{bTEA&H^W6%U zB?&9n#TkAp*6vb{%U5sBHOI{X7DwDxlUr@=oO7BRWvseXO%_p_0fr!iBKN!bKecw8 zB)cFg1(IzCR1e;CWK;#|RFX@#g>vUsw<1HQn?w|bA0>9G6yDJXHo)k}y|kD(a%gO) zIH8ImHs`Lg#-P6n(u*3nc&mVmSN`Y4t3<3a6q&<1k!0b=!wq7b4oqnUdUgv5Chldq z{s#474(>StNUu1e_jB5}ym7cETfoJ8V(-AA*H9+GXQWqBW&>QjRTfTQduVz8Gql3u zb`OWfW;NUxI3|f3e$)7lf=Krb;q!tu7U0s`2xz@*YR~xw2PRd5jyDjC(!V2iF*lrG z{FgdLHxLVxfDX90XJh%|-P)0@KjI<-tnud+jQ8zNB+B!+pq?`pH^?r7X}LbNC$pgt-v1|(Rl&kE_-N`g)oa0n2*#(!I5iu@T3(R)OWdKl5g z3U(s&rQkc1bILtXWi}0F@?-Uar(W&1EhHhUqnqAwq2(*UiW#W(3S9pXgO{SM#;fp< za(F=F$P%OY21jW2)3n5~Lp=sY2N{%rWd5=qOQV50eTYzqmU+TQjpA~03O3&fXT2}C zf>n^GdK!kwG*8*YxiNZ4<5k3hR|>!;36_CabG$YU872Jz+(_&>&ybFHJkcNz0B_8a z+JJ2Gx`fom7oGUS#{axx1Ac$T2aGjSfl}=K-1j}-EMw%rzzGtl1s{L42AJVaq8^kSi%Q+B7aQN z8ZQisGcdf5$|I&QEc6m3^+1y6_lUzHW5rNE--JZAqR5WSoUJ|{8ZQ=2K#4qnr4TPX z3kAsW*ws6S+dwoD^;Ty@zjdS~ZC__=0xa~ZX56tDfPX4|*&+xJf(+T?0d=N*igl*# z{*GxekEED>rbg~z&#zdpG)`rJ)-Ai6V@wu)?-em15NFGp?gmT9abOD(+s;wCV?<|D zZLOk0tQ)6E*ap0c(9s+RE;5wh#|lgQ+iWB=xkb(J;9IrW(cZgmnFuw?{uY1RHQP~* z6L`OIF}W1vjIy?FdYcEppBci9lU{s~P(<5inn2EqZSiT8rb|u(@>H1M zMx^Iu|A)2j3~OrL)(xVfB1F1?5ET&>Au3HNiDfAwV(bVAS?WTXn5BS32?>I9fu$%c zL5Yo`l&BCuN&+Mhmn;lTkRYU~NS{+7Oil5A?t9ODo_p`J&pG?q_m_&A^389w_kG70 z$@U$Dwt%%@Bg9fNWssb}yE06_TsC}ipu?Q5&p7}o%V!(XZJ2W@wxX?Ih1MU;Y2=YO z3;ogD61mD9UVkA+FX=@?PsUcd!|PgNa)D_IdCs*RB(qKi2@Fr$!efE&-4c1Hp6)3! z#Q>sEo3Csu4YkT|arL`%hU}g6rQl}M&}UWa?+TMuwnf>D&(7!;zSe*O-^FlfT>bh7>bR~Jk>~sIaa~3gaKq$> zpY(HH4}aVX+^}ivmcG?|!*5bj{wE}+ZOLWAGH^@LJ5+j=BRMn8w|TYcTYw?(!vWomYkM2_^Wy_E+U+*BU$^sBcxFAw zl|Em7&d9n6ngV{}g!g6rY|5u%Kh|!?{qja(x zC3LVa+)lAIeKW53AB7SI6iRqdC>@AyCVtsQ_Efcn16<)iHS_CTJpcmJe};1c@YMZF zuH5;7QlwNe!#gROV*tQlf9RhLK}3)m1=hpBMBjmwHbL}yZlusXFb*OLZh?7BY)e+Z(5oca6!g{ zrp^}&91EQSkDzaN@lHP(a=x|7@IBk92}x{uk7-`9rt(~yF4!3Nv;n{2asWD4@6TS= zp=%c!7yadqHfAJM*cO@JDi7|cUmr_{N@Y7CtE*>U^fh?77TCi!kN+6jKDVwf&yXIi zxp?)>p8f7y{QsJt@R5F`;1dwYxSt7I+42JwNCbCs8kAH&{Fb_CN&ROo;`c#kG zlY?H>{yg%xr`=ByUW<>H!MB5t225GlaZj)JYPlCmUTU-VoxYLkDaQc?T2 z+Eo8%z}yLhi;LWLe88OP|3;0p&kHFnendE1?>09hZ~EpZVNcu*3p&f^XAy&n@5BY|1M0%gz?|EmxoK7G#>l(P|U_ zV(4weDSh+oxb(sa#Zq(Z`oH0Ksjr!oJwdmQm3!=|UR_q`Tzj`h@9N#By-!lOhue5U zUNF@PS%1L$XzYusk4l4UutnllPV(2Z%jbVBIjj5ESF4SsnD#_o@$82FqxU~oo0^yaM-mw7>LP@G`I8=-32r5{J z+>kJ?v)18^UWM{D{Nz>JZjHm{Vf@?=%c%it{(f{sSyyPaF?`?o*F~lqA7!<+jJ~;c z>M}h)P_^=Rwg%+1m=^YF6PZ6tTz%V>vA8|u?@*z2ORY-ceDHerT&QGZXZq-&`d{RB zV&cSA5mDVMu$=r*LNFoU?B09+zTG3A&(5*E`(Ny~EXvF54)9nCjQ?rK-^xAMv7mSv1bmCsG=dF5Ox+gMp!{K9E7(YJs zpC`5dX)>(-Z+CP3Cw6POK*ewo>U~a zV+`@X2~mpOFMAz^R(mKglE$4e>4W7vTfO>np9oL7c)7I|KYlH`Jg4X4;qZp;mfpay zY;E!1$HjliO{e`*fPyXb{tOz}y-#7*`ZAHS$I0kV5lD^$LbABM_d=1oJ?lz+^P*sb z!VR~d`%o>^4@ZR_<(@uuy+nXNCE^<+*@;hpt2hT-g`>$mSGN_mtK=&J^w9e@=#QS- z{H)k&VsytI`_a=Ol2yyWug=T7vznbpn()9`P>ABcW+x4%Bkf_^wEyKS?AE`v*~$F7 zR6p7zY;()g&`Ywj?yr(NPupBd9%Q zeER90yBD_oRv2Zll#jkPa!9*kZfvcOMU4Np6Ya5U zwk+K!xYgafw)ak?JOnkUd?0r39KX8Nq*~KO(y$wZ*poj)tog8BGoKfokz;dbTyek<(s z#|0}~LwAo879Y^d_^6Rux{zPdq<&xhCRuv(BBA%D$E@odV?zJtfZy?%siDEq(kpDI zzB#;ZBZziY#EZwl^j5?FqKN!Y?d|7CwSTw6;(wd_KO(cmeDfU|B^I@-vq7_fm%~{w zFu5-5X|P^(=^mz6BntHz^`T(vhr8LcYi`C8+&+8Q-1My}%B#7g^b2QA2R!&`p~0*V zhRno4ys>%0}UD}8S%$P|H4rt=y(lrz|-4xS>jIak|d2b6dOH0Tksa3i| z$=bfh-9Vdae>F%f2V*WvLi*;`zUdB`E^oqLDM8)W2A$lkgk<7;syPC%fL6xx-~u%y zN))~}oYWd%0~@@n?5@giHq2c4rPe!7@@eeTiH(tyxHqQv+>iF254Rt3?4D9h4GVrp ze~JN6f*DC}LH6U;)Ztr5ad;Ee#^4-pT|Y*8RM_-ViepbyU`9*&q|yGyTyEXhcl+;< zwd;$>F^61j+U|sU*sIMFC%k{4H1t&*A+w*0MpIV9TFIFpWg?~GY}m{$#d;FF(@h%` z-D~?9ANSf%qeB8*JEN>iHZsfih*ce@&}lQIr9PoXq_E7}|Y?zk9v8Iz3ZNQxT*buF`dRNqibwUowy+c`>5TIq!qqxAfg<|4-%Bn`_t&A!5KP>g=wXL%5AWCzR zpPn3zIO*py&`}cnJ^cM2w?Zb$-&cjIefTFgpPE5ycA<$F^h%OKznv@8b6pQvHT^)X zaJ4LXP&5PQe59tTQh2e+qD& zq5|5?9{f3>!bvzE|9w@7`Y3ilQ>Cq^yv`2C3b5juiNBzFaq^_geezdH20x`d5l zTF9|NWX~JIQe+nw=fHAqolB5O@-h%{mIZ^h>>bF(jg8% z8&UXIiJA35`T2z6KWF_+KcDiMylMKR2?yLtd?c;e7av4G);EH==jARUd_2p6yoZ)> ziMpf_c2S&!rmse>V@TlM;dKdn{TDQt!lt~e2+K-@aL75OS8xA`oEVF9b4i|wOq6oh ze+dHrM+EuTB{^s=2H9GvI%Fw#r@d>2uz+o2aOzO19W>FkA1H_*j3Yva&;o18G(Zsq z%aHfvGtKw~#qd-bMN_iX)uH4E>O4D)S4ORg$-glFT+p(=KE)-j zQ2%}t+_+!CE(D@b`4A6{kFpiqPK{}F3p!D?9I=3M#nH_)psfoAFs(6^Ebfn|8X=zY zfJxFU3EAVSCN8&Y$wSKuzw9`dTbCs}o*g0^tg5c@%cnaA#;+9Xt9J#fBfw=RJfq@h zExTd4EKHeiKR6^KYN||-1PMLWMwGo7qeD5|Z?v=92HS&&m5+ll=nQ4ahNZ^?Y-}|( zAL^?^K|DN~x)Ow(ZR}9OKxtbA$&@>62GJ(&$bFHJ^QbDIhS>mRT~%!u{%o|Q#6stD zfvx!}=r>X7;ZItt2~~HNz9>i0N{QDR4m~7GTUf?$aS}uC5Hymmz&|2C+TLpc&NlWT zIl-&?ZB^+jXzxJOndtfB@l@{>1yyRD2Q|L9gS&WE;R6$rsSBxp(H2J5kCzfODTk1B z7z;Y?YN~JUefZWEr}w!)>p3)=@$Gs^ZDr<&Bv4jVeZ(+vdS={IxbA(3?8`4|Ux^A+ zP;$>7R;IH4%^6_tlhDC$zxL4?RvX@)2c${5M2}c}I{1fUzO` zfga!I5HH zwas>gy1Z2Rhpoz*NPSJKjOFpd?Yz5K4z!j(kW(71_gsjB${G!>A3-C;khMA7`&_@K z@<9ZHLyL+^{lx9TPh+MJYINOFQ~9wWzv*xL*pv4_c(>RCDtww~4D|!Gk3T?CdF9F? zfraZq=>U8HGy6)^hf35H_kk09O8;_`Hb_^!Ntarwit3msTJROD!W4AQ&gZkcX7Wdc zvZSxmk?oo|}s!j6XyL-ueJZhq4RC zPfQ7Q^N%3+9)7-pPGyT-;aEm$d24bqgTd6o%bl%bHQgPvV;>!?{rVy3?%sU;4dLx5 zYEGxdHyOBqeV8vdu-E7^;M=s>vk|J!qiS>R3SEwB5mvrf^$!1xFrk#YQvzri>Jlus z+=Z7Lu*TdFNj&rLGmeyu+dv*^{vIu(-oYkDEw=HNV>kj@fyoz|<2e6M1Ks)C(eH=@ zXa4b8RG!dWg;8}07ZIg9kaVa|8c+wlg9%(~v#=dsDehwb=w?BdEa?t9G4h*jt{lU4 zPX5F23wp!&tGl^6_UF~)p4&0kgwRE_;$brAfXMo3#=WUg+^>*Zu#Ag2G`uL)8>@}4I&gXc@rK#hG^pe3NJA_5n;M>w^ z*V)j1;=4JCrRsqm>jp&dfXo|9PQHmNoNG>Hq7(BPryg0~_}H-_uHHyWfCwm(q!gC>BIK8eAlDd1pr^c_CA=*-zmnONtbFP-(b_pd+O7OY-$AN@t8 zY;-*a;JgJ3!R3FY*xxy0J-{eaZBV_%=_&6j&{3hP->f(R=CD;VsNQ3a_9XLHI9|yp z$Yfb=JmyV(bRqiULl0Y%IJ^%q#BqL{%v=X4mYXYrJMC-Bsap*82lw?OS6q+shUy~n2iPw2MqHEc>eK3YR6oEF8ds8 z)RJLw3~b8Vz2$OwkX1|LPA|QdOK(0*4+BQ|F|>Q!I`KEB{DmKm-aLqY=ZsS91^;)P z*6h@93VbbXWlp3u?b_lq7htK#J2eVzMse_z16}*XsLAa&_X3~t%R+v|G)FgO31VcQz>E7)f?)?Xr-LNXm{7uo z!!ce?5Kje|TLN6u9i20NC&{U5oI@Q6W-2Roy4p|br>jbjf@xkxyx+lpDj_=*v zVH+g2*tO6i{DAN%+;``EcYdR9tj4~0$rluQ?CXKvNF|Z*{B2eKxZ9C^Z#Paxnb{rb zsd&)XGi!#E>A$RGJ#VPKY%?`6HCdP@=^GpNSXE%Gd*a@Ww|~z2h@$08D-7kT!wh*4 zZD4N~dzOee$KksxWqtq$4piR5Ph3;{#9V3OG1Ocrcs}d!$cAFYW4dev;4cr6zrY&y zit_E4!fGNEF{02fYI)P$rsX6%|7BzO{irv%xXEW&=@VgXUO>=aL-IT7JyjRC|&Ram?yS z8mR6}y}Bs;Ws(;_2|aDXkg%xW5CnN#d*`X?#dtkS8N@hkikU#t$o@P{)WC?7o$ko))5 z)SW6tk`MYtm?g4vgKfmWPV0HD)0lQw=p?8#!{leF!|dwBnkGW#CE`L6v{9%@xh&Pl zZc;7mbH!KC!jKCyhlB}3YiEC;qF$xmEzy{u zDRhalCeUnt0UWP3INr1Y{?k}GmxdxrigLw9U#ss~;)5~sKG&f+PmV<|)D{{z5Ov=_ ze6;f3bN#?T+Zi=PEVrc?0(rJ5O9&ms3)X(`Sv|+YzaTb~G==AQxyn0mI>&q)Jaqq$ zg!(tCek5Y^FV>Z>v{sU~Y>C6XphLlYMFysZri{Y};gwqzq4&{~=l|On*1x_1;GenP z-@!L{JG~h3ZUy^2u#=i+B>bfat<~_ju+ppJEt8&774G84tf|B3v&?te{#w&pUU522 zw0q-?%Uuuu`uNxC^MW_)K!O8~(gHf8N;Tr36)P#$KTxmpP&2Qjnd`dO-LObob3&Tw zuz1CV`+}5|+M~Z5G&r_Lf9X=S?U>Cffza%M@(%vDEP<0$$~S8qX%Qxr%j5DgHPu13x@sF`hq8dR1u>EeIr)<~d@5eM zVQ+yg)b>PT2Bwf!|4vR?Q@boQy6$XQwqVR@nb+_Ae=r5@FJ@QOeLB(Gsqqd|ovbhj zlC>$>u9{*(GOemOO<^jbX(QIHbSRG;E!Px-_37)MoEUd^?~UBXmIOWY@$>gQ6LIEA zyDZ<>xcpOX&5PQ=uQsdg)s)L<&48@IT%B#9CCCCi!|2Gr2qvzUcr z!z+5i?LRAAp8AADU-C{b@6dno-i5fs`A@Z9QsW|C#@*Mh2X)=t1V~&LJXdB<;IN8) z$~zP%33h=$@~Bm{s2bw6c35zz7BDG^)ZpgUU{sT5lolB$U?f&B9yBC<63lV(DsrE+ zE)^*sxVD^7M}mM=3{#tET5M4PzWO(!CQCcix#|Z>lWIZP+=<(SIPL6bYP@CA7Wj@A zSi)J?W-*Jr%1&Zx!W>Pg<)Ze%4!y&@l%Zcff6vIFKOu(J72Jz?Iuu6>#Xux_rovk) zL@Y5A1K=4CHXaz~=u!4Vw&^9reP2&{i3y7oUU0x|asDccO3Vu~ZExBj$K;$R(`IH! zw|l_*oX@Xl!9L(+ZG?!;oT88@djoRc8;@vXz_p=hg+UX*Yp!jVJJSXhBf9~d{sYD7 zRh#MscZLQXBYg9~PXY%Kv>OHr&LjT5arj4#<0hd7aYsp zD}m)N-n;IbdfxEhj={V2YAL^J-;BfaYgF3LexPopQr3Ww;Dkg0r4(Hje;+;Su3EGU zVu+JdXrfz~7dSv5Y=z8UmJWaZfilSZdaTbCBc3E2t`DZVQV!RoycY(H_Pl>{x+ZD4 z#g^BttJ1dSE=s9VlN;YxI3N*XKlmwfrpbH>^r>Xk&G(_cAg{GCSNL_*yon14kvYzp z@2@xdJN@r>a_@`x9>%%&q7-XEUHJ#?qdwk*HW7nZfsf_RiBv<9f1nn!6?WY$2MP!b z@udp0e%I#@72e1ph$yZu3nXl@?`gOoo)!dgoH9q_Pq>qw)Qhx)*!F}plq$m267FyN zfl{Z=SM?KLM7_N?nMR3*@y(NVyqx`Fi=Jt4{s2QF(}{jAwe3kE(tc9T%986&gNA=F za`NNwkIVgldtWa^9ITHuzO0g)*TA_Fqj;75_=O2UAXtx)FUx|6$qJiGC*ppS2LW_r zF@pQBO?~kOZsAS)XcRa*Q5XH23I6;KlpIBUL;HRKdAl7W82WFoQN;YqBt5!~fnfPp z8^U3XYH^5sJF-hWlAt&u4-gErGho3J+f4|-B zb7Jshz)+Q8MYZe?Ld531r=t&|Mbom25MN=iOXdzAcqt`;c&srQ4du25tm!mu5qx5b z*>MH{Q?zmtolRvGM5^nv_VTGfi-jdbaOdWe63g=9EoR$T_@-l*%Ixtj6c z1*(h-rwaMS#Bb|0?vU2fLtp1FPC36Y4sTBreefqr7naJ^M?o-UX;K_Phc%Xn48ajC zCf@1x!erbM*!_BOk3vm!Dq1=|-f0q-^RHK|yg;eZ(A}!de7l5=hK^jPCdqMtZ}AwRcDo zf4lv)FPYEj&8+!;sgpPN?(e_RHetSToyJTvaEj{4N?I`EU9#*6vN@>O%-sj>Z<0I*+AXYJ+tljR$ksm$JW#(w^1rXwkQdQQkKyIr;+vE zO*BJtr7T?eKw%A3LcDSbF+qjzi=rpsbt7X<_`kri^b6q+hQ_{^&m~Qk*-v5*z{=c& zsPLV#@4r>mRP}t!30ZaYs|2{OJ$Wd_0`L%2Ao1Gr4`60HPK~VIMw@rehRM#tSAsAW z?#UTO=S{VHf$M)&5fuKY__`~$Xw2yAz&m$|pEX|#q4`6C(C9w~-dh&Ee7qATj$h($ z$NYtv$dX?KuX_X!kRgOG#w1V;kV=j@2F9lR)*nR&(3d%G5xGyg?*)9dvZ~vb;{IT; z7Aj7$SGphUshV_t1C4&?ggAr!4aHt=_u2>jPOh6DBm=-eJb+f4&(cD?ky0r(u>kjW zmTjPAwW|^QF>3)xN~wz}F3|ZuziOIUd-TqlZQ*%j?dn`z+t^4zll@(HNji>y8IvEn z+3wpP<=H;iiJrkLGw^5eOH^(27vPn%2J)M0UW5wpEi{ehhbO~c4BCKIeel``F_$H1 zWAeR;n;tn_B)3)2_OikzuC`7-k68Fe-OFW*->Z+-fkSnmAsZPJ3^@TAQ7yS3_eUz5 z@s-Iu#&WWsFOu;1f=9JSC9`K5&I`SDkctk1;w6<4HEe;8J>DA>lRzo zGV7VOnR{)+i+{;md_!`>;B8KvTSXlHZzI)`Fu5ft8$o6ipF|Y|tc7YOI^;XZxtuF= zlU6Y4Sf^sgeTp%XQ5Kx{CO1Z^bs)ygbKl#@X|0p*LLH5MclHXu9CX2<0e1dN|N3<; z6s;JYY(Z{tyWhIO^`iTukPCmUNIN8re16s6Z23a(;|qLF%zM0SyM?}5CFsJZEoMUz z$rH1%T*90D3RQAxnm7&0uSl+V96w;)WMVVi2yU{tIKwsYk?**n(1_|1@IJ)J83_Np z_O)pp80H`9nfmlRC#o(@@cqr@)h8-`y}TW7$I?=OjZg6(seHN?#SWs0-sH;9A?o7d zgwwqbARg#fh{M^$+U-d{(H8}%5|2<&k89gby{hkHhI<~&epCBLYQ=}e)tge{Fpp@^ z0RX=Ct2Cpf_(7WN48-7doRM+qqBr&M8BSd^H-$oiy!|>UmR5@9Yn~$IY8dmRhvUG%P3YLU88J-tJz}B zS1fFEv0`@~e}Df>toHaXa$I^TQa!h$E(3eqY{SU@moI8J<+~q6shBj;Gh$_KY6G}g z^LM|+pUt|)(uT2FOnMS)nKFlJ7K}56u*p$0z45xjTn^n7gmhcd#wvg9*Kw|vaA1Q8&Y*B1jOHv{Xl`r+L9#gzQqQkv+J11hl2w~&T^e%cD@F~_WAtR&GKD4V*DP?#YS1is zKQ?U8-}*JgH}O+?1^J3Z6jFC@DvSJEm%^hc`1=t3c1g(G@An&f%CC=_ydV5lUFpYP zrxEraQ$JQD$0=e(KTxS)ekfcV#~dfeP!pO@(pVJ{Lata>BDeH6;g-ga1_i+y*RhfQ z(cI&8TJ#%BpVnjtvrPJ<7K9}%H9wHQHRM{-n%}iL!hCvMT^@xFuk4#%-7^!exu4w^ z6}$7-Po`#e`$qo92NQ0*OXE&VcO1#V=E>K^QwB{M81lV%8H0 z-hiBYsJgq#-@Mgqm0m!=kca->o|B#n3Lh`&xDXR_Av`cdzdxdR>3wqps9x5s%u{V9 z_qB`J@v4=>gNXci4|bNVjo^7K6p{;Nb8**5BgY}fI{?xgUh)#|%P;cVmwP2+ zI-%!e_45}|jdeNJM?RHk^j3j+rmL*Lvo*>pry6-Me6d;6lvO3(Fa=W#-O!c1e> zerW0e!{RbNP;OblEDOn_r1j4ebzIgt;k#+-zF92lqPZG8m!MitcH#(^QPdc|WO{Rf zbx+SRNXGuPW^vHd(J!ty3g6ZZ?IQhd5wiNm_MAn+4b*@cR0s|SQC~_iMhbj))VQb6 zn7pvP<$Kn3`$ajTfZ*dehveh65VK>@b^ZCj$~X@~zxXN(LjKe=rocLzlTaXQzTU4| zg@C^w?d+ganuDkavlr%aSLB|pe|8Q=Xzus*0Z zZ|jYr?GDXL)z>ctyCF4JCcIjCJ$})LWtZpfF97W9W+q;TOxxWEsqU1G*EwcCAy*!w z?}RGoPsT1CHv-}cn<{@lZmzRa@}zBXT5Qm<8ffZj#rW4zL1eVkjo>=l@~0k4-i`L> zE<>H`{5ho0-M({>W7Eog-aKEYp@(l*c964lUw}v8jn|Jaw59nE4IDG@+>FxOZXOQh zN--QlCQCPqM_=4GvS!!Eoqt$IW4NHbaGzg~N9w zW-Eq2`!dVm_oG)b-mhsyT?q%04p^TC9b&)xB(6xzYK?V2mc~Ey*8UE|o|s59c4%~9 zY8f4>>vr&qiS_nCE?+JVFf}{S_NDFe#;M}O^WjC;x2@Zairpr{r-5sK&noQ{@zJ) zlDXvj{jNnaCy%tymQr-2m{fDOzDbIMh?cA}>Ib7hFgn7G(}DL9zn1UE`f3>CPU&I# zb2ec`A;-PFE6W@7_McAV9@_iyP#o3=p>wVzF=Ifl@3P>2szpzvzaBR)H@SS)Wqs77 z6K8ns%f54pZ53nATiyt6XWn20kR!N`R~#Qjg=rNPN8cYm-WNe|yiLgwnO3Qd&UXYK>Z&Z zUW(T9jEb2zpJTU9Bc4o>eNpBp{3SN(EqNMQ4ZAK^Aavhuh1)}c7nCk_%-8BGFDLFO z8m;agb1vqzyE(ROo3=fb<~g+UOLyDb<^1S~1$C|^YBNB%^gpABNj01mH~TY+oc($T z*1i#5`mVfX(DMoT2-lZ!tzmcY!!gs#4IS3pE9RwzCk<0p)xNmJ{nB#S8#VF20`ShA z@qcee>3VEMX?v^@p)}THe>)ww#nnw>rruhoogtww3CqK$DmF{pY=Wx1ESd2S6ae)&A320%Py6v~o-mZfye zVv2#ZQICt)#VrgV`*I}x2@?e$!ps-GgjqKn8^!j0t7>bKw&YD^lP+97<94^kaq1bt z^i?(&?wm*FNEt17lwv;sT1ai?uAMWOG|Y;}Fom{QVL+a2GsS5Jh$nTXq0to(2-I}4TrWMn5awf_{pP1@9)NGBd6tUMExRF zcf4%8DPVbz0)JUjdhZNZ5Kz#6rRdH%%C_R+amP}(JU;CdX^m|2$r95zmvqni7`dn4 zxX1Ar&vx?p$)Np-dBYNiJmaIAmKyFII(Z%?eu;v&8-ioj-qkV;LRLl;dPPWpVSl;9 zy!wY(ZA_+5A3>YkOxY~XGOkXboJ}$aYX-k1pE)sfuBTZBHrZcpJ7s?e6*cpJ z4DqD>zhXf}pfW=dA`b`_U?;Jspe$Joq62F*!74y`)kKV{tl<7hPbndB*rL8JSN0hB z^ZRw90PQYzASvy*;j)3@JLToJtKr*n;ULfKef9U4zxytruDDNT%TFlIDN`FPp>f%B zB)0*3^l?<{`WMb>EZIA1br$~CsmCQ;h zK~FGNU}dtR4z*x3m*q(w0jPNFUw&l$#L ziKEkJFc?or*n(UB0!h5z`h=X_9AJr@3bIP_ZmsK2v3209kNGCO46{wQ{6oV?gwMjc zL0OX)P(+i;2x*r4DSQzcoG#|^=!nNGT0j?BX0^EC+S@=Kh6#UC>lKr53QB{6>*tV!Yw6V=BXJxrP;oUCT5oNt=ko+hjZKdnF z`iOs^-tpUr%UH`X3lx}c)e?l=#9q;G49aa`Swr&ACIn7B*6_1xV;#iHs-PTJZR)0w z&WE!scCYWQ>cEP>3J~2_>SKiDE=rX0Da8XMPLhSW@_mY3h^crw35*t9tI$H6M11~@+EbMc$B!1oZQAXTm_HBxgKL6BM0H!tQn!s0ayGf33hSt_aM&a8BPCXA*%It zjWFdtMn}~_*K0Ubq3qP9tFw{B?GfI~Q*dLaz#_ zKU1_zgw_h7En+#0nVTS%_XEZQ*1d$;Sr|@rUD=hpZ1hY@!|unUbF5W)B6STe%>d_2 z`4uW|!7ON%3XKL4q1Z}cXbRxYc`A(JFfstmahx?;t%;~HfPfQHsH;wpi+Sei-H{|s zYD<~YQ(RCasjyt zOU1NFOUOcYzbg-&ehH(E7ds%au#>pB1#q31Q32r8XQz`?DC9CJTEsU*eA`>=h^drq z<)cn;aKUOOR47a&Ri$fAdhe}6eajWoCygZ-9Y2KyVtN6#l9eJJP`@a5f+$}VYDbW- zqyCLqhT95O0e>nJw<7yTGUNIyqdIl^nyY%b7&yp!x1Xdbu_ON!_ZLWi-icBMpf z=qzB~c68cAzHGuDVxOj`vh`V33gefJ2)mHnhcP63N{q578bOk248;NtYHFlOY7!c@ zl>;7j5w_Knk;t-x<`Sc_mINR*Elzo^1*@JX@944LA(7*C=;#ygKGRPuzw6?^n3f&X|T`pT)R-nEm$!%Muh-f1vC3z@_=z96>+4|!P&6Nx$` z)q?lb9$iI1CoRO_8AMBD5)8?^S}}`o%f}~SY>Uald{~`x<-NH%9GytDMmz(cH@OjI zpSyPz=_#L7AS7SUHJueGbPC3d7K|UDbA?QFQwCNtTnb0~CAG^I5C^0@p|L%7Q9u|S zO>vh;fGw3e__LbtC}9yI5}J(O2Qv~?E0FBwWfYIjo+I7mv+3`c*6hVVAv}3Agt2VF zw7^O1)XGSt8RA9sh)`iwGMAR2((0#$lNN>yuj^868YOC4^p&~#88y=~oino~!ug@X zr7AOplh>BlU##7NykM&Y>_k+#SO37py4=PR~L=j)ZhjIYI zaxf_e!KHMO@)Hg#Jp96@7a~$ge+yx`FU1$C;gm;kyh=akG151>dZFVT_B3?6+EH0n zJrh-Oy20o&KqS>9HsMI{Tr1XOkj#_ODwQn!Z%R{+$?>c392mj4fhfR=@NItlRQ6KJ zDwxlm^A12E5!m#yD1w$^B~l}Dv*P6?rx!wt<=)p6BoXj-dIEAxoAc{Y!7ZZ-6hA44 z#&nwWhO%1ORmJh_P>dc00|%wL65wOBAaJGzpbj2%OyLFS zqPMIJHg9<4Ga%US@aANXAK{1yh?9lBiMp9{@jMGJ8xcDk851S;bV<$HF$UVu{ zs>Mgd{3XJ7WDPFSh{;X@X<0XQtuRz&*#qA1$nHKs>!lQ|g}kphXkD7)0Dhs9aRx@G zmsR;`xfAj|Ya45RN0;M+gz12YnVu$25L52Nm8pyxpj&kZ?nIZ4 z9*Micm;}|S)dTP#--5`HB?nVE$89Ow@1v8z8W25MeX?rtkT`2_x)sk1%5=b|;mn|l z8}QC?abZ?GOB*mb3tW$g!mZo>@Cl`A!=S2Dt*}ZzAH`UXtTnw8MKl;SckCqDDt2BS1am)GWLzW}tV3K<%=Vh$l2IBDRJ{>_fJRC&Lb_ z1YmZmf>fy3gJj(I849j;!t08%xuY?KapdGAs;jEc8BoN)#W!QLm?VKZ&xkmm76N!t zbHf@ieOzUvaO%Q`#oz}X@r2qcLy)nh#(;>F9Iy&vBsQQKioMWNB%k{nSxqpcxMXpi z>G8v_V}MmYYO6l($v|DkPhzB6L`n373piLT1WpFruj>UHp^>ZjK(rB{DwdJJjaU*% z1iTE>J;C-d5(ZzyEC-d?12HibQz^X4Z~%*(b;@Tt7B|>QwXB-IM6qqBA zBR@x`+C%7P6z?$kL4w?qvPPNRU@SjImhXc6rzh&A^fbCIZqvB=VnnB$657j{p`{Nm z?*z%lhCe8nZkEAk>dHJ`>oX+Qp_HGLS8=tN?7rhA=mva>2)(OeAR8K|sjD_A_P`h* z^y0M^Si!&5)uiAIDHoN`U5!PP=f^#v*}HY_NuVjFy*1DM>g3s)o~nE;+iz7~F8eAo zJv(-`eUcvBbSKJ#VfNt?>f5x80z|*lGF~l2NMx{Ffg}v<-ZN3X0=LzhOG-6gh4??B zI6Mdch$baXYC<63w_Pb$J$gc}Z^B`LyGW#{iNmekUo=*BDNM!pbVs_+?tS zn6I__0kC5lkDmb4P5vWXATP8sOorWMWpD$|`kC^%Y7^qJ8!m34p()Fr(~m(z#Xtoe zNCpvI*VXGG(k~*UR^79f2J)}k{0iEBlz8`=TEsIVj8-u|Yy|B|W(b3?@BLpCEs2DcAxjtMYD_H>ix@ z72XAA^uv|U*u8JkV;+Weg$Viz)V>YKH?_j~tpzKT+3Y|JTGa(c^H~93kEU`k8noc) z6yQV4s%QzGaFB0;MBkCM1R+ACrtfJKtK{b42;tdu$hcB z%5L$F2MT|XH%4N$5RxBk6vv#NhxE&L9fA(zi`)pUEG=`r6H^K|N!XAlHyVX0r)z?K zTGBiOyB`|4PF+W41DwaEkp1#4ZY5dh3E8GrjC~z5>NgSwnYeRkix7*JE0=B;+BEgp zd%CzS3fS>j;8RrkWZd`9hPUUN@Ia^`Do|}zzL?<;oN20y=CB7iG8&v5SFVVF1#ak8 zs*a&@YTZRkU0`NstGTEP8jVEDl2 zDmr@f*A>{S>=1O;C1<0i>9o8cE^&|~#kXb|AvIzKceW87pO* zA_?w2dr6LS9#GCBIfiV)BQ{)5TwMGfso9=(kb7^ZP3^DfSNv=EDyLKmUc?w^mqm0_ zPQiR}@im8UKog3;F4P5>%Ql4?T*Kq1`)55`C5xZvAJV=>)jjF2%s(}o_mN@Fl z{wTf)S$Y(r4W3Ef0UUJ_W!uwHCzWM^>b?5gAmt-km~olH4k~SCxgq?=CqjYnkljqU zHoQRjkm{yt|6bFA#{dURYb7NLb)tmJgY$CZaqAV9$c6i0G?-BfO^57x$b^)ka1*&% z?Cg7#E*^y)?>zCiAVFMzQJc!cC$NLt8G>;Mc7owFnE}5bC447Le1rJXS$4YVF2n-E zbHN*tM|gk{rkbB5Z|G@*DHepKSk5UU&U4AvP>LqV53k`?*Cu;b!Qt$LoN-S7eGJH| zf1{l3tzyJsP@v9pk*>YR2*v2INkVN!05T5Dn(I2!d3`{Tz>n2pUw* z*wpVDR~`6i7eOcal@Tu19LuqX`ja!W%0h6<(_8BLuPfGl51ucWp0t*GhX~B;A)&Y? zQ?=E-*h@}OwW=0_W}!W*9?T1NDpj8hI<<(C8nC7>6y1tR8eRzjjr%nknE06@sA(yL zCVYDXHbCq|SA6tSax||%rz^^hLe3?;RqUp!&DuVApa@5zgxZmWU6;>F2>W733b3BhUa~ zxn}Mv-43V231Vg)`S?LC^mUdR?3I|SF!FA75}LBGNR}u5#lo7)R#z$Bj}@lRI;Zqn z=`XNcH$V5vw_xntG9;qSkPm(7Vv8|QgClE0Rc-cxrIZNlbtcof5fvL=@;{op_OGVS zbPZxbK?sO)l|<_xS_r9?ON)VBii$`vDk=zu)bRp=V(LIjgiV5S2^W#JjxvQpP(i$5 zqyn)R5+DKEQsfRA3dv47a+keFF8h$MJ)ghLnzhakbJm=-&Ofk|wb!@b?|Gl+d7oFI z58`*r(RP8&f=CtGuC``rC2e!rkeO^JynRTz3;lH%vFRl~;Dw&7Z{Xw{Pj$OAFCycg z>5!%T#JU{@-@8-g{+Rco1ks1>>ui6+6NL}h9;-JhKz<|!1al@oqGK(v9w?((j_QI?dw zzE(M@+LZy1qvJIIYz_7h+_o5GO zk-*k*gd(ejm0c&$>*}I~#1sY|k$^cLM7y)N&$`@$hh$r(AWNxZ;=LDfcFTv%CZHJx z_7P(f)E;I!yqJZNI#^b?uX4+ALL zUx!c0t>}C2!BD?<`ssa*gI+6)Bg1!kY>)n6^7_|*8r31a?fcgNRKp6Yo{7L9hX`uxO|jyCpD@q+xd^_^x=Ht}8`L$^UY`DY{)`Dh<+}sC&9F z%3nyv>;3<{oRAi{VcTiRE2H^tE8D=lKQkH%%uNoQ8fKO;RX2BRqp|+|k zTF2hS(;pjDw-eq0Rwyltz7r`GIrD@qlGI=YSa$8zLKbN($x8=-2-%2L7t!E7##nLQ zTccAhX{{n>umz)g4eSBPNRa|qhKTnjpoVQ?bVTdKr$~O3m*`HE^rUj1!GBJxFT#^K4>?ul7 zuE>s0Ws5B4FJb(#&KADSpv+-XzM8)|5Q{~8M5w5>Btqy(cddxTBeZ38kTrKTW+&24 ziyiUo;}nOOgaAryZyj~}Dy6(OIM=|yXo#Sll`pC%wRMvX!FcEeZ2`^v7d8UE2og%? zTVmZgG?=Cno1f%S_M^@ej3Zv#h`I*8r1}0IeZQxDdp4|>xq1~ViNUrdA;FQ)VilQ*} zImc;qLd6j-sGSX;48gI8OUh9oX^8CDsR7@E8_}borY0`JuT5ldb&9!Ei9a|rR9|z* zD0S499YCa8v^9Qu#$a|?*NP;ck$MLmICWh_c7QDlc7KKoZzbFik!rphrSA#OHk{>ZN=HFYkF@7K!h;U> z(5aePTV!xitSRjwovK|aq5&gfdUOYClk8)BT*tanjKmfZB%alqL!c$6+g89{s9dR! zwqUqSmv4IKWpj4lJ(o-VK+-!O8WsV>{r0;z8qfW;BseEoWW_EK=hkq)S@%Nz=Lbc= za8FS}#xg&ANz;7=;GAHjyP32xevxoNeGBJF`2lA5;nOLx8q4r@pb762`utG78~t{W zyVzqmfpnIc2gYh$7{Nm`+)*bNa>oIq<*gb{OO352BI6W#@R}G9aK6K-OL@}M+P6k7 zys_oZLzwWYAxRf@{*99FfpK!H`{rjU!8vb^4T{Ho8jok*jvI49iR)HnfU>ZfSUxVS znpCAfeUI@{uSpStBO({>G(bHdZ$SBGj3?;;1(qJ6qu4q-(!+F+3w#i3cm`mlBTp1l zda$mx?z^SK!-k;L1}reaQYNYjtY#nowyIooKG#@R?y!;vx^l|ZLhRXIjCF;of(j|? ziQSW9t73aut$x8*13rYe_44iDeSRs11H~tVp_q4jk(<)}+17h9H94Vt^T6$Izg!6M z_^U~hwsBPU6OF*JF&aI2e`sm?uF+TFL|gf0OmtOd4hMo6p3mW9 zc*_H#TVU-$Y=J-O_oVMeyPL}$g(oHGViQu(bh<5ya>?LYwO1?HFxBXr>pA1;{Y&+e z$9+`tB54gSP`KAjj~_Eynp0V5>@&fLclW9&Fg%i4oe%F!s{oE$mNmRqr#7BySf*Vi zHo<$)#HB@HHsF$14uTUu|8sqzXYA948{JVrurrD3qb>MbuzKs6_TjSHr$#6MIrv;V z;fklJk7N4T(Zc8^qm`@Ahi zYMc*YZn+%(rYZjFr!q;}r1oPj`kV?H56lB&}T!Y#VL0KM4ne0$1ndK736xl4ZJYv zn&;rIb1k#Gk$O>U8em*S8y7@tCPYu<1@d!@wIS4{tmIKaD`d4G&m%hnpR0R~TSOmy zYply~9^p78vq2X`+4Y6z701K&jT{V-GTGYD?;pi{W%Zi%Lefs&f#;!+R^7%?Nx(N& zB-_mIhOBLYx>;R|%3E2h@dNHuMhoCz(lL|IfSBRMFbS*XEJO60w zkkqqQH41waBQr|@TM}WDZUaD-t2Nh}<)&sc9SEcn>B@`sKJkqQZ{Ol6kY^|0PZ}}P zno8b{(0hjT3LZxb%dE*e!DceB$au=Bts~E)uC$;qV!yyTfsMXlq8{rfznL^5cjzcD zP9ttt&ftw;zmlZ26AKDnDSue^3B2)QRh*NsWj1M%)ilWEWRC5`Po#R4%4dqKaaOea z$>8R&7|Yl_Pl=BDK5<<^m(}#Kep<61MF>5K%}?g!JAs8SR|I4@5e##Xtq6B!ixp7-DS)!A#54_2aIy;xgeKy?**tyGZ!qBUENNHk{ zGW0=4YH*QkEl3x%Z)0Sr?YREYkv|T}j1pu4!&2`%FPyhjP5VODeDXBQiu*CQL#265QTmUiE#QGW) zWN-z2@V@C;7H4$jZ^@il%eO`}!({@@;6$3f${^*bYbBTXJKSaiN;>lC(bYw&+X~7$ zI#oxR8R~5ThoiMK{eU|7DLSmG>&%e&)>eo0>UE00kxQCUIor*cXG?+lMNvQuzd|)-CDjK65a{l^AA_X1C}+{ROk{P+NlqEa!{0 z)X{N8w8%P+Mdmx8X~bFNEe)9Uz`Q_6 zkWsPlcK^&m>1?=ixMXE17d}C|Lc25QQTI10(QykXFsGjzPm_&S%BsPIS!8BlVZt_& z9sD_7gm5y+fSl)QEjhucK&ZjUnPNj=A3e3?c@dADGXt?{*NuQ)Z%rt!#iy_~ff*~H?vS*_mx(p}UfKItL;g z$>Q9{xUbgpCh`Cf9lI2A>$bXLVtc;_=TUt$lW}}_&ahESF*_N*v#H{}2aFemuz7$} z0%T11;BPeQBKSSj4e6d47xQlQgEfFx=EeDHOJZZ>$tZj+@jmcQE?c%=g9_j++RcbTW+KZRk>#%+nBt4l9eYM4JrZ`u&jx z&Ql2}%r;LG~bS@JP;V(-+bs^0x>0NlXi%Bw^ zn}z^)mG}fFNByI`mGjbfzmS=}<(3qUXmw#Q2fZNccYt#8#(B^}bw2ui?|tuQiYkYj znKO+rsp)r<-)QnL@)$Y5q`~=g<+jX|7rhvbwKr+QB9ttn`Lf;3f{8H-_NYEZjE^9! zEdKUxq!_=1fN+ElWCQhS(cPpI@xJ6OJ@ZsfI68h=dJ19MBo|OOo6OGH^Mb-K!6gGj z9kus);Z`;#Jrcc_T2s^MyoX0#&C^-h?lV7R*6Adg zNvNJ&gjR7G+0aI5A}Rv7;;j*SRiTL$2K;FBqEWo0fEDIH|lK`_X?P6t!hG8x^6DK40OLrlH9D>p}A01}053SCbf8h3GZSmoO z*WUg?ZBb)QTK}UaubqrAkZ1xrSMa(ySp*s1i=;b?^&vp4KzRKxSjT1Hr-R8VM_cLWD+!7=49PQt07Cuhy zcgZ)3T&Vz```0#&jycK6z`9UP^rn{~ddK!YXOh_O6 zdDAIvnXAD!u5s5%ujK=kOO*5dw6(bvrVU~}EiP5m5f-ZR!@HF`*)nh36`9L`>}4B9 zCu3{|4Qnw*Gk@JvyhflI9IP6ULQsA(H8gmD{}KK?dJ^{6TDVjBzb07v9)0}XSnqEd zG6NC4NIBm3knarpW5Kh#Fd;y)Pv%-lHaMg#H^V>CQlaKUzpE)Zs+t?mP=!KZLu{KY zcc=rhKWz={Ka^Z%cDQ%GQ@;Wo!z?>;>TEFE7_4q*{NsepluwDiw?@YEaurJhcxTHg z;scCyX;vC^AGc*nu-NP`dR}u^ND=r&%&b+u-pgXdg0p@ybu2rnFs0QmIpz3r`Sr8} z{~wBXdbyS{jp!r5-?B8jv2uEueD47<2078gD<>Pu-MFZ05q&uZ`oc?;-5M&{FN3 zl9I!+m03-RoX?`wO1%YX&GeFAcQzD9%ClE*2zVce`Ab;~P38hi{7Lh0j9c-Zf#gyy zh_4B%nBv>^crz)=;}L=pib~_8a+?W7@Ht?T6gwNjaUtfc%`Tc<3&4vnfTA|uFAUUb zChxXVW{L*jt+{HW7}~^!^w;&aW92tKz>X!-wV&vCGI}jaIBvBY5Z`BP?>(D zZ@x3l_4_Ba{YtyX&plnA8vU1Qe9-}YRa%Xw9KlmChL)rd<;Sc6x=e^69*t;0m~8qg>}=78|U5?D|yrqJ@8b*icoOYN@Bv>-O@N)l=meZaUOjA7bv#t%rs=lcb*8a?eTJl zEb$1Wq3FVehh5uBPbWZm-j<8385Rb$a3YrL6X#EgvYKH*IpgEpX8N7r%((8Qd)c=g0qXbGz~QnCnUb--Y*}SzbSvu>g3qpF9L#l5*eW z!23LiO}Z1Ez#`GviKqmD6f8@S9OhXZ_VVmq+;3c?&Vo~r&ZZb@R5ZgO$o027X{#l* zxvPdj6+6w!k=dd0nG1-e*>TMK#_)RUvA)%!3Qooo>arjbRewyR|_c{$ZQvKKwQ0B!gF1r@<@h6qUFRFIQT^5Vz zwku&}eEt<4969vI@Pa7Q4{F;%|4?mRS9DobHLw(Qbj&{U@HOR7jJ5n38dIQ4cUPSI zwe@F{r+BH}E>5uCdrp-)4ja%+fp=Zw?ueOT>%TadjJt#{ZhRI- z(V8h}#{52tJ>P+N4tDU>&p9THdE!(g(HEI7tR&_6J-Yn}czx6gQtom!@P#Czy4C>t zkat-c0FzyQi(tYX9qi8azJYTd@oXpu!nT`8Fw%^WQ;Cm!jtlj4!y$|^Gop0>&L3aR zaBiJ^4ah%>aYuc@IeI@jsC~*)&J1+*TBEByZ@Qz V{%@c1Zx6@+U%#LKZ_|S>{~Nc1?Y{s3 literal 0 HcmV?d00001 diff --git a/figures/favicon.ico b/figures/favicon.ico new file mode 100644 index 000000000..e2538a32f --- /dev/null +++ b/figures/favicon.ico @@ -0,0 +1,88 @@ + + + + diff --git a/figures/figure-1.svg b/figures/figure-1.svg new file mode 100644 index 000000000..decd48479 --- /dev/null +++ b/figures/figure-1.svg @@ -0,0 +1,4 @@ + + + +
EASIFEM_INSTALL_DIR
EASIFEM_INSTALL_DIR
easifem
easifem
extpkgs
extpkgs
base
base
classes
classes
app
app
materials
materials
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
bin
bin
lib
lib
include
include
share
share
kernels
kernels
bin
bin
lib
lib
include
include
share
shareText is not SVG - cannot display \ No newline at end of file diff --git a/figures/figure-2.svg b/figures/figure-2.svg new file mode 100644 index 000000000..d90a2d6aa --- /dev/null +++ b/figures/figure-2.svg @@ -0,0 +1,4 @@ + + + +
easifemBase
easifemBase
src
src
modules
modules
submodules
submodules
Header and Interface Only
Header and Interface Only
CSRSparsity
CSRSparsity
src
src
CSRSparsity_Method.F90
CSRSparsit...
CMakeLists.txt
CMakeLists...
Implementation
Implementation
CSRSparsity
CSRSparsity
src
src
CSRSparsity_Method@ConstructorMethods.F90
CSRSparsit...
CMakeLists.txt
CMakeLists...
CSRSparsity_Method@IOMethods.F90
CSRSparsit...Text is not SVG - cannot display \ No newline at end of file diff --git a/figures/logo_hero.svg b/figures/logo_hero.svg new file mode 100644 index 000000000..1a0aca649 --- /dev/null +++ b/figures/logo_hero.svg @@ -0,0 +1,105 @@ + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/figures/what-is-easifem.svg b/figures/what-is-easifem.svg new file mode 100644 index 000000000..c611e29ac --- /dev/null +++ b/figures/what-is-easifem.svg @@ -0,0 +1,780 @@ + + + + + + + + + + + +image/svg+xml + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +BASEKERNELSCLASSESMid-level, Object Orientated Interface-Bindings: Gmsh, PlPlot, HDF5, XML, VTK, TOML, PETSc, MPI, CUDA-Fortran, OpenMP, etc.Physics simulatorsLow level, Multiple dispatch, BaseType, BaseMethods, Bindings: Sparsekit, LIS, Lapack, Blas, PlPlot, Metis, etc.EASIFEMMulti level design architecture of EASIFEM diff --git a/fortran.json b/fortran.json new file mode 100644 index 000000000..48b4191ee --- /dev/null +++ b/fortran.json @@ -0,0 +1,237 @@ +"type": { + "prefix": "type", + "description": "define a new dataTYPE", + "body": [ + "!----------------------------------------------------------------------------", + "! ${name}", + "!----------------------------------------------------------------------------", + "TYPE :: ${name}", + "\t", + "END TYPE ${name}", + "", + "PUBLIC :: ${name}", + "", + "TYPE( ${name} ), PUBLIC, PARAMETER :: Type${name} = ", + "\t", + "", + "TYPE :: ${name}Pointer_", + "\tCLASS( ${name}, POINTER :: Ptr => NULL()", + "END TYPE ${name}Pointer_", + "", + "PUBLIC :: ${name}Pointer_", + ], + }, + "gnu-gpl3": { + "prefix": "gpl3", + "description": "GNU-GPL3 licence", + "body": [ + "! This program is a part of EASIFEM library", + "! Copyright (C) 2020-2021 Vikas Sharma, Ph.D", + "!", + "! This program is free software: you can redistribute it and/or modify", + "! it under the terms of the GNU General Public License as published by", + "! the Free Software Foundation, either version 3 of the License, or", + "! (at your option) any later version.", + "!", + "! This program is distributed in the hope that it will be useful,", + "! but WITHOUT ANY WARRANTY; without even the implied warranty of", + "! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the", + "! GNU General Public License for more details.", + "!", + "! You should have received a copy of the GNU General Public License", + "! along with this program. If not, see ", + "!", + ], + }, + "int": { + "prefix": "int", + "description": "integer", + "body": "INTEGER( I4B )", + }, + "real": { + "prefix": "real", + "body": "REAL( DFP ) ", + "description": "real", + }, + "logical": { + "prefix": "logi", + "description": "logical", + "body": "LOGICAL( LGT ) ", + }, + "modpuresub": { + "prefix": "mps", + "description": "module pure subroutine", + "body": [ + "INTERFACE", + "MODULE PURE SUBROUTINE ${NAME}( $0 )", + "\t", + "END SUBROUTINE ${NAME}", + "END INTERFACE", + "", + ], + }, + "warn": { + "prefix": "warn", + "description": "warning ", + "body": [ + "!@warning", + "! \t$0", + "!@endwarning", + ], + }, + "note": { + "prefix": "note", + "description": "note ", + "body": [ + "!@note", + "! \t$0", + "!@endnote", + ], + }, + "todo": { + "prefix": "todo", + "description": "todo ", + "body": [ + "!@todo", + "! \t$0", + "!@endtodo", + ], + } + "intro": { + "prefix": "intro", + "description": "introduction ", + "body": [ + "!# Introduction", + "! \t$0", + ], + }, + "vikas": { + "prefix": "vikas", + "description": "vikas", + "body": [ + "!> author: Vikas Sharma, Ph. D.", + "! date: \t$1", + "! summary: \t$2", + ], + }, + "usage": { + "prefix": "use", + "description": "use", + "body": [ + "! ", + "!### Usage", + "! ", + "!```fortran", + "!\t$0", + "!```", + ], + }, + "modsub": { + "prefix": "ms", + "description": "module subroutine", + "body": [ + "INTERFACE", + "MODULE SUBROUTINE ${NAME}( ${Name2} )", + "\t$0", + "END SUBROUTINE ${NAME}", + "END INTERFACE", + "", + ], + }, + "modpurefunc": { + "prefix": "mpf", + "description": "module pure function", + "body": [ + "INTERFACE", + "MODULE PURE FUNCTION ${NAME}( ${name2} ) RESULT( Ans )", + "\t$0", + "END FUNCTION ${NAME}", + "END INTERFACE", + "", + ], + }, + "class": { + "prefix": "cls", + "description": "class", + "body": "CLASS( $1 )", + }, + "intentin": { + "prefix": "in", + "description": "intent in", + "body": "INTENT( IN ) :: $1", + }, + "intentout": { + "prefix": "out", + "description": "intent out", + "body": "INTENT (OUT) :: $1", + }, + "intentinout": { + "prefix": "inout", + "description": "intent in out", + "body": "INTENT( INOUT ) :: $1", + }, + "generic": { + "prefix": "generic", + "description": "itnerface", + "body": [ + "INTERFACE ${NAME}", + "\tMODULE PROCEDURE $0", + "END INTERFACE ${NAME}", + "", + "PUBLIC :: ${NAME}", + ], + }, + "line": { + "prefix": "line", + "description": ".........", + "body": [ + "!----------------------------------------------------------------------------", + "! $1", + "!----------------------------------------------------------------------------", + ], + }, + "procedure": { + "prefix": "proc", + "description": "procedure", + "body": "PROCEDURE, PUBLIC, PASS( obj ) :: $1", + }, + "moduleprocedure":{ + "prefix": "mp", + "description": "module procedure", + "body": [ + "MODULE PROCEDURE ${NAME}", + "\t$0", + "END PROCEDURE ${NAME}", + ], + }, + "modulefunction":{ + "prefix": "mf", + "description": "module function", + "body": [ + "INTERFACE", + "MODULE FUNCTION $1( $2 ) RESULT( Ans )", + "\t$0", + "END FUNCTION $1", + "END INTERFACE", + ], + }, + "char":{ + "prefix": "char", + "description": "charcter(len=*)", + "body": "CHARACTER( LEN = * )", + }, + "display": { + "prefix": "disp", + "description": "display", + "body": [ + "INTERFACE", + "MODULE SUBROUTINE ${NAME1}( obj, Msg, UnitNo )", + "\tCLASS( ${NAME2} ), INTENT( IN ) :: obj", + "\tCHARACTER( LEN = * ), INTENT( IN ) :: Msg", + "\tINTEGER( I4B ), OPTIONAL, INTENT( IN ) :: UnitNo", + "END SUBROUTINE ${NAME1}", + "END INTERFACE", + "", + ], + }, +} diff --git a/install.py b/install.py new file mode 100755 index 000000000..560997cc9 --- /dev/null +++ b/install.py @@ -0,0 +1,53 @@ +#!/usr/bin/env python3 +#!/Users/easifem/anaconda3/envs/easifem/bin/python3 + +# This program is a part of EASIFEM library. +# See. www.easifem.com +# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. +# + +import os +import platform + +print("Detecting OS type...") +_os = platform.system() +if _os == "Windows": + print("ERROR: INSTALLATION on windows is work in progress") + exit + # print("Please use Windows Subsystem Linux(WSL) ") + # print("Installation DONE!!") +else: + cmake_def = "" + cmake_def += ' -G "Ninja"' # Unix Makefiles, Ninja, Ninja Multi-Config + cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Debug" # Release + cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" + cmake_def += " -D CMAKE_EXPORT_COMPILE_COMMANDS:BOOL=ON" + cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" + cmake_def += " -D USE_OPENMP:BOOL=ON" # OFF + cmake_def += " -D USE_PLPLOT:BOOL=ON" + cmake_def += " -D USE_BLAS95:BOOL=ON" + cmake_def += " -D USE_LAPACK95:BOOL=ON" + cmake_def += " -D USE_FFTW:BOOL=ON" + cmake_def += " -D USE_GTK:BOOL=OFF" + cmake_def += " -D USE_ARPACK:BOOL=ON" + cmake_def += " -D USE_SUPERLU:BOOL=ON" + cmake_def += " -D USE_LIS:BOOL=ON" + cmake_def += " -D USE_PARPACK:BOOL=OFF" + cmake_def += " -D USE_METIS:BOOL=OFF" + cmake_def += " -D USE_LUA:BOOL=ON" + cmake_def += " -D USE_INT32:BOOL=ON" + cmake_def += " -D USE_REAL64:BOOL=ON" + cmake_def += " -D USE_RAYLIB:BOOL=ON" + cmake_def += " -D USE_COLORDISP:BOOL=OFF" + + print("CMAKE DEF : ", cmake_def) + + _build0 = os.path.join(os.environ["HOME"], "temp") + build_dir = os.path.join( + os.environ.get("EASIFEM_BUILD_DIR", _build0), "easifem", "base", "build" + ) + # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" + os.makedirs(build_dir, exist_ok=True) + os.system(f"cmake -S ./ -B {build_dir} {cmake_def}") + os.system(f"cmake --build {build_dir} --target install") + print("Installation DONE!!") diff --git a/neovim.json b/neovim.json new file mode 100644 index 000000000..0f02b3949 --- /dev/null +++ b/neovim.json @@ -0,0 +1 @@ +{"cargo":{"dap_name":"lldb"},"cmake":{"build_type":"Debug","dap_name":"lldb","args":{"configure":["-D","CMAKE_EXPORT_COMPILE_COMMANDS=1","-G","Ninja","-D","USE_OPENMP=ON"]},"env":{"configure":[]},"build_dir":"{cwd}\/build\/{os}-{build_type}","cmd":"cmake"}} \ No newline at end of file diff --git a/package-lock.json b/package-lock.json new file mode 100644 index 000000000..4616572a7 --- /dev/null +++ b/package-lock.json @@ -0,0 +1,64 @@ +{ + "name": "easifem-base", + "lockfileVersion": 2, + "requires": true, + "packages": { + "": { + "dependencies": { + "shiki": "^0.11.1" + } + }, + "node_modules/jsonc-parser": { + "version": "3.2.0", + "resolved": "https://registry.npmjs.org/jsonc-parser/-/jsonc-parser-3.2.0.tgz", + "integrity": "sha512-gfFQZrcTc8CnKXp6Y4/CBT3fTc0OVuDofpre4aEeEpSBPV5X5v4+Vmx+8snU7RLPrNHPKSgLxGo9YuQzz20o+w==" + }, + "node_modules/shiki": { + "version": "0.11.1", + "resolved": "https://registry.npmjs.org/shiki/-/shiki-0.11.1.tgz", + "integrity": "sha512-EugY9VASFuDqOexOgXR18ZV+TbFrQHeCpEYaXamO+SZlsnT/2LxuLBX25GGtIrwaEVFXUAbUQ601SWE2rMwWHA==", + "dependencies": { + "jsonc-parser": "^3.0.0", + "vscode-oniguruma": "^1.6.1", + "vscode-textmate": "^6.0.0" + } + }, + "node_modules/vscode-oniguruma": { + "version": "1.7.0", + "resolved": "https://registry.npmjs.org/vscode-oniguruma/-/vscode-oniguruma-1.7.0.tgz", + "integrity": "sha512-L9WMGRfrjOhgHSdOYgCt/yRMsXzLDJSL7BPrOZt73gU0iWO4mpqzqQzOz5srxqTvMBaR0XZTSrVWo4j55Rc6cA==" + }, + "node_modules/vscode-textmate": { + "version": "6.0.0", + "resolved": "https://registry.npmjs.org/vscode-textmate/-/vscode-textmate-6.0.0.tgz", + "integrity": "sha512-gu73tuZfJgu+mvCSy4UZwd2JXykjK9zAZsfmDeut5dx/1a7FeTk0XwJsSuqQn+cuMCGVbIBfl+s53X4T19DnzQ==" + } + }, + "dependencies": { + "jsonc-parser": { + "version": "3.2.0", + "resolved": "https://registry.npmjs.org/jsonc-parser/-/jsonc-parser-3.2.0.tgz", + "integrity": "sha512-gfFQZrcTc8CnKXp6Y4/CBT3fTc0OVuDofpre4aEeEpSBPV5X5v4+Vmx+8snU7RLPrNHPKSgLxGo9YuQzz20o+w==" + }, + "shiki": { + "version": "0.11.1", + "resolved": "https://registry.npmjs.org/shiki/-/shiki-0.11.1.tgz", + "integrity": "sha512-EugY9VASFuDqOexOgXR18ZV+TbFrQHeCpEYaXamO+SZlsnT/2LxuLBX25GGtIrwaEVFXUAbUQ601SWE2rMwWHA==", + "requires": { + "jsonc-parser": "^3.0.0", + "vscode-oniguruma": "^1.6.1", + "vscode-textmate": "^6.0.0" + } + }, + "vscode-oniguruma": { + "version": "1.7.0", + "resolved": "https://registry.npmjs.org/vscode-oniguruma/-/vscode-oniguruma-1.7.0.tgz", + "integrity": "sha512-L9WMGRfrjOhgHSdOYgCt/yRMsXzLDJSL7BPrOZt73gU0iWO4mpqzqQzOz5srxqTvMBaR0XZTSrVWo4j55Rc6cA==" + }, + "vscode-textmate": { + "version": "6.0.0", + "resolved": "https://registry.npmjs.org/vscode-textmate/-/vscode-textmate-6.0.0.tgz", + "integrity": "sha512-gu73tuZfJgu+mvCSy4UZwd2JXykjK9zAZsfmDeut5dx/1a7FeTk0XwJsSuqQn+cuMCGVbIBfl+s53X4T19DnzQ==" + } + } +} diff --git a/package.json b/package.json new file mode 100644 index 000000000..cc4382947 --- /dev/null +++ b/package.json @@ -0,0 +1,5 @@ +{ + "dependencies": { + "shiki": "^0.11.1" + } +} diff --git a/package.py b/package.py new file mode 100644 index 000000000..8d3759121 --- /dev/null +++ b/package.py @@ -0,0 +1,49 @@ +# This program is a part of EASIFEM library. +# See. www.easifem.com +# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. +# + +import os +import platform + +print("Detecting OS type...") +_os = platform.system() +if _os == "Windows": + print("ERROR: INSTALLATION on windows is work in progress") + exit + # print("Please use Windows Subsystem Linux(WSL) ") + # print("Installation DONE!!") +else: + + cmake_def = "" + user_query = False + cmake_def = "" + cmake_def += ' -G "Ninja"' + cmake_def += " -D USE_OpenMP:BOOL=ON" + cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Release" + cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" + cmake_def += " -D USE_PLPLOT:BOOL=ON" + cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" + cmake_def += " -D USE_BLAS95:BOOL=ON" + cmake_def += " -D USE_LAPACK95:BOOL=ON" + cmake_def += " -D USE_FFTW:BOOL=ON" + cmake_def += " -D USE_GTK:BOOL=ON" + cmake_def += " -D USE_ARPACK:BOOL=ON" + cmake_def += " -D USE_SUPERLU:BOOL=ON" + cmake_def += " -D USE_LIS:BOOL=ON" + cmake_def += " -D USE_PARPACK:BOOL=OFF" + cmake_def += " -D USE_METIS:BOOL=OFF" + cmake_def += " -D USE_Int32:BOOL=ON" + cmake_def += " -D USE_Real64:BOOL=ON" + + print("CMAKE DEF : ", cmake_def) + + _build0 = os.path.join(os.environ["HOME"], "temp") + build_dir = os.path.join( + os.environ.get("EASIFEM_BUILD_DIR", _build0), "base", "build" + ) + # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" + os.makedirs(build_dir, exist_ok=True) + os.system(f"cmake -S ./ -B {build_dir} {cmake_def}") + os.system(f"cmake --build {build_dir} --target package") + print("Installation DONE!!") diff --git a/pages/BaseMethods.md b/pages/BaseMethods.md new file mode 100644 index 000000000..b1c7c6c09 --- /dev/null +++ b/pages/BaseMethods.md @@ -0,0 +1,58 @@ +# BaseMethods + +`BaseMethods` library contains the modules which defines and implements methods (routines) for data types defined in BaseType. + +At present BaseMethods contains following modules. + +|Module|Comment|Category| +|---|---|---| +|String_Class|Defines String class and methods.|String| +|String_Method|Additional methods for handling strings.|String| +|PENF|For portability.|OS| +|BeFoR64|For portability.|OS| +|FACE|Colorful console printing.|IO| +|FPL|Fortran parameter list|Utility| +|System_Method|Interface to C system libray.|OS| +|CInterface|Utility for C-Fortran interface building.|OS| +|OpenMP_Method|Methods which uses OpenMP for acceleration.|Misc| +|GlobalData|GlobalData for easifem library|Misc| +|Hashing32|Hash functions.|Utility, Crypto| +|OGPF|Gnuplot library|Plot| +|Test_Method|Unit testing library|Test| +|MdEncode_Method|Encoding text into markdown.|IO| +|DispModule|Pretty printing on terminal.|IO| +|Display_Method|Pretty printing on terminal.|IO| +|ErrorHandling|Exception handling.|ExceptionHandling| +|Utility|Utility module.|Utility| +|PolynomialUtility|Collection of useful routine for polynomial interpolation.|Basis| +|BaseType|Collection of user define data types.|Core| +|MultiIndices_Method|Methods for MultiIndices_.|Math| +|Random_Method|Methods for Random_ data type.|Math| +|BoundingBox_Method|Methods for BoundingBox_ data type|Math| +|IntVector_Method|Methods for IntVector_ data type|Vector| +|IndexValue_Method|Methods for IndexValue_ data type|FEM| +|IterationData_Method|Methods for IterationData_ data type.|FEM| +|Vector3D_Method|Methods for Vector3D_ data type.|Vector| +|RealVector_Method|Methods for RealVector_ data type|Vector| +|DOF_Method|Methods for DOF_ data type|FEM| +|Geometry_Method|Geometry realted methods.|Math| +|QuadraturePoint_Method|Methods for QuadraturePoint_ data type.|FEM| +|FEVariable_Method|Methods for FEVariable_ data type|FEM| +|ElemshapeData_Method|Methods for ElemshapeData_ data type.|FEM| +|RealMatrix_Method|Methods for RealMatrix_ data type.|Matrix| +|FEMatrix_Method|Methods for FEMatrix_ data type.|FEM| +|FEVector_Method|Methods for FEVector_ data type.|FEM| +|Rank2Tensor_Method|Methods for Rank2Tensor_ data type.|Tensor| +|VoigtRank2Tensor_Method|Methods for VoigtRank2Tensor_ data type.|Tensor| +|CSRSparisty_Method|Methods for CSRSparisty_ data type.|Matrix| +|CSRMatrix_Method|Methods for CSRMatrix_ data type.|Matrix| +|SuperLUInterface|Fortran interface to SuperLU lib|LinearSolver| +|LISInterface|Fortran interface to LIS lib|LinearSolver| +|F77_BLAS|F77 interface to BLAS.|LinearAlgebra| +|F95_BLAS|Fortran 95 interface to BLAS lib.|LinearAlgebra| +|F77_LAPACK|Fortran interface to Lapack.|LinearAlgebra| +|F95_LAPACK|Fortran 95 interface to Lapack lib.|LinearAlgebra| +|Lapack_Method|Methods for linear algebra by using Lapack.|LinearAlgebra| +|EASIFEM_ARPACK|Fortran interface to ARPACK.|LinearAlgebra| +|FFTW3|Fast fourer tranform library|LinearAlgebra| +|MetisInterface|Fortran interface to Metis library.|LinearAlgebra| diff --git a/pages/BaseType.md b/pages/BaseType.md new file mode 100644 index 000000000..3023a6b7e --- /dev/null +++ b/pages/BaseType.md @@ -0,0 +1,66 @@ +# BaseType + +`BaseType` contains user-define data type. + +|Data-type|Summary|Category| +|---|---|---| +|Math_|Contains mathematical constants.|Math| +|BoundingBox_|Data type for bounding box.|FEM| +|RealMatrix_|Extension for Fortran two-d array|Matrix| +|IntVector_|Vector of integers.|Vector| +|RealVector_|Vector of reals|Vector| +|Vector3D_|3D Vector|Vector| +|IndexValue_|Key (integer) and value (real), useful for defining nodal boundary conditions|FEM| +|DOF_|Degree of freedom object type|FEM| +|SparseMatixReOrdering_|Sparse matrix reordering scheme|LinearAlgebra| +|CSRSparisty_|Datatype for handling sparsity pattern|LinearAlgebra| +|SuperLU_|SuperLU data structure.|LinearAlgebra| +|CSRMatrix_|Compressed sparse row matrix|LinearAlgebra| +|IterationData_|Datatype for storing iteration data|FEM| +|VoigtRank2Tensor_|Rank2 tensor|Tensor| +|DeformationGradient_|Deformation Gradient tensor|Tensor| +|LeftCauchyGreen_|Left Cauchy Green tensor|Tensor| +|RightCauchyGreen_|Right Cauchy Green tensor|Tensor| +|Strain_|Strain tensor|Tensor| +|AlmansiStrain_|Almansi strain|Tensor| +|GreenStrain_|Green strain tensor|Tensor| +|SmallStrain_|Small strain tensor.|Tensor| +|ReferenceTopology_|Data type for handling reference element in FEM|FEM| +|ReferenceElement_|Data type for reference element in FEM|FEM| +|ReferencePoint_|Data type for reference point in FEM|FEM| +|ReferenceLine_|Data type for reference line in FEM|FEM| +|ReferenceTriangle_|Data type for reference triangle in FEM|FEM| +|ReferenceQuadrangle_|Data type for reference quadrangle in FEM|FEM| +|ReferenceTetrahedron_|Data type for reference tetrahedron in FEM|FEM| +|ReferenceHexahedron_|Data type for reference hexahedron in FEM|FEM| +|ReferencePrism_|Data type for reference prism in FEM|FEM| +|ReferencePyramid_|Data type for reference pyramid in FEM|FEM| +|KeyValue_|Poor man's implementation of dic.|Container| +|FEVariable_|Data type for finite element variables.|FEM| +|FEVariableConstant_|Constant finite element variable|FEM| +|FEVariableSpace_|Spatially variable finite element variable|FEM| +|FEVariableTime_|Time variable finite element variable|FEM| +|FEVariableSpaceTime_|Spatially and temporally changing finite element variable|FEM| +|FEVariableScalar_|Scalar finite element variable|FEM| +|FEVariableVector_|Vector finite element variable|FEM| +|FEVariableMatrix_|Matrix finite element variable|FEM| +|QuadraturePoint_|Quadrature points|FEM| +|BaseInterpolation_|Data type for basis interpolation|FEM| +|LagrangeInterpolation_|Lagrange interpolation|FEM| +|HermitInterpolation_|Hermit interpolation|FEM| +|SerendipityInterpolation_|Serendipity interpolation|FEM| +|HierarchyInterpolation_|Hierarchical interpolation|FEM| +|BaseContinuity_|Continuity type of basis functions.|FEM| +|H1_|H1 finite element basis|FEM| +|H1DIV_|H1(Div) finite element basis|FEM| +|H1Curl_|H1(Curl) finite element basis|FEM| +|DG_|Discontinuous Galerkin finite element basis|FEM| +|ElementData_|Data necessary for creating finite element.|FEM| +|ShapeData_|Storage for shape data|FEM| +|STShapeData_|Space-time shape function data|FEM| +|ElemshapeData_|Element shape function data|FEM| +|STElemShapeData_|Space-time element shape data.|FEM| +|QualityMeasure_|Datatype for mesh quality measure|FEM| +|Random_|Data type for random variables|FEM| +|OpenMP_|Data type for OpenMP parallel environment|FEM| +|MultiIndices_|Data type for multi indices|FEM| diff --git a/pages/Environment.md b/pages/Environment.md new file mode 100644 index 000000000..d613afd44 --- /dev/null +++ b/pages/Environment.md @@ -0,0 +1,152 @@ +# 𑗕 Environment variables for easifem + +The structure of easifem library after installation is given in Figure 1. + +![](../figures/figure-1.svg) + +In this figure "EASIFEM_INSTALL_DIR" is the location of parent directory where EASIFEM will be installed. +For example, if you want to install easifem at `~/local`, then `EASIFEM_INSTALL_DIR=~/local`. + +## Environment variables + +| var-name | description | comment | +|:--- | :--- | :--- | +|**EASIFEM_INSTALL_DIR** | location where easifem is installed | example: `/opt`, `${HOME}`, `/usr/local/` | +| **EASIFEM_SOURCE_DIR** | location where the source code of easifem will be stored | example: `~/Dropbox`, `~/code` | +| **EASIFEM_BUILD_DIR** | location where easifem will be build | To keep your source directory clean, always keep your build directory separated from build directory | +| **EASIFEM_EXTPKGS** | location where external packages necessary for easifem are installed | It is given by `EASIFEM_INSTALL_DIR/easifem/extpkgs` | +| **EASIFEM_BASE** | location where easifemBase library is installed | It is given by: `EASIFEM_BASE=EASIFEM_INSTALL_DIR/easifem/base` | +|**EASIFEM_CLASSES** | location where easifemClasses library is installed | It is given by: `EASIFEM_INSTALL_DIR/easifem/classes` | +| **EASIFEM_MATERIALS** | location where easifemMaterials library is installed | It is given by: `EASIFEM_INSTALL_DIR/easifem/materials` | +| **EASIFEM_KERNELS** | location where easifemKernels library is installed | It is given by: `EASIFEM_INSTALL_DIR/easifem/kernels` | + +## Setting up environment on UNIX and LINUX + +### EASIFEM cli (recommended method) + +The easiest way to work with the EASIFEM is `easifem` command line interface. + +- First download the `easifem` from `pip` by using following command. + +```bash +pip install easifem +``` + +- Then, we can set up the environment variables by using following command. + +```bash +easifem setenv --install /home/easifem/install --build /home/easifem/build --source /home/easifem/src +``` + +- This command will create config files for bash, zsh, and fish shell in `~/.config/easifem` directory. For bash and zsh the name of the file is `easifemvar.sh`, and for fish the name of the file is `easifemvar.fish`. +- Then, you can run following command to bring the changes in your current shell session. + +```bash title="bash and zsh" +source ${HOME}/.config/easifem/easifemvar.sh +``` + +```bash title="fish" +source $HOME/.config/easifem/easifemvar.fish +``` + +:::info +- If you are using bash or zsh shell, then you can place `easifemvar.sh` in your shell. For bash or zsh shell, open `.bashrc` or `.zshrc` in your editor and add the following line at the end of the file: + +```bash +source ${HOME}/.config/easifem/easifemvar.sh +``` + +- If you are using fish shell, then you can place `easifemvar.fish` in your shell. For fish shell, open `config.fish` in your editor and add the following line at the end of the file: + +```bash +source $HOME/.config/easifem/easifemvar.fish +``` + +::: + +import Tabs from '@theme/Tabs'; +import TabItem from '@theme/TabItem'; + + + + + +The following file is generated by running the command. + +```bash +easifem setenv --install /home/easifem/.easifem --build /home/easifem/temp --source /home/easifem/temp/src +``` + +```bash + export EASIFEM_INSTALL_DIR=/home/easifem/.easifem + export EASIFEM_BUILD_DIR=/home/easifem/temp + export EASIFEM_SOURCE_DIR=/home/easifem/temp/source + export EASIFEM_BASE=/home/easifem/.easifem/easifem/base + export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_BASE}/lib" + export EASIFEM_CLASSES=/home/easifem/.easifem/easifem/classes + export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_CLASSES}/lib" + export EASIFEM_EXTPKGS=/home/easifem/.easifem/easifem/extpkgs + export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_EXTPKGS}/lib" + export EASIFEM_APP=/home/easifem/.easifem/easifem/app + export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_APP}/lib" + export EASIFEM_MATERIALS=/home/easifem/.easifem/easifem/materials + export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_MATERIALS}/lib" + export EASIFEM_KERNELS=/home/easifem/.easifem/easifem/kernels + export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:${EASIFEM_KERNELS}/lib" + export PKG_CONFIG_PATH="${PKG_CONFIG_PATH}:${EASIFEM_EXTPKGS}/lib/pkgconfig" + export PATH="${PATH}:${EASIFEM_EXTPKGS}/bin" + export PATH="${PATH}:${EASIFEM_APP}/bin" +``` + + + + + +The following file is generated by running the command. + +```bash +easifem setenv --install /home/easifem/.easifem --build /home/easifem/temp/build --source /home/easifem/temp/src +``` + +```bash +set -gx EASIFEM_INSTALL_DIR /Users/easifem/.easifem +set -gx EASIFEM_BUILD_DIR /Users/easifem/temp/build +set -gx EASIFEM_SOURCE_DIR /Users/easifem/temp/src +set -gx EASIFEM_BASE /Users/easifem/.easifem/easifem/base +set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_BASE/lib +set -gx EASIFEM_CLASSES /Users/easifem/.easifem/easifem/classes +set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_CLASSES/lib +set -gx EASIFEM_EXTPKGS /Users/easifem/.easifem/easifem/extpkgs +set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_EXTPKGS/lib +set -gx EASIFEM_APP /Users/easifem/.easifem/easifem/app +set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_APP/lib +set -gx EASIFEM_MATERIALS /Users/easifem/.easifem/easifem/materials +set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_MATERIALS/lib +set -gx EASIFEM_KERNELS /Users/easifem/.easifem/easifem/kernels +set -gx LD_LIBRARY_PATH $LD_LIBRARY_PATH $EASIFEM_KERNELS/lib +set -gx PKG_CONFIG_PATH $PKG_CONFIG_PATH $EASIFEM_EXTPKGS/lib/pkgconfig +set -gx PATH $PATH $EASIFEM_EXTPKGS/bin +set -gx PATH $PATH $EASIFEM_APP/bin +``` + + + + + + + + +### Bash, Zsh shell + +If you do not want to use EASIFEM-cli, then please copy the above-mentioned template file +and place it in `.bashrc` or `.zshrc`. + +### Fish shell + +If you do not want to use EASIFEM-cli, then please copy the above-mentioned template file +and place it in `config.fish`. + + +## Setting up environment on Windows  + +Coming soon. diff --git a/pages/Extpkgs.md b/pages/Extpkgs.md new file mode 100644 index 000000000..fc4c2f298 --- /dev/null +++ b/pages/Extpkgs.md @@ -0,0 +1,20 @@ +# 𑗕 External packages + +EASIFEM depends upon the following external packages (extpkgs) that are not shipped with the source-code. + +| extpkg| description | command | +|:--- | :--- | :--- | +| [OpenBlas](https://www.openblas.net/) | Highly optimized BLAS | easifem install openblas | +| [SuperLU](https://github.com/xiaoyeli/superlu.git) | Direct solution of large, sparse, nonsymmetric systems of linear equations | easifem install superlu | +| [LIS](https://github.com/anishida/lis.git) | Linear interative solver | easifem install lis| +| [METIS](https://github.com/KarypisLab/METIS) | Mesh partitioning library | easifem install metis | +| [SCOTCH](https://gitlab.inria.fr/scotch/scotch) | Mesh partitioning library | easifem install scotch | +| [ARPACK](https://github.com/opencollab/arpack-ng) | Eigensolver for sparse matrices | easifem install arpack | +| [FFTW](https://www.fftw.org/) | Fast Fourier Transform| easifem install fftw | +| [GTK-Fortran](https://github.com/vmagnin/gtk-fortran) | Fortran bindings for GTK-4 library | easifem install gtk-fortran | +| [LAPACK95](https://github.com/vickysharma0812/LAPACK95.git) | Fortran 95 interface for Lapack library | easifem install lapack95 | +| [Sparsekit](https://github.com/vickysharma0812/Sparsekit.git) | Fortran library for sparse matrices | easifem install sparsekit | +| [Gmsh](https://gmsh.info/) | Finite element mesh generator| easifem install gmsh | + +More information about the extpkgs used in the EASIFEM are given [here.](../extpkgs/about.md) + diff --git a/pages/Install_Linux.md b/pages/Install_Linux.md new file mode 100644 index 000000000..15b0d46fa --- /dev/null +++ b/pages/Install_Linux.md @@ -0,0 +1,149 @@ +# Installation of easifemBase on Linux + +## Ubuntu + +### System requirements + +Then download the requirements by copying following code and paste it in terminal. + +```bash +sudo apt-get update && sudo apt-get install -y gfortran gcc libomp-dev curl git \ +python3 python3-pip cmake ninja-build \ +liblapack-dev libopenblas-dev libhdf5-dev \ +libplplot-dev plplot-driver-cairo libboost-all-dev \ +gnuplot doxygen libgtk-4-dev +``` + +### Install easifem CLI + +The easiest way and the recommended way to install the components of easifem is through `easifem` command line interface. + +```bash +python3 -m pip install --upgrade easifem +``` + +### Set environment variables + +After downloading the easifem CLI, we need to set three environment variables related to the location of the source files, build files, and installation of the easifem. + +You can read about the environment variables [here](./Environment.md) + +```bash +easifem setenv --install ~/.easifem/install --build ~/.easifem/build --source ~/.easifem/src +``` + +### Install External packages + +```bash +easifem install extpkgs +``` + +You can also install individual package by using following: + +```bash +easifem install openblas superlu lis metis scotch arpack fftw gtk-fortran lapack95 sparsekit gmsh +``` + +- The packages will be stored at `EASIFEM_SOURCE_DIR/extpkgs/` +- The packages will be build at `EASIFEM_BUILD_DIR/extpkgs/` +- The packages will be installed at `EASIFEM_INSTALL_DIR/extpkgs/` + +### Install easifemBase + +```bash +easifem install base +``` + +### Installation by using CMake + +Download the source code: + +```bash +git clone https://github.com/vickysharma0812/easifem-base.git +``` + +or + +```bash +git clone git@github.com:vickysharma0812/easifem-base.git +``` + +or + +```bash +gh repo clone vickysharma0812/easifem-base +``` + +After downloading the source code, enter the source directory, and make a build directory. + +```bash +cd easifem-base +mkdir ./build +``` + +EASIFEM uses CMake build system. You can install the Base library from CMake by using following steps + +1. Configuration +2. Build +3. Install + +To configure the `Base` library you can define following variables: + +| Variable | Type | Options | +| --- | --- | --- | +| USE_OpenMP | BOOL | `ON`, `OFF` | +| CMAKE_BUILD_TYPE | STRING | `Release`, `Debug` | +| BUILD_SHARED_LIBS | BOOL | `ON`, `OFF` | +| USE_PLPLOT | BOOL | `ON`, `OFF`| +| CMAKE_INSTALL_PREFIX | PATH | | +| USE_BLAS95 | BOOL | `ON`, `OFF`| +| USE_LAPACK95 | BOOL | `ON`, `OFF`| +| USE_FFTW | BOOL | `ON`, `OFF`| +| USE_GTK | BOOL | `ON`, `OFF`| +| USE_ARPACK | BOOL | `ON`, `OFF`| +| USE_SUPERLU | BOOL | `ON`, `OFF`| +| USE_LIS | BOOL | `ON`, `OFF`| +| USE_PARPACK | BOOL | `ON`, `OFF`| +| USE_METIS | BOOL | `ON`, `OFF`| +| USE_Int32 | BOOL | `ON`, `OFF`| +| USE_Real64 | BOOL | `ON`, `OFF`| + +An example of configuration step is given below: + +```bash +export EASIFEM_BASE=${HOME}/.local/easifem/base +cmake -G "Ninja" -S ./ -B ./build \ +-D USE_OpenMP:BOOL=ON \ +-D CMAKE_BUILD_TYPE:STRING=Release \ +-D BUILD_SHARED_LIBS:BOOL=ON \ +-D USE_PLPLOT:BOOL=ON \ +-D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE} \ +-D USE_BLAS95:BOOL=ON \ +-D USE_LAPACK95:BOOL=ON \ +-D USE_FFTW:BOOL=ON \ +-D USE_GTK:BOOL=ON \ +-D USE_ARPACK:BOOL=ON \ +-D USE_PARPACK:BOOL=ON \ +-D USE_METIS:BOOL=ON \ +-D USE_Int32:BOOL=ON \ +-D USE_Real64:BOOL=ON +``` + +After configuration, you can build and install the library by using: + +```bash +cmake --build ./build --target --install +``` + +## Arch Linux + +Coming soon. + +## Fedora + +Coming soon. + +## Other Linux Distro + +Coming soon. + diff --git a/pages/Install_MacOSX.md b/pages/Install_MacOSX.md new file mode 100644 index 000000000..d6590e6cd --- /dev/null +++ b/pages/Install_MacOSX.md @@ -0,0 +1,21 @@ +# Install easifemBase on MacOSX + +## System requirements + +```bash +brew install gcc +brew install gfortran +brew install libomp +brew install curl +brew install git +brew install python3 +brew install cmake +brew install ninja +brew install lapack +brew install openblas +brew install hdf5 +brew install plplot +brew install gnuplot +brew install doxygen +brew install gtk4 +``` diff --git a/pages/Install_Windows.md b/pages/Install_Windows.md new file mode 100644 index 000000000..49c641b37 --- /dev/null +++ b/pages/Install_Windows.md @@ -0,0 +1,3 @@ +# Installation of easifemBase on Windows + +Coming soon. diff --git a/pages/IntVector_.md b/pages/IntVector_.md new file mode 100644 index 000000000..3cbea32cc --- /dev/null +++ b/pages/IntVector_.md @@ -0,0 +1,106 @@ +--- +title: IntVector +author: Vikas Sharma, Ph.D. +date: 24 Feb 2021 +--- + +- [ ] TODO Finish documentation of IntVector#Set-Method and IntVector#Get-Method documentation. + +# IntVector + +!!! example "" + Intvector contains a dynamic array of rank 1 of integer type. It can be used to construct ragged vectors. Or vector or arrays of intvector. + +## Structure + +The structure of [[IntVector_]] is given below. + +```fortran +TYPE :: IntVector_ + INTEGER(I4B) :: tDimension = 1_I4B + INTEGER(I4B), ALLOCATABLE :: Val(:) +END TYPE IntVector_ +``` + +### tDimension + +Total dimension of the array, it is always one + +### Val + +Vectors of integers. + +## Constructor methods + +### Shape + +!!! note "" + Return the shape of IntVector in a fortran vector of size 1. See example [[IntVector_test_1]] + +### Size + +!!! note "" + Return the size of IntVector, If the instance of intvector is not allocated then it will return 0. See example [[IntVector_test_1]] + +### GetTotalDimension + +!!! note "" + Return a integer scalar, total dimension of IntVector. It will return 1. + See example [[IntVector_test_1]] + +### Allocate + +!!! note "" + Allocate the size of IntVector. See example [[IntVector_test_1]] + +### Deallocate + +!!! note "" + Deallocate the data stored inside IntVector. See example [[IntVector_test_1]] + +### Initiate + +!!! note "" + Initiate an instance of IntVector. See example [[IntVector_test_2]] for more details. + +### IntVector + +!!! note "" + This is a function, which returns an intance of [[IntVector_]]. You can find more details about this function here 👉⚡ [[IntVector_test_3]]. + +### IntVector_Pointer + +!!! note "" + This is a function, which returns a pointer to a newly created instance of [[IntVector_]]. You can find more details about this function here 👉⚡ [[IntVector_test_4]]. + +### isAllocated + +!!! note "" + This function returns true if the instance of intvector is allocated. See [[IntVector_test_1]] for usage. + +### isInitiated + +!!! note "" + Alias to isAllocated method. + +## IO methods + +### Display + +!!! note "" + This function displays the content of intvector. You can find more details about this function here 👉⚡ [[IntVector_test_1]] [[IntVector_test_2]] [[IntVector_test_3]] [[IntVector_test_4]]. + +## Get methods + +### Operator(.in.) + +!!! note "" + The operator (.in.) returns true if a integer set is subset of another integer set. You can find the usage and more details about this method 👉🔥 [[IntVector_test_5]] + +### Get + +!!! note "" + Returns the values stored inside intvector. See, 👉🔥 [[IntVector_test_6]] for more details. This routine has all the features of fortran for native integer vectors. + +## Set methods + diff --git a/release_install.py b/release_install.py new file mode 100755 index 000000000..29e917d2f --- /dev/null +++ b/release_install.py @@ -0,0 +1,52 @@ +#!/usr/bin/env python3 +#!/Users/easifem/anaconda3/envs/easifem/bin/python3 + +# This program is a part of EASIFEM library. +# See. www.easifem.com +# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. +# + +import os +import platform + +print("Detecting OS type...") +_os = platform.system() +if _os == "Windows": + print("ERROR: INSTALLATION on windows is work in progress") + exit + # print("Please use Windows Subsystem Linux(WSL) ") + # print("Installation DONE!!") +else: + cmake_def = "" + cmake_def += ' -G "Ninja"' # Unix Makefiles, Ninja, Ninja Multi-Config + cmake_def += " -D USE_OPENMP:BOOL=ON" # OFF + cmake_def += " -D CMAKE_BUILD_TYPE:STRING=Release" + cmake_def += " -D BUILD_SHARED_LIBS:BOOL=ON" + cmake_def += " -D USE_PLPLOT:BOOL=ON" + cmake_def += " -D CMAKE_INSTALL_PREFIX:PATH=${EASIFEM_BASE}" + cmake_def += " -D USE_BLAS95:BOOL=ON" + cmake_def += " -D USE_LAPACK95:BOOL=ON" + cmake_def += " -D USE_FFTW:BOOL=ON" + cmake_def += " -D USE_GTK:BOOL=OFF" + cmake_def += " -D USE_ARPACK:BOOL=ON" + cmake_def += " -D USE_SUPERLU:BOOL=ON" + cmake_def += " -D USE_LIS:BOOL=ON" + cmake_def += " -D USE_PARPACK:BOOL=OFF" + cmake_def += " -D USE_METIS:BOOL=OFF" + cmake_def += " -D USE_LUA:BOOL=ON" + cmake_def += " -D USE_INT32:BOOL=ON" + cmake_def += " -D USE_REAL64:BOOL=ON" + cmake_def += " -D COLOR_DISP:BOOL=OFF" + cmake_def += " -D CMAKE_EXPORT_COMPILE_COMMANDS:BOOL=ON" + + print("CMAKE DEF : ", cmake_def) + + _build0 = os.path.join(os.environ["HOME"], "temp") + build_dir = os.path.join( + os.environ.get("EASIFEM_BUILD_DIR", _build0), "easifem", "base", "build" + ) + # build_dir = os.environ["HOME"] + "/temp/easifem-base/build" + os.makedirs(build_dir, exist_ok=True) + os.system(f"cmake -S ./ -B {build_dir} {cmake_def}") + os.system(f"cmake --build {build_dir} --target install") + print("Installation DONE!!") diff --git a/selected b/selected new file mode 100644 index 000000000..e69de29bb diff --git a/setup.py b/setup.py new file mode 100644 index 000000000..361e73bae --- /dev/null +++ b/setup.py @@ -0,0 +1,76 @@ +# This program is a part of EASIFEM library. +# See. www.easifem.com +# Copyright (c) 2020-2021, All right reserved, Vikas Sharma, Ph.D. +# + +import os +import sys +import platform + +str=" _______ ___ _______. __ _______ _______ .___ ___. " +print(str) +str="| ____| / \ / || | | ____|| ____|| \/ | " +print(str) +str="| |__ / ^ \ | (----`| | | |__ | |__ | \ / | " +print(str) +str="| __| / /_\ \ \ \ | | | __| | __| | |\/| | " +print(str) +str="| |____ / _____ \ .----) | | | | | | |____ | | | |" +print(str) +str="|_______/__/ \__\ |_______/ |__| |__| |_______||__| |__|" +print(str+"\n") +str = "Expandable And Scalable Infrastrcture for Finite Element Methods" +print(str) +str = "Developed by Vikas Sharma, Ph. D." +print(str) +str = "(c) 2020-present" +print(str) +print("") +print("================================================================\n") + +def installpkgs(): + while True: + choice = input( f"Do you want to automatically Install external packages? 'yes' or 'no' [Y/n]: " ).lower() + if choice in ['Y', 'y', 'ye', 'yes']: + return True + else: + return False + +def setEnvVar(): + while True: + choice = input( f"Do you want to automatically set environment variables? 'yes' or 'no' [Y/n]: " ).lower() + if choice in ['Y', 'y', 'ye', 'yes']: + return True + else: + return False + +print("Detecting OS type...") +_os = platform.system() +if _os == 'Windows': + print("Windows platform found") + print("Setting up for Windows...") + print("ERROR: INSTALLATION on windows is work in progress") + exit + #os.system("install.bat") + print("Please use Windows Subsystem Linux(WSL) ") + print("Installation DONE!!") + +elif _os == "Darwin": + print("MacOSX system found") + print("Setting up for MacOSX...") + if( installpkgs() ): + os.system( "sh ./setup/install_pkgs_Darwin.sh" ) + if( setEnvVar() ): + os.system("sh ./setup/set_envvar_Darwin.sh") + print("Installation DONE!!") + +elif _os == "Linux": + print("Linux system found") + print("Setting up for Linux...") + if(installpkgs()): + os.system("${SHELL} ./setup/install_pkgs_Ubuntu.sh") + if(setEnvVar()): + os.system("${SHELL} ./setup/set_envvar_Ubuntu.sh") + +else: + print("ERROR: Unknown Operating System") diff --git a/setup/install_pkgs_Darwin.sh b/setup/install_pkgs_Darwin.sh new file mode 100644 index 000000000..1967dfe5e --- /dev/null +++ b/setup/install_pkgs_Darwin.sh @@ -0,0 +1,40 @@ +#!/bin/sh +# This is a setup script for installing EASIFEM-base library. +# (c) 2021, Dr Vikas Sharma, all rights reserved +# +# +# Log (dd/mm/yyyy) +# 15/02/2021 this document was created +# +#-------------------------------------------------------------- + +/bin/bash -c "$(curl -fsSL https://raw.githubusercontent.com/Homebrew/install/HEAD/install.sh)" + +echo "==========================================" +echo "brew install curl" +brew install curl +echo "==========================================" +echo "brew install git" +brew install git +echo "==========================================" +echo "brew install gcc" +brew install gcc +echo "==========================================" +echo "brew install gfortran" +brew install gfortran +echo "==========================================" +echo "brew install python3" +brew install python3 +echo "==========================================" +echo "brew install lapack" +brew install lapack +echo "==========================================" +echo "brew install cmake" +brew install cmake +echo "==========================================" +echo "brew install gmsh" +brew install gmsh +echo "==========================================" +echo "brew install gnuplot" +brew install gnuplot +echo "==========================================" diff --git a/setup/install_pkgs_Ubuntu.sh b/setup/install_pkgs_Ubuntu.sh new file mode 100644 index 000000000..92ee0db39 --- /dev/null +++ b/setup/install_pkgs_Ubuntu.sh @@ -0,0 +1,58 @@ +#!/bin/sh +# This program is a part of EASIFEM library +# # Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# This program is free software: you can redistribute it and/or modify +# under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# You should have received a copy of the GNU General Public License +# along with this program. If not, see + + +#sh -c "$(curl -fsSL https://api.cacher.io/raw/41c42c3479fa291be9d8/f7f3a874cad01c19127f/install_pkgs.sh)" + +# go to home +cd ${HOME} + +# run update and upgrade +echo "[try:] apt update" +sudo apt update +if [ $? -eq 0 ] ; then echo 'apt update [OK!]' ; else echo 'apt update [FAILED!]'; exit ; fi +echo "[try:] apt upgrade" +sudo apt upgrade +if [ $? -eq 0 ] ; then echo 'apt upgrade [OK!]' ; else echo 'apt upgrade [FAILED!]'; exit ; fi +# +# +# Install pkgs here +# +# sudo apt install -y gmsh +# sudo apt install -y gnuplot +# +pkg="curl git neovim zsh gfortran gcc g++ python3 python3-pip liblapack-dev libopenblas-dev" +echo "[try:] apt install -y ${pkg}" +sudo apt install -y ${pkg} +if [ $? -eq 0 ] ; then echo "${pkg} install [SUCCESSFUL!]" ; else echo "${pkg} install [FAILED!]"; exit ; fi +# +# Install cmake from pip +# +pip3 install cmake +# +# install spacevim +# +# +# +mkdir -p ${HOME}/.SpaceVim.d +echo "Download init.toml" +url="https://api.cacher.io/raw/5f5dd01fcf10a2d39603/6385a7e389aafd0c99c6/init.toml" +curl -o ${HOME}/.SpaceVim.d/init.toml ${url} +url="https://spacevim.org/install.sh" +# +# oh-my-zsh +# +sudo chsh -s /bin/zsh +url="https://raw.githubusercontent.com/ohmyzsh/ohmyzsh/master/tools/install.sh" +sh -c "$(curl -fsSL ${url})" diff --git a/setup/requirements.txt b/setup/requirements.txt new file mode 100644 index 000000000..197db5f37 --- /dev/null +++ b/setup/requirements.txt @@ -0,0 +1,11 @@ +numpy +scipy +matplotlib +jupyter +jupyterlab +plotly +dash +seaborn +pillow +opencv-python +pandas \ No newline at end of file diff --git a/setup/set_envvar_CentOS.sh b/setup/set_envvar_CentOS.sh new file mode 100644 index 000000000..e69de29bb diff --git a/setup/set_envvar_Darwin.sh b/setup/set_envvar_Darwin.sh new file mode 100644 index 000000000..0c952dcfa --- /dev/null +++ b/setup/set_envvar_Darwin.sh @@ -0,0 +1,72 @@ +#!/bin/sh +# This is a setup script for installing EASIFEM-base library. +# (c) 2021, Dr Vikas Sharma, all rights reserved +# +# +# Log (dd/mm/yyyy) +# 15/02/2021 this document was created +# +#-------------------------------------------------------------- + +SHELL_=${SHELL} +if [[ $SHELL_ =~ .*zsh.* ]]; then + BP=${HOME}/.zshrc +fi +if [[ $SHELL_ =~ .*bash.* ]]; then + BP=${HOME}/.bashrc +fi +echo $BP + +if [ -f "$BP" ]; then + echo "${BP} found" +else + touch ${BP} + echo '#!/bin/sh' >> ${BP} +fi + +ERC=${HOME}/.easifemrc +if [ -f "$ERC" ]; then + echo "${ERC} found, removing it" + rm -rf ${ERC} + touch ${ERC} + echo '#!/bin/sh' >> ${ERC} +else + touch ${ERC} + echo '#!/bin/sh' >> ${ERC} +fi + +prefix=${HOME} +export EASIFEM_BASE=${prefix}/.easifem/base/ +export EASIFEM_CLASSES=${prefix}/.easifem/classes/ +export EASIFEM_KERNEL=${prefix}/.easifem/kernel/ +export EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs/ +echo "${EASIFEM_BASE}" +mkdir -p ${EASIFEM_EXTPKGS} +mkdir -p ${EASIFEM_BASE} +mkdir -p ${EASIFEM_CLASSES} +mkdir -p ${EASIFEM_KERNEL} + +echo "easifem_prefix=${prefix}" >> ${ERC} +echo "export EASIFEM_BASE=${prefix}/.easifem/base/" >> ${ERC} +echo "export EASIFEM_CLASSES=${prefix}/.easifem/classes/" >> ${ERC} +echo "export EASIFEM_KERNEL=${prefix}/.easifem/kernel/" >> ${ERC} +echo "export EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs/" >> ${ERC} +echo "mkdir -p ${EASIFEM_EXTPKGS}" >> ${ERC} +echo "mkdir -p ${EASIFEM_BASE}" >> ${ERC} +echo "mkdir -p ${EASIFEM_CLASSES}" >> ${ERC} +echo "mkdir -p ${EASIFEM_KERNEL}" >> ${ERC} + +echo "export CC=/usr/local/bin/gcc-10" >> ${ERC} +echo "export CXX=/usr/local/bin/g++-10" >> ${ERC} +echo "export CPP=/usr/local/bin/cpp-10" >> ${ERC} +echo "export LD=/usr/local/bin/gcc-10" >> ${ERC} +echo "export FC=/usr/local/bin/gfortran-10" >> ${ERC} +echo "alias c++=/usr/local/bin/c++-10" >> ${ERC} +echo "alias g++=/usr/local/bin/g++-10" >> ${ERC} +echo "alias gcc=/usr/local/bin/gcc-10" >> ${ERC} +echo "alias cpp=/usr/local/bin/cpp-10" >> ${ERC} +echo "alias ld=/usr/local/bin/gcc-10" >> ${ERC} +echo "alias cc=/usr/local/bin/gcc-10" >> ${ERC} +echo "alias gfortran=/usr/local/bin/gfortran-10" >> ${ERC} +echo "source ${ERC}" >> ${BP} +source ${BP} \ No newline at end of file diff --git a/setup/set_envvar_Ubuntu.sh b/setup/set_envvar_Ubuntu.sh new file mode 100644 index 000000000..5ddb0ec5e --- /dev/null +++ b/setup/set_envvar_Ubuntu.sh @@ -0,0 +1,70 @@ +#!/bin/sh +# This is a setup script for installing EASIFEM-base library. +# (c) 2021, Dr Vikas Sharma, all rights reserved +# +# +# Log (dd/mm/yyyy) +# 15/02/2021 this document was created +# +#-------------------------------------------------------------- + +#!/bin/sh +# This is a setup script for installing EASIFEM-base library. +# (c) 2021, Dr Vikas Sharma, all rights reserved +# +# +# Log (dd/mm/yyyy) +# 15/02/2021 this document was created +# +#-------------------------------------------------------------- + +SHELL_=${SHELL} +if [[ $SHELL_ =~ .*zsh.* ]] +then + BP=${HOME}/.zshrc +fi +if [[ $SHELL_ =~ .*bash.* ]] +then + BP=${HOME}/.bashrc +fi + +if [ -f "${BP}" ] +then + echo "${BP} found" +else + touch ${BP} + echo '#!/bin/sh' >> ${BP} +fi + +ERC=${HOME}/.easifemrc +if [ -f "$ERC" ] +then + echo "${ERC} found, removing it" + rm -rf ${ERC} + touch ${ERC} + echo '#!/bin/sh' >> ${ERC} +else + touch ${ERC} + echo '#!/bin/sh' >> ${ERC} +fi + +prefix=${HOME} +EASIFEM_BASE=${prefix}/.easifem/base +EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs +EASIFEM_CLASSES=${prefix}/.easifem/classes +EASIFEM_MATERIALS=${prefix}/.easifem/materials +EASIFEM_KERNELS=${prefix}/.easifem/kernels + +echo "export EASIFEM_BASE=${prefix}/.easifem/base" >> ${ERC} +echo "export EASIFEM_EXTPKGS=${prefix}/.easifem/extpkgs" >> ${ERC} +echo "export EASIFEM_CLASSES=${prefix}/.easifem/classes" >> ${ERC} +echo "export EASIFEM_MATERIALS=${prefix}/.easifem/materials" >> ${ERC} +echo "export EASIFEM_KERNELS=${prefix}/.easifem/kernels" >> ${ERC} + +echo "mkdir -p ${EASIFEM_EXTPKGS}" >> ${ERC} +echo "mkdir -p ${EASIFEM_BASE}" >> ${ERC} +echo "mkdir -p ${EASIFEM_CLASSES}" >> ${ERC} +echo "mkdir -p ${EASIFEM_KERNELS}" >> ${ERC} + +echo "source ${ERC}" >> ${BP} +source ${BP} diff --git a/src/modules/ARPACK/CMakeLists.txt b/src/modules/ARPACK/CMakeLists.txt new file mode 100644 index 000000000..b9e42666e --- /dev/null +++ b/src/modules/ARPACK/CMakeLists.txt @@ -0,0 +1,24 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/EASIFEM_F77_ARPACK.F90 + ${src_path}/ARPACK_SAUPD.F90 + ${src_path}/EASIFEM_ARPACK.F90 +) \ No newline at end of file diff --git a/src/modules/ARPACK/src/ARPACK_SAUPD.F90 b/src/modules/ARPACK/src/ARPACK_SAUPD.F90 new file mode 100644 index 000000000..22340fb10 --- /dev/null +++ b/src/modules/ARPACK/src/ARPACK_SAUPD.F90 @@ -0,0 +1,253 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE ARPACK_SAUPD +USE GlobalData, ONLY: I4B, DFP, LGT +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! SAUPD_ErrorMsg +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION SAUPD_ErrorMsg(INFO) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: INFO + TYPE(String) :: ans + END FUNCTION SAUPD_ErrorMsg +END INTERFACE + +PUBLIC :: SAUPD_ErrorMsg + +!---------------------------------------------------------------------------- +! SAUPD_ErrorMsg +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION SEUPD_ErrorMsg(INFO) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: INFO + TYPE(String) :: ans + END FUNCTION SEUPD_ErrorMsg +END INTERFACE + +PUBLIC :: SEUPD_ErrorMsg + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the largest eigenvalue of a real sym dense matrix +! +!# Introduction +! +!- This routine calculates the largest eigenvalue of a real sym dense matrix. +!- It calls ARPACK SSAUPD or DSAUPD routine + +INTERFACE + MODULE FUNCTION SymLargestEigenVal1(mat, which, NCV, maxIter, tol) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(:, :) + !! dense matrix + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "LM"` ⇨ absolute largest eigenvalue + !! `which = "LA"` ⇨ algebraic largest eigenvalue + !! default is "LA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, 20)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans + !! maximum eigenvalue + END FUNCTION SymLargestEigenVal1 +END INTERFACE + +INTERFACE SymLargestEigenVal + MODULE PROCEDURE SymLargestEigenVal1 +END INTERFACE SymLargestEigenVal + +PUBLIC :: SymLargestEigenVal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the `nev` smallest eigenvalue of a real sym dense matrix +! +!# Introduction +! +!- This routine calculates the smallest eigenvalue of a real sym dense matrix. +!- It calls ARPACK SSAUPD or DSAUPD routine + +INTERFACE + MODULE FUNCTION SymLargestEigenVal2(mat, nev, which, NCV, maxIter, tol) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(:, :) + !! dense matrix + INTEGER(I4B), INTENT(IN) :: nev + !! number of eigenvalues requested + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "LM"` ⇨ absolute largest eigenvalue + !! `which = "LA"` ⇨ algebraic largest eigenvalue + !! default is "LA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, MAX(2*nev+1, 20))` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans(nev) + !! first k, largest eigenvalue + END FUNCTION SymLargestEigenVal2 +END INTERFACE + +INTERFACE SymLargestEigenVal + MODULE PROCEDURE SymLargestEigenVal2 +END INTERFACE SymLargestEigenVal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the smallest eigenvalue of a real sym dense matrix +! +!# Introduction +! +!- This routine calculates the smallest eigenvalue of a real sym dense matrix. +!- It calls ARPACK SSAUPD or DSAUPD routine with MODE=3 +! +! In this routine we use shift-inverted method to compute the +! smallest eigenvalue of a regular (standard) eigenvalue problem. This is +! because `ARPACK` is good at finding the largest eigenvalue. +! +! Internally this routine solves a system of linear equations: `mat * y = x` +! by using LU decomposition. +! +! In this routine we make a call to LUSolve and getLU routine. +! +!@note +! In this routine we make a copy of mat in mat0. Then, compute the LU +! decomposition of mat0. +!@endnote + +INTERFACE + MODULE FUNCTION SymSmallestEigenVal1(mat, sigma, which, NCV, maxIter, tol) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(:, :) + !! dense matrix + REAL(DFP), OPTIONAL, INTENT(IN) :: sigma + !! Default value is 0.0 + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "SM"` ⇨ absolute smallest eigenvalue + !! `which = "SA"` ⇨ algebraic smallest eigenvalue + !! default is "SA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, 20)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans + !! maximum eigenvalue + END FUNCTION SymSmallestEigenVal1 +END INTERFACE + +INTERFACE SymSmallestEigenVal + MODULE PROCEDURE SymSmallestEigenVal1 +END INTERFACE SymSmallestEigenVal + +PUBLIC :: SymSmallestEigenVal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the smallest eigenvalue of a real sym dense matrix +! +!# Introduction +! +! This routine is similar to SysSmallestEigenVal1() +! In this routine you can pass a factorized matrix `mat` and set `isLU=true` +! Then, this routine will not perform LU decomposition on mat. +! +! However, if `isLU=false`, then we will change mat, and on return +! it will contain the LU factorization of `mat` +! +!- [ ] TODO use Cholsky factorization instead of LU as mat is +! symmetric. +! + +INTERFACE + MODULE FUNCTION SymSmallestEigenVal2(mat, isFactor, ipiv, sigma, which, & + & NCV, maxIter, tol) & + & RESULT(ans) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + !! + !! Dense matrix + !! If isFactor is false, then this matrix will change on return + !! in this case, it will contain LU decomposition of `A-sigma*I` + !! If isFactor is true, then this matrix will not change + !! + LOGICAL(LGT), INTENT(INOUT) :: isFactor + !! if mat is already factorized, the set isFactor to true + !! if mat is not factorized, then set isFactor to false + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipiv(:) + !! When `isFactor` is true, then `mat` represents the + !! `LU` factorization of `A-sigma*I` obtained by `SymGetLU` routine. + !! In this case `ipiv` is returned by `SymGetLU`. + REAL(DFP), OPTIONAL, INTENT(IN) :: sigma + !! Default value is 0.0 + !! Sigma is ignored when isFactor=true. Because in this case + !! mat represents LU factorization of `A-sigma*I` + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "SM"` ⇨ absolute smallest eigenvalue + !! `which = "SA"` ⇨ algebraic smallest eigenvalue + !! default is "SA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, 20)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans + !! smallest eigenvalue + END FUNCTION SymSmallestEigenVal2 +END INTERFACE + +INTERFACE SymSmallestEigenVal + MODULE PROCEDURE SymSmallestEigenVal2 +END INTERFACE SymSmallestEigenVal + +END MODULE ARPACK_SAUPD diff --git a/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 b/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 new file mode 100644 index 000000000..f75ac9037 --- /dev/null +++ b/src/modules/ARPACK/src/EASIFEM_ARPACK.F90 @@ -0,0 +1,25 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-09 +! summary: This module contains interface to ARPACK lib. + +MODULE EASIFEM_ARPACK +USE EASIFEM_F77_ARPACK +USE ARPACK_SAUPD +END MODULE EASIFEM_ARPACK diff --git a/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 b/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 new file mode 100644 index 000000000..30da97cf1 --- /dev/null +++ b/src/modules/ARPACK/src/EASIFEM_F77_ARPACK.F90 @@ -0,0 +1,158 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 EASIFEM_F77_ARPACK +USE GlobalData, ONLY: I4B, Real32, Real64 +IMPLICIT NONE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE F77_SAUPD + + SUBROUTINE SSAUPD(ido, bmat, n, which, nev, tol, resid, ncv, & + & v, ldv, iparam, ipntr, workd, workl, lworkl, info) + !! + IMPORT :: I4B, Real32 + INTEGER(I4B), PARAMETER :: DFP = Real32 + INTEGER(I4B), INTENT(INOUT) :: ido + CHARACTER(LEN=1), INTENT(IN) :: bmat + INTEGER(I4B), INTENT(IN) :: n + CHARACTER(LEN=2), INTENT(IN) :: which + INTEGER(I4B), INTENT(IN) :: nev + REAL(DFP), INTENT(IN) :: tol + REAL(DFP), INTENT(INOUT) :: resid(:) + INTEGER(I4B), INTENT(IN) :: ncv + REAL(DFP), INTENT(INOUT) :: v(:, :) + INTEGER(I4B), INTENT(IN) :: ldv + INTEGER(I4B), INTENT(INOUT) :: iparam(11) + INTEGER(I4B), INTENT(INOUT) :: ipntr(11) + REAL(DFP), INTENT(INOUT) :: workd(:) + INTEGER(I4B), INTENT(IN) :: lworkl + REAL(DFP), INTENT(INOUT) :: workl(:) + INTEGER(I4B), INTENT(INOUT) :: info + END SUBROUTINE SSAUPD + + SUBROUTINE DSAUPD(ido, bmat, n, which, nev, tol, resid, ncv, & + & v, ldv, iparam, ipntr, workd, workl, lworkl, info) + !! + IMPORT :: I4B, Real64 + INTEGER(I4B), PARAMETER :: DFP = Real64 + INTEGER(I4B) :: ido + CHARACTER(LEN=1) :: bmat + INTEGER(I4B) :: n + CHARACTER(LEN=2) :: which + INTEGER(I4B) :: nev + REAL(DFP) :: tol + REAL(DFP) :: resid(n) + INTEGER(I4B) :: ncv + REAL(DFP) :: v(n, ncv) + INTEGER(I4B) :: ldv + INTEGER(I4B) :: iparam(11) + INTEGER(I4B) :: ipntr(11) + REAL(DFP) :: workd(3 * n) + INTEGER(I4B) :: lworkl + REAL(DFP) :: workl(lworkl) + INTEGER(I4B) :: info + END SUBROUTINE DSAUPD + +END INTERFACE F77_SAUPD + +PUBLIC :: F77_SAUPD + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE F77_SEUPD + + SUBROUTINE SSEUPD(rvec, howmny, select, d, & + & z, ldz, sigma, bmat,& + & n, which, nev, tol,& + & resid, ncv, v, ldv,& + & iparam, ipntr, workd, workl,& + & lworkl, info) + !! + USE GlobalData, ONLY: I4B, DFP => Real32, LGT + !! + LOGICAL(LGT) :: rvec + CHARACTER(LEN=*) :: howmny + INTEGER(I4B) :: ncv + LOGICAL(LGT) :: select(:) + INTEGER(I4B) :: nev + REAL(DFP) :: d(nev) + INTEGER(I4B) :: n + REAL(DFP) :: z(n, nev) + INTEGER(I4B) :: ldz + REAL(DFP) :: sigma + CHARACTER(LEN=*) :: bmat + CHARACTER(LEN=*) :: which + REAL(DFP) :: tol + REAL(DFP) :: resid(n) + REAL(DFP) :: v(n, ncv) + INTEGER(I4B) :: ldv + INTEGER(I4B) :: iparam(11) + INTEGER(I4B) :: ipntr(11) + REAL(DFP) :: workd(3 * n) + INTEGER(I4B) :: lworkl + REAL(DFP) :: workl(lworkl) + INTEGER(I4B) :: info + END SUBROUTINE SSEUPD + + SUBROUTINE DSEUPD(rvec, howmny, select, d, & + & z, ldz, sigma, bmat,& + & n, which, nev, tol,& + & resid, ncv, v, ldv,& + & iparam, ipntr, workd, workl,& + & lworkl, info) + !! + USE GlobalData, ONLY: I4B, DFP => Real64, LGT + !! + LOGICAL(LGT) :: rvec + CHARACTER(LEN=*) :: howmny + INTEGER(I4B) :: ncv + LOGICAL(LGT) :: select(:) + INTEGER(I4B) :: nev + REAL(DFP) :: d(nev) + INTEGER(I4B) :: n + REAL(DFP) :: z(n, nev) + INTEGER(I4B) :: ldz + REAL(DFP) :: sigma + CHARACTER(LEN=*) :: bmat + CHARACTER(LEN=*) :: which + REAL(DFP) :: tol + REAL(DFP) :: resid(n) + REAL(DFP) :: v(n, ncv) + INTEGER(I4B) :: ldv + INTEGER(I4B) :: iparam(11) + INTEGER(I4B) :: ipntr(11) + REAL(DFP) :: workd(3 * n) + INTEGER(I4B) :: lworkl + REAL(DFP) :: workl(lworkl) + INTEGER(I4B) :: info + END SUBROUTINE DSEUPD + +END INTERFACE F77_SEUPD + +PUBLIC :: F77_SEUPD + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE EASIFEM_F77_ARPACK diff --git a/src/modules/BLAS95/CMakeLists.txt b/src/modules/BLAS95/CMakeLists.txt new file mode 100644 index 000000000..a9ad14950 --- /dev/null +++ b/src/modules/BLAS95/CMakeLists.txt @@ -0,0 +1,26 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +IF( USE_BLAS95 ) + LIST( APPEND TARGET_COMPILE_DEF "-DUSE_BLAS95" ) + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/F77_BLAS.F90 + ${src_path}/F95_BLAS.F90 + ) +ENDIF() diff --git a/src/modules/BLAS95/aux/blas95.lst b/src/modules/BLAS95/aux/blas95.lst new file mode 100755 index 000000000..5227182e0 --- /dev/null +++ b/src/modules/BLAS95/aux/blas95.lst @@ -0,0 +1,219 @@ +#=============================================================================== +# Copyright 2006-2020 Intel Corporation. +# +# This software and the related documents are Intel copyrighted materials, and +# your !USE of them is governed by the express license under which they were +# provided to you (License). Unless the License provides otherwise, you may not +# !USE, modify, copy, publish, distribute, disclose or transmit this software or +# the related documents without Intel's prior written permission. +# +# This software and the related documents are provided as is, with no express +# or implied warranties, other than those that are expressly stated in the +# License. +#=============================================================================== + +src_blas95 = \ +caxpby.F90 \ +caxpy.F90 \ +caxpyi.F90 \ +ccopy.F90 \ +cdotc.F90 \ +cdotci.F90 \ +cdotu.F90 \ +cdotui.F90 \ +cgbmv.F90 \ +cgem2vc.F90 \ +cgemm.F90 \ +cgemm_batch.F90 \ +cgemm3m.F90 \ +cgemm3m_batch.F90 \ +cgemmt.F90 \ +cgemv.F90 \ +cgerc.F90 \ +cgeru.F90 \ +cgthr.F90 \ +cgthrz.F90 \ +chbmv.F90 \ +chemm.F90 \ +chemv.F90 \ +cher.F90 \ +cher2.F90 \ +cher2k.F90 \ +cherk.F90 \ +chpmv.F90 \ +chpr.F90 \ +chpr2.F90 \ +crotg.F90 \ +cscal.F90 \ +csctr.F90 \ +csrot.F90 \ +csscal.F90 \ +cswap.F90 \ +csymm.F90 \ +csyr2k.F90 \ +csyrk.F90 \ +ctbmv.F90 \ +ctbsv.F90 \ +ctpmv.F90 \ +ctpsv.F90 \ +ctrmm.F90 \ +ctrmv.F90 \ +ctrsm.F90 \ +ctrsm_batch.F90 \ +ctrsv.F90 \ +dasum.F90 \ +daxpby.F90 \ +daxpy.F90 \ +daxpyi.F90 \ +dcabs1.F90 \ +dcopy.F90 \ +ddot.F90 \ +ddoti.F90 \ +dgbmv.F90 \ +dgem2vu.F90 \ +dgemm.F90 \ +dgemm_batch.F90 \ +dgemmt.F90 \ +dgemv.F90 \ +dger.F90 \ +dgthr.F90 \ +dgthrz.F90 \ +dnrm2.F90 \ +drot.F90 \ +droti.F90 \ +drotm.F90 \ +drotmg.F90 \ +drotg.F90 \ +dsbmv.F90 \ +dscal.F90 \ +dsctr.F90 \ +dsdot.F90 \ +dspmv.F90 \ +dspr.F90 \ +dspr2.F90 \ +dswap.F90 \ +dsymm.F90 \ +dsymv.F90 \ +dsyr.F90 \ +dsyr2.F90 \ +dsyr2k.F90 \ +dsyrk.F90 \ +dtbmv.F90 \ +dtbsv.F90 \ +dtpmv.F90 \ +dtpsv.F90 \ +dtrmm.F90 \ +dtrmv.F90 \ +dtrsm.F90 \ +dtrsm_batch.F90 \ +dtrsv.F90 \ +dzasum.F90 \ +dzgemm.F90 \ +dzgemv.F90 \ +dznrm2.F90 \ +icamax.F90 \ +icamin.F90 \ +idamax.F90 \ +idamin.F90 \ +isamax.F90 \ +isamin.F90 \ +izamax.F90 \ +izamin.F90 \ +sasum.F90 \ +saxpby.F90 \ +saxpy.F90 \ +saxpyi.F90 \ +scasum.F90 \ +scgemm.F90 \ +scgemv.F90 \ +scnrm2.F90 \ +scopy.F90 \ +scabs1.F90 \ +sdot.F90 \ +sdoti.F90 \ +sdsdot.F90 \ +sgbmv.F90 \ +sgem2vu.F90 \ +sgemm.F90 \ +sgemm_batch.F90 \ +sgemmt.F90 \ +sgemv.F90 \ +sger.F90 \ +sgthr.F90 \ +sgthrz.F90 \ +snrm2.F90 \ +srot.F90 \ +sroti.F90 \ +srotm.F90 \ +srotmg.F90 \ +srotg.F90 \ +ssbmv.F90 \ +sscal.F90 \ +ssctr.F90 \ +sspmv.F90 \ +sspr.F90 \ +sspr2.F90 \ +sswap.F90 \ +ssymm.F90 \ +ssymv.F90 \ +ssyr.F90 \ +ssyr2.F90 \ +ssyr2k.F90 \ +ssyrk.F90 \ +stbmv.F90 \ +stbsv.F90 \ +stpmv.F90 \ +stpsv.F90 \ +strmm.F90 \ +strmv.F90 \ +strsm.F90 \ +strsm_batch.F90 \ +strsv.F90 \ +zaxpby.F90 \ +zaxpy.F90 \ +zaxpyi.F90 \ +zcopy.F90 \ +zdotc.F90 \ +zdotci.F90 \ +zdotu.F90 \ +zdotui.F90 \ +zdrot.F90 \ +zdscal.F90 \ +zgbmv.F90 \ +zgem2vc.F90 \ +zgemm.F90 \ +zgemm_batch.F90 \ +zgemm3m.F90 \ +zgemm3m_batch.F90 \ +zgemmt.F90 \ +zgemv.F90 \ +zgerc.F90 \ +zgeru.F90 \ +zgthr.F90 \ +zgthrz.F90 \ +zhbmv.F90 \ +zhemm.F90 \ +zhemv.F90 \ +zher.F90 \ +zher2.F90 \ +zher2k.F90 \ +zherk.F90 \ +zhpmv.F90 \ +zhpr.F90 \ +zhpr2.F90 \ +zrotg.F90 \ +zscal.F90 \ +zsctr.F90 \ +zswap.F90 \ +zsymm.F90 \ +zsyr2k.F90 \ +zsyrk.F90 \ +ztbmv.F90 \ +ztbsv.F90 \ +ztpmv.F90 \ +ztpsv.F90 \ +ztrmm.F90 \ +ztrmv.F90 \ +ztrsm.F90 \ +ztrsm_batch.F90 \ +ztrsv.F90 \ \ No newline at end of file diff --git a/src/modules/BLAS95/aux/test.F90 b/src/modules/BLAS95/aux/test.F90 new file mode 100644 index 000000000..b70ebaffe --- /dev/null +++ b/src/modules/BLAS95/aux/test.F90 @@ -0,0 +1,21 @@ +program main +implicit none + +integer :: in, out, iostat, len +character( len = 1000 ) temp + +open( newunit = in, file = '../src/blas95.lst', status="old", & + & action="read" ) + +open( newunit = out, file = './EASIFEM_BLAS.F90', status="replace", & + & action="write" ) + +DO +read( in, *, IOSTAT=iostat) temp +len = LEN_TRIM(temp) +if(temp(1:1) .eq. '#') cycle +write( out, "(A)" ) '#include "./' // temp(1:len) // '"' +if( iostat .LT. 0 ) exit +END DO + +end program main \ No newline at end of file diff --git a/src/modules/BLAS95/src/F77_BLAS.F90 b/src/modules/BLAS95/src/F77_BLAS.F90 new file mode 100755 index 000000000..e6a67a7cb --- /dev/null +++ b/src/modules/BLAS95/src/F77_BLAS.F90 @@ -0,0 +1,2590 @@ +!============================================================================ +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, +! and your !USE of them is governed by the express license under which +! they were provided to you (License). Unless the License provides +! otherwise, you may not +! USE, modify, copy, publish, distribute, +! disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with +! no express +! or implied warranties, other than those that are expressly +! stated in the +! License. +!============================================================================ +! Content: +! Intel(R) MKL BLAS77 interface as prototypes for +! Intel(R) MKL BLAS95 interfaces +! + +MODULE F77_BLAS +IMPLICIT NONE + +INTERFACE F77_XERBLA + PURE SUBROUTINE XERBLA(NAME, INFO) + CHARACTER(LEN=*), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: INFO + END SUBROUTINE XERBLA +END INTERFACE F77_XERBLA + +! BLAS level 1 +INTERFACE F77_ASUM + PURE FUNCTION SASUM(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SASUM + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION SASUM + PURE FUNCTION SCASUM(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SCASUM + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION SCASUM + PURE FUNCTION DASUM(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DASUM + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION DASUM + PURE FUNCTION DZASUM(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DZASUM + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION DZASUM +END INTERFACE F77_ASUM + +INTERFACE F77_AXPY + PURE SUBROUTINE SAXPY(N, A, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SAXPY + PURE SUBROUTINE DAXPY(N, A, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DAXPY + PURE SUBROUTINE CAXPY(N, A, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CAXPY + PURE SUBROUTINE ZAXPY(N, A, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZAXPY +END INTERFACE F77_AXPY + +INTERFACE F77_COPY + PURE SUBROUTINE SCOPY(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SCOPY + PURE SUBROUTINE DCOPY(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DCOPY + PURE SUBROUTINE CCOPY(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CCOPY + PURE SUBROUTINE ZCOPY(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZCOPY +END INTERFACE F77_COPY + +INTERFACE F77_DOT + PURE FUNCTION SDOT(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SDOT + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION SDOT + PURE FUNCTION DDOT(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DDOT + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION DDOT +END INTERFACE F77_DOT + +INTERFACE F77_SDOT + PURE FUNCTION SDSDOT(N, SB, SX, INCX, SY, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SDSDOT + REAL(WP), INTENT(IN) :: SX(*) + REAL(WP), INTENT(IN) :: SY(*) + REAL(WP), INTENT(IN) :: SB + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION SDSDOT + PURE FUNCTION DSDOT(N, SX, INCX, SY, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, PARAMETER :: SP = KIND(1.0E0) + REAL(WP) :: DSDOT + REAL(SP), INTENT(IN) :: SX(*) + REAL(SP), INTENT(IN) :: SY(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION DSDOT +END INTERFACE F77_SDOT + +INTERFACE F77_DOTC + PURE FUNCTION CDOTC(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTC + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION CDOTC + PURE FUNCTION ZDOTC(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTC + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION ZDOTC +END INTERFACE F77_DOTC + +INTERFACE F77_DOTU + PURE FUNCTION CDOTU(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTU + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION CDOTU + PURE FUNCTION ZDOTU(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTU + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END FUNCTION ZDOTU +END INTERFACE F77_DOTU + +INTERFACE F77_NRM2 + PURE FUNCTION SNRM2(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SNRM2 + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION SNRM2 + PURE FUNCTION DNRM2(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DNRM2 + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION DNRM2 + PURE FUNCTION SCNRM2(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SCNRM2 + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION SCNRM2 + PURE FUNCTION DZNRM2(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DZNRM2 + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION DZNRM2 +END INTERFACE F77_NRM2 + +INTERFACE F77_ROT + PURE SUBROUTINE SROT(N, X, INCX, Y, INCY, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SROT + PURE SUBROUTINE DROT(N, X, INCX, Y, INCY, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DROT + PURE SUBROUTINE CSROT(N, X, INCX, Y, INCY, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CSROT + PURE SUBROUTINE ZDROT(N, X, INCX, Y, INCY, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZDROT +END INTERFACE F77_ROT + +INTERFACE F77_ROTG + PURE SUBROUTINE SROTG(A, B, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: A + REAL(WP), INTENT(INOUT) :: B + REAL(WP), INTENT(OUT) :: C + REAL(WP), INTENT(OUT) :: S + END SUBROUTINE SROTG + PURE SUBROUTINE DROTG(A, B, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: A + REAL(WP), INTENT(INOUT) :: B + REAL(WP), INTENT(OUT) :: C + REAL(WP), INTENT(OUT) :: S + END SUBROUTINE DROTG + PURE SUBROUTINE CROTG(A, B, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(INOUT) :: A + COMPLEX(WP), INTENT(INOUT) :: B + REAL(WP), INTENT(OUT) :: C + COMPLEX(WP), INTENT(OUT) :: S + END SUBROUTINE CROTG + PURE SUBROUTINE ZROTG(A, B, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(INOUT) :: A + COMPLEX(WP), INTENT(INOUT) :: B + REAL(WP), INTENT(OUT) :: C + COMPLEX(WP), INTENT(OUT) :: S + END SUBROUTINE ZROTG +END INTERFACE F77_ROTG + +INTERFACE F77_ROTM + PURE SUBROUTINE SROTM(N, X, INCX, Y, INCY, PARAM) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: PARAM(5) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SROTM + PURE SUBROUTINE DROTM(N, X, INCX, Y, INCY, PARAM) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: PARAM(5) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DROTM +END INTERFACE F77_ROTM + +INTERFACE F77_ROTMG + PURE SUBROUTINE SROTMG(D1, D2, X1, Y1, PARAM) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: D1 + REAL(WP), INTENT(INOUT) :: D2 + REAL(WP), INTENT(INOUT) :: X1 + REAL(WP), INTENT(IN) :: Y1 + REAL(WP), INTENT(OUT) :: PARAM(5) + END SUBROUTINE SROTMG + PURE SUBROUTINE DROTMG(D1, D2, X1, Y1, PARAM) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: D1 + REAL(WP), INTENT(INOUT) :: D2 + REAL(WP), INTENT(INOUT) :: X1 + REAL(WP), INTENT(IN) :: Y1 + REAL(WP), INTENT(OUT) :: PARAM(5) + END SUBROUTINE DROTMG +END INTERFACE F77_ROTMG + +INTERFACE F77_SCAL + PURE SUBROUTINE SSCAL(N, A, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSCAL + PURE SUBROUTINE DSCAL(N, A, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSCAL + PURE SUBROUTINE CSCAL(N, A, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + COMPLEX(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CSCAL + PURE SUBROUTINE ZSCAL(N, A, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + COMPLEX(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZSCAL + PURE SUBROUTINE CSSCAL(N, A, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CSSCAL + PURE SUBROUTINE ZDSCAL(N, A, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZDSCAL +END INTERFACE F77_SCAL + +INTERFACE F77_SWAP + PURE SUBROUTINE SSWAP(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSWAP + PURE SUBROUTINE DSWAP(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSWAP + PURE SUBROUTINE CSWAP(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CSWAP + PURE SUBROUTINE ZSWAP(N, X, INCX, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(INOUT) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZSWAP +END INTERFACE F77_SWAP + +INTERFACE F77_IAMAX + PURE FUNCTION ISAMAX(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ISAMAX + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION ISAMAX + PURE FUNCTION IDAMAX(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IDAMAX + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION IDAMAX + PURE FUNCTION ICAMAX(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ICAMAX + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION ICAMAX + PURE FUNCTION IZAMAX(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IZAMAX + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION IZAMAX +END INTERFACE F77_IAMAX + +INTERFACE F77_IAMIN + PURE FUNCTION ISAMIN(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ISAMIN + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION ISAMIN + PURE FUNCTION IDAMIN(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IDAMIN + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION IDAMIN + PURE FUNCTION ICAMIN(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ICAMIN + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION ICAMIN + PURE FUNCTION IZAMIN(N, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IZAMIN + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END FUNCTION IZAMIN +END INTERFACE F77_IAMIN + +INTERFACE F77_CABS1 + PURE FUNCTION SCABS1(C) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SCABS1 + COMPLEX(WP), INTENT(IN) :: C + END FUNCTION SCABS1 + PURE FUNCTION DCABS1(Z) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DCABS1 + COMPLEX(WP), INTENT(IN) :: Z + END FUNCTION DCABS1 +END INTERFACE F77_CABS1 + +INTERFACE F77_GBMV + PURE SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: KL + INTEGER, INTENT(IN) :: M + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KU + END SUBROUTINE SGBMV + PURE SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: KL + INTEGER, INTENT(IN) :: M + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KU + END SUBROUTINE DGBMV + PURE SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: KL + INTEGER, INTENT(IN) :: M + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KU + END SUBROUTINE CGBMV + PURE SUBROUTINE ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: KL + INTEGER, INTENT(IN) :: M + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KU + END SUBROUTINE ZGBMV +END INTERFACE F77_GBMV + +INTERFACE F77_GEMV + PURE SUBROUTINE SGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE SGEMV + PURE SUBROUTINE DGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE DGEMV + PURE SUBROUTINE CGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE CGEMV + PURE SUBROUTINE ZGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZGEMV + PURE SUBROUTINE SCGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE SCGEMV + PURE SUBROUTINE DZGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + CHARACTER(LEN=1), INTENT(IN) :: TRANS + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE DZGEMV +END INTERFACE F77_GEMV + +INTERFACE F77_GER + PURE SUBROUTINE SGER(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(INOUT) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE SGER + PURE SUBROUTINE DGER(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(INOUT) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE DGER +END INTERFACE F77_GER + +INTERFACE F77_GERC + PURE SUBROUTINE CGERC(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE CGERC + PURE SUBROUTINE ZGERC(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZGERC +END INTERFACE F77_GERC + +INTERFACE F77_GERU + PURE SUBROUTINE CGERU(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE CGERU + PURE SUBROUTINE ZGERU(M, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZGERU +END INTERFACE F77_GERU + +INTERFACE F77_HBMV + PURE SUBROUTINE CHBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CHBMV + PURE SUBROUTINE ZHBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZHBMV +END INTERFACE F77_HBMV + +INTERFACE F77_HEMV + PURE SUBROUTINE CHEMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CHEMV + PURE SUBROUTINE ZHEMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZHEMV +END INTERFACE F77_HEMV + +INTERFACE F77_HER + PURE SUBROUTINE CHER(UPLO, N, ALPHA, X, INCX, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CHER + PURE SUBROUTINE ZHER(UPLO, N, ALPHA, X, INCX, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZHER +END INTERFACE F77_HER + +INTERFACE F77_HER2 + PURE SUBROUTINE CHER2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CHER2 + PURE SUBROUTINE ZHER2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(INOUT) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZHER2 +END INTERFACE F77_HER2 + +INTERFACE F77_HPMV + PURE SUBROUTINE CHPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: AP(*) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CHPMV + PURE SUBROUTINE ZHPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: AP(*) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZHPMV +END INTERFACE F77_HPMV + +INTERFACE F77_HPR + PURE SUBROUTINE CHPR(UPLO, N, ALPHA, X, INCX, AP) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(INOUT) :: AP(*) + COMPLEX(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CHPR + PURE SUBROUTINE ZHPR(UPLO, N, ALPHA, X, INCX, AP) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(INOUT) :: AP(*) + COMPLEX(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZHPR +END INTERFACE F77_HPR + +INTERFACE F77_HPR2 + PURE SUBROUTINE CHPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(INOUT) :: AP(*) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CHPR2 + PURE SUBROUTINE ZHPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(INOUT) :: AP(*) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZHPR2 +END INTERFACE F77_HPR2 + +INTERFACE F77_SBMV + PURE SUBROUTINE SSBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE SSBMV + PURE SUBROUTINE DSBMV(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE DSBMV +END INTERFACE F77_SBMV + +INTERFACE F77_SPMV + PURE SUBROUTINE SSPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: AP(*) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSPMV + PURE SUBROUTINE DSPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: AP(*) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSPMV +END INTERFACE F77_SPMV + +INTERFACE F77_SPR + PURE SUBROUTINE SSPR(UPLO, N, ALPHA, X, INCX, AP) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: AP(*) + REAL(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSPR + PURE SUBROUTINE DSPR(UPLO, N, ALPHA, X, INCX, AP) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: AP(*) + REAL(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSPR +END INTERFACE F77_SPR + +INTERFACE F77_SPR2 + PURE SUBROUTINE SSPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: AP(*) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSPR2 + PURE SUBROUTINE DSPR2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: AP(*) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSPR2 +END INTERFACE F77_SPR2 + +INTERFACE F77_SYMV + PURE SUBROUTINE SSYMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSYMV + PURE SUBROUTINE DSYMV(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSYMV +END INTERFACE F77_SYMV + +INTERFACE F77_SYR + PURE SUBROUTINE SSYR(UPLO, N, ALPHA, X, INCX, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(INOUT) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSYR + PURE SUBROUTINE DSYR(UPLO, N, ALPHA, X, INCX, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(INOUT) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSYR +END INTERFACE F77_SYR + +INTERFACE F77_SYR2 + PURE SUBROUTINE SSYR2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(INOUT) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSYR2 + PURE SUBROUTINE DSYR2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(INOUT) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(IN) :: Y(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSYR2 +END INTERFACE F77_SYR2 + +INTERFACE F77_TBMV + PURE SUBROUTINE STBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE STBMV + PURE SUBROUTINE DTBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE DTBMV + PURE SUBROUTINE CTBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CTBMV + PURE SUBROUTINE ZTBMV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZTBMV +END INTERFACE F77_TBMV + +INTERFACE F77_TBSV + PURE SUBROUTINE STBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE STBSV + PURE SUBROUTINE DTBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE DTBSV + PURE SUBROUTINE CTBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CTBSV + PURE SUBROUTINE ZTBSV(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZTBSV +END INTERFACE F77_TBSV + +INTERFACE F77_TPMV + PURE SUBROUTINE STPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: AP(*) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE STPMV + PURE SUBROUTINE DTPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: AP(*) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE DTPMV + PURE SUBROUTINE CTPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: AP(*) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CTPMV + PURE SUBROUTINE ZTPMV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: AP(*) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZTPMV +END INTERFACE F77_TPMV + +INTERFACE F77_TPSV + PURE SUBROUTINE STPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: AP(*) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE STPSV + PURE SUBROUTINE DTPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: AP(*) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE DTPSV + PURE SUBROUTINE CTPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: AP(*) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CTPSV + PURE SUBROUTINE ZTPSV(UPLO, TRANS, DIAG, N, AP, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: AP(*) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZTPSV +END INTERFACE F77_TPSV + +INTERFACE F77_TRMV + PURE SUBROUTINE STRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE STRMV + PURE SUBROUTINE DTRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE DTRMV + PURE SUBROUTINE CTRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CTRMV + PURE SUBROUTINE ZTRMV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZTRMV +END INTERFACE F77_TRMV + +INTERFACE F77_TRSV + PURE SUBROUTINE STRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE STRSV + PURE SUBROUTINE DTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE DTRSV + PURE SUBROUTINE CTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE CTRSV + PURE SUBROUTINE ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: X(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + CHARACTER(LEN=1), INTENT(IN) :: DIAG + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZTRSV +END INTERFACE F77_TRSV + +INTERFACE F77_GEMM + PURE SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE SGEMM + PURE SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE DGEMM + PURE SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CGEMM + PURE SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZGEMM + PURE SUBROUTINE SCGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE SCGEMM + PURE SUBROUTINE DZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE DZGEMM +END INTERFACE F77_GEMM + +INTERFACE F77_HEMM + PURE SUBROUTINE CHEMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE CHEMM + PURE SUBROUTINE ZHEMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZHEMM +END INTERFACE F77_HEMM + +INTERFACE F77_HERK + PURE SUBROUTINE CHERK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CHERK + PURE SUBROUTINE ZHERK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZHERK +END INTERFACE F77_HERK + +INTERFACE F77_HER2K +PURE SUBROUTINE CHER2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + COMPLEX(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CHER2K +PURE SUBROUTINE ZHER2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + COMPLEX(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZHER2K +END INTERFACE F77_HER2K + +INTERFACE F77_SYMM + PURE SUBROUTINE SSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE SSYMM + PURE SUBROUTINE DSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE DSYMM + PURE SUBROUTINE CSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE CSYMM + PURE SUBROUTINE ZSYMM(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZSYMM +END INTERFACE F77_SYMM + +INTERFACE F77_SYRK + PURE SUBROUTINE SSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE SSYRK + PURE SUBROUTINE DSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDC + END SUBROUTINE DSYRK + PURE SUBROUTINE CSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDC + END SUBROUTINE CSYRK + PURE SUBROUTINE ZSYRK(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDC + END SUBROUTINE ZSYRK +END INTERFACE F77_SYRK + +INTERFACE F77_SYR2K +PURE SUBROUTINE SSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE SSYR2K +PURE SUBROUTINE DSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE DSYR2K +PURE SUBROUTINE CSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CSYR2K +PURE SUBROUTINE ZSYR2K(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANS + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZSYR2K +END INTERFACE F77_SYR2K + +INTERFACE F77_TRMM + PURE SUBROUTINE STRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE STRMM + PURE SUBROUTINE DTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + END SUBROUTINE DTRMM + PURE SUBROUTINE CTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE CTRMM + PURE SUBROUTINE ZTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZTRMM +END INTERFACE F77_TRMM + +INTERFACE F77_TRSM + PURE SUBROUTINE STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + END SUBROUTINE STRSM + PURE SUBROUTINE DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + REAL(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + END SUBROUTINE DTRSM + PURE SUBROUTINE CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + END SUBROUTINE CTRSM + PURE SUBROUTINE ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(INOUT) :: B(LDB, *) + CHARACTER(LEN=1), INTENT(IN) :: SIDE + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: DIAG + COMPLEX(WP), INTENT(IN) :: ALPHA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + END SUBROUTINE ZTRSM +END INTERFACE F77_TRSM + +INTERFACE F77_GEMM3M + PURE SUBROUTINE CGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE CGEMM3M + PURE SUBROUTINE ZGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C, & + & LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + END SUBROUTINE ZGEMM3M +END INTERFACE F77_GEMM3M + +INTERFACE F77_GEMMT + PURE SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & + & C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + ! INTEGER, INTENT(IN) :: LDC + END SUBROUTINE SGEMMT + PURE SUBROUTINE DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & + & C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: B(LDB, *) + REAL(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + ! INTEGER, INTENT(IN) :: LDC + END SUBROUTINE DGEMMT + PURE SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & + & C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + ! INTEGER, INTENT(IN) :: LDC + END SUBROUTINE CGEMMT + PURE SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, & + & C, LDC) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + INTEGER, INTENT(IN) :: LDB + INTEGER, INTENT(IN) :: LDC + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: B(LDB, *) + COMPLEX(WP), INTENT(INOUT) :: C(LDC, *) + CHARACTER(LEN=1), INTENT(IN) :: UPLO + CHARACTER(LEN=1), INTENT(IN) :: TRANSA + CHARACTER(LEN=1), INTENT(IN) :: TRANSB + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + ! INTEGER, INTENT(IN) :: LDA + ! INTEGER, INTENT(IN) :: LDB + ! INTEGER, INTENT(IN) :: LDC + END SUBROUTINE ZGEMMT +END INTERFACE F77_GEMMT + +INTERFACE F77_AXPBY + PURE SUBROUTINE SAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE SAXPBY + PURE SUBROUTINE DAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: X(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE DAXPBY + PURE SUBROUTINE CAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE CAXPBY + PURE SUBROUTINE ZAXPBY(N, ALPHA, X, INCX, BETA, Y, INCY) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: X(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX + INTEGER, INTENT(IN) :: INCY + INTEGER, INTENT(IN) :: N + END SUBROUTINE ZAXPBY +END INTERFACE F77_AXPBY + +! Intel mkl related +! #ifdef USE_INTEL_MKL +INTERFACE F77_ROTI + PURE SUBROUTINE SROTI(NZ, X, INDX, Y, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(INOUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(IN) :: Y(*) + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE SROTI + PURE SUBROUTINE DROTI(NZ, X, INDX, Y, C, S) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(INOUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(IN) :: Y(*) + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE DROTI +END INTERFACE F77_ROTI + +INTERFACE F77_GEM2V + PURE SUBROUTINE SGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & + & INCY1, Y2, INCY2) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X1(*) + REAL(WP), INTENT(IN) :: X2(*) + REAL(WP), INTENT(INOUT) :: Y1(*) + REAL(WP), INTENT(INOUT) :: Y2(*) + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX1 + INTEGER, INTENT(IN) :: INCX2 + INTEGER, INTENT(IN) :: INCY1 + INTEGER, INTENT(IN) :: INCY2 + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + END SUBROUTINE SGEM2VU + PURE SUBROUTINE DGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & + & INCY1, Y2, INCY2) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + REAL(WP), INTENT(IN) :: A(LDA, *) + REAL(WP), INTENT(IN) :: X1(*) + REAL(WP), INTENT(IN) :: X2(*) + REAL(WP), INTENT(INOUT) :: Y1(*) + REAL(WP), INTENT(INOUT) :: Y2(*) + REAL(WP), INTENT(IN) :: ALPHA + REAL(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX1 + INTEGER, INTENT(IN) :: INCX2 + INTEGER, INTENT(IN) :: INCY1 + INTEGER, INTENT(IN) :: INCY2 + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + END SUBROUTINE DGEM2VU + PURE SUBROUTINE CGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & + & INCY1, Y2, INCY2) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X1(*) + COMPLEX(WP), INTENT(IN) :: X2(*) + COMPLEX(WP), INTENT(INOUT) :: Y1(*) + COMPLEX(WP), INTENT(INOUT) :: Y2(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX1 + INTEGER, INTENT(IN) :: INCX2 + INTEGER, INTENT(IN) :: INCY1 + INTEGER, INTENT(IN) :: INCY2 + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + END SUBROUTINE CGEM2VC + PURE SUBROUTINE ZGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1, & + & INCY1, Y2, INCY2) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, INTENT(IN) :: LDA + COMPLEX(WP), INTENT(IN) :: A(LDA, *) + COMPLEX(WP), INTENT(IN) :: X1(*) + COMPLEX(WP), INTENT(IN) :: X2(*) + COMPLEX(WP), INTENT(INOUT) :: Y1(*) + COMPLEX(WP), INTENT(INOUT) :: Y2(*) + COMPLEX(WP), INTENT(IN) :: ALPHA + COMPLEX(WP), INTENT(IN) :: BETA + INTEGER, INTENT(IN) :: INCX1 + INTEGER, INTENT(IN) :: INCX2 + INTEGER, INTENT(IN) :: INCY1 + INTEGER, INTENT(IN) :: INCY2 + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + ! INTEGER, INTENT(IN) :: LDA + END SUBROUTINE ZGEM2VC +END INTERFACE F77_GEM2V + +INTERFACE F77_AXPYI + PURE SUBROUTINE SAXPYI(NZ, A, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE SAXPYI + PURE SUBROUTINE DAXPYI(NZ, A, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(INOUT) :: Y(*) + REAL(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE DAXPYI + PURE SUBROUTINE CAXPYI(NZ, A, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE CAXPYI + PURE SUBROUTINE ZAXPYI(NZ, A, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + COMPLEX(WP), INTENT(IN) :: A + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE ZAXPYI +END INTERFACE F77_AXPYI + +INTERFACE F77_DOTI + PURE FUNCTION SDOTI(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SDOTI + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END FUNCTION SDOTI + PURE FUNCTION DDOTI(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DDOTI + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END FUNCTION DDOTI +END INTERFACE F77_DOTI + +INTERFACE F77_DOTCI + PURE FUNCTION CDOTCI(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTCI + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END FUNCTION CDOTCI + PURE FUNCTION ZDOTCI(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTCI + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END FUNCTION ZDOTCI +END INTERFACE F77_DOTCI + +INTERFACE F77_DOTUI + PURE FUNCTION CDOTUI(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTUI + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END FUNCTION CDOTUI + PURE FUNCTION ZDOTUI(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTUI + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END FUNCTION ZDOTUI +END INTERFACE F77_DOTUI + +INTERFACE F77_GEMM_BATCH + PURE SUBROUTINE SGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& + & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & + & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & + & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) + REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) + REAL(WP), INTENT(IN) :: BETA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: K_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: LDC_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE SGEMM_BATCH + PURE SUBROUTINE DGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& + & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & + & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & + & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) + REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) + REAL(WP), INTENT(IN) :: BETA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: K_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: LDC_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE DGEMM_BATCH + + PURE SUBROUTINE CGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& + & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & + & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & + & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: K_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: LDC_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE CGEMM_BATCH + PURE SUBROUTINE ZGEMM_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, N_ARRAY,& + & K_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY, & + & B_ARRAY, LDB_ARRAY, BETA_ARRAY, C_ARRAY, & + & LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: K_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: LDC_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE ZGEMM_BATCH +END INTERFACE F77_GEMM_BATCH + +INTERFACE F77_GEMM3M_BATCH + PURE SUBROUTINE CGEMM3M_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, & + & N_ARRAY, K_ARRAY, ALPHA_ARRAY, A_ARRAY, & + & LDA_ARRAY, B_ARRAY, LDB_ARRAY, BETA_ARRAY, & + & C_ARRAY, LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: K_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: LDC_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE CGEMM3M_BATCH + PURE SUBROUTINE ZGEMM3M_BATCH(TRANSA_ARRAY, TRANSB_ARRAY, M_ARRAY, & + & N_ARRAY, K_ARRAY, ALPHA_ARRAY, A_ARRAY, & + & LDA_ARRAY, B_ARRAY, LDB_ARRAY, BETA_ARRAY, & + & C_ARRAY, LDC_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT) :: C_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSB_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: BETA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: K_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: LDC_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE ZGEMM3M_BATCH +END INTERFACE F77_GEMM3M_BATCH + +INTERFACE F77_TRSM_BATCH +PURE SUBROUTINE STRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& + & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& + & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) + REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE STRSM_BATCH +PURE SUBROUTINE DTRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& + & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& + & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) + REAL(WP), INTENT(IN) :: ALPHA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE DTRSM_BATCH +PURE SUBROUTINE CTRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& + & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& + & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE CTRSM_BATCH +PURE SUBROUTINE ZTRSM_BATCH(SIDE_ARRAY, UPLO_ARRAY, TRANSA_ARRAY, DIAG_ARRAY,& + & M_ARRAY, N_ARRAY, ALPHA_ARRAY, A_ARRAY, LDA_ARRAY,& + & B_ARRAY, LDB_ARRAY, GROUP_COUNT, GROUP_SIZE) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(*) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: SIDE_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: UPLO_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: TRANSA_ARRAY(*) + CHARACTER(LEN=1), INTENT(IN) :: DIAG_ARRAY(*) + COMPLEX(WP), INTENT(IN) :: ALPHA_ARRAY(*) + INTEGER, INTENT(IN) :: M_ARRAY(*) + INTEGER, INTENT(IN) :: N_ARRAY(*) + INTEGER, INTENT(IN) :: LDA_ARRAY(*) + INTEGER, INTENT(IN) :: LDB_ARRAY(*) + INTEGER, INTENT(IN) :: GROUP_COUNT + INTEGER, INTENT(IN) :: GROUP_SIZE(*) + END SUBROUTINE ZTRSM_BATCH +END INTERFACE F77_TRSM_BATCH + +INTERFACE F77_GTHR + PURE SUBROUTINE SGTHR(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE SGTHR + PURE SUBROUTINE DGTHR(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE DGTHR + PURE SUBROUTINE CGTHR(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE CGTHR + PURE SUBROUTINE ZGTHR(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(IN) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE ZGTHR +END INTERFACE F77_GTHR + +INTERFACE F77_GTHRZ + PURE SUBROUTINE SGTHRZ(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE SGTHRZ + PURE SUBROUTINE DGTHRZ(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE DGTHRZ + PURE SUBROUTINE CGTHRZ(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE CGTHRZ + PURE SUBROUTINE ZGTHRZ(NZ, Y, X, INDX) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(OUT) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(INOUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE ZGTHRZ +END INTERFACE F77_GTHRZ + +INTERFACE F77_SCTR + PURE SUBROUTINE SSCTR(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(OUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE SSCTR + PURE SUBROUTINE DSCTR(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + REAL(WP), INTENT(OUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE DSCTR + PURE SUBROUTINE CSCTR(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(OUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE CSCTR + PURE SUBROUTINE ZSCTR(NZ, X, INDX, Y) + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP), INTENT(IN) :: X(*) + INTEGER, INTENT(IN) :: INDX(*) + COMPLEX(WP), INTENT(OUT) :: Y(*) + INTEGER, INTENT(IN) :: NZ + END SUBROUTINE ZSCTR +END INTERFACE F77_SCTR +! #endif +END MODULE F77_BLAS diff --git a/src/modules/BLAS95/src/F95_BLAS.F90 b/src/modules/BLAS95/src/F95_BLAS.F90 new file mode 100644 index 000000000..9f5b8bb01 --- /dev/null +++ b/src/modules/BLAS95/src/F95_BLAS.F90 @@ -0,0 +1,422 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 26 Feb 2021 +! summary: + +MODULE F95_BLAS +USE F77_BLAS +IMPLICIT NONE +PRIVATE + +PUBLIC :: IAMAX +PUBLIC :: SWAP +PUBLIC :: SCAL +PUBLIC :: ROTMG +PUBLIC :: ROTM +PUBLIC :: ROTG +PUBLIC :: ROT +PUBLIC :: NRM2 +PUBLIC :: DOTU +PUBLIC :: DOT +PUBLIC :: DOTC +PUBLIC :: SDOT +PUBLIC :: COPY +PUBLIC :: AXPY +PUBLIC :: ASUM +PUBLIC :: GEMV + +#ifndef USE_NativeBLAS +PUBLIC :: IAMIN +#endif + +#ifndef USE_APPLE_NativeBLAS +PUBLIC :: CABS1 +#endif + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE ASUM + MODULE PROCEDURE SASUM_F95, SCASUM_F95, DASUM_F95, DZASUM_F95 +END INTERFACE ASUM + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE AXPY + MODULE PROCEDURE SAXPY_F95, DAXPY_F95, CAXPY_F95, ZAXPY_F95 +END INTERFACE AXPY + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE COPY + MODULE PROCEDURE SCOPY_F95, DCOPY_F95, CCOPY_F95, ZCOPY_F95 +END INTERFACE COPY + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DOT + MODULE PROCEDURE SDOT_F95, DDOT_F95 +END INTERFACE DOT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE SDOT + MODULE PROCEDURE SDSDOT_F95, DSDOT_F95 +END INTERFACE SDOT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DOTC + MODULE PROCEDURE CDOTC_F95, ZDOTC_F95 +END INTERFACE DOTC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DOTU + MODULE PROCEDURE CDOTU_F95, ZDOTU_F95 +END INTERFACE DOTU + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE NRM2 + MODULE PROCEDURE SNRM2_F95, DNRM2_F95, SCNRM2_F95, DZNRM2_F95 +END INTERFACE NRM2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE ROT + MODULE PROCEDURE SROT_F95, DROT_F95, CSROT_F95, ZDROT_F95 +END INTERFACE ROT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE ROTG + MODULE PROCEDURE SROTG_F95, DROTG_F95, CROTG_F95, ZROTG_F95 +END INTERFACE ROTG + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE ROTM + MODULE PROCEDURE SROTM_F95, DROTM_F95 +END INTERFACE ROTM + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE ROTMG + MODULE PROCEDURE SROTMG_F95, DROTMG_F95 +END INTERFACE ROTMG + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE SCAL + MODULE PROCEDURE SSCAL_F95, DSCAL_F95, CSCAL_F95, ZSCAL_F95, CSSCAL_F95,& + & ZDSCAL_F95 +END INTERFACE SCAL + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE SWAP + MODULE PROCEDURE SSWAP_F95, DSWAP_F95, CSWAP_F95, ZSWAP_F95 +END INTERFACE SWAP + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE IAMAX + MODULE PROCEDURE ISAMAX_F95, IDAMAX_F95, ICAMAX_F95, IZAMAX_F95 +END INTERFACE IAMAX + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#ifndef USE_NativeBLAS +INTERFACE IAMIN + MODULE PROCEDURE ISAMIN_F95, IDAMIN_F95, ICAMIN_F95, IZAMIN_F95 +END INTERFACE IAMIN +#endif + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#ifndef USE_APPLE_NativeBLAS +INTERFACE CABS1 + MODULE PROCEDURE SCABS1_F95, DCABS1_F95 +END INTERFACE CABS1 +#endif + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE GEMV + MODULE PROCEDURE SGEMV_F95, DGEMV_F95, CGEMV_F95, ZGEMV_F95 +END INTERFACE GEMV + +#ifdef USE_INTEL_MKL +INTERFACE GEMV + MODULE PROCEDURE SCGEMV_F95, DZGEMV_F95 +END INTERFACE GEMV +#endif + +CONTAINS + +#ifndef USE_APPLE_NativeBLAS +#include "./blas95_src/dcabs1.F90" +#include "./blas95_src/scabs1.F90" +#include "./blas95_src/cgemm3m.F90" +#include "./blas95_src/saxpby.F90" +#include "./blas95_src/daxpby.F90" +#include "./blas95_src/caxpby.F90" +#include "./blas95_src/zaxpby.F90" +#include "./blas95_src/zgemm3m.F90" +#endif + +#include "./blas95_src/caxpy.F90" +#include "./blas95_src/ccopy.F90" +#include "./blas95_src/cdotc.F90" +#include "./blas95_src/cdotu.F90" +#include "./blas95_src/cgbmv.F90" +#include "./blas95_src/cgemm.F90" +#include "./blas95_src/cgemv.F90" +#include "./blas95_src/cgerc.F90" +#include "./blas95_src/cgeru.F90" +#include "./blas95_src/chbmv.F90" +#include "./blas95_src/chemm.F90" +#include "./blas95_src/chemv.F90" +#include "./blas95_src/cher.F90" +#include "./blas95_src/cher2.F90" +#include "./blas95_src/cher2k.F90" +#include "./blas95_src/cherk.F90" +#include "./blas95_src/chpmv.F90" +#include "./blas95_src/chpr.F90" +#include "./blas95_src/chpr2.F90" +#include "./blas95_src/crotg.F90" +#include "./blas95_src/cscal.F90" +#include "./blas95_src/csrot.F90" +#include "./blas95_src/csscal.F90" +#include "./blas95_src/cswap.F90" +#include "./blas95_src/zswap.F90" +#include "./blas95_src/csymm.F90" +#include "./blas95_src/csyr2k.F90" +#include "./blas95_src/csyrk.F90" +#include "./blas95_src/ctbmv.F90" +#include "./blas95_src/ctbsv.F90" +#include "./blas95_src/ctpmv.F90" +#include "./blas95_src/ctpsv.F90" +#include "./blas95_src/ctrmm.F90" +#include "./blas95_src/ctrmv.F90" +#include "./blas95_src/ctrsm.F90" +#include "./blas95_src/ctrsv.F90" +#include "./blas95_src/dasum.F90" +#include "./blas95_src/daxpy.F90" +#include "./blas95_src/dcopy.F90" +#include "./blas95_src/ddot.F90" +#include "./blas95_src/dgbmv.F90" +#include "./blas95_src/dgemm.F90" +#include "./blas95_src/dgemv.F90" +#include "./blas95_src/dger.F90" +#include "./blas95_src/dnrm2.F90" +#include "./blas95_src/drot.F90" +#include "./blas95_src/drotm.F90" +#include "./blas95_src/drotmg.F90" +#include "./blas95_src/drotg.F90" +#include "./blas95_src/dsbmv.F90" +#include "./blas95_src/dscal.F90" +#include "./blas95_src/dsdot.F90" +#include "./blas95_src/dspmv.F90" +#include "./blas95_src/dspr.F90" +#include "./blas95_src/dspr2.F90" +#include "./blas95_src/dswap.F90" +#include "./blas95_src/dsymm.F90" +#include "./blas95_src/dsymv.F90" +#include "./blas95_src/dsyr.F90" +#include "./blas95_src/dsyr2.F90" +#include "./blas95_src/dsyr2k.F90" +#include "./blas95_src/dsyrk.F90" +#include "./blas95_src/dtbmv.F90" +#include "./blas95_src/dtbsv.F90" +#include "./blas95_src/dtpmv.F90" +#include "./blas95_src/dtpsv.F90" +#include "./blas95_src/dtrmm.F90" +#include "./blas95_src/dtrmv.F90" +#include "./blas95_src/dtrsm.F90" +#include "./blas95_src/dtrsv.F90" +#include "./blas95_src/dzasum.F90" +#include "./blas95_src/dznrm2.F90" +#include "./blas95_src/icamax.F90" +#include "./blas95_src/idamax.F90" +#include "./blas95_src/isamax.F90" +#include "./blas95_src/izamax.F90" +#include "./blas95_src/sasum.F90" +#include "./blas95_src/saxpy.F90" +#include "./blas95_src/scasum.F90" +#include "./blas95_src/scnrm2.F90" +#include "./blas95_src/scopy.F90" +#include "./blas95_src/sdot.F90" +#include "./blas95_src/sdsdot.F90" +#include "./blas95_src/sgbmv.F90" +#include "./blas95_src/sgemm.F90" +#include "./blas95_src/sgemv.F90" +#include "./blas95_src/sger.F90" +#include "./blas95_src/snrm2.F90" +#include "./blas95_src/srot.F90" +#include "./blas95_src/srotm.F90" +#include "./blas95_src/srotmg.F90" +#include "./blas95_src/srotg.F90" +#include "./blas95_src/ssbmv.F90" +#include "./blas95_src/sscal.F90" +#include "./blas95_src/sspmv.F90" +#include "./blas95_src/sspr.F90" +#include "./blas95_src/sspr2.F90" +#include "./blas95_src/sswap.F90" +#include "./blas95_src/ssymm.F90" +#include "./blas95_src/ssymv.F90" +#include "./blas95_src/ssyr.F90" +#include "./blas95_src/ssyr2.F90" +#include "./blas95_src/ssyr2k.F90" +#include "./blas95_src/ssyrk.F90" +#include "./blas95_src/stbmv.F90" +#include "./blas95_src/stbsv.F90" +#include "./blas95_src/stpmv.F90" +#include "./blas95_src/stpsv.F90" +#include "./blas95_src/strmm.F90" +#include "./blas95_src/strmv.F90" +#include "./blas95_src/strsm.F90" +#include "./blas95_src/strsv.F90" +#include "./blas95_src/zaxpy.F90" +#include "./blas95_src/zcopy.F90" +#include "./blas95_src/zdotc.F90" +#include "./blas95_src/zdotu.F90" +#include "./blas95_src/zdrot.F90" +#include "./blas95_src/zdscal.F90" +#include "./blas95_src/zgbmv.F90" +#include "./blas95_src/zgemm.F90" +#include "./blas95_src/zgemv.F90" +#include "./blas95_src/zgerc.F90" +#include "./blas95_src/zgeru.F90" +#include "./blas95_src/zhbmv.F90" +#include "./blas95_src/zhemm.F90" +#include "./blas95_src/zhemv.F90" +#include "./blas95_src/zher.F90" +#include "./blas95_src/zher2.F90" +#include "./blas95_src/zher2k.F90" +#include "./blas95_src/zherk.F90" +#include "./blas95_src/zhpmv.F90" +#include "./blas95_src/zhpr.F90" +#include "./blas95_src/zhpr2.F90" +#include "./blas95_src/zrotg.F90" +#include "./blas95_src/zscal.F90" +#include "./blas95_src/zsymm.F90" +#include "./blas95_src/zsyr2k.F90" +#include "./blas95_src/zsyrk.F90" +#include "./blas95_src/ztbmv.F90" +#include "./blas95_src/ztbsv.F90" +#include "./blas95_src/ztpmv.F90" +#include "./blas95_src/ztpsv.F90" +#include "./blas95_src/ztrmm.F90" +#include "./blas95_src/ztrmv.F90" +#include "./blas95_src/ztrsm.F90" +#include "./blas95_src/ztrsv.F90" + +#ifndef USE_NativeBLAS +#include "./blas95_src/icamin.F90" +#include "./blas95_src/idamin.F90" +#include "./blas95_src/isamin.F90" +#include "./blas95_src/izamin.F90" +#endif + +#ifdef USE_INTEL_MKL +#include "./blas95_src/droti.F90" +#include "./blas95_src/sroti.F90" +#include "./blas95_src/zgem2vc.F90" +#include "./blas95_src/cgem2vc.F90" +#include "./blas95_src/dgem2vu.F90" +#include "./blas95_src/sgem2vu.F90" +#include "./blas95_src/caxpyi.F90" +#include "./blas95_src/daxpyi.F90" +#include "./blas95_src/saxpyi.F90" +#include "./blas95_src/zaxpyi.F90" +#include "./blas95_src/ddoti.F90" +#include "./blas95_src/sdoti.F90" +#include "./blas95_src/cdotci.F90" +#include "./blas95_src/zdotci.F90" +#include "./blas95_src/cdotui.F90" +#include "./blas95_src/zdotui.F90" +#include "./blas95_src/cgemm_batch.F90" +#include "./blas95_src/cgemm3m_batch.F90" +#include "./blas95_src/ctrsm_batch.F90" +#include "./blas95_src/dgemm_batch.F90" +#include "./blas95_src/dtrsm_batch.F90" +#include "./blas95_src/sgemm_batch.F90" +#include "./blas95_src/strsm_batch.F90" +#include "./blas95_src/zgemm_batch.F90" +#include "./blas95_src/zgemm3m_batch.F90" +#include "./blas95_src/ztrsm_batch.F90" +#include "./blas95_src/cgemmt.F90" +#include "./blas95_src/dgemmt.F90" +#include "./blas95_src/sgemmt.F90" +#include "./blas95_src/zgemmt.F90" +#include "./blas95_src/cgthr.F90" +#include "./blas95_src/cgthrz.F90" +#include "./blas95_src/dgthr.F90" +#include "./blas95_src/dgthrz.F90" +#include "./blas95_src/sgthr.F90" +#include "./blas95_src/sgthrz.F90" +#include "./blas95_src/zgthr.F90" +#include "./blas95_src/zgthrz.F90" +#include "./blas95_src/dsctr.F90" +#include "./blas95_src/ssctr.F90" +#include "./blas95_src/csctr.F90" +#include "./blas95_src/dzgemm.F90" +#include "./blas95_src/dzgemv.F90" +#include "./blas95_src/scgemm.F90" +#include "./blas95_src/scgemv.F90" +#endif + +END MODULE F95_BLAS diff --git a/src/modules/BLAS95/src/blas95_src/caxpby.F90 b/src/modules/BLAS95/src/blas95_src/caxpby.F90 new file mode 100755 index 000000000..17ea58a12 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/caxpby.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! CAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + ! Default ALPHA=1 + ! Default BETA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPBY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE CAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/caxpy.F90 b/src/modules/BLAS95/src/blas95_src/caxpy.F90 new file mode 100755 index 000000000..456c791c5 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/caxpy.F90 @@ -0,0 +1,58 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CAXPY_F95(X,Y,A) + ! Fortran77 call: + ! CAXPY(N,A,X,INCX,Y,INCY) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_A + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) +END SUBROUTINE CAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/caxpyi.F90 b/src/modules/BLAS95/src/blas95_src/caxpyi.F90 new file mode 100755 index 000000000..2667221f4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/caxpyi.F90 @@ -0,0 +1,55 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! CAXPYI(NZ,A,X,INDX,Y) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPYI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_A + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPYI(NZ,O_A,X,INDX,Y) +END SUBROUTINE CAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ccopy.F90 b/src/modules/BLAS95/src/blas95_src/ccopy.F90 new file mode 100755 index 000000000..78369f3ad --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ccopy.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CCOPY_F95(X,Y) + ! Fortran77 call: + ! CCOPY(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_COPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_COPY(N,X,INCX,Y,INCY) +END SUBROUTINE CCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotc.F90 b/src/modules/BLAS95/src/blas95_src/cdotc.F90 new file mode 100755 index 000000000..5dc6e5f3f --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cdotc.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION CDOTC_F95(X,Y) + ! Fortran77 call: + ! CDOTC(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTC + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTC_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTC' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CDOTC_F95 = F77_DOTC(N,X,INCX,Y,INCY) +END FUNCTION CDOTC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotci.F90 b/src/modules/BLAS95/src/blas95_src/cdotci.F90 new file mode 100755 index 000000000..014446af5 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cdotci.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION CDOTCI_F95(X,INDX,Y) + ! Fortran77 call: + ! CDOTCI(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTCI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTCI_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTCI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CDOTCI_F95 = F77_DOTCI(NZ,X,INDX,Y) +END FUNCTION CDOTCI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotu.F90 b/src/modules/BLAS95/src/blas95_src/cdotu.F90 new file mode 100755 index 000000000..62990cdd9 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cdotu.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION CDOTU_F95(X,Y) + ! Fortran77 call: + ! CDOTU(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTU + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTU_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTU' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CDOTU_F95 = F77_DOTU(N,X,INCX,Y,INCY) +END FUNCTION CDOTU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cdotui.F90 b/src/modules/BLAS95/src/blas95_src/cdotui.F90 new file mode 100755 index 000000000..62dffa908 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cdotui.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION CDOTUI_F95(X,INDX,Y) + ! Fortran77 call: + ! CDOTUI(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTUI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + COMPLEX(WP) :: CDOTUI_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTUI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CDOTUI_F95 = F77_DOTUI(NZ,X,INDX,Y) +END FUNCTION CDOTUI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgbmv.F90 b/src/modules/BLAS95/src/blas95_src/cgbmv.F90 new file mode 100755 index 000000000..25da63315 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgbmv.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' + ! <<< Local scalars >>> + INTEGER :: O_KL + INTEGER :: O_M + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: KU + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + IF(PRESENT(KL)) THEN + O_KL = KL + ELSE + O_KL = (LDA-1)/2 + ENDIF + IF(PRESENT(M)) THEN + O_M = M + ELSE + O_M = N + ENDIF + KU = LDA-O_KL-1 + ! <<< Call blas77 routine >>> + CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & + & INCY) +END SUBROUTINE CGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgem2vc.F90 b/src/modules/BLAS95/src/blas95_src/cgem2vc.F90 new file mode 100755 index 000000000..8380898fb --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgem2vc.F90 @@ -0,0 +1,78 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! CGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEM2V + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X1(:) + COMPLEX(WP), INTENT(IN) :: X2(:) + COMPLEX(WP), INTENT(INOUT ) :: Y1(:) + COMPLEX(WP), INTENT(INOUT ) :: Y2(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX1 + INTEGER :: INCX2 + INTEGER :: INCY1 + INTEGER :: INCY2 + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + INCX1 = 1 + INCX2 = 1 + INCY1 = 1 + INCY2 = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & + & Y2,INCY2) +END SUBROUTINE CGEM2VC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm.F90 b/src/modules/BLAS95/src/blas95_src/cgemm.F90 new file mode 100755 index 000000000..be0dc4db4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgemm.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & + & LDC) +END SUBROUTINE CGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm3m.F90 b/src/modules/BLAS95/src/blas95_src/cgemm3m.F90 new file mode 100755 index 000000000..1c6d7770f --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgemm3m.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! CGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM3M + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=6), PARAMETER :: SRNAME = 'GEMM3M' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM3M(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA, & + & C,LDC) +END SUBROUTINE CGEMM3M_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 b/src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 new file mode 100755 index 000000000..eee50d3a9 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgemm3m_batch.F90 @@ -0,0 +1,190 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE CGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,GROUP_SIZE,TRANSA_ARRAY,& + & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! CGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! BETA_ARRAY=Array of beta values; default: array where each element=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM3M_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=13), PARAMETER :: SRNAME = 'CGEMM3M_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) + COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) + COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + INTEGER, POINTER :: LDC_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(BETA_ARRAY)) THEN + O_BETA_ARRAY => BETA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_BETA_ARRAY(I) = 0 + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSB_ARRAY)) THEN + O_TRANSB_ARRAY => TRANSB_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSB_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & + & O_TRANSA_ARRAY(I).EQ.'n')) THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & + & O_TRANSB_ARRAY(I).EQ.'n')) THEN + LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) + ELSE + LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_GEMM3M_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & + & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(BETA_ARRAY)) THEN + IF (ASSOCIATED(O_BETA_ARRAY)) THEN + DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN + DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDC_ARRAY)) THEN + DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE CGEMM3M_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 new file mode 100755 index 000000000..96901c0b1 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgemm_batch.F90 @@ -0,0 +1,190 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE CGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& + & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & + & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! CGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! BETA_ARRAY=Array of beta values; default: array where each element=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'CGEMM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) + COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) + COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + INTEGER, POINTER :: LDC_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(BETA_ARRAY)) THEN + O_BETA_ARRAY => BETA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_BETA_ARRAY(I) = 0 + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSB_ARRAY)) THEN + O_TRANSB_ARRAY => TRANSB_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSB_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & + & O_TRANSA_ARRAY(I).EQ.'n')) THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & + & O_TRANSB_ARRAY(I).EQ.'n')) THEN + LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) + ELSE + LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & + & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(BETA_ARRAY)) THEN + IF (ASSOCIATED(O_BETA_ARRAY)) THEN + DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN + DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDC_ARRAY)) THEN + DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE CGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemmt.F90 b/src/modules/BLAS95/src/blas95_src/cgemmt.F90 new file mode 100755 index 000000000..799b5204b --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgemmt.F90 @@ -0,0 +1,100 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMMT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & + & O_BETA,C,LDC) +END SUBROUTINE CGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgemv.F90 b/src/modules/BLAS95/src/blas95_src/cgemv.F90 new file mode 100755 index 000000000..87077117f --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgemv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE CGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgerc.F90 b/src/modules/BLAS95/src/blas95_src/cgerc.F90 new file mode 100755 index 000000000..aaaa26be0 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgerc.F90 @@ -0,0 +1,63 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGERC_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GERC + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERC' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GERC(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE CGERC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgeru.F90 b/src/modules/BLAS95/src/blas95_src/cgeru.F90 new file mode 100755 index 000000000..1bea60d6f --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgeru.F90 @@ -0,0 +1,63 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGERU_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GERU + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERU' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GERU(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE CGERU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgthr.F90 b/src/modules/BLAS95/src/blas95_src/cgthr.F90 new file mode 100755 index 000000000..9d7a3242c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgthr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! CGTHR(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHR(NZ,Y,X,INDX) +END SUBROUTINE CGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cgthrz.F90 b/src/modules/BLAS95/src/blas95_src/cgthrz.F90 new file mode 100755 index 000000000..f330f11db --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cgthrz.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! CGTHRZ(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHRZ + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHRZ(NZ,Y,X,INDX) +END SUBROUTINE CGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chbmv.F90 b/src/modules/BLAS95/src/blas95_src/chbmv.F90 new file mode 100755 index 000000000..a144bca40 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/chbmv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE CHBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chemm.F90 b/src/modules/BLAS95/src/blas95_src/chemm.F90 new file mode 100755 index 000000000..cf0df5b6d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/chemm.F90 @@ -0,0 +1,87 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_HEMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE CHEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chemv.F90 b/src/modules/BLAS95/src/blas95_src/chemv.F90 new file mode 100755 index 000000000..15d05d47b --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/chemv.F90 @@ -0,0 +1,77 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HEMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE CHEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cher.F90 b/src/modules/BLAS95/src/blas95_src/cher.F90 new file mode 100755 index 000000000..3c210a5e1 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cher.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHER_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! CHER(UPLO,N,ALPHA,X,INCX,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HER + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HER' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HER(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) +END SUBROUTINE CHER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cher2.F90 b/src/modules/BLAS95/src/blas95_src/cher2.F90 new file mode 100755 index 000000000..843eb096d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cher2.F90 @@ -0,0 +1,69 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHER2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HER2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HER2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HER2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE CHER2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cher2k.F90 b/src/modules/BLAS95/src/blas95_src/cher2k.F90 new file mode 100755 index 000000000..979ad7d7c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cher2k.F90 @@ -0,0 +1,91 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HER2K + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'HER2K' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + COMPLEX(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_HER2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE CHER2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cherk.F90 b/src/modules/BLAS95/src/blas95_src/cherk.F90 new file mode 100755 index 000000000..9f022d779 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cherk.F90 @@ -0,0 +1,88 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HERK + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HERK' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_HERK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) +END SUBROUTINE CHERK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chpmv.F90 b/src/modules/BLAS95/src/blas95_src/chpmv.F90 new file mode 100755 index 000000000..4028fc6bd --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/chpmv.F90 @@ -0,0 +1,75 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_HPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE CHPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chpr.F90 b/src/modules/BLAS95/src/blas95_src/chpr.F90 new file mode 100755 index 000000000..3c4a0aa4c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/chpr.F90 @@ -0,0 +1,64 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! CHPR(UPLO,N,ALPHA,X,INCX,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HPR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HPR' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_HPR(O_UPLO,N,O_ALPHA,X,INCX,AP) +END SUBROUTINE CHPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/chpr2.F90 b/src/modules/BLAS95/src/blas95_src/chpr2.F90 new file mode 100755 index 000000000..6923f3b33 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/chpr2.F90 @@ -0,0 +1,67 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CHPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HPR2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPR2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_HPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) +END SUBROUTINE CHPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/crotg.F90 b/src/modules/BLAS95/src/blas95_src/crotg.F90 new file mode 100755 index 000000000..cc5f5c3c2 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/crotg.F90 @@ -0,0 +1,40 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE CROTG_F95(A,B,C,S) + ! Fortran77 call: + ! CROTG(A,B,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTG + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A + COMPLEX(WP), INTENT(INOUT ) :: B + REAL(WP), INTENT(OUT) :: C + COMPLEX(WP), INTENT(OUT) :: S + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' + ! <<< Local scalars >>> + ! <<< Executable statements >>> + ! <<< Call blas77 routine >>> + CALL F77_ROTG(A,B,C,S) +END SUBROUTINE CROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cscal.F90 b/src/modules/BLAS95/src/blas95_src/cscal.F90 new file mode 100755 index 000000000..24e06f0e8 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cscal.F90 @@ -0,0 +1,48 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSCAL_F95(X,A) + ! Fortran77 call: + ! CSCAL(N,A,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCAL + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN) :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCAL(N,A,X,INCX) +END SUBROUTINE CSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csctr.F90 b/src/modules/BLAS95/src/blas95_src/csctr.F90 new file mode 100755 index 000000000..55f6a9296 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/csctr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! CSCTR(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCTR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(OUT) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCTR(NZ,X,INDX,Y) +END SUBROUTINE CSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csrot.F90 b/src/modules/BLAS95/src/blas95_src/csrot.F90 new file mode 100755 index 000000000..18170df7d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/csrot.F90 @@ -0,0 +1,52 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSROT_F95(X,Y,C,S) + ! Fortran77 call: + ! CSROT(N,X,INCX,Y,INCY,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROT(N,X,INCX,Y,INCY,C,S) +END SUBROUTINE CSROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csscal.F90 b/src/modules/BLAS95/src/blas95_src/csscal.F90 new file mode 100755 index 000000000..189d0447b --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/csscal.F90 @@ -0,0 +1,48 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSSCAL_F95(X,A) + ! Fortran77 call: + ! CSSCAL(N,A,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCAL + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCAL(N,A,X,INCX) +END SUBROUTINE CSSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/cswap.F90 b/src/modules/BLAS95/src/blas95_src/cswap.F90 new file mode 100755 index 000000000..c53069dd8 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/cswap.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSWAP_F95(X,Y) + ! Fortran77 call: + ! CSWAP(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SWAP + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SWAP(N,X,INCX,Y,INCY) +END SUBROUTINE CSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csymm.F90 b/src/modules/BLAS95/src/blas95_src/csymm.F90 new file mode 100755 index 000000000..7d1e59ef7 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/csymm.F90 @@ -0,0 +1,87 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE CSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csyr2k.F90 b/src/modules/BLAS95/src/blas95_src/csyr2k.F90 new file mode 100755 index 000000000..ae2c0c5e0 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/csyr2k.F90 @@ -0,0 +1,91 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR2K + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE CSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/csyrk.F90 b/src/modules/BLAS95/src/blas95_src/csyrk.F90 new file mode 100755 index 000000000..c67cc6657 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/csyrk.F90 @@ -0,0 +1,88 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYRK + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) +END SUBROUTINE CSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctbmv.F90 b/src/modules/BLAS95/src/blas95_src/ctbmv.F90 new file mode 100755 index 000000000..3c9dc65db --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctbmv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE CTBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctbsv.F90 b/src/modules/BLAS95/src/blas95_src/ctbsv.F90 new file mode 100755 index 000000000..956c8e068 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctbsv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE CTBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctpmv.F90 b/src/modules/BLAS95/src/blas95_src/ctpmv.F90 new file mode 100755 index 000000000..e074ff8d7 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctpmv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE CTPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctpsv.F90 b/src/modules/BLAS95/src/blas95_src/ctpsv.F90 new file mode 100755 index 000000000..8618999cb --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctpsv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE CTPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrmm.F90 b/src/modules/BLAS95/src/blas95_src/ctrmm.F90 new file mode 100755 index 000000000..65480605c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctrmm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + COMPLEX(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE CTRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrmv.F90 b/src/modules/BLAS95/src/blas95_src/ctrmv.F90 new file mode 100755 index 000000000..38f872cc0 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctrmv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE CTRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrsm.F90 b/src/modules/BLAS95/src/blas95_src/ctrsm.F90 new file mode 100755 index 000000000..67e399762 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctrsm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + COMPLEX(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE CTRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 new file mode 100755 index 000000000..76cd1c7c4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctrsm_batch.F90 @@ -0,0 +1,191 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE CTRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & + & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & + & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) + ! Fortran77 call: + ! CTRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! GROUP_COUNT,GROUP_SIZE) + ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' + ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! SIDE_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) + ! UPLO_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! DIAG_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'CTRSM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) + COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(SIDE_ARRAY)) THEN + O_SIDE_ARRAY => SIDE_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_SIDE_ARRAY(I) = 'L' + END DO + ENDIF + ENDIF + IF(PRESENT(UPLO_ARRAY)) THEN + O_UPLO_ARRAY => UPLO_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_UPLO_ARRAY(I) = 'U' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(DIAG_ARRAY)) THEN + O_DIAG_ARRAY => DIAG_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_DIAG_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF(O_SIDE_ARRAY(I).EQ.'L') THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & + & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & + & O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & + & GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(SIDE_ARRAY)) THEN + IF (ASSOCIATED(O_SIDE_ARRAY)) THEN + DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(UPLO_ARRAY)) THEN + IF (ASSOCIATED(O_UPLO_ARRAY)) THEN + DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(DIAG_ARRAY)) THEN + IF (ASSOCIATED(O_DIAG_ARRAY)) THEN + DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE CTRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ctrsv.F90 b/src/modules/BLAS95/src/blas95_src/ctrsv.F90 new file mode 100755 index 000000000..72518dbea --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ctrsv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE CTRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE CTRSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dasum.F90 b/src/modules/BLAS95/src/blas95_src/dasum.F90 new file mode 100755 index 000000000..00a7602ff --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dasum.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION DASUM_F95(X) + ! Fortran77 call: + ! DASUM(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ASUM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DASUM_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + DASUM_F95 = F77_ASUM(N,X,INCX) +END FUNCTION DASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/daxpby.F90 b/src/modules/BLAS95/src/blas95_src/daxpby.F90 new file mode 100755 index 000000000..24f25c173 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/daxpby.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! DAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + ! Default ALPHA=1 + ! Default BETA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPBY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE DAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/daxpy.F90 b/src/modules/BLAS95/src/blas95_src/daxpy.F90 new file mode 100755 index 000000000..d4d6b51ec --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/daxpy.F90 @@ -0,0 +1,58 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DAXPY_F95(X,Y,A) + ! Fortran77 call: + ! DAXPY(N,A,X,INCX,Y,INCY) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' + ! <<< Local scalars >>> + REAL(WP) :: O_A + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) +END SUBROUTINE DAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/daxpyi.F90 b/src/modules/BLAS95/src/blas95_src/daxpyi.F90 new file mode 100755 index 000000000..8e124ba24 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/daxpyi.F90 @@ -0,0 +1,55 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! DAXPYI(NZ,A,X,INDX,Y) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPYI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' + ! <<< Local scalars >>> + REAL(WP) :: O_A + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPYI(NZ,O_A,X,INDX,Y) +END SUBROUTINE DAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dcabs1.F90 b/src/modules/BLAS95/src/blas95_src/dcabs1.F90 new file mode 100755 index 000000000..6d0974ec6 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dcabs1.F90 @@ -0,0 +1,37 @@ +!=============================================================================== +! Copyright 2015-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE FUNCTION DCABS1_F95(Z) + ! Fortran77 call: + ! DCABS(Z) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_CABS1 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DCABS1_F95 + ! <<< Arguments >>> + COMPLEX(WP), INTENT(IN) :: Z + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'CABS1' + ! <<< Executable statements >>> + ! <<< Call blas77 routine >>> + DCABS1_F95 = F77_CABS1(Z) +END FUNCTION DCABS1_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dcopy.F90 b/src/modules/BLAS95/src/blas95_src/dcopy.F90 new file mode 100755 index 000000000..e4b3a49d4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dcopy.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DCOPY_F95(X,Y) + ! Fortran77 call: + ! DCOPY(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_COPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_COPY(N,X,INCX,Y,INCY) +END SUBROUTINE DCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ddot.F90 b/src/modules/BLAS95/src/blas95_src/ddot.F90 new file mode 100755 index 000000000..84e1147c9 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ddot.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION DDOT_F95(X,Y) + ! Fortran77 call: + ! DDOT(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DDOT_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'DOT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + DDOT_F95 = F77_DOT(N,X,INCX,Y,INCY) +END FUNCTION DDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ddoti.F90 b/src/modules/BLAS95/src/blas95_src/ddoti.F90 new file mode 100755 index 000000000..a910d9d77 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ddoti.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION DDOTI_F95(X,INDX,Y) + ! Fortran77 call: + ! DDOTI(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DDOTI_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + DDOTI_F95 = F77_DOTI(NZ,X,INDX,Y) +END FUNCTION DDOTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgbmv.F90 b/src/modules/BLAS95/src/blas95_src/dgbmv.F90 new file mode 100755 index 000000000..57ae73720 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgbmv.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' + ! <<< Local scalars >>> + INTEGER :: O_KL + INTEGER :: O_M + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: KU + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + IF(PRESENT(KL)) THEN + O_KL = KL + ELSE + O_KL = (LDA-1)/2 + ENDIF + IF(PRESENT(M)) THEN + O_M = M + ELSE + O_M = N + ENDIF + KU = LDA-O_KL-1 + ! <<< Call blas77 routine >>> + CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & + & INCY) +END SUBROUTINE DGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgem2vu.F90 b/src/modules/BLAS95/src/blas95_src/dgem2vu.F90 new file mode 100755 index 000000000..bc32df5ad --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgem2vu.F90 @@ -0,0 +1,78 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! DGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEM2V + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X1(:) + REAL(WP), INTENT(IN) :: X2(:) + REAL(WP), INTENT(INOUT ) :: Y1(:) + REAL(WP), INTENT(INOUT ) :: Y2(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX1 + INTEGER :: INCX2 + INTEGER :: INCY1 + INTEGER :: INCY2 + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + INCX1 = 1 + INCX2 = 1 + INCY1 = 1 + INCY2 = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & + & Y2,INCY2) +END SUBROUTINE DGEM2VU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemm.F90 b/src/modules/BLAS95/src/blas95_src/dgemm.F90 new file mode 100755 index 000000000..163162ec8 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgemm.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & + & LDC) +END SUBROUTINE DGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 new file mode 100755 index 000000000..c342d12e5 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgemm_batch.F90 @@ -0,0 +1,190 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE DGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& + & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & + & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! DGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! BETA_ARRAY=Array of beta values; default: array where each element=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'DGEMM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) + REAL(WP), POINTER :: O_ALPHA_ARRAY(:) + REAL(WP), POINTER :: O_BETA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + INTEGER, POINTER :: LDC_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(BETA_ARRAY)) THEN + O_BETA_ARRAY => BETA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_BETA_ARRAY(I) = 0 + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSB_ARRAY)) THEN + O_TRANSB_ARRAY => TRANSB_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSB_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & + & O_TRANSA_ARRAY(I).EQ.'n')) THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & + & O_TRANSB_ARRAY(I).EQ.'n')) THEN + LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) + ELSE + LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & + & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(BETA_ARRAY)) THEN + IF (ASSOCIATED(O_BETA_ARRAY)) THEN + DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN + DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDC_ARRAY)) THEN + DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE DGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemmt.F90 b/src/modules/BLAS95/src/blas95_src/dgemmt.F90 new file mode 100755 index 000000000..365fd419d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgemmt.F90 @@ -0,0 +1,100 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMMT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & + & O_BETA,C,LDC) +END SUBROUTINE DGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgemv.F90 b/src/modules/BLAS95/src/blas95_src/dgemv.F90 new file mode 100755 index 000000000..ec4deb720 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgemv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE DGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dger.F90 b/src/modules/BLAS95/src/blas95_src/dger.F90 new file mode 100755 index 000000000..ad23ef5a4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dger.F90 @@ -0,0 +1,63 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGER_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GER + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'GER' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GER(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE DGER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgthr.F90 b/src/modules/BLAS95/src/blas95_src/dgthr.F90 new file mode 100755 index 000000000..43400c968 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgthr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! DGTHR(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHR(NZ,Y,X,INDX) +END SUBROUTINE DGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dgthrz.F90 b/src/modules/BLAS95/src/blas95_src/dgthrz.F90 new file mode 100755 index 000000000..951baebdc --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dgthrz.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! DGTHRZ(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHRZ + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHRZ(NZ,Y,X,INDX) +END SUBROUTINE DGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dnrm2.F90 b/src/modules/BLAS95/src/blas95_src/dnrm2.F90 new file mode 100755 index 000000000..bd2cbedb9 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dnrm2.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION DNRM2_F95(X) + ! Fortran77 call: + ! DNRM2(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_NRM2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DNRM2_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + DNRM2_F95 = F77_NRM2(N,X,INCX) +END FUNCTION DNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drot.F90 b/src/modules/BLAS95/src/blas95_src/drot.F90 new file mode 100755 index 000000000..0688293f9 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/drot.F90 @@ -0,0 +1,52 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DROT_F95(X,Y,C,S) + ! Fortran77 call: + ! DROT(N,X,INCX,Y,INCY,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROT(N,X,INCX,Y,INCY,C,S) +END SUBROUTINE DROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drotg.F90 b/src/modules/BLAS95/src/blas95_src/drotg.F90 new file mode 100755 index 000000000..5ad503350 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/drotg.F90 @@ -0,0 +1,40 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE DROTG_F95(A,B,C,S) + ! Fortran77 call: + ! DROTG(A,B,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTG + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(INOUT ) :: A + REAL(WP), INTENT(INOUT ) :: B + REAL(WP), INTENT(OUT) :: C + REAL(WP), INTENT(OUT) :: S + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' + ! <<< Local scalars >>> + ! <<< Executable statements >>> + ! <<< Call blas77 routine >>> + CALL F77_ROTG(A,B,C,S) +END SUBROUTINE DROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/droti.F90 b/src/modules/BLAS95/src/blas95_src/droti.F90 new file mode 100755 index 000000000..4e47910ab --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/droti.F90 @@ -0,0 +1,51 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DROTI_F95(X,INDX,Y,C,S) + ! Fortran77 call: + ! DROTI(NZ,X,INDX,Y,C,S) + ! Default C=1 + ! Default S=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROTI(NZ,X,INDX,Y,C,S) +END SUBROUTINE DROTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drotm.F90 b/src/modules/BLAS95/src/blas95_src/drotm.F90 new file mode 100755 index 000000000..03a1034fa --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/drotm.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DROTM_F95(X,Y,PARAM) + ! Fortran77 call: + ! DROTM(N,X,INCX,Y,INCY,PARAM) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + REAL(WP), INTENT(IN) :: PARAM(5) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTM' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROTM(N,X,INCX,Y,INCY,PARAM) +END SUBROUTINE DROTM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/drotmg.F90 b/src/modules/BLAS95/src/blas95_src/drotmg.F90 new file mode 100755 index 000000000..d23635e49 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/drotmg.F90 @@ -0,0 +1,45 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DROTMG_F95(D1,D2,X1,Y1,PARAM) + ! Fortran77 call: + ! DROTMG(D1,D2,X1,Y1,PARAM) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTMG + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(INOUT ) :: D1 + REAL(WP), INTENT(INOUT ) :: D2 + REAL(WP), INTENT(INOUT ) :: X1 + REAL(WP), INTENT(IN) :: Y1 + ! <<< Array arguments >>> + REAL(WP), INTENT(OUT) :: PARAM(5) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'ROTMG' + ! <<< Local scalars >>> + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + ! <<< Call blas77 routine >>> + CALL F77_ROTMG(D1,D2,X1,Y1,PARAM) +END SUBROUTINE DROTMG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsbmv.F90 b/src/modules/BLAS95/src/blas95_src/dsbmv.F90 new file mode 100755 index 000000000..89aacd433 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsbmv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE DSBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dscal.F90 b/src/modules/BLAS95/src/blas95_src/dscal.F90 new file mode 100755 index 000000000..88d0c333a --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dscal.F90 @@ -0,0 +1,48 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSCAL_F95(X,A) + ! Fortran77 call: + ! DSCAL(N,A,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCAL + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: A + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCAL(N,A,X,INCX) +END SUBROUTINE DSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsctr.F90 b/src/modules/BLAS95/src/blas95_src/dsctr.F90 new file mode 100755 index 000000000..7152b0e7d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsctr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! DSCTR(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCTR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(OUT) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCTR(NZ,X,INDX,Y) +END SUBROUTINE DSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsdot.F90 b/src/modules/BLAS95/src/blas95_src/dsdot.F90 new file mode 100755 index 000000000..c97267bf7 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsdot.F90 @@ -0,0 +1,51 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION DSDOT_F95(SX,SY) + ! Fortran77 call: + ! DSDOT(N,SX,INCX,SY,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SDOT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER, PARAMETER :: SP = KIND(1.0E0) + REAL(WP) :: DSDOT_F95 + ! <<< Array arguments >>> + REAL(SP), INTENT(IN) :: SX(:) + REAL(SP), INTENT(IN) :: SY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SDOT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(SX) + ! <<< Call blas77 routine >>> + DSDOT_F95 = F77_SDOT(N,SX,INCX,SY,INCY) +END FUNCTION DSDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dspmv.F90 b/src/modules/BLAS95/src/blas95_src/dspmv.F90 new file mode 100755 index 000000000..eb7991b84 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dspmv.F90 @@ -0,0 +1,75 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE DSPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dspr.F90 b/src/modules/BLAS95/src/blas95_src/dspr.F90 new file mode 100755 index 000000000..ee7efbca4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dspr.F90 @@ -0,0 +1,64 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! DSPR(UPLO,N,ALPHA,X,INCX,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SPR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SPR' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SPR(O_UPLO,N,O_ALPHA,X,INCX,AP) +END SUBROUTINE DSPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dspr2.F90 b/src/modules/BLAS95/src/blas95_src/dspr2.F90 new file mode 100755 index 000000000..426968482 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dspr2.F90 @@ -0,0 +1,67 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SPR2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPR2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) +END SUBROUTINE DSPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dswap.F90 b/src/modules/BLAS95/src/blas95_src/dswap.F90 new file mode 100755 index 000000000..a87adf606 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dswap.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSWAP_F95(X,Y) + ! Fortran77 call: + ! DSWAP(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SWAP + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SWAP(N,X,INCX,Y,INCY) +END SUBROUTINE DSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsymm.F90 b/src/modules/BLAS95/src/blas95_src/dsymm.F90 new file mode 100755 index 000000000..a568a18b4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsymm.F90 @@ -0,0 +1,87 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE DSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsymv.F90 b/src/modules/BLAS95/src/blas95_src/dsymv.F90 new file mode 100755 index 000000000..94ab9b413 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsymv.F90 @@ -0,0 +1,77 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_SYMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE DSYMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyr.F90 b/src/modules/BLAS95/src/blas95_src/dsyr.F90 new file mode 100755 index 000000000..693010a75 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsyr.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSYR_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SYR' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) +END SUBROUTINE DSYR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyr2.F90 b/src/modules/BLAS95/src/blas95_src/dsyr2.F90 new file mode 100755 index 000000000..8c34bb3b5 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsyr2.F90 @@ -0,0 +1,69 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSYR2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYR2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE DSYR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyr2k.F90 b/src/modules/BLAS95/src/blas95_src/dsyr2k.F90 new file mode 100755 index 000000000..8089ba316 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsyr2k.F90 @@ -0,0 +1,91 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR2K + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE DSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dsyrk.F90 b/src/modules/BLAS95/src/blas95_src/dsyrk.F90 new file mode 100755 index 000000000..b4320c22e --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dsyrk.F90 @@ -0,0 +1,88 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYRK + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) +END SUBROUTINE DSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtbmv.F90 b/src/modules/BLAS95/src/blas95_src/dtbmv.F90 new file mode 100755 index 000000000..cd5f05270 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtbmv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE DTBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtbsv.F90 b/src/modules/BLAS95/src/blas95_src/dtbsv.F90 new file mode 100755 index 000000000..34a706679 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtbsv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE DTBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtpmv.F90 b/src/modules/BLAS95/src/blas95_src/dtpmv.F90 new file mode 100755 index 000000000..dc8ad0775 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtpmv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE DTPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtpsv.F90 b/src/modules/BLAS95/src/blas95_src/dtpsv.F90 new file mode 100755 index 000000000..2ae69a85d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtpsv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE DTPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrmm.F90 b/src/modules/BLAS95/src/blas95_src/dtrmm.F90 new file mode 100755 index 000000000..72237d63d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtrmm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + REAL(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE DTRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrmv.F90 b/src/modules/BLAS95/src/blas95_src/dtrmv.F90 new file mode 100755 index 000000000..1f50d20bf --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtrmv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE DTRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrsm.F90 b/src/modules/BLAS95/src/blas95_src/dtrsm.F90 new file mode 100755 index 000000000..2dfb9406d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtrsm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + REAL(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE DTRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 new file mode 100755 index 000000000..32c03b120 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtrsm_batch.F90 @@ -0,0 +1,191 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE DTRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & + & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & + & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) + ! Fortran77 call: + ! DTRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! GROUP_COUNT,GROUP_SIZE) + ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' + ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! SIDE_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) + ! UPLO_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! DIAG_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'DTRSM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) + REAL(WP), POINTER :: O_ALPHA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(SIDE_ARRAY)) THEN + O_SIDE_ARRAY => SIDE_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_SIDE_ARRAY(I) = 'L' + END DO + ENDIF + ENDIF + IF(PRESENT(UPLO_ARRAY)) THEN + O_UPLO_ARRAY => UPLO_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_UPLO_ARRAY(I) = 'U' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(DIAG_ARRAY)) THEN + O_DIAG_ARRAY => DIAG_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_DIAG_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF(O_SIDE_ARRAY(I).EQ.'L') THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & + & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & + & O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & + & GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(SIDE_ARRAY)) THEN + IF (ASSOCIATED(O_SIDE_ARRAY)) THEN + DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(UPLO_ARRAY)) THEN + IF (ASSOCIATED(O_UPLO_ARRAY)) THEN + DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(DIAG_ARRAY)) THEN + IF (ASSOCIATED(O_DIAG_ARRAY)) THEN + DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE DTRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dtrsv.F90 b/src/modules/BLAS95/src/blas95_src/dtrsv.F90 new file mode 100755 index 000000000..aa8396132 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dtrsv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DTRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE DTRSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dzasum.F90 b/src/modules/BLAS95/src/blas95_src/dzasum.F90 new file mode 100755 index 000000000..ded9b3c0e --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dzasum.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION DZASUM_F95(X) + ! Fortran77 call: + ! DZASUM(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ASUM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DZASUM_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + DZASUM_F95 = F77_ASUM(N,X,INCX) +END FUNCTION DZASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dzgemm.F90 b/src/modules/BLAS95/src/blas95_src/dzgemm.F90 new file mode 100755 index 000000000..7eef1fede --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dzgemm.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! DZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & + & LDC) +END SUBROUTINE DZGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dzgemv.F90 b/src/modules/BLAS95/src/blas95_src/dzgemv.F90 new file mode 100755 index 000000000..41a1de187 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dzgemv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE DZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! DZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE DZGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/dznrm2.F90 b/src/modules/BLAS95/src/blas95_src/dznrm2.F90 new file mode 100755 index 000000000..37fa0f4dc --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/dznrm2.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION DZNRM2_F95(X) + ! Fortran77 call: + ! DZNRM2(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_NRM2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + REAL(WP) :: DZNRM2_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + DZNRM2_F95 = F77_NRM2(N,X,INCX) +END FUNCTION DZNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/icamax.F90 b/src/modules/BLAS95/src/blas95_src/icamax.F90 new file mode 100755 index 000000000..7897bdfdd --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/icamax.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ICAMAX_F95(X) + ! Fortran77 call: + ! ICAMAX(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMAX + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ICAMAX_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + ICAMAX_F95 = F77_IAMAX(N,X,INCX) +END FUNCTION ICAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/icamin.F90 b/src/modules/BLAS95/src/blas95_src/icamin.F90 new file mode 100755 index 000000000..d5e29da81 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/icamin.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ICAMIN_F95(X) + ! Fortran77 call: + ! ICAMIN(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMIN + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ICAMIN_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + ICAMIN_F95 = F77_IAMIN(N,X,INCX) +END FUNCTION ICAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/idamax.F90 b/src/modules/BLAS95/src/blas95_src/idamax.F90 new file mode 100755 index 000000000..f19045683 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/idamax.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION IDAMAX_F95(X) + ! Fortran77 call: + ! IDAMAX(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMAX + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IDAMAX_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + IDAMAX_F95 = F77_IAMAX(N,X,INCX) +END FUNCTION IDAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/idamin.F90 b/src/modules/BLAS95/src/blas95_src/idamin.F90 new file mode 100755 index 000000000..ee903a516 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/idamin.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION IDAMIN_F95(X) + ! Fortran77 call: + ! IDAMIN(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMIN + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IDAMIN_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + IDAMIN_F95 = F77_IAMIN(N,X,INCX) +END FUNCTION IDAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/isamax.F90 b/src/modules/BLAS95/src/blas95_src/isamax.F90 new file mode 100755 index 000000000..8e6e62d8b --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/isamax.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ISAMAX_F95(X) + ! Fortran77 call: + ! ISAMAX(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMAX + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ISAMAX_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + ISAMAX_F95 = F77_IAMAX(N,X,INCX) +END FUNCTION ISAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/isamin.F90 b/src/modules/BLAS95/src/blas95_src/isamin.F90 new file mode 100755 index 000000000..72c17d539 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/isamin.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ISAMIN_F95(X) + ! Fortran77 call: + ! ISAMIN(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMIN + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + INTEGER :: ISAMIN_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + ISAMIN_F95 = F77_IAMIN(N,X,INCX) +END FUNCTION ISAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/izamax.F90 b/src/modules/BLAS95/src/blas95_src/izamax.F90 new file mode 100755 index 000000000..225099639 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/izamax.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION IZAMAX_F95(X) + ! Fortran77 call: + ! IZAMAX(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMAX + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IZAMAX_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMAX' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + IZAMAX_F95 = F77_IAMAX(N,X,INCX) +END FUNCTION IZAMAX_F95 diff --git a/src/modules/BLAS95/src/blas95_src/izamin.F90 b/src/modules/BLAS95/src/blas95_src/izamin.F90 new file mode 100755 index 000000000..d6ddcf1c7 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/izamin.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION IZAMIN_F95(X) + ! Fortran77 call: + ! IZAMIN(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_IAMIN + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + INTEGER :: IZAMIN_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'IAMIN' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + IZAMIN_F95 = F77_IAMIN(N,X,INCX) +END FUNCTION IZAMIN_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sasum.F90 b/src/modules/BLAS95/src/blas95_src/sasum.F90 new file mode 100755 index 000000000..7e22c3c74 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sasum.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION SASUM_F95(X) + ! Fortran77 call: + ! SASUM(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ASUM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SASUM_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + SASUM_F95 = F77_ASUM(N,X,INCX) +END FUNCTION SASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/saxpby.F90 b/src/modules/BLAS95/src/blas95_src/saxpby.F90 new file mode 100755 index 000000000..9b58d7c31 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/saxpby.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! SAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + ! Default ALPHA=1 + ! Default BETA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPBY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE SAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/saxpy.F90 b/src/modules/BLAS95/src/blas95_src/saxpy.F90 new file mode 100755 index 000000000..b9c740284 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/saxpy.F90 @@ -0,0 +1,58 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SAXPY_F95(X,Y,A) + ! Fortran77 call: + ! SAXPY(N,A,X,INCX,Y,INCY) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' + ! <<< Local scalars >>> + REAL(WP) :: O_A + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) +END SUBROUTINE SAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/saxpyi.F90 b/src/modules/BLAS95/src/blas95_src/saxpyi.F90 new file mode 100755 index 000000000..23845d822 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/saxpyi.F90 @@ -0,0 +1,55 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! SAXPYI(NZ,A,X,INDX,Y) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPYI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' + ! <<< Local scalars >>> + REAL(WP) :: O_A + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPYI(NZ,O_A,X,INDX,Y) +END SUBROUTINE SAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scabs1.F90 b/src/modules/BLAS95/src/blas95_src/scabs1.F90 new file mode 100755 index 000000000..2cc362070 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/scabs1.F90 @@ -0,0 +1,37 @@ +!=============================================================================== +! Copyright 2015-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE FUNCTION SCABS1_F95(Z) + ! Fortran77 call: + ! SCABS(Z) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_CABS1 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SCABS1_F95 + ! <<< Arguments >>> + COMPLEX(WP), INTENT(IN) :: Z + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'CABS1' + ! <<< Executable statements >>> + ! <<< Call blas77 routine >>> + SCABS1_F95 = F77_CABS1(Z) +END FUNCTION SCABS1_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scasum.F90 b/src/modules/BLAS95/src/blas95_src/scasum.F90 new file mode 100755 index 000000000..f0bcebad9 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/scasum.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION SCASUM_F95(X) + ! Fortran77 call: + ! SCASUM(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ASUM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SCASUM_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ASUM' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + SCASUM_F95 = F77_ASUM(N,X,INCX) +END FUNCTION SCASUM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scgemm.F90 b/src/modules/BLAS95/src/blas95_src/scgemm.F90 new file mode 100755 index 000000000..d67e69b77 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/scgemm.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SCGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! SCGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & + & LDC) +END SUBROUTINE SCGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scgemv.F90 b/src/modules/BLAS95/src/blas95_src/scgemv.F90 new file mode 100755 index 000000000..75f8c48e5 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/scgemv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SCGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! SCGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE SCGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scnrm2.F90 b/src/modules/BLAS95/src/blas95_src/scnrm2.F90 new file mode 100755 index 000000000..5a868feae --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/scnrm2.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION SCNRM2_F95(X) + ! Fortran77 call: + ! SCNRM2(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_NRM2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SCNRM2_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + SCNRM2_F95 = F77_NRM2(N,X,INCX) +END FUNCTION SCNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/scopy.F90 b/src/modules/BLAS95/src/blas95_src/scopy.F90 new file mode 100755 index 000000000..658826f8b --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/scopy.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SCOPY_F95(X,Y) + ! Fortran77 call: + ! SCOPY(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_COPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_COPY(N,X,INCX,Y,INCY) +END SUBROUTINE SCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sdot.F90 b/src/modules/BLAS95/src/blas95_src/sdot.F90 new file mode 100755 index 000000000..c7dcd1694 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sdot.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION SDOT_F95(X,Y) + ! Fortran77 call: + ! SDOT(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SDOT_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'DOT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + SDOT_F95 = F77_DOT(N,X,INCX,Y,INCY) +END FUNCTION SDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sdoti.F90 b/src/modules/BLAS95/src/blas95_src/sdoti.F90 new file mode 100755 index 000000000..8ddf6f3fc --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sdoti.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION SDOTI_F95(X,INDX,Y) + ! Fortran77 call: + ! SDOTI(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SDOTI_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + SDOTI_F95 = F77_DOTI(NZ,X,INDX,Y) +END FUNCTION SDOTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sdsdot.F90 b/src/modules/BLAS95/src/blas95_src/sdsdot.F90 new file mode 100755 index 000000000..75f1108f2 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sdsdot.F90 @@ -0,0 +1,52 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION SDSDOT_F95(SX,SY,SB) + ! Fortran77 call: + ! SDSDOT(N,SB,SX,INCX,SY,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SDOT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SDSDOT_F95 + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: SB + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: SX(:) + REAL(WP), INTENT(IN) :: SY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SDOT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(SX) + ! <<< Call blas77 routine >>> + SDSDOT_F95 = F77_SDOT(N,SB,SX,INCX,SY,INCY) +END FUNCTION SDSDOT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgbmv.F90 b/src/modules/BLAS95/src/blas95_src/sgbmv.F90 new file mode 100755 index 000000000..743af1520 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgbmv.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' + ! <<< Local scalars >>> + INTEGER :: O_KL + INTEGER :: O_M + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: KU + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + IF(PRESENT(KL)) THEN + O_KL = KL + ELSE + O_KL = (LDA-1)/2 + ENDIF + IF(PRESENT(M)) THEN + O_M = M + ELSE + O_M = N + ENDIF + KU = LDA-O_KL-1 + ! <<< Call blas77 routine >>> + CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & + & INCY) +END SUBROUTINE SGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgem2vu.F90 b/src/modules/BLAS95/src/blas95_src/sgem2vu.F90 new file mode 100755 index 000000000..a1464079c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgem2vu.F90 @@ -0,0 +1,78 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! SGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEM2V + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X1(:) + REAL(WP), INTENT(IN) :: X2(:) + REAL(WP), INTENT(INOUT ) :: Y1(:) + REAL(WP), INTENT(INOUT ) :: Y2(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX1 + INTEGER :: INCX2 + INTEGER :: INCY1 + INTEGER :: INCY2 + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + INCX1 = 1 + INCX2 = 1 + INCY1 = 1 + INCY2 = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & + & Y2,INCY2) +END SUBROUTINE SGEM2VU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemm.F90 b/src/modules/BLAS95/src/blas95_src/sgemm.F90 new file mode 100755 index 000000000..e532f434d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgemm.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & + & LDC) +END SUBROUTINE SGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 new file mode 100755 index 000000000..08fb37bcb --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgemm_batch.F90 @@ -0,0 +1,190 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE SGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& + & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & + & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! SGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! BETA_ARRAY=Array of beta values; default: array where each element=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'SGEMM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) + REAL(WP), POINTER :: O_ALPHA_ARRAY(:) + REAL(WP), POINTER :: O_BETA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + INTEGER, POINTER :: LDC_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(BETA_ARRAY)) THEN + O_BETA_ARRAY => BETA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_BETA_ARRAY(I) = 0 + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSB_ARRAY)) THEN + O_TRANSB_ARRAY => TRANSB_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSB_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & + & O_TRANSA_ARRAY(I).EQ.'n')) THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & + & O_TRANSB_ARRAY(I).EQ.'n')) THEN + LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) + ELSE + LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & + & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(BETA_ARRAY)) THEN + IF (ASSOCIATED(O_BETA_ARRAY)) THEN + DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN + DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDC_ARRAY)) THEN + DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE SGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemmt.F90 b/src/modules/BLAS95/src/blas95_src/sgemmt.F90 new file mode 100755 index 000000000..3e71e98fb --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgemmt.F90 @@ -0,0 +1,100 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMMT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & + & O_BETA,C,LDC) +END SUBROUTINE SGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgemv.F90 b/src/modules/BLAS95/src/blas95_src/sgemv.F90 new file mode 100755 index 000000000..9dd56a189 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgemv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE SGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sger.F90 b/src/modules/BLAS95/src/blas95_src/sger.F90 new file mode 100755 index 000000000..b429e874f --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sger.F90 @@ -0,0 +1,63 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGER_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GER + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'GER' + ! <<< Local scalars >>> + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GER(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE SGER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgthr.F90 b/src/modules/BLAS95/src/blas95_src/sgthr.F90 new file mode 100755 index 000000000..bf960fdb7 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgthr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! SGTHR(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHR(NZ,Y,X,INDX) +END SUBROUTINE SGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sgthrz.F90 b/src/modules/BLAS95/src/blas95_src/sgthrz.F90 new file mode 100755 index 000000000..d640925e5 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sgthrz.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! SGTHRZ(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHRZ + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHRZ(NZ,Y,X,INDX) +END SUBROUTINE SGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/snrm2.F90 b/src/modules/BLAS95/src/blas95_src/snrm2.F90 new file mode 100755 index 000000000..0290f354c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/snrm2.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION SNRM2_F95(X) + ! Fortran77 call: + ! SNRM2(N,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_NRM2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + REAL(WP) :: SNRM2_F95 + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'NRM2' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + SNRM2_F95 = F77_NRM2(N,X,INCX) +END FUNCTION SNRM2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srot.F90 b/src/modules/BLAS95/src/blas95_src/srot.F90 new file mode 100755 index 000000000..a2dde608a --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/srot.F90 @@ -0,0 +1,52 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SROT_F95(X,Y,C,S) + ! Fortran77 call: + ! SROT(N,X,INCX,Y,INCY,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROT(N,X,INCX,Y,INCY,C,S) +END SUBROUTINE SROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srotg.F90 b/src/modules/BLAS95/src/blas95_src/srotg.F90 new file mode 100755 index 000000000..763ebaf4b --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/srotg.F90 @@ -0,0 +1,40 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE SROTG_F95(A,B,C,S) + ! Fortran77 call: + ! SROTG(A,B,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTG + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(INOUT ) :: A + REAL(WP), INTENT(INOUT ) :: B + REAL(WP), INTENT(OUT) :: C + REAL(WP), INTENT(OUT) :: S + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' + ! <<< Local scalars >>> + ! <<< Executable statements >>> + ! <<< Call blas77 routine >>> + CALL F77_ROTG(A,B,C,S) +END SUBROUTINE SROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sroti.F90 b/src/modules/BLAS95/src/blas95_src/sroti.F90 new file mode 100755 index 000000000..3d5dfa2d4 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sroti.F90 @@ -0,0 +1,51 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SROTI_F95(X,INDX,Y,C,S) + ! Fortran77 call: + ! SROTI(NZ,X,INDX,Y,C,S) + ! Default C=1 + ! Default S=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROTI(NZ,X,INDX,Y,C,S) +END SUBROUTINE SROTI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srotm.F90 b/src/modules/BLAS95/src/blas95_src/srotm.F90 new file mode 100755 index 000000000..1ff97a845 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/srotm.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SROTM_F95(X,Y,PARAM) + ! Fortran77 call: + ! SROTM(N,X,INCX,Y,INCY,PARAM) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + REAL(WP), INTENT(IN) :: PARAM(5) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTM' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROTM(N,X,INCX,Y,INCY,PARAM) +END SUBROUTINE SROTM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/srotmg.F90 b/src/modules/BLAS95/src/blas95_src/srotmg.F90 new file mode 100755 index 000000000..b326e6a2a --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/srotmg.F90 @@ -0,0 +1,45 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SROTMG_F95(D1,D2,X1,Y1,PARAM) + ! Fortran77 call: + ! SROTMG(D1,D2,X1,Y1,PARAM) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTMG + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(INOUT ) :: D1 + REAL(WP), INTENT(INOUT ) :: D2 + REAL(WP), INTENT(INOUT ) :: X1 + REAL(WP), INTENT(IN) :: Y1 + ! <<< Array arguments >>> + REAL(WP), INTENT(OUT) :: PARAM(5) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'ROTMG' + ! <<< Local scalars >>> + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + ! <<< Call blas77 routine >>> + CALL F77_ROTMG(D1,D2,X1,Y1,PARAM) +END SUBROUTINE SROTMG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssbmv.F90 b/src/modules/BLAS95/src/blas95_src/ssbmv.F90 new file mode 100755 index 000000000..b350f2a2e --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssbmv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE SSBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sscal.F90 b/src/modules/BLAS95/src/blas95_src/sscal.F90 new file mode 100755 index 000000000..5efbcc568 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sscal.F90 @@ -0,0 +1,48 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSCAL_F95(X,A) + ! Fortran77 call: + ! SSCAL(N,A,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCAL + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: A + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCAL(N,A,X,INCX) +END SUBROUTINE SSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssctr.F90 b/src/modules/BLAS95/src/blas95_src/ssctr.F90 new file mode 100755 index 000000000..0bd1409e6 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssctr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! SSCTR(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCTR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(OUT) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCTR(NZ,X,INDX,Y) +END SUBROUTINE SSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sspmv.F90 b/src/modules/BLAS95/src/blas95_src/sspmv.F90 new file mode 100755 index 000000000..7690e62d2 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sspmv.F90 @@ -0,0 +1,75 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE SSPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sspr.F90 b/src/modules/BLAS95/src/blas95_src/sspr.F90 new file mode 100755 index 000000000..102b8a9de --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sspr.F90 @@ -0,0 +1,64 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! SSPR(UPLO,N,ALPHA,X,INCX,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SPR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SPR' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SPR(O_UPLO,N,O_ALPHA,X,INCX,AP) +END SUBROUTINE SSPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sspr2.F90 b/src/modules/BLAS95/src/blas95_src/sspr2.F90 new file mode 100755 index 000000000..80ab84103 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sspr2.F90 @@ -0,0 +1,67 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SPR2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SPR2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) +END SUBROUTINE SSPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/sswap.F90 b/src/modules/BLAS95/src/blas95_src/sswap.F90 new file mode 100755 index 000000000..84e69ee20 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/sswap.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSWAP_F95(X,Y) + ! Fortran77 call: + ! SSWAP(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SWAP + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SWAP(N,X,INCX,Y,INCY) +END SUBROUTINE SSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssymm.F90 b/src/modules/BLAS95/src/blas95_src/ssymm.F90 new file mode 100755 index 000000000..417091a79 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssymm.F90 @@ -0,0 +1,87 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE SSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssymv.F90 b/src/modules/BLAS95/src/blas95_src/ssymv.F90 new file mode 100755 index 000000000..3309c297e --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssymv.F90 @@ -0,0 +1,77 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_SYMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE SSYMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyr.F90 b/src/modules/BLAS95/src/blas95_src/ssyr.F90 new file mode 100755 index 000000000..0cffcb6b8 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssyr.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSYR_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'SYR' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) +END SUBROUTINE SSYR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyr2.F90 b/src/modules/BLAS95/src/blas95_src/ssyr2.F90 new file mode 100755 index 000000000..d00fa770c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssyr2.F90 @@ -0,0 +1,69 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSYR2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYR2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE SSYR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyr2k.F90 b/src/modules/BLAS95/src/blas95_src/ssyr2k.F90 new file mode 100755 index 000000000..aaaa71417 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssyr2k.F90 @@ -0,0 +1,91 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR2K + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE SSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ssyrk.F90 b/src/modules/BLAS95/src/blas95_src/ssyrk.F90 new file mode 100755 index 000000000..5f63cfda8 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ssyrk.F90 @@ -0,0 +1,88 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE SSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYRK + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) +END SUBROUTINE SSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stbmv.F90 b/src/modules/BLAS95/src/blas95_src/stbmv.F90 new file mode 100755 index 000000000..199831df5 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/stbmv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE STBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stbsv.F90 b/src/modules/BLAS95/src/blas95_src/stbsv.F90 new file mode 100755 index 000000000..0efa9364b --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/stbsv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE STBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stpmv.F90 b/src/modules/BLAS95/src/blas95_src/stpmv.F90 new file mode 100755 index 000000000..94d22d53c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/stpmv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE STPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/stpsv.F90 b/src/modules/BLAS95/src/blas95_src/stpsv.F90 new file mode 100755 index 000000000..8ffe34c94 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/stpsv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE STPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strmm.F90 b/src/modules/BLAS95/src/blas95_src/strmm.F90 new file mode 100755 index 000000000..dbb95c0b8 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/strmm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + REAL(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE STRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strmv.F90 b/src/modules/BLAS95/src/blas95_src/strmv.F90 new file mode 100755 index 000000000..d34f52fbf --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/strmv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE STRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strsm.F90 b/src/modules/BLAS95/src/blas95_src/strsm.F90 new file mode 100755 index 000000000..9d4cf4cd3 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/strsm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + REAL(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE STRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/strsm_batch.F90 new file mode 100755 index 000000000..df85eefcf --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/strsm_batch.F90 @@ -0,0 +1,191 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE STRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & + & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & + & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) + ! Fortran77 call: + ! STRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! GROUP_COUNT,GROUP_SIZE) + ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' + ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! SIDE_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) + ! UPLO_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! DIAG_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'STRSM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) + REAL(WP), POINTER :: O_ALPHA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(SIDE_ARRAY)) THEN + O_SIDE_ARRAY => SIDE_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_SIDE_ARRAY(I) = 'L' + END DO + ENDIF + ENDIF + IF(PRESENT(UPLO_ARRAY)) THEN + O_UPLO_ARRAY => UPLO_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_UPLO_ARRAY(I) = 'U' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(DIAG_ARRAY)) THEN + O_DIAG_ARRAY => DIAG_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_DIAG_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF(O_SIDE_ARRAY(I).EQ.'L') THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & + & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & + & O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & + & GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(SIDE_ARRAY)) THEN + IF (ASSOCIATED(O_SIDE_ARRAY)) THEN + DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(UPLO_ARRAY)) THEN + IF (ASSOCIATED(O_UPLO_ARRAY)) THEN + DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(DIAG_ARRAY)) THEN + IF (ASSOCIATED(O_DIAG_ARRAY)) THEN + DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE STRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/strsv.F90 b/src/modules/BLAS95/src/blas95_src/strsv.F90 new file mode 100755 index 000000000..a4ba0ccb3 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/strsv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE STRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0E0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE STRSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zaxpby.F90 b/src/modules/BLAS95/src/blas95_src/zaxpby.F90 new file mode 100755 index 000000000..eda018f30 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zaxpby.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! ZAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + ! Default ALPHA=1 + ! Default BETA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPBY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPBY' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPBY(N,O_ALPHA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE ZAXPBY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zaxpy.F90 b/src/modules/BLAS95/src/blas95_src/zaxpy.F90 new file mode 100755 index 000000000..80d2c0a87 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zaxpy.F90 @@ -0,0 +1,58 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZAXPY_F95(X,Y,A) + ! Fortran77 call: + ! ZAXPY(N,A,X,INCX,Y,INCY) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'AXPY' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_A + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPY(N,O_A,X,INCX,Y,INCY) +END SUBROUTINE ZAXPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zaxpyi.F90 b/src/modules/BLAS95/src/blas95_src/zaxpyi.F90 new file mode 100755 index 000000000..46ea99efe --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zaxpyi.F90 @@ -0,0 +1,55 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! ZAXPYI(NZ,A,X,INDX,Y) + ! Default A=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_AXPYI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'AXPYI' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_A + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(A)) THEN + O_A = A + ELSE + O_A = 1 + ENDIF + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_AXPYI(NZ,O_A,X,INDX,Y) +END SUBROUTINE ZAXPYI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zcopy.F90 b/src/modules/BLAS95/src/blas95_src/zcopy.F90 new file mode 100755 index 000000000..6686d8f9c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zcopy.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZCOPY_F95(X,Y) + ! Fortran77 call: + ! ZCOPY(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_COPY + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'COPY' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_COPY(N,X,INCX,Y,INCY) +END SUBROUTINE ZCOPY_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotc.F90 b/src/modules/BLAS95/src/blas95_src/zdotc.F90 new file mode 100755 index 000000000..f350aa532 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zdotc.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ZDOTC_F95(X,Y) + ! Fortran77 call: + ! ZDOTC(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTC + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTC_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTC' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + ZDOTC_F95 = F77_DOTC(N,X,INCX,Y,INCY) +END FUNCTION ZDOTC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotci.F90 b/src/modules/BLAS95/src/blas95_src/zdotci.F90 new file mode 100755 index 000000000..46f6ed65f --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zdotci.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ZDOTCI_F95(X,INDX,Y) + ! Fortran77 call: + ! ZDOTCI(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTCI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTCI_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTCI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + ZDOTCI_F95 = F77_DOTCI(NZ,X,INDX,Y) +END FUNCTION ZDOTCI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotu.F90 b/src/modules/BLAS95/src/blas95_src/zdotu.F90 new file mode 100755 index 000000000..7a374d749 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zdotu.F90 @@ -0,0 +1,50 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ZDOTU_F95(X,Y) + ! Fortran77 call: + ! ZDOTU(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTU + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTU_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'DOTU' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + ZDOTU_F95 = F77_DOTU(N,X,INCX,Y,INCY) +END FUNCTION ZDOTU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdotui.F90 b/src/modules/BLAS95/src/blas95_src/zdotui.F90 new file mode 100755 index 000000000..66661113a --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zdotui.F90 @@ -0,0 +1,47 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE FUNCTION ZDOTUI_F95(X,INDX,Y) + ! Fortran77 call: + ! ZDOTUI(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_DOTUI + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + COMPLEX(WP) :: ZDOTUI_F95 + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'DOTUI' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + ZDOTUI_F95 = F77_DOTUI(NZ,X,INDX,Y) +END FUNCTION ZDOTUI_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdrot.F90 b/src/modules/BLAS95/src/blas95_src/zdrot.F90 new file mode 100755 index 000000000..c302cb600 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zdrot.F90 @@ -0,0 +1,52 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZDROT_F95(X,Y,C,S) + ! Fortran77 call: + ! ZDROT(N,X,INCX,Y,INCY,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'ROT' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_ROT(N,X,INCX,Y,INCY,C,S) +END SUBROUTINE ZDROT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zdscal.F90 b/src/modules/BLAS95/src/blas95_src/zdscal.F90 new file mode 100755 index 000000000..240b6d58c --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zdscal.F90 @@ -0,0 +1,48 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZDSCAL_F95(X,A) + ! Fortran77 call: + ! ZDSCAL(N,A,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCAL + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + REAL(WP), INTENT(IN) :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCAL(N,A,X,INCX) +END SUBROUTINE ZDSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgbmv.F90 b/src/modules/BLAS95/src/blas95_src/zgbmv.F90 new file mode 100755 index 000000000..aec39a04d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgbmv.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GBMV' + ! <<< Local scalars >>> + INTEGER :: O_KL + INTEGER :: O_M + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: KU + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + IF(PRESENT(KL)) THEN + O_KL = KL + ELSE + O_KL = (LDA-1)/2 + ENDIF + IF(PRESENT(M)) THEN + O_M = M + ELSE + O_M = N + ENDIF + KU = LDA-O_KL-1 + ! <<< Call blas77 routine >>> + CALL F77_GBMV(O_TRANS,O_M,N,O_KL,KU,O_ALPHA,A,LDA,X,INCX,O_BETA,Y, & + & INCY) +END SUBROUTINE ZGBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgem2vc.F90 b/src/modules/BLAS95/src/blas95_src/zgem2vc.F90 new file mode 100755 index 000000000..7ae6d29fc --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgem2vc.F90 @@ -0,0 +1,78 @@ +!=============================================================================== +! Copyright 2010-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! ZGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2,INCY2) + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEM2V + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X1(:) + COMPLEX(WP), INTENT(IN) :: X2(:) + COMPLEX(WP), INTENT(INOUT ) :: Y1(:) + COMPLEX(WP), INTENT(INOUT ) :: Y2(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEM2V' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX1 + INTEGER :: INCX2 + INTEGER :: INCY1 + INTEGER :: INCY2 + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + INCX1 = 1 + INCX2 = 1 + INCY1 = 1 + INCY2 = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEM2V(M,N,O_ALPHA,A,LDA,X1,INCX1,X2,INCX2,O_BETA,Y1,INCY1, & + & Y2,INCY2) +END SUBROUTINE ZGEM2VC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm.F90 b/src/modules/BLAS95/src/blas95_src/zgemm.F90 new file mode 100755 index 000000000..1cba4d2d7 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgemm.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C, & + & LDC) +END SUBROUTINE ZGEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm3m.F90 b/src/modules/BLAS95/src/blas95_src/zgemm3m.F90 new file mode 100755 index 000000000..505ab5499 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgemm3m.F90 @@ -0,0 +1,94 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! ZGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM3M + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=6), PARAMETER :: SRNAME = 'GEMM3M' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMM3M(O_TRANSA,O_TRANSB,M,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA, & + & C,LDC) +END SUBROUTINE ZGEMM3M_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 b/src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 new file mode 100755 index 000000000..b21b5c5fc --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgemm3m_batch.F90 @@ -0,0 +1,190 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE ZGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,GROUP_SIZE,TRANSA_ARRAY,& + & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! ZGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! BETA_ARRAY=Array of beta values; default: array where each element=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM3M_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=13), PARAMETER :: SRNAME = 'ZGEMM3M_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) + COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) + COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + INTEGER, POINTER :: LDC_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(BETA_ARRAY)) THEN + O_BETA_ARRAY => BETA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_BETA_ARRAY(I) = 0 + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSB_ARRAY)) THEN + O_TRANSB_ARRAY => TRANSB_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSB_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & + & O_TRANSA_ARRAY(I).EQ.'n')) THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & + & O_TRANSB_ARRAY(I).EQ.'n')) THEN + LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) + ELSE + LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_GEMM3M_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & + & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(BETA_ARRAY)) THEN + IF (ASSOCIATED(O_BETA_ARRAY)) THEN + DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN + DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDC_ARRAY)) THEN + DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE ZGEMM3M_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 b/src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 new file mode 100755 index 000000000..15e30f69d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgemm_batch.F90 @@ -0,0 +1,190 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE ZGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,& + & K_ARRAY,GROUP_SIZE,TRANSA_ARRAY, & + & TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! ZGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! BETA_ARRAY=Array of beta values; default: array where each element=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: BETA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(INOUT ) :: C_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'ZGEMM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSB_ARRAY(:) + COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) + COMPLEX(WP), POINTER :: O_BETA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + INTEGER, POINTER :: LDC_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(BETA_ARRAY)) THEN + O_BETA_ARRAY => BETA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_BETA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_BETA_ARRAY(I) = 0 + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSB_ARRAY)) THEN + O_TRANSB_ARRAY => TRANSB_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSB_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSA_ARRAY(I).EQ.'N' .OR. & + & O_TRANSA_ARRAY(I).EQ.'n')) THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,K_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF((O_TRANSB_ARRAY(I).EQ.'N' .OR. & + & O_TRANSB_ARRAY(I).EQ.'n')) THEN + LDB_ARRAY(I) = MAX(1,K_ARRAY(I)) + ELSE + LDB_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDC_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDC_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_GEMM_BATCH(O_TRANSA_ARRAY,O_TRANSB_ARRAY,M_ARRAY, & + & N_ARRAY,K_ARRAY,O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY,O_BETA_ARRAY, & + & C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(BETA_ARRAY)) THEN + IF (ASSOCIATED(O_BETA_ARRAY)) THEN + DEALLOCATE(O_BETA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSB_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSB_ARRAY)) THEN + DEALLOCATE(O_TRANSB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDC_ARRAY)) THEN + DEALLOCATE(LDC_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE ZGEMM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemmt.F90 b/src/modules/BLAS95/src/blas95_src/zgemmt.F90 new file mode 100755 index 000000000..6ccd57b8e --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgemmt.F90 @@ -0,0 +1,100 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMMT + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GEMMT' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_TRANSB + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(TRANSB)) THEN + O_TRANSB = TRANSB + ELSE + O_TRANSB = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANSA.EQ.'N'.OR.O_TRANSA.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMMT(O_UPLO,O_TRANSA,O_TRANSB,N,K,O_ALPHA,A,LDA,B,LDB, & + & O_BETA,C,LDC) +END SUBROUTINE ZGEMMT_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgemv.F90 b/src/modules/BLAS95/src/blas95_src/zgemv.F90 new file mode 100755 index 000000000..6bfcbd509 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgemv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GEMV' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + CHARACTER(LEN=1) :: O_TRANS + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GEMV(O_TRANS,M,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE ZGEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgerc.F90 b/src/modules/BLAS95/src/blas95_src/zgerc.F90 new file mode 100755 index 000000000..a8d2f7b03 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgerc.F90 @@ -0,0 +1,63 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGERC_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GERC + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERC' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GERC(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE ZGERC_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgeru.F90 b/src/modules/BLAS95/src/blas95_src/zgeru.F90 new file mode 100755 index 000000000..eaa558846 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgeru.F90 @@ -0,0 +1,63 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGERU_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GERU + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GERU' + ! <<< Local scalars >>> + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + M = SIZE(A,1) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_GERU(M,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE ZGERU_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgthr.F90 b/src/modules/BLAS95/src/blas95_src/zgthr.F90 new file mode 100755 index 000000000..076ef5d2d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgthr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! ZGTHR(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'GTHR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHR(NZ,Y,X,INDX) +END SUBROUTINE ZGTHR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zgthrz.F90 b/src/modules/BLAS95/src/blas95_src/zgthrz.F90 new file mode 100755 index 000000000..f30fa8b77 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zgthrz.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! ZGTHRZ(NZ,Y,X,INDX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_GTHRZ + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'GTHRZ' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_GTHRZ(NZ,Y,X,INDX) +END SUBROUTINE ZGTHRZ_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhbmv.F90 b/src/modules/BLAS95/src/blas95_src/zhbmv.F90 new file mode 100755 index 000000000..a68b28960 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zhbmv.F90 @@ -0,0 +1,79 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HBMV(O_UPLO,N,K,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE ZHBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhemm.F90 b/src/modules/BLAS95/src/blas95_src/zhemm.F90 new file mode 100755 index 000000000..d863e01be --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zhemm.F90 @@ -0,0 +1,87 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HEMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_HEMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE ZHEMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhemv.F90 b/src/modules/BLAS95/src/blas95_src/zhemv.F90 new file mode 100755 index 000000000..2dd97fef2 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zhemv.F90 @@ -0,0 +1,77 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HEMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HEMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HEMV(O_UPLO,N,O_ALPHA,A,LDA,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE ZHEMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zher.F90 b/src/modules/BLAS95/src/blas95_src/zher.F90 new file mode 100755 index 000000000..3711fcab6 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zher.F90 @@ -0,0 +1,66 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHER_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HER + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HER' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HER(O_UPLO,N,O_ALPHA,X,INCX,A,LDA) +END SUBROUTINE ZHER_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zher2.F90 b/src/modules/BLAS95/src/blas95_src/zher2.F90 new file mode 100755 index 000000000..48ed47b85 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zher2.F90 @@ -0,0 +1,69 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHER2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HER2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HER2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_HER2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,A,LDA) +END SUBROUTINE ZHER2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zher2k.F90 b/src/modules/BLAS95/src/blas95_src/zher2k.F90 new file mode 100755 index 000000000..250312c48 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zher2k.F90 @@ -0,0 +1,91 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HER2K + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'HER2K' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + COMPLEX(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_HER2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE ZHER2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zherk.F90 b/src/modules/BLAS95/src/blas95_src/zherk.F90 new file mode 100755 index 000000000..1930e5f61 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zherk.F90 @@ -0,0 +1,88 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HERK + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HERK' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + REAL(WP) :: O_ALPHA + REAL(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_HERK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) +END SUBROUTINE ZHERK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhpmv.F90 b/src/modules/BLAS95/src/blas95_src/zhpmv.F90 new file mode 100755 index 000000000..37c6e8221 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zhpmv.F90 @@ -0,0 +1,75 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_HPMV(O_UPLO,N,O_ALPHA,AP,X,INCX,O_BETA,Y,INCY) +END SUBROUTINE ZHPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhpr.F90 b/src/modules/BLAS95/src/blas95_src/zhpr.F90 new file mode 100755 index 000000000..21c5696a3 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zhpr.F90 @@ -0,0 +1,64 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! ZHPR(UPLO,N,ALPHA,X,INCX,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HPR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=3), PARAMETER :: SRNAME = 'HPR' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + REAL(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_HPR(O_UPLO,N,O_ALPHA,X,INCX,AP) +END SUBROUTINE ZHPR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zhpr2.F90 b/src/modules/BLAS95/src/blas95_src/zhpr2.F90 new file mode 100755 index 000000000..e4f298cea --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zhpr2.F90 @@ -0,0 +1,67 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZHPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_HPR2 + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'HPR2' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_HPR2(O_UPLO,N,O_ALPHA,X,INCX,Y,INCY,AP) +END SUBROUTINE ZHPR2_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zrotg.F90 b/src/modules/BLAS95/src/blas95_src/zrotg.F90 new file mode 100755 index 000000000..8f9b0f290 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zrotg.F90 @@ -0,0 +1,40 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE ZROTG_F95(A,B,C,S) + ! Fortran77 call: + ! ZROTG(A,B,C,S) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_ROTG + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: A + COMPLEX(WP), INTENT(INOUT ) :: B + REAL(WP), INTENT(OUT) :: C + COMPLEX(WP), INTENT(OUT) :: S + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'ROTG' + ! <<< Local scalars >>> + ! <<< Executable statements >>> + ! <<< Call blas77 routine >>> + CALL F77_ROTG(A,B,C,S) +END SUBROUTINE ZROTG_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zscal.F90 b/src/modules/BLAS95/src/blas95_src/zscal.F90 new file mode 100755 index 000000000..ce16ad85a --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zscal.F90 @@ -0,0 +1,48 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZSCAL_F95(X,A) + ! Fortran77 call: + ! ZSCAL(N,A,X,INCX) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCAL + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + COMPLEX(WP), INTENT(IN) :: A + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCAL' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCAL(N,A,X,INCX) +END SUBROUTINE ZSCAL_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsctr.F90 b/src/modules/BLAS95/src/blas95_src/zsctr.F90 new file mode 100755 index 000000000..258d4d25f --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zsctr.F90 @@ -0,0 +1,46 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! ZSCTR(NZ,X,INDX,Y) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SCTR + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(OUT) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SCTR' + ! <<< Local scalars >>> + INTEGER :: NZ + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + NZ = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SCTR(NZ,X,INDX,Y) +END SUBROUTINE ZSCTR_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zswap.F90 b/src/modules/BLAS95/src/blas95_src/zswap.F90 new file mode 100755 index 000000000..0de384da9 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zswap.F90 @@ -0,0 +1,49 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZSWAP_F95(X,Y) + ! Fortran77 call: + ! ZSWAP(N,X,INCX,Y,INCY) + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SWAP + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(INOUT ) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SWAP' + ! <<< Local scalars >>> + INTEGER :: INCX + INTEGER :: INCY + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + INCX = 1 + INCY = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_SWAP(N,X,INCX,Y,INCY) +END SUBROUTINE ZSWAP_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsymm.F90 b/src/modules/BLAS95/src/blas95_src/zsymm.F90 new file mode 100755 index 000000000..c9c85bb75 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zsymm.F90 @@ -0,0 +1,87 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + M = SIZE(C,1) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYMM(O_SIDE,O_UPLO,M,N,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE ZSYMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsyr2k.F90 b/src/modules/BLAS95/src/blas95_src/zsyr2k.F90 new file mode 100755 index 000000000..c1d41cefb --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zsyr2k.F90 @@ -0,0 +1,91 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYR2K + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=5), PARAMETER :: SRNAME = 'SYR2K' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDB + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYR2K(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,B,LDB,O_BETA,C,LDC) +END SUBROUTINE ZSYR2K_F95 diff --git a/src/modules/BLAS95/src/blas95_src/zsyrk.F90 b/src/modules/BLAS95/src/blas95_src/zsyrk.F90 new file mode 100755 index 000000000..3e1edf7b7 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/zsyrk.F90 @@ -0,0 +1,88 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_SYRK + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'SYRK' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + COMPLEX(WP) :: O_ALPHA + COMPLEX(WP) :: O_BETA + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + INTEGER :: LDC + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(BETA)) THEN + O_BETA = BETA + ELSE + O_BETA = 0 + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + IF((O_TRANS.EQ.'N'.OR.O_TRANS.EQ.'n')) THEN + K = SIZE(A,2) + ELSE + K = SIZE(A,1) + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDC = MAX(1,SIZE(C,1)) + N = SIZE(C,2) + ! <<< Call blas77 routine >>> + CALL F77_SYRK(O_UPLO,O_TRANS,N,K,O_ALPHA,A,LDA,O_BETA,C,LDC) +END SUBROUTINE ZSYRK_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztbmv.F90 b/src/modules/BLAS95/src/blas95_src/ztbmv.F90 new file mode 100755 index 000000000..3c68c3970 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztbmv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBMV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE ZTBMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztbsv.F90 b/src/modules/BLAS95/src/blas95_src/ztbsv.F90 new file mode 100755 index 000000000..829b65521 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztbsv.F90 @@ -0,0 +1,76 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TBSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TBSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: K + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + K = SIZE(A,1)-1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TBSV(O_UPLO,O_TRANS,O_DIAG,N,K,A,LDA,X,INCX) +END SUBROUTINE ZTBSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztpmv.F90 b/src/modules/BLAS95/src/blas95_src/ztpmv.F90 new file mode 100755 index 000000000..41d659a14 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztpmv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPMV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE ZTPMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztpsv.F90 b/src/modules/BLAS95/src/blas95_src/ztpsv.F90 new file mode 100755 index 000000000..8bb30bbc3 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztpsv.F90 @@ -0,0 +1,72 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TPSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TPSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + ! <<< Intrinsic functions >>> + INTRINSIC PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + N = SIZE(X) + ! <<< Call blas77 routine >>> + CALL F77_TPSV(O_UPLO,O_TRANS,O_DIAG,N,AP,X,INCX) +END SUBROUTINE ZTPSV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrmm.F90 b/src/modules/BLAS95/src/blas95_src/ztrmm.F90 new file mode 100755 index 000000000..2f5e8dfe1 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztrmm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + COMPLEX(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE ZTRMM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrmv.F90 b/src/modules/BLAS95/src/blas95_src/ztrmv.F90 new file mode 100755 index 000000000..1512c786d --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztrmv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRMV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRMV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRMV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE ZTRMV_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrsm.F90 b/src/modules/BLAS95/src/blas95_src/ztrsm.F90 new file mode 100755 index 000000000..d22fa141e --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztrsm.F90 @@ -0,0 +1,92 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSM' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_SIDE + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANSA + CHARACTER(LEN=1) :: O_DIAG + COMPLEX(WP) :: O_ALPHA + INTEGER :: M + INTEGER :: N + INTEGER :: LDA + INTEGER :: LDB + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(ALPHA)) THEN + O_ALPHA = ALPHA + ELSE + O_ALPHA = 1 + ENDIF + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(SIDE)) THEN + O_SIDE = SIDE + ELSE + O_SIDE = 'L' + ENDIF + IF(PRESENT(TRANSA)) THEN + O_TRANSA = TRANSA + ELSE + O_TRANSA = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + LDA = MAX(1,SIZE(A,1)) + LDB = MAX(1,SIZE(B,1)) + M = SIZE(B,1) + N = SIZE(B,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSM(O_SIDE,O_UPLO,O_TRANSA,O_DIAG,M,N,O_ALPHA,A,LDA,B,LDB) +END SUBROUTINE ZTRSM_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 b/src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 new file mode 100755 index 000000000..5990b07a3 --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztrsm_batch.F90 @@ -0,0 +1,191 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* + +PURE SUBROUTINE ZTRSM_BATCH_F95(A_ARRAY,B_ARRAY,M_ARRAY,N_ARRAY, & + & GROUP_SIZE,SIDE_ARRAY,UPLO_ARRAY, & + & TRANSA_ARRAY,DIAG_ARRAY,ALPHA_ARRAY) + ! Fortran77 call: + ! ZTRSM_BATCH(SIDE_ARRAY,UPLO_ARRAY,TRANSA_ARRAY,DIAG_ARRAY,M_ARRAY,N_ARRAY, + ! ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY, + ! GROUP_COUNT,GROUP_SIZE) + ! SIDE_ARRAY=Array where each element is one of 'L' or 'R'; default: 'L' + ! UPLO_ARRAY=Array where each element is one of 'U' or 'L'; default: 'U' + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! DIAG_ARRAY=Array where each element is one of 'U' or 'N'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: array where each element=1 + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSM_BATCH, F77_XERBLA + USE, INTRINSIC :: ISO_C_BINDING + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Array arguments >>> + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + ! SIDE_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: SIDE_ARRAY(:) + ! UPLO_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: UPLO_ARRAY(:) + ! TRANSA_ARRAY: INOUT intent instead of IN beca!USE PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: TRANSA_ARRAY(:) + ! DIAG_ARRAY + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL, TARGET :: DIAG_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN beca!USE PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL, TARGET :: ALPHA_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: B_ARRAY(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=11), PARAMETER :: SRNAME = 'ZTRSM_BATCH' + ! <<< Local scalars >>> + INTEGER :: L_STAT_ALLOC, L_STAT_DEALLOC + INTEGER :: GROUP_COUNT + INTEGER :: I + ! <<< Local arrays >>> + CHARACTER(LEN=1), POINTER :: O_SIDE_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_UPLO_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_TRANSA_ARRAY(:) + CHARACTER(LEN=1), POINTER :: O_DIAG_ARRAY(:) + COMPLEX(WP), POINTER :: O_ALPHA_ARRAY(:) + INTEGER, POINTER :: LDA_ARRAY(:) + INTEGER, POINTER :: LDB_ARRAY(:) + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init skipped scalars >>> + GROUP_COUNT = SIZE(GROUP_SIZE) + ! <<< Init allocate status >>> + L_STAT_ALLOC = 0 + ! <<< Init optional and skipped arrays >>> + IF(PRESENT(ALPHA_ARRAY)) THEN + O_ALPHA_ARRAY => ALPHA_ARRAY + ELSE + ALLOCATE(O_ALPHA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_ALPHA_ARRAY(I) = 1 + END DO + ENDIF + ENDIF + IF(PRESENT(SIDE_ARRAY)) THEN + O_SIDE_ARRAY => SIDE_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_SIDE_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_SIDE_ARRAY(I) = 'L' + END DO + ENDIF + ENDIF + IF(PRESENT(UPLO_ARRAY)) THEN + O_UPLO_ARRAY => UPLO_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_UPLO_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_UPLO_ARRAY(I) = 'U' + END DO + ENDIF + ENDIF + IF(PRESENT(TRANSA_ARRAY)) THEN + O_TRANSA_ARRAY => TRANSA_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_TRANSA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_TRANSA_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(PRESENT(DIAG_ARRAY)) THEN + O_DIAG_ARRAY => DIAG_ARRAY + ELSEIF(L_STAT_ALLOC==0) THEN + ALLOCATE(O_DIAG_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + O_DIAG_ARRAY(I) = 'N' + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDA_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + IF(O_SIDE_ARRAY(I).EQ.'L') THEN + LDA_ARRAY(I) = MAX(1,M_ARRAY(I)) + ELSE + LDA_ARRAY(I) = MAX(1,N_ARRAY(I)) + ENDIF + END DO + ENDIF + ENDIF + IF(L_STAT_ALLOC==0) THEN + ALLOCATE(LDB_ARRAY(GROUP_COUNT), STAT=L_STAT_ALLOC) + IF(L_STAT_ALLOC==0) THEN + DO I=1, GROUP_COUNT + LDB_ARRAY(I) = MAX(1,M_ARRAY(I)) + END DO + ENDIF + ENDIF + + ! <<< Call blas77 routine >>> + IF(L_STAT_ALLOC==0) THEN + CALL F77_TRSM_BATCH(O_SIDE_ARRAY,O_UPLO_ARRAY,O_TRANSA_ARRAY, & + & O_DIAG_ARRAY,M_ARRAY,N_ARRAY, & + & O_ALPHA_ARRAY,A_ARRAY, & + & LDA_ARRAY,B_ARRAY,LDB_ARRAY, & + & GROUP_COUNT,GROUP_SIZE) + ENDIF + ! <<< Deallocate local arrays >>> + IF(.NOT. PRESENT(ALPHA_ARRAY)) THEN + IF (ASSOCIATED(O_ALPHA_ARRAY)) THEN + DEALLOCATE(O_ALPHA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(SIDE_ARRAY)) THEN + IF (ASSOCIATED(O_SIDE_ARRAY)) THEN + DEALLOCATE(O_SIDE_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(UPLO_ARRAY)) THEN + IF (ASSOCIATED(O_UPLO_ARRAY)) THEN + DEALLOCATE(O_UPLO_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(TRANSA_ARRAY)) THEN + IF (ASSOCIATED(O_TRANSA_ARRAY)) THEN + DEALLOCATE(O_TRANSA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF(.NOT. PRESENT(DIAG_ARRAY)) THEN + IF (ASSOCIATED(O_DIAG_ARRAY)) THEN + DEALLOCATE(O_DIAG_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + ENDIF + IF (ASSOCIATED(LDA_ARRAY)) THEN + DEALLOCATE(LDA_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF (ASSOCIATED(LDB_ARRAY)) THEN + DEALLOCATE(LDB_ARRAY, STAT=L_STAT_DEALLOC) + ENDIF + IF(L_STAT_ALLOC .NE. 0) THEN + CALL F77_XERBLA(SRNAME,1000) + ENDIF +END SUBROUTINE ZTRSM_BATCH_F95 diff --git a/src/modules/BLAS95/src/blas95_src/ztrsv.F90 b/src/modules/BLAS95/src/blas95_src/ztrsv.F90 new file mode 100755 index 000000000..829bca3ce --- /dev/null +++ b/src/modules/BLAS95/src/blas95_src/ztrsv.F90 @@ -0,0 +1,74 @@ +!=============================================================================== +! Copyright 2005-2020 Intel Corporation. +! +! This software and the related documents are Intel copyrighted materials, and +! your !USE of them is governed by the express license under which they were +! provided to you (License). Unless the License provides otherwise, you may not +! !USE, modify, copy, publish, distribute, disclose or transmit this software or +! the related documents without Intel's prior written permission. +! +! This software and the related documents are provided as is, with no express +! or implied warranties, other than those that are expressly stated in the +! License. +!=============================================================================== + +! Content: +! F95 interface for BLAS routines +!******************************************************************************* +! This file was generated automatically! +!******************************************************************************* + +PURE SUBROUTINE ZTRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! <<< !USE statements >>> + !USE F77_BLAS, ONLY: F77_TRSV + ! <<< Implicit statement >>> + !IMPLICIT NONE + ! <<< Kind parameter >>> + INTEGER, PARAMETER :: WP = KIND(1.0D0) + ! <<< Scalar arguments >>> + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + ! <<< Array arguments >>> + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + ! <<< Local declarations >>> + ! <<< Parameters >>> + CHARACTER(LEN=4), PARAMETER :: SRNAME = 'TRSV' + ! <<< Local scalars >>> + CHARACTER(LEN=1) :: O_UPLO + CHARACTER(LEN=1) :: O_TRANS + CHARACTER(LEN=1) :: O_DIAG + INTEGER :: INCX + INTEGER :: N + INTEGER :: LDA + ! <<< Intrinsic functions >>> + INTRINSIC MAX, PRESENT, SIZE + ! <<< Executable statements >>> + ! <<< Init optional and skipped scalars >>> + IF(PRESENT(DIAG)) THEN + O_DIAG = DIAG + ELSE + O_DIAG = 'N' + ENDIF + IF(PRESENT(TRANS)) THEN + O_TRANS = TRANS + ELSE + O_TRANS = 'N' + ENDIF + IF(PRESENT(UPLO)) THEN + O_UPLO = UPLO + ELSE + O_UPLO = 'U' + ENDIF + INCX = 1 + LDA = MAX(1,SIZE(A,1)) + N = SIZE(A,2) + ! <<< Call blas77 routine >>> + CALL F77_TRSV(O_UPLO,O_TRANS,O_DIAG,N,A,LDA,X,INCX) +END SUBROUTINE ZTRSV_F95 diff --git a/src/modules/BLAS95/src/easifem_blas_interface.inc b/src/modules/BLAS95/src/easifem_blas_interface.inc new file mode 100644 index 000000000..0adb9c51b --- /dev/null +++ b/src/modules/BLAS95/src/easifem_blas_interface.inc @@ -0,0 +1,1870 @@ +INTERFACE GBMV + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SGBMV_F95 + PURE SUBROUTINE DGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DGBMV_F95 + PURE SUBROUTINE CGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CGBMV_F95 + PURE SUBROUTINE ZGBMV_F95(A,X,Y,KL,M,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + INTEGER, INTENT(IN), OPTIONAL :: KL + INTEGER, INTENT(IN), OPTIONAL :: M + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZGBMV_F95 +END INTERFACE GBMV + +INTERFACE GEMV + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SGEMV_F95 + PURE SUBROUTINE DGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DGEMV_F95 + PURE SUBROUTINE CGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CGEMV_F95 + PURE SUBROUTINE ZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZGEMV_F95 + PURE SUBROUTINE SCGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! SCGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SCGEMV_F95 + PURE SUBROUTINE DZGEMV_F95(A,X,Y,ALPHA,BETA,TRANS) + ! Fortran77 call: + ! DZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DZGEMV_F95 +END INTERFACE GEMV + +INTERFACE GER + ! Default ALPHA=1 + PURE SUBROUTINE SGER_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE SGER_F95 + PURE SUBROUTINE DGER_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE DGER_F95 +END INTERFACE GER + +INTERFACE GERC + ! Default ALPHA=1 + PURE SUBROUTINE CGERC_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE CGERC_F95 + PURE SUBROUTINE ZGERC_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE ZGERC_F95 +END INTERFACE GERC + +INTERFACE GERU + ! Default ALPHA=1 + PURE SUBROUTINE CGERU_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE CGERU_F95 + PURE SUBROUTINE ZGERU_F95(A,X,Y,ALPHA) + ! Fortran77 call: + ! ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE ZGERU_F95 +END INTERFACE GERU + +INTERFACE HBMV + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE CHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CHBMV_F95 + PURE SUBROUTINE ZHBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZHBMV_F95 +END INTERFACE HBMV + +INTERFACE HEMV + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE CHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CHEMV_F95 + PURE SUBROUTINE ZHEMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZHEMV_F95 +END INTERFACE HEMV + +INTERFACE HER + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE CHER_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! CHER(UPLO,N,ALPHA,X,INCX,A,LDA) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + END SUBROUTINE CHER_F95 + PURE SUBROUTINE ZHER_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + END SUBROUTINE ZHER_F95 +END INTERFACE HER + +INTERFACE HER2 + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE CHER2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE CHER2_F95 + PURE SUBROUTINE ZHER2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE ZHER2_F95 +END INTERFACE HER2 + +INTERFACE HPMV + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE CHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CHPMV_F95 + PURE SUBROUTINE ZHPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZHPMV_F95 +END INTERFACE HPMV + +INTERFACE HPR + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE CHPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! CHPR(UPLO,N,ALPHA,X,INCX,AP) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + END SUBROUTINE CHPR_F95 + PURE SUBROUTINE ZHPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! ZHPR(UPLO,N,ALPHA,X,INCX,AP) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + END SUBROUTINE ZHPR_F95 +END INTERFACE HPR + +INTERFACE HPR2 + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE CHPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE CHPR2_F95 + PURE SUBROUTINE ZHPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(INOUT ) :: AP(:) + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE ZHPR2_F95 +END INTERFACE HPR2 + +INTERFACE SBMV + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SSBMV_F95 + PURE SUBROUTINE DSBMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DSBMV_F95 +END INTERFACE SBMV + +INTERFACE SPMV + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SSPMV_F95 + PURE SUBROUTINE DSPMV_F95(AP,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DSPMV_F95 +END INTERFACE SPMV + +INTERFACE SPR + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE SSPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! SSPR(UPLO,N,ALPHA,X,INCX,AP) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + END SUBROUTINE SSPR_F95 + PURE SUBROUTINE DSPR_F95(AP,X,UPLO,ALPHA) + ! Fortran77 call: + ! DSPR(UPLO,N,ALPHA,X,INCX,AP) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + END SUBROUTINE DSPR_F95 +END INTERFACE SPR + +INTERFACE SPR2 + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE SSPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE SSPR2_F95 + PURE SUBROUTINE DSPR2_F95(AP,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: AP(:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE DSPR2_F95 +END INTERFACE SPR2 + +INTERFACE SYMV + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SSYMV_F95 + PURE SUBROUTINE DSYMV_F95(A,X,Y,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DSYMV_F95 +END INTERFACE SYMV + +INTERFACE SYR + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE SSYR_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + END SUBROUTINE SSYR_F95 + PURE SUBROUTINE DSYR_F95(A,X,UPLO,ALPHA) + ! Fortran77 call: + ! DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + END SUBROUTINE DSYR_F95 +END INTERFACE SYR + +INTERFACE SYR2 + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + PURE SUBROUTINE SSYR2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE SSYR2_F95 + PURE SUBROUTINE DSYR2_F95(A,X,Y,UPLO,ALPHA) + ! Fortran77 call: + ! DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(INOUT ) :: A(:,:) + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE DSYR2_F95 +END INTERFACE SYR2 + +INTERFACE TBMV + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + PURE SUBROUTINE STBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE STBMV_F95 + PURE SUBROUTINE DTBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE DTBMV_F95 + PURE SUBROUTINE CTBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE CTBMV_F95 + PURE SUBROUTINE ZTBMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE ZTBMV_F95 +END INTERFACE TBMV + +INTERFACE TBSV + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + PURE SUBROUTINE STBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE STBSV_F95 + PURE SUBROUTINE DTBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE DTBSV_F95 + PURE SUBROUTINE CTBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE CTBSV_F95 + PURE SUBROUTINE ZTBSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE ZTBSV_F95 +END INTERFACE TBSV + +INTERFACE TPMV + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + PURE SUBROUTINE STPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE STPMV_F95 + PURE SUBROUTINE DTPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE DTPMV_F95 + PURE SUBROUTINE CTPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE CTPMV_F95 + PURE SUBROUTINE ZTPMV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE ZTPMV_F95 +END INTERFACE TPMV + +INTERFACE TPSV + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + PURE SUBROUTINE STPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE STPSV_F95 + PURE SUBROUTINE DTPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: AP(:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE DTPSV_F95 + PURE SUBROUTINE CTPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE CTPSV_F95 + PURE SUBROUTINE ZTPSV_F95(AP,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: AP(:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE ZTPSV_F95 +END INTERFACE TPSV + +INTERFACE TRMV + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + PURE SUBROUTINE STRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE STRMV_F95 + PURE SUBROUTINE DTRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE DTRMV_F95 + PURE SUBROUTINE CTRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE CTRMV_F95 + PURE SUBROUTINE ZTRMV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE ZTRMV_F95 +END INTERFACE TRMV + +INTERFACE TRSV + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + PURE SUBROUTINE STRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE STRSV_F95 + PURE SUBROUTINE DTRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE DTRSV_F95 + PURE SUBROUTINE CTRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE CTRSV_F95 + PURE SUBROUTINE ZTRSV_F95(A,X,UPLO,TRANS,DIAG) + ! Fortran77 call: + ! ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: X(:) + END SUBROUTINE ZTRSV_F95 +END INTERFACE TRSV + +INTERFACE GEMM + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE SGEMM_F95 + PURE SUBROUTINE DGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE DGEMM_F95 + PURE SUBROUTINE CGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CGEMM_F95 + PURE SUBROUTINE ZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZGEMM_F95 + PURE SUBROUTINE SCGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! SCGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE SCGEMM_F95 + PURE SUBROUTINE DZGEMM_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! DZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE DZGEMM_F95 +END INTERFACE GEMM + +INTERFACE HEMM + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE CHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CHEMM_F95 + PURE SUBROUTINE ZHEMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZHEMM_F95 +END INTERFACE HEMM + +INTERFACE HERK + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE CHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CHERK_F95 + PURE SUBROUTINE ZHERK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZHERK_F95 +END INTERFACE HERK + +INTERFACE HER2K + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE CHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CHER2K_F95 + PURE SUBROUTINE ZHER2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZHER2K_F95 +END INTERFACE HER2K + +INTERFACE SYMM + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE SSYMM_F95 + PURE SUBROUTINE DSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE DSYMM_F95 + PURE SUBROUTINE CSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CSYMM_F95 + PURE SUBROUTINE ZSYMM_F95(A,B,C,SIDE,UPLO,ALPHA,BETA) + ! Fortran77 call: + ! ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZSYMM_F95 +END INTERFACE SYMM + +INTERFACE SYRK + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE SSYRK_F95 + PURE SUBROUTINE DSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE DSYRK_F95 + PURE SUBROUTINE CSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CSYRK_F95 + PURE SUBROUTINE ZSYRK_F95(A,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZSYRK_F95 +END INTERFACE SYRK + +INTERFACE SYR2K + ! UPLO='U','L'; default: 'U' + ! TRANS='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE SSYR2K_F95 + PURE SUBROUTINE DSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE DSYR2K_F95 + PURE SUBROUTINE CSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CSYR2K_F95 + PURE SUBROUTINE ZSYR2K_F95(A,B,C,UPLO,TRANS,ALPHA,BETA) + ! Fortran77 call: + ! ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZSYR2K_F95 +END INTERFACE SYR2K + +INTERFACE TRMM + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + PURE SUBROUTINE STRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE STRMM_F95 + PURE SUBROUTINE DTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE DTRMM_F95 + PURE SUBROUTINE CTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE CTRMM_F95 + PURE SUBROUTINE ZTRMM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE ZTRMM_F95 +END INTERFACE TRMM + +INTERFACE TRSM + ! SIDE='L','R'; default: 'L' + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! DIAG='N','U'; default: 'N' + ! Default ALPHA=1 + PURE SUBROUTINE STRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE STRSM_F95 + PURE SUBROUTINE DTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE DTRSM_F95 + PURE SUBROUTINE CTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE CTRSM_F95 + PURE SUBROUTINE ZTRSM_F95(A,B,SIDE,UPLO,TRANSA,DIAG,ALPHA) + ! Fortran77 call: + ! ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: SIDE + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: DIAG + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(INOUT ) :: B(:,:) + END SUBROUTINE ZTRSM_F95 +END INTERFACE TRSM + +INTERFACE GEMMT + ! UPLO='U','L'; default: 'U' + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE SGEMMT_F95 + PURE SUBROUTINE DGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: B(:,:) + REAL(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE DGEMMT_F95 + PURE SUBROUTINE CGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CGEMMT_F95 + PURE SUBROUTINE ZGEMMT_F95(A,B,C,UPLO,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZGEMMT_F95 +END INTERFACE GEMMT + +INTERFACE AXPYI + ! Default A=1 + PURE SUBROUTINE SAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! SAXPYI(NZ,A,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(IN), OPTIONAL :: A + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SAXPYI_F95 + PURE SUBROUTINE DAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! DAXPYI(NZ,A,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(IN), OPTIONAL :: A + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DAXPYI_F95 + PURE SUBROUTINE CAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! CAXPYI(NZ,A,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN), OPTIONAL :: A + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CAXPYI_F95 + PURE SUBROUTINE ZAXPYI_F95(X,INDX,Y,A) + ! Fortran77 call: + ! ZAXPYI(NZ,A,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN), OPTIONAL :: A + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZAXPYI_F95 +END INTERFACE AXPYI + +INTERFACE DOTI + PURE FUNCTION SDOTI_F95(X,INDX,Y) + ! Fortran77 call: + ! SDOTI(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP) :: SDOTI_F95 + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + END FUNCTION SDOTI_F95 + PURE FUNCTION DDOTI_F95(X,INDX,Y) + ! Fortran77 call: + ! DDOTI(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP) :: DDOTI_F95 + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + END FUNCTION DDOTI_F95 +END INTERFACE DOTI + +INTERFACE DOTCI + PURE FUNCTION CDOTCI_F95(X,INDX,Y) + ! Fortran77 call: + ! CDOTCI(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP) :: CDOTCI_F95 + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END FUNCTION CDOTCI_F95 + PURE FUNCTION ZDOTCI_F95(X,INDX,Y) + ! Fortran77 call: + ! ZDOTCI(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP) :: ZDOTCI_F95 + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END FUNCTION ZDOTCI_F95 +END INTERFACE DOTCI + +INTERFACE DOTUI + PURE FUNCTION CDOTUI_F95(X,INDX,Y) + ! Fortran77 call: + ! CDOTUI(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP) :: CDOTUI_F95 + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END FUNCTION CDOTUI_F95 + PURE FUNCTION ZDOTUI_F95(X,INDX,Y) + ! Fortran77 call: + ! ZDOTUI(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP) :: ZDOTUI_F95 + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END FUNCTION ZDOTUI_F95 +END INTERFACE DOTUI + +INTERFACE GTHR + PURE SUBROUTINE SGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! SGTHR(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE SGTHR_F95 + PURE SUBROUTINE DGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! DGTHR(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE DGTHR_F95 + PURE SUBROUTINE CGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! CGTHR(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE CGTHR_F95 + PURE SUBROUTINE ZGTHR_F95(X,INDX,Y) + ! Fortran77 call: + ! ZGTHR(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(IN) :: Y(:) + END SUBROUTINE ZGTHR_F95 +END INTERFACE GTHR + +INTERFACE GTHRZ + PURE SUBROUTINE SGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! SGTHRZ(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SGTHRZ_F95 + PURE SUBROUTINE DGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! DGTHRZ(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DGTHRZ_F95 + PURE SUBROUTINE CGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! CGTHRZ(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CGTHRZ_F95 + PURE SUBROUTINE ZGTHRZ_F95(X,INDX,Y) + ! Fortran77 call: + ! ZGTHRZ(NZ,Y,X,INDX) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(OUT) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZGTHRZ_F95 +END INTERFACE GTHRZ + +INTERFACE ROTI + ! Default C=1 + ! Default S=1 + PURE SUBROUTINE SROTI_F95(X,INDX,Y,C,S) + ! Fortran77 call: + ! SROTI(NZ,X,INDX,Y,C,S) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + REAL(WP), INTENT(INOUT ) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE SROTI_F95 + PURE SUBROUTINE DROTI_F95(X,INDX,Y,C,S) + ! Fortran77 call: + ! DROTI(NZ,X,INDX,Y,C,S) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(IN) :: C + REAL(WP), INTENT(IN) :: S + REAL(WP), INTENT(INOUT ) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(IN) :: Y(:) + END SUBROUTINE DROTI_F95 +END INTERFACE ROTI + +INTERFACE SCTR + PURE SUBROUTINE SSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! SSCTR(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(OUT) :: Y(:) + END SUBROUTINE SSCTR_F95 + PURE SUBROUTINE DSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! DSCTR(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + REAL(WP), INTENT(OUT) :: Y(:) + END SUBROUTINE DSCTR_F95 + PURE SUBROUTINE CSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! CSCTR(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(OUT) :: Y(:) + END SUBROUTINE CSCTR_F95 + PURE SUBROUTINE ZSCTR_F95(X,INDX,Y) + ! Fortran77 call: + ! ZSCTR(NZ,X,INDX,Y) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN) :: X(:) + INTEGER, INTENT(IN) :: INDX(:) + COMPLEX(WP), INTENT(OUT) :: Y(:) + END SUBROUTINE ZSCTR_F95 +END INTERFACE SCTR + +INTERFACE GEMM3M + ! TRANSA='N','C','T'; default: 'N' + ! TRANSB='N','C','T'; default: 'N' + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE CGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! CGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => SP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE CGEMM3M_F95 + PURE SUBROUTINE ZGEMM3M_F95(A,B,C,TRANSA,TRANSB,ALPHA,BETA) + ! Fortran77 call: + ! ZGEMM3M(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + USE F95_PRECISION, ONLY: WP => DP + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSA + CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANSB + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: B(:,:) + COMPLEX(WP), INTENT(INOUT ) :: C(:,:) + END SUBROUTINE ZGEMM3M_F95 +END INTERFACE GEMM3M + +INTERFACE AXPBY + ! Default ALPHA=1 + ! Default BETA=1 + PURE SUBROUTINE SAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! SAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE SAXPBY_F95 + PURE SUBROUTINE DAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! DAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: X(:) + REAL(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE DAXPBY_F95 + PURE SUBROUTINE CAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! CAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE CAXPBY_F95 + PURE SUBROUTINE ZAXPBY_F95(X,Y,ALPHA,BETA) + ! Fortran77 call: + ! ZAXPBY(N,ALPHA,X,INCX,BETA,Y,INCY) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: X(:) + COMPLEX(WP), INTENT(INOUT ) :: Y(:) + END SUBROUTINE ZAXPBY_F95 +END INTERFACE AXPBY + +INTERFACE GEM2V + ! Default ALPHA=1 + ! Default BETA=0 + PURE SUBROUTINE SGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! SGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, + ! INCY2) + USE F95_PRECISION, ONLY: WP => SP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X1(:) + REAL(WP), INTENT(IN) :: X2(:) + REAL(WP), INTENT(INOUT ) :: Y1(:) + REAL(WP), INTENT(INOUT ) :: Y2(:) + END SUBROUTINE SGEM2VU_F95 + PURE SUBROUTINE DGEM2VU_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! DGEM2VU(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, + ! INCY2) + USE F95_PRECISION, ONLY: WP => DP + REAL(WP), INTENT(IN), OPTIONAL :: ALPHA + REAL(WP), INTENT(IN), OPTIONAL :: BETA + REAL(WP), INTENT(IN) :: A(:,:) + REAL(WP), INTENT(IN) :: X1(:) + REAL(WP), INTENT(IN) :: X2(:) + REAL(WP), INTENT(INOUT ) :: Y1(:) + REAL(WP), INTENT(INOUT ) :: Y2(:) + END SUBROUTINE DGEM2VU_F95 + PURE SUBROUTINE CGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! CGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, + ! INCY2) + USE F95_PRECISION, ONLY: WP => SP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X1(:) + COMPLEX(WP), INTENT(IN) :: X2(:) + COMPLEX(WP), INTENT(INOUT ) :: Y1(:) + COMPLEX(WP), INTENT(INOUT ) :: Y2(:) + END SUBROUTINE CGEM2VC_F95 + PURE SUBROUTINE ZGEM2VC_F95(A,X1,X2,Y1,Y2,ALPHA,BETA) + ! Fortran77 call: + ! ZGEM2VC(M,N,ALPHA,A,LDA,X1,INCX1,X2,INCX2,BETA,Y1,INCY1,Y2, + ! INCY2) + USE F95_PRECISION, ONLY: WP => DP + COMPLEX(WP), INTENT(IN), OPTIONAL :: ALPHA + COMPLEX(WP), INTENT(IN), OPTIONAL :: BETA + COMPLEX(WP), INTENT(IN) :: A(:,:) + COMPLEX(WP), INTENT(IN) :: X1(:) + COMPLEX(WP), INTENT(IN) :: X2(:) + COMPLEX(WP), INTENT(INOUT ) :: Y1(:) + COMPLEX(WP), INTENT(INOUT ) :: Y2(:) + END SUBROUTINE ZGEM2VC_F95 +END INTERFACE GEM2V + +INTERFACE SGEMM_BATCH + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: 1 + ! BETA_ARRAY=Array of beta values; default: 0 + PURE SUBROUTINE SGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & + GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! SGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + USE F95_PRECISION, ONLY: WP => SP + USE, INTRINSIC :: ISO_C_BINDING + ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN because PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) + END SUBROUTINE SGEMM_BATCH_F95 +END INTERFACE SGEMM_BATCH + +INTERFACE DGEMM_BATCH + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: 1 + ! BETA_ARRAY=Array of beta values; default: 0 + PURE SUBROUTINE DGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & + GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! DGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + USE F95_PRECISION, ONLY: WP => DP + USE, INTRINSIC :: ISO_C_BINDING + ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN because PURE. + REAL(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) + END SUBROUTINE DGEMM_BATCH_F95 +END INTERFACE DGEMM_BATCH + +INTERFACE CGEMM_BATCH + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: 1 + ! BETA_ARRAY=Array of beta values; default: 0 + PURE SUBROUTINE CGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & + GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! CGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + USE F95_PRECISION, ONLY: WP => SP + USE, INTRINSIC :: ISO_C_BINDING + ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) + END SUBROUTINE CGEMM_BATCH_F95 +END INTERFACE CGEMM_BATCH + +INTERFACE ZGEMM_BATCH + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: 1 + ! BETA_ARRAY=Array of beta values; default: 0 + PURE SUBROUTINE ZGEMM_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & + GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! ZGEMM_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + USE F95_PRECISION, ONLY: WP => DP + USE, INTRINSIC :: ISO_C_BINDING + ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) + END SUBROUTINE ZGEMM_BATCH_F95 +END INTERFACE ZGEMM_BATCH + +INTERFACE CGEMM3M_BATCH + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: 1 + ! BETA_ARRAY=Array of beta values; default: 0 + PURE SUBROUTINE CGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & + GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! CGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + USE F95_PRECISION, ONLY: WP => SP + USE, INTRINSIC :: ISO_C_BINDING + ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) + END SUBROUTINE CGEMM3M_BATCH_F95 +END INTERFACE CGEMM3M_BATCH + +INTERFACE ZGEMM3M_BATCH + ! TRANSA_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! TRANSB_ARRAY=Array where each element is one of 'N','C','T'; default: 'N' + ! ALPHA_ARRAY=Array of alpha values; default: 1 + ! BETA_ARRAY=Array of beta values; default: 0 + PURE SUBROUTINE ZGEMM3M_BATCH_F95(A_ARRAY,B_ARRAY,C_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY, & + GROUP_SIZE,TRANSA_ARRAY,TRANSB_ARRAY,ALPHA_ARRAY,BETA_ARRAY) + ! Fortran77 call: + ! ZGEMM3M_BATCH(TRANSA_ARRAY,TRANSB_ARRAY,M_ARRAY,N_ARRAY,K_ARRAY,ALPHA_ARRAY,A_ARRAY,LDA_ARRAY,B_ARRAY,LDB_ARRAY,BETA_ARRAY,C_ARRAY,LDC_ARRAY,GROUP_COUNT,GROUP_SIZE) + USE F95_PRECISION, ONLY: WP => DP + USE, INTRINSIC :: ISO_C_BINDING + ! TRANSA_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSA_ARRAY(:) + ! TRANSB_ARRAY: INOUT intent instead of IN because PURE. + CHARACTER(LEN=1), INTENT(INOUT ), OPTIONAL :: TRANSB_ARRAY(:) + ! ALPHA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: ALPHA_ARRAY(:) + ! BETA_ARRAY: INOUT intent instead of IN because PURE. + COMPLEX(WP), INTENT(INOUT ), OPTIONAL :: BETA_ARRAY(:) + INTEGER, INTENT(IN) :: M_ARRAY(:) + INTEGER, INTENT(IN) :: N_ARRAY(:) + INTEGER, INTENT(IN) :: K_ARRAY(:) + INTEGER, INTENT(IN) :: GROUP_SIZE(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: A_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(IN) :: B_ARRAY(:) + INTEGER(KIND=C_INTPTR_T), INTENT(INOUT ) :: C_ARRAY(:) + END SUBROUTINE ZGEMM3M_BATCH_F95 +END INTERFACE ZGEMM3M_BATCH \ No newline at end of file diff --git a/src/modules/BaseContinuity/CMakeLists.txt b/src/modules/BaseContinuity/CMakeLists.txt new file mode 100644 index 000000000..1ce46813f --- /dev/null +++ b/src/modules/BaseContinuity/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}/BaseContinuity_Method.F90 +) + diff --git a/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 b/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 new file mode 100644 index 000000000..703f34c6c --- /dev/null +++ b/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 @@ -0,0 +1,177 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! + +MODULE BaseContinuity_Method +USE ErrorHandling, ONLY: Errormsg +USE GlobalData +USE String_Class, ONLY: String +USE BaseType +USE Utility, ONLY: UpperCase +IMPLICIT NONE +PRIVATE +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: BaseContinuity_ToString +PUBLIC :: BaseContinuity_FromString +PUBLIC :: BaseContinuityPointer_FromString + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE BaseContinuity_Copy +END INTERFACE + +CONTAINS + +!---------------------------------------------------------------------------- +! BaseContinuityPointer_FromString +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 30 Aug 2021 +! summary: This routine returns a pointer to a child of BaseContinuity_ + +FUNCTION BaseContinuityPointer_FromString(name) RESULT(ans) + CHARACTER(*), INTENT(IN) :: name + CLASS(BaseContinuity_), POINTER :: ans + !! + TYPE(String) :: astr + astr = TRIM(UpperCase(name)) + + SELECT CASE (astr%chars()) + CASE ("H1") + ALLOCATE (H1_ :: ans) + CASE ("HDIV") + ALLOCATE (HDiv_ :: ans) + CASE ("HCURL") + ALLOCATE (HCurl_ :: ans) + CASE ("DG") + ALLOCATE (DG_ :: ans) + CASE DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for given name="//astr, & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseContinuityPointer_FromString()", & + & file=__FILE__ & + & ) + END SELECT +END FUNCTION BaseContinuityPointer_FromString + +!---------------------------------------------------------------------------- +! BaseContinuity_Copy +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Copy BaseContinuity + +SUBROUTINE BaseContinuity_Copy(obj1, obj2) + CLASS(BaseContinuity_), ALLOCATABLE, INTENT(INOUT) :: obj1 + CLASS(BaseContinuity_), INTENT(IN) :: obj2 + + IF (ALLOCATED(obj1)) THEN + DEALLOCATE (obj1) + END IF + + SELECT TYPE (obj2) + CLASS IS (H1_) + ALLOCATE (H1_ :: obj1) + CLASS IS (HDiv_) + ALLOCATE (HDiv_ :: obj1) + CLASS IS (HCurl_) + ALLOCATE (HCurl_ :: obj1) + CLASS IS (DG_) + ALLOCATE (DG_ :: obj1) + CLASS DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for type of obj2", & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseContinuity_Copy()", & + & file=__FILE__ & + & ) + + END SELECT +END SUBROUTINE BaseContinuity_Copy + +!---------------------------------------------------------------------------- +! BaseContinuity_toString +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +FUNCTION BaseContinuity_ToString(obj) RESULT(ans) + CLASS(BaseContinuity_), INTENT(IN) :: obj + TYPE(String) :: ans + SELECT TYPE (obj) + CLASS IS (H1_) + ans = "H1" + CLASS IS (HCurl_) + ans = "HCurl" + CLASS IS (HDiv_) + ans = "HDiv" + CLASS IS (DG_) + ans = "DG" + CLASS DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for type of obj", & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseContinuity_toString()", & + & file=__FILE__ & + & ) + END SELECT +END FUNCTION BaseContinuity_ToString + +!---------------------------------------------------------------------------- +! BaseContinuity_fromString +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +SUBROUTINE BaseContinuity_FromString(obj, name) + CLASS(BaseContinuity_), ALLOCATABLE, INTENT(OUT) :: obj + CHARACTER(*), INTENT(IN) :: name + TYPE(String) :: ans + + ans = UpperCase(name) + IF (ALLOCATED(obj)) DEALLOCATE (obj) + + SELECT CASE (ans%chars()) + CASE ("H1") + ALLOCATE (H1_ :: obj) + CASE ("HDIV") + ALLOCATE (HDiv_ :: obj) + CASE ("HCURL") + ALLOCATE (HCurl_ :: obj) + CASE ("DG") + ALLOCATE (DG_ :: obj) + CASE DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for given name="//TRIM(name), & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseContinuity_fromString()", & + & file=__FILE__ & + & ) + END SELECT +END SUBROUTINE BaseContinuity_FromString + +END MODULE BaseContinuity_Method diff --git a/src/modules/BaseInterpolation/CMakeLists.txt b/src/modules/BaseInterpolation/CMakeLists.txt new file mode 100644 index 000000000..0ed6e3a25 --- /dev/null +++ b/src/modules/BaseInterpolation/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}/BaseInterpolation_Method.F90 +) diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 new file mode 100644 index 000000000..cf3eb88a5 --- /dev/null +++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 @@ -0,0 +1,449 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! + +MODULE BaseInterpolation_Method +USE ErrorHandling, ONLY: Errormsg +USE GlobalData +USE String_Class, ONLY: String +USE BaseType +USE Utility, ONLY: UpperCase +USE Display_Method, ONLY: Tostring +IMPLICIT NONE +PRIVATE +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: BaseInterpolation_ToInteger +PUBLIC :: BaseInterpolation_FromInteger +PUBLIC :: BaseInterpolation_ToString +PUBLIC :: BaseInterpolation_FromString +PUBLIC :: BaseInterpolationPointer_FromString + +INTERFACE BaseInterpolation_ToInteger + MODULE PROCEDURE BaseInterpolation_ToInteger1 + MODULE PROCEDURE BaseInterpolation_ToInteger2 +END INTERFACE BaseInterpolation_ToInteger + +INTERFACE BaseInterpolation_ToString + MODULE PROCEDURE BaseInterpolation_ToString1 + MODULE PROCEDURE BaseInterpolation_ToString2 +END INTERFACE BaseInterpolation_ToString + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE BaseInterpolation_Copy +END INTERFACE + +CONTAINS + +!---------------------------------------------------------------------------- +! BaseInterpolationPointer_FromString +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-18 +! summary: This routine returns a pointer to a child of BaseInterpolation_ + +FUNCTION BaseInterpolationPointer_FromString(name) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: name + CLASS(BaseInterpolation_), POINTER :: ans + !! + TYPE(String) :: astr + astr = TRIM(UpperCase(name)) + + SELECT CASE (astr%chars()) + CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") + ALLOCATE (LagrangeInterpolation_ :: ans) + CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") + ALLOCATE (SerendipityInterpolation_ :: ans) + CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") + ALLOCATE (HermitInterpolation_ :: ans) + CASE ( & + & "HIERARCHICALPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHICALPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION") + ALLOCATE (HierarchyInterpolation_ :: ans) + CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") + ALLOCATE (OrthogonalInterpolation_ :: ans) + CASE DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for type of name="//astr, & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseInterpolationPointer_FromString()", & + & file=__FILE__ & + & ) + END SELECT +END FUNCTION BaseInterpolationPointer_FromString + +!---------------------------------------------------------------------------- +! BaseInterpolation_Copy +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Copy BaseInterpolation + +SUBROUTINE BaseInterpolation_Copy(obj1, obj2) + CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(INOUT) :: obj1 + CLASS(BaseInterpolation_), INTENT(IN) :: obj2 + + IF (ALLOCATED(obj1)) THEN + DEALLOCATE (obj1) + END IF + + SELECT TYPE (obj2) + CLASS IS (LagrangeInterpolation_) + ALLOCATE (LagrangeInterpolation_ :: obj1) + CLASS IS (SerendipityInterpolation_) + ALLOCATE (SerendipityInterpolation_ :: obj1) + CLASS IS (HermitInterpolation_) + ALLOCATE (HermitInterpolation_ :: obj1) + CLASS IS (HierarchyInterpolation_) + ALLOCATE (HierarchyInterpolation_ :: obj1) + CLASS IS (OrthogonalInterpolation_) + ALLOCATE (OrthogonalInterpolation_ :: obj1) + CLASS DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for type of obj2", & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseInterpolation_Copy()", & + & file=__FILE__ & + & ) + + END SELECT +END SUBROUTINE BaseInterpolation_Copy + +!---------------------------------------------------------------------------- +! BaseInterpolation_toString +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +FUNCTION BaseInterpolation_ToString1(obj) RESULT(ans) + CLASS(BaseInterpolation_), INTENT(IN) :: obj + TYPE(String) :: ans + SELECT TYPE (obj) + CLASS IS (LagrangeInterpolation_) + ans = "LagrangeInterpolation" + CLASS IS (SerendipityInterpolation_) + ans = "SerendipityInterpolation" + CLASS IS (HermitInterpolation_) + ans = "HermitInterpolation" + CLASS IS (HierarchyInterpolation_) + ans = "HierarchyInterpolation" + CLASS IS (OrthogonalInterpolation_) + ans = "OrthogonalInterpolation" + CLASS DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for type of obj2", & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseInterpolation_tostring()", & + & file=__FILE__ & + & ) + END SELECT +END FUNCTION BaseInterpolation_ToString1 + +!---------------------------------------------------------------------------- +! BaseInterpolation_toInteger +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) + CLASS(BaseInterpolation_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + SELECT TYPE (obj) + CLASS IS (LagrangeInterpolation_) + ans = LagrangePolynomial + CLASS IS (SerendipityInterpolation_) + ans = SerendipityPolynomial + CLASS IS (HermitInterpolation_) + ans = HermitPolynomial + CLASS IS (HierarchyInterpolation_) + ans = HeirarchicalPolynomial + CLASS IS (OrthogonalInterpolation_) + ans = OrthogonalPolynomial + CLASS DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for type of obj2", & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseInterpolation_toInteger()", & + & file=__FILE__ & + & ) + END SELECT +END FUNCTION BaseInterpolation_ToInteger1 + +!---------------------------------------------------------------------------- +! BaseInterpolation_toInteger +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) + CHARACTER(*), INTENT(IN) :: name + INTEGER(I4B) :: ans + + SELECT CASE (TRIM(UpperCase(name))) + CASE ("EQUIDISTANCE") + ans = Equidistance + + CASE ("GAUSSLEGENDRE") + ans = GaussLegendre + + CASE ("GAUSSLEGENDRELOBATTO") + ans = GaussLegendreLobatto + + CASE ("GAUSSLEGENDRERADAU") + ans = GaussLegendreRadau + + CASE ("GAUSSLEGENDRERADAULEFT") + ans = GaussLegendreRadauLeft + + CASE ("GAUSSLEGENDRERADAURIGHT") + ans = GaussLegendreRadauRight + + CASE ("GAUSSCHEBYSHEV") + ans = GaussChebyshev + + CASE ("GAUSSCHEBYSHEVLOBATTO") + ans = GaussChebyshevLobatto + + CASE ("GAUSSCHEBYSHEVRADAU") + ans = GaussChebyshevRadau + + CASE ("GAUSSCHEBYSHEVRADAULEFT") + ans = GaussChebyshevRadauLeft + + CASE ("GAUSSCHEBYSHEVRADAURIGHT") + ans = GaussChebyshevRadauRight + + CASE ("GAUSSJACOBI") + ans = GaussJacobi + + CASE ("GAUSSJACOBILOBATTO") + ans = GaussJacobiLobatto + + CASE ("GAUSSJACOBIRADAU") + ans = GaussJacobiRadau + + CASE ("GAUSSJACOBIRADAULEFT") + ans = GaussJacobiRadauLeft + + CASE ("GAUSSJACOBIRADAURIGHT") + ans = GaussJacobiRadauRight + + CASE ("GAUSSULTRASPHERICAL") + ans = GaussUltraspherical + + CASE ("GAUSSULTRASPHERICALLOBATTO") + ans = GaussUltrasphericalLobatto + + CASE ("GAUSSULTRASPHERICALRADAU") + ans = GaussUltrasphericalRadau + + CASE ("GAUSSULTRASPHERICALRADAULEFT") + ans = GaussUltrasphericalRadauLeft + + CASE ("GAUSSULTRASPHERICALRADAURIGHT") + ans = GaussUltrasphericalRadauRight + + CASE DEFAULT + ans = -1_I4B + CALL Errormsg(& + & msg="No case found for given baseInterpolation name", & + & file=__FILE__, & + & line=__LINE__,& + & routine="BaseInterpolation_ToInteger2()", & + & unitno=stderr) + RETURN + END SELECT +END FUNCTION BaseInterpolation_ToInteger2 + +!---------------------------------------------------------------------------- +! BaseInterpolation_fromString +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +SUBROUTINE BaseInterpolation_FromString(obj, name) + CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj + CHARACTER(*), INTENT(IN) :: name + TYPE(String) :: ans + + ans = UpperCase(name) + IF (ALLOCATED(obj)) DEALLOCATE (obj) + + SELECT CASE (ans%chars()) + CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") + ALLOCATE (LagrangeInterpolation_ :: obj) + CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") + ALLOCATE (SerendipityInterpolation_ :: obj) + CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") + ALLOCATE (HermitInterpolation_ :: obj) + CASE ( & + & "HIERARCHICALPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHICALPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION") + ALLOCATE (HierarchyInterpolation_ :: obj) + CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") + ALLOCATE (OrthogonalInterpolation_ :: obj) + CASE DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for type of name="//TRIM(name), & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseInterpolation_fromString()", & + & file=__FILE__ & + & ) + END SELECT +END SUBROUTINE BaseInterpolation_FromString + +!---------------------------------------------------------------------------- +! BaseInterpolation_fromInteger +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +SUBROUTINE BaseInterpolation_FromInteger(obj, name) + CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj + INTEGER(I4B), INTENT(IN) :: name + + SELECT CASE (name) + CASE (LagrangePolynomial) + ALLOCATE (LagrangeInterpolation_ :: obj) + CASE (SerendipityPolynomial) + ALLOCATE (SerendipityInterpolation_ :: obj) + CASE (HermitPolynomial) + ALLOCATE (HermitInterpolation_ :: obj) + CASE (OrthogonalPolynomial) + ALLOCATE (OrthogonalInterpolation_ :: obj) + CASE (HeirarchicalPolynomial) + ALLOCATE (HierarchyInterpolation_ :: obj) + CASE DEFAULT + CALL ErrorMsg(& + & msg="NO CASE FOUND for given name="//tostring(name), & + & line=__LINE__, & + & unitno=stdout, & + & routine="BaseInterpolation_fromInteger()", & + & file=__FILE__ & + & ) + END SELECT + +END SUBROUTINE BaseInterpolation_FromInteger + +!---------------------------------------------------------------------------- +! QuadraturePointIDToName +!---------------------------------------------------------------------------- + +FUNCTION BaseInterpolation_ToString2(name) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: name + TYPE(String) :: ans + + SELECT CASE (name) + CASE (Equidistance) + ans = "EQUIDISTANCE" + + CASE (GaussLegendre) + ans = "GAUSSLEGENDRE" + + CASE (GaussLegendreLobatto) + ans = "GAUSSLEGENDRELOBATTO" + + CASE (GaussLegendreRadau) + ans = "GAUSSLEGENDRERADAU" + + CASE (GaussLegendreRadauLeft) + ans = "GAUSSLEGENDRERADAULEFT" + + CASE (GaussLegendreRadauRight) + ans = "GAUSSLEGENDRERADAURIGHT" + + CASE (GaussChebyshev) + ans = "GAUSSCHEBYSHEV" + + CASE (GaussChebyshevLobatto) + ans = "GAUSSCHEBYSHEVLOBATTO" + + CASE (GaussChebyshevRadau) + ans = "GAUSSCHEBYSHEVRADAU" + + CASE (GaussChebyshevRadauLeft) + ans = "GAUSSCHEBYSHEVRADAULEFT" + + CASE (GaussChebyshevRadauRight) + ans = "GAUSSCHEBYSHEVRADAURIGHT" + + CASE (GaussJacobi) + ans = "GAUSSJACOBI" + + CASE (GaussJacobiLobatto) + ans = "GAUSSJACOBILOBATTO" + + CASE (GaussJacobiRadau) + ans = "GAUSSJACOBIRADAU" + + CASE (GaussJacobiRadauLeft) + ans = "GAUSSJACOBIRADAULEFT" + + CASE (GaussJacobiRadauRight) + ans = "GAUSSJACOBIRADAURIGHT" + + CASE (GaussUltraspherical) + ans = "GAUSSULTRASPHERICAL" + + CASE (GaussUltrasphericalLobatto) + ans = "GAUSSULTRASPHERICALLOBATTO" + + CASE (GaussUltrasphericalRadau) + ans = "GAUSSULTRASPHERICALRADAU" + + CASE (GaussUltrasphericalRadauLeft) + ans = "GAUSSULTRASPHERICALRADAULEFT" + + CASE (GaussUltrasphericalRadauRight) + ans = "GAUSSULTRASPHERICALRADAURIGHT" + + CASE DEFAULT + CALL Errormsg(& + & msg="No case found for given quadratureType name", & + & file=__FILE__, & + & line=__LINE__,& + & routine="QuadraturePointIDToName()", & + & unitno=stderr) + RETURN + END SELECT +END FUNCTION BaseInterpolation_ToString2 + +END MODULE BaseInterpolation_Method diff --git a/src/modules/BaseMethod/CMakeLists.txt b/src/modules/BaseMethod/CMakeLists.txt new file mode 100644 index 000000000..6b7bbcad1 --- /dev/null +++ b/src/modules/BaseMethod/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/BaseMethod.F90 +) \ No newline at end of file diff --git a/src/modules/BaseMethod/src/BaseMethod.F90 b/src/modules/BaseMethod/src/BaseMethod.F90 new file mode 100644 index 000000000..04f1ed78f --- /dev/null +++ b/src/modules/BaseMethod/src/BaseMethod.F90 @@ -0,0 +1,120 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 23 Feb 2021 +! summary: Modules related to [[BaseType]] module. +! +!# Introduction +! This module contains the modules related to data types which are defined +! inside the [[BaseType]] module. This module should be compiled before +! compilation of any submodule because almost all the submodules of user +! defined data type methods uses [[BaseMethod]] module. Further, after adding +! a new user defined data type inside [[BaseType]] module, its method should +! be included here. + +MODULE BaseMethod +#ifdef USE_SuperLU +USE SuperLUInterface +#endif + +#ifdef USE_LIS +! USE LISInterface +#endif + +#ifdef USE_PLPLOT +USE PLPLOT +#endif + +#ifdef USE_OpenMP +USE OMP_LIB +#endif + +#ifdef USE_BLAS95 +USE F77_BLAS +USE F95_BLAS +#endif + +#ifdef USE_LAPACK95 +USE F77_LAPACK +USE F95_LAPACK +USE Lapack_Method +#endif + +#ifdef USE_ARPACK +USE EASIFEM_ARPACK +#endif + +#ifdef USE_FFTW +USE FFTW3 +#endif + +#ifdef USE_METIS +USE MetisInterface +#endif + +USE String_Class +USE String_Method +USE PENF, ONLY: endianL, endianB, endian, byte_size, str_ascii, & + & str_ucs4, str, strz, cton, bstr, bcton, check_endian, digit, & + & penf_Init, penf_print +USE BeFoR64 +USE FACE +USE FPL, ONLY: ParameterList_, & +& ParameterListIterator_, & +& FPL_Init, & +& FPL_Finalize +USE System_Method +USE CInterface +USE OpenMP_Method +USE GlobalData +USE Hashing32 +USE OGPF +USE Test_Method +USE MdEncode_Method +! USE DISPMODULE +USE Display_Method +USE ErrorHandling +USE BaseInterpolation_Method +USE BaseContinuity_Method +USE Utility +USE PolynomialUtility +USE BaseType +USE MultiIndices_Method +USE Random_Method +USE BoundingBox_Method +USE IntVector_Method +USE IndexValue_Method +USE KeyValue_Method +USE IterationData_Method +USE Vector3D_Method +USE RealVector_Method +USE DOF_Method +USE Geometry_Method +USE QuadraturePoint_Method +USE FEVariable_Method +USE Elemshapedata_Method +USE RealMatrix_Method +USE FEMatrix_Method +USE FEVector_Method +USE Rank2Tensor_Method +USE VoigtRank2Tensor_Method +USE CSRSparsity_Method +USE CSRMatrix_Method +USE LuaInterface + +END MODULE BaseMethod diff --git a/src/modules/BaseType/CMakeLists.txt b/src/modules/BaseType/CMakeLists.txt new file mode 100644 index 000000000..a1e0d39ca --- /dev/null +++ b/src/modules/BaseType/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}/BaseType.F90 +) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 new file mode 100644 index 000000000..5385572b3 --- /dev/null +++ b/src/modules/BaseType/src/BaseType.F90 @@ -0,0 +1,1748 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see < https://www.gnu.org/licenses/> +! + +!> author: Dr. Vikas Sharma +! +! [[BaseType]] module contains several userful user defined data types. + +MODULE BaseType +USE GlobalData +USE String_Class, ONLY: String +#ifdef USE_SuperLU +USE SuperLUInterface +USE ISO_C_BINDING, ONLY: C_CHAR, C_PTR, C_SIZE_T +#endif +IMPLICIT NONE +PRIVATE + +PUBLIC :: Math +PUBLIC :: BoundingBox_ +PUBLIC :: TypeBoundingBox +PUBLIC :: BoundingBoxPointer_ +PUBLIC :: RealMatrix_ +PUBLIC :: TypeRealMatrix +PUBLIC :: RealMatrixPointer_ +PUBLIC :: IntVector_ +PUBLIC :: TypeIntVector +PUBLIC :: IntVectorPointer_ +PUBLIC :: RealVector_ +PUBLIC :: TypeRealVector +PUBLIC :: RealVectorPointer_ +PUBLIC :: Vector3D_ +PUBLIC :: TypeVector3D +PUBLIC :: Vector3DPointer_ +PUBLIC :: IndexValue_ +PUBLIC :: IndexValuePointer_ +PUBLIC :: DOF_ +PUBLIC :: TypeDOF +PUBLIC :: DOFPointer_ +PUBLIC :: SparseMatrixReOrdering_ +PUBLIC :: TypeSparseMatrixReOrdering +PUBLIC :: CSRSparsity_ +PUBLIC :: TypeCSRSparsity +PUBLIC :: CSRSparsityPointer_ +PUBLIC :: CSRMatrix_ +PUBLIC :: TypeCSRMatrix +PUBLIC :: CSRMatrixPointer_ +PUBLIC :: IterationData_ +PUBLIC :: TypeIterationData +PUBLIC :: IterationDataPointer_ +PUBLIC :: VoigtRank2Tensor_ +PUBLIC :: TypeVoigtRank2Tensor +PUBLIC :: VoigtRank2TensorPointer +PUBLIC :: Rank2Tensor_ +PUBLIC :: TypeRank2Tensor +PUBLIC :: Rank2TensorPointer_ +PUBLIC :: DeformationGradient_ +PUBLIC :: DeformationGradientPointer_ +PUBLIC :: TypeDeformationGradient +PUBLIC :: LeftCauchyGreen_ +PUBLIC :: TypeLeftCauchyGreen +PUBLIC :: LeftCauchyGreenPointer_ +PUBLIC :: RightCauchyGreen_ +PUBLIC :: TypeRightCauchyGreen +PUBLIC :: RightCauchyGreenPointer_ +PUBLIC :: Strain_ +PUBLIC :: TypeStrain +PUBLIC :: StrainPointer_ +PUBLIC :: AlmansiStrain_ +PUBLIC :: TypeAlmansiStrain +PUBLIC :: AlmansiStrainPointer_ +PUBLIC :: GreenStrain_ +PUBLIC :: TypeGreenStrain +PUBLIC :: GreenStrainPointer_ +PUBLIC :: SmallStrain_ +PUBLIC :: TypeSmallStrain +PUBLIC :: SmallStrainPointer_ +PUBLIC :: ReferenceTopology_ +! PUBLIC :: TypeReferenceTopology +PUBLIC :: ReferenceTopologyPointer_ +PUBLIC :: ReferenceElement_ +PUBLIC :: ReferenceElementPointer_ +PUBLIC :: ReferencePoint_ +PUBLIC :: TypeReferencePoint +PUBLIC :: ReferenceLine_ +PUBLIC :: TypeReferenceLine +PUBLIC :: ReferenceTriangle_ +PUBLIC :: TypeReferenceTriangle +PUBLIC :: ReferenceQuadrangle_ +PUBLIC :: TypeReferenceQuadrangle +PUBLIC :: ReferenceTetrahedron_ +PUBLIC :: TypeReferenceTetrahedron +PUBLIC :: ReferenceHexahedron_ +PUBLIC :: TypeReferenceHexahedron +PUBLIC :: ReferencePrism_ +PUBLIC :: TypeReferencePrism +PUBLIC :: ReferencePyramid_ +PUBLIC :: TypeReferencePyramid +PUBLIC :: KeyValue_ +PUBLIC :: TypeKeyValue +PUBLIC :: FEVariable_ +PUBLIC :: TypeFEVariable +PUBLIC :: FEVariableConstant_ +PUBLIC :: TypeFEVariableConstant +PUBLIC :: TypeVariableConstant +PUBLIC :: FEVariableSpace_ +PUBLIC :: TypeFEVariableSpace +PUBLIC :: TypeVariableSpace +PUBLIC :: FEVariableSpaceTime_ +PUBLIC :: TypeFEVariableSpaceTime +PUBLIC :: TypeVariableSpaceTime +PUBLIC :: FEVariableTime_ +PUBLIC :: TypeFEVariableTime +PUBLIC :: TypeVariableTime +PUBLIC :: FEVariableScalar_ +PUBLIC :: TypeFEVariableScalar +PUBLIC :: TypeVariableScalar +PUBLIC :: FEVariableVector_ +PUBLIC :: TypeFEVariableVector +PUBLIC :: TypeVariableVector +PUBLIC :: FEVariableMatrix_ +PUBLIC :: TypeFEVariableMatrix +PUBLIC :: TypeVariableMatrix +PUBLIC :: QuadraturePoint_ +PUBLIC :: TypeQuadraturePoint +PUBLIC :: QuadraturePointPointer_ +PUBLIC :: BaseInterpolation_ +PUBLIC :: LagrangeInterpolation_ +PUBLIC :: TypeLagrangeInterpolation +PUBLIC :: HermitInterpolation_ +PUBLIC :: TypeHermitInterpolation +PUBLIC :: SerendipityInterpolation_ +PUBLIC :: TypeSerendipityInterpolation +PUBLIC :: HierarchyInterpolation_ +PUBLIC :: TypeHierarchyInterpolation +PUBLIC :: OrthogonalInterpolation_ +PUBLIC :: TypeOrthogonalInterpolation +PUBLIC :: BaseContinuity_ +PUBLIC :: TypeBaseContinuity +PUBLIC :: H1_ +PUBLIC :: TypeH1 +PUBLIC :: HDIV_ +PUBLIC :: TypeHDIV +PUBLIC :: HCURL_ +PUBLIC :: TypeHCURL +PUBLIC :: DG_ +PUBLIC :: TypeDG +PUBLIC :: DEL_NONE, DEL_X, DEL_Y, DEL_Z, DEL_X_ALL, DEL_t +PUBLIC :: ElementData_ +PUBLIC :: TypeElementData +PUBLIC :: ElementDataPointer_ +PUBLIC :: ShapeData_ +PUBLIC :: TypeShapeData +PUBLIC :: ShapeDataPointer_ +PUBLIC :: STShapeData_ +PUBLIC :: STShapeDataPointer_ +PUBLIC :: ElemShapeData_ +PUBLIC :: TypeElemShapeData +PUBLIC :: ElemShapeDataPointer_ +PUBLIC :: STElemShapeData_ +PUBLIC :: TypeSTElemShapeData +PUBLIC :: QualityMeasure +PUBLIC :: Random_ +PUBLIC :: TypeRandom +PUBLIC :: OMP +PUBLIC :: TypeOpenMP +PUBLIC :: MultiIndices_ +PUBLIC :: iface_SpaceTimeFunction +PUBLIC :: iface_SpaceFunction +PUBLIC :: iface_TimeFunction +PUBLIC :: iface_1DFunction +PUBLIC :: iface_2DFunction +PUBLIC :: iface_3DFunction +PUBLIC :: iface_ScalarFunction +PUBLIC :: iface_VectorFunction +PUBLIC :: iface_MatrixFunction +PUBLIC :: Range_ +PUBLIC :: Interval1D_ + +INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 + +!---------------------------------------------------------------------------- +! Math_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2022 +! summary: Math class + +TYPE :: Math_ + REAL(DFP) :: PI = 3.14159265359_DFP + REAL(DFP) :: e = 2.718281828459045_DFP + 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_() + +!---------------------------------------------------------------------------- +! BoundingBox_ +!---------------------------------------------------------------------------- + +! date: 23 Feb 2021 +!> author: Vikas Sharma, Ph. D. +! summary: A data type to represent a bounding box; +! +!{!pages/BoundingBox_.md!} + +TYPE :: BoundingBox_ + INTEGER(I4B) :: nsd = 0 + !! Number of spatial dimension + !! NSD = 1, 2, 3 for 1D, 2D, 3D box + REAL(DFP) :: box(2, 3) = 0.0 + !! Box contains the xmin, ymin, ... + !! `Box(1:2, 1:3)` an array containing box coordinates. + !!- `Box(1:2, 1:3)` an array containing box coordinates. + !!- `Box(1, 1)` is x_min + !!- `Box(2, 1)` is x_max + !!- `Box(1, 2)` is y_min + !!- `Box(2, 2)` is y_max + !!- `Box(1, 3)` is z_min + !!- `Box(2, 3)` is z_max + REAL(DFP) :: l(3) = 0.0_DFP + !! l(1) length in x + !! l(2) length in y + !! l(3) length in z +END TYPE BoundingBox_ + +TYPE(BoundingBox_), PARAMETER :: TypeBoundingBox = BoundingBox_() +!! A Type Instance of Boundingbox + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Contains the pointer to the [[BoundingBox_]] data type. + +TYPE :: BoundingBoxPointer_ + CLASS(BoundingBoxPointer_), POINTER :: ptr => NULL() +END TYPE BoundingBoxPointer_ + +!---------------------------------------------------------------------------- +! Matrix_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: A data type for an Array of rank 2 of real numbers +! +!{!pages/docs-api/RealMatrix/RealMatrix_.md!} + +TYPE :: RealMatrix_ + INTEGER(I4B) :: tDimension = 0_I4B + CHARACTER(5) :: MatrixProp = 'UNSYM' + REAL(DFP), ALLOCATABLE :: Val(:, :) +END TYPE RealMatrix_ + +TYPE(RealMatrix_), PARAMETER :: TypeRealMatrix = RealMatrix_(Val=NULL()) + +TYPE :: RealMatrixPointer_ + CLASS(RealMatrix_), POINTER :: ptr => NULL() +END TYPE RealMatrixPointer_ + +!---------------------------------------------------------------------------- +! IntVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: A data type to contain fortran vector of integer numbers +! +!{!pages/IntVector_.md!} + +TYPE :: IntVector_ + INTEGER(I4B) :: tDimension = 1_I4B + INTEGER(I4B), ALLOCATABLE :: Val(:) +END TYPE IntVector_ + +TYPE(IntVector_), PARAMETER :: TypeIntVector = IntVector_(Val=NULL()) + +TYPE :: IntVectorPointer_ + CLASS(IntVector_), POINTER :: ptr => NULL() +END TYPE IntVectorPointer_ + +!---------------------------------------------------------------------------- +! RealVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: A data type to contain fortran vector of real numbers +! +!{!pages/RealVector_.md!} + +TYPE :: RealVector_ + INTEGER(I4B) :: tDimension = 1_I4B + REAL(DFP), ALLOCATABLE :: Val(:) +END TYPE RealVector_ + +TYPE(RealVector_), PARAMETER :: TypeRealVector = RealVector_(Val=NULL()) + +TYPE :: RealVectorPointer_ + CLASS(RealVector_), POINTER :: ptr => NULL() +END TYPE RealVectorPointer_ + +!---------------------------------------------------------------------------- +! Vector3D_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! summary: Data type for 3D vectors +! date: 24 Feb 2021 + +TYPE :: Vector3D_ + INTEGER(I4B) :: tDimension = 1_I4B + REAL(DFP) :: Val(3) = 0.0_DFP +END TYPE Vector3D_ + +TYPE(Vector3D_), PARAMETER :: TypeVector3D = Vector3D_() + +!---------------------------------------------------------------------------- +! Vector3DPointer_ +!---------------------------------------------------------------------------- + +TYPE :: Vector3DPointer_ + CLASS(Vector3D_), POINTER :: ptr => NULL() +END TYPE Vector3DPointer_ + +!---------------------------------------------------------------------------- +! IndexValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: Index value keymap; useful for defining nodal boundary conditions + +TYPE :: IndexValue_ + INTEGER(I4B) :: Indx + REAL(DFP) :: Val +END TYPE + +TYPE(IndexValue_), PUBLIC, PARAMETER :: TypeIndexValue = & + & IndexValue_(Indx=0, Val=0.0_DFP) + +TYPE :: IndexValuePointer_ + CLASS(IndexValue_), POINTER :: ptr => NULL() +END TYPE IndexValuePointer_ + +!---------------------------------------------------------------------------- +! DOF_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Degree of freedom object type + +TYPE :: DOF_ + INTEGER(I4B), ALLOCATABLE :: map(:, :) + !! Encapsulation of information of DOF + INTEGER(I4B), ALLOCATABLE :: valMap(:) + !! Val map + INTEGER(I4B) :: storageFMT = FMT_NODES + !! Storage format +END TYPE DOF_ + +TYPE(DOF_), PARAMETER :: TypeDOF = DOF_(MAP=NULL(), ValMap=NULL()) + +TYPE :: DOFPointer_ + CLASS(DOF_), POINTER :: ptr => NULL() +END TYPE DOFPointer_ + +!---------------------------------------------------------------------------- +! SparseOrdering +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: SparseMatrix reordering scheme + +TYPE :: SparseMatrixReOrdering_ + CHARACTER(10) :: name + INTEGER(I4B), ALLOCATABLE :: PERM(:) + INTEGER(I4B), ALLOCATABLE :: IPERM(:) +END TYPE SparseMatrixReOrdering_ + +TYPE(SparseMatrixReOrdering_), PARAMETER :: TypeSparseMatrixReOrdering = & + & SparseMatrixReOrdering_(name='', PERM=NULL(), IPERM=NULL()) + +!---------------------------------------------------------------------------- +! CSRSparsity_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 June 2021 +! summary: User data type for handling the sparsity pattern +! +!{!pages/CSRSparsity_.md!} + +TYPE :: CSRSparsity_ + INTEGER(I4B) :: nnz = 0 + INTEGER(I4B) :: ncol = 0 + INTEGER(I4B) :: nrow = 0 + LOGICAL(LGT) :: isSorted = .FALSE. + LOGICAL(LGT) :: isInitiated = .FALSE. + LOGICAL(LGT) :: isSparsityLock = .FALSE. + LOGICAL(LGT) :: isDiagStored = .FALSE. + INTEGER(I4B), ALLOCATABLE :: IA(:) + INTEGER(I4B), ALLOCATABLE :: JA(:) + INTEGER(I4B), ALLOCATABLE :: idiag(:) + TYPE(IntVector_), ALLOCATABLE :: row(:) + TYPE(DOF_) :: idof + !! DOF for row + TYPE(DOF_) :: jdof + !! DOF for columns +END TYPE CSRSparsity_ + +TYPE(CSRSparsity_), PARAMETER :: TypeCSRSparsity = & + & CSRSparsity_(IA=NULL(), JA=NULL(), Row=NULL()) + +TYPE :: CSRSparsityPointer_ + CLASS(CSRSparsity_), POINTER :: ptr => NULL() +END TYPE CSRSparsityPointer_ + +!---------------------------------------------------------------------------- +! SuperLU_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-25 +! summary: SuperLU data structure + +#ifdef USE_SuperLU +TYPE :: SuperLU_ + TYPE(SuperMatrix) :: A + TYPE(SuperMatrix) :: B + TYPE(SuperMatrix) :: X + TYPE(SuperMatrix) :: L + TYPE(SuperMatrix) :: U + TYPE(GlobalLU_t) :: Glu + TYPE(superlu_options_t) :: options + TYPE(SuperLUStat_t) :: stat + TYPE(mem_usage_t) :: mem_usage + TYPE(C_PTR) :: Work + ! TYPE(C_PTR), POINTER :: Work + !! work-space for superlu, the size is decided by superlu + INTEGER(I4B), ALLOCATABLE :: ia(:) + !! starting index of row, size(m+1) + INTEGER(I4B), ALLOCATABLE :: ja(:) + !! column indices, size(nnz) + INTEGER(I4B), ALLOCATABLE :: perm_c(:) + !! col permutation, size(n) + INTEGER(I4B), ALLOCATABLE :: perm_r(:) + !! row permutation, size(m) + INTEGER(I4B), ALLOCATABLE :: etree(:) + !! elimination tree, size(n) + REAL(DFP), ALLOCATABLE :: nzval(:) + !! nonzero values, size(nnz) + REAL(DFP), ALLOCATABLE :: sol(:, :) + !! solution, size(n, nrhs) + REAL(DFP), ALLOCATABLE :: rhs(:, :) + !! right hand side, size(m, nrhs) + REAL(DFP), ALLOCATABLE :: R(:) + !! row digonal scaling, size(m) + REAL(DFP), ALLOCATABLE :: C(:) + !! column diagonal scaling, size(n) + REAL(DFP), ALLOCATABLE :: ferr(:) + !! size(nrhs) + REAL(DFP), ALLOCATABLE :: berr(:) + !! size(nrhs) + CHARACTER(1, kind=C_CHAR) :: equed(2) + INTEGER(C_SIZE_T) :: lwork = 0 + INTEGER(C_SIZE_T) :: info = 0 + REAL(DFP) :: recip_pivot_growth = 0.0_DFP + REAL(DFP) :: rcond = 0.0_DFP + LOGICAL(LGT) :: isAInitiated = .FALSE. + LOGICAL(LGT) :: isBInitiated = .FALSE. + LOGICAL(LGT) :: isXInitiated = .FALSE. + LOGICAL(LGT) :: isLInitiated = .FALSE. + LOGICAL(LGT) :: isUInitiated = .FALSE. + LOGICAL(LGT) :: isGluInitiated = .FALSE. + LOGICAL(LGT) :: isStatInitiated = .FALSE. +END TYPE SuperLU_ +#endif + +!---------------------------------------------------------------------------- +! CSRMatrix_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: User data type for handling CSR matrices + +TYPE :: CSRMatrix_ + LOGICAL(LGT) :: csrOwnership = .TRUE. + !! This variable, if true, denotes that csr is allocated inside the obj + INTEGER(I4B) :: tDimension = 2_I4B + CHARACTER(20) :: matrixProp = 'UNSYM' + REAL(DFP), ALLOCATABLE :: A(:) + TYPE(CSRSparsity_) :: csr +#ifdef USE_SuperLU + TYPE(SuperLU_), POINTER :: slu => NULL() +#endif +END TYPE CSRMatrix_ + +TYPE(CSRMatrix_), PARAMETER :: TypeCSRMatrix = CSRMatrix_(& + & A=NULL(), slu=NULL()) + +TYPE :: CSRMatrixPointer_ + CLASS(CSRMatrix_), POINTER :: ptr => NULL() +END TYPE CSRMatrixPointer_ + +!---------------------------------------------------------------------------- +! IterationData_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: Iteration data + +TYPE :: IterationData_ + INTEGER(I4B) :: maxIter = 100 + !! Maximum number of iterations allowed + INTEGER(I4B) :: iterationNumber = 1 + !! Iteration number + REAL(DFP) :: residualError0 = 0.0 + !! Initial Residual error + REAL(DFP) :: residualError = 0.0 + !! Current residual error + REAL(DFP) :: residualTolerance = 1.0E-5 + !! Tolerance for checking convergence in residual + REAL(DFP) :: solutionError0 = 0.0 + !! Initial solution error + REAL(DFP) :: solutionError = 0.0 + !! Current solution error + REAL(DFP) :: solutionTolerance = 1.0E-5 + !! Tolerance for checking convergence in solution + INTEGER(I4B) :: convergenceType = RelativeConvergence + !! Type of convergence + INTEGER(I4B) :: convergenceIn = ConvergenceInRes + !! Check Convergence in solution and/or residual + INTEGER(I4B) :: normType = NormL2 + !! Error norm type + LOGICAL(LGT) :: converged = .FALSE. + !! Status of convergence + REAL(DFP) :: timeAtStart = 0.0 + !! Starting time + REAL(DFP) :: timeAtEnd = 0.0 + !! Present time + REAL(DFP), ALLOCATABLE :: convergenceData(:, :) + !! history of convergence data + !! each column corresponding to a iteration + TYPE(String), ALLOCATABLE :: header(:) + !! header for convergenceData +END TYPE IterationData_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE(IterationData_), PARAMETER :: TypeIterationData = & + & IterationData_(header=NULL()) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: IterationDataPointer_ + CLASS(IterationData_), POINTER :: ptr => NULL() +END TYPE IterationDataPointer_ + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: Voigt representation of rank2 tensor + +TYPE :: VoigtRank2Tensor_ + REAL(DFP) :: V(6) = 0.0_DFP + REAL(DFP) :: Scale = 1.0_DFP + INTEGER(I4B) :: VoigtType = StressTypeVoigt +END TYPE VoigtRank2Tensor_ + +TYPE(VoigtRank2Tensor_), PARAMETER :: TypeVoigtRank2Tensor & + & = VoigtRank2Tensor_() + +TYPE :: VoigtRank2TensorPointer + CLASS(VoigtRank2Tensor_), POINTER :: ptr => NULL() +END TYPE VoigtRank2TensorPointer + +!---------------------------------------------------------------------------- +! Tensor_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-05 +! summary: General type for Tensor + +TYPE :: Tensor_ +END TYPE Tensor_ + +!---------------------------------------------------------------------------- +! Rank2Tensor_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-05 +! summary: Rank 2 tensor + +TYPE, EXTENDS(Tensor_) :: Rank2Tensor_ + REAL(DFP) :: T(3, 3) = 0.0_DFP + LOGICAL(LGT) :: isSym = .FALSE. +END TYPE Rank2Tensor_ + +TYPE(Rank2Tensor_), PARAMETER :: TypeRank2Tensor = Rank2Tensor_() + +TYPE :: Rank2TensorPointer_ + CLASS(Rank2Tensor_), POINTER :: ptr => NULL() +END TYPE Rank2TensorPointer_ + +!---------------------------------------------------------------------------- +! DeformationGradient_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-05 +! summary: Deformation gradient tensor + +TYPE, EXTENDS(Rank2Tensor_) :: DeformationGradient_ +END TYPE DeformationGradient_ + +TYPE(DeformationGradient_), PARAMETER :: TypeDeformationGradient & + & = DeformationGradient_() + +TYPE :: DeformationGradientPointer_ + CLASS(DeformationGradient_), POINTER :: ptr => NULL() +END TYPE DeformationGradientPointer_ + +!---------------------------------------------------------------------------- +! LeftCauchyGreen_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Left Cauchy Green Deformation tensor +! +!# Introduction +! This data tyoe defines Left Cauchy Green Deformation tensor, which +! is an Eulerian tensor. It is symmetric and given by +! +! $$b = F F^{T}=V^2$$ +! +!{!pages/docs-api/LeftCauchyGreen/LeftCauchyGreen_.md!} + +TYPE, EXTENDS(Rank2Tensor_) :: LeftCauchyGreen_ +END TYPE LeftCauchyGreen_ + +TYPE(LeftCauchyGreen_), PARAMETER :: TypeLeftCauchyGreen & + & = LeftCauchyGreen_() + +TYPE :: LeftCauchyGreenPointer_ + CLASS(LeftCauchyGreen_), POINTER :: ptr => NULL() +END TYPE LeftCauchyGreenPointer_ + +!---------------------------------------------------------------------------- +! RightCauchyGreen_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Right Cauchy Green Deformation tensor +! +!# Introduction +! This data tyoe defines Right Cauchy Green Deformation tensor, which is an +! Eulerian tensor. It is symmetric and given by +! +! $$b = F F^{T}=V^2$$ +! +!{!pages/RightCauchyGreen.md} + +TYPE, EXTENDS(Rank2Tensor_) :: RightCauchyGreen_ +END TYPE RightCauchyGreen_ + +TYPE(RightCauchyGreen_), PARAMETER :: TypeRightCauchyGreen & + & = RightCauchyGreen_() + +TYPE :: RightCauchyGreenPointer_ + CLASS(RightCauchyGreen_), POINTER :: ptr => NULL() +END TYPE RightCauchyGreenPointer_ + +!---------------------------------------------------------------------------- +! Strain_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(Rank2Tensor_) :: Strain_ +END TYPE Strain_ + +TYPE(Strain_), PARAMETER :: TypeStrain = Strain_() + +TYPE :: StrainPointer_ + CLASS(Strain_), POINTER :: ptr => NULL() +END TYPE StrainPointer_ + +!---------------------------------------------------------------------------- +! AlmansiStrain_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(Strain_) :: AlmansiStrain_ +END TYPE AlmansiStrain_ + +TYPE(AlmansiStrain_), PARAMETER :: TypeAlmansiStrain = AlmansiStrain_() + +TYPE :: AlmansiStrainPointer_ + CLASS(AlmansiStrain_), POINTER :: ptr => NULL() +END TYPE AlmansiStrainPointer_ + +!---------------------------------------------------------------------------- +! GreenStrain_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(Strain_) :: GreenStrain_ +END TYPE GreenStrain_ + +TYPE(GreenStrain_), PARAMETER :: TypeGreenStrain = GreenStrain_() + +TYPE :: GreenStrainPointer_ + CLASS(GreenStrain_), POINTER :: ptr => NULL() +END TYPE GreenStrainPointer_ + +!---------------------------------------------------------------------------- +! SmallStrain_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(Strain_) :: SmallStrain_ +END TYPE SmallStrain_ + +TYPE(SmallStrain_), PARAMETER :: TypeSmallStrain = SmallStrain_() + +TYPE :: SmallStrainPointer_ + CLASS(SmallStrain_), POINTER :: ptr => NULL() +END TYPE SmallStrainPointer_ + +!---------------------------------------------------------------------------- +! ReferenceTopology_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This data type is defined to handle reference topology +! +!{!pages/ReferenceElement_.md} + +TYPE :: ReferenceTopology_ + INTEGER(I4B), ALLOCATABLE :: nptrs(:) + INTEGER(I4B) :: name = 0 + INTEGER(I4B) :: xiDimension = 0 +END TYPE ReferenceTopology_ + +TYPE :: ReferenceTopologyPointer_ + CLASS(ReferenceTopology_), POINTER :: ptr => NULL() +END TYPE ReferenceTopologyPointer_ + +!---------------------------------------------------------------------------- +! ReferenceElement_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 March 2021 +! summary: An abstract data type for Reference Element +! +!{!pages/docs-api/ReferenceElement/ReferenceElement_.md!} + +TYPE :: ReferenceElement_ + CHARACTER(10) :: domainName = "GENERAL" + !! UNIT, BIUNIT, GENERAL + INTEGER(I4B) :: entityCounts(4) = 0 + !! Number of 0D, 1D, 2D, 3D entities + !! entityCounts(1) = total number of points + !! entityCounts(2) = total number of edges + !! entityCounts(3) = total number of faces + !! entityCounts(4) = total number of cells + INTEGER(I4B) :: xiDimension = 0 + !! Xidimension + INTEGER(I4B) :: name = 0 + !! name of the element + INTEGER(I4B) :: order = 0 + !! Order of element + INTEGER(I4B) :: nsd = 0 + !! Number of spatial dimensions + INTEGER(I4B) :: interpolationPointType = Equidistance + !! Interpolation point + !! Equidistance + !! GaussLegendre + !! GaussLobatto + !! Chebyshev + TYPE(ReferenceTopology_), ALLOCATABLE :: topology(:) + !! Topology information of 0D, 1, 2, 3D entities + REAL(DFP), ALLOCATABLE :: xiJ(:, :) + !! Node coord + !! Rows represents the spatial components + !! Columns represents the node number + PROCEDURE(highorder_refelem), POINTER, PASS(obj) :: & + & highOrderElement => NULL() + !! Routine to generate hgher order LagrangeElement +END TYPE ReferenceElement_ + +TYPE :: ReferenceElementPointer_ + CLASS(ReferenceElement_), POINTER :: ptr => NULL() +END TYPE ReferenceElementPointer_ + +INTERFACE + SUBROUTINE highorder_refelem(obj, order, highOrderobj, ipType) + IMPORT :: ReferenceElement_, I4B + CLASS(ReferenceElement_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: order + CLASS(ReferenceElement_), INTENT(INOUT) :: highOrderobj + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE highorder_refelem +END INTERFACE + +!---------------------------------------------------------------------------- +! ReferencePoint_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference point element +! +!{!pages/docs-api/ReferencePoint/ReferencePoint_.md!} + +TYPE, EXTENDS(ReferenceElement_) :: ReferencePoint_ +END TYPE ReferencePoint_ + +TYPE(ReferencePoint_), PARAMETER :: & + & TypeReferencePoint = ReferencePoint_( & + & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & + & xiDimension=0, name=0, & + & Topology=NULL(), Order=0, NSD=0) + +!---------------------------------------------------------------------------- +! ReferenceLine_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference line +! +!{!pages/docs-api/ReferenceLine/ReferenceLine_.md!} + +TYPE, EXTENDS(ReferenceElement_) :: ReferenceLine_ +END TYPE ReferenceLine_ + +TYPE(ReferenceLine_), PARAMETER :: & + & TypeReferenceLine = ReferenceLine_( & + & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & + & xiDimension=0, name=0, & + & Topology=NULL(), Order=0, NSD=0) + +!---------------------------------------------------------------------------- +! ReferenceTriangle_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference triangle +! +!{!pages/ReferenceTriangle.md} +TYPE, EXTENDS(ReferenceElement_) :: ReferenceTriangle_ +END TYPE ReferenceTriangle_ + +TYPE(ReferenceTriangle_), PARAMETER :: & + & TypeReferenceTriangle = ReferenceTriangle_( & + & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & + & xiDimension=0, name=0, & + & Topology=NULL(), Order=0, NSD=0) + +!---------------------------------------------------------------------------- +! ReferenceQuadrangle_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference quadrangle +! +!{!pages/ReferenceQuadrangle/ReferenceQuadrangle_.md!} + +TYPE, EXTENDS(ReferenceElement_) :: ReferenceQuadrangle_ +END TYPE ReferenceQuadrangle_ + +TYPE(ReferenceQuadrangle_), PARAMETER :: & + & TypeReferenceQuadrangle & + & = ReferenceQuadrangle_( & + & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], & + & xiDimension=0, name=0, & + & Topology=NULL(), Order=0, NSD=0) + +!---------------------------------------------------------------------------- +! ReferenceTetrahedron_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference tetrahedron +! +!{!pages/ReferenceTetrahedron/ReferenceTetrahedron_.md!} + +TYPE, EXTENDS(ReferenceElement_) :: ReferenceTetrahedron_ +END TYPE ReferenceTetrahedron_ + +TYPE(ReferenceTetrahedron_), PARAMETER :: & + & TypeReferenceTetrahedron & + & = ReferenceTetrahedron_( & + & XiJ=NULL(), EntityCounts=[0, 0, 0, 0], xiDimension=0, name=0, & + & Topology=NULL(), Order=0, NSD=0) + +!---------------------------------------------------------------------------- +! ReferenceHexahedron_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference hexahedron +! +!{!pages/docs-api/ReferenceHexahedron/ReferenceHexahedron_.md} + +TYPE, EXTENDS(ReferenceElement_) :: ReferenceHexahedron_ +END TYPE ReferenceHexahedron_ + +TYPE(ReferenceHexahedron_), PARAMETER :: & + & TypeReferenceHexahedron & + & = ReferenceHexahedron_( & + & XiJ=NULL(), & + & EntityCounts=[0, 0, 0, 0], & + & xiDimension=0, & + & name=0, & + & Topology=NULL(), & + & Order=0, & + & NSD=0) + +!---------------------------------------------------------------------------- +! ReferencePrism_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference prism +! +!{!pages/ReferencePrism.md} + +TYPE, EXTENDS(ReferenceElement_) :: ReferencePrism_ +END TYPE ReferencePrism_ + +TYPE(ReferencePrism_), PARAMETER :: TypeReferencePrism & + & = ReferencePrism_( & + & XiJ=NULL(), & + & EntityCounts=[0, 0, 0, 0], & + & xiDimension=0, & + & name=0, & + & Topology=NULL(), & + & Order=0, & + & NSD=0) + +!---------------------------------------------------------------------------- +! ReferencePyramid_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This data type defines a reference pyramid +! +!{!pages/ReferencePyramid.md} + +TYPE, EXTENDS(ReferenceElement_) :: ReferencePyramid_ +END TYPE ReferencePyramid_ + +TYPE(ReferencePyramid_), PARAMETER :: TypeReferencePyramid & + & = ReferencePyramid_( & + & XiJ=NULL(), & + & EntityCounts=[0, 0, 0, 0], & + & xiDimension=0, & + & name=0, & + & Topology=NULL(), & + & Order=0, & + & NSD=0) + +!---------------------------------------------------------------------------- +! KeyValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: [[keyvalue_]] is a poor implementation of dict + +TYPE :: KeyValue_ + INTEGER(I4B) :: DataType = 0 + TYPE(String) :: Key + REAL(DFP), ALLOCATABLE :: VALUE(:, :) +END TYPE KeyValue_ + +TYPE(KeyValue_), PARAMETER :: TypeKeyValue = KeyValue_(VALUE=NULL()) + +!---------------------------------------------------------------------------- +! FEVariable_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: Finite element variable +! +! {!pages/FEVariable_.md!} + +TYPE :: FEVariable_ + REAL(DFP), ALLOCATABLE :: val(:) + !! values + 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 + INTEGER(I4B) :: rank = 0 + !! Scalar + !! Vector + !! Matrix + INTEGER(I4B) :: len = 0_I4B + !! current total size + INTEGER(I4B) :: capacity = 0_I4B + !! capacity of the val +END TYPE FEVariable_ + +TYPE(FEVariable_), PARAMETER :: TypeFEVariable = FEVariable_(val=NULL()) + +!---------------------------------------------------------------------------- +! FEVariableConstant_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: FEVariable Constant + +TYPE :: FEVariableConstant_ +!! INTEGER(I4B):: Val = 1 +END TYPE FEVariableConstant_ + +TYPE(FEVariableConstant_), PARAMETER :: TypeFEVariableConstant = & + & FEVariableConstant_() + +TYPE(FEVariableConstant_), PARAMETER :: TypeVariableConstant = & + & FEVariableConstant_() + +!---------------------------------------------------------------------------- +! FEVariableSpace_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: FEVariable Space +! +TYPE :: FEVariableSpace_ +!! INTEGER(I4B):: Val = 2 +END TYPE FEVariableSpace_ + +TYPE(FEVariableSpace_), PARAMETER :: TypeFEVariableSpace = & + & FEVariableSpace_() +TYPE(FEVariableSpace_), PARAMETER :: TypeVariableSpace = & + & FEVariableSpace_() + +!---------------------------------------------------------------------------- +! FEVariableSpaceTime_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: FEVariable Space time + +TYPE :: FEVariableSpaceTime_ +!! INTEGER(I4B):: Val = 3 +END TYPE FEVariableSpaceTime_ + +TYPE(FEVariableSpaceTime_), PARAMETER :: TypeFEVariableSpaceTime & + & = FEVariableSpaceTime_() +TYPE(FEVariableSpaceTime_), PARAMETER :: TypeVariableSpaceTime & + & = FEVariableSpaceTime_() + +!---------------------------------------------------------------------------- +! FEVariableTime_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: FEVariable time + +TYPE :: FEVariableTime_ +!! INTEGER(I4B):: Val = 4 +END TYPE FEVariableTime_ + +TYPE(FEVariableTime_), PARAMETER :: TypeFEVariableTime = FEVariableTime_() +TYPE(FEVariableTime_), PARAMETER :: TypeVariableTime = FEVariableTime_() + +!---------------------------------------------------------------------------- +! FEVariableScalar_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: FEVariable scalar + +TYPE :: FEVariableScalar_ +!! INTEGER(I4B):: Val = 0 +END TYPE FEVariableScalar_ + +TYPE(FEVariableScalar_), PARAMETER :: TypeFEVariableScalar & + & = FEVariableScalar_() + +TYPE(FEVariableScalar_), PARAMETER :: TypeVariableScalar & + & = FEVariableScalar_() + +!---------------------------------------------------------------------------- +! FEVariableVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: FEVariable vector + +TYPE :: FEVariableVector_ +!! INTEGER(I4B):: Val = 1 +END TYPE FEVariableVector_ + +TYPE(FEVariableVector_), PARAMETER :: TypeFEVariableVector & + & = FEVariableVector_() + +TYPE(FEVariableVector_), PARAMETER :: TypeVariableVector & + & = FEVariableVector_() + +!---------------------------------------------------------------------------- +! FEVariableMatrix_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: FEVariable matrix + +TYPE :: FEVariableMatrix_ +!! INTEGER(I4B):: Val = 2 +END TYPE FEVariableMatrix_ + +TYPE(FEVariableMatrix_), PARAMETER :: TypeFEVariableMatrix & + & = FEVariableMatrix_() +TYPE(FEVariableMatrix_), PARAMETER :: TypeVariableMatrix & + & = FEVariableMatrix_() + +!---------------------------------------------------------------------------- +! QuadraturePoint_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Quadrature points for numerical integration +! +!{!pages/docs-api/QuadraturePoint/QuadraturePoint_.md!} + +TYPE :: QuadraturePoint_ + REAL(DFP), ALLOCATABLE :: points(:, :) + INTEGER(I4B) :: txi = 0 +END TYPE QuadraturePoint_ + +TYPE(QuadraturePoint_), PARAMETER :: TypeQuadraturePoint & + & = QuadraturePoint_(points=NULL()) + +TYPE :: QuadraturePointPointer_ + CLASS(QuadraturePoint_), POINTER :: ptr => NULL() +END TYPE QuadraturePointPointer_ + +!---------------------------------------------------------------------------- +! BasisInterpolation_ +!---------------------------------------------------------------------------- + +TYPE :: BaseInterpolation_ +END TYPE BaseInterpolation_ + +!---------------------------------------------------------------------------- +! LagrangeInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Lagrange basis functions + +TYPE, EXTENDS(BaseInterpolation_) :: LagrangeInterpolation_ +END TYPE LagrangeInterpolation_ + +TYPE(LagrangeInterpolation_), PARAMETER :: TypeLagrangeInterpolation & + & = LagrangeInterpolation_() + +!---------------------------------------------------------------------------- +! HermitInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Hermit basis functions + +TYPE, EXTENDS(BaseInterpolation_) :: HermitInterpolation_ +END TYPE HermitInterpolation_ + +TYPE(HermitInterpolation_), PARAMETER :: TypeHermitInterpolation & + & = HermitInterpolation_() + +!---------------------------------------------------------------------------- +! SerendipityInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Serendipity basis functions + +TYPE, EXTENDS(BaseInterpolation_) :: SerendipityInterpolation_ +END TYPE SerendipityInterpolation_ + +TYPE(SerendipityInterpolation_), PARAMETER :: TypeSerendipityInterpolation & + & = SerendipityInterpolation_() + +!---------------------------------------------------------------------------- +! HierarchyInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Hierarchical basis functions + +TYPE, EXTENDS(BaseInterpolation_) :: HierarchyInterpolation_ +END TYPE HierarchyInterpolation_ + +TYPE(HierarchyInterpolation_), PARAMETER :: TypeHierarchyInterpolation & + & = HierarchyInterpolation_() + +!---------------------------------------------------------------------------- +! OrthogonalInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Orthogonal basis functions + +TYPE, EXTENDS(BaseInterpolation_) :: OrthogonalInterpolation_ +END TYPE OrthogonalInterpolation_ + +TYPE(OrthogonalInterpolation_), PARAMETER :: TypeOrthogonalInterpolation & + & = OrthogonalInterpolation_() + +!---------------------------------------------------------------------------- +! BaseContinuity_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-03 +! summary: Continuity of basis functions +! +!# Introduction +! +! `BaseContinuity_` denotes the Continuity or conformity of basis functions. +! Following values are allowed: +! +! - H1_ +! - HDIV_ +! - HCURL_ +! - DG_ + +TYPE :: BaseContinuity_ +END TYPE BaseContinuity_ + +TYPE(BaseContinuity_), PARAMETER :: TypeBaseContinuity = BaseContinuity_() + +!---------------------------------------------------------------------------- +! H1_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(BaseContinuity_) :: H1_ +END TYPE H1_ + +TYPE(H1_), PARAMETER :: TypeH1 = H1_() + +!---------------------------------------------------------------------------- +! H1DIV_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(BaseContinuity_) :: HDIV_ +END TYPE HDIV_ + +TYPE(HDIV_), PARAMETER :: TypeHDIV = HDIV_() + +!---------------------------------------------------------------------------- +! HCURL_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(BaseContinuity_) :: HCURL_ +END TYPE HCURL_ + +TYPE(HCURL_), PARAMETER :: TypeHCURL = HCURL_() + +!---------------------------------------------------------------------------- +! DG_ +!---------------------------------------------------------------------------- + +TYPE, EXTENDS(BaseContinuity_) :: DG_ +END TYPE DG_ + +TYPE(DG_), PARAMETER :: TypeDG = DG_() + +!---------------------------------------------------------------------------- +! Derivative +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-06 +! update: 2021-11-06 +! summary: Derivative class contains symbols for derivatives + +INTEGER(I4B), PARAMETER :: DEL_NONE = 0 +INTEGER(I4B), PARAMETER :: DEL_X = 1 +INTEGER(I4B), PARAMETER :: DEL_Y = 2 +INTEGER(I4B), PARAMETER :: DEL_Z = 3 +INTEGER(I4B), PARAMETER :: DEL_X_ALL = 4 +INTEGER(I4B), PARAMETER :: DEL_t = -1 + +!---------------------------------------------------------------------------- +! ElementData_ +!---------------------------------------------------------------------------- + +TYPE :: ElementData_ + INTEGER(I4B) :: NSD = -1 + INTEGER(I4B) :: NNE = -1 + INTEGER(I4B) :: NNS = -1 + INTEGER(I4B) :: NNT = -1 + INTEGER(I4B) :: xiDimension = -1 + INTEGER(I4B) :: ElemTopology = -1 + INTEGER(I4B) :: SpaceElemTopo = -1 + INTEGER(I4B) :: TimeElemTopo = -1 + INTEGER(I4B) :: ElemType = -1 + INTEGER(I4B) :: MAT_Type = -1 +END TYPE ElementData_ + +TYPE(ElementData_), PARAMETER :: TypeElementData = ElementData_() + +TYPE :: ElementDataPointer_ + CLASS(ElementData_), POINTER :: ptr => NULL() +END TYPE ElementDataPointer_ + +!---------------------------------------------------------------------------- +! ShapeData_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: shape function data (deprecated) + +TYPE :: ShapeData_ + REAL(DFP) :: Ws = 0.0_DFP + REAL(DFP) :: Js = 0.0_DFP + REAL(DFP) :: Thickness = 1.0_DFP + REAL(DFP) :: Xi(3) = 0.0_DFP + REAL(DFP) :: XBar(3) = 0.0_DFP + REAL(DFP) :: Normal(3) = 0.0_DFP + INTEGER(I4B) :: ElemTopology = 0 + INTEGER(I4B) :: NSD = 0 + REAL(DFP), ALLOCATABLE :: N(:) + REAL(DFP), ALLOCATABLE :: dNdXi(:, :) + REAL(DFP), ALLOCATABLE :: dNdXt(:, :) + REAL(DFP), ALLOCATABLE :: Jacobian(:, :) +END TYPE ShapeData_ + +TYPE(ShapeData_), PARAMETER :: & + & TypeShapeData = ShapeData_( & + & N=NULL(), & + & dNdXi=NULL(), & + & dNdXt=NULL(), & + & Jacobian=NULL()) + +TYPE :: ShapeDataPointer_ + CLASS(ShapeDataPointer_), POINTER :: ptr => NULL() +END TYPE ShapeDataPointer_ + +!---------------------------------------------------------------------------- +! STShapeData_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 June 2022 +! summary: Datatype for space-time shape data + +TYPE, EXTENDS(ShapeData_) :: STShapeData_ + REAL(DFP) :: Theta = 0.0 + REAL(DFP) :: Wt = 0.0 + REAL(DFP) :: Jt = 0.0 + INTEGER(I4B) :: SpaceElemTopo = 0 + INTEGER(I4B) :: TimeElemTopo = 0 + REAL(DFP), ALLOCATABLE :: T(:) + !! values of shape function at different time nodes + REAL(DFP), ALLOCATABLE :: dTdTheta(:) + !! Value of local time derivative of T at time gauss point + REAL(DFP), ALLOCATABLE :: dNTdt(:, :) + !! Value of global time derivative of T at time gauss points + REAL(DFP), ALLOCATABLE :: dNTdXt(:, :, :) + !! Spatial gradient of the shape functions at space-time gauss points +END TYPE STShapeData_ + +TYPE :: STShapeDataPointer_ + CLASS(STShapeData_), POINTER :: ptr => NULL() +END TYPE STShapeDataPointer_ + +!---------------------------------------------------------------------------- +! ElemShapeData_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Datatype for data defined at all gauss points of an elements +! +!{!pages/docs-api/ElemShapeData/ElemshapeData_.md!} +! +TYPE :: ElemShapeData_ + REAL(DFP), ALLOCATABLE :: N(:, :) + !! Shape function value `N(I, ips)` + REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) + !! Local derivative of a shape function + REAL(DFP), ALLOCATABLE :: jacobian(:, :, :) + !! Jacobian of mapping `J(:,:,ips)` also $\mathbf{F}_{\Xi x}$ + REAL(DFP), ALLOCATABLE :: js(:) + !! Determinant of Jacobian at ips + REAL(DFP), ALLOCATABLE :: ws(:) + !! Weighting functions + REAL(DFP), ALLOCATABLE :: dNdXt(:, :, :) + !! Spatial derivative of shape function + REAL(DFP), ALLOCATABLE :: thickness(:) + !! Thickness of element + REAL(DFP), ALLOCATABLE :: coord(:, :) + !! Barycentric coordinate + REAL(DFP), ALLOCATABLE :: normal(:, :) + !! Normal in case of facet element + TYPE(ReferenceElement_) :: refelem + !! Refererece element + TYPE(QuadraturePoint_) :: quad + !! Quadrature points +END TYPE ElemShapeData_ + +TYPE(ElemShapeData_), PARAMETER :: & + & TypeElemShapeData = ElemShapeData_( & + & N=NULL(), & + & dNdXi=NULL(), & + & Jacobian=NULL(), & + & Js=NULL(), & + & Ws=NULL(), & + & dNdXt=NULL(), & + & Thickness=NULL(), & + & Coord=NULL(), & + & Normal=NULL()) + +TYPE :: ElemShapeDataPointer_ + CLASS(ShapeDataPointer_), POINTER :: ptr => NULL() +END TYPE ElemShapeDataPointer_ + +!---------------------------------------------------------------------------- +! STElemShapeData_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-08 +! update: 2021-12-08 +! summary: Space-time shape function data + +TYPE, EXTENDS(ElemShapeData_) :: STElemShapeData_ + REAL(DFP) :: wt = 0.0 + !! Weight of gauss point in time domain + REAL(DFP) :: theta = 0.0 + !! Gauss point in time domain + REAL(DFP) :: jt = 0.0 + !! Jacobian $\frac{dt}{d\theta}$ + REAL(DFP), ALLOCATABLE :: T(:) + !! Shape function in time domain + REAL(DFP), ALLOCATABLE :: dTdTheta(:) + !! Local shape function derivative in time domain + REAL(DFP), ALLOCATABLE :: dNTdt(:, :, :) + REAL(DFP), ALLOCATABLE :: dNTdXt(:, :, :, :) + !! (I, a, i, ips) +END TYPE STElemShapeData_ + +TYPE(STElemShapeData_), PARAMETER :: & + & TypeSTElemShapeData = STElemShapeData_( & + & N=NULL(), & + & dNdXi=NULL(), & + & Jacobian=NULL(), & + & Js=NULL(), & + & Ws=NULL(), & + & dNdXt=NULL(), & + & Thickness=NULL(), & + & Coord=NULL(), & + & Normal=NULL(), & + & T=NULL(), & + & dTdTheta=NULL(), & + & dNTdt=NULL(), & + & dNTdXt=NULL()) + +!---------------------------------------------------------------------------- +! Meshquality_ +!---------------------------------------------------------------------------- + +TYPE :: QualityMeasure_ + INTEGER(I4B), PUBLIC :: area = 100 + INTEGER(I4B), PUBLIC :: maxAngle = 101 + INTEGER(I4B), PUBLIC :: minAngle = 102 + INTEGER(I4B), PUBLIC :: AngleRatio = 103 + INTEGER(I4B), PUBLIC :: RadiusRatio = 104 + INTEGER(I4B), PUBLIC :: EdgeRatio = 105 + INTEGER(I4B), PUBLIC :: AspectRatio = 106 + INTEGER(I4B), PUBLIC :: ScaledJacobian = 107 + INTEGER(I4B), PUBLIC :: Default = 106 +END TYPE QualityMeasure_ + +TYPE(QualityMeasure_), PARAMETER :: QualityMeasure = QualityMeasure_() + +!---------------------------------------------------------------------------- +! Random_ +!---------------------------------------------------------------------------- + +TYPE :: Random_ + INTEGER(I4B) :: random_int = 100 + INTEGER(I4B), ALLOCATABLE :: random_int_seed(:) + INTEGER(I4B), ALLOCATABLE :: random_int_vec(:) + REAL(DFP) :: random_real = 0.0_DFP + REAL(DFP), ALLOCATABLE :: random_real_vec(:) +END TYPE + +TYPE(Random_), PARAMETER :: & + & TypeRandom = Random_(random_int_seed=NULL(), & + & random_int_vec=NULL(), & + & random_real_vec=NULL()) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 March 2021 +! summary: OpenMP and EASIFEM +TYPE :: OpenMP_ + INTEGER(I4B) :: Rank = 0 + INTEGER(I4B) :: NUM_THREADS = 1 + INTEGER(I4B) :: MAX_THREADS = 1 + INTEGER(I4B) :: STATE = OMP_THREADS_JOINED + LOGICAL(LGT) :: IS_INIT = .FALSE. + LOGICAL(LGT) :: DID_I_INIT = .FALSE. +END TYPE OpenMP_ + +TYPE(OpenMP_), PARAMETER :: TypeOpenMP = OpenMP_() +TYPE(OpenMP_) :: OMP +!$OMP THREADPRIVATE( OMP ) + +!---------------------------------------------------------------------------- +! MultiIndices_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Multi-indices object is defined + +TYPE :: MultiIndices_ + INTEGER(I4B) :: d + !! dimension of simplex + INTEGER(I4B) :: n + !! order +END TYPE MultiIndices_ + +!---------------------------------------------------------------------------- +! Range_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-09 +! summary: Range denotes the triplet index + +TYPE :: Range_ + INTEGER(I4B) :: is = 0_I4B + !! istart + INTEGER(I4B) :: ie = 0_I4B + !! iend + INTEGER(I4B) :: ic = 1_I4B + !! increment +END TYPE Range_ + +!---------------------------------------------------------------------------- +! Interval1D_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-09 +! summary: Interval1D_ denotes the 1d interval + +TYPE :: Interval1D_ + REAL(DFP) :: lower +!! lower limit + REAL(DFP) :: upper +!! upper limit +END TYPE Interval1D_ + +!---------------------------------------------------------------------------- +! SpaceTimeFunction +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_SpaceTimeFunction(x, t) RESULT(ans) + IMPORT :: DFP + ! CLASS( DirichletBC_ ), INTENT( IN ):: obj + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(IN) :: t + REAL(DFP) :: ans + END FUNCTION iface_SpaceTimeFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! SpaceFunction +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_SpaceFunction(x) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans + END FUNCTION iface_SpaceFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! TimeFunction +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_TimeFunction(t) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: t + REAL(DFP) :: ans + END FUNCTION iface_TimeFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! 1DFunction +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_1DFunction(x) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION iface_1DFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! 2DFunction +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_2DFunction(x, y) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: x, y + REAL(DFP) :: ans + END FUNCTION iface_2DFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! 3DFunction +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_3DFunction(x, y, z) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: x, y, z + REAL(DFP) :: ans + END FUNCTION iface_3DFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! ScalarFunction +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_ScalarFunction(x) RESULT(ans) + IMPORT :: DFP + REAL(DFP), OPTIONAL, INTENT(IN) :: x(:) + REAL(DFP) :: ans + END FUNCTION iface_ScalarFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_VectorFunction(x) RESULT(ans) + IMPORT :: DFP + REAL(DFP), OPTIONAL, INTENT(IN) :: x(:) + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION iface_VectorFunction +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_MatrixFunction(x) RESULT(ans) + IMPORT :: DFP + REAL(DFP), OPTIONAL, INTENT(IN) :: x(:) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION iface_MatrixFunction +END INTERFACE + +END MODULE BaseType diff --git a/src/modules/BeFoR64/CMakeLists.txt b/src/modules/BeFoR64/CMakeLists.txt new file mode 100644 index 000000000..c276252ab --- /dev/null +++ b/src/modules/BeFoR64/CMakeLists.txt @@ -0,0 +1,64 @@ +# set type specific output defaults +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/befor64.F90 + ${src_path}/befor64_pack_data_m.F90 + ) + +# set variables used for compile definitions of targets after support check +include(CheckFortranSourceRuns) +check_fortran_source_runs( + "program r16p_support; + integer, parameter :: r16p = selected_real_kind(33, 4931); + if(r16p < 0) stop 1; + end program r16p_support" + R16P_SUPPORTED + SRC_EXT f90 + ) +IF(R16P_SUPPORTED) + SET(r16p_supported "-D_R16P") +ENDIF() + +check_fortran_source_runs( + "program ascii_support; + integer, parameter :: ascii = selected_char_kind('ascii'); + if(ascii < 0) stop 1; + end program ascii_support" + ASCII_SUPPORTED + SRC_EXT f90) +IF(ASCII_SUPPORTED) + SET(ascii_supported "-D_ASCII_SUPPORTED") +ENDIF() + +check_fortran_source_runs( + "program ascii_neq_default; + integer, parameter :: ascii = selected_char_kind('ascii'); + integer, parameter :: default = selected_char_kind('default'); + if(ascii == default) stop 1; + end program ascii_neq_default" + ASCII_NEQ_DEFAULT + SRC_EXT f90 + ) + +IF(ASCII_NEQ_DEFAULT) + SET(ascii_neq_default "-D_ASCII_NEQ_DEFAULT") +ENDIF() + +check_fortran_source_runs( + "program ucs4_support; + integer, parameter :: ucs4 = selected_char_kind('iso_10646'); + if(ucs4 < 0) stop 1; + end program ucs4_support" + UCS4_SUPPORTED + SRC_EXT f90 + ) + +IF(UCS4_SUPPORTED) + SET(ucs4_supported "-D_UCS4_SUPPORTED") +ENDIF() + +LIST( APPEND TARGET_COMPILE_DEF ${r16p_supported} ) +LIST( APPEND TARGET_COMPILE_DEF ${ascii_supported} ) +LIST( APPEND TARGET_COMPILE_DEF ${ascii_neq_default} ) +LIST( APPEND TARGET_COMPILE_DEF ${ucs4_supported} ) \ No newline at end of file diff --git a/src/modules/BeFoR64/src/befor64.F90 b/src/modules/BeFoR64/src/befor64.F90 new file mode 100644 index 000000000..1ed72dc2d --- /dev/null +++ b/src/modules/BeFoR64/src/befor64.F90 @@ -0,0 +1,1122 @@ +!< BeFoR64, Base64 encoding/decoding library for FoRtran poor people. + +module befor64 +!< BeFoR64, Base64 encoding/decoding library for FoRtran poor people. +use penf +use befor64_pack_data_m + +implicit none +private +public :: is_b64_initialized, b64_init +public :: b64_encode, b64_encode_up +public :: b64_decode, b64_decode_up +public :: pack_data + +logical :: is_b64_initialized=.false. !< Flag for checking the initialization of the library. +character(64) :: base64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" !< Base64 alphabet. + +interface b64_encode + !< Encode numbers (integer and real) to base64. + !< + !< This is an interface for encoding integer and real numbers of any kinds into a base64 string. This interface can encode both + !< scalar and array. + !< + !< @warning The encoded string is returned as varying length character string, `character(len=:), allocatable:: string`, thus the + !< compiler must support such a Fortran (2003) feature. + !< + !< @note Before start to encode anything the library must be initialized. The procedure `b64_init` must be called at first. The + !< global variable `is_b64_initialized` can be used to check the status of the initialization. + !< + !<### Usage + !< For a practical example see the `autotest` procedure. + !< + !<#### Scalar encoding + !<```ortran + ! T <<< + + if (.not.is_initialized) call penf_init + is_b64_initialized = .true. + endsubroutine b64_init + + pure subroutine encode_bits(bits, padd, code) + !< Encode a bits stream (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4). + !< + !< The bits stream are encoded in chunks of 24 bits as the following example (in little endian order) + !<``` + !< +--first octet--+-second octet--+--third octet--+ + !< |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0| + !< +-----------+---+-------+-------+---+-----------+ + !< |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0| + !< +--1.index--+--2.index--+--3.index--+--4.index--+ + !<``` + !< @note The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used. + !< + !< @note The number of paddings must be computed outside this procedure, into the calling scope. + !< + !< @warning This procedure is the backend of encoding, thus it must be never called outside the module. + integer(I1P), intent(in) :: bits(1:) !< Bits to be encoded. + integer(I4P), intent(in) :: padd !< Number of padding characters ('='). + character(*), intent(out) :: code !< Characters code. + integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. + integer(I8P) :: c !< Counter. + integer(I8P) :: e !< Counter. + integer(I8P) :: Nb !< Length of bits array. + + Nb=size(bits,dim=1,kind=I8P) + c = 1_I8P + do e=1_I8P,Nb,3_I8P ! loop over array elements: 3 bytes (24 bits) scanning + sixb = 0_I1P + call mvbits(bits(e ),2,6,sixb(1),0) + call mvbits(bits(e ),0,2,sixb(2),4) + if (e+1<=Nb) then + call mvbits(bits(e+1),4,4,sixb(2),0) + call mvbits(bits(e+1),0,4,sixb(3),2) + endif + if (e+2<=Nb) then + call mvbits(bits(e+2),6,2,sixb(3),0) + call mvbits(bits(e+2),0,6,sixb(4),0) + endif + sixb = sixb + 1_I1P + code(c :c ) = base64(sixb(1):sixb(1)) + code(c+1:c+1) = base64(sixb(2):sixb(2)) + code(c+2:c+2) = base64(sixb(3):sixb(3)) + code(c+3:c+3) = base64(sixb(4):sixb(4)) + c = c + 4_I8P + enddo + if (padd>0) code(len(code)-padd+1:)=repeat('=',padd) + endsubroutine encode_bits + + pure subroutine decode_bits(code, bits) + !< Decode a base64 string into a sequence of bits stream. + !< + !< The base64 string must be parsed with a strike of 4 characters and converted into a 3 bytes stream. Considering the base64 code + !< `QUJD` the decoding process must do + !<``` + !< +-b64 char--+-b64 char--+-b64 char--+-b64 char--+ + !< | Q | U | J | D | + !< +-b64 index-+-b64 index-+-b64 index-+-b64 index-+ + !< ! 16 | 20 | 9 | 3 | + !< +-6 bits----+-6 bits----+-6 bits----+-6 bits----+ + !< |0 1 0 0 0 0|0 1 0 1 0 0|0 0 1 0 0 1|0 0 0 0 1 1| + !< +-----------+---+-------+-------+---+-----------+ + !< |0 1 0 0 0 0 0 1|0 1 0 0 0 0 1 0|0 1 0 0 0 0 1 1| + !< +-----8 bits----+-----8 bits----+-----8 bits----+ + !<``` + !< @note The bits pattern is returned as a 1-byte element array, the dimension of witch must be computed outside this procedure. + !< + !< @warning This procedure is the backend of decoding, thus it must be never called outside the module. + character(*), intent(in) :: code !< Characters code. + integer(I1P), intent(out) :: bits(1:) !< Bits decoded. + integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. + integer(I8P) :: c !< Counter. + integer(I8P) :: e !< Counter. + integer(I8P) :: Nb !< Length of bits array. + + Nb=size(bits,dim=1,kind=I8P) + e = 1_I8P + do c=1_I8P,len(code),4_I8P ! loop over code characters: 3 bytes (24 bits) scanning + sixb = 0_I1P + sixb(1) = index(base64,code(c :c )) - 1 + sixb(2) = index(base64,code(c+1:c+1)) - 1 + sixb(3) = index(base64,code(c+2:c+2)) - 1 + sixb(4) = index(base64,code(c+3:c+3)) - 1 + call mvbits(sixb(1),0,6,bits(e ),2) ; call mvbits(sixb(2),4,2,bits(e ),0) + if (e+1<=Nb) then + call mvbits(sixb(2),0,4,bits(e+1),4) ; call mvbits(sixb(3),2,4,bits(e+1),0) + endif + if (e+2<=Nb) then + call mvbits(sixb(3),0,2,bits(e+2),6) ; call mvbits(sixb(4),0,6,bits(e+2),0) + endif + e = e + 3_I8P + enddo + endsubroutine decode_bits + + subroutine b64_encode_up(up, code) + !< Encode an unlimited polymorphic scalar to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode_up(up=1._R8P, code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAAAA8D8= <<< + class(*), intent(in) :: up !< Unlimited polymorphic variable to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + + select type(up) + type is(real(R8P)) + call b64_encode_R8(n=up,code=code) + type is(real(R4P)) + call b64_encode_R4(n=up,code=code) + type is(integer(I8P)) + call b64_encode_I8(n=up,code=code) + type is(integer(I4P)) + call b64_encode_I4(n=up,code=code) + type is(integer(I2P)) + call b64_encode_I2(n=up,code=code) + type is(integer(I1P)) + call b64_encode_I1(n=up,code=code) + type is(character(*)) + call b64_encode_string(s=up,code=code) + endselect + endsubroutine b64_encode_up + + pure subroutine b64_encode_up_a(up, code) + !< Encode an unlimited polymorphic array to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode_up(up=[0._R4P,-32.12_R4P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAOF6AMI= <<< + class(*), intent(in) :: up(1:) !< Unlimited polymorphic variable to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + + select type(up) + type is(real(R8P)) + call b64_encode_R8_a(n=up,code=code) + type is(real(R4P)) + call b64_encode_R4_a(n=up,code=code) + type is(integer(I8P)) + call b64_encode_I8_a(n=up,code=code) + type is(integer(I4P)) + call b64_encode_I4_a(n=up,code=code) + type is(integer(I2P)) + call b64_encode_I2_a(n=up,code=code) + type is(integer(I1P)) + call b64_encode_I1_a(n=up,code=code) + type is(character(*)) + call b64_encode_string_a(s=up,code=code) + endselect + endsubroutine b64_encode_up_a + + subroutine b64_decode_up(code, up) + !< Decode an unlimited polymorphic scalar from base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: scalar_I4 + !< call b64_decode_up(code='5wcAAA==',up=scalar_I4) + !< print "(L1)", scalar_I4==2023_I4P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + class(*), intent(out) :: up !< Unlimited polymorphic variable to be decoded. + + select type(up) + type is(real(R8P)) + call b64_decode_R8(code=code,n=up) + type is(real(R4P)) + call b64_decode_R4(code=code,n=up) + type is(integer(I8P)) + call b64_decode_I8(code=code,n=up) + type is(integer(I4P)) + call b64_decode_I4(code=code,n=up) + type is(integer(I2P)) + call b64_decode_I2(code=code,n=up) + type is(integer(I1P)) + call b64_decode_I1(code=code,n=up) + type is(character(*)) + call b64_decode_string(code=code,s=up) + endselect + endsubroutine b64_decode_up + + subroutine b64_decode_up_a(code, up) + !< Decode an unlimited polymorphic array from base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: array_I8(1:4) + !< call b64_decode_up(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=', up=array_I8) + !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + class(*), intent(out) :: up(1:) !< Unlimited polymorphic variable to be decoded. + + select type(up) + type is(real(R8P)) + call b64_decode_R8_a(code=code,n=up) + type is(real(R4P)) + call b64_decode_R4_a(code=code,n=up) + type is(integer(I8P)) + call b64_decode_I8_a(code=code,n=up) + type is(integer(I4P)) + call b64_decode_I4_a(code=code,n=up) + type is(integer(I2P)) + call b64_decode_I2_a(code=code,n=up) + type is(integer(I1P)) + call b64_decode_I1_a(code=code,n=up) + type is(character(*)) + call b64_decode_string_a(code=code,s=up) + endselect + endsubroutine b64_decode_up_a + + pure subroutine b64_encode_R16(n, code) + !< Encode scalar number to base64 (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=134.231_R16P, code=code64) + !< print "(A)", code64 + !<``` + !=> CKwcWmTHYEA= <<< + real(R16P), intent(in) :: n !< Number to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + + allocate(nI1P(1:((BYR16P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYR16P+2)/3)*4) + nI1P = transfer(n,nI1P) +#if defined _R16P + padd = mod((BYR16P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd +#else + padd = mod((BYR16P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd +#endif + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_R16 + + pure subroutine b64_encode_R8(n, code) + !< Encode scalar number to base64 (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=1._R8P, code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAAAA8D8= <<< + real(R8P), intent(in) :: n !< Number to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + + allocate(nI1P(1:((BYR8P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYR8P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((BYR8P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_R8 + + pure subroutine b64_encode_R4(n, code) + !< Encode scalar number to base64 (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=0._R4P, code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAA== <<< + real(R4P), intent(in) :: n !< Number to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + + allocate(nI1P(1:((BYR4P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYR4P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((BYR4P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_R4 + + pure subroutine b64_encode_I8(n, code) + !< Encode scalar number to base64 (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=23_I8P, code=code64) + !< print "(A)", code64 + !<``` + !=> FwAAAAAAAAA= <<< + integer(I8P), intent(in) :: n !< Number to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + + allocate(nI1P(1:((BYI8P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYI8P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I8 + + pure subroutine b64_encode_I4(n, code) + !< Encode scalar number to base64 (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=2023_I4P, code=code64) + !< print "(A)", code64 + !<``` + !=> 5wcAAA== <<< + integer(I4P), intent(in) :: n !< Number to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + + allocate(nI1P(1:((BYI4P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYI4P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((BYI4P),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I4 + + pure subroutine b64_encode_I2(n, code) + !< Encode scalar number to base64 (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=-203_I2P, code=code64) + !< print "(A)", code64 + !<``` + !=> Nf8= <<< + integer(I2P), intent(in) :: n !< Number to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + + allocate(nI1P(1:((BYI2P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYI2P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((BYI2P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I2 + + pure subroutine b64_encode_I1(n, code) + !< Encode scalar number to base64 (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=120_I1P, code=code64) + !< print "(A)", code64 + !<``` + !=> eA== <<< + integer(I1P), intent(in) :: n !< Number to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + + allocate(nI1P(1:((BYI1P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYI1P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((BYI1P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I1 + + pure subroutine b64_encode_string(s, code) + !< Encode scalar string to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(s='hello', code=code64) + !< print "(A)", code64 + !<``` + !=> aGVsbG8= <<< + character(*), intent(in) :: s !< String to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I4P) :: BYCHS !< Bytes of character string. + + BYCHS = byte_size(s) + allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYCHS+2)/3)*4) + nI1P = transfer(s,nI1P) + padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_string + + pure subroutine b64_encode_R16_a(n, code) + !< Encode array numbers to base64 (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[121._R16P,2.32_R16P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAABAXkCPwvUoXI8CQA== <<< + real(R16P), intent(in) :: n(1:) !< Array of numbers to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I8P) :: ns !< Size of n. + + ns = size(n,dim=1) + allocate(nI1P(1:((ns*BYR16P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((ns*BYR16P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((ns*BYR16P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_R16_a + + pure subroutine b64_encode_R8_a(n, code) + !< Encode array numbers to base64 (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[1._R8P,2._R8P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAAAA8D8AAAAAAAAAQA== <<< + real(R8P), intent(in) :: n(1:) !< Array of numbers to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I8P) :: ns !< Size of n. + + ns = size(n,dim=1) + allocate(nI1P(1:((ns*BYR8P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((ns*BYR8P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((ns*BYR8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_R8_a + + pure subroutine b64_encode_R4_a(n, code) + !< Encode array numbers to base64 (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[0._R4P,-32.12_R4P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAOF6AMI= <<< + real(R4P), intent(in) :: n(1:) !< Array of numbers to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I8P) :: ns !< Size of n. + + ns = size(n,dim=1) + allocate(nI1P(1:((ns*BYR4P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((ns*BYR4P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((ns*BYR4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_R4_a + + pure subroutine b64_encode_I8_a(n, code) + !< Encode array numbers to base64 (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[23_I8P,324_I8P,25456656_I8P,2_I8P], code=code64) + !< print "(A)", code64 + !<``` + !=> FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA= <<< + integer(I8P), intent(in) :: n(1:) !< Array of numbers to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I8P) :: ns !< Size of n. + + ns = size(n,dim=1) + allocate(nI1P(1:((ns*BYI8P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((ns*BYI8P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((ns*BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I8_a + + pure subroutine b64_encode_I4_a(n, code) + !< Encode array numbers to base64 (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[2023_I4P,-24_I4P], code=code64) + !< print "(A)", code64 + !<``` + !=> 5wcAAOj///8= <<< + integer(I4P), intent(in) :: n(1:) !< Array of numbers to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I8P) :: ns !< Size of n. + + ns = size(n,dim=1) + allocate(nI1P(1:((ns*BYI4P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((ns*BYI4P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((ns*BYI4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I4_a + + pure subroutine b64_encode_I2_a(n, code) + !< Encode array numbers to base64 (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[-203_I2P,-10_I2P], code=code64) + !< print "(A)", code64 + !<``` + !=> Nf/2/w== <<< + integer(I2P), intent(in) :: n(1:) !< Array of numbers to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I8P) :: ns !< Size of n. + + ns = size(n,dim=1) + allocate(nI1P(1:((ns*BYI2P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((ns*BYI2P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((ns*BYI2P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I2_a + + pure subroutine b64_encode_I1_a(n, code) + !< Encode array numbers to base64 (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[120_I1P,-1_I1P], code=code64) + !< print "(A)", code64 + !<``` + !=> eP8= <<< + integer(I1P), intent(in) :: n(1:) !< Array of numbers to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded array. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I8P) :: ns !< Size of n. + + ns = size(n,dim=1) + allocate(nI1P(1:((ns*BYI1P+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((ns*BYI1P+2)/3)*4) + nI1P = transfer(n,nI1P) + padd = mod((ns*BYI1P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_I1_a + + pure subroutine b64_encode_string_a(s, code) + !< Encode array string to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(s=['hello','world'], code=code64) + !< print "(A)", code64 + !<``` + !=> aGVsbG93b3JsZA== <<< + character(*), intent(in) :: s(1:) !< String to be encoded. + character(len=:), allocatable, intent(out) :: code !< Encoded scalar. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + integer(I4P) :: padd !< Number of padding characters ('='). + integer(I4P) :: BYCHS !< Bytes of character string. + + BYCHS = byte_size(s(1))*size(s,dim=1) + allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P + code = repeat(' ',((BYCHS+2)/3)*4) + nI1P = transfer(s,nI1P) + padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd + call encode_bits(bits=nI1P,padd=padd,code=code) + endsubroutine b64_encode_string_a + + elemental subroutine b64_decode_R16(code, n) + !< Decode a base64 code into a scalar number (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R16P) :: scalar_R16 + !< call b64_decode(code='CKwcWmTHYEA=',n=scalar_R16) + !< print "(L1)", scalar_R16==134.231_R16P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + real(R16P), intent(out) :: n !< Number to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:BYR16P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_R16 + + elemental subroutine b64_decode_R8(code, n) + !< Decode a base64 code into a scalar number (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: scalar_R8 + !< call b64_decode(code='AAAAAAAA8D8=',n=scalar_R8) + !< print "(L1)", scalar_R8==1._R8P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + real(R8P), intent(out) :: n !< Number to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:BYR8P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_R8 + + elemental subroutine b64_decode_R4(code, n) + !< Decode a base64 code into a scalar number (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: scalar_R4 + !< call b64_decode(code='AAAAAA==',n=scalar_R4) + !< print "(L1)", scalar_R4==0._R4P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + real(R4P), intent(out) :: n !< Number to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:BYR4P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_R4 + + elemental subroutine b64_decode_I8(code, n) + !< Decode a base64 code into a scalar number (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: scalar_I8 + !< call b64_decode(code='FwAAAAAAAAA=',n=scalar_I8) + !< print "(L1)", scalar_I8==23_I8P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + integer(I8P), intent(out) :: n !< Number to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:BYI8P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I8 + + elemental subroutine b64_decode_I4(code, n) + !< Decode a base64 code into a scalar number (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: scalar_I4 + !< call b64_decode(code='5wcAAA==',n=scalar_I4) + !< print "(L1)", scalar_I4==2023_I4P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + integer(I4P), intent(out) :: n !< Number to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:BYI4P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I4 + + elemental subroutine b64_decode_I2(code, n) + !< Decode a base64 code into a scalar number (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: scalar_I2 + !< call b64_decode(code='Nf8=',n=scalar_I2) + !< print "(L1)", scalar_I2==-203_I2P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + integer(I2P), intent(out) :: n !< Number to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:BYI2P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I2 + + elemental subroutine b64_decode_I1(code, n) + !< Decode a base64 code into a scalar number (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: scalar_I1 + !< call b64_decode(code='eA==',n=scalar_I1) + !< print "(L1)", scalar_I1==120_I1P + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + integer(I1P), intent(out) :: n !< Number to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:BYI1P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I1 + + elemental subroutine b64_decode_string(code, s) + !< Decode a base64 code into a scalar string. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(:), allocatable :: code64 + !< code64 = repeat(' ',5) + !< call b64_decode(code='aGVsbG8=',s=code64) + !< print "(L1)", code64=='hello' + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + character(*), intent(out) :: s !< String to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:byte_size(s))) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + s = transfer(nI1P,s) + endsubroutine b64_decode_string + + pure subroutine b64_decode_R16_a(code, n) + !< Decode a base64 code into an array numbers (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R16P) :: array_R16(1:2) + !< call b64_decode(code='AAAAAABAXkCPwvUoXI8CQA==',n=array_R16) + !< print "(L1)", str(n=array_R16)==str(n=[121._R16P,2.32_R16P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + real(R16P), intent(out) :: n(1:) !< Array of numbers to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:size(n,dim=1)*BYR16P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_R16_a + + pure subroutine b64_decode_R8_a(code, n) + !< Decode a base64 code into an array numbers (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: array_R8(1:2) + !< call b64_decode(code='AAAAAAAA8D8AAAAAAAAAQA==',n=array_R8) + !< print "(L1)", str(n=array_R8)==str(n=[1._R8P,2._R8P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + real(R8P), intent(out) :: n(1:) !< Array of numbers to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:size(n,dim=1)*BYR8P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_R8_a + + pure subroutine b64_decode_R4_a(code, n) + !< Decode a base64 code into an array numbers (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: array_R4(1:2) + !< call b64_decode(code='AAAAAOF6AMI=',n=array_R4) + !< print "(L1)", str(n=array_R4)==str(n=[0._R4P,-32.12_R4P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + real(R4P), intent(out) :: n(1:) !< Array of numbers to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:size(n,dim=1)*BYR4P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_R4_a + + pure subroutine b64_decode_I8_a(code, n) + !< Decode a base64 code into an array numbers (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: array_I8(1:4) + !< call b64_decode(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=',n=array_I8) + !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + integer(I8P), intent(out) :: n(1:) !< Array of numbers to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:size(n,dim=1)*BYI8P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I8_a + + pure subroutine b64_decode_I4_a(code, n) + !< Decode a base64 code into an array numbers (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: array_I4(1:2) + !< call b64_decode(code='5wcAAOj///8=',n=array_I4) + !< print "(L1)", str(n=array_I4)==str(n=[2023_I4P,-24_I4P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + integer(I4P), intent(out) :: n(1:) !< Array of numbers to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:size(n,dim=1)*BYI4P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I4_a + + pure subroutine b64_decode_I2_a(code, n) + !< Decode a base64 code into an array numbers (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: array_I2(1:2) + !< call b64_decode(code='Nf/2/w==',n=array_I2) + !< print "(L1)", str(n=array_I2)==str(n=[-203_I2P,-10_I2P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + integer(I2P), intent(out) :: n(1:) !< Array of numbers to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:size(n,dim=1)*BYI2P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I2_a + + pure subroutine b64_decode_I1_a(code, n) + !< Decode a base64 code into an array numbers (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: array_I1(1:2) + !< call b64_decode(code='eP8=',n=array_I1) + !< print "(L1)", str(n=array_I1)==str(n=[120_I1P,-1_I1P]) + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded array. + integer(I1P), intent(out) :: n(1:) !< Array of numbers to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:size(n,dim=1)*BYI1P)) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + n = transfer(nI1P,n) + endsubroutine b64_decode_I1_a + + pure subroutine b64_decode_string_a(code, s) + !< Decode a base64 code into an array of strings. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(5) :: array_s(1:2) + !< call b64_decode(code='aGVsbG93b3JsZA==',s=array_s) + !< print "(L1)", array_s(1)//array_s(2)=='helloworld' + !<``` + !=> T <<< + character(*), intent(in) :: code !< Encoded scalar. + character(*), intent(out) :: s(1:) !< String to be decoded. + integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. + + allocate(nI1P(1:byte_size(s(1))*size(s,dim=1))) ; nI1P = 0_I1P + call decode_bits(code=code,bits=nI1P) + s = transfer(nI1P,s) + endsubroutine b64_decode_string_a +endmodule befor64 diff --git a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 new file mode 100644 index 000000000..29fddacf8 --- /dev/null +++ b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 @@ -0,0 +1,848 @@ +!< KISS library for packing heterogeneous data into single (homogeneous) packed one. +! +module befor64_pack_data_m +!< KISS library for packing heterogeneous data into single (homogeneous) packed one. +use penf + +implicit none +private +public :: pack_data + +interface pack_data + !< Pack different kinds of data into single I1P array. + !< + !< This is useful for encoding different (heterogeneous) kinds variables into a single (homogeneous) stream of bits. + !< @note This procedure exploits the `transfer` builtin function, that from the standard (2003+) is defined as + !< `TRANSFER(SOURCE, MOLD [, SIZE])`. Data object having a physical representation identical to that of `SOURCE` but with the type + !< and type parameters of `MOLD`. The result is of the same type and type parameters as `MOLD`. + !< If `MOLD` is an array and `SIZE` is absent, the result is an array and of rank one. Its size is as small as possible such + !< that its physical representation is not shorter than that of `SOURCE`. + !< + !< Presently, the following combinations are available: + !< + !<* [ ] Arrays-Arrays: + !< * [X] real(any)-real(any); + !< * [X] real(any)-integer(any); + !< * [X] integer(any)-integer(any); + !< * [X] integer(any)-real(any); + !< * [ ] real(any)-character; + !< * [ ] character-real(any); + !< * [ ] integer(any)-character; + !< * [ ] character-integer(any); + !<* [ ] Scalars-Scalars: + !< * [ ] real(any)-real(any); + !< * [ ] real(any)-integer(any); + !< * [ ] integer(any)-integer(any); + !< * [ ] integer(any)-real(any); + !< * [ ] real(any)-character; + !< * [ ] character-real(any); + !< * [ ] integer(any)-character; + !< * [ ] character-integer(any); + !< + !<### Examples of usage + !< + !<#### Packing two real arrays, one with kind R8P and one with R4P + !<```ortran + ! 63 <<< + real(R8P), intent(in) :: a1(1:) !< Firs data stream. + real(R4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R8_R4 + + pure subroutine pack_data_R8_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + real(R8P), intent(in) :: a1(1:) !< First data stream. + integer(I8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R8_I8 + + pure subroutine pack_data_R8_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + real(R8P), intent(in) :: a1(1:) !< First data stream. + integer(I4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R8_I4 + + pure subroutine pack_data_R8_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + real(R8P), intent(in) :: a1(1:) !< First data stream. + integer(I2P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R8_I2 + + pure subroutine pack_data_R8_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + real(R8P), intent(in) :: a1(1:) !< First data stream. + integer(I1P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R8_I1 + + pure subroutine pack_data_R4_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + real(R4P), intent(in) :: a1(1:) !< Firs data stream. + real(R8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R4_R8 + + pure subroutine pack_data_R4_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + real(R4P), intent(in) :: a1(1:) !< First data stream. + integer(I8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R4_I8 + + pure subroutine pack_data_R4_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + real(R4P), intent(in) :: a1(1:) !< First data stream. + integer(I4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R4_I4 + + pure subroutine pack_data_R4_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + real(R4P), intent(in) :: a1(1:) !< First data stream. + integer(I2P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R4_I2 + + pure subroutine pack_data_R4_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + real(R4P), intent(in) :: a1(1:) !< First data stream. + integer(I1P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_R4_I1 + + pure subroutine pack_data_I8_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I8P), intent(in) :: a1(1:) !< First data stream. + real(R8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I8_R8 + + pure subroutine pack_data_I8_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I8P), intent(in) :: a1(1:) !< First data stream. + real(R4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I8_R4 + + pure subroutine pack_data_I8_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + integer(I8P), intent(in) :: a1(1:) !< First data stream. + integer(I4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I8_I4 + + pure subroutine pack_data_I8_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + integer(I8P), intent(in) :: a1(1:) !< First data stream. + integer(I2P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I8_I2 + + pure subroutine pack_data_I8_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + integer(I8P), intent(in) :: a1(1:) !< First data stream. + integer(I1P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I8_I1 + + pure subroutine pack_data_I4_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I4P), intent(in) :: a1(1:) !< First data stream. + real(R8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I4_R8 + + pure subroutine pack_data_I4_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I4P), intent(in) :: a1(1:) !< First data stream. + real(R4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I4_R4 + + pure subroutine pack_data_I4_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + integer(I4P), intent(in) :: a1(1:) !< First data stream. + integer(I8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I4_I8 + + pure subroutine pack_data_I4_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + integer(I4P), intent(in) :: a1(1:) !< First data stream. + integer(I2P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I4_I2 + + pure subroutine pack_data_I4_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + integer(I4P), intent(in) :: a1(1:) !< First data stream. + integer(I1P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I4_I1 + + pure subroutine pack_data_I2_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I2P), intent(in) :: a1(1:) !< First data stream. + real(R8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I2_R8 + + pure subroutine pack_data_I2_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I2P), intent(in) :: a1(1:) !< First data stream. + real(R4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I2_R4 + + pure subroutine pack_data_I2_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(3) + !<``` + !=> 1 <<< + integer(I2P), intent(in) :: a1(1:) !< First data stream. + integer(I8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I2_I8 + + pure subroutine pack_data_I2_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(3) + !<``` + !=> 1 <<< + integer(I2P), intent(in) :: a1(1:) !< First data stream. + integer(I4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I2_I4 + + pure subroutine pack_data_I2_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(3) + !<``` + !=> 1 <<< + integer(I2P), intent(in) :: a1(1:) !< First data stream. + integer(I1P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I2_I1 + + pure subroutine pack_data_I1_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I1P), intent(in) :: a1(1:) !< First data stream. + real(R8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I1_R8 + + pure subroutine pack_data_I1_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + integer(I1P), intent(in) :: a1(1:) !< First data stream. + real(R4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I1_R4 + + pure subroutine pack_data_I1_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(2) + !<``` + !=> 1 <<< + integer(I1P), intent(in) :: a1(1:) !< First data stream. + integer(I8P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I1_I8 + + pure subroutine pack_data_I1_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(2) + !<``` + !=> 1 <<< + integer(I1P), intent(in) :: a1(1:) !< First data stream. + integer(I4P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I1_I4 + + pure subroutine pack_data_I1_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(2) + !<``` + !=> 1 <<< + integer(I1P), intent(in) :: a1(1:) !< First data stream. + integer(I2P), intent(in) :: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. + + p1 = transfer(a1,p1) + p2 = transfer(a2,p2) + packed = [p1,p2] + endsubroutine pack_data_I1_I2 +endmodule befor64_pack_data_m diff --git a/src/modules/BoundingBox/CMakeLists.txt b/src/modules/BoundingBox/CMakeLists.txt new file mode 100644 index 000000000..d57a7c279 --- /dev/null +++ b/src/modules/BoundingBox/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/BoundingBox_Method.F90 +) \ No newline at end of file diff --git a/src/modules/BoundingBox/src/BoundingBox_Method.F90 b/src/modules/BoundingBox/src/BoundingBox_Method.F90 new file mode 100644 index 000000000..0df44a5c4 --- /dev/null +++ b/src/modules/BoundingBox/src/BoundingBox_Method.F90 @@ -0,0 +1,934 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 23 Feb 2021 +! summary: [[BoundingBox_Method]] module consists method for[[BoundingBox_]] +! +!# Introduction +! This module consists method for data type [[BoundingBox_]]. These methods +! are included in following submoudles: +!- `BoundingBox_Method@Constructor` + +MODULE BoundingBox_Method +USE GlobalData, ONLY: DFP, I4B, LGT, stdout +USE BaseType, ONLY: BoundingBox_ +USE tomlf, ONLY: toml_table +IMPLICIT NONE + +PUBLIC :: OPERATOR(.Xmin.) +PUBLIC :: OPERATOR(.Xmax.) +PUBLIC :: OPERATOR(.Ymin.) +PUBLIC :: OPERATOR(.Ymax.) +PUBLIC :: OPERATOR(.Zmin.) +PUBLIC :: OPERATOR(.Zmax.) +PUBLIC :: OPERATOR(.isIntersect.) +PUBLIC :: OPERATOR(.Intersection.) +PUBLIC :: OPERATOR(.UNION.) +PUBLIC :: OPERATOR(.Center.) +PUBLIC :: OPERATOR(.isInside.) +PUBLIC :: OPERATOR(.Nptrs.) + +PUBLIC :: ASSIGNMENT(=) + +PUBLIC :: Initiate +PUBLIC :: BoundingBox +PUBLIC :: BoundingBox_Pointer +PUBLIC :: DEALLOCATE +PUBLIC :: Display + +PUBLIC :: isIntersectInX +PUBLIC :: isIntersectInY +PUBLIC :: isIntersectInZ +PUBLIC :: isIntersect +PUBLIC :: isEmpty +PUBLIC :: Intersection +PUBLIC :: Union +PUBLIC :: Center +PUBLIC :: isInside +PUBLIC :: GetDiameter +PUBLIC :: GetRadius +PUBLIC :: GetDiameterSqr +PUBLIC :: GetRadiusSqr +PUBLIC :: GetValue +PUBLIC :: Append + +PRIVATE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function Initiatea an instance of [[BoundingBox_]]. +! +!# Introduction +! This function Initiates an instance of [[BoundingBox_]]. +!- `NSD` is the spatial dimension +!- `lim` is vector of real numbers (length=6) +!- `lim(1)` => xmin +!- `lim(2)` => ymin +!- `lim(3)` => zmin +!- `lim(4)` => xmax +!- `lim(5)` => ymax +!- `lim(6)` => zmax +! +!### Usage +! +!```fortran +! subroutine test +! type(BoundingBox_) :: obj +! call Initiate( obj, nsd = 2, lim=[0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0. +! 0_DFP, 0.0_DFP] ) +! call display( obj, msg="test1" ) +! end subroutine test +!``` + +INTERFACE Initiate + MODULE PURE SUBROUTINE Initiate_1(obj, nsd, lim) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + !! Instance of bounding box + INTEGER(I4B), INTENT(IN) :: NSD + !! Spatial dimension + REAL(DFP), INTENT(IN) :: lim(6) + !! Extent of bounding box + END SUBROUTINE Initiate_1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Initiate the instance of [[BoundingBox_]] from the another box +! +!# Introduction +! +! This subroutine Initiate the instance of [[BoundingBox_]] from another +! instance. It is basically a copy command. +! +!### Usage +! +!```fortran +! subroutine test2 +! type(BoundingBox_) :: obj, obj2 +! call Initiate( obj, 2, [0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. +! 0_DFP] ) +! call Initiate(obj2, obj) +! call display( obj2, msg="test2") +! end subroutine test2 +!``` + +INTERFACE Initiate + MODULE PURE SUBROUTINE Initiate_2(obj, Anotherobj) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + TYPE(BoundingBox_), INTENT(IN) :: Anotherobj + END SUBROUTINE Initiate_2 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE Initiate_2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Initiate the instance of [[BoundingBox_]] from the another box + +INTERFACE Initiate + MODULE PURE SUBROUTINE Initiate_3(obj, Anotherobj) + TYPE(BoundingBox_), INTENT(INOUT) :: obj(:) + TYPE(BoundingBox_), INTENT(IN) :: Anotherobj(:) + END SUBROUTINE Initiate_3 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE Initiate_3 +END INTERFACE + +!---------------------------------------------------------------------------- +! Append@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Initiate the instance of [[BoundingBox_]] from the another box + +INTERFACE Append + MODULE PURE SUBROUTINE Append_1(obj, VALUE) + TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + TYPE(BoundingBox_), INTENT(IN) :: VALUE(:) + END SUBROUTINE Append_1 +END INTERFACE Append + +!---------------------------------------------------------------------------- +! BoundingBox@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Function to create [[BoundingBox_]] instance +! +!# Introduction +! This function Initiates an instance of [[BoundingBox_]]. +!- `NSD` is the spatial dimension +!- `lim` is vector of real numbers (length=6) +!- `lim(1)` => xmin +!- `lim(2)` => ymin +!- `lim(3)` => zmin +!- `lim(4)` => xmax +!- `lim(5)` => ymax +!- `lim(6)` => zmax +! +!### Usage +!```fortran +! subroutine test3 +! type(BoundingBox_) :: obj +! obj = BoundingBox( nsd = 2, lim=[0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0. +! 0_DFP, 0.0_DFP] ) +! call display( obj, msg="test1" ) +! end subroutine test3 +!``` + +INTERFACE BoundingBox + MODULE PURE FUNCTION Constructor1(nsd, lim) RESULT(Ans) + TYPE(BoundingBox_) :: Ans + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN) :: lim(6) + END FUNCTION Constructor1 +END INTERFACE BoundingBox + +!---------------------------------------------------------------------------- +! BoundingBox@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function creates an instance of [[BoundingBox_]] +! +!# Introduction +!This function creates an intance of [[BoundingBox_]]. +! +!### Usage +!```fortran +! subroutine test4 +! type(BoundingBox_) :: obj, obj2 +! call Initiate( obj, 2, [0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. +! 0_DFP] ) +! obj2 = BoundingBox(obj) +! call display( obj2, msg="test2") +! end subroutine test4 +!``` + +INTERFACE BoundingBox + MODULE PURE FUNCTION Constructor2(Anotherobj) RESULT(Ans) + TYPE(BoundingBox_) :: Ans + TYPE(BoundingBox_), INTENT(IN) :: Anotherobj + END FUNCTION Constructor2 +END INTERFACE BoundingBox + +!---------------------------------------------------------------------------- +! BoundingBox +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function creates an instance of [[BoundingBox_]] +! +!# Introduction +! This function creates an instance of [[BoundingBox_]]. In this function NSD +! is determined from SIZE(xij, 1). +! +!### Usage +!```fortran +! subroutine test5 +! type(BoundingBox_) :: obj +! obj = boundingBox(RESHAPE([0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. +! 0_DFP], [2,3])) +! call display(obj, "test5") +! end subroutine test5 +!``` + +INTERFACE BoundingBox + MODULE PURE FUNCTION Constructor3(xij) RESULT(Ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Nodal coordinates xij( 1:nsd, 1:tnodes ) + TYPE(BoundingBox_) :: Ans + !! + END FUNCTION Constructor3 +END INTERFACE BoundingBox + +!---------------------------------------------------------------------------- +! BoundingBox_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the pointer to [[BoundingBox_]] instance +! +!# Introduction +! +! This function returns the pointer to [[BoundingBox_]] instance. +!- `NSD` is the spatial dimension +!- `lim` is vector of real numbers (length=6) +!- `lim(1)` => xmin +!- `lim(2)` => ymin +!- `lim(3)` => zmin +!- `lim(4)` => xmax +!- `lim(5)` => ymax +!- `lim(6)` => zmax +! +!### Usage +! +!```fortran +! subroutine test6 +! type(BoundingBox_) :: obj +! type(BoundingBox_), pointer :: obj2 +! call Initiate( obj, 2, [0.0_DFP, 1.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0. +! 0_DFP] ) +! obj2 => BoundingBox_Pointer(obj) +! call display( obj2, msg="test6") +! end subroutine test6 +!``` + +INTERFACE BoundingBox_Pointer + MODULE FUNCTION Constructor_1(nsd, lim) RESULT(Ans) + TYPE(BoundingBox_), POINTER :: Ans + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN) :: lim(6) + END FUNCTION Constructor_1 +END INTERFACE BoundingBox_Pointer + +!---------------------------------------------------------------------------- +! BoundingBox_Pointer@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the pointer to an instance of [[BoundingBox_]] +! +!# Introduction +! This function returns the pointer to an instance of [[BoundingBox_]] by +! copying contents from `Anotherobj` +! +!### Usage +!```fortran +! subroutine test7 +! type(BoundingBox_), pointer :: obj +! obj => BoundingBox_Pointer(nsd=3, lim=[0.0_DFP, 1.0_DFP, 0.0_DFP, 1. +! 0_DFP, 0.0_DFP, 0.0_DFP]) +! call display(obj, "test7") +! end subroutine test7 +!``` + +INTERFACE BoundingBox_Pointer + MODULE FUNCTION Constructor_2(Anotherobj) RESULT(Ans) + TYPE(BoundingBox_), POINTER :: Ans + TYPE(BoundingBox_), INTENT(IN) :: Anotherobj + END FUNCTION Constructor_2 +END INTERFACE BoundingBox_Pointer + +!---------------------------------------------------------------------------- +! Deallocate@Constructor +!---------------------------------------------------------------------------- + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE BB_Deallocate(obj) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + END SUBROUTINE BB_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Deallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-11-15 +! summary: Deallocate vector of bounding box + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE BB_Deallocate2(obj) + TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE BB_Deallocate2 +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Display@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine displays the content of [[BoundingBox_]] + +INTERFACE Display + MODULE SUBROUTINE display_obj(obj, msg, unitno) + TYPE(BoundingBox_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitNo + END SUBROUTINE display_obj +END INTERFACE Display + +!---------------------------------------------------------------------------- +! setXmin@setMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the Xmin in bounding box + +INTERFACE + MODULE PURE SUBROUTINE setXmin(obj, Val) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + END SUBROUTINE setXmin +END INTERFACE + +!---------------------------------------------------------------------------- +! setXmax@setMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the Xmax in bounding box + +INTERFACE + MODULE PURE SUBROUTINE setXmax(obj, Val) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + END SUBROUTINE setXmax +END INTERFACE + +!---------------------------------------------------------------------------- +! setYmin@setMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the Ymin in bounding box + +INTERFACE + MODULE PURE SUBROUTINE setYmin(obj, Val) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + END SUBROUTINE setYmin +END INTERFACE + +!---------------------------------------------------------------------------- +! setYmax@setMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the Ymax of bounding box + +INTERFACE + MODULE PURE SUBROUTINE setYmax(obj, Val) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + END SUBROUTINE setYmax +END INTERFACE + +!---------------------------------------------------------------------------- +! setZmin@setMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the Zmin of bounding box + +INTERFACE + MODULE PURE SUBROUTINE setZmin(obj, Val) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + END SUBROUTINE setZmin +END INTERFACE + +!---------------------------------------------------------------------------- +! setZmax@setMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the Zmax of bounding box + +INTERFACE + MODULE PURE SUBROUTINE setZmax(obj, Val) + TYPE(BoundingBox_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + END SUBROUTINE setZmax +END INTERFACE + +!---------------------------------------------------------------------------- +! getXmin@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the xmin +! +!### Usage +! +!```fortran +! xmin = .xmin. obj +!``` + +INTERFACE OPERATOR(.Xmin.) + MODULE PURE FUNCTION getXmin(obj) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: Ans + END FUNCTION getXmin +END INTERFACE + +!---------------------------------------------------------------------------- +! getXmax@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the xmax +! +!### Usage +! +!```fortran +! xmax = .xmax. obj +!``` + +INTERFACE OPERATOR(.Xmax.) + MODULE PURE FUNCTION getXmax(obj) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: Ans + END FUNCTION getXmax +END INTERFACE + +!---------------------------------------------------------------------------- +! getYmin@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the ymin +! +!### Usage +! +!```fortran +! ymin = .ymin. obj +!``` + +INTERFACE OPERATOR(.Ymin.) + MODULE PURE FUNCTION getYmin(obj) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: Ans + END FUNCTION getYmin +END INTERFACE + +!---------------------------------------------------------------------------- +! getYmax@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the ymax +! +!### Usage +! +!```fortran +! ymax = .ymax. obj +!``` + +INTERFACE OPERATOR(.Ymax.) + MODULE PURE FUNCTION getYmax(obj) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: Ans + END FUNCTION getYmax +END INTERFACE + +!---------------------------------------------------------------------------- +! getZmin@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the zmin +! +!### Usage +! +!```fortran +! zmin = .zmin. obj +!``` + +INTERFACE OPERATOR(.Zmin.) + MODULE PURE FUNCTION getZmin(obj) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: Ans + END FUNCTION getZmin +END INTERFACE + +!---------------------------------------------------------------------------- +! getZmax@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the zmax +! +!### Usage +! +!```fortran +! zmax = .zmax. obj +!``` + +INTERFACE OPERATOR(.Zmax.) + MODULE PURE FUNCTION getZmax(obj) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: Ans + END FUNCTION getZmax +END INTERFACE + +!---------------------------------------------------------------------------- +! isIntersectInX@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function checks if two bounding boxes interesect in x direction +! +!@todo +!### Usage +!@endtodo + +INTERFACE isIntersectInX + MODULE PURE FUNCTION is_intersect_in_X(obj, obj2) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 + LOGICAL(LGT) :: Ans + END FUNCTION is_intersect_in_X +END INTERFACE isIntersectInX + +!---------------------------------------------------------------------------- +! isIntersectInY@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function checks if two bounding boxes interesect in y direction +! +!@todo +!### Usage +!@endtodo + +INTERFACE isIntersectInY + MODULE PURE FUNCTION is_intersect_in_Y(obj, obj2) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 + LOGICAL(LGT) :: Ans + END FUNCTION is_intersect_in_Y +END INTERFACE isIntersectInY + +!---------------------------------------------------------------------------- +! isIntersectInZ@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function checks if two bounding boxes interesect in z direction +! +!@todo +!### Usage +!@endtodo + +INTERFACE isIntersectInZ + MODULE PURE FUNCTION is_intersect_in_Z(obj, obj2) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 + LOGICAL(LGT) :: Ans + END FUNCTION is_intersect_in_Z +END INTERFACE isIntersectInZ + +!---------------------------------------------------------------------------- +! isIntersect@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-12 +! summary: This function checks if two bounding boxes interesect each other + +INTERFACE OPERATOR(.isIntersect.) + MODULE PURE FUNCTION is_intersect(obj, obj2) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 + LOGICAL(LGT) :: Ans + END FUNCTION is_intersect +END INTERFACE + +INTERFACE isIntersect + MODULE PROCEDURE is_intersect +END INTERFACE isIntersect + +!---------------------------------------------------------------------------- +! isEmpty@getMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-11 +! summary: Checks if bounding box is empty + +INTERFACE isEmpty + MODULE PURE FUNCTION bbox_isEmpty(obj) RESULT(ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION bbox_isEmpty +END INTERFACE isEmpty + +!---------------------------------------------------------------------------- +! getIntersection@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the intersection bounding +! box of two bounding box +! +!# Introduction +! This function returns the bounding box which is formed by the +! intersection of two bounding box +! +!@todo +![] add usage +!@endtodo + +INTERFACE OPERATOR(.Intersection.) + MODULE PURE FUNCTION get_intersection(obj, obj2) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 + TYPE(BoundingBox_) :: Ans + END FUNCTION get_intersection +END INTERFACE + +INTERFACE Intersection + MODULE PROCEDURE get_intersection +END INTERFACE Intersection + +!---------------------------------------------------------------------------- +! getUnion@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the union of two bounding box +! +!# Introduction +! This function returns the bounding box which is formed by the union +! of two bounding box. +! +!@todo +![] add usage +!@endtodo + +INTERFACE OPERATOR(.UNION.) + MODULE PURE FUNCTION get_Union(obj, obj2) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj, obj2 + TYPE(BoundingBox_) :: Ans + END FUNCTION get_Union +END INTERFACE + +INTERFACE Union + MODULE PROCEDURE get_Union +END INTERFACE Union + +!---------------------------------------------------------------------------- +! getCenter@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function returns the center of bounding box +! +!# Introduction +! +!This function returns the centern of bounding box. +! +!@todo +![] add usage +!@endtodo + +INTERFACE OPERATOR(.Center.) + MODULE PURE FUNCTION get_Center(obj) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: Ans(3) + END FUNCTION get_Center +END INTERFACE + +INTERFACE Center + MODULE PROCEDURE get_Center +END INTERFACE Center + +!---------------------------------------------------------------------------- +! isInside@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This function checks if a point is inside the bounding box or not +! +!# Introduction +! +! This function checks if a point is inside a bounding box or not +! +!@todo +![] add usage +!@endtodo + +INTERFACE OPERATOR(.isInside.) + MODULE PURE FUNCTION is_Inside(obj, Val) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + LOGICAL(LGT) :: Ans + END FUNCTION is_Inside +END INTERFACE + +INTERFACE isInside + MODULE PROCEDURE is_Inside +END INTERFACE isInside + +!---------------------------------------------------------------------------- +! getNptrs@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-11 +! summary: This function returns the node numbers located inside +! the bounding box +! +!# Introduction +! +! This function returns the list of node numbers which are inside +! the bounding box + +INTERFACE OPERATOR(.Nptrs.) + MODULE PURE FUNCTION get_nptrs(obj, xij) RESULT(Ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: xij(:, :) + INTEGER(I4B), ALLOCATABLE :: Ans(:) + END FUNCTION get_nptrs +END INTERFACE + +!---------------------------------------------------------------------------- +! GetDiameter@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2022 +! summary: Returns the diameter of the box + +INTERFACE GetDiameter + MODULE PURE FUNCTION bbox_GetDiameter(obj) RESULT(ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION bbox_GetDiameter +END INTERFACE GetDiameter + +!---------------------------------------------------------------------------- +! GetRadius@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-10 +! summary: Returns the Radius of the box + +INTERFACE GetRadius + MODULE PURE FUNCTION bbox_GetRadius(obj) RESULT(ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION bbox_GetRadius +END INTERFACE GetRadius + +!---------------------------------------------------------------------------- +! GetDiameterSqr@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-10 +! summary: Returns the diameter of the box + +INTERFACE GetDiameterSqr + MODULE PURE FUNCTION bbox_GetDiameterSqr(obj) RESULT(ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION bbox_GetDiameterSqr +END INTERFACE GetDiameterSqr + +!---------------------------------------------------------------------------- +! GetRadiusSqr@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-10 +! summary: Returns the Radius of the box + +INTERFACE GetRadiusSqr + MODULE PURE FUNCTION bbox_GetRadiusSqr(obj) RESULT(ans) + TYPE(BoundingBox_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION bbox_GetRadiusSqr +END INTERFACE GetRadiusSqr + +!---------------------------------------------------------------------------- +! GetValue@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-11-15 +! summary: GetValue Integer Vectors + +INTERFACE GetValue + MODULE SUBROUTINE toml_get_bbox_r0(table, key, VALUE, origin, stat, & + & isFound) + TYPE(toml_table), INTENT(INOUT) :: table + CHARACTER(*), INTENT(IN) :: key + !! We dont need table here, so this argument is ignored. + TYPE(BoundingBox_), INTENT(INOUT) :: VALUE + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: origin + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: stat + LOGICAL(LGT), OPTIONAL, INTENT(INOUT) :: isFound + END SUBROUTINE toml_get_bbox_r0 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-11-15 +! summary: GetValue Integer Vectors + +INTERFACE GetValue + MODULE SUBROUTINE toml_get_bbox_r1(table, key, VALUE, origin, stat, & + & isFound) + TYPE(toml_table), INTENT(INOUT) :: table + CHARACTER(*), INTENT(IN) :: key + TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: origin + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: stat + LOGICAL(LGT), OPTIONAL, INTENT(INOUT) :: isFound + END SUBROUTINE toml_get_bbox_r1 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE BoundingBox_Method diff --git a/src/modules/CInterface/CMakeLists.txt b/src/modules/CInterface/CMakeLists.txt new file mode 100644 index 000000000..ed2b030f2 --- /dev/null +++ b/src/modules/CInterface/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/CInterface.F90 +) \ No newline at end of file diff --git a/src/modules/CInterface/src/CInterface.F90 b/src/modules/CInterface/src/CInterface.F90 new file mode 100644 index 000000000..ae30ad133 --- /dev/null +++ b/src/modules/CInterface/src/CInterface.F90 @@ -0,0 +1,1214 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CInterface +USE GlobalData +USE String_Class, ONLY: String +USE, INTRINSIC :: ISO_C_BINDING, C_PTR => C_PTR, & + & C_CHAR_PTR => C_PTR, C_CONST_CHAR_PTR => C_PTR, & + & C_void_ptr => C_PTR, C_CONST_VOID_PTR => C_PTR +IMPLICIT NONE +PRIVATE + +PUBLIC :: C_CHAR_PTR, C_VOID_PTR, C_CONST_CHAR_PTR, C_CONST_VOID_PTR +PUBLIC :: CString + +INTEGER(I4B), PUBLIC, PARAMETER :: C_ENUM = C_INT + !! a C enum may not always be a standard C int +CHARACTER(1, KIND=C_CHAR), PUBLIC, PARAMETER :: NUL = C_NULL_CHAR + !! C string terminator alais using the 3-letter ASCII name. + !! The C_ prefix is not used because it is just an ASCII character. + !! In C, "char" is distinct from "signed char", unlike integers. + !! The plain "char" type is specific for text/string values, whereas + !! "signed char" should indicate 1-byte integer data. + !! Most ISO-C systems have wide chars "wchar_t", but Fortran compilers + !! have limited support for different character kinds. UTF encoding + !! adds more complexity. This should be updated as Fortran compilers + !! include support for more character types. +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED = C_INT +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_SHORT = C_SHORT +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG = C_LONG +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG_LONG = C_LONG_LONG +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_CHAR = C_SIGNED_CHAR +INTEGER(I4B), PUBLIC, PARAMETER :: C_SSIZE_T = C_SIZE_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT8_T = C_INT8_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT16_T = C_INT16_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT32_T = C_INT32_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT64_T = C_INT64_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST8_T = C_INT_LEAST8_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST16_T = C_INT_LEAST16_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST32_T = C_INT_LEAST32_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_LEAST64_T = C_INT_LEAST64_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST8_T = C_INT_FAST8_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST16_T = C_INT_FAST16_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST32_T = C_INT_FAST32_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINT_FAST64_T = C_INT_FAST64_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_UINTMAX_T = C_INTMAX_T +INTEGER(I4B), PUBLIC, PARAMETER :: C_SHORT_INT = C_SHORT +INTEGER(I4B), PUBLIC, PARAMETER :: C_LONG_INT = C_LONG +INTEGER(I4B), PUBLIC, PARAMETER :: C_LONG_LONG_INT = C_LONG_LONG +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_INT = C_UNSIGNED +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_SHORT_INT = C_SHORT +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG_INT = C_LONG +INTEGER(I4B), PUBLIC, PARAMETER :: C_UNSIGNED_LONG_LONG_INT = C_LONG_LONG + +PUBLIC :: C_MEMCPY +PUBLIC :: C_memmove +PUBLIC :: C_memset +PUBLIC :: C_memcmp +PUBLIC :: C_memchr +PUBLIC :: C_strcpy +PUBLIC :: C_strncpy +PUBLIC :: C_strcat +PUBLIC :: C_strncat +PUBLIC :: C_strcmp +PUBLIC :: C_strncmp +PUBLIC :: C_strlen +PUBLIC :: C_calloc +PUBLIC :: C_malloc +PUBLIC :: C_free +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: C_ASSOCIATED_PURE +PUBLIC :: C_F_STRING +PUBLIC :: FString +PUBLIC :: F_C_STRING +PUBLIC :: C_STRLEN_SAFE +PUBLIC :: F_C_STRING_DUP +PUBLIC :: C_STRING_VALUE +PUBLIC :: C_STRING_ALLOC +PUBLIC :: C_STRING_FREE +PUBLIC :: C_PTR_TO_INT_VEC +PUBLIC :: C_PTR_TO_Real_VEC +PUBLIC :: C2Fortran +PUBLIC :: optval_c_int +PUBLIC :: optval_c_size_t +PUBLIC :: optval_c_double +PUBLIC :: optval_c_bool + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE C_F_STRING + MODULE PROCEDURE F_string_assign_C_string + MODULE PROCEDURE C_F_STRING_CHARS +END INTERFACE C_F_STRING + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE F_string_assign_C_string +END INTERFACE ASSIGNMENT(=) + +INTERFACE FString + MODULE PROCEDURE Fstring1 +END INTERFACE FString + +INTERFACE F_C_STRING + MODULE PROCEDURE F_C_STRING_CHARS, F_C_STRING_PTR +END INTERFACE F_C_STRING + +INTERFACE C_PTR_TO_INT_VEC + MODULE PROCEDURE C_PTR_TO_Int8_VEC, C_PTR_TO_Int16_VEC, & + & C_PTR_TO_Int32_VEC, C_PTR_TO_Int64_VEC +END INTERFACE C_PTR_TO_INT_VEC + +INTERFACE C_PTR_TO_Real_VEC + MODULE PROCEDURE C_PTR_TO_Real32_VEC, C_PTR_TO_Real64_VEC +END INTERFACE C_PTR_TO_Real_VEC + +INTERFACE C2Fortran + MODULE PROCEDURE C_PTR_TO_Int8_VEC, C_PTR_TO_Int16_VEC, & + & C_PTR_TO_Int32_VEC, C_PTR_TO_Int64_VEC, C_PTR_TO_Real32_VEC, & + & C_PTR_TO_Real64_VEC, F_string_assign_C_string, & + & C_F_STRING_CHARS +END INTERFACE C2Fortran + +INTERFACE optval_c_int + MODULE PROCEDURE optval_c_int_1 +END INTERFACE optval_c_int + +INTERFACE optval_c_size_t + MODULE PROCEDURE optval_c_size_t_1, optval_c_size_t_2 +END INTERFACE optval_c_size_t + +INTERFACE optval_c_double + MODULE PROCEDURE optval_c_double_1, optval_c_double_2 +END INTERFACE optval_c_double + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. +! +!# Introduction +! +! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. +! +!### CInterface +! +!```c +! extern void *memcpy (void *dest, const void *src, size_t n); +!``` + +INTERFACE + FUNCTION C_MEMCPY(dest, src, n) RESULT(RESULT) BIND(C, name="memcpy") + IMPORT C_void_ptr, C_SIZE_T + TYPE(C_VOID_PTR) :: RESULT + TYPE(C_VOID_PTR), VALUE, INTENT(IN) :: dest + !! target=intent(out) + TYPE(C_VOID_PTR), VALUE, INTENT(IN) :: src + !! target=INTENT(IN) + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n + END FUNCTION C_MEMCPY +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Copy N bytes of SRC to DEST, guaranteeing correct behavior +! for overlapping strings. +! +!# Introduction +! Copy N bytes of SRC to DEST, guaranteeing correct behavior for +! overlapping strings. +! +!### CInterface +! +!```c +! extern void *memmove (void *dest, const void *src, size_t n) +!``` + +INTERFACE + FUNCTION C_memmove(dest, src, n) RESULT(RESULT) BIND(C, name="memmove") + IMPORT C_void_ptr, C_SIZE_T + TYPE(C_void_ptr) :: RESULT + TYPE(C_void_ptr), VALUE, INTENT(IN) :: dest ! target=intent(out) + TYPE(C_void_ptr), VALUE, INTENT(IN) :: src + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n + END FUNCTION C_memmove +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Set N bytes of S to C. +! +!# Introduction +! Set N bytes of S to C. +! +!### CInterface +! +!```c +!extern void *memset (void *s, int c, size_t n) +!``` + +INTERFACE + FUNCTION C_memset(s, c, n) RESULT(RESULT) BIND(C, name="memset") + IMPORT :: C_void_ptr, C_INT, C_SIZE_T + TYPE(C_void_ptr) :: RESULT + TYPE(C_void_ptr), VALUE, INTENT(in) :: s ! target=intent(out) + INTEGER(C_INT), VALUE, INTENT(in) :: c + INTEGER(C_SIZE_T), VALUE, INTENT(in) :: n + END FUNCTION C_memset +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Compare N bytes of S1 and S2. +! +!# Introduction +! Compare N bytes of S1 and S2. +! +!### CInterface +! +!```c +!extern int memcmp (const void *s1, const void *s2, size_t n) +!``` + +INTERFACE + PURE FUNCTION C_memcmp(s1, s2, n) RESULT(RESULT) BIND(C, name="memcmp") + IMPORT :: C_INT, C_void_ptr, C_SIZE_T + INTEGER(C_INT) :: RESULT + TYPE(C_void_ptr), VALUE, INTENT(IN) :: s1 + TYPE(C_void_ptr), VALUE, INTENT(IN) :: s2 + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n + END FUNCTION C_memcmp +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Search N bytes of S for C. +! +!# Introduction +! Search N bytes of S for C. +! +!### CInterface +! +!```c +!extern void *memchr (const void *s, int c, size_t n) +!``` + +INTERFACE + PURE FUNCTION C_memchr(s, c, n) RESULT(RESULT) BIND(C, name="memchr") + IMPORT :: C_void_ptr, C_INT, C_SIZE_T + TYPE(C_void_ptr) :: RESULT + TYPE(C_void_ptr), VALUE, INTENT(IN) :: s + INTEGER(C_INT), VALUE, INTENT(IN) :: c + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n + END FUNCTION C_memchr +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Copy SRC to DEST. +! +!# Introduction +! Copy SRC to DEST. +! +!### CInterface +! +!```c +!extern char *strcpy (char *dest, const char *src) +!``` + +INTERFACE + FUNCTION C_strcpy(dest, src) RESULT(RESULT) BIND(C, name="strcpy") + IMPORT :: C_CHAR_PTR, C_SIZE_T + TYPE(C_CHAR_PTR) :: RESULT + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: dest ! target=intent(out) + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: src + END FUNCTION C_strcpy +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Copy no more than N characters of SRC to DEST. +! +!# Introduction +! Copy no more than N characters of SRC to DEST. +! +! +!### CInterface +! +!```c +!extern char *strncpy (char *dest, const char *src, size_t n) +!``` + +INTERFACE + FUNCTION C_strncpy(dest, src, n) RESULT(RESULT) BIND(C, name="strncpy") + IMPORT C_CHAR_PTR, C_SIZE_T + TYPE(C_CHAR_PTR) :: RESULT + TYPE(C_CHAR_PTR), VALUE, INTENT(in) :: dest ! target=intent(out) + TYPE(C_CHAR_PTR), VALUE, INTENT(in) :: src + INTEGER(C_SIZE_T), VALUE, INTENT(in) :: n + END FUNCTION C_strncpy +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Append SRC onto DEST. +! +!# Introduction +! Append SRC onto DEST. +! +! +!### CInterface +! +!```c +!extern char *strcat (char *dest, const char *src) +!``` + +INTERFACE + FUNCTION C_strcat(dest, src) RESULT(RESULT) BIND(C, name="strcat") + IMPORT :: C_CHAR_PTR, C_SIZE_T + TYPE(C_CHAR_PTR) :: RESULT + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: dest + !! target=intent(out) + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: src + END FUNCTION C_strcat +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Append no more than N characters from SRC onto DEST. +! +!# Introduction +! Append no more than N characters from SRC onto DEST. +! +!### CInterface +! +!```c +!extern char *strncat (char *dest, const char *src, size_t n) +!``` + +INTERFACE + FUNCTION C_strncat(dest, src, n) RESULT(RESULT) BIND(C, name="strncat") + IMPORT :: C_CHAR_PTR, C_SIZE_T + TYPE(C_CHAR_PTR) :: RESULT + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: dest + !! target=intent(out) + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: src + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n + END FUNCTION C_strncat +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Compare S1 and S2. +! +!# Introduction +! Compare S1 and S2. +! +!### CInterface +! +!```c +!extern int strcmp (const char *s1, const char *s2) +!``` + +INTERFACE + PURE FUNCTION C_strcmp(s1, s2) RESULT(RESULT) BIND(C, name="strcmp") + IMPORT :: C_INT, C_CHAR_PTR, C_SIZE_T + INTEGER(C_INT) :: RESULT + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s1 + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s2 + END FUNCTION C_strcmp +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Compare N characters of S1 and S2. +! +!# Introduction +! Compare N characters of S1 and S2. +! +!### CInterface +! +!```c +!extern int strncmp (const char *s1, const char *s2, size_t n) +!``` + +INTERFACE + PURE FUNCTION C_strncmp(s1, s2, n) RESULT(RESULT) BIND(C, name="strncmp") + IMPORT :: C_INT, C_CHAR_PTR, C_SIZE_T + INTEGER(C_INT) :: RESULT + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s1 + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s2 + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: n + END FUNCTION C_strncmp +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Return the length of S. +! +!# Introduction +! Return the length of S. +! +!### CInterface +! +!```c +!extern size_t strlen (const char *s) +!``` + +INTERFACE + PURE FUNCTION C_strlen(s) RESULT(RESULT) BIND(C, name="strlen") + IMPORT :: C_CHAR_PTR, C_SIZE_T + INTEGER(C_SIZE_T) :: RESULT + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s !character(len=*), intent(in) + END FUNCTION C_strlen +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: CAlloc function +! +!# Introduction +! CAlloc function. +! +!### CInterface +! +!```c +!void *calloc(size_t nmemb, size_t size); +!``` + +INTERFACE + TYPE(C_void_ptr) FUNCTION C_calloc(nmemb, size) BIND(C, name="calloc") + IMPORT :: C_void_ptr, C_SIZE_T + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: nmemb, size + END FUNCTION C_calloc +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: +! +!### CInterface +! +!```c +! void *malloc(size_t size); +!``` + +INTERFACE + TYPE(C_void_ptr) FUNCTION C_malloc(size) BIND(C, name="malloc") + IMPORT :: C_void_ptr, C_SIZE_T + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: size + END FUNCTION C_malloc +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: +! +!### Usage +! +!```fortran +! void free(void *ptr); +!``` + +INTERFACE + SUBROUTINE C_free(ptr) BIND(C, name="free") + IMPORT :: C_void_ptr + TYPE(C_void_ptr), VALUE, INTENT(IN) :: ptr + END SUBROUTINE C_free +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: +! +! +!### CInterface +! +!```c +! void *realloc(void *ptr, size_t size); +!``` + +INTERFACE + TYPE(C_void_ptr) FUNCTION C_realloc(ptr, size) BIND(C, name="realloc") + IMPORT :: C_void_ptr, C_SIZE_T + TYPE(C_void_ptr), VALUE, INTENT(IN) :: ptr + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: size + END FUNCTION C_realloc +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: + +PURE LOGICAL FUNCTION C_ASSOCIATED_PURE(ptr) RESULT(associated) + TYPE(C_PTR), INTENT(IN) :: ptr + INTEGER(C_INTPTR_T) :: iptr + iptr = TRANSFER(ptr, iptr) + ASSOCIATED = (iptr /= 0) +END FUNCTION C_ASSOCIATED_PURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Set a fixed-length Fortran string to the value of a C string. +! +!# Introduction +! Copy a C string, passed by pointer, to a Fortran string. +! If the C pointer is NULL, the Fortran string is blanked. +! C_string must be NUL terminated, or at least as long as F_string. +! If C_string is longer, it is truncated. Otherwise, F_string is +! blank-padded at the end. + +SUBROUTINE F_string_assign_C_string(F_string, C_string) + CHARACTER(*), INTENT(OUT) :: F_string + TYPE(C_CHAR_PTR), INTENT(IN) :: C_string + !> internal variables + CHARACTER(1, KIND=C_CHAR), POINTER :: p_chars(:) + INTEGER(I4B) :: i + !> main + IF (.NOT. C_ASSOCIATED(C_string)) THEN + F_string = '' + ELSE + CALL C_F_POINTER(C_string, p_chars, [HUGE(0)]) + i = 1 + DO WHILE (p_chars(i) .NE. NUL .AND. I .LE. LEN(F_string)) + F_string(i:i) = p_chars(i); i = i + 1 + END DO + IF (i .LT. LEN(F_string)) F_string(i:) = ' ' + END IF +END SUBROUTINE F_string_assign_C_string + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Copy a C string, passed as a char-array reference, to a Fortran string. +! +!# Introduction +! +! Copy a C string, passed by pointer, to a Fortran string. +! If the C pointer is NULL, the Fortran string is blanked. +! C_string must be NUL terminated, or at least as long as F_string. +! If C_string is longer, it is truncated. Otherwise, F_string is +! blank-padded at the end. + +SUBROUTINE C_F_string_chars(C_string, F_string) + CHARACTER(1, KIND=C_CHAR), INTENT(IN) :: C_string(*) + CHARACTER(*), INTENT(OUT) :: F_string + !! F_String is fortran string, it should be allocated + !! before calling the routine + ! + ! internal variable + ! + INTEGER(I4B) :: i + i = 1 + DO WHILE (C_string(i) .NE. NUL .AND. i .LE. LEN(F_string)) + F_string(i:i) = C_string(i) + i = i + 1 + END DO + IF (i .LT. LEN(F_string)) F_string(i:) = ' ' +END SUBROUTINE C_F_string_chars + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION Fstring1(C_string) RESULT(F_string) + CHARACTER(1, KIND=C_CHAR), INTENT(IN) :: C_string(:) + CHARACTER(:), ALLOCATABLE :: F_string + !! + INTEGER(I4B) :: i, n, m + n = SIZE(C_string) + m = 0 + DO i = 1, n - 1 + IF (C_string(i) .EQ. NUL) THEN + EXIT + ELSE + m = m + 1 + END IF + END DO + ALLOCATE (CHARACTER(m) :: F_string) + DO i = 1, m + F_string(i:i) = C_string(i) + END DO +END FUNCTION Fstring1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! FUNCTION Fstring2(C_string) RESULT(F_string) +! TYPE(C_CHAR_PTR), INTENT(IN) :: C_string +! !! C pointer +! CHARACTER(:), ALLOCATABLE :: F_string +! !! Fortran string +! +! ! ! internal variables +! ! CHARACTER(1, KIND=C_CHAR), POINTER :: p_chars(:) +! ! INTEGER(I4B) :: i, n, m +! ! +! ! !> main +! ! IF (.NOT. C_ASSOCIATED(C_string)) THEN +! ! F_string = '' +! ! RETURN +! ! ELSE +! ! CALL C_F_POINTER(C_string, p_chars, [HUGE(0)]) +! ! i = 1 +! ! DO WHILE (p_chars(i) .NE. NUL .AND. I .LE. LEN(F_string)) +! ! F_string(i:i) = p_chars(i); i = i + 1 +! ! END DO +! ! IF (i .LT. LEN(F_string)) F_string(i:) = ' ' +! ! END IF +! ! +! ! n = SIZE(C_string) +! ! m = 0 +! ! +! ! DO i = 1, n - 1 +! ! IF (C_string(i) .EQ. NUL) THEN +! ! EXIT +! ! ELSE +! ! m = m + 1 +! ! END IF +! ! END DO +! ! +! ! ALLOCATE (CHARACTER(m) :: F_string) +! ! +! ! DO i = 1, m +! ! F_string(i:i) = C_string(i) +! ! END DO +! END FUNCTION Fstring2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Copy a Fortran string to an allocated C string pointer. +! +!# Introduction +! +! Copy a Fortran string to an allocated C string pointer. +! If the C pointer is NULL, no action is taken. (Maybe auto allocate via libc call?) +! If the length is not passed, the C string must be at least: len(F_string)+1 +! If the length is passed and F_string is too long, it is truncated. + +SUBROUTINE F_C_STRING_PTR(F_string, C_string, C_string_len) + CHARACTER(*), INTENT(IN) :: F_string + TYPE(C_CHAR_PTR), INTENT(IN) :: C_string + !! target = intent(out) + INTEGER(I4B), INTENT(IN), OPTIONAL :: C_string_len + !! Max string length, + !! INCLUDING THE TERMINAL NUL + !> internal variables + CHARACTER(1, KIND=C_CHAR), DIMENSION(:), POINTER :: p_chars + INTEGER(I4B) :: i, strlen + !> main + strlen = LEN(F_string) + IF (PRESENT(C_string_len)) THEN + IF (C_string_len .LE. 0) RETURN + strlen = MIN(strlen, C_string_len - 1) + END IF + IF (.NOT. C_ASSOCIATED(C_string)) RETURN + CALL C_F_POINTER(C_string, p_chars, [strlen + 1]) + DO CONCURRENT(i=1:strlen) + p_chars(i) = F_string(i:i) + END DO + p_chars(strlen + 1) = NUL +END SUBROUTINE F_C_STRING_PTR + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Copy a Fortran string to a C string passed by char-array reference. +! +!# Introduction +! +! Copy a Fortran string to a C string passed by char-array reference. +! If the length is not passed, the C string must be at least: len(F_string)+1 +! If the length is passed and F_string is too long, it is truncated. + +SUBROUTINE F_C_STRING_CHARS(F_string, C_string, C_string_len) + CHARACTER(*), INTENT(IN) :: F_string + ! fortran string + CHARACTER(1, KIND=C_CHAR), INTENT(OUT) :: C_string(*) + ! c string + INTEGER(I4B), INTENT(IN), OPTIONAL :: C_string_len + ! max string length, optional + ! + ! main + ! + INTEGER(I4B) :: i, strlen + ! + strlen = LEN(F_string) + IF (PRESENT(C_string_len)) THEN + IF (C_string_len .LE. 0) RETURN + strlen = MIN(strlen, C_string_len - 1) + END IF + ! + DO CONCURRENT(i=1:strlen) + C_string(i) = F_string(i:i) + END DO + ! + C_string(strlen + 1) = NUL + ! +END SUBROUTINE F_C_STRING_CHARS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-21 +! summary: Convert a fortran string to cString + +FUNCTION CString(o) RESULT(v) + CHARACTER(*), INTENT(in) :: o + CHARACTER(:, kind=C_CHAR), ALLOCATABLE :: v + v = TRIM(o)//C_NULL_CHAR +END FUNCTION CString + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Convert Fortran string to C string + +FUNCTION F_C_STRING_DUP(F_string, length) RESULT(C_string) + CHARACTER(*), INTENT(IN) :: F_string + INTEGER, INTENT(IN), OPTIONAL :: length + TYPE(C_PTR) :: C_string + !> internal variables + CHARACTER(1, KIND=C_CHAR), POINTER :: C_string_ptr(:) + INTEGER(I4B) :: i + INTEGER(C_SIZE_T) :: strlen + !> main + IF (PRESENT(length)) THEN + strlen = length + ELSE + strlen = LEN(F_string) + END IF + IF (strlen .LE. 0) THEN + C_string = C_NULL_PTR + ELSE + C_string = C_MALLOC(strlen + 1) + IF (C_ASSOCIATED(C_string)) THEN + CALL C_F_POINTER(C_string, C_string_ptr, [strlen + 1]) + DO CONCURRENT(i=1:strlen) + C_string_ptr(i) = F_string(i:i) + END DO + C_string_ptr(strlen + 1) = NUL + END IF + END IF +END FUNCTION F_C_STRING_DUP + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: This function returns length of string + +PURE FUNCTION C_STRLEN_SAFE(s) RESULT(length) + INTEGER(C_SIZE_T) :: length + TYPE(C_CHAR_PTR), VALUE, INTENT(IN) :: s + !> + IF (.NOT. C_ASSOCIATED_PURE(s)) THEN + length = 0 + ELSE + length = C_STRLEN(s) + END IF +END FUNCTION C_STRLEN_SAFE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Returns the value of target of C string + +FUNCTION C_STRING_VALUE(C_string) RESULT(F_string) + TYPE(C_CHAR_PTR), INTENT(IN) :: C_string + CHARACTER(LEN=C_STRLEN_SAFE(C_string)) :: F_string + !> internal variables + CHARACTER(1, kind=C_CHAR), DIMENSION(:), POINTER :: p_chars + INTEGER(I4B) :: i, length + !> main + length = LEN(F_string) + IF (length .NE. 0) THEN + CALL C_F_POINTER(C_string, p_chars, [length]) + DO CONCURRENT(i=1:length) + F_string(i:i) = p_chars(i) + END DO + END IF +END FUNCTION C_STRING_VALUE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Allocate memory space and return C string + +FUNCTION C_STRING_ALLOC(length) RESULT(C_string) + INTEGER(C_SIZE_T), INTENT(IN) :: length + TYPE(C_PTR) :: C_String + !> internal variables + CHARACTER(1, KIND=C_CHAR), POINTER :: C_CHARPTR + !> main + C_string = C_MALLOC(length + 1) + IF (C_ASSOCIATED(C_string)) THEN + CALL C_F_POINTER(C_string, C_charptr) + C_CHARPTR = NUL + END IF +END FUNCTION C_STRING_ALLOC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE C_STRING_FREE(string) + TYPE(C_PTR), INTENT(INOUT) :: string + IF (C_ASSOCIATED(string)) THEN + CALL C_FREE(string) + string = C_NULL_PTR + END IF +END SUBROUTINE C_STRING_FREE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Converts C pointer to integer vector + +SUBROUTINE C_PTR_TO_Int8_VEC(vec, cptr) + INTEGER(INT8), INTENT(OUT) :: vec(:) + TYPE(C_PTR), INTENT(IN) :: cptr + !> Internal variables + INTEGER(I4B) :: n, ii + INTEGER(INT8), POINTER :: p(:) + !> main + n = SIZE(vec); vec = 0 + IF (C_ASSOCIATED(cptr)) THEN + CALL C_F_POINTER(cptr, p, [n]) + DO ii = 1, n + vec(ii) = p(ii) + END DO + DEALLOCATE (p) + END IF +END SUBROUTINE C_PTR_TO_Int8_VEC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Converts C pointer to integer vector + +SUBROUTINE C_PTR_TO_Int16_VEC(vec, cptr) + INTEGER(INT16), INTENT(OUT) :: vec(:) + TYPE(C_PTR), INTENT(IN) :: cptr + !> Internal variables + INTEGER(I4B) :: n, ii + INTEGER(INT16), POINTER :: p(:) + !> main + n = SIZE(vec); vec = 0 + IF (C_ASSOCIATED(cptr)) THEN + CALL C_F_POINTER(cptr, p, [n]) + DO ii = 1, n + vec(ii) = p(ii) + END DO + DEALLOCATE (p) + END IF +END SUBROUTINE C_PTR_TO_Int16_VEC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Converts C pointer to integer vector + +SUBROUTINE C_PTR_TO_Int32_VEC(vec, cptr) + INTEGER(INT32), INTENT(OUT) :: vec(:) + TYPE(C_PTR), INTENT(IN) :: cptr + !> Internal variables + INTEGER(I4B) :: n, ii + INTEGER(INT32), POINTER :: p(:) + !> main + n = SIZE(vec); vec = 0 + IF (C_ASSOCIATED(cptr)) THEN + CALL C_F_POINTER(cptr, p, [n]) + DO ii = 1, n + vec(ii) = p(ii) + END DO + DEALLOCATE (p) + END IF +END SUBROUTINE C_PTR_TO_Int32_VEC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Converts C pointer to integer vector + +SUBROUTINE C_PTR_TO_Int64_VEC(vec, cptr) + INTEGER(INT64), INTENT(OUT) :: vec(:) + TYPE(C_PTR), INTENT(IN) :: cptr + !> Internal variables + INTEGER(I4B) :: n, ii + INTEGER(INT64), POINTER :: p(:) + !> main + n = SIZE(vec); vec = 0 + IF (C_ASSOCIATED(cptr)) THEN + CALL C_F_POINTER(cptr, p, [n]) + DO ii = 1, n + vec(ii) = p(ii) + END DO + DEALLOCATE (p) + END IF +END SUBROUTINE C_PTR_TO_Int64_VEC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Converts C pointer to real vector + +SUBROUTINE C_PTR_TO_Real32_VEC(vec, cptr) + REAL(REAL32), INTENT(OUT) :: vec(:) + TYPE(C_PTR), INTENT(IN) :: cptr + ! Internal variables + INTEGER :: n, ii + REAL(REAL32), POINTER :: p(:) + !> main + n = SIZE(vec); vec = 0 + IF (C_ASSOCIATED(cptr)) THEN + CALL C_F_POINTER(cptr, p, [n]) + DO ii = 1, n + vec(ii) = p(ii) + END DO + DEALLOCATE (p) + END IF +END SUBROUTINE C_PTR_TO_Real32_VEC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Sept 2021 +! summary: Converts C pointer to real vector + +SUBROUTINE C_PTR_TO_Real64_VEC(vec, cptr) + REAL(REAL64), INTENT(OUT) :: vec(:) + TYPE(C_PTR), INTENT(IN) :: cptr + ! Internal variables + INTEGER :: n, ii + REAL(REAL64), POINTER :: p(:) + !> main + n = SIZE(vec); vec = 0 + IF (C_ASSOCIATED(cptr)) THEN + CALL C_F_POINTER(cptr, p, [n]) + DO ii = 1, n + vec(ii) = p(ii) + END DO + DEALLOCATE (p) + END IF +END SUBROUTINE C_PTR_TO_Real64_VEC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Nov 2022 +! summary: optional value for `C_INT` +! +!# Introduction +! +! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 + +PURE FUNCTION optval_c_int_1(default, option) RESULT(res) + INTEGER(C_INT), INTENT(IN) :: default + INTEGER(C_INT), OPTIONAL, INTENT(IN) :: option + INTEGER(C_INT) :: res + !! + IF (PRESENT(option)) THEN + res = INT(option, KIND=C_INT) + ELSE + res = INT(default, KIND=C_INT) + END IF +END FUNCTION optval_c_int_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Nov 2022 +! summary: Optional value for `C_SIZE_T` +! +!# Introduction +! +! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 + +PURE FUNCTION optval_c_size_t_1(default, option) RESULT(res) + INTEGER(I4B), INTENT(IN) :: default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: option + INTEGER(C_SIZE_T) :: res + !! + IF (PRESENT(option)) THEN + res = INT(option, KIND=C_SIZE_T) + ELSE + res = INT(default, KIND=C_SIZE_T) + END IF +END FUNCTION optval_c_size_t_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Nov 2022 +! summary: Optional value for `C_SIZE_T` +! +!# Introduction +! +! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 + +PURE FUNCTION optval_c_size_t_2(default, option) RESULT(res) + INTEGER(C_SIZE_T), INTENT(IN) :: default + INTEGER(C_SIZE_T), OPTIONAL, INTENT(IN) :: option + INTEGER(C_SIZE_T) :: res + !! + IF (PRESENT(option)) THEN + res = INT(option, KIND=C_SIZE_T) + ELSE + res = INT(default, KIND=C_SIZE_T) + END IF +END FUNCTION optval_c_size_t_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Nov 2022 +! summary: Optional value for `C_DOUBLE` +! +!# Introduction +! +! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 + +PURE FUNCTION optval_c_double_1(default, option) RESULT(res) + REAL(C_DOUBLE), INTENT(in) :: default + REAL(C_DOUBLE), OPTIONAL, INTENT(in) :: option + REAL(C_DOUBLE) :: res + !! + res = REAL(default, kind=C_DOUBLE) + IF (PRESENT(option)) res = REAL(option, kind=C_DOUBLE) +END FUNCTION optval_c_double_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Nov 2022 +! summary: Optional value for `C_DOUBLE` +! +!# Introduction +! +! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 + +PURE FUNCTION optval_c_double_2(default, option) RESULT(res) + REAL, INTENT(in) :: default + REAL(C_DOUBLE), OPTIONAL, INTENT(in) :: option + REAL(C_DOUBLE) :: res + !! + res = REAL(default, kind=C_DOUBLE) + IF (PRESENT(option)) res = REAL(option, kind=C_DOUBLE) +END FUNCTION optval_c_double_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Nov 2022 +! summary: Optional value for boolean +! +!# Introduction +! +! Reference: https://gitlab.onelab.info/gmsh/gmsh/-/blob/master/api/gmsh.f90 + +PURE FUNCTION optval_c_bool(default, option) RESULT(res) + LOGICAL, INTENT(in) :: default + LOGICAL, OPTIONAL, INTENT(in) :: option + INTEGER(C_INT) :: res + !! + res = MERGE(1_C_INT, 0_C_INT, default) + IF (PRESENT(option)) res = MERGE(1_C_INT, 0_C_INT, option) +END FUNCTION optval_c_bool + +END MODULE CInterface diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt new file mode 100644 index 000000000..18beb64bf --- /dev/null +++ b/src/modules/CMakeLists.txt @@ -0,0 +1,211 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +# FFTW +include(${CMAKE_CURRENT_LIST_DIR}/FFTW/CMakeLists.txt) + +# PENF +include(${CMAKE_CURRENT_LIST_DIR}/PENF/CMakeLists.txt) + +# BeFoR64 +include(${CMAKE_CURRENT_LIST_DIR}/BeFoR64/CMakeLists.txt) + +# String +include(${CMAKE_CURRENT_LIST_DIR}/String/CMakeLists.txt) + +# FACE +include(${CMAKE_CURRENT_LIST_DIR}/FACE/CMakeLists.txt) + +# FPL +include(${CMAKE_CURRENT_LIST_DIR}/FPL/CMakeLists.txt) + +# System +include(${CMAKE_CURRENT_LIST_DIR}/System/CMakeLists.txt) + +# TriangleInterface +include(${CMAKE_CURRENT_LIST_DIR}/TriangleInterface/CMakeLists.txt) + +# BLAS95 +include(${CMAKE_CURRENT_LIST_DIR}/BLAS95/CMakeLists.txt) + +# Test +include(${CMAKE_CURRENT_LIST_DIR}/Test/CMakeLists.txt) + +# GlobalData +include(${CMAKE_CURRENT_LIST_DIR}/GlobalData/CMakeLists.txt) + +# RaylibInterface +include(${CMAKE_CURRENT_LIST_DIR}/RaylibInterface/CMakeLists.txt) + +# Display +include(${CMAKE_CURRENT_LIST_DIR}/Display/CMakeLists.txt) + +# ARPACK +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) + +# CInterface +include(${CMAKE_CURRENT_LIST_DIR}/CInterface/CMakeLists.txt) + +# LuaInterface +include(${CMAKE_CURRENT_LIST_DIR}/LuaInterface/CMakeLists.txt) + +# SuperLUInterface +include(${CMAKE_CURRENT_LIST_DIR}/SuperLUInterface/CMakeLists.txt) + +# LISInterface +include(${CMAKE_CURRENT_LIST_DIR}/LISInterface/CMakeLists.txt) + +# MetisInterface +include(${CMAKE_CURRENT_LIST_DIR}/MetisInterface/CMakeLists.txt) + +# MdEncode +include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) + +# ErrorHandling +include(${CMAKE_CURRENT_LIST_DIR}/ErrorHandling/CMakeLists.txt) + +# Utility +include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) + +# Kdtree2 +include(${CMAKE_CURRENT_LIST_DIR}/Kdtree2/CMakeLists.txt) + +# BaseInterpolation +include(${CMAKE_CURRENT_LIST_DIR}/BaseInterpolation/CMakeLists.txt) + +# BaseContinuity +include(${CMAKE_CURRENT_LIST_DIR}/BaseContinuity/CMakeLists.txt) + +# Polynomial +include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) + +# BaseType +include(${CMAKE_CURRENT_LIST_DIR}/BaseType/CMakeLists.txt) + +# MultiIndices +include(${CMAKE_CURRENT_LIST_DIR}/MultiIndices/CMakeLists.txt) + +# OpenMP +include(${CMAKE_CURRENT_LIST_DIR}/OpenMP/CMakeLists.txt) + +# Random +include(${CMAKE_CURRENT_LIST_DIR}/Random/CMakeLists.txt) + +# BoundingBox +include(${CMAKE_CURRENT_LIST_DIR}/BoundingBox/CMakeLists.txt) + +# IntVector +include(${CMAKE_CURRENT_LIST_DIR}/IntVector/CMakeLists.txt) + +# IndexValue +include(${CMAKE_CURRENT_LIST_DIR}/IndexValue/CMakeLists.txt) + +# IndexValue +include(${CMAKE_CURRENT_LIST_DIR}/IterationData/CMakeLists.txt) + +# KeyValue +include(${CMAKE_CURRENT_LIST_DIR}/KeyValue/CMakeLists.txt) + +# Vector3D_ +include(${CMAKE_CURRENT_LIST_DIR}/Vector3D/CMakeLists.txt) + +# Lapack +include(${CMAKE_CURRENT_LIST_DIR}/Lapack/CMakeLists.txt) + +# RealVector +include(${CMAKE_CURRENT_LIST_DIR}/RealVector/CMakeLists.txt) + +# DOF +include(${CMAKE_CURRENT_LIST_DIR}/DOF/CMakeLists.txt) + +# Geometry +include(${CMAKE_CURRENT_LIST_DIR}/Geometry/CMakeLists.txt) + +# QuadraturePoint +include(${CMAKE_CURRENT_LIST_DIR}/QuadraturePoint/CMakeLists.txt) + +# FEVariable +include(${CMAKE_CURRENT_LIST_DIR}/FEVariable/CMakeLists.txt) + +# ElemshapeData +include(${CMAKE_CURRENT_LIST_DIR}/ElemshapeData/CMakeLists.txt) + +# RealMatrix +include(${CMAKE_CURRENT_LIST_DIR}/RealMatrix/CMakeLists.txt) + +# MassMatrix +include(${CMAKE_CURRENT_LIST_DIR}/MassMatrix/CMakeLists.txt) + +# STMassMatrix +include(${CMAKE_CURRENT_LIST_DIR}/STMassMatrix/CMakeLists.txt) + +# DiffusionMatrix +include(${CMAKE_CURRENT_LIST_DIR}/DiffusionMatrix/CMakeLists.txt) + +# STDiffusionMatrix +include(${CMAKE_CURRENT_LIST_DIR}/STDiffusionMatrix/CMakeLists.txt) + +# ConvectiveMatrix +include(${CMAKE_CURRENT_LIST_DIR}/ConvectiveMatrix/CMakeLists.txt) + +# STConvectiveMatrix +include(${CMAKE_CURRENT_LIST_DIR}/STConvectiveMatrix/CMakeLists.txt) + +# StiffnessMatrix +include(${CMAKE_CURRENT_LIST_DIR}/StiffnessMatrix/CMakeLists.txt) + +# ElasticNitscheMatrix +include(${CMAKE_CURRENT_LIST_DIR}/ElasticNitscheMatrix/CMakeLists.txt) + +# FacetMatrix +include(${CMAKE_CURRENT_LIST_DIR}/FacetMatrix/CMakeLists.txt) + +# FEMatrix +include(${CMAKE_CURRENT_LIST_DIR}/FEMatrix/CMakeLists.txt) + +# ForceVector +include(${CMAKE_CURRENT_LIST_DIR}/ForceVector/CMakeLists.txt) + +# STForceVector +include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt) + +# FEVector +include(${CMAKE_CURRENT_LIST_DIR}/FEVector/CMakeLists.txt) + +# VoigtRank2Tensor +include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt) + +# Rank2Tensor +include(${CMAKE_CURRENT_LIST_DIR}/Rank2Tensor/CMakeLists.txt) + +# CSRSparsity +include(${CMAKE_CURRENT_LIST_DIR}/CSRSparsity/CMakeLists.txt) + +# CSRMatrix +include(${CMAKE_CURRENT_LIST_DIR}/CSRMatrix/CMakeLists.txt) + +# BaseMethod +include(${CMAKE_CURRENT_LIST_DIR}/BaseMethod/CMakeLists.txt) + +# easifemBase +include(${CMAKE_CURRENT_LIST_DIR}/easifemBase/CMakeLists.txt) diff --git a/src/modules/CSRMatrix/CMakeLists.txt b/src/modules/CSRMatrix/CMakeLists.txt new file mode 100644 index 000000000..d9f37d031 --- /dev/null +++ b/src/modules/CSRMatrix/CMakeLists.txt @@ -0,0 +1,51 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/CSRMatrix_AddMethods.F90 + ${src_path}/CSRMatrix_ConstructorMethods.F90 + ${src_path}/CSRMatrix_DiagonalScalingMethods.F90 + ${src_path}/CSRMatrix_GetBlockColMethods.F90 + ${src_path}/CSRMatrix_GetBlockRowMethods.F90 + ${src_path}/CSRMatrix_GetColMethods.F90 + ${src_path}/CSRMatrix_GetMethods.F90 + ${src_path}/CSRMatrix_GetRowMethods.F90 + ${src_path}/CSRMatrix_GetSubMatrixMethods.F90 + ${src_path}/CSRMatrix_ILUMethods.F90 + ${src_path}/CSRMatrix_IOMethods.F90 + ${src_path}/CSRMatrix_LUSolveMethods.F90 + ${src_path}/CSRMatrix_SymMatmulMethods.F90 + ${src_path}/CSRMatrix_MatVecMethods.F90 + ${src_path}/CSRMatrix_ReorderingMethods.F90 + ${src_path}/CSRMatrix_SetBlockColMethods.F90 + ${src_path}/CSRMatrix_SetBlockRowMethods.F90 + ${src_path}/CSRMatrix_SetColMethods.F90 + ${src_path}/CSRMatrix_SetMethods.F90 + ${src_path}/CSRMatrix_SetRowMethods.F90 + ${src_path}/CSRMatrix_SparsityMethods.F90 + ${src_path}/CSRMatrix_UnaryMethods.F90 + ${src_path}/CSRMatrix_Method.F90 + ${src_path}/CSRMatrix_SpectralMethods.F90 + ${src_path}/CSRMatrix_MatrixMarketIO.F90 + ${src_path}/CSRMatrix_DBCMethods.F90 + ${src_path}/CSRMatrix_LinSolveMethods.F90) + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} PRIVATE ${src_path}/CSRMatrix_SuperLU.F90 + ${src_path}/CSRMatrix_SchurMethods.F90) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 new file mode 100644 index 000000000..90411faa2 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 @@ -0,0 +1,505 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE CSRMatrix_AddMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 Marach 2021 +! summary: This subroutine Add contribution + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add0(obj, nodenum, VALUE, scale) + 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 + END SUBROUTINE obj_Add0 +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 + 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 + END SUBROUTINE obj_Add1 +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 +! +!# Introduction +! This routine Adds all values of sparse matrix to given value. +! This routine signifies `obj=obj+scale*value`. + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add2(obj, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add2 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Adds a single entry of sparse matrix +! +!# Introduction +! +! This subroutine Adds a single entry of sparse matrix. +! Before using this subroutien the user should be aware of the storage +! pattern of degree of freedom. However, if total number of degrees of +! freedom is one then there is not need to worry. In my opinion, this routine +! should be avoided by general user. + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add3(obj, irow, icolumn, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B), INTENT(IN) :: icolumn + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add3 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Adds the specific row and column entry to a given value +! +!# Introduction +! +! This routine Adds the specific row and column entry to a given value. +! The row and column index is calculated by using (iNodeNum, idof) and +! (jNodeNum, jdof), respectively. +! After computing the irow and icolumn (internally) this routine calls, +! `obj_Add3`. + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add4(obj, iNodeNum, jNodeNum, idof, & + & jdof, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum + INTEGER(I4B), INTENT(IN) :: jNodeNum + INTEGER(I4B), INTENT(IN) :: idof + INTEGER(I4B), INTENT(IN) :: jdof + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add4 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! 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_Add5(obj, nodenum, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add5 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Add the value in sparse matrix +! +!# Introduction +! +! - This subroutine Adds the values in block sparse matrix. +! - The storage pattern of both sparse matrix and value +! (the element matrix) should be in `FMT_DOF`. +! +!$$ +! obj(Nptrs,Nptrs)=value(:,:) +!$$ +! + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, & + & ivar, jvar, VALUE, scale) + 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 + END SUBROUTINE obj_Add6 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Adds the specific row and column entry to a given value +! +!# Introduction +! +! - This routine Adds the specific row and column entry to a given value. +! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Add3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Add3]] +!@endnote +! +!@note +! idof, jdof are continuously numbered, so if there are two +! or more physical variables, then idof and jdof of the second +! or later physical variables will not start from 1. +!@endnote + +INTERFACE Add + 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 + 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 + END SUBROUTINE obj_Add7 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Adds the specific row and column entry to a given value + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, & + & jvar, iDOF, jDOF, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + 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 + END SUBROUTINE obj_Add8 +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 +! +!# Introduction +! +! - This routine Adds the specific row and column entry to a given value. +! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Add3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Add3]] +!@endnote +! +!@note +! idof, jdof are continuously numbered, so if there are two +! or more physical variables, then idof and jdof of the second +! or later physical variables will not start from 1. +!@endnote + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum + !! row node number + 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 + END SUBROUTINE obj_Add9 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17/01/2022 +! summary: This subroutine Add the value in sparse matrix +! +!# Introduction +! +! - This subroutine Adds the values in block sparse matrix. +! - The storage pattern of both sparse matrix and value +! (the element matrix) should be in `FMT_DOF`. +! +!$$ +! obj(Nptrs,Nptrs)=value(:,:) +!$$ +! + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add10(obj, iNodeNum, jNodeNum, & + & ivar, jvar, VALUE, scale) + 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 + END SUBROUTINE obj_Add10 +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_Add11(obj, iNodeNum, jNodeNum, ivar, & + & jvar, iDOF, jDOF, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! + 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 + END SUBROUTINE obj_Add11 +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_Add12(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + 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 + END SUBROUTINE obj_Add12 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17/01/2022 +! summary: Adds the specific row and column entry to a given value + +INTERFACE Add + MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! + 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 + END SUBROUTINE obj_Add13 +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_Add14(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! + 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 + END SUBROUTINE obj_Add14 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: obj = obj + scale * value +! +!# Introduction +! +! Add a csrmatrix to another csrmatrix + +INTERFACE Add + MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, & + & isSorted) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + !! CSRMatrix_ + TYPE(CSRMatrix_), INTENT(IN) :: VALUE + !! CSRMatrix to add to obj + REAL(DFP), INTENT(IN) :: scale + !! scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSameStructure + !! If obj and value has same structure + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSorted + !! True if the matrix is sorted. + END SUBROUTINE obj_Add15 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE CSRMatrix_AddMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 new file mode 100644 index 000000000..9d67cb259 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_ConstructorMethods.F90 @@ -0,0 +1,391 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_ConstructorMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE Basetype, ONLY: CSRMatrix_, DOF_, CSRSparsity_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: Initiate +PUBLIC :: Shape +PUBLIC :: Size +PUBLIC :: TotalDimension +PUBLIC :: SetTotalDimension +PUBLIC :: GetNNZ +PUBLIC :: ALLOCATE +PUBLIC :: DEALLOCATE +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: CSRMatrixAPLSB +PUBLIC :: CSRMatrixAPLSBSorted + +!---------------------------------------------------------------------------- +! Shape@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This function returns the shape of sparse matrix + +INTERFACE Shape + MODULE PURE FUNCTION obj_Shape(obj) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B) :: ans(2) + END FUNCTION obj_Shape +END INTERFACE Shape + +!---------------------------------------------------------------------------- +! Size@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This function returns the size of sparse matrix +! +!# Introduction +! +! This function returns the size of sparse matrix +! If dims equal to 1 then total number of rows are returned +! If dims is equal to 2 then total number of columns are return +! If dims is absent then nrow*ncol are returned + +INTERFACE Size + MODULE PURE FUNCTION obj_Size(obj, dims) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), OPTIONAL, INTENT(IN) :: dims + INTEGER(I4B) :: ans + END FUNCTION obj_Size +END INTERFACE Size + +!---------------------------------------------------------------------------- +! TotalDimension@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Returns the total dimension of an array + +INTERFACE TotalDimension + MODULE PURE FUNCTION obj_TotalDimension(obj) RESULT(ans) + CLASS(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_TotalDimension +END INTERFACE TotalDimension + +!---------------------------------------------------------------------------- +! SetTotalDimension@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine Set the total dimension (rank) of an array + +INTERFACE SetTotalDimension + MODULE PURE SUBROUTINE obj_SetTotalDimension(obj, tDimension) + CLASS(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tDimension + END SUBROUTINE obj_SetTotalDimension +END INTERFACE SetTotalDimension + +!---------------------------------------------------------------------------- +! GetNNZ@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Return the total number of non zero entry in the matrix + +INTERFACE GetNNZ + MODULE PURE FUNCTION obj_GetNNZ(obj) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_GetNNZ +END INTERFACE GetNNZ + +!---------------------------------------------------------------------------- +! Allocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine creates memeory space for the sparse matrix object +! +!# Introduction +! +! This subroutine creates memory space for the sparse matrix +! +! dims(1) denotes total number of rows +! dims(2) denotes total number of columns +! tDOF is Set to 1 +! tNodes is Set to dims(1) +! nnz is Set to to 0 + +INTERFACE ALLOCATE + MODULE SUBROUTINE obj_Allocate(obj, dims, matrixProp) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: dims(2) + CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp + END SUBROUTINE obj_Allocate +END INTERFACE ALLOCATE + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine deallocates the data + +INTERFACE DEALLOCATE + MODULE SUBROUTINE obj_Deallocate(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This subroutine construct the `CSRMatrix_` object + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate1(obj, ncol, nrow, idof, jdof, matrixProp, nnz) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ncol + !! number of columns in sparse matrix + INTEGER(I4B), INTENT(IN) :: nrow + !! number of rows in sparse matrix + TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof, jdof + !! degree of freedom object; It contains information like + !! storage format (NODES_FMT, DOF_FMT), and names of physical variable + !! space-time component in each physical variables + !! Total number of nodes used for these physical variables + CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp + !! Matrix is `SYM`, `UNSYM` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnz + !! number of non zeros + END SUBROUTINE obj_Initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This subroutine construct the `CSRMatrix_` object +! +!# Introduction +! This subroutine Initiates an instance of [[CSRMatrix_]]. The object so +! created does not own the ownership of `obj%csr`. Instead it points to a +! [[CSRSparsity_]] object which is supplied by the user. +! +!@note +! The object `csr` should be Initiated by the user before sending it to +! CSR matrix via this routine. This is because this routine uses information +! such as ncol, nrow, nnz from the csr. +!@endnote + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate2(obj, csr, matrixProp) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRSparsity_), INTENT(IN) :: csr + !! number of columns in sparse matrix + !! number of rows in sparse matrix + !! degree of freedom object; It contains information like + !! storage format (NODES_FMT, DOF_FMT), and names of physical variable + !! space-time component in each physical variables + !! Total number of nodes used for these physical variables + CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp + !! Matrix is `SYM`, `UNSYM` + END SUBROUTINE obj_Initiate2 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine constructs `sparsematrix_` object from IA, JA, A + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate3(obj, A, IA, JA, matrixProp, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: IA(:), JA(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: matrixProp + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ncol + !! Number of columns in obj, default is number of rows + END SUBROUTINE obj_Initiate3 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 July 2021 +! summary: Initiate by copying +! +!# Introduction +! This routine Initiates obj by copying contents from obj2 +! This routine is used in defining the assignment operator. + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate4(obj, obj2) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(IN) :: obj2 + END SUBROUTINE obj_Initiate4 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE obj_Initiate4 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: Initiates a submatrix + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate5(obj, obj2, i1, i2, j1, j2) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + !! submatrix to be returned + TYPE(CSRMatrix_), INTENT(IN) :: obj2 + !! csr matrix + INTEGER(I4B), INTENT(IN) :: i1, i2 + !! start and end row indices + INTEGER(I4B), INTENT(IN) :: j1, j2 + !! start and end col indices + END SUBROUTINE obj_Initiate5 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This routine Initiates an instance of sparse matrix by copying +! the content of another object obj2 +! +!# Introduction +! +! This method has been deprecated as it is same as `Initiate4` + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate6(obj, obj2, hardCopy) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(IN) :: obj2 + LOGICAL(LGT), INTENT(IN) :: hardCopy + END SUBROUTINE obj_Initiate6 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: Initiate an object by adding two csrmatrix + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate7(obj, obj1, obj2, scale, isSorted) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(IN) :: obj1 + TYPE(CSRMatrix_), INTENT(IN) :: obj2 + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSorted + END SUBROUTINE obj_Initiate7 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: Initiate an object by adding two csrmatrix + +INTERFACE CSRMatrixAPLSB + MODULE SUBROUTINE obj_aplsb(nrow, ncol, a, ja, ia, s, b, jb, ib, c, & + & jc, ic, nzmax, ierr) + INTEGER(I4B), INTENT(IN) :: nrow + INTEGER(I4B), INTENT(IN) :: ncol + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + !! nrow + 1 + REAL(DFP), INTENT(IN) :: s + REAL(DFP), INTENT(IN) :: b(:) + INTEGER(I4B), INTENT(IN) :: jb(:) + INTEGER(I4B), INTENT(IN) :: ib(:) + !! nrow + 1 + REAL(DFP), INTENT(INOUT) :: c(:) + !! The size of c should be less than or equalto nzmax + INTEGER(I4B), INTENT(INOUT) :: jc(:) + !! The size of jc should be less than or equalto nzmax + INTEGER(I4B), INTENT(INOUT) :: ic(:) + !! nrow + 1 + INTEGER(I4B), INTENT(IN) :: nzmax + !! max number of nonzero in c + INTEGER(I4B), INTENT(OUT) :: ierr + END SUBROUTINE obj_aplsb +END INTERFACE CSRMatrixAPLSB + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: Initiate an object by adding two csrmatrix + +INTERFACE CSRMatrixAPLSBSorted + MODULE SUBROUTINE obj_aplsb_sorted(nrow, ncol, a, ja, ia, s, b, jb, ib, & + & c, jc, ic, nzmax, ierr) + INTEGER(I4B), INTENT(IN) :: nrow + INTEGER(I4B), INTENT(IN) :: ncol + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + !! nrow + 1 + REAL(DFP), INTENT(IN) :: s + !! scale + REAL(DFP), INTENT(IN) :: b(:) + INTEGER(I4B), INTENT(IN) :: jb(:) + INTEGER(I4B), INTENT(IN) :: ib(:) + !! nrow + 1 + REAL(DFP), INTENT(INOUT) :: c(:) + !! The size of c should be less than or equalto nzmax + INTEGER(I4B), INTENT(INOUT) :: jc(:) + !! The size of jc should be less than or equalto nzmax + INTEGER(I4B), INTENT(INOUT) :: ic(:) + !! nrow + 1 + INTEGER(I4B), INTENT(IN) :: nzmax + !! max number of nonzero in c + INTEGER(I4B), INTENT(OUT) :: ierr + END SUBROUTINE obj_aplsb_sorted +END INTERFACE CSRMatrixAPLSBSorted + +END MODULE CSRMatrix_ConstructorMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 new file mode 100644 index 000000000..ee8c251ca --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_DBCMethods +USE BaseType, ONLY: CSRMatrix_ +USE GlobalData, ONLY: I4B +IMPLICIT NONE +PRIVATE +PUBLIC :: ApplyDBC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE ApplyDBC + MODULE SUBROUTINE csrMat_ApplyDBC(obj, dbcptrs) + CLASS(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: dbcptrs(:) + END SUBROUTINE csrMat_ApplyDBC +END INTERFACE ApplyDBC + +END MODULE CSRMatrix_DBCMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 new file mode 100644 index 000000000..531597018 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods.F90 @@ -0,0 +1,75 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_DiagonalScalingMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: DiagonalScaling + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE csrmat_DiagonalScaling_1(obj, side, OPERATOR) + CLASS(CSRMatrix_), INTENT(INOUT) :: obj + CHARACTER(*), INTENT(IN) :: side + !! LEFT + !! RIGHT + !! BOTH + CHARACTER(*), OPTIONAL, INTENT(IN) :: OPERATOR + !! + !! SQRT <-- default + !! NONE + !! + END SUBROUTINE csrmat_DiagonalScaling_1 +END INTERFACE + +INTERFACE DiagonalScaling + MODULE PROCEDURE csrmat_DiagonalScaling_1 +END INTERFACE DiagonalScaling + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE csrmat_DiagonalScaling_2(obj, side, diag, OPERATOR) + CLASS(CSRMatrix_), INTENT(INOUT) :: obj + CHARACTER(*), INTENT(IN) :: side + !! LEFT + !! RIGHT + !! BOTH + REAL(DFP), INTENT(IN) :: diag(:) + !! Use this diagonal if present + !! + CHARACTER(*), OPTIONAL, INTENT(IN) :: OPERATOR + !! + !! SQRT <-- default + !! NONE + !! + END SUBROUTINE csrmat_DiagonalScaling_2 +END INTERFACE + +INTERFACE DiagonalScaling + MODULE PROCEDURE csrmat_DiagonalScaling_2 +END INTERFACE DiagonalScaling + +END MODULE CSRMatrix_DiagonalScalingMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 new file mode 100644 index 000000000..b25445049 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetBlockColMethods.F90 @@ -0,0 +1,380 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE CSRMatrix_GetBlockColMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the col of a sparse matrix +! +!# Introduction +! +! - This routine returns the col of given block matrix +! - This routine is designed to handle block matrices, which +! means it only works when StorageFMT is DOF_FMT +! - ivar is the row number for the block matrix, whose col are to be +! extracting +! - the result is returned inside `value`. +! - `value` should be allocated +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn1(obj, ivar, iColumn, & + & VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: iColumn + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn1 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn1 +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the col of a sparse matrix +! +!# Introduction +! +! - This routine returns the col of given block matrix +! - This routine is designed to handle block matrices, which +! means it only works when StorageFMT is DOF_FMT +! - ivar is the row number for the block matrix, whose col are to be +! extracting +! - the result is returned inside `value`. +! - `value` should be allocated +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn1b(obj, ivar, iColumn, & + & VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: iColumn(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn1b +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn1b +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the col of a sparse matrix +! +!# Introduction +! +! - This routine returns the col of given block matrix +! - This routine is designed to handle block matrices, which +! means it only works when StorageFMT is DOF_FMT +! - ivar is the row number for the block matrix, whose col are to be +! extracting +! - the result is returned inside `value`. +! - `value` should be allocated +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn2(obj, ivar, nodenum, idof, & + & VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn2 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn2 +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, jvar, idof, and nodenum is used to calculate the index of +! physical variable jvar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn3(obj, ivar, jvar, nodenum, idof, & + & VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn3 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn3 +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, jvar, idof, and nodenum is used to calculate the index of +! physical variable jvar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn4(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn4 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn4 +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, jvar, idof, and nodenum is used to calculate the index of +! physical variable jvar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn5(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn5 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn5 +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, jvar, idof, and nodenum is used to calculate the index of +! physical variable jvar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn6(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn6 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn6 +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, jvar, idof, and nodenum is used to calculate the index of +! physical variable jvar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn7(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn7 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn7 +END INTERFACE getBlockColumn + +!---------------------------------------------------------------------------- +! getBlockColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, jvar, idof, and nodenum is used to calculate the index of +! physical variable jvar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockColumn8(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockColumn8 +END INTERFACE + +INTERFACE getBlockColumn + MODULE PROCEDURE csrMat_getBlockColumn8 +END INTERFACE getBlockColumn + +END MODULE CSRMatrix_GetBlockColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 new file mode 100644 index 000000000..adb44c6a9 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods.F90 @@ -0,0 +1,385 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_GetBlockRowMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of given block matrix +! - This routine is designed to handle block matrices, which +! means it only works when StorageFMT is DOF_FMT +! - jvar is the column number for the block matrix, whose row we are +! extracting +! - the result is returned inside `value`. +! - `value` should be allocated +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow1(obj, jvar, irow, VALUE, scale, & + & addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: irow + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow1 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow1 +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of given block matrix +! - This routine is designed to handle block matrices, which +! means it only works when StorageFMT is DOF_FMT +! - jvar is the column number for the block matrix, whose row we are +! extracting +! - the result is returned inside `value`. +! - `value` should be allocated +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow1b(obj, jvar, irow, VALUE, scale, & + & addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: irow(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow1b +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow1b +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of given block matrix +! - This routine is designed to handle block matrices, which +! means it only works when StorageFMT is DOF_FMT +! - jvar is the column number for the block matrix, whose row we are +! extracting +! - the result is returned inside `value`. +! - `value` should be allocated +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow2(obj, jvar, nodenum, idof, VALUE, & + & scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow2 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow2 +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number of physical variable ivar +! - `idof` should be between 1 and the total number of dof in ivar +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, ivar, idof, and nodenum is used to calculate the index of +! physical variable ivar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow3(obj, ivar, jvar, nodenum, idof, & + & VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow3 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow3 +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number of physical variable ivar +! - `idof` should be between 1 and the total number of dof in ivar +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, ivar, idof, and nodenum is used to calculate the index of +! physical variable ivar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow4(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow4 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow4 +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number of physical variable ivar +! - `idof` should be between 1 and the total number of dof in ivar +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, ivar, idof, and nodenum is used to calculate the index of +! physical variable ivar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow5(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow5 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow5 +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number of physical variable ivar +! - `idof` should be between 1 and the total number of dof in ivar +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, ivar, idof, and nodenum is used to calculate the index of +! physical variable ivar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow6(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow6 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow6 +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number of physical variable ivar +! - `idof` should be between 1 and the total number of dof in ivar +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, ivar, idof, and nodenum is used to calculate the index of +! physical variable ivar and its degree of freedom +! + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow7(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow7 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow7 +END INTERFACE getBlockRow + +!---------------------------------------------------------------------------- +! getBlockRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number of physical variable ivar +! - `idof` should be between 1 and the total number of dof in ivar +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +! Here, ivar, idof, and nodenum is used to calculate the index of +! physical variable ivar and its degree of freedom + +INTERFACE + MODULE SUBROUTINE csrMat_getBlockRow8(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_getBlockRow8 +END INTERFACE + +INTERFACE getBlockRow + MODULE PROCEDURE csrMat_getBlockRow8 +END INTERFACE getBlockRow + +END MODULE CSRMatrix_GetBlockRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 new file mode 100644 index 000000000..9b46a92e5 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetColMethods.F90 @@ -0,0 +1,394 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_GetColMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the column of a sparse matrix +! - This rouine does not care about the storage pattern +! - Therefore, it should be used with care. +! - The result is returned inside the value +! - `value` should be allocated +! - the size of `value` should be atleast the number of rows in csrmatrix +! +! If addContribution is not present +! then the this routine performs the following action +! +!```fortran +! DO i = 1, obj%csr%nrow +! value( i ) = 0.0_DFP +! DO j = obj%csr%IA( i ), obj%csr%IA( i+1 ) - 1 +! IF( obj%csr%JA(j) .EQ. iColumn ) value( i ) = obj%A( j ) +! END DO +! END DO +!``` + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn1(obj, iColumn, VALUE, scale, & + & addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iColumn + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn1 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the column of a sparse matrix +! - This rouine does not care about the storage pattern +! - Therefore, it should be used with care. +! - The result is returned inside the value +! - `value` should be allocated +! - the size of `value` should be atleast the number of rows in csrmatrix +! +! If addContribution is not present +! then the this routine performs the following action +! +!```fortran +! DO i = 1, obj%csr%nrow +! value( i ) = 0.0_DFP +! DO j = obj%csr%IA( i ), obj%csr%IA( i+1 ) - 1 +! IF( obj%csr%JA(j) .EQ. iColumn ) value( i ) = obj%A( j ) +! END DO +! END DO +!``` + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn1b(obj, iColumn, VALUE, scale, & + & addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iColumn(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn1b +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the `nodenum` and `idof`. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the column index from nodenum and idof +!@endnote + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn2(obj, nodenum, idof, VALUE, scale, & + & addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn2 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the `nodenum` and `idof`. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the column index from nodenum and idof +!@endnote + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn3(obj, nodenum, ivar, idof, VALUE, & + & scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn3 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the `nodenum` and `idof`. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the column index from nodenum and idof +!@endnote + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn4(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn4 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the `nodenum` and `idof`. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the column index from nodenum and idof +!@endnote + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn5(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn5 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the `nodenum` and `idof`. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the column index from nodenum and idof +!@endnote + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn6(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn6 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the `nodenum` and `idof`. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the column index from nodenum and idof +!@endnote + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn7(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn7 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! GetColumn@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the Column of a sparse matrix +! +!# Introduction +! +! - This routine returns the Column of a sparse matrix. The Column index is +! calculated using the `nodenum` and `idof`. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `iColumn` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the column index from nodenum and idof +!@endnote + +INTERFACE GetColumn + MODULE SUBROUTINE csrMat_GetColumn8(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE csrMat_GetColumn8 +END INTERFACE GetColumn + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE CSRMatrix_GetColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 new file mode 100644 index 000000000..1a66b9b33 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 @@ -0,0 +1,680 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_GetMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_, DOF_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetStorageFMT +PUBLIC :: OPERATOR(.storageFMT.) +PUBLIC :: OPERATOR(.MatrixProp.) +PUBLIC :: GetMatrixProp +PUBLIC :: GetDOFPointer +PUBLIC :: isSquare +PUBLIC :: isRectangle +PUBLIC :: GetColIndex +PUBLIC :: GetColNumber +PUBLIC :: OPERATOR(.startColumn.) +PUBLIC :: OPERATOR(.endColumn.) +PUBLIC :: GetSingleValue +PUBLIC :: Get +PUBLIC :: GetIA +PUBLIC :: GetJA +PUBLIC :: GetValue + +!---------------------------------------------------------------------------- +! GetIA +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get entry in IA + +INTERFACE GetIA + 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 GetIA + +!---------------------------------------------------------------------------- +! GetJA +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get entry in JA + +INTERFACE GetJA + 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 GetJA + +!---------------------------------------------------------------------------- +! GetSingleValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get single value + +INTERFACE GetSingleValue + 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 + +INTERFACE Get + MODULE PROCEDURE obj_GetSingleValue +END INTERFACE Get + +!---------------------------------------------------------------------------- +! GetSingleValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get single value + +INTERFACE GetSeveralValue + 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 + +INTERFACE Get + MODULE PROCEDURE obj_GetSeveralValue +END INTERFACE Get + +!---------------------------------------------------------------------------- +! GetStorageFMT +!---------------------------------------------------------------------------- + +INTERFACE GetStorageFMT + 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 GetStorageFMT + +INTERFACE OPERATOR(.storageFMT.) + MODULE PROCEDURE obj_GetStorageFMT +END INTERFACE OPERATOR(.storageFMT.) + +!---------------------------------------------------------------------------- +! GetMatrixProp +!---------------------------------------------------------------------------- + +INTERFACE GetMatrixProp + MODULE PURE FUNCTION obj_GetMatrixProp(obj) RESULT(ans) + TYPE(CSRMatrix_), TARGET, INTENT(IN) :: obj + CHARACTER(20) :: ans + END FUNCTION obj_GetMatrixProp +END INTERFACE GetMatrixProp + +INTERFACE OPERATOR(.MatrixProp.) + MODULE PROCEDURE obj_GetMatrixProp +END INTERFACE OPERATOR(.MatrixProp.) + +!---------------------------------------------------------------------------- +! GetDOFPointer +!---------------------------------------------------------------------------- + +INTERFACE GetDOFPointer + 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 GetDOFPointer + +!---------------------------------------------------------------------------- +! isSquare +!---------------------------------------------------------------------------- + +INTERFACE isSquare + MODULE PURE FUNCTION obj_isSquare(obj) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION obj_isSquare +END INTERFACE isSquare + +!---------------------------------------------------------------------------- +! isRectangle +!---------------------------------------------------------------------------- + +INTERFACE isRectangle + MODULE PURE FUNCTION obj_isRectangle(obj) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION obj_isRectangle +END INTERFACE isRectangle + +!---------------------------------------------------------------------------- +! GetColNumber +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the column number from JA. + +INTERFACE GetColNumber + 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 GetColNumber + +!---------------------------------------------------------------------------- +! GetColIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the starting and ending column index of irow + +INTERFACE GetColIndex + 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 GetColIndex + +!---------------------------------------------------------------------------- +! startColumn +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the starting column index of irow + +INTERFACE OPERATOR(.startColumn.) + MODULE PURE FUNCTION obj_startColumn(obj, irow) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B) :: ans + END FUNCTION obj_startColumn +END INTERFACE OPERATOR(.startColumn.) + +!---------------------------------------------------------------------------- +! endColumn +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the ending column index of irow + +INTERFACE OPERATOR(.endColumn.) + MODULE PURE FUNCTION obj_endColumn(obj, irow) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B) :: ans + END FUNCTION obj_endColumn +END INTERFACE OPERATOR(.endColumn.) + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: This subroutine Get the value in sparse matrix +! +!# Introduction +! +! - This subroutine Gets the value in [[CSRMatrix_]] +! - Shape( value ) = [SIZE(nodenum)*tdof, SIZE(nodenum)*tdof] +! - Usually `value` denotes the element matrix +! - Symbolic we are performing following task `obj(nodenum, nodenum)=value` + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE, nrow, ncol) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Get0 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Get the value in sparse matrix +! +!# Introduction +! +! This subroutine Gets the values in sparse matrix. +! +!$$ +! obj(Nptrs,Nptrs)=value(:,:) +!$$ +! +! - Usually `value(:,:)` represents the element finite element matrix +! - The shape of `value` should be the tdof*size(nodenum), tdof*size(nodenum) +! - `tdof` is the total degree of freedom in obj%csr%dof +! +! - `StorageFMT` denotes the storage format of `value` +! It can be `Nodes_FMT` or `DOF_FMT` +! +! - Usually, element matrix is stored with `DOF_FMT` + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: storageFMT + !! storage format of value (desired format of value) + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Get1 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Gets a single entry of sparse matrix +! +!# Introduction +! +! - This subroutine Gets a single entry of sparse matrix. +! - Before using this routine the user should be aware of the storage +! pattern of degree of freedom. +! - However, if total number of degrees of freedom is one then there is not +! need to worry. +! +!@warning +! This routine should be avoided by general user. +!@endwarning + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + !! row index + INTEGER(I4B), INTENT(IN) :: icolumn + !! column index + REAL(DFP), INTENT(INOUT) :: VALUE + !! value + END SUBROUTINE obj_Get2 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +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 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: Gets the specific row and column entry to a given value +! +!# Introduction +! +! - This routine Gets the specific row and column entry to a given value. +! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] +! method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Get3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Get2]] +!@endnote +! +!@note +! idof, jdof are continuously numbered, so if there are two +! or more physical variables, then idof and jdof of the second +! or later physical variables will not start from 1. +!@endnote + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, 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) :: iDOF + !! row degree of freedom + INTEGER(I4B), INTENT(IN) :: jDOF + !! col degree of freedom + REAL(DFP), INTENT(INOUT) :: VALUE + !! scalar value to be Get + END SUBROUTINE obj_Get3 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: This subroutine get the value from the sparse matrix +! +!# Introduction +! +! - This subroutine Gets the values from block sparse matrix. +! - The storage pattern of both sparse matrix and value +! (the element matrix) should be in `FMT_DOF`. +! +!$$ +! obj(Nptrs,Nptrs)=value(:,:) +!$$ + +INTERFACE GetValue + 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(:) + !! row node numbers + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! row physical variables + INTEGER(I4B), INTENT(IN) :: jvar + !! column physical variables + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + !! value + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Get4 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: Gets the specific row and column entry to a given value +! +!# Introduction +! +! - This routine Gets the specific row and column entry to a given value. +! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do the above task, routine employs [[DOF_Method:getNodeLoc]] method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Get3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Get3]] +!@endnote +! +!@note +! rowdof, coldof are continuously numbered, so if there are two +! or more physical variables, then rowdof and coldof of the second +! 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) + 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 + !! + 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(INOUT) :: VALUE + !! scalar value to be Get + END SUBROUTINE obj_Get5 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: Gets the specific row and column entry from a given value + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & + jvar, iDOF, jDOF, VALUE, nrow, ncol) + TYPE(CSRMatrix_), INTENT(IN) :: obj + !! block matrix field + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! row physical variables + INTEGER(I4B), INTENT(IN) :: jvar + !! column physical variable + INTEGER(I4B), INTENT(IN) :: iDOF + !! row degree of freedom + INTEGER(I4B), INTENT(IN) :: jDOF + !! col degree of freedom + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + !! Matrix value + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Get6 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: Gets the specific row and column entry from the matrix +! +!# Introduction +! +! - This routine Gets the specific row and column entry from the matrix. +! - The irow and icolumn index in `CSRMatrix_` are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do above task, the routine employs [[DOF_Method:getNodeLoc]] method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Get3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Get3]] +!@endnote +! +!@note +! rowdof, coldof are continuously numbered, so if there are two +! or more physical variables, then rowdof and coldof of the second +! 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) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! row physical variable + INTEGER(I4B), INTENT(IN) :: jvar + !! col physical variable + INTEGER(I4B), INTENT(IN) :: ispacecompo + !! row space component + INTEGER(I4B), INTENT(IN) :: itimecompo + !! row time component + INTEGER(I4B), INTENT(IN) :: jspacecompo + !! col space component + INTEGER(I4B), INTENT(IN) :: jtimecompo + !! col time component + REAL(DFP), INTENT(INOUT) :: VALUE + !! scalar value to be Get + END SUBROUTINE obj_Get7 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +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 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: Gets the specific row and column entry from the matrix +! +!# Introduction +! +! - 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) + TYPE(CSRMatrix_), INTENT(IN) :: obj1 + !! master object + TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 + !! slave object + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ivar1 + !! row physical variable obj1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: jvar1 + !! col physical variable obj1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ispacecompo1 + !! row space component obj1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: itimecompo1 + !! row time component obj1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: jspacecompo1 + !! col space component obj1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: jtimecompo1 + !! col time component obj1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ivar2 + !! row physical variable obj2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: jvar2 + !! col physical variable obj2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ispacecompo2 + !! row space component obj2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: itimecompo2 + !! row time component obj2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: jspacecompo2 + !! col space component obj2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: jtimecompo2 + !! col time component obj2 + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: ierr + !! Error code, if 0 no error, else error + END SUBROUTINE obj_Get8 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: Gets the specific row and column entry from the matrix +! +!# Introduction +! +! - 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) + TYPE(CSRMatrix_), INTENT(IN) :: obj1 + !! master object + TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 + !! slave object + INTEGER(I4B), INTENT(IN) :: idof1 + !! row space component obj1 + INTEGER(I4B), INTENT(IN) :: jdof1 + !! row time component obj1 + INTEGER(I4B), INTENT(IN) :: idof2 + !! col space component obj1 + INTEGER(I4B), INTENT(IN) :: jdof2 + !! col time component obj1 + INTEGER(I4B), INTENT(IN) :: tNodes1 + INTEGER(I4B), INTENT(IN) :: tNodes2 + END SUBROUTINE CSR2CSR_Get_Master +END INTERFACE + +END MODULE CSRMatrix_GetMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 new file mode 100644 index 000000000..a266d3b11 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetRowMethods.F90 @@ -0,0 +1,348 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_GetRowMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix +! - This rouine does not care about the storage pattern +! - Therefore, it should be used with care. +! - The result is returned inside the value +! - `value` should be allocated +! - the size of `value` should be atleast the number of columns in csrmatrix +! +! If addContribution is not present +! then the this routine performs the following action +! +!```fortran +! value = 0.0_DFP +! value(obj%csr%JA(a:b)) = obj%A( a:b ) +!``` + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow1(obj, irow, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + !! index of row in csr matrix + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow1 +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix +! - This rouine does not care about the storage pattern +! - Therefore, it should be used with care. +! - The result is returned inside the value +! - `value` should be allocated +! - the size of `value` should be atleast the number of columns in csrmatrix +! +! If addContribution is not present +! then the this routine performs the following action +! +!```fortran +! value = 0.0_DFP +! value(obj%csr%JA(a:b)) = obj%A( a:b ) +!``` + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow1b(obj, irow, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow(:) + !! index of row in csr matrix + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow1b +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the row index from nodenum and idof +!@endnote + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow2(obj, nodenum, idof, VALUE, scale, & + & addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow2 +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the row index from nodenum and idof +!@endnote + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow3(obj, nodenum, ivar, idof, VALUE, scale, & + & addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow3 +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the row index from nodenum and idof +!@endnote + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow4(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow4 +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the row index from nodenum and idof +!@endnote + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow5(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow5 +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the row index from nodenum and idof +!@endnote + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow6(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow6 +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the row index from nodenum and idof +!@endnote + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow7(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow7 +END INTERFACE GetRow + +!---------------------------------------------------------------------------- +! GetRow@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the row of a sparse matrix +! +!# Introduction +! +! - This routine returns the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. +! +!@note +! This routine calls [[DOF_Method:GetNodeLoc]] method to calculate +! the row index from nodenum and idof +!@endnote + +INTERFACE GetRow + MODULE SUBROUTINE obj_GetRow8(obj, nodenum, ivar, spacecompo, & + & timecompo, VALUE, scale, addContribution) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(INOUT) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + END SUBROUTINE obj_GetRow8 +END INTERFACE GetRow + +END MODULE CSRMatrix_GetRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 new file mode 100644 index 000000000..3ab0128e2 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_GetSubMatrixMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: GetSubMatrix + +!---------------------------------------------------------------------------- +! GetColumn@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the submatrix + +INTERFACE GetSubMatrix + 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 GetSubMatrix + +!---------------------------------------------------------------------------- +! GetColumn@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the submatrix + +INTERFACE GetSubMatrix + 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 GetSubMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE CSRMatrix_GetSubMatrixMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 new file mode 100644 index 000000000..8201feadc --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_ILUMethods.F90 @@ -0,0 +1,513 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_ILUMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_, RealMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: getILUT +PUBLIC :: getILUTP +PUBLIC :: getILUD +PUBLIC :: getILUDP +PUBLIC :: getILUK + +!---------------------------------------------------------------------------- +! getILUT@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUT precondition +! +!# Introduction +! +! This routine builds the ILUT precondition. Incomplete LU factorization with +! dual truncation mechanism. +! +! - `obj` matrix stored in Compressed Sparse Row format. +! - `lfil` = integer. The fill-in parameter. Each row of L and each row of U +! will have a maximum of lfil elements (excluding the diagonal element). lfil +! must be .ge. 0. +! - `droptol` = real*8. Sets the threshold for dropping small terms in the +! factorization. See below for details on dropping strategy. +! +! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing +! the L and U factors together. The diagonal (stored in ALU(1:n) ) is +! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L +! (excluding the diagonal entry=1) followed by the ith row of U. +! - JU = integer array of length n containing the pointers to the beginning +! of each row of U in the matrix ALU,JLU. +! +! The diagonal elements of the input matrix must be nonzero (at least +! 'structurally'). Dual drop strategy works as follows: +! +! - Theresholding in L and U as set by `droptol`. Any element whose +! MAGNITUDE is less than some tolerance (relative to the abs value of +! diagonal element in U) is dropped. +! - Keeping only the largest `lfil` elements in the ith row of L and the +! largest `lfil` elements in the ith row of `U` (excluding diagonal elements). +! - Flexibility: one can use `droptol=0` to get a strategy based on +! keeping the largest elements in each row of `L` and `U`. +! - Taking `droptol .ne. 0` but `lfil=n` will give the usual threshold +! strategy (however, fill-in is then mpredictible). + +INTERFACE + MODULE SUBROUTINE csrMat_getILUT1(obj, ALU, JLU, JU, lfil, droptol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) + INTEGER(I4B), INTENT(IN) :: lfil + REAL(DFP), INTENT(IN) :: droptol + END SUBROUTINE csrMat_getILUT1 +END INTERFACE + +INTERFACE getILUT + MODULE PROCEDURE csrMat_getILUT1 +END INTERFACE getILUT + +!---------------------------------------------------------------------------- +! getILUT@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUT precondition +! +!# Introduction +! This routine builds the ILUT precondition. Incomplete LU factorization with +! dual truncation mechanism. +! +! This routine calls `csrMat_getILUT1`. The only difference between +! this routine and `csrMat_getILUT1` is that the present routine +! returns ILU data in `CSRMatrix_` format. However, the `csrMat_getILUT1` +! returns the ILU data in MSR format. +! +! This routine calls `MSRCSR` routine from Sparsekit lib. + +INTERFACE + MODULE SUBROUTINE csrMat_getILUT2(obj, Pmat, lfil, droptol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat + INTEGER(I4B), INTENT(IN) :: lfil + REAL(DFP), INTENT(IN) :: droptol + END SUBROUTINE csrMat_getILUT2 +END INTERFACE + +INTERFACE getILUT + MODULE PROCEDURE csrMat_getILUT2 +END INTERFACE getILUT + +!---------------------------------------------------------------------------- +! getILUTP@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUT precondition +! +!# Introduction +! +! This routine builds the ILUTP precondition. ILUT with pivoting, incomplete +! LU factorization with dual truncation mechanism +! +! - `obj` matrix stored in Compressed Sparse Row format. +! - `lfil` denotes the fill-in parameter. Each row of L and each row of U +! will have a maximum of lfil elements (excluding the diagonal element). +! lfil +! must be .ge. 0. +! - `droptol` sets the threshold for dropping small terms in the +! factorization. See below for details on dropping strategy. +! - `permtol` = tolerance ratio used to determine whether or not to permute +! two columns. At step i columns i and j are permuted when +! +! `abs(a(i,j))*permtol .gt. abs(a(i,i))`. +! +! - permtol=0 implies never permute; good values 0.1 to 0.01 +! +! - `mbloc` = if desired, permuting can be done only within the diagonal +! blocks of size mbloc. Useful for PDE problems with several degrees of +! freedom.. If feature not wanted take mbloc=n. +! +! `iperm` = contains the permutation arrays. iperm(1:n) = old numbers of +! unknowns iperm(n+1:2*n) = reverse permutation = new unknowns. +! +! TO AVOID PERMUTING THE SOLUTION VECTORS ARRAYS FOR EACH LU-SOLVE, THE +! MATRIX A IS PERMUTED ON RETURN. All column indices are changed. SIMILARLY +! FOR THE U MATRIX. To permute the matrix back to its original state use the +! loop: +! +!```fortran +! do k=ia(1), ia(n+1)-1 +! ja(k) = iperm(ja(k)) +! enddo +!``` +! +! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing +! the L and U factors together. The diagonal (stored in ALU(1:n) ) is +! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L +! (excluding the diagonal entry=1) followed by the ith row of U. +! - JU = integer array of length n containing the pointers to the beginning +! of each row of U in the matrix ALU,JLU. +! +! - Theresholding in L and U as set by `droptol`. Any element whose +! MAGNITUDE is less than some tolerance (relative to the abs value of +! diagonal element in U) is dropped. +! - Keeping only the largest `lfil` elements in the ith row of L and the +! largest `lfil` elements in the ith row of `U` (excluding diagonal elements). +! - Flexibility: one can use `droptol=0` to get a strategy based on +! keeping the largest elements in each row of `L` and `U`. +! - Taking `droptol .ne. 0` but `lfil=n` will give the usual threshold +! strategy (however, fill-in is then mpredictible). + +INTERFACE + MODULE SUBROUTINE csrMat_getILUTP1(obj, ALU, JLU, JU, lfil, droptol, & + & permtol, mbloc, IPERM) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) + INTEGER(I4B), INTENT(IN) :: lfil + REAL(DFP), INTENT(IN) :: droptol + REAL(DFP), INTENT(IN) :: permtol + INTEGER(I4B), INTENT(IN) :: mbloc + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) + END SUBROUTINE csrMat_getILUTP1 +END INTERFACE + +INTERFACE getILUTP + MODULE PROCEDURE csrMat_getILUTP1 +END INTERFACE getILUTP + +!---------------------------------------------------------------------------- +! getILUTP@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUT precondition +! +!# Introduction +! This routine builds the ILUTP precondition. ILUT with pivoting, incomplete +! LU factorization with dual truncation mechanism +! +! This routine calls `csrMat_getILUTP1`. +! This routine calls `MSRCSR` from Sparsekit + +INTERFACE + MODULE SUBROUTINE csrMat_getILUTP2(obj, Pmat, lfil, droptol, permtol, & + & mbloc, IPERM) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat + INTEGER(I4B), INTENT(IN) :: lfil + REAL(DFP), INTENT(IN) :: droptol + REAL(DFP), INTENT(IN) :: permtol + INTEGER(I4B), INTENT(IN) :: mbloc + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) + END SUBROUTINE csrMat_getILUTP2 +END INTERFACE + +INTERFACE getILUTP + MODULE PROCEDURE csrMat_getILUTP2 +END INTERFACE getILUTP + +!---------------------------------------------------------------------------- +! getILUTD@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUT precondition +! +!# Introduction +! +! This routine computes the ILU factorization with standard threshold +! dropping: at ith step of elimination, an element a(i,j) in row i is dropped +! if it satisfies the criterion: +! +! - abs(a(i,j)) < tol, that is, average magnitude of elements in row i of A +! - There is no control on memory size required for the factors as is done in +! ILUT. +! - This routines computes also various diagonal compensation ILU's such +! MILU. These are defined through the parameter `alph` +! +! - alph = diagonal compensation parameter, alph*(sum of all dropped out +! elements in a given row) is added to the diagonal element of U of the +! factorization +! - alph = 0 means the scheme is ILU with threshold, +! - alph = 1 means the scheme is MILU with threshold. +! - droptol = Threshold parameter for dropping small terms in the +! factorization. During the elimination, a term a(i,j) is dropped whenever abs +! (a(i,j)) .lt. tol * [weighted norm of row i]. Here weighted norm = 1-norm / +! number of nnz elements in the row. +! - `obj` matrix stored in Compressed Sparse Row format. +! +! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing +! the L and U factors together. The diagonal (stored in ALU(1:n) ) is +! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L +! (excluding the diagonal entry=1) followed by the ith row of U. +! - JU = integer array of length n containing the pointers to the beginning +! of each row of U in the matrix ALU,JLU. +! +! - Theresholding in L and U as set by `droptol`. Any element whose +! MAGNITUDE is less than some tolerance (relative to the abs value of +! diagonal element in U) is dropped. + +INTERFACE + MODULE SUBROUTINE csrMat_getILUD1(obj, ALU, JLU, JU, alpha, droptol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: droptol + END SUBROUTINE csrMat_getILUD1 +END INTERFACE + +INTERFACE getILUD + MODULE PROCEDURE csrMat_getILUD1 +END INTERFACE getILUD + +!---------------------------------------------------------------------------- +! ILUD@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUT precondition +! +!# Introduction +! +! This routine computes the ILU factorization with standard threshold +! dropping: at ith step of elimination, an element a(i,j) in row i is dropped +! if it satisfies the criterion: +! +! This routine is similar to csrMat_getILUD1, but in this case the +! matrix PMat is in CSRMatrix_ format, and it contains the ILU factorization +! + +INTERFACE + MODULE SUBROUTINE csrMat_getILUD2(obj, Pmat, alpha, droptol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: droptol + END SUBROUTINE csrMat_getILUD2 +END INTERFACE + +INTERFACE getILUD + MODULE PROCEDURE csrMat_getILUD2 +END INTERFACE getILUD + +!---------------------------------------------------------------------------- +! getILUDP@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUDP precondition +! +! # Introduction +! +! This routine computes ILUDP preconditioner, incomplete LU factorization +! with standard droppoing strategy. +! +! - `droptol` = tolerance used for dropping elements in L and U. elements are +! dropped if they are .lt. norm(row) x droptol row = row being eliminated +! - `permtol` = tolerance ratio used for determning whether to permute two +! columns. Two columns are permuted only when abs(a(i,j))*permtol .gt. abs(a +! (i,i)) [0 --> never permute; good values 0.1 to 0.01] +! - `mbloc` = if desired, permuting can be done only within the diagonal +! blocks of size mbloc. Useful for PDE problems with several degrees of +! freedom.. If feature not wanted take mbloc=n. +! +! - iperm = contains the permutation arrays, iperm(1:n) = old numbers of +! unknowns, iperm(n+1:2*n) = reverse permutation = new unknowns. +! +! - abs(a(i,j)) < droptol, that is, average magnitude of elements in row i +! of A +! - alph = diagonal compensation parameter, alph*(sum of all dropped out +! elements in a given row) is added to the diagonal element of U of the +! factorization +! - alph = 0 means the scheme is ILU with threshold, +! - alph = 1 means the scheme is MILU with threshold. +! - droptol = Threshold parameter for dropping small terms in the +! factorization. During the elimination, a term a(i,j) is dropped whenever abs +! (a(i,j)) .lt. droptol * [weighted norm of row i]. Here weighted norm = +! 1-norm / number of nnz elements in the row. +! - `obj` matrix stored in Compressed Sparse Row format. +! +! - `ALU,JLU`, matrix stored in Modified Sparse Row (MSR) Format containing +! the L and U factors together. The diagonal (stored in ALU(1:n) ) is +! inverted. Each ith row of the ALU,JLU matrix contains the ith row of L +! (excluding the diagonal entry=1) followed by the ith row of U. +! - JU = integer array of length n containing the pointers to the beginning +! of each row of U in the matrix ALU,JLU. +! +! - Theresholding in L and U as set by `droptol`. Any element whose +! MAGNITUDE is less than some tolerance (relative to the abs value of +! diagonal element in U) is dropped. + +INTERFACE + MODULE SUBROUTINE csrMat_getILUDP1(obj, ALU, JLU, JU, alpha, droptol, & + & permtol, mbloc, IPERM) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: droptol + REAL(DFP), INTENT(IN) :: permtol + INTEGER(I4B), INTENT(IN) :: mbloc + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) + END SUBROUTINE csrMat_getILUDP1 +END INTERFACE + +INTERFACE getILUDP + MODULE PROCEDURE csrMat_getILUDP1 +END INTERFACE getILUDP + +!---------------------------------------------------------------------------- +! getILUTDP@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUDP precondition +! +!# Introduction +! +! This routine computes ILUDP preconditioner, incomplete LU factorization +! with standard droppoing strategy. +! +! This routine is like csrMat_getILUDP1, but in this case we ILU +! matrix is returned as an instance of `CSRMatrix_`. + +INTERFACE + MODULE SUBROUTINE csrMat_getILUDP2(obj, Pmat, alpha, droptol, & + & permtol, mbloc, IPERM) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: droptol + REAL(DFP), INTENT(IN) :: permtol + INTEGER(I4B), INTENT(IN) :: mbloc + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IPERM(:) + END SUBROUTINE csrMat_getILUDP2 +END INTERFACE + +INTERFACE getILUDP + MODULE PROCEDURE csrMat_getILUDP2 +END INTERFACE getILUDP + +!---------------------------------------------------------------------------- +! getILUK@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUK precondition +! +!# Introduction +! +! This routine returns the ILU WITH LEVEL OF FILL-IN OF K (ILU(k)) +! +! - `lfil` = integer. The fill-in parameter. Each element whose leve-of-fill +! exceeds lfil during the ILU process is dropped. lfil must be .ge. 0 +! - droptol = real*8. Sets the threshold for dropping small terms in the +! factorization. See below for details on dropping strategy. +! - `ALU,JLU` = matrix stored in Modified Sparse Row (MSR) format containing +! the L and U factors together. The diagonal (stored in alu(1:n) ) is +! inverted. Each i-th row of the `ALU,JLU` matrix contains the i-th row of L +! (excluding the diagonal entry=1) followed by the i-th row of `U`. +! - `JU` = integer array of length n containing the pointers to the beginning +! of each row of `U` in the matrix `ALU,JLU`. +! - `LEVS` = integer (work) array of size `IWK`, which contains the levels of +! each element in `ALU, JLU`. +! +! @note +! This is not implemented efficiently storage-wise. For example: Only the +! part of the array levs(*) associated with the U-matrix is needed in the +! routine.. So some storage can be saved if needed. The levels of fills in +! the LU matrix are output for information only -- they are not needed by +! LU-solve. +! @endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getILUK1(obj, ALU, JLU, JU, lfil, LEVS) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ALU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JLU(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: JU(:) + INTEGER(I4B), INTENT(IN) :: lfil + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: LEVS(:) + END SUBROUTINE csrMat_getILUK1 +END INTERFACE + +INTERFACE getILUK + MODULE PROCEDURE csrMat_getILUK1 +END INTERFACE getILUK + +!---------------------------------------------------------------------------- +! getILUK@ILUTMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 July 2021 +! summary: Returns the ILUK precondition +! +!# Introduction +! +! This routine returns the ILU WITH LEVEL OF FILL-IN OF K (ILU(k)) +! +! - `lfil` = integer. The fill-in parameter. Each element whose leve-of-fill +! exceeds lfil during the ILU process is dropped. lfil must be .ge. 0 +! - droptol = real*8. Sets the threshold for dropping small terms in the +! factorization. See below for details on dropping strategy. +! - `ALU,JLU` = matrix stored in Modified Sparse Row (MSR) format containing +! the L and U factors together. The diagonal (stored in alu(1:n) ) is +! inverted. Each i-th row of the `ALU,JLU` matrix contains the i-th row of L +! (excluding the diagonal entry=1) followed by the i-th row of `U`. +! - `JU` = integer array of length n containing the pointers to the beginning +! of each row of `U` in the matrix `ALU,JLU`. +! - `LEVS` = integer (work) array of size `IWK`, which contains the levels of +! each element in `ALU, JLU`. +! +! @note +! This is not implemented efficiently storage-wise. For example: Only the +! part of the array levs(*) associated with the U-matrix is needed in the +! routine.. So some storage can be saved if needed. The levels of fills in +! the LU matrix are output for information only -- they are not needed by +! LU-solve. +! @endnote + +INTERFACE + MODULE SUBROUTINE csrMat_getILUK2(obj, Pmat, lfil, LEVS) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: Pmat + INTEGER(I4B), INTENT(IN) :: lfil + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: LEVS(:) + END SUBROUTINE csrMat_getILUK2 +END INTERFACE + +INTERFACE getILUK + MODULE PROCEDURE csrMat_getILUK2 +END INTERFACE getILUK + +END MODULE CSRMatrix_ILUMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 new file mode 100644 index 000000000..e6fb1030d --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_IOMethods.F90 @@ -0,0 +1,110 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_IOMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: Display +PUBLIC :: SPY +PUBLIC :: IMPORT + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine display the content of sparse matrix +! +!# Introduction +! +! This subroutine display the content of sparse matrix +! - In this subroutine `dump` routine from sparsekit lib is called + +INTERFACE Display + MODULE SUBROUTINE obj_Display(obj, Msg, UnitNo) + TYPE(CSRMatrix_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: Msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + END SUBROUTINE obj_Display +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Spy@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Prints the structure of sparse matrix in pdf/svg/png format. + +INTERFACE SPY + MODULE SUBROUTINE obj_SPY(obj, filename, ext) + TYPE(CSRMatrix_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: filename + CHARACTER(*), INTENT(IN) :: ext + END SUBROUTINE obj_SPY +END INTERFACE SPY + +!---------------------------------------------------------------------------- +! IMPORT@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Jul 2021 +! summary: Import sparse matrix from a file +! +!# Introduction +! +! this routine will open the file and read the data and close the file +! Currently only matFormat="SPARSE_FMT_COO" is supported. +! + +INTERFACE IMPORT + MODULE SUBROUTINE obj_Import(obj, fileName, matFormat) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + CHARACTER(*), INTENT(IN) :: fileName + !! File from which data should be read. This file will + !! be opened by the this routine on entry. This file + !! will be closed on return. + INTEGER(I4B), INTENT(IN) :: matFormat + !! Currently only `SPARSE_FMT_COO` is supported + END SUBROUTINE obj_Import +END INTERFACE IMPORT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-19 +! summary: Deprecated version of obj_Import + +INTERFACE + MODULE SUBROUTINE deprecated_obj_Import(obj, fileName, matFormat) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + CHARACTER(*), INTENT(IN) :: fileName + !! File from which data should be read. This file will + !! be opened by the this routine on entry. This file + !! will be closed on return. + INTEGER(I4B), INTENT(IN) :: matFormat + !! Currently only `SPARSE_FMT_COO` is supported + END SUBROUTINE deprecated_obj_Import +END INTERFACE + +END MODULE CSRMatrix_IOMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 new file mode 100644 index 000000000..d60de237f --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_LUSolveMethods.F90 @@ -0,0 +1,140 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_LUSolveMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: LUSOLVE +PUBLIC :: LUTSOLVE + +!---------------------------------------------------------------------------- +! LUSOLVE@LUsolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jul 2021 +! summary: This routine solves the LU x = y +! +! This routine solves the system `LU x = y`, given an LU decomposition of a +! matrix stored in (`ALU, JLU, JU`) modified sparse row format (MSR). +! This ALU, JLU, JU are created by calling ILUT methods described above + +INTERFACE + MODULE SUBROUTINE csrMat_LUSOLVE(sol, rhs, alu, jlu, ju, isTranspose) + REAL(DFP), INTENT(INOUT) :: sol(:) + REAL(DFP), INTENT(IN) :: rhs(:) + REAL(DFP), INTENT(IN) :: alu(:) + INTEGER(I4B), INTENT(IN) :: jlu(:) + INTEGER(I4B), INTENT(IN) :: ju(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! if transpose is present, and it is true then + !! LUTSolve is called. + !! default is isTranspose = .FALSE. + END SUBROUTINE csrMat_LUSOLVE +END INTERFACE + +INTERFACE LUSOLVE + MODULE PROCEDURE csrMat_LUSOLVE +END INTERFACE LUSOLVE + +!---------------------------------------------------------------------------- +! LUTSOLVE@ILUT +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jul 2021 +! summary: This routine solves the (LU)^T x = y +! +! This routine solves the system `(LU)^T x = y`, given an LU decomposition of +! a matrix stored in (`ALU, JLU, JU`) modified sparse row format (MSR). +! This ALU, JLU, JU are created by calling ILUT methods described above + +INTERFACE + MODULE SUBROUTINE csrMat_LUTSOLVE(sol, rhs, alu, jlu, ju) + REAL(DFP), INTENT(INOUT) :: sol(:) + REAL(DFP), INTENT(IN) :: rhs(:) + REAL(DFP), INTENT(IN) :: alu(:) + INTEGER(I4B), INTENT(IN) :: jlu(:) + INTEGER(I4B), INTENT(IN) :: ju(:) + END SUBROUTINE csrMat_LUTSOLVE +END INTERFACE + +INTERFACE LUTSOLVE + MODULE PROCEDURE csrMat_LUTSOLVE +END INTERFACE LUTSOLVE + +! !---------------------------------------------------------------------------- +! ! LSolve@LinAlg +! !---------------------------------------------------------------------------- + +! !> author: Vikas Sharma, Ph. D. +! ! date: 14 July 2021 +! ! summary: Solve Lx = y by forward elimination technique will be used +! ! +! !# Introduction +! ! This subroutine Solve Lx = y by forward elimination technique will be used +! ! Here L is lower triangular matrix with unit diag in CSR format +! +! INTERFACE +! MODULE SUBROUTINE csrMat_LSolve( obj, x, y ) +! TYPE( CSRMatrix_ ), INTENT( IN ) :: obj +! !! Sparse matrix +! REAL( DFP ), INTENT( IN ) :: y( : ) +! !! This contains RHS +! REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: x( : ) +! !! This contains solution +! END SUBROUTINE csrMat_LSolve +! END INTERFACE +! +! INTERFACE LSolve +! MODULE PROCEDURE csrMat_LSolve +! END INTERFACE LSolve +! +! PUBLIC :: LSolve + +!---------------------------------------------------------------------------- +! ! USolve@LinAlg +! !---------------------------------------------------------------------------- + +! !> author: Vikas Sharma, Ph. D. +! ! date: 14 July 2021 +! ! summary: Solve Ux = y by backward elimination technique will be used +! ! +! !# Introduction +! !- This subroutine solve Ux = y by backward elimination technique will be +! ! used +! ! - Here U is upper triangular matrix with unit diag in CSR format + +! INTERFACE +! MODULE SUBROUTINE csrMat_USolve( obj, x, y ) +! TYPE( CSRMatrix_ ), INTENT( IN ) :: obj +! !! Sparse matrix in upper triangle form +! REAL( DFP ), INTENT( IN ) :: y( : ) +! !! RHS +! REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: x( : ) +! !! Solution +! END SUBROUTINE csrMat_USolve +! END INTERFACE + +! INTERFACE USolve +! MODULE PROCEDURE csrMat_USolve +! END INTERFACE USolve + +! PUBLIC :: USolve +END MODULE CSRMatrix_LUSolveMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 new file mode 100644 index 000000000..9162e96f7 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_LinSolveMethods.F90 @@ -0,0 +1,162 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_LinSolveMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: CSRMatrixLinSolveInitiate +PUBLIC :: CSRMatrix_GMRES +PUBLIC :: CSRMatrix_CG +PUBLIC :: CSRMatrix_BiCGStab + +INTEGER(I4B), PARAMETER :: IPAR_LENGTH = 14 +INTEGER(I4B), PARAMETER :: FPAR_LENGTH = 14 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-03-14 +! summary: Return integer code of linear solver from character name + +INTERFACE + MODULE PURE FUNCTION GetLinSolverCodeFromName(name) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: name + INTEGER(I4B) :: ans + END FUNCTION GetLinSolverCodeFromName +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-03-14 +! summary: Return character name of linear solver from integer code + +INTERFACE + MODULE PURE FUNCTION GetLinSolverNameFromCode(name) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: name + CHARACTER(15) :: ans + END FUNCTION GetLinSolverNameFromCode +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE CSRMatrixLinSolveInitiate + MODULE SUBROUTINE CSRMatrix_LinSolve_Initiate(ipar, fpar, W, n, & + & solverName, preConditionOption, convergenceIn, convergenceType, & + & maxIter, KrylovSubspaceSize, rtol, atol, relativeToRHS) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: ipar(:) + !! Integer PARAMETER + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: fpar(:) + !! Read PARAMETER + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: W(:) + !! Workspace requirement + INTEGER(I4B), INTENT(IN) :: n + !! size of the problem + INTEGER(I4B), OPTIONAL, INTENT(in) :: solverName + !! solverName + INTEGER(I4B), OPTIONAL, INTENT(in) :: preconditionOption + !! preconditionOption + !! NO_PRECONDITION + !! LEFT_PRECONDITION + !! RIGHT_PRECONDITON + !! LEFT_RIGHT_PRECONDITION + INTEGER(I4B), OPTIONAL, INTENT(in) :: convergenceIn + !! convergenceInRes + !! convergenceInSol + INTEGER(I4B), OPTIONAL, INTENT(in) :: convergenceType + !! absoluteConvergence + !! relativeConvergence + INTEGER(I4B), OPTIONAL, INTENT(in) :: maxIter + !! maximum number of iterations + INTEGER(I4B), OPTIONAL, INTENT(in) :: KrylovSubspaceSize + !! Size of KrylovSubspace + REAL(DFP), OPTIONAL, INTENT(in) :: rtol + !! relative tolerance + REAL(DFP), OPTIONAL, INTENT(in) :: atol + !! absolute tolerance + LOGICAL(LGT), OPTIONAL, INTENT(in) :: relativeToRHS + !! true if convergence is checked relatative to RHS + END SUBROUTINE CSRMatrix_LinSolve_Initiate +END INTERFACE CSRMatrixLinSolveInitiate + +!---------------------------------------------------------------------------- +! LinSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-03-14 +! summary: Solver + +INTERFACE + MODULE SUBROUTINE CSRMatrix_GMRES(obj, sol, rhs, ipar, fpar, W) + CLASS(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(INOUT) :: sol(:) + REAL(DFP), INTENT(INOUT) :: rhs(:) + INTEGER(I4B), INTENT(INOUT) :: ipar(:) + REAL(DFP), INTENT(INOUT) :: fpar(:) + REAL(DFP), INTENT(INOUT) :: W(:) + END SUBROUTINE CSRMatrix_GMRES +END INTERFACE + +!---------------------------------------------------------------------------- +! LinSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-03-14 +! summary: Solver + +INTERFACE + MODULE SUBROUTINE CSRMatrix_CG(obj, sol, rhs, ipar, fpar, W) + CLASS(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(INOUT) :: sol(:) + REAL(DFP), INTENT(INOUT) :: rhs(:) + INTEGER(I4B), INTENT(INOUT) :: ipar(:) + REAL(DFP), INTENT(INOUT) :: fpar(:) + REAL(DFP), INTENT(INOUT) :: W(:) + END SUBROUTINE CSRMatrix_CG +END INTERFACE + +!---------------------------------------------------------------------------- +! LinSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-03-14 +! summary: Solver + +INTERFACE + MODULE SUBROUTINE CSRMatrix_BiCGStab(obj, sol, rhs, ipar, fpar, W) + CLASS(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(INOUT) :: sol(:) + REAL(DFP), INTENT(INOUT) :: rhs(:) + INTEGER(I4B), INTENT(INOUT) :: ipar(:) + REAL(DFP), INTENT(INOUT) :: fpar(:) + REAL(DFP), INTENT(INOUT) :: W(:) + END SUBROUTINE CSRMatrix_BiCGStab +END INTERFACE + +END MODULE CSRMatrix_LinSolveMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 new file mode 100644 index 000000000..674e73388 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 @@ -0,0 +1,257 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_MatVecMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: MatVec +PUBLIC :: AMatVec +PUBLIC :: AtMatvec +PUBLIC :: CSRMatrixAMUX +PUBLIC :: CSRMatrixAMUX_Add +PUBLIC :: CSRMatrixATMUX +PUBLIC :: CSRMatrixATMUX_Add + +!---------------------------------------------------------------------------- +! CSRMatrixAMUX +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: Mat vec + +! y = A *x +INTERFACE CSRMatrixAMUX + MODULE SUBROUTINE CSRMatrixAMUX1(n, x, y, a, ja, ia) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + END SUBROUTINE CSRMatrixAMUX1 +END INTERFACE CSRMatrixAMUX + +!---------------------------------------------------------------------------- +! CSRMatrixAMUX +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: y = s * A*x + +INTERFACE CSRMatrixAMUX + MODULE SUBROUTINE CSRMatrixAMUX2(n, x, y, a, ja, ia, s) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + REAL(DFP), INTENT(IN) :: s + END SUBROUTINE CSRMatrixAMUX2 +END INTERFACE CSRMatrixAMUX + +!---------------------------------------------------------------------------- +! CSRMatrixAMUX_Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: y = y+s * A*x + +INTERFACE CSRMatrixAMUX_Add + MODULE SUBROUTINE CSRMatrixAMUX_Add_1(n, x, y, a, ja, ia, s) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + REAL(DFP), INTENT(IN) :: s + END SUBROUTINE CSRMatrixAMUX_Add_1 +END INTERFACE CSRMatrixAMUX_Add + +!---------------------------------------------------------------------------- +! CSRMatrixATMUX +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: y = A^T *x + +INTERFACE CSRMatrixATMUX + MODULE SUBROUTINE CSRMatrixATMUX1(n, x, y, a, ja, ia) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + END SUBROUTINE CSRMatrixATMUX1 +END INTERFACE CSRMatrixATMUX + +!---------------------------------------------------------------------------- +! CSRMatrixATMUX +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: y = s * A^T*x + +INTERFACE CSRMatrixATMUX + MODULE SUBROUTINE CSRMatrixATMUX2(n, x, y, a, ja, ia, s) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + REAL(DFP), INTENT(IN) :: s + END SUBROUTINE CSRMatrixATMUX2 +END INTERFACE CSRMatrixATMUX + +!---------------------------------------------------------------------------- +! CSRMatrixATMUX_Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: y = y+s * A^T*x + +INTERFACE CSRMatrixATMUX_Add + MODULE SUBROUTINE CSRMatrixATMUX_Add_1(n, x, y, a, ja, ia, s) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + REAL(DFP), INTENT(IN) :: a(:) + INTEGER(I4B), INTENT(IN) :: ja(:) + INTEGER(I4B), INTENT(IN) :: ia(:) + REAL(DFP), INTENT(IN) :: s + END SUBROUTINE CSRMatrixATMUX_Add_1 +END INTERFACE CSRMatrixATMUX_Add + +!---------------------------------------------------------------------------- +! AMatVec1@MatvecMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 july 2021 +! summary: This routine computes y = A*x + +INTERFACE AMatVec + MODULE SUBROUTINE csrMat_AMatVec1(obj, x, y, addContribution, scale) + TYPE(CSRMatrix_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + END SUBROUTINE csrMat_AMatVec1 +END INTERFACE AMatVec + +!---------------------------------------------------------------------------- +! AMatVec2@MatvecMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 july 2021 +! summary: This routine computes y = A*x, A is in MSR format + +INTERFACE AMatVec + MODULE SUBROUTINE csrMat_AMatVec2(A, JA, x, y, addContribution, scale) + REAL(DFP), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: JA(:) + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + END SUBROUTINE csrMat_AMatVec2 +END INTERFACE AMatvec + +!---------------------------------------------------------------------------- +! AtMatvec@MatvecMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 july 2021 +! summary: This routine computes y = A*x + +INTERFACE AtMatvec + MODULE SUBROUTINE csrMat_AtMatvec(obj, x, y, addContribution, scale) + TYPE(CSRMatrix_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + END SUBROUTINE csrMat_AtMatvec +END INTERFACE AtMatvec + +!---------------------------------------------------------------------------- +! Matvec@MatVec +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This routine performs matrix-vector multiplication +! +!# Introduction +! y = A*x + +INTERFACE MatVec + MODULE SUBROUTINE csrMat_MatVec1(obj, x, y, isTranspose, addContribution, & + & scale) + TYPE(CSRMatrix_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + END SUBROUTINE csrMat_MatVec1 +END INTERFACE MatVec + +!---------------------------------------------------------------------------- +! Matvec@MatVec +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This routine performs matrix-vector multiplication +! +!# Introduction +! +! y = A*x + +INTERFACE MatVec + MODULE SUBROUTINE csrMat_MatVec2(A, JA, x, y, addContribution, & + & scale) + REAL(DFP), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: JA(:) + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + END SUBROUTINE csrMat_MatVec2 +END INTERFACE MatVec + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE CSRMatrix_MatVecMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 b/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 new file mode 100644 index 000000000..56ef274ed --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_MatrixMarketIO.F90 @@ -0,0 +1,97 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_MatrixMarketIO +USE GlobalData, ONLY: DFPC, I4B, DFP, LGT, stdout, stderr, stdin +IMPLICIT NONE +PRIVATE + +INTERFACE + MODULE SUBROUTINE ParseHeader(aline, h1, h2, h3, h4, h5, ierr, errmsg) + CHARACTER(*), INTENT(IN) :: aline + CHARACTER(*), INTENT(OUT) :: h1 + CHARACTER(*), INTENT(OUT) :: h2 + CHARACTER(*), INTENT(OUT) :: h3 + CHARACTER(*), INTENT(OUT) :: h4 + CHARACTER(*), INTENT(OUT) :: h5 + INTEGER(I4B), INTENT(OUT) :: ierr + CHARACTER(*), INTENT(OUT) :: errmsg + END SUBROUTINE ParseHeader +END INTERFACE + +!---------------------------------------------------------------------------- +! MMRead +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-19 +! summary: Read sparse matrix from matrix market format. +! +!# Introduction +! +! This routine reads the sparse matrix from matrix market format. +! +! The matrix market format is described here: +! https://math.nist.gov/MatrixMarket/formats.html +! +! - Matrix should contains real values +! - The forth argumnet of header should be real + +INTERFACE + MODULE SUBROUTINE MMRead(unitno, rep, field, symm, rows, cols, nnz, & + & indx, jndx, rval, ival, cval) + INTEGER(I4B), INTENT(IN) :: unitno + !! unit number of file + CHARACTER(*), INTENT(OUT) :: rep + !! coordinate <-- sparse array in COO format + !! array <-- dense array + CHARACTER(*), INTENT(OUT) :: field + !! real + !! integer + !! pattern + !! complex + CHARACTER(*), INTENT(OUT) :: symm + !! symmetric <-- if the matrix is symmetric + !! skew-symmetric <-- if the matrix is skew-symmetric + !! general <-- if the matrix is general + !! hermitian <-- if the matrix is complex and symmetric + INTEGER(I4B), INTENT(OUT) :: rows + !! number of rows in matrix + INTEGER(I4B), INTENT(OUT) :: cols + !! number of columns in matrix + INTEGER(I4B), INTENT(OUT) :: nnz + !! number of nonzero elements + INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: indx(:) + !! row number (index) + INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: jndx(:) + !! col number (index) + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: rval(:) + !! real value needed when field is `real` + INTEGER(I4B), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: ival(:) + !! integer value needed when field is `integer` + COMPLEX(DFPC), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: cval(:) + !! complex value needed when field is `complex` + END SUBROUTINE MMRead +END INTERFACE + +PUBLIC :: MMRead + +!---------------------------------------------------------------------------- +! MMRead +!---------------------------------------------------------------------------- + +END MODULE CSRMatrix_MatrixMarketIO diff --git a/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 b/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 new file mode 100644 index 000000000..41cf2828c --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 @@ -0,0 +1,50 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE CSRMatrix_Method +USE CSRMatrix_ConstructorMethods +USE CSRMatrix_IOMethods +USE CSRMatrix_SparsityMethods +USE CSRMatrix_SetMethods +USE CSRMatrix_AddMethods +USE CSRMatrix_SetRowMethods +USE CSRMatrix_SetColMethods +USE CSRMatrix_SetBlockRowMethods +USE CSRMatrix_SetBlockColMethods +USE CSRMatrix_GetMethods +USE CSRMatrix_GetRowMethods +USE CSRMatrix_GetColMethods +USE CSRMatrix_GetSubMatrixMethods +USE CSRMatrix_GetBlockRowMethods +USE CSRMatrix_GetBlockColMethods +USE CSRMatrix_UnaryMethods +USE CSRMatrix_ILUMethods +USE CSRMatrix_LUSolveMethods +USE CSRMatrix_MatVecMethods +USE CSRMatrix_SymMatmulMethods +USE CSRMatrix_ReorderingMethods +USE CSRMatrix_DiagonalScalingMethods +USE CSRMatrix_MatrixMarketIO +USE CSRMatrix_Superlu +USE CSRMatrix_SpectralMethods +USE CSRMatrix_SchurMethods +USE CSRMatrix_DBCMethods +USE CSRMatrix_LinSolveMethods +USE GlobalData, ONLY: I4B +INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_CSR = 0 +INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_COO = 1 +END MODULE CSRMatrix_Method diff --git a/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 new file mode 100644 index 000000000..6c766ed73 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_ReorderingMethods.F90 @@ -0,0 +1,81 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_ReorderingMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_, SparseMatrixReOrdering_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: NestedDissect + +!---------------------------------------------------------------------------- +! NestedDissect@ReoderingMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2021 +! summary: Nested dissection using Metis library + +INTERFACE + MODULE SUBROUTINE csrMat_NestedDissect(reorder, csrMat) + TYPE(SparseMatrixReOrdering_), INTENT(INOUT) :: reorder + TYPE(CSRMatrix_), INTENT(IN) :: csrMat + END SUBROUTINE csrMat_NestedDissect +END INTERFACE + +INTERFACE NestedDissect + MODULE PROCEDURE csrMat_NestedDissect +END INTERFACE NestedDissect + +!---------------------------------------------------------------------------- +! Display@ReorderingMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2021 +! summary: Display the content of SparseMatrixReordering + +INTERFACE + MODULE SUBROUTINE csrMat_reorderDisplay(obj, msg, unitNo) + TYPE(SparseMatrixReOrdering_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitNo + END SUBROUTINE csrMat_reorderDisplay +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE csrMat_reorderDisplay +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Permute@ReorderingMethod +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION csrMat_Permute2(obj, rowPERM, colPERM) RESULT(Ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + TYPE(SparseMatrixReOrdering_), INTENT(IN) :: rowPERM + TYPE(SparseMatrixReOrdering_), INTENT(IN) :: colPERM + TYPE(CSRMatrix_) :: ans + END FUNCTION csrMat_Permute2 +END INTERFACE + +INTERFACE Permute + MODULE PROCEDURE csrMat_Permute2 +END INTERFACE Permute +END MODULE CSRMatrix_ReorderingMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 new file mode 100644 index 000000000..c00e3af73 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SchurMethods.F90 @@ -0,0 +1,187 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_SchurMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: SchurMatVec +PUBLIC :: SymSchurLargestEigenval + +!---------------------------------------------------------------------------- +! AMatVec1@MatvecMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-30 +! summary: This routine computes y = (Transpose(B) * Inv(A) * B) +! +!# Introduction +! +!$$ +!y = S \cdot x +!$$ +! +!where, +! +!$$ +! {\bf S}=\left({\bf B}^{T}{\bf A}^{-1}{\bf B}\right), +!$$ + +INTERFACE + MODULE SUBROUTINE csrMat_AMatVec(A, B, x, y) + TYPE(CSRMatrix_), INTENT(INOUT) :: A + TYPE(CSRMatrix_), INTENT(INOUT) :: B + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + END SUBROUTINE csrMat_AMatVec +END INTERFACE + +!---------------------------------------------------------------------------- +! AtMatvec@MatvecMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-30 +! summary: This routine computes y = (Transpose(B) * Inv(A) * B) +! +!# Introduction +! +!$$ +!y = S^{T} \cdot x +!$$ +! +!where, +! +!$$ +! {\bf S}=\left({\bf B}^{T}{\bf A}^{-1}{\bf B}\right), +!$$ + +INTERFACE + MODULE SUBROUTINE csrMat_AtMatVec(A, B, x, y, isASym) + TYPE(CSRMatrix_), INTENT(INOUT) :: A + TYPE(CSRMatrix_), INTENT(INOUT) :: B + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isASym + !! True if A is symmetric + !! False if A is not symmetric + !! Default is False + END SUBROUTINE csrMat_AtMatVec +END INTERFACE + +!---------------------------------------------------------------------------- +! Matvec@MatVec +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-30 +! summary: This routine computes y = (Transpose(B) * Inv(A) * B) +! + +INTERFACE + MODULE SUBROUTINE csrMat_SchurMatVec(A, B, x, y, isTranspose, isASym) + TYPE(CSRMatrix_), INTENT(INOUT) :: A + TYPE(CSRMatrix_), INTENT(INOUT) :: B + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: y(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isASym + END SUBROUTINE csrMat_SchurMatVec +END INTERFACE + +INTERFACE SchurMatVec + MODULE PROCEDURE csrMat_SchurMatVec +END INTERFACE SchurMatVec + +!---------------------------------------------------------------------------- +! SymSchurLargestEigenval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: +! + +INTERFACE + MODULE FUNCTION SymSchurLargestEigenVal1(A, B, which, NCV, maxIter, tol) & + & RESULT(ans) + TYPE(CSRMatrix_), INTENT(INOUT) :: A + !! Symmetric matrix + TYPE(CSRMatrix_), INTENT(INOUT) :: B + !! B matrix, it can be rectangle + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "LM"` ⇨ absolute largest eigenvalue + !! `which = "LA"` ⇨ algebraic largest eigenvalue + !! default is "LA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, 20)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans + !! maximum eigenvalue + END FUNCTION SymSchurLargestEigenVal1 +END INTERFACE + +INTERFACE SymSchurLargestEigenVal + MODULE PROCEDURE SymSchurLargestEigenVal1 +END INTERFACE SymSchurLargestEigenVal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-30 +! summary: + +INTERFACE + MODULE FUNCTION SymSchurLargestEigenVal2(A, B, nev, which, NCV, & + & maxIter, tol) RESULT(ans) + TYPE(CSRMatrix_), INTENT(INOUT) :: A + !! CSRMatrix, symmetric + TYPE(CSRMatrix_), INTENT(INOUT) :: B + !! B matrix, possibly rectangle + INTEGER(I4B), INTENT(IN) :: nev + !! number of eigenvalues requested + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "LM"` ⇨ absolute largest eigenvalue + !! `which = "LA"` ⇨ algebraic largest eigenvalue + !! default is "LA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, MAX(2*nev+1, 20))` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans(nev) + !! first k, largest eigenvalue + END FUNCTION SymSchurLargestEigenVal2 +END INTERFACE + +INTERFACE SymSchurLargestEigenVal + MODULE PROCEDURE SymSchurLargestEigenVal2 +END INTERFACE SymSchurLargestEigenVal + +END MODULE CSRMatrix_SchurMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 new file mode 100644 index 000000000..a70ec5eb7 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SetBlockColMethods.F90 @@ -0,0 +1,166 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_SetBlockColMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: SetBlockColumn + +!---------------------------------------------------------------------------- +! setBlockColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockColumn1(obj, ivar, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: icolumn + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setBlockColumn1 +END INTERFACE + +INTERFACE setBlockColumn + MODULE PROCEDURE csrMat_setBlockColumn1 +END INTERFACE setBlockColumn + +!---------------------------------------------------------------------------- +! setBlockColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockColumn2(obj, ivar, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: icolumn + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setBlockColumn2 +END INTERFACE + +INTERFACE setBlockColumn + MODULE PROCEDURE csrMat_setBlockColumn2 +END INTERFACE setBlockColumn + +!---------------------------------------------------------------------------- +! setBlockColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockColumn3(obj, ivar, jvar, nodenum, idof, & + & VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setBlockColumn3 +END INTERFACE + +INTERFACE setBlockColumn + MODULE PROCEDURE csrMat_setBlockColumn3 +END INTERFACE setBlockColumn + +!---------------------------------------------------------------------------- +! setBlockColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockColumn4(obj, ivar, jvar, nodenum, idof, & + & VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setBlockColumn4 +END INTERFACE + +INTERFACE setBlockColumn + MODULE PROCEDURE csrMat_setBlockColumn4 +END INTERFACE setBlockColumn + +!---------------------------------------------------------------------------- +! setBlockColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockColumn5(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setBlockColumn5 +END INTERFACE + +INTERFACE setBlockColumn + MODULE PROCEDURE csrMat_setBlockColumn5 +END INTERFACE setBlockColumn + +!---------------------------------------------------------------------------- +! setBlockColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockColumn6(obj, ivar, jvar, nodenum, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setBlockColumn6 +END INTERFACE + +INTERFACE setBlockColumn + MODULE PROCEDURE csrMat_setBlockColumn6 +END INTERFACE setBlockColumn + +END MODULE CSRMatrix_SetBlockColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 new file mode 100644 index 000000000..b11792bd2 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods.F90 @@ -0,0 +1,166 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_SetBlockRowMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: SetBlockRow + +!---------------------------------------------------------------------------- +! setBlockRow@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockRow1(obj, jvar, irow, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: irow + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setBlockRow1 +END INTERFACE + +INTERFACE setBlockRow + MODULE PROCEDURE csrMat_setBlockRow1 +END INTERFACE setBlockRow + +!---------------------------------------------------------------------------- +! setBlockRow@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockRow2(obj, jvar, irow, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: irow + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setBlockRow2 +END INTERFACE + +INTERFACE setBlockRow + MODULE PROCEDURE csrMat_setBlockRow2 +END INTERFACE setBlockRow + +!---------------------------------------------------------------------------- +! setBlockRow@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockRow3(obj, ivar, jvar, nodenum, idof, & + & VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setBlockRow3 +END INTERFACE + +INTERFACE setBlockRow + MODULE PROCEDURE csrMat_setBlockRow3 +END INTERFACE setBlockRow + +!---------------------------------------------------------------------------- +! setBlockRow@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockRow4(obj, ivar, jvar, nodenum, idof, & + & VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setBlockRow4 +END INTERFACE + +INTERFACE setBlockRow + MODULE PROCEDURE csrMat_setBlockRow4 +END INTERFACE setBlockRow + +!---------------------------------------------------------------------------- +! setBlockRow@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockRow5(obj, ivar, jvar, nodenum, spacecompo,& + & timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setBlockRow5 +END INTERFACE + +INTERFACE setBlockRow + MODULE PROCEDURE csrMat_setBlockRow5 +END INTERFACE setBlockRow + +!---------------------------------------------------------------------------- +! setBlockRow@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE + MODULE SUBROUTINE csrMat_setBlockRow6(obj, ivar, jvar, nodenum, spacecompo,& + & timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setBlockRow6 +END INTERFACE + +INTERFACE setBlockRow + MODULE PROCEDURE csrMat_setBlockRow6 +END INTERFACE setBlockRow + +END MODULE CSRMatrix_SetBlockRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 new file mode 100644 index 000000000..4f250906a --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SetColMethods.F90 @@ -0,0 +1,485 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_SetColMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn1(obj, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: icolumn + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn1 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn1b(obj, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: icolumn(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn1b +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn2(obj, nodenum, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn2 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn3(obj, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: icolumn + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn3 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn3b(obj, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: icolumn(:) + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn3b +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn4(obj, nodenum, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn4 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn5(obj, nodenum, ivar, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn5 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn6(obj, nodenum, ivar, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn6 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn7(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn7 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn8(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn8 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn9(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn9 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn10(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn10 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn11(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn11 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn12(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn12 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn13(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn13 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn14(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn14 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn15(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setColumn15 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! setColumn@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the Column of a sparse matrix +! +!# Introduction +! +! - This routine sets the Column of a sparse matrix. The Column index is +! calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - icolumn calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetColumn + MODULE SUBROUTINE csrMat_setColumn16(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setColumn16 +END INTERFACE SetColumn + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE CSRMatrix_SetColMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 new file mode 100644 index 000000000..127461fde --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 @@ -0,0 +1,580 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_SetMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaSetype, ONLY: CSRMatrix_ +IMPLICIT NONE + +PRIVATE +PUBLIC :: Set +PUBLIC :: SetSingleValue +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: SetIA, SetJA + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: This subroutine sets the single value + +INTERFACE SetSingleValue + MODULE PURE SUBROUTINE obj_SetSingleValue(obj, indx, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: indx + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE obj_SetSingleValue +END INTERFACE SetSingleValue + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set the value in sparse matrix +! +!# Introduction +! +! - This subroutine Sets the value in [[CSRMatrix_]] +! - Shape( value ) = [SIZE(nodenum)*tdof, SIZE(nodenum)*tdof] +! - Usually `value` denotes the element matrix +! - Symbolic we are performing following task `obj(nodenum, nodenum)=value` + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set0(obj, nodenum, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:, :) + END SUBROUTINE obj_Set0 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set the value in sparse matrix +! +!# Introduction +! +! This subroutine Sets the values in sparse matrix. +! +!$$ +! obj(Nptrs,Nptrs)=value(:,:) +!$$ +! +! - Usually `value(:,:)` represents the element finite element matrix +! - The shape of `value` should be the tdof*size(nodenum), tdof*size(nodenum) +! - `tdof` is the total degree of freedom in obj%csr%dof +! +! - `StorageFMT` denotes the storage format of `value` +! It can be `Nodes_FMT` or `DOF_FMT` +! +! - Usually, element matrix is stored with `DOF_FMT` + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set1(obj, nodenum, VALUE, storageFMT) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:, :) + INTEGER(I4B), INTENT(IN) :: storageFMT + END SUBROUTINE obj_Set1 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets all values of sparse matrix to given scalar value +! +!# Introduction +! This routine Sets all values of sparse matrix to given value. +! This routine is used to define an assignment operator. Therefore, we can +! call this routine by `obj=value`. + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set2(obj, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE obj_Set2 +END INTERFACE Set + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE obj_Set2 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets a single entry of sparse matrix +! +!# Introduction +! +! - This subroutine Sets a single entry of sparse matrix. +! - Before using this routine the user should be aware of the storage +! pattern of degree of freedom. +! - However, if total number of degrees of freedom is one then there is not +! need to worry. +! +!@warning +! This routine should be avoided by general user. +!@endwarning + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set3(obj, irow, icolumn, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow + !! row index + INTEGER(I4B), INTENT(IN) :: icolumn + !! column index + REAL(DFP), INTENT(IN) :: VALUE + !! value + END SUBROUTINE obj_Set3 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets the specific row and column entry to a given value +! +!# Introduction +! +! - This routine Sets the specific row and column entry to a given value. +! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Set3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Set3]] +!@endnote +! +!@note +! rowdof, coldof are continuously numbered, so if there are two +! or more physical variables, then rowdof and coldof of the second +! or later physical variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set4(obj, iNodeNum, jNodeNum, iDOF, & + & jDOF, VALUE) + 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) :: iDOF + !! row degree of freedom + INTEGER(I4B), INTENT(IN) :: jDOF + !! col degree of freedom + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value to be Set + END SUBROUTINE obj_Set4 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Sets selected values in sparse matrix +! +!# Introduction +! +! This subroutine Sets selected values of the sparse matrix to the scalar +! value `value` +! +! This routine corresponds to `obj(nodenum) = value` + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set5(obj, nodenum, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE obj_Set5 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set the value in sparse matrix +! +!# Introduction +! +! - This subroutine Sets the values in block sparse matrix. +! - The storage pattern of both sparse matrix and value +! (the element matrix) should be in `FMT_DOF`. +! +!$$ +! obj(Nptrs,Nptrs)=value(:,:) +!$$ +! + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set6(obj, iNodeNum, jNodeNum, & + & ivar, jvar, VALUE) + 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(:, :) + END SUBROUTINE obj_Set6 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets the specific row and column entry to a given value +! +!# Introduction +! +! - This routine Sets the specific row and column entry to a given value. +! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Set3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Set3]] +!@endnote +! +!@note +! rowdof, coldof are continuously numbered, so if there are two +! or more physical variables, then rowdof and coldof of the second +! or later physical variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set7(obj, iNodeNum, jNodeNum, ivar, & + & jvar, iDOF, jDOF, VALUE) + 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 Set + END SUBROUTINE obj_Set7 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets the specific row and column entry to a given value + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set8(obj, iNodeNum, jNodeNum, ivar, & + & jvar, iDOF, jDOF, VALUE) + 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 Set + END SUBROUTINE obj_Set8 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets the specific row and column entry to a given value +! +!# Introduction +! +! - This routine Sets the specific row and column entry to a given value. +! - The irow and icolumn index in [[CSRMatrix_]] are calculated by using +! (iNodeNum, iDOF) and (jNodeNum, jDOF), respectively. +! - To do the above task, the routine employs [[DOF_Method:getNodeLoc]] method +! - After computing the irow and icolumn (internally) this routine calls, +! `obj_Set3`. +! +!@note +! General user should prefer this routine over +! [[CSRMatrix_Method:obj_Set3]] +!@endnote +! +!@note +! rowdof, coldof are continuously numbered, so if there are two +! or more physical variables, then rowdof and coldof of the second +! or later physical variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set9(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) + 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 + !! col degree of freedom + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value to be Set + END SUBROUTINE obj_Set9 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set the value in sparse matrix +! +!# Introduction +! +! - This subroutine Sets the values in block sparse matrix. +! - The storage pattern of both sparse matrix and value +! (the element matrix) should be in `FMT_DOF`. +! +!$$ +! obj(Nptrs,Nptrs)=value(:,:) +!$$ +! + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set10(obj, iNodeNum, jNodeNum, & + & ivar, jvar, VALUE) + 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 + END SUBROUTINE obj_Set10 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets the specific row and column entry to a given value + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set11(obj, iNodeNum, jNodeNum, ivar, & + & jvar, iDOF, jDOF, VALUE) + 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 Set + END SUBROUTINE obj_Set11 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets the specific row and column entry to a given value + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set12(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) + 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 Set + END SUBROUTINE obj_Set12 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Sets the specific row and column entry to a given value + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set13(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) + 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 Set + END SUBROUTINE obj_Set13 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-25 +! summary: Sets the specific row and column entry to a given value + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set14(obj, iNodeNum, jNodeNum, ivar, & + & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) + 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 Set + END SUBROUTINE obj_Set14 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-17 +! summary: Scale the sparse matrix , obj = scale*Value + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set15(obj, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(IN) :: VALUE + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_Set15 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! SetIA@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Set entry in IA + +INTERFACE SetIA + MODULE PURE SUBROUTINE obj_SetIA(obj, irow, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B), INTENT(IN) :: VALUE + END SUBROUTINE obj_SetIA +END INTERFACE SetIA + +!---------------------------------------------------------------------------- +! SetJA@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Set entry in JA + +INTERFACE SetJA + MODULE PURE SUBROUTINE obj_SetJA(obj, indx, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(I4B), INTENT(IN) :: VALUE + END SUBROUTINE obj_SetJA +END INTERFACE SetJA + +END MODULE CSRMatrix_SetMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 new file mode 100644 index 000000000..f8d4c1884 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SetRowMethods.F90 @@ -0,0 +1,476 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_SetRowMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the the row of a sparse matrix + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow1(obj, irow, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow1 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the the row of a sparse matrix + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow1b(obj, irow, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow1b +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is +! calculated using the nodenum and idof. +! - `nodenum` is the node number +! - `idof` is the degree of freedom number +! - `irow` calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow2(obj, nodenum, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow2 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the the row of a sparse matrix + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow3(obj, irow, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow3 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine sets the the row of a sparse matrix + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow3b(obj, irow, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow(:) + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow3b +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow4(obj, nodenum, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow4 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow5(obj, nodenum, ivar, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow5 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow6(obj, nodenum, ivar, idof, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow6 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow7(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow7 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow8(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow8 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow9(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow9 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow10(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow10 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow11(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow11 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow12(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow12 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow13(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow13 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow14(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow14 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow15(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE csrMat_setRow15 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! setRow@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine set the row of a sparse matrix +! +!# Introduction +! +! - This routine sets the row of a sparse matrix. The row index is calculated +! using the nodenum and idof. +! - nodenum is the node number +! - idof is the degree of freedom number +! - irow calculated from nodenum and idof depends upon the storageFMT. + +INTERFACE SetRow + MODULE SUBROUTINE csrMat_setRow16(obj, nodenum, ivar, & + & spacecompo, timecompo, VALUE) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE csrMat_setRow16 +END INTERFACE SetRow + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE CSRMatrix_SetRowMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 new file mode 100644 index 000000000..37a69a98d --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SparsityMethods.F90 @@ -0,0 +1,153 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_SparsityMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_, IntVector_ +IMPLICIT NONE +PRIVATE +PUBLIC :: SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@setMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine set the sparsity pattern of a given row +! +!# Introduction +! +! This subroutine sets the sparsity pattern of a given row +! - If `obj%tdof` is equal to 1, then `Col` is sorted in increasing order, +! and appended to `obj%Row(Row)` +! - If `obj%tdof` is not equal to 1, then based on the storage format and +! `Col` connectivity information is generated. + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_setSparsity1(obj, row, col) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: row + !! row number + INTEGER(I4B), INTENT(IN) :: col(:) + !! column indices (only node number is required) + END SUBROUTINE obj_setSparsity1 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine sets the sparsity pattern of a given row +! +!# Introduction +! +! This subroutine sets the sparsity pattern of many rows + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_setSparsity2(obj, row, col) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: row(:) + !! row indices + TYPE(IntVector_), INTENT(IN) :: col(:) + !! each intVector, col(i), contains col indices of row(i) + END SUBROUTINE obj_setSparsity2 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine set the sparsity pattern of a given row +! +!# Introduction +! +! This subroutine sets the sparsity pattern of a given row +! - If `obj%tdof` is equal to 1, then `Col` is sorted in increasing order, +! and appended to `obj%Row(Row)` +! - If `obj%tdof` is not equal to 1, then based on the storage format and +! `Col` connectivity information is generated. + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_setSparsity3(obj, row, col, ivar, jvar) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: row + !! row index + INTEGER(I4B), INTENT(IN) :: col(:) + !! col indices + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable i + INTEGER(I4B), INTENT(IN) :: jvar + !! physical variable j + END SUBROUTINE obj_setSparsity3 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine sets the sparsity pattern of a given row +! +!# Introduction +! +! This subroutine sets the sparsity pattern of a given row +! This subroutine calls `obj_setSparsity1` + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_setSparsity4(obj, row, col, ivar, jvar) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: row(:) + TYPE(IntVector_), INTENT(IN) :: col(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + END SUBROUTINE obj_setSparsity4 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine set sparsity pattern of `sparsematrix_` +! +!# Introduction +! +! authors: Dr. Vikas Sharma +! +! This subroutine set sparsity pattern of `sparsematrix_` +! This will finally set the data into +! +! - `obj%A(:)` +! - `obj%IA(:)` +! - `obj%JA(:)` +! in CSR format. This routine also set data inside `obj%ColSize(:)` and +! `obj%RowSize(:) `, and `obj%DiagIndx(:)` + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_setSparsity_final(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE obj_setSparsity_final +END INTERFACE SetSparsity + +END MODULE CSRMatrix_SparsityMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 new file mode 100644 index 000000000..0f54a94b5 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SpectralMethods.F90 @@ -0,0 +1,209 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE CSRMatrix_SpectralMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: SymLargestEigenval +PUBLIC :: SymSmallestEigenval + +!---------------------------------------------------------------------------- +! SymLargestEigenval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the largest eigenvalue of a real sym dense matrix +! +!# Introduction +! +!- This routine calculates the largest eigenvalue of a real sym dense matrix. +!- It calls ARPACK SSAUPD or DSAUPD routine + +INTERFACE + MODULE FUNCTION SymLargestEigenVal1(mat, which, NCV, maxIter, tol) & + & RESULT(ans) + TYPE(CSRMatrix_), INTENT(INOUT) :: mat + !! dense matrix + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "LM"` ⇨ absolute largest eigenvalue + !! `which = "LA"` ⇨ algebraic largest eigenvalue + !! default is "LA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, 20)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans + !! maximum eigenvalue + END FUNCTION SymLargestEigenVal1 +END INTERFACE + +INTERFACE SymLargestEigenVal + MODULE PROCEDURE SymLargestEigenVal1 +END INTERFACE SymLargestEigenVal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the `nev` smallest eigenvalue of a real sym dense matrix +! +!# Introduction +! +!- This routine calculates the smallest eigenvalue of a real sym dense matrix. +!- It calls ARPACK SSAUPD or DSAUPD routine + +INTERFACE + MODULE FUNCTION SymLargestEigenVal2(mat, nev, which, NCV, maxIter, tol) & + & RESULT(ans) + TYPE(CSRMatrix_), INTENT(INOUT) :: mat + !! dense matrix + INTEGER(I4B), INTENT(IN) :: nev + !! number of eigenvalues requested + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "LM"` ⇨ absolute largest eigenvalue + !! `which = "LA"` ⇨ algebraic largest eigenvalue + !! default is "LA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, MAX(2*nev+1, 20))` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans(nev) + !! first k, largest eigenvalue + END FUNCTION SymLargestEigenVal2 +END INTERFACE + +INTERFACE SymLargestEigenVal + MODULE PROCEDURE SymLargestEigenVal2 +END INTERFACE SymLargestEigenVal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the smallest eigenvalue of a real sym dense matrix +! +!# Introduction +! +!- This routine calculates the smallest eigenvalue of a real sym dense matrix. +!- It calls ARPACK SSAUPD or DSAUPD routine with MODE=3 +! +! In this routine we use shift-inverted method to compute the +! smallest eigenvalue of a regular (standard) eigenvalue problem. This is +! because `ARPACK` is good at finding the largest eigenvalue. +! +! Internally this routine solves a system of linear equations: `mat * y = x` +! by using LU decomposition. +! +! In this routine we make a call to LUSolve and getLU routine. +! +!@note +! In this routine we make a copy of mat in mat0. Then, compute the LU +! decomposition of mat0. +!@endnote + +INTERFACE + MODULE FUNCTION SymSmallestEigenVal1(mat, which, NCV, maxIter, tol) & + & RESULT(ans) + TYPE(CSRMatrix_), INTENT(INOUT) :: mat + !! dense matrix + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "SM"` ⇨ absolute smallest eigenvalue + !! `which = "SA"` ⇨ algebraic smallest eigenvalue + !! default is "SA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, 20)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans + !! maximum eigenvalue + END FUNCTION SymSmallestEigenVal1 +END INTERFACE + +INTERFACE SymSmallestEigenVal + MODULE PROCEDURE SymSmallestEigenVal1 +END INTERFACE SymSmallestEigenVal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-10 +! summary: Calculate the smallest eigenvalue of a real sym dense matrix +! +!# Introduction +! +! This routine is similar to SysSmallestEigenVal1() +! In this routine you can pass a factorized matrix `mat` and set `isLU=true` +! Then, this routine will not perform LU decomposition on mat. +! +! However, if `isLU=false`, then we will change mat, and on return +! it will contain the LU factorization of `mat` +! +!- [ ] TODO use Cholsky factorization instead of LU as mat is +! symmetric. +! + +INTERFACE + MODULE FUNCTION SymSmallestEigenVal2(mat, nev, which, & + & NCV, maxIter, tol) RESULT(ans) + TYPE(CSRMatrix_), INTENT(INOUT) :: mat + !! CSRMatrix + INTEGER(I4B), INTENT(IN) :: nev + !! number of eigenvalues + CHARACTER(*), OPTIONAL, INTENT(IN) :: which + !! `which = "SM"` ⇨ absolute smallest eigenvalue + !! `which = "SA"` ⇨ algebraic smallest eigenvalue + !! default is "SA" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NCV + !! Number of Lanczos vectors generated + !! It must be greater than 1 and smaller than `size(mat,1)` + !! Default is `NCV = MIN(n, 20)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! Maximum number of iteration default = `N*10` + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + !! tolerance, default = 0.0 + REAL(DFP) :: ans(nev) + !! smallest eigenvalue + END FUNCTION SymSmallestEigenVal2 +END INTERFACE + +INTERFACE SymSmallestEigenVal + MODULE PROCEDURE SymSmallestEigenVal2 +END INTERFACE SymSmallestEigenVal + +END MODULE CSRMatrix_SpectralMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 new file mode 100644 index 000000000..3b1701250 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SuperLU.F90 @@ -0,0 +1,503 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 CSRMatrix_Superlu +USE BaseType, ONLY: CSRMatrix_ +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE + +! PUBLIC :: GetLU +! PUBLIC :: LUSolve +! PUBLIC :: ! Solve +PUBLIC :: InitiateSuperluRHS +PUBLIC :: InitiateSuperluA +PUBLIC :: LinSolve +PUBLIC :: SuperluDeallocate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-26 +! summary: Initiate Superlu data structure inside csrmatrix + +INTERFACE + MODULE SUBROUTINE InitiateSuperluA(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE InitiateSuperluA +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-26 +! summary: Initiate Superlu data structure inside csrmatrix + +INTERFACE + MODULE SUBROUTINE SetSuperluA(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE SetSuperluA +END INTERFACE + +!---------------------------------------------------------------------------- +! InitiateSuperluRHS +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Set RHS + +INTERFACE InitiateSuperluRHS + MODULE SUBROUTINE InitiateSuperluRHS1(obj, rhs) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: rhs(:) + END SUBROUTINE InitiateSuperluRHS1 +END INTERFACE InitiateSuperluRHS + +!---------------------------------------------------------------------------- +! InitiateSuperluRHS +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Set RHS + +INTERFACE InitiateSuperluRHS + MODULE SUBROUTINE InitiateSuperluRHS2(obj, rhs) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: rhs(:, :) + END SUBROUTINE InitiateSuperluRHS2 +END INTERFACE InitiateSuperluRHS + +!---------------------------------------------------------------------------- +! SetSuperluRHS +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Set RHS + +INTERFACE SetSuperluRHS + MODULE SUBROUTINE SetSuperluRHS1(obj, rhs) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: rhs(:) + END SUBROUTINE SetSuperluRHS1 +END INTERFACE SetSuperluRHS + +!---------------------------------------------------------------------------- +! SetSuperluRHS +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Set RHS + +INTERFACE SetSuperluRHS + MODULE SUBROUTINE SetSuperluRHS2(obj, rhs) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: rhs(:, :) + END SUBROUTINE SetSuperluRHS2 +END INTERFACE SetSuperluRHS + +!---------------------------------------------------------------------------- +! GetSuperlux +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Get solutions + +INTERFACE GetSuperlux + MODULE SUBROUTINE GetSuperluX1(obj, x) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(INOUT) :: x(:) + END SUBROUTINE GetSuperluX1 +END INTERFACE GetSuperlux + +!---------------------------------------------------------------------------- +! GetSuperlux +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Get solutions + +INTERFACE GetSuperlux + MODULE SUBROUTINE GetSuperluX2(obj, x) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(INOUT) :: x(:, :) + END SUBROUTINE GetSuperluX2 +END INTERFACE GetSuperlux + +!---------------------------------------------------------------------------- +! InitiateSuperLuOptions +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Initiate Superlu Options + +INTERFACE + MODULE SUBROUTINE InitiateSuperLuOptions(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE InitiateSuperLuOptions +END INTERFACE + +!---------------------------------------------------------------------------- +! SetSuperluOptions +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Set options for superlu + +INTERFACE + MODULE SUBROUTINE SetSuperluOptions(obj, Fact, Equil, ColPerm, & + & Trans, IterRefine, DiagPivotThresh, SymmetricMode, & + & PivotGrowth, ConditionNumber, RowPerm, ILU_DropRule, & + & ILU_DropTol, ILU_FillFactor, ILU_MILU, PrintStat) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Fact + !! Fact_t + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil + !! yes_no_t%YES, yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm + !! Colperm_t%COLAMD + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Trans + !! Trans_t%TRANS, Trans_t% + INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine + !! IterRefine_t + REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh + !! From 0 to 1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode + !! + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth + !! yes_no_t%YES, yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber + !! yes_no_t%YES, yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: RowPerm + !! + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ILU_DropRule + !! + REAL(DFP), OPTIONAL, INTENT(IN) :: ILU_DropTol + !! + REAL(DFP), OPTIONAL, INTENT(IN) :: ILU_FillFactor + !! + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ILU_MILU + !! + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat + !! + END SUBROUTINE SetSuperluOptions +END INTERFACE + +!---------------------------------------------------------------------------- +! SuperluDGSSVX +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-27 +! summary: Call Superlu DGSSVX to solve Ax=b + +INTERFACE + MODULE SUBROUTINE SuperluDGSSVX(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE SuperluDGSSVX +END INTERFACE + +!---------------------------------------------------------------------------- +! InitiateSuperluDGSSVXParam +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-27 +! summary: Initiate Superlu DGSSVX variables + +INTERFACE + MODULE SUBROUTINE InitiateSuperluDGSSVXParam(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE InitiateSuperluDGSSVXParam +END INTERFACE + +!---------------------------------------------------------------------------- +! SuperluPrintStat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-27 +! summary: Print statistics + +INTERFACE + MODULE SUBROUTINE SuperluDisplayStat(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE SuperluDisplayStat +END INTERFACE + +!---------------------------------------------------------------------------- +! SuperluDeallocate +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-27 +! summary: SuperluDeallocate + +INTERFACE + MODULE SUBROUTINE SuperluDeallocate(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE SuperluDeallocate +END INTERFACE + +!---------------------------------------------------------------------------- +! LinSolve1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Linear solver using LUSolve +! +!# Introduction +! +! This routine solves `A*X=B` + +INTERFACE LinSolve + MODULE SUBROUTINE LinSolve1(X, A, B, isTranspose, isFactored, & + & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & + & ConditionNumber, SymmetricMode, PrintStat, info) + REAL(DFP), INTENT(INOUT) :: X(:) + !! Solution + TYPE(CSRMatrix_), INTENT(INOUT) :: A + !! CSRMatrix + REAL(DFP), INTENT(IN) :: B(:) + !! RHS, it will not be modified, we will make a copy of it + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! Should we solve `A*X=B` or `transpose(A)*X=B` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored + !! is A already factored + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm + !! Colperm_t%NATURAL + !! Colperm_t%MMD_ATA + !! Colperm_t%MMD_AT_PLUS_A + !! Colperm_t%COLAMD + !! Colperm_t%MY_PERMC + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine + !! IterRefine_t%NO + !! IterRefine_t%SLU_SINGLE + !! IterRefine_t%SLU_DOUBLE + !! IterRefine_t%SLU_EXTRA + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth + !! yes_no_t%YES + !! yes_no_t%NO + REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh + !! between 0 and 1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! if info equal to zero then success, else failure + END SUBROUTINE LinSolve1 +END INTERFACE LinSolve + +!---------------------------------------------------------------------------- +! LinSolve2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Linear solver using LUSolve +! +!# Introduction +! +! This routine solves `A*X=B` + +INTERFACE LinSolve + MODULE SUBROUTINE LinSolve2(X, A, B, isTranspose, isFactored, & + & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & + & ConditionNumber, SymmetricMode, PrintStat, info) + REAL(DFP), INTENT(INOUT) :: X(:, :) + !! Solution + TYPE(CSRMatrix_), INTENT(INOUT) :: A + !! CSRMatrix + REAL(DFP), INTENT(IN) :: B(:, :) + !! RHS, it will not be modified, we will make a copy of it + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! Should we solve `A*X=B` or `transpose(A)*X=B` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored + !! is A already factored + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm + !! Colperm_t%NATURAL + !! Colperm_t%MMD_ATA + !! Colperm_t%MMD_AT_PLUS_A + !! Colperm_t%COLAMD + !! Colperm_t%MY_PERMC + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine + !! IterRefine_t%NO + !! IterRefine_t%SLU_SINGLE + !! IterRefine_t%SLU_DOUBLE + !! IterRefine_t%SLU_EXTRA + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth + !! yes_no_t%YES + !! yes_no_t%NO + REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh + !! between 0 and 1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! if info equal to zero then success, else failure + END SUBROUTINE LinSolve2 +END INTERFACE LinSolve + +!---------------------------------------------------------------------------- +! LinSolve1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Linear solver using LUSolve +! +!# Introduction +! +! This routine solves `A*X=B` +! Solution is returned in B + +INTERFACE LinSolve + MODULE SUBROUTINE LinSolve3(A, B, isTranspose, isFactored, & + & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & + & ConditionNumber, SymmetricMode, PrintStat, info) + TYPE(CSRMatrix_), INTENT(INOUT) :: A + !! CSRMatrix + REAL(DFP), INTENT(INOUT) :: B(:) + !! RHS, it will not be modified, we will make a copy of it + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! Should we solve `A*X=B` or `transpose(A)*X=B` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored + !! is A already factored + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm + !! Colperm_t%NATURAL + !! Colperm_t%MMD_ATA + !! Colperm_t%MMD_AT_PLUS_A + !! Colperm_t%COLAMD + !! Colperm_t%MY_PERMC + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine + !! IterRefine_t%NO + !! IterRefine_t%SLU_SINGLE + !! IterRefine_t%SLU_DOUBLE + !! IterRefine_t%SLU_EXTRA + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth + !! yes_no_t%YES + !! yes_no_t%NO + REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh + !! between 0 and 1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! if info equal to zero then success, else failure + END SUBROUTINE LinSolve3 +END INTERFACE LinSolve + +!---------------------------------------------------------------------------- +! LinSolve2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-26 +! summary: Linear solver using LUSolve +! +!# Introduction +! +! This routine solves `A*X=B` + +INTERFACE LinSolve + MODULE SUBROUTINE LinSolve4(A, B, isTranspose, isFactored, & + & ColPerm, Equil, IterRefine, PivotGrowth, DiagPivotThresh, & + & ConditionNumber, SymmetricMode, PrintStat, info) + TYPE(CSRMatrix_), INTENT(INOUT) :: A + !! CSRMatrix + REAL(DFP), INTENT(INOUT) :: B(:, :) + !! RHS, it will be modified on return, solution is in B + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! Should we solve `A*X=B` or `transpose(A)*X=B` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isFactored + !! is A already factored + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ColPerm + !! Colperm_t%NATURAL + !! Colperm_t%MMD_ATA + !! Colperm_t%MMD_AT_PLUS_A + !! Colperm_t%COLAMD + !! Colperm_t%MY_PERMC + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Equil + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: IterRefine + !! IterRefine_t%NO + !! IterRefine_t%SLU_SINGLE + !! IterRefine_t%SLU_DOUBLE + !! IterRefine_t%SLU_EXTRA + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PivotGrowth + !! yes_no_t%YES + !! yes_no_t%NO + REAL(DFP), OPTIONAL, INTENT(IN) :: DiagPivotThresh + !! between 0 and 1 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ConditionNumber + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: SymmetricMode + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(IN) :: PrintStat + !! yes_no_t%YES + !! yes_no_t%NO + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! if info equal to zero then success, else failure + END SUBROUTINE LinSolve4 +END INTERFACE LinSolve + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +END MODULE CSRMatrix_Superlu diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 new file mode 100644 index 000000000..72f26cb0c --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_SymMatmulMethods.F90 @@ -0,0 +1,41 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE CSRMatrix_SymMatmulMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: SymMatSquare + +!---------------------------------------------------------------------------- +! Matmul@MatVec +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-27 +! summary: Returns A^2 + +INTERFACE SymMatSquare + MODULE SUBROUTINE obj_SymMatSquare(obj, A) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + TYPE(CSRMatrix_), INTENT(IN) :: A + END SUBROUTINE obj_SymMatSquare +END INTERFACE SymMatSquare + +END MODULE CSRMatrix_SymMatmulMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 new file mode 100644 index 000000000..5321053a5 --- /dev/null +++ b/src/modules/CSRMatrix/src/CSRMatrix_UnaryMethods.F90 @@ -0,0 +1,512 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: UnaryMethods operator for [[SparseMaatrix_]] +! +! Following subroutines are planned to include in this module +! +! | subroutine | description | +! |---|---| +! | `SUBMAT` | extracts a submatrix from a sparse matrix | +! | `FILTER` | filters elements from a matrix according to their magnitude | +! | `CSORT` | sorts the elements in increasing order of columns | +! | `CLNCSR` | clean up the CSR format matrix, remove duplicate entry, etc | +! | `TRANSP` | in-place transposition routine | +! | `COPMAT` | copy of a matrix into another matrix (both stored csr) | +! | `GETELM` | returns a(i,j) for any (i,j) from a CSR-stored matrix. | +! | `GETDIA` | extracts a specified diagonal from a matrix. | +! | `GETL` | extracts lower triangular part | +! | `GETU` | extracts upper triangular part | +! | `LEVELS` | gets the level scheduling structure for lower triangular matrices | +! | `AMASK` | extracts C = A mask M | +! | `RPERM` | permutes the rows of a matrix (B = P A) | +! | `CPERM` | permutes the columns of a matrix (B = A Q) | +! | `DPERM` | permutes both the rows and columns of a matrix (B = P A Q ) | +! | `DPERM1` | general extraction routine (extracts arbitrary rows) | +! | `DPERM2` | general submatrix permutation/extraction routine | +! | `DVPERM` | permutes a real vector (in-place) | +! | `IVPERM` | permutes an integer vector (in-place) | +! | `RETMX` | returns the max absolute value in each row of the matrix | +! | `DIAPOS` | returns the positions of the diagonal elements in A. | +! | `EXTBDG` | extracts the main diagonal blocks of a matrix. | +! | `GETBWD` | returns the bandwidth information on a matrix. | +! | `BLKFND` | finds the block-size of a matrix. | +! | `BLKCHK` | checks whether a given integer is the block size of A. | +! | `INFDIA` | obtains information on the diagonals of A. | +! | `AMUBDG` | gets number of nonzeros in each row of A*B (as well as NNZ) | +! | `APLBDG` | gets number of nonzeros in each row of A+B (as well as NNZ) | +! | `RNRMS` | computes the norms of the rows of A | +! | `CNRMS` | computes the norms of the columns of A | +! | `ROSCAL` | scales the rows of a matrix by their norms. | +! | `COSCAL` | scales the columns of a matrix by their norms. | +! | `ADDBLK` | Adds a matrix B into a block of A. | +! | `GET1UP` | Collects the first elements of each row of the upper triangular portion of the matrix | +! | `XTROWS` | extracts given rows from a matrix in CSR format. | +! | `CSRKVSTR`| Finds block row partitioning of matrix in CSR format | +! | `CSRKVSTC`| Finds block column partitioning of matrix in CSR format | +! | `KVSTMERGE`| Merges block partitionings, for conformal row/col pattern | + +MODULE CSRMatrix_UnaryMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: CSRMatrix_, RealMatrix_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: Convert +PUBLIC :: ColumnSORT +PUBLIC :: RemoveDuplicates +PUBLIC :: Clean +PUBLIC :: Copy +PUBLIC :: Get +PUBLIC :: DropEntry +PUBLIC :: GetTRANSPOSE +PUBLIC :: GetDiagonal +PUBLIC :: GetLowerTriangle +PUBLIC :: GetUpperTriangle +PUBLIC :: PermuteRow +PUBLIC :: PermuteColumn +PUBLIC :: Permute +PUBLIC :: GetSym +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: SCAL + +!---------------------------------------------------------------------------- +! Scal@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-17 +! summary: Scale the matrix + +INTERFACE Scal + MODULE SUBROUTINE obj_Scal(obj, a) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: a + END SUBROUTINE obj_Scal +END INTERFACE Scal + +!---------------------------------------------------------------------------- +! Convert@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine converts sparsematrix to dense storage +! +!# Introduction +! +! This subroutine converts sparsematrix into a dense storage format +! `A(:), IA(:), JA(:)` denotes CSR format. +! This subroutine can be used for debuggin purpose. + +INTERFACE Convert + MODULE PURE SUBROUTINE obj_Convert1(A, IA, JA, mat) + REAL(DFP), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: IA(:) + INTEGER(I4B), INTENT(IN) :: JA(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) + END SUBROUTINE obj_Convert1 +END INTERFACE Convert + +!---------------------------------------------------------------------------- +! Convert@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine converts sparsematrix to dense storage +! +!# Introduction +! +! This subroutine converts sparsematrix to dense storage format +! `A(:), IA(:), JA(:)` denotes CSR format. + +INTERFACE Convert + MODULE PURE SUBROUTINE obj_Convert2(To, From) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) + TYPE(CSRMatrix_), INTENT(IN) :: From + END SUBROUTINE obj_Convert2 +END INTERFACE Convert + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE obj_Convert2 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Convert@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine converts sparsematrix to dense storage +! +!# Introduction +! +! This subroutine converts sparsematrix to dense storage format +! `A(:), IA(:), JA(:)` denotes CSR format. + +INTERFACE Convert + MODULE PURE SUBROUTINE obj_Convert3(To, From) + TYPE(RealMatrix_), INTENT(INOUT) :: To + TYPE(CSRMatrix_), INTENT(IN) :: From + END SUBROUTINE obj_Convert3 +END INTERFACE Convert + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE obj_Convert3 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! ColumnSORT@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 March 2021 +! summary: Sort column of row +! +!# Introduction +! +! - This routine sorts the elements of a matrix (stored in Compressed +! Sparse Row Format) in increasing order of their column indices within +! each row. It uses insertion sort algorithm +! +! - `values`= logical indicating whether or not the real values a(*) must +! also be permuted. IF (.not. values) then the array a is not +! touched by csort and can be a dummy array. +! +! - Default value of `SortValue` is true. + +INTERFACE ColumnSORT + MODULE SUBROUTINE obj_ColumnSORT(obj, isValues) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + LOGICAL(LGT), INTENT(IN), OPTIONAL :: isValues + END SUBROUTINE obj_ColumnSORT +END INTERFACE ColumnSORT + +!---------------------------------------------------------------------------- +! RemoveDuplicates@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: Removes duplicate entries from the sparse matrix +! +!# Introduction +! +! This routine calls CLNCSR routine from Sparsekit + +INTERFACE RemoveDuplicates + MODULE SUBROUTINE obj_RemoveDuplicates(obj, isValues) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + LOGICAL(LGT), INTENT(IN), OPTIONAL :: isValues + END SUBROUTINE obj_RemoveDuplicates +END INTERFACE RemoveDuplicates + +!---------------------------------------------------------------------------- +! Clean@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: Performs different tasks related to cleaning of sparse matrix +! +!# Introduction +! This routine performs tasks related to the cleaning of sparse matrix. + +INTERFACE Clean + MODULE SUBROUTINE obj_Clean(obj, isValues, ExtraOption) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues + !! If .TRUE. then values will be touched, otherwise they remain + !! untouched by this subroutine + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ExtraOption + !! If it is 0, then do nothing + !! If 1, then remove duplicates and zeros, if any + !! If 2, then remove duplicates and perform partial ordering + !! If 3, then remove duplicates, sort entries in increasing order of col + END SUBROUTINE obj_Clean +END INTERFACE Clean + +!---------------------------------------------------------------------------- +! Copy@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 March 2021 +! summary: Copy sparse matrix into each other + +INTERFACE Copy + MODULE SUBROUTINE obj_Copy(From, To) + TYPE(CSRMatrix_), INTENT(IN) :: From + TYPE(CSRMatrix_), INTENT(INOUT) :: To + END SUBROUTINE obj_Copy +END INTERFACE Copy + +!---------------------------------------------------------------------------- +! get@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This returns a sigle value from the matrix + +INTERFACE Get + MODULE FUNCTION obj_Get1(obj, i, j) RESULT(Ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: i, j + REAL(DFP) :: Ans + END FUNCTION obj_Get1 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Filter@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July, 2021 +! summary: This routine removes any elements whose absolute value is small +! from an input matrix A and puts the resulting matrix in B. +! +!# Introduction +! +! - `option` = integer. used to determine strategy chosen by caller to drop +! elements from matrix A. +! - `option` = 1, Elements whose absolute value is less than the drop +! tolerance are removed. +! - `option` = 2, Elements whose absolute value is less than the product of +! the drop tolerance and the Euclidean norm of the row are removed. +! - `option` = 3, Elements whose absolute value is less that the product of +! the drop tolerance and the largest element in the row are removed. +! - `droptol` = real. drop tolerance used for dropping strategy. + +INTERFACE DropEntry + MODULE SUBROUTINE obj_DropEntry(objIn, objOut, droptol, option) + TYPE(CSRMatrix_), INTENT(IN) :: objIn + TYPE(CSRMatrix_), INTENT(INOUT) :: objOut + REAL(DFP), INTENT(IN) :: droptol + INTEGER(I4B), OPTIONAL, INTENT(IN) :: option + END SUBROUTINE obj_DropEntry +END INTERFACE DropEntry + +!---------------------------------------------------------------------------- +! Transpose@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July 2021 +! summary: Transpose of the sparse matrix +! +!# Introduction +! +! In-place transposition routine. This subroutine transposes a matrix stored +! in compressed sparse row format. the transposition is done in place in that +! the arrays a,ja,ia c of the transpose are overwritten onto the original +! arrays. + +INTERFACE GetTRANSPOSE + MODULE SUBROUTINE obj_Transpose(obj) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Transpose +END INTERFACE GetTRANSPOSE + +!---------------------------------------------------------------------------- +! getDiagonal@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July 2021 +! summary: Returns the diagonal of sparse matrix +! +!# Introduction +! +! This subroutine returns the diagonal entries of sparse matrix. +! +! - offset: containing the offset of the wanted diagonal the diagonal +! extracted is the one corresponding to the entries `a(i,j)` with `j-i = +! ioff`. thus `ioff = 0` means the main diagonal +! - `diag` : real*8 array of length nrow containing the wanted diagonal. diag +! contains the diagonal (`a(i,j),j-i = ioff`) as defined above. +! - `idiag` = integer array of length `len`, containing the poisitions in +! the original arrays `a` and `ja` of the diagonal elements collected in +! `diag`. A zero entry in `idiag(i)` means that there was no entry found in +! row i belonging to the diagonal. + +INTERFACE GetDiagonal + MODULE SUBROUTINE obj_getDiagonal1(obj, diag, idiag, offset) + TYPE(CSRMatrix_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: idiag(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: offset + END SUBROUTINE obj_getDiagonal1 +END INTERFACE GetDiagonal + +!---------------------------------------------------------------------------- +! getDiagonal@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July 2021 +! summary: Returns the diagonal of sparse matrix +! +!# Introduction +! +! This subroutine returns the diagonal entries of sparse matrix. +! +! - offset: containing the offset of the wanted diagonal the diagonal +! extracted is the one corresponding to the entries `a(i,j)` with `j-i = +! ioff`. thus `ioff = 0` means the main diagonal +! - `diag` : real*8 array of length nrow containing the wanted diagonal. diag +! contains the diagonal (`a(i,j),j-i = ioff`) as defined above. + +INTERFACE GetDiagonal + MODULE SUBROUTINE obj_getDiagonal2(obj, diag, offset) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: offset + END SUBROUTINE obj_getDiagonal2 +END INTERFACE GetDiagonal + +!---------------------------------------------------------------------------- +! getLowerTriangle@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July 2021 +! summary: Returns the lower part of the sparse matrix +! +!# Introduction +! +! This subroutine returns the lower part of the sparse matrix. + +INTERFACE GetLowerTriangle + MODULE SUBROUTINE obj_getLowerTriangle(obj, L) + TYPE(CSRMatrix_), INTENT(IN) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: L + END SUBROUTINE obj_getLowerTriangle +END INTERFACE GetLowerTriangle + +!---------------------------------------------------------------------------- +! getUpperTriangle@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July 2021 +! summary: Returns the Upper part of the sparse matrix +! +!# Introduction +! +! This subroutine returns the Upper part of the sparse matrix. + +INTERFACE GetUpperTriangle + MODULE SUBROUTINE obj_getUpperTriangle(obj, U) + TYPE(CSRMatrix_), INTENT(IN) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: U + END SUBROUTINE obj_getUpperTriangle +END INTERFACE GetUpperTriangle + +!---------------------------------------------------------------------------- +! PermuteRow@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2021 +! summary: Permute the rows of sparse matrix + +INTERFACE PermuteRow + MODULE FUNCTION obj_permuteRow(obj, PERM, isValues) & + & RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: PERM(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues + TYPE(CSRMatrix_) :: ans + END FUNCTION obj_permuteRow +END INTERFACE PermuteRow + +!---------------------------------------------------------------------------- +! PermuteColumn@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2021 +! summary: Permute the columns of sparse matrix + +INTERFACE PermuteColumn + MODULE FUNCTION obj_permuteColumn(obj, PERM, isValues) & + & RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: PERM(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues + TYPE(CSRMatrix_) :: ans + END FUNCTION obj_permuteColumn +END INTERFACE PermuteColumn + +!---------------------------------------------------------------------------- +! Permute@Unary +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2021 +! summary: Permute the columns of sparse matrix + +INTERFACE Permute + MODULE FUNCTION obj_permute(obj, rowPERM, colPERM, & + & isValues, symPERM) RESULT(ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), OPTIONAL, INTENT(IN) :: rowPERM(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: colPERM(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isValues + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: symPERM + TYPE(CSRMatrix_) :: ans + END FUNCTION obj_permute +END INTERFACE Permute + +!---------------------------------------------------------------------------- +! GetSym +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-28 +! summary: Returns symmetric part of csrmatrix in symObj + +INTERFACE GetSym + MODULE SUBROUTINE obj_GetSym1(obj, symObj, from) + TYPE(CSRMatrix_), INTENT(IN) :: obj + TYPE(CSRMatrix_), INTENT(INOUT) :: symObj + CHARACTER(1), INTENT(IN) :: from + END SUBROUTINE obj_GetSym1 +END INTERFACE GetSym + +!---------------------------------------------------------------------------- +! GetSym +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-28 +! summary: Returns symmetric part of csrmatrix in symObj + +INTERFACE GetSym + MODULE SUBROUTINE obj_GetSym2(obj, from) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + CHARACTER(1), INTENT(IN) :: from + END SUBROUTINE obj_GetSym2 +END INTERFACE GetSym + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +END MODULE CSRMatrix_UnaryMethods diff --git a/src/modules/CSRSparsity/CMakeLists.txt b/src/modules/CSRSparsity/CMakeLists.txt new file mode 100644 index 000000000..7c10b33f3 --- /dev/null +++ b/src/modules/CSRSparsity/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/CSRSparsity_Method.F90 +) \ No newline at end of file diff --git a/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 b/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 new file mode 100644 index 000000000..479d0be9a --- /dev/null +++ b/src/modules/CSRSparsity/src/CSRSparsity_Method.F90 @@ -0,0 +1,821 @@ +! This program is a part of EASIFEM librarycsrsparsity +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: This module contains methods for [[CSRSparsity_]] + +MODULE CSRSparsity_Method +USE GlobalData +USE Basetype +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetSym +PUBLIC :: Initiate +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: SetSparsity +PUBLIC :: CSRSparsity +PUBLIC :: CSRSparsityPointer +PUBLIC :: DEALLOCATE +PUBLIC :: GetDiagonal +PUBLIC :: Display +PUBLIC :: Shape +PUBLIC :: Size +PUBLIC :: GetNNZ +PUBLIC :: GetColIndex +PUBLIC :: GetColNumber +PUBLIC :: OPERATOR(.startColumn.) +PUBLIC :: OPERATOR(.endColumn.) +PUBLIC :: SetIA +PUBLIC :: SetJA +PUBLIC :: GetIA +PUBLIC :: GetJA + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine constructs the CSR sparsity object +! +!# Introduction +! +! This subroutine initiate the instance of [[CSRSparsity_]] object +! +! - ncol is the number of columns +! - nrow is the number of rows +! - dof is the degrees of freedom object, if it is present then it used +! to initiate [[DOF_:dof]]. +! +!@note +! If dof object is not present, then this routine initiates +! [[CSRSparsity_:dof]] internally with following options. +! +! - tNodes = [nrow] +! - names= ["K"] +! - spacecompo= [1] +! - timecompo = [1] +! - storageFMT = FMT_NODES +!@endnote +! + +INTERFACE Initiate + MODULE SUBROUTINE obj_initiate1(obj, ncol, nrow, idof, jdof, nnz) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ncol, nrow + TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof + !! DOF for row + TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof + !! DOF for column + INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnz + !! number of nonzeros + END SUBROUTINE obj_initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine construct `CSRSparsity_` object from copying +! +!# Introduction +! +! This subroutine copies `obj2` into `obj`, and initiates the latter one. +! This routine is used to define the assignment operator. + +INTERFACE Initiate + MODULE SUBROUTINE obj_initiate2(obj, obj2) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + TYPE(CSRSparsity_), INTENT(IN) :: obj2 + END SUBROUTINE obj_initiate2 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE obj_initiate2 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine constructs `CSRSparsity_` object from IA, JA +! +!# Introduction +! +! - This routine constructs [[CSRSparsity_]] instance by using the +! indices `IA` and `JA` +! - This routine is helpful in reading data from files. +! - This routine calls [[CSRSparsity_Method:obj_initiate1]] method +! without `dof` argument. So this type of initiation does not contain +! useful information about the degree of freedoms. +! + +INTERFACE Initiate + MODULE SUBROUTINE obj_initiate3(obj, IA, JA, ncol) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: IA(:), JA(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ncol + !! number of columns, default is number of rows + END SUBROUTINE obj_initiate3 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! CSRSparsity@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct, 2021 +! summary: Returns an instance of [[CSRSparsity_]] +! +!# Introduction +! +! This function returns an instance of [[CSRSparsity_]] + +INTERFACE CSRSparsity + MODULE FUNCTION obj_constructor1(nrow, ncol, idof, jdof) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nrow + INTEGER(I4B), INTENT(IN) :: ncol + TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof + !! dof for row + TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof + !! dof for column + TYPE(CSRSparsity_) :: ans + END FUNCTION obj_constructor1 +END INTERFACE CSRSparsity + +!---------------------------------------------------------------------------- +! CSRSparsity@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct, 2021 +! summary: Returns an instance of [[CSRSparsity_]] +! +!# Introduction +! +! This function returns an instance of [[CSRSparsity_]] + +INTERFACE CSRSparsity + MODULE FUNCTION obj_constructor2(IA, JA) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: IA(:) + INTEGER(I4B), INTENT(IN) :: JA(:) + TYPE(CSRSparsity_) :: ans + END FUNCTION obj_constructor2 +END INTERFACE CSRSparsity + +!---------------------------------------------------------------------------- +! CSRSparsityPointer@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct, 2021 +! summary: Returns an instance of [[CSRSparsity_]] +! +!# Introduction +! +! This function returns an instance of [[CSRSparsity_]] + +INTERFACE CSRSparsityPointer + MODULE FUNCTION obj_constructor_1(nrow, ncol, idof, jdof) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nrow + INTEGER(I4B), INTENT(IN) :: ncol + TYPE(DOF_), OPTIONAL, INTENT(IN) :: idof + !! dof for row + TYPE(DOF_), OPTIONAL, INTENT(IN) :: jdof + !! dof for column + TYPE(CSRSparsity_), POINTER :: ans + END FUNCTION obj_constructor_1 +END INTERFACE CSRSparsityPointer + +!---------------------------------------------------------------------------- +! CSRSparsityPointer@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct, 2021 +! summary: Returns an instance of [[CSRSparsity_]] +! +!# Introduction +! +! This function returns an instance of [[CSRSparsity_]] + +INTERFACE CSRSparsityPointer + MODULE FUNCTION obj_constructor_2(IA, JA) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: IA(:) + INTEGER(I4B), INTENT(IN) :: JA(:) + TYPE(CSRSparsity_), POINTER :: ans + END FUNCTION obj_constructor_2 +END INTERFACE CSRSparsityPointer + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine deallocates the data + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE obj_Deallocate(obj) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine display the content of sparsity + +INTERFACE Display + MODULE SUBROUTINE obj_Display(obj, Msg, UnitNo) + TYPE(CSRSparsity_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: Msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + END SUBROUTINE obj_Display +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Shape@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This function returns the shape of the sparse matrix +! +!# Introduction +! +! This function returns the shape of sparse matrix + +INTERFACE Shape + MODULE PURE FUNCTION obj_shape(obj) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B) :: ans(2) + END FUNCTION obj_shape +END INTERFACE Shape + +!---------------------------------------------------------------------------- +! Size@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This function returns the size of sparse matrix +! +!# Introduction +! +! This function returns the size of sparse matrix +! If Dims equal to 1 then total number of rows are returned +! If Dims is equal to 2 then total number of columns are return +! If Dims is absent then nrow*ncol are returned + +INTERFACE Size + MODULE PURE FUNCTION obj_size(obj, Dims) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Dims + INTEGER(I4B) :: ans + END FUNCTION obj_size +END INTERFACE Size + +!---------------------------------------------------------------------------- +! GetNNZ@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Return the total number of non zero entry + +INTERFACE GetNNZ + MODULE PURE FUNCTION obj_GetNNZ(obj) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_GetNNZ +END INTERFACE GetNNZ + +!---------------------------------------------------------------------------- +! GetNNZ@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Return the total number of non zero entry + +INTERFACE GetNNZ + MODULE PURE FUNCTION obj_GetNNZ_from_operation(obj1, obj2, op, isSorted) & + & RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj1 + !! CSRSparsity object + TYPE(CSRSparsity_), INTENT(IN) :: obj2 + !! CSRSparsity object + CHARACTER(1), INTENT(IN) :: op + !! "*", "+", "-" + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isSorted + !! Set it to true if the columns are sorted in obj1 and obj2 + !! Default is .false. + INTEGER(I4B) :: ans + !! total number of non zero entries + END FUNCTION obj_GetNNZ_from_operation +END INTERFACE GetNNZ + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: Initiate an object by adding two csrmatrix + +INTERFACE + MODULE PURE FUNCTION GetNNZ_Add_Subtract(nrow, ncol, ja, ia, jb, ib) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nrow, ncol + !! number of rows in a and b matrix + INTEGER(I4B), INTENT(IN) :: ja(:) + !! sparsity of ja + INTEGER(I4B), INTENT(IN) :: ia(:) + !! nrow + 1 + INTEGER(I4B), INTENT(IN) :: jb(:) + !! sparsity of jb + INTEGER(I4B), INTENT(IN) :: ib(:) + !! nrow + 1 + INTEGER(I4B) :: ans + END FUNCTION GetNNZ_Add_Subtract +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-16 +! summary: Initiate an object by adding two csrmatrix + +INTERFACE + MODULE PURE FUNCTION GetNNZ_Add_Subtract_sorted(nrow, ncol, ja, ia, jb, & + & ib) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nrow, ncol + !! number of rows in a and b matrix + INTEGER(I4B), INTENT(IN) :: ja(:) + !! sparsity of ja + INTEGER(I4B), INTENT(IN) :: ia(:) + !! nrow + 1 + INTEGER(I4B), INTENT(IN) :: jb(:) + !! sparsity of jb + INTEGER(I4B), INTENT(IN) :: ib(:) + !! nrow + 1 + INTEGER(I4B) :: ans + END FUNCTION GetNNZ_Add_Subtract_sorted +END INTERFACE + +!---------------------------------------------------------------------------- +! GetNNZ@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-28 +! summary: Return the total number of non zero entry + +INTERFACE GetNNZ + MODULE PURE FUNCTION obj_GetNNZ1(obj, from) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + CHARACTER(1), INTENT(IN) :: from + !! "U" nnz in upper triangular part, j > i + !! "L" nnz in lower triangular part, i > j + !! "D" nnz in diagonal part, i=j + !! "A" nnz in whole matrix, L+U+D + INTEGER(I4B) :: ans + END FUNCTION obj_GetNNZ1 +END INTERFACE GetNNZ + +!---------------------------------------------------------------------------- +! GetNNZ@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-28 +! summary: Return the total number of non zero in U, L and D + +INTERFACE GetNNZ + MODULE PURE FUNCTION obj_GetNNZ2(obj, from) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + CHARACTER(1), INTENT(IN) :: from(1) + !! this argument is not referred, it is here + !! to create a unique interface only + INTEGER(I4B) :: ans(3) + !! [nnzU, nnzL, nnzD] + END FUNCTION obj_GetNNZ2 +END INTERFACE GetNNZ + +!---------------------------------------------------------------------------- +! GetDiagonal@GeMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July 2021 +! summary: Returns the diagonal of sparse matrix +! +!# Introduction +! +! This subroutine returns the diagonal entries of sparse matrix. This +! Routine calls the Saad's sparse library. +! +! `offSet`: containing the `offset` of the wanted diagonal. The diagonal +! extracted is the one corresponding to the entries `a(i,j)` with `j-i = +! offSet`. Therefore, `offset = 0` means the main diagonal +! +! `diag` : real array of length `nrow` containing the wanted diagonal. `diag` +! contains the diagonal (`a(i,j),j-i = offSet`) as defined above. +! +! `idiag` = integer array. It contains the poisitions of diagonal in the +! original arrays `A`. If `idiag(i)=0` then it means that there was no +! diagonal found in row=i. + +INTERFACE GetDiagonal + MODULE SUBROUTINE obj_GetDiagonal1(obj, A, diag, idiag, offSet) + TYPE(CSRSparsity_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) + !! Diagonal entries + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: idiag(:) + !! Position of diagonal entries in `A(:)` + INTEGER(I4B), OPTIONAL, INTENT(IN) :: offSet + !! offSet of the wanted diagonal + END SUBROUTINE obj_GetDiagonal1 +END INTERFACE GetDiagonal + +!---------------------------------------------------------------------------- +! GetDiagonal@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 July 2021 +! summary: Returns the diagonal of sparse matrix +! +!# Introduction +! +! This subroutine returns the diagonal entries of sparse matrix. +! +! This routine is similar to [[CSRSparsity_Method:obj_GetDiagonal1]]. +! However, this routine does not return the position of diagonal in `A` + +INTERFACE GetDiagonal + MODULE SUBROUTINE obj_GetDiagonal2(obj, A, diag, offSet) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: A(:) + !! Sparse matrix values + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: diag(:) + !! Diagonal entries + INTEGER(I4B), OPTIONAL, INTENT(IN) :: offSet + !! offSet of diagonal + END SUBROUTINE obj_GetDiagonal2 +END INTERFACE GetDiagonal + +!---------------------------------------------------------------------------- +! GetColNumber@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the column number from JA. + +INTERFACE GetColNumber + MODULE PURE FUNCTION obj_GetColNumber1(obj, indx) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(I4B) :: ans + END FUNCTION obj_GetColNumber1 +END INTERFACE GetColNumber + +!---------------------------------------------------------------------------- +! GetColIndex@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the starting and ending column index of irow + +INTERFACE GetColIndex + MODULE PURE FUNCTION obj_GetColIndex1(obj, irow) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B) :: ans(2) + END FUNCTION obj_GetColIndex1 +END INTERFACE GetColIndex + +!---------------------------------------------------------------------------- +! startColumn@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the starting column index of irow + +INTERFACE OPERATOR(.startColumn.) + MODULE PURE FUNCTION obj_startColumn1(obj, irow) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B) :: ans + END FUNCTION obj_startColumn1 +END INTERFACE OPERATOR(.startColumn.) + +!---------------------------------------------------------------------------- +! endColumn@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get the ending column index of irow + +INTERFACE OPERATOR(.endColumn.) + MODULE PURE FUNCTION obj_endColumn1(obj, irow) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B) :: ans + END FUNCTION obj_endColumn1 +END INTERFACE OPERATOR(.endColumn.) + +!---------------------------------------------------------------------------- +! SetSparsity@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set the sparsity pattern of a given row +! +!# Introduction +! +! This subroutine Sets the sparsity pattern of a given row +! - If `obj%tdof` is equal to 1, then `Col` is sorted in increasing order, +! and appended to `obj%Row(Row)` +! - If `obj%tdof` is not equal to 1, then based on the storage format and +! `Col` connectivity information is generated. + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_SetSparsity1(obj, Row, Col) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Row + !! row number + INTEGER(I4B), INTENT(IN) :: Col(:) + !! column number + END SUBROUTINE obj_SetSparsity1 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Sets the sparsity pattern of several rows +! +!# Introduction +! This routine is similar to [[CSRSparsity_Method:obj_SetSparsity1]]. +! However, in this routine several rows can be given. + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_SetSparsity2(obj, Row, Col) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Row(:) + !! row number + TYPE(IntVector_), INTENT(IN) :: Col(:) + !! column number + END SUBROUTINE obj_SetSparsity2 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2021 +! summary: This subroutine Sets sparsity pattern for block `CSRSparsity_` + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_SetSparsity3(obj, row, col, ivar, jvar) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: row + !! row number + INTEGER(I4B), INTENT(IN) :: col(:) + !! sparsity of row, column numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! block address (row index) + INTEGER(I4B), INTENT(IN) :: jvar + !! block address (col index) + END SUBROUTINE obj_SetSparsity3 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Sets the sparsity pattern of a given row +! +!# Introduction +! This routine is similar to the [[CSRSparsity_Method:obj_SetSparsity3]], +! however, in this routine we can specify several rows and their +! column indices. + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_SetSparsity4(obj, Row, Col, iVar, jVar) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Row(:) + !! several row numbers + TYPE(IntVector_), INTENT(IN) :: Col(:) + !! column index for each row number + INTEGER(I4B), INTENT(IN) :: iVar + !! block address (row index) + INTEGER(I4B), INTENT(IN) :: jVar + !! block address (col index) + END SUBROUTINE obj_SetSparsity4 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set the sparsity pattern of a given row +! +!# Introduction +! +! This subroutine Sets the sparsity pattern by using the graph. +! graph( i, j ) is either 0 or 1, if zero then there is not connection +! between row-i and row-j + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_SetSparsity5(obj, graph) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: graph(:, :) + !! graph of sparsity + !! If graph( i, j ) .EQ. 0, then i and j are not connected + !! else they are connected. + END SUBROUTINE obj_SetSparsity5 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set the sparsity pattern of a given row +! +!# Introduction +! +! This subroutine Sets the sparsity pattern by using the graph. +! graph( i, j ) is either FALSE or TRUE, if FALSE then there is not connection +! between row-i and row-j + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_SetSparsity6(obj, graph) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + LOGICAL(LGT), INTENT(IN) :: graph(:, :) + !! graph of sparsity + !! If graph( i, j ) .EQ. FALSE, then i and j are not connected + !! else they are connected. + END SUBROUTINE obj_SetSparsity6 +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetSparsity@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Set sparsity pattern of `CSRSparsity_` +! +!# Introduction +! This subroutine Set sparsity pattern of `CSRSparsity_` +! This will finally Set the data into +! - `obj%IA(:)`, +! - `obj%JA(:)` +! in CSR format. This routine also Set data inside `obj%ColSize(:)` and +! `obj%RowSize(:) `, and `obj%DiagIndx(:)` + +INTERFACE SetSparsity + MODULE SUBROUTINE obj_SetSparsity_final(obj) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + END SUBROUTINE obj_SetSparsity_final +END INTERFACE SetSparsity + +!---------------------------------------------------------------------------- +! SetIA@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Set entry in IA + +INTERFACE SetIA + MODULE PURE SUBROUTINE obj_SetIA(obj, irow, VALUE) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B), INTENT(IN) :: VALUE + END SUBROUTINE obj_SetIA +END INTERFACE SetIA + +!---------------------------------------------------------------------------- +! SetJA@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Set entry in JA + +INTERFACE SetJA + MODULE PURE SUBROUTINE obj_SetJA(obj, indx, VALUE) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(I4B), INTENT(IN) :: VALUE + END SUBROUTINE obj_SetJA +END INTERFACE SetJA + +!---------------------------------------------------------------------------- +! GetIA@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-23 +! summary: Get entry from IA + +INTERFACE GetIA + MODULE PURE FUNCTION obj_GetIA(obj, irow) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow + INTEGER(I4B) :: ans + END FUNCTION obj_GetIA +END INTERFACE GetIA + +!---------------------------------------------------------------------------- +! GetJA@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get entry from JA + +INTERFACE GetJA + MODULE PURE FUNCTION obj_GetJA(obj, indx) RESULT(ans) + TYPE(CSRSparsity_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(I4B) :: ans + END FUNCTION obj_GetJA +END INTERFACE GetJA + +!---------------------------------------------------------------------------- +! GetSym@SymMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-28 +! summary: Get symmetric part + +INTERFACE GetSym + MODULE SUBROUTINE obj_GetSym1(obj, symObj, from) + TYPE(CSRSparsity_), INTENT(IN) :: obj + TYPE(CSRSparsity_), INTENT(INOUT) :: symObj + CHARACTER(1), INTENT(IN) :: from + END SUBROUTINE obj_GetSym1 +END INTERFACE GetSym + +!---------------------------------------------------------------------------- +! GetSym@SymMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-28 +! summary: Get symmetric part + +INTERFACE GetSym + MODULE SUBROUTINE obj_GetSym2(obj, from) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + CHARACTER(1), INTENT(IN) :: from + END SUBROUTINE obj_GetSym2 +END INTERFACE GetSym + +END MODULE CSRSparsity_Method diff --git a/src/modules/ConvectiveMatrix/CMakeLists.txt b/src/modules/ConvectiveMatrix/CMakeLists.txt new file mode 100644 index 000000000..42b66b648 --- /dev/null +++ b/src/modules/ConvectiveMatrix/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}/ConvectiveMatrix_Method.F90 +) diff --git a/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 b/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 new file mode 100644 index 000000000..b38be47e3 --- /dev/null +++ b/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 @@ -0,0 +1,125 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE ConvectiveMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@ConvectiveMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-21 +! update: 2021-11-21 +! summary: returns the convective matrix + +INTERFACE + MODULE PURE FUNCTION ConvectiveMatrix_1(test, trial, term1, & + & term2, opt) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z, del_x_all, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z, del_x_all, del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ConvectiveMatrix_1 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE ConvectiveMatrix_1 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@ConvectiveMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-21 +! update: 2021-11-21 +! summary: returns the convective matrix + +INTERFACE + MODULE PURE FUNCTION ConvectiveMatrix_2(test, trial, c, crank, term1, & + & term2, opt) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + !! scalar variable + TYPE(FEVariableScalar_), INTENT(IN) :: crank + !! scalar variable + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z, del_x_all, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z, del_x_all, del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! number of copies + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ConvectiveMatrix_2 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE ConvectiveMatrix_2 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@ConvectiveMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-21 +! update: 2021-11-21 +! summary: returns the convective matrix + +INTERFACE + MODULE PURE FUNCTION ConvectiveMatrix_3(test, trial, c, crank, term1, & + & term2, opt) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + !! It can be a scalar or vector variable + TYPE(FEVariableVector_), INTENT(IN) :: crank + !! It can be a scalar or vector variable + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z, del_x_all, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z, del_x_all, del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! number of copies + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ConvectiveMatrix_3 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE ConvectiveMatrix_3 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ConvectiveMatrix_Method diff --git a/src/modules/DOF/CMakeLists.txt b/src/modules/DOF/CMakeLists.txt new file mode 100644 index 000000000..35bb9361d --- /dev/null +++ b/src/modules/DOF/CMakeLists.txt @@ -0,0 +1,27 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/DOF_Method.F90 + ${src_path}/DOF_ConstructorMethods.F90 + ${src_path}/DOF_IOMethods.F90 + ${src_path}/DOF_GetMethods.F90 + ${src_path}/DOF_GetValueMethods.F90 + ${src_path}/DOF_SetMethods.F90 + ${src_path}/DOF_AddMethods.F90 +) diff --git a/src/modules/DOF/src/DOF_AddMethods.F90 b/src/modules/DOF/src/DOF_AddMethods.F90 new file mode 100644 index 000000000..14241de95 --- /dev/null +++ b/src/modules/DOF/src/DOF_AddMethods.F90 @@ -0,0 +1,451 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 DOF_AddMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of all dof defined inside `obj`. Once +! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. +! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF` +! or `NONE`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add1(vec, obj, nodenum, VALUE, scale, & + conversion) + REAL(DFP), INTENT(INOUT) :: vec(:) + !! Vector to set values in + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! Node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! Value + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(IN) :: conversion(1) + !! conversion + END SUBROUTINE obj_Add1 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of all dof defined inside `obj`. Once +! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. +! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF` +! or `NONE`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add2(vec, obj, nodenum, VALUE, scale) + REAL(DFP), INTENT(INOUT) :: vec(:) + !! vector to set values in + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + REAL(DFP), INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_Add2 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of dof `dofno`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add3(vec, obj, nodenum, VALUE, scale, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + !! vector to set values in + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vec = values, size of value should be equal to the size of nodenum + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + END SUBROUTINE obj_Add3 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +! This subroutine calls obj_Add3 + +INTERFACE Add + MODULE SUBROUTINE obj_Add4(vec, obj, nodenum, VALUE, scale, ivar, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + !! vector to set values in + TYPE(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add4 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!@note +! this routine calls obj_Add3 +!@endnote + +INTERFACE Add + MODULE SUBROUTINE obj_Add5(vec, obj, nodenum, VALUE, scale, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + !! the size of value should be same as nodenum + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space components + INTEGER(I4B), INTENT(IN) :: timecompo + !! time components + END SUBROUTINE obj_Add5 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers + +INTERFACE Add + MODULE SUBROUTINE obj_Add6(vec, obj, nodenum, VALUE, scale, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space components + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time components + END SUBROUTINE obj_Add6 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers + +INTERFACE Add + MODULE SUBROUTINE obj_Add7(vec, obj, nodenum, VALUE, scale, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! space components + INTEGER(I4B), INTENT(IN) :: timecompo + !! time components + END SUBROUTINE obj_Add7 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of all dof defined inside `obj`. Once +! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. +! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF` +! or `NONE`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add8(vec, obj, nodenum, VALUE, scale) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add8 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of dof `dofno`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add9(vec, obj, nodenum, VALUE, scale, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add9 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of dof `dofno`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add10(vec, obj, nodenum, VALUE, scale, ivar, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add10 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of dof `dofno`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add11(vec, obj, nodenum, VALUE, scale, & + ivar, spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add11 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of dof `dofno`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add12(vec, obj, nodenum, VALUE, scale, & + ivar, spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + END SUBROUTINE obj_Add12 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Add values in a vector of real numbers +! +!# Introduction +! +! This subroutine is designed to Add values in a vector of real number +! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom +! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF` +! - `value` denotes the nodal values of dof `dofno`. +! +! This subroutine effectivily performes +! `vec( nptrs ) = vec(nptrs) + scale * value` + +INTERFACE Add + MODULE SUBROUTINE obj_Add13(vec, obj, nodenum, VALUE, scale, & + ivar, spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add13 +END INTERFACE Add + +END MODULE DOF_AddMethods diff --git a/src/modules/DOF/src/DOF_ConstructorMethods.F90 b/src/modules/DOF/src/DOF_ConstructorMethods.F90 new file mode 100644 index 000000000..f70e5bd71 --- /dev/null +++ b/src/modules/DOF/src/DOF_ConstructorMethods.F90 @@ -0,0 +1,220 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 DOF_ConstructorMethods +USE GlobalData, ONLY: DFP, I4B, LGT, FMT_DOF, FMT_NODES, DOF_FMT, & + NODES_FMT + +USE BaseType, ONLY: DOF_ + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: Initiate +PUBLIC :: DOF_Pointer +PUBLIC :: DEALLOCATE +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: DOF + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine initiate DOF_ object +! +!# Introduction +! +! This subroutine initiate DOF_ object +! +!- If the size of all physical variables are equal then set +! tNodes = [tNodes] otherwise we need to provide size of each dof +!- For a scalar physical variable such as pressure and temperature, +! `spacecompo` is set to -1. +!- For a time independent physical variable `timecompo` is set to 1. +!- The size of `Names`, `spacecompo`, `timecompo` should be same +! +!@note +! $\matbf{v}$ is a physical variable, however, +! its component $v_1, v_2, v_3$ all are degrees of freedom. +!@endnote + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_initiate1(obj, tNodes, Names, spacecompo, & + & timecompo, StorageFMT) + CLASS(DOF_), INTENT(INOUT) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: tNodes(:) + !! number of nodes for each physical variable + CHARACTER(1), INTENT(IN) :: Names(:) + !! Names of each physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! Space component of each physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! Time component of each physical variable + INTEGER(I4B), INTENT(IN) :: StorageFMT + !! Storage format `FMT_DOF`, `FMT_Nodes` + END SUBROUTINE obj_initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Initiate a fortran vector using DOF_ object +! +!# Introduction +! +! This subroutine initiates a fortran vector (rank-1 fortran array ) of +! real using the information stored inside DOF_ object. This subroutine +! gets the size of array from the DOF_ object and then reallocates +! `val` and set its all values to zero. + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_initiate2(val, obj) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: val(:) + !! This vector will be initiated by using obj + CLASS(DOF_), INTENT(IN) :: obj + !! DOF object + END SUBROUTINE obj_initiate2 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct, 2021 +! summary: Initiate two fortran vectors using obj_ object +! +!# Introduction +! +! This subroutine can initiate two fortran vectors (rank-1 fortran arrays) +! using the information stored inside the DOF_ object + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_initiate3(Val1, Val2, obj) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Val1(:), Val2(:) + CLASS(DOF_), INTENT(IN) :: obj + END SUBROUTINE obj_initiate3 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 July 2021 +! summary: Initiate an instance of DOF_ by copying other object +! +!# Introduction +! +! This routine copy obj2 into obj1. It also define an assignment operator + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_initiate4(obj1, obj2) + CLASS(DOF_), INTENT(INOUT) :: obj1 + CLASS(DOF_), INTENT(IN) :: obj2 + END SUBROUTINE obj_initiate4 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE obj_initiate4 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! DOF@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 oct 2021 +! summary: Constructor for dof_ object +! +!# Introduction +! +! This function return instance of DOF_ +! This function calls DOF_Method:DOF_Initiate1 method +! for more see dof_ + +INTERFACE DOF + MODULE PURE FUNCTION obj_Constructor1(tNodes, Names, spacecompo, timecompo, & + & StorageFMT) RESULT(obj) + TYPE(DOF_) :: obj + INTEGER(I4B), INTENT(IN) :: tNodes(:), spacecompo(:), & + & timecompo(:), StorageFMT + CHARACTER(1), INTENT(IN) :: Names(:) + END FUNCTION obj_Constructor1 +END INTERFACE DOF + +!---------------------------------------------------------------------------- +! DOF_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct, 2021 +! summary: Returns pointer to newly created dof_ object +! +!# Introduction +! +! This function returns the pointer to instance of dof_ object +! for more see dof_ + +INTERFACE DOF_Pointer + MODULE FUNCTION obj_Constructor_1(tNodes, Names, spacecompo, timecompo, & + & StorageFMT) RESULT(obj) + CLASS(DOF_), POINTER :: obj + !! dof_ object + INTEGER(I4B), INTENT(IN) :: tNodes(:) + !! total number of nodes for each dof + CHARACTER(1), INTENT(IN) :: Names(:) + !! name of each dof + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! space components for each dof + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time component for each dof + INTEGER(I4B), INTENT(IN) :: StorageFMT + !! storage format for dof + END FUNCTION obj_Constructor_1 +END INTERFACE DOF_Pointer + +!---------------------------------------------------------------------------- +! Deallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: Oct 10, 2021 +! summary: Deallocate data in dof_ +! +!# Introduction +! +! This subroutine deallocates the data in DOF_ object + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE obj_Deallocate(obj) + CLASS(DOF_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE DOF_ConstructorMethods diff --git a/src/modules/DOF/src/DOF_GetMethods.F90 b/src/modules/DOF/src/DOF_GetMethods.F90 new file mode 100644 index 000000000..a81bd982e --- /dev/null +++ b/src/modules/DOF/src/DOF_GetMethods.F90 @@ -0,0 +1,1595 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 DOF_GetMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: DOF_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: OPERATOR(.DOFStartIndex.) +PUBLIC :: OPERATOR(.DOFEndIndex.) +PUBLIC :: OPERATOR(.tNodes.) +PUBLIC :: OPERATOR(.tNames.) +PUBLIC :: OPERATOR(.tDOF.) +PUBLIC :: OPERATOR(.tspacecomponents.) +PUBLIC :: OPERATOR(.spacecomponents.) +PUBLIC :: OPERATOR(.timecomponents.) +PUBLIC :: OPERATOR(.ttimecomponents.) +PUBLIC :: OPERATOR(.EQ.) +PUBLIC :: OPERATOR(.NE.) +PUBLIC :: OPERATOR(.Names.) +PUBLIC :: GetIDOF +PUBLIC :: SIZE +PUBLIC :: GetNodeLoc +PUBLIC :: GetNodeLoc_ +PUBLIC :: GetIndex +PUBLIC :: GetIndex_ + +!---------------------------------------------------------------------------- +! DOFStartIndex@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: returns obj%map( ivar, 5 ) + +INTERFACE + MODULE PURE FUNCTION obj_DOFStartIndex(obj, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B) :: ans + END FUNCTION obj_DOFStartIndex +END INTERFACE + +INTERFACE OPERATOR(.DOFStartIndex.) + MODULE PROCEDURE obj_DOFStartIndex +END INTERFACE OPERATOR(.DOFStartIndex.) + +!---------------------------------------------------------------------------- +! DOFEndIndex@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: returns obj%map( ivar+1, 5 ) - 1 + +INTERFACE OPERATOR(.DOFEndIndex.) + MODULE PURE FUNCTION obj_DOFEndIndex(obj, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B) :: ans + END FUNCTION obj_DOFEndIndex +END INTERFACE + +!---------------------------------------------------------------------------- +! tNodes@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the total length of the vector + +INTERFACE Size + MODULE PURE FUNCTION obj_tNodes1(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_tNodes1 +END INTERFACE Size + +INTERFACE OPERATOR(.tNodes.) + MODULE PROCEDURE obj_tNodes1 +END INTERFACE + +!---------------------------------------------------------------------------- +! tNodes@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: This function returns the total number of nodes +! +!# Introduction +! +! This function returns the total number of nodes for a given degree of +! freedom number +! idof should be lesser than the total degree of freedom + +INTERFACE Size + MODULE PURE FUNCTION obj_tNodes2(obj, idof) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: idof + INTEGER(I4B) :: ans + END FUNCTION obj_tNodes2 +END INTERFACE Size + +INTERFACE OPERATOR(.tNodes.) + MODULE PROCEDURE obj_tNodes2 +END INTERFACE + +!---------------------------------------------------------------------------- +! tNodes@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: This function returns the total number of nodes +! +!# Introduction +! +! This function returns the total number of nodes for a given degree of +! freedom number +! idof should be lesser than the total degree of freedom + +INTERFACE Size + MODULE PURE FUNCTION obj_tNodes3(obj, varname) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: varname + INTEGER(I4B) :: ans + END FUNCTION obj_tNodes3 +END INTERFACE Size + +INTERFACE OPERATOR(.tNodes.) + MODULE PROCEDURE obj_tNodes3 +END INTERFACE + +!---------------------------------------------------------------------------- +! tNodes@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: This function returns the total number of nodes +! +!# Introduction +! +! This function returns the total number of nodes for a given degree of +! freedom number +! idof should be lesser than the total degree of freedom + +INTERFACE Size + MODULE PURE FUNCTION obj_tNodes4(obj, idof) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: idof(:) + INTEGER(I4B) :: ans + END FUNCTION obj_tNodes4 +END INTERFACE Size + +INTERFACE OPERATOR(.tNodes.) + MODULE PROCEDURE obj_tNodes4 +END INTERFACE + +!---------------------------------------------------------------------------- +! tDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: This function returns the total number of degree of freedom + +INTERFACE OPERATOR(.tDOF.) + MODULE PURE FUNCTION obj_tdof1(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_tdof1 +END INTERFACE + +!---------------------------------------------------------------------------- +! tDOF@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: This subroutine returns the total number of degrees of freedom +! +!# Introduction +! This function returns the total number of degrees of freedom in a +! physical variable. +! The physical variable is specified by using its name. + +INTERFACE OPERATOR(.tDOF.) + MODULE PURE FUNCTION obj_tdof2(obj, Name) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + CHARACTER(1), INTENT(IN) :: Name + INTEGER(I4B) :: ans + END FUNCTION obj_tdof2 +END INTERFACE + +!---------------------------------------------------------------------------- +! tDOF@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: This subroutine returns the total number of degrees of freedom +! +!# Introduction +! This function returns the total number of degrees of freedom in a +! physical variable. +! The physical variable is specified by using its name. + +INTERFACE OPERATOR(.tDOF.) + MODULE PURE FUNCTION obj_tdof3(obj, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B) :: ans + END FUNCTION obj_tdof3 +END INTERFACE + +!---------------------------------------------------------------------------- +! tDOF@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This subroutine returns the total number of degrees of freedom +! +!# Introduction +! This function returns the total number of degrees of freedom in a +! physical variable. +! The physical variable is specified by using its name. + +INTERFACE OPERATOR(.tDOF.) + MODULE PURE FUNCTION obj_tdof4(obj, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar(:) + INTEGER(I4B) :: ans + END FUNCTION obj_tdof4 +END INTERFACE + +!---------------------------------------------------------------------------- +! tNames@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the total number of names in dof object + +INTERFACE OPERATOR(.tNames.) + MODULE PURE FUNCTION obj_tNames(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_tNames +END INTERFACE + +!---------------------------------------------------------------------------- +! Names@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the name of all physical variables stored in obj + +INTERFACE OPERATOR(.Names.) + MODULE PURE FUNCTION obj_names1(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + CHARACTER(1), ALLOCATABLE :: ans(:) + END FUNCTION obj_names1 +END INTERFACE OPERATOR(.Names.) + +!---------------------------------------------------------------------------- +! Names@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: This function returns the name of a physical variable +! +!# Introduction +! +! This function returns the name of a physical variable +! The physical variable is given by its number ii, i.e., the first, second, +! third, and so on, physical variable. + +INTERFACE OPERATOR(.Names.) + MODULE PURE FUNCTION obj_names2(obj, ii) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ii + CHARACTER(1) :: ans + END FUNCTION obj_names2 +END INTERFACE OPERATOR(.Names.) + +!---------------------------------------------------------------------------- +! NameToIndex@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Return the index of a physical variable + +INTERFACE + MODULE PURE FUNCTION NameToIndex(obj, Name) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + CHARACTER(1), INTENT(IN) :: Name + INTEGER(I4B) :: ans + END FUNCTION NameToIndex +END INTERFACE + +!---------------------------------------------------------------------------- +! tspacecomponents@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: Returns the total physical variable which have space-compo + +INTERFACE OPERATOR(.tspacecomponents.) + MODULE PURE FUNCTION obj_tspacecomponents(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_tspacecomponents +END INTERFACE OPERATOR(.tspacecomponents.) + +!---------------------------------------------------------------------------- +! spacecomponents@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: Returns the space components of each physical vars + +INTERFACE OPERATOR(.spacecomponents.) + MODULE PURE FUNCTION obj_spacecomponents1(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION obj_spacecomponents1 +END INTERFACE OPERATOR(.spacecomponents.) + +!---------------------------------------------------------------------------- +! spacecomponents@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: Returns the space component of a given physical vars + +INTERFACE OPERATOR(.spacecomponents.) + MODULE PURE FUNCTION obj_spacecomponents2(obj, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B) :: ans + END FUNCTION obj_spacecomponents2 +END INTERFACE OPERATOR(.spacecomponents.) + +!---------------------------------------------------------------------------- +! ttimecomponents@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: Returns the total physical var which has time compo + +INTERFACE OPERATOR(.ttimecomponents.) + MODULE PURE FUNCTION obj_ttimecomponents(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_ttimecomponents +END INTERFACE OPERATOR(.ttimecomponents.) + +!---------------------------------------------------------------------------- +! timecomponents@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: Returns the timecompo + +INTERFACE OPERATOR(.timecomponents.) + MODULE PURE FUNCTION obj_timecomponents1(obj) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION obj_timecomponents1 +END INTERFACE OPERATOR(.timecomponents.) + +!---------------------------------------------------------------------------- +! timecomponents@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Oct 2021 +! summary: Returns the timecompo + +INTERFACE OPERATOR(.timecomponents.) + MODULE PURE FUNCTION obj_timecomponents2(obj, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B) :: ans + END FUNCTION obj_timecomponents2 +END INTERFACE OPERATOR(.timecomponents.) + +!---------------------------------------------------------------------------- +! EQ@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE OPERATOR(.EQ.) + MODULE PURE FUNCTION obj_isEqual(obj1, obj2) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj1 + TYPE(DOF_), INTENT(IN) :: obj2 + LOGICAL(LGT) :: ans + END FUNCTION obj_isEqual +END INTERFACE OPERATOR(.EQ.) + +!---------------------------------------------------------------------------- +! NE@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE OPERATOR(.NE.) + MODULE PURE FUNCTION obj_isNE(obj1, obj2) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj1 + TYPE(DOF_), INTENT(IN) :: obj2 + LOGICAL(LGT) :: ans + END FUNCTION obj_isNE +END INTERFACE OPERATOR(.NE.) + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get the idof from spacecompo, timecompo, tsapcecompo + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF1(spacecompo, timecompo, tspacecompo) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component + INTEGER(I4B), INTENT(IN) :: tspacecompo + !! total space component + INTEGER(I4B) :: ans + END FUNCTION obj_GetIDOF1 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get idof of a physical variable from space-time components + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF2(obj, ivar, spacecompo, timecompo) & + RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + INTEGER(I4B) :: ans + END FUNCTION obj_GetIDOF2 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get idof of physical variable from space and time components + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF3(obj, ivar, spacecompo, timecompo) & + RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time components of physical variable + INTEGER(I4B) :: ans(SIZE(timecompo)) + !! idof of each time component + END FUNCTION obj_GetIDOF3 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get idof of physical variable from space and time components + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF4(obj, ivar, spacecompo, timecompo) & + RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! several space components of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! a time component of a physical variable + INTEGER(I4B) :: ans(SIZE(spacecompo)) + !! idof of each space component + END FUNCTION obj_GetIDOF4 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get idof of from space and time components +! +!# Introduction +! +!@note +! This is an expert level routine and should be used with care. +!@endnote + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF5(spacecompo, timecompo, tspacecompo) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! several time components + INTEGER(I4B), INTENT(IN) :: tspacecompo + !! total time component + INTEGER(I4B) :: ans(SIZE(timecompo)) + !! idof of each time component + END FUNCTION obj_GetIDOF5 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get idof from space-time components +! +!# Introduction +! +!@note +! This is an expert level routine and should be used with care. +!@endnote + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF6(spacecompo, timecompo, tspacecompo) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! several space components + INTEGER(I4B), INTENT(IN) :: timecompo + !! a time component + INTEGER(I4B), INTENT(IN) :: tspacecompo + !! total space components + INTEGER(I4B) :: ans(SIZE(spacecompo)) + !! idof of each space component + END FUNCTION obj_GetIDOF6 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get idof of physical variable from its local idof +! +!# Introduction +! +! What is local idof and global idof? +! In this context, idof is local idof of a physical variable. +! ans is global idof of a physical variable's local idof. +! +! For example, consider velocity with 2 space-components and 1 time component. +! then Vx has local idof 1, Vy has local idof 2. +! But it may happen that Vx and Vy have different idof when they are stored in +! DOF object. + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF7(obj, ivar, idof) & + RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local idof of a physical variable + INTEGER(I4B) :: ans + !! global idof of a physical variable + END FUNCTION obj_GetIDOF7 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetIDOF@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get all idof of a physical variable + +INTERFACE GetIDOF + MODULE PURE FUNCTION obj_GetIDOF8(obj, ivar) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), ALLOCATABLE :: ans(:) + !! global idofs of all the dofs of a physical variable + END FUNCTION obj_GetIDOF8 +END INTERFACE GetIDOF + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node +! +!# Introduction +! +! - This routine is like [[DOF_Method:GetIndex]]. +! - It returns the location of degree of freedom number `idof` +! at node number `nodenum`. +! +!@note +! `nodenum` should be lesser than the total number of nodes +! defined for dof number `idof`. +!@endnote +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc1(obj, nodenum, idof) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof + INTEGER(I4B) :: ans + END FUNCTION obj_GetNodeLoc1 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node +! +!# Introduction +! +! - This routine is like [[DOF_Method:GetIndex]]. +! - It returns the location of degree of freedom number `idof` +! at node number `nodenum`. +! +!@note +! `nodenum` should be lesser than the total number of nodes +! defined for dof number `idof`. +!@endnote +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc2(obj, nodenum, idof) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + INTEGER(I4B) :: ans(SIZE(nodenum)) + !! location of nodenum + END FUNCTION obj_GetNodeLoc2 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get node location wihtout memory allocation + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_2(obj, nodenum, idof, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written in ans + END SUBROUTINE obj_GetNodeLoc_2 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node +! +!# Introduction +! +! - This routine is like [[DOF_Method:GetIndex]]. +! - It returns the location of degree of freedom number `idof` +! at node number `nodenum`. +! +!@note +! `nodenum` should be lesser than the total number of nodes +! defined for dof number `idof`. +!@endnote +! +!@note +! idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc3(obj, nodenum, idof) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: idof(:) + INTEGER(I4B) :: ans(SIZE(idof)) + END FUNCTION obj_GetNodeLoc3 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get node location wihtout memory allocation + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_3(obj, nodenum, idof, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: idof(:) + !! global degree of freedom number + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written in ans + END SUBROUTINE obj_GetNodeLoc_3 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of idof +! +!# Introduction +! +! This routine returns the location of degree of freedom number `idof` +! +! Note that in this routine we do not pass node number. +! +! ans(1) : istart +! ans(2) : iend +! ans(3) : stride +! +! In this way a given degree of freedom `idof` will be located in +! vec(istart:iend:stride). +! +!@note +! In DOF_ object, idofs are continuously numbered, so if there are two +! or more physical variables, then idof of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc4(obj, idof) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom in obj + INTEGER(I4B) :: ans(3) + !! ans(1) : istart + !! ans(2) : iend + !! ans(3) : stride + END FUNCTION obj_GetNodeLoc4 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node +! +!# Introduction +! +! In this routine we pass the physical variable number and +! the local degree of freedom number `idof` +! +! The `idof` will be converted to global degree of freedom number +! and then the location of the global degree of freedom number +! is returned + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc5(obj, nodenum, ivar, idof) & + RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom number of physical variable + INTEGER(I4B) :: ans + !! location of nodenum + END FUNCTION obj_GetNodeLoc5 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc6(obj, nodenum, ivar, idof) & + RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom number of physical variable + INTEGER(I4B) :: ans(SIZE(nodenum)) + !! returned location of nodenum + END FUNCTION obj_GetNodeLoc6 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_6(obj, nodenum, ivar, idof, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom number of physical variable + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! returned location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of data written in ans + END SUBROUTINE obj_GetNodeLoc_6 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc7(obj, nodenum, ivar, spacecompo, & + timecompo) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + INTEGER(I4B) :: ans + !! location of nodenum + END FUNCTION obj_GetNodeLoc7 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc8(obj, nodenum, ivar, spacecompo, & + timecompo) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + INTEGER(I4B) :: ans(SIZE(nodenum)) + !! location of nodenum + END FUNCTION obj_GetNodeLoc8 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_8(obj, nodenum, ivar, spacecompo, & + timecompo, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE obj_GetNodeLoc_8 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc9(obj, nodenum, ivar, idof) & + RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof(:) + !! local degree of freedom number of physical variable + INTEGER(I4B) :: ans(SIZE(idof)) + !! location of nodenum + END FUNCTION obj_GetNodeLoc9 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_9(obj, nodenum, ivar, idof, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof(:) + !! local degree of freedom number of physical variable + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written in ans + END SUBROUTINE obj_GetNodeLoc_9 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc10(obj, nodenum, ivar, spacecompo, & + timecompo) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time components of physical variable + INTEGER(I4B) :: ans(SIZE(timecompo)) + !! location of nodenum + END FUNCTION obj_GetNodeLoc10 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_10(obj, nodenum, ivar, spacecompo, & + timecompo, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time components of physical variable + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total data written in ans + END SUBROUTINE obj_GetNodeLoc_10 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc11(obj, nodenum, ivar, spacecompo, & + timecompo) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! several space components of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! a time component of a physical variable + INTEGER(I4B) :: ans(SIZE(spacecompo)) + !! returned location of nodenum + END FUNCTION obj_GetNodeLoc11 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_11(obj, nodenum, ivar, spacecompo, & + timecompo, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! several space components of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! a time component of a physical variable + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! returned location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total data written in ans + END SUBROUTINE obj_GetNodeLoc_11 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc12(obj, nodenum, ivar, spacecompo, & + timecompo) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! a space component of a physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! several time components of a physical variable + INTEGER(I4B) :: ans(SIZE(timecompo) * SIZE(nodenum)) + !! returned location of nodenum + END FUNCTION obj_GetNodeLoc12 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_12(obj, nodenum, ivar, spacecompo, & + timecompo, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! a space component of a physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! several time components of a physical variable + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! returned location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total data written in ans + END SUBROUTINE obj_GetNodeLoc_12 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc + MODULE PURE FUNCTION obj_GetNodeLoc13(obj, nodenum, ivar, spacecompo, & + timecompo) RESULT(ans) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! several space components of a physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! a time component of a physical variable + INTEGER(I4B) :: ans(SIZE(spacecompo) * SIZE(nodenum)) + !! returned location of nodenum + END FUNCTION obj_GetNodeLoc13 +END INTERFACE GetNodeLoc + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_13(obj, nodenum, ivar, spacecompo, & + timecompo, ans, tsize) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! several space components of a physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! a time component of a physical variable + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! returned location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total data written in ans + END SUBROUTINE obj_GetNodeLoc_13 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-01 +! summary: This routine returns the location of node + +INTERFACE GetNodeLoc_ + MODULE PURE SUBROUTINE obj_GetNodeLoc_14(obj, nodenum, idof, ans, nrow, & + ncol, storageFMT) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(IN) :: idof(:) + !! physical variable number + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) + !! returned location of nodenum + INTEGER(I4B), INTENT(OUT) :: nrow + !! number of rows written in ans + INTEGER(I4B), INTENT(OUT) :: ncol + !! number of cols written in ans + INTEGER(I4B), INTENT(IN) :: storageFMT + !! if storageFMT is NODES_FMT, then + !! nrow is size(idofs) and ncol is size(nodenum) + !! if storageFMT is DOF_FMT, then + !! nrow is size(nodenum) and ncol is size(idofs) + END SUBROUTINE obj_GetNodeLoc_14 +END INTERFACE GetNodeLoc_ + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! - This function returns indices, representing the location of all degrees +! of freedom define on a given node number. +! - The size of these indices is equal to the total number of DOF in obj +! - In this way, ans(ii) represents the location of ii dof at node number +! nodenum +! - It is user's responsibility to ensure that for every physical variable +! the `nodenumber` is lesser than the total number of +! nodes defined for that physical variable. +! - The returned indiced can be used to extract values from an instance of +! [[RealVector_]] or fortran vector of real numbers. +! +!@note +! The size of returned vector `ans` will be the total number of +! degrees of freedom in the [[DOF_]] object +!@endnote +! +!@note +! This routine calls GetNodeLoc +!@endnote + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex1(obj, nodenum) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), ALLOCATABLE :: ans(:) + !! location of nodenum + END FUNCTION obj_GetIndex1 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Get index without memory allocation + +INTERFACE GetIndex_ + MODULE PURE SUBROUTINE obj_GetIndex_1(obj, nodenum, ans, tsize) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written in ans + END SUBROUTINE obj_GetIndex_1 +END INTERFACE GetIndex_ + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! - This function returns indices, representing the locations of all the +! degrees of freedom of a given physical variable `ivar` at a given +! node number `nodenum` +! - The physical variable is defined by an `ivar` +! - The size of these indices is equal to the total number of DOF +! defined for the `ivar` physical variable. +! - It is user's responsibility to ensure that for the selected physical var +! the `nodenum` is lesser than the total number of +! nodes defined for that physical variable. +! +!@note +! This routine calls GetNodeLoc +!@endnote + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex2(obj, nodenum, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), ALLOCATABLE :: ans(:) + !! location of nodenum + END FUNCTION obj_GetIndex2 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! This method is same as obj_GetIndex2, +! but it does not allocate memory for ans. + +INTERFACE GetIndex_ + MODULE PURE SUBROUTINE obj_GetIndex_2(obj, nodenum, ivar, ans, tsize) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE obj_GetIndex_2 +END INTERFACE GetIndex_ + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! Same as obj_GetIndex2, but physical variable is selected by +! it name. + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex3(obj, nodenum, varname) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + CHARACTER(1), INTENT(IN) :: varname + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION obj_GetIndex3 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! - This function returns indices, representing the location of all the +! degrees of freedom defined at node numbers specified by nodenum. +! - The size of these indices is equal to the total number of DOF in obj +! times the size of nodenum(:) +! +!@note +! The returned indices has same storage pattern as the DOF object +!@endnote + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex4(obj, nodenum) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), ALLOCATABLE :: ans(:) + !! location of nodenum + END FUNCTION obj_GetIndex4 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Returns the indices for node number `nodenum` + +INTERFACE GetIndex_ + MODULE PURE SUBROUTINE obj_GetIndex_4(obj, nodenum, ans, tsize) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total data written in ans + END SUBROUTINE obj_GetIndex_4 +END INTERFACE GetIndex_ + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! - This function returns indices, representing the location of all the +! degrees of freedom of physical variable given by ivar, at nodes given in +! nodenum. +! - The physical variable is defined by an `ivar` +! - The size of these indices is equal to the total number of DOF +! defined for the `ivar` physical variable times the size of nodenum. + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex5(obj, nodenum, ivar) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), ALLOCATABLE :: ans(:) + !! location of nodenum + END FUNCTION obj_GetIndex5 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! This method is same as obj_GetIndex5, but it does not allocate memory +! for ans. + +INTERFACE GetIndex_ + MODULE PURE SUBROUTINE obj_GetIndex_5(obj, nodenum, ivar, ans, tsize) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(INOUT) :: ans(:) + !! location of nodenum + INTEGER(I4B), INTENT(OUT) :: tsize + !! total data written in ans + END SUBROUTINE obj_GetIndex_5 +END INTERFACE GetIndex_ + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the indices for node number `nodenum` +! +!# Introduction +! +! - This function returns a vector of integers (indices) for a +! a given node number and a given physical Variable. +! - The physical variable is defined by an `varname` +! - The size of these indices is equal to the total number of DOF +! defined for the `varname` physical variable. +! - The returned indices represents the degrees of freedom of +! physical variable `varname` defined on each node. +! - It is user's responsibility to ensure that for the selected physical var +! the `nodenumber` is lesser than the total number of +! nodes defined for that physical variable. +! - The returned indices can be used for Getting the dof (all dof) +! defined on the nodenum for the given physical variable. +! - The returned indices can be used to extract values from an instance of +! [[RealVector_]] or fortran vector of real numbers. + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex6(obj, nodenum, varname) RESULT(ans) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + CHARACTER(1), INTENT(IN) :: varname + !! variable name + INTEGER(I4B), ALLOCATABLE :: ans(:) + !! location of nodenum + END FUNCTION obj_GetIndex6 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PROCEDURE obj_GetNodeLoc5 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PROCEDURE obj_GetNodeLoc6 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PROCEDURE obj_GetNodeLoc7 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PROCEDURE obj_GetNodeLoc8 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +INTERFACE GetIndex_ + MODULE PROCEDURE obj_GetNodeLoc_6 +END INTERFACE GetIndex_ + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +INTERFACE GetIndex_ + MODULE PROCEDURE obj_GetNodeLoc_8 +END INTERFACE GetIndex_ + +END MODULE DOF_GetMethods diff --git a/src/modules/DOF/src/DOF_GetValueMethods.F90 b/src/modules/DOF/src/DOF_GetValueMethods.F90 new file mode 100644 index 000000000..c017ca256 --- /dev/null +++ b/src/modules/DOF/src/DOF_GetValueMethods.F90 @@ -0,0 +1,384 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 DOF_GetValueMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: DOF_ +IMPLICIT NONE + +PRIVATE + +PUBLIC :: GetValue +PUBLIC :: GetValue_ +PUBLIC :: Get + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_GetValue1(v, val, obj, idof, storageFMT, & + nodenum) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: v(:) + !! values to return + REAL(DFP), INTENT(IN) :: val(:) + !! values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof(:) + !! degrees of freedom to extract + INTEGER(I4B), INTENT(IN) :: storageFMT + !! storage format of returned vector + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers to extract + END SUBROUTINE obj_GetValue1 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a 2D array +! +!# Introduction +! This subroutine extracts all the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V(:,:)` +! values in `v(:,:)` are stored in xiJ format. +! +! - Force3D will return a vector in 3D. if there are only two components +! then it will set the third component to 0 +! + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_GetValue2(v, val, obj, idof, force3D) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: v(:, :) + REAL(DFP), INTENT(IN) :: val(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: idof(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D + END SUBROUTINE obj_GetValue2 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values of from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue + MODULE PURE SUBROUTINE obj_GetValue3(v, val, obj, idof, storageFMT) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: v(:) + REAL(DFP), INTENT(IN) :: val(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: idof(:) + INTEGER(I4B), INTENT(IN) :: storageFMT + END SUBROUTINE obj_GetValue3 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION obj_get1(val, obj, idof, StorageFMT, nodenum, & + Force3D) RESULT(ans) + REAL(DFP), INTENT(IN) :: val(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: idof(:) + INTEGER(I4B), INTENT(IN) :: StorageFMT + INTEGER(I4B), INTENT(IN) :: nodenum(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_get1 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION obj_get2(val, obj, idof, StorageFMT, & + Force3D) RESULT(ans) + REAL(DFP), INTENT(IN) :: val(:) + TYPE(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: idof(:) + INTEGER(I4B), INTENT(IN) :: StorageFMT + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_get2 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! +! This subroutine is same as GetValue1 +! but it does not allocate any extra memory + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_1(v, tsize, val, obj, idof, storageFMT, & + nodenum) + REAL(DFP), INTENT(INOUT) :: v(:) + !! values to return + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of data written in v + REAL(DFP), INTENT(IN) :: val(:) + !! values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof(:) + !! degrees of freedom to extract + INTEGER(I4B), INTENT(IN) :: storageFMT + !! storage format of returned vector + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers to extract + END SUBROUTINE obj_GetValue_1 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a 2D array +! +!# Introduction +! +! This subroutine is same as GetValue2 but +! it does not allocate any extra memory + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_2(v, val, nrow, ncol, obj, idof, force3D) + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! Data to be returned + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in v + REAL(DFP), INTENT(IN) :: val(:) + !! values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object for val + INTEGER(I4B), INTENT(IN) :: idof(:) + !! degrees of freedom to extract + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D + !! if true then return 3D vector + END SUBROUTINE obj_GetValue_2 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! +! This subroutine is same as GetValue3 but +! it does not allocate any extra memory + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_3(v, tsize, val, obj, idof, storageFMT) + REAL(DFP), INTENT(INOUT) :: v(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of data written in v + REAL(DFP), INTENT(IN) :: val(:) + !! values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof(:) + !! degrees of freedom to extract + INTEGER(I4B), INTENT(IN) :: storageFMT + !! stroage format of returned vector + END SUBROUTINE obj_GetValue_3 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Returns the values +! +!# Introduction +! +! This routine performs following operations without extra memory allocation +! index = obj_GetIndex1(obj, nodenum) +! v = val(index) + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_4(v, tsize, val, obj, nodenum) + REAL(DFP), INTENT(INOUT) :: v(:) + !! Values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! Size of data written in v + REAL(DFP), INTENT(IN) :: val(:) + !! Values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! Degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! Node number to extract + END SUBROUTINE obj_GetValue_4 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Returns the values +! +!# Introduction +! +! This routine performs following operations without extra memory allocation +! index = obj_GetIndex2(obj, nodenum, ivar) +! v = val(index) + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_5(v, tsize, val, obj, nodenum, ivar) + REAL(DFP), INTENT(INOUT) :: v(:) + !! Values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! Size of data written in v + REAL(DFP), INTENT(IN) :: val(:) + !! Values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! Degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! Node number to extract + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable numbers + END SUBROUTINE obj_GetValue_5 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-26 +! summary: Returns the values +! +!# Introduction +! +! This routine performs following operations without extra memory allocation +! index = obj_GetIndex4(obj, nodenum) +! v = val(index) + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_6(v, tsize, val, obj, nodenum) + REAL(DFP), INTENT(INOUT) :: v(:) + !! Values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! Size of data written in v + REAL(DFP), INTENT(IN) :: val(:) + !! Values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! Degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! Node number to extract + END SUBROUTINE obj_GetValue_6 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_7(v, tsize, val, obj, idof, nodenum) + REAL(DFP), INTENT(INOUT) :: v(:) + !! values to return + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of data written in v + REAL(DFP), INTENT(IN) :: val(:) + !! values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof + !! global degrees of freedom to extract + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers to extract + END SUBROUTINE obj_GetValue_7 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector + +INTERFACE GetValue_ + MODULE PURE SUBROUTINE obj_GetValue_8(v, tsize, val, obj, idof, isidof) + REAL(DFP), INTENT(INOUT) :: v(:) + !! values to return + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of data written in v + REAL(DFP), INTENT(IN) :: val(:) + !! values to extract from + TYPE(DOF_), INTENT(IN) :: obj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof + !! global degrees of freedom to extract + LOGICAL(LGT), INTENT(IN) :: isidof + !! This variable is not used, it here to create unique interface + !! otherwise it conflicts with obj_GetValue_4 + END SUBROUTINE obj_GetValue_8 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE DOF_GetValueMethods diff --git a/src/modules/DOF/src/DOF_IOMethods.F90 b/src/modules/DOF/src/DOF_IOMethods.F90 new file mode 100644 index 000000000..fee5e0a80 --- /dev/null +++ b/src/modules/DOF/src/DOF_IOMethods.F90 @@ -0,0 +1,111 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 DOF_IOMethods +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 June 2021 +! summary: Display content of [[dof_]] + +INTERFACE + MODULE SUBROUTINE dof_Display1(obj, msg, UnitNo) + CLASS(DOF_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: UnitNo + END SUBROUTINE dof_Display1 +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE dof_Display1 +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 June 2021 +! summary: Display content of fortran vec with [[DOF_]] object info +! +! +!## Usage +! +!```fortran +! ! [[DOF_]] +! PROGRAM main +! USE easifemBase +! IMPLICIT NONE +! TYPE( DOF_ ) :: obj +! REAL( DFP ), ALLOCATABLE :: val( : ) +! ! main +! ! #DOF/Initiate +! CALL Initiate( obj, tNodes=[10], names=["U"], spacecompo=[3], & +! & timecompo=[1], storageFMT = FMT_DOF ) +! ! #DOF/Initiate +! CALL Initiate( Val=val, obj=obj ) +! val(1:10) = 1; val(11:20)=2; val(21:)=3 +! CALL Display( Val, obj, "CALL Initiate( Val=val, obj=obj ) : " ) +! ! #DOF/Deallocate +! CALL Deallocate( obj ) +! END PROGRAM main +!``` + +INTERFACE + MODULE SUBROUTINE dof_Display2(Vec, obj, msg, unitno) + REAL(DFP), INTENT(IN) :: Vec(:) + CLASS(DOF_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + END SUBROUTINE dof_Display2 +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE dof_Display2 +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 June 2021 +! summary: Display content of fortran vec with [[DOF_]] object info + +INTERFACE + MODULE SUBROUTINE dof_Display3(Vec, obj, msg, unitno) + CLASS(RealVector_), INTENT(IN) :: Vec + CLASS(DOF_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + END SUBROUTINE dof_Display3 +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE dof_Display3 +END INTERFACE Display + +END MODULE DOF_IOMethods diff --git a/src/modules/DOF/src/DOF_Method.F90 b/src/modules/DOF/src/DOF_Method.F90 new file mode 100644 index 000000000..8f22fab1c --- /dev/null +++ b/src/modules/DOF/src/DOF_Method.F90 @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 23 Feb 2021 +! summary: This module contains methods of [[DOF_]] object +! +!{!pages/docs-api/DOF/DOF_.md!} + +MODULE DOF_Method +USE DOF_ConstructorMethods +USE DOF_IOMethods +USE DOF_GetMethods +USE DOF_GetValueMethods +USE DOF_SetMethods +USE DOF_AddMethods +END MODULE DOF_Method diff --git a/src/modules/DOF/src/DOF_SetMethods.F90 b/src/modules/DOF/src/DOF_SetMethods.F90 new file mode 100644 index 000000000..a5412556f --- /dev/null +++ b/src/modules/DOF/src/DOF_SetMethods.F90 @@ -0,0 +1,464 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 DOF_SetMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Set values in a vector of real numbers +! +!# Introduction +! +! - This subroutine is designed to Set the values in a vector of real number +! - This subroutine effectivily performes `vec( nptrs ) = value` +! - If `SIZE(value)==1` then all values are Set to `value(1)` +! - If `SIZE(value) .EQ. SIZE(nptrs)` then, each dof is Set to value +! - If `SIZE(value)=tDOF*Size(nptrs)` then each dof is Set to appropriate +! value from value + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set1(vec, obj, nodenum, VALUE, conversion) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set + INTEGER(I4B), INTENT(IN) :: conversion(1) + !! DOFToNodes + !! NodesTODOF + !! None + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of all dof defined inside `obj`. + !! The storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`. + END SUBROUTINE obj_Set1 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Set values in a vector of real numbers + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set2(vec, obj, nodenum, VALUE) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + END SUBROUTINE obj_Set2 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers +! +!# Introduction +! +! - This subroutine is designed to Set the values in a array of real number. +! - This subroutine handles only those entries which belongs to the +! dofno. +! - This subroutine effectivily performes `vec( nptrs ) = value` +! - If the size of value is not equal to 1, then the size of nptrs should be +! same as the size of value +! +!@note +! In [[DOF_]], dofno are continuously numbered, so if there are two +! or more physical variables, then dofno of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set3(vec, obj, nodenum, VALUE, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom in obj + END SUBROUTINE obj_Set3 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set4(vec, obj, nodenum, VALUE, ivar, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Set4 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set5(vec, obj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + END SUBROUTINE obj_Set5 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set6(vec, obj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time components of physical variables + END SUBROUTINE obj_Set6 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set7(vec, obj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + REAL(DFP), INTENT(IN) :: VALUE(:) + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! space components of physical variables + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + END SUBROUTINE obj_Set7 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Set values in a vector of real numbers + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set8(vec, obj, nodenum, VALUE) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node to set + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + END SUBROUTINE obj_Set8 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers +! +!# Introduction +! +! - This subroutine is designed to Set the values in a array of real number. +! - This subroutine handles only those entries which belongs to the +! dofno. +! - This subroutine effectivily performes `vec( nptrs ) = value` +! - If the size of value is not equal to 1, then the size of nptrs should be +! same as the size of value +! +!@note +! In [[DOF_]], dofno are continuously numbered, so if there are two +! or more physical variables, then dofno of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set9(vec, obj, nodenum, VALUE, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! Object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + REAL(DFP), INTENT(IN) :: VALUE + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom in obj + END SUBROUTINE obj_Set9 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers +! +!# Introduction +! +! - This subroutine is designed to Set the values in a array of real number. +! - This subroutine handles only those entries which belongs to the +! dofno. +! - This subroutine effectivily performes `vec( nptrs ) = value` +! - If the size of value is not equal to 1, then the size of nptrs should be +! same as the size of value +! +!@note +! In [[DOF_]], dofno are continuously numbered, so if there are two +! or more physical variables, then dofno of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set10(vec, obj, nodenum, VALUE, ivar, idof) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + REAL(DFP), INTENT(IN) :: VALUE + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom in physical variable + END SUBROUTINE obj_Set10 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers +! +!# Introduction +! +! - This subroutine is designed to Set the values in a array of real number. +! - This subroutine handles only those entries which belongs to the +! dofno. +! - This subroutine effectivily performes `vec( nptrs ) = value` +! - If the size of value is not equal to 1, then the size of nptrs should be +! same as the size of value +! +!@note +! In [[DOF_]], dofno are continuously numbered, so if there are two +! or more physical variables, then dofno of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set11(vec, obj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + REAL(DFP), INTENT(IN) :: VALUE + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + END SUBROUTINE obj_Set11 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers +! +!# Introduction +! +! - This subroutine is designed to Set the values in a array of real number. +! - This subroutine handles only those entries which belongs to the +! dofno. +! - This subroutine effectivily performes `vec( nptrs ) = value` +! - If the size of value is not equal to 1, then the size of nptrs should be +! same as the size of value +! +!@note +! In [[DOF_]], dofno are continuously numbered, so if there are two +! or more physical variables, then dofno of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set12(vec, obj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + REAL(DFP), INTENT(IN) :: VALUE + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time components of physical variables + END SUBROUTINE obj_Set12 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: Set values in a vector of real numbers +! +!# Introduction +! +! - This subroutine is designed to Set the values in a array of real number. +! - This subroutine handles only those entries which belongs to the +! dofno. +! - This subroutine effectivily performes `vec( nptrs ) = value` +! - If the size of value is not equal to 1, then the size of nptrs should be +! same as the size of value +! +!@note +! In [[DOF_]], dofno are continuously numbered, so if there are two +! or more physical variables, then dofno of the second or later physical +! variables will not start from 1. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set13(vec, obj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + REAL(DFP), INTENT(INOUT) :: vec(:) + CLASS(DOF_), INTENT(IN) :: obj + !! object `obj` contains the storage pattern of degrees of freedom + !! inside `vec`. + !! This storage pattern can be `FMT_Nodes` or `FMT_DOF` + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + REAL(DFP), INTENT(IN) :: VALUE + !! `value` denotes the nodal values of dof `idof`. + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! space components of physical variables + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component of physical variable + END SUBROUTINE obj_Set13 +END INTERFACE Set + +END MODULE DOF_SetMethods diff --git a/src/modules/DiffusionMatrix/CMakeLists.txt b/src/modules/DiffusionMatrix/CMakeLists.txt new file mode 100644 index 000000000..b13d43c1c --- /dev/null +++ b/src/modules/DiffusionMatrix/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}/DiffusionMatrix_Method.F90 +) diff --git a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 new file mode 100644 index 000000000..dfa236fbd --- /dev/null +++ b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 @@ -0,0 +1,577 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE DiffusionMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! If opt is not present. +! +! $$ +! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}\frac{\partial N^{J}} +! {\partial x_{i}}d\Omega +! $$ +! +! If opt is present. +! +! $$ +! \left[M\right]_{IJ}^{ij}=\delta_{ij}\int\frac{\partial N^{I}} +! {\partial x_{k}}\frac{\partial N^{J}}{\partial x_{k}}d\Omega +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_1(test, trial, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_1 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_1 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! M(I,J)=\int\rho\frac{\partial N^{I}}{\partial x_{i}}\frac{\partial N^{J}} +! {\partial x_{i}}d\Omega +! $$ +! + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_2(test, trial, k, krank, opt) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! scalar + TYPE(FEVariableScalar_), INTENT(IN) :: krank + !! scalar fe variable + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_2 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_2 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}v_{i}v_{j} +! \frac{\partial N^{J}}{\partial x_{j}}d\Omega +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_3(test, trial, k, krank, opt) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! vector + TYPE(FEVariableVector_), INTENT(IN) :: krank + !! vector + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_3 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_3 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}k_{ij} +! \frac{\partial N^{J}}{\partial x_{j}}d\Omega +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_4(test, trial, k, krank, opt) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! matrix + TYPE(FEVariableMatrix_), INTENT(IN) :: krank + !! matrix + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_4 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_4 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! M(I,J)=\int\frac{\partial N^{I}}{\partial x_{i}}u_{i}v_{j} +! \frac{\partial N^{J}}{\partial x_{j}}d\Omega +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_5(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Scalar + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + !! Scalar + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + !! Scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_5 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_5 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! M(I,J)=\int\rho\frac{\partial N^{I}}{\partial x_{i}}k_{ij} +! \frac{\partial N^{J}}{\partial x_{j}}d\Omega +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_6(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + !! Scalar + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! Vector + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_6 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_6 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! M(I,J)=\int\rho_{1}\frac{\partial N^{I}}{\partial x_{i}}k_{ij} +! \frac{\partial N^{J}}{\partial x_{j}}d\Omega +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_7(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Matrix + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + !! Scalar + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + !! Matrix + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_7 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_7 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_8(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Vector + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Scalar + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + !! Vector + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + !! Scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_8 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_8 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_9(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Vector + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + !! Vector + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! Vector + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_9 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_9 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_10(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Vector + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Matrix + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + !! Vector + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + !! Matrix + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_10 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_10 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_11(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Matrix + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Scalar + TYPE(FEVariableMatrix_), INTENT(IN) :: c1rank + !! Matrix + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + !! Scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_11 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_11 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_12(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Matrix + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector + TYPE(FEVariableMatrix_), INTENT(IN) :: c1rank + !! Matrix + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! Vector + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_12 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_12 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_13(test, trial, c1, c2, c1rank, & + & c2rank, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Matrix + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Matrix + TYPE(FEVariableMatrix_), INTENT(IN) :: c1rank + !! Matrix + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + !! Matrix + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_13 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_13 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 May 2022 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! If opt is [1] then: +! +! $$ +! \left[M\right]_{IJ}^{ij}=\int\frac{\partial N^{I}}{\partial x_{i}} +! \frac{\partial N^{J}}{\partial x_{j}}d\Omega +! $$ +! +! If opt is [2] then: +! +! $$ +! \left[M\right]_{IJ}^{ij}=\int\frac{\partial N^{I}}{\partial x_{j}} +! \frac{\partial N^{J}}{\partial x_{i}}d\Omega +! $$ + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_14(test, trial, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_14 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_14 +END INTERFACE DiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix@DiffusionMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine returns the diffusion matrix in space domain +! +!# Introduction +! +! $$ +! M(I,J)=\int\rho\frac{\partial N^{I}}{\partial x_{i}}\frac{\partial N^{J}} +! {\partial x_{i}}d\Omega +! $$ +! + +INTERFACE + MODULE PURE FUNCTION DiffusionMatrix_15(test, trial, k, krank, opt) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! scalar + TYPE(FEVariableScalar_), INTENT(IN) :: krank + !! scalar fe variable + INTEGER(I4B), INTENT(IN) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION DiffusionMatrix_15 +END INTERFACE + +INTERFACE DiffusionMatrix + MODULE PROCEDURE DiffusionMatrix_15 +END INTERFACE DiffusionMatrix + +END MODULE DiffusionMatrix_Method diff --git a/src/modules/Display/CMakeLists.txt b/src/modules/Display/CMakeLists.txt new file mode 100644 index 000000000..31c9f7d76 --- /dev/null +++ b/src/modules/Display/CMakeLists.txt @@ -0,0 +1,26 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/disp/disp_i1mod.F90 + ${src_path}/disp/disp_i2mod.F90 + ${src_path}/disp/disp_i4mod.F90 + ${src_path}/disp/disp_i8mod.F90 + ${src_path}/disp/disp_l1mod.F90 + ${src_path}/disp/disp_r4mod.F90 + ${src_path}/disp/disp_r8mod.F90 + ${src_path}/disp/disp_r16mod.F90 + ${src_path}/disp/disp_charmod.F90 + ${src_path}/disp/dispmodule_util.F90 + ${src_path}/disp/dispmodule.F90 + ${src_path}/disp/putstrmodule.F90 + ${src_path}/Display_Method.F90 +) \ No newline at end of file diff --git a/src/modules/Display/src/Display_Mat2.inc b/src/modules/Display/src/Display_Mat2.inc new file mode 100644 index 000000000..a26013cde --- /dev/null +++ b/src/modules/Display/src/Display_Mat2.inc @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) :: I + +LOGICAL(LGT) :: full_ +INTEGER(I4B) :: ii, ff, mm, nn +CHARACTER(3) :: orient_ + +CALL setDefaultSettings +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 + +! 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" +! END IF +orient_ = "row" + +mm = SIZE(val, 1) +nn = SIZE(val, 2) +IF (full_ .OR. mm .LE. (minRow + minRow) .OR. (nn .LE. (minCol + minCol))) 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, advance=advance) +#else + CALL DISP(title=msg, x=val, unit=I, advance=advance) +#endif +ELSE + CALL Disp(title=msg, unit=I, advance="YES") + CALL DISP(title="", x=val(1:minRow, 1:minCol), unit=I, advance="NO") + CALL Display("...", unitNo=I, advance=.FALSE.) + CALL DISP(title="", x=val(1:minRow, nn-minCol+1:nn), unit=I, advance="YES") + CALL Display("."//CHAR_LF//"."//CHAR_LF//".", unitNo=I, advance=.TRUE.) +CALL DISP(title="", x=val(mm - minRow + 1:mm, 1:minCol), unit=I, advance="NO") + CALL Display("...", unitNo=I, advance=.FALSE.) + CALL DISP(title="", x=val(mm-minRow+1:mm, nn-minCol+1:nn), unit=I, advance=advance) +END IF diff --git a/src/modules/Display/src/Display_Mat3.inc b/src/modules/Display/src/Display_Mat3.inc new file mode 100644 index 000000000..ed9459fb4 --- /dev/null +++ b/src/modules/Display/src/Display_Mat3.inc @@ -0,0 +1,24 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +! Define internal variables +INTEGER(I4B) :: J +DO J = 1, SIZE(Val, 3) + CALL Display(val=Val(:, :, J), & + & msg=TRIM(msg)//"( :, :, "//TRIM(Int2Str(J))//" ) = ", & + & unitNo=unitNo, full=full, advance=advance) +END DO diff --git a/src/modules/Display/src/Display_Mat4.inc b/src/modules/Display/src/Display_Mat4.inc new file mode 100644 index 000000000..4ac83233e --- /dev/null +++ b/src/modules/Display/src/Display_Mat4.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 internal variables +INTEGER(I4B) :: J, K +DO K = 1, SIZE(Val, 4) + DO J = 1, SIZE(Val, 3) + CALL Display(Val=Val(:, :, J, K), & + & msg=TRIM(msg) & + & //"( :, :, " & + & //TRIM(Int2Str(J)) & + & //", " & + & //TRIM(Int2Str(K)) & + & //" ) = " & + & , unitNo=unitNo, full=full, advance=advance) + END DO +END DO diff --git a/src/modules/Display/src/Display_Method.F90 b/src/modules/Display/src/Display_Method.F90 new file mode 100755 index 000000000..2a7fd7d35 --- /dev/null +++ b/src/modules/Display/src/Display_Method.F90 @@ -0,0 +1,1712 @@ +! ploDataElem is a post-processing software for T+H (TOUGH HYDRATE) program. +! It reads plot_data_elem file generated by T+H simulations and converts them +! vtu format. Which can then be visualized by usign PARAVIEW and other +! softwares. +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: Dr. Vikas Sharma +! +! [[Display_Method]] module consists small routines related +! to displaying the fortran variables on the screen + +MODULE Display_Method +USE GlobalData +USE DISPMODULE +USE FACE +IMPLICIT NONE +PRIVATE +INTEGER(I4B), PARAMETER :: minRow = 4, minCol = 4 +PUBLIC :: Display, BlankLines, DashLine +PUBLIC :: DotLine, EqualLine +PUBLIC :: TIMESTAMP +PUBLIC :: setDisplayProfile +PUBLIC :: ToString, DISP !! from DISPMODULE + +CHARACTER(*), PARAMETER :: equal = "==============================" +CHARACTER(*), PARAMETER :: dot = ".............................." +CHARACTER(*), PARAMETER :: dash = "------------------------------" +CHARACTER(*), PARAMETER :: COLOR_FG = "CYAN" +CHARACTER(*), PARAMETER :: COLOR_BG = "BLACK" +CHARACTER(*), PARAMETER :: COLOR_STYLE = "BOLD_ON" + +TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: & + & DisplayProfileTerminal = DISP_SETTINGS(& + & advance="YES", matsep=",", orient="COL", style="UNDERLINE", & + & trim="FALSE", ZEROAS=".") + +TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: & + & DisplayProfilePrint = DISP_SETTINGS(& + & advance="YES", matsep=",", orient="COL", style="UNDERLINE", & + & trim="FALSE", ZEROAS="") + +TYPE(DISP_SETTINGS), PARAMETER :: DisplayProfileOriginal = DISP_SETTINGS() +LOGICAL(LGT) :: defaultSettingSet = .FALSE. + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +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 +END INTERFACE + +CONTAINS + +!---------------------------------------------------------------------------- +! setDefaultSetting +!---------------------------------------------------------------------------- + +SUBROUTINE setDefaultSettings + IF (defaultSettingSet) THEN + RETURN + ELSE + CALL DISP_SET(DisplayProfileTerminal) + defaultSettingSet = .TRUE. + END IF +END SUBROUTINE setDefaultSettings + +!---------------------------------------------------------------------------- +! setDisplayProfile +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This routine sets the display profile + +SUBROUTINE setDisplayProfile(DispProfile, advance, digmax, & + & matsep, orient, sep, style, unit, zeroas) + TYPE(DISP_SETTINGS), INTENT(IN) :: DispProfile + !! An instance of Display settings + !! It can be DisplayProfileTerminal, DisplayProfilePrint + !! + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance + !! "NO", stay on the same line + !! "YES", advance to the next line, default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: digmax + !! Number of significant digits to show for X-element of largest + !! absolute magnitude + CHARACTER(*), OPTIONAL, INTENT(IN) :: matsep + !! + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + !! "ROW" display vector as row + !! "COL" display vector as column, default + CHARACTER(*), OPTIONAL, INTENT(IN) :: sep + !! String used to separate matrix column + CHARACTER(*), OPTIONAL, INTENT(IN) :: style + !! "LEFT", default + !! "ABOVE" + !! "PAD" + !! "UNDERLINE" + !! "NUMBER" + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unit + !! External file unit to send output to (stdout is default) + CHARACTER(*), OPTIONAL, INTENT(IN) :: zeroas + !! String to display instead of zeros + !> internal variables + CALL DISP_SET(DispProfile) + CALL DISP_SET(advance=advance, digmax=digmax, matsep=matsep, & + & orient=orient, sep=sep, style=style, unit=unit, zeroas=zeroas) +END SUBROUTINE setDisplayProfile + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine Displays the string +! +!# Introduction +! This routine displays a string +! +!## usage +!```fortran +! CALL Display( msg="hello world", unitno=stdout ) +!``` + +SUBROUTINE Display_Str(msg, unitno, advance) + ! Dummt arguments + CHARACTER(*), INTENT(IN) :: msg + !! input message + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + !! unit no + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: advance + ! Internal variables + INTEGER(I4B) :: i + CHARACTER(:), ALLOCATABLE :: advance0 + LOGICAL(LGT) :: bool1 + + CALL setDefaultSettings + + i = stdout; IF (PRESENT(unitno)) i = unitno + bool1 = .TRUE.; IF (PRESENT(advance)) bool1 = advance + + IF (bool1) THEN + advance0 = "YES" + ELSE + advance0 = "NO" + END IF + +#ifdef COLOR_DISP + CALL DISP(title="", & + & x=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, & + & style=COLOR_STYLE)), & + & FMT='a', unit=i, style="left", & + & advance=advance0) +#else + CALL DISP(title="", x=msg, FMT='a', unit=i, style="left", & + & advance=advance0) +#endif +END SUBROUTINE Display_Str + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This routine prints a string; msg=val +! +!# Introduction +! +! This routine prints a string; msg=val +! +!## Usage +!```fortran +! CALL Display( val=" world!", msg="hello", stdout) +!``` + +SUBROUTINE Display_Str2(val, msg, unitno, advance) + CHARACTER(*), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: advance + CALL Display(msg=TRIM(msg)//TRIM(val), unitNo=unitNo, advance=advance) +END SUBROUTINE Display_Str2 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar real number +! +!# Introduction +! +! This subroutine display a scalar real number +! +!## Usage +! +!```fortran +! call display( val=1.0_DFP, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Real64(val, msg, unitNo, advance) + ! Define intent of dummy variables + REAL(REAL64), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Real64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar real number +! +!# Introduction +! +! This subroutine display a scalar real number +! +!## Usage +! +!```fortran +! call display( val=1.0_DFP, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Real32(val, msg, unitNo, advance) + ! Define intent of dummy variables + REAL(REAL32), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Real32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine displays a scalar complex number +! +!## Usage +! +!```fortran +! call display( val=CMPLX(1.0_DFP, 1.0_DFP), msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Cmplx64(val, msg, unitNo, advance) + ! Define intent of dummy variables + COMPLEX(DPC), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Cmplx64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine displays a scalar complex number +! +!## Usage +! +!```fortran +! call display( val=CMPLX(1.0_DFP, 1.0_DFP), msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Cmplx32(val, msg, unitNo, advance) + ! Define intent of dummy variables + COMPLEX(SPC), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Cmplx32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar integer number +! +!# Introduction +! +! This subroutine display a scalar integer number +! +!## Usage +! +!```fortran +! call display( val=1.0_I4B, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Int64(val, msg, unitNo, advance) + ! Define intent of dummy variables + INTEGER(INT64), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Int64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar integer number +! +!# Introduction +! +! This subroutine display a scalar integer number +! +!## Usage +! +!```fortran +! call display( val=1.0_I4B, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Int32(val, msg, unitNo, advance) + ! Define intent of dummy variables + INTEGER(INT32), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Int32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar integer number +! +!# Introduction +! +! This subroutine display a scalar integer number +! +!## Usage +! +!```fortran +! call display( val=1.0_I4B, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Int16(val, msg, unitNo, advance) + ! Define intent of dummy variables + INTEGER(INT16), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Int16 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar integer number +! +!# Introduction +! +! This subroutine display a scalar integer number +! +!## Usage +! +!```fortran +! call display( val=1.0_I4B, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Int8(val, msg, unitNo, advance) + ! Define intent of dummy variables + INTEGER(INT8), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Scalar.inc" +END SUBROUTINE Display_Int8 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar logical variable +! +!# Introduction +! +! This subroutine display a scalar logical variable +! +!## Usage +! +!```fortran +! call display( val=.TRUE., msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Logical(val, msg, unitNo, advance) + ! Define intent of dummy variables + LOGICAL(LGT), INTENT(IN) :: val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance + + ! Internal variables + CHARACTER(:), ALLOCATABLE :: advance0 + LOGICAL(LGT) :: bool1 + + advance0 = "YES"; IF (PRESENT(advance)) advance0 = TRIM(advance) + + SELECT CASE (TRIM(advance0)) + CASE ("YES") + bool1 = .TRUE. + CASE ("NO") + bool1 = .FALSE. + CASE default + bool1 = .TRUE. + END SELECT + + IF (val) THEN + CALL Display_Str(msg=TRIM(msg)//" TRUE", & + & unitNo=unitNo, advance=bool1) + ELSE + CALL Display_Str(msg=TRIM(msg)//" FALSE", & + & unitNo=unitNo, advance=bool1) + END IF +END SUBROUTINE Display_Logical + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a scalar logical variable +! +!# Introduction +! +! This subroutine display a scalar logical variable +! +!## Usage +! +!```fortran +! call display( val=.TRUE., msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Vector_Logical(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + LOGICAL(LGT), INTENT(IN) :: val(:) + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Logical + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a vector of real numbers +! +!# Introduction +! This subroutine display a vector of real numbers +! +! +!### Usage +! +!```fortran +! real( dfp ) :: vec(10) +! call RANDOM_NUMBER(vec) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Real64(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + REAL(REAL64), INTENT(IN) :: val(:) + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance + !! vector of real numbers +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Real64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a vector of real numbers +! +!# Introduction +! This subroutine display a vector of real numbers +! +! +!### Usage +! +!```fortran +! real( dfp ) :: vec(10) +! call RANDOM_NUMBER(vec) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Real32(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + REAL(REAL32), INTENT(IN) :: val(:) + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Real32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine displays a vector of complex numbers +! +! +!### Usage +! +!```fortran +! REAL(DFP) :: x(10), y(10) +! COMPLEX( DFPC ), INTENT(IN) :: vec(10) +! call random_number(x) +! call random_number(y) +! vec = cmplx(x, y, kind=DFP) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Cmplx64(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + COMPLEX(DPC), INTENT(IN) :: val(:) + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance + !! vector of real numbers +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Cmplx64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine displays a vector of complex numbers +! +! +!### Usage +! +!```fortran +! REAL(DFP) :: x(10), y(10) +! COMPLEX( DFPC ), INTENT(IN) :: vec(10) +! call random_number(x) +! call random_number(y) +! vec = cmplx(x, y, kind=DFP) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Cmplx32(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + COMPLEX(SPC), INTENT(IN) :: val(:) + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Cmplx32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a vector of integer numbers +! +!# Introduction +! +! This subroutine display a vector of integer numbers +! +!### Usage +! +!```fortran +! real( dfp ) :: vec(10) +! call RANDOM_NUMBER(vec) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Int32(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + INTEGER(INT32), INTENT(IN) :: val(:) + !! vector of real numbers + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Int32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a vector of integer numbers +! +!# Introduction +! +! This subroutine display a vector of integer numbers +! +!### Usage +! +!```fortran +! real( dfp ) :: vec(10) +! call RANDOM_NUMBER(vec) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Int64(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + INTEGER(INT64), INTENT(IN) :: val(:) + !! vector of real numbers + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Int64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a vector of integer numbers +! +!# Introduction +! +! This subroutine display a vector of integer numbers +! +!### Usage +! +!```fortran +! real( dfp ) :: vec(10) +! call RANDOM_NUMBER(vec) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Int16(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + INTEGER(INT16), INTENT(IN) :: val(:) + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Int16 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a vector of integer numbers +! +!# Introduction +! +! This subroutine display a vector of integer numbers +! +!### Usage +! +!```fortran +! real( dfp ) :: vec(10) +! call RANDOM_NUMBER(vec) +! call display( val=vec, msg="var=", unitno=stdout) +! call display( val=vec, msg="var=", unitno=stdout, orient="col") +!``` + +SUBROUTINE Display_Vector_Int8(val, msg, unitNo, orient, full, advance) + ! Define intent of dummy variables + INTEGER(INT8), INTENT(IN) :: val(:) + CHARACTER(*), INTENT(IN) :: msg + ! message + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + ! Unit number + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + ! orient=row => rowwise printing + ! orient=col => columnwise printing + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + ! logical variable to print the whole vector + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Vector.inc" +END SUBROUTINE Display_Vector_Int8 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a matrix of real numbers +! +!# Introduction +! +! ## Usage +! ```fortran +! real( dfp ) :: mat(10, 10) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Real64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + REAL(REAL64), DIMENSION(:, :), INTENT(IN) :: Val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Real64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine display a matrix of real numbers +! +!# Introduction +! +! ## Usage +! ```fortran +! real( dfp ) :: mat(10, 10) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Real32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + REAL(REAL32), DIMENSION(:, :), INTENT(IN) :: Val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Real32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine display a matrix of complex numbers +! +! ## Usage +! ```fortran +! REAL(DFP) :: x(10, 10), y(10, 10) +! COMPLEX(DFPC) :: mat(10, 10) +! call RANDOM_NUMBER(x) +! call RANDOM_NUMBER(y) +! mat = CMPLX(x, y, kind=DFP) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Cmplx64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + COMPLEX(DPC), INTENT(IN) :: Val(:, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Cmplx64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine display a matrix of complex numbers +! +! ## Usage +! ```fortran +! REAL(DFP) :: x(10, 10), y(10, 10) +! COMPLEX(DFPC) :: mat(10, 10) +! call RANDOM_NUMBER(x) +! call RANDOM_NUMBER(y) +! mat = CMPLX(x, y, kind=DFP) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Cmplx32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + COMPLEX(SPC), INTENT(IN) :: Val(:, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Cmplx32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine display a matrix of real numbers +! +! ## Usage +! ```fortran +! integer( i4b ) :: mat(10, 10) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Int64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT64), DIMENSION(:, :), INTENT(IN) :: Val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Int64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine display a matrix of real numbers +! +! ## Usage +! ```fortran +! integer( i4b ) :: mat(10, 10) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Int32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT32), DIMENSION(:, :), INTENT(IN) :: Val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Int32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine display a matrix of real numbers +! +! ## Usage +! ```fortran +! integer( i4b ) :: mat(10, 10) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Int16(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT16), DIMENSION(:, :), INTENT(IN) :: Val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Int16 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine display a matrix of real numbers +! +! ## Usage +! ```fortran +! integer( i4b ) :: mat(10, 10) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Int8(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT8), DIMENSION(:, :), INTENT(IN) :: Val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Int8 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine display a matrix of real numbers +! +! ## Usage +! ```fortran +! integer( i4b ) :: mat(10, 10) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat2_Bool(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + LOGICAL(LGT), DIMENSION(:, :), INTENT(IN) :: Val + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), INTENT(IN), OPTIONAL :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat2.inc" +END SUBROUTINE Display_Mat2_Bool + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! This subroutine displays the contents of a rank 3 array. +! +! ## Usage +!```fortran +! real( dfp ) :: mat(5, 5, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat3_Real64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + REAL(REAL64), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Real64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! This subroutine displays the contents of a rank 3 array. +! +! ## Usage +!```fortran +! real( dfp ) :: mat(5, 5, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat3_Real32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + REAL(REAL32), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Real32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! #Usage +! ```fortran +! REAL(DFP) :: x(5, 5, 2), y(5, 5, 2) +! COMPLEX(DFPC) :: mat(5, 5, 2) +! call RANDOM_NUMBER(x) +! call RANDOM_NUMBER(y) +! mat = CMPLX(x, y, kind=DFP) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat3_Cmplx64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + COMPLEX(DPC), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Cmplx64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! #Usage +! ```fortran +! REAL(DFP) :: x(5, 5, 2), y(5, 5, 2) +! COMPLEX(DFPC) :: mat(5, 5, 2) +! call RANDOM_NUMBER(x) +! call RANDOM_NUMBER(y) +! mat = CMPLX(x, y, kind=DFP) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat3_Cmplx32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + COMPLEX(SPC), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Cmplx32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! This subroutine displays the contents of a rank 3 array. +! +! ## Usage +!```fortran +! real( dfp ) :: mat(5, 5, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat3_Int64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT64), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Int64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! This subroutine displays the contents of a rank 3 array. +! +! ## Usage +!```fortran +! real( dfp ) :: mat(5, 5, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat3_Int32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT32), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Int32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! This subroutine displays the contents of a rank 3 array. +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(5, 5, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat3_Int16(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT16), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Int16 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the contents of a rank 3 array. +! +!# Introduction +! +! This subroutine displays the contents of a rank 3 array. +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(5, 5, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat3_Int8(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT8), INTENT(IN) :: Val(:, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat3.inc" +END SUBROUTINE Display_Mat3_Int8 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +! This subroutine displays the content of rank4 matrix +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(3, 3, 2, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat4_Real64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + REAL(REAL64), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Real64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +! This subroutine displays the content of rank4 matrix +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(3, 3, 2, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat4_Real32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + REAL(REAL32), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Real32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +!### Usage +! +! ```fortran +! REAL(DFP) :: x(3, 3, 3, 2), y(3, 3, 3, 2) +! COMPLEX(DFPC) :: mat(3, 3, 3, 2) +! call RANDOM_NUMBER(x) +! call RANDOM_NUMBER(y) +! mat = CMPLX(x, y, kind=DFP) +! call display( val=mat, msg="var=", unitno=stdout) +! ``` + +SUBROUTINE Display_Mat4_Cmplx64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + COMPLEX(DPC), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Cmplx64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +! This subroutine displays the content of rank4 matrix +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(3, 3, 2, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat4_Cmplx32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + COMPLEX(SPC), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Cmplx32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +! This subroutine displays the content of rank4 matrix +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(3, 3, 2, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat4_Int64(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT64), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Int64 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +! This subroutine displays the content of rank4 matrix +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(3, 3, 2, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat4_Int32(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT32), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Int32 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +! This subroutine displays the content of rank4 matrix +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(3, 3, 2, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat4_Int16(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT16), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Int16 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This subroutine displays the content of rank4 matrix +! +!# Introduction +! +! This subroutine displays the content of rank4 matrix +! +!### Usage +! +!```fortran +! real( dfp ) :: mat(3, 3, 2, 2) +! call RANDOM_NUMBER(mat) +! call display( val=mat, msg="var=", unitno=stdout) +!``` + +SUBROUTINE Display_Mat4_Int8(Val, msg, unitNo, full, advance) + ! Define intent of dummy variables + INTEGER(INT8), INTENT(IN) :: Val(:, :, :, :) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full + CHARACTER(*), OPTIONAL, INTENT(IN) :: advance +#include "./Display_Mat4.inc" +END SUBROUTINE Display_Mat4_Int8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Sept 2021 +! summary: This function converts integer to character + +FUNCTION Int2Str(I) + ! Define intent of dummy arguments + INTEGER(I4B), INTENT(IN) :: I + CHARACTER(15) :: Int2Str + ! Define internal variables + CHARACTER(15) :: Str + WRITE (Str, "(I15)") I + Int2Str = TRIM(ADJUSTL(Str)) +END FUNCTION Int2Str + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints blankline + +SUBROUTINE BlankLines(unitNo, NOL) + ! INTENT OF DUMMY VARIABLES + INTEGER(I4B), INTENT(IN), OPTIONAL :: NOL, unitNo + ! Define internal variables + INTEGER(I4B) :: M = 1, I + + IF (PRESENT(NOL)) M = NOL + + IF (PRESENT(unitNo)) THEN + DO I = 1, M + WRITE (unitNo, "(A)") "" + END DO + ELSE + DO I = 1, M + WRITE (stdout, *) "" + END DO + END IF +END SUBROUTINE BlankLines + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints dash line + +SUBROUTINE DashLine(unitNo) + ! INTENT OF DUMMY VARIABLES + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + + IF (PRESENT(unitNo)) THEN + WRITE (unitNo, "(A)") dash + ELSE + WRITE (stdout, "(A)") dash + END IF +END SUBROUTINE DashLine + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints dot line + +SUBROUTINE DotLine(unitNo) + ! INTENT OF DUMMY VARIABLES + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + + IF (PRESENT(unitNo)) THEN + WRITE (unitNo, "(A)") dot + ELSE + WRITE (stdout, "(A)") dot + END IF + +END SUBROUTINE DotLine + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints equal line + +SUBROUTINE EqualLine(unitNo) + ! INTENT OF DUMMY VARIABLES + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + + IF (PRESENT(unitNo)) THEN + WRITE (unitNo, "(A)") equal + ELSE + WRITE (stdout, "(A)") equal + END IF + +END SUBROUTINE EqualLine + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints the time stamp + +SUBROUTINE TIMESTAMP() + ! Define Intent of dummy Variable + CHARACTER(8) :: ampm + INTEGER(I4B) :: d + INTEGER(I4B) :: h + INTEGER(I4B) :: m + INTEGER(I4B) :: mm + CHARACTER(9), PARAMETER, DIMENSION(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December '/) + INTEGER(I4B) :: n + INTEGER(I4B) :: s + INTEGER(I4B) :: values(8) + INTEGER(I4B) :: y + + CALL DATE_AND_TIME(values=values) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + + IF (h < 12) THEN + ampm = 'AM' + ELSE IF (h == 12) THEN + IF (n == 0 .AND. s == 0) THEN + ampm = 'Noon' + ELSE + ampm = 'PM' + END IF + ELSE + h = h - 12 + IF (h < 12) THEN + ampm = 'PM' + ELSE IF (h == 12) THEN + IF (n == 0 .AND. s == 0) THEN + ampm = 'Midnight' + ELSE + ampm = 'AM' + END IF + END IF + END IF + + WRITE (*, '(8x, i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)') & + 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_Scalar.inc b/src/modules/Display/src/Display_Scalar.inc new file mode 100644 index 000000000..c7f0b7646 --- /dev/null +++ b/src/modules/Display/src/Display_Scalar.inc @@ -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 +! + +! Define internal variables +INTEGER(I4B) :: I +CALL setDefaultSettings +I = stdout; IF (PRESENT(unitNo)) I = unitNo +#ifdef COLOR_DISP +CALL DISP( & + & title=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, & + & style=COLOR_STYLE)), & + & x=val, unit=I, style='left', advance=advance) +#else +CALL DISP(title=msg, x=val, unit=I, style='left', advance=advance) +#endif diff --git a/src/modules/Display/src/Display_Vector.inc b/src/modules/Display/src/Display_Vector.inc new file mode 100644 index 000000000..897509be8 --- /dev/null +++ b/src/modules/Display/src/Display_Vector.inc @@ -0,0 +1,73 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: I +CHARACTER(3) :: orient_ +LOGICAL(LGT) :: full_ +INTEGER(I4B) :: ii, ff, ss + +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 + +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" +END IF + +ss = SIZE(val) +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) +#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 Display("...", unitNo=I, advance=.FALSE.) + 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 Display("."//CHAR_LF//"."//CHAR_LF//".", unitNo=I, advance=.TRUE.) + CALL DISP(title="", x=val(ss-minRow+1:ss), unit=I, orient=orient_, advance=advance) + END IF +END IF diff --git a/src/modules/Display/src/References/dispmodule-userman.pdf b/src/modules/Display/src/References/dispmodule-userman.pdf new file mode 100755 index 0000000000000000000000000000000000000000..d16ec1824f778ed05577d4aa91f5161e998103a6 GIT binary patch literal 162230 zcma&tLy#^^urBK6YOJP~P zc5yN_w1xJ_I@Z-p++s@r-0Cahtt%yu$|AGZ&o9|>6n z{CtCu0Q*RiMVPdjU4=Cd8nXNyikI;5BtZVMTxAow*?6<3(&^!{bpJ*B@di9BO0Jf@ z$^U|;(Cc6Kc)C11x7v}5EM9CEnv>fecCTK~g{@(3YII+U9GZH(oGp(7+&!KK#{A5J3^f7iQv=GTf=qgzcJh~R7R@nTBx zbMgn7Ie54>GU4T$Z3{c0uYVc}&h5x$vJC9B&gw1qZHPgS2QNG<-Y@O{d5W@YNmC1b zi_6RP@LLbJ+eEQ!x}ktE-K>NzKo_FO?woYRGH;sP76jNoTSRB|6ukbcDIN z?Z@ALPo;&{q(#xz$3>Q0xKJP8KRbe~BObJ`_Hc$c3+{3^yD0~wfsli4a@W6Zkh)Nd z;dZ}FXxW!RyZp1gy%hA_)V;R{%7zaMDHB>%yq&q<3zW zo%uH!JseN6U~Ev`#TObr%m_mXts(1YbW#6`#uR#dAxT{ID!&&OZZ?+&B*d`I=2fsf zK(l$M{|2dkpte*m7Clr3LKeB0>0I5Pds7JC%EQMu7D0E4PB>N)@*BAC;))a&saW}H zmOM4+!_hltNaRk|IqYbh*9%2k_)d!qlIf-F|71ZzM)zC%P3_}m*o-}YJ`92*iN3<6 zbf#*ymAP~)6?$nyIe#1tbTG`k5D6V~m6yJ+sJkBaH=ZOP%lBl?8o%Lj1Q^;C#@Mni>ad zttrVH^q8LAF63aHo&^n2>J;Zz9!`P^c>k^B%RFGhls+!DXBOcNn?g*J zzqvhOr6G97cbv+;i1LddP6QuwJaqf|&_*=LCSy|2EV$4-&8)!|$qNHzEm4kdEc`Q9 zF{hxA6w=bMprY>p(5NYjGSH_QQ>E0=n&lr!0SzDQ_%=@~SQfm6{K6mEv|4YjzBT9L z`Kbjkhvj9QGaSAxg<$@&rrsPQSps!nXgdh4*K=n=H57ep-1QbAZP6>S8L#XZtvJ`Phce4loy!9VQ4Pu_Ntu@F;65!Aw=+8Er8<<3a?K&nR8>5D8Zpj@#= zG?fPeYNh5QNEXWBRJejei+-Pwn$D%=L#~^`Ou;z8fKcYuDGGoWK2`$2{tQi6K@F$P zJRg6{C*v6)>%)ba`Vc2e;`|VgO)Oo4(;wzCr~<>&J%AaQ^2_bcCm;k0xFNyYdqVfu zIW^w#!MUnfL9ks*qC^D{cpx9oba6qrR(Fj}1j8(ejGn3Urx9BDX0Tz}T2|P~L!@Ww zrVXX9o=OV%xu`L;7C}BGykSlf)aH+PQ}lABjRbq9F+|rD1hTO_Kw1gMjzWc+PB$S2 zRG50Mi%-v10``+(8vjNnFL8y!>ZBY<=$WgWxT&85X_>OSe{?6-5ig$Hg!vCVO~z!r2C{B$6tfX@_*!ZcdLe3!%y9v=)iYD(V@Jg6}r5MW563w>tXkq(Y%O zmNAg<_`oW7^b75e!sr|Nkx`Ty>R9H!)(TorvAK*6?*QS~Yc5-Doua%egZJV4#WFDi z;RXal>Cyd#0uHZ%JS*xkdvIpZeT3OP#q9eOMa~S5Gx0isTS?parz?2HIaA0W=x3OI zq3vX_Ody*Lu7*o^ww~mm=cHFEAshi_T&qH!felb0EpQ`N43kQ9on6rIr}^9AmfC^_lx~?x=T)t;=qAkWj3~uQO%Z?=vetxs>^HB0spZWR zTrO#Bst7b0=_yc_>h4@YMXI6aXA4duAuH!f1&ys(O$P5>pah|A=U$;0MUe_H<6Sv- z5AHa`hI8oW_U$*KuiG#d^T#M9f?YsoTf+tle0c0jur(OJ0LLgaPBAs>KqZ2ZMsouemm`%*im?UXRL>X5WA07Ux$C8GhWR?!d3Lhb)3`4ixhY~ z%fD2lnF}v7R`z5vLe|Rn&=~4px`a`_`;@NQppR>XG**ydV&zUR7*bB-;iI}zi7(LdWxR6D(|kynXM12};@Nw8qrY`4YLtHr@n>I_HR9P5nw z{m1h0N7?!HY?eH>=ZmjHX^^Pm48&6q2gTA-@HdB6S09xW-wBI;qhY|vQL@y`bVcN| zBLk;;1x3RwKeu3$g|g4&d7?nxN-6qk@k4!4!fsEWG;P?rpT zTs=FE971wNV@!D^p{szR8(>0EkZl_HNpFeDj6bo^Y{qarOP^EIyPAkzsn%j5881in z-Q8*cNcW*Ce;FSW1Yfi5o$4{|Ph+;X^w3g##F;Y7b-GV9*ZbmC=0z9j&+Gj^3=_w| zuBqEz>b;i(geGs>CgKZEKT*Q4RN%QkjAY5<8De8_!Q24ShjF41u!RC*cyZjGZ3 z+w;BEMwm|wsYES>0=`&#^j=UO&$y1wq3e^CgAX0Q4iztj%&6$)#0PuP)%FpydqNipQEhU-)>ZRg`m=O&RJWo1Klzp*e5n?F)+CyCQO65k>bEuZvZo0_< zMeo#Q!G2=l)X0J4(iRk85SXjGngC!P<&;+q7zA7+0e}}SC8Y96D^-;tY0??%WPLDU zxIGc$!_?w+_-n==c7`vJ(E%_&B79j`3;k!^J?+#e23p;FjNy@pnmC7knN-~UUU^6j zEzE|Q)u77d1>a$@OBb}`->B%3NX{(_jX{SbbiCGGsfkEAwip?9Ck=u!%c^gPtJWO* z+Q!`$400P9#o-s@So<+RdM5$r?@0tG0*=w}{kX7_XSGKB5IZ+wSRx~mDqFmFu;F-c zEA0MH1#0xg8D~#vD1Q5NasaKtzm*^WYce`G%67;WU-k9C0@zclB)=Xl_TS~7Uahd_ zs%C7Buorw&LZVD{Lf^l&w&Fh58+r++@mIASadk-uIBIijh#?6rdKheHMt1#25f^xH&7JnxN6&tK=BpqvZ zR_lVO7cwbQnjTgki|iB|6%H%*6@bm_u@b9nlZGi}Kpn)b=uUlTi#yAq`;zz~`hhs^ z9zo9X6j@u8r*}-(OgPg6(WPLl4`RGxG-1oh`LM5W(SsF)kl)nAmC|8?DxRb5Ez_2H zJenc$WjpdNiSe46ly~iG$+oFQ6`IsKmAdR`EO{X0D3MyVq8*3JRIIVKGjP7-gc*S~ z*1Od3Y*U@uQ^v`+_96Eh3dVP5K8ve*==>o{DqE-=&P>7;$9_oAu)nMK=@Kv-ttuAI6&6ExV)H$XEJyF9ael9eLCy{9-a1n`oOhER~wu780JZTbA> zinhbUB6?>-__~q`N0Y1qkVFbb)kxf@<||`GymDD*3yjp5oGJNUB&i3kdg+qgkKusH zj5C8C8vAPz@ zeElW2L3Ojib#tJp>1-rb(VZ9pCNSqvV?`-<1X0{a={Uj3sF|H?RMl#+s|WwW!De?( zC)=_n@|(IZOUDRhgNgl)N^K=pmh=;}HlR(nK4CQ1uDMlWcb)K{uZ>Pm@K z9(@2(7t;*<8olw!=IhaMlyn$BJ%Up#|J9DPT$6Ekq;;|iW2r1OzuXZN8d5+iH(x$G z1z%Fd+6>WW9&0V1DNQ_7bm~cMP*)O^=I%0UXtcgb(%H@=a^;{1ngHcYP5aj3T|1JxBUr|U`|Vz=7#S=1$pAxK_3St zM&>JM;Jdk=A|Zj>*UY%WUOIOQPQNs95=GhUbE>$T3TVYuJOZ4cF!fo!a8ccf0Zhn2 z4}11LG76Xv1#3O;PmOS9UP4^-HYKhTw@$L&S&D58TJNhD(_p`jjwI+9Hh_h|ny%A$ zZWN#7)a^~?pEisKX2Uc0nxQjbZ@DvArbtS39aluJLF$*zzIwU|dr71q#qDkUn!g2t zY^80GBl zVNttqAs_=EWh#D^x2 zXw(1F5c(p+-wJ0)NY97xE~?qU^Tk4O&AcGYir7agO`Ut7MM>nIJQv5x0jzBZj>nnOPS5F-da>q)|kpCll1CQ zU9w#)AzORZ4A70>H}L_kgfUfx5CGa^*2^Y-xqm#->2)*$^l;O}2HR$azDbXk4Pk8| zZja&!(|V!zXi(ijrpU_tFW*@j)kw2)qP@PbiG#{|v$>5`viaq*XNKMhJkh`tU;GO) zXr6~Uliff$Ld(KcMq|M@dkz=+p-0fFqxXf6abxOb533f;Cf0zZ_>+k0YfEAt;G)S2coi=WeW)p_b zLu1}JtR4^(RpU6ad_&0PG?DT3J9W)|Qvex;uFv_~zKluP5Faj?_g%6{|)1W&ghtCp2)nvXC<})5# z?I~Y*^WqyG;+%`bcyr^~1dc<1Q-9?u19v-lORfTB}BWodn4L!=inFN z4}jWQtW)OZ`}E!LC!OX^H|3_zC0DpI>g3sB|DR0-%w6Q5NNyt^&mp!hr&Vunc4jX# zzB7tlvAYL1os32&Ma2hpiRS?w8dUbfkyQ|v96+dy^VvE`D~~V1T0(N=S1h}5xGSp86?)LI3BnCW zvN!plm3jD<0cCeUq=Dp9FVU5wu7i1(WbZ+v1d4x-(~3~MzetlU9r54$W{y(knW^N& z$)CVeQ$9~#qYRgtO-aJlsD410Dl+Yqc9E8ytCGK5+@CcNfuEgr&1-zjD zF)&LBL%z1Ecy?u1wpFmCHo5FZ6=*U@s9ZVoK%JV*D{or?mo>Eubg70PR5>i`PJOSf z+^<#Ja4a^S{#r%*EaWoV)vt+pp}7EW(7Xp^P#_gNMIg1qQlftcD`BGF~n z`J~${kY-_MC2xE`t+?$+03-FDFSg{$c^Ty!?^Z=kq2prx9Epsh*Snf+B;zS?_IWe? zc}F9*A>`xIFqKw{P|U@=ZVjW3gPOj-CUd^|9$`rG5jxJEy? zE9xH&o!H8ufe0$71-`yiMlj@F_?w20?+@El-zOdZP3mFSc`Y7izJ%)%BkzrPbJ@q7 zPE>t}fcA*QMB;zduA&8GUA}ofV6mBgyiYW0QFKoC8c3O@?w)wmi`@ht>&e@PL~KII zp=T<3m9KCvoA9oGh=2ar7}nPlt9f@1w#TmLg}s7dUW^*b)9>>k^5 zPV+-96IIDw%&K~YPAFYC&2-GZ0(WzFCR<5WI4FT4(H(J}!O^mPhcs_I$^|4kCh!dS zDyEY7I-HX$yu#M!|6!dee%t!7Bvti;ea-~5IllZ0dtb%20I^e(Ozqj79E}%xkWj_c zd(!~(4IHB1x_0&CqOQ@!uom(o=#V3P%aD%~H|LnATx>1UhOhZGHTSd!fE3C$UAt%x zlh3zA#_bhq-890g*Pu0D`9VXg7-2wfWu5%nIa;{o+?T8o?3~%}Q2R#)WM{qu+e?kH~HLomAbJvQu0%U%J+Hs)J0J+V&u}U<9_CjF%EySfp&Xi zM}{!%D%p6>VSIgnUZAXONCz|J{9VRkWL{8!3hXS^#z+r!u_+B~OTk2>dFQvUwQVzGYMrQ!!` z6m8f*!&61DEDA4xRUB0rj&U=Fii6-Fma0M|XMX=pAeAOHxGS*J|8sJ%GDH90jFIDi`4}VT{|k@}>uM)%vpE5B^%-OAPuqA{91l&I zD@9t0t7S=(A8M35*Cqm4jHR_=S+ukpj=w&@B|yGe=LkGm8f=rL5#Z-6w)kAwJN$jK zTB8?EZQqcQ)#+z89{JyYb925AZ7gKo>_31P|I2!PTwaFtKb(s*R&w}1ZmMiY9Gk9X zM6x?;&ad9{G88}UWA(CdXJTW2055y<>+Cr-Ep{BY+?y`j4nGGn-15Xfk7hsStL1OA zap^zrS69BX`a9w5yc=d$7|vXb?De5vGXHH-bA(?wTHVcOn{16krFQ>4;)xaC{`({! z@a5*=(u0|{(5Z!=jX}399G!=Gxx2m}P_Gp$_Sr_ywzjzp8H^oO(A}l{`aW4>z2@Lh zJBvuDUA&!*MQ=I(+({p#U3x}ZC}(o@K;rxCvAEu&^d{5YwUoClU@W`8dz@#hz^@KR zg9Fqu~?@1dgGYahkiC=3AK*z1C=*mF=jsyFGG{!B{w_OI}63* z2MLvrt+3VE#V&#_$_r4hGCl#^e5S8Gykjl!Ug_cm%=UKN?V35^OA%7^1C{eikGX5%(&;LIR#cY6T1PKN^&$|Eu5uEuA(>SA_$H;)>Y(T0c)@DaU zrf0i8DM6#}Xbph^{|1$4;Pu_7L*mA@UiHQK8$es|%Hxan9XMNNr;ciFl3dLwp#x@!Ut>QBf**wu~Z%kNzV=#5BAS>Am0v6YMs*$P$NemT5U;QtBH)jb@UH%^6PGLO;qlXdj) z3XzHP9~%@G=o(G(Nw+|R@k(j_?N*f(8K=%8rG=&&_Gnvi@B7HWS2Y*#isZ4tb(hv( zhfN0YXp;&q^Qgat1r-*BqpT+rn7f@o)bW?~zsy|1?z>3rQqUk~Sf*}#t?!DcIZZFk zLSG)`cz%)j&~P?s#a&C%%qvNv5F!WpX2&5EB+#I6*e6mG<+zuLb1^s%i)s){9wsy& zFgZew=uPm|_ka+Bg0nY0^E=q2p-Td$}BX&m^5?=^AKYXJPacTj=7}~^pGR6 z2O<$@(qFhGxFKA3Mktp^fp8g|(&>(7!mB#eSHK1B0NO%?G$D;9E+SvKgxiM@2)Ct{ zmIKLcEw~eLzC`_o6M)Y8^8fJ8VbK2)J%5a^0`1VR0yW-rIqk;6V#kJ{OKva4X4Sf+ zOD;M3N4YNaFiCmt;=2xTwNI$8dbAYH?Uj=hOZNt}2_`Am_{nj)pk--xtMiT5bAl(S7j!?;Ztg zZ5ld6H(MYQxa?o>gvkU*>ilH#jwBwRj^&A1cCGh)sOqi6BsHW;W6ig11oR)M>1f=R zg&p{nP4DthSi4>EK>i8rF5~1(%@oMQugb#vK90zMCag$U#}DWRFq?P#2u&|ugsX)j3-4;nKwEU}5npr9~#g^S^N)^7DGoCz;K{Gz&XG0PeCqr3r*a83dp zfrn@la3VOr>(O>7Ul(h(Boce$TypNYatzF*a>IB_FD()}!r%xA$2m$?feU8b z`LktoampXwbJn8G0#O{0Vw+29sQ~=gX-7ZyczF|N%!I?aa_CHcYXO&p>GTM)i8&yKGmqDInUUmVk{SRt{o z#aAR!ih96$r~+YR1EZzqr|`w;U6f8i(S))T3*$kSU?6m+M_;w8&|O6DOAGP~qw;l> zoup(!SZSYgs;4T;p~n(o33vhMV?KvXPA<2pq2YhT>t6+Uj(DK3Wp(1v<8Ou=TEP!W z$L0`7nkiCAnCj8^V>@XPhVAj`ONhg+fH_oa}mm#+Cb-Ay9h;mK1>JI!c;CpS$9PR zr@V$FR+Zz!#7?(?T(wHTr8i)AeCyB7-@Sf9WmH;s7@hHSQdBB0hQ~(mE4q9qM~t-5 zFmFg&2L(q%638*$OeDRj87^B3#&)a}f=8{pzu+0%KAll;o|RciBigyCnD*eWY!*~; zy7zO@GANp8q1YFuTU-;$_W+Zmc|jY>-pN6$@yvG`=$f&y=&R5KPc53HUoREpDF*Vj z$|G-}KgYZ=Fn<-Zw?IenzHL%+!DFF7bv+zeMriQ#04zGQU$}jCLF7=Z;_G1sKE-l{ zTkaIYwjlT)g&uSEZgaMPp@|u!wgL?$^(-~|U%f|9oe}LSVmzbLnI2u!HG^555m7ne zB$H~4EG|MYE52fQNQVFX)3A>qZg!w}JDiV{*Gk_?-D%H1iH)#$u1FX$R!=|@@%0w; zxFCahnP~pg4Sya``pMxTO7Wa?WdXhhMidGIxyA2tAlS*F-L^>$WvW0sI@xtlv8$=RK?#UzhbmK_-l5mXo}f?M4s?iNOt3E2NLEfgYqH=vQ|Jh!xf1c5><0hMS{VurYa!0+Vgm zvTHe$8k&0Ixa3A~6cBlk)*qPv_2!4ks(e8jzbaIQosdaz1FC&t3AV+vB=rUEUUOOP z46IK7N|$3mojh?2Y{P?j(#TMnd|A2(R#^sjcVLieO)y~vv$7e=;h4Ig;RuVT4ffX; zrIc(~z|$LVQ%#9^ft5!6CI5C`QSQR6K;9PVqkxnjA|`f3aUGInTMh5TljfHknU(2` zqrydm2V%6NLIn)ek)gBzs)}ZwR!kSK#61glf%t*Jc>FYsH4#;FHdT~S@%9evZNCkE zyKrloNQIHihVc~p>B`IE{Iz$=-+=sf;RA33T3Rpmz68-biN)$X)rjmwMNbGFRDZ(< zkqPl)5l%nbwQ_~up>Fq0I`n$ku;-e;p^N8btZcZaP3JCpq`6}p5GA#7z+dFO1-0{z z#gFHPw?UYremz5DgnumGNxN5bX$;_iz=MdKKI`mw7)Jx+jpWc=#)_&)17Rjz!z*Ay zx=@+x*dQaS5uB#v#r)L(E(#iHR3Ku@hgy&cUDIfq&}C>h-U#T47MvC05HpGSx%61+ zK!@)ELwcnS;|ozL=YE0U8Kp%izjU`)MwKGi=_s&0M2R^_j@e#^HRK?gFkfaoy!>f; zShRyBJ`759Njz~#nWIViDWYK;vH1yCaIjpWkT+y*2{#gtQ5Q#Z%OdoEP*Io5GlO40 zYMO+~GOpJQwt&oYjEM}wV4x6hda^*nyrXu!&lLhKco8e9p~R#?q@G~cbhA1w($D!{ zoNg++?Xs_x3r&^^)e-8=`@`H4v9cQF{R!M$yK4Lz$$$bg3#-5b*)uO2p))w{mvb?A zehaQP-_qMINn}k{mTIfc23{|_sB;uu*t=cBJloZd8R>bE7wz3FJ`Ksz-n-P(e7_5y z*%2B3&_`SAFO6YIHph0D)>)2qu1~Sn>Jv@9phL#etuZG3(0FFCa?6I%BU#1USVJx= zIRw&i6YhHX311mJEd8fkRWr)|gC~#@Q2< z#r25`P8FsJp*y_JN&?c}P+GcV*m~o8>pM) z;k4swfx;T)8l#Q z_a2lil45}vQYXs^iFkSiu3$Q08wKi)c<%A+`@?NJUa`Q<8T;}V6@>CbJ7PocjWs+(6*H*PmJMY>~ z%*3x*NEd`AlGuG9)uSD6q%}!)m@UL>7YE9wwS=#dbkn(af48njD)w!f^jF=Aq$}V~ zL55`ib3ar_bJ-~bRYP{XFq4r4OV=1#{xQVF5$+LJWD%k!d44sdcm6K}mOO_$Tx zJr`yY_XJA&vqzTD9d>_QwVqB*K{w64Q^SDmr)`+pgwlYD4)JmE=gE;W-Qlw?61ABz zB1PC-MUhI5AQc&hOm`g+C@cn)$~29<&mDU^;jITUV(YE@skkfTYS>p5>}#~^pSpjt zQM=c&5Ta|inj{;*?5*PTQY?BIYX@Xowq8W+USsY1;*l#GysX|^Zrhfuvl-rXC^Q2? z!_3V@!fYh!s_Pe{2+o48HqOVXPkrqb9q*qx>t%Y)j~-bHy$_u!co?A8nX5GUH+w_y z&eq^^R7B-Wx(@#Y*#O+&aYP(1XTHg3*0UXJ2dMX|t)7LZnb21fG<^bh3#MYuy%DW# zZi}Wsk{83;=Y0Z5GslZByvkESh&-?;w%nqW#E&vZ=^{j>@^Kyk zTyku&v$5Db+M5s4MxZ@axBy(N1yn05CD=fsK zr(lSJchuTR<+u z9JXxH!{E}o#@VEFBZ6|p_CY5WA^J=Y@fn3@=Zk@$IM1y(UWGQstjt$^yJb1DuJ*^9uMRYu%QEv@u;DI*GYVU^$x*62hga5{^&6ex)dQ=_A zTWHu$T`#h5d^5_YkD9fZ>9aLAXldSjS&!e-n`5)UTQqIE+ZZZUdN?C->I zXPE6KWg<;}``L878Y?(EA{Yf4LzQ0<-1iM-tT*}0>HL4pgirCfm|Jm;&~?mc@2vtBQZ;ZnB@^KsQnVxWeTn#Mjp@+S#nj#n4m;c3$yLt?!3R}ih;V; z0LE=#6hw!wKx6eNkMa?))dCDYBOE~@k-Oi5+X%k1g)>1OoSG}U#uO3BDt11x{L=nx z$Im2JBM%k8ba1zHn?@!C@xeP|^3hHB$6sr7DG=gWS|)gbF>g7tl?lrUzQ9+{K!nGHcMI?zc@>_8KM1B~>4YnY0v^5-gBXdzF-r>Iq z9T3LnRHJ_PQ@(n=`>p{`A?X-9Ajg_p+dBVRlBlZ2N=pLjhWnWHuhR<;qG84g7OmIS z!vbbWJ71~iPk{+;(9d}x-*dnzJ7zSlNm*|o>rd5EJ*X&l())rKh!lEfsp5&@nGg)6 zA{E@;@0}$@P1p#3oQA5fb8nJ^S2CxdqPt6*o%|oym;x#J1lu+k5EzbE{Lpnod)kpw z6%sJ01YMIAf<3q4qR$f_%kDO&=v>9y)GE+;g*}ni4F9epMLFxnEE;DMHq}8sP01rs z!=WZ@Vy$iy>3h4yi$r&dp`QwEfpt_p&M+cP(#ko`(YbKjZZ11$k#$1?vfDB&*M%tO z<|ray!3fJD^%8(Xqaxr{P7E<0UY7fy_l?*oL`zC5+)(lQAgAOKy)C@SuNIfFck-ze z6*M()F_n$Nu;6X<-HRL8vfhHvhV{4aq*caq-tG7b`m;c24tdJ>;xU<3h|T09NVZkn zOUvhKbUc!s#;B8yGB%EtlE<2YsXjpRV*N~=iJzg}2atx^mdzQ)|F9@`&Xy8s6`a8A zExofz;t-Ug#0pmFB!HMGQbY_&E=0POKzSib(T7R>WK=aD zu&Cfa{wcnGo}GR{LR1i+0B=?p$FGR=8hm(s$*hzfNoH41#o25KTvFH>K8VC`BG}o4 z47$8^+fpDEV7wezPg-LiDY3|V0A7K@WKMK9o7CpFma$QZQd_cUOPAB$h19N(1I;3c z8W&Q1CMtbm+o6+5)Ds}^uRUR+6xn(#>>C>D+(9Pq9!%^#8t$6;-WtCGiaahe%hCs! zwHiT7r4hv4OXU4RM_MrqK4r0A-xptk(3oyzD@viGPiUWS0MV#AzN1yi1WQp_P&ds` zt^Q3_%sRfrFh*^E(3sxt=P&*T*Vwa30cn#BWcF!SES>bXH214TehB?N1?flXJ*G^W z^=ZF$xlH;Cuv#|xDSqs|)Qrp*3^}?|e3MP3Erhcxl%0=V%7;N{_pq#^0~aR}5a$SW zF%&mh8m9+{S)LYdS7~LRQF1kQLe3r-ca6iFpCZ+l4CVyzQLQ$`;CXI`I1e5~Ppa}@ z&k8(7`Hy;Db%cIxhO{s!_`ZdWH?+#nVUxdSNg*r`e&}Q^o zpBiPpV8`_baf`C+NBr`w=A`Ws#pUAbU~5^o%783J3Ik$>#8djJp>FqqddXPBFj+Lf zhREq9ra~d~j+OKaUxRV>n?HI;-n8=vR|a`5?a_%^Qk~si#|OLI`~9a(XKm*)9lj9( z^xRnb8Jk{D)ei|62yd+ui8x0!G(6rSw`Ft8xOaKsZ*jOhvP8V_q=-hdaN#1s5V{zo z=bS0AL1>?Lc^MJnGiralPnrAI4RVnNrt#2*TGyU_?g4f4u{Li1ba^}$qnib$Yl9=+ zxm}s79an|j78Xc^NiQiqej#|ewaOb?^%tELbea6|espc(pMp$0;5E|qg+=?^on2x7p60HLnsom!Eczb>`X4P~W8nP%wTOxN ze`ygD%m0fOUF&K)leD@5PHWSKQdkO+w4?vbMei7;9b6nVP=^yo((x8O)Jfmac1{+X zI8{&Avd=|Ny88v5<0Yi9$21pLn8DXTK;X~7milfrMW3-%f1=~j?cge{<&iM6tE+aUhkDc_fFNZ*cu^Vw8!ew&&b))qUJ>9xfEagH`i z4~`s5j|@2Z!@Dz!TYjGPmS`r_jeoB|l}s=l=TX*gy)C`l;ra808+^OCm0}jeQPV*g#NQr>LYAK3b>YAE3x|!_mSWsmt0}to zzkI*hq)ppQ#syC79#nscx9vcfa+?kro}GS1tg{^-%qr)8QNZBMMr=&k|hkYEVg9@&Q>9rht;4vGlG~AjqxG4R8I$aU*0>!73?3K+x6OIT-l+9LI zXpJ~VhXMXB>C;4;696iD1`La$usiFVS%P0_yCs{e2ow*((+5_A&ub^0doX5qi1C58 z3$6=}C%ozde3~V?p4%jiJe%|Q?t&B( z^eQ`C^iT6QtHFUIN2y^rKf)0-%s0voQA>CEzG4x49J3+i_HzAIC&Roo0PRQyUH~dl zU$VEHp6R&H;_l&(AZLu<7<_%TwO^bPL%JS%r=gd3q5+lbzlG>h1O=QWu zk-hv8N~7TzZ6M_3{%@Zz`W)q=MF|;|JJ~yueNgoL>-}dqmbm;H8{eDr@2B{{&kI@k zeGO0Ok_*GBIF34*<(1Dwq?=|}j|dT?Qjsupw_B(ityWA6O;fN2U?=0m(vOZ(GcQ1lB5A@7C`jIe=awdjPvi| z8`>3gDaR9+-1HRK-`BL-LrP|*M}AN7THrzHGA+ipXyRBsaYQG|q5kwwj?F2dqk`CF z^(`7$hbjO?JW-^866fLkbDAi^UV^+&l0WLqA^yGDqY5$#6wM2JO5qJRI0?Vyue}eQ zMx10oF02-iZDaL96!Z7wAee4{1mii6igR%;k>)3%+*P&w*-WrXn>L$I3c4>Nv6tPg zd75ADr!(iPd)@otwKGa#o${W7wcO9kd@CGmD4wBH<dpU5@xeEc*kO!T~M@AoP0<4XC?@%Vk^+mrnLdE?uY zrOyXgOn2?NoU$~w1#<)LVp-#3(r42G4@>hpyOPb*D#KT@8eknhnuz8fQ%B*6ajjd%D-?2E`K?M8^; zNqiTvkQI0+Z=5Se{p3LDjobksP!VVqGI`I*e^?pd;1dLSS2gU)GBZfU7K0RqN?Wf& z8)+78KkOb{WIcMcWVj4t;v#5`pW|tJxO6YG7IlqLFga_Fs+>R^|LCz4l5aAicudIamEEvir>-u#!(5dA6Kl^g+LyJ*f%<`JZ>x!}jI z2!p=M+?wuMuoePm3BdbE2DBN)$6Uuv$+E5D?5K)bkzOk+MFCZLT}Jwj2dot(9aSkW zw073*#zW5k{m;@dY);_l^MrpT#)O`iN=tz*7Ku9a@>j-Q_wZ~?dLc^_f9nlC^}NKC z?M?#vP<=IzdDc{cxOWzZE1coAZ`M9vZ@klggdNZXdM*RQ{!2dofu`}<=iJW{bOG-{ zRR!)rc?B0p$b!1zp;?t`7E6P+A2J*)9M=_P$AQ`Df}oBQnrdPq*yc4ubZm<;js0?_ z1sw1SKOY7vz81n*!bjy&qsf)ZArH0K^k+326_ZbwdWX7P=Si+#eE;q~u%2eOcq1S{ zewRzpxMFL%QzAO$tB25A#|2LE&^xW@e!4?4d}Y*ss@`g@+{T1n3>mJd)_s7k*RC{i zLvC$i1X-W+_LD;nI=ErLy^bu*zc+uVr}Zr zUcOuui%1JclIt+kmk(SDef1;l@;NpAT2=-2FaE8X&mlQM%eixj(zmaEC8dIW5~ije z&)T0i?7}RcrpZr`W;OZLJ!+9+qTBF935f%scdsQY3>i{U7P$&nH}{Z`OZxax1f1-| z^YukF1)O;hD8{iUVx*F1jz)}L@;4NI<_ny;HqruIqsc=6;!-F_$dW^tI);bM;vpb% zZJctUS?fAqf`D&Lw#H~|=Xi=WTN@o#2bszroHU(=Q4GT9$7_{`HLEM;1s1__b@=JI zL$SKVOnX9Ai*+LggdHkPEg=<;hJ23BA7mCqWg%PY1;TUF)BbI?NR!=WoyzF6<9LHs zcMmgz5$sYG?FdaJfJ!7-6K#$!AalnBGoIsTIv+Ph@h%}tJxSGkGjeNmw4}a7B*qvF zlR!=Q=-&inFA9|T4N;v82Cb%saW$kpLrpPdUmJWvpz(S@j9)ig&YX%;BxeqMXFaBNx&gIN{CO3QIV1`%DTs0qR9s-f zIW$1NL6r<~d`9*18_hZ6SGp&3+{t#7l7$G7Q~g{~JpxDhyQVS%N6-woJNH5}-(LqV z9lI?C1Z6}MWChhIOn)x?Pso!r&CC8PX5_O35Ys*Wlggh&FLyPIi-x{>9!S!QW)t%i zU``W=>C!yABLqhZri(rEAH3jQ{ z4dVhu(|3R{B;Gc4z^ts9PflUYK%9YpRxbma+FSRQ*!tmHKwl-p(~zS;>TfjZ|Hs%j zMa$AH=`P#0ZSQ5ieKm4^^-!4^GhzlQD?%le z9Y(4ZmE9FZNF>65kC**@9 z>pJf%unc;__Y?)kivt6ExM^dC*!} zZrPX63?S@XL>`>(s2?mqV4oCl4`OUWYa$HXmc4urRaX;w7U}-KNE_S?NXI`*CSc-<*Ho0r>fK3z%j= zy#(w&L6+nA0*5od=oUsk#0v-~8c$K4J-j7|>(5Jl1N?QjXjpDi+r0*^O`jxsm?xe2 zR|=u8Q<=zGtbBkp!`COOc(Ey?7<}w02Ma}+eoANqPQ6+wK^|iY;pt*RSJ&FNkSiuB zo>)~Iew6KmXc3gGI)esno$9kZM$(dU(S76&!Oshz{W8qoPQ53k6H2%WF_l+tK=zYT z#(|FAHiQ(hXXw%m&B$-^UxjsH=E`y2$2Pf=-VxJL;%^^y)oxpmiIHGdE^a_cF#;5@ zvfE-!Jkr|RN2&x&tG`$A^9;tgn&BVWzt9z#CUK4Df6@xfB z(6sOgl;$}R%v{k1Edh3}$G0(hy9w3yc7&dDeyF8Bsek%O2rGNnc-!l_pP-=X3B;-L zwlc1IA@)P2Di0^@#^-;IJ}+!Q7!|VA5hIb3q(he|e_DglM3$~BA_jDRBEs4dw@H*< zonV!>$jaCV0y5UUTsNQ=MIXJiRrSK}uEKzE(s9>)8sf}%Pm2DXNNzm_ zK>H>8&=0Z(7y|}Yz>kJwCpeTXvgs^WoijwtxryFcM#XJ0De z&y7I)=4Q>GhIJ(nF*qsPG5n6XU!#l5*^5FrE`vZP5O-dzS$SHj6V%6Z@(a9}f`ctU z);5Cmn~Epm>CM^WD}=K1drHh(Q=uW;z7og=swOAfZf^JRu1voRBi`Iq$PBIIRE-|d z*Po{~ckrTEexuW_6hjkTLT`p1M=cT=$3rbKeJ_8Le%sD-?0U6*O28N}Y_FSKkkxP# z39=*o6+ZwZgSg+A-h;qF{1bTHdfD&ixKq%|qB7zvXF^q)Au>LFx$;t4SgIMX^a>oe z+(Bgz_V9jScO4okGTqh=%F1>u0DOl>O||IBKNp0xH#+tp%A0!8DAVmy%Yo{O@0SSF zXsZl^+1$&$jW6q&Ah)d5AL=ekV01``P1g=MU{&sVP9dV`!YPy)C{GiQGf#^mcXekz zVN5=!tqhG(%xi>&l&@{O5i|H9%y<@X2hrDhhY%Kn2U=e%%yYq&#i3ThzD>uudJI~~ zd9H`o0TzS=U%s07!pMsb;MKA}huVo`KYzk3_Y6NyUq!R$k3-{?==QkoVmY#WC*p=w zz7jEIZfE&SH`whDVE(|gL}Xx?pZRdW0qu8!x}5>A&ZK!*rcpK{c!I%xDIJkYt2Sn& z4<%iwy%;&7>jJHpfLF@(tL4xaw1=A^T=-^U7%8j!fefDl)(oY^+7s}p(ufba40nRm zVA9)=?x0P1N+YNbe}U!`U*7CWnmyiyGa^9;dJAIA00l&4Kl~13j_C%dya|(cInLHb z82$K#ly-ZH9~c+5Ab@6kVq^gCXk8?N13mGmOtrqK6i25%nTVM4%)sA_awRZ5y6^hL zNfPJ{)m<6wSHCJ0b}74)E3*n^GDfy)}4nwbjPX+q~8|Z(ho3iD$PUx->>#8`BCb_Ljq`UOs1KB+aIU@^m zPEe1{Xn5^qHd&!+agZAXbhbfbFs5e@5$p&|iz;}czlHz=&ff>JSez;TOq~)e!R#e7 z@arxvT)MFcGCy)*^y-3Vc9rPSo3{{e@oz4<;HkZ3UKqqinz z)9MmTq!nzos=oeBE3(DfDc%engkviRmD-?s5~#r*;=o+Ov>u%5&W$qhx6H+15eS5A zbRSDF>u#UVA9#{+rLM;tJ6peng>rTFc=`p-WC3qeUhBrP3?aifZxV?SUzQx$hy}Uf zH%WI2d`DIqvfYM`B9xL8uS$n-mTe~IZl>K+hzE5Mm>^9{8^>a~%OsD9>;`KSK=ST?ngy%MNx(v%1uqK}A|26+ z&^}#e(Xc_Shx1Q*M!KBOdL$wyxrWW!AGCSrqedxrWhP~#XO$$C2W{Q;QSC4UWkq{N z8d#%;^=5-k5zs%7Tr~??>>?YyCgOKh2aqr_jO`#1Qusd65H$JhpnWWQ7}nUNFk>#u zweL|Khx0bpK|#SWqIh_O3b1}*h)AR50QIG~XoP@+kpeai5p}5O+&y$Aia(1i@7^>m zj4w84gbrF!GC2~f<}$Txb!!@!Fd?d>?a{El)VEy9j&=AC(dck62|?{w;$mUy4s&WD zc9+S8Ex$LzTB6waOOzs2C<>`gSwtf0s;j8-?qH-oQTa5USC-{S<8 z76%zpDB}eI*D;QHRgO!azGq^jBUHz(@m&{QD#hx(uSPa2W}2?szJhEl~`Dy)W4E_+Oyn#tsl|VkZQ0a{V$zOW9K4i+eZ2oED(;8tKH*HViC|jgk zs+__Z(q1v9OFie&L!au=jE7e4vKT8hp+g*nF$WH$1x+b$Iv)GgU7$L$%j`B0ZcLKS zbQnlzJ|Z+cNZBNxl1-~FwMzD6J!Tr|5^m1;j9zr52gTe6a^8*PFtaP_HH%KhQ6r^X zL6KI>+elW*pt1f?;d?Zi&&2;i_LZ%?gvWKr^15Nh-F9jFbgBE95DRc>P;@WwtD#}D zn6X*B$$h$@wLucnt1S9gP;d*?E< zpfmk__}D+z7iE<1>HaWP*M_O(NcLnsq6jz?%2yXifFX1S5>alV;B^SbYfJR^x4|Rw zAG%M(PW|iyF7#FxF`qEUDfe(?OW7D5T6ulx5VDOL)vLUB#qer~)M*NU4-E`qTnTJQ znljEv3pbGJ*hkO}E9w2NWygp$6hoKkHu;P?tCLI~(#3&8(8{WfX}fF;7hiAkFn;Pi zuC4dhCm{b5)qKm|y1nA43E-~^#pbv_p=Oe(IWUrw_s*HP*5J*!H%i+U_w==+hgrFUU zpFdzkA+4AMI$S-~e=UEU5(q^$3J1ICHqx(XU{zZpRG=soR#66Om-mHah`5G;6!-8} z|1(Cpp+ZQVae-d@*w(ckVpQ6_>b|lg#*`T0PXjdL*|6O&*XO?U<|XqvDIoXa^Vn=n3e2+eN1Kk2pIfV|i zmEbCw-P}?FmK;gH48(9Z#|zG9F!-w+wZ6vZi5b&W?;{AFZqt`#U)jOcPIXwSBvkg% ze-xWdhK8?31S8mDS-fu8907gWX7*ck_Y>~J`*}^aGc%hZK|2;Uk(O6Wr&Nk{ojuXq zm}8wimxWGiP9;pmPZ19ZC`5=(BH>DgxlEH}tDAQb*$X9^reD6m#>_a2==ZE%swZ3H zYihbRGb*b)VAy9OB0&D~kvQZNqB1yLk5qO$=2|QDBWI`daiL(&4c35!YV4oX%3bAFQc!^%0QQnJ4iJkjC1ePPOF2<+B!{c1ApNnHO z>p~E8)C}t90(f8LwxyDqg-lAO+}OZuPGmS8B#jp07S4b-d#QAUF~V@%S#nTMmmYb` zeoIB?EP=#bEl)1E2qAqRbaZH;Y8yfEy{;CdNxuRi5`WvFol|=BRY_IS%GBjnuHN@b ze6gO>QKxDIJT9c0?=C#9H=p}rDLiJsTErDta}lCPmDkyrFY@1gt|Luvztukvhk;))~Q^bOj@nSUIfOW$9Ub0uz!^<@wFp9w=z5tCc)YUL*{@(*HstCuKkA=5a zy}bauayy;>E3)*jh|#|zOaD`c#Pmf`>}PKo3cCep5EK-;b5oh6ZFf|<<|Cf!1zw?E5O(1!SHX$&lBH!-&Inkahu1> z!!~Edx!LhT_!{jOM<=v}ChHttPn&D~Cg0a(cP>xYE7zIYCh1jIW1^$M>p_lg9=wHa zX^CS*#+Y`d-tOn%&9R2jVr91KD$Gnu|M33({m?$`^&J{-mrK(r{Or`D@gU&(_f1eu zGUrZcSBEt$G2mug{z9^;cA8z#t-bSHS1J6yHvzNk*zkyIWwZ zf|UIJ!Mg7B;z4(NTRE^ty;`1v&%753{kM@bK zhe&11!I86*7?p9#X` zaF;#0mwlxy`KVZSheaHDJ=8aH3%bbKE4ph)fJv_YIogUlvG;Hz>~qDx+FTwFqCsIh zocMK`Mw|Wn*+G@%37LPR77!s*M>#jBUN+fH9tbMi94j#DY~j?grbOa9q>cnqJdiF$ z$9RSe69mvg>9dxeXy?{aU>&5IDRaK!MH(tk6I!=Kk_nyp()sG2#XO@GX7TK^ z6_9`Z5}=xLsSd3J6clZVI1&6CfbyKwShw3w2I0)!8Pr3&K0ZfPAdg(?*IZ%~h(}VN zxLhLEd8z)6P>gprkUA6c+`X}~2P7VQ71VukE{z|*?B_G@o((KI-z4^S^*lINB{@J$ zZUQ{mEL4c$3fSM4l0UzqtqCs@Kklo|A$P9~c(TMan^mb0Wr~Z?vY_AyqZHb2#RhnWp>}DT~xOOaYl{Ic&U@? z84V&v`hM5(YF3KJpV(LrXX?lmeg@{Sye$>d*P++)E64ba=1Y62&ClI>E#?JPX93_h zN7l@rd)8tvXX<}Z{VxiIcfaNXdpe{J?Q~AY^LUI*@w$!p^Kb|xNZ*3|UB6}e+`9#- zKWte#0(B;K@z1e35|0hQIbVm0dZNgP&oL&LJ2V#a$XFKV8_k+wJW5yTKl81^<}R-v zUP8oxs5X)Xi|(VZ{OP3`QF@V_op^2SpsHh(r5w~zu}P@RSeBGArkjS9ca8Fc zbG6b5f@Oe5xO3>rCdythEH$1(QCy z?%Ab(+#2(l?=)d$PUK;2yh_!_`RC#Nit7%B4EQ;xw4(mNL|^o$E|BlxOj1)3R^ieZ zdN0zzPS|t?hhU)eE7-e>$RPP;3*9AnvarQ(19hx=+M2$n|J$IplL0;Z+fE-9dj zMZqvvUwfsXF?PFP=c=M$n6(X@fYuq99`u|H=`AyVt3Q`O>l814YdnwOf8#I1+x*SG zoILFM*EwtB*g4up_&IBRxw&YPMWO%Z{Svq`2ZWf@7)?Y%;?anTj|o6IQ!qrr6(OE0 zgdyRSRm~gKfP7+(f(98t1L>q09{$c+2>FBeE2Kepxkxyw=81cA+($gIrwPvCH*Qfg z_aFJp%=9Os?C3{$?JIn`Kk~)tPtD@YtdVa>k1h*CUxP0NQ}5t(6TE)_atLVplpf*# ztY_6gZ~&P8sU?x?R~2%?vK@9BNKSGu`#BD8^UP6WpGC$GAisQ#Nk_fGy*` z00Py&0tWQ`4+Eh5K+c(Q8o{FmqsE_|392+(1W?a4eME;1$?bku-}f>zerZ2 zWocYiF2QuPnM;uhC|q>peXc1(lcEwk{?37ad5(Bb=3K09G>{I$XK<=mi0aTR#>`a7 zh<6wIeKPmk^Y2Hv#3OKstVqUh@=Gjgce?3+_Cuq;-EJr-oeT@U{>+7k%5sVbp>UpK zQ5z`H`iIIEw`-gg&Cm3N&W)dqx4|QDP7B7o-J){#58q;NQvQ0Jqx?nblz|((_>YW3 zXY)s7UI2*5N<;q0iOSO8jH!F??=Lml6vW>rRPn2BqiCXDTk5c+Tu`HK3?v33N|T4S ziUq_F$FE{s=SN!>@PuN}ZXsO_WA5&sC@yi}Jg$a~sPB&fmmS29j%5>NOz{e{5PL?M zGkqe=M_n-%5WeshV6G_%3tf2&GdGNeku}02PWR;yVI@f8|BEnwB_vE7<}KRDq9mNx z{{O!1GXK8qk7f5r*Fd0ZhL~Op{HGcjPlDqc|vJj;*vU zICCEA9?RXcGYvExnE#q7xOfFZZ#to&V15CFv88xcZZ)_&2mR{RLHZAO5dCv^;x6&; zGYv|Uw1?2tA!yECuY7FqE#W$*k@K9ZqIdd)dx;n~-+zmRzzgRqIny#k?84o-aEJD6 zKd-X_`RMw1-vZwTv5j2mh(thEddnTYt-mSI zJ!d4s;WbwEb=Tq;NrtU3WcRU!$1zKYYu^ld^>jGg&U;VRj;9gc&f7TlKbXDd*~VK(-X?p+qm92#tUY@Ltc|~htW7@t z^dFuM0@u_G7k$5TINp9NznB2j(@_NoXM|{;7^b*WRuzA2BhuL^Hyh{(d~8*<)6T3c z#>kT_r+M zO}c8|x=w+%fD?$SZhKneb>D)_evOTm7mNfLKX`)xF|R)4tyv+teox(tqvv=>8cTws zfZ@fRMt5tHEXtzXC_sN}*cn3CJB};WtlY_;PLRvnq+eC42M%(tlLPZ;I~F&HJ1MT39VVd`Ho zM3K0r#)7iKSb7jU`C}hY&lKW_c_gIs#O9-(NPzwE$hj64t3*HCF-%3pJ5mBy9;{qr zOTm)#-jA6DL2YNjLapvm6tycAWHwX3Dlq9w2IbW1FD20SPIPx z&nyPY{Y&v=xNOf+%r2X*%U_0s&l{>}FUMm|11;q|Ml^*hBh-2AlOKQTz zC|5BU_3#wK5k9rNb>Mwb=C(IBWIv(6v;?MY%IUK8I}sbTQ_$k0=vFA1AnBAmkNXp4Y=qafH;(-e#;9Uo z%bhX6fArH!I%GvVR3c-euu<74O+?|Phpg`h=gtD^oPjTONQ5gjoz7*ip00)~tpI4P zs)wE)NYh+;@3Fk9U}==Bbf`IKXF>jJ0SFt{byF}i?KR*yU|T@tHNs#TZ|B19BKY#> znX4|VO5j49@g;Xm>^aKBE)h*VT8^f}w{w_1S?vKdYhd6RaN4~HHHvN5BCPw8AGIG_ zdr2#U_xQ&0e)p|Ou#ArQuxHyQBQLz0%ZQZn*^!s#u7j8IHHiHO<*vFH@z)X;$zOKP zW3T4V&0hM?;jhNe6OBFo!=n%L-br5$o%t)-~KhGJkaA~%bd&x@sPIn)dsRNU=3^mCBlF6 z(5^5L5H0JBC66}$F$+-Y`OSRzEww#lh82Ua0l|Y?iC8o4;qvmJLO5{@s@U-z$1j=j z?I{3r3t~UQ91NG1mK+np!2k$P+%sfz6w?>9=BZCqN6bL@f|mwy1tAUP2`(-A@^1uj zL7px^*E9UpAf~TKvIvOmk2_6R|Jo<~kJxz@3}~nSKNTJOdVG#4>%#1~D1T97qX*rw z-EdxADE1!~5QV`_4M(dl!2O8>+)(Ov3AJTTOhTFF_EDLPzSex!}V7|V7UfJYFg`JKZFh( z<=*;PFr-~s^m8K9{8j3}Y<-v0%d^36CL;bsYSjxNuqxwZQtP$A)T%!vwJ;Fo22o(x z=U%FJ#)gi}e1l>8s=8@^?aovBD7|||X3M9dNz2dkQRt0R+LFzRFk3zdYm@t6<%`J} zF<)Zc<%nzU?tUN-zhf#sbyu3hAu!=b<*#+&5{PLQN(D9e$D7(8K)sJWT;}ekl@R)F zSf>N5bg9R$QMGHN)Er2`kz~d8yOc^qnjQ{R5*5YT1C2w*Ici)LJj(6v1X-Em)7KJ7 z+W9dOD~qTK47-~AVbv_-p}?9*se9!drG zN&wJ9lV|HoM~W2fbzeGE^>~n3hH0*O5mB-gmyRX3PYk5kS=zMZy?Q6P!yLF2373^) z8mR|Sv7`sXgYU6Jh&+_>miTflvpWS8G2p4+Jh9hT4RwO6qg0H;(K6$&gagmAWrBh7 zB2|Le?MgwJ>!A>?#<7Strual#@jRk!Lpx$^z@8Cy;oY%zVlNo`rZ0p8xNAy5QVHk8 z|01M&huMMF4@TXYoe(VpfteYipDFYJ@jy8gk%vS6-$zXH=Nd8;eXpP1Ki`P=ZP^!R zsZMn_fq(L9zghMS-SjgvQPyUtea{-%TA{2ei$?lZ_RUozaFVH}EiGnP>zu3HTl-ve zcp`CVBdt?VHHd=ws`9l=m$m`o;& zPqv+|&E{zon~CEaDLmo>#^iy?QwWsV#5_mRxp5 zOvck~$B&5j+vl;xLVjccg}1$!z9?c}q&S#baKA@p&P+QYdgM!)27Q6{z(3vpRty8bJrq$@0v1nNKZ)7 zd5xMb3Z7pye5OM48?zm`X66dG25+7CKS=h1rv`rosfO$sTPgMuR>}P7R|)uTCRNZ8DwSj6UA734(_FRYysxE1Q-yHtV>a;M)cF89qZP_hTJ%|6e+O7SE&Tzigiz>3M#+My&HwQ$#vshMHjzaY3=gXEu`c>rPyzI<=JFB|esOxfuR&^JA<*uep?E_p%D zaN3?$f)}?sESCCDtee}eDM;)xl4b7(VzFPR0+A$U8?hwe3t(~7RhVL!H$NpYS3%Oi zPGOQi&%ZH#d&rHc9-hKPKbE3cyhQ9D0*WENd<20@6Fl>G-qXbRWX7V{i)umjkk9r= z4087^39VTP+$7}_(zy`5eKNDNx=DVjIKD@Cq+It?B;QNInK!)zd0DD1d5|uV_Zex0 zWC>ga)4wkVhHY5J%}Eu(cMA_sED6+)=puFBij?Gl^W5RGrQz4VhfXXohG!@PyneD~ zP!uC@_yn_A`Kzm#oI#u*%@WZ8YP>HOdh5=ebeK ze)U%IjKhS3rj%WHWb{%Yd-o=FDHwOvSMt^6>!C@UdTroc+3<(f%xe5tSw+*k>2AtB}w+w5gYLEP`3RLYVUb-=tr1Ny@uJ^U8HXXKmD22|mbj3sTw1TPZBtM2Ivchb2D2L!qZsSZ9*z>^W+~ca zW6py!?#8+?2`u&0fH2%$iM^^o_xuvEISz6jzQjB|T>5j>0Vtnd?jJJ{z;|CQ1qr~6 zX_Y#8a;(wI%=L&;h{X~KI0;cY4Bq{a{oS%QTN@ndWN9Cyg{x*@V)!04qWM}BmFn3x z-(l{nR}Fu5`1Sj}>;xPxzgI(Pv~{FTipI;V`?NpQeV@pvBroEsM7F)=OsycRvN@`> zWNCG2jlYBbjcHDTpyr}3o9v`=M|QU*R6M;lcsox{9p-w4lB_hM%}FClV|Cc>>Ha|P zh4}u*YVx(hrx)eGJAV;cDg5#r8U_$qv)Kx%S{UgrI8c- zn(Vpaw=)*(ZyPDz0=lP7;F*#eKCB4=E$J$01u%f1??|6}_w(MJAMBGn$=hFpPxB?X zO-Z~x0xOG90t{V>=x#ba>Cc?htQj(F{zpVfgd(l?slFB7v??FG(g>9|4Cms*cP5oP z4exe~bkyie$TrkyUq`Aw@#biD#o?*X9vGv9feL%5oV7zC!7avhkYU@RnSN^9D3&hM z)gJHc*J^eQmHjIHa)fJ(SIE)F&L;XVOq1p-U!H9129d?Ozd@oNDZzg~c?a@9QwL&O z8TpVK1VJsN9q>*ND9Ukeq?XaGZuty+Z&v}S4RbDRr=OZ*%-Yqjven0<8{S8rcybz!s+I5Jr?MoE0$t( z4ui;O3zm@^&GiOd%G5U7r6{r0KyqP@*GrmvbpQt`)7;yE!=`wn2m?zGQZ&Axcd#Q0 z=*5K*C4;$(=1t$DTe%HuOKJ`p(I(YyUnT%1l<4Wx2>*FNXl1$%(zSE4w>Jb~La>nfo)c3IrmWeanGRvWn^r6q z%s4Ndc(L{23KIe=h2`gi_}ia5E}9ReUv=??)~Sfkw7p2S4vY z1mqu7z8-Oj)+!zS*94t`qRWBIL{gmf{VV+pApKS2fRoZWvA?Z>N6$S04~fT+?OX%z zB`Q0Y#9dZO6iX$SgEj96)Tu}MJl=qJrZl*d5S5Upy<;~RunRbdy4lBr_G^>11X67P ziH|==1{TkT%`b|r!eeI4pWhM`TZ-3sEtEjaY$z+OJ;`}zD>A1LR^44joKa%Z1ihBi zrjQ_Un9>u*G`>LEruQkg%edaYwIXuIx_3dB`?nHZ2jhOq1cNbs8A^1M05X7CwVuK? zzJEV2!#m$kswE8fah*|u+`^4&4&A-Yd58Pw3$O)s*whw7L}E7J#}w^h1v#Uvur_c* zF8YIQ>i+Nt5|#_~WNx-lfZb(*v&Lgo2xq`_6g^>%y(M=R<+6drdwk0_1jx{dM(A%$ z@jk1#rhR=!cJBk5>hy8|FPYdpJ6qu*Q8!ic}x*6g{6o(?9zesMQm1CbISn;B{ump*!;g>9~ucda1 zF@kDW#LuhkBL7VC-96T=`@)>3fn@aD3AW*&mOP$oCAnxC`v=HZSI<9Q)s{(1JP zbN+)*by^Bf#L^`7r*&7Z$CkR%QSt~N{QS4uSf6r2IpF3B3}H@VM_JevO1^4I z*o4ZWkMwi}V0Yt4Eg4I^2k_sKQc^m{2F@CW9#XVys@gqb-sMvCR8!wFC}95f=BC8v zFg=F)u+_Pqe4Kfo#)VU2sIQ??W9wr(bJ~Sss+Q&j>%OFA=<78($2wAwxJkp$3 zC^VzH0*~V3F&+#yac!s`!u1|7*zMFwgHq+*bSDcWT|Lq6gh7T-cd(dvjF$d&5jrwcup<$<28OSL;O1 zhf836urr&ydq0gD<9g-b?9f6$7A)^W`cQj>2Zj&d`n!kk!27%C&p+3Jz1(Tw$A6&t z_8ul*L+NvQ-VWdw1)>HUXcqU^Gyfhwn&DW7`q%m|25CY>Vjk|Uz5@^UpRRoIxxHWZ zUTe(Cr@hju@T#)mZ}G*MFP=`9KT4a4e$J@}b8qqfPLcTzpBoo}k0jko2hjyU5JCZ9 zLE#SsEV|nP_p`tO=TTd^ea&5KM{tM>{q10h(Bb3rwRk?z_T3Q4@$+sBrq+LP2>!<& z@7OBlRu+B18#U5JUmIez86`k9O-BOL+snH{K2X6FrR{>$%Nx|&T7)tdo!kKYI_237 zm`|^j^o5p5##mhYdj5SgN=g-Bb@?%-G zR>fR5!^0cVl%6DFCNMS7aoCq_ds45HO3#{CcRckS|x4B-9^@4WkIol zpX^a15rqd9J4NAM?BBDEzMcfjOkv}PD~)P!3OfSWAh?>yXXl$s$b2SEoW^1;Cw0@Q z40EyNa%FD;ppZUdhXnlkW1CB-s9#et@0`{Hm4-agL~lR0rO;eai)R~pCt9V$SE^HO zH{_kdXO#%bZI)H#3Yef8IKKyQUPY}g39KDJ%zz%=UK4${lo z#0`&~=f6ED&`gk`4kxN}%gR4jid_<%-stjlf)X3W%UA(%(&wmH_IrF?EdedZEYO}W zgsh40Yj9vV91GJuwSk134&?hC76aK3dibRUrrxpc@ZMvR|7{6w)bvG~sWh6)yJ&Tb~PoSIs@h{Uy?Tj#TjGE#i(*Ca|S> zcl_LDUU8Hkbf82!DG(0|mSm^s;0+a}Hw5a86XSEd90%7(T=ehkFy!ji@FIeJusgu% z3=tk*$KoD}-iy&}96TOb47qsvpP$jiVfHnXq<|C!)EuyUV8L0FH8EBNyih_#)NyLO zOf7DM6B>nil7Wc_Vh9RhnmK?nx8xBblsv)UbQ?aly^&Jy_M zQC@wk70&!KMg+klFfq&MPi@1Np$!oAR2R==xT9;mjBOXzAKm(5Jii`G+IYFW`2O}1 zsScHxLer5mgFI<*&tE2Kgl6cwa2wF`s2ee9c_Xeu6|8B6G@=M!!-|h=7pe<0@{TTp z^c)_zCm=eQkXsXwz=j`Y9XWTPJED`#``egDwZLt7IujWjz359n9Lpj`7E21*2D`U$ z3M6Am%SOSXZLddjG`q5KY;X2q(yqnu8nMS)W{(`d~n3v z@s|#ORd;Igs`tm{FP+K4ts0YA=qd0^if!)Nu0C`8bAk3qMLryIiin>|AA9cuy1=o* zW@L}Lfn+m1hwW1;3RViKd`@l8iSlHv`Pq7$71Jbbcw_4zalvB%!DBeOv1STY(@bLN z16;Cp@m}Z$l?-_E1b7B!1OlmJ`DBjT3o~FZVlvpT+aPFt6oMq!h%WVL*a$OtNOL=- zd|li1-}NA<(Gv^5bt{8S!)|lM?IBVT`3l&~nwl(wV}E-^4f{_-j@yHTKaaEUA4}V; zL7lA}uMehZ!aoO_))@w_An)Y6q7K=qkYhW=V-se(bst4Z2Li$3}!Sf8*8vuoexi>RKqU( z7Mc#2%=54_hsD{&_KMMjzOZfUzNAck`m$}w!Nw8J&Y4`u5h8~&3yF$rTm|t(LP?@~ zBfq3gh2hOY?!tJ}FbE6N&)Rziwp23u%|=L4-7GI^YOdQ2l324xSt!t_a!f3T9mH0{ z{koeyk?jb_Q^r{#Y-AlTTCW_gig=u1#Puf`L6m`q;hM5LmTOv5x>lVk=O%M(M<%h* zZ16XxDHjw`J}>l<>eRSPV?~Rkz0!=2vni3yPQw=%jd4HZr(>A%Xx{B~)E+jUAPCn= zO)#XI)pG=KNV^Y7p=sHoR?K(j{+qbPz`CeeIH_G$?*NcpTUDw+B*6$hpnx8a9g;2q zmY`a?ZGNdi0(hkf3CpgnH5Ga?GIQ4?=n`MkXx(9+M5Y>UY9{NCYOv@m#6)$69vd z6P0BLi`?cR#dWoA+4N-&wHIayUX}ZWGyXy{n*Em!I+z4HgK6D9WE7Rj`}^D7N4(ow4kT+2!v z?DALI>eWVh?OS!tVpB=gT(OTH-N*Z$WB1UCKq1QghLSodC#g|U&*X@@cOECn&SHYo zCbRgaO=l@Y1XvgvAjK8J^nFU;Ub};q;W%J;$L>NQ=9XZF8l?cL;&7UC)*zus0@V=g+AF% z9WZ+bgvI%lh8GY|*xdw?=YyjPt)J-FmaN$YTeB7PNGXh5 z8NU?RVz$K?eefJUx0CiD^QQcz}y2dhFRt$e6ck`jpVC{{e4; zi-Id9*EPnW(Fu`r-ky*AWubNgjs7gQBEa$ns;5bi6}nCS+t(D1~-m%b|qF5VR|V0kbf!f{U=KD{^Agp9cwPWP}nH%y(|V zXX*`hPtik{xOY$|A%9gnhnXPi9ib zj8Wa6dsA8_qD2xC>C8}m=kt3a#?=V3ho>u3`OVkz7 zv)D0bhgqe1I)@}{co{^6=h>8zqShhWLKp^M!W-EjWc%vvk{H=R&P{*6HZ7nQf|Ej@ zIu_H8;J_UMwPu~LNRz@5e0c!t3zUtLaB(!szBnsH^aKMq7EtjFIG?o@DzfbZSa_}s z$L7NH4N@bnLCY1|R0A2N2m{}`4tCIK#W77l!>EHQWPZ3#Jtp=9`#mdATzKP;pZBRz z>2(-T2_iJ43%1oTG6OnBFY*u~Gu$8Y)$*oB1=MpthJ#ayi-I$W8$-s__0JRIHuP6G zP^MsJ>(O!jJ=+BAq0FRGQ0S_dG1`!}7$Sd!BMw~_SONY8~0O!v`v>|Go(hlMF=agW!=sapd(ym}YFGAghr?}*=c`J{u%9aYRs)fug z{mfvFz^+_c*LM6X2R>P4EMBB-F@G>HkVKllgPUOD*fEHQm zPq_GPVNde+Pxn1cVWfMD`F>!Xi#>lE4!Jb6?HuCOm*o13s@un`=FU6T{~V^>v!7mL zQ(W_^7h{2E2V$k(t>V>STx=Y9H$C{Ql~qdPCt@rGBbL`en#P{-tXq}O7TJegs9{M@ z>#PI;OM%D0-t(J%(uyIP*Glt(U*!y|^T`*&9SojCzA3{|J5|WYtfql|N5gB|d?rd> zzHNJ}SE$@M@5v@v>{?kvKVq6+?;sbGA2uVSs#`u~?i>07JVdrsj@h4uyTmsPIGTi^ zH|iP?S&je;`|cw3M$&%c(6evXHQ{iYn+|pvP}liLht&#Icge3#IBIx=<;%Cxe3LCm zH`9QWtGK$bD=^!TZ5fY)w>TR502nSKOqGw7l=v}6^BP`%S+LlF8_a`?2c|ZRf~F0r z$HH|@CJ>M!54vA#CREQ_*1$R~O^K@4s}0@s9(o)&`Uy}lOUR`kvpx-BHlSudP%%xa8$JOKR$rYwQH?AFgmS)T7=4q>xU~d=ow*YT96I1M(-z=X`qac2xl^T5W>hCMM?=Ad4jGbeXB|w{Pi{0fe z+qP}nwolnzwr$&8)+u(`wr$(i?e|8^jkq&k<_~0KM1IJ~XRq9=i*gzziA4PdnM}cS zgIKXoG!=~~IY??HoY|42HCApdCLU?HZJGY5$xJQ-Kf+n!ED7pNBDN-bblMBwf3F7b zI2ILADdlL&rFfEWlyDDqW~km$?o|;VnKDjPR1jCc6xZ)qau^x&Guk^GFf*7U9&{}AO>W;D!4@Hu|cKdiO!2p|kO zj+u7aAIzZ!_K2JS4i8k$9e#K}v`m9JyA)%vv;Sd$?s>OLMfw&Cb=%=WgWJA~XgYXm z5}gzt#4WT86NZU1FNm1X#ngibt zUNr~rmK*i5nCJeWEyWSMq<@Z%3v<87}P@*I|glcFijQz&;{2c z)O~C%a_%|05!C{tLfR5=kvg3fMbKn%=KpYku_1H>zulQ3IN8=;KKmOE^?3&MEkiCm zO&}!k75~ybF_PPKNJ!}?T0Zk}*+$q^5hDW`cp9(3Qb=e-( znjC~q(=ZXuRH%hwdX?gOyQ-BdR7P$p_y_4)4W}=Q0&m4ST2>>SO;{Y7$++S6e&w6^ z01!saPs*DZYbyaR{Z_p~XGI-fHY6Fb(jP{dO0>;}Sc$%gUJ(N5s=zx}=)(z(%|G&} z{%fB1xsFz@?GTYLZ(HHJIBHs!jCx+XOuVavdHw88Ki5Xvt=_ zjj7BL zahwZ6I~9UJ1ywCRKib63;Dy}*&OTw;Bg<5Ge(AJ=TU?*_A_9U`1KvbY%7c5Z!PiQ` z&cL~6WArLc@d9G0v#7HuOm_F5tc@O#1}h?9OhWKh^=9k7(|j4OZ;<9u$Ty^ewEHlG z0x8O{-`rSXl;$U#&i4JyGbQ(u9=vsA$Hix&4&eEXHsV^n^(d0U6JiD=9afj>rG#Q!uL?EaAPJClSp?Kr_s~{u#$hf-Y2kHx z_;J4rj4uN9-LPd4A35{dpdo+6l^f)(T%r_}E*3KWIG9eg=hWwyaiLGHn0$lI!vzby zRDPwxQB{Ca*RL=vP9%OkUy6kHGNr;kuaxnOtam+UawDzm7K5m!%9lBvM^5U0D|ais zjYQu#cJ%7?aP6G@E%xUXSggTi30JcwuJ$6IIw)MNpY3({)AP|3{coDW&ia(u`zrp* zYRZMV_58#cO1sS#>;tprvXDko@~qNVb_L}=m=3=s+bhr8G{cx^O+y8cHm|^MGK~C6 zNpnbE2S(=0WqnUAJ@K6iBMAcU#P=>@h;YL(9XI z+v8;GpaQc2QCHZbbPFWU#e$E~1&xHF_OBb4wW<|1 zt&~7OwppIw50_she;{vN@TOHbJb-LW%y5eUO)LxoH?@H4npSG4xOT2Djs0d7L%}z` zI7ez>{GP&oYRVd>S9t>u6OZ33^mym$7zKpTd4?!Yq~Ii8H#OD^q;K`=kiIuCA>Igp z?EctdwzBETQ2Hu~vjy|3BSZBYEf6h`ymTkKIo1A|TJ9-LUjx&BJ; zh@-ME^XdJ*;)3f_DH&R~HVy1$x1C^{M-2o+b&K53EsY^XPiLGkOI!}E$!>clseL_m z@jM#kSfVGMYof=r%%r9q=eg>ue=7_`TW|f?t#Hh_)JNkH zzr&=jejbzz@h47t9H`c7-+D{nreHcuX^4pcnbho&+J|ptIzGd0^c^X;yb?MrCMw4W zN7V)cSYjQz?QhvrLS#4-{Y5)1yOPP$hbhE8LiNE1@B^dSmWFR99)xVwzZd5iF6)_D zGr$2s8z%;-9n%B(k|BAK9X|*nk-fj;eikz;P+L8~KzK&%H2kiG#r;O27~NI<{78cQ z4(0|7+m}!d`Y_GEMXStRD|dvM8oD2YmBrel)hBwkzfrF)h0B4Zze}5Omz=!=tn>K0 zEh~D?=NBR(#%;uaVM+kQR~mV}JCXbeNqc{uW-PAiyHf zIaZ4rjXOz78qoeu20g2wLOl7JKi*=R=QpjjNv7%8$xaOCy|w zJa^IX8EBe_7sTyj6kDzMg6mMktq8&}ZW3jzTxzJO6rU7`%i6GWt*bNN-@o+kw&ysD zQTsa`v}d4)Ts*zu-%)KE;$Gs->izMUA*=fF!?w#gdkhU%Oy9qd!wvP8nbsq@+*O;) z?(!ayt{ZcYbogvt>L^n3+co%vgo1shq-a}et$js6dFEe$Ju!zu>(*xyuJ!P1F3@8I zP$8i=&;iEg)&Ykqa&JWlTG+QB+GtUc2OUBETk*cei(sxbuPXYutMJHH;H(6UfKt`2 zf9x^oIZa)xHNu@AdWd$uB72;2e8%d_Z2^O?$MMfP64B{1F+%aQhz`v+J+HpL@FV-> z>GW3KoV~3BiE)|S5tH29s#xs2E_z5U)_vqI?Q*V1}UcG`YS}FLP0pS zcTVKiDJ_*O+XA7saxssdl8+sYjGDVAs*ogVl;->E=BTZs0_o(17{&$(Gk9qsB_FqR zzpzb6_4LH~IDz#giQDF_yQKkwiTxJUvem7fb#4Ait1>?Yu>L|?YmjB53cBS8VZ)b; z?SQj)?Z}4ED&i8De*%-e)zhP?=o+B09n7=t9X-veud|l7c+?PVJQn z$kt3C``nR&%W?y}a-%g+9v2yl070XeCI4x3p6*mjq!ESbj%_~rIW1m)JyB{!m2e_m z)>aXxShRUoH0NT4LTz&-Iv7sT@vp+2DKDq>bXrt}`u+~)7GJCo3oN!(h+RV=ELJP| z)m0+_gA%qNUAT3et}>@Z-}5@;2IOOV+5JLq88yHZ!)4{rrDiEwh*AC591R7*1ozK6 zA;o_R!1^1r;a~875chM)BpWeDXSGibb@i6SBP`5h7Qo7hqfQuBgCnO`TSp(-G7l}K zJoP5)JIH2ehhP;DZ#tBh7NRAMCMpT$NNUOlP=P|}-Y{Z`zWgT`sIz|es_;^F9jJj1 z%opuZHdC)Zf=Sn+6B{{~$S8Q{ENV5Iq(Ae)e#6#vUl;i_beqQfAUpA?_i@5@JXW=I z&RdYBuVGI5%6C=)Jh%!f50orsvPc$ z11Pj=#`B0Cym6{=5rflOhiD3kE+9^pJMk;I*S_E}b6F@A$)vWf?}ls%^^yGkS(lGh zc<;ZaVG?I-06?Jhj7VfO4-TysHEAmC_GECIy0j|qYHbiNlL@2Obv1+7J$~5~jQ_%{ z+#z#o(dfG3<%uTXkfNAFz%lsXD-si_G#K4@ORn}8mUzZI-6+(7lRm27nv)^5%v}Xn z(z-xhFO^4cUb{AlaYiFlAHZDxVcmA;~?y#TK4fll_JfF#9_(B2|I zpf!2mM#dD29>gm)Gk+p{uh`OHjA-SbuR?2n1)|YwmP%Y@oV35nBdzaA-!Fh{frjx- zk6#sV40T&k9Khu&;60QW>>n!-JI9vxc6AJtu9NOE0DXS8pjFn#74^I%uNr@7X$>JY zH&e^8=ye_#Ye-QlB{O(TLx@vy_m`6a=dG6~RlP)ut?o68Sk1?50}RJtwYw6gKeu+l z5i5^GLmRz9uP%#Yj7W)Aa!aKS*FEcgI8Je zt!v+72*YW?^^w7?k9D03#r;6a(@ZI4sk&ZPM@o~@D^vJpCY)V-W0y`hdlDUmf8SF|E z=aJLEv!ydp0oTR5nmBX1&rG_-8=llm#cI^qDLw)PJ&0`@N?5i?A`isVwnEP>y=u~A zbBsHY-5>=G0X>|4p`QJKlZ^W?)S$u^7+*~+p#`k3I;fQO_X2WQt2lrNO0a7E>wWE* zl`!eevZ^{ZMfp{0dJjF1-|NQf`T84Fh9%GXf8s0ur6A_yWMuv?e1-KtJs@4==>KVf$t?%JvYD<7wMIg|t3W zS!s^T*1WEVoH2iiC~DAH4QN;V)ua-`&J*%o8b(n&wQx0kbG^FSJ+(Hp=lA*R<8`!h zGbhYk;EV67(WbXtEN(a8e^dx=0^-skVz*k({(6A0voc)u>iXS>!RPy5Xf<_GsId=fs_ zhZB1|;r*D%C*jS4Ww&<;3~g_mWXlfQ@Aq8;B%1UFp)vC+Sxn&E5__nT%NO=>yDZtI zzqB{GV6h17fkn!3oZEBT>=usOmzf`9%u?HL5CMU%Z36Fk>iM^Ow-=}!UH@jfj^K#w z?&58~bpo6D*AqnF=onc1HZKs&<=#752Q!) z6DCChX3yYx&NBGhkNWS`e>&9*I5>d}ysxQHh2QlF-2g>`OOlR->K~aq#kLq+9})|9 zE}?#06APKC96rKw+lt_s-#VULi3VQ%O0Sf1@iAg$UE3tjSm)UL0rvR%U`33wtHlO0 zlHgx8bVtv*zJ9r3e$;`+;JoC;FUn*O`t#G#lw=FRAl2B8b9TRAEaDkv_VALbIme(0 zS0(?L!^sDC;O0!e>8{e&!%xL#|Vqb6J? z`eJhKpzGA#;j*BK0}k=4hob^-=?QWa76p$yegF`{>9q}E4eO$aW^tTZwyr3> z5P`fIch0(#^Du%-_wow;Xl~J2UI}V5+KAilX@jjAz=k73-dl%Eh?)Z3p>Temt=V?4 z-}PsAEg}L}ZpZd3W0XIsOd;_m#gjZ{p!mE$|EDa(P>dAP%o}emQT3uK4|$m^Ko1Sx z6GlR1FXtt#*OPqGAF2lx9;a!Bs$9UuvtP|@Zi?XK&`T+f`GrM)a2r}hT)No`jvD8@ zz7T)7fL_*%W`3{5#~-?}LZ;t!AMDp!T4Pq_8Y}(<*@C!Xa8nHj0YCXYk%JdFWulk6 zs_v{?4Bq2%WhZ=0>>3IF4??Q=xHzw6mlYR1GEeyIL5IJLo7MOcWCKRoJDhv%F72h@ zA#G7LgH+Gy7|fY~JnIBH(S-_Y-k%+#Kju5BCV>HfANc-Ea5~y0$$5a3!A6w#oM!f? zM9Xdo-A*#aKjPB+21nZ&^4^Jym_ZC@r)gx0nl!fcg&Br&4T;YL+A(IobV}`YhM7Lc z^}~ivUl44e4`tVL1Ea z17Wrf1q@>Su=$9&Sf~8(kF_&;aAPjsJZ`Xbduw5!uZS(Ge`v64uLQ7Fse^cgV-pPL zp~+Jy{K=DLLviAXJpGO47KFM%PezDohNmqw&)*kdBNa1;bna>82!&w?01nMTl0`2f z$CzvGMl!wqMgo28I;;0jvd7j5AN`BoESn&B$^brtvk_3e!pK>E?XAz2FChF{K%~E; zH_j|+$XBn{3YtD*Sxc)x&^P(7Z-memgbjUu^7Aj8K#d{SkLO>lJfF1kS7EXYgQV$Q=@?Z3I42tRB&Q|51e847@-)lmD)^aLEQ zSjIxJ`LJCeO%;0aba_d+*J1hK`Ys2lWrUiec;sP3KN7#}QwQGMeL>ojLYO&cGvc35 zyB~{?7xM-L4yt@h%r6QdQH5gDIx`}x%~5usRB!26zU1=Gv4eul_LO4>S1gE*j{YjL`5Sg)uS|_&a`Cz4sX)8v^mvPX*k|f z}GG-dsxNq7_kX1_{6};(akKOf_HZ>oh<8pB$?s zT`F5s?yBLr9tOc{D(ocOW`fovQf+1Q4*lWxkBQ^gLhdwu9(y1=eMy2vStl5+q+GkhxF=I@qlG<%xi9{=`Q`4;rfbn~C`JKAzI zL#c7HUYx6QZH2_kxuba0J_wI^hR*tpC^GSZqNI-hPgUVJt zdZMAsa7<;=A=R4|{|&W+HgtGHdhk*&l@L7xE1>CqWa6(AFLAcGnK}TNGcHBWv_%@C z{YuaFi^8&CI4tw2f>e^xTrE=bmt;!_U(S%34*d2eWDcRMcO8j1FEsfr;;$8G9H>Ll zLDmJ@_kdX+Y{iWTQSiAarO5T=Qd>0UIEI1{nO4*f9YN^`d!)#z0# zq~C@(%aFtyb|tthw0p|~wxo-{^c+$hB;UZiw68!L++}zgMO7g`g zcb>pm*^0VtSAn!$RW=OGGw9YE%x~dHc|{ndZ4sS0CgXTE4JMI*XAMnLXIO6u!q+Sk zzPolPq8(xUCUCTg9;cogM#Qdan)E$b%@d)D9$mDGwq~dFlNyprv(yT0=;gg5xd)Xg z{n9dXt|p^FsCVO2wvb@ZtLmj5^aT8>6(_Pd+m-$M)#+pY1W0XVk^RkExF^G*?NTK! z{pTbP{JF=(QkSD@Zl13ZzV1yBdt$_>X;g>y8+HpmrF_VPwl@fmzd1%@iMYKtUhHx? zbgg2hOmo3DL^si%7@Mj0flZxHo8bvtq>(@SyPg9H){K>c*rDH*_$elid`}UlLeDTk zua;$~%`zffldPN@&hL@RySnbgzNaG}`A00MlFpv3Ooz(j_6+BDE0%qCP7b2t3YE1L3BKrLBiC(0GXC}8+C3X(>4S~CPL?oJX3WC zy5fwA3jKJUi9+Mr)gNgKspJi}Kc)U@!Nes?>%#R4Xdz@uGZ#QW7*E{Ijz60769Ulv z32RA7A50-LeKBZ2Xr7uH|17ePL3E?DW=W`yZ$dxB7#*IeHm|YwD6h>!b((M9?Z^1w@8kE!Kl0dvh1)ufY z7+;W<{0Vcc53$6!83PI=!^X{VLoXqcUq z#-Ar7^xrG&p3x6J?9LL=zehIa5Mh0~F+4JXo}gFykbs}<)E6CUg^wlOYMH~xcXNHs z88`mJu$L!~;SFbZvUOteqOM@4+Idsh5mBXvG}u8($KMI4x^Gzjge%>8CkX!r$F&$VWj9?LoHx0B`h%AiaDU61evAq417U+U;SwBDf->OR&R4 z`t6s)_i<%TxP7D)L0DF8c0i%1EClw< zjHH~%`S>TBvx&!png@!yQB0mcTwic(L1H6}EEHEtuo~qEDYZ4|u|3&TE3gqNdi6!r zb^cJZk^fDlUcaR?E4q2u;At&@!k!YTB1#07*5kcwPu%>t)wN9Am0Lw6vOh9p`K}zE z$%_`Bu^dfOUcOUyTs62}h3nU?cBX#9B3f*HM>%JkG3Jtv^Uz9RfkLX*+RVP~X+lGu z=1CY4FlHPfVNDk#-!$6d-@NnW~RVD)8*AfPi`0K`>Dkgzq3u2n)BB zGt&bGb+lHZ)0s#G-Dgd{d@1ynPB!*AX|`yNp=y_+#iI7}xHJ<(Uc} zH}JJ8$6u1DI}qTo0Oa1snJUn^t4;5!rE_bVBUwf$?zfkerA7!pYbW77Z{ zY2hXuB1xULf(FSXoWjR6T#GDmu=j^Ji9V$_+N|Nyit4dGxPNG9B|CwNS`_7s&EpD9 ztdTZL1g(7jkhZz%ZPGlazr(lS^(u)CQR?}-0HoBG2~DIn0+Ls$ zHPPPS-OFPZN9q-ALToKsX;TKFl(MOz4zzRUm0{3Sf2PAv)U2^rT+ zga=o%tQh;KL(Te0!Fz6ga^uN-FlN%Ug(Ygqs| zl6}4uc=hu8xLOM`5$qswdSVe|X+!4@2ety8zOWo~doShlnDMNN*i^*$A7)DYAcuUv z4tnd~8F2M$f1Ll)i|hYPdGxFA&$+taaGzVH9=3Y^!?#(YrrVN&{`}Fma33Xt-ZD`Q zmy0P=ma4}%ahqH|MING?tE+PKN%y;24@i|BtJj_0`#9Cc^tROXNeOwqtwKkP};&B3nnqR_(2v> z#O@ASdrB#4WVC(BS$1PP9N${RwH45Ry^ZbHDN$N>OmwmvZK=)n8XC}B#~1_e%h3*5 zWNd94p%bu!*o}6TkeLLnT9jUhs8bgUgo*W@gB??Cu_hp>_}a((DIHoY9H_Z0Qj@v|9>2*)|edYlfYmF+WA78M!RmU>N} zuM@76k}6%ufhr912le%j zNll-AS10G+#AjqpW%{H79EFfh6EQn9WJB_n0MP|$q~)K1y3Z+hRV&tdvA1xh0eu*$ z`uQ+uqSd-G)WiBwMVEc~`*fIf7~bkR@$s3J!NmXml)C7xhBRjf=B-uA$cEqZWkSm> z6WHW17pzXN+`{Yhj(caDl6OWix%N+yGcV*YZSR$@_s58r7eRMnxy~R6amG$M) z*kSPB_+Au{+jYm~-#1jFotX@yv^PZu22g+0b)BHxgiUmEXP|0|9k`}$-k;7k^o0X^ zS<0kDVE}9ja8toMhPHkl{RQ7g3n2UKfVLIT&^@P2pl;-!VRDYS82D!0e0Fv^esIRp zo^}}TUJ~7HQm5~hz|<1h2GMi|&TaWCQUZaZ#C(i^$0mmfR)q|PF&sl%%8lYg5u&Od z&C8gDa`jfJ{pXF6+bYIN3~l3?KQcr`xd)Z=oWpux)OT8k;#t7c$1B*J+AAiFpwx6l z`f7(8h?ilFGQyf99!(6HCkkav{rK_7?^QrL35{x3(?f!4{|9$I=F79PRj_vTV2cl3 zF_3?ld8HSp`XpfxN2}tX7b(|NC)T;k`$+WX#MjN!`LMQgxO>X;6I0>UCLH_wq&(|* z+?N)AqgzG7Z)t42Bn5B$yGQjFDW;B+3u7X#@>9>u$iur-xujBBtezA>?1~-tUGlcV zBcm%FM#&W2Loea&6WdFPP%N>Nq7p=z4 z5A0l9-|lK$7E|-Y9&nC=zjZ+dy&Bj;{W*oQNu%X|h!t2l%9d3!9svKW0`SNNa?LM$ z>^c)h3ml^bRI7sP_ma9+8skn6`HJxEmwV%7cKhC3bCKF1a)=B_MwiQKEw??a!_m7u za2_|SEQ_Cc@2zKa{cOc0G`E=_^-#-_o3T{LAT5|2xP5KMn5Vvg^3bxs=78J4!(WMC zhB?&Fj?&uz$wR35xMw-E6k5o0s)AdS(L9rd`Kzmq>jX!O>+-4NX>Z&*4e@RFyq3_tilJjZ0jQs?{LoJVwcZAkHdc0VyC zLP)wI{9jjku1!$|s!&FANwRu2Rki@^t}>Q2$*ArwU{@Gm({EF+Z!bT)?XabOIC zQU20Bt3pg$Q8df`+Zt|ALRD=5l|G}>J;2%9aplpWtn}yB{5F8uP!-d>4})X*pzvyR zFR}`6Uz~cqCQ7$sm~DTL&Y`;bL#gqIoTB2Sj2OjpH{3}n&reQC|C=AmRjV+OMuZc( zWH#?nl*?DOFDvH??A381?yfOt`|v5wq2?nzt}Nr^1`Lj!l0u74xRpDlS*)cceGG#O z(h}HH`EQ_0zdsC|$0%C1^G&NIt}U^@3&1b%1ei41JMEeEAIpT0RPMnu%pG?PUh`Eg zlAzjc?*&{pjkkwf12I<@(Q3L{S~vQJ7~j)tt=F1A(rZ7A^wC$$G!~~sj>G_ra;|@f zMPT0T+o`<9IodI#GsjSH3lUOW!<(j`CAB)wk6z0?FB%cML|tY%CoEHl0(Y|1kE6fC z#Og=HXCu4$sq>oYtSHwDqcvJi5kW)$6$G~y13@{t`vi}P_>5XjeVrfNdH4duA{Dl> z9*_x?h+O3!swILPyuH3C$}K&e@w}pzEp1N?oHIM*K#I`^_c`soVZ6@J%F13-y}Qqx*6qpg)Q(ffU%>s)gsuRJ__$cw5*oe`A;ftpJd6C^>fcs zBB*W3)W!By1U{NW6W}OlIvP`(K%D83!k+`ga zPqB9wLzrcu&j8Cos{(eDL%PAiP7@~l7i+~ujO8ivPs!?*f!X;44+%X`;8wn)DJ9|} ze0=m1OFv5cN8VjJ2V}4QtP+QU&?wX00$IjU9@2)O|3cKf{gR*Fc1~4{x_L9q-vKA; zp_3DdCy@_jRTrIw>h$Yd~oEx?3XWHm6*6oC?3SO7aL$dR4&q_g9B9U7%)t zs{lCqa$j!U%ZKYx8kiCLNhaEB&B%o6rMD2t$2P2SWwk@LdfG*s+MOLwTP<4-td>B# zz~|e?X-m zG!%&JH{qiOs7hE^>a>B{t*M2z2-9rx=*VT z%hTsrdmv`|`FALuHTJ2mz{ml* zmXC13qb@|aVi>AFvj>6d6snUIlZiMNq~V%{4iAuP`)LH<7!1HEr2i2T|KITUKY1_* zJ2UJ53yJ@u8UJq~@qcO$lo`Y=ZJYs4gbd;~M$Q0HfQh{+fS(`cx3d$#$QH&udy~&P zX`?w|`&lD8XC*g+jdcq|k488w>l8fI;?uLSnO?@+H=4n*4jLHUxec#h-a}yA7ya$QwHT3b3>3 zioILg8qw8<@?$@G#zbJ*qAy**4LyHho``=v>5h1n%r05|rkC?Yg(2YM=kFN~dycIE zO1tCvxeBwXw|x8Drf~|;%8Q{Mzoy_ErAg1MK3^jgBFR$`9e!QzLIqO-&KJJOUOyLm z-)G`@gV-!Vz%<~xcyRUneQps5CcpL^lAC9TUO%IPY^xge`@JQ$-3yAhzrDj@VYeXG z&PRJ$1tavu82J=im@dEGH@?&QXW54;L1se9p==+%JUHU5f;PIRYPTOzqzEY8r|V8p zYA`I{5Qxa+{3hb#wO;iZ?#lY58yjb6=;E%wt?~0@Jwt-_-lV=kljJi$@p>ZbrL8bg z6GdYrX|N%&{G;Svaxh*RRO%Eg=2Uw@z86}d;pA^&TvDtEjp#^T9@2H}(5bcbwj z2UDimm#P+8+biON=H;xe5TB*Z(M68bg6MMjZJ~bZ=*N3NFbJ<CX4ej<>ZvbD=$q|~+JFLnQSY74`S|1*7~uIk1&`ebg!F)LcO0=o z2qx0|ce0Ui3hCsh3$-E<>G5uwzEDrStYb(SlSmEHBt1|#^V-zHXXfXz4mP;t1e{UTprI>yLcIRm z%G`8}U!dnPqP>r9nSpGU#2k~<7b_tOdd!dvNMR~2|162JnqVh6Mdbw;F5x+CAf;N@?_($0;`-)ksZg$Ik9L?6n~h7m zgK9?1qB%)kJriy|Ae&n^36ioR>^K}!4r(so`EVv_h=*2&UG03l(`B%`duK(%K3nn0 z#0b=w$ZkXWNk+m4ctGz0GQxya0S8aLz57I{QjLqjlmW?xJwd9K@DVJdrp}R$Z)$C}Bd)9`$D+FF7H7Pa zEJ%$Gs6-ThU6?sXEK>7vK(rus1~eu3h5gyWgVWFpqQaLP=~^zt&$c~FQ>6pyt2IPH zENix{rq=uQ34i%EYZUe?u$*-eu+2Hh%6+Vo6N=~audInwG4wCP6BSc|_)_VDWucS{Dm?o3NOIJh7oAIvZ3~G21zI6O=QP~kBo2rt6cy6Ar|=2t z>DEdAxU~jy|7vYVx1`e4w2kv?Zq91@g;s;~s9ceeR+wk>=#pkaxm(8jZU%%(NL5a| z0!;CyXXJ&Do1kDWUb4!zMHgF6+slO=v5TLOPU$#xJyUZ_bay;N+(db~mW44|tnmD# zh2NgmrDs(+2eKsCSK{#jR*%$ORdN(%vL4f})lOJ8$K24ReUV3t27tCM;;mf0bJUv(C{qhZ@E5FD2D6CSwv2@PI339Z+GlnuAPkrr1hqfIj1A;XI7<)e z1~109qw8&{y$A8TDZYk#EG3sOsp{fLw1^ty)kY(TH)M$!!=*fj<7}D0iILxV3d12E zn^_8SM)Yzcy^Vmytw(=&iRhH^<4@x3&SEFG#C@0?vPu2>k3Y{Lz<`9uS=|u&p>if# z?pGLVP3$i0x84cA$zFvN?5%hfF;eT{2$MkclVoCc`?-2S2y+&{Au&f(FvsE7M!V?b zi2KR(Fwg2Y$d(fdTB3qjk!< zPV@68q2#Oh*@d#^gCpsIgh@@P2yw9KtDl87!$!}rKC`zh2lCLAKGGJfPQ5s%+!}oT zm7nPlD-s($@VzYCA>3z5ipwT=#EG*H6Y?@04VXi@r=t zX1)!CKyoFtGaGf}@6Ug0JRGkr_8_#2YnFoT8nagqgORASmlzGeegP5$^E=(n9XHvw zqR%D$)J)eUd&4hs2{n#6Ce~_fS+$dFMWcAOCJ*`sMRbr9kq-r8nR64^FVyTPF@cJ+ z>--Yy9v0?NntDgR?`De>>aV% zo2Tiy-Y=y60RfCqj+ULd2_w6OlYD^Zzhixt4D9p4Uph2m(@wi$R zCs1I1`AooqmQ%dDwG^ifzGh+e&3$MXgFvy~j9F^^&Som!6HMrp&#%&2`wH${vt%$< z*;kkHtYvT1BFQ8Qye0rQ5M(eVpw8Me8I9AZvWsD-Lw*^uM5Qe6$nePug=RhKB3JqY zt+fvWJELMI&FWi+z5TBYUmjn$H={_GGDNR{yJSm5Qj`FYx1$%!El-yKJWh{~VS=?R z9v7lkg@*|VA)+7c5PJZla8~cb5C_HrRmyqDCASFjlYoVEDW?!$kv%xe?7~00#WIH6 zvG-P|2qU(xNcCD}ibj%Vxl@e~W&#KFuMQkjAykSji8+owr>QnhxGJMe!ugmElvs8} zL-?&g=L{=h_p^u23CLigj2>+yXM7qTR37t2HB3cp!^vM#RbUdr>Wm~0h7VcNv=Pjw z(hI-$3QTOgFK$SY3KD4>=ZFnV8JWur!i_7|+?D+x4l=Xuk8=wo<1Iz_Elp=iC%DD& zbBzk!23+Mf;a?v|2AP?6F{DI-ul%7@4}^y&0%^QPv>qy?_X|vzDx@K&fl4+qCR2tpSz>=^u&6T8_FyYA-5%(>shd;+EuB${ z4JM-ASXd@oi@%gpQadw_VTDon$wjCj&CeUiOPcZ2l}3T$X&U{uS9ezALs^4&9OPCN z{RIn}vqwxipW<6ik2u-9`g+9Nvk+xM1bZwSVqARqrSCv5@-N3O#2>giJ@6&3I#*9!4I9=ERu`fTP}O4=oNeC@rMqY63dj{f#hIzi0i zAz4_77*Lq4J#6-}@gpp*7r@;t*L_d-GqF~?ww*knJFIG7qki6^J#f^g zN#z~Oi?}VSIMc|1Cn2zC8HGK|H(3@hxj7!30(Ht`>*Y^&)2fRUrhog*S!(J-InRu5 zm@lKDvGz92Ml#{ulR0D9Ryv4rU#~=S&ch}GgERZ3@t0s>M`DnTjzMR8Qdt4Z_b_fJ zfy5)}q`+EAhpuFk&rH90}_$si6`K$JljZl0$CrDQRK=O zro$hr(txRzKns(|w5iJ-KN+#HRQXYYEfrX0;d#380?4f^`!b>O6V}f1W6bM8^)+GI z+HAzu*I@UAD;F>pz4=eC36mHZlEv*0Mnco~?!q#WO5_Qh+f{D(ZYO=OzA?_lqNs?R zB?&{4L@vinKD%-0r-fao&Vlx066CV`wB>b*bR8JmoyrPF04n_{-i%4ZuSih&|HIfj zHE9;8UAAf4HY;tr($<@{ZQDkrZQHhO+pM&GYWIn+`(j^o|AiH?R>Yd)8FLcz?Lh2| zQUQ_xjq@QDxwDi9kH(h?3@%T@+){O!Bk*W2R3<|Z!Mrx*zuqU)equ@R)Mv3RCWc_6 zD{_hyip*dQM;F_x^X8oTOO9NSYX(jVm~t3(y9+W-89Qcb=jRHkvD)x`mV{vaPB=@X z1R)V};3hdXg@&CT3e(6a8PvfS;l2WJsV*Ca=F_tuJ93G4n}#YbL8UNl-lAWmnJX+zL4_p)^Sf&7WoxJ2amrD(;LUyR zpZWn74BQmxeT3p&w&;whfnu!OeSQ^nKC~^SOrBr{)3_X9^5?8)M&V4hY;Mjqwq;x}||V+B%7M0JC6F59HSI6fUU8=I?7_Aa|vJ<(iY-Vktc@`X{>krMR0 zDX*S&DLOiPPz)y2@B_RJSkoi@IJ8F}4#M>!pAI14+!tgAm@hgobM&^o}i9dOK^~{V5V-a>^)t>4c*>TMlXLcMIUVO&gf! zBkK@*y0 ziY7X{k4!}Vy1CI8gEASzfKRj;) z^Hgx8Kfbbo489b-aXnT^1MKEoV9=$n-})iy2&bSKDrkKYGr%>${U7k7P-4>1l1wcG z?a*o~W>wW#2ERx&JV-eaTj$1dN4(gSl~?|b%RhZZujGi~V@Pe+(xR7!dY=h4>rc*I zF2%9KeU(b?Jb}*porV3SeJ`y+WNNOfP2D}kn%&hQ9*Unu{sTv&slyXEd-cu8^@dz{ zyv;c^lp;pY*&9QHar#eB$*tQ{dCnw=*X?Sgd;`mnK;6GWAk>)Si219v(LHf0}X9-8zj4{x*0XFC`9l8Ta4k*9bx_h#l#DH>dD8n0E(C26w!MyS?RQXU1# zRR6bK*ftBJYZ5!`2N!;V-V*aze1*WZvh+zZIV50M_u;=~<5pM;?VOAcC&6Rz@-1`y z4f6A4|GbD`PSlsw4dfc!si?_==E<2j(ky#gh*WK3{E1K+oqW?AD*(N?=IZA19H&!- zN$dg?81!>Bsp0P&;-?Gm2g9e*dWL%{z>$mqER?9y7+<~;`Zr3B>QG6k?eBq};4|=4 z&;mhGtX8$4Tf#4bku)=XlQUKbc$j1mVue0%#NUe{@B{&P0h+XMXz0jRylTeAqR?$8k~$@< zV40bG1YJj4=iOp`#9!4geh^(M=c8^%ZCO;>+xcdhGK+slxubn`=Dl{!#1BZ2Ow z8x93LKZhZT5GtUv?~t2gnV(qKl*lRfDSd-QZTjLOm{kIDzj_@ss72YZC*v=-pV+<+ z>v#O+jlgX_&+lJUt!anaOahTYsC-AwZBoTIp(smu(A#tZNzYzwv^y}vcb#}c;t)|E z7gad+D4MKiH*D(dS3BU77EPRo9m{QxTbi2Q2G;m~R=H{-KCGh&eb_0!ei72!#i+Do z8F2lgxujHi<1w1Dy?BzhDz@~nIyfaAz{7lucoS|y-3#B zQJROeZ4x1@Y0{>WEvpVa*CG#wf7qoRaob?`!FX8eb86v$*a(oOi~dvTv|)AHw9ANL zPP*YhDW*i|G~g?`65|PbH5*QzdtV|~zEcfSQ{4KtiCaDi_Y4t?z2tt?5aKNLFY%8= zTej#p#uhW7ulm3}+HPy)@rD^Gzz5mr?$2gnu`C7jz_9N&3b-G?GzhM}*MuVHQzs%? z%J%*eavOs{R_K1R^AuqW>X|$C>W`;$S2@`M3N?e>dW`v7lE@u{@MQCR3$NU`$0RaW zKu+o%U%r{qx8D2%2Gy!IcB>QTH{zUg-MdQ0j;jiW;BKT7xiN@Udrx^2ed_QV4Miy` zA(aCGn#YBVDb5*qBlyMoEaa7W{Zp}g6oW4|NjL>mX3)Byc<<2=tU7>Va4+lrkf)qH z=1g8;${n~mzqoY)1T$fFJ=$sINBw;iW#P^6Rr?!C4?BP^({I=o{g>-%mOxrf1ZQLV z4X(=012)?^-$!=E>J&F@uj7R*zK_h;4ILp1#V)lz`=42RiHIKnSLpAx*P}bv;y5C^ zwHk{gUTllsf!bX<1@#4(sB)ud-FwnC=>6c<@t;ll`<%(7EB%60Fm7Hr$d{=YyLgr8 zgW$Gn?+!@)XEfs+CxkQwP~LS-2lOR0j7;<A7EEJX%;8J6STq^IAFLfUP>I zt0Ihb7->|R$N{vsKWh_&_3#q>BcayNn7y1rMCJQwon#t~&v==1iC!GVfyaWR6j7&Q z;K^&=3$p8AIB01tzYhjMTj`33$luo76?=@E#hZWry}VAJZ+FDP2Yx`%SSs-UP0RkL z{F|MV{eL%tvvU47E&I>F`v0Al>HMb=+~teE_kgQm@C8l2G(gO5DjY#A6>l^$NwWP{ zg-Ya+ed0K_CZ5zmFUK7G9s#QygPlZsQh0Gij%^j@3&9q=yWe(l$U^7B7c8RuZdOv~ z?&gnP*5^|Z&99f;Tj1Q>p7m`Wfwxn;jqG1hx*XHjpKlR97hXo8AeL$zqDHRS4Y|_Y zJbq3MyZAG`JRa`8_surynH`(WG1M6)o84UVE*1y5wW9)=Vj%)L25%3?nwY%3h z1S*QHE*e)q5B8RS%_lq7a|z{a>U&z^5RdON)gLDZ%YQXpf3PnpRc!xk=F?d!zf6Do zjRLQ@sQsf^WhT)(Kh*p}K4+GY%HD8v+ESR9_ia3nqH1nZZ?2akf_i>Qru$5UYQ>&q z05s}rSM0Ldh{2{c zH%+^%n5wr0xe%s}NokFSkbrb+ID>(3Kt|G#w@y#%V3mvx`QwO6;KiCgc;nC?!fOIR8J`zEU!Izljq)MxFV}jT_73^c25J3Z3wI? z7e$MIT(tP+O!%qUc2)|VP?g$_aC}p9XNPk6`32$bc<}X}wMT_-ML>0eM4ZogC8?vV z(pS|yW<|Li{N86D%2-Mn+HCbp!{bKI#KJ@c9`0>(EdEl3rI~tyK40_AU$$18n0&!5 zn}4nkaKBXHxVcq-6j93t6jnM>u9IKTW*v#Df&1iE)99l#;j;Zo4jyuIjJT^>2( zE{A7kCvzofm^-ty&2u!bY^T(edh=4e;(9@?!$l4;a&&gIK7?BPOV+zQ*!{Zsez8{5 zpU0x_T5e)yofY8_BpsNsOQN+zT4=@%oQjm{j*P$C^!AfApl>c-5SI3^4PLcG>IJ#a zQUKl@bzVRQ%Ktp0pWxbhpJgfHE9?Av2IxK6=YyU7$GwA61yIpwan>+u0c6WRm`%dI z_rgC(*U^i*JCRkt>Y!XVMxHs)m^B6QtpEDSYs*?E#iG>~&%f7M^&F-xcRD{gU_G%M zYlV#fY7X3k4k9nsvukwgg1O<@guj?sG8eJLbcfB>p{)EYx~au@u~h_dkGN4K>Xsb; z{v@Gq^6spLK;war-lnF6()Tyy%+d<2MJkcyS<@!6M%r~5I10^B(fb4Hxfj>Aa-nbZ z8h4_go~>CQBK96Y$>6-1Kh|r!<{;TTFL<_^zH&f>kWngyycAfV1_mnB0Zw^lW`2g_ zqOOoK{*o%gn}24SZBzX=+Lx(dp;~I?Ny*vf`s1mOGwM^4kmpLt{Kc@)7c^FCOZ&~^ z!L9t#D(!6&*^+M5Y783@?A{f6iuPVkoP5n;)Jj)X__N~zokx~u%mLNe=d-nR`D=a2 zJ8lmFY2L?ZsO28}J_OubM8 z2wVkj-nH$(aa_i=K3V!6E&5;7*61vD6YfI+maQhzZBLsqy@a7RM^D+{vF}peaYh3V z;c9LnwkVU{x4w%t8L_aCLvbZ{%EE@nU&S5a2)K-uPL6G@h z?QfWwkcEvqKb)RHSM03G(dWJo2{QPWEXC+4_kr;cC2tuT^FRw-PMdAzbV6k$?d(of=Lk-N{VM^(rR`UEETrq7n?tNWqNxz8V#r``CWWKd zywE2uFeo;sd2?Z*B4atq?LU3}f*w_FCDnSU46A0?Wx?y>H6fR(y)1=n&>+F4@Uq#hobb!F@>f1JHSOeeTx!Rw!%qy>W z9NHH)`=5AB+D1~Y@%N&r@U>a15H%JR8D_lRzN)%N@zSVS>C*!x_rPTn2fDR zE`kH{z{a8?EBp=%fiDkr-4lM*rLXTP33C7f5$CA}S<}o`^=_5%n=SXOh_uoXxVZk} z*r4tVCNIppColvGf{HL?w5LYo-p@mU9(w@b84Gh(kyv{PYl0pm2I8ePP;uAne)95T z@84R$VEwXvPJ%CC8hXsn{)4YeKQcwvFzMRogV`>$b{C+XFq@vUuYcKWzYNiu?MTff z5h~wtx~j@|wq5VhDR{c8!Dz$7Q%%oQ)(%4PMxECaC>gEKQIDfD4i+{3LMA}rP3fzq zO8mD6GaeP&xUF5^MXstZ*?$Q3A_>2vd{Uzoqkor>2#l*4PANMGkn2ELQ<1VF!PHrT zkYE1?K4n?d=nq`7}Dh7E5J~R2!U1dW_fDX#q^w|Ln#TXSiCfmQY_JfznzrD%P zJz|$-HnS#=>GEmwFNBbtc>tbEpU6zm8d;ROjM{GXsoWwOAEb zGM_6deCC%LqxIH%$Ilv_d8>^S)!dGOklSp^0rpB9p5Ig-3B?e?wKv9Fv$T25rr~gK zj|AKn7l05ssqN6({MrdO69`HN_j@`W!`+3A&NMlwLw7@u3X7OWKX9EUi=GX;84YWxh)f@Ht|rkiT~yqvv&6e?-!zlw6+aj%~7^p7`$kR zg5X*EcF#!bE~+Y&3Hvby`LSjNV4w_-IL-ScUnzy-2t#a5NkrT2EDnH6sGV4#A^jcO zPp=}m!05+M$pl%_y>Tpn7%@C_r=)%}KG7<=W{8*SR?A$q-@?6P318zTflYiRS=_t+ znN!4AsK-TRxiQB=_;(62UH+0!_T&_3{C=`1#X|j*BlY8J|EayQ9h@3&gxe!vFeP|+ z8lbO=>(2G`iwv1D)E^{sAsIG+?u5!Tr$~}ykd>Z!eaN+oj z@I2J)A1EAZ7TMp*DJ<17EYe6n9(-4Wh;MgEm3SoDEa#s&%v60-dMLnHnP$YVLr<|; z>;Mn$tNEfd`oW^P_=%ADU|13=@;By5iU_y4{|Un_{w zZ8E1i+uuH*eH`34%<6NTDn#orjmEf|9k;aA=zElnX4*FDI0RhMgFtVAbtDJG8?9)uzaE5}Y+z&Bcd=qRld_ zxZ=yfN`xAp7|4&(8#J|Rsv@mf7JLok;?wosfdBJ+QiOV5MY)E4WXH`vvaU`B)psS- zKR*-~8lXJ1z9$}3M?a35W!ZE1nr0g) z5f{Eh{|Pmjqdyzu(lalsTI3B{s5hG_o9Zsf6blB79)r!$AmOAlvOJZ%*DmV+*r)KA z#`;?r5gP?QWIX;AAbBbz!bbB4Zz5SOT6Z%Y^g@AT6>`t4g{2VQ!`ff0F)f85d8){<2RGcJR{UCSU<)k9WPEEc6` zua%Xq09Fw>)(0bm1zT-9OI1oW1Ai-lFro|1gvVEMhQCKx>%5y>YI_hZlL#rt;CE}ZWd<&s)#om*u0E6U%~@JY5(sGE+` zrlc4w{0W zUPJ1@>-SjPT)q5cI=7_M8YO^)@&3bf*5z~x2-w{DG$NH#$vXz+H(aZT^VQK(PYv+N z>Y^gi(;^0`PRX;w0^3FYacBmSTzfu_O-K~%76Gz1ej`h75wDh2{$V7_xMIaA>hcZNT zrFE~9y+fZfd1$sNbO+W}&nT=tKfT$zoKBw%G@poZ$2H2qJt{%r$XB7X*I(EA)i-&n za^ONw(somzy+d~)UENx%j`ybfDV z*hO1w)vl}Hdc0_Yy?i#bPqJ|_Pc*(>+T~+zvaNv{Rz;Y<%MoOvi@icQ>CL!Q7QpHN z7U%4z;TOU4&%HsE)Yw|G>S6s=O>ejaof-%X)A1wUITOL_+JzzXXk)T2OwMBtXrfSusPC)Fn!c z703lNH_fd@MGawP(|>kq)1DeTfXDfX+;M6}{+yC<4rZ%d6EF>nF4-oH$cWU6XQyG0 zMQE|-4vdaIWt-p*Ul*!8!tZPG?SOE1`*1bOpWg*17b3`yy@j|Vg31d9XmjB_=S7@b ztqR+4>SIKj#?H)ZW^3ylTnDTlu&~N43*P78J4X2X@C0IC{DY@vU@fS~Nd8Hk`#|R; zPU>XqzIQ?zMYPOrP{By9&qo4$Jiyd?`yWP{uv-C-BdV@dcNv~w=FDGKCqPG~*y}R+ z#e{&!1yWQNrs%$W4n8>fSk^ff==3m)ZwWAhK`eQJ$B;i=_8Z-=?llX2_mA&1WkKKN zx9z4m-T(S0bntxwi5-GuGX-@tzuU7$Pp&?OcTbKrwtFy04azwi^13JAEozR z$hH_f+n%$_QyRsLyQS&9Y7x<`?jP$D(_NLo!+*rH3oMUT^l>zcTK}G6lPtK4kVH+U zI?Q)!m=Ft2#qzOVE@Z`M@Uv_A4Hz{#s$)}3 zpzrP=G2mM)1PX%bUv06@ZYO%~4~N(jB9!mGg}n;3+( zQGz@Qr|83X`Ui*dC75l;Ok?RnG6T3#?I1FGZOx1R4Ho0H3)p?QbY_t`2^9o@sydoV zT+2}Z!IxNp8vc-V&T&pJi(4F`F`+V>)-h)&9hPAC{FEDG^vVQll8?I`*r>_=lv=Sc zMpaI0lN7Q?OW35qmB_(k*12Uax{{Bgcvow?M_K-5B&kV`yqE_fbP!qb{OF#9FQMAG zeg|qv=GNEpXbN;xW2+V39eSghNrWK{t=WBS%jdR)=y@{pr_baOVUBE^B$pS2fi{() zEdbO<5_p_e@KK9Iq88we0m(ZeRlR^8a1|-@cc(8Dz}5GWh+W=;;;%{n zx(nHP445GC4V0WjBg~NsvHBcqQEuIcZQ)%y-XK?)I9@tyc*Jl}iJKCZ(p~My0xfeE zx{j|WTU3n@a5@@=G|Qw<^NiceAPi0Bt0H3kd~naHS(-kut-CX$zgW?^AbR+0;$Uvi zOnoo%n84uO4S;@897}V;B2axAy=Iynl9QS~Ig+H&kCt-8r?QirkbKSAK90A9Ef2Wl znaBtHd#;+Q;khus}yF6q<}ZH5QGg0*C0Lv`hV zJrOCpQS2~lqZoB4KX|zwWv_-{nVZv{ZpGzfT|U)^KvFroPaTmIO?a?nqw*W`Bas zC#)YzBEoy4AMyK!g;raVx?~jjP&dIov?OM6-e|)(6>TY$K-^@_s z7Yemj$tQPjPN`Z2ZW_~TJn{b?9Y{Rlq#iTz>1&|x=_|;bRbm~qd+R@oKU{H$Nt#OW z-lv$UldsVmf<^+;#_H(ZpFyeEwVs4;&Mk7}B0=t~VMk1OtrQTJR>7CXAa2#IY@n-Z z>FxI{Hk4$ezm4f8n!xPlCR-I+;9(s!;;j)F|J?TWW|572_W6zw^=a$wG9{b+6b7ge zvY!$ijtFS#1CV$11GuD>Z)jWa4E!}f^UUjJV*b`fIQ^68Tde(TSOFAFD&JZiikF#+ z%Aams{gG!7wGL-@ifAS4mCGzX8CzyO$7`UfWuWj3Sd}%{hFIa#PqWy=CZf~uHJd#V z1hFPDsoVc(+ZdffTWO56v<`=^7)nX&iQ6Gbp2er}$+I!vC+C`jql#K`Cy1A7{MPJz zu)*IEtwf&IF9O`m?Pt)I33Z-d^Y|34v}3dFk~wj!_@N2+(k+N&*iya^hhh~$3qIWJ zxA>(jh^tk8f|Q(5KvTFJTJ(KdJQTv!t4B(nj^noz%d>5P&|2jUG#j=k=h9{8ypm$T zSc$vK8c%%jbu$XjYts-uXr#&wSX}z515d5475aDkk+x*Irui>4JK&aFlhazA7&w0OMv3NGzm zgH$j8(wW2_w`nd@!S5JNa!0|4POZNy(~}bt*~gXXsm4!}Hzwt!lTXFk#R`o?$(X+= zkn3H&2@RzZ77!Llm`NN_i%sOjs5qtscA9o#G6bo*(d95`Cn0<>9^p~AwP`aOORG+5 zO*wrt`vfoP*V7_oxI4*R->pM%sfo9wN!Z{5PN`z zzCUnxFzyik8;tx1c>Kp0VrOCb-(8bz%>M;O*jWBwz{oMamD5(sU8nCbTei$i23`QTC02<|NBa9k-6sa*2Uu;a?^hlq9E=6 zC`2&-QHZ#Ge4BJ_fIUfZ1pi1sO&%_BN36Ut{qn8m(3%J0*0fuZwU$2g zsa%QW)w9tL`QiNnIe{N+VrCVFflSQFfv@`$cOk~J9{PRta#_pXP`?Ay-9y&cvsFd` zMKkER*}8%_w)yziu#v5f-(dUQvoX2;>iGRltYSoJvxe~brugxaki8?|55v13z?f-p zXeE@_0M9;DcH?8+v=Zk$kK^joz40jqMYwscpQ9hDdav6ii{qAy*<3v>5t@YiZ59j- zW`!%Z_nN2yE0X*}1Cdx(0qb^zOG11dQnhmPpY#QP#7 zxKy4)YZI%sC^XJa$4C{I?CJw5SJ!a&G!w`Quv1-oyU&vKkIo5L%NSYXazq9lm%if6 zq{O(NnZkI;ZFEdkx9x9W87y$4S!2qH$knoj4iPf(ATmUdh-@xZ$Q5B zd4vxlU!P`H+a>|;9dO|jJYOQ}iuQ?2T9=|ScH5%rgK;4uy}fof!Xcc$!6`cY*+uNE zHStD_2QS4>hss6%eP6nF%1a4+&KuWDQ8``fcahOAsZ39uALJKTNvh0u-LiF|P?Pv} zrr`_aWQp6E(Ct2*A4~g9%|U+7jg(@$`odk%j35WIOIA3hU3(7+rLzy+fB4OO_^dGs zoD_LzmbK1antw`Zu-_d)>no7Y_;Gkb3(|l4gbxh!S z%hsPulmJ7mWx3j}YQD01DF*869fer<6f+5l@`#9S-F(?^stUY^TsCGJk@Vw9(elqe zxE7wN;fzzO(W5imAR&_QEKwuhU9> zkCiuo_6d?emntXgQ!Nur#O zQeN{Cc>yGPkxSO^-~6m8;SO)85m9xeN=_JXk zg~`22Gg_c>2HtLc_R!(G!>WUZTEv<*$-`fV9>Bvi9JK248V#qkz`W{RpJcFtSK(a@ zYfhys&~=;6rgq>8aDcPxDaRL}LVsv0%Q`nI0QFVj1K1S{h((K3>Qx0w{?k9YR zw$T39M@Ch~uk-pFf)OaA^e_YIn3tgx_t30Yyv*TPG1o#*8qL<~QW=i45^!3TwCgCQ z(ggB(3|=PIiIEkQpF#hV{u+)JG<=UaHvHUI*lS?}ldF7W3H$>~J_RYq3hzE@d-vOw zo8y-X6S>3pxVNpITrIz0E_r*o7}=0%)Qv5vbs(ikhl6K2x#6U>uBgK!8w4>j)U(O> zc}Uz(#;{-s9S$Pa~c%A+WGFJFE=NT?42jg$_Zf-xd5R5VzeSo?fxgHd8(MKUWM%f--?yrZJh{~lpC01|?3>olVJ^N(p(ma_%2JA+# zY~I*=FRb9%c#COLj1QEOA%qXCFjXv~LE6(I!6Q$PX1{zX$VEI?ivXuxF4T3=QOfY& zURmZM%E(mI)QFq5Q_eN6rl}6b}jH8ut({ z2TsDBVfVEhoMQYV7~u@RuZRpWRimgx zRl!0B8_T!r93|RPGGpjZ`b==8{(kLpx`YJPd{FZ^D>Xi=(25Ci*`B_+na92!JR~Y~ zIw5m=^|D1L#3fn=`NpMau~GMHMUDZpsItjuhdgU~9|f~ikO8{D;)mF*&HZ=C9W(Y< zsH|02`hLIDgEl>0@WDkJCvC&`tJc@8n@|WBhsJv|Wo{o*?j90J=JPDae+&cg8z{fi zx%SYpZ^hr&n41$+As1`?6Uj6lgOys1%`{UX5vGVen;hQ%<`;pjE62t zi5%YQQ*K_5IB{O~98F~eHD_6-0V9=>R-i$j+Kid4{je+4BI>r-P5Gz zJ!d(u(9%T|2+B;F5qFHasHk&0tc!$|+>~iV-6*_9mTX5zf2ImY{s+6W8e*H4LY5AS zYf5NKyb30K9_1T|nEh?vbxtXp&UtTh61y{&f=WkeUr1F-bQ=iFGr=naG+E;V`w+ro zgjqOR%zhlj_?cYW;>>fTP6maB#9r4)t{gd&fa3UzQVs9LR|pIQIur?cxXo^?bd8D- z`v=yu!B2l(B0>6X~Py z{LULR94RuUR6`w`Zx=I62vg+~$}OjgTnq=Vq;$-n&R5L=$xRTNWUE^rD@D%kVIi`O zcRth)Nvnr{p7T$NJ0E@(TH%p{@&mAKod=d2K;z>rFI|)oN+xIHT3a^r>RUcpY&mZS z&Y-+7m`JgBjG863isZ0LYL~Q+iuEUFBQABXxpaveW@aQ9keZasMo z943fuv5~XiI7a60r;#nU$x#VtPp$d8Xe0+5+NjErdX7u+ve&jvfvxj^J-HtoL!mDs z@BV;vUc{hZ1r`-~BxcN3MG&B|hneUmZ&?V>F#eN{sE(qqM{f{$cwowC?z82_L9j6x zA$=v$RK#5c_%9(JkQ`8g#2n@>^0){**wyW;pDju3pD_cpmN0HcL zxOZ5+0mGODg`tcTO8o~`ar%*u>C`@dK(Xi>84M)yz<~dS&tbBLJUC#t><|RseIXMQ zM56B-+GFftHY=m;E`%cSSj)&{mZuu(?KhZrDC}}H4!Ffet$+SPp34YJ|9s$cr3B0D zI!hm!HgF-QMUTj{E4Qsg4qj#2jRzv_)jCTfNRW-2F@I$)y!p4iXiOQ z`l%sEQK1X#yWNgVbC4&W%h85Q^e)m7L%Tb5HqNFPBlWe6ODs*LbT{Ku>s*FYlF0uy zq4bMU`jLk;Hjn+lGBBqK-T^<)V<6LVCViUzyH=_<`iz&<=rfW4ZSX|(CmiBsd~+W7 zxxejpjZ9A55R|CY_TQB->!i@`so>1PC)WHPHWpX2wGBeJ1G+D!xi8CA3yI)>AuDS0 z?GN@OOT|12YtOpFNKzLU@5e42I`LYc*5m>}SR@}Lcu2W`Fc7aJt@c1lP+2wmOLgqz54(7h{a z`4t3j*@soYG zQ%HKP5P;JNO*4A@bfJkr{6Xwt*c^9HhNLFQI1@%h%Ut@bp>D`o|5>YPQV zt87K#Xu*c|%Eo#D3K*@UxT5vSmqg0;o>jcN=o{iyNmK#JfrVt5gB&7w=LxsBQfkfy z6I3fpJV&?aw9fZ7vci9G)1`Y(sl7H0NVju&_DG+_OG6SwLVwS+n5B?!lG4p&Hrn=> zy^SG?*&-=X=c!aDo%O;$oz>0pkFaKFe9|%Lv_(i?n%YB=KScf~bfc1a3tTx}_&IA6 z*&fY;uFVF;8WDN5h`S^=qblOA*g(vKR}zs5*>tNTwP}qoz%X!ei9S&pI;9=ucL;@b zcNI8l=ZKS>`cBQq{&H7}G{vNGjt}y$EY*f?8<62cE#-!JGFgaOcJ)44b2Y8ys}f?N8VWBoXia{vC~z#4&! z&K@0UA`>Q;ToD`|J8bb5yff!Z3YL>NcV}UfE#{`omBkfSLk;aQRzv3`7iPjh_Q1X7x^2 zKj8GMK^^g=y=fu967UyVL!iA|v6^;!@FRZ`LZ*~UN*N03Jcc=)O->`Cmv!0g16n1C@LM^c;8sprkcK2+E0 z1s<8l2?M$P*5`GSm-ln|psGr)t}%&N71~p>xX*ba0p{f{l-Bt?0Q)1CCutVS;W-}Q zPJN?fXs%yFV~Nn2`nwRR$lm>nb0{+G=@6;iXcE8?j9<5d-aKm613BX3K5j4GA_l2w z5h0zitd2Vp!}lfxiC>0DCZtV8*LgiY48H7utvbZDP{6&BmL>HAeMx@`Yrh9ix>C#S z=kChI1+7*-RKW~Cua_+`Oc_0|44%{-G^3Y49c{aFJeB;um(HUW5C^?O2O}_y^VR9v z{3vq>khKhn!{VtJ=O~Y7Hpx#|A>b`f(#1y~^N;I2;OBSo4wE8-)JX)7lBpNIYB0j4 zQA;$e{We|XLkgXfWP=+YAk|e=*x+|4#@=Pu@a58eM^(# z6-y*Sz)qV8h&b)4L?a=?m!N>bET-WaHCMoWPPB;lv`Bjl9OTrC&$oOnGH6y#>8nf*I~UW~FUfE$ z7mfFnXS2f%96&Sln9e6$u7EueRJsWaGb{F$z1Y4(mx>7e%q`MyT=;4FX(zX%Rr9O` z4W{Pezg$pP@zGEQhl_a5c<6HMH4GI{2lQ!mOYs*yU)8jWrLE<(-fO^mx2D(ig3nl( zNCpK4oDWTZv#t;zFQ?^#6{x@@UOIO@MUra{I!@Rf9F$7gSN|oL#NvE;l;MWG-x7BY zOW%z*m=wA5^%#l93YT5|6)3-;>(xK=d$qmTqKHQ&0_~+vEjBcF=99tGmWcYlqQCzY z>HR1AV`F6gKhfX+Y|rrWGRTfJ8R1hJ0$2g6T`>M;Q$v-h{ZXM~xP zZlH3{4arbjaa!|#Wh%2DH*1)5US=CVNUK1bpmu<&YxAF=Y~Vk=`~fZ%$0*IN;`$xKp&ZhUN_7BC|6Y<$g>JexS{TrOMNB?NAv zB`y5?&Dqv5_sH$Q6?G=-&vgbCs4BuC_@pYEnA38vE7)|cy{r>2hiG2$6is$9)hBDL zJgcoM>H*V)8QHeYa~rmL>?LdioXtK9aGB@bYy7qYR)^VJ{D?uCtCIUI^0>>ts(E4% z4dxge6eziaX!wd=-pbDnzRg0w@=q%p7DR%}S@ptR7PL$p-W(MASm_@pZ+Eov4dyDL zdX}Zq>JmS18-VVW`=Ml$>57x^j?IZ1F-|uGE znN_Bknn3v`k5^28sF>T#yw8BVQS|r$QGn z##wDQT8|?#-v$N#-1u9dn?R2OM9PVb+XHW@NR?x*KV?T{x4@muNNdk4WROuRz~Dq7 zj5-rU>#Ly~6z(}zEjQ{FYnDMYQ8rHi{q7wa%;>!up7)c4XD+=4*aSMUvyeN!_fpOF zWup!%ZV?n_+{Te7EsM;6TeQOZ(vzD;LhrFA$sZ#U&W;2O2$CdA%$DV^d$fE<&*(2k z!|-6G6AcFDCnYs61z{J6CUFE|lPpQbclt1v#D)}|(ABI9J+QOgWc>|XCv9?=_oj}M zw}@Qu_^?nW$Qh{9!b55jt3&4^^2z{inct=v{Qf<7ExemkGDkUA$a=GvLMj$?77O+9 ze)gBak9DG8_{A@xQ2<62A2jrZ*}Gnb9 z@o>GN`Rny*9-pu&iT1$k!+|32tY0RVj+sz=m62NZ37I3(%orzbD=ON_u1Bzm1rY*+ z=rer%IVQ-Ux;0r4Uc3RZoMQ)~d{cf0en!5;o}h1Y;rFQZ-W8-VjUMr2Y!L^WncIfg z1pAu7@~D*V1M|}_)Nzb_Zox(Sg&Wpk2Lz~rH7b<~w!v$e$L)__1Rx3F!ZfN#q0sLB zW$B03XbRC90 zOMc3BFp@~PC~V+sFw2T!;b>KfM zh$o5{3W1mB9IohRguV1fK$)>|eLo`o#>amw3_SleRL4O&h+`q&MjoK0F_={7Mls3+ zbIMAYnq-Wb3;8*oh`r98h;elv$g+VPk{;l`|B@n;ZTge!2v+rQYkkB$->L&?`ii4P zwJmRcVWSFrW3MaHT&BLJn8;!C!*x&(gLu9I{^HKXlg<+_>jw@~`dG9Wlup28Hk*Lj z=NtlXnAUN~2IZ}Vy9>OVb&-X2ueCgg5{&cxZ7byZr?i`hyMRxkCIlw)mbnCfG%`*? zeLeghhOSk^Swsd*-dE=sq<^Clkteoi3WK0KyWD{P9%;{j6p>cC{0B76ml z=K8e`3|X)QQKW@v7SRh_C0Q_c(NrqWZ3ZBdNuGwV?L0?~g=dg(5jYiB2YpYfx9|~F zTxORo6L*6e7MhMQs{~hXwg`U8&84QtI-HPXtn$m!(lR4aa#sjli;)eV4?>`Bg7YZt z&0!EudT%Jj`h=nnkh)sRiq{aBVYrfXJ5*zR!7RjP{ddJVEhj7VZ{JFYur1EvR{F{bFpt5cCCEg!89$q@0 zq{TrgAp134@-F5x*k@MS&8oJ%sX30uW{S*gLGzC#mfJ5J`ujBK=9HZH{u~BpS(Qhc zvc6yOL5M7mE>TAvGHtz+8X(Pp2NrRSSFV0unEZu$eSD?hhzpxs4#Ht>NF{$?ennMf zpk!pLV{Bf~uO3dw5>Oza@Y=sHjBool7ms^7-NpRxb#J6_8;zA%*DviT@GfNxUK97Q zj%Q4h`IVW_6M%kplPi5&QIV0M$H0jF?iS?y#>=G^xzeNZ(9p|M?Bp$>W?jfAX01fT zz+b2k!o`JA;|ZP5yRW(bkFj%V7A#uQ?KW!Lwr$(CZQHhO ztF~?1wr$&1SNDzEFXyG#Pnc^)M$9iW$KX=$+{DYQL8(~uX*y!GH(PtP6T%e+@md!| zLw94%TL&%wU5;12=Ui)mn{d<{Fdjti-+Fqfi%wY}T&)#OZor_r$7NED#}E8clH`WD z$yww$W~O$R?cV8f8K}Ur^}tS-jbwQuB)RXgFpMvVlAx?RB6xqq3Pvh{w9Idlthj43 z&ZrOs8e1Oib|<>{Q;PCRRXbBE&@OO9Eiei!SU4y-bFZchJNwhS?>(s@t_)d~Wjgn_ z;)#PjZ&kdc{u#4MkJmkqQyg09Xt?=?*Oj?vJ8{7!}v}DmsQIOQ1{)E0fL~2 zGR1(2i-Wn5uNh8Cbv*QbBV=Yg)YGxYJSfbUhI>GDT7RZan3p27&k+$p$%UE2x~AOI z1ea137OkSz#2kx3BSee|_)ic*fS5*Xl?cL~>qwi)ss(hp;26uY4f*tV58`X|p@+aD z1O(}9ldv3%GlR7x!%R1*jF7lF&mF={jf*SlTe_!2QrK>CnE9-WG2OP_-O}mH3NQq6 ze5suUw@P`Vl8ORwqhhJfGUvyE^IXSKm-p6`el@pdj_CzjAdMTl`ul_93OtWDcoIIO zZ9t=5B@g`z)jMHc&@Zcf71V?t3Dv#Wnql3t<7KTj!`XfSjlU5EvHjl&LK>AwrUFP> zKFEqZ8@OjsCLO(I=y<(GkP+r(6MX-s3ufmL5764+|lsV*%` zLGfvYB<-|Zmu~ihn!$fpv~`a&j19|{QlX*gED;kRN)+WL zSklQ@Lr7-q+prJAb!0eqaK0)yf@2)Tb>zSw0V-^gh5OhlKWhDz;LNbj8=^xULt{mR zfJ4lH25z)sKDb7wBg$3R0YlhE00;O~0VE6L8|)5(tA-JgsUc8(gA&yqh#iT%+#@cK zYv*HXRpblu6g#kQ6WS#~_QGTwMuY8T5y1P08_sh8!b99`)lKYj0zeG~VG7!&`g2+O z-Yi~Fk47Du)q#%cDSQvFX<$RQ6K)wn`)1au@icC7k zc2rEPu_q&E?es-||6Wk{v;$suJw41Z zl~<|G81@#(}b2gy$4DvfNEDzk?EDLctEw zK;^8mLdFRMR#5+HH0q+z@GPvm+STrhJyBp>g_rSxbGX~Ei!VvSV?1>BVG8%XBpFIo zg$rYw&!PDrC*?t(OuvnK61mp0Jb8GM8@7k%_6xEb$ZmTKApCQ5W6bLn!26xTRI46!LdHf>Jw%1c7sC`KlfGw8lo=^pj zUJ7){3xEYY>+WMo4pQG)Lsz}34*oVeoYHaiSW%MKeHe7-r1uM@l>C{t{fRe#%*;R=}2oDlAc#0 z@}8OWfCVn&UX+8i2Aj3J3!8$jg9o2fjBCf{4LXj(!0sU+*MBm^=x=9@TqPQBtVEol z9bxl`YOz5=pZhyM0iNTU|I9xAJJa~@?1Pz+<$w3VS^rb9%ldy(>@MrP$B~FQ{&fFF zt`KV7YIJQ(bVlNg1pYH_SQ)L*R8t#kI5DQ@o@=BB4EueXs;Za@EBm^1<$_tm7j#g@ zjS=-kQyqRkH`pZiSTFXz?~hMLy*xC&?Xscyb)R7-{b2Ckos!Yf@%41Pedi4pTW0Bc z`FT8l5%NBFHwyu}oO>T$o0J}$s_N->cd={Z*8ZFxELKL<8V+t?x?yzLbluYG>6(`c zy+3+>EqbN=N{5`!qM`YPbZg(aiBLqKtN-)-%1D3L?z;=HTYc z^*(goEgys%G(xi;oooQQx_*2^53{rJbJt4!QStC}Y>J7IIUmeYrf<>=8EhSGgU@06 zu^+5x8=ckLhrN6Ccba<`zP`joVa5y{~myTQPg0s^A6a&Sb+swu7 z+*Yb`F@FPt7h-?5$;9(}J9n4-oK@E<>5fuTFg=Exw)?RK%CpR@!V4RB?8nYkDE>E) zMn7?1VkULI;TXB{PM2iF-~r<+beK5 zs+H10_>3X-L3<#%hjqsxgXiU~`a+kb%ki~^jJ>18>SKXtfz&@hqTcR_$u>c%bW|!9 z5^Gg4aPs3(WkYBco#(Tajgy!4Ptfv_+QVnsRNV8qa)0sk0Mq@|KIM(nsx)MtwEkqg zIoHZaA&}PF)ue`Vp*li8nouZsp0BQhcb z=Ou>`y;xrYT98gGcF7^GiNJ|idk{-BCp|NPLU(Z1!?Y~pBOHf-IO)BXsI{$T^wKqE z<(VOjWjwpj!9qrBj zj46K-X7B)7QL%8$r7W*pR@vQDOqTWoNB|KzNP{HY$Qt+T$#54^u6ELFy({WjsFod@ zj|(W^5sP@Zhd*glHi#`Ly(~-iczRk^n$TlM&TP1xP&s}J4o9x)s3f?aBuzv>Kfb|S z@7FXl{k)?DrRZ)y>JiCd)6HZ_acGumW@mvm%yT(4vL90i-iYzCE>)Ka7dTipPRA_$ zs)zFERej8iQ*d~o+(ncd;o+;y+9-OV$w>BocEk!#1t=*sq>`JmWw6MP!-Xb~ zCf%5RET6DOTX9wOU1zgKK|wR>Be$iu{Pxqiij*zWj93__mTA`Ea^BmAD}_7%wJO z;XMR}M4-G7G0*lEE>UXNC1|b3DzJt%ygugg)1ux60xFYS0%)x4!B?RW;=XG6{wP5- zo+tbtd>=ysy`V}R$D5;Pv9oJ3X;8suENN_24jx#+8+Rw3h#X$2O8!L_K-xF#e zd^*xHuuY|>;-vT+EC-SZ7gZCk{5wb{Rzd7MuX$@4;~SpxMbe$RQP5DRiwVf6q59+O z@GPfihQa}JnPjLiZ%(UxZya$CC|Q#FGT%hsr*(cU2s%3r#wZhG317Got(tF`IPULMpg}G@IXPq z>-5Xh{^9Yj%_z;QxT*P*q04({lR9d3GdiA?9A zO-T@Pp~cw4pcyb`k0DB3R91t`OKxnr;&N7-iB^u z0+6`tLW&(4mtG5a424Qv`#78h<~ouj$zW-Y+H9rPF|f;<%b8yDi9CXkVC>r&gAw9C(EOoEAY-vv z8a@xfm1u&)PHoc77cDPcy(}2v{&F_`7-EoFKy0@{;-V()HkISxjdOXTF=S|~$4ikp z;NnVpAPvje8@X53gVs)BcG4h_<>fk*6EkuaY#x8w9#JBP2=EV>O+Ci~)=5CzAw&nZ zb&G^jG6vM$YT}xCKN^VU$B{eJlWf}ZnJNV^5{P_)HkFPbOLatu@Lr3QF?M=DdLR?5 zq(&CaPkuJN*+-TUj3+*%S9ynpGqgH(UY#zvY=x2vw_ff3xX+H>&u1YEUhh1qUV zGi+*YlBsIDOXs1D|xO#e1zx^jN zb74B|(~qrPS{m|TXjOV++!cmennx&>*PQuK(BcPLVguHVRwSS36?1&P?MHEJ;f?2t z%%uNEusdEjnXKu>{64tX=a9Z-k=xvz1o?0>MFH! zdGk4 z=!NvHv7vs?D7i$vSOqUtjc^-1t7`RJV}x?aJt!+YK@3=o;tzNgO4EABc}imGR+eDV zcrHR8;W8@!qjQ^Vf33e}+=`aXs=?AXZl|Y`I^cX}!Y&C4JWx4hL80=DIWAXe21?N7QUVu@v1hn+bT{Si9!v;_@Q)$F} zL|#N*P|`3H*n7v_ER&zi!|lr-#+f>_HCOxsAb3#GlWw?a)>7><=(`chGSsS)tm84Z zpHK=k7buY2bMC>nSpz9w-hrZ<CNf+RBjjZ+0)k*t6UEH<6}9hyY+I>})3y*r0e zu;S?80cS1A8z;q03MH}CWQN}J%!;$Da3|=?sL(rRSysdL%OWiMY}+-57s>888@awR zx<-X}V6Y>jcXKVPKTJ5!S=vKd$beML9{6F5`O(z(DmKL1gvXT;Z~Y8^(V)pfXU|(8 zmKu5S=#tWPI|SkH-)eY9T8^<^NcRvL31mcHkWIy6rB@bN9_Xh8m~q~$v46Ezpo9)# zGVe&XVaYe#2c^kzws7!K-*H>vsal;oWoS2M!?RlhoTaulmYF7;suoeEsSU2M)Xz;h zV^kIsm`aY!^Z}9crFKvVb{M?j0br5WY_Oqu3${%pC+Q_8xa{k&ik}pZFCm_Q$t>yO zf}NhvFr*va7||hH(xbtMmCDa6lHlb#opWL=9{z56;79udQ@velL#Kn3Z*f0OHe5qv zI4K-VRX=nF0-#bU87m@T5^K{A1qLiZR=HhG=@^tE=SofUe&r{8i5d6uGq{)xxh6H6BlQ8$w=qD)13otrHM8v+tvH~$@Lb0O z`RXiugT8DhoKX1W2TP=EDjqo*1mYmuw0NVN=b*(&uOClQCd46JU9{7Ry*^`bH=I+d z1dVS!Nd$fQA@h|7N!73ye9{l+WF)^*YphD8sGcg#7jdDFgfT9yY|BBMM$1I3wrt;B z|2?WhRsHrW%#il{FcsjGLQtj;FWI0J_$$6lCQUtp@RnWO8As^L{^wMiW1PxA^&A~u z;>&(xYqrLYSt}nWF;3P4Vz_{D!cF*K26>2t0o6;N9M?PLvX~_ZmiVkaC~wvgV0zG2 zsCAy3Es;sOAjN1JO6s2?1L(r4-><)H@S@55Q?QZivj&y=P6O~tS^=OnZgDDcdwT3!(YL_4YOoK4JM*cV{QZiLd zQztjEP$$l*9=}DulfyY~DWmgc$9uibbpvoUY|`^^BPQ+H7cw%0wB1*vSbLiWOqeQX ze5f)o;PtTn0$iP?V)BH=J0`kjMi#QixJa%C;#`!+)AIuyH?T>|u})}=yHH$m@>%3E zCa2rwAK9e0FlD@rZdrm8ZG{E{x{^o4$wqQwizO{asWPoiSBGU-9#z{S&m zXba~c+sVt$gTcdpwgkD>M=ok#A`}9tsTIK#!}z;xxA)l!9ND zgLQ&fv}txD)eh}5MO!tjNvlY$tLfx(@KjFI%^Uh|QnQ86BHAP03&>T({hUHp{MuAO z2-Qd(xFIhpH)o~9qI#C8cg6zO;>yH% zjtu;ImU@}~`J)|{NBF)AIVvca18QcQ2J*5P$!(*0iNf-E)=Vmu{^Q$(h3M#xjJ5fJ z#$*P)rG!l_S*bENo+YbHjguCl93x?!L14p6lsI?Ua8PO+@}D_vcLe^ab*ho4zMOtk zqkh3ui470cbbJL$xffUEJ71-$r~&O@iEHi*L$n&YD-`Q&+!}g?q{5V^WPh(Qvwmnu zsr7+Ala$d$i7b)kfyEOaF%%MtBKgWE?Qsygsqej!t&)Z3&!+gu%q=r#7`JD6+uX(@xp6 z{6n0By`2=SB0h|k^ef0oWB=9(DB|G$wPBe0ikgFtM4b=MbI9J$v`D3L6?rFSxCmaW z^n}sKK}4|89h=~Ihck=Q(l22(DTjGVbzUnC{Y92-$-CV9p28sz zTGx~U)S$_iGGRF(;3E~c&pIyLLSf_lE4RtE^LN**j3k6ImpJK{?2qAJys{4JUVWf3 zv{>hYA6rG_dlU;`?S$uaZp@)xx$>P(?Ae?ppO30Zq+brCmcYgwZrT2ebCBz_ISm!s z_)4e81ZXg$?%cScFUfcDg*mBGKKX;VR^>Ye9$&td{RpugMMi}5qF@rz3{T^3?MP*k ze=D|DTl)|RB2T~I-Y{*0B})rnQm z#UhC)qMnkchCw=oT~M|K+}&Ly$6a@WMv--w~9+e{LSa6d5}h&D~&CGP6|@Kf*?N=3>zMWR-}BKhU4W4nsGJ z;YPCcc4|uew)ZI}GhbY4J&5(`d%1hL+QLa@{)}s zI&s5F?O8aI zX}tU+YX=CS<;mEzZ)e_=rlOJ~T;rknf?cx4?j6aVQ|IYHdV2`Cy(#@A!Oo67b7QQ- z5;@7Azz3$ATcHimD457F<@wE*bRG`^m3@EmihD@SB&y2CXnaaMkC!_kvoyEyX`AL| zp5nh_YE6;jVHl5#u#FC?gs*A0W4yG3LNi}qsQIxbgkIWnpvM4n;v)^GuIKa*y*Rh@0&k<(DqE+vSOyU7ADH8l(3wUl813B!qRR z(p$`rMe?-yMx?sjyXpFDtPE88R3Wy6%}MXE`;KRVJY8M%IVd~(Jizy7Sa{BEm3)+S zGs!QPDc8sc;HVx>?>%DV3ukDz@s0PK+1ch(l!NRkZ%ZGsko=sQSwpmH6dK0E;1je> zSYEUHL;Zc$$C?ZM1G{2vg7o!taZveoy9?--SXKHTY5o7C@c%QZ$id3-|6PZy|LHnp z{Xe-5uXQeywwW7#dHsgRVS=3+I7S+t>kQIqfC3IydiG?OecPJx5~X$1j2W>QH5&ZB zQ>-Pn8~hr)O&|0t{R{4}wW?JscM~;#x0X`OS(`uExVgO@l18Y*|a`Vq3Dd&wp{Yxp+S2 zfozQ{Sw$x$FKr(W$`oQE{CM$xmo$U6FzsV*REAaWEO3* zaw;zUvVUH~Fa2r6?D|@y>aW>bC?0MBHd|~fNyR4d)cS0PMZ+snK{{-?trt~MWsHhK zc;FAz$B;CdC7U1GR-Vky6tb^eiZeHwMxVEl#L7jULe8k`HPANgT)nsodf2vKEQmk9 zw*i`OhhCO#?WkYH*B|xpZj4D(%rdX7UU!ya=r_gg#a7IX_NiX`U(jAVP@4~Ibgwrm zQW{b>&7KZDgpbB$RV2w58QI|=W76&iAKwUoXW)HJKP@=7Ey27^;+l7Ihgahujt&7` zmJ!>p#^?^yW{u*Yi7-Kdol!fzTedL_!sDN2g`k-+((#natqbgUs5cZjkoh|UIbx~3`3~(!6gPu2W1S5M5&ul z3}>>hMxBUTh+dyn*H}A6VJMyPN?hqSDsD#Jr|nr2-=&1z3MNToKV`n?1;|_4g?((P zX{tL=%~xWs%+d3HjjN61DyA*nYd1Ne`Z0hNTox{8y~t!pJgq=uvv_$|c1OhK1K?WN z-1aSy@@%gSv%JVUY$=ytL|itTLid?8BUwoQrZ_;jJo-ulxZMA9%bZ4AWdXpE837F_ z83F+bLfZc|NcGZAL@HI8a2!CE-g_DXi&q(71;7Wg=`#kxb_Cx9m{+T|9R~yXr;XDe ziqQgKo0r)PW5ArRgM+f)DF?ly-E|PPF;L*BsfW`v|2gzs zZHZ9=EJV0->O^~Cb1VIW*2sq0V)P!*R3Ubymi zKc7#3A($DL6AW`kc8}{->1n_; zF(h!xaRY(2o{b2LHC!ltjq7&Ug(Io_-jBc^=IO4UuPn0kY^`1O4`R(Ze7mEUZ7gZ<6 z6hx$QU*EP@m6wbIA{Zph<8f!N*Sag_kh#3((f(DgyUdFo#FZLWoIkltrk!G$zwqD_ z7qThN6JX6F>10!<776ty`_H{Z<&u9Wkl4Dx;r3>-i5`Da9L3GZDmoLDOfvfuXl8|0 z5@HyfA{6n#wDVupG50$n?QER=SQ=XcC$nE!mB?io7+i|B9^5h)go2FQNH7#H`7Lam zXAA&nd99v!SPXkjRoVI*6fz_MO=%a=_|j?kF~@l@?T~|)6tb}$+Sx_qS7EI&iE=v0 zkfW_IJ-;w{aq(kVLBu%?2h~ZUCw%okSS+I;js7lrey4L<`yV6T0Ic(IbIm3k?JFS6 z>fzsvK%8W!0r-6*!fpiA5e`9xXLJ4zR5&d^BQ== zCrfPpqYm46B)k#adJd4#LaJy=w&|z3IdI%OFHt=i-tH%NXS}DeyB-)Kq@oc{x!zE8 zC@5yJiHI!~I>cu_+pJ7zShalS#M|yFzy&sIgge!d9ROQxDlBKEI`%7hdNM>N>*=zF z{v&%SHkqbQdPuV!LsP`XHKVd5<{MKNm4nkwS9m8gp37D(Rj9Uxt%0teOFG3j9*ya? zxGXOjHn#r4`3k8=EG4joxm*~`BrXTg_oXW|*yG735t|_R#pronK&^YBm{?-0%QS_F z5Dj=1I2J-{jaMpw3^Yn#0fVZ3C!&XT9ev;ejSOaB`cQ!|e_xO5LR4C(jN?zqBYpVG zkOj@oo(U|X@&K_h$RjY|nqvM?tV-kp=MoxZ9GQ&JS@eQNrr9rqGQ&dRNDoahnhrQa zWn9+F1txE@?(up1lkon7^-yw9S|4)IXJ@Y9)s;| zfJ64VgZbX@+FzQW@NaHdeU(jOR1U4TP%2kGXUGZX8?y$E$dg5*Al)p@rS4RI7m-V& zqhE)qr9SlPb1e;jO7y7i3=Nn#trL}(jq~^!JE})2cvlGc)-37Ag`C1F{xbk~5y>?; z(%o`XNGrZSHJ?*fOUJGdm4U}`#lNo@Afx(y{h_YJW*bJ*zvatvV?I@L;}S%2kT_mN zXfs&VYg%%r>%mZbZPf~uH@PmLQNPnxoCiV&TGi~7kshLZ?HSRNcv()2#j>b(>$po< zdUZj7evT?zE2+O8K@rey=b{5t*-^c){yPy7x*TwwS*<78wj~|9v%39Wyg`7Jq(}<_ zQE8K*j0}k^ol?C2X58YphBAM-f$ST=*17W@56Srofg^L~Jz7nzF$0Y16te%lw})`s zPdNf^bK3F&SYZ0?C#U@SG;R9~-z51-0k5VGx6Q0{k;t!2!FB7}zX}N+pyIF}NNP!? zc!Gq?RI$BdxuN@Fy4I$tH5GlHRc+kc2zkb>Zr}jlj0>~5V&@f?qv=&5f;YWW4kfgq zOVRyZIjDTG!TU2Ce`~o-^to4>QZK z`aF|iP8D@pOEfbQMOM+$^71}B6T7N;Y(STGsTkc;Tio5U8@kd9{oU+RNQe?e zc4I7;b@hAWy;V^ok|(;tw1c}eWIV|73Q;=mkiMDb02n{KGh6nZ1n zHt^juULnPc?hv!{P-SMXyK2+SXC8Ooe=gWMjb!R1FBw~acXCxfDh5^LKyZPR7r(4( zHYAf`U&*tPE8s5QfJ@e>M%L?oHLSEPg>|;;KlXEaycSf77!|wGwlsEhhFOlISS4X= z)~!~$oynGFk-jM7`q402cb#T#dFn%sYc?eUes!WqS9yQMF~lv&PC3-*|j6Qp}y0*5?@6ZTG=-9Rhs zXTzDw?n~X}OZyzZiE9LKLNBVe!YOet_L5s{1I^<)-@5fupV5Z3&5EP*qS=U7c(yuK z+7Ts4{wF*Ab=C#k3%5|!O0hCj1b!(V@ROK#J2#JfYe!!}9(wA0l9>D5Gdvc@Zj<6; zasK=oj(_Da6M~p%1!geQbZ_?l8_n9ADYEU1kGYg?Uz#`%=-@#ZD0{rOCR4&nFsE?T z>>o7^Lk2!`NiLimX5((COi-wOoIHbABvt(a456Cn!#*3kuxVgqxC8QM*hW}+1xXCE zFwha&elD7v4VB#kkABN5m-iDsl8`xzp3NfCMv5KyM3z4TNqp(;@ue5Qk4)Pq%8A@~ z^X@RM^L_Dp8&KM340>0PI#jEjE;TFVBLrUkgVN-U!_Mp>Lj66S+qVPwdl%%}iJ%8K z_-(~5b{wOV)RQ6cY_y%CK*%-aD(qfAG`)~9{X-o zuPG<*GSK_2MDyibkYqS*N#yt0Zz*gggsJI*S4Q+4d$Ie$BOPfvBn&Ye;6#p%t9b}u zdC0*RP$PYPmhyl0ToL9jq;+%w!m6}4J2_%_&pw=q76U8qWxYcPHCE~0d7<}=jxT&a zwc*GDl@|OtG@=Wx_*ANYn2t^LKQ=N!i`AHX#)H4fB4fz<7tOf6^=X+2xv&on7N@~-IFNcR)0zZ^B6c7$^`7X_Mdw)2cUkV_>m6>Tnl_aIbNla&!e&Rx#@-X{j1={n16e z=Z@J_dr?zZ2vGmNfS{(Q?x$OOf^7pjDq=5`J#~pALr!s{bANQq>x0J z_nrw$&A1eEh85iemBNFB1dDNNwO;s?*)^$FKd$cYV;Od&V5!PROuVZ(c&^SFWth(u z!z;#V%G}e{2>SZfd+C4A3MURE&RDV);Y?;thn2uZUgkm$vTxBQuB_B7`!ae~$#-ji zi_FBP`W=Pgzt-Ia`3V=RD>{y)5&8mAhy;m}bHsJ|Amzvzh(&;kH^Iv8et0dCGvdQ= zKPgKIP`ifLfG%K3Gr}Bz#*D>ZgJ~ixtbBf8wq2NT7NF@=70AJIy;xKc6|iX!W66X= z$Av&s5jl7)Qu$*zR0(}mxTWfC$bU0X5zpU1l`Zx?)h@*^n_MeSh5BQ0G-3`o3i3Ux zIFp5|rHw*PygvNDIjMNkaXq|oCSgcU@r`N=B^m$8BK5``z2PQp`Xp7+=kl~Jy< znH9?$_;8*L|D^3dL7;eYWHmT=8aCL&I)a*&lABC6Jp2hN6k6Ko1-8T4MIoyenUNf6 z0lT^oQ;7SK$7dAA_3V!OTOk0t<;Vg!x{5vPrQCFDUE!o$J?RFh6A&cML*NI_#j#i^ zD0&wm0~z}@3!07UV)$_$9XqiK^l*zOy}Vm=us^6iQKqB-Ebx`S@M&^dw&@~sfYJW1 zno4@Ys2~c#Y74A{W(|jC%@m9f#tcI9Ms1lsn+4al-*^eiZUB~6r#YOknK7P+v6ZDr zF@D4*E*`w@Z~2W*nt;bl*5zunLzX!eg=VoME5bi56_CcwpPzqbcL2so)h1<1isgVv zS<`5*?s0t+xN??<^Rlslrf}vdl>Wj(I``S|M?lQzWMteyulF%uQd>lM@+sSHoL zAIfukL&}Zl)s=eOt^>V#cZgm;Fz@7VIL~{?*35^K72Qs`_$6bNp7F{F@+(7yQ14y| zf9pzGadq-Wyzs_x+F)wFPm1yELKi11=%-zf?S`ZH1hZx80;QnyBA4@FWd2obzq=Sq zoX*`HrtG-ZBVX{JN>t|0PSwHb{&0_@Nm8=6_B%+QzMT)rVAV@ex&Q0%d_1-;S=IPy z;v=vps*z=;zF@&vt&_=>wDC}s6YS=RXG#nsgs}}RJ%L^!q7G>UY9V-gMhoB$$8@fy zNYHMW(F19bE>)ri=D559M%dcx9L1Q3=m}*v=YLPV9Byj6wmF7VGS8nt<77~PQ0{c; zA(2r*L2~70aqfxQPQMz}4p>xj(vW&l0+OsIbZ6_R9-JCr{D;bk#~l7>iQr)`>iB3d zOj=ME=+9y@Ur{iJ>|1<~Fq$G6r~S?HK4Bda+>jIuwbH;9_G4@s35Ik@ga+8Wijhi; zeI1DL8_Z+AR0*b85<7!l`*83&$z6tL-n*oDIfc3d zl5zUs6iK-BAOMQr90?C@>7ZpH+!}}JpET50XA6fFhnE;euqiZ@X=FIJ5a8)Le5PI< zotByTZMqWEkMoNen+Gad0^)~b^U|eXJsg^6y&FLE*2bjW{L0sWxM{x zVBLO>znJe-k00{oZ)n~l55M)<5; zcOMV&(ResDGn8>{VBTdrRbf_+fwq!e^afe04akHa!Nm#1QnJF6-X%quzXc6%v`3BciG zL)Z)0hA{2*9?kG~xQ&pc?7dVnbI(+}7uTZQh`RxvHQ$QE9aF$Tb{$-f=Ca|iT96uL z9u89BNaRv7>7td@!1V_rAoo*kfnUAEq_6MmMO>m!lY=`7+~y&H8`k8_lB0Yl2RZRK zODtAhyW3f?LUO1Q=+q3*gizs~*HrcR(yYEwZBqH}@$gjEE|xcUKKbv*sID&tmXGb` z*pyj$jwtO5LX|46F(WCFuyq@-;a7wuqSYyLq|>)xrq zey@)3$a>W7{T6|}zu(?Z2EoaGf7DtLg!m+_*x-8jAk_}bo}U8O&^NWZ?+Lkak52j@ zldem=?)b>^xY^%Ho&O&#!LE9jn=j!XE#dV2tF)Q$7egs)};E3ESBI5H? z)tPJ2itJm}#T5PLvp>&FlgyIA1F1Pz@sgoA`Av<#8dI50tLy8;zbE7$E&&d+1K0Rs z^L@uQd$Buj{Z6DcsarvJ^IC+=lLWlDmCvO!KkX3R){bue`Op^49I+67GfW46m;JIu zZCmzrz^7%4zQ--R#bd^cjL0XQCu2shlRpZpd4pG?iBoXj zCA$#4dbcO|6z!PQ(pl5i_CPtu+4GZ#9_snM;qlwN3j6V^dekS^~L^Yv2d3|yk z!tP(nKZ(APu91EF$4%~q@X4&DWm4_mIdg6Gs?pMDXL@z^ndDcm|CDQW!GnC={M}#Z zFP58*-i+00|CI10cxKtg&PQ>k;thsvb8BVX-RjvsX1k5_0N}FyZEQlw<1fXNNt?J} z-yHiOuM9ZX%jI_ey^XRkgH>tFrDf6PY4qk&_a@GVXsG)JyAfhM=N=6kvj-CmMGhuauztJ2i(aw&t!ZWfpV5YP#MC(ZxvqTYnTY%a+%GCDBlz~ zQT$5;UUJ++9V_%vxcs(Je{to*0UG+*73XoduVAY8%j0O)j!!Q3Oksz+U~f@U!jL#7 zxeB2S4d~5b)f)7^Q_tkh@P28cxQ}^irtG>JlgW8iV4Ak~Uel+Uje0^r^()n21_-!m zz6Q@5Seautx7TpH$OtHjXPYe;y_Kw67B|4Y`<^ihB}2)=r4IsS{p^AU8T=#DtV%)7 z`1|n?b}GzmF8N{E>nqYBaO%$#7jzclAh2jdHeXjBi35T1=n#SasNllX#q|jMU#(KL zW_`LsasMrN@*XADAl86Fw(q|xC>5=pX3UXfnQA$h4XtkIAwz+ELn{#%t59oJUB~v9 zw58~`jEHIy(eMMHD!hV*FNdTZ9;fyNKgZG6E+ZQ=knC#*yk6_jLJK{j(PO%cJtJ5r zkzFOhREckD33fVCc~u_dV(t)=!WJoxJTsg6hMbmR3ToP4;Nmm;Y+ScN55+7q@z*_C zfU#ao0Hx3YLyCKQJ|r&>(QgEyK`HKW!%x3@SlmmU9?$kk3&itc6Iw>p&9jrGuz=(R0AWCN47@(uwq6$1}*%g+0XGjM3x$7ss8 z&B(OCYeDMEtmfxo23x*?zi%yAp7}%g$Uf&$;!zKppVxjal=7C%8@{Y4qmX3DG0P?q z!V5Q#w5Tr@VqyVly?=7X=Rf}%E9tqSo9LV2?sqyqlL$57I_u9!Kl~L-XgP!{yIopA zVFmXLIZtWXEGOodj?Wj$a-iQtyZbWm_-Wf*-wEajzlO^>kE!G2rg@!t z=q9s=bIAyWUWmi`X4mm7AYnRoxVe67{}J)#g3XEEz;;VCZ0m`P9+%?l^-)vFoKE$?2aLK@=44K6MK`Es1sP za2p;+H~IKpl88ySs*=H2fK-og=8d~F4#!y57v%^yAHWV)|aBd%>W|`EKH*y3y$O7#KKE8lMQTwS`-N2GIXQsD04P?d1jxW z_YBBCbWJU>IrB(pO;;n~7?|d{34|2@b{>Oqda6!|I2Up`2+hWGU;1ub*}mj-Cm}Q1 zpC62ttXA|zRr2dbs;w*7EeWJuVkH>*juNOqE|Pfgis~pbeC{wr&gPG$Axj~8+Rhf8 z@*OV1+ZM=*iOya^M@oj!E58Yn`C`^3dz3y&GvJpXr)YeWE%1Vvm$cM->lSUQ7vU#*5TMZq>qRkXt$Raq$G|H z2S@sd9AO?BaHihiS??Vfg`4mcqaZ*1-7#r1a~Rc?#EXgCqj zrDro-YGF_QPXt;T8m@OpDYgtY@?D#jRJu!4idOhqu;NsD)r(_Purglf7PiFr9qi0X zs9XMzg-rbi6D}dc9l5r^ojq)tOj1VE1>-2K$G}8>sRWX8c%EH8WaIht4{oWqHF~@b zBEt!$HOIS@QjIrFkx&wegD!+u5C+kfWd9$Z*fyX3=Q!PN{liX=nB;$J^Hi;7h5k^) zPaLTo2h`Y@J^?P}UhXNpcwu9BQb82DsgIR$ZKwDXRpEUoBVXRP(d8XjNjhaIFp$KZoKL*>cts3ANS`k_qr$p1!*&w4t+3OvjY#bZ2l!ZV zP`;5JONg?v)UKm_Ct^1UaKUj_<61^4a5*_O6feE329q20C~0PWuR5z_)Q6;VOiZ)Q z;TnvRRfwgk_Wp~z_l~#e+8Txlf{n;gquagjwR`WqpWW-(z4xw$h)xhCY7m|1JtRa# z7m<)eixypok|2oiZAXaY-sisezVGk3e|&!&)?91NvBw;Jj5*hwhi^SND~aJo2vM_0 zGmwYnot2k5!fr0Tw5REuWzFaPAV0^M+cA27>gcaN@K`UvNA5fCD{k&`r>kYAZvSn{ zhsA-E!Q|WRJAF7E`^C(?tJZ$i@Eto@jPL*cgOj%&2WIQ8wF#p>YqXZIxfSm4dG*zf z*B%Vr{;jKcXK$AgU6Rx8NgA(PG`#Q|ag~0@m|L3Py~$(OHRd^A0nG>_q7mX9sQhZ8 zckh~evNyb6-2b5X)wWp86E^3Iz1wH++SRJxQke9$Ui;PL_xj8p@0@mbj@$Ir@Q<{v z>3&;~5P#DTLOeE03KHJr9H4_CKR8@skNX6gs)5?42j?DtwHEpbuA zynL>?B1oHNe95*S7>61(qxFGtx*aHLDmvNX&3%=djc0aYjMOolS_*pAu&(z<7I{4W}qTSLsw00K?+w8%T8yZR zfZV^DhFyNxed6VL;||D=F4}vZ*skx+$DK~J5iRkB)Em00Z{BW4+4kD4uMQgq30kuh z`AqK%uR)hit!p!Va)%4n?cMjz`28&NEy;)5mt%uFzCLtf{>sU%8%)34b@;vGt-f0` z1>3yY(0#48ZM;72h`Zg_9Wn_o^!rmD`v5QNkKh(Ve-QKqS0}uq^^+@%ue$T++j_X(CovxkxVt{KrrP76a zVo`hdrqcU5nouIH>7Yh(@Wg(~pqO@ZP`L zyf^Z*8CR(DPYmSVT~U$#HtWj5G4dPVZ=Tg`?XOes%TUX{WKRAeo_XcwwsFv*?)joG zw_WS?Y3t;|#khXcL~net8#D7k8~NCio2B2@edfO`e7Ndrs~=9?J3Fx(tz{(8`GIFf z@aC+RcV&=b%Of!jE;=nTz>7Y;O$zvQCXYdUNnk zr|ft#Xz>1)!+9aq!sb`0>;-)jgf)oQPF-wtD>|IU;6Qe;k$p1bF;2JQ!jyTZov|s% zkGH-{**3c6T?)Z0cCFZTe*cxz!2;6y4zy!-($d|Jx*iP9{qfe}W&bHR7~=%Q5!xTSa;ER zi0;1Azt2PW^ur%N8Gcr;q&I#*+NJO}s_S*_MnCYzQkUJW6+0QdzO@A~DF5phdXCyW z@!pL=2S1!MpMGo9;D-Bu=`RGmXCE4Rh0|vof9~z8+xyBQdz$ophrDrs@^f4J@pq$* zfauoEKaN!FmF@lf^W62H8ZOwhc6IUH?PmXurKy7x*XEBE)yH5>8v!kj9QdrCH#mxI zpS!m8Ci7el&o!~>gHGzU6B_M_<=ul!US{MBToR67RGbA3?|bxO1L=~xt&iLv-L~aQ zFL7*J!NvV|va%iPxFOgOy!x|Yt0;<@dp`U4waaz)CYNR|ZP)9=w!xEYW`4RsGO7Y} z+>P3OU_C7K<6ctNQP7%k-&*y*IZTUnKO0(}!0v%EW}r`pfca~8m%qC$CyS~(s)~Od zq+5Fui;go_gZ!t?-uigQ_G@bof43R&<+?fdd!lyDc)Z>+TXvitZ+yGKyves_!&rmo z6NY7PP{1GD=u8}XT;mKLJ?!n#jy@(}D?&3W-v!BoZw@{g5xM-1tqeQy{4=Np|l@ydb~vo5goo9=zzr2OmD z{f+gBnGbQzKL2S3w#8dh+Fc?;TF63!ZtoxSji^W0jUP>{>^-{oA}pr8cN=+0+Vj+q zFIK3Gg2s0rkZv1)an3sOcwp8tj9z|s+>wTtx{+5-J6ot`O=L?~*%nVa_shD8eH;Je zdGGaUeLj~=_5@(aAN;$b4QT2`|^F8 z3or0%9@QNG>Z{G)Ei_Fzvs}FhwdrSbuyv<-m&g8$LR|Z7w)R5P-&vEH*XDF@vds0{ z;gLw~bi|JvPW-%h0&N*5{c5Ybo4p3t>~#w_geQ$T4t)RCg3hdNip<3A=ML-EF8TP% zZLea_I~xWslRfs|iyIbRP`668AK1lZ>T7K|W3^0q-?Y9>bIzgu8psdx8pglSqq;VO z&Z+K*{@&vQ*Y@A^&Lj_Pw_XG+^0XV#qsQ4Pix|02PQCNy>SOaeUGMi^U+&~DKi~Lc z`Sq#qAKbV*Fu&LRhEpCAr%c=F@B2oJ70o}{^eD>z_3c)O_hIdr`@YLM){B}pzG>R6 zZp3O?-EDk+`oq(`Y9%|rdZ)j(N3gMq_qJorE;HkuuavMY#}>ZR_e&2No!+(O!*L+k zwWhE172>t|G-xw&n7yhr+0CUu*!>c*NLTh3gpTR#7Cq>=mJ zVkPz7+AYS%YkczT@87kN?;Ll+sa#SVhY!7WZSKC-C#ieKeOv4wpR>3|Ne~U~{_22{ zXTMyiC8^$cTs?l2(DlsVoAJpv{qTmP?XP%;hU%PymhXFI{rw9^YDRo=ZdD_fxXY;T z4}Ey1yfJmEaG-Nv;S_A;Nher?O*a+7sUI9ve70eCd`I_zXIo$K5C`0-IURp8>DKPS zLnQ(c`DXgU;2-7%{Br~QWXwSbl%3oY)y zG%`Q(xPg1o@9%e&_CH|`zKzx7gRX*ZQrFX)_$b&`Ae;!JKt=))p&Imu|=27XNGfEzBcwZ^q5!YuIRDr z?68!1=rzHyRl$`j-H$t*P3}tNCnHRk&V2Ocr|s3>59;^xt`)bo=-mv?eP%w1}CD)r~IOKK#7-&fV9W{&WL}cRd<=rqQR+-tT{% z-UVmBPQ1OC@pG=I>~wm>8?$~N+6>(_Jh6F~k*B5&kyCeVIdG0fX?Nj^RwIthVEOtj zZ=I*aCN+O=yKB$*;ORbH-=%A|hr0ecec`$7b8jwqc=77*jcZolZ8iQu?1qKV?*`}K zqO&)ry|QF<=YgtbJAS}!9DfVDd*6u@HPaiX+tE^|Rp-njUBAzE`{=gES9oZ+GZPZqx~0_U z_@Hh_GeZ!gUZHeDt?zSiZ+ue;tqHGkct{o(q;)9WDP^o@CgFWGJ$JU#Pz?-A>s%zkw7`h_kHmaiy$ayD~*z{#zwL;4X9FJJqi z_NMg#rLtS#oBie|pFE~sC@=1!oA6t9)oY5Q$L5?r-M#Mn$G=_wqT$i*?$O?NGZ&7@ zN8=Tb?VlZ4zvxhD{iA53^uk`NKWV=*=x#T-$)-j%kA65t|9G8e^>2s)*e>G5zs`8{ zDJOn((&f|NOxwQn*!rb+8{E0xclTIrvh#Us#}P+v-t%>}oFAO}^6{noP}=(&f4Y}@ zP0i46&OW)9U%z_jkq5tD+hJtv=XCsaYSV8%JNZ%5Q#+4L7W8hs>zyAKPu-DU_)3}m zP~Lyg^zT32v(et{VduBDcAj$8(y~E+$9c>pCpDUi|pzl^>3hKO~or{q(hc z$1A@q*#C|5VyD?hf4S9lYLUA{iXD6H+SRGs+VngoUq!nf8#`i28@s7y z%+C|WU83VZ=`d*G?EB}jLw#2k;BGk}Ls|?!So_&qOMVJ-5B9abzi;NIgB?H1>}I#6 zv`#F0|MfS2c(SVXp7PAG8_MeY?Ul>M7KiO!G#~X=yKd6!z6CwD>L_b^1@?Wkx=pvO zx9{vZKHx`JgA}i+LD0$7Wcd~$dB=nB+HX5HB!<%=cdPKE7<}7ljOHhhF`< zdCxc7uxIrc9zM%%jA=cvYp+v-KU*?ym~xy)_Dg&9l#a}(VoFUHLt$wf>fJX-wIz+7 zyfV^h>Fl=OxFE38>ZZ0StpxWLf3b1O*`d;zKWkP`=vkaSt?|HbE9-yUdwr-nqP{ZP zRC`?|l=snHkM}UP`{C-YzJ^8LCG?dMn;3V}lfQg)wBe%lD}TE5?(Lzg zj~?E)u$zW5Vb(G3p;hY!jhB~#k|y`Z4ZqSrpMJgJkw!hXUHxflvzF7|9$d42(HmqQ zWYCi>zNXX2o(-kXY}dZt*|2S|)rEap<5TyiZtUR#d$L~42(r=SzF6j|%`ChM@*E_$?m~`ol4`&sfc*ODUpDg+5 zq;1;4p|;NUaSM^+kB3;n?~in9e*Gl8U32rZd%^YHmd`uZhq~bd`}fyoOXaVvKl`TY zqk+qs($1?OyGHWXXxCPT%zK3DKft^!y?V??t5tg*Z96kg_w`U8$T%%akp2)j%Io8e zGin;m-i;c~x%8&J&xOjG_vf8`6}e;dt?yUQyHk<$+T1Topko@}I;m~M9r?A$Af-Sl z4#VC-XV<;`asMIit}g86C_<|{GU}Rq=KO{Or#5LdriR;n|7Q!P-wH;**4K>x?#b$K zWz3wZpLg)-hoxtJykgWcuc7rC+>m@T@mt_?kMyHo1HaW~PGssU6>wJec-zF+F3x;n zKKnteyTzY6@%fPO_)UQcvc*5Y`xRy%e|gW*Uh~fzhAVBzPh9X5R}WODQy0{NVQ$`S zW)tzYDLa?EajT{Y`E4qc6q#Utbp>+^-ZaStDy(@t(ss3ZK!)s@TN}du*3-e z4*Q-Z{4MGhYyAiFuP81tyN@}v@7(^wYR1PD+`&7bh2QO5ew)gcqzT}8jo)0bdPl4+ zf8D;@j^sw%m054qof&zO1lpDn;KDWY25y@?ue)a6XD-QDAhGrPpb~m}*LVHlrkWmK zP}`g%!dws2enFFm2U3er9TzQndwm=H)XhHbt!2hl{L?X9$0@L-xHque4g>6bQ}6Th z7m#-isQ)kaTq7OZ^pF2q7TsC9Qi9_U(Je5y&LU%XBP|G?6=oG{r*YMuB%ES zd3k~7K%@|y@?g&h!gS>%{8*b|ExOm%ewTja;zoNvTX*3i>ItQ$(&X^N+gRSsv($a8 zZ672ToZQm}-Qxj zW$L-|?z*dAd~);Ztiw~4i`TMnL+hjhG)$JAaMpH@jIIOy|Wu#^9D)W?^)iyZ0wGdekA^<%pcpqfgSU)1BCq8wOD5 z;fJ2?#|Y@vnAy^)owhw*H%Gb&i%{2=Q+v7R=6=4l{V%1Z;pyX=JehCX0ebA+JZUJb z%`7&vIs3qp=;1&~rycj!g@9OjtZ|#BQ^sD8UHjO!=a{2yY*{PNEA#FS*UFez8%;hG z*%Ti6ZgIna+HJp|+=uvW%NcXWwWp-tFMntF+UX5u8oQlnk91R~dCf+XV8Wb}go7<6 zF7G9-oq2`5IMi?4CyU%QP!BtD%h_6w(9#m)O}fn(T~Q4{yCQXFsf!>hZG zOD_0r7h+r3zcg_4A#J-ZgdE#cnuXcSn=xWbt=V=~!aT22=O*9|9qM;x37vTUal3DV zb1!{$T{bD>btJl4T@X>_?<-<4xa`Vlu z-FvV`_VEMo8y%^RoA=uPWL#u7Zd5KlvA^;0Yctn$`{f+n@x$iJqlsq;8#9B+b@$H+lCv5n&q`mtsjnyB0u!!?huubJmH$J3MQv3eW!Ta7D zy5(B~nEvL9le3(!zD{m9pLnyygYO5Nd=n@9ZE-unFy+D<7;*P2`{iAB?ol;fpxm!Y z;xflRZno^(mb1QschXPqop~Eg4Mfpd!QgZIM&(;VDEnXU-MN3wmNM5tx$GWyzj_Mt zf=d&moj~JPekfkZ|7=c(xTXkiC!BGRI(pRO%{{+3As_Ul!`t6*=iL0I;l0*NXIxq2 z8oFVA=i^KJ6mPN-E)Xth)XwPeEsCV$%XHB)W!w;qhr7|>F|-A%o+oxrPB?GpDF zt+-fjbqM!9ZhP>2_=j3CzWDZSO?1UYqdWOa@hB$@S-h==*(G)5a@%j4jJM3_d%5$& za8t5i`QRrVHZ5v+e*V}l&Dh~-+Vh@P=g5+EcV^P4zbqKs_duI?Z$e}J&xv-MzcQbi zKT6v7@mjb8bjvmeAoW3hbFI3~#pF@mg`OjG}WFTb?qkD;fH-$7aj#JzIjUdQ~aZq?U%fMn-rP{I;_wxy#0oL-^7FL z3!T2X+y;e%JI2zoxV@Ju2m9U__6bx@L%aw5^+P#jcc-PSo=1{t;*5*y7??3iDqfT}EDRJf!u7{tpmy-%(xftt%TZLb#`1+4Zn(yN9pqej3rcXYcSuU$=*!bdeA~ zzV~HE@Yc?AkDXa;**dO)#m^eoa0mM5R{MW#S$kbcgtwUK-P?6<)c@_kUxul=3|Mh~ zcZ*5EZZq;dM)d8p?uQ>f+^5F;qO{M%e9%7f`?t;2ptEnv5pAYh&$hLk(LB_Q`*fVC z8@jc|PdLpz;TjRcEi=rN{$5NjUcbuv25!a!u5kUO0aw2^eag)An7ik3lYy8=Z*JLY z;qL0t>F5O7#4_a2Xw!u-C&R~c)O++O`^#$W02q@RA(Pj&r%9<*{qdsYY68i)eS z7wy;m_(s*NO!z^o|^mU=#FEMM#?-JaA)LGRqMF=%m^7eNKd)vsd*_wW1l;jvGQM`MQzAJ0tl zp|HvOQ*D-vIsW>bDO$Wn*UlffzY=@|`?lhAjdyw5bH&p=lDlVh66~hCDl-~4C!eMb zpAc*Wo6;9Oti`_KD#XyY&kxx) zXq>t$f2~$tVXbU&l#}v$uYssS-~bJ7OtN%LjOz8&B__W_ZAf&I=A45 zwVilqUCqgpkF(S_7yM+ZoywlJYmWC!2|ncX=cCRzyL{dJ&AOi+hAOXGu$zZmun#*e z9x{LL*t?28y6J-kjO;c${nhpzhiSX|4qrQOQ;;!h|C~{0zj*iBd%Ye^#C=Fu`axELwLMI&L+ z+zuMSzB!RIS;ZN*1QxsV3WCbmPU<@1?f<@aB}2rq73Zhb})nBGSV8v30Kha^p{5 zKeeJgXF76yi|ku%d)R*K%ZlwjQw*&-I(GKAHLD=+e(3lSa`~HyLo!WPe!Ss8({B#Z z4^|E|g;qZehRrNb3;(*@VN+)DM~O|>bg^~9e`$wte!b!+ndjM)#b-aYb->(QNd%N7i6nq7T*^v+3F z*U>LnJIRv2b)U$_wCTTc{(`f=Xgk?{H=e)sE^bF>!JS4NM~{b_IkJ;2W$z6=sU;4a z&~tH{p7Mq4nJc&6XzF3_zB_{UAlu(2oVNCSmvyG@BPMaeHD=DE(iYMOTYBIoteNt2 zPn4$rNYt_!p!oo^$=ZH1zg5nEJgEOKP5Qp^W8rj7F+H)bNj_}!wGXb`ztg<9;_K_v zy8ia*MAb6O*qP_QS!X$60Xub<&COpw-l%s|=n2ODA={43eIMajY$rwXpKC{N+<&q4 zV7B|?rPJqpRreike-qK@-d|rBKk=A#edDhWcIuM-dEwx&suro<{Z4uM%sw3eIC*4y z&yvL>du_kerC~_Sy4vQ`H-4P|?pvT4k9FTI!^;m|3~%dGxxst&-qjAvho(Ck+wf+# zsDXFBgr72C(<#j7D-~bbCBf1+9{~)3SOm~T z!ij)5*QclZ>6XVd7Of|fO7?&NQ?48+M|u*gZxtiia?ko2RrPkHl&cg&ky7CsUp5T6eMB-M7cf2n8vh73<{Rgry)8R_}H%T-AK z%jl5nw{HF`I;5w|HtSLR10V8Bg}MK2eCm(U`YS%TAA{1f$} zK4s5e@cHlQ7wrWt{^S?+1rPtwFWOTj{O{0*_JS6F;zN7E!{_)s6{!CbJ}+qT5UX?-~GFC!k4$OFiA7XE5r$t_f7{?5h7g8&th%H-YLc zstHtY$g2N6b5iwcYXZ@pnP1v7uTU==CQv;~OrUy7m_VMMRqQHHy+8HO@ZnE?_BV1> zUk;Q5>0InNp3i(xH6AGk!qq1|nJOCrmR8IuJ#01q3{7>ZSBZTL$$wUyjUIPB#K)xieCNd2~{sYT@ zANoIFS?{NxWBKn7oI(Oo>gn?5c0V6n!ambCzWF6c>)zZ>XaZJv@NvM7XI3LmAKzy2o z0}~=hIW0RxM9b4)GurErr|mRW4xvmUm^P!0N@ioUNs~7k(3|OG1Dsk)CKFrrO4A15YQORN^vdLlE_3#`bck6E)&SsCx_BVDO614 z%ei7ta=nQMEIDg7@syA~>q%{TmJU9JQl)I7SSm~6fnrY*pbfmZv?s#lc*)(9L?jZc zNvAAZ?ViZSdNQBcZF419ewyK0ij~MyU-+k%*T3)wuJu{f^RB>C%wII@iL5AFO1x-G z6VYg-ng>@CUpI&Z1d7F6?_werFMIw3{gRlxpn}D2u#0S1Tcj8cWCMR6Kj|5^^?3ZN z;WB{d<7HB+IeOI+GOAq}Rd>LuhS|)jb8hfR`p&r zbYWB-V)gIov%iq*nY;WK+oscyTTrR#gLsMCfHPc`<@2vq^ulq&_nEI~;T0OfZ-JH+t6x z0e|mZ4RMNzNb%q3ULTA6z5Abocp1WTIqS)M7PR~i!>NDz2gJV$?_cGU1Y{D~O6etn z)(1m>$3<(mD>OQ+wh~H&1Li=s^b}@Qtg9C8A0)LtI(r%Af2x>F$_q)Q6RQ&VfAk6(dzuwp5KYAOa*+-8KPEAOt7?eO1TvPs@hsNVNRys@_-vpc>vROjCbAJAA1NksVGvM`7b6iMQm6#dK)H7gC`EcjvOvE`F$Y8wy&^!gs(U~w z(Fe#?J4K$FUqB4x)0I-ys^|a*U;_aeAP=O0K0vf;RzkUSE(@f97!dE9k5?g8{YUke zN+}@x)bwP-fl?eOrJw$52La(+Ivpqi8o&kg1$qO$fIy~-S1FJU1N{IcP<=C!sd}lW zAcNKSg2g~66)D$`u<*R~Y?Srm3kTC6Akrt44rG8>H3)dBRLPe#@}=zHPjB(mS>m6$ z%9otNa}HK3v(<>k1iWDWUyWV;(|_MOfJhVy5J{&K`BI`(&5Y>J`102wJR9CqepSa) z|EQX6k$_0%DebByTt+?l>#a>Sr=$UaK&VoVfXGw|kgLCZX~gw8$lq;{LT7Q9t^bw{ zqCB&WFA?US+8{FZzh#5|qL$oJlNVB~jHG)-%85{* z-dDfuGhR^VuYy}22EI(1r?JqVVPd^6(g!k;|2d`f3*eN z1~bI1(4yH&C)JfOFbHZ3&4**jLU4T=%aWr52Aj%5HzfoGLK&iWNG*6O;J^``IXIEy zv%#@K6W%TZsiD=Gn*vQ~Pnh@|WGx~G@dq512s9k2)kK&)joFhVL;;ypmLp>TSkfC& z#qAM3*%1o^G(t(?$g5;|uhJ~Y*J410WFdt{WT_0k&6o36>>(L54%T|09C?-TlAu0i z#pRMYdKyj*I${>7Nv+nEiE@9sE<_NZ6g0OcBq^!5d4NlFg6t?rM#Zy3YGXzYUx`NH zN|7Rk3lHFFES)TaK&KHUY#m1$O4gzIQg^m2F?*bt0>q9l$B9gZRmrgFIIcn*S0)ER zoLT`S6^naqehc5~NNVgZmdnTt#XVuV%S2^GWSYE^mBXjWMHx$=EbCe6eA?|7M{ChM z6_e-J>JtzOpd!(jPluV4zSq@QOH&BT%FZn zbGgMTo<56Ai=AP)%8x)I5fT|0FXFMVR;Lrp2eAcEnpzxp3Y}>v1X7k7Ofei846o&Q zDkUD2ZL~phhP;Vi1}6c0%QMNcu~e7U$?O4;UZP_%QnpyMqGzfQwLF#u z&A}8hOt2MNK?Tt;eq7^^SlA4ll9Y-`4MvgH?_u!@=!7AYXNZ|3jyPe^XC1nfIRFY} zFphvgMARg3RAwv~FR+a)Wdav*N-fE(8||qiDQLgXnh&AM#2`H@)M}KpVufPxx)6F{ zJ`#)Yxa?XTJ0TXjL1?E_5r`%LIEhd|ncON)D640P3dB5~k1C|=bU=wB@#4j56f19q zg3UC&L6npFDvH{)NhN|rVk*DHL&S1L!RmK@9B+}Hs{{15h+oF=C=haa3>+_nb6AW# zN-~ozC1fQoC(v>QOr1Wf@Dbq9Ou0fY8N?{C#9AlHfGzYak4#BtNJNmSBIeV>0X z^A?RtJtoKYz})s~S)y1<7;p&<7l{h8)l@gpX7>tRBnXf-Ix#Yl-6$1P{C0L-UPBMy zr6sZ*0E5+y8GZ7NEk=ENvSESy!ls!6*H8BiAJQ7VI&D%Db= zHoQif#f5w@t3U56Cb&Ko9b(agFb1+oL97de#bQEU15W2sNFGFuD+m)ZoHZ{{T2&Do zfHkBv1r=MAEo!~cFoghk(dMXB>IT!o6$aCxfq@bDWEo`fYOobaNlbOS2tt=r&WsDm zI1bf|@YD&=84bNGiWdAOyT}tV19ZJC$hT_s96O-!vI9D08k;sj7$##XYsPRXAeBjy z0#xc8R%R1Bky;ZUXHW^{UPe?zb`nK!q1%;$5E%FrgkG%F@)>-RL*gV7bs1&UmX~V$ zAsDnGdH1y34`QOV%aDBlv*ft5Lnii!jn85#|X(@JhII;+Zp&?o2w7t5e90x@Vb z2&2FRc0W>t(-pAAJO`V0SoBymw9anfbCfE7imu9$yOnXS!hfb;n?kDK`8;vGICUS%wJ$BfUL->(Pd4LxF4cIA+y#Z z&jeD%%drBGR8a_;1k1>QIlXbD#D|93ETRHL0zs;D9;6_^fcr^`yw^%sXCzn?B@m<~ zG9)jKmBG;op|FDnFAK6z5Rj8uOLPRpf>uDR7Mj4sfxAo*z1OJ-Svffbl%Px$;1X#@ zLbs~8QEt!;E#d2k@r1`tfQ#`?i6;oH6Qaa^bUqIig0JzU0Z;vD8%XoCk~H# z(jF|7!c(e1KDjnuXW=6RMw=X-XJCqXBp+^o;CKO@%0LepMQM-USz(3>6+n%laVe>c zjiQ0joUSZb=q^E+4!fA05DKY*vI<0H0v@3=NfYJ04t^4RQoP>~I>#i&sxv}y@*s3=UX zK$sK^h{mMQQuXO@q0T9Qkz@dxgw%ux5DJ#=lYs-VSgObpaKa>~8bk1FabXhK0|P+p zJd$aV2@@f9v?9zGy>bIf%P;3@C0I8R3?zGvx%4o zEEZH!2BckMGbCVD{|J!9ShzHA4MuTHk}Dnnr+IOsN=&M*F^wQ_j7X3YHrHAKq~C!L z%SBNUGlBQ;vLb(-F`EsAWn7fbOmR@)EVwcYQm_RAsm-r)kW0DNhi)R3eG9}BZE;Ofe!UnOOoKk8XDiYGn@UYcnpM|CfluHz&JLLu;hzdiB4|Nxa z44+e9#DwWln2=R~U~LK`^N(TJNgi3@I(6eeC z9^lDk91y+^!I7gN0&S2`Fc5WSq|ijrNZbh`pNOeV2;DrgAt)CFy%+`B1BSC<0g+#B zb!9Y3A=sh9BZX=qitd2P9SV3BBw;G^?tF|wm$6kaI}=ypmAM(K6;?2o5CV^n$t;S= zGLym%6}dBPm4KnPQImBU5>IP2f=w1H+Y%H7k#%)?mq`mEtEEAiIIKpKqX3ZvmQ}bu zvONIy+4xR5J|{L)M2x7A03pVdDXmai)W(@~KvcliRp<~W2_XP<(pnXopY{sHevmy^ zF^SxGsLSpqE9(3vR7?}JSL{@@2c-}xBnm7|hs)AT7Oew;lqJ-Ke8eLUabqTYJdjbA z^lpJzTwqi~vs_LGBGCD$YT4ITK-o~WIV^yJ;%opxi7rEt9%eLc;MG~OQXN{IgcQh@ zx`Z)_BNgxwt0ij-o3#{7uA=uR5;Qo8Wzm8J=wOK_cUgo{UqP#vVBmUAj0ivpv9OyX zBk==*WUT-pArvveh>;2RiM)1*2a!qy>v&$K-ok*;gmh^bsZqGIb`UJUcFS`PJujv; zD`YUO&H>~xQAAdfPeB9P7{({A<0!J+JWrsrl$ZcNjNm)zNj9;{(EtyOR6y|}4?y7UI;pbaHQ2 z>>ws39tFiiZ2Sdx4sKwa43kh$ z>3BpEu!YP@I#Hb$NkkO5RlrK{sGbA_lmt-TGCQs{gvcXpx;@;3+Eh0*io$Nw^>mUg7}<+`%Bt#uh3P zDTz$P(WIR+4VbBw;XE-WR%fyMOiGuLRzPJ7mLdv~s#+*5D&n+wS)Q0%2BksZS#Z?p z1LY+KhKa+VhKq4~N^6AaqkuSWL~>IBTez5K2f;3pR?2c3JuX%lE2rj*Y`er7a@v(K zIg}$pX@XQY21!HLI-(ko-9zP-S?n~csBl?jhH%wXn}P(Yfh5WEDqcK4XO6277Bt@@ zMQbuNr%$M36G>{mk6yN@$@wTJsLu&uD6&jf=K|&BB5lAc!Vs;+RNNU2;&mzEr{Li$ zQbqt~wQ;dz7(p1IO3+4E1aFahKwdnuR_7#9aal2#Xiz%wUR5O~@udUMv{{RlO8s_~ zNyqWP1elCp>y{CLfDq{=RUF6!L&#yVY*P@IwuCQs_fQD`L= zONKElQPxFIDyfbIEb&R#1XXA?@SA_QMHM0_0c%^kjxqk7ePJ> zlb7VBoMA+at4;8a6`o8;};L+y$USDhl3_b*eycvVo@}Q1DQXkcY99!!U$2Lno*VIwLh_ zrWs`gVKpB2Ndf>JfCy~t1dwy7Dh56hA}~Utl{lFf%!mjTjWWxvfNE74l*NwHWbE8z zt}bkL!86s86*G*2<2Z~YLMA9N1wc4!1dL{z*HS8*jbOKn&+_`1xEK^hb>_81ml;-D z!WhgTlAlG)7?C9s303yQ?Yy!>Cvv;2%%Tm(%z|SWG1Z8W8r(QB)g}huv>4T^Ao0^a zN}5P;(`$*f!GrVRwag5zW?RS7PlfSix+Mp3YmfR+QvSqxDq6dK|>lQETA zlfemW{umcy1zRB^bT!X1IsHmEEoHYEtX#c00tR?75Z$jf2B~2YEJMXx3#ovpjt6(; zZPhw+!bWl^ifJD=MU~jiW(vAQj9^_31W635By2~|#6B^(K)MDwr+ z2wsta!$J-VghbWYy7i^?r91)v8Wm5(OaVd)@ z;^lb>t^p~<`HgCoQAe)x6eaw$Ii<*g)K%Yww&=i2DOJFA&_g~fOi0qxj21*t0MGjo z<$%l?;6<`tD%;_qS?y9xB1p=s#dK^?qp%c6(vX1f(PG2wU=9@4JJJzIm=nSl}-%^3j4#d2$D0i3WTvWDykILxYx zgCI1$)f9(lP`W%jTMfBLwO$|&(NdJ6IwF>&sAYu-Of^>&Lnbv?C|(7IDky9~=+3B& zDUnPnNrlX2U*2M_t(e%LV9Xv?b+R^)0dngI7_eh(wqrdG9;8UsWugd2@;_gIGzfH z(b2GYCnT9Ghg3#5LS_rAz-&SpUFK`NF)5O$fy#w>2Topz8KO$Fx*Yb(J#oHQM2L~? ze1*g#XORdXS49F92ZoLF6>9VHa@L89UTz;IyEak`$@jyekxCub;wxgIuXKe_QRua1;tjuQ`A8&&zVRIS!DnO zNr%w57|kIHAh=3anv>P}eT;%K#^Ny?L6^D0#G!~Of*DyCcjrx5H<^-k@cbgS+v10S zf?{stY2j2ZNTFQl3U{3W1Z>Xe?akHO85B9wHA*59+Ju zmBC9Wf)pCew>S;(}E`G$sUS zU(gZ(^ihs4&0sTgL3r312kUbAx=lmw6xCB*W13>hjPjZsw!UR0vOcvu!ACM2#Vu@a3Z6+jabBE1P(_LC*mZ6t+Z zXRZ)1Iz=KnDIE4np+rlyNMNqIPEa&KcJp%Tyb}%BiHwLQ42jB&5V8gEdG+2rp;B9b zi=nxIP%IE=0!FspET8HGxGANWhi2elH3Rit#)VmduETqxd;ZNMDpmxfP?gBn`M=NT8t0lIa$O#zYh(#Z~=r zs2q7(3hEc3nHh-A%PPvs61v>a(R$1gzzRxYeAS$a5;uwTxkSDYoM*8elBE z8iIiHq+p8@ia~}6Qb3N>gQ{h<3Q7ouh?HhHGz6y*4J@5orbg(^DGiK<)-d!2vLZ&a zYal)a8_TR7zhhXz7&O!t^clP?BC~3P@1Cj}tj)a$Og=#GrE!4^3I-Q}MRjEkk)U_lj z#+&wsFv&7o;>wu>Xqumj@r$CVELF@-La1V%2nb0{a+_SEjcK?by4A(>9K(;;5?&EB;AT7M zMFxnNrJ&R-MG_(8CfOLI8$tx@xdx0$rSx0aNo63HH`J8_+z{LgR^aNAo(f+GD?vy! zegF)Fd3A6_kpoEcd~G@h1;w!PVGU0;IIAl177!G*gxQj-pb=saBD6fD2a3^{Vh# zV!$nT8LBfy46i5wh%u(>#J?lsWQl84L6HD}DqteI3oOwTSkw}YQ9`iFT9A(ad6&y4HDx)t9{3i?S>eq?=I}@b;WVu=W)F`nhzPc2OS)HC_&{+RCH(I^< z^4w^B^ZDFpwd4OZJ6c@~`q$afr>pV)GCf+qzVD^!(U+F+{zucJOd5^;e0G$^AhZ5l zSQ&&6JmL)3VmIoT*hHRRET;?*71ig-O9iH+16;&lodCwc)K*`_v!Nm-ldm>L>6BVl zH331%tI?-diAX?X892z`VYrJ0OxBylIix0JfxwAX%*Zgg&W#V!fjWXG$^$aVs3=8{ z2O|)NnT$(CzBaNEEH8H$H&U7I=|P01JP;Ll#Kz`;Nfz=St#{r9cmkx!B8U% zh&ZO=xP1i>D@{#Ts2L8G zTrDVJan%Syoq;F$f*91Vk|Kn7A-RI^<{?@dp(4S?XciltsgtX7Iwc`nkcs_#3|+>8 z5LqD|SO>xcpuin`GSQeA+Qp)6kA>;0>wQ{8yaxNtJ#6tuj2afUMvwzG!~30b(m~5yFG$n zq7~q0}%zPuBi0swEC;yv3uF@59{H|AX+YrS- z5Q}(Q4dp_AW`Muj$~tU~H!|DIw?L}CAu5yZEL(QMyC}MJaZfVuptnx`ZVA~gLQ%_* z@j|;$TC5LWwK#tCP6qwtyHrr<{8_y8M%7ibOe>s521&ahpF^?GHyGA$oJ0d9@bz{j zRB>(}HfNBbkNC^Rf+wd)iu?Aki(Es$I9F8k0B%tsqYZ{&M{*z?ReUfL^+L_JTlDIY z=|i~GLZLUD`ovZ2N7jTT(kKp%J zvo<*ZX}KcS?k}*@mYIPe!js(EdG9RQ4KzAB`uD@6+n-vw&3bIZ_`Eb4Jgb*b1PVrx z=^@tn)7>8~y(axB)9>CFpPI3=qZO8TiuXTrJE4l_wDn&2hg@>`l~@* ze=Vr`P5Y5iton!PRlc;Wo_k+?4(HBbf86}dsAB)((zW?%e7^Ot*b2qk!6yFn&5S-S z>&0|@g8cTT4u;}{$}TlK9NzX~dUh_0bmuyJn|HE9)YR}Xi`mieSyrPJ5Oh<0rT_=8 zNAJBb?Y?)KoxSj|h(K`5!18HDEFzZ?^_M6-!N66F*zZ$QR{!v+MYkO^q66SYM#*83 zZ(3^Ngv?gEDDWjXB%4d6lgZ8A^!5jtr*-dRV}HDF($AkxBxdwkk5^yO`NL=}+;;Gy zsGWx*|L*L9Yp>d#X~jZj_L*Bgt*$z1xAeH`H)DyvHjunsszdfq_lydDkH&L$YqRZl zbcRcBtT|pMhqAwqSlRZ+d`oNfyk$9IF|H+Kl`CwK1%c^F1*eU!XZ{L$KbG0>D$`iY zKlqllE!$x_!24Db@cC(%T?1RvRJMrw^X!$a?_Y0pXdE!Hm&1dEQr|AMvv1&i=2Nr> zY2)|(S%{vSPCY3#JN2)im<|NI zuVTOZ)nj2dNO=f8>k>z=lS-K<;DQDe^72lIK3qTS#`F&|Jat&f*0Wvr-Bynut#Td!sviTU zLerS6WU!bGCib zbI%2I6Pgm>w2BSHUGgcx2WXSLkD{JV7)?E@a=YS8j~ehWy;*e zU-%U6ru%bqX*UO-#(weuXoIRI{o&o^G;27f1nBA1H6t+XA=4FW#<&2^jBa&3Ct#&i z%^#Wh>9h6FX5Zikp`CS)#o0Bj46}kbBr0`(UTYqy_fNU$ao&eMg&j*LxAN%vAY}Kv zuhqX|t6Jqsr^&F;-bO9L_luW%f9G5Zb|+6~$i{5U4#pAKhdKPdjcPx=9g&@KD(n3evVrq8+o}|S40bU)??rpTmua#4rmfLG?_>>pDZ&vbF z#P@14k7Kz7ox)RT&WzgYR;!*}UML9*U6&h6i9D{1QHI50d&-2((n7=+U-P*E#sS$+ ztD|_lzs1*Ie3dAdt&~o$5Hlvzt;I>Kb?m@wfJMOk_gL| zyVLU{RKE_%Dv(i$Bzfxx;zY}PHE$x5v9RV}<2GPNQU@A#P(tm@b1bkv=B;?1RUQ_8Y%m7P>0|$LyQqv|Opowm#D$0o zMhJ%+KUYcel8L$P8RP-%RHK)V*w-S|Bh&6n5bu^~qp~2kiwv$G zq=T77o9tbdEk|VGCOixE!*CW$Is3ro<>KKgN>e)QH1Esfvi49@vK2w|%`Q4`zu$TT z8$RYsq!uP6TnX9i97nZ|F~~`C0T1@==GI?*8E-saJ!d`Zy|r=a6n5$hr%W?+XYp9h zQAk#V*kl`bo1l@j2G)dIa!Ie`Vz^@l-|KXneqSxV?rx|{Nj*mO!Vx`id%R_qt9vyp zpRLb{`8I5c+*=7$LY3-cac8Ru*)5A)LHN>(JzxWs%b$EZfzxL*i=KhRQ84aJ*Wy$4 z*HY2&u4^H?H!pe{tQLWOxGp!i40X#F*k5kVzA#@;j>))nPTWS@hzU}kSdU4xRKodE zwoj$OF}`o8f$vJfJD(zp(GiRb-+nOO(%so^Pm~oXC~ZP<=l99}ILCTr8@bbV*S)AJ&W1^QsQDHVLWk^P+5}eI7qaZu zlkx#I_=6LYufp$gd1;r$b(a{tx`lqdFg#hM^nPB#%(Q0%n6goA|J>3I2z4j)Zm3V- z_G!bkOo$2yOQqt3N)|h^_xWB->5i6qAY*grns`&2Zf_@>)2-jia}QIkhX+?) zYcsAT^NJE|S*TrpjS^q*ynS;VzJ%@!tZSYZm94OJeB{ZlwKJ>tXYGqiW%ub5XT_0@ zy6x@v(wKTk!$spFwVEep0{@*My*+2X_q-o93(1II8{T*KyI5jN>0eT~H$v`QZmDv%2 z{kxnJ*H8Vrw!fS`WZA~+6#>h2o z>=?{{r(n|l!c29QQGjR@$%Pm+L-dzCl1^s}HsSlboJ(wtKTbb>rRn}6p{cyqVAi9l zVJ5~l-!3VTm8w~*#O856%PivMxX*h`RZz9+l>=sVxwY~$d|q-p={%WxlK*qW4Whb0 zZy9#cisg@$+T(GdT6|e(L-2Asn8(X8|0yHwE( zdo@n?eq9rvJs1C^w?wq^$=P~bK67VX2A&t>HPz(Qrj+X=#^SV*D_wOLH!H!`8r;S= zp;x=W0=uq$1;-p0Eq2)j#+QDHl_xW_n40}En3j+IdAp8!0Tjh@IW_7Z0x5lJtrYn? zxzFVQXql0v!?hw+e_y=rE3EW9zp7o*rTx(_N}Xm$xs73Gp>gu3BO)Ol6kuLJ)1C;+}W~GPg_s&~F&- zd*5$(fZB~Ifz-FaV=8qSBs34vxG6tgyBI6@{-;*MBlx)LWB0H#U4DXnVwsjiCuXv^ zUT*4_U$xF?5QmG%;o4B^?GRiUjGI4EcrNu1w3xt?|74CiF_83o+F z{t*oZI~Jp?m4w3I#~9__w;sW*iY|u-aS&zI^$%FA@E;V7xkaHI_V`pz80M3|hWq z`j;nrCGF)HxtBM!Xsqy)?(~daXHG~uK?vQ@{pzaIPfb@~Zg zC-8rv`z`Lt(+4LY@M)>T14CfCmtxSB*Hqs+#ee8<0auJ!0H65ZZXlbg!mUsRAlj9lQPq1&giI24lVV zXG?!!uRrUDD=8eqjjk$>ow$Dqf+aEq^bcLcRGHH*<3;}#Ti)Fb%8{73M6p)(BTiIH-apz5pouzaz{>;hg%z+PZT_C z-{)MNT4?w5;!zwV8NFn7TpMRfvm8!tHK^uG_zdR$AfFY0?7e#Kh9NK}(GOQSH7{RO z46&YH}|+KbOp;iQ{qi;Sg(iZoL;9 zG+t-vqt*1DShbhBw>t;~k$&UW!YvtK8|JK9)m%V_mbKmE)-1KE!a#qggOg2Jot zvb|+zol#z7@YjkOgo#v{^(&@+$*drDnYxnTC$%G`?)~6 zRC|Z2+R!atO~Y$69ZmqV)%dw_8Tl2H!e{;2AKx;U?n z5J{8Wvm|xT4&zO)^D+nWBnJ-aWn|~BBz$jJSV?*66lUZK%m!+ee*qBv6Q0V?=FC8i z)pquAx0Tqb>hAIC&Wdnv*RRFiU^IE|9M<4w7l`D|7+FQar+DBOKGAJNt#O}Q#{#pf zB&H+ogg+afJD1DwojuFg&ZepHk-3LAd8p{f4p`4wfyVw|d zh2~v-m3W^-`1`yo*uwVYGsy3<)UEYh2x#BOtYk4mI`=VShI^t*$;Aa}>So$xpcR_| zIDopzwP`IBK|DcRl7+|JEZo`uQjGtP0n7g`t@J;|YyVZ52WNqQ;z<9e+2Z~SX}$#_ zNdGUk1pW;~|C=-qe)GT4=7s+hT;l(KW&Z#6ef&FR{@=wB|5wU9%L>B3N%L%tYk>6i zzm^`H3es0A+~oDO;w8L3Y5Zz$JrCWUfYbxH#;(rM{A0=!`EeJI5?jiPiq&fQ)Qemf zg{&k|?^rH6qhC~p;L37!-|&{K%<|TJvwB(B-JK4@oM{}^uX;p2*!;)q%Y#BKcaQz@ z=Q{>j^|L;8$dwLy=({`Myn#c}ybiG&H{u`ew-cO7-#l#+z9ddZ&+5_Z4*%>$4apnB zR`jb39X$3|ymfO8&AUqb@c<;Q{+1|psmp*)J>^UnvbDz4ALh^Pl>~Ax3nEDo6?i9o zE-(X~d=sa7;9C0W_ZU29=P$9SBc0E&Yw>j}(eyi8N;c%Vl04^IWCS5B(*CpNyWW?} z-eWiBTesrs5@MHc5oBV{qbn^w&C;YlEBhlG`SbbSLZ8T)==`d$rWl<&Jm%mpt-5zhD){+Sjm_RBxjf!nMOxQ0mt@T8HcE$69MdynSd>?HmU0bOqGZq3?P ztFpUI>UZ}~Mm9mBN+&B`mi)chsg)-^{+gCsQqy(pa0-Yh;GylcM$68t`ZYn}v0FvY zLBoW%vtU!syvlIgw>r$n zT-0Ie+3VXf)f8A02TIDF{*I;>5#%J4bO<0QaSd@VuDKfmEpihzk?Ku9F1W3kT$Jxq zrfB(9-z;Qp@##ES>vX8BPpRqx8C006YLQsXOtm3V^^V)#*ag;yXoUy-(CW(#u{K(- zGf4R| zn{4?Q9K0%%|X|QkL6V%0~E29f7sZQ?>X?4GL6De(;4V|0;dtmgj%A=QA zyX=if%M_yR+=!J|sj#(H97|AtrvJs+W|(;odR;La3Ts;Y9_+)VAMmTYtH!#0zGT&7 z?=rHJ7yew`fnMiD&+_XJo`emuLvj40X9&q0gItc8CjQdBRU(Z8tfhL(Yn%SBuK?e? zUNZ+MUS)1R@m&zDPQ0tGo>ed`Z=bh5w>VK%kWFJ*yyZrl1=tsQ{_{-`N4W9fN*!iV zZ|D6`@T&UT9d{LaX}O&fZ;-=kri+VCbdE>nFeoe1@al!N%_BCzt0KNnA*^5;RI@sv zaPlyn)i7kd<;!)Ato*j64!jjY$|~jZR5;TV;B*!k%?rRW(f8>e8y8B7^US#EpL2Qt zW!1b$Nl?(ea|lf zVPPmzl{`Py2tItiV->BZi9;(#pMdzD`nx}S7$>I?V`;falW2_ar zS=Lkg>mRXkHRlT_-9Cc;dNsr>A7@@xfHmUtQFqPX;&CA++?7*U(avS>|}IdMNi+|*b!y6wusjjOu5Gu zw|O}V2Wz=lV@9j`zT6#5#n%9gWAXJU{DC~%vq@U>Pr9a^3A zw%LF;t{<6jbLZjZWgR6MxvE*|AuuahuXtQsSZjGwzojC>PS$zJoRAP}@ML3>&s})+ z)lgecZ_VowB=QjP8q89o+kJh2QQ%%q*17-Cl1zNi)>x@ppBG2L?aAzlTII^$A?qOa-+@8wv# zaa+39pg-|Sz}&?5ac)Stc)PJZh%(%fK)qaRoB4c)!$f}cZTuXCz@4lDe4|2w;3`u(|y+~THL z^YI<1NUz{w4`;{2%y@nG!Kc&emW#8fu$q)An^$8)(gWmX;u|9hd8p8EyrBnHrO+L5}b9Z z@ws1o6^!IL+CdV`?8qaL2nXVF+~ZrHW?AwuSw=xnjCCv9{e9 zzfFZ|o@Y8j{DFv$tUCUpGWdJ`l9)4CcG#rFyh+?&5z+Y3k~ zk~gm84jaKu5Hnyc>_%n4K<|%yFHwfkt1z-k#|Zqg%B|Mm`y3%BVq)Ce&xEN=b4TfC z);m3nX0t!847sOh@rM?M+f@T5IafJ*)ZoJH&st}7cSJo$)%M_WTXwa%ix%29M+5Jd zdz+RDLS~ob@#YeozV2XBu4V@?8@Bz=o5Z)C=8E0h+1^CE_K-ggCOL_>ckc`kxvlzr zonp^%1&q(3dLH4p47z4R{7S82e(nZGmi-xa{0T-<38FZzDqei;uHh zDT1q0+K<0N`L~;wc|C}u-yPD6oLpIW0eY(#JF|q+S@Y6Qr&LoaCxD6U9Tr^wWmPJ| zX+OD5=l$sp$b6qj@m}u)?flYH(>dzjhzsEp)a2KXiHNZ40Gr;y!XR@jw~{mUp@@$9q{|-`-N^- zE52PuJ-a?nw!7f~p8RQj`siQ#e-G~S=TqIXtrE0rd)zkKcUC6@%M8xDlZg?1fI{W77z7TCU`2aF`ZlA3kGdy6%#dnvK(>)FK>mpZY#u1f73D=KP3B8 zTx~qrN-q@#K7B+^$SYQKwU#wG^T2e=Sd;$YbB#NT&w%j*$UYBu3#R7ancto6OIoK@ zAz$lIf3hp8Ie&=1Q8HgonLhC4z*(td+k5b`x3t$JxfW*!%V7(@#|9~(ztafnCf36> zHe~XN8;@fe(ReNH6092pD=c`qs5e7Q$JE%HHc83>;^*4GH2j}zXwSr9vwHw zzuv6^bmh%aMK)LJBIx#Un>RG-rQKG48}r-*PIy;kR%M?@ZMHjhzYAnElP5^inOEn2 zf^yJk+-kz>zI13?y@IxGp0qMqw6J&dULTnXXlG-X{M{Ti;ZUEI8vUBY!6QRNHYhqF zZ>iXn2bRPiQ`|VNAZ=969k|S!)%oh%X!oacua7VlOiuWv|H=v_rVJjiD2!XHYmInx zul%Pgazh_%c#Gr0t78{5-dvi_=Q9OK=+3TKFN-$J@C&6kN3BmLDsPyz0zTOIpfW;u zP-1l+wi|`j{n0~6z>2k(RjvBhhi}p0+kceN+OWF?DLW6}0yM2C{EFgcjf|bA_Bwy+ zj8yFE`fY^{O73(@(XH|&ez}Voco^IB)UE$URZ|EW{d)5-kcI{~57b10R&{Sr`Oi%* zH>QX0ucmZHgxKqPU8#}|zrD%zc&r{pYj4}9bbG`272a-|w?WNPXZ0?~B=)Q;+a8;J zxkW>(w@H7J@gW*GWAaZe@|wKZ9#4k3_vfVn^NG&vxYAIS;-|5qc-=2g9>aP`7o>Vm z94Fi6lS+y4d3#s+48o9hk&w$-nK>A8Exfrr@wrKMqmokzyPzMM+z-(P#}neN@{0;b z%u~%fIju@ayxqUp&gvQbsl@Wg9yREG9gEXsePuIU$=V~H0ExIb15qsespb!%^kyYT z9ShTC{CZU;MmRe5u4=hK?TaIN~b~q`Iv?^_Vo%V+TE--e>ztW79Q!(FUlx;K=oJ$kX}fDsy%veb{*#jvhS)Z9(dQ5cAy*BUw0a zRCf(uNQ9^TNMAQ*j?>6%wz~UB^N&=oU7}iV!iQ@iFVOaB3Luq^+sEzELHWD@VET+9 z!l{vpwtL+%%mPuct5VDgD1N5trN$x3`{^gOEuTi0T zxv`D;C;q%AP~=(T>e6viYkDZ_mR0NB+kW(lT`6Xl z?>w>$2D!`>a#$PmAALQ_0t|Xehbg$`9u`UyxJjCzUFB3k+x?uXch?qexb2G2y_Z_5 z5yzu`&zcBGfDPaHt2u>>cym)e=5fWP($TxaL&e6T`>~{eCfn+jz7+bz?lUN*K_`Ev z4Wu(>lbip*vtM-r5S3-8M)hz8grH`_UMhkpfzfFF_~?E*)~Fhk5r5OLGrZPt!W>Z4 zi7H%&$ALoCkQgftj#59_g2?9U+|OIytU}k{h7o?Vj9!HJ0Wc)PV@3JpDLAD44$yUE zTo2mTOa14-7T!DLTYOS)lrF-uay*p2{wSVQ*lB5)B5Y7SS!v_2MDaKIf)jhDbd>GF z!}@Vh)a8s~ zSgNqpWyBy2u2iWJb?Wf$b5JO$#9^#qOUW6|emZ+2ui;-SqBu z36qUrKK9Cg@TZyjbeS6J<<2L?miyJ zJnkpw9c=dSTXLYUgOAmd@%D4tuQl$@T4)L-zKh;FaGV^WW{)oy$Cq2G7rKiFV@PAs zLb`S9$mxB!@#t%CTsTc5UAwsnRi&xMjp6M#(!d0!z<+YLU&V9jx~Q}lN9eRpE=YXF zg{Gsg<45?qm3AwH8`F4q_Pj~2aQ1d?SZ~NYo)!BVRk#>$pXV{!x&D@uC;si!yUhEz zkU=*SBs@>-c6e>Qgr+o4^%7ECPOx5l`FqPTh;^(rTVD4+n>PO?RN!UIj(P{DU9Q{m z*P~sf;s^%}FIkzSk_6<2Tv<_R@{Eid^Is!MTUlqaTIH)TO^t_3R?2L;A@m;hvHo{Q zIGxTLTlkMq(bDd3nRP2_X@CrqPC?BA2;)3*(SS!uLi)9w71(oe;HEaWz@kE zzgU-=0SOEj>Qg#`NDrgPPvGK@3*83SIQ)*YO#K%187N?(eeaKJHU``es=W|SIGg-r zR2Y}X(rmXKD)sR*Opxuntge`_GF_jlvP}Rt$EgtjPC&mspdrX`e+hCs#(2qSUXDj8 zNC_WKh2o#Li8`eVovmMvRyZ@`SxDJu7OJrx!_`k*{1!R@hk7^`>sCtKe9MFL{+h7^J4n z#MY$7kMKdMaAE5dP@{Iav&brBx`B{>IuuF{dJ|T27>slIXus;z*WFB>&(&^fZuhn^ z3`Rd@{tFLY>!p5ME4whh{p}*mc@9{R7rw$5#^2XZ(7SYJna^rL8hJ!|y|^}*Vb|Q; zk6v@Zw%1@`Gj1suAf|`frgm1~!o#;0w~4|Jt3X*i*V>mF^+yhx?Boa?>k5V^k4o9V zN{Rk>em#*BdteyF$H!`Zr`&*oMe@yEVCrs0`ubA>{Zt|dZ zDa}jxGFS0s;WUKsT&se}AUo_o{9$alvSv-sb!<8nWo9vo;Bf&dInrCSi`8eb1}6Ad z+3kP$S$=+P_5b{t2c7G^ONm)b_6tyd&dVQA3ItxFIF(ns%CKban?O(+ zrHkXSRPR@;q6QGLZ#XV;tD9FZcRycm2Qa$jfCm%+w3!A?v`93=-sHHZdnc*5CW7;5 z`zd@og*kJTQG_UJXgp(P^MTU;-4O-rdZWUk&S9_*;G69=+-}_@0_(l9swK!$Wc$6G z5IJIJ5?vB(B+)3k?1(=xxM?uiGcUzLgDUTd`ggJ6L6=l%fGQeSwO{&Q%5VEY*&aUc z5cdm%Q9U4M2nTzhu%dFzCE*h#DULC%{;_b9N0n;(Tg;yCT3I#nEO_b02dj-gyG7yz zWFMq!f9Jv3C{&@h(PK4ajlMAO7?V@b10{XjO^~m1u)XffKjbe6`h zyfW{>t4-5oZq2oU8(a~vlDuNaYm@~Pq2I^sNBp^U3L%{-*RD;Cy2}Vn+_b3MBu{ z5=_=h-~{;le+vu5O>5doN32QG?3Qcj{k=pW?hVhbzITe?XSI9im)ZM%&L$WiPs(kE65~ zw?H-Mcn#afC_;$ww&pCW$#KP@uhC)AsuesJYVK;q^bGH?2mwKU+nDv+PWu98fU;0b z1(q_S?VA{elM)UK1F&U`wnlqo6uZEo*nyPgxPCEvL9E@ieGM9X0sFh28rwp^kLsSU z>(vu$c;0v!0$`;_SnJF3+;;W-dxI{-8V)`iEwvtI#RrGjE1})r{d@S;@&)~b;u|>W zh{08_#8mIHGG0bwi1BdNyl#0ZFn;4UMdIR~n;uH@iQoF8fG=Y;K9^rRDfC)|Jfix) zqwg9KH-unVZ2fM7rqb^<@1^YGme^%A{9`jId~Vk|hW+}bQPQNU7;qKa`6|9=-=Ruf z@2@nO!ySdY{bof#ZC7m*8urfbpR)kn8!|0=zxO00tNV~A+*+qB-I7MXAZFrtnvZK{ z+@V=qh>kCmeO1h9cg^fg@xJ_lQm+|Et!yD8`Aa~{C3?0wd9-h^9nyAstI_z=ULgp5 zpX}D-?Q;7Zo~FOAb2dTq(m21~%gUcr-c0!8dN#PPVsE*}K0dStV4zz$pDPG#v4c^? z7({cLxj#A&FC4TAZqn9PU+h+%2;tvTY!~Lh6xl3F)}IYFnsCdYQD0EK&qGyUNNgV| zym{VK6~GyL7Z8a=+QKzfvXg7n8|rHNw>k)8>D!-tTtL}G77i-=HqH*5>HegRgK^_I z1KJ77*)4x5&(x@cC^bYCpHU=Jl0d)*}?I8s+LB{|4~;5irkr`)?O( z<0KKz?eXo)K6;6_%$H$qLdA{C9uT`x4^Ik6B8`J?jqh5GdAe-;Wq3TBp5JMFs$Ay$ zi6vR=mxMzERNyS?cI7L~H5#|8z@Yc~$(Molzh8=|J_?GGdR`s$hK*#VIKiiX_5Q{g z(Tau3qdxp1v){oS4(clru!CvvcP`G4RdQXfmuwJxh84~Kz`)Bin3|rOhe7WJk~1X& z*5o@#Il&5r9%kb``ozFD*v=*Uk z%cQS8H5!7~Znc)|TbKEi=$oG5H%BeTK7D=V)3A?2MZq<=0ywLExTA+E{%eMyCT!;D z@g=RY(pwlaO!+m3X9`n}4R~7iOVw+qb#qB>-~o5%lO@y;z|2Sl454(T2F_<+Pw=)gI2C}g2#l~FF~H69k(jjy0l96ec=80_?%2T+-gqM z)J>y!uBBj-f-$FmlBg2#1a-+lH+oR%1Ul`?B-35JEisU}SEM(172dgWr;pR{=G&(cH{#C5f%NevW#`WuzhdLa-zT+& zU&xr+!nq?}@y~f)Li@QI7EJVTT|(ze-1?I7RtMnJW6Hc6QLqP<>+niCoa>{Q!%0h0@N{byq-b4SeHm1XBX>nZ6%O_uTV{l#t7t^3!j7LE` z+rvr(7Jqj#oKTYiI(*JR=l|gVr1$K1E}^GHFV)oFyyoHzU8q_#sO!KsU8MU4_tiY^ zpy}H z`e#o(%Ah+c$41&5nmsClJ^h)ba}Rx`+ah_x&?(fh7Y}L)jQUaOM6YFE=Wml=V}9qM{c>G zIm;zq($Dc^6m%bu0Ow^`-yEMs?K7~l`IW-j%!!uGq(4OSS%KYQPZx%>VQeXr2Tw)*>{tG^x*(i>zT zzq~^a5g*H6j^y+Mlsm2yDo?(B`q}9zr*&mB4vdT7fDv`SJk0H-X^LJqVHM{tzuf5q}J9q2t`}L6wYQrsL zVp4-%=;!iM@4lUVOU}%h5U_uW3{1(wZdT>@o#rUsTOc}Q?E9eAcM24X1|oznH5ISI z1AS}(BGZT_H3)gnC#YFAXTQ)et^pr8L>ce=9r0EB7#FjZ+#T$+x8mfB?%xGHk?u3n z+h@S(1S5bRfd&Zub^MD|61x+S^eT3u4QTLUgytuGUaNIGM_TQq{Z9J*_h^3v>Z$n} zQlp>9>sJ}{3r#N7OL=Tf3pTL@BhP-468#AUU_}VrxgM_%1AtA`KUFDvDp*3>YTb*s z>fmP*J?Avtuv&943&D+XC#R5j)ah|Pq-$_$@nuIBtVw)j9xY-2f)*&)spr5^iaO?6 zj@9nwc&&V#S4d0SukEj|BfPfsZgf1vK0PXS~vo3{ChHq%E8#}j`t|V1eV{bs4 zU|{@>xY-lbzf08s*d5;KayYp1=rit;1@{e7Y&{{lIN#+{bQ>j+%5t&w%pI5Zip8lx z&MnaBG-=lN8;EpEWLM<(8?E#l8(5{CUgbA$l$9{O{_*^!^&I>9a`4^IeDzlO6_2Og z;i7O6k9HcV`$I>@c_1v`^rXi@U8FXvfmVX!3lYz&+Niiyy~Z9j7GnKHt81@zQ??rm zjq9t~xBf0QWl)uh7N_Ux8`gcRw%dl58q_=FbfrT5+ID!8ozZv!RMY#NOXDVbPf}DW zH2FJxMoBC>4VDJ`xn~YbXiq4Thso}Q7k)DkVYC6 z8x&hqumiC{Q4z2K0lUcD`_$@39a5b_jk(@8bLZZb@x}fsvSzGBFzvwUBk+uI-`8z$ z>3L5*p9XnkvT~GeD#mKHaq5JA#$ZOg6bnOg4E5M{Z;ON0pwcXGQkq83c!?tSis~fy z$~Jh^{OW~w`kw#!?mMyG?;_|zt|g>88-#~+ZWO^>At0;?^IiXYPs-O z^0!VoYbes#+0D((fbUi3K6t{yIIiwL7tNVVWcri2tIM5R`wU-NRtGpvwV9j0FGXZtp3YnJQCa4P-cWFx zGpi%OSD*)Ymt1EO-JKK2I_uX1OYoK3_H%GB{R9B9#G|Smy3R*w9l`If9y%+LLh}8J zBaqDWSqadRcTBG8_+!W`muqo!>`rWy)chTcW$1-0TiL2{_F8Z#s7@P2vYXbLuX`(( z?#MJTNugb2*c>I=q*IX}r)r+uJs)31C?$*2?gPrB<$Ph17G`0O!9XcsT z>{K7qRg|PF)WJ>FU8%c{js8q#j@1pgiaVj4jgcB>h~Nn>m4pEROsrZ=)_OxMnO#Uw zoADnHp}^vxvV#^z`CK385AICIU0q5Zzm|XMkrz5;^TR&tbiY1w!y92^j%H8GhJcly zS!1912KD)4u8nJwTVLGsvjNpDcfxr=JFh=mXyX;LuSELNvPs&2*5&?DHxt-7J-;HZ z#{wc1O=o7J)vH2rXGG@~^vhZf8@rYt_I3qp6-s__xvL)-+%WM2luqYxTAEe# zR{5~T2OQb03n@^f%CZK`AvP0mhD*CA?aEkCL4OW+QC!elWb4tf_?2iLxPk5 zv69RkYFC_GK+H!n^F2u4V>&I#1bo|-)3{L4mKoJ!m~*MSadGgKmb1^!3pR``~>@g)ruNzm*+q3L}TQtqZlU-8Lo?B7I}m=@T7!-ou~op1i@A<+wWd z9{8R=psOn9?6AwcoGIbnMAF@G)os~}=5{h**6Fgu1gU3GE}bI0^xYugGlR_o_B(DA zctJOog+Y6QzP#>44NGqFH9eHkVVleLTPHc^62iU|$)Mej&+9H=4glIw$Q;kQy^B?u zM}&3Pj1o%mexF#AO+TXM*uFxuGcKJgwK~%!QTePMR>LpK3SFD`pL!#VDpO+-W?b!7 zYpkHK&aW463T?EIum=PZf09Zct8QJn3BonEYD_D+$>0bA18<2v>Z9y_>Wqpk$y~=Y zj)Hl=xz(u#xzNXp=Eo{*@>lv3EMVR-@b=ZkQZ+QOF0=W2gmcI1^T-!ghu5L8$&S7o z-gP$Wet0n(gI2)xq=wShg!oO@Zwgxp^FY{3 zI}H_2Bo}gjXHZ8=yCVspcI&~g42*apo)d?#Q2eYG*UfjaD$mz5j3Kv~hA5BqR+tCFHxmzNZlu;#R-s{SVEjik3;FMu%g?1I2GLtmakdpISJZkic zTcFAzclQo+5lo`B4s*#NG2MjZFXwA@<3euD33n%{7M|bT zN9WOGcJuO`1*U|>r;Zdnmt+U=k#oZR*JE=D!05(Icx)bn{PTlWB%2p=5Z$p~UbRg+ z7o`@-eUVHIxDLgR%EB$NnP^>l_x^y7A|rca0s@_=CulG(sabzA98JUY3u{(f+a(r? zMy0Yj^uz#`H6y^Bxt4T#m(IDt_q`dKNSetTeY47e)H`p=IgXZ6QClSf{SL!xO< zt8l7IJY4oDe*0_lB1{`sxI*F?E6S;X6AZfi;I#;g?-8N2UN?&s_Qz}!xF~j6&n4mb zDFWghS(1t2X9|4kN!gs>v0ohyTQe-(o(+0g#oV%#?Buv(wWc&KW2`AT6#=V1^1DSU zr*=uf^i}m!e57vNo5~|Dk)BqVn=wLFW2!wCpTK;h(ac_NL@08pOFjLG+E&?VjM}6t zVV_=P+r4C^`^_9KgUg%SXGv(5=5H-XlhK0LcAwXT9f&;$ozSaH0pL^NwtqZKu5?eM zH?%#K&;jd(Zf4t8M}y?p&kV@P>*C{HrgRw1n;9y5O?m+`3QEsykK>?3-!)v>>Yh{aP^wYQ0?AtDLj+b(@72TNjag*4D*MrI*X5AAI1M&bM8}!u@m=Bcr!nARvjhxT^QL}H-#YvNGf{m`71xJuNkmrtYe{)4j+A`G8iVJ z4gZ*%pm%c*rQ_q$hP25zrxw^)m zJ=WS@q5afHOKN7edcGO=nUeEiw5LU5w0yRGD&bayHsmt~2~@kCH?cM?wk&hMoxb=- z?VRKy+d{5S^K{~tsOTx-8h zM~T?D%H(vh(08wYgR(2>AnANJ-xLeo?2b!k?4uzS3%#r_JUiPVw6RX?;Azhj=ag9$ z8$8#l9TIixVx>#vT0zeTm+y1Oouve6no{b9P}joMZaf}EP%35!gUI>AYJPFAV zy4@it)P_P6bcL(U&Y)s&+ayq1X`FoVu78JqTmJ~~prZ@q1SGZ~G&WwZuyf=fZT^DH!!P2Kg1_ z{slQWnU;|+Zz zv~OF|;G|d~H{7`QFtL-}+C7P8+U#v|i%>#nRk(#0X^!l z@tWoG)O7or*;c!hb|3VC<;G9HFC6gNq#)8n>w&gY`3iu@ebk6Sw!66u3d=>9nAE7| zFhy-)tm-hsQ>kQ0xH*f@8i%=$K+dp-++4NEPkl~YWV~}4S%qLkK_~75pe2sC( zK;Hq(7ffLJb-a&#o~4M+_*>ZAe`4fF> z4Zg-|gk+@>zHmpVSzfBsLV44zw{{l~?>%2kT+`c;4SCzF3yNo8d6h3i8sf6%djJv> zZRj47jI~hM{H;o_q{au4cct<<8KLQG0&smhy1Y!*)4fLR)1Kuv=Sy)u)Th{7`6%1U zCU@wnt7vy=yI@5kM~ic9zHa2I>DDsozCa(HHfNdhLKY_qSDngbvJPbp@M`6x?x+5u z7vp=O&$W_+Eu`nF3GpXlBdc5p(`>KPU528geen+b?{#WbyE4i5etgAgxemFnO|d>i#FM=*$fV#~>5=pOgr_+kHSCUI99ryUMpL!cfY^c{`b;9A`{^vErwu5c{SM7DAiP zw)8=QHSRh*eWl4YYQmcj#Ptocd#GGA8yNkjL+#F^a%8&dBP`r9=pwFXl#nPvTpof?dn<<`wbhfQI)UsIRk6%LR;D!+P1S>FKZ)5B#K5tDFRK#c zq5NDW67%FWRT_v<@3CeYtsa(Y;{C9yc~y3-8eqdIG<)?AB7Wo2qre91*|j5<$H8$u z*A+*vTS~XGDNJYk=5#w8Y%Z30Mz2Y63YUl%bNyZ1x}VQI=q(AflZ4#L?W_DkR&UIP zln)7rbwY)_r@YGClfs-|$`$l2vmf^DR`FEX=b1e>e3!HPBzGCbM_`26O$!1QK2maB z;GvBi4)7G&_fMzG<1gm#e#S z+p&*}$tZ0q)A=@@MFx0zyR3X}Pix;?uOeu~j2mq9jgc5;yAjgrfkBDb&r=nZ`|RGr z;5P4N@ivpI=wz)?&X_aNXBs-uPKbRan- zsC(Nw3=ng5xODf@irYx->MONB3gZirkGo)b zhv%hzBj6%mJRjX}y_I*B`?f*m2Ia)mq_+dGr{Bw9B32A62?RJ`p^cnAcQrM(tiBE< zTB;1=W*kV(Cd&8Oa=x%48lDBSyb6csJIbJ-^2%X+`jpgScuBGP;SY5Je9T{Zw z^fbWphhSEXYAvC{of~p;6D6w*zG6$_{CGVj3xOa7CUuYIw*|z@f%-*yFLxt+;3Nlp_MudbMqAlHLiuZv zx0xVMWG(KtTEFs^ed&CK6o)LN$FsGZ_#JDO+n0QLlF$YE6uC*v4cQ86b<^*Av)4mw zmLEm4V~)NbC?^+Br~J_%3Kj2L-EP|+v72t%2o{f{J$YDN$^`Du>O{gDlH~gK8VcRu zohh2)Zd;kwV!Ttq4i*nNa|Hf6(JS<_tSsb0M(0A+PVn~`aH5cE<-+M{3ryR?x|93% zJ40Th63t7(Zhfn1M(W_be0EgnJMURlcP}qSe(h-JB@FC4A!o7k} zAB`5f?H1LWI~?Cw4;U3JwTE;>GHj}#10b8o-IOQ+WqP!zcxdwjaj%4nx35(v94bmk z%|Dl8RQKE(0Rf+S7BUvvuT7xJ3C%61;&v>G>)WXQ4Oe=7g>AR=zjJ@yLw=%f?*#&%~{phrgS$;Bh!Ru*Eo7E|gw2wKk ztx+rsq3&^=T98{5-}JOqHk$(etr<)wj9YiXt}x3y3w^V(@roZ40QAkC*iPkQzG9bm z2dg|&$S!ht)xQOKI!*772P+?@X0>+dF=T-(e(5jXg8e@36|wc2t)hOuR;iQtB`+H7K`2+_}5sia4*PGX|fst6n;kYyh!(tpRBf7 z?WgbhJhk9Ekx-0ZXqumj@8DHi?iw9aU9Z-c1+Sa~MSN9Hg-s6`>8zR+1Nu8t)ybL| znQi<&0m6zR3mVoy(bME8LI6+P=t80R)+PoxS5ZN*ygBiKKG9m2xOmS|nOJR-$bfe{ zyCK1Un-Ewtrrssig_xWJIu!^Aeb`;9v-WapWnP0NTnIXg_0(0Q-Mwws*~{Zt8}3Z+ z*cq(ieCv@%x-aMI`klyD+JS!1=aWl5qrVq}!uf%==;jEBpV<)e`jZ#r33R2^b?XJ3 z?Rp^f-@EC>gsxSIt2q0nRvpAI=1LRE5b}P<=*PL)VH1B%u%!>Si$*5^@zIUd2L{FxwKlJ z(sRM-%9m$(i`A}dnYAmdr8CFdtB@$-aCzE>m?uTn)feC%$hn$k_3$O>DQD`I9Q9%r%pWIOblwVel6PxV|_jkB** zTJ4*M*SoyoL4nu5MyncD>m`tSQym=6flVq*G2XGMGUEhSM&O3MxnwrTPrI8z>(2w9 zA{c41N;AjOB9$I9+tYC2I@ePzNe^3=qOZ}1gA{z!8^r7NVoPoKaNNUgd}RfC!O>n@ zOW6Hn=IY%Oj?=^Xrb>6TnRmOF#Jao88?Ede%U%jUOfVLdTsI7AqL241g@?lQaCmOo z<^4r$KBa~6ExRpK&hi%a;hzoh*mpxdK6Zm4{i+Sq7q7a%ta~5vUWaU%(x<~Y0 zQp&Ny16qgyf4rO=dramv$sPEpUESQzd7Oms>&D&mVLEQf6@75|0UU08w`DC|ls+88 zTHhjNGo^$G%_fDyz&|_3=C_iVy92Ul?u&7mDnKj+s@MBBA%9|*q?Xw-xkBBT*@qsu z&HLWl$)_qcV*5<}Gln6{{GxyTcLIf=(z4c;xbi*UoRfA6-}=AB?q6QFkNcv2xQBmZ z7#8Wu9}Gi|{wEAW4%mbLz%cyz_3sQrc;^2t!>|HxV(||Q!=K;(d{h6w7=}f<1PSZP z4_*KIt5PXf{sCbK;C(sKud8zf@^nP0!8G(?m7J|^UpQ*D-H$dkh3u@(^h6rJ7+s_%liFEW{)I>U%!@w@ch z#@uZji;qSK;diYjM)kmD&lm|K0YbElN5X}VI@>mniR$g?WZaHYM>I+(%yYngSa%o! zysU>|{gip4<8x+fPKkuR+I0JRLxVCgT}Ey34cPPT`x@w*))$~a`t}soui(R?Vddz6lr+6jdN+;Y8~d4w(#ws5NpzH+ccJyoEeno?(F(IyoXOG z1ncDdgApV|03yj8{Tat^&|b%*R_%QgUiaObR~EG0d^|O(onM_cnINH`GQopNZR9Ov zewB^;YG{30$!0qI%C~J7yY>@H87bXosr(?gIzbSd-*>n8_6{6>)ritQ*()$}W35Tl zr09YY`?6m;e3~l9Gt9ZY1Y>h}sCZzz2|z`rghCTZ5rF(py(9f9LpY0^ZiWtUw20cR ziGplobz1Bf_)&hZPulHuPbc;>K)WCD zs@qCJd(Vrr%jEeTgVbCsJaMtD_ckb&_vU=9Ar<2~+2y9S`U&!2vRw#}$DldlrLuUz zLTZ{QYRBx=pgKou?1YZrhH1&2)Ytn3_!|JbIo(DMo0$&s7kW_MtenRrpazq*y_^Ch zQ|9g}4#|J@8gy$}>0NowKg zZE22jeXwNRQp~!ii`y7A)BH(9YVXZwsa{&$_VtCeu?i7i7VBzXgNQDuX%D9d-tb{^D@aNv@si{F{gy*=?jU+pRC~R~()yz?-CU!7BDz=|p>fK8c?|IyJ{s z3Ar!oD~N@Vztv19JTI%|S7NiA#Ze_6P5CXMwp;Ot^mmt8eUs5Fo!2hK(K8ld9Jdj(08WeV)@E07CBmXV92c=M` zfD`)r(Vywv!*MVV%M6scn{FodWkv zi`2F9-B6iT^|)6B^H#zlJtgk>wB?taDJP8O_Th9uPERb^7KYzdrLpRu=waEy7c;;y z^4kNh7CRPS?>?%j5U^P0UCTmK=1HygiNZ7YsjRr*h6^?2*lqS(_Rc~IljYD;1Uq+` zf&9G}`nz|hTnUr64CJalha{B`S}cy4#p+<0AIzu1x&^lKb0wPz+F22=D|)|rXz);O z(~yb+1iq1PxwQqvD-I2aQ89(>P<;4!Hw|X>v2*9YV`&qP$=3V6+T|pX_moQMIUU`G zpXBs%uT1E|*r6|%&Z%$_?Av_epxMqIMoEUtuovc-UfPW-mj`?70@RHk`A&N4D)uj zZsfF8FC&W;CQ4~6Q!4xT0*!{RiTaYTVq0UB!eS#co1Mju1jQM ziWv7&uMlZF`zR1>rZJO?rRU{~TgS;Eqs1+lAxqTkGHvFiFDjr!e3n`319=+*Y6xsi zthn4+AQagebYY3C4jns$q&=eC=jmPC#0D!NtQX?DAT5}5lVzgizItgzm%tjIW}?Go z*X#IojlP?YFl)$lix$ukOhMG%3P}z`>c!Nwu;MALY>{@%6r~Ps<4x8XeKfYxT&xQ_ zjhjxLNy<&E0N|ItOhL_E;h<>t!IA44pjFnrw z+UW3n5D9K9)CUczN{&{zq?xlDa*jNSr^mf!BF%Ns)lcz4j@#V=6L_n>223==sZezb zYi5c`UV?agrQZsAm;B-yR`OpaxfD)@9zsjy(LoM*L)xVs0WI0t?%XsJZTo&c0xEp7 zA7@V(%!;qOD#op^T5T7a@o0OM#*knt#=$(Tm%^QN7Hs^&`O{7fxh2Ng>{!DzKo{j| zR4$#Wp_O(|*`3wEcuo{Lm4G}%%qB12VbTWJdHq2CsaB~dgI1D-u34n?avY5k6?T@z=v6e zV59?Cqp0E$0cR@|+j$kEJl1E7TJ3`Ogd{$HSoL{q--F@Lrj(ioX8~&4f zUev)7<(KH>O;X)$(>9;E-UxXUX8XVgCAl*@;FSJZ zes5-j;&GuIf$Sv{+v{ta%6XK1Z7wWD0Id+aL%p zXO|w@OcK+zRl1n02a;lsP_Nl4r6nj-REAy1{sHyUHcT4Z_Q=Y(EM*O)qRmj)2^rC$ z?`{C%LyNa5rMt#{+Y@L*0oz81pw{(5h`(Q@h72*g(s(#O)RvTbr0Ye4A|b*Qu&McfHvTaMvBWFI>aRok}XU zmq-ulBisjrCzwn`{wGtgx(}kHN?r1 z=nSADK8kAMLbeNW1{w%A#u&~)ukv__fb6cQ$XUDPkNr#JJsMQ|%sMB3fN|c&pRJYL zXVonMxudbGg&${Sl7}wR) zy!YAP@zO9yxAN*PnHb;sOnL;#%X-kv(15o-ctSUAr3Ye~n;%mk3Ld*YmPjThAUO$+ zqgJ)!eIHtJAm@R)76-x!(_7+t#1{I*aQtj;-=LJtuJxDMo-S59`3(}#_Rxel*IpM~ zo*AR-Wd}}BM#f7r|6<5d;-X;YSxexMDEL)G+FTR%Wn1EEO;fYU;&@p+kl6JAqJ&%dKoH)E~dBp2;-sY7P^dgK-%(F zR7WQ77UXhuOI!MKjkfeD7%jv5bt6>MPos&?@aHRWo2TPb(1w`6+r@-0+;h=57y3_R zy21h`v)aYZlRzV}zTebpo2}GzDKo!#XjuLB zRbKZJzo(u)mL-tRst9SbdajB4v^ecI7HonF^_r0BT?ytct=~?14IrcOZk_5UvB|8G zn803@j=e-n&7TSR0ZCpOx`YTi0?xIQB~bC`b+4@-^7}k{?1utf!kcwePxUwVT`L&M z!l-6vUw$x?fw-bl!vm(dh08K%*4_HrY5Lkq%|>kmUAQiE$r2Q5nvGY2M5jS2xfbu0 z&SG{69=Gj7C|>(ht~klxMXEJ#uuDv&aT(B>C2FoLfOiI$=ls@S8VI2b%lH22%Z7G& zQ={l>ehSkvt)HHbS08ulNjo)2;op?4TRr2-bDw3I%eSEYw=W4$Z*V(wqmOY~WxdAYv|MzKf<^R^D|%lW|;lhJr*C#S$iPXn4<_ZQb^Fj+ILVdOU( zM|*IGd170`)_sJy_2ff!8L@)!RCbM=AVg&mY80u7?SR7&o2DXeg%A9SJdVg?pl+?? zp+26MTc96V;)k`gGRq3Ol@vCK%#Y(iC=b~EbxlKFuJ6kAdf=5op)&05U+YA5WHkIj z?cFfuV1^SGGmBulW=>T!V352AkH!8{eeY*VDg)L4O4(eGohe}Lgmdv8@5I<5>PZbH z1BTlaa8CE=XChWt<|vU+O#kLox1uVlw>%XOyxj6R;5%6MRvflHM72i{?dE((??%wS zd&aWz%GFv;e58~b-(^N_E0TYR6y>_(*L;w~ws@QhQeF=$`5VvpVD^hw5gr935))k2Fmr*hMHS(%rn%3;`| zr&(^7J0`@-IoOu?!@Iuh`8*)%^hx+eynPP#{CS5bXqEhT@lO*oPI*+Paq32 ztS#l*>vMc2>36M6h`Swd1)*+ztUk+7a02QQo=DA#{4TTf{ZmbGl|0zYOJ4HUa$nCC z5*CQy(`zlW?I4lFKTY#cs2Rr&Gf(C(rXSF8<1^}o@Bws#uhZmzl|QX?q1W$H9USQ12=mrol{s7qwZ}6+JFq*B!6JEYcCN*BoBo+`6!7ta@zl)-gMuVt=- z)&T6)l!j9<6hc zkw|yB=?<<^HAV_KY{s^(12jE%lBn)A+xTTh4-T7rQmcDtOVGg_N#BU|6ZZ36dh-(mA~imSzf4`^Ji-TQDc?-p(&O!;=krw>8Qn== ztkPS248rYK^;)`4-}>@)fNt10*qM=5@iCkkTxh$6;zUfmu1cHaw8%q5PrH{dS8<(Z zeF${d+c&kVVpy(naruH<0LHd}?cRm-$hu~7D8}y%@DOw2f@C`W1u&^Zp(h=3_ALqM zbX}N~s#?5XejdGamUX{{Cd0PoVyVTKGbwUP43aQ?bEI7B!+v^R`!zpp7t4mWG%GM2 ze=NGD!@R#^$Qdsp@iWpU-JWskirh{^y_$+MEVioNQ^jqzw(1n9TL&{{Wb>f!4&~?! zuJw%{75d9$el_Z)rm7m9dA4;pnG>X?P8YkX?d0U4Rtt|AaT=mcrz(KoNvJjY4QRwRZQ~_~wCl%o)6+h-7!h$#Om6U6=w37BMb1xh*(R5Th+L(4; ztVa7v$K4K}?=m|#Vsl9^R)y8WZI=A;nvg6Iy&cHpW<({udb3=r&YT6+{E-WQ7(6G7 z_m@`H!ax}YEeOX#OvSmIjiK0vNba=wsw}sX#umEs(7F}|yJ_5Q0s>|FS|ue&dY~Ur zu?jT>PS(Baan8nr&BSldtj0Z^45mmwRh*C$b%!i4f4!GH6 zHxEn=iqut&+$BV_O+LdC)@6JBWx~mtc$V21HA(#(I#89~R6F_Lu*Y)>k`Wc_sy%3w zACO=tnF=Hj!*DmJ^rAcuSHTx;w$`^(JD}Ub^yU~&|b=M^8Eb%61jd|7I;pffl zA&=PI1L7^CEIqquWu#<^od}4186ZoXayn)olRj3+y8)AE!llr6d5>hYz_n)+s?FPC zIvnJ@Waqudm;8M_&s(?C29*xUbp0$LW6tgXxNWBvd&#)*K9rJ938c7M(dhAc5dON zfCDa$&2v) zu2#yusqUtTMSX)+x&?)t0&H{w+=t8hS>1ljQEFs=ztzDi+gPNF+)KnON@7kuD^XHz zeosCER-%uz5tI+aK6a>18DFG$<%&*2C=m1)>FnjJvDcabvGKj-q|s^T9}q&Kw1#eF z?-x3mRm*(#b87CZH^KVLE&B_4>zPmp#aU`SWA!>RVMk>_s7WTpkIEX`J64zV+QJ135_*F>H=-e$!b zPnD#4EJx&kkV!?_) z^-EAeAY;Q5I>zhG>5OMJG;u30H>XAkkl~uiwuqF7mKSA`}Hd6Rbxz_MbYYaiG zGt578kC%@rTe&(AY9j=EyemdHr;dOrSaX|WC)IgCK)u%?R+{kuE>)!}LY{${VWs(4 zonbXdweCEXjd0Kw3kczZF;In$N5!p*NSGY~yc{L7{;kzj>8v;KZYiTZrfz9Nipj$) zb*awH9<{G=*aK&`lXGUL=&74*Nwa!((b8d~TUwXPXp&PZ+*;iAYdc4ky=HL7w$HMl<49ZOO8h8d z7Nga^_^OQ8cHyvT+bT{^8&PvC(aStU>SaI$HonSm=)y%F>LjEb<@AzXo>=o~x7a*o z+m|ej+(P-B>_UvrY1H)5>gm->io@fyGpKK0ul;l~k@ZykrEA8Nfg~K$G12NHg*WUD zHo&P6-Mm^nnWHCID$F6T!Q6N~ORL=gPLJK!I3A*1AgEwPviv%Y>&oX@QrxA%=O8^j zh1n`9J$7J3iLePTpw0PYf6RT}+jD06@Q?%H5(T*qK5{uOLykMWPC&GGja1$85tDT4 z$(%5JcuiaVt>c6)+Rr>P(e_h1v|@2yn#kO(#hI_67Ci@A*N2D(~F;VY}Wsnsd|2W4v-m z-oD|zhv2%EN@7%G6sAJ%w5zAA_SS9jOlZx*Md9*}RE`M=u+^$k5g65iyJj+KwJtW9 zPggFra;HW?e#eze7(~!3&ymd$ruQdZ_C_4ATw-%f&6VA!vgOn6wHu_Q`C9pI7N2*L zt_dNAZOl>!OkjsrUI!H7@L(Uc4FpwpMhF{2@1t}wX!-E1)G-x;>f=ME+?XHRogPqf zFXZj1Edu)$7MX-3cRc;MB4>aJNuGp%rt_(k{zDS;r@p1gm4v_RTk6ff#;3FIety~R zR%u6!~L9o{q+%q@9JM0+22p8!urq6RQA{JhkX1-cCF5S zeWECUfXQDBDUd~?$QFKiuhYZ*OZ4)870FT-Uh?I5)kU}e=L^DbjqLUFi2)@0m%sdl z{0mD)uM1TafHXie6vGhk2;%*3;pg;MB7CP{d%t(&2KD4WpBBE!-}^+KBf!Y5sUk^J zf7{THI_Y(bKes6S^|RrV9ep8C%i~~tj#iHX7H2e@na3nHizASj2@V70+ z|FDPuX;W|qY>S0I0jyPLugLkH-B%+!m?^&o*XaHEW7EGXB+q53Ki~PkV29w-`seQ* z?)c-)|AMuu8aX%b-@2!d+sHCBT_I?mU`p_=;J(hwh1>s+`^5U+?~GnLe3arpdoRCc z@aX{u7luon`max@Q$K&^e|VSw()X>Z|KIQY@%R~#r&v|1-RS&%xFJA({+l27zwi@s z&VS#{`1=Zek7(yixq1=;{@aJ6vx5seEJ!t6bz=UScf}5w@=`T zzrQb1@cCmUxc!X(YH$jHdi__zalO+w_+-T$VBO(=c?YA|`B~h47Vn=${IhucETW&q z?|Z*LYr)UL{aJuVmZpE-_WK#XZv$n`pHDmetc8Dku)$6IW99cAQU9@*uy+0#RMG2? z9o5|D-}d-F?cDw6#eVNd__Ox=wSRB)_u`K`{>!F*ztqpB{=R{KGRA)21cwzEZq(lo zS|al6U-a{@d!he0QoA7>p8xW59EP<&qn2UqNBH;;s?NV1S91UCtC$Bl=FeXp#?8-{ zIoGZJeA8(trWJwHLzi)y&cZ)<7#t1$=_BAS{b!uz{@;(FzwK=F`cE4Jb0AH3e-{0p zMdxSnd+_}phQ9~M=jXQHW8?Q7zkYs&Ou#=!@9*1w51-$I{yzrS@5j+Uk0XB;!r#|e z*cIvfx&D_u`R|NPc;?vsH#na;?;NaaU;FN!Ke@ap{`t}U_2qg9{i{+&V3U9T{3`K0 z%m4Cz{c)QBb^GG4-}n6r|G2FP7yV^8$N%s4t~{)!?fq9Wl#qLqsmn%1hSS;S?0wGJ zC>l=5RH%Dm!9YM zPdyK^#&^AIy?edy`h3>jzKLkCE1HI7F2o8sZ(bKqW zwoDq%#AtO2-0OE1SkeX=xxak4Kk};IcR}CzuyC1jP?x@jm|QrOl9i9el+gi;BV*@KmqqWF$K=R9>!28YZ4fM;jQv7g8C~(< zJ8m*{F}95E2^PVnj|1w;$^xpA(LH=io<0tO%VE;`MVUC0{+vYNhpsEIOE4t*d|((s zU%LcG;Pg3%C!Nf5hyXK}nGX(l1N1&PT&B#}xG3FbP?&M5{z8LYef&IwRmYD<^lf|= zdBXmN=+6iY3`IaVWCo%SuVM>CKmcS0TmmsgoW`@va5Fx~2(}H3&1Lc6VPXU`%rP=% znHm|RJf`9IOE{~-osf`F*WggWrV4u`7bR46boiD)3X#OaAdqkqMn>o%qHP@+;Tss> z8WIv107(M>1{vYu6A}ccS7CmhW5Pl_!S5#XsNR$6Ke|td*nL6-ML??MAT&H$%Js2bUMV&95TY+)!ouYl8-VO@WFRBGJAw^n2(Lq{VWU37&8=E*Z8 zFf16p&yA4NN8a{9P*?-xw1GhGHgIa-1iwO5r*8{=AkNSZ{0bL@Al20i{+H4cn~7GS9%IDsQPa2}k=n!yn4An>q*a#F!iut0f|kvrng zNk-b~4~fR2E-IsdfIt`~xyh1^QMK{UW0uvlDofOW98I^vC1fv}yxP!L_; z)Cd`&KgrWC+%pu8Z=qAfb{@5W+ zTBM&C>@Rpyqf`%))C4*8k}k+%s`|of+EB@l#1%ZqkQs==^Dr5@6_ureQRl2 z(SLAI&R%0eV?~mK^_Wjp3yKHU?&@68Ww)Ew+7C}!4o=&)(|h9nemP^*$_zW}*!^!u z?2(40U9$$gn0rO9pgj8UsPx2xk#oN(dercPWRGeIv9+OGrg+&3lq6QMNuXa~ zunnMdo`S_{5`rS+$&zTf@*_jdZAj-@kZDe43Lk3ZT5i3E!pusY7eNzb7vQ;Dn3x#5 zhIo1)gwV1jHYNDKSPnR`_Y4jodxAUr;Xdx3Gt7+<@nv~9FlHh8)4^MBb1Fd?$yB9n zim&ba2nLp9$~n3X!|L9Nb>ZH;UixQ0>=nK)*m!p;6m$>u4)f}*VjVQe9tdLi= z?fsxtesk8BJW?CpeQiU7Ux;G*e8#A!+@|!Hz{_V=5g)f)dDS#?-0r>;qK8@ZVSDoH zcJJ9e#q{b`wVo+u9?c)sTWZe|KL5K^JbGLD*}iXAKDD!cx=|%I&O3kQ_-Ole@KVOu zWw&aU_2Ufh+J9-%4kDgCmpYv`Yx^X zPF09P?D9$Koi=r1Oj7chsC>l8@Q#A25qd{4e1&h2LPhkV>&nw(I6+-zE6+OHBdELD za`TC*tBR&D6|16sy2ZRv@3X^b-#X2my|x(NRv+ltZJ~*g6;Gqnd6T$x>gy+dzOK8s z-^dmFGEA%tJ`4*TaH^a0iZ6e5y^dgAniZpBdv8`MckOXU;n?!KhsJ4jGe39bFVo0A z+q(8Wd%tG#2~ESE$Itbx8TdwF^h%d=8@f%r*saqIGy84>-xXSiCQx7{W)Z*6wpJacN_C!Bfe?C8%i zyWDOa-fchpz=UuWPVcP=V@hVuO`Pj=DCKacJFX4mw0f4F?f*zCXz7W5vsnT7LFMDU zD&zB)zbNieqx&}U^vEiW*D<|{Lf*J78B(aaOl#So>cqhp&J16t;;1}7rq_^7h_;`$ zt@?m&_1&6dd!NIsqxV{d4qc_buw=HI-r+y)7@fAz(w)9R!(x?o-x=C^Tk@i9EqsSM z>l)}54B2pLtcQ7UKZl8PEDvg@BQ83<)=#k7I6_y$alInoWV*9e(H{7x8L1T-QwIzrO6z5e(wmRS>@9lEKr zYsdiO@?8sWp2(Y)H};T)m7=yHxZ z_Y-?Y|6TDL;`8GZ-(ycsmerQs=j8azX*sQz{CQ-+$R)``ljkKXCMWKjY8QA*<5t=} z|9zGfOkZ7JSKqt7O}7~P6Uz3KMQkribHQ33e_j3j(5bjZC%*XpUHshO`Gx_h0}2Q9 zA7D2i1-pRvPYp=Dlv{#bme{>ErdCRM-w)1py*Af}o2Vd?PbHi}w z!~F)??t63Xy)vigUi;N~J;RA>bbR)4n+RjeDf;&ME;-h(GYqZMv(tB;F+bz9?DE;` z$i2C1jkXr;%~+Fh#&x@EW{vx>eM$RojLdY*9Cv}|er&;-w}!P&x`*P@EY@2jT$*Nc zr=rSs?y0i8GPU_nymhhtcz)@QLk}Dr4w&8klPDg4aY^RFt)EAAH&|=GHcj)PrpxG; zqix2#7(LiQ&!Mxuf8O&$UyARQq|SGCk1Ac|TkD>CZTG_`N3*lWREM8=88t4|`Orhn z{OS2+jXfKOHt9B@T@6-8t}f{L@lI&?i2T^7TfJXAtvPY+ZG3Il;fseKF1OfIo#t>& z?^=&*ncda;zUf;rreE-l1vMwMf|D2?jChyGpo|K;`^mMAFTPxzR+&&AUgBT!@Q%UV z<`Ye$dQIt-WWKg^*$8fA+oMD3DuZ7`-`=j(f zxi%{`hktqazVc1|m&ztfWuEc@m8YsZmCclAb~WtIQu(EGm~wHEVo`p~VEvme+OsP( zm5jfdgs&X0f~z_A`4ZBPF&aCd+pzG2UF6cp2<0(w(axkKe^TPbn-|U3CTLF4j4-=o zex85Jd>Vf-KZQRf#eTFy?qjof$9QD7f#%?WeHLqn2WNe}`EbhW+J;A}wXYcL*_(13 z?gbyM%eqo_aGgt$!-A261`htMTD>Li*K=8QQxAS{IT=x>T)82Cb<_I#3!~~2-a3Es z{Fa1|+p6h$0 z%FEm{{j&Ad-cLR}PJJA3<+n@kFEuU2=iw1yUWMV`R(&nPU(N5Cz4G?K+4oOQk8mzJ zRr7b@i$s6Kf70DISIn*?cn+)%SW{JD{ipSz!nxkLub*5nK51-SQ!wV5Q%}G1etrC2 zKAe}E?R!6E=$spWyIpy-=8>h&gY_?}9inD^et5Mp_GQ7Y#$8Pje}#98c<}JqsrU9< z+#KfIy?*d7=j^(x?{>U9ouZP zJYRhLW!k;c`;}*^{g;(1CUiRA)o_r8*6C#zKU&StHu693`k>}OaoLL<&rhB4TIRCM z^yQ?tNoD3M&3BcaOANa;uA-8=m%EX3E@AzJ!?g=a1DpT)+hp;t`=42{Gf#d}<_#g< zJ}Uh*`1N+R@pl)liQ4yUcyoH=vFna&95Ze|xE*(FC&y>;)Wy}$mY1jfcI~$@6SlT2 z`4Hc@B{lc5*OaoPYkjtDCDJ37zB9hC^6lEVzN^R13N<{H_xNVo!9xeDu0*Hg%z1k< zIO~2v(^tEc{ay#*Hd9nuRKd$t%?Y;$W>F|54aEs{V^} zlYUj>si?X?TG9q~THEEzD@NhsmN^d$o<&tP-{_jvYtDqLi+Ii6&F&4gJBF)Tj@-U) zLU!}5PnGks3O+RaSvj{X_jj+vRVPgJTarKLSQd9K%PJdXmS^_dJlni1{&W1pMTb9} ze{&^1rM!0K8NF}EJ|^GTpT0DrsldzaQpub7H(qR+Fu7`PA@SvQqkp}})5qlzKCgH0 zSyQ#Ya6)5rb4HWL@ZJH`Yuw}f8LYokFoEY+Hji1$04NODe;;~ z$5-sF8c&1Z45%$WL4FIxp^4O2ruf0)INS*#F+*xZ3DJgZL@6jF?nF*RiIT`k>yVNF z5+=~nI0zZc@BnB;P&l+F;SE(b2Iu=cb{i2To5jQ_7{PZUN^s4MRNE(_gr39#OT-h) z3nLK9D=r~BBxy>U@g(JhSEwnmN+kg$gcHJZzV8H-0%+_9B1#q;<^Z5_4g=6<98QV^ zsD&g-nU;9CXECB?8d3PDaQWPE%eRaRy;jj{qJK)>jLR)k!tTYIs@>UBp8q~ZrF)El zW=^Ju_F$b-?N1LNpe)|i+t=g`e}%@envXdvOc}#6?9?jFUimP7uixp=U*E}Wa0n}L zVfm_rId+)Gx|DUpR8Gw(@_QCn5#~Q|jPC13d-veto;D6ha0P_D!}gnAOIxs9L_C2{3{j4I*P zXp&q>SP6g>fIif)QrHOD3pK6;_J^RdB(M}Fh=u8hEIT60j>xhjvh0W~J0i=D$g(4{ z?1(HoBFq1;$Px&6BHx)BS_-{ivA_CnV@na08*P)x%|e9fD28!RaF59!lDUmZ(+Mi; z4|q@F3OKyiU0MNHN0JN{l{*c*Nl6Bq2jQr=3*gj9GJwuZ$snW|Tq-pY_#~1Vt$5s+ zR4NV=rAP%_3ULh%AY0Nt$go$S5V(KFrqX$VM7)(hLLbHEsaOgtmtVZ z6Ni>Y$dKdV<4|yK8sKA2oB$b z$2Q@iMmWkdB#%<4{89nwl)U-?pr~g!BIJTnX{RLkPbG`OT>^~N23b^md*esgqEe!1 z>w7ms5{6^E1rs@rCCwc_2$VT#f?rBcDA#aycwQ^jsT{7T z-02o^NZWC`MVwNKXjCH7f3Oh|hqN6<6LCtVqRHWk%GDZqtx9xU*iPmv;*?TE6Cci# zyz~E{H4%rjJ+(#}0hNX>hbt;qYa$M5JBlXaluETGhbt;yH1QbQ?|Cd5Jj9+MG|unv3z2IB?;0J!ZDEurEpB* zQR3vFMBGhP{kG_#f@^{je}M+!Nzgs;INIiiqU23vm?Lo~!gBwDAPR5okPGLH>sicH zGx@kJX1LYpQQy2@T_6fBpU2RW#LjA4V0P2D(|bK%a{xE&eui#B2@!cFd&BpVb3UZyx#Vv%j&c7jHP)*|JD z!o@>DWvRgk62!iK+qj*81S*2mb}&N!DsNLyFJ=Gm-lKBDMr1gZFh%U*;l3=x`2)yvr-@T#C@)@P;0WR8oWvhCzjp zqzD}jco?;Yv~zgNA*Bx~LWgrPHl>CXp~Ja2^_?hEgbwF&;Vz^^T!`95&>hYNNJpAM z2JajpbO-NOq;^8qMR6Xy+(TMgl*XaIcLvIF>F>HC(_|n%z+}loC-R4c{eA$VGBGhT y!B|W_kIyycVMYMm@%hF;{blownJ8*z{0|TnfNCO$N`OGggQz$F%W*^y)&BvWMitQj literal 0 HcmV?d00001 diff --git a/src/modules/Display/src/disp/disp_charmod.F90 b/src/modules/Display/src/disp/disp_charmod.F90 new file mode 100755 index 000000000..cd12e191e --- /dev/null +++ b/src/modules/Display/src/disp/disp_charmod.F90 @@ -0,0 +1,178 @@ +! Add-on module to DISPMODULE to display selected_real_kind(25) reals +! (these are probably 16 bytes and possibly snglruple precision) +! +! This module is obtained by copying the section SINGLE PRECSION PROCEDURES from +! dispmodule.F90, replacing sngl with sngl, single withe snglruple (only appears +! in comments) and cplx with cplx, adding a DECLARATIONS section, and defining +! the constant sngl as selected_real_kind(25). +! +! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of +! Iceland (jonasson@hi.is). This software is free. For details see the file README. + +MODULE DISP_CHARMOD +USE DISPMODULE_UTIL +USE GlobalData, ONLY: Real32 +PRIVATE +PUBLIC DISP + +INTERFACE DISP + MODULE PROCEDURE disp_ts_dchr, disp_v_dchr, disp_tv_dchr, disp_m_dchr, disp_tm_dchr +END INTERFACE DISP + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine disp_v_dchr(x, fmt, advance, lbound, sep, style, trim, unit, orient) + ! Default character vector without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient + character(*), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tv_dchr('', x, fmt, advance, lbound, sep, style, trim, unit, orient) +end subroutine disp_v_dchr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine disp_m_dchr(x, fmt, advance, lbound, sep, style, trim, unit) + ! Default character matrix without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim + character(*), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tm_dchr('', x, fmt, advance, lbound, sep, style, trim, unit) +end subroutine disp_m_dchr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine disp_ts_dchr(title, x, fmt, advance, sep, style, trim, unit) + ! Default character scalar with title + character(*), intent(in), optional :: title, x, fmt, advance, sep, style, trim + character(0) empty(1,0) + integer, intent(in), optional :: unit + empty = '' + if (present(title).and.present(x)) then + call disp_nonopt_dchr(title, x, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) + elseif (present(x)) then + call disp_nonopt_dchr('', x, fmt, advance, sep=sep, style='left', trim=trim, unit=unit) + elseif (present(title)) then + call disp_nonopt_dchr('', title, fmt, advance, sep=sep, style='left', trim=trim, unit=unit) + else + call disp_tm_dchr('', empty, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) + end if +end subroutine disp_ts_dchr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine disp_nonopt_dchr(title, x, fmt, advance, sep, style, trim, unit) + ! This routine exists to circumvent bug in gfortran, that made it not possible to change scalar strings + ! to matrices with reshape in calls of disp_tm_dchr. This intermediate routine provides work-around. + character(*), intent(in) :: title, x, fmt, advance, sep, style, trim + optional fmt, advance, sep, style, trim + integer, intent(in), optional :: unit + character(len(x)) :: xm(1,1) + xm(1,1) = x + call disp_tm_dchr(title, xm, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) +end subroutine disp_nonopt_dchr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine disp_tv_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit, orient) + ! Default character vector with title + character(*), intent(in) :: title, x(:) + character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient + integer, intent(in), optional :: unit, lbound(:) + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient) + if (SE%row) then + call disp_dchr(title, reshape(x, (/1, size(x)/)), SE) + else + call disp_dchr(title, reshape(x, (/size(x), 1/)), SE) + end if +end subroutine disp_tv_dchr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine disp_tm_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit) + ! Default character matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + character(*), intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'A4') + integer, intent(in), optional :: unit ! Unit to display on + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: style ! Style(s): see NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + ! + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit) + call disp_dchr(title, x, SE) +end subroutine disp_tm_dchr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine disp_dchr(title, x, SE) + ! Default character item to box + character(*), intent(in) :: title, x(:,:) + type(settings), intent(INOUT ) :: SE + character(13) :: edesc + character, pointer :: boxp(:,:) + integer :: m, n, j, lin1, wleft, lx, w + integer, dimension(size(x,2)) :: wid, nbl, n1, n2, widp + m = size(x,1) + n = size(x,2) + lx = len(x) + w = SE%w + if (w <= 0) then + w = lx + if (w < 0) then + edesc = '(A__________)' + write(edesc(3:12), '(SS,I10)') w + SE%ed = edesc + end if + end if + if (SE%trm .and. size(x) > 0) then + n1 = minval(mod(verify(x, ' ') - w - 1, w + 1), 1) + w + 1 + n2 = maxval(verify(x, ' ', back = .true.), 1) + wid = n2 - n1 + 1 + nbl = w - wid + else + n1 = 1 + n2 = w + wid = w + nbl = 0 + end if + if (all(wid == 0)) n = 0 + SE%w = w + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (SE%trm) then + call copytobox(x(:,j)(n1(j):n2(j)), lin1, wid(j), widp(j), nbl(j), boxp, wleft) + else + if (widp(j) > lx) call copyseptobox(repeat(' ', widp(j)-lx), m, lin1, boxp, wleft) + call copytobox(x(:,j), lin1, lx, lx, 0, boxp, wleft) + end if + if (j 0) write(s, SE%ed) x(:,j) + if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j 0) then + wid = merge(SE%lzas, wid, xallz) + wid = max(wid, merge(SE%lzas, 0, xzero)) + nbl = w - wid + endif + end subroutine getwid_byte + + ! ********* 1-BYTE INTEGER TOSTRING PROCEDURES ********* + function tostring_s_byte(x) result(st) + ! Scalar to string + integer(byte), intent(in) :: x + character(len_f_byte((/x/), tosset0%ifmt)) :: st + st = tostring_f_byte((/x/), tosset0%ifmt) + end function tostring_s_byte + + function tostring_sf_byte(x, fmt) result(st) + ! Scalar with specified format to string + integer(byte),intent(in) :: x + character(*), intent(in) :: fmt + character(len_f_byte((/x/), fmt)) :: st + st = tostring_f_byte((/x/), fmt) + end function tostring_sf_byte + + function tostring_byte(x) result(st) + ! Vector to string + integer(byte), intent(in) :: x(:) + character(len_f_byte(x, tosset0%ifmt)) :: st + st = tostring_f_byte(x, tosset0%ifmt) + end function tostring_byte + + function tostring_f_byte(x, fmt) result(st) + ! Vector with specified format to string + integer(byte), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(len_f_byte(x, fmt)) :: st + character(widthmax_byte(x, fmt)) :: sa(size(x)) + integer :: w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; st = errormsg; return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + call tostring_get(sa, st) + end function tostring_f_byte + + pure function len_f_byte(x, fmt) result(wtot) + ! Total width of tostring representation of x + integer(byte), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(widthmax_byte(x, fmt)) :: sa(size(x)) + integer :: wtot, w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; wtot = len(errormsg); return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) + end function len_f_byte + + pure function widthmax_byte(x, fmt) result(w) + ! Maximum width of string representation of an element in x + integer(byte), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(range(x)+2) sx(2) + integer w, d + logical gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w<=0) then + write(sx, '(SS,I0)') maxval(x), minval(x) + w = maxval(len_trim(sx)) + end if + end function widthmax_byte + +END MODULE DISP_I1MOD diff --git a/src/modules/Display/src/disp/disp_i2mod.F90 b/src/modules/Display/src/disp/disp_i2mod.F90 new file mode 100755 index 000000000..3fa00b9b5 --- /dev/null +++ b/src/modules/Display/src/disp/disp_i2mod.F90 @@ -0,0 +1,276 @@ +MODULE DISP_I2MOD + + ! Add-on module to DISPMODULE to display 2-byte integers + ! (assuming that these are obtained with selected_int_kind(4)) + ! + ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from + ! from dispmodule.F90, replacing dint with byt2 and default integer' with 2-byte + ! integer (only appears in comments), and adding the DECLARATIONS section below. + ! + ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of + ! Iceland (jonasson@hi.is). This software is free. For details see the file README. + + ! ******************************** DECLARATIONS ******************************************** + USE DISPMODULE_UTIL + USE GlobalData, ONLY: Int16 + IMPLICIT NONE + PRIVATE + + PUBLIC DISP + PUBLIC TOSTRING + + interface Display + module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2 + end interface + + interface disp + module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2 + end interface + + interface tostring + module procedure tostring_byt2, tostring_f_byt2, tostring_s_byt2, tostring_sf_byt2 + end interface + + ! integer, parameter :: byt2 = selected_int_kind(4) + integer, parameter :: byt2 = Int16 + +CONTAINS + + ! ******************************** 2-BYTE INTEGER PROCEDURES ******************************* + subroutine disp_s_byt2(x, fmt, advance, sep, trim, unit, zeroas) + ! 2-byte integer scalar without title + character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas + integer(byt2), intent(in) :: x + integer, intent(in), optional :: unit + call disp_ts_byt2('', x, fmt, advance, sep, 'left', trim, unit, zeroas) + end subroutine disp_s_byt2 + + subroutine disp_v_byt2(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + ! 2-byte integer vector without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient + integer(byt2), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tv_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + end subroutine disp_v_byt2 + + subroutine disp_m_byt2(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + ! 2-byte integer matrix without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas + integer(byt2), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tm_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + end subroutine disp_m_byt2 + + subroutine disp_ts_byt2(title, x, fmt, advance, sep, style, trim, unit, zeroas) + ! 2-byte integer scalar with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas + integer(byt2), intent(in) :: x + integer, intent(in), optional :: unit + call disp_tm_byt2(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & + zeroas=zeroas) + end subroutine disp_ts_byt2 + + subroutine disp_tv_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + ! 2-byte integer vector with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient + integer(byt2), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + if (SE%row) then + call disp_byt2(title, reshape(x, (/1, size(x)/)), SE) + else + call disp_byt2(title, reshape(x, (/size(x), 1/)), SE) + end if + end subroutine disp_tv_byt2 + + subroutine disp_tm_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + ! 2-byte integer matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + integer(byt2),intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') + integer, intent(in), optional :: unit ! Unit to display on + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string + character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, + ! ! trimming, 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) + call disp_byt2(title, x, SE) + end subroutine disp_tm_byt2 + + subroutine disp_byt2(title, x, SE) + ! 2-byte integer item + character(*), intent(in) :: title + integer(byt2), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer wid(size(x,2)), nbl(size(x,2)) + call find_editdesc_byt2(x, SE, wid, nbl) ! determine also SE%w + call tobox_byt2(title, x, SE, wid, nbl) + end subroutine disp_byt2 + + subroutine tobox_byt2(title, x, SE, wid, nbl) + ! Write 2-byte integer matrix to box + character(*), intent(in) :: title + integer(byt2), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer, intent(INOUT ) :: wid(:) + integer, intent(INOUT ) :: nbl(:) + character(SE%w) :: s(size(x,1)) + integer :: lin1, j, wleft, m, n, widp(size(wid)) + character, pointer :: boxp(:,:) + m = size(x,1) + n = size(x,2) + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (m > 0) write(s, SE%ed) x(:,j) + if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j 0) then + wid = merge(SE%lzas, wid, xallz) + wid = max(wid, merge(SE%lzas, 0, xzero)) + nbl = w - wid + endif + end subroutine getwid_byt2 + + ! ********* 2-BYTE INTEGER TOSTRING PROCEDURES ********* + function tostring_s_byt2(x) result(st) + ! Scalar to string + integer(byt2), intent(in) :: x + character(len_f_byt2((/x/), tosset0%ifmt)) :: st + st = tostring_f_byt2((/x/), tosset0%ifmt) + end function tostring_s_byt2 + + function tostring_sf_byt2(x, fmt) result(st) + ! Scalar with specified format to string + integer(byt2),intent(in) :: x + character(*), intent(in) :: fmt + character(len_f_byt2((/x/), fmt)) :: st + st = tostring_f_byt2((/x/), fmt) + end function tostring_sf_byt2 + + function tostring_byt2(x) result(st) + ! Vector to string + integer(byt2), intent(in) :: x(:) + character(len_f_byt2(x, tosset0%ifmt)) :: st + st = tostring_f_byt2(x, tosset0%ifmt) + end function tostring_byt2 + + function tostring_f_byt2(x, fmt) result(st) + ! Vector with specified format to string + integer(byt2), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(len_f_byt2(x, fmt)) :: st + character(widthmax_byt2(x, fmt)) :: sa(size(x)) + integer :: w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; st = errormsg; return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + call tostring_get(sa, st) + end function tostring_f_byt2 + + pure function len_f_byt2(x, fmt) result(wtot) + ! Total width of tostring representation of x + integer(byt2), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(widthmax_byt2(x, fmt)) :: sa(size(x)) + integer :: wtot, w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; wtot = len(errormsg); return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) + end function len_f_byt2 + + pure function widthmax_byt2(x, fmt) result(w) + ! Maximum width of string representation of an element in x + integer(byt2), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(range(x)+2) sx(2) + integer w, d + logical gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w<=0) then + write(sx, '(SS,I0)') maxval(x), minval(x) + w = maxval(len_trim(sx)) + end if + end function widthmax_byt2 + ! ************************************* END OF 2-BYTE INTEGER PROCEDURES ****************************************** + +END MODULE DISP_I2MOD diff --git a/src/modules/Display/src/disp/disp_i4mod.F90 b/src/modules/Display/src/disp/disp_i4mod.F90 new file mode 100755 index 000000000..497fe3d7d --- /dev/null +++ b/src/modules/Display/src/disp/disp_i4mod.F90 @@ -0,0 +1,270 @@ +MODULE DISP_I4MOD + + ! Add-on module to DISPMODULE to display 4-byte integers + ! (assuming that these are obtained with selected_int_kind(18)) + ! + ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from + ! from dispmodule.F90, replacing dint with byt4 and 'default integer' with 4-byte + ! integer (only appears in comments), and adding the DECLARATIONS section below. + ! + ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of + ! Iceland (jonasson@hi.is). This software is free. For details see the file README. + + ! ******************************** DECLARATIONS ******************************************** + USE dispmodule_util + USE GlobalData, ONLY: Int32 + IMPLICIT NONE + PRIVATE + PUBLIC DISP + PUBLIC TOSTRING + + interface disp + module procedure disp_s_byt4, disp_ts_byt4, disp_v_byt4, disp_tv_byt4, disp_m_byt4, disp_tm_byt4 + end interface + + interface tostring + module procedure tostring_byt4, tostring_f_byt4, tostring_s_byt4, tostring_sf_byt4 + end interface + + integer, parameter :: byt4 = Int32 + +CONTAINS + + ! ******************************** 4-BYTE INTEGER PROCEDURES ******************************* + subroutine disp_s_byt4(x, fmt, advance, sep, trim, unit, zeroas) + ! 4-byte integer scalar without title + character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas + integer(byt4), intent(in) :: x + integer, intent(in), optional :: unit + call disp_ts_byt4('', x, fmt, advance, sep, 'left', trim, unit, zeroas) + end subroutine disp_s_byt4 + + subroutine disp_v_byt4(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + ! 4-byte integer vector without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient + integer(byt4), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tv_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + end subroutine disp_v_byt4 + + subroutine disp_m_byt4(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + ! 4-byte integer matrix without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas + integer(byt4), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tm_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + end subroutine disp_m_byt4 + + subroutine disp_ts_byt4(title, x, fmt, advance, sep, style, trim, unit, zeroas) + ! 4-byte integer scalar with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas + integer(byt4), intent(in) :: x + integer, intent(in), optional :: unit + call disp_tm_byt4(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & + zeroas=zeroas) + end subroutine disp_ts_byt4 + + subroutine disp_tv_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + ! 4-byte integer vector with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient + integer(byt4), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + if (SE%row) then + call disp_byt4(title, reshape(x, (/1, size(x)/)), SE) + else + call disp_byt4(title, reshape(x, (/size(x), 1/)), SE) + end if + end subroutine disp_tv_byt4 + + subroutine disp_tm_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + ! 4-byte integer matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + integer(byt4),intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') + integer, intent(in), optional :: unit ! Unit to display on + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string + character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, + ! ! trimming, 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) + call disp_byt4(title, x, SE) + end subroutine disp_tm_byt4 + + subroutine disp_byt4(title, x, SE) + ! 4-byte integer item + character(*), intent(in) :: title + integer(byt4), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer wid(size(x,2)), nbl(size(x,2)) + call find_editdesc_byt4(x, SE, wid, nbl) ! determine also SE%w + call tobox_byt4(title, x, SE, wid, nbl) + end subroutine disp_byt4 + + subroutine tobox_byt4(title, x, SE, wid, nbl) + ! Write 4-byte integer matrix to box + character(*), intent(in) :: title + integer(byt4), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer, intent(INOUT ) :: wid(:) + integer, intent(INOUT ) :: nbl(:) + character(SE%w) :: s(size(x,1)) + integer :: lin1, j, wleft, m, n, widp(size(wid)) + character, pointer :: boxp(:,:) + m = size(x,1) + n = size(x,2) + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (m > 0) write(s, SE%ed) x(:,j) + if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j 0) then + wid = merge(SE%lzas, wid, xallz) + wid = max(wid, merge(SE%lzas, 0, xzero)) + nbl = w - wid + endif + end subroutine getwid_byt4 + + ! ********* 4-BYTE INTEGER TOSTRING PROCEDURES ********* + function tostring_s_byt4(x) result(st) + ! Scalar to string + integer(byt4), intent(in) :: x + character(len_f_byt4((/x/), tosset0%ifmt)) :: st + st = tostring_f_byt4((/x/), tosset0%ifmt) + end function tostring_s_byt4 + + function tostring_sf_byt4(x, fmt) result(st) + ! Scalar with specified format to string + integer(byt4),intent(in) :: x + character(*), intent(in) :: fmt + character(len_f_byt4((/x/), fmt)) :: st + st = tostring_f_byt4((/x/), fmt) + end function tostring_sf_byt4 + + function tostring_byt4(x) result(st) + ! Vector to string + integer(byt4), intent(in) :: x(:) + character(len_f_byt4(x, tosset0%ifmt)) :: st + st = tostring_f_byt4(x, tosset0%ifmt) + end function tostring_byt4 + + function tostring_f_byt4(x, fmt) result(st) + ! Vector with specified format to string + integer(byt4), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(len_f_byt4(x, fmt)) :: st + character(widthmax_byt4(x, fmt)) :: sa(size(x)) + integer :: w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; st = errormsg; return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + call tostring_get(sa, st) + end function tostring_f_byt4 + + pure function len_f_byt4(x, fmt) result(wtot) + ! Total width of tostring representation of x + integer(byt4), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(widthmax_byt4(x, fmt)) :: sa(size(x)) + integer :: wtot, w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; wtot = len(errormsg); return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) + end function len_f_byt4 + + pure function widthmax_byt4(x, fmt) result(w) + ! Maximum width of string representation of an element in x + integer(byt4), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(range(x)+2) sx(2) + integer w, d + logical gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w<=0) then + write(sx, '(SS,I0)') maxval(x), minval(x) + w = maxval(len_trim(sx)) + end if + end function widthmax_byt4 + ! ************************************* END OF 4-BYTE INTEGER PROCEDURES ****************************************** + +END MODULE DISP_I4MOD diff --git a/src/modules/Display/src/disp/disp_i8mod.F90 b/src/modules/Display/src/disp/disp_i8mod.F90 new file mode 100755 index 000000000..54794d25c --- /dev/null +++ b/src/modules/Display/src/disp/disp_i8mod.F90 @@ -0,0 +1,270 @@ +MODULE DISP_I8MOD + + ! Add-on module to DISPMODULE to display 8-byte integers + ! (assuming that these are obtained with selected_int_kind(18)) + ! + ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from + ! from dispmodule.F90, replacing dint with byt8 and 'default integer' with 8-byte + ! integer (only appears in comments), and adding the DECLARATIONS section below. + ! + ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of + ! Iceland (jonasson@hi.is). This software is free. For details see the file README. + + USE DISPMODULE_UTIL + use GlobalData, ONLY: Int64 + + PUBLIC DISP + PUBLIC TOSTRING + + PRIVATE + + interface disp + module procedure disp_s_byt8, disp_ts_byt8, disp_v_byt8, disp_tv_byt8, disp_m_byt8, disp_tm_byt8 + end interface + + interface tostring + module procedure tostring_byt8, tostring_f_byt8, tostring_s_byt8, tostring_sf_byt8 + end interface + + integer, parameter :: byt8 = Int64 + +CONTAINS + + ! ******************************** 8-BYTE INTEGER PROCEDURES ******************************* + subroutine disp_s_byt8(x, fmt, advance, sep, trim, unit, zeroas) + ! 8-byte integer scalar without title + character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas + integer(byt8), intent(in) :: x + integer, intent(in), optional :: unit + call disp_ts_byt8('', x, fmt, advance, sep, 'left', trim, unit, zeroas) + end subroutine disp_s_byt8 + + subroutine disp_v_byt8(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + ! 8-byte integer vector without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient + integer(byt8), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tv_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + end subroutine disp_v_byt8 + + subroutine disp_m_byt8(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + ! 8-byte integer matrix without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas + integer(byt8), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tm_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + end subroutine disp_m_byt8 + + subroutine disp_ts_byt8(title, x, fmt, advance, sep, style, trim, unit, zeroas) + ! 8-byte integer scalar with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas + integer(byt8), intent(in) :: x + integer, intent(in), optional :: unit + call disp_tm_byt8(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & + zeroas=zeroas) + end subroutine disp_ts_byt8 + + subroutine disp_tv_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + ! 8-byte integer vector with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient + integer(byt8), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) + if (SE%row) then + call disp_byt8(title, reshape(x, (/1, size(x)/)), SE) + else + call disp_byt8(title, reshape(x, (/size(x), 1/)), SE) + end if + end subroutine disp_tv_byt8 + + subroutine disp_tm_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) + ! 8-byte integer matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + integer(byt8),intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') + integer, intent(in), optional :: unit ! Unit to display on + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string + character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, + ! ! trimming, 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) + call disp_byt8(title, x, SE) + end subroutine disp_tm_byt8 + + subroutine disp_byt8(title, x, SE) + ! 8-byte integer item + character(*), intent(in) :: title + integer(byt8), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer wid(size(x,2)), nbl(size(x,2)) + call find_editdesc_byt8(x, SE, wid, nbl) ! determine also SE%w + call tobox_byt8(title, x, SE, wid, nbl) + end subroutine disp_byt8 + + subroutine tobox_byt8(title, x, SE, wid, nbl) + ! Write 8-byte integer matrix to box + character(*), intent(in) :: title + integer(byt8), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer, intent(INOUT ) :: wid(:) + integer, intent(INOUT ) :: nbl(:) + character(SE%w) :: s(size(x,1)) + integer :: lin1, j, wleft, m, n, widp(size(wid)) + character, pointer :: boxp(:,:) + m = size(x,1) + n = size(x,2) + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (m > 0) write(s, SE%ed) x(:,j) + if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j 0) then + wid = merge(SE%lzas, wid, xallz) + wid = max(wid, merge(SE%lzas, 0, xzero)) + nbl = w - wid + endif + end subroutine getwid_byt8 + + ! ********* 8-BYTE INTEGER TOSTRING PROCEDURES ********* + function tostring_s_byt8(x) result(st) + ! Scalar to string + integer(byt8), intent(in) :: x + character(len_f_byt8((/x/), tosset0%ifmt)) :: st + st = tostring_f_byt8((/x/), tosset0%ifmt) + end function tostring_s_byt8 + + function tostring_sf_byt8(x, fmt) result(st) + ! Scalar with specified format to string + integer(byt8),intent(in) :: x + character(*), intent(in) :: fmt + character(len_f_byt8((/x/), fmt)) :: st + st = tostring_f_byt8((/x/), fmt) + end function tostring_sf_byt8 + + function tostring_byt8(x) result(st) + ! Vector to string + integer(byt8), intent(in) :: x(:) + character(len_f_byt8(x, tosset0%ifmt)) :: st + st = tostring_f_byt8(x, tosset0%ifmt) + end function tostring_byt8 + + function tostring_f_byt8(x, fmt) result(st) + ! Vector with specified format to string + integer(byt8), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(len_f_byt8(x, fmt)) :: st + character(widthmax_byt8(x, fmt)) :: sa(size(x)) + integer :: w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; st = errormsg; return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + call tostring_get(sa, st) + end function tostring_f_byt8 + + pure function len_f_byt8(x, fmt) result(wtot) + ! Total width of tostring representation of x + integer(byt8), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(widthmax_byt8(x, fmt)) :: sa(size(x)) + integer :: wtot, w, d + logical :: gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; wtot = len(errormsg); return; endif + write(sa, fmt1) x + if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) + wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) + end function len_f_byt8 + + pure function widthmax_byt8(x, fmt) result(w) + ! Maximum width of string representation of an element in x + integer(byt8), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(range(x)+2) sx(2) + integer w, d + logical gedit + character(nnblk(fmt)+5) :: fmt1 + call readfmt(fmt, fmt1, w, d, gedit) + if (w<=0) then + write(sx, '(SS,I0)') maxval(x), minval(x) + w = maxval(len_trim(sx)) + end if + end function widthmax_byt8 + ! ************************************* END OF 8-BYTE INTEGER PROCEDURES ****************************************** + +END MODULE DISP_I8MOD diff --git a/src/modules/Display/src/disp/disp_l1mod.F90 b/src/modules/Display/src/disp/disp_l1mod.F90 new file mode 100755 index 000000000..ae1012cac --- /dev/null +++ b/src/modules/Display/src/disp/disp_l1mod.F90 @@ -0,0 +1,202 @@ +MODULE DISP_L1MOD + + ! Add-on module to DISPMODULE to display 1-byte logical items + ! (assuming that these have kind = 1) + ! + ! This module is obtained by copying the section DEFAULT LOGICAL PROCEDURES from + ! dispmodule.F90, replacing dlog with log1 and 'default logical' with '1-byte + ! logical' (only appears in comments), and adding the DECLARATIONS section below. + ! + ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of + ! Iceland (jonasson@hi.is). This software is free. For details see the file README. + + use dispmodule_util + USE GlobalData, ONLY: LGT + PUBLIC DISP + PUBLIC TOSTRING + + PRIVATE + + interface Display + module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1 + end interface + + interface disp + module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1 + end interface + + interface tostring + module procedure tostring_log1, tostring_f_log1, tostring_s_log1, tostring_sf_log1 + end interface + + integer, parameter :: log1 = LGT ! hopefully logical(1) is byte + +CONTAINS + + ! ********************************************** 1-BYTE LOGICAL PROCEDURES ************************************************* + subroutine disp_s_log1(x, fmt, advance, sep, trim, unit) + ! 1-byte logical scalar without title + character(*), intent(in), optional :: fmt, advance, sep, trim + logical(log1), intent(in) :: x + integer, intent(in), optional :: unit + call disp_ts_log1('', x, fmt, advance, sep, 'left', trim, unit) + end subroutine disp_s_log1 + + subroutine disp_v_log1(x, fmt, advance, lbound, sep, style, trim, unit, orient) + ! 1-byte logical vector without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient + logical(log1), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tv_log1('', x, fmt, advance, lbound, sep, style, trim, unit, orient) + end subroutine disp_v_log1 + + subroutine disp_m_log1(x, fmt, advance, lbound, sep, style, trim, unit) + ! 1-byte logical matrix without title + character(*), intent(in), optional :: fmt, advance, sep, style, trim + logical(log1), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, lbound(:) + call disp_tm_log1('', x, fmt, advance, lbound, sep, style, trim, unit) + end subroutine disp_m_log1 + + subroutine disp_ts_log1(title, x, fmt, advance, sep, style, trim, unit) + ! 1-byte logical scalar with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim + logical(log1), intent(in) :: x + integer, intent(in), optional :: unit + call disp_tm_log1(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit) + end subroutine disp_ts_log1 + + subroutine disp_tv_log1(title, x, fmt, advance, lbound, sep, style, trim, unit, orient) + ! 1-byte logical vector with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient + logical(log1), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:) + type(settings) :: SE + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient) + if (SE%row) then + call disp_log1(title, reshape(x, (/1, size(x)/)), SE) + else + call disp_log1(title, reshape(x, (/size(x), 1/)), SE) + end if + end subroutine disp_tv_log1 + + subroutine disp_tm_log1(title, x, fmt, advance, lbound, sep, style, trim, unit) + ! 1-byte logical matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + logical(log1),intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g. 'L1') + integer, intent(in), optional :: unit ! Unit to display on + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, + ! ! 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + type(settings) :: SE + ! + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit) + call disp_log1(title, x, SE) + end subroutine disp_tm_log1 + + subroutine disp_log1(title, x, SE) + ! Write 1-byte logical to box or unit + character(*), intent(in) :: title + logical(log1), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer wid(size(x,2)), nbl(size(x,2)) + if (SE%w <= 0 .or. SE%trm) then + SE%ed = '(L1)' + if (size(x) == 0) then + wid = 0 + else + wid = 1 + endif + SE%w = 1 + nbl = SE%w - wid + else + wid = SE%w + nbl = 0 + endif + call tobox_log1(title, x, SE, wid, nbl) + end subroutine disp_log1 + + subroutine tobox_log1(title, x, SE, wid, nbl) + character(*), intent(in) :: title + logical(log1), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE + integer, intent(INOUT ) :: wid(:) + integer, intent(INOUT ) :: nbl(:) + character(SE%w) :: s(size(x,1)) + integer :: m, n, lin1, i, j, wleft, widp(size(wid)) + character, pointer :: boxp(:,:) + m = size(x,1) + n = size(x,2) + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (m > 0) write(s, SE%ed) (x(i,j), i=1,m) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j 0) write(s, SE%ed) xj + call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf + if (.not. any(xfinite)) then + w = 4 + else + xmax = maxval(x, mask=xfinite) + xmin = minval(x, mask=xfinite) + f1 = '(SS,ES9.0E4)' + write(s,f1) xmax, xmin + read(s(:)(5:9),'(I5)') expmax, expmin + w = max(0, expmax, expmin) + d + 4 + end if + if (.not. all(xfinite)) w = max(w, 4) + end function maxw_quad + + subroutine find_editdesc_quad(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid. + ! The if-block (*) is for safety: make f wider in case xm is written ok with the + ! ES format in fmt but overflows with F format (the feature has been tested through + ! manual changes to the program). + real(quad), intent(in) :: x(:,:) ! Item to be written + type(settings), intent(INOUT ) :: SE ! Settings + integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns + integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns + integer :: expmax, expmin, ww, dd, dmx + real(quad) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h + character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 + character(99) s + logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) + ! + dmx = SE%dmx + h = huge(h) + xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf + if (SE%w == 0) then ! Edit descriptor 'F0.d' specified + ww = maxw_quad(reshape(x, (/size(x)/)), SE%d) + if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas) + call replace_w(SE%ed, ww) + SE%w = ww + elseif (SE%w < 0) then ! No edit descriptor specified + if (size(x) == 0) then + SE%w = 0 + wid = 0 + nbl = 0 + return + endif + if (any(xfinite)) then + xp = maxval(x, mask=xfinite) + xm = minval(x, mask=xfinite) + write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 + write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax + write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin + call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) + if (.not. all(xfinite)) ww = max(ww, 4) + if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas) + if (SE%ed(5:5)=='F') then ! (*) + write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 + write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 + write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd + endif + else + ww = 4 + SE%ed = '(F4.0)' + endif + SE%w = ww + endif + if (SE%trm) then + xmaxv = maxval(x, 1, mask=xfinite) ! max in each column + xminv = minval(x, 1, mask=xfinite) ! min + xzero = any(x == 0._quad, 1) ! true where column has some zeros + xallz = all(x == 0._quad, 1) ! true where column has only zeros + xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) + xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) + call getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + else + wid = SE%w + nbl = 0 + endif + end subroutine find_editdesc_quad + + subroutine getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ! determine length of the strings that result when writing with edit descriptor SE%ed a + ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output + real(quad), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column + logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros + logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals + type(settings), intent(in) :: SE ! settings + integer, intent(out) :: wid(:) ! widths of columns + integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) + character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) + integer w + w = SE%w + write(stmin, SE%ed) xminv + write(stmax, SE%ed) xmaxv + nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) + if (SE%gedit) then + wid = w + else + wid = len_trim(adjustl(stmin)) + wid = max(wid, len_trim(adjustl(stmax))) + endif + if (SE%lzas > 0) then + wid = merge(SE%lzas, wid, xallz) + wid = max(wid, merge(SE%lzas, 0, xzero)) + endif + wid = merge(4, wid, xalln) + wid = max(wid, merge(4, 0, xnonn)) + nbl = w - wid + end subroutine getwid_quad + + ! ******** TOSTRING QUADRUPLE PRECISION PROCEDURES *********** + function tostring_s_quad(x) result(st) + ! Scalar to string + real(quad), intent(in) :: x + character(len_f_quad((/x/), tosset0%rfmt)) :: st + st = tostring_f_quad((/x/), tosset0%rfmt) + end function tostring_s_quad + + function tostring_sf_quad(x, fmt) result(st) + ! Scalar with specified format to string + real(quad), intent(in) :: x + character(*), intent(in) :: fmt + character(len_f_quad((/x/), fmt)) :: st + st = tostring_f_quad((/x/), fmt) + end function tostring_sf_quad + + function tostring_quad(x) result(st) + ! Vector to string + real(quad), intent(in) :: x(:) + character(len_f_quad(x, tosset0%rfmt)) :: st + st = tostring_f_quad(x, tosset0%rfmt) + end function tostring_quad + + function tostring_f_quad(x, fmt) result(st) + ! Vector with specified format to string + real(quad) , intent(in) :: x(:) + character(*), intent(in) :: fmt + character(len_f_quad(x, fmt)) :: st + character(widthmax_quad(x, fmt)) :: sa(size(x)) + character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) + integer :: w, d, ww + logical :: gedit + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then + st = errormsg + return + elseif (w == 0) then + ww = maxw_quad(x, d) + call replace_w(fmt1, ww) + endif + write(sa, fmt1) x + call trim_real(sa, gedit, w) + call tostring_get(sa, st) + end function tostring_f_quad + + pure function len_f_quad(x, fmt) result(wtot) + ! Total length of returned string, vector s + real(quad), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(widthmax_quad(x, fmt)) :: sa(size(x)) + integer :: wtot, w, d, ww + logical :: gedit + character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; wtot = len(errormsg); return; endif + if (w == 0) then + ww = maxw_quad(x, d) + call replace_w(fmt1, ww) + endif + write(sa, fmt1) x + call trim_real(sa, gedit, w) + wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) + end function len_f_quad + + pure function widthmax_quad(x, fmt) result(w) + ! Maximum width of an element of x + real(quad), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(nnblk(fmt)+5) :: fmt1 + integer w, d + logical gedit + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then ! illegal format, use 1 + w = 1 + elseif (w == 0) then + w = maxw_quad(x, d) + endif + end function widthmax_quad + + ! *************************************** END OF QUADRUPLE PRECISION PROCEDURES *************************************** + + ! *************************************** QUADRUPLE PRECISION COMPLEX PROCEDURES ************************************** + subroutine disp_s_cplq(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) + ! quadruple precision complex scalar without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim + complex(quad), intent(in) :: x + integer, intent(in), optional :: unit, digmax + call disp_ts_cplq('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) + end subroutine disp_s_cplq + + subroutine disp_v_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + ! quadruple precision complex vector without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient + complex(quad), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:), digmax + call disp_tv_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + end subroutine disp_v_cplq + + subroutine disp_m_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + ! quadruple precision complex matrix without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim + complex(quad), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, digmax, lbound(:) + call disp_tm_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + end subroutine disp_m_cplq + + subroutine disp_ts_cplq(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) + ! quadruple precision complex scalar with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim + complex(quad), intent(in) :: x + integer, intent(in), optional :: unit, digmax + call disp_tm_cplq(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, & + trim=trim, unit=unit) + end subroutine disp_ts_cplq + + subroutine disp_tv_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + ! quadruple precision complex vector with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient + complex(quad), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:), digmax + type(settings) SE, SEim + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) + if (present(fmt_imag)) then + if (.not.present(fmt)) then + call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; + endif + call get_SE(SEim, title, shape(x), fmt_imag) + else + SEim = SE + end if + if (SE%row) then + call disp_cplq(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) + else + call disp_cplq(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) + end if + end subroutine disp_tv_cplq + + subroutine disp_tm_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + ! quadruple precision complex matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + complex(quad), intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & + ! ! is present) + character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element + integer, intent(in), optional :: unit ! Unit to display on + integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & + ! ! and aimag(x) + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + ! + type(settings) :: SE, SEim + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) + if (present(fmt_imag)) then + if (.not.present(fmt)) then + call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return + endif + call get_SE(SEim, title, shape(x), fmt_imag) + else + SEim = SE + end if + call disp_cplq(title, x, SE, SEim, n = size(x,2)) + end subroutine disp_tm_cplq + + subroutine disp_cplq(title, x, SE, SEim, n) + ! quadruple precision item + character(*), intent(in) :: title + complex(quad), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE, SEim + integer, intent(in) :: n + integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) + call find_editdesc_quad(real(x), SE, widre, nblre) ! determine also SE%w + call find_editdesc_quad(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w + call tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) + end subroutine disp_cplq + + subroutine tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) + ! Write quadruple precision complex matrix to box + character(*), intent(in) :: title + complex(quad), intent(in) :: x(:,:) + integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) + type(settings), intent(INOUT ) :: SE, SEim + character(SE%w) :: s(m) + character(SEim%w) :: sim(m) + character(3) :: sgn(m) + integer :: lin1, i, j, wleft, wid(n), widp(n) + character, pointer :: boxp(:,:) + SE%zas = '' + SEim%zas = '' + wid = widre + widim + 4 + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) + call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) + do i=1,m + if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif + enddo + call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) + if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) + call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) + call copyseptobox('i', m, lin1, boxp, wleft) + if (j 0) write(s, SE%ed) xj + call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf + if (.not. any(xfinite)) then + w = 4 + else + xmax = maxval(x, mask=xfinite) + xmin = minval(x, mask=xfinite) + f1 = '(SS,ES9.0E4)' + write(s,f1) xmax, xmin + read(s(:)(5:9),'(I5)') expmax, expmin + w = max(0, expmax, expmin) + d + 4 + end if + if (.not. all(xfinite)) w = max(w, 4) + end function maxw_sngl + + subroutine find_editdesc_sngl(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid. + ! The if-block (*) is for safety: make f wider in case xm is written ok with the + ! ES format in fmt but overflows with F format (the feature has been tested through + ! manual changes to the program). + real(sngl), intent(in) :: x(:,:) ! Item to be written + type(settings), intent(INOUT ) :: SE ! Settings + integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns + integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns + integer :: expmax, expmin, ww, dd, dmx + real(sngl) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h + character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 + character(99) s + logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) + ! + dmx = SE%dmx + h = huge(h) + xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf + if (SE%w == 0) then ! Edit descriptor 'F0.d' specified + ww = maxw_sngl(reshape(x, (/size(x)/)), SE%d) + if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas) + call replace_w(SE%ed, ww) + SE%w = ww + elseif (SE%w < 0) then ! No edit descriptor specified + if (size(x) == 0) then + SE%w = 0 + wid = 0 + nbl = 0 + return + endif + if (any(xfinite)) then + xp = maxval(x, mask=xfinite) + xm = minval(x, mask=xfinite) + write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 + write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax + write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin + call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) + if (.not. all(xfinite)) ww = max(ww, 4) + if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas) + if (SE%ed(5:5)=='F') then ! (*) + write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 + write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 + write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd + endif + else + ww = 4 + SE%ed = '(F4.0)' + endif + SE%w = ww + endif + if (SE%trm) then + xmaxv = maxval(x, 1, mask=xfinite) ! max in each column + xminv = minval(x, 1, mask=xfinite) ! min + xzero = any(x == 0._sngl, 1) ! true where column has some zeros + xallz = all(x == 0._sngl, 1) ! true where column has only zeros + xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) + xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) + call getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + else + wid = SE%w + nbl = 0 + endif + end subroutine find_editdesc_sngl + + subroutine getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ! determine length of the strings that result when writing with edit descriptor SE%ed a + ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output + real(sngl), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column + logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros + logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals + type(settings), intent(in) :: SE ! settings + integer, intent(out) :: wid(:) ! widths of columns + integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) + character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) + integer w + w = SE%w + write(stmin, SE%ed) xminv + write(stmax, SE%ed) xmaxv + nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) + if (SE%gedit) then + wid = w + else + wid = len_trim(adjustl(stmin)) + wid = max(wid, len_trim(adjustl(stmax))) + endif + if (SE%lzas > 0) then + wid = merge(SE%lzas, wid, xallz) + wid = max(wid, merge(SE%lzas, 0, xzero)) + endif + wid = merge(4, wid, xalln) + wid = max(wid, merge(4, 0, xnonn)) + nbl = w - wid + end subroutine getwid_sngl + + ! ******** TOSTRING snglRUPLE PRECISION PROCEDURES *********** + function tostring_s_sngl(x) result(st) + ! Scalar to string + real(sngl), intent(in) :: x + character(len_f_sngl((/x/), tosset0%rfmt)) :: st + st = tostring_f_sngl((/x/), tosset0%rfmt) + end function tostring_s_sngl + + function tostring_sf_sngl(x, fmt) result(st) + ! Scalar with specified format to string + real(sngl), intent(in) :: x + character(*), intent(in) :: fmt + character(len_f_sngl((/x/), fmt)) :: st + st = tostring_f_sngl((/x/), fmt) + end function tostring_sf_sngl + + function tostring_sngl(x) result(st) + ! Vector to string + real(sngl), intent(in) :: x(:) + character(len_f_sngl(x, tosset0%rfmt)) :: st + st = tostring_f_sngl(x, tosset0%rfmt) + end function tostring_sngl + + function tostring_f_sngl(x, fmt) result(st) + ! Vector with specified format to string + real(sngl) , intent(in) :: x(:) + character(*), intent(in) :: fmt + character(len_f_sngl(x, fmt)) :: st + character(widthmax_sngl(x, fmt)) :: sa(size(x)) + character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) + integer :: w, d, ww + logical :: gedit + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then + st = errormsg + return + elseif (w == 0) then + ww = maxw_sngl(x, d) + call replace_w(fmt1, ww) + endif + write(sa, fmt1) x + call trim_real(sa, gedit, w) + call tostring_get(sa, st) + end function tostring_f_sngl + + pure function len_f_sngl(x, fmt) result(wtot) + ! Total length of returned string, vector s + real(sngl), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(widthmax_sngl(x, fmt)) :: sa(size(x)) + integer :: wtot, w, d, ww + logical :: gedit + character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; wtot = len(errormsg); return; endif + if (w == 0) then + ww = maxw_sngl(x, d) + call replace_w(fmt1, ww) + endif + write(sa, fmt1) x + call trim_real(sa, gedit, w) + wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) + end function len_f_sngl + + pure function widthmax_sngl(x, fmt) result(w) + ! Maximum width of an element of x + real(sngl), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(nnblk(fmt)+5) :: fmt1 + integer w, d + logical gedit + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then ! illegal format, use 1 + w = 1 + elseif (w == 0) then + w = maxw_sngl(x, d) + endif + end function widthmax_sngl + + ! *************************************** END OF snglRUPLE PRECISION PROCEDURES *************************************** + + ! *************************************** snglRUPLE PRECISION COMPLEX PROCEDURES ************************************** + subroutine disp_s_cplx(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) + ! snglruple precision complex scalar without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim + complex(sngl), intent(in) :: x + integer, intent(in), optional :: unit, digmax + call disp_ts_cplx('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) + end subroutine disp_s_cplx + + subroutine disp_v_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + ! snglruple precision complex vector without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient + complex(sngl), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:), digmax + call disp_tv_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + end subroutine disp_v_cplx + + subroutine disp_m_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + ! snglruple precision complex matrix without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim + complex(sngl), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, digmax, lbound(:) + call disp_tm_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + end subroutine disp_m_cplx + + subroutine disp_ts_cplx(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) + ! snglruple precision complex scalar with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim + complex(sngl), intent(in) :: x + integer, intent(in), optional :: unit, digmax + call disp_tm_cplx(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, & + trim=trim, unit=unit) + end subroutine disp_ts_cplx + + subroutine disp_tv_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + ! snglruple precision complex vector with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient + complex(sngl), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:), digmax + type(settings) SE, SEim + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) + if (present(fmt_imag)) then + if (.not.present(fmt)) then + call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; + endif + call get_SE(SEim, title, shape(x), fmt_imag) + else + SEim = SE + end if + if (SE%row) then + call disp_cplx(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) + else + call disp_cplx(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) + end if + end subroutine disp_tv_cplx + + subroutine disp_tm_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + ! snglruple precision complex matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + complex(sngl), intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & + ! ! is present) + character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element + integer, intent(in), optional :: unit ! Unit to display on + integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & + ! ! and aimag(x) + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + ! + type(settings) :: SE, SEim + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) + if (present(fmt_imag)) then + if (.not.present(fmt)) then + call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return + endif + call get_SE(SEim, title, shape(x), fmt_imag) + else + SEim = SE + end if + call disp_cplx(title, x, SE, SEim, n = size(x,2)) + end subroutine disp_tm_cplx + + subroutine disp_cplx(title, x, SE, SEim, n) + ! snglruple precision item + character(*), intent(in) :: title + complex(sngl), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE, SEim + integer, intent(in) :: n + integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) + call find_editdesc_sngl(real(x), SE, widre, nblre) ! determine also SE%w + call find_editdesc_sngl(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w + call tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) + end subroutine disp_cplx + + subroutine tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) + ! Write snglruple precision complex matrix to box + character(*), intent(in) :: title + complex(sngl), intent(in) :: x(:,:) + integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) + type(settings), intent(INOUT ) :: SE, SEim + character(SE%w) :: s(m) + character(SEim%w) :: sim(m) + character(3) :: sgn(m) + integer :: lin1, i, j, wleft, wid(n), widp(n) + character, pointer :: boxp(:,:) + SE%zas = '' + SEim%zas = '' + wid = widre + widim + 4 + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) + call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) + do i=1,m + if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif + enddo + call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) + if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) + call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) + call copyseptobox('i', m, lin1, boxp, wleft) + if (j 0) write(s, SE%ed) xj + call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) + call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf + if (.not. any(xfinite)) then + w = 4 + else + xmax = maxval(x, mask=xfinite) + xmin = minval(x, mask=xfinite) + f1 = '(SS,ES9.0E4)' + write(s,f1) xmax, xmin + read(s(:)(5:9),'(I5)') expmax, expmin + w = max(0, expmax, expmin) + d + 4 + end if + if (.not. all(xfinite)) w = max(w, 4) + end function maxw_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine find_editdesc_dble(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid. + ! The if-block (*) is for safety: make f wider in case xm is written ok with the + ! ES format in fmt but overflows with F format (the feature has been tested through + ! manual changes to the program). + real(dble), intent(in) :: x(:,:) ! Item to be written + type(settings), intent(INOUT ) :: SE ! Settings + integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns + integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns + integer :: expmax, expmin, ww, dd, dmx + real(dble) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h + character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 + character(99) s + logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) + ! + dmx = SE%dmx + h = huge(h) + xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf + if (SE%w == 0) then ! Edit descriptor 'F0.d' specified + ww = maxw_dble(reshape(x, (/size(x)/)), SE%d) + if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas) + call replace_w(SE%ed, ww) + SE%w = ww + elseif (SE%w < 0) then ! No edit descriptor specified + if (size(x) == 0) then + SE%w = 0 + wid = 0 + nbl = 0 + return + endif + if (any(xfinite)) then + xp = maxval(x, mask=xfinite) + xm = minval(x, mask=xfinite) + write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 + write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax + write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin + call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) + if (.not. all(xfinite)) ww = max(ww, 4) + if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas) + if (SE%ed(5:5)=='F') then ! (*) + write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 + write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 + write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd + endif + else + ww = 4 + SE%ed = '(F4.0)' + endif + SE%w = ww + endif + if (SE%trm) then + xmaxv = maxval(x, 1, mask=xfinite) ! max in each column + xminv = minval(x, 1, mask=xfinite) ! min + xzero = any(x == 0._dble, 1) ! true where column has some zeros + xallz = all(x == 0._dble, 1) ! true where column has only zeros + xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) + xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) + call getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + else + wid = SE%w + nbl = 0 + endif + end subroutine find_editdesc_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ! determine length of the strings that result when writing with edit descriptor SE%ed a + ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output + real(dble), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column + logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros + logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals + type(settings), intent(in) :: SE ! settings + integer, intent(out) :: wid(:) ! widths of columns + integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) + character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) + integer w + w = SE%w + write(stmin, SE%ed) xminv + write(stmax, SE%ed) xmaxv + nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) + if (SE%gedit) then + wid = w + else + wid = len_trim(adjustl(stmin)) + wid = max(wid, len_trim(adjustl(stmax))) + endif + if (SE%lzas > 0) then + wid = merge(SE%lzas, wid, xallz) + wid = max(wid, merge(SE%lzas, 0, xzero)) + endif + wid = merge(4, wid, xalln) + wid = max(wid, merge(4, 0, xnonn)) + nbl = w - wid + end subroutine getwid_dble + + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + function tostring_s_dble(x) result(st) + ! Scalar to string + real(dble), intent(in) :: x + character(len_f_dble((/x/), tosset0%rfmt)) :: st + st = tostring_f_dble((/x/), tosset0%rfmt) + end function tostring_s_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + function tostring_sf_dble(x, fmt) result(st) + ! Scalar with specified format to string + real(dble), intent(in) :: x + character(*), intent(in) :: fmt + character(len_f_dble((/x/), fmt)) :: st + st = tostring_f_dble((/x/), fmt) + end function tostring_sf_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + function tostring_dble(x) result(st) + ! Vector to string + real(dble), intent(in) :: x(:) + character(len_f_dble(x, tosset0%rfmt)) :: st + st = tostring_f_dble(x, tosset0%rfmt) + end function tostring_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + function tostring_f_dble(x, fmt) result(st) + ! Vector with specified format to string + real(dble) , intent(in) :: x(:) + character(*), intent(in) :: fmt + character(len_f_dble(x, fmt)) :: st + character(widthmax_dble(x, fmt)) :: sa(size(x)) + character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) + integer :: w, d, ww + logical :: gedit + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then + st = errormsg + return + elseif (w == 0) then + ww = maxw_dble(x, d) + call replace_w(fmt1, ww) + endif + write(sa, fmt1) x + call trim_real(sa, gedit, w) + call tostring_get(sa, st) + end function tostring_f_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + pure function len_f_dble(x, fmt) result(wtot) + ! Total length of returned string, vector s + real(dble), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(widthmax_dble(x, fmt)) :: sa(size(x)) + integer :: wtot, w, d, ww + logical :: gedit + character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then; wtot = len(errormsg); return; endif + if (w == 0) then + ww = maxw_dble(x, d) + call replace_w(fmt1, ww) + endif + write(sa, fmt1) x + call trim_real(sa, gedit, w) + wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) + end function len_f_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + pure function widthmax_dble(x, fmt) result(w) + ! Maximum width of an element of x + real(dble), intent(in) :: x(:) + character(*), intent(in) :: fmt + character(nnblk(fmt)+5) :: fmt1 + integer w, d + logical gedit + call readfmt(fmt, fmt1, w, d, gedit) + if (w < 0) then ! illegal format, use 1 + w = 1 + elseif (w == 0) then + w = maxw_dble(x, d) + endif + end function widthmax_dble + + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine disp_s_cpld(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) + ! dbleruple precision complex scalar without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim + complex(dble), intent(in) :: x + integer, intent(in), optional :: unit, digmax + call disp_ts_cpld('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) + end subroutine disp_s_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine disp_v_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + ! dbleruple precision complex vector without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient + complex(dble), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:), digmax + call disp_tv_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + end subroutine disp_v_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine disp_m_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + ! dbleruple precision complex matrix without title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim + complex(dble), intent(in) :: x(:,:) + integer, intent(in), optional :: unit, digmax, lbound(:) + call disp_tm_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + end subroutine disp_m_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine disp_ts_cpld(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) + ! dbleruple precision complex scalar with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim + complex(dble), intent(in) :: x + integer, intent(in), optional :: unit, digmax + call disp_tm_cpld(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, & + & advance, digmax, sep=sep, style=style, trim=trim, unit=unit) + end subroutine disp_ts_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine disp_tv_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) + ! dbleruple precision complex vector with title + character(*), intent(in) :: title + character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient + complex(dble), intent(in) :: x(:) + integer, intent(in), optional :: unit, lbound(:), digmax + type(settings) SE, SEim + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) + if (present(fmt_imag)) then + if (.not.present(fmt)) then + call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; + endif + call get_SE(SEim, title, shape(x), fmt_imag) + else + SEim = SE + end if + if (SE%row) then + call disp_cpld(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) + else + call disp_cpld(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) + end if + end subroutine disp_tv_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine disp_tm_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) + ! dbleruple precision complex matrix with title + character(*), intent(in) :: title ! The title to use for the matrix + complex(dble), intent(in) :: x(:,:) ! The matrix to be written + character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & + ! ! is present) + character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element + integer, intent(in), optional :: unit ! Unit to display on + integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & + ! ! and aimag(x) + character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") + character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below + character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + integer, intent(in), optional :: lbound(:) ! Lower bounds of x + ! + type(settings) :: SE, SEim + call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) + if (present(fmt_imag)) then + if (.not.present(fmt)) then + call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return + endif + call get_SE(SEim, title, shape(x), fmt_imag) + else + SEim = SE + end if + call disp_cpld(title, x, SE, SEim, n = size(x,2)) + end subroutine disp_tm_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine disp_cpld(title, x, SE, SEim, n) + ! dbleruple precision item + character(*), intent(in) :: title + complex(dble), intent(in) :: x(:,:) + type(settings), intent(INOUT ) :: SE, SEim + integer, intent(in) :: n + integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) + call find_editdesc_dble(real(x), SE, widre, nblre) ! determine also SE%w + call find_editdesc_dble(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w + call tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) + end subroutine disp_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + subroutine tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) + ! Write dbleruple precision complex matrix to box + character(*), intent(in) :: title + complex(dble), intent(in) :: x(:,:) + integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) + type(settings), intent(INOUT ) :: SE, SEim + character(SE%w) :: s(m) + character(SEim%w) :: sim(m) + character(3) :: sgn(m) + integer :: lin1, i, j, wleft, wid(n), widp(n) + character, pointer :: boxp(:,:) + SE%zas = '' + SEim%zas = '' + wid = widre + widim + 4 + call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + do j=1,n + if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) + call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) + do i=1,m + if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif + enddo + call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) + if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) + call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) + call copyseptobox('i', m, lin1, boxp, wleft) + if (j NULL(), boxl_dummy2 => NULL() + TYPE(boxnode), POINTER :: boxn_dummy1 => NULL(), boxn_dummy2 => NULL() + TYPE(tostring_settings), POINTER :: ts1 => NULL(), ts2 => NULL() + ts1 => ts2 + ts2 => ts1 + boxl_dummy2 => boxl_dummy1 + boxl_dummy1 => boxl_dummy2 + boxn_dummy2 => boxn_dummy1 + boxn_dummy1 => boxn_dummy2 +END SUBROUTINE avoid_compiler_warnings + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE tostring_set(sep, rfmt, ifmt, trimb, trimz) + CHARACTER(*), OPTIONAL, INTENT(in) :: sep, rfmt, ifmt, trimb, trimz + IF (PRESENT(sep)) tosset0%sep = upper(sep) + IF (PRESENT(sep)) tosset0%seplen = MIN(9, LEN(sep)) + IF (PRESENT(rfmt)) tosset0%rfmt = upper(rfmt) + IF (PRESENT(ifmt)) tosset0%ifmt = upper(ifmt) + IF (PRESENT(trimb)) tosset0%trimb = upper(trimb) + IF (PRESENT(trimz)) tosset0%trimz = upper(trimz) + CALL tostring_check_settings +END SUBROUTINE tostring_set + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE tostring_set_factory() + LOGICAL dummy + dummy = .FALSE. + IF (dummy) CALL avoid_compiler_warnings + tosset0 = tosfac +END SUBROUTINE tostring_set_factory + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE disp_set_ds(settings) + ! Change display settings according to the structure "settings" + TYPE(disp_settings), INTENT(in) :: settings + DEFSET = settings + CALL check_settings +END SUBROUTINE disp_set_ds + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION disp_get() RESULT(defs) + ! Return current display settings + TYPE(disp_settings) :: defs + defs = DEFSET +END FUNCTION disp_get + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE DISPMODULE diff --git a/src/modules/Display/src/disp/dispmodule_util.F90 b/src/modules/Display/src/disp/dispmodule_util.F90 new file mode 100644 index 000000000..6fddd0658 --- /dev/null +++ b/src/modules/Display/src/disp/dispmodule_util.F90 @@ -0,0 +1,955 @@ +! DISPMODULE, A FORTRAN 95 MODULE FOR PRETTY-PRINTING MATRICES. +! Version number 1.03 16-February-2009. This version published as Algorithm 892 in ACM TOMS. +! +! NOTE: THE MAIN MODULE, DISPMODULE, IS LATER IN THIS FILE. +! +! The usage documentation for DISPMODULE is in a separate document, that exists +! in several formats: +! +! dispmodule_userman.doc Word 2003 doc file +! dispmodule_userman.pdf PDF file +! dispmodule_userman.html HTML file +! dispmodule_userman.txt Text file + +MODULE DISPMODULE_UTIL +! Dispmodule_util contains utilities that are used by Dispmodule, and the add-on modules +! disp_i1mod, disp_i2mod,..., disp_l1mod and disp_r16mod. Note that the entities that are +! declared public below are not exported to the user. The private statements in dispmodule and +! the add-on modules prevent that from happening. + +USE putstrmodule +IMPLICIT NONE + +! ***************** PUBLIC ENTITIES (ONLY PUBLIC TO DISPMODULE, NOT TO USER PROGRAMS) ***************** +PRIVATE + +PUBLIC :: disp_settings, defset, factory_settings, tosset0, tosfac, errormsg, tostring_settings +PUBLIC :: nnblk, upper, readfmt, replace_w, trim_real, get_SE, preparebox, copytobox, boxlist, boxnode +PUBLIC :: copyseptobox, finishbox, tostring_get_complex, disp_errmsg, tostring_get, find_editdesc_real +PUBLIC :: check_settings, tostring_check_settings, replace_zeronaninf, settings, trim_s_real + +! *********************************** GENERAL DECLARATIONS ******************************************** +TYPE disp_settings + ! Settings used by subroutine disp and the utility procedures. + CHARACTER(6) :: advance = 'YES' + CHARACTER(9) :: matsep = ' ' + CHARACTER(3) :: orient = 'COL' + CHARACTER(9) :: sep = ' ' + CHARACTER(9) :: style = 'LEFT' + CHARACTER(4) :: trim = 'AUTO' + CHARACTER(9) :: zeroas = '' + INTEGER :: digmax = 6 + INTEGER :: matseplen = 3 + INTEGER :: seplen = 2 + INTEGER :: unit = DEFAULT_UNIT + INTEGER :: zaslen = 0 +END TYPE disp_settings + +TYPE tostring_settings + ! Settings used by function tostring. + CHARACTER(10) :: ifmt = 'I0' + CHARACTER(16) :: rfmt = '1PG12.5' ! 'SP,1P,G20.11E3' has length 14 and is about max + CHARACTER(9) :: sep = ', ' + INTEGER :: seplen = 2 + CHARACTER(3) :: trimb = 'YES' + CHARACTER(4) :: trimz = 'G' +END TYPE tostring_settings + +TYPE settings + ! Settings used (privately) by disp and the utility procedures, in the variable SE. + CHARACTER(22) ed + CHARACTER(9) sep, tsty, zas + CHARACTER(1) tch + INTEGER lun, dmx, w, d, lsep, lzas, m1, n1, adv + LOGICAL trm, number, vec, row, gedit +END TYPE settings + +TYPE(disp_settings) :: DEFSET +!$OMP THREADPRIVATE(DEFSET) +!! Current default settings for disp +TYPE(disp_settings) :: FACTORY_SETTINGS +!$OMP THREADPRIVATE(FACTORY_SETTINGS) +!! Original (factory) settings for disp +TYPE(tostring_settings), SAVE :: tosset0 +!$OMP THREADPRIVATE(tosset0) +!! Current settings for tostring +TYPE(tostring_settings) :: tosfac +!$OMP THREADPRIVATE(tosfac) +!! Factory settings for tostring + +CHARACTER(*), PARAMETER :: errormsg = 'Illegal format' + +! ********************* BOX-PACKAGE DECLARATIONS (SEE EXPLANATION ABOUT BOX-PACKAGE BELOW) ***************** +TYPE boxnode + ! A box is the character representation of a printed item + CHARACTER, POINTER :: box(:, :) + TYPE(boxnode), POINTER :: nextbox => NULL() +END TYPE boxnode +! +TYPE boxlist + ! There is one list of boxes associated with each logical unit + INTEGER :: unit = 1 + TYPE(boxnode), POINTER :: firstbox => NULL() + TYPE(boxnode), POINTER :: lastbox => NULL() + TYPE(boxlist), POINTER :: nextboxlist => NULL() +END TYPE boxlist +! +TYPE(boxlist), POINTER :: firstboxlist => NULL() +! ************************ END OF BOX-PACKAGE DECLARATIONS ****************************** + +CONTAINS + +! ***************************** GENERAL PROCEDURES ************************************** +SUBROUTINE check_settings() + ! Sanity check of display settings + CHARACTER(9) :: tsty + CHARACTER tch + LOGICAL number, ok, dmxerr, orierr, styerr, adverr + CHARACTER(6), PARAMETER :: ADVOK(3) = (/'NO ', 'YES ', 'DOUBLE'/) + TYPE(disp_settings) ds + ds = DEFSET + CALL getstyles(ds%style, tsty, tch, number, ok) + styerr = .NOT. ok + dmxerr = ds%digmax < 1 .OR. ds%digmax > 89 + orierr = ALL(ds%orient /= (/'ROW', 'COL'/)) + adverr = ALL(ds%advance /= ADVOK) + IF (dmxerr) DEFSET%digmax = 6 + IF (orierr) DEFSET%orient = 'COL' + IF (styerr) DEFSET%style = 'LEFT' + IF (adverr) DEFSET%advance = 'YES' + ! + if (dmxerr) call disp_errmsg('DISP_SET: error, illegal digmax (must be 1-89), set to 6') + if (orierr) call disp_errmsg('DISP_SET: error, illegal orient: ' // trim(ds%orient) // ', set to "COL"') + if (styerr) call disp_errmsg('DISP_SET: error, illegal style: ' // trim(ds%style) // ', set to "LEFT"') + if (adverr) call disp_errmsg('DISP_SET: error, illegal advance: ' // trim(ds%advance) // ', set to "YES"') +END SUBROUTINE check_settings + +FUNCTION number_rows(SE) RESULT(nbr) + ! Should rows be numbered? + TYPE(settings), INTENT(in) :: SE + LOGICAL nbr + nbr = .FALSE. + IF (.NOT. SE%number) RETURN + IF (SE%vec .AND. SE%row) RETURN + nbr = .TRUE. +END FUNCTION number_rows + +FUNCTION number_cols(SE) RESULT(nbr) + ! Should columns be numbered? + TYPE(settings), INTENT(in) :: SE + LOGICAL nbr + nbr = .FALSE. + IF (.NOT. SE%number) RETURN + IF (SE%vec .AND. .NOT. SE%row) RETURN + nbr = .TRUE. +END FUNCTION number_cols + +SUBROUTINE preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + ! Determine format to use to write matrix to box and row where matrix begins, copy + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + TYPE(settings), INTENT(in) :: SE ! Settings + INTEGER, INTENT(in) :: m ! Row count of matrix + INTEGER, INTENT(in) :: n ! Column count of matrix + INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns in matrix + INTEGER, INTENT(out) :: widp(:) ! widths of columns in box (max(wid, width of col nums)) + INTEGER, INTENT(out) :: lin1 ! Row number where matrix begins (tsty='left' 0, 'pad' 1, 'underline' 2) + INTEGER, INTENT(out) :: wleft ! Number of spaces on left of matrix (when tsty is left or title long) + CHARACTER, POINTER :: boxp(:, :) ! The box + + INTEGER wt, wa ! Char count of title, idth of matrix in characters (wbox = lm + wa + rm) + INTEGER wbox, wrow ! Width of box in characters, width of row numbers in characters + INTEGER lm ! Left margin + INTEGER h, ws ! Height of box in characters, length of column separator + INTEGER m1, n1, i ! lower bounds (for numbering), index + CHARACTER(RANGE(0) + 2) sn(2), row_nums(m), col_nums(n) + CHARACTER(10) fmt + + ! ----------wbox--------- -----------wbox---------- -----wbox------ + ! ---lm--- --wleft- --wt- + ! ----wleft--- lm wrow wa rm wrow wa + ! wt wrow wa ----====-----------====== ----=========== + ! --------====----------- THIS-IS-A-VERY-LONG-TITLE TITLE + ! 1 2 1 2 1 2 + ! MATRIX = 1 4.50 6.80 1 4.50 6.80 1 4.50 6.80 + ! 2 6.88 9.22 2 6.88 9.22 2 6.88 9.22 + ! 3 19.44 0.08 3 19.44 0.08 3 19.44 0.08 + ! ... ... ... + ! 10 6.18 4.22 10 6.18 4.22 10 6.18 4.22 + ! rm = 0 wt = wbox lm = rm = 0, wleft = wrow + m1 = SE%m1 + n1 = SE%n1 + ws = SE%lsep + wt = LEN(title) + wrow = 0 + widp = wid + IF (SE%number) THEN + fmt = '(SS,I0)' + IF (number_cols(SE)) THEN + WRITE (col_nums, fmt) (/(i, i=n1, n1 + n - 1)/) + widp = MAX(wid, LEN_TRIM(col_nums)) + END IF + IF (number_rows(SE)) THEN + WRITE (sn, fmt) m1, m1 + m - 1 + wrow = MAXVAL(LEN_TRIM(sn)) + ws ! determine max width of row numbers + CALL replace_w(fmt, wrow - ws) ! to create e.g. 'I5' from 'I0' + WRITE (row_nums, fmt) (/(i, i=m1, m1 + m - 1)/) + END IF + END IF + wa = MAX(0, n - 1) * ws + SUM(widp) + SELECT CASE (upper(SE%tsty)) + CASE ('LEFT'); lin1 = 1; wbox = wt + wrow + wa; h = MAX(1, m); lm = wt + CASE ('PAD'); lin1 = 2; wbox = MAX(wt, wa + wrow); h = m + 1; lm = MAX(0, (wt - wa - wrow) / 2) + CASE ('UNDERLINE'); lin1 = 3; wbox = MAX(wt, wa + wrow); h = m + 2; lm = MAX(0, (wt - wa - wrow) / 2) + CASE default; lin1 = 1; wbox = 0; h = 0; lm = 0 ! should not happen + END SELECT + wleft = lm + IF (number_cols(SE)) h = h + 1 + CALL newbox(SE%lun, h, wbox, boxp) + IF (number_cols(SE)) THEN +CALL copycolumnnumberstobox(col_nums, wleft + wrow, wid, widp, ws, boxp, lin1) + END IF + IF (number_rows(SE)) THEN + call copytobox(row_nums, lin1, wrow - ws, wrow - ws, nblj = 0, boxp = boxp, wleft = wleft) + CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END IF +END SUBROUTINE preparebox + +SUBROUTINE copytobox(s, lin1, widj, widpj, nblj, boxp, wleft) + ! Copy strings to column in boxp; update wleft to current char column in boxp + CHARACTER(*), INTENT(in) :: s(:) ! the strings to copy + INTEGER, INTENT(in) :: lin1, widj ! first line in box to copy to, width of column + INTEGER, INTENT(in) :: nblj, widpj ! number of blank characters to trim from left of s, offset to next col + CHARACTER, INTENT(INOUT) :: boxp(:, :) ! the box to accept the column + INTEGER, INTENT(INOUT) :: wleft ! number of char-columns in box already written to + INTEGER i, j + wleft = wleft + widpj - widj + ! forall(i = 1:widj, j=1:size(s)) boxp(wleft+i, j+lin1-1) = s(j)(i+nblj:i+nblj) + DO CONCURRENT(i=1:widj, j=1:SIZE(s)) + boxp(wleft + i, j + lin1 - 1) = s(j) (i + nblj:i + nblj) + END DO + wleft = wleft + widj +END SUBROUTINE copytobox + +SUBROUTINE copyseptobox(sep, m, lin1, boxp, wleft) + ! Copy column separator to boxp; update wleft + CHARACTER(*), INTENT(in) :: sep + INTEGER, INTENT(in) :: m, lin1 + CHARACTER, INTENT(INOUT) :: boxp(:, :) + INTEGER, INTENT(INOUT) :: wleft + INTEGER i, j + ! forall(i = 1:len(sep), j=1:m) boxp(wleft+i, j+lin1-1) = sep(i:i) + DO CONCURRENT(i=1:LEN(sep), j=1:m) + boxp(wleft + i, j + lin1 - 1) = sep(i:i) + END DO + wleft = wleft + LEN(sep) +END SUBROUTINE copyseptobox + +SUBROUTINE copycolumnnumberstobox(s, wleft, wid, widp, lsep, boxp, lin1) + CHARACTER(*), INTENT(in) :: s(:) ! strings with left-adjusted column numbers + INTEGER, INTENT(in) :: wleft ! char positions on left of 1st col + INTEGER, INTENT(in) :: wid(:) ! widths of columns in matrix + INTEGER, INTENT(in) :: widp(:) ! widths of columns in box (max(wid, width of col nums)) + INTEGER, INTENT(in) :: lsep ! width of column separator + CHARACTER, INTENT(INOUT) :: boxp(:, :) ! receives the numbers + INTEGER, INTENT(INOUT) :: lin1 ! line number in box to copy to + INTEGER ls(SIZE(s)), rmargmax, k, i, lmargin, j + ! + ls = LEN_TRIM(s) + rmargmax = (MAX(0, MINVAL(wid) - MAXVAL(ls))) / 2 ! locate according to narrowest column, widest number + k = wleft + DO i = 1, SIZE(wid) + lmargin = MAX(0, widp(i) - ls(i) - rmargmax) + k = k + lmargin + DO CONCURRENT(j=1:ls(i)) + boxp(k + j, lin1) = s(i) (j:j) + END DO + k = k + widp(i) - lmargin + lsep + END DO + lin1 = lin1 + 1 +END SUBROUTINE copycolumnnumberstobox + +SUBROUTINE finishbox(title, SE, boxp) + ! Finish creating a box and display it if advancing is turned on + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + TYPE(settings), INTENT(in) :: SE ! Settings + CHARACTER, INTENT(INOUT) :: boxp(:, :) ! The box + ! + INTEGER i, wt, w, wpadright, wpadleft ! index, width of title, width of box and spacing on either side of it + INTEGER lin1 ! line to put left title + ! + wt = LEN(title) + w = SIZE(boxp, 1) + IF (upper(SE%tsty) == 'LEFT') THEN + lin1 = 1 + IF (number_cols(SE)) lin1 = MIN(2, SIZE(boxp, 2)) + ! forall(i=1:wt) boxp(i,lin1) = title(i:i) + DO CONCURRENT(i=1:wt) + boxp(i, lin1) = title(i:i) + END DO + ELSE + wpadright = (w - wt) / 2 + wpadleft = w - wpadright - wt + ! forall(i=1:wt) boxp(wpadleft+i, 1) = title(i:i) + DO CONCURRENT(i=1:wt) + boxp(wpadleft + i, 1) = title(i:i) + END DO + IF (upper(SE%tsty) == 'PAD') THEN + boxp(1:wpadleft, 1) = SE%tch + boxp(w - wpadright + 1:w, 1) = SE%tch + ELSE ! tsty == 'UNDERLINE' + boxp(:, 2) = SE%tch + END IF + END IF + IF (SE%adv >= 1) CALL dispboxlist(SE%lun, DEFSET%matsep(1:DEFSET%matseplen)) + IF (SE%adv >= 2) CALL dispnewline(SE%lun) +END SUBROUTINE finishbox + +SUBROUTINE find_editdesc_real(exp, expm, dmx, edesc, flen, ndec, posit) + ! Subroutine of find_editdesc_sngl and find_editdesc_dble + INTEGER, INTENT(in) :: expm, dmx + INTEGER, INTENT(INOUT) :: exp + CHARACTER(14), INTENT(out) :: edesc + INTEGER, INTENT(out) :: flen, ndec + LOGICAL, INTENT(in) :: posit + INTEGER :: neg, nxp + exp = MAX(exp, expm) + neg = 1 + IF (exp < dmx .AND. exp >= -1) THEN + IF (posit .OR. exp > MAX(0, expm)) neg = 0 + edesc = '(SS,Fxx.yy)' + ndec = MAX(0, dmx - exp - 1) + flen = neg + 2 + ndec + MAX(0, exp) ! -X.YYYYY (2 covers X and .) + WRITE (edesc(6:10), '(SS,I2,".",I2)') flen, ndec + ELSE + IF (posit) neg = 0 + IF (ABS(exp) > 999) THEN; nxp = 4 + ELSEIF (ABS(exp) > 99) THEN; nxp = 3 + ELSEIF (ABS(exp) > 9) THEN; nxp = 2 + ELSE; nxp = 1 + END IF + flen = neg + 3 + dmx + nxp + edesc = '(SS,ESxx.yyEz)' + WRITE (edesc(7:13), '(SS,I2,".",I2,"E",I1)') flen, dmx - 1, nxp + ndec = dmx - 1 + END IF +END SUBROUTINE find_editdesc_real + +PURE SUBROUTINE readfmt(fmt, fmt1, w, d, gedit) + ! Returns w and d when fmt is (Xw.d) or (Xw) (then d = 0), X = edit descriptor letter + ! (I, F, etc). X can also be ES, DS, 1PG or 1PF. Returns w = -1 for illegal fmt. + ! Returns gedit = .true. if fmt is Gw.d. How about SS,1PES4.3? + CHARACTER(*), INTENT(in) :: fmt ! e.g. fmt = F 8.2 + CHARACTER(*), INTENT(out) :: fmt1 ! returns '(SS,F8.2)' + CHARACTER ch + INTEGER, INTENT(out) :: w, d + LOGICAL, INTENT(out) :: gedit + INTEGER :: k0, k1, k2, k3, k4 + CALL sszipfmt(fmt, fmt1) + w = -1; d = 0; gedit = .FALSE. + k1 = VERIFY(fmt1(2:), '0123456789') + 1 + IF (k1 == 0) RETURN ! only digits + k2 = VERIFY(fmt1(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 ! , for "1P,G12.3" + IF (k2 <= k1) RETURN ! no letter or only letters + ch = upper(fmt1(k2 - 1:k2 - 1)) + IF (ch == ',') THEN ! deal with SS,1PG13.5 + k0 = k2 + k1 = VERIFY(fmt1(k0:), '0123456789') + k0 - 1 + IF (k1 == 0) RETURN + k2 = VERIFY(fmt1(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 + IF (k2 <= k1) RETURN + ch = upper(fmt1(k2 - 1:k2 - 1)) + END IF + gedit = ch == 'G' .OR. ch == 'g' + k3 = VERIFY(fmt1(k2:), '0123456789') + k2 - 1 + IF (k3 == k2) RETURN ! no digits + READ (fmt1(k2:k3 - 1), *) w + IF (k3 > LEN(fmt1)) RETURN + IF (fmt1(k3:k3) /= '.') RETURN ! not . after w + k4 = VERIFY(fmt1(k3 + 1:), '0123456789') + k3 + IF (k4 == k3 + 1) RETURN ! no digits + READ (fmt1(k3 + 1:k4 - 1), *) d +END SUBROUTINE readfmt + +PURE SUBROUTINE replace_w(fmt, wnew) + ! Change e.g. '(F0.3)' to '(F5.3)'. Works also for '(SS,I0)' to '(SS,I5)'. If wnew > 999, set it to 999 + CHARACTER(*), INTENT(INOUT) :: fmt + INTEGER, INTENT(in) :: wnew + INTEGER :: k0, k1, k2, k3 + CHARACTER(3) rw + k1 = VERIFY(fmt(2:), '0123456789') + 1 + k2 = VERIFY(fmt(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 + IF (k2 == k1) RETURN ! no letter + IF (fmt(k2 - 1:k2 - 1) == ',') THEN ! Handle (SS,1PF10.3) + k0 = k2 + k1 = VERIFY(fmt(k0:), '0123456789') + 1 + IF (k1 == 0) RETURN + k2 = VERIFY(fmt(k1:), 'ABDEFGILNOPSZabdefgilnopsz,') + k1 - 1 + IF (k2 <= k1) RETURN + END IF + k3 = VERIFY(fmt(k2:), '0123456789') + k2 - 1 + IF (k3 == k2) RETURN ! no digits + WRITE (rw, '(SS,I0)') MIN(999, wnew) + fmt = fmt(1:k2 - 1)//TRIM(rw)//fmt(k3:) +END SUBROUTINE replace_w + + subroutine get_SE(SE, title, shapex, fmt, advance, lbound, seperator, style, trim, unit, orient, zeroas, digmax) + ! Get the settings from the optional parameters fmt...zeroas in to the structure SE. + ! Replace absent arguments with corresponding values from the structure DEFSET. + TYPE(settings), INTENT(out) :: SE + CHARACTER(*), INTENT(in) :: title + INTEGER, INTENT(in) :: shapex(:) + CHARACTER(*), INTENT(in), OPTIONAL :: fmt + INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) + character(*), intent(in), optional :: advance, seperator, style, zeroas, trim, orient + LOGICAL ok + ! + CHARACTER(22) ed + CHARACTER(9) sep, tsty, zas + CHARACTER(1) tch + CHARACTER(6) advchr + INTEGER lun, dmx, w, d, lsep, lzas, m1, n1, adv + LOGICAL trm, number, vec, row, is_scalar, gedit + ! + vec = (SIZE(shapex) == 1) + is_scalar = SIZE(shapex) == 0 + IF (vec .AND. PRESENT(orient)) THEN + SELECT CASE (upper(orient)) + CASE ('ROW'); row = .TRUE. + CASE ('COL'); row = .FALSE. + CASE default; + call disp_errmsg('DISP: error, wrong value of orient: '//orient(1:len_trim(orient))//', using "COL"') + row = .FALSE. + END SELECT + ELSEIF (vec) THEN + row = DEFSET%orient == 'ROW' + ELSE + row = .FALSE. + END IF + IF (PRESENT(fmt)) THEN + CALL readfmt(fmt, ed, w, d, gedit) + ELSE + ed = '()' + w = -1; d = 0; gedit = .FALSE. + END IF + IF (PRESENT(unit)) THEN + lun = unit + ELSE + lun = DEFSET%unit + END IF + IF (.NOT. PRESENT(digmax)) THEN + dmx = DEFSET%digmax + ELSEIF (PRESENT(fmt)) THEN + CALL disp_errmsg('DISP: error, both FMT and DIGMAX present, ignoring DIGMAX') + dmx = 1 + ELSEIF (digmax < 1 .OR. digmax > 89) THEN + CALL disp_errmsg('DISP: error, digmax must be >= 1 and < 90, using 6') + dmx = 6 + ELSE + dmx = digmax + END IF + IF (PRESENT(advance)) THEN + advchr = upper(advance) + ELSE + advchr = DEFSET%advance + END IF + SELECT CASE (trims(advchr)) + CASE ('NO'); adv = 0 + CASE ('YES'); adv = 1 + CASE ('DOUBLE'); adv = 2 + CASE default + call disp_errmsg('DISP: error, illegal advance: ' // trims(advance) // ', using "YES"') + adv = 1 + END SELECT + IF (PRESENT(trim)) THEN + if (upper(trim) /= 'YES' .and. upper(trim) /= 'NO' .and. upper(trim) /= 'AUTO') then + CALL disp_errmsg('DISP: error, illegal trim: '//trims(trim)//', using "YES"') + trm = .TRUE. + ELSE +trm = upper(trim) == 'YES' .OR. upper(trim) == 'AUTO' .AND. .NOT. PRESENT(FMT) + END IF + ELSEIF (w == 0) THEN + trm = .TRUE. + ELSE +trm = DEFSET%trim == 'YES' .OR. DEFSET%trim == 'AUTO' .AND. .NOT. PRESENT(FMT) + END IF + IF (PRESENT(seperator)) THEN + sep = seperator + lsep = LEN(seperator) + ELSE + sep = DEFSET%sep + lsep = DEFSET%seplen + END IF + IF (PRESENT(style)) THEN + CALL getstyles(style, tsty, tch, number, ok) + if (.not. ok) call disp_errmsg('DISP: error, illegal style: '//style//'. Using default instead') + ELSE + CALL getstyles(DEFSET%style, tsty, tch, number, ok) + END IF + IF (title == '') tsty = 'LEFT' + IF (is_scalar) number = .FALSE. + IF (PRESENT(zeroas)) THEN + zas = zeroas + lzas = LEN(zeroas) + ELSE + zas = DEFSET%zeroas + lzas = DEFSET%zaslen + END IF + IF (w > 0) lzas = MIN(w, lzas) + zas = zas(1:lzas) + m1 = 1 + n1 = 1 + IF (PRESENT(lbound)) THEN + number = .TRUE. + IF (SIZE(lbound) == 1) THEN + IF (vec .AND. row) THEN + n1 = LBOUND(1) + ELSE + m1 = LBOUND(1) + END IF + ELSEIF (SIZE(lbound) >= 2) THEN + m1 = LBOUND(1) + n1 = LBOUND(2) + END IF + END IF + SE = settings(ed, sep, tsty, zas, tch, lun, dmx, w, d, lsep, lzas, m1, n1, adv, trm, number, vec, row, gedit) +CONTAINS + FUNCTION trims(s) RESULT(t) + CHARACTER(*), INTENT(in) :: s + CHARACTER(LEN_TRIM(s)) :: t + INTRINSIC trim + t = TRIM(s) + END FUNCTION trims +END SUBROUTINE get_SE + +SUBROUTINE getstyles(style, tsty, tch, number, ok) + ! Return tsty = 'LEFT', 'PAD', or 'UNDERLINE', tch = x from xPAD or xUNDERLINE, number = .true. if style includes + ! NUMBER. If style has ABOVE, return tsty = 'PAD' and tch = ' '. Return tsty = 'LEFT' if error. See NOTE 1 below. + CHARACTER(*), INTENT(in) :: style + CHARACTER(9), INTENT(out) :: tsty + CHARACTER(1), INTENT(out) :: tch + LOGICAL, INTENT(out) :: number, ok + INTEGER kamp, i, nsty + CHARACTER(LEN(style)) :: sty(2) + character(9), parameter :: LPUA(4) = (/'LEFT ', 'PAD ', 'UNDERLINE', 'ABOVE '/) + CHARACTER(9), PARAMETER :: PU(2) = (/'PAD ', 'UNDERLINE'/) + kamp = SCAN(upper(style), '&') + ok = .TRUE. + IF (kamp > 0) THEN + sty(1) = ADJUSTL(upper(style(1:kamp - 1))) + sty(2) = ADJUSTL(upper(style(kamp + 1:))) + nsty = 2 + ELSE + sty(1) = ADJUSTL(upper(style)) + nsty = 1 + END IF + number = .FALSE. + tsty = 'LEFT' + tch = '-' + DO i = 1, nsty + IF (sty(i) == 'NUMBER') THEN + number = .TRUE. + ELSEIF (sty(i) == 'ABOVE') THEN + tsty = 'PAD' + tch = ' ' + ELSEIF (ANY(sty(i) == LPUA)) THEN + tsty = sty(i) + ELSEIF (ANY(sty(i) (2:) == PU)) THEN + tsty = sty(i) (2:) + tch = sty(i) (1:1) + ELSE + ok = .FALSE. + RETURN + END IF + END DO + ok = .TRUE. +END SUBROUTINE getstyles + +SUBROUTINE replace_zeronaninf(s, zas, maskz, masknan, maskminf, maskinf) + ! replace zeros in s (where maskz is true) with zas (i.e. zero-as string) also replace nans with 'NaN', + ! infinities with '+Inf' and minus infinities with '-Inf'. Zeros are aligned with . if zas contains . + ! otherwise right-adjusted. Nans, and infs are right adjusted. + ! NOTE: There are compiler bugs in current versions of both the Absoft and the Pathscale compilers + ! so the merge calls (commented out below) had to be replaced with do loops. + CHARACTER(*), INTENT(INOUT) :: s(:) + LOGICAL, INTENT(in) :: maskz(:), masknan(:), maskinf(:), maskminf(:) + CHARACTER(*), INTENT(in) :: zas + OPTIONAL :: masknan, maskminf, maskinf + CHARACTER(LEN(s)) z, nan, minf, inf + INTEGER w, wz, n, i, k, zasdot + w = LEN(s) + wz = LEN(zas) + n = SIZE(maskz) + IF (wz /= 0 .AND. wz <= w) THEN ! zas not empty and not too wide + zasdot = INDEX(zas, '.') + z = '' + IF (zasdot > 0) THEN + DO i = 1, n + IF (maskz(i)) EXIT + END DO + IF (i <= n) THEN ! some zeros + k = INDEX(s(i), '.') + IF (k == 0 .OR. zasdot > k .OR. wz - zasdot > w - k) THEN ! cannot align .'s + z(w - wz + 1:) = zas ! align right + ELSE + z(k - zasdot + 1:k - zasdot + wz) = zas + END IF + END IF + ELSE + z(w - wz + 1:) = zas + END IF + ! s = merge(z, s, maskz) + DO i = 1, n + IF (maskz(i)) s(i) = z + END DO + END IF + IF (PRESENT(masknan)) THEN + IF (w >= 4) THEN + nan = REPEAT(' ', w - 4)//' NaN' + minf = REPEAT(' ', w - 4)//'-Inf' + inf = REPEAT(' ', w - 4)//'+Inf' + ELSEIF (w == 3) THEN + nan = 'NaN' + minf = '***' + inf = 'Inf' + ELSE + nan = REPEAT('*', w) + minf = nan + inf = nan + END IF + ! s = merge(nan, s, masknan) + ! s = merge(minf, s, maskminf) + ! s = merge(inf, s, maskinf) + DO i = 1, n + IF (masknan(i)) s(i) = nan + IF (maskminf(i)) s(i) = minf + IF (maskinf(i)) s(i) = inf + END DO + END IF +END SUBROUTINE replace_zeronaninf + +PURE FUNCTION upper(s) RESULT(su) ! Change string to upper case + CHARACTER(*), INTENT(in) :: s + CHARACTER(LEN(s)) su + CHARACTER(26), PARAMETER :: ll = 'abcdefghijklmnopqrstuvwxyz', & + ul = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + INTEGER i, k + su = s + DO i = 1, LEN(s) + k = INDEX(ll, s(i:i)) + IF (k > 0) su(i:i) = ul(k:k) + END DO +END FUNCTION upper + +PURE SUBROUTINE sszipfmt(fmt, fmt1) + ! Set fmt1 to '(SS,'//removeblanks(fmt)//')'. Caller is responsible that + ! fmt1 has sufficient length. + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(*), INTENT(out) :: fmt1 + INTEGER i, j + fmt1 = '(SS,' + j = 5 + DO i = 1, LEN(fmt) + IF (fmt(i:i) /= ' ') THEN + fmt1(j:j) = fmt(i:i) + j = j + 1 + END IF + END DO + fmt1(j:j) = ')' +END SUBROUTINE sszipfmt + +PURE FUNCTION nnblk(s) RESULT(n) ! count nonblanks in s + CHARACTER(*), INTENT(in) :: s + INTEGER i, n + n = 0 + DO i = 1, LEN(s) + IF (s(i:i) /= ' ') n = n + 1 + END DO +END FUNCTION nnblk + +SUBROUTINE disp_errmsg(s) + CHARACTER(*), INTENT(in) :: s + INTEGER wleft + CHARACTER(1), POINTER :: boxp(:, :) + wleft = 0 + CALL newbox(DEFAULT_UNIT, 1, LEN(s), boxp) + call copytobox((/s/), lin1 = 1, widj = len(s), widpj = len(s), nblj = 0, boxp = boxp, wleft = wleft) + CALL dispboxlist(DEFAULT_UNIT, sep='') +END SUBROUTINE disp_errmsg +! *********************************** END OF GENERAL PROCEDURES ********************************* + +! ************************************* TOSTRING PROCEDURES ************************************* +SUBROUTINE tostring_check_settings + ! Sanity check of tostring settings + TYPE(tostring_settings) ts + INTEGER wi, wr, d + CHARACTER(MAX(LEN(tosset0%rfmt), LEN(tosset0%ifmt)) + 5) fmt1 + LOGICAL gedit + ts = tosset0 + IF (ALL(ts%trimb /= (/'YES', 'NO '/))) tosset0%trimb = tosfac%trimb + IF (ALL(ts%trimz /= (/'NONE', 'ALL ', 'G '/))) tosset0%trimz = tosfac%trimz + CALL readfmt(tosset0%rfmt, fmt1, wr, d, gedit) + CALL readfmt(tosset0%ifmt, fmt1, wi, d, gedit) + IF (wr < 0) tosset0%rfmt = tosfac%rfmt + IF (wi < 0) tosset0%ifmt = tosfac%ifmt + IF (ALL(ts%trimb /= (/'YES ', 'NO ', 'AUTO'/))) CALL disp_errmsg( & + 'TOSTRING_SET: error, illegal trimb: '//trim(ts%trimb)//', set to ' // trim(tosfac%trimb)) + IF (ALL(ts%trimz /= (/'NONE', 'ALL ', 'G '/))) CALL disp_errmsg( & + 'TOSTRING_SET: error, illegal trimz: '//trim(ts%trimz)//', set to '//trim(tosfac%trimz)) + IF (wr < 0) CALL disp_errmsg( & + 'TOSTRING_SET: error, illegal rfmt: '//trim(ts%rfmt)//', set to '//trim(tosfac%rfmt)) + IF (wi < 0) CALL disp_errmsg( & + 'TOSTRING_SET: error, illegal ifmt: '//trim(ts%ifmt)//', set to '//trim(tosfac%ifmt)) +END SUBROUTINE tostring_check_settings + +PURE SUBROUTINE trim_s_real(sa, gedit, w) + ! Trim trailing zeros and possibly decimal point from fractional part. + ! If sa = '52.2000E12' on entry then it is returned as '52.2E12 '. + ! Whether trimming is actually done depends on tosset0, gedit and w. + CHARACTER(*), INTENT(INOUT) :: sa + LOGICAL, INTENT(in) :: gedit + INTEGER, INTENT(in) :: w + INTEGER k, k2, k3 + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + IF (tosset0%trimz == 'ALL' .OR. tosset0%trimz == 'G' .AND. gedit) THEN + k = SCAN(sa, '.') + IF (k > 0) THEN + k2 = VERIFY(sa(k + 1:), '0123456789') + k + IF (k2 == k) k2 = LEN(sa) + 1 + k3 = VERIFY(sa(k:k2 - 1), '0.', back=.TRUE.) + k - 1 + sa(k3 + 1:) = sa(k2:) + END IF + END IF +END SUBROUTINE trim_s_real + +PURE SUBROUTINE trim_real(sa, gedit, w) + ! Trim trailing zeros and possibly decimal point from fractional part. + ! If sa = '52.2000E12' on entry then it is returned as '52.2E12 '. + ! Whether trimming is actually done depends on tosset0, gedit and w. + CHARACTER(*), INTENT(INOUT) :: sa(:) + LOGICAL, INTENT(in) :: gedit + INTEGER, INTENT(in) :: w + INTEGER i + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + IF (tosset0%trimz == 'ALL' .OR. tosset0%trimz == 'G' .AND. gedit) THEN + DO i = 1, SIZE(sa) ! trim trailing zeros from fractional part + CALL trim_s_real(sa(i), gedit, w) + END DO + END IF +END SUBROUTINE trim_real + +PURE SUBROUTINE tostring_get(sa, st) + ! Copy trimmed elements of sa (containing individual elements as strings) to the final + ! tostring result st, separated by tosset0%sep strings. + CHARACTER(*), INTENT(in) :: sa(:) + CHARACTER(*), INTENT(out) :: st + INTEGER :: i, k, n, sepl + sepl = tosset0%seplen + k = 0 + DO i = 1, SIZE(sa) + IF (k > 0) st(k + 1:k + sepl) = tosset0%sep(1:sepl) + IF (k > 0) k = k + sepl + n = LEN_TRIM(sa(i)) + st(k + 1:k + n) = TRIM(sa(i)) + k = k + n + END DO +END SUBROUTINE tostring_get + +PURE SUBROUTINE tostring_get_complex(sar, sgn, sai, st) + ! Version of tostring_get for complex numbers + CHARACTER(*), INTENT(in) :: sar(:), sai(:), sgn(*) + CHARACTER(*), INTENT(out) :: st + INTEGER :: i, k, n, sepl + sepl = tosset0%seplen + k = 0 + DO i = 1, SIZE(sar) + IF (k > 0) st(k + 1:k + sepl) = tosset0%sep(1:sepl) + IF (k > 0) k = k + sepl + n = LEN_TRIM(sar(i)) + st(k + 1:k + n) = TRIM(sar(i)) + st(k + n + 1:k + n + 3) = ' '//sgn(i)//' ' + k = k + n + 3 + n = LEN_TRIM(sai(i)) + st(k + 1:k + n) = TRIM(sai(i)) + st(k + n + 1:k + n + 1) = 'i' + k = k + n + 1 + END DO +END SUBROUTINE tostring_get_complex + +! ********************************* END OF TOSTRING PROCEDURES ********************************* + +! *********************************** BOX-PACKAGE ********************************************** +! +! A "box" is a variable dimension character matrix that can be created dynamically. There are +! linked lists of boxes, one for each logical unit. When disp is called the item to be displayed +! is written to a box. If advance = 'no' is in effect, the writing out of the items is delayed +! until disp is called on the same unit with advance = 'yes' in effect; then all the boxes in +! the relevant list are written to the unit. There are two subroutines that are meant to be +! called from outside the Box-package: NEWBOX and DISPBOXLIST: +! +! CALL NEWBOX(UNIT, M, N, BOXP) creates a box on unit UNIT. BOXP returns a pointer to the +! created box which is of type CHARACTER and DIMENSION (M,N). +! +! CALL DISPBOXLIST(UNIT, SEP) writes all the boxes in the list associated with UNIT to the file +! on UNIT, separated with the string SEP. The following example makes this clear: let SEP = ' : ' +! and let the first box contain XXX and the second have two rows, both equal to YYYY. Then the +! text written will be: XXX : YYYY : YYYY +! +! To obtain tab-separated boxes when using ASCII, let SEP = char(9). After writing the boxes, +! the complete list is deallocated. If UNIT = -3 the asterisk unit (usually command window) is +! written to. If UNIT = -2 the routine putstr from the disp_where unit is used for writing. If +! UNIT = -1 all output will be discarded. With the iso_fortran_env module of Fortran 2003, unit +! may also equal OUTPUT_UNIT, unless the compiler sets that to -2. + +FUNCTION getboxlist(unit) RESULT(p) + ! Return boxlist associated with specified unit. If this list does not exist a new list is started. + INTEGER, INTENT(in) :: unit + TYPE(boxlist), POINTER :: p + p => firstboxlist + DO WHILE (ASSOCIATED(p)) + IF (p%unit == unit) RETURN + p => p%nextboxlist + END DO + ALLOCATE (p) + p%nextboxlist => firstboxlist ! put at head of list + p%unit = unit + firstboxlist => p +END FUNCTION getboxlist + +SUBROUTINE clearboxlist(unit) + ! Deallocate all boxes associated with unit + INTEGER, INTENT(in) :: unit + TYPE(boxnode), POINTER :: p, q + TYPE(boxlist), POINTER :: blp + blp => firstboxlist + DO WHILE (ASSOCIATED(blp)) + IF (blp%unit == unit) EXIT + blp => blp%nextboxlist + END DO + IF (.NOT. ASSOCIATED(blp)) RETURN + p => blp%firstbox + DO WHILE (ASSOCIATED(p)) + q => p + p => p%nextbox + DEALLOCATE (q%box) + DEALLOCATE (q) + END DO + IF (ASSOCIATED(firstboxlist, blp)) THEN + firstboxlist => blp%nextboxlist + END IF + DEALLOCATE (blp) +END SUBROUTINE clearboxlist + +SUBROUTINE newbox(unit, m, n, boxp) + ! Create a new box + CHARACTER, POINTER :: boxp(:, :) + INTEGER, INTENT(in) :: unit, m, n + TYPE(boxnode), POINTER :: p + TYPE(boxlist), POINTER :: blp + ALLOCATE (p) + ALLOCATE (p%box(n, m)) + blp => getboxlist(unit) + IF (.NOT. ASSOCIATED(blp%firstbox)) THEN + blp%firstbox => p + ELSE + blp%lastbox%nextbox => p + END IF + blp%lastbox => p + boxp => p%box + boxp = ' ' +END SUBROUTINE newbox + +FUNCTION tostr(a) RESULT(s) + ! Copy char array to string + CHARACTER, INTENT(in) :: a(:) + CHARACTER(SIZE(a)) s + INTEGER i + DO i = 1, SIZE(a) + s(i:i) = a(i) + END DO +END FUNCTION tostr + +SUBROUTINE dispboxlist(unit, sep) + ! Display the list of boxes associated with unit + INTEGER, INTENT(in) :: unit + TYPE(boxnode), POINTER :: pfirst, p + TYPE(boxlist), POINTER :: blp + INTEGER k, nlines, h, w, ns + CHARACTER(*), INTENT(in) :: sep + blp => getboxlist(unit) + pfirst => blp%firstbox + nlines = 0 + p => pfirst + DO WHILE (ASSOCIATED(p)) + nlines = MAX(nlines, SIZE(p%box, 2)) + p => p%nextbox + END DO + DO k = 1, nlines + p => pfirst + ns = 0 + DO WHILE (ASSOCIATED(p)) + h = SIZE(p%box, 2) + w = SIZE(p%box, 1) + IF (k <= h) THEN + SELECT CASE (unit) + CASE (-1) + CONTINUE + CASE (-2) + CALL putstr(sep(1:ns)//tostr(p%box(:, k))) + CASE (-3) + WRITE (*, '(2A)', advance='no') sep(1:ns), tostr(p%box(:, k)) + CASE default + WRITE (unit, '(2A)', advance='no') sep(1:ns), tostr(p%box(:, k)) + END SELECT + ELSE + SELECT CASE (unit) + CASE (-1) + CONTINUE + CASE (-2) + CALL putstr(sep(1:ns)//REPEAT(' ', w)) + CASE (-3) + WRITE (*, '(2A)', advance='no') sep(1:ns), REPEAT(' ', w) + CASE default + WRITE (unit, '(2A)', advance='no') sep(1:ns), REPEAT(' ', w) + END SELECT + END IF + p => p%nextbox + ns = LEN(sep) + END DO + CALL dispnewline(unit) + END DO + CALL clearboxlist(unit) +END SUBROUTINE dispboxlist + +SUBROUTINE dispnewline(unit) + INTEGER, INTENT(in) :: unit + SELECT CASE (unit) + CASE (-1); CONTINUE + CASE (-2); CALL putnl + CASE (-3); WRITE (*, *) + CASE default; WRITE (unit, *) + END SELECT +END SUBROUTINE dispnewline + +! subroutine print_boxes +! ! Print info on all boxes (used for debug purposes) +! integer :: k +! type(boxlist), pointer :: bl +! type(boxnode), pointer :: p +! bl => firstboxlist +! write(*,'("BOXES:")') +! do while (associated(bl)) +! write(*,'("UNIT=",SS,I0,":")') bl%unit +! p => bl%firstbox +! k = 1 +! do while(associated(p)) +! write(*,'(" box ",SS,I0,", size=(",I0,",",I0,")")') k, shape(p%box) +! k = k+1 +! p => p%nextbox +! enddo +! bl => bl%nextboxlist +! enddo +! end subroutine print_boxes + +! ******************************** END OF BOX-PACKAGE ******************************* + +END MODULE DISPMODULE_UTIL diff --git a/src/modules/Display/src/disp/putstrmodule.F90 b/src/modules/Display/src/disp/putstrmodule.F90 new file mode 100644 index 000000000..62823a946 --- /dev/null +++ b/src/modules/Display/src/disp/putstrmodule.F90 @@ -0,0 +1,25 @@ +MODULE PUTSTRMODULE ! DUMMY VERSION + ! An auxilliary module that accompanies DISPMODULE. This module contains dummy versions of the + ! subroutines putstr and putnl that do nothing. It is needed to avoid an "undefined symbol" link + ! error for these. In addition it defines the named constant (or parameter) DEFAULT_UNIT = -3, + ! which makes the asterisk unit (usually the screen) the default to display on. + ! + ! The purpose of having this module is to make displaying possible in situations where ordinary + ! print- and write-statements do not work. Then this module should be replaced by one defining + ! functional versions of putstr and putnl. An example is given by the commented out PUTSTRMODULE + ! for Matlab mex files below. + ! + integer, parameter :: DEFAULT_UNIT = -3 + ! +CONTAINS + subroutine putstr(s) + character(*), intent(in) :: s + integer ldummy, ldummy1 ! these variables exist to avoid unused variable warnings + ldummy = len(s) + ldummy1 = ldummy + ldummy = ldummy1 + end subroutine putstr + + subroutine putnl() + end subroutine putnl +END MODULE PUTSTRMODULE diff --git a/src/modules/ElasticNitscheMatrix/CMakeLists.txt b/src/modules/ElasticNitscheMatrix/CMakeLists.txt new file mode 100644 index 000000000..93a59d460 --- /dev/null +++ b/src/modules/ElasticNitscheMatrix/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}/ElasticNitscheMatrix_Method.F90 +) diff --git a/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 b/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 new file mode 100644 index 000000000..124148100 --- /dev/null +++ b/src/modules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method.F90 @@ -0,0 +1,552 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE ElasticNitscheMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: ElasticNitscheMatrix +PUBLIC :: ElasticNitscheMatrixNormal +PUBLIC :: ElasticNitscheMatrixTangent + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1a(test, trial, lambda, mu, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: lambda + CLASS(FEVariable_), INTENT(IN) :: mu + CLASS(FEVariable_), INTENT(IN) :: evec + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1a +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1a +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1b(test, trial, lambda, mu, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + CLASS(FEVariable_), INTENT(IN) :: evec + REAL(DFP), INTENT(IN) :: lambda, mu + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1b +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1b +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1c(test, trial, lambda, mu, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + CLASS(FEVariable_), INTENT(IN) :: evec + REAL(DFP), INTENT(IN) :: lambda(:) + !! quadrature values + REAL(DFP), INTENT(IN) :: mu(:) + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1c +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1c +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1d(test, trial, lambda, mu, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: evec(:, :) + !! vector at quadrature value + REAL(DFP), INTENT(IN) :: lambda(:) + !! quadrature values + REAL(DFP), INTENT(IN) :: mu(:) + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1d +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1d +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1e(test, trial, lambda, mu, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: evec(:, :) + !! vector at quadrature value + REAL(DFP), INTENT(IN) :: lambda, mu + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1e +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1e +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1f(test, trial, lambda, mu, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: evec(:) + !! constant vector + REAL(DFP), INTENT(IN) :: lambda, mu + !! constant lambda and mu + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1f +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1f +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1g(test, trial, lambda, mu, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: evec(:) + !! vector at quadrature value + REAL(DFP), INTENT(IN) :: lambda(:) + !! quadrature values + REAL(DFP), INTENT(IN) :: mu(:) + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1g +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1g +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1h(test, trial, lambda, mu, dim) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + INTEGER(I4B), INTENT(IN) :: dim + !! evec represent e1 , e2, e3 (1,2,3) + REAL(DFP), INTENT(IN) :: lambda(:) + !! quadrature values + REAL(DFP), INTENT(IN) :: mu(:) + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1h +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1h +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1i(test, trial, lambda, mu, dim) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + INTEGER(I4B), INTENT(IN) :: dim + !! evec represent e1 , e2, e3 (1,2,3) + REAL(DFP), INTENT(IN) :: lambda + !! quadrature values + REAL(DFP), INTENT(IN) :: mu + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1i +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1i +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix1j(test, trial, lambda, mu, dim) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + INTEGER(I4B), INTENT(IN) :: dim + !! evec represent e1 , e2, e3 (1,2,3) + !! dim=4 normal direction + !! dim=5 tangent direction + TYPE(FEVariable_), INTENT(IN) :: lambda + !! quadrature values + TYPE(FEVariable_), INTENT(IN) :: mu + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix1j +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix1j +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ElasticNitscheMatrix2a(test, trial, lambda, mu, isNoSlip)& + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: lambda, mu + LOGICAL(LGT), INTENT(IN) :: isNoSlip + !! this is a dummy variable, It is used only to create distinct interface + !! It is not used in the routine + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix2a +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix2a +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix2b(test, trial, lambda, mu, isNoSlip)& + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + CLASS(FEVariable_), INTENT(IN) :: lambda, mu + LOGICAL(LGT), INTENT(IN) :: isNoSlip + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix2b +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix2b +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3a(test, trial, alpha, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: alpha + CLASS(FEVariable_), INTENT(IN) :: evec + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3a +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3a +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3b(test, trial, alpha, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + CLASS(FEVariable_), INTENT(IN) :: evec + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3b +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3b +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3c(test, trial, alpha, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: alpha(:) + REAL(DFP), INTENT(IN) :: evec(:, :) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3c +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3c +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3d(test, trial, alpha, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: evec(:, :) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3d +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3d +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3e(test, trial, alpha, evec) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: evec(:) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3e +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3e +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3f(test, trial, alpha, dim) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: alpha + INTEGER(I4B), INTENT(IN) :: dim + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3f +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3f +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3g(test, trial, alpha, dim) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: alpha + INTEGER(I4B), INTENT(IN) :: dim + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3g +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3g +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrix3h(test, trial, alpha, dim) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: alpha(:) + INTEGER(I4B), INTENT(IN) :: dim + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrix3h +END INTERFACE + +INTERFACE ElasticNitscheMatrix + MODULE PROCEDURE ElasticNitscheMatrix3h +END INTERFACE ElasticNitscheMatrix + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrixNormal@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrixNormal1a(test, trial, lambda, mu) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL(DFP), INTENT(IN) :: lambda(:) + !! quadrature values + REAL(DFP), INTENT(IN) :: mu(:) + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrixNormal1a +END INTERFACE + +INTERFACE ElasticNitscheMatrixNormal + MODULE PROCEDURE ElasticNitscheMatrixNormal1a +END INTERFACE ElasticNitscheMatrixNormal + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrixNormal@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrixNormal1b(test, trial, lambda, mu) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL(DFP), INTENT(IN) :: lambda + !! quadrature values + REAL(DFP), INTENT(IN) :: mu + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrixNormal1b +END INTERFACE + +INTERFACE ElasticNitscheMatrixNormal + MODULE PROCEDURE ElasticNitscheMatrixNormal1b +END INTERFACE ElasticNitscheMatrixNormal + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrixNormal@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrixNormal1c(test, trial, lambda, mu) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: lambda + !! quadrature values + TYPE(FEVariable_), INTENT(IN) :: mu + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrixNormal1c +END INTERFACE + +INTERFACE ElasticNitscheMatrixNormal + MODULE PROCEDURE ElasticNitscheMatrixNormal1c +END INTERFACE ElasticNitscheMatrixNormal + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrixTangent@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrixTangent1a(test, trial, mu, & + & jacobian) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL(DFP), INTENT(IN) :: mu(:) + !! quadrature values + REAL(DFP), INTENT(IN) :: jacobian(:, :, :) + !! jacobian + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrixTangent1a +END INTERFACE + +INTERFACE ElasticNitscheMatrixTangent + MODULE PROCEDURE ElasticNitscheMatrixTangent1a +END INTERFACE ElasticNitscheMatrixTangent + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrixTangent@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrixTangent1b(test, trial, mu) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL(DFP), INTENT(IN) :: mu + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrixTangent1b +END INTERFACE + +INTERFACE ElasticNitscheMatrixTangent + MODULE PROCEDURE ElasticNitscheMatrixTangent1b +END INTERFACE ElasticNitscheMatrixTangent + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrixTangent@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ElasticNitscheMatrixTangent1c(test, trial, mu) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: mu + !! quadrature values + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ElasticNitscheMatrixTangent1c +END INTERFACE + +INTERFACE ElasticNitscheMatrixTangent + MODULE PROCEDURE ElasticNitscheMatrixTangent1c +END INTERFACE ElasticNitscheMatrixTangent + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ElasticNitscheMatrix_Method diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt new file mode 100644 index 000000000..39fa1ba47 --- /dev/null +++ b/src/modules/ElemshapeData/CMakeLists.txt @@ -0,0 +1,43 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/ElemshapeData_Method.F90 + ${src_path}/ElemshapeData_ConstructorMethods.F90 + ${src_path}/ElemshapeData_DivergenceMethods.F90 + ${src_path}/ElemshapeData_GradientMethods.F90 + ${src_path}/ElemshapeData_GetMethods.F90 + + ${src_path}/ElemshapeData_H1Methods.F90 + ${src_path}/ElemshapeData_DGMethods.F90 + ${src_path}/ElemshapeData_HDivMethods.F90 + ${src_path}/ElemshapeData_HCurlMethods.F90 + + ${src_path}/ElemshapeData_HminHmaxMethods.F90 + ${src_path}/ElemshapeData_HRGNParamMethods.F90 + ${src_path}/ElemshapeData_HRQIParamMethods.F90 + ${src_path}/ElemshapeData_InterpolMethods.F90 + ${src_path}/ElemshapeData_IOMethods.F90 + ${src_path}/ElemshapeData_LocalDivergenceMethods.F90 + ${src_path}/ElemshapeData_LocalGradientMethods.F90 + ${src_path}/ElemshapeData_ProjectionMethods.F90 + ${src_path}/ElemshapeData_SetMethods.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods.F90 + ${src_path}/ElemshapeData_UnitNormalMethods.F90 +) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 new file mode 100644 index 000000000..e740cd001 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 @@ -0,0 +1,224 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE ElemshapeData_ConstructorMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Initiate +PUBLIC :: DEALLOCATE +PUBLIC :: ALLOCATE +PUBLIC :: ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Allocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Allocates the memory for various matrices in elemsd +! +!# Introduction +! +!- This subroutine allocates the memory for various matrices in the obj. +!- This subroutine belongs to the generic interface called `Allocate()`. + +INTERFACE ALLOCATE + MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! object to be returned + INTEGER(I4B), INTENT(IN) :: nsd + !! spatial dimension + INTEGER(I4B), INTENT(IN) :: xidim + !! xidimension + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in element + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points + END SUBROUTINE elemsd_Allocate +END INTERFACE ALLOCATE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the element shapefunction data + +INTERFACE Initiate + MODULE SUBROUTINE elemsd_initiate1(obj, quad, refelem, continuityType, & + & interpolType) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! ElemshapeData to be formed + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! Quadrature points + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! reference element + CHARACTER(*), INTENT(IN) :: continuityType + !! - continuity/ conformity of shape function (basis functions) + CHARACTER(*), INTENT(IN) :: interpolType + !! interpolation/polynomial family for basis functions + END SUBROUTINE elemsd_initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Copy data from an instance of elemshapedata to another instance + +INTERFACE Initiate + MODULE SUBROUTINE elemsd_initiate2(obj1, obj2) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj1 + TYPE(ElemshapeData_), INTENT(IN) :: obj2 + END SUBROUTINE elemsd_initiate2 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE elemsd_initiate2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Initiate an instance of ElemshapeData from STElemshapeData +! +!# Introduction +! +! This subroutine initiates an instance of ElemshapeData by copying data +! from an instance of STElemshapeData. + +INTERFACE Initiate + MODULE SUBROUTINE elemsd_initiate3(obj1, obj2) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj1 + TYPE(STElemshapeData_), INTENT(IN) :: obj2 + END SUBROUTINE elemsd_initiate3 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE elemsd_initiate3 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: This routine initiates an instance of STElemshapeData +! +!# Introduction +! +! This routine initiate an instance of STElemshapeData by copying data +! from the instance of ElemshapeData + +INTERFACE Initiate + MODULE SUBROUTINE elemsd_initiate4(obj1, obj2) + TYPE(STElemshapeData_), INTENT(INOUT) :: obj1 + TYPE(ElemshapeData_), INTENT(IN) :: obj2 + END SUBROUTINE elemsd_initiate4 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE elemsd_initiate4 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Initiate an instance of STElemshapeData from instance of same class +! +!# Introduction +! This routine initiates an instance of STElemshapeData by copying data +! from the instance of STElemshapeData. + +INTERFACE Initiate + MODULE SUBROUTINE elemsd_initiate5(obj1, obj2) + TYPE(STElemshapeData_), INTENT(INOUT) :: obj1 + TYPE(STElemshapeData_), INTENT(IN) :: obj2 + END SUBROUTINE elemsd_initiate5 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE elemsd_initiate5 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Initiate time shape function data in [[stelemshapedata_]] +! +!# Introduction +! +! - This subroutine initiates the shape-function data related to time +! domain in the instance of [[stelemshapedata_]]. +! - User should provide an instance of [[Elemshapedata_]] elemsd, +! - The `elemsd`, actually contains the information of +! the shape-function in the time domain +! - The shape-function data in the time domain is +! - $T$ +! - $\frac{dT}{d\theta}$ +! - ... +!@note +! This routine uses `elemsd` to set `obj%T`, `obj%dTdTheta`, `obj%Jt`, +! `obj%Wt`, `obj%Theta`. +!@endnote +! + +INTERFACE Initiate + MODULE PURE SUBROUTINE stsd_initiate(obj, elemsd) + TYPE(STElemshapeData_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + TYPE(ElemshapeData_), INTENT(IN) :: elemsd + !! It has information about location shape function for time element + END SUBROUTINE stsd_initiate +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Deallocates the data stored inside [[elemshapedata_]] +! +!# Introduction +! +! This routine deallocates the data stored inside [[elemshapedata_]]. This +! routine belongs to `Allocate()` +! + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE elemsd_Deallocate(obj) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + END SUBROUTINE elemsd_Deallocate +END INTERFACE DEALLOCATE + +END MODULE ElemshapeData_ConstructorMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 new file mode 100644 index 000000000..f212f608a --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_DGHermitMethods.F90 @@ -0,0 +1,53 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +module ElemshapeData_DGHermitMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +public :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGHermit +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. +! + +INTERFACE + MODULE PURE SUBROUTINE DG_Hermit(obj, quad, refElem, & + & continuityType, interpolType) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refElem + CLASS(DG_), INTENT(IN) :: continuityType + CLASS(HermitInterpolation_), INTENT(IN) :: interpolType + END SUBROUTINE DG_Hermit +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE DG_Hermit +END INTERFACE Initiate + +end module ElemshapeData_DGHermitMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 new file mode 100644 index 000000000..8dcbc4c20 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_DGHierarchyMethods.F90 @@ -0,0 +1,53 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +module ElemshapeData_DGHierarchyMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +public :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGHierarchy +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. +! + +INTERFACE + MODULE PURE SUBROUTINE DG_Hierarchy(obj, quad, refElem, & + & continuityType, interpolType) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refElem + CLASS(DG_), INTENT(IN) :: continuityType + CLASS(HierarchyInterpolation_), INTENT(IN) :: interpolType + END SUBROUTINE DG_Hierarchy +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE DG_Hierarchy +END INTERFACE Initiate + +end module ElemshapeData_DGHierarchyMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 new file mode 100644 index 000000000..0d05a4908 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_DGLagrangeMethods.F90 @@ -0,0 +1,53 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +module ElemshapeData_DGLagrangeMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +public :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGLagrange +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. +! + +INTERFACE + MODULE PURE SUBROUTINE DG_Lagrange(obj, quad, refElem, & + & continuityType, interpolType) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refElem + CLASS(DG_), INTENT(IN) :: continuityType + CLASS(LagrangeInterpolation_), INTENT(IN) :: interpolType + END SUBROUTINE DG_Lagrange +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE DG_Lagrange +END INTERFACE Initiate + +end module ElemshapeData_DGLagrangeMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 new file mode 100644 index 000000000..58e4a52ee --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_DGMethods.F90 @@ -0,0 +1,252 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_DGMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE DG_Lagrange1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & coeff, & + & firstCall, & + & alpha, & + & beta, & + & lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + CLASS(DG_), INTENT(IN) :: baseContinuity + CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation point type + !! Default value is Equidistance + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function types + !! Default value is Monomial + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE DG_Lagrange1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGHierarchy +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE DG_Hierarchy1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(DG_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + !! This argument is not needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + !! This argument is not needed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + !! This argument is not needed + END SUBROUTINE DG_Hierarchy1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGOrthogonal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE DG_Orthogonal1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(DG_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE DG_Orthogonal1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGHermit +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE DG_Hermit1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(DG_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE DG_Hermit1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGSerendipity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE DG_Serendipity1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(DG_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE DG_Serendipity1 +END INTERFACE Initiate + +END MODULE ElemshapeData_DGMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 new file mode 100644 index 000000000..30b833a50 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_DGSerendipityMethods.F90 @@ -0,0 +1,54 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_DGSerendipityMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +public :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@DGSerendipity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. +! + +INTERFACE + MODULE PURE SUBROUTINE DG_Serendipity(obj, quad, refElem, & + & continuityType, interpolType) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refElem + CLASS(DG_), INTENT(IN) :: continuityType + CLASS(SerendipityInterpolation_), INTENT(IN) :: interpolType + END SUBROUTINE DG_Serendipity +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE DG_Serendipity +END INTERFACE Initiate + +end module ElemshapeData_DGSerendipityMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 new file mode 100644 index 000000000..a22cb4207 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 @@ -0,0 +1,245 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_DivergenceMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: getDivergence +PUBLIC :: Divergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_1(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) + !! Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :) + !! space nodal values of vector in `xiJ` format + !! row index: space component + !! col index: node number + END SUBROUTINE elemsd_getDivergence_1 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_1 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence of a vector +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_2(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) + !! Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + END SUBROUTINE elemsd_getDivergence_2 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_2 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence of a vector +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_3(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) + !! Divergence of vector at integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! vector finite-element variable + END SUBROUTINE elemsd_getDivergence_3 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_3 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence of a matrix + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_4(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getDivergence_4 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_4 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_5(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal values of matrix in (i,j,I,a) format + END SUBROUTINE elemsd_getDivergence_5 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_5 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_6(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! Divergence at integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space/space-time nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getDivergence_6 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_6 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_7(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! Divergence of scalar/vector/matrix at space integration points + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE elemsd_getDivergence_7 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_7 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! getDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Divergence + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getDivergence_8(obj, lg, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! Divergence of scalar/vector/matrix at space-time + !! integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space time nodal values of scalar/vector/matrix + END SUBROUTINE elemsd_getDivergence_8 +END INTERFACE + +INTERFACE getDivergence + MODULE PROCEDURE elemsd_getDivergence_8 +END INTERFACE getDivergence + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_Divergence_1(obj, val) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_Divergence_1 +END INTERFACE + +INTERFACE Divergence + MODULE PROCEDURE elemsd_Divergence_1 +END INTERFACE Divergence + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_Divergence_2(obj, val) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_Divergence_2 +END INTERFACE + +INTERFACE Divergence + MODULE PROCEDURE elemsd_Divergence_2 +END INTERFACE Divergence + +end module ElemshapeData_DivergenceMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 new file mode 100644 index 000000000..084e82e6a --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 @@ -0,0 +1,94 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_GetMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: getNormal + +!---------------------------------------------------------------------------- +! GetNormal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Jan 2022 +! update: 28 Jan 2022 +! summary: This routine returns the normal vector stored in [[ElemShapeData_]] + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getNormal_1(obj, normal, nsd) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: normal(:, :) + !! normal(1:3, 1:nip) = obj%normal + INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd + END SUBROUTINE elemsd_getNormal_1 +END INTERFACE + +INTERFACE getNormal + MODULE PROCEDURE elemsd_getNormal_1 +END INTERFACE getNormal + +!---------------------------------------------------------------------------- +! GetNormal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Jan 2022 +! update: 28 Jan 2022 +! summary: This routine returns the normal vector stored in [[ElemShapeData_]] + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getNormal_2(obj, normal, nsd) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: normal + !! normal(1:3, 1:nip) = obj%normal + !! Quadrature, Vector, Space + INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd + END SUBROUTINE elemsd_getNormal_2 +END INTERFACE + +INTERFACE getNormal + MODULE PROCEDURE elemsd_getNormal_2 +END INTERFACE getNormal + +!---------------------------------------------------------------------------- +! GetNormal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Jan 2022 +! update: 28 Jan 2022 +! summary: This routine returns the normal vector stored in [[ElemShapeData_]] + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getNormal_3(obj, normal, nsd) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: normal + !! normal(1:3, 1:nip) = obj%normal + !! Quadrature, Vector, SpaceTime + INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd + END SUBROUTINE elemsd_getNormal_3 +END INTERFACE + +INTERFACE getNormal + MODULE PROCEDURE elemsd_getNormal_3 +END INTERFACE getNormal + +end module ElemshapeData_GetMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 new file mode 100644 index 000000000..dce3a5ba4 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_GradientMethods.F90 @@ -0,0 +1,323 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +module ElemshapeData_GradientMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: getSpatialGradient +PUBLIC :: SpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of scalar + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_1(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! Spatial gradient of scalar + REAL(DFP), INTENT(IN) :: val(:) + !! Nodal values of scalar + END SUBROUTINE elemsd_getSpatialGradient_1 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_1 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_2(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) + !! spatial gradient of vector at integration points + REAL(DFP), INTENT(IN) :: val(:, :) + !! nodal values of vector in `xiJ` format + END SUBROUTINE elemsd_getSpatialGradient_2 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_2 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of scalar + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_3(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! Spatial gradient of scalar + REAL(DFP), INTENT(IN) :: val(:, :) + !! space-time Nodal values of scalar + END SUBROUTINE elemsd_getSpatialGradient_3 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_3 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of scalar +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_4(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) + !! spatial gradient of vector at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + END SUBROUTINE elemsd_getSpatialGradient_4 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_4 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of scalar + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_5(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! Spatial gradient of scalar + TYPE(FEVariable_), INTENT(IN) :: val + !! Nodal values of scalar + END SUBROUTINE elemsd_getSpatialGradient_5 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_5 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of scalar +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_6(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) + !! spatial gradient of vector at integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space-time nodal values of vector in `xiJa` format + END SUBROUTINE elemsd_getSpatialGradient_6 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_6 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of a matrix + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_7(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) + !! spatial gradient at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getSpatialGradient_7 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_7 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of a matrix + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_8(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) + !! spatial gradient at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal values of matrix in (i,j,I,a) format + END SUBROUTINE elemsd_getSpatialGradient_8 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_8 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_9(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) + !! spatial gradient at integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getSpatialGradient_9 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_9 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient +! +!# Introduction +! +! - This routine returns spatial gradient in [[FEVariable_]] +! the input is also a [[FEVariable_]]. +! - This routine can be considered as a master routine + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_10(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! spatial gradient of scalar/vector/matrix at space integration points + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE elemsd_getSpatialGradient_10 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_10 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! getSpatialGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the spatial gradient +! +!# Introduction +! +! - This routine returns spatial gradient in [[FEVariable_]] +! the input is also a [[FEVariable_]]. +! - This routine can be considered as a master routine + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getSpatialGradient_11(obj, lg, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! spatial gradient of scalar/vector/matrix at space-time + !! integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space time nodal values of scalar/vector/matrix + END SUBROUTINE elemsd_getSpatialGradient_11 +END INTERFACE + +INTERFACE getSpatialGradient + MODULE PROCEDURE elemsd_getSpatialGradient_11 +END INTERFACE getSpatialGradient + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_SpatialGradient_1(obj, val) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_SpatialGradient_1 +END INTERFACE + +INTERFACE SpatialGradient + MODULE PROCEDURE elemsd_SpatialGradient_1 +END INTERFACE SpatialGradient + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_SpatialGradient_2(obj, val) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_SpatialGradient_2 +END INTERFACE + +INTERFACE SpatialGradient + MODULE PROCEDURE elemsd_SpatialGradient_2 +END INTERFACE SpatialGradient + +end module ElemshapeData_GradientMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 new file mode 100644 index 000000000..2af6c22b6 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 @@ -0,0 +1,252 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_H1Methods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE H1_Lagrange1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & coeff, & + & firstCall, & + & alpha, & + & beta, & + & lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + CLASS(H1_), INTENT(IN) :: baseContinuity + CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation point type + !! Default value is Equidistance + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function types + !! Default value is Monomial + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE H1_Lagrange1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@H1Hierarchy +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE H1_Hierarchy1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(H1_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + !! This argument is not needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + !! This argument is not needed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + !! This argument is not needed + END SUBROUTINE H1_Hierarchy1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@H1Orthogonal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE H1_Orthogonal1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(H1_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE H1_Orthogonal1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@H1Hermit +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE H1_Hermit1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(H1_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE H1_Hermit1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@H1Serendipity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE H1_Serendipity1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(H1_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE H1_Serendipity1 +END INTERFACE Initiate + +END MODULE ElemshapeData_H1Methods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 new file mode 100644 index 000000000..dadbfeeaa --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_HCurlMethods.F90 @@ -0,0 +1,253 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_HCurlMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE HCurl_Lagrange1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & coeff, & + & firstCall, & + & alpha, & + & beta, & + & lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + CLASS(HCurl_), INTENT(IN) :: baseContinuity + CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation point type + !! Default value is Equidistance + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function types + !! Default value is Monomial + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE HCurl_Lagrange1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@HCurlHierarchy +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE HCurl_Hierarchy1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HCurl_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + !! This argument is not needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + !! This argument is not needed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + !! This argument is not needed + END SUBROUTINE HCurl_Hierarchy1 +END INTERFACE Initiate + + +!---------------------------------------------------------------------------- +! Initiate@HCurlOrthogonal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE HCurl_Orthogonal1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HCurl_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE HCurl_Orthogonal1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@HCurlHermit +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE HCurl_Hermit1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HCurl_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE HCurl_Hermit1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@HCurlSerendipity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE HCurl_Serendipity1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HCurl_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE HCurl_Serendipity1 +END INTERFACE Initiate + +END MODULE ElemshapeData_HCurlMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 new file mode 100644 index 000000000..5aaa909c9 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_HDivMethods.F90 @@ -0,0 +1,253 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_HDivMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE HDiv_Lagrange1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & coeff, & + & firstCall, & + & alpha, & + & beta, & + & lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + CLASS(HDiv_), INTENT(IN) :: baseContinuity + CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation point type + !! Default value is Equidistance + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function types + !! Default value is Monomial + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE HDiv_Lagrange1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@HDivHierarchy +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE HDiv_Hierarchy1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HDiv_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + !! This argument is not needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + !! This argument is not needed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + !! This argument is not needed + END SUBROUTINE HDiv_Hierarchy1 +END INTERFACE Initiate + + +!---------------------------------------------------------------------------- +! Initiate@HDivOrthogonal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-09-02 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE HDiv_Orthogonal1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HDiv_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE HDiv_Orthogonal1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@HDivHermit +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data +! +!# Introduction +! +! This routine initiates the shape function related data inside the element. + +INTERFACE Initiate + MODULE SUBROUTINE HDiv_Hermit1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HDiv_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(HermitInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE HDiv_Hermit1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@HDivSerendipity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate the shape data + +INTERFACE Initiate + MODULE SUBROUTINE HDiv_Serendipity1( & + & obj, & + & quad, & + & refelem, & + & baseContinuity, & + & baseInterpolation, & + & order, & + & ipType, & + & basisType, & + & alpha, beta, lambda & + &) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! Element shape data + CLASS(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point type + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Reference element type + CLASS(HDiv_), INTENT(IN) :: baseContinuity + !! Base continuity type + CLASS(SerendipityInterpolation_), INTENT(IN) :: baseInterpolation + !! Base Interpolation type + INTEGER(I4B), INTENT(IN) :: order + !! Order of polynomials + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! alpha and beta are Jacobi polynomial param + !! lambda is Ultraspherical polynomial param + END SUBROUTINE HDiv_Serendipity1 +END INTERFACE Initiate + +END MODULE ElemshapeData_HDivMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 new file mode 100644 index 000000000..55e093c20 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_HRGNParamMethods.F90 @@ -0,0 +1,141 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_HRGNParamMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetHRGNParam + +!---------------------------------------------------------------------------- +! GetHRGNParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRGN param +! +!# Introduction +! +! In this method `h` is oneD real-vector defined at quadrature points + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRGNParam1(obj, h, val, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) + !! h is a scalar field and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetHRGNParam1 +END INTERFACE + +INTERFACE GetHRGNParam + MODULE PROCEDURE elemsd_GetHRGNParam1 +END INTERFACE GetHRGNParam + +!---------------------------------------------------------------------------- +! GetHRGNParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRGN param +! +!# Introduction +! +!- This routine is same as `elemsd_GetHRGNParam1` +!- Here, `h` is an [[FEVariable_]] (scalar and quadVariable) +!- This routine calls `elemsd_GetHRGNParam1` and then convert +!- the result in to [[FEVariable_]]. + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRGNParam2(obj, h, val, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: h + !! h is a scalar, and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetHRGNParam2 +END INTERFACE + +INTERFACE GetHRGNParam + MODULE PROCEDURE elemsd_GetHRGNParam2 +END INTERFACE GetHRGNParam + +!---------------------------------------------------------------------------- +! GetHRGNParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRGN param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRGNParam3(obj, h, val, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:, :) + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! it can be a scalar, defined on space or space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + END SUBROUTINE elemsd_GetHRGNParam3 +END INTERFACE + +INTERFACE GetHRGNParam + MODULE PROCEDURE elemsd_GetHRGNParam3 +END INTERFACE GetHRGNParam + +!---------------------------------------------------------------------------- +! GetHRGNParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRGN param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRGNParam4(obj, h, val, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + TYPE(FEVariable_), INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! it can be a scalar, defined on space or space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + END SUBROUTINE elemsd_GetHRGNParam4 +END INTERFACE + +INTERFACE GetHRGNParam + MODULE PROCEDURE elemsd_GetHRGNParam4 +END INTERFACE GetHRGNParam + +end module ElemshapeData_HRGNParamMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 new file mode 100644 index 000000000..c3a494971 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_HRQIParamMethods.F90 @@ -0,0 +1,147 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_HRQIParamMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetHRQIParam + +!---------------------------------------------------------------------------- +! GetHRQIParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRQIParam1(obj, h, val, hmax, hmin, & + & r, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) + !! h is a scalar, and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmax(:) + !! maximum directional length, size(hmax) = nips + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmin(:) + !! minimum directional length, size(hmin) = nips + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: r(:, :) + !! unit normal, shape(r) = (nsd, nips) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetHRQIParam1 +END INTERFACE + +INTERFACE GetHRQIParam + MODULE PROCEDURE elemsd_GetHRQIParam1 +END INTERFACE GetHRQIParam + +!---------------------------------------------------------------------------- +! GetHRQIParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRQIParam2(obj, h, val, hmax, & + & hmin, r, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: h + !! h is a scalar, and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax, hmin, r + !! h is a scalar, and defined on quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetHRQIParam2 +END INTERFACE + +INTERFACE GetHRQIParam + MODULE PROCEDURE elemsd_GetHRQIParam2 +END INTERFACE GetHRQIParam + +!---------------------------------------------------------------------------- +! GetHRQIParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRQIParam3(obj, h, val, hmax, & + & hmin, r, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:, :) + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! it can be a scalar, defined on space or space-time quadrature points + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmax(:, :) + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: hmin(:, :) + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: r(:, :, :) + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + END SUBROUTINE elemsd_GetHRQIParam3 +END INTERFACE + +INTERFACE GetHRQIParam + MODULE PROCEDURE elemsd_GetHRQIParam3 +END INTERFACE GetHRQIParam + +!---------------------------------------------------------------------------- +! GetHRQIParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHRQIParam4(obj, h, val, hmax, & + & hmin, r, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + TYPE(FEVariable_), INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! it can be a scalar, defined on space or space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax, hmin, r + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + END SUBROUTINE elemsd_GetHRQIParam4 +END INTERFACE + +INTERFACE GetHRQIParam + MODULE PROCEDURE elemsd_GetHRQIParam4 +END INTERFACE GetHRQIParam + +end module ElemshapeData_HRQIParamMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 new file mode 100644 index 000000000..a786e31b2 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_HminHmaxMethods.F90 @@ -0,0 +1,228 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_HminHmaxMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns Hmin and Hmax + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHminHmax1(obj, hmax, hmin) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:) + !! maximum directional length, size(hmax) = nips + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:) + !! minimum directional length, size(hmin) = nips + END SUBROUTINE elemsd_GetHminHmax1 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax1 +END INTERFACE GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns Hmin and Hmax + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHminHmax2(obj, hmax, hmin, G) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:) + !! maximum directional length, size(hmax) = nips + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:) + !! minimum directional length, size(hmin) = nips + REAL(DFP), INTENT(IN) :: G(:, :, :) + !! shape(G) = [nsd, nsd, nips] + END SUBROUTINE elemsd_GetHminHmax2 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax2 +END INTERFACE GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns Hmin and Hmax + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHminHmax3(obj, hmax, hmin) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: hmax + !! maximum directional length, size(hmax) = nips + TYPE(FEVariable_), INTENT(INOUT) :: hmin + !! minimum directional length, size(hmin) = nips + END SUBROUTINE elemsd_GetHminHmax3 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax3 +END INTERFACE GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns Hmin and Hmax + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetHminHmax6(obj, hmax, hmin, G) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: hmax + !! maximum directional length, size(hmax) = nips + TYPE(FEVariable_), INTENT(INOUT) :: hmin + !! minimum directional length, size(hmin) = nips + REAL(DFP), INTENT(IN) :: G(:, :, :) + !! shape=[nsd, nsd, nips] + END SUBROUTINE elemsd_GetHminHmax6 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax6 +END INTERFACE GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE SUBROUTINE elemsd_GetHminHmax4(obj, hmax, hmin) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:, :) + !! shape(hmax) = [nips, nipt] + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:, :) + !! shape(hmin) = [nips, nipt] + END SUBROUTINE elemsd_GetHminHmax4 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax4 +END INTERFACE GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE SUBROUTINE elemsd_GetHminHmax7(obj, hmax, hmin, G) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmax(:, :) + !! shape(hmax) = [nips, nipt] + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: hmin(:, :) + !! shape(hmin) = [nips, nipt] + REAL(DFP), INTENT(IN) :: G(:, :, :, :) + !! shape = [nsd, nsd, nips, nipt] + END SUBROUTINE elemsd_GetHminHmax7 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax7 +END INTERFACE GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE SUBROUTINE elemsd_GetHminHmax5(obj, hmax, hmin) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + !! it can be a scalar, defined on space or space-time quadrature points + TYPE(FEVariable_), INTENT(INOUT) :: hmax, hmin + !! SpaceTime, Quadrature + END SUBROUTINE elemsd_GetHminHmax5 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax5 +END INTERFACE GetHminHmax + +!---------------------------------------------------------------------------- +! GetHminHmax@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the HRQI param + +INTERFACE + MODULE SUBROUTINE elemsd_GetHminHmax8(obj, hmax, hmin, G) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! Spacetime shape function data, obj(ipt) denotes data at + !! ipt quadrature point in time domain + !! it can be a scalar, defined on space or space-time quadrature points + TYPE(FEVariable_), INTENT(INOUT) :: hmax, hmin + !! SpaceTime, Quadrature + REAL(DFP), INTENT(IN) :: G(:, :, :, :) + !! shape = [nsd, nsd, nips, nipt] + END SUBROUTINE elemsd_GetHminHmax8 +END INTERFACE + +INTERFACE GetHminHmax + MODULE PROCEDURE elemsd_GetHminHmax8 +END INTERFACE GetHminHmax + +end module ElemshapeData_HminHmaxMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 new file mode 100644 index 000000000..3ddeaf0f5 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 @@ -0,0 +1,92 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE ElemshapeData_IOMethods +USE BaseType +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE + +PUBLIC :: Display +PUBLIC :: ElemshapeData_MdEncode +PUBLIC :: MdEncode +PUBLIC :: ElemshapeData_ReactEncode + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] + +INTERFACE Display + MODULE SUBROUTINE elemsd_display_1(obj, msg, unitNo) + CLASS(ElemshapeData_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + END SUBROUTINE elemsd_display_1 +END INTERFACE Display + +!---------------------------------------------------------------------------- +! ElemshapeData_MdEncode@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] + +INTERFACE MdEncode + MODULE FUNCTION ElemshapeData_MdEncode(obj) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(String) :: ans + END FUNCTION ElemshapeData_MdEncode +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! ElemshapeData_ReactEncode@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] + +INTERFACE + MODULE FUNCTION ElemshapeData_ReactEncode(obj) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(String) :: ans + END FUNCTION ElemshapeData_ReactEncode +END INTERFACE + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Display the content of [[elemshapedata_]] and [[stelemshapedata_]] + +INTERFACE Display + MODULE SUBROUTINE elemsd_display_2(obj, msg, unitNo) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo + END SUBROUTINE elemsd_display_2 +END INTERFACE Display + +END MODULE ElemshapeData_IOMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 new file mode 100644 index 000000000..1074afee6 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -0,0 +1,695 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_InterpolMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +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 + MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) + !! Interpolation value of of scalar + REAL(DFP), INTENT(IN) :: val(:) + !! spatial nodal values of scalar + END SUBROUTINE scalar_getInterpolation_1 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE scalar_getInterpolation_1 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolations of scalar nodal values +! +!# Introduction +! +! This subroutine performs interpolation of a scalar from its space-time nodal +! values. +! +! $$u=u^{a}_{I}N^{I}T_{a}$$ +! +! The resultant represents the interpolation value of `val` at +! spatial-quadrature points + +INTERFACE + MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:) + !! Interpolation of scalar + REAL(DFP), INTENT(IN) :: val(:, :) + !! space-time nodal values of scalar + END SUBROUTINE scalar_getInterpolation_2 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE scalar_getInterpolation_2 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolations of scalar nodal values +! +!# 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 + MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) + !! space-time Interpolation of scalar + REAL(DFP), INTENT(IN) :: val(:, :) + !! space-time nodal values of scalar + END SUBROUTINE scalar_getInterpolation_3 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE scalar_getInterpolation_3 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of scalar FEVariable +! +!# Introduction +! +! Returns the interpolation of scalar variable +! The scalar variable can be+ +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +!@note +!This routine calls [[Interpolation]] function from the same module. +!@endnote + +INTERFACE + 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 + +INTERFACE getInterpolation + MODULE PROCEDURE scalar_getInterpolation_4 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolations of scalar FEVariable +! +!# Introduction +! +! This subroutine performs interpolation of a scalar [[FEVariable_]] +! The FE Variable can be a +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +! $$u=u^{a}_{I}N^{I}T_{a}$$ +! +! The resultant represents the interpolation value of `val` at +! spatial-quadrature points + +INTERFACE + MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) + !! space-time interpolation of scalar + TYPE(FEVariable_), INTENT(IN) :: val + !! scalar FE variable + END SUBROUTINE scalar_getInterpolation_5 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE scalar_getInterpolation_5 +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 + MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) + !! interpolation of vector + REAL(DFP), INTENT(IN) :: val(:, :) + !! nodal values of vector in `xiJ` format + END SUBROUTINE vector_getInterpolation_1 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE vector_getInterpolation_1 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of a vector +! +!# Introduction +! +! This subroutine performs interpolation of a vector from its space-time +! nodal values +! +! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ + +INTERFACE + MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) + !! + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + END SUBROUTINE vector_getInterpolation_2 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE vector_getInterpolation_2 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of a vector +! +!# Introduction +! +! This subroutine performs interpolation of a vector from its space-time +! nodal values +! +! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ + +INTERFACE + MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) + !! + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + END SUBROUTINE vector_getInterpolation_3 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE vector_getInterpolation_3 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of vector FEVariable +! +!# Introduction +! +! Returns the interpolation of vector variable +! The vector variable can be+ +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +! NOTE This routine calls [[Interpolation]] function from the same module. +! +INTERFACE + MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val) + 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 + +INTERFACE getInterpolation + MODULE PROCEDURE vector_getInterpolation_4 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of vector FEVariable +! +!# Introduction +! +! Returns the interpolation of vector variable +! The vector variable can be+ +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +! NOTE This routine calls [[Interpolation]] function from the same module. +! +INTERFACE + MODULE PURE SUBROUTINE vector_getInterpolation_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 + +INTERFACE getInterpolation + MODULE PROCEDURE vector_getInterpolation_5 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolation of matrix + +INTERFACE + MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) + !! interpolation of matrix + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! nodal value of matrix + END SUBROUTINE matrix_getInterpolation_1 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE matrix_getInterpolation_1 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of matrix +! +!# Introduction +! +! This subroutine performs interpolation of matrix from its space-time +! nodal values + +INTERFACE + MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal value of matrix + END SUBROUTINE matrix_getInterpolation_2 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE matrix_getInterpolation_2 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of matrix +! +!# Introduction +! +! This subroutine performs interpolation of matrix from its space-time +! nodal values + +INTERFACE + MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :, :) + !! space-time interpolation + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal value of matrix + END SUBROUTINE matrix_getInterpolation_3 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE matrix_getInterpolation_3 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolation of matrix FEVariable +! +INTERFACE + MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) + !! interpolation of matrix + TYPE(FEVariable_), INTENT(IN) :: val + !! matrix fe variable + END SUBROUTINE matrix_getInterpolation_4 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE matrix_getInterpolation_4 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +INTERFACE + 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 + +INTERFACE getInterpolation + MODULE PROCEDURE matrix_getInterpolation_5 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 + MODULE PURE SUBROUTINE master_getInterpolation_1(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: interpol + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE master_getInterpolation_1 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE master_getInterpolation_1 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 + MODULE PURE SUBROUTINE master_getInterpolation_2(obj, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: interpol + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE master_getInterpolation_2 +END INTERFACE + +INTERFACE getInterpolation + MODULE PROCEDURE master_getInterpolation_2 +END INTERFACE getInterpolation + +!---------------------------------------------------------------------------- +! Interpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This function returns the interpolation of a scalar + +INTERFACE + MODULE PURE FUNCTION scalar_interpolation_1(obj, val) RESULT(interpol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), ALLOCATABLE :: interpol(:) + END FUNCTION scalar_interpolation_1 +END INTERFACE + +INTERFACE Interpolation + MODULE PROCEDURE scalar_interpolation_1 +END INTERFACE Interpolation + +!---------------------------------------------------------------------------- +! Interpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This function returns the interpolation of vector + +INTERFACE + MODULE PURE FUNCTION vector_interpolation_1(obj, val) RESULT(interpol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + REAL(DFP), ALLOCATABLE :: interpol(:, :) + END FUNCTION vector_interpolation_1 +END INTERFACE + +INTERFACE Interpolation + MODULE PROCEDURE vector_interpolation_1 +END INTERFACE Interpolation + +!---------------------------------------------------------------------------- +! Interpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This function returns the interpolation of matrix + +INTERFACE + MODULE PURE FUNCTION matrix_interpolation_1(obj, val) RESULT(interpol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + REAL(DFP), ALLOCATABLE :: interpol(:, :, :) + END FUNCTION matrix_interpolation_1 +END INTERFACE + +INTERFACE Interpolation + MODULE PROCEDURE matrix_interpolation_1 +END INTERFACE Interpolation + +!---------------------------------------------------------------------------- +! Interpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-13 +! update: 2021-12-13 +! summary: Interpolation of FEVariable + +INTERFACE + MODULE PURE FUNCTION master_interpolation_1(obj, val) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION master_interpolation_1 +END INTERFACE + +INTERFACE Interpolation + 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_LocalDivergenceMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 new file mode 100644 index 000000000..52e2195e9 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods.F90 @@ -0,0 +1,264 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_LocalDivergenceMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: getLocalDivergence +PUBLIC :: LocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local Divergence of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_1(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) + !! local Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :) + !! space nodal values of vector in `xiJ` format + !! row index: space component + !! col index: node number + END SUBROUTINE elemsd_getLocalDivergence_1 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_1 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local Divergence of a vector +! +! $$ +! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac +! {\partial N^{I}}{\partial \xi_{j} } +! $$ +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_2(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) + !! local Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + !! first index: space compo + !! second index: space node + !! third index: time node + END SUBROUTINE elemsd_getLocalDivergence_2 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_2 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local Divergence of a vector +! +! $$ +! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac +! {\partial N^{I}}{\partial \xi_{j} } +! $$ +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_3(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) + !! local Divergence of vector at integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! vector finite-element variable + END SUBROUTINE elemsd_getLocalDivergence_3 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_3 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local Divergence of a matrix + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_4(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! local Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getLocalDivergence_4 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_4 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local Divergence of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_5(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! local Divergence at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal values of matrix in (i,j,I,a) format + END SUBROUTINE elemsd_getLocalDivergence_5 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_5 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local Divergence of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_6(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! local Divergence at integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space/space-time nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getLocalDivergence_6 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_6 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local Divergence +! +!# Introduction +! +! - This routine returns local Divergence in [[FEVariable_]] +! the input is also a [[FEVariable_]]. +! - This routine can be considered as a master routine +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_7(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! local Divergence of scalar/vector/matrix at space integration points + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE elemsd_getLocalDivergence_7 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_7 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! getLocalDivergence@DivergenceMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Local Divergence + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalDivergence_8(obj, lg, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! Local Divergence of scalar/vector/matrix at space-time + !! integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space time nodal values of scalar/vector/matrix + END SUBROUTINE elemsd_getLocalDivergence_8 +END INTERFACE + +INTERFACE getLocalDivergence + MODULE PROCEDURE elemsd_getLocalDivergence_8 +END INTERFACE getLocalDivergence + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_LocalDivergence_1(obj, val) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_LocalDivergence_1 +END INTERFACE + +INTERFACE localDivergence + MODULE PROCEDURE elemsd_LocalDivergence_1 +END INTERFACE localDivergence + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_LocalDivergence_2(obj, val) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_LocalDivergence_2 +END INTERFACE + +INTERFACE localDivergence + MODULE PROCEDURE elemsd_LocalDivergence_2 +END INTERFACE localDivergence + +end module ElemshapeData_LocalDivergenceMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 new file mode 100644 index 000000000..c5104e760 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_LocalGradientMethods.F90 @@ -0,0 +1,367 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_LocalGradientMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: getLocalGradient +PUBLIC :: LocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a scalar +! +! $$ +! \frac{\partial \phi }{\partial \xi_{i} } =\phi_{I} \frac{\partial N^{I}} +! {\partial \xi_{i} } +! $$ +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_1(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! local gradients of scalar + REAL(DFP), INTENT(IN) :: val(:) + !! Space nodal values of scalar + END SUBROUTINE elemsd_getLocalGradient_1 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_1 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_2(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) + !! local gradient at integration points + !! first index: space component of V + !! second index: space component of x + !! third index: integration point + REAL(DFP), INTENT(IN) :: val(:, :) + !! space nodal values of vector in `xiJ` format + !! row index: space component + !! col index: node number + END SUBROUTINE elemsd_getLocalGradient_2 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_2 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a scalar +! +! $$ +! \frac{\partial \phi }{\partial \xi_{i} } =\phi^{a}_{I} T_{a}\frac +! {\partial N^{I}}{\partial \xi_{i} } +! $$ +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_3(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! local gradient of scalar (space-time nodal) + !! first index = space component of xi + !! second index= integration point in space + REAL(DFP), INTENT(IN) :: val(:, :) + !! space-time nodal values of scalar + !! first index = space node + !! second index = time node + END SUBROUTINE elemsd_getLocalGradient_3 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_3 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a vector +! +! $$ +! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac +! {\partial N^{I}}{\partial \xi_{j} } +! $$ +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_4(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) + !! local gradient at integration points + !! first index : space compo of V + !! second index: space compo of Xi + !! third index: integration point in space + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + !! first index: space compo + !! second index: space node + !! third index: time node + END SUBROUTINE elemsd_getLocalGradient_4 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_4 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a scalar +! +! $$ +! \frac{\partial \phi }{\partial \xi_{i} } =\phi_{I} \frac{\partial N^{I}} +! {\partial \xi_{i} } +! $$ +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_5(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) + !! local gradient of scalar + TYPE(FEVariable_), INTENT(IN) :: val + !! Scalar finite elememt variable + END SUBROUTINE elemsd_getLocalGradient_5 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_5 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a vector +! +! $$ +! \frac{\partial v_{i} }{\partial \xi_{j} } =v^{a}_{iI} T_{a}\frac +! {\partial N^{I}}{\partial \xi_{j} } +! $$ +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_6(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :) + !! local gradient of vector at integration points + !! first index : space compo of V + !! second index: space compo of Xi + !! third index: integration point in space + TYPE(FEVariable_), INTENT(IN) :: val + !! vector fe variable + END SUBROUTINE elemsd_getLocalGradient_6 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_6 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_7(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) + !! local gradient at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getLocalGradient_7 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_7 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_8(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) + !! local gradient at integration points + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal values of matrix in (i,j,I,a) format + END SUBROUTINE elemsd_getLocalGradient_8 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_8 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient of a vector + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_9(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :, :, :) + !! local gradient at integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space nodal values of matrix in (i,j,I) format + END SUBROUTINE elemsd_getLocalGradient_9 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_9 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the local gradient +! +!# Introduction +! +! - This routine returns local gradient in [[FEVariable_]] +! the input is also a [[FEVariable_]]. +! - This routine can be considered as a master routine +! +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_10(obj, lg, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! local gradient of scalar/vector/matrix at space integration points + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE elemsd_getLocalGradient_10 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_10 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! getLocalGradient@GradientMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine returns the Local gradient +! +!# Introduction +! +! - This routine returns Local gradient in [[FEVariable_]] +! the input is also a [[FEVariable_]]. +! - This routine can be considered as a master routine + +INTERFACE + MODULE PURE SUBROUTINE elemsd_getLocalGradient_11(obj, lg, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: lg + !! Local gradient of scalar/vector/matrix at space-time + !! integration points + TYPE(FEVariable_), INTENT(IN) :: val + !! space time nodal values of scalar/vector/matrix + END SUBROUTINE elemsd_getLocalGradient_11 +END INTERFACE + +INTERFACE getLocalGradient + MODULE PROCEDURE elemsd_getLocalGradient_11 +END INTERFACE getLocalGradient + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_LocalGradient_1(obj, val) RESULT(Ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_LocalGradient_1 +END INTERFACE + +INTERFACE localGradient + MODULE PROCEDURE elemsd_LocalGradient_1 +END INTERFACE localGradient + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION elemsd_LocalGradient_2(obj, val) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION elemsd_LocalGradient_2 +END INTERFACE + +INTERFACE LocalGradient + MODULE PROCEDURE elemsd_LocalGradient_2 +END INTERFACE LocalGradient + +end module ElemshapeData_LocalGradientMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 new file mode 100644 index 000000000..1df4c3ff0 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -0,0 +1,37 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_Method +USE ElemshapeData_ConstructorMethods +USE ElemshapeData_DGMethods +USE ElemshapeData_DivergenceMethods +USE ElemshapeData_GetMethods +USE ElemshapeData_GradientMethods +USE ElemshapeData_H1Methods +USE ElemshapeData_HCurlMethods +USE ElemshapeData_HDivMethods +USE ElemshapeData_HRGNParamMethods +USE ElemshapeData_HRQIParamMethods +USE ElemshapeData_HminHmaxMethods +USE ElemshapeData_IOMethods +USE ElemshapeData_InterpolMethods +USE ElemshapeData_LocalDivergenceMethods +USE ElemshapeData_LocalGradientMethods +USE ElemshapeData_ProjectionMethods +USE ElemshapeData_SetMethods +USE ElemshapeData_StabilizationParamMethods +USE ElemshapeData_UnitNormalMethods +END MODULE ElemshapeData_Method diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 new file mode 100644 index 000000000..4d78a673c --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -0,0 +1,214 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_ProjectionMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: getProjectionOfdNdXt +PUBLIC :: getProjectionOfdNTdXt + +!---------------------------------------------------------------------------- +! getProjectionOfdNdXt@ProjectionMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-21 +! update: 2021-11-21 +! summary: Computes $\frac{dN}{dx_k}c_k$ +! +!# Introduction +! +! This subroutine computes the projcetion cdNdXt on the vector `val` +! Here the vector `val` is constant in space and time +! +! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ + +INTERFACE + MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val) + 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 +END INTERFACE + +INTERFACE getProjectionOfdNdXt + MODULE PROCEDURE getProjectionOfdNdXt_1 +END INTERFACE getProjectionOfdNdXt + +!---------------------------------------------------------------------------- +! getProjectionOfdNdXt@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-21 +! update: 2021-11-21 +! summary: computes the projection of dNdXt on a vector +! +!# Introduction +! +! This subroutine computes the projcetion cdNdXt on the vector `val` +! Here the vector `val` is a finite element variable +! +! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ + +INTERFACE + MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val) + 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 + !! FEVariable vector + END SUBROUTINE getProjectionOfdNdXt_2 +END INTERFACE + +INTERFACE getProjectionOfdNdXt + MODULE PROCEDURE getProjectionOfdNdXt_2 +END INTERFACE getProjectionOfdNdXt + +!---------------------------------------------------------------------------- +! getProjectionOfdNdXt@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-21 +! update: 2021-11-21 +! summary: computes the projection of dNdXt on a vector +! +!# Introduction +! +! This subroutine computes the projcetion cdNdXt on the vector `val` +! Here the vector `val` is constant in space and time +! +! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ + +INTERFACE + MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val) + 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(:, :) + !! a vector, defined over quadrature points + END SUBROUTINE getProjectionOfdNdXt_3 +END INTERFACE + +INTERFACE getProjectionOfdNdXt + MODULE PROCEDURE getProjectionOfdNdXt_3 +END INTERFACE getProjectionOfdNdXt + +!---------------------------------------------------------------------------- +! getProjectionOfdNTdXt@getMethod +!---------------------------------------------------------------------------- + +!> 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 getProjectionOfdNTdXt_1(obj, cdNTdXt, val) + 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(:) + !! constant value of vector + END SUBROUTINE getProjectionOfdNTdXt_1 +END INTERFACE + +INTERFACE getProjectionOfdNTdXt + MODULE PROCEDURE getProjectionOfdNTdXt_1 +END INTERFACE getProjectionOfdNTdXt + +!---------------------------------------------------------------------------- +! getProjectionOfdNTdXt@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-07 +! update: 2021-12-07 +! summary: returns the projection of dNTdXt on a vector +! +!# Introduction +! +! This subroutine computes the projcetion cdNTdXt on the vector `val` +! Here the vector `val` is a vector variable +! +! - It can be constant in space and time +! - It can be vary in space but contant in time +! - It can vary in space and time domain +! +! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ +! +INTERFACE + MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val) + 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 + !! constant value of vector + END SUBROUTINE getProjectionOfdNTdXt_2 +END INTERFACE + +INTERFACE getProjectionOfdNTdXt + MODULE PROCEDURE getProjectionOfdNTdXt_2 +END INTERFACE getProjectionOfdNTdXt + +!---------------------------------------------------------------------------- +! getProjectionOfdNTdXt@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-07 +! update: 2021-12-07 +! summary: returns the projection of dNTdXt on a vector +! +!# Introduction +! +! +! This subroutine computes the projcetion cdNTdXt on the vector `val` +! Here the vector `val` is a vector variable +! +! - It can be constant in space and time +! - It can be vary in space but contant in time +! - It can vary in space and time domain +! +! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ +! +INTERFACE + MODULE PURE SUBROUTINE getProjectionOfdNTdXt_3(obj, cdNTdXt, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE getProjectionOfdNTdXt_3 +END INTERFACE + +INTERFACE getProjectionOfdNTdXt + MODULE PROCEDURE getProjectionOfdNTdXt_3 +END INTERFACE getProjectionOfdNTdXt + +end module ElemshapeData_ProjectionMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 new file mode 100644 index 000000000..74069ca7f --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 @@ -0,0 +1,482 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_SetMethods +USE BaSetype +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Set +PUBLIC :: SetBarycentricCoord +PUBLIC :: SetJacobian +PUBLIC :: SetJs +PUBLIC :: SetNormal +PUBLIC :: SetThickness +PUBLIC :: SetdNTdXt +PUBLIC :: SetdNTdt +PUBLIC :: SetdNdXt + +!---------------------------------------------------------------------------- +! SetNormal@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Sets the normal vector + +INTERFACE SetNormal + MODULE PURE SUBROUTINE elemsd_SetNormal(obj) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + END SUBROUTINE elemsd_SetNormal +END INTERFACE SetNormal + +!---------------------------------------------------------------------------- +! SetThickness@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March +! summary: This subroutine Set the thickness field +! +!# Introduction +! +! This subroutine Set the `thickness` field +! Here `val` denotes the nodal value of thickeness +! +! $$d = d_{I} N^{I}$$ + +INTERFACE SetThickness + MODULE PURE SUBROUTINE elemsd_SetThickness(obj, val, N) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:) + !! Nodal values of thickness + REAL(DFP), INTENT(IN) :: N(:, :) + !! Shape function values at quadrature points + END SUBROUTINE elemsd_SetThickness +END INTERFACE SetThickness + +!---------------------------------------------------------------------------- +! SetThickness@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set the thickness field +! +!# Introduction +! +! This subroutine Set the `thickness` field +! Here `val` denotes the space-time nodal value of thickeness +! +! $$d = d_{I}^{a} N^{I} T_{a}$$ + +INTERFACE SetThickness + MODULE PURE SUBROUTINE stsd_SetThickness(obj, val, N, T) + CLASS(STElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + !! Space-time nodal values of thickness + REAL(DFP), INTENT(IN) :: N(:, :) + !! Shape function at spatial quadrature + REAL(DFP), INTENT(IN) :: T(:) + !! Shape function at temporal quadrature + END SUBROUTINE stsd_SetThickness +END INTERFACE SetThickness + +!---------------------------------------------------------------------------- +! SetBarycentricCoord@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set the Barycentric coordinates +! +!# Introduction +! +! This subroutine Set the barycentric coordinates +! +! $$x_i = x_{iI} N^{I}$$ +! + +INTERFACE SetBarycentricCoord + MODULE PURE SUBROUTINE elemsd_SetBarycentricCoord(obj, val, N) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + !! Nodal coordinates in `xiJ` format + REAL(DFP), INTENT(IN) :: N(:, :) + !! When element is not an isoparametric we can supply N. + END SUBROUTINE elemsd_SetBarycentricCoord +END INTERFACE SetBarycentricCoord + +!---------------------------------------------------------------------------- +! SetBarycentricCoord@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set the Barycentric coordinates +! +!# Introduction +! +! This subroutine Set the barycentric coordinates by using +! space-time nodal coordinates +! +! $$x=x_{I}^{a} N^I T_a$$ + +INTERFACE SetBarycentricCoord + MODULE PURE SUBROUTINE stsd_SetBarycentricCoord(obj, val, N, T) + CLASS(STElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time Nodal coordinates in `xiJ` format + REAL(DFP), INTENT(IN) :: N(:, :), T(:) + !! N and T are required to handle non isoparametric elements + END SUBROUTINE stsd_SetBarycentricCoord +END INTERFACE SetBarycentricCoord + +!---------------------------------------------------------------------------- +! SetJs@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set the determinent of jacobian + +INTERFACE SetJs + MODULE PURE SUBROUTINE elemsd_SetJs(obj) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + END SUBROUTINE elemsd_SetJs +END INTERFACE SetJs + +!---------------------------------------------------------------------------- +! SetdNdXt@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set $\frac{d N}{d X_t}$ internally +! +!# Introduction +! +! This subroutine will internally Set `dNdXt`. +! It use the inverse of jacobian stored internally, so make sure jacobian is +! Set before calling this subroutine. + +INTERFACE SetdNdXt + MODULE PURE SUBROUTINE elemsd_SetdNdXt(obj) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + END SUBROUTINE elemsd_SetdNdXt +END INTERFACE SetdNdXt + +!---------------------------------------------------------------------------- +! SetJacobian@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set the jacobian +! +!# Introduction +! +! This subroutine Set the jacobian by using the nodal coordinates +! +! $$\frac{d x_i}{d \xi_j} = x_{iI}\frac{d N^I}{d \xi_j}$$ + +INTERFACE SetJacobian + MODULE PURE SUBROUTINE elemsd_SetJacobian(obj, val, dNdXi) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + !! nodal coordinates in `xiJ` format + REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) + END SUBROUTINE elemsd_SetJacobian +END INTERFACE SetJacobian + +!---------------------------------------------------------------------------- +! SetJacobian@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set the jacobian using space-time nodal coords +! +!# Introduction +! +! This subroutine Set the jacobian by using space-time nodal coords, `dNdXi` +! `T` are used to handle non-isoparameteric elements. +! +! $$\frac{d x_i}{d \xi_j} = x_{iI}^{a}T_a\frac{d N^I}{d \xi_j}$$ +! + +INTERFACE SetJacobian + MODULE PURE SUBROUTINE stsd_SetJacobian(obj, val, dNdXi, T) + CLASS(STElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! Space time nodal values of coordinates + REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) + !! Local derivative of shape function for geometry + REAL(DFP), INTENT(IN) :: T(:) + !! Shape function for time element + END SUBROUTINE stsd_SetJacobian +END INTERFACE SetJacobian + +!---------------------------------------------------------------------------- +! SetdNTdt@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set `dNTdt` by using the space-time nodal values +! +!# Introduction +! +! - This subroutine Set `dNTdt` by using space-time nodal values +! - It is important to note that `dNTdXt` should be allocated before calling +! - This subroutine uses following formula +! +! $$ +! \frac{\partial N^{I\ }T_{a}}{\partial t} =N^{I}\frac{\partial T_{a}} +! {\partial \theta } J^{-1}_{t}-\frac{\partial N^{I}T_{a}}{\partial x_{k}} +! \hat{v}_{k} +! $$ + +INTERFACE SetdNTdt + MODULE PURE SUBROUTINE stsd_SetdNTdt(obj, val) + CLASS(STElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! Space-time nodal values + END SUBROUTINE stsd_SetdNTdt +END INTERFACE SetdNTdt + +!---------------------------------------------------------------------------- +! SetdNTdXt@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set `dNTdXt` by using internal data +! +!# Introduction +! +! * This subroutine Set `dNTdXt` by using internal data +! * This subroutine uses inverse of Jacobian, therefore, before calling +! * this subroutine make sure to Set jacobian +! +! $$\frac{\partial N^{I\ }T_{a}}{\partial x_{i\ }} +! =\frac{\partial N^{I}T_{a}}{\partial \xi_{j} } \frac{\partial \xi_{j} } +! {\partial x_{i}} $$ + +INTERFACE SetdNTdXt + MODULE PURE SUBROUTINE stsd_SetdNTdXt(obj) + CLASS(STElemshapeData_), INTENT(INOUT) :: obj + !! Space-time nodal values + END SUBROUTINE stsd_SetdNTdXt +END INTERFACE SetdNTdXt + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: Sets parameters defined on physical element +! +!# Introduction +! +!This subroutine sets parameters defined on physical element +! +!- `val` denotes nodal coordinates of element in `xiJ` format +!- This subroutine will call +! - `SetJacobian` +! - `SetJs` +! - `SetdNdXt` +! - `SetBarycentricCoord` +!- By using `N` and `dNdXi` we can handle non-isoparametric +! elements +! +!@note +! In case `obj` is instance of [[stelemshapedata_]] then `val` will denotes +! coordinates of spatial nodes at some time in [tn, tn+1] +!@endnote +! +! The number of cols in val should be same as the number of rows +! in N and size of first index of dNdXi. + +INTERFACE Set + MODULE PURE SUBROUTINE elemsd_Set1(obj, val, N, dNdXi) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + !! Spatial nodal coordinates + REAL(DFP), INTENT(IN) :: N(:, :) + !! Shape function for geometry + REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) + !! Local derivative of shape functions for geometry + END SUBROUTINE elemsd_Set1 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set parameters defined on physical element +! +!# Introduction +! +! This routine performs following tasks +! +!- Set Jacobian for cellobj +!- Set Js for cellobj +!- Set dNdXt for cellobj +!- Set SetBarycentricCoord for cellobj +! +! Then it get connectivity of facet element by using refelem stored +! inside facetobj. This conectivity is necessary for getting +! the coordinates of facet element. Then, it performs following tasks +! for facetobj +! +!- SetJacobian +!- SetJs +!- SetBarycentricCoord +!- SetNormal +! +! It is important to note that `dNdXt` in facetobj cannot be computed +! as facet elements are n-1 dimensional manifold in n dimensional space. +! Therefore, we extend (copy from) dNdXt from cellobj to facetobj. +! +! We also make normal, Js, Ws by in **cellObj** by copying from **facetObj** +! +!@note +! Both facetObj and cellObj should be defined at same quadrature +! points. These quadrature points corresponds points in facetObj. +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & + & celldNdXi, facetN, facetdNdXi) + CLASS(ElemshapeData_), INTENT(INOUT) :: facetobj + CLASS(ElemshapeData_), INTENT(INOUT) :: cellobj + REAL(DFP), INTENT(IN) :: cellval(:, :) + !! Spatial nodal coordinates of cell + REAL(DFP), INTENT(IN) :: cellN(:, :) + !! shape function for cell + REAL(DFP), INTENT(IN) :: facetN(:, :) + !! Shape function for geometry + REAL(DFP), INTENT(IN) :: celldNdXi(:, :, :) + REAL(DFP), INTENT(IN) :: facetdNdXi(:, :, :) + !! Local derivative of shape functions for geometry + END SUBROUTINE elemsd_Set2 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine Set parameters defined on physical element +! +!# Introduction +! +!TODO: Add documentation of elemsd_Set3 + +INTERFACE Set + MODULE PURE SUBROUTINE elemsd_Set3( & + & masterFacetobj, & + & masterCellobj, & + & masterCellval, & + & masterCellN, & + & masterCelldNdXi, & + & masterFacetN, & + & masterFacetdNdXi, & + & slaveFacetobj, & + & slaveCellobj, & + & slaveCellval, & + & slaveCellN, & + & slaveCelldNdXi, & + & slaveFacetN, & + & slaveFacetdNdXi) + CLASS(ElemshapeData_), INTENT(INOUT) :: masterFacetobj + CLASS(ElemshapeData_), INTENT(INOUT) :: masterCellobj + REAL(DFP), INTENT(IN) :: masterCellval(:, :) + !! Spatial nodal coordinates of master cell + REAL(DFP), INTENT(IN) :: masterCellN(:, :) + !! local shape function for geometry of master cell + REAL(DFP), INTENT(IN) :: masterFacetN(:, :) + !! Shape function for geometry of master facet element + REAL(DFP), INTENT(IN) :: masterCelldNdXi(:, :, :) + !! Local gradient of shape functions for geometry of master cell + REAL(DFP), INTENT(IN) :: masterFacetdNdXi(:, :, :) + !! Local gradient of shape functions for geometry of + !! facet element of master cell + CLASS(ElemshapeData_), INTENT(INOUT) :: slaveFacetobj + !! Shape function data for facet element of slave cell + CLASS(ElemshapeData_), INTENT(INOUT) :: slaveCellobj + !! Shape function data for cell element of slave cell + REAL(DFP), INTENT(IN) :: slaveCellval(:, :) + !! Spatial nodal coordinates of cell element of slave cell + REAL(DFP), INTENT(IN) :: slaveCellN(:, :) + !! Local shape function for geometry of cell element of slave + REAL(DFP), INTENT(IN) :: slaveFacetN(:, :) + !! Local shape function for geometry of facet element of slave + REAL(DFP), INTENT(IN) :: slaveCelldNdXi(:, :, :) + !! Local derivative of shape function for geometry of cell element + !! of slave + REAL(DFP), INTENT(IN) :: slaveFacetdNdXi(:, :, :) + !! Local derivative of shape function for geometry of facet element + !! of slave + END SUBROUTINE elemsd_Set3 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine sets the parameters defined on physical element +! +!# Introduction +! +! This subroutine Set parameters defined on physical element +! +! * `val` denotes coordinates of the space-time element in `xiJa` format +! * The facility of supplying `N`, `T`, and `dNdXi` allows us to handle +! non-isoparametric element +! * This subroutine will call +! - `SetJacobian` uses `dNdXi` +! - `SetJs` +! - `SetdNdXt` +! - `SetBarycentricCoord` uses `N` and `T` +! - `SetdNTdXt` +! - `SetdNTdt` +! +!@note +! In case of [[stelemshapedata_]] `val` denotes nodal coordinate at +! some intermediate space-time slab +!@endnote + +INTERFACE Set + MODULE PURE SUBROUTINE stelemsd_Set1(obj, val, N, T, dNdXi) + CLASS(STElemshapeData_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! Spatial nodal coordinates + REAL(DFP), INTENT(IN) :: N(:, :) + REAL(DFP), INTENT(IN) :: T(:) + REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) + END SUBROUTINE stelemsd_Set1 +END INTERFACE Set + +END MODULE ElemshapeData_SetMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 new file mode 100644 index 000000000..17d2c83ca --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods.F90 @@ -0,0 +1,481 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_StabilizationParamMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: GetSUPGParam +PUBLIC :: getSUGN3Param +PUBLIC :: getSUGN3Param_Takizawa2018 + +!---------------------------------------------------------------------------- +! getSUGN3Param@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_1(obj, tau, val, nu, h, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + TYPE(FEVariable_), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_1 +END INTERFACE + +INTERFACE getSUGN3Param + MODULE PROCEDURE elemsd_GetSUGN3Param_1 +END INTERFACE getSUGN3Param + +!---------------------------------------------------------------------------- +! getSUGN3Param@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 May 2022 +! update: 3 May 2022 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_2(obj, tau, val, nu, h, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + TYPE(FEVariable_), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_2 +END INTERFACE + +INTERFACE getSUGN3Param + MODULE PROCEDURE elemsd_GetSUGN3Param_2 +END INTERFACE getSUGN3Param + +!---------------------------------------------------------------------------- +! getSUGN3Param@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_3(obj, tau, val, nu, h, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + REAL(DFP), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_3 +END INTERFACE + +INTERFACE getSUGN3Param + MODULE PROCEDURE elemsd_GetSUGN3Param_3 +END INTERFACE getSUGN3Param + +!---------------------------------------------------------------------------- +! getSUGN3Param@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 May 2022 +! update: 3 May 2022 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_4(obj, tau, val, nu, h, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + REAL(DFP), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_4 +END INTERFACE + +INTERFACE getSUGN3Param + MODULE PROCEDURE elemsd_GetSUGN3Param_4 +END INTERFACE getSUGN3Param + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_1(obj, & + & tau, val, nu, h, hmax, hmin, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + TYPE(FEVariable_), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_1 +END INTERFACE + +INTERFACE getSUGN3Param_Takizawa2018 + MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_1 +END INTERFACE getSUGN3Param_Takizawa2018 + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 May 2022 +! update: 3 May 2022 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_2(obj, tau, val, & + & nu, h, hmax, hmin, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + TYPE(FEVariable_), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_2 +END INTERFACE + +INTERFACE getSUGN3Param_Takizawa2018 + MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_2 +END INTERFACE getSUGN3Param_Takizawa2018 + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_3(obj, tau, val, & + & nu, h, hmax, hmin, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + REAL(DFP), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_3 +END INTERFACE + +INTERFACE getSUGN3Param_Takizawa2018 + MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_3 +END INTERFACE getSUGN3Param_Takizawa2018 + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 May 2022 +! update: 3 May 2022 +! summary: Returns the SUGN3 param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_4(obj, tau, val, & + & nu, h, hmax, hmin, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! obj can be an instance of [[STElemshapeData_]] + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! tau-sugn3 is a scalar and defined on quadrature points + TYPE(FEVariable_), INTENT(IN) :: val + !! val can be a vector or a scalar + REAL(DFP), INTENT(IN) :: nu + !! kinematic viscosity or diffusivity + !! scalar and defined on quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: h + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmax + !! scalar variable, defined on space-time quadrature points + TYPE(FEVariable_), OPTIONAL, INTENT(INOUT) :: hmin + !! scalar variable, defined on space-time quadrature points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! currently, opt is not used, but it may be used in future + END SUBROUTINE elemsd_GetSUGN3Param_Takizawa2018_4 +END INTERFACE + +INTERFACE getSUGN3Param_Takizawa2018 + MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_4 +END INTERFACE getSUGN3Param_Takizawa2018 + +!---------------------------------------------------------------------------- +! GetSUPGParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUPG param +! +!# Introduction +! +!- `tau` stabilization parameter, instance of [[FEVariable_]], +!- defined on quadrature, changes in space +!- `c` convective velocity, instance of [[FEVariable_]], vector, defined on +!- nodes or quadrature points +!- `val` instance of [[FEVariable_]], can be vector or scalar, defined on +!- nodes or quadrature points +!- `nu` instance of [[FEVariable_]], scalar, defined on nodes or quadrature +!- `k` instance of [[FEVariable_]], scalar, optional, defined on nodes/ +!- quadrature points +!- `phi`, porosity, [[FEVariable_]], scalar, optional, defined on nodes/quads +!- + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUPGParam1(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! It can be an instance of ElemshapeData_ or STElemshapeData_ + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! Stabilization parameter, [[FEVariable_]], Defined on Quadrature points + TYPE(FEVariable_), INTENT(IN) :: c + !! Convective velocity => Vector variable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution, it can be scalar or vector variable + TYPE(FEVariable_), INTENT(IN) :: nu + !! diffusivity + !! In case of NSE it should be mu/rho + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k + !! permeability + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi + !! porosity + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time step size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default=1 + !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` + !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` + END SUBROUTINE elemsd_GetSUPGParam1 +END INTERFACE + +INTERFACE GetSUPGParam + MODULE PROCEDURE elemsd_GetSUPGParam1 +END INTERFACE GetSUPGParam + +!---------------------------------------------------------------------------- +! GetSUPGParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUPG param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUPGParam2(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! space-time shape data + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! Stabilization parameter + !! Quadrature type + !! SpaceTime + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + !! vector FEVariable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution + !! scalar or vector FEVariable + TYPE(FEVariable_), INTENT(IN) :: nu + !! kinematic diffusivity + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k + !! permeability + !! Scalar FEVariable + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi + !! porosity + !! Scalar FEVariable + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time step size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default=1 + !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` + !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` + END SUBROUTINE elemsd_GetSUPGParam2 +END INTERFACE + +INTERFACE GetSUPGParam + MODULE PROCEDURE elemsd_GetSUPGParam2 +END INTERFACE GetSUPGParam + +!---------------------------------------------------------------------------- +! GetSUPGParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUPG param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUPGParam3(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! It can be an instance of ElemshapeData_ or STElemshapeData_ + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! Stabilization parameter + !! Quadrature FEVariable + !! varType=Space + TYPE(FEVariable_), INTENT(IN) :: c + !! Convective velocity => Vector variable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution, it can be scalar or vector variable + REAL(DFP), INTENT(IN) :: nu + !! In case of NSE it should be mu/rho + !! diffusivity + REAL(DFP), OPTIONAL, INTENT(IN) :: k + !! permeability + REAL(DFP), OPTIONAL, INTENT(IN) :: phi + !! porosity + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time step size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default=1 + !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` + !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` + END SUBROUTINE elemsd_GetSUPGParam3 +END INTERFACE + +INTERFACE GetSUPGParam + MODULE PROCEDURE elemsd_GetSUPGParam3 +END INTERFACE GetSUPGParam + +!---------------------------------------------------------------------------- +! GetSUPGParam@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the SUPG param + +INTERFACE + MODULE PURE SUBROUTINE elemsd_GetSUPGParam4(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + !! space-time shape data + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! Stabilization parameter + !! Quadrature type + !! SpaceTime + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + !! vector FEVariable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution + !! scalar or vector FEVariable + REAL(DFP), INTENT(IN) :: nu + !! kinematic diffusivity + REAL(DFP), OPTIONAL, INTENT(IN) :: k + !! permeability + !! Scalar FEVariable + REAL(DFP), OPTIONAL, INTENT(IN) :: phi + !! porosity + !! Scalar FEVariable + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time step size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default=1 + !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` + !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` + END SUBROUTINE elemsd_GetSUPGParam4 +END INTERFACE + +INTERFACE GetSUPGParam + MODULE PROCEDURE elemsd_GetSUPGParam4 +END INTERFACE GetSUPGParam + +end module ElemshapeData_StabilizationParamMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 new file mode 100644 index 000000000..6ede5911e --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_UnitNormalMethods.F90 @@ -0,0 +1,129 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +module ElemshapeData_UnitNormalMethods +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetUnitNormal + +!---------------------------------------------------------------------------- +! GetUnitNormal@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine can be used in SUPG formulation +! +!# Introduction +! +! This routine can be used in the SUPG formulation: +! +! $$ +! \frac{\nabla \vert \phi \vert}{\Vert \nabla \vert \phi \vert \Vert} +! $$ + +INTERFACE + MODULE PURE SUBROUTINE GetUnitNormal_1(obj, R, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: R(:, :) + !! unit vector defined over quadrature points, in xiJ format + REAL(DFP), INTENT(IN) :: val(:) + !! spatial nodal values of scalar + END SUBROUTINE GetUnitNormal_1 +END INTERFACE + +INTERFACE GetUnitNormal + MODULE PROCEDURE GetUnitNormal_1 +END INTERFACE GetUnitNormal + +!---------------------------------------------------------------------------- +! GetUnitNormal@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine can be used in SUPG formulation +! +!# Introduction +! +! This routine can be used in the SUPG formulation, here +! val is spatial nodal values of a vector. +! +! $$ +! {\bf r}=\frac{\nabla\Vert{\bf v}\Vert}{\left|\nabla\Vert{\bf v}\Vert\right|} +! $$ + +INTERFACE + MODULE PURE SUBROUTINE GetUnitNormal_2(obj, R, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: R(:, :) + !! unit vector defined over quadrature points, in xiJ format + REAL(DFP), INTENT(IN) :: val(:, :) + !! spatial nodal values of velocity (vector field) + END SUBROUTINE GetUnitNormal_2 +END INTERFACE + +INTERFACE GetUnitNormal + MODULE PROCEDURE GetUnitNormal_2 +END INTERFACE GetUnitNormal + +!---------------------------------------------------------------------------- +! GetUnitNormal@getMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-26 +! update: 2021-11-26 +! summary: This subroutine can be used in SUPG formulation +! +!# Introduction +! +! - This routine can be used in the SUPG formulation. +! - `val` is the [[FEVariable_]], it can be vector or scalar +! +! $$ +! \frac{\nabla \vert \phi \vert}{\Vert \nabla \vert \phi \vert \Vert} +! $$ +! +! $$ +! {\bf r}=\frac{\nabla\Vert{\bf v}\Vert}{\left|\nabla\Vert{\bf v}\Vert\right|} +! $$ +! +! TODO: Make implementation simple: +! extract scalar or vector values from fevariable val, +! and call above routines + +INTERFACE + MODULE PURE SUBROUTINE GetUnitNormal_3(obj, R, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: R(:, :) + !! unit vector defined over quadrature points, in xiJ format + TYPE(FEVariable_), INTENT(IN) :: val + !! it can be scalar or vector fe variable + END SUBROUTINE GetUnitNormal_3 +END INTERFACE + +INTERFACE GetUnitNormal + MODULE PROCEDURE GetUnitNormal_3 +END INTERFACE GetUnitNormal + +end module ElemshapeData_UnitNormalMethods diff --git a/src/modules/ErrorHandling/CMakeLists.txt b/src/modules/ErrorHandling/CMakeLists.txt new file mode 100644 index 000000000..5581df053 --- /dev/null +++ b/src/modules/ErrorHandling/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/ErrorHandling.F90 +) \ No newline at end of file diff --git a/src/modules/ErrorHandling/src/ErrorHandling.F90 b/src/modules/ErrorHandling/src/ErrorHandling.F90 new file mode 100644 index 000000000..206db18e2 --- /dev/null +++ b/src/modules/ErrorHandling/src/ErrorHandling.F90 @@ -0,0 +1,195 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> [[ErrorHandling]] module contains error handling routines. + +MODULE ErrorHandling +USE GlobalData, ONLY: I4B, OPT_ALLOC, OPT_DEALLOC, OPT_OPEN, & + & OPT_READ, OPT_WRITE, OPT_CLOSE +USE Display_Method, ONLY: Display, DashLine +IMPLICIT NONE +PRIVATE + +PUBLIC :: Errormsg, Warningmsg, fileError, AllocationErr + +CONTAINS + +!---------------------------------------------------------------------------- +! Errormsg +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints the error message +! +! #Usage +! ```fortran +! call Errormsg( & +! & msg="Some Error Message", & +! & file= "test_ErrorHandling", & +! & routine = "test1", & +! & line = 29 & +! ) +! ``` + +SUBROUTINE Errormsg(msg, file, routine, line, unitno) + CHARACTER(*), INTENT(IN) :: msg + !! Message + CHARACTER(*), INTENT(IN) :: file + !! Name of the file + CHARACTER(*), INTENT(IN) :: routine + !! Name of the routine where error has occured + INTEGER(I4B), INTENT(IN) :: line + !! line number where error has occured + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + !! Unit number + !! + CALL Display(file, "ERROR :: In file :: ", unitno=unitno) + CALL Display(LINE, "at line number :: ", unitno=unitno) + CALL Display(" ", "in routine named :: "//TRIM(routine)// & + & " with following message :: ", unitno=unitno) + CALL Dashline(unitno=unitno) + CALL Display(msg, unitno=unitno) + CALL Dashline(unitno=unitno) +END SUBROUTINE Errormsg + +!---------------------------------------------------------------------------- +! Warningmsg +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints the warning message + +SUBROUTINE Warningmsg(msg, file, routine, line, unitno) + !! This subroutine prints the warning message + CHARACTER(*), INTENT(IN) :: msg + !! Message + CHARACTER(*), INTENT(IN) :: file + !! Name of the file + CHARACTER(*), INTENT(IN) :: routine + !! Name of the routine where error has occured + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + !! file id to write the message to + INTEGER(I4B), INTENT(IN) :: line + !! line number + !! + CALL Display(file, "WARNING :: In file ::", unitno=unitno) + CALL Display(LINE, "line number ::", unitno=unitno) + CALL Display(" ", "in routine named :: "//TRIM(routine)// & + & " with following message :: ", unitno=unitno) + CALL Dashline(unitno=unitno) + CALL Display(msg, unitno=unitno) + CALL Dashline(unitno=unitno) +END SUBROUTINE Warningmsg + +!---------------------------------------------------------------------------- +! fileError +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints error while handling a file + +SUBROUTINE fileError(istat, filename, flg, unitno, file, routine, line) + ! Dummy argumnet + INTEGER(I4B), INTENT(IN) :: istat + !! Result of iostat=istat for open,read,write,close + CHARACTER(*), INTENT(IN) :: filename + !! Name of the file (IO related) + INTEGER(I4B), INTENT(IN) :: flg + !! IO_OPEN=Open, IO_READ=Read, IO_WRITE=Write, IO_CLOSE=Close + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + !! file id to write the error to + CHARACTER(*), INTENT(IN) :: file, routine + !! Name of the source code file and routine name + INTEGER(I4B), INTENT(IN) :: line + !! line number + !! + ! Define internal variables + CHARACTER(:), ALLOCATABLE :: Amsg + !! + ! Return if no error + IF (istat == 0) THEN + RETURN + END IF + !! + Amsg = "" + !! + SELECT CASE (flg) + CASE (OPT_OPEN) + Amsg = 'Opening file: '//TRIM(filename) + CASE (OPT_READ) + Amsg = 'Reading from: '//TRIM(filename) + CASE (OPT_WRITE) + Amsg = 'Writing to file: '//TRIM(filename) + CASE (OPT_CLOSE) + Amsg = 'Closing file: '//TRIM(filename) + CASE DEFAULT + Amsg = 'Error:Invalid error flag [1-4]' + END SELECT + !! + CALL Errormsg(msg=Amsg, unitno=unitno, file=file, line=line, & + & routine=routine) + !! +END SUBROUTINE fileError + +!---------------------------------------------------------------------------- +! AllocationErr +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This subroutine prints the error which occurs while allocating/ +! deallocating an array +! +! Use this after an allocate/deallocate statement +! allocate(x(nz,ny,nx), stat=istat); call AllocationErr(istat,'x',1) +! deallocate(x, stat=istat); call AllocationErr(istat,'x',2) + +SUBROUTINE AllocationErr(istat, amsg, alloc, unitno, file, routine, line) + INTEGER(I4B), INTENT(IN) :: istat + !! results of stat=istat in (de)allocate + CHARACTER(*), INTENT(IN) :: amsg + !! Message associated with the (de)allocate + INTEGER(I4B), INTENT(IN) :: alloc + !! For OPT_ALLOC = allocate, for OPT_DEALLOC = deallocate + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + !! Optional file id to write the message to + CHARACTER(*), INTENT(IN) :: file, routine + !! filename and routine name + INTEGER(I4B), INTENT(IN) :: line + !! + ! Define internal variables + CHARACTER(:), ALLOCATABLE :: tmp + !! + IF (istat == 0) RETURN + !! + tmp = "" + SELECT CASE (alloc) + CASE (OPT_ALLOC) + tmp = 'Allocating Memory: '//TRIM(amsg) + CASE (OPT_DEALLOC) + tmp = 'Deallocating Memory: '//TRIM(amsg) + END SELECT + !! + CALL Errormsg(msg=tmp, unitno=unitno, file=file, line=line, & + & routine=routine) + !! +END SUBROUTINE AllocationErr + +END MODULE ErrorHandling diff --git a/src/modules/FACE/CMakeLists.txt b/src/modules/FACE/CMakeLists.txt new file mode 100644 index 000000000..0a603073f --- /dev/null +++ b/src/modules/FACE/CMakeLists.txt @@ -0,0 +1,68 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/face.F90 +) + +INCLUDE(CheckFortranSourceRuns) + +check_fortran_source_runs( + "program ascii_support; + integer, parameter :: ascii = selected_char_kind('ascii'); + if(ascii < 0) stop 1; + end program ascii_support" + ASCII_SUPPORTED + SRC_EXT f90 +) + +IF(ASCII_SUPPORTED) + SET(ascii_supported "-DASCII_SUPPORTED") +ENDIF() + +check_fortran_source_runs( + "program ascii_neq_default; + integer, parameter :: ascii = selected_char_kind('ascii'); + integer, parameter :: default = selected_char_kind('default'); + if(ascii == default) stop 1; + end program ascii_neq_default" + ASCII_NEQ_DEFAULT + SRC_EXT f90 +) + +IF(ASCII_NEQ_DEFAULT) + SET(ascii_neq_default "-DASCII_NEQ_DEFAULT") +ENDIF() + +check_fortran_source_runs( + "program ucs4_support; + integer, parameter :: ucs4 = selected_char_kind('iso_10646'); + if(ucs4 < 0) stop 1; + end program ucs4_support" + UCS4_SUPPORTED + SRC_EXT f90 +) + +IF(UCS4_SUPPORTED) + SET(ucs4_supported "-DUCS4_SUPPORTED") +ENDIF() + +LIST( APPEND TARGET_COMPILE_DEF ${ascii_supported} ) +LIST( APPEND TARGET_COMPILE_DEF ${ascii_neq_default} ) +LIST( APPEND TARGET_COMPILE_DEF ${ucs4_supported} ) diff --git a/src/modules/FACE/src/face.F90 b/src/modules/FACE/src/face.F90 new file mode 100644 index 000000000..385355136 --- /dev/null +++ b/src/modules/FACE/src/face.F90 @@ -0,0 +1,287 @@ +!< FACE, Fortran Ansi Colors Environment. +module face +!< FACE, Fortran Ansi Colors Environment. +use, intrinsic :: iso_fortran_env, only: int32 + +implicit none +private +public :: colorize +public :: colors_samples +public :: styles_samples +public :: ASCII +public :: UCS4 + +interface colorize +#if defined ASCII_SUPPORTED && defined ASCII_NEQ_DEFAULT + module procedure colorize_ascii + module procedure colorize_default +#else + module procedure colorize_default +#endif +#ifdef UCS4_SUPPORTED + module procedure colorize_ucs4 +#endif +endinterface + +! kind parameters +#ifdef ASCII_SUPPORTED +integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind. +#else +integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind. +#endif +#ifdef UCS4_SUPPORTED +integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind. +#else +integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind. +#endif +! parameters +character(26), parameter :: UPPER_ALPHABET='ABCDEFGHIJKLMNOPQRSTUVWXYZ' !< Upper case alphabet. +character(26), parameter :: LOWER_ALPHABET='abcdefghijklmnopqrstuvwxyz' !< Lower case alphabet. +character(1), parameter :: NL=new_line('a') !< New line character. +character(1), parameter :: ESCAPE=achar(27) !< "\" character. +! codes +character(2), parameter :: CODE_START=ESCAPE//'[' !< Start ansi code, "\[". +character(1), parameter :: CODE_END='m' !< End ansi code, "m". +character(4), parameter :: CODE_CLEAR=CODE_START//'0'//CODE_END !< Clear all styles, "\[0m". +! styles codes +character(17), parameter :: STYLES(1:2,1:16)=reshape([& + 'BOLD_ON ','1 ', & ! Bold on. + 'ITALICS_ON ','3 ', & ! Italics on. + 'UNDERLINE_ON ','4 ', & ! Underline on. + 'INVERSE_ON ','7 ', & ! Inverse on: reverse foreground and background colors. + 'STRIKETHROUGH_ON ','9 ', & ! Strikethrough on. + 'BOLD_OFF ','22 ', & ! Bold off. + 'ITALICS_OFF ','23 ', & ! Italics off. + 'UNDERLINE_OFF ','24 ', & ! Underline off. + 'INVERSE_OFF ','27 ', & ! Inverse off: reverse foreground and background colors. + 'STRIKETHROUGH_OFF','29 ', & ! Strikethrough off. + 'FRAMED_ON ','51 ', & ! Framed on. + 'ENCIRCLED_ON ','52 ', & ! Encircled on. + 'OVERLINED_ON ','53 ', & ! Overlined on. + 'FRAMED_OFF ','54 ', & ! Framed off. + 'ENCIRCLED_OFF ','54 ', & ! Encircled off. + 'OVERLINED_OFF ','55 ' & ! Overlined off. + ], [2,16]) !< Styles. +! colors codes +character(15), parameter :: COLORS_FG(1:2,1:17)=reshape([& + 'BLACK ','30 ', & ! Black. + 'RED ','31 ', & ! Red. + 'GREEN ','32 ', & ! Green. + 'YELLOW ','33 ', & ! Yellow. + 'BLUE ','34 ', & ! Blue. + 'MAGENTA ','35 ', & ! Magenta. + 'CYAN ','36 ', & ! Cyan. + 'WHITE ','37 ', & ! White. + 'DEFAULT ','39 ', & ! Default (white). + 'BLACK_INTENSE ','90 ', & ! Black intense. + 'RED_INTENSE ','91 ', & ! Red intense. + 'GREEN_INTENSE ','92 ', & ! Green intense. + 'YELLOW_INTENSE ','93 ', & ! Yellow intense. + 'BLUE_INTENSE ','94 ', & ! Blue intense. + 'MAGENTA_INTENSE','95 ', & ! Magenta intense. + 'CYAN_INTENSE ','96 ', & ! Cyan intense. + 'WHITE_INTENSE ','97 ' & ! White intense. + ], [2,17]) !< Foreground colors. +character(15), parameter :: COLORS_BG(1:2,1:17)=reshape([& + 'BLACK ','40 ', & ! Black. + 'RED ','41 ', & ! Red. + 'GREEN ','42 ', & ! Green. + 'YELLOW ','43 ', & ! Yellow. + 'BLUE ','44 ', & ! Blue. + 'MAGENTA ','45 ', & ! Magenta. + 'CYAN ','46 ', & ! Cyan. + 'WHITE ','47 ', & ! White. + 'DEFAULT ','49 ', & ! Default (black). + 'BLACK_INTENSE ','100 ', & ! Black intense. + 'RED_INTENSE ','101 ', & ! Red intense. + 'GREEN_INTENSE ','102 ', & ! Green intense. + 'YELLOW_INTENSE ','103 ', & ! Yellow intense. + 'BLUE_INTENSE ','104 ', & ! Blue intense. + 'MAGENTA_INTENSE','105 ', & ! Magenta intense. + 'CYAN_INTENSE ','106 ', & ! Cyan intense. + 'WHITE_INTENSE ','107 ' & ! White intense. + ], [2,17]) !< Background colors. +contains + ! public procedures + subroutine colors_samples() + !< Print to standard output all colors samples. + integer(int32) :: c !< Counter. + + print '(A)', colorize('Foreground colors samples', color_fg='red_intense') + do c=1, size(COLORS_FG, dim=2) + print '(A)', ' colorize("'//COLORS_FG(1, c)//'", color_fg="'//COLORS_FG(1, c)//'") => '//& + colorize(COLORS_FG(1, c), color_fg=COLORS_FG(1, c))//& + ' code: '//colorize(trim(COLORS_FG(2, c)), color_fg=COLORS_FG(1, c), style='inverse_on') + enddo + print '(A)', colorize('Background colors samples', color_fg='red_intense') + do c=1, size(COLORS_BG, dim=2) + print '(A)', ' colorize("'//COLORS_BG(1, c)//'", color_bg="'//COLORS_BG(1, c)//'") => '//& + colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))//& + ' code: '//colorize(trim(COLORS_BG(2, c)), color_bg=COLORS_BG(1, c), style='inverse_on') + enddo + endsubroutine colors_samples + + subroutine styles_samples() + !< Print to standard output all styles samples. + integer(int32) :: s !< Counter. + + print '(A)', colorize('Styles samples', color_fg='red_intense') + do s=1, size(STYLES, dim=2) + print '(A)', ' colorize("'//STYLES(1, s)//'", style="'//STYLES(1, s)//'") => '//& + colorize(STYLES(1, s), style=STYLES(1, s))//& + ' code: '//colorize(trim(STYLES(2, s)), color_fg='magenta', style='inverse_on') + enddo + endsubroutine styles_samples + + ! private procedures + pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized) + !< Colorize and stylize strings, ASCII kind. + character(len=*, kind=ASCII), intent(in) :: string !< Input string. + character(len=*), intent(in), optional :: color_fg !< Foreground color definition. + character(len=*), intent(in), optional :: color_bg !< Background color definition. + character(len=*), intent(in), optional :: style !< Style definition. + character(len=:, kind=ASCII), allocatable :: colorized !< Colorized string. + character(len=:, kind=ASCII), allocatable :: buffer !< Temporary buffer. + integer(int32) :: i !< Counter. + + colorized = string + if (present(color_fg)) then + i = color_index(upper(color_fg)) + if (i>0) then + buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + endif + endif + if (present(color_bg)) then + i = color_index(upper(color_bg)) + if (i>0) then + buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + endif + endif + if (present(style)) then + i = style_index(upper(style)) + if (i>0) then + buffer = CODE_START//trim(STYLES(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + endif + endif + endfunction colorize_ascii + + pure function colorize_default(string, color_fg, color_bg, style) result(colorized) + !< Colorize and stylize strings, DEFAULT kind. + character(len=*), intent(in) :: string !< Input string. + character(len=*), intent(in), optional :: color_fg !< Foreground color definition. + character(len=*), intent(in), optional :: color_bg !< Background color definition. + character(len=*), intent(in), optional :: style !< Style definition. + character(len=:), allocatable :: colorized !< Colorized string. + integer(int32) :: i !< Counter. + + colorized = string + if (present(color_fg)) then + i = color_index(upper(color_fg)) + if (i>0) colorized = CODE_START//trim(COLORS_FG(2, i))//CODE_END//colorized//CODE_CLEAR + endif + if (present(color_bg)) then + i = color_index(upper(color_bg)) + if (i>0) colorized = CODE_START//trim(COLORS_BG(2, i))//CODE_END//colorized//CODE_CLEAR + endif + if (present(style)) then + i = style_index(upper(style)) + if (i>0) colorized = CODE_START//trim(STYLES(2, i))//CODE_END//colorized//CODE_CLEAR + endif + endfunction colorize_default + + pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized) + !< Colorize and stylize strings, UCS4 kind. + character(len=*, kind=UCS4), intent(in) :: string !< Input string. + character(len=*), intent(in), optional :: color_fg !< Foreground color definition. + character(len=*), intent(in), optional :: color_bg !< Background color definition. + character(len=*), intent(in), optional :: style !< Style definition. + character(len=:, kind=UCS4), allocatable :: colorized !< Colorized string. + character(len=:, kind=UCS4), allocatable :: buffer !< Temporary buffer. + integer(int32) :: i !< Counter. + + colorized = string + if (present(color_fg)) then + i = color_index(upper(color_fg)) + if (i>0) then + buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + endif + endif + if (present(color_bg)) then + i = color_index(upper(color_bg)) + if (i>0) then + buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + endif + endif + if (present(style)) then + i = style_index(upper(style)) + if (i>0) then + buffer = CODE_START//trim(STYLES(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + endif + endif + endfunction colorize_ucs4 + + elemental function color_index(color) + !< Return the array-index corresponding to the queried color. + !< + !< @note Because Foreground and backround colors lists share the same name, no matter what array is used to find the color index. + !< Thus, the foreground array is used. + character(len=*), intent(in) :: color !< Color definition. + integer(int32) :: color_index !< Index into the colors arrays. + integer(int32) :: c !< Counter. + + color_index = 0 + do c=1, size(COLORS_FG, dim=2) + if (trim(COLORS_FG(1, c))==trim(adjustl(color))) then + color_index = c + exit + endif + enddo + endfunction color_index + + elemental function style_index(style) + !< Return the array-index corresponding to the queried style. + character(len=*), intent(in) :: style !< Style definition. + integer(int32) :: style_index !< Index into the styles array. + integer(int32) :: s !< Counter. + + style_index = 0 + do s=1, size(STYLES, dim=2) + if (trim(STYLES(1, s))==trim(adjustl(style))) then + style_index = s + exit + endif + enddo + endfunction style_index + + elemental function upper(string) + !< Return a string with all uppercase characters. + character(len=*), intent(in) :: string !< Input string. + character(len=len(string)) :: upper !< Upper case string. + integer :: n1 !< Characters counter. + integer :: n2 !< Characters counter. + + upper = string + do n1=1, len(string) + n2 = index(LOWER_ALPHABET, string(n1:n1)) + if (n2>0) upper(n1:n1) = UPPER_ALPHABET(n2:n2) + enddo + endfunction upper +endmodule face diff --git a/src/modules/FEMatrix/CMakeLists.txt b/src/modules/FEMatrix/CMakeLists.txt new file mode 100644 index 000000000..a7b089be6 --- /dev/null +++ b/src/modules/FEMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/FEMatrix_Method.F90 +) diff --git a/src/modules/FEMatrix/src/FEMatrix_Method.F90 b/src/modules/FEMatrix/src/FEMatrix_Method.F90 new file mode 100644 index 000000000..07d9985ac --- /dev/null +++ b/src/modules/FEMatrix/src/FEMatrix_Method.F90 @@ -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 +! + +MODULE FEMatrix_Method +USE MassMatrix_Method +USE STMassMatrix_Method +USE DiffusionMatrix_Method +USE STDiffusionMatrix_Method +USE ConvectiveMatrix_Method +USE STConvectiveMatrix_Method +USE StiffnessMatrix_Method +USE ElasticNitscheMatrix_Method +USE FacetMatrix_Method +END MODULE FEMatrix_Method diff --git a/src/modules/FEVariable/CMakeLists.txt b/src/modules/FEVariable/CMakeLists.txt new file mode 100644 index 000000000..2bf970d1a --- /dev/null +++ b/src/modules/FEVariable/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/FEVariable_Method.F90 +) \ No newline at end of file diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 new file mode 100644 index 000000000..965542d7e --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -0,0 +1,1626 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_Method +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_ + +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 :: 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(=) + +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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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: 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: 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: 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: 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: 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: 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: 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: 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 + +!---------------------------------------------------------------------------- +! 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 + +END MODULE FEVariable_Method diff --git a/src/modules/FEVector/CMakeLists.txt b/src/modules/FEVector/CMakeLists.txt new file mode 100644 index 000000000..96973b09c --- /dev/null +++ b/src/modules/FEVector/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}/FEVector_Method.F90 +) diff --git a/src/modules/FEVector/src/FEVector_Method.F90 b/src/modules/FEVector/src/FEVector_Method.F90 new file mode 100644 index 000000000..11c77e074 --- /dev/null +++ b/src/modules/FEVector/src/FEVector_Method.F90 @@ -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 +! + +MODULE FEVector_Method + USE ForceVector_Method + USE STForceVector_Method +END MODULE FEVector_Method \ No newline at end of file diff --git a/src/modules/FFTW/CMakeLists.txt b/src/modules/FFTW/CMakeLists.txt new file mode 100644 index 000000000..225b83f30 --- /dev/null +++ b/src/modules/FFTW/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}/FFTW3.F90 +) diff --git a/src/modules/FFTW/src/FFTW3.F90 b/src/modules/FFTW/src/FFTW3.F90 new file mode 100644 index 000000000..ad2c82000 --- /dev/null +++ b/src/modules/FFTW/src/FFTW3.F90 @@ -0,0 +1,2231 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +#ifdef USE_FFTW +MODULE FFTW3 +USE, INTRINSIC :: ISO_C_BINDING +INTEGER, PARAMETER :: C_FFTW_R2R_KIND = C_INT32_T +INTEGER(C_INT), PARAMETER :: FFTW_R2HC = 0 +INTEGER(C_INT), PARAMETER :: FFTW_HC2R = 1 +INTEGER(C_INT), PARAMETER :: FFTW_DHT = 2 +INTEGER(C_INT), PARAMETER :: FFTW_REDFT00 = 3 +INTEGER(C_INT), PARAMETER :: FFTW_REDFT01 = 4 +INTEGER(C_INT), PARAMETER :: FFTW_REDFT10 = 5 +INTEGER(C_INT), PARAMETER :: FFTW_REDFT11 = 6 +INTEGER(C_INT), PARAMETER :: FFTW_RODFT00 = 7 +INTEGER(C_INT), PARAMETER :: FFTW_RODFT01 = 8 +INTEGER(C_INT), PARAMETER :: FFTW_RODFT10 = 9 +INTEGER(C_INT), PARAMETER :: FFTW_RODFT11 = 10 +INTEGER(C_INT), PARAMETER :: FFTW_FORWARD = -1 +INTEGER(C_INT), PARAMETER :: FFTW_BACKWARD = +1 +INTEGER(C_INT), PARAMETER :: FFTW_MEASURE = 0 +INTEGER(C_INT), PARAMETER :: FFTW_DESTROY_INPUT = 1 +INTEGER(C_INT), PARAMETER :: FFTW_UNALIGNED = 2 +INTEGER(C_INT), PARAMETER :: FFTW_CONSERVE_MEMORY = 4 +INTEGER(C_INT), PARAMETER :: FFTW_EXHAUSTIVE = 8 +INTEGER(C_INT), PARAMETER :: FFTW_PRESERVE_INPUT = 16 +INTEGER(C_INT), PARAMETER :: FFTW_PATIENT = 32 +INTEGER(C_INT), PARAMETER :: FFTW_ESTIMATE = 64 +INTEGER(C_INT), PARAMETER :: FFTW_WISDOM_ONLY = 2097152 +INTEGER(C_INT), PARAMETER :: FFTW_ESTIMATE_PATIENT = 128 +INTEGER(C_INT), PARAMETER :: FFTW_BELIEVE_PCOST = 256 +INTEGER(C_INT), PARAMETER :: FFTW_NO_DFT_R2HC = 512 +INTEGER(C_INT), PARAMETER :: FFTW_NO_NONTHREADED = 1024 +INTEGER(C_INT), PARAMETER :: FFTW_NO_BUFFERING = 2048 +INTEGER(C_INT), PARAMETER :: FFTW_NO_INDIRECT_OP = 4096 +INTEGER(C_INT), PARAMETER :: FFTW_ALLOW_LARGE_GENERIC = 8192 +INTEGER(C_INT), PARAMETER :: FFTW_NO_RANK_SPLITS = 16384 +INTEGER(C_INT), PARAMETER :: FFTW_NO_VRANK_SPLITS = 32768 +INTEGER(C_INT), PARAMETER :: FFTW_NO_VRECURSE = 65536 +INTEGER(C_INT), PARAMETER :: FFTW_NO_SIMD = 131072 +INTEGER(C_INT), PARAMETER :: FFTW_NO_SLOW = 262144 +INTEGER(C_INT), PARAMETER :: FFTW_NO_FIXED_RADIX_LARGE_N = 524288 +INTEGER(C_INT), PARAMETER :: FFTW_ALLOW_PRUNING = 1048576 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: fftw_iodim + INTEGER(C_INT) :: n, is, os +END TYPE fftw_iodim + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: fftw_iodim64 + INTEGER(C_INTPTR_T) n, is, os +END TYPE fftw_iodim64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: fftwf_iodim + INTEGER(C_INT) n, is, os +END TYPE fftwf_iodim + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: fftwf_iodim64 + INTEGER(C_INTPTR_T) n, is, os +END TYPE fftwf_iodim64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft(rank,n,in,out,sign,flags) & + & BIND(C, name='fftw_plan_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_1d(n,in,out,sign,flags) & + & BIND(C, name='fftw_plan_dft_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_2d(n0,n1,in,out,sign,flags) & + & BIND(C, name='fftw_plan_dft_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_3d(n0,n1,n2,in,out,sign,flags) & + & BIND(C, name='fftw_plan_dft_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_many_dft(rank,n,howmany,in,inembed, & + & istride,idist,out,onembed,ostride,odist,sign,flags) & + & BIND(C, name='fftw_plan_many_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_many_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru_dft(rank,dims,howmany_rank,& + & howmany_dims,in,out,sign,flags) & + & BIND(C, name='fftw_plan_guru_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru_split_dft(rank,dims,howmany_rank,& + & howmany_dims,ri,ii,ro,io,flags) & + & BIND(C, name='fftw_plan_guru_split_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru_split_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru64_dft(rank,dims,howmany_rank,& + & howmany_dims,in,out,sign,flags) & + & BIND(C, name='fftw_plan_guru64_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru64_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru64_split_dft(rank,dims,howmany_rank,& + & howmany_dims,ri,ii,ro,io,flags) & + & BIND(C, name='fftw_plan_guru64_split_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru64_split_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_execute_dft(p,in,out) BIND(C, name='fftw_execute_dft') + IMPORT + TYPE(C_PTR), VALUE :: p + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftw_execute_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_execute_split_dft(p,ri,ii,ro,io) & + & BIND(C, name='fftw_execute_split_dft') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ri + REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ii + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io + END SUBROUTINE fftw_execute_split_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_many_dft_r2c(rank,n,howmany,in,inembed,& + & istride,idist,out,onembed,ostride,odist,flags) & + & BIND(C, name='fftw_plan_many_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_many_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c(rank,n,in,out,flags) & + & BIND(C, name='fftw_plan_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c_1d(n,in,out,flags) & + & BIND(C, name='fftw_plan_dft_r2c_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_r2c_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c_2d(n0,n1,in,out,flags) & + & BIND(C, name='fftw_plan_dft_r2c_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_r2c_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_r2c_3d(n0,n1,n2,in,out,flags) & + & BIND(C, name='fftw_plan_dft_r2c_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_r2c_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_many_dft_c2r(rank,n,howmany,in,inembed,& + & istride,idist,out,onembed,ostride,odist,flags) & + & BIND(C, name='fftw_plan_many_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_many_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r(rank,n,in,out,flags) & + & BIND(C, name='fftw_plan_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r_1d(n,in,out,flags) & + & BIND(C, name='fftw_plan_dft_c2r_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_c2r_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r_2d(n0,n1,in,out,flags) & + & BIND(C, name='fftw_plan_dft_c2r_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_c2r_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_dft_c2r_3d(n0,n1,n2,in,out,flags) & + & BIND(C, name='fftw_plan_dft_c2r_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_dft_c2r_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru_dft_r2c(rank,dims,howmany_rank, & + & howmany_dims,in,out,flags) & + & BIND(C, name='fftw_plan_guru_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru_dft_c2r(rank,dims,howmany_rank, & + & howmany_dims,in,out,flags) & + & BIND(C, name='fftw_plan_guru_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru_split_dft_r2c(rank,dims,howmany_rank, & + & howmany_dims,in,ro,io,flags) & + & BIND(C, name='fftw_plan_guru_split_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru_split_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru_split_dft_c2r(rank,dims,howmany_rank, & + & howmany_dims,ri,ii,out,flags) & + & BIND(C, name='fftw_plan_guru_split_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru_split_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru64_dft_r2c(rank,dims,howmany_rank,& + & howmany_dims,in,out,flags) & + & BIND(C, name='fftw_plan_guru64_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru64_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru64_dft_c2r(rank,dims,howmany_rank,& + & howmany_dims,in,out,flags) & + & BIND(C, name='fftw_plan_guru64_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru64_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru64_split_dft_r2c(rank,dims,howmany_rank,& + & howmany_dims,in,ro,io,flags) & + & BIND(C, name='fftw_plan_guru64_split_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru64_split_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru64_split_dft_c2r(rank,dims,howmany_rank,& + & howmany_dims,ri,ii,out,flags) & + & BIND(C, name='fftw_plan_guru64_split_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru64_split_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_execute_dft_r2c(p,in,out) & + & BIND(C, name='fftw_execute_dft_r2c') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: in + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftw_execute_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_execute_dft_c2r(p,in,out) & + & BIND(C, name='fftw_execute_dft_c2r') + IMPORT + TYPE(C_PTR), VALUE :: p + COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftw_execute_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_execute_split_dft_r2c(p,in,ro,io) & + & BIND(C, name='fftw_execute_split_dft_r2c') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: io + END SUBROUTINE fftw_execute_split_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_execute_split_dft_c2r(p,ri,ii,out) & + & BIND(C, name='fftw_execute_split_dft_c2r') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ri + REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: ii + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftw_execute_split_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_many_r2r(rank,n,howmany,in,inembed,& + & istride, idist,out,onembed,ostride,odist,kind,flags) & + & BIND(C, name='fftw_plan_many_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_many_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_r2r(rank,n,in,out,kind,flags) & + & BIND(C, name='fftw_plan_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_r2r_1d(n,in,out,kind,flags) & + & BIND(C, name='fftw_plan_r2r_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_r2r_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_r2r_2d(n0,n1,in,out,kind0,kind1,flags) & + & BIND(C, name='fftw_plan_r2r_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_r2r_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_r2r_3d(n0,n1,n2,in,out,kind0,kind1,kind2, & + & flags) BIND(C, name='fftw_plan_r2r_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind2 + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_r2r_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru_r2r(rank,dims,howmany_rank, & + & howmany_dims,in,out,kind,flags) & + & BIND(C, name='fftw_plan_guru_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_plan_guru64_r2r(rank,dims,howmany_rank,& + & howmany_dims,in,out,kind,flags) & + & BIND(C, name='fftw_plan_guru64_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftw_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftw_plan_guru64_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_execute_r2r(p,in,out) BIND(C, name='fftw_execute_r2r') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_DOUBLE), DIMENSION(*), INTENT(INOUT) :: in + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftw_execute_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_destroy_plan(p) BIND(C, name='fftw_destroy_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + END SUBROUTINE fftw_destroy_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_forget_wisdom() BIND(C, name='fftw_forget_wisdom') + IMPORT + END SUBROUTINE fftw_forget_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_cleanup() BIND(C, name='fftw_cleanup') + IMPORT + END SUBROUTINE fftw_cleanup +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_set_timelimit(t) BIND(C, name='fftw_set_timelimit') + IMPORT + REAL(C_DOUBLE), VALUE :: t + END SUBROUTINE fftw_set_timelimit +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_plan_with_nthreads(nthreads) & + & BIND(C, name='fftw_plan_with_nthreads') + IMPORT + INTEGER(C_INT), VALUE :: nthreads + END SUBROUTINE fftw_plan_with_nthreads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_planner_nthreads() & + & BIND(C, name='fftw_planner_nthreads') + IMPORT + END FUNCTION fftw_planner_nthreads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_init_threads() & + & BIND(C, name='fftw_init_threads') + IMPORT + END FUNCTION fftw_init_threads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_cleanup_threads() BIND(C, name='fftw_cleanup_threads') + IMPORT + END SUBROUTINE fftw_cleanup_threads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE +! Unable to generate Fortran interface for fftw_threads_set_callback + SUBROUTINE fftw_make_planner_thread_safe() & + & BIND(C, name='fftw_make_planner_thread_safe') + IMPORT + END SUBROUTINE fftw_make_planner_thread_safe +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_export_wisdom_to_filename(filename) & + & BIND(C, name='fftw_export_wisdom_to_filename') + IMPORT + CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename + END FUNCTION fftw_export_wisdom_to_filename +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_export_wisdom_to_file(output_file) & + & BIND(C, name='fftw_export_wisdom_to_file') + IMPORT + TYPE(C_PTR), VALUE :: output_file + END SUBROUTINE fftw_export_wisdom_to_file +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_export_wisdom_to_string() & + & BIND(C, name='fftw_export_wisdom_to_string') + IMPORT + END FUNCTION fftw_export_wisdom_to_string +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_export_wisdom(write_char,data) & + & BIND(C, name='fftw_export_wisdom') + IMPORT + TYPE(C_FUNPTR), VALUE :: write_char + TYPE(C_PTR), VALUE :: data + END SUBROUTINE fftw_export_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_IMPORT_system_wisdom() & + & BIND(C, name='fftw_IMPORT_system_wisdom') + IMPORT + END FUNCTION fftw_IMPORT_system_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom_from_filename(filename) & + & BIND(C, name='fftw_IMPORT_wisdom_from_filename') + IMPORT + CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename + END FUNCTION fftw_IMPORT_wisdom_from_filename +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom_from_file(input_file) & + & BIND(C, name='fftw_IMPORT_wisdom_from_file') + IMPORT + TYPE(C_PTR), VALUE :: input_file + END FUNCTION fftw_IMPORT_wisdom_from_file +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom_from_string(input_string) & + & BIND(C, name='fftw_IMPORT_wisdom_from_string') + IMPORT + CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: input_string + END FUNCTION fftw_IMPORT_wisdom_from_string +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_IMPORT_wisdom(read_char,data) & + & BIND(C, name='fftw_IMPORT_wisdom') + IMPORT + TYPE(C_FUNPTR), VALUE :: read_char + TYPE(C_PTR), VALUE :: data + END FUNCTION fftw_IMPORT_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_fprint_plan(p,output_file) BIND(C, name='fftw_fprint_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + TYPE(C_PTR), VALUE :: output_file + END SUBROUTINE fftw_fprint_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_print_plan(p) BIND(C, name='fftw_print_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + END SUBROUTINE fftw_print_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_sprint_plan(p) BIND(C, name='fftw_sprint_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + END FUNCTION fftw_sprint_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_malloc(n) BIND(C, name='fftw_malloc') + IMPORT + INTEGER(C_SIZE_T), VALUE :: n + END FUNCTION fftw_malloc +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_alloc_real(n) BIND(C, name='fftw_alloc_real') + IMPORT + INTEGER(C_SIZE_T), VALUE :: n + END FUNCTION fftw_alloc_real +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftw_alloc_complex(n) & + & BIND(C, name='fftw_alloc_complex') + IMPORT + INTEGER(C_SIZE_T), VALUE :: n + END FUNCTION fftw_alloc_complex +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_free(p) BIND(C, name='fftw_free') + IMPORT + TYPE(C_PTR), VALUE :: p + END SUBROUTINE fftw_free +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftw_flops(p,add,mul,fmas) BIND(C, name='fftw_flops') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_DOUBLE), INTENT(OUT) :: add + REAL(C_DOUBLE), INTENT(OUT) :: mul + REAL(C_DOUBLE), INTENT(OUT) :: fmas + END SUBROUTINE fftw_flops +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + REAL(C_DOUBLE) FUNCTION fftw_estimate_cost(p) & + & BIND(C, name='fftw_estimate_cost') + IMPORT + TYPE(C_PTR), VALUE :: p + END FUNCTION fftw_estimate_cost +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + REAL(C_DOUBLE) FUNCTION fftw_cost(p) BIND(C, name='fftw_cost') + IMPORT + TYPE(C_PTR), VALUE :: p + END FUNCTION fftw_cost +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftw_alignment_of(p) & + & BIND(C, name='fftw_alignment_of') + IMPORT + REAL(C_DOUBLE), DIMENSION(*), INTENT(OUT) :: p + END FUNCTION fftw_alignment_of +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft(rank,n,in,out,sign,flags) & + & BIND(C, name='fftwf_plan_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_1d(n,in,out,sign,flags) & + & BIND(C, name='fftwf_plan_dft_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_2d(n0,n1,in,out,sign,flags) & + & BIND(C, name='fftwf_plan_dft_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_3d(n0,n1,n2,in,out,sign,flags) & + & BIND(C, name='fftwf_plan_dft_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_many_dft(rank,n,howmany,in,inembed,istride,& + & idist,out,onembed,ostride,odist,sign,flags) & + & BIND(C, name='fftwf_plan_many_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_many_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru_dft(rank,dims,howmany_rank,& + & howmany_dims,in,out,sign,flags) & + & BIND(C, name='fftwf_plan_guru_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru_split_dft(rank,dims,howmany_rank,& + & howmany_dims,ri,ii,ro,io,flags) & + & BIND(C, name='fftwf_plan_guru_split_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru_split_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru64_dft(rank,dims,howmany_rank,& + & howmany_dims,in,out,sign,flags) & + & BIND(C, name='fftwf_plan_guru64_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: sign + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru64_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru64_split_dft(rank,dims,howmany_rank,& + & howmany_dims,ri,ii,ro,io,flags) & + & BIND(C, name='fftwf_plan_guru64_split_dft') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru64_split_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_execute_dft(p,in,out) BIND(C, name='fftwf_execute_dft') + IMPORT + TYPE(C_PTR), VALUE :: p + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftwf_execute_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_execute_split_dft(p,ri,ii,ro,io) & + & BIND(C, name='fftwf_execute_split_dft') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ri + REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ii + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io + END SUBROUTINE fftwf_execute_split_dft +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_many_dft_r2c(rank,n,howmany,in,& + & inembed,istride,idist,out,onembed,ostride,odist,flags) & + & BIND(C, name='fftwf_plan_many_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_many_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c(rank,n,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c_1d(n,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_r2c_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_r2c_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c_2d(n0,n1,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_r2c_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_r2c_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_r2c_3d(n0,n1,n2,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_r2c_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_r2c_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_many_dft_c2r(rank,n,howmany,in,inembed,& + & istride,idist,out,onembed,ostride,odist,flags) & + & BIND(C, name='fftwf_plan_many_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_many_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r(rank,n,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r_1d(n,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_c2r_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_c2r_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r_2d(n0,n1,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_c2r_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_c2r_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_dft_c2r_3d(n0,n1,n2,in,out,flags) & + & BIND(C, name='fftwf_plan_dft_c2r_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_dft_c2r_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru_dft_r2c(rank,dims,howmany_rank,& + & howmany_dims,in,out,flags) & + & BIND(C, name='fftwf_plan_guru_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru_dft_c2r(rank,dims,howmany_rank, & + & howmany_dims,in,out,flags) & + & BIND(C, name='fftwf_plan_guru_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru_split_dft_r2c(rank,dims,howmany_rank,& + & howmany_dims,in,ro,io,flags) & + & BIND(C, name='fftwf_plan_guru_split_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru_split_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru_split_dft_c2r(rank,dims,& + & howmany_rank,howmany_dims,ri,ii,out,flags) & + & BIND(C, name='fftwf_plan_guru_split_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru_split_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru64_dft_r2c(rank,dims,howmany_rank,& + & howmany_dims,in,out,flags) & + & BIND(C, name='fftwf_plan_guru64_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru64_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru64_dft_c2r(rank,dims,howmany_rank,& + & howmany_dims,in,out,flags) & + & BIND(C, name='fftwf_plan_guru64_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru64_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru64_split_dft_r2c(rank,dims, & + & howmany_rank,howmany_dims,in,ro,io,flags) & + & BIND(C, name='fftwf_plan_guru64_split_dft_r2c') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru64_split_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru64_split_dft_c2r(rank,dims,& + & howmany_rank,howmany_dims,ri,ii,out,flags) & + & BIND(C, name='fftwf_plan_guru64_split_dft_c2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ri + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ii + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru64_split_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_execute_dft_r2c(p,in,out) & + & BIND(C, name='fftwf_execute_dft_r2c') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: in + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftwf_execute_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_execute_dft_c2r(p,in,out) & + & BIND(C, name='fftwf_execute_dft_c2r') + IMPORT + TYPE(C_PTR), VALUE :: p + COMPLEX(C_FLOAT_COMPLEX), DIMENSION(*), INTENT(INOUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftwf_execute_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_execute_split_dft_r2c(p,in,ro,io) & + & BIND(C, name='fftwf_execute_split_dft_r2c') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: ro + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: io + END SUBROUTINE fftwf_execute_split_dft_r2c +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_execute_split_dft_c2r(p,ri,ii,out) & + & BIND(C, name='fftwf_execute_split_dft_c2r') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ri + REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: ii + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftwf_execute_split_dft_c2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_many_r2r(rank,n,howmany,in,inembed,& + & istride,idist,out,onembed,ostride,odist,kind,flags) & + & BIND(C, name='fftwf_plan_many_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + INTEGER(C_INT), VALUE :: howmany + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: inembed + INTEGER(C_INT), VALUE :: istride + INTEGER(C_INT), VALUE :: idist + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: onembed + INTEGER(C_INT), VALUE :: ostride + INTEGER(C_INT), VALUE :: odist + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_many_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_r2r(rank,n,in,out,kind,flags) & + & BIND(C, name='fftwf_plan_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + INTEGER(C_INT), DIMENSION(*), INTENT(IN) :: n + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_r2r_1d(n,in,out,kind,flags) & + & BIND(C, name='fftwf_plan_r2r_1d') + IMPORT + INTEGER(C_INT), VALUE :: n + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_r2r_1d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_r2r_2d(n0,n1,in,out,kind0,kind1,flags) & + & BIND(C, name='fftwf_plan_r2r_2d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_r2r_2d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_r2r_3d(n0,n1,n2,in,out,kind0, & + & kind1,kind2,flags) BIND(C, name='fftwf_plan_r2r_3d') + IMPORT + INTEGER(C_INT), VALUE :: n0 + INTEGER(C_INT), VALUE :: n1 + INTEGER(C_INT), VALUE :: n2 + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind0 + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind1 + INTEGER(C_FFTW_R2R_KIND), VALUE :: kind2 + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_r2r_3d +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & + BIND(C, name='fftwf_plan_guru_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_plan_guru64_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & + BIND(C, name='fftwf_plan_guru64_r2r') + IMPORT + INTEGER(C_INT), VALUE :: rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: dims + INTEGER(C_INT), VALUE :: howmany_rank + TYPE(fftwf_iodim64), DIMENSION(*), INTENT(IN) :: howmany_dims + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + INTEGER(C_FFTW_R2R_KIND), DIMENSION(*), INTENT(IN) :: kind + INTEGER(C_INT), VALUE :: flags + END FUNCTION fftwf_plan_guru64_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_execute_r2r(p,in,out) BIND(C, name='fftwf_execute_r2r') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_FLOAT), DIMENSION(*), INTENT(INOUT) :: in + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: out + END SUBROUTINE fftwf_execute_r2r +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_destroy_plan(p) BIND(C, name='fftwf_destroy_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + END SUBROUTINE fftwf_destroy_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_forget_wisdom() BIND(C, name='fftwf_forget_wisdom') + IMPORT + END SUBROUTINE fftwf_forget_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_cleanup() BIND(C, name='fftwf_cleanup') + IMPORT + END SUBROUTINE fftwf_cleanup +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_set_timelimit(t) BIND(C, name='fftwf_set_timelimit') + IMPORT + REAL(C_DOUBLE), VALUE :: t + END SUBROUTINE fftwf_set_timelimit +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_plan_with_nthreads(nthreads) BIND(C, name='fftwf_plan_with_nthreads') + IMPORT + INTEGER(C_INT), VALUE :: nthreads + END SUBROUTINE fftwf_plan_with_nthreads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_planner_nthreads() BIND(C, name='fftwf_planner_nthreads') + IMPORT + END FUNCTION fftwf_planner_nthreads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_init_threads() BIND(C, name='fftwf_init_threads') + IMPORT + END FUNCTION fftwf_init_threads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_cleanup_threads() BIND(C, name='fftwf_cleanup_threads') + IMPORT + END SUBROUTINE fftwf_cleanup_threads +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + ! Unable to generate Fortran interface for fftwf_threads_set_callback + SUBROUTINE fftwf_make_planner_thread_safe() BIND(C, name='fftwf_make_planner_thread_safe') + IMPORT + END SUBROUTINE fftwf_make_planner_thread_safe +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_export_wisdom_to_filename(filename) BIND(C, name='fftwf_export_wisdom_to_filename') + IMPORT + CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename + END FUNCTION fftwf_export_wisdom_to_filename +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_export_wisdom_to_file(output_file) BIND(C, name='fftwf_export_wisdom_to_file') + IMPORT + TYPE(C_PTR), VALUE :: output_file + END SUBROUTINE fftwf_export_wisdom_to_file +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_export_wisdom_to_string() BIND(C, name='fftwf_export_wisdom_to_string') + IMPORT + END FUNCTION fftwf_export_wisdom_to_string +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_export_wisdom(write_char,data) BIND(C, name='fftwf_export_wisdom') + IMPORT + TYPE(C_FUNPTR), VALUE :: write_char + TYPE(C_PTR), VALUE :: data + END SUBROUTINE fftwf_export_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_IMPORT_system_wisdom() BIND(C, name='fftwf_IMPORT_system_wisdom') + IMPORT + END FUNCTION fftwf_IMPORT_system_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom_from_filename(filename) BIND(C, name='fftwf_IMPORT_wisdom_from_filename') + IMPORT + CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: filename + END FUNCTION fftwf_IMPORT_wisdom_from_filename +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom_from_file(input_file) BIND(C, name='fftwf_IMPORT_wisdom_from_file') + IMPORT + TYPE(C_PTR), VALUE :: input_file + END FUNCTION fftwf_IMPORT_wisdom_from_file +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom_from_string(input_string) BIND(C, name='fftwf_IMPORT_wisdom_from_string') + IMPORT + CHARACTER(C_CHAR), DIMENSION(*), INTENT(IN) :: input_string + END FUNCTION fftwf_IMPORT_wisdom_from_string +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_IMPORT_wisdom(read_char,data) BIND(C, name='fftwf_IMPORT_wisdom') + IMPORT + TYPE(C_FUNPTR), VALUE :: read_char + TYPE(C_PTR), VALUE :: data + END FUNCTION fftwf_IMPORT_wisdom +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_fprint_plan(p,output_file) BIND(C, name='fftwf_fprint_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + TYPE(C_PTR), VALUE :: output_file + END SUBROUTINE fftwf_fprint_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_print_plan(p) BIND(C, name='fftwf_print_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + END SUBROUTINE fftwf_print_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_sprint_plan(p) BIND(C, name='fftwf_sprint_plan') + IMPORT + TYPE(C_PTR), VALUE :: p + END FUNCTION fftwf_sprint_plan +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_malloc(n) BIND(C, name='fftwf_malloc') + IMPORT + INTEGER(C_SIZE_T), VALUE :: n + END FUNCTION fftwf_malloc +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_alloc_real(n) BIND(C, name='fftwf_alloc_real') + IMPORT + INTEGER(C_SIZE_T), VALUE :: n + END FUNCTION fftwf_alloc_real +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + TYPE(C_PTR) FUNCTION fftwf_alloc_complex(n) BIND(C, name='fftwf_alloc_complex') + IMPORT + INTEGER(C_SIZE_T), VALUE :: n + END FUNCTION fftwf_alloc_complex +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_free(p) BIND(C, name='fftwf_free') + IMPORT + TYPE(C_PTR), VALUE :: p + END SUBROUTINE fftwf_free +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE fftwf_flops(p,add,mul,fmas) BIND(C, name='fftwf_flops') + IMPORT + TYPE(C_PTR), VALUE :: p + REAL(C_DOUBLE), INTENT(OUT) :: add + REAL(C_DOUBLE), INTENT(OUT) :: mul + REAL(C_DOUBLE), INTENT(OUT) :: fmas + END SUBROUTINE fftwf_flops +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + REAL(C_DOUBLE) FUNCTION fftwf_estimate_cost(p) BIND(C, name='fftwf_estimate_cost') + IMPORT + TYPE(C_PTR), VALUE :: p + END FUNCTION fftwf_estimate_cost +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + REAL(C_DOUBLE) FUNCTION fftwf_cost(p) BIND(C, name='fftwf_cost') + IMPORT + TYPE(C_PTR), VALUE :: p + END FUNCTION fftwf_cost +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(C_INT) FUNCTION fftwf_alignment_of(p) BIND(C, name='fftwf_alignment_of') + IMPORT + REAL(C_FLOAT), DIMENSION(*), INTENT(OUT) :: p + END FUNCTION fftwf_alignment_of +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FFTW3 +#endif \ No newline at end of file diff --git a/src/modules/FPL/CMakeLists.txt b/src/modules/FPL/CMakeLists.txt new file mode 100644 index 000000000..2c7dc8619 --- /dev/null +++ b/src/modules/FPL/CMakeLists.txt @@ -0,0 +1,17 @@ +################################################################# +# Search F90 files recursively in all subdirs +################################################################# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +FILE(GLOB_RECURSE WRAPPER_LIB_SRC ${src_path}/Wrapper/*.F90) +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${WRAPPER_LIB_SRC} + ${src_path}/ErrorMessages.F90 + ${src_path}/FPL_utils.F90 + ${src_path}/FPL.F90 + ${src_path}/ParameterEntry.F90 + ${src_path}/ParameterEntryDictionary.F90 + ${src_path}/ParameterList.F90 + ${src_path}/ParameterRootEntry.F90 + ) \ No newline at end of file diff --git a/src/modules/FPL/LICENSE b/src/modules/FPL/LICENSE new file mode 100644 index 000000000..02bbb60bc --- /dev/null +++ b/src/modules/FPL/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. \ No newline at end of file diff --git a/src/modules/FPL/src/ErrorMessages.F90 b/src/modules/FPL/src/ErrorMessages.F90 new file mode 100644 index 000000000..b01db881a --- /dev/null +++ b/src/modules/FPL/src/ErrorMessages.F90 @@ -0,0 +1,123 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +MODULE ErrorMessages +USE ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT, ERROR_UNIT +USE PENF, ONLY: I4P, str + +IMPLICIT NONE +PRIVATE + +INTEGER(I4P), PUBLIC, PARAMETER :: FPLSuccess = 0 +INTEGER(I4P), PUBLIC, PARAMETER :: FPLWrapperFactoryError = -1 +INTEGER(I4P), PUBLIC, PARAMETER :: FPLWrapperError = -2 +INTEGER(I4P), PUBLIC, PARAMETER :: FPLSublistError = -3 +INTEGER(I4P), PUBLIC, PARAMETER :: FPLParameterListIteratorError = -4 + +TYPE :: MessageHandler_t + PRIVATE + CHARACTER(5) :: prefix = '[FPL]' +CONTAINS + PROCEDURE, NON_OVERRIDABLE :: PRINT => MessageHandler_Print + PROCEDURE, NON_OVERRIDABLE :: Warn => MessageHandler_Warn + PROCEDURE, NON_OVERRIDABLE :: Error => MessageHandler_Error +END TYPE + +TYPE(MessageHandler_t), SAVE :: msg +!$OMP THREADPRIVATE(msg) + +PUBLIC :: msg + +CONTAINS + +SUBROUTINE MessageHandler_Print(this, txt, unit, iostat, iomsg) + !----------------------------------------------------------------- + !< Print a txt message preceding for prefix + !----------------------------------------------------------------- + CLASS(MessageHandler_t), INTENT(IN) :: this !< Message handler + CHARACTER(*), INTENT(IN) :: txt !< Text to print + INTEGER(I4P), OPTIONAL, INTENT(IN) :: unit !< Unit where to print + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + INTEGER(I4P) :: iostatd !< Real IO error. + INTEGER(I4P) :: u !< Real unit + CHARACTER(500) :: iomsgd !< Real IO error message. + !----------------------------------------------------------------- + u = OUTPUT_UNIT; IF (PRESENT(unit)) u = unit; iostatd = 0; + iomsgd = '' + WRITE (unit=u, fmt='(A)', iostat=iostatd, iomsg=iomsgd) & + & this%Prefix//' '//txt + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE + +SUBROUTINE MessageHandler_Warn(this, txt, unit, file, line, iostat, iomsg) + !----------------------------------------------------------------- + !< Warn a with txt message preceding for WARNING! + !----------------------------------------------------------------- + CLASS(MessageHandler_t), INTENT(IN) :: this !< Message handler + CHARACTER(*), INTENT(IN) :: txt !< Text to print + INTEGER(I4P), OPTIONAL, INTENT(IN) :: unit !< Unit where to print + CHARACTER(*), OPTIONAL, INTENT(IN) :: file !< Source file + INTEGER(I4P), OPTIONAL, INTENT(IN) :: line !< Number of line in source file + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(:), ALLOCATABLE :: loc !< Warning location string + INTEGER(I4P) :: iostatd !< Real IO error. + INTEGER(I4P) :: u !< Real unit + CHARACTER(500) :: iomsgd !< Real IO error message. + !----------------------------------------------------------------- + u = ERROR_UNIT; IF (PRESENT(unit)) u = unit; iostatd = 0; + iomsgd = ''; loc = '' + IF (PRESENT(file) .AND. PRESENT(line)) & + & loc = '('//file//':'//TRIM(str(no_sign=.TRUE., n=line))//') ' + call this%Print('WARNING! '//trim(adjustl(loc//txt)), & + & unit=u, iostat=iostatd, iomsg=iomsgd) + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE + +SUBROUTINE MessageHandler_Error(this, txt, unit, file, line, iostat, iomsg) + !----------------------------------------------------------------- + !< Print a txt message preceding for ERROR! + !----------------------------------------------------------------- + CLASS(MessageHandler_t), INTENT(IN) :: this !< Message handler + CHARACTER(*), INTENT(IN) :: txt !< Text to print + INTEGER(I4P), OPTIONAL, INTENT(IN) :: unit !< Unit where to print + CHARACTER(*), OPTIONAL, INTENT(IN) :: file !< Source file + INTEGER(I4P), OPTIONAL, INTENT(IN) :: line !< Number of line in source file + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(:), ALLOCATABLE :: loc !< Error location string + INTEGER(I4P) :: iostatd !< Real IO error. + INTEGER(I4P) :: u !< Real unit + CHARACTER(500) :: iomsgd !< Real IO error message. + !----------------------------------------------------------------- + u = ERROR_UNIT; IF (PRESENT(unit)) u = unit; iostatd = 0; iomsgd = '' + loc = '' + IF (PRESENT(file) .AND. PRESENT(line)) & + & loc = '('//file//':'//TRIM(str(no_sign=.TRUE., n=line))//') ' + call this%Print('ERROR! '//trim(adjustl(loc//txt)), & + & unit=u, iostat=iostatd, iomsg=iomsgd) + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE + +END MODULE diff --git a/src/modules/FPL/src/FPL.F90 b/src/modules/FPL/src/FPL.F90 new file mode 100644 index 000000000..9011c95c9 --- /dev/null +++ b/src/modules/FPL/src/FPL.F90 @@ -0,0 +1,54 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +#define ParameterList_t ParameterList_ +#define ParameterListIterator_t ParameterListIterator_ + +MODULE FPL +USE ParameterList +USE WrapperFactoryListSingleton +PRIVATE +PUBLIC :: ParameterList_t, ParameterListIterator_t +PUBLIC :: FPL_Init +PUBLIC :: FPL_Finalize + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-02 +! summary: Initialize FPL + +SUBROUTINE FPL_Init() + CALL TheWrapperFactoryList_Init() +END SUBROUTINE FPL_Init + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE FPL_Finalize() + CALL TheWrapperFactoryList%Free() +END SUBROUTINE FPL_Finalize + +END MODULE FPL diff --git a/src/modules/FPL/src/FPL_utils.F90 b/src/modules/FPL/src/FPL_utils.F90 new file mode 100644 index 000000000..978416506 --- /dev/null +++ b/src/modules/FPL/src/FPL_utils.F90 @@ -0,0 +1,45 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 FPL_Utils +USE PENF, only: I1P, I4P +contains + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! 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 + !! Character variable whose number of bits must be computed. + integer(I4P) :: bytes + !! Number of bits of l. + 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +end module FPL_Utils diff --git a/src/modules/FPL/src/ParameterEntry.F90 b/src/modules/FPL/src/ParameterEntry.F90 new file mode 100644 index 000000000..d3e82886a --- /dev/null +++ b/src/modules/FPL/src/ParameterEntry.F90 @@ -0,0 +1,381 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter Entry) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module ParameterEntry + +USE PENF +USE DimensionsWrapper + +implicit none +private + +type :: EntryListIterator_t + private + type(ParameterEntry_t), pointer :: CurrentEntry => NULL() +contains + private + procedure, non_overridable :: EntryListIterator_Assignment + procedure, public, non_overridable :: Init => EntryListIterator_Init + procedure, public, non_overridable :: Next => EntryListIterator_Next + procedure, public, non_overridable :: HasFinished => & + & EntryListIterator_HasFinished + procedure, public, non_overridable :: GetEntry => EntryListIterator_GetEntry + procedure, public, non_overridable :: GetKey => EntryListIterator_GetKey + procedure, public, non_overridable :: PointToValue => & + & EntryListIterator_PointToValue + procedure, public, non_overridable :: Free => EntryListIterator_Free + generic, public :: Assignment(=) => EntryListIterator_Assignment + final :: EntryListIterator_Final +end type + +type :: ParameterEntry_t + private + character(len=:), allocatable :: Key + class(*), pointer :: Value => NULL() + class(ParameterEntry_t), pointer :: Next => NULL() +contains + private + procedure, non_overridable, public :: Free => ParameterEntry_Free + procedure, non_overridable, public :: Print => ParameterEntry_Print + procedure, non_overridable, public :: HasNext => ParameterEntry_HasNext + procedure, non_overridable, public :: SetNext => ParameterEntry_SetNext + procedure, non_overridable, public :: GetNext => ParameterEntry_GetNext + procedure, non_overridable, public :: NullifyNext => & + & ParameterEntry_NullifyNext + procedure, non_overridable, public :: HasKey => ParameterEntry_HasKey + procedure, non_overridable, public :: SetKey => ParameterEntry_SetKey + procedure, non_overridable, public :: GetKey => ParameterEntry_GetKey + procedure, non_overridable, public :: DeallocateKey => & + & ParameterEntry_DeallocateKey + procedure, non_overridable, public :: HasValue => ParameterEntry_HasValue + procedure, non_overridable, public :: SetValue => ParameterEntry_SetValue + procedure, non_overridable, public :: GetValue => ParameterEntry_GetValue + procedure, non_overridable, public :: DeallocateValue => & + & ParameterEntry_DeallocateValue + procedure, non_overridable, public :: PointToValue => & + & ParameterEntry_PointToValue + procedure, non_overridable, public :: GetIterator => & + & ParameterEntry_GetIterator + final :: ParameterEntry_Finalize +end type ParameterEntry_t + +public :: ParameterEntry_t +public :: EntryListIterator_t + +contains + +function ParameterEntry_HasNext(this) result(hasNext) + + !< Check if Next is associated for the current Node + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + logical :: hasNext !< Check if Next is associated + + hasNext = associated(this%Next) +end function ParameterEntry_HasNext + +subroutine ParameterEntry_SetNext(this, Next) + + !< Set the pointer to the Next node + + class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + class(ParameterEntry_t), pointer, intent(IN) :: Next !< Pointer to Next + + this%Next => Next +end subroutine ParameterEntry_SetNext + +function ParameterEntry_GetNext(this) result(Next) + + !< Return a pointer to the Next node + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + class(ParameterEntry_t), pointer :: Next !< Pointer to Next + + nullify (Next) + if (this%HasNext()) Next => this%Next +end function ParameterEntry_GetNext + +subroutine ParameterEntry_NullifyNext(this) + + !< Nullify Next + + class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + + nullify (this%Next) +end subroutine ParameterEntry_NullifyNext + +function ParameterEntry_HasKey(this) result(hasKey) + + !< Check if Key is allocated for the current Node + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + logical :: hasKey !< Check if Key is associated + + hasKey = allocated(this%Key) +end function ParameterEntry_HasKey + +subroutine ParameterEntry_SetKey(this, Key) + + !< Check if Next is associated for the current Node + + class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + character(len=*), intent(IN) :: Key !< Key + + this%Key = Key +end subroutine ParameterEntry_SetKey + +subroutine ParameterEntry_GetKey(this, Key) + + !< Return entry key + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + character(len=:), allocatable, intent(INOUT) :: Key !< Key + + Key = this%Key +end subroutine ParameterEntry_GetKey + +subroutine ParameterEntry_DeallocateKey(this) + + !< Deallocate Key if allocated + + class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + + if (this%HasKey()) deallocate (this%Key) +end subroutine ParameterEntry_DeallocateKey + +subroutine ParameterEntry_Free(this) + + !< Free the Entry + + class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + + call this%DeallocateKey() + call this%DeallocateValue() + call this%NullifyNext() +end subroutine ParameterEntry_Free + +function ParameterEntry_HasValue(this) result(hasValue) + + !< Check if Value is allocated for the current Node + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + logical :: hasValue !< Check if Value is allocated + + hasValue = associated(this%Value) +end function ParameterEntry_HasValue + +subroutine ParameterEntry_SetValue(this, Value) + + !< Set a concrete Wrapper + + class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + class(*), pointer, intent(IN) :: Value !< Concrete Wrapper + + if (this%HasValue()) deallocate (this%Value) + this%Value => Value +end subroutine ParameterEntry_SetValue + +subroutine ParameterEntry_GetValue(this, Value) + + !< Return a concrete WrapperFactory + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + class(*), allocatable, intent(OUT) :: Value !< Concrete Wrapper + + if (this%HasValue()) allocate (Value, source=this%Value) +end subroutine ParameterEntry_GetValue + +function ParameterEntry_PointToValue(this) result(Value) + + !< Return a pointer to a concrete WrapperFactory + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + class(*), pointer :: Value !< Concrete Wrapper + + Value => this%Value +end function ParameterEntry_PointToValue + +subroutine ParameterEntry_DeallocateValue(this) + + !< Deallocate Key if allocated + + class(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + + if (this%HasValue()) deallocate (this%Value) +end subroutine ParameterEntry_DeallocateValue + +subroutine ParameterEntry_Finalize(this) + + !< Finalize procedure + + type(ParameterEntry_t), intent(INOUT) :: this !< Parameter Entry + + call this%Free() +end subroutine ParameterEntry_Finalize + +function ParameterEntry_GetIterator(this) result(Iterator) + + !< Free the list + + class(ParameterEntry_t), target, intent(INOUT) :: this !< Parameter Entry + type(EntryListIterator_t) :: Iterator !< List iterator + + call Iterator%Init(Entry=this) +end function ParameterEntry_GetIterator + +subroutine ParameterEntry_Print(this, unit, prefix, iostat, iomsg) + + !< Print the keys/value pair contained in the Parameter Entry + + class(ParameterEntry_t), intent(IN) :: this !< Parameter Entry + 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 :: Key !< Entry Key + integer(I4P) :: iostatd !< IO error. + character(500) :: iomsgd !< Temporary variable for IO error message. + + iostatd = 0; iomsgd = ''; prefd = ''; if (present(prefix)) prefd = prefix + if (this%HasKey()) then + call this%GetKey(Key) + write (unit=unit, fmt='(A)', advance="NO", iostat=iostatd, & + & iomsg=iomsgd) prefd//' Key = "'//Key//'", ' + !! + select type (Wrapper => this%Value) + class is (DimensionsWrapper_t) + call Wrapper%Print(unit=unit) + class Default + write (unit=unit, fmt='(A)', iostat=iostatd, iomsg=iomsgd) & + & ' is a Parameter SubList' + end select + end if + + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd +end subroutine ParameterEntry_Print + +!--------------------------------------------------------------------- +!< Entry List Iterator Procedures +!--------------------------------------------------------------------- + +subroutine EntryListIterator_Assignment(this, ListIterator) + + !< Assignment operator + + class(EntryListIterator_t), intent(INOUT) :: this ! Output List iterator + type(EntryListIterator_t), intent(IN) :: ListIterator ! Input List iterator + + this%CurrentEntry => ListIterator%CurrentEntry +end subroutine EntryListIterator_Assignment + +subroutine EntryListIterator_Free(this) + + !< Free the List iterator + + class(EntryListIterator_t), intent(INOUT) :: this ! List iterator + + nullify (this%CurrentEntry) +end subroutine EntryListIterator_Free + +subroutine EntryListIterator_Final(this) + + !< Free the List iterator + + type(EntryListIterator_t), intent(INOUT) :: this ! List iterator + + call this%Free() +end subroutine EntryListIterator_Final + +subroutine EntryListIterator_Init(this, Entry) + + !< Associate the iterator with an entry + + class(EntryListIterator_t), intent(INOUT) :: this ! List iterator + type(ParameterEntry_t), target, intent(IN) :: Entry ! List entry + + call this%Free() + this%CurrentEntry => Entry +end subroutine EntryListIterator_Init + +subroutine EntryListIterator_Next(this) + + !< The iterator points to the next associated entry + + class(EntryListIterator_t), intent(INOUT) :: this ! List iterator + +if (.not. this%HasFinished()) this%CurrentEntry => this%CurrentEntry%GetNext() +end subroutine EntryListIterator_Next + +function EntryListIterator_GetEntry(this) result(CurrentEntry) + + !< Return the current Entry + + class(EntryListIterator_t), intent(IN) :: this ! List iterator + type(ParameterEntry_t), pointer :: CurrentEntry ! Current entry + + nullify (CurrentEntry) + CurrentEntry => this%CurrentEntry +end function EntryListIterator_GetEntry + +subroutine EntryListIterator_GetKey(this, Key) + + !< Return the current Key + + class(EntryListIterator_t), intent(IN) :: this ! List iterator + character(len=:), allocatable, intent(INOUT) :: Key ! Entry Key + type(ParameterEntry_t), pointer :: CurrentEntry ! Current entry + + if (associated(this%CurrentEntry)) then + if (this%CurrentEntry%HasKey()) call this%CurrentEntry%GetKey(Key) + end if +end subroutine EntryListIterator_GetKey + +function EntryListIterator_PointToValue(this) result(Value) + + !< Return the current Value + + class(EntryListIterator_t), intent(IN) :: this ! List iterator + type(ParameterEntry_t), pointer :: CurrentEntry ! Current entry + class(*), pointer :: Value ! Entry Value + + nullify (Value) + if (associated(this%CurrentEntry)) then + if (this%CurrentEntry%HasValue()) Value => this%CurrentEntry%PointToValue() + end if +end function EntryListIterator_PointToValue + +function EntryListIterator_HasFinished(this) result(HasFinished) + + !< Check if Iterator has reached the end of the dictionary + + class(EntryListIterator_t), intent(IN) :: this ! List iterator + logical :: HasFinished ! Check if has reached the end of the list + + HasFinished = .false. + if (.not. associated(this%CurrentEntry)) then + HasFinished = .true. + elseif (.not. this%CurrentEntry%HasNext()) then + HasFinished = .true. + end if +end function EntryListIterator_HasFinished + +end module ParameterEntry diff --git a/src/modules/FPL/src/ParameterEntryDictionary.F90 b/src/modules/FPL/src/ParameterEntryDictionary.F90 new file mode 100644 index 000000000..fbf85a0f0 --- /dev/null +++ b/src/modules/FPL/src/ParameterEntryDictionary.F90 @@ -0,0 +1,336 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +!----------------------------------------------------------------- +! ParameterEntryDictionary is a datatype containing a Database +! array of ParameterListEntries made to store diferent Entries +! depending on the hash of its Key. +! +! This work takes as a starting point the previou work of +! Stefano Zaghi (@szaghi, https://github.com/szaghi). +! +! You can find the original source at: +! https://github.com/szaghi/OFF/blob/ +!95691ca15e6d68128ba016e40df74e42123f1c54/ +!src/Data_Type_Hash_Table.f90 +!----------------------------------------------------------------- + +MODULE ParameterEntryDictionary + +USE ParameterEntry +USE ParameterRootEntry +USE PENF, ONLY: I4P, str + +IMPLICIT NONE +PRIVATE + +INTEGER(I4P), PARAMETER :: DefaultDataBaseSize = 100_I4P + +TYPE :: ParameterEntryDictionary_t + PRIVATE + TYPE(ParameterRootEntry_t), ALLOCATABLE :: DataBase(:) + INTEGER(I4P) :: Size = 0_I4P +CONTAINS + PRIVATE + PROCEDURE, NON_OVERRIDABLE :: Hash => & + & ParameterEntryDictionary_Hash + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Init => & + & ParameterEntryDictionary_Init + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Set => & + & ParameterEntryDictionary_Set + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Get => & + & ParameterEntryDictionary_Get + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetPointer => & + & ParameterEntryDictionary_GetPointer + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetDatabase => & + & ParameterEntryDictionary_GetDataBase + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Del => & + & ParameterEntryDictionary_Delete + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: IsPresent => & + & ParameterEntryDictionary_IsPresent + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Length => & + & ParameterEntryDictionary_Length + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: PRINT => & + & ParameterEntryDictionary_Print + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Free => & + & ParameterEntryDictionary_Free + FINAL :: ParameterEntryDictionary_Finalize +END TYPE + +PUBLIC :: ParameterEntryDictionary_t + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterEntryDictionary_Hash(this, Key) RESULT(Hash) + + !< String hash function + + CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this + !< Parameter Entry Dictionary + CHARACTER(*), INTENT(IN) :: Key + !< String Key + INTEGER(I4P) :: Hash + !< Hash code + CHARACTER, DIMENSION(LEN(Key)) :: CharArray + !< Character array containing the Key + INTEGER(I4P) :: CharIterator + !< Char iterator index + + DO CONCURRENT(CharIterator=1:LEN(Key)) + CharArray(CharIterator) = Key(CharIterator:CharIterator) + END DO + Hash = MOD(SUM(ICHAR(CharArray)), this%Size) +END FUNCTION ParameterEntryDictionary_Hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterEntryDictionary_Init(this, Size) + + !< Allocate the database with a given Szie of DefaultDataBaseSize + + CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this + !< Parameter Entry Dictionary + INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size + !< DataBase Size + + CALL this%Free() + IF (PRESENT(Size)) THEN + this%Size = Size + ELSE + this%Size = DefaultDataBaseSize + END IF + ALLOCATE (this%DataBase(0:this%Size - 1)) +END SUBROUTINE ParameterEntryDictionary_Init + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterEntryDictionary_isPresent(this, Key) RESULT(isPresent) + + !< Check if a Key is present in the DataBase + + CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this + !< Parameter Entry Dictionary + CHARACTER(*), INTENT(IN) :: Key + !< String Key + LOGICAL :: isPresent + !< Boolean flag to check if a Key is present + + isPresent = this%DataBase(this%Hash(Key=Key))%isPresent(Key=Key) +END FUNCTION ParameterEntryDictionary_isPresent + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterEntryDictionary_Set(this, Key, VALUE) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this + !< Parameter Entry Dictionary + CHARACTER(*), INTENT(IN) :: Key + !< String Key + CLASS(*), POINTER, INTENT(IN) :: VALUE + !< Value + + CALL this%DataBase(this%Hash(Key=Key))%AddEntry(Key=Key, VALUE=VALUE) +END SUBROUTINE ParameterEntryDictionary_Set + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterEntryDictionary_Get(this, Key, VALUE) + + !< Return a Value given the Key + + CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this + !< Parameter Entry Dictionary + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), ALLOCATABLE, INTENT(INOUT) :: VALUE + !< Returned value + CLASS(ParameterEntry_t), POINTER :: ENTRY + !< Pointer to a Parameter List + + ENTRY => this%DataBase(this%Hash(Key=Key))%GetEntry(Key=Key) + IF (ASSOCIATED(ENTRY)) CALL ENTRY%GetValue(VALUE=VALUE) +END SUBROUTINE ParameterEntryDictionary_Get + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterEntryDictionary_GetPointer(this, Key, VALUE) + + !< Return a Value given the Key + + CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this !< Parameter Entry Dictionary + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE !< Returned value + CLASS(ParameterEntry_t), POINTER :: ENTRY !< Pointer to a Parameter List + INTEGER(I4P) :: Hash !< Hash code corresponding to Key + + ENTRY => this%DataBase(this%Hash(Key=Key))%GetEntry(Key=Key) + IF (ASSOCIATED(ENTRY)) VALUE => ENTRY%PointToValue() +END SUBROUTINE ParameterEntryDictionary_GetPointer + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterEntryDictionary_GetDataBase(this) RESULT(Database) + + !< Return a pointer to a Dictionary Database + + CLASS(ParameterEntryDictionary_t), TARGET, INTENT(IN) :: this + !< Parameter Entry Dictionary + TYPE(ParameterRootEntry_t), POINTER :: Database(:) + !< Dictionary Database + + DataBase => this%Database +END FUNCTION ParameterEntryDictionary_GetDataBase + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterEntryDictionary_Delete(this, Key) + + !< Remove an Entry given a Key + + CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this + !< Parameter Entry Dictionary + CHARACTER(*), INTENT(IN) :: Key + !< String Key + + CALL this%DataBase(this%Hash(Key=Key))%RemoveEntry(Key=Key) +END SUBROUTINE ParameterEntryDictionary_Delete + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterEntryDictionary_Length(this) RESULT(Length) + + !< Return the number of ParameterListEntries contained in the DataBase + + CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this + !< Parameter Entry Dictionary + INTEGER(I4P) :: Length + !< Number of parameters in database + INTEGER(I4P) :: DBIterator + !< Database Iterator index + + Length = 0 + IF (ALLOCATED(this%DataBase)) THEN + DO DBIterator = LBOUND(this%DataBase, dim=1), UBOUND(this%DataBase, dim=1) + Length = Length + this%DataBase(DBIterator)%Length() + END DO + END IF +END FUNCTION ParameterEntryDictionary_Length + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterentryDictionary_Free(this) + + !< Free ParameterListEntries and the DataBase + + CLASS(ParameterEntryDictionary_t), INTENT(INOUT) :: this + !< Parameter Entry Dictionary + INTEGER(I4P) :: DBIterator + !< Database Iterator index + + IF (ALLOCATED(this%DataBase)) THEN + DO DBIterator = LBOUND(this%DataBase, dim=1), UBOUND(this%DataBase, dim=1) + CALL this%DataBase(DBIterator)%Free() + END DO + DEALLOCATE (this%DataBase) + END IF + this%Size = 0_I4P +END SUBROUTINE ParameterEntryDictionary_Free + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterEntryDictionary_Finalize(this) + + !< Destructor procedure + + TYPE(ParameterEntryDictionary_t), INTENT(INOUT) :: this + !< Parameter Entry Dictionary + + CALL this%Free() +END SUBROUTINE ParameterEntryDictionary_Finalize + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterEntryDictionary_Print(this, unit, prefix, iostat, iomsg) + + !< Print the content of the DataBase + + CLASS(ParameterEntryDictionary_t), INTENT(IN) :: this + !< Linked List + 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(:), ALLOCATABLE :: prefd + !< Prefixing string. + INTEGER(I4P) :: iostatd + !< IO error. + CHARACTER(500) :: iomsgd + !< Temporary variable for IO error message. + INTEGER(I4P) :: DBIter + !< Database iterator + + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + IF (ALLOCATED(this%DataBase)) THEN + DO DBIter = LBOUND(this%DataBase, dim=1), UBOUND(this%DataBase, dim=1) + CALL this%DataBase(DBIter)%PRINT(unit=unit, & + prefix=prefd//' ['//TRIM(str(no_sign=.TRUE., n=DBIter))//'] ', & + iostat=iostatd, iomsg=iomsgd) + END DO + END IF + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE ParameterEntryDictionary_Print + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ParameterEntryDictionary diff --git a/src/modules/FPL/src/ParameterList.F90 b/src/modules/FPL/src/ParameterList.F90 new file mode 100644 index 000000000..aec8a6919 --- /dev/null +++ b/src/modules/FPL/src/ParameterList.F90 @@ -0,0 +1,2742 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +#define ParameterList_t ParameterList_ +#define ParameterListIterator_t ParameterListIterator_ + +MODULE ParameterList + +USE ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT +USE ErrorMessages +USE PENF +USE ParameterEntryDictionary +USE ParameterRootEntry +USE ParameterEntry +USE WrapperFactoryListSingleton +USE WrapperFactory +USE DimensionsWrapper +USE DimensionsWrapper0D +USE DimensionsWrapper1D +USE DimensionsWrapper2D +USE DimensionsWrapper3D +USE DimensionsWrapper4D +USE DimensionsWrapper5D +USE DimensionsWrapper6D +USE DimensionsWrapper7D + +IMPLICIT NONE +PRIVATE +PUBLIC :: ParameterList_t +PUBLIC :: ParameterListIterator_t + +!---------------------------------------------------------------------------- +! ParameterList_t +!---------------------------------------------------------------------------- + +TYPE :: ParameterList_t + PRIVATE + TYPE(ParameterEntryDictionary_t) :: Dictionary +CONTAINS + PRIVATE + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set0D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set1D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set2D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set3D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set4D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set5D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set6D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Set7D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get0D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get1D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get2D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get3D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get4D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get5D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get6D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_Get7D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer0D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer1D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer2D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer3D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer4D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer5D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer6D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_GetPointer7D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType0D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType1D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType2D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType3D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType4D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType5D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType6D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_IsOfDataType7D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable0D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable1D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable2D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable3D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable4D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable5D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable6D + PROCEDURE, NON_OVERRIDABLE :: ParameterList_isAssignable7D + GENERIC, PUBLIC :: Set => ParameterList_Set0D, & + ParameterList_Set1D, & + ParameterList_Set2D, & + ParameterList_Set3D, & + ParameterList_Set4D, & + ParameterList_Set5D, & + ParameterList_Set6D, & + ParameterList_Set7D + GENERIC, PUBLIC :: Get => ParameterList_Get0D, & + ParameterList_Get1D, & + ParameterList_Get2D, & + ParameterList_Get3D, & + ParameterList_Get4D, & + ParameterList_Get5D, & + ParameterList_Get6D, & + ParameterList_Get7D + GENERIC, PUBLIC :: GetPointer => ParameterList_GetPointer0D, & + ParameterList_GetPointer1D, & + ParameterList_GetPointer2D, & + ParameterList_GetPointer3D, & + ParameterList_GetPointer4D, & + ParameterList_GetPointer5D, & + ParameterList_GetPointer6D, & + ParameterList_GetPointer7D + GENERIC, PUBLIC :: isOfDataType => ParameterList_IsOfDataType0D, & + ParameterList_IsOfDataType1D, & + ParameterList_IsOfDataType2D, & + ParameterList_IsOfDataType3D, & + ParameterList_IsOfDataType4D, & + ParameterList_IsOfDataType5D, & + ParameterList_IsOfDataType6D, & + ParameterList_IsOfDataType7D + GENERIC, PUBLIC :: isAssignable => ParameterList_isAssignable0D, & + ParameterList_isAssignable1D, & + ParameterList_isAssignable2D, & + ParameterList_isAssignable3D, & + ParameterList_isAssignable4D, & + ParameterList_isAssignable5D, & + ParameterList_isAssignable6D, & + ParameterList_isAssignable7D + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: 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 + 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 + 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 + FINAL :: ParameterList_Finalize +END TYPE ParameterList_t + +!---------------------------------------------------------------------------- +! ParameterListIterator_t +!---------------------------------------------------------------------------- + +TYPE :: ParameterListIterator_t + PRIVATE + TYPE(ParameterRootEntry_t), POINTER :: DataBase(:) => NULL() + TYPE(EntryListIterator_t) :: EntryListIterator + INTEGER(I4P) :: Index = 0 + INTEGER(I4P) :: UpperBound = 0 +CONTAINS + PRIVATE + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Assignment + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get0D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get1D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get2D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get3D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get4D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get5D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get6D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_Get7D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType0D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType1D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType2D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType3D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType4D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType5D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType6D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isOfDataType7D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable0D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable1D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable2D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable3D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable4D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable5D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable6D + PROCEDURE, NON_OVERRIDABLE :: ParameterListIterator_isAssignable7D + PROCEDURE, NON_OVERRIDABLE :: GetEntry => ParameterListIterator_GetEntry + PROCEDURE, NON_OVERRIDABLE :: GetIndex => ParameterListIterator_GetIndex + PROCEDURE, NON_OVERRIDABLE :: PointToValue => & + & ParameterListIterator_PointToValue + PROCEDURE, NON_OVERRIDABLE :: 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 + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetShape => & + & ParameterListIterator_GetShape + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetDimensions => & + & ParameterListIterator_GetDimensions + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: DataSizeInBytes => & + & ParameterListIterator_DataSizeInBytes + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetAsString => & + & ParameterListIterator_GetAsString + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetSubList => & + & ParameterListIterator_GetSubList + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: isSubList => & + & ParameterListIterator_isSubList + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: toString => & + & ParameterListIterator_toString + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: PRINT => ParameterListIterator_Print + PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Free => ParameterListIterator_Free + GENERIC, PUBLIC :: Get => ParameterListIterator_Get0D, & + ParameterListIterator_Get1D, & + ParameterListIterator_Get2D, & + ParameterListIterator_Get3D, & + ParameterListIterator_Get4D, & + ParameterListIterator_Get5D, & + ParameterListIterator_Get6D, & + ParameterListIterator_Get7D + GENERIC, PUBLIC :: isOfDataType => ParameterListIterator_IsOfDataType0D, & + ParameterListIterator_IsOfDataType1D, & + ParameterListIterator_IsOfDataType2D, & + ParameterListIterator_IsOfDataType3D, & + ParameterListIterator_IsOfDataType4D, & + ParameterListIterator_IsOfDataType5D, & + ParameterListIterator_IsOfDataType6D, & + ParameterListIterator_IsOfDataType7D + GENERIC, PUBLIC :: isAssignable => ParameterListIterator_isAssignable0D, & + ParameterListIterator_isAssignable1D, & + ParameterListIterator_isAssignable2D, & + ParameterListIterator_isAssignable3D, & + ParameterListIterator_isAssignable4D, & + ParameterListIterator_isAssignable5D, & + ParameterListIterator_isAssignable6D, & + ParameterListIterator_isAssignable7D + GENERIC, PUBLIC :: ASSIGNMENT(=) => ParameterListIterator_Assignment + FINAL :: ParameterListIterator_Final +END TYPE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +!--------------------------------------------------------------------- +!< Parameter List Procedures +!--------------------------------------------------------------------- + +SUBROUTINE ParameterList_Init(this, Size) + + !< Initialize the dictionary + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size !< Dictionary Size + + CALL this%Free() + IF (PRESENT(Size)) THEN + CALL this%Dictionary%Init(Size=Size) + ELSE + CALL this%Dictionary%Init() + END IF +END SUBROUTINE ParameterList_Init + +!---------------------------------------------------------------------------- +! ParameterList_GetShape +!---------------------------------------------------------------------------- + +FUNCTION ParameterList_GetShape(this, Key, Shape) RESULT(FPLError) + + !< Return an allocatable array with the shape of the contained value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: SHAPE(:) !< Shape of the stored value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + CALL Wrapper%GetShape(Shape) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Unknown Wrapper. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetShape + +FUNCTION ParameterList_GetDimensions(this, Key) RESULT(Dimensions) + + !< Return an integer with the dimensions of the contained value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + INTEGER(I4P) :: Dimensions !< Dimensions of the stored value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + Dimensions = 0 + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + Dimensions = Wrapper%GetDimensions() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Unknown Wrapper. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetDimensions + +SUBROUTINE ParameterList_Free(this) + + !< Free the dictionary + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + + CALL this%Dictionary%Free() +END SUBROUTINE ParameterList_Free + +SUBROUTINE ParameterList_Finalize(this) + + !< Destructor procedure + + TYPE(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + + CALL this%Free() +END SUBROUTINE ParameterList_Finalize + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + + +!> author: Vikas Sharma, Ph. D. +! 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 + !! Parameter List + CHARACTER(*), INTENT(IN) :: Key + !! String Key + INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size + !! Sublist Size + TYPE(ParameterList_t), POINTER :: SublistPointer + !! New Sublist pointer + + ! Internal variables + CLASS(*), POINTER :: Sublist !< New Sublist + + ALLOCATE (ParameterList_t :: SubList) + CALL this%Dictionary%Set(Key=Key, VALUE=Sublist) + SELECT TYPE (SubList) + CLASS is (ParameterList_t) + SublistPointer => SubList + IF (PRESENT(Size)) THEN + CALL Sublist%Init(Size=Size) + ELSE + CALL Sublist%Init(Size=Size) + END IF + END SELECT +END FUNCTION ParameterList_NewSubList + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterList_GetSublist(this, Key, Sublist) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + TYPE(ParameterList_t), POINTER, INTENT(INOUT) :: Sublist !< Wrapper + CLASS(*), POINTER :: VALUE !< Returned pointer to value + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (VALUE) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=VALUE) + IF (ASSOCIATED(VALUE)) THEN + SELECT TYPE (VALUE) + CLASS IS (ParameterList_t) + SubList => VALUE + CLASS DEFAULT + FPLerror = FPLSublistError + CALL msg%Error(txt='Getting [Key="'//Key//'"]: Is not a sublist.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLSublistError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetSubList + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterList_Set0D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the Dictionary + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE !< Unlimited polymorphic Value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set0D + +FUNCTION ParameterList_Set1D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(:) !< Unlimited polymorphic 1D array Value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set1D + +FUNCTION ParameterList_Set2D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(:, :) !< Unlimited polymorphic 2D array value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set2D + +FUNCTION ParameterList_Set3D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(:, :, :) !< Unlimited Polimorphic 3D array Value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set3D + +FUNCTION ParameterList_Set4D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :) !< Unlimited Polymorphic 4D array Value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set4D + +FUNCTION ParameterList_Set5D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) !< Unlimited Polymorphic 5D array Value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set5D + +FUNCTION ParameterList_Set6D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) !< Unlimited Polymorphic 5D array Value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set6D + +FUNCTION ParameterList_Set7D(this, Key, VALUE) RESULT(FPLerror) + + !< Set a Key/Value pair into the DataBase + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) !< Unlimited Polymorphic 7D array Value + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< WrapperFactory + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (WrapperFactory) + NULLIFY (Wrapper) + WrapperFactory => TheWrapperFactoryList%GetFactory(VALUE=VALUE) + IF (ASSOCIATED(WrapperFactory)) THEN + Wrapper => WrapperFactory%Wrap(VALUE=VALUE) + IF (ASSOCIATED(Wrapper)) THEN + CALL this%Dictionary%Set(Key=Key, VALUE=Wrapper) + ELSE + FPLerror = FPLWrapperError + call msg%Error(txt='Setting [Key="'//Key//'"]: Nonexistent wrapper. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Setting [Key="'//Key//'"]: Unsupported data type. Not added to the list.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Set7D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-13 +! summary: Return a scalar Value given the Key + +FUNCTION ParameterList_Get0D(this, Key, VALUE) RESULT(FPLerror) + CLASS(ParameterList_t), INTENT(IN) :: this + !! Parameter List + CHARACTER(*), INTENT(IN) :: Key + !! String Key + CLASS(*), INTENT(INOUT) :: VALUE + !! Returned value + CLASS(*), POINTER :: Wrapper + !! Wrapper + INTEGER(I4P) :: FPLerror + !! Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper0D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get0D + +FUNCTION ParameterList_Get1D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a vector Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(INOUT) :: VALUE(:) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper1D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get1D + +FUNCTION ParameterList_Get2D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a 2D array Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(INOUT) :: VALUE(:, :) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper2D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get2D + +FUNCTION ParameterList_Get3D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a 3D array Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper3D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get3D + +FUNCTION ParameterList_Get4D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a 4D array Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper4D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get4D + +FUNCTION ParameterList_Get5D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a 5D array Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) !< Returned value + CLASS(*), POINTER :: Node !< Pointer to a Parameter List + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper5D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get5D + +FUNCTION ParameterList_Get6D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a 6D array Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper6D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get6D + +FUNCTION ParameterList_Get7D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a 7D array Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper7D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_Get7D + +FUNCTION ParameterList_GetPointer0D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper0D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer0D + +FUNCTION ParameterList_GetPointer1D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:) !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper1D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer1D + +FUNCTION ParameterList_GetPointer2D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :) !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper2D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer2D + +FUNCTION ParameterList_GetPointer3D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :) !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper3D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer3D + +FUNCTION ParameterList_GetPointer4D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :) !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper4D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer4D + +FUNCTION ParameterList_GetPointer5D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :, :) !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper5D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer5D + +FUNCTION ParameterList_GetPointer6D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :, :, :) !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper6D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer6D + +FUNCTION ParameterList_GetPointer7D(this, Key, VALUE) RESULT(FPLerror) + + !< Return a Unlimited polymorphic pointer to a Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER, INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) !< Returned pointer to value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper7D_t) + VALUE => Wrapper%GetPointer() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetPointer7D + +FUNCTION ParameterList_isPresent(this, Key) RESULT(isPresent) + + !< Check if a Key is present at the DataBase + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + LOGICAL :: isPresent !< Boolean flag to check if a Key is present + + isPresent = this%Dictionary%IsPresent(Key=Key) +END FUNCTION ParameterList_isPresent + +FUNCTION ParameterList_isSubList(this, Key) RESULT(isSubList) + + !< Check if a Key is a SubList + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER :: SubListPointer !< Pointer to a SubList + LOGICAL :: isSubList !< Check if is a SubList + + isSubList = .FALSE. + NULLIFY (SubListPointer) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=SubListPointer) + IF (ASSOCIATED(SubListPointer)) THEN + SELECT TYPE (SubListPointer) + CLASS is (ParameterList_t) + isSubList = .TRUE. + END SELECT + END IF +END FUNCTION ParameterList_isSubList + +FUNCTION ParameterList_DataSizeInBytes(this, Key) RESULT(DataSizeInBytes) + + !< Return the data size in bytes of the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes + + DataSizeInBytes = 0 + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + DataSizeInBytes = Wrapper%DataSizeInBytes() + END SELECT + END IF +END FUNCTION ParameterList_DataSizeInBytes + +FUNCTION ParameterList_isOfDataType0D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold) + CLASS is (ParameterList_t) + SELECT TYPE (Mold) + CLASS is (ParameterList_t) + isOfDataType = .TRUE. + END SELECT + END SELECT + END IF +END FUNCTION ParameterList_isOfDataType0D + +FUNCTION ParameterList_isOfDataType1D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold(1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE.; NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1)) + END SELECT + END IF +END FUNCTION ParameterList_isOfDataType1D + +FUNCTION ParameterList_isOfDataType2D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold(1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE.; NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1)) + END SELECT + END IF +END FUNCTION ParameterList_isOfDataType2D + +FUNCTION ParameterList_isOfDataType3D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE.; NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1)) + END SELECT +END FUNCTION ParameterList_isOfDataType3D + +FUNCTION ParameterList_isOfDataType4D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE.; NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterList_isOfDataType4D + +FUNCTION ParameterList_isOfDataType5D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE.; NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterList_isOfDataType5D + +FUNCTION ParameterList_isOfDataType6D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE.; NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterList_isOfDataType6D + +FUNCTION ParameterList_isOfDataType7D(this, Key, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the value associated with Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE.; NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterList_isOfDataType7D + +FUNCTION ParameterList_isAssignable0D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE !< Value to compare with the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper0D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE)) Assignable = .TRUE. + END SELECT + END IF +END FUNCTION ParameterList_isAssignable0D + +FUNCTION ParameterList_isAssignable1D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(1:) !< Value to check against with the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper1D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterList_isAssignable1D + +FUNCTION ParameterList_isAssignable2D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(1:, 1:) !< Value to check against with the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper2D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterList_isAssignable2D + +FUNCTION ParameterList_isAssignable3D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) !< Value to check against with the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper3D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterList_isAssignable3D + +FUNCTION ParameterList_isAssignable4D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) !< Value to check against the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper4D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterList_isAssignable4D + +FUNCTION ParameterList_isAssignable5D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) !< Value to check against the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper5D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterList_isAssignable5D + +FUNCTION ParameterList_isAssignable6D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) !< Value to check against the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper6D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterList_isAssignable6D + +FUNCTION ParameterList_isAssignable7D(this, Key, VALUE) RESULT(Assignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Value to check against the stored variable + LOGICAL :: Assignable !< Boolean flag to check compatibility + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + Assignable = .FALSE. + NULLIFY (Wrapper) + ! Check if present + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper7D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) Assignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterList_isAssignable7D + +SUBROUTINE ParameterList_RemoveEntry(this, Key) + + !< Remove an Entry given a Key + + CLASS(ParameterList_t), INTENT(INOUT) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + + CALL this%Dictionary%Del(Key=Key) +END SUBROUTINE ParameterList_RemoveEntry + +FUNCTION ParameterList_Length(this) RESULT(Length) + + !< Return the number of ParameterListEntries contained in the DataBase + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + INTEGER(I4P) :: Length !< Number of parameters in database + + Length = this%Dictionary%Length() +END FUNCTION ParameterList_Length + +FUNCTION ParameterList_GetIterator(this) RESULT(Iterator) + + !< Return a pointer to a Parameters Iterator + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List Entry Container Type + TYPE(ParameterListIterator_t) :: Iterator !< Parameter List iterator + + CALL Iterator%Init(DataBase=this%Dictionary%GetDataBase()) +END FUNCTION ParameterList_GetIterator + +function ParameterList_GetAsString(this,Key,String,Separator) result(FPLerror) + + !< Return a scalar Value given the Key + + CLASS(ParameterList_t), INTENT(IN) :: this !< Parameter List + CHARACTER(*), INTENT(IN) :: Key !< String Key + CHARACTER(:), ALLOCATABLE, INTENT(INOUT) :: String !< Returned value as string + CHARACTER(1), OPTIONAL, INTENT(IN) :: Separator !< Array values separator + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + CALL this%Dictionary%GetPointer(Key=Key, VALUE=Wrapper) + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + CALL Wrapper%toString(String=String, Separator=Separator) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//Key//'"]: Unknown Wrapper. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//Key//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterList_GetAsString + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ParameterList_Display(this, msg, unitno) + + !< Print the content of the DataBase + + 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 + +!---------------------------------------------------------------------------- +! Print +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-02 +! summary: Print the content of the DataBase + +RECURSIVE SUBROUTINE ParameterList_Print(this, unit, prefix, iostat, iomsg) + CLASS(ParameterList_t), INTENT(IN) :: this + !! Linked List + INTEGER(I4P), OPTIONAL, 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(:), ALLOCATABLE :: prefd + !! Prefixing string. + INTEGER(I4P) :: unitd + !! Logic unit. + INTEGER(I4P) :: iostatd + !! IO error. + CHARACTER(500) :: iomsgd + !! Temporary variable for IO error message. + TYPE(ParameterListIterator_t) :: Iterator + !! Dictionary Iterator + ! + ! Internal variables + ! + CLASS(*), POINTER :: VALUE + ! + ! + ! + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + unitd = OUTPUT_UNIT; IF (PRESENT(unit)) unitd = unit + Iterator = this%GetIterator() + ! + DO WHILE (.NOT. Iterator%HasFinished()) + !! + NULLIFY (VALUE) + !! + VALUE => Iterator%PointToValue() + !! + IF (ASSOCIATED(VALUE)) THEN + !! + SELECT TYPE (VALUE) + !! + CLASS is (DimensionsWrapper_t) + !! + CALL VALUE%PRINT(unit=unitd, & + & prefix=prefd// & + & '['//TRIM(str(no_sign=.TRUE., n=Iterator%GetIndex()))//']'// & + & ' Key = '//Iterator%GetKey()//',', & + & iostat=iostatd, & + & iomsg=iomsgd) + !! + TYPE is (ParameterList_t) + !! + WRITE (unit=unitd, fmt='(A)') prefd// & + & '['//TRIM(str(no_sign=.TRUE., n=Iterator%GetIndex()))//']'// & + & ' Key = '//Iterator%GetKey()//', Data Type = ParameterList' + !! + CALL VALUE%PRINT( & + & unit=unitd, & + & prefix=prefd//'['//TRIM(str(no_sign=.TRUE., & + & n=Iterator%GetIndex()))//'] ', & + & iostat=iostatd, & + & iomsg=iomsgd) + !! + CLASS default + !! + WRITE (unit=unitd, fmt='(A)') prefd// & + & '['//TRIM(str(no_sign=.TRUE., n=Iterator%GetIndex()))//']'// & + & ' Key = '//Iterator%GetKey()//', Data Type = Unknown Data Type!' + !! + END SELECT + END IF + CALL Iterator%Next() + END DO + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE ParameterList_Print + +!--------------------------------------------------------------------- +!< Parameter List Iterator Procedures +!--------------------------------------------------------------------- + +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 + + this%DataBase(0:) => ParameterListIterator%DataBase + this%EntryListIterator = ParameterListIterator%EntryListIterator + this%Index = ParameterListIterator%Index + this%UpperBound = ParameterListIterator%UpperBound +END SUBROUTINE ParameterListIterator_Assignment + +SUBROUTINE ParameterListIterator_Free(this) + + !< Free the dictionary iterator + + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + + this%Index = 0 + this%UpperBound = 0 + NULLIFY (this%DataBase) + CALL this%EntryListIterator%Free() +END SUBROUTINE ParameterListIterator_Free + +SUBROUTINE ParameterListIterator_Final(this) + + !< Free the dictionary iterator + + TYPE(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + + CALL this%Free() +END SUBROUTINE ParameterListIterator_Final + +SUBROUTINE ParameterListIterator_Init(this, DataBase) + + !< Associate the iterator with a dictionary and rewind + !< to the first position + + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + TYPE(ParameterRootEntry_t), TARGET, INTENT(IN) :: DataBase(:) ! Entries database + + CALL this%Free() + this%DataBase(0:) => DataBase(:) + this%Index = -1 + this%UpperBound = SIZE(this%DataBase) + CALL this%Next() +END SUBROUTINE ParameterListIterator_Init + +SUBROUTINE ParameterListIterator_Begin(this) + + !< Rewind the iterator to the first dictionary position + + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + TYPE(ParameterRootEntry_t), POINTER :: DataBase(:) ! Entries database + + DataBase => this%DataBase + CALL this%Init(DataBase) +END SUBROUTINE ParameterListIterator_Begin + +SUBROUTINE ParameterListIterator_End(this) + + !< Fast forward to the last dictionary position (HasFinished = .true.) + + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + + this%Index = this%UpperBound + CALL this%EntryListIterator%Free() +END SUBROUTINE ParameterListIterator_End + +SUBROUTINE ParameterListIterator_NextNotEmptyListIterator(this) + + !< The iterator points to the next associated entry + + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + + CALL this%EntryListIterator%Free() + this%Index = this%Index + 1 + DO WHILE (this%Index < this%UpperBound) + IF (this%DataBase(this%Index)%HasRoot()) THEN + this%EntryListIterator = this%Database(this%Index)%GetIterator() + EXIT + END IF + this%Index = this%Index + 1 + END DO +END SUBROUTINE ParameterListIterator_NextNotEmptyListIterator + +SUBROUTINE ParameterListIterator_Next(this) + + !< The iterator points to the next associated entry + + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + + IF (.NOT. this%HasFinished()) THEN + IF (.NOT. this%EntryListIterator%HasFinished()) THEN + CALL this%EntryListIterator%Next() + ELSE + CALL this%NextNotEmptyListIterator() + END IF + END IF +END SUBROUTINE ParameterListIterator_Next + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterListIterator_GetEntry(this) RESULT(CurrentEntry) + + !< Return the current Entry + + CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator + TYPE(ParameterEntry_t), POINTER :: CurrentEntry ! Current entry + INTEGER(I4P) :: FPLerror !< Error flag + + NULLIFY (CurrentEntry) + CurrentEntry => this%EntryListIterator%GetEntry() + IF (.NOT. ASSOCIATED(CurrentEntry)) THEN + FPLerror = FPLParameterListIteratorError + CALL msg%Error(txt='Current entry not associated. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_GetEntry + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION ParameterListIterator_PointToValue(this) RESULT(VALUE) + + !< Return a pointer to the value stored in the current Entry + + CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator + CLASS(*), POINTER :: VALUE ! Unlimited polymorphic pointer + TYPE(ParameterEntry_t), POINTER :: CurrentEntry ! Current entry + + NULLIFY (CurrentEntry) + NULLIFY (VALUE) + CurrentEntry => this%GetEntry() + IF (ASSOCIATED(CurrentEntry)) VALUE => CurrentEntry%PointToValue() +END FUNCTION ParameterListIterator_PointToValue + +FUNCTION ParameterListIterator_GetKey(this) RESULT(Key) + + !< Return the Key of the current Entry + + CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator + CHARACTER(:), ALLOCATABLE :: Key ! Key + TYPE(ParameterEntry_t), POINTER :: CurrentEntry ! Current entry + + NULLIFY (CurrentEntry) + CurrentEntry => this%GetEntry() + IF (ASSOCIATED(CurrentEntry)) CALL CurrentEntry%GetKey(Key) +END FUNCTION ParameterListIterator_GetKey + +FUNCTION ParameterListIterator_GetIndex(this) RESULT(CurrentIndex) + + !< Return the current Index + + CLASS(ParameterListIterator_t), INTENT(IN) :: this ! Dictionary iterator + INTEGER(I4P) :: CurrentIndex ! Current index + + CurrentIndex = this%Index +END FUNCTION ParameterListIterator_GetIndex + +FUNCTION ParameterListIterator_GetShape(this, Shape) RESULT(FPLError) + + !< Return an allocatable array with the shape of the contained value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: SHAPE(:) !< Shape of the stored value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + CALL Wrapper%GetShape(Shape) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_GetShape + +FUNCTION ParameterListIterator_GetDimensions(this) RESULT(Dimensions) + + !< Return an allocatable array with the shape of the contained value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + INTEGER(I4P) :: Dimensions !< Dimensions of the stored value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + Dimensions = 0 + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + Dimensions = Wrapper%GetDimensions() + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Shape was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_GetDimensions + + function ParameterListIterator_GetAsString(this,String,Separator) result(FPLerror) + + !< Return the current value converted into a string + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CHARACTER(:), ALLOCATABLE, INTENT(INOUT) :: String !< Returned string + CHARACTER(1), OPTIONAL, INTENT(IN) :: Separator !< Array values separator + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + CALL Wrapper%ToString(String=String, Separator=Separator) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_GetAsString + +FUNCTION ParameterListIterator_Get0D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper0D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get0D + +FUNCTION ParameterListIterator_Get1D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE(:) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper1D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get1D + +FUNCTION ParameterListIterator_Get2D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE(:, :) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper2D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get2D + +FUNCTION ParameterListIterator_Get3D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) !< Returned value + TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper3D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get3D + +FUNCTION ParameterListIterator_Get4D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) !< Returned value + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper4D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get4D + +FUNCTION ParameterListIterator_Get5D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) !< Returned value + TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper5D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get5D + +FUNCTION ParameterListIterator_Get6D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) !< Returned value + TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper6D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get6D + +FUNCTION ParameterListIterator_Get7D(this, VALUE) RESULT(FPLerror) + + !< Return the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) !< Returned value + TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper7D_t) + CALL Wrapper%Get(VALUE=VALUE) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Dimensions do not match. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_Get7D + +FUNCTION ParameterListIterator_GetSublist(this, Sublist) RESULT(FPLerror) + + !< Return a pointer to the current sublist + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List + TYPE(ParameterList_t), POINTER, INTENT(INOUT) :: Sublist !< Wrapper + CLASS(*), POINTER :: VALUE !< Returned pointer to value + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (VALUE) + NULLIFY (Sublist) + VALUE => this%PointToValue() + IF (ASSOCIATED(VALUE)) THEN + SELECT TYPE (VALUE) + CLASS is (ParameterList_t) + SubList => VALUE + CLASS Default + FPLerror = FPLSublistError +CALL msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Is not a sublist.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLSublistError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Sublist was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_GetSubList + +FUNCTION ParameterListIterator_isSubList(this) RESULT(isSubList) + + !< Check if a Key is a SubList + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), POINTER :: SubList !< Sublist pointer + LOGICAL :: isSubList !< Check if is a SubList + + isSubList = .FALSE. + NULLIFY (Sublist) + SubList => this%PointToValue() + IF (ASSOCIATED(Sublist)) THEN + SELECT TYPE (Sublist) + CLASS is (ParameterList_t) + isSubList = .TRUE. + END SELECT + END IF +END FUNCTION ParameterListIterator_isSubList + +FUNCTION ParameterListIterator_DataSizeInBytes(this) RESULT(DataSizeInBytes) + + !< Return the data size in bytes of the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + TYPE(ParameterEntry_t), POINTER :: CurrentEntry !< Current entry + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes + + DataSizeInBytes = 0 + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + DataSizeInBytes = Wrapper%DataSizeInBytes() + END SELECT + END IF +END FUNCTION ParameterListIterator_DataSizeInBytes + +FUNCTION ParameterListIterator_isOfDataType0D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType0D + +FUNCTION ParameterListIterator_isOfDataType1D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold(1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1)) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType1D + +FUNCTION ParameterListIterator_isOfDataType2D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold(1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1)) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType2D + +FUNCTION ParameterListIterator_isOfDataType3D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType3D + +FUNCTION ParameterListIterator_isOfDataType4D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType4D + +FUNCTION ParameterListIterator_isOfDataType5D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType5D + +FUNCTION ParameterListIterator_isOfDataType6D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType6D + +FUNCTION ParameterListIterator_isOfDataType7D(this, Mold) RESULT(IsOfDataType) + + !< Check if the data type of Mold agrees with the current value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: Mold(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Mold + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isOfDataType !< Check if has the same type + + isOfDataType = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + isOfDataType = Wrapper%isOfDataType(Mold=Mold(1, 1, 1, 1, 1, 1, 1)) + END SELECT + END IF +END FUNCTION ParameterListIterator_isOfDataType7D + +function ParameterListIterator_isAssignable0D(this,Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper0D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE)) isAssignable = .TRUE. + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable0D + +function ParameterListIterator_isAssignable1D(this,Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE(1:) !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper1D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable1D + +function ParameterListIterator_isAssignable2D(this,Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE(1:, 1:) !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper2D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable2D + + function ParameterListIterator_isAssignable3D(this, Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper3D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable3D + + function ParameterListIterator_isAssignable4D(this, Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper4D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable4D + + function ParameterListIterator_isAssignable5D(this, Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper5D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable5D + + function ParameterListIterator_isAssignable6D(this, Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper6D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable6D + + function ParameterListIterator_isAssignable7D(this, Value) result(isAssignable) + + !< Check if a stored variable is Assignable to Value + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Value + CLASS(*), POINTER :: Wrapper !< Wrapper + LOGICAL :: isAssignable !< Check if is assignable + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) !< Shape of the stored value + + isAssignable = .FALSE. + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper7D_t) + ! Check same data type + IF (Wrapper%isOfDataType(Mold=VALUE(1, 1, 1, 1, 1, 1, 1))) THEN + CALL Wrapper%GetShape(ValueShape) + ! Check right shape + IF (ALL(ValueShape == SHAPE(VALUE))) isAssignable = .TRUE. + END IF + END SELECT + END IF +END FUNCTION ParameterListIterator_isAssignable7D + +FUNCTION ParameterListIterator_toString(this, Separator) RESULT(String) + + !< Return a scalar Value given the Key + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter List Iterator + CHARACTER(1), OPTIONAL, INTENT(IN) :: Separator !< Array values separator + CHARACTER(:), ALLOCATABLE :: String !< Returned value as string + CLASS(*), POINTER :: Wrapper !< Wrapper + INTEGER(I4P) :: FPLerror !< Error flag + + FPLerror = FPLSuccess + NULLIFY (Wrapper) + Wrapper => this%PointToValue() + IF (ASSOCIATED(Wrapper)) THEN + SELECT TYPE (Wrapper) + CLASS is (DimensionsWrapper_t) + CALL Wrapper%toString(String, Separator) + CLASS Default + FPLerror = FPLWrapperError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Unknown Wrapper. Value was not modified.', & + file=__FILE__, line=__LINE__) + END SELECT + ELSE + FPLerror = FPLWrapperFactoryError + call msg%Error(txt='Getting [Key="'//this%GetKey()//'"]: Not present. Value was not modified.', & + file=__FILE__, line=__LINE__) + END IF +END FUNCTION ParameterListIterator_toString + + recursive subroutine ParameterListIterator_Print(this, unit, prefix, iostat, iomsg) + + !< Print the content of the DataBase + + CLASS(ParameterListIterator_t), INTENT(IN) :: this !< Parameter Iterator + INTEGER(I4P), OPTIONAL, 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(:), ALLOCATABLE :: prefd !< Prefixing string. + INTEGER(I4P) :: unitd !< Logic unit. + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + CLASS(*), POINTER :: VALUE !< Unlimited polymorphic value + + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + unitd = OUTPUT_UNIT; IF (PRESENT(unit)) unitd = unit + NULLIFY (VALUE) + VALUE => this%PointToValue() + IF (ASSOCIATED(VALUE)) THEN + SELECT TYPE (VALUE) + CLASS is (DimensionsWrapper_t) + CALL VALUE%PRINT(unit=unitd, & + prefix=prefd// & + '['//TRIM(str(no_sign=.TRUE., n=this%GetIndex()))//']'// & + ' Key = '//this%GetKey()//',', & + iostat=iostatd, & + iomsg=iomsgd) + END SELECT + END IF + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE ParameterListIterator_Print + +FUNCTION ParameterListIterator_HasFinished(this) RESULT(HasFinished) + + !< Check if Iterator has reached the end of the dictionary + + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Dictionary iterator + LOGICAL :: HasFinished + + HasFinished = .FALSE. + IF (this%Index == this%UpperBound) HasFinished = .TRUE. +END FUNCTION ParameterListIterator_HasFinished + +END MODULE ParameterList diff --git a/src/modules/FPL/src/ParameterRootEntry.F90 b/src/modules/FPL/src/ParameterRootEntry.F90 new file mode 100644 index 000000000..11f5cba92 --- /dev/null +++ b/src/modules/FPL/src/ParameterRootEntry.F90 @@ -0,0 +1,350 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module ParameterRootEntry + +USE ParameterEntry +USE PENF, only: I4P, str + +implicit none +private + + type :: ParameterRootEntry_t + private + type(ParameterEntry_t), pointer :: Root => null() + contains + private + procedure, non_overridable :: Init => ParameterRootEntry_Init + procedure, non_overridable, public :: HasRoot => ParameterRootEntry_HasRoot + procedure, non_overridable :: SetRoot => ParameterRootEntry_SetRoot + procedure, non_overridable, public :: GetRoot => ParameterRootEntry_GetRoot + procedure, non_overridable :: NullifyRoot => ParameterRootEntry_NullifyRoot + procedure, non_overridable :: DeallocateRoot => ParameterRootEntry_DeallocateRoot + procedure, non_overridable, public :: GetEntry => ParameterRootEntry_GetEntry + procedure, non_overridable, public :: GetPreviousEntry => ParameterRootEntry_GetPreviousEntry + procedure, non_overridable, public :: Print => ParameterRootEntry_Print + procedure, non_overridable, public :: isPresent => ParameterRootEntry_isPresent + procedure, non_overridable, public :: Length => ParameterRootEntry_Length + procedure, non_overridable, public :: RemoveEntry => ParameterRootEntry_RemoveEntry + procedure, non_overridable, public :: AddEntry => ParameterRootEntry_AddEntry + procedure, non_overridable, public :: GetIterator => ParameterRootEntry_GetIterator + procedure, non_overridable, public :: Free => ParameterRootEntry_Free + final :: ParameterRootEntry_Finalize + end type + + +public :: ParameterRootEntry_T + +contains + + + subroutine ParameterRootEntry_SetRoot(this, Root) + + !< Set the Root of the list + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + class(ParameterEntry_t), pointer, intent(IN) :: Root !< Parameter Entry correspoing to the head of the list + + this%Root => Root + end subroutine ParameterRootEntry_SetRoot + + + function ParameterRootEntry_GetRoot(this) result(Root) + + !< Return a pointer to the Root of the list + + class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry + class(ParameterEntry_t), pointer :: Root !< Parameter Entry correspoing to the head of the list + + Root => this%Root + end function ParameterRootEntry_GetRoot + + + function ParameterRootEntry_HasRoot(this) result(HasRoot) + + !< Return a pointer to the Root of the list + + class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry + logical :: hasRoot !< Check if Root is associated + + hasRoot = associated(this%GetRoot()) + end function ParameterRootEntry_HasRoot + + + subroutine ParameterRootEntry_NullifyRoot(this) + + !< Set the Root of the list + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + + nullify(this%Root) + end subroutine ParameterRootEntry_NullifyRoot + + + subroutine ParameterRootEntry_DeallocateRoot(this) + + !< Set the Root of the list + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + + if(this%HasRoot()) then + call this%Root%Free() + deallocate(this%Root) + endif + end subroutine ParameterRootEntry_DeallocateRoot + + + subroutine ParameterRootEntry_Init(this, Key, Value) + + !< Initialize the Root of the list + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + character(len=*), intent(IN) :: Key !< Key (unique) of the current node. + class(*), pointer, intent(IN) :: Value !< Parameter Entry Value + + if(.not. this%HasRoot()) allocate(ParameterEntry_t::this%Root) + call this%Root%SetKey(Key=Key) + call this%Root%SetValue(Value=Value) + end subroutine ParameterRootEntry_Init + + + function ParameterRootEntry_IsPresent(this, Key) result(isPresent) + + !< Check if a Key is present in the List + + class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry + character(len=*), intent(IN) :: Key !< String Key + logical :: isPresent !< Boolean flag to check if a Key is present + + isPresent = associated(this%GetEntry(Key)) + end function ParameterRootEntry_IsPresent + + + subroutine ParameterRootEntry_AddEntry(this,Key, Value) + + !< Add a new Node if key does not Exist + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + character(len=*), intent(IN) :: Key !< Key (unique) of the current node. + class(*), pointer, intent(IN) :: Value !< Parameter Entry Value + class(ParameterEntry_t), pointer :: NextEntry !< Parameter Entry + class(ParameterEntry_t), pointer :: NewEntry !< New Parameter Entry + character(len=:), allocatable :: NextEntryKey !< Key of the NextEntry + + if(.not. this%HasRoot()) then + call this%Init(Key=Key, Value=Value) + else + NextEntry => this%GetRoot() + do while(associated(NextEntry)) + call NextEntry%GetKey(NExtEntryKey) + if (NextEntryKey/=Key) then + if (.not. NextEntry%hasNext()) then + ! I reached the end of the list + allocate(ParameterEntry_t::NewEntry) + call NewEntry%SetKey(Key=Key) + call NewEntry%SetValue(Value=Value) + call NextEntry%SetNext(NExt=NewEntry) + exit + else + NextEntry => NextEntry%GetNext() + endif + else + call NextEntry%SetValue(Value=Value) + exit + endif + enddo + if(allocated(NextEntryKey)) deallocate(NextEntryKey) + endif + end subroutine ParameterRootEntry_AddEntry + + + subroutine ParameterRootEntry_RemoveEntry(this, Key) + + !< Remove an Entry given a Key + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + character(len=*), intent(IN) :: Key !< String Key + character(len=:), allocatable :: CurrentEntryKey !< Current Entry Key + class(ParameterEntry_t), pointer :: PreviousEntry !< The Previous Entry of a given key + class(ParameterEntry_t), pointer :: CurrentEntry !< Entry of a given key + class(ParameterEntry_t), pointer :: NextEntry !< The Next Entry of a given key + + if(this%HasRoot()) then + CurrentEntry => this%GetRoot() + call CurrentEntry%GetKey(CurrentEntryKey) + if(CurrentEntryKey == Key) then + NextEntry => CurrentEntry%GetNext() + call CurrentEntry%DeallocateKey() + call CurrentEntry%DeallocateValue() + call CurrentEntry%NullifyNext() + deallocate(CurrentEntry) + call this%NullifyRoot() + if(allocated(CurrentEntryKey)) deallocate(CurrentEntryKey) + else + PreviousEntry => this%GetPreviousEntry(Key=Key) + if(associated(PreviousEntry)) then + CurrentEntry => PreviousEntry%GetNext() + NextEntry => CurrentEntry%GetNext() + call CurrentEntry%DeallocateKey() + call CurrentEntry%DeallocateValue() + call CurrentEntry%NullifyNext() + deallocate(CurrentEntry) + call PreviousEntry%NullifyNext() + if(associated(NextEntry)) call PreviousEntry%SetNext(Next=NextEntry) + endif + endif + if(associated(NextEntry)) call this%SetRoot(Root = NextEntry) + endif + end subroutine ParameterRootEntry_RemoveEntry + + + + function ParameterRootEntry_GetEntry(this,Key) result(Entry) + + !< Return a pointer to a ParameterEntry given a Key + + class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry + character(len=*), intent(IN) :: Key !< String Key + class(ParameterEntry_t), pointer :: Entry !< Parameter Entry + character(len=:), allocatable :: EntryKey !< Entry Key + + Entry => this%GetRoot() + do while(associated(Entry)) + call Entry%GetKey(EntryKey) + if (EntryKey==Key) exit + Entry => Entry%GetNext() + enddo + if(allocated(EntryKey)) deallocate(EntryKey) + end function ParameterrootEntry_GetEntry + + + function ParameterRootEntry_GetPreviousEntry(this,Key) result(PreviousEntry) + + !< Return a pointer to the provious node of a Parameter List given a Key + + class(ParameterRootEntry_t), intent(IN) :: this !< Parameter List + character(len=*), intent(IN) :: Key !< String Key + class(ParameterEntry_t), pointer :: PreviousEntry !< Parameter List Entry + class(ParameterEntry_t), pointer :: NextEntry !< Parameter List Next Entry + character(len=:), allocatable :: NExtEntryKey !< NextEntry Key + + PreviousEntry => this%GetRoot() + do while(associated(PreviousEntry)) + if (PreviousEntry%HasNext()) then + NextEntry => PreviousEntry%GetNext() + call NextEntry%GetKey(NextEntryKey) + if (NextEntryKey==Key) then + exit + else + PreviousEntry => NextEntry + endif + else + nullify(PreviousEntry) + exit + endif + enddo + if(allocated(NextEntryKey)) deallocate(NextEntryKey) + end function ParameterRootEntry_GetPreviousEntry + + + function ParameterRootEntry_Length(this) result(Length) + + !< Return the length of the list + + class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry + integer(I4P) :: Length !< Length of the list + type(ParameterEntry_t), pointer :: NextEntry !< Next Parameter Entry + + Length = 0 + NextEntry => this%GetRoot() + do while (associated(NextEntry)) + Length = Length + 1 + NextEntry => NextEntry%GetNext() + enddo + nullify(NextEntry) + end function ParameterRootEntry_Length + + + subroutine ParameterRootEntry_Free(this) + + !< Free the list + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + class(ParameterEntry_t), pointer :: Current !< Current Parameter List Node + class(ParameterEntry_t), pointer :: Next !< Next Parameter List Node + + do while(this%HasRoot()) + Next => this%Root%GetNext() + call this%Root%Free() + call this%DeallocateRoot() + call this%SetRoot(Root=Next) + enddo + end subroutine ParameterRootEntry_Free + + + function ParameterRootEntry_GetIterator(this) result(Iterator) + + !< Free the list + + class(ParameterRootEntry_t), intent(INOUT) :: this !< Parameter Root Entry + type(EntryListIterator_t) :: Iterator !< List iterator + + call Iterator%Init(Entry=this%Root) + end function ParameterRootEntry_GetIterator + + + subroutine ParameterRootEntry_Print(this, unit, prefix, iostat, iomsg) + + !< Print the keys/value pair contained in the parameter list + + class(ParameterRootEntry_t), intent(IN) :: this !< Parameter Root Entry + 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. + integer(I4P) :: iostatd !< IO error. + character(500) :: iomsgd !< Temporary variable for IO error message. + class(ParameterEntry_t), pointer :: NextEntry !< Pointer for scanning the list. + + iostatd = 0 ; iomsgd = ''; prefd = '';if (present(prefix)) prefd = prefix + if(this%HasRoot()) then + NextEntry => this%GetRoot() + do while(associated(NextEntry)) + call NextEntry%Print(unit=unit, prefix=prefix, iostat=iostatd, iomsg=iomsgd ) + NextEntry => NextEntry%GetNext() + enddo + endif + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd + end subroutine ParameterRootEntry_Print + + + subroutine ParameterRootEntry_Finalize(this) + + !< Finalize procedure + + type(ParameterRootEntry_t), intent(INOUT):: this !< Parameter List + + call this%Free() + end subroutine ParameterRootEntry_Finalize + + +end module ParameterRootEntry diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 new file mode 100644 index 000000000..4e0a6e5ff --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper.F90 @@ -0,0 +1,126 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper + +USE PENF, only: I1P, I4P, str + +implicit none +private + + type, abstract :: DimensionsWrapper_t + private + integer(I1P) :: Dimensions = -1 + contains + private + procedure, public :: SetDimensions => DimensionsWrapper_SetDimensions + procedure, public :: GetDimensions => DimensionsWrapper_GetDimensions + procedure, public :: Print => DimensionsWrapper_Print + procedure(DimensionsWrapper_isOfDataType), public, deferred :: isOfDataType + procedure(DimensionsWrapper_DataSizeInBytes), public, deferred :: DataSizeInBytes + procedure(DimensionsWrapper_Free), public, deferred :: Free + procedure(DimensionsWrapper_GetShape), public, deferred :: GetShape + procedure(DimensionsWrapper_toString), public, deferred :: toString + end type + + abstract interface + subroutine DimensionsWrapper_Free(this) + import DimensionsWrapper_t + class(DimensionsWrapper_t), intent(INOUT) :: this + end subroutine + + function DimensionsWrapper_isOfDataType(this, Mold) result(isOfDataType) + import DimensionsWrapper_t + class(DimensionsWrapper_t), intent(IN) :: this + class(*), intent(IN) :: Mold + logical :: isOfDataType + end function + + function DimensionsWrapper_DataSizeInBytes(this) result(DataSizeInBytes) + import DimensionsWrapper_t + import I4P + class(DimensionsWrapper_t), intent(IN) :: this + integer(I4P) :: DataSizeInBytes + end function + + subroutine DimensionsWrapper_GetShape(this, ValueShape) + import DimensionsWrapper_t + import I4P + class(DimensionsWrapper_t), intent(IN) :: this + integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) + end subroutine + + subroutine DimensionsWrapper_toString(this, String, Separator) + import DimensionsWrapper_t + import I4P + class(DimensionsWrapper_t), intent(IN) :: this + character(len=:), allocatable, intent(INOUT) :: String + character(len=1), optional, intent(IN) :: Separator + end subroutine + end interface + +public :: DimensionsWrapper_t + + +contains + + subroutine DimensionsWrapper_SetDimensions(this, Dimensions) + !----------------------------------------------------------------- + !< Set the dimensions of the Value contained in the wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper_t), intent(INOUT) :: this + integer(I1P), intent(IN) :: Dimensions + !----------------------------------------------------------------- + this%Dimensions = Dimensions + end subroutine + + + function DimensionsWrapper_GetDimensions(this) result(Dimensions) + !----------------------------------------------------------------- + !< Get the dimensions of the Value contained in the wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper_t), intent(IN) :: this + !----------------------------------------------------------------- + integer(I1P) :: Dimensions + Dimensions = this%Dimensions + end function + + + subroutine DimensionsWrapper_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Generic Wrapper Print + !----------------------------------------------------------------- + class(DimensionsWrapper_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. + 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)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = -, '//& + ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions())) + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd + end subroutine DimensionsWrapper_Print + +end module DimensionsWrapper diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 new file mode 100644 index 000000000..de115949c --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D + +USE DimensionsWrapper + +implicit none +private + + type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper0D_t + private + contains + procedure(DimensionsWrapper0D_Set), deferred :: Set + procedure(DimensionsWrapper0D_Get), deferred :: Get + procedure(DimensionsWrapper0D_GetPointer), deferred :: GetPointer + end type + + abstract interface + subroutine DimensionsWrapper0D_Set(this, Value) + import DimensionsWrapper0D_t + class(DimensionsWrapper0D_t), intent(INOUT) :: this + class(*), intent(IN) :: Value + end subroutine + + subroutine DimensionsWrapper0D_Get(this, Value) + import DimensionsWrapper0D_t + class(DimensionsWrapper0D_t), intent(IN) :: this + class(*), intent(OUT) :: Value + end subroutine + + function DimensionsWrapper0D_GetPointer(this) result(Value) + import DimensionsWrapper0D_t + class(DimensionsWrapper0D_t), target, intent(IN) :: this + class(*), pointer :: Value + end function + + subroutine DimensionsWrapper0D_GetPolymorphic(this, Value) + import DimensionsWrapper0D_t + class(DimensionsWrapper0D_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value + end subroutine + end interface + +public :: DimensionsWrapper0D_t + +end module DimensionsWrapper0D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 new file mode 100644 index 000000000..7b327415a --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_DLCA.F90 @@ -0,0 +1,219 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_DLCA + +USE DimensionsWrapper0D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_DLCA_t + character(len=:), allocatable :: Value + contains + private + procedure, public :: Set => DimensionsWrapper0D_DLCA_Set + procedure, public :: Get => DimensionsWrapper0D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper0D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper0D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper0D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper0D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper0D_DLCA_toString + procedure, public :: Free => DimensionsWrapper0D_DLCA_Free + procedure, public :: Print => DimensionsWrapper0D_DLCA_Print + final :: DimensionsWrapper0D_DLCA_Final + end type + +public :: DimensionsWrapper0D_DLCA_t + +contains + + + subroutine DimensionsWrapper0D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + type(DimensionsWrapper0D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper0D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + this%Value = Value + class Default + call msg%Warn(txt='Setting value: Expected data type (character(*))',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper0D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + class Default + call msg%Warn(txt='Getting value: Expected data type (character(*))',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper0D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper0D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value + !----------------------------------------------------------------- + allocate(Value, source = this%Value) + end subroutine + + + subroutine DimensionsWrapper0D_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_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 + + + subroutine DimensionsWrapper0D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_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 = DLCA'//& + ', 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_DLCA_Print + + + function DimensionsWrapper0D_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_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_DLCA_DataSizeInBytes + + + subroutine DimensionsWrapper0D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_t), intent(IN) :: this + character(len=:), allocatable, intent(INOUT) :: String + character(len=1), optional, intent(IN) :: Separator + !----------------------------------------------------------------- + String = '' + if(allocated(this%Value)) String = trim(this%Value) + end subroutine + + + function DimensionsWrapper0D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper0D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper0D_DLCA_isOfDataType + +end module DimensionsWrapper0D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 new file mode 100644 index 000000000..adb405985 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I1P.F90 @@ -0,0 +1,218 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_I1P + +USE DimensionsWrapper0D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I1P_t + integer(I1P), allocatable :: Value + contains + private + procedure, public :: Set => DimensionsWrapper0D_I1P_Set + procedure, public :: Get => DimensionsWrapper0D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper0D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper0D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper0D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper0D_I1P_isOfDataType + procedure, public :: toString => DimensionsWrapper0D_I1P_toString + procedure, public :: Free => DimensionsWrapper0D_I1P_Free + procedure, public :: Print => DimensionsWrapper0D_I1P_Print + final :: DimensionsWrapper0D_I1P_Final + end type + +public :: DimensionsWrapper0D_I1P_t + +contains + + + subroutine DimensionsWrapper0D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + type(DimensionsWrapper0D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper0D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper0D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + Value = this%Value + class Default + call msg%Warn(txt='Getting value: Expected data type (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper0D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper0D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value + !----------------------------------------------------------------- + allocate(Value, source = this%Value) + end subroutine + + + subroutine DimensionsWrapper0D_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_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_I1P_DataSizeInBytes + + + function DimensionsWrapper0D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper0D_I1P_isOfDataType + + + subroutine DimensionsWrapper0D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I1P_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 = I1P'//& + ', 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_I1P_Print + + +end module DimensionsWrapper0D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 new file mode 100644 index 000000000..e7a02b1f4 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I2P.F90 @@ -0,0 +1,217 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_I2P + +USE DimensionsWrapper0D +USE PENF, only: I2P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I2P_t + integer(I2P), allocatable :: Value + contains + private + procedure, public :: Set => DimensionsWrapper0D_I2P_Set + procedure, public :: Get => DimensionsWrapper0D_I2P_Get + procedure, public :: GetShape => DimensionsWrapper0D_I2P_GetShape + procedure, public :: GetPointer => DimensionsWrapper0D_I2P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper0D_I2P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I2P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper0D_I2P_isOfDataType + procedure, public :: toString => DimensionsWrapper0D_I2P_toString + procedure, public :: Free => DimensionsWrapper0D_I2P_Free + procedure, public :: Print => DimensionsWrapper0D_I2P_Print + final :: DimensionsWrapper0D_I2P_Final + end type + +public :: DimensionsWrapper0D_I2P_t + +contains + + + subroutine DimensionsWrapper0D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + type(DimensionsWrapper0D_I2P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper0D_I2P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I2P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I2P)) + 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 (I2P)', & + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper0D_I2P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I2P_t), intent(IN) :: this + class(*), intent(OUT) :: Value + !----------------------------------------------------------------- + select type (Value) + type is (integer(I2P)) + Value = this%Value + class Default + call msg%Warn(txt='Getting value: Expected data type (I2P)', & + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper0D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_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 DimensionsWrapper0D_I2P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I2P_t), target, intent(IN) :: this + class(*), pointer :: Value + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper0D_I2P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I2P_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value + !----------------------------------------------------------------- + allocate(Value, source = this%Value) + end subroutine + + + subroutine DimensionsWrapper0D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + class(DimensionsWrapper0D_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 DimensionsWrapper0D_I2P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I2P_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_I2P_DataSizeInBytes + + + function DimensionsWrapper0D_I2P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I2P_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(I2P)) + isOfDataType = .true. + end select + end function DimensionsWrapper0D_I2P_isOfDataType + + + subroutine DimensionsWrapper0D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper0D_I2P_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_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper0D_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 + call this%toString(strvalue) + write(unit=unit,fmt='(A)',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 = '//strvalue + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd + end subroutine DimensionsWrapper0D_I2P_Print + + +end module DimensionsWrapper0D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 new file mode 100644 index 000000000..0220fa6c8 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 @@ -0,0 +1,216 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_I4P + +USE DimensionsWrapper0D +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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 new file mode 100644 index 000000000..bbc8b0a38 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 @@ -0,0 +1,217 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_I8P + +USE DimensionsWrapper0D +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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 new file mode 100644 index 000000000..1ba2b3c05 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 @@ -0,0 +1,218 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_L + +USE DimensionsWrapper0D +USE FPL_Utils +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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 new file mode 100644 index 000000000..ed9329027 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 @@ -0,0 +1,216 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_R4P + +USE DimensionsWrapper0D +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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 new file mode 100644 index 000000000..b93c5d148 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 @@ -0,0 +1,217 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper0D_R8P + +USE DimensionsWrapper0D +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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 new file mode 100644 index 000000000..6b209c52d --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D + +USE DimensionsWrapper + +implicit none +private + + type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper1D_t + private + contains + procedure(DimensionsWrapper1D_Set), deferred :: Set + procedure(DimensionsWrapper1D_Get), deferred :: Get + procedure(DimensionsWrapper1D_GetPointer), deferred :: GetPointer + end type + + abstract interface + subroutine DimensionsWrapper1D_Set(this, Value) + import DimensionsWrapper1D_t + class(DimensionsWrapper1D_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:) + end subroutine + + subroutine DimensionsWrapper1D_Get(this, Value) + import DimensionsWrapper1D_t + class(DimensionsWrapper1D_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:) + end subroutine + + function DimensionsWrapper1D_GetPointer(this) result(Value) + import DimensionsWrapper1D_t + class(DimensionsWrapper1D_t), target, intent(IN) :: this + class(*), pointer :: Value(:) + end function + + subroutine DimensionsWrapper1D_GetPolymorphic(this, Value) + import DimensionsWrapper1D_t + class(DimensionsWrapper1D_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:) + end subroutine + end interface + +public :: DimensionsWrapper1D_t + +end module DimensionsWrapper1D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 new file mode 100644 index 000000000..e4924683f --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_DLCA.F90 @@ -0,0 +1,251 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_DLCA + +USE DimensionsWrapper1D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_DLCA_t + character(len=:), allocatable :: Value(:) + contains + private + procedure, public :: Set => DimensionsWrapper1D_DLCA_Set + procedure, public :: Get => DimensionsWrapper1D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper1D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper1D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper1D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper1D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper1D_DLCA_toString + procedure, public :: Free => DimensionsWrapper1D_DLCA_Free + procedure, public :: Print => DimensionsWrapper1D_DLCA_Print + final :: DimensionsWrapper1D_DLCA_Final + end type + +public :: DimensionsWrapper1D_DLCA_t + +contains + + + subroutine DimensionsWrapper1D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + type(DimensionsWrapper1D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper1D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:) + integer :: err + !----------------------------------------------------------------- +#ifdef __GFORTRAN__ + call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& + file=__FILE__, line=__LINE__ ) +#else + select type (Value) + type is (character(len=*)) + + + allocate(character(len=len(Value))::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 (character(*))',& + file=__FILE__, line=__LINE__ ) + end select +#endif + end subroutine + + + subroutine DimensionsWrapper1D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + call this%GetShape(ValueShape) + if(all(ValueShape == shape(Value))) then + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + 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 (character(*))',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper1D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value(:) + !----------------------------------------------------------------- + Value => this%value + end function + + + subroutine DimensionsWrapper1D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:) + !----------------------------------------------------------------- +! allocate(Value(size(this%Value,dim=1)),source=this%Value) + end subroutine + + + subroutine DimensionsWrapper1D_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 1D + integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = 0 + if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1))*size(this%value) + end function DimensionsWrapper1D_DLCA_DataSizeInBytes + + + function DimensionsWrapper1D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper1D_DLCA_isOfDataType + + + subroutine DimensionsWrapper1D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_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(this%Value(idx)) // Sep + enddo + String = trim(adjustl(String(:len(String)-1))) + endif + end subroutine + + + subroutine DimensionsWrapper1D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper1D_DLCA_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)', advance="no", iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = DLCA'//& + ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& + ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& + ', Value = ' + write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd + end subroutine DimensionsWrapper1D_DLCA_Print + +end module DimensionsWrapper1D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 new file mode 100644 index 000000000..8f52360b3 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I1P.F90 @@ -0,0 +1,227 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_I1P + +USE DimensionsWrapper1D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I1P_t + integer(I1P), allocatable :: Value(:) + contains + private + procedure, public :: Set => DimensionsWrapper1D_I1P_Set + procedure, public :: Get => DimensionsWrapper1D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper1D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper1D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper1D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper1D_I1P_isOfDataType + procedure, public :: toString => DimensionsWrapper1D_I1P_toString + procedure, public :: Free => DimensionsWrapper1D_I1P_Free + procedure, public :: Print => DimensionsWrapper1D_I1P_Print + final :: DimensionsWrapper1D_I1P_Final + end type + +public :: DimensionsWrapper1D_I1P_t + +contains + + + subroutine DimensionsWrapper1D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + type(DimensionsWrapper1D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper1D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:) + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)', & + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper1D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper1D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value(:) + !----------------------------------------------------------------- + Value => this%value + end function + + + subroutine DimensionsWrapper1D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:) + !----------------------------------------------------------------- + allocate(Value(size(this%Value,dim=1)),source=this%Value) + end subroutine + + + subroutine DimensionsWrapper1D_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_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_I1P_DataSizeInBytes + + + function DimensionsWrapper1D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper1D_I1P_isOfDataType + + + subroutine DimensionsWrapper1D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I1P_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 = I1P'//& + ', 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_I1P_Print + +end module DimensionsWrapper1D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 new file mode 100644 index 000000000..ebb27ae12 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I2P.F90 @@ -0,0 +1,225 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_I2P + +USE DimensionsWrapper1D +USE PENF, only: I2P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I2P_t + integer(I2P), allocatable :: Value(:) + contains + private + procedure, public :: Set => DimensionsWrapper1D_I2P_Set + procedure, public :: Get => DimensionsWrapper1D_I2P_Get + procedure, public :: GetShape => DimensionsWrapper1D_I2P_GetShape + procedure, public :: GetPointer => DimensionsWrapper1D_I2P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper1D_I2P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I2P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper1D_I2P_isOfDataType + procedure, public :: toString => DimensionsWrapper1D_I2P_toString + procedure, public :: Free => DimensionsWrapper1D_I2P_Free + procedure, public :: Print => DimensionsWrapper1D_I2P_Print + final :: DimensionsWrapper1D_I2P_Final + end type + +public :: DimensionsWrapper1D_I2P_t + +contains + + + subroutine DimensionsWrapper1D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + type(DimensionsWrapper1D_I2P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper1D_I2P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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)), 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 DimensionsWrapper1D_I2P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 DimensionsWrapper1D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 DimensionsWrapper1D_I2P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic W2apper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I2P_t), target, intent(IN) :: this + class(*), pointer :: Value(:) + !----------------------------------------------------------------- + Value => this%value + end function + + + subroutine DimensionsWrapper1D_I2P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I2P_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:) + !----------------------------------------------------------------- + allocate(Value(size(this%Value,dim=1)),source=this%Value) + end subroutine + + + subroutine DimensionsWrapper1D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 DimensionsWrapper1D_I2P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I2P_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_I2P_DataSizeInBytes + + + function DimensionsWrapper1D_I2P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I2P_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(I2P)) + isOfDataType = .true. + end select + end function DimensionsWrapper1D_I2P_isOfDataType + + + subroutine DimensionsWrapper1D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I2P_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_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 + call this%toString(strvalue) + write(unit=unit,fmt='(A)',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 = '//strvalue + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd + end subroutine DimensionsWrapper1D_I2P_Print + +end module DimensionsWrapper1D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 new file mode 100644 index 000000000..e011507fc --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 @@ -0,0 +1,226 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_I4P + +USE DimensionsWrapper1D +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 = '' + 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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 new file mode 100644 index 000000000..40c8eb64b --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I8P.F90 @@ -0,0 +1,225 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_I8P + +USE DimensionsWrapper1D +USE PENF, only: i4P, I8P , str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I8P_t + integer(I8P), allocatable :: Value(:) + contains + private + procedure, public :: Set => DimensionsWrapper1D_I8P_Set + procedure, public :: Get => DimensionsWrapper1D_I8P_Get + procedure, public :: GetShape => DimensionsWrapper1D_I8P_GetShape + procedure, public :: GetPointer => DimensionsWrapper1D_I8P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper1D_I8P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I8P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper1D_I8P_isOfDataType + procedure, public :: toString => DimensionsWrapper1D_I8P_toString + procedure, public :: Print => DimensionsWrapper1D_I8P_Print + procedure, public :: Free => DimensionsWrapper1D_I8P_Free + final :: DimensionsWrapper1D_I8P_Final + end type + +public :: DimensionsWrapper1D_I8P_t + +contains + + + subroutine DimensionsWrapper1D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + type(DimensionsWrapper1D_I8P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper1D_I8P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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)), 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 DimensionsWrapper1D_I8P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic W2apper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I8P_t), target, intent(IN) :: this + class(*), pointer :: Value(:) + !----------------------------------------------------------------- + Value => this%value + end function + + + subroutine DimensionsWrapper1D_I8P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I8P_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:) + !----------------------------------------------------------------- + allocate(Value(size(this%Value,dim=1)),source=this%Value) + end subroutine + + + subroutine DimensionsWrapper1D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I8P_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_I8P_DataSizeInBytes + + + function DimensionsWrapper1D_I8P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper1D_I8P_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(I8P)) + isOfDataType = .true. + end select + end function DimensionsWrapper1D_I8P_isOfDataType + + + subroutine DimensionsWrapper1D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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, separator=Separator)) + end subroutine + + + subroutine DimensionsWrapper1D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper1D_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 DimensionsWrapper1D_I8P_Print + +end module DimensionsWrapper1D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 new file mode 100644 index 000000000..b6fa86fa3 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 @@ -0,0 +1,235 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_L + +USE DimensionsWrapper1D +USE FPL_Utils +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 new file mode 100644 index 000000000..05f3d5c20 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 @@ -0,0 +1,225 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_R4P + +USE DimensionsWrapper1D +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 = '' + 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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 new file mode 100644 index 000000000..fa590fca8 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 @@ -0,0 +1,225 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper1D_R8P + +USE DimensionsWrapper1D +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 = '' + 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) + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 new file mode 100644 index 000000000..c5efef7e8 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D + +USE DimensionsWrapper + +implicit none +private + + type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper2D_t + private + contains + procedure(DimensionsWrapper2D_Set), deferred :: Set + procedure(DimensionsWrapper2D_Get), deferred :: Get + procedure(DimensionsWrapper2D_GetPointer), deferred :: GetPointer + end type + + abstract interface + subroutine DimensionsWrapper2D_Set(this, Value) + import DimensionsWrapper2D_t + class(DimensionsWrapper2D_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:) + end subroutine + + subroutine DimensionsWrapper2D_Get(this, Value) + import DimensionsWrapper2D_t + class(DimensionsWrapper2D_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:) + end subroutine + + function DimensionsWrapper2D_GetPointer(this) result(Value) + import DimensionsWrapper2D_t + class(DimensionsWrapper2D_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:) + end function + + subroutine DimensionsWrapper2D_GetPolymorphic(this, Value) + import DimensionsWrapper2D_t + class(DimensionsWrapper2D_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:,:) + end subroutine + end interface + +public :: DimensionsWrapper2D_t + +end module DimensionsWrapper2D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 new file mode 100644 index 000000000..1dee149de --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_DLCA.F90 @@ -0,0 +1,257 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_DLCA + +USE DimensionsWrapper2D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_DLCA_t + character(len=:), allocatable :: Value(:,:) + contains + private + procedure, public :: Set => DimensionsWrapper2D_DLCA_Set + procedure, public :: Get => DimensionsWrapper2D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper2D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper2D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper2D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper2D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper2D_DLCA_toString + procedure, public :: Free => DimensionsWrapper2D_DLCA_Free + procedure, public :: Print => DimensionsWrapper2D_DLCA_Print + final :: DimensionsWrapper2D_DLCA_Final + end type + +public :: DimensionsWrapper2D_DLCA_t + +contains + + + subroutine DimensionsWrapper2D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + type(DimensionsWrapper2D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper2D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:) + integer :: err + !----------------------------------------------------------------- +#ifdef __GFORTRAN__ + call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& + file=__FILE__, line=__LINE__ ) +#else + select type (Value) + type is (character(len=*)) + allocate(character(len=len(Value)):: & + 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 (character(*))', & + file=__FILE__, line=__LINE__ ) + end select +#endif + end subroutine + + + subroutine DimensionsWrapper2D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + call this%GetShape(ValueShape) + if(all(ValueShape == shape(Value))) then + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + 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 (character(*))',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper2D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:) + !----------------------------------------------------------------- + Value => this%value + end function + + + subroutine DimensionsWrapper2D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_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_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 2D + integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = 0 + if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1))*size(this%value) + end function DimensionsWrapper2D_DLCA_DataSizeInBytes + + + function DimensionsWrapper2D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper2D_DLCA_isOfDataType + + + subroutine DimensionsWrapper2D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_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(this%Value(idx1,idx2)) // Sep + enddo + enddo + String = trim(adjustl(String(:len(String)-1))) + endif + end subroutine + + + subroutine DimensionsWrapper2D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper2D_DLCA_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 = DLCA'//& + ', 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_DLCA_Print + +end module DimensionsWrapper2D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 new file mode 100644 index 000000000..c1ff48b82 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I1P.F90 @@ -0,0 +1,241 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_I1P + +USE DimensionsWrapper2D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I1P_t + integer(I1P), allocatable :: Value(:,:) + contains + private + procedure, public :: Set => DimensionsWrapper2D_I1P_Set + procedure, public :: Get => DimensionsWrapper2D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper2D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper2D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper2D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper2D_I1P_isOfDataType + procedure, public :: toString => DimensionsWrapper2D_I1P_toString + procedure, public :: Free => DimensionsWrapper2D_I1P_Free + procedure, public :: Print => DimensionsWrapper2D_I1P_Print + final :: DimensionsWrapper2D_I1P_Final + end type + +public :: DimensionsWrapper2D_I1P_t + +contains + + + subroutine DimensionsWrapper2D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + type(DimensionsWrapper2D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper2D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:) + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)', & + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper2D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper2D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:) + !----------------------------------------------------------------- + Value => this%value + end function + + + subroutine DimensionsWrapper2D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_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_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_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_I1P_DataSizeInBytes + + + function DimensionsWrapper2D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper2D_I1P_isOfDataType + + + subroutine DimensionsWrapper2D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I1P_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 = I1P'//& + ', 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_I1P_Print + +end module DimensionsWrapper2D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 new file mode 100644 index 000000000..ab56d2de1 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I2P.F90 @@ -0,0 +1,241 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_I2P + +USE DimensionsWrapper2D +USE PENF, only: I2P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I2P_t + integer(I2P), allocatable :: Value(:,:) + contains + private + procedure, public :: Set => DimensionsWrapper2D_I2P_Set + procedure, public :: Get => DimensionsWrapper2D_I2P_Get + procedure, public :: GetShape => DimensionsWrapper2D_I2P_GetShape + procedure, public :: GetPointer => DimensionsWrapper2D_I2P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper2D_I2P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I2P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper2D_I2P_isOfDataType + procedure, public :: toString => DimensionsWrapper2D_I2P_toString + procedure, public :: Free => DimensionsWrapper2D_I2P_Free + procedure, public :: Print => DimensionsWrapper2D_I2P_Print + final :: DimensionsWrapper2D_I2P_Final + end type + +public :: DimensionsWrapper2D_I2P_t + +contains + + + subroutine DimensionsWrapper2D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + type(DimensionsWrapper2D_I2P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper2D_I2P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_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)), & + 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 DimensionsWrapper2D_I2P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_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 DimensionsWrapper2D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper2D_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 DimensionsWrapper2D_I2P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I2P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:) + !----------------------------------------------------------------- + Value => this%value + end function + + + subroutine DimensionsWrapper2D_I2P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I2P_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 + + + function DimensionsWrapper2D_I2P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I2P_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_I2P_DataSizeInBytes + + + function DimensionsWrapper2D_I2P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I2P_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(I2P)) + isOfDataType = .true. + end select + end function DimensionsWrapper2D_I2P_isOfDataType + + + subroutine DimensionsWrapper2D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + class(DimensionsWrapper2D_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 + + + subroutine DimensionsWrapper2D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper2D_I2P_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_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper2D_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 DimensionsWrapper2D_I2P_Print + +end module DimensionsWrapper2D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 new file mode 100644 index 000000000..a2259c9f2 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 @@ -0,0 +1,240 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_I4P + +USE DimensionsWrapper2D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 new file mode 100644 index 000000000..dec2da4ae --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 @@ -0,0 +1,241 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_I8P + +USE DimensionsWrapper2D +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 + 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 DimensionsWrapper2D_I8P_Print + +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 new file mode 100644 index 000000000..65389e615 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 @@ -0,0 +1,243 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_L + +USE DimensionsWrapper2D +USE FPL_Utils +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 new file mode 100644 index 000000000..6b9f749f5 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 @@ -0,0 +1,241 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_R4P + +USE DimensionsWrapper2D +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 + 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 DimensionsWrapper2D_R4P_Print + +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 new file mode 100644 index 000000000..9d8fbd362 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 @@ -0,0 +1,241 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper2D_R8P + +USE DimensionsWrapper2D +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 + 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 DimensionsWrapper2D_R8P_Print + +end module DimensionsWrapper2D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 new file mode 100644 index 000000000..1d6ebf4a1 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D + +USE DimensionsWrapper + +implicit none +private + + type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper3D_t + private + contains + procedure(DimensionsWrapper3D_Set), deferred :: Set + procedure(DimensionsWrapper3D_Get), deferred :: Get + procedure(DimensionsWrapper3D_GetPointer), deferred :: GetPointer + end type + + abstract interface + subroutine DimensionsWrapper3D_Set(this, Value) + import DimensionsWrapper3D_t + class(DimensionsWrapper3D_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:) + end subroutine + + subroutine DimensionsWrapper3D_Get(this, Value) + import DimensionsWrapper3D_t + class(DimensionsWrapper3D_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:) + end subroutine + + function DimensionsWrapper3D_GetPointer(this) result(Value) + import DimensionsWrapper3D_t + class(DimensionsWrapper3D_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:) + end function + + subroutine DimensionsWrapper3D_GetPolymorphic(this, Value) + import DimensionsWrapper3D_t + class(DimensionsWrapper3D_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:,:,:) + end subroutine + end interface + +public :: DimensionsWrapper3D_t + +end module DimensionsWrapper3D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 new file mode 100644 index 000000000..734281267 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_DLCA.F90 @@ -0,0 +1,261 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_DLCA + +USE DimensionsWrapper3D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_DLCA_t + character(len=:), allocatable :: Value(:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper3D_DLCA_Set + procedure, public :: Get => DimensionsWrapper3D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper3D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper3D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper3D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper3D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper3D_DLCA_toString + procedure, public :: Free => DimensionsWrapper3D_DLCA_Free + procedure, public :: Print => DimensionsWrapper3D_DLCA_Print + final :: DimensionsWrapper3D_DLCA_Final + end type + +public :: DimensionsWrapper3D_DLCA_t + +contains + + + subroutine DimensionsWrapper3D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + type(DimensionsWrapper3D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper3D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:) + integer :: err + !----------------------------------------------------------------- +#ifdef __GFORTRAN__ + call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& + file=__FILE__, line=__LINE__ ) +#else + select type (Value) + type is (character(len=*)) + allocate(character(len=len(Value)):: & + 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 (character(*))', & + file=__FILE__, line=__LINE__ ) + end select +#endif + end subroutine + + + subroutine DimensionsWrapper3D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + call this%GetShape(ValueShape) + if(all(ValueShape == shape(Value))) then + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + 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 (character(*))',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper3D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper3D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_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_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 3D + integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = 0 + if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) + end function DimensionsWrapper3D_DLCA_DataSizeInBytes + + + function DimensionsWrapper3D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper3D_DLCA_isOfDataType + + + subroutine DimensionsWrapper3D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_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(this%Value(idx1,idx2,idx3)) // Sep + enddo + enddo + enddo + String = trim(adjustl(String(:len(String)-1))) + endif + end subroutine + + + subroutine DimensionsWrapper3D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper3D_DLCA_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 = DLCA'//& + ', 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_DLCA_Print + +end module DimensionsWrapper3D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 new file mode 100644 index 000000000..988baecee --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I1P.F90 @@ -0,0 +1,246 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_I1P + +USE DimensionsWrapper3D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I1P_t + integer(I1P), allocatable :: Value(:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper3D_I1P_Set + procedure, public :: Get => DimensionsWrapper3D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper3D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper3D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper3D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper3D_I1P_isOfDataType + procedure, public :: Free => DimensionsWrapper3D_I1P_Free + procedure, public :: toString => DimensionsWrapper3D_I1P_toString + procedure, public :: Print => DimensionsWrapper3D_I1P_Print + final :: DimensionsWrapper3D_I1P_Final + end type + +public :: DimensionsWrapper3D_I1P_t + +contains + + + subroutine DimensionsWrapper3D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + type(DimensionsWrapper3D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper3D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:) + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)', & + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper3D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper3D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper3D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_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_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_t), intent(IN) :: this !< Dimensions wrapper 3D + integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !---------------------------------s-------------------------------- + DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) + end function DimensionsWrapper3D_I1P_DataSizeInBytes + + + function DimensionsWrapper3D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper3D_I1P_isOfDataType + + + subroutine DimensionsWrapper3D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I1P_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 = I1P'//& + ', 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_I1P_Print + +end module DimensionsWrapper3D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 new file mode 100644 index 000000000..56ae614fb --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I2P.F90 @@ -0,0 +1,245 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_I2P + +USE DimensionsWrapper3D +USE PENF, only: I2P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I2P_t + integer(I2P), allocatable :: Value(:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper3D_I2P_Set + procedure, public :: Get => DimensionsWrapper3D_I2P_Get + procedure, public :: GetShape => DimensionsWrapper3D_I2P_GetShape + procedure, public :: GetPointer => DimensionsWrapper3D_I2P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper3D_I2P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I2P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper3D_I2P_isOfDataType + procedure, public :: toString => DimensionsWrapper3D_I2P_toString + procedure, public :: Free => DimensionsWrapper3D_I2P_Free + procedure, public :: Print => DimensionsWrapper3D_I2P_Print + final :: DimensionsWrapper3D_I2P_Final + end type + +public :: DimensionsWrapper3D_I2P_t + +contains + + + subroutine DimensionsWrapper3D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + type(DimensionsWrapper3D_I2P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper3D_I2P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_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)), & + 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 DimensionsWrapper3D_I2P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_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 DimensionsWrapper3D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper3D_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 DimensionsWrapper3D_I2P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I2P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper3D_I2P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper3D_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)), & + source=this%Value) + end subroutine + + + subroutine DimensionsWrapper3D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I2P_t), intent(INOUT) :: this + integer :: err = FPLSuccess + !----------------------------------------------------------------- + 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_I2P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I2P_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_I2P_DataSizeInBytes + + + function DimensionsWrapper3D_I2P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper3D_I2P_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(I2P)) + isOfDataType = .true. + end select + end function DimensionsWrapper3D_I2P_isOfDataType + + + subroutine DimensionsWrapper3D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper3D_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 + !----------------------------------------------------------------- + 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_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper3D_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 DimensionsWrapper3D_I2P_Print + +end module DimensionsWrapper3D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 new file mode 100644 index 000000000..880940708 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 @@ -0,0 +1,245 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_I4P + +USE DimensionsWrapper3D +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 + 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 DimensionsWrapper3D_I4P_Print + +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 new file mode 100644 index 000000000..385d0299e --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 @@ -0,0 +1,245 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_I8P + +USE DimensionsWrapper3D +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 + 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 DimensionsWrapper3D_I8P_Print + +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 new file mode 100644 index 000000000..dad4c1c13 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 @@ -0,0 +1,247 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_L + +USE DimensionsWrapper3D +USE FPL_Utils +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 new file mode 100644 index 000000000..134fc66ab --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 @@ -0,0 +1,244 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_R4P + +USE DimensionsWrapper3D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 new file mode 100644 index 000000000..c349fdf60 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 @@ -0,0 +1,245 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper3D_R8P + +USE DimensionsWrapper3D +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 + 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 DimensionsWrapper3D_R8P_Print + +end module DimensionsWrapper3D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 new file mode 100644 index 000000000..8b62522ff --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D + +USE DimensionsWrapper + +implicit none +private + + type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper4D_t + private + contains + procedure(DimensionsWrapper4D_Set), deferred :: Set + procedure(DimensionsWrapper4D_Get), deferred :: Get + procedure(DimensionsWrapper4D_GetPointer), deferred :: GetPointer + end type + + abstract interface + subroutine DimensionsWrapper4D_Set(this, Value) + import DimensionsWrapper4D_t + class(DimensionsWrapper4D_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:) + end subroutine + + subroutine DimensionsWrapper4D_Get(this, Value) + import DimensionsWrapper4D_t + class(DimensionsWrapper4D_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:) + end subroutine + + function DimensionsWrapper4D_GetPointer(this) result(Value) + import DimensionsWrapper4D_t + class(DimensionsWrapper4D_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:) + end function + + subroutine DimensionsWrapper4D_GetPolymorphic(this, Value) + import DimensionsWrapper4D_t + class(DimensionsWrapper4D_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:,:,:,:) + end subroutine + end interface + +public :: DimensionsWrapper4D_t + +end module DimensionsWrapper4D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 new file mode 100644 index 000000000..fc3f526b9 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_DLCA.F90 @@ -0,0 +1,265 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_DLCA + +USE DimensionsWrapper4D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_DLCA_t + character(len=:), allocatable :: Value(:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper4D_DLCA_Set + procedure, public :: Get => DimensionsWrapper4D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper4D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper4D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper4D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper4D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper4D_DLCA_toString + procedure, public :: Print => DimensionsWrapper4D_DLCA_Print + procedure, public :: Free => DimensionsWrapper4D_DLCA_Free + final :: DimensionsWrapper4D_DLCA_Final + end type + +public :: DimensionsWrapper4D_DLCA_t + +contains + + + subroutine DimensionsWrapper4D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + type(DimensionsWrapper4D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper4D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:) + integer :: err + !----------------------------------------------------------------- +#ifdef __GFORTRAN__ + call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& + file=__FILE__, line=__LINE__ ) +#else + select type (Value) + type is (character(len=*)) + allocate(character(len=len(Value)):: & + 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 (character(*))', & + file=__FILE__, line=__LINE__ ) + end select +#endif + end subroutine + + + subroutine DimensionsWrapper4D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + call this%GetShape(ValueShape) + if(all(ValueShape == shape(Value))) then + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + 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 (character(*))',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper4D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper4D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_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_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_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_DLCA_DataSizeInBytes(this) result(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 4D + integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = 0 + if(allocated(this%value)) DAtaSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value) + end function DimensionsWrapper4D_DLCA_DataSizeInBytes + + + function DimensionsWrapper4D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper4D_DLCA_isOfDataType + + + subroutine DimensionsWrapper4D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_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(this%Value(idx1,idx2,idx3,idx4)) // Sep + enddo + enddo + enddo + enddo + String = trim(adjustl(String(:len(String)-1))) + endif + end subroutine + + + subroutine DimensionsWrapper4D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper4D_DLCA_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 = DLCA'//& + ', 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_DLCA_Print + +end module DimensionsWrapper4D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 new file mode 100644 index 000000000..f0f5a64ed --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I1P.F90 @@ -0,0 +1,249 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_I1P + +USE DimensionsWrapper4D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I1P_t + integer(I1P), allocatable :: Value(:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper4D_I1P_Set + procedure, public :: Get => DimensionsWrapper4D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper4D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper4D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper4D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper4D_I1P_isOfDataType + procedure, public :: toString => DimensionsWrapper4D_I1P_toString + procedure, public :: Print => DimensionsWrapper4D_I1P_Print + procedure, public :: Free => DimensionsWrapper4D_I1P_Free + final :: DimensionsWrapper4D_I1P_Final + end type + +public :: DimensionsWrapper4D_I1P_t + +contains + + + subroutine DimensionsWrapper4D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + type(DimensionsWrapper4D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper4D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:) + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)', & + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper4D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper4D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper4D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_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_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_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_I1P_DataSizeInBytes(this) result(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_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_I1P_DataSizeInBytes + + + function DimensionsWrapper4D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper4D_I1P_isOfDataType + + + subroutine DimensionsWrapper4D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I1P_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 = I1P'//& + ', 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_I1P_Print + +end module DimensionsWrapper4D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 new file mode 100644 index 000000000..12d20c0eb --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I2P.F90 @@ -0,0 +1,249 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_I2P + +USE DimensionsWrapper4D +USE PENF, only: I2P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I2P_t + integer(I2P), allocatable :: Value(:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper4D_I2P_Set + procedure, public :: Get => DimensionsWrapper4D_I2P_Get + procedure, public :: GetShape => DimensionsWrapper4D_I2P_GetShape + procedure, public :: GetPointer => DimensionsWrapper4D_I2P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper4D_I2P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I2P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper4D_I2P_isOfDataType + procedure, public :: toString => DimensionsWrapper4D_I2P_toString + procedure, public :: Print => DimensionsWrapper4D_I2P_Print + procedure, public :: Free => DimensionsWrapper4D_I2P_Free + final :: DimensionsWrapper4D_I2P_Final + end type + +public :: DimensionsWrapper4D_I2P_t + +contains + + + subroutine DimensionsWrapper4D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + type(DimensionsWrapper4D_I2P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper4D_I2P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_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)), & + 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 DimensionsWrapper4D_I2P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I2P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper4D_I2P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper4D_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)), & + source=this%Value) + end subroutine + + + subroutine DimensionsWrapper4D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_DataSizeInBytes(this) result(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I2P_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_I2P_DataSizeInBytes + + + function DimensionsWrapper4D_I2P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper4D_I2P_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(I2P)) + isOfDataType = .true. + end select + end function DimensionsWrapper4D_I2P_isOfDataType + + + subroutine DimensionsWrapper4D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper4D_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 + !----------------------------------------------------------------- + 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_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper4D_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 DimensionsWrapper4D_I2P_Print + +end module DimensionsWrapper4D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 new file mode 100644 index 000000000..9b3ff11dd --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 @@ -0,0 +1,249 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_I4P + +USE DimensionsWrapper4D +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 + 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 DimensionsWrapper4D_I4P_Print + +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 new file mode 100644 index 000000000..a14b3381d --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 @@ -0,0 +1,250 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_I8P + +USE DimensionsWrapper4D +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 + 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 DimensionsWrapper4D_I8P_Print + +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 new file mode 100644 index 000000000..9699fd431 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 @@ -0,0 +1,252 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_L + +USE DimensionsWrapper4D +USE FPL_Utils +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 + 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 DimensionsWrapper4D_L_Print + +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 new file mode 100644 index 000000000..09e494310 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 @@ -0,0 +1,249 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_R4P + +USE DimensionsWrapper4D +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 + 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 DimensionsWrapper4D_R4P_Print + +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 new file mode 100644 index 000000000..400397aed --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 @@ -0,0 +1,249 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper4D_R8P + +USE DimensionsWrapper4D +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 + 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 DimensionsWrapper4D_R8P_Print + +end module DimensionsWrapper4D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 new file mode 100644 index 000000000..7f8c09350 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D + +USE DimensionsWrapper + +implicit none +private + + type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper5D_t + private + contains + procedure(DimensionsWrapper5D_Set), deferred :: Set + procedure(DimensionsWrapper5D_Get), deferred :: Get + procedure(DimensionsWrapper5D_GetPointer), deferred :: GetPointer + end type + + abstract interface + subroutine DimensionsWrapper5D_Set(this, Value) + import DimensionsWrapper5D_t + class(DimensionsWrapper5D_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:) + end subroutine + + subroutine DimensionsWrapper5D_Get(this, Value) + import DimensionsWrapper5D_t + class(DimensionsWrapper5D_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:) + end subroutine + + function DimensionsWrapper5D_GetPointer(this) result(Value) + import DimensionsWrapper5D_t + class(DimensionsWrapper5D_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:) + end function + + subroutine DimensionsWrapper5D_GetPolymorphic(this, Value) + import DimensionsWrapper5D_t + class(DimensionsWrapper5D_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) + end subroutine + end interface + +public :: DimensionsWrapper5D_t + +end module DimensionsWrapper5D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 new file mode 100644 index 000000000..fe6869e80 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_DLCA.F90 @@ -0,0 +1,269 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_DLCA + +USE DimensionsWrapper5D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_DLCA_t + character(len=:), allocatable :: Value(:,:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper5D_DLCA_Set + procedure, public :: Get => DimensionsWrapper5D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper5D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper5D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper5D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper5D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper5D_DLCA_toString + procedure, public :: Print => DimensionsWrapper5D_DLCA_Print + procedure, public :: Free => DimensionsWrapper5D_DLCA_Free + final :: DimensionsWrapper5D_DLCA_Final + end type + +public :: DimensionsWrapper5D_DLCA_t + +contains + + + subroutine DimensionsWrapper5D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + type(DimensionsWrapper5D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper5D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:) + integer :: err + !----------------------------------------------------------------- +#ifdef __GFORTRAN__ + call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& + file=__FILE__, line=__LINE__ ) +#else + select type (Value) + type is (character(len=*)) + allocate(character(len=len(Value)):: & + 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 (character(*))', & + file=__FILE__, line=__LINE__ ) + + end select +#endif + end subroutine + + + subroutine DimensionsWrapper5D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + call this%GetShape(ValueShape) + if(all(ValueShape == shape(Value))) then + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + 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 (DLCA)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper5D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper5D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_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_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 5D + integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = 0 + if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value) + end function DimensionsWrapper5D_DLCA_DataSizeInBytes + + + function DimensionsWrapper5D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper5D_DLCA_isOfDataType + + + subroutine DimensionsWrapper5D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_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(this%Value(idx1,idx2,idx3,idx4,idx5)) // Sep + enddo + enddo + enddo + enddo + enddo + String = String(:len(String)-1) + endif + end subroutine + + + subroutine DimensionsWrapper5D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper5D_DLCA_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 = DLCA'//& + ', 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_DLCA_Print + +end module DimensionsWrapper5D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 new file mode 100644 index 000000000..68109a225 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I1P.F90 @@ -0,0 +1,254 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_I1P + +USE DimensionsWrapper5D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I1P_t + integer(I1P), allocatable :: Value(:,:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper5D_I1P_Set + procedure, public :: Get => DimensionsWrapper5D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper5D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper5D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper5D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper5D_I1P_isOfDataType + procedure, public :: toString => DimensionsWrapper5D_I1P_toString + procedure, public :: Print => DimensionsWrapper5D_I1P_Print + procedure, public :: Free => DimensionsWrapper5D_I1P_Free + final :: DimensionsWrapper5D_I1P_Final + end type + +public :: DimensionsWrapper5D_I1P_t + +contains + + + subroutine DimensionsWrapper5D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + type(DimensionsWrapper5D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper5D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:) + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)', & + file=__FILE__, line=__LINE__ ) + + end select + end subroutine + + + subroutine DimensionsWrapper5D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper5D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper5D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_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_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_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_I1P_DataSizeInBytes + + + function DimensionsWrapper5D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper5D_I1P_isOfDataType + + + subroutine DimensionsWrapper5D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper5D_I1P_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 = I1P'//& + ', 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_I1P_Print + +end module DimensionsWrapper5D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 new file mode 100644 index 000000000..e78e2ed6e --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 @@ -0,0 +1,253 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_I2P + +USE DimensionsWrapper5D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 new file mode 100644 index 000000000..3fbd5a841 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 @@ -0,0 +1,252 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_I4P + +USE DimensionsWrapper5D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 new file mode 100644 index 000000000..af5fc8610 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 @@ -0,0 +1,252 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_I8P + +USE DimensionsWrapper5D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 new file mode 100644 index 000000000..ec5e237e9 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 @@ -0,0 +1,256 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_L + +USE DimensionsWrapper5D +USE FPL_Utils +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 new file mode 100644 index 000000000..b340628f6 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 @@ -0,0 +1,253 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_R4P + +USE DimensionsWrapper5D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 new file mode 100644 index 000000000..3521ff661 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 @@ -0,0 +1,253 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper5D_R8P + +USE DimensionsWrapper5D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 new file mode 100644 index 000000000..a5a10a6f1 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D + +USE DimensionsWrapper + +implicit none +private + + type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper6D_t + private + contains + procedure(DimensionsWrapper6D_Set), deferred :: Set + procedure(DimensionsWrapper6D_Get), deferred :: Get + procedure(DimensionsWrapper6D_GetPointer), deferred :: GetPointer + end type + + abstract interface + subroutine DimensionsWrapper6D_Set(this, Value) + import DimensionsWrapper6D_t + class(DimensionsWrapper6D_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:,:) + end subroutine + + subroutine DimensionsWrapper6D_Get(this, Value) + import DimensionsWrapper6D_t + class(DimensionsWrapper6D_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:,:) + end subroutine + + function DimensionsWrapper6D_GetPointer(this) result(Value) + import DimensionsWrapper6D_t + class(DimensionsWrapper6D_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:,:) + end function + + subroutine DimensionsWrapper6D_GetPolymorphic(this, Value) + import DimensionsWrapper6D_t + class(DimensionsWrapper6D_t), intent(IN) :: this + class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) + end subroutine + end interface + +public :: DimensionsWrapper6D_t + +end module DimensionsWrapper6D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 new file mode 100644 index 000000000..dff63c7dc --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_DLCA.F90 @@ -0,0 +1,273 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_DLCA + +USE DimensionsWrapper6D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_DLCA_t + character(len=:), allocatable :: Value(:,:,:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper6D_DLCA_Set + procedure, public :: Get => DimensionsWrapper6D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper6D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper6D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper6D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper6D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper6D_DLCA_toString + procedure, public :: Print => DimensionsWrapper6D_DLCA_Print + procedure, public :: Free => DimensionsWrapper6D_DLCA_Free + final :: DimensionsWrapper6D_DLCA_Final + end type + +public :: DimensionsWrapper6D_DLCA_t + +contains + + + subroutine DimensionsWrapper6D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + type(DimensionsWrapper6D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper6D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:,:) + integer :: err + !----------------------------------------------------------------- +#ifdef __GFORTRAN__ + call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& + file=__FILE__, line=__LINE__ ) +#else + select type (Value) + type is (character(len=*)) + allocate(character(len=len(Value)):: & + 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 (character(*))', & + file=__FILE__, line=__LINE__ ) + + end select +#endif + end subroutine + + + subroutine DimensionsWrapper6D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + call this%GetShape(ValueShape) + if(all(ValueShape == shape(Value))) then + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + 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 (DLCA)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper6D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper6D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_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_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_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_DLCA_DataSizeInBytes(this) result(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 6D + integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = 0 + if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value) + end function DimensionsWrapper6D_DLCA_DataSizeInBytes + + + function DimensionsWrapper6D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper6D_DLCA_isOfDataType + + + subroutine DimensionsWrapper6D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_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(this%Value(idx1,idx2,idx3,idx4,idx5,idx6)) // Sep + enddo + enddo + enddo + enddo + enddo + enddo + String = String(:len(String)-1) + endif + end subroutine + + + subroutine DimensionsWrapper6D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper6D_DLCA_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 = DLCA'//& + ', 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_DLCA_Print + +end module DimensionsWrapper6D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 new file mode 100644 index 000000000..a7abfd629 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I1P.F90 @@ -0,0 +1,257 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_I1P + +USE DimensionsWrapper6D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I1P_t + integer(I1P), allocatable :: Value(:,:,:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper6D_I1P_Set + procedure, public :: Get => DimensionsWrapper6D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper6D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper6D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper6D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper6D_I1P_isOfDataType + procedure, public :: toString => DimensionsWrapper6D_I1P_toString + procedure, public :: Print => DimensionsWrapper6D_I1P_Print + procedure, public :: Free => DimensionsWrapper6D_I1P_Free + final :: DimensionsWrapper6D_I1P_Final + end type + +public :: DimensionsWrapper6D_I1P_t + +contains + + + subroutine DimensionsWrapper6D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + type(DimensionsWrapper6D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper6D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:,:) + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)', & + file=__FILE__, line=__LINE__ ) + + end select + end subroutine + + + subroutine DimensionsWrapper6D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper6D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper6D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_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_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_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_I1P_DataSizeInBytes(this) result(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_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_I1P_DataSizeInBytes + + + function DimensionsWrapper6D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper6D_I1P_isOfDataType + + + subroutine DimensionsWrapper6D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper6D_I1P_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 = I1P'//& + ', 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_I1P_Print + +end module DimensionsWrapper6D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 new file mode 100644 index 000000000..7d1841fdc --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 @@ -0,0 +1,257 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_I2P + +USE DimensionsWrapper6D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 new file mode 100644 index 000000000..c91f3141b --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 @@ -0,0 +1,257 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_I4P + +USE DimensionsWrapper6D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 new file mode 100644 index 000000000..754a73cdc --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 @@ -0,0 +1,258 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_I8P + +USE DimensionsWrapper6D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 new file mode 100644 index 000000000..657218d52 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 @@ -0,0 +1,260 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_L + +USE DimensionsWrapper6D +USE FPL_Utils +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) + 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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 new file mode 100644 index 000000000..c5f84b200 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 @@ -0,0 +1,257 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_R4P + +USE DimensionsWrapper6D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 new file mode 100644 index 000000000..a9864c4a6 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 @@ -0,0 +1,257 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper6D_R8P + +USE DimensionsWrapper6D +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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 new file mode 100644 index 000000000..1f1bf25f4 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 @@ -0,0 +1,64 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D + +USE DimensionsWrapper + +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 + + 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 + + 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 + +public :: DimensionsWrapper7D_t + +end module DimensionsWrapper7D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 new file mode 100644 index 000000000..5403abece --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_DLCA.F90 @@ -0,0 +1,276 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_DLCA + +USE DimensionsWrapper7D +USE PENF, only: I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_DLCA_t + character(len=:), allocatable :: Value(:,:,:,:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper7D_DLCA_Set + procedure, public :: Get => DimensionsWrapper7D_DLCA_Get + procedure, public :: GetShape => DimensionsWrapper7D_DLCA_GetShape + procedure, public :: GetPointer => DimensionsWrapper7D_DLCA_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper7D_DLCA_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_DLCA_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper7D_DLCA_isOfDataType + procedure, public :: toString => DimensionsWrapper7D_DLCA_toString + procedure, public :: Print => DimensionsWrapper7D_DLCA_Print + procedure, public :: Free => DimensionsWrapper7D_DLCA_Free + final :: DimensionsWrapper7D_DLCA_Final + end type + +public :: DimensionsWrapper7D_DLCA_t + +contains + + + subroutine DimensionsWrapper7D_DLCA_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + type(DimensionsWrapper7D_DLCA_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper7D_DLCA_Set(this, Value) + !----------------------------------------------------------------- + !< Set DLCA Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:,:,:) + integer :: err + !----------------------------------------------------------------- +#ifdef __GFORTRAN__ + call msg%Warn(txt='Setting value: Array of deferred length allocatable arrays not supported in Gfortran)',& + file=__FILE__, line=__LINE__ ) +#else + select type (Value) + type is (character(len=*)) + allocate(character(len=len(Value)):: & + 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 (character(*))', & + file=__FILE__, line=__LINE__ ) + end select +#endif + end subroutine + + + subroutine DimensionsWrapper7D_DLCA_Get(this, Value) + !----------------------------------------------------------------- + !< Get deferred length character array Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (character(len=*)) + call this%GetShape(ValueShape) + if(all(ValueShape == shape(Value))) then + if(len(Value) >= len(this%Value)) then + Value = this%Value + else + call msg%Warn(txt='Getting value: Not enought length ('// & + trim(str(no_sign=.true.,n=len(Value)))//'<'// & + trim(str(no_sign=.true.,n=len(this%Value)))//')',& + file=__FILE__, line=__LINE__ ) + endif + 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 (character(*))',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper7D_DLCA_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_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_DLCA_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper7D_DLCA_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_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_DLCA_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_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_DLCA_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_t), intent(IN) :: this !< Dimensions wrapper 7D + integer(I4P) :: dAtaSizeInBytes !< Data size in bytes + !----------------------------------------------------------------- + DataSizeInBytes = 0 + if(allocated(this%value)) DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) + end function DimensionsWrapper7D_DLCA_DataSizeInBytes + + + function DimensionsWrapper7D_DLCA_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_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 (character(len=*)) + isOfDataType = .true. + end select + end function DimensionsWrapper7D_DLCA_isOfDataType + + + subroutine DimensionsWrapper7D_DLCA_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_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(this%Value(idx1,idx2,idx3,idx4,idx5,idx6,idx7)) // Sep + enddo + enddo + enddo + enddo + enddo + enddo + enddo + String = String(:len(String)-1) + endif + end subroutine + + + subroutine DimensionsWrapper7D_DLCA_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper7D_DLCA_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 = DLCA'//& + ', 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_DLCA_Print + +end module DimensionsWrapper7D_DLCA diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 new file mode 100644 index 000000000..898342d08 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I1P.F90 @@ -0,0 +1,260 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_I1P + +USE DimensionsWrapper7D +USE PENF, only: I1P, I4P, str, byte_size +USE ErrorMessages + +implicit none +private + + type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I1P_t + integer(I1P), allocatable :: Value(:,:,:,:,:,:,:) + contains + private + procedure, public :: Set => DimensionsWrapper7D_I1P_Set + procedure, public :: Get => DimensionsWrapper7D_I1P_Get + procedure, public :: GetShape => DimensionsWrapper7D_I1P_GetShape + procedure, public :: GetPointer => DimensionsWrapper7D_I1P_GetPointer + procedure, public :: GetPolymorphic => DimensionsWrapper7D_I1P_GetPolymorphic + procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I1P_DataSizeInBytes + procedure, public :: isOfDataType => DimensionsWrapper7D_I1P_isOfDataType + procedure, public :: toString => DimensionsWrapper7D_I1P_toString + procedure, public :: Print => DimensionsWrapper7D_I1P_Print + procedure, public :: Free => DimensionsWrapper7D_I1P_Free + final :: DimensionsWrapper7D_I1P_Final + end type + +public :: DimensionsWrapper7D_I1P_t + +contains + + + subroutine DimensionsWrapper7D_I1P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + type(DimensionsWrapper7D_I1P_t), intent(INOUT) :: this + !----------------------------------------------------------------- + call this%Free() + end subroutine + + + subroutine DimensionsWrapper7D_I1P_Set(this, Value) + !----------------------------------------------------------------- + !< Set I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_t), intent(INOUT) :: this + class(*), intent(IN) :: Value(:,:,:,:,:,:,:) + integer :: err + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)', & + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper7D_I1P_Get(this, Value) + !----------------------------------------------------------------- + !< Get I1P Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_t), intent(IN) :: this + class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) + integer(I4P), allocatable :: ValueShape(:) + !----------------------------------------------------------------- + select type (Value) + type is (integer(I1P)) + 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 (I1P)',& + file=__FILE__, line=__LINE__ ) + end select + end subroutine + + + subroutine DimensionsWrapper7D_I1P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_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_I1P_GetPointer(this) result(Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_t), target, intent(IN) :: this + class(*), pointer :: Value(:,:,:,:,:,:,:) + !----------------------------------------------------------------- + Value => this%Value + end function + + + subroutine DimensionsWrapper7D_I1P_GetPolymorphic(this, Value) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_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_I1P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_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_I1P_DataSizeInBytes(this) result(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_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_I1P_DataSizeInBytes + + + function DimensionsWrapper7D_I1P_isOfDataType(this, Mold) result(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_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(I1P)) + isOfDataType = .true. + end select + end function DimensionsWrapper7D_I1P_isOfDataType + + + subroutine DimensionsWrapper7D_I1P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_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_I1P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + class(DimensionsWrapper7D_I1P_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 = I1P'//& + ', 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_I1P_Print + +end module DimensionsWrapper7D_I1P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 new file mode 100644 index 000000000..b86dc8c82 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 @@ -0,0 +1,260 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_I2P + +USE DimensionsWrapper7D +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) + 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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 new file mode 100644 index 000000000..32f371693 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 @@ -0,0 +1,260 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_I4P + +USE DimensionsWrapper7D +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) + 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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 new file mode 100644 index 000000000..a6cbcaa18 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 @@ -0,0 +1,260 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_I8P + +USE DimensionsWrapper7D +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) + 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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 new file mode 100644 index 000000000..08dc231a5 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 @@ -0,0 +1,262 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_L + +USE DimensionsWrapper7D +USE FPL_Utils +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 + !----------------------------------------------------------------- + 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) + 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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 new file mode 100644 index 000000000..cbd5cc5a9 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 @@ -0,0 +1,260 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_R4P + +USE DimensionsWrapper7D +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) + 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 + 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 diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 new file mode 100644 index 000000000..90c0581ad --- /dev/null +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 @@ -0,0 +1,259 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DimensionsWrapper7D_R8P + +USE DimensionsWrapper7D +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) + 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 + 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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 new file mode 100644 index 000000000..c146d848f --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/DLACWrapperFactory.F90 @@ -0,0 +1,354 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module DLCAWrapperFactory + +USE PENF, only: I1P +USE WrapperFactory +USE DimensionsWrapper +USE DimensionsWrapper0D_DLCA +USE DimensionsWrapper1D_DLCA +USE DimensionsWrapper2D_DLCA +USE DimensionsWrapper3D_DLCA +USE DimensionsWrapper4D_DLCA +USE DimensionsWrapper5D_DLCA +USE DimensionsWrapper6D_DLCA +USE DimensionsWrapper7D_DLCA + +implicit none +private + + type, extends(WrapperFactory_t) :: DLCAWrapperFactory_t + private + + contains + procedure :: Wrap0D => DLCAWrapperFactory_Wrap0D + procedure :: Wrap1D => DLCAWrapperFactory_Wrap1D + procedure :: Wrap2D => DLCAWrapperFactory_Wrap2D + procedure :: Wrap3D => DLCAWrapperFactory_Wrap3D + procedure :: Wrap4D => DLCAWrapperFactory_Wrap4D + procedure :: Wrap5D => DLCAWrapperFactory_Wrap5D + procedure :: Wrap6D => DLCAWrapperFactory_Wrap6D + procedure :: Wrap7D => DLCAWrapperFactory_Wrap7D + procedure :: UnWrap0D => DLCAWrapperFactory_UnWrap0D + procedure :: UnWrap1D => DLCAWrapperFactory_UnWrap1D + procedure :: UnWrap2D => DLCAWrapperFactory_UnWrap2D + procedure :: UnWrap3D => DLCAWrapperFactory_UnWrap3D + procedure :: UnWrap4D => DLCAWrapperFactory_UnWrap4D + procedure :: UnWrap5D => DLCAWrapperFactory_UnWrap5D + procedure :: UnWrap6D => DLCAWrapperFactory_UnWrap6D + procedure :: UnWrap7D => DLCAWrapperFactory_UnWrap7D + procedure, public :: hasSameType => DLCAWrapperFactory_hasSameType + end type + + type(DLCAWrapperFactory_t), public, save :: WrapperFactoryDLCA + !$OMP THREADPRIVATE(WrapperFactoryDLCA) + +contains + + function DLCAWrapperFactory_hasSameType(this, Value) result(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + logical :: hasSameType + !----------------------------------------------------------------- + hasSameType = .false. + select type(Value) + type is (character(len=*)) + hasSameType = .true. + end select + end function DLCAWrapperFactory_hasSameType + + + function DLCAWrapperFactory_Wrap0D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 0D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value)) then + allocate(DimensionsWrapper0D_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=0_I1P) + select type (Wrapper) + type is(DimensionsWrapper0D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap0D + + + function DLCAWrapperFactory_Wrap1D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 1D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1))) then + allocate(DimensionsWrapper1D_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=1_I1P) + select type (Wrapper) + type is(DimensionsWrapper1D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap1D + + + function DLCAWrapperFactory_Wrap2D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 2D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:,1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1,1))) then + allocate(DimensionsWrapper2D_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=2_I1P) + select type (Wrapper) + type is(DimensionsWrapper2D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap2D + + + function DLCAWrapperFactory_Wrap3D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 3D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_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_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=3_I1P) + select type (Wrapper) + type is(DimensionsWrapper3D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap3D + + + function DLCAWrapperFactory_Wrap4D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 4D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_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_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=4_I1P) + select type (Wrapper) + type is(DimensionsWrapper4D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap4D + + + function DLCAWrapperFactory_Wrap5D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 5D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_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_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=5_I1P) + select type (Wrapper) + type is(DimensionsWrapper5D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap5D + + + function DLCAWrapperFactory_Wrap6D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 6D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_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_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=6_I1P) + select type (Wrapper) + type is(DimensionsWrapper6D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap6D + + + function DLCAWrapperFactory_Wrap7D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create DLCA 7D Wrapper + !----------------------------------------------------------------- + class(DLCAWrapperFactory_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_DLCA_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=7_I1P) + select type (Wrapper) + type is(DimensionsWrapper7D_DLCA_t) + call Wrapper%Set(Value=Value) + end select + endif + end function DLCAWrapperFactory_Wrap7D + + + subroutine DLCAWrapperFactory_UnWrap0D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 0D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper0D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine DLCAWrapperFactory_UnWrap1D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 1D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper1D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine DLCAWrapperFactory_UnWrap2D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 2D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper2D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine DLCAWrapperFactory_UnWrap3D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 3D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper3D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine DLCAWrapperFactory_UnWrap4D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 4D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper4D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine DLCAWrapperFactory_UnWrap5D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 5D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper5D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine DLCAWrapperFactory_UnWrap6D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 6D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper6D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine DLCAWrapperFactory_UnWrap7D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the DLCA 7D Wrapped Value + !----------------------------------------------------------------- + class(DLCAWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper7D_DLCA_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + +end module DLCAWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 new file mode 100644 index 000000000..303f2b216 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I1PWrapperFactory.F90 @@ -0,0 +1,354 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module I1PWrapperFactory + +USE WrapperFactory +USE PENF, only: I1P +USE DimensionsWrapper +USE DimensionsWrapper0D_I1P +USE DimensionsWrapper1D_I1P +USE DimensionsWrapper2D_I1P +USE DimensionsWrapper3D_I1P +USE DimensionsWrapper4D_I1P +USE DimensionsWrapper5D_I1P +USE DimensionsWrapper6D_I1P +USE DimensionsWrapper7D_I1P + +implicit none +private + + type, extends(WrapperFactory_t) :: I1PWrapperFactory_t + private + + contains + procedure :: Wrap0D => I1PWrapperFactory_Wrap0D + procedure :: Wrap1D => I1PWrapperFactory_Wrap1D + procedure :: Wrap2D => I1PWrapperFactory_Wrap2D + procedure :: Wrap3D => I1PWrapperFactory_Wrap3D + procedure :: Wrap4D => I1PWrapperFactory_Wrap4D + procedure :: Wrap5D => I1PWrapperFactory_Wrap5D + procedure :: Wrap6D => I1PWrapperFactory_Wrap6D + procedure :: Wrap7D => I1PWrapperFactory_Wrap7D + procedure :: UnWrap0D => I1PWrapperFactory_UnWrap0D + procedure :: UnWrap1D => I1PWrapperFactory_UnWrap1D + procedure :: UnWrap2D => I1PWrapperFactory_UnWrap2D + procedure :: UnWrap3D => I1PWrapperFactory_UnWrap3D + procedure :: UnWrap4D => I1PWrapperFactory_UnWrap4D + procedure :: UnWrap5D => I1PWrapperFactory_UnWrap5D + procedure :: UnWrap6D => I1PWrapperFactory_UnWrap6D + procedure :: UnWrap7D => I1PWrapperFactory_UnWrap7D + procedure, public :: hasSameType => I1PWrapperFactory_hasSameType + end type + + type(I1PWrapperFactory_t), save, public :: WrapperFactoryI1P + !$OMP THREADPRIVATE(WrapperFactoryI1P) + +contains + + function I1PWrapperFactory_hasSameType(this, Value) result(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + logical :: hasSameType + !----------------------------------------------------------------- + hasSameType = .false. + select type(Value) + type is (integer(I1P)) + hasSameType = .true. + end select + end function I1PWrapperFactory_hasSameType + + + function I1PWrapperFactory_Wrap0D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 0D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value)) then + allocate(DimensionsWrapper0D_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=0_I1P) + select type (Wrapper) + type is(DimensionsWrapper0D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap0D + + + function I1PWrapperFactory_Wrap1D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 1D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1))) then + allocate(DimensionsWrapper1D_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=1_I1P) + select type (Wrapper) + type is(DimensionsWrapper1D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap1D + + + function I1PWrapperFactory_Wrap2D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 2D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:,1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1,1))) then + allocate(DimensionsWrapper2D_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=2_I1P) + select type (Wrapper) + type is(DimensionsWrapper2D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap2D + + + function I1PWrapperFactory_Wrap3D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 3D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_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_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=3_I1P) + select type (Wrapper) + type is(DimensionsWrapper3D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap3D + + + function I1PWrapperFactory_Wrap4D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 4D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_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_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=4_I1P) + select type (Wrapper) + type is(DimensionsWrapper4D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap4D + + + function I1PWrapperFactory_Wrap5D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 5D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_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_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=5_I1P) + select type (Wrapper) + type is(DimensionsWrapper5D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap5D + + + function I1PWrapperFactory_Wrap6D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 6D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_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_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=6_I1P) + select type (Wrapper) + type is(DimensionsWrapper6D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap6D + + + function I1PWrapperFactory_Wrap7D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I1P 7D Wrapper + !----------------------------------------------------------------- + class(I1PWrapperFactory_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_I1P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=7_I1P) + select type (Wrapper) + type is(DimensionsWrapper7D_I1P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I1PWrapperFactory_Wrap7D + + + subroutine I1PWrapperFactory_UnWrap0D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 0D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper0D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I1PWrapperFactory_UnWrap1D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 1D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper1D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I1PWrapperFactory_UnWrap2D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 2D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper2D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I1PWrapperFactory_UnWrap3D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 3D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper3D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I1PWrapperFactory_UnWrap4D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 4D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper4D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I1PWrapperFactory_UnWrap5D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 5D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper5D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I1PWrapperFactory_UnWrap6D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 6D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper6D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I1PWrapperFactory_UnWrap7D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I1P 7D Wrapped Value + !----------------------------------------------------------------- + class(I1PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper7D_I1P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + +end module I1PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 new file mode 100644 index 000000000..cebb80c3f --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 @@ -0,0 +1,353 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module I2PWrapperFactory + +USE WrapperFactory +USE PENF, only: I1P, I2P +USE DimensionsWrapper +USE DimensionsWrapper0D_I2P +USE DimensionsWrapper1D_I2P +USE DimensionsWrapper2D_I2P +USE DimensionsWrapper3D_I2P +USE DimensionsWrapper4D_I2P +USE DimensionsWrapper5D_I2P +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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 new file mode 100644 index 000000000..be2999f64 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 @@ -0,0 +1,353 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module I4PWrapperFactory + +USE WrapperFactory +USE PENF, only: I1P, I4P +USE DimensionsWrapper +USE DimensionsWrapper0D_I4P +USE DimensionsWrapper1D_I4P +USE DimensionsWrapper2D_I4P +USE DimensionsWrapper3D_I4P +USE DimensionsWrapper4D_I4P +USE DimensionsWrapper5D_I4P +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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 new file mode 100644 index 000000000..a63dfe521 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I8PWrapperFactory.F90 @@ -0,0 +1,353 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module I8PWrapperFactory + +USE WrapperFactory +USE PENF, only: I1P, I8P +USE DimensionsWrapper +USE DimensionsWrapper0D_I8P +USE DimensionsWrapper1D_I8P +USE DimensionsWrapper2D_I8P +USE DimensionsWrapper3D_I8P +USE DimensionsWrapper4D_I8P +USE DimensionsWrapper5D_I8P +USE DimensionsWrapper6D_I8P +USE DimensionsWrapper7D_I8P + +implicit none +private + + type, extends(WrapperFactory_t) :: I8PWrapperFactory_t + private + + contains + procedure :: Wrap0D => I8PWrapperFactory_Wrap0D + procedure :: Wrap1D => I8PWrapperFactory_Wrap1D + procedure :: Wrap2D => I8PWrapperFactory_Wrap2D + procedure :: Wrap3D => I8PWrapperFactory_Wrap3D + procedure :: Wrap4D => I8PWrapperFactory_Wrap4D + procedure :: Wrap5D => I8PWrapperFactory_Wrap5D + procedure :: Wrap6D => I8PWrapperFactory_Wrap6D + procedure :: Wrap7D => I8PWrapperFactory_Wrap7D + procedure :: UnWrap0D => I8PWrapperFactory_UnWrap0D + procedure :: UnWrap1D => I8PWrapperFactory_UnWrap1D + procedure :: UnWrap2D => I8PWrapperFactory_UnWrap2D + procedure :: UnWrap3D => I8PWrapperFactory_UnWrap3D + procedure :: UnWrap4D => I8PWrapperFactory_UnWrap4D + procedure :: UnWrap5D => I8PWrapperFactory_UnWrap5D + procedure :: UnWrap6D => I8PWrapperFactory_UnWrap6D + procedure :: UnWrap7D => I8PWrapperFactory_UnWrap7D + procedure, public :: hasSameType => I8PWrapperFactory_hasSameType + end type + + type(I8PWrapperFactory_t), save, public :: WrapperFactoryI8P + !$OMP THREADPRIVATE(WrapperFactoryI8P) + +contains + + function I8PWrapperFactory_hasSameType(this, Value) result(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + logical :: hasSameType + !----------------------------------------------------------------- + hasSameType = .false. + select type(Value) + type is (integer(I8P)) + hasSameType = .true. + end select + end function I8PWrapperFactory_hasSameType + + + function I8PWrapperFactory_Wrap0D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 0D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value)) then + allocate(DimensionsWrapper0D_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=0_I1P) + select type (Wrapper) + type is(DimensionsWrapper0D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap0D + + + function I8PWrapperFactory_Wrap1D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 1D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1))) then + allocate(DimensionsWrapper1D_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=1_I1P) + select type (Wrapper) + type is(DimensionsWrapper1D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap1D + + + function I8PWrapperFactory_Wrap2D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 2D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:,1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1,1))) then + allocate(DimensionsWrapper2D_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=2_I1P) + select type (Wrapper) + type is(DimensionsWrapper2D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap2D + + + function I8PWrapperFactory_Wrap3D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 3D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_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_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=3_I1P) + select type (Wrapper) + type is(DimensionsWrapper3D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap3D + + + function I8PWrapperFactory_Wrap4D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 4D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_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_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=4_I1P) + select type (Wrapper) + type is(DimensionsWrapper4D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap4D + + + function I8PWrapperFactory_Wrap5D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 5D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_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_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=5_I1P) + select type (Wrapper) + type is(DimensionsWrapper5D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap5D + + + function I8PWrapperFactory_Wrap6D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 6D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_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_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=6_I1P) + select type (Wrapper) + type is(DimensionsWrapper6D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap6D + + + function I8PWrapperFactory_Wrap7D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create I8P 7D Wrapper + !----------------------------------------------------------------- + class(I8PWrapperFactory_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_I8P_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=7_I1P) + select type (Wrapper) + type is(DimensionsWrapper7D_I8P_t) + call Wrapper%Set(Value=Value) + end select + endif + end function I8PWrapperFactory_Wrap7D + + + subroutine I8PWrapperFactory_UnWrap0D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 0D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper0D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I8PWrapperFactory_UnWrap1D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 1D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper1D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I8PWrapperFactory_UnWrap2D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 2D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper2D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I8PWrapperFactory_UnWrap3D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 3D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper3D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I8PWrapperFactory_UnWrap4D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 4D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper4D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I8PWrapperFactory_UnWrap5D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 5D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper5D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I8PWrapperFactory_UnWrap6D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 6D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper6D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine I8PWrapperFactory_UnWrap7D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the I8P 7D Wrapped Value + !----------------------------------------------------------------- + class(I8PWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper7D_I8P_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + +end module I8PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 new file mode 100644 index 000000000..d21dd42c1 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/LWrapperFactory.F90 @@ -0,0 +1,353 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module LWrapperFactory + +USE PENF, only: I1P +USE WrapperFactory +USE DimensionsWrapper +USE DimensionsWrapper0D_L +USE DimensionsWrapper1D_L +USE DimensionsWrapper2D_L +USE DimensionsWrapper3D_L +USE DimensionsWrapper4D_L +USE DimensionsWrapper5D_L +USE DimensionsWrapper6D_L +USE DimensionsWrapper7D_L + +implicit none +private + + type, extends(WrapperFactory_t) :: LWrapperFactory_t + private + + contains + procedure :: Wrap0D => LWrapperFactory_Wrap0D + procedure :: Wrap1D => LWrapperFactory_Wrap1D + procedure :: Wrap2D => LWrapperFactory_Wrap2D + procedure :: Wrap3D => LWrapperFactory_Wrap3D + procedure :: Wrap4D => LWrapperFactory_Wrap4D + procedure :: Wrap5D => LWrapperFactory_Wrap5D + procedure :: Wrap6D => LWrapperFactory_Wrap6D + procedure :: Wrap7D => LWrapperFactory_Wrap7D + procedure :: UnWrap0D => LWrapperFactory_UnWrap0D + procedure :: UnWrap1D => LWrapperFactory_UnWrap1D + procedure :: UnWrap2D => LWrapperFactory_UnWrap2D + procedure :: UnWrap3D => LWrapperFactory_UnWrap3D + procedure :: UnWrap4D => LWrapperFactory_UnWrap4D + procedure :: UnWrap5D => LWrapperFactory_UnWrap5D + procedure :: UnWrap6D => LWrapperFactory_UnWrap6D + procedure :: UnWrap7D => LWrapperFactory_UnWrap7D + procedure, public :: hasSameType => LWrapperFactory_hasSameType + end type + + type(LWrapperFactory_t), save, public :: WrapperFactoryL + !$OMP THREADPRIVATE(WrapperFactoryL) + +contains + + function LWrapperFactory_hasSameType(this, Value) result(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + logical :: hasSameType + !----------------------------------------------------------------- + hasSameType = .false. + select type(Value) + type is (logical) + hasSameType = .true. + end select + end function LWrapperFactory_hasSameType + + + function LWrapperFactory_Wrap0D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 0D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value)) then + allocate(DimensionsWrapper0D_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=0_I1P) + select type (Wrapper) + type is(DimensionsWrapper0D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap0D + + + function LWrapperFactory_Wrap1D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 1D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1))) then + allocate(DimensionsWrapper1D_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=1_I1P) + select type (Wrapper) + type is(DimensionsWrapper1D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap1D + + + function LWrapperFactory_Wrap2D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 2D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(1:,1:) + class(DimensionsWrapper_t), pointer :: Wrapper + !----------------------------------------------------------------- + if(this%hasSameType(Value(1,1))) then + allocate(DimensionsWrapper2D_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=2_I1P) + select type (Wrapper) + type is(DimensionsWrapper2D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap2D + + + function LWrapperFactory_Wrap3D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 3D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_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_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=3_I1P) + select type (Wrapper) + type is(DimensionsWrapper3D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap3D + + + function LWrapperFactory_Wrap4D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 4D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_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_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=4_I1P) + select type (Wrapper) + type is(DimensionsWrapper4D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap4D + + + function LWrapperFactory_Wrap5D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 5D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_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_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=5_I1P) + select type (Wrapper) + type is(DimensionsWrapper5D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap5D + + + function LWrapperFactory_Wrap6D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 6D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_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_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=6_I1P) + select type (Wrapper) + type is(DimensionsWrapper6D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap6D + + + function LWrapperFactory_Wrap7D(this, Value) result(Wrapper) + !----------------------------------------------------------------- + !< Create L 7D Wrapper + !----------------------------------------------------------------- + class(LWrapperFactory_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_L_t::Wrapper) + call Wrapper%SetDimensions(Dimensions=7_I1P) + select type (Wrapper) + type is(DimensionsWrapper7D_L_t) + call Wrapper%Set(Value=Value) + end select + endif + end function LWrapperFactory_Wrap7D + + + subroutine LWrapperFactory_UnWrap0D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 0D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper0D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine LWrapperFactory_UnWrap1D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 1D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper1D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine LWrapperFactory_UnWrap2D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 2D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper2D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine LWrapperFactory_UnWrap3D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 3D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper3D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine LWrapperFactory_UnWrap4D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 4D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper4D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine LWrapperFactory_UnWrap5D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 5D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper5D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine LWrapperFactory_UnWrap6D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 6D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper6D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + + + subroutine LWrapperFactory_UnWrap7D(this, Wrapper, Value) + !----------------------------------------------------------------- + !< Return the L 7D Wrapped Value + !----------------------------------------------------------------- + class(LWrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) + !----------------------------------------------------------------- + select type (Wrapper) + type is(DimensionsWrapper7D_L_t) + call Wrapper%Get(Value = Value) + end select + end subroutine + +end module LWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 new file mode 100644 index 000000000..f58934d4d --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 @@ -0,0 +1,353 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module R4PWrapperFactory + +USE WrapperFactory +USE PENF, only: I1P, R4P +USE DimensionsWrapper +USE DimensionsWrapper0D_R4P +USE DimensionsWrapper1D_R4P +USE DimensionsWrapper2D_R4P +USE DimensionsWrapper3D_R4P +USE DimensionsWrapper4D_R4P +USE DimensionsWrapper5D_R4P +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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 new file mode 100644 index 000000000..92bcab984 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 @@ -0,0 +1,353 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module R8PWrapperFactory + +USE WrapperFactory +USE PENF, only: I1P, R8P +USE DimensionsWrapper +USE DimensionsWrapper0D_R8P +USE DimensionsWrapper1D_R8P +USE DimensionsWrapper2D_R8P +USE DimensionsWrapper3D_R8P +USE DimensionsWrapper4D_R8P +USE DimensionsWrapper5D_R8P +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 diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 new file mode 100644 index 000000000..113c4c7c1 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/WrapperFactory.F90 @@ -0,0 +1,172 @@ +module WrapperFactory + +USE DimensionsWrapper + +implicit none +private + + type, abstract :: WrapperFactory_t + private + + contains + private + procedure(WrapperFactory_Wrap0D), public, deferred :: Wrap0D + procedure(WrapperFactory_Wrap1D), public, deferred :: Wrap1D + procedure(WrapperFactory_Wrap2D), public, deferred :: Wrap2D + procedure(WrapperFactory_Wrap3D), public, deferred :: Wrap3D + procedure(WrapperFactory_Wrap4D), public, deferred :: Wrap4D + procedure(WrapperFactory_Wrap5D), public, deferred :: Wrap5D + procedure(WrapperFactory_Wrap6D), public, deferred :: Wrap6D + procedure(WrapperFactory_Wrap7D), public, deferred :: Wrap7D + procedure(WrapperFactory_hasSameType), public, deferred :: hasSameType + generic, public :: Wrap => Wrap0D, & + Wrap1D, & + Wrap2D, & + Wrap3D, & + Wrap4D, & + Wrap5D, & + Wrap6D, & + Wrap7D + end type + + abstract interface + function WrapperFactory_hasSameType(this, Value) result(hasSameType) + import WrapperFactory_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + logical :: hasSameType + end function + + function WrapperFactory_Wrap0D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + function WrapperFactory_Wrap1D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(:) + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + function WrapperFactory_Wrap2D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(:,:) + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + function WrapperFactory_Wrap3D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(:,:,:) + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + function WrapperFactory_Wrap4D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(:,:,:,:) + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + function WrapperFactory_Wrap5D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(:,:,:,:,:) + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + function WrapperFactory_Wrap6D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(:,:,:,:,:,:) + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + function WrapperFactory_Wrap7D(this, Value) result(Wrapper) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(*), intent(IN) :: Value(:,:,:,:,:,:,:) + class(DimensionsWrapper_t), pointer :: Wrapper + end function + + subroutine WrapperFactory_UnWrap0D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value + end subroutine + + subroutine WrapperFactory_UnWrap1D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:) + end subroutine + + subroutine WrapperFactory_UnWrap2D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:) + end subroutine + + subroutine WrapperFactory_UnWrap3D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:) + end subroutine + + subroutine WrapperFactory_UnWrap4D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:) + end subroutine + + subroutine WrapperFactory_UnWrap5D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:) + end subroutine + + subroutine WrapperFactory_UnWrap6D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:) + end subroutine + + subroutine WrapperFactory_UnWrap7D(this, Wrapper, Value) + import WrapperFactory_t + import DimensionsWrapper_t + class(WrapperFactory_t), intent(IN) :: this + class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper + class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) + end subroutine + + end interface + +public :: WrapperFactory_t + +end module WrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 b/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 new file mode 100644 index 000000000..724c1f9f7 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactoryList.F90 @@ -0,0 +1,418 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +MODULE WrapperFactoryList + +USE PENF, ONLY: I4P +USE WrapperFactory + +IMPLICIT NONE +PRIVATE + +TYPE, PUBLIC :: WrapperFactoryList_t + PRIVATE + CHARACTER(:), ALLOCATABLE :: Key + CLASS(WrapperFactory_t), POINTER :: VALUE => NULL() + TYPE(WrapperFactoryList_t), POINTER :: Next => NULL() +CONTAINS + PRIVATE + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Init => WrapperFactoryList_Init + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: HasNext => WrapperFactoryList_HasNext + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: SetNext => WrapperFactoryList_SetNext + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetNext => WrapperFactoryList_GetNext + procedure, non_overridable, public :: NullifyNext => WrapperFactoryList_NullifyNext + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: HasKey => WrapperFactoryList_HasKey + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: SetKey => WrapperFactoryList_SetKey + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetKey => WrapperFactoryList_GetKey + procedure, non_overridable, public :: DeallocateKey => WrapperFactoryList_DeallocateKey + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: HasValue => WrapperFactoryList_HasValue + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: SetValue => WrapperFactoryList_SetValue + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetValue => WrapperFactoryList_GetValue + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Free => WrapperFactoryList_Free + procedure, non_overridable, public :: AddWrapperFactory => WrapperFactoryList_AddWrapperFactory + PROCEDURE, NON_OVERRIDABLE, PUBLIC :: PRINT => WrapperFactoryList_Print + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory0D + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory1D + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory2D + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory3D + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory4D + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory5D + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory6D + PROCEDURE, NON_OVERRIDABLE :: WrapperFactoryList_GetFactory7D + GENERIC, PUBLIC :: GetFactory => WrapperFactoryList_GetFactory0D, & + WrapperFactoryList_GetFactory1D, & + WrapperFactoryList_GetFactory2D, & + WrapperFactoryList_GetFactory3D, & + WrapperFactoryList_GetFactory4D, & + WrapperFactoryList_GetFactory5D, & + WrapperFactoryList_GetFactory6D, & + WrapperFactoryList_GetFactory7D + FINAL :: WrapperFactoryList_Finalize +END TYPE WrapperFactoryList_t + +CONTAINS + +SUBROUTINE WrapperFactoryList_Init(this) + !----------------------------------------------------------------- + !< Initialize the node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + !----------------------------------------------------------------- + IF (ALLOCATED(this%Key)) DEALLOCATE (this%Key) + NULLIFY (this%VALUE) + NULLIFY (this%Next) +END SUBROUTINE WrapperFactoryList_Init + +FUNCTION WrapperFactoryList_HasNext(this) RESULT(hasNext) + !----------------------------------------------------------------- + !< Check if Next is associated for the current Node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + LOGICAL :: hasNext !< Check if Next is associated + !----------------------------------------------------------------- + hasNext = ASSOCIATED(this%Next) +END FUNCTION WrapperFactoryList_HasNext + +SUBROUTINE WrapperFactoryList_SetNext(this, Next) + !----------------------------------------------------------------- + !< Set the pointer to the Next node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + CLASS(WrapperFactoryList_t), TARGET, INTENT(IN) :: Next !< Pointer to Next + !----------------------------------------------------------------- + this%Next => Next +END SUBROUTINE WrapperFactoryList_SetNext + +FUNCTION WrapperFactoryList_GetNext(this) RESULT(Next) + !----------------------------------------------------------------- + !< Return a pointer to the Next node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(WrapperFactoryList_t), POINTER :: Next !< Pointer to Next + !----------------------------------------------------------------- + NULLIFY (Next) + IF (this%HasNext()) Next => this%Next +END FUNCTION WrapperFactoryList_GetNext + +SUBROUTINE WrapperFactoryList_NullifyNext(this) + !----------------------------------------------------------------- + !< Nullify Next + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + !----------------------------------------------------------------- + NULLIFY (this%Next) +END SUBROUTINE WrapperFactoryList_NullifyNext + +FUNCTION WrapperFactoryList_HasKey(this) RESULT(hasKey) + !----------------------------------------------------------------- + !< Check if Key is allocated for the current Node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + LOGICAL :: hasKey !< Check if Key is associated + !----------------------------------------------------------------- + hasKey = ALLOCATED(this%Key) +END FUNCTION WrapperFactoryList_HasKey + +SUBROUTINE WrapperFactoryList_SetKey(this, Key) + !----------------------------------------------------------------- + !< Check if Next is associated for the current Node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + CHARACTER(len=*), INTENT(IN) :: Key !< Key + !----------------------------------------------------------------- + this%Key = Key +END SUBROUTINE WrapperFactoryList_SetKey + +FUNCTION WrapperFactoryList_GetKey(this) RESULT(Key) + !----------------------------------------------------------------- + !< Check if Next is associated for the current Node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CHARACTER(len=:), ALLOCATABLE :: Key !< Key + !----------------------------------------------------------------- + IF (this%HasKey()) Key = this%Key +END FUNCTION WrapperFactoryList_GetKey + +SUBROUTINE WrapperFactoryList_DeallocateKey(this) + !----------------------------------------------------------------- + !< Deallocate Key if allocated + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + !----------------------------------------------------------------- + IF (this%HasKey()) DEALLOCATE (this%Key) +END SUBROUTINE WrapperFactoryList_DeallocateKey + +FUNCTION WrapperFactoryList_HasValue(this) RESULT(hasValue) + !----------------------------------------------------------------- + !< Check if Value is allocated for the current Node + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + LOGICAL :: hasValue !< Check if Value is allocated + !----------------------------------------------------------------- + hasValue = ASSOCIATED(this%VALUE) +END FUNCTION WrapperFactoryList_HasValue + +SUBROUTINE WrapperFactoryList_SetValue(this, VALUE) + !----------------------------------------------------------------- + !< Return a concrete WrapperFactory + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + CLASS(WrapperFactory_t), TARGET, INTENT(IN) :: VALUE !< Concrete WrapperFactory + !----------------------------------------------------------------- + this%VALUE => VALUE +END SUBROUTINE WrapperFactoryList_SetValue + +SUBROUTINE WrapperFactoryList_GetValue(this, VALUE) + !----------------------------------------------------------------- + !< Return a concrete WrapperFactory + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(WrapperFactory_t), POINTER, INTENT(OUT) :: VALUE !< Concrete WrapperFactory pointer + !----------------------------------------------------------------- + NULLIFY (VALUE) + IF (this%HasValue()) VALUE => this%VALUE +END SUBROUTINE WrapperFactoryList_GetValue + +RECURSIVE SUBROUTINE WrapperFactoryList_Free(this) + !----------------------------------------------------------------- + !< Free the list + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + CLASS(WrapperFactoryList_t), POINTER :: Next !< Wrapper Factory List Node + !----------------------------------------------------------------- + IF (this%HasNext()) THEN + Next => this%GetNext() + CALL Next%Free() + DEALLOCATE (Next) + NULLIFY (Next) + END IF + IF (this%HasKey()) DEALLOCATE (this%Key) + NULLIFY (this%Next) + NULLIFY (this%VALUE) +END SUBROUTINE WrapperFactoryList_Free + +RECURSIVE SUBROUTINE WrapperFactoryList_Finalize(this) + !----------------------------------------------------------------- + !< Finalize procedure + !----------------------------------------------------------------- + TYPE(WrapperFactoryList_t), INTENT(INOUT) :: this !< Wrapper Factory List + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE WrapperFactoryList_Finalize + + recursive subroutine WrapperFactoryList_AddWrapperFactory(this,Key, WrapperFactory) + !----------------------------------------------------------------- + !< Add a new Node if key does not Exist + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_T), INTENT(INOUT) :: this !< Wrapper Factory List + CHARACTER(len=*), INTENT(IN) :: Key !< Key (unique) of the current node. + CLASS(WrapperFactory_t), TARGET, INTENT(IN) :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + IF (this%HasKey()) THEN + IF (this%GetKey() /= Key) THEN + IF (.NOT. this%hasNext()) THEN + ALLOCATE (WrapperFactoryList_t :: this%Next) + CALL this%Next%AddWrapperFactory(Key=Key, WrapperFactory=WrapperFactory) + ELSE + CALL this%Next%AddWrapperFactory(Key=Key, WrapperFactory=WrapperFactory) + END IF + ELSE + CALL this%SetValue(VALUE=WrapperFactory) + END IF + ELSE + CALL this%SetKey(Key=Key) + CALL this%SetValue(VALUE=WrapperFactory) + END IF +END SUBROUTINE WrapperFactoryList_AddWrapperFactory + + recursive function WrapperFactoryList_GetFactory0D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE)) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory0D + + recursive function WrapperFactoryList_GetFactory1D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE(1:) !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE(1))) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory1D + + recursive function WrapperFactoryList_GetFactory2D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE(1:, 1:) !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1))) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory2D + + recursive function WrapperFactoryList_GetFactory3D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1))) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory3D + + recursive function WrapperFactoryList_GetFactory4D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1))) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory4D + + recursive function WrapperFactoryList_GetFactory5D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1, 1))) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory5D + + recursive function WrapperFactoryList_GetFactory6D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1, 1, 1))) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory6D + + recursive function WrapperFactoryList_GetFactory7D(this, Value) result(WrapperFactory) + !----------------------------------------------------------------- + !< Return a WrapperFactory given a value + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), INTENT(IN) :: this !< Wrapper Factory List + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) !< Polymorphic Mold + CLASS(WrapperFactory_t), POINTER :: WrapperFactory !< Wrapper Factory + !----------------------------------------------------------------- + NULLIFY (WrapperFactory) + IF (this%HasKey() .AND. this%HasValue()) THEN + IF (this%VALUE%HasSameType(VALUE=VALUE(1, 1, 1, 1, 1, 1, 1))) THEN + WrapperFactory => this%VALUE + ELSEIF (this%HasNext()) THEN + WrapperFactory => this%Next%GetFactory(VALUE=VALUE) + END IF + END IF +END FUNCTION WrapperFactoryList_GetFactory7D + +SUBROUTINE WrapperFactoryList_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print the keys contained in the list + !----------------------------------------------------------------- + CLASS(WrapperFactoryList_t), TARGET, INTENT(IN) :: this !< Wrapper Factory List + 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. + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + CLASS(WrapperFactoryList_T), POINTER :: Node !< Pointer for scanning the list. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + Node => this + WRITE (*, fmt='(A)') prefd//' WRAPPER FACTORY LIST KEYS:' + DO WHILE (Node%HasKey()) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//' Key = '//Node%GetKey() + IF (Node%HasNExt()) THEN + Node => Node%GetNext() + ELSE + EXIT + END IF + END DO + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE WrapperFactoryList_Print + +END MODULE WrapperFactoryList diff --git a/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 b/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 new file mode 100644 index 000000000..23cf3a4c6 --- /dev/null +++ b/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 @@ -0,0 +1,60 @@ +!----------------------------------------------------------------- +! FPL (Fortran Parameter List) +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Javier Principe and Víctor Sande. +! All rights reserved. +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 3.0 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with this library. +!----------------------------------------------------------------- + +module WrapperFactoryListSingleton + +USE WrapperFactoryList +USE DLCAWrapperFactory +USE I1PWrapperFactory +USE I2PWrapperFactory +USE I4PWrapperFactory +USE I8PWrapperFactory +USE LWrapperFactory +USE R4PWrapperFactory +USE R8PWrapperFactory + +implicit none +private + + type(WrapperFactoryList_t), save :: TheWrapperFactoryList + !$OMP THREADPRIVATE(TheWrapperFactoryList) + +public :: TheWrapperFactoryList +public :: TheWrapperFactoryList_Init + +contains + + 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) + call TheWrapperFactoryList%AddWrapperFactory(key='I8P', WrapperFactory=WrapperFactoryI8P) + call TheWrapperFactoryList%AddWrapperFactory(key='R4P', WrapperFactory=WrapperFactoryR4P) + 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 module WrapperFactoryListSingleton diff --git a/src/modules/FacetMatrix/CMakeLists.txt b/src/modules/FacetMatrix/CMakeLists.txt new file mode 100644 index 000000000..fed11a933 --- /dev/null +++ b/src/modules/FacetMatrix/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}/FacetMatrix_Method.F90 +) diff --git a/src/modules/FacetMatrix/src/FacetMatrix1.inc b/src/modules/FacetMatrix/src/FacetMatrix1.inc new file mode 100644 index 000000000..afcfc045c --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix1.inc @@ -0,0 +1,175 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix1 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau\left[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot +! {\bf n}\right]\cdot\left[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} +! \right]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix1_1( masterElemSD, slaveElemSD, & + & quadMap ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix1_1 +END INTERFACE + +INTERFACE FacetMatrix1 + MODULE PROCEDURE FacetMatrix1_1 +END INTERFACE FacetMatrix1 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau\left[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot +! {\bf n}\right]\cdot\left[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} +! \right]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix1_2( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix1_2 +END INTERFACE + +INTERFACE FacetMatrix1 + MODULE PROCEDURE FacetMatrix1_2 +END INTERFACE FacetMatrix1 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix1_3( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauvar, quadMap ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix1_3 +END INTERFACE + +INTERFACE FacetMatrix1 + MODULE PROCEDURE FacetMatrix1_3 +END INTERFACE FacetMatrix1 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix1_4( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix1_4 +END INTERFACE + +INTERFACE FacetMatrix1 + MODULE PROCEDURE FacetMatrix1_4 +END INTERFACE FacetMatrix1 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix1_5( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauvar, quadMap ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix1_5 +END INTERFACE + +INTERFACE FacetMatrix1 + MODULE PROCEDURE FacetMatrix1_5 +END INTERFACE FacetMatrix1 diff --git a/src/modules/FacetMatrix/src/FacetMatrix11.inc b/src/modules/FacetMatrix/src/FacetMatrix11.inc new file mode 100644 index 000000000..c00d50d16 --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix11.inc @@ -0,0 +1,178 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix11 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix11_1( masterElemSD, slaveElemSD, quadMap, & + & nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix11_1 +END INTERFACE + +INTERFACE FacetMatrix11 + MODULE PROCEDURE FacetMatrix11_1 +END INTERFACE FacetMatrix11 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix11_2( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap, nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix11_2 +END INTERFACE + +INTERFACE FacetMatrix11 + MODULE PROCEDURE FacetMatrix11_2 +END INTERFACE FacetMatrix11 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix11_3( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauvar, quadMap, nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix11_3 +END INTERFACE + +INTERFACE FacetMatrix11 + MODULE PROCEDURE FacetMatrix11_3 +END INTERFACE FacetMatrix11 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix11_4( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap, nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix11_4 +END INTERFACE + +INTERFACE FacetMatrix11 + MODULE PROCEDURE FacetMatrix11_4 +END INTERFACE FacetMatrix11 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix11_5( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauvar, quadMap, nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: quadMap( : ) + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix11_5 +END INTERFACE + +INTERFACE FacetMatrix11 + MODULE PROCEDURE FacetMatrix11_5 +END INTERFACE FacetMatrix11 diff --git a/src/modules/FacetMatrix/src/FacetMatrix12.inc b/src/modules/FacetMatrix/src/FacetMatrix12.inc new file mode 100644 index 000000000..7e35f04f0 --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix12.inc @@ -0,0 +1,166 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix12 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot +! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} +! dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix12_1( elemsd, nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix12_1 +END INTERFACE + +INTERFACE FacetMatrix12 + MODULE PROCEDURE FacetMatrix12_1 +END INTERFACE FacetMatrix12 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot +! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} +! dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix12_2( elemsd, mu, nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix12_2 +END INTERFACE + +INTERFACE FacetMatrix12 + MODULE PROCEDURE FacetMatrix12_2 +END INTERFACE FacetMatrix12 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot +! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} +! dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix12_3( elemsd, mu, tauvar, nCopy ) & + & RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix12_3 +END INTERFACE + +INTERFACE FacetMatrix12 + MODULE PROCEDURE FacetMatrix12_3 +END INTERFACE FacetMatrix12 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot +! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} +! dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix12_4( elemsd, mu, nCopy ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix12_4 +END INTERFACE + +INTERFACE FacetMatrix12 + MODULE PROCEDURE FacetMatrix12_4 +END INTERFACE FacetMatrix12 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot +! {\bf n}\cdot\frac{\partial\delta{\bf \bar{v}}}{\partial{\bf x}}\cdot{\bf n} +! dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix12_5( elemsd, mu, tauvar, nCopy ) & + & RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: nCopy + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix12_5 +END INTERFACE + +INTERFACE FacetMatrix12 + MODULE PROCEDURE FacetMatrix12_5 +END INTERFACE FacetMatrix12 diff --git a/src/modules/FacetMatrix/src/FacetMatrix13.inc b/src/modules/FacetMatrix/src/FacetMatrix13.inc new file mode 100644 index 000000000..2465a2125 --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix13.inc @@ -0,0 +1,187 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix13 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix13_1( elemsd, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix13_1 +END INTERFACE + +INTERFACE FacetMatrix13 + MODULE PROCEDURE FacetMatrix13_1 +END INTERFACE FacetMatrix13 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix13_2( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix13_2 +END INTERFACE + +INTERFACE FacetMatrix13 + MODULE PROCEDURE FacetMatrix13_2 +END INTERFACE FacetMatrix13 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix13_3( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix13_3 +END INTERFACE + +INTERFACE FacetMatrix13 + MODULE PROCEDURE FacetMatrix13_3 +END INTERFACE FacetMatrix13 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix13_4( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix13_4 +END INTERFACE + +INTERFACE FacetMatrix13 + MODULE PROCEDURE FacetMatrix13_4 +END INTERFACE FacetMatrix13 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix13_5( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix13_5 +END INTERFACE + +INTERFACE FacetMatrix13 + MODULE PROCEDURE FacetMatrix13_5 +END INTERFACE FacetMatrix13 diff --git a/src/modules/FacetMatrix/src/FacetMatrix14.inc b/src/modules/FacetMatrix/src/FacetMatrix14.inc new file mode 100644 index 000000000..c2e39bd4e --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix14.inc @@ -0,0 +1,187 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix14 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix14_1( elemsd, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix14_1 +END INTERFACE + +INTERFACE FacetMatrix14 + MODULE PROCEDURE FacetMatrix14_1 +END INTERFACE FacetMatrix14 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix14_2( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix14_2 +END INTERFACE + +INTERFACE FacetMatrix14 + MODULE PROCEDURE FacetMatrix14_2 +END INTERFACE FacetMatrix14 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix14_3( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix14_3 +END INTERFACE + +INTERFACE FacetMatrix14 + MODULE PROCEDURE FacetMatrix14_3 +END INTERFACE FacetMatrix14 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix14_4( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix14_4 +END INTERFACE + +INTERFACE FacetMatrix14 + MODULE PROCEDURE FacetMatrix14_4 +END INTERFACE FacetMatrix14 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\left(\mu\nabla\delta{\bf v}\cdot{\bf n} +! \right)\cdot\left(\bar{p}{\bf n}\right)dS & =\int_{\Gamma_{e}}\tau\mu\frac +! {\partial\delta v_{i}}{\partial x_{p}}n_{p}n_{i}\bar{p}dS\\ & =\int_{\Gamma_ +! {e}}\tau\mu\frac{\partial\delta v_{iI}N^{I}}{\partial x_{p}}n_{p}n_{i}\bar +! {p}_{J}N^{J}dS\\ & =\delta v_{iI}\left[\int_{\Gamma_{e}}\tau\mu\frac +! {\partial N^{I}}{\partial x_{p}}n_{p}n_{i}N^{J}dS\right]\bar{p}_{J} \end +! {aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix14_5( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix14_5 +END INTERFACE + +INTERFACE FacetMatrix14 + MODULE PROCEDURE FacetMatrix14_5 +END INTERFACE FacetMatrix14 diff --git a/src/modules/FacetMatrix/src/FacetMatrix15.inc b/src/modules/FacetMatrix/src/FacetMatrix15.inc new file mode 100644 index 000000000..11adb0e51 --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix15.inc @@ -0,0 +1,214 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix15 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix15_1( masterElemSD, slaveElemSD, & + & quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix15_1 +END INTERFACE + +INTERFACE FacetMatrix15 + MODULE PROCEDURE FacetMatrix15_1 +END INTERFACE FacetMatrix15 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix15_2( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix15_2 +END INTERFACE + +INTERFACE FacetMatrix15 + MODULE PROCEDURE FacetMatrix15_2 +END INTERFACE FacetMatrix15 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix15_3( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + REAL( DFP ), INTENT( IN ) :: tauMaster + REAL( DFP ), INTENT( IN ) :: tauSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix15_3 +END INTERFACE + +INTERFACE FacetMatrix15 + MODULE PROCEDURE FacetMatrix15_3 +END INTERFACE FacetMatrix15 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix15_4( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix15_4 +END INTERFACE + +INTERFACE FacetMatrix15 + MODULE PROCEDURE FacetMatrix15_4 +END INTERFACE FacetMatrix15 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix15_5( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster + TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix15_5 +END INTERFACE + +INTERFACE FacetMatrix15 + MODULE PROCEDURE FacetMatrix15_5 +END INTERFACE FacetMatrix15 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix15_6( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster + TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix15_6 +END INTERFACE + +INTERFACE FacetMatrix15 + MODULE PROCEDURE FacetMatrix15_6 +END INTERFACE FacetMatrix15 diff --git a/src/modules/FacetMatrix/src/FacetMatrix2.inc b/src/modules/FacetMatrix/src/FacetMatrix2.inc new file mode 100644 index 000000000..b3294f35c --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix2.inc @@ -0,0 +1,159 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix2 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot +! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} +! \right)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix2_1( elemsd ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix2_1 +END INTERFACE + +INTERFACE FacetMatrix2 + MODULE PROCEDURE FacetMatrix2_1 +END INTERFACE FacetMatrix2 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot +! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} +! \right)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix2_2( elemsd, mu ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix2_2 +END INTERFACE + +INTERFACE FacetMatrix2 + MODULE PROCEDURE FacetMatrix2_2 +END INTERFACE FacetMatrix2 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot +! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} +! \right)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix2_3( elemsd, mu, tauvar ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix2_3 +END INTERFACE + +INTERFACE FacetMatrix2 + MODULE PROCEDURE FacetMatrix2_3 +END INTERFACE FacetMatrix2 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot +! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} +! \right)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix2_4( elemsd, mu ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix2_4 +END INTERFACE + +INTERFACE FacetMatrix2 + MODULE PROCEDURE FacetMatrix2_4 +END INTERFACE FacetMatrix2 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau\left(2\mu{\bf d}\left(\delta\bar{{\bf v}}\right)\cdot +! {\bf n}\right)\cdot\left(2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n} +! \right)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix2_5( elemsd, mu, tauvar ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix2_5 +END INTERFACE + +INTERFACE FacetMatrix2 + MODULE PROCEDURE FacetMatrix2_5 +END INTERFACE FacetMatrix2 diff --git a/src/modules/FacetMatrix/src/FacetMatrix21.inc b/src/modules/FacetMatrix/src/FacetMatrix21.inc new file mode 100644 index 000000000..d26991dac --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix21.inc @@ -0,0 +1,103 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix21 + +!---------------------------------------------------------------------------- +! FacetMatrix21 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\delta p{\bf n}\cdot\nabla pdS & +! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau N^{I}{\bf n}\cdot\nabla N^{J} +! dS\right)p_{J}\end{aligned} +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix21_1( elemsd ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix21_1 +END INTERFACE + +INTERFACE FacetMatrix21 + MODULE PROCEDURE FacetMatrix21_1 +END INTERFACE FacetMatrix21 + +!---------------------------------------------------------------------------- +! FacetMatrix21 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\delta p{\bf n}\cdot\nabla pdS & +! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau N^{I}{\bf n}\cdot\nabla N^{J} +! dS\right)p_{J}\end{aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix21_2( elemsd, tauvar ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix21_2 +END INTERFACE + +INTERFACE FacetMatrix21 + MODULE PROCEDURE FacetMatrix21_2 +END INTERFACE FacetMatrix21 + +!---------------------------------------------------------------------------- +! FacetMatrix21 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}\tau\delta p{\bf n}\cdot\nabla pdS & +! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau N^{I}{\bf n}\cdot\nabla N^{J} +! dS\right)p_{J}\end{aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix21_3( elemsd, tauvar ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix21_3 +END INTERFACE + +INTERFACE FacetMatrix21 + MODULE PROCEDURE FacetMatrix21_3 +END INTERFACE FacetMatrix21 diff --git a/src/modules/FacetMatrix/src/FacetMatrix22.inc b/src/modules/FacetMatrix/src/FacetMatrix22.inc new file mode 100644 index 000000000..3dee21d1b --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix22.inc @@ -0,0 +1,103 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix22 + +!---------------------------------------------------------------------------- +! FacetMatrix22 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}{\bf n}\cdot\nabla\delta p\tau pdS & +! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau{\bf n}\cdot\nabla N^{I}N^{J} +! dS\right)p_{J}\end{aligned} +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix22_1( elemsd ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix22_1 +END INTERFACE + +INTERFACE FacetMatrix22 + MODULE PROCEDURE FacetMatrix22_1 +END INTERFACE FacetMatrix22 + +!---------------------------------------------------------------------------- +! FacetMatrix22 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}{\bf n}\cdot\nabla\delta p\tau pdS & +! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau{\bf n}\cdot\nabla N^{I}N^{J} +! dS\right)p_{J}\end{aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix22_2( elemsd, tauvar ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix22_2 +END INTERFACE + +INTERFACE FacetMatrix22 + MODULE PROCEDURE FacetMatrix22_2 +END INTERFACE FacetMatrix22 + +!---------------------------------------------------------------------------- +! FacetMatrix22 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \begin{aligned}\int_{\Gamma_{e}}{\bf n}\cdot\nabla\delta p\tau pdS & +! =\delta p_{I}\left(\int_{\Gamma_{e}}\tau{\bf n}\cdot\nabla N^{I}N^{J} +! dS\right)p_{J}\end{aligned} +! $$ + + +INTERFACE +MODULE PURE FUNCTION FacetMatrix22_3( elemsd, tauvar ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix22_3 +END INTERFACE + +INTERFACE FacetMatrix22 + MODULE PROCEDURE FacetMatrix22_3 +END INTERFACE FacetMatrix22 diff --git a/src/modules/FacetMatrix/src/FacetMatrix3.inc b/src/modules/FacetMatrix/src/FacetMatrix3.inc new file mode 100644 index 000000000..6a96fb65e --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix3.inc @@ -0,0 +1,154 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix3 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix3_1( elemsd, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix3_1 +END INTERFACE + +INTERFACE FacetMatrix3 + MODULE PROCEDURE FacetMatrix3_1 +END INTERFACE FacetMatrix3 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix3_2( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix3_2 +END INTERFACE + +INTERFACE FacetMatrix3 + MODULE PROCEDURE FacetMatrix3_2 +END INTERFACE FacetMatrix3 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix3_3( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix3_3 +END INTERFACE + +INTERFACE FacetMatrix3 + MODULE PROCEDURE FacetMatrix3_3 +END INTERFACE FacetMatrix3 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix3_4( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix3_4 +END INTERFACE + +INTERFACE FacetMatrix3 + MODULE PROCEDURE FacetMatrix3_4 +END INTERFACE FacetMatrix3 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}G_{12}(I,j,i)n_{j}N^{J}dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix3_5( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix3_5 +END INTERFACE + +INTERFACE FacetMatrix3 + MODULE PROCEDURE FacetMatrix3_5 +END INTERFACE FacetMatrix3 diff --git a/src/modules/FacetMatrix/src/FacetMatrix4.inc b/src/modules/FacetMatrix/src/FacetMatrix4.inc new file mode 100644 index 000000000..6557b7bab --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix4.inc @@ -0,0 +1,154 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix4 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix4_1( elemsd, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix4_1 +END INTERFACE + +INTERFACE FacetMatrix4 + MODULE PROCEDURE FacetMatrix4_1 +END INTERFACE FacetMatrix4 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix4_2( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix4_2 +END INTERFACE + +INTERFACE FacetMatrix4 + MODULE PROCEDURE FacetMatrix4_2 +END INTERFACE FacetMatrix4 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix4_3( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + REAL( DFP ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + REAL( DFP ), ALLOCATABLE :: ans( :, : ) + INTEGER( I4B ), INTENT( IN ) :: opt +END FUNCTION FacetMatrix4_3 +END INTERFACE + +INTERFACE FacetMatrix4 + MODULE PROCEDURE FacetMatrix4_3 +END INTERFACE FacetMatrix4 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix4_4( elemsd, mu, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix4_4 +END INTERFACE + +INTERFACE FacetMatrix4 + MODULE PROCEDURE FacetMatrix4_4 +END INTERFACE FacetMatrix4 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}\bigcap\Gamma^{h}}\tau_{E1}N_{J}n_{i}G_{12}(J,i,j)dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix4_5( elemsd, mu, tauvar, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: elemsd + TYPE( FEVariable_ ), INTENT( IN ) :: mu + TYPE( FEVariable_ ), INTENT( IN ) :: tauvar + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix4_5 +END INTERFACE + +INTERFACE FacetMatrix4 + MODULE PROCEDURE FacetMatrix4_5 +END INTERFACE FacetMatrix4 diff --git a/src/modules/FacetMatrix/src/FacetMatrix5.inc b/src/modules/FacetMatrix/src/FacetMatrix5.inc new file mode 100644 index 000000000..26b666efc --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix5.inc @@ -0,0 +1,214 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PUBLIC :: FacetMatrix5 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix5_1( masterElemSD, slaveElemSD, & + & quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix5_1 +END INTERFACE + +INTERFACE FacetMatrix5 + MODULE PROCEDURE FacetMatrix5_1 +END INTERFACE FacetMatrix5 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix5_2( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix5_2 +END INTERFACE + +INTERFACE FacetMatrix5 + MODULE PROCEDURE FacetMatrix5_2 +END INTERFACE FacetMatrix5 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix5_3( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + REAL( DFP ), INTENT( IN ) :: tauMaster + REAL( DFP ), INTENT( IN ) :: tauSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix5_3 +END INTERFACE + +INTERFACE FacetMatrix5 + MODULE PROCEDURE FacetMatrix5_3 +END INTERFACE FacetMatrix5 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix5_4( masterElemSD, slaveElemSD, & + & muMaster, muSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix5_4 +END INTERFACE + +INTERFACE FacetMatrix5 + MODULE PROCEDURE FacetMatrix5_4 +END INTERFACE FacetMatrix5 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix5_5( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + REAL( DFP ), INTENT( IN ) :: muMaster + REAL( DFP ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster + TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix5_5 +END INTERFACE + +INTERFACE FacetMatrix5 + MODULE PROCEDURE FacetMatrix5_5 +END INTERFACE FacetMatrix5 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 May 2022 +! summary: FacetMatrix for VMS-FEM for CFD +! +!# Introduction +! +! $$ +! \int_{\Gamma_{e}}\tau_{E1}[[2\mu{\bf d}\left(\delta\bar{{\bf v}}\right) +! \cdot{\bf n}]]\cdot[[2\mu{\bf d}\left(\bar{{\bf v}}\right)\cdot{\bf n}]]dS +! $$ + +INTERFACE +MODULE PURE FUNCTION FacetMatrix5_6( masterElemSD, slaveElemSD, & + & muMaster, muSlave, tauMaster, tauSlave, quadMap, opt ) RESULT( ans ) + CLASS( ElemshapeData_ ), INTENT( IN ) :: masterElemSD + CLASS( ElemshapeData_ ), INTENT( IN ) :: slaveElemSD + TYPE( FEVariable_ ), INTENT( IN ) :: muMaster + TYPE( FEVariable_ ), INTENT( IN ) :: muSlave + TYPE( FEVariable_ ), INTENT( IN ) :: tauMaster + TYPE( FEVariable_ ), INTENT( IN ) :: tauSlave + INTEGER( I4B ), INTENT( IN ) :: quadMap(:) + INTEGER( I4B ), INTENT( IN ) :: opt + REAL( DFP ), ALLOCATABLE :: ans( :, : ) +END FUNCTION FacetMatrix5_6 +END INTERFACE + +INTERFACE FacetMatrix5 + MODULE PROCEDURE FacetMatrix5_6 +END INTERFACE FacetMatrix5 diff --git a/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 b/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 new file mode 100644 index 000000000..f49e682ff --- /dev/null +++ b/src/modules/FacetMatrix/src/FacetMatrix_Method.F90 @@ -0,0 +1,37 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE FacetMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +#include "./FacetMatrix1.inc" +#include "./FacetMatrix2.inc" +#include "./FacetMatrix3.inc" +#include "./FacetMatrix4.inc" +#include "./FacetMatrix5.inc" +#include "./FacetMatrix11.inc" +#include "./FacetMatrix12.inc" +#include "./FacetMatrix13.inc" +#include "./FacetMatrix14.inc" +#include "./FacetMatrix15.inc" +#include "./FacetMatrix21.inc" +#include "./FacetMatrix22.inc" + +END MODULE FacetMatrix_Method \ No newline at end of file diff --git a/src/modules/ForceVector/CMakeLists.txt b/src/modules/ForceVector/CMakeLists.txt new file mode 100644 index 000000000..a3ca4027f --- /dev/null +++ b/src/modules/ForceVector/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}/ForceVector_Method.F90 +) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 new file mode 100644 index 000000000..3e4deb1af --- /dev/null +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -0,0 +1,229 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 ForceVector_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: 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 FUNCTION ForceVector_1(test) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION ForceVector_1 +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_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) + CLASS(ElemshapeData_), INTENT(IN) :: test + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION ForceVector_2 +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 FUNCTION ForceVector_3(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 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 FUNCTION ForceVector_4(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 INTERFACE ForceVector + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! This routine computes the following integral +! +! $$ +! F_{I}=\int_{\Omega}\rho_{1}\rho_{2}N^{I}d\Omega +! $$ + +INTERFACE ForceVector + MODULE PURE FUNCTION ForceVector_5(test, c1, c1rank, c2, c2rank) & + & RESULT(ans) + 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 INTERFACE ForceVector + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! This routine computes the following integral. +! +! $$ +! +! $$ + +INTERFACE ForceVector + MODULE PURE FUNCTION ForceVector_6(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 INTERFACE ForceVector + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! This routine computes the following. +! +! $$ +! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega +! $$ + +INTERFACE ForceVector + MODULE PURE FUNCTION ForceVector_7(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 INTERFACE ForceVector + +END MODULE ForceVector_Method diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt new file mode 100644 index 000000000..8c398fbc6 --- /dev/null +++ b/src/modules/Geometry/CMakeLists.txt @@ -0,0 +1,34 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +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 diff --git a/src/modules/Geometry/src/Geometry_Method.F90 b/src/modules/Geometry/src/Geometry_Method.F90 new file mode 100644 index 000000000..2c87d5278 --- /dev/null +++ b/src/modules/Geometry/src/Geometry_Method.F90 @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 Geometry_Method +USE ReferenceElement_Method +USE ReferencePoint_Method +USE ReferenceLine_Method +USE ReferenceTriangle_Method +USE ReferenceQuadrangle_Method +USE ReferenceTetrahedron_Method +USE ReferenceHexahedron_Method +USE ReferencePrism_Method +USE ReferencePyramid_Method +USE Line_Method +USE Triangle_Method +USE Plane_Method +END MODULE Geometry_Method diff --git a/src/modules/Geometry/src/Line_Method.F90 b/src/modules/Geometry/src/Line_Method.F90 new file mode 100644 index 000000000..2c1757412 --- /dev/null +++ b/src/modules/Geometry/src/Line_Method.F90 @@ -0,0 +1,431 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> 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/Plane_Method.F90 b/src/modules/Geometry/src/Plane_Method.F90 new file mode 100644 index 000000000..2be4626c7 --- /dev/null +++ b/src/modules/Geometry/src/Plane_Method.F90 @@ -0,0 +1,69 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 Plane_Method +USE GlobalData +IMPLICIT NONE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: intersection of plane and line in 3D. +! +!# Introduction +! +! The normal form of a plane in 3D is: +! +! PP is a point on the plane, +! N is a normal vector to the plane. +! +! The explicit form of a line in 3D is: +! +! P1, P2 are two points on the line. +! +!# Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. +! +! Input, real ( kind = 8 ) P1(3), P2(3), two distinct points on the line. +! +! Output, integer ( kind = 4 ) IVAL, the kind of intersection; +! 0, the line and plane seem to be parallel and separate; +! 1, the line and plane intersect at a single point; +! 2, the line and plane seem to be parallel and joined. +! +! 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 + +END MODULE Plane_Method diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 new file mode 100644 index 000000000..58a0500c0 --- /dev/null +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -0,0 +1,1347 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 1 March 2021 +! summary: This submodule contains method for [[ReferenceElement_]] + +MODULE ReferenceElement_Method +USE BaseType +USE String_Class, ONLY: String +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Display +PUBLIC :: MdEncode +PUBLIC :: ReactEncode +PUBLIC :: ReferenceTopology +PUBLIC :: DEALLOCATE +PUBLIC :: OPERATOR(.NNE.) +PUBLIC :: Initiate +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: ReferenceElement_Pointer +PUBLIC :: GetConnectivity +PUBLIC :: ElementType +PUBLIC :: Elementname +PUBLIC :: TotalNodesInElement +PUBLIC :: ElementOrder +PUBLIC :: OPERATOR(.order.) +PUBLIC :: XiDimension +PUBLIC :: IsVolume +PUBLIC :: IsSurface +PUBLIC :: IsLine +PUBLIC :: IsPoint +PUBLIC :: IsTriangle +PUBLIC :: IsQuadrangle +PUBLIC :: IsTetrahedron +PUBLIC :: IsHexahedron +PUBLIC :: IsPrism +PUBLIC :: IsPyramid +PUBLIC :: IsSerendipityElement +PUBLIC :: ElementTopology +PUBLIC :: OPERATOR(.topology.) +PUBLIC :: FacetMatrix +PUBLIC :: GetFacetElements +PUBLIC :: LocalNodeCoord +PUBLIC :: MeasureSimplex +PUBLIC :: ElementQuality +PUBLIC :: ContainsPoint +PUBLIC :: TotalEntities +PUBLIC :: GetFacetTopology +PUBLIC :: GetVTKelementType +PUBLIC :: GetEdgeConnectivity +PUBLIC :: GetFaceConnectivity +PUBLIC :: GetTotalNodes +PUBLIC :: GetTotalEdges +PUBLIC :: GetTotalFaces +PUBLIC :: GetTotalCells +PUBLIC :: ReferenceElementInfo +PUBLIC :: RefElemGetGeoParam +PUBLIC :: GetFaceElemType +PUBLIC :: GetElementIndex +PUBLIC :: Reallocate +PUBLIC :: RefTopoReallocate + +INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_FACES = 6 +INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_EDGES = 12 +INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_POINTS = 8 + +!---------------------------------------------------------------------------- +! ReferenceElementInfo_ +!---------------------------------------------------------------------------- + +TYPE :: ReferenceElementInfo_ + INTEGER(I4B) :: point = 1 + INTEGER(I4B) :: line = 2 + INTEGER(I4B) :: triangle = 3 + INTEGER(I4B) :: quadrangle = 4 + INTEGER(I4B) :: tetrahedron = 5 + INTEGER(I4B) :: hexahedron = 6 + INTEGER(I4B) :: prism = 7 + INTEGER(I4B) :: pyramid = 8 + INTEGER(I4B) :: tElemTopologyType_0D = 1 + INTEGER(I4B) :: tElemTopologyType_1D = 1 + INTEGER(I4B) :: tElemTopologyType_2D = 2 + INTEGER(I4B) :: tElemTopologyType_3D = 4 + INTEGER(I4B) :: tElemTopologyType = 8 + INTEGER(I4B) :: elemTopologyname(8) = [ & + & Point, & + & Line, & + & Triangle, & + & Quadrangle, & + & Tetrahedron, Hexahedron, Prism, Pyramid] + INTEGER(I4B) :: maxFaces = PARAM_REFELEM_MAX_FACES + INTEGER(I4B) :: maxEdges = PARAM_REFELEM_MAX_EDGES + INTEGER(I4B) :: maxPoints = PARAM_REFELEM_MAX_POINTS + INTEGER(I4B) :: tCells(8) = [0, 0, 0, 0, 1, 1, 1, 1] + !! Here cell is a topology for which xidim = 3 + INTEGER(I4B) :: tFaces(8) = [0, 0, 1, 1, 4, 6, 5, 5] + !! Here facet is topology entity for which xidim = 2 + INTEGER(I4B) :: tEdges(8) = [0, 0, 3, 4, 6, 12, 9, 8] + !! Here edge is topology entity for which xidim = 1 + INTEGER(I4B) :: tPoints(8) = [1, 2, 3, 4, 4, 8, 6, 5] + !! A point is topology entity for which xidim = 0 + INTEGER(I4B) :: nne_in_face_triangle(1) = [3] + !! number of nodes in each face of triangle + INTEGER(I4B) :: nne_in_face_quadrangle(1) = [4] + !! number of nodes in each face of quadrangle + INTEGER(I4B) :: nne_in_face_tetrahedron(4) = [3, 3, 3, 3] + !! number of nodes in each face of tetrahedron + INTEGER(I4B) :: nne_in_face_hexahedron(6) = [4, 4, 4, 4, 4, 4] + !! number of nodes in each face of tetrahedron + INTEGER(I4B) :: nne_in_face_prism(5) = [3, 4, 4, 4, 3] + !! number of nodes in each face of tetrahedron + INTEGER(I4B) :: nne_in_face_pyramid(5) = [4, 3, 3, 3, 3] + !! number of nodes in each face of tetrahedron +END TYPE ReferenceElementInfo_ + +TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = & + & ReferenceElementInfo_() + +!---------------------------------------------------------------------------- +! GetElementIndex@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-19 +! summary: Returns the index of an element based on its topology +! +!# Introduction +! +! Point 1 +! Line 2 +! Triangle 3 +! Quadrangle 4 +! Tetrahedron 5 +! Hexahedron 6 +! Prism 7 +! Pyramid 8 + +INTERFACE + MODULE PURE FUNCTION GetElementIndex(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION GetElementIndex +END INTERFACE + +!---------------------------------------------------------------------------- +! RefElemGetGeoParam@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-09 +! summary: Returns the geometry parameters + +INTERFACE RefElemGetGeoParam + MODULE PURE SUBROUTINE RefElemGetGeoParam1(elemType, tNodes, tEdges, & + & tFaces, tCells, edgeCon, faceCon, edgeOpt, faceOpt, faceElemType, & + & tFaceNodes, order) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tNodes + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tEdges + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaces + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tCells + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: edgeCon(:, :) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceCon(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOpt + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOpt + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! Order of element + END SUBROUTINE RefElemGetGeoParam1 +END INTERFACE RefElemGetGeoParam + +!---------------------------------------------------------------------------- +! GetTotalEdges@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-14 +! summary: Returns number of edges in the element + +INTERFACE GetTotalEdges + MODULE PURE FUNCTION GetTotalEdges1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION GetTotalEdges1 +END INTERFACE GetTotalEdges + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-07 +! summary: Returns number of edges in the element + +INTERFACE GetEdgeConnectivity + MODULE PURE SUBROUTINE GetEdgeConnectivity1(elemType, con, opt, order, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: elemType + !! name of element + INTEGER(I4B), INTENT(INOUT) :: con(:, :) + !! Connectivity + !! The columns represents the edge number + !! The row represents the connectivity of edge + !! con should be allocated by the user + 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 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! Order of element + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow + !! Number of rows written to con + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol + !! number of columns written to con + END SUBROUTINE GetEdgeConnectivity1 +END INTERFACE GetEdgeConnectivity + +!---------------------------------------------------------------------------- +! GetFaceConnectivity@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-07 +! summary: Returns number of edges in the element + +INTERFACE GetFaceConnectivity + MODULE PURE SUBROUTINE GetFaceConnectivity1(elemType, con, opt, order, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: elemType + !! name of element + 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 + !! 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) :: order + !! order of element + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow + !! Number of rows written to con + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol + !! number of columns written to con + END SUBROUTINE GetFaceConnectivity1 +END INTERFACE GetFaceConnectivity + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType + MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, & + tFaceNodes) + INTEGER(I4B), INTENT(IN) :: elemType + !! name of element + INTEGER(I4B), 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 GetFaceElemType1 +END INTERFACE GetFaceElemType + +!---------------------------------------------------------------------------- +! GetTotalNodes@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-14 +! summary: Returns number of nodes (vertices) in the element + +INTERFACE GetTotalNodes + MODULE PURE FUNCTION GetTotalNodes1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION GetTotalNodes1 +END INTERFACE GetTotalNodes + +!---------------------------------------------------------------------------- +! GetTotalFaces@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-14 +! summary: Returns number of faces in the element + +INTERFACE GetTotalFaces + MODULE PURE FUNCTION GetTotalFaces1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION GetTotalFaces1 +END INTERFACE GetTotalFaces + +!---------------------------------------------------------------------------- +! GetTotalCells@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-14 +! summary: Returns number of faces in the element + +INTERFACE GetTotalCells + MODULE PURE FUNCTION GetTotalCells1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION GetTotalCells1 +END INTERFACE GetTotalCells + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Display the ReferenceElement + +INTERFACE Display + MODULE SUBROUTINE refelem_Display(obj, msg, unitno) + CLASS(ReferenceElement_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno + END SUBROUTINE refelem_Display +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Markdown encoding of reference element + +INTERFACE MdEncode + MODULE FUNCTION refelem_MdEncode(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + TYPE(String) :: ans + END FUNCTION refelem_MdEncode +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Returns react element for reference element + +INTERFACE ReactEncode + MODULE FUNCTION refelem_ReactEncode(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + TYPE(String) :: ans + END FUNCTION refelem_ReactEncode +END INTERFACE ReactEncode + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Display reference topology + +INTERFACE Display + MODULE SUBROUTINE reftopo_Display(obj, msg, unitno) + CLASS(ReferenceTopology_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno + END SUBROUTINE reftopo_Display +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 May 2022 +! summary: Display reference topology + +INTERFACE MdEncode + MODULE FUNCTION reftopo_MdEncode(obj) RESULT(ans) + CLASS(ReferenceTopology_), INTENT(IN) :: obj + TYPE(String) :: ans + END FUNCTION reftopo_MdEncode +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! ReferenceTopology@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This function returns the instance of [[ReferenceTopology_]] +! +!# Introduction +! +! This function returns the instance of [[ReferenceTopology_]]. +! +! The possible valaues of name can be +! +! - `Line, Line2, Line3, Line4, Line5, Line6` +! - `Triangle, Triangle3, Triangle6, Triangle9, Triangle10, Triangle12, +! Triangl15a, Triangl15b, Triangl15, Triangl21` +! - `Quadrangle, Quadrangle4, Quadrangle9, Quadrangle8` +! - `Tetrahedron, Tetrahedron4, Tetrahedron10, Tetrahedron20, Tetrahedron35, +! Tetrahedron56` +! - `Hexahedron, Hexahedron8, Hexahedron27, Hexahedron20, Hexahedron64, +! Hexahedron125` +! - `Prism, Prism6, Prism15, Prism18` +! - `Pyramid, Pyramid5, Pyramid14, Pyramid13` +! - `Point, Point1` +! +!### Usage +! +!```fortran +! type( ReferenceTopology_ ) :: obj +! obj = ReferenceTopology( nptrs = [1,2,3], name=Triangle3 ) +! call display( obj, "obj=") +!``` + +INTERFACE ReferenceTopology + MODULE PURE FUNCTION refelem_ReferenceTopology(nptrs, name) RESULT(obj) + TYPE(ReferenceTopology_) :: obj + INTEGER(I4B), INTENT(IN) :: nptrs(:) + INTEGER(I4B), INTENT(IN) :: name + END FUNCTION refelem_ReferenceTopology +END INTERFACE ReferenceTopology + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This subroutine reset the instance of [[ReferenceTopology_]] +! +!### Usage +! +!```fortran +! type( ReferenceTopology_ ) :: obj +! obj = ReferenceTopology( nptrs = [1,2,3], name=Triangle3 ) +! call display( obj, "obj=") +! call Deallocate( obj ) +!``` + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE refelem_Deallocate1(obj) + CLASS(ReferenceTopology_), INTENT(INOUT) :: obj + END SUBROUTINE refelem_Deallocate1 +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-24 +! summary: Deallocate topology vector + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE RefTopoDeallocate(obj) + TYPE(ReferenceTopology_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RefTopoDeallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-24 +! summary: Reallocate topology vector + +INTERFACE Reallocate + MODULE PURE SUBROUTINE RefTopoReallocate(obj, n) + TYPE(ReferenceTopology_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: n + END SUBROUTINE RefTopoReallocate +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: Deallocates the data stored inside the [[ReferenceElement_]] + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE refelem_Deallocate2(obj) + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + END SUBROUTINE refelem_Deallocate2 +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! NNE@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This function returns the totat nodes inside the referenc topology +! +!### Usage +! +!```fortran +! type( ReferenceTopology_ ) :: obj +! obj = ReferenceTopology( nptrs = [1,2,3], name=Triangle3 ) +! call display( obj, "obj=") +! call display( .NNE. obj, "nne =") +!``` + +INTERFACE OPERATOR(.NNE.) + MODULE PURE FUNCTION refelem_NNE1(obj) RESULT(ans) + CLASS(ReferenceTopology_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION refelem_NNE1 +END INTERFACE OPERATOR(.NNE.) + +INTERFACE TotalNodesInElement + MODULE PROCEDURE refelem_NNE1 +END INTERFACE TotalNodesInElement + +!---------------------------------------------------------------------------- +! NNE@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: Returns the total number of nodes in the reference element +! + +INTERFACE OPERATOR(.NNE.) + MODULE PURE FUNCTION refelem_NNE2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION refelem_NNE2 +END INTERFACE OPERATOR(.NNE.) + +INTERFACE TotalNodesInElement + MODULE PROCEDURE refelem_NNE2 +END INTERFACE TotalNodesInElement + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 March 2021 +! summary: This subroutine copies one reference element into other +! +!# Introduction +! +! This subroutine copies one reference element into other +! This subroutine also defines an assignment operator for `obj1=obj2` +! type opertions + +INTERFACE Initiate + MODULE PURE SUBROUTINE refelem_Initiate1(obj, anotherobj) + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + CLASS(ReferenceElement_), INTENT(IN) :: anotherobj + END SUBROUTINE refelem_Initiate1 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE refelem_Initiate1 +END INTERFACE + +!---------------------------------------------------------------------------- +! ReferenceElement_Pointer@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns a pointer to an instance of ReferenceElement + +INTERFACE ReferenceElement_Pointer + MODULE FUNCTION refelem_Constructor_1(xidim, nsd, elemType, & + & ipType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: xidim + !! xidimension + INTEGER(I4B), INTENT(IN) :: nsd + !! spatial dimenstion + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolationType + CLASS(ReferenceElement_), POINTER :: ans + !! reference element + END FUNCTION refelem_Constructor_1 +END INTERFACE ReferenceElement_Pointer + +!---------------------------------------------------------------------------- +! ReferenceElementPointer@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns a pointer to an instance of ReferenceElement + +INTERFACE ReferenceElement_Pointer + MODULE FUNCTION refelem_Constructor_2(refelem) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + CLASS(ReferenceElement_), POINTER :: ans + END FUNCTION refelem_Constructor_2 +END INTERFACE ReferenceElement_Pointer + +!---------------------------------------------------------------------------- +! GetConnectivity@ConstrucorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 June 2021 +! summary: Returns the node numbers of reference element + +INTERFACE GetConnectivity + MODULE PURE FUNCTION refelem_Getnptrs(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION refelem_Getnptrs +END INTERFACE GetConnectivity + +!---------------------------------------------------------------------------- +! ElementType@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns element name in integer from element name + +INTERFACE ElementType + MODULE PURE FUNCTION Element_Type(Elemname) RESULT(ans) + CHARACTER(*), INTENT(IN) :: Elemname + INTEGER(I4B) :: ans + END FUNCTION Element_Type +END INTERFACE ElementType + +!---------------------------------------------------------------------------- +! ElementType@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-11-22 +! summary: Return name of element + +INTERFACE ElementType + MODULE PURE FUNCTION Element_Type_obj(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION Element_Type_obj +END INTERFACE ElementType + +!---------------------------------------------------------------------------- +! Elementname@ElementNameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns element name in character from element number/type + +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 + +!---------------------------------------------------------------------------- +! Elementname@ElementNameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns element name in character from ReferenceElement + +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 + +!---------------------------------------------------------------------------- +! TotalNodesInElement@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns total numbers of nodes present in a given element + +INTERFACE TotalNodesInElement + MODULE PURE FUNCTION Total_Nodes_In_Element(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION Total_Nodes_In_Element +END INTERFACE TotalNodesInElement + +!---------------------------------------------------------------------------- +! ElementOrder@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns the order of an element + +INTERFACE ElementOrder + MODULE PURE FUNCTION Element_Order(elemType) RESULT(ans) + INTEGER(I4B) :: ans + INTEGER(I4B), INTENT(IN) :: elemType + END FUNCTION Element_Order +END INTERFACE ElementOrder + +!---------------------------------------------------------------------------- +! ElementOrder@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns the order of an element + +INTERFACE ElementOrder + MODULE PURE FUNCTION Element_Order_refelem(refelem) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + INTEGER(I4B) :: ans + END FUNCTION Element_Order_refelem +END INTERFACE ElementOrder + +INTERFACE OPERATOR(.order.) + MODULE PROCEDURE Element_Order_refelem, Element_Order +END INTERFACE OPERATOR(.order.) + +!---------------------------------------------------------------------------- +! XiDimension@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-13 +! update: 2021-11-13 +! summary: Returns the xidimension of an element + +INTERFACE XiDimension + MODULE PURE FUNCTION Elem_XiDimension1(elemType) RESULT(ans) + INTEGER(I4B) :: ans + INTEGER(I4B), INTENT(IN) :: elemType + END FUNCTION Elem_XiDimension1 +END INTERFACE Xidimension + +!---------------------------------------------------------------------------- +! Xidimension@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-13 +! update: 2021-11-13 +! summary: Returns xidimension of the reference element + +INTERFACE Xidimension + MODULE PURE FUNCTION Elem_Xidimension2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION Elem_Xidimension2 +END INTERFACE XiDimension + +!---------------------------------------------------------------------------- +! isVolume@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a volume element + +INTERFACE isVolume + MODULE PURE FUNCTION isVolume1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isVolume1 +END INTERFACE isVolume + +!---------------------------------------------------------------------------- +! isVolume@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a volume element + +INTERFACE isVolume + MODULE PURE FUNCTION isVolume2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isVolume2 +END INTERFACE isVolume + +!---------------------------------------------------------------------------- +! isSurface@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Surface element + +INTERFACE isSurface + MODULE PURE FUNCTION isSurface1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isSurface1 +END INTERFACE isSurface + +!---------------------------------------------------------------------------- +! isSurface@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Surface element + +INTERFACE isSurface + MODULE PURE FUNCTION isSurface2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isSurface2 +END INTERFACE isSurface + +!---------------------------------------------------------------------------- +! isLine@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Line element + +INTERFACE isLine + MODULE PURE FUNCTION isLine1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isLine1 +END INTERFACE isLine + +!---------------------------------------------------------------------------- +! isLine@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Line element + +INTERFACE isLine + MODULE PURE FUNCTION isLine2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isLine2 +END INTERFACE isLine + +!---------------------------------------------------------------------------- +! isPoint@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Point element + +INTERFACE isPoint + MODULE PURE FUNCTION isPoint1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isPoint1 +END INTERFACE isPoint + +!---------------------------------------------------------------------------- +! isPoint@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Point element + +INTERFACE isPoint + MODULE PURE FUNCTION isPoint2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isPoint2 +END INTERFACE isPoint + +!---------------------------------------------------------------------------- +! isTriangle@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Triangle element + +INTERFACE isTriangle + MODULE PURE FUNCTION isTriangle1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isTriangle1 +END INTERFACE isTriangle + +!---------------------------------------------------------------------------- +! isTriangle@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Triangle element + +INTERFACE isTriangle + MODULE PURE FUNCTION isTriangle2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isTriangle2 +END INTERFACE isTriangle + +!---------------------------------------------------------------------------- +! isQuadrangle@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Quadrangle element + +INTERFACE isQuadrangle + MODULE PURE FUNCTION isQuadrangle1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isQuadrangle1 +END INTERFACE isQuadrangle + +!---------------------------------------------------------------------------- +! isQuadrangle@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Quadrangle element + +INTERFACE isQuadrangle + MODULE PURE FUNCTION isQuadrangle2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isQuadrangle2 +END INTERFACE isQuadrangle + +!---------------------------------------------------------------------------- +! isTetrahedron@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Tetrahedron element + +INTERFACE isTetrahedron + MODULE PURE FUNCTION isTetrahedron1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isTetrahedron1 +END INTERFACE isTetrahedron + +!---------------------------------------------------------------------------- +! isTetrahedron@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Tetrahedron element + +INTERFACE isTetrahedron + MODULE PURE FUNCTION isTetrahedron2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isTetrahedron2 +END INTERFACE isTetrahedron + +!---------------------------------------------------------------------------- +! isHexahedron@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Hexahedron element + +INTERFACE isHexahedron + MODULE PURE FUNCTION isHexahedron1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isHexahedron1 +END INTERFACE isHexahedron + +!---------------------------------------------------------------------------- +! isHexahedron@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Hexahedron element + +INTERFACE isHexahedron + MODULE PURE FUNCTION isHexahedron2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isHexahedron2 +END INTERFACE isHexahedron + +!---------------------------------------------------------------------------- +! isPrism@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Prism element + +INTERFACE isPrism + MODULE PURE FUNCTION isPrism1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isPrism1 +END INTERFACE isPrism + +!---------------------------------------------------------------------------- +! isPrism@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Prism element + +INTERFACE isPrism + MODULE PURE FUNCTION isPrism2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isPrism2 +END INTERFACE isPrism + +!---------------------------------------------------------------------------- +! isPyramid@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Pyramid element + +INTERFACE isPyramid + MODULE PURE FUNCTION isPyramid1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isPyramid1 +END INTERFACE isPyramid + +!---------------------------------------------------------------------------- +! isPyramid@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a Pyramid element + +INTERFACE isPyramid + MODULE PURE FUNCTION isPyramid2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isPyramid2 +END INTERFACE isPyramid + +!---------------------------------------------------------------------------- +! isSerendipityElement@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a SerendipityElement element + +INTERFACE isSerendipityElement + MODULE PURE FUNCTION isSerendipityElement1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + LOGICAL(LGT) :: ans + END FUNCTION isSerendipityElement1 +END INTERFACE isSerendipityElement + +!---------------------------------------------------------------------------- +! isSerendipityElement@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 May 2022 +! summary: Returns true if element is a SerendipityElement element + +INTERFACE isSerendipityElement + MODULE PURE FUNCTION isSerendipityElement2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION isSerendipityElement2 +END INTERFACE isSerendipityElement + +!---------------------------------------------------------------------------- +! ElementTopology@ElementnameMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-10 +! update: 2021-11-10 +! summary: Return the element topology +! +!# Introduction +! +! This routine returns the topology of the reference element +! - Line +! - Triangle +! - Quadrangle +! - Tetrahedron + +INTERFACE ElementTopology + MODULE PURE FUNCTION refelem_ElementTopology1(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION refelem_ElementTopology1 +END INTERFACE ElementTopology + +INTERFACE OPERATOR(.topology.) + MODULE PROCEDURE refelem_ElementTopology1 +END INTERFACE OPERATOR(.topology.) + +!---------------------------------------------------------------------------- +! ElementTopology@ElementnameMethods +!---------------------------------------------------------------------------- + +INTERFACE ElementTopology + MODULE PURE FUNCTION refelem_ElementTopology2(obj) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION refelem_ElementTopology2 +END INTERFACE ElementTopology + +INTERFACE OPERATOR(.topology.) + MODULE PROCEDURE refelem_ElementTopology2 +END INTERFACE OPERATOR(.topology.) + +!---------------------------------------------------------------------------- +! FacetMatrix@FacetElementMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 11 April 2022 +! summary: Returns the facet matrix +! +!# Introduction +! +! Returns the facet matrix of a reference element. +! +! - Number of rows are equal to the number of facet in an element +! - Number of columns = MAX( NNS ) +! - First column => ElementTopology +! - Second Column => XiDimension +! - Third column => NNS +! - 4 to NNS + 3 => Local nptrs + +INTERFACE FacetMatrix + MODULE PURE FUNCTION Facet_Matrix_refelem(refelem) RESULT(FM) + INTEGER(I4B), ALLOCATABLE :: FM(:, :) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + END FUNCTION Facet_Matrix_refelem +END INTERFACE FacetMatrix + +!---------------------------------------------------------------------------- +! FacetElements@FacetElementMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-25 +! summary: This routine returns the facet elements + +INTERFACE GetFacetElements + MODULE SUBROUTINE refelem_GetFacetElements1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE refelem_GetFacetElements1 +END INTERFACE GetFacetElements + +!---------------------------------------------------------------------------- +! FacetElements@FacetElementMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-25 +! summary: This routine returns the facet elements + +INTERFACE GetFacetElements + MODULE SUBROUTINE refelem_GetFacetElements2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE refelem_GetFacetElements2 +END INTERFACE GetFacetElements + +!---------------------------------------------------------------------------- +! FacetTopology@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 June 2021 +! summary: Returns the facet topology of the given element type + +INTERFACE GetFacetTopology + MODULE PURE SUBROUTINE refelem_GetFacetTopology(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE refelem_GetFacetTopology +END INTERFACE GetFacetTopology + +!---------------------------------------------------------------------------- +! LocalNodeCoord@LocalNodeCoordMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 11 April 2022 +! summary: Deprecated +! +!# Introduction +! +! This routine will be removed in near future +! This routine is not included in generic LocalNodeCoord routine + +INTERFACE + MODULE PURE SUBROUTINE Local_NodeCoord(NodeCoord, elemType) + ! Define intent of dummy variables + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: NodeCoord(:, :) + INTEGER(I4B), INTENT(IN) :: elemType + END SUBROUTINE Local_NodeCoord +END INTERFACE + +!---------------------------------------------------------------------------- +! LocalNodeCoord@LocalNodeCoordMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 11 April 2022 +! summary: Returns the local NodeCoord of an element + +INTERFACE LocalNodeCoord + MODULE PURE FUNCTION Local_NodeCoord_refelem(refelem) RESULT(nodecoord) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), ALLOCATABLE :: nodecoord(:, :) + END FUNCTION Local_NodeCoord_refelem +END INTERFACE LocalNodeCoord + +!---------------------------------------------------------------------------- +! MeasureSimplex@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 11 April 2022 +! summary: Returns measures for simplex + +INTERFACE MeasureSimplex + MODULE PURE FUNCTION Measure_Simplex(refelem, XiJ) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: XiJ(:, :) + REAL(DFP) :: ans + END FUNCTION Measure_Simplex +END INTERFACE MeasureSimplex + +!---------------------------------------------------------------------------- +! ElementQuality@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 11 April 2022 +! summary: Measure the quality of the element + +INTERFACE ElementQuality + MODULE FUNCTION Element_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 Element_Quality +END INTERFACE ElementQuality + +!---------------------------------------------------------------------------- +! ContainsPoint@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 11 April 2022 +! summary: Returns true if the given point is inside the element + +INTERFACE ContainsPoint + MODULE FUNCTION contains_point(refelem, xij, x) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP), INTENT(IN) :: x(:) + LOGICAL(LGT) :: ans + END FUNCTION contains_point +END INTERFACE ContainsPoint + +!---------------------------------------------------------------------------- +! TotalEntities@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 June 2021 +! summary: Total entities present in an element + +INTERFACE TotalEntities + MODULE PURE FUNCTION refelem_TotalEntities(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION refelem_TotalEntities +END INTERFACE TotalEntities + +!---------------------------------------------------------------------------- +! getVTKelementType@VTKMethods +!---------------------------------------------------------------------------- + +INTERFACE GetVTKelementType + MODULE PURE SUBROUTINE get_vtk_elemType(elemType, vtk_type, nptrs) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(INT8), INTENT(OUT) :: vtk_type + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: nptrs(:) + END SUBROUTINE get_vtk_elemType +END INTERFACE GetVTKelementType + +END MODULE ReferenceElement_Method diff --git a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 b/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 new file mode 100644 index 000000000..af249edaa --- /dev/null +++ b/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 @@ -0,0 +1,375 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 module contains methods for [[ReferenceHexahedron_]] + +MODULE ReferenceHexahedron_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate +PUBLIC :: ReferenceHexahedron +PUBLIC :: ReferenceHexahedron_Pointer +PUBLIC :: HighorderElement_Hexahedron +PUBLIC :: Measure_Simplex_Hexahedron +PUBLIC :: Hexahedron_Quality +PUBLIC :: Quality_Hexahedron +PUBLIC :: HexahedronVolume3D +PUBLIC :: GetEdgeConnectivity_Hexahedron +PUBLIC :: GetFaceConnectivity_Hexahedron +PUBLIC :: RefCoord_Hexahedron +PUBLIC :: RefHexahedronCoord +PUBLIC :: GetFaceElemType_Hexahedron +PUBLIC :: FacetElements_Hexahedron +PUBLIC :: ElementOrder_Hexahedron +PUBLIC :: ElementType_Hexahedron +PUBLIC :: TotalNodesInElement_Hexahedron +PUBLIC :: TotalEntities_Hexahedron +PUBLIC :: FacetTopology_Hexahedron +PUBLIC :: ElementName_Hexahedron +PUBLIC :: MaxOrder_Hexahedron + +#ifdef MAX_HEXAHEDRON_ORDER +INTEGER(I4B), PARAMETER :: MaxOrder_Hexahedron = MAX_HEXAHEDRON_ORDER +#else +INTEGER(I4B), PARAMETER :: MaxOrder_Hexahedron = 2_I4B +#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_Hexahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION ElementName_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetTopology_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-23 +! summary: Returns the topology of tetrahedron + +INTERFACE + MODULE PURE SUBROUTINE FacetTopology_Hexahedron(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetTopology_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalEntities_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total entities in Hexahedron + +INTERFACE + MODULE PURE FUNCTION TotalEntities_Hexahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION TotalEntities_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total nodes in element + +INTERFACE + MODULE PURE FUNCTION TotalNodesInElement_Hexahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION TotalNodesInElement_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementType_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the type of element from char name + +INTERFACE + MODULE PURE FUNCTION ElementType_Hexahedron(elemName) RESULT(ans) + CHARACTER(*), INTENT(IN) :: elemName + INTEGER(I4B) :: ans + END FUNCTION ElementType_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementOrder_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the order of element + +INTERFACE + MODULE PURE FUNCTION ElementOrder_Hexahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION ElementOrder_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetElements_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Hexahedron + MODULE SUBROUTINE FacetElements_Hexahedron1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Hexahedron1 +END INTERFACE FacetElements_Hexahedron + +!---------------------------------------------------------------------------- +! FacetElements_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Hexahedron + MODULE SUBROUTINE FacetElements_Hexahedron2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Hexahedron2 +END INTERFACE FacetElements_Hexahedron + +!---------------------------------------------------------------------------- +! Initiate@Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This subroutine for constructing the object + +INTERFACE Initiate + MODULE PURE SUBROUTINE Initiate_Ref_Hexahedron(obj, nsd, xij, domainName) + CLASS(ReferenceHexahedron_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + END SUBROUTINE Initiate_Ref_Hexahedron +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! ReferenceHexahedron@Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE ReferenceHexahedron + MODULE PURE FUNCTION Reference_Hexahedron(nsd, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: NSD + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + TYPE(ReferenceHexahedron_) :: obj + END FUNCTION Reference_Hexahedron +END INTERFACE ReferenceHexahedron + +!---------------------------------------------------------------------------- +! ReferenceHexahedron_Pointer@Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE ReferenceHexahedron_Pointer + MODULE FUNCTION Reference_Hexahedron_Pointer(nsd, xij, domainName) & + & RESULT(obj) + INTEGER(I4B), INTENT(IN) :: NSD + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + CLASS(ReferenceHexahedron_), POINTER :: obj + END FUNCTION Reference_Hexahedron_Pointer +END INTERFACE ReferenceHexahedron_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement@Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE HighorderElement_Hexahedron(refelem, order, obj, & + & ipType) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + INTEGER(I4B), INTENT(IN) :: order + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE HighorderElement_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! MeasureSimplex@Geometry +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Measure_Simplex_Hexahedron(refelem, xij) RESULT(Ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: Ans + END FUNCTION Measure_Simplex_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! Hexahedron_quality +!---------------------------------------------------------------------------- + +INTERFACE Quality_Hexahedron + MODULE FUNCTION Hexahedron_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 Hexahedron_Quality +END INTERFACE Quality_Hexahedron + +!---------------------------------------------------------------------------- +! HexahedronVolume3D +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE HexahedronVolume3D(xij, ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP), INTENT(OUT) :: ans + END SUBROUTINE HexahedronVolume3D +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +!> author: Shion Shimizu +! update: 2024-03-22 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetEdgeConnectivity_Hexahedron(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 + !! If opt =2, then edge connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! order default is 1 + 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_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +!> author: Shion Shimizu +! update : 2024-03-22 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetFaceConnectivity_Hexahedron(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 + !! If opt = 1, then face connectivity for hierarchial approximation + !! If opt =2, then face connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! order default is 1 + 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_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! RefHexahedronCoord +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-07 +! summary: Returns coordinates of reference Hexahedron + +INTERFACE RefCoord_Hexahedron + MODULE PURE FUNCTION RefHexahedronCoord(refHexahedron) RESULT(ans) + CHARACTER(*), INTENT(IN) :: refHexahedron + !! UNIT + !! BIUNIT + REAL(DFP) :: ans(3, 8) + END FUNCTION RefHexahedronCoord +END INTERFACE RefCoord_Hexahedron + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE + MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron(faceElemType, opt, & + & tFaceNodes, elemType) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) + !! Face element type + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! This denotes the element type of Hexahedron + !! Default value is Hexahedron6 + END SUBROUTINE GetFaceElemType_Hexahedron +END INTERFACE + +END MODULE ReferenceHexahedron_Method diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Geometry/src/ReferenceLine_Method.F90 new file mode 100644 index 000000000..4a9e9b0e9 --- /dev/null +++ b/src/modules/Geometry/src/ReferenceLine_Method.F90 @@ -0,0 +1,518 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 +USE GlobalData +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 + MODULE PURE SUBROUTINE GetFaceElemType_Line(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_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ReferenceLine_Method diff --git a/src/modules/Geometry/src/ReferencePrism_Method.F90 b/src/modules/Geometry/src/ReferencePrism_Method.F90 new file mode 100644 index 000000000..486e6237e --- /dev/null +++ b/src/modules/Geometry/src/ReferencePrism_Method.F90 @@ -0,0 +1,407 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 module contains methods for [[ReferencePrism_]] + +MODULE ReferencePrism_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +PUBLIC :: PolyhedronVolume3D +PUBLIC :: Initiate +PUBLIC :: ReferencePrism +PUBLIC :: ReferencePrism_Pointer +PUBLIC :: HighOrderElement_Prism +PUBLIC :: Measure_Simplex_Prism +PUBLIC :: Prism_Quality +PUBLIC :: Quality_Prism +PUBLIC :: GetEdgeConnectivity_Prism +PUBLIC :: GetFaceConnectivity_Prism +PUBLIC :: RefCoord_Prism +PUBLIC :: GetFaceElemType_Prism +PUBLIC :: FacetElements_Prism +PUBLIC :: ElementOrder_Prism +PUBLIC :: ElementType_Prism +PUBLIC :: TotalNodesInElement_Prism +PUBLIC :: TotalEntities_Prism +PUBLIC :: FacetTopology_Prism +PUBLIC :: ElementName_Prism +PUBLIC :: MaxOrder_Prism + +#ifdef MAX_PRISM_ORDER +INTEGER(I4B), PARAMETER :: MaxOrder_Prism = MAX_PRISM_ORDER +#else +INTEGER(I4B), PARAMETER :: MaxOrder_Prism = 2_I4B +#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_Prism(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION ElementName_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetTopology_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-23 +! summary: Returns the topology of tetrahedron + +INTERFACE + MODULE PURE SUBROUTINE FacetTopology_Prism(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetTopology_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalEntities_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total entities in Prism + +INTERFACE + MODULE PURE FUNCTION TotalEntities_Prism(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION TotalEntities_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total nodes in element + +INTERFACE + MODULE PURE FUNCTION TotalNodesInElement_Prism(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION TotalNodesInElement_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementType_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the type of element from char name + +INTERFACE + MODULE PURE FUNCTION ElementType_Prism(elemName) RESULT(ans) + CHARACTER(*), INTENT(IN) :: elemName + INTEGER(I4B) :: ans + END FUNCTION ElementType_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementOrder_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the order of element + +INTERFACE + MODULE PURE FUNCTION ElementOrder_Prism(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION ElementOrder_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetElements_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Prism + MODULE SUBROUTINE FacetElements_Prism1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Prism1 +END INTERFACE FacetElements_Prism + +!---------------------------------------------------------------------------- +! FacetElements_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Prism + MODULE SUBROUTINE FacetElements_Prism2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Prism2 +END INTERFACE FacetElements_Prism + +!---------------------------------------------------------------------------- +! Initiate@Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This subroutine for constructing the object + +INTERFACE Initiate + MODULE SUBROUTINE Initiate_Ref_Prism(obj, nsd, xij, domainName) + CLASS(ReferencePrism_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + END SUBROUTINE Initiate_Ref_Prism +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! ReferencePrism@Prism +!---------------------------------------------------------------------------- + +INTERFACE ReferencePrism + MODULE FUNCTION Reference_Prism(nsd, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + TYPE(ReferencePrism_) :: obj + END FUNCTION Reference_Prism +END INTERFACE ReferencePrism + +!---------------------------------------------------------------------------- +! ReferencePrism_Pointer@Prism +!---------------------------------------------------------------------------- + +INTERFACE ReferencePrism_Pointer + MODULE FUNCTION Reference_Prism_Pointer(nsd, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + CLASS(ReferencePrism_), POINTER :: obj + END FUNCTION Reference_Prism_Pointer +END INTERFACE ReferencePrism_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement@Prism +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE highOrderElement_Prism(RefElem, Order, obj, ipType) + CLASS(ReferenceElement_), INTENT(IN) :: RefElem + INTEGER(I4B), INTENT(IN) :: Order + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE highOrderElement_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! MeasureSimplex@Geometry +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Measure_Simplex_Prism(RefElem, XiJ) RESULT(Ans) + CLASS(ReferenceElement_), INTENT(IN) :: RefElem + REAL(DFP), INTENT(IN) :: XiJ(:, :) + REAL(DFP) :: Ans + END FUNCTION Measure_Simplex_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! Prism_Quality +!---------------------------------------------------------------------------- + +INTERFACE Quality_Prism + MODULE FUNCTION Prism_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 Prism_Quality +END INTERFACE Quality_Prism + +!---------------------------------------------------------------------------- +! POLYHEDRONVOLUME3D +!---------------------------------------------------------------------------- + +!> author: John Burkardt, Vikas Sharma +! date: 2023-08-08 +! summary: computes the volume of a polyhedron in 3D. +! +! Licensing: +! This code is distributed under the GNU LGPL license. +! Modified: +! 19 August 2003 +! Author: +! John Burkardt +! Parameters: +! +! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of +! the vertices. The vertices may be listed in any order. +! +! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices +! that make up a face of the polyhedron. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the +! polyhedron. +! +! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is +! defined by +! the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices +! are listed in neighboring order. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in +! COORD. +! +! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices +! making +! up each face. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. + +INTERFACE + MODULE PURE SUBROUTINE PolyhedronVolume3D( & + & coord, order_max, face_num, node, & + & node_num, order, ans) + INTEGER(I4B), INTENT(IN) :: order_max + INTEGER(I4B), INTENT(IN) :: face_num + INTEGER(I4B), INTENT(IN) :: node(face_num, order_max) + INTEGER(I4B), INTENT(IN) :: node_num + REAL(DFP), INTENT(IN) :: coord(3, node_num) + INTEGER(I4B), INTENT(IN) :: order(face_num) + REAL(DFP), INTENT(OUT) :: ans + END SUBROUTINE PolyhedronVolume3D +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetEdgeConnectivity_Prism(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 + !! If opt =2, then edge connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + 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_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetFaceConnectivity_Prism(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 + !! If opt = 1, then face connectivity for hierarchial approximation + !! If opt =2, then face connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + 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_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! RefCoord_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Reference Coordinates of prism + +INTERFACE + MODULE PURE FUNCTION RefCoord_Prism(refPrism) RESULT(ans) + CHARACTER(*), INTENT(IN) :: refPrism + REAL(DFP) :: ans(3, 6) + END FUNCTION RefCoord_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE + MODULE PURE SUBROUTINE GetFaceElemType_Prism(faceElemType, opt, & + & tFaceNodes, elemType) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) + !! Face element type + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! elemType for prism + !! default is Prism + END SUBROUTINE GetFaceElemType_Prism +END INTERFACE + +END MODULE ReferencePrism_Method diff --git a/src/modules/Geometry/src/ReferencePyramid_Method.F90 b/src/modules/Geometry/src/ReferencePyramid_Method.F90 new file mode 100644 index 000000000..64e15d10c --- /dev/null +++ b/src/modules/Geometry/src/ReferencePyramid_Method.F90 @@ -0,0 +1,354 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 module contains methods for [[ReferencePyramid_]] + +MODULE ReferencePyramid_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate +PUBLIC :: ReferencePyramid +PUBLIC :: ReferencePyramid_Pointer +PUBLIC :: HighOrderElement_Pyramid +PUBLIC :: Measure_Simplex_Pyramid +PUBLIC :: Pyramid_Quality +PUBLIC :: Quality_Pyramid +PUBLIC :: GetEdgeConnectivity_Pyramid +PUBLIC :: GetFaceConnectivity_Pyramid +PUBLIC :: RefCoord_Pyramid +PUBLIC :: GetFaceElemType_Pyramid +PUBLIC :: FacetElements_Pyramid +PUBLIC :: ElementOrder_Pyramid +PUBLIC :: ElementType_Pyramid +PUBLIC :: TotalNodesInElement_Pyramid +PUBLIC :: TotalEntities_Pyramid +PUBLIC :: FacetTopology_Pyramid +PUBLIC :: ElementName_Pyramid +PUBLIC :: MaxOrder_Pyramid + +#ifdef MAX_PYRAMID_ORDER +INTEGER(I4B), PARAMETER :: MaxOrder_Pyramid = MAX_PYRAMID_ORDER +#else +INTEGER(I4B), PARAMETER :: MaxOrder_Pyramid = 2_I4B +#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_Pyramid(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION ElementName_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetTopology_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-23 +! summary: Returns the topology of tetrahedron + +INTERFACE + MODULE PURE SUBROUTINE FacetTopology_Pyramid(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetTopology_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalEntities_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total entities in Pyramid + +INTERFACE + MODULE PURE FUNCTION TotalEntities_Pyramid(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION TotalEntities_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total nodes in element + +INTERFACE + MODULE PURE FUNCTION TotalNodesInElement_Pyramid(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION TotalNodesInElement_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementType_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the type of element from char name + +INTERFACE + MODULE PURE FUNCTION ElementType_Pyramid(elemName) RESULT(ans) + CHARACTER(*), INTENT(IN) :: elemName + INTEGER(I4B) :: ans + END FUNCTION ElementType_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementOrder_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the order of element + +INTERFACE + MODULE PURE FUNCTION ElementOrder_Pyramid(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION ElementOrder_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetElements_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Pyramid + MODULE SUBROUTINE FacetElements_Pyramid1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Pyramid1 +END INTERFACE FacetElements_Pyramid + +!---------------------------------------------------------------------------- +! FacetElements_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Pyramid + MODULE SUBROUTINE FacetElements_Pyramid2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Pyramid2 +END INTERFACE FacetElements_Pyramid + +!---------------------------------------------------------------------------- +! Initiate@Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This subroutine for constructing the object + +INTERFACE Initiate + MODULE SUBROUTINE Initiate_Ref_Pyramid(obj, nsd, xij, domainName) + CLASS(ReferencePyramid_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + END SUBROUTINE Initiate_Ref_Pyramid +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! ReferencePyramid@Pyramid +!---------------------------------------------------------------------------- + +INTERFACE ReferencePyramid + MODULE FUNCTION Reference_Pyramid(nsd, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + TYPE(ReferencePyramid_) :: obj + END FUNCTION Reference_Pyramid +END INTERFACE ReferencePyramid + +!---------------------------------------------------------------------------- +! ReferencePyramid_Pointer@Pyramid +!---------------------------------------------------------------------------- + +INTERFACE ReferencePyramid_Pointer + MODULE FUNCTION Reference_Pyramid_Pointer(nsd, xij, domainName) & + & RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + CLASS(ReferencePyramid_), POINTER :: obj + END FUNCTION Reference_Pyramid_Pointer +END INTERFACE ReferencePyramid_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement@Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE HighOrderElement_Pyramid(RefElem, Order, obj, ipType) + CLASS(ReferenceElement_), INTENT(IN) :: RefElem + INTEGER(I4B), INTENT(IN) :: Order + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE HighOrderElement_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! MeasureSimplex@Geometry +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Measure_Simplex_Pyramid(RefElem, XiJ) RESULT(Ans) + CLASS(ReferenceElement_), INTENT(IN) :: RefElem + REAL(DFP), INTENT(IN) :: XiJ(:, :) + REAL(DFP) :: Ans + END FUNCTION Measure_Simplex_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! Pyramid_Quality +!---------------------------------------------------------------------------- + +INTERFACE Quality_Pyramid + MODULE FUNCTION Pyramid_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 Pyramid_Quality +END INTERFACE Quality_Pyramid + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetEdgeConnectivity_Pyramid(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 + !! If opt =2, then edge connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! Order of element + 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_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetFaceConnectivity_Pyramid(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 + !! If opt = 1, then face connectivity for hierarchial approximation + !! If opt =2, then face connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! Order of element + 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_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! RefCoord_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-09 +! summary: Reference Coordinates of pyramid + +INTERFACE + MODULE PURE FUNCTION RefCoord_Pyramid(refPyramid) RESULT(ans) + CHARACTER(*), INTENT(IN) :: refPyramid + REAL(DFP) :: ans(3, 5) + END FUNCTION RefCoord_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE + MODULE PURE SUBROUTINE GetFaceElemType_Pyramid(faceElemType, opt, & + & tFaceNodes, elemType) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) + !! Face element type + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! Element type + END SUBROUTINE GetFaceElemType_Pyramid +END INTERFACE + +END MODULE ReferencePyramid_Method diff --git a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 new file mode 100644 index 000000000..09f3e2cd3 --- /dev/null +++ b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 @@ -0,0 +1,484 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 module contains methods for [[ReferenceQuadrangle_]] + +MODULE ReferenceQuadrangle_Method +USE GlobalData +USE BaseType, ONLY: ReferenceQuadrangle_, ReferenceElement_, & + ReferenceTopology_ +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate +PUBLIC :: ReferenceQuadrangle +PUBLIC :: ReferenceQuadrangle_Pointer +PUBLIC :: HighorderElement_Quadrangle +PUBLIC :: Measure_Simplex_Quadrangle +PUBLIC :: Quadrangle_Quality +PUBLIC :: Quality_Quadrangle +PUBLIC :: QuadArea3D, QuadrangleArea3D +PUBLIC :: QuadArea2D, QuadrangleArea2D +PUBLIC :: QuadrangleName +PUBLIC :: GetEdgeConnectivity_Quadrangle +PUBLIC :: GetFaceConnectivity_Quadrangle +PUBLIC :: RefQuadrangleCoord +PUBLIC :: RefCoord_Quadrangle +PUBLIC :: FaceShapeMetaData_Quadrangle +PUBLIC :: FacetElements_Quadrangle +PUBLIC :: DEFAULT_OPT_QUADRANGLE_EDGE_CON +PUBLIC :: ElementOrder_Quadrangle +PUBLIC :: ElementType_Quadrangle +PUBLIC :: TotalNodesInElement_Quadrangle +PUBLIC :: TotalEntities_Quadrangle +PUBLIC :: FacetTopology_Quadrangle +PUBLIC :: ElementName_Quadrangle +PUBLIC :: MaxOrder_Quadrangle +PUBLIC :: GetFaceElemType_Quadrangle + +#ifdef MAX_QUADRANGLE_ORDER +INTEGER(I4B), PARAMETER :: MaxOrder_Quadrangle = MAX_QUADRANGLE_ORDER +#else +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]) + +#ifdef QUADRANGLE_EDGE_CON_DEFAULT_OPT_1 +INTEGER(I4B), PARAMETER :: DEFAULT_OPT_QUADRANGLE_EDGE_CON = 1_I4B +!! This means edges are [1,2], [4,3], [1,4], [2, 3] +#else +INTEGER(I4B), PARAMETER :: DEFAULT_OPT_QUADRANGLE_EDGE_CON = 2_I4B +!! This means edges are [1,2], [2,3], [3,4], [4,1] +!! This is default option +#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_Quadrangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION ElementName_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetTopology@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the facet topology of the given element type + +INTERFACE + MODULE PURE SUBROUTINE FacetTopology_Quadrangle(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetTopology_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalEntities_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total entities + +INTERFACE + MODULE PURE FUNCTION TotalEntities_Quadrangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION TotalEntities_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total nodes in element + +INTERFACE + MODULE PURE FUNCTION TotalNodesInElement_Quadrangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION TotalNodesInElement_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementType_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the type of element from char name + +INTERFACE + MODULE PURE FUNCTION ElementType_Quadrangle(elemName) RESULT(ans) + CHARACTER(*), INTENT(IN) :: elemName + INTEGER(I4B) :: ans + END FUNCTION ElementType_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementOrder_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the order of element + +INTERFACE + MODULE PURE FUNCTION ElementOrder_Quadrangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION ElementOrder_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetElements_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Quadrangle + MODULE SUBROUTINE FacetElements_Quadrangle1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Quadrangle1 +END INTERFACE FacetElements_Quadrangle + +!---------------------------------------------------------------------------- +! FacetElements_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Quadrangle + MODULE SUBROUTINE FacetElements_Quadrangle2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Quadrangle2 +END INTERFACE FacetElements_Quadrangle + +!---------------------------------------------------------------------------- +! QuadrangleName +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-17 +! summary: Returns integer name of quadragle from order + +INTERFACE QuadrangleName + MODULE PURE FUNCTION QuadrangleName1(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION QuadrangleName1 +END INTERFACE QuadrangleName + +!---------------------------------------------------------------------------- +! Initiate@Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: Returns linear quadrangle element + +INTERFACE Initiate + MODULE PURE SUBROUTINE initiate_ref_Quadrangle(obj, NSD, xij, domainName) + CLASS(ReferenceQuadrangle_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: NSD + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + END SUBROUTINE initiate_ref_Quadrangle +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! ReferenceQuadrangle@Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: Returns Lienar Quadrangle element + +INTERFACE ReferenceQuadrangle + MODULE PURE FUNCTION reference_Quadrangle(NSD, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: NSD + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + TYPE(ReferenceQuadrangle_) :: obj + END FUNCTION reference_Quadrangle +END INTERFACE ReferenceQuadrangle + +!---------------------------------------------------------------------------- +! ReferenceQuadrangle_Pointer@Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: Returns linear Quadrangle element + +INTERFACE ReferenceQuadrangle_Pointer + MODULE FUNCTION reference_Quadrangle_Pointer(NSD, xij, domainName) & + & RESULT(obj) + INTEGER(I4B), INTENT(IN) :: NSD + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + CLASS(ReferenceQuadrangle_), POINTER :: obj + END FUNCTION reference_Quadrangle_Pointer +END INTERFACE ReferenceQuadrangle_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement@Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: Higher order lagrange elements +! +!### Usage +! +!```fortran +! subroutine test4 +! class( ReferenceElement_ ), pointer :: obj_ptr => null() +! type( ReferenceQuadrangle_ ) :: obj +! obj_ptr => referenceQuadrangle_pointer( nsd = 2 ) +! call obj_ptr%LagrangeElement( order = 2, Highorderobj = obj ) +! call display( obj, "higher order obj : ") +! call obj_ptr%LagrangeElement( order = 3, Highorderobj = obj ) +! call display( obj, "3rd order obj : ") +! end +!``` + +INTERFACE + MODULE SUBROUTINE HighorderElement_Quadrangle(refelem, order, obj, & + & ipType) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + INTEGER(I4B), INTENT(IN) :: order + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE HighorderElement_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! MeasureSimplex@Geometry +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Measure_Simplex_Quadrangle(refelem, xij) RESULT(Ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: Ans + END FUNCTION Measure_Simplex_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! Quadrangle_quality +!---------------------------------------------------------------------------- + +INTERFACE Quality_Quadrangle + MODULE FUNCTION Quadrangle_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 Quadrangle_Quality +END INTERFACE Quality_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Aug 2022 +! summary: Area of quadrangle in 3D +! +!# Introduction +! +!- QUADAREA3D computes the area of a quadrilateral in 3D. +!- A quadrilateral is a polygon defined by 4 vertices. +! It is assumed that the four vertices of the quadrilateral +! are coplanar. +!- This algorithm computes the area of the related Varignon parallelogram +! first. + +INTERFACE QuadrangleArea3D + MODULE PURE SUBROUTINE QuadArea3D(q, ans) + REAL(DFP), INTENT(IN) :: q(3, 4) + REAL(DFP), INTENT(OUT) :: ans + END SUBROUTINE QuadArea3D +END INTERFACE QuadrangleArea3D + +!---------------------------------------------------------------------------- +! QuadrangleArea2D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Aug 2022 +! summary: QuadArea2D +! +!# Introduction +! +!- QUADAREA2D computes the area of a quadrilateral in 2D. +!- A quadrilateral is a polygon defined by 4 vertices. +! This algorithm should be able to handle nonconvex quadrilaterals. +! The vertices of the quadrilateral should be listed in counter clockwise +! order, so that the area is positive. + +INTERFACE QuadrangleArea2D + MODULE PURE SUBROUTINE QuadArea2D(q, ans) + REAL(DFP), INTENT(IN) :: q(2, 4) + REAL(DFP), INTENT(OUT) :: ans + END SUBROUTINE QuadArea2D +END INTERFACE QuadrangleArea2D + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetEdgeConnectivity_Quadrangle(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 + !! If opt =2, then edge connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! Order of the element + 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_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Returns face connectivity +! +!# Introduction +! +! this routine calls [[GetEdgeConnectivity_Quadrangle]] +! with opt=2 + +INTERFACE + MODULE PURE SUBROUTINE GetFaceConnectivity_Quadrangle(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 not used + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! Order of the element + 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_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! RefQuadrangleCoord +!---------------------------------------------------------------------------- + +INTERFACE RefCoord_Quadrangle + MODULE PURE FUNCTION RefQuadrangleCoord(refQuadrangle) RESULT(ans) + CHARACTER(*), INTENT(IN) :: refQuadrangle + REAL(DFP) :: ans(2, 4) + END FUNCTION RefQuadrangleCoord +END INTERFACE RefCoord_Quadrangle + +!---------------------------------------------------------------------------- +! FaceShapeMetaData_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-13 +! summary: Returns meta data for global orientation of face + +INTERFACE + MODULE SUBROUTINE FaceShapeMetaData_Quadrangle(face, sorted_face, & + & faceOrient, localFaces) + INTEGER(I4B), INTENT(INOUT) :: face(:) + INTEGER(I4B), INTENT(INOUT) :: sorted_face(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceOrient(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: localFaces(:) + END SUBROUTINE FaceShapeMetaData_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceElemType_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Returns the element type of each face + +INTERFACE +MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(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_Quadrangle +END INTERFACE + +END MODULE ReferenceQuadrangle_Method diff --git a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 b/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 new file mode 100644 index 000000000..6dd64c981 --- /dev/null +++ b/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 @@ -0,0 +1,368 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 module contains methods for [[ReferenceTetrahedron_]] + +MODULE ReferenceTetrahedron_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate +PUBLIC :: ReferenceTetrahedron +PUBLIC :: ReferenceTetrahedron_Pointer +PUBLIC :: HighOrderElement_Tetrahedron +PUBLIC :: Measure_Simplex_Tetrahedron +PUBLIC :: Tetrahedron_Quality +PUBLIC :: TetrahedronVolume3D +PUBLIC :: Quality_Tetrahedron +PUBLIC :: GetEdgeConnectivity_Tetrahedron +PUBLIC :: GetFaceConnectivity_Tetrahedron +PUBLIC :: RefCoord_Tetrahedron +PUBLIC :: GetFaceElemType_Tetrahedron +PUBLIC :: FacetElements_Tetrahedron +PUBLIC :: ElementOrder_Tetrahedron +PUBLIC :: ElementType_Tetrahedron +PUBLIC :: TotalNodesInElement_Tetrahedron +PUBLIC :: TotalEntities_Tetrahedron +PUBLIC :: FacetTopology_Tetrahedron +PUBLIC :: ElementName_Tetrahedron +PUBLIC :: MaxOrder_Tetrahedron + +#ifdef MAX_TETRAHEDRON_ORDER +INTEGER(I4B), PARAMETER :: MaxOrder_Tetrahedron = MAX_TETRAHEDRON_ORDER +#else +INTEGER(I4B), PARAMETER :: MaxOrder_Tetrahedron = 2_I4B +#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_Tetrahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION ElementName_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetTopology_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-23 +! summary: Returns the topology of tetrahedron + +INTERFACE + MODULE PURE SUBROUTINE FacetTopology_Tetrahedron(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetTopology_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalEntities_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total entities in Tetrahedron + +INTERFACE + MODULE PURE FUNCTION TotalEntities_Tetrahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION TotalEntities_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total nodes in element + +INTERFACE + MODULE PURE FUNCTION TotalNodesInElement_Tetrahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION TotalNodesInElement_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementType_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the type of element from char name + +INTERFACE + MODULE PURE FUNCTION ElementType_Tetrahedron(elemName) RESULT(ans) + CHARACTER(*), INTENT(IN) :: elemName + INTEGER(I4B) :: ans + END FUNCTION ElementType_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementOrder_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the order of element + +INTERFACE + MODULE PURE FUNCTION ElementOrder_Tetrahedron(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION ElementOrder_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetElements_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Tetrahedron + MODULE SUBROUTINE FacetElements_Tetrahedron1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Tetrahedron1 +END INTERFACE FacetElements_Tetrahedron + +!---------------------------------------------------------------------------- +! FacetElements_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Tetrahedron + MODULE SUBROUTINE FacetElements_Tetrahedron2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Tetrahedron2 +END INTERFACE FacetElements_Tetrahedron + +!---------------------------------------------------------------------------- +! Initiate@Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This subroutine for constructing the object + +INTERFACE Initiate + MODULE PURE SUBROUTINE Initiate_Ref_Tetrahedron(obj, nsd, xij, domainName) + CLASS(ReferenceTetrahedron_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + END SUBROUTINE Initiate_Ref_Tetrahedron +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! ReferenceTetrahedron@Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE ReferenceTetrahedron + MODULE PURE FUNCTION reference_Tetrahedron(nsd, xij, domainName) & + & RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + TYPE(ReferenceTetrahedron_) :: obj + END FUNCTION reference_Tetrahedron +END INTERFACE ReferenceTetrahedron + +!---------------------------------------------------------------------------- +! ReferenceTetrahedron_Pointer@Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE ReferenceTetrahedron_Pointer + MODULE FUNCTION reference_Tetrahedron_Pointer(nsd, xij, domainName) & + & RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + CLASS(ReferenceTetrahedron_), POINTER :: obj + END FUNCTION reference_Tetrahedron_Pointer +END INTERFACE ReferenceTetrahedron_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement@Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE HighOrderElement_Tetrahedron(refelem, order, obj, ipType) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + INTEGER(I4B), INTENT(IN) :: order + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE HighOrderElement_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! MeasureSimplex@Geometry +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Measure_Simplex_Tetrahedron(RefElem, XiJ) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: RefElem + REAL(DFP), INTENT(IN) :: XiJ(:, :) + REAL(DFP) :: ans + END FUNCTION Measure_Simplex_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! Tetrahedron_Quality +!---------------------------------------------------------------------------- + +INTERFACE Quality_Tetrahedron + MODULE FUNCTION Tetrahedron_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 Tetrahedron_Quality +END INTERFACE Quality_Tetrahedron + +!---------------------------------------------------------------------------- +! TetrahedronVolume3D +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE TetrahedronVolume3D(xij, ans) + REAL(DFP), INTENT(IN) :: xij(3, 4) + REAL(DFP), INTENT(OUT) :: ans + END SUBROUTINE TetrahedronVolume3D +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetEdgeConnectivity_Tetrahedron(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 + !! If opt =2, then edge connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! Order of the edge + 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_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetFaceConnectivity_Tetrahedron(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 + !! If opt = 1, then face connectivity for hierarchial approximation + !! If opt =2, then face connectivity for Lagrangian approximation + !! opt=1 is default + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! order + 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_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! RefCoord_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference Tetrahedron + +INTERFACE + MODULE PURE FUNCTION RefCoord_Tetrahedron(refTetrahedron) RESULT(ans) + CHARACTER(*), INTENT(IN) :: refTetrahedron + REAL(DFP) :: ans(3, 4) + END FUNCTION RefCoord_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! 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) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) + !! Face element type + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: 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 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! element type for Tetrahedron + !! default is Tetrahedron4 + END SUBROUTINE GetFaceElemType_Tetrahedron +END INTERFACE + +END MODULE ReferenceTetrahedron_Method diff --git a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 b/src/modules/Geometry/src/ReferenceTriangle_Method.F90 new file mode 100644 index 000000000..2e71a0e39 --- /dev/null +++ b/src/modules/Geometry/src/ReferenceTriangle_Method.F90 @@ -0,0 +1,825 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 module contains method for [[ReferenceTriangle_]] data type. + +MODULE ReferenceTriangle_Method +USE GlobalData +USE BaseType, ONLY: ReferenceElement_, ReferenceTopology_, ReferenceTriangle_ +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate +PUBLIC :: ReferenceTriangle +PUBLIC :: ReferenceTriangle_Pointer +PUBLIC :: HighorderElement_Triangle +PUBLIC :: Measure_Simplex_Triangle +PUBLIC :: Triangle_Contains_Point +PUBLIC :: Contains_Point_Triangle +PUBLIC :: Angles +PUBLIC :: Area +PUBLIC :: ArealVector +PUBLIC :: Barycentric +PUBLIC :: Centroid +PUBLIC :: CircumCenter +PUBLIC :: CircumCircle +PUBLIC :: CircumRadius +PUBLIC :: ContainsLine +PUBLIC :: Diameter +PUBLIC :: EdgeLength +PUBLIC :: Incenter +PUBLIC :: Incircle +PUBLIC :: Inradius +PUBLIC :: Orthocenter +PUBLIC :: DistanceFromPoint +PUBLIC :: NearestPoint +PUBLIC :: RandomPoint +PUBLIC :: Triangle_Quality +PUBLIC :: Quality_Triangle +PUBLIC :: TriangleArea3D +PUBLIC :: TriangleArea2D +PUBLIC :: GetEdgeConnectivity_Triangle +PUBLIC :: GetFaceConnectivity_Triangle +PUBLIC :: RefTriangleCoord +PUBLIC :: RefCoord_Triangle +PUBLIC :: FacetElements_Triangle +PUBLIC :: DEFAULT_OPT_TRIANGLE_EDGE_CON +PUBLIC :: ElementOrder_Triangle +PUBLIC :: ElementType_Triangle +PUBLIC :: TotalNodesInElement_Triangle +PUBLIC :: TotalEntities_Triangle +PUBLIC :: FacetTopology_Triangle +PUBLIC :: ElementName_Triangle +PUBLIC :: MaxOrder_Triangle +PUBLIC :: FaceShapeMetaData_Triangle +PUBLIC :: GetFaceElemType_Triangle + +#ifdef MAX_TRIANGLE_ORDER +INTEGER(I4B), PARAMETER :: MaxOrder_Triangle = MAX_TRIANGLE_ORDER +#else +INTEGER(I4B), PARAMETER :: MaxOrder_Triangle = 2_I4B +#endif + +#ifdef TRIANGLE_EDGE_CON_DEFAULT_OPT_1 +INTEGER(I4B), PARAMETER :: DEFAULT_OPT_TRIANGLE_EDGE_CON = 1_I4B +!! This means edges are [1,2], [1,3], [2,3] +#else +INTEGER(I4B), PARAMETER :: DEFAULT_OPT_TRIANGLE_EDGE_CON = 2_I4B +!! This means edges are [1,2], [2,3], [3,1] +!! This is default option +#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_Triangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION ElementName_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetTopology@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the facet topology of the given element type + +INTERFACE + MODULE PURE SUBROUTINE FacetTopology_Triangle(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetTopology_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalEntities_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total entities + +INTERFACE + MODULE PURE FUNCTION TotalEntities_Triangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION TotalEntities_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total nodes in element + +INTERFACE + MODULE PURE FUNCTION TotalNodesInElement_Triangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION TotalNodesInElement_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementType_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the type of element from char name + +INTERFACE + MODULE PURE FUNCTION ElementType_Triangle(elemName) RESULT(ans) + CHARACTER(*), INTENT(IN) :: elemName + INTEGER(I4B) :: ans + END FUNCTION ElementType_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementOrder_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the order of element + +INTERFACE + MODULE PURE FUNCTION ElementOrder_Triangle(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION ElementOrder_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetElements_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Triangle + MODULE SUBROUTINE FacetElements_Triangle1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Triangle1 +END INTERFACE FacetElements_Triangle + +!---------------------------------------------------------------------------- +! FacetElements_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Triangle + MODULE SUBROUTINE FacetElements_Triangle2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Triangle2 +END INTERFACE FacetElements_Triangle + +!---------------------------------------------------------------------------- +! Initiate@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This routine constructs an instance of [[ReferenceTriangle_]] +! +!# Introduction +! +! - This routine contructs an instance of [[ReferenceTriangle_]] +! - User can specify the coordinates of the trinagle +! +!@note +! This routine will contruct a three node triangle. +! Also, SHAPE(xij) = [3,3] +!@endnote +! +!### Usage +! +!```fortran +! subroutine test1 +! type( ReferenceTriangle_ ) :: obj +! real( dfp ) :: xij( 3, 3 ) +! xij( 1, 1:3 ) = [1.0, 2.0, 1.0] +! xij( 2, 1:3 ) = [0.0, 0.0, 1.0] +! xij( 3, : ) = 0.0 +! call initiate( obj, nsd = 2, xij = xij ) +! call display( obj, "obj : " ) +! end +!``` + +INTERFACE Initiate + MODULE PURE SUBROUTINE Initiate_Ref_Triangle(obj, nsd, xij, domainName) + CLASS(ReferenceTriangle_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + END SUBROUTINE Initiate_Ref_Triangle +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! ReferenceTriangle@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This function returns an instance of [[ReferenceTriangle_]] +! +!# Introduction +! * This routine contructs an instance of [[ReferenceTriangle_]] +! * User can specify the coordinates of the trinagle +!@note +! This routine will contruct a three node triangle. Also, SHAPE(xij) = [3,3] +!@endnote +! +!### Usage +! +!```fortran +! subroutine test2 +! type( ReferenceTriangle_ ) :: obj +! obj = referenceTriangle( nsd = 2 ) +! call display( obj, "obj : " ) +! end +!``` + +INTERFACE ReferenceTriangle + MODULE PURE FUNCTION Reference_Triangle(nsd, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + TYPE(ReferenceTriangle_) :: obj + END FUNCTION Reference_Triangle +END INTERFACE ReferenceTriangle + +!---------------------------------------------------------------------------- +! ReferenceTriangle_Pointer@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This function returns an instance of [[ReferenceTriangle_]] +! +!# Introduction +! * This routine contructs an instance of [[ReferenceTriangle_]] +! * User can specify the coordinates of the trinagle +!@note +!This routine will contruct a three node triangle. Also, SHAPE(xij) = [3,3] +!@endnote +! +!### Usage +! +!```fortran +! subroutine test3 +! class( ReferenceElement_ ), pointer :: obj => null() +! obj => referenceTriangle_pointer( nsd = 2 ) +! call display( obj, "obj : " ) +! end +!``` + +INTERFACE ReferenceTriangle_Pointer + MODULE FUNCTION Reference_Triangle_Pointer(nsd, xij, domainName) & + & RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName + CLASS(ReferenceTriangle_), POINTER :: obj + END FUNCTION Reference_Triangle_Pointer +END INTERFACE ReferenceTriangle_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: Returns lagrange Triangle element of higher order +! +!# Introduction +! This routine retuns the lagrance element of higher order +! This routine will be called by [[ReferenceTriangle_:LagrangeElement]] +! Currently upto 3rd order triangle elements are supported. +! +!### Usage +! +!```fortran +! subroutine test4 +! class( ReferenceElement_ ), pointer :: obj_ptr => null() +! type( ReferenceTriangle_ ) :: obj +! obj_ptr => referenceTriangle_pointer( nsd = 2 ) +! call obj_ptr%highorderElement( order = 2, Highorderobj = obj ) +! call display( obj, "higher order obj : ") +! call obj_ptr%highorderElement( order = 3, Highorderobj = obj ) +! call display( obj, "3rd order obj : ") +! end +!``` + +INTERFACE + MODULE SUBROUTINE HighorderElement_Triangle(refelem, order, obj, ipType) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + INTEGER(I4B), INTENT(IN) :: order + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE HighorderElement_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! MeasureSimplex@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns the measure of linear triangle +! +!# Introduction +! +! This function returns the measure of linear triangle. This function belongs +! to the generic function [[ReferenceElement_Method:MeasureSimplex]]. + +INTERFACE + MODULE PURE FUNCTION Measure_Simplex_Triangle(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans + END FUNCTION Measure_Simplex_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! Angles@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns three angles of a triangle + +INTERFACE Angles + MODULE PURE FUNCTION Triangle_angles(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(3) + END FUNCTION Triangle_angles +END INTERFACE Angles + +!---------------------------------------------------------------------------- +! Area@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns the area of triangle + +INTERFACE Area + MODULE PURE FUNCTION Triangle_area(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans + END FUNCTION Triangle_area +END INTERFACE Area + +!---------------------------------------------------------------------------- +! ArealVector@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns the area vector + +INTERFACE ArealVector + MODULE PURE FUNCTION Triangle_arealVector(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(3) + END FUNCTION Triangle_arealVector +END INTERFACE ArealVector + +!---------------------------------------------------------------------------- +! Barycentric@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns the barycentric coordinates of triangle + +INTERFACE Barycentric + MODULE PURE FUNCTION Triangle_barycentric(refelem, xij, x) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(3) + END FUNCTION Triangle_barycentric +END INTERFACE Barycentric + +!---------------------------------------------------------------------------- +! Centroid@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns the centroid of a triangle + +INTERFACE Centroid + MODULE PURE FUNCTION Triangle_centroid(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(3) + END FUNCTION Triangle_centroid +END INTERFACE Centroid + +!---------------------------------------------------------------------------- +! CircumCenter@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns the circum center of the triangle + +INTERFACE CircumCenter + MODULE PURE FUNCTION Triangle_circumcentre(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(3) + END FUNCTION Triangle_circumcentre +END INTERFACE CircumCenter + +!---------------------------------------------------------------------------- +! CircumCircle@Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: Returns circum circle of triangle + +INTERFACE CircumCircle + MODULE PURE FUNCTION Triangle_circumcircle(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(4) + !! ans(1) = radius and ans(2:4) center + END FUNCTION Triangle_circumcircle +END INTERFACE CircumCircle + +!---------------------------------------------------------------------------- +! CircumRadius@Triangle +!---------------------------------------------------------------------------- + +INTERFACE CircumRadius + MODULE PURE FUNCTION Triangle_circumradius(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans + END FUNCTION Triangle_circumradius +END INTERFACE CircumRadius + +!---------------------------------------------------------------------------- +! ContainsLine@Triangle +!---------------------------------------------------------------------------- + +INTERFACE ContainsLine + MODULE PURE SUBROUTINE Triangle_contains_line(refelem, xij, x1, x2, & + & parametricLine, inside, xint) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :), x1(3), x2(3) + LOGICAL(LGT), INTENT(IN) :: parametricLine + LOGICAL(LGT), INTENT(OUT) :: inside + REAL(DFP), INTENT(OUT) :: xint(3) + END SUBROUTINE Triangle_contains_line +END INTERFACE ContainsLine + +!---------------------------------------------------------------------------- +! ContainsPoint@Triangle +!---------------------------------------------------------------------------- + +INTERFACE Contains_Point_Triangle + MODULE PURE FUNCTION Triangle_Contains_Point(refelem, xij, x) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :), x(:) + LOGICAL(LGT) :: ans + END FUNCTION Triangle_Contains_Point +END INTERFACE Contains_Point_Triangle + +!---------------------------------------------------------------------------- +! Diameter@Triangle +!---------------------------------------------------------------------------- + +INTERFACE Diameter + MODULE PURE FUNCTION triangle_diameter(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans + END FUNCTION triangle_diameter +END INTERFACE Diameter + +!---------------------------------------------------------------------------- +! EdgeLength@Triangle +!---------------------------------------------------------------------------- + +INTERFACE EdgeLength + MODULE PURE FUNCTION triangle_edge_length(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(3) + END FUNCTION triangle_edge_length +END INTERFACE EdgeLength + +!---------------------------------------------------------------------------- +! Incenter@Triangle +!---------------------------------------------------------------------------- + +INTERFACE Incenter + MODULE PURE FUNCTION triangle_incenter(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(3) + END FUNCTION triangle_incenter +END INTERFACE Incenter + +!---------------------------------------------------------------------------- +! Incircle@Triangle +!---------------------------------------------------------------------------- + +INTERFACE Incircle + MODULE PURE FUNCTION triangle_incircle(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(4) + END FUNCTION triangle_incircle +END INTERFACE Incircle + +!---------------------------------------------------------------------------- +! Inradius@Triangle +!---------------------------------------------------------------------------- + +INTERFACE Inradius + MODULE PURE FUNCTION triangle_inradius(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans + END FUNCTION triangle_inradius +END INTERFACE Inradius + +!---------------------------------------------------------------------------- +! Orthocenter@Triangle +!---------------------------------------------------------------------------- + +INTERFACE Orthocenter + MODULE PURE FUNCTION triangle_orthocenter(refelem, xij) RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: ans(3) + END FUNCTION triangle_orthocenter +END INTERFACE Orthocenter + +!---------------------------------------------------------------------------- +! DistanceFromPoint@Triangle +!---------------------------------------------------------------------------- + +INTERFACE DistanceFromPoint + MODULE PURE FUNCTION triangle_point_dist(refelem, xij, x) & + & RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :), x(:) + REAL(DFP) :: ans + END FUNCTION triangle_point_dist +END INTERFACE DistanceFromPoint + +!---------------------------------------------------------------------------- +! NearestPoint@Triangle +!---------------------------------------------------------------------------- + +INTERFACE NearestPoint + MODULE PURE SUBROUTINE triangle_get_nearest_point(refelem, xij, x, xn, & + & dist) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :), x(:) + REAL(DFP), INTENT(INOUT) :: xn(:) + REAL(DFP), INTENT(OUT) :: dist + END SUBROUTINE triangle_get_nearest_point +END INTERFACE NearestPoint + +!---------------------------------------------------------------------------- +! RandomPoint@Triangle +!---------------------------------------------------------------------------- + +INTERFACE RandomPoint + MODULE PURE FUNCTION triangle_random_point(refelem, xij, n, seed) & + & RESULT(ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + REAL(DFP) :: ans(3, n) + END FUNCTION triangle_random_point +END INTERFACE RandomPoint + +!---------------------------------------------------------------------------- +! Quality@Triangle +!---------------------------------------------------------------------------- + +INTERFACE Quality_Triangle + MODULE PURE FUNCTION Triangle_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 Triangle_Quality +END INTERFACE Quality_Triangle + +!---------------------------------------------------------------------------- +! TriangleArea3D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Aug 2022 +! summary: Area of triangle in 3D +! +!# Introduction +! +!- TRIANGLEAREA3D computes the area of a triangle in 3D. +!- This routine uses the fact that the norm of the cross product +! of two vectors is the area of the parallelogram they form. +! Therefore, the area of the triangle is half of that value. + +INTERFACE + MODULE PURE SUBROUTINE TriangleArea3D(t, ans) + REAL(DFP), INTENT(IN) :: t(3, 3) + REAL(DFP), INTENT(OUT) :: ans + END SUBROUTINE TriangleArea3D +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Aug 2022 +! summary: Return are of triangle in 2D +! +!# Introduction +! +!- TRIANGLEAREA2D computes the area of a triangle in 2D. +!- If the triangle's vertices are given in counter clockwise order, +! the area will be positive. If the triangle's vertices are given +! in clockwise order, the area will be negative! + +INTERFACE + MODULE PURE SUBROUTINE TriangleArea2D(t, ans) + REAL(DFP), INTENT(IN) :: t(2, 3) + REAL(DFP), INTENT(OUT) :: ans + END SUBROUTINE TriangleArea2D +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-08 +! summary: Returns number of edges in the element + +INTERFACE + MODULE PURE SUBROUTINE GetEdgeConnectivity_Triangle(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_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Get the face connectivity of triangle +! +!# Introduction +! +! This routine calls [[GetEdgeConnectivity_Triangle]] with opt=2 + +INTERFACE + MODULE PURE SUBROUTINE GetFaceConnectivity_Triangle(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_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! RefTriangleCoord +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference triangle + +INTERFACE RefCoord_Triangle + MODULE PURE FUNCTION RefTriangleCoord(refTriangle) RESULT(ans) + CHARACTER(*), INTENT(IN) :: refTriangle + REAL(DFP) :: ans(2, 3) + END FUNCTION RefTriangleCoord +END INTERFACE RefCoord_Triangle + +!---------------------------------------------------------------------------- +! FaceShapeMetaData_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-13 +! summary: Returns meta data for global orientation of face + +INTERFACE + MODULE SUBROUTINE FaceShapeMetaData_Triangle(face, sorted_face, & + faceOrient, localFaces) + INTEGER(I4B), INTENT(INOUT) :: face(:) + INTEGER(I4B), INTENT(INOUT) :: sorted_face(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceOrient(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: localFaces(:) + END SUBROUTINE FaceShapeMetaData_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Returns the element type of each face + +INTERFACE +MODULE PURE SUBROUTINE GetFaceElemType_Triangle(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_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ReferenceTriangle_Method diff --git a/src/modules/Geometry/src/Triangle_Method.F90 b/src/modules/Geometry/src/Triangle_Method.F90 new file mode 100644 index 000000000..62db70829 --- /dev/null +++ b/src/modules/Geometry/src/Triangle_Method.F90 @@ -0,0 +1,1505 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 28 Aug 2022 +! summary: Triangle geometry MODULE +! +!# Introduction +! +! This MODULE is just a carbon copy of the MODULE written by +! professor John Burkardt. The original code is kept in the directory +! named "./assets/geometry_burkardt_triangle.inc". +! +! I have just restructured the code according to the code style of +! easifem. + +MODULE Triangle_Method +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: triangle_angles_2d +PUBLIC :: triangle_angles_3d +PUBLIC :: triangle_area_2d +PUBLIC :: triangle_area_3d +PUBLIC :: triangle_area_3d_2 +PUBLIC :: triangle_area_3d_3 +PUBLIC :: triangle_area_heron +PUBLIC :: triangle_area_vector_3d +PUBLIC :: triangle_barycentric_2d +PUBLIC :: triangle_centroid_2d +PUBLIC :: triangle_centroid_3d +PUBLIC :: triangle_circumcenter_2d +PUBLIC :: triangle_circumcenter_2d_2 +PUBLIC :: triangle_circumcenter +PUBLIC :: triangle_circumcircle_2d +PUBLIC :: triangle_circumcircle_2d_2 +PUBLIC :: triangle_circumradius_2d +PUBLIC :: triangle_contains_line_exp_3d +PUBLIC :: triangle_contains_line_par_3d +PUBLIC :: triangle_contains_point_2d_1 +PUBLIC :: triangle_contains_point_2d_2 +PUBLIC :: triangle_contains_point_2d_3 +PUBLIC :: triangle_diameter_2d +PUBLIC :: triangle_edge_length_2d +PUBLIC :: triangle_incenter_2d +PUBLIC :: triangle_incircle_2d +PUBLIC :: triangle_inradius_2d +PUBLIC :: triangle_orthocenter_2d +PUBLIC :: triangle_point_dist_2d +PUBLIC :: triangle_point_dist_3d +PUBLIC :: triangle_point_dist_signed_2d +PUBLIC :: triangle_point_near_2d +PUBLIC :: triangle_quality_2d +PUBLIC :: triangle_sample + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Computes the angles of a triangle in 2D. +! +!# Introduction +! +! The law of cosines is used: +! +!$$ +! C^2 = A^2 + B^2 - 2 * A * B * COS ( GAMMA ) +!$$ +! +! where GAMMA is the angle opposite side C. + +INTERFACE + MODULE PURE FUNCTION triangle_angles_2d(t) RESULT(angle) + REAL(DFP), INTENT(IN) :: t(:, :) + !! vertex in xij format + REAL(DFP) :: angle(3) + !! The angles opposite sides P1-P2, P2-P3 and P3-P1, in radians. + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Computes the angles of a triangle in 3D. +! +!# Introduction +! +! The law of cosines is used: +! +!$$ +! C * C = A * A + B * B - 2 * A * B * COS ( GAMMA ) +!$$ +! +! where GAMMA is the angle opposite side C. + +INTERFACE + MODULE PURE FUNCTION triangle_angles_3d(t) RESULT(angle) + REAL(DFP), INTENT(IN) :: t(:, :) + !! vertices in xij format + REAL(DFP) :: angle(3) + !! angle + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: compute area of the triangle +! +!# Introduction +! +! If the triangle's vertices are given in counter clockwise order, +! the area will be positive. If the triangle's vertices are given +! in clockwise order, the area will be negative! +! +! An earlier version of this routine always returned the absolute +! value of the computed area. I am convinced now that that is +! a less useful RESULT! For instance, by returning the signed +! area of a triangle, it is possible to easily compute the area +! of a nonconvex polygon as the sum of the (possibly negative) +! areas of triangles formed by node 1 and successive pairs of vertices. +! + +INTERFACE + MODULE PURE FUNCTION triangle_area_2d(t) RESULT(area) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: area + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: compute area of triangle in 3D +! +!# Introduction +! +! This routine uses the fact that the norm of the cross product +! of two vectors is the area of the parallelogram they form. +! +! Therefore, the area of the triangle is half of that value. + +INTERFACE + MODULE PURE FUNCTION triangle_area_3d(t) RESULT(area) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: area + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: area of triangle in 3D +! +!# Introduction +! +! This routine computes the area "the hard way". + +INTERFACE + MODULE PURE FUNCTION triangle_area_3d_2(t) RESULT(area) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: area + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: area of triangle using Heron's formula + +INTERFACE + MODULE PURE FUNCTION triangle_area_3d_3(t) RESULT(area) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: area + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Area of triangle using Herons formula +! +!# Introduction +! +! The formula is valid for any spatial dimension, depENDing only +! on the lengths of the sides, and not the coordinates of the vertices. + +INTERFACE + MODULE PURE FUNCTION triangle_area_heron(s) RESULT(area) + REAL(DFP), INTENT(IN) :: s(3) + REAL(DFP) :: area + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: compute the area vector of a tri in 3D +! +!# Introduction +! +! The "area vector" of a triangle is simply a cross product of, +! for instance, the vectors (V2-V1) and (V3-V1), where V1, V2 +! and V3 are the vertices of the triangle. +! +! The norm of the cross product vector of two vectors is the area +! of the parallelogram they form. +! +! Therefore, the area of the triangle is half of the norm of the +! area vector: +! +! area = 0.5 * sqrt ( sum ( area_vector(1:3)^2 ) ) +! +! The reason for looking at the area vector rather than the area +! is that this makes it possible to compute the area of a flat +! polygon in 3D by summing the areas of the triangles that form +! a decomposition of the polygon, while allowing for both positive +! and negative areas. (Sum the vectors, THEN take the norm and +! multiply by 1/2). + +INTERFACE + MODULE PURE FUNCTION triangle_area_vector_3d(t) RESULT(area_vector) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: area_vector(3) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Find the barycentric coordinates of a point in 2D +! +!# Introduction +! +! The barycentric coordinate of point P related to vertex A can be +! interpreted as the ratio of the area of the triangle with +! vertex A replaced by vertex P to the area of the original +! triangle. +! +! This routine assumes that the triangle vertices are given in +! counter clockwise order. + +INTERFACE + MODULE PURE FUNCTION triangle_barycentric_2d(t, p) RESULT(xsi) + REAL(DFP), INTENT(IN) :: t(:, :) + !! vertex + REAL(DFP), INTENT(IN) :: p(2) + !! point + REAL(DFP) :: xsi(3) + !! barycentric points + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: compute the centroid of a triangle in 2D +! +!# Introduction +! +! The centroid of a triangle can also be considered the +! center of gravity, or center of mass, assuming that the triangle +! is made of a thin uniform sheet of massy material. +! +! The centroid of a triangle is the intersection of the medians. +! +! A median of a triangle is a line connecting a vertex to the +! midpoint of the opposite side. +! +! In barycentric coordinates, in which the vertices of the triangle +! have the coordinates (1,0,0), (0,1,0) and (0,0,1), the centroid +! has coordinates (1/3,1/3,1/3). +! +! In geometry, the centroid of a triangle is often symbolized by "G". + +INTERFACE + MODULE PURE FUNCTION triangle_centroid_2d(t) RESULT(centroid) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: centroid(2) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: computes the centroid of a triangle in 3D +! +!# Introduction +! +! The centroid of a triangle can also be considered the +! center of gravity or center of mass, assuming that the triangle +! is made of a thin uniform sheet of massy material. +! +! The centroid of a triangle is the intersection of the medians. +! A median of a triangle is a line connecting any vertex to the +! midpoint of the opposite side. + +INTERFACE + MODULE PURE FUNCTION triangle_centroid_3d(t) RESULT(centroid) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: centroid(3) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: cirumcenter of a triangle in 2D +! +!# Introduction +! +! The circumcenter of a triangle is the center of the circumcircle, the +! circle that passes through the three vertices of the triangle. +! +! The circumcircle contains the triangle, but it is not necessarily the +! smallest triangle to do so. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. +! +! The circumcenter is the intersection of the perpENDicular bisectors +! of the sides of the triangle. +! +! In geometry, the circumcenter of a triangle is often symbolized by "O". + +INTERFACE + MODULE PURE FUNCTION triangle_circumcenter_2d(t) RESULT(pc) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: pc(2) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: circum center in 2d +! +!# Introduction +! +! The circumcenter of a triangle is the center of the circumcircle, the +! circle that passes through the three vertices of the triangle. +! +! The circumcircle contains the triangle, but it is not necessarily the +! smallest triangle to do so. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. +! +! The circumcenter is the intersection of the perpENDicular bisectors +! of the sides of the triangle. +! +! Surprisingly, the diameter of the circle can be found by solving +! a 2 by 2 linear system. If we label the vertices of the triangle +! P1, P2 and P3, then the vectors P2 - P1 and P3 - P1 are secants of +! the circle, and each forms a right triangle with the diameter +! vector through P1. +! +! Hence, the dot product of P2 - P1 with the diameter vector is equal +! to the square of the length of P2 - P1, and similarly for P3 - P1. +! This determines the diameter vector originating at P1. +! +! In geometry, the circumcenter of a triangle is often symbolized by "O". +! + +INTERFACE + MODULE PURE FUNCTION triangle_circumcenter_2d_2(t) RESULT(pc) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: pc(2) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: computes the circumcenter of a triangle in ND. +! +!# Introduction +! +! Three ND points A, B and C lie on a circle. +! +! The circumcenter P has the formula +! +! P = ( Area ( PBC ) * A + Area ( APC) * B + Area ( ABP ) * C ) +! / ( Area ( PBC ) + Area ( APC ) + Area ( ABP ) ) +! +! The details of the formula rely on information supplied +! by Oscar Lanzi III. + +INTERFACE + MODULE PURE FUNCTION triangle_circumcenter(n, t) RESULT(p) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: t(:, :) + !! shape (n,3) + REAL(DFP) :: p(n) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: computes the circumcircle of a triangle in 2D +! +!# Introduction +! +! The circumcenter of a triangle is the center of the circumcircle, the +! circle that passes through the three vertices of the triangle. +! +! The circumcircle contains the triangle, but it is not necessarily the +! smallest triangle to do so. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. +! +! The circumcenter is the intersection of the perpENDicular bisectors +! of the sides of the triangle. +! +! In geometry, the circumcenter of a triangle is often symbolized by "O". + +INTERFACE + MODULE PURE SUBROUTINE triangle_circumcircle_2d(t, r, pc) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(OUT) :: pc(2) + !! circum center + REAL(DFP), INTENT(OUT) :: r + !! circum radius + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: circumcircle +! +!# Introduction +! +! The circumscribed circle of a triangle is the circle that passes through +! the three vertices of the triangle. The circumscribed circle contains +! the triangle, but it is not necessarily the smallest triangle to do so. +! +! Surprisingly, the diameter of the circle can be found by solving +! a 2 by 2 linear system. This is because the vectors P2 - P1 +! and P3 - P1 are secants of the circle, and each forms a right +! triangle with the diameter. Hence, the dot product of +! P2 - P1 with the diameter is equal to the square of the length +! of P2 - P1, and similarly for P3 - P1. This determines the +! diameter vector originating at P1. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. + +INTERFACE + MODULE PURE SUBROUTINE triangle_circumcircle_2d_2(t, r, pc) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(OUT) :: pc(2) + !! circum center + REAL(DFP), INTENT(OUT) :: r + !! circum radius + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: triangle circumradius in 2d +! +!# Introduction +! +! The circumscribed circle of a triangle is the circle that passes through +! the three vertices of the triangle. The circumscribed circle contains +! the triangle, but it is not necessarily the smallest triangle to do so. +! +! The circumradius of a triangle is the radius of the circumscribed +! circle. + +INTERFACE + MODULE PURE FUNCTION triangle_circumradius_2d(t) RESULT(r) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: r + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: is a line inside the triangle in 3D +! +!# Introduction +! +! A line will "intersect" the plane of a triangle in 3D if +! * the line does not lie in the plane of the triangle +! (there would be infinitely many intersections), AND +! * the line does not lie parallel to the plane of the triangle +! (there are no intersections at all). +! +! Therefore, if a line intersects the plane of a triangle, it does so +! at a single point. We say the line is "inside" the triangle if, +! regarded as 2D objects, the intersection point of the line and the plane +! is inside the triangle. +! +! A triangle in 3D is determined by three points: +! +! T(1:3,1), T(1:3,2) and T(1:3,3). +! +! The explicit form of a line in 3D is: +! +! the line through the points P1(1:3), P2(1:3). +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(3,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) P1(3), P2(3), two points on the line. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if +! (the intersection point of) +! the line is inside the triangle. +! +! Output, REAL ( kind = 8 ) PINT(3), the point where the line +! intersects the plane of the triangle. + +INTERFACE + MODULE PURE SUBROUTINE triangle_contains_line_exp_3d(t, p1, p2, & + & inside, pint) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p1(3) + REAL(DFP), INTENT(IN) :: p2(3) + LOGICAL(LGT), INTENT(OUT) :: inside + REAL(DFP), INTENT(OUT) :: pint(3) + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: finds if a line is inside a triangle in 3D. +! +!# Introduction +! +! A line will "intersect" the plane of a triangle in 3D if +! * the line does not lie in the plane of the triangle +! (there would be infinitely many intersections), AND +! * the line does not lie parallel to the plane of the triangle +! (there are no intersections at all). +! +! Therefore, if a line intersects the plane of a triangle, it does so +! at a single point. We say the line is "inside" the triangle if, +! regarded as 2D objects, the intersection point of the line and the plane +! is inside the triangle. +! +! A triangle in 3D is determined by three points: +! +! T(1:3,1), T(1:3,2) and T(1:3,3). +! +! The parametric form of a line in 3D is: +! +! P(1:3) = P0(1:3) + PD(1:3) * T +! +! We can normalize by requiring PD to have euclidean norm 1, +! and the first nonzero entry positive. +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(3,3), the three points that define +! the triangle. +! +! Input, REAL ( kind = 8 ) P0(3), PD(3), parameters that define the +! parametric line. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if +! (the intersection point of) +! the line is inside the triangle. +! +! Output, REAL ( kind = 8 ) P(3), is the point of intersection of the line +! and the plane of the triangle, unless they are parallel. + +INTERFACE + MODULE PURE SUBROUTINE triangle_contains_line_par_3d(t, p0, pd, inside, p) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p0(3) + REAL(DFP), INTENT(IN) :: pd(3) + REAL(DFP), INTENT(OUT) :: p(3) + LOGICAL(LGT), INTENT(OUT) :: inside + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: finds if a point is inside the triangle in 2D +! +!# Introduction +! +! It is conventional to list the triangle vertices in counter clockwise +! order. However, this routine does not require a particular order +! for the vertices. +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside +! the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_contains_point_2d_1(t, p) RESULT(inside) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(2) + LOGICAL(LGT) :: inside + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: finds if a poiint is inside a triangle in 2D +! +!# Introduction +! +! The routine assumes that the vertices are given in counter clockwise +! order. If the triangle vertices are actually given in clockwise +! order, this routine will behave as though the triangle contains +! no points whatsoever! +! +! The routine determines if a point P is "to the right of" each of the +! lines +! that bound the triangle. It does this by computing the cross product +! of vectors from a vertex to its next vertex, and to P. +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! The vertices should be given in counter clockwise order. +! +! Input, REAL ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is +! inside the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_contains_point_2d_2(t, p) RESULT(inside) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(2) + LOGICAL(LGT) :: inside + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: returns true if the point is contained inside the triangle +! +!# Introduction +! +! This routine is the same as TRIANGLE_CONTAINS_POINT_2D_2, except +! that it does not assume an ordering of the points. It should +! work correctly whether the vertices of the triangle are listed +! in clockwise or counter clockwise order. +! +! The routine determines if a point P is "to the right of" each of the +! lines +! that bound the triangle. It does this by computing the cross product +! of vectors from a vertex to its next vertex, and to P. +! +! The point is inside the triangle if it is to the right of all +! the lines, or to the left of all the lines. +! +! This version was suggested by Paulo Ernesto of Maptek Brasil. +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is +! inside the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_contains_point_2d_3(t, p) RESULT(inside) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(2) + LOGICAL(LGT) :: inside + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: returns the triangle diameter in 2d +! +!# Introduction +! +! The diameter of a triangle is the diameter of the smallest circle +! that can be drawn around the triangle. At least two of the vertices +! of the triangle will intersect the circle, but not necessarily +! all three! +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, REAL ( kind = 8 ) DIAMETER, the diameter of the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_diameter_2d(t) RESULT(diameter) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: diameter + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: returns edge lengths of a triangle in 2D +! +!# Introduction +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, REAL ( kind = 8 ) EDGE_LENGTH(3), the length of the edges. + +INTERFACE + MODULE PURE FUNCTION triangle_edge_length_2d(t) RESULT(edge_length) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: edge_length(3) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Returns grid points within a triangle in 2D +! +!# Introduction +! +! The gridpoints are computed by repeated halving of the triangle. +! The 0-th set of grid points is the vertices themselves. +! The first set of grid points is the midpoints of the sides. +! These points can be used to draw 4 triangles that make up the original +! triangle. The second set of grid points is the side midpoints and +! centers +! of these four triangles. +! +! SUB_NUM GRID_NUM +! ----- ----- +! 0 1 = 1 (centroid) +! 1 1 + 2 = 3 (vertices) +! 2 1 + 2 + 3 = 6 +! 3 1 + 2 + 3 + 4 = 10 +! 4 1 + 2 + 3 + 4 + 5 = 15 +! +! GRID_NUM is the sum of the integers from 1 to SUB_NUM+1 or +! +! GRID_NUM = (SUB_NUM+1) * (SUB_NUM+2) / 2 +! +!# Parameters: +! +!- Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +!- Input, integer ( kind = 4 ) SUB_NUM, the number of subdivisions. +!- Input, integer ( kind = 4 ) GRID_MAX, the maximum number of grid points. +!- Output, integer ( kind = 4 ) GRID_NUM, the number of grid points +! returned. +!- Output, REAL ( kind = 8 ) G(2,GRID_MAX), the grid points. +! + +INTERFACE + MODULE PURE SUBROUTINE triangle_gridpoints_2d(t, sub_num, grid_max, & + & grid_num, g) + REAL(DFP), INTENT(IN) :: t(:, :) + INTEGER(I4B), INTENT(IN) :: sub_num + INTEGER(I4B), INTENT(IN) :: grid_max + INTEGER(I4B), INTENT(OUT) :: grid_num + REAL(DFP), INTENT(OUT) :: g(2, grid_max) + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: computes the incenter of a triangle in 2D. +! +!# Introduction +! +! The incenter of a triangle is the center of the inscribed circle. +! +! The inscribed circle of a triangle is the largest circle that can +! be drawn inside the triangle. +! +! The inscribed circle is tangent to all three sides of the triangle. +! +! The angle bisectors of the triangle intersect at the center of the +! inscribed circle. +! +! In geometry, the incenter is often represented by "I". +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, REAL ( kind = 8 ) PC(2), the incenter. + +INTERFACE + MODULE PURE FUNCTION triangle_incenter_2d(t) RESULT(pc) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: pc(2) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: computes the inscribed circle of a triangle in 2D. +! +!# Introduction +! +! The inscribed circle of a triangle is the largest circle that can +! be drawn inside the triangle. It is tangent to all three sides, +! and the lines from its center to the vertices bisect the angles +! made by each vertex. +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, REAL ( kind = 8 ) R, PC(2), the radius and center of the +! inscribed circle. + +INTERFACE + MODULE PURE SUBROUTINE triangle_incircle_2d(t, r, pc) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(OUT) :: pc(2) + REAL(DFP), INTENT(OUT) :: r + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Radius of the inscribed circle of a triangle in 2D +! +!# Introduction +! +! The inscribed circle of a triangle is the largest circle that can +! be drawn inside the triangle. It is tangent to all three sides, +! and the lines from its center to the vertices bisect the angles +! made by each vertex. +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! Output, REAL ( kind = 8 ) R, the radius of the inscribed circle. + +INTERFACE + MODULE PURE FUNCTION triangle_inradius_2d(t) RESULT(r) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: r + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: finds if a triangle is degenerate in ND. +! +!# Introduction +! +! A triangle in ND is described by the coordinates of its 3 vertices. +! A triangle in ND is degenerate if any two vertices are equal. +! +!# Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! Input, REAL ( kind = 8 ) T(DIM_NUM,3), the triangle vertices. +! Output, logical ( kind = 4 ) TRIANGLE_IS_DEGENERATE_ND, is TRUE if the +! triangle is degenerate. + +INTERFACE + MODULE PURE FUNCTION triangle_is_degenerate_nd(dim_num, t) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: dim_num + REAL(DFP), INTENT(IN) :: t(dim_num, 3) + LOGICAL(LGT) :: ans + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: next triangle lattice layer point. +! +!# Introduction +! +! The triangle lattice layer L is bounded by the lines +! +! 0 <= X, +! 0 <= Y, +! L - 1 < X / C(1) + Y / C(2) <= L. +! +! In particular, layer L = 0 always contains the single point (0,0). +! +! This FUNCTION returns, one at a time, the points that lie within +! a given triangle lattice layer. +! +! Thus, if we set C(1) = 2, C(2) = 3, then we get the following layers: +! +! L = 0: (0,0) +! L = 1: (1,0), (2,0), (0,1), (1,1), (0,2), (0,3) +! L = 2: (3,0), (4,0), (2,1), (3,1), (1,2), (2,2), (1,3), (2,3), +! (0,4), (1,4), (0,5), (0,6). +! +!# Parameters: +! +!- Input, integer ( kind = 4 ) C(3), coefficients defining the +! lattice layer. Entry C(3) contains the layer index. C(1) and C(2) should +! be positive, and C(3) must be nonnegative. +!- Input/output, integer ( kind = 4 ) V(2). On first call for a given layer, +! the input value of V is not important. On a repeated call for the same +! layer, the input value of V should be the output value from the previous +! call. On output, V contains the next lattice layer point. +!- Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to +! indicate that this is the first call for a given layer. Thereafter, the +! input value should be the output value from the previous call. +! On output, MORE is TRUE if the returned value V is a new point. +! If the output value is FALSE, then no more points were found, +! and V was reset to 0, and the lattice layer has been exhausted. + +INTERFACE + MODULE PURE SUBROUTINE triangle_lattice_layer_point_next(c, v, more) + INTEGER(I4B), INTENT(IN) :: c(3) + INTEGER(I4B), INTENT(INOUT) :: v(2) + LOGICAL(LGT), INTENT(INOUT) :: more + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: returns the next triangle lattice point +! +!# Introduction +! +! The lattice triangle is defined by the vertices: +! +! (0,0), (C(3)/C(1), 0) and (0,C(3)/C(2)) +! +! The lattice triangle is bounded by the lines +! +! 0 <= X, +! 0 <= Y +! X / C(1) + Y / C(2) <= C(3) +! +! Lattice points are listed one at a time, starting at the origin, +! with X increasing first. +! +!# Parameters: +! +! Input, integer ( kind = 4 ) C(3), coefficients defining the +! lattice triangle. These should be positive. +! +! Input/output, integer ( kind = 4 ) V(2). On first call, the input +! value is not important. On a repeated call, the input value should +! be the output value from the previous call. On output, V contains +! the next lattice point. +! +! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to +! indicate that this is the first call for a given triangle. Thereafter, +! the input value should be the output value from the previous call. On +! output, MORE is TRUE if the returned value V is a new lattice point. +! If the output value is FALSE, then no more lattice points were found, +! and V was reset to 0, and the routine should not be called further +! for this triangle. + +INTERFACE + MODULE PURE SUBROUTINE triangle_lattice_point_next(c, v, more) + INTEGER(I4B), INTENT(IN) :: c(3) + INTEGER(I4B), INTENT(INOUT) :: v(2) + LOGICAL(LGT), INTENT(INOUT) :: more + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: implicit line intersects a triangle in 2D. +! +!# Introduction +! +! An implicit line is the set of points ( X, Y ) satisfying +! +! A * X + B * Y + C = 0 +! +! where at least one of A and B is not zero. +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) A, B, C, determine the equation of the line: +! A*X + B*Y + C = 0. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of points of +! intersection +! of the line with the triangle. INT_NUM may be 0, 1, 2 or 3. +! +! Output, REAL ( kind = 8 ) PINT(2,3), contains the intersection points. + +INTERFACE + MODULE PURE SUBROUTINE triangle_line_imp_int_2d(t, a, b, c, int_num, pint) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: a, b, c + INTEGER(I4B), INTENT(OUT) :: int_num + INTEGER(I4B), INTENT(OUT) :: pint(2, 3) + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: determines the orientation of a triangle in 2D. +! +!# Introduction +! +! Three distinct non-colinear points in the plane define a circle. +! If the points are visited in the order P1, P2, and then +! P3, this motion defines a clockwise or counter clockwise +! rotation along the circle. +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, integer ( kind = 4 ) TRIANGLE_ORIENTATION_2D, reports if the +! three points lie clockwise on the circle that passes through them. +! The possible return values are: +! 0, the points are distinct, noncolinear, and lie counter clockwise +! on their circle. +! 1, the points are distinct, noncolinear, and lie clockwise +! on their circle. +! 2, the points are distinct and colinear. +! 3, at least two of the points are identical. + +INTERFACE + MODULE PURE FUNCTION triangle_orientation_2d(t) RESULT(ans) + REAL(DFP), INTENT(IN) :: t(:, :) + INTEGER(I4B) :: ans + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: computes the orthocenter of a triangle in 2D. +! +!# Introduction +! +! The orthocenter is defined as the intersection of the three altitudes +! of a triangle. +! +! An altitude of a triangle is the line through a vertex of the triangle +! and perpENDicular to the opposite side. +! +! In geometry, the orthocenter of a triangle is often symbolized by "H". +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, REAL ( kind = 8 ) PC(2), the orthocenter of the triangle. +! +! Output, logical ( kind = 4 ) FLAG, is TRUE if the value could not +! be computed. + +INTERFACE + MODULE PURE FUNCTION triangle_orthocenter_2d(t) RESULT(pc) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: pc(2) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: distance ( triangle, point ) in 2D +! +!# Introduction +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) P(2), the point to be checked. +! +! Output, REAL ( kind = 8 ) DIST, the distance from the point to the +! triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_point_dist_2d(t, p) RESULT(dist) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(:) + REAL(DFP) :: dist + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: distance ( triangle, point ) in 3D. +! +!# Introduction +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(3,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) P(3), the point which is to be checked. +! +! Output, REAL ( kind = 8 ) DIST, the distance from the point to the +! triangle. DIST is zero if the point lies exactly on the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_point_dist_3d(t, p) RESULT(dist) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(:) + REAL(DFP) :: dist + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: signed distance in 2D +! +!# Introduction +! +! If the signed distance is: +! 0, the point is on the boundary of the triangle; +! negative, the point is in the triangle; +! positive, the point is outside the triangle. +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! These should be given in counter clockwise order. +! +! Input, REAL ( kind = 8 ) P(2), the point which is to be checked. +! +! Output, REAL ( kind = 8 ) DIST_SIGNED, the signed distance from the +! point to the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_point_dist_signed_2d(t, p) RESULT(dist_signed) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(2) + REAL(DFP) :: dist_signed + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: computes the nearest point on a triangle in 2D. +! +!# Introduction +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) P(2), the point whose nearest triangle point +! is to be determined. +! +! Output, REAL ( kind = 8 ) PN(2), the nearest point to P. +! +! Output, REAL ( kind = 8 ) DIST, the distance from the point to the +! triangle. + +INTERFACE + MODULE PURE SUBROUTINE triangle_point_near_2d(t, p, pn, dist) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(2) + REAL(DFP), INTENT(OUT) :: pn(2) + REAL(DFP), INTENT(OUT) :: dist + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: "quality" of a triangle in 2D. +! +!# Introduction +! +! The quality of a triangle is 2.0 times the ratio of the radius of +! the inscribed circle divided by that of the circumscribed circle. +! An equilateral triangle achieves the maximum possible quality of 1. +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! Output, REAL ( kind = 8 ) QUALITY, the quality of the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_quality_2d(t) RESULT(quality) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP) :: quality + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: count lattice points. +! +!# Introduction +! +! The triangle is assumed to be a right triangle which, without loss +! of generality, has the coordinates: +! +! ( (0,0), (a,0), (0,b) ) +! +! The routine returns the number of integer lattice points that appear +! inside the triangle or on its edges or vertices. +! +! The formula for this FUNCTION occurred to me (JVB) after some thought, +! on 06 July 2009. +! +! Parameters: +! +! Input, integer ( kind = 4 ) A, B, define the vertices. +! +! Output, integer ( kind = 4 ) N, the number of lattice points. + +INTERFACE + MODULE PURE FUNCTION triangle_right_lattice_point_num_2d(a, b) RESULT(n) + INTEGER(I4B), INTENT(IN) :: a + INTEGER(I4B), INTENT(IN) :: b + INTEGER(I4B) :: n + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: returns random points in a triangle. +! +!# Introduction +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, integer ( kind = 4 ) N, the number of points to generate. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, REAL ( kind = 8 ) P(2,N), random points in the triangle. + +INTERFACE + MODULE PURE FUNCTION triangle_sample(t, n, seed) RESULT(p) + REAL(DFP), INTENT(IN) :: t(:, :) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(IN) :: seed + REAL(DFP) :: p(2, n) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: count lattice points. +! +!# Introduction +! +! The triangle is assumed to be the unit triangle: +! +!$$ +! ( (0,0), (1,0), (0,1) ) +!$$ +! +! or a copy of this triangle scaled by an integer S: +! +!$$ +! ( (0,0), (S,0), (0,S) ). +!$$ +! +! The routine returns the number of integer lattice points that appear +! inside the triangle or on its edges or vertices. +! +! Parameters: +! +! Input, integer ( kind = 4 ) S, the scale factor. +! +! Output, integer ( kind = 4 ) N, the number of lattice points. +! + +INTERFACE + MODULE PURE FUNCTION triangle01_lattice_point_num_2d(s) RESULT(n) + INTEGER(I4B), INTENT(IN) :: s + INTEGER(I4B) :: n + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: converts from barycentric to XY coordinates in 2D. +! +!# Introduction +! +! Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) XSI(3), the barycentric coordinates of a point. +! XSI(1) + XSI(2) + XSI(3) should equal 1, but this is not checked. +! +! Output, REAL ( kind = 8 ) P(2), the XY coordinates of the point. +! + +INTERFACE + MODULE PURE FUNCTION triangle_xsi_to_xy_2d(t, xsi) RESULT(p) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: xsi(3) + REAL(DFP) :: p(2) + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: converts from XY to barycentric in 2D. +! +!# Introduction +! +!# Parameters: +! +! Input, REAL ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, REAL ( kind = 8 ) P(2), the XY coordinates of a point. +! +! Output, REAL ( kind = 8 ) XSI(3), the barycentric coordinates of the +! point. +! XSI1 + XSI2 + XSI3 should equal 1. +! + +INTERFACE + MODULE PURE FUNCTION triangle_xy_to_xsi_2d(t, p) RESULT(xsi) + REAL(DFP), INTENT(IN) :: t(:, :) + REAL(DFP), INTENT(IN) :: p(2) + REAL(DFP) :: xsi(3) + END FUNCTION +END INTERFACE + +END MODULE Triangle_Method diff --git a/src/modules/Geometry/src/assets/geometry_burkardt_line.inc b/src/modules/Geometry/src/assets/geometry_burkardt_line.inc new file mode 100644 index 000000000..8bb9bb53a --- /dev/null +++ b/src/modules/Geometry/src/assets/geometry_burkardt_line.inc @@ -0,0 +1,2991 @@ +function line_exp_is_degenerate_nd(dim_num, p1, p2) + +!*****************************************************************************80 +! +!! LINE_EXP_IS_DEGENERATE_ND finds if an explicit line is degenerate in ND. +! +! Discussion: +! +! 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. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4) dim_num + + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + line_exp_is_degenerate_nd = (all(p1(1:dim_num) == p2(1:dim_num))) + + return +end +subroutine line_exp_normal_2d(p1, p2, normal) + +!*****************************************************************************80 +! +!! LINE_EXP_NORMAL_2D computes a unit normal vector to a line in 2D. +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The sign of the normal vector N is chosen so that the normal vector +! points "to the left" of the direction of the line. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two distinct points on the line. +! +! Output, real ( kind = 8 ) NORMAL(2), a unit normal vector to the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) norm + real(kind=8) normal(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + normal(1:dim_num) = sqrt(2.0D+00) + return + end if + + norm = sqrt((p2(1) - p1(1))**2 + (p2(2) - p1(2))**2) + + normal(1) = -(p2(2) - p1(2)) / norm + normal(2) = (p2(1) - p1(1)) / norm + + return +end +subroutine line_exp_perp_2d(p1, p2, p3, p4, flag) + +!*****************************************************************************80 +! +!! LINE_EXP_PERP_2D computes a line perpendicular to a line and through a point. +! +! Discussion: +! +! 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. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 July 2009 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) bot + logical(kind=4) flag + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + real(kind=8) r8_huge + 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)) + + return +end +subroutine line_exp_point_dist_2d(p1, p2, p, dist) + +!*****************************************************************************80 +! +!! LINE_EXP_POINT_DIST_2D: distance ( explicit line, point ) in 2D. +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! +! Input, real ( kind = 8 ) P(2), the point whose distance from the line is +! to be measured. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) bot + real(kind=8) dist + real(kind=8) dot + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) t + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + + pn(1:dim_num) = p1(1:dim_num) +! +! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). +! +! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T +! of the projection of (P-P1) onto (P2-P1). +! + else + + dot = sum((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) + + bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) + + t = dot / bot + + pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) + + end if + + dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + + return +end +subroutine line_exp_point_dist_3d(p1, p2, p, dist) + +!*****************************************************************************80 +! +!! LINE_EXP_POINT_DIST_3D: distance ( explicit line, point ) in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. +! +! Input, real ( kind = 8 ) P(3), the point whose distance from the line is +! to be measured. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) bot + real(kind=8) dist + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) t + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + + pn(1:dim_num) = p1(1:dim_num) +! +! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). +! +! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T +! of the projection of (P-P1) onto (P2-P1). +! + 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 + + pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) + + end if +! +! Now compute the distance between the projection point and P. +! + dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + + return +end +subroutine line_exp_point_dist_signed_2d(p1, p2, p, dist_signed) + +!*****************************************************************************80 +! +!! LINE_EXP_POINT_DIST_SIGNED_2D: signed distance ( exp line, point ) in 2D. +! +! 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). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) dist_signed + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) +! +! 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 + + return +end +subroutine line_exp_point_near_2d(p1, p2, p, pn, dist, t) + +!*****************************************************************************80 +! +!! LINE_EXP_POINT_NEAR_2D: point on an explicit line nearest a point in 2D. +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The nearest point PN = (XN,YN) has the form: +! +! PN = (1-T) * P1 + T * P2. +! +! If T is less than 0, PN is furthest from P2. +! If T is between 0 and 1, PN is between P1 and P2. +! If T is greater than 1, PN is furthest from P1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! +! Input, real ( kind = 8 ) P(2), the point whose nearest neighbor on the +! line is to be determined. +! +! Output, real ( kind = 8 ) PN(2), the nearest point on the line to P. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the line. +! +! Output, real ( kind = 8 ) T, the relative position of the point +! PN to the points P1 and P2. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) bot + real(kind=8) dist + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) t + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_POINT_NEAR_2D - Fatal error!' + write (*, '(a)') ' The line is degenerate.' + stop 1 + end if +! +! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). +! +! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T +! of the projection of (P-P1) onto (P2-P1). +! + bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) + + t = sum((p1(1:dim_num) - p(1:dim_num)) & + * (p1(1:dim_num) - p2(1:dim_num))) / bot + + pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) + + dist = sqrt(sum((pn(1:dim_num) - p(1:dim_num))**2)) + + return +end +subroutine line_exp_point_near_3d(p1, p2, p, pn, dist, t) + +!*****************************************************************************80 +! +!! LINE_EXP_POINT_NEAR_3D: nearest point on explicit line to point in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! The nearest point PN has the form: +! +! PN = ( 1 - T ) * P1 + T * P2. +! +! If T is less than 0, PN is furthest away from P2. +! If T is between 0 and 1, PN is between P1 and P2. +! If T is greater than 1, PN is furthest away from P1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. +! +! Input, real ( kind = 8 ) P(3), the point whose nearest neighbor on +! the line is to be determined. +! +! Output, real ( kind = 8 ) PN(3), the point which is the nearest +! point on the line to P. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! nearest point on the line. +! +! Output, real ( kind = 8 ) T, the relative position of the point +! PN to P1 and P2. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) bot + real(kind=8) dist + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) t + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_EXP_POINT_NEAR_3D - Fatal error!' + write (*, '(a)') ' The line is degenerate.' + stop 1 + end if +! +! (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta). +! +! (P-P1) dot (P2-P1) / Norm(P-P1)^2 = normalized coordinate T +! of the projection of (P-P1) onto (P2-P1). +! + 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 +! +! Now compute the location of the projection point. +! + pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +! +! Now compute the distance between the projection point and P. +! + dist = sqrt(sum((pn(1:dim_num) - p(1:dim_num))**2)) + + return +end +subroutine line_exp2imp_2d(p1, p2, a, b, c) + +!*****************************************************************************80 +! +!! LINE_EXP2IMP_2D converts an explicit line to implicit form in 2D. +! +! Discussion: +! +! 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 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) norm + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) +! +! Take care of degenerate cases. +! + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_EXP2IMP_2D - Warning!' + write (*, '(a)') ' The line is degenerate.' + 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 + + return +end +subroutine line_exp2par_2d(p1, p2, f, g, x0, y0) + +!*****************************************************************************80 +! +!! LINE_EXP2PAR_2D converts a line from explicit to parametric form in 2D. +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F^2 + G^2 = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! +! Output, real ( kind = 8 ) F, G, X0, Y0, the parametric parameters +! of the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) f + real(kind=8) g + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) norm + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) x0 + real(kind=8) y0 + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_EXP2PAR_2D - Warning!' + write (*, '(a)') ' The line is degenerate.' + end if + + x0 = p1(1) + y0 = p1(2) + + f = p2(1) - p1(1) + g = p2(2) - p1(2) + + norm = sqrt(f * f + g * g) + + if (norm /= 0.0D+00) then + f = f / norm + g = g / norm + end if + + if (f < 0.0D+00) then + f = -f + g = -g + end if + + return +end +subroutine line_exp2par_3d(p1, p2, f, g, h, x0, y0, z0) + +!*****************************************************************************80 +! +!! LINE_EXP2PAR_3D converts a line from explicit to parametric form in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! The parametric form of a line in 3D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! Z = Z0 + H * T +! +! We normalize by always choosing F^2 + G^2 + H^2 = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. +! +! Output, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric parameters +! of the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) f + real(kind=8) g + real(kind=8) h + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) norm + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) x0 + real(kind=8) y0 + real(kind=8) z0 + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_EXP2PAR_3D - Warning!' + write (*, '(a)') ' The line is degenerate.' + end if + + x0 = p1(1) + y0 = p1(2) + z0 = p1(3) + + f = p2(1) - p1(1) + g = p2(2) - p1(2) + h = p2(3) - p1(3) + + norm = sqrt(f * f + g * g + h * h) + + if (norm /= 0.0D+00) then + f = f / norm + g = g / norm + h = h / norm + end if + + if (f < 0.0D+00) then + f = -f + g = -g + h = -h + end if + + return +end +function line_imp_is_degenerate_2d(a, b, c) + +!*****************************************************************************80 +! +!! LINE_IMP_IS_DEGENERATE_2D finds if an implicit point is degenerate in 2D. +! +! Discussion: +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + logical(kind=4) line_imp_is_degenerate_2d + + line_imp_is_degenerate_2d = (a * a + b * b == 0.0D+00) + + return +end +subroutine line_imp_point_dist_2d(a, b, c, p, dist) + +!*****************************************************************************80 +! +!! LINE_IMP_POINT_DIST_2D: distance ( implicit line, point ) in 2D. +! +! Discussion: +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. +! +! Input, real ( kind = 8 ) P(2), the point whose distance from the line is +! to be measured. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) dist + logical(kind=4) line_imp_is_degenerate_2d + real(kind=8) p(dim_num) + + if (line_imp_is_degenerate_2d(a, b, c)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_IMP_POINT_DIST_2D - Fatal error!' + write (*, '(a)') ' The line is degenerate.' + stop 1 + end if + + dist = abs(a * p(1) + b * p(2) + c) / sqrt(a * a + b * b) + + return +end +subroutine line_imp_point_dist_signed_2d(a, b, c, p, dist_signed) + +!*****************************************************************************80 +! +!! LINE_IMP_POINT_DIST_SIGNED_2D: signed distance ( imp line, point ) in 2D. +! +! Discussion: +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. +! +! Input, real ( kind = 8 ) P(2), the coordinates of the point. +! +! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the +! point to the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) dist_signed + logical(kind=4) line_imp_is_degenerate_2d + real(kind=8) p(dim_num) + + if (line_imp_is_degenerate_2d(a, b, c)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_IMP_POINT_DIST_SIGNED_2D - Fatal error!' + write (*, '(a)') ' The line is degenerate.' + stop 1 + end if + + dist_signed = -sign(1.0D+00, c) * (a * p(1) + b * p(2) + c) / & + sqrt(a * a + b * b) + + return +end +subroutine line_imp2exp_2d(a, b, c, p1, p2) + +!*****************************************************************************80 +! +!! LINE_IMP2EXP_2D converts an implicit line to explicit form in 2D. +! +! Discussion: +! +! The implicit form of line in 2D is: +! +! A * X + B * Y + C = 0 +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. +! +! Output, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + logical(kind=4) line_imp_is_degenerate_2d + real(kind=8) normsq + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + if (line_imp_is_degenerate_2d(a, b, c)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_IMP2EXP_2D - Fatal error!' + write (*, '(a)') ' The line is degenerate.' + stop 1 + end if + + normsq = a * a + b * b + + p1(1) = -a * c / normsq + p1(2) = -b * c / normsq + + if (abs(b) < abs(a)) then + p2(1) = -(a - b / a) * c / normsq + p2(2) = -(b + 1.0D+00) * c / normsq + else + p2(1) = -(a + 1.0D+00) * c / normsq + p2(2) = -(b - a / b) * c / normsq + end if + + return +end +subroutine line_imp2par_2d(a, b, c, f, g, x0, y0) + +!*****************************************************************************80 +! +!! LINE_IMP2PAR_2D converts an implicit line to parametric form in 2D. +! +! Discussion: +! +! The implicit form of line in 2D is: +! +! A * X + B * Y + C = 0 +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We may normalize by choosing F*F + G*G = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 January 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. +! +! Output, real ( kind = 8 ) F, G, X0, Y0, the parametric parameters of +! the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) f + logical(kind=4) line_imp_is_degenerate_2d + real(kind=8) g + real(kind=8) x0 + real(kind=8) y0 + + if (line_imp_is_degenerate_2d(a, b, c)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINE_IMP2PAR_2D - Fatal error!' + write (*, '(a)') ' The line is degenerate.' + stop 1 + end if + + x0 = -a * c / (a * a + b * b) + y0 = -b * c / (a * a + b * b) + + f = b / sqrt(a * a + b * b) + g = -a / sqrt(a * a + b * b) + + if (f < 0.0D+00) then + f = -f + g = -g + end if + + return +end +subroutine line_par_point_dist_2d(f, g, x0, y0, p, dist) + +!*****************************************************************************80 +! +!! LINE_PAR_POINT_DIST_2D: distance ( parametric line, point ) in 2D. +! +! Discussion: +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F*F + G*G = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. +! +! Input, real ( kind = 8 ) P(2), the point whose distance from the line is +! to be measured. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) dx + real(kind=8) dy + real(kind=8) f + real(kind=8) g + real(kind=8) p(dim_num) + real(kind=8) x0 + real(kind=8) y0 + + dx = g * g * (p(1) - x0) - f * g * (p(2) - y0) + dy = -f * g * (p(1) - x0) + f * f * (p(2) - y0) + + dist = sqrt(dx * dx + dy * dy) / (f * f + g * g) + + return +end +subroutine line_par_point_dist_3d(f, g, h, x0, y0, z0, p, dist) + +!*****************************************************************************80 +! +!! LINE_PAR_POINT_DIST_3D: distance ( parametric line, point ) in 3D. +! +! Discussion: +! +! The parametric form of a line in 3D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! Z = Z0 + H * T +! +! We normalize by always choosing F*F + G*G + H*H = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric line +! parameters. +! +! Input, real ( kind = 8 ) P(3), the point whose distance from the line is +! to be measured. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dist + real(kind=8) dx + real(kind=8) dy + real(kind=8) dz + real(kind=8) f + real(kind=8) g + real(kind=8) h + real(kind=8) p(dim_num) + real(kind=8) x0 + real(kind=8) y0 + real(kind=8) z0 + + dx = g * (f * (p(2) - y0) - g * (p(1) - x0)) & + + h * (f * (p(3) - z0) - h * (p(1) - x0)) + + dy = h * (g * (p(3) - z0) - h * (p(2) - y0)) & + - f * (f * (p(2) - y0) - g * (p(1) - x0)) + + dz = -f * (f * (p(3) - z0) - h * (p(1) - x0)) & + - g * (g * (p(3) - z0) - h * (p(2) - y0)) + + dist = sqrt(dx * dx + dy * dy + dz * dz) & + / (f * f + g * g + h * h) + + return +end +subroutine line_par_point_near_2d(f, g, x0, y0, p, pn) + +!*****************************************************************************80 +! +!! LINE_PAR_POINT_NEAR_2D: nearest point on parametric line to given point, 2D. +! +! Discussion: +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We may normalize by choosing F*F + G*G = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 April 2013 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. +! +! Input, real ( kind = 8 ) P(2), the point whose distance from the line is +! to be measured. +! +! Output, real ( kind = 8 ) PN(2), the point on the parametric line which +! is nearest to P. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) f + real(kind=8) g + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) t + real(kind=8) x0 + real(kind=8) y0 + + t = (f * (p(1) - x0) + g * (p(2) - y0)) / (f * f + g * g) + + pn(1) = x0 + t * f + pn(2) = y0 + t * g + + return +end +subroutine line_par_point_near_3d(f, g, h, x0, y0, z0, p, pn) + +!*****************************************************************************80 +! +!! LINE_PAR_POINT_NEAR_3D: nearest point on parametric line to given point, 3D. +! +! Discussion: +! +! The parametric form of a line in 3D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! Z = Z0 + H * T +! +! We may normalize by choosing F*F + G*G + H*H = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 April 2013 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric +! line parameters. +! +! Input, real ( kind = 8 ) P(3), the point whose distance from the line is +! to be measured. +! +! Output, real ( kind = 8 ) PN(3), the point on the parametric line which +! is nearest to P. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) f + real(kind=8) g + real(kind=8) h + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) t + real(kind=8) x0 + real(kind=8) y0 + real(kind=8) z0 + + t = (f * (p(1) - x0) + g * (p(2) - y0) + h * (p(3) - z0)) & + / (f * f + g * g + h * h) + + pn(1) = x0 + t * f + pn(2) = y0 + t * g + pn(3) = z0 + t * h + + return +end +subroutine line_par2exp_2d(f, g, x0, y0, p1, p2) + +!*****************************************************************************80 +! +!! LINE_PAR2EXP_2D converts a parametric line to explicit form in 2D. +! +! Discussion: +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F*F + G*G = 1, and F nonnegative. +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. +! +! Output, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) f + real(kind=8) g + real(kind=8) x0 + real(kind=8) y0 + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + p1(1) = x0 + p1(2) = y0 + + p2(1) = p1(1) + f + p2(2) = p1(2) + g + + return +end +subroutine line_par2exp_3d(f, g, h, x0, y0, z0, p1, p2) + +!*****************************************************************************80 +! +!! LINE_PAR2EXP_3D converts a parametric line to explicit form in 3D. +! +! Discussion: +! +! The parametric form of a line in 3D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! Z = Z0 + H * T +! +! We may normalize by choosing F*F + G*G + H*H = 1, and F nonnegative. +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 13 April 2013 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F, G, H, X0, Y0, Z0, the parametric +! line parameters. +! +! Output, real ( kind = 8 ) P1(3), P2(3), two points on the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) f + real(kind=8) g + real(kind=8) h + real(kind=8) x0 + real(kind=8) y0 + real(kind=8) z0 + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + p1(1) = x0 + p1(2) = y0 + p1(3) = z0 + + p2(1) = p1(1) + f + p2(2) = p1(2) + g + p2(3) = p1(3) + h + + return +end +subroutine line_par2imp_2d(f, g, x0, y0, a, b, c) + +!*****************************************************************************80 +! +!! LINE_PAR2IMP_2D converts a parametric line to implicit form in 2D. +! +! Discussion: +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F*F + G*G = 1, and F nonnegative. +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 January 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric line parameters. +! +! Output, real ( kind = 8 ) A, B, C, the implicit line parameters. +! + implicit none + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) f + real(kind=8) g + real(kind=8) x0 + real(kind=8) y0 + + a = -g + b = f + c = g * x0 - f * y0 + + return +end +subroutine lines_exp_angle_3d(p1, p2, q1, q2, angle) + +!*****************************************************************************80 +! +!! LINES_EXP_ANGLE_3D finds the angle between two explicit lines in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. +! +! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. +! +! Output, real ( kind = 8 ) ANGLE, the angle in radians between the two +! lines. The angle is computed using the ACOS function, and so lies between +! 0 and PI. But if one of the lines is degenerate, the angle is +! returned as -1.0. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) angle + real(kind=8) ctheta + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pdotq + real(kind=8) pnorm + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) qnorm + real(kind=8) r8_acos + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then +! write ( *, '(a)' ) ' ' +! write ( *, '(a)' ) 'LINES_EXP_ANGLE_3D - Fatal error!' +! write ( *, '(a)' ) ' The line (P1,P2) is degenerate!' + angle = -1.0D+00 + return + end if + + if (line_exp_is_degenerate_nd(dim_num, q1, q2)) then +! write ( *, '(a)' ) ' ' +! write ( *, '(a)' ) 'LINES_EXP_ANGLE_3D - Warning!' +! write ( *, '(a)' ) ' The line (Q1,Q2) is degenerate!' + angle = -1.0D+00 + return + end if + + pnorm = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) + + qnorm = sqrt(sum((q2(1:dim_num) - q1(1:dim_num))**2)) + + pdotq = sum((p2(1:dim_num) - p1(1:dim_num)) & + * (q2(1:dim_num) - q1(1:dim_num))) + + ctheta = pdotq / (pnorm * qnorm) + + angle = r8_acos(ctheta) + + return +end +subroutine lines_exp_angle_nd(dim_num, p1, p2, q1, q2, angle) + +!*****************************************************************************80 +! +!! LINES_EXP_ANGLE_ND returns the angle between two explicit lines in ND. +! +! Discussion: +! +! The explicit form of a line in ND is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), two points +! on the first line. +! +! Input, real ( kind = 8 ) Q1(DIM_NUM), Q2(DIM_NUM), two points +! on the second line. +! +! Output, real ( kind = 8 ) ANGLE, the angle in radians between the two +! lines. The angle is computed using the ACOS function, and so lies +! between 0 and PI. But if one of the lines is degenerate, the angle +! is returned as -1.0. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) angle + real(kind=8) ctheta + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pdotq + real(kind=8) pnorm + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) qnorm + real(kind=8) r8_acos + + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINES_EXP_ANGLE_3D - Fatal error!' + write (*, '(a)') ' The line (P1,P2) is degenerate!' + angle = -1.0D+00 + stop 1 + end if + + if (line_exp_is_degenerate_nd(dim_num, q1, q2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINES_EXP_ANGLE_3D - Fatal error!' + write (*, '(a)') ' The line (Q1,Q2) is degenerate!' + angle = -1.0D+00 + stop 1 + end if + + pnorm = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) + qnorm = sqrt(sum((q2(1:dim_num) - q1(1:dim_num))**2)) + + pdotq = sum((p2(1:dim_num) - p1(1:dim_num)) & + * (q2(1:dim_num) - q1(1:dim_num))) + + ctheta = pdotq / (pnorm * qnorm) + angle = r8_acos(ctheta) + + return +end +subroutine lines_exp_dist_3d(p1, p2, q1, q2, dist) + +!*****************************************************************************80 +! +!! LINES_EXP_DIST_3D computes the distance between two explicit lines in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. +! +! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. +! +! Output, real ( kind = 8 ) DIST, the distance between the lines. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a11 + real(kind=8) a12 + real(kind=8) a13 + real(kind=8) a21 + real(kind=8) a22 + real(kind=8) a23 + real(kind=8) a31 + real(kind=8) a32 + real(kind=8) a33 + real(kind=8) bot + real(kind=8) cr1 + real(kind=8) cr2 + real(kind=8) cr3 + real(kind=8) dist + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) top +! +! The distance is found by computing the volume of a parallelipiped, +! and dividing by the area of its base. +! +! But if the lines are parallel, we compute the distance by +! finding the distance between the first line and any point +! on the second line. +! + a11 = q1(1) - p1(1) + a12 = q1(2) - p1(2) + a13 = q1(3) - p1(3) + + a21 = p2(1) - p1(1) + a22 = p2(2) - p1(2) + a23 = p2(3) - p1(3) + + a31 = q2(1) - q1(1) + a32 = q2(2) - q1(2) + a33 = q2(3) - q1(3) +! +! Compute the cross product. +! + cr1 = a22 * a33 - a23 * a32 + cr2 = a23 * a31 - a21 * a33 + cr3 = a21 * a32 - a22 * a31 + + bot = sqrt(cr1 * cr1 + cr2 * cr2 + cr3 * cr3) + + if (bot == 0.0D+00) then + + call line_exp_point_dist_3d(p1, p2, q1, dist) + + else + + top = abs(a11 * (a22 * a33 - a23 * a32) & + - a12 * (a21 * a33 - a23 * a31) & + + a13 * (a21 * a32 - a22 * a31)) + + dist = top / bot + + end if + + return +end +subroutine lines_exp_dist_3d_2(p1, p2, q1, q2, dist) + +!*****************************************************************************80 +! +!! LINES_EXP_DIST_3D_2 computes the distance between two explicit lines in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! This routine uses a method that is essentially independent of dimension. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 August 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. +! +! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. +! +! Output, real ( kind = 8 ) DIST, the distance between the lines. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) det + real(kind=8) dist + real(kind=8) e + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) qn(dim_num) + real(kind=8) sn + real(kind=8) tn + real(kind=8) u(dim_num) + real(kind=8) v(dim_num) + real(kind=8) w0(dim_num) +! +! Let U = (P2-P1) and V = (Q2-Q1) be the direction vectors on +! the two lines. +! + u(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + v(1:dim_num) = q2(1:dim_num) - q1(1:dim_num) +! +! Let SN be the unknown coordinate of the nearest point PN on line 1, +! so that PN = P(SN) = P1 + SN * (P2-P1). +! +! Let TN be the unknown coordinate of the nearest point QN on line 2, +! so that QN = Q(TN) = Q1 + TN * (Q2-Q1). +! +! Let W0 = (P1-Q1). +! + w0(1:dim_num) = p1(1:dim_num) - q1(1:dim_num) +! +! The vector direction WC = P(SN) - Q(TC) is unique (among directions) +! perpendicular to both U and V, so +! +! U dot WC = 0 +! V dot WC = 0 +! +! or, equivalently: +! +! U dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 +! V dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 +! +! or, equivalently: +! +! (u dot u ) * sn - (u dot v ) tc = -u * w0 +! (v dot u ) * sn - (v dot v ) tc = -v * w0 +! +! or, equivalently: +! +! ( a -b ) * ( sn ) = ( -d ) +! ( b -c ) ( tc ) ( -e ) +! + a = dot_product(u, u) + b = dot_product(u, v) + c = dot_product(v, v) + d = dot_product(u, w0) + e = dot_product(v, w0) +! +! Check the determinant. +! + det = -a * c + b * b + + if (det == 0.0D+00) then + sn = 0.0D+00 + if (abs(b) < abs(c)) then + tn = e / c + else + tn = d / b + end if + else + sn = (c * d - b * e) / det + tn = (b * d - a * e) / det + end if + + pn(1:dim_num) = p1(1:dim_num) + sn * (p2(1:dim_num) - p1(1:dim_num)) + qn(1:dim_num) = q1(1:dim_num) + tn * (q2(1:dim_num) - q1(1:dim_num)) + + dist = sqrt(sum((pn(1:dim_num) - qn(1:dim_num))**2)) + + return +end +function lines_exp_equal_2d(p1, p2, q1, q2) + +!*****************************************************************************80 +! +!! LINES_EXP_EQUAL_2D determines if two explicit lines are equal in 2D. +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! It is essentially impossible to accurately determine whether two +! explicit lines are equal in 2D. However, for form's sake, and +! because occasionally the correct result can be determined, we +! provide this routine. Since divisions are avoided, if the +! input data is exactly representable, the result should be +! correct. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 July 2006 +! +! Author: +! +! John Burkardt +! +! 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, logical ( kind = 4 ) LINES_EXP_EQUAL_2D, is TRUE if the two lines +! are determined to be identical. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) lines_exp_equal_2d + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) q1(2) + real(kind=8) q2(2) + real(kind=8) test1 + real(kind=8) test2 + real(kind=8) test3 + real(kind=8) test4 +! +! Slope (P1,P2) = Slope (P2,Q1). +! + test1 = (p2(2) - p1(2)) * (q1(1) - p2(1)) & + - (p2(1) - p1(1)) * (q1(2) - p2(2)) + + if (test1 /= 0.0D+00) then + lines_exp_equal_2d = .false. + return + end if +! +! Slope (Q1,Q2) = Slope (P2,Q1). +! + test2 = (q2(2) - q1(2)) * (q1(1) - p2(1)) & + - (q2(1) - q1(1)) * (q1(2) - p2(2)) + + if (test2 /= 0.0D+00) then + lines_exp_equal_2d = .false. + return + end if +! +! Slope (P1,P2) = Slope (P1,Q2). +! + test3 = (p2(2) - p1(2)) * (q2(1) - p1(1)) & + - (p2(1) - p1(1)) * (q2(2) - p1(2)) + + if (test3 /= 0.0D+00) then + lines_exp_equal_2d = .false. + return + end if +! +! Slope (Q1,Q2) = Slope (P1,Q2). +! + test4 = (q2(2) - q1(2)) * (q2(1) - p1(1)) & + - (q2(1) - q1(1)) * (q2(2) - p1(2)) + + if (test4 /= 0.0D+00) then + lines_exp_equal_2d = .false. + return + end if + + lines_exp_equal_2d = .true. + + return +end +subroutine lines_exp_int_2d(p1, p2, q1, q2, ival, p) + +!*****************************************************************************80 +! +!! LINES_EXP_INT_2D determines where two explicit lines intersect in 2D. +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + 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 + integer(kind=4) ival + logical(kind=4) point_1 + logical(kind=4) point_2 + real(kind=8) p(2) + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) q1(2) + real(kind=8) q2(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 + + return +end +subroutine lines_exp_near_3d(p1, p2, q1, q2, pn, qn) + +!*****************************************************************************80 +! +!! LINES_EXP_NEAR_3D computes the nearest points on two explicit lines in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! This routine uses a method that is essentially independent of dimension. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 August 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. +! +! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. +! +! Output, real ( kind = 8 ) PN(3), QN(3), the points on the first and +! second lines that are nearest. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) det + real(kind=8) e + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) qn(dim_num) + real(kind=8) sn + real(kind=8) tn + real(kind=8) u(dim_num) + real(kind=8) v(dim_num) + real(kind=8) w0(dim_num) +! +! Let U = (P2-P1) and V = (Q2-Q1) be the direction vectors on +! the two lines. +! + u(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + v(1:dim_num) = q2(1:dim_num) - q1(1:dim_num) +! +! Let SN be the unknown coordinate of the nearest point PN on line 1, +! so that PN = P(SN) = P1 + SN * (P2-P1). +! +! Let TN be the unknown coordinate of the nearest point QN on line 2, +! so that QN = Q(TN) = Q1 + TN * (Q2-Q1). +! +! Let W0 = (P1-Q1). +! + w0(1:dim_num) = p1(1:dim_num) - q1(1:dim_num) +! +! The vector direction WC = P(SN) - Q(TC) is unique (among directions) +! perpendicular to both U and V, so +! +! U dot WC = 0 +! V dot WC = 0 +! +! or, equivalently: +! +! U dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 +! V dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 +! +! or, equivalently: +! +! (u dot u ) * sn - (u dot v ) tc = -u * w0 +! (v dot u ) * sn - (v dot v ) tc = -v * w0 +! +! or, equivalently: +! +! ( a -b ) * ( sn ) = ( -d ) +! ( b -c ) ( tc ) ( -e ) +! + a = dot_product(u, u) + b = dot_product(u, v) + c = dot_product(v, v) + d = dot_product(u, w0) + e = dot_product(v, w0) +! +! Check the determinant. +! + det = -a * c + b * b + + if (det == 0.0D+00) then + sn = 0.0D+00 + if (abs(b) < abs(c)) then + tn = e / c + else + tn = d / b + end if + else + sn = (c * d - b * e) / det + tn = (b * d - a * e) / det + end if + + pn(1:dim_num) = p1(1:dim_num) + sn * (p2(1:dim_num) - p1(1:dim_num)) + qn(1:dim_num) = q1(1:dim_num) + tn * (q2(1:dim_num) - q1(1:dim_num)) + + return +end +function lines_exp_parallel_2d(p1, p2, q1, q2) + +!*****************************************************************************80 +! +!! LINES_EXP_PARALLEL_2D determines if two lines are parallel in 2D. +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The test is essentially a comparison of slopes, but should be +! more accurate than an explicit slope comparison, and unfazed +! by degenerate cases. +! +! On the other hand, there is NO tolerance for error. If the +! slopes differ by a single digit in the last place, then the +! lines are judged to be nonparallel. A more robust test would +! be to compute the angle between the lines, because then it makes +! sense to say the lines are "almost" parallel: the angle is small. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! 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, logical ( kind = 4 ) LINES_EXP_PARALLEL_2D is TRUE if the +! lines are parallel. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) lines_exp_parallel_2d + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + + lines_exp_parallel_2d = (p2(1) - p1(1)) * (q2(2) - q1(2)) == & + (q2(1) - q1(1)) * (p2(2) - p1(2)) + + return +end +function lines_exp_parallel_3d(p1, p2, q1, q2) + +!*****************************************************************************80 +! +!! LINES_EXP_PARALLEL_3D determines if two lines are parallel in 3D. +! +! Discussion: +! +! The explicit form of a line in 3D is: +! +! the line through the points P1 and P2. +! +! The points P1, P2 define a direction (P2-P1). Similarly, the +! points (Q1,Q2) define a direction (Q2-Q1). The quantity +! +! (P2-P1) dot (Q2-Q1) = norm(P2-P1) * norm(Q2-Q1) * cos ( angle ) +! +! Therefore, the following value is between 0 and 1; +! +! abs ( (P2-P1) dot (Q2-Q1) / ( norm(P2-P1) * norm(Q2-Q1) ) ) +! +! and the lines are parallel if +! +! abs ( (P2-P1) dot (Q2-Q1) / ( norm(P2-P1) * norm(Q2-Q1) ) ) = 1 +! +! We can rephrase this as requiring: +! +! ( (P2-P1)dot(Q2-Q1) )^2 = (P2-P1)dot(P2-P1) * (Q2-Q1)dot(Q2-Q1) +! +! which avoids division and square roots. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 August 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the first line. +! +! Input, real ( kind = 8 ) Q1(3), Q2(3), two points on the second line. +! +! Output, logical ( kind = 4 ) LINES_EXP_PARALLEL_3D is TRUE if the lines +! are parallel. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + logical(kind=4) lines_exp_parallel_3d + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pdotp + real(kind=8) pdotq + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) qdotq + + pdotq = dot_product(p2(1:dim_num) - p1(1:dim_num), & + q2(1:dim_num) - q1(1:dim_num)) + + pdotp = dot_product(p2(1:dim_num) - p1(1:dim_num), & + p2(1:dim_num) - p1(1:dim_num)) + + qdotq = dot_product(q2(1:dim_num) - q1(1:dim_num), & + q2(1:dim_num) - q1(1:dim_num)) + + lines_exp_parallel_3d = (pdotq * pdotq == pdotp * qdotq) + + return +end +subroutine lines_imp_angle_2d(a1, b1, c1, a2, b2, c2, theta) + +!*****************************************************************************80 +! +!! LINES_IMP_ANGLE_2D finds the angle between two implicit lines in 2D. +! +! Discussion: +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 January 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) A1, B1, C1, the implicit parameters of the +! first line. +! +! Input, real ( kind = 8 ) A2, B2, C2, the implicit parameters of the +! second line. +! +! Output, real ( kind = 8 ) THETA, the angle between the two lines. +! + implicit none + + 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 + real(kind=8) pdotq + real(kind=8) pnorm + real(kind=8) qnorm + real(kind=8) r8_acos + real(kind=8) theta + + pdotq = a1 * a2 + b1 * b2 + pnorm = sqrt(a1 * a1 + b1 * b1) + qnorm = sqrt(a2 * a2 + b2 * b2) + + theta = r8_acos(pdotq / (pnorm * qnorm)) + + return +end +subroutine lines_imp_dist_2d(a1, b1, c1, a2, b2, c2, dist) + +!*****************************************************************************80 +! +!! LINES_IMP_DIST_2D determines the distance between two implicit lines in 2D. +! +! Discussion: +! +! If the lines intersect, then their distance is zero. +! If the two lines are parallel, then they have a nonzero distance. +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 January 2001 +! +! Author: +! +! John Burkardt +! +! 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, real ( kind = 8 ) DIST, the distance between the two lines. +! + implicit none + + 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 + real(kind=8) dist + logical(kind=4) line_imp_is_degenerate_2d +! +! Refuse to handle degenerate lines. +! + if (line_imp_is_degenerate_2d(a1, b1, c1)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINES_IMP_DIST_2D - Fatal error!' + write (*, '(a)') ' Line 1 is degenerate.' + stop 1 + end if + + if (line_imp_is_degenerate_2d(a2, b2, c2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'LINES_IMP_DIST_2D - Fatal error!' + write (*, '(a)') ' Line 2 is degenerate.' + stop 1 + end if +! +! Determine if the lines intersect. +! + if (a1 * b2 /= a2 * b1) then + dist = 0.0D+00 + return + end if +! +! Determine the distance between the parallel lines. +! + dist = abs(c2 / sqrt(a2 * a2 + b2 * b2) & + - c1 / sqrt(a1 * a1 + b1 * b1)) + + return +end +subroutine lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) + +!*****************************************************************************80 +! +!! LINES_IMP_INT_2D determines where two implicit lines intersect in 2D. +! +! Discussion: +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 February 2005 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a(dim_num, dim_num + 1) + real(kind=8) a1 + real(kind=8) a2 + real(kind=8) b1 + real(kind=8) b2 + real(kind=8) c1 + real(kind=8) c2 + integer(kind=4) info + integer(kind=4) ival + logical(kind=4) line_imp_is_degenerate_2d + real(kind=8) p(dim_num) + + 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 + + return +end +subroutine lines_par_angle_2d(f1, g1, x01, y01, f2, g2, x02, y02, theta) + +!*****************************************************************************80 +! +!! LINES_PAR_ANGLE_2D finds the angle between two parametric lines in 2D. +! +! Discussion: +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F*F + G*G = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 January 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F1, G1, X01, Y01, the parametric parameters of the +! first line. +! +! Input, real ( kind = 8 ) F2, G2, X02, Y02, the parametric parameters of the +! second line. +! +! Output, real ( kind = 8 ) THETA, the angle between the two lines. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) f1 + real(kind=8) f2 + real(kind=8) g1 + real(kind=8) g2 + real(kind=8) pdotq + real(kind=8) pnorm + real(kind=8) qnorm + real(kind=8) r8_acos + real(kind=8) theta + real(kind=8) x01 + real(kind=8) x02 + real(kind=8) y01 + real(kind=8) y02 + + pdotq = f1 * f2 + g1 * g2 + pnorm = sqrt(f1 * f1 + g1 * g1) + qnorm = sqrt(f2 * f2 + g2 * g2) + + theta = r8_acos(pdotq / (pnorm * qnorm)) + + return +end +subroutine lines_par_angle_3d(f1, g1, h1, x01, y01, z01, f2, g2, h2, & + x02, y02, z02, theta) + +!*****************************************************************************80 +! +!! LINES_PAR_ANGLE_3D finds the angle between two parametric lines in 3D. +! +! Discussion: +! +! The parametric form of a line in 3D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! Z = Z0 + H * T +! +! We normalize by always choosing F*F + G*G + H*H = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F1, G1, H1, X01, Y01, Z01, the parametric +! parameters of the first line. +! +! Input, real ( kind = 8 ) F2, G2, H2, X02, Y02, Z02, the parametric +! parameters of the second line. +! +! Output, real ( kind = 8 ) THETA, the angle between the two lines. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) f1 + real(kind=8) f2 + real(kind=8) g1 + real(kind=8) g2 + real(kind=8) h1 + real(kind=8) h2 + real(kind=8) pdotq + real(kind=8) pnorm + real(kind=8) qnorm + real(kind=8) r8_acos + real(kind=8) theta + real(kind=8) x01 + real(kind=8) x02 + real(kind=8) y01 + real(kind=8) y02 + real(kind=8) z01 + real(kind=8) z02 + + pdotq = f1 * f2 + g1 * g2 + h1 * h2 + pnorm = sqrt(f1 * f1 + g1 * g1 + h1 * h1) + qnorm = sqrt(f2 * f2 + g2 * g2 + h2 * h2) + + theta = r8_acos(pdotq / (pnorm * qnorm)) + + return +end +subroutine lines_par_dist_3d(f1, g1, h1, x01, y01, z01, f2, g2, h2, & + x02, y02, z02, dist) + +!*****************************************************************************80 +! +!! LINES_PAR_DIST_3D finds the distance between two parametric lines in 3D. +! +! Discussion: +! +! The parametric form of a line in 3D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! Z = Z0 + H * T +! +! We normalize by always choosing F*F + G*G + H*H = 1, and F nonnegative. +! +! This code does not work for parallel or near parallel lines. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F1, G1, H1, X01, Y01, Z01, the parametric +! parameters of the first line. +! +! Input, real ( kind = 8 ) F2, G2, H2, X02, Y02, Z02, the parametric +! parameters of the second line. +! +! Output, real ( kind = 8 ) DIST, the distance between the two lines. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dist + real(kind=8) f1 + real(kind=8) f2 + real(kind=8) g1 + real(kind=8) g2 + real(kind=8) h1 + real(kind=8) h2 + real(kind=8) x01 + real(kind=8) x02 + real(kind=8) y01 + real(kind=8) y02 + real(kind=8) z01 + real(kind=8) z02 + + dist = abs((x02 - x01) * (g1 * h2 - g2 * h1) & + + (y02 - y01) * (h1 * f2 - h2 * f1) & + + (z02 - z01) * (f1 * g2 - f2 * g1)) / & + ((f1 * g2 - f2 * g1)**2 & + + (g1 * h2 - g2 * h1)**2 & + + (h1 * f2 - h2 * f1)**2) + + return +end +subroutine lines_par_int_2d(f1, g1, x1, y1, f2, g2, x2, y2, t1, t2, pint) + +!*****************************************************************************80 +! +!! LINES_PAR_INT_2D determines where two parametric lines intersect in 2D. +! +! Discussion: +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F*F + G*G = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 January 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) F1, G1, X1, Y1, define the first parametric line. +! +! Input, real ( kind = 8 ) F2, G2, X2, Y2, define the second parametric line. +! +! Output, real ( kind = 8 ) T1, T2, the T parameters on the first and second +! lines of the intersection point. +! +! Output, real ( kind = 8 ) PINT(2), the intersection point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) det + real(kind=8) f1 + real(kind=8) f2 + real(kind=8) g1 + real(kind=8) g2 + real(kind=8) pint(dim_num) + real(kind=8) t1 + real(kind=8) t2 + real(kind=8) x1 + real(kind=8) x2 + real(kind=8) y1 + real(kind=8) y2 + + det = f2 * g1 - f1 * g2 + + if (det == 0.0D+00) then + t1 = 0.0D+00 + t2 = 0.0D+00 + pint(1:dim_num) = 0.0D+00 + else + t1 = (f2 * (y2 - y1) - g2 * (x2 - x1)) / det + t2 = (f1 * (y2 - y1) - g1 * (x2 - x1)) / det + pint(1) = x1 + f1 * t1 + pint(2) = y1 + g1 * t1 + end if + + return +end diff --git a/src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc b/src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc new file mode 100644 index 000000000..f198ba526 --- /dev/null +++ b/src/modules/Geometry/src/assets/geometry_burkardt_triangle.inc @@ -0,0 +1,3469 @@ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_angles_2d(t, angle) + +!***************************************************************************80 +! +!! TRIANGLE_ANGLES_2D computes the angles of a triangle in 2D. +! +! Discussion: +! +! The law of cosines is used: +! +! C^2 = A^2 + B^2 - 2 * A * B * COS ( GAMMA ) +! +! where GAMMA is the angle opposite side C. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) ANGLE(3), the angles opposite +! sides P1-P2, P2-P3 and P3-P1, in radians. +! + implicit none + + real(kind=8) t(dim_num, 3) + real(kind=8) angle(3) + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r8_acos +! +! Compute the length of each side. +! + a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) + b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) + c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) +! +! Take care of ridiculous special cases. +! + if (a == 0.0D+00 .and. b == 0.0D+00 .and. c == 0.0D+00) then + angle(1:3) = 2.0D+00 * r8_pi / 3.0D+00 + return + end if + + if (c == 0.0D+00 .or. a == 0.0D+00) then + angle(1) = r8_pi + else + angle(1) = r8_acos((c * c + a * a - b * b) / (2.0D+00 * c * a)) + end if + + if (a == 0.0D+00 .or. b == 0.0D+00) then + angle(2) = r8_pi + else + angle(2) = r8_acos((a * a + b * b - c * c) / (2.0D+00 * a * b)) + end if + + if (b == 0.0D+00 .or. c == 0.0D+00) then + angle(3) = r8_pi + else + angle(3) = r8_acos((b * b + c * c - a * a) / (2.0D+00 * b * c)) + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_angles_3d(t, angle) + +!***************************************************************************80 +! +!! TRIANGLE_ANGLES_3D computes the angles of a triangle in 3D. +! +! Discussion: +! +! The law of cosines is used: +! +! C * C = A * A + B * B - 2 * A * B * COS ( GAMMA ) +! +! where GAMMA is the angle opposite side C. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Output, real ( kind = 8 ) ANGLE(3), the angles opposite +! sides P1-P2, P2-P3 and P3-P1, in radians. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) angle(3) + real(kind=8) b + real(kind=8) c + real(kind=8) r8_acos + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) t(dim_num, 3) +! +! Compute the length of each side. +! + a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) + b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) + c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) +! +! Take care of a ridiculous special case. +! + if (a == 0.0D+00 .and. b == 0.0D+00 .and. c == 0.0D+00) then + angle(1:3) = 2.0D+00 * r8_pi / 3.0D+00 + return + end if + + if (c == 0.0D+00 .or. a == 0.0D+00) then + angle(1) = r8_pi + else + angle(1) = r8_acos((c * c + a * a - b * b) / (2.0D+00 * c * a)) + end if + + if (a == 0.0D+00 .or. b == 0.0D+00) then + angle(2) = r8_pi + else + angle(2) = r8_acos((a * a + b * b - c * c) / (2.0D+00 * a * b)) + end if + + if (b == 0.0D+00 .or. c == 0.0D+00) then + angle(3) = r8_pi + else + angle(3) = r8_acos((b * b + c * c - a * a) / (2.0D+00 * b * c)) + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_area_2d(t, area) + +!***************************************************************************80 +! +!! TRIANGLE_AREA_2D computes the area of a triangle in 2D. +! +! Discussion: +! +! If the triangle's vertices are given in counter clockwise order, +! the area will be positive. If the triangle's vertices are given +! in clockwise order, the area will be negative! +! +! An earlier version of this routine always returned the absolute +! value of the computed area. I am convinced now that that is +! a less useful result! For instance, by returning the signed +! area of a triangle, it is possible to easily compute the area +! of a nonconvex polygon as the sum of the (possibly negative) +! areas of triangles formed by node 1 and successive pairs of vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 October 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) AREA, the area of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) t(dim_num, 3) + + area = 0.5D+00 * ( & + t(1, 1) * (t(2, 2) - t(2, 3)) & + + t(1, 2) * (t(2, 3) - t(2, 1)) & + + t(1, 3) * (t(2, 1) - t(2, 2))) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_area_3d(t, area) + +!*****************************************************************************80 +! +!! TRIANGLE_AREA_3D computes the area of a triangle in 3D. +! +! Discussion: +! +! This routine uses the fact that the norm of the cross product +! of two vectors is the area of the parallelogram they form. +! +! Therefore, the area of the triangle is half of that value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 December 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Output, real ( kind = 8 ) AREA, the area of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) area + real(kind=8) cross(dim_num) + real(kind=8) t(dim_num, 3) +! +! Compute the cross product vector. +! + cross(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & + - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) + + cross(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & + - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) + + cross(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) + + area = 0.5D+00 * sqrt(sum(cross(1:3)**2)) + + return +end +subroutine triangle_area_3d_2(t, area) + +!*****************************************************************************80 +! +!! TRIANGLE_AREA_3D_2 computes the area of a triangle in 3D. +! +! Discussion: +! +! This routine computes the area "the hard way". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Output, real ( kind = 8 ) AREA, the area of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) alpha + real(kind=8) area + real(kind=8) base + real(kind=8) dot + real(kind=8) height + real(kind=8) t(dim_num, 3) +! +! Find the projection of (P3-P1) onto (P2-P1). +! + dot = (t(1, 2) - t(1, 1)) * (t(1, 3) - t(1, 1)) & + + (t(2, 2) - t(2, 1)) * (t(2, 3) - t(2, 1)) & + + (t(3, 2) - t(3, 1)) * (t(3, 3) - t(3, 1)) +! +! Find the length of (P2-P1). +! + base = sqrt((t(1, 2) - t(1, 1))**2 & + + (t(2, 2) - t(2, 1))**2 & + + (t(3, 2) - t(3, 1))**2) +! +! The height of the triangle is the length of (P3-P1) after its +! projection onto (P2-P1) has been subtracted. +! + if (base == 0.0D+00) then + + height = 0.0D+00 + + else + + alpha = dot / (base * base) + + height = sqrt( & + (t(1, 1) + alpha * (t(1, 2) - t(1, 1)) - t(1, 3))**2 & + + (t(2, 1) + alpha * (t(2, 2) - t(2, 1)) - t(2, 3))**2 & + + (t(3, 1) + alpha * (t(3, 2) - t(3, 1)) - t(3, 3))**2) + + end if + + area = 0.5D+00 * base * height + + return +end +subroutine triangle_area_3d_3(t, area) + +!*****************************************************************************80 +! +!! TRIANGLE_AREA_3D_3 computes the area of a triangle in 3D. +! +! Discussion: +! +! This routine uses Heron's formula +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 December 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Output, real ( kind = 8 ) AREA, the area of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) area + integer(kind=4) i + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) s(3) + real(kind=8) t(dim_num, 3) + + do j = 1, 3 + jp1 = mod(j, 3) + 1 + s(j) = 0.0D+00 + do i = 1, dim_num + s(j) = s(j) + (t(i, j) - t(i, jp1))**2 + end do + s(j) = sqrt(s(j)) + end do + + area = (s(1) + s(2) + s(3)) & + * (-s(1) + s(2) + s(3)) & + * (s(1) - s(2) + s(3)) & + * (s(1) + s(2) - s(3)) + + if (area < 0.0D+00) then + area = -1.0D+00 + return + end if + + area = 0.25D+00 * sqrt(area) + + return +end +subroutine triangle_area_heron(s, area) + +!*****************************************************************************80 +! +!! TRIANGLE_AREA_HERON computes the area of a triangle using Heron's formula. +! +! Discussion: +! +! The formula is valid for any spatial dimension, depending only +! on the lengths of the sides, and not the coordinates of the vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) S(3), the lengths of the three sides. +! +! Output, real ( kind = 8 ) AREA, the area of the triangle, or -1.0 if the +! sides cannot constitute a triangle. +! + implicit none + + real(kind=8) area + real(kind=8) s(3) + + area = (s(1) + s(2) + s(3)) & + * (-s(1) + s(2) + s(3)) & + * (s(1) - s(2) + s(3)) & + * (s(1) + s(2) - s(3)) + + if (area < 0.0D+00) then + area = -1.0D+00 + return + end if + + area = 0.25D+00 * sqrt(area) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_area_vector_3d(t, area_vector) +! +!! TRIANGLE_AREA_VECTOR_3D computes the area vector of a triangle in 3D. +! +! Discussion: +! +! The "area vector" of a triangle is simply a cross product of, +! for instance, the vectors (V2-V1) and (V3-V1), where V1, V2 +! and V3 are the vertices of the triangle. +! +! The norm of the cross product vector of two vectors is the area +! of the parallelogram they form. +! +! Therefore, the area of the triangle is half of the norm of the +! area vector: +! +! area = 0.5 * sqrt ( sum ( area_vector(1:3)^2 ) ) +! +! The reason for looking at the area vector rather than the area +! is that this makes it possible to compute the area of a flat +! polygon in 3D by summing the areas of the triangles that form +! a decomposition of the polygon, while allowing for both positive +! and negative areas. (Sum the vectors, THEN take the norm and +! multiply by 1/2). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 October 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Output, real ( kind = 8 ) AREA_VECTOR(3), the area vector of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) area_vector(dim_num) + real(kind=8) t(dim_num, 3) + + area_vector(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & + - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) + + area_vector(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & + - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) + + area_vector(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_barycentric_2d(t, p, xsi) + +! +!! TRIANGLE_BARYCENTRIC_2D finds the barycentric coordinates of a point in 2D. +! +! Discussion: +! +! The barycentric coordinate of point P related to vertex A can be +! interpreted as the ratio of the area of the triangle with +! vertex A replaced by vertex P to the area of the original +! triangle. +! +! This routine assumes that the triangle vertices are given in +! counter clockwise order. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! The vertices should be given in counter clockwise order. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) XSI(3), the barycentric coordinates of P +! with respect to the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4), parameter :: rhs_num = 1 + + real(kind=8) a(dim_num, dim_num + rhs_num) + integer(kind=4) info + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) + real(kind=8) xsi(dim_num + 1) +! +! Set up the linear system +! +! ( X2-X1 X3-X1 ) XSI(1) = X-X1 +! ( Y2-Y1 Y3-Y1 ) XSI(2) Y-Y1 +! +! which is satisfied by the barycentric coordinates of P. +! + a(1, 1) = t(1, 2) - t(1, 1) + a(1, 2) = t(1, 3) - t(1, 1) + a(1, 3) = p(1) - t(1, 1) + + a(2, 1) = t(2, 2) - t(2, 1) + a(2, 2) = t(2, 3) - t(2, 1) + a(2, 3) = p(2) - t(2, 1) +! +! Solve the linear system. +! + call r8mat_solve(dim_num, rhs_num, a, info) + + if (info /= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'TRIANGLE_BARYCENTRIC_2D - Fatal error!' + write (*, '(a)') ' The linear system is singular.' + write (*, '(a)') ' The input data does not form a proper triangle.' + stop 1 + end if + + xsi(1) = a(1, 3) + xsi(2) = a(2, 3) + xsi(3) = 1.0D+00 - xsi(1) - xsi(2) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_centroid_2d(t, centroid) + +! +!! TRIANGLE_CENTROID_2D computes the centroid of a triangle in 2D. +! +! Discussion: +! +! The centroid of a triangle can also be considered the +! center of gravity, or center of mass, assuming that the triangle +! is made of a thin uniform sheet of massy material. +! +! The centroid of a triangle is the intersection of the medians. +! +! A median of a triangle is a line connecting a vertex to the +! midpoint of the opposite side. +! +! In barycentric coordinates, in which the vertices of the triangle +! have the coordinates (1,0,0), (0,1,0) and (0,0,1), the centroid +! has coordinates (1/3,1/3,1/3). +! +! In geometry, the centroid of a triangle is often symbolized by "G". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) centroid(dim_num) + integer(kind=4) i + real(kind=8) t(dim_num, 3) + + do i = 1, dim_num + centroid(i) = sum(t(i, 1:3)) / 3.0D+00 + end do + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_centroid_3d(t, centroid) + +! +!! TRIANGLE_CENTROID_3D computes the centroid of a triangle in 3D. +! +! Discussion: +! +! The centroid of a triangle can also be considered the +! center of gravity or center of mass, assuming that the triangle +! is made of a thin uniform sheet of massy material. +! +! The centroid of a triangle is the intersection of the medians. +! A median of a triangle is a line connecting any vertex to the +! midpoint of the opposite side. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) centroid(dim_num) + integer(kind=4) i + real(kind=8) t(dim_num, 3) + + do i = 1, dim_num + centroid(i) = sum(t(i, 1:3)) / 3.0D+00 + end do + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_circumcenter_2d(t, pc) +! +!! TRIANGLE_CIRCUMCENTER_2D computes the circumcenter of a triangle in 2D. +! +! Discussion: +! +! The circumcenter of a triangle is the center of the circumcircle, the +! circle that passes through the three vertices of the triangle. +! +! The circumcircle contains the triangle, but it is not necessarily the +! smallest triangle to do so. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. +! +! The circumcenter is the intersection of the perpendicular bisectors +! of the sides of the triangle. +! +! In geometry, the circumcenter of a triangle is often symbolized by "O". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) PC(2), the circumcenter of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) det + real(kind=8) f(2) + real(kind=8) pc(dim_num) + real(kind=8) t(dim_num, 3) + real(kind=8) top(dim_num) + + f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 + f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 + + top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) + top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) + + det = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) + + pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / det + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_circumcenter_2d_2(t, pc) + +!*****************************************************************************80 +! +!! TRIANGLE_CIRCUMCENTER_2D_2 computes the circumcenter of a triangle in 2D. +! +! Discussion: +! +! The circumcenter of a triangle is the center of the circumcircle, the +! circle that passes through the three vertices of the triangle. +! +! The circumcircle contains the triangle, but it is not necessarily the +! smallest triangle to do so. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. +! +! The circumcenter is the intersection of the perpendicular bisectors +! of the sides of the triangle. +! +! Surprisingly, the diameter of the circle can be found by solving +! a 2 by 2 linear system. If we label the vertices of the triangle +! P1, P2 and P3, then the vectors P2 - P1 and P3 - P1 are secants of +! the circle, and each forms a right triangle with the diameter +! vector through P1. +! +! Hence, the dot product of P2 - P1 with the diameter vector is equal +! to the square of the length of P2 - P1, and similarly for P3 - P1. +! This determines the diameter vector originating at P1. +! +! In geometry, the circumcenter of a triangle is often symbolized by "O". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) PC(2), the circumcenter of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4), parameter :: rhs_num = 1 + + real(kind=8) a(dim_num, dim_num + rhs_num) + integer(kind=4) info + real(kind=8) pc(dim_num) + real(kind=8) t(dim_num, 3) +! +! Set up the linear system. +! + a(1, 1) = t(1, 2) - t(1, 1) + a(1, 2) = t(2, 2) - t(2, 1) + a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 + + a(2, 1) = t(1, 3) - t(1, 1) + a(2, 2) = t(2, 3) - t(2, 1) + a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 +! +! Solve the linear system. +! + call r8mat_solve(dim_num, rhs_num, a, info) +! +! Compute the center +! + if (info /= 0) then + pc(1:dim_num) = 0.0D+00 + else + pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_circumcenter(n, t, p) + +!*****************************************************************************80 +! +!! TRIANGLE_CIRCUMCENTER computes the circumcenter of a triangle in ND. +! +! Discussion: +! +! Three ND points A, B and C lie on a circle. +! +! The circumcenter P has the formula +! +! P = ( Area ( PBC ) * A + Area ( APC) * B + Area ( ABP ) * C ) +! / ( Area ( PBC ) + Area ( APC ) + Area ( ABP ) ) +! +! The details of the formula rely on information supplied +! by Oscar Lanzi III. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 October 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the spatial dimension. +! +! Input, real ( kind = 8 ) T(N,3), the triangle vertices. +! +! Output, real ( kind = 8 ) P(N), the circumcenter of the triangle. +! + implicit none + + integer(kind=4) n + + real(kind=8) a + real(kind=8) abp + real(kind=8) apc + real(kind=8) b + real(kind=8) c + real(kind=8) p(n) + real(kind=8) pbc + real(kind=8) r8vec_normsq_affine + real(kind=8) t(n, 3) + + a = r8vec_normsq_affine(n, t(1:n, 2), t(1:n, 3)) + b = r8vec_normsq_affine(n, t(1:n, 3), t(1:n, 1)) + c = r8vec_normsq_affine(n, t(1:n, 1), t(1:n, 2)) + + pbc = a * (-a + b + c) + apc = b * (a - b + c) + abp = c * (a + b - c) + + p(1:n) = (pbc * t(1:n, 1) + apc * t(1:n, 2) + abp * t(1:n, 3)) & + / (pbc + apc + abp) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_circumcircle_2d(t, r, pc) + +!*****************************************************************************80 +! +!! TRIANGLE_CIRCUMCIRCLE_2D computes the circumcircle of a triangle in 2D. +! +! Discussion: +! +! The circumcenter of a triangle is the center of the circumcircle, the +! circle that passes through the three vertices of the triangle. +! +! The circumcircle contains the triangle, but it is not necessarily the +! smallest triangle to do so. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. +! +! The circumcenter is the intersection of the perpendicular bisectors +! of the sides of the triangle. +! +! In geometry, the circumcenter of a triangle is often symbolized by "O". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) R, PC(2), the circumradius and circumcenter +! of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) bot + real(kind=8) c + real(kind=8) det + real(kind=8) f(2) + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) top(dim_num) + real(kind=8) t(dim_num, 3) +! +! Circumradius. +! + a = sqrt((t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2) + b = sqrt((t(1, 3) - t(1, 2))**2 + (t(2, 3) - t(2, 2))**2) + c = sqrt((t(1, 1) - t(1, 3))**2 + (t(2, 1) - t(2, 3))**2) + + bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) + + if (bot <= 0.0D+00) then + r = -1.0D+00 + pc(1:2) = 0.0D+00 + return + end if + + r = a * b * c / sqrt(bot) +! +! Circumcenter. +! + f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 + f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 + + top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) + top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) + + det = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) + + pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / det + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_circumcircle_2d_2(t, r, pc) +! +!! TRIANGLE_CIRCUMCIRCLE_2D_2 computes the circumcircle of a triangle in 2D. +! +! Discussion: +! +! The circumscribed circle of a triangle is the circle that passes through +! the three vertices of the triangle. The circumscribed circle contains +! the triangle, but it is not necessarily the smallest triangle to do so. +! +! Surprisingly, the diameter of the circle can be found by solving +! a 2 by 2 linear system. This is because the vectors P2 - P1 +! and P3 - P1 are secants of the circle, and each forms a right +! triangle with the diameter. Hence, the dot product of +! P2 - P1 with the diameter is equal to the square of the length +! of P2 - P1, and similarly for P3 - P1. This determines the +! diameter vector originating at P1. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) R, PC(2), the circumradius and circumcenter. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4), parameter :: rhs_num = 1 + + real(kind=8) a(dim_num, dim_num + rhs_num) + integer(kind=4) info + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) t(dim_num, 3) +! +! Set up the linear system. +! + a(1, 1) = t(1, 2) - t(1, 1) + a(1, 2) = t(2, 2) - t(2, 1) + a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 + + a(2, 1) = t(1, 3) - t(1, 1) + a(2, 2) = t(2, 3) - t(2, 1) + a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 +! +! Solve the linear system. +! + call r8mat_solve(dim_num, rhs_num, a, info) + + if (info /= 0) then + r = -1.0D+00 + pc(1:dim_num) = 0.0D+00 + end if + + r = 0.5D+00 * sqrt(a(1, dim_num + 1) * a(1, dim_num + 1) & + + a(2, dim_num + 1) * a(2, dim_num + 1)) + pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_circumradius_2d(t, r) + +! +!! TRIANGLE_CIRCUMRADIUS_2D computes the circumradius of a triangle in 2D. +! +! Discussion: +! +! The circumscribed circle of a triangle is the circle that passes through +! the three vertices of the triangle. The circumscribed circle contains +! the triangle, but it is not necessarily the smallest triangle to do so. +! +! The circumradius of a triangle is the radius of the circumscribed +! circle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) R, the circumradius of the circumscribed circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) bot + real(kind=8) c + real(kind=8) r + real(kind=8) t(dim_num, 3) +! +! Compute the length of each side. +! + a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) + b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) + c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + + bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) + + if (bot <= 0.0D+00) then + r = -1.0D+00 + return + end if + + r = a * b * c / sqrt(bot) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_contains_line_exp_3d(t, p1, p2, inside, pint) + +! +!! TRIANGLE_CONTAINS_LINE_EXP_3D finds if a line is inside a triangle in 3D. +! +! Discussion: +! +! A line will "intersect" the plane of a triangle in 3D if +! * the line does not lie in the plane of the triangle +! (there would be infinitely many intersections), AND +! * the line does not lie parallel to the plane of the triangle +! (there are no intersections at all). +! +! Therefore, if a line intersects the plane of a triangle, it does so +! at a single point. We say the line is "inside" the triangle if, +! regarded as 2D objects, the intersection point of the line and the plane +! is inside the triangle. +! +! A triangle in 3D is determined by three points: +! +! T(1:3,1), T(1:3,2) and T(1:3,3). +! +! The explicit form of a line in 3D is: +! +! the line through the points P1(1:3), P2(1:3). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Steve Marschner, Cornell University, +! CS465 Notes: Simple Ray-Triangle Intersection. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the line. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if (the intersection point of) +! the line is inside the triangle. +! +! Output, real ( kind = 8 ) PINT(3), the point where the line +! intersects the plane of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + logical(kind=4) inside + integer(kind=4) ival + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) normal(dim_num) + real(kind=8) normal2(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pint(dim_num) + real(kind=8) t(dim_num, 3) + real(kind=8) temp + logical(kind=4) triangle_is_degenerate_nd + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) +! +! Make sure the line is not degenerate. +! + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'TRIANGLE_CONTAINS_LINE_EXP_3D - Fatal error!' + write (*, '(a)') ' The explicit line is degenerate.' + stop 1 + end if +! +! Make sure the triangle is not degenerate. +! + if (triangle_is_degenerate_nd(dim_num, t)) then + write (*, '(a)') ' ' + write (*, '(a)') 'TRIANGLE_CONTAINS_LINE_EXP_3D - Fatal error!' + write (*, '(a)') ' The triangle is degenerate.' + stop 1 + end if +! +! Determine a unit normal vector associated with the plane of +! the triangle. +! + v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) + v2(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 1) + + normal(1) = v1(2) * v2(3) - v1(3) * v2(2) + normal(2) = v1(3) * v2(1) - v1(1) * v2(3) + normal(3) = v1(1) * v2(2) - v1(2) * v2(1) + + temp = sqrt(sum(normal(1:dim_num)**2)) + normal(1:dim_num) = normal(1:dim_num) / temp +! +! 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) + + if (ival == 0) then + inside = .false. + pint(1:dim_num) = huge(temp) + return + else if (ival == 2) then + inside = .false. + pint(1:dim_num) = p1(1:dim_num) + return + end if +! +! Now, check that all three triangles made by two vertices and +! the intersection point have the same "clock sense" as the +! triangle's normal vector. +! + v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) + v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 1) + + normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) + normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) + normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) + + if (dot_product(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) then + inside = .false. + return + end if + + v1(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 2) + v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 2) + + normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) + normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) + normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) + + if (dot_product(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) then + inside = .false. + return + end if + + v1(1:dim_num) = t(1:dim_num, 1) - t(1:dim_num, 3) + v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 3) + + normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) + normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) + normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) + + if (dot_product(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) then + inside = .false. + return + end if + + inside = .true. + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_contains_line_par_3d(t, p0, pd, inside, p) + +! +!! TRIANGLE_CONTAINS_LINE_PAR_3D: finds if a line is inside a triangle in 3D. +! +! Discussion: +! +! A line will "intersect" the plane of a triangle in 3D if +! * the line does not lie in the plane of the triangle +! (there would be infinitely many intersections), AND +! * the line does not lie parallel to the plane of the triangle +! (there are no intersections at all). +! +! Therefore, if a line intersects the plane of a triangle, it does so +! at a single point. We say the line is "inside" the triangle if, +! regarded as 2D objects, the intersection point of the line and the plane +! is inside the triangle. +! +! A triangle in 3D is determined by three points: +! +! T(1:3,1), T(1:3,2) and T(1:3,3). +! +! The parametric form of a line in 3D is: +! +! P(1:3) = P0(1:3) + PD(1:3) * T +! +! We can normalize by requiring PD to have euclidean norm 1, +! and the first nonzero entry positive. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 February 2007 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420, +! page 111. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the three points that define +! the triangle. +! +! Input, real ( kind = 8 ) P0(3), PD(3), parameters that define the +! parametric line. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if (the intersection point of) +! the line is inside the triangle. +! +! Output, real ( kind = 8 ) P(3), is the point of intersection of the line +! and the plane of the triangle, unless they are parallel. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) angle_sum + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) denom + logical(kind=4) inside + logical(kind=4) intersect + real(kind=8) norm + real(kind=8) norm1 + real(kind=8) norm2 + real(kind=8) p(dim_num) + real(kind=8) p0(dim_num) + real(kind=8) pd(dim_num) + real(kind=8) r8_acos + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) t(dim_num, 3) + real(kind=8) t_int + real(kind=8), parameter :: tol = 0.00001D+00 + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) + real(kind=8) v3(dim_num) +! +! Determine the implicit form (A,B,C,D) of the plane containing the +! triangle. +! + a = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & + - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) + + b = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & + - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) + + c = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) + + d = -t(1, 2) * a - t(2, 2) * b - t(3, 2) * c +! +! Make sure the plane is well-defined. +! + norm1 = sqrt(a * a + b * b + c * c) + + if (norm1 == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'TRIANGLE_LINE_PAR_INT_3D - Fatal error!' + write (*, '(a)') ' The plane normal vector is null.' + inside = .false. + p(1:dim_num) = 0.0D+00 + stop 1 + end if +! +! Make sure the implicit line is well defined. +! + norm2 = sqrt(sum(pd(1:dim_num)**2)) + + if (norm2 == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'TRIANGLE_LINE_PAR_INT_3D - Fatal error!' + write (*, '(a)') ' The line direction vector is null.' + inside = .false. + p(1:dim_num) = 0.0D+00 + stop 1 + end if +! +! Determine the denominator of the parameter in the +! implicit line definition that determines the intersection +! point. +! + denom = a * pd(1) + b * pd(2) + c * pd(3) +! +! If DENOM is zero, or very small, the line and the plane may be +! parallel or almost so. +! + if (abs(denom) < tol * norm1 * norm2) then +! +! The line may actually lie in the plane. We're not going +! to try to address this possibility. +! + if (a * p0(1) + b * p0(2) + c * p0(3) + d == 0.0D+00) then + + intersect = .true. + inside = .false. + p(1:dim_num) = p0(1:dim_num) +! +! The line and plane are parallel and disjoint. +! + else + + intersect = .false. + inside = .false. + p(1:dim_num) = 0.0D+00 + + end if +! +! The line and plane intersect at a single point P. +! + else + + intersect = .true. + t_int = -(a * p0(1) + b * p0(2) + c * p0(3) + d) / denom + p(1:dim_num) = p0(1:dim_num) + t_int * pd(1:dim_num) +! +! To see if P is included in the triangle, sum the angles +! formed by P and pairs of the vertices. If the point is in the +! triangle, we get a total 360 degree view. Otherwise, we +! get less than 180 degrees. +! + v1(1:dim_num) = t(1:dim_num, 1) - p(1:dim_num) + v2(1:dim_num) = t(1:dim_num, 2) - p(1:dim_num) + v3(1:dim_num) = t(1:dim_num, 3) - p(1:dim_num) + + norm = sqrt(sum(v1(1:dim_num)**2)) + + if (norm == 0.0D+00) then + inside = .true. + return + end if + + v1(1:dim_num) = v1(1:dim_num) / norm + + norm = sqrt(sum(v2(1:dim_num)**2)) + + if (norm == 0.0D+00) then + inside = .true. + return + end if + + v2(1:dim_num) = v2(1:dim_num) / norm + + norm = sqrt(sum(v3(1:dim_num)**2)) + + if (norm == 0.0D+00) then + inside = .true. + return + end if + + v3(1:dim_num) = v3(1:dim_num) / norm + + angle_sum = r8_acos(dot_product(v1(1:3), v2(1:3))) & + + r8_acos(dot_product(v2(1:3), v3(1:3))) & + + r8_acos(dot_product(v3(1:3), v1(1:3))) + + if (nint(angle_sum / r8_pi) == 2) then + inside = .true. + else + inside = .false. + end if + + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_contains_point_2d_1(t, p, inside) + +! +!! TRIANGLE_CONTAINS_POINT_2D_1 finds if a point is inside a triangle in 2D. +! +! Discussion: +! +! It is conventional to list the triangle vertices in counter clockwise +! order. However, this routine does not require a particular order +! for the vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 June 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside +! the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) + real(kind=8) xsi(dim_num + 1) + + call triangle_barycentric_2d(t, p, xsi) + + if (any(xsi(1:3) < 0.0D+00)) then + inside = .false. + else + inside = .true. + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_contains_point_2d_2(t, p, inside) + +! +!! TRIANGLE_CONTAINS_POINT_2D_2 finds if a point is inside a triangle in 2D. +! +! Discussion: +! +! The routine assumes that the vertices are given in counter clockwise +! order. If the triangle vertices are actually given in clockwise +! order, this routine will behave as though the triangle contains +! no points whatsoever! +! +! The routine determines if a point P is "to the right of" each of the lines +! that bound the triangle. It does this by computing the cross product +! of vectors from a vertex to its next vertex, and to P. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 June 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! The vertices should be given in counter clockwise order. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is +! inside the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) inside + integer(kind=4) j + integer(kind=4) k + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) + + do j = 1, 3 + + k = mod(j, 3) + 1 + + if (0.0D+00 < (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & + - (p(2) - t(2, j)) * (t(1, k) - t(1, j))) then + inside = .false. + return + end if + + end do + + inside = .true. + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_contains_point_2d_3(t, p, inside) + +! +!! TRIANGLE_CONTAINS_POINT_2D_3 finds if a point is inside a triangle in 2D. +! +! Discussion: +! +! This routine is the same as TRIANGLE_CONTAINS_POINT_2D_2, except +! that it does not assume an ordering of the points. It should +! work correctly whether the vertices of the triangle are listed +! in clockwise or counter clockwise order. +! +! The routine determines if a point P is "to the right of" each of the lines +! that bound the triangle. It does this by computing the cross product +! of vectors from a vertex to its next vertex, and to P. +! +! The point is inside the triangle if it is to the right of all +! the lines, or to the left of all the lines. +! +! This version was suggested by Paulo Ernesto of Maptek Brasil. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 June 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is +! inside the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dir_new + real(kind=8) dir_old + logical(kind=4) inside + integer(kind=4) j + integer(kind=4) k + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) + + dir_old = 0.0D+00 + + do j = 1, 3 + + k = mod(j, 3) + 1 + + dir_new = (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & + - (p(2) - t(2, j)) * (t(1, k) - t(1, j)) + + if (dir_new * dir_old < 0.0D+00) then + inside = .false. + return + end if + + if (dir_new /= 0.0D+00) then + dir_old = dir_new + end if + + end do + + inside = .true. + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_diameter_2d(t, diameter) + +! +!! TRIANGLE_DIAMETER_2D computes the diameter of a triangle in 2D. +! +! Discussion: +! +! The diameter of a triangle is the diameter of the smallest circle +! that can be drawn around the triangle. At least two of the vertices +! of the triangle will intersect the circle, but not necessarily +! all three! +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) DIAMETER, the diameter of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) asq + real(kind=8) b + real(kind=8) bsq + real(kind=8) c + real(kind=8) csq + real(kind=8) diameter + real(kind=8) t(dim_num, 3) +! +! Compute the squared length of each side. +! + asq = sum(t(1:dim_num, 1) - t(1:dim_num, 2))**2 + bsq = sum(t(1:dim_num, 2) - t(1:dim_num, 3))**2 + csq = sum(t(1:dim_num, 3) - t(1:dim_num, 1))**2 +! +! Take care of a zero side. +! + if (asq == 0.0D+00) then + diameter = sqrt(bsq) + return + else if (bsq == 0.0D+00) then + diameter = sqrt(csq) + return + else if (csq == 0.0D+00) then + diameter = sqrt(asq) + return + end if +! +! Make ASQ the largest. +! + if (asq < bsq) then + call r8_swap(asq, bsq) + end if + + if (asq < csq) then + call r8_swap(asq, csq) + end if +! +! If ASQ is very large... +! + if (bsq + csq < asq) then + + diameter = sqrt(asq) + + else + + a = sqrt(asq) + b = sqrt(bsq) + c = sqrt(csq) + + diameter = 2.0D+00 * a * b * c / sqrt((a + b + c) * (-a + b + c) & + * (a - b + c) * (a + b - c)) + + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_edge_length_2d(t, edge_length) + +! +!! TRIANGLE_EDGE_LENGTH_2D returns edge lengths of a triangle in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 August 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) EDGE_LENGTH(3), the length of the edges. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) edge_length(3) + integer(kind=4) i4_wrap + integer(kind=4) j1 + integer(kind=4) j2 + real(kind=8) r8vec_norm + real(kind=8) t(dim_num, 3) + + do j1 = 1, 3 + j2 = i4_wrap(j1 + 1, 1, 3) + edge_length(j1) = & + r8vec_norm(dim_num, t(1:dim_num, j2) - t(1:dim_num, j1)) + end do + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_gridpoints_2d(t, sub_num, grid_max, grid_num, g) + +! +!! TRIANGLE_GRIDPOINTS_2D computes gridpoints within a triangle in 2D. +! +! Discussion: +! +! The gridpoints are computed by repeated halving of the triangle. +! The 0-th set of grid points is the vertices themselves. +! The first set of grid points is the midpoints of the sides. +! These points can be used to draw 4 triangles that make up the original +! triangle. The second set of grid points is the side midpoints and +! centers +! of these four triangles. +! +! SUB_NUM GRID_NUM +! ----- ----- +! 0 1 = 1 (centroid) +! 1 1 + 2 = 3 (vertices) +! 2 1 + 2 + 3 = 6 +! 3 1 + 2 + 3 + 4 = 10 +! 4 1 + 2 + 3 + 4 + 5 = 15 +! +! GRID_NUM is the sum of the integers from 1 to SUB_NUM+1 or +! +! GRID_NUM = (SUB_NUM+1) * (SUB_NUM+2) / 2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, integer ( kind = 4 ) SUB_NUM, the number of subdivisions. +! +! Input, integer ( kind = 4 ) GRID_MAX, the maximum number of grid points. +! +! Output, integer ( kind = 4 ) GRID_NUM, the number of grid points returned. +! +! Output, real ( kind = 8 ) G(2,GRID_MAX), the grid points. +! + implicit none + + integer(kind=4) grid_max + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) g(dim_num, grid_max) + integer(kind=4) i + integer(kind=4) j + integer(kind=4) grid_num + integer(kind=4) sub_num + real(kind=8) t(dim_num, 3) + + grid_num = 0 +! +! Special case, SUB_NUM = 0. +! + if (sub_num == 0) then + if (1 <= grid_max) then + grid_num = 1 + g(1, 1) = (t(1, 1) + t(1, 2) + t(1, 3)) / 3.0D+00 + g(2, 1) = (t(2, 1) + t(2, 2) + t(2, 3)) / 3.0D+00 + end if + return + end if + + do i = 0, sub_num + + do j = 0, sub_num - i + + if (grid_num < grid_max) then + + grid_num = grid_num + 1 + + g(1, grid_num) = (real(i, kind=8) * t(1, 1) & + + real(j, kind=8) * t(1, 2) & + + real(sub_num - i - j, kind=8) * t(1, 3)) & + / real(sub_num, kind=8) + + g(2, grid_num) = (real(i, kind=8) * t(2, 1) & + + real(j, kind=8) * t(2, 2) & + + real(sub_num - i - j, kind=8) * t(2, 3)) & + / real(sub_num, kind=8) + end if + + end do + end do + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_incenter_2d(t, pc) + +! +!! TRIANGLE_INCENTER_2D computes the incenter of a triangle in 2D. +! +! Discussion: +! +! The incenter of a triangle is the center of the inscribed circle. +! +! The inscribed circle of a triangle is the largest circle that can +! be drawn inside the triangle. +! +! The inscribed circle is tangent to all three sides of the triangle. +! +! The angle bisectors of the triangle intersect at the center of the +! inscribed circle. +! +! In geometry, the incenter is often represented by "I". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 August 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) PC(2), the incenter. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) pc(dim_num) + real(kind=8) perimeter + real(kind=8) t(dim_num, 3) +! +! Compute the length of each side. +! + a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) + b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) + c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + + perimeter = a + b + c + + if (perimeter == 0.0D+00) then + pc(1:dim_num) = t(1:dim_num, 1) + else + pc(1:dim_num) = (b * t(1:dim_num, 1) & + + c * t(1:dim_num, 2) & + + a * t(1:dim_num, 3)) / perimeter + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_incircle_2d(t, r, pc) + +! +!! TRIANGLE_INCIRCLE_2D computes the inscribed circle of a triangle in 2D. +! +! Discussion: +! +! The inscribed circle of a triangle is the largest circle that can +! be drawn inside the triangle. It is tangent to all three sides, +! and the lines from its center to the vertices bisect the angles +! made by each vertex. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 December 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) R, PC(2), the radius and center of the +! inscribed circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) pc(dim_num) + real(kind=8) perimeter + real(kind=8) r + real(kind=8) t(dim_num, 3) +! +! Compute the length of each side. +! + a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) + b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) + c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + + perimeter = a + b + c + + if (perimeter == 0.0D+00) then + pc(1:dim_num) = t(1:dim_num, 1) + r = 0.0D+00 + return + end if + + pc(1:dim_num) = ( & + b * t(1:dim_num, 1) & + + c * t(1:dim_num, 2) & + + a * t(1:dim_num, 3)) / perimeter + + r = 0.5D+00 * sqrt( & + (-a + b + c) & + * (+a - b + c) & + * (+a + b - c) / perimeter) + + return +end + +!---------------------------------------------------------------------------- +! + +!---------------------------------------------------------------------------- +subroutine triangle_inradius_2d(t, r) + +! +!! TRIANGLE_INRADIUS_2D: radius of the inscribed circle of a triangle in 2D. +! +! Discussion: +! +! The inscribed circle of a triangle is the largest circle that can +! be drawn inside the triangle. It is tangent to all three sides, +! and the lines from its center to the vertices bisect the angles +! made by each vertex. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 13 April 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) R, the radius of the inscribed circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) perimeter + real(kind=8) r + real(kind=8) t(dim_num, 3) +! +! Compute the length of each side. +! + a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) + b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) + c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + + perimeter = a + b + c + + if (perimeter == 0.0D+00) then + r = 0.0D+00 + return + end if + + r = 0.5D+00 * sqrt( & + (-a + b + c) & + * (+a - b + c) & + * (+a + b - c) / perimeter) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function triangle_is_degenerate_nd(dim_num, t) + +! +!! TRIANGLE_IS_DEGENERATE_ND finds if a triangle is degenerate in ND. +! +! Discussion: +! +! A triangle in ND is described by the coordinates of its 3 vertices. +! +! A triangle in ND is degenerate if any two vertices are equal. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) T(DIM_NUM,3), the triangle vertices. +! +! Output, logical ( kind = 4 ) TRIANGLE_IS_DEGENERATE_ND, is TRUE if the +! triangle is degenerate. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) t(dim_num, 3) + logical(kind=4) triangle_is_degenerate_nd + + triangle_is_degenerate_nd = & + (all(t(1:dim_num, 1) == t(1:dim_num, 2)) .or. & + all(t(1:dim_num, 2) == t(1:dim_num, 3)) .or. & + all(t(1:dim_num, 3) == t(1:dim_num, 1))) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_lattice_layer_point_next(c, v, more) + +!*****************************************************************************80 +! +!! TRIANGLE_LATTICE_LAYER_POINT_NEXT: next triangle lattice layer point. +! +! Discussion: +! +! The triangle lattice layer L is bounded by the lines +! +! 0 <= X, +! 0 <= Y, +! L - 1 < X / C(1) + Y / C(2) <= L. +! +! In particular, layer L = 0 always contains the single point (0,0). +! +! This function returns, one at a time, the points that lie within +! a given triangle lattice layer. +! +! Thus, if we set C(1) = 2, C(2) = 3, then we get the following layers: +! +! L = 0: (0,0) +! L = 1: (1,0), (2,0), (0,1), (1,1), (0,2), (0,3) +! L = 2: (3,0), (4,0), (2,1), (3,1), (1,2), (2,2), (1,3), (2,3), +! (0,4), (1,4), (0,5), (0,6). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) C(3), coefficients defining the +! lattice layer. Entry C(3) contains the layer index. +! C(1) and C(2) should be positive, and C(3) must be nonnegative. +! +! Input/output, integer ( kind = 4 ) V(2). On first call for a given layer, +! the input value of V is not important. On a repeated call for the same +! layer, the input value of V should be the output value from the previous +! call. On output, V contains the next lattice layer point. +! +! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to +! indicate that this is the first call for a given layer. Thereafter, the +! input value should be the output value from the previous call. On output, +! MORE is TRUE if the returned value V is a new point. +! If the output value is FALSE, then no more points were found, +! and V was reset to 0, and the lattice layer has been exhausted. +! + implicit none + + integer(kind=4) c(3) + integer(kind=4) c1n + integer(kind=4) i4vec_lcm + logical(kind=4) more + integer(kind=4), parameter :: n = 2 + integer(kind=4) rhs1 + integer(kind=4) rhs2 + integer(kind=4) v(2) +! +! Treat layer C(N+1) = 0 specially. +! + if (c(n + 1) == 0) then + if (.not. more) then + v(1:n) = 0 + more = .true. + else + more = .false. + end if + return + end if +! +! Compute first point. +! + if (.not. more) then + + v(1) = (c(n + 1) - 1) * c(1) + 1 + v(2) = 0 + more = .true. + + else + + c1n = i4vec_lcm(n, c) + + rhs1 = c1n * (c(n + 1) - 1) + rhs2 = c1n * c(n + 1) + + if (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs2) then + v(1) = v(1) + 1 + else + v(1) = (rhs1 - c(1) * (v(2) + 1)) / c(2) + v(1) = max(v(1), 0) + v(2) = v(2) + 1 + if (c(2) * v(1) + c(1) * v(2) <= rhs1) then + v(1) = v(1) + 1 + end if + if (c(2) * v(1) + c(1) * v(2) <= rhs2) then + + else + v(1:n) = 0 + more = .false. + end if + end if + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_lattice_point_next(c, v, more) + +!! TRIANGLE_LATTICE_POINT_NEXT returns the next triangle lattice point. +! +! Discussion: +! +! The lattice triangle is defined by the vertices: +! +! (0,0), (C(3)/C(1), 0) and (0,C(3)/C(2)) +! +! The lattice triangle is bounded by the lines +! +! 0 <= X, +! 0 <= Y +! X / C(1) + Y / C(2) <= C(3) +! +! Lattice points are listed one at a time, starting at the origin, +! with X increasing first. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) C(3), coefficients defining the +! lattice triangle. These should be positive. +! +! Input/output, integer ( kind = 4 ) V(2). On first call, the input +! value is not important. On a repeated call, the input value should +! be the output value from the previous call. On output, V contains +! the next lattice point. +! +! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to +! indicate that this is the first call for a given triangle. Thereafter, +! the input value should be the output value from the previous call. On +! output, MORE is TRUE if the returned value V is a new lattice point. +! If the output value is FALSE, then no more lattice points were found, +! and V was reset to 0, and the routine should not be called further +! for this triangle. +! + implicit none + + integer(kind=4) c(3) + integer(kind=4) c1n + integer(kind=4) i4vec_lcm + logical(kind=4) more + integer(kind=4), parameter :: n = 2 + integer(kind=4) rhs + integer(kind=4) v(2) + + if (.not. more) then + + v(1:n) = 0 + more = .true. + + else + + c1n = i4vec_lcm(n, c) + + rhs = c1n * c(n + 1) + + if (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs) then + v(1) = v(1) + 1 + else + v(1) = 0 + if (c(2) * v(1) + c(1) * (v(2) + 1) <= rhs) then + v(2) = v(2) + 1 + else + v(2) = 0 + more = .false. + end if + end if + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_line_imp_int_2d(t, a, b, c, int_num, pint) + +!*****************************************************************************80 +! +!! TRIANGLE_LINE_IMP_INT_2D: implicit line intersects a triangle in 2D. +! +! Discussion: +! +! An implicit line is the set of points ( X, Y ) satisfying +! +! A * X + B * Y + C = 0 +! +! where at least one of A and B is not zero. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, real ( kind = 8 ) A, B, C, determine the equation of the line: +! A*X + B*Y + C = 0. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of points of intersection +! of the line with the triangle. INT_NUM may be 0, 1, 2 or 3. +! +! Output, real ( kind = 8 ) PINT(2,3), contains the intersection points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) a1 + real(kind=8) b + real(kind=8) b1 + real(kind=8) c + real(kind=8) c1 + integer(kind=4) i + integer(kind=4) i4_wrap + integer(kind=4) int_num + integer(kind=4) ival + integer(kind=4) j + real(kind=8) p(dim_num) + real(kind=8) pint(dim_num, 3) + real(kind=8) t(dim_num, 3) + real(kind=8) test1 + real(kind=8) test2 + + int_num = 0 + + do i = 1, 3 + + j = i4_wrap(i + 1, 1, 3) +! +! Get the implicit form of the line through vertices I and I+1. +! + call line_exp2imp_2d(t(1:2, i), t(1:2, j), a1, b1, c1) +! +! Seek an intersection with the original line. +! + call lines_imp_int_2d(a, b, c, a1, b1, c1, ival, p) +! +! If there is an intersection, determine if it lies between the two vertices. +! + if (ival == 1) then + + test1 = sum((p(1:dim_num) - t(1:dim_num, i)) & + * (t(1:dim_num, j) - t(1:dim_num, i))) + test2 = sum((t(1:dim_num, j) - t(1:dim_num, i)) & + * (t(1:dim_num, j) - t(1:dim_num, i))) + + if (0 <= test1 .and. test1 <= test2) then + int_num = int_num + 1 + pint(1:dim_num, int_num) = p(1:dim_num) + end if + + end if + + end do + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function triangle_orientation_2d(t) + +! +!! TRIANGLE_ORIENTATION_2D determines the orientation of a triangle in 2D. +! +! Discussion: +! +! Three distinct non-colinear points in the plane define a circle. +! If the points are visited in the order P1, P2, and then +! P3, this motion defines a clockwise or counter clockwise +! rotation along the circle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, integer ( kind = 4 ) TRIANGLE_ORIENTATION_2D, reports if the +! three points lie clockwise on the circle that passes through them. +! The possible return values are: +! 0, the points are distinct, noncolinear, and lie counter clockwise +! on their circle. +! 1, the points are distinct, noncolinear, and lie clockwise +! on their circle. +! 2, the points are distinct and colinear. +! 3, at least two of the points are identical. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) det + integer(kind=4) triangle_orientation_2d + real(kind=8) t(dim_num, 3) + + if (all(t(1:dim_num, 1) == t(1:dim_num, 2)) .or. & + all(t(1:dim_num, 2) == t(1:dim_num, 3)) .or. & + all(t(1:dim_num, 3) == t(1:dim_num, 1))) then + triangle_orientation_2d = 3 + return + end if + + det = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & + - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) + + if (det == 0.0D+00) then + triangle_orientation_2d = 2 + else if (det < 0.0D+00) then + triangle_orientation_2d = 1 + else if (0.0D+00 < det) then + triangle_orientation_2d = 0 + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_orthocenter_2d(t, pc) + +! +!! TRIANGLE_ORTHOCENTER_2D computes the orthocenter of a triangle in 2D. +! +! Discussion: +! +! The orthocenter is defined as the intersection of the three altitudes +! of a triangle. +! +! An altitude of a triangle is the line through a vertex of the triangle +! and perpendicular to the opposite side. +! +! In geometry, the orthocenter of a triangle is often symbolized by "H". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 July 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) PC(2), the orthocenter of the triangle. +! +! Output, logical ( kind = 4 ) FLAG, is TRUE if the value could not +! be computed. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) flag + integer(kind=4) ival + real(kind=8) p23(dim_num) + real(kind=8) p31(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r8_huge + real(kind=8) t(dim_num, 3) +! +! Determine a point P23 common to the line (P2,P3) and +! its perpendicular through P1. +! + call line_exp_perp_2d(t(1:2, 2), t(1:2, 3), t(1:2, 1), p23, flag) + + if (flag) then + pc(1:2) = r8_huge() + return + end if +! +! Determine a point P31 common to the line (P3,P1) and +! its perpendicular through P2. +! + call line_exp_perp_2d(t(1:2, 3), t(1:2, 1), t(1:2, 2), p31, flag) + + if (flag) then + pc(1:2) = r8_huge() + return + end if +! +! Determine PC, the intersection of the lines (P1,P23) and (P2,P31). +! + call lines_exp_int_2d(t(1:2, 1), p23(1:2), t(1:2, 2), p31(1:2), ival, pc) + + if (ival /= 1) then + pc(1:2) = r8_huge() + flag = .true. + return + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_point_dist_2d(t, p, dist) + +! +!! TRIANGLE_POINT_DIST_2D: distance ( triangle, point ) in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4), parameter :: side_num = 3 + + real(kind=8) dist + real(kind=8) dist2 + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, side_num) +! +! Find the distance to each of the line segments. +! + dist = huge(dist) + + do j = 1, side_num + + jp1 = i4_wrap(j + 1, 1, side_num) + + call segment_point_dist_2d(t(1:dim_num, j), t(1:dim_num, jp1), p, dist2) + + if (dist2 < dist) then + dist = dist2 + end if + + end do + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_point_dist_3d(t, p, dist) + +! +!! TRIANGLE_POINT_DIST_3D: distance ( triangle, point ) in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the triangle vertices. +! +! Input, real ( kind = 8 ) P(3), the point which is to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! triangle. DIST is zero if the point lies exactly on the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dist + real(kind=8) dist2 + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) +! +! Compute the distances from the point to each of the sides. +! + call segment_point_dist_3d(t(1:dim_num, 1), t(1:dim_num, 2), p, dist2) + + dist = dist2 + + call segment_point_dist_3d(t(1:dim_num, 2), t(1:dim_num, 3), p, dist2) + + dist = min(dist, dist2) + + call segment_point_dist_3d(t(1:dim_num, 3), t(1:dim_num, 1), p, dist2) + + dist = min(dist, dist2) + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_point_dist_signed_2d(t, p, dist_signed) + +! +!! TRIANGLE_POINT_DIST_SIGNED_2D: signed distance ( triangle, point ) in 2D. +! +! Discussion: +! +! If the signed distance is: +! 0, the point is on the boundary of the triangle; +! negative, the point is in the triangle; +! positive, the point is outside the triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! These should be given in counter clockwise order. +! +! Input, real ( kind = 8 ) P(2), the point which is to be checked. +! +! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the +! point to the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dis12 + real(kind=8) dis23 + real(kind=8) dis31 + real(kind=8) dist_signed + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) +! +! Compute the signed line distances to the point. +! + call line_exp_point_dist_signed_2d(t(1:2, 1), t(1:2, 2), p, dis12) + + call line_exp_point_dist_signed_2d(t(1:2, 2), t(1:2, 3), p, dis23) + + call line_exp_point_dist_signed_2d(t(1:2, 3), t(1:2, 1), p, dis31) +! +! If the point is inside the triangle, all the line distances are negative. +! The largest (negative) line distance has the smallest magnitude, +! and is the signed triangle distance. +! + if (dis12 <= 0.0D+00 .and. dis23 <= 0.0D+00 .and. dis31 <= 0.0D+00) then + dist_signed = max(dis12, dis23, dis31) +! +! If the point is outside the triangle, then we have to compute +! the (positive) line segment distances and take the minimum. +! + else + + call segment_point_dist_2d(t(1:2, 1), t(1:2, 2), p, dis12) + call segment_point_dist_2d(t(1:2, 2), t(1:2, 3), p, dis23) + call segment_point_dist_2d(t(1:2, 3), t(1:2, 1), p, dis31) + + dist_signed = min(dis12, dis23, dis31) + + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_point_near_2d(t, p, pn, dist) + +! +!! TRIANGLE_POINT_NEAR_2D computes the nearest point on a triangle in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, real ( kind = 8 ) P(2), the point whose nearest triangle point +! is to be determined. +! +! Output, real ( kind = 8 ) PN(2), the nearest point to P. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4), parameter :: side_num = 3 + + real(kind=8) dist + real(kind=8) dist2 + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) pn2(dim_num) + real(kind=8) t(dim_num, side_num) + real(kind=8) tval +! +! Find the distance to each of the line segments that make up the edges +! of the triangle. +! + dist = huge(dist) + pn(1:dim_num) = 0.0D+00 + + 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) + + if (dist2 < dist) then + dist = dist2 + pn(1:dim_num) = pn2(1:dim_num) + end if + + end do + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_quality_2d(t, quality) + +! +!! TRIANGLE_QUALITY_2D: "quality" of a triangle in 2D. +! +! Discussion: +! +! The quality of a triangle is 2.0 times the ratio of the radius of +! the inscribed circle divided by that of the circumscribed circle. +! An equilateral triangle achieves the maximum possible quality of 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 July 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) QUALITY, the quality of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) quality + real(kind=8) t(dim_num, 3) +! +! Compute the length of each side. +! + a = sqrt(sum((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) + b = sqrt(sum((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) + c = sqrt(sum((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + + if (a * b * c == 0.0D+00) then + quality = 0.0D+00 + else + quality = (-a + b + c) * (a - b + c) * (a + b - c) & + / (a * b * c) + end if + + return +end + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +subroutine triangle_right_lattice_point_num_2d(a, b, n) + +! +!! TRIANGLE_RIGHT_LATTICE_POINT_NUM_2D: count lattice points. +! +! Discussion: +! +! The triangle is assumed to be a right triangle which, without loss +! of generality, has the coordinates: +! +! ( (0,0), (a,0), (0,b) ) +! +! The routine returns the number of integer lattice points that appear +! inside the triangle or on its edges or vertices. +! +! The formula for this function occurred to me (JVB) after some thought, +! on 06 July 2009. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) A, B, define the vertices. +! +! Output, integer ( kind = 4 ) N, the number of lattice points. +! + implicit none + + integer(kind=4) a + integer(kind=4) b + integer(kind=4) i4_gcd + integer(kind=4) n + + n = ((a + 1) * (b + 1) + i4_gcd(a, b) + 1) / 2 + + return +end +subroutine triangle_sample(t, n, seed, p) + +!*****************************************************************************80 +! +!! TRIANGLE_SAMPLE returns random points in a triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 April 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, integer ( kind = 4 ) N, the number of points to generate. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, real ( kind = 8 ) P(2,N), random points in the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4) n + + real(kind=8) alpha(n) + integer(kind=4) dim + real(kind=8) p(dim_num, n) + real(kind=8) p12(dim_num, n) + real(kind=8) p13(dim_num, n) + integer(kind=4) seed + real(kind=8) t(dim_num, 3) +! +! For comparison between F90, C++ and MATLAB codes, call R8VEC_UNIFORM_01. +! For faster execution, call RANDOM_NUMBER. +! + if (.true.) then + + call r8vec_uniform_01(n, seed, alpha) + + else + + call random_number(harvest=alpha(1:n)) + + end if +! +! Interpret R as a percentage of the triangle's area. +! +! Imagine a line L, parallel to side 1, so that the area between +! vertex 1 and line L is R percent of the full triangle's area. +! +! The line L will intersect sides 2 and 3 at a fraction +! ALPHA = SQRT ( R ) of the distance from vertex 1 to vertices 2 and 3. +! + alpha(1:n) = sqrt(alpha(1:n)) +! +! Determine the coordinates of the points on sides 2 and 3 intersected +! by line L. +! + do dim = 1, dim_num + + p12(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & + + alpha(1:n) * t(dim, 2) + + p13(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & + + alpha(1:n) * t(dim, 3) + + end do +! +! Now choose, uniformly at random, a point on the line L. +! +! For comparison between F90, C++ and MATLAB codes, call R8VEC_UNIFORM_01. +! For faster execution, call RANDOM_NUMBER. +! + if (.true.) then + + call r8vec_uniform_01(n, seed, alpha) + + else + + call random_number(harvest=alpha(1:n)) + + end if + + do dim = 1, dim_num + + p(dim, 1:n) = (1.0D+00 - alpha(1:n)) * p12(dim, 1:n) & + + alpha(1:n) * p13(dim, 1:n) + + end do + + return +end +subroutine triangle01_lattice_point_num_2d(s, n) + +!*****************************************************************************80 +! +!! TRIANGLE01_LATTICE_POINT_NUM_2D: count lattice points. +! +! Discussion: +! +! The triangle is assumed to be the unit triangle: +! +! ( (0,0), (1,0), (0,1) ) +! +! or a copy of this triangle scaled by an integer S: +! +! ( (0,0), (S,0), (0,S) ). +! +! The routine returns the number of integer lattice points that appear +! inside the triangle or on its edges or vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 July 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Matthias Beck, Sinai Robins, +! Computing the Continuous Discretely, +! Springer, 2006, +! ISBN13: 978-0387291390, +! LC: QA640.7.B43. +! +! Parameters: +! +! Input, integer ( kind = 4 ) S, the scale factor. +! +! Output, integer ( kind = 4 ) N, the number of lattice points. +! + implicit none + + integer(kind=4) n + integer(kind=4) s + + n = ((s + 2) * (s + 1)) / 2 + + return +end +subroutine triangle_xsi_to_xy_2d(t, xsi, p) + +!*****************************************************************************80 +! +!! TRIANGLE_XSI_TO_XY_2D converts from barycentric to XY coordinates in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, real ( kind = 8 ) XSI(3), the barycentric coordinates of a point. +! XSI(1) + XSI(2) + XSI(3) should equal 1, but this is not checked. +! +! Output, real ( kind = 8 ) P(2), the XY coordinates of the point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) + real(kind=8) xsi(dim_num + 1) + + p(1:dim_num) = matmul(t(1:dim_num, 1:3), xsi(1:dim_num + 1)) + + return +end +subroutine triangle_xy_to_xsi_2d(t, p, xsi) + +!*****************************************************************************80 +! +!! TRIANGLE_XY_TO_XSI_2D converts from XY to barycentric in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Input, real ( kind = 8 ) P(2), the XY coordinates of a point. +! +! Output, real ( kind = 8 ) XSI(3), the barycentric coordinates of the point. +! XSI1 + XSI2 + XSI3 should equal 1. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) det + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) + real(kind=8) xsi(3) + + det = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & + - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) + + xsi(1) = ((t(2, 2) - t(2, 3)) * (p(1) - t(1, 3)) & + - (t(1, 2) - t(1, 3)) * (p(2) - t(2, 3))) / det + + xsi(2) = (-(t(2, 1) - t(2, 3)) * (p(1) - t(1, 3)) & + + (t(1, 1) - t(1, 3)) * (p(2) - t(2, 3))) / det + + xsi(3) = 1.0D+00 - xsi(1) - xsi(2) + + return +end diff --git a/src/modules/Geometry/src/assets/geometry_by_burkardt.inc b/src/modules/Geometry/src/assets/geometry_by_burkardt.inc new file mode 100644 index 000000000..8cba7d6f7 --- /dev/null +++ b/src/modules/Geometry/src/assets/geometry_by_burkardt.inc @@ -0,0 +1,34798 @@ +subroutine angle_box_2d(dist, p1, p2, p3, p4, p5) + +!*****************************************************************************80 +! +!! ANGLE_BOX_2D "boxes" an angle defined by three points in 2D. +! +! Discussion: +! +! The routine is given points P1, P2 and P3, determining the two lines: +! P1 to P2 +! and +! P2 to P3 +! and a nonnegative distance +! DIST. +! +! The routine returns a pair of "corner" points +! P4 and P5 +! both of which are a distance DIST from both lines, and in fact, +! both of which are a distance DIST from P2. +! +! / P3 +! / / / +! - - - - - - - - -P4 - / -P6 - - - +! / / / +! P1---------------/--P2----------------- +! / / / +! - - - - - - -P7 - / -P5 - - - - - +! / / / +! +! In the illustration, P1, P2 and P3 are the points defining the lines. +! +! P4 and P5 represent the desired "corner points", which +! are on the positive or negative sides of both lines. +! +! P6 and P7 represent the undesired points, which +! are on the positive side of one line and the negative of the other. +! +! Special cases: +! +! if P1 = P2, this is the same as extending the line from +! P3 through P2 without a bend. +! +! if P3 = P2, this is the same as extending the line from +! P1 through P2 without a bend. +! +! if P1 = P2 = P3 this is an error. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DIST, the nonnegative distance from P1 +! to the computed points P4 and P5. +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2). +! P1 and P2 are distinct points that define a line. +! P2 and P3 are distinct points that define a line. +! +! Output, real ( kind = 8 ) P4(2), P5(2), points which lie DIST units from +! the line between P1 and P2, and from the line between P2 and P3. +! + implicit none + + real(kind=8) dist + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) p3(2) + real(kind=8) p4(2) + real(kind=8) p5(2) + real(kind=8) stheta + real(kind=8) temp1 + real(kind=8) temp2 + real(kind=8) u(2) + real(kind=8) u1(2) + real(kind=8) u2(2) +! +! If DIST = 0, assume the user knows best. +! + if (dist == 0.0D+00) then + p4(1:2) = p2(1:2) + p5(1:2) = p2(1:2) + return + end if +! +! Fail if all three points are equal. +! + if (all(p1(1:2) == p2(1:2)) .and. & + all(p2(1:2) == p3(1:2))) then + write (*, '(a)') ' ' + write (*, '(a)') 'ANGLE_BOX_2D - Fatal error!' + write (*, '(a)') ' Input points P1 = P2 = P3.' + write (*, '(a,2g14.6)') ' P1 = ', p1(1:2) + stop 1 + end if +! +! If P1 = P2, extend the line through the doubled point. +! + if (all(p1(1:2) == p2(1:2))) then + u2(1) = p3(2) - p2(2) + u2(2) = p2(1) - p3(1) + temp1 = sqrt(sum(u2(1:2)**2)) + u2(1:2) = u2(1:2) / temp1 + p4(1:2) = p2(1:2) + dist * u2(1:2) + p5(1:2) = p2(1:2) - dist * u2(1:2) + return + end if +! +! If P2 = P3, extend the line through the doubled point. +! + if (all(p2(1:2) == p3(1:2))) then + u1(1) = p1(2) - p2(2) + u1(2) = p2(1) - p1(1) + temp1 = sqrt(sum(u1(1:2)**2)) + u1(1:2) = u1(1:2) / temp1 + p4(1:2) = p2(1:2) + dist * u1(1:2) + p5(1:2) = p2(1:2) - dist * u1(1:2) + return + end if +! +! Compute the unit normal vectors to each line. +! We choose the sign so that the unit normal to line 1 has +! a positive dot product with line 2. +! + u1(1) = p1(2) - p2(2) + u1(2) = p2(1) - p1(1) + temp1 = sqrt(sum(u1(1:2)**2)) + u1(1:2) = u1(1:2) / temp1 + + temp1 = dot_product(u1(1:2), p3(1:2) - p2(1:2)) + + if (temp1 < 0.0D+00) then + u1(1:2) = -u1(1:2) + end if + + u2(1) = p3(2) - p2(2) + u2(2) = p2(1) - p3(1) + temp1 = sqrt(sum(u2(1:2)**2)) + u2(1:2) = u2(1:2) / temp1 + + temp1 = dot_product(u2(1:2), p1(1:2) - p2(1:2)) + if (temp1 < 0.0D+00) then + u2(1:2) = -u2(1:2) + end if +! +! Try to catch the case where we can't determine the +! sign of U1, because both U1 and -U1 are perpendicular +! to (P3-P2)...and similarly for U2 and (P1-P2). +! + temp1 = dot_product(u1(1:2), p3(1:2) - p2(1:2)) + temp2 = dot_product(u2(1:2), p1(1:2) - p2(1:2)) + + if (temp1 == 0.0D+00 .or. temp2 == 0.0D+00) then + + if (dot_product(u1(1:2), u2(1:2)) < 0.0D+00) then + u1(1:2) = -u1(1:2) + end if + + end if +! +! Try to catch a line turning back on itself, evidenced by +! Cos(theta) = (P3-P2) dot (P2-P1) / ( norm(P3-P2) * norm(P2-P1) ) +! being -1, or very close to -1. +! + temp1 = dot_product(p3(1:2) - p2(1:2), p2(1:2) - p1(1:2)) + + temp1 = temp1 / & + (sqrt(sum((p3(1:2) - p2(1:2))**2)) & + * sqrt(sum((p2(1:2) - p1(1:2))**2))) + + if (temp1 < -0.99D+00) then + temp1 = sqrt(sum((p2(1:2) - p1(1:2))**2)) + p4(1:2) = p2(1:2) + dist * (p2(1:2) - p1(1:2)) & + / temp1 + dist * u1(1:2) + p5(1:2) = p2(1:2) + dist * (p2(1:2) - p1(1:2)) & + / temp1 - dist * u1(1:2) + return + end if +! +! Compute the "average" unit normal vector. +! +! The average of the unit normals could be zero, but only when +! the second line has the same direction and opposite sense +! of the first, and we've already checked for that case. +! +! Well, check again! This problem "bit" me in the case where +! P1 = P2, which I now treat specially just to guarantee I +! avoid this problem! +! + if (dot_product(u1(1:2), u2(1:2)) < 0.0D+00) then + u2(1:2) = -u2(1:2) + end if + + u(1:2) = 0.5D+00 * (u1(1:2) + u2(1:2)) + temp1 = sqrt(sum(u(1:2)**2)) + u(1:2) = u(1:2) / temp1 +! +! You must go DIST/STHETA units along this unit normal to +! result in a distance DIST from line1 (and line2). +! + stheta = dot_product(u(1:2), u1(1:2)) + + p4(1:2) = p2(1:2) + dist * u(1:2) / stheta + p5(1:2) = p2(1:2) - dist * u(1:2) / stheta + + return +end +subroutine angle_contains_point_2d(p1, p2, p3, p, inside) + +!*****************************************************************************80 +! +!! ANGLE_CONTAINS_POINT_2D determines if an angle contains a point, in 2D. +! +! Discussion: +! +! The angle is defined by the sequence of points P1, P2 and P3. +! +! The point is "contained" by the angle if the ray P - P2 +! is between (in a counter clockwise sense) the rays P1 - P2 +! and P3 - P2. +! +! P1 +! / +! / P +! / . +! / . +! P2--------->P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the coordinates of +! three points that define the angle. The order of these points matters! +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside +! the angle. +! + implicit none + + real(kind=8) angle_rad_2d + logical(kind=4) inside + real(kind=8) p(2) + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) p3(2) + + if (angle_rad_2d(p1, p2, p) <= angle_rad_2d(p1, p2, p3)) then + inside = .true. + else + inside = .false. + end if + + return +end +function angle_deg_2d(p1, p2, p3) + +!*****************************************************************************80 +! +!! ANGLE_DEG_2D returns the angle swept out between two rays in 2D. +! +! Discussion: +! +! Except for the zero angle case, it should be true that +! +! ANGLE_DEG_2D ( P1, P2, P3 ) + ANGLE_DEG_2D ( P3, P2, P1 ) = 360.0 +! +! P1 +! / +! / +! / +! / +! P2--------->P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), define the rays +! P1 - P2 and P3 - P2 which define the angle. +! +! Output, real ( kind = 8 ) ANGLE_DEG_2D, the angle swept out by the +! rays, measured in degrees. 0 <= ANGLE_DEG_2D < 360. If either ray +! has zero length, then ANGLE_DEG_2D is set to 0. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle_deg_2d + real(kind=8) angle_rad_2d + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radians_to_degrees + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + + p(1) = (p3(1) - p2(1)) * (p1(1) - p2(1)) & + + (p3(2) - p2(2)) * (p1(2) - p2(2)) + + p(2) = (p3(1) - p2(1)) * (p1(2) - p2(2)) & + - (p3(2) - p2(2)) * (p1(1) - p2(1)) + + if (p(1) == 0.0D+00 .and. p(2) == 0.0D+00) then + angle_deg_2d = 0.0D+00 + return + end if + + angle_rad_2d = atan2(p(2), p(1)) + + if (angle_rad_2d < 0.0D+00) then + angle_rad_2d = angle_rad_2d + 2.0D+00 * r8_pi + end if + + angle_deg_2d = radians_to_degrees(angle_rad_2d) + + return +end +subroutine angle_half_2d(p1, p2, p3, p4) + +!*****************************************************************************80 +! +!! ANGLE_HALF_2D finds half an angle in 2D. +! +! Discussion: +! +! The original angle is defined by the sequence of points P1, P2 and P3. +! +! The point P4 is calculated so that: +! +! (P1,P2,P4) = (P1,P2,P3) / 2 +! +! P1 +! / +! / P4 +! / . +! / . +! P2--------->P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), points defining the angle. +! +! Input, real ( kind = 8 ) P4(2), a point defining the half angle. +! The vector P4 - P2 will have unit norm. +! + implicit none + + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) p3(2) + real(kind=8) p4(2) + + p4(1:2) = 0.5D+00 * ( & + (p1(1:2) - p2(1:2)) / sqrt(sum((p1(1:2) - p2(1:2))**2)) & + + (p3(1:2) - p2(1:2)) / sqrt(sum((p3(1:2) - p2(1:2))**2))) + + p4(1:2) = p2(1:2) + p4(1:2) / sqrt(sum(p4(1:2)**2)) + + return +end +function angle_rad_2d(p1, p2, p3) + +!*****************************************************************************80 +! +!! ANGLE_RAD_2D returns the angle in radians swept out between two rays in 2D. +! +! Discussion: +! +! Except for the zero angle case, it should be true that +! +! ANGLE_RAD_2D ( P1, P2, P3 ) + ANGLE_RAD_2D ( P3, P2, P1 ) = 2 * PI +! +! P1 +! / +! / +! / +! / +! P2--------->P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), define the rays +! P1 - P2 and P3 - P2 which define the angle. +! +! Output, real ( kind = 8 ) ANGLE_RAD_2D, the angle swept out by the rays, +! in radians. 0 <= ANGLE_RAD_2D < 2 * PI. If either ray has zero +! length, then ANGLE_RAD_2D is set to 0. +! + implicit none + + real(kind=8) angle_rad_2d + real(kind=8) p(2) + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) p3(2) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + p(1) = (p3(1) - p2(1)) * (p1(1) - p2(1)) & + + (p3(2) - p2(2)) * (p1(2) - p2(2)) + + p(2) = (p3(1) - p2(1)) * (p1(2) - p2(2)) & + - (p3(2) - p2(2)) * (p1(1) - p2(1)) + + if (all(p(1:2) == 0.0D+00)) then + angle_rad_2d = 0.0D+00 + return + end if + + angle_rad_2d = atan2(p(2), p(1)) + + if (angle_rad_2d < 0.0D+00) then + angle_rad_2d = angle_rad_2d + 2.0D+00 * r8_pi + end if + + return +end +function angle_rad_3d(p1, p2, p3) + +!*****************************************************************************80 +! +!! ANGLE_RAD_3D returns the angle in radians between two rays in 3D. +! +! Discussion: +! +! The routine always computes the SMALLER of the two angles between +! two rays. Thus, if the rays make an (exterior) angle of +! 1.5 pi radians, the (interior) angle of 0.5 pi radians will be reported. +! +! X dot Y = Norm(X) * Norm(Y) * Cos ( Angle(X,Y) ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), points defining an angle. +! The rays are P1 - P2 and P3 - P2. +! +! Output, real ( kind = 8 ) ANGLE_RAD_3D, the angle between the two rays, +! in radians. This value will always be between 0 and PI. If either ray has +! zero length, then the angle is returned as zero. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) angle_rad_3d + real(kind=8) dot + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) r8_acos + real(kind=8) v1norm + real(kind=8) v2norm + + v1norm = sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) + + if (v1norm == 0.0D+00) then + angle_rad_3d = 0.0D+00 + return + end if + + v2norm = sqrt(sum((p3(1:dim_num) - p2(1:dim_num))**2)) + + if (v2norm == 0.0D+00) then + angle_rad_3d = 0.0D+00 + return + end if + + dot = sum((p1(1:dim_num) - p2(1:dim_num)) & + * (p3(1:dim_num) - p2(1:dim_num))) + + angle_rad_3d = r8_acos(dot / (v1norm * v2norm)) + + return +end +function angle_rad_nd(dim_num, v1, v2) + +!*****************************************************************************80 +! +!! ANGLE_RAD_ND returns the angle in radians between two rays in ND. +! +! Discussion: +! +! This routine always computes the SMALLER of the two angles between +! two rays. Thus, if the rays make an (exterior) angle of 1.5 PI, +! then the (interior) angle of 0.5 PI is reported. +! +! X dot Y = Norm(X) * Norm(Y) * Cos( Angle(X,Y) ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the two rays. +! +! Output, real ( kind = 8 ) ANGLE_RAD_ND, the angle between the rays, +! in radians. This value will always be between 0 and PI. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) angle_rad_nd + real(kind=8) dot + real(kind=8) r8_acos + real(kind=8) v1(dim_num) + real(kind=8) v1norm + real(kind=8) v2(dim_num) + real(kind=8) v2norm + + dot = dot_product(v1(1:dim_num), v2(1:dim_num)) + + v1norm = sqrt(sum(v1(1:dim_num)**2)) + + if (v1norm == 0.0D+00) then + angle_rad_nd = 0.0D+00 + return + end if + + v2norm = sqrt(sum(v2(1:dim_num)**2)) + + if (v2norm == 0.0D+00) then + angle_rad_nd = 0.0D+00 + return + end if + + angle_rad_nd = r8_acos(dot / (v1norm * v2norm)) + + return +end +subroutine angle_turn_2d(p1, p2, p3, turn) + +!*****************************************************************************80 +! +!! ANGLE_TURN_2D computes a turning angle in 2D. +! +! Discussion: +! +! This routine is most useful when considering the vertices of a +! polygonal shape. We wish to distinguish between angles that "turn +! in" to the shape, (between 0 and 180 degrees) and angles that +! "turn out" (between 180 and 360 degrees), as we traverse the boundary. +! +! If we compute the interior angle and subtract 180 degrees, we get the +! supplementary angle, which has the nice property that it is +! negative for "in" angles and positive for "out" angles, and is zero if +! the three points actually lie along a line. +! +! Assuming P1, P2 and P3 define an angle, the TURN can be +! defined to be either: +! +! * the supplementary angle to the angle formed by P1=P2=P3, or +! +! * the angle between the vector ( P3-P2) and the vector -(P1-P2), +! where -(P1-P2) can be understood as the vector that continues +! through P2 from the direction P1. +! +! The turning will be zero if P1, P2 and P3 lie along a straight line. +! +! It will be a positive angle if the turn from the previous direction +! is counter clockwise, and negative if it is clockwise. +! +! The turn is given in radians, and will lie between -PI and PI. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 13 August 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the points that form +! the angle. +! +! Output, real ( kind = 8 ) TURN, the turn angle, between -PI and PI. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) r8_atan + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) turn + + p(1) = (p3(1) - p2(1)) * (p1(1) - p2(1)) & + + (p3(2) - p2(2)) * (p1(2) - p2(2)) + + p(2) = (p3(1) - p2(1)) * (p1(2) - p2(2)) & + - (p3(2) - p2(2)) * (p1(1) - p2(1)) + + if (p(1) == 0.0D+00 .and. p(2) == 0.0D+00) then + turn = 0.0D+00 + else + turn = r8_pi - r8_atan(p(2), p(1)) + end if + + return +end +subroutine annulus_area_2d(r1, r2, area) + +!*****************************************************************************80 +! +!! ANNULUS_AREA_2D computes the area of a circular annulus in 2D. +! +! Discussion: +! +! A circular annulus with center (XC,YC), inner radius R1 and +! outer radius R2, is the set of points (X,Y) so that +! +! R1^2 <= (X-XC)^2 + (Y-YC)^2 <= R2^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the inner and outer radii. +! +! Output, real ( kind = 8 ) AREA, the area. +! + implicit none + + real(kind=8) area + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + area = r8_pi * (r2 + r1) * (r2 - r1) + + return +end +subroutine annulus_sector_area_2d(r1, r2, theta1, theta2, area) + +!*****************************************************************************80 +! +!! ANNULUS_SECTOR_AREA_2D computes the area of an annular sector in 2D. +! +! Discussion: +! +! An annular sector with center PC, inner radius R1 and +! outer radius R2, and angles THETA1, THETA2, is the set of points +! P so that +! +! R1^2 <= (P(1)-PC(1))^2 + (P(2)-PC(2))^2 <= R2^2 +! +! and +! +! THETA1 <= THETA ( P - PC ) <= THETA2 +! +! Modified: +! +! 02 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the inner and outer radii. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles. +! +! Output, real ( kind = 8 ) AREA, the area. +! + implicit none + + real(kind=8) area + real(kind=8) r1 + real(kind=8) r2 + real(kind=8) theta1 + real(kind=8) theta2 + + area = 0.5D+00 * (theta2 - theta1) * (r2 + r1) * (r2 - r1) + + return +end +subroutine annulus_sector_centroid_2d(pc, r1, r2, theta1, theta2, centroid) + +!*****************************************************************************80 +! +!! ANNULUS_SECTOR_CENTROID_2D computes the centroid of an annular sector in 2D. +! +! Discussion: +! +! An annular sector with center PC, inner radius R1 and +! outer radius R2, and angles THETA1, THETA2, is the set of points +! P so that +! +! R1^2 <= (P(1)-PC(1))^2 + (P(2)-PC(2))^2 <= R2^2 +! +! and +! +! THETA1 <= THETA ( P - PC ) <= THETA2 +! +! Thanks to Ed Segall for pointing out a mistake in the computation +! of the angle THETA associated with the centroid. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 December 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! John Harris, Horst Stocker, +! Handbook of Mathematics and Computational Science, +! Springer, 1998, QA40.S76 +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(2), the center. +! +! Input, real ( kind = 8 ) R1, R2, the inner and outer radii. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles. +! +! Output, real ( kind = 8 ) CENTROID(2), the centroid. +! + implicit none + + real(kind=8) centroid(2) + real(kind=8) pc(2) + real(kind=8) r + real(kind=8) r1 + real(kind=8) r2 + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + + theta = theta2 - theta1 + + r = 4.0D+00 * sin(theta / 2.0D+00) / (3.0D+00 * theta) & + * (r1 * r1 + r1 * r2 + r2 * r2) / (r1 + r2) + + centroid(1) = pc(1) + r * cos(theta1 + theta / 2.0D+00) + centroid(2) = pc(2) + r * sin(theta1 + theta / 2.0D+00) + + return +end +subroutine ball01_sample_2d(seed, p) + +!*****************************************************************************80 +! +!! BALL01_SAMPLE_2D picks a random point in the unit ball in 2D. +! +! Discussion: +! +! The unit ball is the set of points P such that +! +! P(1) * P(1) + P(2) * P(2) <= 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, real ( kind = 8 ) P(2), a random point in the unit ball. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) p(dim_num) + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seed + real(kind=8) theta + real(kind=8) u(dim_num) + + call r8vec_uniform_01(dim_num, seed, u) + + r = sqrt(u(1)) + theta = 2.0D+00 * r8_pi * u(2) + + p(1) = r * cos(theta) + p(2) = r * sin(theta) + + return +end +subroutine ball01_sample_3d(seed, p) + +!*****************************************************************************80 +! +!! BALL01_SAMPLE_3D picks a random point in the unit ball in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, real ( kind = 8 ) P(3), the sample point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) p(dim_num) + real(kind=8) phi + real(kind=8) r + real(kind=8) r8_acos + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seed + real(kind=8) theta + real(kind=8) u(dim_num) + real(kind=8) vdot + + call r8vec_uniform_01(dim_num, seed, u) +! +! Pick a uniformly random VDOT, which must be between -1 and 1. +! This represents the dot product of the random vector with the Z unit vector. +! +! Note: this works because the surface area of the sphere between +! Z and Z + dZ is independent of Z. So choosing Z uniformly chooses +! a patch of area uniformly. +! + vdot = 2.0D+00 * u(1) - 1.0D+00 + + phi = r8_acos(vdot) +! +! Pick a uniformly random rotation between 0 and 2 Pi around the +! axis of the Z vector. +! + theta = 2.0D+00 * r8_pi * u(2) +! +! Pick a random radius R. +! + r = u(3)**(1.0D+00 / 3.0D+00) + + p(1) = r * cos(theta) * sin(phi) + p(2) = r * sin(theta) * sin(phi) + p(3) = r * cos(phi) + + return +end +subroutine ball01_sample_nd(dim_num, seed, p) + +!*****************************************************************************80 +! +!! BALL01_SAMPLE_ND picks a random point in the unit ball in ND. +! +! Discussion: +! +! N-1 random Givens rotations are applied to the point ( 1, 0, 0, ..., 0 ). +! +! The I-th Givens rotation is in the plane of coordinate axes I and I+1, +! and has the form: +! +! [ cos ( theta ) - sin ( theta ) ] * x(i) = x'(i) +! [ sin ( theta ) cos ( theta ) ] x(i+1) x'(i+1) +! +! Finally, a scaling is applied to set the point at a distance R +! from the origin, in a way that results in a uniform distribution. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, real ( kind = 8 ) P(N), the random point. +! + implicit none + + integer(kind=4) dim_num + + integer(kind=4) i + real(kind=8) p(dim_num) + real(kind=8) pi + real(kind=8) r + real(kind=8) r8_uniform_01 + real(kind=8) random_cosine + real(kind=8) random_sign + real(kind=8) random_sine + integer(kind=4) seed + + p(1) = 1.0D+00 + p(2:dim_num) = 0.0D+00 + + do i = 1, dim_num - 1 + + r = r8_uniform_01(seed) + random_cosine = 2.0D+00 * r - 1.0D+00 + r = r8_uniform_01(seed) + random_sign = real(2 * int(2.0D+00 * r) - 1, kind=8) + r = r8_uniform_01(seed) + random_sine = random_sign * sqrt(1.0D+00 - random_cosine * random_cosine) + + pi = p(i) + p(i) = random_cosine * pi + p(i + 1) = random_sine * pi + + end do + + r = r8_uniform_01(seed) + + r = r**(1.0D+00 / real(dim_num, kind=8)) + + p(1:dim_num) = r * p(1:dim_num) + + return +end +function ball01_volume() + +!*****************************************************************************80 +! +!! BALL01_VOLUME returns the volume of the unit ball in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) BALL01_VOLUME_3D, the volume. +! + implicit none + + real(kind=8) ball01_volume + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + r = 1.0D+00 + ball01_volume = 4.0D+00 * r8_pi * r**3 / 3.0D+00 + + return +end +subroutine basis_map_3d(u, v, a, ierror) + +!*****************************************************************************80 +! +!! BASIS_MAP_3D computes the matrix which maps one basis to another in 3D. +! +! Discussion: +! +! As long as the column vectors U1, U2 and U3 are linearly independent, +! a matrix A will be computed that maps U1 to V1, U2 to V2, and +! U3 to V3, where V1, V2 and V3 are the columns of V. +! +! Depending on the values of the vectors, A may represent a +! rotation, reflection, dilation, projection, or a combination of these +! basic linear transformations. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) U(3,3), the columns of U are the three +! "domain" or "preimage" vectors, which should be linearly independent. +! +! Input, real ( kind = 8 ) V(3,3), the columns of V are the three +! "range" or "image" vectors. +! +! Output, real ( kind = 8 ) A(3,3), a matrix with the property that +! A * U1 = V1, A * U2 = V2 and A * U3 = V3. +! +! Output, integer ( kind = 4 ) IERROR, error flag. +! 0, no error occurred. +! nonzero, the matrix [ U1 | U2 | U3 ] is exactly singular. +! + implicit none + + real(kind=8) a(3, 3) + real(kind=8) b(3, 3) + real(kind=8) c(3, 3) + real(kind=8) det + integer(kind=4) ierror + real(kind=8) u(3, 3) + real(kind=8) v(3, 3) + + ierror = 0 +! +! Compute C = the inverse of [ U1 | U2 | U3 ]. +! + b(1:3, 1:3) = u(1:3, 1:3) + + call r8mat_inverse_3d(b, c, det) + + if (det == 0.0D+00) then + ierror = 1 + return + end if +! +! A = [ V1 | V2 | V3 ] * inverse [ U1 | U2 | U3 ]. +! + a(1:3, 1:3) = matmul(v(1:3, 1:3), c(1:3, 1:3)) + + return +end +function box_contains_point_2d(p1, p2, p) + +!*****************************************************************************80 +! +!! BOX_CONTAINS_POINT_2D determines if a point is inside a box in 2D. +! +! Discussion: +! +! A box in 2D is a rectangle with sides aligned on coordinate +! axes. It can be described by its low and high corners, P1 and P2 +! as the set of points P satisfying: +! +! P1(1:2) <= P(1:2) <= P2(1:2). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 June 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the low and high +! corners of the box. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) BOX_CONTAINS_POINT_2D, is TRUE if the point +! is inside the box. +! + implicit none + + logical(kind=4) box_contains_point_2d + real(kind=8) p(2) + real(kind=8) p1(2) + real(kind=8) p2(2) + + if (p(1) < p1(1) .or. & + p2(1) < p(1) .or. & + p(2) < p1(2) .or. & + p2(2) < p(2)) then + box_contains_point_2d = .false. + else + box_contains_point_2d = .true. + end if + + return +end +function box_contains_point_nd(dim_num, p1, p2, p) + +!*****************************************************************************80 +! +!! BOX_CONTAINS_POINT_ND determines if a point is inside a box in ND. +! +! Discussion: +! +! A box is a rectangle with sides aligned on coordinate +! axes. It can be described by its low and high corners, P1 and P2 +! as the set of points P satisfying: +! +! P1(1:DIM_NUM) <= P(1:DIM_NUM) <= P2(1:DIM_NUM). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), the low and high +! corners of the box. +! +! Input, real ( kind = 8 ) P(DIM_NUM), the point to be checked. +! +! Output, logical ( kind = 4 ) BOX_CONTAINS_POINT_ND, is TRUE if the point +! is inside the box. +! + implicit none + + integer(kind=4) dim_num + + logical(kind=4) box_contains_point_nd + integer(kind=4) i + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + box_contains_point_nd = .false. + + do i = 1, dim_num + if (p(i) < p1(i) .or. p2(i) < p(i)) then + return + end if + end do + + box_contains_point_nd = .true. + + return +end +function box_contains_segment_nd(dim_num, p1, p2, pa, pb) + +!*****************************************************************************80 +! +!! BOX_CONTAINS_SEGMENT_ND reports if a box contains a line segment in ND. +! +! Discussion: +! +! A box is assumed to be a rectangle with sides aligned on coordinate +! axes. It can be described by its low and high corners, P1 and P2 +! as the set of points P satisfying: +! +! P1(1:DIM_NUM) <= P(1:DIM_NUM) <= P2(1:DIM_NUM). +! +! A line segment is the finite portion of a line that lies between +! two points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), the low and high corners +! of the box. +! +! Input, real ( kind = 8 ) PA(DIM_NUM), PB(DIM_NUM), the endpoints of the +! line segment. +! +! Output, logical ( kind = 4 ) BOX_CONTAINS_SEGMENT_ND, is TRUE if the box +! contains the line segment. +! + implicit none + + integer(kind=4) dim_num + + logical(kind=4) box_contains_segment_nd + logical(kind=4) box_contains_point_nd + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pa(dim_num) + real(kind=8) pb(dim_num) + + box_contains_segment_nd = .false. + + if (.not. box_contains_point_nd(dim_num, p1, p2, pa)) then + return + end if + + if (.not. box_contains_point_nd(dim_num, p1, p2, pb)) then + return + end if + + box_contains_segment_nd = .true. + + return +end +subroutine box_ray_int_2d(p1, p2, pa, pb, pint) + +!*****************************************************************************80 +! +!! BOX_RAY_INT_2D: intersection ( box, ray ) in 2D. +! +! Discussion: +! +! A box in 2D is a rectangle with sides aligned on coordinate +! axes. It can be described by its low and high corners, P1 and P2 +! as the set of points P satisfying: +! +! P1(1:2) <= P(1:2) <= P2(1:2). +! +! The origin of the ray is assumed to be inside the box. This +! guarantees that the ray will intersect the box in exactly one point. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the low and high corners of the box. +! +! Input, real ( kind = 8 ) PA(2), the origin of the ray, which should be +! inside the box. +! +! Input, real ( kind = 8 ) PB(2), a second point on the ray. +! +! Output, real ( kind = 8 ) PINT(2), the point on the box intersected +! by the ray. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) inside + integer(kind=4) ival + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) pa(2) + real(kind=8) pb(2) + real(kind=8) pc(2) + real(kind=8) pd(2) + real(kind=8) pint(2) + integer(kind=4) side + + do side = 1, 4 + + if (side == 1) then + pd(1:2) = (/p1(1), p1(2)/) + pc(1:2) = (/p2(1), p1(2)/) + else if (side == 2) then + pd(1:2) = (/p2(1), p1(2)/) + pc(1:2) = (/p2(1), p2(2)/) + else if (side == 3) then + pd(1:2) = (/p2(1), p2(2)/) + pc(1:2) = (/p1(1), p2(2)/) + else if (side == 4) then + pd(1:2) = (/p1(1), p2(2)/) + pc(1:2) = (/p1(1), p1(2)/) + end if + + call angle_contains_point_2d(pc, pa, pd, pb, inside) + + if (inside) then + exit + end if + + if (side == 4) then + write (*, '(a)') ' ' + write (*, '(a)') 'BOX_RAY_INT_2D - Fatal error!' + write (*, '(a)') ' No intersection could be found.' + stop 1 + end if + + end do + + call lines_exp_int_2d(pa, pb, pc, pd, ival, pint) + + return +end +subroutine box_segment_clip_2d(p1, p2, pa, pb, ival) + +!*****************************************************************************80 +! +!! BOX_SEGMENT_CLIP_2D uses a box to clip a line segment in 2D. +! +! Discussion: +! +! A box in 2D is a rectangle with sides aligned on coordinate +! axes. It can be described by its low and high corners, P1 and P2 +! as the set of points P satisfying: +! +! P1(1:2) <= P(1:2) <= P2(1:2). +! +! A line segment is the finite portion of a line that lies between +! two points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 March 2011 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the low and high corners of the box. +! +! Input/output, real ( kind = 8 ) PA(2), PB(2); on input, the endpoints +! of a line segment. On output, the endpoints of the portion of the +! line segment that lies inside the box. However, if no part of the +! initial line segment lies inside the box, the output value is the +! same as the input value. +! +! Output, integer ( kind = 4 ) IVAL: +! -1, no part of the line segment is within the box. +! 0, no clipping was necessary. +! 1, PA was clipped. +! 2, PB was clipped. +! 3, PA and PB were clipped. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) clip_a + logical(kind=4) clip_b + integer(kind=4) ival + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pa(dim_num) + real(kind=8) pb(dim_num) + real(kind=8) q(dim_num) + + clip_a = .false. + clip_b = .false. +! +! Require that XMIN <= X. +! + if (pa(1) < p1(1) .and. pb(1) < p1(1)) then + ival = -1 + return + end if + + if (pa(1) < p1(1) .and. p1(1) <= pb(1)) then + q(1) = p1(1) + q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) + pa(1:2) = q(1:2) + clip_a = .true. + else if (p1(1) <= pa(1) .and. pb(1) < p1(1)) then + q(1) = p1(1) + q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) + pb(1:2) = q(1:2) + clip_b = .true. + end if +! +! Require that X <= XMAX. +! + if (p2(1) < pa(1) .and. p2(1) < pb(1)) then + ival = -1 + return + end if + + if (p2(1) < pa(1) .and. pb(1) <= p2(1)) then + q(1) = p2(1) + q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) + pa(1:2) = q(1:2) + clip_a = .true. + else if (pa(1) <= p2(1) .and. p2(1) < pb(1)) then + q(1) = p2(1) + q(2) = pa(2) + (pb(2) - pa(2)) * (q(1) - pa(1)) / (pb(1) - pa(1)) + pb(1:2) = q(1:2) + clip_b = .true. + end if +! +! Require that YMIN <= Y. +! + if (pa(2) < p1(2) .and. pb(2) < p1(2)) then + ival = -1 + return + end if + + if (pa(2) < p1(2) .and. p1(2) <= pb(2)) then + q(2) = p1(2) + q(1) = pa(1) + (pb(1) - pa(1)) * (q(2) - pa(2)) / (pb(2) - pa(2)) + pa(1:2) = q(1:2) + clip_a = .true. + else if (p1(2) <= pa(2) .and. pb(2) < p1(2)) then + q(2) = p1(2) + q(1) = pa(1) + (pb(1) - pa(1)) * (q(2) - pa(2)) / (pb(2) - pa(2)) + pb(1:2) = q(1:2) + clip_b = .true. + end if +! +! Require that Y <= YMAX. +! + if (p2(2) < pa(2) .and. p2(2) < pb(2)) then + ival = -1 + return + end if + + if (p2(2) < pa(2) .and. pb(2) <= p2(2)) then + q(2) = p2(2) + q(1) = pa(1) + (pb(1) - pa(1)) * (q(2) - pa(2)) / (pb(2) - pa(2)) + pa(1:2) = q(1:2) + clip_a = .true. + else if (pa(2) <= p2(2) .and. p2(2) < pb(2)) then + q(2) = p2(2) + q(1) = pa(1) + (pb(1) - pa(1)) * (p2(2) - pa(2)) / (pb(2) - pa(2)) + pb(1:2) = q(1:2) + clip_b = .true. + end if + + ival = 0 + + if (clip_a) then + ival = ival + 1 + end if + + if (clip_b) then + ival = ival + 2 + end if + + return +end +function box01_contains_point_2d(p) + +!*****************************************************************************80 +! +!! BOX01_CONTAINS_POINT_2D determines if a point is inside the unit box in 2D. +! +! Discussion: +! +! A unit box is assumed to be a rectangle with sides aligned on coordinate +! axes. It can be described as the set of points P satisfying: +! +! 0.0 <= P(1:DIM_NUM) <= 1.0 +! +! 0.0 <= P(1:2) <= 1.0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) BOX01_CONTAINS_POINT_2D, is TRUE if the +! point is inside the box. +! + implicit none + + logical(kind=4) box01_contains_point_2d + real(kind=8) p(2) + + box01_contains_point_2d = & + all(0.0D+00 <= p(1:2)) .and. all(p(1:2) <= 1.0D+00) + + return +end +function box01_contains_point_nd(dim_num, p) + +!*****************************************************************************80 +! +!! BOX01_CONTAINS_POINT_ND determines if a point is inside the unit box in ND. +! +! Discussion: +! +! A unit box is assumed to be a rectangle with sides aligned on coordinate +! axes. It can be described as the set of points P satisfying: +! +! 0.0 <= P(1:DIM_NUM) <= 1.0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 June 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) P(DIM_NUM), the point to be checked. +! +! Output, logical ( kind = 4 ) BOX_01_CONTAINS_POINT_ND, is TRUE +! if the point is inside the box. +! + implicit none + + integer(kind=4) dim_num + + logical(kind=4) box01_contains_point_nd + real(kind=8) p(dim_num) + + box01_contains_point_nd = & + all(0.0D+00 <= p(1:dim_num)) .and. all(p(1:dim_num) <= 1.0D+00) + + return +end +subroutine circle_arc_point_near_2d(r, pc, theta1, theta2, p, pn, & + dist) + +!*****************************************************************************80 +! +!! CIRCLE_ARC_POINT_NEAR_2D : nearest point on a circular arc. +! +! Discussion: +! +! A circular arc is defined by the portion of a circle (R,C) +! between two angles (THETA1,THETA2). +! +! Thus, a point P on a circular arc satisfies +! +! ( P(1) - PC(1) ) * ( P(1) - PC(1) ) +! + ( P(2) - PC(2) ) * ( P(2) - PC(2) ) = R * R +! +! and +! +! Theta1 <= Theta <= Theta2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, +! in radians. Normally, THETA1 < THETA2. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) PN(2), a point on the circular arc which is +! nearest to the point. +! +! Output, real ( kind = 8 ) DIST, the distance to the nearest point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) r + real(kind=8) r2 + real(kind=8) r8_atan + real(kind=8) r8_modp + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 +! +! Special case, the zero circle. +! + if (r == 0.0D+00) then + pn(1:dim_num) = pc(1:dim_num) + dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + return + end if +! +! Determine the angle made by the point. +! + theta = r8_atan(p(2) - pc(2), p(1) - pc(1)) +! +! If the angle is between THETA1 and THETA2, then you can +! simply project the point onto the arc. +! + if (r8_modp(theta - theta1, 2.0D+00 * r8_pi) <= & + r8_modp(theta2 - theta1, 2.0D+00 * r8_pi)) then + + r2 = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) + + pn(1:dim_num) = pc(1:dim_num) + (p(1:dim_num) - pc(1:dim_num)) * r / r2 +! +! Otherwise, if the angle is less than the negative of the +! average of THETA1 and THETA2, it's on the side of the arc +! where the endpoint associated with THETA2 is closest. +! + else if (r8_modp(theta - 0.5D+00 * (theta1 + theta2), 2.0D+00 * r8_pi) & + <= r8_pi) then + + pn(1:dim_num) = pc(1:dim_num) + r * (/cos(theta2), sin(theta2)/) +! +! Otherwise, the endpoint associated with THETA1 is closest. +! + else + + pn(1:dim_num) = pc(1:dim_num) + r * (/cos(theta1), sin(theta1)/) + + end if + + dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + + return +end +subroutine circle_area_2d(r, area) + +!*****************************************************************************80 +! +!! CIRCLE_AREA_2D computes the area of a circle in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 December 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Output, real ( kind = 8 ) AREA, the area of the circle. +! + implicit none + + real(kind=8) area + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + area = r8_pi * r * r + + return +end +subroutine circle_dia2imp_2d(p1, p2, r, pc) + +!*****************************************************************************80 +! +!! CIRCLE_DIA2IMP_2D converts a diameter to an implicit circle in 2D. +! +! Discussion: +! +! The diameter form of a circle is: +! +! P1 and P2 are the endpoints of a diameter. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points that are the +! endpoints of a diameter of the circle. +! +! Output, real ( kind = 8 ) R, the radius of the circle. +! +! Output, real ( kind = 8 ) PC(2), the center of the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + + r = 0.5D+00 * sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) + + pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) + + return +end +subroutine circle_exp_contains_point_2d(p1, p2, p3, p, inside) + +!*****************************************************************************80 +! +!! CIRCLE_EXP_CONTAINS_POINT_2D: explicit circle contains a point in 2D. +! +! Discussion: +! +! The explicit form of a circle in 2D is: +! +! The circle passing through points P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 January 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), three points on a circle. +! +! Input, real ( kind = 8 ) P(2), the point to test. +! +! Output, integer ( kind = 4 ) INSIDE, reports the result: +! -1, the three points are distinct and noncolinear, +! and P lies inside the circle. +! 0, the three points are distinct and noncolinear, +! and P lies on the circle. +! 1, the three points are distinct and noncolinear, +! and P lies outside the circle. +! 2, the three points are distinct and colinear, +! and P lies on the line. +! 3, the three points are distinct and colinear, +! and P does not lie on the line. +! 4, two points are distinct, and P lies on the line. +! 5, two points are distinct, and P does not lie on the line. +! 6, all three points are equal, and P is equal to them, +! 7, all three points are equal, and P is not equal to them. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a(4, 4) + real(kind=8) det + real(kind=8) r8mat_det_4d + integer(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) +! +! P1 = P2? +! + if (all(p1(1:dim_num) == p2(1:dim_num))) then + + if (all(p1(1:dim_num) == p3(1:dim_num))) then + + if (all(p1(1:dim_num) == p(1:dim_num))) then + inside = 6 + else + inside = 7 + end if + + else + + det = (p1(1) - p3(1)) * (p(2) - p3(2)) & + - (p(1) - p3(1)) * (p1(2) - p3(2)) + + if (det == 0.0D+00) then + inside = 4 + else + inside = 5 + end if + end if + + return + + end if +! +! P1 does not equal P2. Does P1 = P3? +! + if (all(p1(1:dim_num) == p3(1:dim_num))) then + + det = (p1(1) - p2(1)) * (p(2) - p2(2)) & + - (p(1) - p2(1)) * (p1(2) - p2(2)) + + if (det == 0.0D+00) then + inside = 4 + else + inside = 5 + end if + + return + + end if +! +! The points are distinct. Are they colinear? +! + det = (p1(1) - p2(1)) * (p3(2) - p2(2)) & + - (p3(1) - p2(1)) * (p1(2) - p2(2)) + + if (det == 0.0D+00) then + + det = (p1(1) - p2(1)) * (p(2) - p2(2)) & + - (p(1) - p2(1)) * (p1(2) - p2(2)) + + if (det == 0.0D+00) then + inside = 2 + else + inside = 3 + end if + + return + + end if +! +! The points are distinct and non-colinear. +! +! Compute the determinant +! + a(1, 1) = p1(1) + a(1, 2) = p1(2) + a(1, 3) = p1(1) * p1(1) + p1(2) * p1(2) + a(1, 4) = 1.0D+00 + + a(2, 1) = p2(1) + a(2, 2) = p2(2) + a(2, 3) = p2(1) * p2(1) + p2(2) * p2(2) + a(2, 4) = 1.0D+00 + + a(3, 1) = p3(1) + a(3, 2) = p3(2) + a(3, 3) = p3(1) * p3(1) + p3(2) * p3(2) + a(3, 4) = 1.0D+00 + + a(4, 1) = p(1) + a(4, 2) = p(2) + a(4, 3) = p(1) * p(1) + p(2) * p(2) + a(4, 4) = 1.0D+00 + + det = r8mat_det_4d(a) + + if (det < 0.0D+00) then + inside = 1 + else if (det == 0.0D+00) then + inside = 0 + else + inside = -1 + end if + + return +end +subroutine circle_exp2imp_2d(p1, p2, p3, r, pc) + +!*****************************************************************************80 +! +!! CIRCLE_EXP2IMP_2D converts a circle from explicit to implicit form in 2D. +! +! Discussion: +! +! The explicit form of a circle in 2D is: +! +! The circle passing through points P1, P2 and P3. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Any three distinct points define a circle, as long as they don't lie +! on a straight line. (If the points do lie on a straight line, we +! could stretch the definition of a circle to allow an infinite radius +! and a center at some infinite point.) +! +! The diameter of the circle can be found by solving a 2 by 2 linear system. +! This is because the vectors P2 - P1 and P3 - P1 are secants of the circle, +! and each forms a right triangle with the diameter. Hence, the dot product +! of P2 - P1 with the diameter is equal to the square of the length +! of P2 - P1, and similarly for P3 - P1. These two equations determine the +! diameter vector originating at P1. +! +! If all three points are equal, return a circle of radius 0 and +! the obvious center. +! +! If two points are equal, return a circle of radius half the distance +! between the two distinct points, and center their average. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 March 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Joseph ORourke, +! Computational Geometry, +! Second Edition, +! Cambridge, 1998, +! ISBN: 0521649765, +! LC: QA448.D38. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), three points on the circle. +! +! Output, real ( kind = 8 ) R, the radius of the circle. Normally, R will +! be positive. R will be (meaningfully) zero if all three points are +! equal. If two points are equal, R is returned as the distance between +! two nonequal points. R is returned as -1 in the unlikely event that +! the points are numerically collinear; philosophically speaking, R +! should actually be "infinity" in this case. +! +! Output, real ( kind = 8 ) PC(2), the center of the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) e + real(kind=8) f + real(kind=8) g + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r +! +! If all three points are equal, then the +! circle of radius 0 and center P1 passes through the points. +! + if (all(p1(1:dim_num) == p2(1:dim_num)) .and. & + all(p1(1:dim_num) == p3(1:dim_num))) then + r = 0.0D+00 + pc(1:dim_num) = p1(1:dim_num) + return + end if +! +! If exactly two points are equal, then the circle is defined as +! having the obvious radius and center. +! + if (all(p1(1:dim_num) == p2(1:dim_num))) then + + r = 0.5D+00 * sqrt(sum((p1(1:dim_num) - p3(1:dim_num))**2)) + pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p3(1:dim_num)) + return + + else if (all(p1(1:dim_num) == p3(1:dim_num))) then + + r = 0.5D+00 * sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) + pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) + return + + else if (all(p2(1:dim_num) == p3(1:dim_num))) then + + r = 0.5D+00 * sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) + pc(1:dim_num) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) + return + + end if +! +! We check for collinearity. A more useful check would compare the +! absolute value of G to a small quantity. +! + e = (p2(1) - p1(1)) * (p1(1) + p2(1)) & + + (p2(2) - p1(2)) * (p1(2) + p2(2)) + + f = (p3(1) - p1(1)) * (p1(1) + p3(1)) & + + (p3(2) - p1(2)) * (p1(2) + p3(2)) + + g = (p2(1) - p1(1)) * (p3(2) - p2(2)) & + - (p2(2) - p1(2)) * (p3(1) - p2(1)) + + if (g == 0.0D+00) then + pc(1:2) = (/0.0D+00, 0.0D+00/) + r = -1.0D+00 + return + end if +! +! The center is halfway along the diameter vector from P1. +! + pc(1) = 0.5D+00 * ((p3(2) - p1(2)) * e - (p2(2) - p1(2)) * f) / g + pc(2) = 0.5D+00 * ((p2(1) - p1(1)) * f - (p3(1) - p1(1)) * e) / g +! +! Knowing the center, the radius is now easy to compute. +! + r = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) + + return +end +subroutine circle_imp_contains_point_2d(r, pc, p, inside) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_CONTAINS_POINT_2D: implicit circle contains a point in 2D? +! +! Discussion: +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside or +! on the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + + if ((p(1) - pc(1)) * (p(1) - pc(1)) & + + (p(2) - pc(2)) * (p(2) - pc(2)) <= r * r) then + inside = .true. + else + inside = .false. + end if + + return +end +subroutine circle_imp_line_exp_dist_2d(r, pc, p1, p2, dist) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_LINE_EXP_DIST_2D: distance ( impl circle, explicit line ) in 2D. +! +! Discussion: +! +! The distance is zero if the line intersects the circle. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The distance between the circle and the line is zero if +! and only if they intersect. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 November 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! +! Output, real ( kind = 8 ) DIST, the distance of the line to the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + + call line_exp_point_dist_2d(p1, p2, pc, dist) + + dist = dist - r + + if (dist < 0.0D+00) then + dist = 0.0D+00 + end if + + return +end +subroutine circle_imp_line_par_int_2d(r, pc, x0, y0, f, g, int_num, p) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_LINE_PAR_INT_2D: ( imp circle, param line ) intersection in 2D. +! +! Discussion: +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F^2 + G^2 = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) F, G, X0, Y0, the parametric parameters of +! the line. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersecting +! points found. INT_NUM will be 0, 1 or 2. +! +! Output, real ( kind = 8 ) P(2,INT_NUM), the intersecting points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) f + real(kind=8) g + integer(kind=4) int_num + real(kind=8) p(dim_num, 2) + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) root + real(kind=8) t + real(kind=8) x0 + real(kind=8) y0 + + root = r * r * (f * f + g * g) - (f * (pc(2) - y0) & + - g * (pc(1) - x0))**2 + + if (root < 0.0D+00) then + + int_num = 0 + + else if (root == 0.0D+00) then + + int_num = 1 + + t = (f * (pc(1) - x0) + g * (pc(2) - y0)) / (f * f + g * g) + p(1, 1) = x0 + f * t + p(2, 1) = y0 + g * t + + else if (0.0D+00 < root) then + + int_num = 2 + + t = ((f * (pc(1) - x0) + g * (pc(2) - y0)) & + - sqrt(root)) / (f * f + g * g) + + p(1, 1) = x0 + f * t + p(2, 1) = y0 + g * t + + t = ((f * (pc(1) - x0) + g * (pc(2) - y0)) & + + sqrt(root)) / (f * f + g * g) + + p(1, 2) = x0 + f * t + p(2, 2) = y0 + g * t + + end if + + return +end +subroutine circle_imp_point_dist_2d(r, pc, p, dist) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_POINT_DIST_2D: distance ( implicit circle, point ) in 2D. +! +! Discussion: +! +! The distance is zero if the point is on the circle. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance of the point to the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) r2 + + r2 = sqrt(sum((p(1:2) - pc(1:2))**2)) + + dist = abs(r2 - r) + + return +end +subroutine circle_imp_point_dist_signed_2d(r, pc, p, dist) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_POINT_DIST_SIGNED_2D: signed distance ( imp circle, point ) in 2D. +! +! Discussion: +! +! The signed distance is zero if the point is on the circle. +! The signed distance is negative if the point is inside the circle. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) DIST, the signed distance of the point +! to the circle. If the point is inside the circle, the signed distance +! is negative. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) r2 + + r2 = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) + + dist = r2 - r + + return +end +subroutine circle_imp_point_near_2d(r, pc, p, pn, dist) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_POINT_NEAR_2D: nearest ( implicit circle, point ) in 2D. +! +! Discussion: +! +! This routine finds the distance from a point to an implicitly +! defined circle, and returns the point on the circle that is +! nearest to the given point. +! +! If the given point is the center of the circle, than any point +! on the circle is "the" nearest. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) PN(2), the nearest point on the circle. +! +! Output, real ( kind = 8 ) DIST, the distance of the point to the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) r + real(kind=8) r2 + + if (all(p(1:dim_num) == pc(1:dim_num))) then + dist = r + pn(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) + return + end if + + r2 = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) + + dist = abs(r2 - r) + + pn(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / r2 + + return +end +subroutine circle_imp_points_2d(r, pc, n, p) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_POINTS_2D returns points on an implicit circle in 2D. +! +! Discussion: +! +! The first point is always ( PC(1) + R, PC(2) ), and subsequent +! points proceed counter clockwise around the circle. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, integer ( kind = 4 ) N, the number of points desired. +! N must be at least 1. +! +! Output, real ( kind = 8 ) P(2,N), the coordinates of points +! on the circle. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) j + real(kind=8) p(2, n) + real(kind=8) pc(2) + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + + do j = 1, n + theta = 2.0D+00 * r8_pi * real(j - 1, kind=8) / real(n, kind=8) + p(1:dim_num, j) = pc(1:dim_num) + r * (/cos(theta), sin(theta)/) + end do + + return +end +subroutine circle_imp_points_3d(r, pc, nc, n, p) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_POINTS_3D returns points on an implicit circle in 3D. +! +! Discussion: +! +! Points P on an implicit circle in 3D satisfy the equations: +! +! ( P(1) - PC(1) )^2 +! + ( P(2) - PC(2) )^2 +! + ( P(3) - PC(3) )^2 = R^2 +! +! and +! +! ( P(1) - PC(1) ) * NC(1) +! + ( P(2) - PC(2) ) * NC(2) +! + ( P(3) - PC(3) ) * NC(3) = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 March 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(3), the center of the circle. +! +! Input, real ( kind = 8 ) NC(3), a nonzero vector that is normal to +! the plane of the circle. It is customary, but not necessary, +! that this vector have unit norm. +! +! Input, integer ( kind = 4 ) N, the number of points desired. +! N must be at least 1. +! +! Output, real ( kind = 8 ) P(3,N), the coordinates of points +! on the circle. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + integer(kind=4) j + real(kind=8) n1(dim_num) + real(kind=8) n2(dim_num) + real(kind=8) nc(dim_num) + real(kind=8) p(dim_num, n) + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta +! +! Get two unit vectors N1 and N2 which are orthogonal to each other, +! and to NC. +! + call plane_normal_basis_3d(pc, nc, n1, n2) +! +! Rotate R units away from PC in the plane of N1 and N2. +! + do j = 1, n + + theta = (2.0D+00 * r8_pi * real(j - 1, kind=8)) & + / real(n, kind=8) + + p(1:dim_num, j) = pc(1:dim_num) & + + r * (cos(theta) * n1(1:dim_num) & + + sin(theta) * n2(1:dim_num)) + + end do + + return +end +subroutine circle_imp_points_arc_2d(r, pc, theta1, theta2, n, p) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_POINTS_ARC_2D: N points on an arc of an implicit circle in 2D. +! +! Discussion: +! +! The first point is +! ( PC(1) + R * COS ( THETA1 ), PC(2) + R * SIN ( THETA1 ) ); +! The last point is +! ( PC(1) + R * COS ( THETA2 ), PC(2) + R * SIN ( THETA2 ) ); +! and the intermediate points are evenly spaced in angle between these, +! and in counter clockwise order. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angular coordinates of +! the first and last points to be drawn, in radians. +! +! Input, integer ( kind = 4 ) N, the number of points desired. +! N must be at least 1. +! +! Output, real ( kind = 8 ) P(2,N), the points on the circle. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) pc(dim_num) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r + real(kind=8) r8_modp + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + real(kind=8) theta3 +! +! THETA3 is the smallest angle, no less than THETA1, which +! coincides with THETA2. +! + theta3 = theta1 + r8_modp(theta2 - theta1, 2.0D+00 * r8_pi) + + do i = 1, n + + if (1 < n) then + theta = (real(n - i, kind=8) * theta1 & + + real(i - 1, kind=8) * theta3) & + / real(n - 1, kind=8) + else + theta = 0.5D+00 * (theta1 + theta3) + end if + + p(1:dim_num, i) = pc(1:dim_num) + r * (/cos(theta), sin(theta)/) + + end do + + return +end +subroutine circle_imp_print_2d(r, pc, title) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_PRINT_2D prints an implicit circle in 2D. +! +! Discussion: +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, character ( length = * ) TITLE, a title. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) pc(dim_num) + real(kind=8) r + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + write (*, '(a)') ' ' + write (*, '(a,g14.6)') ' Radius = ', r + write (*, '(a,2g14.6)') ' Center = ', pc(1:dim_num) + + return +end +subroutine circle_imp_print_3d(r, pc, nc, title) + +!*****************************************************************************80 +! +!! CIRCLE_IMP_PRINT_3D prints an implicit circle in 3D. +! +! Discussion: +! +! Points P on an implicit circle in 3D satisfy the equations: +! +! ( P(1) - PC(1) )^2 +! + ( P(2) - PC(2) )^2 +! + ( P(3) - PC(3) )^2 = R^2 +! +! and +! +! ( P(1) - PC(1) ) * NC(1) +! + ( P(2) - PC(2) ) * NC(2) +! + ( P(3) - PC(3) ) * NC(3) = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 March 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(3), the center of the circle. +! +! Input, real ( kind = 8 ) NC(3), the normal vector to the circle. +! +! Input, character ( length = * ) TITLE, a title. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) nc(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + write (*, '(a)') ' ' + write (*, '(a,g14.6)') ' Radius = ', r + write (*, '(a,3g14.6)') ' Center = ', pc(1:dim_num) + write (*, '(a,3g14.6)') ' Normal = ', nc(1:dim_num) + + return +end +subroutine circle_imp2exp_2d(r, pc, p1, p2, p3) + +!*****************************************************************************80 +! +!! CIRCLE_IMP2EXP_2D converts a circle from implicit to explicit form in 2D. +! +! Discussion: +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! The explicit form of a circle in 2D is: +! +! The circle passing through points P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 May 2007 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Joseph ORourke, +! Computational Geometry, +! Second Edition, +! Cambridge, 1998, +! ISBN: 0521649765, +! LC: QA448.D38. +! +! Parameters: +! +! Input, real ( kind = 8 ) R, PC(2), the radius and center of the circle. +! +! Output, real ( kind = 8 ) P1(2), P2(2), P3(2), three points on the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pc(dim_num) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r + real(kind=8) theta + + theta = 0.0D+00 + p1(1) = pc(1) + r * cos(theta) + p1(2) = pc(2) + r * sin(theta) + + theta = 2.0D+00 * r8_pi / 3.0D+00 + p2(1) = pc(1) + r * cos(theta) + p2(2) = pc(2) + r * sin(theta) + + theta = 4.0D+00 * r8_pi / 3.0D+00 + p3(1) = pc(1) + r * cos(theta) + p3(2) = pc(2) + r * sin(theta) + + return +end +subroutine circle_llr2imp_2d(p1, p2, q1, q2, r, pc) + +!*****************************************************************************80 +! +!! CIRCLE_LLR2IMP_2D converts a circle from LLR to implicit form in 2D. +! +! Discussion: +! +! The LLR form of a circle in 2D is: +! +! The circle of radius R tangent to the lines L1 and L2. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Let S be the scaled distance of a point on L1 from P1 to P2, +! and let N1 be a unit normal vector to L1. Then a point P that is +! R units from L1 satisfies: +! +! P = P1 + s * ( P2 - P1 ) + R * N1. +! +! Let t be the scaled distance of a point on L2 from Q1 to Q2, +! and let N2 be a unit normal vector to L2. Then a point Q that is +! R units from L2 satisfies: +! +! Q = Q1 + t * ( Q2 - Q1 ) + R * N2. +! +! For the center of the circle, then, we have P = Q, that is +! +! ( P2 - P1 ) * s - ( Q2 - Q1 ) * t = - P1 + Q1 - R * N1 + R * N2 ) +! +! This is a linear system for ( s and t ) from which we can compute +! the points of tangency, and the center. +! +! Note that we have four choices for the circle based on the use +! of plus or minus N1 and plus or minus N2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 November 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on line 1. +! +! Input, real ( kind = 8 ) Q1(2), Q2(2), two points on line 2. +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Output, real ( kind = 8 ) PC(2,4), the centers of the circles. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a(2, 2) + real(kind=8) b(2) + real(kind=8) det + real(kind=8) n1(dim_num) + real(kind=8) n2(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pc(dim_num, 4) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) r + real(kind=8) x(dim_num) +! +! Compute the normals N1 and N2. +! + call line_exp_normal_2d(p1, p2, n1) + + call line_exp_normal_2d(q1, q2, n2) +! +! Set the linear system. +! + a(1:2, 1) = p2(1:2) - p1(1:2) + a(1:2, 2) = -q2(1:2) + q1(1:2) +! +! Solve the 4 linear systems, using every combination of +! signs on the normal vectors. +! + b(1:2) = -p1(1:2) + q1(1:2) + r * n1(1:2) + r * n2(1:2) + + call r8mat_solve_2d(a, b, det, x) + + pc(1:2, 1) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) - r * n1(1:2) + + b(1:2) = -p1(1:2) + q1(1:2) + r * n1(1:2) - r * n2(1:2) + + call r8mat_solve_2d(a, b, det, x) + + pc(1:2, 2) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) - r * n1(1:2) + + b(1:2) = -p1(1:2) + q1(1:2) - r * n1(1:2) + r * n2(1:2) + + call r8mat_solve_2d(a, b, det, x) + + pc(1:2, 3) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) + r * n1(1:2) + + b(1:2) = -p1(1:2) + q1(1:2) - r * n1(1:2) - r * n2(1:2) + + call r8mat_solve_2d(a, b, det, x) + + pc(1:2, 4) = p1(1:2) + (p2(1:2) - p1(1:2)) * x(1) + r * n1(1:2) + + return +end +subroutine circle_lune_angle_by_height_2d(r, h, angle) + +!*****************************************************************************80 +! +!! CIRCLE_LUNE_ANGLE_BY_HEIGHT_2D computes the angle of a circular lune. +! +! Discussion: +! +! Draw the chord connecting two points on the circumference of a circle. +! The region between the chord and the circumference is a "lune". +! We wish to know the angle subtended by the lune. +! +! The distance from the center of the circle to the midpoint of the chord +! is the "height" H of the lune. It is natural to expect 0 <= H <= R. +! However, if we allow -R <= H < 0 as well, this allows us to include +! lunes which involve more than half the circle's area. +! +! If H < -R or R < H, then no lune is formed, and we return a zero angle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) H, the height of the lune. +! +! Output, real ( kind = 8 ) ANGLE, the angle of the lune. +! + implicit none + + real(kind=8) angle + real(kind=8) h + real(kind=8) r + + if (-r <= h .and. h <= r) then + angle = 2.0D+00 * acos(h / r); + else + angle = 0.0D+00 + end if + + return +end +subroutine circle_lune_area_by_angle_2d(r, pc, theta1, theta2, area) + +!*****************************************************************************80 +! +!! CIRCLE_LUNE_AREA_BY_ANGLE_2D returns the area of a circular lune in 2D. +! +! Discussion: +! +! A lune is formed by drawing a circular arc, and joining its endpoints. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, +! in radians. Normally, THETA1 < THETA2. +! +! Output, real ( kind = 8 ) AREA, the area of the lune. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) area_sector + real(kind=8) area_triangle + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) theta1 + real(kind=8) theta2 + + call circle_sector_area_2d(r, pc, theta1, theta2, area_sector) + call circle_triangle_area_2d(r, pc, theta1, theta2, area_triangle) + + area = area_sector - area_triangle + + return +end +subroutine circle_lune_area_by_height_2d(r, h) + +!*****************************************************************************80 +! +!! CIRCLE_LUNE_AREA_BY_ANGLE_2D returns the area of a circular lune in 2D. +! +! Discussion: +! +! Draw the chord connecting two points on the circumference of a circle. +! The region between the chord and the circumference is a "lune". +! We wish to know the area of this region. +! +! The distance from the center of the circle to the midpoint of the chord +! is the "height" H of the lune. It is natural to expect 0 <= H <= R. +! However, if we allow -R <= H < 0 as well, this allows us to include +! lunes which involve more than half the circle's area. +! +! If H < -R or R < H, then no lune is formed and we have zero area. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) H, the height of the lune. +! +! Output, real ( kind = 8 ) AREA, the area of the lune. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) h + real(kind=8) r + + if (-r <= h .and. h <= r) then + area = r**2 * acos(h / r) - h * sqrt(r**2 - h**2) + else + area = 0.0D+00 + end if + + return +end +subroutine circle_lune_centroid_2d(r, pc, theta1, theta2, centroid) + +!*****************************************************************************80 +! +!! CIRCLE_LUNE_CENTROID_2D returns the centroid of a circular lune in 2D. +! +! Discussion: +! +! A lune is formed by drawing a circular arc, and joining its endpoints. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, +! in radians. Normally, THETA1 < THETA2. +! +! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid +! of the lune. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) centroid(dim_num) + real(kind=8) d + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + + theta = theta2 - theta1 + + if (theta == 0.0D+00) then + d = r + else + d = 4.0D+00 * r * (sin(0.5D+00 * theta))**3 / & + (3.0D+00 * (theta - sin(theta))) + end if + + centroid(1:2) = (/pc(1) + d * cos(theta), & + pc(2) + d * sin(theta)/) + + return +end +subroutine circle_lune_height_by_angle_2d(r, angle, height) + +!*****************************************************************************80 +! +!! CIRCLE_LUNE_HEIGHT_BY_ANGLE_2D computes the height of a circular lune. +! +! Discussion: +! +! Draw the chord connecting two points on the circumference of a circle. +! The region between the chord and the circumference is a "lune". +! The lune subtends a given angle between 0 and 2 pi. +! +! The distance from the center of the circle to the midpoint of the chord +! is the "height" H of the lune and we wish to determine this value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) ANGLE, the angle subtended by the lune. +! +! Output, real ( kind = 8 ) HEIGHT, the height of the lune +! + implicit none + + real(kind=8) angle + real(kind=8) height + real(kind=8) r + + height = r * cos(angle / 2.0D+00) + + return +end +subroutine circle_pppr2imp_3d(p1, p2, p3, r, pc, normal) + +!*****************************************************************************80 +! +!! CIRCLE_PPPR2IMP_3D converts a circle from PPPR to implicit form in 3D. +! +! Discussion: +! +! The PPPR form of a circle in 3D is: +! +! The circle of radius R passing through points P1 and P2, +! and lying in the plane of P1, P2 and P3. +! +! Points P on an implicit circle in 2D satisfy the equations: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 + ( P(3) - PC(3) )^2 = R^2 +! and +! ( P - PC ) dot NORMAL = 0. +! +! There may be zero, one, or two circles that satisfy the +! requirements of the PPPR form. +! +! If there is no such circle, then PC(1:2,1) and PC(1:2,2) +! are set to the midpoint of (P1,P2). +! +! If there is one circle, PC(1:2,1) and PC(1:2,2) will be equal. +! +! If there are two circles, then PC(1:2,1) is the first center, +! and PC(1:2,2) is the second. +! +! This calculation is equivalent to finding the intersections of +! spheres of radius R at points P1 and P2, which lie in the plane +! defined by P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 November 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), two points on the circle. +! +! Input, real ( kind = 8 ) P3(3), a third point. +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Output, real ( kind = 8 ) PC(3,2), the centers of the two circles. +! +! Output, real ( kind = 8 ) NORMAL(3), the normal to the circles. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dist + real(kind=8) dot + real(kind=8) h + integer(kind=4) j + real(kind=8) length + real(kind=8) normal(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pc(dim_num, 2) + real(kind=8) r + real(kind=8) v(dim_num) +! +! Compute the distance from P1 to P2. +! + dist = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) +! +! If R is smaller than DIST, we don't have a circle. +! + if (2.0D+00 * r < dist) then + do j = 1, 2 + pc(1:dim_num, j) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) + end do + return + end if +! +! H is the distance from the midpoint of (P1,P2) to the center. +! + h = sqrt((r + 0.5D+00 * dist) * (r - 0.5D+00 * dist)) +! +! Define a unit direction V that is normal to P2-P1, and lying +! in the plane (P1,P2,P3). +! +! To do this, subtract from P3-P1 the component in the direction P2-P1. +! + v(1:dim_num) = p3(1:dim_num) - p1(1:dim_num) + dot = dot_product(v(1:dim_num), p2(1:dim_num) - p1(1:dim_num)) + dot = dot / dist + + v(1:dim_num) = v(1:dim_num) - dot * (p2(1:dim_num) - p1(1:dim_num)) / dist + + length = sqrt(sum(v(1:dim_num)**2)) + + v(1:dim_num) = v(1:dim_num) / length +! +! We can go with or against the given normal direction. +! + pc(1:dim_num, 1) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & + + h * v(1:dim_num) + + pc(1:dim_num, 2) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & + - h * v(1:dim_num) + + call plane_exp_normal_3d(p1, p2, p3, normal) + + return +end +subroutine circle_ppr2imp_2d(p1, p2, r, pc) + +!*****************************************************************************80 +! +!! CIRCLE_PPR2IMP_2D converts a circle from PPR to implicit form in 2D. +! +! Discussion: +! +! The PPR form of a circle in 2D is: +! +! The circle of radius R passing through points P1 and P2. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! There may be zero, one, or two circles that satisfy the +! requirements of the PPR form. +! +! If there is no such circle, then PC(1:2,1) and PC(1:2,2) +! are set to the midpoint of (P1,P2). +! +! If there is one circle, PC(1:2,1) and PC(1:2,2) will be equal. +! +! If there are two circles, then PC(1:2,1) is the first center, +! and PC(1:2,2) is the second. +! +! This calculation is equivalent to finding the intersections of +! circles of radius R at points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 November 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the circle. +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Output, real ( kind = 8 ) PC(2,2), the centers of the two circles. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) h + integer(kind=4) j + real(kind=8) normal(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pc(dim_num, 2) + real(kind=8) r +! +! Compute the distance from P1 to P2. +! + dist = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) +! +! If R is smaller than DIST, we don't have a circle. +! + if (2.0D+00 * r < dist) then + do j = 1, 2 + pc(1:dim_num, j) = 0.5D+00 * (p1(1:dim_num) + p2(1:dim_num)) + end do + return + end if +! +! H is the distance from the midpoint of (P1,P2) to the center. +! + h = sqrt((r + 0.5D+00 * dist) * (r - 0.5D+00 * dist)) +! +! Determine the unit normal direction. +! + normal(1) = (p2(2) - p1(2)) / dist + normal(2) = -(p2(1) - p1(1)) / dist +! +! We can go with or against the given normal direction. +! + pc(1:dim_num, 1) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & + + h * normal(1:dim_num) + + pc(1:dim_num, 2) = 0.5D+00 * (p2(1:dim_num) + p1(1:dim_num)) & + - h * normal(1:dim_num) + + return +end +subroutine circle_sector_area_2d(r, pc, theta1, theta2, area) + +!*****************************************************************************80 +! +!! CIRCLE_SECTOR_AREA_2D computes the area of a circular sector in 2D. +! +! Discussion: +! +! A circular sector is formed by a circular arc, and the two straight line +! segments that join its ends to the center of the circle. +! +! A circular sector is defined by the two conditions +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! and +! +! Theta1 <= Theta <= Theta2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the two angles defining the +! sector, in radians. Normally, THETA1 < THETA2. +! +! Output, real ( kind = 8 ) AREA, the area of the circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) theta1 + real(kind=8) theta2 + + area = 0.5D+00 * r * r * (theta2 - theta1) + + return +end +subroutine circle_sector_centroid_2d(r, pc, theta1, theta2, centroid) + +!*****************************************************************************80 +! +!! CIRCLE_SECTOR_CENTROID_2D returns the centroid of a circular sector in 2D. +! +! Discussion: +! +! A circular sector is formed by a circular arc, and the two straight line +! segments that join its ends to the center of the circle. +! +! A circular sector is defined by +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! and +! +! Theta1 <= Theta <= Theta2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, +! in radians. Normally, THETA1 < THETA2. +! +! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid +! of the sector. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) centroid(dim_num) + real(kind=8) d + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + + theta = theta2 - theta1 + + if (theta == 0.0D+00) then + d = 2.0D+00 * r / 3.0D+00 + else + d = 4.0D+00 * r * sin(0.5D+00 * theta) / & + (3.0D+00 * theta) + end if + + centroid(1:2) = (/pc(1) + d * cos(theta), & + pc(2) + d * sin(theta)/) + + return +end +subroutine circle_sector_contains_point_2d(r, pc, theta1, theta2, & + p, inside) + +!*****************************************************************************80 +! +!! CIRCLE_SECTOR_CONTAINS_POINT_2D : is a point inside a circular sector? +! +! Discussion: +! +! A circular sector is formed by a circular arc, and the two straight line +! segments that join its ends to the center of the circle. +! +! A circular sector is defined by +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! and +! +! Theta1 <= Theta <= Theta2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, +! in radians. Normally, THETA1 < THETA2. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside or +! on the circular sector. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) r8_atan + real(kind=8) r8_modp + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + + inside = .false. +! +! Is the point inside the (full) circle? +! + if ((p(1) - pc(1)) * (p(1) - pc(1)) & + + (p(2) - pc(2)) * (p(2) - pc(2)) <= r * r) then +! +! Is the point's angle within the arc's range? +! Try to force the angles to lie between 0 and 2 * PI. +! + theta = r8_atan(p(2) - pc(2), p(1) - pc(1)) + + if (r8_modp(theta - theta1, 2.0D+00 * r8_pi) <= & + r8_modp(theta2 - theta1, 2.0D+00 * r8_pi)) then + + inside = .true. + + end if + + end if + + return +end +subroutine circle_sector_print_2d(r, pc, theta1, theta2) + +!*****************************************************************************80 +! +!! CIRCLE_SECTOR_PRINT_2D prints a circular sector in 2D. +! +! Discussion: +! +! A circular sector is formed by a circular arc, and the two straight line +! segments that join its ends to the center of the circle. +! +! A circular sector is defined by +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! and +! +! Theta1 <= Theta <= Theta2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, +! in radians. Normally, THETA1 < THETA2. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) theta1 + real(kind=8) theta2 + + write (*, '(a)') ' ' + write (*, '(a)') ' Circular sector definition:' + write (*, '(a)') ' ' + write (*, '(a,g14.6)') ' Radius = ', r + write (*, '(a,2g14.6)') ' Center = ', pc(1:2) + write (*, '(a,2g14.6)') ' Theta = ', theta1, theta2 + + return +end +subroutine circle_triangle_area_2d(r, pc, theta1, theta2, area) + +!*****************************************************************************80 +! +!! CIRCLE_TRIANGLE_AREA_2D returns the area of a circle triangle in 2D. +! +! Discussion: +! +! A circle triangle is formed by drawing a circular arc, and considering +! the triangle formed by the endpoints of the arc plus the center of +! the circle. +! +! Note that for angles greater than PI, the triangle will actually +! have NEGATIVE area. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle. +! +! Input, real ( kind = 8 ) PC(2), the center of the circle. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angles defining the arc, +! in radians. Normally, THETA1 < THETA2. +! +! Output, real ( kind = 8 ) AREA, the (signed) area of the triangle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) theta1 + real(kind=8) theta2 + + area = 0.5D+00 * r * r * sin(theta2 - theta1) + + return +end +subroutine circle_triple_angles_2d(r1, r2, r3, angle1, angle2, angle3) + +!*****************************************************************************80 +! +!! CIRCLE_TRIPLE_ANGLE_2D returns an angle formed by three circles in 2D. +! +! Discussion: +! +! A circle triple is a set of three tangent circles. We assume +! that no circle is contained in another. +! +! We consider the triangle formed by joining the centers of the circles. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 June 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Kenneth Stephenson, +! Circle Packing, The Theory of Discrete Analytic Functions, +! Cambridge, 2005. +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, R3, the radii of the circles. +! +! Input, real ( kind = 8 ) ANGLE1, ANGLE2, ANGLE3, the angles +! in the triangle. +! + implicit none + + real(kind=8) angle1 + real(kind=8) angle2 + real(kind=8) angle3 + real(kind=8) r1 + real(kind=8) r2 + real(kind=8) r3 + real(kind=8) r8_acos + + angle1 = r8_acos( & + (r1 + r2)**2 + (r1 + r3)**2 - (r2 + r3)**2) / & + (2.0D+00 * (r1 + r2) * (r1 + r3)) + + angle2 = r8_acos( & + (r2 + r3)**2 + (r2 + r1)**2 - (r3 + r1)**2) / & + (2.0D+00 * (r2 + r3) * (r2 + r1)) + + angle3 = r8_acos( & + (r3 + r1)**2 + (r3 + r2)**2 - (r1 + r2)**2) / & + (2.0D+00 * (r3 + r1) * (r3 + r2)) + + return +end +subroutine circles_intersect_points_2d(r1, pc1, r2, pc2, int_num, p) + +!*****************************************************************************80 +! +!! CIRCLES_INTERSECT_POINTS_2D: intersection points of two circles in 2D. +! +! Discussion: +! +! Two circles can intersect in 0, 1, 2 or infinitely many points. +! +! The 0 and 2 intersection cases are numerically robust; the 1 and +! infinite intersection cases are numerically fragile. The routine +! uses a tolerance to try to detect the 1 and infinite cases. +! +! Points P on an implicit circle in 2D satisfy the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, the radius of the first circle. +! +! Input, real ( kind = 8 ) PC1(2), the center of the first circle. +! +! Input, real ( kind = 8 ) R2, the radius of the second circle. +! +! Input, real ( kind = 8 ) PC2(2), the center of the second circle. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersecting points +! found. INT_NUM will be 0, 1, 2 or 3. 3 indicates that there are an +! infinite number of intersection points. +! +! Output, real ( kind = 8 ) P(2,2), if INT_NUM is 1 or 2, +! the coordinates of the intersecting points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) distsq + integer(kind=4) int_num + real(kind=8) p(dim_num, 2) + real(kind=8) pc1(dim_num) + real(kind=8) pc2(dim_num) + real(kind=8) r1 + real(kind=8) r2 + real(kind=8) root + real(kind=8) sc1 + real(kind=8) sc2 + real(kind=8) t1 + real(kind=8) t2 + real(kind=8) tol + + tol = epsilon(tol) + + p(1:dim_num, 1:2) = 0.0D+00 +! +! Take care of the case in which the circles have the same center. +! + t1 = (abs(pc1(1) - pc2(1)) & + + abs(pc1(2) - pc2(2))) / 2.0D+00 + + t2 = (abs(pc1(1)) + abs(pc2(1)) & + + abs(pc1(2)) + abs(pc2(2)) + 1.0D+00) / 5.0D+00 + + if (t1 <= tol * t2) then + + t1 = abs(r1 - r2) + t2 = (abs(r1) + abs(r2) + 1.0D+00) / 3.0D+00 + + if (t1 <= tol * t2) then + int_num = 3 + else + int_num = 0 + end if + + return + + end if + + distsq = (pc1(1) - pc2(1))**2 + (pc1(2) - pc2(2))**2 + + root = 2.0D+00 * (r1**2 + r2**2) * distsq - distsq**2 & + - (r1 - r2)**2 * (r1 + r2)**2 + + if (root < -tol) then + int_num = 0 + return + end if + + sc1 = (distsq - (r2**2 - r1**2)) / distsq + + if (root < tol) then + int_num = 1 + p(1:dim_num, 1) = pc1(1:dim_num) & + + 0.5D+00 * sc1 * (pc2(1:dim_num) - pc1(1:dim_num)) + return + end if + + sc2 = sqrt(root) / distsq + + int_num = 2 + + p(1, 1) = pc1(1) + 0.5D+00 * sc1 * (pc2(1) - pc1(1)) & + - 0.5D+00 * sc2 * (pc2(2) - pc1(2)) + p(2, 1) = pc1(2) + 0.5D+00 * sc1 * (pc2(2) - pc1(2)) & + + 0.5D+00 * sc2 * (pc2(1) - pc1(1)) + + p(1, 2) = pc1(1) + 0.5D+00 * sc1 * (pc2(1) - pc1(1)) & + + 0.5D+00 * sc2 * (pc2(2) - pc1(2)) + p(2, 2) = pc1(2) + 0.5D+00 * sc1 * (pc2(2) - pc1(2)) & + - 0.5D+00 * sc2 * (pc2(1) - pc1(1)) + + return +end +subroutine combin2(n, k, icnk) + +!*****************************************************************************80 +! +!! COMBIN2 computes the binomial coefficient C(N,K). +! +! Discussion: +! +! The value is calculated in such a way as to avoid overflow and +! roundoff. The calculation is done in integer arithmetic. +! +! The formula used is: +! +! C(N,K) = N! / ( K! * (N-K)! ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 January 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! ML Wolfson, HV Wright, +! Algorithm 160: +! Combinatorial of M Things Taken N at a Time, +! Communications of the ACM, +! April, 1963. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, K, are the values of N and K. +! +! Output, integer ( kind = 4 ) ICNK, the number of combinations of N +! things taken K at a time. +! + implicit none + + integer(kind=4) i + integer(kind=4) icnk + integer(kind=4) k + integer(kind=4) mn + integer(kind=4) mx + integer(kind=4) n + + mn = min(k, n - k) + + if (mn < 0) then + + icnk = 0 + + else if (mn == 0) then + + icnk = 1 + + else + + mx = max(k, n - k) + icnk = mx + 1 + + do i = 2, mn + icnk = (icnk * (mx + i)) / i + end do + + end if + + return +end +subroutine cone_area_3d(h, r, area) + +!*****************************************************************************80 +! +!! CONE_AREA_3D computes the surface area of a right circular cone in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) H, R, the height of the cone, and the radius +! of the circle that forms the base of the cone. +! +! Output, real ( kind = 8 ) AREA, the surface area of the cone. +! + implicit none + + real(kind=8) area + real(kind=8) h + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + area = r8_pi * r * sqrt(h * h + r * r) + + return +end +subroutine cone_centroid_3d(r, pc, pt, centroid) + +!*****************************************************************************80 +! +!! CONE_CENTROID_3D returns the centroid of a cone in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the circle at the base of +! the cone. +! +! Input, real ( kind = 8 ) PC(3), the center of the circle. +! +! Input, real ( kind = 8 ) PT(3), the coordinates of the tip of the cone. +! +! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid +! of the cone. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) centroid(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pt(dim_num) + real(kind=8) r + + centroid(1:dim_num) = 0.75D+00 * pc(1:dim_num) + 0.25D+00 * pt(1:dim_num) + + return +end +subroutine cone_volume_3d(h, r, volume) + +!*****************************************************************************80 +! +!! CONE_VOLUME_3D computes the volume of a right circular cone in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 December 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) H, R, the height of the cone, and the radius +! of the circle that forms the base of the cone. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the cone. +! + implicit none + + real(kind=8) h + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) volume + + volume = r8_pi * r * r * h / 3.0D+00 + + return +end +subroutine conv3d(axis, theta, n, cor3, cor2) + +!*****************************************************************************80 +! +!! CONV3D converts 3D data to a 2D projection. +! +! Discussion: +! +! A "presentation angle" THETA is used to project the 3D point +! (X3D, Y3D, Z3D) to the 2D projection (XVAL,YVAL). +! +! If AXIS = 'X': +! +! X2D = Y3D - sin ( THETA ) * X3D +! Y2D = Z3D - sin ( THETA ) * X3D +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, character AXIS, the coordinate axis to be projected. +! AXIS should be 'X', 'Y', or 'Z'. +! +! Input, real ( kind = 8 ) THETA, the presentation angle in degrees. +! +! Input, integer ( kind = 4 ) N, the number of points. +! +! Input, real ( kind = 8 ) COR3(3,N), the 3D points. +! +! Output, real ( kind = 8 ) COR2(2,N), the 2D projections. +! + implicit none + + integer(kind=4) n + + character axis + real(kind=8) cor2(2, n) + real(kind=8) cor3(3, n) + real(kind=8) degrees_to_radians + real(kind=8) stheta + real(kind=8) theta + + stheta = sin(degrees_to_radians(theta)) + + if (axis == 'X' .or. axis == 'x') then + + cor2(1, 1:n) = cor3(2, 1:n) - stheta * cor3(1, 1:n) + cor2(2, 1:n) = cor3(3, 1:n) - stheta * cor3(1, 1:n) + + else if (axis == 'Y' .or. axis == 'y') then + + cor2(1, 1:n) = cor3(1, 1:n) - stheta * cor3(2, 1:n) + cor2(2, 1:n) = cor3(3, 1:n) - stheta * cor3(2, 1:n) + + else if (axis == 'Z' .or. axis == 'z') then + + cor2(1, 1:n) = cor3(1, 1:n) - stheta * cor3(3, 1:n) + cor2(2, 1:n) = cor3(2, 1:n) - stheta * cor3(3, 1:n) + + else + + write (*, '(a)') ' ' + write (*, '(a)') 'CONV3D - Fatal error!' + write (*, '(a)') ' Illegal coordinate index = "'//axis//'".' + stop 1 + + end if + + return +end +function cot_rad(angle_rad) + +!*****************************************************************************80 +! +!! COT_RAD returns the cotangent of an angle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 July 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) ANGLE_RAD, the angle, in radians. +! +! Output, real ( kind = 8 ) COT_RAD, the cotangent of the angle. +! + implicit none + + real(kind=8) angle_rad + real(kind=8) cot_rad + + cot_rad = cos(angle_rad) / sin(angle_rad) + + return +end +subroutine cube_shape_3d(point_num, face_num, face_order_max, & + point_coord, face_order, face_point) + +!*****************************************************************************80 +! +!! CUBE_SHAPE_3D describes a cube in 3D. +! +! Discussion: +! +! The vertices lie on the unit sphere. +! +! The dual of the cube is the octahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 October 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices +! in a face. +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), +! the vertices. +! +! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices +! per face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. The +! points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) point_num + + real(kind=8) a + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) point_coord(dim_num, point_num) +! +! Set point coordinates. +! + a = sqrt(1.0D+00 / 3.0D+00) + + point_coord(1:dim_num, 1:point_num) = reshape((/ & + -a, -a, -a, & + a, -a, -a, & + a, a, -a, & + -a, a, -a, & + -a, -a, a, & + a, -a, a, & + a, a, a, & + -a, a, a/), (/dim_num, point_num/)) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 4, 4, 4, 4, 4, 4/) +! +! Set the faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 1, 4, 3, 2, & + 1, 2, 6, 5, & + 2, 3, 7, 6, & + 3, 4, 8, 7, & + 1, 5, 8, 4, & + 5, 6, 7, 8/), (/face_order_max, face_num/)) + + return +end +subroutine cube_size_3d(point_num, edge_num, face_num, face_order_max) + +!*****************************************************************************80 +! +!! CUBE_SIZE_3D gives "sizes" for a cube in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 8 + edge_num = 12 + face_num = 6 + face_order_max = 4 + + return +end +function cube01_volume() + +!*****************************************************************************80 +! +!! CUBE01_VOLUME returns the volume of the unit cube in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) CUBE01_VOLUME, the volume. +! + implicit none + + real(kind=8) cube01_volume + + cube01_volume = 1.0D+00 + + return +end +subroutine cylinder_point_dist_3d(p1, p2, r, p, distance) + +!*****************************************************************************80 +! +!! CYLINDER_POINT_DIST_3D: distance from a cylinder to a point in 3D. +! +! Discussion: +! +! We are computing the distance to the SURFACE of the cylinder. +! +! The surface of a (right) (finite) cylinder in 3D is defined by an axis, +! which is the line segment from point P1 to P2, and a radius R. The points +! on the surface of the cylinder are: +! * points at a distance R from the line through P1 and P2, and whose nearest +! point on the line through P1 and P2 is strictly between P1 and P2, +! PLUS +! * points at a distance less than or equal to R from the line through P1 +! and P2, whose nearest point on the line through P1 and P2 is either +! P1 or P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points +! on the axis line of the cylinder. +! +! Input, real ( kind = 8 ) R, the radius of the cylinder. +! +! Input, real ( kind = 8 ) P(3), the point. +! +! Output, real ( kind = 8 ) DISTANCE, the distance from the point +! to the cylinder. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) axis(dim_num) + real(kind=8) axis_length + real(kind=8) distance + real(kind=8) r8vec_norm + real(kind=8) off_axis_component + real(kind=8) p(3) + real(kind=8) p_dot_axis + real(kind=8) p_length + real(kind=8) p1(3) + real(kind=8) p2(3) + real(kind=8) r + + axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + axis_length = r8vec_norm(dim_num, axis) + + if (axis_length == 0.0D+00) then + distance = -huge(distance) + return + end if + + axis(1:dim_num) = axis(1:dim_num) / axis_length + + p_dot_axis = dot_product(p(1:dim_num) - p1(1:dim_num), axis) +! +! Case 1: Below bottom cap. +! + if (p_dot_axis <= 0.0D+00) then + + call disk_point_dist_3d(p1, r, axis, p, distance) +! +! Case 2: between cylinder planes. +! + else if (p_dot_axis <= axis_length) then + + p_length = r8vec_norm(dim_num, p(1:dim_num) - p1(1:dim_num)) + off_axis_component = sqrt(p_length**2 - p_dot_axis**2) + + distance = abs(off_axis_component - r) + + if (off_axis_component < r) then + distance = min(distance, axis_length - p_dot_axis) + distance = min(distance, p_dot_axis) + end if +! +! Case 3: Above the top cap. +! + else if (axis_length < p_dot_axis) then + + call disk_point_dist_3d(p2, r, axis, p, distance) + + end if + + return +end +subroutine cylinder_point_dist_signed_3d(p1, p2, r, p, distance) + +!*****************************************************************************80 +! +!! CYLINDER_POINT_DIST_SIGNED_3D: signed distance from cylinder to point in 3D. +! +! Discussion: +! +! We are computing the signed distance to the SURFACE of the cylinder. +! +! The surface of a (right) (finite) cylinder in 3D is defined by an axis, +! which is the line segment from point P1 to P2, and a radius R. The points +! on the surface of the cylinder are: +! * points at a distance R from the line through P1 and P2, and whose nearest +! point on the line through P1 and P2 is strictly between P1 and P2, +! PLUS +! * points at a distance less than or equal to R from the line through P1 +! and P2, whose nearest point on the line through P1 and P2 is either +! P1 or P2. +! +! Points inside the surface have a negative distance. +! Points on the surface have a zero distance. +! Points outside the surface have a positive distance. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points +! on the axis line of the cylinder. +! +! Input, real ( kind = 8 ) R, the radius of the cylinder. +! +! Input, real ( kind = 8 ) P(3), the point. +! +! Output, real ( kind = 8 ) DISTANCE, the signed distance from the point +! to the cylinder. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) axis(dim_num) + real(kind=8) axis_length + real(kind=8) distance + real(kind=8) r8vec_norm + real(kind=8) off_axis_component + real(kind=8) p(dim_num) + real(kind=8) p_dot_axis + real(kind=8) p_length + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) r + + axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + axis_length = r8vec_norm(dim_num, axis) + + if (axis_length == 0.0D+00) then + distance = -huge(distance) + return + end if + + axis(1:dim_num) = axis(1:dim_num) / axis_length + + p_dot_axis = dot_product(p(1:dim_num) - p1(1:dim_num), axis) +! +! Case 1: Below bottom cap. +! + if (p_dot_axis <= 0.0D+00) then + + call disk_point_dist_3d(p1, r, axis, p, distance) +! +! Case 2: between cylinder planes. +! + else if (p_dot_axis <= axis_length) then + + p_length = r8vec_norm(dim_num, p(1:dim_num) - p1(1:dim_num)) + off_axis_component = sqrt(p_length**2 - p_dot_axis**2) + + distance = off_axis_component - r + + if (distance < 0.0D+00) then + distance = max(distance, p_dot_axis - axis_length) + distance = max(distance, -p_dot_axis) + end if +! +! Case 3: Above the top cap. +! + else if (axis_length < p_dot_axis) then + + call disk_point_dist_3d(p2, r, axis, p, distance) + + end if + + return +end +subroutine cylinder_point_inside_3d(p1, p2, r, p, inside) + +!*****************************************************************************80 +! +!! CYLINDER_POINT_INSIDE_3D determines if a cylinder contains a point in 3D. +! +! Discussion: +! +! The surface and interior of a (right) (finite) cylinder in 3D is defined +! by an axis, which is the line segment from point P1 to P2, and a +! radius R. The points contained in the volume include: +! * points at a distance less than or equal to R from the line through P1 +! and P2, whose nearest point on the line through P1 and P2 is, in fact, +! P1, P2, or any point between them. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points +! on the axis line of the cylinder. +! +! Input, real ( kind = 8 ) R, the radius of the cylinder. +! +! Input, real ( kind = 8 ) P(3), the point. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is +! inside the cylinder. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) axis(dim_num) + real(kind=8) axis_length + logical(kind=4) inside + real(kind=8) off_axis_component + real(kind=8) p(dim_num) + real(kind=8) p_dot_axis + real(kind=8) p_length + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) r + real(kind=8) r8vec_norm + + axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + axis_length = r8vec_norm(dim_num, axis) + + if (axis_length == 0.0D+00) then + inside = .false. + return + end if + + axis(1:dim_num) = axis(1:dim_num) / axis_length + + p_dot_axis = dot_product(p(1:dim_num) - p1(1:dim_num), axis) +! +! If the point lies below or above the "caps" of the cylinder, we're done. +! + if (p_dot_axis < 0.0D+00 .or. axis_length < p_dot_axis) then + + inside = .false. +! +! Otherwise, determine the distance from P to the axis. +! + else + + p_length = r8vec_norm(dim_num, p(1:dim_num) - p1(1:dim_num)) + + off_axis_component = sqrt(p_length**2 - p_dot_axis**2) + + if (off_axis_component <= r) then + inside = .true. + else + inside = .false. + end if + + end if + + return +end +subroutine cylinder_point_near_3d(p1, p2, r, p, pn) + +!*****************************************************************************80 +! +!! CYLINDER_POINT_NEAR_3D: nearest point on a cylinder to a point in 3D. +! +! Discussion: +! +! We are computing the nearest point on the SURFACE of the cylinder. +! +! The surface of a (right) (finite) cylinder in 3D is defined by an axis, +! which is the line segment from point P1 to P2, and a radius R. The points +! on the surface of the cylinder are: +! * points at a distance R from the line through P1 and P2, and whose nearest +! point on the line through P1 and P2 is strictly between P1 and P2, +! PLUS +! * points at a distance less than or equal to R from the line through P1 +! and P2, whose nearest point on the line through P1 and P2 is either +! P1 or P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points +! on the axis line of the cylinder. +! +! Input, real ( kind = 8 ) R, the radius of the cylinder. +! +! Input, real ( kind = 8 ) P(3), the point. +! +! Output, real ( kind = 8 ) PN(3), the nearest point on the cylinder. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) axial_component + real(kind=8) axis(dim_num) + real(kind=8) axis_length + real(kind=8) distance + real(kind=8) r8vec_norm + real(kind=8) off_axis(dim_num) + real(kind=8) off_axis_component + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) r + + axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + axis_length = r8vec_norm(dim_num, axis) + axis(1:dim_num) = axis(1:dim_num) / axis_length + + axial_component = dot_product(p(1:dim_num) - p1(1:dim_num), axis) + + off_axis(1:dim_num) = p(1:dim_num) - p1(1:dim_num) & + - axial_component * axis(1:dim_num) + + off_axis_component = r8vec_norm(dim_num, off_axis) +! +! Case 1: Below bottom cap. +! + if (axial_component <= 0.0D+00) then + + if (off_axis_component <= r) then + pn(1:dim_num) = p1(1:dim_num) + off_axis(1:dim_num) + else + pn(1:dim_num) = p1(1:dim_num) & + + (r / off_axis_component) * off_axis(1:dim_num) + end if +! +! Case 2: between cylinder planes. +! + else if (axial_component <= axis_length) then + + if (off_axis_component == 0.0D+00) then + + call r8vec_any_normal(dim_num, axis, off_axis) + + pn(1:dim_num) = p(1:dim_num) + r * off_axis(1:dim_num) + + else + + distance = abs(off_axis_component - r) + + pn(1:dim_num) = p1(1:dim_num) + axial_component * axis(1:dim_num) & + + (r / off_axis_component) * off_axis(1:dim_num) + + if (off_axis_component < r) then + + if (axis_length - axial_component < distance) then + distance = axis_length - axial_component + pn(1:dim_num) = p2(1:dim_num) + off_axis(1:dim_num) + end if + + if (axial_component < distance) then + distance = axial_component + pn(1:dim_num) = p1(1:dim_num) + off_axis(1:dim_num) + end if + + end if + + end if +! +! Case 3: Above the top cap. +! + else if (axis_length < axial_component) then + + if (off_axis_component <= r) then + pn(1:dim_num) = p2(1:dim_num) + off_axis(1:dim_num) + else + pn(1:dim_num) = p2(1:dim_num) & + + (r / off_axis_component) * off_axis(1:dim_num) + end if + + end if + + return +end +subroutine cylinder_sample_3d(p1, p2, r, n, seed, p) + +!*****************************************************************************80 +! +!! CYLINDER_SAMPLE_3D samples a cylinder in 3D. +! +! Discussion: +! +! We are sampling the interior of a right finite cylinder in 3D. +! +! The interior of a (right) (finite) cylinder in 3D is defined by an axis, +! which is the line segment from point P1 to P2, and a radius R. The points +! on or inside the cylinder are: +! * points whose distance from the line through P1 and P2 is less than +! or equal to R, and whose nearest point on the line through P1 and P2 +! lies (nonstrictly) between P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points +! on the axis line of the cylinder. +! +! Input, real ( kind = 8 ) R, the radius of the cylinder. +! +! Input, integer ( kind = 4 ) N, the number of sample points to compute. +! +! Input/output, integer ( kind = 4 ) SEED, the random number seed. +! +! Input, real ( kind = 8 ) P(3,N), the sample points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) n + + real(kind=8) axis(dim_num) + real(kind=8) axis_length + real(kind=8) r8vec_norm + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radius(n) + integer(kind=4) seed + real(kind=8) theta(n) + real(kind=8) v2(dim_num) + real(kind=8) v3(dim_num) + real(kind=8) z(n) +! +! Compute the axis vector. +! + axis(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + axis_length = r8vec_norm(dim_num, axis) + axis(1:dim_num) = axis(1:dim_num) / axis_length +! +! Compute vectors V2 and V3 that form an orthogonal triple with AXIS. +! + call plane_normal_basis_3d(p1, axis, v2, v3) +! +! Assemble the randomized information. +! + call random_number(harvest=radius(1:n)) + radius(1:n) = r * sqrt(radius(1:n)) + + call random_number(harvest=theta(1:n)) + theta(1:n) = 2.0D+00 * r8_pi * theta(1:n) + + call random_number(harvest=z(1:n)) + z(1:n) = axis_length * z(1:n) + + do i = 1, dim_num + + p(i, 1:n) = p1(i) & + + z(1:n) * axis(i) & + + radius(1:n) * cos(theta(1:n)) * v2(i) & + + radius(1:n) * sin(theta(1:n)) * v3(i) + + end do + + return +end +subroutine cylinder_volume_3d(p1, p2, r, volume) + +!*****************************************************************************80 +! +!! CYLINDER_VOLUME_3D determines the volume of a cylinder in 3D. +! +! Discussion: +! +! The surface and interior of a (right) (finite) cylinder in 3D is defined +! by an axis, which is the line segment from point P1 to P2, and a radius R. +! The points contained in the volume include: +! * points at a distance less than or equal to R from the line through P1 +! and P2, whose nearest point on the line through P1 and P2 is, in fact, +! P1, P2, or any point between them. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the first and last points +! on the axis line of the cylinder. +! +! Input, real ( kind = 8 ) R, the radius of the cylinder. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the cylinder. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) h + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) volume + + h = sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) + + volume = r8_pi * r * r * h + + return +end +function degrees_to_radians(angle_deg) + +!*****************************************************************************80 +! +!! DEGREES_TO_RADIANS converts an angle from degrees to radians. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) ANGLE_DEG, an angle in degrees. +! +! Output, real ( kind = 8 ) DEGREES_TO_RADIANS, the equivalent angle +! in radians. +! + implicit none + + real(kind=8) angle_deg + real(kind=8) degrees_to_radians + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + degrees_to_radians = (angle_deg / 180.0D+00) * r8_pi + + return +end +subroutine direction_pert_3d(sigma, vbase, seed, vran) + +!*****************************************************************************80 +! +!! DIRECTION_PERT_3D randomly perturbs a direction vector in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) SIGMA, determines the strength of the +! perturbation. +! SIGMA <= 0 results in a completely random direction. +! 1 <= SIGMA results in VBASE. +! 0 < SIGMA < 1 results in a perturbation from VBASE, which is +! large when SIGMA is near 0, and small when SIGMA is near 1. +! +! Input, real ( kind = 8 ) VBASE(3), the base direction vector, which +! should have unit norm. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) VRAN(3), the perturbed vector, which will +! have unit norm. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) r8_uniform_01 + real(kind=8) dphi + real(kind=8) phi + real(kind=8) psi + real(kind=8) r + real(kind=8) r8_acos + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seed + real(kind=8) sigma + real(kind=8) theta + real(kind=8) v(dim_num) + real(kind=8) vbase(dim_num) + real(kind=8) vdot + real(kind=8) vran(dim_num) + real(kind=8) x +! +! 1 <= SIGMA, just use the base vector. +! + if (1.0D+00 <= sigma) then + + vran(1:dim_num) = vbase(1:dim_num) + + else if (sigma <= 0.0D+00) then + + vdot = r8_uniform_01(seed) + vdot = 2.0D+00 * vdot - 1.0D+00 + + phi = r8_acos(vdot) + + theta = r8_uniform_01(seed) + theta = 2.0D+00 * r8_pi * theta + + vran(1) = cos(theta) * sin(phi) + vran(2) = sin(theta) * sin(phi) + vran(3) = cos(phi) + + else + + phi = r8_acos(vbase(3)) + theta = atan2(vbase(2), vbase(1)) +! +! Pick VDOT, which must be between -1 and 1. This represents +! the dot product of the perturbed vector with the base vector. +! +! R8_UNIFORM_01 returns a uniformly random value between 0 and 1. +! The operations we perform on this quantity tend to bias it +! out towards 1, as SIGMA grows from 0 to 1. +! +! VDOT, in turn, is a value between -1 and 1, which, for large +! SIGMA, we want biased towards 1. +! + r = r8_uniform_01(seed) + x = exp((1.0D+00 - sigma) * log(r)) + dphi = r8_acos(2.0D+00 * x - 1.0D+00) +! +! Now we know enough to write down a vector that is rotated DPHI +! from the base vector. +! + v(1) = cos(theta) * sin(phi + dphi) + v(2) = sin(theta) * sin(phi + dphi) + v(3) = cos(phi + dphi) +! +! Pick a uniformly random rotation between 0 and 2 Pi around the +! axis of the base vector. +! + psi = r8_uniform_01(seed) + psi = 2.0D+00 * r8_pi * psi +! +! Carry out the rotation. +! + call rotation_axis_vector_3d(vbase, psi, v, vran) + + end if + + return +end +subroutine direction_uniform_2d(seed, vran) + +!*****************************************************************************80 +! +!! DIRECTION_UNIFORM_2D picks a random direction vector in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) VRAN(2), the random direction vector, with +! unit norm. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r8_uniform_01 + integer(kind=4) seed + real(kind=8) theta + real(kind=8) vran(dim_num) + + theta = r8_uniform_01(seed) + theta = 2.0D+00 * r8_pi * theta + + vran(1) = cos(theta) + vran(2) = sin(theta) + + return +end +subroutine direction_uniform_3d(seed, vran) + +!*****************************************************************************80 +! +!! DIRECTION_UNIFORM_3D picks a random direction vector in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 December 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) VRAN(3), the random direction vector, +! with unit norm. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) r8_uniform_01 + real(kind=8) phi + real(kind=8) r8_acos + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seed + real(kind=8) theta + real(kind=8) vdot + real(kind=8) vran(dim_num) +! +! Pick a uniformly random VDOT, which must be between -1 and 1. +! This represents the dot product of the random vector with the Z unit vector. +! +! Note: this works because the surface area of the sphere between +! Z and Z + dZ is independent of Z. So choosing Z uniformly chooses +! a patch of area uniformly. +! + vdot = r8_uniform_01(seed) + vdot = 2.0D+00 * vdot - 1.0D+00 + + phi = r8_acos(vdot) +! +! Pick a uniformly random rotation between 0 and 2 Pi around the +! axis of the Z vector. +! + theta = r8_uniform_01(seed) + theta = 2.0D+00 * r8_pi * theta + + vran(1) = cos(theta) * sin(phi) + vran(2) = sin(theta) * sin(phi) + vran(3) = cos(phi) + + return +end +subroutine direction_uniform_nd(dim_num, seed, w) + +!*****************************************************************************80 +! +!! DIRECTION_UNIFORM_ND generates a random direction vector in ND. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 13 February 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) W(DIM_NUM), a random direction vector, +! with unit norm. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) norm + integer(kind=4) seed + real(kind=8) w(dim_num) +! +! Get N values from a standard normal distribution. +! + call r8vec_normal_01(dim_num, seed, w) +! +! Compute the length of the vector. +! + norm = sqrt(sum(w(1:dim_num)**2)) +! +! Normalize the vector. +! + w(1:dim_num) = w(1:dim_num) / norm + + return +end +subroutine disk_point_dist_3d(pc, r, axis, p, dist) + +!*****************************************************************************80 +! +!! DISK_POINT_DIST_3D determines the distance from a disk to a point in 3D. +! +! Discussion: +! +! A disk in 3D satisfies the equations: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 + ( P(3) - PC(3) <= R^2 +! +! and +! +! P(1) * AXIS(1) + P(2) * AXIS(2) + P(3) * AXIS(3) = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(3), the center of the disk. +! +! Input, real ( kind = 8 ) R, the radius of the disk. +! +! Input, real ( kind = 8 ) AXIS(3), the axis vector. +! +! Input, real ( kind = 8 ) P(3), the point to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance of the point to the disk. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) axial_component + real(kind=8) axis(dim_num) + real(kind=8) axis_length + real(kind=8) dist + real(kind=8) r8vec_norm + real(kind=8) off_axis_component + real(kind=8) off_axis(dim_num) + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r +! +! Special case: the point is the center. +! + if (all(p(1:dim_num) == pc(1:dim_num))) then + dist = 0.0D+00 + return + end if + + axis_length = r8vec_norm(dim_num, axis(1:dim_num)) + + if (axis_length == 0.0D+00) then + dist = -huge(dist) + return + end if + + axial_component = dot_product(p(1:dim_num) - pc(1:dim_num), & + axis(1:dim_num)) / axis_length +! +! Special case: the point satisfies the disk equation exactly. +! + if (sum(p(1:dim_num) - pc(1:dim_num))**2 <= r * r .and. & + axial_component == 0.0D+00) then + dist = 0.0D+00 + return + end if +! +! Decompose P-PC into axis component and off-axis component. +! + off_axis(1:dim_num) = p(1:dim_num) - pc(1:dim_num) & + - axial_component * axis(1:dim_num) / axis_length + + off_axis_component = r8vec_norm(dim_num, off_axis) +! +! If the off-axis component has norm less than R, the nearest point is +! the projection to the disk along the axial direction, and the distance +! is just the dot product of P-PC with unit AXIS. +! + if (off_axis_component <= r) then + dist = abs(axial_component) + return + end if +! +! Otherwise, the nearest point is along the perimeter of the disk. +! + dist = sqrt(axial_component**2 + (off_axis_component - r)**2) + + return +end +subroutine dms_to_radians(degrees, minutes, seconds, radians) + +!*****************************************************************************80 +! +!! DMS_TO_RADIANS converts an angle from degrees/minutes/seconds to radians. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 June 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DEGREES, MINUTES, SECONDS, an angle in +! degrees, minutes, and seconds. +! +! Output, real ( kind = 8 ) RADIANS, the equivalent angle in radians. +! + implicit none + + real(kind=8) angle + integer(kind=4) degrees + integer(kind=4) minutes + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radians + integer(kind=4) seconds + + angle = real(degrees, kind=8) & + + (real(minutes, kind=8) & + + (real(seconds, kind=8) / 60.0D+00)) / 60.0D+00 + + radians = (angle / 180.0D+00) * r8_pi + + return +end +subroutine dodec_shape_3d(point_num, face_num, face_order_max, & + point_coord, face_order, face_point) + +!*****************************************************************************80 +! +!! DODEC_SHAPE_3D describes a dodecahedron in 3D. +! +! Discussion: +! +! The vertices lie on the unit sphere. +! +! The dual of a dodecahedron is an icosahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 October 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices +! per face. +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. +! +! Output, integer ( kind = 4 ) FACE_ORDER[FACE_NUM], the number of vertices +! per face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,POINT_NUM); +! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. +! The points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + real(kind=8) a + real(kind=8) b + real(kind=8) c + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) phi + real(kind=8) point_coord(dim_num, point_num) + real(kind=8) z +! +! Set point coordinates. +! + phi = 0.5D+00 * (sqrt(5.0D+00) + 1.0D+00) + + a = 1.0D+00 / sqrt(3.0D+00) + b = phi / sqrt(3.0D+00) + c = (phi - 1.0D+00) / sqrt(3.0D+00) + z = 0.0D+00 + + point_coord(1:dim_num, 1:point_num) = reshape((/ & + a, a, a, & + a, a, -a, & + a, -a, a, & + a, -a, -a, & + -a, a, a, & + -a, a, -a, & + -a, -a, a, & + -a, -a, -a, & + c, b, z, & + -c, b, z, & + c, -b, z, & + -c, -b, z, & + b, z, c, & + b, z, -c, & + -b, z, c, & + -b, z, -c, & + z, c, b, & + z, -c, b, & + z, c, -b, & + z, -c, -b/), (/dim_num, point_num/)) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5/) +! +! Set the faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 2, 9, 1, 13, 14, & + 5, 10, 6, 16, 15, & + 3, 11, 4, 14, 13, & + 8, 12, 7, 15, 16, & + 3, 13, 1, 17, 18, & + 2, 14, 4, 20, 19, & + 5, 15, 7, 18, 17, & + 8, 16, 6, 19, 20, & + 5, 17, 1, 9, 10, & + 3, 18, 7, 12, 11, & + 2, 19, 6, 10, 9, & + 8, 20, 4, 11, 12/), (/face_order_max, face_num/)) + + return +end +subroutine dodec_size_3d(point_num, edge_num, face_num, face_order_max) + +!*****************************************************************************80 +! +!! DODEC_SIZE_3D gives "sizes" for a dodecahedron in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 20 + edge_num = 30 + face_num = 12 + face_order_max = 5 + + return +end +subroutine dual_shape_3d(point_num, face_num, face_order_max, & + point_coord, face_order, face_point, point_num2, face_num2, & + face_order_max2, point_coord2, face_order2, face_point2) + +!*****************************************************************************80 +! +!! DUAL_SHAPE_3D constructs the dual of a shape in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices +! per face. +! +! Input, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. +! +! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices +! per face. +! +! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The +! points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! +! Input, integer ( kind = 4 ) POINT_NUM2, the number of points in the dual. +! +! Input, integer ( kind = 4 ) FACE_NUM2, the number of faces in the dual. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX2, the maximum number of +! vertices per face in the dual. +! +! Output, real ( kind = 8 ) POINT_COORD2(3,POINT_NUM2), the point +! coordinates of the dual. +! +! Output, integer ( kind = 4 ) FACE_ORDER2(FACE_NUM2), the number of +! vertices per face. +! +! Output, integer ( kind = 4 ) FACE_POINT2(FACE_ORDER_MAX2,FACE_NUM2), +! the vertices of each face in the dual. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) face_num2 + integer(kind=4) face_order_max + integer(kind=4) face_order_max2 + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) point_num + integer(kind=4) point_num2 + + integer(kind=4) col + integer(kind=4) face + integer(kind=4) face_order(face_num) + integer(kind=4) face_order2(face_num2) + integer(kind=4) face_point(face_order_max, face_num) + integer(kind=4) face_point2(face_order_max2, face_num2) + integer(kind=4) i + integer(kind=4) inext + integer(kind=4) iprev + integer(kind=4) istop + integer(kind=4) j + integer(kind=4) k + real(kind=8) norm + real(kind=8) p(dim_num) + real(kind=8) point_coord(dim_num, point_num) + real(kind=8) point_coord2(dim_num, point_num2) + integer(kind=4) row +! +! This computation should really compute the center of gravity +! of the face, in the general case. +! +! We'll also assume the vertices of the original and the dual +! are to lie on the unit sphere, so we can normalize the +! position vector of the vertex. +! + do face = 1, face_num + + p(1:dim_num) = 0.0D+00 + + do j = 1, face_order(face) + k = face_point(j, face) + p(1:dim_num) = p(1:dim_num) + point_coord(1:dim_num, k) + end do + + norm = sqrt(sum(p(1:dim_num)**2)) + + point_coord2(1:dim_num, face) = p(1:dim_num) / norm + + end do +! +! Now build the face in the dual associated with each node FACE. +! + do face = 1, face_num2 +! +! Initialize the order. +! + face_order2(face) = 0 +! +! Find the first occurrence of FACE in an edge of polyhedron. +! + call i4col_find_item(face_order_max, face_num, face_point, & + face, row, col) + + if (row <= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'DUAL_SHAPE_3D - Fatal error!' + write (*, '(a,i8)') ' Could not find an edge using node ', face + stop 1 + end if +! +! Save the following node as ISTOP. +! When we encounter ISTOP again, this will mark the end of our search. +! + i = row + 1 + if (face_order(col) < i) then + i = 1 + end if + + istop = face_point(i, col) +! +! Save the previous node as INEXT. +! + do + + i = row - 1 + if (i < 1) then + i = i + face_order(col) + end if + + inext = face_point(i, col) + + face_order2(face) = face_order2(face) + 1 + + face_point2(face_order2(face), face) = col +! +! If INEXT =/= ISTOP, continue. +! + if (inext == istop) then + exit + end if +! +! Set IPREV:= INEXT. +! + iprev = inext +! +! Search for the occurrence of the edge FACE-IPREV. +! + call i4col_find_pair_wrap(face_order_max, face_num, face_point, & + face, iprev, row, col) + + if (row <= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'DUAL_SHAPE_3D - Fatal error!' + write (*, '(a,i8)') ' No edge from node ', iprev + write (*, '(a,i8)') ' to node ', face + stop 1 + end if + + end do + + end do + + return +end +subroutine dual_size_3d(point_num, edge_num, face_num, face_order_max, & + point_coord, face_order, face_point, point_num2, edge_num2, face_num2, & + face_order_max2) + +!*****************************************************************************80 +! +!! DUAL_SIZE_3D determines sizes for a dual of a shape in 3D. +! +! Discussion: +! +! We don't actually need FACE_POINT as input here. But since the +! three arrays occur together everywhere else, it seems unnecessarily +! user-confusing to vary the usage here! +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices +! per face. +! +! Input, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. +! +! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices +! per face. +! +! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The +! points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! +! Output, integer ( kind = 4 ) POINT_NUM2, the number of points in the dual. +! +! Output, integer ( kind = 4 ) EDGE_NUM2, the number of edges in the dual. +! +! Output, integer ( kind = 4 ) FACE_NUM2, the number of faces in the dual. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX2, the maximum number of +! vertices per face in the dual. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + integer(kind=4) edge_num + integer(kind=4) edge_num2 + integer(kind=4) face + integer(kind=4) face_num2 + integer(kind=4) face_order(face_num) + integer(kind=4) face_order2(point_num) + integer(kind=4) face_order_max2 + integer(kind=4) face_point(face_order_max, face_num) + integer(kind=4) face2 + integer(kind=4) i + integer(kind=4) point_num2 + real(kind=8) point_coord(dim_num, point_num) +! +! These values are easy to compute: +! + point_num2 = face_num + edge_num2 = edge_num + face_num2 = point_num +! +! To determine FACE_ORDER_MAX2 is not so easy. +! You have to construct the FACE_ORDER array for the dual shape. +! The order of a dual face is the number of edges that the vertex occurs in. +! But then all we have to do is count how many times each item shows up +! in the FACE_POINT array. +! + face_order_max2 = 0 + face_order2(1:face_num2) = 0 + + do face = 1, face_num + do i = 1, face_order(face) + face2 = face_point(i, face) + face_order2(face2) = face_order2(face2) + 1 + end do + end do + + face_order_max2 = maxval(face_order2(1:face_num2)) + + return +end +function ellipse_area1(a, r) + +!*****************************************************************************80 +! +!! ELLIPSE_AREA1 returns the area of an ellipse defined by a matrix. +! +! Discussion: +! +! The points X in the ellipse are described by a 2 by 2 +! positive definite symmetric matrix A, and a "radius" R, such that +! X' * A * X <= R * R +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 April 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(2,2), the matrix that describes +! the ellipse. A must be symmetric and positive definite. +! +! Input, real ( kind = 8 ) R, the "radius" of the ellipse. +! +! Output, real ( kind = 8 ) ELLIPSE_AREA1, the area of the ellipse. +! + implicit none + + real(kind=8) a(2, 2) + real(kind=8) ellipse_area1 + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + ellipse_area1 = r**2 * r8_pi / sqrt(a(1, 1) * a(2, 2) - a(2, 1) * a(1, 2)) + + return +end +function ellipse_area2(a, b, c, d) + +!*****************************************************************************80 +! +!! ELLIPSE_AREA2 returns the area of an ellipse defined by an equation. +! +! Discussion: +! +! The ellipse is described by the formula +! a x^2 + b xy + c y^2 = d +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 November 2016 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, coefficients on the left hand side. +! +! Input, real ( kind = 8 ) D, the right hand side. +! +! Output, real ( kind = 8 ) ELLIPSE_AREA2, the area of the ellipse. +! + implicit none + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) ellipse_area2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + ellipse_area2 = 2.0D+00 * d * d * r8_pi / sqrt(4.0D+00 * a * c - b * b) + + return +end +function ellipse_area3(r1, r2) + +!*****************************************************************************80 +! +!! ELLIPSE_AREA3 returns the area of an ellipse in 2D. +! +! Discussion: +! +! An ellipse in standard position has a center at the origin, and +! axes aligned with the coordinate axes. Any point P on the ellipse +! satisfies +! +! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 May 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the "radius" of the ellipse in the major +! and minor axis directions. A circle has these values equal. +! +! Output, real ( kind = 8 ) ELLIPSE_AREA3, the area of the ellipse. +! + implicit none + + real(kind=8) ellipse_area3 + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + ellipse_area3 = r8_pi * r1 * r2 + + return +end +subroutine ellipse_point_dist_2d(r1, r2, p, dist) + +!*****************************************************************************80 +! +!! ELLIPSE_POINT_DIST_2D finds the distance from a point to an ellipse in 2D. +! +! Discussion: +! +! An ellipse in standard position has a center at the origin, and +! axes aligned with the coordinate axes. Any point P on the ellipse +! satisfies +! +! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Dianne O'Leary, +! Elastoplastic Torsion: Twist and Stress, +! Computing in Science and Engineering, +! July/August 2004, pages 74-76. +! September/October 2004, pages 63-65. +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the ellipse parameters. Normally, +! these are both positive quantities. Generally, they are also +! distinct. +! +! Input, real ( kind = 8 ) P(2), the point. +! +! Output, real ( kind = 8 ) DIST, the distance to the ellipse. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) r1 + real(kind=8) r2 + + call ellipse_point_near_2d(r1, r1, p, pn) + + dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + + return +end +subroutine ellipse_point_near_2d(r1, r2, p, pn) + +!*****************************************************************************80 +! +!! ELLIPSE_POINT_NEAR_2D finds the nearest point on an ellipse in 2D. +! +! Discussion: +! +! An ellipse in standard position has a center at the origin, and +! axes aligned with the coordinate axes. Any point P on the ellipse +! satisfies +! +! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 +! +! The nearest point PN on the ellipse has the property that the +! line from PN to P is normal to the ellipse. Points on the ellipse +! can be parameterized by T, to have the form +! +! ( R1 * cos ( T ), R2 * sin ( T ) ). +! +! The tangent vector to the ellipse has the form +! +! ( -R1 * sin ( T ), R2 * cos ( T ) ) +! +! At PN, the dot product of this vector with ( P - PN ) must be +! zero: +! +! - R1 * sin ( T ) * ( X - R1 * cos ( T ) ) +! + R2 * cos ( T ) * ( Y - R2 * sin ( T ) ) = 0 +! +! This nonlinear equation for T can be solved by Newton's method. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the ellipse parameters. Normally, +! these are both positive quantities. Generally, they are also +! distinct. +! +! Input, real ( kind = 8 ) P(2), the point. +! +! Output, real ( kind = 8 ) PN(2), the point on the ellipse which +! is closest to P. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) ct + real(kind=8) f + real(kind=8) fp + integer(kind=4) iteration + integer(kind=4), parameter :: iteration_max = 100 + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) st + real(kind=8) t + real(kind=8) x + real(kind=8) y + + x = abs(p(1)) + y = abs(p(2)) + + if (y == 0.0D+00 .and. r1 * r1 - r2 * r2 <= r1 * x) then + + t = 0.0D+00 + + else if (x == 0.0D+00 .and. r2 * r2 - r1 * r1 <= r2 * y) then + + t = r8_pi / 2.0D+00 + + else + + if (y == 0.0D+00) then + y = sqrt(epsilon(y)) * abs(r2) + end if + + if (x == 0.0D+00) then + x = sqrt(epsilon(x)) * abs(r1) + end if +! +! Initial parameter T: +! + t = atan2(y, x) + + iteration = 0 + + do + + ct = cos(t) + st = sin(t) + + f = (x - abs(r1) * ct) * abs(r1) * st & + - (y - abs(r2) * st) * abs(r2) * ct + + if (abs(f) <= 100.0D+00 * epsilon(f)) then + exit + end if + + if (iteration_max <= iteration) then + write (*, '(a)') ' ' + write (*, '(a)') 'ELLIPSE_POINT_NEAR_2D - Warning!' + write (*, '(a)') ' Reached iteration limit.' + write (*, '(a,f8.6)') ' T = ', t + write (*, '(a,g14.6)') ' F = ', f + exit + end if + + iteration = iteration + 1 + + fp = r1 * r1 * st * st + r2 * r2 * ct * ct & + + (x - abs(r1) * ct) * abs(r1) * ct & + + (y - abs(r2) * st) * abs(r2) * st + + t = t - f / fp + + end do + + end if +! +! From the T value, we get the nearest point. +! + pn(1) = abs(r1) * cos(t) + pn(2) = abs(r2) * sin(t) +! +! Take care of case where the point was in another quadrant. +! + pn(1) = sign(1.0D+00, p(1)) * pn(1) + pn(2) = sign(1.0D+00, p(2)) * pn(2) + + return +end +subroutine ellipse_points_2d(pc, r1, r2, psi, n, p) + +!*****************************************************************************80 +! +!! ELLIPSE_POINTS_2D returns N points on an tilted ellipse in 2D. +! +! Discussion: +! +! An ellipse in standard position has a center at the origin, and +! axes aligned with the coordinate axes. Any point P on the ellipse +! satisfies +! +! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 +! +! The points are "equally spaced" in the angular sense. They are +! not equally spaced along the perimeter of the ellipse. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(2), the center of the ellipse. +! +! Input, real ( kind = 8 ) R1, R2, the "radius" of the ellipse in the major +! and minor axis directions. A circle has these values equal. +! +! Input, real ( kind = 8 ) PSI, the angle that the major axis of the ellipse +! makes with the X axis. A value of 0.0 means that the major and +! minor axes of the ellipse will be the X and Y coordinate axes. +! +! Input, integer ( kind = 4 ) N, the number of points desired. N must +! be at least 1. +! +! Output, real ( kind = 8 ) P(2,N), points on the ellipse. +! + implicit none + + integer(kind=4) n + + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) pc(dim_num) + real(kind=8) psi + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + + do i = 1, n + + theta = (2.0D+00 * r8_pi * real(i - 1, kind=8)) & + / real(n, kind=8) + + p(1, i) = pc(1) + r1 * cos(psi) * cos(theta) & + - r2 * sin(psi) * sin(theta) + + p(2, i) = pc(2) + r1 * sin(psi) * cos(theta) & + + r2 * cos(psi) * sin(theta) + + end do + + return +end +subroutine ellipse_points_arc_2d(pc, r1, r2, psi, theta1, theta2, n, p) + +!*****************************************************************************80 +! +!! ELLIPSE_POINTS_ARC_2D returns N points on a tilted elliptical arc in 2D. +! +! Discussion: +! +! An ellipse in standard position has a center at the origin, and +! axes aligned with the coordinate axes. Any point P on the ellipse +! satisfies +! +! ( P(1) / R1 )^2 + ( P(2) / R2 )^2 == 1 +! +! The points are "equally spaced" in the angular sense. They are +! not equally spaced along the perimeter of the ellipse. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(2), the coordinates of the center of +! the ellipse. +! +! Input, real ( kind = 8 ) R1, R2, the "radius" of the ellipse in the major +! and minor axis directions. A circle has these values equal. +! +! Input, real ( kind = 8 ) PSI, the angle that the major axis of the ellipse +! makes with the X axis. A value of 0.0 means that the major and +! minor axes of the ellipse will be the X and Y coordinate axes. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the angular coordinates of +! the first and last points to be drawn, in radians. This angle is measured +! with respect to the (possibly tilted) major axis. +! +! Input, integer ( kind = 4 ) N, the number of points desired. N must +! be at least 1. +! +! Output, real ( kind = 8 ) P(2,N), points on the ellipse. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) r8_modp + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) pc(dim_num) + real(kind=8) psi + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + real(kind=8) theta3 +! +! THETA3 is the smallest angle, no less than THETA1, which +! coincides with THETA2. +! + theta3 = theta1 + r8_modp(theta2 - theta1, 2.0D+00 * r8_pi) + + do i = 1, n + + if (1 < n) then + theta = (real(n - i, kind=8) * theta1 & + + real(i - 1, kind=8) * theta3) & + / real(n - 1, kind=8) + else + theta = 0.5D+00 * (theta1 + theta3) + end if + + p(1, i) = pc(1) + r1 * cos(psi) * cos(theta) & + - r2 * sin(psi) * sin(theta) + + p(2, i) = pc(2) + r1 * sin(psi) * cos(theta) & + + r2 * cos(psi) * sin(theta) + + end do + + return +end +subroutine get_seed(seed) + +!*****************************************************************************80 +! +!! GET_SEED returns a seed for the random number generator. +! +! Discussion: +! +! The seed depends on the current time, and ought to be (slightly) +! different every millisecond. Once the seed is obtained, a random +! number generator should be called a few times to further process +! the seed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 November 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) SEED, a pseudorandom seed value. +! + implicit none + + integer(kind=4) seed + real(kind=8) temp + character(len=10) time + character(len=8) today + integer(kind=4) values(8) + character(len=5) zone + + call date_and_time(today, time, zone, values) + + temp = 0.0D+00 + + temp = temp + real(values(2) - 1, kind=8) / 11.0D+00 + temp = temp + real(values(3) - 1, kind=8) / 30.0D+00 + temp = temp + real(values(5), kind=8) / 23.0D+00 + temp = temp + real(values(6), kind=8) / 59.0D+00 + temp = temp + real(values(7), kind=8) / 59.0D+00 + temp = temp + real(values(8), kind=8) / 999.0D+00 + temp = temp / 6.0D+00 +! +! Force 0 < TEMP <= 1. +! + do while (temp <= 0.0D+00) + temp = temp + 1.0D+00 + end do + + do while (1.0D+00 < temp) + temp = temp - 1.0D+00 + end do + + seed = int(real(huge(1), kind=8) * temp) +! +! Never use a seed of 0 or maximum integer. +! + if (seed == 0) then + seed = 1 + end if + + if (seed == huge(1)) then + seed = seed - 1 + end if + + return +end +subroutine get_unit(iunit) + +!*****************************************************************************80 +! +!! GET_UNIT returns a free FORTRAN unit number. +! +! Discussion: +! +! A "free" FORTRAN unit number is a value between 1 and 99 which +! is not currently associated with an I/O device. A free FORTRAN unit +! number is needed in order to open a file with the OPEN command. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 March 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) IUNIT. +! +! If IUNIT = 0, then no free FORTRAN unit could be found, although +! all 99 units were checked (except for units 5 and 6). +! +! Otherwise, IUNIT is a value between 1 and 99, representing a +! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 +! are special, and will never return those values. +! + implicit none + + integer(kind=4) i + integer(kind=4) ios + integer(kind=4) iunit + logical(kind=4) lopen + + iunit = 0 + + do i = 1, 99 + + if (i /= 5 .and. i /= 6) then + + inquire (unit=i, opened=lopen, iostat=ios) + + if (ios == 0) then + if (.not. lopen) then + iunit = i + return + end if + end if + + end if + + end do + + return +end +subroutine glob2loc_3d(cospitch, cosroll, cosyaw, sinpitch, sinroll, sinyaw, & + globas, glopts, locpts) + +!*****************************************************************************80 +! +!! GLOB2LOC_3D converts from a global to a local coordinate system in 3D. +! +! Discussion: +! +! A global coordinate system is given. +! +! A local coordinate system has been translated to the point with +! global coordinates GLOBAS, and rotated through a yaw, a pitch, and +! a roll. +! +! A point has global coordinates GLOPTS, and it is desired to know +! the point's local coordinates LOCPTS. +! +! The transformation may be written as +! +! LOC = M_ROLL * M_PITCH * M_YAW * ( GLOB - GLOBAS ) +! +! where +! +! ( 1 0 0 ) +! M_ROLL = ( 0 cos(Roll) sin(Roll) ) +! ( 0 - sin(Roll) cos(Roll) ) +! +! ( cos(Pitch) 0 - sin(Pitch) ) +! M_PITCH = ( 0 1 0 ) +! ( sin(Pitch) 0 cos(Pitch) ) +! +! ( cos(Yaw) sin(Yaw) 0 ) +! M_YAW = ( - sin(Yaw) cos(Yaw) 0 ) +! ( 0 0 1 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) COSPITCH, COSROLL, COSYAW, the cosines of +! the pitch, roll and yaw angles. +! +! Input, real ( kind = 8 ) SINPITCH, SINROLL, SINYAW, the sines of the pitch, +! roll and yaw angles. +! +! Input, real ( kind = 8 ) GLOBAS(3), the global base vector. +! +! Input, real ( kind = 8 ) GLOPTS(3), the global coordinates +! of the point whose coordinates are to be transformed. +! +! Output, real ( kind = 8 ) LOCPTS(3), the local coordinates of the point +! whose global coordinates were given in GLOPTS. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) cospitch + real(kind=8) cosroll + real(kind=8) cosyaw + real(kind=8) globas(dim_num) + real(kind=8) glopts(dim_num) + real(kind=8) locpts(dim_num) + real(kind=8) sinpitch + real(kind=8) sinroll + real(kind=8) sinyaw + + locpts(1) = (cosyaw * cospitch) * (glopts(1) - globas(1)) & + + (sinyaw * cospitch) * (glopts(2) - globas(2)) & + - sinpitch * (glopts(3) - globas(3)) + + locpts(2) = (cosyaw * sinpitch * sinroll - sinyaw * cosroll) & + * (glopts(1) - globas(1)) & + + (sinyaw * sinpitch * sinroll + cosyaw * cosroll) & + * (glopts(2) - globas(2)) & + + cospitch * sinroll * (glopts(3) - globas(3)) + + locpts(3) = (cosyaw * sinpitch * cosroll + sinyaw * sinroll) & + * (glopts(1) - globas(1)) & + + (sinyaw * sinpitch * cosroll - cosyaw * sinroll) & + * (glopts(2) - globas(2)) & + + (cospitch * cosroll) * (glopts(3) - globas(3)) + + return +end +function halfplane_contains_point_2d(p1, p2, p) + +!*****************************************************************************80 +! +!! HALFPLANE_CONTAINS_POINT_2D reports if a half-plane contains a point in 2d. +! +! Discussion: +! +! The halfplane is assumed to be all the points "to the left" of the +! line that passes from P1 through P2. Thus, one way to +! understand where the point P is, is to compute the signed +! area of the triangle ( P1, P2, P ). +! +! If this area is +! positive, the point is strictly inside the halfplane, +! zero, the point is on the boundary of the halfplane, +! negative, the point is strictly outside the halfplane. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two distinct points +! on the line defining the half plane. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) HALFPLANE_CONTAINS_POINT_2D, is TRUE if +! the halfplane contains the point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area_signed + logical(kind=4) halfplane_contains_point_2d + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + area_signed = 0.5D+00 * & + (p1(1) * (p2(2) - p(2)) & + + p2(1) * (p(2) - p1(2)) & + + p(1) * (p1(2) - p2(2))) + + halfplane_contains_point_2d = (0.0D+00 <= area_signed) + + return +end +subroutine halfspace_imp_triangle_int_3d(a, b, c, d, t, int_num, pint) + +!*****************************************************************************80 +! +!! HALFSPACE_IMP_TRIANGLE_INT_3D: intersection ( imp halfspace, triangle ). +! +! Discussion: +! +! The implicit form of a half-space in 3D may be described as the set +! of points P on or "above" an implicit plane: +! +! 0 <= A * P(1) + B * P(2) + C * P(3) + D +! +! The triangle is specified by listing its three vertices. +! +! The intersection may be described by the number of vertices of the +! triangle that are included in the halfspace, and by the location of +! points between vertices that separate a side of the triangle into +! an included part and an unincluded part. +! +! 0 vertices, 0 separators (no intersection) +! 1 vertex, 0 separators (point intersection) +! 2 vertices, 0 separators (line intersection) +! 3 vertices, 0 separators (triangle intersection) +! +! 1 vertex, 2 separators, (intersection is a triangle) +! 2 vertices, 2 separators, (intersection is a quadrilateral). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the parameters that define the +! implicit plane, which in turn define the implicit halfspace. +! +! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points +! returned, which will always be between 0 and 4. +! +! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the INT_NUM +! intersection points. The points will lie in sequence on the triangle. +! Some points will be vertices, and some may be separators. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) dist1 + real(kind=8) dist2 + real(kind=8) dist3 + integer(kind=4) int_num + real(kind=8) pint(dim_num, 4) + real(kind=8) t(dim_num, 3) +! +! Compute the signed distances between the vertices and the plane. +! + dist1 = a * t(1, 1) + b * t(2, 1) + c * t(3, 1) + d + dist2 = a * t(1, 2) + b * t(2, 2) + c * t(3, 2) + d + dist3 = a * t(1, 3) + b * t(2, 2) + c * t(3, 3) + d +! +! Now we can find the intersections. +! + call halfspace_triangle_int_3d(dist1, dist2, dist3, t, int_num, pint) + + return +end +subroutine halfspace_normal_triangle_int_3d(pp, normal, t, int_num, pint) + +!*****************************************************************************80 +! +!! HALFSPACE_NORMAL_TRIANGLE_INT_3D: intersection ( norm halfspace, triangle ). +! +! Discussion: +! +! The normal form of a halfspace in 3D may be described as the set +! of points P on or "above" a plane described in normal form: +! +! PP is a point on the plane, +! NORMAL is the unit normal vector, pointing "out" of the +! halfspace. +! +! The triangle is specified by listing its three vertices. +! +! The intersection may be described by the number of vertices of the +! triangle that are included in the halfspace, and by the location of +! points between vertices that separate a side of the triangle into +! an included part and an unincluded part. +! +! 0 vertices, 0 separators (no intersection) +! 1 vertex, 0 separators (point intersection) +! 2 vertices, 0 separators (line intersection) +! 3 vertices, 0 separators (triangle intersection) +! +! 1 vertex, 2 separators, (intersection is a triangle) +! 2 vertices, 2 separators, (intersection is a quadrilateral). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the bounding plane +! that defines the halfspace. +! +! Input, real ( kind = 8 ) NORMAL(3), the components of the normal vector +! to the bounding plane that defines the halfspace. By convention, the +! normal vector points "outwards" from the halfspace. +! +! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points +! returned, which will always be between 0 and 4. +! +! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the INT_NUM +! intersection points. The points will lie in sequence on the triangle. +! Some points will be vertices, and some may be separators. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) d + real(kind=8) dist1 + real(kind=8) dist2 + real(kind=8) dist3 + real(kind=8) normal(dim_num) + integer(kind=4) int_num + real(kind=8) pp(dim_num) + real(kind=8) pint(dim_num, 4) + real(kind=8) t(dim_num, 3) +! +! Compute the signed distances between the vertices and the plane. +! + d = -dot_product(normal(1:dim_num), pp(1:dim_num)) +! +! Compute the signed distances between the vertices and the plane. +! + dist1 = d + dot_product(normal(1:dim_num), t(1:dim_num, 1)) + dist2 = d + dot_product(normal(1:dim_num), t(1:dim_num, 2)) + dist3 = d + dot_product(normal(1:dim_num), t(1:dim_num, 3)) +! +! Now we can find the intersections. +! + call halfspace_triangle_int_3d(dist1, dist2, dist3, t, int_num, pint) + + return +end +subroutine halfspace_triangle_int_3d(dist1, dist2, dist3, t, int_num, pint) + +!*****************************************************************************80 +! +!! HALFSPACE_TRIANGLE_INT_3D: intersection ( halfspace, triangle ) in 3D. +! +! Discussion: +! +! The triangle is specified by listing its three vertices. +! +! The halfspace is not described in the input data. Rather, the +! distances from the triangle vertices to the halfspace are given. +! +! The intersection may be described by the number of vertices of the +! triangle that are included in the halfspace, and by the location of +! points between vertices that separate a side of the triangle into +! an included part and an unincluded part. +! +! 0 vertices, 0 separators (no intersection) +! 1 vertex, 0 separators (point intersection) +! 2 vertices, 0 separators (line intersection) +! 3 vertices, 0 separators (triangle intersection) +! +! 1 vertex, 2 separators, (intersection is a triangle) +! 2 vertices, 2 separators, (intersection is a quadrilateral). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DIST1, DIST2, DIST3, the distances from each of +! the three vertices of the triangle to the halfspace. The distance is +! zero if a vertex lies within the halfspace, or on the plane that +! defines the boundary of the halfspace. Otherwise, it is the +! distance from that vertex to the bounding plane. +! +! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points +! returned, which will always be between 0 and 4. +! +! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the INT_NUM +! intersection points. The points will lie in sequence on the triangle. +! Some points will be vertices, and some may be separators. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dist1 + real(kind=8) dist2 + real(kind=8) dist3 + integer(kind=4) int_num + real(kind=8) pint(dim_num, 4) + real(kind=8) t(dim_num, 3) +! +! Walk around the triangle, looking for vertices that are included, +! and points of separation. +! + int_num = 0 + + if (dist1 <= 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 1) + + end if + + if (dist1 * dist2 < 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = & + (dist1 * t(1:dim_num, 2) - dist2 * t(1:dim_num, 1)) & + / (dist1 - dist2) + + end if + + if (dist2 <= 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 2) + + end if + + if (dist2 * dist3 < 0.0D+00) then + + int_num = int_num + 1 + + pint(1:dim_num, int_num) = & + (dist2 * t(1:dim_num, 3) - dist3 * t(1:dim_num, 2)) & + / (dist2 - dist3) + + end if + + if (dist3 <= 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 3) + + end if + + if (dist3 * dist1 < 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = & + (dist3 * t(1:dim_num, 1) - dist1 * t(1:dim_num, 3)) & + / (dist3 - dist1) + + end if + + return +end +function haversine(a) + +!*****************************************************************************80 +! +!! HAVERSINE computes the haversine of an angle. +! +! Discussion: +! +! haversine(A) = ( 1 - cos ( A ) ) / 2 +! +! The haversine is useful in spherical trigonometry. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 July 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, the angle. +! +! Output, real ( kind = 8 ) HAVERSINE, the haversine of the angle. +! + implicit none + + real(kind=8) a + real(kind=8) haversine + + haversine = (1.0D+00 - cos(a)) / 2.0D+00 + + return +end +subroutine helix_shape_3d(a, n, r, theta1, theta2, p) + +!*****************************************************************************80 +! +!! HELIX_SHAPE_3D computes points on a helix in 3D. +! +! Discussion: +! +! The user specifies the parameters A and R, the first and last +! THETA values, and the number of equally spaced THETA values +! at which point values are to be computed. +! +! X = R * COS ( THETA ) +! Y = R * SIN ( THETA ) +! Z = A * THETA +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, the rate at which Z advances with THETA. +! +! Input, integer ( kind = 4 ) N, the number of points to compute on +! the helix. +! +! Input, real ( kind = 8 ) R, the radius of the helix. +! +! Input, real ( kind = 8 ) THETA1, THETA2, the first and last THETA values at +! which to compute points on the helix. THETA is measured in +! radians. +! +! Output, real ( kind = 8 ) P(3,N), the coordinates of points on the helix. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) r + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + + do i = 1, n + + if (n == 1) then + theta = 0.5D+00 * (theta1 + theta2) + else + theta = (real(n - i, kind=8) * theta1 & + + real(i - 1, kind=8) * theta2) & + / real(n - 1, kind=8) + end if + + p(1, i) = r * cos(theta) + p(2, i) = r * sin(theta) + p(3, i) = a * theta + + end do + + return +end +function hexagon_area_2d(r) + +!*****************************************************************************80 +! +!! HEXAGON_AREA_2D returns the area of a regular hexagon in 2D. +! +! Discussion: +! +! The radius of a regular hexagon is the distance from the center +! of the hexagon to any vertex. This happens also to equal the +! length of any side. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the hexagon. +! +! Output, real ( kind = 8 ) HEXAGON_AREA_2D, the area of the hexagon. +! + implicit none + + real(kind=8) hexagon_area_2d + real(kind=8) hexagon01_area_2d + real(kind=8) r + + hexagon_area_2d = r * r * hexagon01_area_2d() + + return +end +function hexagon_contains_point_2d(v, p) + +!*****************************************************************************80 +! +!! HEXAGON_CONTAINS_POINT_2D finds if a point is inside a hexagon in 2D. +! +! Discussion: +! +! This test is only valid if the hexagon is convex. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 June 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V(2,6), the vertices, in counter clockwise order. +! +! Input, real ( kind = 8 ) P(2), the point to be tested. +! +! Output, logical ( kind = 4 ) HEXAGON_CONTAINS_POINT_2D, is TRUE +! if X is in the hexagon. +! + implicit none + + integer(kind=4), parameter :: n = 6 + integer(kind=4), parameter :: dim_num = 2 + + logical(kind=4) hexagon_contains_point_2d + integer(kind=4) i + integer(kind=4) j + real(kind=8) p(dim_num) + real(kind=8) v(dim_num, n) +! +! A point is inside a convex hexagon if and only if it is "inside" +! each of the 6 halfplanes defined by lines through consecutive +! vertices. +! + do i = 1, n + + j = mod(i, n) + 1 + + if (v(1, i) * (v(2, j) - p(2)) & + + v(1, j) * (p(2) - v(2, i)) & + + p(1) * (v(2, i) - v(2, j)) < 0.0D+00) then + + hexagon_contains_point_2d = .false. + return + + end if + + end do + + hexagon_contains_point_2d = .true. + + return +end +subroutine hexagon_shape_2d(angle_deg, p) + +!*****************************************************************************80 +! +!! HEXAGON_SHAPE_2D returns points on the unit regular hexagon in 2D. +! +! Diagram: +! +! 120_____60 +! / \ +! 180/ \0 +! \ / +! \_____/ +! 240 300 +! +! Discussion: +! +! The unit regular hexagon has radius 1. The radius is the distance from +! the center to any vertex, and it is also the length of any side. +! An example of a unit hexagon is the convex hull of the points: +! +! ( 1, 0 ), +! ( 0.5, sqrt (3)/2 ), +! ( - 0.5, sqrt (3)/2 ), +! ( - 1, 0 ), +! ( - 0.5, - sqrt (3)/2 ), +! ( 0.5, - sqrt (3)/2 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 July 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) ANGLE_DEG, the angle, in degrees, of the point. +! +! Output, real ( kind = 8 ) P(2), the coordinates of the point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle_deg + real(kind=8) angle2 + real(kind=8) p(dim_num) + real(kind=8) r8_cotd + real(kind=8) r8_modp + real(kind=8) r8_tand +! +! Ensure that 0 <= ANGLE < 360. +! + angle2 = r8_modp(angle_deg, 360.0D+00) +! +! y = - sqrt(3) * x + sqrt(3) +! + if (0.0D+00 <= angle2 .and. angle2 <= 60.0D+00) then + + p(1) = sqrt(3.0D+00) / (r8_tand(angle2) + sqrt(3.0D+00)) + p(2) = r8_tand(angle2) * p(1) +! +! y = sqrt(3) / 2 +! + else if (angle2 <= 120.0D+00) then + + p(2) = sqrt(3.0D+00) / 2.0D+00 + p(1) = r8_cotd(angle2) * p(2) +! +! y = sqrt(3) * x + sqrt(3) +! + else if (angle2 <= 180.0D+00) then + + p(1) = sqrt(3.0D+00) / (r8_tand(angle2) - sqrt(3.0D+00)) + p(2) = r8_tand(angle2) * p(1) +! +! y = - sqrt(3) * x - sqrt(3) +! + else if (angle2 <= 240.0D+00) then + + p(1) = -sqrt(3.0D+00) / (r8_tand(angle2) + sqrt(3.0D+00)) + p(2) = r8_tand(angle2) * p(1) +! +! y = - sqrt(3) / 2 +! + else if (angle2 <= 300.0D+00) then + + p(2) = -sqrt(3.0D+00) / 2.0D+00 + p(1) = r8_cotd(angle2) * p(2) +! +! y = sqrt(3) * x - sqrt(3) +! + else if (angle2 <= 360.0D+00) then + + p(1) = -sqrt(3.0D+00) / (r8_tand(angle2) - sqrt(3.0D+00)) + p(2) = r8_tand(angle2) * p(1) + + end if + + return +end +subroutine hexagon_vertices_2d(p) + +!*****************************************************************************80 +! +!! HEXAGON_VERTICES_2D returns the vertices of the unit hexagon in 2D. +! +! Discussion: +! +! The unit hexagon has maximum radius 1, and is the hull of the points +! +! ( 1, 0 ), +! ( 0.5, sqrt (3)/2 ), +! ( - 0.5, sqrt (3)/2 ), +! ( - 1, 0 ), +! ( - 0.5, - sqrt (3)/2 ), +! ( 0.5, - sqrt (3)/2 ). +! +! Diagram: +! +! 120_____60 +! / \ +! 180/ \0 +! \ / +! \_____/ +! 240 300 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) P(2,6), the coordinates of the vertices. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8), parameter :: a = 0.8660254037844386D+00 + real(kind=8) p(dim_num, 6) + + p(1:2, 1:6) = reshape((/ & + 1.0D+00, 0.0D+00, & + 0.5D+00, a, & + -0.5D+00, a, & + -1.0D+00, 0.0D+00, & + -0.5D+00, -a, & + 0.5D+00, -a/), (/dim_num, 6/)) + + return +end +function hexagon01_area_2d() + +!*****************************************************************************80 +! +!! HEXAGON01_AREA_2D returns the area of a unit regular hexagon in 2D. +! +! Discussion: +! +! A "unit" regular hexagon has both a "radius" of 1 (distance +! from the center to any vertex), and a side length of 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) HEXAGON01_AREA_2D, the area of the hexagon. +! + implicit none + + real(kind=8) hexagon01_area_2d + + hexagon01_area_2d = 3.0D+00 * sqrt(3.0D+00) / 2.0D+00 + + return +end +function hyperball01_volume(m) + +!*****************************************************************************80 +! +!! HYPERBALL01_VOLUME returns the volume of the unit hyperball in M dimensions. +! +! Discussion: +! +! M Volume +! +! 1 2 +! 2 1 * PI +! 3 ( 4 / 3) * PI +! 4 ( 1 / 2) * PI^2 +! 5 ( 8 / 15) * PI^2 +! 6 ( 1 / 6) * PI^3 +! 7 (16 / 105) * PI^3 +! 8 ( 1 / 24) * PI^4 +! 9 (32 / 945) * PI^4 +! 10 ( 1 / 120) * PI^5 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the spatial dimension. +! +! Output, real ( kind = 8 ) HYPERBALL01_VOLUME, the volume of the unit ball. +! + implicit none + + real(kind=8) hyperball01_volume + integer(kind=4) i + integer(kind=4) m + integer(kind=4) m_half + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) volume + + if (mod(m, 2) == 0) then + m_half = (m / 2) + volume = r8_pi**m_half + do i = 1, m_half + volume = volume / real(i, kind=8) + end do + else + m_half = ((m - 1) / 2) + volume = r8_pi**m_half * 2.0D+00**m + do i = m_half + 1, 2 * m_half + 1 + volume = volume / real(i, kind=8) + end do + end if + + hyperball01_volume = volume + + return +end +function i4_dedekind_factor(p, q) + +!*****************************************************************************80 +! +!! I4_DEDEKIND_FACTOR computes a function needed for a Dedekind sum. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Hans Rademacher, Emil Grosswald, +! Dedekind Sums, +! Mathematics Association of America, 1972, +! LC: QA241.R2. +! +! Parameters: +! +! Input, integer ( kind = 4 ) P, Q, two positive integers. +! +! Input, real ( kind = 8 ) I4_DEDEKIND_FACTOR, the Dedekind factor of P / Q. +! + implicit none + + real(kind=8) i4_dedekind_factor + integer(kind=4) p + integer(kind=4) q + + if (mod(p, q) == 0) then + i4_dedekind_factor = 0.0D+00 + else + i4_dedekind_factor = real(p, kind=8) / real(q, kind=8) & + - real((p / q), kind=8) - 0.5D+00 + end if + + return +end +subroutine i4_dedekind_sum(p, q, s) + +!*****************************************************************************80 +! +!! I4_DEDEKIND_SUM computes the Dedekind sum of two I4's. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Hans Rademacher, Emil Grosswald, +! Dedekind Sums, +! Mathematics Association of America, 1972, +! LC: QA241.R2. +! +! Parameters: +! +! Input, integer ( kind = 4 ) P, Q, two positive integers. +! +! Output, real ( kind = 8 ) S, the Dedekind sum of P and Q. +! + implicit none + + integer(kind=4) i + real(kind=8) i4_dedekind_factor + integer(kind=4) p + integer(kind=4) q + real(kind=8) s + + s = 0.0D+00 + + do i = 1, q + s = s + i4_dedekind_factor(i, q) * i4_dedekind_factor(p * i, q) + end do + + return +end +function i4_factorial2(n) + +!*****************************************************************************80 +! +!! I4_FACTORIAL2 computes the double factorial function. +! +! Discussion: +! +! FACTORIAL2( N ) = Product ( N * (N-2) * (N-4) * ... * 2 ) (N even) +! = Product ( N * (N-2) * (N-4) * ... * 1 ) (N odd) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 December 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the argument of the double factorial +! function. If N is less than 1, I4_FACTORIAL2 is returned as 1. +! +! Output, integer ( kind = 4 ) I4_FACTORIAL2, the value of N!!. +! + implicit none + + integer(kind=4) i4_factorial2 + integer(kind=4) n + integer(kind=4) n_copy + + if (n < 1) then + i4_factorial2 = 1 + return + end if + + n_copy = n + i4_factorial2 = 1 + + do while (1 < n_copy) + i4_factorial2 = i4_factorial2 * n_copy + n_copy = n_copy - 2 + end do + + return +end +function i4_gcd(i, j) + +!*****************************************************************************80 +! +!! I4_GCD finds the greatest common divisor of two I4's. +! +! Discussion: +! +! Note that only the absolute values of I and J are +! considered, so that the result is always nonnegative. +! +! If I or J is 0, I4_GCD is returned as max ( 1, abs ( I ), abs ( J ) ). +! +! If I and J have no common factor, I4_GCD is returned as 1. +! +! Otherwise, using the Euclidean algorithm, I4_GCD is the +! greatest common divisor of I and J. +! +! An I4 is an integer ( kind = 4 ) value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 March 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) I, J, two numbers whose GCD is desired. +! +! Output, integer ( kind = 4 ) I4_GCD, the greatest common divisor +! of I and J. +! + implicit none + + integer(kind=4) i + integer(kind=4) i4_gcd + integer(kind=4) j + 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 + + return +end +function i4_huge() + +!*****************************************************************************80 +! +!! I4_HUGE returns a "huge" I4. +! +! Discussion: +! +! On an IEEE 32 bit machine, I4_HUGE should be 2**31 - 1, and its +! bit pattern should be +! +! 01111111111111111111111111111111 +! +! In this case, its numerical value is 2147483647. +! +! Using the Dec/Compaq/HP Alpha FORTRAN compiler FORT, I could +! use I4_HUGE() and HUGE interchangeably. +! +! However, when using the G95, the values returned by HUGE were +! not equal to 2147483647, apparently, and were causing severe +! and obscure errors in my random number generator, which needs to +! add I4_HUGE to the seed whenever the seed is negative. So I +! am backing away from invoking HUGE, whereas I4_HUGE is under +! my control. +! +! Explanation: because under G95 the default integer type is 64 bits! +! So HUGE ( 1 ) = a very very huge integer indeed, whereas +! I4_HUGE ( ) = the same old 32 bit big value. +! +! An I4 is an integer ( kind = 4 ) value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 January 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) I4_HUGE, a "huge" I4. +! + implicit none + + integer(kind=4) i4_huge + + i4_huge = 2147483647 + + return +end +function i4_lcm(i, j) + +!*****************************************************************************80 +! +!! I4_LCM computes the least common multiple of two I4's. +! +! Discussion: +! +! The least common multiple may be defined as +! +! LCM(I,J) = ABS( I * J ) / GCD(I,J) +! +! where GCD(I,J) is the greatest common divisor of I and J. +! +! An I4 is an integer ( kind = 4 ) value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 March 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) I, J, the integers whose I4_LCM is desired. +! +! Output, integer ( kind = 4 ) I4_LCM, the least common multiple of I and J. +! I4_LCM is never negative. I4_LCM is 0 if either I or J is zero. +! + implicit none + + integer(kind=4) i + integer(kind=4) i4_gcd + integer(kind=4) j + integer(kind=4) i4_lcm + + i4_lcm = abs(i * (j / i4_gcd(i, j))) + + return +end +function i4_modp(i, j) + +!*****************************************************************************80 +! +!! I4_MODP returns the nonnegative remainder of integer division. +! +! Discussion: +! +! If +! NREM = I4_MODP ( I, J ) +! NMULT = ( I - NREM ) / J +! then +! I = J * NMULT + NREM +! where NREM is always nonnegative. +! +! The MOD function computes a result with the same sign as the +! quantity being divided. Thus, suppose you had an angle A, +! and you wanted to ensure that it was between 0 and 360. +! Then mod(A,360) would do, if A was positive, but if A +! was negative, your result would be between -360 and 0. +! +! On the other hand, I4_MODP(A,360) is between 0 and 360, always. +! +! Example: +! +! I J MOD I4_MODP Factorization +! +! 107 50 7 7 107 = 2 * 50 + 7 +! 107 -50 7 7 107 = -2 * -50 + 7 +! -107 50 -7 43 -107 = -3 * 50 + 43 +! -107 -50 -7 43 -107 = 3 * -50 + 43 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 March 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) I, the number to be divided. +! +! Input, integer ( kind = 4 ) J, the number that divides I. +! +! Output, integer ( kind = 4 ) I4_MODP, the nonnegative remainder when I is +! divided by J. +! + implicit none + + integer(kind=4) i + integer(kind=4) i4_modp + integer(kind=4) j + + if (j == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4_MODP - Fatal error!' + write (*, '(a,i8)') ' I4_MODP ( I, J ) called with J = ', j + stop 1 + end if + + i4_modp = mod(i, j) + + if (i4_modp < 0) then + i4_modp = i4_modp + abs(j) + end if + + return +end +subroutine i4_swap(i, j) + +!*****************************************************************************80 +! +!! I4_SWAP switches two I4's. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 November 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) I, J. On output, the values of I and +! J have been interchanged. +! + implicit none + + integer(kind=4) i + integer(kind=4) j + integer(kind=4) k + + k = i + i = j + j = k + + return +end +function i4_uniform(a, b, seed) + +!*****************************************************************************80 +! +!! I4_UNIFORM returns a scaled pseudorandom I4. +! +! Discussion: +! +! An I4 is an integer ( kind = 4 ) value. +! +! The pseudorandom number will be scaled to be uniformly distributed +! between A and B. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 November 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paul Bratley, Bennett Fox, Linus Schrage, +! A Guide to Simulation, +! Springer Verlag, pages 201-202, 1983. +! +! Pierre L'Ecuyer, +! Random Number Generation, +! in Handbook of Simulation, +! edited by Jerry Banks, +! Wiley Interscience, page 95, 1998. +! +! Bennett Fox, +! Algorithm 647: +! Implementation and Relative Efficiency of Quasirandom +! Sequence Generators, +! ACM Transactions on Mathematical Software, +! Volume 12, Number 4, pages 362-376, 1986. +! +! Peter Lewis, Allen Goodman, James Miller +! A Pseudo-Random Number Generator for the System/360, +! IBM Systems Journal, +! Volume 8, pages 136-143, 1969. +! +! Parameters: +! +! Input, integer ( kind = 4 ) A, B, the limits of the interval. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, +! which should NOT be 0. On output, SEED has been updated. +! +! Output, integer ( kind = 4 ) I4_UNIFORM, a number between +! A and B. +! + implicit none + + integer(kind=4) a + integer(kind=4) b + integer(kind=4) i4_uniform + integer(kind=4) k + real(kind=4) r + integer(kind=4) seed + integer(kind=4) value + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4_UNIFORM - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if + + r = real(seed, kind=4) * 4.656612875E-10 +! +! Scale R to lie between A-0.5 and B+0.5. +! + r = (1.0E+00 - r) * (real(min(a, b), kind=4) - 0.5E+00) & + + r * (real(max(a, b), kind=4) + 0.5E+00) +! +! Use rounding to convert R to an integer between A and B. +! + value = nint(r, kind=4) + + value = max(value, min(a, b)) + value = min(value, max(a, b)) + + i4_uniform = value + + return +end +function i4_wrap(ival, ilo, ihi) + +!*****************************************************************************80 +! +!! I4_WRAP forces an I4 to lie between given limits by wrapping. +! +! Example: +! +! ILO = 4, IHI = 8 +! +! I I4_WRAP +! +! -2 8 +! -1 4 +! 0 5 +! 1 6 +! 2 7 +! 3 8 +! 4 4 +! 5 5 +! 6 6 +! 7 7 +! 8 8 +! 9 4 +! 10 5 +! 11 6 +! 12 7 +! 13 8 +! 14 4 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) IVAL, an integer value. +! +! Input, integer ( kind = 4 ) ILO, IHI, the desired bounds for the integer +! value. +! +! Output, integer ( kind = 4 ) I4_WRAP, a "wrapped" version of IVAL. +! + implicit none + + integer(kind=4) i4_modp + integer(kind=4) i4_wrap + integer(kind=4) ihi + integer(kind=4) ilo + integer(kind=4) ival + integer(kind=4) jhi + integer(kind=4) jlo + integer(kind=4) wide + + jlo = min(ilo, ihi) + jhi = max(ilo, ihi) + + wide = jhi - jlo + 1 + + if (wide == 1) then + i4_wrap = jlo + else + i4_wrap = jlo + i4_modp(ival - jlo, wide) + end if + + return +end +subroutine i4col_compare(m, n, a, i, j, isgn) + +!*****************************************************************************80 +! +!! I4COL_COMPARE compares columns I and J of an I4COL. +! +! Example: +! +! Input: +! +! M = 3, N = 4, I = 2, J = 4 +! +! A = ( +! 1 2 3 4 +! 5 6 7 8 +! 9 10 11 12 ) +! +! Output: +! +! ISGN = -1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 June 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), an array of N columns of vectors +! of length M. +! +! Input, integer ( kind = 4 ) I, J, the columns to be compared. +! I and J must be between 1 and N. +! +! Output, integer ( kind = 4 ) ISGN, the results of the comparison: +! -1, column I < column J, +! 0, column I = column J, +! +1, column J < column I. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) i + integer(kind=4) isgn + integer(kind=4) j + integer(kind=4) k +! +! Check. +! + if (i < 1 .or. n < i) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4COL_COMPARE - Fatal error!' + write (*, '(a)') ' Column index I is out of bounds.' + stop 1 + end if + + if (j < 1 .or. n < j) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4COL_COMPARE - Fatal error!' + write (*, '(a)') ' Column index J is out of bounds.' + stop 1 + end if + + isgn = 0 + + if (i == j) then + return + end if + + k = 1 + + do while (k <= m) + + if (a(k, i) < a(k, j)) then + isgn = -1 + return + else if (a(k, j) < a(k, i)) then + isgn = +1 + return + end if + + k = k + 1 + + end do + + return +end +subroutine i4col_find_item(m, n, a, item, row, col) + +!*****************************************************************************80 +! +!! I4COL_FIND_ITEM searches a table by columns for a given scalar value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 November 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns in +! the table. +! +! Input, integer ( kind = 4 ) A(M,N), an array of N columns of vectors +! of length M. +! +! Input, integer ( kind = 4 ) ITEM, the value to search for. +! +! Output, integer ( kind = 4 ) ROW, COL, the row and column indices +! of the first occurrence of the value ITEM. The search +! is conducted by columns. If the item is not found, then +! ROW = COL = -1. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) col + integer(kind=4) i + integer(kind=4) item + integer(kind=4) j + integer(kind=4) row + + do j = 1, n + do i = 1, m + if (a(i, j) == item) then + row = i + col = j + return + end if + end do + end do + + row = -1 + col = -1 + + return +end +subroutine i4col_find_pair_wrap(m, n, a, item1, item2, row, col) + +!*****************************************************************************80 +! +!! I4COL_FIND_PAIR_WRAP searches a table by columns for a pair of items. +! +! Discussion: +! +! The items (ITEM1, ITEM2) must occur consecutively. +! However, wrapping is allowed, that is, if ITEM1 occurs +! in the last row, and ITEM2 "follows" it in the first row +! of the same column, a match is declared. +! +! If the pair of items is not found, then ROW = COL = -1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns in +! the array. +! +! Input, integer ( kind = 4 ) A(M,N), the array to search. +! +! Input, integer ( kind = 4 ) ITEM1, ITEM2, the values to search for. +! +! Output, integer ( kind = 4 ) ROW, COL, the row and column indices +! of the first occurrence of the value ITEM1 followed immediately +! by ITEM2. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) col + integer(kind=4) i + integer(kind=4) i2 + integer(kind=4) item1 + integer(kind=4) item2 + integer(kind=4) j + integer(kind=4) row + + do j = 1, n + do i = 1, m + + if (a(i, j) == item1) then + + i2 = i + 1 + + if (m < i2) then + i2 = 1 + end if + + if (a(i2, j) == item2) then + row = i + col = j + return + end if + + end if + + end do + end do + + row = -1 + col = -1 + + return +end +subroutine i4col_sort_a(m, n, a) + +!*****************************************************************************80 +! +!! I4COL_SORT_A ascending sorts an integer array of columns. +! +! Discussion: +! +! In lexicographic order, the statement "X < Y", applied to two real +! vectors X and Y of length M, means that there is some index I, with +! 1 <= I <= M, with the property that +! +! X(J) = Y(J) for J < I, +! and +! X(I) < Y(I). +! +! In other words, the first time they differ, X is smaller. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 September 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of rows of A, and the length of +! a vector of data. +! +! Input, integer ( kind = 4 ) N, the number of columns of A. +! +! Input/output, integer ( kind = 4 ) A(M,N). +! On input, the array of N columns of M-vectors. +! On output, the columns of A have been sorted in ascending +! lexicographic order. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) i + integer(kind=4) indx + integer(kind=4) isgn + integer(kind=4) j + + if (m <= 0) then + return + end if + + if (n <= 1) then + return + end if +! +! Initialize. +! + i = 0 + indx = 0 + isgn = 0 + j = 0 +! +! Call the external heap sorter. +! + do + + call sort_heap_external(n, indx, i, j, isgn) +! +! Interchange the I and J objects. +! + if (0 < indx) then + + call i4col_swap(m, n, a, i, j) +! +! Compare the I and J objects. +! + else if (indx < 0) then + + call i4col_compare(m, n, a, i, j, isgn) + + else if (indx == 0) then + + exit + + end if + + end do + + return +end +subroutine i4col_sorted_unique_count(m, n, a, unique_num) + +!*****************************************************************************80 +! +!! I4COL_SORTED_UNIQUE_COUNT counts unique elements in an I4COL. +! +! Discussion: +! +! The columns of the array may be ascending or descending sorted. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), a sorted array, containing +! N columns of data. +! +! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) j1 + integer(kind=4) j2 + integer(kind=4) unique_num + + if (n <= 0) then + unique_num = 0 + return + end if + + unique_num = 1 + j1 = 1 + + do j2 = 2, n + + if (any(a(1:m, j1) /= a(1:m, j2))) then + unique_num = unique_num + 1 + j1 = j2 + end if + + end do + + return +end +subroutine i4col_swap(m, n, a, i, j) + +!*****************************************************************************80 +! +!! I4COL_SWAP swaps columns I and J of a integer array of column data. +! +! Example: +! +! Input: +! +! M = 3, N = 4, I = 2, J = 4 +! +! A = ( +! 1 2 3 4 +! 5 6 7 8 +! 9 10 11 12 ) +! +! Output: +! +! A = ( +! 1 4 3 2 +! 5 8 7 6 +! 9 12 11 10 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns in +! the array. +! +! Input/output, integer ( kind = 4 ) A(M,N), an array of N columns of +! length M. +! +! Input, integer ( kind = 4 ) I, J, the columns to be swapped. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) col(m) + integer(kind=4) i + integer(kind=4) j + + if (i < 1 .or. n < i .or. j < 1 .or. n < j) then + + write (*, '(a)') ' ' + write (*, '(a)') 'I4COL_SWAP - Fatal error!' + write (*, '(a)') ' I or J is out of bounds.' + write (*, '(a,i8)') ' I = ', i + write (*, '(a,i8)') ' J = ', j + write (*, '(a,i8)') ' N = ', n + stop 1 + + end if + + if (i == j) then + return + end if + + col(1:m) = a(1:m, i) + a(1:m, i) = a(1:m, j) + a(1:m, j) = col(1:m) + + return +end +subroutine i4mat_print(m, n, a, title) + +!*****************************************************************************80 +! +!! I4MAT_PRINT prints an integer matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 June 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of rows in A. +! +! Input, integer ( kind = 4 ) N, the number of columns in A. +! +! Input, integer ( kind = 4 ) A(M,N), the matrix to be printed. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) ihi + integer(kind=4) ilo + integer(kind=4) jhi + integer(kind=4) jlo + character(len=*) title + + ilo = 1 + ihi = m + jlo = 1 + jhi = n + + call i4mat_print_some(m, n, a, ilo, jlo, ihi, jhi, title) + + return +end +subroutine i4mat_print_some(m, n, a, ilo, jlo, ihi, jhi, title) + +!*****************************************************************************80 +! +!! I4MAT_PRINT_SOME prints some of an I4MAT. +! +! Discussion: +! +! An I4MAT is a rectangular array of I4 values. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 September 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. +! +! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. +! +! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4), parameter :: incx = 10 + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + character(len=8) ctemp(incx) + integer(kind=4) i + integer(kind=4) i2hi + integer(kind=4) i2lo + integer(kind=4) ihi + integer(kind=4) ilo + integer(kind=4) inc + integer(kind=4) j + integer(kind=4) j2 + integer(kind=4) j2hi + integer(kind=4) j2lo + integer(kind=4) jhi + integer(kind=4) jlo + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + + do j2lo = max(jlo, 1), min(jhi, n), incx + + j2hi = j2lo + incx - 1 + j2hi = min(j2hi, n) + j2hi = min(j2hi, jhi) + + inc = j2hi + 1 - j2lo + + write (*, '(a)') ' ' + + do j = j2lo, j2hi + j2 = j + 1 - j2lo + write (ctemp(j2), '(i8)') j + end do + + write (*, '('' Col '',10a8)') ctemp(1:inc) + write (*, '(a)') ' Row' + write (*, '(a)') ' ' + + i2lo = max(ilo, 1) + i2hi = min(ihi, m) + + do i = i2lo, i2hi + + do j2 = 1, inc + + j = j2lo - 1 + j2 + + write (ctemp(j2), '(i8)') a(i, j) + + end do + + write (*, '(i5,a,10a8)') i, ':', (ctemp(j), j=1, inc) + + end do + + end do + + return +end +subroutine i4mat_transpose_print(m, n, a, title) + +!*****************************************************************************80 +! +!! I4MAT_TRANSPOSE_PRINT prints an I4MAT, transposed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + character(len=*) title + + call i4mat_transpose_print_some(m, n, a, 1, 1, m, n, title) + + return +end +subroutine i4mat_transpose_print_some(m, n, a, ilo, jlo, ihi, jhi, title) + +!*****************************************************************************80 +! +!! I4MAT_TRANSPOSE_PRINT_SOME prints some of the transpose of an I4MAT. +! +! Discussion: +! +! An I4MAT is a rectangular array of I4 values. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 September 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. +! +! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. +! +! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4), parameter :: incx = 10 + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + character(len=8) ctemp(incx) + integer(kind=4) i + integer(kind=4) i2 + integer(kind=4) i2hi + integer(kind=4) i2lo + integer(kind=4) ihi + integer(kind=4) ilo + integer(kind=4) inc + integer(kind=4) j + integer(kind=4) j2hi + integer(kind=4) j2lo + integer(kind=4) jhi + integer(kind=4) jlo + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + + do i2lo = max(ilo, 1), min(ihi, m), incx + + i2hi = i2lo + incx - 1 + i2hi = min(i2hi, m) + i2hi = min(i2hi, ihi) + + inc = i2hi + 1 - i2lo + + write (*, '(a)') ' ' + + do i = i2lo, i2hi + i2 = i + 1 - i2lo + write (ctemp(i2), '(i8)') i + end do + + write (*, '('' Row '',10a8)') ctemp(1:inc) + write (*, '(a)') ' Col' + write (*, '(a)') ' ' + + j2lo = max(jlo, 1) + j2hi = min(jhi, n) + + do j = j2lo, j2hi + + do i2 = 1, inc + + i = i2lo - 1 + i2 + + write (ctemp(i2), '(i8)') a(i, j) + + end do + + write (*, '(i5,a,10a8)') j, ':', (ctemp(i), i=1, inc) + + end do + + end do + + return +end +subroutine i4row_compare(m, n, a, i, j, isgn) + +!*****************************************************************************80 +! +!! I4ROW_COMPARE compares two rows of a integer array. +! +! Example: +! +! Input: +! +! M = 3, N = 4, I = 2, J = 3 +! +! A = ( +! 1 2 3 4 +! 5 6 7 8 +! 9 10 11 12 ) +! +! Output: +! +! ISGN = -1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 July 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), an array of M rows of vectors of +! length N. +! +! Input, integer ( kind = 4 ) I, J, the rows to be compared. +! I and J must be between 1 and M. +! +! Output, integer ( kind = 4 ) ISGN, the results of the comparison: +! -1, row I < row J, +! 0, row I = row J, +! +1, row J < row I. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) i + integer(kind=4) isgn + integer(kind=4) j + integer(kind=4) k +! +! Check that I and J are legal. +! + if (i < 1) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' + write (*, '(a)') ' Row index I is less than 1.' + write (*, '(a,i8)') ' I = ', i + stop 1 + else if (m < i) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' + write (*, '(a)') ' Row index I is out of bounds.' + write (*, '(a,i8)') ' I = ', i + write (*, '(a,i8)') ' Maximum legal value is M = ', m + stop 1 + end if + + if (j < 1) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' + write (*, '(a)') ' Row index J is less than 1.' + write (*, '(a,i8)') ' J = ', j + stop 1 + else if (m < j) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4ROW_COMPARE - Fatal error!' + write (*, '(a)') ' Row index J is out of bounds.' + write (*, '(a,i8)') ' J = ', j + write (*, '(a,i8)') ' Maximum legal value is M = ', m + stop 1 + end if + + isgn = 0 + + if (i == j) then + return + end if + + k = 1 + + do while (k <= n) + + if (a(i, k) < a(j, k)) then + isgn = -1 + return + else if (a(j, k) < a(i, k)) then + isgn = +1 + return + end if + + k = k + 1 + + end do + + return +end +subroutine i4row_sort_a(m, n, a) + +!*****************************************************************************80 +! +!! I4ROW_SORT_A ascending sorts the rows of an integer array. +! +! Discussion: +! +! In lexicographic order, the statement "X < Y", applied to two +! vectors X and Y of length M, means that there is some index I, with +! 1 <= I <= M, with the property that +! +! X(J) = Y(J) for J < I, +! and +! X(I) < Y(I). +! +! In other words, X is less than Y if, at the first index where they +! differ, the X value is less than the Y value. +! +! Example: +! +! Input: +! +! M = 5, N = 3 +! +! A = +! 3 2 1 +! 2 4 3 +! 3 1 8 +! 2 4 2 +! 1 9 9 +! +! Output: +! +! A = +! 1 9 9 +! 2 4 2 +! 2 4 3 +! 3 1 8 +! 3 2 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 July 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of rows of A. +! +! Input, integer ( kind = 4 ) N, the number of columns of A. +! +! Input/output, integer ( kind = 4 ) A(M,N). +! On input, the array of M rows of N-vectors. +! On output, the rows of A have been sorted in ascending +! lexicographic order. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) i + integer(kind=4) indx + integer(kind=4) isgn + integer(kind=4) j +! +! Initialize. +! + i = 0 + indx = 0 + isgn = 0 + j = 0 +! +! Call the external heap sorter. +! + do + + call sort_heap_external(m, indx, i, j, isgn) +! +! Interchange the I and J objects. +! + if (0 < indx) then + + call i4row_swap(m, n, a, i, j) +! +! Compare the I and J objects. +! + else if (indx < 0) then + + call i4row_compare(m, n, a, i, j, isgn) + + else if (indx == 0) then + + exit + + end if + + end do + + return +end +subroutine i4row_sorted_unique_count(m, n, a, unique_num) + +!*****************************************************************************80 +! +!! I4ROW_SORTED_UNIQUE_COUNT counts unique elements in an IROW array. +! +! Discussion: +! +! The rows of the array may be ascending or descending sorted. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), a sorted array, containing +! M rows of data. +! +! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique rows. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) i1 + integer(kind=4) i2 + integer(kind=4) unique_num + + if (n <= 0) then + unique_num = 0 + return + end if + + unique_num = 1 + i1 = 1 + + do i2 = 2, m + + if (any(a(i1, 1:n) /= a(i2, 1:n))) then + unique_num = unique_num + 1 + i1 = i2 + end if + + end do + + return +end +subroutine i4row_swap(m, n, a, irow1, irow2) + +!*****************************************************************************80 +! +!! I4ROW_SWAP swaps two rows of an integer array. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input/output, integer ( kind = 4 ) A(M,N), an array of data. +! +! Input, integer ( kind = 4 ) IROW1, IROW2, the two rows to swap. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) a(m, n) + integer(kind=4) irow1 + integer(kind=4) irow2 + integer(kind=4) row(n) +! +! Check. +! + if (irow1 < 1 .or. m < irow1) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4ROW_SWAP - Fatal error!' + write (*, '(a)') ' IROW1 is out of range.' + stop 1 + end if + + if (irow2 < 1 .or. m < irow2) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4ROW_SWAP - Fatal error!' + write (*, '(a)') ' IROW2 is out of range.' + stop 1 + end if + + if (irow1 == irow2) then + return + end if + + row(1:n) = a(irow1, 1:n) + a(irow1, 1:n) = a(irow2, 1:n) + a(irow2, 1:n) = row(1:n) + + return +end +subroutine i4vec_heap_d(n, a) + +!*****************************************************************************80 +! +!! I4VEC_HEAP_D reorders an array of integers into a descending heap. +! +! Discussion: +! +! A descending heap is an array A with the property that, for every index J, +! A(2*J) <= A(J) and A(2*J+1) <= A(J), (as long as the indices +! 2*J and 2*J+1 are legal). +! +! Diagram: +! +! A(1) +! / \ +! A(2) A(3) +! / \ / \ +! A(4) A(5) A(6) A(7) +! / \ / \ +! A(8) A(9) A(10) A(11) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Albert Nijenhuis, Herbert Wilf, +! Combinatorial Algorithms, +! Academic Press, 1978, second edition, +! ISBN 0-12-519260-6. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the size of the input array. +! +! Input/output, integer ( kind = 4 ) A(N). +! On input, an unsorted array. +! On output, the array has been reordered into a heap. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a(n) + integer(kind=4) i + integer(kind=4) ifree + integer(kind=4) key + integer(kind=4) m +! +! Only nodes N/2 down to 1 can be "parent" nodes. +! + do i = n / 2, 1, -1 +! +! Copy the value out of the parent node. +! Position IFREE is now "open". +! + key = a(i) + ifree = i + + do +! +! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position +! IFREE. (One or both may not exist because they exceed N.) +! + m = 2 * ifree +! +! Does the first position exist? +! + if (n < m) then + exit + end if +! +! Does the second position exist? +! + if (m + 1 <= n) then +! +! If both positions exist, take the larger of the two values, +! and update M if necessary. +! + if (a(m) < a(m + 1)) then + m = m + 1 + end if + + end if +! +! If the large descendant is larger than KEY, move it up, +! and update IFREE, the location of the free position, and +! consider the descendants of THIS position. +! + if (a(m) <= key) then + exit + end if + + a(ifree) = a(m) + ifree = m + + end do +! +! Once there is no more shifting to do, KEY moves into the free spot IFREE. +! + a(ifree) = key + + end do + + return +end +subroutine i4vec_indicator(n, a) + +!*****************************************************************************80 +! +!! I4VEC_INDICATOR sets an integer vector to the indicator vector. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 November 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of elements of A. +! +! Output, integer ( kind = 4 ) A(N), the array to be initialized. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a(n) + integer(kind=4) i + + do i = 1, n + a(i) = i + end do + + return +end +function i4vec_lcm(n, v) + +!*****************************************************************************80 +! +!! I4VEC_LCM returns the least common multiple of an I4VEC. +! +! Discussion: +! +! An I4VEC is a vector of I4's. +! +! The value LCM returned has the property that it is the smallest integer +! which is evenly divisible by every element of V. +! +! The entries in V may be negative. +! +! If any entry of V is 0, then LCM is 0. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the order of V. +! +! Input, integer ( kind = 4 ) V(N), the vector. +! +! Output, integer ( kind = 4 ) I4VEC_LCM, the least common multiple of V. +! + implicit none + + integer(kind=4) n + + integer(kind=4) i + integer(kind=4) i4_lcm + integer(kind=4) i4vec_lcm + integer(kind=4) lcm + integer(kind=4) v(n) + + 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 + + return +end +subroutine i4vec_print(n, a, title) + +!*****************************************************************************80 +! +!! I4VEC_PRINT prints an I4VEC. +! +! Discussion: +! +! An I4VEC is a vector of I4's. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 May 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of components of the vector. +! +! Input, integer ( kind = 4 ) A(N), the vector to be printed. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a(n) + integer(kind=4) i + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + write (*, '(a)') ' ' + do i = 1, n + write (*, '(2x,i8,a,2x,i12)') i, ':', a(i) + end do + + return +end +subroutine i4vec_sort_heap_a(n, a) + +!*****************************************************************************80 +! +!! I4VEC_SORT_HEAP_A ascending sorts an integer array using heap sort. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Albert Nijenhuis, Herbert Wilf, +! Combinatorial Algorithms, +! Academic Press, 1978, second edition, +! ISBN 0-12-519260-6. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the array. +! +! Input/output, integer ( kind = 4 ) A(N). +! On input, the array to be sorted; +! On output, the array has been sorted. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a(n) + integer(kind=4) n1 + + if (n <= 1) then + return + end if +! +! 1: Put A into descending heap form. +! + call i4vec_heap_d(n, a) +! +! 2: Sort A. +! +! The largest object in the heap is in A(1). +! Move it to position A(N). +! + call i4_swap(a(1), a(n)) +! +! Consider the diminished heap of size N1. +! + do n1 = n - 1, 2, -1 +! +! Restore the heap structure of A(1) through A(N1). +! + call i4vec_heap_d(n1, a) +! +! Take the largest object from A(1) and move it to A(N1). +! + call i4_swap(a(1), a(n1)) + + end do + + return +end +subroutine i4vec_sorted_unique(n, a, unique_num) + +!*****************************************************************************80 +! +!! I4VEC_SORTED_UNIQUE gets the unique elements in a sorted integer array. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 July 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of elements in A. +! +! Input/output, integer ( kind = 4 ) A(N). On input, the sorted +! integer array. On output, the unique elements in A. +! +! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique elements +! in A. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a(n) + integer(kind=4) itest + integer(kind=4) unique_num + + unique_num = 0 + + if (n <= 0) then + return + end if + + unique_num = 1 + + do itest = 2, n + + if (a(itest) /= a(unique_num)) then + unique_num = unique_num + 1 + a(unique_num) = a(itest) + end if + + end do + + return +end +subroutine i4vec_uniform(n, a, b, seed, x) + +!*****************************************************************************80 +! +!! I4VEC_UNIFORM returns a scaled pseudorandom I4VEC. +! +! Discussion: +! +! An I4VEC is a vector of integer ( kind = 4 ) values. +! +! The pseudorandom numbers should be scaled to be uniformly distributed +! between A and B. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 November 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the vector. +! +! Input, integer ( kind = 4 ) A, B, the limits of the interval. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which +! should NOT be 0. On output, SEED has been updated. +! +! Output, integer ( kind = 4 ) X(N), a vector of numbers between A and B. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a + integer(kind=4) b + integer(kind=4) i + integer(kind=4) k + real(kind=4) r + integer(kind=4) seed + integer(kind=4) value + integer(kind=4) x(n) + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'I4VEC_UNIFORM - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + do i = 1, n + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if + + r = real(seed, kind=4) * 4.656612875E-10 +! +! Scale R to lie between A-0.5 and B+0.5. +! + r = (1.0E+00 - r) * (real(min(a, b), kind=4) - 0.5E+00) & + + r * (real(max(a, b), kind=4) + 0.5E+00) +! +! Use rounding to convert R to an integer between A and B. +! + value = nint(r, kind=4) + + value = max(value, min(a, b)) + value = min(value, max(a, b)) + + x(i) = value + + end do + + return +end +subroutine i4vec2_compare(n, a1, a2, i, j, isgn) + +!*****************************************************************************80 +! +!! I4VEC2_COMPARE compares pairs of integers stored in two vectors. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 October 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of data items. +! +! Input, integer ( kind = 4 ) A1(N), A2(N), contain the two components +! of each item. +! +! Input, integer ( kind = 4 ) I, J, the items to be compared. +! +! Output, integer ( kind = 4 ) ISGN, the results of the comparison: +! -1, item I < item J, +! 0, item I = item J, +! +1, item J < item I. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a1(n) + integer(kind=4) a2(n) + integer(kind=4) i + integer(kind=4) isgn + integer(kind=4) j + + isgn = 0 + + if (a1(i) < a1(j)) then + + isgn = -1 + + else if (a1(i) == a1(j)) then + + if (a2(i) < a2(j)) then + isgn = -1 + else if (a2(i) < a2(j)) then + isgn = 0 + else if (a2(j) < a2(i)) then + isgn = +1 + end if + + else if (a1(j) < a1(i)) then + + isgn = +1 + + end if + + return +end +subroutine i4vec2_sort_a(n, a1, a2) + +!*****************************************************************************80 +! +!! I4VEC2_SORT_A ascending sorts a vector of pairs of integers. +! +! Discussion: +! +! Each item to be sorted is a pair of integers (I,J), with the I +! and J values stored in separate vectors A1 and A2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 June 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of items of data. +! +! Input/output, integer ( kind = 4 ) A1(N), A2(N), the data to be sorted.. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a1(n) + integer(kind=4) a2(n) + integer(kind=4) i + integer(kind=4) indx + integer(kind=4) isgn + integer(kind=4) j +! +! Initialize. +! + i = 0 + indx = 0 + isgn = 0 + j = 0 +! +! Call the external heap sorter. +! + do + + call sort_heap_external(n, indx, i, j, isgn) +! +! Interchange the I and J objects. +! + if (0 < indx) then + + call i4_swap(a1(i), a1(j)) + call i4_swap(a2(i), a2(j)) +! +! Compare the I and J objects. +! + else if (indx < 0) then + + call i4vec2_compare(n, a1, a2, i, j, isgn) + + else if (indx == 0) then + + exit + + end if + + end do + + return +end +subroutine i4vec2_sorted_unique(n, a1, a2, unique_num) + +!*****************************************************************************80 +! +!! I4VEC2_SORTED_UNIQUE gets the unique elements in a sorted I4VEC2. +! +! Discussion: +! +! Item I is stored as the pair A1(I), A2(I). +! +! The items must have been sorted, or at least it must be the +! case that equal items are stored in adjacent vector locations. +! +! If the items were not sorted, then this routine will only +! replace a string of equal values by a single representative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 July 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of items. +! +! Input/output, integer ( kind = 4 ) A1(N), A2(N). +! On input, the array of N items. +! On output, an array of unique items. +! +! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique items. +! + implicit none + + integer(kind=4) n + + integer(kind=4) a1(n) + integer(kind=4) a2(n) + integer(kind=4) itest + integer(kind=4) unique_num + + unique_num = 0 + + if (n <= 0) then + return + end if + + unique_num = 1 + + do itest = 2, n + + if (a1(itest) /= a1(unique_num) .or. a2(itest) /= a2(unique_num)) then + + unique_num = unique_num + 1 + + a1(unique_num) = a1(itest) + a2(unique_num) = a2(itest) + + end if + + end do + + return +end +subroutine icos_shape(point_num, edge_num, face_num, face_order_max, & + point_coord, edge_point, face_order, face_point) + +!*****************************************************************************80 +! +!! ICOS_SHAPE describes an icosahedron. +! +! Discussion: +! +! The input data required for this routine can be retrieved from +! ICOS_SIZE. +! +! The vertices lie on the unit sphere. +! +! The dual of an icosahedron is a dodecahedron. +! +! The data has been rearranged from a previous assignment. +! The STRIPACK program refuses to triangulate data if the first +! three nodes are "collinear" on the sphere. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points (12). +! +! Input, integer ( kind = 4 ) EDGE_NUM, the number of edges (30). +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces (20). +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of +! vertices per face (3). +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. +! +! Output, integer ( kind = 4 ) EDGE_POINT(2,EDGE_NUM), the points that +! make up each edge, listed in ascending order of their indexes. +! +! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices +! per face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The +! points are listed in the counter clockwise direction defined +! by the outward normal at the face. The nodes of each face are ordered +! so that the lowest index occurs first. The faces are then sorted by +! nodes. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4), parameter :: edge_order = 2 + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) point_num + + real(kind=8) a + real(kind=8) b + integer(kind=4) edge_point(edge_order, edge_num) + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) phi + real(kind=8) point_coord(dim_num, point_num) + real(kind=8) z +! +! Set the point coordinates. +! + phi = 0.5D+00 * (sqrt(5.0D+00) + 1.0D+00) + + a = phi / sqrt(1.0D+00 + phi * phi) + b = 1.0D+00 / sqrt(1.0D+00 + phi * phi) + z = 0.0D+00 +! +! A*A + B*B + Z*Z = 1. +! + point_coord(1:dim_num, 1:point_num) = reshape((/ & + a, b, z, & + a, -b, z, & + b, z, a, & + b, z, -a, & + z, a, b, & + z, a, -b, & + z, -a, b, & + z, -a, -b, & + -b, z, a, & + -b, z, -a, & + -a, b, z, & + -a, -b, z/), (/dim_num, point_num/)) +! +! Set the edges. +! + edge_point(1:edge_order, 1:edge_num) = reshape((/ & + 1, 2, & + 1, 3, & + 1, 4, & + 1, 5, & + 1, 6, & + 2, 3, & + 2, 4, & + 2, 7, & + 2, 8, & + 3, 5, & + 3, 7, & + 3, 9, & + 4, 6, & + 4, 8, & + 4, 10, & + 5, 6, & + 5, 9, & + 5, 11, & + 6, 10, & + 6, 11, & + 7, 8, & + 7, 9, & + 7, 12, & + 8, 10, & + 8, 12, & + 9, 11, & + 9, 12, & + 10, 11, & + 10, 12, & + 11, 12/), (/edge_order, edge_num/)) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3/) +! +! Set the faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 1, 2, 4, & + 1, 3, 2, & + 1, 4, 6, & + 1, 5, 3, & + 1, 6, 5, & + 2, 3, 7, & + 2, 7, 8, & + 2, 8, 4, & + 3, 5, 9, & + 3, 9, 7, & + 4, 8, 10, & + 4, 10, 6, & + 5, 6, 11, & + 5, 11, 9, & + 6, 10, 11, & + 7, 9, 12, & + 7, 12, 8, & + 8, 12, 10, & + 9, 11, 12, & + 10, 12, 11/), (/face_order_max, face_num/)) + + return +end +subroutine icos_size(point_num, edge_num, face_num, face_order_max) + +!*****************************************************************************80 +! +!! ICOS_SIZE gives "sizes" for an icosahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 12 + edge_num = 30 + face_num = 20 + face_order_max = 3 + + return +end + +subroutine loc2glob_3d(cospitch, cosroll, cosyaw, sinpitch, sinroll, sinyaw, & + globas, locpts, glopts) + +!*****************************************************************************80 +! +!! LOC2GLOB_3D converts from a local to global coordinate system in 3D. +! +! Discussion: +! +! A global coordinate system is given. +! +! A local coordinate system has been translated to the point with +! global coordinates GLOBAS, and rotated through a yaw, a pitch, and +! a roll. +! +! A point has local coordinates LOCPTS, and it is desired to know +! the point's global coordinates GLOPTS. +! +! The transformation may be written as +! +! GLOB = GLOBAS + N_YAW * N_PITCH * N_ROLL * LOC +! +! where +! +! ( cos(Yaw) -sin(Yaw) 0 ) +! N_YAW = ( sin(Yaw) cos(Yaw) 0 ) +! ( 0 0 1 ) +! +! ( cos(Pitch) 0 sin(Pitch) ) +! N_PITCH = ( 0 1 0 ) +! ( -sin(Pitch) 0 cos(Pitch) ) +! +! ( 1 0 0 ) +! N_ROLL = ( 0 cos(Roll) -sin(Roll) ) +! ( 0 sin(Roll) cos(Roll) ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) COSPITCH, COSROLL, COSYAW, the cosines of the +! pitch, roll and yaw angles. +! +! Input, real ( kind = 8 ) SINPITCH, SINROLL, SINYAW, the sines of the pitch, +! roll and yaw angles. +! +! Input, real ( kind = 8 ) GLOBAS(3), the global coordinates of the base +! vector. +! +! Input, real ( kind = 8 ) LOCPTS(3), the local coordinates of the point. +! +! Output, real ( kind = 8 ) GLOPTS(3), the global coordinates of the point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) cospitch + real(kind=8) cosroll + real(kind=8) cosyaw + real(kind=8) globas(dim_num) + real(kind=8) glopts(dim_num) + real(kind=8) locpts(dim_num) + real(kind=8) sinpitch + real(kind=8) sinroll + real(kind=8) sinyaw + + glopts(1) = globas(1) + (cosyaw * cospitch) * locpts(1) & + + (cosyaw * sinpitch * sinroll - sinyaw * cosroll) * locpts(2) & + + (cosyaw * sinpitch * cosroll + sinyaw * sinroll) * locpts(3) + + glopts(2) = globas(2) + (sinyaw * cospitch) * locpts(1) & + + (sinyaw * sinpitch * sinroll + cosyaw * cosroll) * locpts(2) & + + (sinyaw * sinpitch * cosroll - cosyaw * sinroll) * locpts(3) + + glopts(3) = globas(3) + (-sinpitch) * locpts(1) & + + (cospitch * sinroll) * locpts(2) & + + (cospitch * cosroll) * locpts(3) + + return +end +subroutine l4vec_print(n, a, title) + +!*****************************************************************************80 +! +!! L4VEC_PRINT prints an L4VEC. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of components of the vector. +! +! Input, logical ( kind = 4 ) A(N), the vector to be printed. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4) n + + logical(kind=4) a(n) + integer(kind=4) i + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + write (*, '(a)') ' ' + + do i = 1, n + write (*, '(2x,i8,a,1x,l1)') i, ':', a(i) + end do + + return +end +subroutine minabs(x1, y1, x2, y2, x3, y3, xmin, ymin) + +!*****************************************************************************80 +! +!! MINABS finds a local minimum of F(X) = A * abs ( X ) + B. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 October 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, are three sets of +! data of the form ( X, F(X) ). The three X values must be distinct. +! On output, the data has been sorted so that X1 < X2 < X3, +! and the Y values have been rearranged accordingly. +! +! Output, real ( kind = 8 ) XMIN, YMIN. XMIN is a point within the interval +! spanned by X1, X2 and X3, at which F takes its local minimum +! value YMIN. +! + implicit none + + real(kind=8) slope + real(kind=8) slope12 + real(kind=8) slope13 + real(kind=8) slope23 + real(kind=8) x1 + real(kind=8) x2 + real(kind=8) x3 + real(kind=8) xmin + real(kind=8) y1 + real(kind=8) y2 + real(kind=8) y3 + real(kind=8) ymin +! +! Refuse to deal with coincident data. +! + if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then + write (*, '(a)') ' ' + write (*, '(a)') 'MINABS - Fatal error!' + write (*, '(a)') ' X values are equal.' + stop 1 + end if +! +! Sort the data. +! + if (x2 < x1) then + call r8_swap(x1, x2) + call r8_swap(y1, y2) + end if + + if (x3 < x1) then + call r8_swap(x1, x3) + call r8_swap(y1, y3) + end if + + if (x3 < x2) then + call r8_swap(x2, x3) + call r8_swap(y2, y3) + end if +! +! Now determine the slopes. +! + slope12 = (y2 - y1) / (x2 - x1) + slope23 = (y3 - y2) / (x3 - x2) + slope13 = (y3 - y1) / (x3 - x1) +! +! Case 1: Minimum must be at an endpoint. +! + if (slope13 <= slope12 .or. 0.0D+00 <= slope12) then + + if (y1 < y3) then + xmin = x1 + ymin = y1 + else + xmin = x3 + ymin = y3 + end if +! +! Case 2: The curve decreases, and decreases faster than the line +! joining the endpoints. +! +! Whichever of SLOPE12 and SLOPE23 is the greater in magnitude +! represents the actual slope of the underlying function. +! Find where two lines of that slope, passing through the +! endpoint data, intersect. +! + else + + slope = max(abs(slope12), slope23) + + xmin = 0.5D+00 * (x1 + x3 + (y1 - y3) / slope) + ymin = y1 - slope * (xmin - x1) + + end if + + return +end +subroutine minquad(x1, y1, x2, y2, x3, y3, xmin, ymin) + +!*****************************************************************************80 +! +!! MINQUAD finds a local minimum of F(X) = A * X * X + B * X + C. +! +! Discussion: +! +! MINQUAD is primarily intended as a utility routine. +! The square of the distance function between a point +! and a line segment has the form of F(X). Hence, we can seek +! the line on the second segment which minimizes the square of +! the distance to the other line segment. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 November 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, three sets of data +! of the form ( X, F(X) ). The three X values must be distinct. +! On output, the data has been sorted so that X1 < X2 < X3, +! and the Y values have been rearranged accordingly. +! +! Output, real ( kind = 8 ) XMIN, YMIN. XMIN is a point within the interval +! spanned by X1, X2 and X3, at which F takes its local minimum value YMIN. +! + implicit none + + integer(kind=4) ierror + real(kind=8) x + real(kind=8) x1 + real(kind=8) x2 + real(kind=8) x3 + real(kind=8) xleft + real(kind=8) xmin + real(kind=8) xrite + real(kind=8) y + real(kind=8) y1 + real(kind=8) y2 + real(kind=8) y3 + real(kind=8) ymin +! +! Refuse to deal with coincident data. +! + if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then + write (*, '(a)') ' ' + write (*, '(a)') 'MINQUAD - Fatal error!' + write (*, '(a)') ' X values are equal.' + stop 1 + end if +! +! Find the interval endpoints. +! + xleft = min(x1, x2, x3) + xrite = max(x1, x2, x3) +! +! Find the minimizer and its function value, over the three input points. +! + if (y1 <= y2 .and. y1 <= y3) then + xmin = x1 + ymin = y1 + else if (y2 <= y1 .and. y2 <= y3) then + xmin = x2 + ymin = y2 + else + xmin = x3 + ymin = y3 + end if +! +! Find the minimizer and its function value over the real line. +! + call parabola_ex(x1, y1, x2, y2, x3, y3, x, y, ierror) +! +! If F is linear, then take the already computed min. +! + if (ierror == 2) then +! +! If F has a maximum, then take the already computed min. +! + else if (ymin < y) then +! +! If the minimizer is to the left, take the already computed min. +! + else if (x < xleft) then +! +! If the minimizer is to the right, take the already computed min. +! + else if (xrite < x) then + + else + + xmin = x + ymin = y + + end if + + return +end +subroutine octahedron_shape_3d(point_num, face_num, face_order_max, & + point_coord, face_order, face_point) + +!*****************************************************************************80 +! +!! OCTAHEDRON_SHAPE_3D describes an octahedron in 3D. +! +! Discussion: +! +! The vertices lie on the unit sphere. +! +! The dual of the octahedron is the cube. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 October 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of vertices +! per face. +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the points. +! +! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of +! vertices per face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) is the index of the I-th point in the J-th face. The +! points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) point_num + + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) point_coord(dim_num, point_num) +! +! Set point coordinates. +! + point_coord(1:dim_num, 1:point_num) = reshape((/ & + 0.0D+00, 0.0D+00, -1.0D+00, & + 0.0D+00, -1.0D+00, 0.0D+00, & + 1.0D+00, 0.0D+00, 0.0D+00, & + 0.0D+00, 1.0D+00, 0.0D+00, & + -1.0D+00, 0.0D+00, 0.0D+00, & + 0.0D+00, 0.0D+00, 1.0D+00/), (/dim_num, point_num/)) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 3, 3, 3, 3, 3, 3, 3, 3/) +! +! Set the faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 1, 3, 2, & + 1, 4, 3, & + 1, 5, 4, & + 1, 2, 5, & + 2, 3, 6, & + 3, 4, 6, & + 4, 5, 6, & + 5, 2, 6/), (/face_order_max, face_num/)) + + return +end +subroutine octahedron_size_3d(point_num, edge_num, face_num, face_order_max) + +!*****************************************************************************80 +! +!! OCTAHEDRON_SIZE_3D returns size information for an octahedron in 3D. +! +! Discussion: +! +! This routine can be called before calling OCTAHEDRON_SHAPE_3D, +! so that space can be allocated for the arrays. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of +! vertices per face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 6 + edge_num = 12 + face_num = 8 + face_order_max = 3 + + return +end +subroutine parallelogram_area_2d(p, area) + +!*****************************************************************************80 +! +!! PARALLELOGRAM_AREA_2D computes the area of a parallelogram in 2D. +! +! Discussion: +! +! A parallelogram is a polygon having four sides, with the property +! that each pair of opposite sides is paralell. +! +! Given the first three vertices of the parallelogram, +! P1, P2, and P3, the fourth vertex must satisfy +! +! P4 = P1 + ( P3 - P2 ) +! +! This routine uses the fact that the norm of the cross product +! of two vectors is the area of the parallelogram they form: +! +! Area = ( P3 - P2 ) x ( P1 - P2 ). +! +! P4<-----P3 +! / / +! / / +! P1----->P2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 May 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P(2,4), the parallelogram vertices, +! given in counterclockwise order. The fourth vertex is ignored. +! +! Output, real ( kind = 8 ) AREA, the (signed) area. +! + implicit none + + real(kind=8) area + real(kind=8) p(2, 4) +! +! Compute the cross product vector, which only has a single +! nonzero component. +! + area = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & + - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) + + return +end +subroutine parallelogram_area_3d(p, area) + +!*****************************************************************************80 +! +!! PARALLELOGRAM_AREA_3D computes the area of a parallelogram in 3D. +! +! Discussion: +! +! A parallelogram is a polygon having four sides, with the property +! that each pair of opposite sides is paralell. +! +! A parallelogram in 3D must have the property that it is "really" +! a 2D object, that is, that the four vertices that define it lie +! in some plane. +! +! Given the first three vertices of the parallelogram (in 2D or 3D), +! P1, P2, and P3, the fourth vertex must satisfy +! +! P4 = P1 + ( P3 - P2 ) +! +! This routine uses the fact that the norm of the cross product +! of two vectors is the area of the parallelogram they form: +! +! Area = ( P3 - P2 ) x ( P1 - P2 ). +! +! P4<-----P3 +! / / +! / / +! P1----->P2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 May 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P(3,4), the parallelogram vertices, +! given in counterclockwise order. The fourth vertex is ignored. +! +! Output, real ( kind = 8 ) AREA, the area +! + implicit none + + real(kind=8) area + real(kind=8) cross(3) + real(kind=8) p(3, 4) +! +! Compute the cross product vector. +! + cross(1) = (p(2, 2) - p(2, 1)) * (p(3, 3) - p(3, 1)) & + - (p(3, 2) - p(3, 1)) * (p(2, 3) - p(2, 1)) + + cross(2) = (p(3, 2) - p(3, 1)) * (p(1, 3) - p(1, 1)) & + - (p(1, 2) - p(1, 1)) * (p(3, 3) - p(3, 1)) + + cross(3) = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & + - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) + + area = sqrt(sum(cross(1:3)**2)) + + return +end +function parallelogram_contains_point_2d(p1, p2, p3, p) + +!*****************************************************************************80 +! +!! PARALLELOGRAM_CONTAINS_POINT_2D: is point inside a parallelogram in 2D. +! +! Discussion: +! +! P2.............. +! / . +! / . +! / . +! P1----------->P3 +! +! The algorithm used here essentially computes the barycentric +! coordinates of the point P, and accepts it if both coordinates +! are between 0 and 1. ( For a triangle, they must be positive, +! and sum to no more than 1.) The same trick works for a parallelepiped. +! +! 05 August 2005: Thanks to Gernot Grabmair for pointing out that a previous +! version of this routine was incorrect. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), three corners of the +! parallelogram, with P1 between P2 and P3. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) PARALLELOGRAM_CONTAINS_POINT_2D, +! is TRUE if P is inside the parallelogram. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a(dim_num, dim_num + 1) + integer(kind=4) info + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + logical(kind=4) parallelogram_contains_point_2d +! +! Set up the linear system +! +! ( X2-X1 X3-X1 ) XSI(1) = X-X1 +! ( Y2-Y1 Y3-Y1 ) XSI(2) Y-Y1 +! +! which is satisfied by the barycentric coordinates of P. +! + a(1, 1) = p2(1) - p1(1) + a(1, 2) = p3(1) - p1(1) + a(1, 3) = p(1) - p1(1) + + a(2, 1) = p2(2) - p1(2) + a(2, 2) = p3(2) - p1(2) + a(2, 3) = p(2) - p1(2) +! +! Solve the linear system. +! + call r8mat_solve(dim_num, 1, a, info) + + if (info /= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'PARALLELOGRAM_CONTAINS_CONTAIN_2D - Fatal error!' + write (*, '(a)') ' The linear system is singular.' + write (*, '(a)') ' The input data does not form a proper triangle.' + stop 1 + end if + + if (a(1, 3) < 0.0D+00 .or. 1.0D+00 < a(1, 3)) then + parallelogram_contains_point_2d = .false. + else if (a(2, 3) < 0.0D+00 .or. 1.0D+00 < a(2, 3)) then + parallelogram_contains_point_2d = .false. + else + parallelogram_contains_point_2d = .true. + end if + + return +end +function parallelogram_contains_point_3d(p1, p2, p3, p) + +!*****************************************************************************80 +! +!! PARALLELOGRAM_CONTAINS_POINT_3D: point "inside" parallelogram in 3D. +! +! Discussion: +! +! The parallelogram is a 2-dimensional object in a 3D space. +! For a point to be "inside" the parallelogram, it should +! lie in the plane defined by the sides of the parallelogram, +! and, within that plane, lie inside the parallelogram. +! +! The algorithm constructs an auxilliary point P4, such that +! P4-P1 is normal to P2-P1 and P3-P1. The barycentric coordinates +! of the point P can be used to determine if the point lies in +! the plane, and within the parallelogram. +! +! P2.............. +! / . +! / . +! / . +! P1----------->P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three corners of the +! parallelogram, with P1 between P2 and P3. +! +! Input, real ( kind = 8 ) P(3), the point to be checked. +! +! Output, logical ( kind = 4 ) PARALLELOGRAM_CONTAINS_POINT_3D, +! is TRUE if P is inside the parallelogram, or on its boundary. +! A slight amount of leeway is allowed for error, since a three +! dimensional point may lie exactly in the plane of the parallelogram, +! and yet be computationally slightly outside it. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a(dim_num, dim_num + 1) + real(kind=8) r8vec_norm + integer(kind=4) info + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + logical(kind=4) parallelogram_contains_point_3d + real(kind=8), parameter :: tol = 0.0001D+00 +! +! Turn the triangle into a tetrahedron by computing the normal to +! P2-P1 and P3-P1. +! + call r8vec_cross_product_3d(p2(1:dim_num) - p1(1:dim_num), & + p3(1:dim_num) - p1(1:dim_num), p4) + + p4(1:dim_num) = p4(1:dim_num) / r8vec_norm(dim_num, p4) +! +! Set up the linear system +! +! ( X2-X1 X3-X1 X4-X1 ) XSI(1) = X-X1 +! ( Y2-Y1 Y3-Y1 Y4-Y1 ) XSI(2) Y-Y1 +! ( Z2-Z1 Z3-Z1 Z4-Z1 ) XSI(3) Z-Z1 +! +! which is satisfied by the barycentric coordinates of P. +! + a(1, 1) = p2(1) - p1(1) + a(1, 2) = p3(1) - p1(1) + a(1, 3) = p4(1) - p1(1) + a(1, 4) = p(1) - p1(1) + + a(2, 1) = p2(2) - p1(2) + a(2, 2) = p3(2) - p1(2) + a(2, 3) = p4(2) - p1(2) + a(2, 4) = p(2) - p1(2) + + a(3, 1) = p2(3) - p1(3) + a(3, 2) = p3(3) - p1(3) + a(3, 3) = p4(3) - p1(3) + a(3, 4) = p(3) - p1(3) +! +! Solve the linear system. +! + call r8mat_solve(dim_num, 1, a, info) + + if (info /= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'PARALLELOGRAM_CONTAINS_CONTAIN_3D - Fatal error!' + write (*, '(a)') ' The linear system is singular.' + write (*, '(a)') ' The input data does not form a proper triangle.' + stop 1 + end if + + if (a(1, 4) < 0.0D+00 .or. 1.0D+00 < a(1, 4)) then + parallelogram_contains_point_3d = .false. + else if (a(2, 4) < 0.0D+00 .or. 1.0D+00 < a(2, 4)) then + parallelogram_contains_point_3d = .false. + else if (tol < abs(a(3, 4))) then + parallelogram_contains_point_3d = .false. + else + parallelogram_contains_point_3d = .true. + end if + + return +end +subroutine parallelogram_point_dist_3d(p1, p2, p3, p, dist) + +!*****************************************************************************80 +! +!! PARALLELOGRAM_POINT_DIST_3D: distance ( parallelogram, point ) in 3D. +! +! Discussion: +! +! P2.............. +! / . +! / . +! / . +! P1----------->P3 +! +! Note that we are asking for the distance, in 3D, to a parallelogram, +! which is a 2D object. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three corners of the +! parallelogram, with P1 between P2 and P3. +! +! Input, real ( kind = 8 ) P(3), the point which is to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! parallelogram. DIST is zero if the point lies exactly on the +! parallelogram. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dis13 + real(kind=8) dis21 + real(kind=8) dis34 + real(kind=8) dis42 + real(kind=8) dist + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + logical(kind=4) parallelogram_contains_point_3d + real(kind=8) pn(dim_num) + real(kind=8) pp(dim_num) + real(kind=8) t + real(kind=8) temp +! +! Compute PP, the unit normal to X2-X1 and X3-X1: +! + pp(1) = (p2(2) - p1(2)) * (p3(3) - p1(3)) & + - (p2(3) - p1(3)) * (p3(2) - p1(2)) + pp(2) = (p2(3) - p1(3)) * (p3(1) - p1(1)) & + - (p2(1) - p1(1)) * (p3(3) - p1(3)) + pp(3) = (p2(1) - p1(1)) * (p3(2) - p1(2)) & + - (p2(2) - p1(2)) * (p3(1) - p1(1)) + + temp = sqrt(sum(pp(1:dim_num)**2)) + + if (temp == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PARALLELOGRAM_POINT_DIST_3D - Fatal error!' + write (*, '(a)') ' The normal vector is zero.' + stop 1 + end if + + pp(1:dim_num) = pp(1:dim_num) / temp +! +! Find PN, the nearest point to P in the plane. +! + t = dot_product(pp(1:dim_num), p(1:dim_num) - p1(1:dim_num)) + + pn(1:dim_num) = p(1:dim_num) - pp(1:dim_num) * t +! +! If P lies WITHIN the parallelogram, we're done. +! + inside = parallelogram_contains_point_3d(p1, p2, p3, p) + + if (inside) then + dist = sqrt(sum((pn(1:dim_num) - p(1:dim_num))**2)) + return + end if +! +! Otherwise, find the distance between P and each of the +! four line segments that make up the boundary of the parallelogram. +! + p4(1:dim_num) = p2(1:dim_num) + p3(1:dim_num) - p1(1:dim_num) + + call segment_point_dist_3d(p1, p3, p, dis13) + call segment_point_dist_3d(p3, p4, p, dis34) + call segment_point_dist_3d(p4, p2, p, dis42) + call segment_point_dist_3d(p2, p1, p, dis21) + + dist = min(dis13, dis34, dis42, dis21) + + return +end +subroutine parabola_ex(x1, y1, x2, y2, x3, y3, x, y, ierror) + +!*****************************************************************************80 +! +!! PARABOLA_EX: extremal point of a parabola determined by three points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 November 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, the coordinates of +! three points on the parabola. X1, X2 and X3 must be distinct. +! +! Output, real ( kind = 8 ) X, Y, the X coordinate of the extremal point +! of the parabola, and the value of the parabola at that point. +! +! Output, integer ( kind = 4 ) IERROR, error flag. +! 0, no error. +! 1, two of the X values are equal. +! 2, the data lies on a straight line; there is no finite extremal point. +! + implicit none + + real(kind=8) bot + integer(kind=4) ierror + real(kind=8) x + real(kind=8) x1 + real(kind=8) x2 + real(kind=8) x3 + real(kind=8) y + real(kind=8) y1 + real(kind=8) y2 + real(kind=8) y3 + + ierror = 0 + + if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then + ierror = 1 + return + end if + + if (y1 == y2 .and. y2 == y3 .and. y3 == y1) then + x = x1 + y = y1 + return + end if + + bot = (x2 - x3) * y1 - (x1 - x3) * y2 + (x1 - x2) * y3 + + if (bot == 0.0D+00) then + ierror = 2 + return + end if + + x = 0.5D+00 * (x1 * x1 * (y3 - y2) & + + x2 * x2 * (y1 - y3) & + + x3 * x3 * (y2 - y1)) / bot + + y = ((x - x2) * (x - x3) * (x2 - x3) * y1 & + - (x - x1) * (x - x3) * (x1 - x3) * y2 & + + (x - x1) * (x - x2) * (x1 - x2) * y3) / & + ((x1 - x2) * (x2 - x3) * (x1 - x3)) + + return +end +subroutine parabola_ex2(x1, y1, x2, y2, x3, y3, x, y, a, b, c, ierror) + +!*****************************************************************************80 +! +!! PARABOLA_EX2: extremal point of a parabola determined by three points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 October 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, the coordinates of +! three points on the parabola. X1, X2 and X3 must be distinct. +! +! Output, real ( kind = 8 ) X, Y, the X coordinate of the extremal point +! of the parabola, and the value of the parabola at that point. +! +! Output, real ( kind = 8 ) A, B, C, the coefficients that define the +! parabola: P(X) = A * X * X + B * X + C. +! +! Output, integer ( kind = 4 ) IERROR, error flag. +! 0, no error. +! 1, two of the X values are equal. +! 2, the data lies on a straight line; there is no finite extremal +! point. +! + implicit none + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) det + integer(kind=4) ierror + real(kind=8) v(3, 3) + real(kind=8) w(3, 3) + real(kind=8) x + real(kind=8) x1 + real(kind=8) x2 + real(kind=8) x3 + real(kind=8) y + real(kind=8) y1 + real(kind=8) y2 + real(kind=8) y3 + + ierror = 0 + + if (x1 == x2 .or. x2 == x3 .or. x3 == x1) then + ierror = 1 + return + end if + + if (y1 == y2 .and. y2 == y3 .and. y3 == y1) then + x = x1 + y = y1 + return + end if +! +! Set up the Vandermonde matrix. +! + v(1, 1) = 1.0D+00 + v(1, 2) = x1 + v(1, 3) = x1 * x1 + + v(2, 1) = 1.0D+00 + v(2, 2) = x2 + v(2, 3) = x2 * x2 + + v(3, 1) = 1.0D+00 + v(3, 2) = x3 + v(3, 3) = x3 * x3 +! +! Get the inverse. +! + call r8mat_inverse_3d(v, w, det) +! +! Compute the parabolic coefficients. +! + c = w(1, 1) * y1 + w(1, 2) * y2 + w(1, 3) * y3 + b = w(2, 1) * y1 + w(2, 2) * y2 + w(2, 3) * y3 + a = w(3, 1) * y1 + w(3, 2) * y2 + w(3, 3) * y3 +! +! Determine the extremal point. +! + if (a == 0.0D+00) then + ierror = 2 + return + end if + + x = -b / (2.0D+00 * a) + y = a * x * x + b * x + c + + return +end +function parallelepiped_contains_point_3d(p1, p2, p3, p4, p) + +!*****************************************************************************80 +! +!! PARALLELEPIPED_CONTAINS_POINT_3D: point inside parallelepiped in 3D. +! +! Discussion: +! +! A parallelepiped is a "slanted box", that is, opposite +! sides are parallel planes. +! +! *------------------* +! / . / \ +! / . / \ +! / . / \ +! P4------------------* \ +! \ . \ \ +! \ . \ \ +! \ . \ \ +! \ P2.........\.......\ +! \ . \ / +! \ . \ / +! \ . \ / +! P1-----------------P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), four corners +! of the parallelepiped. It is assumed that P2, P3 and P4 are +! immediate neighbors of P1. +! +! Input, real ( kind = 8 ) P(3), the point to be checked. +! +! Output, logical ( kind = 4 ) PARALLELEPIPED_CONTAINS_POINT_3D, +! is true if P is inside the parallelepiped, or on its boundary. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dot + logical(kind=4) parallelepiped_contains_point_3d + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + + parallelepiped_contains_point_3d = .false. + + dot = dot_product(p(1:dim_num) - p1(1:dim_num), & + p2(1:dim_num) - p1(1:dim_num)) + + if (dot < 0.0D+00) then + return + end if + + if (sum((p2(1:dim_num) - p1(1:dim_num))**2) < dot) then + return + end if + + dot = dot_product(p(1:dim_num) - p1(1:dim_num), & + p3(1:dim_num) - p1(1:dim_num)) + + if (dot < 0.0D+00) then + return + end if + + if (sum((p3(1:dim_num) - p1(1:dim_num))**2) < dot) then + return + end if + + dot = dot_product(p(1:dim_num) - p1(1:dim_num), & + p4(1:dim_num) - p1(1:dim_num)) + + if (dot < 0.0D+00) then + return + end if + + if (sum((p4(1:dim_num) - p1(1:dim_num))**2) < dot) then + return + end if + + parallelepiped_contains_point_3d = .true. + + return +end +subroutine parallelepiped_point_dist_3d(p1, p2, p3, p4, p, dist) + +!*****************************************************************************80 +! +!! PARALLELEPIPED_POINT_DIST_3D: distance ( parallelepiped, point ) in 3D. +! +! Discussion: +! +! A parallelepiped is a "slanted box", that is, opposite +! sides are parallel planes. +! +! *------------------* +! / . / \ +! / . / \ +! / . / \ +! P4------------------* \ +! \ . \ \ +! \ . \ \ +! \ . \ \ +! \ P2.........\.......\ +! \ . \ / +! \ . \ / +! \ . \ / +! P1-----------------P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), +! half of the corners of the box, from which the other corners can be +! deduced. The corners should be chosen so that the first corner +! is directly connected to the other three. The locations of +! corners 5, 6, 7 and 8 will be computed by the parallelogram +! relation. +! +! Input, real ( kind = 8 ) P(3), the point which is to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the box. +! DIST is zero if the point lies exactly on the box. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dis + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + real(kind=8) p5(dim_num) + real(kind=8) p6(dim_num) + real(kind=8) p7(dim_num) + real(kind=8) p8(dim_num) +! +! Fill in the other corners +! + p5(1:dim_num) = p2(1:dim_num) + p3(1:dim_num) - p1(1:dim_num) + p6(1:dim_num) = p2(1:dim_num) + p4(1:dim_num) - p1(1:dim_num) + p7(1:dim_num) = p3(1:dim_num) + p4(1:dim_num) - p1(1:dim_num) + p8(1:dim_num) = p2(1:dim_num) + p3(1:dim_num) + p4(1:dim_num) & + - 2.0D+00 * p1(1:dim_num) +! +! Compute the distance from the point P to each of the six +! parallelogram faces. +! + call parallelogram_point_dist_3d(p1, p2, p3, p, dis) + + dist = dis + + call parallelogram_point_dist_3d(p1, p2, p4, p, dis) + + dist = min(dist, dis) + + call parallelogram_point_dist_3d(p1, p3, p4, p, dis) + + dist = min(dist, dis) + + call parallelogram_point_dist_3d(p8, p5, p6, p, dis) + + dist = min(dist, dis) + + call parallelogram_point_dist_3d(p8, p5, p7, p, dis) + + dist = min(dist, dis) + + call parallelogram_point_dist_3d(p8, p6, p7, p, dis) + + dist = min(dist, dis) + + return +end +subroutine perm_inverse(n, p) + +!*****************************************************************************80 +! +!! PERM_INVERSE inverts a permutation "in place". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 July 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of objects being permuted. +! +! Input/output, integer ( kind = 4 ) P(N), the permutation, in standard +! index form. On output, P describes the inverse permutation +! + implicit none + + integer(kind=4) n + + integer(kind=4) i + integer(kind=4) i0 + integer(kind=4) i1 + integer(kind=4) i2 + integer(kind=4) is + integer(kind=4) p(n) + + if (n <= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'PERM_INVERSE - Fatal error!' + write (*, '(a,i8)') ' Input value of N = ', n + stop 1 + end if + + is = 1 + + do i = 1, n + + i1 = p(i) + + do while (i < i1) + i2 = p(i1) + p(i1) = -i2 + i1 = i2 + end do + + is = -sign(1, p(i)) + p(i) = sign(p(i), is) + + end do + + do i = 1, n + + i1 = -p(i) + + if (0 <= i1) then + + i0 = i + + do + + i2 = p(i1) + p(i1) = i0 + + if (i2 < 0) then + exit + end if + + i0 = i1 + i1 = i2 + + end do + + end if + + end do + + return +end +subroutine plane_exp_grid_3d(p1, p2, p3, ncor3, line_num, cor3, lines, & + maxcor3, line_max, ierror) + +!*****************************************************************************80 +! +!! PLANE_EXP_GRID_3D computes points and lines making up a planar grid in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is: +! +! the plane through P1, P2 and P3. +! +! The data format used is that of SGI Inventor. +! +! On input, if NCOR3 is zero (or negative), then the data computed by +! this routine will be stored normally in COR3. But if NCOR3 is +! positive, it is assumed that COR3 already contains NCOR3 items +! of useful data. The new data is appended to COR3. On output, NCOR3 +! is increased by the number of points computed by this routine. +! +! On input, if LINE_NUM is zero (or negative), then the data computed by +! this routine will be stored normally in LINES. But if LINE_NUM is +! positive, it is assumed that LINES already contains some useful data. The +! new data is appended to LINES. On output, LINE_NUM is increased by the +! number of lines computed by this routine. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 October 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Input/output, integer ( kind = 4 ) NCOR3, the number of points stored +! in COR3. +! +! Input/output, integer ( kind = 4 ) LINE_NUM, the number of line data items. +! +! Input/output, real ( kind = 8 ) COR3(3,MAXCOR3), the grid points. +! +! Input/output, integer ( kind = 4 ) LINES(LINE_MAX), the indices of +! points used in the lines of the grid. Successive entries of LINES are +! joined by a line, unless an entry equals -1. Note that indices begin +! with 0. +! +! Input, integer ( kind = 4 ) MAXCOR3, the maximum number of points. +! +! Input, integer ( kind = 4 ) LINE_MAX, the maximum number of lines. +! +! Output, integer ( kind = 4 ) IERROR, error indicator. +! 0, no error. +! 1, more space for point coordinates is needed. +! 2, more space for line data is needed. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) maxcor3 + integer(kind=4) line_max + + real(kind=8) a + real(kind=8) amax + real(kind=8) amin + real(kind=8) b + real(kind=8) bmax + real(kind=8) bmin + real(kind=8) cor3(dim_num, maxcor3) + real(kind=8) dot + integer(kind=4) i + integer(kind=4) ierror + integer(kind=4) j + integer(kind=4) line_num + integer(kind=4) lines(line_max) + integer(kind=4) nbase + integer(kind=4) ncor3 + integer(kind=4), parameter :: nx = 5 + integer(kind=4), parameter :: ny = 5 + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) + + ierror = 0 + + if (ncor3 <= 0) then + ncor3 = 0 + end if + + if (line_num <= 0) then + line_num = 0 + end if + + nbase = ncor3 +! +! Compute the two basis vectors for the affine plane. +! + v1(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + + call vector_unit_nd(dim_num, v1) + + v2(1:dim_num) = p3(1:dim_num) - p1(1:dim_num) + + dot = dot_product(v1(1:dim_num), v2(1:dim_num)) +! +! Remove the component of V1 from V2, and give the +! resulting vector unit norm. V1 and V2 are now orthogonal +! and of unit length, and represent the two direction vectors +! of our plane. +! + v2(1:dim_num) = v2(1:dim_num) - dot * v1(1:dim_num) + + call vector_unit_nd(dim_num, v2) +! +! Compute the (V1,V2) coordinate range of the input data, if any. +! + if (ncor3 == 0) then + + amin = 0.0D+00 + amax = 1.0D+00 + bmin = 0.0D+00 + bmax = 1.0D+00 + + else + + do i = 1, ncor3 + + a = dot_product(v1(1:dim_num), cor3(1:dim_num, i)) + b = dot_product(v2(1:dim_num), cor3(1:dim_num, i)) + + if (i == 1) then + amin = a + amax = a + bmin = b + bmax = b + else + amin = min(amin, a) + amax = max(amax, a) + bmin = min(bmin, b) + bmax = max(bmax, b) + end if + + end do + + end if +! +! Generate the points we will use. +! + if (maxcor3 < ncor3 + nx * ny) then + ierror = 1 + return + end if + + do j = 1, ny + + b = (real(ny - j, kind=8) * bmin & + + real(j - 1, kind=8) * bmax) & + / real(ny - 1, kind=8) + + do i = 1, nx + + a = (real(nx - i, kind=8) * amin & + + real(i - 1, kind=8) * amax) & + / real(nx - 1, kind=8) + + ncor3 = ncor3 + 1 + cor3(1:dim_num, ncor3) = a * v1(1:dim_num) + b * v2(1:dim_num) + + end do + + end do +! +! Do the "horizontals". +! + do i = 1, nx + + do j = 1, ny + + if (line_max <= line_num) then + ierror = 2 + return + end if + + line_num = line_num + 1 + lines(line_num) = nbase + (j - 1) * nx + i + + end do + + if (line_max <= line_num) then + ierror = 2 + return + end if + + line_num = line_num + 1 + lines(line_num) = 0 + + end do +! +! Do the "verticals". +! + do j = 1, ny + + do i = 1, nx + + if (line_max <= line_num) then + ierror = 2 + return + end if + + line_num = line_num + 1 + lines(line_num) = nbase + (j - 1) * nx + i + + end do + + if (line_max <= line_num) then + ierror = 2 + return + end if + + line_num = line_num + 1 + lines(line_num) = 0 + + end do + + return +end +subroutine plane_exp_normal_3d(p1, p2, p3, normal) + +!*****************************************************************************80 +! +!! PLANE_EXP_NORMAL_3D finds the normal to an explicit plane in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is +! +! the plane through P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Output, real ( kind = 8 ) NORMAL(3), the coordinates of the unit normal +! vector to the plane containing the three points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) normal(dim_num) + real(kind=8) normal_norm + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) +! +! The cross product (P2-P1) x (P3-P1) is normal to (P2-P1) and (P3-P1). +! + normal(1) = (p2(2) - p1(2)) * (p3(3) - p1(3)) & + - (p2(3) - p1(3)) * (p3(2) - p1(2)) + + normal(2) = (p2(3) - p1(3)) * (p3(1) - p1(1)) & + - (p2(1) - p1(1)) * (p3(3) - p1(3)) + + normal(3) = (p2(1) - p1(1)) * (p3(2) - p1(2)) & + - (p2(2) - p1(2)) * (p3(1) - p1(1)) + + normal_norm = sqrt(sum(normal(1:dim_num)**2)) + + if (normal_norm == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_EXP_NORMAL_3D - Fatal error!' + write (*, '(a)') ' The plane is poorly defined.' + stop 1 + end if + + normal(1:dim_num) = normal(1:dim_num) / normal_norm + + return +end +subroutine plane_exp_point_dist_3d(p1, p2, p3, p, dist) + +!*****************************************************************************80 +! +!! PLANE_EXP_POINT_DIST_3D: distance ( explicit plane, point ) in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is +! +! the plane through P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Input, real ( kind = 8 ) P(3), the coordinates of the point. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + + call plane_exp2imp_3d(p1, p2, p3, a, b, c, d) + + call plane_imp_point_dist_3d(a, b, c, d, p, dist) + + return +end +subroutine plane_exp_pro2(p1, p2, p3, n, p, pp) + +!*****************************************************************************80 +! +!! PLANE_EXP_PRO2 produces 2D coordinates of points that lie in a plane, in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is: +! +! the plane through P1, P2 and P3. +! +! The first thing to do is to compute two orthonormal vectors V1 and +! V2, so that any point P that lies in the plane may be written as +! +! P = P1 + alpha * V1 + beta * V2 +! +! The vector V1 lies in the direction P2-P1, and V2 lies in +! the plane, is orthonormal to V1, and has a positive component +! in the direction of P3-P1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Input, integer ( kind = 4 ) N, the number of points to project. +! +! Input, real ( kind = 8 ) P(3,N), are the Cartesian +! coordinates of points which lie on the plane spanned by the +! three points. These points are not checked to ensure that +! they lie on the plane. +! +! Output, real ( kind = 8 ) PP(2,N), the "in-plane" +! coordinates of the points. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dot + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pp(2, dim_num) + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) +! +! Compute the two basis vectors for the affine plane. +! + v1(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + + call vector_unit_nd(dim_num, v1) + + v2(1:dim_num) = p3(1:dim_num) - p1(1:dim_num) + + dot = dot_product(v1(1:dim_num), v2(1:dim_num)) + + v2(1:dim_num) = v2(1:dim_num) - dot * v1(1:dim_num) + + call vector_unit_nd(dim_num, v2) +! +! Now decompose each point. +! + do i = 1, n + pp(1, i) = dot_product(p(1:dim_num, i) - p1(1:dim_num), v1(1:dim_num)) + pp(2, i) = dot_product(p(1:dim_num, i) - p2(1:dim_num), v2(1:dim_num)) + end do + + return +end +subroutine plane_exp_pro3(p1, p2, p3, n, p, pp) + +!*****************************************************************************80 +! +!! PLANE_EXP_PRO3 projects points orthographically onto a plane, in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is: +! +! the plane through P1, P2 and P3. +! +! PP may share the same memory as PO, in +! which case the projections will overwrite the original data. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Input, integer ( kind = 4 ) N, the number of points to project. +! +! Input, real ( kind = 8 ) P(3,N), the points. +! +! Output, real ( kind = 8 ) PP(3,N), the projections of the points through +! the focus point onto the plane. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pp(dim_num, n) +! +! Put the plane into ABCD form. +! + call plane_exp2imp_3d(p1, p2, p3, a, b, c, d) +! +! For each point, its image in the plane is the nearest point +! in the plane. +! + do i = 1, n + + call plane_imp_point_near_3d(a, b, c, d, p(1:dim_num, i), pp(1:dim_num, i)) + + end do + + return +end +subroutine plane_exp_project_3d(p1, p2, p3, pf, n, po, pp, ivis) + +!*****************************************************************************80 +! +!! PLANE_EXP_PROJECT_3D projects points through a point onto a plane in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is +! +! the plane through P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Input, real ( kind = 8 ) PF(3), the focus point. +! +! Input, integer ( kind = 4 ) N, the number of points to project. +! +! Input, real ( kind = 8 ) PO(3,N), the object points. +! +! Output, real ( kind = 8 ) PP(3,N), are the +! coordinates of the projections of the object points through the focus +! point onto the plane. PP may share the same memory as PO, +! in which case the projections will overwrite the original data. +! +! Output, integer ( kind = 4 ) IVIS(N), visibility indicator: +! 3, the object was behind the plane; +! 2, the object was already on the plane; +! 1, the object was between the focus and the plane; +! 0, the line from the object to the focus is parallel to the plane, +! so the object is "invisible". +! -1, the focus is between the object and the plane. The object +! might be considered invisible. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) alpha + real(kind=8) angle_rad_3d + real(kind=8) b + real(kind=8) beta + real(kind=8) c + real(kind=8) d + real(kind=8) disfo + real(kind=8) disfn + integer(kind=4) i + integer(kind=4) ivis(n) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pf(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) po(dim_num, n) + real(kind=8) pp(dim_num, n) +! +! Put the plane into ABCD form. +! + call plane_exp2imp_3d(p1, p2, p3, a, b, c, d) +! +! Get the nearest point on the plane to the focus. +! + call plane_imp_point_near_3d(a, b, c, d, pf, pn) +! +! Get the distance from the focus to the plane. +! + disfn = sqrt(sum((pf(1:dim_num) - pn(1:dim_num))**2)) +! +! If the focus lies in the plane, this is bad. We could still +! project points that actually lie in the plane, but we'll +! just bail out. +! + if (disfn == 0.0D+00) then + ivis(1:n) = 0 + do i = 1, dim_num + pp(i, 1:n) = pf(i) + end do + return + end if +! +! Process the points. +! + do i = 1, n +! +! Get the distance from the focus to the object. +! + disfo = sqrt(sum((po(1:dim_num, i) - pf(1:dim_num))**2)) + + if (disfo == 0.0D+00) then + + ivis(i) = 0 + pp(1:dim_num, i) = pn(1:dim_num) + + else +! +! Compute ALPHA, the angle between (objECT-FOCUS) and (NEAREST-FOCUS). +! + alpha = angle_rad_3d(po(1:3, i), pf(1:3), pn(1:3)) + + if (cos(alpha) == 0.0D+00) then + + ivis(i) = 0 + pp(1:dim_num, i) = pn(1:dim_num) + + else +! +! BETA is Dist(NEAREST-FOCUS) / ( Cos(ALPHA)*Dist(objECT-FOCUS) ) +! + beta = disfn / (cos(alpha) * disfo) + + if (1.0D+00 < beta) then + ivis(i) = 1 + else if (beta == 1.0D+00) then + ivis(i) = 2 + else if (0.0D+00 < beta) then + ivis(i) = 3 + else + ivis(i) = -1 + end if +! +! Set the projected point. +! + pp(1:dim_num, i) = pf(1:dim_num) & + + beta * (po(1:dim_num, i) - pf(1:dim_num)) + + end if + + end if + + end do + + return +end +subroutine plane_exp2imp_3d(p1, p2, p3, a, b, c, d) + +!*****************************************************************************80 +! +!! PLANE_EXP2IMP_3D converts an explicit plane to implicit form in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is +! +! the plane through P1, P2 and P3. +! +! The implicit form of a plane in 3D is +! +! A * X + B * Y + C * Z + D = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 February 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Output, real ( kind = 8 ) A, B, C, D, coefficients which describe +! the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + + a = (p2(2) - p1(2)) * (p3(3) - p1(3)) & + - (p2(3) - p1(3)) * (p3(2) - p1(2)) + + b = (p2(3) - p1(3)) * (p3(1) - p1(1)) & + - (p2(1) - p1(1)) * (p3(3) - p1(3)) + + c = (p2(1) - p1(1)) * (p3(2) - p1(2)) & + - (p2(2) - p1(2)) * (p3(1) - p1(1)) + + d = -p2(1) * a - p2(2) * b - p2(3) * c + + return +end +subroutine plane_exp2normal_3d(p1, p2, p3, pp, normal) + +!*****************************************************************************80 +! +!! PLANE_EXP2NORMAL_3D converts an explicit plane to normal form in 3D. +! +! Discussion: +! +! The explicit form of a plane in 3D is +! +! the plane through P1, P2 and P3. +! +! The normal form of a plane in 3D is +! +! PP, a point on the plane, and +! N, the unit normal to the plane. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! +! Output, real ( kind = 8 ) PP(3), a point on the plane. +! +! Output, real ( kind = 8 ) NORMAL(3), a unit normal vector to the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) norm + real(kind=8) normal(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pp(dim_num) + + pp(1:dim_num) = p1(1:dim_num) + + normal(1) = (p2(2) - p1(2)) * (p3(3) - p1(3)) & + - (p2(3) - p1(3)) * (p3(2) - p1(2)) + + normal(2) = (p2(3) - p1(3)) * (p3(1) - p1(1)) & + - (p2(1) - p1(1)) * (p3(3) - p1(3)) + + normal(3) = (p2(1) - p1(1)) * (p3(2) - p1(2)) & + - (p2(2) - p1(2)) * (p3(1) - p1(1)) + + norm = sqrt(sum(normal(1:dim_num)**2)) + + if (norm == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_EXP2NORMAL_3D - Fatal error!' + write (*, '(a)') ' The normal vector is null.' + write (*, '(a)') ' Two points coincide, or nearly so.' + stop 1 + end if + + normal(1:dim_num) = normal(1:dim_num) / norm + + return +end +function plane_imp_is_degenerate_3d(a, b, c) + +!*****************************************************************************80 +! +!! PLANE_IMP_IS_DEGENERATE_3D is TRUE if an implicit plane is degenerate. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! The implicit plane is degenerate if A = B = C = 0. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, the implicit plane parameters. +! +! Output, logical ( kind = 4 ) PLANE_IMP_IS_DEGENERATE_3D, +! is TRUE if the plane is degenerate. +! + implicit none + + real(kind=8) a + real(kind=8) b + real(kind=8) c + logical(kind=4) plane_imp_is_degenerate_3d + + if (a == 0.0D+00 .and. b == 0.0D+00 .and. c == 0.0D+00) then + plane_imp_is_degenerate_3d = .true. + else + plane_imp_is_degenerate_3d = .false. + end if + + return +end +subroutine plane_imp_line_par_int_3d(a, b, c, d, x0, y0, z0, f, g, h, & + intersect, p) + +!*****************************************************************************80 +! +!! PLANE_IMP_LINE_PAR_INT_3D: intersection ( impl plane, param line ) in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! The parametric form of a line in 3D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! Z = Z0 + H * T +! +! We normalize by always choosing F*F + G*G + H*H = 1, +! and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420, +! page 111. +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Input, real ( kind = 8 ) X0, Y0, Z0, F, G, H, parameters that define the +! parametric line. +! +! Output, logical ( kind = 4 ) INTERSECT, is TRUE if the line and the plane +! intersect. +! +! Output, real ( kind = 8 ) P(3), is a point of intersection of the line +! and the plane, if INTERSECT is TRUE. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) denom + real(kind=8) f + real(kind=8) g + real(kind=8) h + logical(kind=4) intersect + real(kind=8) norm1 + real(kind=8) norm2 + real(kind=8) p(dim_num) + real(kind=8) t + real(kind=8), parameter :: tol = 0.00001D+00 + real(kind=8) x0 + real(kind=8) y0 + real(kind=8) z0 +! +! Check. +! + norm1 = sqrt(a * a + b * b + c * c) + + if (norm1 == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP_LINE_PAR_INT_3D - Fatal error!' + write (*, '(a)') ' The plane normal vector is null.' + stop 1 + end if + + norm2 = sqrt(f * f + g * g + h * h) + + if (norm2 == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP_LINE_PAR_INT_3D - Fatal error!' + write (*, '(a)') ' The line direction vector is null.' + stop 1 + end if + + denom = a * f + b * g + c * h +! +! The line and the plane may be parallel. +! + if (abs(denom) < tol * norm1 * norm2) then + + if (a * x0 + b * y0 + c * z0 + d == 0.0D+00) then + intersect = .true. + p(1) = x0 + p(2) = y0 + p(3) = z0 + else + intersect = .false. + p(1:dim_num) = 0.0D+00 + end if +! +! If they are not parallel, they must intersect. +! + else + + intersect = .true. + t = -(a * x0 + b * y0 + c * z0 + d) / denom + p(1) = x0 + t * f + p(2) = y0 + t * g + p(3) = z0 + t * h + + end if + + return +end +subroutine plane_imp_point_dist_3d(a, b, c, d, p, dist) + +!*****************************************************************************80 +! +!! PLANE_IMP_POINT_DIST_3D: distance ( implicit plane, point ) in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Input, real ( kind = 8 ) P(3), the coordinates of the point. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) dist + real(kind=8) norm + real(kind=8) p(dim_num) + + norm = sqrt(a * a + b * b + c * c) + + if (norm == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP_POINT_DIST_3D - Fatal error!' + write (*, '(a)') ' The plane normal vector is null.' + stop 1 + end if + + dist = abs(a * p(1) + b * p(2) + c * p(3) + d) / norm + + return +end +subroutine plane_imp_point_dist_signed_3d(a, b, c, d, p, dist_signed) + +!*****************************************************************************80 +! +!! PLANE_IMP_POINT_DIST_SIGNED_3D: signed distance ( imp plane, point) in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Priamos Georgiades, +! Signed Distance From Point To Plane, +! in Graphics Gems III, +! edited by David Kirk, +! Academic Press, 1992, pages 233-235, T385.G6973. +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Input, real ( kind = 8 ) P(3), the coordinates of the point. +! +! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from +! the point to the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) dist_signed + real(kind=8) norm + real(kind=8) p(dim_num) + + norm = sqrt(a * a + b * b + c * c) + + if (norm == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP_POINT_DIST_SIGNED_3D - Fatal error!' + write (*, '(a)') ' The plane normal vector is null.' + stop 1 + end if + + dist_signed = -sign(1.0D+00, d) & + * (a * p(1) + b * p(2) + c * p(3) + d) / norm + + return +end +subroutine plane_imp_point_near_3d(a, b, c, d, p, pn) + +!*****************************************************************************80 +! +!! PLANE_IMP_POINT_NEAR_3D: nearest point on a implicit plane to a point in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! A normal vector to the plane is (A,B,C). +! +! The line defined by (XN-P(1))/A = (YN-P(2))/B = (ZN-P(3))/C = T +! goes through P and is parallel to N. +! +! Solving for the point (XN,YN,ZN) we get +! +! XN = A*T+P(1) +! YN = B*T+P(2) +! ZN = C*T+P(3) +! +! Now place these values in the equation for the plane: +! +! A*(A*T+P(1)) + B*(B*T+P(2)) + C*(C*T+P(3)) + D = 0 +! +! and solve for T: +! +! T = (-A*P(1)-B*P(2)-C*P(3)-D) / (A * A + B * B + C * C ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Input, real ( kind = 8 ) P(3), the coordinates of the point. +! +! Output, real ( kind = 8 ) PN(3), the nearest point on the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) p(dim_num) + logical(kind=4) plane_imp_is_degenerate_3d + real(kind=8) pn(dim_num) + real(kind=8) t + + if (plane_imp_is_degenerate_3d(a, b, c)) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP_POINT_NEAR_3D - Fatal error!' + write (*, '(a)') ' A = B = C = 0.' + stop 1 + end if + + t = -(a * p(1) + b * p(2) + c * p(3) + d) / (a * a + b * b + c * c) + + pn(1) = p(1) + a * t + pn(2) = p(2) + b * t + pn(3) = p(3) + c * t + + return +end +subroutine plane_imp_segment_near_3d(p1, p2, a, b, c, d, dist, p, pn) + +!*****************************************************************************80 +! +!! PLANE_IMP_SEGMENT_NEAR_3D: nearest ( implicit plane, line segment ) in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! A line segment is the finite portion of a line that lies between +! two points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the line +! segment. +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Output, real ( kind = 8 ) DIST, the distance between the line segment and +! the plane. +! +! Output, real ( kind = 8 ) P(3), the nearest point on the plane. +! +! Output, real ( kind = 8 ) PN(3), the nearest point on the line +! segment to the plane. If DIST is zero, the PN is a point of +! intersection of the plane and the line segment. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) alpha + real(kind=8) an + real(kind=8) b + real(kind=8) bn + real(kind=8) c + real(kind=8) cn + real(kind=8) d + real(kind=8) dist + real(kind=8) dn + real(kind=8) dot1 + real(kind=8) dot2 + real(kind=8) norm + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + + pn(1:dim_num) = 0.0D+00 + p(1:dim_num) = 0.0D+00 + + norm = sqrt(a * a + b * b + c * c) + + if (norm == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP_SEGMENT_NEAR_3D - Fatal error!' + write (*, '(a)') ' Plane normal vector is null.' + stop 1 + end if +! +! The normalized coefficients allow us to compute the (signed) distance. +! + an = a / norm + bn = b / norm + cn = c / norm + dn = d / norm +! +! If the line segment is actually a point, then the answer is easy. +! + if (all(p1(1:dim_num) == p2(1:dim_num))) then + + dot1 = an * p1(1) + bn * p1(2) + cn * p1(3) + dn + dist = abs(dot1) + pn(1:dim_num) = p1(1:dim_num) + p(1) = pn(1) - an * dot1 + p(2) = pn(2) - bn * dot1 + p(3) = pn(3) - cn * dot1 + return + + end if +! +! Compute the projections of the two points onto the normal vector. +! + dot1 = an * p1(1) + bn * p1(2) + cn * p1(3) + dn + dot2 = an * p2(1) + bn * p2(2) + cn * p2(3) + dn +! +! If these have the same sign, then the line segment does not +! cross the plane, and one endpoint is the nearest point. +! + if ((0.0D+00 < dot1 .and. 0.0D+00 < dot2) .or. & + (dot1 < 0.0D+00 .and. dot2 < 0.0D+00)) then + + dot1 = abs(dot1) + dot2 = abs(dot2) + + if (dot1 < dot2) then + pn(1:dim_num) = p1(1:dim_num) + p(1) = pn(1) - an * dot1 + p(2) = pn(2) - bn * dot1 + p(3) = pn(3) - cn * dot1 + dist = dot1 + else + pn(1:dim_num) = p2(1:dim_num) + dist = dot2 + p(1) = pn(1) - an * dot2 + p(2) = pn(2) - bn * dot2 + p(3) = pn(3) - cn * dot2 + end if +! +! If the projections differ in sign, the line segment crosses the plane. +! + else + + if (dot1 == 0.0D+00) then + alpha = 0.0D+00 + else if (dot2 == 0.0D+00) then + alpha = 1.0D+00 + else + alpha = dot2 / (dot2 - dot1) + end if + + pn(1:dim_num) = alpha * p1(1:dim_num) & + + (1.0D+00 - alpha) * p2(1:dim_num) + + p(1:dim_num) = pn(1:dim_num) + + dist = 0.0D+00 + + end if + + return +end +subroutine plane_imp_triangle_int_3d(a, b, c, d, t, int_num, pint) + +!*****************************************************************************80 +! +!! PLANE_IMP_TRIANGLE_INT_3D: intersection ( implicit plane, triangle ) in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! There may be 0, 1, 2 or 3 points of intersection returned. +! +! If two intersection points are returned, then the entire line +! between them comprises points of intersection. +! +! If three intersection points are returned, then all points of +! the triangle intersect the plane. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersection points +! returned. +! +! Output, real ( kind = 8 ) PINT(3,3), the intersection points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) dist1 + real(kind=8) dist2 + real(kind=8) dist3 + integer(kind=4) int_num + real(kind=8) pint(dim_num, 3) + real(kind=8) t(dim_num, 3) + + int_num = 0 +! +! Compute the signed distances between the vertices and the plane. +! + dist1 = a * t(1, 1) + b * t(2, 1) + c * t(3, 1) + d + dist2 = a * t(1, 2) + b * t(2, 2) + c * t(3, 2) + d + dist3 = a * t(1, 3) + b * t(2, 3) + c * t(3, 3) + d +! +! Consider any zero distances. +! + if (dist1 == 0.0D+00) then + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 1) + end if + + if (dist2 == 0.0D+00) then + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 2) + end if + + if (dist3 == 0.0D+00) then + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 3) + end if +! +! If 2 or 3 of the nodes intersect, we're already done. +! + if (2 <= int_num) then + return + end if +! +! If one node intersects, then we're done unless the other two +! are of opposite signs. +! + if (int_num == 1) then + + if (dist1 == 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & + dist2, dist3, int_num, pint) + + else if (dist2 == 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & + dist1, dist3, int_num, pint) + + else if (dist3 == 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & + dist1, dist2, int_num, pint) + + end if + + return + + end if +! +! All nodal distances are nonzero, and there is at least one +! positive and one negative. +! + if (dist1 * dist2 < 0.0D+00 .and. dist1 * dist3 < 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & + dist1, dist2, int_num, pint) + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & + dist1, dist3, int_num, pint) + + else if (dist2 * dist1 < 0.0D+00 .and. dist2 * dist3 < 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 1), & + dist2, dist1, int_num, pint) + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & + dist2, dist3, int_num, pint) + + else if (dist3 * dist1 < 0.0D+00 .and. dist3 * dist2 < 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 1), & + dist3, dist1, int_num, pint) + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 2), & + dist3, dist2, int_num, pint) + + end if + + return +end +subroutine plane_imp_triangle_int_add_3d(p1, p2, dist1, dist2, int_num, pint) + +!*****************************************************************************80 +! +!! PLANE_IMP_TRIANGLE_INT_ADD_3D is a utility for plane/triangle intersections. +! +! Discussion: +! +! This routine is called to consider the value of the signed distance +! from a plane of two nodes of a triangle. If the two values +! have opposite signs, then there is a point of intersection between +! them. The routine computes this point and adds it to the list. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the coordinates of two vertices +! of a triangle. +! +! Input, real ( kind = 8 ) DIST1, DIST2, the signed distances of the +! two vertices from a plane. +! +! Input/output, integer ( kind = 4 ) INT_NUM, the number of intersection +! points. +! +! Input/output, real ( kind = 8 ) PINT(3,INT_NUM), the intersection points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) alpha + real(kind=8) dist1 + real(kind=8) dist2 + integer(kind=4) int_num + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pint(dim_num, 3) + + if (dist1 == 0.0D+00) then + int_num = int_num + 1 + pint(1:dim_num, int_num) = p1(1:dim_num) + else if (dist2 == 0.0D+00) then + int_num = int_num + 1 + pint(1:dim_num, int_num) = p2(1:dim_num) + else if (dist1 * dist2 < 0.0D+00) then + alpha = dist2 / (dist2 - dist1) + int_num = int_num + 1 + pint(1:dim_num, int_num) = alpha * p1(1:dim_num) & + + (1.0D+00 - alpha) * p2(1:dim_num) + end if + + return +end +subroutine plane_imp_triangle_near_3d(t, a, b, c, d, dist, near_num, pn) + +!*****************************************************************************80 +! +!! PLANE_IMP_TRIANGLE_NEAR_3D: nearest ( implicit plane, triangle ) in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! If DIST = 0, then each point is a point of intersection, and there +! will be at most 3 such points returned. +! +! If 0 < DIST, then the points are listed in pairs, with the first +! being on the triangle, and the second on the plane. Two points will +! be listed in the most common case, but possibly 4 or 6. +! +! I should see to it that the underlying distance routine always returns +! one of the endpoints if the entire line segment is at zero distance. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Output, real ( kind = 8 ) DIST, the distance between the triangle +! and the plane. +! +! Output, integer ( kind = 4 ) NEAR_NUM, the number of nearest points +! returned. +! +! Output, real ( kind = 8 ) PN(3,6), a collection of nearest points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) dist + real(kind=8) dist12 + real(kind=8) dist23 + real(kind=8) dist31 + integer(kind=4) near_num + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num, 6) + real(kind=8) pt(dim_num) + real(kind=8) t(dim_num, 3) + + near_num = 0 +! +! Consider the line segment P1 - P2. +! + call plane_imp_segment_near_3d(t(1:dim_num, 1), t(1:dim_num, 2), & + a, b, c, d, dist12, p, pt) + + dist = dist12 + + near_num = near_num + 1 + pn(1:dim_num, near_num) = pt(1:dim_num) + + if (0.0D+00 < dist12) then + near_num = near_num + 1 + pn(1:dim_num, near_num) = p(1:dim_num) + end if +! +! Consider the line segment P2 - P3. +! + call plane_imp_segment_near_3d(t(1:dim_num, 2), t(1:dim_num, 3), & + a, b, c, d, dist23, p, pt) + + if (dist23 < dist) then + + near_num = 0 + dist = dist23 + + near_num = near_num + 1 + pn(1:dim_num, near_num) = pt(1:dim_num) + + if (0.0D+00 < dist23) then + near_num = near_num + 1 + pn(1:dim_num, near_num) = p(1:dim_num) + end if + + else if (dist23 == dist) then + + near_num = near_num + 1 + pn(1:dim_num, near_num) = pt(1:dim_num) + + if (0.0D+00 < dist23) then + near_num = near_num + 1 + pn(1:dim_num, near_num) = p(1:dim_num) + end if + + end if +! +! Consider the line segment P3 - P1. +! + call plane_imp_segment_near_3d(t(1:dim_num, 3), t(1:dim_num, 1), & + a, b, c, d, dist31, p, pt) + + if (dist31 < dist) then + + near_num = 0 + dist = dist31 + + near_num = near_num + 1 + pn(1:dim_num, near_num) = pt(1:dim_num) + + if (0.0D+00 < dist31) then + near_num = near_num + 1 + pn(1:dim_num, near_num) = p(1:dim_num) + end if + + else if (dist31 == dist) then + + near_num = near_num + 1 + pn(1:dim_num, near_num) = pt(1:dim_num) + + if (0.0D+00 < dist31) then + near_num = near_num + 1 + pn(1:dim_num, near_num) = p(1:dim_num) + end if + + end if + + return +end +subroutine plane_imp2exp_3d(a, b, c, d, p1, p2, p3) + +!*****************************************************************************80 +! +!! PLANE_IMP2EXP_3D converts an implicit plane to explicit form in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is +! +! A * X + B * Y + C * Z + D = 0. +! +! The explicit form of a plane in 3D is +! +! the plane through P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Output, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) normal(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pp(dim_num) + + call plane_imp2normal_3d(a, b, c, d, pp, normal) + + call plane_normal2exp_3d(pp, normal, p1, p2, p3) + + return +end +subroutine plane_imp2normal_3d(a, b, c, d, pp, normal) + +!*****************************************************************************80 +! +!! PLANE_IMP2NORMAL_3D converts an implicit plane to normal form in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is +! +! A * X + B * Y + C * Z + D = 0. +! +! The normal form of a plane in 3D is +! +! PP, a point on the plane, and +! N, the unit normal to the plane. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! +! Output, real ( kind = 8 ) PP(3), a point on the plane. +! +! Output, real ( kind = 8 ) NORMAL(3), the unit normal vector to the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) norm + real(kind=8) normal(dim_num) + real(kind=8) pp(dim_num) + + norm = sqrt(a * a + b * b + c * c) + + if (norm == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP2NORMAL_3D - Fatal error!' + write (*, '(a)') ' The plane (A,B,C) has zero norm.' + stop 1 + end if + + normal(1) = a / norm + normal(2) = b / norm + normal(3) = c / norm + + if (a /= 0.0D+00) then + pp(1) = -d / a + pp(2) = 0.0D+00 + pp(3) = 0.0D+00 + else if (b /= 0.0D+00) then + pp(1) = 0.0D+00 + pp(2) = -d / b + pp(3) = 0.0D+00 + else if (c /= 0.0D+00) then + pp(1) = 0.0D+00 + pp(2) = 0.0D+00 + pp(3) = -d / c + else + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_IMP2NORMAL_3D - Fatal error!' + write (*, '(a)') ' The (A,B,C) vector is null.' + stop 1 + end if + + return +end +subroutine plane_normal_basis_3d(pp, normal, pq, pr) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_BASIS_3D finds two perpendicular vectors in a plane in 3D. +! +! Discussion: +! +! The normal form of a plane in 3D is: +! +! PP is a point on the plane, +! N is a normal vector to the plane. +! +! The two vectors to be computed, PQ and PR, can be regarded as +! the basis of a Cartesian coordinate system for points in the plane. +! Any point in the plane can be described in terms of the "origin" +! point PP plus a weighted sum of the two vectors PQ and PR: +! +! P = PP + a * PQ + b * PR. +! +! The vectors PQ and PR have unit length, and are perpendicular to N +! and to each other. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. (Actually, +! we never need to know these values to do the calculation!) +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The +! vector must not have zero length, but it is not necessary for N +! to have unit length. +! +! Output, real ( kind = 8 ) PQ(3), a vector of unit length, +! perpendicular to the vector N and the vector PR. +! +! Output, real ( kind = 8 ) PR(3), a vector of unit length, +! perpendicular to the vector N and the vector PQ. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) r8vec_norm + real(kind=8) normal(dim_num) + real(kind=8) normal_norm + real(kind=8) pp(dim_num) + real(kind=8) pq(dim_num) + real(kind=8) pr(dim_num) + real(kind=8) pr_norm +! +! Compute the length of NORMAL. +! + normal_norm = r8vec_norm(dim_num, normal) + + if (normal_norm == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_NORMAL_BASIS_3D - Fatal error!' + write (*, '(a)') ' The normal vector is 0.' + stop 1 + end if +! +! Find a vector PQ that is normal to NORMAL and has unit length. +! + call r8vec_any_normal(dim_num, normal, pq) +! +! Now just take the cross product NORMAL x PQ to get the PR vector. +! + call r8vec_cross_product_3d(normal, pq, pr) + + pr_norm = r8vec_norm(dim_num, pr) + + pr(1:dim_num) = pr(1:dim_num) / pr_norm + + return +end + +subroutine plane_normal_line_exp_int_3d(pp, normal, p1, p2, ival, pint) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_LINE_EXP_INT_3D: intersection of plane and line in 3D. +! +! Discussion: +! +! The normal form of a plane in 3D is: +! +! PP is a point on the plane, +! N is a normal vector to the plane. +! +! The explicit form of a line in 3D is: +! +! P1, P2 are two points on the line. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. +! +! Input, real ( kind = 8 ) P1(3), P2(3), two distinct points on the line. +! +! Output, integer ( kind = 4 ) IVAL, the kind of intersection; +! 0, the line and plane seem to be parallel and separate; +! 1, the line and plane intersect at a single point; +! 2, the line and plane seem to be parallel and joined. +! +! Output, real ( kind = 8 ) PINT(3), the coordinates of a +! common point of the plane and line, when IVAL is 1 or 2. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) direction(dim_num) + integer(kind=4) ival + logical(kind=4) line_exp_is_degenerate_nd + real(kind=8) normal(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pint(dim_num) + real(kind=8) pp(dim_num) + real(kind=8) temp +! +! Make sure the line is not degenerate. +! + if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_NORMAL_LINE_EXP_INT_3D - Fatal error!' + write (*, '(a)') ' The line is degenerate.' + stop 1 + end if +! +! Make sure the plane normal vector is a unit vector. +! + temp = sqrt(sum(normal(1:dim_num)**2)) + + if (temp == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'PLANE_NORMAL_LINE_EXP_INT_3D - Fatal error!' + write (*, '(a)') ' The normal vector of the plane is degenerate.' + stop 1 + end if + + normal(1:dim_num) = normal(1:dim_num) / temp +! +! Determine the unit direction vector of the line. +! + direction(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + temp = sqrt(sum(direction(1:dim_num)**2)) + direction(1:dim_num) = direction(1:dim_num) / temp +! +! If the normal and direction vectors are orthogonal, then +! we have a special case to deal with. +! + if (dot_product(normal(1:dim_num), direction(1:dim_num)) == 0.0D+00) then + + temp = dot_product(normal(1:dim_num), p1(1:dim_num) - pp(1:dim_num)) + + if (temp == 0.0D+00) then + ival = 2 + pint(1:dim_num) = p1(1:dim_num) + else + ival = 0 + pint(1:dim_num) = huge(temp) + end if + + return + end if +! +! Determine the distance along the direction vector to the intersection point. +! + temp = dot_product(pp(1:dim_num) - p1(1:dim_num), normal(1:dim_num)) & + / dot_product(direction(1:dim_num), normal(1:dim_num)) + + ival = 1 + pint(1:dim_num) = p1(1:dim_num) + temp * direction(1:dim_num) + + return +end +subroutine plane_normal_qr_to_xyz(pp, normal, pq, pr, n, qr, xyz) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_QR_TO_XYZ: QR_TO_XYZ coordinates for a normal form plane. +! +! Discussion: +! +! The normal form of a plane in 3D is: +! +! PP is a point on the plane, +! NORMAL is a normal vector to the plane. +! +! Two vectors PQ and PR can be computed with the properties that +! * NORMAL, PQ and PR are pairwise orthogonal; +! * PQ and PR have unit length; +! * every point P in the plane has a "QR" representation +! as P = PP + q * PQ + r * PR. +! +! This function is given the QR coordinates of a set of points on the +! plane, and returns the XYZ coordinates. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 November 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The +! vector must not have zero length, but it is not necessary for N +! to have unit length. +! +! Input, real ( kind = 8 ) PQ(3), a vector of unit length, +! perpendicular to the vector N and the vector PR. +! +! Input, real ( kind = 8 ) PR(3), a vector of unit length, +! perpendicular to the vector N and the vector PQ. +! +! Input, integer ( kind = 4 ) N, the number of points on the plane. +! +! Input, real ( kind = 8 ) QR(2,N), the QR coordinates of the points. +! +! Output, real ( kind = 8 ) XYZ(3,N), the XYZ coordinates of the points. +! + implicit none + + integer(kind=4) n + + real(kind=8) normal(3) + real(kind=8) pp(3) + real(kind=8) pq(3) + real(kind=8) pqpr(3, 2) + real(kind=8) pr(3) + real(kind=8) qr(2, n) + real(kind=8) xyz(3, n) + + xyz(1, 1:n) = pp(1) + xyz(2, 1:n) = pp(2) + xyz(3, 1:n) = pp(3) + + pqpr(1:3, 1) = pq(1:3) + pqpr(1:3, 2) = pr(1:3) + + xyz(1:3, 1:n) = xyz(1:3, 1:n) + matmul(pqpr(1:3, 1:2), qr(1:2, 1:n)) + + return +end +subroutine plane_normal_tetrahedron_intersect(pp, normal, t, int_num, pint) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_TETRAHEDRON_INTERSECT intersects a plane and a tetrahedron. +! +! Discussion: +! +! The intersection of a plane and a tetrahedron is one of: +! 0) empty +! 1) a single point +! 2) a single line segment +! 3) a triangle +! 4) a quadrilateral. +! +! In each case, the region of intersection can be described by the +! corresponding number of points. In particular, cases 2, 3 and 4 +! are described by the vertices that bound the line segment, triangle, +! or quadrilateral. +! +! The normal form of a plane is: +! +! PP is a point on the plane, +! N is a normal vector to the plane. +! +! The form of a tetrahedron is +! +! T(1:3,1:4) contains the coordinates of the vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 June 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. +! +! Input, real ( kind = 8 ) T(3,4), the tetrahedron vertices. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersection +! points returned. This will be 0, 1, 2, 3 or 4. +! +! Output, real ( kind = 8 ) PINT(3,4), the coordinates of the +! intersection points. +! + implicit none + + real(kind=8) area1 + real(kind=8) area2 + real(kind=8) d(4) + real(kind=8) dn + real(kind=8) dpp + integer(kind=4) int_num + integer(kind=4) j1 + integer(kind=4) j2 + real(kind=8) normal(3) + real(kind=8) pint(3, 4) + real(kind=8) pp(3) + logical(kind=4) r8_sign_opposite_strict + real(kind=8) t(3, 4) + real(kind=8) temp(3) + + int_num = 0 + pint(1:3, 1:4) = 0.0D+00 +! +! DN is the length of the normal vector. +! + dn = dot_product(normal(1:3), normal(1:3)) +! +! DPP is the distance between the origin and the projection of the +! point PP onto the normal vector. +! + dpp = dn - dot_product(normal(1:3), pp(1:3)) +! +! D(I) is positive, zero, or negative if vertex I is above, +! on, or below the plane. +! + d(1:4) = dn - matmul(normal(1:3), t(1:3, 1:4)) - dpp +! +! If all D are positive or negative, no intersection. +! + if (all(d(1:4) < 0.0D+00) .or. all(0.0D+00 < d(1:4))) then + int_num = 0 + return + end if +! +! Points with zero distance are automatically added to the list. +! +! For each point with nonzero distance, seek another point +! with opposite sign and higher index, and compute the intersection +! of the line between those points and the plane. +! + do j1 = 1, 4 + + if (d(j1) == 0.0D+00) then + int_num = int_num + 1 + pint(1:3, int_num) = t(1:3, j1) + else + do j2 = j1 + 1, 4 + if (r8_sign_opposite_strict(d(j1), d(j2))) then + int_num = int_num + 1 + pint(1:3, int_num) = (d(j1) * t(1:3, j2) & + - d(j2) * t(1:3, j1)) & + / (d(j1) - d(j2)) + end if + end do + end if + end do +! +! If four points were found, try to order them properly. +! + if (int_num == 4) then + call quad_area_3d(pint, area1) + temp(1:3) = pint(1:3, 3) + pint(1:3, 3) = pint(1:3, 4) + pint(1:3, 4) = temp(1:3) + call quad_area_3d(pint, area2) + if (area2 < area1) then + temp(1:3) = pint(1:3, 3) + pint(1:3, 3) = pint(1:3, 4) + pint(1:3, 4) = temp(1:3) + end if + end if + + return +end +subroutine plane_normal_triangle_int_3d(pp, normal, t, int_num, pint) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_TRIANGLE_INT_3D: intersection ( normal plane, triangle ) in 3D. +! +! Discussion: +! +! The normal form of a plane in 3D is: +! +! PP is a point on the plane, +! N is a normal vector to the plane. +! +! There may be 0, 1, 2 or 3 points of intersection returned. +! +! If two intersection points are returned, then the entire line +! between them comprises points of intersection. +! +! If three intersection points are returned, then all points of +! the triangle intersect the plane. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 May 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector to the plane. +! +! Input, real ( kind = 8 ) T(3,3), the vertices of the triangle. +! +! Output, integer ( kind = 4 ) INT_NUM, the number of intersection +! points returned. +! +! Output, real ( kind = 8 ) PINT(3,3), the coordinates of the +! intersection points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) d + real(kind=8) dist1 + real(kind=8) dist2 + real(kind=8) dist3 + real(kind=8) normal(dim_num) + integer(kind=4) int_num + real(kind=8) pint(dim_num, 3) + real(kind=8) pp(dim_num) + real(kind=8) t(dim_num, 3) + + int_num = 0 +! +! Compute the signed distances between the vertices and the plane. +! + d = -dot_product(normal(1:dim_num), pp(1:dim_num)) + + dist1 = dot_product(normal(1:dim_num), t(1:dim_num, 1)) + d + dist2 = dot_product(normal(1:dim_num), t(1:dim_num, 2)) + d + dist3 = dot_product(normal(1:dim_num), t(1:dim_num, 3)) + d +! +! Consider any zero distances. +! + if (dist1 == 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 1) + + end if + + if (dist2 == 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 2) + + end if + + if (dist3 == 0.0D+00) then + + int_num = int_num + 1 + pint(1:dim_num, int_num) = t(1:dim_num, 3) + + end if +! +! If 2 or 3 of the nodes intersect, we're already done. +! + if (2 <= int_num) then + return + end if +! +! If one node intersects, then we're done unless the other two +! are of opposite signs. +! + if (int_num == 1) then + + if (dist1 == 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & + dist2, dist3, int_num, pint) + + else if (dist2 == 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & + dist1, dist3, int_num, pint) + + else if (dist3 == 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & + dist1, dist2, int_num, pint) + + end if + + return + + end if +! +! All nodal distances are nonzero, and there is at least one +! positive and one negative. +! + if (dist1 * dist2 < 0.0D+00 .and. dist1 * dist3 < 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 2), & + dist1, dist2, int_num, pint) + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 1), t(1:dim_num, 3), & + dist1, dist3, int_num, pint) + + else if (dist2 * dist1 < 0.0D+00 .and. dist2 * dist3 < 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 1), & + dist2, dist1, int_num, pint) + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 2), t(1:dim_num, 3), & + dist2, dist3, int_num, pint) + + else if (dist3 * dist1 < 0.0D+00 .and. dist3 * dist2 < 0.0D+00) then + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 1), & + dist3, dist1, int_num, pint) + + call plane_imp_triangle_int_add_3d(t(1:dim_num, 3), t(1:dim_num, 2), & + dist3, dist2, int_num, pint) + + end if + + return +end +subroutine plane_normal_uniform_3d(seed, pp, normal) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_UNIFORM_3D generates a random normal plane in 3D. +! +! Discussion: +! +! The normal form of a plane is: +! +! PP is a point on the plane, +! N is a normal vector to the plane. +! +! The point PP will be chosen at random inside the unit sphere. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 November 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, real ( kind = 8 ) PP(3), a point on the plane. +! +! Output, real ( kind = 8 ) NORMAL(3), the unit normal vector. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) norm + real(kind=8) normal(dim_num) + real(kind=8) pp(dim_num) + integer(kind=4) seed +! +! Pick PP as a random point inside the unit sphere in ND. +! + call ball01_sample_3d(seed, pp) +! +! Get values from a standard normal distribution. +! + call r8vec_normal_01(dim_num, seed, normal) +! +! Compute the length of the vector. +! + norm = sqrt(sum(normal(1:dim_num)**2)) +! +! Normalize the vector. +! + normal(1:dim_num) = normal(1:dim_num) / norm + + return +end +subroutine plane_normal_uniform_nd(dim_num, seed, pp, normal) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_UNIFORM_ND generates a random normal plane in ND. +! +! Discussion: +! +! The normal form of a plane is: +! +! PP is a point on the plane, +! N is a normal vector to the plane. +! +! The point PP will be chosen at random inside the unit sphere. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 November 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, real ( kind = 8 ) PP(DIM_NUM), a point on the plane. +! +! Output, real ( kind = 8 ) NORMAL(DIM_NUM), the unit normal vector. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) norm + real(kind=8) normal(dim_num) + real(kind=8) pp(dim_num) + integer(kind=4) seed +! +! Pick PP as a random point inside the unit sphere in ND. +! + call ball01_sample_nd(dim_num, seed, pp) +! +! Get values from a standard normal distribution. +! + call r8vec_normal_01(dim_num, seed, normal) +! +! Compute the length of the vector. +! + norm = sqrt(sum(normal(1:dim_num)**2)) +! +! Normalize the vector. +! + normal(1:dim_num) = normal(1:dim_num) / norm + + return +end +subroutine plane_normal_xyz_to_qr(pp, normal, pq, pr, n, xyz, qr) + +!*****************************************************************************80 +! +!! PLANE_NORMAL_XYZ_TO_QR: XYZ to QR coordinates for a normal form plane. +! +! Discussion: +! +! The normal form of a plane in 3D is: +! +! PP is a point on the plane, +! NORMAL is a normal vector to the plane. +! +! Two vectors PQ and PR can be computed with the properties that +! * NORMAL, PQ and PR are pairwise orthogonal; +! * PQ and PR have unit length; +! * every point P in the plane has a "QR" representation +! as P = PP + q * PQ + r * PR. +! +! This function is given the XYZ coordinates of a set of points on the +! plane, and returns the QR coordinates. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 May 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The +! vector must not have zero length, but it is not necessary for N +! to have unit length. +! +! Input, real ( kind = 8 ) PQ(3), a vector of unit length, +! perpendicular to the vector N and the vector PR. +! +! Input, real ( kind = 8 ) PR(3), a vector of unit length, +! perpendicular to the vector N and the vector PQ. +! +! Input, integer ( kind = 4 ) N, the number of points on the plane. +! +! Input, real ( kind = 8 ) XYZ(3,N), the XYZ coordinates of the points. +! +! Output, real ( kind = 8 ) QR(2,N), the QR coordinates of the points. +! + implicit none + + integer(kind=4) n + + real(kind=8) normal(3) + real(kind=8) pp(3) + real(kind=8) pq(3) + real(kind=8) pr(3) + real(kind=8) qr(2, n) + real(kind=8) rpqp(2, 3) + real(kind=8) xyz(3, n) + + rpqp(1, 1:3) = pq(1:3) + rpqp(2, 1:3) = pr(1:3) + + qr(1:2, 1:n) = matmul(rpqp(1:2, 1:3), xyz(1:3, 1:n)) + + qr(1, 1:n) = qr(1, 1:n) - dot_product(pq(1:3), pp(1:3)) + qr(2, 1:n) = qr(2, 1:n) - dot_product(pr(1:3), pp(1:3)) + + return +end +subroutine plane_normal2exp_3d(pp, normal, p1, p2, p3) + +!*****************************************************************************80 +! +!! PLANE_NORMAL2EXP_3D converts a normal plane to explicit form in 3D. +! +! Discussion: +! +! The normal form of a plane in 3D is +! +! PP, a point on the plane, and +! N, the unit normal to the plane. +! +! The explicit form of a plane in 3D is +! +! the plane through P1, P2 and P3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), a normal vector N to the plane. The +! vector must not have zero length, but it is not necessary for N +! to have unit length. +! +! Output, real ( kind = 8 ) P1(3), P2(3), P3(3), three points on the plane. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) normal(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pp(dim_num) + real(kind=8) pq(dim_num) + real(kind=8) pr(dim_num) + + call plane_normal_basis_3d(pp, normal, pq, pr) + + p1(1:dim_num) = pp(1:dim_num) + p2(1:dim_num) = pp(1:dim_num) + pq(1:dim_num) + p3(1:dim_num) = pp(1:dim_num) + pr(1:dim_num) + + return +end +subroutine plane_normal2imp_3d(pp, normal, a, b, c, d) + +!*****************************************************************************80 +! +!! PLANE_NORMAL2IMP_3D converts a normal form plane to implicit form in 3D. +! +! Discussion: +! +! The normal form of a plane in 3D is +! +! PP, a point on the plane, and +! N, the unit normal to the plane. +! +! The implicit form of a plane in 3D is +! +! A * X + B * Y + C * Z + D = 0. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PP(3), a point on the plane. +! +! Input, real ( kind = 8 ) NORMAL(3), the unit normal vector to the plane. +! +! Output, real ( kind = 8 ) A, B, C, D, the implicit plane parameters. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) normal(dim_num) + real(kind=8) pp(dim_num) + + a = normal(1) + b = normal(2) + c = normal(3) + d = -a * pp(1) - b * pp(2) - c * pp(3) + + return +end +subroutine planes_imp_angle_3d(a1, b1, c1, d1, a2, b2, c2, d2, angle) + +!*****************************************************************************80 +! +!! PLANES_IMP_ANGLE_3D: dihedral angle between implicit planes in 3D. +! +! Discussion: +! +! The implicit form of a plane in 3D is: +! +! A * X + B * Y + C * Z + D = 0 +! +! If two planes P1 and P2 intersect in a nondegenerate way, then there is a +! line of intersection L0. Consider any plane perpendicular to L0. The +! dihedral angle of P1 and P2 is the angle between the lines L1 and L2, where +! L1 is the intersection of P1 and P0, and L2 is the intersection of P2 +! and P0. +! +! The dihedral angle may also be calculated as the angle between the normal +! vectors of the two planes. Note that if the planes are parallel or +! coincide, the normal vectors are identical, and the dihedral angle is 0. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 September 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Daniel Zwillinger, editor, +! CRC Standard Math Tables and Formulae, 30th edition, +! Section 4.13, "Planes", +! CRC Press, 1996, pages 305-306. +! +! Parameters: +! +! Input, real ( kind = 8 ) A1, B1, C1, D1, coefficients that define the +! first plane. +! +! Input, real ( kind = 8 ) A2, B2, C2, D2, coefficients that define +! the second plane. +! +! Output, real ( kind = 8 ) ANGLE, the dihedral angle, in radians, +! defined by the two planes. If either plane is degenerate, or they +! do not intersect, or they coincide, then the angle is set to HUGE(1.0). +! Otherwise, the angle is between 0 and PI. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a1 + real(kind=8) a2 + real(kind=8) angle + real(kind=8) b1 + real(kind=8) b2 + real(kind=8) c1 + real(kind=8) c2 + real(kind=8) cosine + real(kind=8) d1 + real(kind=8) d2 + real(kind=8) norm1 + real(kind=8) norm2 + real(kind=8) r8_acos + + norm1 = sqrt(a1 * a1 + b1 * b1 + c1 * c1) + + if (norm1 == 0.0D+00) then + angle = huge(angle) + return + end if + + norm2 = sqrt(a2 * a2 + b2 * b2 + c2 * c2) + + if (norm2 == 0.0D+00) then + angle = huge(angle) + return + end if + + cosine = (a1 * a2 + b1 * b2 + c1 * c2) / (norm1 * norm2) + + angle = r8_acos(cosine) + + return +end +function points_avoid_point_naive_2d(n, p_set, p) + +!*****************************************************************************80 +! +!! POINTS_AVOID_POINT_NAIVE_2D: is a point "far" from a set of points in 2D? +! +! Discussion: +! +! The routine discards points that are too close to other points. +! The method used to check this is quadratic in the number of points, +! and may take an inordinate amount of time if there are a large +! number of points. But in that case, what do you want? If you want +! lots of points, you don't want to delete any because it won't matter. +! +! The test point is "far enough" from an accepted point if +! the Euclidean distance is at least 100 times EPSILON. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 February 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of accepted points. +! +! Input, real ( kind = 8 ) P_SET(2,N), the accepted points. +! +! Input, real ( kind = 8 ) P(2), a point to be tested. +! +! Output, logical ( kind = 4 ) POINTS_AVOID_POINT_NAIVE_2D, is TRUE if +! XY_TEST is "far enough" from all the accepted points. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) j + real(kind=8) p(dim_num) + real(kind=8) p_set(dim_num, n) + logical(kind=4) points_avoid_point_naive_2d + real(kind=8) tol + + tol = 100.0D+00 * epsilon(tol) + + points_avoid_point_naive_2d = .true. + + do j = 1, n + + if (sqrt(sum((p_set(1:dim_num, j) - p(1:dim_num))**2)) < tol) then + points_avoid_point_naive_2d = .false. + return + end if + + end do + + return +end +subroutine points_bisect_line_imp_2d(p1, p2, a, b, c) + +!*****************************************************************************80 +! +!! POINTS_BISECT_LINE_IMP_2D: implicit bisector line between two points in 2D. +! +! Discussion: +! +! This routine finds, in implicit form, the equation of the line +! that is equidistant from two points. +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 January 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the coordinates of two points. +! +! Output, real ( kind = 8 ) A, B, C, the parameters of the implicit line +! equidistant from both points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + a = p1(1) - p2(1) + b = p1(2) - p2(2) + c = -0.5D+00 * ((p1(1) * p1(1) + p1(2) * p1(2)) & + - (p2(1) * p2(1) + p2(2) * p2(2))) + + return +end +subroutine points_bisect_line_par_2d(p1, p2, f, g, x, y) + +!*****************************************************************************80 +! +!! POINTS_BISECT_LINE_PAR_2D: parametric bisector line between points in 2D. +! +! Discussion: +! +! This routine finds, in parametric form, the equation of the line +! that is equidistant from two points. +! +! The parametric form of a line in 2D is: +! +! X = X0 + F * T +! Y = Y0 + G * T +! +! We normalize by always choosing F*F + G*G = 1, and F nonnegative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points. +! +! Output, real ( kind = 8 ) F, G, X, Y, the parameters of the parametric line +! equidistant from both points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) f + real(kind=8) g + real(kind=8) norm + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) x + real(kind=8) y + + f = 0.5D+00 * (p1(1) + p2(1)) + g = 0.5D+00 * (p1(2) + p2(2)) + + norm = f * f + g * g + + if (norm /= 0.0D+00) then + f = f / norm + g = g / norm + end if + + if (f < 0.0D+00) then + f = -f + g = -g + end if + + x = -(p2(2) - p1(2)) + y = +(p2(1) - p1(1)) + + return +end +subroutine points_centroid_2d(n, p, centroid_index) + +!*****************************************************************************80 +! +!! POINTS_CENTROID_2D computes the discrete centroid of a point set in 2D. +! +! Discussion: +! +! Given a discrete set of points S, the discrete centroid z is defined by +! +! sum ( x in S ) ( x - z )^2 +! = min ( y in S ) { sum ( x in S ) ( x - y )^2 +! +! In other words, the discrete centroid is a point in the set whose distance +! to the other points is minimized. The discrete centroid of a point set +! need not be unique. Consider a point set that comprises the +! vertices of an equilateral triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of points. +! +! Input, real ( kind = 8 ) P(2,N), the points. +! +! Output, integer ( kind = 4 ) CENTROID_INDEX, the index of a discrete +! centroid of the set, between 1 and N. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) centroid_index + real(kind=8) dist + real(kind=8) dist_min + integer(kind=4) i + integer(kind=4) j + real(kind=8) p(dim_num, n) + + dist_min = 0.0D+00 + centroid_index = -1 + + do i = 1, n + + dist = 0.0D+00 + do j = 1, n + dist = dist + sum((p(1:dim_num, i) - p(1:dim_num, j))**2) + end do + + if (i == 1) then + dist_min = dist + centroid_index = i + else if (dist < dist_min) then + dist_min = dist + centroid_index = i + end if + + end do + + return +end +subroutine points_colin_2d(p1, p2, p3, colin) + +!*****************************************************************************80 +! +!! POINTS_COLIN_2D estimates the colinearity of 3 points in 2D. +! +! Discussion: +! +! The estimate of colinearity that is returned is the ratio +! of the area of the triangle spanned by the points to the area +! of the equilateral triangle with the same perimeter. +! +! This estimate is 1 if the points are maximally noncolinear, 0 if the +! points are exactly colinear, and otherwise is closer to 1 or 0 depending +! on whether the points are far or close to colinearity. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 October 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the points. +! +! Output, real ( kind = 8 ) COLIN, the colinearity estimate. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area_triangle + real(kind=8) area2 + real(kind=8) colin + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) perim + real(kind=8) side + real(kind=8) t(dim_num, 3) + + t(1:dim_num, 1:3) = reshape((/ & + p1(1:dim_num), p2(1:dim_num), p3(1:dim_num)/), (/dim_num, 3/)) + + call triangle_area_2d(t, area_triangle) + + if (area_triangle == 0.0D+00) then + + colin = 0.0D+00 + + else + + perim = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) & + + sqrt(sum((p3(1:dim_num) - p2(1:dim_num))**2)) & + + sqrt(sum((p1(1:dim_num) - p3(1:dim_num))**2)) + + side = perim / 3.0D+00 + + area2 = 0.25D+00 * sqrt(3.0D+00) * side * side + + colin = abs(area_triangle) / area2 + + end if + + return +end +subroutine points_colin_3d(p1, p2, p3, colin) + +!*****************************************************************************80 +! +!! POINTS_COLIN_3D estimates the colinearity of 3 points in 3D. +! +! Discussion: +! +! The estimate of colinearity that is returned is the ratio +! of the area of the triangle spanned by the points to the area +! of the equilateral triangle with the same perimeter. +! +! This estimate is 1 if the points are maximally noncolinear, 0 if the +! points are exactly colinear, and otherwise is closer to 1 or 0 depending +! on whether the points are far or close to colinearity. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), the points. +! +! Output, real ( kind = 8 ) COLIN, the colinearity estimate. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) area_triangle + real(kind=8) area2 + real(kind=8) colin + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) perim + real(kind=8) side + real(kind=8) t(dim_num, 3) + + t(1:dim_num, 1:3) = reshape((/ & + p1(1:dim_num), p2(1:dim_num), p3(1:dim_num)/), (/dim_num, 3/)) + + call triangle_area_3d(t, area_triangle) + + if (area_triangle == 0.0D+00) then + + colin = 0.0D+00 + + else + + perim = sqrt(sum((p2(1:dim_num) - p1(1:dim_num))**2)) & + + sqrt(sum((p3(1:dim_num) - p2(1:dim_num))**2)) & + + sqrt(sum((p1(1:dim_num) - p3(1:dim_num))**2)) + + side = perim / 3.0D+00 + + area2 = 0.25D+00 * sqrt(3.0D+00) * side * side + + colin = abs(area_triangle) / area2 + + end if + + return +end +subroutine points_dist_nd(dim_num, p1, p2, dist) + +!*****************************************************************************80 +! +!! POINTS_DIST_ND finds the distance between two points in ND. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), the coordinates +! of two points. +! +! Output, real ( kind = 8 ) DIST, the distance between the points. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) dist + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + + dist = sqrt(sum((p1(1:dim_num) - p2(1:dim_num))**2)) + + return +end +subroutine points_hull_2d(node_num, node_xy, hull_num, hull) + +!*****************************************************************************80 +! +!! POINTS_HULL_2D computes the convex hull of 2D points. +! +! Discussion: +! +! The work involved is N*log(H), where N is the number of points, and H is +! the number of points that are on the hull. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 June 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of nodes. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of the nodes. +! +! Output, integer ( kind = 4 ) HULL_NUM, the number of nodes that lie on +! the convex hull. +! +! Output, integer ( kind = 4 ) HULL(NODE_NUM). Entries 1 through HULL_NUM +! contain the indices of the nodes that form the convex hull, in order. +! + implicit none + + integer(kind=4) node_num + + real(kind=8) angle + real(kind=8) angle_max + real(kind=8) angle_rad_2d + real(kind=8) di + real(kind=8) dr + integer(kind=4) first + integer(kind=4) hull(node_num) + integer(kind=4) hull_num + integer(kind=4) i + real(kind=8) node_xy(2, node_num) + real(kind=8) p_xy(2) + integer(kind=4) q + real(kind=8) q_xy(2) + integer(kind=4) r + real(kind=8) r_xy(2) + + if (node_num < 1) then + hull_num = 0 + return + end if +! +! If NODE_NUM = 1, the hull is the point. +! + if (node_num == 1) then + hull_num = 1 + hull(1) = 1 + return + end if +! +! If NODE_NUM = 2, then the convex hull is either the two distinct points, +! or possibly a single (repeated) point. +! + if (node_num == 2) then + + if (node_xy(1, 1) /= node_xy(1, 2) .or. node_xy(2, 1) /= node_xy(2, 2)) then + hull_num = 2 + hull(1) = 1 + hull(2) = 2 + else + hull_num = 1 + hull(1) = 1 + end if + + return + + end if +! +! Find the leftmost point and call it "Q". +! In case of ties, take the bottom-most. +! + q = 1 + do i = 2, node_num + if (node_xy(1, i) < node_xy(1, q) .or. & + (node_xy(1, i) == node_xy(1, q) .and. node_xy(2, i) < node_xy(2, q))) then + q = i + end if + end do + + q_xy(1:2) = node_xy(1:2, q) +! +! Remember the starting point, so we know when to stop! +! + first = q + hull_num = 1 + hull(1) = q +! +! For the first point, make a dummy previous point, 1 unit south, +! and call it "P". +! + p_xy(1) = q_xy(1) + p_xy(2) = q_xy(2) - 1.0D+00 +! +! Now, having old point P, and current point Q, find the new point R +! so the angle PQR is maximal. +! +! Watch out for the possibility that the two nodes are identical. +! + do + + r = 0 + angle_max = 0.0D+00 + + do i = 1, node_num + + if (i /= q .and. & + (node_xy(1, i) /= q_xy(1) .or. node_xy(2, i) /= q_xy(2))) then + + angle = angle_rad_2d(p_xy, q_xy, node_xy(1:2, i)) + + if (r == 0 .or. angle_max < angle) then + + r = i + r_xy(1:2) = node_xy(1:2, r) + angle_max = angle +! +! In case of ties, choose the nearer point. +! + else if (r /= 0 .and. angle == angle_max) then + + di = (node_xy(1, i) - q_xy(1))**2 + (node_xy(2, i) - q_xy(2))**2 + dr = (r_xy(1) - q_xy(1))**2 + (r_xy(2) - q_xy(2))**2 + + if (di < dr) then + r = i + r_xy(1:2) = node_xy(1:2, r) + angle_max = angle + end if + + end if + + end if + + end do +! +! We are done when we have returned to the first point on the convex hull. +! + if (r == first) then + exit + end if + + hull_num = hull_num + 1 + + if (node_num < hull_num) then + write (*, '(a)') ' ' + write (*, '(a)') 'POINTS_HULL_2D - Fatal error!' + write (*, '(a)') ' The algorithm has failed.' + stop 1 + end if +! +! Add point R to convex hull. +! + hull(hull_num) = r +! +! Set P := Q, Q := R, and prepare to search for next point R. +! + q = r + + p_xy(1:2) = q_xy(1:2) + q_xy(1:2) = r_xy(1:2) + + end do + + return +end +subroutine points_plot(file_name, node_num, node_xy, node_label) + +!*****************************************************************************80 +! +!! POINTS_PLOT plots a pointset. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, character ( len = * ) FILE_NAME, the name of the output file. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the nodes. +! +! Input, logical ( kind = 4 ) NODE_LABEL, is TRUE if the nodes should +! be labeled. +! +! Local parameters: +! +! Local, integer CIRCLE_SIZE, controls the size of the circles depicting +! the nodes, measured in PostScript points (1/72 of an inch). +! Currently set to 5. 3 is pretty small, and 1 is barely visible. +! + implicit none + + integer(kind=4) node_num + + integer(kind=4), parameter :: circle_size = 5 + integer(kind=4) delta + character(len=*) file_name + integer(kind=4) file_unit + integer(kind=4) ios + integer(kind=4) node + logical(kind=4) node_label + real(kind=8) node_xy(2, node_num) + character(len=40) string + real(kind=8) x_max + real(kind=8) x_min + integer(kind=4) x_ps + integer(kind=4) :: x_ps_max = 576 + integer(kind=4) :: x_ps_max_clip = 594 + integer(kind=4) :: x_ps_min = 36 + integer(kind=4) :: x_ps_min_clip = 18 + real(kind=8) x_scale + real(kind=8) y_max + real(kind=8) y_min + integer(kind=4) y_ps + integer(kind=4) :: y_ps_max = 666 + integer(kind=4) :: y_ps_max_clip = 684 + integer(kind=4) :: y_ps_min = 126 + integer(kind=4) :: y_ps_min_clip = 108 + real(kind=8) y_scale +! +! We need to do some figuring here, so that we can determine +! the range of the data, and hence the height and width +! of the piece of paper. +! + x_max = maxval(node_xy(1, 1:node_num)) + x_min = minval(node_xy(1, 1:node_num)) + x_scale = x_max - x_min + + x_max = x_max + 0.05D+00 * x_scale + x_min = x_min - 0.05D+00 * x_scale + x_scale = x_max - x_min + + y_max = maxval(node_xy(2, 1:node_num)) + y_min = minval(node_xy(2, 1:node_num)) + y_scale = y_max - y_min + + y_max = y_max + 0.05D+00 * y_scale + y_min = y_min - 0.05D+00 * y_scale + y_scale = y_max - y_min + + if (x_scale < y_scale) then + + delta = nint(real(x_ps_max - x_ps_min, kind=8) & + * (y_scale - x_scale) / (2.0D+00 * y_scale)) + + x_ps_max = x_ps_max - delta + x_ps_min = x_ps_min + delta + + x_ps_max_clip = x_ps_max_clip - delta + x_ps_min_clip = x_ps_min_clip + delta + + x_scale = y_scale + + else if (y_scale < x_scale) then + + delta = nint(real(y_ps_max - y_ps_min, kind=8) & + * (x_scale - y_scale) / (2.0D+00 * x_scale)) + + y_ps_max = y_ps_max - delta + y_ps_min = y_ps_min + delta + + y_ps_max_clip = y_ps_max_clip - delta + y_ps_min_clip = y_ps_min_clip + delta + + y_scale = x_scale + + end if + + call get_unit(file_unit) + + open (unit=file_unit, file=file_name, status='replace', & + iostat=ios) + + if (ios /= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'POINTS_PLOT - Fatal error!' + write (*, '(a)') ' Can not open output file.' + stop 1 + end if + + write (file_unit, '(a)') '%!PS-Adobe-3.0 EPSF-3.0' + write (file_unit, '(a)') '%%Creator: points_plot.F90' + write (file_unit, '(a)') '%%Title: '//trim(file_name) + write (file_unit, '(a)') '%%Pages: 1' + write (file_unit, '(a,i3,2x,i3,2x,i3,2x,i3)') '%%BoundingBox: ', & + x_ps_min, y_ps_min, x_ps_max, y_ps_max + write (file_unit, '(a)') '%%Document-Fonts: Times-Roman' + write (file_unit, '(a)') '%%LanguageLevel: 1' + write (file_unit, '(a)') '%%EndComments' + write (file_unit, '(a)') '%%BeginProlog' + write (file_unit, '(a)') '/inch {72 mul} def' + write (file_unit, '(a)') '%%EndProlog' + write (file_unit, '(a)') '%%Page: 1 1' + write (file_unit, '(a)') 'save' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Set the RGB line color to very light gray.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '0.900 0.900 0.900 setrgbcolor' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Draw a gray border around the page.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') 'newpath' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_min, y_ps_min, ' moveto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_max, y_ps_min, ' lineto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_max, y_ps_max, ' lineto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_min, y_ps_max, ' lineto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', x_ps_min, y_ps_min, ' lineto' + write (file_unit, '(a)') 'stroke' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Set the RGB line color to black.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '0.000 0.000 0.000 setrgbcolor' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Set the font and its size.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '/Times-Roman findfont' + write (file_unit, '(a)') '0.50 inch scalefont' + write (file_unit, '(a)') 'setfont' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Print a title.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% 210 702 moveto' + write (file_unit, '(a)') '% (Pointset) show' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Define a clipping polygon.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') 'newpath' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & + x_ps_min_clip, y_ps_min_clip, ' moveto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & + x_ps_max_clip, y_ps_min_clip, ' lineto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & + x_ps_max_clip, y_ps_max_clip, ' lineto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & + x_ps_min_clip, y_ps_max_clip, ' lineto' + write (file_unit, '(a,i3,2x,i3,2x,a)') ' ', & + x_ps_min_clip, y_ps_min_clip, ' lineto' + write (file_unit, '(a)') 'clip newpath' +! +! Draw the nodes. +! + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Draw filled dots at each node.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Set the RGB color to blue.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '0.000 0.150 0.750 setrgbcolor' + write (file_unit, '(a)') '%' + + do node = 1, node_num + + x_ps = int( & + ((x_max - node_xy(1, node)) * real(x_ps_min, kind=8) & + + (node_xy(1, node) - x_min) * real(x_ps_max, kind=8)) & + / (x_max - x_min)) + + y_ps = int( & + ((y_max - node_xy(2, node)) * real(y_ps_min, kind=8) & + + (node_xy(2, node) - y_min) * real(y_ps_max, kind=8)) & + / (y_max - y_min)) + + write (file_unit, '(a,i4,2x,i4,2x,i4,2x,a)') 'newpath ', x_ps, y_ps, & + circle_size, '0 360 arc closepath fill' + + end do +! +! Label the nodes. +! + if (node_label) then + + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Label the nodes:' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% Set the RGB color to darker blue.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '0.000 0.250 0.850 setrgbcolor' + write (file_unit, '(a)') '/Times-Roman findfont' + write (file_unit, '(a)') '0.20 inch scalefont' + write (file_unit, '(a)') 'setfont' + + do node = 1, node_num + + x_ps = int( & + ((x_max - node_xy(1, node)) * real(x_ps_min, kind=8) & + + (+node_xy(1, node) - x_min) * real(x_ps_max, kind=8)) & + / (x_max - x_min)) + + y_ps = int( & + ((y_max - node_xy(2, node)) * real(y_ps_min, kind=8) & + + (node_xy(2, node) - y_min) * real(y_ps_max, kind=8)) & + / (y_max - y_min)) + + write (string, '(i4)') node + string = adjustl(string) + + write (file_unit, '(i4,2x,i4,a)') x_ps, y_ps + 5, & + ' moveto ('//trim(string)//') show' + + end do + + end if + + write (file_unit, '(a)') '%' + write (file_unit, '(a)') 'restore showpage' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '% End of page.' + write (file_unit, '(a)') '%' + write (file_unit, '(a)') '%%Trailer' + write (file_unit, '(a)') '%%EOF' + close (unit=file_unit) + + return +end +subroutine points_point_near_naive_nd(dim_num, set_num, pset, p, i_min, & + dist_min) + +!*****************************************************************************80 +! +!! POINTS_POINT_NEAR_NAIVE_ND finds the nearest point to a given point in ND. +! +! Discussion: +! +! A naive algorithm is used. The distance to every point is calculated, +! in order to determine the smallest. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) SET_NUM, the number of points in the set. +! +! Input, real ( kind = 8 ) PSET(DIM_NUM,SET_NUM), the points in the set. +! +! Input, real ( kind = 8 ) P(DIM_NUM), the point whose nearest neighbor +! is sought. +! +! Output, integer ( kind = 4 ) I_MIN, the index of the nearest point in +! PSET to P. +! +! Output, real ( kind = 8 ) DIST_MIN, the distance between P(*) +! and PSET(*,I_MIN). +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) set_num + + real(kind=8) d + real(kind=8) dist_min + integer(kind=4) i + integer(kind=4) i_min + real(kind=8) p(dim_num) + real(kind=8) pset(dim_num, set_num) + + dist_min = huge(dist_min) + i_min = -1 + + do i = 1, set_num + d = sum((p(1:dim_num) - pset(1:dim_num, i))**2) + if (d < dist_min) then + dist_min = d + i_min = i + end if + end do + + dist_min = sqrt(dist_min) + + return +end +subroutine polar_to_xy(r, t, xy) + +!*****************************************************************************80 +! +!! POLAR_TO_XY converts polar coordinates to XY coordinates. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 January 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, T, the radius and angle (in radians). +! +! Output, real ( kind = 8 ) XY(2), the Cartesian coordinates. +! + implicit none + + real(kind=8) r + real(kind=8) t + real(kind=8) xy(2) + + xy(1) = r * cos(t) + xy(2) = r * sin(t) + + return +end +subroutine polygon_1_2d(n, v, result) + +!*****************************************************************************80 +! +!! POLYGON_1_2D integrates the function 1 over a polygon in 2D. +! +! Discussion: +! +! The polygon is bounded by the points (X(1:N), Y(1:N)). +! +! INTEGRAL = 0.5 * sum ( 1 <= I <= N ) +! ( X(I) + X(I-1) ) * ( Y(I) - Y(I-1) ) +! +! where X(0) and Y(0) should be replaced by X(N) and Y(N). +! +! The integral of 1 over a polygon is the area of the polygon. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 February 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! SF Bockman, +! Generalizing the Formula for Areas of Polygons to Moments, +! American Mathematical Society Monthly, +! 1989, pages 131-132. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! N should be at least 3 for a nonzero result. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices +! of the polygon. These vertices should be given in counter clockwise order. +! +! Output, real ( kind = 8 ) RESULT, the value of the integral. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + integer(kind=4) im1 + real(kind=8) result + real(kind=8) v(2, n) + + result = 0.0D+00 + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_1_2D - Fatal error!' + write (*, '(a)') ' The number of vertices must be at least 3.' + write (*, '(a,i8)') ' The input value of N = ', n + stop 1 + end if + + do i = 1, n + + if (i == 1) then + im1 = n + else + im1 = i - 1 + end if + + result = result + 0.5D+00 * (v(1, i) + v(1, im1)) * (v(2, i) - v(2, im1)) + + end do + + return +end +subroutine polygon_angles_2d(n, v, angle) + +!*****************************************************************************80 +! +!! POLYGON_ANGLES_2D computes the interior angles of a polygon in 2D. +! +! Discussion: +! +! The vertices should be listed in counter clockwise order. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 March 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! +! Input, real ( kind = 8 ) V(2,N), the vertices. +! +! Output, real ( kind = 8 ) ANGLE(N), the angles of the polygon, +! in radians. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle(n) + real(kind=8) angle_rad_2d + integer(kind=4) i + integer(kind=4) i4_wrap + integer(kind=4) im1 + integer(kind=4) ip1 + real(kind=8) v(dim_num, n) + + if (n <= 2) then + angle(1:n) = 0.0D+00 + return + end if + + do i = 1, n + + im1 = i4_wrap(i - 1, 1, n) + ip1 = i4_wrap(i + 1, 1, n) + + angle(i) = angle_rad_2d(v(1:dim_num, im1), v(1:dim_num, i), & + v(1:dim_num, ip1)) + + end do + + return +end +subroutine polygon_area_2d(n, v, area) + +!*****************************************************************************80 +! +!! POLYGON_AREA_2D computes the area of a polygon in 2D. +! +! Discussion: +! +! AREA = 1/2 * abs ( sum ( 1 <= I <= N ) X(I) * ( Y(I+1) - Y(I-1) ) ) +! where Y(0) should be replaced by Y(N), and Y(N+1) by Y(1). +! +! If the vertices are given in counter clockwise order, the area +! will be positive. If the vertices are given in clockwise order, +! the area will be negative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 October 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! +! Input, real ( kind = 8 ) V(2,N), the vertices. +! +! Output, real ( kind = 8 ) AREA, the absolute area of the polygon. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + integer(kind=4) i + integer(kind=4) i4_wrap + integer(kind=4) im1 + integer(kind=4) ip1 + real(kind=8) v(dim_num, n) + + area = 0.0D+00 + + do i = 1, n + + im1 = i4_wrap(i - 1, 1, n) + ip1 = i4_wrap(i + 1, 1, n) + + area = area + v(1, i) * (v(2, ip1) - v(2, im1)) + + end do + + area = 0.5D+00 * area + + return +end +subroutine polygon_area_2d_2(n, v, area) + +!*****************************************************************************80 +! +!! POLYGON_AREA_2D_2 computes the area of a polygon in 2D. +! +! Discussion: +! +! The area is the sum of the areas of the triangles formed by +! node N with consecutive pairs of nodes. +! +! If the vertices are given in counter clockwise order, the area +! will be positive. If the vertices are given in clockwise order, +! the area will be negative. +! +! Thanks to Martin Pineault for noticing that an earlier version +! of this routine would not correctly compute the area of a nonconvex +! polygon. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 October 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! +! Input, real ( kind = 8 ) V(2,N), the vertices. +! +! Output, real ( kind = 8 ) AREA, the absolute area of the polygon. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) area_triangle + integer(kind=4) i + real(kind=8) t(dim_num, 3) + real(kind=8) v(dim_num, n) + + area = 0.0D+00 + + do i = 1, n - 2 + + t(1:dim_num, 1:3) = reshape((/ & + v(1:dim_num, i), v(1:dim_num, i + 1), v(1:dim_num, n)/), & + (/dim_num, 3/)) + + call triangle_area_2d(t, area_triangle) + + area = area + area_triangle + + end do + + return +end +subroutine polygon_area_3d(n, v, area, normal) + +!*****************************************************************************80 +! +!! POLYGON_AREA_3D computes the area of a polygon in 3D. +! +! Discussion: +! +! The computation is not valid unless the vertices of the polygon +! lie in a plane, so that the polygon that is defined is "flat". +! +! The polygon does not have to be "regular", that is, neither its +! sides nor its angles need to be equal. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 February 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Allen Van Gelder, +! Efficient Computation of Polygon Area and Polyhedron Volume, +! Graphics Gems V, +! edited by Alan Paeth, +! AP Professional, 1995, T385.G6975. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices. +! +! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. +! The vertices should be listed in neighboring order. +! +! Output, real ( kind = 8 ) AREA, the area of the polygon. +! +! Output, real ( kind = 8 ) NORMAL(3), the unit normal vector to the polygon. +! + implicit none + + integer(kind=4) n + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) area + real(kind=8) cross(dim_num) + integer(kind=4) i + integer(kind=4) ip1 + real(kind=8) normal(dim_num) + real(kind=8) v(dim_num, n) + + normal(1:dim_num) = 0.0D+00 + + do i = 1, n + + if (i < n) then + ip1 = i + 1 + else + ip1 = 1 + end if +! +! Compute the cross product vector. +! + cross(1) = v(2, i) * v(3, ip1) - v(3, i) * v(2, ip1) + cross(2) = v(3, i) * v(1, ip1) - v(1, i) * v(3, ip1) + cross(3) = v(1, i) * v(2, ip1) - v(2, i) * v(1, ip1) + + normal(1:dim_num) = normal(1:dim_num) + cross(1:dim_num) + + end do + + area = sqrt(sum(normal(1:dim_num)**2)) + + if (area /= 0.0D+00) then + normal(1:dim_num) = normal(1:dim_num) / area + else + normal(1:dim_num) = 1.0D+00 / sqrt(real(dim_num, kind=8)) + end if + + area = 0.5D+00 * area + + return +end +subroutine polygon_area_3d_2(n, v, area) + +!*****************************************************************************80 +! +!! POLYGON_AREA_3D_2 computes the area of a polygon in 3D. +! +! Discussion: +! +! The computation is not valid unless the vertices of the polygon +! lie in a plane, so that the polygon that is defined is "flat". +! +! The polygon does not have to be "regular", that is, neither its +! sides nor its angles need to be equal. +! +! The area is computed as the sum of the areas of the triangles +! formed by the last node with consecutive pairs of nodes (1,2), +! (2,3), ..., and (N-2,N-1). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 October 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! +! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. +! +! Output, real ( kind = 8 ) AREA, the area of the polygon. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) area + real(kind=8) area_vector(dim_num) + real(kind=8) area_vector_triangle(dim_num) + integer(kind=4) j + real(kind=8) t(dim_num, 3) + real(kind=8) v(dim_num, n) + + area_vector(1:dim_num) = 0.0D+00 + + do j = 1, n - 2 + + t(1:dim_num, 1:3) = reshape((/ & + v(1:dim_num, j), v(1:dim_num, j + 1), v(1:dim_num, n)/), & + (/dim_num, 3/)) + + call triangle_area_vector_3d(t, area_vector_triangle) + + area_vector(1:dim_num) = area_vector(1:dim_num) & + + area_vector_triangle(1:dim_num) + + end do + + area = 0.5D+00 * sqrt(sum(area_vector(1:dim_num)**2)) + + return +end +subroutine polygon_centroid_2d(n, v, centroid) + +!*****************************************************************************80 +! +!! POLYGON_CENTROID_2D computes the centroid of a polygon in 2D. +! +! Discussion: +! +! Denoting the centroid coordinates by CENTROID, then +! +! CENTROID(1) = Integral ( Polygon interior ) x dx dy / Area ( Polygon ) +! CENTROID(2) = Integral ( Polygon interior ) y dx dy / Area ( Polygon ). +! +! Green's theorem states that for continuously differentiable functions +! M(x,y) and N(x,y), +! +! Integral ( Polygon boundary ) ( M dx + N dy ) = +! Integral ( Polygon interior ) ( dN/dx - dM/dy ) dx dy. +! +! Using M(x,y) = 0 and N(x,y) = x*x/2, we get: +! +! CENTROID(1) = 0.5 * Integral ( Polygon boundary ) x*x dy +! / Area ( Polygon ), +! +! which becomes +! +! CENTROID(1) = 1/6 sum ( 1 <= I <= N ) +! ( X(I+1) + X(I) ) * ( X(I) * Y(I+1) - X(I+1) * Y(I)) +! / Area ( Polygon ) +! +! where, when I = N, the index "I+1" is replaced by 1. +! +! A similar calculation gives us a formula for CENTROID(2). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 July 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Gerard Bashein, Paul Detmer, +! Centroid of a Polygon, +! in Graphics Gems IV, +! edited by Paul Heckbert, +! AP Professional, 1994, +! T385.G6974. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of sides of the polygon. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices. +! +! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) centroid(dim_num) + integer(kind=4) i + integer(kind=4) ip1 + real(kind=8) temp + real(kind=8) v(dim_num, n) + + area = 0.0D+00 + centroid(1:dim_num) = 0.0D+00 + + do i = 1, n + + if (i < n) then + ip1 = i + 1 + else + ip1 = 1 + end if + + temp = (v(1, i) * v(2, ip1) - v(1, ip1) * v(2, i)) + + area = area + temp + + centroid(1:dim_num) = centroid(1:dim_num) & + + (v(1:dim_num, ip1) + v(1:dim_num, i)) * temp + + end do + + area = area / 2.0D+00 + + if (area == 0.0D+00) then + centroid(1:dim_num) = v(1:dim_num, 1) + else + centroid(1:dim_num) = centroid(1:dim_num) / (6.0D+00 * area) + end if + + return +end +subroutine polygon_centroid_2d_2(n, v, centroid) + +!*****************************************************************************80 +! +!! POLYGON_CENTROID_2D_2 computes the centroid of a polygon in 2D. +! +! Discussion: +! +! The centroid is the area-weighted sum of the centroids of +! disjoint triangles that make up the polygon. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 July 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices. +! +! Output, real ( kind = 8 ) CENTROID(2), the coordinates of the centroid. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area_polygon + real(kind=8) area_triangle + real(kind=8) centroid(dim_num) + integer(kind=4) i + real(kind=8) t(dim_num, 3) + real(kind=8) v(dim_num, n) + + area_polygon = 0.0D+00 + centroid(1:dim_num) = 0.0D+00 + + do i = 1, n - 2 + + t(1:dim_num, 1:3) = reshape((/ & + v(1:dim_num, i), v(1:dim_num, i + 1), v(1:dim_num, n)/), & + (/dim_num, 3/)) + + call triangle_area_2d(t, area_triangle) + + area_polygon = area_polygon + area_triangle + + centroid(1:dim_num) = centroid(1:dim_num) + area_triangle & + * (v(1:dim_num, i) + v(1:dim_num, i + 1) + v(1:dim_num, n)) / 3.0D+00 + + end do + + if (area_polygon == 0.0D+00) then + centroid(1:dim_num) = v(1:dim_num, 1) + else + centroid(1:dim_num) = centroid(1:dim_num) / area_polygon + end if + + return +end +subroutine polygon_centroid_3d(n, v, centroid) + +!*****************************************************************************80 +! +!! POLYGON_CENTROID_3D computes the centroid of a polygon in 3D. +! +! Discussion: +! +! The polygon is described by its vertices. In many applications, +! these vertices will lie in a common plane, and the polygon will +! be "flat". However, that is not required for this formula. +! +! This formula triangulates the polygon, computes the area of +! each triangle and its centroid, and then computes the centroid +! of the polygon as the weight-averaged sum of the triangle centroids. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 February 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! +! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. +! +! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) area_polygon + real(kind=8) area_triangle + real(kind=8) centroid(dim_num) + integer(kind=4) i + real(kind=8) t(dim_num, 3) + real(kind=8) v(dim_num, n) + + area_polygon = 0.0D+00 + centroid(1:dim_num) = 0.0D+00 + + do i = 1, n - 2 + + t(1:dim_num, 1:3) = reshape((/ & + v(1:dim_num, i), v(1:dim_num, i + 1), v(1:dim_num, n)/), & + (/dim_num, 3/)) + + call triangle_area_3d(t, area_triangle) + + area_polygon = area_polygon + area_triangle + + centroid(1:dim_num) = centroid(1:dim_num) + area_triangle & + * (v(1:dim_num, i) + v(1:dim_num, i + 1) + v(1:dim_num, n)) / 3.0D+00 + + end do + + if (area_polygon == 0.0D+00) then + centroid(1:dim_num) = v(1:dim_num, 1) + else + centroid(1:dim_num) = centroid(1:dim_num) / area_polygon + end if + + return +end +subroutine polygon_contains_point_2d(n, v, p, inside) + +!*****************************************************************************80 +! +!! POLYGON_CONTAINS_POINT_2D finds if a point is inside a polygon. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 November 2016 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of nodes or vertices in +! the polygon. N must be at least 3. +! +! Input, real ( kind = 8 ) V(2,N), the vertices of the polygon. +! +! Input, real ( kind = 8 ) P(2), the coordinates of the point to be tested. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside +! the polygon. +! + implicit none + + integer(kind=4) n + + integer(kind=4) i + logical(kind=4) inside + integer(kind=4) ip1 + real(kind=8) p(2) + real(kind=8) px1 + real(kind=8) px2 + real(kind=8) py1 + real(kind=8) py2 + real(kind=8) v(2, n) + real(kind=8) xints + + inside = .false. + + px1 = v(1, 1) + py1 = v(2, 1) + xints = p(1) - 1.0D+00 + + do i = 1, n + + px2 = v(1, mod(i, n) + 1) + py2 = v(2, mod(i, n) + 1) + + if (min(py1, py2) < p(2)) then + if (p(2) <= max(py1, py2)) then + if (p(1) <= max(px1, px2)) then + if (py1 /= py2) then + xints = (p(2) - py1) * (px2 - px1) / (py2 - py1) + px1 + end if + if (px1 == px2 .or. p(1) <= xints) then + inside = .not. inside + end if + end if + end if + end if + + px1 = px2 + py1 = py2 + + end do + + return +end +subroutine polygon_contains_point_2d_2(n, v, p, inside) + +!*****************************************************************************80 +! +!! POLYGON_CONTAINS_POINT_2D_2: is a point inside a convex polygon in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of nodes or vertices in the +! polygon. N must be at least 3. +! +! Input, real ( kind = 8 ) V(2,N), the vertices of the polygon. +! +! Input, real ( kind = 8 ) P(2), the coordinates of the point to be tested. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside +! the polygon or on its boundary. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) t(dim_num, 3) + real(kind=8) v(dim_num, n) + + inside = .false. +! +! A point is inside a convex polygon if and only if it is inside +! one of the triangles formed by X(1),Y(1) and any two consecutive +! points on the polygon's circumference. +! + t(1:dim_num, 1) = v(1:dim_num, 1) + + do i = 2, n - 1 + + t(1:dim_num, 2) = v(1:dim_num, i) + t(1:dim_num, 3) = v(1:dim_num, i + 1) + + call triangle_contains_point_2d_1(t, p, inside) + + if (inside) then + return + end if + + end do + + return +end +subroutine polygon_contains_point_2d_3(n, v, p, inside) + +!*****************************************************************************80 +! +!! POLYGON_CONTAINS_POINT_2D_3: a point is inside a simple polygon in 2D. +! +! Discussion: +! +! A simple polygon is one whose boundary never crosses itself. +! The polygon does not need to be convex. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 May 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Moshe Shimrat, +! ACM Algorithm 112, +! Position of Point Relative to Polygon, +! Communications of the ACM, +! Volume 5, Number 8, page 434, August 1962. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of nodes or vertices in +! the polygon. N must be at least 3. +! +! Input, real ( kind = 8 ) V(2,N), the vertices of the polygon. +! +! Input, real ( kind = 8 ) P(2), the coordinates of the point to be tested. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is inside +! the polygon. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + logical(kind=4) inside + integer(kind=4) ip1 + real(kind=8) p(dim_num) + real(kind=8) v(dim_num, n) + + inside = .false. + + do i = 1, n + + if (i < n) then + ip1 = i + 1 + else + ip1 = 1 + end if + + if ((v(2, i) < p(2) .and. p(2) <= v(2, ip1)) .or. & + (p(2) <= v(2, i) .and. v(2, ip1) < p(2))) then + if ((p(1) - v(1, i)) - (p(2) - v(2, i)) & + * (v(1, ip1) - v(1, i)) / (v(2, ip1) - v(2, i)) < 0.0D+00) then + inside = .not. inside + end if + end if + + end do + + return +end +subroutine polygon_diameter_2d(n, v, diameter) + +!*****************************************************************************80 +! +!! POLYGON_DIAMETER_2D computes the diameter of a polygon in 2D. +! +! Discussion: +! +! The diameter of a polygon is the maximum distance between any +! two points on the polygon. It is guaranteed that this maximum +! distance occurs between two vertices of the polygon. It is +! sufficient to check the distance between all pairs of vertices. +! This is an N^2 algorithm. There is an algorithm by Shamos which +! can compute this quantity in order N time instead. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! +! Input, real ( kind = 8 ) V(2,N), the vertices. +! +! Output, real ( kind = 8 ) DIAMETER, the diameter of the polygon. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) diameter + integer(kind=4) i + integer(kind=4) j + real(kind=8) v(dim_num, n) + + diameter = 0.0D+00 + + do i = 1, n + + do j = i + 1, n + diameter = max(diameter, & + sqrt((v(1, i) - v(1, j))**2 + (v(2, i) - v(2, j))**2)) + end do + + end do + + return +end +subroutine polygon_expand_2d(n, v, h, w) + +!*****************************************************************************80 +! +!! POLYGON_EXPAND_2D expands a polygon in 2D. +! +! Discussion: +! +! This routine simple moves each vertex of the polygon outwards +! in such a way that the sides of the polygon advance by H. +! +! This approach should always work if the polygon is convex, or +! star-shaped. But for general polygons, it is possible +! that this procedure, for large enough H, will create a polygon +! whose sides intersect. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of sides of the polygon. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices. +! +! Input, real ( kind = 8 ) H, the expansion amount. +! +! Output, real ( kind = 8 ) W(2,N), the "expanded" coordinates. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle + real(kind=8) angle_rad_2d + real(kind=8) h + real(kind=8) h2 + integer(kind=4) i + integer(kind=4) i4_wrap + integer(kind=4) im1 + integer(kind=4) ip1 + real(kind=8) p4(dim_num) + real(kind=8) v(dim_num, n) + real(kind=8) w(dim_num, n) +! +! Consider each angle, formed by the nodes P(I-1), P(I), P(I+1). +! + do i = 1, n + + im1 = i4_wrap(i - 1, 1, n) + ip1 = i4_wrap(i + 1, 1, n) +! +! P1 +! / +! / P4 +! / . +! / . +! P2--------->P3 +! + call angle_half_2d(v(1:dim_num, im1), v(1:dim_num, i), v(1:dim_num, ip1), & + p4) +! +! Compute the value of the half angle. +! + angle = angle_rad_2d(v(1:dim_num, im1), v(1:dim_num, i), p4(1:dim_num)) +! +! The stepsize along the ray must be adjusted so that the sides +! move out by H. +! + h2 = h / sin(angle) + + w(1:dim_num, i) = v(1:dim_num, i) - h2 * (p4(1:dim_num) - v(1:dim_num, i)) + + end do + + return +end +subroutine polygon_inrad_data_2d(n, radin, area, radout, side) + +!*****************************************************************************80 +! +!! POLYGON_INRAD_DATA_2D determines polygonal data from its inner radius in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of sides of the polygon. +! N must be at least 3. +! +! Input, real ( kind = 8 ) RADIN, the inner radius of the polygon, that is, +! the radius of the largest circle that can be inscribed within +! the polygon. +! +! Output, real ( kind = 8 ) AREA, the area of the regular polygon. +! +! Output, real ( kind = 8 ) RADOUT, the outer radius of the polygon, that is, +! the radius of the smallest circle that can be described about +! the polygon. +! +! Output, real ( kind = 8 ) SIDE, the length of one side of the polygon. +! + implicit none + + real(kind=8) angle + real(kind=8) area + integer(kind=4) n + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radin + real(kind=8) radout + real(kind=8) side + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_INRAD_DATA_2D - Fatal error!' + write (*, '(a)') ' Input value of N must be at least 3' + write (*, '(a,i8)') ' but your input value was N = ', n + stop 1 + end if + + angle = r8_pi / real(n, kind=8) + area = real(n, kind=8) * radin * radin * tan(angle) + side = 2.0D+00 * radin * tan(angle) + radout = 0.5D+00 * side / sin(angle) + + return +end +function polygon_is_convex_2d(n, v) + +!*****************************************************************************80 +! +!! POLYGON_IS_CONVEX_2D determines whether a polygon is convex in 2D. +! +! Discussion: +! +! If the polygon has less than 3 distinct vertices, it is +! classified as convex degenerate. +! +! If the polygon "goes around" more than once, it is classified +! as NOT convex. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 May 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Peter Schorn, Frederick Fisher, +! Testing the Convexity of a Polygon, +! in Graphics Gems IV, +! edited by Paul Heckbert, +! AP Professional, 1994, +! T385.G6974. +! +! Parameters +! +! Input, integer ( kind = 4 ) N, the number of vertices. +! +! Input/output, real ( kind = 8 ) V(2,N), the coordinates of the vertices +! of the polygon. On output, duplicate consecutive points have been +! deleted, and the vertices have been reordered so that the +! lexicographically least point comes first. +! +! Output, integer ( kind = 4 ) POLYGON_IS_CONVEX_2D: +! -1, the polygon is not convex; +! 0, the polygon has less than 3 vertices; it is "degenerately" convex; +! 1, the polygon is convex and counter clockwise; +! 2, the polygon is convex and clockwise. +! + implicit none + + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8), parameter :: RAD_TO_DEG = 180.0D+00 / r8_pi + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle + integer(kind=4), parameter :: CONVEX_CCW = 1 + integer(kind=4), parameter :: CONVEX_CW = 2 + real(kind=8) cross + integer(kind=4), parameter :: DEGENERATE_CONVEX = 0 + real(kind=8) dot + real(kind=8) exterior_total + integer(kind=4) i + integer(kind=4) ip1 + integer(kind=4) ip2 + integer(kind=4), parameter :: NOT_CONVEX = -1 + integer(kind=4) polygon_is_convex_2d + real(kind=8) sense + real(kind=8), parameter :: tol = 1.0D+00 + real(kind=8) v(dim_num, n) + + exterior_total = 0.0D+00 +! +! If there are not at least 3 distinct vertices, we are done. +! + if (n < 3) then + polygon_is_convex_2d = DEGENERATE_CONVEX + return + end if + + sense = 0.0D+00 +! +! Consider each polygonal vertex I. +! + do i = 1, n + + ip1 = i + 1 + if (n < ip1) then + ip1 = ip1 - n + end if + + ip2 = i + 2 + if (n < ip2) then + ip2 = ip2 - n + end if + + dot = (v(1, ip2) - v(1, ip1)) * (v(1, i) - v(1, ip1)) & + + (v(2, ip2) - v(2, ip1)) * (v(2, i) - v(2, ip1)) + + cross = (v(1, ip2) - v(1, ip1)) * (v(2, i) - v(2, ip1)) & + - (v(1, i) - v(1, ip1)) * (v(2, ip2) - v(2, ip1)) + + angle = atan2(cross, dot) +! +! See if the turn defined by this vertex is our first indication of +! the "sense" of the polygon, or if it disagrees with the previously +! defined sense. +! + if (sense == 0.0D+00) then + + if (angle < 0.0D+00) then + sense = -1.0D+00 + else if (0.0D+00 < angle) then + sense = +1.0D+00 + end if + + else if (sense == 1.0D+00) then + + if (angle < 0.0D+00) then + polygon_is_convex_2d = NOT_CONVEX + return + end if + + else if (sense == -1.0D+00) then + + if (0.0D+00 < angle) then + polygon_is_convex_2d = NOT_CONVEX + return + end if + + end if +! +! If the exterior total is greater than 360, then the polygon is +! going around again. +! + angle = atan2(-cross, -dot) + + exterior_total = exterior_total + angle + + if (360.0D+00 + tol < abs(exterior_total) * RAD_TO_DEG) then + polygon_is_convex_2d = NOT_CONVEX + return + end if + + end do + + if (sense == +1.0D+00) then + polygon_is_convex_2d = CONVEX_CCW + else if (sense == -1.0D+00) then + polygon_is_convex_2d = CONVEX_CW + end if + + return +end +subroutine polygon_lattice_area_2d(i, b, area) + +!*****************************************************************************80 +! +!! POLYGON_LATTICE_AREA_2D computes the area of a lattice polygon in 2D. +! +! Discussion: +! +! We define a lattice to be the 2D plane, in which the points +! whose (X,Y) coordinates are both integers are given a special +! status as "lattice points". +! +! A lattice polygon is a polygon whose vertices are lattice points. +! +! The area of a lattice polygon can be computed by Pick's Theorem: +! +! Area = I + B / 2 - 1 +! +! where +! +! I = the number of lattice points contained strictly inside the polygon; +! +! B = the number of lattice points that lie exactly on the boundary. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 June 2002 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Branko Gruenbaum, Geoffrey Shephard, +! Pick's Theorem, +! The American Mathematical Monthly, +! Volume 100, Number 2, February 1993, pages 150-161. +! +! Parameters: +! +! Input, integer ( kind = 4 ) I, the number of interior lattice points. +! +! Input, integer ( kind = 4 ) B, the number of boundary lattice points. +! +! Output, real ( kind = 8 ) AREA, the area of the lattice polygon. +! + implicit none + + real(kind=8) area + integer(kind=4) b + integer(kind=4) i + + area = real(i, kind=8) + real(b, kind=8) / 2.0D+00 - 1.0D+00 + + return +end +subroutine polygon_normal_3d(n, v, normal) + +!*****************************************************************************80 +! +!! POLYGON_NORMAL_3D computes the normal vector to a polygon in 3D. +! +! Discussion: +! +! If the polygon is planar, then this calculation is correct. +! +! Otherwise, the normal vector calculated is the simple average +! of the normals defined by the planes of successive triples +! of vertices. +! +! If the polygon is "almost" planar, this is still acceptable. +! But as the polygon is less and less planar, so this averaged normal +! vector becomes more and more meaningless. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 August 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, +! Point in Polyhedron Testing Using Spherical Polygons, +! in Graphics Gems V, +! edited by Alan Paeth, +! Academic Press, 1995, +! ISBN: 0125434553, +! LC: T385.G6975. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices. +! +! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. +! +! Output, real ( kind = 8 ) NORMAL(3), the averaged normal vector +! to the polygon. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) n + + real(kind=8) r8vec_norm + integer(kind=4) j + real(kind=8) normal(dim_num) + real(kind=8) normal_norm + real(kind=8) p(dim_num) + real(kind=8) v(dim_num, n) + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) + + normal(1:dim_num) = 0.0D+00 + + v1(1:dim_num) = v(1:dim_num, 2) - v(1:dim_num, 1) + + do j = 3, n + + v2(1:dim_num) = v(1:dim_num, j) - v(1:dim_num, 1) + + call r8vec_cross_product_3d(v1, v2, p) + + normal(1:dim_num) = normal(1:dim_num) + p(1:dim_num) + + v1(1:dim_num) = v2(1:dim_num) + + end do +! +! Normalize. +! + normal_norm = r8vec_norm(dim_num, normal) + + if (normal_norm == 0.0D+00) then + return + end if + + normal(1:dim_num) = normal(1:dim_num) / normal_norm + + return +end +subroutine polygon_outrad_data_2d(n, radout, area, radin, side) + +!*****************************************************************************80 +! +!! POLYGON_OUTRAD_DATA_2D determines polygonal data from its outer radius in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of sides of the polygon. +! N must be at least 3. +! +! Input, real ( kind = 8 ) RADOUT, the outer radius of the polygon, that is, +! the radius of the smallest circle that can be described +! around the polygon. +! +! Output, real ( kind = 8 ) AREA, the area of the regular polygon. +! +! Output, real ( kind = 8 ) RADIN, the inner radius of the polygon, that is, +! the radius of the largest circle that can be inscribed +! within the polygon. +! +! Output, real ( kind = 8 ) SIDE, the length of one side of the polygon. +! + implicit none + + real(kind=8) angle + real(kind=8) area + integer(kind=4) n + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radin + real(kind=8) radout + real(kind=8) side + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_OUTRAD_DATA_2D - Fatal error!' + write (*, '(a)') ' Input value of N must be at least 3' + write (*, '(a,i8)') ' but your input value was N = ', n + stop 1 + end if + + angle = r8_pi / real(n, kind=8) + area = 0.5D+00 * real(n, kind=8) * radout * radout & + * sin(2.0D+00 * angle) + side = 2.0D+00 * radout * sin(angle) + radin = 0.5D+00 * side / tan(angle) + + return +end +subroutine polygon_point_dist_2d(n, v, p, dist) + +!*****************************************************************************80 +! +!! POLYGON_POINT_DIST_2D: distance ( polygon, point ) in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices. +! +! Input, real ( kind = 8 ) V(2,N), the triangle vertices. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! polygon. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) dist2 + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) p(dim_num) + real(kind=8) v(dim_num, n) +! +! Find the distance to each of the line segments. +! + dist = huge(dist) + + do j = 1, n + + jp1 = i4_wrap(j + 1, 1, n) + + call segment_point_dist_2d(v(1:dim_num, j), v(1:dim_num, jp1), p, dist2) + + if (dist2 < dist) then + dist = dist2 + end if + + end do + + return +end +subroutine polygon_point_near_2d(n, v, p, pn, dist) + +!*****************************************************************************80 +! +!! POLYGON_POINT_NEAR_2D computes the nearest point on a polygon in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V(2,N), the polygon vertices. +! +! Input, real ( kind = 8 ) P(2), the point whose nearest polygon point +! is to be determined. +! +! Output, real ( kind = 8 ) PN(2), the nearest point to P. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! polygon. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) dist2 + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) pn2(dim_num) + real(kind=8) tval + real(kind=8) v(dim_num, n) +! +! Find the distance to each of the line segments that make up the edges +! of the polygon. +! + dist = huge(dist) + pn(1:dim_num) = 0.0D+00 + + do j = 1, n + + jp1 = i4_wrap(j + 1, 1, n) + + call segment_point_near_2d(v(1:dim_num, j), v(1:dim_num, jp1), p, & + pn2, dist2, tval) + + if (dist2 < dist) then + dist = dist2 + pn(1:dim_num) = pn2(1:dim_num) + end if + + end do + + return +end +subroutine polygon_side_data_2d(n, side, area, radin, radout) + +!*****************************************************************************80 +! +!! POLYGON_SIDE_DATA_2D determines polygonal data from its side length in 2D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 June 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of sides of the polygon. +! N must be at least 3. +! +! Input, real ( kind = 8 ) SIDE, the length of one side of the polygon. +! +! Output, real ( kind = 8 ) AREA, the area of the regular polygon. +! +! Output, real ( kind = 8 ) RADIN, the inner radius of the polygon, that is, +! the radius of the largest circle that can be inscribed within +! the polygon. +! +! Output, real ( kind = 8 ) RADOUT, the outer radius of the polygon, that is, +! the radius of the smallest circle that can be described about +! the polygon. +! + implicit none + + real(kind=8) angle + real(kind=8) area + integer(kind=4) n + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radin + real(kind=8) radout + real(kind=8) side + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_SIDE_DATA_2D - Fatal error!' + write (*, '(a)') ' Input value of N must be at least 3' + write (*, '(a,i8)') ' but your input value was N = ', n + stop 1 + end if + + angle = r8_pi / real(n, kind=8) + area = 0.25D+00 * real(n, kind=8) * side * side / tan(angle) + radin = 0.5D+00 * side / tan(angle) + radout = 0.5D+00 * side / sin(angle) + + return +end +subroutine polygon_solid_angle_3d(n, v, p, solid_angle) + +!*****************************************************************************80 +! +!! POLYGON_SOLID_ANGLE_3D: projected solid angle of a 3D plane polygon. +! +! Discussion: +! +! A point P is at the center of a unit sphere. A planar polygon +! is to be projected onto the surface of this sphere, by drawing +! the ray from P to each polygonal vertex, and noting where this ray +! intersects the sphere. +! +! We compute the area on the sphere of the projected polygon. +! +! Since we are projecting the polygon onto a unit sphere, the area +! of the projected polygon is equal to the solid angle subtended by +! the polygon. +! +! The value returned by this routine will include a sign. The +! angle subtended will be NEGATIVE if the normal vector defined by +! the polygon points AWAY from the viewing point, and will be +! POSITIVE if the normal vector points towards the viewing point. +! +! If the orientation of the polygon is of no interest to you, +! then you can probably simply take the absolute value of the +! solid angle as the information you want. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 October 2007 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, +! Point in Polyhedron Testing Using Spherical Polygons, +! in Graphics Gems V, +! edited by Alan Paeth, +! Academic Press, 1995, +! ISBN: 0125434553, +! LC: T385.G6975. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices. +! +! Input, real ( kind = 8 ) V(3,N), the coordinates of the vertices. +! +! Input, real ( kind = 8 ) P(3), the point at the center of the unit sphere. +! +! Output, double SOLID_ANGLE, the solid angle subtended +! by the polygon, as projected onto the unit sphere around the point P. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) n + + real(kind=8) a(dim_num) + real(kind=8) angle + real(kind=8) area + real(kind=8) b(dim_num) + real(kind=8) r8vec_norm + real(kind=8) r8vec_scalar_triple_product + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) normal1(dim_num) + real(kind=8) normal1_norm + real(kind=8) normal2(dim_num) + real(kind=8) normal2_norm + real(kind=8) p(dim_num) + real(kind=8) plane(dim_num) + real(kind=8) r1(dim_num) + real(kind=8) r8_acos + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) s + real(kind=8) solid_angle + real(kind=8) v(dim_num, n) + + if (n < 3) then + solid_angle = 0.0D+00 + return + end if + + call polygon_normal_3d(n, v, plane) + + a(1:dim_num) = v(1:dim_num, n) - v(1:dim_num, 1) + + area = 0.0D+00 + + do j = 1, n + + r1(1:dim_num) = v(1:dim_num, j) - p(1:dim_num) + + jp1 = i4_wrap(j + 1, 1, n) + + b(1:dim_num) = v(1:dim_num, jp1) - v(1:dim_num, j) + + call r8vec_cross_product_3d(a, r1, normal1) + + normal1_norm = r8vec_norm(dim_num, normal1) + + call r8vec_cross_product_3d(r1, b, normal2) + + normal2_norm = r8vec_norm(dim_num, normal2) + + s = dot_product(normal1(1:dim_num), normal2(1:dim_num)) & + / (normal1_norm * normal2_norm) + + angle = r8_acos(s) + + s = r8vec_scalar_triple_product(b, a, plane) + + if (0.0D+00 < s) then + area = area + r8_pi - angle + else + area = area + r8_pi + angle + end if + + a(1:dim_num) = -b(1:dim_num) + + end do + + area = area - r8_pi * real(n - 2, kind=8) + + if (0.0D+00 < dot_product(plane(1:dim_num), r1(1:dim_num))) then + solid_angle = -area + else + solid_angle = area + end if + + return +end +subroutine polygon_x_2d(n, v, result) + +!*****************************************************************************80 +! +!! POLYGON_X_2D integrates the function X over a polygon in 2D. +! +! Discussion: +! +! The polygon is bounded by the points (X(1:N), Y(1:N)). +! +! INTEGRAL = (1/6) * sum ( 1 <= I <= N ) +! ( X(I)*X(I) + X(I) * X(I-1) + X(I-1)*X(I-1) ) * ( Y(I) - Y(I-1) ) +! +! where X(0) and Y(0) should be replaced by X(N) and Y(N). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! SF Bockman, +! Generalizing the Formula for Areas of Polygons to Moments, +! American Mathematical Society Monthly, +! 1989, pages 131-132. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! N should be at least 3 for a nonzero result. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices +! of the polygon. These vertices should be given in counter clockwise order. +! +! Output, real ( kind = 8 ) RESULT, the value of the integral. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + integer(kind=4) im1 + real(kind=8) result + real(kind=8) v(2, n) + + result = 0.0D+00 + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_X_2D - Fatal error!' + write (*, '(a)') ' The number of vertices must be at least 3.' + write (*, '(a,i8)') ' The input value of N = ', n + stop 1 + end if + + do i = 1, n + + if (i == 1) then + im1 = n + else + im1 = i - 1 + end if + + result = result + (v(1, i)**2 + v(1, i) * v(1, im1) + v(1, im1)**2) & + * (v(2, i) - v(2, im1)) + + end do + + result = result / 6.0D+00 + + return +end +subroutine polygon_xx_2d(n, v, result) + +!*****************************************************************************80 +! +!! POLYGON_XX_2D integrates the function X*X over a polygon in 2D. +! +! Discussion: +! +! The polygon is bounded by the points (X(1:N), Y(1:N)). +! +! INTEGRAL = (1/12) * sum ( 1 <= I <= N ) +! ( X(I)^3 + X(I)^2 * X(I-1) + X(I) * X(I-1)^2 + X(I-1)^3 ) +! * ( Y(I) - Y(I-1) ) +! +! where X(0) and Y(0) should be replaced by X(N) and Y(N). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! SF Bockman, +! Generalizing the Formula for Areas of Polygons to Moments, +! American Mathematical Society Monthly, +! 1989, pages 131-132. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! N should be at least 3 for a nonzero result. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices +! of the polygon. These vertices should be given in +! counter clockwise order. +! +! Output, real ( kind = 8 ) RESULT, the value of the integral. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + integer(kind=4) im1 + real(kind=8) result + real(kind=8) v(2, n) + + result = 0.0D+00 + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_XX_2D - Fatal error!' + write (*, '(a)') ' The number of vertices must be at least 3.' + write (*, '(a,i8)') ' The input value of N = ', n + stop 1 + end if + + do i = 1, n + + if (i == 1) then + im1 = n + else + im1 = i - 1 + end if + + result = result + (v(1, i)**3 + v(1, i)**2 * v(1, im1) & + + v(1, i) * v(1, im1)**2 + v(1, im1)**3) * (v(2, i) - v(2, im1)) + + end do + + result = result / 12.0D+00 + + return +end +subroutine polygon_xy_2d(n, v, result) + +!*****************************************************************************80 +! +!! POLYGON_XY_2D integrates the function X*Y over a polygon in 2D. +! +! Discussion: +! +! The polygon is bounded by the points (X(1:N), Y(1:N)). +! +! INTEGRAL = (1/24) * sum ( 1 <= I <= N ) +! ( Y(I) * ( 3 * X(I)^2 + 2 * X(I) * X(I-1) + X(I-1)^2 ) +! + Y(I-1) * ( X(I)^2 + 2 * X(I) * X(I-1) + 3 * X(I-1)^2 ) ) +! * ( Y(I) - Y(I-1) ) +! +! where X(0) and Y(0) should be replaced by X(N) and Y(N). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! SF Bockman, +! Generalizing the Formula for Areas of Polygons to Moments, +! American Mathematical Society Monthly, +! 1989, pages 131-132. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! N should be at least 3 for a nonzero result. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices +! of the polygon. These vertices should be given in +! counter clockwise order. +! +! Output, real ( kind = 8 ) RESULT, the value of the integral. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + integer(kind=4) im1 + real(kind=8) result + real(kind=8) v(dim_num, n) + + result = 0.0D+00 + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_XY_2D - Fatal error!' + write (*, '(a)') ' The number of vertices must be at least 3.' + write (*, '(a,i8)') ' The input value of N = ', n + stop 1 + end if + + do i = 1, n + + if (i == 1) then + im1 = n + else + im1 = i - 1 + end if + + result = result + ( & + v(2, i) * (3.0D+00 * v(1, i)**2 + 2.0D+00 * v(1, i) * v(1, im1) & + + v(1, im1)**2) + v(2, im1) * (v(1, i)**2 + 2.0D+00 * v(1, i) * v(1, im1) & + + 3.0D+00 * v(1, im1)**2)) * (v(2, i) - v(2, im1)) + + end do + + result = result / 24.0D+00 + + return +end +subroutine polygon_y_2d(n, v, result) + +!*****************************************************************************80 +! +!! POLYGON_Y_2D integrates the function Y over a polygon in 2D. +! +! Discussion: +! +! The polygon is bounded by the points (X(1:N), Y(1:N)). +! +! INTEGRAL = (1/6) * sum ( 1 <= I <= N ) +! - ( Y(I)^2 + Y(I) * Y(I-1) + Y(I-1)^2 ) * ( X(I) - X(I-1) ) +! +! where X(0) and Y(0) should be replaced by X(N) and Y(N). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! SF Bockman, +! Generalizing the Formula for Areas of Polygons to Moments, +! American Mathematical Society Monthly, +! 1989, pages 131-132. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! N should be at least 3 for a nonzero result. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices +! of the polygon. These vertices should be given in +! counter clockwise order. +! +! Output, real ( kind = 8 ) RESULT, the value of the integral. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + integer(kind=4) im1 + real(kind=8) result + real(kind=8) v(dim_num, n) + + result = 0.0D+00 + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_Y_2D - Fatal error!' + write (*, '(a)') ' The number of vertices must be at least 3.' + write (*, '(a,i8)') ' The input value of N = ', n + stop 1 + end if + + do i = 1, n + + if (i == 1) then + im1 = n + else + im1 = i - 1 + end if + + result = result - (v(2, i)**2 + v(2, i) * v(2, im1) + v(2, im1)**2) & + * (v(1, i) - v(1, im1)) + + end do + + result = result / 6.0D+00 + + return +end +subroutine polygon_yy_2d(n, v, result) + +!*****************************************************************************80 +! +!! POLYGON_YY_2D integrates the function Y*Y over a polygon in 2D. +! +! Discussion: +! +! The polygon is bounded by the points (X(1:N), Y(1:N)). +! +! INTEGRAL = (1/12) * sum ( 1 <= I <= N ) +! - ( Y(I)^3 + Y(I)^2 * Y(I-1) + Y(I) * Y(I-1)^2 + Y(I-1)^3 ) +! * ( X(I) - X(I-1) ) +! +! where X(0) and Y(0) should be replaced by X(N) and Y(N). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! SF Bockman, +! Generalizing the Formula for Areas of Polygons to Moments, +! American Mathematical Society Monthly, +! 1989, pages 131-132. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices of the polygon. +! N should be at least 3 for a nonzero result. +! +! Input, real ( kind = 8 ) V(2,N), the coordinates of the vertices +! of the polygon. These vertices should be given in +! counter clockwise order. +! +! Output, real ( kind = 8 ) RESULT, the value of the integral. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) i + integer(kind=4) im1 + real(kind=8) result + real(kind=8) v(dim_num, n) + + result = 0.0D+00 + + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYGON_YY_2D - Fatal error!' + write (*, '(a)') ' The number of polygonal vertices must be ' + write (*, '(a,i8)') ' at least 3, but the input polygon has N = ', n + stop 1 + end if + + do i = 1, n + + if (i == 1) then + im1 = n + else + im1 = i - 1 + end if + + result = result - (v(2, i)**3 + v(2, i)**2 * v(2, im1) & + + v(2, i) * v(2, im1)**2 + v(2, im1)**3) * (v(1, i) - v(1, im1)) + + end do + + result = result / 12.0D+00 + + return +end +subroutine polyhedron_area_3d(coord, order_max, face_num, node, & + node_num, order, area) + +!*****************************************************************************80 +! +!! POLYHEDRON_AREA_3D computes the surface area of a polyhedron in 3D. +! +! Discussion: +! +! The computation is not valid unless the faces of the polyhedron +! are planar polygons. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 April 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Allen Van Gelder, +! Efficient Computation of Polygon Area and Polyhedron Volume, +! in Graphics Gems V, +! edited by Alan Paeth, +! AP Professional, 1995, T385.G6975 +! +! Parameters: +! +! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of the +! vertices. The vertices may be listed in any order. +! +! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices +! that make up a face of the polyhedron. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the +! polyhedron. +! +! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined +! by the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices +! are listed in neighboring order. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. +! +! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices +! making up each face. +! +! Output, real ( kind = 8 ) AREA, the total surface area of the polyhedron. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) node_num + + real(kind=8) ainc + real(kind=8) area + real(kind=8) coord(dim_num, node_num) + integer(kind=4) face + integer(kind=4) j + integer(kind=4) k1 + integer(kind=4) k2 + integer(kind=4) node(face_num, order_max) + integer(kind=4) order(face_num) + real(kind=8) v(dim_num) + + area = 0.0D+00 +! +! For each face +! + do face = 1, face_num + + v(1:dim_num) = 0.0D+00 +! +! For each triangle in the face, compute the normal vector. +! + do j = 1, order(face) + + k1 = node(face, j) + + if (j < order(face)) then + k2 = node(face, j + 1) + else + k2 = node(face, 1) + end if +! +! Compute the cross product. +! + v(1) = v(1) + coord(2, k1) * coord(3, k2) - coord(3, k1) * coord(2, k2) + v(2) = v(2) + coord(3, k1) * coord(1, k2) - coord(1, k1) * coord(3, k2) + v(3) = v(3) + coord(1, k1) * coord(2, k2) - coord(2, k1) * coord(1, k2) + + end do +! +! Add the magnitude of the normal vector to the sum. +! + ainc = sqrt(sum(v(1:dim_num)**2)) + area = area + ainc + + end do + + area = 0.5D+00 * area + + return +end +subroutine polyhedron_centroid_3d(coord, order_max, face_num, node, & + node_num, order, centroid) + +!*****************************************************************************80 +! +!! POLYHEDRON_CENTROID_3D computes the centroid of a polyhedron in 3D. +! +! Discussion: +! +! The centroid can be computed as the volume-weighted average of +! the centroids of the tetrahedra defined by choosing a point in +! the interior of the polyhedron, and using as a base every triangle +! created by triangulating the faces of the polyhedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the vertices. +! The vertices may be listed in any order. +! +! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices +! that make up a face of the polyhedron. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the +! polyhedron. +! +! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined +! by the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices +! are listed in neighboring order. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. +! +! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices making +! up each face. +! +! Output, real ( kind = 8 ) CENTROID(3), the centroid of the polyhedron. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) node_num + + real(kind=8) area + real(kind=8) centroid(dim_num) + real(kind=8) coord(dim_num, node_num) + integer(kind=4) face + integer(kind=4) n1 + integer(kind=4) n2 + integer(kind=4) n3 + integer(kind=4) node(face_num, order_max) + real(kind=8) normal(dim_num) + integer(kind=4) order(face_num) + real(kind=8) point(dim_num) + real(kind=8) polygon_area + real(kind=8) polygon_centroid(dim_num) + real(kind=8) tetra(dim_num, 4) + real(kind=8) tetra_centroid(dim_num) + real(kind=8) tetra_volume + integer(kind=4) vert + integer(kind=4) vert_num + real(kind=8) volume + real(kind=8) v(dim_num, order_max) +! +! Compute a point in the interior. +! We take the area-weighted centroid of each face. +! + point(1:dim_num) = 0.0D+00 + area = 0.0D+00 + + do face = 1, face_num + + vert_num = order(face) + + v(1:dim_num, 1:vert_num) = coord(1:dim_num, node(face, 1:vert_num)) + + call polygon_area_3d(vert_num, v, polygon_area, normal) + + call polygon_centroid_3d(vert_num, v, polygon_centroid) + + point(1:dim_num) = point(1:dim_num) & + + polygon_area * polygon_centroid(1:dim_num) + + area = area + polygon_area + + end do + + point(1:dim_num) = point(1:dim_num) / area +! +! Now triangulate each face. +! For each triangle, consider the tetrahedron created by including POINT. +! + centroid(1:dim_num) = 0.0D+00 + volume = 0.0D+00 + + do face = 1, face_num + + n3 = node(face, order(face)) + + do vert = 1, order(face) - 2 + + n1 = node(face, vert) + n2 = node(face, vert + 1) + + tetra(1:dim_num, 1:4) = reshape((/ & + coord(1:dim_num, n1), coord(1:dim_num, n2), coord(1:dim_num, n3), & + point(1:dim_num)/), (/dim_num, 4/)) + + call tetrahedron_volume_3d(tetra, tetra_volume) + + call tetrahedron_centroid_3d(tetra, tetra_centroid) + + centroid(1:dim_num) = centroid(1:dim_num) & + + tetra_volume * tetra_centroid(1:dim_num) + + volume = volume + tetra_volume + + end do + end do + + centroid(1:dim_num) = centroid(1:dim_num) / volume + + return +end +subroutine polyhedron_contains_point_3d(node_num, face_num, & + face_order_max, v, face_order, face_point, p, inside) + +!*****************************************************************************80 +! +!! POLYHEDRON_CONTAINS_POINT_3D determines if a point is inside a polyhedron. +! +! Discussion: +! +! The reference states that the polyhedron should be simple (that +! is, the faces should form a single connected surface), and that +! the individual faces should be consistently oriented. +! +! However, the polyhedron does not, apparently, need to be convex. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 August 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, +! Point in Polyhedron Testing Using Spherical Polygons, +! in Graphics Gems V, +! edited by Alan Paeth, +! Academic Press, 1995, +! ISBN: 0125434553, +! LC: T385.G6975. +! +! Parameters: +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of vertices. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! +! Input, real ( kind = 8 ) V(3,NODE_NUM), the coordinates of the vertices. +! +! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the order of each face. +! +! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM), the +! indices of the nodes that make up each face. +! +! Input, real ( kind = 8 ) P(3), the point to be tested. +! +! Output, logical ( kind = 4 ) INSIDE, is true if the point +! is inside the polyhedron. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) node_num + + real(kind=8) area + integer(kind=4) face + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + logical(kind=4) inside + integer(kind=4) k + integer(kind=4) node + integer(kind=4) node_num_face + real(kind=8) p(dim_num) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) solid_angle + real(kind=8) v(dim_num, node_num) + real(kind=8) v_face(dim_num, face_order_max) + + area = 0.0D+00 + + do face = 1, face_num + + node_num_face = face_order(face) + + do k = 1, node_num_face + + node = face_point(k, face) + + v_face(1:dim_num, k) = v(1:dim_num, node) + + end do + + call polygon_solid_angle_3d(node_num_face, v_face, p, solid_angle) + + area = area + solid_angle + + end do +! +! AREA should be -4*PI, 0, or 4*PI. +! So this test should be quite safe! +! + if (area < -2.0D+00 * r8_pi .or. 2.0D+00 * r8_pi < area) then + inside = .true. + else + inside = .false. + end if + + return +end +subroutine polyhedron_volume_3d(coord, order_max, face_num, node, & + node_num, order, volume) + +!*****************************************************************************80 +! +!! POLYHEDRON_VOLUME_3D computes the volume of a polyhedron in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of +! the vertices. The vertices may be listed in any order. +! +! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices +! that make up a face of the polyhedron. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the +! polyhedron. +! +! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined by +! the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices +! are listed in neighboring order. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. +! +! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices making +! up each face. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) node_num + + real(kind=8) coord(dim_num, node_num) + integer(kind=4) face + integer(kind=4) n1 + integer(kind=4) n2 + integer(kind=4) n3 + integer(kind=4) node(face_num, order_max) + integer(kind=4) order(face_num) + integer(kind=4) v + real(kind=8) volume + + volume = 0.0D+00 +! +! Triangulate each face. +! + do face = 1, face_num + + n3 = node(face, order(face)) + + do v = 1, order(face) - 2 + + n1 = node(face, v) + n2 = node(face, v + 1) + + volume = volume & + + coord(1, n1) & + * (coord(2, n2) * coord(3, n3) - coord(2, n3) * coord(3, n2)) & + + coord(1, n2) & + * (coord(2, n3) * coord(3, n1) - coord(2, n1) * coord(3, n3)) & + + coord(1, n3) & + * (coord(2, n1) * coord(3, n2) - coord(2, n2) * coord(3, n1)) + + end do + + end do + + volume = volume / 6.0D+00 + + return +end +subroutine polyhedron_volume_3d_2(coord, order_max, face_num, node, & + node_num, order, volume) + +!*****************************************************************************80 +! +!! POLYHEDRON_VOLUME_3D_2 computes the volume of a polyhedron in 3D. +! +! Discussion: +! +! The computation is not valid unless the faces of the polyhedron +! are planar polygons. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 August 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Allen Van Gelder, +! Efficient Computation of Polygon Area and Polyhedron Volume, +! in Graphics Gems V, +! edited by Alan Paeth, +! AP Professional, 1995, T385.G6975. +! +! Parameters: +! +! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the vertices. +! The vertices may be listed in any order. +! +! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices +! that make up a face of the polyhedron. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the +! polyhedron. +! +! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is defined +! by the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices +! are listed in neighboring order. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in COORD. +! +! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices making +! up each face. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) node_num + + real(kind=8) coord(dim_num, node_num) + integer(kind=4) face + integer(kind=4) j + integer(kind=4) k + integer(kind=4) k1 + integer(kind=4) k2 + integer(kind=4) node(face_num, order_max) + real(kind=8) normal(dim_num) + integer(kind=4) order(face_num) + real(kind=8) v(dim_num) + real(kind=8) volume + + volume = 0.0D+00 + + do face = 1, face_num + + v(1:dim_num) = 0.0D+00 +! +! Compute the area vector for this face. +! + do j = 1, order(face) + + k1 = node(face, j) + + if (j < order(face)) then + k2 = node(face, j + 1) + else + k2 = node(face, 1) + end if +! +! Compute the cross product. +! + normal(1) = coord(2, k1) * coord(3, k2) - coord(3, k1) * coord(2, k2) + normal(2) = coord(3, k1) * coord(1, k2) - coord(1, k1) * coord(3, k2) + normal(3) = coord(1, k1) * coord(2, k2) - coord(2, k1) * coord(1, k2) + + v(1:dim_num) = v(1:dim_num) + normal(1:dim_num) + + end do +! +! Area vector dot any vertex. +! + k = node(face, 1) + volume = volume + dot_product(v(1:dim_num), coord(1:dim_num, k)) + + end do + + volume = volume / 6.0D+00 + + return +end +subroutine polyline_arclength_nd(dim_num, n, p, s) + +!*****************************************************************************80 +! +!! POLYLINE_ARCLENGTH_ND computes the arclength of points on a polyline in ND. +! +! Discussion: +! +! A polyline of order N is the geometric structure consisting of +! the N-1 line segments that lie between successive elements of a list +! of N points. +! +! An ordinary line segment is a polyline of order 2. +! The letter "V" is a polyline of order 3. +! The letter "N" is a polyline of order 4, and so on. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) N, the number of points defining the polyline. +! +! Input, real ( kind = 8 ) P(DIM_NUM,N), the points defining the polyline. +! +! Output, real ( kind = 8 ) S(N), the arclength coordinates +! of each point. The first point has S(1) = 0 and the +! last point has S(N) = arclength of the entire polyline. +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) n + + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) s(n) + + s(1) = 0.0D+00 + + do i = 2, n + + s(i) = s(i - 1) + sqrt(sum((p(1:dim_num, i) - p(1:dim_num, i - 1))**2)) + + end do + + return +end +subroutine polyline_index_point_nd(dim_num, n, p, t, pt) + +!*****************************************************************************80 +! +!! POLYLINE_INDEX_POINT_ND evaluates a polyline at a given arclength in ND. +! +! Discussion: +! +! The polyline is defined as the set of N-1 line segments lying +! between a sequence of N points. The arclength of a point lying +! on the polyline is simply the length of the broken line from the +! initial point. Any point on the polyline can be found by +! specifying its arclength. +! +! If the given arclength coordinate is less than 0, or greater +! than the arclength coordinate of the last given point, then +! extrapolation is used, that is, the first and last line segments +! are extended as necessary. +! +! The arclength coordinate system measures the distance between +! any two points on the polyline as the length of the segment of the +! line that joins them. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) N, the number of points defining the polyline. +! +! Input, real ( kind = 8 ) P(DIM_NUM,N), the points defining the polyline. +! +! Input, real ( kind = 8 ) T, the desired arclength coordinate. +! +! Output, real ( kind = 8 ) PT(DIM_NUM), the point corresponding to the +! arclength. +! + implicit none + + integer(kind=4) n + integer(kind=4) dim_num + + integer(kind=4) i + real(kind=8) p(dim_num, n) + real(kind=8) pt(dim_num) + real(kind=8) t + real(kind=8) t1 + real(kind=8) t2 + + if (n <= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'POLYLINE_INDEX_POINT_ND - Fatal error!' + write (*, '(a)') ' The input quantity N is nonpositive.' + write (*, '(a,i8)') ' N = ', n + stop 1 + end if + + if (n == 1) then + + pt(1:dim_num) = p(1:dim_num, 1) + + else + + t2 = 0.0D+00 + + do i = 1, n - 1 +! +! Find the distance between points I and I+1. +! + t1 = t2 + t2 = t1 + sqrt(sum((p(1:dim_num, i + 1) - p(1:dim_num, i))**2)) +! +! Interpolate or extrapolate in an interval. +! + if (t <= t2 .or. i == n - 1) then + + pt(1:dim_num) = ((t2 - t) * p(1:dim_num, i) & + + (t - t1) * p(1:dim_num, i + 1)) & + / (t2 - t1) + + return + end if + end do + end if + + return +end +subroutine polyline_length_nd(dim_num, nk, pk, length) + +!*****************************************************************************80 +! +!! POLYLINE_LENGTH_ND computes the length of a polyline in ND. +! +! Discussion: +! +! A polyline of order NK is the geometric structure consisting of +! the NK-1 line segments that lie between successive elements of a list +! of NK points. +! +! An ordinary line segment is a polyline of order 2. +! The letter "V" is a polyline of order 3. +! The letter "N" is a polyline of order 4, and so on. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) NK, the number of points defining the polyline. +! +! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyline. +! +! Output, real ( kind = 8 ) LENGTH, the length of the polyline. +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) nk + + integer(kind=4) i + real(kind=8) length + real(kind=8) pk(dim_num, nk) + + length = 0.0D+00 + + do i = 2, nk + + length = length & + + sqrt(sum((pk(1:dim_num, i) - pk(1:dim_num, i - 1))**2)) + + end do + + return +end +subroutine polyline_points_nd(dim_num, n, p, nt, pt) + +!*****************************************************************************80 +! +!! POLYLINE_POINTS_ND computes equally spaced points on a polyline in ND. +! +! Discussion: +! +! A polyline of order N is the geometric structure consisting of +! the N-1 line segments that lie between successive elements of a list +! of N points. +! +! An ordinary line segment is a polyline of order 2. +! The letter "V" is a polyline of order 3. +! The letter "N" is a polyline of order 4, and so on. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) N, the number of points defining the polyline. +! +! Input, real ( kind = 8 ) P(DIM_NUM,N), the points defining the polyline. +! +! Input, integer ( kind = 4 ) NT, the number of points to be sampled. +! +! Output, real ( kind = 8 ) PT(DIM_NUM,NT), equally spaced points +! on the polyline. +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) n + integer(kind=4) nt + + integer(kind=4) it + integer(kind=4) j + real(kind=8) p(dim_num, n) + real(kind=8) pt(dim_num, nt) + real(kind=8) s(n) + real(kind=8) st + + call polyline_arclength_nd(dim_num, n, p, s) + + j = 1 + + do it = 1, nt + + st = (real(nt - it, kind=8) * 0.0D+00 + & + real(it - 1, kind=8) * s(n)) & + / real(nt - 1, kind=8) + + do + + if (s(j) <= st .and. st <= s(j + 1)) then + exit + end if + + if (n - 1 <= j) then + exit + end if + + j = j + 1 + + end do + + pt(1:dim_num, it) = ((s(j + 1) - st) * p(1:dim_num, j) & + + (st - s(j)) * p(1:dim_num, j + 1)) & + / (s(j + 1) - s(j)) + + end do + + return +end +subroutine polyloop_arclength_nd(dim_num, nk, pk, sk) + +!*****************************************************************************80 +! +!! POLYLOOP_ARCLENGTH_ND computes the arclength of points on a polyloop in ND. +! +! Discussion: +! +! A polyloop of order NK is the geometric structure consisting of +! the NK line segments that lie between successive elements of a list +! of NK points, with the last point joined to the first. +! +! Warning: I just made up the word "polyloop", so don't go repeating it! +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) NK, the number of points defining the polyloop. +! +! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyloop. +! +! Output, real ( kind = 8 ) SK(NK+1), the arclength coordinates +! of each point. The first point has two arc length values, +! namely SK(1) = 0 and SK(NK+1) = LENGTH. +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) nk + + integer(kind=4) i + integer(kind=4) j + real(kind=8) pk(dim_num, nk) + real(kind=8) sk(nk + 1) + + sk(1) = 0.0D+00 + + do i = 2, nk + 1 + + if (i <= nk) then + j = i + else + j = 1 + end if + + sk(i) = sk(i - 1) & + + sqrt(sum((pk(1:dim_num, j) - pk(1:dim_num, i - 1))**2)) + + end do + + return +end +subroutine polyloop_length_nd(dim_num, nk, pk, length) + +!*****************************************************************************80 +! +!! POLYLOOP_LENGTH_ND computes the length of a polyloop in ND. +! +! Discussion: +! +! A polyloop of order NK is the geometric structure consisting of +! the NK line segments that lie between successive elements of a list +! of NK points, with the last point joined to the first. +! +! Warning: I just made up the word "polyloop", so don't go repeating it! +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) NK, the number of points defining the polyloop. +! +! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyloop. +! +! Output, real ( kind = 8 ) LENGTH, the length of the polyloop. +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) nk + + integer(kind=4) i + integer(kind=4) j + real(kind=8) length + real(kind=8) pk(dim_num, nk) + + length = 0.0D+00 + + do i = 2, nk + 1 + + if (i <= nk) then + j = i + else + j = 1 + end if + + length = length & + + sqrt(sum((pk(1:dim_num, j) - pk(1:dim_num, i - 1))**2)) + + end do + + return +end +subroutine polyloop_points_nd(dim_num, nk, pk, nt, pt) + +!*****************************************************************************80 +! +!! POLYLOOP_POINTS_ND computes equally spaced points on a polyloop in ND. +! +! Discussion: +! +! A polyloop of order NK is the geometric structure consisting of +! the NK line segments that lie between successive elements of a list +! of NK points, including a segment from the last point to the first. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) NK, the number of points defining the polyloop. +! +! Input, real ( kind = 8 ) PK(DIM_NUM,NK), the points defining the polyloop. +! +! Input, integer ( kind = 4 ) NT, the number of points to be sampled. +! +! Input, real ( kind = 8 ) PT(DIM_NUM,NT), equally spaced points +! on the polyloop. +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) nk + integer(kind=4) nt + + integer(kind=4) it + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) pk(dim_num, nk) + real(kind=8) pt(dim_num, nt) + real(kind=8) sk(nk + 1) + real(kind=8) st + + call polyloop_arclength_nd(dim_num, nk, pk, sk) + + j = 1 + + do it = 1, nt + + st = (real(nt - it, kind=8) * 0.0D+00 + & + real(it - 1, kind=8) * sk(nk + 1)) & + / real(nt - 1, kind=8) + + do + + if (sk(j) <= st .and. st <= sk(j + 1)) then + exit + end if + + if (nk <= j) then + exit + end if + + j = j + 1 + + end do + + jp1 = i4_wrap(j + 1, 1, nk) + + pt(1:dim_num, it) = ((sk(j + 1) - st) * pk(1:dim_num, j) & + + (st - sk(j)) * pk(1:dim_num, jp1)) & + / (sk(j + 1) - sk(j)) + + end do + + return +end +subroutine provec(m, n, base, vecm, vecn, vecnm) + +!*****************************************************************************80 +! +!! PROVEC projects a vector from M space into N space. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the dimension of the higher order space. +! +! Input, integer ( kind = 4 ) N, the dimension of the lower order space. +! +! Input, real ( kind = 8 ) BASE(M,N). The columns of BASE contain +! N vectors, each of length M, which form the basis for +! a space of dimension N. +! +! Input, real ( kind = 8 ) VECM(M), is an M dimensional vector. +! +! Output, real ( kind = 8 ) VECN(N), the projection of VECM into the +! lower dimensional space. These values represent +! coordinates in the lower order space. +! +! Output, real ( kind = 8 ) VECNM(M), the projection of VECM into the +! lower dimensional space, but using coordinates in +! the higher dimensional space. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + real(kind=8) base(m, n) + integer(kind=4) i + integer(kind=4) j + real(kind=8) temp + real(kind=8) vecm(m) + real(kind=8) vecn(n) + real(kind=8) vecnm(m) +! +! For each vector, remove all projections onto previous vectors, +! and then normalize. This should result in a matrix BASE +! whose columns are orthonormal. +! + do j = 1, n + + do i = 1, j - 1 + + temp = dot_product(base(1:m, i), base(1:m, j)) + + base(1:m, j) = base(1:m, j) - temp * base(1:m, i) + + end do + + temp = sqrt(sum(base(1:m, j)**2)) + + if (0.0D+00 < temp) then + base(1:m, j) = base(1:m, j) / temp + end if + + end do +! +! Compute the coordinates of the projection of the vector +! simply by taking dot products. +! + do j = 1, n + vecn(j) = dot_product(vecm(1:m), base(1:m, j)) + end do +! +! Compute the coordinates of the projection in terms of +! the original space. +! + do i = 1, m + vecnm(i) = dot_product(base(i, 1:n), vecn(1:n)) + end do + + return +end +subroutine pyramid_volume_3d(h, s, volume) + +!*****************************************************************************80 +! +!! PYRAMID_VOLUME_3D computes the volume of a pyramid with square base in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 November 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) H, S, the height of the pyramid, and the +! length of one side of the square base. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the pyramid. +! + implicit none + + real(kind=8) h + real(kind=8) s + real(kind=8) volume + + volume = s * s * h / 3.0D+00 + + return +end +function pyramid01_volume() + +!*****************************************************************************80 +! +!! PYRAMID01_VOLUME returns the volume of a unit pyramid. +! +! Discussion: +! +! A pyramid with square base can be regarded as the upper half of a +! 3D octahedron. +! +! The integration region: +! +! - ( 1 - Z ) <= X <= 1 - Z +! - ( 1 - Z ) <= Y <= 1 - Z +! 0 <= Z <= 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) VALUE, the volume of the pyramid. +! + implicit none + + real(kind=8) pyramid01_volume + real(kind=8) volume + + volume = 4.0D+00 / 3.0D+00 + + pyramid01_volume = volume + + return +end +subroutine quad_area_2d(q, area) + +!*****************************************************************************80 +! +!! QUAD_AREA_2D computes the area of a quadrilateral in 2D. +! +! Discussion: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! This algorithm should be able to handle nonconvex quadrilaterals. +! +! The vertices of the quadrilateral should be listed in counter clockwise +! order, so that the area is positive. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Q(2,4), the vertices, specified in +! counter clockwise order. +! +! Output, real ( kind = 8 ) AREA, the area of the quadrilateral. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) area + real(kind=8) area_triangle + real(kind=8) q(dim_num, 4) + real(kind=8) t(dim_num, 3) + + area = 0.0D+00 + + t(1:dim_num, 1:3) = reshape((/ & + q(1:2, 1), q(1:2, 2), q(1:2, 3)/), (/dim_num, 3/)) + + call triangle_area_2d(t, area_triangle) + + area = area + area_triangle + + t(1:dim_num, 1:3) = reshape((/ & + q(1:2, 3), q(1:2, 4), q(1:2, 1)/), (/dim_num, 3/)) + + call triangle_area_2d(t, area_triangle) + + area = area + area_triangle + + return +end +subroutine quad_area2_2d(q, area) + +!*****************************************************************************80 +! +!! QUAD_AREA2_2D computes the area of a quadrilateral in 2D. +! +! Discussion: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! This algorithm computes the area of the related +! Varignon parallelogram first. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 May 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Q(2,4), the vertices, specified in +! counter clockwise order. +! +! Output, real ( kind = 8 ) AREA, the area of the quadrilateral. +! + implicit none + + real(kind=8) area + real(kind=8) p(2, 4) + real(kind=8) q(2, 4) +! +! Define a parallelogram by averaging consecutive vertices. +! + p(1:2, 1:3) = (q(1:2, 1:3) + q(1:2, 2:4)) / 2.0D+00 + p(1:2, 4) = (q(1:2, 4) + q(1:2, 1)) / 2.0D+00 +! +! Compute the area. +! + call parallelogram_area_2d(p, area) +! +! The quadrilateral's area is twice that of the parallelogram. +! + area = 2.0D+00 * area + + return +end +subroutine quad_area_3d(q, area) + +!*****************************************************************************80 +! +!! QUAD_AREA_3D computes the area of a quadrilateral in 3D. +! +! Discussion: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! It is assumed that the four vertices of the quadrilateral +! are coplanar. +! +! This algorithm computes the area of the related +! Varignon parallelogram first. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 May 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Q(3,4), the vertices, specified in +! counter clockwise order. +! +! Output, real ( kind = 8 ) AREA, the area of the quadrilateral. +! + implicit none + + real(kind=8) area + real(kind=8) p(3, 4) + real(kind=8) q(3, 4) +! +! Define a parallelogram by averaging consecutive vertices. +! + p(1:3, 1:3) = (q(1:3, 1:3) + q(1:3, 2:4)) / 2.0D+00 + p(1:3, 4) = (q(1:3, 4) + q(1:3, 1)) / 2.0D+00 +! +! Compute the area. +! + call parallelogram_area_3d(p, area) +! +! The quadrilateral's area is twice that of the parallelogram. +! + area = 2.0D+00 * area + + return +end +subroutine quad_contains_point_2d(q, p, inside) + +!*****************************************************************************80 +! +!! QUAD_CONTAINS_POINT_2D: is point inside a convex quadrilateral in 2D. +! +! Discussion: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Q(2,4), the vertices of the quadrilateral. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is in the +! quadrilateral. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle_1 + real(kind=8) angle_2 + real(kind=8) angle_rad_2d + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) q(dim_num, 4) +! +! This will only handle convex quadrilaterals. +! + inside = .false. + + angle_1 = angle_rad_2d(q(1:2, 1), q(1:2, 2), q(1:2, 3)) + angle_2 = angle_rad_2d(q(1:2, 1), q(1:2, 2), p(1:2)) + + if (angle_1 < angle_2) then + return + end if + + angle_1 = angle_rad_2d(q(1:2, 2), q(1:2, 3), q(1:2, 4)) + angle_2 = angle_rad_2d(q(1:2, 2), q(1:2, 3), p(1:2)) + + if (angle_1 < angle_2) then + return + end if + + angle_1 = angle_rad_2d(q(1:2, 3), q(1:2, 4), q(1:2, 1)) + angle_2 = angle_rad_2d(q(1:2, 3), q(1:2, 4), p(1:2)) + + if (angle_1 < angle_2) then + return + end if + + angle_1 = angle_rad_2d(q(1:2, 4), q(1:2, 1), q(1:2, 2)) + angle_2 = angle_rad_2d(q(1:2, 4), q(1:2, 1), p(1:2)) + + if (angle_1 < angle_2) then + return + end if + + inside = .true. + + return +end +subroutine quad_convex_random(seed, xy) + +!*****************************************************************************80 +! +!! QUAD_CONVEX_RANDOM returns a random convex quadrilateral. +! +! Description: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! The quadrilateral is constrained in that the vertices must all lie +! with the unit square. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 June 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) XY(2,NODE_NUM), the coordinates of the +! nodes of the quadrilateral, given in counterclockwise order. +! + implicit none + + integer(kind=4), parameter :: node_num = 4 + + integer(kind=4) hull(node_num) + integer(kind=4) hull_num + integer(kind=4) j + integer(kind=4) seed + real(kind=8) xy(2, node_num) + real(kind=8) xy_random(2, node_num) + + do +! +! Generate 4 random points. +! + call r8mat_uniform_01(2, node_num, seed, xy_random) +! +! Determine the convex hull. +! + call points_hull_2d(node_num, xy_random, hull_num, hull) +! +! If HULL_NUM < NODE_NUM, then our convex hull is a triangle. +! Try again. +! + if (hull_num == node_num) then + exit + end if + + end do +! +! Make an ordered copy of the random points. +! + do j = 1, node_num + xy(1:2, j) = xy_random(1:2, hull(j)) + end do + + return +end +subroutine quad_point_dist_2d(q, p, dist) + +!*****************************************************************************80 +! +!! QUAD_POINT_DIST_2D: distance ( quadrilateral, point ) in 2D. +! +! Discussion: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Q(2,4), the quadrilateral vertices. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! quadrilateral. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4), parameter :: side_num = 4 + + real(kind=8) dist + real(kind=8) dist2 + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) p(dim_num) + real(kind=8) q(dim_num, side_num) +! +! Find the distance to each of the line segments. +! + dist = huge(dist) + + do j = 1, side_num + + jp1 = i4_wrap(j + 1, 1, side_num) + + call segment_point_dist_2d(q(1:dim_num, j), q(1:dim_num, jp1), p, dist2) + + if (dist2 < dist) then + dist = dist2 + end if + + end do + + return +end +subroutine quad_point_dist_signed_2d(q, p, dist_signed) + +!*****************************************************************************80 +! +!! QUAD_POINT_DIST_SIGNED_2D: signed distance ( quadrilateral, point ) in 2D. +! +! Discussion: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! The quadrilateral must be convex. DIST_SIGNED is actually the maximum +! of the signed distances from the point to each of the four lines that +! make up the quadrilateral. +! +! Essentially, if the point is outside the convex quadrilateral, +! only one of the signed distances can be positive, or two can +! be positive and equal. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Q(2,4), the vertices of the quadrilateral. +! +! Input, real ( kind = 8 ) P(2), the point which is to be checked. +! +! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the +! point to the convex quadrilateral. If DIST_SIGNED is +! 0.0, the point is on the boundary; +! negative, the point is in the interior; +! positive, the point is in the exterior. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dis + real(kind=8) dis12 + real(kind=8) dis23 + real(kind=8) dis34 + real(kind=8) dis41 + real(kind=8) dist_signed + real(kind=8) p(dim_num) + real(kind=8) pm(dim_num) + real(kind=8) q(dim_num, 4) +! +! Compare the signed distance from each line segment to the point, +! with the signed distance to the midpoint of the opposite line. +! +! The signed distances should all be negative if the point is inside. +! +! Side 12 +! + call line_exp_point_dist_signed_2d(q(1:2, 1), q(1:2, 2), p, dis12) + + pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 3) + q(1:dim_num, 4)) + + call line_exp_point_dist_signed_2d(q(1:2, 1), q(1:2, 2), pm, dis) + + if (0.0D+00 < dis) then + dis = -dis + dis12 = -dis12 + end if +! +! Side 23 +! + call line_exp_point_dist_signed_2d(q(1:2, 2), q(1:2, 3), p, dis23) + + pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 4) + q(1:dim_num, 1)) + + call line_exp_point_dist_signed_2d(q(1:2, 2), q(1:2, 3), pm, dis) + + if (0.0D+00 < dis) then + dis = -dis + dis23 = -dis23 + end if +! +! Side 34 +! + call line_exp_point_dist_signed_2d(q(1:2, 3), q(1:2, 4), p, dis34) + + pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 1) + q(1:dim_num, 2)) + + call line_exp_point_dist_signed_2d(q(1:2, 3), q(1:2, 4), pm, dis) + + if (0.0D+00 < dis) then + dis = -dis + dis34 = -dis34 + end if +! +! Side 41 +! + call line_exp_point_dist_signed_2d(q(1:2, 4), q(1:2, 1), p, dis41) + + pm(1:dim_num) = 0.5D+00 * (q(1:dim_num, 2) + q(1:dim_num, 3)) + + call line_exp_point_dist_signed_2d(q(1:2, 4), q(1:2, 1), pm, dis) + + if (0.0D+00 < dis) then + dis = -dis + dis41 = -dis41 + end if + + dist_signed = max(dis12, dis23, dis34, dis41) + + return +end +subroutine quad_point_near_2d(q, p, pn, dist) + +!*****************************************************************************80 +! +!! QUAD_POINT_NEAR_2D computes the nearest point on a quadrilateral in 2D. +! +! Discussion: +! +! A quadrilateral is a polygon defined by 4 vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Q(2,4), the quadrilateral vertices. +! +! Input, real ( kind = 8 ) P(2), the point whose nearest quadrilateral point +! is to be determined. +! +! Output, real ( kind = 8 ) PN(2), the nearest point to P. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! quadrilateral. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4), parameter :: side_num = 4 + + real(kind=8) dist + real(kind=8) dist2 + integer(kind=4) i4_wrap + integer(kind=4) j + integer(kind=4) jp1 + real(kind=8) p(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) pn2(dim_num) + real(kind=8) q(dim_num, side_num) + real(kind=8) tval +! +! Find the distance to each of the line segments that make up the edges +! of the quadrilateral. +! + dist = huge(dist) + pn(1:dim_num) = 0.0D+00 + + do j = 1, side_num + + jp1 = i4_wrap(j + 1, 1, side_num) + + call segment_point_near_2d(q(1:dim_num, j), q(1:dim_num, jp1), p, & + pn2, dist2, tval) + + if (dist2 < dist) then + dist = dist2 + pn(1:dim_num) = pn2(1:dim_num) + end if + + end do + + return +end +function r8_acos(c) + +!*****************************************************************************80 +! +!! R8_ACOS computes the arc cosine function, with argument truncation. +! +! Discussion: +! +! If you call your system ACOS routine with an input argument that is +! even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant +! surprise (I did). +! +! This routine simply truncates arguments outside the range. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) C, the argument. +! +! Output, real ( kind = 8 ) R8_ACOS, an angle whose cosine is C. +! + implicit none + + real(kind=8) c + real(kind=8) c2 + real(kind=8) r8_acos + + c2 = c + c2 = max(c2, -1.0D+00) + c2 = min(c2, +1.0D+00) + + r8_acos = acos(c2) + + return +end +function r8_asin(s) + +!*****************************************************************************80 +! +!! R8_ASIN computes the arc sine function, with argument truncation. +! +! Discussion: +! +! If you call your system ASIN routine with an input argument that is +! even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant +! surprise (I did). +! +! This routine simply truncates arguments outside the range. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) S, the argument. +! +! Output, real ( kind = 8 ) R8_ASIN, an angle whose sine is S. +! + implicit none + + real(kind=8) r8_asin + real(kind=8) s + real(kind=8) s2 + + s2 = s + s2 = max(s2, -1.0D+00) + s2 = min(s2, +1.0D+00) + + r8_asin = asin(s2) + + return +end +function r8_atan(y, x) + +!*****************************************************************************80 +! +!! R8_ATAN computes the inverse tangent of the ratio Y / X. +! +! Discussion: +! +! R8_ATAN returns an angle whose tangent is ( Y / X ), a job which +! the built in functions ATAN and ATAN2 already do. +! +! However: +! +! * R8_ATAN always returns a positive angle, between 0 and 2 PI, +! while ATAN and ATAN2 return angles in the interval [-PI/2,+PI/2] +! and [-PI,+PI] respectively; +! +! * R8_ATAN accounts for the signs of X and Y, (as does ATAN2). The ATAN +! function by contrast always returns an angle in the first or fourth +! quadrants. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) Y, X, two quantities which represent the +! tangent of an angle. If Y is not zero, then the tangent is (Y/X). +! +! Output, real ( kind = 8 ) R8_ATAN, an angle between 0 and 2 * PI, whose +! tangent is (Y/X), and which lies in the appropriate quadrant so that +! the signs of its cosine and sine match those of X and Y. +! + implicit none + + real(kind=8) abs_x + real(kind=8) abs_y + real(kind=8) r8_atan + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + real(kind=8) theta_0 + real(kind=8) x + real(kind=8) y +! +! Special cases: +! + if (x == 0.0D+00) then + + if (0.0D+00 < y) then + theta = r8_pi / 2.0D+00 + else if (y < 0.0D+00) then + theta = 3.0D+00 * r8_pi / 2.0D+00 + else if (y == 0.0D+00) then + theta = 0.0D+00 + end if + + else if (y == 0.0D+00) then + + if (0.0D+00 < x) then + theta = 0.0D+00 + else if (x < 0.0D+00) then + theta = r8_pi + end if +! +! We assume that ATAN2 is correct when both arguments are positive. +! + else + + abs_y = abs(y) + abs_x = abs(x) + + theta_0 = atan2(abs_y, abs_x) + + if (0.0D+00 < x .and. 0.0D+00 < y) then + theta = theta_0 + else if (x < 0.0D+00 .and. 0.0D+00 < y) then + theta = r8_pi - theta_0 + else if (x < 0.0D+00 .and. y < 0.0D+00) then + theta = r8_pi + theta_0 + else if (0.0D+00 < x .and. y < 0.0D+00) then + theta = 2.0D+00 * r8_pi - theta_0 + end if + + end if + + r8_atan = theta + + return +end +function r8_cosd(degrees) + +!*****************************************************************************80 +! +!! R8_COSD returns the cosine of an angle given in degrees. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 July 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DEGREES, the angle in degrees. +! +! Output, real ( kind = 8 ) R8_COSD, the cosine of the angle. +! + implicit none + + real(kind=8) degrees + real(kind=8) r8_cosd + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radians + + radians = r8_pi * (degrees / 180.0D+00) + r8_cosd = cos(radians) + + return +end +function r8_cotd(degrees) + +!*****************************************************************************80 +! +!! R8_COTD returns the cotangent of an angle given in degrees. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 July 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DEGREES, the angle in degrees. +! +! Output, real ( kind = 8 ) R8_COTD, the cotangent of the angle. +! + implicit none + + real(kind=8) degrees + real(kind=8) r8_cotd + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radians + + radians = r8_pi * (degrees / 180.0D+00) + r8_cotd = cos(radians) / sin(radians) + + return +end +function r8_cscd(degrees) + +!*****************************************************************************80 +! +!! R8_CSCD returns the cosecant of an angle given in degrees. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 July 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DEGREES, the angle in degrees. +! +! Output, real ( kind = 8 ) R8_CSCD, the cosecant of the angle. +! + implicit none + + real(kind=8) degrees + real(kind=8) r8_cscd + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radians + + radians = r8_pi * (degrees / 180.0D+00) + r8_cscd = 1.0D+00 / sin(radians) + + return +end +function r8_huge() + +!*****************************************************************************80 +! +!! R8_HUGE returns a very large R8. +! +! Discussion: +! +! The value returned by this function is NOT required to be the +! maximum representable R8. This value varies from machine to machine, +! from compiler to compiler, and may cause problems when being printed. +! We simply want a "very large" but non-infinite number. +! +! FORTRAN90 provides a built-in routine HUGE ( X ) that +! can return the maximum representable number of the same datatype +! as X, if that is what is really desired. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 October 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) R8_HUGE, a "huge" value. +! + implicit none + + real(kind=8) r8_huge + + r8_huge = 1.0D+30 + + return +end +function r8_is_int(r) + +!*****************************************************************************80 +! +!! R8_IS_INT determines if a real number represents an integer value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 March 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the number to be checked. +! +! Output, logical ( kind = 4 ) R8_IS_INT, is TRUE if R is an integer value. +! + implicit none + + integer(kind=4) i + real(kind=8) r + logical(kind=4) r8_is_int + + if (real(huge(i), kind=8) < r) then + r8_is_int = .false. + else if (r < -real(huge(i), kind=8)) then + r8_is_int = .false. + else if (r == real(int(r), kind=8)) then + r8_is_int = .true. + else + r8_is_int = .false. + end if + + return +end +function r8_modp(x, y) + +!*****************************************************************************80 +! +!! R8_MODP returns the nonnegative remainder of real division. +! +! Discussion: +! +! If +! REM = R8_MODP ( X, Y ) +! RMULT = ( X - REM ) / Y +! then +! X = Y * RMULT + REM +! where REM is always nonnegative. +! +! The MOD function computes a result with the same sign as the +! quantity being divided. Thus, suppose you had an angle A, +! and you wanted to ensure that it was between 0 and 360. +! Then mod(A,360.0) would do, if A was positive, but if A +! was negative, your result would be between -360 and 0. +! +! On the other hand, R8_MODP(A,360.0) is between 0 and 360, always. +! +! Example: +! +! I J MOD R8_MODP R8_MODP Factorization +! +! 107 50 7 7 107 = 2 * 50 + 7 +! 107 -50 7 7 107 = -2 * -50 + 7 +! -107 50 -7 43 -107 = -3 * 50 + 43 +! -107 -50 -7 43 -107 = 3 * -50 + 43 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 July 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) X, the number to be divided. +! +! Input, real ( kind = 8 ) Y, the number that divides X. +! +! Output, real ( kind = 8 ) R8_MODP, the nonnegative remainder +! when X is divided by Y. +! + implicit none + + real(kind=8) r8_modp + real(kind=8) x + real(kind=8) y + + if (y == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8_MODP - Fatal error!' + write (*, '(a,g14.6)') ' R8_MODP ( X, Y ) called with Y = ', y + stop 1 + end if + + r8_modp = mod(x, y) + + if (r8_modp < 0.0D+00) then + r8_modp = r8_modp + abs(y) + end if + + return +end +function r8_normal_01(seed) + +!*****************************************************************************80 +! +!! R8_NORMAL_01 returns a unit pseudonormal R8. +! +! Discussion: +! +! The standard normal probability distribution function (PDF) has +! mean 0 and standard deviation 1. +! +! Because this routine uses the Box Muller method, it requires pairs +! of uniform random values to generate a pair of normal random values. +! This means that on every other call, essentially, the input value of +! SEED is ignored, since the code saves the second normal random value. +! +! If you didn't know this, you might be confused since, usually, the +! output of a random number generator can be completely controlled by +! the input value of the SEED. If I were more careful, I could rewrite +! this routine so that it would distinguish between cases where the input +! value of SEED is the output value from the previous call (all is well) +! and those cases where it is not (the user has decided to do something +! new. Restart the uniform random number sequence.) But I'll leave +! that for later. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) R8_NORMAL_01, a sample of the standard +! normal PDF. +! + implicit none + + real(kind=8) r1 + real(kind=8) r2 + real(kind=8) r8_normal_01 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r8_uniform_01 + integer(kind=4) seed + integer(kind=4), save :: seed2 = 0 + integer(kind=4), save :: used = 0 + real(kind=8) x + real(kind=8), save :: y = 0.0D+00 +! +! On odd numbered calls, generate two uniforms, create two normals, +! return the first normal and its corresponding seed. +! + if (mod(used, 2) == 0) then + + r1 = r8_uniform_01(seed) + + if (r1 == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8_NORMAL_01 - Fatal error!' + write (*, '(a)') ' R8_UNIFORM_01 returned a value of 0.' + stop 1 + end if + + seed2 = seed + r2 = r8_uniform_01(seed2) + + x = sqrt(-2.0D+00 * log(r1)) * cos(2.0D+00 * r8_pi * r2) + y = sqrt(-2.0D+00 * log(r1)) * sin(2.0D+00 * r8_pi * r2) +! +! On odd calls, return the second normal and its corresponding seed. +! + else + + seed = seed2 + x = y + + end if + + used = used + 1 + + r8_normal_01 = x + + return +end +function r8_pi() + +!*****************************************************************************80 +! +!! R8_PI returns the value of pi. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 December 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) R8_PI, the value of pi. +! + implicit none + + real(kind=8) r8_pi + + r8_pi = 3.141592653589793D+00 + + return +end +function r8_sign_opposite_strict(r1, r2) + +!*****************************************************************************80 +! +!! R8_SIGN_OPPOSITE_STRICT is TRUE if two R8's are strictly of opposite sign. +! +! Discussion: +! +! This test could be coded numerically as +! +! if ( r1 * r2 < 0.0 ) then ... +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 June 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the values to check. +! +! Output, logical ( kind = 4 ) R8_SIGN_OPPOSITE_STRICT, is TRUE +! if ( R1 < 0 and 0 < R2 ) or ( R2 < 0 and 0 < R1 ). +! + implicit none + + real(kind=8) r1 + real(kind=8) r2 + logical(kind=4) r8_sign_opposite_strict + + r8_sign_opposite_strict = (r1 < 0.0D+00 .and. 0.0D+00 < r2) .or. & + (r2 < 0.0D+00 .and. 0.0D+00 < r1) + + return +end +function r8_sind(degrees) + +!*****************************************************************************80 +! +!! R8_SIND returns the sine of an angle given in degrees. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 July 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DEGREES, the angle in degrees. +! +! Output, real ( kind = 8 ) R8_SIND, the sine of the angle. +! + implicit none + + real(kind=8) degrees + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r8_sind + real(kind=8) radians + + radians = r8_pi * (degrees / 180.0D+00) + r8_sind = sin(radians) + + return +end +function r8_secd(degrees) + +!*****************************************************************************80 +! +!! R8_SECD returns the secant of an angle given in degrees. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 July 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DEGREES, the angle in degrees. +! +! Output, real ( kind = 8 ) R8_SECD, the secant of the angle. +! + implicit none + + real(kind=8) degrees + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r8_secd + real(kind=8) radians + + radians = r8_pi * (degrees / 180.0D+00) + r8_secd = 1.0D+00 / cos(radians) + + return +end +subroutine r8_swap(x, y) + +!*****************************************************************************80 +! +!! R8_SWAP switches two R8's. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 May 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, real ( kind = 8 ) X, Y. On output, the values of X and +! Y have been interchanged. +! + implicit none + + real(kind=8) x + real(kind=8) y + real(kind=8) z + + z = x + x = y + y = z + + return +end +function r8_tand(degrees) + +!*****************************************************************************80 +! +!! R8_TAND returns the tangent of an angle given in degrees. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 July 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DEGREES, the angle in degrees. +! +! Output, real ( kind = 8 ) R8_TAND, the tangent of the angle. +! + implicit none + + real(kind=8) degrees + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r8_tand + real(kind=8) radians + + radians = r8_pi * (degrees / 180.0D+00) + r8_tand = tan(radians) + + return +end +function r8_uniform(a, b, seed) + +!*****************************************************************************80 +! +!! R8_UNIFORM returns a scaled pseudorandom R8. +! +! Discussion: +! +! An R8 is a real ( kind = 8 ) value. +! +! For now, the input quantity SEED is an integer ( kind = 4 ) variable. +! +! The pseudorandom number should be uniformly distributed +! between A and B. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 July 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, the limits of the interval. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should +! NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R8_UNIFORM, a number strictly between A and B. +! + implicit none + + real(kind=8) a + real(kind=8) b + integer(kind=4) k + real(kind=8) r8_uniform + integer(kind=4) seed + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8_UNIFORM - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if + + r8_uniform = a + (b - a) * real(seed, kind=8) * 4.656612875D-10 + + return +end +function r8_uniform_01(seed) + +!*****************************************************************************80 +! +!! R8_UNIFORM_01 returns a unit pseudorandom R8. +! +! Discussion: +! +! An R8 is a real ( kind = 8 ) value. +! +! For now, the input quantity SEED is an integer ( kind = 4 ) variable. +! +! This routine implements the recursion +! +! seed = 16807 * seed mod ( 2^31 - 1 ) +! r8_uniform_01 = seed / ( 2^31 - 1 ) +! +! The integer arithmetic never requires more than 32 bits, +! including a sign bit. +! +! If the initial seed is 12345, then the first three computations are +! +! Input Output R8_UNIFORM_01 +! SEED SEED +! +! 12345 207482415 0.096616 +! 207482415 1790989824 0.833995 +! 1790989824 2035175616 0.947702 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 July 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paul Bratley, Bennett Fox, Linus Schrage, +! A Guide to Simulation, +! Springer Verlag, pages 201-202, 1983. +! +! Pierre L'Ecuyer, +! Random Number Generation, +! in Handbook of Simulation, +! edited by Jerry Banks, +! Wiley Interscience, page 95, 1998. +! +! Bennett Fox, +! Algorithm 647: +! Implementation and Relative Efficiency of Quasirandom +! Sequence Generators, +! ACM Transactions on Mathematical Software, +! Volume 12, Number 4, pages 362-376, 1986. +! +! Peter Lewis, Allen Goodman, James Miller +! A Pseudo-Random Number Generator for the System/360, +! IBM Systems Journal, +! Volume 8, pages 136-143, 1969. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should +! NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate, +! strictly between 0 and 1. +! + implicit none + + integer(kind=4) k + real(kind=8) r8_uniform_01 + integer(kind=4) seed + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8_UNIFORM_01 - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if +! +! Although SEED can be represented exactly as a 32 bit integer, +! it generally cannot be represented exactly as a 32 bit real number! +! + r8_uniform_01 = real(seed, kind=8) * 4.656612875D-10 + + return +end +subroutine r82vec_permute(n, p, a) + +!*****************************************************************************80 +! +!! R82VEC_PERMUTE permutes a R82 vector in place. +! +! Discussion: +! +! This routine permutes an array of real "objects", but the same +! logic can be used to permute an array of objects of any arithmetic +! type, or an array of objects of any complexity. The only temporary +! storage required is enough to store a single object. The number +! of data movements made is N + the number of cycles of order 2 or more, +! which is never more than N + N/2. +! +! Example: +! +! Input: +! +! N = 5 +! P = ( 2, 4, 5, 1, 3 ) +! A = ( 1.0, 2.0, 3.0, 4.0, 5.0 ) +! (11.0, 22.0, 33.0, 44.0, 55.0 ) +! +! Output: +! +! A = ( 2.0, 4.0, 5.0, 1.0, 3.0 ) +! ( 22.0, 44.0, 55.0, 11.0, 33.0 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 March 2011 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of objects. +! +! Input, integer ( kind = 4 ) P(N), the permutation. P(I) = J means +! that the I-th element of the output array should be the J-th +! element of the input array. P must be a legal permutation +! of the integers from 1 to N, otherwise the algorithm will +! fail catastrophically. +! +! Input/output, real ( kind = 8 ) A(2,N), the array to be permuted. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(2, n) + real(kind=8) a_temp(2) + integer(kind=4) iget + integer(kind=4) iput + integer(kind=4) istart + integer(kind=4) p(n) +! +! Search for the next element of the permutation that has not been used. +! + do istart = 1, n + + if (p(istart) < 0) then + + cycle + + else if (p(istart) == istart) then + + p(istart) = -p(istart) + cycle + + else + + a_temp(1:2) = a(1:2, istart) + iget = istart +! +! Copy the new value into the vacated entry. +! + do + + iput = iget + iget = p(iget) + + p(iput) = -p(iput) + + if (iget < 1 .or. n < iget) then + write (*, '(a)') ' ' + write (*, '(a)') 'R82VEC_PERMUTE - Fatal error!' + stop 1 + end if + + if (iget == istart) then + a(1:2, iput) = a_temp(1:2) + exit + end if + + a(1:2, iput) = a(1:2, iget) + + end do + + end if + + end do +! +! Restore the signs of the entries. +! + p(1:n) = -p(1:n) + + return +end +subroutine r82vec_sort_heap_index_a(n, a, indx) + +!*****************************************************************************80 +! +!! R82VEC_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R82VEC. +! +! Discussion: +! +! The sorting is not actually carried out. Rather an index array is +! created which defines the sorting. This array may be used to sort +! or index the array, or to sort or index related arrays keyed on the +! original array. +! +! Once the index array is computed, the sorting can be carried out +! "implicitly: +! +! A(1:2,INDX(I)), I = 1 to N is sorted, +! +! or explicitly, by the call +! +! call R82VEC_PERMUTE ( N, A, INDX ) +! +! after which A(1:2,I), I = 1 to N is sorted. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 January 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the array. +! +! Input, real ( kind = 8 ) A(2,N), an array to be index-sorted. +! +! Output, integer ( kind = 4 ) INDX(N), the sort index. The +! I-th element of the sorted array is A(1:2,INDX(I)). +! + implicit none + + integer(kind=4) n + + real(kind=8) a(2, n) + real(kind=8) aval(2) + integer(kind=4) i + integer(kind=4) indx(n) + integer(kind=4) indxt + integer(kind=4) ir + integer(kind=4) j + integer(kind=4) l + + if (n < 1) then + return + end if + + if (n == 1) then + indx(1) = 1 + return + end if + + call i4vec_indicator(n, indx) + + l = n / 2 + 1 + ir = n + + do + + if (1 < l) then + + l = l - 1 + indxt = indx(l) + aval(1:2) = a(1:2, indxt) + + else + + indxt = indx(ir) + aval(1:2) = a(1:2, indxt) + indx(ir) = indx(1) + ir = ir - 1 + + if (ir == 1) then + indx(1) = indxt + exit + end if + + end if + + i = l + j = l + l + + do while (j <= ir) + + if (j < ir) then + if (a(1, indx(j)) < a(1, indx(j + 1)) .or. & + (a(1, indx(j)) == a(1, indx(j + 1)) .and. & + a(2, indx(j)) < a(2, indx(j + 1)))) then + j = j + 1 + end if + end if + + if (aval(1) < a(1, indx(j)) .or. & + (aval(1) == a(1, indx(j)) .and. & + aval(2) < a(2, indx(j)))) then + indx(i) = indx(j) + i = j + j = j + j + else + j = ir + 1 + end if + + end do + + indx(i) = indxt + + end do + + return +end +subroutine r8ge_det(n, a, pivot, det) + +!*****************************************************************************80 +! +!! R8GE_DET computes the determinant of a matrix factored by R8GE_FA. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 March 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Jack Dongarra, James Bunch, Cleve Moler, Pete Stewart, +! LINPACK User's Guide, +! SIAM, 1979 +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the order of the matrix. +! N must be positive. +! +! Input, real ( kind = 8 ) A(N,N), the LU factors computed by R8GE_FA. +! +! Input, integer ( kind = 4 ) PIVOT(N), as computed by R8GE_FA. +! +! Output, real ( kind = 8 ) DET, the determinant of the matrix. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(n, n) + real(kind=8) det + integer(kind=4) i + integer(kind=4) pivot(n) + + det = 1.0D+00 + + do i = 1, n + det = det * a(i, i) + if (pivot(i) /= i) then + det = -det + end if + end do + + return +end +subroutine r8ge_fa(n, a, pivot, info) + +!*****************************************************************************80 +! +!! R8GE_FA factors a general matrix. +! +! Discussion: +! +! R8GE_FA is a simplified version of the LINPACK routine DGEFA. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 February 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Jack Dongarra, James Bunch, Cleve Moler, Pete Stewart, +! LINPACK User's Guide, +! SIAM, 1979 +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the order of the matrix. +! N must be positive. +! +! Input/output, real ( kind = 8 ) A(N,N), the matrix to be factored. +! On output, A contains an upper triangular matrix and the multipliers +! which were used to obtain it. The factorization can be written +! A = L * U, where L is a product of permutation and unit lower +! triangular matrices and U is upper triangular. +! +! Output, integer ( kind = 4 ) PIVOT(N), a vector of pivot indices. +! +! Output, integer ( kind = 4 ) INFO, singularity flag. +! 0, no singularity detected. +! nonzero, the factorization failed on the INFO-th step. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(n, n) + integer(kind=4) i + integer(kind=4) info + integer(kind=4) pivot(n) + integer(kind=4) j + integer(kind=4) k + integer(kind=4) l + real(kind=8) t + + info = 0 + + do k = 1, n - 1 +! +! Find L, the index of the pivot row. +! + l = k + do i = k + 1, n + if (abs(a(l, k)) < abs(a(i, k))) then + l = i + end if + end do + + pivot(k) = l +! +! If the pivot index is zero, the algorithm has failed. +! + if (a(l, k) == 0.0D+00) then + info = k + write (*, '(a)') ' ' + write (*, '(a)') 'R8GE_FA - Warning!' + write (*, '(a,i8)') ' Zero pivot on step ', info + return + end if +! +! Interchange rows L and K if necessary. +! + if (l /= k) then + t = a(l, k) + a(l, k) = a(k, k) + a(k, k) = t + end if +! +! Normalize the values that lie below the pivot entry A(K,K). +! + a(k + 1:n, k) = -a(k + 1:n, k) / a(k, k) +! +! Row elimination with column indexing. +! + do j = k + 1, n + + if (l /= k) then + t = a(l, j) + a(l, j) = a(k, j) + a(k, j) = t + end if + + a(k + 1:n, j) = a(k + 1:n, j) + a(k + 1:n, k) * a(k, j) + + end do + + end do + + pivot(n) = n + + if (a(n, n) == 0.0D+00) then + info = n + write (*, '(a)') ' ' + write (*, '(a)') 'R8GE_FA - Warning!' + write (*, '(a,i8)') ' Zero pivot on step ', info + end if + + return +end +subroutine r8ge_sl(n, a, pivot, b, job) + +!*****************************************************************************80 +! +!! R8GE_SL solves a system factored by R8GE_FA. +! +! Discussion: +! +! R8GE_SL is a simplified version of the LINPACK routine DGESL. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 March 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the order of the matrix. +! N must be positive. +! +! Input, real ( kind = 8 ) A(N,N), the LU factors from R8GE_FA. +! +! Input, integer ( kind = 4 ) PIVOT(N), the pivot vector from R8GE_FA. +! +! Input/output, real ( kind = 8 ) B(N). +! On input, the right hand side vector. +! On output, the solution vector. +! +! Input, integer ( kind = 4 ) JOB, specifies the operation. +! 0, solve A * x = b. +! nonzero, solve A' * x = b. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(n, n) + real(kind=8) b(n) + integer(kind=4) pivot(n) + integer(kind=4) job + integer(kind=4) k + integer(kind=4) l +! +! Solve A * x = b. +! + if (job == 0) then +! +! Solve PL * Y = B. +! + do k = 1, n - 1 + + l = pivot(k) + + if (l /= k) then + call r8_swap(b(l), b(k)) + end if + + b(k + 1:n) = b(k + 1:n) + a(k + 1:n, k) * b(k) + + end do +! +! Solve U * X = Y. +! + do k = n, 1, -1 + b(k) = b(k) / a(k, k) + b(1:k - 1) = b(1:k - 1) - a(1:k - 1, k) * b(k) + end do +! +! Solve A' * X = B. +! + else +! +! Solve U' * Y = B. +! + do k = 1, n + b(k) = (b(k) - sum(b(1:k - 1) * a(1:k - 1, k))) / a(k, k) + end do +! +! Solve ( PL )' * X = Y. +! + do k = n - 1, 1, -1 + + b(k) = b(k) + sum(b(k + 1:n) * a(k + 1:n, k)) + + l = pivot(k) + + if (l /= k) then + call r8_swap(b(l), b(k)) + end if + + end do + + end if + + return +end +function r8mat_det_2d(a) + +!*****************************************************************************80 +! +!! R8MAT_DET_2D computes the determinant of a 2 by 2 matrix. +! +! Discussion: +! +! The determinant is the area spanned by the vectors making up the rows +! or columns of the matrix. +! +! R8MAT_DET_2D = A(1,1) * A(2,2) - A(1,2) * A(2,1). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(2,2), the matrix whose determinant is desired. +! +! Output, real ( kind = 8 ) R8MAT_DET_2D, the determinant of the matrix. +! + implicit none + + real(kind=8) a(2, 2) + real(kind=8) r8mat_det_2d + + r8mat_det_2d = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1) + + return +end +function r8mat_det_3d(a) + +!*****************************************************************************80 +! +!! R8MAT_DET_3D computes the determinant of a 3 by 3 matrix. +! +! Discussion: +! +! The determinant is the volume of the shape spanned by the vectors +! making up the rows or columns of the matrix. +! +! det = a11 * a22 * a33 - a11 * a23 * a32 +! + a12 * a23 * a31 - a12 * a21 * a33 +! + a13 * a21 * a32 - a13 * a22 * a31 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(3,3), the matrix whose determinant is desired. +! +! Output, real ( kind = 8 ) R8MAT_DET_3D, the determinant of the matrix. +! + implicit none + + real(kind=8) a(3, 3) + real(kind=8) r8mat_det_3d + + r8mat_det_3d = a(1, 1) * (a(2, 2) * a(3, 3) - a(2, 3) * a(3, 2)) & + + a(1, 2) * (a(2, 3) * a(3, 1) - a(2, 1) * a(3, 3)) & + + a(1, 3) * (a(2, 1) * a(3, 2) - a(2, 2) * a(3, 1)) + + return +end +function r8mat_det_4d(a) + +!*****************************************************************************80 +! +!! R8MAT_DET_4D computes the determinant of a 4 by 4 matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the matrix whose determinant is desired. +! +! Output, real ( kind = 8 ) R8MAT_DET_4D, the determinant of the matrix. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) r8mat_det_4d + + r8mat_det_4d = & + a(1, 1) * ( & + a(2, 2) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & + - a(2, 3) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & + + a(2, 4) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2))) & + - a(1, 2) * ( & + a(2, 1) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & + - a(2, 3) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & + + a(2, 4) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1))) & + + a(1, 3) * ( & + a(2, 1) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & + - a(2, 2) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & + + a(2, 4) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) & + - a(1, 4) * ( & + a(2, 1) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2)) & + - a(2, 2) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1)) & + + a(2, 3) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) + + return +end +function r8mat_det_5d(a) + +!*****************************************************************************80 +! +!! R8MAT_DET_5D computes the determinant of a 5 by 5 matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(5,5), the matrix whose determinant is desired. +! +! Output, real ( kind = 8 ) R8MAT_DET_5D, the determinant of the matrix. +! + implicit none + + real(kind=8) a(5, 5) + real(kind=8) b(4, 4) + real(kind=8) r8mat_det_4d + real(kind=8) r8mat_det_5d + integer(kind=4) i + integer(kind=4) inc + integer(kind=4) j + integer(kind=4) k +! +! Expand the determinant into the sum of the determinants of the +! five 4 by 4 matrices created by dropping row 1, and column k. +! + r8mat_det_5d = 0.0D+00 + + do k = 1, 5 + + do i = 1, 4 + do j = 1, 4 + + if (j < k) then + inc = 0 + else + inc = 1 + end if + + b(i, j) = a(i + 1, j + inc) + + end do + end do + + r8mat_det_5d = r8mat_det_5d + (-1)**(k + 1) * a(1, k) * r8mat_det_4d(b) + + end do + + return +end +subroutine r8mat_inverse_2d(a, b, det) + +!*****************************************************************************80 +! +!! R8MAT_INVERSE_2D inverts a 2 by 2 real matrix using Cramer's rule. +! +! Discussion: +! +! If DET is zero, then A is singular, and does not have an +! inverse. In that case, B is simply set to zero, and a +! message is printed. +! +! If DET is nonzero, then its value is roughly an estimate +! of how nonsingular the matrix A is. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(2,2), the matrix to be inverted. +! +! Output, real ( kind = 8 ) B(2,2), the inverse of the matrix A. +! +! Output, real ( kind = 8 ) DET, the determinant of the matrix A. +! + implicit none + + real(kind=8) a(2, 2) + real(kind=8) b(2, 2) + real(kind=8) det +! +! Compute the determinant. +! + det = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1) +! +! If the determinant is zero, bail out. +! + if (det == 0.0D+00) then + + b(1:2, 1:2) = 0.0D+00 + + return + end if +! +! Compute the entries of the inverse matrix using an explicit formula. +! + b(1, 1) = +a(2, 2) / det + b(1, 2) = -a(1, 2) / det + b(2, 1) = -a(2, 1) / det + b(2, 2) = +a(1, 1) / det + + return +end +subroutine r8mat_inverse_3d(a, b, det) + +!*****************************************************************************80 +! +!! R8MAT_INVERSE_3D inverts a 3 by 3 real matrix using Cramer's rule. +! +! Discussion: +! +! If DET is zero, then A is singular, and does not have an +! inverse. In that case, B is simply set to zero, and a +! message is printed. +! +! If DET is nonzero, then its value is roughly an estimate +! of how nonsingular the matrix A is. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(3,3), the matrix to be inverted. +! +! Output, real ( kind = 8 ) B(3,3), the inverse of the matrix A. +! +! Output, real ( kind = 8 ) DET, the determinant of the matrix A. +! + implicit none + + real(kind=8) a(3, 3) + real(kind=8) b(3, 3) + real(kind=8) det +! +! Compute the determinant of A +! + det = a(1, 1) * (a(2, 2) * a(3, 3) - a(2, 3) * a(3, 2)) & + + a(1, 2) * (a(2, 3) * a(3, 1) - a(2, 1) * a(3, 3)) & + + a(1, 3) * (a(2, 1) * a(3, 2) - a(2, 2) * a(3, 1)) +! +! If the determinant is zero, bail out. +! + if (det == 0.0D+00) then + + b(1:3, 1:3) = 0.0D+00 + + return + end if +! +! Compute the entries of the inverse matrix using an explicit +! formula. +! + b(1, 1) = +(a(2, 2) * a(3, 3) - a(2, 3) * a(3, 2)) / det + b(1, 2) = -(a(1, 2) * a(3, 3) - a(1, 3) * a(3, 2)) / det + b(1, 3) = +(a(1, 2) * a(2, 3) - a(1, 3) * a(2, 2)) / det + + b(2, 1) = -(a(2, 1) * a(3, 3) - a(2, 3) * a(3, 1)) / det + b(2, 2) = +(a(1, 1) * a(3, 3) - a(1, 3) * a(3, 1)) / det + b(2, 3) = -(a(1, 1) * a(2, 3) - a(1, 3) * a(2, 1)) / det + + b(3, 1) = +(a(2, 1) * a(3, 2) - a(2, 2) * a(3, 1)) / det + b(3, 2) = -(a(1, 1) * a(3, 2) - a(1, 2) * a(3, 1)) / det + b(3, 3) = +(a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1)) / det + + return +end +subroutine r8mat_print(m, n, a, title) + +!*****************************************************************************80 +! +!! R8MAT_PRINT prints a real matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 May 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of rows in A. +! +! Input, integer ( kind = 4 ) N, the number of columns in A. +! +! Input, real ( kind = 8 ) A(M,N), the matrix. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + real(kind=8) a(m, n) + character(len=*) title + + call r8mat_print_some(m, n, a, 1, 1, m, n, title) + + return +end +subroutine r8mat_print_some(m, n, a, ilo, jlo, ihi, jhi, title) + +!*****************************************************************************80 +! +!! R8MAT_PRINT_SOME prints some of an R8MAT. +! +! Discussion: +! +! An R8MAT is an array of R8 values. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 September 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. +! +! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. +! +! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4), parameter :: incx = 5 + integer(kind=4) m + integer(kind=4) n + + real(kind=8) a(m, n) + character(len=14) ctemp(incx) + integer(kind=4) i + integer(kind=4) i2hi + integer(kind=4) i2lo + integer(kind=4) ihi + integer(kind=4) ilo + integer(kind=4) inc + integer(kind=4) j + integer(kind=4) j2 + integer(kind=4) j2hi + integer(kind=4) j2lo + integer(kind=4) jhi + integer(kind=4) jlo + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + + do j2lo = max(jlo, 1), min(jhi, n), incx + + j2hi = j2lo + incx - 1 + j2hi = min(j2hi, n) + j2hi = min(j2hi, jhi) + + inc = j2hi + 1 - j2lo + + write (*, '(a)') ' ' + + do j = j2lo, j2hi + j2 = j + 1 - j2lo + write (ctemp(j2), '(i8,6x)') j + end do + + write (*, '('' Col '',5a14)') ctemp(1:inc) + write (*, '(a)') ' Row' + write (*, '(a)') ' ' + + i2lo = max(ilo, 1) + i2hi = min(ihi, m) + + do i = i2lo, i2hi + + do j2 = 1, inc + + j = j2lo - 1 + j2 + + if (a(i, j) == real(int(a(i, j)), kind=8)) then + write (ctemp(j2), '(f8.0,6x)') a(i, j) + else + write (ctemp(j2), '(g14.6)') a(i, j) + end if + + end do + + write (*, '(i5,a,5a14)') i, ':', (ctemp(j), j=1, inc) + + end do + + end do + + return +end +subroutine r8mat_solve(n, rhs_num, a, info) + +!*****************************************************************************80 +! +!! R8MAT_SOLVE uses Gauss-Jordan elimination to solve an N by N linear system. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! 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. +! + implicit none + + integer(kind=4) n + integer(kind=4) rhs_num + + real(kind=8) a(n, n + rhs_num) + real(kind=8) apivot + real(kind=8) factor + integer(kind=4) i + integer(kind=4) info + integer(kind=4) ipivot + integer(kind=4) 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 r8_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 + + return +end +subroutine r8mat_solve_2d(a, b, det, x) + +!*****************************************************************************80 +! +!! R8MAT_SOLVE_2D solves a 2 by 2 linear system using Cramer's rule. +! +! Discussion: +! +! If DET is zero, then A is singular, and does not have an +! inverse. In that case, X is simply set to zero, and a +! message is printed. +! +! If DET is nonzero, then its value is roughly an estimate +! of how nonsingular the matrix A is. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 November 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(2,2), the matrix. +! +! Input, real ( kind = 8 ) B(2), the right hand side. +! +! Output, real ( kind = 8 ) DET, the determinant of the matrix A. +! +! Output, real ( kind = 8 ) X(2), the solution of the system, +! if DET is nonzero. +! + implicit none + + real(kind=8) a(2, 2) + real(kind=8) b(2) + real(kind=8) det + real(kind=8) x(2) +! +! Compute the determinant. +! + det = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1) +! +! If the determinant is zero, bail out. +! + if (det == 0.0D+00) then + x(1:2) = 0.0D+00 + return + end if +! +! Compute the solution. +! + x(1) = (a(2, 2) * b(1) - a(1, 2) * b(2)) / det + x(2) = (-a(2, 1) * b(1) + a(1, 1) * b(2)) / det + + return +end +subroutine r8mat_transpose_print(m, n, a, title) + +!*****************************************************************************80 +! +!! R8MAT_TRANSPOSE_PRINT prints a R8MAT, transposed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 June 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + real(kind=8) a(m, n) + character(len=*) title + + call r8mat_transpose_print_some(m, n, a, 1, 1, m, n, title) + + return +end +subroutine r8mat_transpose_print_some(m, n, a, ilo, jlo, ihi, jhi, title) + +!*****************************************************************************80 +! +!! R8MAT_TRANSPOSE_PRINT_SOME prints some of an R8MAT, transposed. +! +! Discussion: +! +! An R8MAT is an array of R8 values. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 September 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. +! +! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. +! +! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4), parameter :: incx = 5 + integer(kind=4) m + integer(kind=4) n + + real(kind=8) a(m, n) + character(len=14) ctemp(incx) + integer(kind=4) i + integer(kind=4) i2 + integer(kind=4) i2hi + integer(kind=4) i2lo + integer(kind=4) ihi + integer(kind=4) ilo + integer(kind=4) inc + integer(kind=4) j + integer(kind=4) j2hi + integer(kind=4) j2lo + integer(kind=4) jhi + integer(kind=4) jlo + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + + do i2lo = max(ilo, 1), min(ihi, m), incx + + i2hi = i2lo + incx - 1 + i2hi = min(i2hi, m) + i2hi = min(i2hi, ihi) + + inc = i2hi + 1 - i2lo + + write (*, '(a)') ' ' + + do i = i2lo, i2hi + i2 = i + 1 - i2lo + write (ctemp(i2), '(i8,6x)') i + end do + + write (*, '('' Row '',5a14)') ctemp(1:inc) + write (*, '(a)') ' Col' + write (*, '(a)') ' ' + + j2lo = max(jlo, 1) + j2hi = min(jhi, n) + + do j = j2lo, j2hi + + do i2 = 1, inc + i = i2lo - 1 + i2 + write (ctemp(i2), '(g14.6)') a(i, j) + end do + + write (*, '(i5,a,5a14)') j, ':', (ctemp(i), i=1, inc) + + end do + + end do + + return +end +subroutine r8mat_uniform(m, n, a, b, seed, r) + +!*****************************************************************************80 +! +!! R8MAT_UNIFORM fills scaled pseudorandom R8MAT. +! +! Discussion: +! +! An R8MAT is an array of real ( kind = 8 ) values. +! +! For now, the input quantity SEED is an integer ( kind = 4 ) variable. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 July 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paul Bratley, Bennett Fox, Linus Schrage, +! A Guide to Simulation, +! Springer Verlag, pages 201-202, 1983. +! +! Bennett Fox, +! Algorithm 647: +! Implementation and Relative Efficiency of Quasirandom +! Sequence Generators, +! ACM Transactions on Mathematical Software, +! Volume 12, Number 4, pages 362-376, 1986. +! +! Peter Lewis, Allen Goodman, James Miller +! A Pseudo-Random Number Generator for the System/360, +! IBM Systems Journal, +! Volume 8, pages 136-143, 1969. +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns +! in the array. +! +! Input, real ( kind = 8 ) A, B, the lower and upper limits. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which +! should NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + real(kind=8) a + real(kind=8) b + integer(kind=4) i + integer(kind=4) j + integer(kind=4) k + integer(kind=4) seed + real(kind=8) r(m, n) + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8MAT_UNIFORM - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + do j = 1, n + + do i = 1, m + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if + + r(i, j) = a + (b - a) * real(seed, kind=8) * 4.656612875D-10 + + end do + end do + + return +end +subroutine r8mat_uniform_01(m, n, seed, r) + +!*****************************************************************************80 +! +!! R8MAT_UNIFORM_01 returns a unit pseudorandom R8MAT. +! +! Discussion: +! +! An R8MAT is an array of real ( kind = 8 ) values. +! +! For now, the input quantity SEED is an integer ( kind = 4 ) variable. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 July 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paul Bratley, Bennett Fox, Linus Schrage, +! A Guide to Simulation, +! Springer Verlag, pages 201-202, 1983. +! +! Bennett Fox, +! Algorithm 647: +! Implementation and Relative Efficiency of Quasirandom +! Sequence Generators, +! ACM Transactions on Mathematical Software, +! Volume 12, Number 4, pages 362-376, 1986. +! +! Peter Lewis, Allen Goodman, James Miller +! A Pseudo-Random Number Generator for the System/360, +! IBM Systems Journal, +! Volume 8, pages 136-143, 1969. +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns +! in the array. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which +! should NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values. +! + implicit none + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) i + integer(kind=4) j + integer(kind=4) k + integer(kind=4) seed + real(kind=8) r(m, n) + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8MAT_UNIFORM_01 - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + do j = 1, n + + do i = 1, m + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if + + r(i, j) = real(seed, kind=8) * 4.656612875D-10 + + end do + end do + + return +end +subroutine r8vec_angle_3d(u, v, angle) + +!*****************************************************************************80 +! +!! R8VEC_ANGLE_3D computes the angle between two vectors in 3D. +! +! Modified: +! +! 07 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) U(3), V(3), the vectors. +! +! Output, real ( kind = 8 ) ANGLE, the angle between the two vectors. +! + implicit none + + real(kind=8) angle + real(kind=8) angle_cos + real(kind=8) r8_acos + real(kind=8) u(3) + real(kind=8) u_norm + real(kind=8) uv_dot + real(kind=8) v(3) + real(kind=8) v_norm + + uv_dot = dot_product(u(1:3), v(1:3)) + + u_norm = sqrt(dot_product(u(1:3), u(1:3))) + + v_norm = sqrt(dot_product(v(1:3), v(1:3))) + + angle_cos = uv_dot / u_norm / v_norm + + angle = r8_acos(angle_cos) + + return +end +subroutine r8vec_any_normal(dim_num, v1, v2) + +!*****************************************************************************80 +! +!! R8VEC_ANY_NORMAL returns some normal vector to V1. +! +! Discussion: +! +! If DIM_NUM < 2, then no normal vector can be returned. +! +! If V1 is the zero vector, then any unit vector will do. +! +! No doubt, there are better, more robust algorithms. But I will take +! just about ANY reasonable unit vector that is normal to V1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) V1(DIM_NUM), the vector. +! +! Output, real ( kind = 8 ) V2(DIM_NUM), a vector that is +! normal to V2, and has unit Euclidean length. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) r8vec_norm + integer(kind=4) i + integer(kind=4) j + integer(kind=4) k + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) + real(kind=8) vj + real(kind=8) vk + + if (dim_num < 2) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8VEC_ANY_NORMAL - Fatal error!' + write (*, '(a)') ' Called with DIM_NUM < 2.' + stop 1 + end if + + if (r8vec_norm(dim_num, v1) == 0.0D+00) then + v2(1) = 1.0D+00 + v2(2:dim_num) = 0.0D+00 + return + end if +! +! Seek the largest entry in V1, VJ = V1(J), and the +! second largest, VK = V1(K). +! +! Since V1 does not have zero norm, we are guaranteed that +! VJ, at least, is not zero. +! + j = -1 + vj = 0.0D+00 + + k = -1 + vk = 0.0D+00 + + do i = 1, dim_num + + if (abs(vk) < abs(v1(i)) .or. k < 1) then + + if (abs(vj) < abs(v1(i)) .or. j < 1) then + k = j + vk = vj + j = i + vj = v1(i) + else + k = i + vk = v1(i) + end if + + end if + + end do +! +! Setting V2 to zero, except that V2(J) = -VK, and V2(K) = VJ, +! will just about do the trick. +! + v2(1:dim_num) = 0.0D+00 + + v2(j) = -vk / sqrt(vk * vk + vj * vj) + v2(k) = vj / sqrt(vk * vk + vj * vj) + + return +end +subroutine r8vec_bracket(n, x, xval, left, right) + +!*****************************************************************************80 +! +!! R8VEC_BRACKET searches a sorted array for successive brackets of a value. +! +! Discussion: +! +! If the values in the vector are thought of as defining intervals +! on the real line, then this routine searches for the interval +! nearest to or containing the given value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, length of input array. +! +! Input, real ( kind = 8 ) X(N), an array that has been sorted into +! ascending order. +! +! Input, real ( kind = 8 ) XVAL, a value to be bracketed. +! +! Output, integer ( kind = 4 ) LEFT, RIGHT, the results of the search. +! Either: +! XVAL < X(1), when LEFT = 1, RIGHT = 2; +! X(N) < XVAL, when LEFT = N-1, RIGHT = N; +! or +! X(LEFT) <= XVAL <= X(RIGHT). +! + implicit none + + integer(kind=4) n + + integer(kind=4) i + integer(kind=4) left + integer(kind=4) right + real(kind=8) x(n) + real(kind=8) xval + + do i = 2, n - 1 + + if (xval < x(i)) then + left = i - 1 + right = i + return + end if + + end do + + left = n - 1 + right = n + + return +end +function r8vec_cross_product_2d(v1, v2) + +!*****************************************************************************80 +! +!! R8VEC_CROSS_PRODUCT_2D finds the cross product of a pair of vectors in 2D. +! +! Discussion: +! +! Strictly speaking, the vectors V1 and V2 should be considered +! to lie in a 3D space, both having Z coordinate zero. The cross +! product value V3 then represents the standard cross product vector +! (0,0,V3). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(2), V2(2), the vectors. +! +! Output, real ( kind = 8 ) R8VEC_CROSS_PRODUCT_2D, the cross product. +! + implicit none + + real(kind=8) r8vec_cross_product_2d + real(kind=8) v1(2) + real(kind=8) v2(2) + + r8vec_cross_product_2d = v1(1) * v2(2) - v1(2) * v2(1) + + return +end +function r8vec_cross_product_affine_2d(v0, v1, v2) + +!*****************************************************************************80 +! +!! R8VEC_CROSS_PRODUCT_AFFINE_2D finds the affine cross product in 2D. +! +! Discussion: +! +! Strictly speaking, the vectors V1 and V2 should be considered +! to lie in a 3D space, both having Z coordinate zero. The cross +! product value V3 then represents the standard cross product vector +! (0,0,V3). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 October 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V0(2), the base vector. +! +! Input, real ( kind = 8 ) V1(2), V2(2), the vectors. +! +! Output, real ( kind = 8 ) R8VEC_CROSS_PRODUCT_AFFINE_2D, +! the cross product (V1-V0) x (V2-V0). +! + implicit none + + real(kind=8) r8vec_cross_product_affine_2d + real(kind=8) v0(2) + real(kind=8) v1(2) + real(kind=8) v2(2) + + r8vec_cross_product_affine_2d = & + (v1(1) - v0(1)) * (v2(2) - v0(2)) & + - (v2(1) - v0(1)) * (v1(2) - v0(2)) + + return +end +subroutine r8vec_cross_product_3d(v1, v2, v3) + +!*****************************************************************************80 +! +!! R8VEC_CROSS_PRODUCT_3D computes the cross product of two vectors in 3D. +! +! Discussion: +! +! The cross product in 3D can be regarded as the determinant of the +! symbolic matrix: +! +! | i j k | +! det | x1 y1 z1 | +! | x2 y2 z2 | +! +! = ( y1 * z2 - z1 * y2 ) * i +! + ( z1 * x2 - x1 * z2 ) * j +! + ( x1 * y2 - y1 * x2 ) * k +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), V2(3), the two vectors. +! +! Output, real ( kind = 8 ) V3(3), the cross product vector. +! + implicit none + + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + + v3(1) = v1(2) * v2(3) - v1(3) * v2(2) + v3(2) = v1(3) * v2(1) - v1(1) * v2(3) + v3(3) = v1(1) * v2(2) - v1(2) * v2(1) + + return +end +subroutine r8vec_cross_product_affine_3d(v0, v1, v2, v3) + +!*****************************************************************************80 +! +!! R8VEC_CROSS_PRODUCT_AFFINE_3D computes the affine cross product in 3D. +! +! Discussion: +! +! The cross product in 3D can be regarded as the determinant of the +! symbolic matrix: +! +! | i j k | +! det | x1 y1 z1 | +! | x2 y2 z2 | +! +! = ( y1 * z2 - z1 * y2 ) * i +! + ( z1 * x2 - x1 * z2 ) * j +! + ( x1 * y2 - y1 * x2 ) * k +! +! Here, we use V0 as the base of an affine system so we compute +! the cross product of (V1-V0) and (V2-V0). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 October 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V0(3), the base vector. +! +! Input, real ( kind = 8 ) V1(3), V2(3), the two vectors. +! +! Output, real ( kind = 8 ) V3(3), the cross product vector +! ( V1-V0) x (V2-V0). +! + implicit none + + real(kind=8) v0(3) + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + + v3(1) = (v1(2) - v0(2)) * (v2(3) - v0(3)) & + - (v2(2) - v0(2)) * (v1(3) - v0(3)) + + v3(2) = (v1(3) - v0(3)) * (v2(1) - v0(1)) & + - (v2(3) - v0(3)) * (v1(1) - v0(1)) + + v3(3) = (v1(1) - v0(1)) * (v2(2) - v0(2)) & + - (v2(1) - v0(1)) * (v1(2) - v0(2)) + + return +end +function r8vec_distance(dim_num, v1, v2) + +!*****************************************************************************80 +! +!! R8VEC_DISTANCE returns the Euclidean distance between two vectors. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the vectors. +! +! Output, real ( kind = 8 ) R8VEC_DISTANCE, the Euclidean distance +! between the vectors. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) r8vec_distance + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) + + r8vec_distance = sqrt(sum((v1(1:dim_num) - v2(1:dim_num))**2)) + + return +end +function r8vec_dot_product(dim_num, v1, v2) + +!*****************************************************************************80 +! +!! R8VEC_DOT_PRODUCT finds the dot product of a pair of vectors in ND. +! +! Discussion: +! +! In FORTRAN, the system routine DOT_PRODUCT should be called +! directly. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the vectors. +! +! Output, real ( kind = 8 ) R8VEC_DOT_PRODUCT, the dot product. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) r8vec_dot_product + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) + + r8vec_dot_product = dot_product(v1(1:dim_num), v2(1:dim_num)) + + return +end +function r8vec_dot_product_affine(n, v0, v1, v2) + +!*****************************************************************************80 +! +!! R8VEC_DOT_PRODUCT_AFFINE computes the affine dot product V1-V0 * V2-V0. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 October 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the spatial dimension. +! +! Input, real ( kind = 8 ) V0(N), the base vector. +! +! Input, real ( kind = 8 ) V1(N), V2(N), the vectors. +! +! Output, real ( kind = 8 ) R8VEC_DOT_PRODUCT_AFFINE, the dot product. +! + implicit none + + integer(kind=4) n + + real(kind=8) r8vec_dot_product_affine + real(kind=8) v0(n) + real(kind=8) v1(n) + real(kind=8) v2(n) + + r8vec_dot_product_affine = dot_product( & + v1(1:n) - v0(1:n), & + v2(1:n) - v0(1:n)) + + return +end +function r8vec_eq(n, a1, a2) + +!*****************************************************************************80 +! +!! R8VEC_EQ is true if every pair of entries in two vectors is equal. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 March 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the vectors. +! +! Input, real ( kind = 8 ) A1(N), A2(N), two vectors to compare. +! +! Output, logical ( kind = 4 ) R8VEC_EQ. +! R8VEC_EQ is TRUE if every pair of elements A1(I) and A2(I) are equal. +! + implicit none + + integer(kind=4) n + + real(kind=8) a1(n) + real(kind=8) a2(n) + logical(kind=4) r8vec_eq + + r8vec_eq = (all(a1(1:n) == a2(1:n))) + + return +end +function r8vec_gt(n, a1, a2) + +!*****************************************************************************80 +! +!! R8VEC_GT == ( A1 > A2 ) for real vectors. +! +! Discussion: +! +! The comparison is lexicographic. +! +! A1 > A2 <=> A1(1) > A2(1) or +! ( A1(1) == A2(1) and A1(2) > A2(2) ) or +! ... +! ( A1(1:N-1) == A2(1:N-1) and A1(N) > A2(N) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the vectors. +! +! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared. +! +! Output, logical ( kind = 4 ) R8VEC_GT, is TRUE if and only if A1 > A2. +! + implicit none + + integer(kind=4) n + + real(kind=8) a1(n) + real(kind=8) a2(n) + integer(kind=4) i + logical(kind=4) r8vec_gt + + r8vec_gt = .false. + + do i = 1, n + + if (a2(i) < a1(i)) then + r8vec_gt = .true. + exit + else if (a1(i) < a2(i)) then + r8vec_gt = .false. + exit + end if + + end do + + return +end +function r8vec_lt(n, a1, a2) + +!*****************************************************************************80 +! +!! R8VEC_LT == ( A1 < A2 ) for real vectors. +! +! Discussion: +! +! The comparison is lexicographic. +! +! A1 < A2 <=> A1(1) < A2(1) or +! ( A1(1) == A2(1) and A1(2) < A2(2) ) or +! ... +! ( A1(1:N-1) == A2(1:N-1) and A1(N) < A2(N) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the vectors. +! +! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared. +! +! Output, logical ( kind = 4 ) R8VEC_LT, is TRUE if and only if A1 < A2. +! + implicit none + + integer(kind=4) n + + real(kind=8) a1(n) + real(kind=8) a2(n) + integer(kind=4) i + logical(kind=4) r8vec_lt + + r8vec_lt = .false. + + do i = 1, n + + if (a1(i) < a2(i)) then + r8vec_lt = .true. + exit + else if (a2(i) < a1(i)) then + r8vec_lt = .false. + exit + end if + + end do + + return +end +function r8vec_norm(n, a) + +!*****************************************************************************80 +! +!! R8VEC_NORM returns the L2 norm of an R8VEC. +! +! Discussion: +! +! An R8VEC is a vector of R8's. +! +! The vector L2 norm is defined as: +! +! R8VEC_NORM = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 August 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in A. +! +! Input, real ( kind = 8 ) A(N), the vector whose L2 norm is desired. +! +! Output, real ( kind = 8 ) R8VEC_NORM, the L2 norm of A. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(n) + real(kind=8) r8vec_norm + + r8vec_norm = sqrt(sum(a(1:n)**2)) + + return +end +function r8vec_norm_affine(n, v0, v1) + +!*****************************************************************************80 +! +!! R8VEC_NORM_AFFINE returns the affine norm of an R8VEC. +! +! Discussion: +! +! An R8VEC is a vector of R8's. +! +! The affine vector L2 norm is defined as: +! +! R8VEC_NORM_AFFINE(V0,V1) +! = sqrt ( sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 27 October 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the order of the vectors. +! +! Input, real ( kind = 8 ) V0(N), the base vector. +! +! Input, real ( kind = 8 ) V1(N), the vector whose affine norm is desired. +! +! Output, real ( kind = 8 ) R8VEC_NORM_AFFINE, the L2 norm of V1-V0. +! + implicit none + + integer(kind=4) n + + real(kind=8) r8vec_norm_affine + real(kind=8) v0(n) + real(kind=8) v1(n) + + r8vec_norm_affine = sqrt(sum((v0(1:n) - v1(1:n))**2)) + + return +end +subroutine r8vec_normal_01(n, seed, x) + +!*****************************************************************************80 +! +!! R8VEC_NORMAL_01 samples the unit normal probability distribution. +! +! Discussion: +! +! The standard normal probability distribution function (PDF) has +! mean 0 and standard deviation 1. +! +! This routine can generate a vector of values on one call. It +! has the feature that it should provide the same results +! in the same order no matter how we break up the task. +! +! The Box-Muller method is used, which is efficient, but +! generates an even number of values each time. On any call +! to this routine, an even number of new values are generated. +! Depending on the situation, one value may be left over. +! In that case, it is saved for the next call. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 January 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of values desired. If N is +! negative, then the code will flush its internal memory; in particular, +! if there is a saved value to be used on the next call, it is +! instead discarded. This is useful if the user has reset the +! random number seed, for instance. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. +! +! Local parameters: +! +! Local, integer MADE, records the number of values that have +! been computed. On input with negative N, this value overwrites +! the return value of N, so the user can get an accounting of +! how much work has been done. +! +! Local, real ( kind = 8 ) R(N+1), is used to store some uniform +! random values. Its dimension is N+1, but really it is only needed +! to be the smallest even number greater than or equal to N. +! +! Local, integer SAVED, is 0 or 1 depending on whether there is a +! single saved value left over from the previous call. +! +! Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of +! X that we need to compute. This starts off as 1:N, but is adjusted +! if we have a saved value that can be immediately stored in X(1), +! and so on. +! +! Local, real ( kind = 8 ) Y, the value saved from the previous call, if +! SAVED is 1. +! + implicit none + + integer(kind=4) n + + integer(kind=4) m + integer(kind=4), save :: made = 0 + real(kind=8) r(n + 1) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) r8_uniform_01 + integer(kind=4), save :: saved = 0 + integer(kind=4) seed + real(kind=8) x(n) + integer(kind=4) x_hi_index + integer(kind=4) x_lo_index + real(kind=8), save :: y = 0.0D+00 +! +! I'd like to allow the user to reset the internal data. +! But this won't work properly if we have a saved value Y. +! I'm making a crock option that allows the user to signal +! explicitly that any internal memory should be flushed, +! by passing in a negative value for N. +! + if (n < 0) then + n = made + made = 0 + saved = 0 + y = 0.0D+00 + return + else if (n == 0) then + return + end if +! +! Record the range of X we need to fill in. +! + x_lo_index = 1 + x_hi_index = n +! +! Use up the old value, if we have it. +! + if (saved == 1) then + x(1) = y + saved = 0 + x_lo_index = 2 + end if +! +! Maybe we don't need any more values. +! + if (x_hi_index - x_lo_index + 1 == 0) then +! +! If we need just one new value, do that here to avoid null arrays. +! + else if (x_hi_index - x_lo_index + 1 == 1) then + + r(1) = r8_uniform_01(seed) + + if (r(1) == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8VEC_NORMAL_01 - Fatal error!' + write (*, '(a)') ' R8_UNIFORM_01 returned a value of 0.' + stop 1 + end if + + r(2) = r8_uniform_01(seed) + + x(x_hi_index) = & + sqrt(-2.0D+00 * log(r(1))) * cos(2.0D+00 * r8_pi * r(2)) + y = sqrt(-2.0D+00 * log(r(1))) * sin(2.0D+00 * r8_pi * r(2)) + + saved = 1 + + made = made + 2 +! +! If we require an even number of values, that's easy. +! + else if (mod(x_hi_index - x_lo_index + 1, 2) == 0) then + + m = (x_hi_index - x_lo_index + 1) / 2 + + call r8vec_uniform_01(2 * m, seed, r) + + x(x_lo_index:x_hi_index - 1:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & + * cos(2.0D+00 * r8_pi * r(2:2 * m:2)) + + x(x_lo_index + 1:x_hi_index:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & + * sin(2.0D+00 * r8_pi * r(2:2 * m:2)) + + made = made + x_hi_index - x_lo_index + 1 +! +! If we require an odd number of values, we generate an even number, +! and handle the last pair specially, storing one in X(N), and +! saving the other for later. +! + else + + x_hi_index = x_hi_index - 1 + + m = (x_hi_index - x_lo_index + 1) / 2 + 1 + + call r8vec_uniform_01(2 * m, seed, r) + + x(x_lo_index:x_hi_index - 1:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & + * cos(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) + + x(x_lo_index + 1:x_hi_index:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & + * sin(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) + + x(n) = sqrt(-2.0E+00 * log(r(2 * m - 1))) & + * cos(2.0D+00 * r8_pi * r(2 * m)) + + y = sqrt(-2.0D+00 * log(r(2 * m - 1))) & + * sin(2.0D+00 * r8_pi * r(2 * m)) + + saved = 1 + + made = made + x_hi_index - x_lo_index + 2 + + end if + + return +end +function r8vec_normsq(n, v) + +!*****************************************************************************80 +! +!! R8VEC_NORMSQ returns the square of the L2 norm of an R8VEC. +! +! Discussion: +! +! An R8VEC is a vector of R8's. +! +! The square of the vector L2 norm is defined as: +! +! R8VEC_NORMSQ = sum ( 1 <= I <= N ) V(I)^2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 October 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the vector dimension. +! +! Input, real ( kind = 8 ) V(N), the vector. +! +! Output, real ( kind = 8 ) R8VEC_NORMSQ, the squared L2 norm. +! + implicit none + + integer(kind=4) n + + real(kind=8) r8vec_normsq + real(kind=8) v(n) + + r8vec_normsq = sum(v(1:n)**2) + + return +end + +function r8vec_normsq_affine(n, v0, v1) + +!*****************************************************************************80 +! +!! R8VEC_NORMSQ_AFFINE returns the affine squared norm of an R8VEC. +! +! Discussion: +! +! An R8VEC is a vector of R8's. +! +! The affine squared vector L2 norm is defined as: +! +! R8VEC_NORMSQ_AFFINE(V0,V1) +! = sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 October 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the vector dimension. +! +! Input, real ( kind = 8 ) V0(N), the base vector. +! +! Input, real ( kind = 8 ) V1(N), the vector. +! +! Output, real ( kind = 8 ) R8VEC_NORMSQ_AFFINE, the affine squared L2 norm. +! + implicit none + + integer(kind=4) n + + real(kind=8) r8vec_normsq_affine + real(kind=8) v0(n) + real(kind=8) v1(n) + + r8vec_normsq_affine = sum((v0(1:n) - v1(1:n))**2) + + return +end +subroutine r8vec_polarize(n, a, p, a_normal, a_parallel) + +!*****************************************************************************80 +! +!! R8VEC_POLARIZE decomposes an R8VEC into normal and parallel components. +! +! Discussion: +! +! An R8VEC is a vector of R8's. +! +! The (nonzero) vector P defines a direction. +! +! The vector A can be written as the sum +! +! A = A_normal + A_parallel +! +! where A_parallel is a linear multiple of P, and A_normal +! is perpendicular to P. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 November 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the array. +! +! Input, real ( kind = 8 ) A(N), the vector to be polarized. +! +! Input, real ( kind = 8 ) P(N), the polarizing direction. +! +! Output, real ( kind = 8 ) A_NORMAL(N), A_PARALLEL(N), the normal +! and parallel components of A. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(n) + real(kind=8) a_dot_p + real(kind=8) a_normal(n) + real(kind=8) a_parallel(n) + real(kind=8) p(n) + real(kind=8) p_norm + + p_norm = sqrt(sum(p(1:n)**2)) + + if (p_norm == 0.0D+00) then + a_normal(1:n) = a(1:n) + a_parallel(1:n) = 0.0D+00 + return + end if + + a_dot_p = dot_product(a(1:n), p(1:n)) / p_norm + + a_parallel(1:n) = a_dot_p * p(1:n) / p_norm + + a_normal(1:n) = a(1:n) - a_parallel(1:n) + + return +end +subroutine r8vec_print(n, a, title) + +!*****************************************************************************80 +! +!! R8VEC_PRINT prints an R8VEC. +! +! Discussion: +! +! An R8VEC is a vector of R8's. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 August 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of components of the vector. +! +! Input, real ( kind = 8 ) A(N), the vector to be printed. +! +! Input, character ( len = * ) TITLE, a title. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(n) + integer(kind=4) i + character(len=*) title + + write (*, '(a)') ' ' + write (*, '(a)') trim(title) + write (*, '(a)') ' ' + + do i = 1, n + write (*, '(2x,i8,a,1x,g16.8)') i, ':', a(i) + end do + + return +end +function r8vec_scalar_triple_product(v1, v2, v3) + +!*****************************************************************************80 +! +!! R8VEC_SCALAR_TRIPLE_PRODUCT finds the scalar triple product in 3D. +! +! Discussion: +! +! [A,B,C] = A dot ( B cross C ) +! = B dot ( C cross A ) +! = C dot ( A cross B ) +! +! The volume of a parallelepiped, whose sides are given by +! vectors A, B, and C, is abs ( A dot ( B cross C ) ). +! +! Three vectors are coplanar if and only if their scalr triple +! product vanishes. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 August 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Eric Weisstein, +! "Scalar Triple Product", +! CRC Concise Encyclopedia of Mathematics, +! CRC, 1999 +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vectors. +! +! Output, real ( kind = 8 ) R8VEC_SCALAR_TRIPLE_PRODUCT, the scalar +! triple product. +! + implicit none + + real(kind=8) r8vec_scalar_triple_product + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + real(kind=8) v4(3) + + call r8vec_cross_product_3d(v2, v3, v4) + + r8vec_scalar_triple_product = dot_product(v1(1:3), v4(1:3)) + + return +end +subroutine r8vec_swap(n, a1, a2) + +!*****************************************************************************80 +! +!! R8VEC_SWAP swaps the entries of two real vectors. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the arrays. +! +! Input/output, real ( kind = 8 ) A1(N), A2(N), the vectors to swap. +! + implicit none + + integer(kind=4) n + + real(kind=8) a1(n) + real(kind=8) a2(n) + real(kind=8) a3(n) + + a3(1:n) = a1(1:n) + a1(1:n) = a2(1:n) + a2(1:n) = a3(1:n) + + return +end +subroutine r8vec_uniform_01(n, seed, r) + +!*****************************************************************************80 +! +!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. +! +! Discussion: +! +! An R8VEC is a vector of real ( kind = 8 ) values. +! +! For now, the input quantity SEED is an integer ( kind = 4 ) variable. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 July 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paul Bratley, Bennett Fox, Linus Schrage, +! A Guide to Simulation, +! Springer Verlag, pages 201-202, 1983. +! +! Bennett Fox, +! Algorithm 647: +! Implementation and Relative Efficiency of Quasirandom +! Sequence Generators, +! ACM Transactions on Mathematical Software, +! Volume 12, Number 4, pages 362-376, 1986. +! +! Peter Lewis, Allen Goodman, James Miller +! A Pseudo-Random Number Generator for the System/360, +! IBM Systems Journal, +! Volume 8, pages 136-143, 1969. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the vector. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which +! should NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. +! + implicit none + + integer(kind=4) n + + integer(kind=4) i + integer(kind=4) k + integer(kind=4) seed + real(kind=8) r(n) + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8VEC_UNIFORM_01 - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + do i = 1, n + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if + + r(i) = real(seed, kind=8) * 4.656612875D-10 + + end do + + return +end +subroutine r8vec_uniform_ab(n, a, b, seed, r) + +!*****************************************************************************80 +! +!! R8VEC_UNIFORM_AB returns a scaled pseudorandom R8VEC. +! +! Discussion: +! +! An R8VEC is a vector of real ( kind = 8 ) values. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 July 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paul Bratley, Bennett Fox, Linus Schrage, +! A Guide to Simulation, +! Springer Verlag, pages 201-202, 1983. +! +! Bennett Fox, +! Algorithm 647: +! Implementation and Relative Efficiency of Quasirandom +! Sequence Generators, +! ACM Transactions on Mathematical Software, +! Volume 12, Number 4, pages 362-376, 1986. +! +! Peter Lewis, Allen Goodman, James Miller +! A Pseudo-Random Number Generator for the System/360, +! IBM Systems Journal, +! Volume 8, pages 136-143, 1969. +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of entries in the vector. +! +! Input, real ( kind = 8 ) A, B, the lower and upper limits. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which +! should NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. +! + implicit none + + integer(kind=4) n + + real(kind=8) a + real(kind=8) b + integer(kind=4) i + integer(kind=4) k + integer(kind=4) seed + real(kind=8) r(n) + + if (seed == 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'R8VEC_UNIFORM_AB - Fatal error!' + write (*, '(a)') ' Input value of SEED = 0.' + stop 1 + end if + + do i = 1, n + + k = seed / 127773 + + seed = 16807 * (seed - k * 127773) - k * 2836 + + if (seed < 0) then + seed = seed + 2147483647 + end if + + r(i) = a + (b - a) * real(seed, kind=8) * 4.656612875D-10 + + end do + + return +end +subroutine r8vec_uniform_unit(m, seed, w) + +!*****************************************************************************80 +! +!! R8VEC_UNIFORM_UNIT generates a uniformly random unit vector. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 October 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the spatial dimension. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) W(M), a random direction vector, +! with unit norm. +! + implicit none + + integer(kind=4) m + + real(kind=8) norm + integer(kind=4) seed + real(kind=8) w(m) +! +! Get M values from a standard normal distribution. +! + call r8vec_normal_01(m, seed, w) +! +! Compute the length of the vector. +! + norm = sqrt(sum(w(1:m)**2)) +! +! Normalize the vector. +! + w(1:m) = w(1:m) / norm + + return +end +subroutine radec_distance_3d(ra1, dec1, ra2, dec2, theta) + +!*****************************************************************************80 +! +!! RADEC_DISTANCE_3D - angular distance, astronomical units, sphere in 3D. +! +! Discussion: +! +! Right ascension is measured in hours, between 0 and 24, and +! essentially measures longitude. +! +! Declination measures the angle from the equator towards the north pole, +! and ranges from -90 (South Pole) to 90 (North Pole). +! +! On the unit sphere, the angular separation between two points is +! equal to their geodesic or great circle distance. On any other +! sphere, multiply the angular separation by the radius of the +! sphere to get the geodesic or great circle distance. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 December 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) RA1, DEC1, RA2, DEC2, the right ascension and +! declination of the two points. +! +! Output, real ( kind = 8 ) THETA, the angular separation between the points, +! in radians. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) cos_theta + real(kind=8) dec1 + real(kind=8) dec2 + real(kind=8) degrees_to_radians + real(kind=8) norm_v1 + real(kind=8) norm_v2 + real(kind=8) phi1 + real(kind=8) phi2 + real(kind=8) r8_acos + real(kind=8) ra1 + real(kind=8) ra2 + real(kind=8) theta + real(kind=8) theta1 + real(kind=8) theta2 + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) + + theta1 = degrees_to_radians(15.0D+00 * ra1) + phi1 = degrees_to_radians(dec1) + + v1(1:dim_num) = (/cos(theta1) * cos(phi1), & + sin(theta1) * cos(phi1), & + sin(phi1)/) + + norm_v1 = sqrt(sum(v1(1:dim_num)**2)) + + theta2 = degrees_to_radians(15.0D+00 * ra2) + phi2 = degrees_to_radians(dec2) + + v2(1:dim_num) = (/cos(theta2) * cos(phi2), & + sin(theta2) * cos(phi2), & + sin(phi2)/) + + norm_v2 = sqrt(sum(v2(1:dim_num)**2)) + + cos_theta = dot_product(v1(1:dim_num), v2(1:dim_num)) & + / (norm_v1 * norm_v2) + + theta = r8_acos(cos_theta) + + return +end +subroutine radec_to_xyz(ra, dec, p) + +!*****************************************************************************80 +! +!! RADEC_TO_XYZ converts right ascension/declination to (X,Y,Z) coordinates. +! +! Discussion: +! +! Right ascension is measured in hours, between 0 and 24, and +! essentially measures longitude. +! +! Declination measures the angle from the equator towards the north pole, +! and ranges from -90 (South Pole) to 90 (North Pole). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) RA, DEC, the right ascension and declination +! of a point. +! +! Output, real ( kind = 8 ) P(3), the corresponding coordinates of +! a point with radius 1. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dec + real(kind=8) degrees_to_radians + real(kind=8) p(dim_num) + real(kind=8) phi + real(kind=8) ra + real(kind=8) theta + + theta = degrees_to_radians(15.0D+00 * ra) + phi = degrees_to_radians(dec) + + p(1) = cos(theta) * cos(phi) + p(2) = sin(theta) * cos(phi) + p(3) = sin(phi) + + return +end +function radians_to_degrees(angle_rad) + +!*****************************************************************************80 +! +!! RADIANS_TO_DEGREES converts an angle from radians to degrees. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) ANGLE_RAD, an angle in radians. +! +! Output, real ( kind = 8 ) RADIANS_TO_DEGREES, the equivalent angle +! in degrees. +! + implicit none + + real(kind=8) angle_rad + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radians_to_degrees + + radians_to_degrees = (angle_rad / r8_pi) * 180.0D+00 + + return +end +subroutine radians_to_dms(angle_rad, degrees, minutes, seconds) + +!*****************************************************************************80 +! +!! RADIANS_TO_DMS converts an angle from radians to degrees/minutes/seconds. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) ANGLE_RAD, the angle in radians. +! +! Output, integer ( kind = 4 ) DEGREES, MINUTES, SECONDS, the equivalent +! angle in degrees, minutes, and seconds. +! + implicit none + + real(kind=8) angle_deg + real(kind=8) angle_rad + integer(kind=4) degrees + integer(kind=4) minutes + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seconds + + angle_deg = 180.0D+00 * abs(angle_rad) / r8_pi + + degrees = int(angle_deg) + angle_deg = (angle_deg - real(degrees, kind=8)) * 60.0D+00 + minutes = int(angle_deg) + angle_deg = (angle_deg - real(minutes, kind=8)) * 60.0D+00 + seconds = nint(angle_deg) + + if (angle_rad < 0.0D+00) then + degrees = -degrees + minutes = -minutes + seconds = -seconds + end if + + return +end +subroutine random_initialize(seed) + +!*****************************************************************************80 +! +!! RANDOM_INITIALIZE initializes the FORTRAN90 random number seed. +! +! Discussion: +! +! If you don't initialize the random number generator, its behavior +! is not specified. If you initialize it simply by: +! +! call random_seed ( ) +! +! its behavior is not specified. On the DEC ALPHA, if that's all you +! do, the same random number sequence is returned. In order to actually +! try to scramble up the random number generator a bit, this routine +! goes through the tedious process of getting the size of the random +! number seed, making up values based on the current time, and setting +! the random number seed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED. +! If SEED is zero on input, then you're asking this routine to come up +! with a seed value, which is returned as output. +! If SEED is nonzero on input, then you're asking this routine to +! use the input value of SEED to initialize the random number generator. +! + implicit none + + integer(kind=4) count + integer(kind=4) count_max + integer(kind=4) count_rate + integer(kind=4) i + integer(kind=4) seed + integer(kind=4), allocatable :: seed_vector(:) + integer(kind=4) seed_size + real(kind=8) t +! +! Initialize the random number seed. +! + call random_seed() +! +! Determine the size of the random number seed. +! + call random_seed(size=seed_size) +! +! Allocate a seed of the right size. +! + allocate (seed_vector(seed_size)) + + if (seed /= 0) then + + write (*, '(a)') ' ' + write (*, '(a)') 'RANDOM_INITIALIZE' + write (*, '(a,i12)') ' Initialize RANDOM_NUMBER with user SEED = ', seed + + else + + call system_clock(count, count_rate, count_max) + + seed = count + + write (*, '(a)') ' ' + write (*, '(a)') 'RANDOM_INITIALIZE' + write (*, '(a,i12)') & + ' Initialize RANDOM_NUMBER with arbitrary SEED = ', seed + + end if +! +! Now set the seed. +! + seed_vector(1:seed_size) = seed + + call random_seed(put=seed_vector(1:seed_size)) +! +! Free up the seed space. +! + deallocate (seed_vector) +! +! Call the random number routine a bunch of times. +! + do i = 1, 100 + call random_number(harvest=t) + end do + + return +end +subroutine rotation_axis_vector_3d(axis, angle, v, w) + +!*****************************************************************************80 +! +!! ROTATION_AXIS_VECTOR_3D rotates a vector around an axis vector in 3D. +! +! Discussion: +! +! Thanks to Cody Farnell for correcting some mistakes in an earlier +! version of this routine. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 May 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) AXIS(3), the axis vector for the rotation. +! +! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation. +! +! Input, real ( kind = 8 ) V(3), the vector to be rotated. +! +! Output, real ( kind = 8 ) W(3), the rotated vector. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) angle + real(kind=8) axis(dim_num) + real(kind=8) axis_norm + real(kind=8) dot + real(kind=8) norm + real(kind=8) normal(dim_num) + real(kind=8) normal_component + real(kind=8) normal2(dim_num) + real(kind=8) parallel(dim_num) + real(kind=8) rot(dim_num) + real(kind=8) u(dim_num) + real(kind=8) v(dim_num) + real(kind=8) w(dim_num) +! +! Compute the length of the rotation axis. +! + u(1:dim_num) = axis(1:dim_num) + + axis_norm = sqrt(sum(u(1:dim_num)**2)) + + if (axis_norm == 0.0D+00) then + w(1:dim_num) = 0.0D+00 + return + end if + + u(1:dim_num) = u(1:dim_num) / axis_norm +! +! Compute the dot product of the vector and the unit rotation axis. +! + dot = dot_product(u(1:dim_num), v(1:dim_num)) +! +! Compute the parallel component of the vector. +! + parallel(1:dim_num) = dot * u(1:dim_num) +! +! Compute the normal component of the vector. +! + normal(1:dim_num) = v(1:dim_num) - parallel(1:dim_num) + + normal_component = sqrt(sum(normal(1:dim_num)**2)) + + if (normal_component == 0.0D+00) then + w(1:dim_num) = parallel(1:dim_num) + return + end if + + normal(1:dim_num) = normal(1:dim_num) / normal_component +! +! Compute a second vector, lying in the plane, perpendicular +! to V, and forming a right-handed system, as the cross product +! of the first two vectors. +! + normal2(1) = u(2) * normal(3) - u(3) * normal(2) + normal2(2) = u(3) * normal(1) - u(1) * normal(3) + normal2(3) = u(1) * normal(2) - u(2) * normal(1) + + norm = sqrt(sum(normal2(1:dim_num)**2)) + + normal2(1:dim_num) = normal2(1:dim_num) / norm +! +! Rotate the normal component by the angle. +! + rot(1:dim_num) = normal_component * ( & + cos(angle) * normal(1:dim_num) & + + sin(angle) * normal2(1:dim_num)) +! +! The rotated vector is the parallel component plus the rotated component. +! + w(1:dim_num) = parallel(1:dim_num) + rot(1:dim_num) + + return +end +subroutine rtp_to_xyz(r, theta, phi, xyz) + +!*****************************************************************************80 +! +!! RTP_TO_XYZ converts (R,Theta,Phi) to (X,Y,Z) coordinates. +! +! Discussion: +! +! R measures the distance of the point to the origin. +! +! Theta measures the "longitude" of the point, between 0 and 2 PI. +! +! PHI measures the angle from the "north pole", between 0 and PI. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 January 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, THETA, PHI, the radius, longitude, and +! declination of a point. +! +! Output, real ( kind = 8 ) XYZ(3), the corresponding Cartesian coordinates. +! + implicit none + + real(kind=8) phi + real(kind=8) r + real(kind=8) theta + real(kind=8) xyz(3) + + xyz(1) = r * cos(theta) * sin(phi) + xyz(2) = r * sin(theta) * sin(phi) + xyz(3) = r * cos(phi) + + return +end +subroutine segment_contains_point_1d(p1, p2, p, t) + +!*****************************************************************************80 +! +!! SEGMENT_CONTAINS_POINT_1D reports if a line segment contains a point in 1D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 September 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1, P2, two points defining a line segment. +! The line segment has T = 0 at P1, and T = 1 at P2. +! +! Input, real ( kind = 8 ) P, a point to be tested. +! +! Output, real ( kind = 8 ) T, the coordinate of P3 in units of (P2-P1). +! The point P3 is contained in the line segment if 0 <= T <= 1. +! + implicit none + + real(kind=8) p + real(kind=8) p1 + real(kind=8) p2 + real(kind=8) t + real(kind=8) unit + + unit = p2 - p1 + + if (unit == 0.0D+00) then + + if (p == p1) then + t = 0.5D+00 + else if (p < p1) then + t = -huge(t) + else if (p1 < p) then + t = huge(t) + end if + + else + + t = (p - p1) / unit + + end if + + return +end +subroutine segment_contains_point_2d(p1, p2, p, u) + +!*****************************************************************************80 +! +!! SEGMENT_CONTAINS_POINT_2D reports if a line segment contains a point in 2D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! In exact arithmetic, point P is on the line segment between +! P1 and P2 if and only if 0 <= U <= 1 and V = 0. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. +! +! Input, real ( kind = 8 ) P(2), a point to be tested. +! +! Output, real ( kind = 8 ) U(2), the components of P, with the first +! component measured along the axis with origin at P1 and unit at P2, +! and second component the magnitude of the off-axis portion of the +! vector P-P1, measured in units of (P2-P1). +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) normsq + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) u(dim_num) + + normsq = sum((p2(1:dim_num) - p1(1:dim_num))**2) + + if (normsq == 0.0D+00) then + + if (all(p(1:dim_num) == p1(1:dim_num))) then + u(1) = 0.5D+00 + u(2) = 0.0D+00 + else + u(1) = 0.5D+00 + u(2) = huge(u(2)) + end if + + else + + u(1) = sum((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) / normsq + + u(2) = sqrt(((u(1) - 1.0D+00) * p1(1) - u(1) * p2(1) + p(1))**2 & + + ((u(1) - 1.0D+00) * p1(2) - u(1) * p2(2) + p(2))**2) & + / sqrt(normsq) + + end if + + return +end +subroutine segment_point_coords_2d(p1, p2, p, s, t) + +!*****************************************************************************80 +! +!! SEGMENT_POINT_COORDS_2D: coordinates of a point on a line segment in 2D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! By the coordinates of a point P with respect to a line segment [P1,P2] +! we mean numbers S and T such that S gives us the distance from the +! point P to the nearest point PN on the line (not the line segment!), +! and T gives us the position of PN relative to P1 and P2. +! +! If S is zero, then P lies on the line. +! +! If 0 <= T <= 1, then PN lies on the line segment. +! +! If both conditions hold, then P lies on the line segment. +! +! If E is the length of the line segment, then the distance of the +! point to the line segment is: +! +! sqrt ( S^2 + T^2 * E^2 ) if T <= 0; +! S if 0 <= T <= 1 +! sqrt ( S^2 + (T-1)^2 * E^2 ) if 1 <= T +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 July 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. +! +! Input, real ( kind = 8 ) P(2), the point to be considered. +! +! Output, real ( kind = 8 ) S, the distance of P to the nearest point PN +! on the line through P1 and P2. (S will always be nonnegative.) +! +! Output, real ( kind = 8 ) T, the relative position of the point PN +! to the points P1 and P2. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) bot + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) s + 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 + + end if + + pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) + + s = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + + return +end +subroutine segment_point_coords_3d(p1, p2, p, s, t) + +!*****************************************************************************80 +! +!! SEGMENT_POINT_COORDS_3D: coordinates of a point on a line segment in 3D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! By the coordinates of a point P with respect to a line segment [P1,P2] +! we mean numbers S and T such that S gives us the distance from the +! point P to the nearest point PN on the line (not the line segment!), +! and T gives us the position of PN relative to P1 and P2. +! +! If S is zero, then P lies on the line. +! +! If 0 <= T <= 1, then PN lies on the line segment. +! +! If both conditions hold, then P lies on the line segment. +! +! If E is the length of the line segment, then the distance of the +! point to the line segment is: +! +! sqrt ( S^2 + T^2 * E^2 ) if T <= 0; +! S if 0 <= T <= 1 +! sqrt ( S^2 + (T-1)^2 * E^2 ) if 1 <= T +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 August 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the line segment. +! +! Input, real ( kind = 8 ) P(3), the point to be considered. +! +! Output, real ( kind = 8 ) S, the distance of P to the nearest point PN +! on the line through P1 and P2. (S will always be nonnegative.) +! +! Output, real ( kind = 8 ) T, the relative position of the point PN +! to the points P1 and P2. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) bot + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) s + 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 + + end if + + pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) + + s = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + + return +end +subroutine segment_point_dist_2d(p1, p2, p, dist) + +!*****************************************************************************80 +! +!! SEGMENT_POINT_DIST_2D: distance ( line segment, point ) in 2D. +! +! 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. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2006 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) bot + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + 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)) + + return +end +subroutine segment_point_dist_3d(p1, p2, p, dist) + +!*****************************************************************************80 +! +!! SEGMENT_POINT_DIST_3D: distance ( line segment, point ) in 3D. +! +! 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. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2006 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) bot + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + 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)) + + return +end +subroutine segment_point_near_2d(p1, p2, p, pn, dist, t) + +!*****************************************************************************80 +! +!! SEGMENT_POINT_NEAR_2D: nearest point on line segment to point in 2D. +! +! 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. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2006 +! +! Author: +! +! John Burkardt +! +! 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. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) bot + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + 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)) + + return +end +subroutine segment_point_near_3d(p1, p2, p, pn, dist, t) + +!*****************************************************************************80 +! +!! SEGMENT_POINT_NEAR_3D: nearest point on line segment to point in 3D. +! +! 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. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2006 +! +! Author: +! +! John Burkardt +! +! 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 ) PN(3), the point on the line segment +! nearest to 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 nearest point +! P to P1 and P2, that is PN = (1-T)*P1 + T*P2. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) bot + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + 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)) + + return +end +subroutine segments_curvature_2d(p1, p2, p3, curvature) + +!*****************************************************************************80 +! +!! SEGMENTS_CURVATURE_2D computes the curvature of two line segments in 2D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! We assume that the segments are [P1,P2] and [P2,P3]. +! +! We compute the circle that passes through P1, P2 and P3. +! +! The inverse of the radius of this circle is the local "curvature" +! associated with the three points. +! +! If curvature is 0, the two line segments have the same slope, +! and the three points are collinear. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 March 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), the points. +! +! Output, real ( kind = 8 ) CURVATURE, the local curvature. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) curvature + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + + call circle_exp2imp_2d(p1, p2, p3, r, pc) + + if (0.0D+00 < r) then + curvature = 1.0D+00 / r + else + curvature = 0.0D+00 + end if + + return +end +subroutine segments_dist_2d(p1, p2, q1, q2, dist) + +!*****************************************************************************80 +! +!! SEGMENTS_DIST_2D computes the distance between two line segments in 2D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! If the lines through [P1,P2] and [Q1,Q2] intersect, and both +! line segments include the point of intersection, then the distance +! is zero and we are done. +! +! Therefore, we compute the intersection of the two lines, and +! find the coordinates of that intersection point on each line. +! This will tell us if the zero distance case has occurred. +! +! Otherwise, let PN and QN be points in [P1,P2] and [Q1,Q2] for which +! the distance is minimal. If the lines do not intersect, then it +! cannot be the case that both PN and QN are strictly interior to their +! line segments, aside from the exceptional singular case when +! the line segments overlap or are parallel. Even then, one of PN +! and QN may be taken to be a segment endpoint. +! +! Therefore, our second computation finds the minimum of: +! +! Distance ( P1, [Q1,Q2] ); +! Distance ( P2, [Q1,Q2] ); +! Distance ( Q1, [P1,P2] ); +! Distance ( Q2, [P1,P2] ); +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 August 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the first +! segment. +! +! Input, real ( kind = 8 ) Q1(2), Q2(2), the endpoints of the second +! segment. +! +! Output, real ( kind = 8 ) DIST, the distance between the line segments. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) dist + real(kind=8) dist2 + integer(kind=4) ival + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) r(dim_num) + real(kind=8) rps + real(kind=8) rpt + real(kind=8) rqs + real(kind=8) rqt +! +! Determine whether and where the underlying lines intersect. +! + call lines_exp_int_2d(p1, p2, q1, q2, ival, r) +! +! If there is exactly one intersection point part of both lines, +! check that it is part of both line segments. +! + if (ival == 1) then + + call segment_point_coords_2d(p1, p2, r, rps, rpt) + call segment_point_coords_2d(q1, q2, r, rqs, rqt) + + if (0.0D+00 <= rpt .and. rpt <= 1.0D+00 .and. & + 0.0D+00 <= rqt .and. rqt <= 1.0D+00) then + dist = 0.0D+00 + return + end if + + end if +! +! If there is no intersection, or the intersection point is +! not part of both line segments, then an endpoint of one +! line segment achieves the minimum distance. +! + call segment_point_dist_2d(q1, q2, p1, dist2) + dist = dist2 + call segment_point_dist_2d(q1, q2, p2, dist2) + dist = min(dist, dist2) + call segment_point_dist_2d(p1, p2, q1, dist2) + dist = min(dist, dist2) + call segment_point_dist_2d(p1, p2, q2, dist2) + dist = min(dist, dist2) + + return +end +subroutine segments_dist_3d(p1, p2, q1, q2, dist) + +!*****************************************************************************80 +! +!! SEGMENTS_DIST_3D computes the distance between two line segments in 3D. +! +! Discussion: +! +! +! NOTE: The special cases for identical and parallel lines have not been +! worked out yet; those cases are exceptional, and so this code +! is made available in a slightly unfinished form! +! +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! Given two line segments, consider the underlying lines on which +! they lie. +! +! A) If the lines are identical, then the distance between the line segments +! is 0, if the segments overlap, or otherwise is attained by the +! minimum of the distances between each endpoint and the opposing +! line segment. +! +! B) If the lines are parallel, then the distance is either the distance +! between the lines, if the projection of one line segment onto +! the other overlaps, or otherwise is attained by the +! minimum of the distances between each endpoint and the opposing +! line segment. +! +! C) If the lines are not identical, and not parallel, then there are +! unique points PN and QN which are the closest pair of points on the lines. +! If PN is interior to [P1,P2] and QN is interior to [Q1,Q2], +! then the distance between the two line segments is the distance +! between PN and QN. Otherwise, the nearest distance can be computed +! by taking the minimum of the distance from each endpoing to the +! opposing line segment. +! +! Therefore, our computation first checks whether the lines are +! identical, parallel, or other, and checks for the special case +! where the minimum occurs in the interior. +! +! If that case is ruled out, it computes and returns the minimum of: +! +! Distance ( P1, [Q1,Q2] ); +! Distance ( P2, [Q1,Q2] ); +! Distance ( Q1, [P1,P2] ); +! Distance ( Q2, [P1,P2] ); +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 August 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the first +! segment. +! +! Input, real ( kind = 8 ) Q1(3), Q2(3), the endpoints of the second +! segment. +! +! Output, real ( kind = 8 ) DIST, the distance between the line segments. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + real(kind=8) det + real(kind=8) dist + real(kind=8) dist2 + real(kind=8) e + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) qn(dim_num) + real(kind=8) sn + real(kind=8) tn + real(kind=8) u(dim_num) + real(kind=8) v(dim_num) + real(kind=8) w0(dim_num) +! +! The lines are identical. +! THIS CASE NOT SET UP YET +! +! if ( lines_exp_equal_3d ( p1, p2, q1, q2 ) ) then +! end if +! +! The lines are not identical, but parallel +! THIS CASE NOT SET UP YET. +! +! if ( lines_exp_parallel_3d ( p1, p2, q1, q2 ) ) then +! end if +! +! C: The lines are not identical, not parallel. +! + +! +! Let U = (P2-P1) and V = (Q2-Q1) be the direction vectors on +! the two lines. +! + u(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) + v(1:dim_num) = q2(1:dim_num) - q1(1:dim_num) +! +! Let SN be the unknown coordinate of the nearest point PN on line 1, +! so that PN = P(SN) = P1 + SN * (P2-P1). +! +! Let TN be the unknown coordinate of the nearest point QN on line 2, +! so that QN = Q(TN) = Q1 + TN * (Q2-Q1). +! +! Let W0 = (P1-Q1). +! + w0(1:dim_num) = p1(1:dim_num) - q1(1:dim_num) +! +! The vector direction WC = P(SN) - Q(TC) is unique (among directions) +! perpendicular to both U and V, so +! +! U dot WC = 0 +! V dot WC = 0 +! +! or, equivalently: +! +! U dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 +! V dot ( P1 + SN * (P2 - P1) - Q1 - TN * (Q2 - Q1) ) = 0 +! +! or, equivalently: +! +! (u dot u ) * sn - (u dot v ) tc = -u * w0 +! (v dot u ) * sn - (v dot v ) tc = -v * w0 +! +! or, equivalently: +! +! ( a -b ) * ( sn ) = ( -d ) +! ( b -c ) ( tc ) ( -e ) +! + a = dot_product(u, u) + b = dot_product(u, v) + c = dot_product(v, v) + d = dot_product(u, w0) + e = dot_product(v, w0) +! +! Check the determinant. +! + det = -a * c + b * b + + if (det == 0.0D+00) then + sn = 0.0D+00 + if (abs(b) < abs(c)) then + tn = e / c + else + tn = d / b + end if + else + sn = (c * d - b * e) / det + tn = (b * d - a * e) / det + end if +! +! Now if both nearest points on the lines +! also happen to lie inside their line segments, +! then we have found the nearest points on the line segments. +! + if (0.0D+00 <= sn .and. sn <= 1.0D+00 .and. & + 0.0D+00 <= tn .and. tn <= 1.0D+00) then + pn(1:dim_num) = p1(1:dim_num) + sn * (p2(1:dim_num) - p1(1:dim_num)) + qn(1:dim_num) = q1(1:dim_num) + tn * (q2(1:dim_num) - q1(1:dim_num)) + dist = sqrt(sum((pn(1:dim_num) - qn(1:dim_num))**2)) + return + end if +! +! The nearest point did not occur in the interior. +! Therefore it must be achieved at an endpoint. +! + call segment_point_dist_3d(q1, q2, p1, dist2) + dist = dist2 + call segment_point_dist_3d(q1, q2, p2, dist2) + dist = min(dist, dist2) + call segment_point_dist_3d(p1, p2, q1, dist2) + dist = min(dist, dist2) + call segment_point_dist_3d(p1, p2, q2, dist2) + dist = min(dist, dist2) + + return +end +subroutine segments_dist_3d_old(p1, p2, q1, q2, dist) + +!*****************************************************************************80 +! +!! SEGMENTS_DIST_3D_OLD computes the distance between two line segments in 3D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the +! first segment. +! +! Input, real ( kind = 8 ) Q1(3), Q2(3), the endpoints of the +! second segment. +! +! Output, real ( kind = 8 ) DIST, the distance between the line segments. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) d1 + real(kind=8) d2 + real(kind=8) dist + real(kind=8) dl + real(kind=8) dm + real(kind=8) dr + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pm(dim_num) + real(kind=8) pn1(dim_num) + real(kind=8) pn2(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) t1 + real(kind=8) t2 + real(kind=8) tl + real(kind=8) tm + real(kind=8) tmin + real(kind=8) tr +! +! Find the nearest points on line 2 to the endpoints of line 1. +! + call segment_point_near_3d(q1, q2, p1, pn1, d1, t1) + call segment_point_near_3d(q1, q2, p2, pn2, d2, t2) + + if (t1 == t2) then + call segment_point_dist_3d(p1, p2, pn1, dist) + return + end if + + pm(1:dim_num) = 0.5D+00 * (pn1(1:dim_num) + pn2(1:dim_num)) +! +! On line 2, over the interval between the points nearest to line 1, +! the square of the distance of any point to line 1 is a quadratic function. +! Evaluate it at three points, and seek its local minimum. +! + call segment_point_dist_3d(p1, p2, pn1, dl) + call segment_point_dist_3d(p1, p2, pm, dm) + call segment_point_dist_3d(p1, p2, pn2, dr) + + tl = 0.0D+00 + tm = 0.5D+00 + tr = 1.0D+00 + + dl = dl * dl + dm = dm * dm + dr = dr * dr + + call minquad(tl, dl, tm, dm, tr, dr, tmin, dist) + + dist = sqrt(dist) + + return +end +subroutine segments_int_1d(p1, p2, q1, q2, dist, r1, r2) + +!*****************************************************************************80 +! +!! SEGMENTS_INT_1D computes the intersection of two line segments in 1D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! In 1D, two line segments "intersect" if they overlap. +! +! Using a real number DIST to report overlap is preferable to +! returning a TRUE/FALSE flag, since DIST is better able to +! handle cases where the segments "almost" interlap. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 July 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1, P2, the endpoints of the first segment. +! +! Input, real ( kind = 8 ) Q1, Q2, the endpoints of the second segment. +! +! Output, real ( kind = 8 ) DIST, the "distance" between the segments. +! < 0, the segments overlap, and the overlap is DIST units long; +! = 0, the segments overlap at a single point; +! > 0, the segments do not overlap. The distance between the nearest +! points is DIST units. +! +! Output, real ( kind = 8 ) R1, R2, the endpoints of the intersection +! segment. +! If DIST < 0, then the interval [R1,R2] is the common intersection +! of the two segments. +! If DIST = 0, then R1 = R2 is the single common point of the two segments. +! If DIST > 0, then (R1,R2) is an open interval separating the two +! segments, which do not overlap at all. +! + implicit none + + real(kind=8) dist + real(kind=8) p1 + real(kind=8) p2 + real(kind=8) q1 + real(kind=8) q2 + real(kind=8) r1 + real(kind=8) r2 + + r1 = max(min(p1, p2), & + min(q1, q2)) + + r2 = min(max(p1, p2), & + max(q1, q2)) + + dist = r1 - r2 + + return +end +subroutine segments_int_2d(p1, p2, q1, q2, flag, r) + +!*****************************************************************************80 +! +!! SEGMENTS_INT_2D computes the intersection of two line segments in 2D. +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! In 2D, two line segments might not intersect, even though the +! lines, of which they are portions, intersect. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the first +! segment. +! +! Input, real ( kind = 8 ) Q1(2), Q2(2), the endpoints of the second +! segment. +! +! Output, integer ( kind = 4 ) FLAG, records the results. +! 0, the line segments do not intersect. +! 1, the line segments intersect. +! +! Output, real ( kind = 8 ) R(2), an intersection point, if there is one. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + integer(kind=4) flag + integer(kind=4) ival + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) q1(dim_num) + real(kind=8) q2(dim_num) + real(kind=8) r(dim_num) + real(kind=8), parameter :: tol = 0.001D+00 + real(kind=8) u(dim_num) +! +! Find the intersection of the two lines. +! + r(1:dim_num) = (/0.0D+00, 0.0D+00/) + + call lines_exp_int_2d(p1, p2, q1, q2, ival, r) + + if (ival == 0) then + flag = 0 + return + end if +! +! Is the intersection point part of the first line segment? +! + call segment_contains_point_2d(p1, p2, r, u) + + if (u(1) < 0.0D+00 .or. 1.0D+00 < u(1) .or. tol < u(2)) then + flag = 0 + return + end if +! +! Is the intersection point part of the second line segment? +! + call segment_contains_point_2d(q1, q2, r, u) + + if (u(1) < 0.0D+00 .or. 1.0D+00 < u(1) .or. tol < u(2)) then + flag = 0 + return + end if + + flag = 1 + + return +end +subroutine shape_point_dist_2d(pc, p1, side_num, p, dist) + +!*****************************************************************************80 +! +!! SHAPE_POINT_DIST_2D: distance ( regular shape, point ) in 2D. +! +! Discussion: +! +! The "regular shape" is assumed to be an equilateral and equiangular +! polygon, such as the standard square, pentagon, hexagon, and so on. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(2), the center of the shape. +! +! Input, real ( kind = 8 ) P1(2), the first vertex of the shape. +! +! Input, integer ( kind = 4 ) SIDE_NUM, the number of sides. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the shape. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle + real(kind=8) angle_deg_2d + real(kind=8) angle2 + real(kind=8) degrees_to_radians + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) pa(dim_num) + real(kind=8) pb(dim_num) + real(kind=8) pc(dim_num) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radius + real(kind=8) sector_angle + integer(kind=4) sector_index + integer(kind=4) side_num +! +! Determine the angle subtended by a single side. +! + sector_angle = 360.0D+00 / real(side_num, kind=8) +! +! How long is the half-diagonal? +! + radius = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) +! +! If the radius is zero, then the shape is a point and the computation is easy. +! + if (radius == 0.0D+00) then + dist = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) + return + end if +! +! If the test point is at the pc, then the computation is easy. +! The angle subtended by any side is ( 2 * PI / SIDE_NUM ) and the +! nearest distance is the midpoint of any such side. +! + if (all(p(1:dim_num) == pc(1:dim_num))) then + dist = radius * cos(r8_pi / real(side_num, kind=8)) + return + end if +! +! Determine the angle between the ray to the first corner, +! and the ray to the test point. +! + angle = angle_deg_2d(p1(1:2), pc(1:2), p(1:2)) +! +! Determine the sector of the point. +! + sector_index = int(angle / sector_angle) + 1 +! +! Generate the two corner points that terminate the SECTOR-th side. +! + angle2 = real(sector_index - 1, kind=8) * sector_angle + angle2 = degrees_to_radians(angle2) + + call vector_rotate_base_2d(p1, pc, angle2, pa) + + angle2 = real(sector_index, kind=8) * sector_angle + angle2 = degrees_to_radians(angle2) + + call vector_rotate_base_2d(p1, pc, angle2, pb) +! +! Determine the distance from the test point to the line segment that +! is the SECTOR-th side. +! + call segment_point_dist_2d(pa, pb, p, dist) + + return +end +subroutine shape_point_near_2d(pc, p1, side_num, p, pn, dist) + +!*****************************************************************************80 +! +!! SHAPE_POINT_NEAR_2D: nearest point ( regular shape, point ) in 2D. +! +! Discussion: +! +! The "regular shape" is assumed to be an equilateral and equiangular +! polygon, such as the standard square, pentagon, hexagon, and so on. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(2), the center of the shape. +! +! Input, real ( kind = 8 ) P1(2), the first vertex of the shape. +! +! Input, integer ( kind = 4 ) SIDE_NUM, the number of sides. +! +! Input, real ( kind = 8 ) P(2), the point to be checked. +! +! Output, real ( kind = 8 ) PN(2), the point on the shape that is nearest +! to the given point. +! +! Output, real ( kind = 8 ) DIST, the distance between the points. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle + real(kind=8) angle_deg_2d + real(kind=8) angle2 + real(kind=8) degrees_to_radians + real(kind=8) dist + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) pa(dim_num) + real(kind=8) pb(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pd(dim_num) + real(kind=8) pn(dim_num) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) radius + real(kind=8) sector_angle + integer(kind=4) sector_index + integer(kind=4) side_num + real(kind=8) t +! +! Determine the angle subtended by a single side. +! + sector_angle = 360.0D+00 / real(side_num, kind=8) +! +! How long is the half-diagonal? +! + radius = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) +! +! If the radius is zero, then the shape is a point and the computation is easy. +! + if (radius == 0.0D+00) then + pn(1:dim_num) = pc(1:dim_num) + dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) + return + end if +! +! If the test point is at the pc, then the computation is easy. +! The angle subtended by any side is ( 2 * PI / SIDE_NUM ) and the +! nearest distance is the midpoint of any such side. +! + if (all(p(1:dim_num) == pc(1:dim_num))) then + angle = r8_pi / real(side_num, kind=8) + pd(1) = (p(1) - pc(1)) * cos(angle) & + + (p(2) - pc(2)) * sin(angle) + pd(2) = -(p(1) - pc(1)) * sin(angle) & + + (p(2) - pc(2)) * cos(angle) + pn(1) = pc(1) + pd(1) * cos(angle) + pn(2) = pc(2) + pd(2) * sin(angle) + dist = radius * cos(angle) + return + end if +! +! Determine the angle between the ray to the first corner, +! and the ray to the test point. +! + angle = angle_deg_2d(p1(1:2), pc(1:2), p(1:2)) +! +! Determine the sector of the point. +! + sector_index = int(angle / sector_angle) + 1 +! +! Generate the two corner points that terminate the SECTOR-th side. +! + angle2 = real(sector_index - 1, kind=8) * sector_angle + angle2 = degrees_to_radians(angle2) + + call vector_rotate_base_2d(p1, pc, angle2, pa) + + angle2 = real(sector_index, kind=8) * sector_angle + angle2 = degrees_to_radians(angle2) + + call vector_rotate_base_2d(p1, pc, angle2, pb) +! +! Determine the point on the SECTOR-th side of the shape which is +! nearest. +! + call segment_point_near_2d(pa, pb, p, pn, dist, t) + + return +end +subroutine shape_print_3d(point_num, face_num, face_order_max, & + point_coord, face_order, face_point) + +!*****************************************************************************80 +! +!! SHAPE_PRINT_3D prints information about a polyhedron in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 January 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the number of vertices +! per face. +! +! Input, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. +! +! Input, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices +! per face. +! +! Input, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. +! The points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) point_num + + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + integer(kind=4) i + real(kind=8) point_coord(dim_num, point_num) + + write (*, '(a)') ' ' + write (*, '(a)') 'SHAPE_PRINT_3D' + write (*, '(a)') ' Information about a polytope.' + write (*, '(a)') ' ' + write (*, '(a,i8)') ' The number of vertices is ', point_num + write (*, '(a)') ' ' + write (*, '(a)') ' Vertices:' + write (*, '(a)') ' ' + write (*, '(a)') ' Index X Y Z' + write (*, '(a)') ' ' + + do i = 1, point_num + write (*, '(2x,i8,2x,3f16.8)') i, point_coord(1:dim_num, i) + end do + + write (*, '(a)') ' ' + write (*, '(a,i8)') ' The number of faces is ', face_num + write (*, '(a,i8)') ' The maximum order of any face is ', face_order_max + write (*, '(a)') ' ' + write (*, '(a)') ' Index Order Indices of Nodes in Face' + write (*, '(22x,10i8)') (i, i=1, face_order_max) + write (*, '(a)') ' ' + + do i = 1, face_num + write (*, '(2x,i8,2x,i8,2x,10i8)') i, face_order(i), & + face_point(1:face_order(i), i) + end do + + return +end +subroutine shape_ray_int_2d(pc, p1, side_num, pa, pb, pint) + +!*****************************************************************************80 +! +!! SHAPE_RAY_INT_2D: intersection ( regular shape, ray ) in 2D. +! +! Discussion: +! +! The "regular shape" is assumed to be an equilateral and equiangular +! polygon, such as the standard square, pentagon, hexagon, and so on. +! +! The origin of the ray is assumed to be inside the shape. This +! guarantees that the ray will intersect the shape in exactly one point. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(2), the center of the shape. +! +! Input, real ( kind = 8 ) P1(2), the first vertex of the shape. +! +! Input, integer ( kind = 4 ) SIDE_NUM, the number of sides. +! +! Input, real ( kind = 8 ) PA(2), the origin of the ray. +! +! Input, real ( kind = 8 ) PB(2), a second point on the ray. +! +! Output, real ( kind = 8 ) PINT(2), the point on the shape intersected +! by the ray. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle2 + real(kind=8) degrees_to_radians + logical(kind=4) inside + integer(kind=4) ival + real(kind=8) p1(dim_num) + real(kind=8) pa(dim_num) + real(kind=8) pb(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pint(dim_num) + real(kind=8) radius + real(kind=8) sector_angle + integer(kind=4) sector_index + integer(kind=4) side_num + real(kind=8) v1(dim_num) + real(kind=8) v2(dim_num) +! +! Warning! +! No check is made to ensure that the ray origin is inside the shape. +! These calculations are not valid if that is not true! +! +! Determine the angle subtended by a single side. +! + sector_angle = 360.0D+00 / real(side_num, kind=8) +! +! How long is the half-diagonal? +! + radius = sqrt(sum((p1(1:dim_num) - pc(1:dim_num))**2)) +! +! If the radius is zero, refuse to continue. +! + if (radius == 0.0D+00) then + write (*, '(a)') ' ' + write (*, '(a)') 'SHAPE_RAY_INT_2D - Fatal error!' + write (*, '(a)') ' The shape has radius zero.' + stop 1 + end if +! +! Determine which sector side intersects the ray. +! + v2(1:dim_num) = (/0.0D+00, 0.0D+00/) + + do sector_index = 1, side_num +! +! Determine the two vertices that define this sector. +! + if (sector_index == 1) then + + angle2 = real(sector_index - 1, kind=8) * sector_angle + angle2 = degrees_to_radians(angle2) + + call vector_rotate_base_2d(p1, pc, angle2, v1) + + else + + v1(1:dim_num) = v2(1:dim_num) + + end if + + angle2 = real(sector_index, kind=8) * sector_angle + angle2 = degrees_to_radians(angle2) + + call vector_rotate_base_2d(p1, pc, angle2, v2) +! +! Draw the angle from one vertex to the ray origin to the next vertex, +! and see if that angle contains the ray. If so, then the ray +! must intersect the shape side of that sector. +! + call angle_contains_point_2d(v1, pa, v2, pb, inside) +! +! Determine the intersection of the lines defined by the ray and the +! sector side. (We're already convinced that the ray and sector line +! segment intersect, so we can use the simpler code that treats them +! as full lines). +! + if (inside) then + + call lines_exp_int_2d(pa, pb, v1, v2, ival, pint) + + return + + end if + + end do +! +! If the calculation fell through the loop, then something's wrong. +! + write (*, '(a)') ' ' + write (*, '(a)') 'SHAPE_RAY_INT_2D - Fatal error!' + write (*, '(a)') ' Cannot find intersection of ray and shape.' + stop 1 +end +subroutine simplex_lattice_layer_point_next(n, c, v, more) + +!*****************************************************************************80 +! +!! SIMPLEX_LATTICE_LAYER_POINT_NEXT: next simplex lattice layer point. +! +! Discussion: +! +! The simplex lattice layer L is bounded by the lines +! +! 0 <= X(1:N), +! L - 1 < sum X(1:N) / C(1:N) <= L. +! +! In particular, layer L = 0 always contains just the origin. +! +! This function returns, one at a time, the points that lie within +! a given simplex lattice layer. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the spatial dimension. +! +! Input, integer ( kind = 4 ) C(N+1), coefficients defining the +! lattice layer in entries 1 to N, and the laver index in C(N+1). +! The coefficients should be positive, and C(N+1) must be nonnegative. +! +! Input/output, integer ( kind = 4 ) V(N). On first call for a given layer, +! the input value of V is not important. On a repeated call for the same +! layer, the input value of V should be the output value from the previous +! call. On output, V contains the next lattice layer point. +! +! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE +! to indicate that this is the first call for a given layer. Thereafter, +! the input value should be the output value from the previous call. On +! output, MORE is TRUE if the returned value V is a new point. +! If the output value is FALSE, then no more points were found, +! and V was reset to 0, and the lattice layer has been exhausted. +! + implicit none + + integer(kind=4) n + + integer(kind=4) c(n + 1) + integer(kind=4) c1n + integer(kind=4) i + integer(kind=4) i4vec_lcm + integer(kind=4) j + integer(kind=4) lhs + logical(kind=4) more + integer(kind=4) rhs1 + integer(kind=4) rhs2 + integer(kind=4) v(n) +! +! Treat layer C(N+1) = 0 specially. +! + if (c(n + 1) == 0) then + if (.not. more) then + v(1:n) = 0 + more = .true. + else + more = .false. + end if + return + end if +! +! Compute the first point. +! + if (.not. more) then + + v(1) = (c(n + 1) - 1) * c(1) + 1 + v(2:n) = 0 + more = .true. + + else + + c1n = i4vec_lcm(n, c) + + rhs1 = c1n * (c(n + 1) - 1) + rhs2 = c1n * c(n + 1) +! +! Try to increment component I. +! + do i = 1, n + + v(i) = v(i) + 1 + + v(1:i - 1) = 0 + + if (1 < i) then + v(1) = rhs1 + do j = 2, n + v(1) = v(1) - (c1n / c(j)) * v(j) + end do + v(1) = (c(1) * v(1)) / c1n + v(1) = max(v(1), 0) + end if + + lhs = 0 + do j = 1, n + lhs = lhs + (c1n / c(j)) * v(j) + end do + + if (lhs <= rhs1) then + v(1) = v(1) + 1 + lhs = lhs + c1n / c(1) + end if + + if (lhs <= rhs2) then + return + end if + + end do + + v(1:n) = 0 + more = .false. + + end if + + return +end +subroutine simplex_lattice_point_next(n, c, v, more) + +!*****************************************************************************80 +! +!! SIMPLEX_LATTICE_POINT_NEXT returns the next simplex lattice point. +! +! Discussion: +! +! The lattice simplex is defined by the vertices: +! +! (0,0,...,0), (C(N+1)/C(1),0,...,0), (0,C(N+1)/C(2),...,0) ... +! (0,0,...C(N+1)/C(N)) +! +! The lattice simplex is bounded by the lines +! +! 0 <= V(1:N), +! V(1) / C(1) + V(2) / C(2) + ... + V(N) / C(N) <= C(N+1) +! +! Lattice points are listed one at a time, starting at the origin, +! with V(1) increasing first. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the spatial dimension. +! +! Input, integer ( kind = 4 ) C(N+1), coefficients defining the +! lattice simplex. These should be positive. +! +! Input/output, integer ( kind = 4 ) V(N). On first call, the input +! value is not important. On a repeated call, the input value should +! be the output value from the previous call. On output, V contains +! the next lattice point. +! +! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to +! indicate that this is the first call for a given simplex. Thereafter, +! the input value should be the output value from the previous call. On +! output, MORE is TRUE if not only is the returned value V a lattice point, +! but the routine can be called again for another lattice point. +! If the output value is FALSE, then no more lattice points were found, +! and V was reset to 0, and the routine should not be called further +! for this simplex. +! + implicit none + + integer(kind=4) n + + integer(kind=4) c(n + 1) + integer(kind=4) c1n + integer(kind=4) i + integer(kind=4) i4vec_lcm + integer(kind=4) j + integer(kind=4) lhs + logical(kind=4) more + integer(kind=4) rhs + integer(kind=4) term + integer(kind=4) v(n) + + if (.not. more) then + + v(1:n) = 0 + more = .true. + + else + + c1n = i4vec_lcm(n, c) + rhs = c1n * c(n + 1) + + lhs = 0 + do i = 1, n + term = 1 + do j = 1, n + if (i == j) then + term = term * v(j) + else + term = term * c(j) + end if + end do + lhs = lhs + term + end do + + do i = 1, n + if (lhs + c1n / c(i) <= rhs) then + v(i) = v(i) + 1 + more = .true. + return + end if + lhs = lhs - c1n * v(i) / c(i) + v(i) = 0 + end do + + more = .false. + + end if + + return +end +subroutine simplex01_lattice_point_num_nd(d, s, n) + +!*****************************************************************************80 +! +!! SIMPLEX01_LATTICE_POINT_NUM_ND: count lattice points. +! +! Discussion: +! +! The simplex is assumed to be the unit D-dimensional simplex: +! +! ( (0,0,...,0), (1,0,...,0), (0,1,...,0), ... (0,,0,...,1) ) +! +! or a copy of this simplex scaled by an integer S: +! +! ( (0,0,...,0), (S,0,...,0), (0,S,...,0), ... (0,,0,...,S) ) +! +! The routine returns the number of integer lattice points that appear +! inside the simplex or on its boundary. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 July 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Matthias Beck, Sinai Robins, +! Computing the Continuous Discretely, +! Springer, 2006, +! ISBN13: 978-0387291390, +! LC: QA640.7.B43. +! +! Parameters: +! +! Input, integer ( kind = 4 ) D, the spatial dimension. +! +! Input, integer ( kind = 4 ) S, the scale factor. +! +! Output, integer ( kind = 4 ) N, the number of lattice points. +! + implicit none + + integer(kind=4) d + integer(kind=4) i + integer(kind=4) n + integer(kind=4) s + + n = 1 + do i = 1, d + n = (n * (s + i)) / i + end do + + return +end +subroutine simplex01_volume_nd(dim_num, volume) + +!*****************************************************************************80 +! +!! SIMPLEX01_VOLUME_ND computes the volume of the unit simplex in ND. +! +! Discussion: +! +! The formula is simple: volume = 1/N!. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 March 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Output, real ( kind = 8 ) VOLUME, the volume. +! + implicit none + + integer(kind=4) i + integer(kind=4) dim_num + real(kind=8) volume + + volume = 1.0D+00 + do i = 1, dim_num + volume = volume / real(i, kind=8) + end do + + return +end +subroutine simplex_volume_nd(dim_num, a, volume) + +!*****************************************************************************80 +! +!! SIMPLEX_VOLUME_ND computes the volume of a simplex in ND. +! +! Discussion: +! +! The formula is: +! +! volume = 1/N! * det ( A ) +! +! where A is the N by N matrix obtained by subtracting one +! vector from all the others. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 March 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. +! +! Input, real ( kind = 8 ) A(DIM_NUM,DIM_NUM+1), the vertices. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the simplex. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) a(dim_num, dim_num + 1) + real(kind=8) b(dim_num, dim_num) + real(kind=8) det + integer(kind=4) i + integer(kind=4) info + integer(kind=4) j + integer(kind=4) pivot(dim_num) + real(kind=8) volume + + b(1:dim_num, 1:dim_num) = a(1:dim_num, 1:dim_num) + do j = 1, dim_num + b(1:dim_num, j) = b(1:dim_num, j) - a(1:dim_num, dim_num + 1) + end do + + call r8ge_fa(dim_num, b, pivot, info) + + if (info /= 0) then + + volume = -1.0D+00 + + else + + call r8ge_det(dim_num, b, pivot, det) + + volume = abs(det) + do i = 1, dim_num + volume = volume / real(i, kind=8) + end do + + end if + + return +end +function sin_power_int(a, b, n) + +!*****************************************************************************80 +! +!! SIN_POWER_INT evaluates the sine power integral. +! +! Discussion: +! +! The function is defined by +! +! SIN_POWER_INT(A,B,N) = Integral ( A <= T <= B ) ( sin ( t ))^n dt +! +! The algorithm uses the following fact: +! +! Integral sin^n ( t ) = (1/n) * ( +! sin^(n-1)(t) * cos(t) + ( n-1 ) * Integral sin^(n-2) ( t ) dt ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 September 2004 +! +! Author: +! +! John Burkardt +! +! Parameters +! +! Input, real ( kind = 8 ) A, B, the limits of integration. +! +! Input, integer ( kind = 4 ) N, the power of the sine function. +! +! Output, real ( kind = 8 ) SIN_POWER_INT, the value of the integral. +! + implicit none + + real(kind=8) a + real(kind=8) b + real(kind=8) ca + real(kind=8) cb + integer(kind=4) m + integer(kind=4) mlo + integer(kind=4) n + real(kind=8) sa + real(kind=8) sb + real(kind=8) sin_power_int + real(kind=8) value + + if (n < 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'SIN_POWER_INT - Fatal error!' + write (*, '(a)') ' Power N < 0.' + value = 0.0D+00 + stop 1 + end if + + sa = sin(a) + sb = sin(b) + ca = cos(a) + cb = cos(b) + + if (mod(n, 2) == 0) then + + value = b - a + mlo = 2 + else + value = ca - cb + mlo = 3 + end if + + do m = mlo, n, 2 + value = (real(m - 1, kind=8) * value & + + sa**(m - 1) * ca - sb**(m - 1) * cb) & + / real(m, kind=8) + end do + + sin_power_int = value + + return +end +subroutine soccer_shape_3d(point_num, face_num, face_order_max, point_coord, & + face_order, face_point) + +!*****************************************************************************80 +! +!! SOCCER_SHAPE_3D describes a truncated icosahedron in 3D. +! +! Discussion: +! +! The shape is a truncated icosahedron, which is the design used +! on a soccer ball. There are 12 pentagons and 20 hexagons. +! +! Call SOCCER_SIZE_3D to get the values of POINT_NUM, FACE_NUM, and +! FACE_ORDER_MAX, so you can allocate space for the arrays. +! +! For each face, the face list must be of length FACE_ORDER_MAX. +! In cases where a face is of lower than maximum order (the +! 12 pentagons, in this case), the extra entries are listed as +! "-1". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 August 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! http://mathworld.wolfram.com/TruncatedIcosahedron.html +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points (60). +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces (32). +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any +! face (6). +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. +! +! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of +! vertices per face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. +! The points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) point_num + + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) point_coord(dim_num, point_num) +! +! Set the point coordinates. +! + point_coord(1:dim_num, 1:point_num) = reshape((/ & + -0.100714D+01, 0.153552D+00, 0.067258D+00, & + -0.960284D+00, 0.0848813D+00, -0.336290D+00, & + -0.951720D+00, -0.153552D+00, 0.336290D+00, & + -0.860021D+00, 0.529326D+00, 0.150394D+00, & + -0.858000D+00, -0.290893D+00, -0.470806D+00, & + -0.849436D+00, -0.529326D+00, 0.201774D+00, & + -0.802576D+00, -0.597996D+00, -0.201774D+00, & + -0.784200D+00, 0.418215D+00, -0.502561D+00, & + -0.749174D+00, -0.0848813D+00, 0.688458D+00, & + -0.722234D+00, 0.692896D+00, -0.201774D+00, & + -0.657475D+00, 0.597996D+00, 0.502561D+00, & + -0.602051D+00, 0.290893D+00, 0.771593D+00, & + -0.583675D+00, -0.692896D+00, 0.470806D+00, & + -0.579632D+00, -0.333333D+00, -0.771593D+00, & + -0.521710D+00, -0.418215D+00, 0.771593D+00, & + -0.505832D+00, 0.375774D+00, -0.803348D+00, & + -0.489955D+00, -0.830237D+00, -0.336290D+00, & + -0.403548D+00, 0.000000D+00, -0.937864D+00, & + -0.381901D+00, 0.925138D+00, -0.201774D+00, & + -0.352168D+00, -0.666667D+00, -0.688458D+00, & + -0.317142D+00, 0.830237D+00, 0.502561D+00, & + -0.271054D+00, -0.925138D+00, 0.336290D+00, & + -0.227464D+00, 0.333333D+00, 0.937864D+00, & + -0.224193D+00, -0.993808D+00, -0.067258D+00, & + -0.179355D+00, 0.993808D+00, 0.150394D+00, & + -0.165499D+00, 0.608015D+00, -0.803348D+00, & + -0.147123D+00, -0.375774D+00, 0.937864D+00, & + -0.103533D+00, 0.882697D+00, -0.502561D+00, & + -0.513806D-01, 0.666667D+00, 0.771593D+00, & + 0.000000D+00, 0.000000D+00, 1.021000D+00, & + 0.000000D+00, 0.000000D+00, -1.021000D+00, & + 0.513806D-01, -0.666667D+00, -0.771593D+00, & + 0.103533D+00, -0.882697D+00, 0.502561D+00, & + 0.147123D+00, 0.375774D+00, -0.937864D+00, & + 0.165499D+00, -0.608015D+00, 0.803348D+00, & + 0.179355D+00, -0.993808D+00, -0.150394D+00, & + 0.224193D+00, 0.993808D+00, 0.067258D+00, & + 0.227464D+00, -0.333333D+00, -0.937864D+00, & + 0.271054D+00, 0.925138D+00, -0.336290D+00, & + 0.317142D+00, -0.830237D+00, -0.502561D+00, & + 0.352168D+00, 0.666667D+00, 0.688458D+00, & + 0.381901D+00, -0.925138D+00, 0.201774D+00, & + 0.403548D+00, 0.000000D+00, 0.937864D+00, & + 0.489955D+00, 0.830237D+00, 0.336290D+00, & + 0.505832D+00, -0.375774D+00, 0.803348D+00, & + 0.521710D+00, 0.418215D+00, -0.771593D+00, & + 0.579632D+00, 0.333333D+00, 0.771593D+00, & + 0.583675D+00, 0.692896D+00, -0.470806D+00, & + 0.602051D+00, -0.290893D+00, -0.771593D+00, & + 0.657475D+00, -0.597996D+00, -0.502561D+00, & + 0.722234D+00, -0.692896D+00, 0.201774D+00, & + 0.749174D+00, 0.0848813D+00, -0.688458D+00, & + 0.784200D+00, -0.418215D+00, 0.502561D+00, & + 0.802576D+00, 0.597996D+00, 0.201774D+00, & + 0.849436D+00, 0.529326D+00, -0.201774D+00, & + 0.858000D+00, 0.290893D+00, 0.470806D+00, & + 0.860021D+00, -0.529326D+00, -0.150394D+00, & + 0.951720D+00, 0.153552D+00, -0.336290D+00, & + 0.960284D+00, -0.0848813D+00, 0.336290D+00, & + 1.007140D+00, -0.153552D+00, -0.067258D+00/), & + (/dim_num, point_num/)) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 6, 6, 5, 6, 5, 6, 5, 6, 6, 6, & + 5, 6, 5, 6, 5, 6, 6, 6, 5, 6, & + 5, 5, 6, 6, 6, 5, 6, 5, 6, 6, & + 5, 6/) +! +! Set faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 30, 43, 47, 41, 29, 23, & + 30, 23, 12, 9, 15, 27, & + 30, 27, 35, 45, 43, -1, & + 43, 45, 53, 59, 56, 47, & + 23, 29, 21, 11, 12, -1, & + 27, 15, 13, 22, 33, 35, & + 47, 56, 54, 44, 41, -1, & + 45, 35, 33, 42, 51, 53, & + 12, 11, 4, 1, 3, 9, & + 29, 41, 44, 37, 25, 21, & + 15, 9, 3, 6, 13, -1, & + 56, 59, 60, 58, 55, 54, & + 53, 51, 57, 60, 59, -1, & + 11, 21, 25, 19, 10, 4, & + 33, 22, 24, 36, 42, -1, & + 13, 6, 7, 17, 24, 22, & + 54, 55, 48, 39, 37, 44, & + 51, 42, 36, 40, 50, 57, & + 4, 10, 8, 2, 1, -1, & + 3, 1, 2, 5, 7, 6, & + 25, 37, 39, 28, 19, -1, & + 55, 58, 52, 46, 48, -1, & + 60, 57, 50, 49, 52, 58, & + 10, 19, 28, 26, 16, 8, & + 36, 24, 17, 20, 32, 40, & + 7, 5, 14, 20, 17, -1, & + 48, 46, 34, 26, 28, 39, & + 50, 40, 32, 38, 49, -1, & + 8, 16, 18, 14, 5, 2, & + 46, 52, 49, 38, 31, 34, & + 16, 26, 34, 31, 18, -1, & + 32, 20, 14, 18, 31, 38/), (/face_order_max, face_num/)) + + return +end +subroutine soccer_size_3d(point_num, edge_num, face_num, face_order_max) + +!*****************************************************************************80 +! +!! SOCCER_SIZE_3D gives "sizes" for a truncated icosahedron in 3D. +! +! Discussion: +! +! The shape is a truncated icosahedron, which is the design used +! on a soccer ball. There are 12 pentagons and 20 hexagons. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2007 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! http://mathworld.wolfram.com/TruncatedIcosahedron.html +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 60 + edge_num = 90 + face_num = 32 + face_order_max = 6 + + return +end +subroutine sort_heap_external(n, indx, i, j, isgn) + +!*****************************************************************************80 +! +!! SORT_HEAP_EXTERNAL externally sorts a list of items into ascending order. +! +! Discussion: +! +! The actual list of data is not passed to the routine. Hence this +! routine may be used to sort integers, real ( kind = 8 )s, numbers, names, +! dates, shoe sizes, and so on. After each call, the routine asks +! the user to compare or interchange two items, until a special +! return value signals that the sorting is completed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 February 2004 +! +! Author: +! +! Original FORTRAN77 version by Albert Nijenhuis and Herbert Wilf +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Albert Nijenhuis, Herbert Wilf, +! Combinatorial Algorithms, +! Academic Press, 1978, second edition, +! ISBN 0-12-519260-6. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of items to be sorted. +! +! Input/output, integer ( kind = 4 ) INDX, the main communication signal. +! +! The user must set INDX to 0 before the first call. +! Thereafter, the user should not change the value of INDX until +! the sorting is done. +! +! On return, if INDX is +! +! greater than 0, +! * interchange items I and J; +! * call again. +! +! less than 0, +! * compare items I and J; +! * set ISGN = -1 if I < J, ISGN = +1 if J < I; +! * call again. +! +! equal to 0, the sorting is done. +! +! Output, integer ( kind = 4 ) I, J, the indices of two items. +! On return with INDX positive, elements I and J should be interchanged. +! On return with INDX negative, elements I and J should be compared, and +! the result reported in ISGN on the next call. +! +! Input, integer ( kind = 4 ) ISGN, results of comparison of elements I +! and J. (Used only when the previous call returned INDX less than 0). +! ISGN <= 0 means I is less than or equal to J; +! 0 <= ISGN means I is greater than or equal to J. +! + implicit none + + integer(kind=4) i + integer(kind=4), save :: i_save = 0 + integer(kind=4) indx + integer(kind=4) isgn + integer(kind=4) j + integer(kind=4), save :: j_save = 0 + integer(kind=4), save :: k = 0 + integer(kind=4), save :: k1 = 0 + integer(kind=4) n + integer(kind=4), save :: n1 = 0 +! +! INDX = 0: This is the first call. +! + if (indx == 0) then + + i_save = 0 + j_save = 0 + k = n / 2 + k1 = k + n1 = n +! +! INDX < 0: The user is returning the results of a comparison. +! + else if (indx < 0) then + + if (indx == -2) then + + if (isgn < 0) then + i_save = i_save + 1 + end if + + j_save = k1 + k1 = i_save + indx = -1 + i = i_save + j = j_save + return + + end if + + if (0 < isgn) then + indx = 2 + i = i_save + j = j_save + return + end if + + if (k <= 1) then + + if (n1 == 1) then + i_save = 0 + j_save = 0 + indx = 0 + else + i_save = n1 + n1 = n1 - 1 + j_save = 1 + indx = 1 + end if + + i = i_save + j = j_save + return + + end if + + k = k - 1 + k1 = k +! +! 0 < INDX, the user was asked to make an interchange. +! + else if (indx == 1) then + + k1 = k + + end if + + do + + i_save = 2 * k1 + + if (i_save == n1) then + j_save = k1 + k1 = i_save + indx = -1 + i = i_save + j = j_save + return + else if (i_save <= n1) then + j_save = i_save + 1 + indx = -2 + i = i_save + j = j_save + return + end if + + if (k <= 1) then + exit + end if + + k = k - 1 + k1 = k + + end do + + if (n1 == 1) then + i_save = 0 + j_save = 0 + indx = 0 + i = i_save + j = j_save + else + i_save = n1 + n1 = n1 - 1 + j_save = 1 + indx = 1 + i = i_save + j = j_save + end if + + return +end +subroutine sphere_cap_area_2d(r, h, area) + +!*****************************************************************************80 +! +!! SPHERE_CAP_AREA_2D computes the surface area of a spherical cap in 2D. +! +! Discussion: +! +! Draw any radius of the sphere and note the point P where the radius +! intersects the sphere. Consider the point on the radius line which is +! H units from P. Draw the circle that lies in the plane perpendicular to +! the radius, and which intersects the sphere. The circle divides the sphere +! into two pieces, and the corresponding disk divides the solid sphere into +! two pieces. The spherical cap is the part of the solid sphere that +! includes the point P. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H, the "height" of the spherical cap. +! H must be between 0 and 2 * R. +! +! Output, real ( kind = 8 ) AREA, the area of the spherical cap. +! + implicit none + + real(kind=8) area + real(kind=8) h + real(kind=8) r + real(kind=8) r8_asin + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + + if (h <= 0.0D+00) then + area = 0.0D+00 + else if (2.0D+00 * r <= h) then + area = 2.0D+00 * r8_pi * r + else + + theta = 2.0D+00 * r8_asin(sqrt(r * r - (r - h)**2) / r) + area = r * theta + + if (r <= h) then + area = 2.0D+00 * r8_pi * r - area + end if + + end if + + return +end +subroutine sphere_cap_area_3d(r, h, area) + +!*****************************************************************************80 +! +!! SPHERE_CAP_AREA_3D computes the surface area of a spherical cap in 3D. +! +! Discussion: +! +! Draw any radius of the sphere and note the point P where the radius +! intersects the sphere. Consider the point on the radius line which is +! H units from P. Draw the circle that lies in the plane perpendicular to +! the radius, and which intersects the sphere. The circle divides the sphere +! into two pieces, and the corresponding disk divides the solid sphere into +! two pieces. The spherical cap is the part of the solid sphere that +! includes the point P. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H, the "height" of the spherical cap. +! H must be between 0 and 2 * R. +! +! Output, real ( kind = 8 ) AREA, the area of the spherical cap. +! + implicit none + + real(kind=8) area + real(kind=8) h + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + if (h <= 0.0D+00) then + area = 0.0D+00 + else if (2.0D+00 * r <= h) then + area = 4.0D+00 * r8_pi * r * r + else + area = 2.0D+00 * r8_pi * r * h + end if + + return +end +subroutine sphere_cap_area_nd(dim_num, r, h, area) + +!*****************************************************************************80 +! +!! SPHERE_CAP_AREA_ND computes the area of a spherical cap in ND. +! +! Discussion: +! +! The spherical cap is a portion of the surface of the sphere: +! +! sum ( X(1:N)^2 ) = R^2 +! +! which is no more than H units from the uppermost point on the sphere. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 June 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Thomas Ericson, Victor Zinoviev, +! Codes on Euclidean Spheres, +! Elsevier, 2001, pages 439-441. +! QA166.7 E75 +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H, the "thickness" of the spherical cap, +! which is normally between 0 and 2 * R. +! +! Output, real ( kind = 8 ) AREA, the area of the spherical cap. +! + implicit none + + real(kind=8) area + real(kind=8) area2 + real(kind=8) h + real(kind=8) haver_sine + integer(kind=4) i + integer(kind=4) dim_num + real(kind=8) r + real(kind=8) r8_asin + real(kind=8) sphere_k + real(kind=8) theta + real(kind=8) ti + real(kind=8) tj + real(kind=8) tk + + if (h <= 0.0D+00) then + area = 0.0D+00 + return + end if + + if (2.0D+00 * r <= h) then + call sphere_imp_area_nd(dim_num, r, area) + return + end if +! +! For cases where R < H < 2 * R, work with the complementary region. +! + haver_sine = sqrt((2.0D+00 * r - h) * h) + + theta = r8_asin(haver_sine / r) + + if (dim_num < 1) then + + area = -1.0D+00 + return + + else if (dim_num == 1) then + + area = 0.0D+00 + + else if (dim_num == 2) then + + area = 2.0D+00 * theta * r + + else + + ti = theta + + tj = ti + ti = 1.0D+00 - cos(theta) + + do i = 2, dim_num - 2 + tk = tj + tj = ti + ti = (real(i - 1, kind=8) * tk & + - cos(theta) * sin(theta)**(i - 1)) & + / real(i, kind=8) + end do + + area = sphere_k(dim_num - 1) * ti * r**(dim_num - 1) + + end if +! +! Adjust for cases where R < H < 2R. +! + if (r < h) then + call sphere_imp_area_nd(dim_num, r, area2) + area = area2 - area + end if + + return +end +subroutine sphere_cap_volume_2d(r, h, volume) + +!*****************************************************************************80 +! +!! SPHERE_CAP_VOLUME_2D computes the volume of a spherical cap in 2D. +! +! Discussion: +! +! Draw any radius R of the circle and denote as P the point where the +! radius intersects the circle. Now consider the point Q which lies +! on the radius and which is H units from P. The line which is +! perpendicular to the radius R and passes through Q divides the +! circle into two pieces. The piece including the point P is the +! spherical (circular) cap of height (or thickness) H. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H, the "height" of the spherical cap. H must +! be between 0 and 2 * R. +! +! Output, real ( kind = 8 ) VOLUME, the volume (area) of the spherical cap. +! + implicit none + + real(kind=8) h + real(kind=8) r + real(kind=8) r8_asin + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + real(kind=8) volume + + if (h <= 0.0D+00) then + + volume = 0.0D+00 + + else if (2.0D+00 * r <= h) then + + volume = r8_pi * r * r + + else + + theta = 2.0D+00 * r8_asin(sqrt(r * r - (r - h)**2) / r) + volume = r * r * (theta - sin(theta)) / 2.0D+00 + + if (r < h) then + volume = r8_pi * r * r - volume + end if + + end if + + return +end +subroutine sphere_cap_volume_3d(r, h, volume) + +!*****************************************************************************80 +! +!! SPHERE_CAP_VOLUME_3D computes the volume of a spherical cap in 3D. +! +! Discussion: +! +! Draw any radius of the sphere and note the point P where the radius +! intersects the sphere. Consider the point on the radius line which is +! H units from P. Draw the circle that lies in the plane perpendicular to +! the radius, and which intersects the sphere. The circle divides the sphere +! into two pieces, and the corresponding disk divides the solid sphere into +! two pieces. The part of the solid sphere that includes the point P +! is the spherical cap of height (or thickness) H. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H, the "height" of the spherical cap. H must +! be between 0 and 2 * R. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the spherical cap. +! + implicit none + + real(kind=8) h + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) volume + + if (h <= 0.0D+00) then + volume = 0.0D+00 + else if (2.0D+00 * r <= h) then + volume = (4.0D+00 / 3.0D+00) * r8_pi * r * r * r + else + volume = (1.0D+00 / 3.0D+00) * r8_pi * h * h * (3.0D+00 * r - h) + end if + + return +end +subroutine sphere_cap_volume_nd(dim_num, r, h, volume) + +!*****************************************************************************80 +! +!! SPHERE_CAP_VOLUME_ND computes the volume of a spherical cap in ND. +! +! Discussion: +! +! The spherical cap is a portion of the surface and interior of the sphere: +! +! sum ( X(1:N)^2 ) <= R^2 +! +! which is no more than H units from some point P on the sphere. +! +! +! The algorithm proceeds from the observation that the N-dimensional +! sphere can be parameterized by a quantity RC that runs along the +! radius from the center to the point P. The value of RC at the +! base of the spherical cap is (R-H) and at P it is R. We intend to +! use RC as our integration parameeter. +! +! The volume of the spherical cap is then the integral, as RC goes +! from (R-H) to R, of the N-1 dimensional volume of the sphere +! of radius RS, where RC^2 + RS^2 = R^2. +! +! The volume of the N-1 dimensional sphere of radius RS is simply +! some constants times RS^(N-1). +! +! After factoring out the constant terms, and writing RC = R * cos ( T ), +! and RS = R * sin ( T ), and letting +! T_MAX = arc_sine ( sqrt ( ( 2.0D+00 * r - h ) * h / r ) ), +! the "interesting part" of our integral becomes +! +! constants * R^N * Integral ( T = 0 to T_MAX ) sin^N ( T ) dT +! +! The integral of sin^N ( T ) dT can be handled by recursion. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H, the "thickness" of the spherical cap, +! which is normally between 0 and 2 * R. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the spherical cap. +! + implicit none + + real(kind=8) angle + real(kind=8) factor1 + real(kind=8) factor2 + real(kind=8) h + integer(kind=4) dim_num + real(kind=8) r + real(kind=8) r8_asin + real(kind=8) sin_power_int + real(kind=8) sphere01_volume_nd + real(kind=8) volume + real(kind=8) volume2 + + if (h <= 0.0D+00) then + volume = 0.0D+00 + return + end if + + if (2.0D+00 * r <= h) then + call sphere_imp_volume_nd(dim_num, r, volume) + return + end if + + if (dim_num < 1) then + + volume = -1.0D+00 + + else if (dim_num == 1) then + + volume = h + + else + + factor1 = sphere01_volume_nd(dim_num - 1) + + angle = r8_asin(sqrt((2.0D+00 * r - h) * h / r)) + + factor2 = sin_power_int(0.0D+00, angle, dim_num) + + volume = factor1 * factor2 * r**dim_num + + if (r < h) then + call sphere_imp_volume_nd(dim_num, r, volume2) + volume = volume2 - volume + end if + + end if + + return +end +subroutine sphere_dia2imp_3d(p1, p2, r, pc) + +!*****************************************************************************80 +! +!! SPHERE_DIA2IMP_3D converts a diameter to an implicit sphere in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! ( P(1) - PC(1) )^2 + ( P(2) - PC(2) )^2 + ( P(3) - PC(3) )^2 = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), are two points which form a +! diameter of the sphere. +! +! Output, real ( kind = 8 ) R, the computed radius of the sphere. +! +! Output, real ( kind = 8 ) PC(3), the computed center of the sphere. +! + implicit none + + real(kind=8) p1(3) + real(kind=8) p2(3) + real(kind=8) pc(3) + real(kind=8) r + real(kind=8) r8vec_norm_affine + + r = 0.5D+00 * r8vec_norm_affine(3, p1, p2) + + pc(1:3) = 0.5D+00 * (p1(1:3) + p2(1:3)) + + return +end +subroutine sphere_distance_xyz(xyz1, xyz2, dist) + +!*****************************************************************************80 +! +!! SPHERE_DISTANCE_XYZ computes great circle distances on a sphere. +! +! Discussion: +! +! XYZ coordinates are used. +! +! We assume the points XYZ1 and XYZ2 lie on the same sphere. +! +! This computation is a special form of the Vincenty formula. +! It should be less sensitive to errors associated with very small +! or very large angular separations. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 August 2010 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! "Great-circle distance", +! Wikipedia. +! +! Parameters: +! +! Input, real ( kind = 8 ) XYZ1(3), the coordinates of the first point. +! +! Input, real ( kind = 8 ) XYZ2(3), the coordinates of the second point. +! +! Output, real ( kind = 8 ) DIST, the great circle distance between +! the points. +! + implicit none + + real(kind=8) bot + real(kind=8) dist + real(kind=8) lat1 + real(kind=8) lat2 + real(kind=8) lon1 + real(kind=8) lon2 + real(kind=8) r + real(kind=8) r8_asin + real(kind=8) r8_atan + real(kind=8) r8vec_norm + real(kind=8) top + real(kind=8) xyz1(3) + real(kind=8) xyz2(3) + + r = r8vec_norm(3, xyz1) + + lat1 = r8_asin(xyz1(3)) + lon1 = r8_atan(xyz1(2), xyz1(1)) + + lat2 = r8_asin(xyz2(3)) + lon2 = r8_atan(xyz2(2), xyz2(1)) + + top = (cos(lat2) * sin(lon1 - lon2))**2 & + + (cos(lat1) * sin(lat2) & + - sin(lat1) * cos(lat2) * cos(lon1 - lon2))**2 + + top = sqrt(top) + + bot = sin(lat1) * sin(lat2) & + + cos(lat1) * cos(lat2) * cos(lon1 - lon2) + + dist = r * atan2(top, bot) + + return +end +subroutine sphere_distance1(lat1, lon1, lat2, lon2, r, dist) + +!*****************************************************************************80 +! +!! SPHERE_DISTANCE1 computes great circle distances on a sphere. +! +! Discussion: +! +! This computation is based on the law of cosines for spheres. +! This formula can suffer from rounding errors when the angular +! distances are small. +! +! Here we assume that latitude is measured in radians, and goes +! from -PI at the south pole to +PI at the north pole. +! +! Similarly, longitude is measured in radians, and goes from 0 to 2 PI. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 February 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! "Great-circle distance", +! Wikipedia. +! +! Parameters: +! +! Input, real ( kind = 8 ) LAT1, LON1, the latitude and longitude of +! the first point. +! +! Input, real ( kind = 8 ) LAT2, LON2, the latitude and longitude of +! the second point. +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Output, real ( kind = 8 ) DIST, the great circle distance between +! the points, measured in the same units as R. +! + implicit none + + real(kind=8) c + real(kind=8) dist + real(kind=8) lat1 + real(kind=8) lat2 + real(kind=8) lon1 + real(kind=8) lon2 + real(kind=8) r + + c = cos(lat1) * cos(lat2) * cos(lon1 - lon2) & + + sin(lat1) * sin(lat2) + + dist = r * acos(c) + + return +end +subroutine sphere_distance2(lat1, lon1, lat2, lon2, r, dist) + +!*****************************************************************************80 +! +!! SPHERE_DISTANCE2 computes great circle distances on a sphere. +! +! Discussion: +! +! This computation is written in terms of haversines, and can be more +! accurate when measuring small angular distances. It can be somewhat +! inaccurate when the two points are antipodal. +! +! Here we assume that latitude is measured in radians, and goes +! from -PI at the south pole to +PI at the north pole. +! +! Similarly, longitude is measured in radians, and goes from 0 to 2 PI. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 February 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! "Great-circle distance", +! Wikipedia. +! +! Parameters: +! +! Input, real ( kind = 8 ) LAT1, LON1, the latitude and longitude of +! the first point. +! +! Input, real ( kind = 8 ) LAT2, LON2, the latitude and longitude of +! the second point. +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Output, real ( kind = 8 ) DIST, the great circle distance between +! the points, measured in the same units as R. +! + implicit none + + real(kind=8) dist + real(kind=8) lat1 + real(kind=8) lat2 + real(kind=8) lon1 + real(kind=8) lon2 + real(kind=8) r + real(kind=8) s + + s = (sin((lat1 - lat2) / 2.0D+00))**2 & + + cos(lat1) * cos(lat2) * (sin((lon1 - lon2) / 2.0D+00))**2 + s = sqrt(s) + + dist = 2.0D+00 * r * asin(s) + + return +end +subroutine sphere_distance3(lat1, lon1, lat2, lon2, r, dist) + +!*****************************************************************************80 +! +!! SPHERE_DISTANCE3 computes great circle distances on a sphere. +! +! Discussion: +! +! This computation is a special form of the Vincenty formula. +! It should be less sensitive to errors associated with very small +! or very large angular separations. +! +! Here we assume that latitude is measured in radians, and goes +! from -PI at the south pole to +PI at the north pole. +! +! Similarly, longitude is measured in radians, and goes from 0 to 2 PI. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 February 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! "Great-circle distance", +! Wikipedia. +! +! Parameters: +! +! Input, real ( kind = 8 ) LAT1, LON1, the latitude and longitude of +! the first point. +! +! Input, real ( kind = 8 ) LAT2, LON2, the latitude and longitude of +! the second point. +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Output, real ( kind = 8 ) DIST, the great circle distance between +! the points, measured in the same units as R. +! + implicit none + + real(kind=8) bot + real(kind=8) dist + real(kind=8) lat1 + real(kind=8) lat2 + real(kind=8) lon1 + real(kind=8) lon2 + real(kind=8) r + real(kind=8) top + + top = (cos(lat2) * sin(lon1 - lon2))**2 & + + (cos(lat1) * sin(lat2) & + - sin(lat1) * cos(lat2) * cos(lon1 - lon2))**2 + + top = sqrt(top) + + bot = sin(lat1) * sin(lat2) & + + cos(lat1) * cos(lat2) * cos(lon1 - lon2) + + dist = r * atan2(top, bot) + + return +end +subroutine sphere_exp_contains_point_3d(p1, p2, p3, p4, p, inside) + +!*****************************************************************************80 +! +!! SPHERE_EXP_CONTAINS_POINT_3D: does an explicit sphere contain a point in 3D. +! +! Discussion: +! +! An explicit sphere in 3D is determined by four points, +! which should be distinct, and not coplanar. +! +! The computation checks the determinant of the 5 by 5 matrix: +! +! x1 y1 z1 x1^2+y1^2+z1^2 1 +! x2 y2 z2 x2^2+y2^2+z2^2 1 +! x3 y3 z3 x3^2+y3^2+z3^2 1 +! x4 y4 z4 x4^2+y4^2+z4^2 1 +! x y z x^2 +y^2 +z^2 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), +! four distinct noncoplanar points on the sphere. +! +! Input, real ( kind = 8 ) P(3), the coordinates of a point, whose +! position relative to the sphere is desired. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is in the sphere. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a(5, 5) + real(kind=8) det + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + real(kind=8) r8mat_det_5d +! +! Compute the determinant. +! + a(1, 1:dim_num) = p1(1:dim_num) + a(1, 4) = sum(p1(1:dim_num)**2) + a(1, 5) = 1.0D+00 + + a(2, 1:dim_num) = p2(1:dim_num) + a(2, 4) = sum(p2(1:dim_num)**2) + a(2, 5) = 1.0D+00 + + a(3, 1:dim_num) = p3(1:dim_num) + a(3, 4) = sum(p3(1:dim_num)**2) + a(3, 5) = 1.0D+00 + + a(4, 1:dim_num) = p4(1:dim_num) + a(4, 4) = sum(p4(1:dim_num)**2) + a(4, 5) = 1.0D+00 + + a(5, 1:dim_num) = p(1:dim_num) + a(5, 4) = sum(p(1:dim_num)**2) + a(5, 5) = 1.0D+00 + + det = r8mat_det_5d(a) + + if (det < 0.0D+00) then + inside = .false. + else if (0.0D+00 <= det) then + inside = .true. + end if + + return +end +subroutine sphere_exp_point_near_3d(p1, p2, p3, p4, p, pn) + +!*****************************************************************************80 +! +!! SPHERE_EXP_POINT_NEAR_3D: nearest point on explicit sphere to a point in 3D. +! +! Discussion: +! +! An explicit sphere in 3D is determined by four points, +! which should be distinct, and not coplanar. +! +! If the center of the sphere is PC, and the point is P, then +! the desired point lies at a positive distance R along the vector +! P-PC unless P = PC in which case any point on the sphere is "nearest". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), +! four distinct noncoplanar points on the sphere. +! +! Input, real ( kind = 8 ) P(3), a point whose nearest point on the +! sphere is desired. +! +! Output, real ( kind = 8 ) PN(3), the nearest point on the sphere. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) norm + real(kind=8) p(dim_num) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pn(dim_num) + real(kind=8) r +! +! Find the center. +! + call sphere_exp2imp_3d(p1, p2, p3, p4, r, pc) +! +! If P = PC, bail out now. +! + norm = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) + + if (norm == 0.0D+00) then + pn(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) + return + end if +! +! Compute the nearest point. +! + pn(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / norm + + return +end +subroutine sphere_exp2imp_3d(p1, p2, p3, p4, r, pc) + +!*****************************************************************************80 +! +!! SPHERE_EXP2IMP_3D converts a sphere from explicit to implicit form in 3D. +! +! Discussion: +! +! An explicit sphere in 3D is determined by four points, +! which should be distinct, and not coplanar. +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), +! four distinct noncoplanar points on the sphere. +! +! Output, real ( kind = 8 ) R, PC(3), the radius and the center +! of the sphere. If the linear system is +! singular, then R = -1, PC(1:3) = 0. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) tetra(dim_num, 4) + + tetra(1:dim_num, 1:4) = reshape((/ & + p1(1:dim_num), p2(1:dim_num), p3(1:dim_num), p4(1:dim_num)/), & + (/dim_num, 4/)) + + call tetrahedron_circumsphere_3d(tetra, r, pc) + + return +end +subroutine sphere_exp2imp_nd(n, p, r, pc) + +!*****************************************************************************80 +! +!! SPHERE_EXP2IMP_ND finds an N-dimensional sphere through N+1 points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 July 2011 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the spatial dimension. +! +! Input, real ( kind = 4 ) P(N,N+1), the points. +! +! Output, real ( kind = 8 ) R, PC(N), the radius and center of the +! sphere. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(n, n + 1) + integer(kind=4) i + integer(kind=4) info + integer(kind=4) j + real(kind=8) pc(n) + real(kind=8) r + real(kind=8) p(n, n + 1) +! +! Set up the linear system. +! + a(1:n, 1:n) = transpose(p(1:n, 2:n + 1)) + + do j = 1, n + a(1:n, j) = a(1:n, j) - p(j, 1) + end do + + do i = 1, n + a(i, n + 1) = sum(a(i, 1:n)**2) + end do +! +! Solve the linear system. +! + call r8mat_solve(n, 1, a, info) +! +! If the system was singular, return a consolation prize. +! + if (info /= 0) then + r = -1.0D+00 + pc(1:n) = 0.0D+00 + return + end if +! +! Compute the radius and center. +! + r = 0.5D+00 * sqrt(sum(a(1:n, n + 1)**2)) + + pc(1:n) = p(1:n, 1) + 0.5D+00 * a(1:n, n + 1) + + return +end +subroutine sphere_imp_area_3d(r, area) + +!*****************************************************************************80 +! +!! SPHERE_IMP_AREA_3D computes the surface area of an implicit sphere in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 13 August 2014 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Output, real ( kind = 8 ) AREA, the area of the sphere. +! + implicit none + + real(kind=8) area + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + area = 4.0D+00 * r8_pi * r * r + + return +end +subroutine sphere_imp_area_nd(dim_num, r, area) + +!*****************************************************************************80 +! +!! SPHERE_IMP_AREA_ND computes the surface area of an implicit sphere in ND. +! +! Discussion: +! +! An implicit sphere in ND satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - pc(1:DIM_NUM) )^2 ) = R^2 +! +! DIM_NUM Area +! +! 2 2 * PI * R +! 3 4 * PI * R^2 +! 4 2 * PI^2 * R^3 +! 5 (8/3) * PI^2 * R^4 +! 6 PI^3 * R^5 +! 7 (16/15) * PI^3 * R^6 +! +! Sphere_Area ( DIM_NUM, R ) = +! 2 * PI^(DIM_NUM/2) * R^(DIM_NUM-1) / Gamma ( DIM_NUM / 2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Output, real ( kind = 8 ) AREA, the area of the sphere. +! + implicit none + + real(kind=8) area + integer(kind=4) dim_num + real(kind=8) r + real(kind=8) sphere01_area_nd + + area = r**(dim_num - 1) * sphere01_area_nd(dim_num) + + return +end +subroutine sphere_imp_contains_point_3d(r, pc, p, inside) + +!*****************************************************************************80 +! +!! SPHERE_IMP_CONTAINS_POINT_3D: point in implicit sphere in 3D? +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 February 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) PC(3), the center of the sphere. +! +! Input, real ( kind = 8 ) P(3), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if the point is +! inside the sphere. +! + implicit none + + logical(kind=4) inside + real(kind=8) p(3) + real(kind=8) pc(3) + real(kind=8) r + + if (sum((p(1:3) - pc(1:3))**2) <= r * r) then + inside = .true. + else + inside = .false. + end if + + return +end +subroutine sphere_imp_line_project_3d(r, pc, n, p, maxpnt2, n2, pp, & + theta_min, theta_max) + +!*****************************************************************************80 +! +!! SPHERE_IMP_LINE_PROJECT_3D projects a line onto an implicit sphere in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! The line to be projected is specified as a sequence of points. +! If two successive points subtend a small angle, then the second +! point is essentially dropped. If two successive points subtend +! a large angle, then intermediate points are inserted, so that +! the projected line stays closer to the sphere. +! +! Note that if any P coincides with the center of the sphere, then +! its projection is mathematically undefined. PP will +! be returned as the center. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. If R is +! zero, PP will be returned as the pc, and if R is +! negative, points will end up diametrically opposite from where +! you would expect them for a positive R. +! +! Input, real ( kind = 8 ) PC(3), the center of the sphere. +! +! Input, integer ( kind = 4 ) N, the number of points on the line that is +! to be projected. +! +! Input, real ( kind = 8 ) P(3,N), the coordinates of +! the points on the line that is to be projected. +! +! Input, integer ( kind = 4 ) MAXPNT2, the maximum number of points on the +! projected line. Even if the routine thinks that more points are needed, +! no more than MAXPNT2 will be generated. +! +! Output, integer ( kind = 4 ) N2, the number of points on the projected +! line. N2 can be zero, if the line has an angular projection of less +! than THETA_MIN radians. +! +! Output, real ( kind = 8 ) PP(3,N2), the coordinates +! of the points representing the projected line. These points lie on the +! sphere. Successive points are separated by at least THETA_MIN +! radians, and by no more than THETA_MAX radians. +! +! Input, real ( kind = 8 ) THETA_MIN, THETA_MAX, the minimum and maximum +! angular projections allowed between successive projected points. +! If two successive points on the original line have projections +! separated by more than THETA_MAX radians, then intermediate points +! will be inserted, in an attempt to keep the line closer to the +! sphere. If two successive points are separated by less than +! THETA_MIN radians, then the second point is dropped, and the +! line from the first point to the next point is considered. +! + implicit none + + integer(kind=4) maxpnt2 + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) n + + real(kind=8) alpha + real(kind=8) ang3d + real(kind=8) dot + integer(kind=4) i + integer(kind=4) j + integer(kind=4) nfill + integer(kind=4) n2 + real(kind=8) p(dim_num, n) + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pd(dim_num) + real(kind=8) pp(dim_num, maxpnt2) + real(kind=8) r + real(kind=8) r8_acos + real(kind=8) theta_max + real(kind=8) theta_min + real(kind=8) tnorm +! +! Check the input. +! + if (r == 0.0D+00) then + n2 = 0 + return + end if + + p1(1:dim_num) = pc(1:dim_num) + p2(1:dim_num) = pc(1:dim_num) + + n2 = 0 + + do i = 1, n + + if (all(p(1:dim_num, i) == pc(1:dim_num))) then + + else + + p1(1:dim_num) = p2(1:dim_num) + + alpha = sqrt(sum((p(1:dim_num, i) - pc(1:dim_num))**2)) + + p2(1:dim_num) = pc(1:dim_num) & + + r * (p(1:dim_num, i) - pc(1:dim_num)) / alpha +! +! If we haven't gotten any points yet, take this point as our start. +! + if (n2 == 0) then + + n2 = n2 + 1 + pp(1:dim_num, n2) = p2(1:dim_num) +! +! Compute the angular projection of P1 to P2. +! + else if (1 <= n2) then + + dot = sum((p1(1:dim_num) - pc(1:dim_num)) & + * (p2(1:dim_num) - pc(1:dim_num))) + + ang3d = r8_acos(dot / (r * r)) +! +! If the angle is at least THETA_MIN, (or it's the last point), +! then we will draw a line segment. +! + if (theta_min < abs(ang3d) .or. i == n) then +! +! Now we check to see if the line segment is too long. +! + if (theta_max < abs(ang3d)) then + + nfill = int(abs(ang3d) / theta_max) + + do j = 1, nfill - 1 + + pd(1:dim_num) = & + (real(nfill - j, kind=8) & + * (p1(1:dim_num) - pc(1:dim_num)) & + + real(j, kind=8) & + * (p2(1:dim_num) - pc(1:dim_num))) + + tnorm = sqrt(sum(pd(1:dim_num)**2)) + + if (tnorm /= 0.0D+00) then + pd(1:dim_num) = pc(1:dim_num) + r * pd(1:dim_num) / tnorm + n2 = n2 + 1 + pp(1:dim_num, n2) = pd(1:dim_num) + end if + + end do + + end if +! +! Now tack on the projection of point 2. +! + n2 = n2 + 1 + pp(1:dim_num, n2) = p2(1:dim_num) + + end if + + end if + + end if + + end do + + return +end +subroutine sphere_imp_local2xyz_3d(r, pc, theta, phi, p) + +!*****************************************************************************80 +! +!! SPHERE_IMP_LOCAL2XYZ_3D: local to XYZ coordinates on implicit sphere in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! The "local" spherical coordinates of a point are two angles, THETA and PHI. +! PHI measures the angle that the vector from the origin to the point +! makes with the positive Z axis. THETA measures the angle that the +! projection of the vector onto the XY plane makes with the positive X axis. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 July 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) PC(3), the center of the sphere. +! +! Input, real ( kind = 8 ) THETA, PHI, the local (THETA,PHI) spherical +! coordinates of a point on the sphere. THETA and PHI are angles, +! measured in radians. Usually, 0 <= THETA < 2 * PI, and 0 <= PHI <= PI. +! +! Output, real ( kind = 8 ) P(3), the XYZ coordinates of the point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) phi + real(kind=8) r + real(kind=8) theta + + p(1) = pc(1) + r * sin(phi) * cos(theta) + p(2) = pc(2) + r * sin(phi) * sin(theta) + p(3) = pc(3) + r * cos(phi) + + return +end +subroutine sphere_imp_point_near_3d(r, pc, p, pn) + +!*****************************************************************************80 +! +!! SPHERE_IMP_POINT_NEAR_3D: nearest point on implicit sphere to a point in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! If the center of the sphere is PC, and the point is P, then +! the desired point lies at a positive distance R along the vector +! P-PC unless P = PC, in which case any point on the sphere is "nearest". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 July 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) PC(3), the center of the sphere. +! +! Input, real ( kind = 8 ) P(3), a point whose +! nearest point on the sphere is desired. +! +! Output, real ( kind = 8 ) PN(3), the nearest point on the sphere. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) norm + real(kind=8) p(3) + real(kind=8) pc(3) + real(kind=8) pn(3) + real(kind=8) r +! +! If P = PC, bail out now. +! + norm = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) + + if (norm == 0.0D+00) then + pn(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) + return + end if +! +! Compute the nearest point. +! + pn(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / norm + + return +end +subroutine sphere_imp_point_project_3d(r, pc, p, pp) + +!*****************************************************************************80 +! +!! SPHERE_IMP_POINT_PROJECT_3D projects a point onto an implicit sphere in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) PC(3), the center of the sphere. +! +! Input, real ( kind = 8 ) P(3), a point. +! +! Output, real ( kind = 8 ) PP(3), the projected point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) norm + real(kind=8) p(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) pp(dim_num) + real(kind=8) r + + if (r == 0.0D+00) then + + pp(1:dim_num) = pc(1:dim_num) + + else if (all(p(1:dim_num) == pc(1:dim_num))) then + + pp(1:dim_num) = pc(1:dim_num) + r / sqrt(real(dim_num, kind=8)) + + else + + norm = sqrt(sum((p(1:dim_num) - pc(1:dim_num))**2)) + + pp(1:dim_num) = pc(1:dim_num) + r * (p(1:dim_num) - pc(1:dim_num)) / norm + + end if + + return +end +subroutine sphere_imp_volume_3d(r, volume) + +!*****************************************************************************80 +! +!! SPHERE_IMP_VOLUME_3D computes the volume of an implicit sphere in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - pc(1:DIM_NUM) )^2 ) = R^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 January 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the sphere. +! + implicit none + + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) volume + + volume = (4.0D+00 / 3.0D+00) * r8_pi * r * r * r + + return +end +subroutine sphere_imp_volume_nd(dim_num, r, volume) + +!*****************************************************************************80 +! +!! SPHERE_IMP_VOLUME_ND computes the volume of an implicit sphere in ND. +! +! Discussion: +! +! An implicit sphere in ND satisfies the equation: +! +! sum ( ( X(1:N) - PC(1:N) )^2 ) = R^2 +! +! where R is the radius and PC is the center. +! +! Results for the first few values of N are: +! +! DIM_NUM Volume +! - ----------------------- +! 2 PI * R^2 +! 3 (4/3) * PI * R^3 +! 4 (1/2) * PI^2 * R^4 +! 5 (8/15) * PI^2 * R^5 +! 6 (1/6) * PI^3 * R^6 +! 7 (16/105) * PI^3 * R^7 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the sphere. +! + implicit none + + integer(kind=4) dim_num + real(kind=8) r + real(kind=8) sphere01_volume_nd + real(kind=8) volume + + volume = r**dim_num * sphere01_volume_nd(dim_num) + + return +end +subroutine sphere_imp_zone_area_3d(r, h1, h2, area) + +!*****************************************************************************80 +! +!! SPHERE_IMP_ZONE_AREA_3D computes the surface area of a spherical zone in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! Draw any radius of the sphere and note the point P where the radius +! intersects the sphere. Now choose two points on the radius line, a +! distance H1 and H2 from the point P. Consider all the points on or within +! the sphere whose projection onto the radius lies between these two points. +! These points constitute the spherical zone, which can also be considered +! the difference of two spherical caps. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H1, H2, the distances that define the +! thickness of the zone. H1 and H2 must be between 0 and 2 * R. +! +! Output, real ( kind = 8 ) AREA, the area of the spherical zone. +! + implicit none + + real(kind=8) area + real(kind=8) h + real(kind=8) h1 + real(kind=8) h2 + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + + h = abs(h1 - h2) + + if (h <= 0.0D+00) then + area = 0.0D+00 + else if (2.0D+00 * r <= h) then + area = 4.0D+00 * r8_pi * r * r + else + area = 2.0D+00 * r8_pi * r * h + end if + + return +end +subroutine sphere_imp_zone_volume_3d(r, h1, h2, volume) + +!*****************************************************************************80 +! +!! SPHERE_IMP_ZONE_VOLUME_3D computes the volume of a spherical zone in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - pc(1:DIM_NUM) )^2 ) = R^2 +! +! Draw any radius of the sphere and note the point P where the radius +! intersects the sphere. Now choose two points on the radius line, a +! distance H1 and H2 from the point P. Consider all the points on or within +! the sphere whose projection onto the radius lies between these two points. +! These points constitute the spherical zone, which can also be considered +! the difference of two spherical caps. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 April 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) H1, H2, the distances that define the +! thickness of the zone. H1 and H2 must be between 0 and 2 * R. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the spherical zone +! + implicit none + + real(kind=8) h1 + real(kind=8) h11 + real(kind=8) h2 + real(kind=8) h22 + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) volume + + h11 = min(h1, h2) + h11 = max(h11, 0.0D+00) + + if (2.0D+00 * r <= h11) then + volume = 0.0D+00 + return + end if + + h22 = max(h1, h2) + h22 = min(h22, 2.0D+00 * r) + + if (h22 <= 0.0D+00) then + volume = 0.0D+00 + return + end if + + volume = (1.0D+00 / 3.0D+00) * r8_pi * ( & + h22 * h22 * (3.0D+00 * r - h22) & + - h11 * h11 * (3.0D+00 * r - h11)) + + return +end +subroutine sphere_imp2exp_3d(r, pc, p1, p2, p3, p4) + +!*****************************************************************************80 +! +!! SPHERE_IMP2EXP_3D converts a sphere from implicit to explicit form in 3D. +! +! Discussion: +! +! An implicit sphere in 3D satisfies the equation: +! +! sum ( ( P(1:DIM_NUM) - PC(1:DIM_NUM) )^2 ) = R^2 +! +! An explicit sphere in 3D is determined by four points, +! which should be distinct, and not coplanar. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 February 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) R, PC(3), the radius and center of the sphere. +! +! Output, real ( kind = 8 ) P1(3), P2(3), P3(3), P4(3), +! four distinct noncoplanar points on the sphere. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) p1(dim_num) + real(kind=8) p2(dim_num) + real(kind=8) p3(dim_num) + real(kind=8) p4(dim_num) + real(kind=8) pc(dim_num) + real(kind=8) phi + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) theta + + theta = 0.0D+00 + phi = 0.0D+00 + + p1(1) = pc(1) + r * cos(theta) * sin(phi) + p1(2) = pc(2) + r * sin(theta) * sin(phi) + p1(3) = pc(3) + r * cos(phi) + + theta = 0.0D+00 + phi = 2.0D+00 * r8_pi / 3.0D+00 + + p2(1) = pc(1) + r * cos(theta) * sin(phi) + p2(2) = pc(2) + r * sin(theta) * sin(phi) + p2(3) = pc(3) + r * cos(phi) + + theta = 2.0D+00 * r8_pi / 3.0D+00 + phi = 2.0D+00 * r8_pi / 3.0D+00 + + p3(1) = pc(1) + r * cos(theta) * sin(phi) + p3(2) = pc(2) + r * sin(theta) * sin(phi) + p3(3) = pc(3) + r * cos(phi) + + theta = 4.0D+00 * r8_pi / 3.0D+00 + phi = 2.0D+00 * r8_pi / 3.0D+00 + + p4(1) = pc(1) + r * cos(theta) * sin(phi) + p4(2) = pc(2) + r * sin(theta) * sin(phi) + p4(3) = pc(3) + r * cos(phi) + + return +end +function sphere_k(dim_num) + +!*****************************************************************************80 +! +!! SPHERE_K computes a factor useful for spherical computations. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 December 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Thomas Ericson, Victor Zinoviev, +! Codes on Euclidean Spheres, +! Elsevier, 2001, pages 439-441. +! QA166.7 E75 +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. +! +! Output, real ( kind = 8 ) SPHERE_K, the factor. +! + implicit none + + integer(kind=4) i4_factorial2 + integer(kind=4) dim_num + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) sphere_k + + if (mod(dim_num, 2) == 0) then + sphere_k = (2.0D+00 * r8_pi)**(dim_num / 2) + else + sphere_k = 2.0D+00 * (2.0D+00 * r8_pi)**((dim_num - 1) / 2) + end if + + sphere_k = sphere_k / real(i4_factorial2(dim_num - 2), kind=8) + + return +end +subroutine sphere_triangle_angles_to_area(r, a, b, c, area) + +!*****************************************************************************80 +! +!! SPHERE_TRIANGLE_ANGLES_TO_AREA computes the area of a spherical triangle. +! +! Discussion: +! +! A sphere centered at 0 in 3D satisfies the equation: +! +! X*X + Y*Y + Z*Z = R*R +! +! A spherical triangle is specified by three points on the surface +! of the sphere. +! +! The area formula is known as Girard's formula. +! +! The area of a spherical triangle is: +! +! AREA = ( A + B + C - PI ) * R*R +! +! where A, B and C are the (surface) angles of the triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) A, B, C, the angles of the triangle. +! +! Output, real ( kind = 8 ) AREA, the area of the spherical triangle. +! + implicit none + + real(kind=8) a + real(kind=8) area + real(kind=8) b + real(kind=8) c + real(kind=8) r + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 +! +! Apply Girard's formula. +! + area = r * r * (a + b + c - r8_pi) + + return +end +subroutine sphere_triangle_sides_to_angles(r, as, bs, cs, a, b, c) + +!*****************************************************************************80 +! +!! SPHERE_TRIANGLE_SIDES_TO_ANGLES computes spherical triangle angles. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the +! sides of the triangle. +! +! Output, real ( kind = 8 ) A, B, C, the spherical angles of the triangle. +! Angle A is opposite the side of length AS, and so on. +! + implicit none + + real(kind=8) a + real(kind=8) as + real(kind=8) asu + real(kind=8) b + real(kind=8) bs + real(kind=8) bsu + real(kind=8) c + real(kind=8) cs + real(kind=8) csu + real(kind=8) r + real(kind=8) ssu + real(kind=8) tan_a2 + real(kind=8) tan_b2 + real(kind=8) tan_c2 + + asu = as / r + bsu = bs / r + csu = cs / r + ssu = (asu + bsu + csu) / 2.0D+00 + + tan_a2 = sqrt((sin(ssu - bsu) * sin(ssu - csu)) / & + (sin(ssu) * sin(ssu - asu))) + + a = 2.0D+00 * atan(tan_a2) + + tan_b2 = sqrt((sin(ssu - asu) * sin(ssu - csu)) / & + (sin(ssu) * sin(ssu - bsu))) + + b = 2.0D+00 * atan(tan_b2) + + tan_c2 = sqrt((sin(ssu - asu) * sin(ssu - bsu)) / & + (sin(ssu) * sin(ssu - csu))) + + c = 2.0D+00 * atan(tan_c2) + + return +end +subroutine sphere_triangle_vertices_to_angles(r, v1, v2, v3, a, b, c) + +!*****************************************************************************80 +! +!! SPHERE_TRIANGLE_VERTICES_TO_ANGLES: spherical triangle angles from vertices. +! +! Discussion: +! +! A sphere centered at 0 in 3D satisfies the equation: +! +! X * X + Y * Y + Z * Z = R * R +! +! A spherical triangle is specified by three points on the surface +! of the sphere. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 August 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. +! +! Output, real ( kind = 8 ) A, B, C, the angles of the spherical triangle. +! + implicit none + + real(kind=8) a + real(kind=8) as + real(kind=8) b + real(kind=8) bs + real(kind=8) c + real(kind=8) cs + real(kind=8) r + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) +! +! Compute the lengths of the sides of the spherical triangle. +! + call sphere_triangle_vertices_to_sides(r, v1, v2, v3, as, bs, cs) +! +! Get the spherical angles. +! + call sphere_triangle_sides_to_angles(r, as, bs, cs, a, b, c) + + return +end +subroutine sphere_triangle_vertices_to_area(r, v1, v2, v3, area) + +!*****************************************************************************80 +! +!! SPHERE_TRIANGLE_VERTICES_TO_AREA computes the area of a spherical triangle. +! +! Discussion: +! +! A sphere centered at 0 in 3D satisfies the equation: +! +! X * X + Y * Y + Z * Z = R * R +! +! A spherical triangle is specified by three points on the surface +! of the sphere. +! +! The area formula is known as Girard's formula. +! +! The area of a spherical triangle is: +! +! AREA = ( A + B + C - PI ) * R*R +! +! where A, B and C are the (surface) angles of the triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. +! +! Output, real ( kind = 8 ) AREA, the area of the spherical triangle. +! + implicit none + + real(kind=8) a + real(kind=8) area + real(kind=8) as + real(kind=8) b + real(kind=8) bs + real(kind=8) c + real(kind=8) cs + real(kind=8) r + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) +! +! Compute the lengths of the sides of the spherical triangle. +! + call sphere_triangle_vertices_to_sides(r, v1, v2, v3, as, bs, cs) +! +! Get the spherical angles. +! + call sphere_triangle_sides_to_angles(r, as, bs, cs, a, b, c) +! +! Get the area. +! + call sphere_triangle_angles_to_area(r, a, b, c, area) + + return +end +subroutine sphere_triangle_vertices_to_centroid(r, v1, v2, v3, vs) + +!*****************************************************************************80 +! +!! SPHERE_TRIANGLE_VERTICES_TO_CENTROID gets a spherical triangle centroid. +! +! Discussion: +! +! A sphere centered at 0 in 3D satisfies the equation: +! +! X*X + Y*Y + Z*Z = R*R +! +! A spherical triangle is specified by three points on the sphere. +! +! The (true) centroid of a spherical triangle is the point +! +! VT = (XT,YT,ZT) = Integral ( X, Y, Z ) dArea / Integral 1 dArea +! +! Note that the true centroid does NOT, in general, lie on the sphere. +! +! The "flat" centroid VF is the centroid of the planar triangle defined by +! the vertices of the spherical triangle. +! +! The "spherical" centroid VS of a spherical triangle is computed by +! the intersection of the geodesic bisectors of the triangle angles. +! The spherical centroid lies on the sphere. +! +! VF, VT and VS lie on a line through the center of the sphere. We can +! easily calculate VF by averaging the vertices, and from this determine +! VS by normalizing. +! +! Of course, we still will not have actually computed VT, which lies +! somewhere between VF and VS! +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. +! +! Output, real ( kind = 8 ) VS(3), the coordinates of the "spherical +! centroid" of the spherical triangle. +! + implicit none + + real(kind=8) norm + real(kind=8) r + real(kind=8) r8vec_norm + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + real(kind=8) vs(3) + + vs(1:3) = (v1(1:3) + v2(1:3) + v3(1:3)) / 3.0D+00 + + norm = r8vec_norm(3, vs) + + vs(1:3) = r * vs(1:3) / norm + + return +end +subroutine sphere_triangle_vertices_to_orientation(a, b, c, o) + +!*****************************************************************************80 +! +!! SPHERE_TRIANGLE_VERTICES_TO_ORIENTATION: orientation of a spherical triangle. +! +! Discussion: +! +! Three points on a sphere actually compute two triangles; typically +! we are interested in the smaller of the two. +! +! As long as our triangle is "small", we can define an orientation +! by comparing the direction of the centroid against the normal +! vector (C-B) x (A-B). If the dot product of these vectors +! is positive, we say the triangle has positive orientation. +! +! By using information from the triangle orientation, we can correctly +! determine the area of a Voronoi polygon by summing up the pieces +! of Delaunay triangles, even in the case when the Voronoi vertex +! lies outside the Delaunay triangle. In that case, the areas of +! some of the Delaunay triangle pieces must be formally negative. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 May 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A(3), B(3), C(3), three points on a sphere. +! +! Output, integer ( kind = 4 ) O, is +1 if the spherical triangle is +! judged to have positive orientation, and -1 otherwise. +! + implicit none + + real(kind=8) a(3) + real(kind=8) b(3) + real(kind=8) c(3) + real(kind=8) cd(3) + real(kind=8) cp(3) + integer(kind=4) o + real(kind=8) v1(3) + real(kind=8) v2(3) +! +! Centroid. +! + cd(1:3) = (a(1:3) + b(1:3) + c(1:3)) / 3.0D+00 +! +! Cross product ( C - B ) x ( A - B ); +! + v1(1:3) = c(1:3) - b(1:3) + v2(1:3) = a(1:3) - b(1:3) + + cp(1) = v1(2) * v2(3) - v1(3) * v2(2) + cp(2) = v1(3) * v2(1) - v1(1) * v2(3) + cp(3) = v1(1) * v2(2) - v1(2) * v2(1) +! +! Compare the directions. +! + if (dot_product(cp, cd) < 0.0D+00) then + o = -1 + else + o = +1 + end if + + return +end +subroutine sphere_triangle_vertices_to_sides(r, v1, v2, v3, as, bs, cs) + +!*****************************************************************************80 +! +!! SPHERE_TRIANGLE_VERTICES_TO_SIDES computes spherical triangle sides. +! +! Discussion: +! +! We can use the ACOS system call here, but the ARC_COSINE routine +! will automatically take care of cases where the input argument is +! (usually slightly) out of bounds. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R, the radius of the sphere. +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the spherical +! triangle. +! +! Output, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the sides +! of the triangle. +! + implicit none + + real(kind=8) as + real(kind=8) bs + real(kind=8) cs + real(kind=8) r + real(kind=8) r8_acos + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + + as = r * r8_acos(dot_product(v2(1:3), v3(1:3)) / r**2) + bs = r * r8_acos(dot_product(v3(1:3), v1(1:3)) / r**2) + cs = r * r8_acos(dot_product(v1(1:3), v2(1:3)) / r**2) + + return +end +function sphere01_area_nd(dim_num) + +!*****************************************************************************80 +! +!! SPHERE01_AREA_ND computes the surface area of a unit sphere in ND. +! +! Discussion: +! +! The unit sphere in ND satisfies: +! +! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 +! +! Results for the first few values of N are: +! +! DIM_NUM Area +! +! 2 2 * PI +! 3 4 * PI +! 4 ( 2 / 1) * PI^2 +! 5 ( 8 / 3) * PI^2 +! 6 ( 1 / 1) * PI^3 +! 7 (16 / 15) * PI^3 +! 8 ( 1 / 3) * PI^4 +! 9 (32 / 105) * PI^4 +! 10 ( 1 / 12) * PI^5 +! +! For the unit sphere, Area(DIM_NUM) = DIM_NUM * Volume(DIM_NUM) +! +! Sphere_Unit_Area ( DIM_NUM ) = 2 * PI^(DIM_NUM/2) / Gamma ( DIM_NUM / 2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. +! +! Output, real ( kind = 8 ) SPHERE01_AREA_ND, the area of the sphere. +! + implicit none + + real(kind=8) area + integer(kind=4) dim_num + integer(kind=4) i + integer(kind=4) m + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) sphere01_area_nd + + if (mod(dim_num, 2) == 0) then + m = dim_num / 2 + area = 2.0D+00 * (r8_pi)**m + do i = 1, m - 1 + area = area / real(i, kind=8) + end do + else + m = (dim_num - 1) / 2 + area = (r8_pi)**m * 2.0D+00**dim_num + do i = m + 1, 2 * m + area = area / real(i, kind=8) + end do + end if + + sphere01_area_nd = area + + return +end +subroutine sphere01_area_values(n_data, n, area) + +!*****************************************************************************80 +! +!! SPHERE01_AREA_VALUES returns some areas of the unit sphere in ND. +! +! Discussion: +! +! The formula for the surface area of the unit sphere in N dimensions is: +! +! Sphere_Unit_Area ( N ) = 2 * pi^(N/2) / Gamma ( N / 2 ) +! +! Some values of the function include: +! +! N Area +! +! 2 2 * PI +! 3 ( 4 / ) * PI +! 4 ( 2 / 1) * PI^2 +! 5 ( 8 / 3) * PI^2 +! 6 ( 1 / 1) * PI^3 +! 7 (16 / 15) * PI^3 +! 8 ( 1 / 3) * PI^4 +! 9 (32 / 105) * PI^4 +! 10 ( 1 / 12) * PI^5 +! +! For the unit sphere, Area(N) = N * Volume(N) +! +! In Mathematica, the function can be evaluated by: +! +! 2 * Pi^(n/2) / Gamma[n/2] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 August 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, integer ( kind = 4 ) N, the spatial dimension. +! +! Output, real ( kind = 8 ) AREA, the area of the unit sphere +! in that dimension. +! + implicit none + + integer(kind=4), parameter :: n_max = 20 + + real(kind=8) area + real(kind=8), save, dimension(n_max) :: area_vec = (/ & + 0.2000000000000000D+01, & + 0.6283185307179586D+01, & + 0.1256637061435917D+02, & + 0.1973920880217872D+02, & + 0.2631894506957162D+02, & + 0.3100627668029982D+02, & + 0.3307336179231981D+02, & + 0.3246969701133415D+02, & + 0.2968658012464836D+02, & + 0.2550164039877345D+02, & + 0.2072514267328890D+02, & + 0.1602315322625507D+02, & + 0.1183817381218268D+02, & + 0.8389703410491089D+01, & + 0.5721649212349567D+01, & + 0.3765290085742291D+01, & + 0.2396678817591364D+01, & + 0.1478625959000308D+01, & + 0.8858104195716824D+00, & + 0.5161378278002812D+00/) + integer(kind=4) n_data + integer(kind=4) n + integer(kind=4), save, dimension(n_max) :: n_vec = (/ & + 1, & + 2, & + 3, & + 4, & + 5, & + 6, & + 7, & + 8, & + 9, & + 10, & + 11, & + 12, & + 13, & + 14, & + 15, & + 16, & + 17, & + 18, & + 19, & + 20/) + + if (n_data < 0) then + n_data = 0 + end if + + n_data = n_data + 1 + + if (n_max < n_data) then + n_data = 0 + n = 0 + area = 0.0D+00 + else + n = n_vec(n_data) + area = area_vec(n_data) + end if + + return +end +subroutine sphere01_sample_2d(seed, x) + +!*****************************************************************************80 +! +!! SPHERE01_SAMPLE_2D picks a random point on the unit sphere (circle) in 2D. +! +! Discussion: +! +! The unit sphere in 2D satisfies: +! +! X * X + Y * Y = 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(2), a random point on the unit circle. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) r8_uniform_01 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seed + real(kind=8) u + real(kind=8) x(dim_num) + + u = r8_uniform_01(seed) + + x(1) = cos(2.0D+00 * r8_pi * u) + x(2) = sin(2.0D+00 * r8_pi * u) + + return +end +subroutine sphere01_sample_3d(seed, x) + +!*****************************************************************************80 +! +!! SPHERE01_SAMPLE_3D picks a random point on the unit sphere in 3D. +! +! Discussion: +! +! The unit sphere in 3D satisfies: +! +! X * X + Y * Y + Z * Z = 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(3), the sample point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) r8_acos + real(kind=8) r8_uniform_01 + real(kind=8) phi + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seed + real(kind=8) theta + real(kind=8) vdot + real(kind=8) x(dim_num) +! +! Pick a uniformly random VDOT, which must be between -1 and 1. +! This represents the dot product of the random vector with the Z unit vector. +! +! Note: this works because the surface area of the sphere between +! Z and Z + dZ is independent of Z. So choosing Z uniformly chooses +! a patch of area uniformly. +! + vdot = r8_uniform_01(seed) + vdot = 2.0D+00 * vdot - 1.0D+00 + + phi = r8_acos(vdot) +! +! Pick a uniformly random rotation between 0 and 2 Pi around the +! axis of the Z vector. +! + theta = r8_uniform_01(seed) + theta = 2.0D+00 * r8_pi * theta + + x(1) = cos(theta) * sin(phi) + x(2) = sin(theta) * sin(phi) + x(3) = cos(phi) + + return +end +subroutine sphere01_sample_3d_2(seed, x) + +!*****************************************************************************80 +! +!! SPHERE01_SAMPLE_3D_2 is a BAD method for sampling the unit sphere in 3D. +! +! Discussion: +! +! The unit sphere in 3D satisfies: +! +! X * X + Y * Y + Z * Z = 1 +! +! Points on the unit sphere have coordinates ( PHI, THETA ) where +! PHI varies from 0 to PI, and THETA from 0 to 2 PI, so that: +! +! x = cos ( theta ) * sin ( phi ) +! y = sin ( theta ) * sin ( phi ) +! z = cos ( phi ) +! +! This routine implements a sampling of the sphere that simply +! picks PHI and THETA uniformly at random from their ranges. +! This is a uniform sampling on the cylinder, but it is NOT +! a uniform sampling on the sphere. I implement it here just +! so I can run some tests against the code in SPHERE_UNIT_SAMPLE_3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(3), the sample point. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) r8_uniform_01 + real(kind=8) phi + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + integer(kind=4) seed + real(kind=8) theta + real(kind=8) x(dim_num) + + phi = r8_uniform_01(seed) + phi = r8_pi * phi + + theta = r8_uniform_01(seed) + theta = 2.0D+00 * r8_pi * theta + + x(1) = cos(theta) * sin(phi) + x(2) = sin(theta) * sin(phi) + x(3) = cos(phi) + + return +end +subroutine sphere01_sample_nd(dim_num, seed, x) + +!*****************************************************************************80 +! +!! SPHERE01_SAMPLE_ND picks a random point on the unit sphere in ND. +! +! Discussion: +! +! The unit sphere in ND satisfies: +! +! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 +! +! DIM_NUM-1 random Givens rotations are applied to the point +! ( 1, 0, 0, ..., 0 ). +! +! The I-th Givens rotation is in the plane of coordinate axes I and I+1, +! and has the form: +! +! [ cos ( theta ) - sin ( theta ) ] * x(i) = x'(i) +! [ sin ( theta ) cos ( theta ) ] x(i+1) x'(i+1) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(DIM_NUM), the random point. +! + implicit none + + integer(kind=4) dim_num + + integer(kind=4) i + real(kind=8) r8_uniform_01 + real(kind=8) random_cosine + real(kind=8) random_sign + real(kind=8) random_sine + integer(kind=4) seed + real(kind=8) x(dim_num) + real(kind=8) xi + + x(1) = 1.0D+00 + x(2:dim_num) = 0.0D+00 + + do i = 1, dim_num - 1 + random_cosine = r8_uniform_01(seed) + random_cosine = 2.0D+00 * random_cosine - 1.0D+00 + random_sign = r8_uniform_01(seed) + random_sign = real(2 * int(2.0D+00 * random_sign) - 1, kind=8) + random_sine = random_sign * sqrt(1.0D+00 - random_cosine**2) + xi = x(i) + x(i) = random_cosine * xi + x(i + 1) = random_sine * xi + end do + + return +end +subroutine sphere01_sample_nd_2(dim_num, seed, x) + +!*****************************************************************************80 +! +!! SPHERE01_SAMPLE_ND_2 picks a random point on the unit sphere in ND. +! +! Discussion: +! +! The unit sphere in ND satisfies: +! +! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 +! +! DIM_NUM independent normally distributed random numbers are generated, +! and then scaled to have unit norm. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(DIM_NUM), the random point. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) norm + integer(kind=4) seed + real(kind=8) x(dim_num) + + call r8vec_normal_01(dim_num, seed, x) + + norm = sqrt(sum(x(1:dim_num)**2)) + + x(1:dim_num) = x(1:dim_num) / norm + + return +end +subroutine sphere01_sample_nd_3(dim_num, seed, x) + +!*****************************************************************************80 +! +!! SPHERE01_SAMPLE_ND_3 picks a random point on the unit sphere in ND. +! +! Discussion: +! +! The unit sphere in ND satisfies: +! +! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 +! +! Points in the [-1,1] cube are generated. Points lying outside +! the sphere are rejected. Points inside the unit sphere are normalized +! to lie on the sphere. +! +! Because the volume of the unit sphere +! relative to the unit cube decreases drastically in higher dimensions, +! this routine becomes increasingly inefficient at higher DIM_NUM. +! Above DIM_NUM = 5, this problem will become significant. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(DIM_NUM), the random point. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) norm + integer(kind=4) seed + real(kind=8) x(dim_num) + + do + + call r8vec_uniform_01(dim_num, seed, x) + + x(1:dim_num) = 2.0D+00 * x(1:dim_num) - 1.0D+00 + + norm = sqrt(sum(x(1:dim_num)**2)) + + if (norm <= 1.0E00) then + x(1:dim_num) = x(1:dim_num) / norm + exit + end if + + end do + + return +end +function sphere01_volume_nd(dim_num) + +!*****************************************************************************80 +! +!! SPHERE01_VOLUME_ND computes the volume of a unit sphere in ND. +! +! Discussion: +! +! The unit sphere in ND satisfies: +! +! sum ( 1 <= I <= DIM_NUM ) X(I) * X(I) = 1 +! +! Results for the first few values of DIM_NUM are: +! +! DIM_NUM Volume +! +! 1 2 +! 2 1 * PI +! 3 ( 4 / 3) * PI +! 4 ( 1 / 2) * PI^2 +! 5 ( 8 / 15) * PI^2 +! 6 ( 1 / 6) * PI^3 +! 7 (16 / 105) * PI^3 +! 8 ( 1 / 24) * PI^4 +! 9 (32 / 945) * PI^4 +! 10 ( 1 / 120) * PI^5 +! +! For the unit sphere, Volume(DIM_NUM) = 2 * PI * Volume(DIM_NUM-2)/ DIM_NUM +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Output, real ( kind = 8 ) SPHERE_UNIT_VOLUME_ND, the volume of the sphere. +! + implicit none + + integer(kind=4) dim_num + integer(kind=4) i + integer(kind=4) m + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) sphere01_volume_nd + real(kind=8) volume + + if (mod(dim_num, 2) == 0) then + m = dim_num / 2 + volume = r8_pi**m + do i = 1, m + volume = volume / real(i, kind=8) + end do + else + m = (dim_num - 1) / 2 + volume = r8_pi**m * 2.0D+00**dim_num + do i = m + 1, 2 * m + 1 + volume = volume / real(i, kind=8) + end do + end if + + sphere01_volume_nd = volume + + return +end +subroutine sphere01_volume_values(n_data, n, volume) + +!*****************************************************************************80 +! +!! SPHERE01_VOLUME_VALUES returns some volumes of the unit sphere in ND. +! +! Discussion: +! +! The formula for the volume of the unit sphere in N dimensions is +! +! Volume(N) = 2 * pi^(N/2) / ( N * Gamma ( N / 2 ) ) +! +! This function satisfies the relationships: +! +! Volume(N) = 2 * pi * Volume(N-2) / N +! Volume(N) = Area(N) / N +! +! Some values of the function include: +! +! N Volume +! +! 1 1 +! 2 1 * PI +! 3 ( 4 / 3) * PI +! 4 ( 1 / 2) * PI^2 +! 5 ( 8 / 15) * PI^2 +! 6 ( 1 / 6) * PI^3 +! 7 (16 / 105) * PI^3 +! 8 ( 1 / 24) * PI^4 +! 9 (32 / 945) * PI^4 +! 10 ( 1 / 120) * PI^5 +! +! In Mathematica, the function can be evaluated by: +! +! 2 * Pi^(n/2) / ( n * Gamma[n/2] ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 August 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, integer ( kind = 4 ) N, the spatial dimension. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the unit +! sphere in that dimension. +! + implicit none + + integer(kind=4), parameter :: n_max = 20 + + integer(kind=4) n_data + integer(kind=4) n + integer(kind=4), save, dimension(n_max) :: n_vec = (/ & + 1, 2, & + 3, 4, & + 5, 6, & + 7, 8, & + 9, 10, & + 11, 12, & + 13, 14, & + 15, 16, & + 17, 18, & + 19, 20/) + real(kind=8) volume + real(kind=8), save, dimension(n_max) :: volume_vec = (/ & + 0.2000000000000000D+01, & + 0.3141592653589793D+01, & + 0.4188790204786391D+01, & + 0.4934802200544679D+01, & + 0.5263789013914325D+01, & + 0.5167712780049970D+01, & + 0.4724765970331401D+01, & + 0.4058712126416768D+01, & + 0.3298508902738707D+01, & + 0.2550164039877345D+01, & + 0.1884103879389900D+01, & + 0.1335262768854589D+01, & + 0.9106287547832831D+00, & + 0.5992645293207921D+00, & + 0.3814432808233045D+00, & + 0.2353306303588932D+00, & + 0.1409811069171390D+00, & + 0.8214588661112823D-01, & + 0.4662160103008855D-01, & + 0.2580689139001406D-01/) + + if (n_data < 0) then + n_data = 0 + end if + + n_data = n_data + 1 + + if (n_max < n_data) then + n_data = 0 + n = 0 + volume = 0.0D+00 + else + n = n_vec(n_data) + volume = volume_vec(n_data) + end if + + return +end +subroutine sphere01_distance_xyz(xyz1, xyz2, dist) + +!*****************************************************************************80 +! +!! SPHERE01_DISTANCE_XYZ computes great circle distances on a unit sphere. +! +! Discussion: +! +! XYZ coordinates are used. +! +! We assume the points XYZ1 and XYZ2 lie on the unit sphere. +! +! This computation is a special form of the Vincenty formula. +! It should be less sensitive to errors associated with very small +! or very large angular separations. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 August 2010 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! "Great-circle distance", +! Wikipedia. +! +! Parameters: +! +! Input, real ( kind = 8 ) XYZ1(3), the coordinates of the first point. +! +! Input, real ( kind = 8 ) XYZ2(3), the coordinates of the second point. +! +! Output, real ( kind = 8 ) DIST, the great circle distance between +! the points. +! + implicit none + + real(kind=8) bot + real(kind=8) dist + real(kind=8) lat1 + real(kind=8) lat2 + real(kind=8) lon1 + real(kind=8) lon2 + real(kind=8) r8_asin + real(kind=8) r8_atan + real(kind=8) top + real(kind=8) xyz1(3) + real(kind=8) xyz2(3) + + lat1 = r8_asin(xyz1(3)) + lon1 = r8_atan(xyz1(2), xyz1(1)) + + lat2 = r8_asin(xyz2(3)) + lon2 = r8_atan(xyz2(2), xyz2(1)) + + top = (cos(lat2) * sin(lon1 - lon2))**2 & + + (cos(lat1) * sin(lat2) & + - sin(lat1) * cos(lat2) * cos(lon1 - lon2))**2 + + top = sqrt(top) + + bot = sin(lat1) * sin(lat2) & + + cos(lat1) * cos(lat2) * cos(lon1 - lon2) + + dist = atan2(top, bot) + + return +end +function sphere01_polygon_area(n, lat, lon) + +!*****************************************************************************80 +! +!! SPHERE01_POLYGON_AREA returns the area of a spherical polygon. +! +! Discussion: +! +! On a unit sphere, the area of a spherical polygon with N sides +! is equal to the spherical excess: +! +! E = sum ( interior angles ) - ( N - 2 ) * pi. +! +! On a sphere with radius R, the area is the spherical excess multiplied +! by R * R. +! +! The code was revised in accordance with suggestions in Carvalho and +! Cavalcanti. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 August 2005 +! +! Author: +! +! Original C version by Robert Miller. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, +! Point in Polyhedron Testing Using Spherical Polygons, +! in Graphics Gems V, +! edited by Alan Paeth, +! Academic Press, 1995, +! ISBN: 0125434553, +! LC: T385.G6975. +! +! Robert Miller, +! Computing the Area of a Spherical Polygon, +! Graphics Gems, Volume IV, pages 132-138, +! Edited by Paul Heckbert, +! Academic Press, 1994, T385.G6974. +! +! Eric Weisstein, +! "Spherical Polygon", +! CRC Concise Encyclopedia of Mathematics, +! CRC Press, 1999. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices. +! +! Input, real ( kind = 8 ) LAT[N], LON[N], the latitudes and longitudes +! of the vertices of the spherical polygon. +! +! Output, real ( kind = 8 ) SPHERE01_POLYGON_AREA, the area of the +! spherical polygon, measured in spherical radians. +! + implicit none + + integer(kind=4) n + + real(kind=8) a + real(kind=8) area + real(kind=8) b + real(kind=8) beta1 + real(kind=8) beta2 + real(kind=8) c + real(kind=8) cos_b1 + real(kind=8) cos_b2 + real(kind=8) excess + real(kind=8) hav_a + real(kind=8) haversine + integer(kind=4) j + integer(kind=4) k + real(kind=8) lam + real(kind=8) lam1 + real(kind=8) lam2 + real(kind=8) lat(n) + real(kind=8) lon(n) + real(kind=8), parameter :: r8_pi_half = 1.5707963267948966192313D+00 + real(kind=8) s + real(kind=8) sphere01_polygon_area + real(kind=8) t + + area = 0.0D+00 + + do j = 1, n + 1 + + if (j == 1) then + lam1 = lon(j) + beta1 = lat(j) + lam2 = lon(j + 1) + beta2 = lat(j + 1) + cos_b1 = cos(beta1) + cos_b2 = cos(beta2) + else + k = mod(j + 1, n + 1) + lam1 = lam2 + beta1 = beta2 + lam2 = lon(k) + beta2 = lat(k) + cos_b1 = cos_b2 + cos_b2 = cos(beta2) + end if + + if (lam1 /= lam2) then + + hav_a = haversine(beta2 - beta1) & + + cos_b1 * cos_b2 * haversine(lam2 - lam1) + a = 2.0D+00 * asin(sqrt(hav_a)) + + b = r8_pi_half - beta2 + c = r8_pi_half - beta1 + s = 0.5D+00 * (a + b + c) +! +! Given the three sides of a spherical triangle, we can use a formula +! to find the spherical excess. +! + t = tan(s / 2.0D+00) * tan((s - a) / 2.0D+00) & + * tan((s - b) / 2.0D+00) * tan((s - c) / 2.0D+00) + + excess = abs(4.0D+00 * atan(sqrt(abs(t)))) + + if (lam1 < lam2) then + lam = lam2 - lam1 + else + lam = lam2 - lam1 + 4.0D+00 * r8_pi_half + end if + + if (2.0D+00 * r8_pi_half < lam) then + excess = -excess + end if + + area = area + excess + + end if + + end do + + sphere01_polygon_area = abs(area) + + return +end +subroutine sphere01_triangle_angles_to_area(a, b, c, area) + +!*****************************************************************************80 +! +!! SPHERE01_TRIANGLE_ANGLES_TO_AREA computes the area of a spherical triangle. +! +! Discussion: +! +! A unit sphere in 3D satisfies the equation: +! +! X^2 + Y^2 + Z^2 = 1 +! +! A spherical triangle is specified by three points on the surface +! of the sphere. +! +! The area formula is known as Girard's formula. +! +! The area of a spherical triangle on a unit sphere is: +! +! AREA = ( A + B + C - PI ) +! +! where A, B and C are the (surface) angles of the triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, the angles of the triangle. +! +! Output, real ( kind = 8 ) AREA, the area of the sphere. +! + implicit none + + real(kind=8) area + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 +! +! Apply Girard's formula. +! + area = a + b + c - r8_pi + + return +end +subroutine sphere01_triangle_sides_to_angles(as, bs, cs, a, b, c) + +!*****************************************************************************80 +! +!! SPHERE01_TRIANGLE_SIDES_TO_ANGLES computes spherical triangle angles. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the +! sides of the triangle. +! +! Output, real ( kind = 8 ) A, B, C, the spherical angles of the triangle. +! Angle A is opposite the side of length AS, and so on. +! + implicit none + + real(kind=8) a + real(kind=8) as + real(kind=8) asu + real(kind=8) b + real(kind=8) bs + real(kind=8) bsu + real(kind=8) c + real(kind=8) cs + real(kind=8) csu + real(kind=8) ssu + real(kind=8) tan_a2 + real(kind=8) tan_b2 + real(kind=8) tan_c2 + + asu = as + bsu = bs + csu = cs + ssu = (asu + bsu + csu) / 2.0D+00 + + tan_a2 = sqrt((sin(ssu - bsu) * sin(ssu - csu)) / & + (sin(ssu) * sin(ssu - asu))) + + a = 2.0D+00 * atan(tan_a2) + + tan_b2 = sqrt((sin(ssu - asu) * sin(ssu - csu)) / & + (sin(ssu) * sin(ssu - bsu))) + + b = 2.0D+00 * atan(tan_b2) + + tan_c2 = sqrt((sin(ssu - asu) * sin(ssu - bsu)) / & + (sin(ssu) * sin(ssu - csu))) + + c = 2.0D+00 * atan(tan_c2) + + return +end +subroutine sphere01_triangle_vertices_to_angles(v1, v2, v3, a, b, c) + +!*****************************************************************************80 +! +!! SPHERE01_TRIANGLE_VERTICES_TO_ANGLES: spherical triangle angles by vertices. +! +! Discussion: +! +! A unit sphere centered at 0 in 3D satisfies the equation: +! +! X * X + Y * Y + Z * Z = 1 +! +! A spherical triangle is specified by three points on the surface +! of the sphere. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 September 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. +! +! Output, real ( kind = 8 ) A, B, C, the angles of the spherical triangle. +! + implicit none + + real(kind=8) a + real(kind=8) as + real(kind=8) b + real(kind=8) bs + real(kind=8) c + real(kind=8) cs + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) +! +! Compute the lengths of the sides of the spherical triangle. +! + call sphere01_triangle_vertices_to_sides(v1, v2, v3, as, bs, cs) +! +! Get the spherical angles. +! + call sphere01_triangle_sides_to_angles(as, bs, cs, a, b, c) + + return +end +subroutine sphere01_triangle_vertices_to_area(v1, v2, v3, area) + +!*****************************************************************************80 +! +!! SPHERE01_TRIANGLE_VERTICES_TO_AREA computes the area of a spherical triangle. +! +! Discussion: +! +! A unit sphere in 3D satisfies the equation: +! +! X^2 + Y^2 + Z^2 = 1 +! +! A spherical triangle is specified by three points on the surface +! of the sphere. +! +! The area formula is known as Girard's formula. +! +! The area of a spherical triangle on a unit sphere is: +! +! AREA = ( A + B + C - PI ) +! +! where A, B and C are the (surface) angles of the triangle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. +! +! Output, real ( kind = 8 ) AREA, the area of the sphere. +! + implicit none + + real(kind=8) area + real(kind=8) a + real(kind=8) as + real(kind=8) b + real(kind=8) bs + real(kind=8) c + real(kind=8) cs + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) +! +! Compute the lengths of the sides of the spherical triangle. +! + call sphere01_triangle_vertices_to_sides(v1, v2, v3, as, bs, cs) +! +! Get the spherical angles. +! + call sphere01_triangle_sides_to_angles(as, bs, cs, a, b, c) +! +! Get the area. +! + call sphere01_triangle_angles_to_area(a, b, c, area) + + return +end +subroutine sphere01_triangle_vertices_to_centroid(v1, v2, v3, vs) + +!*****************************************************************************80 +! +!! SPHERE01_TRIANGLE_VERTICES_TO_CENTROID gets a spherical triangle "centroid". +! +! Discussion: +! +! A unit sphere in 3D satisfies the equation: +! +! X^2 + Y^2 + Z^2 = 1 +! +! A spherical triangle is specified by three points on the sphere. +! +! The (true) centroid of a spherical triangle is the point +! +! VT = (XT,YT,ZT) = Integral ( X, Y, Z ) dArea / Integral 1 dArea +! +! Note that the true centroid does NOT, in general, lie on the sphere. +! +! The "flat" centroid VF is the centroid of the planar triangle defined by +! the vertices of the spherical triangle. +! +! The "spherical" centroid VS of a spherical triangle is computed by +! the intersection of the geodesic bisectors of the triangle angles. +! The spherical centroid lies on the sphere. +! +! VF, VT and VS lie on a line through the center of the sphere. We can +! easily calculate VF by averaging the vertices, and from this determine +! VS by normalizing. +! +! (Of course, we still will not have actually computed VT, which lies +! somewhere between VF and VS!) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. +! +! Output, real ( kind = 8 ) VS(3), the coordinates of the "spherical +! centroid" of the spherical triangle. +! + implicit none + + real(kind=8) norm + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + real(kind=8) vs(3) + + vs(1:3) = (v1(1:3) + v2(1:3) + v3(1:3)) / 3.0D+00 + + norm = sqrt(sum(vs(1:3)**2)) + + vs(1:3) = vs(1:3) / norm + + return +end +subroutine sphere01_triangle_vertices_to_midpoints(v1, v2, v3, m1, m2, m3) + +!*****************************************************************************80 +! +!! SPHERE01_TRIANGLE_VERTICES_TO_MIDPOINTS: midsides of a spherical triangle. +! +! Discussion: +! +! The points are assumed to lie on the unit sphere. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the triangle. +! +! Output, real ( kind = 8 ) M1(3), M2(3), M3(3), the coordinates of +! the midpoints of the sides of the spherical triangle. +! + implicit none + + real(kind=8) m1(3) + real(kind=8) m2(3) + real(kind=8) m3(3) + real(kind=8) norm + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + + m1(1:3) = (v1(1:3) + v2(1:3)) / 2.0D+00 + norm = sqrt(sum(m1(1:3)**2)) + m1(1:3) = m1(1:3) / norm + + m2(1:3) = (v2(1:3) + v3(1:3)) / 2.0D+00 + norm = sqrt(sum(m2(1:3)**2)) + m2(1:3) = m2(1:3) / norm + + m3(1:3) = (v3(1:3) + v1(1:3)) / 2.0D+00 + norm = sqrt(sum(m3(1:3)**2)) + m3(1:3) = m3(1:3) / norm + + return +end +subroutine sphere01_triangle_vertices_to_sides(v1, v2, v3, as, bs, cs) + +!*****************************************************************************80 +! +!! SPHERE01_TRIANGLE_VERTICES_TO_SIDES computes spherical triangle sides. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 June 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the vertices of the spherical +! triangle. +! +! Output, real ( kind = 8 ) AS, BS, CS, the (geodesic) length of the +! sides of the triangle. +! + implicit none + + real(kind=8) as + real(kind=8) bs + real(kind=8) cs + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) v3(3) + + as = acos(dot_product(v2(1:3), v3(1:3))) + bs = acos(dot_product(v3(1:3), v1(1:3))) + cs = acos(dot_product(v1(1:3), v2(1:3))) + + return +end +subroutine string_2d(nvec, p1, p2, string_num, order, string) + +!*****************************************************************************80 +! +!! STRING_2D groups line segments into connected lines in 2D. +! +! Discussion: +! +! The routine receives an unordered set of line segments, described by +! pairs of coordinates P1 and P2, and tries to group them +! into ordered lists that constitute connected jagged lines. +! +! This routine will not match two endpoints unless they are exactly equal. +! +! On input, line segment I has endpoints P1(I), P2(I). +! +! On output, the order of the components may have been switched. +! That is, for some I, P1(I) and P2(I) may have been swapped. +! +! More importantly, both points P1(I) and P2(I) may have been swapped +! with another pair P1(J), P2(J). +! +! The resulting coordinates will have been sorted in order +! of the string to which they belong, and then by the order +! of their traversal within that string. +! +! The array STRING(I) identifies the string to which segment I belongs. +! +! If two segments I and J have the same value of STRING, then +! ORDER(I) and ORDER(J) give the relative order of the two segments +! in the string. Thus if ORDER(I) = -3 and ORDER(J) = 2, then when +! the string is traversed, segment I is traversed first, then four other +! segments are traversed, and then segment J is traversed. +! +! For each string, the segment with ORDER(I) = 0 is the initial segment +! from which the entire string was "grown" (with growth possible to both the +! left and the right). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) NVEC, the number of line segments to be +! analyzed. +! +! Input/output, real ( kind = 8 ) P1(2,NVEC), P2VEC(2,NVEC), the +! line segments. +! +! Output, integer ( kind = 4 ) ORDER(NVEC), the order vector. +! +! Output, integer ( kind = 4 ) STRING(NVEC), the string to which each +! segment belongs. +! +! Output, integer ( kind = 4 ) STRING_NUM, the number of strings created. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + integer(kind=4) nvec + + integer(kind=4) i + integer(kind=4) indx + integer(kind=4) isgn + integer(kind=4) j + integer(kind=4) jval + integer(kind=4) kval + integer(kind=4) match + integer(kind=4) order(nvec) + real(kind=8) p1(dim_num, nvec) + real(kind=8) p2(dim_num, nvec) + integer(kind=4) seed + integer(kind=4) string(nvec) + integer(kind=4) string_num + real(kind=8) x1val + real(kind=8) x2val + real(kind=8) y1val + real(kind=8) y2val +! +! Mark STRING so that each segment is alone. +! + order(1:nvec) = 0 + string(1:nvec) = nvec + i +! +! Starting with the lowest numbered group of line segments, +! see if any higher numbered groups belong. +! + seed = 1 + string_num = 1 + string(seed) = string_num + + do + + x1val = p1(1, seed) + y1val = p1(2, seed) + + x2val = p2(1, seed) + y2val = p2(2, seed) + + jval = order(seed) + kval = order(seed) + + do + + match = 0 + + do j = 1, nvec + + if (string_num < string(j)) then + + if (x1val == p1(1, j) .and. y1val == p1(2, j)) then + + jval = jval - 1 + order(j) = jval + string(j) = string_num + x1val = p2(1, j) + y1val = p2(2, j) + match = match + 1 + + call r8_swap(p1(1, j), p2(1, j)) + call r8_swap(p1(2, j), p2(2, j)) + + else if (x1val == p2(1, j) .and. y1val == p2(2, j)) then + + jval = jval - 1 + order(j) = jval + string(j) = string_num + x1val = p1(1, j) + y1val = p1(2, j) + match = match + 1 + + else if (x2val == p1(1, j) .and. y2val == p1(2, j)) then + + kval = kval + 1 + order(j) = kval + string(j) = string_num + x2val = p2(1, j) + y2val = p2(2, j) + match = match + 1 + + else if (x2val == p2(1, j) .and. y2val == p2(2, j)) then + + kval = kval + 1 + order(j) = kval + string(j) = string_num + x2val = p1(1, j) + y2val = p1(2, j) + match = match + 1 + + call r8_swap(p1(1, j), p2(1, j)) + call r8_swap(p1(2, j), p2(2, j)) + + end if + + end if + + end do +! +! If the string has closed on itself, then we don't want to +! look for any more matches for this string. +! + if (x1val == x2val .and. y1val == y2val) then + exit + end if +! +! If we made no matches this pass, we're done. +! + if (match <= 0) then + exit + end if + + end do +! +! This string is "exhausted". Are there any line segments we +! haven't looked at yet? +! + seed = 0 + + do i = 1, nvec + if (string_num < string(i)) then + seed = i + string_num = string_num + 1 + string(i) = string_num + exit + end if + end do + + if (seed == 0) then + exit + end if + + end do +! +! There are no more line segments to look at. Renumber the +! isolated segments. +! +! Question: Can this ever happen? +! + do i = 1, nvec + if (nvec < string(i)) then + string_num = string_num + 1 + string(i) = string_num + end if + end do +! +! Now sort the line segments by string and by order of traversal. +! + i = 0 + isgn = 0 + j = 0 + + indx = 0 + + do + + call sort_heap_external(nvec, indx, i, j, isgn) + + if (0 < indx) then + + call i4_swap(order(i), order(j)) + call i4_swap(string(i), string(j)) + call r8_swap(p1(1, i), p1(1, j)) + call r8_swap(p1(2, i), p1(2, j)) + call r8_swap(p2(1, i), p2(1, j)) + call r8_swap(p2(2, i), p2(2, j)) + + else if (indx < 0) then + + if ((string(i) < string(j)) .or. & + (string(i) == string(j) .and. order(i) < order(j))) then + + isgn = -1 + + else + + isgn = +1 + + end if + + else if (indx == 0) then + + exit + + end if + + end do + + return +end +subroutine super_ellipse_points_2d(pc, r1, r2, expo, psi, n, p) + +!*****************************************************************************80 +! +!! SUPER_ELLIPSE_POINTS_2D returns N points on a tilted superellipse in 2D. +! +! Discussion: +! +! The points are "equally spaced" in the angular sense. They are +! not equally spaced along the perimeter. +! +! The parametric formula of the (untilted) superellipse is: +! +! X = R1 * cos^EXPO ( THETA ) +! Y = R2 * sin^EXPO ( THETA ) +! +! An implicit form of the (untilted) superellipse is: +! +! (X/R1)^(2/EXPO) + (Y/R2)^(2/EXPO) = 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 January 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Martin Gardner, +! The Mathematical Carnival, +! Knopf, 1975, pages 240-254. +! +! Parameters: +! +! Input, real ( kind = 8 ) PC(2), the center of the superellipse. +! +! Input, real ( kind = 8 ) R1, R2, the "radius" of the superellipse +! in the major and minor axis directions. A circle has these values equal. +! +! Input, real ( kind = 8 ) EXPO, the exponent of the superellipse. +! 0 = a rectangle; +! between 0 and 1, a "rounded" rectangle; +! 1.0 = an ellipse; +! 2.0 = a diamond; +! > 2.0 a pinched shape. +! +! Input, real ( kind = 8 ) PSI, the angle that the major axis of the +! superellipse makes with the X axis. A value of 0.0 means that the +! major and minor axes of the superellipse will be the X and Y +! coordinate axes. +! +! Input, integer ( kind = 4 ) N, the number of points desired. N must +! be at least 1. +! +! Output, real ( kind = 8 ) P(2,N), the coordinates of points +! on the superellipse. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) act + real(kind=8) ast + integer(kind=4) i + real(kind=8) expo + real(kind=8) p(dim_num, n) + real(kind=8) pc(dim_num) + real(kind=8) psi + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) sct + real(kind=8) sst + real(kind=8) theta + + do i = 1, n + + theta = (2.0D+00 * r8_pi * real(i - 1, kind=8)) & + / real(n, kind=8) + + act = abs(cos(theta)) + sct = sign(1.0D+00, cos(theta)) + ast = abs(sin(theta)) + sst = sign(1.0D+00, sin(theta)) + + p(1, i) = pc(1) + r1 * cos(psi) * sct * (act)**expo & + - r2 * sin(psi) * sst * (ast)**expo + + p(2, i) = pc(2) + r1 * sin(psi) * sct * (act)**expo & + + r2 * cos(psi) * sst * (ast)**expo + + end do + + return +end +subroutine tetrahedron_barycentric_3d(tetra, p, c) + +!*****************************************************************************80 +! +!! TETRAHEDRON_BARYCENTRIC_3D: barycentric coordinates of a point in 3D. +! +! Discussion: +! +! The barycentric coordinates of a point P with respect to +! a tetrahedron are a set of four values C(1:4), each associated +! with a vertex of the tetrahedron. The values must sum to 1. +! If all the values are between 0 and 1, the point is contained +! within the tetrahedron. +! +! The barycentric coordinate of point P related to vertex A can be +! interpreted as the ratio of the volume of the tetrahedron with +! vertex A replaced by vertex P to the volume of the original +! tetrahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. +! +! Input, real ( kind = 8 ) P(3), the point to be checked. +! +! Output, real ( kind = 8 ) C(4), the barycentric coordinates of P with +! respect to the tetrahedron. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4), parameter :: rhs_num = 1 + + real(kind=8) a(dim_num, dim_num + rhs_num) + real(kind=8) c(dim_num + 1) + integer(kind=4) i + integer(kind=4) info + real(kind=8) p(dim_num) + real(kind=8) tetra(dim_num, 4) +! +! Set up the linear system +! +! ( X2-X1 X3-X1 X4-X1 ) C2 X - X1 +! ( Y2-Y1 Y3-Y1 Y4-Y1 ) C3 = Y - Y1 +! ( Z2-Z1 Z3-Z1 Z4-Z1 ) C4 Z - Z1 +! +! which is satisfied by the barycentric coordinates of P. +! + a(1:dim_num, 1:3) = tetra(1:dim_num, 2:4) + a(1:dim_num, 4) = p(1:dim_num) + + do i = 1, dim_num + a(i, 1:4) = a(i, 1:4) - tetra(i, 1) + end do +! +! Solve the linear system. +! + call r8mat_solve(dim_num, rhs_num, a, info) + + if (info /= 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'TETRAHEDRON_BARYCENTRIC_3D - Fatal error!' + write (*, '(a)') ' The linear system is singular.' + write (*, '(a)') ' The input data does not form a proper tetrahedron.' + stop 1 + end if + + c(2:4) = a(1:dim_num, 4) + + c(1) = 1.0D+00 - sum(c(2:4)) + + return +end +subroutine tetrahedron_centroid_3d(tetra, centroid) + +!*****************************************************************************80 +! +!! TETRAHEDRON_CENTROID_3D computes the centroid of a tetrahedron in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. +! +! Output, real ( kind = 8 ) CENTROID(3), the coordinates of the centroid. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) centroid(dim_num) + integer(kind=4) i + real(kind=8) tetra(dim_num, 4) + + do i = 1, dim_num + centroid(i) = sum(tetra(i, 1:4)) / 4.0D+00 + end do + + return +end +subroutine tetrahedron_circumsphere_3d(tetra, r, pc) + +!*****************************************************************************80 +! +!! TETRAHEDRON_CIRCUMSPHERE_3D computes the circumsphere of a tetrahedron in 3D. +! +! Discussion: +! +! The circumsphere, or circumscribed sphere, of a tetrahedron is the +! sphere that passes through the four vertices. The circumsphere is +! not necessarily the smallest sphere that contains the tetrahedron. +! +! Surprisingly, the diameter of the sphere can be found by solving +! a 3 by 3 linear system. This is because the vectors P2 - P1, +! P3 - P1 and P4 - P1 are secants of the sphere, and each forms a +! right triangle with the diameter through P1. Hence, the dot product of +! P2 - P1 with that diameter is equal to the square of the length +! of P2 - P1, and similarly for P3 - P1 and P4 - P1. This determines +! the diameter vector originating at P1, and hence the radius and +! center. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 August 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Adrian Bowyer, John Woodwark, +! A Programmer's Geometry, +! Butterworths, 1983, +! ISBN: 0408012420. +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. +! +! Output, real ( kind = 8 ) R, PC(3), the center of the +! circumscribed sphere, and its radius. If the linear system is +! singular, then R = -1, PC(1:3) = 0. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4), parameter :: rhs_num = 1 + + real(kind=8) a(dim_num, dim_num + rhs_num) + integer(kind=4) i + integer(kind=4) info + integer(kind=4) j + real(kind=8) pc(dim_num) + real(kind=8) r + real(kind=8) tetra(dim_num, 4) +! +! Set up the linear system. +! + a(1:dim_num, 1:3) = transpose(tetra(1:dim_num, 2:4)) + + do j = 1, dim_num + a(1:dim_num, j) = a(1:dim_num, j) - tetra(j, 1) + end do + + do i = 1, 3 + a(i, 4) = sum(a(i, 1:3)**2) + end do +! +! Solve the linear system. +! + call r8mat_solve(dim_num, rhs_num, a, info) +! +! If the system was singular, return a consolation prize. +! + if (info /= 0) then + r = -1.0D+00 + pc(1:dim_num) = 0.0D+00 + return + end if +! +! Compute the radius and center. +! + r = 0.5D+00 * sqrt(sum(a(1:dim_num, 4)**2)) + + pc(1:dim_num) = tetra(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, 4) + + return +end +subroutine tetrahedron_contains_point_3d(tetra, p, inside) + +!*****************************************************************************80 +! +!! TETRAHEDRON_CONTAINS_POINT_3D finds if a point is inside a tetrahedron in 3D. +! +! Discussion: +! +! We compute the barycentric coordinates C(1:4) of the point, with respect +! to the tetrahedron. The point is inside the tetrahedron if and only +! if each coordinate is nonnegative, and their sum is no greater than 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. +! +! Input, real ( kind = 8 ) P(3), the point to be checked. +! +! Output, logical ( kind = 4 ) INSIDE, is TRUE if P is inside the +! tetrahedron. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) c(dim_num + 1) + logical(kind=4) inside + real(kind=8) p(dim_num) + real(kind=8) tetra(dim_num, 4) + + call tetrahedron_barycentric_3d(tetra, p, c) +! +! If the point is in the tetrahedron, its barycentric coordinates +! must be nonnegative. +! + if (any(c(1:dim_num + 1) < 0.0D+00)) then + inside = .false. + else + inside = .true. + end if + + return +end +subroutine tetrahedron_dihedral_angles_3d(tetra, angle) + +!*****************************************************************************80 +! +!! TETRAHEDRON_DIHEDRAL_ANGLES_3D computes dihedral angles of a tetrahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron, +! which can be labeled as A, B, C and D. +! +! Output, real ( kind = 8 ) ANGLE(6), the dihedral angles along the +! axes AB, AC, AD, BC, BD and CD, respectively. +! + implicit none + + real(kind=8) ab(3) + real(kind=8) abc_normal(3) + real(kind=8) abd_normal(3) + real(kind=8) ac(3) + real(kind=8) acd_normal(3) + real(kind=8) ad(3) + real(kind=8) angle(6) + real(kind=8) bc(3) + real(kind=8) bcd_normal(3) + real(kind=8) bd(3) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) tetra(3, 4) + + ab(1:3) = tetra(1:3, 2) - tetra(1:3, 1) + ac(1:3) = tetra(1:3, 3) - tetra(1:3, 1) + ad(1:3) = tetra(1:3, 4) - tetra(1:3, 1) + bc(1:3) = tetra(1:3, 3) - tetra(1:3, 2) + bd(1:3) = tetra(1:3, 4) - tetra(1:3, 2) + + call r8vec_cross_product_3d(ac, ab, abc_normal) + call r8vec_cross_product_3d(ab, ad, abd_normal) + call r8vec_cross_product_3d(ad, ac, acd_normal) + call r8vec_cross_product_3d(bc, bd, bcd_normal) + + call r8vec_angle_3d(abc_normal, abd_normal, angle(1)) + call r8vec_angle_3d(abc_normal, acd_normal, angle(2)) + call r8vec_angle_3d(abd_normal, acd_normal, angle(3)) + call r8vec_angle_3d(abc_normal, bcd_normal, angle(4)) + call r8vec_angle_3d(abd_normal, bcd_normal, angle(5)) + call r8vec_angle_3d(acd_normal, bcd_normal, angle(6)) + + angle(1:6) = r8_pi - angle(1:6) + + return +end +subroutine tetrahedron_edge_length_3d(tetra, edge_length) + +!*****************************************************************************80 +! +!! TETRAHEDRON_EDGE_LENGTH_3D returns edge lengths of a tetrahedron in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. +! +! Output, real ( kind = 8 ) EDGE_LENGTH(6), the length of the edges. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) r8vec_norm + real(kind=8) edge_length(6) + integer(kind=4) j1 + integer(kind=4) j2 + integer(kind=4) k + real(kind=8) tetra(dim_num, 4) + + k = 0 + do j1 = 1, 3 + do j2 = j1 + 1, 4 + k = k + 1 + edge_length(k) = r8vec_norm(dim_num, & + tetra(1:dim_num, j2) - tetra(1:dim_num, j1)) + end do + end do + + return +end +subroutine tetrahedron_face_angles_3d(tetra, angles) + +!*****************************************************************************80 +! +!! TETRAHEDRON_FACE_ANGLES_3D returns the 12 face angles of a tetrahedron 3D. +! +! Discussion: +! +! The tetrahedron has 4 triangular faces. This routine computes the +! 3 planar angles associated with each face. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. +! +! Output, real ( kind = 8 ) ANGLES(3,4), the face angles. +! + implicit none + + real(kind=8) angles(3, 4) + real(kind=8) tri(3, 3) + real(kind=8) tetra(3, 4) +! +! Face 123 +! + tri(1:3, 1:3) = tetra(1:3, 1:3) + call triangle_angles_3d(tri, angles(1:3, 1)) +! +! Face 124 +! + tri(1:3, 1:2) = tetra(1:3, 1:2) + tri(1:3, 3) = tetra(1:3, 4) + call triangle_angles_3d(tri, angles(1:3, 2)) +! +! Face 134 +! + tri(1:3, 1) = tetra(1:3, 1) + tri(1:3, 2:3) = tetra(1:3, 3:4) + call triangle_angles_3d(tri, angles(1:3, 3)) +! +! Face 234 +! + tri(1:3, 1:3) = tetra(1:3, 2:4) + call triangle_angles_3d(tri, angles(1:3, 4)) + + return +end +subroutine tetrahedron_face_areas_3d(tetra, areas) + +!*****************************************************************************80 +! +!! TETRAHEDRON_FACE_AREAS_3D returns the 4 face areas of a tetrahedron 3D. +! +! Discussion: +! +! The tetrahedron has 4 triangular faces. This routine computes the +! area of each face. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4) the tetrahedron vertices. +! +! Output, real ( kind = 8 ) AREAS(4), the face areas. +! + implicit none + + real(kind=8) areas(4) + real(kind=8) tri(3, 3) + real(kind=8) tetra(3, 4) +! +! Face 123 +! + tri(1:3, 1:3) = tetra(1:3, 1:3) + call triangle_area_3d(tri, areas(1)) +! +! Face 124 +! + tri(1:3, 1:2) = tetra(1:3, 1:2) + tri(1:3, 3) = tetra(1:3, 4) + call triangle_area_3d(tri, areas(2)) +! +! Face 134 +! + tri(1:3, 1) = tetra(1:3, 1) + tri(1:3, 2:3) = tetra(1:3, 3:4) + call triangle_area_3d(tri, areas(3)) +! +! Face 234 +! + tri(1:3, 1:3) = tetra(1:3, 2:4) + call triangle_area_3d(tri, areas(4)) + + return +end +subroutine tetrahedron_insphere_3d(tetra, r, pc) + +!*****************************************************************************80 +! +!! TETRAHEDRON_INSPHERE_3D finds the insphere of a tetrahedron in 3D. +! +! Discussion: +! +! The insphere of a tetrahedron is the inscribed sphere, which touches +! each face of the tetrahedron at a single point. +! +! The points of contact are the centroids of the triangular faces +! of the tetrahedron. Therefore, the point of contact for a face +! can be computed as the average of the vertices of that face. +! +! The sphere can then be determined as the unique sphere through +! the four given centroids. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 August 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Philip Schneider, David Eberly, +! Geometric Tools for Computer Graphics, +! Elsevier, 2002, +! ISBN: 1558605940, +! LC: T385.G6974. +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. +! +! Output, real ( kind = 8 ) R, PC(3), the radius and the center +! of the sphere. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) b(4, 4) + real(kind=8) r8mat_det_4d + real(kind=8) r8vec_norm + real(kind=8) gamma + real(kind=8) l123 + real(kind=8) l124 + real(kind=8) l134 + real(kind=8) l234 + real(kind=8) n123(1:dim_num) + real(kind=8) n124(1:dim_num) + real(kind=8) n134(1:dim_num) + real(kind=8) n234(1:dim_num) + real(kind=8) pc(1:dim_num) + real(kind=8) r + real(kind=8) tetra(1:dim_num, 4) + real(kind=8) v21(1:dim_num) + real(kind=8) v31(1:dim_num) + real(kind=8) v41(1:dim_num) + real(kind=8) v32(1:dim_num) + real(kind=8) v42(1:dim_num) + real(kind=8) v43(1:dim_num) + + v21(1:dim_num) = tetra(1:dim_num, 2) - tetra(1:dim_num, 1) + v31(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 1) + v41(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 1) + v32(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 2) + v42(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 2) + v43(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 3) + + call r8vec_cross_product_3d(v21, v31, n123) + call r8vec_cross_product_3d(v41, v21, n124) + call r8vec_cross_product_3d(v31, v41, n134) + call r8vec_cross_product_3d(v42, v32, n234) + + l123 = r8vec_norm(dim_num, n123) + l124 = r8vec_norm(dim_num, n124) + l134 = r8vec_norm(dim_num, n134) + l234 = r8vec_norm(dim_num, n234) + + pc(1:dim_num) = (l234 * tetra(1:dim_num, 1) & + + l134 * tetra(1:dim_num, 2) & + + l124 * tetra(1:dim_num, 3) & + + l123 * tetra(1:dim_num, 4)) & + / (l234 + l134 + l124 + l123) + + b(1:dim_num, 1:4) = tetra(1:dim_num, 1:4) + b(4, 1:4) = 1.0D+00 + + gamma = abs(r8mat_det_4d(b)) + +! gamma = abs ( & +! ( tetra(1,2) * tetra(2,3) * tetra(3,4) & +! - tetra(1,3) * tetra(2,4) * tetra(3,2) & +! + tetra(1,4) * tetra(2,2) * tetra(3,3) ) & +! - ( tetra(1,1) * tetra(2,3) * tetra(3,4) & +! - tetra(1,3) * tetra(2,4) * tetra(3,1) & +! + tetra(1,4) * tetra(2,1) * tetra(3,3) ) & +! + ( tetra(1,1) * tetra(2,2) * tetra(3,4) & +! - tetra(1,2) * tetra(2,4) * tetra(3,1) & +! + tetra(1,4) * tetra(2,1) * tetra(3,2) ) & +! - ( tetra(1,1) * tetra(2,2) * tetra(3,3) & +! - tetra(1,2) * tetra(2,3) * tetra(3,1) & +! + tetra(1,3) * tetra(2,1) * tetra(3,2) ) ) + + r = gamma / (l234 + l134 + l124 + l123) + + return +end +subroutine tetrahedron_lattice_layer_point_next(c, v, more) + +!*****************************************************************************80 +! +!! TETRAHEDRON_LATTICE_LAYER_POINT_NEXT: next tetrahedron lattice layer point. +! +! Discussion: +! +! The tetrahedron lattice layer L is bounded by the lines +! +! 0 <= X, +! 0 <= Y, +! 0 <= Z, +! L - 1 < X / C(1) + Y / C(2) + Z/C(3) <= L. +! +! In particular, layer L = 0 always contains the single point (0,0). +! +! This function returns, one at a time, the points that lie within +! a given tetrahedron lattice layer. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) C(4), coefficients defining the +! lattice layer in entries 1 to 3, and the laver index in C(4). +! The coefficients should be positive, and C(4) must be nonnegative. +! +! Input/output, integer ( kind = 4 ) V(3). On first call for a given layer, +! the input value of V is not important. On a repeated call for the same +! layer, the input value of V should be the output value from the previous +! call. On output, V contains the next lattice layer point. +! +! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to +! indicate that this is the first call for a given layer. Thereafter, the +! input value should be the output value from the previous call. On output, +! MORE is TRUE if the returned value V is a new point. +! If the output value is FALSE, then no more points were found, +! and V was reset to 0, and the lattice layer has been exhausted. +! + implicit none + + integer(kind=4) c(4) + integer(kind=4) c1n + integer(kind=4) i4vec_lcm + integer(kind=4) lhs + logical(kind=4) more + integer(kind=4), parameter :: n = 3 + integer(kind=4) rhs1 + integer(kind=4) rhs2 + integer(kind=4) v(3) +! +! Treat layer C(N+1) = 0 specially. +! + if (c(n + 1) == 0) then + if (.not. more) then + v(1:n) = 0 + more = .true. + else + more = .false. + end if + return + end if +! +! Compute the first point. +! + if (.not. more) then + + v(1) = (c(n + 1) - 1) * c(1) + 1 + v(2:n) = 0 + more = .true. + + else + + c1n = i4vec_lcm(n, c) + + rhs1 = c1n * (c(n + 1) - 1) + rhs2 = c1n * c(n + 1) +! +! Can we simply increase X? +! + v(1) = v(1) + 1 + + lhs = (c1n / c(1)) * v(1) & + + (c1n / c(2)) * v(2) & + + (c1n / c(3)) * v(3) + + if (lhs <= rhs2) then +! +! No. Increase Y, and set X so we just exceed RHS1...if possible. +! + else + + v(2) = v(2) + 1 + + v(1) = (c(1) * (rhs1 - (c1n / c(2)) * v(2) & + - (c1n / c(3)) * v(3))) / c1n + v(1) = max(v(1), 0) + + lhs = (c1n / c(1)) * v(1) & + + (c1n / c(2)) * v(2) & + + (c1n / c(3)) * v(3) + + if (lhs <= rhs1) then + v(1) = v(1) + 1 + lhs = lhs + c1n / c(1) + end if +! +! We have increased Y by 1. Have we stayed below the upper bound? +! + if (lhs <= rhs2) then + + else +! +! No. Increase Z, and set X so we just exceed RHS1...if possible. +! + v(3) = v(3) + 1 + v(2) = 0 + v(1) = (c(1) * (rhs1 - (c1n / c(2)) * v(2) & + - (c1n / c(3)) * v(3))) / c1n + v(1) = max(v(1), 0) + + lhs = (c1n / c(1)) * v(1) & + + (c1n / c(2)) * v(2) & + + (c1n / c(3)) * v(3) + + if (lhs <= rhs1) then + v(1) = v(1) + 1 + lhs = lhs + c1n / c(1) + end if + + if (lhs <= rhs2) then + + else + more = .false. + v(1:n) = 0 + end if + + end if + end if + end if + + return +end +subroutine tetrahedron_lattice_point_next(c, v, more) + +!*****************************************************************************80 +! +!! TETRAHEDRON_LATTICE_POINT_NEXT returns the next tetrahedron lattice point. +! +! Discussion: +! +! The lattice tetrahedron is defined by the vertices: +! +! (0,0,0), (C(4)/C(1),0,0), (0,C(4)/C(2),0) and (0,0,C(4)/C(3)) +! +! The lattice tetrahedron is bounded by the lines +! +! 0 <= X, +! 0 <= Y +! 0 <= Z, +! X / C(1) + Y / C(2) + Z / C(3) <= C(4) +! +! Lattice points are listed one at a time, starting at the origin, +! with X increasing first. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) C(4), coefficients defining the +! lattice tetrahedron. These should be positive. +! +! Input/output, integer ( kind = 4 ) V(3). On first call, the input +! value is not important. On a repeated call, the input value should +! be the output value from the previous call. On output, V contains +! the next lattice point. +! +! Input/output, logical ( kind = 4 ) MORE. On input, set MORE to FALSE to +! indicate that this is the first call for a given tetrahedron. Thereafter, +! the input value should be the output value from the previous call. On +! output, MORE is TRUE if not only is the returned value V a lattice point, +! but the routine can be called again for another lattice point. +! If the output value is FALSE, then no more lattice points were found, +! and V was reset to 0, and the routine should not be called further +! for this tetrahedron. +! + implicit none + + integer(kind=4) c(4) + integer(kind=4) c1n + integer(kind=4) i4vec_lcm + integer(kind=4) lhs + logical(kind=4) more + integer(kind=4), parameter :: n = 3 + integer(kind=4) rhs + integer(kind=4) v(3) + + if (.not. more) then + + v(1:n) = 0 + more = .true. + + else + + c1n = i4vec_lcm(n, c) + + rhs = c1n * c(n + 1) + + lhs = c(2) * c(3) * v(1) & + + c(1) * c(3) * v(2) & + + c(1) * c(2) * v(3) + + if (lhs + c1n / c(1) <= rhs) then + + v(1) = v(1) + 1 + + else + + lhs = lhs - c1n * v(1) / c(1) + v(1) = 0 + + if (lhs + c1n / c(2) <= rhs) then + + v(2) = v(2) + 1 + + else + + lhs = lhs - c1n * v(2) / c(2) + v(2) = 0 + + if (lhs + c1n / c(3) <= rhs) then + + v(3) = v(3) + 1 + + else + + v(3) = 0 + more = .false. + + end if + + end if + + end if + + end if + + return +end +subroutine tetrahedron_quality1_3d(tetra, quality) + +!*****************************************************************************80 +! +!! TETRAHEDRON_QUALITY1_3D: "quality" of a tetrahedron in 3D. +! +! Discussion: +! +! The quality of a tetrahedron is 3 times the ratio of the radius of +! the inscribed sphere divided by that of the circumscribed sphere. +! +! An equilateral tetrahredron achieves the maximum possible quality of 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. +! +! Output, real ( kind = 8 ) QUALITY, the quality of the tetrahedron. +! + implicit none + + real(kind=8) pc(3) + real(kind=8) quality + real(kind=8) r_in + real(kind=8) r_out + real(kind=8) tetra(3, 4) + + call tetrahedron_circumsphere_3d(tetra, r_out, pc) + + call tetrahedron_insphere_3d(tetra, r_in, pc) + + quality = 3.0D+00 * r_in / r_out + + return +end +subroutine tetrahedron_quality2_3d(tetra, quality2) + +!*****************************************************************************80 +! +!! TETRAHEDRON_QUALITY2_3D: "quality" of a tetrahedron in 3D. +! +! Discussion: +! +! The quality measure #2 of a tetrahedron is: +! +! QUALITY2 = 2 * sqrt ( 6 ) * RIN / LMAX +! +! where +! +! RIN = radius of the inscribed sphere; +! LMAX = length of longest side of the tetrahedron. +! +! An equilateral tetrahredron achieves the maximum possible quality of 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 August 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Qiang Du, Desheng Wang, +! The Optimal Centroidal Voronoi Tesselations and the Gersho's +! Conjecture in the Three-Dimensional Space, +! Computers and Mathematics with Applications, +! Volume 49, 2005, pages 1355-1373. +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the tetrahedron vertices. +! +! Output, real ( kind = 8 ) QUALITY2, the quality of the tetrahedron. +! + implicit none + + real(kind=8) edge_length(6) + real(kind=8) l_max + real(kind=8) pc(3) + real(kind=8) quality2 + real(kind=8) r_in + real(kind=8) tetra(3, 4) + + call tetrahedron_edge_length_3d(tetra, edge_length) + + l_max = maxval(edge_length(1:6)) + + call tetrahedron_insphere_3d(tetra, r_in, pc) + + quality2 = 2.0D+00 * sqrt(6.0D+00) * r_in / l_max + + return +end +subroutine tetrahedron_quality3_3d(tetra, quality3) + +!*****************************************************************************80 +! +!! TETRAHEDRON_QUALITY3_3D computes the mean ratio of a tetrahedron. +! +! Discussion: +! +! This routine computes QUALITY3, the eigenvalue or mean ratio of +! a tetrahedron. +! +! QUALITY3 = 12 * ( 3 * volume )**(2/3) / (sum of squares of edge lengths). +! +! This value may be used as a shape quality measure for the tetrahedron. +! +! For an equilateral tetrahedron, the value of this quality measure +! will be 1. For any other tetrahedron, the value will be between +! 0 and 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 August 2005 +! +! Author: +! +! Original FORTRAN77 version by Barry Joe. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Barry Joe, +! GEOMPACK - a software package for the generation of meshes +! using geometric algorithms, +! Advances in Engineering Software, +! Volume 13, pages 325-331, 1991. +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. +! +! Output, real ( kind = 8 ) QUALITY3, the mean ratio of the tetrahedron. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) ab(dim_num) + real(kind=8) ac(dim_num) + real(kind=8) ad(dim_num) + real(kind=8) bc(dim_num) + real(kind=8) bd(dim_num) + real(kind=8) cd(dim_num) + real(kind=8) denom + real(kind=8) lab + real(kind=8) lac + real(kind=8) lad + real(kind=8) lbc + real(kind=8) lbd + real(kind=8) lcd + real(kind=8) quality3 + real(kind=8) tetra(dim_num, 4) + real(kind=8) volume +! +! Compute the vectors representing the sides of the tetrahedron. +! + ab(1:3) = tetra(1:dim_num, 2) - tetra(1:dim_num, 1) + ac(1:3) = tetra(1:dim_num, 3) - tetra(1:dim_num, 1) + ad(1:3) = tetra(1:dim_num, 4) - tetra(1:dim_num, 1) + bc(1:3) = tetra(1:dim_num, 3) - tetra(1:dim_num, 2) + bd(1:3) = tetra(1:dim_num, 4) - tetra(1:dim_num, 2) + cd(1:3) = tetra(1:dim_num, 4) - tetra(1:dim_num, 3) +! +! Compute the squares of the lengths of the sides. +! + lab = sum(ab(1:dim_num)**2) + lac = sum(ac(1:dim_num)**2) + lad = sum(ad(1:dim_num)**2) + lbc = sum(bc(1:dim_num)**2) + lbd = sum(bd(1:dim_num)**2) + lcd = sum(cd(1:dim_num)**2) +! +! Compute the volume. +! + volume = abs( & + ab(1) * (ac(2) * ad(3) - ac(3) * ad(2)) & + + ab(2) * (ac(3) * ad(1) - ac(1) * ad(3)) & + + ab(3) * (ac(1) * ad(2) - ac(2) * ad(1))) / 6.0D+00 + + denom = lab + lac + lad + lbc + lbd + lcd + + if (denom == 0.0D+00) then + quality3 = 0.0D+00 + else + quality3 = 12.0D+00 * (3.0D+00 * volume)**(2.0D+00 / 3.0D+00) / denom + end if + + return +end +subroutine tetrahedron_quality4_3d(tetra, quality4) + +!*****************************************************************************80 +! +!! TETRAHEDRON_QUALITY4_3D computes the minimum solid angle of a tetrahedron. +! +! Discussion: +! +! This routine computes a quality measure for a tetrahedron, based +! on the sine of half the minimum of the four solid angles. +! +! The quality measure for an equilateral tetrahedron should be 1, +! since the solid angles of such a tetrahedron are each equal to pi. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 August 2005 +! +! Author: +! +! Original FORTRAN77 version by Barry Joe. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Barry Joe, +! GEOMPACK - a software package for the generation of meshes +! using geometric algorithms, +! Advances in Engineering Software, +! Volume 13, pages 325-331, 1991. +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. +! +! Output, real ( kind = 8 ) QUALITY4, the value of the quality measure. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) ab(dim_num) + real(kind=8) ac(dim_num) + real(kind=8) ad(dim_num) + real(kind=8) bc(dim_num) + real(kind=8) bd(dim_num) + real(kind=8) cd(dim_num) + real(kind=8) denom + real(kind=8) l1 + real(kind=8) l2 + real(kind=8) l3 + real(kind=8) lab + real(kind=8) lac + real(kind=8) lad + real(kind=8) lbc + real(kind=8) lbd + real(kind=8) lcd + real(kind=8) quality4 + real(kind=8) tetra(dim_num, 4) + real(kind=8) volume +! +! Compute the vectors that represent the sides. +! + ab(1:dim_num) = tetra(1:dim_num, 2) - tetra(1:dim_num, 1) + ac(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 1) + ad(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 1) + bc(1:dim_num) = tetra(1:dim_num, 3) - tetra(1:dim_num, 2) + bd(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 2) + cd(1:dim_num) = tetra(1:dim_num, 4) - tetra(1:dim_num, 3) +! +! Compute the lengths of the sides. +! + lab = sqrt(sum(ab(1:dim_num)**2)) + lac = sqrt(sum(ac(1:dim_num)**2)) + lad = sqrt(sum(ad(1:dim_num)**2)) + lbc = sqrt(sum(bc(1:dim_num)**2)) + lbd = sqrt(sum(bd(1:dim_num)**2)) + lcd = sqrt(sum(cd(1:dim_num)**2)) +! +! Compute the volume +! + volume = abs( & + ab(1) * (ac(2) * ad(3) - ac(3) * ad(2)) & + + ab(2) * (ac(3) * ad(1) - ac(1) * ad(3)) & + + ab(3) * (ac(1) * ad(2) - ac(2) * ad(1))) / 6.0D+00 + + quality4 = 1.0D+00 + + l1 = lab + lac + l2 = lab + lad + l3 = lac + lad + + denom = (l1 + lbc) * (l1 - lbc) & + * (l2 + lbd) * (l2 - lbd) & + * (l3 + lcd) * (l3 - lcd) + + if (denom <= 0.0D+00) then + quality4 = 0.0D+00 + else + quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) + end if + + l1 = lab + lbc + l2 = lab + lbd + l3 = lbc + lbd + + denom = (l1 + lac) * (l1 - lac) & + * (l2 + lad) * (l2 - lad) & + * (l3 + lcd) * (l3 - lcd) + + if (denom <= 0.0D+00) then + quality4 = 0.0D+00 + else + quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) + end if + + l1 = lac + lbc + l2 = lac + lcd + l3 = lbc + lcd + + denom = (l1 + lab) * (l1 - lab) & + * (l2 + lad) * (l2 - lad) & + * (l3 + lbd) * (l3 - lbd) + + if (denom <= 0.0D+00) then + quality4 = 0.0D+00 + else + quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) + end if + + l1 = lad + lbd + l2 = lad + lcd + l3 = lbd + lcd + + denom = (l1 + lab) * (l1 - lab) & + * (l2 + lac) * (l2 - lac) & + * (l3 + lbc) * (l3 - lbc) + + if (denom <= 0.0D+00) then + quality4 = 0.0D+00 + else + quality4 = min(quality4, 12.0D+00 * volume / sqrt(denom)) + end if + + quality4 = quality4 * 1.5D+00 * sqrt(6.0D+00) + + return +end +subroutine tetrahedron_rhombic_shape_3d(point_num, face_num, & + face_order_max, point_coord, face_order, face_point) + +!*****************************************************************************80 +! +!! TETRAHEDRON_RHOMBIC_SHAPE_3D describes a rhombic tetrahedron in 3D. +! +! Discussion: +! +! Call TETRAHEDRON_RHOMBIC_SIZE_3D first, to get dimension information. +! +! The tetrahedron is described using 10 nodes. If we label the vertices +! P0, P1, P2 and P3, then the extra nodes lie halfway between vertices, +! and have the labels P01, P02, P03, P12, P13 and P23. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 January 2007 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Anwei Liu, Barry Joe, +! Quality Local Refinement of Tetrahedral Meshes Based +! on 8-Subtetrahedron Subdivision, +! Mathematics of Computation, +! Volume 65, Number 215, July 1996, pages 1183-1200. +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of +! vertices per face. +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. +! +! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices +! for each face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. +! The points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) d + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) point_coord(dim_num, point_num) + real(kind=8), parameter :: z = 0.0D+00 + + a = 1.0D+00 / sqrt(3.0D+00) + b = sqrt(2.0D+00) / sqrt(3.0D+00) + c = sqrt(3.0D+00) / 6.0D+00 + d = 1.0D+00 / sqrt(6.0D+00) +! +! Set the point coordinates. +! + point_coord(1:dim_num, 1) = (/-b, z, z/) + point_coord(1:dim_num, 2) = (/z, -a, z/) + point_coord(1:dim_num, 3) = (/z, a, z/) + point_coord(1:dim_num, 4) = (/z, z, b/) + point_coord(1:dim_num, 5) = (/-d, -c, z/) + point_coord(1:dim_num, 6) = (/-d, c, z/) + point_coord(1:dim_num, 7) = (/-d, z, d/) + point_coord(1:dim_num, 8) = (/z, z, z/) + point_coord(1:dim_num, 9) = (/z, -c, d/) + point_coord(1:dim_num, 10) = (/z, c, d/) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 6, 6, 6, 6/) +! +! Set faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 1, 5, 2, 9, 4, 7, & + 2, 8, 3, 10, 4, 9, & + 3, 6, 1, 7, 4, 10, & + 1, 6, 3, 8, 2, 5/), (/face_order_max, face_num/)) + + return +end +subroutine tetrahedron_rhombic_size_3d(point_num, edge_num, face_num, & + face_order_max) + +!*****************************************************************************80 +! +!! TETRAHEDRON_RHOMBIC_SIZE_3D gives "sizes" for a rhombic tetrahedron in 3D. +! +! Discussion: +! +! Call this routine first, in order to learn the required dimensions +! of arrays to be set up by TETRAHEDRON_RHOMBIC_SHAPE_3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 January 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of vertices. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 10 + edge_num = 6 + face_num = 4 + face_order_max = 6 + + return +end +subroutine tetrahedron_sample_3d(t, n, seed, p) + +!*****************************************************************************80 +! +!! TETRAHEDRON_SAMPLE_3D returns random points in a tetrahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 December 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(3,4), the tetrahedron vertices. +! +! Input, integer ( kind = 4 ) N, the number of points to sample. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random +! number generator. +! +! Output, real ( kind = 8 ) P(3,N), random points in the tetrahedron. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) n + + real(kind=8) alpha + real(kind=8) beta + real(kind=8) gamma + integer(kind=4) j + real(kind=8) p(dim_num, n) + real(kind=8) p12(dim_num) + real(kind=8) p13(dim_num) + real(kind=8) r + real(kind=8) r8_uniform_01 + integer(kind=4) seed + real(kind=8) t(dim_num, dim_num + 1) + real(kind=8) tr(dim_num, 3) + + do j = 1, n + + r = r8_uniform_01(seed) +! +! Interpret R as a percentage of the tetrahedron's volume. +! +! Imagine a plane, parallel to face 1, so that the volume between +! vertex 1 and the plane is R percent of the full tetrahedron volume. +! +! The plane will intersect sides 12, 13, and 14 at a fraction +! ALPHA = R^1/3 of the distance from vertex 1 to vertices 2, 3, and 4. +! + alpha = r**(1.0D+00 / 3.0D+00) +! +! Determine the coordinates of the points on sides 12, 13 and 14 intersected +! by the plane, which form a triangle TR. +! + tr(1:dim_num, 1) = (1.0D+00 - alpha) * t(1:dim_num, 1) & + + alpha * t(1:dim_num, 2) + tr(1:dim_num, 2) = (1.0D+00 - alpha) * t(1:dim_num, 1) & + + alpha * t(1:dim_num, 3) + tr(1:dim_num, 3) = (1.0D+00 - alpha) * t(1:dim_num, 1) & + + alpha * t(1:dim_num, 4) +! +! Now choose, uniformly at random, a point in this triangle. +! + r = r8_uniform_01(seed) +! +! Interpret R as a percentage of the triangle's area. +! +! Imagine a line L, parallel to side 1, so that the area between +! vertex 1 and line L is R percent of the full triangle's area. +! +! The line L will intersect sides 2 and 3 at a fraction +! ALPHA = SQRT ( R ) of the distance from vertex 1 to vertices 2 and 3. +! + beta = sqrt(r) +! +! Determine the coordinates of the points on sides 2 and 3 intersected +! by line L. +! + p12(1:dim_num) = (1.0D+00 - beta) * tr(1:dim_num, 1) & + + beta * tr(1:dim_num, 2) + p13(1:dim_num) = (1.0D+00 - beta) * tr(1:dim_num, 1) & + + beta * tr(1:dim_num, 3) +! +! Now choose, uniformly at random, a point on the line L. +! + gamma = r8_uniform_01(seed) + + p(1:dim_num, j) = (1.0D+00 - gamma) * p12(1:dim_num) & + + gamma * p13(1:dim_num) + + end do + + return +end +subroutine tetrahedron_shape_3d(point_num, face_num, face_order_max, & + point_coord, face_order, face_point) + +!*****************************************************************************80 +! +!! TETRAHEDRON_SHAPE_3D describes a tetrahedron in 3D. +! +! Discussion: +! +! Call TETRAHEDRON_SIZE_3D first, to get dimension information. +! +! The vertices lie on the unit sphere. +! +! The dual of the tetrahedron is the tetrahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 October 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum number of +! vertices per face. +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. +! +! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of vertices +! for each face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. +! The points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) point_coord(dim_num, point_num) +! +! Set the point coordinates. +! + point_coord(1:dim_num, 1:point_num) = reshape((/ & + 0.942809D+00, 0.000000D+00, -0.333333D+00, & + -0.471405D+00, 0.816497D+00, -0.333333D+00, & + -0.471405D+00, -0.816497D+00, -0.333333D+00, & + 0.000000D+00, 0.000000D+00, 1.000000D+00/), & + (/dim_num, point_num/)) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 3, 3, 3, 3/) +! +! Set faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 1, 3, 2, & + 1, 2, 4, & + 1, 4, 3, & + 2, 3, 4/), (/face_order_max, face_num/)) + + return +end +subroutine tetrahedron_size_3d(point_num, edge_num, face_num, & + face_order_max) + +!*****************************************************************************80 +! +!! TETRAHEDRON_SIZE_3D gives "sizes" for a tetrahedron in 3D. +! +! Discussion: +! +! Call this routine first, in order to learn the required dimensions +! of arrays to be set up by TETRAHEDRON_SHAPE_3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of vertices. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 4 + edge_num = 6 + face_num = 4 + face_order_max = 3 + + return +end +subroutine tetrahedron_solid_angles_3d(tetra, angle) + +!*****************************************************************************80 +! +!! TETRAHEDRON_SOLID_ANGLES_3D computes solid angles of a tetrahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 July 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. +! +! Output, real ( kind = 8 ) ANGLE(4), the solid angles. +! + implicit none + + real(kind=8) angle(6) + real(kind=8) dihedral_angle(6) + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) tetra(3, 4) + + call tetrahedron_dihedral_angles_3d(tetra, dihedral_angle) + + angle(1) = dihedral_angle(1) + dihedral_angle(2) + dihedral_angle(3) - r8_pi + angle(2) = dihedral_angle(1) + dihedral_angle(4) + dihedral_angle(5) - r8_pi + angle(3) = dihedral_angle(2) + dihedral_angle(4) + dihedral_angle(6) - r8_pi + angle(4) = dihedral_angle(3) + dihedral_angle(5) + dihedral_angle(6) - r8_pi + + return +end +subroutine tetrahedron_volume_3d(tetra, volume) + +!*****************************************************************************80 +! +!! TETRAHEDRON_VOLUME_3D computes the volume of a tetrahedron in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the tetrahedron. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) a(4, 4) + real(kind=8) r8mat_det_4d + real(kind=8) tetra(dim_num, 4) + real(kind=8) volume + + a(1:dim_num, 1:4) = tetra(1:dim_num, 1:4) + a(4, 1:4) = 1.0D+00 + + volume = abs(r8mat_det_4d(a)) / 6.0D+00 + + return +end +subroutine tetrahedron01_lattice_point_num_3d(s, n) + +!*****************************************************************************80 +! +!! TETRAHEDRON01_LATTICE_POINT_NUM_3D: count lattice points. +! +! Discussion: +! +! The tetrahedron is assumed to be the unit tetrahedron: +! +! ( (0,0,0), (1,0,0), (0,1,0), (0,0,1) ) +! +! or a copy of this tetrahedron scaled by an integer S: +! +! ( (0,0,0), (S,0,0), (0,S,0), (0,0,S) ). +! +! The routine returns the number of integer lattice points that appear +! inside the tetrahedron, or on its faces, edges or vertices. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 July 2009 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Matthias Beck, Sinai Robins, +! Computing the Continuous Discretely, +! Springer, 2006, +! ISBN13: 978-0387291390, +! LC: QA640.7.B43. +! +! Parameters: +! +! Input, integer ( kind = 4 ) S, the scale factor. +! +! Output, integer ( kind = 4 ) N, the number of lattice points. +! + implicit none + + integer(kind=4) n + integer(kind=4) s + + n = ((s + 3) * (s + 2) * (s + 1)) / 6 + + return +end +function tetrahedron01_volume() + +!*****************************************************************************80 +! +!! TETRAHEDRON01_VOLUME returns the volume of the unit tetrahedron. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) TETRAHEDRON01_VOLUME, the volume. +! + implicit none + + real(kind=8) tetrahedron01_volume + + tetrahedron01_volume = 1.0D+00 / 6.0D+00 + + return +end +subroutine timestamp() + +!*****************************************************************************80 +! +!! TIMESTAMP prints the current YMDHMS date as a time stamp. +! +! Example: +! +! 31 May 2001 9:45:54.872 AM +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! None +! + implicit none + + character(len=8) ampm + integer(kind=4) d + integer(kind=4) h + integer(kind=4) m + integer(kind=4) mm + character(len=9), parameter, dimension(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December '/) + integer(kind=4) n + integer(kind=4) s + integer(kind=4) values(8) + integer(kind=4) y + + call date_and_time(values=values) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + + if (h < 12) then + ampm = 'AM' + else if (h == 12) then + if (n == 0 .and. s == 0) then + ampm = 'Noon' + else + ampm = 'PM' + end if + else + h = h - 12 + if (h < 12) then + ampm = 'PM' + else if (h == 12) then + if (n == 0 .and. s == 0) then + ampm = 'Midnight' + else + ampm = 'AM' + end if + end if + end if + + write (*, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)') & + d, trim(month(m)), y, h, ':', n, ':', s, '.', mm, trim(ampm) + + return +end +subroutine tmat_init(a) + +!*****************************************************************************80 +! +!! TMAT_INIT initializes the geometric transformation matrix. +! +! Discussion: +! +! The geometric transformation matrix can be thought of as a 4 by 4 +! matrix "A" having components: +! +! r11 r12 r13 t1 +! r21 r22 r23 t2 +! r31 r32 r33 t3 +! 0 0 0 1 +! +! This matrix encodes the rotations, scalings and translations that +! are applied to graphical objects. +! +! A point P = (x,y,z) is rewritten in "homogeneous coordinates" as +! PH = (x,y,z,1). Then to apply the transformations encoded in A to +! the point P, we simply compute A * PH. +! +! Individual transformations, such as a scaling, can be represented +! by simple versions of the transformation matrix. If the matrix +! A represents the current set of transformations, and we wish to +! apply a new transformation B, then the original points are +! transformed twice: B * ( A * PH ). The new transformation B can +! be combined with the original one A, to give a single matrix C that +! encodes both transformations: C = B * A. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 1998 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. +! + implicit none + + real(kind=8) a(4, 4) + integer(kind=4) i + integer(kind=4) j + + do i = 1, 4 + do j = 1, 4 + if (i == j) then + a(i, j) = 1.0D+00 + else + a(i, j) = 0.0D+00 + end if + end do + end do + + return +end +subroutine tmat_mxm(a, b, c) + +!*****************************************************************************80 +! +!! TMAT_MXM multiplies two geometric transformation matrices. +! +! Discussion: +! +! The product is accumulated in a temporary array, and then assigned +! to the result. Therefore, it is legal for any two, or all three, +! of the arguments to share memory. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 December 2000 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the first geometric transformation matrix. +! +! Input, real ( kind = 8 ) B(4,4), the second geometric transformation +! matrix. +! +! Output, real ( kind = 8 ) C(4,4), the product A * B. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) b(4, 4) + real(kind=8) c(4, 4) + + c(1:4, 1:4) = matmul(a(1:4, 1:4), b(1:4, 1:4)) + + return +end +subroutine tmat_mxp(a, x, y) + +!*****************************************************************************80 +! +!! TMAT_MXP multiplies a geometric transformation matrix times a point. +! +! Discussion: +! +! The matrix will normally have the form +! +! xx xy xz tx +! yx yy yz ty +! zx zy zz tz +! 0 0 0 1 +! +! where the 3x3 initial block controls rotations and scalings, +! and the values [ tx, ty, tz ] implement a translation. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 December 2000 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. +! +! Input, real ( kind = 8 ) X(3), the point to be multiplied. The fourth +! component of X is implicitly assigned the value of 1. +! +! Output, real ( kind = 8 ) Y(3), the result of A*X. The product is +! accumulated in a temporary vector, and then assigned to the result. +! Therefore, it is legal for X and Y to share memory. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) x(3) + real(kind=8) y(3) + + y(1:3) = a(1:3, 4) + matmul(a(1:3, 1:3), x(1:3)) + + return +end +subroutine tmat_mxp2(a, n, x, y) + +!*****************************************************************************80 +! +!! TMAT_MXP2 multiplies a geometric transformation matrix times N points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 March 2006 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. +! +! Input, integer ( kind = 4 ) N, the number of points to be multiplied. +! +! Input, real ( kind = 8 ) X(3,N), the points to be multiplied. +! +! Output, real ( kind = 8 ) Y(3,N), the transformed points. Each product is +! accumulated in a temporary vector, and then assigned to the +! result. Therefore, it is legal for X and Y to share memory. +! + implicit none + + integer(kind=4) n + + real(kind=8) a(4, 4) + integer(kind=4) i + real(kind=8) x(3, n) + real(kind=8) y(3, n) + + do i = 1, 3 + y(i, 1:n) = a(i, 4) + end do + + y(1:3, 1:n) = y(1:3, 1:n) + matmul(a(1:3, 1:3), x(1:3, 1:n)) + + return +end +subroutine tmat_mxv(a, x, y) + +!*****************************************************************************80 +! +!! TMAT_MXV multiplies a geometric transformation matrix times a vector. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 August 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the geometric transformation matrix. +! +! Input, real ( kind = 8 ) X(3), the vector to be multiplied. The fourth +! component of X is implicitly assigned the value of 1. +! +! Output, real ( kind = 8 ) Y(3), the result of A*X. The product is +! accumulated in a temporary vector, and then assigned to the result. +! Therefore, it is legal for X and Y to share memory. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) x(3) + real(kind=8) y(3) + + y(1:3) = a(1:3, 4) + matmul(a(1:3, 1:3), x(1:3)) + + return +end +subroutine tmat_rot_axis(a, angle, axis, b) + +!*****************************************************************************80 +! +!! TMAT_ROT_AXIS: coordinate axis rotation to geometric transformation matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 December 1998 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the current geometric transformation +! matrix. +! +! Input, real ( kind = 8 ) ANGLE, the angle, in degrees, of the rotation. +! +! Input, character AXIS, is 'X', 'Y' or 'Z', specifying the coordinate +! axis about which the rotation occurs. +! +! Output, real ( kind = 8 ) B(4,4), the modified geometric +! transformation matrix. +! A and B may share the same memory. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) angle + real(kind=8) angle_rad + character axis + real(kind=8) b(4, 4) + real(kind=8) c(4, 4) + real(kind=8) degrees_to_radians + + angle_rad = degrees_to_radians(angle) + + call tmat_init(c) + + if (axis == 'X' .or. axis == 'x') then + c(2, 2) = cos(angle_rad) + c(2, 3) = -sin(angle_rad) + c(3, 2) = sin(angle_rad) + c(3, 3) = cos(angle_rad) + else if (axis == 'Y' .or. axis == 'y') then + c(1, 1) = cos(angle_rad) + c(1, 3) = sin(angle_rad) + c(3, 1) = -sin(angle_rad) + c(3, 3) = cos(angle_rad) + else if (axis == 'Z' .or. axis == 'z') then + c(1, 1) = cos(angle_rad) + c(1, 2) = -sin(angle_rad) + c(2, 1) = sin(angle_rad) + c(2, 2) = cos(angle_rad) + else + write (*, '(a)') ' ' + write (*, '(a)') 'TMAT_ROT_AXIS - Fatal error!' + write (*, '(a)') ' Illegal rotation axis: '//axis + write (*, '(a)') ' Legal choices are ''X'', ''Y'', or ''Z''.' + stop 1 + end if + + b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) + + return +end +subroutine tmat_rot_vector(a, angle, axis, b) + +!*****************************************************************************80 +! +!! TMAT_ROT_VECTOR: arbitrary axis rotation to geometric transformation matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 December 1998 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the current geometric transformation +! matrix. +! +! Input, real ( kind = 8 ) ANGLE, the angle, in degrees, of the rotation. +! +! Input, real ( kind = 8 ) AXIS(3), the axis vector about which +! rotation occurs. AXIS may not be the zero vector. +! +! Output, real ( kind = 8 ) B(4,4), the modified geometric +! transformation matrix. +! A and B may share the same memory. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) angle + real(kind=8) angle_rad + real(kind=8) axis(3) + real(kind=8) b(4, 4) + real(kind=8) c(4, 4) + real(kind=8) ca + real(kind=8) degrees_to_radians + real(kind=8) norm + real(kind=8) sa + real(kind=8) v1 + real(kind=8) v2 + real(kind=8) v3 + + v1 = axis(1) + v2 = axis(2) + v3 = axis(3) + + norm = sqrt(v1 * v1 + v2 * v2 + v3 * v3) + + if (norm == 0.0D+00) then + return + end if + + v1 = v1 / norm + v2 = v2 / norm + v3 = v3 / norm + + angle_rad = degrees_to_radians(angle) + ca = cos(angle_rad) + sa = sin(angle_rad) + + call tmat_init(c) + + c(1, 1) = v1 * v1 + ca * (1.0D+00 - v1 * v1) + c(1, 2) = (1.0D+00 - ca) * v1 * v2 - sa * v3 + c(1, 3) = (1.0D+00 - ca) * v1 * v3 + sa * v2 + + c(2, 1) = (1.0D+00 - ca) * v2 * v1 + sa * v3 + c(2, 2) = v2 * v2 + ca * (1.0D+00 - v2 * v2) + c(2, 3) = (1.0D+00 - ca) * v2 * v3 - sa * v1 + + c(3, 1) = (1.0D+00 - ca) * v3 * v1 - sa * v2 + c(3, 2) = (1.0D+00 - ca) * v3 * v2 + sa * v1 + c(3, 3) = v3 * v3 + ca * (1.0D+00 - v3 * v3) + + b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) + + return +end +subroutine tmat_scale(a, s, b) + +!*****************************************************************************80 +! +!! TMAT_SCALE applies a scaling to the geometric transformation matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 1998 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the current geometric transformation +! matrix. +! +! Input, real ( kind = 8 ) S(3), the scalings to be applied to the +! X, Y and Z coordinates. +! +! Output, real ( kind = 8 ) B(4,4), the modified geometric transformation +! matrix. A and B may share the same memory. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) b(4, 4) + real(kind=8) c(4, 4) + real(kind=8) s(3) + + call tmat_init(c) + + c(1, 1) = s(1) + c(2, 2) = s(2) + c(3, 3) = s(3) + + b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) + + return +end +subroutine tmat_shear(a, axis, s, b) + +!*****************************************************************************80 +! +!! TMAT_SHEAR applies a shear to the geometric transformation matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 October 1998 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the current geometric transformation +! matrix. +! +! Input, character ( len = 2 ) AXIS, is 'XY', 'XZ', 'YX', 'YZ', 'ZX' or 'ZY', +! specifying the shear equation: +! +! XY: x' = x + s * y; +! XZ: x' = x + s * z; +! YX: y' = y + s * x; +! YZ: y' = y + s * z; +! ZX: z' = z + s * x; +! ZY: z' = z + s * y. +! +! Input, real ( kind = 8 ) S, the shear coefficient. +! +! Output, real ( kind = 8 ) B(4,4), the modified geometric transformation +! matrix. A and B may share the same memory. +! + implicit none + + real(kind=8) a(4, 4) + character(len=2) axis + real(kind=8) b(4, 4) + real(kind=8) c(4, 4) + real(kind=8) s + + call tmat_init(c) + + if (axis == 'XY' .or. axis == 'xy') then + c(1, 2) = s + else if (axis == 'XZ' .or. axis == 'xz') then + c(1, 3) = s + else if (axis == 'YX' .or. axis == 'yx') then + c(2, 1) = s + else if (axis == 'YZ' .or. axis == 'yz') then + c(2, 3) = s + else if (axis == 'ZX' .or. axis == 'zx') then + c(3, 1) = s + else if (axis == 'ZY' .or. axis == 'zy') then + c(3, 2) = s + else + write (*, '(a)') ' ' + write (*, '(a)') 'TMAT_SHEAR - Fatal error!' + write (*, '(a)') ' Illegal shear axis: "'//axis//'".' + write (*, '(a)') ' Legal choices are XY, XZ, YX, YZ, ZX, or ZY.' + stop 1 + end if + + b(1:4, 1:4) = matmul(c(1:4, 1:4), a(1:4, 1:4)) + + return +end +subroutine tmat_trans(a, t, b) + +!*****************************************************************************80 +! +!! TMAT_TRANS applies a translation to the geometric transformation matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 December 2000 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! James Foley, Andries van Dam, Steven Feiner, John Hughes, +! Computer Graphics, Principles and Practice, +! Second Edition, +! Addison Wesley, 1990. +! +! Parameters: +! +! Input, real ( kind = 8 ) A(4,4), the current geometric transformation +! matrix. +! +! Input, real ( kind = 8 ) T(3), the translation. This may be thought +! of as the point that the origin moves to under the translation. +! +! Output, real ( kind = 8 ) B(4,4), the modified transformation matrix. +! A and B may share the same memory. +! + implicit none + + real(kind=8) a(4, 4) + real(kind=8) b(4, 4) + real(kind=8) t(3) + + b(1:4, 1:4) = a(1:4, 1:4) + + b(1:3, 4) = b(1:3, 4) + t(1:3) + + return +end +function torus_area_3d(r1, r2) + +!*****************************************************************************80 +! +!! TORUS_AREA_3D returns the area of a torus in 3D. +! +! Discussion: +! +! A torus with radii R1 and R2 is the set of points P satisfying: +! +! ( sqrt ( P(1)^2 + P(2)^2 ) - R1 )^2 + P(3)^2 <= R2^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 November 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the two radii that define the torus. +! +! Output, real ( kind = 8 ) TORUS_AREA_3D, the area of the torus. +! + implicit none + + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) torus_area_3d + + torus_area_3d = 4.0D+00 * r8_pi * r8_pi * r1 * r2 + + return +end +subroutine torus_volume_3d(r1, r2, volume) + +!*****************************************************************************80 +! +!! TORUS_VOLUME_3D computes the volume of a torus in 3D. +! +! Discussion: +! +! A torus with radii R1 and R2 is the set of points P satisfying: +! +! ( sqrt ( P(1)*^ + P(2)^2 ) - R1 )^2 + P(3)^2 <= R2^2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 December 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) R1, R2, the "inner" and "outer" radii of the +! torus. +! +! Output, real ( kind = 8 ) VOLUME, the volume of the torus. +! + implicit none + + real(kind=8) r1 + real(kind=8) r2 + real(kind=8), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=8) volume + + volume = 2.0D+00 * r8_pi * r8_pi * r1 * r2 * r2 + + return +end +subroutine tp_to_xyz(theta, phi, v) + +!*****************************************************************************80 +! +!! TP_TO_XYZ converts unit spherical TP coordinates to XYZ coordinates. +! +! Discussion: +! +! The point is assume to lie on the unit sphere centered at the origin. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 September 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) THETA, PHI, the angular coordinates of a point +! on the unit sphere. +! +! Output, real ( kind = 8 ) V(3), the XYZ coordinates. +! + implicit none + + real(kind=8) phi + real(kind=8) theta + real(kind=8) v(3) + + v(1) = cos(theta) * sin(phi) + v(2) = sin(theta) * sin(phi) + v(3) = cos(phi) + + return +end + +subroutine truncated_octahedron_shape_3d(point_num, face_num, & + face_order_max, point_coord, face_order, face_point) + +!*****************************************************************************80 +! +!! TRUNCATED_OCTAHEDRON_SHAPE_3D describes a truncated octahedron in 3D. +! +! Discussion: +! +! The shape is a truncated octahedron. There are 8 hexagons and 6 +! squares. +! +! The truncated octahedron is an interesting shape because it +! is "space filling". In other words, all of 3D space can be +! filled by a regular lattice of these shapes. +! +! Call TRUNCATED_OCTAHEDRON_SIZE_3D to get the values of POINT_NUM, +! FACE_NUM, and FACE_ORDER_MAX, so you can allocate space for the arrays. +! +! For each face, the face list must be of length FACE_ORDER_MAX. +! In cases where a face is of lower than maximum order (the +! squares, in this case), the extra entries are listed as "-1". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 August 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) POINT_NUM, the number of points (24). +! +! Input, integer ( kind = 4 ) FACE_NUM, the number of faces (14). +! +! Input, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any +! face (6). +! +! Output, real ( kind = 8 ) POINT_COORD(3,POINT_NUM), the vertices. +! +! Output, integer ( kind = 4 ) FACE_ORDER(FACE_NUM), the number of +! vertices per face. +! +! Output, integer ( kind = 4 ) FACE_POINT(FACE_ORDER_MAX,FACE_NUM); +! FACE_POINT(I,J) contains the index of the I-th point in the J-th face. +! The points are listed in the counter clockwise direction defined +! by the outward normal at the face. +! + implicit none + + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4), parameter :: dim_num = 3 + integer(kind=4) point_num + + integer(kind=4) face_order(face_num) + integer(kind=4) face_point(face_order_max, face_num) + real(kind=8) point_coord(dim_num, point_num) +! +! Set the point coordinates. +! + point_coord(1:dim_num, 1:point_num) = reshape((/ & + -1.5D+00, -0.5D+00, 0.0D+00, & + -1.5D+00, 0.5D+00, 0.0D+00, & + -1.0D+00, -1.0D+00, -0.70710677D+00, & + -1.0D+00, -1.0D+00, 0.70710677D+00, & + -1.0D+00, 1.0D+00, -0.70710677D+00, & + -1.0D+00, 1.0D+00, 0.70710677D+00, & + -0.5D+00, -1.5D+00, 0.0D+00, & + -0.5D+00, -0.5D+00, -1.4142135D+00, & + -0.5D+00, -0.5D+00, 1.4142135D+00, & + -0.5D+00, 0.5D+00, -1.4142135D+00, & + -0.5D+00, 0.5D+00, 1.4142135D+00, & + -0.5D+00, 1.5D+00, 0.0D+00, & + 0.5D+00, -1.5D+00, 0.0D+00, & + 0.5D+00, -0.5D+00, -1.4142135D+00, & + 0.5D+00, -0.5D+00, 1.4142135D+00, & + 0.5D+00, 0.5D+00, -1.4142135D+00, & + 0.5D+00, 0.5D+00, 1.4142135D+00, & + 0.5D+00, 1.5D+00, 0.0D+00, & + 1.0D+00, -1.0D+00, -0.70710677D+00, & + 1.0D+00, -1.0D+00, 0.70710677D+00, & + 1.0D+00, 1.0D+00, -0.70710677D+00, & + 1.0D+00, 1.0D+00, 0.70710677D+00, & + 1.5D+00, -0.5D+00, 0.0D+00, & + 1.5D+00, 0.5D+00, 0.0D+00/), (/dim_num, point_num/)) +! +! Set the face orders. +! + face_order(1:face_num) = (/ & + 4, 4, 4, 4, 4, 4, 6, 6, 6, 6, & + 6, 6, 6, 6/) +! +! Set faces. +! + face_point(1:face_order_max, 1:face_num) = reshape((/ & + 17, 11, 9, 15, -1, -1, & + 14, 8, 10, 16, -1, -1, & + 22, 24, 21, 18, -1, -1, & + 12, 5, 2, 6, -1, -1, & + 13, 19, 23, 20, -1, -1, & + 4, 1, 3, 7, -1, -1, & + 19, 13, 7, 3, 8, 14, & + 15, 9, 4, 7, 13, 20, & + 16, 10, 5, 12, 18, 21, & + 22, 18, 12, 6, 11, 17, & + 20, 23, 24, 22, 17, 15, & + 14, 16, 21, 24, 23, 19, & + 9, 11, 6, 2, 1, 4, & + 3, 1, 2, 5, 10, 8/), (/face_order_max, face_num/)) + + return +end +subroutine truncated_octahedron_size_3d(point_num, edge_num, face_num, & + face_order_max) + +!*****************************************************************************80 +! +!! TRUNCATED_OCTAHEDRON_SIZE_3D gives "sizes" for a truncated octahedron in 3D. +! +! Discussion: +! +! The truncated octahedron is "space-filling". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 July 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) POINT_NUM, the number of points. +! +! Output, integer ( kind = 4 ) EDGE_NUM, the number of edges. +! +! Output, integer ( kind = 4 ) FACE_NUM, the number of faces. +! +! Output, integer ( kind = 4 ) FACE_ORDER_MAX, the maximum order of any face. +! + implicit none + + integer(kind=4) edge_num + integer(kind=4) face_num + integer(kind=4) face_order_max + integer(kind=4) point_num + + point_num = 24 + edge_num = 36 + face_num = 14 + face_order_max = 6 + + return +end +subroutine tube_2d(dist, n, p, p1, p2) + +!*****************************************************************************80 +! +!! TUBE_2D constructs a "tube" of given width around a path in 2D. +! +! Discussion: +! +! The routine is given a sequence of N points, and a distance DIST. +! +! It returns the coordinates of the corners of the top and bottom +! of a tube of width 2*DIST, which envelopes the line connecting +! the points. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) DIST, the radius of the tube. +! +! Input, integer ( kind = 4 ) N, the number of points defining the line. +! N must be at least 2. +! +! Input, real ( kind = 8 ) P(2,N), the points which comprise the broken +! line which is to be surrounded by the tube. Points should +! not be immediately repeated, that is, it should never be +! the case that +! P(1,I) = P(1,I+1) and P(2,I) = P(2,I+1). +! +! Output, real ( kind = 8 ) P1(2,N), P2(2,N), the points P1 form +! one side of the tube, and P2 the other. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) a + real(kind=8) b + real(kind=8) c + real(kind=8) dis1 + real(kind=8) dis2 + real(kind=8) dist + integer(kind=4) i + integer(kind=4) i4_wrap + integer(kind=4) im1 + integer(kind=4) ip1 + real(kind=8) p(dim_num, n) + real(kind=8) p1(dim_num, n) + real(kind=8) p2(dim_num, n) + real(kind=8) temp +! +! Check that N is at least 3. +! + if (n < 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'TUBE_2D - Fatal error!' + write (*, '(a)') ' N must be at least 3' + write (*, '(a,i8)') ' but your input value was N = ', n + stop 1 + end if +! +! Check that consecutive points are distinct. +! + do i = 1, n - 1 + if (all(p(1:2, i) == p(1:2, i + 1))) then + write (*, '(a)') ' ' + write (*, '(a)') 'TUBE_2D - Fatal error!' + write (*, '(a,i8)') ' P(1:2,I) = P(1:2,I+1) for I = ', i + write (*, '(a,2g14.6)') ' P(1:2,I) = ', p(1:2, i) + stop 1 + end if + end do + + do i = 1, n + + im1 = i4_wrap(i - 1, 1, n) + ip1 = i4_wrap(i + 1, 1, n) + + call angle_box_2d(dist, p(1:2, im1), p(1:2, i), & + p(1:2, ip1), p1(1:2, i), p2(1:2, i)) +! +! On the first and last steps, translate the corner points DIST units +! along the line, to make an extra buffer. +! + if (i == 1) then + + temp = sqrt((p(1, 2) - p(1, 1))**2 + (p(2, 2) - p(2, 1))**2) + p1(1:2, 1) = p1(1:2, 1) - dist * (p(1:2, 2) - p(1:2, 1)) / temp + p2(1:2, 1) = p2(1:2, 1) - dist * (p(1:2, 2) - p(1:2, 1)) / temp + + else if (i == n) then + + temp = sqrt((p(1, n) - p(1, n - 1))**2 + (p(2, n) - p(2, n - 1))**2) + p1(1:2, n) = p1(1:2, n) + dist * (p(1:2, n) - p(1:2, n - 1)) / temp + p2(1:2, n) = p2(1:2, n) + dist * (p(1:2, n) - p(1:2, n - 1)) / temp + + end if +! +! The new points P1 and P2 may need to be swapped. +! +! Compute the signed distance from the points to the line. +! + if (1 < i) then + + a = p(2, i - 1) - p(2, i) + b = p(1, i) - p(1, i - 1) + c = p(1, i - 1) * p(2, i) - p(1, i) * p(2, i - 1) + + dis1 = (a * p1(1, i - 1) + b * p1(2, i - 1) + c) / sqrt(a * a + b * b) + + dis2 = (a * p1(1, i) + b * p1(2, i) + c) / sqrt(a * a + b * b) + + if (sign(1.0D+00, dis1) /= sign(1.0D+00, dis2)) then + + call r8_swap(p1(1, i), p2(1, i)) + call r8_swap(p1(2, i), p2(2, i)) + + end if + + end if + + end do + + return +end +subroutine vector_directions_nd(dim_num, v, angle) + +!*****************************************************************************80 +! +!! VECTOR_DIRECTIONS_ND returns the direction angles of a vector in ND. +! +! Discussion: +! +! Let V be the vector, and let E(I) be the I-th unit coordinate axis vector. +! The I-th direction angle is the angle between V and E(I), which is +! the angle whose cosine is equal to the direction cosine: +! +! Direction_Cosine(I) = V dot E(I) / |V|. +! +! If V is the null or zero vector, then the direction cosines and +! direction angles are undefined, and this routine simply returns +! zeroes. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) V(DIM_NUM), the vector. +! +! Output, real ( kind = 8 ) ANGLE(DIM_NUM), the direction angles, in radians, +! that the vector V makes with the coordinate axes. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) angle(dim_num) + real(kind=8) v(dim_num) + real(kind=8) vnorm +! +! Get the norm of the vector. +! + vnorm = sqrt(sum(v(1:dim_num)**2)) + + if (vnorm == 0.0D+00) then + angle(1:dim_num) = 0.0D+00 + return + end if + + angle(1:dim_num) = acos(v(1:dim_num) / vnorm) + + return +end +subroutine vector_rotate_2d(v, angle, w) + +!*****************************************************************************80 +! +!! VECTOR_ROTATE_2D rotates a vector around the origin in 2D. +! +! Discussion: +! +! To see why this formula is so, consider that the original point +! has the form ( R cos Theta, R sin Theta ), and the rotated point +! has the form ( R cos ( Theta + Angle ), R sin ( Theta + Angle ) ). +! Now use the addition formulas for cosine and sine to relate +! the new point to the old one: +! +! ( W1 ) = ( cos Angle - sin Angle ) * ( V1 ) +! ( W2 ) ( sin Angle cos Angle ) ( V2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 April 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V(2), the components of the vector to be +! rotated. +! +! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation +! to be carried out. A positive angle rotates the vector in the +! counter clockwise direction. +! +! Output, real ( kind = 8 ) W(2), the rotated vector. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle + real(kind=8) v(dim_num) + real(kind=8) w(dim_num) + + w(1) = cos(angle) * v(1) - sin(angle) * v(2) + w(2) = sin(angle) * v(1) + cos(angle) * v(2) + + return +end +subroutine vector_rotate_3d(v1, axis, angle, v2) + +!*****************************************************************************80 +! +!! VECTOR_ROTATE_3D rotates a vector around an axis vector in 3D. +! +! Discussion: +! +! Thanks to Cody Farnell for correcting some errors in a previous +! version of this routine! +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 August 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) V1(3), the vector to be rotated. +! +! Input, real ( kind = 8 ) AXIS(3), the vector about which the +! rotation is to be carried out. +! +! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation +! to be carried out. +! +! Output, real ( kind = 8 ) V2(3), the rotated vector. +! + implicit none + + real(kind=8) angle + real(kind=8) axis(3) + real(kind=8) dot + real(kind=8) norm + real(kind=8) norm_vn + real(kind=8) normal2(3) + real(kind=8) r8vec_norm + real(kind=8) v1(3) + real(kind=8) v2(3) + real(kind=8) vn(3) + real(kind=8) vp(3) + real(kind=8) vr(3) +! +! Compute the length of the rotation axis. +! + norm = r8vec_norm(3, axis) + + if (norm == 0.0D+00) then + v2(1:3) = v1(1:3) + return + end if +! +! Compute the dot product of the vector and the (unit) rotation axis. +! + dot = dot_product(v1(1:3), axis(1:3)) / norm +! +! Compute the parallel component of the vector. +! + vp(1:3) = dot * axis(1:3) / norm +! +! Compute the normal component of the vector. +! + vn(1:3) = v1(1:3) - vp(1:3) + + norm_vn = r8vec_norm(3, vn) + + if (norm_vn == 0.0D+00) then + v2(1:3) = vp(1:3) + return + end if + + vn(1:3) = vn(1:3) / norm_vn +! +! Compute a second vector, lying in the plane, perpendicular +! to V1 and VN, and forming a right-handed system. +! + normal2(1) = axis(2) * vn(3) - axis(3) * vn(2) + normal2(2) = axis(3) * vn(1) - axis(1) * vn(3) + normal2(3) = axis(1) * vn(2) - axis(2) * vn(1) + + norm = r8vec_norm(3, normal2) + if (norm /= 0.0D+00) then + normal2(1:3) = normal2(1:3) / norm + end if +! +! Rotate the normal component by the angle. +! + vr(1:3) = norm_vn * (cos(angle) * vn(1:3) + sin(angle) * normal2(1:3)) +! +! The rotated vector is the parallel component plus the rotated component. +! + v2(1:3) = vp(1:3) + vr(1:3) + + return +end +subroutine vector_rotate_base_2d(p1, pb, angle, p2) + +!*****************************************************************************80 +! +!! VECTOR_ROTATE_BASE_2D rotates a vector around a base point in 2D. +! +! Discussion: +! +! The original vector is assumed to be ( X1-XB, Y1-YB ), and the +! rotated vector is ( X2-XB, Y2-YB ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), the endpoint of the original vector. +! +! Input, real ( kind = 8 ) PB(2), the location of the base point. +! +! Input, real ( kind = 8 ) ANGLE, the angle, in radians, of the rotation +! to be carried out. A positive angle rotates the vector in the +! counter clockwise direction. +! +! Output, real ( kind = 8 ) P2(2), the endpoint of the rotated vector. +! + implicit none + + integer(kind=4), parameter :: dim_num = 2 + + real(kind=8) angle + real(kind=8) p1(2) + real(kind=8) p2(2) + real(kind=8) pb(2) + + p2(1) = pb(1) + cos(angle) * (p1(1) - pb(1)) & + - sin(angle) * (p1(2) - pb(2)) + + p2(2) = pb(2) + sin(angle) * (p1(1) - pb(1)) & + + cos(angle) * (p1(2) - pb(2)) + + return +end +subroutine vector_separation_nd(dim_num, v1, v2, theta) + +!*****************************************************************************80 +! +!! VECTOR_SEPARATION_ND finds the angular separation between vectors in ND. +! +! Discussion: +! +! Any two vectors lie in a plane, and are separated by a plane angle. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 December 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the two vectors. +! +! Output, real ( kind = 8 ) THETA, the angle between the two vectors. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) cos_theta + real(kind=8) r8_acos + real(kind=8) theta + real(kind=8) v1(dim_num) + real(kind=8) v1_norm + real(kind=8) v2(dim_num) + real(kind=8) v2_norm + + v1_norm = sqrt(sum(v1(1:dim_num)**2)) + + v2_norm = sqrt(sum(v2(1:dim_num)**2)) + + cos_theta = dot_product(v1(1:dim_num), v2(1:dim_num)) & + / (v1_norm * v2_norm) + + theta = r8_acos(cos_theta) + + return +end +subroutine vector_unit_nd(dim_num, v) + +!*****************************************************************************80 +! +!! VECTOR_UNIT_ND normalizes a vector in ND. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 07 February 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input/output, real ( kind = 8 ) V(DIM_NUM), the vector to be normalized. +! On output, V should have unit Euclidean norm. However, if the input vector +! has zero Euclidean norm, it is not altered. +! + implicit none + + integer(kind=4) dim_num + + real(kind=8) norm + real(kind=8) v(dim_num) + + norm = sqrt(sum(v(1:dim_num)**2)) + + if (norm /= 0.0D+00) then + v(1:dim_num) = v(1:dim_num) / norm + end if + + return +end +function voxels_dist_l1_nd(dim_num, v1, v2) + +!*****************************************************************************80 +! +!! VOXELS_DIST_L1_ND computes the L1 distance between voxels in ND. +! +! Discussion: +! +! A voxel is generally a point in 3D space with integer coordinates. +! There's no reason to stick with 3D, so this routine will handle +! any dimension. +! +! We can imagine that, in traveling from V1 to V2, we are allowed to +! increment or decrement just one coordinate at a time. The minimum number +! of such changes required is the L1 distance. +! +! More formally, +! +! DIST_L1 ( V1, V2 ) = sum ( 1 <= I <= N ) | V1(I) - V2(I) | +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, integer ( kind = 4 ) V1(DIM_NUM), the voxel that begins the line. +! +! Input, integer ( kind = 4 ) V2(DIM_NUM), the voxel that ends the line. +! +! Output, integer ( kind = 4 ) VOXELS_DIST_L1_ND, the L1 distance +! between the voxels. +! + implicit none + + integer(kind=4) dim_num + + integer(kind=4) v1(dim_num) + integer(kind=4) v2(dim_num) + integer(kind=4) voxels_dist_l1_nd + + voxels_dist_l1_nd = sum(abs(v1(1:dim_num) - v2(1:dim_num))) + + return +end +subroutine voxels_line_3d(v1, v2, n, v) + +!*****************************************************************************80 +! +!! VOXELS_LINE_3D computes voxels along a line in 3D. +! +! Discussion: +! +! The line itself is defined by two voxels. The line will begin +! at the first voxel, and move towards the second. If the value of +! N is equal to the L1 distance between the two voxels, then the +! line will "almost" reach the second voxel. Depending on the +! direction, 1, 2 or 3 more steps may be needed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 06 March 2005 +! +! Author: +! +! Daniel Cohen +! +! FORTRAN90 version by John Burkardt +! +! Reference: +! +! Daniel Cohen, +! Voxel Traversal along a 3D Line, +! in Graphics Gems IV, +! edited by Paul Heckbert, +! AP Professional, 1994, +! T385.G6974. +! +! Parameters: +! +! Input, integer ( kind = 4 ) V1(3), the voxel that begins the line. +! +! Input, integer ( kind = 4 ) V2(3), the voxel that ends the line. +! +! Input, integer ( kind = 4 ) N, the number of voxels to compute. +! +! Output, integer ( kind = 4 ) V(3,N), a sequence of voxels, whose +! first value is V1 and which proceeds towards V2. +! + implicit none + + integer(kind=4) n + integer(kind=4), parameter :: dim_num = 3 + + integer(kind=4) a(3) + integer(kind=4) exy + integer(kind=4) exz + integer(kind=4) ezy + integer(kind=4) i + integer(kind=4) s(3) + integer(kind=4) v(3, n) + integer(kind=4) v1(3) + integer(kind=4) v2(3) + + if (n <= 0) then + return + end if +! +! Determine the number of voxels on the line. +! + s(1:dim_num) = sign(1, v2(1:dim_num) - v1(1:dim_num)) + a(1:dim_num) = abs(v2(1:dim_num) - v1(1:dim_num)) + + exy = a(2) - a(1) + exz = a(3) - a(1) + ezy = a(2) - a(3) +! +! We start at the starting point. +! + v(1:dim_num, 1) = v1(1:dim_num) + + do i = 2, n + + v(1:dim_num, i) = v(1:dim_num, i - 1) + + if (exy < 0) then + + if (exz < 0) then + v(1, i) = v(1, i) + s(1) + exy = exy + 2 * a(2) + exz = exz + 2 * a(3) + else + v(3, i) = v(3, i) + s(3) + exz = exz - 2 * a(1) + ezy = ezy + 2 * a(2) + end if + + else if (ezy < 0) then + + v(3, i) = v(3, i) + s(3) + exz = exz - 2 * a(1) + ezy = ezy + 2 * a(2) + + else + + v(2, i) = v(2, i) + s(2) + exy = exy - 2 * a(1) + ezy = ezy - 2 * a(3) + + end if + + end do + + return +end +subroutine voxels_region_3d(list_max, nx, ny, nz, ishow, list_num, list, & + region_num) + +!*****************************************************************************80 +! +!! VOXELS_REGION_3D arranges contiguous voxels into regions in 3D. +! +! Discussion: +! +! On input, the ISHOW array contains zero and nonzero values. The nonzero +! values are taken to be active voxels. On output, the zero voxels remain +! zero, and all the active voxels have been assigned a value which now +! indicates membership in a region, or group of contiguous voxels. +! +! On output, the array LIST contains information about the regions. +! The last used element of LIST is LIST_NUM. +! +! The number of elements in region REGION_NUM is NELEM = LIST(LIST_NUM). +! The (I,J,K) indices of the last element in this region are in +! LIST(LIST_NUM-3) through LIST(LIST_NUM-1), and the first element is +! listed in LIST(LIST_NUM-3*NELEM), LIST(LIST_NUM-3*NELEM+1), +! LIST(LIST_NUM-3*NELEM+2). +! +! The number of elements in REGION_NUM-1 is listed in +! LIST(LIST_NUM-3*NELEM-1), +! and the (I,J,K) indices of the these elements are listed there. +! +! Thanks to Emre Evren for pointing out a hard-to-spot error involving +! a DO loop that mistakenly read "DO 1 = 1, N". +! +! Picture: +! +! Input: +! +! 0 2 0 0 17 0 3 +! 0 0 3 0 1 0 4 +! 1 0 4 8 8 0 7 +! 3 0 6 45 0 0 0 +! 3 17 0 5 9 2 5 +! +! Output: +! +! 0 1 0 0 2 0 3 +! 0 0 2 0 2 0 3 +! 4 0 2 2 2 0 3 +! 4 0 2 2 0 0 0 +! 4 4 0 2 2 2 2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 March 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) LIST_MAX, the maximum length of the array +! used to list the elements of the regions. +! +! Input, integer ( kind = 4 ) NX, NY, NZ, the number of voxels in the X, Y +! and Z directions. +! +! Input/output, integer ( kind = 4 ) ISHOW(NX,NY,NZ). On input, the only +! significance to the entries is whether they are zero or nonzero. On +! output, the nonzero entries have now been revalued so that contiguous +! entries have the same value, indicating a grouping into a region. +! +! Output, integer ( kind = 4 ) LIST_NUM, the number of entries of LIST that +! were used. However, if LIST_MAX < LIST_NUM, then there was not enough +! space in LIST to store the data properly, and LIST should not be used, +! although the data in ISHOW should be correct. +! +! Output, integer ( kind = 4 ) LIST(LIST_MAX), contains, in stack form, a +! list of the indices of the elements in each region. +! +! Output, integer ( kind = 4 ) REGION_NUM, the number of regions discovered. +! + implicit none + + integer(kind=4), parameter :: maxstack = 100 + + integer(kind=4) list_max + integer(kind=4) nx + integer(kind=4) ny + integer(kind=4) nz + + integer(kind=4) i + integer(kind=4) i2 + integer(kind=4) ibase + integer(kind=4) ihi + integer(kind=4) ilo + integer(kind=4) ishow(nx, ny, nz) + integer(kind=4) j + integer(kind=4) j2 + integer(kind=4) jbase + integer(kind=4) jhi + integer(kind=4) jlo + integer(kind=4) k + integer(kind=4) k2 + integer(kind=4) kbase + integer(kind=4) khi + integer(kind=4) klo + integer(kind=4) list(list_max) + integer(kind=4) list_num + integer(kind=4) nabes + integer(kind=4) ncan + integer(kind=4) nelements + integer(kind=4) nstack + integer(kind=4) region_num + integer(kind=4) stack(maxstack) +! +! Reset all nonzero entries of ISHOW to -1. +! + do k = 1, nz + do j = 1, ny + do i = 1, nx + + if (ishow(i, j, k) /= 0) then + ishow(i, j, k) = -1 + end if + + end do + end do + end do +! +! Start the number of items in the region list at 0. +! + list_num = 0 +! +! Start the number of regions at 0. +! + region_num = 0 +! +! The stack begins empty. +! + nstack = 0 +! +! Search for an unused "ON" voxel from which we can "grow" a new region. +! + do k = 1, nz + do j = 1, ny + do i = 1, nx +! +! We found a voxel that is "ON", and does not belong to any region. +! + if (ishow(i, j, k) == -1) then +! +! Increase the number of regions. +! + region_num = region_num + 1 +! +! Add this voxel to the region. +! + ishow(i, j, k) = region_num +! +! Add this voxel to the stack. +! + if (maxstack < nstack + 4) then + write (*, '(a)') ' ' + write (*, '(a)') 'VOXELS_REGION - Fatal error!' + write (*, '(a)') ' The internal stack overflowed.' + write (*, '(a)') ' The algorithm has failed.' + stop 1 + end if + + stack(nstack + 1) = i + stack(nstack + 2) = j + stack(nstack + 3) = k + stack(nstack + 4) = 1 + + nstack = nstack + 4 +! +! Add this voxel to the description of the region. +! + nelements = 1 + + if (list_num + 3 <= list_max) then + list(list_num + 1) = i + list(list_num + 2) = j + list(list_num + 3) = k + end if + + list_num = list_num + 3 + + do +! +! Find all neighbors of BASE that are "ON" but unused. +! Mark them as belonging to this region, and stack their indices. +! + ibase = stack(nstack - 3) + jbase = stack(nstack - 2) + kbase = stack(nstack - 1) + + ilo = max(ibase - 1, 1) + ihi = min(ibase + 1, nx) + jlo = max(jbase - 1, 1) + jhi = min(jbase + 1, ny) + klo = max(kbase - 1, 1) + khi = min(kbase + 1, nz) + + nabes = 0 + + do i2 = ilo, ihi + do j2 = jlo, jhi + do k2 = klo, khi +! +! We found a neighbor to our current search point, which is "ON" and unused. +! + if (ishow(i2, j2, k2) == -1) then +! +! Increase the number of neighbors. +! + nabes = nabes + 1 +! +! Mark the neighbor as belonging to the region. +! + ishow(i2, j2, k2) = region_num +! +! Add the neighbor to the stack. +! + if (maxstack < nstack + 3) then + write (*, '(a)') ' ' + write (*, '(a)') 'VOXELS_REGION - Fatal error!' + write (*, '(a)') ' The internal stack overflowed.' + write (*, '(a)') ' The algorithm has failed.' + stop 1 + end if + + stack(nstack + 1) = i2 + stack(nstack + 2) = j2 + stack(nstack + 3) = k2 + + nstack = nstack + 3 +! +! Add the neighbor to the description of the region. +! + nelements = nelements + 1 + + if (list_num + 3 <= list_max) then + list(list_num + 1) = i2 + list(list_num + 2) = j2 + list(list_num + 3) = k2 + end if + + list_num = list_num + 3 + + end if + + end do + end do + end do +! +! If any new neighbors were found, take the last one as the basis +! for a deeper search. +! + if (0 < nabes) then + + if (maxstack < nstack + 1) then + write (*, '(a)') ' ' + write (*, '(a)') 'VOXELS_REGION - Fatal error!' + write (*, '(a)') ' The internal stack overflowed.' + write (*, '(a)') ' The algorithm has failed.' + stop 1 + end if + + stack(nstack + 1) = nabes + nstack = nstack + 1 + cycle + + end if +! +! If the current search point had no new neighbors, drop it from the stack. +! + ncan = stack(nstack) - 1 + nstack = nstack - 3 + stack(nstack) = ncan +! +! If there are still any unused candidates at this level, take the +! last one as the basis for a deeper search. +! + if (0 < stack(nstack)) then + cycle + end if +! +! If there are no more unused candidates at this level, then we need +! to back up a level in the stack. If there are any candidates at +! that earlier level, then we can still do more searching. +! + nstack = nstack - 1 + + if (nstack <= 0) then + exit + end if + + end do +! +! If we have exhausted the stack, we have completed this region. +! Tag the number of elements to the end of the region description list. +! + list_num = list_num + 1 + if (list_num <= list_max) then + list(list_num) = nelements + end if + + end if + + end do + end do + end do +! +! Print some warnings. +! + if (list_max < list_num) then + write (*, '(a)') ' ' + write (*, '(a)') 'VOXELS_REGION - Warning!' + write (*, '(a)') ' LIST_MAX was too small to list the regions.' + write (*, '(a)') ' Do not try to use the LIST array!' + write (*, '(a)') ' The ISHOW data is OK, however.' + end if + + return +end +subroutine voxels_step_3d(v1, v2, inc, jnc, knc, v3) + +!*****************************************************************************80 +! +!! VOXELS_STEP_3D computes voxels along a line from a given point in 3D. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 September 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) V1(3), the coordinates of the base voxel from +! which the line begins. +! +! Input, integer ( kind = 4 ) V2(3), the coordinates of the current voxel +! on the line. For the first call, these might be equal to V1. +! +! Input, integer ( kind = 4 ) INC, JNC, KNC, the increments to the voxels. +! These values define the direction along which the line proceeds. +! However, the voxels on the line will typically be incremented +! by a fractional value of the vector (INC,JNC,KNC), and the +! result is essentially rounded. +! +! Output, integer ( kind = 4 ) V3(3), the coordinates of the next voxel along +! the line. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) alpha + real(kind=8) alphai + real(kind=8) alphaj + real(kind=8) alphak + integer(kind=4) inc + integer(kind=4) jnc + integer(kind=4) knc + integer(kind=4) v1(3) + integer(kind=4) v2(3) + integer(kind=4) v3(3) + + v3(1:dim_num) = v2(1:dim_num) +! +! Assuming for the moment that (I,J,K) can take on real values, +! points on the line have the form: +! +! I = V1(2) + alpha * inc +! J = V1(2) + alpha * jnc +! K = V1(3) + alpha * knc +! + if (inc == 0 .and. jnc == 0 .and. knc == 0) then + return + end if + + alpha = 0.0D+00 +! +! Compute the smallest ALPHA that will change one of V2(1:3) by +-0.5. +! + if (0 < inc) then + alphai = (real(v2(1) - v1(1), kind=8) + 0.5D+00) & + / real(inc, kind=8) + else if (inc < 0) then + alphai = (real(v2(1) - v1(1), kind=8) - 0.5D+00) & + / real(inc, kind=8) + else + alphai = huge(alphai) + end if + + if (0 < jnc) then + alphaj = (real(v2(2) - v1(2), kind=8) + 0.5D+00) & + / real(jnc, kind=8) + else if (jnc < 0) then + alphaj = (real(v2(2) - v1(2), kind=8) - 0.5D+00) & + / real(jnc, kind=8) + else + alphaj = huge(alphaj) + end if + + if (0 < knc) then + alphak = (real(v2(3) - v1(3), kind=8) + 0.5D+00) & + / real(knc, kind=8) + else if (knc < 0) then + alphak = (real(v2(3) - v1(3), kind=8) - 0.5D+00) & + / real(knc, kind=8) + else + alphaj = huge(alphaj) + end if +! +! The ALPHA of smallest positive magnitude represents the closest next voxel. +! + alpha = huge(alpha) + + if (0.0D+00 < alphai) then + alpha = min(alpha, alphai) + end if + + if (0.0D+00 < alphaj) then + alpha = min(alpha, alphaj) + end if + + if (0.0D+00 < alphak) then + alpha = min(alpha, alphak) + end if +! +! Move to the new voxel. Whichever index just made the half +! step must be forced to take a whole step. +! + if (alpha == alphai) then + v3(1) = v2(1) + sign(1, inc) + v3(2) = v1(2) + nint(alpha * real(jnc, kind=8)) + v3(3) = v1(3) + nint(alpha * real(knc, kind=8)) + else if (alpha == alphaj) then + v3(1) = v1(1) + nint(alpha * real(inc, kind=8)) + v3(2) = v2(2) + sign(1, jnc) + v3(3) = v1(3) + nint(alpha * real(knc, kind=8)) + else if (alpha == alphak) then + v3(1) = v1(1) + nint(alpha * real(inc, kind=8)) + v3(2) = v1(2) + nint(alpha * real(jnc, kind=8)) + v3(3) = v2(3) + sign(1, knc) + end if + + return +end +function wedge01_volume() + +!*****************************************************************************80 +! +!! WEDGE01_VOLUME: volume of the unit wedge in 3D. +! +! Discussion: +! +! The integration region is defined as: +! +! 0 <= X +! 0 <= Y +! X + Y <= 1 +! -1 <= Z <= 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, real ( kind = 8 ) WEDGE01_VOLUME, the volume. +! + implicit none + + real(kind=8) wedge01_volume + + wedge01_volume = 1.0D+00 + + return +end +subroutine xy_to_polar(xy, r, t) + +!*****************************************************************************80 +! +!! XY_TO_POLAR converts XY coordinates to polar coordinates. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 January 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) XY(2), the Cartesian coordinates. +! +! Output, real ( kind = 8 ) R, T, the radius and angle (in radians). +! + implicit none + + real(kind=8) r + real(kind=8) r8_atan + real(kind=8) t + real(kind=8) xy(2) + + r = sqrt(xy(1) * xy(1) + xy(2) * xy(2)) + + if (r == 0.0D+00) then + t = 0.0D+00 + else + t = r8_atan(xy(2), xy(1)) + end if + + return +end +subroutine xyz_to_radec(p, ra, dec) + +!*****************************************************************************80 +! +!! XYZ_TO_RADEC converts (X,Y,Z) to right ascension/declination coordinates. +! +! Discussion: +! +! Given an XYZ point, compute its distance R from the origin, and +! regard it as lying on a sphere of radius R, whose axis is the Z +! axis. +! +! The right ascension of the point is the "longitude", measured in hours, +! between 0 and 24, with the X axis having right ascension 0, and the +! Y axis having right ascension 6. +! +! Declination measures the angle from the equator towards the north pole, +! and ranges from -90 (South Pole) to 90 (North Pole). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 28 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P(3), the coordinates of a point in 3D. +! +! Output, real ( kind = 8 ) RA, DEC, the corresponding right ascension +! and declination. +! + implicit none + + integer(kind=4), parameter :: dim_num = 3 + + real(kind=8) dec + real(kind=8) p(dim_num) + real(kind=8) p_norm + real(kind=8) phi + real(kind=8) r8_asin + real(kind=8) r8_atan + real(kind=8) ra + real(kind=8) radians_to_degrees + real(kind=8) theta + + p_norm = sqrt(sum(p(1:dim_num)**2)) + + if (p_norm == 0.0D+00) then + dec = 0.0D+00 + ra = 0.0D+00 + return + end if + + phi = r8_asin(p(3) / p_norm) + + if (cos(phi) == 0.0D+00) then + theta = 0.0D+00 + else + theta = r8_atan(p(2), p(1)) + end if + + dec = radians_to_degrees(phi) + ra = radians_to_degrees(theta) / 15.0D+00 + + return +end +subroutine xyz_to_rtp(xyz, r, theta, phi) + +!*****************************************************************************80 +! +!! XYZ_TO_RTP converts (X,Y,Z) to (R,Theta,Phi) coordinates. +! +! Discussion: +! +! Given an XYZ point, compute its distance R from the origin, and +! regard it as lying on a sphere of radius R, whose axis is the Z +! axis. +! +! Theta measures the "longitude" of the point, between 0 and 2 PI. +! +! PHI measures the angle from the "north pole", between 0 and PI. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 January 2007 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) XYZ(3), the coordinates of a point in 3D. +! +! Output, real ( kind = 8 ) R, THETA, PHI, the radius, longitude and +! declination of the point. +! + implicit none + + real(kind=8) r + real(kind=8) r8_acos + real(kind=8) r8_atan + real(kind=8) phi + real(kind=8) theta + real(kind=8) xyz(3) + + r = sqrt(sum(xyz(1:3)**2)) + + if (r == 0.0D+00) then + theta = 0.0D+00 + phi = 0.0D+00 + return + end if + + phi = r8_acos(xyz(3) / r) + + theta = r8_atan(xyz(2), xyz(1)) + + return +end +subroutine xyz_to_tp(xyz, theta, phi) + +!*****************************************************************************80 +! +!! XYZ_TO_TP converts (X,Y,Z) to (Theta,Phi) coordinates. +! +! Discussion: +! +! Given an XYZ point, regard it as lying on a sphere of radius R, +! centered at the origin, whose axis is the Z axis. +! +! We assume that the actual value of R is of no interest, and do +! not report it. This is especially appropriate if the point is +! expected to lie on the unit sphere, for instance. +! +! THETA measures the "longitude" of the point, between 0 and 2 PI. +! +! PHI measures the angle from the "north pole", between 0 and PI. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 September 2010 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) XYZ(3), the coordinates of a point in 3D. +! +! Output, real ( kind = 8 ) THETA, PHI, the longitude and declination +! of the point. +! + implicit none + + real(kind=8) r + real(kind=8) r8_acos + real(kind=8) r8_atan + real(kind=8) phi + real(kind=8) theta + real(kind=8) xyz(3) + + r = sqrt(sum(xyz(1:3)**2)) + + if (r == 0.0D+00) then + theta = 0.0D+00 + phi = 0.0D+00 + return + end if + + phi = r8_acos(xyz(3) / r) + + theta = r8_atan(xyz(2), xyz(1)) + + return +end diff --git a/src/modules/GlobalData/CMakeLists.txt b/src/modules/GlobalData/CMakeLists.txt new file mode 100644 index 000000000..4c192ea45 --- /dev/null +++ b/src/modules/GlobalData/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}/GlobalData.F90" +) \ No newline at end of file diff --git a/src/modules/GlobalData/src/ElementNames.txt b/src/modules/GlobalData/src/ElementNames.txt new file mode 100644 index 000000000..dab0f7895 --- /dev/null +++ b/src/modules/GlobalData/src/ElementNames.txt @@ -0,0 +1,138 @@ +#define MSH_LIN_2 1 +#define MSH_TRI_3 2 +#define MSH_QUA_4 3 +#define MSH_TET_4 4 +#define MSH_HEX_8 5 +#define MSH_PRI_6 6 +#define MSH_PYR_5 7 +#define MSH_LIN_3 8 +#define MSH_TRI_6 9 +#define MSH_QUA_9 10 +#define MSH_TET_10 11 +#define MSH_HEX_27 12 +#define MSH_PRI_18 13 +#define MSH_PYR_14 14 +#define MSH_PNT 15 +#define MSH_QUA_8 16 +#define MSH_HEX_20 17 +#define MSH_PRI_15 18 +#define MSH_PYR_13 19 +#define MSH_TRI_9 20 +#define MSH_TRI_10 21 +#define MSH_TRI_12 22 +#define MSH_TRI_15 23 +#define MSH_TRI_15I 24 +#define MSH_TRI_21 25 +#define MSH_LIN_4 26 +#define MSH_LIN_5 27 +#define MSH_LIN_6 28 +#define MSH_TET_20 29 +#define MSH_TET_35 30 +#define MSH_TET_56 31 +#define MSH_TET_22 32 +#define MSH_TET_28 33 +#define MSH_POLYG_ 34 +#define MSH_POLYH_ 35 +#define MSH_QUA_16 36 +#define MSH_QUA_25 37 +#define MSH_QUA_36 38 +#define MSH_QUA_12 39 +#define MSH_QUA_16I 40 +#define MSH_QUA_20 41 +#define MSH_TRI_28 42 +#define MSH_TRI_36 43 +#define MSH_TRI_45 44 +#define MSH_TRI_55 45 +#define MSH_TRI_66 46 +#define MSH_QUA_49 47 +#define MSH_QUA_64 48 +#define MSH_QUA_81 49 +#define MSH_QUA_100 50 +#define MSH_QUA_121 51 +#define MSH_TRI_18 52 +#define MSH_TRI_21I 53 +#define MSH_TRI_24 54 +#define MSH_TRI_27 55 +#define MSH_TRI_30 56 +#define MSH_QUA_24 57 +#define MSH_QUA_28 58 +#define MSH_QUA_32 59 +#define MSH_QUA_36I 60 +#define MSH_QUA_40 61 +#define MSH_LIN_7 62 +#define MSH_LIN_8 63 +#define MSH_LIN_9 64 +#define MSH_LIN_10 65 +#define MSH_LIN_11 66 +#define MSH_LIN_B 67 +#define MSH_TRI_B 68 +#define MSH_POLYG_B 69 +#define MSH_LIN_C 70 +!! TETS COMPLETE (6->10) +#define MSH_TET_84 71 +#define MSH_TET_120 72 +#define MSH_TET_165 73 +#define MSH_TET_220 74 +#define MSH_TET_286 75 +!! TETS INCOMPLETE (6->10) +#define MSH_TET_34 79 +#define MSH_TET_40 80 +#define MSH_TET_46 81 +#define MSH_TET_52 82 +#define MSH_TET_58 83 +!! +#define MSH_LIN_1 84 +#define MSH_TRI_1 85 +#define MSH_QUA_1 86 +#define MSH_TET_1 87 +#define MSH_HEX_1 88 +#define MSH_PRI_1 89 +#define MSH_PRI_40 90 +#define MSH_PRI_75 91 +!! HEXES COMPLETE (3->9) +#define MSH_HEX_64 92 +#define MSH_HEX_125 93 +#define MSH_HEX_216 94 +#define MSH_HEX_343 95 +#define MSH_HEX_512 96 +#define MSH_HEX_729 97 +#define MSH_HEX_1000 98 +!! HEXES INCOMPLETE (3->9) +#define MSH_HEX_32 99 +#define MSH_HEX_44 100 +#define MSH_HEX_56 101 +#define MSH_HEX_68 102 +#define MSH_HEX_80 103 +#define MSH_HEX_92 104 +#define MSH_HEX_104 105 +!! PRISMS COMPLETE (5->9) +#define MSH_PRI_126 106 +#define MSH_PRI_196 107 +#define MSH_PRI_288 108 +#define MSH_PRI_405 109 +#define MSH_PRI_550 110 +!! PRISMS INCOMPLETE (3->9) +#define MSH_PRI_24 111 +#define MSH_PRI_33 112 +#define MSH_PRI_42 113 +#define MSH_PRI_51 114 +#define MSH_PRI_60 115 +#define MSH_PRI_69 116 +#define MSH_PRI_78 117 +!! PYRAMIDS COMPLETE (3->9) +#define MSH_PYR_30 118 +#define MSH_PYR_55 119 +#define MSH_PYR_91 120 +#define MSH_PYR_140 121 +#define MSH_PYR_204 122 +#define MSH_PYR_285 123 +#define MSH_PYR_385 124 + +!! PYRAMIDS INCOMPLETE (3->9) +#define MSH_PYR_21 125 +#define MSH_PYR_29 126 +#define MSH_PYR_37 127 +#define MSH_PYR_45 128 +#define MSH_PYR_53 129 +#define MSH_PYR_61 130 +#define MSH_PYR_69 131 diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 new file mode 100755 index 000000000..caf86f440 --- /dev/null +++ b/src/modules/GlobalData/src/GlobalData.F90 @@ -0,0 +1,617 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 GlobalData +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INPUT_UNIT, & + & OUTPUT_UNIT, ERROR_UNIT +IMPLICIT NONE +PUBLIC + +#include "./ElementNames.txt" + +SAVE +INTEGER, PARAMETER :: stdin = INPUT_UNIT +INTEGER, PARAMETER :: stdout = OUTPUT_UNIT +INTEGER, PARAMETER :: stderr = OUTPUT_UNIT +INTEGER, PARAMETER :: endianL = 1 +INTEGER, PARAMETER :: endianB = 0 +INTEGER :: endian = endianL +#ifdef USE_Real128 +INTEGER, PARAMETER :: REAL128 = SELECTED_REAL_KIND(33, 4931) +#else +INTEGER, PARAMETER :: REAL128 = SELECTED_REAL_KIND(15, 307) +#endif +INTEGER, PARAMETER :: REAL64 = SELECTED_REAL_KIND(15, 307) +INTEGER, PARAMETER :: REAL32 = SELECTED_REAL_KIND(6, 37) +#ifdef USE_Real64 +INTEGER, PARAMETER :: Float = REAL64 ! Default +#else +INTEGER, PARAMETER :: Float = REAL32 ! Default +#endif +#ifdef USE_Real64 +INTEGER, PARAMETER :: DFP = REAL64 +#else +INTEGER, PARAMETER :: DFP = REAL32 +#endif +INTEGER, PARAMETER :: INT64 = SELECTED_INT_KIND(18) +INTEGER, PARAMETER :: INT32 = SELECTED_INT_KIND(9) +INTEGER, PARAMETER :: INT16 = SELECTED_INT_KIND(4) +INTEGER, PARAMETER :: INT8 = SELECTED_INT_KIND(2) +#ifdef USE_Int64 +INTEGER, PARAMETER :: I4B = INT64 +INTEGER, PARAMETER :: DIP = INT64 +#else +INTEGER, PARAMETER :: I4B = INT32 +INTEGER, PARAMETER :: DIP = INT32 +#endif +INTEGER, PARAMETER :: SP = REAL32 +INTEGER, PARAMETER :: DP = REAL64 +INTEGER, PARAMETER :: SPC = KIND((1.0_REAL32, 1.0_REAL32)) +INTEGER, PARAMETER :: DPC = KIND((1.0_REAL64, 1.0_REAL64)) +#ifdef USE_Real64 +INTEGER, PARAMETER :: DFPC = KIND((1.0_REAL64, 1.0_REAL64)) +#else +INTEGER, PARAMETER :: DFPC = KIND((1.0_REAL32, 1.0_REAL32)) +#endif +INTEGER, PARAMETER :: LGT = KIND(.TRUE.) +! Logical +! +!Format parameters +#ifdef USE_Real128 +CHARACTER(*), PARAMETER :: FReal128 = '(E42.33E4)' +#else +CHARACTER(*), PARAMETER :: FReal128 = '(E23.15E3)' +#endif +CHARACTER(*), PARAMETER :: FReal64 = '(E23.15E3)' +CHARACTER(*), PARAMETER :: FReal32 = '(E13.6E2)' +#ifdef USE_Real64 +CHARACTER(*), PARAMETER :: FReal = FReal64 +CHARACTER(*), PARAMETER :: FFloat = FReal64 +#else +CHARACTER(*), PARAMETER :: FReal = FReal32 +CHARACTER(*), PARAMETER :: FFloat = FReal32 +#endif +#ifdef USE_Real64 +CHARACTER(*), PARAMETER :: FDFP = FReal64 ! Default +#else +CHARACTER(*), PARAMETER :: FDFP = FReal32 ! Default +#endif +CHARACTER(*), PARAMETER :: FInt64 = '(I20)' +CHARACTER(*), PARAMETER :: FInt64ZP = '(I20.19)' +CHARACTER(*), PARAMETER :: FInt32 = '(I11)' +CHARACTER(*), PARAMETER :: FInt32ZP = '(I11.10)' +CHARACTER(*), PARAMETER :: FInt16 = '(I6)' +CHARACTER(*), PARAMETER :: FInt16ZP = '(I6.5)' +CHARACTER(*), PARAMETER :: FInt8 = '(I4)' +CHARACTER(*), PARAMETER :: FInt8ZP = '(I4.3)' +#ifdef USE_Int64 +CHARACTER(*), PARAMETER :: FInt = FInt64 +CHARACTER(*), PARAMETER :: FI4B = FInt64 +CHARACTER(*), PARAMETER :: FI4BZP = FInt64ZP +CHARACTER(*), PARAMETER :: FIntZP = FInt64ZP +#else +CHARACTER(*), PARAMETER :: FInt = FInt32 !Default +CHARACTER(*), PARAMETER :: FI4B = FInt32 !Default +CHARACTER(*), PARAMETER :: FI4BZP = FInt32ZP +CHARACTER(*), PARAMETER :: FIntZP = FInt32ZP +#endif +! Length (number of digits) of formatted numbers +#ifdef USE_Real128 +INTEGER, PARAMETER :: DReal128 = 42 +#else +INTEGER, PARAMETER :: DReal128 = 23 +#endif +INTEGER, PARAMETER :: DReal64 = 23 +INTEGER, PARAMETER :: DReal32 = 13 +#ifdef USE_Real64 +INTEGER, PARAMETER :: DReal = DReal64 +INTEGER, PARAMETER :: DFloat = DReal64 +INTEGER, PARAMETER :: DDFP = DReal64 +#else +INTEGER, PARAMETER :: DReal = DReal32 +INTEGER, PARAMETER :: DFloat = DReal32 +INTEGER, PARAMETER :: DDFP = DReal32 +#endif +INTEGER, PARAMETER :: DInt64 = 20 +INTEGER, PARAMETER :: DInt32 = 11 +INTEGER, PARAMETER :: DInt16 = 6 +INTEGER, PARAMETER :: DInt8 = 4 +#ifdef USE_Int64 +INTEGER, PARAMETER :: DInt = DInt64 +INTEGER, PARAMETER :: DI4B = DInt64 +#else +INTEGER, PARAMETER :: DInt = DInt32 +INTEGER, PARAMETER :: DI4B = DInt32 +#endif +! Minimum and maximum (representable) values +REAL(REAL128), PARAMETER :: TypeReal128 = 1.0 +REAL(REAL128), PARAMETER :: MinReal128 = -HUGE(1._REAL128) +REAL(REAL128), PARAMETER :: MaxReal128 = HUGE(1._REAL128) +REAL(REAL64), PARAMETER :: TypeReal64 = 1.0 +REAL(REAL64), PARAMETER :: MinReal64 = -HUGE(1._REAL64) +REAL(REAL64), PARAMETER :: MaxReal64 = HUGE(1._REAL64) +REAL(REAL32), PARAMETER :: TypeReal32 = 1.0 +REAL(REAL32), PARAMETER :: MinReal32 = -HUGE(1._REAL32) +REAL(REAL32), PARAMETER :: MaxReal32 = HUGE(1._REAL32) +#ifdef USE_Real64 +REAL(Float), PARAMETER :: MinFloat = MinReal64 +REAL(Float), PARAMETER :: MinReal = MinReal64 +REAL(Float), PARAMETER :: MaxFloat = MaxReal64 +REAL(Float), PARAMETER :: MaxReal = MaxReal64 +REAL(Float), PARAMETER :: MinDFP = MinReal64 +REAL(Float), PARAMETER :: MaxDFP = MaxReal64 +#else +REAL(Float), PARAMETER :: MinFloat = MinReal32 +REAL(Float), PARAMETER :: MinReal = MinReal32 +REAL(Float), PARAMETER :: MaxFloat = MaxReal32 +REAL(Float), PARAMETER :: MaxReal = MaxReal32 +REAL(Float), PARAMETER :: MinDFP = MinReal32 +REAL(Float), PARAMETER :: MaxDFP = MaxReal32 +#endif +REAL(DFP), PARAMETER :: TypeReal = 1.0_DFP +REAL(DFP), PARAMETER :: TypeDFP = 1.0_DFP +REAL(Float), PARAMETER :: TypeFloat = 1.0_FLOAT +INTEGER(INT64), PARAMETER :: MinInt64 = -HUGE(1_INT64), TypeInt64 = 1_INT64 +INTEGER(INT32), PARAMETER :: MinInt32 = -HUGE(1_INT32), TypeInt32 = 1_INT32 +INTEGER(INT16), PARAMETER :: MinInt16 = -HUGE(1_INT16), TypeInt16 = 1_INT16 +INTEGER(INT8), PARAMETER :: MinInt8 = -HUGE(1_INT8), TypeInt8 = 1_INT8 +#ifdef USE_Int64 +INTEGER(DIP), PARAMETER :: MinInt = MinInt64 +INTEGER(I4B), PARAMETER :: MinI4B = MinInt64 +#else +INTEGER(DIP), PARAMETER :: MinInt = MinInt32 +INTEGER(I4B), PARAMETER :: MinI4B = MinInt32 +#endif +INTEGER(DIP), PARAMETER :: TypeInt = 1 +INTEGER(DIP), PARAMETER :: TypeIntI4B = 1 +INTEGER(INT64), PARAMETER :: MaxInt64 = HUGE(1_INT64) +INTEGER(INT32), PARAMETER :: MaxInt32 = HUGE(1_INT32) +INTEGER(INT16), PARAMETER :: MaxInt16 = HUGE(1_INT16) +INTEGER(INT8), PARAMETER :: MaxInt8 = HUGE(1_INT8) +#ifdef USE_Int64 +INTEGER(DIP), PARAMETER :: MaxI4B = MaxInt64 !default +INTEGER(DIP), PARAMETER :: MaxInt = MaxInt64 !default +#else +INTEGER(DIP), PARAMETER :: MaxI4B = MaxInt32 !default +INTEGER(DIP), PARAMETER :: MaxInt = MaxInt32 !default +#endif +! Real smallest (representable) values +REAL(REAL128), PARAMETER :: smallReal128 = TINY(1._REAL128) +REAL(REAL64), PARAMETER :: smallReal64 = TINY(1._REAL64) +REAL(REAL32), PARAMETER :: smallReal32 = TINY(1._REAL32) +#ifdef USE_Real64 +REAL(Float), PARAMETER :: smallFloat = smallReal64 +REAL(Float), PARAMETER :: smallReal = smallReal64 +REAL(Float), PARAMETER :: smallDFP = smallReal64 +#else +REAL(Float), PARAMETER :: smallFloat = smallReal32 +REAL(Float), PARAMETER :: smallReal = smallReal32 +REAL(Float), PARAMETER :: smallDFP = smallReal32 +#endif +! Smallest REAL representable difference by the running calculator +REAL(REAL128), PARAMETER :: ZeroReal128 = & + & NEAREST(1._REAL128, 1._REAL128) - NEAREST(1._REAL128, -1._REAL128) +REAL(REAL64), PARAMETER :: ZeroReal64 = & + & NEAREST(1._REAL64, 1._REAL64) - NEAREST(1._REAL64, -1._REAL64) +REAL(REAL32), PARAMETER :: ZeroReal32 = & + & NEAREST(1._REAL32, 1._REAL32) - NEAREST(1._REAL32, -1._REAL32) +#ifdef USE_Real64 +REAL(Float), PARAMETER :: Zero = ZeroReal64 +#else +REAL(Float), PARAMETER :: Zero = ZeroReal32 +#endif +! Bits/bytes memory requirements +#ifdef USE_Real128 +INTEGER(INT16), PARAMETER :: BIReal128 = int(STORAGE_SIZE(MaxReal128), kind=int16) +#else +INTEGER(INT16), PARAMETER :: BIReal128 = int(STORAGE_SIZE(MaxReal64), kind=int16) +#endif +INTEGER(INT8), PARAMETER :: BIReal64 = INT(STORAGE_SIZE(MaxReal64), kind=INT8) +INTEGER(INT8), PARAMETER :: BIReal32 = INT(STORAGE_SIZE(MaxReal32), kind=INT8) +#ifdef USE_Real64 +INTEGER(INT8), PARAMETER :: BIFloat = BIReal64 !default in bits +INTEGER(INT8), PARAMETER :: BIReal = BIReal64 !default in bits +INTEGER(INT8), PARAMETER :: BIDFP = BIReal64 !default in bytes +#else +INTEGER(INT8), PARAMETER :: BIFloat = BIReal32 !default in bits +INTEGER(INT8), PARAMETER :: BIReal = BIReal32 !default in bits +INTEGER(INT8), PARAMETER :: BIDFP = BIReal32 !default in bytes +#endif +INTEGER(INT16), PARAMETER :: BYReal128 = INT(BIReal128 / 8_INT16, kind=INT16) +INTEGER(INT8), PARAMETER :: BYReal64 = INT(BIReal64 / 8_INT16, kind=INT8) +INTEGER(INT8), PARAMETER :: BYReal32 = INT(BIReal32 / 8_INT16, kind=INT8) +#ifdef USE_Real64 +INTEGER(INT8), PARAMETER :: BYFloat = INT(BYReal64, kind=INT8) +INTEGER(INT8), PARAMETER :: BYReal = INT(BYReal64, kind=INT8) +INTEGER(INT8), PARAMETER :: BYDFP = INT(BYReal64, kind=INT8) +#else +INTEGER(INT8), PARAMETER :: BYFloat = INT(BYReal32, kind=INT8) +INTEGER(INT8), PARAMETER :: BYReal = INT(BYReal32, kind=INT8) +INTEGER(INT8), PARAMETER :: BYDFP = INT(BYReal32, kind=INT8) +#endif +INTEGER(INT64), PARAMETER :: BIInt64 = INT(BIT_SIZE(MaxInt64), kind=INT64) +INTEGER(INT32), PARAMETER :: BIInt32 = INT(BIT_SIZE(MaxInt32), kind=INT32) +INTEGER(INT16), PARAMETER :: BIInt16 = INT(BIT_SIZE(MaxInt16), kind=INT16) +INTEGER(INT8), PARAMETER :: BIInt8 = INT(BIT_SIZE(MaxInt8), kind=INT8) +INTEGER(DIP), PARAMETER :: BIInt = INT(BIT_SIZE(MaxInt), kind=DIP) +INTEGER(DIP), PARAMETER :: BII4B = INT(BIT_SIZE(MaxInt), kind=DIP) +INTEGER(INT64), PARAMETER :: BYInt64 = int(BIT_SIZE(MaxInt64) / 8_INT64, kind=int64) +INTEGER(INT32), PARAMETER :: BYInt32 = int(BIT_SIZE(MaxInt32) / 8_INT32, kind=int32) +INTEGER(INT16), PARAMETER :: BYInt16 = int(BIT_SIZE(MaxInt16) / 8_INT16, kind=int16) +INTEGER(INT8), PARAMETER :: BYInt8 = int(BIT_SIZE(MaxInt8) / 8_INT8, kind=int8) +INTEGER(DIP), PARAMETER :: BYInt = INT(BIT_SIZE(MaxInt) / 8_DIP, kind=DIP) +INTEGER(DIP), PARAMETER :: BYI4B = INT(BIT_SIZE(MaxInt) / 8_DIP, kind=DIP) +REAL(DFP), PARAMETER :: Pi = 3.14159265359_DFP +REAL(DFP), PARAMETER :: Eye3(3, 3) = RESHAPE( & + & [1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.0_DFP, 0.0_DFP, 1.0_DFP], [3, 3]) +REAL(DFP), PARAMETER :: Eye2(2, 2) = RESHAPE( & + & [1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP], [2, 2]) +! Parameters for iteration data +INTEGER(I4B), PARAMETER :: RelativeConvergence = 1 +INTEGER(I4B), PARAMETER :: AbsoluteConvergence = 2 +INTEGER(I4B), PARAMETER :: ConvergenceInRes = 1 +INTEGER(I4B), PARAMETER :: ConvergenceInSol = 2 +INTEGER(I4B), PARAMETER :: ConvergenceInResSol = 3 +INTEGER(I4B), PARAMETER :: ConvergenceInSolRes = 3 +INTEGER(I4B), PARAMETER :: NormL1 = 1 +INTEGER(I4B), PARAMETER :: NormL2 = 2 +INTEGER(I4B), PARAMETER :: NormInfinity = 3 +!! +!! Type of polynomial for scale interpolation +!! +INTEGER(I4B), PARAMETER :: Monomial = 0 +INTEGER(I4B), PARAMETER :: LagrangePolynomial = 1 +INTEGER(I4B), PARAMETER :: Lagrange = LagrangePolynomial +INTEGER(I4B), PARAMETER :: SerendipityPolynomial = 2 +INTEGER(I4B), PARAMETER :: Serendipity = SerendipityPolynomial +INTEGER(I4B), PARAMETER :: HeirarchicalPolynomial = 3 +INTEGER(I4B), PARAMETER :: Heirarchical = HeirarchicalPolynomial +INTEGER(I4B), PARAMETER :: HierarchicalPolynomial = 3 +INTEGER(I4B), PARAMETER :: Hierarchical = HierarchicalPolynomial +INTEGER(I4B), PARAMETER :: HeirarchyPolynomial = 3 +INTEGER(I4B), PARAMETER :: Heirarchy = HeirarchyPolynomial +INTEGER(I4B), PARAMETER :: HierarchyPolynomial = 3 +INTEGER(I4B), PARAMETER :: Hierarchy = HierarchyPolynomial +INTEGER(I4B), PARAMETER :: Jacobi = 4 +INTEGER(I4B), PARAMETER :: Ultraspherical = 5 +INTEGER(I4B), PARAMETER :: Legendre = 6 +INTEGER(I4B), PARAMETER :: Chebyshev = 7 +INTEGER(I4B), PARAMETER :: Lobatto = 8 +INTEGER(I4B), PARAMETER :: Orthogonal = 9 +INTEGER(I4B), PARAMETER :: OrthogonalPolynomial = Orthogonal +INTEGER(I4B), PARAMETER :: UnscaledLobatto = 10 +INTEGER(I4B), PARAMETER :: HermitPolynomial = 11 +!! +!! Quadrature types +!! +INTEGER(I4B), PARAMETER :: Equidistance = 1 +INTEGER(I4B), PARAMETER :: Gauss = 2 +INTEGER(I4B), PARAMETER :: GaussRadau = 3 +INTEGER(I4B), PARAMETER :: GaussRadauLeft = 4 +INTEGER(I4B), PARAMETER :: GaussRadauRight = 5 +INTEGER(I4B), PARAMETER :: GaussLobatto = 6 +!! +INTEGER(I4B), PARAMETER :: GaussLegendre = 7 +INTEGER(I4B), PARAMETER :: GaussLegendreLobatto = 8 +INTEGER(I4B), PARAMETER :: GaussLegendreRadau = 9 +INTEGER(I4B), PARAMETER :: GaussLegendreRadauLeft = 10 +INTEGER(I4B), PARAMETER :: GaussLegendreRadauRight = 11 +!! +INTEGER(I4B), PARAMETER :: GaussChebyshev = 12 +INTEGER(I4B), PARAMETER :: GaussChebyshevRadau = 13 +INTEGER(I4B), PARAMETER :: GaussChebyshevRadauLeft = 14 +INTEGER(I4B), PARAMETER :: GaussChebyshevRadauRight = 15 +INTEGER(I4B), PARAMETER :: GaussChebyshevLobatto = 16 +!! +INTEGER(I4B), PARAMETER :: GaussJacobi = 17 +INTEGER(I4B), PARAMETER :: GaussJacobiRadau = 18 +INTEGER(I4B), PARAMETER :: GaussJacobiRadauLeft = 19 +INTEGER(I4B), PARAMETER :: GaussJacobiRadauRight = 20 +INTEGER(I4B), PARAMETER :: GaussJacobiLobatto = 21 +!! +INTEGER(I4B), PARAMETER :: GaussUltraspherical = 22 +INTEGER(I4B), PARAMETER :: GaussUltrasphericalRadau = 23 +INTEGER(I4B), PARAMETER :: GaussUltrasphericalRadauLeft = 24 +INTEGER(I4B), PARAMETER :: GaussUltrasphericalRadauRight = 25 +INTEGER(I4B), PARAMETER :: GaussUltrasphericalLobatto = 26 +!! +!! Type of quadrature points +!! +INTEGER(I4B), PARAMETER :: GaussQP = Gauss +INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre +INTEGER(I4B), PARAMETER :: GaussRadauQP = GaussRadau +INTEGER(I4B), PARAMETER :: GaussRadauLeftQP = GaussRadauLeft +INTEGER(I4B), PARAMETER :: GaussRadauRightQP = GaussRadauRight +INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto +INTEGER(I4B), PARAMETER :: GaussChebyshevQP = GaussChebyshev +!! +INTEGER(I4B), PARAMETER :: ChenBabuska = 22 !! for triangle nodes +INTEGER(I4B), PARAMETER :: Hesthaven = 23 !! for triangle nodes +INTEGER(I4B), PARAMETER :: Feket = 24 !! for triangle nodes +!! +INTEGER(I4B), PARAMETER :: BlythPozLegendre = 25 !! for triangle +INTEGER(I4B), PARAMETER :: BlythPozChebyshev = 26 !! for triangle +!! +INTEGER(I4B), PARAMETER :: IsaacLegendre = 27 !! for triangle +INTEGER(I4B), PARAMETER :: IsaacChebyshev = 28 !! for triangle +!! +!! Type of Lagrange Interpolation Points +!! +INTEGER(I4B), PARAMETER :: EquidistanceLIP = Equidistance +INTEGER(I4B), PARAMETER :: GaussLobattoLIP = GaussLobatto +INTEGER(I4B), PARAMETER :: GaussLegendreLIP = GaussLegendre +INTEGER(I4B), PARAMETER :: ChebyshevLIP = Chebyshev + +!! Types of Element domain +INTEGER(I4B), PARAMETER :: Line = MSH_LIN_2 +INTEGER(I4B), PARAMETER :: Line2 = Line +INTEGER(I4B), PARAMETER :: Line3 = MSH_LIN_3 +INTEGER(I4B), PARAMETER :: Line4 = MSH_LIN_4 +INTEGER(I4B), PARAMETER :: Line5 = MSH_LIN_5 +INTEGER(I4B), PARAMETER :: Line6 = MSH_LIN_6 +INTEGER(I4B), PARAMETER :: Line7 = MSH_LIN_7 +INTEGER(I4B), PARAMETER :: Line8 = MSH_LIN_8 +INTEGER(I4B), PARAMETER :: Line9 = MSH_LIN_9 +INTEGER(I4B), PARAMETER :: Line10 = MSH_LIN_10 +INTEGER(I4B), PARAMETER :: Line11 = MSH_LIN_11 + +INTEGER(I4B), PARAMETER :: Triangle = MSH_TRI_3 +INTEGER(I4B), PARAMETER :: Triangle3 = MSH_TRI_3 +INTEGER(I4B), PARAMETER :: Triangle6 = MSH_TRI_6 +INTEGER(I4B), PARAMETER :: Triangle9 = MSH_TRI_9 +INTEGER(I4B), PARAMETER :: Triangle10 = MSH_TRI_10 +INTEGER(I4B), PARAMETER :: Triangle12 = MSH_TRI_12 +INTEGER(I4B), PARAMETER :: Triangle15a = MSH_TRI_15 +INTEGER(I4B), PARAMETER :: Triangle15b = MSH_TRI_15I +INTEGER(I4B), PARAMETER :: Triangle15 = MSH_TRI_15 +INTEGER(I4B), PARAMETER :: Triangle18 = MSH_TRI_18 +INTEGER(I4B), PARAMETER :: Triangle21 = MSH_TRI_21 +INTEGER(I4B), PARAMETER :: Triangle21a = MSH_TRI_21 +INTEGER(I4B), PARAMETER :: Triangle21b = MSH_TRI_21I +INTEGER(I4B), PARAMETER :: Triangle24 = MSH_TRI_24 +INTEGER(I4B), PARAMETER :: Triangle27 = MSH_TRI_27 +INTEGER(I4B), PARAMETER :: Triangle28 = MSH_TRI_28 +INTEGER(I4B), PARAMETER :: Triangle30 = MSH_TRI_30 +INTEGER(I4B), PARAMETER :: Triangle36 = MSH_TRI_36 +INTEGER(I4B), PARAMETER :: Triangle45 = MSH_TRI_45 +INTEGER(I4B), PARAMETER :: Triangle55 = MSH_TRI_55 +INTEGER(I4B), PARAMETER :: Triangle66 = MSH_TRI_66 + +INTEGER(I4B), PARAMETER :: Quadrangle = MSH_QUA_4 +INTEGER(I4B), PARAMETER :: Quadrangle16 = MSH_QUA_16 +INTEGER(I4B), PARAMETER :: Quadrangle16a = MSH_QUA_16 +INTEGER(I4B), PARAMETER :: Quadrangle16b = MSH_QUA_16I +INTEGER(I4B), PARAMETER :: Quadrangle20 = MSH_QUA_20 +INTEGER(I4B), PARAMETER :: Quadrangle24 = MSH_QUA_24 +INTEGER(I4B), PARAMETER :: Quadrangle25 = MSH_QUA_25 +INTEGER(I4B), PARAMETER :: Quadrangle28 = MSH_QUA_28 +INTEGER(I4B), PARAMETER :: Quadrangle32 = MSH_QUA_32 +INTEGER(I4B), PARAMETER :: Quadrangle36 = MSH_QUA_36 +INTEGER(I4B), PARAMETER :: Quadrangle36a = MSH_QUA_36 +INTEGER(I4B), PARAMETER :: Quadrangle36b = MSH_QUA_36I +INTEGER(I4B), PARAMETER :: Quadrangle40 = MSH_QUA_40 +INTEGER(I4B), PARAMETER :: Quadrangle49 = MSH_QUA_49 +INTEGER(I4B), PARAMETER :: Quadrangle64 = MSH_QUA_64 +INTEGER(I4B), PARAMETER :: Quadrangle81 = MSH_QUA_81 +INTEGER(I4B), PARAMETER :: Quadrangle4 = MSH_QUA_4 +INTEGER(I4B), PARAMETER :: Quadrangle8 = MSH_QUA_8 +INTEGER(I4B), PARAMETER :: Quadrangle9 = MSH_QUA_9 +INTEGER(I4B), PARAMETER :: Quadrangle100 = MSH_QUA_100 +INTEGER(I4B), PARAMETER :: Quadrangle121 = MSH_QUA_121 + +!! Forder order 4, 5, and so on, we use 1601, 1602, 1603, etc. +INTEGER(I4B), PARAMETER :: Tetrahedron = 4 +INTEGER(I4B), PARAMETER :: Tetrahedron4 = 4 +INTEGER(I4B), PARAMETER :: Tetrahedron10 = 11 +INTEGER(I4B), PARAMETER :: Tetrahedron20 = 29 +INTEGER(I4B), PARAMETER :: Tetrahedron35 = 30 +INTEGER(I4B), PARAMETER :: Tetrahedron56 = 31 +INTEGER(I4B), PARAMETER :: Hexahedron = 5 +INTEGER(I4B), PARAMETER :: Hexahedron8 = 5 +INTEGER(I4B), PARAMETER :: Hexahedron27 = 12 +INTEGER(I4B), PARAMETER :: Hexahedron20 = 17 +INTEGER(I4B), PARAMETER :: Hexahedron64 = 92 +INTEGER(I4B), PARAMETER :: Hexahedron125 = 93 +INTEGER(I4B), PARAMETER :: Prism = 6 +INTEGER(I4B), PARAMETER :: Prism6 = 6 +INTEGER(I4B), PARAMETER :: Prism18 = 13 +INTEGER(I4B), PARAMETER :: Prism15 = 18 +INTEGER(I4B), PARAMETER :: Pyramid = 7 +INTEGER(I4B), PARAMETER :: Pyramid5 = 7 +INTEGER(I4B), PARAMETER :: Pyramid14 = 14 +INTEGER(I4B), PARAMETER :: Pyramid13 = 19 +INTEGER(I4B), PARAMETER :: Point = 15 +INTEGER(I4B), PARAMETER :: Point1 = 15 +INTEGER(I4B), PARAMETER :: Line1 = 15 +! Read material data from ? +INTEGER(I4B), PARAMETER :: PhysicalTag = 1 +INTEGER(I4B), PARAMETER :: GeometryTag = 2 +! ScalarDOF +INTEGER(I4B), PARAMETER :: ScalarDOF = -1 + !! Following are used in ErrorHandling.F90 +INTEGER(I4B), PARAMETER, PUBLIC :: OPT_OPEN = 1 + !! Constant for file open used by fErr +INTEGER(I4B), PARAMETER, PUBLIC :: OPT_READ = 2 + !! Constant for file read used by fErr +INTEGER(I4B), PARAMETER, PUBLIC :: OPT_WRITE = 3 + !! Constant for file write used by fErr +INTEGER(I4B), PARAMETER, PUBLIC :: OPT_CLOSE = 4 + !! Constant for file close used by fErr +INTEGER(I4B), PARAMETER, PUBLIC :: OPT_ALLOC = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: OPT_DEALLOC = 2 +! for matrix conversion ( dense to dense ) +! element matrix storage may differ from global matrix storage format +INTEGER(I4B), PARAMETER, PUBLIC :: DofToNodes = 0 + !! It is used in [[RealVector_]] and [[RealMatrix_]] +INTEGER(I4B), PARAMETER, PUBLIC :: NONE = -1 + !! It is used in [[RealVector_]] and [[RealMatrix_]] +INTEGER(I4B), PARAMETER, PUBLIC :: NodesToDOF = 1 + !! It is used in [[RealVector_]] and [[RealMatrix_]] +INTEGER(I4B), PARAMETER, PUBLIC :: DOF_FMT = 0 +INTEGER(I4B), PARAMETER, PUBLIC :: NODES_FMT = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: FMT_DOF = 0 +INTEGER(I4B), PARAMETER, PUBLIC :: FMT_NODES = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: Matrix_ROW = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: Matrix_COLUMN = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: Matrix_DIAGONAL = 0 +INTEGER(I4B), PARAMETER, PUBLIC :: SMALL_MATRIX_ROW = 10 + !! Lenght of small matrix in row dimension +INTEGER(I4B), PARAMETER, PUBLIC :: SMALL_MATRIX_LEN_COL = 10 + !! Length of small matrix in column dimension +INTEGER(I4B), PARAMETER, PUBLIC :: SMALL_VECTOR_LEN = 100 + !! Length of small vector +INTEGER(I4B), PARAMETER, PUBLIC :: OMP_THREADS_FORKED = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: OMP_THREADS_JOINED = 2 +! Related to tensors +INTEGER(I4B), PARAMETER, PUBLIC :: SymTensor = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: SkewSymTensor = -1 +INTEGER(I4B), PARAMETER, PUBLIC :: GeneralTensor = 0 +INTEGER(I4B), PARAMETER, PUBLIC :: StressTypeVoigt = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: StrainTypeVoigt = -1 +INTEGER(I4B), PARAMETER, PUBLIC :: WithSpectral = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: WithoutSpectral = -1 +INTEGER(I4B), PARAMETER, PUBLIC :: SineLode = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: CosineLode = 0 +! Related to vectors, matrices, and linear solver +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CG = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BCG = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICG = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CGS = 3 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BCGSTAB = 4 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICGSTAB = 4 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BCGSTABL = 5 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICGSTABL = 5 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GPBICG = 6 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_TFQMR = 7 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_OMN = 8 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_FOM = 8 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_ORTHOMIN = 8 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GMRES = 9 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GMR = 9 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_JACOBI = 10 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GS = 11 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_SOR = 12 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICGSAFE = 13 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CR = 14 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICR = 15 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CRS = 16 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICRSTAB = 17 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_GPBICR = 18 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_BICRSAFE = 19 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_FGMRES = 20 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_IDRS = 21 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_IDR1 = 22 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_MINRES = 23 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_COCG = 24 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_COCR = 25 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CGNR = 26 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_CGN = 26 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_DBCG = 27 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_DBICG = 27 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_DQGMRES = 28 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_SUPERLU = 29 +! Precondition sides +INTEGER(I4B), PARAMETER :: NoPrecond = 0 +INTEGER(I4B), PARAMETER :: PrecondLeft = 1 +INTEGER(I4B), PARAMETER :: PrecondRight = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: NO_PRECONDITION = NoPrecond +INTEGER(I4B), PARAMETER, PUBLIC :: LEFT_PRECONDITION = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: RIGHT_PRECONDITION = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: LEFT_RIGHT_PRECONDITION = 3 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_NONE = NoPrecond +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_JACOBI = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILU = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_SSOR = 3 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_HYBRID = 4 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_IS = 5 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_SAINV = 6 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_SAAMG = 7 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUC = 8 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ADDS = 9 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUTP = 10 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUD = 11 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUDP = 12 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILU0 = 13 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUK = 14 +INTEGER(I4B), PARAMETER, PUBLIC :: PRECOND_ILUT = 15 +! Linear solver/ linear algebra engines +INTEGER(I4B), PARAMETER, PUBLIC :: NATIVE_SERIAL = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: NATIVE_OMP = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: NATIVE_MPI = 3 +INTEGER(I4B), PARAMETER, PUBLIC :: PETSC = 4 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_SERIAL = 5 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_OMP = 6 +INTEGER(I4B), PARAMETER, PUBLIC :: LIS_MPI = 7 +! Constraint type +INTEGER(I4B), PARAMETER :: StrongBC = 1 +INTEGER(I4B), PARAMETER :: NitscheBC = 2 +INTEGER(I4B), PARAMETER :: LagrangeMultiplierBC = 3 +INTEGER(I4B), PARAMETER :: PenaltyBC = 4 +INTEGER(I4B), PARAMETER :: AugmentedBC = 5 +! Symmetric and Skewsymmertic Nitsche Formulation +INTEGER(I4B), PARAMETER :: SkewSymNitsch = 1, SymNitsche = 2 +CHARACTER(*), PARAMETER :: CHAR_BLANK = " " + !! Character representing a space symbol +CHARACTER(*), PARAMETER :: CHAR_BANG = "!" + !! Character representing a comment symbol +CHARACTER(*), PARAMETER :: CHAR_DOT = "." + !! Character representing a period +CHARACTER(*), PARAMETER :: CHAR_FSLASH = "/" + !! Character representing a forward slash +CHARACTER(*), PARAMETER :: CHAR_BSLASH = ACHAR(92) + !! Character representing a backward slash +CHARACTER(*), PARAMETER :: CHAR_COLON = ":" + !! Character representing a colon +#ifdef WIN32 +CHARACTER(*), PARAMETER :: CHAR_SLASH = CHAR_BSLASH + !! This is needed for doxygen to parse correctly + !! The slash symbol used by the file system + !! (BLASH for Windows, FSLASH for everything else) +#else +CHARACTER(*), PARAMETER :: CHAR_SLASH = CHAR_FSLASH + !! The slash symbol used by the file system + !! (BLASH for Windows, FSLASH for everything else) +#endif +CHARACTER(1), PUBLIC, PARAMETER :: CHAR_SPACE = ' ' + !! Character constant for a single space +CHARACTER(1), PUBLIC, PARAMETER :: CHAR_CR = CHAR(13) + !! Character constant for a carraige return +CHARACTER(1), PUBLIC, PARAMETER :: CHAR_LF = CHAR(10) + !! Character constant for a line feed +CHARACTER(2), PUBLIC, PARAMETER :: CHAR_LF2 = char_lf//char_lf + !! Character constant for a line feed +CHARACTER(3), PUBLIC, PARAMETER :: CHAR_LF3 = char_lf2//char_lf + !! Character constant for a line feed +CHARACTER(1), PUBLIC, PARAMETER :: CHAR_TAB = CHAR(9) + +INTEGER(I4B), PARAMETER, PUBLIC :: Constant = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: Space = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: Time = 3 +INTEGER(I4B), PARAMETER, PUBLIC :: SpaceTime = 4 +INTEGER(I4B), PARAMETER, PUBLIC :: SolutionDependent = 5 +INTEGER(I4B), PARAMETER, PUBLIC :: RandomSpace = 6 +!> +INTEGER(I4B), PARAMETER, PUBLIC :: Scalar = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: Vector = 2 +INTEGER(I4B), PARAMETER, PUBLIC :: Matrix = 3 +INTEGER(I4B), PARAMETER, PUBLIC :: Nodal = 1 +INTEGER(I4B), PARAMETER, PUBLIC :: Quadrature = 2 + +INTEGER(I4B), PARAMETER, PUBLIC :: MAX_CHUNK_SIZE = 1024 + +END MODULE GlobalData diff --git a/src/modules/Gnuplot/CMakeLists.txt b/src/modules/Gnuplot/CMakeLists.txt new file mode 100644 index 000000000..78b80f677 --- /dev/null +++ b/src/modules/Gnuplot/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/ogpf.F90 +) \ No newline at end of file diff --git a/src/modules/Gnuplot/src/ogpf.F90 b/src/modules/Gnuplot/src/ogpf.F90 new file mode 100644 index 000000000..ff86405a8 --- /dev/null +++ b/src/modules/Gnuplot/src/ogpf.F90 @@ -0,0 +1,2662 @@ +!------------------------------------------------------------------------------- +! GnuPlot Interface +!------------------------------------------------------------------------------- +! Purpose: Object Based Interface to GnuPlot from Fortran (ogpf) +! Platform: Windows XP/Vista/7/10 +! (It should work on other platforms, see the finalize_plot subroutine below) +! Language: Fortran 2003 and 2008 +! Requires: 1. Fortran 2003 compiler (e.g gfortran 5, IVF 12.1, ...) +! There is only two more features needs Fortran 2008 standard +! execute_command_line and passing internal function as argument. +! 2. gnuplot 5 and higher (other previous version can be used +! Author: Mohammad Rahmani +! Chem Eng Dep., Amirkabir Uni. of Tech +! Tehran, Ir +! url: aut.ac.ir/m.rahmani +! github: github.com/kookma +! email: m[dot]rahmani[at]aut[dot]ac[dot]ir +! +! +! Acknowledgement: +! Special thanks to Hagen Wierstorf (http://www.gnuplotting.org) +! For vluable codes and examples on using gnuplot +! Some examples and color palletes are provided by gnuplotting. +! + + +! Revision History + +! Revision 0.22 +! Date: Mar 9th, 2018 +! - a new procedure called use_extra_configuration is used to set general gnuplot settings +! - new type for labels (xlabel, ylabel, zlabel, title,...) +! - all lables now accept text color, font name, font size, rorate by degree +! - Secondary axes can use different scale (linear or logarithmic) +! - subroutine plot2d_matrix_vs_matrix(xmat,ymat) +! now plots a matrix columns ymat aganist another matrix column xmat +! - added more examples + +! Revision 0.21 +! Date: Mar 8th, 2018 +! - new axes to plot command to use secondary axes added! + + +! Revision: 0.20 +! Date: Feb 20th, 2018 +! - ogpf now supports animation for 2D and 3D plots +! - rewrite contour and surface plot +! - select_precision has been merged into ogpf +! - new add_script procedure replaced old script +! - new run_script procedure +! - writestring procedure removed +! - linespec for plor2d_matrix_vs_plot now is a single dynamic string +! - splot now uses datablok instead of inline data +! - meshgrid now support full grid vector +! - arange a numpy similar function to create a range in the form of [xa, xa+dx, xa+2*dx, ...] +! - new num2str routines + + + +! Revision: 0.19 +! Date: Jan 15th, 2018 +! - new contour plot procedure + + +! Revision: 0.18 +! Date: Dec 22th, 2017 +! Major revision +! - The dynamic string allocation of Fortran 2003 is used (some old compilers +! does not support this capability) +! - Multiple windows plot now supported +! - Multiplot now supported +! - Gnuplot script file extension is changed from .plt to .gp +! - Default window size (canvas) changed to 640x480 +! - Persist set to on (true) by default +! - A separate subroutine is used now to create the output file for gnuplot commands +! - A separate subroutine is used now to finalize the output + +! + + +! Revision: 0.17 +! Date: Dec 18th, 2017 +! Minor corrections +! - Correct the meshgrid for wrong dy calculation when ygv is sent by two elements. +! - Remove the subroutine ErrHandler (development postponed to future release) + + +! Revision: 0.16 +! Date: Feb 11th, 2016 +! Minor corrections +! Correct the lspec processing in plot2D_matrix_vs_vector +! Now, it is possible to send less line specification and gpf will cycle through lspec + +! Revision: 0.15 +! Date: Apr 20th, 2012 +! Minor corrections +! Use of select_precision module and working precision: wp + +! Revision: 0.14 +! Date: Mar 28th, 2012 +! Minor corrections +! Use of import keyboard and removing the Precision module +! Length of Title string increased by 80 chars + + +! Revision: 0.13 +! Date: Feb 12th, 2012 +! Minor corrections +! Added axis method which sets the axis limits for x-axis, y-axis and z-axis +! Added Precision module + + + +! Version: 0.12 +! Date: Feb 9th, 2012 +! Minor corrections +! New semilogx, semilogy, loglog methods +! New options method, allow to be called several times to set the gnuplot options + + + +! Version: 0.11 +! Date: Feb 9th, 2012 +! Minor corrections +! Use of NEWUINT specifier from Fortran 2008 +! Added configuration parameters +! Extra procedures have been removed +! Temporary file is now deleted using close(...,status='delete') + +! +! Version: 0.1 +! Date: Jan 5th, 2012 +! First object-based version + +MODULE OGPF +USE GlobalData, ONLY: wp=>DFP, sp=>Real32, dp=>Real64 +IMPLICIT NONE +PRIVATE +! Library information +CHARACTER(LEN=*), PARAMETER :: md_name = 'ogpf libray' +CHARACTER(LEN=*), PARAMETER :: md_rev = 'Rev. 0.22 of March 9th, 2018' +CHARACTER(LEN=*), PARAMETER :: md_lic = 'Licence: MIT' + +! ogpf Configuration parameters +! The terminal and font have been set for Windows operating system +! Correct to meet the requirements on other OS like Linux and Mac. +CHARACTER(LEN=*), PARAMETER :: gnuplot_term_type = 'wxt' +!! Output terminal +CHARACTER(LEN=*), PARAMETER :: gnuplot_term_font = 'verdana,10' +!! font +CHARACTER(LEN=*), PARAMETER :: gnuplot_term_size = '640,480' +!! '960,840' ! plot window size +CHARACTER(LEN=*), PARAMETER :: gnuplot_output_filename='ogpf_temp_script.gp' !! temporary file for output +!! extra configuration can be set using ogpf object + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! module procedure +! convert integer, real, double precision into string +INTERFACE num2str + MODULE PROCEDURE num2str_i4, num2str_r4, num2str_r8 +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> 0.22 +! tplabel is a structure for gnuplot labels including +! title, xlabel, x2label, ylabel, ... +INTEGER, PARAMETER, PRIVATE :: NOT_INITIALIZED = -32000 +TYPE TPLABEL + LOGICAL :: has_label = .false. + CHARACTER(LEN=:), ALLOCATABLE :: lbltext + CHARACTER(LEN=:), ALLOCATABLE :: lblcolor + CHARACTER(LEN=:), ALLOCATABLE :: lblfontname + INTEGER :: lblfontsize = NOT_INITIALIZED + INTEGER :: lblrotate = NOT_INITIALIZED +END TYPE TPLABEL + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! the gpf class implement the object for using gnuplot from fortran in a semi-interactive mode! +! the fortran actually do the job and write out the commands and data in a single file and then +! calls the gnuplot by shell command to plot the data + +TYPE, PUBLIC :: GPF + PRIVATE + !> 0.22 + TYPE(TPLABEL) :: tpplottitle + TYPE(TPLABEL) :: tpxlabel + TYPE(TPLABEL) :: tpx2label + TYPE(TPLABEL) :: tpylabel + TYPE(TPLABEL) :: tpy2label + TYPE(TPLABEL) :: tpzlabel + CHARACTER(LEN=:), ALLOCATABLE :: txtoptions + !! a long string to store all type of gnuplot options + CHARACTER(LEN=:), ALLOCATABLE :: txtscript + !! a long string to store gnuplot script + CHARACTER(LEN=:), ALLOCATABLE :: txtdatastyle + !! lines, points, linepoints + LOGICAL :: hasxrange = .false. + LOGICAL :: hasx2range = .false. + LOGICAL :: hasyrange = .false. + LOGICAL :: hasy2range = .false. + LOGICAL :: haszrange = .false. + LOGICAL :: hasoptions = .false. + LOGICAL :: hasanimation = .false. + LOGICAL :: hasfilename = .false. + LOGICAL :: hasfileopen = .false. + REAL(wp) :: xrange(2), yrange(2), zrange(2) + REAL(wp) :: x2range(2), y2range(2) + CHARACTER(len=8) :: plotscale + ! multiplot parameters + LOGICAL :: hasmultiplot = .false. + INTEGER :: multiplot_rows + INTEGER :: multiplot_cols + INTEGER :: multiplot_total_plots + ! animation + INTEGER :: pause_seconds = 0 + !! keep plot on screen for this value in seconds + INTEGER :: frame_number + !! frame number in animation + ! use for debugging and error handling + CHARACTER(LEN=:), ALLOCATABLE :: msg + !! Message from plot procedures + INTEGER :: status=0 + !!Status from plot procedures + INTEGER :: file_unit + !! file unit identifier + CHARACTER(LEN=:), ALLOCATABLE :: txtfilename + !! the name of physical file to write the gnuplot script + ! ogpf preset configuration (kind of gnuplot initialization) + LOGICAL :: preset_configuration = .true. + CONTAINS + PRIVATE + ! local private procedures + PROCEDURE, PASS, PRIVATE :: preset_gnuplot_config + PROCEDURE, PASS, PRIVATE :: plot2d_vector_vs_vector + PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_vector + PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_matrix + PROCEDURE, PASS, PRIVATE :: semilogxv + PROCEDURE, PASS, PRIVATE :: semilogxm + PROCEDURE, PASS, PRIVATE :: semilogyv + PROCEDURE, PASS, PRIVATE :: semilogym + PROCEDURE, PASS, PRIVATE :: loglogv + PROCEDURE, PASS, PRIVATE :: loglogm + !> 0.22 + PROCEDURE, PASS, PRIVATE :: set_label + ! public procedures + PROCEDURE, PASS, PUBLIC :: options => set_options + PROCEDURE, PASS, PUBLIC :: title => set_plottitle + PROCEDURE, PASS, PUBLIC :: xlabel => set_xlabel + PROCEDURE, PASS, PUBLIC :: x2label => set_x2label + PROCEDURE, PASS, PUBLIC :: ylabel => set_ylabel + PROCEDURE, PASS, PUBLIC :: y2label => set_y2label + PROCEDURE, PASS, PUBLIC :: zlabel => set_zlabel + PROCEDURE, PASS, PUBLIC :: axis => set_axis + PROCEDURE, PASS, PUBLIC :: axis_sc => set_secondary_axis + PROCEDURE, PASS, PUBLIC :: filename => set_filename + PROCEDURE, PASS, PUBLIC :: reset => reset_to_defaults + PROCEDURE, PASS, PUBLIC :: preset => use_preset_configuration + PROCEDURE, PASS, PUBLIC :: multiplot => sub_multiplot + GENERIC, PUBLIC :: plot => & + & plot2d_vector_vs_vector, & + & plot2d_matrix_vs_vector, & + & plot2d_matrix_vs_matrix + GENERIC, PUBLIC :: semilogx => semilogxv, semilogxm + GENERIC, PUBLIC :: semilogy => semilogyv, semilogym + GENERIC, PUBLIC :: loglog => loglogv, loglogm + PROCEDURE, PASS, PUBLIC :: surf => splot ! 3D surface plot + PROCEDURE, PASS, PUBLIC :: lplot => lplot3d ! 3D line plot + PROCEDURE, PASS, PUBLIC :: contour => cplot ! contour plot + PROCEDURE, PASS, PUBLIC :: fplot => function_plot + PROCEDURE, PASS, PUBLIC :: add_script => addscript + PROCEDURE, PASS, PUBLIC :: run_script => runscript + PROCEDURE, PASS, PUBLIC :: animation_start => sub_animation_start + PROCEDURE, PASS, PUBLIC :: animation_show => sub_animation_show +END TYPE GPF + +CONTAINS + + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !!> Section One: Set/Get Methods for ogpf object + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + subroutine use_preset_configuration(this,flag) + !.............................................................................. + !Set a flag to tell ogpf if the customized gnuplot configuration should + !be used + !.............................................................................. + + class(gpf):: this + logical, intent(in) :: flag + + ! default is true + this%preset_configuration = flag + + end subroutine use_preset_configuration + + + + subroutine set_filename(this,string) + !.............................................................................. + !Set a file name for plot command output + !This file can be used later by gnuplot as an script file to reproduce the plot + !.............................................................................. + + class(gpf):: this + character(len=*), intent(in) :: string + + this%txtfilename = trim(string) + this%hasfilename = .true. + + end subroutine set_filename + + + subroutine set_options(this,stropt) + !.............................................................................. + ! Set the plot options. This is a very powerfull procedure accepts many types + ! of gnuplot command and customization + !.............................................................................. + + class(gpf):: this + character(len=*), intent(in) :: stropt + + if(.not.allocated(this%txtoptions))this%txtoptions='' + if (len_trim(this%txtoptions) == 0 ) then + this%txtoptions = '' ! initialize string + end if + if ( len_trim(stropt)>0 ) then + this%txtoptions = this%txtoptions // splitstr(stropt) + end if + + this%hasoptions=.true. + + end subroutine set_options + + + + + subroutine set_axis(this,rng) + !.............................................................................. + !Set the axes limits in form of [xmin, xmax, ymin, ymax, zmin, zmax] + !.............................................................................. + + class(gpf):: this + real(wp), intent(in) :: rng(:) + integer :: n + n=size(rng,dim=1) + select case(n) + case(2) !Only the range for x-axis has been sent + this%hasxrange=.true. + this%xrange=rng(1:2) + case(4) + this%hasxrange=.true. + this%hasyrange=.true. + this%xrange=rng(1:2) + this%yrange=rng(3:4) + case(6) + this%hasxrange=.true. + this%hasyrange=.true. + this%haszrange=.true. + this%xrange=rng(1:2) + this%yrange=rng(3:4) + this%zrange=rng(5:6) + case default + print*, 'gpf error: wrong axis range setting!' + return + end select + + end subroutine set_axis + + + subroutine set_secondary_axis(this,rng) + !.............................................................................. + !Set the secondary axes limits in form of [x2min, x2max, y2min, y2max] + !.............................................................................. + + class(gpf):: this + real(wp), intent(in) :: rng(:) + integer :: n + n=size(rng,dim=1) + select case(n) + case(2) !Only the range for x2-axis has been sent + this%hasx2range=.true. + this%x2range=rng(1:2) + case(4) + this%hasx2range=.true. + this%hasy2range=.true. + this%x2range=rng(1:2) + this%y2range=rng(3:4) + case default + print*, 'gpf error: wrong axis range setting!' + return + end select + + end subroutine set_secondary_axis + + + subroutine set_plottitle(this, string, textcolor, font_size, font_name, rotate) + !.............................................................................. + !Set the plot title + !.............................................................................. + class(gpf):: this + character(len=*), intent(in) :: string + character(len=*), intent(in), optional :: textcolor + integer, optional :: font_size + character(len=*), intent(in), optional :: font_name + integer, optional :: rotate + + call this%set_label('plot_title', string, textcolor, font_size, font_name, rotate) + + end subroutine set_plottitle + + + subroutine set_xlabel(this, string, textcolor, font_size, font_name, rotate) + !.............................................................................. + !Set the xlabel + !.............................................................................. + class(gpf):: this + character(len=*), intent(in) :: string + character(len=*), intent(in), optional :: textcolor + integer, optional :: font_size + character(len=*), intent(in), optional :: font_name + integer, optional :: rotate + + call this%set_label('xlabel', string, textcolor, font_size, font_name, rotate) + + end subroutine set_xlabel + + + subroutine set_x2label(this, string, textcolor, font_size, font_name, rotate) + !.............................................................................. + !Set the x2label + !.............................................................................. + class(gpf):: this + character(len=*), intent(in) :: string + character(len=*), intent(in), optional :: textcolor + integer, optional :: font_size + character(len=*), intent(in), optional :: font_name + integer, optional :: rotate + + call this%set_label('x2label', string, textcolor, font_size, font_name, rotate) + + end subroutine set_x2label + + + subroutine set_ylabel(this, string, textcolor, font_size, font_name, rotate) + !.............................................................................. + !Set the ylabel + !.............................................................................. + class(gpf):: this + character(len=*), intent(in) :: string + character(len=*), intent(in), optional :: textcolor + integer, optional :: font_size + character(len=*), intent(in), optional :: font_name + integer, optional :: rotate + + call this%set_label('ylabel', string, textcolor, font_size, font_name, rotate) + + end subroutine set_ylabel + + + + subroutine set_y2label(this, string, textcolor, font_size, font_name, rotate) + !.............................................................................. + !Set the y2label + !.............................................................................. + class(gpf):: this + character(len=*), intent(in) :: string + character(len=*), intent(in), optional :: textcolor + integer, optional :: font_size + character(len=*), intent(in), optional :: font_name + integer, optional :: rotate + + call this%set_label('y2label', string, textcolor, font_size, font_name, rotate) + + end subroutine set_y2label + + + subroutine set_zlabel(this, string, textcolor, font_size, font_name, rotate) + !.............................................................................. + !Set the zlabel + !.............................................................................. + class(gpf):: this + character(len=*), intent(in) :: string + character(len=*), intent(in), optional :: textcolor + integer, optional :: font_size + character(len=*), intent(in), optional :: font_name + integer, optional :: rotate + + call this%set_label('zlabel', string, textcolor, font_size, font_name, rotate) + + end subroutine set_zlabel + + + !> 0.22 + + subroutine set_label(this, lblname, lbltext, lblcolor, font_size, font_name, rotate) + !.............................................................................. + ! Set the text, color, font, size and rotation for labels including + ! title, xlabel, x2label, ylabel, .... + !.............................................................................. + + class(gpf):: this + character(len=*), intent(in) :: lblname + character(len=*), intent(in) :: lbltext + character(len=*), intent(in), optional :: lblcolor + character(len=*), intent(in), optional :: font_name + integer, optional :: font_size + integer, optional :: rotate + + ! local variable + type(tplabel) :: label + + label%has_label = .true. + label%lbltext = trim(lbltext) + + if (present(lblcolor)) then + label%lblcolor = lblcolor + end if + + if (present(font_name)) then + label%lblfontname = font_name + else + if(.not.allocated(label%lblfontname))then + label%lblfontname = '' + endif + end if + + if (present(font_size)) then + label%lblfontsize = font_size + end if + + if (present(rotate)) then + label%lblrotate = rotate + end if + + select case (lblname) + case ('xlabel') + this%tpxlabel = label + case ('x2label') + this%tpx2label = label + case ('ylabel') + this%tpylabel = label + case ('y2label') + this%tpy2label = label + case ('zlabel') + this%tpzlabel = label + case ('plot_title') + this%tpplottitle = label + end select + + + end subroutine set_label + + + + subroutine reset_to_defaults(this) + !.............................................................................. + !Reset all ogpf properties (params to their default values + !............................................................................... + class(gpf):: this + + this%preset_configuration = .true. + this%txtfilename = gnuplot_output_filename + + if (allocated(this%txtoptions)) deallocate(this%txtoptions) + if (allocated(this%txtscript)) deallocate(this%txtscript) + if (allocated(this%txtdatastyle)) deallocate(this%txtdatastyle) + if (allocated(this%msg)) deallocate(this%msg) + + this%hasoptions = .false. + + this%hasxrange = .false. + this%hasx2range = .false. + this%hasyrange = .false. + this%hasy2range = .false. + this%haszrange = .false. + + this%pause_seconds = 0 + this%status = 0 + this%hasanimation = .false. + this%hasfileopen = .false. + this%hasmultiplot = .false. + + this%plotscale = '' + this%tpplottitle%has_label =.false. + this%tpxlabel%has_label =.false. + this%tpx2label%has_label =.false. + this%tpylabel%has_label =.false. + this%tpy2label%has_label =.false. + this%tpzlabel%has_label =.false. + + + end subroutine reset_to_defaults + + + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !!> Section Two: Main Plotting Routines + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + subroutine sub_multiplot(this, rows, cols) + !.............................................................................. + ! This subroutine sets flag and number of rows and columns in case + ! of multiplot layout + !.............................................................................. + + class(gpf):: this + integer, intent(in) :: rows + integer, intent(in) :: cols + + ! ogpf does not support multiplot in animation mode + if (this%hasanimation) then + print*, md_name // ': ogpf does not support animation in multiplot mode' + stop + end if + + ! set multiplot cols and rows + if (rows> 0 ) then + this%multiplot_rows = rows + else + + end if + if (cols > 0 ) then + this%multiplot_cols = cols + else + + end if + + ! set the multiplot layout flag and plot numbers + this%hasmultiplot = .true. + this%multiplot_total_plots = 0 + + ! create the ouput file for writting gnuplot script + call create_outputfile(this) + + + end subroutine sub_multiplot + + + subroutine plot2d_vector_vs_vector(this, x1, y1, ls1, axes1, & + x2, y2, ls2, axes2, & + x3, y3, ls3, axes3, & + x4, y4, ls4, axes4 ) + !.............................................................................. + ! This procedure plots: + ! 1. A vector against another vector (xy plot) + ! 2. A vector versus its element indices (yi plot). + ! 3. Can accept up to 4 data sets as x,y pairs! + ! Arguments + ! xi, yi vectors of data series, + ! lsi a string maximum 80 characters containing the line specification, + ! legends, ... + ! axesi is the axes for plotting: secondary axes are x2, and y2 + !.............................................................................. + + class(gpf):: this + ! Input vector + real(wp), intent(in) :: x1(:) ! vector of data for x + real(wp), intent(in), optional :: y1(:) ! vector of data for y + character(len=*), intent(in), optional :: ls1 ! line specification + character(len=*), intent(in), optional :: axes1 + + real(wp), intent(in), dimension(:), optional :: x2 + real(wp), intent(in), dimension(:), optional :: y2 + character(len=*), intent(in), optional :: ls2 + character(len=*), intent(in), optional :: axes2 + + real(wp), intent(in), dimension(:), optional :: x3 + real(wp), intent(in), dimension(:), optional :: y3 + character(len=*), intent(in), optional :: ls3 + character(len=*), intent(in), optional :: axes3 + + real(wp), intent(in), dimension(:), optional :: x4 + real(wp), intent(in), dimension(:), optional :: y4 + character(len=*), intent(in), optional :: ls4 + character(len=*), intent(in), optional :: axes4 + + ! Local variables + !---------------------------------------------------------------------- + + integer:: nx1 + integer:: ny1 + integer:: nx2 + integer:: ny2 + integer:: nx3 + integer:: ny3 + integer:: nx4 + integer:: ny4 + integer:: number_of_plots + character(len=3):: plottype + integer:: i + character(len=80) :: pltstring(4) ! Four 80 characters string + + !Initialize variables + plottype = '' + pltstring = '' + + ! Check the input + nx1=size(x1) + if ((present(y1) )) then + ny1=size(y1) + if (checkdim(nx1,ny1)) then + plottype='xy1' + number_of_plots=1 + else + print*, md_name // ':plot2d_vector_vs_vector:' // 'length of x1 and y1 does not match' + return + end if + else !plot only x againest its element indices + plottype='xi' + number_of_plots=1 + end if + + !Process line spec and axes set for first data set if present + call process_linespec(1, pltstring(1), ls1, axes1) + + + if (present(x2) .and. present (y2)) then + nx2=size(x2) + ny2=size(y2) + if (checkdim(nx2,ny2)) then + plottype='xy2' + number_of_plots=2 + else + return + end if + !Process line spec for 2nd data set if present + call process_linespec(2, pltstring(2), ls2, axes2) + end if + + if (present(x3) .and. present (y3)) then + nx3=size(x3) + ny3=size(y3) + if (checkdim(nx3,ny3)) then + plottype='xy3' + number_of_plots=3 + else + return + end if + !Process line spec for 3rd data set if present + call process_linespec(3, pltstring(3), ls3, axes3) + end if + + if (present(x4) .and. present (y4)) then + nx4=size(x4) + ny4=size(y4) + if (checkdim(nx4,ny4)) then + plottype='xy4' + number_of_plots=4 + else + return + end if + !Process line spec for 4th data set if present + call process_linespec(4, pltstring(4), ls4, axes4) + end if + + + call create_outputfile(this) + + ! Write plot title, axis labels and other annotations + call processcmd(this) + + ! Write plot command and line styles and legend if any + if (number_of_plots ==1) then + write ( this%file_unit, '(a)' ) trim(pltstring(1)) + else + write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_plots-1) + write ( this%file_unit, '(a)' ) trim(pltstring(number_of_plots)) + end if + ! Write xy data into file + select case (plottype) + case ('xi') + call write_xydata(this%file_unit,nx1,x1) + case ('xy1') + call write_xydata(this%file_unit,nx1,x1,y1) + case ('xy2') + call write_xydata(this%file_unit,nx1,x1,y1) + call write_xydata(this%file_unit,nx2,x2,y2) + case ('xy3') + call write_xydata(this%file_unit,nx1,x1,y1) + call write_xydata(this%file_unit,nx2,x2,y2) + call write_xydata(this%file_unit,nx3,x3,y3) + case ('xy4') + call write_xydata(this%file_unit,nx1,x1,y1) + call write_xydata(this%file_unit,nx2,x2,y2) + call write_xydata(this%file_unit,nx3,x3,y3) + call write_xydata(this%file_unit,nx4,x4,y4) + end select + + !> Rev 0.2 + ! if there is no animation finalize + if (.not. (this%hasanimation)) then + call finalize_plot(this) + else + write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds + end if + + + !: End of plot2D_vector_vs_vector + end subroutine plot2d_vector_vs_vector + + + + subroutine plot2d_matrix_vs_vector(this, xv,ymat, lspec) + !.............................................................................. + ! plot2D_matrix_vs_vector accepts a vector xv and a matrix ymat and plots + ! columns of ymat against xv. lspec is an optional array defines the line + ! specification for each data series. If a single element array is sent for + ! lspec then all series are plotted using the same linespec + !.............................................................................. + + implicit none + class(gpf):: this + ! Input arrays + real(wp), intent(in) :: xv(:) + real(wp), intent(in) :: ymat(:,:) + character(len=*), intent(in), optional :: lspec + !---------------------------------------------------------------------- + ! Local variables + integer:: nx + integer:: ny + integer:: ns + integer:: number_of_curves + integer:: i + integer:: j + integer:: ierr + character(len=80), allocatable :: pltstring(:), lst(:) + ! + + !******************************************************************************* + ! Check the input + nx=size(xv) + ny=size(ymat,dim=1) + if (.not. checkdim(nx,ny)) then + print*, md_name // ':plot2d_matrix_vs_vector:' // 'The length of arrays does not match' + return + end if + ! create the outfile to write the gnuplot script + call create_outputfile(this) + + ! Write titles and other annotations + call processcmd(this) + + ! Write plot command and line styles and legend if any + number_of_curves=size(ymat,dim=2) + allocate(pltstring(number_of_curves), stat=ierr) + if (ierr /=0) then + print*, 'allocation error' + return + end if + + ! assume no linespec is available + pltstring(1:number_of_curves) = '' + + if ( present(lspec) ) then + + call splitstring2array(lspec,lst,';') + ns = size(lst, dim=1) + + if (ns == number_of_curves) then + ! there is a linespec for each curve + pltstring = lst + elseif (ns < number_of_curves) then + ! not enough linespec + do i=1, ns + pltstring(i) = lst(i) + end do + else ! ns > number_of curves + print*, 'ogpf: plot2d_matrix_vs_vector: wrong number of linespec' + print*, 'semicolon ";" acts as delimiter, check the linespec' + end if + end if + + if ( present(lspec) ) then + + call process_linespec(1,pltstring(1),lst(1)) + ns=size(lst) + ! gpf will cylce through line specification, if number of specification passed + ! is less than number of plots + do i=1, number_of_curves + j=mod(i-1, ns) + 1 + call process_linespec(i, pltstring(i), lst(j)) + end do + else !No lspec is available + pltstring(1)=' plot "-" notitle,' + pltstring(2:number_of_curves-1)='"-" notitle,' + pltstring(number_of_curves)='"-" notitle' + end if + + ! Write plot command and line styles and legend if any + write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1) + write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves)) + + ! Write data into script file + do j=1, number_of_curves + do i = 1, nx + write ( this%file_unit, * ) xv(i),ymat(i,j) + end do + write ( this%file_unit, '(a)' ) 'e' !end of jth set of data + end do + + + !> Rev 0.2 + ! if there is no animation finalize + if (.not. (this%hasanimation)) then + call finalize_plot(this) + else + write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds + end if + + !Release memory + if (allocated(pltstring)) then + deallocate(pltstring) + end if + !: End of plot2D_matrix_vs_vector + end subroutine plot2d_matrix_vs_vector + + + + subroutine plot2d_matrix_vs_matrix(this, xmat,ymat, lspec) + !.............................................................................. + ! plot2D_matrix_vs_matrix accepts a matrix xmat and a matrix ymat and plots + ! columns of ymat against columns of xmat. lspec is an optional array defines + ! the line specification for each data series. If a single element array is + ! sent for lspec then all series are plotted using the same linespec + !.............................................................................. + + implicit none + class(gpf):: this + ! Input arrays + real(wp), intent(in) :: xmat(:,:) + real(wp), intent(in) :: ymat(:,:) + character(len=*), intent(in), optional :: lspec + !---------------------------------------------------------------------- + ! Local variables + integer:: mx, nx + integer:: my, ny + integer:: ns + integer:: number_of_curves + integer:: i + integer:: j + integer:: ierr + character(len=80), allocatable :: pltstring(:), lst(:) + ! + + !******************************************************************************* + ! Check the input + ! check number of rows + mx=size(xmat,dim=1) + my=size(ymat,dim=1) + if (.not. checkdim(mx,my)) then + print*, md_name // ':plot2d_matrix_vs_matrix:' // 'The length of arrays does not match' + return + end if + ! check number of rows + nx=size(xmat,dim=2) + ny=size(ymat,dim=2) + if (.not. checkdim(nx,ny)) then + print*, 'gpf error: The number of columns are different, check xmat, ymat' + return + end if + + + ! create the outfile to write the gnuplot script + call create_outputfile(this) + + ! Write titles and other annotations + call processcmd(this) + + ! Write plot command and line styles and legend if any + number_of_curves=size(ymat,dim=2) + allocate(pltstring(number_of_curves), stat=ierr) + if (ierr /=0) then + print*, 'allocation error' + return + end if + + ! assume no linespec is available + pltstring(1:number_of_curves) = '' + + if ( present(lspec) ) then + + call splitstring2array(lspec,lst,';') + ns = size(lst, dim=1) + + if (ns == number_of_curves) then + ! there is a linespec for each curve + pltstring = lst + elseif (ns < number_of_curves) then + ! not enough linespec + do i=1, ns + pltstring(i) = lst(i) + end do + else ! ns > number_of curves + print*, md_name // ': plot2d_matrix_vs_matrix:'//' wrong number of linespec' + print*, 'semicolon ";" acts as delimiter, check the linespec' + end if + end if + + if ( present(lspec) ) then + + call process_linespec(1,pltstring(1),lst(1)) + ns=size(lst) + ! gpf will cylce through line specification, if number of specification passed + ! is less than number of plots + do i=1, number_of_curves + j=mod(i-1, ns) + 1 + call process_linespec(i, pltstring(i), lst(j)) + end do + else !No lspec is available + pltstring(1)=' plot "-" notitle,' + pltstring(2:number_of_curves-1)='"-" notitle,' + pltstring(number_of_curves)='"-" notitle' + end if + + ! Write plot command and line styles and legend if any + write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1) + write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves)) + + ! Write data into script file + do j=1, number_of_curves + do i = 1, mx + write ( this%file_unit, * ) xmat(i,j),ymat(i,j) + end do + write ( this%file_unit, '(a)' ) 'e' !end of jth set of data + end do + + !> Rev 0.2 + ! if there is no animation finalize + if (.not. (this%hasanimation)) then + call finalize_plot(this) + else + write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds + end if + + !Release memory + if (allocated(pltstring)) then + deallocate(pltstring) + end if + !: End of plot2D_matrix_vs_vector + end subroutine plot2d_matrix_vs_matrix + + + subroutine splot(this, x, y, z, lspec, palette) + !.............................................................................. + ! splot create a surface plot + ! datablock is used instead of gnuplot inline file "-" + !.............................................................................. + + class(gpf):: this + ! Input vector + real(wp), intent(in) :: x(:,:) + real(wp), intent(in), optional :: y(:,:) + real(wp), intent(in), optional :: z(:,:) + character(len=*), intent(in), optional :: lspec + character(len=*), intent(in), optional :: palette + + ! Local variables + !---------------------------------------------------------------------- + integer:: ncx + integer:: nrx + integer:: i + integer:: j + logical:: xyz_data + character(len=80):: pltstring + character(len=*), parameter :: datablock = '$xyz' + + pltstring='' + ! Check the input data + ncx=size(x,dim=2) + nrx=size(x,dim=1) + if (present(y) .and. present(z)) then + xyz_data=.true. + elseif (present(y)) then + print*, "gpf error: Z matrix was not sent to 3D plot routine" + return + else + xyz_data=.false. + end if + + ! set default line style for 3D plot, can be overwritten + this%txtdatastyle = 'lines' + ! create the script file for writting gnuplot commands and data + call create_outputfile(this) + + ! Write titles and other annotations + call processcmd(this) + + ! Write xy data into file + write ( this%file_unit, '(a)' ) '#data x y z' + ! Rev 0.20 + ! write the $xyz datablocks + write( this%file_unit, '(a)' ) datablock // ' << EOD' + if (xyz_data) then + do j=1,ncx + do i=1, nrx + write ( this%file_unit, * ) x(i,j), y(i,j), z(i,j) + enddo + write( this%file_unit, '(a)' ) !put an empty line + enddo + write ( this%file_unit, '(a)' ) 'EOD' !end of datablock + else !only Z has been sent (i.e. single matrix data) + do j=1,ncx + do i=1, nrx + write ( this%file_unit, * ) i, j, x(i,j) + enddo + write( this%file_unit, '(a)' ) !put an empty line + enddo + write ( this%file_unit, '(a)' ) 'EOD' !end of datablock + end if + + + !write the color palette into gnuplot script file + if (present(palette)) then + write ( this%file_unit, '(a)' ) color_palettes(palette) + write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec + end if + + + if ( present(lspec) ) then + if (hastitle(lspec)) then + pltstring='splot ' // datablock // ' ' // trim(lspec) + else + pltstring='splot ' // datablock // ' notitle '//trim(lspec) + end if + else + pltstring='splot ' // datablock // ' notitle ' + end if + + write ( this%file_unit, '(a)' ) trim(pltstring) + + + !> Rev 0.2: animation + ! if there is no animation finalize + if (.not. (this%hasanimation)) then + call finalize_plot(this) + else + write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds + end if + + !: End of splot + end subroutine splot + + + subroutine cplot(this, x, y, z, lspec, palette) + !.............................................................................. + ! Rev 0.19 + ! cplot creates a contour plot based on the three dimensional data + !.............................................................................. + + class(gpf):: this + ! Input vector + real(wp), intent(in) :: x(:,:) + real(wp), intent(in), optional :: y(:,:) + real(wp), intent(in), optional :: z(:,:) + character(len=*), intent(in), optional :: lspec + character(len=*), intent(in), optional :: palette + + ! Local variables + !---------------------------------------------------------------------- + + integer:: ncx + integer:: nrx + integer:: i + integer:: j + logical:: xyz_data + character(len=80):: pltstring + character(len=*), parameter :: datablock = '$xyz' + ! character(len=*), parameter :: cntr_table = '$xyz_contour' + + pltstring='' + ! Check the input data + ncx=size(x,dim=2) + nrx=size(x,dim=1) + if (present(y) .and. present(z)) then + xyz_data=.true. + elseif (present(y)) then + print*, "gpf error: Z matrix was not sent to 3D plot routine" + return + else + xyz_data=.false. + end if + + ! set default line style for 3D plot, can be overwritten + this%txtdatastyle = 'lines' + ! create the script file for writting gnuplot commands and data + call create_outputfile(this) + + ! Write titles and other annotations + call processcmd(this) + + ! Write xy data into file + write ( this%file_unit, '(a)' ) '#data x y z' + ! write the $xyz datablocks + write( this%file_unit, '(a)' ) datablock // ' << EOD' + if (xyz_data) then + do j=1,ncx + do i=1, nrx + write ( this%file_unit, fmt=* ) x(i,j), y(i,j), z(i,j) + enddo + write( this%file_unit, '(a)' ) !put an empty line + enddo + write ( this%file_unit, '(a)' ) 'EOD' !end of datablock + else !only Z has been sent (i.e. single matrix data) + do j=1,ncx + do i=1, nrx + write ( this%file_unit, fmt=* ) i, j, x(i,j) + enddo + write( this%file_unit, '(a)' ) !put an empty line + enddo + write ( this%file_unit, '(a)' ) 'EOD' !end of datablock + end if + + + ! create the contour lines + write ( this%file_unit, '(a)' ) ! empty line + write ( this%file_unit, '(a)' ) '# create the contour' + write ( this%file_unit, '(a)' ) 'set contour base' + write ( this%file_unit, '(a)' ) 'set cntrparam levels 14' + write ( this%file_unit, '(a)' ) 'unset surface' + write ( this%file_unit, '(a)' ) 'set view map' + + + !write the color palette into gnuplot script file + if (present(palette)) then + write ( this%file_unit, '(a)' ) color_palettes(palette) + write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec + end if + + + write ( this%file_unit, '(a)' ) ! empty line + + if ( present(lspec) ) then + if (hastitle(lspec)) then + pltstring='splot ' // datablock // ' ' // trim(lspec) + else + pltstring='splot ' // datablock // ' notitle '//trim(lspec) + end if + else + pltstring='splot ' // datablock // ' notitle ' + end if + + write ( this%file_unit, '(a)' ) trim(pltstring) + + !> Rev 0.20 + ! if there is no animation finalize + if (.not. (this%hasanimation)) then + call finalize_plot(this) + else + write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds + end if + + !: End of cplot + end subroutine cplot + + subroutine lplot3d(this, x, y, z, lspec, palette) + !.............................................................................. + ! lplot3d create a line plot in 3d + ! datablock is used instead of gnuplot inline file "-" + !.............................................................................. + + class(gpf):: this + ! Input vector + real(wp), intent(in) :: x(:) + real(wp), intent(in), optional :: y(:) + real(wp), intent(in), optional :: z(:) + character(len=*), intent(in), optional :: lspec + character(len=*), intent(in), optional :: palette + + ! Local variables + !---------------------------------------------------------------------- + integer:: ncx + integer:: nrx + integer:: i + integer:: j + logical:: xyz_data + character(len=80):: pltstring + character(len=*), parameter :: datablock = '$xyz' + + pltstring='' + ! Check the input data + nrx=size(x) + if (present(y) .and. present(z)) then + xyz_data=.true. + elseif (present(y)) then + print*, "gpf error: Z matrix was not sent to 3D plot routine" + return + else + xyz_data=.false. + end if + + ! set default line style for 3D plot, can be overwritten + this%txtdatastyle = 'lines' + ! create the script file for writing gnuplot commands and data + call create_outputfile(this) + + ! Write titles and other annotations + call processcmd(this) + + ! Write xy data into file + write ( this%file_unit, '(a)' ) '#data x y z' + ! Rev 0.20 + ! write the $xyz datablocks + write( this%file_unit, '(a)' ) datablock // ' << EOD' + if (xyz_data) then + do i=1, nrx + write ( this%file_unit, * ) x(i), y(i), z(i) + enddo + write( this%file_unit, '(a)' ) !put an empty line + write ( this%file_unit, '(a)' ) 'EOD' !end of datablock + else !only Z has been sent (i.e. single matrix data) + do i=1, nrx + write ( this%file_unit, * ) i, x(i) + enddo + write( this%file_unit, '(a)' ) !put an empty line + write ( this%file_unit, '(a)' ) 'EOD' !end of datablock + end if + + + !write the color palette into gnuplot script file + if (present(palette)) then + write ( this%file_unit, '(a)' ) color_palettes(palette) + write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec + end if + + + if ( present(lspec) ) then + if (hastitle(lspec)) then + pltstring='splot ' // datablock // ' ' // trim(lspec) // 'with lines' + else + pltstring='splot ' // datablock // ' notitle '//trim(lspec) // 'with lines' + end if + else + pltstring='splot ' // datablock // ' notitle with lines' + end if + + write ( this%file_unit, '(a)' ) trim(pltstring) + + + !> Rev 0.2: animation + ! if there is no animation finalize + if (.not. (this%hasanimation)) then + call finalize_plot(this) + else + write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds + end if + + !: End of lplot3d + end subroutine lplot3d + + subroutine function_plot(this, func,xrange,np) + !.............................................................................. + ! fplot, plot a function in the range xrange=[xmin, xamx] with np points + ! if np is not sent, then np=50 is assumed! + ! func is the name of function to be plotted + !.............................................................................. + + class(gpf):: this + interface + function func(x) + import :: wp + real(wp), intent(in) :: x + real(wp) :: func + end function func + end interface + real(wp), intent(in) :: xrange(2) + integer, optional, intent(in):: np + + integer:: n + integer:: i + integer:: alloc_err + real(wp), allocatable :: x(:) + real(wp), allocatable :: y(:) + + if (present(np)) then + n=np + else + n=50 + end if + allocate(x(1:n), y(1:n), stat=alloc_err) + if (alloc_err /=0) then + stop "Allocation error in fplot procedure..." + end if + !Create set of xy data + x=linspace(xrange(1),xrange(2), n) + y=[ (func(x(i)), i=1, n) ] + + call plot2d_vector_vs_vector(this,x,y) + + ! cleanup memory + if (allocated(x)) deallocate(x) + if (allocated(y)) deallocate(y) + + + end subroutine function_plot + + + subroutine semilogxv(this, x1, y1, ls1, axes1, & + x2, y2, ls2, axes2, & + x3, y3, ls3, axes3, & + x4, y4, ls4, axes4 ) + !.............................................................................. + ! This procedure is the same as plotXY with logarithmic x1 and x2 axes + !.............................................................................. + + class(gpf):: this + ! Input vector + real(wp), intent(in) :: x1(:) ! vector of data for x + real(wp), intent(in), optional :: y1(:) ! vector of data for y + character(len=*), intent(in), optional :: ls1 ! line specification + character(len=*), intent(in), optional :: axes1 + + real(wp), intent(in), dimension(:), optional :: x2 + real(wp), intent(in), dimension(:), optional :: y2 + character(len=*), intent(in), optional :: ls2 + character(len=*), intent(in), optional :: axes2 + + real(wp), intent(in), dimension(:), optional :: x3 + real(wp), intent(in), dimension(:), optional :: y3 + character(len=*), intent(in), optional :: ls3 + character(len=*), intent(in), optional :: axes3 + + real(wp), intent(in), dimension(:), optional :: x4 + real(wp), intent(in), dimension(:), optional :: y4 + character(len=*), intent(in), optional :: ls4 + character(len=*), intent(in), optional :: axes4 + this%plotscale='semilogx' + call plot2d_vector_vs_vector(this, & + x1, y1, ls1, axes1, & + x2, y2, ls2, axes2, & + x3, y3, ls3, axes3, & + x4, y4, ls4, axes4 ) + ! Set the plot scale as linear. It means log scale is off + this%plotscale='linear' + + end subroutine semilogxv + + + !.............................................................................. + subroutine semilogyv(this, x1, y1, ls1, axes1, & + x2, y2, ls2, axes2, & + x3, y3, ls3, axes3, & + x4, y4, ls4,axes4 ) + !.............................................................................. + ! This procedure is the same as plotXY with logarithmic y1 and y2 axes + !.............................................................................. + + class(gpf):: this + ! Input vector + real(wp), intent(in) :: x1(:) ! vector of data for x + real(wp), intent(in), optional :: y1(:) ! vector of data for y + character(len=*), intent(in), optional :: ls1 ! line specification + character(len=*), intent(in), optional :: axes1 + + real(wp), intent(in), dimension(:), optional :: x2 + real(wp), intent(in), dimension(:), optional :: y2 + character(len=*), intent(in), optional :: ls2 + character(len=*), intent(in), optional :: axes2 + + real(wp), intent(in), dimension(:), optional :: x3 + real(wp), intent(in), dimension(:), optional :: y3 + character(len=*), intent(in), optional :: ls3 + character(len=*), intent(in), optional :: axes3 + + real(wp), intent(in), dimension(:), optional :: x4 + real(wp), intent(in), dimension(:), optional :: y4 + character(len=*), intent(in), optional :: ls4 + character(len=*), intent(in), optional :: axes4 + + this%plotscale='semilogy' + call plot2d_vector_vs_vector(this, & + x1, y1, ls1, axes1, & + x2, y2, ls2, axes2, & + x3, y3, ls3, axes3, & + x4, y4, ls4, axes4 ) + ! Set the plot scale as linear. It means log scale is off + this%plotscale='linear' + + + end subroutine semilogyv + + + + subroutine loglogv(this, x1, y1, ls1, axes1, & + x2, y2, ls2, axes2, & + x3, y3, ls3, axes3, & + x4, y4, ls4, axes4 ) + !.............................................................................. + ! This procedure is the same as plotXY with logarithmic x1, y1, x2, y2 axes + !.............................................................................. + + class(gpf):: this + ! Input vector + real(wp), intent(in) :: x1(:) ! vector of data for x + real(wp), intent(in), optional :: y1(:) ! vector of data for y + character(len=*), intent(in), optional :: ls1 ! line specification + character(len=*), intent(in), optional :: axes1 + + real(wp), intent(in), dimension(:), optional :: x2 + real(wp), intent(in), dimension(:), optional :: y2 + character(len=*), intent(in), optional :: ls2 + character(len=*), intent(in), optional :: axes2 + + real(wp), intent(in), dimension(:), optional :: x3 + real(wp), intent(in), dimension(:), optional :: y3 + character(len=*), intent(in), optional :: ls3 + character(len=*), intent(in), optional :: axes3 + + real(wp), intent(in), dimension(:), optional :: x4 + real(wp), intent(in), dimension(:), optional :: y4 + character(len=*), intent(in), optional :: ls4 + character(len=*), intent(in), optional :: axes4 + + + this%plotscale='loglog' + call plot2d_vector_vs_vector(this, & + x1, y1, ls1, axes1, & + x2, y2, ls2, axes2, & + x3, y3, ls3, axes3, & + x4, y4, ls4, axes4 ) + ! Set the plot scale as linear. It means log scale is off + this%plotscale='linear' + + end subroutine loglogv + + + + subroutine semilogxm(this, xv, ymat, lspec) + !.............................................................................. + !Plots a matrix against a vector with logarithmic x-axis + !For more information see plot2D_matrix_vs_vector procedure + !Everything is the same except the x-axis scale + !.............................................................................. + + implicit none + class(gpf) :: this + ! Input arrays + real(wp), intent(in) :: xv(:) + real(wp), intent(in) :: ymat(:,:) + character(len=*), intent(in), optional :: lspec + + this%plotscale='semilogx' + call plot2d_matrix_vs_vector(this, xv,ymat, lspec) + ! Set the plot scale as linear. It means log scale is off + this%plotscale='linear' + + + end subroutine semilogxm + + + + subroutine semilogym(this, xv,ymat, lspec) + !.............................................................................. + !Plots a matrix against a vector with logarithmic y-axis + !For more information see plot2D_matrix_vs_vector procedure + !Everything is the same except the x-axis scale + !.............................................................................. + + implicit none + class(gpf) :: this + ! Input arrays + real(wp), intent(in) :: xv(:) + real(wp), intent(in) :: ymat(:,:) + character(len=*), intent(in), optional :: lspec + + this%plotscale='semilogy' + call plot2d_matrix_vs_vector(this, xv,ymat, lspec) + ! Set the plot scale as linear. It means log scale is off + this%plotscale='linear' + + + end subroutine semilogym + + + subroutine loglogm(this, xv,ymat, lspec) + !.............................................................................. + !Plots a matrix against a vector with logarithmic x-axis and y-axis + !For more information see plot2D_matrix_vs_vector procedure + !Everything is the same except the axes scale + !.............................................................................. + + implicit none + class(gpf) :: this + ! Input arrays + real(wp), intent(in) :: xv(:) + real(wp), intent(in) :: ymat(:,:) + character(len=*), intent(in), optional :: lspec + + this%plotscale='loglog' + call plot2d_matrix_vs_vector(this, xv,ymat, lspec) + ! Set the plot scale as linear. It means log scale is off + this%plotscale='linear' + + + end subroutine loglogm + + + + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !!> Section Three: Animation Routines + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + subroutine sub_animation_start(this, pause_seconds) + !------------------------------------------------------------------------------- + ! sub_animation_start: set the setting to start an animation + ! it simply set flags and open a script file to write data + !------------------------------------------------------------------------------- + class(gpf) :: this + integer, intent(in), optional :: pause_seconds + + + ! ogpf does not support multiplot with animation at the same time + if (this%hasmultiplot) then + print*, md_name // ': does not support animation in multiplot mode!' + stop + end if + + + if (present(pause_seconds)) then + this%pause_seconds = pause_seconds + else + this%pause_seconds = 2 ! delay in second + end if + + this%frame_number = 0 + + ! create the ouput file for writting gnuplot script + call create_outputfile(this) + this%hasfileopen = .true. + this%hasanimation = .true. + + end subroutine sub_animation_start + + + subroutine sub_animation_show(this) + !------------------------------------------------------------------------------- + ! sub_animation_show: simply resets the animation flags + ! and finalize the plotting. + !------------------------------------------------------------------------------- + + class(gpf) :: this + + this%frame_number = 0 + this%hasanimation = .false. + + call finalize_plot(this) + + end subroutine sub_animation_show + + + + + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !!> Section Four: Gnuplot direct scriptting + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + subroutine addscript(this,strcmd) + !.............................................................................. + ! addscript: accepts all type of gnuplot command as a string and store it + ! in global txtscript to be later sent to gnuplot + !.............................................................................. + + class(gpf) :: this + character(len=*), intent(in) :: strcmd + + if (.not.allocated(this%txtscript)) this%txtscript='' + if (len_trim(this%txtscript) == 0 ) then + this%txtscript = '' ! initialize string + end if + if ( len_trim(strcmd)>0 ) then + this%txtscript = this%txtscript // splitstr(strcmd) + end if + + end subroutine addscript + + + + subroutine runscript(this) + !.............................................................................. + ! runscript sends the the script string (txtstring) into a script + ! file to be run by gnuplot + !.............................................................................. + + class(gpf):: this + + !REV 0.18: a dedicated subroutine is used to create the output file + call create_outputfile(this) + + !write the script + call processcmd(this) + write(unit=this%file_unit, fmt='(a)') this%txtscript + + ! close the file and call gnuplot + call finalize_plot(this) + + end subroutine runscript + + + + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !!> Section Five: gnuplot command processing and data writing to script file + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + subroutine process_axes_set(axes_set, axes) + !.............................................................................. + ! process_axesspec accepts the axes set and interpret it into + ! a format to be sent to gnuplot. + ! the axes set can be one of the following set + ! x1y1, x1y2, x2y1, x2y2 + !.............................................................................. + + character(len=*), intent(in) :: axes_set + character(len=4), intent(out) :: axes + + + if (len_trim (adjustl(axes_set)) == 0) then + axes='' + return + end if + + select case ( lcase(trim (adjustl (axes_set) ) ) ) + case ('x1y1') + axes='x1y1' + case ('x1y2') + axes='x1y2' + case ('x2y1') + axes='x2y1' + case ('x2y2') + axes='x2y2' + case default ! wrong strings + print*, md_name // ':process_axes_set:' // ' wrong axes set is sent.'// new_line(' ') & + // 'axes set can be on of: x1y1, x1y2, x2y1, x2y2' + axes='' + return + end select + + end subroutine process_axes_set + + + + subroutine process_linespec(order, lsstring, lspec, axes_set) + !.............................................................................. + ! process_linespec accepts the line specification and interpret it into + ! a format to be sent to gnuplot + !.............................................................................. + + integer, intent(in) :: order !1 for the first data series + character(len=*), intent(out) :: lsstring + character(len=*), intent(in), optional :: lspec + character(len=*), intent(in), optional :: axes_set + + !local variables + character(len=4) :: axes + character(len=10) :: axes_setting + + !check the axes set + axes_setting = '' + if ( present (axes_set)) then + call process_axes_set(axes_set, axes) + if (len(trim(axes))> 0 ) then + axes_setting = ' axes ' // axes + end if + end if + + select case(order) + case(1) + if ( present(lspec) ) then + if (hastitle(lspec)) then + lsstring='plot "-" '//trim(lspec) // axes_setting + else + lsstring='plot "-" notitle '//trim(lspec) // axes_setting + end if + else + lsstring='plot "-" notitle' // axes_setting + end if + case default !e.g. 2, 3, 4, ... + if (present(lspec)) then + if (hastitle(lspec)) then + lsstring=', "-" '// trim(lspec) // axes_setting + else + lsstring=', "-" notitle '// trim(lspec) // axes_setting + end if + else + lsstring=', "-" notitle' // axes_setting + end if + end select + end subroutine process_linespec + + + + subroutine processcmd(this) + !.............................................................................. + ! This subroutine writes all the data into plot file + ! to be read by gnuplot + !.............................................................................. + + class(gpf) :: this + + ! write the plot style for data + ! this is used only when 3D plots (splot, cplot) is used + if (allocated(this%txtdatastyle)) then + write ( this%file_unit, '("set style data ", a)' ) this%txtdatastyle + write ( this%file_unit, '(a)' ) + end if + + + ! Write options + if ( this%hasoptions ) then + write ( this%file_unit, '(" ")' ) + write ( this%file_unit, '("# options")' ) + write ( this%file_unit, '(a)' ) this%txtoptions + write ( this%file_unit, '(a)' ) + end if + + ! Check with plot scale: i.e linear, logx, logy, or log xy + write( this%file_unit, '(" ")' ) + write( this%file_unit, '("# plot scale")' ) + select case (this%plotscale) + case ('semilogx') + write ( this%file_unit, '("set logscale x")' ) + case ('semilogy') + write ( this%file_unit, '("set logscale y")' ) + case ('loglog') + write ( this%file_unit, '("set logscale xy")' ) + case default !for no setting + !pass + end select + + !!>0.22 + ! write annotation + write ( this%file_unit, '(" ")' ) + write ( this%file_unit, '("# Annotation: title and labels")' ) + call write_label(this, 'plot_title') + call write_label(this, 'xlabel' ) + call write_label(this, 'x2label' ) + call write_label(this, 'ylabel' ) + call write_label(this, 'y2label' ) + call write_label(this, 'zlabel' ) + + ! axes range + write ( this%file_unit, '(" ")') + write ( this%file_unit, '("# axes setting")') + if (this%hasxrange) then + write ( this%file_unit, '("set xrange [",G0,":",G0,"]")' ) this%xrange + end if + if (this%hasyrange) then + write ( this%file_unit, '("set yrange [",G0,":",G0,"]")' ) this%yrange + end if + if (this%haszrange) then + write ( this%file_unit, '("set zrange [",G0,":",G0,"]")' ) this%zrange + end if + + ! secondary axes range + if (this%hasx2range) then + write ( this%file_unit, '("set x2range [",G0,":",G0,"]")' ) this%x2range + end if + if (this%hasy2range) then + write ( this%file_unit, '("set y2range [",G0,":",G0,"]")' ) this%y2range + end if + ! finish by new line + write ( this%file_unit, '(a)' ) ! emptyline + + end subroutine processcmd + + + + subroutine write_label(this, lblname) + !.............................................................................. + ! This subroutine writes the labels into plot file + ! to be read by gnuplot + !.............................................................................. + + + ! write_label + class(gpf) :: this + character(len=*) :: lblname + + ! local var + character(len=:), allocatable :: lblstring + character(len=:), allocatable :: lblset + type(tplabel) :: label + + select case (lblname) + case ('xlabel') + if (.not. (this%tpxlabel%has_label) ) then + return ! there is no label + end if + lblset = 'set xlabel "' + label = this%tpxlabel + case ('x2label') + if (.not. (this%tpx2label%has_label) ) then + return ! there is no label + end if + lblset = 'set x2label "' + label = this%tpx2label + case ('ylabel') + if (.not. (this%tpylabel%has_label) ) then + return ! there is no label + end if + lblset = 'set ylabel "' + label = this%tpylabel + case ('y2label') + if (.not. (this%tpy2label%has_label) ) then + return ! there is no label + end if + lblset = 'set y2label "' + label = this%tpy2label + case ('zlabel') + if (.not. (this%tpzlabel%has_label) ) then + return ! there is no label + end if + lblset = 'set zlabel "' + label = this%tpzlabel + case ('plot_title') + if (.not. (this%tpplottitle%has_label) ) then + return ! there is no label + end if + lblset = 'set title "' + label = this%tpplottitle + end select + + lblstring = '' + ! if there is a label continue to set it + lblstring = lblstring // lblset // trim(label%lbltext)//'"' + if (allocated(label%lblcolor)) then + lblstring = lblstring // ' tc "' //trim(label%lblcolor) // '"' + end if + ! set font and size + if (allocated(this%tpxlabel%lblfontname)) then + lblstring = lblstring // ' font "'// trim(label%lblfontname) // ',' + if (label%lblfontsize /= NOT_INITIALIZED) then + lblstring = lblstring // num2str(label%lblfontsize) //'"' + else + lblstring = lblstring //'"' + end if + else ! check if only font size has been given + if (label%lblfontsize /= NOT_INITIALIZED ) then + lblstring = lblstring // ' font ",' // num2str(label%lblfontsize) //'"' + end if + end if + ! set rotation + if (label%lblrotate /= NOT_INITIALIZED ) then + lblstring = lblstring // ' rotate by ' // num2str(label%lblrotate ) + end if + + + ! write to ogpf script file + write ( this%file_unit, '(a)' ) lblstring + + + end subroutine write_label + + + + function color_palettes(palette_name) result(str) + !............................................................................... + ! color_palettes create color palette as a + ! string to be written into gnuplot script file + ! the palettes credit goes to: Anna Schnider (https://github.com/aschn) and + ! Hagen Wierstorf (https://github.com/hagenw) + !............................................................................... + character(len=*), intent(in) :: palette_name + character(len=:), allocatable :: str + + ! local variables + character(len=1) :: strnumber + character(len=11) :: strblank + integer :: j + integer :: maxcolors + + ! define the color palettes + character(len=:), allocatable :: pltname + character(len=7) :: palette(9) ! palettes with maximum 9 colors + + maxcolors = 8 ! default number of discrete colors + palette='' + select case ( lcase(trim(adjustl(palette_name))) ) + case ('set1') + pltname='set1' + palette(1:maxcolors)=[& + "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", & + "#FF7F00", "#FFFF33", "#A65628", "#F781BF" ] + case ('set2') + pltname='set2' + palette(1:maxcolors)=[& + "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", & + "#A6D854", "#FFD92F", "#E5C494", "#B3B3B3" ] + case ('set3') + pltname='set3' + palette(1:maxcolors)=[& + "#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072", & + "#80B1D3", "#FDB462", "#B3DE69", "#FCCDE5" ] + case ('palette1') + pltname='palette1' + palette(1:maxcolors)=[& + "#FBB4AE", "#B3CDE3", "#CCEBC5", "#DECBE4", & + "#FED9A6", "#FFFFCC", "#E5D8BD", "#FDDAEC" ] + case ('palette2') + pltname='palette2' + palette(1:maxcolors)=[& + "#B3E2CD", "#FDCDAC", "#CDB5E8", "#F4CAE4", & + "#D6F5C9", "#FFF2AE", "#F1E2CC", "#CCCCCC" ] + case ('paired') + pltname='paired' + palette(1:maxcolors)=[& + "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", & + "#FB9A99", "#E31A1C", "#FDBF6F", "#FF7F00" ] + case ('dark2') + pltname='dark2' + palette(1:maxcolors)=[& + "#1B9E77", "#D95F02", "#7570B3", "#E7298A", & + "#66A61E", "#E6AB02", "#A6761D", "#666666" ] + case ('accent') + pltname='accent' + palette(1:maxcolors)=[& + "#7FC97F", "#BEAED4", "#FDC086", "#FFFF99", & + "#386CB0", "#F0027F", "#BF5B17", "#666666" ] + case ('jet') + ! Matlab jet palette + maxcolors = 9 + pltname='jet' + palette(1:maxcolors)=[& + '#000090', '#000fff', '#0090ff', '#0fffee', & + '#90ff70', '#ffee00', '#ff7000', '#ee0000', '#7f0000' ] + case default + print*, md_name // ": color_palettes: wrong palette name" + print*, 'gnuplot default palette will be used!' + str=' ' ! empty palette is returned! + return + end select + + ! generate the gnuplot palette as a single multiline string + str = '# Define the ' // pltname // ' pallete' // new_line(' ') + str = str // 'set palette defined ( \' // new_line(' ') + strblank = ' ' ! pad certain number of paces + do j=1, maxcolors - 1 + write(unit =strnumber, fmt='(I1)' ) j-1 + str = str // strblank // strnumber // ' "' // palette(j) // '",\' // new_line(' ') + end do + + j =maxcolors + write(strnumber, fmt='(I1)') j + str = str // strblank // strnumber // ' "' // palette(j) // '" )' // new_line(' ') + + end function color_palettes + + + + subroutine write_xydata(file_unit,ndata,x,y) + !.............................................................................. + ! Writes set of xy data into a file + !.............................................................................. + + integer, intent(in) :: file_unit + integer, intent(in) :: ndata + real(wp), intent(in) :: x(:) + real(wp), intent(in), optional :: y(:) + + integer:: i + + ! TODO (Mohammad#1#12/22/17): The format string shall be modified to write the + ! number in more suitable form + ! Rev 0.18 + if (present(y) ) then !both x and y are present, data are xy set + do i = 1, ndata + write ( file_unit, * ) x(i), y(i) + end do + else !only x is passed, data are index-x set + do i = 1, ndata + write ( file_unit, * ) x(i) + end do + end if + write ( file_unit, '(a)' ) 'e' !end of set of data + + end subroutine write_xydata + + + + subroutine create_outputfile(this) + !.............................................................................. + ! Create an output file, assign a file_unit + ! for writing the gnuplot commands + !.............................................................................. + + ! Rev 0.18 + class(gpf), intent(INOUT ) :: this + + if (this%hasfileopen) then + ! there is nothing to do, file has been already open! + return + end if + + !> Rev 0.2 animation + + ! animation handling + if (this%hasanimation ) then + this%frame_number = this%frame_number + 1 ! for future use + end if + + ! Open the output file + + if (.not. (this%hasfilename)) then ! check if no file has been set by user + this%txtfilename=gnuplot_output_filename + end if + + open ( newunit = this%file_unit, file = this%txtfilename, status = 'replace', iostat = this%status ) + + + if (this%status /= 0 ) then + print*, "md_helperproc, create_outputfile: cannot open file for output" + stop + end if + + + ! Set the gnuplot terminal, write ogpf configuration (customized setting) + ! Can be overwritten by options + + ! write signature + write ( this%file_unit, '(a)' ) '# ' // md_name + write ( this%file_unit, '(a)' ) '# ' // md_rev + write ( this%file_unit, '(a)' ) '# ' // md_lic + write ( this%file_unit, '(a)' ) ! emptyline + + ! write the global settings + write ( this%file_unit, '(a)' ) '# gnuplot global setting' + write(unit=this%file_unit, fmt='(a)') 'set term ' // gnuplot_term_type // & + ' size ' // gnuplot_term_size // ' enhanced font "' // & + gnuplot_term_font // '"' // & + ' title "' // md_name // ': ' // md_rev //'"' ! library name and version + + ! write the preset configuration for gnuplot (ogpf customized settings) + if (this%preset_configuration) then + call this%preset_gnuplot_config() + end if + ! write multiplot setting + if (this%hasmultiplot) then + write(this%file_unit, fmt='(a, I2, a, I2)') 'set multiplot layout ', & + this%multiplot_rows, ',', this%multiplot_cols + end if + ! set flag true for file is opened + this%hasfileopen = .true. + + end subroutine create_outputfile + + + subroutine preset_gnuplot_config(this) + !.............................................................................. + ! To write the preset configuration for gnuplot (ogpf customized settings) + !.............................................................................. + class(gpf) :: this + + write(this%file_unit, fmt='(a)') + write(this%file_unit, fmt='(a)') '# ogpf extra configuration' + write(this%file_unit, fmt='(a)') '# -------------------------------------------' + + + ! color definition + write(this%file_unit, fmt='(a)') '# color definitions' + write(this%file_unit, fmt='(a)') 'set style line 1 lc rgb "#800000" lt 1 lw 2' + write(this%file_unit, fmt='(a)') 'set style line 2 lc rgb "#ff0000" lt 1 lw 2' + write(this%file_unit, fmt='(a)') 'set style line 3 lc rgb "#ff4500" lt 1 lw 2' + write(this%file_unit, fmt='(a)') 'set style line 4 lc rgb "#ffa500" lt 1 lw 2' + write(this%file_unit, fmt='(a)') 'set style line 5 lc rgb "#006400" lt 1 lw 2' + write(this%file_unit, fmt='(a)') 'set style line 6 lc rgb "#0000ff" lt 1 lw 2' + write(this%file_unit, fmt='(a)') 'set style line 7 lc rgb "#9400d3" lt 1 lw 2' + write(this%file_unit, fmt='(a)') + ! axes setting + write(this%file_unit, fmt='(a)') '# Axes' + write(this%file_unit, fmt='(a)') 'set border linewidth 1.15' + write(this%file_unit, fmt='(a)') 'set tics nomirror' + write(this%file_unit, fmt='(a)') + + write(this%file_unit, fmt='(a)') '# grid' + write(this%file_unit, fmt='(a)') '# Add light grid to plot' + write(this%file_unit, fmt='(a)') 'set style line 102 lc rgb "#d6d7d9" lt 0 lw 1' + write(this%file_unit, fmt='(a)') 'set grid back ls 102' + write(this%file_unit, fmt='(a)') + ! set the plot style + write(this%file_unit, fmt='(a)') '# plot style' + write(this%file_unit, fmt='(a)') 'set style data linespoints' + write(this%file_unit, fmt='(a)') + + write(this%file_unit, fmt='(a)') '# -------------------------------------------' + write(this%file_unit, fmt='(a)') '' + + + end subroutine preset_gnuplot_config + + + + subroutine finalize_plot(this) + !.............................................................................. + ! To finalize the writing of gnuplot commands/data and close the output file. + !.............................................................................. + class(gpf) :: this + + ! check for multiplots + if (this%hasmultiplot) then + if (this%multiplot_total_plots < this%multiplot_rows * this%multiplot_cols - 1 ) then + ! increment the number of plots + this%multiplot_total_plots = this%multiplot_total_plots + 1 + return ! do not finalize plot, still there is places in multiplot + else + ! close multiplot + write(this%file_unit, fmt='(a)') 'unset multiplot' + ! reset multiplot flag + this%hasmultiplot = .false. + + end if + end if + + close ( unit = this%file_unit ) ! close the script file + this%hasfileopen = .false. ! reset file open flag + this%hasanimation = .false. + ! Use shell command to run gnuplot + if (get_os_type() == 1) then + call execute_command_line ('wgnuplot -persist ' // this%txtfilename) ! Now plot the results + else + call execute_command_line ('gnuplot -persist ' // this%txtfilename) ! Now plot the results + end if + contains + integer function get_os_type() result(r) + !! Returns one of OS_WINDOWS, others + !! At first, the environment variable `OS` is checked, which is usually + !! found on Windows. + !! Copy from fpm/fpm_environment: https://github.com/fortran-lang/fpm/blob/master/src/fpm_environment.F90 + character(len=32) :: val + integer :: length, rc + + integer, parameter :: OS_OTHERS = 0 + integer, parameter :: OS_WINDOWS = 1 + + r = OS_OTHERS + ! Check environment variable `OS`. + call get_environment_variable('OS', val, length, rc) + + if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then + r = OS_WINDOWS + return + end if + + end function + + end subroutine finalize_plot + + + + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !!> Section Six: Utility and helper procedures + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + function hastitle(string) + !.............................................................................. + ! check to see if the plot title (used as legend = key) + !.............................................................................. + + character(len=*), intent(in) :: string + logical:: hastitle + integer:: idx1 + integer:: idx2 + + idx1=index( lcase(string),'title') !Check if title is passed + idx2=index(' ' // lcase(string),' t ') !Check if the abbreviated title 't' is passed. Extra space is added + ! at the beginning of string to find starting 't' + if (idx1 /=0 .or. idx2 /=0 ) then + hastitle=.true. + else + hastitle=.false. + end if + + end function hastitle + + + function checkdim(nx,ny) + !.............................................................................. + ! checkdim checks the equality of dimensions of two vector + !.............................................................................. + + integer, intent(in):: nx + integer, intent(in):: ny + logical:: checkdim + if (nx/=ny) then + checkdim=.false. + else + checkdim=.true. + end if + + end function checkdim + + + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !> Section Seven: String utility Routines + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + + pure function splitstr(str) result(spstr) + !.............................................................................. + !splitstr, separate a string using ";" delimiters + !.............................................................................. + + character(len=*), intent(in) :: str + + ! local variables + character, parameter :: delimiter=';' + character(len=:), allocatable :: spstr + integer :: n + integer :: m + integer :: k + + + k=len_trim(str) !length with removed trailing blanks + n=scan(str,delimiter) + if (n==0) then ! This is a single statement + spstr = adjustl(str) // new_line(' ') + return + end if + + ! for two or more statements separated by ; + spstr = '' + m=1 + do while (n/=0 .and. m=65 .and. n <= 90) then + lcase(i:i)=char(n+32) + else + lcase(i:i)=chr + end if + end do + end function lcase + + + function num2str_i4(number_in) + !.............................................................................. + ! num2str_int: converts integer number to string + !.............................................................................. + + integer(kind=kind(1)), intent(in) :: number_in + character(len=:), allocatable :: num2str_i4 + + ! local variable + character(len=range(number_in)) :: strnm + write(unit=strnm, fmt='(I0)') number_in + num2str_i4 = trim(strnm) + + end function num2str_i4 + + function num2str_r4(number_in, strfmt) + !.............................................................................. + ! num2str_r4: converts single precision real number to string + ! strfmt is the optional format string + !.............................................................................. + + real(kind=sp), intent(in) :: number_in + character(len=*), intent(in), optional :: strfmt + character(len=:), allocatable :: num2str_r4 + + ! local variable + character(len=range(number_in)) :: strnm + + + if (present(strfmt)) then + write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in + else + write(unit=strnm, fmt='(G0)') number_in + end if + + num2str_r4 = trim(strnm) + + end function num2str_r4 + + + function num2str_r8(number_in, strfmt) + !.............................................................................. + ! num2str_real: converts double precision real number to string + ! strfmt is the optional format string + !.............................................................................. + + real(kind=dp), intent(in) :: number_in + character(len=*), intent(in), optional :: strfmt + character(len=:), allocatable :: num2str_r8 + + ! local variable + character(len=range(number_in)) :: strnm + + if (present(strfmt)) then + write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in + else + write(unit=strnm, fmt='(G0)') number_in + end if + + num2str_r8 = trim(strnm) + + end function num2str_r8 + + + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !!> Section Eight: Math helper function + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + function arange(xa, xb, dx) + !.............................................................................. + ! returns a vector in the form of [xa, xa+dx, xa+2*dx, ...] + ! the number of elements is calculated as m = n+ 1, + ! where n= int ( (xa-xb)/dx) ). + ! arange is similar to colon in Matlab and arange in Python! + ! + ! NOTE: + ! - If n calculated as zero, result is [xa] + ! - If n calculated as Inf (dx=0), a fatal error will be raised + ! - If n calculated as negative value (e.g xa 0.0 " + stop + end if + else + dxl = 1.0_wp + end if + + if ( (xa < xb) .and. (dx < 0.0_wp) ) then + print*, "arange procedure: Fatal Error: wrong dx, use a dx > 0.0 " + stop + end if + + n = int( (xb-xa)/ dxl) ! n+1 is the number of elements + + allocate(arange(n), stat=ierr) + + if (ierr /= 0) then + print*, "arange procedure: Fatal Error, allocation failed in arange function" + stop + end if + + arange = [(xa + i*dxl, i=0, n)] + + end function arange + + + function linspace(a,b,n_elements) + !.............................................................................. + ! returns a linearly spaced vector with n points in [a, b] + ! if n is omitted, 100 points will be considered + !.............................................................................. + + real(wp), intent(in) :: a + real(wp), intent(in) :: b + integer, intent(in), optional :: n_elements + real(wp), allocatable :: linspace(:) + + ! Local vars + real(wp) :: dx + integer :: i + integer :: n + integer :: ierr + + if (present(n_elements)) then + if (n_elements <=1 ) then + print*, "linspace procedure: Error: wrong value of n_elements, use an n_elements > 1" + stop + end if + n=n_elements + else + n=100 + end if + + allocate(linspace(n), stat=ierr) + if (ierr /= 0) then + print*, "linspace procedure: Fatal Error, Allocation failed in linspace function" + stop + end if + + dx=(b-a)/real((n-1),wp) + linspace=[(i*dx+a, i=0,n-1)] + + end function linspace + + + + subroutine meshgrid(x,y,xgv,ygv, ierr) + !.............................................................................. + !meshgrid generate mesh grid over a rectangular domain of [xmin xmax, ymin, ymax] + ! Inputs: + ! xgv, ygv are grid vectors in form of full grid data + ! Outputs: + ! X and Y are matrix each of size [ny by nx] contains the grid data. + ! The coordinates of point (i,j) is [X(i,j), Y(i,j)] + ! ierr: The error flag + ! """ + ! # Example + ! # call meshgrid(X, Y, [0.,1.,2.,3.],[5.,6.,7.,8.]) + ! # X + ! # [0.0, 1.0, 2.0, 3.0, + ! # 0.0, 1.0, 2.0, 3.0, + ! # 0.0, 1.0, 2.0, 3.0, + ! # 0.0, 1.0, 2.0, 3.0] + ! # + ! #Y + ! #[ 5.0, 5.0, 5.0, 5.0, + ! # 6.0, 6.0, 6.0, 6.0, + ! # 7.0, 7.0, 7.0, 7.0, + ! # 8.0, 8.0, 8.0, 8.0] + !.............................................................................. + ! Rev 0.2, Feb 2018 + ! New feature added: xgv and ygv as full grid vector are accepted now + + ! Arguments + real(wp), intent(out), allocatable :: x(:,:) + real(wp), intent(out), allocatable :: y(:,:) + real(wp), intent(in) :: xgv(:) ! x grid vector [start, stop, step] or [start, stop] + real(wp), intent(in), optional :: ygv(:) ! y grid vector [start, stop, step] or [start, stop] + integer, intent(out), optional :: ierr ! the error value + + ! Local variables + integer:: sv + integer:: nx + integer:: ny + logical:: only_xgv_available + + ! Initial setting + only_xgv_available = .false. + sv=0 !Assume no error + + nx=size(xgv, dim=1) + + if (present(ygv)) then + ny = size(ygv, dim=1) + else + only_xgv_available=.true. + ny=nx + end if + + allocate(x(ny,nx),y(ny,nx),stat=sv) + if (sv /=0) then + print*, "allocataion erro in meshgrid" + stop + end if + + x(1,:) = xgv + x(2:ny,:) = spread(xgv, dim=1, ncopies=ny-1) + + if (only_xgv_available) then + y=transpose(x) + else + y(:,1) = ygv + y(:,2:nx) = spread(ygv,dim=2,ncopies=nx-1) + end if + + if (present(ierr)) then + ierr=sv + end if + + end subroutine meshgrid + + + !End of ogpf +end module ogpf diff --git a/src/modules/Hashing/CMakeLists.txt b/src/modules/Hashing/CMakeLists.txt new file mode 100644 index 000000000..0d99ecce7 --- /dev/null +++ b/src/modules/Hashing/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}/Hashing32.F90" +) \ No newline at end of file diff --git a/src/modules/Hashing/src/Hashing32.F90 b/src/modules/Hashing/src/Hashing32.F90 new file mode 100644 index 000000000..4af97335c --- /dev/null +++ b/src/modules/Hashing/src/Hashing32.F90 @@ -0,0 +1,315 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 code is taken from +! +! https://github.com/fortran-lang/stdlib/blob/master/src/stdlib_hash_32bit.fypp +! +! `FNV_1_HASH` and `FNV_1A_Hash` are translations to Fortran 2008 of the `FNV-1` +! and `FNV-1a` hash functions of Glenn Fowler, Landon Curt Noll, and Phong Vo, that +! has been released into the public domain. + +MODULE Hashing32 + +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: CHARACTER_STORAGE_SIZE +USE GlobalData, ONLY: I4B, LGT, dp, INT8, INT16, INT32, INT64 +USE GlobalData, ONLY: BITS_INT8 => BIInt8, BITS_INT16 => BIInt16, & + & BITS_INT32 => BIInt32, BITS_INT64 => BIInt64, & + & BYTES_INT8 => BYInt8, & + & BYTES_INT16 => BYInt16, & + & BYTES_INT32 => BYInt32, & + & BYTES_INT64 => BYInt64 +IMPLICIT NONE +PRIVATE + +INTEGER(I4B), PARAMETER, PUBLIC :: INT_HASH = INT32 +!! The number of bits in the output hash +INTEGER(I4B), PARAMETER :: POW32_OVER_PHI = INT(z'9E3779B9', INT32) +!! pow32_over_phi is the odd integer that most closely approximates +!! 2**32/phi, where phi is the golden ratio 1.618... +INTEGER(I4B), PARAMETER :: BITS_CHAR = CHARACTER_STORAGE_SIZE +INTEGER(I4B), PARAMETER :: BYTES_CHAR = BITS_CHAR / BITS_INT8 + +! Dealing with different endians +LOGICAL(LGT), PARAMETER, PUBLIC :: little_endian = & + & (1 == TRANSFER([1_INT8, 0_INT8], 0_INT16)) + +PUBLIC :: fibonacci_hash, odd_random_integer, universal_mult_hash +PUBLIC :: fnv_1_hash +PUBLIC :: fnv_1a_hash +PUBLIC :: nmhash32 +PUBLIC :: nmhash32x +PUBLIC :: new_water_hash_seed +PUBLIC :: water_hash +PUBLIC :: new_nmhash32_seed +PUBLIC :: new_nmhash32x_seed + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 July 2022 +! summary: FNV_1 hash function for rank 1 array keys of integers + +INTERFACE fnv_1_hash + MODULE PURE FUNCTION Int8_fnv_1(key) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int8_fnv_1 + + MODULE PURE FUNCTION Int16_fnv_1(key) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int16_fnv_1 + + MODULE PURE FUNCTION Int32_fnv_1(key) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int32_fnv_1 + + MODULE PURE FUNCTION Int64_fnv_1(key) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int64_fnv_1 + + MODULE PURE FUNCTION Char_fnv_1(key) RESULT(ans) + CHARACTER(*), INTENT(IN) :: key + INTEGER(INT_HASH) :: ans + END FUNCTION Char_fnv_1 +END INTERFACE fnv_1_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE fnv_1a_hash + MODULE PURE FUNCTION Int8_fnv_1a(key) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int8_fnv_1a + + MODULE PURE FUNCTION Int16_fnv_1a(key) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int16_fnv_1a + + MODULE PURE FUNCTION Int32_fnv_1a(key) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int32_fnv_1a + + MODULE PURE FUNCTION Int64_fnv_1a(key) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: key(:) + INTEGER(INT_HASH) :: ans + END FUNCTION Int64_fnv_1a + + MODULE PURE FUNCTION Char_fnv_1a(key) RESULT(ans) + CHARACTER(*), INTENT(IN) :: key + INTEGER(INT_HASH) :: ans + END FUNCTION Char_fnv_1a +END INTERFACE fnv_1a_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE nmhash32 + MODULE PURE FUNCTION Int8_nmhash32(key, seed) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int8_nmhash32 + MODULE PURE FUNCTION Int16_nmhash32(key, seed) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int16_nmhash32 + MODULE PURE FUNCTION Int32_nmhash32(key, seed) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int32_nmhash32 + MODULE PURE FUNCTION Int64_nmhash32(key, seed) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int64_nmhash32 + MODULE PURE FUNCTION Char_nmhash32(key, seed) RESULT(ans) + CHARACTER(*), INTENT(IN) :: key + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Char_nmhash32 +END INTERFACE nmhash32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE nmhash32x + MODULE PURE FUNCTION Int8_nmhash32x(key, seed) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int8_nmhash32x + MODULE PURE FUNCTION Int16_nmhash32x(key, seed) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int16_nmhash32x + MODULE PURE FUNCTION Int32_nmhash32x(key, seed) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int32_nmhash32x + MODULE PURE FUNCTION Int64_nmhash32x(key, seed) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: key(0:) + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int64_nmhash32x + MODULE PURE FUNCTION Char_nmhash32x(key, seed) RESULT(ans) + CHARACTER(*), INTENT(IN) :: key + INTEGER(INT32), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Char_nmhash32x +END INTERFACE nmhash32x + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE water_hash + MODULE PURE FUNCTION Int8_water_hash(key, seed) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: key(0:) + INTEGER(INT64), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int8_water_hash + MODULE PURE FUNCTION Int16_water_hash(key, seed) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: key(0:) + INTEGER(INT64), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int16_water_hash + MODULE PURE FUNCTION Int32_water_hash(key, seed) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: key(0:) + INTEGER(INT64), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int32_water_hash + MODULE PURE FUNCTION Int64_water_hash(key, seed) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: key(0:) + INTEGER(INT64), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Int64_water_hash + MODULE PURE FUNCTION Char_water_hash(key, seed) RESULT(ans) + CHARACTER(*), INTENT(IN) :: key + INTEGER(INT64), INTENT(IN) :: seed + INTEGER(INT_HASH) :: ans + END FUNCTION Char_water_hash +END INTERFACE water_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE new_water_hash_seed(seed) + INTEGER(INT64), INTENT(INOUT) :: seed + END SUBROUTINE new_water_hash_seed +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE new_nmhash32_seed(seed) + INTEGER(INT_HASH), INTENT(INOUT) :: seed + END SUBROUTINE new_nmhash32_seed +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE new_nmhash32x_seed(seed) + INTEGER(INT_HASH), INTENT(INOUT) :: seed + END SUBROUTINE new_nmhash32x_seed +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +!> author: Vikas Sharma, Ph. D. +! date: 25 July 2023 +! summary: Maps the 32 bit integer `key` to an unsigned integer value with +! only `nbits` bits where `nbits` is less than 32 + +ELEMENTAL FUNCTION fibonacci_hash(key, nbits) RESULT(sample) + INTEGER(INT32), INTENT(IN) :: key + INTEGER, INTENT(IN) :: nbits + INTEGER(INT32) :: sample + sample = ISHFT(key * pow32_over_phi, -32 + nbits) +END FUNCTION fibonacci_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 July 2022 +! summary: Universal mult hash +! +!# Introduction +! +! Uses the "random" odd 32 bit integer `seed` to map the 32 bit integer +! `key` to an unsigned integer value with only `nbits` bits where `nbits` is +! less than 32 + +ELEMENTAL FUNCTION universal_mult_hash(key, seed, nbits) RESULT(sample) + INTEGER(INT32), INTENT(IN) :: key + INTEGER(INT32), INTENT(IN) :: seed + INTEGER, INTENT(IN) :: nbits + INTEGER(INT32) :: sample + sample = ISHFT(key * seed, -32 + nbits) +END FUNCTION universal_mult_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 July 2022 +! summary: +! +!# Introduction +! +! Returns a 32 bit pseudo random integer, `harvest`, distributed uniformly +! over the odd integers of the `Int32` kind. + +SUBROUTINE odd_random_integer(harvest) + INTEGER(INT32), INTENT(OUT) :: harvest + REAL(dp) :: sample + CALL RANDOM_NUMBER(sample) + harvest = INT(FLOOR(sample * 2_INT64**32, INT64) - 2_INT64**31, & + & INT32) + harvest = ISHFT(harvest, 1) + 1_INT32 +END SUBROUTINE odd_random_integer + +END MODULE Hashing32 diff --git a/src/modules/IndexValue/CMakeLists.txt b/src/modules/IndexValue/CMakeLists.txt new file mode 100644 index 000000000..13c7b7c88 --- /dev/null +++ b/src/modules/IndexValue/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/IndexValue_Method.F90 +) \ No newline at end of file diff --git a/src/modules/IndexValue/src/IndexValue_Method.F90 b/src/modules/IndexValue/src/IndexValue_Method.F90 new file mode 100644 index 000000000..705fc04ae --- /dev/null +++ b/src/modules/IndexValue/src/IndexValue_Method.F90 @@ -0,0 +1,70 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IndexValue_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! IndexValue@Constructor +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Constructor1( Indx, Val ) RESULT( obj ) + INTEGER( I4B ), INTENT( IN ) :: Indx + REAL( DFP ), INTENT( IN ) :: Val + TYPE(IndexValue_) :: obj + END FUNCTION Constructor1 +END INTERFACE + +!---------------------------------------------------------------------------- +! IndexValue@Constructor +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Constructor2( Indx, Val ) RESULT( obj ) + INTEGER( I4B ), INTENT( IN ) :: Indx( : ) + REAL( DFP ), INTENT( IN ) :: Val( : ) + TYPE(IndexValue_), ALLOCATABLE :: obj( : ) + END FUNCTION Constructor2 +END INTERFACE + +!---------------------------------------------------------------------------- +! IndexValue@Constructor +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Constructor3( Indx, Val ) RESULT( obj ) + INTEGER( I4B ), INTENT( IN ) :: Indx( : ) + REAL( DFP ), INTENT( IN ) :: Val + TYPE(IndexValue_), ALLOCATABLE :: obj( : ) + END FUNCTION Constructor3 +END INTERFACE + +!---------------------------------------------------------------------------- +! IndexValue@Constructor +!---------------------------------------------------------------------------- + +INTERFACE IndexValue + MODULE PROCEDURE Constructor1, Constructor2, Constructor3 +END INTERFACE IndexValue + +PUBLIC :: IndexValue + +END MODULE IndexValue_Method \ No newline at end of file diff --git a/src/modules/IntVector/CMakeLists.txt b/src/modules/IntVector/CMakeLists.txt new file mode 100644 index 000000000..c07368964 --- /dev/null +++ b/src/modules/IntVector/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}/IntVector_ConstructorMethod.F90 + ${src_path}/IntVector_IOMethod.F90 + ${src_path}/IntVector_GetMethod.F90 + ${src_path}/IntVector_SetMethod.F90 + ${src_path}/IntVector_AppendMethod.F90 + ${src_path}/IntVector_EnquireMethod.F90 + ${src_path}/IntVector_Method.F90 +) diff --git a/src/modules/IntVector/src/IntVector_AppendMethod.F90 b/src/modules/IntVector/src/IntVector_AppendMethod.F90 new file mode 100644 index 000000000..60c9d7760 --- /dev/null +++ b/src/modules/IntVector/src/IntVector_AppendMethod.F90 @@ -0,0 +1,124 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IntVector_AppendMethod +USE BaseType, ONLY: IntVector_ +USE GlobalData, ONLY: DFP, I4B, LGT +PRIVATE + +PUBLIC :: Append +PUBLIC :: H_CONCAT + +!---------------------------------------------------------------------------- +! Append@setMethods +!---------------------------------------------------------------------------- + +INTERFACE Append + MODULE PURE SUBROUTINE IntVec_Append_1(obj, VALUE) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: VALUE + END SUBROUTINE IntVec_Append_1 +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@setMethods +!---------------------------------------------------------------------------- + +INTERFACE Append + MODULE PURE SUBROUTINE IntVec_Append_2(obj, VALUE) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: VALUE(:) + END SUBROUTINE IntVec_Append_2 +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@setMethods +!---------------------------------------------------------------------------- + +INTERFACE Append + MODULE PURE SUBROUTINE IntVec_Append_3(obj, Anotherobj) + CLASS(IntVector_), INTENT(INOUT) :: obj + CLASS(IntVector_), INTENT(IN) :: Anotherobj + END SUBROUTINE IntVec_Append_3 +END INTERFACE Append + +!---------------------------------------------------------------------------- +! H_CONCAT@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 June 2021 +! summary: Horizontally concat two integer vectors + +INTERFACE H_CONCAT + MODULE PURE FUNCTION IntVec_H_CONCAT_1(vec1, vec2) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: vec1(:) + INTEGER(I4B), INTENT(IN) :: vec2(:) + INTEGER(I4B) :: ans(SIZE(vec1) + SIZE(vec2)) + END FUNCTION IntVec_H_CONCAT_1 +END INTERFACE H_CONCAT + +!---------------------------------------------------------------------------- +! H_CONCAT@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 June 2021 +! summary: Horizontally concat two [[IntVector_]] + +INTERFACE H_CONCAT + MODULE PURE FUNCTION IntVec_H_CONCAT_2(obj1, obj2) RESULT(Ans) + TYPE(IntVector_), INTENT(IN) :: obj1 + TYPE(IntVector_), INTENT(IN) :: obj2 + TYPE(IntVector_) :: ans + END FUNCTION IntVec_H_CONCAT_2 +END INTERFACE H_CONCAT + +!---------------------------------------------------------------------------- +! H_CONCAT@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 June 2021 +! summary: Horizontally concat a integer vector to a IntVec datatype. + +INTERFACE H_CONCAT + MODULE PURE FUNCTION IntVec_H_CONCAT_3(vec1, obj2) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: vec1(:) + TYPE(IntVector_), INTENT(IN) :: obj2 + TYPE(IntVector_) :: ans + END FUNCTION IntVec_H_CONCAT_3 +END INTERFACE H_CONCAT + +!---------------------------------------------------------------------------- +! H_CONCAT@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 June 2021 +! summary: Horizontally concat a integer vector to a IntVec datatype. + +INTERFACE H_CONCAT + MODULE PURE FUNCTION IntVec_H_CONCAT_4(obj1, vec2) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: vec2(:) + TYPE(IntVector_), INTENT(IN) :: obj1 + TYPE(IntVector_) :: ans + END FUNCTION IntVec_H_CONCAT_4 +END INTERFACE H_CONCAT + +END MODULE IntVector_AppendMethod + + diff --git a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 new file mode 100644 index 000000000..37c0ded01 --- /dev/null +++ b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 @@ -0,0 +1,374 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IntVector_ConstructorMethod +USE BaseType, ONLY: IntVector_ +USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, & +& REAL64, REAL32 +PRIVATE + +PUBLIC :: Shape +PUBLIC :: SIZE +PUBLIC :: getTotalDimension +PUBLIC :: ALLOCATE +PUBLIC :: DEALLOCATE +PUBLIC :: Reallocate +PUBLIC :: Initiate +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: IntVector +PUBLIC :: IntVector_Pointer +PUBLIC :: Convert + +!---------------------------------------------------------------------------- +! Shape@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! 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 +END INTERFACE Shape + +!---------------------------------------------------------------------------- +! SIZE@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Returns size of the vector + +INTERFACE Size + MODULE PURE FUNCTION intVec_Size(obj, Dims) RESULT(Ans) + TYPE(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims + INTEGER(I4B) :: Ans + END FUNCTION intVec_Size +END INTERFACE Size + +!---------------------------------------------------------------------------- +! TotalDimension@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Returns the total dimension of an array +! +!# Introduction +! +! This function returns the total dimension (or rank) of an array, + +INTERFACE GetTotalDimension + MODULE PURE FUNCTION IntVec_getTotalDimension(obj) RESULT(Ans) + TYPE(IntVector_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION IntVec_getTotalDimension +END INTERFACE GetTotalDimension + +!---------------------------------------------------------------------------- +! Allocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! 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 +END INTERFACE ALLOCATE + +!---------------------------------------------------------------------------- +! Reallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Allocate memory for the vector + +INTERFACE Reallocate + MODULE PURE SUBROUTINE intVec_Reallocate(obj, row) + TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE intVec_Reallocate +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Deallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Deallocate memory occupied by IntVector + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE intVec_Deallocate(obj) + CLASS(IntVector_), INTENT(INOUT) :: obj + END SUBROUTINE intVec_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine initiates the [[IntVector_]] +! +!# Introduction +! +! This routine initiates an instance of IntVector +! Only the size of intvector is set. + +INTERFACE Initiate + MODULE PURE SUBROUTINE intVec_initiate1(obj, tSize) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tSize + END SUBROUTINE intVec_initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine initiates the vector of [[IntVector_]] + +INTERFACE Initiate + MODULE PURE SUBROUTINE intVec_initiate2(obj, tSize) + TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: tSize(:) + END SUBROUTINE intVec_initiate2 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! 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 + INTEGER(I4B), INTENT(IN) :: a, b + END SUBROUTINE intVec_initiate3 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Initiates an instance by using a vector of integers +! +!# Introduction +! This routine initiates an instance of intvector by coping data +! from integer vector. +! +! This routine also define an assignment operator, obj=val + +INTERFACE Initiate + MODULE PURE SUBROUTINE intVec_initiate4a(obj, val) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(INT8), INTENT(IN) :: val(:) + END SUBROUTINE intVec_initiate4a + !! + MODULE PURE SUBROUTINE intVec_initiate4b(obj, val) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(INT16), INTENT(IN) :: val(:) + END SUBROUTINE intVec_initiate4b + !! + MODULE PURE SUBROUTINE intVec_initiate4c(obj, val) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(INT32), INTENT(IN) :: val(:) + END SUBROUTINE intVec_initiate4c + !! + MODULE PURE SUBROUTINE intVec_initiate4d(obj, val) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(INT64), INTENT(IN) :: val(:) + END SUBROUTINE intVec_initiate4d +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE intVec_initiate4a, intVec_initiate4b, & + & intVec_initiate4c, intVec_initiate4d +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Initiates an instance by using a vector of real numbers +! +!# Introduction +! +! This routine initiates an instance of IntVector by copying data +! from a vector of reals. This routien also defines assignment operator, +! obj=val + +INTERFACE Initiate + MODULE PURE SUBROUTINE intVec_initiate5a(obj, val) + CLASS(IntVector_), INTENT(INOUT) :: obj + REAL(REAL32), INTENT(IN) :: val(:) + END SUBROUTINE intVec_initiate5a + !! + MODULE PURE SUBROUTINE intVec_initiate5b(obj, val) + CLASS(IntVector_), INTENT(INOUT) :: obj + REAL(REAL64), INTENT(IN) :: val(:) + END SUBROUTINE intVec_initiate5b +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE intVec_initiate5a, intVec_initiate5b +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! IntVector@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: IntVector returns an instance of [[IntVector_]] of given size + +INTERFACE IntVector + MODULE PURE FUNCTION intVec_Constructor1(tSize) RESULT(obj) + TYPE(IntVector_) :: obj + INTEGER(I4B), INTENT(IN) :: tSize + END FUNCTION intVec_Constructor1 +END INTERFACE IntVector + +!---------------------------------------------------------------------------- +! IntVector@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Convert a integer vector into [[IntVector_]] + +INTERFACE IntVector + MODULE PURE FUNCTION intVec_Constructor2(Val) RESULT(obj) + TYPE(IntVector_) :: obj + INTEGER(I4B), INTENT(IN) :: Val(:) + END FUNCTION intVec_Constructor2 +END INTERFACE IntVector + +!---------------------------------------------------------------------------- +! IntVector@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Converts a real vector into [[IntVector_]] +! +! TODO Implement IntVector method for Int4, Int8, Int16, Int32 +! Real32, Real64 +! +INTERFACE IntVector + MODULE PURE FUNCTION intVec_Constructor3(Val) RESULT(obj) + TYPE(IntVector_) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + END FUNCTION intVec_Constructor3 +END INTERFACE IntVector + +!---------------------------------------------------------------------------- +! Vector_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! 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 + INTEGER(I4B), INTENT(IN) :: tSize + END FUNCTION intVec_Constructor_1 +END INTERFACE IntVector_Pointer + +!---------------------------------------------------------------------------- +! Vector_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! 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 + INTEGER(I4B), INTENT(IN) :: Val(:) + END FUNCTION intVec_Constructor_2 +END INTERFACE IntVector_Pointer + +!---------------------------------------------------------------------------- +! Vector_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! 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 + REAL(DFP), INTENT(IN) :: Val(:) + END FUNCTION intVec_Constructor_3 +END INTERFACE IntVector_Pointer + +!---------------------------------------------------------------------------- +! assign@ConstructorMethods +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE IntVec_assign_a(Val, obj) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Val(:) + CLASS(IntVector_), INTENT(IN) :: obj + END SUBROUTINE IntVec_assign_a +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Convert@ConstructorMethods +!---------------------------------------------------------------------------- + +INTERFACE Convert + MODULE PURE SUBROUTINE obj_convert_int(From, To) + CLASS(IntVector_), INTENT(IN) :: From + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: To(:) + END SUBROUTINE obj_convert_int +END INTERFACE Convert + +END MODULE IntVector_ConstructorMethod diff --git a/src/modules/IntVector/src/IntVector_EnquireMethod.F90 b/src/modules/IntVector/src/IntVector_EnquireMethod.F90 new file mode 100644 index 000000000..6a93ce373 --- /dev/null +++ b/src/modules/IntVector/src/IntVector_EnquireMethod.F90 @@ -0,0 +1,127 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IntVector_EnquireMethod +USE Basetype, ONLY: IntVector_ +USE GlobalData, ONLY: DFP, I4B, LGT, INT8, INT16, INT32, INT64 +PRIVATE + +PUBLIC :: OPERATOR(.in.) +PUBLIC :: isPresent +PUBLIC :: isAllocated +PUBLIC :: isInitiated + +!---------------------------------------------------------------------------- +! isAllocated@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if the instance is allocated + +INTERFACE isAllocated + MODULE PURE FUNCTION intVec_isAllocated(obj) RESULT(Ans) + CLASS(IntVector_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION intVec_isAllocated +END INTERFACE isAllocated + +INTERFACE Allocated + MODULE PROCEDURE intVec_isAllocated +END INTERFACE Allocated + +INTERFACE isInitiated + MODULE PROCEDURE intVec_isAllocated +END INTERFACE isInitiated + +!---------------------------------------------------------------------------- +! Operator(.in.)@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another + +INTERFACE OPERATOR(.in.) + MODULE PURE FUNCTION intVec_in1(obj1, obj2) RESULT(Ans) + CLASS(IntVector_), INTENT(IN) :: obj1 + CLASS(IntVector_), INTENT(IN) :: obj2 + LOGICAL(LGT) :: ans + END FUNCTION intVec_in1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Operator(.in.)@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another + +INTERFACE OPERATOR(.in.) + MODULE PURE FUNCTION intVec_in2a(a, obj) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a + CLASS(IntVector_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION intVec_in2a + + MODULE PURE FUNCTION intVec_in2b(a, obj) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a + CLASS(IntVector_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION intVec_in2b + + MODULE PURE FUNCTION intVec_in2c(a, obj) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a + CLASS(IntVector_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION intVec_in2c + + MODULE PURE FUNCTION intVec_in2d(a, obj) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a + CLASS(IntVector_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION intVec_in2d +END INTERFACE OPERATOR(.in.) + +!---------------------------------------------------------------------------- +! isPresent@EnquireMethods +!---------------------------------------------------------------------------- + +INTERFACE isPresent + MODULE PURE FUNCTION intVec_isPresent1(obj, VALUE) RESULT(Ans) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: VALUE + LOGICAL(LGT) :: Ans + END FUNCTION intVec_isPresent1 +END INTERFACE isPresent + +!---------------------------------------------------------------------------- +! isPresent@getMethod +!---------------------------------------------------------------------------- + +INTERFACE isPresent + MODULE PURE FUNCTION intVec_isPresent2(obj, VALUE) RESULT(Ans) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: VALUE(:) + LOGICAL(LGT), ALLOCATABLE :: Ans(:) + END FUNCTION intVec_isPresent2 +END INTERFACE isPresent + +END MODULE IntVector_EnquireMethod diff --git a/src/modules/IntVector/src/IntVector_GetMethod.F90 b/src/modules/IntVector/src/IntVector_GetMethod.F90 new file mode 100644 index 000000000..f04c4768c --- /dev/null +++ b/src/modules/IntVector/src/IntVector_GetMethod.F90 @@ -0,0 +1,421 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE IntVector_GetMethod +USE GlobalData, ONLY: DFP, I4B, LGT, INT8, INT16, INT32, INT64 +USE BaseType, ONLY: IntVector_ +PRIVATE + +PUBLIC :: GET +PUBLIC :: GetPointer +PUBLIC :: GetIndex + +!---------------------------------------------------------------------------- +! get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns IntVector instance + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_1(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + TYPE(IntVector_), INTENT(IN) :: DataType + TYPE(IntVector_) :: Val + END FUNCTION intVec_get_1 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns an instance of [[intvector_]], obj(indx) + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_2(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + TYPE(IntVector_), INTENT(IN) :: DataType + INTEGER(I4B), INTENT(IN) :: Indx(:) + TYPE(IntVector_) :: Val + END FUNCTION intVec_get_2 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns the value using triplets. + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_3(obj, istart, iend, & + & stride, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + TYPE(IntVector_), INTENT(IN) :: DataType + !! an instance of [[IntVector_]] + INTEGER(I4B), INTENT(IN) :: istart + !! starting index value + INTEGER(I4B), OPTIONAL, INTENT(IN) :: iend, stride + !! iend is optional, default value is size(obj) + !! stride is optional, default value is 1. + TYPE(IntVector_) :: Val + !! returned value + END FUNCTION intVec_get_3 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: converts a vector of [[intvector_]] into a scalar instance. +! +! +!# Introduction +! +! Converts a vector of [[intvector_]] into a scalar instance. +! something like following is done. +! +! obj = obj(1) // obj(2) // obj(3) ... +! +! The size of val is size(obj(1)) + size(obj(2)) + ... + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_4(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + TYPE(IntVector_), INTENT(IN) :: DataType + TYPE(IntVector_) :: Val + END FUNCTION intVec_get_4 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Serialized the vector of [[IntVector_]], select values by indx + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_5(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + TYPE(IntVector_), INTENT(IN) :: DataType + INTEGER(I4B), INTENT(IN) :: Indx(:) + TYPE(IntVector_) :: Val + END FUNCTION intVec_get_5 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_6(obj, iStart, iEnd, & + & Stride, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + TYPE(IntVector_), INTENT(IN) :: DataType + TYPE(IntVector_) :: Val + END FUNCTION intVec_get_6 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_7a(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_7a + MODULE PURE FUNCTION intVec_get_7b(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_7b + MODULE PURE FUNCTION intVec_get_7c(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_7c + MODULE PURE FUNCTION intVec_get_7d(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_7d +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_8a(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_8a + MODULE PURE FUNCTION intVec_get_8b(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_8b + MODULE PURE FUNCTION intVec_get_8c(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_8c + MODULE PURE FUNCTION intVec_get_8d(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_8d +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_9a(obj, iStart, iEnd, Stride,& + & DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_9a + MODULE PURE FUNCTION intVec_get_9b(obj, iStart, iEnd, Stride,& + & DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_9b + MODULE PURE FUNCTION intVec_get_9c(obj, iStart, iEnd, Stride,& + & DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_9c + MODULE PURE FUNCTION intVec_get_9d(obj, iStart, iEnd, Stride,& + & DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_9d +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_10a(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_10a + MODULE PURE FUNCTION intVec_get_10b(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_10b + MODULE PURE FUNCTION intVec_get_10c(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_10c + MODULE PURE FUNCTION intVec_get_10d(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_10d +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_11a(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT8), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_11a + MODULE PURE FUNCTION intVec_get_11b(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT16), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_11b + MODULE PURE FUNCTION intVec_get_11c(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT32), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_11c + MODULE PURE FUNCTION intVec_get_11d(obj, Indx, DataType) & + & RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(INT64), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_11d +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_12a(obj, iStart, iEnd, & + & Stride, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_12a + MODULE PURE FUNCTION intVec_get_12b(obj, iStart, iEnd, & + & Stride, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_12b + MODULE PURE FUNCTION intVec_get_12c(obj, iStart, iEnd, & + & Stride, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_12c + MODULE PURE FUNCTION intVec_get_12d(obj, iStart, iEnd, & + & Stride, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64), ALLOCATABLE :: Val(:) + END FUNCTION intVec_get_12d +END INTERFACE Get + +!---------------------------------------------------------------------------- +! get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION intVec_get_13a(obj, indx, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8) :: val + END FUNCTION intVec_get_13a + MODULE PURE FUNCTION intVec_get_13b(obj, indx, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16) :: val + END FUNCTION intVec_get_13b + MODULE PURE FUNCTION intVec_get_13c(obj, indx, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32) :: val + END FUNCTION intVec_get_13c + MODULE PURE FUNCTION intVec_get_13d(obj, indx, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64) :: val + END FUNCTION intVec_get_13d +END INTERFACE Get + +!---------------------------------------------------------------------------- +! getPointers@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetPointer + MODULE FUNCTION intVec_getPointer_1(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN), TARGET :: obj + TYPE(IntVector_), INTENT(IN) :: DataType + TYPE(IntVector_), POINTER :: Val + END FUNCTION intVec_getPointer_1 +END INTERFACE GetPointer + +!---------------------------------------------------------------------------- +! getPointers@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetPointer + MODULE FUNCTION intVec_getPointer_2(obj, DataType) RESULT(Val) + CLASS(IntVector_), INTENT(IN), TARGET :: obj + INTEGER(I4B), INTENT(IN) :: DataType + INTEGER(I4B), POINTER :: Val(:) + END FUNCTION intVec_getPointer_2 +END INTERFACE GetPointer + +!---------------------------------------------------------------------------- +! getIndex@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PURE FUNCTION intVec_getIndex1(obj, Val) RESULT(Ans) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Val + INTEGER(I4B) :: Ans + END FUNCTION intVec_getIndex1 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! getIndex@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PURE FUNCTION intVec_getIndex2(obj, Val) RESULT(Ans) + CLASS(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Val(:) + INTEGER(I4B), ALLOCATABLE :: Ans(:) + END FUNCTION intVec_getIndex2 +END INTERFACE GetIndex + +END MODULE IntVector_GetMethod diff --git a/src/modules/IntVector/src/IntVector_IOMethod.F90 b/src/modules/IntVector/src/IntVector_IOMethod.F90 new file mode 100644 index 000000000..e4b514f8b --- /dev/null +++ b/src/modules/IntVector/src/IntVector_IOMethod.F90 @@ -0,0 +1,57 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE IntVector_IOMethod +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: IntVector_ +PRIVATE +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Display the content of [[IntVector_]] + +INTERFACE Display + MODULE SUBROUTINE intVec_Display1(obj, msg, UnitNo, orient) + CLASS(IntVector_), INTENT(IN) :: obj(:) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + END SUBROUTINE intVec_Display1 +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Display the content of [[IntVector_]] + +INTERFACE Display + MODULE SUBROUTINE intVec_Display2(obj, msg, UnitNo, orient) + CLASS(IntVector_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + CHARACTER(*), OPTIONAL, INTENT(IN) :: orient + END SUBROUTINE intVec_Display2 +END INTERFACE Display + +END MODULE IntVector_IOMethod diff --git a/src/modules/IntVector/src/IntVector_Method.F90 b/src/modules/IntVector/src/IntVector_Method.F90 new file mode 100644 index 000000000..e181f3b44 --- /dev/null +++ b/src/modules/IntVector/src/IntVector_Method.F90 @@ -0,0 +1,38 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 24 Feb 2021 +! summary: This module contains methods of [[IntVector_]] data type. +! +!###Introduction +! +! This module contains methods of [[IntVector_]] data type. +! This module only contains the definition of the interfaces of these +! methods. The actual implementation is given inside the submodules. This +! modules has following submodules: +! + +MODULE IntVector_Method +USE IntVector_ConstructorMethod +USE IntVector_IOMethod +USE IntVector_EnquireMethod +USE IntVector_GetMethod +USE IntVector_SetMethod +USE IntVector_AppendMethod +END MODULE IntVector_Method diff --git a/src/modules/IntVector/src/IntVector_SetMethod.F90 b/src/modules/IntVector/src/IntVector_SetMethod.F90 new file mode 100644 index 000000000..a1545ba0c --- /dev/null +++ b/src/modules/IntVector/src/IntVector_SetMethod.F90 @@ -0,0 +1,101 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IntVector_SetMethod +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: IntVector_ +PRIVATE + +PUBLIC :: setTotalDimension +PUBLIC :: set +PUBLIC :: RemoveDuplicates +PUBLIC :: Repeat + +!---------------------------------------------------------------------------- +! setTotalDimension@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the total dimension (rank) of an array +! +!# Introduction +! +! This subroutine sets the rank(total dimension) of an array + +INTERFACE setTotalDimension + MODULE PURE SUBROUTINE IntVec_setTotalDimension(obj, tDimension) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tDimension + END SUBROUTINE IntVec_setTotalDimension +END INTERFACE setTotalDimension + +!---------------------------------------------------------------------------- +! setValue@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 June 2021 +! summary: set the value in IntVector + +INTERFACE set + MODULE PURE SUBROUTINE intVec_set1(obj, Indx, VALUE) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(I4B), INTENT(IN) :: VALUE(:) + END SUBROUTINE intVec_set1 +END INTERFACE set + +!---------------------------------------------------------------------------- +! setValue@SetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 June 2021 +! summary: set the value in IntVector + +INTERFACE set + MODULE PURE SUBROUTINE intVec_set2(obj, Indx, VALUE) + CLASS(IntVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Indx + INTEGER(I4B), INTENT(IN) :: VALUE + END SUBROUTINE intVec_set2 +END INTERFACE set + +!---------------------------------------------------------------------------- +! RemoveDuplicates@setMethod +!---------------------------------------------------------------------------- + +INTERFACE RemoveDuplicates + MODULE PURE SUBROUTINE IntVec_RemoveDuplicates_1(obj) + CLASS(IntVector_), INTENT(INOUT) :: obj + END SUBROUTINE IntVec_RemoveDuplicates_1 +END INTERFACE RemoveDuplicates + +!---------------------------------------------------------------------------- +! Repeat@setMethod +!---------------------------------------------------------------------------- + +INTERFACE Repeat + MODULE PURE FUNCTION IntVec_Repeat_1(obj, rtimes) RESULT(Ans) + TYPE(IntVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(I4B) :: Ans(SIZE(obj%Val) * rtimes) + END FUNCTION IntVec_Repeat_1 +END INTERFACE Repeat + +END MODULE IntVector_SetMethod diff --git a/src/modules/IterationData/CMakeLists.txt b/src/modules/IterationData/CMakeLists.txt new file mode 100644 index 000000000..e58ecfa3b --- /dev/null +++ b/src/modules/IterationData/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/IterationData_Method.F90 +) \ No newline at end of file diff --git a/src/modules/IterationData/src/IterationData_Method.F90 b/src/modules/IterationData/src/IterationData_Method.F90 new file mode 100644 index 000000000..34eda0561 --- /dev/null +++ b/src/modules/IterationData/src/IterationData_Method.F90 @@ -0,0 +1,108 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IterationData_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE SUBROUTINE iterdata_Initiate( obj, maxIter, iterationNumber, & + & residualError0, residualError, residualTolerance, solutionError0, & + & solutionError, solutionTolerance, convergenceType, & + & convergenceIn, normType, converged, timeAtStart, timeAtEnd ) + TYPE( IterationData_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: maxIter + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: iterationNumber + REAL( DFP ), OPTIONAL, INTENT( IN ) :: residualError0 + REAL( DFP ), OPTIONAL, INTENT( IN ) :: residualError + REAL( DFP ), OPTIONAL, INTENT( IN ) :: residualTolerance + REAL( DFP ), OPTIONAL, INTENT( IN ) :: solutionError0 + REAL( DFP ), OPTIONAL, INTENT( IN ) :: solutionError + REAL( DFP ), OPTIONAL, INTENT( IN ) :: solutionTolerance + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: convergenceType + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: convergenceIn + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: normType + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: converged + REAL( DFP ), OPTIONAL, INTENT( IN ) :: timeAtStart + REAL( DFP ), OPTIONAL, INTENT( IN ) :: timeAtEnd +END SUBROUTINE iterdata_Initiate +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE iterdata_Initiate +END INTERFACE Initiate + +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +INTERFACE +MODULE SUBROUTINE iterdata_Deallocate( obj ) + TYPE( IterationData_ ), INTENT( INOUT ) :: obj +END SUBROUTINE iterdata_Deallocate +END INTERFACE + +INTERFACE Deallocate + MODULE PROCEDURE iterdata_Deallocate +END INTERFACE Deallocate + +PUBLIC :: Deallocate + +!---------------------------------------------------------------------------- +! isConverged@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION iterdata_isConverged( obj ) RESULT( Ans ) + TYPE( IterationData_ ), INTENT( IN ) :: obj + LOGICAL( LGT ) :: Ans +END FUNCTION iterdata_isConverged +END INTERFACE + +INTERFACE isConverged + MODULE PROCEDURE iterdata_isConverged +END INTERFACE isConverged + +PUBLIC :: isConverged + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +INTERFACE +MODULE SUBROUTINE iterdata_Display( obj, msg, UnitNo ) + TYPE( IterationData_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: msg + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: UnitNo +END SUBROUTINE iterdata_Display +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE iterdata_Display +END INTERFACE Display + +PUBLIC :: Display + +END MODULE IterationData_Method \ No newline at end of file diff --git a/src/modules/Kdtree2/CMakeLists.txt b/src/modules/Kdtree2/CMakeLists.txt new file mode 100644 index 000000000..5aaa38efe --- /dev/null +++ b/src/modules/Kdtree2/CMakeLists.txt @@ -0,0 +1,23 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/Kdtree2_Module.F90 + PRIVATE ${src_path}/Kd2PQueue_Module.F90) diff --git a/src/modules/Kdtree2/src/Kd2PQueue_Module.F90 b/src/modules/Kdtree2/src/Kd2PQueue_Module.F90 new file mode 100644 index 000000000..ac8d1299b --- /dev/null +++ b/src/modules/Kdtree2/src/Kd2PQueue_Module.F90 @@ -0,0 +1,448 @@ +! +!(c) Matthew Kennel, Institute for Nonlinear Science (2004) +! +! Licensed under the Academic Free License version 1.1 found in file LICENSE +! with additional provisions found in that same file. +! + +! There are two modules in this file +! +! kdtree2_priority_queue_module +! kdtree2_module + +MODULE Kd2PQueue_Module +USE GlobalData, ONLY: kdkind => DFP, I4B, LGT +IMPLICIT NONE +PRIVATE + +PUBLIC :: Kdtree2Result_ +PUBLIC :: pq +PUBLIC :: pq_create +PUBLIC :: pq_delete, pq_insert +PUBLIC :: pq_extract_max, pq_max, pq_replace_max, pq_maxpri + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! maintain a priority queue (PQ) of data, pairs of 'priority/payload', +! implemented with a binary heap. This is the type, and the 'dis' field +! is the priority. +! +! a pair of distances, indexes + +TYPE Kdtree2Result_ + REAL(kdkind) :: dis !=0.0 + INTEGER :: idx !=-1 Initializers cause some bugs in compilers. +END TYPE Kdtree2Result_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! A heap-based priority queue lets one efficiently implement the following +! operations, each in log(N) time, as opposed to linear time. +! +! 1) add a datum (push a datum onto the queue, increasing its length) +! 2) return the priority value of the maximum priority element +! 3) pop-off (and delete) the element with the maximum priority, decreasing +! the size of the queue. +! 4) replace the datum with the maximum priority with a supplied datum +! (of either higher or lower priority), maintaining the size of the +! queue. +! +! +! In the k-d tree case, the 'priority' is the square distance of a point in +! the data set to a reference point. The goal is to keep the smallest M +! distances to a reference point. The tree algorithm searches terminal +! nodes to decide whether to add points under consideration. +! +! A priority queue is useful here because it lets one quickly return the +! largest distance currently existing in the list. If a new candidate +! distance is smaller than this, then the new candidate ought to replace +! the old candidate. In priority queue terms, this means removing the +! highest priority element, and inserting the new one. +! +! Algorithms based on Cormen, Leiserson, Rivest, _Introduction +! to Algorithms_, 1990, with further optimization by the author. +! +! Originally informed by a C implementation by Sriranga Veeraraghavan. +! +! This module is not written in the most clear way, but is implemented such +! for speed, as it its operations will be called many times during searches +! of large numbers of neighbors. +! +TYPE pq + ! + ! The priority queue consists of elements + ! priority(1:heap_size), with associated payload(:). + ! + ! There are heap_size active elements. + ! Assumes the allocation is always sufficient. Will NOT increase it + ! to match. + INTEGER :: heap_size = 0 + TYPE(Kdtree2Result_), POINTER :: elems(:) +END TYPE pq + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +FUNCTION pq_create(results_in) RESULT(res) + ! + ! Create a priority queue from ALREADY allocated + ! array pointers for storage. NOTE! It will NOT + ! add any alements to the heap, i.e. any existing + ! data in the input arrays will NOT be used and may + ! be overwritten. + ! + ! usage: + ! real(kdkind), pointer :: x(:) + ! integer, pointer :: k(:) + ! allocate(x(1000),k(1000)) + ! pq => pq_create(x,k) + ! + TYPE(Kdtree2Result_), TARGET :: results_in(:) + TYPE(pq) :: res + ! + ! + INTEGER :: nalloc + + nalloc = SIZE(results_in, 1) + IF (nalloc .LT. 1) THEN + WRITE (*, *) 'PQ_CREATE: error, input arrays must be allocated.' + END IF + res%elems => results_in + res%heap_size = 0 + RETURN +END FUNCTION pq_create + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! +! operations for getting parents and left + right children +! of elements in a binary heap. +! + +! +! These are written inline for speed. +! +! integer function parent(i) +! integer, intent(in) :: i +! parent = (i/2) +! return +! end function parent + +! integer function left(i) +! integer, intent(in) ::i +! left = (2*i) +! return +! end function left + +! integer function right(i) +! integer, intent(in) :: i +! right = (2*i)+1 +! return +! end function right + +! logical function compare_priority(p1,p2) +! real(kdkind), intent(in) :: p1, p2 +! +! compare_priority = (p1 .gt. p2) +! return +! end function compare_priority + +SUBROUTINE heapify(a, i_in) + ! + ! take a heap rooted at 'i' and force it to be in the + ! heap canonical form. This is performance critical + ! and has been tweaked a little to reflect this. + ! + TYPE(pq), POINTER :: a + INTEGER, INTENT(in) :: i_in + ! + INTEGER :: i, l, r, largest + + REAL(kdkind) :: pri_i, pri_l, pri_r, pri_largest + + TYPE(Kdtree2Result_) :: temp + + i = i_in + + bigloop: DO + l = 2 * i ! left(i) + r = l + 1 ! right(i) + ! + ! set 'largest' to the index of either i, l, r + ! depending on whose priority is largest. + ! + ! note that l or r can be larger than the heap size + ! in which case they do not count. + + ! does left child have higher priority? + IF (l .GT. a%heap_size) THEN + ! we know that i is the largest as both l and r are invalid. + EXIT + ELSE + pri_i = a%elems(i)%dis + pri_l = a%elems(l)%dis + IF (pri_l .GT. pri_i) THEN + largest = l + pri_largest = pri_l + ELSE + largest = i + pri_largest = pri_i + END IF + + ! + ! between i and l we have a winner + ! now choose between that and r. + ! + IF (r .LE. a%heap_size) THEN + pri_r = a%elems(r)%dis + IF (pri_r .GT. pri_largest) THEN + largest = r + END IF + END IF + END IF + + IF (largest .NE. i) THEN + ! swap data in nodes largest and i, then heapify + + temp = a%elems(i) + a%elems(i) = a%elems(largest) + a%elems(largest) = temp + ! + ! Canonical heapify() algorithm has tail-ecursive call: + ! + ! call heapify(a,largest) + ! we will simulate with cycle + ! + i = largest + CYCLE bigloop ! continue the loop + ELSE + RETURN ! break from the loop + END IF + END DO bigloop + RETURN +END SUBROUTINE heapify + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE pq_max(a, e) + ! + ! return the priority and its payload of the maximum priority element + ! on the queue, which should be the first one, if it is + ! in heapified form. + ! + TYPE(pq), POINTER :: a + TYPE(Kdtree2Result_), INTENT(out) :: e + + IF (a%heap_size .GT. 0) THEN + e = a%elems(1) + ELSE + WRITE (*, *) 'PQ_MAX: ERROR, heap_size < 1' + STOP + END IF + RETURN +END SUBROUTINE pq_max + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(kdkind) FUNCTION pq_maxpri(a) + TYPE(pq), POINTER :: a + + IF (a%heap_size .GT. 0) THEN + pq_maxpri = a%elems(1)%dis + ELSE + WRITE (*, *) 'PQ_MAX_PRI: ERROR, heapsize < 1' + STOP + END IF + RETURN +END FUNCTION pq_maxpri + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE pq_extract_max(a, e) + ! + ! return the priority and payload of maximum priority + ! element, and remove it from the queue. + ! (equivalent to 'pop()' on a stack) + ! + TYPE(pq), POINTER :: a + TYPE(Kdtree2Result_), INTENT(out) :: e + + IF (a%heap_size .GE. 1) THEN + ! + ! return max as first element + ! + e = a%elems(1) + + ! + ! move last element to first + ! + a%elems(1) = a%elems(a%heap_size) + a%heap_size = a%heap_size - 1 + CALL heapify(a, 1) + RETURN + ELSE + WRITE (*, *) 'PQ_EXTRACT_MAX: error, attempted to pop non-positive PQ' + STOP + END IF + +END SUBROUTINE pq_extract_max + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(kdkind) FUNCTION pq_insert(a, dis, idx) + ! + ! Insert a new element and return the new maximum priority, + ! which may or may not be the same as the old maximum priority. + ! + TYPE(pq), POINTER :: a + REAL(kdkind), INTENT(in) :: dis + INTEGER, INTENT(in) :: idx + ! Type(Kdtree2Result_), intent(in) :: e + ! + INTEGER :: i, isparent + REAL(kdkind) :: parentdis + + a%heap_size = a%heap_size + 1 + i = a%heap_size + + DO WHILE (i .GT. 1) + isparent = INT(i / 2) + parentdis = a%elems(isparent)%dis + IF (dis .GT. parentdis) THEN + ! move what was in i's parent into i. + a%elems(i)%dis = parentdis + a%elems(i)%idx = a%elems(isparent)%idx + i = isparent + ELSE + EXIT + END IF + END DO + + ! insert the element at the determined position + a%elems(i)%dis = dis + a%elems(i)%idx = idx + + pq_insert = a%elems(1)%dis + RETURN + ! end if + +END FUNCTION pq_insert + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(kdkind) FUNCTION pq_replace_max(a, dis, idx) + ! + ! Replace the extant maximum priority element + ! in the PQ with (dis,idx). Return + ! the new maximum priority, which may be larger + ! or smaller than the old one. + ! + TYPE(pq), POINTER :: a + REAL(kdkind), INTENT(in) :: dis + INTEGER, INTENT(in) :: idx +! Type(Kdtree2Result_), intent(in) :: e + ! not tested as well! + + INTEGER :: parent, child, N + REAL(kdkind) :: prichild, prichildp1 + + TYPE(Kdtree2Result_) :: etmp + + IF (.TRUE.) THEN + N = a%heap_size + IF (N .GE. 1) THEN + parent = 1 + child = 2 + + loop: DO WHILE (child .LE. N) + prichild = a%elems(child)%dis + + ! + ! posibly child+1 has higher priority, and if + ! so, get it, and increment child. + ! + + IF (child .LT. N) THEN + prichildp1 = a%elems(child + 1)%dis + IF (prichild .LT. prichildp1) THEN + child = child + 1 + prichild = prichildp1 + END IF + END IF + + IF (dis .GE. prichild) THEN + EXIT loop + ! we have a proper place for our new element, + ! bigger than either children's priority. + ELSE + ! move child into parent. + a%elems(parent) = a%elems(child) + parent = child + child = 2 * parent + END IF + END DO loop + a%elems(parent)%dis = dis + a%elems(parent)%idx = idx + pq_replace_max = a%elems(1)%dis + ELSE + a%elems(1)%dis = dis + a%elems(1)%idx = idx + pq_replace_max = dis + END IF + ELSE + ! + ! slower version using elementary pop and push operations. + ! + CALL pq_extract_max(a, etmp) + etmp%dis = dis + etmp%idx = idx + pq_replace_max = pq_insert(a, dis, idx) + END IF + RETURN +END FUNCTION pq_replace_max + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE pq_delete(a, i) + ! + ! delete item with index 'i' + ! + TYPE(pq), POINTER :: a + INTEGER :: i + + IF ((i .LT. 1) .OR. (i .GT. a%heap_size)) THEN + WRITE (*, *) 'PQ_DELETE: error, attempt to remove out of bounds element.' + STOP + END IF + + ! swap the item to be deleted with the last element + ! and shorten heap by one. + a%elems(i) = a%elems(a%heap_size) + a%heap_size = a%heap_size - 1 + + CALL heapify(a, i) + +END SUBROUTINE pq_delete + +END MODULE Kd2PQueue_Module diff --git a/src/modules/Kdtree2/src/Kdtree2_Module.F90 b/src/modules/Kdtree2/src/Kdtree2_Module.F90 new file mode 100644 index 000000000..b2bff37cf --- /dev/null +++ b/src/modules/Kdtree2/src/Kdtree2_Module.F90 @@ -0,0 +1,1329 @@ +!(c) Matthew Kennel, INstitute for Nonlinear Science (2004) +! +! Licensed under the Academic Free License version 1.1 found in file LICENSE +! with additional provisions found in that same file. +! + +! There are two modules in this file +! +! Kdtree2_priority_queue_module +! Kdtree2_module + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! K-D tree routines in Fortran 90 by Matt Kennel. +! Original program was written in Sather by Steve Omohundro and +! Matt Kennel. Only the Euclidean metric is supported. +! +! +! This module is identical to 'kd_tree', except that the order +! of subscripts is reversed in the data file. +! IN otherwords for an embedding of N D-dimensional vectors, the +! data file is here, in natural Fortran order data(1:D, 1:N) +! because Fortran lays out columns first, +! +! whereas conventionally (C-style) it is data(1:N,1:D) +! as in the original kd_tree module. + +MODULE Kdtree2_Module +USE GlobalData, ONLY: kdkind => DFP, I4B, LGT, stdout, stderr, CHAR_LF +USE ErrorHandling, ONLY: Errormsg +USE Display_Method, ONLY: Display +USE Kd2PQueue_Module +USE INputUtility +IMPLICIT NONE +PRIVATE + +PUBLIC :: Kdtree2_, Kdtree2Result_, Kdtree2Node_ +PUBLIC :: Kdtree2_create, Kdtree2_Destroy +PUBLIC :: Kdtree2_n_nearest, Kdtree2_n_nearest_around_point +PUBLIC :: Kdtree2_r_nearest, Kdtree2_r_nearest_around_point +PUBLIC :: Kdtree2_r_count, Kdtree2_r_count_around_point +PUBLIC :: Kdtree2_sort_results +PUBLIC :: Kdtree2_n_nearest_brute_force, Kdtree2_r_nearest_brute_force + +INTEGER, PARAMETER :: bucket_size = 12 +! The maximum number of points to keep in a terminal node. + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE interval + REAL(kdkind) :: lower, upper +END TYPE interval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! an internal tree node +TYPE :: Kdtree2Node_ + PRIVATE + INTEGER :: cut_dim + ! the dimension to cut + REAL(kdkind) :: cut_val + ! where to cut the dimension + REAL(kdkind) :: cut_val_left, cut_val_right + ! improved cutoffs knowing the spread in child boxes. + INTEGER :: l, u + TYPE(Kdtree2Node_), POINTER :: left, right + TYPE(interval), ALLOCATABLE :: box(:) + ! child pointers + ! Points included in this node are indexes[k] with k \in [l,u] +END TYPE Kdtree2Node_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: Kdtree2_ + ! Global information about the tree, one per tree + INTEGER :: dimen = 0, n = 0 + ! dimensionality and total # of points + LOGICAL :: sort = .FALSE. + ! do we always sort output results? + LOGICAL :: rearrange = .FALSE. + REAL(kdkind), POINTER :: the_data(:, :) => NULL() + ! pointer to the actual data array + ! + ! IMPORTANT NOTE: IT IS DIMENSIONED the_data(1:d,1:N) + ! which may be opposite of what may be conventional. + ! This is, because in Fortran, the memory layout is such that + ! the first dimension is in sequential order. Hence, with + ! (1:d,1:N), all components of the vector will be in consecutive + ! memory locations. The search time is dominated by the + ! evaluation of distances in the terminal nodes. Putting all + ! vector components in consecutive memory location improves + ! memory cache locality, and hence search speed, and may enable + ! vectorization on some processors and compilers. + + INTEGER, ALLOCATABLE :: ind(:) + ! permuted index into the data, so that indexes[l..u] of some + ! bucket represent the indexes of the actual points in that + ! bucket. + REAL(kdkind), ALLOCATABLE :: rearranged_data(:, :) + ! if (rearrange .eqv. .true.) then rearranged_data has been + ! created so that rearranged_data(:,i) = the_data(:,ind(i)), + ! permitting search to use more cache-friendly rearranged_data, at + ! some initial computation and storage cost. + TYPE(Kdtree2Node_), POINTER :: root => NULL() + ! root pointer of the tree +END TYPE Kdtree2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! One of these is created for each search. +! +! Many fields are copied from the tree structure, in order to +! speed up the search. +! +TYPE :: tree_search_record + PRIVATE + INTEGER :: dimen + INTEGER :: nn, nfound + REAL(kdkind) :: ballsize + INTEGER :: centeridx = 999, correltime = 9999 + ! exclude points within 'correltime' of 'centeridx', iff centeridx >= 0 + INTEGER :: nalloc ! how much allocated for results(:)? + LOGICAL :: rearrange ! are the data rearranged or original? + ! did the # of points found overflow the storage provided? + LOGICAL :: overflow + REAL(kdkind), POINTER :: qv(:) ! query vector + TYPE(Kdtree2Result_), POINTER :: results(:) ! results + TYPE(pq) :: pq + REAL(kdkind), POINTER :: DATA(:, :) ! temp pointer to data + INTEGER, POINTER :: ind(:) ! temp pointer to indexes +END TYPE tree_search_record + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE(tree_search_record), SAVE, TARGET :: sr ! A GLOBAL VARIABLE for search + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +! create the actual tree structure, given an input array of data. +! +! Note, input data is input_data(1:d,1:N), NOT the other way around. +! THIS IS THE REVERSE OF THE PREVIOUS VERSION OF THIS MODULE. +! The reason for it is cache friendliness, improving performance. +! +! Optional arguments: If 'dim' is specified, then the tree +! will only search the first 'dim' components +! of input_data, otherwise, dim is inferred +! from SIZE(input_data,1). +! +! if sort .eqv. .true. then output results +! will be sorted by increasing distance. +! default=.false., as it is faster to not sort. +! +! if rearrange .eqv. .true. then an internal +! copy of the data, rearranged by terminal node, +! will be made for cache friendliness. +! default=.true., as it speeds searches, but +! building takes longer, and extra memory is used. + +FUNCTION Kdtree2_create(input_data, dim, sort, rearrange) RESULT(mr) + TYPE(Kdtree2_), POINTER :: mr + INTEGER, INTENT(IN), OPTIONAL :: dim + LOGICAL, INTENT(IN), OPTIONAL :: sort + LOGICAL, INTENT(IN), OPTIONAL :: rearrange + REAL(kdkind), TARGET :: input_data(:, :) + + ! internal variables + INTEGER :: i + + ALLOCATE (mr) + mr%the_data => input_data + ! pointer assignment + + mr%dimen = INput(default=SIZE(input_data, 1), option=dim) + mr%n = SIZE(input_data, 2) + +#ifdef DEBUG_VER + + IF (mr%dimen > mr%n) THEN + ! unlikely to be correct + WRITE (*, *) 'KD_TREE_TRANS: likely user error.' + WRITE (*, *) 'KD_TREE_TRANS: You passed in matrix with D=', mr%dimen + WRITE (*, *) 'KD_TREE_TRANS: and N=', mr%n + WRITE (*, *) 'KD_TREE_TRANS: note, that new format is data(1:D,1:N)' + write (*,*) 'KD_TREE_TRANS: with usually N >> D. If N =approx= D, then a k-d tree' + WRITE (*, *) 'KD_TREE_TRANS: is not an appropriate data structure.' + STOP + END IF + +#endif + + CALL build_tree(mr) + + mr%sort = INput(default=.FALSE., option=sort) + mr%rearrange = INput(default=.TRUE., option=rearrange) + + IF (.NOT. mr%rearrange) THEN + IF (ALLOCATED(mr%rearranged_data)) DEALLOCATE (mr%rearranged_data) + RETURN + END IF + + ALLOCATE (mr%rearranged_data(mr%dimen, mr%n)) + DO i = 1, mr%n + mr%rearranged_data(:, i) = mr%the_data(:, mr%ind(i)) + END DO + +END FUNCTION Kdtree2_create + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE build_tree(tp) + TYPE(Kdtree2_), INTENT(INOUT) :: tp + INTEGER :: j + TYPE(Kdtree2Node_), POINTER :: dummy => NULL() + ALLOCATE (tp%ind(tp%n)) + DO CONCURRENT(j=1:tp%n) + tp%ind(j) = j + END DO + tp%root => build_tree_for_range(tp, 1, tp%n, dummy) +END SUBROUTINE build_tree + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +RECURSIVE FUNCTION build_tree_for_range(tp, l, u, parent) RESULT(res) + TYPE(Kdtree2Node_), POINTER :: res + TYPE(Kdtree2_), INTENT(INOUT) :: tp + TYPE(Kdtree2Node_), POINTER :: parent + INTEGER, INTENT(IN) :: l, u + + ! internal variables + INTEGER :: i, c, m, dimen + LOGICAL :: recompute, isok + REAL(kdkind) :: average + + ! first compute min and max + dimen = tp%dimen + ALLOCATE (res) + ALLOCATE (res%box(dimen)) + + ! First, compute an APPROXIMATE bounding box of all points + ! associated with this node. + IF (u < l) THEN + ! no points in this box + NULLIFY (res) + RETURN + END IF + + isok = (u - l) <= bucket_size + IF (isok) THEN + ! always compute true bounding box for terminal nodes. + DO i = 1, dimen + CALL spread_in_coordinate(tp, i, l, u, res%box(i)) + END DO + res%cut_dim = 0 + res%cut_val = 0.0 + res%l = l + res%u = u + res%left => NULL() + res%right => NULL() + RETURN + END IF + + ! modify approximate bounding box. This will be an + ! overestimate of the true bounding box, as we are only recomputing + ! the bounding box for the dimension that the parent split on. + ! + ! Going to a true bounding box computation would significantly + ! increase the time necessary to build the tree, and usually + ! has only a very small difference. This box is not used + ! for searching but only for deciding which coordinate to split on. + DO i = 1, dimen + + recompute = .TRUE. + IF (ASSOCIATED(parent)) THEN + IF (i .NE. parent%cut_dim) THEN + recompute = .FALSE. + END IF + END IF + + IF (recompute) THEN + CALL spread_in_coordinate(tp, i, l, u, res%box(i)) + ELSE + res%box(i) = parent%box(i) + END IF + + END DO + + c = MAXLOC(res%box(1:dimen)%upper - res%box(1:dimen)%lower, 1) + ! c is the identity of which coordinate has the greatest spread. + + ! select point halfway between min and max, as per A. Moore, + ! who says this helps in some degenerate cases, or + ! actual arithmetic average. + ! actually compute average + average = SUM(tp%the_data(c, tp%ind(l:u))) / REAL(u - l + 1, kdkind) + + res%cut_val = average + m = select_on_coordinate_value(tp%the_data, tp%ind, c, average, l, u) + + ! moves indexes around + res%cut_dim = c + res%l = l + res%u = u + ! res%cut_val = tp%the_data(c,tp%ind(m)) + + res%left => build_tree_for_range(tp, l, m, res) + res%right => build_tree_for_range(tp, m + 1, u, res) + + IF (ASSOCIATED(res%right) .EQV. .FALSE.) THEN + res%box = res%left%box + res%cut_val_left = res%left%box(c)%upper + res%cut_val = res%cut_val_left + ELSEIF (ASSOCIATED(res%left) .EQV. .FALSE.) THEN + res%box = res%right%box + res%cut_val_right = res%right%box(c)%lower + res%cut_val = res%cut_val_right + ELSE + res%cut_val_right = res%right%box(c)%lower + res%cut_val_left = res%left%box(c)%upper + res%cut_val = (res%cut_val_left + res%cut_val_right) / 2 + + ! now remake the true bounding box for self. + ! Since we are taking unions (in effect) of a tree structure, + ! this is much faster than doing an exhaustive + ! search over all points + res%box%upper = MAX(res%left%box%upper, res%right%box%upper) + res%box%lower = MIN(res%left%box%lower, res%right%box%lower) + END IF +END FUNCTION build_tree_for_range + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Move elts of ind around between l and u, so that all points +! <= than alpha (in c cooordinate) are first, and then +! all points > alpha are second. +! +! Algorithm (matt kennel). +! +! Consider the list as having three parts: on the left, +! the points known to be <= alpha. On the right, the points +! known to be > alpha, and in the middle, the currently unknown +! points. The algorithm is to scan the unknown points, starting +! from the left, and swapping them so that they are added to +! the left stack or the right stack, as appropriate. +! +! The algorithm finishes when the unknown stack is empty. +INTEGER FUNCTION select_on_coordinate_value(v, ind, c, alpha, li, ui) & + RESULT(res) + INTEGER, INTENT(IN) :: c, li, ui + REAL(kdkind), INTENT(IN) :: alpha + REAL(kdkind) :: v(1:, 1:) + INTEGER :: ind(1:) + INTEGER :: tmp + INTEGER :: lb, rb + + ! The points known to be <= alpha are in + ! [l,lb-1] + ! + ! The points known to be > alpha are in + ! [rb+1,u]. + ! + ! Therefore we add new points into lb or + ! rb as appropriate. When lb=rb + ! we are done. We return the location of the last point <= alpha. + lb = li; rb = ui + + DO WHILE (lb < rb) + IF (v(c, ind(lb)) <= alpha) THEN + ! it is good where it is. + lb = lb + 1 + ELSE + ! swap it with rb. + tmp = ind(lb); ind(lb) = ind(rb); ind(rb) = tmp + rb = rb - 1 + END IF + END DO + + ! now lb .eq. ub + IF (v(c, ind(lb)) <= alpha) THEN + res = lb + ELSE + res = lb - 1 + END IF + +END FUNCTION select_on_coordinate_value + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE spread_in_coordinate(tp, c, l, u, interv) + TYPE(Kdtree2_), INTENT(INOUT) :: tp + TYPE(interval), INTENT(out) :: interv + INTEGER, INTENT(IN) :: c, l, u + ! internal variables + REAL(kdkind) :: last, lmax, lmin, t, smin, smax + INTEGER :: i, ulocal + ! REAL(kdkind), POINTER :: v(:, :) + ! INTEGER, POINTER :: ind(:) + + ASSOCIATE (v => tp%the_data(1:, 1:), ind => tp%ind(1:)) + smin = v(c, ind(l)) + smax = smin + ulocal = u + + DO i = l + 2, ulocal, 2 + lmin = v(c, ind(i - 1)) + lmax = v(c, ind(i)) + IF (lmin > lmax) THEN + t = lmin + lmin = lmax + lmax = t + END IF + IF (smin > lmin) smin = lmin + IF (smax < lmax) smax = lmax + END DO + + IF (i == ulocal + 1) THEN + last = v(c, ind(ulocal)) + IF (smin > last) smin = last + IF (smax < last) smax = last + END IF + + interv%lower = smin + interv%upper = smax + END ASSOCIATE + +END SUBROUTINE spread_in_coordinate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Deallocates all memory for the tree, except input data matrix +SUBROUTINE Kdtree2_Destroy(tp) + TYPE(Kdtree2_), INTENT(INOUT) :: tp + + CALL destroy_node(tp%root) + + tp%dimen = 0 + tp%sort = .FALSE. + tp%rearrange = .FALSE. + tp%the_data => NULL() + IF (ALLOCATED(tp%ind)) DEALLOCATE (tp%ind) + IF (ALLOCATED(tp%rearranged_data)) DEALLOCATE (tp%rearranged_data) + +CONTAINS + RECURSIVE SUBROUTINE destroy_node(np) + TYPE(Kdtree2Node_), POINTER :: np + + IF (ASSOCIATED(np%left)) THEN + CALL destroy_node(np%left) + NULLIFY (np%left) + END IF + + IF (ASSOCIATED(np%right)) THEN + CALL destroy_node(np%right) + NULLIFY (np%right) + END IF + + IF (ALLOCATED(np%box)) DEALLOCATE (np%box) + DEALLOCATE (np) + + END SUBROUTINE destroy_node + +END SUBROUTINE Kdtree2_Destroy + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Find the 'nn' vectors in the tree nearest to 'qv' in euclidean norm +! returning their indexes and distances in 'indexes' and 'distances' +! arrays already allocated passed to this subroutine. +SUBROUTINE Kdtree2_n_nearest(tp, qv, nn, results) + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + REAL(kdkind), TARGET, INTENT(IN) :: qv(:) + INTEGER, INTENT(IN) :: nn + TYPE(Kdtree2Result_), TARGET :: results(:) + + sr%ballsize = HUGE(1.0) + sr%qv => qv + sr%nn = nn + sr%nfound = 0 + sr%centeridx = -1 + sr%correltime = 0 + sr%overflow = .FALSE. + + sr%results => results + + sr%nalloc = nn ! will be checked + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + IF (tp%rearrange) THEN + sr%DATA => tp%rearranged_data + ELSE + sr%DATA => tp%the_data + END IF + sr%dimen = tp%dimen + + CALL validate_query_storage(nn) + sr%pq = pq_create(results) + + CALL search(tp%root) + + IF (tp%sort) THEN + CALL Kdtree2_sort_results(nn, results) + END IF +! deallocate(sr%pqp) + RETURN +END SUBROUTINE Kdtree2_n_nearest + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Matthew Kennel +! date: 2024-04-10 +! summary: Find nn vectors in the tree. +! +! Find the 'nn' vectors in the tree nearest to point 'idxin', +! with correlation window 'correltime', returing results in +! results(:), which must be pre-allocated upon entry. + +SUBROUTINE Kdtree2_n_nearest_around_point(tp, idxin, correltime, nn, results) + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + INTEGER, INTENT(IN) :: idxin + INTEGER, INTENT(IN) :: correltime + !! correlation window + INTEGER, INTENT(IN) :: nn + TYPE(Kdtree2Result_), TARGET :: results(:) + + ALLOCATE (sr%qv(tp%dimen)) + sr%qv = tp%the_data(:, idxin) + ! copy the vector + sr%ballsize = HUGE(1.0) + ! the largest real(kdkind) number + sr%centeridx = idxin + sr%correltime = correltime + + sr%nn = nn + sr%nfound = 0 + + sr%dimen = tp%dimen + sr%nalloc = nn + + sr%results => results + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + + IF (sr%rearrange) THEN + sr%DATA => tp%rearranged_data + ELSE + sr%DATA => tp%the_data + END IF + + CALL validate_query_storage(nn) + sr%pq = pq_create(results) + + CALL search(tp%root) + + IF (tp%sort) THEN + CALL Kdtree2_sort_results(nn, results) + END IF + DEALLOCATE (sr%qv) + RETURN +END SUBROUTINE Kdtree2_n_nearest_around_point + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! find the nearest neighbors to point 'idxin', within SQUARED +! Euclidean distance 'r2'. Upon ENTRY, nalloc must be the +! size of memory allocated for results(1:nalloc). Upon +! EXIT, nfound is the number actually found within the ball. +! +! Note that if nfound .gt. nalloc then more neighbors were found +! than there were storage to store. The resulting list is NOT +! the smallest ball inside norm r^2 +! +! Results are NOT sorted unless tree was created with sort option. + +SUBROUTINE Kdtree2_r_nearest(tp, qv, r2, nfound, nalloc, results) + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + REAL(kdkind), TARGET, INTENT(IN) :: qv(:) + REAL(kdkind), INTENT(IN) :: r2 + INTEGER, INTENT(out) :: nfound + INTEGER, INTENT(IN) :: nalloc + TYPE(Kdtree2Result_), TARGET :: results(:) + +#ifdef DEBUG_VER + CHARACTER(*), PARAMETER :: msg = & + '[Warning] :: return from Kdtree2_r_nearest found more neighbors' & + //CHAR_LF// & + 'than storage was provided for. Answer is NOT smallest ball' & + //CHAR_LF// & + 'KD_TREE_TRANS: with that number of neighbors! I.e. it is wrong.' +#endif + + ! + sr%qv => qv + sr%ballsize = r2 + sr%nn = 0 ! flag for fixed ball search + sr%nfound = 0 + sr%centeridx = -1 + sr%correltime = 0 + + sr%results => results + + CALL validate_query_storage(nalloc) + sr%nalloc = nalloc + sr%overflow = .FALSE. + sr%ind => tp%ind + sr%rearrange = tp%rearrange + + IF (tp%rearrange) THEN + sr%DATA => tp%rearranged_data + ELSE + sr%DATA => tp%the_data + END IF + sr%dimen = tp%dimen + + CALL search(tp%root) + nfound = sr%nfound + IF (tp%sort) THEN + CALL Kdtree2_sort_results(nfound, results) + END IF + +#ifdef DEBUG_VER + + IF (sr%overflow) THEN + CALL Errormsg( & + msg=msg, & + file=__FILE__, & + line=__LINE__, & + routine="Kdtree2_n_nearest()") + END IF + +#endif + +END SUBROUTINE Kdtree2_r_nearest + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Like Kdtree2_r_nearest, but around a point 'idxin' already existing +! in the data set. +! +! Results are NOT sorted unless tree was created with sort option. +SUBROUTINE Kdtree2_r_nearest_around_point(tp, idxin, correltime, r2, & + nfound, nalloc, results) + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + INTEGER, INTENT(IN) :: idxin, correltime, nalloc + REAL(kdkind), INTENT(IN) :: r2 + INTEGER, INTENT(out) :: nfound + TYPE(Kdtree2Result_), TARGET :: results(:) + +#ifdef DEBUG_VER + CHARACTER(*), PARAMETER :: msg = & + 'warning! return from Kdtree2_r_nearest found more neighbors' & + //CHAR_LF// & + 'than storage was provided for. Answer is NOT smallest ball' & + //CHAR_LF// & + 'with that number of neighbors! I.e. it is wrong.' +#endif + + ALLOCATE (sr%qv(tp%dimen)) + sr%qv = tp%the_data(:, idxin) ! copy the vector + sr%ballsize = r2 + sr%nn = 0 ! flag for fixed r search + sr%nfound = 0 + sr%centeridx = idxin + sr%correltime = correltime + + sr%results => results + + sr%nalloc = nalloc + sr%overflow = .FALSE. + + CALL validate_query_storage(nalloc) + + ! sr%dsl = HUGE(sr%dsl) ! set to huge positive values + ! sr%il = -1 ! set to invalid indexes + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + + IF (tp%rearrange) THEN + sr%DATA => tp%rearranged_data + ELSE + sr%DATA => tp%the_data + END IF + sr%rearrange = tp%rearrange + sr%dimen = tp%dimen + + ! + !sr%dsl = Huge(sr%dsl) ! set to huge positive values + !sr%il = -1 ! set to invalid indexes + ! + + CALL search(tp%root) + nfound = sr%nfound + IF (tp%sort) THEN + CALL Kdtree2_sort_results(nfound, results) + END IF + +#ifdef DEBUG_VER + + IF (sr%overflow) THEN + CALL Errormsg(msg=msg, file=__FILE__, line=__LINE__, & + routine="Kdtree2_r_nearest_around_point()", unitno=stderr) + END IF + +#endif + + DEALLOCATE (sr%qv) +END SUBROUTINE Kdtree2_r_nearest_around_point + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Count the number of neighbors within square distance 'r2'. +FUNCTION Kdtree2_r_count(tp, qv, r2) RESULT(nfound) + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + REAL(kdkind), TARGET, INTENT(IN) :: qv(:) + REAL(kdkind), INTENT(IN) :: r2 + INTEGER :: nfound + + INTRINSIC HUGE + + sr%qv => qv + sr%ballsize = r2 + + sr%nn = 0 ! flag for fixed r search + sr%nfound = 0 + sr%centeridx = -1 + sr%correltime = 0 + + NULLIFY (sr%results) ! for some reason, FTN 95 chokes on '=> null()' + + sr%nalloc = 0 ! we do not allocate any storage but that's OK + ! for counting. + sr%ind => tp%ind + sr%rearrange = tp%rearrange + IF (tp%rearrange) THEN + sr%DATA => tp%rearranged_data + ELSE + sr%DATA => tp%the_data + END IF + sr%dimen = tp%dimen + + sr%overflow = .FALSE. + + CALL search(tp%root) + + nfound = sr%nfound + +END FUNCTION Kdtree2_r_count + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Count the number of neighbors within square distance 'r2' around +! point 'idxin' with decorrelation time 'correltime'. + +FUNCTION Kdtree2_r_count_around_point(tp, idxin, correltime, r2) & + RESULT(nfound) + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + INTEGER, INTENT(IN) :: correltime, idxin + REAL(kdkind), INTENT(IN) :: r2 + INTEGER :: nfound + + ALLOCATE (sr%qv(tp%dimen)) + sr%qv = tp%the_data(:, idxin) + sr%ballsize = r2 + + sr%nn = 0 ! flag for fixed r search + sr%nfound = 0 + sr%centeridx = idxin + sr%correltime = correltime + NULLIFY (sr%results) + + sr%nalloc = 0 ! we do not allocate any storage but that's OK + ! for counting. + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + + IF (sr%rearrange) THEN + sr%DATA => tp%rearranged_data + ELSE + sr%DATA => tp%the_data + END IF + sr%dimen = tp%dimen + + sr%overflow = .FALSE. + + CALL search(tp%root) + + nfound = sr%nfound + +END FUNCTION Kdtree2_r_count_around_point + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-10 +! summary: check storage when run in debug mode + +SUBROUTINE validate_query_storage(n) + INTEGER, INTENT(IN) :: n + +#ifdef DEBUG_VER + + CHARACTER(*), PARAMETER :: msg = "Not enough storage for results" + LOGICAL(LGT) :: problem + + problem = SIZE(sr%results, 1) .LT. n + IF (problem) THEN + CALL ErrorMsg( & + msg=msg, & + line=__LINE__, & + unitno=stderr, & + file=__FILE__, & + routine="validate_query_storage()") + STOP + END IF + +#endif + +END SUBROUTINE validate_query_storage + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! distance between iv[1:n] and qv[1:n] +! .. Function Return Value .. +! re-implemented to improve vectorization. +FUNCTION square_distance(d, iv, qv) RESULT(res) + REAL(kdkind) :: res + INTEGER :: d + REAL(kdkind) :: iv(:), qv(:) + res = SUM((iv(1:d) - qv(1:d))**2) +END FUNCTION square_distance + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! This is the innermost core routine of the kd-tree search. Along +! with "process_terminal_node", it is the performance bottleneck. +! +! This version uses a logically complete secondary search of +! "box in bounds", whether the sear +RECURSIVE SUBROUTINE search(node) + TYPE(Kdtree2Node_), POINTER :: node + + ! internal variables + TYPE(Kdtree2Node_), POINTER :: ncloser, nfarther + INTEGER :: cut_dim, i + REAL(kdkind) :: qval, dis + REAL(kdkind) :: ballsize + REAL(kdkind), POINTER :: qv(:) + TYPE(interval), POINTER :: box(:) + LOGICAL(LGT) :: isok + + isok = (ASSOCIATED(node%left) .AND. ASSOCIATED(node%right)) .EQV. .FALSE. + + IF (isok) THEN + + ! we are on a terminal node + IF (sr%nn .EQ. 0) THEN + CALL process_terminal_node_fixedball(node) + ELSE + CALL process_terminal_node(node) + END IF + RETURN + + END IF + + ! we are not on a terminal node + qv => sr%qv(1:) + cut_dim = node%cut_dim + qval = qv(cut_dim) + + IF (qval < node%cut_val) THEN + ncloser => node%left + nfarther => node%right + dis = (node%cut_val_right - qval)**2 + ! extra = node%cut_val - qval + ELSE + ncloser => node%right + nfarther => node%left + dis = (node%cut_val_left - qval)**2 + ! extra = qval- node%cut_val_left + END IF + + IF (ASSOCIATED(ncloser)) CALL search(ncloser) + + ! we may need to search the second node. + isok = ASSOCIATED(nfarther) + IF (.NOT. isok) RETURN + + ballsize = sr%ballsize + ! dis=extra**2 + + isok = dis <= ballsize + IF (.NOT. isok) RETURN + + ! we do this separately as going on the first cut dimen is often + ! a good idea. + ! note that if extra**2 < sr%ballsize, then the next + ! check will also be false. + box => node%box(1:) + DO i = 1, sr%dimen + IF (i .NE. cut_dim) THEN + dis = dis + dis2_from_bnd(qv(i), box(i)%lower, box(i)%upper) + IF (dis > ballsize) RETURN + END IF + END DO + + ! if we are still here then we need to search mroe. + CALL search(nfarther) + +END SUBROUTINE search + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(kdkind) FUNCTION dis2_from_bnd(x, amin, amax) RESULT(res) + REAL(kdkind), INTENT(IN) :: x, amin, amax + LOGICAL(LGT) :: isok + + res = 0.0 + + isok = x > amax + IF (isok) THEN + res = (x - amax)**2 + RETURN + END IF + + isok = x < amin + IF (isok) res = (amin - x)**2 +END FUNCTION dis2_from_bnd + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Look for actual near neighbors in 'node', and update +! the search results on the sr data structure. +SUBROUTINE process_terminal_node(node) + TYPE(Kdtree2Node_), POINTER :: node + ! + REAL(kdkind), POINTER :: qv(:) + INTEGER, POINTER :: ind(:) + REAL(kdkind), POINTER :: DATA(:, :) + ! + INTEGER :: dimen, i, indexofi, k, centeridx, correltime + REAL(kdkind) :: ballsize, sd, newpri + LOGICAL :: rearrange + TYPE(pq), POINTER :: pqp + ! + ! copy values from sr to local variables + ! + ! + ! Notice, making local pointers with an EXPLICIT lower bound + ! seems to generate faster code. + ! why? I don't know. + qv => sr%qv(1:) + pqp => sr%pq + dimen = sr%dimen + ballsize = sr%ballsize + rearrange = sr%rearrange + ind => sr%ind(1:) + DATA => sr%DATA(1:, 1:) + centeridx = sr%centeridx + correltime = sr%correltime + + ! doing_correl = (centeridx >= 0) ! Do we have a decorrelation window? + ! include_point = .true. ! by default include all points + ! search through terminal bucket. + + mainloop: DO i = node%l, node%u + IF (rearrange) THEN + sd = 0.0 + DO k = 1, dimen + sd = sd + (DATA(k, i) - qv(k))**2 + IF (sd > ballsize) CYCLE mainloop + END DO + indexofi = ind(i) ! only read it if we have not broken out + ELSE + indexofi = ind(i) + sd = 0.0 + DO k = 1, dimen + sd = sd + (DATA(k, indexofi) - qv(k))**2 + IF (sd > ballsize) CYCLE mainloop + END DO + END IF + + IF (centeridx > 0) THEN ! doing correlation interval? + IF (ABS(indexofi - centeridx) < correltime) CYCLE mainloop + END IF + + ! + ! two choices for any point. The list so far is either undersized, + ! or it is not. + ! + ! If it is undersized, then add the point and its distance + ! unconditionally. If the point added fills up the working + ! list then set the sr%ballsize, maximum distance bound (largest distance on + ! list) to be that distance, instead of the initialized +infinity. + ! + ! If the running list is full size, then compute the + ! distance but break out immediately if it is larger + ! than sr%ballsize, "best squared distance" (of the largest element), + ! as it cannot be a good neighbor. + ! + ! Once computed, compare to best_square distance. + ! if it is smaller, then delete the previous largest + ! element and add the new one. + + IF (sr%nfound .LT. sr%nn) THEN + ! + ! add this point unconditionally to fill list. + ! + sr%nfound = sr%nfound + 1 + newpri = pq_insert(pqp, sd, indexofi) + IF (sr%nfound .EQ. sr%nn) ballsize = newpri + ! we have just filled the working list. + ! put the best square distance to the maximum value + ! on the list, which is extractable from the PQ. + + ELSE + ! + ! now, if we get here, + ! we know that the current node has a squared + ! distance smaller than the largest one on the list, and + ! belongs on the list. + ! Hence we replace that with the current one. + ! + ballsize = pq_replace_max(pqp, sd, indexofi) + END IF + END DO mainloop + ! + ! Reset sr variables which may have changed during loop + ! + sr%ballsize = ballsize + +END SUBROUTINE process_terminal_node + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Look for actual near neighbors in 'node', and update +! the search results on the sr data structure, i.e. +! save all within a fixed ball. +SUBROUTINE process_terminal_node_fixedball(node) + TYPE(Kdtree2Node_), POINTER :: node + ! + REAL(kdkind), POINTER :: qv(:) + INTEGER, POINTER :: ind(:) + REAL(kdkind), POINTER :: DATA(:, :) + ! + INTEGER :: nfound + INTEGER :: dimen, i, indexofi, k + INTEGER :: centeridx, correltime, nn + REAL(kdkind) :: ballsize, sd + LOGICAL :: rearrange + + ! copy values from sr to local variables + qv => sr%qv(1:) + dimen = sr%dimen + ballsize = sr%ballsize + rearrange = sr%rearrange + ind => sr%ind(1:) + DATA => sr%DATA(1:, 1:) + centeridx = sr%centeridx + correltime = sr%correltime + nn = sr%nn ! number to search for + nfound = sr%nfound + + ! search through terminal bucket. + mainloop: DO i = node%l, node%u + + ! + ! two choices for any point. The list so far is either undersized, + ! or it is not. + ! + ! If it is undersized, then add the point and its distance + ! unconditionally. If the point added fills up the working + ! list then set the sr%ballsize, maximum distance bound + ! (largest distance on list) to be that distance, + ! instead of the initialized +infinity. + ! + ! If the running list is full size, then compute the + ! distance but break out immediately if it is larger + ! than sr%ballsize, "best squared distance" (of the largest element), + ! as it cannot be a good neighbor. + ! + ! Once computed, compare to best_square distance. + ! if it is smaller, then delete the previous largest + ! element and add the new one. + + ! which index to the point do we use? + + IF (rearrange) THEN + sd = 0.0 + DO k = 1, dimen + sd = sd + (DATA(k, i) - qv(k))**2 + IF (sd > ballsize) CYCLE mainloop + END DO + indexofi = ind(i) ! only read it if we have not broken out + ELSE + indexofi = ind(i) + sd = 0.0 + DO k = 1, dimen + sd = sd + (DATA(k, indexofi) - qv(k))**2 + IF (sd > ballsize) CYCLE mainloop + END DO + END IF + + IF (centeridx > 0) THEN ! doing correlation interval? + IF (ABS(indexofi - centeridx) < correltime) CYCLE mainloop + END IF + + nfound = nfound + 1 + IF (nfound .GT. sr%nalloc) THEN + ! oh nuts, we have to add another one to the tree but + ! there isn't enough room. + sr%overflow = .TRUE. + ELSE + sr%results(nfound)%dis = sd + sr%results(nfound)%idx = indexofi + END IF + END DO mainloop + + ! Reset sr variables which may have changed during loop + sr%nfound = nfound +END SUBROUTINE process_terminal_node_fixedball + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Matthew Kennel +! date: 2024-04-10 +! summary: Used for benchmarking only +! +! find the 'n' nearest neighbors to 'qv' by exhaustive search. +! only use this subroutine for testing, as it is SLOW! The +! whole point of a k-d tree is to avoid doing what this subroutine +! does. + +SUBROUTINE Kdtree2_n_nearest_brute_force(tp, qv, nn, results) + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + REAL(kdkind), INTENT(IN) :: qv(:) + INTEGER, INTENT(IN) :: nn + TYPE(Kdtree2Result_) :: results(:) + + INTEGER :: i, j, k + REAL(kdkind), ALLOCATABLE :: all_distances(:) + ! .. + ALLOCATE (all_distances(tp%n)) + DO i = 1, tp%n + all_distances(i) = square_distance(tp%dimen, qv, tp%the_data(:, i)) + END DO + ! now find 'n' smallest distances + DO i = 1, nn + results(i)%dis = HUGE(1.0) + results(i)%idx = -1 + END DO + DO i = 1, tp%n + IF (all_distances(i) < results(nn)%dis) THEN + ! insert it somewhere on the list + DO j = 1, nn + IF (all_distances(i) < results(j)%dis) EXIT + END DO + ! now we know 'j' + DO k = nn - 1, j, -1 + results(k + 1) = results(k) + END DO + results(j)%dis = all_distances(i) + results(j)%idx = i + END IF + END DO + DEALLOCATE (all_distances) +END SUBROUTINE Kdtree2_n_nearest_brute_force + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE Kdtree2_r_nearest_brute_force(tp, qv, r2, nfound, results) + ! find the nearest neighbors to 'qv' with distance**2 <= r2 by exhaustive + ! search. + ! only use this subroutine for testing, as it is SLOW! The + ! whole point of a k-d tree is to avoid doing what this subroutine + ! does. + TYPE(Kdtree2_), TARGET, INTENT(INOUT) :: tp + REAL(kdkind), INTENT(IN) :: qv(:) + REAL(kdkind), INTENT(IN) :: r2 + INTEGER, INTENT(out) :: nfound + TYPE(Kdtree2Result_) :: results(:) + + INTEGER :: i, nalloc + REAL(kdkind), ALLOCATABLE :: all_distances(:) + ! .. + ALLOCATE (all_distances(tp%n)) + DO i = 1, tp%n + all_distances(i) = square_distance(tp%dimen, qv, tp%the_data(:, i)) + END DO + + nfound = 0 + nalloc = SIZE(results, 1) + + DO i = 1, tp%n + IF (all_distances(i) < r2) THEN + ! insert it somewhere on the list + IF (nfound .LT. nalloc) THEN + nfound = nfound + 1 + results(nfound)%dis = all_distances(i) + results(nfound)%idx = i + END IF + END IF + END DO + DEALLOCATE (all_distances) + + CALL Kdtree2_sort_results(nfound, results) + +END SUBROUTINE Kdtree2_r_nearest_brute_force + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Use after search to sort results(1:nfound) in order of increasing +! distance. +SUBROUTINE Kdtree2_sort_results(nfound, results) + INTEGER, INTENT(IN) :: nfound + TYPE(Kdtree2Result_), TARGET :: results(:) + IF (nfound .GT. 1) CALL heapsort_struct(results, nfound) +END SUBROUTINE Kdtree2_sort_results + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Sort a(1:n) in ascending order +SUBROUTINE heapsort_struct(a, n) + INTEGER, INTENT(IN) :: n + TYPE(Kdtree2Result_), INTENT(INOUT) :: a(:) + + TYPE(Kdtree2Result_) :: VALUE ! temporary value + INTEGER :: i, j + INTEGER :: ileft, iright + + ileft = n / 2 + 1 + iright = n + + IF (n .EQ. 1) RETURN + + DO + IF (ileft > 1) THEN + ileft = ileft - 1 + VALUE = a(ileft) + ELSE + VALUE = a(iright) + a(iright) = a(1) + iright = iright - 1 + IF (iright == 1) THEN + a(1) = VALUE + RETURN + END IF + END IF + + i = ileft + j = 2 * ileft + DO WHILE (j <= iright) + IF (j < iright) THEN + IF (a(j)%dis < a(j + 1)%dis) j = j + 1 + END IF + IF (VALUE%dis < a(j)%dis) THEN + a(i) = a(j); + i = j + j = j + j + ELSE + j = iright + 1 + END IF + END DO + a(i) = VALUE + + END DO +END SUBROUTINE heapsort_struct + +END MODULE Kdtree2_Module diff --git a/src/modules/KeyValue/CMakeLists.txt b/src/modules/KeyValue/CMakeLists.txt new file mode 100644 index 000000000..5decd65fb --- /dev/null +++ b/src/modules/KeyValue/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/KeyValue_Method.F90 +) diff --git a/src/modules/KeyValue/src/KeyValue_Method.F90 b/src/modules/KeyValue/src/KeyValue_Method.F90 new file mode 100644 index 000000000..6c4c7cd9c --- /dev/null +++ b/src/modules/KeyValue/src/KeyValue_Method.F90 @@ -0,0 +1,1227 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 4 March 2021 +! summary: This module contains interfaces of methods related to [[keyvalue_]] +! +!### Usage +! +! ```fortran +! program main +! use easifem +! implicit none +! type( keyvalue_ ) :: obj +! real( dfp ) :: vec( 3 ), mat( 3, 3 ) +! call random_number( vec ) +! call random_number( mat ) +! obj = keyvalue( 'real-rank-0', 1.0_dfp ) +! obj = 1.0_dfp +! call display( obj, 'obj' ) +! obj = keyvalue( 'real-rank-1', vec ) +! obj = [1.0_dfp, 1.0_dfp, 1.0_dfp] +! call display( obj, 'obj' ) +! obj = keyvalue( 'real-rank-2', mat ) +! call display( obj, 'obj' ) +! end program main +! ``` + +MODULE KeyValue_Method +USE BaseType +USE GlobalData +USE String_Class, ONLY:String +IMPLICIT NONE +PRIVATE +INTEGER, PARAMETER :: REAL_RANK_0 = 0 +INTEGER, PARAMETER :: REAL_RANK_1 = 1 +INTEGER, PARAMETER :: REAL_RANK_2 = 2 +INTEGER, PARAMETER :: INT_RANK_0 = 3 +INTEGER, PARAMETER :: INT_RANK_1 = 4 +INTEGER, PARAMETER :: INT_RANK_2 = 5 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = char` +! - `Value = Real Rank 0` +! +!### Usage +! +! ```fortran +! call initiate( obj, Key = 'E', Value = 1.0_dfp ) +! ``` + +MODULE PURE SUBROUTINE Initiate1( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value +END SUBROUTINE Initiate1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = string` +! - `Value = Real Rank 0` +! +!### Usage +! +! ```fortran +! call initiate( obj, Key = string('E'), Value = 1.0_dfp ) +! ``` + +MODULE PURE SUBROUTINE Initiate2( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value +END SUBROUTINE Initiate2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = char` +! - `Value = Real Rank 1` + +MODULE PURE SUBROUTINE Initiate3( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( : ) +END SUBROUTINE Initiate3 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = String` +! - `Value = Real Rank 1` + +MODULE PURE SUBROUTINE Initiate4( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( : ) +END SUBROUTINE Initiate4 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = char` +! - `Value = Real Rank 2` + +MODULE PURE SUBROUTINE Initiate5( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( :, : ) +END SUBROUTINE Initiate5 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = String` +! - `Value = Real Rank 2` + +MODULE PURE SUBROUTINE Initiate6( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( :, : ) +END SUBROUTINE Initiate6 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = char` +! - `Value = Int Rank 0` + +MODULE PURE SUBROUTINE Initiate7( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value +END SUBROUTINE Initiate7 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = String` +! - `Value = Int Rank 0` + +MODULE PURE SUBROUTINE Initiate8( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value +END SUBROUTINE Initiate8 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = char` +! - `Value = Int Rank 1` + +MODULE PURE SUBROUTINE Initiate9( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( : ) +END SUBROUTINE Initiate9 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = string` +! - `Value = Int Rank 1` + +MODULE PURE SUBROUTINE Initiate10( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( : ) +END SUBROUTINE Initiate10 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = char` +! - `Value = Int Rank 2` + +MODULE PURE SUBROUTINE Initiate11( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) +END SUBROUTINE Initiate11 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object +! - `Key = string` +! - `Value = Int Rank 2` + +MODULE PURE SUBROUTINE Initiate12( obj, Key, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) +END SUBROUTINE Initiate12 +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that initiate instance of [[KeyValue_]] + +!> author: Dr. Vikas Sharma +! +! This suborutine constructs [[keyvalue_]] object + +MODULE PURE SUBROUTINE Initiate13( obj, obj2 ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + CLASS( keyValue_ ), INTENT( IN ) :: obj2 +END SUBROUTINE Initiate13 +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE Initiate1, Initiate2, Initiate3, Initiate4, & + & Initiate5, Initiate6, Initiate7, Initiate8, Initiate9, & + & Initiate10, Initiate11, Initiate12, Initiate13 +END INTERFACE Initiate + +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Constructor1( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value +END FUNCTION Constructor1 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Constructor2( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value +END FUNCTION Constructor2 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor3( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor3 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor4( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor4 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor5( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor5 +end INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor6( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor6 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Constructor7( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value +END FUNCTION Constructor7 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Constructor8( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value +END FUNCTION Constructor8 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor9( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor9 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor10( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor10 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor11( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor11 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Function that constructs [[keyvalue_]] + +MODULE PURE FUNCTION Constructor12( Key, Value ) RESULT( Ans ) + TYPE( keyValue_ ) :: Ans + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor12 +END INTERFACE + +INTERFACE KeyValue + MODULE PROCEDURE Constructor1, Constructor2, Constructor3, & + & Constructor4, Constructor5, Constructor6, Constructor7, & + & Constructor8, Constructor9, Constructor10, Constructor11, & + & Constructor12 +END INTERFACE KeyValue + +PUBLIC :: KeyValue + + +INTERFACE +MODULE PURE FUNCTION Contains2( obj, Key ) RESULT( Ans ) + TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) + TYPE( String ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Contains2 +END INTERFACE + +INTERFACE OPERATOR( .CONTAINS. ) + MODULE PROCEDURE Present1, Present2, Contains1, Contains2 +END INTERFACE OPERATOR( .CONTAINS. ) + +PUBLIC :: OPERATOR( .CONTAINS. ) + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_1( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value +END FUNCTION Constructor_1 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_2( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value +END FUNCTION Constructor_2 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_3( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor_3 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_4( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor_4 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_5( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor_5 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_6( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + TYPE( String ), INTENT( IN ) :: Key + REAL( DFP ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor_6 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_7( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value +END FUNCTION Constructor_7 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_8( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value +END FUNCTION Constructor_8 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_9( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor_9 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_10( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( : ) +END FUNCTION Constructor_10 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_11( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor_11 +END INTERFACE + +!---------------------------------------------------------------------------- +! KeyValue_Pointer@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE FUNCTION Constructor_12( Key, Value ) RESULT( Ans ) + CLASS( keyValue_ ), POINTER :: Ans + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) +END FUNCTION Constructor_12 +END INTERFACE + +INTERFACE KeyValue_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3, & + & Constructor_4, Constructor_5, Constructor_6, Constructor_7, & + & Constructor_8, Constructor_9, Constructor_10, Constructor_11, & + & Constructor_12 +END INTERFACE KeyValue_Pointer + +PUBLIC :: KeyValue_Pointer + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +INTERFACE +!! This subroutine display contents of [[keyvalue_]] + +MODULE SUBROUTINE keyvalue_display( obj, msg, UnitNo ) + CLASS( keyValue_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: msg + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo +END SUBROUTINE keyvalue_display +END INTERFACE + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +INTERFACE +!! Display content of vector of [[keyvalue_]] + +MODULE SUBROUTINE mp_display( obj, msg, unitno ) + TYPE( keyvalue_ ), INTENT( IN ) :: obj( : ) + CHARACTER( LEN = * ), INTENT( IN ) :: msg + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo +END SUBROUTINE mp_display +END INTERFACE + +!> Generic subroutine to display content of [[keyvalue_]] +INTERFACE Display + MODULE PROCEDURE keyvalue_display, mp_display +END INTERFACE Display + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +INTERFACE +!! Function to check equality in [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Equal1( obj, Key ) RESULT( Ans ) + CLASS( KeyValue_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Equal1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +INTERFACE +!! Function to check equality in [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Equal2( Key, obj ) RESULT( Ans ) + CLASS( KeyValue_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Equal2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +INTERFACE +!! Function to check equality in [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Equal3( obj, Key ) RESULT( Ans ) + CLASS( KeyValue_ ), INTENT( IN ) :: obj + TYPE( String ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Equal3 +END INTERFACE + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +INTERFACE +!! Function to check equality in [[keyvalue_]] + +MODULE ELEMENTAL FUNCTION Equal4( Key, obj ) RESULT( Ans ) + CLASS( KeyValue_ ), INTENT( IN ) :: obj + TYPE( String ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Equal4 +END INTERFACE + +INTERFACE OPERATOR( .EQ. ) + MODULE PROCEDURE Equal1, Equal2, Equal3, Equal4 +END INTERFACE OPERATOR( .EQ. ) + +PUBLIC :: OPERATOR( .EQ. ) + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE SUBROUTINE keyvalue_deallocate( obj ) + CLASS( KeyValue_ ), INTENT( INOUT ) :: obj +END SUBROUTINE keyvalue_deallocate +END INTERFACE + +INTERFACE Deallocate + MODULE PROCEDURE keyvalue_deallocate +END INTERFACE Deallocate + +PUBLIC :: Deallocate + + + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set value in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set real scalar value in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = 1.0_dfp +! ``` + +MODULE PURE SUBROUTINE SetValue1( obj, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Value +END SUBROUTINE SetValue1 +END INTERFACE + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set value in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set real vector value in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = vec1 +! ``` + +MODULE PURE SUBROUTINE SetValue2( obj, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Value( : ) +END SUBROUTINE SetValue2 +END INTERFACE + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set value in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set real matrix value in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = mat +! ``` + +MODULE PURE SUBROUTINE SetValue3( obj, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Value( :, : ) +END SUBROUTINE SetValue3 +END INTERFACE + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set value in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set integer scalar value in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = intval +! ``` + +MODULE PURE SUBROUTINE SetValue4( obj, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Value +END SUBROUTINE SetValue4 +END INTERFACE + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set value in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set integer vector value in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = intvec +! ``` + +MODULE PURE SUBROUTINE SetValue5( obj, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Value( : ) +END SUBROUTINE SetValue5 +END INTERFACE + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set value in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set integer matrix value in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = intmat +! ``` + +MODULE PURE SUBROUTINE SetValue6( obj, Value ) + CLASS( keyValue_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) +END SUBROUTINE SetValue6 +END INTERFACE + +!> Generic subroutine to set values in [[keyvalue_]] +INTERFACE setValue + MODULE PROCEDURE SetValue1, SetValue2, SetValue3, SetValue4, & + & SetValue5, SetValue6 +END INTERFACE setValue + +PUBLIC :: setValue + +INTERFACE ASSIGNMENT( = ) + MODULE PROCEDURE SetValue1, SetValue2, SetValue3, SetValue4, & + & SetValue5, SetValue6 +END INTERFACE ASSIGNMENT( = ) + +PUBLIC :: ASSIGNMENT( = ) + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set key in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set key in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = "hello" +! ``` + +MODULE PURE SUBROUTINE setKey1( obj, Key ) + CLASS( KeyValue_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Key +END SUBROUTINE setKey1 +END INTERFACE + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +INTERFACE +!! Set key in [[keyvalue_]] object + +!> author: Dr. Vikas Sharma +! +! This subroutine set key in [[keyvalue_]] +! +!### Usage +! +! ```fortran +! obj = string( "hello" ) +! ``` + +MODULE PURE SUBROUTINE setKey2( obj, Key ) + CLASS( KeyValue_ ), INTENT( INOUT ) :: obj + TYPE( String ), INTENT( IN ) :: Key +END SUBROUTINE setKey2 +END INTERFACE + +!> Generic subroutine to set key in [[keyvalue_]] +INTERFACE setKey + MODULE PROCEDURE setKey1, setKey2 +END INTERFACE setKey + +PUBLIC :: setKey + +INTERFACE ASSIGNMENT( = ) + MODULE PROCEDURE setKey1, setKey2 +END INTERFACE ASSIGNMENT( = ) + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +INTERFACE +!! Subroutine that append `keyvalue_` instance to an array of [[keyvalue_]] +!! type + +MODULE PURE SUBROUTINE keyvalue_append( obj, KeyValobj ) + TYPE( KeyValue_ ), ALLOCATABLE, INTENT( INOUT ) :: obj( : ) + TYPE( KeyValue_), INTENT( IN ) :: KeyValobj +END SUBROUTINE keyvalue_append +END INTERFACE + +INTERFACE Append + MODULE PROCEDURE keyvalue_append +END INTERFACE Append + +PUBLIC :: Append + + +!---------------------------------------------------------------------------- +! getKey +!---------------------------------------------------------------------------- + +INTERFACE +!! get key from [[keyvalue_]] + +MODULE PURE SUBROUTINE getKey1( Key, obj ) + CLASS( KeyValue_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( INOUT ) :: Key +END SUBROUTINE getKey1 +END INTERFACE + +!---------------------------------------------------------------------------- +! getKey +!---------------------------------------------------------------------------- + +INTERFACE +!! get key from [[keyvalue_]] + +MODULE PURE SUBROUTINE getKey2( Key, obj ) + CLASS( KeyValue_ ), INTENT( IN ) :: obj + TYPE( String ), INTENT( INOUT ) :: Key +END SUBROUTINE getKey2 +END INTERFACE + +!> Generic subroutine to get key from [[keyvalue_]] +INTERFACE getKey + MODULE PROCEDURE getKey1, getKey2 +END INTERFACE getKey + +PUBLIC :: getKey + +INTERFACE ASSIGNMENT( = ) + MODULE PROCEDURE getKey1, getKey2 +END INTERFACE ASSIGNMENT( = ) + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +INTERFACE +!! getValue from [[keyvalue_]] + +MODULE PURE SUBROUTINE getValue1( Value, obj ) + CLASS( keyValue_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( INOUT ) :: Value +END SUBROUTINE getValue1 +END INTERFACE + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +INTERFACE +!! getValue from [[keyvalue_]] + +MODULE PURE SUBROUTINE getValue2( Value, obj ) + CLASS( keyValue_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: Value( : ) +END SUBROUTINE getValue2 +END INTERFACE + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +INTERFACE +!! getValue from [[keyvalue_]] + +MODULE PURE SUBROUTINE getValue3( Value, obj ) + CLASS( keyValue_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: Value( :, : ) +END SUBROUTINE getValue3 +END INTERFACE + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +INTERFACE +!! getValue from [[keyvalue_]] + +MODULE PURE SUBROUTINE getValue4( Value, obj ) + CLASS( keyValue_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( INOUT ) :: Value +END SUBROUTINE getValue4 +END INTERFACE + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +INTERFACE +!! getValue from [[keyvalue_]] + +MODULE PURE SUBROUTINE getValue5( Value, obj ) + CLASS( keyValue_ ), INTENT( IN ) :: obj + INTEGER( I4B ), ALLOCATABLE, INTENT( INOUT ) :: Value( : ) +END SUBROUTINE getValue5 +END INTERFACE + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +INTERFACE +!! getValue from [[keyvalue_]] + +MODULE PURE SUBROUTINE getValue6( Value, obj ) + CLASS( keyValue_ ), INTENT( IN ) :: obj + INTEGER( I4B ), ALLOCATABLE, INTENT( INOUT ) :: Value( :, : ) +END SUBROUTINE getValue6 +END INTERFACE + +!> Generic subroutine to get value from [[keyvalue_]] +INTERFACE getValue + MODULE PROCEDURE getValue1, getValue2, getValue3, getValue4, & + & getValue5, getValue6 +END INTERFACE getValue + +PUBLIC :: getValue + +INTERFACE ASSIGNMENT( = ) + MODULE PROCEDURE getValue1, getValue2, getValue3, getValue4, & + & getValue5, getValue6 +END INTERFACE ASSIGNMENT( = ) + +!---------------------------------------------------------------------------- +! Index +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION Index1( obj, Key ) RESULT( Ans ) + TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) + CHARACTER( LEN = * ), INTENT( IN ) :: Key + INTEGER( I4B ) :: Ans +END FUNCTION Index1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Index +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION Index2( obj, Key ) RESULT( Ans ) + TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) + TYPE( String ), INTENT( IN ) :: Key + INTEGER( I4B ) :: Ans +END FUNCTION Index2 +END INTERFACE + +INTERFACE IndexOf + MODULE PROCEDURE Index1, Index2 +END INTERFACE IndexOf + +PUBLIC :: IndexOf + +INTERFACE OPERATOR( .INDEX. ) + MODULE PROCEDURE Index1, Index2 +END INTERFACE OPERATOR( .INDEX. ) + +PUBLIC :: OPERATOR( .INDEX. ) + +!---------------------------------------------------------------------------- +! Present +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION Present1( Key, obj ) RESULT( Ans ) + TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) + CHARACTER( LEN = * ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Present1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Present +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION Present2( Key, obj ) RESULT( Ans ) + TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) + TYPE( String ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Present2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Contains +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION Contains1( obj, Key ) RESULT( Ans ) + TYPE( KeyValue_ ), INTENT( IN ) :: obj( : ) + CHARACTER( LEN = * ), INTENT( IN ) :: Key + LOGICAL( LGT ) :: Ans +END FUNCTION Contains1 +END INTERFACE + +!------------------------------------------------------------------------------ +! Contains2 +!------------------------------------------------------------------------------ +END MODULE KeyValue_Method \ No newline at end of file diff --git a/src/modules/LISInterface/CMakeLists.txt b/src/modules/LISInterface/CMakeLists.txt new file mode 100644 index 000000000..e1fa3539b --- /dev/null +++ b/src/modules/LISInterface/CMakeLists.txt @@ -0,0 +1,27 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +# IF( USE_LIS ) +# SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +# TARGET_SOURCES( +# ${PROJECT_NAME} PRIVATE +# ${src_path}/LISParam.F90 +# ${src_path}/LISBasic.F90 +# ${src_path}/LISVector.F90 +# ${src_path}/LISInterface.F90 +# ) +# ENDIF( ) diff --git a/src/modules/LISInterface/src/LISBasic.F90 b/src/modules/LISInterface/src/LISBasic.F90 new file mode 100644 index 000000000..bc86b4d62 --- /dev/null +++ b/src/modules/LISInterface/src/LISBasic.F90 @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 LISBasic +USE GlobalData, ONLY: I4B +IMPLICIT NONE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + + SUBROUTINE lis_init_f(ierr) + IMPORT :: I4B + INTEGER(I4B), INTENT(IN) :: ierr + END SUBROUTINE lis_init_f +END INTERFACE + +PUBLIC :: lis_initialize + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_finalize(void); + +INTERFACE + FUNCTION lis_finalize() & + & BIND(C, name="lis_finalize") + IMPORT :: I4B + INTEGER(I4B) :: lis_finalize + END FUNCTION lis_finalize +END INTERFACE + +PUBLIC :: lis_finalize + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +FUNCTION lis_initialize() + INTEGER(I4B) :: lis_initialize + CALL lis_init_f(lis_initialize) +END FUNCTION lis_initialize + +END MODULE LISBasic diff --git a/src/modules/LISInterface/src/LISInterface.F90 b/src/modules/LISInterface/src/LISInterface.F90 new file mode 100644 index 000000000..4aceb516e --- /dev/null +++ b/src/modules/LISInterface/src/LISInterface.F90 @@ -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 +! + +MODULE LISInterface +! USE LISParam +! USE LISBasic +! USE LISVector +END MODULE LISInterface diff --git a/src/modules/LISInterface/src/LISParam.F90 b/src/modules/LISInterface/src/LISParam.F90 new file mode 100644 index 000000000..6f8edeb7c --- /dev/null +++ b/src/modules/LISInterface/src/LISParam.F90 @@ -0,0 +1,128 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +! #ifdef LONG__LONG +! #define LIS_INTEGER integer*8 +! #else +! #define LIS_INTEGER integer +! #endif +! +! #ifdef LONG__DOUBLE +! #ifdef COMPLEX +! #define LIS_SCALAR complex*32 +! #else +! #define LIS_SCALAR real*16 +! #endif +! #define LIS_COMPLEX complex*32 +! #define LIS_REAL real*16 +! #else +! #ifdef COMPLEX +! #define LIS_SCALAR complex*16 +! #else +! #define LIS_SCALAR real*8 +! #endif +! #define LIS_COMPLEX complex*16 +! #define LIS_REAL real*8 +! #endif +! +! #define LIS_Comm LIS_INTEGER +! +! #ifdef USE_MPI +! #ifndef WIN32 +! INCLUDE 'mpif.h' +! #else +! #include 'mpif.h' +! #endif +! +! #ifdef LONG__LONG +! #define LIS_MPI_INTEGER MPI_INTEGER +! #else +! #define LIS_MPI_INTEGER MPI_INTEGER +! #endif +! +! #define LIS_COMM_WORLD MPI_COMM_WORLD +! #else +! #define LIS_COMM_WORLD 1 +! #endif + +MODULE LISParam +USE GlobalData, ONLY: I4B, DFP, LGT, INT32, INT64 +IMPLICIT NONE +PRIVATE + +INTEGER(I4B), PUBLIC, PARAMETER :: LIS_TRUE = 1 +INTEGER(I4B), PUBLIC, PARAMETER :: LIS_FALSE = 0 +INTEGER(I4B), PUBLIC, PARAMETER :: LIS_INS_VALUE = 0 +INTEGER(I4B), PUBLIC, PARAMETER :: LIS_ADD_VALUE = 1 +INTEGER(I4B), PUBLIC, PARAMETER :: LIS_SUB_VALUE = 2 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_ASSEMBLING = 0 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CSR = 1 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CSC = 2 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_MSR = 3 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DIA = 4 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CDS = 4 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_ELL = 5 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_JAD = 6 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BSR = 7 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BSC = 8 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_VBR = 9 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_COO = 10 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DENSE = 11 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DNS = 11 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_RCO = 255 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_TJAD = 12 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BJAD = 13 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BCR = 14 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CJAD = 15 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_PCSR = 16 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_LCSR = 17 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_LJAD = 18 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_LBSR = 19 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_CDIA = 20 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_MSC = 21 +INTEGER(i4b), public, PARAMETER :: LIS_MATRIX_DECIDING_SIZE = -(LIS_MATRIX_RCO + 1) +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_NULL = -(LIS_MATRIX_RCO + 2) +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_DEFAULT = LIS_MATRIX_CSR +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_POINT = LIS_MATRIX_CSR +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MATRIX_BLOCK = LIS_MATRIX_BSR +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SCALE_NONE = 0 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SCALE_JACOBI = 1 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SCALE_SYMM_DIAG = 2 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_AUTO = 0 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_PLAIN = 1 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_MM = 2 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_LIS = 3 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_LIS_ASCII = 3 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_LIS_BINARY = 4 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_FREE = 5 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_ITBL = 6 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_HB = 7 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FMT_MMB = 8 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_BINARY_BIG = 0 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_BINARY_LITTLE = 1 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_FAILS = -1 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_SUCCESS = 0 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ILL_OPTION = 1 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_ILL_ARG = 1 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_BREAKDOWN = 2 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_OUT_OF_MEMORY = 3 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_OUT_OF_MEMORY = 3 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_MAXITER = 4 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_NOT_IMPLEMENTED = 5 +INTEGER(i4b), PUBLIC, PARAMETER :: LIS_ERR_FILE_IO = 6 + +END MODULE LISParam diff --git a/src/modules/LISInterface/src/LISVector.F90 b/src/modules/LISInterface/src/LISVector.F90 new file mode 100644 index 000000000..394785de7 --- /dev/null +++ b/src/modules/LISInterface/src/LISVector.F90 @@ -0,0 +1,434 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 LISVector +USE ISO_C_BINDING +USE GlobalData, ONLY: I4B, DFP, LGT +USE Display_Method, ONLY: Display +IMPLICIT NONE +PRIVATE + +! struct LIS_VECTOR_STRUCT +! { +! LIS_INT label; +! LIS_INT status; +! LIS_INT precision; +! LIS_INT gn; +! LIS_INT n; +! LIS_INT np; +! LIS_INT pad; +! LIS_INT origin; +! LIS_INT is_copy; +! LIS_INT is_destroy; +! LIS_INT is_scaled; +! LIS_INT my_rank; +! LIS_INT nprocs; +! LIS_Comm comm; +! LIS_INT is; +! LIS_INT ie; +! LIS_INT *ranges; +! LIS_SCALAR *value; +! LIS_SCALAR *value_lo; +! LIS_SCALAR *work; +! LIS_INT intvalue; +! }; +! typedef struct LIS_VECTOR_STRUCT *LIS_VECTOR; + +TYPE, BIND(C) :: LIS_VECTOR + INTEGER(I4B) :: label; + INTEGER(I4B) :: status; + INTEGER(I4B) :: PRECISION; + INTEGER(I4B) :: gn; + INTEGER(I4B) :: n; + INTEGER(I4B) :: np; + INTEGER(I4B) :: pad; + INTEGER(I4B) :: origin; + INTEGER(I4B) :: is_copy; + INTEGER(I4B) :: is_destroy; + INTEGER(I4B) :: is_scaled; + INTEGER(I4B) :: my_rank; + INTEGER(I4B) :: nprocs; + INTEGER(I4B) :: comm; + INTEGER(I4B) :: is; + INTEGER(I4B) :: ie; + TYPE(C_PTR) :: ranges; + TYPE(C_PTR) :: VALUE; + TYPE(C_PTR) :: value_lo; + TYPE(C_PTR) :: work; + INTEGER(I4B) :: intvalue; +END TYPE LIS_VECTOR + +PUBLIC :: LIS_VECTOR + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Display + MODULE PROCEDURE display_lisvector +END INTERFACE Display + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_create(LIS_Comm comm, LIS_VECTOR *vec); + +INTERFACE + FUNCTION lis_vector_create(comm, vec) BIND(C, name="lis_vector_create") + IMPORT :: LIS_VECTOR, I4B + INTEGER(I4B), VALUE, INTENT(in) :: comm + TYPE(LIS_VECTOR), INTENT(INOUT) :: vec + INTEGER(I4B) :: lis_vector_create + END FUNCTION lis_vector_create +END INTERFACE + +PUBLIC :: lis_vector_create + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_set_size(LIS_VECTOR vec, LIS_INT local_n, & +! LIS_INT global_n); + +INTERFACE + FUNCTION lis_vector_set_size(vec, local_n, global_n) & + & BIND(C, name="lis_vector_set_size") + IMPORT :: LIS_VECTOR, I4B, C_PTR + TYPE(LIS_VECTOR), INTENT(INOUT) :: vec + INTEGER(I4B), VALUE, INTENT(IN) :: local_n + INTEGER(I4B), VALUE, INTENT(IN) :: global_n + INTEGER(I4B) :: lis_vector_set_size + END FUNCTION lis_vector_set_size +END INTERFACE + +PUBLIC :: lis_vector_set_size + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_psd_reset_scale(LIS_VECTOR vec); + +INTERFACE + FUNCTION lis_vector_psd_reset_scale(vec) & + & BIND(C, name="lis_vector_psd_reset_scale") + IMPORT :: LIS_VECTOR, I4B + TYPE(LIS_VECTOR), INTENT(INOUT) :: vec + INTEGER(I4B) :: lis_vector_psd_reset_scale + END FUNCTION lis_vector_psd_reset_scale +END INTERFACE + +PUBLIC :: lis_vector_psd_reset_scale + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_destroy(LIS_VECTOR vec); + +INTERFACE + FUNCTION lis_vector_destroy(vec) & + & BIND(C, name="lis_vector_destroy") + IMPORT :: LIS_VECTOR, I4B + TYPE(LIS_VECTOR), INTENT(INOUT) :: vec + INTEGER(I4B) :: lis_vector_destroy + END FUNCTION lis_vector_destroy +END INTERFACE + +PUBLIC :: lis_vector_destroy + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_duplicate(void *vin, LIS_VECTOR *vout); + +INTERFACE + FUNCTION lis_vector_duplicate(vin, vout) BIND(C, name="lis_vector_duplicate") + IMPORT :: LIS_VECTOR, C_PTR, I4B + TYPE(C_PTR), INTENT(IN) :: vin + TYPE(LIS_VECTOR), INTENT(INOUT) :: vout + INTEGER(I4B) :: lis_vector_duplicate + END FUNCTION lis_vector_duplicate +END INTERFACE + +PUBLIC :: lis_vector_duplicate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_get_size(LIS_VECTOR v, LIS_INT *local_n, LIS_INT *global_n); + +INTERFACE + FUNCTION lis_vector_get_size(v, local_n, global_n) & + & BIND(C, name="lis_vector_get_size") + IMPORT :: LIS_VECTOR, I4B + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B), INTENT(INOUT) :: local_n + INTEGER(I4B), INTENT(INOUT) :: global_n + INTEGER(I4B) :: lis_vector_get_size + END FUNCTION lis_vector_get_size +END INTERFACE + +PUBLIC :: lis_vector_get_size + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_get_range(LIS_VECTOR v, LIS_INT *is, LIS_INT *ie); + +INTERFACE + FUNCTION lis_vector_get_range(v, is, ie) & + & BIND(C, name="lis_vector_get_range") + IMPORT :: LIS_VECTOR, I4B + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B), INTENT(INOUT) :: is + INTEGER(I4B), INTENT(INOUT) :: ie + INTEGER(I4B) :: lis_vector_get_range + END FUNCTION lis_vector_get_range +END INTERFACE + +PUBLIC :: lis_vector_get_range + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_get_value(LIS_VECTOR v, LIS_INT i, LIS_SCALAR *value); + +INTERFACE + FUNCTION lis_vector_get_value(v, i, VALUE) & + & BIND(C, name="lis_vector_get_value") + IMPORT :: LIS_VECTOR, I4B, DFP + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B), VALUE, INTENT(IN) :: i + REAL(DFP), INTENT(INOUT) :: VALUE + INTEGER(I4B) :: lis_vector_get_value + END FUNCTION lis_vector_get_value +END INTERFACE + +PUBLIC :: lis_vector_get_value + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_get_values(LIS_VECTOR v, LIS_INT start, LIS_INT count, LIS_SCALAR value[]); + +INTERFACE + FUNCTION lis_vector_get_values(v, start, count, VALUE) & + & BIND(C, name="lis_vector_get_values") + IMPORT :: LIS_VECTOR, I4B, DFP + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B), VALUE, INTENT(IN) :: start + INTEGER(I4B), VALUE, INTENT(IN) :: count + REAL(DFP), INTENT(INOUT) :: VALUE(*) + INTEGER(I4B) :: lis_vector_get_values + END FUNCTION lis_vector_get_values +END INTERFACE + +PUBLIC :: lis_vector_get_values + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_set_value(LIS_INT flag, LIS_INT i, LIS_SCALAR value, LIS_VECTOR v); + +INTERFACE + FUNCTION lis_vector_set_value(flag, i, VALUE, v) & + & BIND(C, name="lis_vector_set_value") + IMPORT :: LIS_VECTOR, I4B, DFP + INTEGER(I4B), VALUE, INTENT(IN) :: flag + INTEGER(I4B), VALUE, INTENT(IN) :: i + REAL(DFP), VALUE, INTENT(IN) :: VALUE + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B) :: lis_vector_set_value + END FUNCTION lis_vector_set_value +END INTERFACE + +PUBLIC :: lis_vector_set_value + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_set_values(LIS_INT flag, LIS_INT count, LIS_INT index[], LIS_SCALAR value[], LIS_VECTOR v); + +INTERFACE + FUNCTION lis_vector_set_values(flag, count, index, VALUE, v) & + & BIND(C, name="lis_vector_set_values") + IMPORT :: LIS_VECTOR, I4B, DFP + INTEGER(I4B), VALUE, INTENT(IN) :: flag + INTEGER(I4B), VALUE, INTENT(IN) :: count + INTEGER(I4B), INTENT(IN) :: INDEX(count) + REAL(DFP), INTENT(IN) :: VALUE(count) + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B) :: lis_vector_set_values + END FUNCTION lis_vector_set_values +END INTERFACE + +PUBLIC :: lis_vector_set_values + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_set_values2(LIS_INT flag, LIS_INT start, LIS_INT count, LIS_SCALAR value[], LIS_VECTOR v); + +INTERFACE + FUNCTION lis_vector_set_values2(flag, start, count, VALUE, v) & + & BIND(C, name="lis_vector_set_values2") + IMPORT :: LIS_VECTOR, I4B, DFP + INTEGER(I4B), VALUE, INTENT(IN) :: flag + INTEGER(I4B), VALUE, INTENT(IN) :: start + INTEGER(I4B), VALUE, INTENT(IN) :: count + REAL(DFP), INTENT(IN) :: VALUE(count) + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B) :: lis_vector_set_values2 + END FUNCTION lis_vector_set_values2 +END INTERFACE + +PUBLIC :: lis_vector_set_values2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_print(LIS_VECTOR x); + +INTERFACE + FUNCTION lis_vector_print(x) & + & BIND(C, name="lis_vector_print") + IMPORT :: LIS_VECTOR, I4B + TYPE(LIS_VECTOR), VALUE, INTENT(IN) :: x + INTEGER(I4B) :: lis_vector_print + END FUNCTION lis_vector_print +END INTERFACE +! +PUBLIC :: lis_vector_print + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern LIS_INT lis_vector_scatter(LIS_SCALAR value[], LIS_VECTOR v); + +INTERFACE + FUNCTION lis_vector_scatter(VALUE, v) & + & BIND(C, name="lis_vector_scatter") + IMPORT :: LIS_VECTOR, I4B, DFP + REAL(DFP), INTENT(IN) :: VALUE(*) + TYPE(LIS_VECTOR), INTENT(INOUT) :: v + INTEGER(I4B) :: lis_vector_scatter + END FUNCTION lis_vector_scatter +END INTERFACE + +PUBLIC :: lis_vector_scatter + +! extern LIS_INT lis_vector_gather(LIS_VECTOR v, LIS_SCALAR value[]); +! extern LIS_INT lis_vector_is_null(LIS_VECTOR v); +! extern LIS_INT lis_vector_swap(LIS_VECTOR vsrc, LIS_VECTOR vdst); +! extern LIS_INT lis_vector_copy(LIS_VECTOR vsrc, LIS_VECTOR vdst); +! extern LIS_INT lis_vector_axpy(LIS_SCALAR alpha, LIS_VECTOR vx, LIS_VECTOR vy); +! extern LIS_INT lis_vector_xpay(LIS_VECTOR vx, LIS_SCALAR alpha, LIS_VECTOR vy); +! extern LIS_INT lis_vector_axpyz(LIS_SCALAR alpha, LIS_VECTOR vx, LIS_VECTOR vy, LIS_VECTOR vz); +! extern LIS_INT lis_vector_scale(LIS_SCALAR alpha, LIS_VECTOR vx); +! extern LIS_INT lis_vector_pmul(LIS_VECTOR vx,LIS_VECTOR vy,LIS_VECTOR vz); +! extern LIS_INT lis_vector_pdiv(LIS_VECTOR vx,LIS_VECTOR vy,LIS_VECTOR vz); +! extern LIS_INT lis_vector_set_all(LIS_SCALAR alpha, LIS_VECTOR vx); +! extern LIS_INT lis_vector_abs(LIS_VECTOR vx); +! extern LIS_INT lis_vector_reciprocal(LIS_VECTOR vx); +! extern LIS_INT lis_vector_conjugate(LIS_VECTOR vx); +! extern LIS_INT lis_vector_shift(LIS_SCALAR sigma, LIS_VECTOR vx); +! extern LIS_INT lis_vector_dot(LIS_VECTOR vx, LIS_VECTOR vy, LIS_SCALAR *value); +! extern LIS_INT lis_vector_nhdot(LIS_VECTOR vx, LIS_VECTOR vy, LIS_SCALAR *value); +! extern LIS_INT lis_vector_nrm1(LIS_VECTOR vx, LIS_REAL *value); +! extern LIS_INT lis_vector_nrm2(LIS_VECTOR vx, LIS_REAL *value); +! extern LIS_INT lis_vector_nrmi(LIS_VECTOR vx, LIS_REAL *value); +! extern LIS_INT lis_vector_sum(LIS_VECTOR vx, LIS_SCALAR *value); + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE display_lisvector(obj, msg, unitno) + TYPE(LIS_VECTOR), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + REAL(DFP), POINTER :: VALUE(:) + + CALL Display(obj%label, "label = ", unitno) + CALL Display(obj%status, "status = ", unitno) + CALL Display(obj%PRECISION, "PRECISION = ", unitno) + CALL Display(obj%gn, "gn = ", unitno) + CALL Display(obj%n, "n = ", unitno) + CALL Display(obj%np, "np = ", unitno) + CALL Display(obj%pad, "pad= ", unitno) + CALL Display(obj%origin, "origin= ", unitno) + CALL Display(obj%is_copy, "is_copy= ", unitno) + CALL Display(obj%is_destroy, "is_destroy= ", unitno) + CALL Display(obj%is_scaled, "is_scaled= ", unitno) + CALL Display(obj%my_rank, "my_rank= ", unitno) + CALL Display(obj%nprocs, "nprocs= ", unitno) + CALL Display(obj%comm, "comm= ", unitno) + CALL Display(obj%is, "is= ", unitno) + CALL Display(obj%ie, "ie= ", unitno) + CALL Display(obj%intvalue, "intvalue= ", unitno) + + IF (C_ASSOCIATED(obj%ranges)) THEN + CALL Display("ranges is associated", unitno) + ELSE + CALL Display("ranges is NOT associated", unitno) + END IF + + IF (C_ASSOCIATED(obj%VALUE)) THEN + CALL Display("VALUE is associated", unitno) + CALL C_F_POINTER(obj%VALUE, VALUE, [obj%n]) + IF (obj%n .LE. 10) THEN + CALL Display(VALUE, "value = ", unitno) + ELSE + CALL Display(VALUE(1:10), "value(1:10) = ", unitno) + END IF + NULLIFY (VALUE) + ELSE + CALL Display("VALUE is NOT associated", unitno) + END IF + + IF (C_ASSOCIATED(obj%value_lo)) THEN + CALL Display("value_lo is associated", unitno) + ELSE + CALL Display("value_lo is NOT associated", unitno) + END IF + + IF (C_ASSOCIATED(obj%work)) THEN + CALL Display("work is associated", unitno) + ELSE + CALL Display("work is NOT associated", unitno) + END IF + +END SUBROUTINE display_lisvector + +END MODULE LISVector diff --git a/src/modules/Lapack/CMakeLists.txt b/src/modules/Lapack/CMakeLists.txt new file mode 100644 index 000000000..1f9c2bd9c --- /dev/null +++ b/src/modules/Lapack/CMakeLists.txt @@ -0,0 +1,37 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +IF( USE_LAPACK95 ) + LIST( APPEND TARGET_COMPILE_DEF "-DUSE_LAPACK95" ) + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/GE_CompRoutineMethods.F90 + ${src_path}/GE_EigenValueMethods.F90 + ${src_path}/GE_LUMethods.F90 + ${src_path}/GE_LinearSolveMethods.F90 + ${src_path}/GE_SingularValueMethods.F90 + ${src_path}/GE_Lapack_Method.F90 + ${src_path}/Sym_CompRoutineMethods.F90 + ${src_path}/Sym_EigenValueMethods.F90 + ${src_path}/Sym_LUMethods.F90 + ${src_path}/Sym_LinearSolveMethods.F90 + ${src_path}/Sym_SingularValueMethods.F90 + ${src_path}/Sym_Lapack_Method.F90 + ${src_path}/Lapack_Method.F90 + ) +ENDIF( ) diff --git a/src/modules/Lapack/src/GE_CompRoutineMethods.F90 b/src/modules/Lapack/src/GE_CompRoutineMethods.F90 new file mode 100644 index 000000000..870b57bb6 --- /dev/null +++ b/src/modules/Lapack/src/GE_CompRoutineMethods.F90 @@ -0,0 +1,158 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 GE_CompRoutineMethods +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE + +PUBLIC :: ConditionNo +PUBLIC :: GetInvMat + +!---------------------------------------------------------------------------- +! ConditionNo +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION ge_ConditionNo_1(A, NORM) RESULT(ans) + REAL(DFP), INTENT(IN) :: A(:, :) + !! General matrix + CHARACTER(1), INTENT(IN) :: NORM + !! "1", "0" + REAL(DFP) :: ans + !! + END FUNCTION ge_ConditionNo_1 +END INTERFACE + +INTERFACE ConditionNo + MODULE PROCEDURE ge_ConditionNo_1 +END INTERFACE ConditionNo + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +! This routine calls `DGETRI` routine from Lapack. +! A copy of matrix A is made into invA, then LU decomposition is performed and +! `DGETRI` is called from lapack + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat1(A, invA) + REAL(DFP), INTENT(IN) :: A(:, :) + !! General matrix + REAL(DFP), INTENT(INOUT) :: invA(:, :) + !! + END SUBROUTINE ge_GetInvMat1 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat1 +END INTERFACE GetInvMat + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +!- This routine calls `DGETRI` routine from Lapack. +!- A and IPIV are obtained from LU decomposition +!- A contains the LU decomposition of matrix A +!- A copy of matrix A is made into invA, then +! `DGETRI` is called from lapack + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat2(A, IPIV, invA) + REAL(DFP), INTENT(IN) :: A(:, :) + !! General matrix + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! General matrix + REAL(DFP), INTENT(INOUT) :: invA(:, :) + !! + END SUBROUTINE ge_GetInvMat2 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat2 +END INTERFACE GetInvMat + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +!- This routine calls `DGETRI` routine from Lapack. +!- A and IPIV are obtained from LU decomposition +!- A contains the LU decomposition of matrix A at input +!- At output invese of A is stored inside A +!- No copy is made. + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat3(A, IPIV) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LU Decompose at input + !! inverse at output + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! + END SUBROUTINE ge_GetInvMat3 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat3 +END INTERFACE GetInvMat + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +!- This routine calls `DGETRI` routine from Lapack. +!- First LU decomposition is performed +!- Then `DGETRI` is called from lapack +!- At output A contains the inverse. + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat4(A) + REAL(DFP), INTENT(INOUT) :: A(:, :) + END SUBROUTINE ge_GetInvMat4 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat4 +END INTERFACE GetInvMat + +END MODULE GE_CompRoutineMethods diff --git a/src/modules/Lapack/src/GE_EigenValueMethods.F90 b/src/modules/Lapack/src/GE_EigenValueMethods.F90 new file mode 100644 index 000000000..ee78f7adf --- /dev/null +++ b/src/modules/Lapack/src/GE_EigenValueMethods.F90 @@ -0,0 +1,188 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 GE_EigenValueMethods +USE GlobalData, ONLY: DFP, DFPC, I4B, LGT +IMPLICIT NONE +CHARACTER(*), PARAMETER :: modName = "GE_EigenValueMethods" +PRIVATE + +PUBLIC :: GetEigVals +PUBLIC :: GetEig + +!---------------------------------------------------------------------------- +! getEigVals +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: calculate eigenvalues for real matrix +! +! if destroy is false matrix A is preserved +! + +INTERFACE GetEigVals + MODULE SUBROUTINE deigvals(A, lam, destroy) + REAL(DFP), INTENT(INOUT) :: A(:, :) + COMPLEX(DFPC), INTENT(INOUT) :: lam(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy + ! default is true + END SUBROUTINE deigvals +END INTERFACE GetEigVals + +!---------------------------------------------------------------------------- +! getEigVals +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: calculate eigenvalues for complex matrix +! +! if destroy is false matrix A is preserved +! + +INTERFACE GetEigVals + MODULE SUBROUTINE zeigvals(A, lam, destroy) + COMPLEX(DFPC), INTENT(INOUT) :: A(:, :) + COMPLEX(DFPC), INTENT(INOUT) :: lam(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy + ! default is true + END SUBROUTINE zeigvals +END INTERFACE GetEigVals + +!---------------------------------------------------------------------------- +! getEig +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: calculate eigenvalues and eigenvectors for real matrix +! +! if destroy is false matrix A is preserved +! + +INTERFACE GetEig + MODULE SUBROUTINE deig(A, lam, c, destroy) + REAL(DFP), INTENT(INOUT) :: A(:, :) + COMPLEX(DFPC), INTENT(INOUT) :: lam(:) + ! eigenvalues + ! should be allocated + COMPLEX(DFPC), INTENT(INOUT) :: c(:, :) + ! eigenvectors + ! c(i,j) = ith component of jth eigenvec. + ! should be allocated + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy + ! default is true + END SUBROUTINE deig +END INTERFACE GetEig + +!---------------------------------------------------------------------------- +! getEig +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-05-17 +! summary: calculate eigenvalues and eigenvectors for complex matrix +! +! if destroy is false matrix A is preserved +! + +INTERFACE GetEig + MODULE SUBROUTINE zeig(A, lam, c, destroy) + COMPLEX(DFPC), INTENT(INOUT) :: A(:, :) + COMPLEX(DFPC), INTENT(INOUT) :: lam(:) + ! eigenvalues + ! should be allocated + COMPLEX(DFPC), INTENT(INOUT) :: c(:, :) + ! eigenvectors + ! c(i,j) = ith component of jth eigenvec. + ! should be allocated + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: destroy + ! default is true + END SUBROUTINE zeig +END INTERFACE GetEig + +!---------------------------------------------------------------------------- +! DGEES@EigenValue +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! DGEES computes for an N-by-N real nonsymmetric matrix A, the +! eigenvalues, the real Schur form T, and, optionally, the matrix of +! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). +! +! Optionally, it also orders the eigenvalues on the diagonal of the +! real Schur form so that selected eigenvalues are at the top left. +! The leading columns of Z then form an orthonormal basis for the +! invariant subspace corresponding to the selected eigenvalues. +! +! A matrix is in real Schur form if it is upper quasi-triangular with +! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the +! form +! [ a b ] +! [ c a ] +! +! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). +! +! JOBVS : JOBVS is CHARACTER*1 +! = 'N': Schur vectors are not computed; +! = 'V': Schur vectors are computed. +! +! SORT : SORT is CHARACTER*1 +! Specifies whether or not to order the eigenvalues on the +! diagonal of the Schur form. +! = 'N': Eigenvalues are not ordered; +! = 'S': Eigenvalues are ordered (see SELECT). +! +! SELECT: SELECT is a LOGICAL FUNCTION of two DOUBLE PRECISION arguments +! SELECT must be declared EXTERNAL in the calling subroutine. +! If SORT = 'S', SELECT is used to select eigenvalues to sort +! to the top left of the Schur form. +! If SORT = 'N', SELECT is not referenced. +! An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if +! SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex +! conjugate pair of eigenvalues is selected, then both complex +! eigenvalues are selected. +! Note that a selected complex eigenvalue may no longer +! satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since +! ordering may change the value of complex eigenvalues +! (especially if the eigenvalue is ill-conditioned); in this +! case INFO is set to N+2 (see INFO below). +! +! N is INTEGER: The order of the matrix A. N >= 0. +! +! A: A is DOUBLE PRECISION array, dimension (LDA,N) +! On entry, the N-by-N matrix A. +! On exit, A has been overwritten by its real Schur form T +! +! LDA: Leading dimension of A +! +! SDIM: + +! INTERFACE +! MODULE SUBROUTINE dgees_1(A, WR, WI, SchurForm) +! REAL(DFP), INTENT(IN) :: A(:, :) +! REAL(DFP), INTENT(INOUT) :: WR(:) +! !! Real part of the eigenvalue +! REAL(DFP), INTENT(INOUT) :: WI(:) +! !! Imaginary part of the eigenvalue +! REAL(DFP), INTENT(INOUT) :: SchurForm(:, :) +! END SUBROUTINE dgees_1 +! END INTERFACE + +END MODULE GE_EigenValueMethods diff --git a/src/modules/Lapack/src/GE_LUMethods.F90 b/src/modules/Lapack/src/GE_LUMethods.F90 new file mode 100644 index 000000000..bd59251bb --- /dev/null +++ b/src/modules/Lapack/src/GE_LUMethods.F90 @@ -0,0 +1,251 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 GE_LUMethods +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetLU +PUBLIC :: LUSolve +PUBLIC :: Inv + +!---------------------------------------------------------------------------- +! GetLU@LU +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-07-07 +! summary: DGetF2 computes an LU factorization of a general m-by-n matrix A +! +!# Introduction +! +! Using partial pivoting with row interchanges. +! +! DGetF2 computes an LU factorization of a general m-by-n matrix A +! using partial pivoting with row interchanges. +! +! The factorization has the form +! A = P * L * U +! where P is a permutation matrix, L is lower triangular with unit +! diagonal elements (lower trapezoidal if m > n), and U is upper +! triangular (upper trapezoidal if m < n). +! +! This is the right-looking Level 2 BLAS version of the algorithm. +! +! ## GetRF +! +! DGetRF computes an LU factorization of a general M-by-N matrix A +! using partial pivoting with row interchanges +! +! - iterative version of Sivan Toledo's recursive LU algorithm +! - left-looking Level 3 BLAS version of the algorithm. +! +! The factorization has the form +! A = P * L * U +! where P is a permutation matrix, L is lower triangular with unit +! diagonal elements (lower trapezoidal if m > n), and U is upper +! triangular (upper trapezoidal if m < n). +! + +INTERFACE GetLU + MODULE SUBROUTINE GetLU_1(A, LU, IPIV, RCOND, NORM, info) + REAL(DFP), INTENT(IN) :: A(:, :) + !! Matrix to be factored + REAL(DFP), INTENT(OUT) :: LU(:, :) + !! LU factorization, the unit diagonal elements of L are not stored. + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! IPIV is INTEGER array,row i of the matrix was interchanged with row + !! IPIV(i). + !! IPIV is INTEGER array, dimension (min(M,N)) + !! The pivot indices; for 1 <= i <= min(M,N), row i of the + !! matrix was interchanged with row IPIV(i). + REAL(DFP), OPTIONAL, INTENT(OUT) :: RCOND + !! Inverse of Condition number + CHARACTER(1), OPTIONAL, INTENT(IN) :: NORM + !! NORM "1", "0" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE GetLU_1 +END INTERFACE GetLU + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Compute LU factorization +! +!# Introduction +! +! This routine is same as `GetLU_1` however in this routine LU +! factorization is computed in A matrix on return. + +INTERFACE GetLU + MODULE SUBROUTINE GetLU_2(A, IPIV, RCOND, NORM, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! Matrix to be factored, on return it contains LU factorization, + !! the unit diagonal elements of L are not stored. + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! IPIV is INTEGER array,row i of the matrix was interchanged with row + !! IPIV(i). + !! IPIV is INTEGER array, dimension (min(M,N)) + !! The pivot indices; for 1 <= i <= min(M,N), row i of the + !! matrix was interchanged with row IPIV(i). + REAL(DFP), OPTIONAL, INTENT(OUT) :: RCOND + !! If present then inverse of condition number is returned + CHARACTER(1), OPTIONAL, INTENT(IN) :: NORM + !! "1", "0" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE GetLU_2 +END INTERFACE GetLU + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y + +INTERFACE LUSolve + MODULE SUBROUTINE LUSolve_1(A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LU decomposition of matrix A, see GetLU + REAL(DFP), INTENT(INOUT) :: B(:) + !! at entry RHS + !! on return solution will be in B + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! IPIV returned from GetLU + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! IF isTranspose true then we solve A^Tx=y + !! Default is `.false.` + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info + END SUBROUTINE LUSolve_1 +END INTERFACE LUSolve + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y + +INTERFACE LUSolve + MODULE SUBROUTINE LUSolve_2(A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LU Decomposition of A returned from GetLU + REAL(DFP), INTENT(INOUT) :: B(:, :) + !! Several rhs, on return solution will be in B + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! pivoting returned from GetLU + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! if true we solve A^Tx = y + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE LUSolve_2 +END INTERFACE LUSolve + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y + +INTERFACE LUSolve + MODULE SUBROUTINE LUSolve_3(X, A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(OUT) :: X(:) + !! RHS, on return solution will be in B + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LU decomposition of matrix A, see GetLU + REAL(DFP), INTENT(IN) :: B(:) + !! RHS + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! IPIV returned from GetLU + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! if isTranspose true then we solve A^Tx=y + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info + END SUBROUTINE LUSolve_3 +END INTERFACE LUSolve + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y + +INTERFACE LUSolve + MODULE SUBROUTINE LUSolve_4(X, A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(OUT) :: X(:, :) + !! solution + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LU Decomposition of A returned from GetLU + REAL(DFP), INTENT(IN) :: B(:, :) + !! several RHS + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! pivoting returned from GetLU + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! if true we solve A^Tx = y + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE LUSolve_4 +END INTERFACE LUSolve + +!---------------------------------------------------------------------------- +! GetInv +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Get inverse of square matrix from LU decomposition + +INTERFACE Inv + MODULE SUBROUTINE Inv_1(A, invA, IPIV, info) + REAL(DFP), INTENT(IN) :: A(:, :) + !! LU Decomposition + REAL(DFP), INTENT(INOUT) :: invA(:, :) + !! inverse of A + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! returned from GetLU + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE Inv_1 +END INTERFACE Inv + +!---------------------------------------------------------------------------- +! GetInv +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Get inverse of square matrix from LU decomposition + +INTERFACE Inv + MODULE SUBROUTINE Inv_2(A, IPIV, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LU Decomposition, inverse will be returned in A + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! returned from GetLU + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE Inv_2 +END INTERFACE Inv + +END MODULE GE_LUMethods diff --git a/src/modules/Lapack/src/GE_Lapack_Method.F90 b/src/modules/Lapack/src/GE_Lapack_Method.F90 new file mode 100644 index 000000000..61ce378ee --- /dev/null +++ b/src/modules/Lapack/src/GE_Lapack_Method.F90 @@ -0,0 +1,39 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 7 July 2022 +! summary: Lapack methods +! +!# Introduction +! +! This module contains linear algebra packages for fortran matrix (2D array) +! The matrix is GE +! This module contains following submoduls +! - @LinearSolveMethods PARTIAL/STABLE +! - @EigenValueMethods TODO +! - @SingularValueMethods TODO +! - @CompRoutineMethods PARTIAL/STABLE +! - @AuxRoutinesMethods TODO + +MODULE GE_Lapack_Method +USE GE_CompRoutineMethods +USE GE_EigenValueMethods +USE GE_LUMethods +USE GE_LinearSolveMethods +USE GE_SingularValueMethods +END MODULE GE_Lapack_Method diff --git a/src/modules/Lapack/src/GE_LinearSolveMethods.F90 b/src/modules/Lapack/src/GE_LinearSolveMethods.F90 new file mode 100644 index 000000000..82eba0dd4 --- /dev/null +++ b/src/modules/Lapack/src/GE_LinearSolveMethods.F90 @@ -0,0 +1,488 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! Linear Solver name +! - GESV +! - GESVX +! - GESVXX +! - GELS +! - GELSD +! - GELSS +! - GELSY +! - GETSLS + +MODULE GE_LinearSolveMethods +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE +PUBLIC :: Solve +PUBLIC :: LinSolve + +!---------------------------------------------------------------------------- +! Solve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 7 July 2022 +! summary: This function solves Ax=b using lapack, A can be square or rect +! +!# Introduction +! +! This function solves Ax=b using LAPACK. A can be a square matrix or +! rectangular matrix. +! +! This routine creates a copy of A and B. So do not use it for large +! systems. +! +! When A is a square matrix, then this routine calls GESV routine. +! +!## GESV +! +! GESV computes the solution to a real system of linear equations +! +!$$ +! Ax = y, +!$$ +! +! The LU decomposition with partial pivoting and row interchanges is +! used to factor A as +! +!$$ +! A = P * L * U, +!$$ +! +! where P is a permutation matrix, L is unit lower triangular, and U is +! upper triangular. The factored form of A is then used to solve the +! system of equations A * X = B. +! +! When A is not a square matrix, then this routine calls can call following +! routines depending upon the value of SolverName. +! +! - GELS <-- Default QR or LQ, (A should have full rank) +! - GELSD <-- When A is rank defincient, SVD +! - GELSS +! +!## GELS +! +! GELS solves overdetermined or underdetermined systems for GE matrices using +! QR or LQ factorization. +! +!@note +! Note that matrix A should have full rank. +!@endnote +! +! If `isTranspose` is false then we solve $Ax=y$. +! +! In this case, if +! the number of rows are greater than number of columns (more equations) +! then we solve a least square problem (by using GEQRF) of +! +!$$ +! min \Vert y-Ax \Vert +!$$ +! +! When number of rows are lesser than the number of columns we have an +! underdetermined system. And we obtain the minimum norm solution +! of an underdetermined system $Ax=y$ (by using GELQF). +! +! When isTranspose is true then we solve $A^T x = y$. Here if number of rows +! are greater than the number of cols, then we have underdetermined system +! If number of rows of A is lesser than the number of columns of A, then +! we solve a least square system. +! +!## GELSD +! +! DGELSD computes the minimum-norm solution to a real linear least +! squares problem: +! +!$$ +! min \Vert b - A*x \Vert_{2} +!$$ +! +! by using the singular value decomposition (SVD) of A. +! A is an M-by-N matrix which may be rank-deficient. +! +! +! The problem is solved in three steps: +! (1) Reduce the coefficient matrix A to bidiagonal form with +! Householder transformations, reducing the original problem +! into a "bidiagonal least squares problem" (BLS) +! (2) Solve the BLS using a divide and conquer approach. +! (3) Apply back all the Householder transformations to solve +! the original least squares problem. +! +! The effective rank of A is determined by treating as zero those +! singular values which are less than RCOND times the largest singular +! value. +! +! The divide and conquer algorithm makes very mild assumptions about +! floating point arithmetic. It will work on machines with a guard +! digit in add/subtract, or on those binary machines without guard +! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +! Cray-2. It could conceivably fail on hexadecimal or decimal machines +! without guard digits, but we know of none. +! +!## GELSS +! +! GELSS solves overdetermined or underdetermined systems for GE matrices +! +!DGELSS computes the minimum norm solution to a real linear least +! squares problem: +! +!$$ +! min \Vert b - A*x \Vert_{2} +!$$ +! +! using the singular value decomposition (SVD) of A. A is an M-by-N +! matrix which may be rank-deficient. +! +! The effective rank of A is determined by treating as zero those +! singular values which are less than RCOND times the largest singular +! value. +! +!@note +! Note that this routine creates a copy of A and b and then find x. +! This is because DGESV modifies the entries of A and b. +! Therefore, when A is large this routine should be avoided. +!@endnote + +INTERFACE Solve + MODULE SUBROUTINE ge_solve_1(X, A, B, IPIV, SolverName, isTranspose, RANK, & + & RCOND, S, info) + REAL(DFP), INTENT(INOUT) :: X(:) + !! Unknown vector + REAL(DFP), INTENT(IN) :: A(:, :) + !! General square matrix + REAL(DFP), INTENT(IN) :: B(:) + !! RHS of Ax=B + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! Used for GESV + ! IPIV is INTEGER array, dimension (N) + ! The pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! If true then we solve $A^{T} x = y$ + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + !! Used in case of GELSD and GELSS + !! The effective rank of A, i.e., the number of singular values + !! which are greater than RCOND*S(1). + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + !! RCOND is used to determine the effective rank of A. + !! Singular values S(i) <= RCOND*S(1) are treated as zero. + !! If RCOND < 0, machine precision is used instead. + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + !! Used in case of GELSD and GELSS + !! S is DOUBLE PRECISION array, dimension (min(M,N)) + !! The singular values of A in decreasing order. + !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE ge_solve_1 +END INTERFACE Solve + +!---------------------------------------------------------------------------- +! Solve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 7 July 2022 +! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays +! +!# Introduction +! +! +! This function solves Ax=b using LAPACK. A can be a square or rectangle +! matrix. In this case we have several RHS denoted by B matrix. +! +! All other things are same as `ge_solve_1`. + +INTERFACE Solve + MODULE SUBROUTINE ge_solve_2(X, A, B, IPIV, SolverName, isTranspose, RANK, & + & RCOND, S, info) + REAL(DFP), INTENT(INOUT) :: X(:, :) + !! Unknown vector + REAL(DFP), INTENT(IN) :: A(:, :) + !! General square matrix + REAL(DFP), INTENT(IN) :: B(:, :) + !! RHS of Ax=B + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! inverse of permuation + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! If true then we solve A^T x = y. + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE ge_solve_2 +END INTERFACE Solve + +!---------------------------------------------------------------------------- +! GELSY@LinearSolve +!---------------------------------------------------------------------------- + +!# Introduction +! +! DGELSY computes the minimum-norm solution to a real linear least +! squares problem: +! minimize || A * X - B || +! using a complete orthogonal factorization of A. A is an M-by-N +! matrix which may be rank-deficient. +! +! Several right hand side vectors b and solution vectors x can be +! handled in a single call; they are stored as the columns of the +! M-by-NRHS right hand side matrix B and the N-by-NRHS solution +! matrix X. +! +! The routine first computes a QR factorization with column pivoting: +! A * P = Q * [ R11 R12 ] +! [ 0 R22 ] +! with R11 defined as the largest leading submatrix whose estimated +! condition number is less than 1/RCOND. The order of R11, RANK, +! is the effective rank of A. +! +! Then, R22 is considered to be negligible, and R12 is annihilated +! by orthogonal transformations from the right, arriving at the +! complete orthogonal factorization: +! A * P = Q * [ T11 0 ] * Z +! [ 0 0 ] +! The minimum-norm solution is then +! X = P * Z**T [ inv(T11)*Q1**T*B ] +! [ 0 ] +! where Q1 consists of the first RANK columns of Q. +! +! This routine is basically identical to the original xGELSX except +! three differences: +! - The call to the subroutine xGEQPF has been substituted by the +! the call to the subroutine xGEQP3. This subroutine is a Blas-3 +! version of the QR factorization with column pivoting. +! - Matrix B (the right hand side) is updated with Blas-3. +! - The permutation of matrix B (the right hand side) is faster and +! more simple. + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve Ax=Y +! +!# Introduction +! +! This routine is same as `ge_solve_1` with following difference. +! +! In this subroutine we do not make copy of A. Therefore A will be +! modified on return. Note that B will not be modified as we still +! make a copy of B. +! +! +!## GESV +! +! On entry, the N-by-N coefficient matrix A. +! On exit, the factors L and U from the factorization +! A = P*L*U; the unit diagonal elements of L are not stored. +! +!## GELS +! +! On entry, the M-by-N matrix A. +! On exit, +! if M >= N, A is overwritten by details of its QR +! factorization as returned by DGEQRF; +! if M < N, A is overwritten by details of its LQ +! factorization as returned by DGELQF. +! +!## GELSD +! +! On entry, the M-by-N matrix A. +! On exit, A has been destroyed. +! +!## GELSS +! +! On entry, the M-by-N matrix A. +! On exit, the first min(m,n) rows of A are overwritten with +! its right singular vectors, stored rowwise. + +INTERFACE LinSolve + MODULE SUBROUTINE ge_linsolve_1(X, A, B, IPIV, SolverName, & + & isTranspose, RANK, RCOND, S, info) + REAL(DFP), INTENT(INOUT) :: X(:) + !! Unknown vector solution + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square/rectangle matrix, it will be modified on return + REAL(DFP), INTENT(IN) :: B(:) + !! RHS of Ax=B + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! Used for GESV + !! IPIV is INTEGER array, dimension (N) + !! The pivot indices that define the permutation matrix P; + !! row i of the matrix was interchanged with row IPIV(i). + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! If true then we solve $A^{T} x = y$ + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + !! Used in case of GELSD and GELSS + !! The effective rank of A, i.e., the number of singular values + !! which are greater than RCOND*S(1). + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + !! RCOND is used to determine the effective rank of A. + !! Singular values S(i) <= RCOND*S(1) are treated as zero. + !! If RCOND < 0, machine precision is used instead. + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + !! Used in case of GELSD and GELSS + !! S is DOUBLE PRECISION array, dimension (min(M,N)) + !! The singular values of A in decreasing order. + !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE ge_linsolve_1 +END INTERFACE LinSolve + +!---------------------------------------------------------------------------- +! LinSolve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 7 July 2022 +! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays +! +!# Introduction +! +! +! This function solves Ax=b using LAPACK. A can be a square or rectangle +! matrix. In this case we have several RHS denoted by B matrix. +! +! All other things are same as `ge_solve_1`. + +INTERFACE LinSolve + MODULE SUBROUTINE ge_linsolve_2(X, A, B, IPIV, SolverName, isTranspose, & + & RANK, RCOND, S, info) + REAL(DFP), INTENT(INOUT) :: X(:, :) + !! Unknown vector or solution + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square/ rectangle matrix, its content will be destroyed + REAL(DFP), INTENT(IN) :: B(:, :) + !! RHS of Ax=B + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! inverse of permuation + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! If true then we solve A^T x = y. + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE ge_linsolve_2 +END INTERFACE LinSolve + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary:Solve Ax=b +! +!# Introduction +! +! This routine is same as `ge_linsolve_1` with following changes +! +! We do not make any copy of B. The solution is returned in B. This +! means B will be destroyed on return. + +INTERFACE LinSolve + MODULE SUBROUTINE ge_linsolve_3(A, B, IPIV, SolverName, & + & isTranspose, RANK, RCOND, S, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square/ rectangle matrix, its content will be modified on + !! return + REAL(DFP), INTENT(INOUT) :: B(:) + !! RHS of Ax=B, it will contain the solution on return + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! Used for GESV + ! IPIV is INTEGER array, dimension (N) + ! The pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! If true then we solve $A^{T} x = y$ + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + !! Used in case of GELSD and GELSS + !! The effective rank of A, i.e., the number of singular values + !! which are greater than RCOND*S(1). + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + !! RCOND is used to determine the effective rank of A. + !! Singular values S(i) <= RCOND*S(1) are treated as zero. + !! If RCOND < 0, machine precision is used instead. + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + !! Used in case of GELSD and GELSS + !! S is DOUBLE PRECISION array, dimension (min(M,N)) + !! The singular values of A in decreasing order. + !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE ge_linsolve_3 +END INTERFACE LinSolve + +INTERFACE Solve + MODULE PROCEDURE ge_linsolve_3 +END INTERFACE Solve + +!---------------------------------------------------------------------------- +! LinSolve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve Ax=y +! +!# Introduction +! +! This routien is same as `ge_linsolve_2` with following difference +! +! In this routine we do not create copy of B, ans sol is returned in B. +! This means B will be changed on return. + +INTERFACE LinSolve + MODULE SUBROUTINE ge_linsolve_4(A, B, IPIV, SolverName, isTranspose, & + & RANK, RCOND, S, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square/rectangle matrix, its content will be modifie + !! on return + REAL(DFP), INTENT(INOUT) :: B(:, :) + !! RHS of Ax=B, it will be modified such that it contains solution on + !! return + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! inverse of permuation + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + !! If true then we solve A^T x = y. + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE ge_linsolve_4 +END INTERFACE LinSolve + +INTERFACE Solve + MODULE PROCEDURE ge_linsolve_4 +END INTERFACE Solve + +END MODULE GE_LinearSolveMethods diff --git a/src/modules/Lapack/src/GE_SingularValueMethods.F90 b/src/modules/Lapack/src/GE_SingularValueMethods.F90 new file mode 100644 index 000000000..d63b20091 --- /dev/null +++ b/src/modules/Lapack/src/GE_SingularValueMethods.F90 @@ -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 +! + +MODULE GE_SingularValueMethods +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE +END MODULE GE_SingularValueMethods diff --git a/src/modules/Lapack/src/Lapack_Method.F90 b/src/modules/Lapack/src/Lapack_Method.F90 new file mode 100644 index 000000000..bb0647fb4 --- /dev/null +++ b/src/modules/Lapack/src/Lapack_Method.F90 @@ -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 +! + +MODULE Lapack_Method +USE GE_Lapack_Method +USE Sym_Lapack_Method +END MODULE Lapack_Method \ No newline at end of file diff --git a/src/modules/Lapack/src/Sym_CompRoutineMethods.F90 b/src/modules/Lapack/src/Sym_CompRoutineMethods.F90 new file mode 100644 index 000000000..a5e47cd41 --- /dev/null +++ b/src/modules/Lapack/src/Sym_CompRoutineMethods.F90 @@ -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 +! + +MODULE Sym_CompRoutineMethods + +END MODULE Sym_CompRoutineMethods diff --git a/src/modules/Lapack/src/Sym_EigenValueMethods.F90 b/src/modules/Lapack/src/Sym_EigenValueMethods.F90 new file mode 100644 index 000000000..112006cae --- /dev/null +++ b/src/modules/Lapack/src/Sym_EigenValueMethods.F90 @@ -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 +! + +MODULE Sym_EigenValueMethods + +END MODULE Sym_EigenValueMethods diff --git a/src/modules/Lapack/src/Sym_LUMethods.F90 b/src/modules/Lapack/src/Sym_LUMethods.F90 new file mode 100644 index 000000000..da1cb88ba --- /dev/null +++ b/src/modules/Lapack/src/Sym_LUMethods.F90 @@ -0,0 +1,488 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 Sym_LUMethods +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE +PUBLIC :: SymGetLU +PUBLIC :: SymGetLDL +PUBLIC :: SymGetCholesky +PUBLIC :: SymLUSolve +PUBLIC :: SymGetInv + +! PUBLIC :: CholeskySolve + +!---------------------------------------------------------------------------- +! SymGetLU +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-15 +! summary: Computes an LU (LL' or U'U) factorization of a sym matrix A + +INTERFACE + MODULE SUBROUTINE SymGetLU_1(A, LU, IPIV, UPLO, info) + REAL(DFP), INTENT(IN) :: A(:, :) + !! Matrix to be factored + REAL(DFP), INTENT(OUT) :: LU(:, :) + !! L or U factorization + !! SHAPE(LU) = [N,N] + INTEGER(I4B), INTENT(OUT) :: IPIV(:) + !! reverse permulation + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info=0 => success + !! info \ne 0 => error + END SUBROUTINE SymGetLU_1 +END INTERFACE + +INTERFACE SymGetLU + MODULE PROCEDURE SymGetLU_1 +END INTERFACE SymGetLU + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Compute LU factorization + +INTERFACE + MODULE SUBROUTINE SymGetLU_2(A, IPIV, UPLO, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! Matrix to be factored, on return it contains L or U factorization, + INTEGER(I4B), INTENT(OUT) :: IPIV(:) + !! permutation + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info = 0 ➡️ success + !! info .ne. 0 ➡️ error + END SUBROUTINE SymGetLU_2 +END INTERFACE + +INTERFACE SymGetLU + MODULE PROCEDURE SymGetLU_2 +END INTERFACE SymGetLU + +!---------------------------------------------------------------------------- +! SymGetLDL +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-15 +! summary: Computes an LU (LL' or U'U) factorization of a sym matrix A +! +!# Introduction +! +!- Computes the LDLt or Bunch-Kaufman factorization of a symmetric/ hermitian +! matrix. +!- This function returns a block diagonal matrix D consisting blocks of +! size at most 2x2 and also a possibly permuted unit lower triangular +! matrix L such that the factorization `A = L D L^H` or +! `A = L D L^T` holds. +! If `uplo=U` (again possibly permuted) upper triangular matrices +! are returned as outer factors. +! +! The permutation array can be used to triangularize the outer factors +! simply by a row shuffle, i.e., `lu[perm, :]` is an upper/lower triangular +! matrix. This is also equivalent to multiplication with a +! permutation matrix MATMUL(P, lu), where P is a column-permuted +! identity matrix I[:, perm]. +! +! Depending on the value of the "uplo", only upper or lower triangular +! part of the input array is referenced. +! Hence, a triangular matrix on entry would give the same result +! as if the full matrix is supplied. +! +! This routine calls following routines +! +!- LACPY: Copy two matrices +!- SYTRF: Perform factorization +!- SYCONV: Convert data from SYTRF to standard form. At this point, the +! LU matrix has undergone both row and column interchange (possibly) +!- LAPMR: At this point we undo the row interchange. +! +! Finally, LU is permuted such that +! +! `MATMUL( MATMUL( LU, Diag(D) ), TRANSPOSE(LU))` returns the A matrix. +! +! ## ?SYTRF +! +! DSYTRF computes the factorization of a real symmetric matrix A using +! the Bunch-Kaufman diagonal pivoting method. +! The form of the factorization is +! +!```fortran +! A = U**T*D*U or A = L*D*L**T +!``` +! +! where, +! +!- U (or L) is a product of permutation and unit upper (or lower) +! triangular matrices +!- D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. +!- This is the blocked version of the algorithm, calling Level 3 BLAS. +! +! Also see, SYTRF from Lapack95 + +INTERFACE + MODULE SUBROUTINE SymGetLDL_1(A, LU, D, E, UPLO, IPIV, info) + REAL(DFP), INTENT(IN) :: A(:, :) + !! Matrix to be factored + REAL(DFP), INTENT(OUT) :: LU(:, :) + !! L or U factorization + !! SHAPE(LU) = [N,N] + REAL(DFP), INTENT(OUT) :: D(:) + !! Diagonal entries + !! Size(D) = N + REAL(DFP), INTENT(OUT) :: E(:) + !! Subdiagonal and superdiagonal entries + !! Size(E) = N + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! reverse permulation + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info=0 => success + !! info \ne 0 => error + END SUBROUTINE SymGetLDL_1 +END INTERFACE + +INTERFACE SymGetLDL + MODULE PROCEDURE SymGetLDL_1 +END INTERFACE SymGetLDL + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Compute LU factorization +! +!# Introduction +! +! This routine is same as `getLU_1` however in this routine LU +! factorization is computed in A matrix on return. + +INTERFACE + MODULE SUBROUTINE SymGetLDL_2(A, D, E, UPLO, IPIV, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! Matrix to be factored, on return it contains L or U factorization, + REAL(DFP), INTENT(OUT) :: D(:) + !! Diagonal entries + REAL(DFP), INTENT(OUT) :: E(:) + !! Sub and super Diagonal entries + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! permutation + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info = 0 ➡️ success + !! info .ne. 0 ➡️ error + END SUBROUTINE SymGetLDL_2 +END INTERFACE + +INTERFACE SymGetLDL + MODULE PROCEDURE SymGetLDL_2 +END INTERFACE SymGetLDL + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-20 +! summary: Cholesky factorization of symmetric matrix +! +!# Introduction +! +! Compute the Cholesky decomposition of a matrix. +! +! Returns the Cholesky decomposition, $A=L \cdot L^{T}$, and $A=U^{T} \cdot U$ +! or of a Hermitian positive-definite matrix A. +! +! This routine call following routines from Lapack95 + +INTERFACE + MODULE SUBROUTINE SymGetCholesky_1(A, LU, UPLO, info) + REAL(DFP), INTENT(IN) :: A(:, :) + !! Matrix to be factored + REAL(DFP), INTENT(OUT) :: LU(:, :) + !! L or U factorization + !! SHAPE(LU) = [N,N] + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info=0 => success + !! info \ne 0 => error + END SUBROUTINE SymGetCholesky_1 +END INTERFACE + +INTERFACE SymGetCholesky + MODULE PROCEDURE SymGetCholesky_1 +END INTERFACE SymGetCholesky + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-20 +! summary: Cholesky factorization of symmetric matrix +! +!# Introduction +! +! Compute the Cholesky decomposition of a matrix. +! +! Returns the Cholesky decomposition, $A=L \cdot L^{T}$, and $A=U^{T} \cdot U$ +! or of a Hermitian positive-definite matrix A. +! +! This routine call following routines from Lapack95 + +INTERFACE + MODULE SUBROUTINE SymGetCholesky_2(A, UPLO, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! On entry Matrix to be factored + !! On exit: L or U factorization + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info=0 => success + !! info \ne 0 => error + END SUBROUTINE SymGetCholesky_2 +END INTERFACE + +INTERFACE SymGetCholesky + MODULE PROCEDURE SymGetCholesky_2 +END INTERFACE SymGetCholesky + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y +! +!# Introduction +! +! A and IPIV are returned from +! SymGetLU or SYTRF routine of Lapack95. + +INTERFACE + MODULE SUBROUTINE SymLUSolve_1(A, B, IPIV, UPLO, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LDLt decomposition of matrix A, see SymGetLU + REAL(DFP), INTENT(INOUT) :: B(:) + !! at entry RHS + !! on return solution will be in B + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! IPIV returned from SymGetLU + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info + END SUBROUTINE SymLUSolve_1 +END INTERFACE + +INTERFACE SymLUSolve + MODULE PROCEDURE SymLUSolve_1 +END INTERFACE SymLUSolve + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y +! +!# Introduction +! +! It calls `SYTRS` + +INTERFACE + MODULE SUBROUTINE SymLUSolve_2(A, B, IPIV, UPLO, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LDLt decomposition of matrix A, see SymGetLU + REAL(DFP), INTENT(INOUT) :: B(:, :) + !! at entry RHS + !! on return solution will be in B + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! IPIV returned from SymGetLU + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info + END SUBROUTINE SymLUSolve_2 +END INTERFACE + +INTERFACE SymLUSolve + MODULE PROCEDURE SymLUSolve_2 +END INTERFACE SymLUSolve + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y +! +!# Introduction +! +! A and IPIV are returned from +! SymGetLU or SYTRF routine of Lapack95. + +INTERFACE + MODULE SUBROUTINE SymLUSolve_3(X, A, B, IPIV, UPLO, info) + REAL(DFP), INTENT(OUT) :: X(:) + !! Solution + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LDLt decomposition of matrix A, see SymGetLU + REAL(DFP), INTENT(IN) :: B(:) + !! RHS + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! IPIV returned from SymGetLU + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info + END SUBROUTINE SymLUSolve_3 +END INTERFACE + +INTERFACE SymLUSolve + MODULE PROCEDURE SymLUSolve_3 +END INTERFACE SymLUSolve + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve LUx=y +! +!# Introduction +! +! It calls `SYTRS` + +INTERFACE + MODULE SUBROUTINE SymLUSolve_4(X, A, B, IPIV, UPLO, info) + REAL(DFP), INTENT(OUT) :: X(:, :) + !! Solution + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LDLt decomposition of matrix A, see SymGetLU + REAL(DFP), INTENT(IN) :: B(:, :) + !! at entry RHS + !! on return solution will be in B + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! IPIV returned from SymGetLU + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! If UPLO="U", then upper triangular part of A is used + !! If UPLO="L", then lower triangular part of A is used + !! Default = "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + !! info + END SUBROUTINE SymLUSolve_4 +END INTERFACE + +INTERFACE SymLUSolve + MODULE PROCEDURE SymLUSolve_4 +END INTERFACE SymLUSolve + +!---------------------------------------------------------------------------- +! SymGetInv +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-20 +! summary: get inverse of square matrix from LU decomposition +! +!# Introduction +! +! It calls `SYTRI` + +INTERFACE + MODULE SUBROUTINE SymGetInv_1(A, invA, IPIV, UPLO, INFO) + REAL(DFP), INTENT(IN) :: A(:, :) + !! LU Decomposition from SymGetLU + REAL(DFP), INTENT(INOUT) :: invA(:, :) + !! Inverse of A + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! Returned from SymGetLU + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE SymGetInv_1 +END INTERFACE + +INTERFACE SymGetInv + MODULE PROCEDURE SymGetInv_1 +END INTERFACE SymGetInv + +!---------------------------------------------------------------------------- +! SymGetInv +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-20 +! summary: get inverse of square matrix from LU decomposition +! +!# Introduction +! +! It calls `SYTRI` + +INTERFACE + MODULE SUBROUTINE SymGetInv_2(A, IPIV, UPLO, INFO) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! On entry: LU Decomposition from SymGetLU + !! On Exit: Inverse of A + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! Returned from SymGetLU + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE SymGetInv_2 +END INTERFACE + +INTERFACE SymGetInv + MODULE PROCEDURE SymGetInv_2 +END INTERFACE SymGetInv + +END MODULE Sym_LUMethods diff --git a/src/modules/Lapack/src/Sym_Lapack_Method.F90 b/src/modules/Lapack/src/Sym_Lapack_Method.F90 new file mode 100644 index 000000000..de9a80a22 --- /dev/null +++ b/src/modules/Lapack/src/Sym_Lapack_Method.F90 @@ -0,0 +1,40 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 20 December 2022 +! summary: Lapack methods +! +!# Introduction +! +! This module contains linear algebra packages for fortran matrix (2D array) +! The matrix is symmetric and dense +! +! This module contains following submoduls +! - @LinearSolveMethods TODO +! - @EigenValueMethods TODO +! - @SingularValueMethods TODO +! - @CompRoutineMethods TODO +! - @AuxRoutinesMethods TODO + +MODULE Sym_Lapack_Method +USE Sym_CompRoutineMethods +USE Sym_EigenValueMethods +USE Sym_LUMethods +USE Sym_LinearSolveMethods +USE Sym_SingularValueMethods +END MODULE Sym_Lapack_Method diff --git a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 new file mode 100644 index 000000000..923cbdd6b --- /dev/null +++ b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 @@ -0,0 +1,290 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! Linear Solver name +!- SYSV + +MODULE Sym_LinearSolveMethods +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE + +PUBLIC :: SymSolve +PUBLIC :: SymLinSolve + +!---------------------------------------------------------------------------- +! Solve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 7 July 2022 +! summary: This function solves Ax=b using lapack, A can be square or rect +! +!# Introduction +! +! This function solves Ax=b using LAPACK. +! +! This routine creates a copy of A and B. So do not use it for large +! systems. +! +! When A is a square matrix, then this routine calls GESV routine. +! +!## SYSV +! +! SYSV computes the solution to a real system of linear equations +! +!$$ +! Ax = y, +!$$ +! +! The LDLt decomposition with partial pivoting and row interchanges is +! used to factor A as (See SYTRF) +! +!@note +! Note that this routine creates a copy of A and b and then find x. +! This is because DGESV modifies the entries of A and b. +! Therefore, when A is large this routine should be avoided. +!@endnote + +INTERFACE + MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & + & UPLO, INFO) + REAL(DFP), INTENT(INOUT) :: X(:) + !! Unknown vector to be found + REAL(DFP), INTENT(IN) :: A(:, :) + !! Symmetric square matrix + REAL(DFP), INTENT(IN) :: B(:) + !! RHS of Ax=B + LOGICAL(LGT), INTENT(IN) :: preserveA + !! This flag is only for getting a unique interface + !! it is always set to true + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! Used for SYSV + !! IPIV is INTEGER array, dimension (N) + !! It is returned by SYTRF + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, default is SYSV + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! "U" or "L", Default is "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO + END SUBROUTINE SymLinSolve_1 +END INTERFACE + +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_1 +END INTERFACE SymSolve + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_1 +END INTERFACE SymLinSolve + +!---------------------------------------------------------------------------- +! Solve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 7 July 2022 +! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays +! +!# Introduction +! +! +! This function solves Ax=b using LAPACK. A is square and symmetric +! matrix. In this case we have several RHS denoted by B matrix. +! +! All other things are same as `ge_solve_1`. + +INTERFACE + MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & + & UPLO, INFO) + REAL(DFP), INTENT(INOUT) :: X(:, :) + !! Unknown vector + REAL(DFP), INTENT(IN) :: A(:, :) + !! General square matrix + REAL(DFP), INTENT(IN) :: B(:, :) + !! RHS of Ax=B + LOGICAL(LGT), INTENT(IN) :: preserveA + !! This flag is only for getting a unique interface + !! it is always set to true + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! inverse of permuation + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! "U" or "L", default is "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO + END SUBROUTINE SymLinSolve_2 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_2 +END INTERFACE SymLinSolve + +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_2 +END INTERFACE SymSolve + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve Ax=Y +! +!# Introduction +! +! This routine is same as `ge_solve_1` with following difference. +! +! In this subroutine we do not make copy of A. Therefore A will be +! modified on return. Note that B will not be modified as we still +! make a copy of B. + +INTERFACE + MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) + REAL(DFP), INTENT(INOUT) :: X(:) + !! Unknown vector solution + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square sym matrix, it will be modified on return + REAL(DFP), INTENT(IN) :: B(:) + !! RHS of Ax=B + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! PERMUTATION + CHARACTER(1), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is SYSV + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! "U" or "L", default is "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO + END SUBROUTINE SymLinSolve_3 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_3 +END INTERFACE SymLinSolve + +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_3 +END INTERFACE SymSolve + +!---------------------------------------------------------------------------- +! LinSolve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 7 July 2022 +! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays + +INTERFACE + MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) + REAL(DFP), INTENT(INOUT) :: X(:, :) + !! Unknown vector or solution + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square sym matrix, its content will be destroyed + REAL(DFP), INTENT(IN) :: B(:, :) + !! RHS of Ax=B + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! inverse of permuation + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, default is SYSV + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! "U" or "L", default is "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO + END SUBROUTINE SymLinSolve_4 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_4 +END INTERFACE SymLinSolve + +INTERFACE Solve + MODULE PROCEDURE SymLinSolve_4 +END INTERFACE Solve + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary:Solve Ax=b +! +!# Introduction +! +! This routine is same as `ge_linsolve_1` with following changes +! +! We do not make any copy of B. The solution is returned in B. This +! means B will be destroyed on return. + +INTERFACE + MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square symmetric matrix, its content will be modified on + !! return + REAL(DFP), INTENT(INOUT) :: B(:) + !! RHS of Ax=B, it will contain the solution on return + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + ! IPIV is INTEGER array, dimension (N) + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! "L" or "U", default is "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO + END SUBROUTINE SymLinSolve_5 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_5 +END INTERFACE SymLinSolve + +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_5 +END INTERFACE SymSolve + +!---------------------------------------------------------------------------- +! LinSolve@LinearSolveMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2022 +! summary: Solve Ax=y + +INTERFACE + MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! General square/rectangle matrix, its content will be modifie + !! on return + REAL(DFP), INTENT(INOUT) :: B(:, :) + !! RHS of Ax=B, it will be modified such that it contains solution on + !! return + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) + !! inverse of permuation + CHARACTER(*), OPTIONAL, INTENT(IN) :: SolverName + !! Name of the solver, when A is not square, default is GELS + CHARACTER(1), OPTIONAL, INTENT(IN) :: UPLO + !! "U" or "L", default is "U" + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO + END SUBROUTINE SymLinSolve_6 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_6 +END INTERFACE SymLinSolve + +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_6 +END INTERFACE SymSolve + +END MODULE Sym_LinearSolveMethods diff --git a/src/modules/Lapack/src/Sym_SingularValueMethods.F90 b/src/modules/Lapack/src/Sym_SingularValueMethods.F90 new file mode 100644 index 000000000..da67af637 --- /dev/null +++ b/src/modules/Lapack/src/Sym_SingularValueMethods.F90 @@ -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 +! + +MODULE Sym_SingularValueMethods + +END MODULE Sym_SingularValueMethods diff --git a/src/modules/LuaInterface/CMakeLists.txt b/src/modules/LuaInterface/CMakeLists.txt new file mode 100644 index 000000000..0431e2dda --- /dev/null +++ b/src/modules/LuaInterface/CMakeLists.txt @@ -0,0 +1,30 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +IF(USE_LUA) + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/LuaInterface.F90 + ) +ELSE() + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/No_LuaInterface.F90 + ) +ENDIF() diff --git a/src/modules/LuaInterface/src/LuaInterface.F90 b/src/modules/LuaInterface/src/LuaInterface.F90 new file mode 100644 index 000000000..68917c52d --- /dev/null +++ b/src/modules/LuaInterface/src/LuaInterface.F90 @@ -0,0 +1,1499 @@ +! This module is taken from +! https://github.com/interkosmos/fortran-lua54 +! +! lua.f90 +! +! A collection of ISO C binding interfaces to Lua 5.4 for Fortran 2008. +! +! Author: Philipp Engel +! Licence: ISC +! +! I have modified it slighly according to the EASIFEM requirement. +! + +MODULE LuaInterface +USE, INTRINSIC :: ISO_C_BINDING +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: i8 => INT64 +USE GlobalData, ONLY: I4B +USE Display_Method, ONLY: Display +IMPLICIT NONE +PRIVATE + +! The integer and float types used by Lua are platform-specific. +! Select the types according to your local Lua library. +INTEGER, PARAMETER, PUBLIC :: lua_integer = C_LONG_LONG +! The other options for lua_integer are +! c_int, c_long, c_long_long, c_int64_t +INTEGER, PARAMETER, PUBLIC :: lua_number = C_DOUBLE +! The other options for lua_number are +! c_float, c_double, c_long_double +INTEGER, PARAMETER, PUBLIC :: lua_kcontext = C_INTPTR_T +! The other options for lua_kcontext are +! c_intptr_t, c_ptrdiff_t + +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_VERSION_NUM = 504 + +! Option for multiple returns in `lua_pcall()` and `lua_call()`. +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_MULTRET = -1 + +! Basic types. +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TNONE = -1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TNIL = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TBOOLEAN = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TLIGHTUSERDATA = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TNUMBER = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TSTRING = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TTABLE = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TFUNCTION = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TUSERDATA = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_TTHREAD = 8 + +! Comparison and arithmetic options. +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPADD = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPSUB = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPMUL = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPMOD = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPPOW = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPDIV = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPIDIV = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBAND = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBOR = 8 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBXOR = 9 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPSHL = 10 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPSHR = 11 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPUNM = 12 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPBNOT = 13 + +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPEQ = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPLT = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OPLE = 2 + +! Garbage-collection options. +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSTOP = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCRESTART = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCCOLLECT = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCCOUNT = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCCOUNTB = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSTEP = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSETPAUSE = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCSETSTEPMUL = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCISRUNNING = 9 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCGEN = 10 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_GCINC = 11 + +! Error codes. +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_OK = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_YIELD = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRRUN = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRSYNTAX = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRMEM = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRERR = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LUA_ERRFILE = LUA_ERRERR + 1 + +PUBLIC :: lua_checkerror +PUBLIC :: lua_arith +PUBLIC :: lua_call +PUBLIC :: lua_callk +PUBLIC :: lua_checkstack +PUBLIC :: lua_close +PUBLIC :: lua_compare +PUBLIC :: lua_concat +PUBLIC :: lua_copy +PUBLIC :: lua_createtable +PUBLIC :: lua_gc +PUBLIC :: lua_getfield +PUBLIC :: lua_getglobal +PUBLIC :: lua_gettable +PUBLIC :: lua_gettop +PUBLIC :: lua_isboolean +PUBLIC :: lua_iscfunction +PUBLIC :: lua_isfunction +PUBLIC :: lua_isinteger +PUBLIC :: lua_isnil +PUBLIC :: lua_isnone +PUBLIC :: lua_isnoneornil +PUBLIC :: lua_isnumber +PUBLIC :: lua_isstring +PUBLIC :: lua_istable +PUBLIC :: lua_isthread +PUBLIC :: lua_isuserdata +PUBLIC :: lua_isyieldable +PUBLIC :: lua_load +PUBLIC :: lua_newtable +PUBLIC :: lua_pcall +PUBLIC :: lua_pcallk +PUBLIC :: lua_pop +PUBLIC :: lua_pushboolean +PUBLIC :: lua_pushcclosure +PUBLIC :: lua_pushinteger +PUBLIC :: lua_pushlightuserdata +PUBLIC :: lua_pushlstring +PUBLIC :: lua_pushnil +PUBLIC :: lua_pushnumber +PUBLIC :: lua_pushstring +PUBLIC :: lua_pushthread +PUBLIC :: lua_pushvalue +PUBLIC :: lua_rawget +PUBLIC :: lua_rawgeti +PUBLIC :: lua_rawlen +PUBLIC :: lua_rawset +PUBLIC :: lua_rawseti +PUBLIC :: lua_register +PUBLIC :: lua_setfield +PUBLIC :: lua_setglobal +PUBLIC :: lua_seti +PUBLIC :: lua_settable +PUBLIC :: lua_settop +PUBLIC :: lua_status +PUBLIC :: lua_toboolean +PUBLIC :: lua_tointeger +PUBLIC :: lua_tointegerx +PUBLIC :: lua_tonumber +PUBLIC :: lua_tonumberx +PUBLIC :: lua_tostring +PUBLIC :: lua_type +PUBLIC :: lua_typename +PUBLIC :: lua_version +PUBLIC :: lual_checkversion_ +PUBLIC :: lual_dofile +PUBLIC :: lual_dostring +PUBLIC :: lual_len +PUBLIC :: lual_loadfile +PUBLIC :: lual_loadfilex +PUBLIC :: lual_loadstring +PUBLIC :: lual_newstate +PUBLIC :: lual_openlibs + +PRIVATE :: c_f_str_ptr + +!---------------------------------------------------------------------------- +! Strlen +!---------------------------------------------------------------------------- + +! Interfaces to libc. +INTERFACE + FUNCTION c_strlen(str) BIND(c, name='strlen') + IMPORT :: C_PTR, C_SIZE_T + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: str + INTEGER(kind=C_SIZE_T) :: c_strlen + END FUNCTION c_strlen +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_checkstack +!---------------------------------------------------------------------------- + +! Interfaces to Lua 5.4. +INTERFACE + ! int lua_checkstack(lua_State *L, int n) + FUNCTION lua_checkstack(l, n) BIND(c, name='lua_checkstack') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: n + INTEGER(kind=C_INT) :: lua_checkstack + END FUNCTION lua_checkstack +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_compare +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_compare(lua_State *L, int index1, int index2, int op) + FUNCTION lua_compare(l, index1, index2, op) BIND(c, name='lua_compare') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: index1 + INTEGER(kind=C_INT), INTENT(in), VALUE :: index2 + INTEGER(kind=C_INT), INTENT(in), VALUE :: op + INTEGER(kind=C_INT) :: lua_compare + END FUNCTION lua_compare +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_gc +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_gc(lua_State *L, int what, int data) + FUNCTION lua_gc(l, what, DATA) BIND(c, name='lua_gc') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: what + INTEGER(kind=C_INT), INTENT(in), VALUE :: DATA + INTEGER(kind=C_INT) :: lua_gc + END FUNCTION lua_gc +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_getfield +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_getfield(lua_State *L, int idx, const char *k) + FUNCTION lua_getfield_(l, idx, k) BIND(c, name='lua_getfield') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + CHARACTER(kind=C_CHAR), INTENT(in) :: k + INTEGER(kind=C_INT) :: lua_getfield_ + END FUNCTION lua_getfield_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_getglobal +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_getglobal(lua_State *L, const char *name) + FUNCTION lua_getglobal_(l, name) BIND(c, name='lua_getglobal') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + CHARACTER(kind=C_CHAR), INTENT(in) :: name + INTEGER(kind=C_INT) :: lua_getglobal_ + END FUNCTION lua_getglobal_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_gettable +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_gettable (lua_State *L, int idx) + FUNCTION lua_gettable(l, idx) BIND(c, name='lua_gettable') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_gettable + END FUNCTION lua_gettable +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_gettop +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_gettop(lua_State *L) + FUNCTION lua_gettop(l) BIND(c, name='lua_gettop') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT) :: lua_gettop + END FUNCTION lua_gettop +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_iscfunction +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_iscfunction(lua_State *L, int idx) + FUNCTION lua_iscfunction(l, idx) BIND(c, name='lua_iscfunction') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_iscfunction + END FUNCTION lua_iscfunction +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_isinteger +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_isinteger(lua_State *L, int idx) + FUNCTION lua_isinteger(l, idx) BIND(c, name='lua_isinteger') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_isinteger + END FUNCTION lua_isinteger +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_isnumber +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_isnumber(lua_State *L, int idx) + FUNCTION lua_isnumber(l, idx) BIND(c, name='lua_isnumber') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_isnumber + END FUNCTION lua_isnumber + +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_isstring +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_isstring(lua_State *L, int idx) + FUNCTION lua_isstring(l, idx) BIND(c, name='lua_isstring') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_isstring + END FUNCTION lua_isstring +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_isuserdata +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_isuserdata(lua_State *L, int idx) + FUNCTION lua_isuserdata(l, idx) BIND(c, name='lua_isuserdata') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_isuserdata + END FUNCTION lua_isuserdata +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_isyieldable +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_isyieldable(lua_State *L) + FUNCTION lua_isyieldable(l) BIND(c, name='lua_isyielable') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT) :: lua_isyieldable + END FUNCTION lua_isyieldable +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_load +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_load(lua_State *L, lua_Reader reader, void *data, const char *chunkname, const char *mode) + FUNCTION lua_load(l, reader, DATA, chunkname, mode) BIND(c, name='lua_load') + IMPORT :: C_CHAR, C_FUNPTR, C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + TYPE(C_FUNPTR), INTENT(in), VALUE :: reader + TYPE(C_PTR), INTENT(in), VALUE :: DATA + CHARACTER(kind=C_CHAR), INTENT(in) :: chunkname + CHARACTER(kind=C_CHAR), INTENT(in) :: mode + INTEGER(kind=C_INT) :: lua_load + END FUNCTION lua_load +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_rawget +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_rawget(lua_State *L, int idx) + FUNCTION lua_rawget(l, idx) BIND(c, name='lua_rawget') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_rawget + END FUNCTION lua_rawget +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_rawgeti +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_rawgeti(lua_State *L, int idx, lua_Integer n) + FUNCTION lua_rawgeti(l, idx, n) BIND(c, name='lua_rawgeti') + IMPORT :: C_INT, C_PTR, lua_integer + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=lua_integer), INTENT(in), VALUE :: n + INTEGER(kind=C_INT) :: lua_rawgeti + END FUNCTION lua_rawgeti +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_rawlen +!---------------------------------------------------------------------------- + +INTERFACE + ! size_t lua_rawlen(lua_State *L, int idx) + FUNCTION lua_rawlen(l, idx) BIND(c, name='lua_rawlen') + IMPORT :: C_INT, C_PTR, C_SIZE_T + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_SIZE_T) :: lua_rawlen + END FUNCTION lua_rawlen +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_status +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_status(lua_State *L) + FUNCTION lua_status(l) BIND(c, name='lua_status') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT) :: lua_status + END FUNCTION lua_status +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_toboolean +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_toboolean(lua_State *L, int idx) + FUNCTION lua_toboolean_(l, idx) BIND(c, name='lua_toboolean') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_toboolean_ + END FUNCTION lua_toboolean_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_tonumberx +!---------------------------------------------------------------------------- + +INTERFACE + ! float lua_tonumberx(lua_State *L, int idx, int *isnum) + FUNCTION lua_tonumberx(l, idx, isnum) BIND(c, name='lua_tonumberx') + IMPORT :: C_INT, C_PTR, lua_number + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + TYPE(C_PTR), INTENT(in), VALUE :: isnum + REAL(kind=lua_number) :: lua_tonumberx + END FUNCTION lua_tonumberx +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_tointegerx +!---------------------------------------------------------------------------- + +INTERFACE + ! lua_Integer lua_tointegerx(lua_State *L, int idx, int *isnum) + FUNCTION lua_tointegerx(l, idx, isnum) BIND(c, name='lua_tointegerx') + IMPORT :: C_INT, C_PTR, lua_integer + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + TYPE(C_PTR), INTENT(in), VALUE :: isnum + INTEGER(kind=lua_integer) :: lua_tointegerx + END FUNCTION lua_tointegerx + +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_tolstring +!---------------------------------------------------------------------------- + +INTERFACE + ! const char *lua_tolstring(lua_State *L, int idx, size_t *len) + FUNCTION lua_tolstring(l, idx, len) BIND(c, name='lua_tolstring') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + TYPE(C_PTR), INTENT(in), VALUE :: len + TYPE(C_PTR) :: lua_tolstring + END FUNCTION lua_tolstring +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_type +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_type(lua_State *L, int idx) + FUNCTION lua_type(l, idx) BIND(c, name='lua_type') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lua_type + END FUNCTION lua_type +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_typename +!---------------------------------------------------------------------------- + +INTERFACE + ! const char *lua_typename(lua_State *L, int tp) + FUNCTION lua_typename_(l, tp) BIND(c, name='lua_typename') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: tp + TYPE(C_PTR) :: lua_typename_ + END FUNCTION lua_typename_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pcallk +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_pcallk(lua_State *L, int nargs, int nresults, int errfunc, lua_KContext ctx, lua_KFunction k) + function lua_pcallk(l, nargs, nresults, errfunc, ctx, k) bind(c, name='lua_pcallk') + IMPORT :: C_FUNPTR, C_INT, C_PTR, lua_kcontext + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: nargs + INTEGER(kind=C_INT), INTENT(in), VALUE :: nresults + INTEGER(kind=C_INT), INTENT(in), VALUE :: errfunc + INTEGER(kind=lua_kcontext), INTENT(in), VALUE :: ctx + TYPE(C_FUNPTR), INTENT(in), VALUE :: k + INTEGER(kind=C_INT) :: lua_pcallk + END FUNCTION lua_pcallk +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushlstring +!---------------------------------------------------------------------------- + +INTERFACE + ! const char *lua_pushlstring(lua_State *L, const char *s, size_t len) + FUNCTION lua_pushlstring_(l, s, len) BIND(c, name='lua_pushlstring') + IMPORT :: C_CHAR, C_PTR, C_SIZE_T + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + CHARACTER(kind=C_CHAR), INTENT(in) :: s + INTEGER(kind=C_SIZE_T), INTENT(in), VALUE :: len + TYPE(C_PTR) :: lua_pushlstring_ + END FUNCTION lua_pushlstring_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushstring +!---------------------------------------------------------------------------- + +INTERFACE + ! const char *lua_pushstring(lua_State *L, const char *s) + FUNCTION lua_pushstring_(l, s) BIND(c, name='lua_pushstring') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + CHARACTER(kind=C_CHAR), INTENT(in) :: s + TYPE(C_PTR) :: lua_pushstring_ + END FUNCTION lua_pushstring_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushthread +!---------------------------------------------------------------------------- + +INTERFACE + ! int lua_pushthread(lua_State *L) + FUNCTION lua_pushthread(l) BIND(c, name='lua_pushthread') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT) :: lua_pushthread + END FUNCTION lua_pushthread +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_version +!---------------------------------------------------------------------------- + +INTERFACE + ! lua_Number lua_version(lua_State *L) + FUNCTION lua_version(l) BIND(c, name='lua_version') + IMPORT :: C_PTR, lua_number + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + REAL(kind=lua_number) :: lua_version + END FUNCTION lua_version +END INTERFACE + +!---------------------------------------------------------------------------- +! luaL_len +!---------------------------------------------------------------------------- + +INTERFACE + ! int luaL_len(lua_State *L, int idx) + FUNCTION lual_len(l, idx) BIND(c, name='luaL_len') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=C_INT) :: lual_len + END FUNCTION lual_len +END INTERFACE + +!---------------------------------------------------------------------------- +! lual_loadfilex +!---------------------------------------------------------------------------- + +INTERFACE + ! int luaL_loadfilex(lua_State *L, const char *filename, const char *mode) + FUNCTION lual_loadfilex(l, filename, mode) BIND(c, name='luaL_loadfilex') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + CHARACTER(kind=C_CHAR), INTENT(in) :: filename + TYPE(C_PTR), INTENT(in), VALUE :: mode + INTEGER(kind=C_INT) :: lual_loadfilex + END FUNCTION lual_loadfilex +END INTERFACE + +!---------------------------------------------------------------------------- +! lual_loadstring +!---------------------------------------------------------------------------- + +INTERFACE + ! int luaL_loadstring(lua_State *L, const char *s) + FUNCTION lual_loadstring_(l, s) BIND(c, name='luaL_loadstring') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + CHARACTER(kind=C_CHAR), INTENT(in) :: s + INTEGER(kind=C_INT) :: lual_loadstring_ + END FUNCTION lual_loadstring_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lual_newstate +!---------------------------------------------------------------------------- + +INTERFACE + ! lua_State *luaL_newstate(void) + FUNCTION lual_newstate() BIND(c, name='luaL_newstate') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR) :: lual_newstate + END FUNCTION lual_newstate +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_arith +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_arith(lua_State *L, int op) + SUBROUTINE lua_arith(l, op) BIND(c, name='lua_arith') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: op + END SUBROUTINE lua_arith +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_callk +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_callk(lua_State *L, int nargs, int nresults, lua_KContext ctx, lua_CFunction k) + SUBROUTINE lua_callk(l, nargs, nresults, ctx, k) BIND(c, name='lua_callk') + IMPORT :: C_FUNPTR, C_INT, C_PTR, lua_kcontext + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: nargs + INTEGER(kind=C_INT), INTENT(in), VALUE :: nresults + INTEGER(kind=lua_kcontext), INTENT(in), VALUE :: ctx + TYPE(C_FUNPTR), INTENT(in), VALUE :: k + END SUBROUTINE lua_callk +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_close +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_close(lua_State *L) + SUBROUTINE lua_close(l) BIND(c, name='lua_close') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + END SUBROUTINE lua_close + +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_concat +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_concat(lua_State *L, int n) + SUBROUTINE lua_concat(l, n) BIND(c, name='lua_concat') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: n + END SUBROUTINE lua_concat +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_copy(lua_State *L, int fromidx, int toidx) + SUBROUTINE lua_copy(l, fromidx, toidx) BIND(c, name='lua_copy') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: fromidx + INTEGER(kind=C_INT), INTENT(in), VALUE :: toidx + END SUBROUTINE lua_copy +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_createtable +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_createtable(lua_State *L, int narr, int nrec) + SUBROUTINE lua_createtable(l, narr, nrec) BIND(c, name='lua_createtable') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: narr + INTEGER(kind=C_INT), INTENT(in), VALUE :: nrec + END SUBROUTINE lua_createtable +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushboolean +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_pushboolean(lua_State *L, int b) + SUBROUTINE lua_pushboolean(l, b) BIND(c, name='lua_pushboolean') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: b + END SUBROUTINE lua_pushboolean +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushcclosure +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_pushcclosure(lua_State *L, lua_CFunction fn, int n) + SUBROUTINE lua_pushcclosure(l, fn, n) BIND(c, name='lua_pushcclosure') + IMPORT :: C_FUNPTR, C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + TYPE(C_FUNPTR), INTENT(in), VALUE :: fn + INTEGER(kind=C_INT), INTENT(in), VALUE :: n + END SUBROUTINE lua_pushcclosure +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushinteger +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_pushinteger(lua_State *L, lua_Integer n) + SUBROUTINE lua_pushinteger(l, n) BIND(c, name='lua_pushinteger') + IMPORT :: C_PTR, lua_integer + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=lua_integer), INTENT(in), VALUE :: n + END SUBROUTINE lua_pushinteger + +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushlightuserdata +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_pushlightuserdata(lua_State *L, void *p) + SUBROUTINE lua_pushlightuserdata(l, p) BIND(c, name='lua_pushlightuserdata') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + TYPE(C_PTR), INTENT(in), VALUE :: p + END SUBROUTINE lua_pushlightuserdata +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushnil +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_pushnil(lua_State *L) + SUBROUTINE lua_pushnil(l) BIND(c, name='lua_pushnil') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + END SUBROUTINE lua_pushnil +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushnumber +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_pushnumber(lua_State *L, lua_Number n) + SUBROUTINE lua_pushnumber(l, n) BIND(c, name='lua_pushnumber') + IMPORT :: C_PTR, lua_number + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + REAL(kind=lua_number), INTENT(in), VALUE :: n + END SUBROUTINE lua_pushnumber +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_pushvalue +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_pushvalue(lua_State *L, int idx) + SUBROUTINE lua_pushvalue(l, idx) BIND(c, name='lua_pushvalue') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + END SUBROUTINE lua_pushvalue +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_rawset +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_rawset(lua_State *L, int idx) + SUBROUTINE lua_rawset(l, idx) BIND(c, name='lua_rawset') + IMPORT :: C_INT, C_PTR, lua_integer + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + END SUBROUTINE lua_rawset +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_rawseti +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_rawseti(lua_State *L, int idx, lua_Integer n) + SUBROUTINE lua_rawseti(l, idx, n) BIND(c, name='lua_rawseti') + IMPORT :: C_INT, C_PTR, lua_integer + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=lua_integer), INTENT(in), VALUE :: n + END SUBROUTINE lua_rawseti +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_setfield +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_setfield(lua_State *L, int idx, const char *k) + SUBROUTINE lua_setfield_(l, idx, k) BIND(c, name='lua_setfield') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + CHARACTER(kind=C_CHAR), INTENT(in) :: k + END SUBROUTINE lua_setfield_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_setglobal +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_setglobal(lua_State *L, const char *name) + SUBROUTINE lua_setglobal_(l, name) BIND(c, name='lua_setglobal') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + CHARACTER(kind=C_CHAR), INTENT(in) :: name + END SUBROUTINE lua_setglobal_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_seti +!---------------------------------------------------------------------------- +INTERFACE + ! void lua_seti(lua_State *L, int idx, lua_Integer n) + SUBROUTINE lua_seti(l, idx, n) BIND(c, name='lua_seti') + IMPORT :: C_INT, C_PTR, lua_integer + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + INTEGER(kind=lua_integer), INTENT(in), VALUE :: n + END SUBROUTINE lua_seti +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_settable +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_settable(lua_State *L, int idx) + SUBROUTINE lua_settable(l, idx) BIND(c, name='lua_settable') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + END SUBROUTINE lua_settable +END INTERFACE + +!---------------------------------------------------------------------------- +! lua_settop +!---------------------------------------------------------------------------- + +INTERFACE + ! void lua_settop(lua_State *L, int idx) + SUBROUTINE lua_settop(l, idx) BIND(c, name='lua_settop') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + INTEGER(kind=C_INT), INTENT(in), VALUE :: idx + END SUBROUTINE lua_settop +END INTERFACE + +!---------------------------------------------------------------------------- +! lual_checkversion_ +!---------------------------------------------------------------------------- + +INTERFACE + ! void luaL_checkversion_(lua_State *L, lua_Number ver, size_t sz) + SUBROUTINE lual_checkversion_(l, ver, sz) BIND(c, name='luaL_checkversion_') + IMPORT :: C_PTR, C_SIZE_T, lua_number + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + REAL(kind=lua_number), INTENT(in), VALUE :: ver + INTEGER(kind=C_SIZE_T), INTENT(in), VALUE :: sz + END SUBROUTINE lual_checkversion_ +END INTERFACE + +!---------------------------------------------------------------------------- +! lual_openlibs +!---------------------------------------------------------------------------- + +INTERFACE + ! void luaL_openlibs(lua_State *L) + SUBROUTINE lual_openlibs(l) BIND(c, name='luaL_openlibs') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: l + END SUBROUTINE lual_openlibs +END INTERFACE + +!---------------------------------------------------------------------------- +! Constains +!---------------------------------------------------------------------------- + +CONTAINS + +!---------------------------------------------------------------------------- +! lua_checkerror +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-11-19 +! summary: Check error + +SUBROUTINE lua_checkerror(ierr, file, routine, lineNo, unitNo) + INTEGER(I4B), INTENT(IN) :: ierr + CHARACTER(*), INTENT(IN) :: file + CHARACTER(*), INTENT(IN) :: routine + INTEGER(I4B), INTENT(IN) :: lineNo + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitNo + + IF (ierr .NE. LUA_OK) THEN + CALL Display("ERROR while running lua code :", unitNo=unitNo) + CALL Display(file, "file :", unitNo=unitNo) + CALL Display(routine, "routine :", unitNo=unitNo) + CALL Display(lineNo, "line :", unitNo=unitNo) + END IF + ! SELECT CASE (ierr) + ! ! CASE (LUA_OK) + ! ! case(LUA_YIELD) + ! ! case(LUA_ERRRUN) + ! ! case(LUA_ERRSYNTAX) + ! ! case(LUA_ERRMEM) + ! ! case(LUA_ERRERR) + ! ! case(LUA_ERRFILE) + ! END SELECT +END SUBROUTINE lua_checkerror + +!---------------------------------------------------------------------------- +! lua_getfield +!---------------------------------------------------------------------------- + +! int lua_getfield(lua_State *L, int idx, const char *k) +FUNCTION lua_getfield(l, idx, k) + !! Wrapper for `lua_getfield_()` that null-terminates string `k`. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + CHARACTER(*), INTENT(in) :: k + INTEGER :: lua_getfield + + lua_getfield = lua_getfield_(l, idx, k//C_NULL_CHAR) +END FUNCTION lua_getfield + +!---------------------------------------------------------------------------- +! lua_getglobal +!---------------------------------------------------------------------------- + +! int lua_getglobal(lua_State *L, const char *name) +FUNCTION lua_getglobal(l, name) + !! Wrapper for `lua_getglobal_()` that null-terminates string `name`. + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: name + INTEGER :: lua_getglobal + + lua_getglobal = lua_getglobal_(l, name//C_NULL_CHAR) +END FUNCTION lua_getglobal + +!---------------------------------------------------------------------------- +! lua_isboolean +!---------------------------------------------------------------------------- + +! int lua_isboolean(lua_State *L, int index) +FUNCTION lua_isboolean(l, idx) + !! Macro replacement that returns whether the stack variable is + !! boolean. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_isboolean + + lua_isboolean = 0 + IF (lua_type(l, idx) == LUA_TBOOLEAN) lua_isboolean = 1 +END FUNCTION lua_isboolean + +!---------------------------------------------------------------------------- +! lua_isfunction +!---------------------------------------------------------------------------- + +! int lua_isfunction(lua_State *L, int index) +FUNCTION lua_isfunction(l, idx) + !! Macro replacement that returns whether the stack variable is a + !! function. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_isfunction + + lua_isfunction = 0 + IF (lua_type(l, idx) == LUA_TFUNCTION) lua_isfunction = 1 +END FUNCTION lua_isfunction + +!---------------------------------------------------------------------------- +! lua_islightuserdata +!---------------------------------------------------------------------------- + +! int lua_islightuserdata(lua_State *L, int index) +FUNCTION lua_islightuserdata(l, idx) + !! Macro replacement that returns whether the stack variable is + !! light user data. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_islightuserdata + + lua_islightuserdata = 0 + IF (lua_type(l, idx) == LUA_TLIGHTUSERDATA) lua_islightuserdata = 1 +END FUNCTION lua_islightuserdata + +!---------------------------------------------------------------------------- +! lua_islightuserdata +!---------------------------------------------------------------------------- + +! int lua_isnil(lua_State *L, int index) +FUNCTION lua_isnil(l, idx) + !! Macro replacement that returns whether the stack variable is + !! nil. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_isnil + + lua_isnil = 0 + IF (lua_type(l, idx) == LUA_TNIL) lua_isnil = 1 +END FUNCTION lua_isnil + +!---------------------------------------------------------------------------- +! lua_isnone +!---------------------------------------------------------------------------- + +! int lua_isnone(lua_State *L, int index) +FUNCTION lua_isnone(l, idx) + !! Macro replacement that returns whether the stack variable is + !! none. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_isnone + + lua_isnone = 0 + IF (lua_type(l, idx) == LUA_TNONE) lua_isnone = 1 +END FUNCTION lua_isnone + +!---------------------------------------------------------------------------- +! lua_isnoneornil +!---------------------------------------------------------------------------- + +! int lua_isnoneornil(lua_State *L, int index) +FUNCTION lua_isnoneornil(l, idx) + !! Macro replacement that returns whether the stack variable is + !! none or nil. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_isnoneornil + + lua_isnoneornil = 0 + IF (lua_type(l, idx) <= 0) lua_isnoneornil = 1 +END FUNCTION lua_isnoneornil + +!---------------------------------------------------------------------------- +! lua_istable +!---------------------------------------------------------------------------- + +! int lua_istable(lua_State *L, int index) +FUNCTION lua_istable(l, idx) + !! Macro replacement that returns whether the stack variable is a + !! table. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_istable + + lua_istable = 0 + IF (lua_type(l, idx) == LUA_TTABLE) lua_istable = 1 +END FUNCTION lua_istable + +!---------------------------------------------------------------------------- +! lua_isthread +!---------------------------------------------------------------------------- + +! int lua_isthread(lua_State *L, int index) +FUNCTION lua_isthread(l, idx) + !! Macro replacement that returns whether the stack variable is a + !! thread. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER :: lua_isthread + + lua_isthread = 0 + IF (lua_type(l, idx) == LUA_TTHREAD) lua_isthread = 1 +END FUNCTION lua_isthread + +!---------------------------------------------------------------------------- +! lua_pcall +!---------------------------------------------------------------------------- + +! int lua_pcall(lua_State *L, int nargs, int nresults, int msgh) +FUNCTION lua_pcall(l, nargs, nresults, errfunc) + !! Macro replacement that calls `lua_pcallk()`. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: nargs + INTEGER, INTENT(in) :: nresults + INTEGER, INTENT(in) :: errfunc + INTEGER :: lua_pcall + + lua_pcall = lua_pcallk(l, nargs, nresults, errfunc, & + & INT(0, kind=lua_kcontext), C_NULL_FUNPTR) +END FUNCTION lua_pcall + +!---------------------------------------------------------------------------- +! lua_tointeger +!---------------------------------------------------------------------------- + +! lua_Integer lua_tointeger(lua_State *l, int idx) +FUNCTION lua_tointeger(l, idx) + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + INTEGER(kind=lua_integer) :: lua_tointeger + + lua_tointeger = lua_tointegerx(l, idx, C_NULL_PTR) +END FUNCTION lua_tointeger + +!---------------------------------------------------------------------------- +! lua_toboolean +!---------------------------------------------------------------------------- + +! logical lua_toboolean(lua_State *L, int index) +FUNCTION lua_toboolean(l, idx) + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + LOGICAL :: lua_toboolean + + lua_toboolean = (lua_toboolean_(l, idx) /= 0) +END FUNCTION lua_toboolean + +!---------------------------------------------------------------------------- +! lua_tonumber +!---------------------------------------------------------------------------- + +! lua_Number lua_tonumber(lua_State *l, int idx) +FUNCTION lua_tonumber(l, idx) + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + REAL(kind=lua_number) :: lua_tonumber + + lua_tonumber = lua_tonumberx(l, idx, C_NULL_PTR) +END FUNCTION lua_tonumber + +!---------------------------------------------------------------------------- +! lua_tostring +!---------------------------------------------------------------------------- + +! const char *lua_tostring(lua_State *L, int index) +FUNCTION lua_tostring(l, i) + !! Wrapper that calls `lua_tolstring()` and converts the returned C + !! pointer to Fortran string. Returns an unallocated character on error. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: i + CHARACTER(:), ALLOCATABLE :: lua_tostring + TYPE(C_PTR) :: ptr + + ptr = lua_tolstring(l, i, C_NULL_PTR) + IF (.NOT. C_ASSOCIATED(ptr)) RETURN + CALL c_f_str_ptr(ptr, lua_tostring) +END FUNCTION lua_tostring + +!---------------------------------------------------------------------------- +! lua_typename +!---------------------------------------------------------------------------- + +! const char *lua_typename(lua_State *L, int tp) +FUNCTION lua_typename(l, tp) + !! Wrapper that calls `lua_typename_()` and converts the returned C + !! pointer to Fortran string. Returns an unallocated character on error. + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: tp + CHARACTER(:), ALLOCATABLE :: lua_typename + TYPE(C_PTR) :: ptr + + ptr = lua_typename_(l, tp) + IF (.NOT. C_ASSOCIATED(ptr)) RETURN + CALL c_f_str_ptr(ptr, lua_typename) +END FUNCTION lua_typename + +!---------------------------------------------------------------------------- +! lual_dofile +!---------------------------------------------------------------------------- + +! int luaL_dofile(lua_State *L, const char *filename) +FUNCTION lual_dofile(l, fn) + !! Macro replacement that calls `lual_loadfile()` and `lua_pcall()`. + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: fn + INTEGER :: lual_dofile + + lual_dofile = lual_loadfile(l, fn) + IF (lual_dofile == 0) lual_dofile = lua_pcall(l, 0, LUA_MULTRET, 0) +END FUNCTION lual_dofile + +!---------------------------------------------------------------------------- +! lual_dostring +!---------------------------------------------------------------------------- + +! int luaL_dostring(lua_State *L, const char *str) +FUNCTION lual_dostring(l, str) + !! Macro replacement that calls `lual_loadstring()` and `lua_pcall()`. + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: str + INTEGER :: lual_dostring + + lual_dostring = lual_loadstring(l, str) + IF (lual_dostring == 0) lual_dostring = lua_pcall(l, 0, LUA_MULTRET, 0) +END FUNCTION lual_dostring + +!---------------------------------------------------------------------------- +! luaL_loadfile +!---------------------------------------------------------------------------- + +! int luaL_loadfile(lua_State *L, const char *filename) +FUNCTION lual_loadfile(l, fn) + !! Macro replacement that calls `lual_loadfilex()`. + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: fn + INTEGER :: lual_loadfile + + lual_loadfile = lual_loadfilex(l, fn//C_NULL_CHAR, C_NULL_PTR) +END FUNCTION lual_loadfile + +!---------------------------------------------------------------------------- +! luaL_loadstring +!---------------------------------------------------------------------------- + +! int luaL_loadstring(lua_State *L, const char *s) +FUNCTION lual_loadstring(l, s) + !! Wrapper for `lual_loadstring()` that null-terminates the given + !! string. + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: s + INTEGER :: lual_loadstring + + lual_loadstring = lual_loadstring_(l, s//C_NULL_CHAR) +END FUNCTION lual_loadstring + +!---------------------------------------------------------------------------- +! lua_pushlstring +!---------------------------------------------------------------------------- + +! const char *lua_pushlstring(lua_State *L, const char *s, size_t len) +FUNCTION lua_pushlstring(l, s, len) + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: s + INTEGER(kind=C_SIZE_T), INTENT(in) :: len + TYPE(C_PTR) :: lua_pushlstring + + lua_pushlstring = lua_pushlstring_(l, s//C_NULL_CHAR, len) +END FUNCTION lua_pushlstring + +!---------------------------------------------------------------------------- +! lua_pushstring +!---------------------------------------------------------------------------- + +! const char *lua_pushstring(lua_State *L, const char *s) +FUNCTION lua_pushstring(l, s) + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: s + TYPE(C_PTR) :: lua_pushstring + + lua_pushstring = lua_pushstring_(l, s//C_NULL_CHAR) +END FUNCTION lua_pushstring + +!---------------------------------------------------------------------------- +! lua_call +!---------------------------------------------------------------------------- + +! void lua_call(lua_State *L, int nargs, int nresults) +SUBROUTINE lua_call(l, nargs, nresults) + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: nargs + INTEGER, INTENT(in) :: nresults + + CALL lua_callk(l, nargs, nresults, INT(0, kind=C_SIZE_T), C_NULL_FUNPTR) +END SUBROUTINE lua_call + +!---------------------------------------------------------------------------- +! lua_newtable +!---------------------------------------------------------------------------- +! void lua_newtable(lua_State *L) +SUBROUTINE lua_newtable(l) + TYPE(C_PTR), INTENT(in) :: l + + CALL lua_createtable(l, 0, 0) +END SUBROUTINE lua_newtable + +!---------------------------------------------------------------------------- +! lua_pop +!---------------------------------------------------------------------------- + +! void lua_pop(lua_State *l, int n) +SUBROUTINE lua_pop(l, n) + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: n + + CALL lua_settop(l, -n - 1) +END SUBROUTINE lua_pop + +!---------------------------------------------------------------------------- +! lua_pushcfunction +!---------------------------------------------------------------------------- + +! void lua_pushcfunction(lua_State *L, lua_CFunction f) +SUBROUTINE lua_pushcfunction(l, f) + TYPE(C_PTR), INTENT(in) :: l + TYPE(C_FUNPTR), INTENT(in) :: f + + CALL lua_pushcclosure(l, f, 0) +END SUBROUTINE lua_pushcfunction + +!---------------------------------------------------------------------------- +! lua_register +!---------------------------------------------------------------------------- + +! void lua_register(lua_State *L, const char *name, lua_CFunction f) +SUBROUTINE lua_register(l, n, f) + !! Macro replacement. + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(*), INTENT(in) :: n + TYPE(C_FUNPTR), INTENT(in) :: f + + CALL lua_pushcfunction(l, f) + CALL lua_setglobal_(l, n//C_NULL_CHAR) +END SUBROUTINE lua_register + +!---------------------------------------------------------------------------- +! lua_setfield +!---------------------------------------------------------------------------- + +! void lua_setfield(lua_State *L, int idx, const char *k) +SUBROUTINE lua_setfield(l, idx, k) + TYPE(C_PTR), INTENT(in) :: l + INTEGER, INTENT(in) :: idx + CHARACTER(*), INTENT(in) :: k + + CALL lua_setfield_(l, idx, k//C_NULL_CHAR) +END SUBROUTINE lua_setfield + +!---------------------------------------------------------------------------- +! lua_setglobal +!---------------------------------------------------------------------------- + +! int lua_getglobal(lua_State *L, const char *name) +SUBROUTINE lua_setglobal(l, name) + TYPE(C_PTR), INTENT(in) :: l + CHARACTER(kind=C_CHAR), INTENT(in) :: name + + CALL lua_setglobal_(l, name//C_NULL_CHAR) +END SUBROUTINE lua_setglobal + +!---------------------------------------------------------------------------- +! c_f_str_ptr +!---------------------------------------------------------------------------- + +SUBROUTINE c_f_str_ptr(c_str, f_str) + !! Copies a C string, passed as a C pointer, to a Fortran string. + TYPE(C_PTR), INTENT(in) :: c_str + CHARACTER(:), ALLOCATABLE, INTENT(out) :: f_str + + CHARACTER(kind=C_CHAR), POINTER :: ptrs(:) + INTEGER(kind=C_SIZE_T) :: i, sz + + copy_block: BLOCK + IF (.NOT. C_ASSOCIATED(c_str)) EXIT copy_block + sz = c_strlen(c_str) + IF (sz < 0) EXIT copy_block + CALL C_F_POINTER(c_str, ptrs, [sz]) + ALLOCATE (CHARACTER(sz) :: f_str) + + DO i = 1, sz + f_str(i:i) = ptrs(i) + END DO + + RETURN + END BLOCK copy_block + + IF (.NOT. ALLOCATED(f_str)) f_str = '' +END SUBROUTINE c_f_str_ptr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +END MODULE LuaInterface diff --git a/src/modules/LuaInterface/src/No_LuaInterface.F90 b/src/modules/LuaInterface/src/No_LuaInterface.F90 new file mode 100644 index 000000000..0daa661db --- /dev/null +++ b/src/modules/LuaInterface/src/No_LuaInterface.F90 @@ -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 +! + +! This module is used when we are not using Lua + +MODULE LuaInterface +END MODULE LuaInterface diff --git a/src/modules/Macro/vectorclass.inc b/src/modules/Macro/vectorclass.inc new file mode 100644 index 000000000..667ad99a3 --- /dev/null +++ b/src/modules/Macro/vectorclass.inc @@ -0,0 +1,46 @@ +#define _AXB_( a, x, b ) _AXB1_( a, x, b ) +#define _AXB1_( a, x, b ) a ## x ## b +#define _AX_( a, x ) _AX1_( a, x ) +#define _AX1_( a, x ) a ## x + +TYPE, EXTENDS( AbstractVector_ ) :: _AX_( _KIND_, Vector_ ) + _TYPE_ ( _KIND_ ), ALLOCATABLE :: Val( : ) +END TYPE + +PUBLIC :: _AX_( _KIND_, Vector_ ) + +TYPE( _AX_( _KIND_, Vector_ ) ), PUBLIC, PARAMETER :: _AXB_( Type, _KIND_, Vector ) = & + & _AX_( _KIND_, Vector_ )( tDimension = 1_I4B, Val = NULL( ) ) + +TYPE :: _AX_( _KIND_, VectorPointer ) + CLASS( _AX_( _KIND_, Vector_ ) ), POINTER :: Ptr => NULL( ) +END TYPE + +PUBLIC :: _AX_( _KIND_, VectorPointer ) + + +#undef _TYPE_ +#undef _KIND_ +#undef _AXB_ +#undef _AXB1_ +#undef _AX_ +#undef _AX1_ + + +!<-- example --->| +! to use this macro define _TYPE_ INTEGER +! define _KIND_ Int8 +! +! TYPE, EXTENDS( AbstractVector_ ) :: Int8Vector_ +! INTEGER( Int8 ), ALLOCATABLE :: Val( : ) +! END TYPE Int8Vector_ + +! PUBLIC :: Int8Vector_ + +! TYPE(Int8Vector_), PUBLIC, PARAMETER :: TypeInt8Vector = Int8Vector_( & +! tDimension = 1_I4B, Val = NULL( ) ) + +! TYPE :: Int8VectorPointer +! CLASS( Int8Vector_ ), POINTER :: Ptr => NULL( ) +! END TYPE Int8VectorPointer +!<-- example --->| \ No newline at end of file diff --git a/src/modules/MassMatrix/CMakeLists.txt b/src/modules/MassMatrix/CMakeLists.txt new file mode 100644 index 000000000..b4d7c4fd9 --- /dev/null +++ b/src/modules/MassMatrix/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}/MassMatrix_Method.F90 +) diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 new file mode 100644 index 000000000..c2b6ab317 --- /dev/null +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -0,0 +1,158 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE MassMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: MassMatrix +PUBLIC :: ViscousBoundaryMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> 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$$ +! + +INTERFACE MassMatrix + MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION MassMatrix_1 +END INTERFACE MassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE MassMatrix + MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) & + & 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 + TYPE(FEVariableScalar_), INTENT(IN) :: rhorank + !! Scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION MassMatrix_2 +END INTERFACE MassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE MassMatrix + MODULE PURE FUNCTION MassMatrix_3(test, trial, rho, rhorank, opt) & + & 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 + TYPE(FEVariableVector_), INTENT(IN) :: rhorank + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION MassMatrix_3 +END INTERFACE MassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE MassMatrix + MODULE PURE FUNCTION MassMatrix_4(test, trial, rho, rhorank) & + & 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 + TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank + !! Matrix + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION MassMatrix_4 +END INTERFACE MassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-01-15 +! summary: This subroutine makes mass matrix used for viscous boundary + +INTERFACE ViscousBoundaryMassMatrix + MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) & + & RESULT(ans) + 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION MassMatrix_5 +END INTERFACE ViscousBoundaryMassMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE MassMatrix_Method diff --git a/src/modules/MdEncode/CMakeLists.txt b/src/modules/MdEncode/CMakeLists.txt new file mode 100644 index 000000000..7ecdcfff8 --- /dev/null +++ b/src/modules/MdEncode/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}/MdEncode_Method.F90 +) diff --git a/src/modules/MdEncode/src/MdEncode_Method.F90 b/src/modules/MdEncode/src/MdEncode_Method.F90 new file mode 100644 index 000000000..8fb9f57eb --- /dev/null +++ b/src/modules/MdEncode/src/MdEncode_Method.F90 @@ -0,0 +1,427 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 MdEncode_Method +USE String_Class, ONLY: String +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: MdEncode +PUBLIC :: React_StartTabs +PUBLIC :: React_StartTabItem +PUBLIC :: React_EndTabs +PUBLIC :: React_EndTabItem + +CHARACTER(3), PARAMETER :: avert = " | " +CHARACTER(2), PARAMETER :: ivert = "| " +CHARACTER(2), PARAMETER :: evert = " |" +CHARACTER(1), PARAMETER :: abr = CHAR_LF +CHARACTER(1), PARAMETER :: ablank = CHAR_BLANK +CHARACTER(5), PARAMETER :: adash = " --- " + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +INTERFACE MdEncode + MODULE FUNCTION MdEncode_Int8(val) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_Int8 + + MODULE FUNCTION MdEncode_Int16(val) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_Int16 + + MODULE FUNCTION MdEncode_Int32(val) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_Int32 + + MODULE FUNCTION MdEncode_Int64(val) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_Int64 + + MODULE FUNCTION MdEncode_Real32(val) RESULT(ans) + REAL(REAL32), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_Real32 + + MODULE FUNCTION MdEncode_Real64(val) RESULT(ans) + REAL(REAL64), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_Real64 + + MODULE FUNCTION MdEncode_Char(val) RESULT(ans) + CHARACTER(*), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_Char + + MODULE FUNCTION MdEncode_String(val) RESULT(ans) + TYPE(String), INTENT(IN) :: val + TYPE(String) :: ans + END FUNCTION MdEncode_String +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +INTERFACE MdEncode + MODULE FUNCTION MdEncode2_Int8(val) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + TYPE(String) :: ans + END FUNCTION MdEncode2_Int8 + + MODULE FUNCTION MdEncode2_Int16(val) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + TYPE(String) :: ans + END FUNCTION MdEncode2_Int16 + + MODULE FUNCTION MdEncode2_Int32(val) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + TYPE(String) :: ans + END FUNCTION MdEncode2_Int32 + + MODULE FUNCTION MdEncode2_Int64(val) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + TYPE(String) :: ans + END FUNCTION MdEncode2_Int64 + + MODULE FUNCTION MdEncode2_Real32(val) RESULT(ans) + REAL(REAL32), INTENT(IN) :: val(:) + TYPE(String) :: ans + END FUNCTION MdEncode2_Real32 + + MODULE FUNCTION MdEncode2_Real64(val) RESULT(ans) + REAL(REAL64), INTENT(IN) :: val(:) + TYPE(String) :: ans + END FUNCTION MdEncode2_Real64 + + MODULE FUNCTION MdEncode2_String(val) RESULT(ans) + TYPE(String), INTENT(IN) :: val(:) + TYPE(String) :: ans + END FUNCTION MdEncode2_String +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +INTERFACE MdEncode + MODULE FUNCTION MdEncode3_Int8(val) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:, :) + TYPE(String) :: ans + END FUNCTION MdEncode3_Int8 + + MODULE FUNCTION MdEncode3_Int16(val) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:, :) + TYPE(String) :: ans + END FUNCTION MdEncode3_Int16 + + MODULE FUNCTION MdEncode3_Int32(val) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:, :) + TYPE(String) :: ans + END FUNCTION MdEncode3_Int32 + + MODULE FUNCTION MdEncode3_Int64(val) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:, :) + TYPE(String) :: ans + END FUNCTION MdEncode3_Int64 + + MODULE FUNCTION MdEncode3_Real32(val) RESULT(ans) + REAL(REAL32), INTENT(IN) :: val(:, :) + TYPE(String) :: ans + END FUNCTION MdEncode3_Real32 + + MODULE FUNCTION MdEncode3_Real64(val) RESULT(ans) + REAL(REAL64), INTENT(IN) :: val(:, :) + TYPE(String) :: ans + END FUNCTION MdEncode3_Real64 + + MODULE FUNCTION MdEncode3_String(val) RESULT(ans) + TYPE(String), INTENT(IN) :: val(:, :) + TYPE(String) :: ans + END FUNCTION MdEncode3_String +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +INTERFACE MdEncode + MODULE FUNCTION MdEncode4_Int8(val) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode4_Int8 + + MODULE FUNCTION MdEncode4_Int16(val) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode4_Int16 + + MODULE FUNCTION MdEncode4_Int32(val) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode4_Int32 + + MODULE FUNCTION MdEncode4_Int64(val) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode4_Int64 + + MODULE FUNCTION MdEncode4_Real32(val) RESULT(ans) + REAL(REAL32), INTENT(IN) :: val(:, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode4_Real32 + + MODULE FUNCTION MdEncode4_Real64(val) RESULT(ans) + REAL(REAL64), INTENT(IN) :: val(:, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode4_Real64 + + MODULE FUNCTION MdEncode4_String(val) RESULT(ans) + TYPE(String), INTENT(IN) :: val(:, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode4_String +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +INTERFACE MdEncode + MODULE FUNCTION MdEncode5_Int8(val) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:, :, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode5_Int8 + + MODULE FUNCTION MdEncode5_Int16(val) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:, :, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode5_Int16 + + MODULE FUNCTION MdEncode5_Int32(val) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:, :, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode5_Int32 + + MODULE FUNCTION MdEncode5_Int64(val) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:, :, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode5_Int64 + + MODULE FUNCTION MdEncode5_Real32(val) RESULT(ans) + REAL(REAL32), INTENT(IN) :: val(:, :, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode5_Real32 + + MODULE FUNCTION MdEncode5_Real64(val) RESULT(ans) + REAL(REAL64), INTENT(IN) :: val(:, :, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode5_Real64 + + MODULE FUNCTION MdEncode5_String(val) RESULT(ans) + TYPE(String), INTENT(IN) :: val(:, :, :, :) + TYPE(String) :: ans + END FUNCTION MdEncode5_String +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +INTERFACE MdEncode + MODULE FUNCTION MdEncode6_Int8(val, rh, ch) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode6_Int8 + + MODULE FUNCTION MdEncode6_Int16(val, rh, ch) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode6_Int16 + + MODULE FUNCTION MdEncode6_Int32(val, rh, ch) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode6_Int32 + + MODULE FUNCTION MdEncode6_Int64(val, rh, ch) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode6_Int64 + + MODULE FUNCTION MdEncode6_Real32(val, rh, ch) RESULT(ans) + REAL(REAL32), INTENT(IN) :: val(:) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode6_Real32 + + MODULE FUNCTION MdEncode6_Real64(val, rh, ch) RESULT(ans) + REAL(REAL64), INTENT(IN) :: val(:) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode6_Real64 + + MODULE FUNCTION MdEncode6_String(val, rh, ch) RESULT(ans) + TYPE(String), INTENT(IN) :: val(:) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode6_String +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +INTERFACE MdEncode + MODULE FUNCTION MdEncode7_Int8(val, rh, ch) RESULT(ans) + INTEGER(Int8), INTENT(IN) :: val(:, :) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode7_Int8 + + MODULE FUNCTION MdEncode7_Int16(val, rh, ch) RESULT(ans) + INTEGER(Int16), INTENT(IN) :: val(:, :) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode7_Int16 + + MODULE FUNCTION MdEncode7_Int32(val, rh, ch) RESULT(ans) + INTEGER(Int32), INTENT(IN) :: val(:, :) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode7_Int32 + + MODULE FUNCTION MdEncode7_Int64(val, rh, ch) RESULT(ans) + INTEGER(Int64), INTENT(IN) :: val(:, :) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode7_Int64 + + MODULE FUNCTION MdEncode7_Real32(val, rh, ch) RESULT(ans) + REAL(Real32) , INTENT(IN) :: val(:, :) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode7_Real32 + + MODULE FUNCTION MdEncode7_Real64(val, rh, ch) RESULT(ans) + REAL(Real64) , INTENT(IN) :: val(:, :) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode7_Real64 + + MODULE FUNCTION MdEncode7_String(val, rh, ch) RESULT(ans) + TYPE(String) , INTENT(IN) :: val(:, :) + TYPE(String), INTENT(IN) :: rh(:) + !! Row header + TYPE(String), INTENT(IN) :: ch(:) + !! Col header + TYPE(String) :: ans + END FUNCTION MdEncode7_String + +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! StartTabs +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION React_StartTabs() RESULT(ans) + TYPE(String) :: ans + END FUNCTION React_StartTabs +END INTERFACE + +!---------------------------------------------------------------------------- +! EndTabs +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION React_EndTabs() RESULT(ans) + TYPE(String) :: ans + END FUNCTION React_EndTabs +END INTERFACE + +!---------------------------------------------------------------------------- +! StartTabItem +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION React_StartTabItem(VALUE, label) RESULT(ans) + CHARACTER(*), INTENT(IN) :: VALUE + CHARACTER(*), INTENT(IN) :: label + TYPE(String) :: ans + END FUNCTION React_StartTabItem +END INTERFACE + +!---------------------------------------------------------------------------- +! EndTabItem +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION React_EndTabItem() RESULT(ans) + TYPE(String) :: ans + END FUNCTION React_EndTabItem +END INTERFACE + +END MODULE MdEncode_Method diff --git a/src/modules/MetisInterface/CMakeLists.txt b/src/modules/MetisInterface/CMakeLists.txt new file mode 100644 index 000000000..d5783acce --- /dev/null +++ b/src/modules/MetisInterface/CMakeLists.txt @@ -0,0 +1,25 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + + +IF(USE_METIS) + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/MetisInterface.F90 + ) +ENDIF() diff --git a/src/modules/MetisInterface/src/MetisInterface.F90 b/src/modules/MetisInterface/src/MetisInterface.F90 new file mode 100644 index 000000000..a30096b06 --- /dev/null +++ b/src/modules/MetisInterface/src/MetisInterface.F90 @@ -0,0 +1,650 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 MetisInterface +USE GlobalData +USE ISO_C_BINDING +USE CInterface +USE ErrorHandling +IMPLICIT NONE +PRIVATE +PUBLIC :: MetisSetDefaultOptions +PUBLIC :: MetisNodeND +PUBLIC :: METISPartGraphRecursive +PUBLIC :: METISPartGraphKway +PUBLIC :: METISPartMeshDual +PUBLIC :: METISPartMeshNodal +PUBLIC :: METISMeshToDual +PUBLIC :: METISMeshToNodal +#include "./MetisInterface.inc" +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE MetisSetDefaultOptions(Options) + INTEGER(I4B), INTENT(OUT) :: Options(:) + INTEGER(I4B) :: IERR + IERR = METIS_SetDefaultOptions(Options) + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error while setting default options", & + & File="MetisInterface.F90", & + & Routine="MetisSetDefaultOptions()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF +END SUBROUTINE MetisSetDefaultOptions + +!---------------------------------------------------------------------------- +! MetisNodeND +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Jul 2021 +! summary: This function computes fill reducing orderings of sparse matrices using the multilevel nested dissection algorithm. +! +!# Introduction +! +! This function computes fill reducing orderings of sparse matrices using the multilevel nested dissection algorithm. +! +! - Let $A$ be the original matrix and $A*$ be the permuted matrix. +! - The arrays `perm` and `iperm` are defined as follows. +! - Row (column) `i` of $A*$ is the `perm(i)` row (column) of $A$ +! - Row (column) `i` of $A$ is the `iperm(i)` row (column) of $A*$. +! - The numbering of this vector starts from either 0 or 1, depending on the value of `options(METIS_OPTION_NUMBERING)`. +! +! If the graph is weighted, meaning `vgwt` was provided, the nested dissection ordering computes vertex separators that minimize the sum of the weights of the vertices on the separators. +! +! GRAPH DATA STRUCTURE +! +! The adjacency structure of the graph is stored using the compressed storage format (CSR). The CSR format is a widely used scheme for storing sparse graphs. In this format the adjacency structure of a graph with n vertices and m edges is represented using two arrays xadj and adjncy. The xadj array is of size n + 1 whereas the adjncy array is of size 2m (this is because for each edge between vertices v and u we actually store both (v; u) and (u; v)) +! +! The adjacency structure of the graph is stored as follows. Assuming that vertex numbering starts from 0 (C style), then the adjacency list of vertex i is stored in array adjncy starting at index xadj[i] and ending at (but not including) index xadj[i + 1] (i.e., adjncy[xadj[i]] through and including adjncy[xadj[i + 1]-1]). That is, for each vertex i, its adjacency list is stored in consecutive locations in the array adjncy, and the array xadj is used to point to where it begins and where it ends. Figure 3(b) illustrates the CSR format for the 15-vertex graph shown in Figure 3(a) +! +! The weights of the vertices (if any) are stored in an additional array called vwgt. If ncon is the number of weights associated with each vertex, the array vwgt contains n ∗ ncon elements (recall that n is the number of vertices). The weights of the ith vertex are stored in ncon consecutive entries starting at location vwgt[i ∗ ncon]. Note that if each vertex has only a single weight, then vwgt will contain n elements, and vwgt[i] will store the weight of the ith vertex. The vertex-weights must be integers greater or equal to zero. If all the vertices of the graph have the same weight (i.e., the graph is unweighted), then the vwgt can be set to NULL. +! +! +!### Usage +! +!```fortran +! INTEGER( I4B ), PARAMETER :: n = 15 +! !! number of vertices +! INTEGER( I4B ), PARAMETER :: m = 22 +! !! number of edges +! INTEGER( I4B ) :: XADJ(n+1), ADJNCY(2*m) +! !! graph adjacency structure +! !! XADJ, ADJNCY +! INTEGER( I4B ) :: PERM(n), IPERM(n) +! !! fill-reducing permutation andinverse permutatio +! CALL Display( "TESTING METISNodeND" ) +! XADJ = [1,3,6,9,12,14,17,21,25,29,32,34,37,40,43,45] +! ADJNCY = [2,6,1,3,7,2,4,8,3,5,9,4,10,1,7,11,2,6, & +! & 8,12,3,7,9,13,4,8,10,14,5,9,15,6,12,7,11,13, & +! & 8,12,14,9,13,15,10,14] +! CALL METISNodeND(XADJ=XADJ, ADJNCY=ADJNCY, PERM=PERM, IPERM=IPERM ) +! CALL DISP( x=PERM, title= " PERM = " ) +! CALL DISP( x=IPERM, title= " IPERM = " ) +!``` + +SUBROUTINE MetisNodeND(XADJ, ADJNCY, PERM, IPERM, OPTIONS, VWGT) + INTEGER(I4B), INTENT(IN) :: XADJ(:) + INTEGER(I4B), INTENT(IN) :: ADJNCY(:) + INTEGER(I4B), INTENT(OUT) :: PERM(:) + INTEGER(I4B), INTENT(OUT) :: IPERM(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) + ! Internal variables + INTEGER(I4B) :: NVTXS, IERR + INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) + TYPE(C_PTR) :: C_OPTIONS, C_VWGT + ! + NVTXS = SIZE(PERM) + IF (PRESENT(OPTIONS)) THEN + C_OPTIONS = C_LOC(OPTIONS) + ELSE + IERR = METIS_SetDefaultOptions(OPT) + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error while setting default options", & + & File="MetisInterface.F90", & + & Routine="MetisNodeND()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT + C_OPTIONS = C_LOC(OPT) + END IF + + IF (PRESENT(VWGT)) THEN + C_VWGT = C_LOC(VWGT) + ELSE + C_VWGT = C_NULL_PTR + END IF + + IERR = METIS_NodeND(nvtxs=NVTXS, xadj=XADJ, adjncy=ADJNCY,& + & perm=PERM, iperm=IPERM, options=C_OPTIONS, vwgt=C_VWGT) + IF (ierr .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error in METIS_NodeND()", & + & File="MetisInterface.F90", & + & Routine="MetisNodeND()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + C_OPTIONS = C_NULL_PTR + C_VWGT = C_NULL_PTR +END SUBROUTINE MetisNodeND + +!---------------------------------------------------------------------------- +! METISPartGraphRecursive +!---------------------------------------------------------------------------- + +SUBROUTINE METISPartGraphRecursive(NCON, NPARTS, OBJVAL, PART, XADJ, & + & ADJNCY, OPTIONS, VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC) + INTEGER(I4B), INTENT(IN) :: NCON + INTEGER(I4B), INTENT(IN) :: NPARTS + INTEGER(I4B), INTENT(OUT) :: OBJVAL + INTEGER(I4B), INTENT(OUT) :: PART(:) + INTEGER(I4B), INTENT(IN) :: XADJ(:) + INTEGER(I4B), INTENT(IN) :: ADJNCY(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: ADJWGT(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: UBVEC(:) + ! Internal variables + INTEGER(I4B) :: NVTXS, IERR + INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) + TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_ADJWGT, C_TPWGTS, C_UBVEC + ! + NVTXS = SIZE(PART) + + IF (PRESENT(OPTIONS)) THEN + C_OPTIONS = C_LOC(OPTIONS) + ELSE + IERR = METIS_SetDefaultOptions(OPT) + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error while setting default options", & + & File="MetisInterface.F90", & + & Routine="METISPartGraphRecursive()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT + C_OPTIONS = C_LOC(OPT) + END IF + + IF (PRESENT(VWGT)) THEN + C_VWGT = C_LOC(VWGT) + ELSE + C_VWGT = C_NULL_PTR + END IF + + IF (PRESENT(VSIZE)) THEN + C_VSIZE = C_LOC(VSIZE) + ELSE + C_VSIZE = C_NULL_PTR + END IF + + IF (PRESENT(ADJWGT)) THEN + C_ADJWGT = C_LOC(ADJWGT) + ELSE + C_ADJWGT = C_NULL_PTR + END IF + + IF (PRESENT(TPWGTS)) THEN + C_TPWGTS = C_LOC(TPWGTS) + ELSE + C_TPWGTS = C_NULL_PTR + END IF + + IF (PRESENT(UBVEC)) THEN + C_UBVEC = C_LOC(UBVEC) + ELSE + C_UBVEC = C_NULL_PTR + END IF + + IERR = METIS_PartGraphRecursive(NCON=NCON, NVTXS=NVTXS, XADJ=XADJ,& + & ADJNCY=ADJNCY, NPARTS=NPARTS, OBJVAL=OBJVAL, PART=PART, & + & VWGT=C_VWGT, VSIZE=C_VSIZE, ADJWGT=C_ADJWGT, & + & TPWGTS=C_TPWGTS, UBVEC=C_UBVEC, OPTIONS=C_OPTIONS) + + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error in METIS_PartGraphRecursive()", & + & File="MetisInterface.F90", & + & Routine="METISPartGraphRecursive()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + C_VWGT = C_NULL_PTR + C_VSIZE = C_NULL_PTR + C_ADJWGT = C_NULL_PTR + C_TPWGTS = C_NULL_PTR + C_UBVEC = C_NULL_PTR + C_OPTIONS = C_NULL_PTR +END SUBROUTINE METISPartGraphRecursive + +!---------------------------------------------------------------------------- +! METISPartGraphKway +!---------------------------------------------------------------------------- + +SUBROUTINE METISPartGraphKway(NCON, NPARTS, OBJVAL, PART, XADJ, & + & ADJNCY, OPTIONS, VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC) + INTEGER(I4B), INTENT(IN) :: NCON + INTEGER(I4B), INTENT(IN) :: NPARTS + INTEGER(I4B), INTENT(OUT) :: OBJVAL + INTEGER(I4B), INTENT(OUT) :: PART(:) + INTEGER(I4B), INTENT(IN) :: XADJ(:) + INTEGER(I4B), INTENT(IN) :: ADJNCY(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: ADJWGT(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: UBVEC(:) + ! Internal variables + INTEGER(I4B) :: NVTXS, IERR + INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) + TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_ADJWGT, C_TPWGTS, C_UBVEC + ! + NVTXS = SIZE(PART) + + IF (PRESENT(OPTIONS)) THEN + C_OPTIONS = C_LOC(OPTIONS) + ELSE + IERR = METIS_SetDefaultOptions(OPT) + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error while setting default options", & + & File="MetisInterface.F90", & + & Routine="METISPartGraphKway()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT + C_OPTIONS = C_LOC(OPT) + END IF + + IF (PRESENT(VWGT)) THEN + C_VWGT = C_LOC(VWGT) + ELSE + C_VWGT = C_NULL_PTR + END IF + + IF (PRESENT(VSIZE)) THEN + C_VSIZE = C_LOC(VSIZE) + ELSE + C_VSIZE = C_NULL_PTR + END IF + + IF (PRESENT(ADJWGT)) THEN + C_ADJWGT = C_LOC(ADJWGT) + ELSE + C_ADJWGT = C_NULL_PTR + END IF + + IF (PRESENT(TPWGTS)) THEN + C_TPWGTS = C_LOC(TPWGTS) + ELSE + C_TPWGTS = C_NULL_PTR + END IF + + IF (PRESENT(UBVEC)) THEN + C_UBVEC = C_LOC(UBVEC) + ELSE + C_UBVEC = C_NULL_PTR + END IF + + IERR = METIS_PartGraphKway(NCON=NCON, NVTXS=NVTXS, XADJ=XADJ,& + & ADJNCY=ADJNCY, NPARTS=NPARTS, OBJVAL=OBJVAL, PART=PART, & + & VWGT=C_VWGT, VSIZE=C_VSIZE, ADJWGT=C_ADJWGT, & + & TPWGTS=C_TPWGTS, UBVEC=C_UBVEC, OPTIONS=C_OPTIONS) + + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error in METIS_PartGraphKway()", & + & File="MetisInterface.F90", & + & Routine="METISPartGraphKway()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + C_VWGT = C_NULL_PTR + C_VSIZE = C_NULL_PTR + C_ADJWGT = C_NULL_PTR + C_TPWGTS = C_NULL_PTR + C_UBVEC = C_NULL_PTR + C_OPTIONS = C_NULL_PTR +END SUBROUTINE METISPartGraphKway + +!---------------------------------------------------------------------------- +! METISPartMeshDual +!---------------------------------------------------------------------------- + +SUBROUTINE METISPartMeshDual(NCOMMON, NPARTS, OBJVAL, EPART, NPART, & + & EPTR, EIND, OPTIONS, VWGT, VSIZE, TPWGTS) + INTEGER(I4B), INTENT(IN) :: NCOMMON + INTEGER(I4B), INTENT(IN) :: NPARTS + INTEGER(I4B), INTENT(OUT) :: OBJVAL + INTEGER(I4B), INTENT(OUT) :: EPART(:) + INTEGER(I4B), INTENT(OUT) :: NPART(:) + INTEGER(I4B), INTENT(IN) :: EPTR(:) + INTEGER(I4B), INTENT(IN) :: EIND(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) + ! Internal variables + INTEGER(I4B) :: NE, NN, IERR + INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) + TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_TPWGTS + ! + NE = SIZE(EPART) + NN = SIZE(NPART) + + IF (PRESENT(OPTIONS)) THEN + C_OPTIONS = C_LOC(OPTIONS) + ELSE + IERR = METIS_SetDefaultOptions(OPT) + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error while setting default options", & + & File="MetisInterface.F90", & + & Routine="METISPartMeshDual()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT + C_OPTIONS = C_LOC(OPT) + END IF + + IF (PRESENT(VWGT)) THEN + C_VWGT = C_LOC(VWGT) + ELSE + C_VWGT = C_NULL_PTR + END IF + + IF (PRESENT(VSIZE)) THEN + C_VSIZE = C_LOC(VSIZE) + ELSE + C_VSIZE = C_NULL_PTR + END IF + + IF (PRESENT(TPWGTS)) THEN + C_TPWGTS = C_LOC(TPWGTS) + ELSE + C_TPWGTS = C_NULL_PTR + END IF + + IERR = METIS_PartMeshDual(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & + & VWGT=C_VWGT, VSIZE=C_VSIZE, NCOMMON=NCOMMON, NPARTS=NPARTS, & + & TPWGTS=C_TPWGTS, OPTIONS=C_OPTIONS, OBJVAL=OBJVAL, EPART=EPART, & + & NPART=NPART) + + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error in METIS_PartMeshDual()", & + & File="MetisInterface.F90", & + & Routine="METISPartMeshDual()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + C_VWGT = C_NULL_PTR + C_VSIZE = C_NULL_PTR + C_TPWGTS = C_NULL_PTR + C_OPTIONS = C_NULL_PTR +END SUBROUTINE METISPartMeshDual + +!---------------------------------------------------------------------------- +! METISPartMeshNodal +!---------------------------------------------------------------------------- + +SUBROUTINE METISPartMeshNodal(NPARTS, OBJVAL, EPART, NPART, & + & EPTR, EIND, OPTIONS, VWGT, VSIZE, TPWGTS) + INTEGER(I4B), INTENT(IN) :: NPARTS + INTEGER(I4B), INTENT(OUT) :: OBJVAL + INTEGER(I4B), INTENT(OUT) :: EPART(:) + INTEGER(I4B), INTENT(OUT) :: NPART(:) + INTEGER(I4B), INTENT(IN) :: EPTR(:) + INTEGER(I4B), INTENT(IN) :: EIND(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: OPTIONS(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VWGT(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: VSIZE(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: TPWGTS(:) + ! Internal variables + INTEGER(I4B) :: NE, NN, IERR + INTEGER(I4B), TARGET :: OPT(0:MAX_METIS_OPTIONS - 1) + TYPE(C_PTR) :: C_OPTIONS, C_VWGT, C_VSIZE, C_TPWGTS + ! + NE = SIZE(EPART) + NN = SIZE(NPART) + + IF (PRESENT(OPTIONS)) THEN + C_OPTIONS = C_LOC(OPTIONS) + ELSE + IERR = METIS_SetDefaultOptions(OPT) + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error while setting default options", & + & File="MetisInterface.F90", & + & Routine="METISPartMeshNodal()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + OPT(METIS_OPTION_NUMBERING) = METIS_NUMBERING_DEFAULT + C_OPTIONS = C_LOC(OPT) + END IF + + IF (PRESENT(VWGT)) THEN + C_VWGT = C_LOC(VWGT) + ELSE + C_VWGT = C_NULL_PTR + END IF + + IF (PRESENT(VSIZE)) THEN + C_VSIZE = C_LOC(VSIZE) + ELSE + C_VSIZE = C_NULL_PTR + END IF + + IF (PRESENT(TPWGTS)) THEN + C_TPWGTS = C_LOC(TPWGTS) + ELSE + C_TPWGTS = C_NULL_PTR + END IF + + IERR = METIS_PartMeshNodal(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & + & VWGT=C_VWGT, VSIZE=C_VSIZE, NPARTS=NPARTS, & + & TPWGTS=C_TPWGTS, OPTIONS=C_OPTIONS, OBJVAL=OBJVAL, EPART=EPART, & + & NPART=NPART) + + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error in METIS_PartMeshNodal()", & + & File="MetisInterface.F90", & + & Routine="METISPartMeshNodal()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + C_VWGT = C_NULL_PTR + C_VSIZE = C_NULL_PTR + C_TPWGTS = C_NULL_PTR + C_OPTIONS = C_NULL_PTR +END SUBROUTINE METISPartMeshNodal + +!---------------------------------------------------------------------------- +! METISMeshToDual +!---------------------------------------------------------------------------- + +SUBROUTINE METISMeshToDual(NE, NN, NCOMMON, EPTR, EIND, XADJ, ADJNCY, & + & NUMFLAG) + INTEGER(I4B), INTENT(IN) :: NE + INTEGER(I4B), INTENT(IN) :: NN + INTEGER(I4B), INTENT(IN) :: NCOMMON + INTEGER(I4B), INTENT(IN) :: EPTR(:) + INTEGER(I4B), INTENT(IN) :: EIND(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: XADJ(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: ADJNCY(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NUMFLAG + ! + INTEGER(I4B) :: NUM_FLAG, IERR + TYPE(C_PTR) :: C_XADJ, C_ADJNCY + INTEGER(I4B), POINTER :: F_XADJ(:), F_ADJNCY(:) + + IF (PRESENT(NUMFLAG)) THEN + NUM_FLAG = NUMFLAG + ELSE + NUM_FLAG = METIS_NUMBERING_FORTRAN + END IF + + IERR = METIS_MeshToDual(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & + & NCOMMON=NCOMMON, NUMFLAG=NUM_FLAG, XADJ=C_XADJ, ADJNCY=C_ADJNCY) + + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error in METIS_MeshToDual()", & + & File="MetisInterface.F90", & + & Routine="METISMeshToDual()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + IF (C_ASSOCIATED(C_XADJ)) THEN + CALL C_F_POINTER(CPTR=C_XADJ, FPTR=F_XADJ, shape=[NN + 1]) + XADJ = F_XADJ(1:NN + 1) + ELSE + CALL ErrorMSG( & + & Msg="XADJ IS NOT ASSOCIATED", & + & File="MetisInterface.F90", & + & Routine="METISMeshToDual()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + IF (C_ASSOCIATED(C_ADJNCY)) THEN + CALL C_F_POINTER(CPTR=C_ADJNCY, FPTR=F_ADJNCY, shape=[F_XADJ(nn + 1) - 1]) + ADJNCY = F_ADJNCY(1:F_XADJ(nn + 1) - 1) + ELSE + CALL ErrorMSG( & + & Msg="ADJNCY IS NOT ASSOCIATED", & + & File="MetisInterface.F90", & + & Routine="METISMeshToDual()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + ierr = METIS_FREE(C_ADJNCY) + ierr = METIS_FREE(C_XADJ) + NULLIFY (F_ADJNCY, F_XADJ) + +END SUBROUTINE METISMeshToDual + +!---------------------------------------------------------------------------- +! METISMeshToDual +!---------------------------------------------------------------------------- + +SUBROUTINE METISMeshToNodal(NE, NN, EPTR, EIND, XADJ, ADJNCY, & + & NUMFLAG) + INTEGER(I4B), INTENT(IN) :: NE + INTEGER(I4B), INTENT(IN) :: NN + INTEGER(I4B), INTENT(IN) :: EPTR(:) + INTEGER(I4B), INTENT(IN) :: EIND(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: XADJ(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: ADJNCY(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: NUMFLAG + ! + INTEGER(I4B) :: NUM_FLAG, IERR + TYPE(C_PTR) :: C_XADJ, C_ADJNCY + INTEGER(I4B), POINTER :: F_XADJ(:), F_ADJNCY(:) + + IF (PRESENT(NUMFLAG)) THEN + NUM_FLAG = NUMFLAG + ELSE + NUM_FLAG = METIS_NUMBERING_FORTRAN + END IF + + IERR = METIS_MeshToNodal(NE=NE, NN=NN, EPTR=EPTR, EIND=EIND, & + & NUMFLAG=NUM_FLAG, XADJ=C_XADJ, ADJNCY=C_ADJNCY) + + IF (IERR .NE. METIS_OK) THEN + CALL ErrorMSG( & + & Msg="Error in METIS_MeshToNodal()", & + & File="MetisInterface.F90", & + & Routine="METISMeshToNodal()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + IF (C_ASSOCIATED(C_XADJ)) THEN + CALL C_F_POINTER(CPTR=C_XADJ, FPTR=F_XADJ, shape=[NN + 1]) + XADJ = F_XADJ(1:NN + 1) + ELSE + CALL ErrorMSG( & + & Msg="XADJ IS NOT ASSOCIATED", & + & File="MetisInterface.F90", & + & Routine="METISMeshToNodal()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + IF (C_ASSOCIATED(C_ADJNCY)) THEN + CALL C_F_POINTER(CPTR=C_ADJNCY, FPTR=F_ADJNCY, shape=[F_XADJ(nn + 1) - 1]) + ADJNCY = F_ADJNCY(1:F_XADJ(nn + 1) - 1) + ELSE + CALL ErrorMSG( & + & Msg="ADJNCY IS NOT ASSOCIATED", & + & File="MetisInterface.F90", & + & Routine="METISMeshToNodal()", & + & Line=__LINE__, & + & UnitNo=stdout) + STOP + END IF + + ierr = METIS_FREE(C_ADJNCY) + ierr = METIS_FREE(C_XADJ) + NULLIFY (F_ADJNCY, F_XADJ) +END SUBROUTINE METISMeshToNodal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE MetisInterface diff --git a/src/modules/MetisInterface/src/MetisInterface.inc b/src/modules/MetisInterface/src/MetisInterface.inc new file mode 100644 index 000000000..c980aabe2 --- /dev/null +++ b/src/modules/MetisInterface/src/MetisInterface.inc @@ -0,0 +1,881 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _I_OUT_ INTEGER( C_INT ), INTENT( OUT ) +#define _I_IN_ INTEGER( C_INT ), INTENT( IN ) +#define _I_V_IN_ INTEGER( C_INT ), VALUE, INTENT( IN ) +#define _ST_V_IN_ INTEGER( C_SIZE_T ), VALUE, INTENT( IN ) +#define _ST_OUT_ INTEGER( C_SIZE_T ), INTENT( OUT ) +#define _ST_IN_ INTEGER( C_SIZE_T ), INTENT( IN ) +#define _R_V_IN_ REAL( C_DOUBLE ), VALUE, INTENT( IN ) +#define _R_IN_ REAL( C_DOUBLE ), INTENT( IN ) +#define _R_OUT_ REAL( C_DOUBLE ), INTENT( OUT ) +#define _CPTR_V_IN_ TYPE(C_PTR), VALUE, INTENT( IN ) +#define _CPTR_IN_ TYPE(C_PTR), INTENT( IN ) + + +INTEGER( I4B ), PARAMETER, PUBLIC :: MAX_METIS_OPTIONS = 40 + !! Maximum number of METSI OPTIONS + +! Return codes +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OK = 1 + !! Flag to indicate that there is no error +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_ERROR_INPUT = -2 + !! Flag to indicate that there is erro during input output +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_ERROR_MEMORY = -3 + !! Flag to indicate error due to the insufficient memory. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_ERROR = -4 + !! Flag to indicate undocumented error + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_PTYPE = 0 + !! It specifies the type of partitioning method; The possible values are + !! given below. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PTYPE_RB = 0 + !! Multilevel recursive bisectioning. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PTYPE_KWAY = 1 + !! Multilevel k-way partitioning. DEFAULT +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PTYPE_DEFAULT = METIS_PTYPE_KWAY + !! Default value of METIS_OPTION_PTYPE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_OBJTYPE = 1 + !! Specifies the objective type, two values are possible: Edge-cut, which + !! minimizes the communication time, and Total communication volume +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_CUT = 0 + !! Edge-cut minimization. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_VOL = 1 + !! Total communication volume minimization. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_NODE = 2 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OBJTYPE_DEFAULT = METIS_OBJTYPE_CUT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_CTYPE = 2 + !! Specifies the matching scheme to be used during coarsening. Possible + !! values are as follows: +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CTYPE_RM = 0 + !! Random matching. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CTYPE_SHEM = 1 + !! Sorted heavy-edge matching. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CTYPE_DEFAULT=METIS_CTYPE_RM + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_IPTYPE = 3 + !! Specify the algorithm used during the initial partitioning of the mesh +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_GROW = 0 + !! grows bisection using a greedy strategy. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_RANDOM = 1 + !! computes bisection at random followed by a refinement. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_EDGE = 2 + !! derives separator form an edge cut. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_NODE = 3 + !! grows bisection using a greedy node-based strategy. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_METISRB = 4 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_IPTYPE_DEFAULT=METIS_IPTYPE_GROW + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_RTYPE = 4 + !! Specify the algorithm used for refinement. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_FM = 0 + !! FM-basecut refinement. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_GREEDY = 1 + !!Greedy-based cut and volume refinement. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_SEP2SIDED = 2 + !! Two-sidenode FM refinement. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_RTYPE_SEP1SIDED = 3 + !! One-sidenode FM refinement. + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_DBGLVL = 5 + !! Specifies the amount of progress/debugging information will be printed during the execution of the algorithms. The default value is 0 (no debugging/progress information). A non-zero value can be supplied that is obtained by a bit-wise OR of the following values +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_INFO = 1 + !! Shows various diagnostic messages. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_TIME = 2 + !! Perform timing analysis. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_COARSEN = 4 + !! Shothe coarsening progress. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_REFINE = 8 + !! Shothe refinement progress. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_IPART = 16 + !! Shoinfo on initial partitioning. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_MOVEINFO = 32 + !! Shoinfo on vertex moves during refinement. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_SEPINFO = 64 + !! Shoinfo on vertex moves during sep refinement. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_CONNINFO = 128 + !! Shoinfo on minimization of subdomain connectivity. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_CONTIGINFO = 256 + !! Shoinfo on elimination of connected components. +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_DBG_MEMORY = 2048 + !! Shoinfo related to wspace allocation. + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NITER = 6 + !! Specifies the number of iterations for the refinement algorithm. + !! Default value is 10 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NITER_DEFAULT = 10 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NCUTS = 7 + !! Specifies the number of different partitionings that it will compute. The final partitioning is the one that achieves the best edgecut or communication volume. Default is 1 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NCUTS_DEFAULT=1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_SEED = 8 + !! Specifies the seed for the random number generator. + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NO2HOP = 9 + !! Specifies that the coarsening will not perform any 2–hop matchings when the standard matching approach fails to sufficiently coarsen the graph. The 2–hop matching is very effective for graphs with power-law degree distributions. + !! - 0 means perform 2-hop matching + !! - 1 means do not perform 2-hop matching + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_MINCONN = 10 + !! Specifies that the partitioning routines should try to minimize the maximum degree of the subdomain graph, i.e., the graph in which each partition is a node, and edges connect subdomains with a shared interface. + !! 0 Does not explicitly minimize the maximum connectivity + !! 1 explicitly minimize the maximum connectivity +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_MINCONN_DEFAULT = 0 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_CONTIG = 11 + !! Specifies that the partitioning routines should try to produce partitionsthat are contigous. If the input graph is not connected then this option is ignored + !! - 0 does not force contiguous partition + !! - 1 does force contingous partition +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CONTIG_DEFAULT = 0 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_COMPRESS = 12 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_COMPRESS_DEFAULT = 0 + !! Specifies that the graph should be compressed by combining togethervertices that have identical adjacency lists. + !! O- does not compress + !! 1 compress + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_CCORDER = 13 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_CCORDER_DEFAULT = 0 + !! Specifies if the connected components of the graph should first be identifies and ordered separately. + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_PFACTOR = 14 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_PFACTOR_DEFAULT = 0 + !! Specifies the minimum degree of the vertices that will be ordered last. + !! If the specified value is x > 0, then + !! any vertices with a degree greater than 0.1*x*(average degree) are removed from the graph, an ordering of + !! the rest of the vertices is computed, and an overall ordering is computed by ordering the removed vertices + !! at the end of the overall ordering. For example if x = 40, and the average degree is 5, then the algorithm + !! will remove all vertices with degree greater than 20. The vertices that are removed are ordered last (i.e., + !! they are automatically placed in the top-level separator). Good values are often in the range of 60 to 200 + !! (i.e., 6 to 20 times more than the average). Default value is 0, indicating that no vertices are removed. + !! Used to control whether or not the ordering algorithm should remove any vertices with high degree (i.e., + !! dense columns). This is particularly helpful for certain classes of LP matrices, in which there a few vertices + !! that are connected to many other vertices. By removing these vertices prior to ordering, the quality and the + !! amount of time required to do the ordering improves + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NSEPS = 15 + !! Specifies the number of different separators that it will compute at each level of nested dissection. The final separator that is used is the smallest one. Default is 1 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NSEPS_DEFAULT = 1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_UFACTOR = 16 + !! Specifies the maximum allowed load imbalance among the partitions. A + !! value of x indicates that the allowed load imbalance is (1 + x)=1000. + !! The load imbalance for the jth constraint is defined to be maxi(w[j; i]) + !! =t[j; i]), where w[j; i] is the fraction of the overall weight of the + !! jth constraint that is assigned to the ith partition and t[j; i] is the + !! desired target weight of the jth constraint for the ith partition (i.e., + !! that specified via -tpwgts). For -ptype=rb, the default value is 1 (i.e. + !! , load imbalance of 1.001) and for -ptype=kway, the default value is 30 + !! (i.e., load imbalance of 1.03). + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_OPTION_NUMBERING = 17 + !! Used to indicate which numbering scheme is used for the adjacency structure of a graph or the element-node structure of a mesh. + !! The possible values are 0 for C-style, and 1 for Fortran style +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NUMBERING_DEFAULT = 1 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NUMBERING_FORTRAN = 1 +INTEGER( I4B ), PARAMETER, PUBLIC :: METIS_NUMBERING_C = 0 + +!---------------------------------------------------------------------------- +! METIS_SetDefaultOptions +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2021 +! summary: Initializes the options array into its default values. +! +!# Introduction +! Initializes the options array into its default values. +! +!@note +! The passed array `options` must have the size `MAX_METIS_OPTIONS` (40). +! To be able to use the option parameters specified in the [[metis_interface]] module +! it is recommended to use zero-based indexing for the options array: +!```Fortran +!INTEGER( I4B ) :: opts(0:39) +!``` +!@endnote +! +! Other options can also be changed using parameters specified in the [[metis_interface]] module. + +INTERFACE +FUNCTION METIS_SetDefaultOptions(options) RESULT(ans) BIND(C,name="METIS_SetDefaultOptions") + IMPORT + INTEGER( I4B ), INTENT(OUT) :: options(MAX_METIS_OPTIONS) + !! The array of options that will be initialized. + INTEGER( I4B ) :: ans + !! `METIS_OK` - Indicates that the function returned normally. +END FUNCTION METIS_SetDefaultOptions +END INTERFACE + +PUBLIC :: METIS_SetDefaultOptions + +!---------------------------------------------------------------------------- +! METIS_NodeND +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2021 +! summary: This function computes fill reducing orderings of sparse matrices using the multilevel nested dissection algorithm. +! +!# Introduction +! This function computes fill reducing orderings of sparse matrices using the +! multilevel nested dissection algorithm. +! +! Let $A$ be the original matrix and $A*$ be the permuted matrix. +! The arrays `perm` and `iperm` are defined as follows. Row (column) `i` of $A*$ is the `perm(i)` row (column) of $A$, and row (column) `i` of $A$ is the `iperm(i)` row (column) of $A*$. +! The numbering of this vector starts from either 0 or 1, depending on the value of `options(METIS_OPTION_NUMBERING)`. +! +! If the graph is weighted, meaning `vgwt` was provided, the nested dissection ordering computes vertex separators that minimize the sum of the weights of the vertices on the separators. +! +! THE FOLLOWING OPTIONS ARE VALID: +! +! - `METIS_OPTION_CTYPE` +! - `METIS_OPTION_RTYPE` +! - `METIS_OPTION_NO2HOP` +! - `METIS_OPTION_NSEPS` +! - `METIS_OPTION_NITER` +! - `METIS_OPTION_UFACTOR` +! - `METIS_OPTION_COMPRESS` +! - `METIS_OPTION_CCORDER` +! - `METIS_OPTION_SEED` +! - `METIS_OPTION_PFACTOR` +! - `METIS_OPTION_NUMBERING` +! - `METIS_OPTION_DBGLVL` +! +! CInterface +! int METIS_NodeND(idx_t *nvtxs, idx_t *xadj, idx_t *adjncy, idx_t *vwgt, idx_t *options, idx_t *perm, idx_t *iperm) +! +! Optional argument : vwgt, options + +INTERFACE +FUNCTION METIS_NodeND( nvtxs, xadj, adjncy, vwgt, options, perm, iperm ) & + & RESULT( Ans ) BIND( C, NAME="METIS_NodeND" ) + IMPORT + INTEGER( I4B ), INTENT( IN ) :: nvtxs + !! The number of vertices in the graph. + INTEGER( I4B ), INTENT(IN) :: xadj(*), adjncy(*) + !! The adjacency structure of the graph as described in Section 5.5 of + !! the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE(C_PTR), VALUE, INTENT( IN ) :: vwgt + !! An array of size `nvtxs` specifying the weights of the vertices. + TYPE(C_PTR), VALUE, INTENT(IN) :: options !( MAX_METIS_OPTIONS ) + !! This is the array of options as described in Section 5.4 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). See description for valid options. + INTEGER( I4B ), INTENT( OUT ) :: perm(nvtxs), iperm(nvtxs) + !! These are vectors, each of size nvtxs. Upon successful completion, + !! they store the fill-reducing permutation and inverse-permutation. Let + !! A be the original matrix and $A*$ be the permuted matrix. + !! The arrays `perm` and `iperm` are defined as follows. + !! Row (or, column) $i$ of $A*$ is the `perm[i]` row (column) of A, + !! and row (column) $i$ of $A$ is the `iperm[i]` row (column) of A0. + !! The numbering of this vector starts from either 0 or 1, + !! depending on the value of options[METIS OPTION NUMBERING] + INTEGER( I4B ) :: ans + !! `METIS_OK` - Indicates that the function returned normally.
+ !! `METIS_ERROR_INPUT` - Indicates an input error.
+ !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory.
+ !! `METIS_ERROR` - Indicates some other type of error. +END FUNCTION METIS_NodeND +END INTERFACE + +PUBLIC :: METIS_NodeND + +!---------------------------------------------------------------------------- +! METIS_PartGraphRecursive +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2021 +! summary: this function is used to partition a graph into `nparts` +! parts using recursive bisection. +! +!# Introduction +! This function is used to partition a graph into `nparts` parts using +! recursive bisection. +! +! THE FOLLOWING OPTIONS ARE VALID: +! +! - `METIS_OPTION_CTYPE` +! - `METIS_OPTION_IPTYPE` +! - `METIS_OPTION_RTYPE` +! - `METIS_OPTION_NO2HOP` +! - `METIS_OPTION_NCUTS` +! - `METIS_OPTION_NITER` +! - `METIS_OPTION_SEED` +! - `METIS_OPTION_UFACTOR` +! - `METIS_OPTION_NUMBERING` +! - `METIS_OPTION_DBGLVL` +! +! OPTIONAL :: VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC, OPTIONS +! +! int_METIS_PartGraphRecursive(idx_t *nvtxs, idx_t *ncon, idx_t *xadj, idx_t ! *adjncy, idx_t *vwgt, idx_t *vsize, idx_t *adjwgt, idx_t *nparts, real_t *tpwgts, real_t *ubvec, idx_t *options, idx_t *objval, idx_t *part) + +INTERFACE +FUNCTION METIS_PartGraphRecursive( nvtxs, ncon, xadj, adjncy, & + & vwgt, vsize, adjwgt, nparts, tpwgts, ubvec, options, objval, part ) & + & RESULT( ans ) BIND(C, name="METIS_PartGraphRecursive") + IMPORT + INTEGER( I4B ), INTENT( IN ) :: nvtxs + !! The number of vertices in the graph. + INTEGER( I4B ), INTENT( IN ) :: ncon + !! The number of balancing constraints on each node. + !! It should be atleast 1. + INTEGER( I4B ), INTENT( IN ) :: xadj(*), adjncy(*) + !! The adjacency structure of the graph as described in + !! section 5.5 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE(C_PTR), VALUE, INTENT( IN ) :: vwgt + !! The weights of the vertices as described in Section 5.5 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE(C_PTR), VALUE, INTENT( IN ) :: vsize + !! The size of the vertices for computing the total communication volume + !! as described in section 5.7 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE(C_PTR), VALUE, INTENT( IN ) :: adjwgt + !! The weights of the edges as describe in Section 5.5 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + INTEGER( I4B ), INTENT(IN) :: nparts + !! The number of parts to partition the graph. + TYPE(C_PTR), VALUE, INTENT( IN ) :: tpwgts + !! This is an array pf size`nparts*ncon` that specifies the desired + !! weight for each partition and constraint. + !! The target partition weight for the ith partition and + !! jth constraint is specified at `tpwgts[i*ncon+j]`. + !! The numbering for both partition and constraints starts from 0. + !! For each constraint, the sum of the `tpwgts[]` entries must be 1.0. + !! If not present, the graph is divided equally among the partitions. + !! More in the description. + TYPE(C_PTR), VALUE, INTENT( IN ) :: ubvec + !! An array of size `ncon` that specifies the allowed load imbalance + !! for each constraint. + !! For the `i`-th partition and `j`-th constraint the allowed + !! weight is the `ubvec(j)*tpwgts(i*ncon+j)` + !! fraction of the `j`-th's constraint total weight. + !! If not present, the load imbalance + !! tolerance is 1.001 (for `ncon = 1`) or 1.01 (for `ncon > 1`). + TYPE(C_PTR), VALUE, INTENT( IN ) :: options + !! An array of options as described in Section 5.4 of the METIS manual. + !! See description for valid options. + INTEGER( I4B ), INTENT(OUT) :: objval + !! Upon successful completion, this variable stores the edge-cut or the + !! total communication volume of the partitioning + !! solution. The value returned depends on the partitioning's objective + !! function. + INTEGER( I4B ), INTENT(OUT) :: part(nvtxs) + !! This is a vector of size `nvtxs` that upon successful completion + !! stores the partition vector of the graph. + !! The numbering of this vector starts from either 0 or 1, + !! depending on the value of `options(METIS_OPTION_NUMBERING)`. + INTEGER( I4B ) :: ans + !! Error code + !! `METIS_OK` - Indicates that the function returned normally. + !! `METIS_ERROR_INPUT` - Indicates an input error. + !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. + !! `METIS_ERROR` - Indicates some other type of error. +END FUNCTION METIS_PartGraphRecursive +END INTERFACE + +PUBLIC :: METIS_PartGraphRecursive + +!---------------------------------------------------------------------------- +! METIS_PartGraphKway +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2021 +! summary: This function is used to partition a graph into `nparts` parts using multilevel k-way partitioning. +! +!# Introduction +! +! This function is used to partition a graph into `nparts` parts using multilevel k-way partitioning. +! +! THE FOLLOWING OPTIONS ARE VALID: +! - `METIS_OPTION_OBJTYPE` +! - `METIS_OPTION_CTYPE` +! - `METIS_OPTION_IPTYPE` +! - `METIS_OPTION_RTYPE` +! - `METIS_OPTION_NO2HOP` +! - `METIS_OPTION_NCUTS` +! - `METIS_OPTION_NITER` +! - `METIS_OPTION_UFACTOR` +! - `METIS_OPTION_MINCONN` +! - `METIS_OPTION_CONTIG` +! - `METIS_OPTION_SEED` +! - `METIS_OPTION_NUMBERING` +! - `METIS_OPTION_DBGLVL` +! +! OPTIONAL :: VWGT, VSIZE, ADJWGT, TPWGTS, UBVEC, OPTIONS +! +! int_METIS_PartGraphRecursive(idx_t *nvtxs, idx_t *ncon, idx_t *xadj, idx_t ! *adjncy, idx_t *vwgt, idx_t *vsize, idx_t *adjwgt, idx_t *nparts, real_t *tpwgts, real_t *ubvec, idx_t *options, idx_t *objval, idx_t *part) + +INTERFACE +FUNCTION METIS_PartGraphKway( nvtxs, ncon, xadj, adjncy, & + & vwgt, vsize, adjwgt, nparts, tpwgts, ubvec, options, objval, part ) & + & RESULT( Ans ) BIND( C, NAME="METIS_PartGraphKway" ) + IMPORT + + INTEGER( I4B ), INTENT(IN) :: nvtxs + !! The number of vertices in the graph. + INTEGER( I4B ), INTENT(IN) :: ncon + !! The number of balancing constraints on each node. + !! It should be atleast 1. + INTEGER( I4B ), INTENT(IN) :: xadj(*), adjncy(*) + !! The adjacency structure of the graph as described in + !! section 5.5 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE(C_PTR), VALUE, INTENT( IN ) :: vwgt + !! The weights of the vertices as described in Section 5.5 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE(C_PTR), VALUE, INTENT( IN ) :: vsize + !! The size of the vertices for computing the total communication volume + !! as described in section 5.7 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE(C_PTR), VALUE, INTENT( IN ) :: adjwgt + !! The weights of the edges as describe in Section 5.5 of the + !! [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + INTEGER( I4B ), INTENT(IN) :: nparts + !! The number of parts to partition the graph. + TYPE(C_PTR), VALUE, INTENT( IN ) :: tpwgts + !! This is an array pf size`nparts*ncon` that specifies the desired + !! weight for each partition and constraint. + !! The target partition weight for the ith partition and + !! jth constraint is specified at `tpwgts[i*ncon+j]`. + !! The numbering for both partition and constraints starts from 0. + !! For each constraint, the sum of the `tpwgts[]` entries must be 1.0. + !! If not present, the graph is divided equally among the partitions. + !! More in the description. + TYPE(C_PTR), VALUE, INTENT( IN ) :: ubvec + !! An array of size `ncon` that specifies the allowed load imbalance + !! for each constraint. + !! For the `i`-th partition and `j`-th constraint the allowed + !! weight is the `ubvec(j)*tpwgts(i*ncon+j)` + !! fraction of the `j`-th's constraint total weight. + !! If not present, the load imbalance + !! tolerance is 1.001 (for `ncon = 1`) or 1.01 (for `ncon > 1`). + TYPE(C_PTR), VALUE, INTENT( IN ) :: options + !! An array of options as described in Section 5.4 of the METIS manual. + !! See description for valid options. + INTEGER( I4B ), INTENT(OUT) :: objval + !! Upon successful completion, this variable stores the edge-cut or the + !! total communication volume of the partitioning + !! solution. The value returned depends on the partitioning's objective + !! function. + INTEGER( I4B ), INTENT(OUT) :: part(nvtxs) + !! This is a vector of size `nvtxs` that upon successful completion + !! stores the partition vector of the graph. + !! The numbering of this vector starts from either 0 or 1, + !! depending on the value of `options(METIS_OPTION_NUMBERING)`. + INTEGER( I4B ) :: ans + !! Error code + !! `METIS_OK` - Indicates that the function returned normally. + !! `METIS_ERROR_INPUT` - Indicates an input error. + !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. + !! `METIS_ERROR` - Indicates some other type of error. +END FUNCTION METIS_PartGraphKway +END INTERFACE + +PUBLIC :: METIS_PartGraphKway + +!---------------------------------------------------------------------------- +! METIS_PartMeshDual +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2021 +! summary: This function is used to partition a mesh into `nparts` parts based on a partitioning of the mesh's dual graph. +! +!# Introduction +! This function is used to partition a mesh into `nparts` parts based on a partitioning of the mesh's dual graph. +! +! This program first converts the mesh into either a dual graph (i.e., each element becomes a graph vertex) or a nodal graph (i.e., each node becomes a graph vertex), and then uses the graph partitioning API routines to partition this graph. METIS utilizes a flexible approach for creating a graph for a finite element mesh, which allows it to handle meshes with different and possibly mixed element types (e.g., triangles, tetrahedra, hexahedra, etc.). The functionality provided by mpmetis is achieved by the METIS PartMeshNodal and METIS PartMeshDual API routines +! +! THE FOLLOWING OPTIONS ARE VALID +! +! - `METIS_OPTION_PTYPE` +! - `METIS_OPTION_OBJTYPE` +! - `METIS_OPTION_CTYPE`, +! - `METIS_OPTION_IPTYPE` +! - `METIS_OPTION_RTYPE` +! - `METIS_OPTION_NCUTS`, +! - `METIS_OPTION_NITER` +! - `METIS_OPTION_SEED` +! - `METIS_OPTION_UFACTOR`, +! - `METIS_OPTION_NUMBERING` +! - `METIS_OPTION_DBGLVL` +! +! OPTIONAL : VWGT, VSIZE, TPWGTS, OPTIONS +! +! MESH DATA STRUCTURE +! +! All of the mesh partitioning and mesh conversion routines in METIS take as input the element node array of a mesh. This element node array is stored using a pair of arrays called eptr and eind, which are similar to the xadj and adjncy arrays used for storing the adjacency structure of a graph. The size of the eptr array is n+ 1, where n is the number of elements in the mesh. The size of the eind array is of size equal to the sum of the number of nodes in all the elements of the mesh. The list of nodes belonging to the ith element of the mesh are stored in consecutive locations of eind starting at position eptr[i] up to (but not including) position eptr[i+1]. This format makes it easy to specify meshes of any type of elements, including meshes with mixed element types that have different number of nodes per element. As it was the case with the format of the mesh file described in Section 4.1.2, the ordering of the nodes in each element is not important + +INTERFACE +FUNCTION METIS_PartMeshDual ( ne,nn,eptr,eind,vwgt,vsize,ncommon, & + & nparts,tpwgts,options,objval,epart,npart ) & + & RESULT( Ans ) BIND(C, NAME="METIS_PartMeshDual") + IMPORT + + INTEGER( I4B ), INTENT(IN) :: ne + !! The number of elements in the mesh. + INTEGER( I4B ), INTENT(IN) :: nn + !! The number of nodes in the mesh. + INTEGER( I4B ), INTENT(IN) :: eptr( * ), eind( * ) + !! The pair of arrays storing the mesh as described in Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE( C_PTR ), VALUE, INTENT(IN) :: vwgt + !! An array of size `ne` specifying the weights of the elements. If not present, all elements have an equal weight. + TYPE( C_PTR ), VALUE, INTENT(IN) :: vsize + !! An array of size `ne` specifying the size of the elements that is used + !! for computing the total comunication volume as described in Section 5.7 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + !! If not present, the objective is cut or all elements have an equal size. + INTEGER( I4B ), INTENT(IN) :: ncommon + !! Specifies the number of common nodes that two elements must have in order to put an edge between them in the dual graph. Given two elements e1 and e2, containing n1 and n2 nodes, respectively, then an edge will connect the vertices in the dual graph corresponding to e1 and e2 if the number of common nodes between them is greater than or equal to min(ncommon; n1 − 1; n2 − 1). The default value is 1, indicating that two elements will be connected via an edge as long as they share one node. However, this will tend to create too many edges (increasing the memory and time requirements of the partitioning). The user should select higher values that are better suited for the element types of the mesh that wants to partition. For example, for tetrahedron meshes, ncommon should be 3, which creates an edge between two tets when they share a triangular face (i.e., 3 nodes) + INTEGER( I4B ), INTENT(IN) :: nparts + !! The number of parts to partition the mesh. + TYPE( C_PTR ), VALUE, INTENT(IN) :: tpwgts + !! An array of size `nparts` that specifies the desired weight for each partition. The *target partition weight* for the `i`-th partition is specified at `tpwgts(i)` (the numbering for the + !! partitions starts from 0). The sum of the `tpwgts` entries must be 1.0. + !! If not present, the graph is divided equally among the partitions. + TYPE( C_PTR ), VALUE, INTENT(IN) :: options + !! An array of options as described in Section 5.4 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). See description for valid options. + INTEGER( I4B ), INTENT(OUT) :: objval + !! Upon successful completion, this variable stores either the edgecut or the total communication + !! volume of the dual graph's partitioning. + INTEGER( I4B ), INTENT(OUT) :: epart(ne) + !! A vector of size `ne` that upon successful completion stores the partition vector for the elements + !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of + !! `options(METIS_OPTION_NUMBERING)`. + INTEGER( I4B ), INTENT(OUT) :: npart(nn) + !! A vector of size `nn` that upon successful completion stores the partition vector for the nodes + !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of + !! `options(METIS_OPTION_NUMBERING)`. + INTEGER( I4B ) :: ans + !! `METIS_OK` - Indicates that the function returned normally.
+ !! `METIS_ERROR_INPUT` - Indicates an input error.
+ !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory.
+ !! `METIS_ERROR` - Indicates some other type of error. +END FUNCTION METIS_PartMeshDual +END INTERFACE + +PUBLIC :: METIS_PartMeshDual + +!---------------------------------------------------------------------------- +! METIS_PartMeshNodal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 July 2021 +! summary: This function us used to partition a mesh into `nparts` parts based on a partitioning of the mesh's nodal graph. +! +!# Introduction +! This function us used to partition a mesh into `nparts` parts based on a +! partitioning of the mesh's nodal graph. +! +! THE FOLLOWING OPTIONS ARE VALID: +! - `METIS_OPTION_PTYPE` +! - `METIS_OPTION_OBJTYPE` +! - `METIS_OPTION_CTYPE` +! - `METIS_OPTION_IPTYPE` +! - `METIS_OPTION_RTYPE` +! - `METIS_OPTION_NCUTS`, +! - `METIS_OPTION_NITER` +! - `METIS_OPTION_SEED` +! - `METIS_OPTION_UFACTOR`, +! - `METIS_OPTION_NUMBERING` +! - `METIS_OPTION_DBGLVL` +! +! +! MESH DATA STRUCTURE +! +! All of the mesh partitioning and mesh conversion routines in METIS take as input the element node array of a mesh. This element node array is stored using a pair of arrays called eptr and eind, which are similar to the xadj and adjncy arrays used for storing the adjacency structure of a graph. The size of the eptr array is n+ 1, where n is the number of elements in the mesh. The size of the eind array is of size equal to the sum of the number of nodes in all the elements of the mesh. The list of nodes belonging to the ith element of the mesh are stored in consecutive locations of eind starting at position eptr[i] up to (but not including) position eptr[i+1]. This format makes it easy to specify meshes of any type of elements, including meshes with mixed element types that have different number of nodes per element. As it was the case with the format of the mesh file described in Section 4.1.2, the ordering of the nodes in each element is not important + +INTERFACE +FUNCTION METIS_PartMeshNodal( ne, nn, eptr, eind, vwgt, vsize, & + & nparts, tpwgts, options, objval, epart, npart ) & + & RESULT( Ans ) BIND( C, NAME="METIS_PartMeshNodal" ) + IMPORT + + INTEGER( I4B ), INTENT(IN) :: ne + !! The number of elements in the mesh. + INTEGER( I4B ), INTENT(IN) :: nn + !! The number of nodes in the mesh. + INTEGER( I4B ), INTENT(IN) :: eptr( * ), eind( * ) + !! The pair of arrays storing the mesh as described in Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + TYPE( C_PTR ), VALUE, INTENT( IN ) :: vwgt + !! An array of size `nn` specifying weights of the nodes. If not passed, all nodes have an equal weight. + TYPE( C_PTR ), VALUE, INTENT( IN ) :: vsize + !! An array of size `nn` specifying the size of the nodes that is used for computing the + !! total comunication volume as described in Section 5.7 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). If not passed, + !! the objective is cut or all nodes have an equal size. + INTEGER( I4B ), INTENT(IN) :: nparts + !! The number of parts to partition the mesh. + TYPE( C_PTR ), VALUE, INTENT( IN ) :: tpwgts + !! An array of size `nparts` that specifies the desired weight for each partition. The *target + !! partition weight* for the `i`-th partition is specified at `tpwgts(i)` (the numbering for the + !! partitions starts from 0). The sum of the `tpwgts` entries must be 1.0. If not passed, the graph + !! is divided equally among the partitions. + TYPE( C_PTR ), VALUE, INTENT( IN ) :: options + !! An array of options as described in Section 5.4 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). See description for valid options. + INTEGER( I4B ), INTENT(OUT) :: objval + !! Upon successful completion, this variable stores either the edgecut or the total communication + !! volume of the nodal graph's partitioning. + INTEGER( I4B ), INTENT(OUT) :: epart(ne) + !! A vector of size `ne` that upon successful completion stores the partition vector for the elements + !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of + !! `options(METIS_OPTION_NUMBERING)`. + INTEGER( I4B ), INTENT(OUT) :: npart(nn) + !! A vector of size `nn` that upon successful completion stores the partition vector for the nodes + !! of the mesh. The numbering of this vector starts from either 0 or 1, depending on the value of + !! `options(METIS_OPTION_NUMBERING)`. + INTEGER( I4B ) :: ans + !! `METIS_OK` - Indicates that the function returned normally. + !! `METIS_ERROR_INPUT` - Indicates an input error. + !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. + !! `METIS_ERROR` - Indicates some other type of error. +END FUNCTION METIS_PartMeshNodal +END INTERFACE + +PUBLIC :: METIS_PartMeshNodal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2021 +! summary: This function is used to generate the dual graph of a mesh. +! +!# Introduction +! This function is used to generate the dual graph of a mesh. +! +!@note +! To use the returned arrays `xadj` and `adjncy`, these must be first converted from +! a C pointer to a Fortran pointer using the subroutine `c_f_pointer(cptr,fptr,shape)` +! that assigns the target of the C pointer `cptr` to the Fortran pointer `fptr` and +! specifies its shape. The `shape` is an integer rank-one array, storing the size `ne+1` +! in case of the dual graph. The size of the new `adjncy` array is stored in the +! last element of `xadj` when using C-style numbering. An example is shown below. +!@endnote +! +!@warning +! Memory for the returned arrays `xadj` and `adjncy` is allocated by METIS' API in C +! using the standard `malloc` function. It is the responsibility of the application to free +! this memory by calling `free`. Therefore, METIS provides the [[METIS_Free]] function that is a wrapper to +! C's `free`function. +!@endwarning +! +! int METIS MeshToDual(idx t *ne, idx t *nn, idx t *eptr, idx t *eind, idx t *ncommon, idx t *numflag, idx t **xadj, idx t **adjncy) +! + + +INTERFACE +FUNCTION METIS_MeshToDual( ne, nn, eptr, eind, ncommon, numflag, xadj, & + & adjncy) RESULT(Ans) BIND(C,NAME="METIS_MeshToDual") + IMPORT + + INTEGER( I4B ), INTENT(IN) :: ne + !! The number of elements in the mesh. + INTEGER( I4B ), INTENT(IN) :: nn + !! The number of nodes in the mesh. + INTEGER( I4B ), INTENT(IN) :: eptr( * ), eind( * ) + !! The pair of arrays storing the mesh as described in + !! Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + INTEGER( I4B ), INTENT(IN) :: ncommon + !! Specifies the number of common nodes that two elements must have in order to put an edge between them in the dual graph. Given two elements e1 and e2, containing n1 and n2 nodes, respectively, then an edge will connect the vertices in the dual graph corresponding to e1 and e2 if the number of common nodes between them is greater than or equal to min(ncommon; n1 − 1; n2 − 1). The default value is 1, indicating that two elements will be connected via an edge as long as they share one node. However, this will tend to create too many edges (increasing the memory and time requirements of the partitioning). The user should select higher values that are better suited for the element types of the mesh that wants to partition. For example, for tetrahedron meshes, ncommon should be 3, which creates an edge between two tets when they share a triangular face (i.e., 3 nodes) + INTEGER( I4B ), INTENT(IN) :: numflag + !! Used to indicate which numbering scheme is used for `eptr` and `eind`. + !! The possible values are:
+ !! 0 - C-style numbering is assumed that starts from 0
+ !! 1 - Fortran-style numbering is assumed that starts from 1 + TYPE(C_PTR), INTENT(OUT) :: xadj, adjncy + !! These arrays store the adjacency structure of the generated dual graph. The format of the adjacency structure is described in Section 5.5 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). Memory for these arrays is allocated by METIS’ API using the standard malloc function. It is the responsibility of the application to free this memory by calling free. METIS provides the METIS Free that is a wrapper to C’s free function. + INTEGER( I4B ) :: Ans + !! `METIS_OK` - Indicates that the function returned normally.
+ !! `METIS_ERROR_INPUT` - Indicates an input error.
+ !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory.
+ !! `METIS_ERROR` - Indicates some other type of error. +END FUNCTION METIS_MeshToDual +END INTERFACE + +PUBLIC :: METIS_MeshToDual + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2021 +! summary: This function is used to generate the nodal graph of a mesh. +! +!# Introduction +! This function is used to generate the nodal graph of a mesh. +! +!@note +! To use the returned arrays `xadj` and `adjncy`, these must be first converted from +! a C pointer to a Fortran pointer using the subroutine `c_f_pointer(cptr,fptr,shape)` +! that assigns the target of the C pointer `cptr` to the Fortran pointer `fptr` and +! specifies its shape. The `shape` is an integer rank-one array, storing the size `nn+1` +! in case of the nodal graph. The size of the new `adjncy` array is stored in the +! last element of `xadj` when using C-style numbering. An example is shown below. +!@endnote +! +!@warning +! Memory for the returned arrays `xadj` and `adjncy` is allocated by METIS' API in C +! using the standard `malloc` function. It is the responsibility of the application to free +! this memory by calling `free`. Therefore, METIS provides the [[METIS_Free]] function that is a wrapper to +! C's `free`function. +!@endwarning + +INTERFACE +FUNCTION METIS_MeshToNodal(ne,nn,eptr,eind,numflag,xadj,adjncy) & + & RESULT(Ans) BIND(C,name="METIS_MeshToNodal") + IMPORT + + INTEGER( I4B ), INTENT(IN) :: ne + !! The number of elements in the mesh. + INTEGER( I4B ), INTENT(IN) :: nn + !! The number of nodes in the mesh. + INTEGER( I4B ), INTENT(IN) :: eptr(*), eind(*) + !! The pair of arrays storing the mesh as described in Section 5.6 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). + INTEGER( I4B ), INTENT(IN) :: numflag + !! Used to indicate which numbering scheme is used for `eptr` and `eind`. + !! The possible values are: + !! 0 - C-style numbering is assumed that starts from 0 + !! 1 - Fortran-style numbering is assumed that starts from 1 + TYPE( C_PTR ), INTENT(OUT) :: xadj, adjncy + !! These arrays store the adjacency structure of the generated dual graph. The format of the adjacency structure is described in Section 5.5 of the [manual](http://glaros.dtc.umn.edu/gkhome/fetch/sw/metis/manual.pdf). Memory for these arrays is allocated by METIS’ API using the standard malloc function. It is the responsibility of the application to free this memory by calling free. METIS provides the METIS Free that is a wrapper to C’s free function. + INTEGER( I4B ) :: ans + !! `METIS_OK` - Indicates that the function returned normally. + !! `METIS_ERROR_INPUT` - Indicates an input error. + !! `METIS_ERROR_MEMORY` - Indicates that it could not allocate the required memory. + !! `METIS_ERROR` - Indicates some other type of error. +END FUNCTION METIS_MeshToNodal +END INTERFACE + +PUBLIC :: METIS_MeshToNodal + +!---------------------------------------------------------------------------- +! METIS_Free +!---------------------------------------------------------------------------- + +!> Frees the memory that was allocated by either the [[METIS_MeshToDual]] or the +! [[METIS_MeshToNodal]] routines for returning the dual or nodal graph of a mesh. +! +!@warning Memory deallocation should always happen on the same side it was allocated! +! Also check the descriptions of the above-mentioned routines. +! +!# Example +! +!```Fortran +! type(c_ptr) :: xadj(:),adjncy(:) +! +! call METIS_MeshToNodal(...,xadj,adjncy) +! +! ! xadj and adjncy should be deallocated on the C side! ;) +! call METIS_Free(xadj) +! call METIS_Free(adjncy) +!``` + +INTERFACE +FUNCTION METIS_Free(ptr) RESULT( ans ) BIND(C,NAME="METIS_Free") + IMPORT + TYPE( C_PTR ), VALUE :: ptr + !! The pointer to be freed. This pointer should be one of the `xadj` or `adjncy`, arrays returned by METIS' API routines + INTEGER( I4B ) :: ans + !! `METIS_OK` Indicates that the function returned normally. +END FUNCTION METIS_Free +END INTERFACE + +PUBLIC :: METIS_FREE + + + + + diff --git a/src/modules/MultiIndices/CMakeLists.txt b/src/modules/MultiIndices/CMakeLists.txt new file mode 100644 index 000000000..75e364bf1 --- /dev/null +++ b/src/modules/MultiIndices/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/MultiIndices_Method.F90 +) diff --git a/src/modules/MultiIndices/src/MultiIndices_Method.F90 b/src/modules/MultiIndices/src/MultiIndices_Method.F90 new file mode 100644 index 000000000..7745808c0 --- /dev/null +++ b/src/modules/MultiIndices/src/MultiIndices_Method.F90 @@ -0,0 +1,154 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE MultiIndices_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate +PUBLIC :: MultiIndices +PUBLIC :: DEALLOCATE +PUBLIC :: Display +PUBLIC :: Size +PUBLIC :: GetMultiIndices + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Initiate the multi indices + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_Initiate1(obj, n, d) + TYPE(MultiIndices_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(IN) :: d + END SUBROUTINE obj_Initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! MultiIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Function to construct the multi-index + +INTERFACE MultiIndices + MODULE PURE FUNCTION obj_MultiIndices(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(IN) :: d + TYPE(MultiIndices_) :: ans + END FUNCTION obj_MultiIndices +END INTERFACE MultiIndices + +!---------------------------------------------------------------------------- +! Deallocate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Deallocate the object + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE obj_Deallocate(obj) + TYPE(MultiIndices_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Display@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Display the content + +INTERFACE Display + MODULE SUBROUTINE obj_Display(obj, msg, unitno) + TYPE(MultiIndices_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + END SUBROUTINE obj_Display +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE Size + MODULE PURE FUNCTION obj_Size1(obj) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_Size1 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE Size + MODULE PURE FUNCTION obj_Size2(obj, upto) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B) :: ans + END FUNCTION obj_Size2 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices + +INTERFACE GetMultiIndices + MODULE PURE FUNCTION obj_GetMultiIndices1(obj) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices1 +END INTERFACE GetMultiIndices + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices + +INTERFACE GetMultiIndices + MODULE PURE FUNCTION obj_GetMultiIndices2(obj, upto) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices2 +END INTERFACE GetMultiIndices + +END MODULE MultiIndices_Method diff --git a/src/modules/OpenMP/CMakeLists.txt b/src/modules/OpenMP/CMakeLists.txt new file mode 100644 index 000000000..e4086ee3f --- /dev/null +++ b/src/modules/OpenMP/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 7/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/OpenMP_Method.F90 +) \ No newline at end of file diff --git a/src/modules/OpenMP/src/OpenMP_Method.F90 b/src/modules/OpenMP/src/OpenMP_Method.F90 new file mode 100644 index 000000000..5a36cf92a --- /dev/null +++ b/src/modules/OpenMP/src/OpenMP_Method.F90 @@ -0,0 +1,82 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 9 March 2021 +! summary: This module contains openmp methods + +MODULE OpenMP_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE +PUBLIC :: OMP_Initiate +PUBLIC :: OMP_Finalize +PUBLIC :: OMP_Partition + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +INTERFACE OMP_Initiate + MODULE SUBROUTINE obj_initiate + END SUBROUTINE obj_initiate +END INTERFACE OMP_Initiate + +!---------------------------------------------------------------------------- +! Finalize@Constructor +!---------------------------------------------------------------------------- + +INTERFACE OMP_Finalize + MODULE SUBROUTINE obj_finalize + END SUBROUTINE obj_finalize +END INTERFACE OMP_Finalize + +!---------------------------------------------------------------------------- +! Partition@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 March 2021 +! summary: This function partition a vector for omp +! +!# Introduction +! +! This function partition a vector for [[OpenMP_]], +! and returns a vector of length 4 (i.e., Ans) +! +! * Ans( 1 ) = istart +! * Ans( 2 ) = iend +! * Ans( 3 ) = stride +! * Ans( 4 ) = Length +! +! +!### Usage +! +!```fortran +! to do +!``` + +INTERFACE OMP_Partition + MODULE FUNCTION obj_partition_vec(N, OMP_NUM_THREADS) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: N + INTEGER(I4B), INTENT(IN) :: OMP_NUM_THREADS + INTEGER(I4B) :: Ans(4) + END FUNCTION obj_partition_vec +END INTERFACE OMP_Partition + +END MODULE OpenMP_Method diff --git a/src/modules/PENF/CMakeLists.txt b/src/modules/PENF/CMakeLists.txt new file mode 100644 index 000000000..a71c52eff --- /dev/null +++ b/src/modules/PENF/CMakeLists.txt @@ -0,0 +1,85 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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 type specific output defaults +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/penf.F90 + ${src_path}/penf_b_size.F90 + ${src_path}/penf_global_parameters_variables.F90 + ${src_path}/penf_stringify.F90 +) + +INCLUDE(CheckFortranSourceRuns) + +check_fortran_source_runs( + "program r16p_support; + integer, parameter :: r16p = selected_real_kind(33, 4931); + if(r16p < 0) stop 1; + end program r16p_support" + R16P_SUPPORTED + SRC_EXT f90 + ) +IF(R16P_SUPPORTED) +SET(r16p_supported "-D_R16P") +ENDIF() + +check_fortran_source_runs( + "program ascii_support; + integer, parameter :: ascii = selected_char_kind('ascii'); + if(ascii < 0) stop 1; + end program ascii_support" + ASCII_SUPPORTED + SRC_EXT f90 + ) + +IF(ASCII_SUPPORTED) +SET(ascii_supported "-D_ASCII_SUPPORTED") +ENDIF() + +check_fortran_source_runs( +"program ascii_neq_default; +integer, parameter :: ascii = selected_char_kind('ascii'); +integer, parameter :: default = selected_char_kind('default'); +if(ascii == default) stop 1; +end program ascii_neq_default" +ASCII_NEQ_DEFAULT +SRC_EXT f90 +) + +IF(ASCII_NEQ_DEFAULT) +SET(ascii_neq_default "-D_ASCII_NEQ_DEFAULT") +ENDIF() + +check_fortran_source_runs( +"program ucs4_support; +integer, parameter :: ucs4 = selected_char_kind('iso_10646'); +if(ucs4 < 0) stop 1; +end program ucs4_support" +UCS4_SUPPORTED +SRC_EXT f90 +) + +IF(UCS4_SUPPORTED) +SET(ucs4_supported "-D_UCS4_SUPPORTED") +ENDIF() + +LIST( APPEND TARGET_COMPILE_DEF ${ascii_supported} ) +LIST( APPEND TARGET_COMPILE_DEF ${ascii_neq_default} ) +LIST( APPEND TARGET_COMPILE_DEF ${ucs4_supported} ) +LIST( APPEND TARGET_COMPILE_DEF ${r16p_supported} ) \ No newline at end of file diff --git a/src/modules/PENF/LICENSE.gpl3.md b/src/modules/PENF/LICENSE.gpl3.md new file mode 100644 index 000000000..16d89e0a3 --- /dev/null +++ b/src/modules/PENF/LICENSE.gpl3.md @@ -0,0 +1,596 @@ +GNU GENERAL PUBLIC LICENSE +========================== + +Version 3, 29 June 2007 + +Copyright © 2007 Free Software Foundation, Inc. <> + +Everyone is permitted to copy and distribute verbatim copies of this license +document, but changing it is not allowed. + +## Preamble + +The GNU General Public License is a free, copyleft license for software and other +kinds of works. + +The licenses for most software and other practical works are designed to take away +your freedom to share and change the works. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change all versions of a +program--to make sure it remains free software for all its users. We, the Free +Software Foundation, use the GNU General Public License for most of our software; it +applies also to any other work released this way by its authors. You can apply it to +your programs, too. + +When we speak of free software, we are referring to freedom, not price. Our General +Public Licenses are designed to make sure that you have the freedom to distribute +copies of free software (and charge for them if you wish), that you receive source +code or can get it if you want it, that you can change the software or use pieces of +it in new free programs, and that you know you can do these things. + +To protect your rights, we need to prevent others from denying you these rights or +asking you to surrender the rights. Therefore, you have certain responsibilities if +you distribute copies of the software, or if you modify it: responsibilities to +respect the freedom of others. + +For example, if you distribute copies of such a program, whether gratis or for a fee, +you must pass on to the recipients the same freedoms that you received. You must make +sure that they, too, receive or can get the source code. And you must show them these +terms so they know their rights. + +Developers that use the GNU GPL protect your rights with two steps: (1) assert +copyright on the software, and (2) offer you this License giving you legal permission +to copy, distribute and/or modify it. + +For the developers' and authors' protection, the GPL clearly explains that there is +no warranty for this free software. For both users' and authors' sake, the GPL +requires that modified versions be marked as changed, so that their problems will not +be attributed erroneously to authors of previous versions. + +Some devices are designed to deny users access to install or run modified versions of +the software inside them, although the manufacturer can do so. This is fundamentally +incompatible with the aim of protecting users' freedom to change the software. The +systematic pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we have designed +this version of the GPL to prohibit the practice for those products. If such problems +arise substantially in other domains, we stand ready to extend this provision to +those domains in future versions of the GPL, as needed to protect the freedom of +users. + +Finally, every program is threatened constantly by software patents. States should +not allow patents to restrict development and use of software on general-purpose +computers, but in those that do, we wish to avoid the special danger that patents +applied to a free program could make it effectively proprietary. To prevent this, the +GPL assures that patents cannot be used to render the program non-free. + +The precise terms and conditions for copying, distribution and modification follow. + +## TERMS AND CONDITIONS + +### 0. Definitions. + +“This License” refers to version 3 of the GNU General Public License. + +“Copyright” also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + +“The Program” refers to any copyrightable work licensed under this +License. Each licensee is addressed as “you”. “Licensees” and +“recipients” may be individuals or organizations. + +To “modify” a work means to copy from or adapt all or part of the work in +a fashion requiring copyright permission, other than the making of an exact copy. The +resulting work is called a “modified version” of the earlier work or a +work “based on” the earlier work. + +A “covered work” means either the unmodified Program or a work based on +the Program. + +To “propagate” a work means to do anything with it that, without +permission, would make you directly or secondarily liable for infringement under +applicable copyright law, except executing it on a computer or modifying a private +copy. Propagation includes copying, distribution (with or without modification), +making available to the public, and in some countries other activities as well. + +To “convey” a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through a computer +network, with no transfer of a copy, is not conveying. + +An interactive user interface displays “Appropriate Legal Notices” to the +extent that it includes a convenient and prominently visible feature that (1) +displays an appropriate copyright notice, and (2) tells the user that there is no +warranty for the work (except to the extent that warranties are provided), that +licensees may convey the work under this License, and how to view a copy of this +License. If the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + +### 1. Source Code. + +The “source code” for a work means the preferred form of the work for +making modifications to it. “Object code” means any non-source form of a +work. + +A “Standard Interface” means an interface that either is an official +standard defined by a recognized standards body, or, in the case of interfaces +specified for a particular programming language, one that is widely used among +developers working in that language. + +The “System Libraries” of an executable work include anything, other than +the work as a whole, that (a) is included in the normal form of packaging a Major +Component, but which is not part of that Major Component, and (b) serves only to +enable use of the work with that Major Component, or to implement a Standard +Interface for which an implementation is available to the public in source code form. +A “Major Component”, in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system (if any) on which +the executable work runs, or a compiler used to produce the work, or an object code +interpreter used to run it. + +The “Corresponding Source” for a work in object code form means all the +source code needed to generate, install, and (for an executable work) run the object +code and to modify the work, including scripts to control those activities. However, +it does not include the work's System Libraries, or general-purpose tools or +generally available free programs which are used unmodified in performing those +activities but which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for the work, and +the source code for shared libraries and dynamically linked subprograms that the work +is specifically designed to require, such as by intimate data communication or +control flow between those subprograms and other parts of the work. + +The Corresponding Source need not include anything that users can regenerate +automatically from other parts of the Corresponding Source. + +The Corresponding Source for a work in source code form is that same work. + +### 2. Basic Permissions. + +All rights granted under this License are granted for the term of copyright on the +Program, and are irrevocable provided the stated conditions are met. This License +explicitly affirms your unlimited permission to run the unmodified Program. The +output from running a covered work is covered by this License only if the output, +given its content, constitutes a covered work. This License acknowledges your rights +of fair use or other equivalent, as provided by copyright law. + +You may make, run and propagate covered works that you do not convey, without +conditions so long as your license otherwise remains in force. You may convey covered +works to others for the sole purpose of having them make modifications exclusively +for you, or provide you with facilities for running those works, provided that you +comply with the terms of this License in conveying all material for which you do not +control copyright. Those thus making or running the covered works for you must do so +exclusively on your behalf, under your direction and control, on terms that prohibit +them from making any copies of your copyrighted material outside their relationship +with you. + +Conveying under any other circumstances is permitted solely under the conditions +stated below. Sublicensing is not allowed; section 10 makes it unnecessary. + +### 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + +No covered work shall be deemed part of an effective technological measure under any +applicable law fulfilling obligations under article 11 of the WIPO copyright treaty +adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention +of such measures. + +When you convey a covered work, you waive any legal power to forbid circumvention of +technological measures to the extent such circumvention is effected by exercising +rights under this License with respect to the covered work, and you disclaim any +intention to limit operation or modification of the work as a means of enforcing, +against the work's users, your or third parties' legal rights to forbid circumvention +of technological measures. + +### 4. Conveying Verbatim Copies. + +You may convey verbatim copies of the Program's source code as you receive it, in any +medium, provided that you conspicuously and appropriately publish on each copy an +appropriate copyright notice; keep intact all notices stating that this License and +any non-permissive terms added in accord with section 7 apply to the code; keep +intact all notices of the absence of any warranty; and give all recipients a copy of +this License along with the Program. + +You may charge any price or no price for each copy that you convey, and you may offer +support or warranty protection for a fee. + +### 5. Conveying Modified Source Versions. + +You may convey a work based on the Program, or the modifications to produce it from +the Program, in the form of source code under the terms of section 4, provided that +you also meet all of these conditions: + +* **a)** The work must carry prominent notices stating that you modified it, and giving a +relevant date. +* **b)** The work must carry prominent notices stating that it is released under this +License and any conditions added under section 7. This requirement modifies the +requirement in section 4 to “keep intact all notices”. +* **c)** You must license the entire work, as a whole, under this License to anyone who +comes into possession of a copy. This License will therefore apply, along with any +applicable section 7 additional terms, to the whole of the work, and all its parts, +regardless of how they are packaged. This License gives no permission to license the +work in any other way, but it does not invalidate such permission if you have +separately received it. +* **d)** If the work has interactive user interfaces, each must display Appropriate Legal +Notices; however, if the Program has interactive interfaces that do not display +Appropriate Legal Notices, your work need not make them do so. + +A compilation of a covered work with other separate and independent works, which are +not by their nature extensions of the covered work, and which are not combined with +it such as to form a larger program, in or on a volume of a storage or distribution +medium, is called an “aggregate” if the compilation and its resulting +copyright are not used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work in an aggregate +does not cause this License to apply to the other parts of the aggregate. + +### 6. Conveying Non-Source Forms. + +You may convey a covered work in object code form under the terms of sections 4 and +5, provided that you also convey the machine-readable Corresponding Source under the +terms of this License, in one of these ways: + +* **a)** Convey the object code in, or embodied in, a physical product (including a +physical distribution medium), accompanied by the Corresponding Source fixed on a +durable physical medium customarily used for software interchange. +* **b)** Convey the object code in, or embodied in, a physical product (including a +physical distribution medium), accompanied by a written offer, valid for at least +three years and valid for as long as you offer spare parts or customer support for +that product model, to give anyone who possesses the object code either (1) a copy of +the Corresponding Source for all the software in the product that is covered by this +License, on a durable physical medium customarily used for software interchange, for +a price no more than your reasonable cost of physically performing this conveying of +source, or (2) access to copy the Corresponding Source from a network server at no +charge. +* **c)** Convey individual copies of the object code with a copy of the written offer to +provide the Corresponding Source. This alternative is allowed only occasionally and +noncommercially, and only if you received the object code with such an offer, in +accord with subsection 6b. +* **d)** Convey the object code by offering access from a designated place (gratis or for +a charge), and offer equivalent access to the Corresponding Source in the same way +through the same place at no further charge. You need not require recipients to copy +the Corresponding Source along with the object code. If the place to copy the object +code is a network server, the Corresponding Source may be on a different server +(operated by you or a third party) that supports equivalent copying facilities, +provided you maintain clear directions next to the object code saying where to find +the Corresponding Source. Regardless of what server hosts the Corresponding Source, +you remain obligated to ensure that it is available for as long as needed to satisfy +these requirements. +* **e)** Convey the object code using peer-to-peer transmission, provided you inform +other peers where the object code and Corresponding Source of the work are being +offered to the general public at no charge under subsection 6d. + +A separable portion of the object code, whose source code is excluded from the +Corresponding Source as a System Library, need not be included in conveying the +object code work. + +A “User Product” is either (1) a “consumer product”, which +means any tangible personal property which is normally used for personal, family, or +household purposes, or (2) anything designed or sold for incorporation into a +dwelling. In determining whether a product is a consumer product, doubtful cases +shall be resolved in favor of coverage. For a particular product received by a +particular user, “normally used” refers to a typical or common use of +that class of product, regardless of the status of the particular user or of the way +in which the particular user actually uses, or expects or is expected to use, the +product. A product is a consumer product regardless of whether the product has +substantial commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + +“Installation Information” for a User Product means any methods, +procedures, authorization keys, or other information required to install and execute +modified versions of a covered work in that User Product from a modified version of +its Corresponding Source. The information must suffice to ensure that the continued +functioning of the modified object code is in no case prevented or interfered with +solely because modification has been made. + +If you convey an object code work under this section in, or with, or specifically for +use in, a User Product, and the conveying occurs as part of a transaction in which +the right of possession and use of the User Product is transferred to the recipient +in perpetuity or for a fixed term (regardless of how the transaction is +characterized), the Corresponding Source conveyed under this section must be +accompanied by the Installation Information. But this requirement does not apply if +neither you nor any third party retains the ability to install modified object code +on the User Product (for example, the work has been installed in ROM). + +The requirement to provide Installation Information does not include a requirement to +continue to provide support service, warranty, or updates for a work that has been +modified or installed by the recipient, or for the User Product in which it has been +modified or installed. Access to a network may be denied when the modification itself +materially and adversely affects the operation of the network or violates the rules +and protocols for communication across the network. + +Corresponding Source conveyed, and Installation Information provided, in accord with +this section must be in a format that is publicly documented (and with an +implementation available to the public in source code form), and must require no +special password or key for unpacking, reading or copying. + +### 7. Additional Terms. + +“Additional permissions” are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. Additional +permissions that are applicable to the entire Program shall be treated as though they +were included in this License, to the extent that they are valid under applicable +law. If additional permissions apply only to part of the Program, that part may be +used separately under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + +When you convey a copy of a covered work, you may at your option remove any +additional permissions from that copy, or from any part of it. (Additional +permissions may be written to require their own removal in certain cases when you +modify the work.) You may place additional permissions on material, added by you to a +covered work, for which you have or can give appropriate copyright permission. + +Notwithstanding any other provision of this License, for material you add to a +covered work, you may (if authorized by the copyright holders of that material) +supplement the terms of this License with terms: + +* **a)** Disclaiming warranty or limiting liability differently from the terms of +sections 15 and 16 of this License; or +* **b)** Requiring preservation of specified reasonable legal notices or author +attributions in that material or in the Appropriate Legal Notices displayed by works +containing it; or +* **c)** Prohibiting misrepresentation of the origin of that material, or requiring that +modified versions of such material be marked in reasonable ways as different from the +original version; or +* **d)** Limiting the use for publicity purposes of names of licensors or authors of the +material; or +* **e)** Declining to grant rights under trademark law for use of some trade names, +trademarks, or service marks; or +* **f)** Requiring indemnification of licensors and authors of that material by anyone +who conveys the material (or modified versions of it) with contractual assumptions of +liability to the recipient, for any liability that these contractual assumptions +directly impose on those licensors and authors. + +All other non-permissive additional terms are considered “further +restrictions” within the meaning of section 10. If the Program as you received +it, or any part of it, contains a notice stating that it is governed by this License +along with a term that is a further restriction, you may remove that term. If a +license document contains a further restriction but permits relicensing or conveying +under this License, you may add to a covered work material governed by the terms of +that license document, provided that the further restriction does not survive such +relicensing or conveying. + +If you add terms to a covered work in accord with this section, you must place, in +the relevant source files, a statement of the additional terms that apply to those +files, or a notice indicating where to find the applicable terms. + +Additional terms, permissive or non-permissive, may be stated in the form of a +separately written license, or stated as exceptions; the above requirements apply +either way. + +### 8. Termination. + +You may not propagate or modify a covered work except as expressly provided under +this License. Any attempt otherwise to propagate or modify it is void, and will +automatically terminate your rights under this License (including any patent licenses +granted under the third paragraph of section 11). + +However, if you cease all violation of this License, then your license from a +particular copyright holder is reinstated (a) provisionally, unless and until the +copyright holder explicitly and finally terminates your license, and (b) permanently, +if the copyright holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + +Moreover, your license from a particular copyright holder is reinstated permanently +if the copyright holder notifies you of the violation by some reasonable means, this +is the first time you have received notice of violation of this License (for any +work) from that copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + +Termination of your rights under this section does not terminate the licenses of +parties who have received copies or rights from you under this License. If your +rights have been terminated and not permanently reinstated, you do not qualify to +receive new licenses for the same material under section 10. + +### 9. Acceptance Not Required for Having Copies. + +You are not required to accept this License in order to receive or run a copy of the +Program. Ancillary propagation of a covered work occurring solely as a consequence of +using peer-to-peer transmission to receive a copy likewise does not require +acceptance. However, nothing other than this License grants you permission to +propagate or modify any covered work. These actions infringe copyright if you do not +accept this License. Therefore, by modifying or propagating a covered work, you +indicate your acceptance of this License to do so. + +### 10. Automatic Licensing of Downstream Recipients. + +Each time you convey a covered work, the recipient automatically receives a license +from the original licensors, to run, modify and propagate that work, subject to this +License. You are not responsible for enforcing compliance by third parties with this +License. + +An “entity transaction” is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an organization, or +merging organizations. If propagation of a covered work results from an entity +transaction, each party to that transaction who receives a copy of the work also +receives whatever licenses to the work the party's predecessor in interest had or +could give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if the predecessor +has it or can get it with reasonable efforts. + +You may not impose any further restrictions on the exercise of the rights granted or +affirmed under this License. For example, you may not impose a license fee, royalty, +or other charge for exercise of rights granted under this License, and you may not +initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging +that any patent claim is infringed by making, using, selling, offering for sale, or +importing the Program or any portion of it. + +### 11. Patents. + +A “contributor” is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The work thus +licensed is called the contributor's “contributor version”. + +A contributor's “essential patent claims” are all patent claims owned or +controlled by the contributor, whether already acquired or hereafter acquired, that +would be infringed by some manner, permitted by this License, of making, using, or +selling its contributor version, but do not include claims that would be infringed +only as a consequence of further modification of the contributor version. For +purposes of this definition, “control” includes the right to grant patent +sublicenses in a manner consistent with the requirements of this License. + +Each contributor grants you a non-exclusive, worldwide, royalty-free patent license +under the contributor's essential patent claims, to make, use, sell, offer for sale, +import and otherwise run, modify and propagate the contents of its contributor +version. + +In the following three paragraphs, a “patent license” is any express +agreement or commitment, however denominated, not to enforce a patent (such as an +express permission to practice a patent or covenant not to sue for patent +infringement). To “grant” such a patent license to a party means to make +such an agreement or commitment not to enforce a patent against the party. + +If you convey a covered work, knowingly relying on a patent license, and the +Corresponding Source of the work is not available for anyone to copy, free of charge +and under the terms of this License, through a publicly available network server or +other readily accessible means, then you must either (1) cause the Corresponding +Source to be so available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner consistent with +the requirements of this License, to extend the patent license to downstream +recipients. “Knowingly relying” means you have actual knowledge that, but +for the patent license, your conveying the covered work in a country, or your +recipient's use of the covered work in a country, would infringe one or more +identifiable patents in that country that you have reason to believe are valid. + +If, pursuant to or in connection with a single transaction or arrangement, you +convey, or propagate by procuring conveyance of, a covered work, and grant a patent +license to some of the parties receiving the covered work authorizing them to use, +propagate, modify or convey a specific copy of the covered work, then the patent +license you grant is automatically extended to all recipients of the covered work and +works based on it. + +A patent license is “discriminatory” if it does not include within the +scope of its coverage, prohibits the exercise of, or is conditioned on the +non-exercise of one or more of the rights that are specifically granted under this +License. You may not convey a covered work if you are a party to an arrangement with +a third party that is in the business of distributing software, under which you make +payment to the third party based on the extent of your activity of conveying the +work, and under which the third party grants, to any of the parties who would receive +the covered work from you, a discriminatory patent license (a) in connection with +copies of the covered work conveyed by you (or copies made from those copies), or (b) +primarily for and in connection with specific products or compilations that contain +the covered work, unless you entered into that arrangement, or that patent license +was granted, prior to 28 March 2007. + +Nothing in this License shall be construed as excluding or limiting any implied +license or other defenses to infringement that may otherwise be available to you +under applicable patent law. + +### 12. No Surrender of Others' Freedom. + +If conditions are imposed on you (whether by court order, agreement or otherwise) +that contradict the conditions of this License, they do not excuse you from the +conditions of this License. If you cannot convey a covered work so as to satisfy +simultaneously your obligations under this License and any other pertinent +obligations, then as a consequence you may not convey it at all. For example, if you +agree to terms that obligate you to collect a royalty for further conveying from +those to whom you convey the Program, the only way you could satisfy both those terms +and this License would be to refrain entirely from conveying the Program. + +### 13. Use with the GNU Affero General Public License. + +Notwithstanding any other provision of this License, you have permission to link or +combine any covered work with a work licensed under version 3 of the GNU Affero +General Public License into a single combined work, and to convey the resulting work. +The terms of this License will continue to apply to the part which is the covered +work, but the special requirements of the GNU Affero General Public License, section +13, concerning interaction through a network will apply to the combination as such. + +### 14. Revised Versions of this License. + +The Free Software Foundation may publish revised and/or new versions of the GNU +General Public License from time to time. Such new versions will be similar in spirit +to the present version, but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Program specifies that +a certain numbered version of the GNU General Public License “or any later +version” applies to it, you have the option of following the terms and +conditions either of that numbered version or of any later version published by the +Free Software Foundation. If the Program does not specify a version number of the GNU +General Public License, you may choose any version ever published by the Free +Software Foundation. + +If the Program specifies that a proxy can decide which future versions of the GNU +General Public License can be used, that proxy's public statement of acceptance of a +version permanently authorizes you to choose that version for the Program. + +Later license versions may give you additional or different permissions. However, no +additional obligations are imposed on any author or copyright holder as a result of +your choosing to follow a later version. + +### 15. Disclaimer of Warranty. + +THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM “AS IS” WITHOUT WARRANTY OF ANY KIND, EITHER +EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE +QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE +DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + +### 16. Limitation of Liability. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY +COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS +PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, +INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE +OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE +WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + +### 17. Interpretation of Sections 15 and 16. + +If the disclaimer of warranty and limitation of liability provided above cannot be +given local legal effect according to their terms, reviewing courts shall apply local +law that most closely approximates an absolute waiver of all civil liability in +connection with the Program, unless a warranty or assumption of liability accompanies +a copy of the Program in return for a fee. + +END OF TERMS AND CONDITIONS + +## How to Apply These Terms to Your New Programs + +If you develop a new program, and you want it to be of the greatest possible use to +the public, the best way to achieve this is to make it free software which everyone +can redistribute and change under these terms. + +To do so, attach the following notices to the program. It is safest to attach them +to the start of each source file to most effectively state the exclusion of warranty; +and each file should have at least the “copyright” line and a pointer to +where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + +If the program does terminal interaction, make it output a short notice like this +when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type 'show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type 'show c' for details. + +The hypothetical commands 'show w' and 'show c' should show the appropriate parts of +the General Public License. Of course, your program's commands might be different; +for a GUI interface, you would use an “about box”. + +You should also get your employer (if you work as a programmer) or school, if any, to +sign a “copyright disclaimer” for the program, if necessary. For more +information on this, and how to apply and follow the GNU GPL, see +<>. + +The GNU General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may consider it +more useful to permit linking proprietary applications with the library. If this is +what you want to do, use the GNU Lesser General Public License instead of this +License. But first, please read +<>. \ No newline at end of file diff --git a/src/modules/PENF/src/BCTON.inc b/src/modules/PENF/src/BCTON.inc new file mode 100644 index 000000000..0a8fdda6a --- /dev/null +++ b/src/modules/PENF/src/BCTON.inc @@ -0,0 +1,128 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +elemental function bctor_R16P(bstr, knd) result(n) + !< Convert bit-string to real. + !< + !<```fortran + !< use penf + !< print FR16P, bcton('00000000000000000000000000000000000000000000000000000000000000000000000000000'//& + !< '000000000000000000000000000000000001111111100111111', knd=1._R16P) + !<``` + !=> 0.100000000000000000000000000000000E+0001 <<< + character(*), intent(in) :: bstr !< String containing input number. + real(R16P), intent(in) :: knd !< Number kind. + real(R16P) :: n !< Number returned. + integer(I1P) :: buffer(16) !< Transfer buffer. + + read (bstr, '(16B8.8)') buffer + n = transfer(buffer, n) +end function bctor_R16P + +elemental function bctor_R8P(bstr, knd) result(n) + !< Convert bit-string to real. + !< + !<```fortran + !< use penf + !< print FR8P, bcton('0000000000000000000000000000000000000000000000001111000000111111', knd=1._R8P) + !<``` + !=> 0.100000000000000E+001 <<< + character(*), intent(in) :: bstr !< String containing input number. + real(R8P), intent(in) :: knd !< Number kind. + real(R8P) :: n !< Number returned. + integer(I1P) :: buffer(8) !< Transfer buffer. + + read (bstr, '(8B8.8)') buffer + n = transfer(buffer, n) +end function bctor_R8P + +elemental function bctor_R4P(bstr, knd) result(n) + !< Convert bit-string to real. + !< + !<```fortran + !< use penf + !< print FR4P, bcton('00000000000000001000000000111111', knd=1._R4P) + !<``` + !=> 0.100000E+01 <<< + character(*), intent(in) :: bstr !< String containing input number. + real(R4P), intent(in) :: knd !< Number kind. + real(R4P) :: n !< Number returned. + integer(I1P) :: buffer(4) !< Transfer buffer. + + read (bstr, '(4B8.8)') buffer + n = transfer(buffer, n) +end function bctor_R4P + +elemental function bctoi_I8P(bstr, knd) result(n) + !< Convert bit-string to integer. + !< + !<```fortran + !< use penf + !< print FI8P, bcton('0000000000000000000000000000000000000000000000000000000000000001', knd=1_I8P) + !<``` + !=> 1 <<< + character(*), intent(in) :: bstr !< String containing input number. + integer(I8P), intent(in) :: knd !< Number kind. + integer(I8P) :: n !< Number returned. + +read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n +end function bctoi_I8P + +elemental function bctoi_I4P(bstr, knd) result(n) + !< Convert bit-string to integer. + !< + !<```fortran + !< use penf + !< print FI4P, bcton('00000000000000000000000000000001', knd=1_I4P) + !<``` + !=> 1 <<< + character(*), intent(in) :: bstr !< String containing input number. + integer(I4P), intent(in) :: knd !< Number kind. + integer(I4P) :: n !< Number returned. + +read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n +end function bctoi_I4P + +elemental function bctoi_I2P(bstr, knd) result(n) + !< Convert bit-string to integer. + !< + !<```fortran + !< use penf + !< print FI2P, bcton('0000000000000001', knd=1_I2P) + !<``` + !=> 1 <<< + character(*), intent(in) :: bstr !< String containing input number. + integer(I2P), intent(in) :: knd !< Number kind. + integer(I2P) :: n !< Number returned. + +read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n +end function bctoi_I2P + +elemental function bctoi_I1P(bstr, knd) result(n) + !< Convert bit-string to integer. + !< + !<```fortran + !< use penf + !< print FI1P, bcton('00000001', knd=1_I1P) + !<``` + !=> 1 <<< + character(*), intent(in) :: bstr !< String containing input number. + integer(I1P), intent(in) :: knd !< Number kind. + integer(I1P) :: n !< Number returned. + +read(bstr,'(B'//trim(str(bit_size(knd), .true.))//'.'//trim(str(bit_size(knd), .true.))//')') n +end function bctoi_I1P diff --git a/src/modules/PENF/src/BSTR.inc b/src/modules/PENF/src/BSTR.inc new file mode 100644 index 000000000..eddcf6370 --- /dev/null +++ b/src/modules/PENF/src/BSTR.inc @@ -0,0 +1,136 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +elemental function bstr_R16P(n) result(bstr) + !< Convert real to string of bits. + !< + !< @note It is assumed that R16P is represented by means of 128 bits, but this is not ensured in all architectures. + !< + !<```fortran + !< use penf + !< character(128) :: b + !< b = bstr(n=1._R16P) + !< print "(A)", b(17:) + !<``` + !=> 0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001111111100111111 <<< + real(R16P), intent(in) :: n !< Real to be converted. + character(128) :: bstr !< Returned bit-string containing input number. + integer(I1P) :: buffer(16) !< Transfer buffer. + + buffer = transfer(n, buffer) + write (bstr, '(16B8.8)') buffer +end function bstr_R16P + +elemental function bstr_R8P(n) result(bstr) + !< Convert real to string of bits. + !< + !< @note It is assumed that R8P is represented by means of 64 bits, but this is not ensured in all architectures. + !< + !<```fortran + !< use penf + !< print "(A)", bstr(n=1._R8P) + !<``` + !=> 0000000000000000000000000000000000000000000000001111000000111111 <<< + real(R8P), intent(in) :: n !< Real to be converted. + character(64) :: bstr !< Returned bit-string containing input number. + integer(I1P) :: buffer(8) !< Transfer buffer. + + buffer = transfer(n, buffer) + write (bstr, '(8B8.8)') buffer +end function bstr_R8P + +elemental function bstr_R4P(n) result(bstr) + !< Convert real to string of bits. + !< + !< @note It is assumed that R4P is represented by means of 32 bits, but this is not ensured in all architectures. + !< + !<```fortran + !< use penf + !< print "(A)", bstr(n=1._R4P) + !<``` + !=> 00000000000000001000000000111111 <<< + real(R4P), intent(in) :: n !< Real to be converted. + character(32) :: bstr !< Returned bit-string containing input number. + integer(I1P) :: buffer(4) !< Transfer buffer. + + buffer = transfer(n, buffer) + write (bstr, '(4B8.8)') buffer +end function bstr_R4P + +elemental function bstr_I8P(n) result(bstr) + !< Convert integer to string of bits. + !< + !< @note It is assumed that I8P is represented by means of 64 bits, but this is not ensured in all architectures. + !< + !<```fortran + !< use penf + !< print "(A)", bstr(n=1_I8P) + !<``` + !=> 0000000000000000000000000000000000000000000000000000000000000001 <<< + integer(I8P), intent(in) :: n !< Real to be converted. + character(64) :: bstr !< Returned bit-string containing input number. + + write (bstr, '(B64.64)') n +end function bstr_I8P + +elemental function bstr_I4P(n) result(bstr) + !< Convert integer to string of bits. + !< + !< @note It is assumed that I4P is represented by means of 32 bits, but this is not ensured in all architectures. + !< + !<```fortran + !< use penf + !< print "(A)", bstr(n=1_I4P) + !<``` + !=> 00000000000000000000000000000001 <<< + integer(I4P), intent(in) :: n !< Real to be converted. + character(32) :: bstr !< Returned bit-string containing input number. + + write (bstr, '(B32.32)') n +end function bstr_I4P + +elemental function bstr_I2P(n) result(bstr) + !< Convert integer to string of bits. + !< + !< @note It is assumed that I2P is represented by means of 16 bits, but this is not ensured in all architectures. + !< + !<```fortran + !< use penf + !< print "(A)", bstr(n=1_I2P) + !<``` + !=> 0000000000000001 <<< + integer(I2P), intent(in) :: n !< Real to be converted. + character(16) :: bstr !< Returned bit-string containing input number. + + write (bstr, '(B16.16)') n +end function bstr_I2P + +elemental function bstr_I1P(n) result(bstr) + !< Convert integer to string of bits. + !< + !< @note It is assumed that I1P is represented by means of 8 bits, but this is not ensured in all architectures. + !< + !<```fortran + !< use penf + !< print "(A)", bstr(n=1_I1P) + !<``` + !=> 00000001 <<< + integer(I1P), intent(in) :: n !< Real to be converted. + character(8) :: bstr !< Returned bit-string containing input number. + + write (bstr, '(B8.8)') n +end function bstr_I1P diff --git a/src/modules/PENF/src/COMPACT_REAL_STRING.inc b/src/modules/PENF/src/COMPACT_REAL_STRING.inc new file mode 100644 index 000000000..5a1ac9718 --- /dev/null +++ b/src/modules/PENF/src/COMPACT_REAL_STRING.inc @@ -0,0 +1,84 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +pure subroutine compact_real_string(string) + !< author: Izaak Beekman + !< date: 02/24/2015 + !< + !< Compact a string representing a real number, so that the same value is displayed with fewer characters. + !< + !< @note No need to add doctest: this is tested by a lot of doctests of other TBPs. + character(len=*), intent(inout) :: string !< string representation of a real number. + character(len=len(string)) :: significand !< Significand characters. + character(len=len(string)) :: expnt !< Exponent characters. + character(len=2) :: separator !< Separator characters. + integer(I4P) :: exp_start !< Start position of exponent. + integer(I4P) :: decimal_pos !< Decimal positions. + integer(I4P) :: sig_trim !< Signature trim. + integer(I4P) :: exp_trim !< Exponent trim. + integer(I4P) :: i !< counter + + string = adjustl(string) + exp_start = scan(string, 'eEdD') + if (exp_start == 0) exp_start = scan(string, '-+', back=.true.) + decimal_pos = scan(string, '.') + if (exp_start /= 0) separator = string(exp_start:exp_start) + if (exp_start < decimal_pos) then ! possibly signed, exponent-less float + significand = string + sig_trim = len(trim(significand)) + do i = len(trim(significand)), decimal_pos + 2, -1 ! look from right to left at 0s, but save one after the decimal place + if (significand(i:i) == '0') then + sig_trim = i - 1 + else + exit + end if + end do + string = trim(significand(1:sig_trim)) + elseif (exp_start > decimal_pos) then ! float has exponent + significand = string(1:exp_start - 1) + sig_trim = len(trim(significand)) + do i = len(trim(significand)), decimal_pos + 2, -1 ! look from right to left at 0s + if (significand(i:i) == '0') then + sig_trim = i - 1 + else + exit + end if + end do + expnt = adjustl(string(exp_start + 1:)) + if (expnt(1:1) == '+' .or. expnt(1:1) == '-') then + separator = trim(adjustl(separator))//expnt(1:1) + exp_start = exp_start + 1 + expnt = adjustl(string(exp_start + 1:)) + end if + exp_trim = 1 + do i = 1, (len(trim(expnt)) - 1) ! look at exponent leading zeros saving last + if (expnt(i:i) == '0') then + exp_trim = i + 1 + else + exit + end if + end do + string = trim(adjustl(significand(1:sig_trim)))// & + trim(adjustl(separator))// & + trim(adjustl(expnt(exp_trim:))) + !else ! mal-formed real, BUT this code should be unreachable + end if +end subroutine compact_real_string diff --git a/src/modules/PENF/src/CTOA.inc b/src/modules/PENF/src/CTOA.inc new file mode 100644 index 000000000..ca4810777 --- /dev/null +++ b/src/modules/PENF/src/CTOA.inc @@ -0,0 +1,212 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function ctor_R16P(str, knd, pref, error) result(n) + !< Convert string to real. + !< + !<```fortran + !< use penf + !< print FR16P, cton(str='-1.0', knd=1._R16P) + !<``` + !=> -0.100000000000000000000000000000000E+0001 <<< + character(*), intent(in) :: str !< String containing input number. + real(R16P), intent(in) :: knd !< Number kind. + character(*), optional, intent(in) :: pref !< Prefixing string. + integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. + real(R16P) :: n !< Number returned. + integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. + character(len=:), allocatable :: prefd !< Prefixing string. + + read (str, *, iostat=err) n ! Casting of str to n. + if (err /= 0) then + prefd = ''; if (present(pref)) prefd = pref + write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to real failed! real(', kind(knd), ')' + end if + if (present(error)) error = err +end function ctor_R16P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function ctor_R8P(str, knd, pref, error) result(n) + !< Convert string to real. + !< + !<```fortran + !< use penf + !< print FR8P, cton(str='-1.0', knd=1._R8P) + !<``` + !=> -0.100000000000000E+001 <<< + character(*), intent(in) :: str !< String containing input number. + real(R8P), intent(in) :: knd !< Number kind. + character(*), optional, intent(in) :: pref !< Prefixing string. + integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. + real(R8P) :: n !< Number returned. + integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. + character(len=:), allocatable :: prefd !< Prefixing string. + + read (str, *, iostat=err) n ! Casting of str to n. + if (err /= 0) then + prefd = ''; if (present(pref)) prefd = pref + write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to real failed! real(', kind(knd), ')' + end if + if (present(error)) error = err +end function ctor_R8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function ctor_R4P(str, knd, pref, error) result(n) + !< Convert string to real. + !< + !<```fortran + !< use penf + !< print FR4P, cton(str='-1.0', knd=1._R4P) + !<``` + !=> -0.100000E+01 <<< + character(*), intent(in) :: str !< String containing input number. + real(R4P), intent(in) :: knd !< Number kind. + character(*), optional, intent(in) :: pref !< Prefixing string. + integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. + real(R4P) :: n !< Number returned. + integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. + character(len=:), allocatable :: prefd !< Prefixing string. + + read (str, *, iostat=err) n ! Casting of str to n. + if (err /= 0) then + prefd = ''; if (present(pref)) prefd = pref + write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to real failed! real(', kind(knd), ')' + end if + if (present(error)) error = err +end function ctor_R4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function ctoi_I8P(str, knd, pref, error) result(n) + !< Convert string to integer. + !< + !<```fortran + !< use penf + !< print FI8P, cton(str='-1', knd=1_I8P) + !<``` + !=> -1 <<< + character(*), intent(in) :: str !< String containing input number. + integer(I8P), intent(in) :: knd !< Number kind. + character(*), optional, intent(in) :: pref !< Prefixing string. + integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. + integer(I8P) :: n !< Number returned. + integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. + character(len=:), allocatable :: prefd !< Prefixing string. + + read (str, *, iostat=err) n ! Casting of str to n. + if (err /= 0) then + prefd = ''; if (present(pref)) prefd = pref + write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' + end if + if (present(error)) error = err +end function ctoi_I8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function ctoi_I4P(str, knd, pref, error) result(n) + !< Convert string to integer. + !< + !<```fortran + !< use penf + !< print FI4P, cton(str='-1', knd=1_I4P) + !<``` + !=> -1 <<< + character(*), intent(in) :: str !< String containing input number. + integer(I4P), intent(in) :: knd !< Number kind. + character(*), optional, intent(in) :: pref !< Prefixing string. + integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. + integer(I4P) :: n !< Number returned. + integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. + character(len=:), allocatable :: prefd !< Prefixing string. + + read (str, *, iostat=err) n ! Casting of str to n. + if (err /= 0) then + prefd = ''; if (present(pref)) prefd = pref + write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' + end if + if (present(error)) error = err +end function ctoi_I4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function ctoi_I2P(str, knd, pref, error) result(n) + !< Convert string to integer. + !< + !<```fortran + !< use penf + !< print FI2P, cton(str='-1', knd=1_I2P) + !<``` + !=> -1 <<< + character(*), intent(in) :: str !< String containing input number. + integer(I2P), intent(in) :: knd !< Number kind. + character(*), optional, intent(in) :: pref !< Prefixing string. + integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. + integer(I2P) :: n !< Number returned. + integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. + character(len=:), allocatable :: prefd !< Prefixing string. + + read (str, *, iostat=err) n ! Casting of str to n. + if (err /= 0) then + prefd = ''; if (present(pref)) prefd = pref + write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' + end if + if (present(error)) error = err +end function ctoi_I2P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +function ctoi_I1P(str, knd, pref, error) result(n) + !< Convert string to integer. + !< + !<```fortran + !< use penf + !< print FI1P, cton(str='-1', knd=1_I1P) + !<``` + !=> -1 <<< + character(*), intent(in) :: str !< String containing input number. + integer(I1P), intent(in) :: knd !< Number kind. + character(*), optional, intent(in) :: pref !< Prefixing string. + integer(I4P), optional, intent(out) :: error !< Error trapping flag: 0 no errors, >0 error occurs. + integer(I1P) :: n !< Number returned. + integer(I4P) :: err !< Error trapping flag: 0 no errors, >0 error occurs. + character(len=:), allocatable :: prefd !< Prefixing string. + + read (str, *, iostat=err) n ! Casting of str to n. + if (err /= 0) then + prefd = ''; if (present(pref)) prefd = pref + write(stderr, '(A,I1,A)') prefd//' Error: conversion of string "'//str//'" to integer failed! integer(', kind(knd), ')' + end if + if (present(error)) error = err +end function ctoi_I1P diff --git a/src/modules/PENF/src/STR.inc b/src/modules/PENF/src/STR.inc new file mode 100644 index 000000000..894fff6f3 --- /dev/null +++ b/src/modules/PENF/src/STR.inc @@ -0,0 +1,1039 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(fm=FR16P, n=1._R16P) +!``` + +elemental function strf_R16P(fm, n) result(str) + character(*), intent(in) :: fm + !! Format different from the standard for the kind. + real(R16P), intent(in) :: n + !! Real to be converted. + character(DR16P) :: str + !! Returned string containing input number. + + write (str, trim(fm)) n +end function strf_R16P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(fm=FR8P, n=1._R8P) +!``` + +elemental function strf_R8P(fm, n) result(str) + character(*), intent(in) :: fm + !! Format different from the standard for the kind. + real(R8P), intent(in) :: n + !! Real to be converted. + character(DR8P) :: str + !! Returned string containing input number. + write (str, trim(fm)) n +end function strf_R8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(fm=FR4P, n=1._R4P) +!``` + +elemental function strf_R4P(fm, n) result(str) + character(*), intent(in) :: fm + !! Format different from the standard for the kind. + real(R4P), intent(in) :: n + !! Real to be converted. + character(DR4P) :: str + !! Returned string containing input number. + write (str, trim(fm)) n +end function strf_R4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(fm=FI8P, n=1_I8P) +!``` + +elemental function strf_I8P(fm, n) result(str) + character(*), intent(in) :: fm + !! Format different from the standard for the kind. + integer(I8P), intent(in) :: n + !! Integer to be converted. + character(DI8P) :: str + !! Returned string containing input number. + write (str, trim(fm)) n +end function strf_I8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(fm=FI4P, n=1_I4P) +!``` + +elemental function strf_I4P(fm, n) result(str) + character(*), intent(in) :: fm + !! Format different from the standard for the kind. + integer(I4P), intent(in) :: n + !! Integer to be converted. + character(DI4P) :: str + !! Returned string containing input number. + write (str, trim(fm)) n +end function strf_I4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(fm=FI2P, n=1_I2P) +!``` + +elemental function strf_I2P(fm, n) result(str) + character(*), intent(in) :: fm + !! Format different from the standard for the kind. + integer(I2P), intent(in) :: n + !! Integer to be converted. + character(DI2P) :: str + !! Returned string containing input number. + write (str, trim(fm)) n +end function strf_I2P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(fm=FI1P, n=1_I1P) +!``` + +elemental function strf_I1P(fm, n) result(str) + character(*), intent(in) :: fm + !! Format different from the standard for the kind. + integer(I1P), intent(in) :: n + !! Integer to be converted. + character(DI1P) :: str + !! Returned string containing input number. + + write (str, trim(fm)) n +end function strf_I1P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(n=-1._R16P) +!``` +!=> -0.100000000000000000000000000000000E+0001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1._R16P, no_sign=.true.) +!``` +!=> 0.100000000000000000000000000000000E+0001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1._R16P, compact=.true.) +!``` + +elemental function str_R16P(n, no_sign, compact) result(str) + real(R16P), intent(in) :: n + !! Real to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + logical, intent(in), optional :: compact + !! Flag for *compacting* string encoding. + character(DR16P) :: str + !! Returned string containing input number. + !! + write (str, FR16P) n ! Casting of n to string. + !! + if (present(no_sign)) then + if (.not. no_sign) then + if (n > 0._R16P) str(1:1) = '+' ! Prefixing plus if n>0. + end if + end if + !! + if (present(compact)) then + if (compact) call compact_real_string(string=str) + end if + !! +end function str_R16P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=-1._R8P) +!``` +!=> -0.100000000000000E+001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1._R8P, no_sign=.true.) +!``` +!=> 0.100000000000000E+001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1._R8P, compact=.true.) +!``` + +elemental function str_R8P(n, no_sign, compact) result(str) + real(R8P), intent(in) :: n + !! Real to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + logical, intent(in), optional :: compact + !! Flag for *compacting* string encoding. + character(DR8P) :: str + !! Returned string containing input number. + !! + write (str, FR8P) n ! Casting of n to string. + !! + if (present(no_sign)) then + if (.not. no_sign) then + if (n > 0._R8P) str(1:1) = '+' ! Prefixing plus if n>0. + end if + end if + !! + if (present(compact)) then + if (compact) call compact_real_string(string=str) + end if +end function str_R8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=-1._R4P) +!``` +!=> -0.100000E+01 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1._R4P, no_sign=.true.) +!``` +!=> 0.100000E+01 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1._R4P, compact=.true.) +!``` + +elemental function str_R4P(n, no_sign, compact) result(str) + real(R4P), intent(in) :: n + !! Real to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + logical, intent(in), optional :: compact + !! Flag for *compacting* string encoding. + character(DR4P) :: str + !! Returned string containing input number. + !! + write (str, FR4P) n ! Casting of n to string. + !! + if (present(no_sign)) then + if (.not. no_sign) then + if (n > 0._R4P) str(1:1) = '+' ! Prefixing plus if n>0. + end if + end if + !! + if (present(compact)) then + if (compact) call compact_real_string(string=str) + end if +end function str_R4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=-1_I8P) +!``` +!=> -1 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1_I8P, no_sign=.true.) +!``` + +elemental function str_I8P(n, no_sign) result(str) + integer(I8P), intent(in) :: n + !! Integer to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(DI8P) :: str + !! Returned string containing input number plus padding zeros. + + write (str, FI8P) n ! Casting of n to string. + str = adjustl(trim(str)) ! Removing white spaces. + !! + if (present(no_sign)) then + if (.not. no_sign) then + if (n >= 0_I8P) str = '+'//trim(str) ! Prefixing plus if n>0. + end if + end if + !! +end function str_I8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Converting integer to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(n=-1_I4P) +!``` +!=> -1 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1_I4P, no_sign=.true.) +!``` +!=> 1 <<< + +elemental function str_I4P(n, no_sign) result(str) + integer(I4P), intent(in) :: n + !! Integer to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(DI4P) :: str + !! Returned string containing input number plus padding zeros. + !! + write (str, FI4P) n ! Casting of n to string. + str = adjustl(trim(str)) ! Removing white spaces. + !! + if (present(no_sign)) then + if (.not. no_sign) then + if (n >= 0_I4P) str = '+'//trim(str) ! Prefixing plus if n>0. + end if + end if + !! +end function str_I4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=-1_I2P) +!``` +!=> -1 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1_I2P, no_sign=.true.) +!``` +!=> 1 <<< + +elemental function str_I2P(n, no_sign) result(str) + integer(I2P), intent(in) :: n + !! Integer to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(DI2P) :: str + !! Returned string containing input number plus padding zeros. + + write (str, FI2P) n ! Casting of n to string. + str = adjustl(trim(str)) ! Removing white spaces. + !! + if (present(no_sign)) then + if (.not. no_sign) then + if (n >= 0_I2P) str = '+'//trim(str) ! Prefixing plus if n>0. + end if + end if + !! +end function str_I2P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(n=-1_I1P) +!``` +!=> -1 <<< +! +!```fortran +! use penf +! print "(A)", str(n=-1_I1P, no_sign=.true.) +!``` +!=> 1 <<< + +elemental function str_I1P(n, no_sign) result(str) + integer(I1P), intent(in) :: n + !! Integer to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(DI1P) :: str + !! Returned string containing input number plus padding zeros. + + write (str, FI1P) n ! Casting of n to string. + str = adjustl(trim(str)) ! Removing white spaces. + !! + if (present(no_sign)) then + if (.not. no_sign) then + if (n >= 0_I1P) str = '+'//trim(str) ! Prefixing plus if n>0. + end if + end if + !! +end function str_I1P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert logical to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(n=.true.) +!``` +!=> T <<< + +elemental function str_bol(n) result(str) + logical, intent(in) :: n + !! Logical to be converted. + character(1) :: str + !! Returned string containing input number plus padding zeros. + + write (str, '(L1)') n +end function str_bol + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Converting real array to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=[1._R16P, -2._R16P]) +!``` +!=> +0.100000000000000000000000000000000E+0001, +! -0.200000000000000000000000000000000E+0001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R16P, 2._R16P], no_sign=.true.) +!``` +!=> 0.100000000000000000000000000000000E+0001, +! 0.200000000000000000000000000000000E+0001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R16P, -2._R16P], separator='|') +!``` +!=> +0.100000000000000000000000000000000E+0001| +! -0.200000000000000000000000000000000E+0001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R16P, -2._R16P], delimiters=['(', ')']) +!``` +!=> (+0.100000000000000000000000000000000E+0001, +! -0.200000000000000000000000000000000E+0001) <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R16P, -2._R16P], compact=.true.) +!``` +!=> +0.1E+1,-0.2E+1 <<< + +pure function str_a_R16P(n, no_sign, separator, delimiters, compact) & + & result(str) + real(R16P), intent(in) :: n(:) + !! Real array to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(1), intent(in), optional :: separator + !! Eventual separator of array values. + character(*), intent(in), optional :: delimiters(1:2) + !! Eventual delimiters of array values. + logical, intent(in), optional :: compact + !! Flag for *compacting* string encoding. + character(len=:), allocatable :: str + !! Returned string containing input number. + character(DR16P) :: strn + !! String containing of element of input array number. + character(len=1) :: sep + !! Array values separator + integer :: i + !! Counter. + !! + str = '' + sep = ',' + if (present(separator)) sep = separator + do i = 1, size(n) + strn = str_R16P(no_sign=no_sign, compact=compact, n=n(i)) + str = str//sep//trim(strn) + end do + str = trim(str(2:)) + if (present(delimiters)) str = delimiters(1)//str//delimiters(2) +end function str_a_R16P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real array to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(n=[1._R8P, -2._R8P]) +!``` +!=> +0.100000000000000E+001,-0.200000000000000E+001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R8P, 2._R8P], no_sign=.true.) +!``` +!=> 0.100000000000000E+001,0.200000000000000E+001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R8P, -2._R8P], separator='|') +!``` +!=> +0.100000000000000E+001|-0.200000000000000E+001 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R8P, -2._R8P], delimiters=['(', ')']) +!``` +!=> (+0.100000000000000E+001,-0.200000000000000E+001) <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R8P, -2._R8P], compact=.true.) +!``` +!=> +0.1E+1,-0.2E+1 <<< + +pure function str_a_R8P(n, no_sign, separator, delimiters, compact) & + & result(str) + real(R8P), intent(in) :: n(:) + !! Real array to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(1), intent(in), optional :: separator + !! Eventual separator of array values. + character(*), intent(in), optional :: delimiters(1:2) + !! Eventual delimiters of array values. + logical, intent(in), optional :: compact + !! Flag for *compacting* string encoding. + character(len=:), allocatable :: str + !! Returned string containing input number. + character(DR8P) :: strn + !! String containing of element of input array number. + character(len=1) :: sep + !! Array values separator + integer :: i + !! Counter. + str = '' + sep = ',' + if (present(separator)) sep = separator + do i = 1, size(n) + strn = str_R8P(no_sign=no_sign, compact=compact, n=n(i)) + str = str//sep//trim(strn) + end do + str = trim(str(2:)) + if (present(delimiters)) str = delimiters(1)//str//delimiters(2) +end function str_a_R8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert real array to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(n=[1._R4P, -2._R4P]) +!``` +!=> +0.100000E+01,-0.200000E+01 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R4P, 2._R4P], no_sign=.true.) +!``` +!=> 0.100000E+01,0.200000E+01 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R4P, -2._R4P], separator='|') +!``` +!=> +0.100000E+01|-0.200000E+01 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R4P, -2._R4P], delimiters=['(', ')']) +!``` +!=> (+0.100000E+01,-0.200000E+01) <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1._R4P, -2._R4P], compact=.true.) +!``` +!=> +0.1E+1,-0.2E+1 <<< + +pure function str_a_R4P(n, no_sign, separator, delimiters, compact) & + & result(str) + real(R4P), intent(in) :: n(:) + !! Real array to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(1), intent(in), optional :: separator + !! Eventual separator of array values. + character(*), intent(in), optional :: delimiters(1:2) + !! Eventual delimiters of array values. + logical, intent(in), optional :: compact + !! Flag for *compacting* string encoding. + character(len=:), allocatable :: str + !! Returned string containing input number. + character(DR4P) :: strn + !! String containing of element of input array number. + character(len=1) :: sep + !! Array values separator + integer :: i + !! Counter. + + str = '' + sep = ',' + if (present(separator)) sep = separator + do i = 1, size(n) + strn = str_R4P(no_sign=no_sign, compact=compact, n=n(i)) + str = str//sep//trim(strn) + end do + str = trim(str(2:)) + if (present(delimiters)) str = delimiters(1)//str//delimiters(2) +end function str_a_R4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer array to string. +! +!# Introduction +! +! +!```fortran +! use penf +! print "(A)", str(n=[1_I8P, -2_I8P]) +!``` +!=> +1,-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I8P, 2_I8P], no_sign=.true.) +!``` +!=> 1,2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I8P, -2_I8P], separator='|') +!``` +!=> +1|-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I8P, -2_I8P], delimiters=['(', ')']) +!``` +!=> (+1,-2) <<< + +pure function str_a_I8P(n, no_sign, separator, delimiters) result(str) + integer(I8P), intent(in) :: n(:) + !! Integer array to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(1), intent(in), optional :: separator + !! Eventual separator of array values. + character(*), intent(in), optional :: delimiters(1:2) + !! Eventual delimiters of array values. + character(len=:), allocatable :: str + !! Returned string containing input number. + character(DI8P) :: strn + !! String containing of element of input array number. + character(len=1) :: sep + !! Array values separator + integer :: i + !! Counter. + str = '' + sep = ',' + if (present(separator)) sep = separator + if (present(no_sign)) then + do i = 1, size(n) + strn = str_I8P(no_sign=no_sign, n=n(i)) + str = str//sep//trim(strn) + end do + else + do i = 1, size(n) + strn = str_I8P(n=n(i)) + str = str//sep//trim(strn) + end do + end if + str = trim(str(2:)) + if (present(delimiters)) str = delimiters(1)//str//delimiters(2) +end function str_a_I8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer array to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=[1_I4P, -2_I4P]) +!``` +!=> +1,-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I4P, 2_I4P], no_sign=.true.) +!``` +!=> 1,2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I4P, -2_I4P], separator='|') +!``` +!=> +1|-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I4P, -2_I4P], delimiters=['(', ')']) +!``` +!=> (+1,-2) <<< + +pure function str_a_I4P(n, no_sign, separator, delimiters) result(str) + integer(I4P), intent(in) :: n(:) + !! Integer array to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(1), intent(in), optional :: separator + !! Eventual separator of array values. + character(*), intent(in), optional :: delimiters(1:2) + !! Eventual delimiters of array values. + character(len=:), allocatable :: str + !! Returned string containing input number. + character(DI4P) :: strn + !! String containing of element of input array number. + character(len=1) :: sep + !! Array values separator + integer :: i + !! Counter. + !! + str = '' + sep = ',' + if (present(separator)) sep = separator + if (present(no_sign)) then + do i = 1, size(n) + strn = str_I4P(no_sign=no_sign, n=n(i)) + str = str//sep//trim(strn) + end do + else + do i = 1, size(n) + strn = str_I4P(n=n(i)) + str = str//sep//trim(strn) + end do + end if + str = trim(str(2:)) + if (present(delimiters)) str = delimiters(1)//str//delimiters(2) +end function str_a_I4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer array to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=[1_I2P, -2_I2P]) +!``` +!=> +1,-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I2P, 2_I2P], no_sign=.true.) +!``` +!=> 1,2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I2P, -2_I2P], separator='|') +!``` +!=> +1|-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I2P, -2_I2P], delimiters=['(', ')']) +!``` +!=> (+1,-2) <<< + +pure function str_a_I2P(n, no_sign, separator, delimiters) result(str) + integer(I2P), intent(in) :: n(:) + !! Integer array to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(1), intent(in), optional :: separator + !! Eventual separator of array values. + character(*), intent(in), optional :: delimiters(1:2) + !! Eventual delimiters of array values. + character(len=:), allocatable :: str + !! Returned string containing input number. + character(DI2P) :: strn + !! String containing of element of input array number. + character(len=1) :: sep + !! Array values separator + integer :: i + !! Counter. + !! + str = '' + sep = ',' + if (present(separator)) sep = separator + if (present(no_sign)) then + do i = 1, size(n) + strn = str_I2P(no_sign=no_sign, n=n(i)) + str = str//sep//trim(strn) + end do + else + do i = 1, size(n) + strn = str_I2P(n=n(i)) + str = str//sep//trim(strn) + end do + end if + str = trim(str(2:)) + if (present(delimiters)) str = delimiters(1)//str//delimiters(2) +end function str_a_I2P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: +! summary: Convert integer array to string. +! +!# Introduction +! +!```fortran +! use penf +! print "(A)", str(n=[1_I1P, -2_I1P]) +!``` +!=> +1,-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I1P, 2_I1P], no_sign=.true.) +!``` +!=> 1,2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I1P, -2_I1P], separator='|') +!``` +!=> +1|-2 <<< +! +!```fortran +! use penf +! print "(A)", str(n=[1_I1P, -2_I1P], delimiters=['(', ')']) +!``` +!=> (+1,-2) <<< + +pure function str_a_I1P(n, no_sign, separator, delimiters) result(str) + integer(I1P), intent(in) :: n(:) + !! Integer array to be converted. + logical, intent(in), optional :: no_sign + !! Flag for leaving out the sign. + character(1), intent(in), optional :: separator + !! Eventual separator of array values. + character(*), intent(in), optional :: delimiters(1:2) + !! Eventual delimiters of array values. + character(len=:), allocatable :: str + !! Returned string containing input number. + character(DI1P) :: strn + !! String containing of element of input array number. + character(len=1) :: sep + !! Array values separator + integer :: i + !! Counter. + + str = '' + sep = ',' + if (present(separator)) sep = separator + if (present(no_sign)) then + do i = 1, size(n) + strn = str_I1P(no_sign=no_sign, n=n(i)) + str = str//sep//trim(strn) + end do + else + do i = 1, size(n) + strn = str_I1P(n=n(i)) + str = str//sep//trim(strn) + end do + end if + str = trim(str(2:)) + if (present(delimiters)) str = delimiters(1)//str//delimiters(2) +end function str_a_I1P diff --git a/src/modules/PENF/src/STRZ.inc b/src/modules/PENF/src/STRZ.inc new file mode 100644 index 000000000..c96591a15 --- /dev/null +++ b/src/modules/PENF/src/STRZ.inc @@ -0,0 +1,108 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +elemental function strz_I8P(n, nz_pad) result(str) + !< Converting integer to string, prefixing with the right number of zeros. + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I8P) + !<``` + !=> 0000000000000000001 <<< + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I8P, nz_pad=5) + !<``` + !=> 00001 <<< + integer(I8P), intent(in) :: n !< Integer to be converted. + integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. + character(DI8P) :: str !< Returned string containing input number plus padding zeros. + + write (str, FI8PZP) n ! Casting of n to string. + str = str(2:) ! Leaving out the sign. + if (present(nz_pad)) str = str(DI8P - nz_pad:DI8P - 1) ! Leaving out the extra zeros padding +end function strz_I8P + +elemental function strz_I4P(n, nz_pad) result(str) + !< Convert integer to string, prefixing with the right number of zeros. + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I4P) + !<``` + !=> 0000000001 <<< + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I4P, nz_pad=5) + !<``` + !=> 00001 <<< + integer(I4P), intent(in) :: n !< Integer to be converted. + integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. + character(DI4P) :: str !< Returned string containing input number plus padding zeros. + + write (str, FI4PZP) n ! Casting of n to string. + str = str(2:) ! Leaving out the sign. + if (present(nz_pad)) str = str(DI4P - nz_pad:DI4P - 1) ! Leaving out the extra zeros padding +end function strz_I4P + +elemental function strz_I2P(n, nz_pad) result(str) + !< Convert integer to string, prefixing with the right number of zeros. + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I2P) + !<``` + !=> 00001 <<< + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I2P, nz_pad=3) + !<``` + !=> 001 <<< + integer(I2P), intent(in) :: n !< Integer to be converted. + integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. + character(DI2P) :: str !< Returned string containing input number plus padding zeros. + + write (str, FI2PZP) n ! Casting of n to string. + str = str(2:) ! Leaving out the sign. + if (present(nz_pad)) str = str(DI2P - nz_pad:DI2P - 1) ! Leaving out the extra zeros padding +end function strz_I2P + +elemental function strz_I1P(n, nz_pad) result(str) + !< Convert integer to string, prefixing with the right number of zeros. + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I1P) + !<``` + !=> 001 <<< + !< + !<```fortran + !< use penf + !< print "(A)", strz(n=1_I1P, nz_pad=3) + !<``` + !=> 001 <<< + integer(I1P), intent(in) :: n !< Integer to be converted. + integer(I4P), intent(in), optional :: nz_pad !< Number of zeros padding. + character(DI1P) :: str !< Returned string containing input number plus padding zeros. + + write (str, FI1PZP) n ! Casting of n to string. + str = str(2:) ! Leaving out the sign. + if (present(nz_pad)) str = str(DI1P - nz_pad:DI1P - 1) ! Leaving out the extra zeros padding +end function strz_I1P diff --git a/src/modules/PENF/src/STR_ASCII.inc b/src/modules/PENF/src/STR_ASCII.inc new file mode 100644 index 000000000..bafc58c87 --- /dev/null +++ b/src/modules/PENF/src/STR_ASCII.inc @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +pure function str_ascii_default(input) result(output) + !< Convert string of default kind to ASCII string. + !< + !<```fortran + !< use penf + !< character(len=:, kind=ASCII), allocatable :: string + !< string = str_ascii('I was DEFAULT kind, but now I am ASCII') + !< print "(A)", string + !<``` + !=> I was DEFAULT kind, but now I am ASCII <<< + character(len=*), intent(in) :: input !< Input string of default kind. + character(len=:, kind=ASCII), allocatable :: output !< Output string of ASCII kind. + + output = input +end function str_ascii_default + +pure function str_ascii_ascii(input) result(output) + !< Convert string of ASCII kind to ASCII string, just for convenience in sanitize strings. + !< + !<```fortran + !< use penf + !< character(len=:, kind=ASCII), allocatable :: string + !< string = str_ascii('I was ASCII kind and I am still ASCII') + !< print "(A)", string + !<``` + !=> I was ASCII kind and I am still ASCII <<< + character(len=*, kind=ASCII), intent(in) :: input !< Input string of ASCII kind. + character(len=:, kind=ASCII), allocatable :: output !< Output string of ASCII kind. + + output = input +end function str_ascii_ascii + +pure function str_ascii_ucs4(input) result(output) + !< Convert string of UCS4 kind to ASCII string. + !< + !<```fortran + !< use penf + !< character(len=:, kind=ASCII), allocatable :: string + !< string = str_ascii(UCS4_'I was UCS4 kind, but now I am ASCII') + !< print "(A)", string + !<``` + !=> I was UCS4 kind, but now I am ASCII <<< + character(len=*, kind=UCS4), intent(in) :: input !< Input string of UCS4 kind. + character(len=:, kind=ASCII), allocatable :: output !< Output string of ASCII kind. + + output = input +end function str_ascii_ucs4 diff --git a/src/modules/PENF/src/STR_UCS4.inc b/src/modules/PENF/src/STR_UCS4.inc new file mode 100644 index 000000000..de028abf0 --- /dev/null +++ b/src/modules/PENF/src/STR_UCS4.inc @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +pure function str_ucs4_default(input) result(output) + !< Convert string of default kind to UCS4 string. + !< + !<```fortran + !< use penf + !< character(len=:, kind=UCS4), allocatable :: string + !< string = str_ascii('I was DEFAULT kind, but now I am UCS4') + !< print "(A)", string + !<``` + !=> I was DEFAULT kind, but now I am UCS4 <<< + character(len=*), intent(in) :: input !< Input string of default kind. + character(len=:, kind=UCS4), allocatable :: output !< Output string of UCS4 kind. + + output = input +end function str_ucs4_default + +pure function str_ucs4_ascii(input) result(output) + !< Convert string of ASCII kind to UCS4 string. + !< + !<```fortran + !< use penf + !< character(len=:, kind=UCS4), allocatable :: string + !< string = str_ascii(ASCII_'I was ASCII kind, but now I am UCS4') + !< print "(A)", string + !<``` + !=> I was ASCII kind, but now I am UCS4 <<< + character(len=*, kind=ASCII), intent(in) :: input !< Input string of ASCII kind. + character(len=:, kind=UCS4), allocatable :: output !< Output string of UCS4 kind. + + output = input +end function str_ucs4_ascii + +pure function str_ucs4_ucs4(input) result(output) + !< Convert string of UCS4 kind to UCS4 string, just for convenience in sanitize strings. + !< + !<```fortran + !< use penf + !< character(len=:, kind=UCS4), allocatable :: string + !< string = str_ascii(UCS4_'I was UCS4 kind and I am still UCS4') + !< print "(A)", string + !<``` + !=> I was UCS4 kind and I am still UCS4 <<< + character(len=*, kind=UCS4), intent(in) :: input !< Input string of UCS4 kind. + character(len=:, kind=UCS4), allocatable :: output !< Output string of UCS4 kind. + + output = input +end function str_ucs4_ucs4 diff --git a/src/modules/PENF/src/penf.F90 b/src/modules/PENF/src/penf.F90 new file mode 100644 index 000000000..720764b20 --- /dev/null +++ b/src/modules/PENF/src/penf.F90 @@ -0,0 +1,239 @@ +!< Portability Environment for Fortran poor people. + +module penf +!< Portability Environment for Fortran poor people. +use penf_global_parameters_variables +#ifdef __INTEL_COMPILER +use penf_b_size +#else +use penf_b_size, only : bit_size, byte_size +#endif +use penf_stringify, only : str_ascii, str_ucs4, str, strz, cton, bstr, bcton + +implicit none +private +save +! global parameters and variables +public :: endianL, endianB, endian, is_initialized +public :: ASCII, UCS4, CK +public :: R16P, FR16P, DR16P, MinR16P, MaxR16P, BIR16P, BYR16P, smallR16P, ZeroR16P +public :: R8P, FR8P, DR8P, MinR8P, MaxR8P, BIR8P, BYR8P, smallR8P, ZeroR8P +public :: R4P, FR4P, DR4P, MinR4P, MaxR4P, BIR4P, BYR4P, smallR4P, ZeroR4P +public :: R_P, FR_P, DR_P, MinR_P, MaxR_P, BIR_P, BYR_P, smallR_P, ZeroR_P +public :: I8P, FI8P, DI8P, MinI8P, MaxI8P, BII8P, BYI8P +public :: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P +public :: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P +public :: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P +public :: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P +public :: CHARACTER_KINDS_LIST, REAL_KINDS_LIST, REAL_FORMATS_LIST +public :: INTEGER_KINDS_LIST, INTEGER_FORMATS_LIST +! bit/byte size functions +public :: bit_size, byte_size +! stringify facility +public :: str_ascii, str_ucs4 +public :: str, strz, cton +public :: bstr, bcton +! miscellanea facility +public :: check_endian +public :: digit +public :: penf_Init +public :: penf_print + +integer, protected :: endian = endianL !< Bit ordering: Little endian (endianL), or Big endian (endianB). +logical, protected :: is_initialized = .false. !< Check the initialization of some variables that must be initialized. + +#ifdef __GFORTRAN__ +! work-around for strange gfortran bug... +interface bit_size + !< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables. +endinterface +#endif + +interface digit + !< Compute the number of digits in decimal base of the input integer. + module procedure digit_I8, digit_I4, digit_I2, digit_I1 +endinterface + +contains + ! public procedures + subroutine check_endian() + !< Check the type of bit ordering (big or little endian) of the running architecture. + !< + !> @note The result is stored into the *endian* global variable. + !< + !<```fortran + !< use penf + !< call check_endian + !< print *, endian + !<``` + !=> 1 <<< + if (is_little_endian()) then + endian = endianL + else + endian = endianB + endif + contains + pure function is_little_endian() result(is_little) + !< Check if the type of the bit ordering of the running architecture is little endian. + logical :: is_little !< Logical output: true is the running architecture uses little endian ordering, false otherwise. + integer(I1P) :: int1(1:4) !< One byte integer array for casting 4 bytes integer. + + int1 = transfer(1_I4P, int1) + is_little = (int1(1)==1_I1P) + endfunction is_little_endian + endsubroutine check_endian + + subroutine penf_init() + !< Initialize PENF's variables that are not initialized into the definition specification. + !< + !<```fortran + !< use penf + !< call penf_init + !< print FI1P, BYR4P + !<``` + !=> 4 <<< + + call check_endian + is_initialized = .true. + endsubroutine penf_init + + subroutine penf_print(unit, pref, iostat, iomsg) + !< Print to the specified unit the PENF's environment data. + !< + !<```fortran + !< use penf + !< integer :: u + !< open(newunit=u, status='scratch') + !< call penf_print(u) + !< close(u) + !< print "(A)", 'done' + !<``` + !=> done <<< + integer(I4P), intent(in) :: unit !< Logic unit. + character(*), intent(in), optional :: pref !< Prefixing string. + integer(I4P), intent(out), optional :: iostat !< IO error. + character(*), intent(out), optional :: iomsg !< IO error message. + character(len=:), allocatable :: prefd !< Prefixing string. + integer(I4P) :: iostatd !< IO error. + character(500) :: iomsgd !< Temporary variable for IO error message. + + if (.not.is_initialized) call penf_init + prefd = '' ; if (present(pref)) prefd = pref + if (endian==endianL) then + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has LITTLE Endian bit ordering' + else + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has BIG Endian bit ordering' + endif + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Character kind:' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ASCII: '//str(n=ASCII) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' UCS4: '//str(n=UCS4) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' CK: '//str(n=CK) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Reals kind, format and characters number:' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R16P: '//str(n=R16P)//','//FR16P//','//str(n=DR16P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R8P: '//str(n=R8P )//','//FR8P //','//str(n=DR8P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R4P: '//str(n=R4P )//','//FR4P //','//str(n=DR4P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R_P: '//str(n=R_P )//','//FR_P //','//str(n=DR_P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Integers kind, format and characters number:' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I8P: '//str(n=I8P)//','//FI8P //','//str(n=DI8P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I4P: '//str(n=I4P)//','//FI4P //','//str(n=DI4P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I2P: '//str(n=I2P)//','//FI2P //','//str(n=DI2P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I1P: '//str(n=I1P)//','//FI1P //','//str(n=DI1P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Reals minimum and maximum values:' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R16P: '//str(n=MinR16P)//','//str(n=MaxR16P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R8P: '//str(n=MinR8P )//','//str(n=MaxR8P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R4P: '//str(n=MinR4P )//','//str(n=MaxR4P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R_P: '//str(n=MinR_P )//','//str(n=MaxR_P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Integergs minimum and maximum values:' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I8P: '//str(n=MinI8P )//','//str(n=MaxI8P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I4P: '//str(n=MinI4P )//','//str(n=MaxI4P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I2P: '//str(n=MinI2P )//','//str(n=MaxI2P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I1P: '//str(n=MinI1P )//','//str(n=MaxI1P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Reals bits/bytes sizes:' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R16P: '//str(n=BIR16P)//'/'//str(n=BYR16P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R8P: '//str(n=BIR8P )//'/'//str(n=BYR8P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R4P: '//str(n=BIR4P )//'/'//str(n=BYR4P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' R_P: '//str(n=BIR_P )//'/'//str(n=BYR_P ) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Integers bits/bytes sizes:' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I8P: '//str(n=BII8P)//'/'//str(n=BYI8P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I4P: '//str(n=BII4P)//'/'//str(n=BYI4P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I2P: '//str(n=BII2P)//'/'//str(n=BYI2P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' I1P: '//str(n=BII1P)//'/'//str(n=BYI1P) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Smallest reals' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR16P: '//str(smallR16P, .true.) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR8P: '//str(smallR8P, .true.) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR4P: '//str(smallR4P, .true.) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR_P: '//str(smallR_P, .true.) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Machine zero' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR16P: '//str(ZeroR16P, .true.) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR8P: '//str(ZeroR8P, .true.) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR4P: '//str(ZeroR4P, .true.) + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR_P: '//str(ZeroR_P, .true.) + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd + endsubroutine penf_print + + ! private procedures + elemental function digit_I8(n) result(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I8P) + !<``` + !=> 3 <<< + integer(I8P), intent(in) :: n !< Input integer. + character(DI8P) :: str !< Returned string containing input number plus padding zeros. + integer(I4P) :: digit !< Number of digits. + + write(str, FI8P) abs(n) ! Casting of n to string. + digit = len_trim(adjustl(str)) ! Calculating the digits number of n. + endfunction digit_I8 + + elemental function digit_I4(n) result(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I4P) + !<``` + !=> 3 <<< + integer(I4P), intent(in) :: n !< Input integer. + character(DI4P) :: str !< Returned string containing input number plus padding zeros. + integer(I4P) :: digit !< Number of digits. + + write(str, FI4P) abs(n) ! Casting of n to string. + digit = len_trim(adjustl(str)) ! Calculating the digits number of n. + endfunction digit_I4 + + elemental function digit_I2(n) result(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I2P) + !<``` + !=> 3 <<< + integer(I2P), intent(in) :: n !< Input integer. + character(DI2P) :: str !< Returned string containing input number plus padding zeros. + integer(I4P) :: digit !< Number of digits. + + write(str, FI2P) abs(n) ! Casting of n to string. + digit = len_trim(adjustl(str)) ! Calculating the digits number of n. + endfunction digit_I2 + + elemental function digit_I1(n) result(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I1P) + !<``` + !=> 3 <<< + integer(I1P), intent(in) :: n !< Input integer. + character(DI1P) :: str !< Returned string containing input number plus padding zeros. + integer(I4P) :: digit !< Number of digits. + + write(str, FI1P) abs(n) ! Casting of n to string. + digit = len_trim(adjustl(str)) ! Calculating the digits number of n. + endfunction digit_I1 +endmodule penf diff --git a/src/modules/PENF/src/penf_b_size.F90 b/src/modules/PENF/src/penf_b_size.F90 new file mode 100644 index 000000000..13054b874 --- /dev/null +++ b/src/modules/PENF/src/penf_b_size.F90 @@ -0,0 +1,227 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!< PENF bit/byte size functions. + +module penf_b_size +!< PENF bit/byte size functions. +use penf_global_parameters_variables + +implicit none +private +save +public :: bit_size, byte_size + +interface bit_size + !< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables. + module procedure & +#if defined _R16P + bit_size_R16P, & +#endif + bit_size_R8P, & + bit_size_R4P, & + bit_size_chr +end interface + +interface byte_size + !< Compute the number of bytes of a variable. + module procedure & + byte_size_I8P, & + byte_size_I4P, & + byte_size_I2P, & + byte_size_I1P, & +#if defined _R16P + byte_size_R16P, & +#endif + byte_size_R8P, & + byte_size_R4P, & + byte_size_chr +end interface + +contains +elemental function bit_size_R16P(i) result(bits) + !< Compute the number of bits of a real variable. + !< + !<```fortran + !< use penf + !< print FI2P, bit_size(1._R16P) + !<``` + !=> 128 <<< + real(R16P), intent(in) :: i !< Real variable whose number of bits must be computed. + integer(I2P) :: bits !< Number of bits of r. + integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + + bits = size(transfer(i, mold), dim=1, kind=I2P) * 8_I2P +end function bit_size_R16P + +elemental function bit_size_R8P(i) result(bits) + !< Compute the number of bits of a real variable. + !< + !<```fortran + !< use penf + !< print FI1P, bit_size(1._R8P) + !<``` + !=> 64 <<< + real(R8P), intent(in) :: i !< Real variable whose number of bits must be computed. + integer(I1P) :: bits !< Number of bits of r. + integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + + bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P +end function bit_size_R8P + +elemental function bit_size_R4P(i) result(bits) + !< Compute the number of bits of a real variable. + !< + !<```fortran + !< use penf + !< print FI1P, bit_size(1._R4P) + !<``` + !=> 32 <<< + real(R4P), intent(in) :: i !< Real variable whose number of bits must be computed. + integer(I1P) :: bits !< Number of bits of r. + integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + + bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P +end function bit_size_R4P + +elemental function bit_size_chr(i) result(bits) + !< Compute the number of bits of a character variable. + !< + !<```fortran + !< use penf + !< print FI4P, bit_size('ab') + !<``` + !=> 16 <<< + character(*), intent(IN) :: i !< Character variable whose number of bits must be computed. + integer(I4P) :: bits !< Number of bits of c. + integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + + bits = size(transfer(i, mold), dim=1, kind=I4P) * 8_I4P +end function bit_size_chr + +elemental function byte_size_R16P(i) result(bytes) + !< Compute the number of bytes of a real variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size(1._R16P) + !<``` + !=> 16 <<< + real(R16P), intent(in) :: i !< Real variable whose number of bytes must be computed. + integer(I1P) :: bytes !< Number of bytes of r. + + bytes = bit_size(i) / 8_I1P +end function byte_size_R16P + +elemental function byte_size_R8P(i) result(bytes) + !< Compute the number of bytes of a real variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size(1._R8P) + !<``` + !=> 8 <<< + real(R8P), intent(in) :: i !< Real variable whose number of bytes must be computed. + integer(I1P) :: bytes !< Number of bytes of r. + + bytes = bit_size(i) / 8_I1P +end function byte_size_R8P + +elemental function byte_size_R4P(i) result(bytes) + !< Compute the number of bytes of a real variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size(1._R4P) + !<``` + !=> 4 <<< + real(R4P), intent(in) :: i !< Real variable whose number of bytes must be computed. + integer(I1P) :: bytes !< Number of bytes of r. + + bytes = bit_size(i) / 8_I1P +end function byte_size_R4P + +elemental function byte_size_chr(i) result(bytes) + !< Compute the number of bytes of a character variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size('ab') + !<``` + !=> 2 <<< + character(*), intent(in) :: i !< Character variable whose number of bytes must be computed. + integer(I4P) :: bytes !< Number of bytes of c. + + bytes = bit_size(i) / 8_I4P +end function byte_size_chr + +elemental function byte_size_I8P(i) result(bytes) + !< Compute the number of bytes of an integer variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size(1_I8P) + !<``` + !=> 8 <<< + integer(I8P), intent(in) :: i !< Integer variable whose number of bytes must be computed. + integer(I1P) :: bytes !< Number of bytes of i. + + bytes = bit_size(i) / 8_I1P +end function byte_size_I8P + +elemental function byte_size_I4P(i) result(bytes) + !< Compute the number of bytes of an integer variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size(1_I4P) + !<``` + !=> 4 <<< + integer(I4P), intent(in) :: i !< Integer variable whose number of bytes must be computed. + integer(I1P) :: bytes !< Number of bytes of i. + + bytes = bit_size(i) / 8_I1P +end function byte_size_I4P + +elemental function byte_size_I2P(i) result(bytes) + !< Compute the number of bytes of an integer variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size(1_I2P) + !<``` + !=> 2 <<< + integer(I2P), intent(in) :: i !< Integer variable whose number of bytes must be computed. + integer(I1P) :: bytes !< Number of bytes of i. + + bytes = bit_size(i) / 8_I1P +end function byte_size_I2P + +elemental function byte_size_I1P(i) result(bytes) + !< Compute the number of bytes of an integer variable. + !< + !<```fortran + !< use penf + !< print FI1P, byte_size(1_I1P) + !<``` + !=> 1 <<< + integer(I1P), intent(in) :: i !< Integer variable whose number of bytes must be computed. + integer(I1P) :: bytes !< Number of bytes of i. + + bytes = bit_size(i) / 8_I1P +end function byte_size_I1P +endmodule penf_b_size diff --git a/src/modules/PENF/src/penf_global_parameters_variables.F90 b/src/modules/PENF/src/penf_global_parameters_variables.F90 new file mode 100644 index 000000000..356764dc9 --- /dev/null +++ b/src/modules/PENF/src/penf_global_parameters_variables.F90 @@ -0,0 +1,213 @@ +!< PENF global parameters and variables. + +module penf_global_parameters_variables +!< PENF global parameters and variables. +!< +!< @note All module defined entities are public. + +implicit none +public +save + +integer, parameter :: endianL = 1 !< Little endian parameter. +integer, parameter :: endianB = 0 !< Big endian parameter. + +! portable kind parameters +#ifdef _ASCII_SUPPORTED +integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind. +#else +integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind defined as default set. +#endif +#ifdef _UCS4_SUPPORTED +integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind. +#else +integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind defined as default set. +#endif +#if defined _CK_IS_DEFAULT +integer, parameter :: CK = selected_char_kind('default') !< Default kind character. +#elif defined _CK_IS_ASCII +integer, parameter :: CK = ASCII !< Default kind character. +#elif defined _CK_IS_UCS4 +integer, parameter :: CK = UCS4 !< Default kind character. +#else +integer, parameter :: CK = selected_char_kind('default') !< Default kind character. +#endif + +#if defined _R16P +integer, parameter :: R16P = selected_real_kind(33,4931) !< 33 digits, range \([10^{-4931}, 10^{+4931} - 1]\); 128 bits. +#else +integer, parameter :: R16P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. +#endif +integer, parameter :: R8P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. +integer, parameter :: R4P = selected_real_kind(6,37) !< 6 digits, range \([10^{-37} , 10^{+37} - 1]\); 32 bits. +#if defined _R16P +#if defined _R_P_IS_R16P +integer, parameter :: R_P = R16P !< Default real precision. +#endif +#endif +#if defined _R_P_IS_R8P +integer, parameter :: R_P = R8P !< Default real precision. +#elif defined _R_P_IS_R4P +integer, parameter :: R_P = R4P !< Default real precision. +#else +integer, parameter :: R_P = R8P !< Default real precision. +#endif + +integer, parameter :: I8P = selected_int_kind(18) !< Range \([-2^{63},+2^{63} - 1]\), 19 digits plus sign; 64 bits. +integer, parameter :: I4P = selected_int_kind(9) !< Range \([-2^{31},+2^{31} - 1]\), 10 digits plus sign; 32 bits. +integer, parameter :: I2P = selected_int_kind(4) !< Range \([-2^{15},+2^{15} - 1]\), 5 digits plus sign; 16 bits. +integer, parameter :: I1P = selected_int_kind(2) !< Range \([-2^{7} ,+2^{7} - 1]\), 3 digits plus sign; 8 bits. +integer, parameter :: I_P = I4P !< Default integer precision. + +! format parameters +#if defined _R16P +character(*), parameter :: FR16P = '(E42.33E4)' !< Output format for kind=R16P real. +#else +character(*), parameter :: FR16P = '(E23.15E3)' !< Output format for kind=R8P real. +#endif +character(*), parameter :: FR8P = '(E23.15E3)' !< Output format for kind=R8P real. +character(*), parameter :: FR4P = '(E13.6E2)' !< Output format for kind=R4P real. +#if defined _R16P +#if defined _R_P_IS_R16P +character(*), parameter :: FR_P = FR16P !< Output format for kind=R_P real. +#endif +#endif +#if defined _R_P_IS_R8P +character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real. +#elif defined _R_P_IS_R4P +character(*), parameter :: FR_P = FR4P !< Output format for kind=R_P real. +#else +character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real. +#endif + +character(*), parameter :: FI8P = '(I20)' !< Output format for kind=I8P integer. +character(*), parameter :: FI8PZP = '(I20.19)' !< Output format for kind=I8P integer with zero prefixing. +character(*), parameter :: FI4P = '(I11)' !< Output format for kind=I4P integer. +character(*), parameter :: FI4PZP = '(I11.10)' !< Output format for kind=I4P integer with zero prefixing. +character(*), parameter :: FI2P = '(I6)' !< Output format for kind=I2P integer. +character(*), parameter :: FI2PZP = '(I6.5)' !< Output format for kind=I2P integer with zero prefixing. +character(*), parameter :: FI1P = '(I4)' !< Output format for kind=I1P integer. +character(*), parameter :: FI1PZP = '(I4.3)' !< Output format for kind=I1P integer with zero prefixing. +character(*), parameter :: FI_P = FI4P !< Output format for kind=I_P integer. +character(*), parameter :: FI_PZP = FI4PZP !< Output format for kind=I_P integer with zero prefixing. + +! length (number of digits) of formatted numbers +#if defined _R16P +integer, parameter :: DR16P = 42 !< Number of digits of output format FR16P. +#else +integer, parameter :: DR16P = 23 !< Number of digits of output format FR8P. +#endif +integer, parameter :: DR8P = 23 !< Number of digits of output format FR8P. +integer, parameter :: DR4P = 13 !< Number of digits of output format FR4P. +#if defined _R16P +#if defined _R_P_IS_R16P +integer, parameter :: DR_P = DR16P !< Number of digits of output format FR_P. +#endif +#endif +#if defined _R_P_IS_R8P +integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P. +#elif defined _R_P_IS_R4P +integer, parameter :: DR_P = DR4P !< Number of digits of output format FR_P. +#else +integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P. +#endif + +integer, parameter :: DI8P = 20 !< Number of digits of output format I8P. +integer, parameter :: DI4P = 11 !< Number of digits of output format I4P. +integer, parameter :: DI2P = 6 !< Number of digits of output format I2P. +integer, parameter :: DI1P = 4 !< Number of digits of output format I1P. +integer, parameter :: DI_P = DI4P !< Number of digits of output format I_P. + +! list of kinds +integer, parameter :: CHARACTER_KINDS_LIST(1:3) = [ASCII, UCS4, CK] !< List of character kinds. +#if defined _R16P +integer, parameter :: REAL_KINDS_LIST(1:4) = [R16P, R8P, R4P, R_P] !< List of real kinds. +#else +integer, parameter :: REAL_KINDS_LIST(1:3) = [R8P, R4P, R_P] !< List of real kinds. +#endif +#if defined _R16P +character(*), parameter :: REAL_FORMATS_LIST(1:4) = [FR16P, FR8P, FR4P//' ', FR_P] !< List of real formats. +#else +character(*), parameter :: REAL_FORMATS_LIST(1:3) = [FR8P, FR4P//' ', FR_P] !< List of real formats. +#endif +integer, parameter :: INTEGER_KINDS_LIST(1:5) = [I8P, I4P, I2P, I1P,I_P] !< List of integer kinds. +character(*), parameter :: INTEGER_FORMATS_LIST(1:5) = [FI8P, FI4P, FI2P//' ', FI1P//' ', FI_P] !< List of integer formats. + +! minimum and maximum (representable) values +#if defined _R16P +real(R16P), parameter :: MinR16P = -huge(1._R16P) !< Minimum value of kind=R16P real. +real(R16P), parameter :: MaxR16P = huge(1._R16P) !< Maximum value of kind=R16P real. +#else +real(R8P), parameter :: MinR16P = -huge(1._R8P ) !< Minimum value of kind=R8P real. +real(R8P), parameter :: MaxR16P = huge(1._R8P ) !< Maximum value of kind=R8P real. +#endif +real(R8P), parameter :: MinR8P = -huge(1._R8P ) !< Minimum value of kind=R8P real. +real(R8P), parameter :: MaxR8P = huge(1._R8P ) !< Maximum value of kind=R8P real. +real(R4P), parameter :: MinR4P = -huge(1._R4P ) !< Minimum value of kind=R4P real. +real(R4P), parameter :: MaxR4P = huge(1._R4P ) !< Maximum value of kind=R4P real. +real(R_P), parameter :: MinR_P = -huge(1._R_P ) !< Minimum value of kind=R_P real. +real(R_P), parameter :: MaxR_P = huge(1._R_P ) !< Maximum value of kind=R_P real. +integer(I8P), parameter :: MinI8P = -huge(1_I8P) !< Minimum value of kind=I8P integer. +integer(I4P), parameter :: MinI4P = -huge(1_I4P) !< Minimum value of kind=I4P integer. +integer(I2P), parameter :: MinI2P = -huge(1_I2P) !< Minimum value of kind=I2P integer. +integer(I1P), parameter :: MinI1P = -huge(1_I1P) !< Minimum value of kind=I1P integer. +integer(I_P), parameter :: MinI_P = -huge(1_I_P) !< Minimum value of kind=I_P integer. +integer(I8P), parameter :: MaxI8P = huge(1_I8P) !< Maximum value of kind=I8P integer. +integer(I4P), parameter :: MaxI4P = huge(1_I4P) !< Maximum value of kind=I4P integer. +integer(I2P), parameter :: MaxI2P = huge(1_I2P) !< Maximum value of kind=I2P integer. +integer(I1P), parameter :: MaxI1P = huge(1_I1P) !< Maximum value of kind=I1P integer. +integer(I_P), parameter :: MaxI_P = huge(1_I_P) !< Maximum value of kind=I_P integer. + +! real smallest (representable) values +#if defined _R16P +real(R16P), parameter :: smallR16P = tiny(1._R16P) !< Smallest representable value of kind=R16P real. +#else +real(R8P), parameter :: smallR16P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real. +#endif +real(R8P), parameter :: smallR8P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real. +real(R4P), parameter :: smallR4P = tiny(1._R4P ) !< Smallest representable value of kind=R4P real. +real(R_P), parameter :: smallR_P = tiny(1._R_P ) !< Smallest representable value of kind=R_P real. + +! smallest real representable difference by the running calculator +#if defined _R16P +real(R16P), parameter :: ZeroR16P = nearest(1._R16P, 1._R16P) - & + nearest(1._R16P,-1._R16P) !< Smallest representable difference of kind=R16P real. +#else +real(R8P), parameter :: ZeroR16P = 0._R8P !nearest(1._R8P, 1._R8P) - & + !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. +#endif +real(R8P), parameter :: ZeroR8P = 0._R8P !nearest(1._R8P, 1._R8P) - & + !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. +real(R4P), parameter :: ZeroR4P = 0._R4P !nearest(1._R4P, 1._R4P) - & + !nearest(1._R4P,-1._R4P) !< Smallest representable difference of kind=R4P real. +real(R_P), parameter :: ZeroR_P = 0._R_P !nearest(1._R_P, 1._R_P) - & + !nearest(1._R_P,-1._R_P) !< Smallest representable difference of kind=R_P real. + +! bits/bytes memory requirements +#if defined _R16P +integer(I2P), parameter :: BIR16P = storage_size(MaxR16P) !< Number of bits of kind=R16P real. +#else +integer(I1P), parameter :: BIR16P = storage_size(MaxR8P) !< Number of bits of kind=R8P real. +#endif +integer(I1P), parameter :: BIR8P = storage_size(MaxR8P) !< Number of bits of kind=R8P real. +integer(I1P), parameter :: BIR4P = storage_size(MaxR4P) !< Number of bits of kind=R4P real. +integer(I1P), parameter :: BIR_P = storage_size(MaxR_P) !< Number of bits of kind=R_P real. +#if defined _R16P +integer(I2P), parameter :: BYR16P = BIR16P/8_I2P !< Number of bytes of kind=R16P real. +#else +integer(I1P), parameter :: BYR16P = BIR8P/8_I1P !< Number of bytes of kind=R8P real. +#endif +integer(I1P), parameter :: BYR8P = BIR8P/8_I1P !< Number of bytes of kind=R8P real. +integer(I1P), parameter :: BYR4P = BIR4P/8_I1P !< Number of bytes of kind=R4P real. +integer(I1P), parameter :: BYR_P = BIR_P/8_I1P !< Number of bytes of kind=R_P real. +integer(I8P), parameter :: BII8P = storage_size(MaxI8P) !< Number of bits of kind=I8P integer. +integer(I4P), parameter :: BII4P = storage_size(MaxI4P) !< Number of bits of kind=I4P integer. +integer(I2P), parameter :: BII2P = storage_size(MaxI2P) !< Number of bits of kind=I2P integer. +integer(I1P), parameter :: BII1P = storage_size(MaxI1P) !< Number of bits of kind=I1P integer. +integer(I_P), parameter :: BII_P = storage_size(MaxI_P) !< Number of bits of kind=I_P integer. +integer(I8P), parameter :: BYI8P = BII8P/8_I8P !< Number of bytes of kind=I8P integer. +integer(I4P), parameter :: BYI4P = BII4P/8_I4P !< Number of bytes of kind=I4P integer. +integer(I2P), parameter :: BYI2P = BII2P/8_I2P !< Number of bytes of kind=I2P integer. +integer(I1P), parameter :: BYI1P = BII1P/8_I1P !< Number of bytes of kind=I1P integer. +integer(I_P), parameter :: BYI_P = BII_P/8_I_P !< Number of bytes of kind=I_P integer. +endmodule penf_global_parameters_variables diff --git a/src/modules/PENF/src/penf_stringify.F90 b/src/modules/PENF/src/penf_stringify.F90 new file mode 100644 index 000000000..979db78d1 --- /dev/null +++ b/src/modules/PENF/src/penf_stringify.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 +! + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: PENF string-to-number (and viceversa) facility. + +MODULE PENF_STRINGIFY +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: stderr => error_unit +USE PENF_B_SIZE +USE PENF_GLOBAL_PARAMETERS_VARIABLES +IMPLICIT NONE +PRIVATE +SAVE +PUBLIC :: STR_ASCII, STR_UCS4 +PUBLIC :: STR, STRZ, CTON +PUBLIC :: BSTR, BCTON + +!---------------------------------------------------------------------------- +! STR_ASCII +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: Convert string of any kind to ASCII string. + +INTERFACE STR_ASCII + MODULE PROCEDURE str_ascii_default +#if defined _ASCII_SUPPORTED && defined _ASCII_NEQ_DEFAULT + MODULE PROCEDURE str_ascii_ascii +#endif +#ifdef _UCS4_SUPPORTED + MODULE PROCEDURE STR_ASCII_UCS4 +#endif +END INTERFACE STR_ASCII + +!---------------------------------------------------------------------------- +! STR_UCS4 +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: Convert string of any kind to UCS4 string. + +INTERFACE STR_UCS4 + MODULE PROCEDURE str_ucs4_default +#if defined _ASCII_SUPPORTED && defined _ASCII_NEQ_DEFAULT + MODULE PROCEDURE str_ucs4_ascii +#endif +#ifdef _UCS4_SUPPORTED + MODULE PROCEDURE str_ucs4_ucs4 +#endif +END INTERFACE + +!---------------------------------------------------------------------------- +! STR +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: Convert number (real and integer) to string (number to string type +! casting). + +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 +#ifdef _R16P + MODULE PROCEDURE strf_R16P, str_R16P, str_a_R16P +#endif +END INTERFACE STR + +!---------------------------------------------------------------------------- +! STRZ +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: Convert integer, to string, prefixing with the right number of +! zeros (integer to string type casting with zero padding). + +INTERFACE STRZ + MODULE PROCEDURE strz_I8P, strz_I4P, strz_I2P, strz_I1P +END INTERFACE + +!---------------------------------------------------------------------------- +! CTON +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: Convert string to number (real and integer, string to number type +! casting). + +INTERFACE CTON + MODULE PROCEDURE & + ctor_R8P, & + ctor_R4P, & + ctoi_I8P, & + ctoi_I4P, & + ctoi_I2P, & + ctoi_I1P +#if defined _R16P + MODULE PROCEDURE ctor_R16P +#endif +END INTERFACE + +!---------------------------------------------------------------------------- +! BSTR +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: Convert number (real and integer) to bit-string (number to +! bit-string type casting). + +INTERFACE BSTR + MODULE PROCEDURE & + & bstr_R8P, & + & bstr_R4P, & + & bstr_I8P, & + & bstr_I4P, & + & bstr_I2P, & + & bstr_I1P + +#if defined _R16P + MODULE PROCEDURE bstr_R16P +#endif +END INTERFACE + +!---------------------------------------------------------------------------- +! BCTON +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 22 July 2022 +! summary: Convert bit-string to number (real and integer, bit-string to +! number type casting). +INTERFACE BCTON + MODULE PROCEDURE & + & bctor_R8P, & + & bctor_R4P, & + & bctoi_I8P, & + & bctoi_I4P, & + & bctoi_I2P, & + & bctoi_I1P +#if defined _R16P + MODULE PROCEDURE bctor_R16P +#endif + +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +#include "./STR_ASCII.inc" +#include "./STR_UCS4.inc" +#include "./STR.inc" +#include "./COMPACT_REAL_STRING.inc" +#include "./STRZ.inc" +#include "./CTOA.inc" +#include "./BSTR.inc" +#include "./BCTON.inc" + +ENDMODULE PENF_STRINGIFY diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt new file mode 100644 index 000000000..86560150e --- /dev/null +++ b/src/modules/Polynomial/CMakeLists.txt @@ -0,0 +1,39 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/InterpolationUtility.F90 + ${src_path}/LagrangePolynomialUtility.F90 + ${src_path}/OrthogonalPolynomialUtility.F90 + ${src_path}/JacobiPolynomialUtility.F90 + ${src_path}/UltrasphericalPolynomialUtility.F90 + ${src_path}/LegendrePolynomialUtility.F90 + ${src_path}/LobattoPolynomialUtility.F90 + ${src_path}/UnscaledLobattoPolynomialUtility.F90 + ${src_path}/Chebyshev1PolynomialUtility.F90 + ${src_path}/LineInterpolationUtility.F90 + ${src_path}/TriangleInterpolationUtility.F90 + ${src_path}/QuadrangleInterpolationUtility.F90 + ${src_path}/TetrahedronInterpolationUtility.F90 + ${src_path}/HexahedronInterpolationUtility.F90 + ${src_path}/PrismInterpolationUtility.F90 + ${src_path}/PyramidInterpolationUtility.F90 + ${src_path}/RecursiveNodesUtility.F90 + ${src_path}/PolynomialUtility.F90 +) \ No newline at end of file diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 new file mode 100644 index 000000000..10bfc0a0c --- /dev/null +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -0,0 +1,1098 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 Chebyshev1PolynomialUtility +USE GlobalData +USE BaseType, ONLY: iface_1DFunction +IMPLICIT NONE +PUBLIC :: Chebyshev1Alpha +PUBLIC :: Chebyshev1Beta +PUBLIC :: GetChebyshev1RecurrenceCoeff +PUBLIC :: GetChebyshev1RecurrenceCoeff2 +PUBLIC :: Chebyshev1LeadingCoeff +PUBLIC :: Chebyshev1LeadingCoeffRatio +PUBLIC :: Chebyshev1NormSQR +PUBLIC :: Chebyshev1NormSQR2 +PUBLIC :: Chebyshev1NormSQRRatio +PUBLIC :: Chebyshev1JacobiMatrix +PUBLIC :: Chebyshev1GaussQuadrature +PUBLIC :: Chebyshev1JacobiRadauMatrix +PUBLIC :: Chebyshev1GaussRadauQuadrature +PUBLIC :: Chebyshev1JacobiLobattoMatrix +PUBLIC :: Chebyshev1GaussLobattoQuadrature +PUBLIC :: Chebyshev1Zeros +PUBLIC :: Chebyshev1Quadrature +PUBLIC :: Chebyshev1Eval +PUBLIC :: Chebyshev1EvalAll +PUBLIC :: Chebyshev1MonomialExpansionAll +PUBLIC :: Chebyshev1MonomialExpansion +PUBLIC :: Chebyshev1GradientEvalAll +PUBLIC :: Chebyshev1GradientEval +PUBLIC :: Chebyshev1EvalSum +PUBLIC :: Chebyshev1GradientEvalSum +PUBLIC :: Chebyshev1Transform +PUBLIC :: Chebyshev1InvTransform +PUBLIC :: Chebyshev1GradientCoeff +PUBLIC :: Chebyshev1DMatrix +PUBLIC :: Chebyshev1DMatEvenOdd + +!---------------------------------------------------------------------------- +! Chebyshev1Alpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Alpha(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION Chebyshev1Alpha +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1Beta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Beta(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION Chebyshev1Beta +END INTERFACE + +!---------------------------------------------------------------------------- +! GetChebyshev1RecurrenceCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Return the recurrence coefficient for nth order Chebyshev1 +! polynomial +! +! +!# Introduction +! +! These recurrence coefficients are for monic jacobi polynomials. + +INTERFACE + MODULE PURE SUBROUTINE GetChebyshev1RecurrenceCoeff(n, alphaCoeff, & + & betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetChebyshev1RecurrenceCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! GetChebyshev1RecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Return the recurrence coefficient for nth order Chebyshev1 +! polynomial +! +! +!# Introduction +! +! These recurrence coefficients are for monic jacobi polynomials. + +INTERFACE + MODULE PURE SUBROUTINE GetChebyshev1RecurrenceCoeff2(n, A, B, C) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + !! size is n + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + !! this coefficient is zero + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + !! size is n + END SUBROUTINE GetChebyshev1RecurrenceCoeff2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1LeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Leading coefficient of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1LeadingCoeff(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION Chebyshev1LeadingCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1LeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Ratio of leading coefficients, kn+1/kn + +INTERFACE + MODULE PURE FUNCTION Chebyshev1LeadingCoeffRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION Chebyshev1LeadingCoeffRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQR +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Square norm of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1NormSQR(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION Chebyshev1NormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Square norm of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1NormSQR2(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(0:n) + END FUNCTION Chebyshev1NormSQR2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQRRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Ratio of Square norm of Chebyshev1 polynomial, n+1/n + +INTERFACE + MODULE PURE FUNCTION Chebyshev1NormSQRRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION Chebyshev1NormSQRRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Return the Jacobi matrix for Chebyshev polynomial + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1JacobiMatrix(n, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + !! recurrence coefficient of monic Chebyshev polynomial, from 0 to n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + !! recurrence coefficient of monic Chebyshev polynomial, from 0 to n-1 + END SUBROUTINE Chebyshev1JacobiMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1GaussQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Return the Jacobi matrix for Chebyshev polynomial + +INTERFACE + MODULE SUBROUTINE Chebyshev1GaussQuadrature(n, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev polynomial. + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! the size is 1 to n + END SUBROUTINE Chebyshev1GaussQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiRadauMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Return the Jacobi-Radau matrix for Chebyshev polynomial + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1JacobiRadauMatrix(a, n, D, E, alphaCoeff, & + & betaCoeff) + REAL(DFP), INTENT(IN) :: a + !! one of the end of the domain + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial. + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+1 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE Chebyshev1JacobiRadauMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1GaussRadauQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the GaussRadau quadrature points for Chebyshev1 Polynomial + +INTERFACE + MODULE SUBROUTINE Chebyshev1GaussRadauQuadrature(a, n, pt, wt) + REAL(DFP), INTENT(IN) :: a + !! +1.0 or -1.0 + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev polynomial + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! the size is 1 to n+1 + END SUBROUTINE Chebyshev1GaussRadauQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiLobattoMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Return the Jacobi-Lobatto matrix for Chebyshev polynomial + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1JacobiLobattoMatrix(n, D, E, alphaCoeff, & + & betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+2 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE Chebyshev1JacobiLobattoMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1GaussLobattoQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary:Returns the GaussLobatto quadrature points for Chebyshev1 Polynomial + +INTERFACE + MODULE SUBROUTINE Chebyshev1GaussLobattoQuadrature(n, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n+2 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! the size is 1 to n+2 + END SUBROUTINE Chebyshev1GaussLobattoQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1Zeros +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION Chebyshev1Zeros(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev polynomial + REAL(DFP) :: ans(n) + END FUNCTION Chebyshev1Zeros +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1Quadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Chebyshev-Gauss, Chebyshev-Radau, +! Chebyshev-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Chebyshev polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of Chebyshev polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE Chebyshev1Quadrature(n, pt, wt, quadType, onlyInside) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Chebyshev polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside + !! only inside + END SUBROUTINE Chebyshev1Quadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1Eval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials of order = n at single x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Eval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1Eval1 +END INTERFACE + +INTERFACE Chebyshev1Eval + MODULE PROCEDURE Chebyshev1Eval1 +END INTERFACE Chebyshev1Eval + +!---------------------------------------------------------------------------- +! Chebyshev1Eval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials of order n at several points + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Eval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! several points of evaluation + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1Eval2 +END INTERFACE + +INTERFACE Chebyshev1Eval + MODULE PROCEDURE Chebyshev1Eval2 +END INTERFACE Chebyshev1Eval + +!---------------------------------------------------------------------------- +! Chebyshev1EvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials from order = 0 to n at single point +! +!# Introduction +! +! Evaluate Chebyshev1 polynomials from order = 0 to n at single point +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- x: the point at which the polynomials are to be evaluated. +!- ans(1:N+1), the values of the first N+1 Chebyshev1 polynomials at the +! point + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP) :: ans(n + 1) + !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION Chebyshev1EvalAll1 +END INTERFACE + +INTERFACE Chebyshev1EvalAll + MODULE PROCEDURE Chebyshev1EvalAll1 +END INTERFACE Chebyshev1EvalAll + +!---------------------------------------------------------------------------- +! Chebyshev1EvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Chebyshev1 polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- x: the points at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Chebyshev1 polynomials at the +! points x(1:m) + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! several points of evaluation + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) + !! at points x + END FUNCTION Chebyshev1EvalAll2 +END INTERFACE + +INTERFACE Chebyshev1EvalAll + MODULE PROCEDURE Chebyshev1EvalAll2 +END INTERFACE Chebyshev1EvalAll + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of all Chebyshev1 polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all Chebyshev1 polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|----|----|----|-----| +! | 1 | 0 | -1 | -0 | 1 | 0 | +! | 0 | 1 | 0 | -3 | -0 | 5 | +! | 0 | 0 | 2 | 0 | -8 | -0 | +! | 0 | 0 | 0 | 4 | 0 | -20 | +! | 0 | 0 | 0 | 0 | 8 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 16 | + +INTERFACE + MODULE PURE FUNCTION Chebyshev1MonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION Chebyshev1MonomialExpansionAll +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a Chebyshev1 polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a Chebyshev1 polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION Chebyshev1MonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION Chebyshev1MonomialExpansion +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION Chebyshev1GradientEvalAll1 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalAll + MODULE PROCEDURE Chebyshev1GradientEvalAll1 +END INTERFACE Chebyshev1GradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION Chebyshev1GradientEvalAll2 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalAll + MODULE PROCEDURE Chebyshev1GradientEvalAll2 +END INTERFACE Chebyshev1GradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Chebyshev1GradientEval1 +END INTERFACE +!! + +INTERFACE Chebyshev1GradientEval + MODULE PROCEDURE Chebyshev1GradientEval1 +END INTERFACE Chebyshev1GradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION Chebyshev1GradientEval2 +END INTERFACE + +INTERFACE Chebyshev1GradientEval + MODULE PROCEDURE Chebyshev1GradientEval2 +END INTERFACE Chebyshev1GradientEval + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Chebyshev1 polynomials at point x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalSum1(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1EvalSum1 +END INTERFACE + +INTERFACE Chebyshev1EvalSum + MODULE PROCEDURE Chebyshev1EvalSum1 +END INTERFACE Chebyshev1EvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Chebyshev1 polynomials at several x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalSum2(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1EvalSum2 +END INTERFACE + +INTERFACE Chebyshev1EvalSum + MODULE PROCEDURE Chebyshev1EvalSum2 +END INTERFACE Chebyshev1EvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials +! at point x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum1(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum1 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum1 +END INTERFACE Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials +! at several x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum2(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum2 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum2 +END INTERFACE Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Chebyshev1 +! polynomials at point x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum3(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum3 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum3 +END INTERFACE Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Chebyshev1 +! polynomials at several x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum4(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum4 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum4 +END INTERFACE Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION Chebyshev1Transform1 +END INTERFACE + +INTERFACE Chebyshev1Transform + MODULE PROCEDURE Chebyshev1Transform1 +END INTERFACE Chebyshev1Transform + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION Chebyshev1Transform2 +END INTERFACE + +INTERFACE Chebyshev1Transform + MODULE PROCEDURE Chebyshev1Transform2 +END INTERFACE Chebyshev1Transform + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Chebyshev1 Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the Chebyshev1 transformation of f defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls +! `Chebyshev1Quadrature` which is not pure due to Lapack call. +!@endnote + +INTERFACE + MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION Chebyshev1Transform3 +END INTERFACE + +INTERFACE Chebyshev1Transform + MODULE PROCEDURE Chebyshev1Transform3 +END INTERFACE Chebyshev1Transform + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Chebyshev1 Transform +! +!# Introduction +! Discrete Chebyshev transform. We calculate weights and quadrature points +! internally. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION Chebyshev1Transform4 +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1InvTransform1(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION Chebyshev1InvTransform1 +END INTERFACE + +INTERFACE Chebyshev1InvTransform + MODULE PROCEDURE Chebyshev1InvTransform1 +END INTERFACE Chebyshev1InvTransform + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1InvTransform2(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION Chebyshev1InvTransform2 +END INTERFACE + +INTERFACE Chebyshev1InvTransform + MODULE PROCEDURE Chebyshev1InvTransform2 +END INTERFACE Chebyshev1InvTransform + +!---------------------------------------------------------------------------- +! Chebyshev1GradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficients for gradient of Chebyshev1 expansion +! +!# Introduction +! +!- This routine returns the coefficients of gradient of Jacobi expansion. +!- Input is coefficient of Chebyshev1 expansion (modal values) +!- Output is coefficient of derivative of Chebyshev1 expansion (modal values) + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientCoeff1(n, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from Chebyshev1Transform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION Chebyshev1GradientCoeff1 +END INTERFACE + +INTERFACE Chebyshev1GradientCoeff + MODULE PROCEDURE Chebyshev1GradientCoeff1 +END INTERFACE Chebyshev1GradientCoeff + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Returns differentiation matrix for Chebyshev1 expansion + +INTERFACE + MODULE PURE FUNCTION Chebyshev1DMatrix1(n, x, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION Chebyshev1DMatrix1 +END INTERFACE + +INTERFACE Chebyshev1DMatrix + MODULE PROCEDURE Chebyshev1DMatrix1 +END INTERFACE Chebyshev1DMatrix + +!---------------------------------------------------------------------------- +! Chebyshev1DMatEvenOdd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Performs even and odd decomposition of Differential matrix + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1DMatEvenOdd1(n, D, e, o) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP), INTENT(IN) :: D(0:n, 0:n) + !! n+1 by n+1 + REAL(DFP), INTENT(OUT) :: e(0:, 0:) + !! even Decomposition, 0:n/2, 0:n/2 + REAL(DFP), INTENT(OUT) :: o(0:, 0:) + !! odd decomposition, 0:n/2, 0:n/2 + END SUBROUTINE Chebyshev1DMatEvenOdd1 +END INTERFACE + +INTERFACE Chebyshev1DMatEvenOdd + MODULE PROCEDURE Chebyshev1DMatEvenOdd1 +END INTERFACE Chebyshev1DMatEvenOdd + +END MODULE Chebyshev1PolynomialUtility diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 new file mode 100644 index 000000000..fef9276e3 --- /dev/null +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -0,0 +1,2636 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 HexahedronInterpolationUtility +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE +PUBLIC :: LagrangeDegree_Hexahedron +PUBLIC :: LagrangeDOF_Hexahedron +PUBLIC :: LagrangeInDOF_Hexahedron +PUBLIC :: EquidistancePoint_Hexahedron +PUBLIC :: EquidistanceInPoint_Hexahedron +PUBLIC :: InterpolationPoint_Hexahedron +PUBLIC :: LagrangeCoeff_Hexahedron +PUBLIC :: EdgeConnectivity_Hexahedron +PUBLIC :: FacetConnectivity_Hexahedron +PUBLIC :: QuadratureNumber_Hexahedron +PUBLIC :: TensorProdBasis_Hexahedron +PUBLIC :: OrthogonalBasis_Hexahedron +PUBLIC :: VertexBasis_Hexahedron +PUBLIC :: xEdgeBasis_Hexahedron +PUBLIC :: yEdgeBasis_Hexahedron +PUBLIC :: zEdgeBasis_Hexahedron +PUBLIC :: EdgeBasis_Hexahedron +PUBLIC :: xyFacetBasis_Hexahedron +PUBLIC :: yzFacetBasis_Hexahedron +PUBLIC :: xzFacetBasis_Hexahedron +PUBLIC :: FacetBasis_Hexahedron +PUBLIC :: CellBasis_Hexahedron +PUBLIC :: HeirarchicalBasis_Hexahedron +PUBLIC :: QuadraturePoint_Hexahedron +PUBLIC :: LagrangeEvalAll_Hexahedron +PUBLIC :: GetVertexDOF_Hexahedron +PUBLIC :: GetEdgeDOF_Hexahedron +PUBLIC :: GetFacetDOF_Hexahedron +PUBLIC :: GetCellDOF_Hexahedron +PUBLIC :: RefElemDomain_Hexahedron +PUBLIC :: LagrangeGradientEvalAll_Hexahedron +PUBLIC :: OrthogonalBasisGradient_Hexahedron +PUBLIC :: TensorProdBasisGradient_Hexahedron +PUBLIC :: HeirarchicalBasisGradient_Hexahedron +PUBLIC :: GetTotalDOF_Hexahedron +PUBLIC :: GetTotalInDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetTotalDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Hexahedron + +INTERFACE + MODULE PURE FUNCTION GetTotalDOF_Hexahedron(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalDOF_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Hexahedron +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Hexahedron +!- These dof are strictly inside the Hexahedron + +INTERFACE + MODULE PURE FUNCTION GetTotalInDOF_Hexahedron(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! RefElemDomain_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain_Hexahedron(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_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! GetVertexDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: returns total number of vertex degrees of freedom + +INTERFACE + MODULE PURE FUNCTION GetVertexDOF_Hexahedron() RESULT(ans) + INTEGER(I4B) :: ans + END FUNCTION GetVertexDOF_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: returns total number of degrees of freedom on edges parallel to +! some axis + +INTERFACE GetEdgeDOF_Hexahedron + MODULE PURE FUNCTION GetEdgeDOF_Hexahedron1(pe1, pe2, pe3, pe4) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1, pe2, pe3, pe4 + !! Order of interpolation in x or y or z direction + INTEGER(I4B) :: ans + END FUNCTION GetEdgeDOF_Hexahedron1 +END INTERFACE GetEdgeDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total number of degrees of freedom on all edges + +INTERFACE GetEdgeDOF_Hexahedron + MODULE PURE FUNCTION GetEdgeDOF_Hexahedron2(p, q, r) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! Order of approximation in x,y and z direction + INTEGER(I4B) :: ans + END FUNCTION GetEdgeDOF_Hexahedron2 +END INTERFACE GetEdgeDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total number of degrees of freedom on all edges + +INTERFACE GetEdgeDOF_Hexahedron + MODULE PURE FUNCTION GetEdgeDOF_Hexahedron3(p) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B) :: ans + END FUNCTION GetEdgeDOF_Hexahedron3 +END INTERFACE GetEdgeDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total number of degrees of freedom on all edges + +INTERFACE GetEdgeDOF_Hexahedron + MODULE PURE FUNCTION GetEdgeDOF_Hexahedron4( & + & px1, px2, px3, px4, & + & py1, py2, py3, py4, & + & pz1, pz2, pz3, pz4) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 + !! orders alongs edges parallel to x axis + INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 + !! orders along edges parallel to y axis + INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 + !! orders along edges parallel to z axis + INTEGER(I4B) :: ans + END FUNCTION GetEdgeDOF_Hexahedron4 +END INTERFACE GetEdgeDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns dof on all facets + +INTERFACE GetFacetDOF_Hexahedron + MODULE PURE FUNCTION GetFacetDOF_Hexahedron1( & + & pxy1, pxy2, & + & pxz1, pxz2, & + & pyz1, pyz2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 + !! orders alongs facets parallel to xy plane + INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 + !! orders along facets parallel to xz plane + INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 + !! orders along facets parallel to yx plane + INTEGER(I4B) :: ans + END FUNCTION GetFacetDOF_Hexahedron1 +END INTERFACE GetFacetDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total degrees of freedom on all facets + +INTERFACE GetFacetDOF_Hexahedron + MODULE PURE FUNCTION GetFacetDOF_Hexahedron2(p, q, r) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! orders in x, y and z direction + INTEGER(I4B) :: ans + END FUNCTION GetFacetDOF_Hexahedron2 +END INTERFACE GetFacetDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total degree of freedom on a single facet + +INTERFACE GetFacetDOF_Hexahedron + MODULE PURE FUNCTION GetFacetDOF_Hexahedron3(p, q) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q + !! orders alongs facets parallel to xy or xz or yz planes + INTEGER(I4B) :: ans + END FUNCTION GetFacetDOF_Hexahedron3 +END INTERFACE GetFacetDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total degrees of freedom on all facets + +INTERFACE GetFacetDOF_Hexahedron + MODULE PURE FUNCTION GetFacetDOF_Hexahedron4(p) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! orders alongs facets parallel to xy or xz or yz planes + INTEGER(I4B) :: ans + END FUNCTION GetFacetDOF_Hexahedron4 +END INTERFACE GetFacetDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: + +INTERFACE GetCellDOF_Hexahedron + MODULE PURE FUNCTION GetCellDOF_Hexahedron1(p, q, r) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! orders alongs to x, y, and z directions + INTEGER(I4B) :: ans + END FUNCTION GetCellDOF_Hexahedron1 +END INTERFACE GetCellDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: + +INTERFACE GetCellDOF_Hexahedron + MODULE PURE FUNCTION GetCellDOF_Hexahedron2(p) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! orders alongs to x, y, and z directions + INTEGER(I4B) :: ans + END FUNCTION GetCellDOF_Hexahedron2 +END INTERFACE GetCellDOF_Hexahedron + +!---------------------------------------------------------------------------- +! QuadratureNumber_Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION QuadratureNumber_Hexahedron( & + & p, & + & q, & + & r, & + & quadType1, & + & quadType2, & + & quadType3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 + INTEGER(I4B) :: ans(3) + END FUNCTION QuadratureNumber_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetConnectivity_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-28 +! summary: This function returns the edge connectivity of Hexahedron + +INTERFACE + MODULE PURE FUNCTION FacetConnectivity_Hexahedron( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(4, 6) + END FUNCTION FacetConnectivity_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-07 +! summary: This function returns the edge connectivity of Hexahedron + +INTERFACE + MODULE PURE FUNCTION EdgeConnectivity_Hexahedron( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2, 12) + END FUNCTION EdgeConnectivity_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE LagrangeDegree_Hexahedron + MODULE PURE FUNCTION LagrangeDegree_Hexahedron1(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Hexahedron1 +END INTERFACE LagrangeDegree_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeDegree_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE LagrangeDegree_Hexahedron + MODULE PURE FUNCTION LagrangeDegree_Hexahedron2(p, q, r) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B), INTENT(IN) :: q + INTEGER(I4B), INTENT(IN) :: r + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Hexahedron2 +END INTERFACE LagrangeDegree_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Hexahedron + +INTERFACE LagrangeDOF_Hexahedron + MODULE PURE FUNCTION LagrangeDOF_Hexahedron1(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Hexahedron1 +END INTERFACE LagrangeDOF_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Hexahedron + +INTERFACE LagrangeDOF_Hexahedron + MODULE PURE FUNCTION LagrangeDOF_Hexahedron2(p, q, r) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Hexahedron2 +END INTERFACE LagrangeDOF_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Hexahedron +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Hexahedron +!- These dof are strictly inside the Hexahedron + +INTERFACE LagrangeInDOF_Hexahedron + MODULE PURE FUNCTION LagrangeInDOF_Hexahedron1(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Hexahedron1 +END INTERFACE LagrangeInDOF_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Hexahedron +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Hexahedron +!- These dof are strictly inside the Hexahedron + +INTERFACE LagrangeInDOF_Hexahedron + MODULE PURE FUNCTION LagrangeInDOF_Hexahedron2(p, q, r) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Hexahedron2 +END INTERFACE LagrangeInDOF_Hexahedron + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points in Hexahedron +! +!# Introduction +! +!- This function returns the equidistance points in Hexahedron +!- All points are inside the Hexahedron + +INTERFACE EquidistanceInPoint_Hexahedron + MODULE PURE FUNCTION EquidistanceInPoint_Hexahedron1(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! number of rows = 3 + !! number of cols = 8 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistanceInPoint_Hexahedron1 +END INTERFACE EquidistanceInPoint_Hexahedron + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points in Hexahedron +! +!# Introduction +! +!- This function returns the equidistance points in Hexahedron +!- All points are inside the Hexahedron + +INTERFACE EquidistanceInPoint_Hexahedron + MODULE PURE FUNCTION EquidistanceInPoint_Hexahedron2(p, q, r, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! order in x, y, and z direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! number of rows = 3 + !! number of cols = 8 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistanceInPoint_Hexahedron2 +END INTERFACE EquidistanceInPoint_Hexahedron + +!---------------------------------------------------------------------------- +! EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Hexahedron element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! Hexahedron 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, VEFC. + +INTERFACE EquidistancePoint_Hexahedron + MODULE PURE FUNCTION EquidistancePoint_Hexahedron1(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! number of rows = 3 + !! number of cols = 8 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistancePoint_Hexahedron1 +END INTERFACE EquidistancePoint_Hexahedron + +!---------------------------------------------------------------------------- +! EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Hexahedron element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! Hexahedron 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, VEFC. + +INTERFACE EquidistancePoint_Hexahedron + MODULE PURE FUNCTION EquidistancePoint_Hexahedron2(p, q, r, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order in z direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! number of rows = 3 + !! number of cols = 8 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistancePoint_Hexahedron2 +END INTERFACE EquidistancePoint_Hexahedron + +!---------------------------------------------------------------------------- +! InterpolationPoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point + +INTERFACE InterpolationPoint_Hexahedron + MODULE FUNCTION InterpolationPoint_Hexahedron1(order, ipType, & + & layout, xij, alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in x, y and z direction + INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation type in x, y, and z direction + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + CHARACTER(*), INTENT(IN) :: layout + !! layout can be VEFC or INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordiantes of reference hexahedron + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + !! rows of ans denotes x, y, z components + !! cols of ans denotes x, y, z components + END FUNCTION InterpolationPoint_Hexahedron1 +END INTERFACE InterpolationPoint_Hexahedron + +!---------------------------------------------------------------------------- +! InterpolationPoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Interpolation points + +INTERFACE InterpolationPoint_Hexahedron + MODULE FUNCTION InterpolationPoint_Hexahedron2( & + & p, & + & q, & + & r, & + & ipType1, & + & ipType2, & + & ipType3, & + & layout, & + & xij, & + & alpha1, beta1, lambda1, & + & alpha2, beta2, lambda2, & + & alpha3, beta3, lambda3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order in z direction + INTEGER(I4B), INTENT(IN) :: ipType1 + !! interpolation type in x direction + INTEGER(I4B), INTENT(IN) :: ipType2 + !! interpolation type in y direction + INTEGER(I4B), INTENT(IN) :: ipType3 + !! interpolation type in z direction + CHARACTER(*), INTENT(IN) :: layout + !! layout can be VEFC or INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinate of reference Hexahedron + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + !! rows of ans denotes x, y, z components + !! cols of ans denotes x, y, z components + END FUNCTION InterpolationPoint_Hexahedron2 +END INTERFACE InterpolationPoint_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Convert IJK to VEFC format + +INTERFACE + MODULE RECURSIVE PURE SUBROUTINE IJK2VEFC_Hexahedron( & + & xi, & + & eta, & + & zeta, & + & temp, & + & p, q, r) + REAL(DFP), INTENT(IN) :: xi(:, :, :) + REAL(DFP), INTENT(IN) :: eta(:, :, :) + REAL(DFP), INTENT(IN) :: zeta(:, :, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B), INTENT(IN) :: q + INTEGER(I4B), INTENT(IN) :: r + END SUBROUTINE IJK2VEFC_Hexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Returns coefficients of monomials for ith lagrange polynomial + +INTERFACE LagrangeCoeff_Hexahedron + MODULE FUNCTION LagrangeCoeff_Hexahedron1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! interpolation points in xij format + !! number of rows in xij is 3 + !! number of columns should be equal to the number degree of freedom + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron1 +END INTERFACE LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Returns coefficients of monomials for ith lagrange polynomial + +INTERFACE LagrangeCoeff_Hexahedron + MODULE FUNCTION LagrangeCoeff_Hexahedron2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron2 +END INTERFACE LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Returns coefficients of monomials for ith lagrange polynomial + +INTERFACE LagrangeCoeff_Hexahedron + MODULE FUNCTION LagrangeCoeff_Hexahedron3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron3 +END INTERFACE LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Returns the coefficients of monomials for all lagrange polynomial + +INTERFACE LagrangeCoeff_Hexahedron + MODULE FUNCTION LagrangeCoeff_Hexahedron4(order, xij, basisType, & + & refHexahedron, 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 + CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron4 +END INTERFACE LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Returns the coefficients of monomials for all lagrange polynomial + +INTERFACE LagrangeCoeff_Hexahedron + MODULE FUNCTION LagrangeCoeff_Hexahedron5(& + & p, & + & q, & + & r, & + & xij, & + & basisType1, & + & basisType2, & + & basisType3, & + & alpha1, & + & beta1, & + & lambda1, & + & alpha2, & + & beta2, & + & lambda2, & + & alpha3, & + & beta3, & + & lambda3, & + & refHexahedron & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order of polynomial in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of polynomial in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order of polynomial in z direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! These are interpolation points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basis type in x direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basis type in y direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType3 + !! basis type in z direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! This parameter is needed when basisType1 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! This parameter is needed when basisType1 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! This parameter is needed when basisType1 is Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! This parameter is needed when basisType2 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! This parameter is needed when basisType2 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! This parameter is needed when basisType2 is Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! This parameter is needed when basisType3 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! This parameter is needed when basisType3 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! This parameter is needed when basisType3 is Ultraspherical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron + !! UNIT + !! BIUNIT + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron5 +END INTERFACE LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! TensorProdBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron + +INTERFACE TensorProdBasis_Hexahedron + MODULE FUNCTION TensorProdBasis_Hexahedron1( & + & p, & + & q, & + & r, & + & xij, & + & basisType1, & + & basisType2, & + & basisType3, & + & alpha1, & + & beta1, & + & lambda1, & + & alpha2, & + & beta2, & + & lambda2, & + & alpha3, & + & beta3, & + & lambda3) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + INTEGER(I4B), INTENT(IN) :: r + !! highest order in x3 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 + !! basis type in x1 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! alpha3 needed when basisType3 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! beta3 is needed when basisType3 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! lambda3 is needed when basisType3 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1) * (r + 1)) + !! + END FUNCTION TensorProdBasis_Hexahedron1 +END INTERFACE TensorProdBasis_Hexahedron + +INTERFACE OrthogonalBasis_Hexahedron + MODULE PROCEDURE TensorProdBasis_Hexahedron1 +END INTERFACE OrthogonalBasis_Hexahedron + +!---------------------------------------------------------------------------- +! TensorProdBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle +! +!# Introduction +! +! This function returns the tensor product expansion of orthogonal +! polynomial on biunit quadrangle. Here xij is obtained by +! outer product of x and y + +INTERFACE TensorProdBasis_Hexahedron + MODULE FUNCTION TensorProdBasis_Hexahedron2( & + & p, & + & q, & + & r, & + & x, & + & y, & + & z, & + & basisType1, & + & basisType2, & + & basisType3, & + & alpha1, & + & beta1, & + & lambda1, & + & alpha2, & + & beta2, & + & lambda2, & + & alpha3, & + & beta3, & + & lambda3) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + INTEGER(I4B), INTENT(IN) :: r + !! highest order in x3 direction + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 + !! orthogonal polynomial family in x1 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1) * (r + 1)) + !! Tensor basis + !! The number of rows corresponds to the + !! total number of points + END FUNCTION TensorProdBasis_Hexahedron2 +END INTERFACE TensorProdBasis_Hexahedron + +INTERFACE OrthogonalBasis_Hexahedron + MODULE PROCEDURE TensorProdBasis_Hexahedron2 +END INTERFACE OrthogonalBasis_Hexahedron + +!---------------------------------------------------------------------------- +! VertexBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit hexahedron + +INTERFACE VertexBasis_Hexahedron + MODULE PURE FUNCTION VertexBasis_Hexahedron1(x, y, z) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), 8) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Hexahedron1 +END INTERFACE VertexBasis_Hexahedron + +!---------------------------------------------------------------------------- +! VertexBasis_Hexahedron2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Hexahedron2(L1, L2, L3) RESULT(ans) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + !! L2 is Lobatto polynomial evaluated at y coordinates + !! L3 is Lobatto polynomial evaluated at z coordinates + REAL(DFP) :: ans(SIZE(L1, 1), 8) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Hexahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! VertexBasis_Hexahedron2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION VertexBasisGradient_Hexahedron2( & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + !! L2 is Lobatto polynomial evaluated at y coordinates + !! L3 is Lobatto polynomial evaluated at z coordinates + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + !! L2 is Lobatto polynomial evaluated at y coordinates + !! L3 is Lobatto polynomial evaluated at z coordinates + REAL(DFP) :: ans(SIZE(L1, 1), 8, 3) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasisGradient_Hexahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! VertexBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE VertexBasis_Hexahedron + MODULE PURE FUNCTION VertexBasis_Hexahedron3(xij) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + REAL(DFP) :: ans(SIZE(xij, 2), 8) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Hexahedron3 +END INTERFACE VertexBasis_Hexahedron + +!---------------------------------------------------------------------------- +! xEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edges parallel to x axis + +INTERFACE xEdgeBasis_Hexahedron + MODULE PURE FUNCTION xEdgeBasis_Hexahedron1( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & x, & + & y, & + & z) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION xEdgeBasis_Hexahedron1 +END INTERFACE xEdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE xEdgeBasis_Hexahedron + MODULE PURE FUNCTION xEdgeBasis_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION xEdgeBasis_Hexahedron2 +END INTERFACE xEdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE xEdgeBasisGradient_Hexahedron + MODULE PURE FUNCTION xEdgeBasisGradient_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) + END FUNCTION xEdgeBasisGradient_Hexahedron2 +END INTERFACE xEdgeBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! yEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edges parallel to y axis + +INTERFACE yEdgeBasis_Hexahedron + MODULE PURE FUNCTION yEdgeBasis_Hexahedron1( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & x, & + & y, & + & z) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION yEdgeBasis_Hexahedron1 +END INTERFACE yEdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE yEdgeBasis_Hexahedron + MODULE PURE FUNCTION yEdgeBasis_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION yEdgeBasis_Hexahedron2 +END INTERFACE yEdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE yEdgeBasisGradient_Hexahedron + MODULE PURE FUNCTION yEdgeBasisGradient_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) + END FUNCTION yEdgeBasisGradient_Hexahedron2 +END INTERFACE yEdgeBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! zEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edges parallel to y axis + +INTERFACE zEdgeBasis_Hexahedron + MODULE PURE FUNCTION zEdgeBasis_Hexahedron1( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & x, & + & y, & + & z) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION zEdgeBasis_Hexahedron1 +END INTERFACE zEdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE zEdgeBasis_Hexahedron + MODULE PURE FUNCTION zEdgeBasis_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION zEdgeBasis_Hexahedron2 +END INTERFACE zEdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE zEdgeBasisGradient_Hexahedron + MODULE PURE FUNCTION zEdgeBasisGradient_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) + END FUNCTION zEdgeBasisGradient_Hexahedron2 +END INTERFACE zEdgeBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! EdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edges parallel to y axis + +INTERFACE EdgeBasis_Hexahedron + MODULE PURE FUNCTION EdgeBasis_Hexahedron1( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & x, & + & y, & + & z, & + & dim) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + INTEGER(I4B), INTENT(IN) :: dim + !! dim specifies the axis orientation, it can be + !! dim = 1, means x axis + !! dim = 2, means y axis + !! dim = 3, means z axis + REAL(DFP) :: ans(SIZE(x), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION EdgeBasis_Hexahedron1 +END INTERFACE EdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EdgeBasis_Hexahedron + MODULE PURE FUNCTION EdgeBasis_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3, & + & dim) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + INTEGER(I4B), INTENT(IN) :: dim + !! dim specifies the axis orientation, it can be + !! dim = 1, means x axis + !! dim = 2, means y axis + !! dim = 3, means z axis + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4) + END FUNCTION EdgeBasis_Hexahedron2 +END INTERFACE EdgeBasis_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EdgeBasisGradient_Hexahedron + MODULE PURE FUNCTION EdgeBasisGradient_Hexahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3, & + & dim) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge e1, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge e2, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge e3, it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge e4, it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + INTEGER(I4B), INTENT(IN) :: dim + !! dim specifies the axis orientation, it can be + !! dim = 1, means x axis + !! dim = 2, means y axis + !! dim = 3, means z axis + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 + pe4 - 4, 3) + END FUNCTION EdgeBasisGradient_Hexahedron2 +END INTERFACE EdgeBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! xyFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xyFacet + +INTERFACE xyFacetBasis_Hexahedron + MODULE PURE FUNCTION xyFacetBasis_Hexahedron1( & + & n1, & + & n2, & + & x, & + & y, & + & z) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xy face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xy face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans( & + & SIZE(x), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION xyFacetBasis_Hexahedron1 +END INTERFACE xyFacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! xyFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xyFacet + +INTERFACE xyFacetBasis_Hexahedron + MODULE PURE FUNCTION xyFacetBasis_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xy face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xy face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION xyFacetBasis_Hexahedron2 +END INTERFACE xyFacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! xyFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xyFacet + +INTERFACE xyFacetBasisGradient_Hexahedron + MODULE PURE FUNCTION xyFacetBasisGradient_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xy face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xy face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3) + END FUNCTION xyFacetBasisGradient_Hexahedron2 +END INTERFACE xyFacetBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! yzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on yzFacet + +INTERFACE yzFacetBasis_Hexahedron + MODULE PURE FUNCTION yzFacetBasis_Hexahedron1( & + & n1, & + & n2, & + & x, & + & y, & + & z) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of yz face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of yz face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans( & + & SIZE(x), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION yzFacetBasis_Hexahedron1 +END INTERFACE yzFacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! yzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on yzFacet + +INTERFACE yzFacetBasis_Hexahedron + MODULE PURE FUNCTION yzFacetBasis_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of yz face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of yz face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION yzFacetBasis_Hexahedron2 +END INTERFACE yzFacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! yzFacetBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on yzFacet + +INTERFACE yzFacetBasisGradient_Hexahedron + MODULE PURE FUNCTION yzFacetBasisGradient_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of yz face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of yz face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3) + END FUNCTION yzFacetBasisGradient_Hexahedron2 +END INTERFACE yzFacetBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! xzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzFacet + +INTERFACE xzFacetBasis_Hexahedron + MODULE PURE FUNCTION xzFacetBasis_Hexahedron1( & + & n1, & + & n2, & + & x, & + & y, & + & z) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xz face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xz face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans( & + & SIZE(x), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION xzFacetBasis_Hexahedron1 +END INTERFACE xzFacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! xzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzFacet + +INTERFACE xzFacetBasis_Hexahedron + MODULE PURE FUNCTION xzFacetBasis_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xz face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xz face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION xzFacetBasis_Hexahedron2 +END INTERFACE xzFacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! xzFacetBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzFacet + +INTERFACE xzFacetBasisGradient_Hexahedron + MODULE PURE FUNCTION xzFacetBasisGradient_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xz face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xz face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3_I4B) + END FUNCTION xzFacetBasisGradient_Hexahedron2 +END INTERFACE xzFacetBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! xzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzFacet + +INTERFACE FacetBasis_Hexahedron + MODULE PURE FUNCTION FacetBasis_Hexahedron1( & + & n1, & + & n2, & + & x, & + & y, & + & z, & + & dim1, & + & dim2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of the face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of the face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + INTEGER(I4B), INTENT(IN) :: dim1 + !! direction in n1 direction + INTEGER(I4B), INTENT(IN) :: dim2 + !! direction in n2 direction + REAL(DFP) :: ans( & + & SIZE(x), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION FacetBasis_Hexahedron1 +END INTERFACE FacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! FacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzFacet + +INTERFACE FacetBasis_Hexahedron + MODULE PURE FUNCTION FacetBasis_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3, & + & dim1, & + & dim2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xy face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xy face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + INTEGER(I4B), INTENT(IN) :: dim1 + !! direction in n1 direction + INTEGER(I4B), INTENT(IN) :: dim2 + !! direction in n2 direction + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B) + END FUNCTION FacetBasis_Hexahedron2 +END INTERFACE FacetBasis_Hexahedron + +!---------------------------------------------------------------------------- +! FacetBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzFacet + +INTERFACE FacetBasisGradient_Hexahedron + MODULE PURE FUNCTION FacetBasisGradient_Hexahedron2( & + & n1, & + & n2, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3, & + & dim1, & + & dim2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 of xy face + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 of xy face + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + !! Gradient of Lobatto polynomials in x, y, and z direction. + INTEGER(I4B), INTENT(IN) :: dim1 + !! direction in n1 direction + INTEGER(I4B), INTENT(IN) :: dim2 + !! direction in n2 direction + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * 2_I4B, 3) + END FUNCTION FacetBasisGradient_Hexahedron2 +END INTERFACE FacetBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! CellBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on Cell + +INTERFACE CellBasis_Hexahedron + MODULE PURE FUNCTION CellBasis_Hexahedron1( & + & n1, & + & n2, & + & n3, & + & x, & + & y, & + & z) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n3 + !! order along axis 3 + !! it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans( & + & SIZE(x), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * (n3 - 1_I4B)) + END FUNCTION CellBasis_Hexahedron1 +END INTERFACE CellBasis_Hexahedron + +!---------------------------------------------------------------------------- +! CellBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzCell + +INTERFACE CellBasis_Hexahedron + MODULE PURE FUNCTION CellBasis_Hexahedron2( & + & n1, & + & n2, & + & n3, & + & L1, & + & L2, & + & L3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 + !! it should be greater than 3 + INTEGER(I4B), INTENT(IN) :: n3 + !! order along axis 3 + !! it should be greater than 3 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * (n3 - 1_I4B)) + END FUNCTION CellBasis_Hexahedron2 +END INTERFACE CellBasis_Hexahedron + +!---------------------------------------------------------------------------- +! CellBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on xzCell + +INTERFACE CellBasisGradient_Hexahedron + MODULE PURE FUNCTION CellBasisGradient_Hexahedron2( & + & n1, & + & n2, & + & n3, & + & L1, & + & L2, & + & L3, & + & dL1, & + & dL2, & + & dL3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n1 + !! order along axis 1 + !! it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: n2 + !! order along axis 2 + !! it should be greater than 3 + INTEGER(I4B), INTENT(IN) :: n3 + !! order along axis 3 + !! it should be greater than 3 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:), L3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:), dL3(1:, 0:) + !! Lobatto polynomials in x, y, and z direction. + REAL(DFP) :: ans( & + & SIZE(L1, 1), & + & (n1 - 1_I4B) * (n2 - 1_I4B) * (n3 - 1_I4B), 3) + END FUNCTION CellBasisGradient_Hexahedron2 +END INTERFACE CellBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Returns the HeirarchicalBasis on Hexahedron + +INTERFACE HeirarchicalBasis_Hexahedron + MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1( & + & pb1, pb2, pb3, & + & pxy1, pxy2, & + & pxz1, pxz2, & + & pyz1, pyz2, & + & px1, px2, px3, px4, & + & py1, py2, py3, py4, & + & pz1, pz2, pz3, pz4, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3 + !! order of interpolation inside the element in x, y, and z dirs + INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 + !! order of interpolation on facets parallel to xy plane + INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 + !! order of interpolation on facets parallel to xz plane + INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 + !! order of interpolation on facets parallel to yz plane + INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 + !! order of interpolation on edges parallel to x-axis + INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 + !! order of interpolation on edges parallel to y-axis + INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 + !! order of interpolation on edges parallel to z-axis + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & 8_I4B & + & + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & + & + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & + & + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & + & + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & + & + (px1 + px2 + px3 + px4 - 4_I4B) & + & + (py1 + py2 + py3 + py4 - 4_I4B) & + & + (pz1 + pz2 + pz3 + pz4 - 4_I4B) & + & ) + !! + END FUNCTION HeirarchicalBasis_Hexahedron1 +END INTERFACE HeirarchicalBasis_Hexahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Returns the HeirarchicalBasis on Hexahedron + +INTERFACE HeirarchicalBasis_Hexahedron + MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2( & + & p, q, r, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! order of interpolation in x, y, and z dirs + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & 8_I4B & + & + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) & + & + (p - 1_I4B) * (q - 1_I4B) * 2_I4B & + & + (p - 1_I4B) * (r - 1_I4B) * 2_I4B & + & + (q - 1_I4B) * (r - 1_I4B) * 2_I4B & + & + (4_I4B * p - 4_I4B) & + & + (4_I4B * q - 4_I4B) & + & + (4_I4B * r - 4_I4B) & + & ) + !! + END FUNCTION HeirarchicalBasis_Hexahedron2 +END INTERFACE HeirarchicalBasis_Hexahedron + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-19 +! summary: Returns quadrature points on reference hexahedron + +INTERFACE QuadraturePoint_Hexahedron + MODULE FUNCTION QuadraturePoint_Hexahedron1( & + & order, & + & quadType, & + & refHexahedron, & + & xij, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand in x, y, and z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev1 + !! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight + !! GaussUltraspherical + !! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight + !! GaussJacobi + !! GaussJacobiLobatto + !! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refHexahedron + !! Reference hexahedron + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordiantes of hexahedron in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! quadrature points in xij format + END FUNCTION QuadraturePoint_Hexahedron1 +END INTERFACE QuadraturePoint_Hexahedron + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Hexahedron + MODULE FUNCTION QuadraturePoint_Hexahedron2( & + & p, q, r, & + & quadType1, quadType2, quadType3, & + & refHexahedron, & + & xij, & + & alpha1, beta1, lambda1, & + & alpha2, beta2, lambda2, & + & alpha3, beta3, lambda3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order of integrand in z direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 + !! quadrature point type in x direction + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev1 + !! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight + !! GaussUltraspherical + !! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight + !! GaussJacobi + !! GaussJacobiLobatto + !! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refHexahedron + !! Reference hexahedron + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Hexahedron2 +END INTERFACE QuadraturePoint_Hexahedron + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-19 +! summary: Returns quadrature points on reference quadrangle + +INTERFACE QuadraturePoint_Hexahedron + MODULE FUNCTION QuadraturePoint_Hexahedron3( & + & nips, & + & quadType, & + & refHexahedron, & + & xij, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! number of integration points in x, y, and z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! interpolation point type + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev1 + !! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight + !! GaussUltraspherical + !! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight + !! GaussJacobi + !! GaussJacobiLobatto + !! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refHexahedron + !! Reference hexahedron + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: 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_Hexahedron3 +END INTERFACE QuadraturePoint_Hexahedron + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Hexahedron + MODULE FUNCTION QuadraturePoint_Hexahedron4( & + & nipsx, nipsy, nipsz, & + & quadType1, quadType2, quadType3, & + & refHexahedron, & + & xij, & + & alpha1, beta1, lambda1, & + & alpha2, beta2, lambda2, & + & alpha3, beta3, lambda3 & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! order of integrand in z direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 + !! quadrature point type in x, y, and z direction + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev1 + !! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight + !! GaussUltraspherical + !! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight + !! GaussJacobi + !! GaussJacobiLobatto + !! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refHexahedron + !! Reference hexahedron + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi and Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Hexahedron4 +END INTERFACE QuadraturePoint_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Hexahedron + MODULE FUNCTION LagrangeEvalAll_Hexahedron1( & + & 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(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + REAL(DFP), 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_Hexahedron1 +END INTERFACE LagrangeEvalAll_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Hexahedron + MODULE FUNCTION LagrangeEvalAll_Hexahedron2( & + & 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 + !! x(3, :) is z 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 + !! 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(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Hexahedron2 +END INTERFACE LagrangeEvalAll_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Gradient of Lagrange polynomials + +INTERFACE LagrangeGradientEvalAll_Hexahedron + MODULE FUNCTION LagrangeGradientEvalAll_Hexahedron1( & + & 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 + 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), 3) + !! 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_Hexahedron1 +END INTERFACE LagrangeGradientEvalAll_Hexahedron + +!---------------------------------------------------------------------------- +! TensorProdBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron + +INTERFACE TensorProdBasisGradient_Hexahedron + MODULE FUNCTION TensorProdBasisGradient_Hexahedron1( & + & p, & + & q, & + & r, & + & xij, & + & basisType1, & + & basisType2, & + & basisType3, & + & alpha1, & + & beta1, & + & lambda1, & + & alpha2, & + & beta2, & + & lambda2, & + & alpha3, & + & beta3, & + & lambda3) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + INTEGER(I4B), INTENT(IN) :: r + !! highest order in x3 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 + !! basis type in x1 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! alpha3 needed when basisType3 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! beta3 is needed when basisType3 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! lambda3 is needed when basisType3 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1) * (r + 1), 3) + END FUNCTION TensorProdBasisGradient_Hexahedron1 +END INTERFACE TensorProdBasisGradient_Hexahedron + +INTERFACE OrthogonalBasisGradient_Hexahedron + MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1 +END INTERFACE OrthogonalBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Returns the HeirarchicalBasisGradient on Hexahedron + +INTERFACE HeirarchicalBasisGradient_Hexahedron + MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron1( & + & pb1, pb2, pb3, & + & pxy1, pxy2, & + & pxz1, pxz2, & + & pyz1, pyz2, & + & px1, px2, px3, px4, & + & py1, py2, py3, py4, & + & pz1, pz2, pz3, pz4, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3 + !! order of interpolation inside the element in x, y, and z dirs + INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 + !! order of interpolation on facets parallel to xy plane + INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 + !! order of interpolation on facets parallel to xz plane + INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 + !! order of interpolation on facets parallel to yz plane + INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 + !! order of interpolation on edges parallel to x-axis + INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 + !! order of interpolation on edges parallel to y-axis + INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 + !! order of interpolation on edges parallel to z-axis + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & 8_I4B & + & + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & + & + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & + & + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & + & + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & + & + (px1 + px2 + px3 + px4 - 4_I4B) & + & + (py1 + py2 + py3 + py4 - 4_I4B) & + & + (pz1 + pz2 + pz3 + pz4 - 4_I4B), & + & 3_I4B) + END FUNCTION HeirarchicalBasisGradient_Hexahedron1 +END INTERFACE HeirarchicalBasisGradient_Hexahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Returns the HeirarchicalBasisGradient on Hexahedron + +INTERFACE HeirarchicalBasisGradient_Hexahedron + MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron2( & + & p, q, r, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! order of interpolation in x, y, and z dirs + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & 8_I4B & + & + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) & + & + (p - 1_I4B) * (q - 1_I4B) * 2_I4B & + & + (p - 1_I4B) * (r - 1_I4B) * 2_I4B & + & + (q - 1_I4B) * (r - 1_I4B) * 2_I4B & + & + (4_I4B * p - 4_I4B) & + & + (4_I4B * q - 4_I4B) & + & + (4_I4B * r - 4_I4B), & + & 3_I4B) + END FUNCTION HeirarchicalBasisGradient_Hexahedron2 +END INTERFACE HeirarchicalBasisGradient_Hexahedron + +END MODULE HexahedronInterpolationUtility diff --git a/src/modules/Polynomial/src/InterpolationUtility.F90 b/src/modules/Polynomial/src/InterpolationUtility.F90 new file mode 100644 index 000000000..fc76c2f07 --- /dev/null +++ b/src/modules/Polynomial/src/InterpolationUtility.F90 @@ -0,0 +1,96 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE InterpolationUtility +USE GlobalData, ONLY: I4B, DFP, REAL32, REAL64 +IMPLICIT NONE +PRIVATE +PUBLIC :: VandermondeMatrix +PUBLIC :: GetTotalInDOF +PUBLIC :: GetTotalDOF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 July 2022 +! summary: Returns vandermonde matrix + +INTERFACE VandermondeMatrix + MODULE PURE FUNCTION VandermondeMatrix_Real32(order, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + REAL(REAL32), INTENT(IN) :: x(:) + REAL(REAL32) :: ans(SIZE(x), order + 1) + END FUNCTION VandermondeMatrix_Real32 + + MODULE PURE FUNCTION VandermondeMatrix_Real64(order, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + REAL(REAL64), INTENT(IN) :: x(:) + REAL(REAL64) :: ans(SIZE(x), order + 1) + END FUNCTION VandermondeMatrix_Real64 +END INTERFACE VandermondeMatrix + +!---------------------------------------------------------------------------- +! GetTotalDOF +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-20 +! summary: Get total number of degrees of freedom + +INTERFACE GetTotalDOF + MODULE PURE FUNCTION GetTotalDOF1(elemType, order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + !! element type, Point, Line, Triangle + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + CHARACTER(LEN=*), INTENT(IN) :: baseContinuity + !! continuity of basis, H1, HDiv, HCurl + CHARACTER(LEN=*), INTENT(IN) :: baseInterpolation + !! interpolation of basis, Lagrange, Heirarchical + INTEGER(I4B) :: ans + !! total number of degrees of freedom + END FUNCTION GetTotalDOF1 +END INTERFACE GetTotalDOF + +!---------------------------------------------------------------------------- +! GetTotalInDOF +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-20 +! summary: Get total number of degrees of freedom internal to the element + +INTERFACE GetTotalInDOF + MODULE PURE FUNCTION GetTotalInDOF1(elemType, order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + !! element type, Point, Line, Triangle + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + CHARACTER(LEN=*), INTENT(IN) :: baseContinuity + !! continuity of basis, H1, HDiv, HCurl + CHARACTER(LEN=*), INTENT(IN) :: baseInterpolation + !! interpolation of basis, Lagrange, Heirarchical + INTEGER(I4B) :: ans + !! total number of degrees of freedom + END FUNCTION GetTotalInDOF1 +END INTERFACE GetTotalInDOF + +END MODULE InterpolationUtility diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 new file mode 100644 index 000000000..c8357a7e4 --- /dev/null +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -0,0 +1,1089 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to Jacobi Polynomials is defined. +! +!{!pages/JacobiPolynomialUtility.md!} + +MODULE JacobiPolynomialUtility +USE GlobalData +USE BaseType, ONLY: iface_1DFunction +IMPLICIT NONE +PRIVATE +PUBLIC :: GetJacobiRecurrenceCoeff +PUBLIC :: GetJacobiRecurrenceCoeff2 +PUBLIC :: JacobiAlpha +PUBLIC :: JacobiBeta +PUBLIC :: JacobiLeadingCoeff +PUBLIC :: JacobiLeadingCoeffRatio +PUBLIC :: JacobiNormSQR +PUBLIC :: JacobiNormSQR2 +PUBLIC :: JacobiNormSQRRatio +PUBLIC :: JacobiJacobiMatrix +PUBLIC :: JacobiGaussQuadrature +PUBLIC :: JacobiJacobiRadauMatrix +PUBLIC :: JacobiGaussRadauQuadrature +PUBLIC :: JacobiJacobiLobattoMatrix +PUBLIC :: JacobiGaussLobattoQuadrature +PUBLIC :: JacobiZeros +PUBLIC :: JacobiQuadrature +PUBLIC :: JacobiEvalAll +PUBLIC :: JacobiEval +PUBLIC :: JacobiEvalSum +PUBLIC :: JacobiGradientEval +PUBLIC :: JacobiGradientEvalAll +PUBLIC :: JacobiGradientEvalSum +PUBLIC :: JacobiTransform +PUBLIC :: JacobiInvTransform +PUBLIC :: JacobiGradientCoeff +PUBLIC :: JacobiDMatrix + +!---------------------------------------------------------------------------- +! GetJacobiRecurrenceCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Return the recurrence coefficient for nth order monic polynomial +! +!# Introduction +! +! These recurrence coefficients are for monic jacobi polynomials. + +INTERFACE + MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff(n, alpha, beta, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetJacobiRecurrenceCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! GetJacobiRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Return the recurrence coefficient for nth order polynomial +! +!# Introduction +! +! These recurrence coefficients are for non-monic jacobi polynomials. +! +!$$ +! P_{n+1}^{(\alpha,\beta)}=\left(a_{n}x+b_{n}\right)P_{n}^{(\alpha,\beta)} +! -c_{n}P_{n-1}^{(\alpha,\beta)},\quad n=1,2,\cdots +!$$ + +INTERFACE + MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff2(n, alpha, beta, & + & A, B, C) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + END SUBROUTINE GetJacobiRecurrenceCoeff2 +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiAlpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Returns reccurence coeff alpha + +INTERFACE + MODULE ELEMENTAL PURE FUNCTION JacobiAlpha(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Jacobi poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Jacobi poly + REAL(DFP) :: ans + !! answer + END FUNCTION JacobiAlpha +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiBeta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Returns reccurence coeff beta + +INTERFACE + MODULE ELEMENTAL PURE FUNCTION JacobiBeta(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Jacobi poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Jacobi poly + REAL(DFP) :: ans + !! answer + END FUNCTION JacobiBeta +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Leading coefficient of Jacobi polynomial + +INTERFACE + MODULE PURE FUNCTION JacobiLeadingCoeff(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Jacobi poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Jacobi poly + REAL(DFP) :: ans + !! answer + END FUNCTION JacobiLeadingCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiLeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Leading coefficient ratio of Jacobi polynomial, n+1/n + +INTERFACE + MODULE PURE FUNCTION JacobiLeadingCoeffRatio(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Jacobi poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Jacobi poly + REAL(DFP) :: ans + !! answer + END FUNCTION JacobiLeadingCoeffRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiNormSQR +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Square norm of Jacobi polynomial +! +!# Introduction +! +! This function returns the following +! +!$$ +!\Vert P_{n}^{\alpha,\beta}\Vert_{d\lambda}^{2}=\int_{-1}^{+1}P_{n}^ +!{\alpha,\beta}P_{n}^{\alpha,\beta}(1-x)^{\alpha}(1+x)^{\beta}dx +!$$ + +INTERFACE + MODULE PURE FUNCTION JacobiNormSQR(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans + END FUNCTION JacobiNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiNormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Square norm of Jacobi polynomial +! +!# Introduction +! +! This function returns the following +! +!$$ +!\Vert P_{n}^{\alpha,\beta}\Vert_{d\lambda}^{2}=\int_{-1}^{+1}P_{n}^ +!{\alpha,\beta}P_{n}^{\alpha,\beta}(1-x)^{\alpha}(1+x)^{\beta}dx +!$$ + +INTERFACE + MODULE PURE FUNCTION JacobiNormSQR2(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans(0:n) + END FUNCTION JacobiNormSQR2 +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiNormSQRRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Ratio of Square norm of Jacobi polynomial n+1/n + +INTERFACE + MODULE PURE FUNCTION JacobiNormSQRRatio(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans + END FUNCTION JacobiNormSQRRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiJacobiMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE JacobiJacobiMatrix(n, alpha, beta, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of jacobu poly + REAL(DFP), INTENT(IN) :: beta + !! beta of jacobi poly + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE JacobiJacobiMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiGaussQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss quadrature points for Jacobi Polynomial +! +!# Introduction +! +! This routine computes the n Gauss-Quadrature points. Which, +! are n zeros of a jacobi polynomial defined with respect to the +! weight $(1-x)^{\alpha} (1+x)^{\beta}$. +! +! All Gauss-Quadrature points are inside $(-1, 1)$ + +INTERFACE + MODULE SUBROUTINE JacobiGaussQuadrature(n, alpha, beta, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! It represents the order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! the size is 1 to n + END SUBROUTINE JacobiGaussQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiJacobiRadauMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE JacobiJacobiRadauMatrix(a, n, alpha, beta, D, & + & E, alphaCoeff, betaCoeff) + REAL(DFP), INTENT(IN) :: a + !! one of the end of the domain + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of jacobu poly + REAL(DFP), INTENT(IN) :: beta + !! beta of jacobi poly + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+1 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE JacobiJacobiRadauMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiGaussRadauQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Radau quadrature points for Jacobi Polynomial +! +!# Introduction +! +! This routine returns the $n+1$ Quadrature points and weights. +! +! The Gauss-Radau quadrature points consists one of the end points denoted +! by $a$. So $a$ can be $\pm 1$. The remaining $n$ points are internal to +! to $(-1, +1)$, and they are n-zeros of Jacobi polynomial of order n with +! respect to the following weight. +! +!- $(1-x)^{\alpha} (1+x)^{\beta} (x+1)$ if $a=-1$. +!- $(1-x)^{\alpha} (1+x)^{\beta} (1-x)$ if $a=+1$. +! +! Here n is the order of Jacobi polynomial. +! +! If $a=1$ then n+1 quadrature point will be +1 +! If $a=-1$ then 1st quadrature point will be -1 + +INTERFACE + MODULE SUBROUTINE JacobiGaussRadauQuadrature(a, n, alpha, beta, pt, wt) + REAL(DFP), INTENT(IN) :: a + !! the value of one of the end points + !! it should be either -1 or +1 + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+1 weights from 1 to n+1 + END SUBROUTINE JacobiGaussRadauQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiJacobiLobattoMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE JacobiJacobiLobattoMatrix(n, alpha, beta, D, & + & E, alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of jacobu poly + REAL(DFP), INTENT(IN) :: beta + !! beta of jacobi poly + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+2 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE JacobiJacobiLobattoMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Lobatto quadrature points for Jacobi Polynomial +! +!# Introduction +! +! This routine returns the $n+2$ Quadrature points and weights. +! +! The Gauss-Lobatto quadrature points consists both $\pm 1$ as +! quadrature points. +! +!- The first quadrature point is $-1$ +!- The second quadrature point is $+1$ +! +! The remaining $n$ points are internal to +! to $(-1, +1)$, and they are n-zeros of Jacobi polynomial of order n with +! respect to the following weight. +! +!$$(1-x)^{\alpha} (1+x)^{\beta} (x+1)(1-x)$$ +! +! Here n is the order of Jacobi polynomial. + +INTERFACE + MODULE SUBROUTINE JacobiGaussLobattoQuadrature(n, alpha, beta, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomials + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+2 quad points indexed from 1 to n+2 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+2 weights, index from 1 to n+2 + END SUBROUTINE JacobiGaussLobattoQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Jacobi polynomials + +INTERFACE + MODULE FUNCTION JacobiZeros(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans(n) + END FUNCTION JacobiZeros +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Jacobi-Gauss, Jacobi-Radau, Jacobi-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Jacobi polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of jacobi polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE JacobiQuadrature(n, alpha, beta, pt, wt, quadType) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Jacobi polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + END SUBROUTINE JacobiQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobiEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomials from order = 0 to n at single points +! +!# Introduction +! +! Evaluate Jacobi polynomials from order = 0 to n at single points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(1:N+1), the values of the first N+1 Jacobi polynomials at x + +INTERFACE JacobiEvalAll + MODULE PURE FUNCTION JacobiEvalAll1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION JacobiEvalAll1 +END INTERFACE JacobiEvalAll + +!---------------------------------------------------------------------------- +! JacobiEvalUpto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomial of order = 0 to n at several points +! +!# Introduction +! +! Evaluate Jacobi polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Jacobi polynomials at the point +! X. + +INTERFACE JacobiEvalAll + MODULE PURE FUNCTION JacobiEvalAll2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION JacobiEvalAll2 +END INTERFACE JacobiEvalAll + +!---------------------------------------------------------------------------- +! JacobiEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomials of order n at single points. +! +!# Introduction +! +! Evaluate Jacobi polynomials of order n at single points. +! +!- N, the order of polynomial to compute. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. + +INTERFACE JacobiEval + MODULE PURE FUNCTION JacobiEval1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEval1 +END INTERFACE JacobiEval + +!---------------------------------------------------------------------------- +! JacobiEvalUpto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomials of order n at several points +! +!# Introduction +! +! Evaluate Jacobi polynomials of order n at several points +! +!- N, the order of polynomial to compute. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. + +INTERFACE JacobiEval + MODULE PURE FUNCTION JacobiEval2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEval2 +END INTERFACE JacobiEval + +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Jacobi polynomials at point x + +INTERFACE JacobiEvalSum + MODULE PURE FUNCTION JacobiEvalSum1(n, alpha, beta, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEvalSum1 +END INTERFACE JacobiEvalSum + +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Jacobi polynomials at several x + +INTERFACE JacobiEvalSum + MODULE PURE FUNCTION JacobiEvalSum2(n, alpha, beta, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEvalSum2 +END INTERFACE JacobiEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE JacobiGradientEval + MODULE PURE FUNCTION JacobiGradientEval1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP) :: ans + !! Derivative of Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEval1 +END INTERFACE JacobiGradientEval + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE JacobiGradientEval + MODULE PURE FUNCTION JacobiGradientEval2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Derivative of Jacobi polynomial of order n at x + END FUNCTION JacobiGradientEval2 +END INTERFACE JacobiGradientEval + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE JacobiGradientEvalAll + MODULE PURE FUNCTION JacobiGradientEvalAll1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP) :: ans(n + 1) + !! Derivative of Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalAll1 +END INTERFACE JacobiGradientEvalAll + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE JacobiGradientEvalAll + MODULE PURE FUNCTION JacobiGradientEvalAll2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Derivative of Jacobi polynomial of order n at x + END FUNCTION JacobiGradientEvalAll2 +END INTERFACE JacobiGradientEvalAll + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Jacobi polynomials at +! point x + +INTERFACE JacobiGradientEvalSum + MODULE PURE FUNCTION JacobiGradientEvalSum1(n, alpha, beta, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum1 +END INTERFACE JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Jacobi polynomials at +! several x + +INTERFACE JacobiGradientEvalSum + MODULE PURE FUNCTION JacobiGradientEvalSum2(n, alpha, beta, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum2 +END INTERFACE JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Jacobi polynomials at +! point x + +INTERFACE JacobiGradientEvalSum + MODULE PURE FUNCTION JacobiGradientEvalSum3(n, alpha, beta, x, coeff, k) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum3 +END INTERFACE JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Jacobi polynomials at +! several x + +INTERFACE JacobiGradientEvalSum + MODULE PURE FUNCTION JacobiGradientEvalSum4(n, alpha, beta, x, coeff, k) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum4 +END INTERFACE JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform + +INTERFACE JacobiTransform + MODULE PURE FUNCTION JacobiTransform1(n, alpha, beta, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION JacobiTransform1 +END INTERFACE JacobiTransform + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Jacobi Transform + +INTERFACE JacobiTransform + MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION JacobiTransform2 +END INTERFACE JacobiTransform + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the jacobi transformation of a function defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls `JacobiQuadrature` +! which is not pure due to Lapack call. +!@endnote + +INTERFACE JacobiTransform + MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION JacobiTransform3 +END INTERFACE JacobiTransform + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform + +INTERFACE JacobiInvTransform + MODULE PURE FUNCTION JacobiInvTransform1(n, alpha, beta, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION JacobiInvTransform1 +END INTERFACE JacobiInvTransform + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform + +INTERFACE JacobiInvTransform + MODULE PURE FUNCTION JacobiInvTransform2(n, alpha, beta, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION JacobiInvTransform2 +END INTERFACE JacobiInvTransform + +!---------------------------------------------------------------------------- +! JacobiGradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Jacobi expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Jacobi expansion. +! Input is cofficients of Jacobipolynomials (modal values). +! + +INTERFACE JacobiGradientCoeff + MODULE PURE FUNCTION JacobiGradientCoeff1(n, alpha, beta, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from JacobiTransform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION JacobiGradientCoeff1 +END INTERFACE JacobiGradientCoeff + +!---------------------------------------------------------------------------- +! JacobiDMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Jacobi expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Jacobi expansion. +! Input is cofficients of Jacobipolynomials (modal values). +! + +INTERFACE JacobiDMatrix + MODULE PURE FUNCTION JacobiDMatrix1(n, alpha, beta, x, quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION JacobiDMatrix1 +END INTERFACE JacobiDMatrix + +END MODULE JacobiPolynomialUtility diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 new file mode 100644 index 000000000..a5c151d8c --- /dev/null +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -0,0 +1,456 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Methods for Lagrange polynomials are defined +! +!{!pages/LagrangePolynomialUtility.md!} + +MODULE LagrangePolynomialUtility +USE GlobalData, ONLY: DFP, I4B, LGT +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE +PUBLIC :: LagrangeDOF +PUBLIC :: LagrangeInDOF +PUBLIC :: LagrangeDegree +PUBLIC :: LagrangeVandermonde +PUBLIC :: LagrangeVandermonde_ +PUBLIC :: EquidistancePoint +PUBLIC :: InterpolationPoint +PUBLIC :: LagrangeCoeff +PUBLIC :: RefCoord +PUBLIC :: RefElemDomain +PUBLIC :: LagrangeEvalAll +PUBLIC :: LagrangeGradientEvalAll + +!---------------------------------------------------------------------------- +! RefElemDomain +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain(elemType, baseContinuity, baseInterpol) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type + CHARACTER(*), INTENT(IN) :: baseContinuity + !! Cointinuity (conformity) of basis functions + !! "H1", "HDiv", "HCurl", "DG" + CHARACTER(*), INTENT(IN) :: baseInterpol + !! Basis function family for Interpolation + !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal + TYPE(String) :: ans + END FUNCTION RefElemDomain +END INTERFACE + +!---------------------------------------------------------------------------- +! RefCoord +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE PURE FUNCTION RefCoord(elemType, refElem) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type + CHARACTER(*), INTENT(IN) :: refElem + !! "UNIT" + !! "BIUNIT" + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION RefCoord +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDOF@BasisMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the number of dof for lagrange polynomial + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION LagrangeDOF +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF@BasisMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the number of internal dof for lagrange polynomial + +INTERFACE + MODULE PURE FUNCTION LagrangeInDOF(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION LagrangeInDOF +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the degrees of monomials for lagrange polynomial + +INTERFACE + MODULE PURE FUNCTION LagrangeDegree(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type: Line, Triangle, Quadrangle, Tetrahedron, ... + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeVandermonde +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the Vandermonde matrix + +INTERFACE + MODULE PURE FUNCTION LagrangeVandermonde(xij, order, elemType) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in $x_{iJ}$ format + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! vandermonde matrix + !! nrows := number of points + !! ncols := number of dof + END FUNCTION LagrangeVandermonde +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeVandermonde +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the Vandermonde matrix + +INTERFACE + MODULE PURE SUBROUTINE LagrangeVandermonde_(xij, order, elemType, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in $x_{iJ}$ format + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! vandermonde matrix + !! nrows := number of points + !! ncols := number of dof + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeVandermonde_ +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistancePoint +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Equidistance points on 1D/2D/3D elements + +INTERFACE + MODULE FUNCTION EquidistancePoint( & + & order, & + & elemType, & + & xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of element + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type + !! Point, Line, Triangle, Quadrangle, Tetrahedron + !! Hexahedron, Prism, Pyramid + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of linear elements + !! Default values: + !! Biunit line + !! Unit triangle + !! Biunit Quadrangle + !! Unit Tetrahedron + !! Biunit Hexahedron + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Equidistance points in xij format + !! Number of rows = nsd + !! Number of columns = Number of points + !! The number of points depend upon the order and elemType + END FUNCTION EquidistancePoint +END INTERFACE + +!---------------------------------------------------------------------------- +! InterpolationPoint +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Get the interpolation point + +INTERFACE + MODULE FUNCTION InterpolationPoint( & + & order, & + & elemType, & + & ipType, & + & xij, & + & layout, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: elemType + !! element type, following values are allowed. + !! Point, Line, Triangle, Quadrangle, Tetrahedron + !! Hexahedron, Prism, Pyramid + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto, + !! GaussUltraspherical, GaussUltrasphericalLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of linear elements. + !! Domain of interpolation, default values are given by: + !! Biunit line + !! Unit triangle + !! Biunit Quadrangle + !! Unit Tetrahedron + !! Biunit Hexahedron + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" Vertex, Edge, Face, Cell + !! "INCREASING" incresing order + !! "DECREASING" decreasing order + !! "XYZ" First X, then Y, then Z + !! "YXZ" First Y, then X, then Z + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Jacobi and Ultraspherical parameters + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION InterpolationPoint +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Returns the coefficient of ith lagrange poly + +INTERFACE LagrangeCoeff + MODULE FUNCTION LagrangeCoeff1(order, elemType, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff1 +END INTERFACE LagrangeCoeff + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Returns the coefficient of all lagrange poly + +INTERFACE LagrangeCoeff + MODULE FUNCTION LagrangeCoeff2(order, elemType, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff2 +END INTERFACE LagrangeCoeff + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff + MODULE FUNCTION LagrangeCoeff3(order, elemType, i, v, & + & isVandermonde) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff3 +END INTERFACE LagrangeCoeff + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff + MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff4 +END INTERFACE LagrangeCoeff + +!---------------------------------------------------------------------------- +! LagrangeEvalAll +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll + MODULE FUNCTION LagrangeEvalAll1( & + & order, & + & elemType, & + & x, & + & xij, & + & domainName, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll1 +END INTERFACE LagrangeEvalAll + +!---------------------------------------------------------------------------- +! LagrangeEvalAll +!---------------------------------------------------------------------------- + +INTERFACE LagrangeGradientEvalAll + MODULE FUNCTION LagrangeGradientEvalAll1( & + & order, & + & elemType, & + & x, & + & xij, & + & domainName, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), SIZE(x, 1)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeGradientEvalAll1 +END INTERFACE LagrangeGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE LagrangePolynomialUtility diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 new file mode 100644 index 000000000..9c7ff28b6 --- /dev/null +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -0,0 +1,1150 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to Legendre Polynomials is defined. +! +!{!pages/LegendrePolynomialUtility.md!} + +MODULE LegendrePolynomialUtility +USE GlobalData +USE BaseType, ONLY: iface_1DFunction +IMPLICIT NONE +PRIVATE +PUBLIC :: LegendreAlpha +PUBLIC :: LegendreBeta +PUBLIC :: GetLegendreRecurrenceCoeff +PUBLIC :: GetLegendreRecurrenceCoeff2 +PUBLIC :: LegendreLeadingCoeff +PUBLIC :: LegendreLeadingCoeffRatio +PUBLIC :: LegendreNormSQR +PUBLIC :: LegendreNormSQR2 +PUBLIC :: LegendreNormSqrRatio +PUBLIC :: LegendreJacobiMatrix +PUBLIC :: LegendreGaussQuadrature +PUBLIC :: LegendreJacobiRadauMatrix +PUBLIC :: LegendreGaussRadauQuadrature +PUBLIC :: LegendreJacobiLobattoMatrix +PUBLIC :: LegendreGaussLobattoQuadrature +PUBLIC :: LegendreZeros +PUBLIC :: LegendreQuadrature +PUBLIC :: LegendreEval +PUBLIC :: LegendreEvalAll +PUBLIC :: LegendreMonomialExpansionAll +PUBLIC :: LegendreMonomialExpansion +PUBLIC :: LegendreGradientEvalAll +PUBLIC :: LegendreGradientEval +PUBLIC :: LegendreEvalSum +PUBLIC :: LegendreGradientEvalSum +PUBLIC :: LegendreTransform +PUBLIC :: LegendreInvTransform +PUBLIC :: LegendreGradientCoeff +PUBLIC :: LegendreDMatrix +PUBLIC :: LegendreDMatEvenOdd + +!---------------------------------------------------------------------------- +! LegendreAlpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, alpha, of Legendre polynomial + +INTERFACE + MODULE PURE FUNCTION LegendreAlpha(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreAlpha +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreBeta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Legendre polynomial + +INTERFACE + MODULE PURE FUNCTION LegendreBeta(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreBeta +END INTERFACE + +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the recurrence coefficient for monic Legendre polynomial +! +!# Introduction +! +! These recurrence coefficients are for monic Legendre polynomials. +! +!$$ +! \pi_{n+1}=\left(x-\alpha_{n}\right)\pi_{n}-\beta_{n}\pi_{n-1},\quad n=0,1,2 +!$$ +! +!$$ +! \alpha_{n}=0,n\ge0 +!$$ +! +!$$ +! \beta_{0}=2 +!$$ +! +!$$ +! \beta_{n\ge1}=\frac{n^{2}}{4n^{2}-1} +!$$ + +INTERFACE + MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff(n, alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial, it should be greater than 1 + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetLegendreRecurrenceCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the recurrence coefficient for Legendre polynomial + +INTERFACE + MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff2(n, A, B, C) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial, it should be greater than 1 + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + !! size is n + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + !! this coefficient is zero + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + !! size is n + END SUBROUTINE GetLegendreRecurrenceCoeff2 +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Leading coefficient of Legendre polynomial +! +!# Introduction +! +! Leading coefficient of legendre polynomial +! +!$$ +! k_{n}=\frac{\left(2n\right)!}{2^{n}\left(n!\right)^{2}} +!$$ +! + +INTERFACE + MODULE PURE FUNCTION LegendreLeadingCoeff(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreLeadingCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreLeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Ration of Leading coefficient of Legendre polynomial n+1/n + +INTERFACE + MODULE PURE FUNCTION LegendreLeadingCoeffRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreLeadingCoeffRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreNormSQR +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Legendre polynomial +! +!# Introduction +! +! This function returns the square norm of legendre polynomial +! +!$$ +! \Vert P_{n}\Vert^{2}=:h_{n}=\frac{2}{2n+1} +!$$ + +INTERFACE + MODULE PURE FUNCTION LegendreNormSQR(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION LegendreNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreNormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Legendre polynomial +! +!# Introduction +! +! This function returns the square norm of legendre polynomial +! +!$$ +! \Vert P_{n}\Vert^{2}=:h_{n}=\frac{2}{2n+1} +!$$ + +INTERFACE + MODULE PURE FUNCTION LegendreNormSQR2(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(0:n) + END FUNCTION LegendreNormSQR2 +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreNormSQRRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Ratio of Square norm of Legendre polynomial n+1/n + +INTERFACE + MODULE PURE FUNCTION LegendreNormSQRRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION LegendreNormSQRRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreJacobiMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the Jacobi matrix for Legendre polynomial + +INTERFACE + MODULE PURE SUBROUTINE LegendreJacobiMatrix(n, D, E, alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + !! recurrence coefficient of monic legendre polynomial, from 0 to n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + !! recurrence coefficient of monic legendre polynomial, from 0 to n-1 + END SUBROUTINE LegendreJacobiMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreGaussQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss quadrature points for Legendre Polynomial +! +!# Introduction +! +! This routine computes the n Gauss-Quadrature points. Which, +! are n zeros of a Legendre polynomial defined with respect to the +! weight $(1-x)^{\alpha} (1+x)^{\beta}$. +! +! All Gauss-Quadrature points are inside $(-1, 1)$ + +INTERFACE + MODULE SUBROUTINE LegendreGaussQuadrature(n, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! It represents the order of Legendre polynomial + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! the size is 1 to n + END SUBROUTINE LegendreGaussQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreJacobiRadauMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE LegendreJacobiRadauMatrix(a, n, D, E, alphaCoeff, & + & betaCoeff) + REAL(DFP), INTENT(IN) :: a + !! one of the end of the domain + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+1 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE LegendreJacobiRadauMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreGaussRadauQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Radau quadrature points for Legendre Polynomial +! +!# Introduction +! +! This routine returns the $n+1$ Quadrature points and weights. +! +! The Gauss-Radau quadrature points consists one of the end points denoted +! by $a$. So $a$ can be $\pm 1$. The remaining $n$ points are internal to +! to $(-1, +1)$, and they are n-zeros of Legendre polynomial of order n with +! respect to the following weight. +! +!- $(1-x)^{\alpha} (1+x)^{\beta} (x+1)$ if $a=-1$. +!- $(1-x)^{\alpha} (1+x)^{\beta} (1-x)$ if $a=+1$. +! +! Here n is the order of Legendre polynomial. +! +! If $a=1$ then n+1 quadrature point will be +1 +! If $a=-1$ then 1st quadrature point will be -1 + +INTERFACE + MODULE SUBROUTINE LegendreGaussRadauQuadrature(a, n, pt, wt) + REAL(DFP), INTENT(IN) :: a + !! the value of one of the end points + !! it should be either -1 or +1 + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+1 weights from 1 to n+1 + END SUBROUTINE LegendreGaussRadauQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreLegendreLobattoMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE LegendreJacobiLobattoMatrix(n, D, E, alphaCoeff, & + & betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+2 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE LegendreJacobiLobattoMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Lobatto quadrature points for Legendre Polynomial +! +!# Introduction +! +! This routine returns the $n+2$ Quadrature points and weights. +! +! The Gauss-Lobatto quadrature points consists both $\pm 1$ as +! quadrature points. +! +!- The first quadrature point is $-1$ +!- The second quadrature point is $+1$ +! +! The remaining $n$ points are internal to +! to $(-1, +1)$, and they are n-zeros of Legendre polynomial of order n with +! respect to the following weight. +! +!$$(1-x)^{\alpha} (1+x)^{\beta} (x+1)(1-x)$$ +! +! Here n is the order of Legendre polynomial. + +INTERFACE + MODULE SUBROUTINE LegendreGaussLobattoQuadrature(n, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomials + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+2 quad points indexed from 1 to n+2 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+2 weights, index from 1 to n+2 + END SUBROUTINE LegendreGaussLobattoQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Legendre polynomials + +INTERFACE + MODULE FUNCTION LegendreZeros(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans(n) + END FUNCTION LegendreZeros +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Legendre-Gauss, Legendre-Radau, +! Legendre-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Legendre polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of Legendre polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE LegendreQuadrature(n, pt, wt, quadType, onlyInside) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Legendre polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside + !! only inside + END SUBROUTINE LegendreQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomial of order n at single points +! +!# Introduction +! +! Evaluate Legendre polynomial of order n at single points + +INTERFACE + MODULE PURE FUNCTION LegendreEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point of evaluation, it should be between -1 and 1 + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEval1 +END INTERFACE + +INTERFACE LegendreEval + MODULE PROCEDURE LegendreEval1 +END INTERFACE LegendreEval + +!---------------------------------------------------------------------------- +! LegendreEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomials of order n at several points +! +!# Introduction +! +! Evaluate Legendre polynomials of order n at several points + +INTERFACE + MODULE PURE FUNCTION LegendreEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! several points of evaluation + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at points x + END FUNCTION LegendreEval2 +END INTERFACE + +INTERFACE LegendreEval + MODULE PROCEDURE LegendreEval2 +END INTERFACE LegendreEval + +!---------------------------------------------------------------------------- +! LegendreEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomials from order = 0 to n at single point +! +!# Introduction +! +! Evaluate Legendre polynomials from order = 0 to n at single points +! +!- x: the point at which the polynomials are to be evaluated. + +INTERFACE + MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! Highest order of polynomial. + !! Polynomials from 0 to n will be computed. + REAL(DFP), INTENT(IN) :: x + !! Point of evaluation, $x \in [-1, 1]$ + REAL(DFP) :: ans(n + 1) + !! Evaluate Legendre polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LegendreEvalAll1 +END INTERFACE + +INTERFACE LegendreEvalAll + MODULE PROCEDURE LegendreEvalAll1 +END INTERFACE LegendreEvalAll + +!---------------------------------------------------------------------------- +! LegendreEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Legendre polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point +! X. +! +!- the ith row of ans denotes the values of all polynomials at +! ith point. In this case shape of ans is (M,1:N+1), where M is number of +! points, N+1 number of polynomials. So ans(j, :) denotes value of all +! polynomials at jth point, and ans(:, n) denotes value of Pn at all nodes + +INTERFACE + MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! Highest order of polynomial. + !! Polynomials from 0 to n will be computed. + REAL(DFP), INTENT(IN) :: x(:) + !! number of points, SIZE(x)=M + REAL(DFP) :: ans(SIZE(x), n + 1) + !! shape (M,N+1) + END FUNCTION LegendreEvalAll2 +END INTERFACE + +INTERFACE LegendreEvalAll + MODULE PROCEDURE LegendreEvalAll2 +END INTERFACE LegendreEvalAll + +!---------------------------------------------------------------------------- +! LegendreMonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of all legendre polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all legendre polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|------|------|-------|-------| +! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | +! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | +! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | +! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | +! | 0 | 0 | 0 | 0 | 4.375 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 7.875 | + +INTERFACE + MODULE PURE FUNCTION LegendreMonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION LegendreMonomialExpansionAll +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreMonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a legendre polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a legendre polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION LegendreMonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LegendreMonomialExpansion +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n + +INTERFACE LegendreGradientEvalAll + MODULE PURE FUNCTION LegendreGradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LegendreGradientEvalAll1 +END INTERFACE LegendreGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n + +INTERFACE LegendreGradientEvalAll + MODULE PURE FUNCTION LegendreGradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION LegendreGradientEvalAll2 +END INTERFACE LegendreGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of legendre polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION LegendreGradientEval1 +END INTERFACE +!! + +INTERFACE LegendreGradientEval + MODULE PROCEDURE LegendreGradientEval1 +END INTERFACE LegendreGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of legendre polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION LegendreGradientEval2 +END INTERFACE +!! + +INTERFACE LegendreGradientEval + MODULE PROCEDURE LegendreGradientEval2 +END INTERFACE LegendreGradientEval + +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Legendre polynomials at point x + +INTERFACE + MODULE PURE FUNCTION LegendreEvalSum1(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEvalSum1 +END INTERFACE + +INTERFACE LegendreEvalSum + MODULE PROCEDURE LegendreEvalSum1 +END INTERFACE LegendreEvalSum + +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Legendre polynomials at several x + +INTERFACE + MODULE PURE FUNCTION LegendreEvalSum2(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEvalSum2 +END INTERFACE + +INTERFACE LegendreEvalSum + MODULE PROCEDURE LegendreEvalSum2 +END INTERFACE LegendreEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Legendre polynomials +! at point x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum1(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum1 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum1 +END INTERFACE LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Legendre polynomials +! at several x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum2 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum2 +END INTERFACE LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Legendre +! polynomials at point x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum3(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum3 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum3 +END INTERFACE LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Legendre +! polynomials at several x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum4(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum4 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum4 +END INTERFACE LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomials + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION LegendreTransform1 +END INTERFACE + +INTERFACE LegendreTransform + MODULE PROCEDURE LegendreTransform1 +END INTERFACE LegendreTransform + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION LegendreTransform2 +END INTERFACE + +INTERFACE LegendreTransform + MODULE PROCEDURE LegendreTransform2 +END INTERFACE LegendreTransform + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Legendre Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the Legendre transformation of f defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls +! `LegendreQuadrature` which is not pure due to Lapack call. +!@endnote + +INTERFACE + MODULE FUNCTION LegendreTransform3(n, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION LegendreTransform3 +END INTERFACE + +INTERFACE LegendreTransform + MODULE PROCEDURE LegendreTransform3 +END INTERFACE LegendreTransform + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION LegendreInvTransform1 +END INTERFACE + +INTERFACE LegendreInvTransform + MODULE PROCEDURE LegendreInvTransform1 +END INTERFACE LegendreInvTransform + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION LegendreInvTransform2 +END INTERFACE + +INTERFACE LegendreInvTransform + MODULE PROCEDURE LegendreInvTransform2 +END INTERFACE LegendreInvTransform + +!---------------------------------------------------------------------------- +! LegendreGradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficients for gradient of Legendre expansion +! +!# Introduction +! +!- This routine returns the coefficients of gradient of Jacobi expansion. +!- Input is coefficient of Legendre expansion (modal values) +!- Output is coefficient of derivative of legendre expansion (modal values) + +INTERFACE + MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from LegendreTransform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION LegendreGradientCoeff1 +END INTERFACE + +INTERFACE LegendreGradientCoeff + MODULE PROCEDURE LegendreGradientCoeff1 +END INTERFACE LegendreGradientCoeff + +!---------------------------------------------------------------------------- +! LegendreDMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Returns differentiation matrix for Legendre expansion + +INTERFACE + MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION LegendreDMatrix1 +END INTERFACE + +INTERFACE LegendreDMatrix + MODULE PROCEDURE LegendreDMatrix1 +END INTERFACE LegendreDMatrix + +!---------------------------------------------------------------------------- +! LegendreDMatEvenOdd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Performs even and odd decomposition of Differential matrix + +INTERFACE + MODULE PURE SUBROUTINE LegendreDMatEvenOdd1(n, D, e, o) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(IN) :: D(0:n, 0:n) + !! n+1 by n+1 + REAL(DFP), INTENT(OUT) :: e(0:, 0:) + !! even Decomposition, 0:n/2, 0:n/2 + REAL(DFP), INTENT(OUT) :: o(0:, 0:) + !! odd decomposition, 0:n/2, 0:n/2 + END SUBROUTINE LegendreDMatEvenOdd1 +END INTERFACE + +INTERFACE LegendreDMatEvenOdd + MODULE PROCEDURE LegendreDMatEvenOdd1 +END INTERFACE LegendreDMatEvenOdd + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE LegendrePolynomialUtility diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 new file mode 100644 index 000000000..dda86c81d --- /dev/null +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -0,0 +1,1179 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE LineInterpolationUtility +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE + +PUBLIC :: LagrangeDegree_Line +PUBLIC :: LagrangeDOF_Point +PUBLIC :: LagrangeDOF_Line +PUBLIC :: LagrangeInDOF_Line +PUBLIC :: GetTotalDOF_Line +PUBLIC :: GetTotalInDOF_Line +PUBLIC :: EquidistanceInPoint_Line +PUBLIC :: EquidistancePoint_Line +PUBLIC :: InterpolationPoint_Line +PUBLIC :: LagrangeCoeff_Line +PUBLIC :: LagrangeEvalAll_Line +PUBLIC :: LagrangeGradientEvalAll_Line +PUBLIC :: BasisEvalAll_Line +PUBLIC :: BasisGradientEvalAll_Line +PUBLIC :: QuadraturePoint_Line +PUBLIC :: ToVEFC_Line +PUBLIC :: QuadratureNumber_Line +PUBLIC :: RefElemDomain_Line +PUBLIC :: HeirarchicalBasis_Line +PUBLIC :: HeirarchicalGradientBasis_Line +PUBLIC :: OrthogonalBasis_Line +PUBLIC :: OrthogonalBasisGradient_Line + +!---------------------------------------------------------------------------- +! RefElemDomain_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain_Line(baseContinuity, baseInterpol) & + & RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseContinuity + !! Cointinuity (conformity) of basis functions + !! "H1", "HDiv", "HCurl", "DG" + CHARACTER(*), INTENT(IN) :: baseInterpol + !! Basis function family for Interpolation + !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal + TYPE(String) :: ans + END FUNCTION RefElemDomain_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! QuadratureNumber_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: REturns the number of quadrature points necessary for given order + +INTERFACE + MODULE PURE FUNCTION QuadratureNumber_Line(order, quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: quadType + INTEGER(I4B) :: ans + END FUNCTION QuadratureNumber_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! ToVEFC_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Change layour of points on line + +INTERFACE + MODULE PURE SUBROUTINE ToVEFC_Line(pt) + REAL(DFP), INTENT(INOUT) :: pt(:) + END SUBROUTINE ToVEFC_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE + MODULE PURE FUNCTION LagrangeDegree_Line(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDOF_Point +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on a point of Line + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF_Point(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Point +END INTERFACE + +!---------------------------------------------------------------------------- +! GetDOF_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Line + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF_Line(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Line +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Line +!- These dof are strictly inside the line + +INTERFACE + MODULE PURE FUNCTION LagrangeInDOF_Line(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! GetTotalDOF_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Line + +INTERFACE + MODULE PURE FUNCTION GetTotalDOF_Line(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalDOF_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Line +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Line +!- These dof are strictly inside the line + +INTERFACE + MODULE PURE FUNCTION GetTotalInDOF_Line(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance internal points on edge +! +!# Introduction +! +!- This function returns the equidistance points on edge in 1D +!- All points are inside the interval +!- Points are in increasing order + +INTERFACE EquidistanceInPoint_Line + MODULE PURE FUNCTION EquidistanceInPoint_Line1(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(IN) :: xij(2) + !! coordinates of point 1 and point 2 + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION EquidistanceInPoint_Line1 +END INTERFACE EquidistanceInPoint_Line + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points on edge +! +!# Introduction +! +!- This function returns the equidistance points on edge in 1D, 2D, 3D +!- The end points are specified by `xij(1:nsd, 1)` and `xij(1:nsd, 2)` +! +!- All points are inside the interval +!- The number of space components in `ans` is nsd if xij present +!- Otherwise, the number of space components in `ans` is 1. + +INTERFACE EquidistanceInPoint_Line + MODULE PURE FUNCTION EquidistanceInPoint_Line2(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 2 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Equidistnace points in $x_{iJ}$ format + !! The number of rows is equal to the number of rows in xij + !! (if xij present), otherwise, it is 1. + END FUNCTION EquidistanceInPoint_Line2 +END INTERFACE EquidistanceInPoint_Line + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points on edge +! +!# Introduction +! +!- This function returns the equidistance points on edge +!- Points are in "VEFC" format, which means `xij(1,1:2)` are end points + +INTERFACE EquidistancePoint_Line + MODULE PURE FUNCTION EquidistancePoint_Line1(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(IN) :: xij(2) + !! coorindates of point 1 and point 2 + REAL(DFP), ALLOCATABLE :: ans(:) + !! equidistance points + END FUNCTION EquidistancePoint_Line1 +END INTERFACE EquidistancePoint_Line + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points on line +! +!# Introduction +! +!- This function returns the equidistance points on line +!- All points are inside the interval + +INTERFACE EquidistancePoint_Line + MODULE PURE FUNCTION EquidistancePoint_Line2(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 2 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! equidistance points in $x_{iJ}$ format + !! If xij is not present, then number of rows in ans + !! is 1. If `xij` is present then the number of rows in + !! ans is same as xij. + END FUNCTION EquidistancePoint_Line2 +END INTERFACE EquidistancePoint_Line + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Aug 2022 +! summary: Returns the interpolation point +! +!# Introduction +! +!- This routine returns the interplation points on line +!- `xij` contains nodal coordinates of line in xij format. +!- SIZE(xij,1) = nsd, and SIZE(xij,2)=2 +!- If xij is absent then [-1,1] is used +!- `ipType` is interpolation point type, it can take following values +!- `Equidistance`, uniformly/evenly distributed points +!- `GaussLegendre`, Zeros of Legendre polynomials, all nodes are strictly +! inside the domain. +!- `GaussLegendreLobatto` or `GaussLobatto` are zeros of Lobatto polynomials +! they always contains boundary points +!- `GaussChebyshev` Zeros of Chebyshev polynomials of first kind, all +! nodes are internal +!- `GaussChebyshevLobatto` they contains boundary points +!- `GaussJacobi` and `GaussJacobiLobatto` +! +!- `layout` specifies the arrangement of points. Following options are +! possible: +! +!- `layout=VEFC` vertex, edge, face, cell, in this case first two points are +! boundary points, remaining (from 3 to n) are internal points in +! increasing order. +! +!- `layout=INCREASING` points are arranged in increasing order + +INTERFACE InterpolationPoint_Line + MODULE FUNCTION InterpolationPoint_Line1(order, ipType, & + & layout, xij, alpha, beta, lambda) RESULT(ans) + !! + INTEGER(I4B), INTENT(IN) :: order + !! Order of interpolation + INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation point type + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! domain of interpolation + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + !! size(ans,1) = 1 + !! size(ans,2) = order+1 + END FUNCTION InterpolationPoint_Line1 +END INTERFACE InterpolationPoint_Line + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Aug 2022 +! summary: Returns the interpolation point + +INTERFACE InterpolationPoint_Line + MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, & + & layout, alpha, beta, lambda) RESULT(ans) + !! + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation point type + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussChebyshev, + !! GaussChebyshevLobatto + !! GaussJacobi + !! GaussJacobiLobatto + REAL(DFP), INTENT(IN) :: xij(2) + !! end points + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + !! "DECREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:) + !! one dimensional interpolation point + END FUNCTION InterpolationPoint_Line2 +END INTERFACE InterpolationPoint_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Line + MODULE FUNCTION LagrangeCoeff_Line1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + REAL(DFP) :: ans(order + 1) + !! coefficients + END FUNCTION LagrangeCoeff_Line1 +END INTERFACE LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Line + MODULE FUNCTION LagrangeCoeff_Line2(order, i, v, isVandermonde) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(order + 1) + !! coefficients + END FUNCTION LagrangeCoeff_Line2 +END INTERFACE LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Line + MODULE FUNCTION LagrangeCoeff_Line3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(order + 1) + !! coefficients + END FUNCTION LagrangeCoeff_Line3 +END INTERFACE LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Line + MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + REAL(DFP) :: ans(order + 1, order + 1) + !! coefficients + !! jth column of ans corresponds to the coeff of lagrange polynomial + !! at the jth point + END FUNCTION LagrangeCoeff_Line4 +END INTERFACE LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Line + MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, & + & beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + INTEGER(I4B), INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + !! jth column of ans corresponds to the coeff of lagrange polynomial + !! at the jth point + END FUNCTION LagrangeCoeff_Line5 +END INTERFACE LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Lagrange polynomials of order n at single points + +INTERFACE LagrangeEvalAll_Line + MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, & + & basisType, alpha, beta, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Line1 +END INTERFACE LagrangeEvalAll_Line + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Lagrange polynomials of n at several points + +INTERFACE LagrangeEvalAll_Line + MODULE FUNCTION LagrangeEvalAll_Line2( & + & order, x, xij, coeff, firstCall, & + & basisType, alpha, beta, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + !! size(xij, 1) = nsd + !! size(xij, 2) = number of points + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + END FUNCTION LagrangeEvalAll_Line2 +END INTERFACE LagrangeEvalAll_Line + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Lagrange polynomials of n at several points + +INTERFACE LagrangeGradientEvalAll_Line + MODULE FUNCTION LagrangeGradientEvalAll_Line1( & + & order, & + & x, & + & xij, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 1) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + END FUNCTION LagrangeGradientEvalAll_Line1 +END INTERFACE LagrangeGradientEvalAll_Line + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate basis functions of order upto n + +INTERFACE BasisEvalAll_Line + MODULE FUNCTION BasisEvalAll_Line1( & + & order, & + & x, & + & refLine, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refLine + !! Refline should be BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(order + 1) + !! Value of n+1 polynomials at point x + END FUNCTION BasisEvalAll_Line1 +END INTERFACE BasisEvalAll_Line + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate basis functions of order upto n + +INTERFACE BasisEvalAll_Line + MODULE FUNCTION BasisEvalAll_Line2( & + & order, & + & x, & + & refLine, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x(:) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT + !! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x), order + 1) + !! Value of n+1 polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + END FUNCTION BasisEvalAll_Line2 +END INTERFACE BasisEvalAll_Line + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate basis functions of order upto n + +INTERFACE OrthogonalBasis_Line + MODULE FUNCTION OrthogonalBasis_Line1( & + & order, & + & xij, & + & refLine, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + !! Number of rows in xij is 1 + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT + !! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(xij, 2), order + 1) + !! Value of n+1 polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + END FUNCTION OrthogonalBasis_Line1 +END INTERFACE OrthogonalBasis_Line + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate basis functions of order upto n + +INTERFACE OrthogonalBasisGradient_Line + MODULE FUNCTION OrthogonalBasisGradient_Line1( & + & order, & + & xij, & + & refLine, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + !! Number of rows in xij is 1 + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT + !! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(xij, 2), order + 1, 1) + !! Value of n+1 polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + END FUNCTION OrthogonalBasisGradient_Line1 +END INTERFACE OrthogonalBasisGradient_Line + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Line + +INTERFACE HeirarchicalBasis_Line + MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Polynomial order of interpolation + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + CHARACTER(*), INTENT(IN) :: refLine + !! This parameter denotes the type of reference line. + !! It can take following values: + !! UNIT: in this case xij is in unit Line. + !! BIUNIT: in this case xij is in biunit Line. + REAL(DFP) :: ans(SIZE(xij, 2), order + 1) + !! Hierarchical basis + END FUNCTION HeirarchicalBasis_Line1 +END INTERFACE HeirarchicalBasis_Line + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line + +INTERFACE HeirarchicalGradientBasis_Line + MODULE FUNCTION HeirarchicalGradientBasis_Line1( & + & order, & + & xij, & + & refLine) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Polynomial order of interpolation + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + !! size(xij, 1) should be 1 + CHARACTER(*), INTENT(IN) :: refLine + !! This parameter denotes the type of reference line. + !! It can take following values: + !! UNIT: in this case xij is in unit Line. + !! BIUNIT: in this case xij is in biunit Line. + REAL(DFP) :: ans(SIZE(xij, 2), order + 1, 1) + !! Gradient of Hierarchical basis + END FUNCTION HeirarchicalGradientBasis_Line1 +END INTERFACE HeirarchicalGradientBasis_Line + +!---------------------------------------------------------------------------- +! BasisGradientEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate the gradient of basis functions of order upto n + +INTERFACE BasisGradientEvalAll_Line + MODULE FUNCTION BasisGradientEvalAll_Line1( & + & order, & + & x, & + & refLine, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refLine + !! Refline should be BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(order + 1) + !! Value of n+1 polynomials at point x + END FUNCTION BasisGradientEvalAll_Line1 +END INTERFACE BasisGradientEvalAll_Line + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate gradient of basis functions of order upto n + +INTERFACE BasisGradientEvalAll_Line + MODULE FUNCTION BasisGradientEvalAll_Line2( & + & order, & + & x, & + & refLine, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x(:) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT + !! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x), order + 1) + !! Value of n+1 polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + END FUNCTION BasisGradientEvalAll_Line2 +END INTERFACE BasisGradientEvalAll_Line + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-19 +! summary: Returns quadrature points + +INTERFACE QuadraturePoint_Line + MODULE FUNCTION QuadraturePoint_Line1( & + & order, & + & quadType, & + & layout, & + & xij, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + !! + INTEGER(I4B), INTENT(IN) :: order + !! Order of interpolation + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature point type + !! Equidistance, + !! GaussLegendre, + !! GaussLegendreLobatto, + !! GaussChebyshev, + !! GaussChebyshevLobatto, + !! GaussJacobi, + !! GaussJacobiLobatto + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! domain of interpolation + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! quadrature points + !! If xij is present then the number of rows in ans + !! is same as size(xij,1) + 1. + !! If xij is not present then the number of rows in + !! ans is 2 + !! The last row of ans contains the weights + !! The first few rows contains the quadrature points + END FUNCTION QuadraturePoint_Line1 +END INTERFACE QuadraturePoint_Line + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Aug 2022 +! summary: Returns the interpolation point + +INTERFACE QuadraturePoint_Line + MODULE FUNCTION QuadraturePoint_Line2( & + & order, & + & quadType, & + & xij, & + & layout, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature point type + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussChebyshev, + !! GaussChebyshevLobatto + !! GaussJacobi + !! GaussJacobiLobatto + REAL(DFP), INTENT(IN) :: xij(2) + !! end points + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! one dimensional interpolation point + END FUNCTION QuadraturePoint_Line2 +END INTERFACE QuadraturePoint_Line + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-19 +! summary: Returns quadrature points + +INTERFACE QuadraturePoint_Line + MODULE FUNCTION QuadraturePoint_Line3( & + & nips, & + & quadType, & + & layout, & + & xij, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + !! + INTEGER(I4B), INTENT(IN) :: nips(1) + !! Order of interpolation + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature point type + !! Equidistance, + !! GaussLegendre, + !! GaussLegendreLobatto, + !! GaussChebyshev, + !! GaussChebyshevLobatto, + !! GaussJacobi, + !! GaussJacobiLobatto + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! domain of interpolation + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! quadrature points + !! If xij is present then the number of rows in ans + !! is same as size(xij,1) + 1. + !! If xij is not present then the number of rows in + !! ans is 2 + !! The last row of ans contains the weights + !! The first few rows contains the quadrature points + END FUNCTION QuadraturePoint_Line3 +END INTERFACE QuadraturePoint_Line + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Aug 2022 +! summary: Returns the interpolation point + +INTERFACE QuadraturePoint_Line + MODULE FUNCTION QuadraturePoint_Line4( & + & nips, & + & quadType, & + & xij, & + & layout, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature point type + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussChebyshev, + !! GaussChebyshevLobatto + !! GaussJacobi + !! GaussJacobiLobatto + REAL(DFP), INTENT(IN) :: xij(2) + !! end points + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! one dimensional interpolation point + END FUNCTION QuadraturePoint_Line4 +END INTERFACE QuadraturePoint_Line + +END MODULE LineInterpolationUtility diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 new file mode 100644 index 000000000..9d7e15c4e --- /dev/null +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -0,0 +1,495 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to Lobatto Polynomials is defined. +! +!{!pages/LobattoPolynomialUtility.md!} + +MODULE LobattoPolynomialUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: LobattoLeadingCoeff +PUBLIC :: LobattoZeros +PUBLIC :: LobattoEval +PUBLIC :: LobattoEvalAll +PUBLIC :: LobattoKernelEvalAll +PUBLIC :: LobattoKernelEvalAll_ +PUBLIC :: LobattoKernelGradientEvalAll +PUBLIC :: LobattoKernelGradientEvalAll_ +PUBLIC :: LobattoMonomialExpansionAll +PUBLIC :: LobattoMonomialExpansion +PUBLIC :: LobattoGradientEvalAll +PUBLIC :: LobattoGradientEval +PUBLIC :: LobattoMassMatrix +PUBLIC :: LobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! LobattoLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Leading coefficient of Lobatto polynomial + +INTERFACE + MODULE PURE FUNCTION LobattoLeadingCoeff(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Lobatto polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LobattoLeadingCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Lobatto polynomial +! + +INTERFACE + MODULE PURE FUNCTION LobattoNormSQR(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION LobattoNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! LobattoZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Lobatto polynomials + +INTERFACE + MODULE FUNCTION LobattoZeros(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Lobatto polynomial, should be greater than equal to 2 + REAL(DFP) :: ans(n) + !! + END FUNCTION LobattoZeros +END INTERFACE + +!---------------------------------------------------------------------------- +! LobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate Lobatto polynomial of order n at point x + END FUNCTION LobattoEval1 +END INTERFACE + +INTERFACE LobattoEval + MODULE PROCEDURE LobattoEval1 +END INTERFACE LobattoEval + +!---------------------------------------------------------------------------- +! LobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Lobatto polynomial of order n at point x + END FUNCTION LobattoEval2 +END INTERFACE + +INTERFACE LobattoEval + MODULE PROCEDURE LobattoEval2 +END INTERFACE LobattoEval + +!---------------------------------------------------------------------------- +! LobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LobattoEvalAll1 +END INTERFACE + +INTERFACE LobattoEvalAll + MODULE PROCEDURE LobattoEvalAll1 +END INTERFACE LobattoEvalAll + +!---------------------------------------------------------------------------- +! LobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LobattoEvalAll2 +END INTERFACE + +INTERFACE LobattoEvalAll + MODULE PROCEDURE LobattoEvalAll2 +END INTERFACE LobattoEvalAll + +!---------------------------------------------------------------------------- +! LobattoKernelEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto bubble functions order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto bubble polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. +!- x: the point at which the polynomials are to be evaluated. + +INTERFACE LobattoKernelEvalAll + MODULE PURE FUNCTION LobattoKernelEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 0:n) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LobattoKernelEvalAll1 +END INTERFACE LobattoKernelEvalAll + +!---------------------------------------------------------------------------- +! LobattoKernelEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto bubble functions order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto bubble polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. +!- x: the point at which the polynomials are to be evaluated. + +INTERFACE LobattoKernelEvalAll_ + MODULE PURE SUBROUTINE LobattoKernelEvalAll1_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(1:, 0:) + !! ans(1:SIZE(x), 0:n) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LobattoKernelEvalAll1_ +END INTERFACE LobattoKernelEvalAll_ + +!---------------------------------------------------------------------------- +! LobattoKernelGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Gradient of Lobatto bubbles of order = 0 to n + +INTERFACE LobattoKernelGradientEvalAll + MODULE PURE FUNCTION LobattoKernelGradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 0:n) + !! Gradient of Lobatto bubbles of order 0 to n + END FUNCTION LobattoKernelGradientEvalAll1 +END INTERFACE LobattoKernelGradientEvalAll + +!---------------------------------------------------------------------------- +! LobattoKernelGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Gradient of Lobatto bubbles of order = 0 to n + +INTERFACE LobattoKernelGradientEvalAll_ + MODULE PURE SUBROUTINE LobattoKernelGradientEvalAll1_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(1:, 0:) + ! ans(1:SIZE(x), 0:n) + !! Gradient of Lobatto bubbles of order 0 to n + INTEGER(I4B), INTENT(OUT) :: nrow + INTEGER(I4B), INTENT(OUT) :: ncol + END SUBROUTINE LobattoKernelGradientEvalAll1_ +END INTERFACE LobattoKernelGradientEvalAll_ + +!---------------------------------------------------------------------------- +! LobattoMonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of all Lobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all Lobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|------|------|-------|-------| +! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | +! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | +! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | +! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | +! | 0 | 0 | 0 | 0 | 4.375 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 7.875 | + +INTERFACE + MODULE PURE FUNCTION LobattoMonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION LobattoMonomialExpansionAll +END INTERFACE + +!---------------------------------------------------------------------------- +! LobattoMonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a Lobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a Lobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION LobattoMonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LobattoMonomialExpansion +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE LobattoGradientEvalAll + MODULE PURE FUNCTION LobattoGradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LobattoGradientEvalAll1 +END INTERFACE LobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE LobattoGradientEvalAll + MODULE PURE FUNCTION LobattoGradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION LobattoGradientEvalAll2 +END INTERFACE LobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LobattoGradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION LobattoGradientEval1 +END INTERFACE +!! + +INTERFACE LobattoGradientEval + MODULE PROCEDURE LobattoGradientEval1 +END INTERFACE LobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LobattoGradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION LobattoGradientEval2 +END INTERFACE + +INTERFACE LobattoGradientEval + MODULE PROCEDURE LobattoGradientEval2 +END INTERFACE LobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Lobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION LobattoMassMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION LobattoMassMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Lobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION LobattoStiffnessMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION LobattoStiffnessMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE LobattoPolynomialUtility diff --git a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 new file mode 100644 index 000000000..5e4783126 --- /dev/null +++ b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 @@ -0,0 +1,226 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 OrthogonalPolynomialUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Clenshaw +PUBLIC :: ChebClenshaw +PUBLIC :: JacobiMatrix +PUBLIC :: EvalAllOrthopol +PUBLIC :: GradientEvalAllOrthopol + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Clenshaw_1(x, alpha, beta, y0, ym1, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(IN) :: alpha(0:) + REAL(DFP), INTENT(IN) :: beta(0:) + REAL(DFP), OPTIONAL, INTENT(IN) :: y0 + !! if y0 is absent then y0 = 1.0 + REAL(DFP), OPTIONAL, INTENT(IN) :: ym1 + !! if ym1 is absent then ym1 = 0.0 + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans + END FUNCTION Clenshaw_1 +END INTERFACE + +INTERFACE Clenshaw + MODULE PROCEDURE Clenshaw_1 +END INTERFACE Clenshaw + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Clenshaw_2(x, alpha, beta, y0, ym1, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(IN) :: alpha(0:) + REAL(DFP), INTENT(IN) :: beta(0:) + REAL(DFP), OPTIONAL, INTENT(IN) :: y0 + !! if y0 is absent then y0 = 1.0 + REAL(DFP), OPTIONAL, INTENT(IN) :: ym1 + !! if ym1 is absent then ym1 = 0.0 + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans(SIZE(x)) + END FUNCTION Clenshaw_2 +END INTERFACE + +INTERFACE Clenshaw + MODULE PROCEDURE Clenshaw_2 +END INTERFACE Clenshaw + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2021 +! summary: CleanShaw for Chebyshev +! +!# Introduction +! +! ClenShaw for Chebyshev polynomial expansion. It returns : +! +!$$ +! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x) +!$$ + +INTERFACE + MODULE PURE FUNCTION ChebClenshaw_1(x, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans + END FUNCTION ChebClenshaw_1 +END INTERFACE + +INTERFACE Clenshaw + MODULE PROCEDURE ChebClenshaw_1 +END INTERFACE Clenshaw + +INTERFACE ChebClenshaw + MODULE PROCEDURE ChebClenshaw_1 +END INTERFACE ChebClenshaw + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2021 +! summary: CleanShaw for Chebyshev +! +!# Introduction +! +! ClenShaw for Chebyshev polynomial expansion. It returns : +! +!$$ +! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x) +!$$ + +INTERFACE + MODULE PURE FUNCTION ChebClenshaw_2(x, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans(SIZE(x)) + END FUNCTION ChebClenshaw_2 +END INTERFACE + +INTERFACE Clenshaw + MODULE PROCEDURE ChebClenshaw_2 +END INTERFACE Clenshaw + +INTERFACE ChebClenshaw + MODULE PROCEDURE ChebClenshaw_2 +END INTERFACE ChebClenshaw + +!---------------------------------------------------------------------------- +! JacobiMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE JacobiMatrix_1(alphaCoeff, betaCoeff, D, E) + REAL(DFP), INTENT(IN) :: alphaCoeff(0:) + !! size n, from 0 to n-1 + REAL(DFP), INTENT(IN) :: betaCoeff(0:) + !! size n, from 0 to n-1 + REAL(DFP), INTENT(OUT) :: D(:) + !! entry from 1 to n are filled + REAL(DFP), INTENT(OUT) :: E(:) + !! entry from 1 to n-1 are filled + END SUBROUTINE JacobiMatrix_1 +END INTERFACE + +INTERFACE JacobiMatrix + MODULE PROCEDURE JacobiMatrix_1 +END INTERFACE JacobiMatrix + +!---------------------------------------------------------------------------- +! EvalAllOrthopol +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION EvalAllOrthopol(n, x, orthopol, alpha, beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! points of evaluation + INTEGER(I4B), INTENT(IN) :: orthopol + !! orthogonal polynomial family + !! Legendre + !! Jacobi + !! Lobatto + !! Chebyshev + !! Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha1 needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta1 is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda1 is needed when orthopol1 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(x), n + 1) + !! The number of rows in ans is equal to the number of points. + !! The number of columns are equal to the orthogonal + !! polynomials from order = 0 to n + !! Therefore, jth column is denotes the value of jth polynomial + !! at all the points. + END FUNCTION EvalAllOrthopol +END INTERFACE + +!---------------------------------------------------------------------------- +! EvalAllOrthopol +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION GradientEvalAllOrthopol( & + & n, & + & x, & + & orthopol, & + & alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! points of evaluation + INTEGER(I4B), INTENT(IN) :: orthopol + !! orthogonal polynomial family + !! Legendre + !! Jacobi + !! Lobatto + !! Chebyshev + !! Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha1 needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta1 is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda1 is needed when orthopol1 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(x), n + 1) + !! The number of rows in ans is equal to the number of points. + !! The number of columns are equal to the orthogonal + !! polynomials from order = 0 to n + !! Therefore, jth column is denotes the value of jth polynomial + !! at all the points. + END FUNCTION GradientEvalAllOrthopol +END INTERFACE + +END MODULE OrthogonalPolynomialUtility diff --git a/src/modules/Polynomial/src/PolynomialUtility.F90 b/src/modules/Polynomial/src/PolynomialUtility.F90 new file mode 100644 index 000000000..362d8fcc0 --- /dev/null +++ b/src/modules/Polynomial/src/PolynomialUtility.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 PolynomialUtility +USE InterpolationUtility +USE LagrangePolynomialUtility +USE OrthogonalPolynomialUtility +USE JacobiPolynomialUtility +USE UltrasphericalPolynomialUtility +USE LegendrePolynomialUtility +USE LobattoPolynomialUtility +USE UnscaledLobattoPolynomialUtility +USE Chebyshev1PolynomialUtility +USE LineInterpolationUtility +USE TriangleInterpolationUtility +USE QuadrangleInterpolationUtility +USE TetrahedronInterpolationUtility +USE HexahedronInterpolationUtility +USE PrismInterpolationUtility +USE PyramidInterpolationUtility +USE RecursiveNodesUtility +END MODULE PolynomialUtility diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 new file mode 100644 index 000000000..40ced9a38 --- /dev/null +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -0,0 +1,690 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 PrismInterpolationUtility +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE +PUBLIC :: LagrangeDegree_Prism +PUBLIC :: LagrangeDOF_Prism +PUBLIC :: LagrangeInDOF_Prism +PUBLIC :: EquidistanceInPoint_Prism +PUBLIC :: EquidistancePoint_Prism +PUBLIC :: InterpolationPoint_Prism +PUBLIC :: LagrangeCoeff_Prism +PUBLIC :: QuadraturePoint_Prism +PUBLIC :: TensorQuadraturePoint_Prism +PUBLIC :: RefElemDomain_Prism +PUBLIC :: LagrangeEvalAll_Prism +PUBLIC :: LagrangeGradientEvalAll_Prism +PUBLIC :: EdgeConnectivity_Prism +PUBLIC :: FacetConnectivity_Prism +PUBLIC :: GetTotalDOF_Prism +PUBLIC :: GetTotalInDOF_Prism + +INTEGER(I4B), PARAMETER :: CONST_tNODES = 6 +INTEGER(I4B), PARAMETER :: CONST_tFACES = 5 +INTEGER(I4B), PARAMETER :: CONST_tEDGES = 9 +INTEGER(I4B), PARAMETER :: CONST_XIDIM = 3 +INTEGER(I4B), PARAMETER :: CONST_MAX_NODES_FACE = 4 +INTEGER(I4B), PARAMETER :: CONST_MIN_NODES_FACE = 3 + +!---------------------------------------------------------------------------- +! GetTotalDOF_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Prism + +INTERFACE + MODULE PURE FUNCTION GetTotalDOF_Prism(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalDOF_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Prism +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Prism +!- These dof are strictly inside the Prism + +INTERFACE + MODULE PURE FUNCTION GetTotalInDOF_Prism(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-07 +! summary: This function returns the edge connectivity of Prism + +INTERFACE + MODULE PURE FUNCTION EdgeConnectivity_Prism( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2, CONST_tEDGES) + END FUNCTION EdgeConnectivity_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetConnectivity_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-10 +! summary: This function returns the facet-connectivity of Prism + +INTERFACE + MODULE PURE FUNCTION FacetConnectivity_Prism( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2 + CONST_MAX_NODES_FACE, CONST_tFACES) + !! ans(1, iface) contains the total nodes in facet (iface) + !! ans(2, iface) contains the integer name of facet element + !! ans(3:2+ans(1,iface), iface ) contains the node numbers + END FUNCTION FacetConnectivity_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! RefElemDomain_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain_Prism(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_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE + MODULE PURE FUNCTION LagrangeDegree_Prism(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDOF_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Prism + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF_Prism(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Prism +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Prism +!- These dof are strictly inside the Prism + +INTERFACE + MODULE PURE FUNCTION LagrangeInDOF_Prism(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points in Prism +! +!# Introduction +! +!- This function returns the equidistance points in Prism +!- All points are inside the Prism + +INTERFACE + MODULE PURE FUNCTION EquidistanceInPoint_Prism(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistanceInPoint_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistancePoint_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Prism element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! Prism 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 + MODULE PURE FUNCTION EquidistancePoint_Prism(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistancePoint_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! InterpolationPoint_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point on Prism + +INTERFACE + MODULE PURE FUNCTION InterpolationPoint_Prism( & + & order, & + & ipType, & + & layout, & + & xij, & + & alpha, beta, lambda) & + & RESULT(nodecoord) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + CHARACTER(*), INTENT(IN) :: layout + !! + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coords of vertices in $x_{iJ}$ format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Jacobi and Ultraspherical parameters + REAL(DFP), ALLOCATABLE :: nodecoord(:, :) + !! interpolation points in $x_{iJ}$ format + END FUNCTION InterpolationPoint_Prism +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism + MODULE FUNCTION LagrangeCoeff_Prism1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism1 +END INTERFACE LagrangeCoeff_Prism + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism + MODULE FUNCTION LagrangeCoeff_Prism2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism2 +END INTERFACE LagrangeCoeff_Prism + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism + MODULE FUNCTION LagrangeCoeff_Prism3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism3 +END INTERFACE LagrangeCoeff_Prism + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism + MODULE FUNCTION LagrangeCoeff_Prism4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism4 +END INTERFACE LagrangeCoeff_Prism + +!---------------------------------------------------------------------------- +! QuadraturePoints_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: quadrature points on Prism + +INTERFACE QuadraturePoint_Prism + MODULE FUNCTION QuadraturePoint_Prism1(& + & order, & + & quadType, & + & refPrism, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPrism + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3. + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Prism1 +END INTERFACE QuadraturePoint_Prism + +!---------------------------------------------------------------------------- +! QuadraturePoints_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: quadrature points on Prism + +INTERFACE QuadraturePoint_Prism + MODULE FUNCTION QuadraturePoint_Prism2(& + & nips, & + & quadType, & + & refPrism, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! nips(1) .LE. 79, then we call + !! economical quadrature rules. + !! Otherwise, this routine will retport + !! error + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type, + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPrism + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Prism2 +END INTERFACE QuadraturePoint_Prism + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points on Prism + +INTERFACE TensorQuadraturePoint_Prism + MODULE FUNCTION TensorQuadraturePoint_Prism1(order, quadType, & + & refPrism, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPrism + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 4. + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Prism1 +END INTERFACE TensorQuadraturePoint_Prism + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points + +INTERFACE TensorQuadraturePoint_Prism + MODULE FUNCTION TensorQuadraturePoint_Prism2( & + & nipsx, & + & nipsy, & + & nipsz, & + & quadType, & + & refPrism, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! number of integration points in z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPrism + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Prism2 +END INTERFACE TensorQuadraturePoint_Prism + +INTERFACE OrthogonalBasisGradient_Prism + MODULE PROCEDURE TensorQuadraturePoint_Prism2 +END INTERFACE OrthogonalBasisGradient_Prism + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Prism + MODULE FUNCTION LagrangeEvalAll_Prism1( & + & order, & + & x, & + & xij, & + & refPrism, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be computed and returned + !! by this routine. + !! If firstCall is False, then coeff should be given, which will be + !! used. + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Prism1 +END INTERFACE LagrangeEvalAll_Prism + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Prism + MODULE FUNCTION LagrangeEvalAll_Prism2( & + & order, & + & x, & + & xij, & + & refPrism, & + & 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 + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Prism2 +END INTERFACE LagrangeEvalAll_Prism + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: GradientEvaluate all Lagrange polynomials at several points + +INTERFACE LagrangeGradientEvalAll_Prism + MODULE FUNCTION LagrangeGradientEvalAll_Prism1( & + & order, & + & x, & + & xij, & + & refPrism, & + & 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 + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 3) + !! 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_Prism1 +END INTERFACE LagrangeGradientEvalAll_Prism + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE PrismInterpolationUtility diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 new file mode 100644 index 000000000..12147960d --- /dev/null +++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 @@ -0,0 +1,701 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 PyramidInterpolationUtility +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE +PUBLIC :: LagrangeDegree_Pyramid +PUBLIC :: LagrangeDOF_Pyramid +PUBLIC :: LagrangeInDOF_Pyramid +PUBLIC :: EquidistanceInPoint_Pyramid +PUBLIC :: EquidistancePoint_Pyramid +PUBLIC :: InterpolationPoint_Pyramid +PUBLIC :: LagrangeCoeff_Pyramid +PUBLIC :: QuadraturePoint_Pyramid +PUBLIC :: TensorQuadraturePoint_Pyramid +PUBLIC :: RefElemDomain_Pyramid +PUBLIC :: LagrangeEvalAll_Pyramid +PUBLIC :: LagrangeGradientEvalAll_Pyramid +PUBLIC :: EdgeConnectivity_Pyramid +PUBLIC :: FacetConnectivity_Pyramid +PUBLIC :: GetTotalDOF_Pyramid +PUBLIC :: GetTotalInDOF_Pyramid + +INTEGER(I4B), PARAMETER :: CONST_tNODES = 5 +INTEGER(I4B), PARAMETER :: CONST_tFACES = 5 +INTEGER(I4B), PARAMETER :: CONST_tEDGES = 8 +INTEGER(I4B), PARAMETER :: CONST_XIDIM = 3 +INTEGER(I4B), PARAMETER :: CONST_MAX_NODES_FACE = 4 +INTEGER(I4B), PARAMETER :: CONST_MIN_NODES_FACE = 3 + +!---------------------------------------------------------------------------- +! GetTotalDOF_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Pyramid + +INTERFACE + MODULE PURE FUNCTION GetTotalDOF_Pyramid(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalDOF_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Pyramid +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Pyramid +!- These dof are strictly inside the Pyramid + +INTERFACE + MODULE PURE FUNCTION GetTotalInDOF_Pyramid(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-07 +! summary: This function returns the edge connectivity of Pyramid + +INTERFACE + MODULE PURE FUNCTION EdgeConnectivity_Pyramid( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2, CONST_tEDGES) + END FUNCTION EdgeConnectivity_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetConnectivity_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-10 +! summary: This function returns the facet-connectivity of Pyramid + +INTERFACE + MODULE PURE FUNCTION FacetConnectivity_Pyramid( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2 + CONST_MAX_NODES_FACE, CONST_tFACES) + !! ans(1, iface) contains the total nodes in facet (iface) + !! ans(2, iface) contains the integer name of facet element + !! ans(3:2+ans(1,iface), iface ) contains the node numbers + END FUNCTION FacetConnectivity_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! RefElemDomain_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain_Pyramid(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_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE + MODULE PURE FUNCTION LagrangeDegree_Pyramid(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDOF_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Pyramid + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF_Pyramid(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Pyramid +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Pyramid +!- These dof are strictly inside the Pyramid + +INTERFACE + MODULE PURE FUNCTION LagrangeInDOF_Pyramid(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points in Pyramid +! +!# Introduction +! +!- This function returns the equidistance points in Pyramid +!- All points are inside the Pyramid + +INTERFACE + MODULE PURE FUNCTION EquidistanceInPoint_Pyramid(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistanceInPoint_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistancePoint_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Pyramid element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! Pyramid 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 + MODULE PURE FUNCTION EquidistancePoint_Pyramid(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistancePoint_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! InterpolationPoint_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point on Pyramid + +INTERFACE + MODULE PURE FUNCTION InterpolationPoint_Pyramid( & + & order, & + & ipType, & + & layout, & + & xij, & + & alpha, beta, lambda) RESULT(nodecoord) + INTEGER(I4B), INTENT(IN) :: order + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation points + CHARACTER(*), INTENT(IN) :: layout + !! layout + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coords of vertices in $x_{iJ}$ format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Alpha, beta, and lambda + REAL(DFP), ALLOCATABLE :: nodecoord(:, :) + !! interpolation points in $x_{iJ}$ format + END FUNCTION InterpolationPoint_Pyramid +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid1 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid1 +END INTERFACE LagrangeCoeff_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid2 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid2 +END INTERFACE LagrangeCoeff_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid3 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid3 +END INTERFACE LagrangeCoeff_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid4 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid4 +END INTERFACE LagrangeCoeff_Pyramid + +!---------------------------------------------------------------------------- +! QuadraturePoints_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: quadrature points on Pyramid + +INTERFACE QuadraturePoint_Pyramid + MODULE FUNCTION QuadraturePoint_Pyramid1(& + & order, & + & quadType, & + & refPyramid, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPyramid + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3. + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Pyramid1 +END INTERFACE QuadraturePoint_Pyramid + +!---------------------------------------------------------------------------- +! QuadraturePoints_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: quadrature points on Pyramid + +INTERFACE QuadraturePoint_Pyramid + MODULE FUNCTION QuadraturePoint_Pyramid2(& + & nips, & + & quadType, & + & refPyramid, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! nips(1) .LE. 79, then we call + !! economical quadrature rules. + !! Otherwise, this routine will retport + !! error + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type, + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPyramid + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Pyramid2 +END INTERFACE QuadraturePoint_Pyramid + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points on Pyramid + +INTERFACE TensorQuadraturePoint_Pyramid + MODULE FUNCTION TensorQuadraturePoint_Pyramid1(order, quadType, & + & refPyramid, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPyramid + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 4. + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Pyramid1 +END INTERFACE TensorQuadraturePoint_Pyramid + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points + +INTERFACE TensorQuadraturePoint_Pyramid + MODULE FUNCTION TensorQuadraturePoint_Pyramid2( & + & nipsx, & + & nipsy, & + & nipsz, & + & quadType, & + & refPyramid, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! number of integration points in z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refPyramid + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Pyramid2 +END INTERFACE TensorQuadraturePoint_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Pyramid + MODULE FUNCTION LagrangeEvalAll_Pyramid1( & + & order, & + & x, & + & xij, & + & refPyramid, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be computed and returned + !! by this routine. + !! If firstCall is False, then coeff should be given, which will be + !! used. + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Pyramid1 +END INTERFACE LagrangeEvalAll_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Pyramid + MODULE FUNCTION LagrangeEvalAll_Pyramid2( & + & order, & + & x, & + & xij, & + & refPyramid, & + & 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 + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Pyramid2 +END INTERFACE LagrangeEvalAll_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: GradientEvaluate all Lagrange polynomials at several points + +INTERFACE LagrangeGradientEvalAll_Pyramid + MODULE FUNCTION LagrangeGradientEvalAll_Pyramid1( & + & order, & + & x, & + & xij, & + & refPyramid, & + & 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 + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 3) + !! 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_Pyramid1 +END INTERFACE LagrangeGradientEvalAll_Pyramid + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE PyramidInterpolationUtility diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 new file mode 100644 index 000000000..20109601e --- /dev/null +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -0,0 +1,2042 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 QuadrangleInterpolationUtility +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE +PUBLIC :: LagrangeDegree_Quadrangle +PUBLIC :: LagrangeDOF_Quadrangle +PUBLIC :: LagrangeInDOF_Quadrangle +PUBLIC :: EquidistancePoint_Quadrangle +PUBLIC :: EquidistanceInPoint_Quadrangle +PUBLIC :: InterpolationPoint_Quadrangle +PUBLIC :: LagrangeCoeff_Quadrangle +PUBLIC :: Dubiner_Quadrangle +PUBLIC :: Dubiner_Quadrangle_ +PUBLIC :: TensorProdBasis_Quadrangle +PUBLIC :: OrthogonalBasis_Quadrangle +PUBLIC :: VertexBasis_Quadrangle +PUBLIC :: VerticalEdgeBasis_Quadrangle +PUBLIC :: HorizontalEdgeBasis_Quadrangle +PUBLIC :: CellBasis_Quadrangle +PUBLIC :: HeirarchicalBasis_Quadrangle +PUBLIC :: IJ2VEFC_Quadrangle_Clockwise +PUBLIC :: IJ2VEFC_Quadrangle_AntiClockwise +PUBLIC :: LagrangeEvalAll_Quadrangle +PUBLIC :: QuadraturePoint_Quadrangle +PUBLIC :: QuadratureNumber_Quadrangle +PUBLIC :: FacetConnectivity_Quadrangle +PUBLIC :: RefElemDomain_Quadrangle +PUBLIC :: LagrangeGradientEvalAll_Quadrangle +PUBLIC :: HeirarchicalBasisGradient_Quadrangle +PUBLIC :: TensorProdBasisGradient_Quadrangle +PUBLIC :: OrthogonalBasisGradient_Quadrangle +PUBLIC :: DubinerGradient_Quadrangle +PUBLIC :: DubinerGradient_Quadrangle_ +PUBLIC :: GetTotalDOF_Quadrangle +PUBLIC :: GetTotalInDOF_Quadrangle + +!---------------------------------------------------------------------------- +! GetTotalDOF_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Quadrangle + +INTERFACE + MODULE PURE FUNCTION GetTotalDOF_Quadrangle(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalDOF_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Quadrangle +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Quadrangle +!- These dof are strictly inside the Quadrangle + +INTERFACE + MODULE PURE FUNCTION GetTotalInDOF_Quadrangle(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! RefElemDomain_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) & + & RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseContinuity + !! Cointinuity (conformity) of basis functions + !! "H1", "HDiv", "HCurl", "DG" + CHARACTER(*), INTENT(IN) :: baseInterpol + !! Basis function family for Interpolation + !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal + TYPE(String) :: ans + END FUNCTION RefElemDomain_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetConnectivity_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-10 +! summary: This function returns the edge connectivity of Quadrangle + +INTERFACE + MODULE FUNCTION FacetConnectivity_Quadrangle( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2, 4) + !! rows represents the end points of an edges + !! columns denote the edge (facet) + END FUNCTION FacetConnectivity_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! 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 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 + +!---------------------------------------------------------------------------- +! LagrangeDOF_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Quadrangle + +INTERFACE LagrangeDOF_Quadrangle + MODULE PURE FUNCTION LagrangeDOF_Quadrangle1(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Quadrangle1 +END INTERFACE LagrangeDOF_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeDOF_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Quadrangle + +INTERFACE LagrangeDOF_Quadrangle + MODULE PURE FUNCTION LagrangeDOF_Quadrangle2(p, q) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B), INTENT(IN) :: q + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Quadrangle2 +END INTERFACE LagrangeDOF_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell/face of Quadrangle +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell/face of Quadrangle +!- These dof are strictly inside the Quadrangle + +INTERFACE LagrangeInDOF_Quadrangle + MODULE PURE FUNCTION LagrangeInDOF_Quadrangle1(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Quadrangle1 +END INTERFACE LagrangeInDOF_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell/face of Quadrangle +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell/face of Quadrangle +!- These dof are strictly inside the Quadrangle + +INTERFACE LagrangeInDOF_Quadrangle + MODULE PURE FUNCTION LagrangeInDOF_Quadrangle2(p, q) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Quadrangle2 +END INTERFACE LagrangeInDOF_Quadrangle + +!---------------------------------------------------------------------------- +! EquidistancePoint_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 EquidistancePoint_Quadrangle + MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + END FUNCTION EquidistancePoint_Quadrangle1 +END INTERFACE EquidistancePoint_Quadrangle + +!---------------------------------------------------------------------------- +! EquidistancePoint_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Quadrangle element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! Quadrangle element +!- The coordinates are distributed uniformly +!- These coordinates can be used to construct lagrange polynomials +!- The returned coordinates are in $x_{iJ}$ format. +!- The node numbering is according to Gmsh convention. + +INTERFACE EquidistancePoint_Quadrangle + MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 or 3 + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + END FUNCTION EquidistancePoint_Quadrangle2 +END INTERFACE EquidistancePoint_Quadrangle + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Quadrangle +!---------------------------------------------------------------------------- + +!> 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 PURE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 or 3 + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + END FUNCTION EquidistanceInPoint_Quadrangle1 +END INTERFACE EquidistanceInPoint_Quadrangle + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Quadrangle +!---------------------------------------------------------------------------- + +!> 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 PURE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 or 3 + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + END FUNCTION EquidistanceInPoint_Quadrangle2 +END INTERFACE EquidistanceInPoint_Quadrangle + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point +! +!# Introduction +! +! In this case order is same in both x1 and x2 direction. Therefore, +! (N+1)**2 grid points are returned. +! +! Also in both x1 and x2 same type of grid family will be used. +! +!- This routine returns the interplation points on quad +!- `xij` contains nodal coordinates of quad in xij format. +!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4 +!- If xij is absent then biunit quad is used +!- `ipType` is interpolation point type, it can take following values +!- `Equidistance`, uniformly/evenly distributed points +!- `GaussLegendreLobatto +!- `GaussChebyshevLobatto +! +!- `layout` specifies the arrangement of points. The nodes are always +! returned in VEFC format (vertex, edge, face, cell). 1:3 are are +! vertex points, then edge, and then internal nodes. The internal nodes +! also follow the same convention. Please read Gmsh manual on this topic. + +INTERFACE InterpolationPoint_Quadrangle + MODULE FUNCTION InterpolationPoint_Quadrangle1( & + & order, & + & ipType, & + & layout, & + & xij, & + & alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev1 + !! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight + !! GaussUltraspherical + !! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight + !! GaussJacobi + !! GaussJacobiLobatto + !! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: layout + !! VEFC, INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION InterpolationPoint_Quadrangle1 +END INTERFACE InterpolationPoint_Quadrangle + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point +! +!# Introduction +! +! In this case order is same in both x1 and x2 direction. Therefore, +! (N+1)**2 grid points are returned. +! +! Also in both x1 and x2 same type of grid family will be used. +! +!- This routine returns the interplation points on quad +!- `xij` contains nodal coordinates of quad in xij format. +!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4 +!- If xij is absent then biunit quad is used +!- `ipType` is interpolation point type, it can take following values +!- `Equidistance`, uniformly/evenly distributed points +!- `GaussLegendreLobatto +!- `GaussChebyshevLobatto +! +!- `layout` specifies the arrangement of points. The nodes are always +! returned in VEFC format (vertex, edge, face, cell). 1:3 are are +! vertex points, then edge, and then internal nodes. The internal nodes +! also follow the same convention. Please read Gmsh manual on this topic. + +INTERFACE InterpolationPoint_Quadrangle + MODULE FUNCTION InterpolationPoint_Quadrangle2( & + & p, q, ipType1, ipType2, layout, xij, alpha1, beta1, & + & lambda1, alpha2, beta2, lambda2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order of element in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of element in y direction + INTEGER(I4B), INTENT(IN) :: ipType1 + !! interpolation point type in x direction + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev1 + !! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight + !! GaussUltraspherical + !! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight + !! GaussJacobi + !! GaussJacobiLobatto + !! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + INTEGER(I4B), INTENT(IN) :: ipType2 + !! interpolation point type in y direction + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev1 + !! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight + !! GaussUltraspherical + !! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight + !! GaussJacobi + !! GaussJacobiLobatto + !! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: layout + !! VEFC, INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION InterpolationPoint_Quadrangle2 +END INTERFACE InterpolationPoint_Quadrangle + +!---------------------------------------------------------------------------- +! IJ2VEFC +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-17 +! summary: Convert format from IJ to VEFC + +INTERFACE + MODULE SUBROUTINE IJ2VEFC_Quadrangle(xi, eta, temp, p, q) + REAL(DFP), INTENT(IN) :: xi(:, :) + REAL(DFP), INTENT(IN) :: eta(:, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B), INTENT(IN) :: q + END SUBROUTINE IJ2VEFC_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-17 +! summary: Convert format from IJ to VEFC + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_Clockwise( & + & xi, eta, temp, p, q, startNode) + REAL(DFP), INTENT(IN) :: xi(:, :) + REAL(DFP), INTENT(IN) :: eta(:, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B), INTENT(IN) :: q + INTEGER(I4B), INTENT(IN) :: startNode + END SUBROUTINE IJ2VEFC_Quadrangle_Clockwise +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-17 +! summary: Convert format from IJ to VEFC + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise( & + & xi, eta, temp, p, q, startNode) + REAL(DFP), INTENT(IN) :: xi(:, :) + REAL(DFP), INTENT(IN) :: eta(:, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B), INTENT(IN) :: q + INTEGER(I4B), INTENT(IN) :: startNode + END SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle1 +END INTERFACE LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle2 +END INTERFACE LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +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 polynomial in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of polynomial in y direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basisType in x direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basisType in y direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle5 +END INTERFACE LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on biunit domain +! +!# Introduction +! +! Forms Dubiner basis on biunit quadrangle domain. +! This routine is called while forming dubiner basis on triangle domain +! +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). +! +! In this way, ans(j,:) denotes the values of all polynomial at jth point +! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ + +INTERFACE Dubiner_Quadrangle + MODULE PURE FUNCTION Dubiner_Quadrangle1(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in biunit quadrangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Quadrangle1 +END INTERFACE Dubiner_Quadrangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> 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 +!---------------------------------------------------------------------------- + +!> 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 +!---------------------------------------------------------------------------- + +!> 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 +!---------------------------------------------------------------------------- + +!> 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(:, :) + !! points in biunit quadrangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + REAL(DFP) :: ans(SIZE(xij, 2), & + & (order + 1_I4B) * (order + 2_I4B) / 2_I4B, & + & 2_I4B) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION DubinerGradient_Quadrangle1 +END INTERFACE DubinerGradient_Quadrangle + +!---------------------------------------------------------------------------- +! DubinerGradient +!---------------------------------------------------------------------------- + +!> 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 SUBROUTINE DubinerGradient_Quadrangle1_(order, xij, ans, & + tsize1, tsize2, tsize3) + 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_I4B) * (order + 2_I4B) / 2_I4B, & + ! & 2_I4B) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 + END SUBROUTINE DubinerGradient_Quadrangle1_ +END INTERFACE DubinerGradient_Quadrangle_ + +!---------------------------------------------------------------------------- +! TensorProdBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle +! +!# Introduction +! +! This function returns the tensor product expansion of orthogonal +! polynomial on biunit quadrangle. + +INTERFACE TensorProdBasis_Quadrangle + MODULE FUNCTION TensorProdBasis_Quadrangle1( & + & p, & + & q, & + & xij, & + & basisType1, & + & basisType2, & + & alpha1, & + & beta1, & + & lambda1, & + & alpha2, & + & beta2, & + & lambda2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basis type in x1 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basis type in x2 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) + !! + END FUNCTION TensorProdBasis_Quadrangle1 +END INTERFACE TensorProdBasis_Quadrangle + +INTERFACE OrthogonalBasis_Quadrangle + MODULE PROCEDURE TensorProdBasis_Quadrangle1 +END INTERFACE OrthogonalBasis_Quadrangle + +!---------------------------------------------------------------------------- +! TensorProdBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle +! +!# Introduction +! +! This function returns the tensor product expansion of orthogonal +! polynomial on biunit quadrangle. Here xij is obtained by +! outer product of x and y + +INTERFACE TensorProdBasis_Quadrangle + MODULE FUNCTION TensorProdBasis_Quadrangle2( & + & p, & + & q, & + & x, & + & y, & + & basisType1, & + & basisType2, & + & alpha1, & + & beta1, & + & lambda1, & + & alpha2, & + & beta2, & + & lambda2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1 + !! orthogonal polynomial family in x1 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! orthogonal poly family in x2 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1)) + !! Tensor basis + !! The number of rows corresponds to the + !! total number of points + END FUNCTION TensorProdBasis_Quadrangle2 +END INTERFACE TensorProdBasis_Quadrangle + +INTERFACE OrthogonalBasis_Quadrangle + MODULE PROCEDURE TensorProdBasis_Quadrangle2 +END INTERFACE OrthogonalBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE VertexBasis_Quadrangle + MODULE PURE FUNCTION VertexBasis_Quadrangle1(x, y) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Quadrangle1 +END INTERFACE VertexBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE VertexBasis_Quadrangle + MODULE PURE FUNCTION VertexBasis_Quadrangle3(xij) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + REAL(DFP) :: ans(SIZE(xij, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Quadrangle3 +END INTERFACE VertexBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Quadrangle2(L1, L2) RESULT(ans) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + !! L2 is Lobatto polynomial evaluated at y coordinates + REAL(DFP) :: ans(SIZE(L1, 1), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION VertexBasisGradient_Quadrangle2( & + & L1, & + & L2, & + & dL1, & + & dL2) RESULT(ans) + REAL(DFP), INTENT(IN) :: L1(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + REAL(DFP), INTENT(IN) :: L2(1:, 0:) + !! L2 is Lobatto polynomial evaluated at y coordinates + REAL(DFP), INTENT(IN) :: dL1(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + REAL(DFP), INTENT(IN) :: dL2(1:, 0:) + !! L2 is Lobatto polynomial evaluated at y coordinates + REAL(DFP) :: ans(SIZE(L1, 1), 4, 2) + !! Gradient of vertex basis + END FUNCTION VertexBasisGradient_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on left, right edge of biunit quadrangle +! +!# Introduction +! +! Evaluate basis functions on left and right edge of biunit quadrangle +! +! qe1 and qe2 should be greater than or equal to 2 +! +! Note that both edge are aligned in positive y direction. + +INTERFACE + MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle(qe1, qe2, x, y) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1), it should be greater than 1 + !! It should be greater than 2 + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2), it should be greater than 1 + !! It should be greater than 2 + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP) :: ans(SIZE(x), qe1 + qe2 - 2) + END FUNCTION VerticalEdgeBasis_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle2(qe1, qe2, L1, L2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2) + END FUNCTION VerticalEdgeBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION VerticalEdgeBasisGradient_Quadrangle2( & + & qe1, & + & qe2, & + & L1, & + & L2, & + & dL1, & + & dL2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2, 2) + END FUNCTION VerticalEdgeBasisGradient_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on bottom and top edge of biunit quadrangle +! +!# Introduction +! +! Evaluate basis functions on bottom and top edge of biunit quadrangle +! +! pe3 and pe4 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3), 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) :: x(:), y(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), pe3 + pe4 - 2) + END FUNCTION HorizontalEdgeBasis_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle2(pe3, pe4, L1, L2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2) + END FUNCTION HorizontalEdgeBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION HorizontalEdgeBasisGradient_Quadrangle2( & + &pe3, & + & pe4, & + & L1, & + & L2, & + & dL1, & + & dL2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2, 2) + END FUNCTION HorizontalEdgeBasisGradient_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis in the cell of biunit quadrangle +! +!# Introduction +! +! Evaluate basis functions in the cell of biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION CellBasis_Quadrangle(pb, qb, x, y) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), 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) :: x(:), y(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), (pb - 1) * (qb - 1)) + END FUNCTION CellBasis_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION CellBasis_Quadrangle2(pb, qb, L1, L2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) + END FUNCTION CellBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! CellBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION CellBasisGradient_Quadrangle2( & + & pb, & + & qb, & + & L1, & + & L2, & + & dL1, & + & dL2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1), 2) + END FUNCTION CellBasisGradient_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! +!# Introduction +! +! This function returns the modal basis on orthogonal polynomial +! The modal function in 1D is given by scaled Lobatto polynomial. +! These modal functions are orthogonal with respect to H1 seminorm. +! However, these modal function are not orthogonal withrespect to L2 norm. +! +! Bubble function in 1D is proportional to Jacobi polynomial with +! alpha=beta=1. Equivalently, these bubble functions are proportional to +! Ultraspherical polynomials with lambda = 3/2. +! + +INTERFACE HeirarchicalBasis_Quadrangle + MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle1(pb, qb, pe3, pe4, & + & qe1, qe2, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(xij, 2), & + & pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) + !! + END FUNCTION HeirarchicalBasis_Quadrangle1 +END INTERFACE HeirarchicalBasis_Quadrangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! +!# Introduction +! +! This function is identical to `HeirarchicalBasis_Quadrangle1` +! with qe1=qe2=qb=q, and pe3=pe4=pb=p. +! + +INTERFACE HeirarchicalBasis_Quadrangle + MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle2(p, q, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! order of interpolation inside the quadrangle in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) + END FUNCTION HeirarchicalBasis_Quadrangle2 +END INTERFACE 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Lagrange polynomials of n at several points + +INTERFACE LagrangeGradientEvalAll_Quadrangle + MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( & + & order, & + & x, & + & xij, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 2) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + END FUNCTION LagrangeGradientEvalAll_Quadrangle1 +END INTERFACE LagrangeGradientEvalAll_Quadrangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! +!# Introduction +! +! This function returns the modal basis on orthogonal polynomial +! The modal function in 1D is given by scaled Lobatto polynomial. +! These modal functions are orthogonal with respect to H1 seminorm. +! However, these modal function are not orthogonal withrespect to L2 norm. +! +! Bubble function in 1D is proportional to Jacobi polynomial with +! alpha=beta=1. Equivalently, these bubble functions are proportional to +! Ultraspherical polynomials with lambda = 3/2. + +INTERFACE HeirarchicalBasisGradient_Quadrangle + MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle1( & + & pb, & + & qb, & + & pe3, & + & pe4, & + & qe1, & + & qe2, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(xij, 2), & + & pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1, 2) + END FUNCTION HeirarchicalBasisGradient_Quadrangle1 +END INTERFACE HeirarchicalBasisGradient_Quadrangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle + +INTERFACE HeirarchicalBasisGradient_Quadrangle + MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle2( & + & p, & + & q, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! order of interpolation inside the quadrangle in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2) + END FUNCTION HeirarchicalBasisGradient_Quadrangle2 +END INTERFACE HeirarchicalBasisGradient_Quadrangle + +!---------------------------------------------------------------------------- +! TensorProdBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle + +INTERFACE TensorProdBasisGradient_Quadrangle + MODULE FUNCTION TensorProdBasisGradient_Quadrangle1( & + & p, & + & q, & + & xij, & + & basisType1, & + & basisType2, & + & alpha1, & + & beta1, & + & lambda1, & + & alpha2, & + & beta2, & + & lambda2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basis type in x1 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basis type in x2 direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2) + !! + END FUNCTION TensorProdBasisGradient_Quadrangle1 +END INTERFACE TensorProdBasisGradient_Quadrangle + +INTERFACE OrthogonalBasisGradient_Quadrangle + MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 +END INTERFACE OrthogonalBasisGradient_Quadrangle + +END MODULE QuadrangleInterpolationUtility diff --git a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 new file mode 100644 index 000000000..e45d75fde --- /dev/null +++ b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 @@ -0,0 +1,215 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE RecursiveNodesUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: RecursiveNode1D +PUBLIC :: RecursiveNode2D +PUBLIC :: RecursiveNode3D + +!---------------------------------------------------------------------------- +! RecursiveNode1D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: RecursiveNodes in 1D + +INTERFACE + MODULE FUNCTION RecursiveNode1D(order, ipType, & + & domain, alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 2 corresponding to b0 and b1 + !! size(ans,2) total number of points + CHARACTER(*), OPTIONAL, INTENT(IN) :: domain + !! unit (0,1) + !! biunit (-1, 1) + !! equilateral + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END FUNCTION RecursiveNode1D +END INTERFACE + +!---------------------------------------------------------------------------- +! RecursiveNode2D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: RecursiveNodes in 2D + +INTERFACE + MODULE FUNCTION RecursiveNode2D( & + & order, & + & ipType, & + & domain, & + & alpha, & + & beta, & + & lambda & + & ) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 3 corresponding to b0, b1, b2 + !! size(ans,2) total number of points + CHARACTER(*), OPTIONAL, INTENT(IN) :: domain + !! unit + !! Biunit + !! Equilateral + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END FUNCTION RecursiveNode2D +END INTERFACE + +!---------------------------------------------------------------------------- +! RecursiveNode3D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Recursive nodes in 3D + +INTERFACE + MODULE FUNCTION RecursiveNode3D( & + & order, & + & ipType, & + & domain, & + & alpha, & + & beta, & + & lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 4 corresponding to b0, b1, b2, b3 + !! size(ans,2) total number of points + CHARACTER(*), OPTIONAL, INTENT(IN) :: domain + !! unit + !! Biunit + !! Equilateral + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END FUNCTION RecursiveNode3D +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ToUnit(x, domain) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(*), INTENT(IN) :: domain + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ToUnit +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION FromUnit(x, domain) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(*), INTENT(IN) :: domain + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION FromUnit +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE PURE SUBROUTINE Unit2Equilateral(d, x) + INTEGER(I4B), INTENT(IN) :: d + REAL(DFP), INTENT(INOUT) :: x(:, :) + END SUBROUTINE Unit2Equilateral +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE PURE SUBROUTINE Equilateral2Unit(d, x) + INTEGER(I4B), INTENT(IN) :: d + REAL(DFP), INTENT(INOUT) :: x(:, :) + END SUBROUTINE Equilateral2Unit +END INTERFACE + +!---------------------------------------------------------------------------- +! Coord_Map +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Coord_Map(x, from, to) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(*), INTENT(IN) :: from + CHARACTER(*), INTENT(IN) :: to + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Coord_Map +END INTERFACE + +END MODULE RecursiveNodesUtility diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 new file mode 100644 index 000000000..1fba7da35 --- /dev/null +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -0,0 +1,1998 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 TetrahedronInterpolationUtility +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE + +PUBLIC :: LagrangeDegree_Tetrahedron +PUBLIC :: LagrangeDOF_Tetrahedron +PUBLIC :: LagrangeInDOF_Tetrahedron +PUBLIC :: EquidistanceInPoint_Tetrahedron +PUBLIC :: EquidistancePoint_Tetrahedron +PUBLIC :: LagrangeCoeff_Tetrahedron +PUBLIC :: Isaac_Tetrahedron +PUBLIC :: BlythPozrikidis_Tetrahedron +PUBLIC :: InterpolationPoint_Tetrahedron +PUBLIC :: OrthogonalBasis_Tetrahedron +PUBLIC :: BarycentricVertexBasis_Tetrahedron +PUBLIC :: BarycentricEdgeBasis_Tetrahedron +PUBLIC :: BarycentricFacetBasis_Tetrahedron +PUBLIC :: BarycentricCellBasis_Tetrahedron +PUBLIC :: BarycentricHeirarchicalBasis_Tetrahedron +PUBLIC :: VertexBasis_Tetrahedron +PUBLIC :: EdgeBasis_Tetrahedron +PUBLIC :: FacetBasis_Tetrahedron +PUBLIC :: CellBasis_Tetrahedron +PUBLIC :: HeirarchicalBasis_Tetrahedron +PUBLIC :: FacetConnectivity_Tetrahedron +PUBLIC :: EdgeConnectivity_Tetrahedron +PUBLIC :: GetVertexDOF_Tetrahedron +PUBLIC :: GetEdgeDOF_Tetrahedron +PUBLIC :: GetFacetDOF_Tetrahedron +PUBLIC :: GetCellDOF_Tetrahedron +PUBLIC :: LagrangeEvalAll_Tetrahedron +PUBLIC :: QuadraturePoint_Tetrahedron +PUBLIC :: RefElemDomain_Tetrahedron +PUBLIC :: LagrangeGradientEvalAll_Tetrahedron +PUBLIC :: HeirarchicalBasisGradient_Tetrahedron +PUBLIC :: OrthogonalBasisGradient_Tetrahedron +PUBLIC :: GetTotalDOF_Tetrahedron +PUBLIC :: GetTotalInDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetTotalDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Tetrahedron + +INTERFACE + MODULE PURE FUNCTION GetTotalDOF_Tetrahedron(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalDOF_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Tetrahedron +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Tetrahedron +!- These dof are strictly inside the Tetrahedron + +INTERFACE + MODULE PURE FUNCTION GetTotalInDOF_Tetrahedron(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! RefElemDomain_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain_Tetrahedron(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_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! GetVertexDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: returns total number of vertex degrees of freedom + +INTERFACE + MODULE PURE FUNCTION GetVertexDOF_Tetrahedron() RESULT(ans) + INTEGER(I4B) :: ans + END FUNCTION GetVertexDOF_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: returns total number of degrees of freedom on edges parallel to +! some axis + +INTERFACE GetEdgeDOF_Tetrahedron + MODULE PURE FUNCTION GetEdgeDOF_Tetrahedron1(pe1, pe2, pe3, & + & pe4, pe5, pe6) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1, pe2, pe3, pe4, pe5, pe6 + !! Order of interpolation in x or y or z direction + INTEGER(I4B) :: ans + END FUNCTION GetEdgeDOF_Tetrahedron1 +END INTERFACE GetEdgeDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total number of degrees of freedom on all edges + +INTERFACE GetEdgeDOF_Tetrahedron + MODULE PURE FUNCTION GetEdgeDOF_Tetrahedron2(p) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! Order of approximation on all edges + INTEGER(I4B) :: ans + END FUNCTION GetEdgeDOF_Tetrahedron2 +END INTERFACE GetEdgeDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns dof on all facets + +INTERFACE GetFacetDOF_Tetrahedron + MODULE PURE FUNCTION GetFacetDOF_Tetrahedron1( & + & ps1, ps2, & + & ps3, ps4) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: ps1 + !! orders alongs facets parallel to xy plane + INTEGER(I4B), INTENT(IN) :: ps2 + !! orders along facets parallel to xz plane + INTEGER(I4B), INTENT(IN) :: ps3 + !! orders along facets parallel to yz plane + INTEGER(I4B), INTENT(IN) :: ps4 + !! orders along facets parallel to xyz plane + INTEGER(I4B) :: ans + END FUNCTION GetFacetDOF_Tetrahedron1 +END INTERFACE GetFacetDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns total degrees of freedom on all facets + +INTERFACE GetFacetDOF_Tetrahedron + MODULE PURE FUNCTION GetFacetDOF_Tetrahedron2(p) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! orders alongs facets parallel to xy or xz or yz planes + INTEGER(I4B) :: ans + END FUNCTION GetFacetDOF_Tetrahedron2 +END INTERFACE GetFacetDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetFacetDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-24 +! summary: Returns the number of cell degree of freedom + +INTERFACE GetCellDOF_Tetrahedron + MODULE PURE FUNCTION GetCellDOF_Tetrahedron1(p) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! orders alongs to x, y, and z directions + INTEGER(I4B) :: ans + END FUNCTION GetCellDOF_Tetrahedron1 +END INTERFACE GetCellDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! FacetConnectivity_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-10 +! summary: This function returns the facet-connectivity of Tetrahedron + +INTERFACE + MODULE PURE FUNCTION FacetConnectivity_Tetrahedron( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(3, 4) + END FUNCTION FacetConnectivity_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-07 +! summary: This function returns the edge connectivity of Tetrahedron + +INTERFACE + MODULE PURE FUNCTION EdgeConnectivity_Tetrahedron( & + & baseInterpol, & + & baseContinuity) RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseInterpol + CHARACTER(*), INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2, 6) + END FUNCTION EdgeConnectivity_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE + MODULE PURE FUNCTION LagrangeDegree_Tetrahedron(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Tetrahedron + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF_Tetrahedron(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Tetrahedron +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell of Tetrahedron +!- These dof are strictly inside the Tetrahedron + +INTERFACE + MODULE PURE FUNCTION LagrangeInDOF_Tetrahedron(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points in Tetrahedron +! +!# Introduction +! +!- This function returns the equidistance points in Tetrahedron +!- All points are inside the Tetrahedron + +INTERFACE + MODULE FUNCTION EquidistanceInPoint_Tetrahedron_old(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistanceInPoint_Tetrahedron_old +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points strictly in Tetrahedron +! +!# Introduction +! +!- This function returns the equidistance points in Tetrahedron +!- All points are inside the Tetrahedron + +INTERFACE + MODULE FUNCTION EquidistanceInPoint_Tetrahedron(order, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistanceInPoint_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistancePoint_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Tetrahedron element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! Tetrahedron 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 + MODULE FUNCTION EquidistancePoint_Tetrahedron(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistancePoint_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistancePoint_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Tetrahedron element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! Tetrahedron 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 + MODULE RECURSIVE FUNCTION EquidistancePoint_Tetrahedron_old( & + & order, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistancePoint_Tetrahedron_old +END INTERFACE + +!---------------------------------------------------------------------------- +! InterpolationPoint_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point + +INTERFACE + MODULE FUNCTION InterpolationPoint_Tetrahedron( & + & order, & + & ipType, & + & layout, & + & xij, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation type + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussChebyshev, + !! GaussChebyshevLobatto + !! GaussJacobi + !! GaussJacobiLobatto + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC", "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(3, 4) + !! coordinates of vertices in $x_{iJ}$ format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in $x_{iJ}$ format + END FUNCTION InterpolationPoint_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE FUNCTION LagrangeCoeff_Tetrahedron1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron1 +END INTERFACE LagrangeCoeff_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE FUNCTION LagrangeCoeff_Tetrahedron2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron2 +END INTERFACE LagrangeCoeff_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE FUNCTION LagrangeCoeff_Tetrahedron3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron3 +END INTERFACE LagrangeCoeff_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE FUNCTION LagrangeCoeff_Tetrahedron4( & + & order, & + & xij, & + & basisType, & + & refTetrahedron, & + & alpha, beta, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi (Dubiner) + !! Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT * default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron4 +END INTERFACE LagrangeCoeff_Tetrahedron + +!---------------------------------------------------------------------------- +! Isaac_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Isaac points on triangle +! +!# Introduction +! +! https://tisaac.gitlab.io/recursivenodes/ + +INTERFACE + MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, & + & alpha, beta, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussChebyshev, + !! GaussChebyshevLobatto + !! GaussJacobi + !! GaussJacobiLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of Tetrahedron + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! xij coordinates + END FUNCTION Isaac_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BlythPozrikidis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Blyth Pozrikidis nodes on triangle +! +!# Introduction +! +! M. G. Blyth and C. Pozrikidis. +! A lobatto interpolation grid over the Tetrahedron. +! IMA Journal of Applied Mathematics, Feb 2006. + +INTERFACE + MODULE FUNCTION BlythPozrikidis_Tetrahedron(order, ipType, layout, xij, & + & alpha, beta, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussChebyshev, + !! GaussChebyshevLobatto + !! GaussJacobi + !! GaussJacobiLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! xij coordinates + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! xij coordinates + END FUNCTION BlythPozrikidis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! IJ2VEFC_Triangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE SUBROUTINE IJK2VEFC_Tetrahedron( & + & xi, & + & eta, & + & zeta, & + & temp, & + & order, & + & N) + REAL(DFP), INTENT(IN) :: xi(:, :, :) + REAL(DFP), INTENT(IN) :: eta(:, :, :) + REAL(DFP), INTENT(IN) :: zeta(:, :, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: N + END SUBROUTINE IJK2VEFC_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Orthogongal basis on Tetrahedron + +INTERFACE OrthogonalBasis_Tetrahedron + MODULE FUNCTION OrthogonalBasis_Tetrahedron1( & + & order, & + & xij, & + & refTetrahedron) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in reference Tetrahedron. + !! The shape functions will be evaluated + !! at these points. + !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" + !! "BIUNIT" + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & (order + 1) * (order + 2) * (order + 3) / 6) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION OrthogonalBasis_Tetrahedron1 +END INTERFACE OrthogonalBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Orthogongal basis on Tetrahedron + +INTERFACE OrthogonalBasis_Tetrahedron + MODULE FUNCTION OrthogonalBasis_Tetrahedron2( & + & order, & + & x, y, z, refTetrahedron) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:) + !! x coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) + REAL(DFP), INTENT(IN) :: y(:) + !! y coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) + REAL(DFP), INTENT(IN) :: z(:) + !! z coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" + !! "BIUNIT" + REAL(DFP) :: ans( & + & SIZE(x) * SIZE(y) * SIZE(z), & + & (order + 1) * (order + 2) * (order + 3) / 6) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION OrthogonalBasis_Tetrahedron2 +END INTERFACE OrthogonalBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricVertexBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on reference Tetrahedron + +INTERFACE + MODULE PURE FUNCTION BarycentricVertexBasis_Tetrahedron(lambda) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + !! number of rows = 4 + !! number of columns = number of points + REAL(DFP) :: ans(SIZE(lambda, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION BarycentricVertexBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricVertexBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Gradient of vertex basis in terms of barycentric coord + +INTERFACE + MODULE PURE FUNCTION BarycentricVertexBasisGradient_Tetrahedron(lambda) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + !! number of rows = 4 + !! number of columns = number of points + REAL(DFP) :: ans(SIZE(lambda, 2), 4, 4) + !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ + !! - index1: point of evaluation + !! - index2: vertex basis number + !! - index3: gradient + END FUNCTION BarycentricVertexBasisGradient_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edge of triangle +! +!# Introduction +! +! Evaluate basis functions on edges of triangle +! pe1, pe2, pe3 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order on edge parallel to yz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6) + END FUNCTION BarycentricEdgeBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 30 Oct 2022 +! summary: Evaluate the edge basis on Tetrahedron in terms of barycentric + +INTERFACE + MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & lambda, & + & phi) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order on edge parallel to yz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 4 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6) + END FUNCTION BarycentricEdgeBasis_Tetrahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 30 Oct 2022 +! summary: Eval grad of the basis in terms of barycentric coord + +INTERFACE + MODULE PURE FUNCTION BarycentricEdgeBasisGradient_Tetrahedron2( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & lambda, & + & phi, & + & dphi) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order on edge parallel to yz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 4 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 6*number of points + !! - (lambda2-lambda1) + !! - (lambda3-lambda1) + !! - (lambda4-lambda1) + !! - (lambda3-lambda2) + !! - (lambda4-lambda2) + !! - (lambda4-lambda3) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP), INTENT(IN) :: dphi(1:, 0:) + !! gradient of lobatto kernel + !! size(phi1, 1) = 3*number of points + !! - (lambda2-lambda1), + !! - (lambda3-lambda1), + !! - (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6, 4) + !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ + !! - index1: point of evaluation + !! - index2: vertex basis number + !! - index3: gradient + END FUNCTION BarycentricEdgeBasisGradient_Tetrahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricFacetBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on facet of triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron( & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: ps1 + !! order on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order on facet parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2) + END FUNCTION BarycentricFacetBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricFacetBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on facet of triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron2( & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & lambda, & + & phi & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: ps1 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order on edge parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2) + END FUNCTION BarycentricFacetBasis_Tetrahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricFacetBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval gradient of facet-basis in terms of barycentric + +INTERFACE + MODULE PURE FUNCTION BarycentricFacetBasisGradient_Tetrahedron2( & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & lambda, & + & phi, & + & dphi & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: ps1 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order on edge parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 6*number of points + !! - (lambda2-lambda1) + !! - (lambda3-lambda1) + !! - (lambda4-lambda1) + !! - (lambda3-lambda2) + !! - (lambda4-lambda2) + !! - (lambda4-lambda3) + REAL(DFP), INTENT(IN) :: dphi(1:, 0:) + !! gradient of lobatto kernel values + !! size(phi1, 1) = 6*number of points + !! - (lambda2-lambda1) + !! - (lambda3-lambda1) + !! - (lambda4-lambda1) + !! - (lambda3-lambda2) + !! - (lambda4-lambda2) + !! - (lambda4-lambda3) + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2, 4) + !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ + !! - index1: point of evaluation + !! - index2: vertex basis number + !! - index3: gradient + END FUNCTION BarycentricFacetBasisGradient_Tetrahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCellBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on cell of triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron( & + & pb, lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on facet parallel to xy + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B) + END FUNCTION BarycentricCellBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCellBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Evaluate cellbasis function in terms of barycentric coord + +INTERFACE + MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron2( & + & pb, lambda, phi) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on facet parallel to xy + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! Value of lobatto kernel values + !! size(phi1, 1) = 6*number of points + !! - (lambda2-lambda1) + !! - (lambda3-lambda1) + !! - (lambda4-lambda1) + !! - (lambda3-lambda2) + !! - (lambda4-lambda2) + !! - (lambda4-lambda3) + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B) + END FUNCTION BarycentricCellBasis_Tetrahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCellBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-25 +! summary: Gradient of cellbasis function in terms of barycentric coord + +INTERFACE + MODULE PURE FUNCTION BarycentricCellBasisGradient_Tetrahedron2( & + & pb, lambda, phi, dphi) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on facet parallel to xy + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! Value of lobatto kernel values + !! size(phi1, 1) = 6*number of points + !! - (lambda2-lambda1) + !! - (lambda3-lambda1) + !! - (lambda4-lambda1) + !! - (lambda3-lambda2) + !! - (lambda4-lambda2) + !! - (lambda4-lambda3) + REAL(DFP), INTENT(IN) :: dphi(1:, 0:) + !! Gradient of lobatto kernel values + !! size(phi1, 1) = 6*number of points + !! - (lambda2-lambda1) + !! - (lambda3-lambda1) + !! - (lambda4-lambda1) + !! - (lambda3-lambda2) + !! - (lambda4-lambda2) + !! - (lambda4-lambda3) + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B, 4) + !! - ans(:,:,i) denotes gradient wrt $\lambda_{i}$ + !! - index1: point of evaluation + !! - index2: vertex basis number + !! - index3: gradient + END FUNCTION BarycentricCellBasisGradient_Tetrahedron2 +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Tetrahedron + +INTERFACE BarycentricHeirarchicalBasis_Tetrahedron + MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1( & + & order, & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order of interpolation on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order of interpolation on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps1 + !! order of interpolation on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order of interpolation on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order of interpolation on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order of interpolation on facet parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 4 + !! number of cols = number of points + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & 4 & + & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + & + (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2 & + & + (order - 1) * (order - 2) * (order - 3) / 6_I4B) + END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1 +END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Gradient of heirarchical basis in terms of barycentric coord + +INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron + MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( & + & order, & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order of interpolation on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order of interpolation on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps1 + !! order of interpolation on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order of interpolation on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order of interpolation on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order of interpolation on facet parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 4 + !! number of cols = number of points + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & 4 & + & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + & + (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2 & + & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 4_I4B) + END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1 +END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-25 +! summary: Evaluate heirarchical basis in terms of barycentric coord + +INTERFACE BarycentricHeirarchicalBasis_Tetrahedron + MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2( & + & order, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 4 + !! number of cols = number of points + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (order + 1) * (order + 2) * (order + 3) / 6_I4B) + END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2 +END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-25 +! summary: Gradient of heirarchical basis in terms of barycentric coord + +INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron + MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron2( & + & order, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Point of evaluation in terms of barycentric coord + !! Barycenteric coordinates + !! number of rows = 4 + !! number of cols = number of points + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & (order + 1) * (order + 2) * (order + 3) / 6_I4B, 4) + END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron2 +END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron + +!---------------------------------------------------------------------------- +! VertexBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on Tetrahedron + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Tetrahedron(xij, refTetrahedron) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Unit or biunit + REAL(DFP) :: ans(SIZE(xij, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! EdgeBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the edge basis functions on Tetrahedron + +INTERFACE + MODULE PURE FUNCTION EdgeBasis_Tetrahedron( & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & xij, & + & refTetrahedron) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order on edge parallel to yz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6) + END FUNCTION EdgeBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the edge basis functions on Tetrahedron + +INTERFACE + MODULE PURE FUNCTION FacetBasis_Tetrahedron( & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & xij, & + & refTetrahedron) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: ps1 + !! order on facet to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order on facet to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order on facet to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order on facet to xyz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2) + END FUNCTION FacetBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! CellBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the cell basis functions on Tetrahedron + +INTERFACE + MODULE PURE FUNCTION CellBasis_Tetrahedron( & + & pb, & + & xij, & + & refTetrahedron) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order in cell + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B) + END FUNCTION CellBasis_Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the heirarchical basis functions on Tetrahedron + +INTERFACE HeirarchicalBasis_Tetrahedron + MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1( & + & order, & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & xij, & + & refTetrahedron) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order of interpolation on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order of interpolation on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps1 + !! order of interpolation on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order of interpolation on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order of interpolation on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order of interpolation on facet parallel to xyz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & 4 & + & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + & + (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2 & + & + (order - 1) * (order - 2) * (order - 3) / 6_I4B) + END FUNCTION HeirarchicalBasis_Tetrahedron1 +END INTERFACE HeirarchicalBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the heirarchical basis functions on Tetrahedron + +INTERFACE HeirarchicalBasis_Tetrahedron + MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2( & + & order, & + & xij, & + & refTetrahedron) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & (order + 1) * (order + 2) * (order + 3) / 6_I4B) + END FUNCTION HeirarchicalBasis_Tetrahedron2 +END INTERFACE HeirarchicalBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Tetrahedron + MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( & + & order, & + & x, & + & xij, & + & refTetrahedron, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, & + & beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be computed and returned + !! by this routine. + !! If firstCall is False, then coeff should be given, which will be + !! used. + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Tetrahedron1 +END INTERFACE LagrangeEvalAll_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: Evaluate all Lagrange polynomials at several points + +INTERFACE LagrangeEvalAll_Tetrahedron + MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( & + & order, & + & x, & + & xij, & + & refTetrahedron, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, & + & beta, & + & lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Tetrahedron2 +END INTERFACE LagrangeEvalAll_Tetrahedron + +!---------------------------------------------------------------------------- +! QuadraturePoints_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: quadrature points on Tetrahedron + +INTERFACE QuadraturePoint_Tetrahedron + MODULE FUNCTION QuadraturePoint_Tetrahedron1(& + & order, & + & quadType, & + & refTetrahedron, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + !! If xij is present then this argument is ignored + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3. + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Tetrahedron1 +END INTERFACE QuadraturePoint_Tetrahedron + +!---------------------------------------------------------------------------- +! QuadraturePoints_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: quadrature points on Tetrahedron + +INTERFACE QuadraturePoint_Tetrahedron + MODULE FUNCTION QuadraturePoint_Tetrahedron2(& + & nips, & + & quadType, & + & refTetrahedron, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! nips(1) .LE. 79, then we call + !! economical quadrature rules. + !! Otherwise, this routine will retport + !! error + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type, + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + !! If xij is present then this argument is ignored + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Tetrahedron2 +END INTERFACE QuadraturePoint_Tetrahedron + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points on Tetrahedron + +INTERFACE TensorQuadraturePoint_Tetrahedron + MODULE FUNCTION TensorQuadraturePoint_Tetrahedron1(order, quadType, & + & refTetrahedron, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 4. + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Tetrahedron1 +END INTERFACE TensorQuadraturePoint_Tetrahedron + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points + +INTERFACE TensorQuadraturePoint_Tetrahedron + MODULE FUNCTION TensorQuadraturePoint_Tetrahedron2( & + & nipsx, & + & nipsy, & + & nipsz, & + & quadType, & + & refTetrahedron, & + & xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! number of integration points in z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Tetrahedron2 +END INTERFACE TensorQuadraturePoint_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-23 +! summary: GradientEvaluate all Lagrange polynomials at several points + +INTERFACE LagrangeGradientEvalAll_Tetrahedron + MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( & + & order, & + & x, & + & xij, & + & refTetrahedron, & + & coeff, & + & firstCall, & + & basisType, & + & alpha, & + & beta, & + & lambda & + & ) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 3) + !! 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_Tetrahedron1 +END INTERFACE LagrangeGradientEvalAll_Tetrahedron + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Orthogongal basis on Tetrahedron + +INTERFACE OrthogonalBasisGradient_Tetrahedron + MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1( & + & order, & + & xij, & + & refTetrahedron) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in reference Tetrahedron. + !! The shape functions will be evaluated + !! at these points. + !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" + !! "BIUNIT" + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & (order + 1) * (order + 2) * (order + 3) / 6, 3) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION OrthogonalBasisGradient_Tetrahedron1 +END INTERFACE OrthogonalBasisGradient_Tetrahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the heirarchical basis functions on Tetrahedron + +INTERFACE HeirarchicalBasisGradient_Tetrahedron + MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1( & + & order, & + & pe1, & + & pe2, & + & pe3, & + & pe4, & + & pe5, & + & pe6, & + & ps1, & + & ps2, & + & ps3, & + & ps4, & + & xij, & + & refTetrahedron) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order of interpolation on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order of interpolation on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps1 + !! order of interpolation on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order of interpolation on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order of interpolation on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order of interpolation on facet parallel to xyz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & 4 & + & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + & + (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2 & + & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 3) + END FUNCTION HeirarchicalBasisGradient_Tetrahedron1 +END INTERFACE HeirarchicalBasisGradient_Tetrahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the heirarchical basis functions on Tetrahedron + +INTERFACE HeirarchicalBasisGradient_Tetrahedron + MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron2( & + & order, & + & xij, & + & refTetrahedron) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & (order + 1) * (order + 2) * (order + 3) / 6_I4B, 3) + END FUNCTION HeirarchicalBasisGradient_Tetrahedron2 +END INTERFACE HeirarchicalBasisGradient_Tetrahedron + +!---------------------------------------------------------------------------- +! Tetrahedron +!---------------------------------------------------------------------------- + +END MODULE TetrahedronInterpolationUtility diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 new file mode 100644 index 000000000..463931d91 --- /dev/null +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -0,0 +1,1633 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 TriangleInterpolationUtility +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE +PUBLIC :: LagrangeDegree_Triangle +PUBLIC :: LagrangeDOF_Triangle +PUBLIC :: LagrangeInDOF_Triangle +PUBLIC :: EquidistanceInPoint_Triangle +PUBLIC :: EquidistancePoint_Triangle +PUBLIC :: InterpolationPoint_Triangle +PUBLIC :: LagrangeCoeff_Triangle + +PUBLIC :: Dubiner_Triangle +PUBLIC :: OrthogonalBasis_Triangle +PUBLIC :: OrthogonalBasisGradient_Triangle + +PUBLIC :: VertexBasis_Triangle +PUBLIC :: EdgeBasis_Triangle +PUBLIC :: CellBasis_Triangle +PUBLIC :: HeirarchicalBasis_Triangle +PUBLIC :: HeirarchicalBasisGradient_Triangle + +PUBLIC :: LagrangeEvalAll_Triangle +PUBLIC :: LagrangeGradientEvalAll_Triangle +PUBLIC :: QuadraturePoint_Triangle +PUBLIC :: IJ2VEFC_Triangle +PUBLIC :: FacetConnectivity_Triangle +PUBLIC :: RefElemDomain_Triangle + +PUBLIC :: GetTotalDOF_Triangle +PUBLIC :: GetTotalInDOF_Triangle + +! PUBLIC :: BarycentricVertexBasis_Triangle +! PUBLIC :: BarycentricEdgeBasis_Triangle +! PUBLIC :: BarycentricHeirarchicalBasis_Triangle +! PUBLIC :: BarycentricHeirarchicalBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! GetTotalDOF_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on Triangle + +INTERFACE + MODULE PURE FUNCTION GetTotalDOF_Triangle(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalDOF_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Triangle +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial on an edge of a Triangle +!- These dof are strictly inside the Triangle + +INTERFACE + MODULE PURE FUNCTION GetTotalInDOF_Triangle(order, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! RefElemDomain_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the name of the reference element domain + +INTERFACE + MODULE FUNCTION RefElemDomain_Triangle(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 + !! UNIT or BIUNIT + END FUNCTION RefElemDomain_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetConnectivity_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-10 +! 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 + INTEGER(I4B) :: ans(2, 3) + !! rows represents the end points of an edges + !! columns denote the edge (facet) + END FUNCTION FacetConnectivity_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! IJ2VEFC_Triangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE IJ2VEFC_Triangle(xi, eta, temp, order, N) + REAL(DFP), INTENT(IN) :: xi(:, :) + REAL(DFP), INTENT(IN) :: eta(:, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: N + END SUBROUTINE IJ2VEFC_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE + MODULE PURE FUNCTION LagrangeDegree_Triangle(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + !! number of rows = LagrangeDOf_Triangle(order) + !! number of cols = 2 + END FUNCTION LagrangeDegree_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDegree_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE + MODULE PURE SUBROUTINE LagrangeDegree_Triangle_(order, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) + !! number of rows = LagrangeDOf_Triangle(order) + !! number of cols = 2 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeDegree_Triangle_ +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeDOF_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial on triangle + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF_Triangle(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeDOF_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns the total number of degree of freedom for a +! lagrange polynomial in cell/face of triangle +! +!# Introduction +! +!- Returns the total number of degree of freedom for a +! lagrange polynomial in cell/face of triangle +!- These dof are strictly inside the triangle + +INTERFACE + MODULE PURE FUNCTION LagrangeInDOF_Triangle(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LagrangeInDOF_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points in triangle +! +!# Introduction +! +!- This function returns the equidistance points in triangle +!- All points are inside the triangle + +INTERFACE + MODULE PURE FUNCTION EquidistanceInPoint_Triangle(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + !! If xij is present then number of rows in ans is same as xij + !! If xij is not present then number of rows in ans is 2. + END FUNCTION EquidistanceInPoint_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! EquidistancePoint_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order triangle element +! +!# Introduction +! +!- This function returns the nodal coordinates of higher order +! triangle element, the layout is always "VEFC" +!- The coordinates are distributed uniformly +!- These coordinates can be used to construct lagrange polynomials +!- The returned coordinates are in $x_{iJ}$ format. +!- The node numbering is according to Gmsh convention, VEFC. + +INTERFACE + MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Triangle(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + END FUNCTION EquidistancePoint_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BlythPozrikidis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Blyth Pozrikidis nodes on triangle +! +!# Introduction +! +! M. G. Blyth and C. Pozrikidis. +! A lobatto interpolation grid over the triangle. +! IMA Journal of Applied Mathematics, 71(1):153–169, Feb 2006. +! URL: http://dx.doi.org/10.1093/imamat/hxh077, +! doi:10.1093/imamat/hxh077. + +INTERFACE + MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, & + & alpha, beta, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! xij coordinates + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! xij coordinates + END FUNCTION BlythPozrikidis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! Isaac_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Isaac points on triangle + +INTERFACE + MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, & + & alpha, beta, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! xij coordinates + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! xij coordinates + END FUNCTION Isaac_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! InterpolationPoint_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation points on triangle +! +!# Introduction +! +!- This routine returns the interplation points on triangle. +!- `xij` contains nodal coordinates of triangle in xij format. +!- SIZE(xij,1) = nsd, and SIZE(xij,2)=3 +!- If xij is absent then unit triangle is assumed +!- `ipType` is interpolation point type, it can take following values +!- `Equidistance`, uniformly/evenly distributed points +!- `GaussLegendreLobatto ---> IsaacLegendre +!- `GaussChebyshevLobatto ---> IsaacChebyshev +!- `ChenBabuska` +!- `Hesthaven` +!- `Feket` +!- `BlythPozChebyshev` +!- `BlythPozLegendre` +!- `IsaacChebyshev` +!- `IsaacLegendre` +! +!- `layout` specifies the arrangement of points. The nodes are always +! returned in VEFC format (vertex, edge, face, cell). 1:3 are are +! vertex points, then edge, and then internal nodes. The internal nodes +! also follow the same convention. Please read Gmsh manual on this topic. + +INTERFACE + MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, & + & layout, xij, alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Coord of domain in xij format + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout, always VEFC + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! xij coordinates + END FUNCTION InterpolationPoint_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Returns the coefficients for ith lagrange polynomial + +INTERFACE LagrangeCoeff_Triangle + MODULE FUNCTION LagrangeCoeff_Triangle1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Triangle1 +END INTERFACE 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 FUNCTION LagrangeCoeff_Triangle2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue, the value of isVandermonde + !! is not used in the function + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients of ith Lagrange polynomial + END FUNCTION LagrangeCoeff_Triangle2 +END INTERFACE LagrangeCoeff_Triangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Returns the coefficients for ith lagrange polynomial + +INTERFACE LagrangeCoeff_Triangle + MODULE FUNCTION LagrangeCoeff_Triangle3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Triangle3 +END INTERFACE 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 FUNCTION LagrangeCoeff_Triangle4(order, xij, basisType, & + refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi (Dubiner) + !! Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTriangle + !! UNIT + !! BIUNIT + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION 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_Triangle4_(order, xij, basisType, & + refTriangle, 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) + !! Heirarchical + CHARACTER(*), INTENT(IN) :: refTriangle + !! UNIT + !! BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Triangle4_ +END INTERFACE LagrangeCoeff_Triangle_ + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. +! +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). +! +! In this way, ans(j,:) denotes the values of all polynomial at jth point +! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ + +INTERFACE Dubiner_Triangle + MODULE PURE FUNCTION Dubiner_Triangle1(order, xij, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points in reference triangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference domain of triangle where xij are defined + !! "UNIT" + !! "BIUNIT" + REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2) + !! Shape Functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Triangle1 +END INTERFACE Dubiner_Triangle + +INTERFACE OrthogonalBasis_Triangle + MODULE PROCEDURE Dubiner_Triangle1 +END INTERFACE OrthogonalBasis_Triangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. +! +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). +! +! In this way, ans(j,:) denotes the values of all polynomial at jth point +! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ + +INTERFACE Dubiner_Triangle_ + MODULE PURE SUBROUTINE Dubiner_Triangle1_(order, xij, refTriangle, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points in reference triangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference domain of triangle where xij are defined + !! "UNIT" + !! "BIUNIT" + 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_Triangle1_ +END INTERFACE Dubiner_Triangle_ + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. Here x and y are coordinate on line. +! xij is given by outerproduct of x and y. + +INTERFACE Dubiner_Triangle + MODULE PURE FUNCTION Dubiner_Triangle2(order, x, y, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! x and y coordinates, total points = SIZE(x)*SIZE(y) + !! x denotes the coordinates along the x direction + !! y denotes the coordinates along the y direction + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference domain of triangle where xij are defined + !! "UNIT" + !! "BIUNIT" + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Triangle2 +END INTERFACE Dubiner_Triangle + +INTERFACE OrthogonalBasis_Triangle + MODULE PROCEDURE Dubiner_Triangle2 +END INTERFACE OrthogonalBasis_Triangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. Here x and y are coordinate on line. +! xij is given by outerproduct of x and y. + +INTERFACE Dubiner_Triangle_ + MODULE PURE SUBROUTINE Dubiner_Triangle2_(order, x, y, refTriangle, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! x and y coordinates, total points = SIZE(x)*SIZE(y) + !! x denotes the coordinates along the x direction + !! y denotes the coordinates along the y direction + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference domain of triangle where xij are defined + !! "UNIT" + !! "BIUNIT" + 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_Triangle2_ +END INTERFACE Dubiner_Triangle_ + +!---------------------------------------------------------------------------- +! BarycentricVertexBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on reference Triangle + +INTERFACE + MODULE PURE SUBROUTINE BarycentricVertexBasis_Triangle(lambda, ans) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + !! number of rows = 3 corresponding to three coordinates + !! number of columns = number of points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans(SIZE(lambda, 2), 3) + !! ans(:,v1) basis function of vertex v1 at all points + END SUBROUTINE BarycentricVertexBasis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! VertexBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit Triangle + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Triangle(xij, refTriangle) RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation on the triangle + CHARACTER(*), INTENT(IN) :: refTriangle + !! UNIT or BIUNIT + REAL(DFP) :: ans(SIZE(xij, 2), 3) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edge of triangle +! +!# Introduction +! +! Evaluate basis functions on edges of triangle +! pe1, pe2, pe3 should be greater than or equal to 2 + +INTERFACE + MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle(pe1, pe2, pe3, & + lambda, ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge (e1) + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge (e2) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge (e3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to three corresponding to + !! three coordinates + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) + END SUBROUTINE BarycentricEdgeBasis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! EdgeBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on left, right edge of biunit Triangle +! +!# Introduction +! +! Evaluate basis functions on left and right edge of biunit Triangle +! +! qe1 and qe2 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION EdgeBasis_Triangle(pe1, pe2, pe3, xij, refTriangle) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on left vertical edge (e1), should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on right vertical edge(e2), should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on right vertical edge(e3), should be greater than 1 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + REAL(DFP) :: ans(SIZE(xij, 2), pe1 + pe2 + pe3 - 3) + END FUNCTION EdgeBasis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCellBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the Cell basis functions on reference Triangle + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCellBasis_Triangle(order, lambda, ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in this cell, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + !! number of rows = 3 corresponding to three coordinates + !! number of columns = number of points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) + END SUBROUTINE BarycentricCellBasis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! CellBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis in the cell of biunit Triangle +! +!# Introduction +! +! Evaluate basis functions in the cell of biunit Triangle + +INTERFACE + MODULE PURE FUNCTION CellBasis_Triangle(order, xij, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of approximation inside the cell, order>2 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + REAL(DFP) :: ans(SIZE(xij, 2), INT((order - 1) * (order - 2) / 2)) + END FUNCTION CellBasis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE BarycentricHeirarchicalBasis_Triangle + MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle1(order, & + & pe1, pe2, pe3, lambda, refTriangle, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge e1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge e2 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 3 + !! number of cols = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans( & + ! & SIZE(lambda, 2), & + ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricHeirarchicalBasis_Triangle1 +END INTERFACE BarycentricHeirarchicalBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE BarycentricHeirarchicalBasis_Triangle +MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle2(order, lambda, & + & refTriangle, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of approximation on triangle + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 3 + !! number of cols = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans( & + ! & SIZE(lambda, 2), & + ! & INT((order + 1) * (order + 2) / 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricHeirarchicalBasis_Triangle2 +END INTERFACE BarycentricHeirarchicalBasis_Triangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE HeirarchicalBasis_Triangle + MODULE PURE FUNCTION HeirarchicalBasis_Triangle1(order, pe1, pe2, pe3,& + & xij, refTriangle) RESULT(ans) + 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)) + !! + END FUNCTION HeirarchicalBasis_Triangle1 +END INTERFACE HeirarchicalBasis_Triangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-22 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE HeirarchicalBasis_Triangle + MODULE PURE FUNCTION HeirarchicalBasis_Triangle2(order, 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 + 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), & + 3 * order + INT((order - 1) * (order - 2) / 2)) + !! + END FUNCTION HeirarchicalBasis_Triangle2 +END INTERFACE HeirarchicalBasis_Triangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE HeirarchicalBasis_Triangle_ + MODULE PURE 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 + 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), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans( & + ! & SIZE(xij, 2), & + ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Triangle1_ +END INTERFACE HeirarchicalBasis_Triangle_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE HeirarchicalBasis_Triangle_ + MODULE PURE 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 + 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), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans( & + ! & SIZE(xij, 2), & + ! & order*3 + INT((order - 1) * (order - 2) / 2)) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Triangle2_ +END INTERFACE HeirarchicalBasis_Triangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-21 +! summary: Evaluate the gradient of the edge basis on triangle +! using barycentric coordinate + +INTERFACE + MODULE PURE SUBROUTINE BarycentricVertexBasisGradient_Triangle(lambda, ans) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! ans(SIZE(lambda, 2), 3, 3) + END SUBROUTINE BarycentricVertexBasisGradient_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-04-21 +! summary: Evaluate the gradient of the edge basis on triangle +! using barycentric coordinate + +INTERFACE + MODULE PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle(pe1, pe2, pe3, & + lambda, ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge (e1) + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge (e2) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge (e3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) + END SUBROUTINE BarycentricEdgeBasisGradient_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-04-21 +! summary: Evaluate the gradient of the edge basis on triangle +! using barycentric coordinate + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCellBasisGradient_Triangle(order, lambda, & + ans) + INTEGER(I4B), INTENT(IN) :: order + !! order on Cell (e1) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! REAL(DFP) :: ans(SIZE(lambda, 2), 3*order - 3, 3) + END SUBROUTINE BarycentricCellBasisGradient_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu and Vikas Sharma +! date: 2024-04-21 +! summary: Evaluate the gradient of the Hierarchical basis on triangle + +INTERFACE BarycentricHeirarchicalBasisGradient_Triangle +MODULE PURE SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1(order, & + & pe1, pe2, pe3, lambda, refTriangle, ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge e1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge e2 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 3 + !! number of cols = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! REAL(DFP) :: ans( & + ! & SIZE(lambda, 2), & + ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 3) + !! + END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1 +END INTERFACE BarycentricHeirarchicalBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-04 +! 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) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(2) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! + CHARACTER(*), INTENT(IN) :: refTriangle + !! interpolation points + REAL(DFP), 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) :: ans(SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Triangle1 +END INTERFACE LagrangeEvalAll_Triangle + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-04 +! 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) + 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 + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Triangle2 +END INTERFACE LagrangeEvalAll_Triangle + +!---------------------------------------------------------------------------- +! QuadraturePoints_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: based quadrature points + +INTERFACE QuadraturePoint_Triangle + MODULE FUNCTION QuadraturePoint_Triangle1(order, quadType, refTriangle, & + xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + !! If xij is present,then this parameter is not used + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Triangle1 +END INTERFACE QuadraturePoint_Triangle + +!---------------------------------------------------------------------------- +! QuadraturePoints_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: based quadrature points + +INTERFACE QuadraturePoint_Triangle + MODULE FUNCTION QuadraturePoint_Triangle2(nips, quadType, refTriangle, & + xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! nips(1) .LE. 79, then we call + !! economical quadrature rules. + !! Otherwise, this routine will retport + !! error + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type, + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION QuadraturePoint_Triangle2 +END INTERFACE QuadraturePoint_Triangle + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points + +INTERFACE TensorQuadraturePoint_Triangle + MODULE FUNCTION TensorQuadraturePoint_Triangle1(order, quadType, & + & refTriangle, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Triangle1 +END INTERFACE TensorQuadraturePoint_Triangle + +!---------------------------------------------------------------------------- +! TensorQuadraturePoints_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-20 +! summary: Tensor based quadrature points + +INTERFACE TensorQuadraturePoint_Triangle + MODULE FUNCTION TensorQuadraturePoint_Triangle2(nipsx, nipsy, quadType, & + & refTriangle, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Quadrature points + END FUNCTION TensorQuadraturePoint_Triangle2 +END INTERFACE TensorQuadraturePoint_Triangle + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Lagrange polynomials of n at several points + +INTERFACE LagrangeGradientEvalAll_Triangle + MODULE FUNCTION LagrangeGradientEvalAll_Triangle1( & + & 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(:, :) + !! 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 + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + 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_Triangle1 +END INTERFACE LagrangeGradientEvalAll_Triangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu and Vikas Sharma +! date: 2024-04-21 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE HeirarchicalBasisGradient_Triangle + 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 + 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) + END FUNCTION HeirarchicalBasisGradient_Triangle1 +END INTERFACE HeirarchicalBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Triangle_ +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu and Vikas Sharma +! date: 2024-04-21 +! 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) + 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), INTENT(INOUT) :: ans(:, :, :) + !! ans( & + !! & SIZE(xij, 2), & + !! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 2) + INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 + END SUBROUTINE HeirarchicalBasisGradient_Triangle1_ +END INTERFACE HeirarchicalBasisGradient_Triangle_ + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. +! +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). +! +! In this way, ans(j,:) denotes the values of all polynomial at jth point +! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ + +INTERFACE OrthogonalBasisGradient_Triangle + MODULE FUNCTION OrthogonalBasisGradient_Triangle1( & + & order, & + & xij, & + & refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in reference triangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! "UNIT" + !! "BIUNIT" + REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2, 2) + !! Derivative of shape functions + !! ans(:, j, 1), derivative wrt x of jth shape functions at all points + !! ans(j, :, 1), derivative wrt x of all shape functions at jth point + END FUNCTION OrthogonalBasisGradient_Triangle1 +END INTERFACE OrthogonalBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. +! +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). +! +! In this way, ans(j,:) denotes the values of all polynomial at jth point +! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ + +INTERFACE OrthogonalBasisGradient_Triangle_ + MODULE SUBROUTINE OrthogonalBasisGradient_Triangle1_(order, xij, & + refTriangle, ans, tsize1, tsize2, tsize3) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in reference triangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! "UNIT" + !! "BIUNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2, 2) + !! Derivative of shape functions + !! ans(:, j, 1), derivative wrt x of jth shape functions at all points + !! ans(j, :, 1), derivative wrt x of all shape functions at jth point + INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 + END SUBROUTINE OrthogonalBasisGradient_Triangle1_ +END INTERFACE OrthogonalBasisGradient_Triangle_ + +!---------------------------------------------------------------------------- +! Triangle +!---------------------------------------------------------------------------- + +END MODULE TriangleInterpolationUtility diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 new file mode 100644 index 000000000..b60a68710 --- /dev/null +++ b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 @@ -0,0 +1,1251 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to Ultraspherical Polynomials is defined. +! +!{!pages/UltrasphericalPolynomialUtility.md!} + +MODULE UltrasphericalPolynomialUtility +USE GlobalData +USE BaseType, ONLY: iface_1DFunction +IMPLICIT NONE +PRIVATE +PUBLIC :: UltrasphericalAlpha +PUBLIC :: UltrasphericalBeta +PUBLIC :: GetUltrasphericalRecurrenceCoeff +PUBLIC :: GetUltrasphericalRecurrenceCoeff2 +PUBLIC :: UltrasphericalLeadingCoeff +PUBLIC :: UltrasphericalLeadingCoeffRatio +PUBLIC :: UltrasphericalNormSQR +PUBLIC :: UltrasphericalNormSQR2 +PUBLIC :: UltrasphericalNormSQRRatio +PUBLIC :: UltrasphericalJacobiMatrix +PUBLIC :: UltrasphericalGaussQuadrature +PUBLIC :: UltrasphericalJacobiRadauMatrix +PUBLIC :: UltrasphericalGaussRadauQuadrature +PUBLIC :: UltrasphericalJacobiLobattoMatrix +PUBLIC :: UltrasphericalGaussLobattoQuadrature +PUBLIC :: UltrasphericalZeros +PUBLIC :: UltrasphericalQuadrature +PUBLIC :: UltrasphericalEval +PUBLIC :: UltrasphericalEvalAll +PUBLIC :: UltrasphericalEvalAll_ +PUBLIC :: UltrasphericalGradientEvalAll +PUBLIC :: UltrasphericalGradientEvalAll_ +PUBLIC :: UltrasphericalGradientEval +PUBLIC :: UltrasphericalEvalSum +PUBLIC :: UltrasphericalGradientEvalSum +PUBLIC :: UltrasphericalTransform +PUBLIC :: UltrasphericalInvTransform +PUBLIC :: UltrasphericalGradientCoeff +PUBLIC :: UltrasphericalDMatrix +PUBLIC :: UltrasphericalDMatEvenOdd + +!---------------------------------------------------------------------------- +! UltrasphericalAlpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, alpha , of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalAlpha(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalAlpha +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalBeta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalBeta(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalBeta +END INTERFACE + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the recurrence coefficient for nth order polynomial (monic) + +INTERFACE + MODULE PURE SUBROUTINE GetUltrasphericalRecurrenceCoeff(n, & + & lambda, alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + !! lambda should not be zero + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetUltrasphericalRecurrenceCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the recurrence coefficient for nth order polynomial (monic) + +INTERFACE + MODULE PURE SUBROUTINE GetUltrasphericalRecurrenceCoeff2(n, lambda, & + & A, B, C) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + !! lambda should not be 0.0 + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + !! size is n + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + !! this coefficient is zero + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + !! size is n + END SUBROUTINE GetUltrasphericalRecurrenceCoeff2 +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Leading coefficient of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalLeadingCoeff(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalLeadingCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Ratio of leading coefficients, kn+1/kn + +INTERFACE + MODULE PURE FUNCTION UltrasphericalLeadingCoeffRatio(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalLeadingCoeffRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalNormSQR +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalNormSQR(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + END FUNCTION UltrasphericalNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalNormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalNormSQR2(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans(0:n) + END FUNCTION UltrasphericalNormSQR2 +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm ration of Ultraspherical polynomial, n+1/n + +INTERFACE + MODULE PURE FUNCTION UltrasphericalNormSQRRatio(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + END FUNCTION UltrasphericalNormSQRRatio +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the Jacobi matrix for Ultraspherical polynomial + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalJacobiMatrix(n, lambda, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + !! recurrence coefficient of monic Ultraspherical polynomial, from 0 to n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + !! recurrence coefficient of monic Ultraspherical polynomial, from 0 to n-1 + END SUBROUTINE UltrasphericalJacobiMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalGaussQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss quadrature points for Ultraspherical Polynomial + +INTERFACE + MODULE SUBROUTINE UltrasphericalGaussQuadrature(n, lambda, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! It represents the order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! the size is 1 to n + END SUBROUTINE UltrasphericalGaussQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiRadauMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalJacobiRadauMatrix(a, n, lambda, D, E, & + & alphaCoeff, betaCoeff) + REAL(DFP), INTENT(IN) :: a + !! one of the end of the domain + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+1 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE UltrasphericalJacobiRadauMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalGaussRadauQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Radau quadrature points for Ultraspherical +! Polynomial + +INTERFACE + MODULE SUBROUTINE UltrasphericalGaussRadauQuadrature(a, n, lambda, pt, wt) + REAL(DFP), INTENT(IN) :: a + !! the value of one of the end points + !! it should be either -1 or +1 + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+1 weights from 1 to n+1 + END SUBROUTINE UltrasphericalGaussRadauQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalUltrasphericalLobattoMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalJacobiLobattoMatrix(n, lambda, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+2 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE UltrasphericalJacobiLobattoMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Lobatto quadrature points for Ultraspherical +! Polynomial + +INTERFACE + MODULE SUBROUTINE UltrasphericalGaussLobattoQuadrature(n, lambda, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomials + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+2 quad points indexed from 1 to n+2 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+2 weights, index from 1 to n+2 + END SUBROUTINE UltrasphericalGaussLobattoQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Ultraspherical polynomials + +INTERFACE + MODULE FUNCTION UltrasphericalZeros(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans(n) + END FUNCTION UltrasphericalZeros +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Ultraspherical-Gauss, Ultraspherical-Radau, +! Ultraspherical-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Ultraspherical polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of Ultraspherical polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE UltrasphericalQuadrature(n, lambda, pt, wt, & + & quadType, onlyInside) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Ultraspherical polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside + !! only inside + END SUBROUTINE UltrasphericalQuadrature +END INTERFACE + +!---------------------------------------------------------------------------- +! UltrasphericalEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEval1(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEval1 +END INTERFACE + +INTERFACE UltrasphericalEval + MODULE PROCEDURE UltrasphericalEval1 +END INTERFACE UltrasphericalEval + +!---------------------------------------------------------------------------- +! UltrasphericalEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEval2(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEval2 +END INTERFACE + +INTERFACE UltrasphericalEval + MODULE PROCEDURE UltrasphericalEval2 +END INTERFACE UltrasphericalEval + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE UltrasphericalEvalAll + MODULE PURE FUNCTION UltrasphericalEvalAll1(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UltrasphericalEvalAll1 +END INTERFACE UltrasphericalEvalAll + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE UltrasphericalEvalAll_ + MODULE PURE SUBROUTINE UltrasphericalEvalAll1_(n, lambda, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + ! REAL(DFP) :: ans(n + 1) + !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE UltrasphericalEvalAll1_ +END INTERFACE UltrasphericalEvalAll_ + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE UltrasphericalEvalAll + MODULE PURE FUNCTION UltrasphericalEvalAll2(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UltrasphericalEvalAll2 +END INTERFACE UltrasphericalEvalAll + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE UltrasphericalEvalAll_ + MODULE PURE SUBROUTINE UltrasphericalEvalAll2_(n, lambda, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow, ncol + END SUBROUTINE UltrasphericalEvalAll2_ +END INTERFACE UltrasphericalEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE UltrasphericalGradientEvalAll + MODULE PURE FUNCTION UltrasphericalGradientEvalAll1(n, lambda, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION UltrasphericalGradientEvalAll1 +END INTERFACE UltrasphericalGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE UltrasphericalGradientEvalAll_ + MODULE PURE SUBROUTINE UltrasphericalGradientEvalAll1_(n, lambda, x, ans, & + tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + !! 1:n+1 + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE UltrasphericalGradientEvalAll1_ +END INTERFACE UltrasphericalGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE UltrasphericalGradientEvalAll + MODULE PURE FUNCTION UltrasphericalGradientEvalAll2(n, lambda, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION UltrasphericalGradientEvalAll2 +END INTERFACE UltrasphericalGradientEvalAll + +!---------------------------------------------------------------------------- +! UltraSphericalGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE UltrasphericalGradientEvalAll_ + MODULE PURE SUBROUTINE UltrasphericalGradientEvalAll2_(n, lambda, x, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(1:SIZE(x), 1:n + 1) + INTEGER(I4B), INTENT(OUT) :: nrow + INTEGER(I4B), INTENT(OUT) :: ncol + END SUBROUTINE UltrasphericalGradientEvalAll2_ +END INTERFACE UltrasphericalGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEval1(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION UltrasphericalGradientEval1 +END INTERFACE +!! + +INTERFACE UltrasphericalGradientEval + MODULE PROCEDURE UltrasphericalGradientEval1 +END INTERFACE UltrasphericalGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEval2(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION UltrasphericalGradientEval2 +END INTERFACE + +INTERFACE UltrasphericalGradientEval + MODULE PROCEDURE UltrasphericalGradientEval2 +END INTERFACE UltrasphericalGradientEval + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Ultraspherical polynomials at point x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEvalSum1(n, lambda, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! alpha of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEvalSum1 +END INTERFACE + +INTERFACE UltrasphericalEvalSum + MODULE PROCEDURE UltrasphericalEvalSum1 +END INTERFACE UltrasphericalEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Ultraspherical polynomials at several x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEvalSum2(n, lambda, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! alpha of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEvalSum2 +END INTERFACE + +INTERFACE UltrasphericalEvalSum + MODULE PROCEDURE UltrasphericalEvalSum2 +END INTERFACE UltrasphericalEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials +! at point x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum1(n, lambda, x, & + & coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum1 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum1 +END INTERFACE UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials +! at several x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum2(n, lambda, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum2 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum2 +END INTERFACE UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Ultraspherical +! polynomials at point x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum3(n, lambda, x, & + & coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum3 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum3 +END INTERFACE UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Ultraspherical +! polynomials at several x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum4(n, lambda, x, & + & coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum4 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum4 +END INTERFACE UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalTransform1(n, lambda, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION UltrasphericalTransform1 +END INTERFACE + +INTERFACE UltrasphericalTransform + MODULE PROCEDURE UltrasphericalTransform1 +END INTERFACE UltrasphericalTransform + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION UltrasphericalTransform2 +END INTERFACE + +INTERFACE UltrasphericalTransform + MODULE PROCEDURE UltrasphericalTransform2 +END INTERFACE UltrasphericalTransform + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the Ultraspherical transformation of f defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls +! `UltrasphericalQuadrature` which is not pure due to Lapack call. +!@endnote + +INTERFACE + MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION UltrasphericalTransform3 +END INTERFACE + +INTERFACE UltrasphericalTransform + MODULE PROCEDURE UltrasphericalTransform3 +END INTERFACE UltrasphericalTransform + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalInvTransform1(n, lambda, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION UltrasphericalInvTransform1 +END INTERFACE + +INTERFACE UltrasphericalInvTransform + MODULE PROCEDURE UltrasphericalInvTransform1 +END INTERFACE UltrasphericalInvTransform + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalInvTransform2(n, lambda, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION UltrasphericalInvTransform2 +END INTERFACE + +INTERFACE UltrasphericalInvTransform + MODULE PROCEDURE UltrasphericalInvTransform2 +END INTERFACE UltrasphericalInvTransform + +!---------------------------------------------------------------------------- +! UltrasphericalGradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Ultraspherical expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Jacobi expansion. +! Input is cofficients of Jacobipolynomials (modal values). + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientCoeff1(n, lambda, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from UltrasphericalTransform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION UltrasphericalGradientCoeff1 +END INTERFACE + +INTERFACE UltrasphericalGradientCoeff + MODULE PROCEDURE UltrasphericalGradientCoeff1 +END INTERFACE UltrasphericalGradientCoeff + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Ultraspherical expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Ultraspherical +! expansion. +! Input is cofficients of Ultrasphericalpolynomials (modal values). + +INTERFACE + MODULE PURE FUNCTION UltrasphericalDMatrix1(n, lambda, x, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION UltrasphericalDMatrix1 +END INTERFACE + +INTERFACE UltrasphericalDMatrix + MODULE PROCEDURE UltrasphericalDMatrix1 +END INTERFACE UltrasphericalDMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalDMatEvenOdd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Ultraspherical expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Ultraspherical +! expansion. +! Input is cofficients of Ultrasphericalpolynomials (modal values). +! + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalDMatEvenOdd1(n, D, e, o) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: D(0:n, 0:n) + !! n+1 by n+1 + REAL(DFP), INTENT(OUT) :: e(0:, 0:) + !! even Decomposition + REAL(DFP), INTENT(OUT) :: o(0:, 0:) + !! odd decomposition + END SUBROUTINE UltrasphericalDMatEvenOdd1 +END INTERFACE + +INTERFACE UltrasphericalDMatEvenOdd + MODULE PROCEDURE UltrasphericalDMatEvenOdd1 +END INTERFACE UltrasphericalDMatEvenOdd + +END MODULE UltrasphericalPolynomialUtility diff --git a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 new file mode 100644 index 000000000..d766d0344 --- /dev/null +++ b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 @@ -0,0 +1,411 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to UnscaledLobatto Polynomials is defined. +! +!{!pages/UnscaledLobattoPolynomialUtility.md!} + +MODULE UnscaledLobattoPolynomialUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: UnscaledLobattoLeadingCoeff +PUBLIC :: UnscaledLobattoZeros +PUBLIC :: UnscaledLobattoEval +PUBLIC :: UnscaledLobattoEvalAll +PUBLIC :: UnscaledLobattoMonomialExpansionAll +PUBLIC :: UnscaledLobattoMonomialExpansion +PUBLIC :: UnscaledLobattoGradientEvalAll +PUBLIC :: UnscaledLobattoGradientEval +PUBLIC :: UnscaledLobattoMassMatrix +PUBLIC :: UnscaledLobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! UnscaledLobattoLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Leading coefficient of UnscaledLobatto polynomial + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoLeadingCoeff(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of UnscaledLobatto polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION UnscaledLobattoLeadingCoeff +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of UnscaledLobatto polynomial +! + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoNormSQR(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION UnscaledLobattoNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! UnscaledLobattoZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of UnscaledLobatto polynomials + +INTERFACE + MODULE FUNCTION UnscaledLobattoZeros(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of UnscaledLobatto polynomial, should be greater than equal to 2 + REAL(DFP) :: ans(n) + !! + END FUNCTION UnscaledLobattoZeros +END INTERFACE + +!---------------------------------------------------------------------------- +! UnscaledLobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto +! polynomials at the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate UnscaledLobatto polynomial of order n at point x + END FUNCTION UnscaledLobattoEval1 +END INTERFACE + +INTERFACE UnscaledLobattoEval + MODULE PROCEDURE UnscaledLobattoEval1 +END INTERFACE UnscaledLobattoEval + +!---------------------------------------------------------------------------- +! UnscaledLobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at +! several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at +! the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate UnscaledLobatto polynomial of order n at point x + END FUNCTION UnscaledLobattoEval2 +END INTERFACE + +INTERFACE UnscaledLobattoEval + MODULE PROCEDURE UnscaledLobattoEval2 +END INTERFACE UnscaledLobattoEval + +!---------------------------------------------------------------------------- +! UnscaledLobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at +! several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at +! the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UnscaledLobattoEvalAll1 +END INTERFACE + +INTERFACE UnscaledLobattoEvalAll + MODULE PROCEDURE UnscaledLobattoEvalAll1 +END INTERFACE UnscaledLobattoEvalAll + +!---------------------------------------------------------------------------- +! UnscaledLobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at +! several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at +! the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UnscaledLobattoEvalAll2 +END INTERFACE + +INTERFACE UnscaledLobattoEvalAll + MODULE PROCEDURE UnscaledLobattoEvalAll2 +END INTERFACE UnscaledLobattoEvalAll + +!---------------------------------------------------------------------------- +! UnscaledLobattoMonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary:Returns the monomial expansion of all UnscaledLobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all UnscaledLobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|------|------|-------|-------| +! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | +! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | +! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | +! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | +! | 0 | 0 | 0 | 0 | 4.375 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 7.875 | + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoMonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION UnscaledLobattoMonomialExpansionAll +END INTERFACE + +!---------------------------------------------------------------------------- +! UnscaledLobattoMonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a UnscaledLobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a UnscaledLobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoMonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION UnscaledLobattoMonomialExpansion +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION UnscaledLobattoGradientEvalAll1 +END INTERFACE +!! + +INTERFACE UnscaledLobattoGradientEvalAll + MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 +END INTERFACE UnscaledLobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION UnscaledLobattoGradientEvalAll2 +END INTERFACE +!! + +INTERFACE UnscaledLobattoGradientEvalAll + MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 +END INTERFACE UnscaledLobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION UnscaledLobattoGradientEval1 +END INTERFACE +!! + +INTERFACE UnscaledLobattoGradientEval + MODULE PROCEDURE UnscaledLobattoGradientEval1 +END INTERFACE UnscaledLobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION UnscaledLobattoGradientEval2 +END INTERFACE + +INTERFACE UnscaledLobattoGradientEval + MODULE PROCEDURE UnscaledLobattoGradientEval2 +END INTERFACE UnscaledLobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: UnscaledLobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoMassMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION UnscaledLobattoMassMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: UnscaledLobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoStiffnessMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION UnscaledLobattoStiffnessMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE UnscaledLobattoPolynomialUtility diff --git a/src/modules/QuadraturePoint/CMakeLists.txt b/src/modules/QuadraturePoint/CMakeLists.txt new file mode 100644 index 000000000..8a1514847 --- /dev/null +++ b/src/modules/QuadraturePoint/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/QuadraturePoint_Method.F90 +) \ No newline at end of file diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 new file mode 100755 index 000000000..8ba04ee10 --- /dev/null +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -0,0 +1,779 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 1 March 2021 +! summary: This module contains the methods for data type [[QuadraturePoint_]] + +MODULE QuadraturePoint_Method +USE BaseType +USE GlobalData +USE String_Class, ONLY: String +IMPLICIT NONE +PRIVATE +PUBLIC :: Initiate +PUBLIC :: QuadraturePoint +PUBLIC :: QuadraturePoint_Pointer +PUBLIC :: DEALLOCATE +PUBLIC :: SIZE +PUBLIC :: GetTotalQuadraturepoints +PUBLIC :: GetQuadraturepoints +PUBLIC :: Outerprod +PUBLIC :: Display +PUBLIC :: QuadraturePoint_MdEncode +PUBLIC :: QuadraturePointIdToName +PUBLIC :: QuadraturePointNameToId +PUBLIC :: MdEncode + +!---------------------------------------------------------------------------- +! QuadratuePointNameToId@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-06 +! summary: Quadrature point name to quadrature point id + +INTERFACE + MODULE FUNCTION QuadraturePointNameToId(name) RESULT(ans) + CHARACTER(*), INTENT(IN) :: name + INTEGER(I4B) :: ans + END FUNCTION QuadraturePointNameToId +END INTERFACE + +!---------------------------------------------------------------------------- +! QuadratuePointIdToName@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-06 +! summary: Quadrature point name to quadrature point id + +INTERFACE + MODULE FUNCTION QuadraturePointIdToName(name) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: name + TYPE(String) :: ans + END FUNCTION QuadraturePointIdToName +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiates the quadrature points + +INTERFACE Initiate + MODULE PURE SUBROUTINE quad_initiate1(obj, points) + CLASS(QuadraturePoint_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: points(:, :) + !! points contains the quadrature points and weights + !! points( :, ipoint ) contains quadrature points and weights of ipoint + !! quadrature point. The last row contains the weight. The rest of the + !! rows contains the coordinates of quadrature. + END SUBROUTINE quad_initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiates the quadrature points + +INTERFACE Initiate + MODULE PURE SUBROUTINE quad_initiate2(obj, tXi, tpoints) + CLASS(QuadraturePoint_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tXi + !! Total number of xidimension + !! For line tXi=1 + !! For 2D element tXi=2 + !! For 3D element tXi=3 + INTEGER(I4B), INTENT(IN) :: tpoints + !! Total number quadrature points + END SUBROUTINE quad_initiate2 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiates the quadrature points + +INTERFACE Initiate + MODULE SUBROUTINE quad_initiate3(obj, refElem, order, quadratureType, & + & alpha, beta, lambda) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + CLASS(ReferenceElement_), INTENT(IN) :: refElem + !! Reference element + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + CHARACTER(*), 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 + END SUBROUTINE quad_initiate3 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiates the quadrature points + +INTERFACE Initiate + MODULE SUBROUTINE quad_initiate4(obj, refElem, nips, quadratureType, & + & alpha, beta, lambda) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + CLASS(ReferenceElement_), INTENT(IN) :: refElem + !! Reference element + INTEGER(I4B), INTENT(IN) :: nips(1) + !! order of integrand + CHARACTER(*), INTENT(IN) :: quadratureType + !! Total number quadrature points + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE quad_initiate4 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine constructs the quadrature points + +INTERFACE Initiate + MODULE SUBROUTINE quad_initiate5( & + & obj, & + & refElem, & + & order, & + & quadratureType, & + & alpha, beta, lambda) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + CLASS(ReferenceElement_), INTENT(IN) :: refElem + !! Reference-element + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadratureType + !! Type of quadrature points + !! GaussLegendre + !! GaussLegendreLobatto + !! GaussLegendreRadau + !! GaussLegendreRadauLeft + !! GaussLegendreRadauRight + !! GaussChebyshev + !! GaussChebyshevLobatto + !! GaussChebyshevRadau + !! GaussChebyshevRadauLeft + !! GaussChebyshevRadauRight + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE quad_initiate5 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiates the quadrature points + +INTERFACE Initiate + MODULE SUBROUTINE quad_initiate6( & + & obj, & + & refElem, & + & nips, & + & quadratureType, & + & alpha, & + & beta, & + & lambda) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + CLASS(ReferenceElement_), INTENT(IN) :: refElem + !! Reference element + INTEGER(I4B), INTENT(IN) :: nips(1) + !! order of integrand + 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 + END SUBROUTINE quad_initiate6 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiates the quadrature points + +INTERFACE Initiate + MODULE SUBROUTINE quad_initiate7( & + & obj, & + & refElem, & + & p, q, r, & + & quadratureType1, & + & quadratureType2, & + & quadratureType3, & + & alpha1, beta1, lambda1, & + & alpha2, beta2, lambda2, & + & alpha3, beta3, lambda3) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + CLASS(ReferenceElement_), INTENT(IN) :: refElem + !! 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 + 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 + END SUBROUTINE quad_initiate7 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiates the quadrature points + +INTERFACE Initiate + MODULE SUBROUTINE quad_initiate8( & + & obj, & + & refElem, & + & nipsx, & + & nipsy, & + & nipsz, & + & quadratureType1, & + & quadratureType2, & + & quadratureType3, & + & alpha1, beta1, lambda1, & + & alpha2, beta2, lambda2, & + & alpha3, beta3, lambda3) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + CLASS(ReferenceElement_), INTENT(IN) :: refElem + !! Reference element + 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 + END SUBROUTINE quad_initiate8 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! QuadraturePoint@ConstructureMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine initiate an instance of quadrature points + +INTERFACE QuadraturePoint + MODULE PURE FUNCTION quad_Constructor1(points) RESULT(obj) + TYPE(QuadraturePoint_) :: obj + REAL(DFP), INTENT(IN) :: points(:, :) + END FUNCTION quad_Constructor1 +END INTERFACE QuadraturePoint + +!---------------------------------------------------------------------------- +! QuadraturePoint_Pointer@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns a pointer to a newly created instance of quadrature points + +INTERFACE QuadraturePoint_Pointer + MODULE PURE FUNCTION quad_Constructor_1(points) RESULT(obj) + CLASS(QuadraturePoint_), POINTER :: obj + REAL(DFP), INTENT(IN) :: points(:, :) + END FUNCTION quad_Constructor_1 +END INTERFACE QuadraturePoint_Pointer + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Deallocates the data stored inside the quadrature point + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE quad_Deallocate(obj) + CLASS(QuadraturePoint_), INTENT(INOUT) :: obj + END SUBROUTINE quad_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! SIZE@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine returns the size of obj%points, + +INTERFACE SIZE + MODULE PURE FUNCTION quad_Size(obj, dims) RESULT(ans) + CLASS(QuadraturePoint_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: dims + INTEGER(I4B) :: ans + END FUNCTION quad_Size +END INTERFACE SIZE + +!---------------------------------------------------------------------------- +! getTotalQuadraturepoints@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine returns total number of quadrature points + +INTERFACE GetTotalQuadraturepoints + MODULE PURE FUNCTION quad_getTotalQuadraturepoints(obj, dims) RESULT(ans) + CLASS(QuadraturePoint_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: dims + INTEGER(I4B) :: ans + END FUNCTION quad_getTotalQuadraturepoints +END INTERFACE GetTotalQuadraturepoints + +!---------------------------------------------------------------------------- +! GetQuadraturePoint@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine returns quadrature points + +INTERFACE + MODULE PURE SUBROUTINE quad_GetQuadraturepoints1(obj, points, weights, num) + CLASS(QuadraturePoint_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: points(3) + !! [xi, eta, zeta] + REAL(DFP), INTENT(INOUT) :: weights + !! weights + INTEGER(I4B), INTENT(IN) :: num + !! quadrature number + END SUBROUTINE quad_GetQuadraturepoints1 +END INTERFACE + +INTERFACE GetQuadraturepoints + MODULE PROCEDURE quad_GetQuadraturepoints1 +END INTERFACE + +!---------------------------------------------------------------------------- +! GetQuadraturePoint@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: This routine returns total number of quadrature points + +INTERFACE + MODULE PURE SUBROUTINE quad_GetQuadraturepoints2(obj, points, weights) + CLASS(QuadraturePoint_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: points(:, :) + !! Point( :, j ) = [xi, eta, zeta] of jth quadrature point + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: weights(:) + !! Weight(j) weight of jth quadrature point + END SUBROUTINE quad_GetQuadraturepoints2 +END INTERFACE + +INTERFACE GetQuadraturepoints + MODULE PROCEDURE quad_GetQuadraturepoints2 +END INTERFACE + +!---------------------------------------------------------------------------- +! OuterProd@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2022 +! summary: Performs outerproduct of quadrature points + +INTERFACE Outerprod + MODULE PURE FUNCTION quad_Outerprod(obj1, obj2) RESULT(ans) + CLASS(QuadraturePoint_), INTENT(IN) :: obj1 + !! quadrature points in 1D + CLASS(QuadraturePoint_), INTENT(IN) :: obj2 + !! quadrature points in 1D + TYPE(QuadraturePoint_) :: ans + !! quadrature points in 2D + END FUNCTION quad_Outerprod +END INTERFACE Outerprod + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Display the content of quadrature point + +INTERFACE Display + MODULE SUBROUTINE quad_Display(obj, msg, unitno) + CLASS(QuadraturePoint_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno + END SUBROUTINE quad_Display +END INTERFACE Display + +!---------------------------------------------------------------------------- +! MdEncode@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Display the content of quadrature point + +INTERFACE MdEncode + MODULE FUNCTION QuadraturePoint_MdEncode(obj) RESULT(ans) + CLASS(QuadraturePoint_), INTENT(IN) :: obj + TYPE(String) :: ans + END FUNCTION QuadraturePoint_MdEncode +END INTERFACE MdEncode + +!---------------------------------------------------------------------------- +! GaussLegendreQuadrature@GaussLegendre +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss Legendre Quadrature points based on given order + +! INTERFACE GaussLegendreQuadrature +! MODULE FUNCTION getGaussLegendreQP1(refelem, order) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: order +! !! order of accuracy in each direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreQP1 +! END INTERFACE GaussLegendreQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreQuadrature@GaussLegendre +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss-Legendre Quadrature points + +! INTERFACE GaussLegendreQuadrature +! MODULE FUNCTION getGaussLegendreQP2(refelem, nips) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: nips(:) +! !! number of integration points +! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn +! !! IF size(nips) = 2, then in x1 direction nips(1) points and in +! !! x2 direction nips(2) points are used. +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreQP2 +! END INTERFACE GaussLegendreQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreQuadrature@GaussLegendre +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss Legendre Quadrature points based on given order + +! INTERFACE GaussLegendreQuadrature +! MODULE FUNCTION getGaussLegendreQP3(refelem, p, q, r) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: p +! !! order of accuracy in x1 direction +! INTEGER(I4B), INTENT(IN) :: q +! !! order of accuracy in x2 direction +! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r +! !! order of accuracy in x3 direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreQP3 +! END INTERFACE GaussLegendreQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreLobattoQuadrature@GaussLegendreLobatto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss LegendreLobatto Quadrature points + +! INTERFACE GaussLegendreLobattoQuadrature +! MODULE FUNCTION getGaussLegendreLobattoQP1(refelem, order) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: order +! !! order of accuracy in each direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreLobattoQP1 +! END INTERFACE GaussLegendreLobattoQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreLobattoQuadrature@GaussLegendreLobatto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss-LegendreLobatto Quadrature points + +! INTERFACE GaussLegendreLobattoQuadrature +! MODULE FUNCTION getGaussLegendreLobattoQP2(refelem, nips) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: nips(:) +! !! number of integration points +! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn +! !! IF size(nips) = 2, then in x1 direction nips(1) points and in +! !! x2 direction nips(2) points are used. +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreLobattoQP2 +! END INTERFACE GaussLegendreLobattoQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreLobattoQuadrature@GaussLegendreLobatto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss LegendreLobatto Quadrature points + +! INTERFACE GaussLegendreLobattoQuadrature +! MODULE FUNCTION getGaussLegendreLobattoQP3(refelem, p, q, r) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: p +! !! order of accuracy in x1 direction +! INTEGER(I4B), INTENT(IN) :: q +! !! order of accuracy in x2 direction +! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r +! !! order of accuracy in x3 direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreLobattoQP3 +! END INTERFACE GaussLegendreLobattoQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreRadauLeftQuadrature@GaussLegendreRadauLeft +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the LegendreRadauLeft Quadrature points + +! INTERFACE GaussLegendreRadauLeftQuadrature +! MODULE FUNCTION getGaussLegendreRadauLeftQP1(refelem, order) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: order +! !! order of accuracy in each direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreRadauLeftQP1 +! END INTERFACE GaussLegendreRadauLeftQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreRadauLeftQuadrature@GaussLegendreRadauLeft +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss-LegendreRadauLeft Quadrature points + +! INTERFACE GaussLegendreRadauLeftQuadrature +! MODULE FUNCTION getGaussLegendreRadauLeftQP2(refelem, nips) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: nips(:) +! !! number of integration points +! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn +! !! IF size(nips) = 2, then in x1 direction nips(1) points and in +! !! x2 direction nips(2) points are used. +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreRadauLeftQP2 +! END INTERFACE GaussLegendreRadauLeftQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreRadauLeftQuadrature@GaussLegendreRadauLeft +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss LegendreRadauLeft Quadrature points + +! INTERFACE GaussLegendreRadauLeftQuadrature +! MODULE FUNCTION getGaussLegendreRadauLeftQP3(refelem, p, q, r) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: p +! !! order of accuracy in x1 direction +! INTEGER(I4B), INTENT(IN) :: q +! !! order of accuracy in x2 direction +! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r +! !! order of accuracy in x3 direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreRadauLeftQP3 +! END INTERFACE GaussLegendreRadauLeftQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreRadauRightQuadrature@GaussLegendreRadauRight +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the LegendreRadauRight Quadrature points + +! INTERFACE GaussLegendreRadauRightQuadrature +! MODULE FUNCTION getGaussLegendreRadauRightQP1(refelem, order) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: order +! !! order of accuracy in each direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreRadauRightQP1 +! END INTERFACE GaussLegendreRadauRightQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreRadauRightQuadrature@GaussLegendreRadauRight +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss-LegendreRadauRight Quadrature points + +! INTERFACE GaussLegendreRadauRightQuadrature +! MODULE FUNCTION getGaussLegendreRadauRightQP2(refelem, nips) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: nips(:) +! !! number of integration points +! !! IF size(nips) = 1, then sqrt(nips(1)) points are used in both dirn +! !! IF size(nips) = 2, then in x1 direction nips(1) points and in +! !! x2 direction nips(2) points are used. +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreRadauRightQP2 +! END INTERFACE GaussLegendreRadauRightQuadrature + +!---------------------------------------------------------------------------- +! GaussLegendreRadauRightQuadrature@GaussLegendreRadauRight +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2021 +! summary: Returns the Gauss LegendreRadauRight Quadrature points + +! INTERFACE GaussLegendreRadauRightQuadrature +! MODULE FUNCTION getGaussLegendreRadauRightQP3(refelem, p, q, r) RESULT(obj) +! CLASS(ReferenceElement_), INTENT(IN) :: refelem +! INTEGER(I4B), INTENT(IN) :: p +! !! order of accuracy in x1 direction +! INTEGER(I4B), INTENT(IN) :: q +! !! order of accuracy in x2 direction +! INTEGER(I4B), OPTIONAL, INTENT(IN) :: r +! !! order of accuracy in x3 direction +! TYPE(QuadraturePoint_) :: obj +! END FUNCTION getGaussLegendreRadauRightQP3 +! END INTERFACE GaussLegendreRadauRightQuadrature + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE QuadraturePoint_Method diff --git a/src/modules/Random/CMakeLists.txt b/src/modules/Random/CMakeLists.txt new file mode 100644 index 000000000..43b65ce44 --- /dev/null +++ b/src/modules/Random/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/Random_Method.F90 +) \ No newline at end of file diff --git a/src/modules/Random/src/Random_Method.F90 b/src/modules/Random/src/Random_Method.F90 new file mode 100644 index 000000000..c1bc307e0 --- /dev/null +++ b/src/modules/Random/src/Random_Method.F90 @@ -0,0 +1,338 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 Random_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE initRandom(obj) + CLASS(Random_), INTENT(INOUT) :: obj + END SUBROUTINE initRandom +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE initRandom +END INTERFACE Initiate + +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! getRandom +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION getRandom(obj, distribution) RESULT(Ans) + CLASS(Random_), INTENT(IN) :: obj + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: distribution + REAL(DFP) :: Ans + END FUNCTION getRandom +END INTERFACE + +INTERFACE RandomValue + MODULE PROCEDURE getRandom +END INTERFACE RandomValue + +PUBLIC :: RandomValue + +!---------------------------------------------------------------------------- +! SaveRandom +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE SaveRandom(obj) + CLASS(Random_), INTENT(INOUT) :: obj + END SUBROUTINE SaveRandom +END INTERFACE + +PUBLIC :: SaveRandom + +!---------------------------------------------------------------------------- +! UniformRandom +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION uniformRandom(obj, From, To) RESULT(Ans) + CLASS(Random_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: From, To + REAL(DFP) :: Ans + END FUNCTION uniformRandom +END INTERFACE + +PUBLIC :: uniformRandom + +INTERFACE RandomValue + MODULE PROCEDURE uniformRandom +END INTERFACE RandomValue + +!---------------------------------------------------------------------------- +! RandomInteger +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION getRandomInteger(obj, From, To) RESULT(Ans) + CLASS(Random_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: From, To + INTEGER(I4B) :: Ans + END FUNCTION getRandomInteger +END INTERFACE + +INTERFACE RandomValue + MODULE PROCEDURE getRandomInteger +END INTERFACE RandomValue + +!---------------------------------------------------------------------------- +! RandomValue +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION select_random_int_from_vec(obj, Val) RESULT(Ans) + CLASS(Random_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Val(:) + INTEGER(I4B) :: Ans + END FUNCTION select_random_int_from_vec +END INTERFACE + +INTERFACE + MODULE FUNCTION select_random_int_from_array(obj, Val) RESULT(Ans) + CLASS(Random_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: Val(:, :) + INTEGER(I4B) :: Ans + END FUNCTION select_random_int_from_array +END INTERFACE + +INTERFACE + MODULE FUNCTION select_random_real_from_vec(obj, Val) RESULT(Ans) + CLASS(Random_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + REAL(DFP) :: Ans + END FUNCTION select_random_real_from_vec +END INTERFACE + +INTERFACE + MODULE FUNCTION select_random_real_from_array(obj, Val) RESULT(Ans) + CLASS(Random_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :) + REAL(DFP) :: Ans + END FUNCTION select_random_real_from_array +END INTERFACE + +INTERFACE RandomValue + MODULE PROCEDURE select_random_int_from_vec, select_random_int_from_array,& + & select_random_real_from_vec, select_random_real_from_array +END INTERFACE RandomValue + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: a unit pseudorandom real vector +! +!# Introduction +! +! This subroutine is taken from rvec_uniform_01 of John Burkardt +! +! An rvec is a vector of real ( kind = 8 ) values. +! +! For now, the input quantity SEED is an integer ( kind = 4 ) variable. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the vector. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which +! should NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. + +INTERFACE + MODULE PURE FUNCTION rvec_uniform_01(n, seed) RESULT(r) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + REAL(DFP) :: r(n) + END FUNCTION rvec_uniform_01 +END INTERFACE + +PUBLIC :: rvec_uniform_01 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: returns a scaled pseudorandom rvec + +INTERFACE + MODULE PURE FUNCTION rvec_uniform_ab(n, a, b, seed) RESULT(r) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: a + REAL(DFP), INTENT(IN) :: b + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + REAL(DFP) :: r(n) + END FUNCTION rvec_uniform_ab +END INTERFACE + +PUBLIC :: rvec_uniform_ab + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: returns a uniformly random unit vector + +INTERFACE + MODULE PURE FUNCTION rvec_uniform_unit(m, seed) RESULT(w) + INTEGER(I4B), INTENT(IN) :: m + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + REAL(DFP) :: w(m) + END FUNCTION rvec_uniform_unit +END INTERFACE + +PUBLIC :: rvec_uniform_unit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary:Samples the unit normal probability distribution. +! +!# Introduction +! +! The standard normal probability distribution function (PDF) has +! mean 0 and standard deviation 1. +! +! This routine can generate a vector of values on one call. It +! has the feature that it should provide the same results +! in the same order no matter how we break up the task. +! +! The Box-Muller method is used, which is efficient, but +! generates an even number of values each time. On any call +! to this routine, an even number of new values are generated. +! Depending on the situation, one value may be left over. +! In that case, it is saved for the next call. + +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of values desired. If N is +! negative, then the code will flush its internal memory; in particular, +! if there is a saved value to be used on the next call, it is +! instead discarded. This is useful if the user has reset the +! random number seed, for instance. +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. +! +! Local parameters: +! +! Local, integer MADE, records the number of values that have +! been computed. On input with negative N, this value overwrites +! the return value of N, so the user can get an accounting of +! how much work has been done. +! +! Local, real ( kind = 8 ) R(N+1), is used to store some uniform +! random values. Its dimension is N+1, but really it is only needed +! to be the smallest even number greater than or equal to N. +! +! Local, integer SAVED, is 0 or 1 depending on whether there is a +! single saved value left over from the previous call. +! +! Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of +! X that we need to compute. This starts off as 1:N, but is adjusted +! if we have a saved value that can be immediately stored in X(1), +! and so on. +! +! Local, real ( kind = 8 ) Y, the value saved from the previous call, if +! SAVED is 1. + +INTERFACE + MODULE PURE FUNCTION rvec_normal_01(n, seed) RESULT(x) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + REAL(DFP) :: x(n) + END FUNCTION rvec_normal_01 +END INTERFACE + +PUBLIC :: rvec_normal_01 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: returns a unit pseudorandom +! +!# Introduction +! +! An R8 is a real ( kind = 8 ) value. +! +! For now, the input quantity SEED is an integer ( kind = 4 ) variable. +! +! This routine implements the recursion +! +! seed = 16807 * seed mod ( 2^31 - 1 ) +! r8_uniform_01 = seed / ( 2^31 - 1 ) +! +! The integer arithmetic never requires more than 32 bits, +! including a sign bit. +! +! If the initial seed is 12345, then the first three computations are +! +! Input Output R8_UNIFORM_01 +! SEED SEED +! +! 12345 207482415 0.096616 +! 207482415 1790989824 0.833995 +! 1790989824 2035175616 0.947702 +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should +! NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate, +! strictly between 0 and 1. + +INTERFACE + MODULE PURE FUNCTION r8_uniform_01(seed) RESULT(ans) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + REAL(DFP) :: ans + END FUNCTION r8_uniform_01 +END INTERFACE + +PUBLIC :: r8_uniform_01 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE Random_Method diff --git a/src/modules/Rank2Tensor/CMakeLists.txt b/src/modules/Rank2Tensor/CMakeLists.txt new file mode 100644 index 000000000..f4482d3ae --- /dev/null +++ b/src/modules/Rank2Tensor/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/Rank2Tensor_Method.F90 +) \ No newline at end of file diff --git a/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 b/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 new file mode 100644 index 000000000..57d03e9da --- /dev/null +++ b/src/modules/Rank2Tensor/src/Rank2Tensor_Method.F90 @@ -0,0 +1,1719 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 10 March 2021 +! summary: This module contains method for [[Rank2Tensor_]] + +MODULE Rank2Tensor_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! initiate@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: Initiates [[Rank2Tensor_]] from another [[Rank2Tensor_]] +! +!# Introduction +! Initiates [[Rank2Tensor_]] from another [[Rank2Tensor_]] +! +!@note +! This routine also used in assignment(=) operator +!@endnote + +INTERFACE +MODULE PURE SUBROUTINE init_by_rank2( obj, obj2 ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 +END SUBROUTINE init_by_rank2 +END INTERFACE + +!---------------------------------------------------------------------------- +! initiate@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: Initiates [[Rank2Tensor_]] from a matrix +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat(3,3) +! call random_number( mat ) +! call display( mat, "mat=") +! call initiate( obj, mat ) +! call display( obj, "test1: ") +! call initiate( obj, sym(mat), .true.) +! call display( obj, "test2: ") +!``` + +INTERFACE +MODULE PURE SUBROUTINE init_by_mat( obj, Mat, isSym ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isSym +END SUBROUTINE init_by_mat +END INTERFACE + +!---------------------------------------------------------------------------- +! initiate@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: Initiates [[Rank2Tensor_]] from a [[VoigtRank2Tensor_]]. +! +!@note +! This subroutine is part of Assignment(=) operator. +!@endnote +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: v( 6 ) +! call random_number(v) +! call display( v, "v: ", orient="row" ) +! call Initiate( obj, VoigtRank2Tensor( v, VoigtType=StressTypeVoigt ) ) +! call display( obj, "obj: ") +!``` + +INTERFACE +MODULE PURE SUBROUTINE init_by_voigt( obj, V ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: V +END SUBROUTINE init_by_voigt +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: Initiates [[VoigtRank2Tensor_]] from a [[Rank2Tensor_]] + +INTERFACE +MODULE PURE SUBROUTINE init_voigt_from_r2tensor( obj, T, VoigtType ) + CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: T + INTEGER( I4B ), INTENT( IN ) :: VoigtType +END SUBROUTINE init_voigt_from_r2tensor +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE init_by_rank2, init_by_mat, init_by_voigt, & + & init_voigt_from_r2tensor +END INTERFACE Initiate + +PUBLIC :: Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE init_by_rank2 +END INTERFACE ASSIGNMENT(=) + +PUBLIC :: ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Rank2Tensor@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: This function returns an instance of [[Rank2Tensor_]] +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat(3,3) +! call random_number( mat ) +! call display( mat, "test3: mat=") +! obj = Rank2Tensor( mat ) +! call display( obj, "test3: obj=") +! obj = Rank2Tensor( sym(mat), .true.) +! call display( obj, "test3: obj=") +!``` + +INTERFACE +MODULE PURE FUNCTION r2t_by_mat( Mat, isSym ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) + TYPE( Rank2Tensor_ ) :: Ans + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isSym +END FUNCTION r2t_by_mat +END INTERFACE + +!---------------------------------------------------------------------------- +! Rank2Tensor@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: This function returns an instance of [[Rank2Tensor_]] +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: v(6) +! call random_number( v ) +! call display( v, "test4 mat=") +! obj = Rank2Tensor( VoigtRank2Tensor(v, VoigtType=StressTypeVoigt) ) +! call display( obj, "test4 obj=") +!``` + +INTERFACE +MODULE PURE FUNCTION r2t_by_voigt( V ) RESULT( Ans ) + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: V + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION r2t_by_voigt +END INTERFACE + +INTERFACE Rank2Tensor + MODULE PROCEDURE r2t_by_mat, r2t_by_voigt +END INTERFACE Rank2Tensor + +PUBLIC :: Rank2Tensor + +!---------------------------------------------------------------------------- +! Rank2Tensor_Pointer@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: returns the pointer to an newly created instance of [[Rank2Tensor_]]. +! +!### Usage +! +!```fortran +! class( Rank2Tensor_ ), pointer :: obj +! real( dfp ) :: mat(3,3) +! call random_number( mat ) +! call display( mat, "test5: mat=") +! obj => Rank2Tensor_Pointer( mat ) +! call display( obj, "test5: obj=") +! obj => Rank2Tensor_Pointer( sym(mat), .true.) +! call display( obj, "test5: obj=") +!``` + +INTERFACE +MODULE PURE FUNCTION ptr_r2t_by_mat( Mat, isSym ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) + CLASS( Rank2Tensor_ ), POINTER :: Ans + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isSym +END FUNCTION ptr_r2t_by_mat +END INTERFACE + +!---------------------------------------------------------------------------- +! Rank2Tensor@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: returns a pointer to a newly created instance of [[Rank2Tensor_]] +! +!### Usage +! +!```fortran +! class( Rank2Tensor_ ), pointer :: obj +! real( dfp ) :: v(6) +! call random_number( v ) +! call display( v, "test6: mat=") +! obj => Rank2Tensor_Pointer( VoigtRank2Tensor(v, VoigtType=StressTypeVoigt)) +! call display( obj, "test6: obj=") +!``` + +INTERFACE +MODULE PURE FUNCTION ptr_r2t_by_voigt( V ) RESULT( Ans ) + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: V + CLASS( Rank2Tensor_ ), POINTER :: Ans +END FUNCTION ptr_r2t_by_voigt +END INTERFACE + +INTERFACE Rank2Tensor_Pointer + MODULE PROCEDURE ptr_r2t_by_mat, ptr_r2t_by_voigt +END INTERFACE Rank2Tensor_Pointer + +PUBLIC :: Rank2Tensor_Pointer + +!---------------------------------------------------------------------------- +! Assignment@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: [[Rank2Tensor_]] = Matrix(3,3) +! +!@note +! This SUBROUTINE will create an unsymmetric tensor +!@endnote +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number(mat) +! obj = mat +! call display( obj, "test7: obj=") +!``` + +INTERFACE +MODULE PURE SUBROUTINE r2tensor_eq_mat( obj, Mat ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( 3, 3 ) +END SUBROUTINE r2tensor_eq_mat +END INTERFACE + +!---------------------------------------------------------------------------- +! Assignment@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: Matrix(3,3) = [[Rank2Tensor_]] +! +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number(mat) +! obj = mat +! call display( obj, "test7: obj=") +! mat = 0.0; mat = obj +! call display( mat, "test7: mat=") +!``` + +INTERFACE +MODULE PURE SUBROUTINE mat_eq_r2tensor( Mat, obj ) + REAL( DFP ), INTENT( INOUT ) :: Mat( 3, 3 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj +END SUBROUTINE mat_eq_r2tensor +END INTERFACE + +!---------------------------------------------------------------------------- +! Assignment@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: This routine returns a [[VoigtRank2Tensor_]] from [[Rank2Tensor_2]] +! +!@note +! The `VoigtType` will be `StressTypeVoigt`. +!@endnote +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! type( VoigtRank2Tensor_ ) :: v +! real( dfp ) :: mat( 3, 3 ) +! call random_number(mat) +! obj = mat +! call display( obj, "test8: obj=") +! v = obj +! call display( v, "test8: v=") +!``` + +INTERFACE +MODULE PURE SUBROUTINE voigt_eq_r2tensor( V, obj ) + CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: V + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj +END SUBROUTINE voigt_eq_r2tensor +END INTERFACE + +INTERFACE ASSIGNMENT( = ) + MODULE PROCEDURE r2tensor_eq_mat, mat_eq_r2tensor, init_by_voigt, & + & voigt_eq_r2tensor +END INTERFACE + +!---------------------------------------------------------------------------- +! IdentityTensor@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the rank2 identity tensor +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! call IdentityTensor(obj) +! call display( obj, "test9: IdentityTensor=") +! call Ones(obj) +! call display( obj, "test9: Ones=") +! call Zeros(obj) +! call display( obj, "test9: Zeros=") +! call IsotropicTensor(obj, 2.0_DFP) +! call display( obj, "test9: Isotropic=") +!``` +INTERFACE +MODULE PURE SUBROUTINE identity_rank2( obj ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj +END SUBROUTINE identity_rank2 +END INTERFACE + +INTERFACE IdentityTensor + MODULE PROCEDURE identity_rank2 +END INTERFACE IdentityTensor + +PUBLIC :: IdentityTensor + +!---------------------------------------------------------------------------- +! getOnesTensor@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns a second order tensor with all entry one + +INTERFACE +MODULE PURE SUBROUTINE rank2_getOnes( obj ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj +END SUBROUTINE rank2_getOnes +END INTERFACE + +INTERFACE getOnes + MODULE PROCEDURE rank2_getOnes +END INTERFACE getOnes + +PUBLIC :: getOnes + +!---------------------------------------------------------------------------- +! ZerosTensor@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns a zero second order tensor +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! call IdentityTensor(obj) +! call display( obj, "test9: IdentityTensor=") +! call Ones(obj) +! call display( obj, "test9: Ones=") +! call Zeros(obj) +! call display( obj, "test9: Zeros=") +! call IsotropicTensor(obj, 2.0_DFP) +! call display( obj, "test9: Isotropic=") +!``` + +INTERFACE +MODULE PURE SUBROUTINE rank2_getZeros( obj ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj +END SUBROUTINE rank2_getZeros +END INTERFACE + +INTERFACE getZeros + MODULE PROCEDURE rank2_getZeros +END INTERFACE getZeros + +PUBLIC :: getZeros + +!---------------------------------------------------------------------------- +! IsotropicTensor@constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: returns a second order isotropic tensor +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! call IdentityTensor(obj) +! call display( obj, "test9: IdentityTensor=") +! call Ones(obj) +! call display( obj, "test9: Ones=") +! call Zeros(obj) +! call display( obj, "test9: Zeros=") +! call IsotropicTensor(obj, 2.0_DFP) +! call display( obj, "test9: Isotropic=") +!``` + +INTERFACE +MODULE PURE SUBROUTINE isotropic_rank2( obj, Lambda ) + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Lambda +END SUBROUTINE isotropic_rank2 +END INTERFACE + +INTERFACE IsotropicTensor + MODULE PROCEDURE isotropic_rank2 +END INTERFACE IsotropicTensor + +PUBLIC :: IsotropicTensor + +!---------------------------------------------------------------------------- +! isSym@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Returns true if symmetric + +INTERFACE +MODULE PURE FUNCTION isSym_rank2( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + LOGICAL( LGT ) :: Ans +END FUNCTION isSym_rank2 +END INTERFACE + +INTERFACE isSym + MODULE PROCEDURE isSym_rank2 +END INTERFACE isSym + +PUBLIC :: isSym + +!---------------------------------------------------------------------------- +! isDeviatoric@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Returns true of deviatoric tensor + +INTERFACE +MODULE PURE FUNCTION isDeviatoric_rank2( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + LOGICAL( LGT ) :: Ans +END FUNCTION isDeviatoric_rank2 +END INTERFACE + +INTERFACE isDeviatoric + MODULE PROCEDURE isDeviatoric_rank2 +END INTERFACE isDeviatoric + +PUBLIC :: isDeviatoric + +!---------------------------------------------------------------------------- +! DeformationGradient@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns pointer to a newly created instance of [[DeformationGradient_]] + +INTERFACE +MODULE PURE FUNCTION F_constructor1( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: obj + TYPE( DeformationGradient_ ) :: Ans +END FUNCTION F_constructor1 +END INTERFACE + +INTERFACE DeformationGradient + MODULE PROCEDURE F_constructor1 +END INTERFACE DeformationGradient + +PUBLIC :: DeformationGradient + +!---------------------------------------------------------------------------- +! DeformationGradient@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns pointer to a newly created instance of [[DeformationGradient_]] + +INTERFACE +MODULE PURE FUNCTION F_constructor_1( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: obj + CLASS( DeformationGradient_ ), POINTER :: Ans +END FUNCTION F_constructor_1 +END INTERFACE + +INTERFACE DeformationGradient_Pointer + MODULE PROCEDURE F_constructor_1 +END INTERFACE DeformationGradient_Pointer + +PUBLIC :: DeformationGradient_Pointer + +!---------------------------------------------------------------------------- +! LeftCauchyGreen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns pointer to a newly created instance of [[LeftCauchyGreen_]] + +INTERFACE +MODULE PURE FUNCTION b_constructor1( F, V ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: V + TYPE( LeftCauchyGreen_ ) :: Ans +END FUNCTION b_constructor1 +END INTERFACE + +INTERFACE LeftCauchyGreen + MODULE PROCEDURE b_constructor1 +END INTERFACE LeftCauchyGreen + +PUBLIC :: LeftCauchyGreen + +!---------------------------------------------------------------------------- +! LeftCauchyGreen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns pointer to a newly created instance of [[LeftCauchyGreen_]] + +INTERFACE +MODULE PURE FUNCTION b_constructor_1( F, V ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: V + CLASS( LeftCauchyGreen_ ), POINTER :: Ans +END FUNCTION b_constructor_1 +END INTERFACE + +INTERFACE LeftCauchyGreen_Pointer + MODULE PROCEDURE b_constructor_1 +END INTERFACE LeftCauchyGreen_Pointer + +PUBLIC :: LeftCauchyGreen_Pointer + +!---------------------------------------------------------------------------- +! RightCauchyGreen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns pointer to a newly created instance of [[RightCauchyGreen_]] + +INTERFACE +MODULE PURE FUNCTION C_constructor1( F, U ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: U + TYPE( RightCauchyGreen_ ) :: Ans +END FUNCTION C_constructor1 +END INTERFACE + +INTERFACE RightCauchyGreen + MODULE PROCEDURE C_constructor1 +END INTERFACE RightCauchyGreen + +PUBLIC :: RightCauchyGreen + +!---------------------------------------------------------------------------- +! RightCauchyGreen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns pointer to a newly created instance of [[RightCauchyGreen_]] + +INTERFACE +MODULE PURE FUNCTION C_constructor_1( F, U ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: F + CLASS( Rank2Tensor_ ), OPTIONAL, INTENT( IN ) :: U + CLASS( RightCauchyGreen_ ), POINTER :: Ans +END FUNCTION C_constructor_1 +END INTERFACE + +INTERFACE RightCauchyGreen_Pointer + MODULE PROCEDURE C_constructor_1 +END INTERFACE RightCauchyGreen_Pointer + +PUBLIC :: RightCauchyGreen_Pointer + +!---------------------------------------------------------------------------- +! INV@Operation +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE SUBROUTINE inv_rank2( obj, Invobj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: Invobj +END SUBROUTINE inv_rank2 +END INTERFACE + +INTERFACE INV + MODULE PROCEDURE inv_rank2 +END INTERFACE INV + +PUBLIC :: INV + +!---------------------------------------------------------------------------- +! Transpose@Operation +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Transpose of a tensor + +INTERFACE +MODULE PURE FUNCTION obj_transpose( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_transpose +END INTERFACE + +INTERFACE TRANSPOSE + MODULE PROCEDURE obj_transpose +END INTERFACE TRANSPOSE + +PUBLIC :: TRANSPOSE + +!---------------------------------------------------------------------------- +! Sym@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the symmetric part of a rank2 tensor +! +!# Introduction +! Returns the symmetric part of the tensor +! +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = mat +! obj = sym(obj) +!``` + +INTERFACE +MODULE PURE FUNCTION sym_r2t( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION sym_r2t +END INTERFACE + +INTERFACE Sym + MODULE PROCEDURE sym_r2t +END INTERFACE Sym + +PUBLIC :: Sym + +!---------------------------------------------------------------------------- +! SkewSym@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the skew symmetric part of the tensor +! +!# Introduction +! Returns the skew symmetric part of the tensor. +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = mat +! obj = SkewSym(obj) +!``` + +INTERFACE +MODULE PURE FUNCTION Skewsym_r2t( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION Skewsym_r2t +END INTERFACE + +INTERFACE SkewSym + MODULE PROCEDURE Skewsym_r2t +END INTERFACE SkewSym + +PUBLIC :: SkewSym + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Display the content of [[Rank2Tensor_]] + +INTERFACE +MODULE SUBROUTINE display_obj( obj, Msg, UnitNo ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Msg + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo +END SUBROUTINE display_obj +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE display_obj +END INTERFACE Display + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! Trace@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns trace of a tensor +! +!# Introduction +! Trace of a tensor is given by +! $$Tr(A) = A_{ii}$$ +! Trace of $A^2$ is given by +! $$Tr(A^2) = A:A^T$$ +! Trace of A^3 is given by +! $$Tr(A^3) = A^2 : A^T$$ +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = sym(mat) +! call display( trace(obj), "test10: trace(obj)=" ) +!``` + +INTERFACE +MODULE PURE FUNCTION trace_obj( obj, Power ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: Power + REAL( DFP ) :: Ans +END FUNCTION trace_obj +END INTERFACE + +INTERFACE Trace + MODULE PROCEDURE trace_obj +END INTERFACE Trace + +PUBLIC :: Trace + +!---------------------------------------------------------------------------- +! J2@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns J2 invariant of tensor +! +!# Introduction +! $J_2$ is given by +! $$J_{2}\left( A\right) =\frac{1}{2} tr\left( dev^{2}\left( A\right) \right)$$ +! +!@note +! if `isDeviatoric` logical flag is false then the function calculates the $J_2$ using the components of the tensor $A$. +!@endnote +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = sym(mat) +! call display( J2(obj), "test10: trace(obj)=" ) +!``` + +INTERFACE +MODULE PURE FUNCTION j2_obj( obj, isDeviatoric ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric + REAL( DFP ) :: Ans +END FUNCTION j2_obj +END INTERFACE + +INTERFACE J2 + MODULE PROCEDURE j2_obj +END INTERFACE J2 + +PUBLIC :: J2 + +!---------------------------------------------------------------------------- +! J3@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns J3 invarinat of a tensor +! +!# Introduction +! $J_3$ is an invariant of a tensor, which is given by +! +! $$J_{3}\left( A\right) =Det\left( Dev\left( A\right) \right)$$ +! +!@note +! If the tensor is not a Deviatoric tensor the this function calculates the Deviatoric part of the tensor to determine $J_3$ +!@endnote +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = sym(mat) +! call display( J3(obj), "test10: trace(obj)=" ) +!``` + +INTERFACE +MODULE PURE FUNCTION j3_obj( obj, isDeviatoric ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric + REAL( DFP ) :: Ans +END FUNCTION j3_obj +END INTERFACE + +INTERFACE J3 + MODULE PROCEDURE j3_obj +END INTERFACE J3 + +PUBLIC :: J3 + +!---------------------------------------------------------------------------- +! Det@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the Determinant of a tensor +! +!# Introduction +! This function returns the Determinant of a tensor. +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = sym(mat) +! call display( Det(obj), "test10: trace(obj)=" ) +!``` + +INTERFACE +MODULE PURE FUNCTION det_obj( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ) :: Ans +END FUNCTION det_obj +END INTERFACE + +INTERFACE Det + MODULE PROCEDURE Det_obj +END INTERFACE Det + +PUBLIC :: Det + +!---------------------------------------------------------------------------- +! LodeAngle@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns lode angle +! +!# Introduction +! This function calculates the Lode angle $\theta$ from the invariants $J_2$ and $J_3$, which is given by: +! +!$$ cos3\theta =\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ +!$$ sin3\theta =-\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ +! +! As mentioned above, Lode angle can be described in two ways; Sine and Cosine. This can be specified by defining the input parameter `LodeType` which can be `SineLode` and `CosineLode` +! +!@note +! This subroutine is called by [[theta_obj]]. +!@endnote +! + +INTERFACE +MODULE PURE FUNCTION theta_obj_j2j3( LodeType, J2, J3 ) RESULT( Ans ) + INTEGER( I4B ), INTENT( IN ) :: LodeType + REAL( DFP ), INTENT( IN ) :: J2, J3 + REAL( DFP ) :: Ans +END FUNCTION theta_obj_j2j3 +END INTERFACE + +!---------------------------------------------------------------------------- +! LodeAngle@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the Lode angle +! +!# Introduction +! +! This function returns the lode angle. +! Lode angle can be described using two ways. Sin and Cosine. This can be selected by using the input parameter `LodeType` which can be `SineLode` and `CosineLode` +! +!$$ cos3\theta =\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ +!$$ sin3\theta =-\frac{3\sqrt{3} J_{3}}{2J_{2}\sqrt{J_{2}}} $$ +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = sym(mat) +! call display( LodeAngle(obj, LodeType=CosineLode, isDeviatoric=.FALSE.), "test10: trace(obj)=" ) +!``` + +INTERFACE +MODULE PURE FUNCTION theta_obj( obj, LodeType, isDeviatoric ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: LodeType + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric + REAL( DFP ) :: Ans +END FUNCTION theta_obj +END INTERFACE + +INTERFACE LodeAngle + MODULE PROCEDURE theta_obj, theta_obj_j2j3 +END INTERFACE LodeAngle + +PUBLIC :: LodeAngle + +!---------------------------------------------------------------------------- +! IsotropicPart@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the isotropic part of the tensor +! +!# Introduction +! This function returns the isotropic part of a tensor, which is given by +! $$Isotropic(obj) = \frac{1}{3} Trace(obj)$$ +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ) +! call random_number( mat ) +! obj = mat +! obj = Isotropic(obj) +!``` + +INTERFACE +MODULE PURE FUNCTION iso_part_obj( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION iso_part_obj +END INTERFACE + +INTERFACE Isotropic + MODULE PROCEDURE iso_part_obj +END INTERFACE Isotropic + +PUBLIC :: Isotropic + +INTERFACE Iso + MODULE PROCEDURE iso_part_obj +END INTERFACE Iso + +PUBLIC :: Iso + +!---------------------------------------------------------------------------- +! DeviatoricPart@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the Deviatoric part of the tensor +! +!# Introduction +!This function returns the Deviatoric part of the tensor, which is given by +! +! $$Dev(T) = T - Iso(T)$$ + +INTERFACE +MODULE PURE FUNCTION dev_part_obj( obj ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION dev_part_obj +END INTERFACE + +INTERFACE Deviatoric + MODULE PROCEDURE dev_part_obj +END INTERFACE Deviatoric + +PUBLIC :: Deviatoric + +INTERFACE Dev + MODULE PROCEDURE dev_part_obj +END INTERFACE Dev + +PUBLIC :: Dev + +!---------------------------------------------------------------------------- +! Invariants@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns invariant of [[Rank2Tensor_]] +! +!# Introduction +! +! This function returns the invariant of [[Rank2Tensor_]]. +! If the tensor is not a Deviatoric tensor then following invariants are returned: +! +! $$I_1 = Tr(T)$$ +! $$I_2 = \frac{1}{2}(Tr^2(T) - Tr(A^2))$$ +! $$I_3 = det(T)$$ +! +! If the tensor is a Deviatoric tensor then following invariants are returned +! $$I_1 = 0.0$$ +! $$I_2 = \frac{1}{2} Tr(A^2)$$ +! $$I_3 = det(T)$$ +! +!### Usage +! +!```fortran +! +!``` + +INTERFACE +MODULE PURE FUNCTION invariants_rank2( obj, isDeviatoric ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isDeviatoric + REAL( DFP ) :: Ans( 3 ) +END FUNCTION invariants_rank2 +END INTERFACE + +INTERFACE Invariants + MODULE PROCEDURE invariants_rank2 +END INTERFACE Invariants + +PUBLIC :: Invariants + +!---------------------------------------------------------------------------- +! Eigen@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the eigen vector and eigen value of the tensor. +! +!# Introduction +! This subroutine returns the eigen values and eigen vectors of a tensor. +! If the tensor is symmetric then the eigenvalues and eigenvectors are real +! and `QI` and `WI` are not required. However, if the tensor is not symmetric +! then `QI` and `WI` contain the imaginary part of the eigenvalues and +! eigenvectors. +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj +! real( dfp ) :: mat( 3, 3 ), QR( 3, 3 ), WR( 3 ), QI( 3, 3 ), WI( 3 ) +! mat = 0.0 +! mat(1,1) = 5.0 +! mat(2:3, 2) = [-6, -12] +! mat(2:3, 3) = [-12, 1] +! call initiate( obj, mat, isSym=.true.) +! call Eigen( obj, QR, WR ) +! call BlankLines(unitNo=stdout, NOL=2) +! call display( obj, 'test12: obj=') +! call display( Invariants(obj), "test12: Invariants=" ) +! call display( QR, "test12: QR=") +! call display( WR, "test12: WR=") +!``` + +INTERFACE +MODULE SUBROUTINE eigen_r2t( obj, QR, WR, QI, WI ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( INOUT ) :: QR( 3, 3 ), WR( 3 ) + REAL( DFP ), OPTIONAL, INTENT( INOUT ) :: QI( 3, 3 ), WI( 3 ) +END SUBROUTINE eigen_r2t +END INTERFACE + +INTERFACE Eigen + MODULE PROCEDURE eigen_r2t +END INTERFACE Eigen + +PUBLIC :: Eigen + +!---------------------------------------------------------------------------- +! PolarDecomp@InvarMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: This subroutine provides polar decomposition of a tensor. +! +!# Introduction +! This subroutine provides right polar decomposition of a tensor, which is +! given by +! +! $$T=RU$$ +! +!### Usage +! +!```fortran +! type( Rank2Tensor_ ) :: obj, R, U, V +! real( dfp ) :: mat( 3, 3 ) = reshape( [1.0, -0.333, 0.959, 0.495, 1.0, 0.0, 0.5, -0.247, 1.5], [3,3] ) +! call initiate( obj, mat, isSym=.false. ) +! call PolarDecomp( obj, R, U, V ) +!``` + +INTERFACE +MODULE SUBROUTINE pd_r2t( obj, R, U, V ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: R + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: U + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: V +END SUBROUTINE pd_r2t +END INTERFACE + +INTERFACE PolarDecomp + MODULE PROCEDURE pd_r2t +END INTERFACE PolarDecomp + +PUBLIC :: PolarDecomp + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the contraction of tensor + +INTERFACE +MODULE PURE FUNCTION r2_contract_r2( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1, obj2 + REAL( DFP ) :: Ans +END FUNCTION r2_contract_r2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns the contraction of a rank2 tensor and voigt rank2 tensor + +INTERFACE +MODULE PURE FUNCTION r2_contract_voigt_r2( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj2 + REAL( DFP ) :: Ans +END FUNCTION r2_contract_voigt_r2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns contraction of aa voigt rank2 tensor and rank2 tensor + +INTERFACE +MODULE PURE FUNCTION voigt_r2_contract_r2( obj1, obj2 ) RESULT( Ans ) + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + REAL( DFP ) :: Ans +END FUNCTION voigt_r2_contract_r2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 March 2021 +! summary: Returns contraction of two voigt rank tensor + +INTERFACE +MODULE PURE FUNCTION voigt_r2_contract_voigt_r2( obj1, obj2 ) RESULT( Ans ) + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj2 + REAL( DFP ) :: Ans +END FUNCTION voigt_r2_contract_voigt_r2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +INTERFACE Contraction + MODULE PROCEDURE & + & r2_contract_r2, & + & r2_contract_voigt_r2, & + & voigt_r2_contract_r2, & + & voigt_r2_contract_voigt_r2 +END INTERFACE Contraction + +PUBLIC :: Contraction + +!---------------------------------------------------------------------------- +! +@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Addition of two tensor +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a+b, "test14: a+b=") + ! call display( a+1.0_DFP, "test14: a+1=") + ! call display( 1.0_DFP + a, "test14: 1+a=") +!``` + +INTERFACE +MODULE PURE FUNCTION obj_add_obj( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_add_obj +END INTERFACE + +!---------------------------------------------------------------------------- +! +@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Addition of tensor and scalar +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a+b, "test14: a+b=") + ! call display( a+1.0_DFP, "test14: a+1=") + ! call display( 1.0_DFP + a, "test14: 1+a=") +!``` + +INTERFACE +MODULE PURE FUNCTION obj_add_scalar( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + REAL( DFP ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_add_scalar +END INTERFACE + +!---------------------------------------------------------------------------- +! +@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Addition of tensor and scalar +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a+b, "test14: a+b=") + ! call display( a+1.0_DFP, "test14: a+1=") + ! call display( 1.0_DFP + a, "test14: 1+a=") +!``` + +INTERFACE +MODULE PURE FUNCTION scalar_add_obj( obj1, obj2 ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION scalar_add_obj +END INTERFACE + +INTERFACE OPERATOR( + ) + MODULE PROCEDURE obj_add_obj, obj_add_scalar, scalar_add_obj +END INTERFACE + +PUBLIC :: OPERATOR( + ) + +!---------------------------------------------------------------------------- +! -@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Subtraction of tensor and tensor +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a-b, "test14: a+b=") + ! call display( a-1.0_DFP, "test14: a+1=") + ! call display( 1.0_DFP - a, "test14: 1+a=") +!``` + +INTERFACE +MODULE PURE FUNCTION obj_minus_obj( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_minus_obj +END INTERFACE + +!---------------------------------------------------------------------------- +! -@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Subtraction of tensor and scalar +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a-b, "test14: a-b=") + ! call display( a-1.0_DFP, "test14: a-1=") + ! call display( 1.0_DFP - a, "test14: 1-a=") +!``` + +INTERFACE +MODULE PURE FUNCTION obj_minus_scalar( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + REAL( DFP ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_minus_scalar +END INTERFACE + +!---------------------------------------------------------------------------- +! -@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Subtraction of tensor and scalar +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a-b, "test14: a-b=") + ! call display( a-1.0_DFP, "test14: a-1=") + ! call display( 1.0_DFP - a, "test14: 1-a=") +!``` + +INTERFACE +MODULE PURE FUNCTION scalar_minus_obj( obj1, obj2 ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION scalar_minus_obj +END INTERFACE + +INTERFACE OPERATOR( - ) + MODULE PROCEDURE obj_minus_obj, & + & obj_minus_scalar, scalar_minus_obj +END INTERFACE + +PUBLIC :: OPERATOR( - ) + +!---------------------------------------------------------------------------- +! *@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: rank2 tensor times rank 2 tensor +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a*b, "test14: a*b=") + ! call display( a*1.0_DFP, "test14: a*1=") + ! call display( 1.0_DFP * a, "test14: 1*a=") +!``` + +INTERFACE +MODULE PURE FUNCTION obj_times_obj( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_times_obj +END INTERFACE + +!---------------------------------------------------------------------------- +! *@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: rank2 tensor times scalar +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a*b, "test14: a*b=") + ! call display( a*1.0_DFP, "test14: a*1=") + ! call display( 1.0_DFP * a, "test14: 1*a=") +!``` + +INTERFACE +MODULE PURE FUNCTION obj_times_scalar( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + REAL( DFP ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_times_scalar +END INTERFACE + +!---------------------------------------------------------------------------- +! *@Operator +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: rank2 tensor times scalar +! +!### Usage +! +!```fortran + ! type( Rank2Tensor_ ) :: a, b + ! real( dfp ) :: mat( 3, 3 ) + ! call random_number( mat ) + ! a = mat + ! call random_number( mat ) + ! b = mat + ! call display( a*b, "test14: a*b=") + ! call display( a*1.0_DFP, "test14: a*1=") + ! call display( 1.0_DFP * a, "test14: 1*a=") +!``` + +INTERFACE +MODULE PURE FUNCTION scalar_times_obj( obj1, obj2 ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION scalar_times_obj +END INTERFACE + +INTERFACE OPERATOR( * ) + MODULE PROCEDURE obj_times_obj, obj_times_scalar, scalar_times_obj +END INTERFACE OPERATOR( * ) + +PUBLIC :: OPERATOR( * ) + +!---------------------------------------------------------------------------- +! /@Operator +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION obj_div_obj( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_div_obj +END INTERFACE + +!---------------------------------------------------------------------------- +! /@Operator +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION obj_div_scalar( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + REAL( DFP ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_div_scalar +END INTERFACE + +!---------------------------------------------------------------------------- +! /@Operator +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION scalar_div_obj( obj1, obj2 ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION scalar_div_obj +END INTERFACE + +INTERFACE OPERATOR( / ) + MODULE PROCEDURE obj_div_obj, obj_div_scalar, scalar_div_obj +END INTERFACE OPERATOR( / ) + +PUBLIC :: OPERATOR( / ) + +!---------------------------------------------------------------------------- +! MATMUL@Operator +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION obj_matmul_obj( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION obj_matmul_obj +END INTERFACE + +!---------------------------------------------------------------------------- +! MATMUL@Operator +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION obj_matmul_vec( obj1, obj2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj1 + REAL( DFP ), INTENT( IN ) :: obj2( 3 ) + REAL( DFP ) :: Ans( 3 ) +END FUNCTION obj_matmul_vec +END INTERFACE + +!---------------------------------------------------------------------------- +! MATMUL@Operator +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION vec_matmul_obj( obj1, obj2 ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: obj1( 3 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj2 + REAL( DFP ) :: Ans( 3 ) +END FUNCTION vec_matmul_obj +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE obj_matmul_obj, obj_matmul_vec, vec_matmul_obj +END INTERFACE MATMUL + +PUBLIC :: MATMUL + +!---------------------------------------------------------------------------- +! Pullback@Pullback +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION pullback_rank2( T, F, indx1, indx2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: T + CLASS( Rank2Tensor_ ), INTENT( IN ) :: F + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION pullback_rank2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Pullback@Pullback +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION pullback_vec( Vec, F, indx1 ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: Vec( 3 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: F + CHARACTER( LEN = * ), INTENT( IN ) :: indx1 + REAL( DFP ) :: Ans( 3 ) +END FUNCTION pullback_vec +END INTERFACE + +INTERFACE PULLBACK + MODULE PROCEDURE pullback_rank2, pullback_vec +END INTERFACE PULLBACK + +PUBLIC :: PULLBACK + +!---------------------------------------------------------------------------- +! PushForward@Pushforward +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION pushforward_rank2( T, F, indx1, indx2 ) RESULT( Ans ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: T + CLASS( Rank2Tensor_ ), INTENT( IN ) :: F + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + TYPE( Rank2Tensor_ ) :: Ans +END FUNCTION pushforward_rank2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Pushforward@Pushforward +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION pushforward_vec( Vec, F, indx1 ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: Vec( 3 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: F + CHARACTER( LEN = * ), INTENT( IN ) :: indx1 + REAL( DFP ) :: Ans( 3 ) +END FUNCTION pushforward_vec +END INTERFACE + +INTERFACE PushForward + MODULE PROCEDURE pushforward_rank2, pushforward_vec +END INTERFACE PushForward + +PUBLIC :: PushForward + +!---------------------------------------------------------------------------- +! D +!---------------------------------------------------------------------------- +END MODULE Rank2Tensor_Method diff --git a/src/modules/RaylibInterface/CMakeLists.txt b/src/modules/RaylibInterface/CMakeLists.txt new file mode 100644 index 000000000..8eac1981e --- /dev/null +++ b/src/modules/RaylibInterface/CMakeLists.txt @@ -0,0 +1,38 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +if(USE_RAYLIB) + set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/RaylibTypes.F90 + ${src_path}/RaylibEnums.F90 + ${src_path}/RaylibDrawMethods.F90 + ${src_path}/RaylibGetMethods.F90 + ${src_path}/RaylibSetMethods.F90 + ${src_path}/RaylibImageMethods.F90 + ${src_path}/RaylibUnloadMethods.F90 + ${src_path}/RaylibLoadMethods.F90 + ${src_path}/RaylibIsMethods.F90 + ${src_path}/RaylibCheckMethods.F90 + ${src_path}/RaylibGenMethods.F90 + ${src_path}/RaylibMethods.F90 + ${src_path}/Raylib.F90 + ${src_path}/RaylibCamera.F90 + ${src_path}/RaylibMath.F90 + ${src_path}/RaylibUtil.F90) +endif() diff --git a/src/modules/RaylibInterface/src/Raylib.F90 b/src/modules/RaylibInterface/src/Raylib.F90 new file mode 100644 index 000000000..d0af8a22a --- /dev/null +++ b/src/modules/RaylibInterface/src/Raylib.F90 @@ -0,0 +1,22 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE Raylib +USE RaylibTypes +USE RaylibEnums +USE RaylibDrawMethods +USE RaylibGetMethods +USE RaylibSetMethods +USE RaylibImageMethods +USE RaylibUnloadMethods +USE RaylibLoadMethods +USE RaylibGenMethods +USE RaylibIsMethods +USE RaylibCheckMethods +USE RaylibMethods +END MODULE Raylib diff --git a/src/modules/RaylibInterface/src/RaylibCamera.F90 b/src/modules/RaylibInterface/src/RaylibCamera.F90 new file mode 100644 index 000000000..c2dc752aa --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibCamera.F90 @@ -0,0 +1,130 @@ +! raylib_camera.f90 +! +! Additional camera routines for raylib 4.5, from `rcamera.h`. +! +! Author: Philipp Engel +! Licence: ISC +MODULE raylib_camera +USE, INTRINSIC :: ISO_C_BINDING +USE :: raylib +IMPLICIT NONE(TYPE, EXTERNAL) +PRIVATE + +PUBLIC :: camera_move_forward +PUBLIC :: camera_move_right +PUBLIC :: camera_move_to_target +PUBLIC :: camera_move_up +PUBLIC :: camera_pitch +PUBLIC :: camera_roll +PUBLIC :: camera_yaw +PUBLIC :: get_camera_forward +PUBLIC :: get_camera_projection_matrix +PUBLIC :: get_camera_right +PUBLIC :: get_camera_up +PUBLIC :: get_camera_view_matrix + +INTERFACE + ! void CameraMoveForward(Camera *camera, float distance, bool moveInWorldPlane) + subroutine camera_move_forward(camera, distance, move_in_world_plane) bind(c, name='CameraMoveForward') + IMPORT :: C_BOOL, C_FLOAT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: distance + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: move_in_world_plane + END SUBROUTINE camera_move_forward + + ! void CameraMoveRight(Camera *camera, float distance, bool moveInWorldPlane) + subroutine camera_move_right(camera, distance, move_in_world_plane) bind(c, name='CameraMoveRight') + IMPORT :: C_BOOL, C_FLOAT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: distance + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: move_in_world_plane + END SUBROUTINE camera_move_right + + ! void CameraMoveToTarget(Camera *camera, float delta) + subroutine camera_move_to_target(camera, delta) bind(c, name='CameraMoveToTarget') + IMPORT :: C_FLOAT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: delta + END SUBROUTINE camera_move_to_target + + ! void CameraMoveUp(Camera *camera, float distance) + SUBROUTINE camera_move_up(camera, distance) BIND(c, name='CameraMoveUp') + IMPORT :: C_FLOAT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: distance + END SUBROUTINE camera_move_up + + ! void CameraPitch(Camera *camera, float angle, bool lockView, bool rotateAroundTarget, bool rotateUp) + subroutine camera_pitch(camera, angle, lock_view, rotate_around_target, rotate_up) bind(c, name='CameraPitch') + IMPORT :: C_BOOL, C_FLOAT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: lock_view + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: rotate_around_target + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: rotate_up + END SUBROUTINE camera_pitch + + ! void CameraRoll(Camera *camera, float angle) + SUBROUTINE camera_roll(camera, angle) BIND(c, name='CameraRoll') + IMPORT :: C_FLOAT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + END SUBROUTINE camera_roll + + ! void CameraYaw(Camera *camera, float angle, bool rotateAroundTarget) + subroutine camera_yaw(camera, angle, rotate_around_target) bind(c, name='CameraYaw') + IMPORT :: C_BOOL, C_FLOAT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: rotate_around_target + END SUBROUTINE camera_yaw + + ! Vector3 GetCameraForward(Camera *camera) + FUNCTION get_camera_forward(camera) BIND(c, name='GetCameraForward') + IMPORT :: camera3d_, vector3_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + TYPE(vector3_) :: get_camera_forward + END FUNCTION get_camera_forward + + ! Matrix GetCameraProjectionMatrix(Camera* camera, float aspect) + function get_camera_projection_matrix(camera, aspect) bind(c, name='GetCameraProjectionMatrix') + IMPORT :: C_FLOAT, camera3d_, matrix_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + REAL(kind=C_FLOAT), INTENT(in), VALUE :: aspect + TYPE(matrix_) :: get_camera_projection_matrix + END FUNCTION get_camera_projection_matrix + + ! Vector3 GetCameraRight(Camera *camera) + FUNCTION get_camera_right(camera) BIND(c, name='GetCameraRight') + IMPORT :: camera3d_, vector3_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + TYPE(vector3_) :: get_camera_right + END FUNCTION get_camera_right + + ! Vector3 GetCameraUp(Camera *camera) + FUNCTION get_camera_up(camera) BIND(c, name='GetCameraUp') + IMPORT :: camera3d_, vector3_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + TYPE(vector3_) :: get_camera_up + END FUNCTION get_camera_up + + ! Matrix GetCameraViewMatrix(Camera *camera) + FUNCTION get_camera_view_matrix(camera) BIND(c, name='GetCameraViewMatrix') + IMPORT :: camera3d_, matrix_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + TYPE(matrix_) :: get_camera_view_matrix + END FUNCTION get_camera_view_matrix +END INTERFACE +END MODULE raylib_camera diff --git a/src/modules/RaylibInterface/src/RaylibCheckMethods.F90 b/src/modules/RaylibInterface/src/RaylibCheckMethods.F90 new file mode 100644 index 000000000..fc3708a4c --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibCheckMethods.F90 @@ -0,0 +1,157 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibCheckMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: CheckCollisionSpheres +PUBLIC :: CheckCollisionRecs +PUBLIC :: CheckCollisionPointTriangle +PUBLIC :: CheckCollisionPointRec +PUBLIC :: CheckCollisionPointPoly +PUBLIC :: CheckCollisionPointLine +PUBLIC :: CheckCollisionPointCircle +PUBLIC :: CheckCollisionLines +PUBLIC :: CheckCollisionCircles +PUBLIC :: CheckCollisionCircleRec +PUBLIC :: CheckCollisionBoxes +PUBLIC :: CheckCollisionBoxSphere + +INTERFACE + ! bool CheckCollisionBoxSphere(BoundingBox box, Vector3 center, float radius) + FUNCTION CheckCollisionBoxSphere(box, center, radius) BIND(c, & + name='CheckCollisionBoxSphere') + IMPORT :: bounding_box_, C_BOOL, C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(bounding_box_), INTENT(in), VALUE :: box + TYPE(vector3_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + LOGICAL(kind=C_BOOL) :: CheckCollisionBoxSphere + END FUNCTION CheckCollisionBoxSphere + + ! bool CheckCollisionBoxes(BoundingBox box1, BoundingBox box2) + FUNCTION CheckCollisionBoxes(box1, box2) BIND(c, name='CheckCollisionBoxes') + IMPORT :: bounding_box_, C_BOOL + IMPLICIT NONE + TYPE(bounding_box_), INTENT(in), VALUE :: box1 + TYPE(bounding_box_), INTENT(in), VALUE :: box2 + LOGICAL(kind=C_BOOL) :: CheckCollisionBoxes + END FUNCTION CheckCollisionBoxes + + ! bool CheckCollisionCircleRec(Vector2 center, float radius, Rectangle rec) + FUNCTION CheckCollisionCircleRec(center, radius, rec) BIND(c, & + name='CheckCollisionCircleRec') + IMPORT :: C_BOOL, C_FLOAT, rectangle_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(rectangle_), INTENT(in), VALUE :: rec + LOGICAL(kind=C_BOOL) :: CheckCollisionCircleRec + END FUNCTION CheckCollisionCircleRec + + ! bool CheckCollisionCircles(Vector2 center1, float radius1, Vector2 center2, float radius2) + function CheckCollisionCircles(center1, radius1, center2, radius2) bind(c, name='CheckCollisionCircles') + IMPORT :: C_BOOL, C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center1 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius1 + TYPE(vector2_), INTENT(in), VALUE :: center2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius2 + LOGICAL(kind=C_BOOL) :: CheckCollisionCircles + END FUNCTION CheckCollisionCircles + + ! bool CheckCollisionLines(Vector2 startPos1, Vector2 endPos1, Vector2 startPos2, Vector2 endPos2, Vector2 *collisionPoint) + function CheckCollisionLines(start_pos1, end_pos1, start_pos2, end_pos2, collision_point) & + BIND(c, name='CheckCollisionLines') + IMPORT :: C_BOOL, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: start_pos1 + TYPE(vector2_), INTENT(in), VALUE :: end_pos1 + TYPE(vector2_), INTENT(in), VALUE :: start_pos2 + TYPE(vector2_), INTENT(in), VALUE :: end_pos2 + TYPE(vector2_), INTENT(out) :: collision_point + LOGICAL(kind=C_BOOL) :: CheckCollisionLines + END FUNCTION CheckCollisionLines + + ! bool CheckCollisionPointCircle(Vector2 point, Vector2 center, float radius) + function CheckCollisionPointCircle(point, center, radius) bind(c, name='CheckCollisionPointCircle') + IMPORT :: C_BOOL, C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: point + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + LOGICAL(kind=C_BOOL) :: CheckCollisionPointCircle + END FUNCTION CheckCollisionPointCircle + + ! bool CheckCollisionPointLine(Vector2 point, Vector2 p1, Vector2 p2, int threshold) + function CheckCollisionPointLine(point, p1, p2, threshold) bind(c, name='CheckCollisionPointLine') + IMPORT :: C_BOOL, C_INT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: point + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: p2 + INTEGER(kind=C_INT), INTENT(in), VALUE :: threshold + LOGICAL(kind=C_BOOL) :: CheckCollisionPointLine + END FUNCTION CheckCollisionPointLine + + ! bool CheckCollisionPointPoly(Vector2 point, Vector2 *points, int pointCount) + function CheckCollisionPointPoly(point, points, point_count) bind(c, name='CheckCollisionPointPoly') + IMPORT :: C_BOOL, C_INT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: point + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + LOGICAL(kind=C_BOOL) :: CheckCollisionPointPoly + END FUNCTION CheckCollisionPointPoly + + ! bool CheckCollisionPointRec(Vector2 point, Rectangle rec) + function CheckCollisionPointRec(point, rec) bind(c, name='CheckCollisionPointRec') + IMPORT :: C_BOOL, rectangle_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: point + TYPE(rectangle_), INTENT(in), VALUE :: rec + LOGICAL(kind=C_BOOL) :: CheckCollisionPointRec + END FUNCTION CheckCollisionPointRec + + ! bool CheckCollisionPointTriangle(Vector2 point, Vector2 p1, Vector2 p2, Vector2 p3) + function CheckCollisionPointTriangle(point, p1, p2, p3) bind(c, name='CheckCollisionPointTriangle') + IMPORT :: C_BOOL, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: point + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: p2 + TYPE(vector2_), INTENT(in), VALUE :: p3 + LOGICAL(kind=C_BOOL) :: CheckCollisionPointTriangle + END FUNCTION CheckCollisionPointTriangle + + ! bool CheckCollisionRecs(Rectangle rec1, Rectangle rec2) + FUNCTION CheckCollisionRecs(rec1, rec2) BIND(c, name='CheckCollisionRecs') + IMPORT :: C_BOOL, rectangle_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec1 + TYPE(rectangle_), INTENT(in), VALUE :: rec2 + LOGICAL(kind=C_BOOL) :: CheckCollisionRecs + END FUNCTION CheckCollisionRecs + + ! bool CheckCollisionSpheres(Vector3 center1, float radius1, Vector3 center2, float radius2) + function CheckCollisionSpheres(center1, radius1, center2, radius2) bind(c, name='CheckCollisionSpheres') + IMPORT :: C_BOOL, C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: center1 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius1 + TYPE(vector3_), INTENT(in), VALUE :: center2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius2 + LOGICAL(kind=C_BOOL) :: CheckCollisionSpheres + END FUNCTION CheckCollisionSpheres +END INTERFACE + +END MODULE RaylibCheckMethods diff --git a/src/modules/RaylibInterface/src/RaylibDrawMethods.F90 b/src/modules/RaylibInterface/src/RaylibDrawMethods.F90 new file mode 100644 index 000000000..083c74579 --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibDrawMethods.F90 @@ -0,0 +1,1144 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibDrawMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: DrawBillboard +PUBLIC :: DrawBillboardPro +PUBLIC :: DrawBillboardRec +PUBLIC :: DrawBoundingBox +PUBLIC :: DrawCapsule +PUBLIC :: DrawCapsuleWires +PUBLIC :: DrawCircle3D +PUBLIC :: DrawCircleGradient +PUBLIC :: DrawCircleLinesV +PUBLIC :: DrawCircleLines +PUBLIC :: DrawCircleSectorLines +PUBLIC :: DrawCircleSector +PUBLIC :: DrawCircleV +PUBLIC :: DrawCircle + +PUBLIC :: DrawCubeWiresV +PUBLIC :: DrawCubeWires +PUBLIC :: DrawCubeV +PUBLIC :: DrawCube + +PUBLIC :: DrawCylinderWiresEx +PUBLIC :: DrawCylinderWires +PUBLIC :: DrawCylinderEx +PUBLIC :: DrawCylinder + +PUBLIC :: DrawEllipseLines +PUBLIC :: DrawEllipse + +PUBLIC :: DrawLineV +PUBLIC :: DrawLineStrip +PUBLIC :: DrawLineEx +PUBLIC :: DrawLineBezier +PUBLIC :: DrawLine3D +PUBLIC :: DrawLine +PUBLIC :: DrawGrid +PUBLIC :: DrawFPS + +PUBLIC :: DrawMeshInstanced +PUBLIC :: DrawMesh + +PUBLIC :: DrawModelWiresEx +PUBLIC :: DrawModelWires +PUBLIC :: DrawModelEx +PUBLIC :: DrawModel + +PUBLIC :: draw_pixel_v +PUBLIC :: draw_pixel + +PUBLIC :: DrawTriangleStrip +PUBLIC :: DrawTriangleLines +PUBLIC :: DrawTriangleFan +PUBLIC :: DrawTriangle3D +PUBLIC :: DrawTriangle + +PUBLIC :: DrawTextureV +PUBLIC :: DrawTextureRec +PUBLIC :: DrawTexturePro +PUBLIC :: DrawTextureNPatch +PUBLIC :: DrawTextureEx +PUBLIC :: DrawTexture + +PUBLIC :: DrawTextPro +PUBLIC :: DrawTextEx +PUBLIC :: DrawTextCodepoints +PUBLIC :: DrawTextCodepoint +PUBLIC :: DrawText +PUBLIC :: DrawSplineSegmentLinear +PUBLIC :: DrawSplineSegmentCatmullRom + +PUBLIC :: DrawSplineSegmentBezierQuadratic +PUBLIC :: DrawSplineSegmentBezierCubic +PUBLIC :: DrawSplineSegmentBasis +PUBLIC :: DrawSplineLinear +PUBLIC :: DrawSplineCatmullRom +PUBLIC :: DrawSplineBezierQuadratic +PUBLIC :: DrawSplineBezierCubic +PUBLIC :: DrawSplineBasis +PUBLIC :: DrawSphereWires +PUBLIC :: DrawSphereEx +PUBLIC :: DrawSphere +PUBLIC :: DrawRingLines +PUBLIC :: DrawRing + +PUBLIC :: DrawRectangleV +PUBLIC :: DrawRectangleRoundedLines +PUBLIC :: DrawRectangleRounded +PUBLIC :: DrawRectangleRec +PUBLIC :: DrawRectanglePro +PUBLIC :: DrawRectangleLinesEx +PUBLIC :: DrawRectangleLines +PUBLIC :: DrawRectangleGradientV +PUBLIC :: DrawRectangleGradientH +PUBLIC :: DrawRectangleGradientEx +PUBLIC :: DrawRectangle +PUBLIC :: DrawRay +PUBLIC :: DrawPolyLinesEx +PUBLIC :: DrawPolyLines +PUBLIC :: DrawPoly +PUBLIC :: DrawPoint3D +PUBLIC :: DrawPlane + +PUBLIC :: DrawTriangleStrip3D + +INTERFACE + +! void DrawBillboard(Camera camera, Texture2D texture, Vector3 position, float size, Color tint) + SUBROUTINE DrawBillboard(camera, texture, position, size, tint) & + BIND(c, name='DrawBillboard') + IMPORT :: C_FLOAT, camera3d_, color_, texture2d_, vector3_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(in), VALUE :: camera + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(vector3_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: size + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawBillboard + +! void DrawBillboardPro(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector3 up, Vector2 size, Vector2 origin, float rotation, Color tint) + SUBROUTINE DrawBillboardPro(camera, texture, source, position, up & + , size, origin, rotation, tint) & + BIND(c, name='DrawBillboardPro') + IMPORT :: C_FLOAT, camera3d_, color_, rectangle_, & + texture2d_, vector2_, vector3_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(in), VALUE :: camera + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(rectangle_), INTENT(in), VALUE :: source + TYPE(vector3_), INTENT(in), VALUE :: position + TYPE(vector3_), INTENT(in), VALUE :: up + TYPE(vector2_), INTENT(in), VALUE :: size + TYPE(vector2_), INTENT(in), VALUE :: origin + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawBillboardPro + +! void DrawBillboardRec(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector2 size, Color tint) + SUBROUTINE DrawBillboardRec(camera, texture, source, position, & + size, tint) BIND(c, name='DrawBillboardRec') + IMPORT :: camera3d_, color_, rectangle_, & + texture2d_, vector2_, vector3_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(in), VALUE :: camera + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(rectangle_), INTENT(in), VALUE :: source + TYPE(vector3_), INTENT(in), VALUE :: position + TYPE(vector2_), INTENT(in), VALUE :: size + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawBillboardRec + +! void DrawBoundingBox(BoundingBox box, Color color) + SUBROUTINE DrawBoundingBox(box, color) BIND(c, name='DrawBoundingBox') + IMPORT :: bounding_box_, color_ + IMPLICIT NONE + TYPE(bounding_box_), INTENT(in), VALUE :: box + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawBoundingBox + +! void DrawCapsule(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) + SUBROUTINE DrawCapsule(start_pos, end_pos, radius, slices, rings, & + color) BIND(c, name='DrawCapsule') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: start_pos + TYPE(vector3_), INTENT(in), VALUE :: end_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + INTEGER(kind=C_INT), INTENT(in), VALUE :: rings + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCapsule + +! void DrawCapsuleWires(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) + SUBROUTINE DrawCapsuleWires(start_pos, end_pos, radius, slices, & + rings, color) BIND(c, name='DrawCapsuleWires') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: start_pos + TYPE(vector3_), INTENT(in), VALUE :: end_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + INTEGER(kind=C_INT), INTENT(in), VALUE :: rings + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCapsuleWires + +! void DrawCircle(int centerX, int centerY, float radius, Color color) + subroutine DrawCircle(center_x, center_y, radius, color) bind(c, name='DrawCircle') + IMPORT :: C_FLOAT, C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCircle + +! void DrawCircle3D(Vector3 center, float radius, Vector3 rotationAxis, float rotationAngle, Color color) + SUBROUTINE DrawCircle3D(center, radius, rotation_axis, & + rotation_angle, color) BIND(c, name='DrawCircle3D') + IMPORT :: C_FLOAT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(vector3_), INTENT(in), VALUE :: rotation_axis + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation_angle + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCircle3D + +! void DrawCircleGradient(int centerX, int centerY, float radius, Color color1, Color color2) + SUBROUTINE DrawCircleGradient(center_x, center_y, radius, color1, & + color2) BIND(c, name='DrawCircleGradient') + IMPORT :: C_FLOAT, C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color1 + TYPE(color_), INTENT(in), VALUE :: color2 + END SUBROUTINE DrawCircleGradient + +! void DrawCircleLines(int centerX, int centerY, float radius, Color color) + SUBROUTINE DrawCircleLines(center_x, center_y, radius, color) BIND & + (c, name='DrawCircleLines') + IMPORT :: C_FLOAT, C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCircleLines + +! void DrawCircleLinesV(Vector2 center, float radius, Color color) + SUBROUTINE DrawCircleLinesV(center, radius, color) BIND(c, name='DrawCircleLinesV') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCircleLinesV + +! void DrawCircleSector(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) + SUBROUTINE DrawCircleSector(center, radius, start_angle, end_angle & + , segments, color) & + BIND(c, name='DrawCircleSector') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle + REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle + INTEGER(kind=C_INT), INTENT(in), VALUE :: segments + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCircleSector + +! void DrawCircleSectorLines(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) + SUBROUTINE DrawCircleSectorLines(center, radius, start_angle, & + end_angle, segments, color) & + BIND(c, name='DrawCircleSectorLines') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle + REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle + INTEGER(kind=C_INT), INTENT(in), VALUE :: segments + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCircleSectorLines + +! void DrawCircleV(Vector2 center, float radius, Color color) + SUBROUTINE DrawCircleV(center, radius, color) BIND(c, name='DrawCircleV') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCircleV + +! void DrawCube(Vector3 position, float width, float height, float length, Color color) + SUBROUTINE DrawCube(position, width, height, length, color) BIND(c & + , name='DrawCube') + IMPORT :: C_FLOAT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: width + REAL(kind=C_FLOAT), INTENT(in), VALUE :: height + REAL(kind=C_FLOAT), INTENT(in), VALUE :: length + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCube + +! void DrawCubeV(Vector3 position, Vector3 size, Color color) + SUBROUTINE DrawCubeV(position, size, color) BIND(c, name='DrawCubeV') + IMPORT :: color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: position + TYPE(vector3_), INTENT(in), VALUE :: size + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCubeV + +! void DrawCubeWires(Vector3 position, float width, float height, float length, Color color) + SUBROUTINE DrawCubeWires(position, width, height, length, color) & + BIND(c, name='DrawCubeWires') + IMPORT :: C_FLOAT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: width + REAL(kind=C_FLOAT), INTENT(in), VALUE :: height + REAL(kind=C_FLOAT), INTENT(in), VALUE :: length + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCubeWires + +! void DrawCubeWiresV(Vector3 position, Vector3 size, Color color) + SUBROUTINE DrawCubeWiresV(position, size, color) BIND(c, name='DrawCubeWiresV') + IMPORT :: color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: position + TYPE(vector3_), INTENT(in), VALUE :: size + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCubeWiresV + +! void DrawCylinder(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) + SUBROUTINE DrawCylinder(position, radius_top, radius_bottom, height & + , slices, color) BIND(c, name='DrawCylinder') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_top + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_bottom + REAL(kind=C_FLOAT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCylinder + +! void DrawCylinderEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) + SUBROUTINE DrawCylinderEx(start_pos, end_pos, start_radius, & + end_radius, sides, color) BIND(c, name='DrawCylinderEx') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: start_pos + TYPE(vector3_), INTENT(in), VALUE :: end_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCylinderEx + +! void DrawCylinderWires(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) + SUBROUTINE DrawCylinderWires(position, radius_top, radius_bottom, & + height, slices, color) & + BIND(c, name='DrawCylinderWires') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_top + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_bottom + REAL(kind=C_FLOAT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCylinderWires + +! void DrawCylinderWiresEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) + SUBROUTINE DrawCylinderWiresEx(start_pos, end_pos, start_radius, & + end_radius, sides, color) & + BIND(c, name='DrawCylinderWiresEx') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: start_pos + TYPE(vector3_), INTENT(in), VALUE :: end_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawCylinderWiresEx + +! void DrawEllipse(int centerX, int centerY, float radiusH, float radiusV, Color color) + SUBROUTINE DrawEllipse(center_x, center_y, radius_h, radius_v, & + color) BIND(c, name='DrawEllipse') + IMPORT :: C_FLOAT, C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_h + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_v + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawEllipse + +! void DrawEllipseLines(int centerX, int centerY, float radiusH, float radiusV, Color color) + SUBROUTINE DrawEllipseLines(center_x, center_y, radius_h, radius_v & + , color) BIND(c, name='DrawEllipseLines') + IMPORT :: C_FLOAT, C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_h + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius_v + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawEllipseLines + +! void DrawFPS(int posX, int posY) + SUBROUTINE DrawFPS(pos_x, pos_y) BIND(c, name='DrawFPS') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + END SUBROUTINE DrawFPS + +! void DrawGrid(int slices, float spacing) + SUBROUTINE DrawGrid(slices, spacing) BIND(c, name='DrawGrid') + IMPORT :: C_FLOAT, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing + END SUBROUTINE DrawGrid + +! void DrawLine(int startPosX, int startPosY, int endPosX, int endPosY, Color color) + SUBROUTINE DrawLine(start_pos_x, start_pos_y, end_pos_x, end_pos_y & + , color) BIND(c, name='DrawLine') + IMPORT :: C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_y + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawLine + +! void DrawLine3D(Vector3 startPos, Vector3 endPos, Color color) + SUBROUTINE DrawLine3D(start_pos, end_pos, color) BIND(c, name='DrawLine3D') + IMPORT :: color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: start_pos + TYPE(vector3_), INTENT(in), VALUE :: end_pos + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawLine3D + +! void DrawLineBezier(Vector2 startPos, Vector2 endPos, float thick, Color color) + SUBROUTINE DrawLineBezier(start_pos, end_pos, thick, color) BIND(c & + , name='DrawLineBezier') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: start_pos + TYPE(vector2_), INTENT(in), VALUE :: end_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawLineBezier + +! void DrawLineEx(Vector2 startPos, Vector2 endPos, float thick, Color color) + SUBROUTINE DrawLineEx(start_pos, end_pos, thick, color) BIND(c, & + name='DrawLineEx') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: start_pos + TYPE(vector2_), INTENT(in), VALUE :: end_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawLineEx + +! void DrawLineStrip(Vector2 *points, int pointCount, Color color) + SUBROUTINE DrawLineStrip(points, point_count, color) BIND(c, name='DrawLineStrip') + IMPORT :: C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawLineStrip + +! void DrawLineV(Vector2 startPos, Vector2 endPos, Color color) + SUBROUTINE DrawLineV(start_pos, end_pos, color) BIND(c, name='DrawLineV') + IMPORT :: color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: start_pos + TYPE(vector2_), INTENT(in), VALUE :: end_pos + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawLineV + +! void DrawMesh(Mesh mesh, Material material, Matrix transform) + SUBROUTINE DrawMesh(mesh, material, transform) BIND(c, name='DrawMesh') + IMPORT :: material_, matrix_, mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in), VALUE :: mesh + TYPE(material_), INTENT(in), VALUE :: material + TYPE(matrix_), INTENT(in), VALUE :: transform + END SUBROUTINE DrawMesh + +! void DrawMeshInstanced(Mesh mesh, Material material, const Matrix *transforms, int instances) + SUBROUTINE DrawMeshInstanced(mesh, material, transforms, instances & + ) BIND(c, name='DrawMeshInstanced') + IMPORT :: C_INT, material_, matrix_, mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in), VALUE :: mesh + TYPE(material_), INTENT(in), VALUE :: material + TYPE(matrix_), INTENT(inout) :: transforms + INTEGER(kind=C_INT), INTENT(in), VALUE :: instances + END SUBROUTINE DrawMeshInstanced + +! void DrawModel(Model model, Vector3 position, float scale, Color tint) + SUBROUTINE DrawModel(model, position, scale, tint) BIND(c, name='DrawModel') + IMPORT :: C_FLOAT, color_, model_, vector3_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + TYPE(vector3_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawModel + +! void DrawModelEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) + SUBROUTINE DrawModelEx(model, position, rotation_axis, & + rotation_angle, scale, tint) & + BIND(c, name='DrawModelEx') + IMPORT :: C_FLOAT, color_, model_, vector3_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + TYPE(vector3_), INTENT(in), VALUE :: position + TYPE(vector3_), INTENT(in), VALUE :: rotation_axis + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation_angle + TYPE(vector3_), INTENT(in), VALUE :: scale + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawModelEx + +! void DrawModelWires(Model model, Vector3 position, float scale, Color tint) + SUBROUTINE DrawModelWires(model, position, scale, tint) BIND(c, & + name='DrawModelWires') + IMPORT :: C_FLOAT, color_, model_, vector3_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + TYPE(vector3_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawModelWires + +! void DrawModelWiresEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) + SUBROUTINE DrawModelWiresEx(model, position, rotation_axis, & + rotation_angle, scale, tint) & + BIND(c, name='DrawModelWiresEx') + IMPORT :: C_FLOAT, color_, model_, vector3_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + TYPE(vector3_), INTENT(in), VALUE :: position + TYPE(vector3_), INTENT(in), VALUE :: rotation_axis + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation_angle + TYPE(vector3_), INTENT(in), VALUE :: scale + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawModelWiresEx + +! void DrawPixel(int posX, int posY, Color color) + SUBROUTINE draw_pixel(pos_x, pos_y, color) BIND(c, name='DrawPixel') + IMPORT :: C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE draw_pixel + +! void DrawPixelV(Vector2 position, Color color) + SUBROUTINE draw_pixel_v(position, color) BIND(c, name='DrawPixelV') + IMPORT :: color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE draw_pixel_v + +! void DrawPlane(Vector3 centerPos, Vector2 size, Color color) + SUBROUTINE DrawPlane(center_pos, size, color) BIND(c, name='DrawPlane') + IMPORT :: color_, vector2_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: center_pos + TYPE(vector2_), INTENT(in), VALUE :: size + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawPlane + +! void DrawPoint3D(Vector3 position, Color color) + SUBROUTINE DrawPoint3D(position, color) BIND(c, name='DrawPoint3D') + IMPORT :: color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: position + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawPoint3D + +! void DrawPoly(Vector2 center, int sides, float radius, float rotation, Color color) + SUBROUTINE DrawPoly(center, sides, radius, rotation, color) BIND(c & + , name='DrawPoly') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawPoly + +! void DrawPolyLines(Vector2 center, int sides, float radius, float rotation, Color color) + SUBROUTINE DrawPolyLines(center, sides, radius, rotation, color) & + BIND(c, name='DrawPolyLines') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawPolyLines + +! void DrawPolyLinesEx(Vector2 center, int sides, float radius, float rotation, float lineThick, Color color) + SUBROUTINE DrawPolyLinesEx(center, sides, radius, rotation, & + line_thick, color) & + BIND(c, name='DrawPolyLinesEx') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + REAL(kind=C_FLOAT), INTENT(in), VALUE :: line_thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawPolyLinesEx + +! void DrawRay(Ray ray, Color color) + SUBROUTINE DrawRay(ray, color) BIND(c, name='DrawRay') + IMPORT :: color_, ray_ + IMPLICIT NONE + TYPE(ray_), INTENT(in), VALUE :: ray + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRay + +! void DrawRectangle(int posX, int posY, int width, int height, Color color) + SUBROUTINE DrawRectangle(pos_x, pos_y, width, height, color) BIND(c & + , name='DrawRectangle') + IMPORT :: C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectangle + +! void DrawRectangleGradientEx(Rectangle rec, Color col1, Color col2, Color col3, Color col4) + SUBROUTINE DrawRectangleGradientEx(rec, col1, col2, col3, col4) & + BIND(c, name='DrawRectangleGradientEx') + IMPORT :: color_, rectangle_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec + TYPE(color_), INTENT(in), VALUE :: col1 + TYPE(color_), INTENT(in), VALUE :: col2 + TYPE(color_), INTENT(in), VALUE :: col3 + TYPE(color_), INTENT(in), VALUE :: col4 + END SUBROUTINE DrawRectangleGradientEx + +! void DrawRectangleGradientH(int posX, int posY, int width, int height, Color color1, Color color2) + SUBROUTINE DrawRectangleGradientH(pos_x, pos_y, width, height, & + color1, color2) & + BIND(c, name='DrawRectangleGradientH') + IMPORT :: C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(color_), INTENT(in), VALUE :: color1 + TYPE(color_), INTENT(in), VALUE :: color2 + END SUBROUTINE DrawRectangleGradientH + +! void DrawRectangleGradientV(int posX, int posY, int width, int height, Color color1, Color color2) + SUBROUTINE DrawRectangleGradientV(pos_x, pos_y, width, height, & + color1, color2) & + BIND(c, name='DrawRectangleGradientV') + IMPORT :: C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(color_), INTENT(in), VALUE :: color1 + TYPE(color_), INTENT(in), VALUE :: color2 + END SUBROUTINE DrawRectangleGradientV + +! void DrawRectangleLines(int posX, int posY, int width, int height, Color color) + SUBROUTINE DrawRectangleLines(pos_x, pos_y, width, height, color) & + BIND(c, name='DrawRectangleLines') + IMPORT :: C_INT, color_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectangleLines + +! void DrawRectangleLinesEx(Rectangle rec, float lineThick, Color color) + SUBROUTINE DrawRectangleLinesEx(rec, line_thick, color) BIND(c, & + name='DrawRectangleLinesEx') + IMPORT :: C_FLOAT, color_, rectangle_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec + REAL(kind=C_FLOAT), INTENT(in), VALUE :: line_thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectangleLinesEx + +! void DrawRectanglePro(Rectangle rec, Vector2 origin, float rotation, Color color) + SUBROUTINE DrawRectanglePro(rec, origin, rotation, color) BIND(c, & + name='DrawRectanglePro') + IMPORT :: C_FLOAT, color_, rectangle_, vector2_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec + TYPE(vector2_), INTENT(in), VALUE :: origin + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectanglePro + +! void DrawRectangleRec(Rectangle rec, Color color) + SUBROUTINE DrawRectangleRec(rec, color) BIND(c, name='DrawRectangleRec') + IMPORT :: color_, rectangle_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectangleRec + +! void DrawRectangleRounded(Rectangle rec, float roundness, int segments, Color color) + SUBROUTINE DrawRectangleRounded(rec, roundness, segments, color) & + BIND(c, name='DrawRectangleRounded') + IMPORT :: C_FLOAT, C_INT, color_, rectangle_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec + REAL(kind=C_FLOAT), INTENT(in), VALUE :: roundness + INTEGER(kind=C_INT), INTENT(in), VALUE :: segments + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectangleRounded + +! void DrawRectangleRoundedLines(Rectangle rec, float roundness, int segments, float lineThick, Color color) + SUBROUTINE DrawRectangleRoundedLines(rec, roundness, segments, & + line_thick, color) & + BIND(c, name='DrawRectangleRoundedLines') + IMPORT :: C_FLOAT, C_INT, color_, rectangle_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec + REAL(kind=C_FLOAT), INTENT(in), VALUE :: roundness + INTEGER(kind=C_INT), INTENT(in), VALUE :: segments + REAL(kind=C_FLOAT), INTENT(in), VALUE :: line_thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectangleRoundedLines + +! void DrawRectangleV(Vector2 position, Vector2 size, Color color) + SUBROUTINE DrawRectangleV(position, size, color) BIND(c, & + name='DrawRectangleV') + IMPORT :: color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(vector2_), INTENT(in), VALUE :: size + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRectangleV + +! void DrawRing(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) + SUBROUTINE DrawRing(center, inner_radius, outer_radius, start_angle & + , end_angle, segments, color) & + BIND(c, name='DrawRing') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: inner_radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: outer_radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle + REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle + INTEGER(kind=C_INT), INTENT(in), VALUE :: segments + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRing + +! void DrawRingLines(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) + SUBROUTINE DrawRingLines(center, inner_radius, outer_radius, & + start_angle, end_angle, segments, color) & + BIND(c, name='DrawRingLines') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: inner_radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: outer_radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start_angle + REAL(kind=C_FLOAT), INTENT(in), VALUE :: end_angle + INTEGER(kind=C_INT), INTENT(in), VALUE :: segments + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawRingLines + +! void DrawSphere(Vector3 centerPos, float radius, Color color) + SUBROUTINE DrawSphere(center_pos, radius, color) BIND(c, name='DrawSphere') + IMPORT :: C_FLOAT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: center_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSphere + +! void DrawSphereEx(Vector3 centerPos, float radius, int rings, int slices, Color color) + SUBROUTINE DrawSphereEx(center_pos, radius, rings, slices, color) & + BIND(c, name='DrawSphereEx') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: center_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: rings + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSphereEx + +! void DrawSphereWires(Vector3 centerPos, float radius, int rings, int slices, Color color) + SUBROUTINE DrawSphereWires(center_pos, radius, rings, slices, & + color) BIND(c, name='DrawSphereWires') + IMPORT :: C_FLOAT, C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: center_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: rings + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSphereWires + +! void DrawSplineBasis(Vector2 *points, int pointCount, float thick, Color color) + SUBROUTINE DrawSplineBasis(points, point_count, thick, color) BIND & + (c, name='DrawSplineBasis') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineBasis + +! void DrawSplineBezierCubic(Vector2 *points, int pointCount, float thick, Color color) + SUBROUTINE DrawSplineBezierCubic(points, point_count, thick, & + color) BIND(c, name='DrawSplineBezierCubic') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineBezierCubic + +! void DrawSplineBezierQuadratic(Vector2 *points, int pointCount, float thick, Color color) + SUBROUTINE DrawSplineBezierQuadratic(points, point_count, thick, & + color) BIND(c, name='DrawSplineBezierQuadratic') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineBezierQuadratic + +! void DrawSplineCatmullRom(Vector2 *points, int pointCount, float thick, Color color) + SUBROUTINE DrawSplineCatmullRom(points, point_count, thick, color & + ) BIND(c, name='DrawSplineCatmullRom') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineCatmullRom + +! void DrawSplineLinear(Vector2 *points, int pointCount, float thick, Color color) + SUBROUTINE DrawSplineLinear(points, point_count, thick, color) & + BIND(c, name='DrawSplineLinear') + IMPORT :: C_FLOAT, C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineLinear + +! void DrawSplineSegmentBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) + SUBROUTINE DrawSplineSegmentBasis(p1, p2, p3, p4, thick, color) & + BIND(c, name='DrawSplineSegmentBasis') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: p2 + TYPE(vector2_), INTENT(in), VALUE :: p3 + TYPE(vector2_), INTENT(in), VALUE :: p4 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineSegmentBasis + +! void DrawSplineSegmentBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float thick, Color color) + SUBROUTINE DrawSplineSegmentBezierCubic(p1, c2, c3, p4, thick, & + color) BIND(c, name='DrawSplineSegmentBezierCubic') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: c2 + TYPE(vector2_), INTENT(in), VALUE :: c3 + TYPE(vector2_), INTENT(in), VALUE :: p4 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineSegmentBezierCubic + +! void DrawSplineSegmentBezierQuadratic(Vector2 p1, Vector2 c2, Vector2 p3, float thick, Color color) + SUBROUTINE DrawSplineSegmentBezierQuadratic(p1, c2, p3, thick, & + color) BIND(c, name='DrawSplineSegmentBezierQuadratic') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: c2 + TYPE(vector2_), INTENT(in), VALUE :: p3 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineSegmentBezierQuadratic + +! void DrawSplineSegmentCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) + SUBROUTINE DrawSplineSegmentCatmullRom(p1, p2, p3, p4, thick, & + color) BIND(c, name='DrawSplineSegmentCatmullRom') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: p2 + TYPE(vector2_), INTENT(in), VALUE :: p3 + TYPE(vector2_), INTENT(in), VALUE :: p4 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineSegmentCatmullRom + +! void DrawSplineSegmentLinear(Vector2 p1, Vector2 p2, float thick, Color color) + SUBROUTINE DrawSplineSegmentLinear(p1, p2, thick, color) BIND(c, & + name='DrawSplineSegmentLinear') + IMPORT :: C_FLOAT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: p2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawSplineSegmentLinear + +! void DrawTriangleStrip3D(Vector3 *points, int pointCount, Color color) + SUBROUTINE DrawTriangleStrip3D(points, point_count, color) BIND(c & + , name='DrawTriangleStrip3D') + IMPORT :: C_INT, color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawTriangleStrip3D + +! void DrawText(const char *text, int posX, int posY, int fontSize, Color color) + SUBROUTINE DrawText(text, pos_x, pos_y, font_size, color) BIND(c, & + name='DrawText') + IMPORT :: C_CHAR, C_INT, color_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawText + +! void DrawTextCodepoint(Font font, int codepoint, Vector2 position, float fontSize, Color tint) + SUBROUTINE DrawTextCodepoint(font, codepoint, position, font_size & + , tint) BIND(c, name='DrawTextCodepoint') + IMPORT :: C_FLOAT, C_INT, color_, font_, vector2_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint + TYPE(vector2_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextCodepoint + +! void DrawTextCodepoints(Font font, const int *codepoints, int codepointCount, Vector2 position, float fontSize, float spacing, Color tint) + SUBROUTINE DrawTextCodepoints(font, codepoints, codepointCount, & + position, font_size, spacing, tint) & + BIND(c, name='DrawTextCodepoints') + IMPORT :: C_FLOAT, C_INT, color_, font_, vector2_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepointCount + TYPE(vector2_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size + REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextCodepoints + +! void DrawTextEx(Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) + SUBROUTINE DrawTextEx(font, text, position, font_size, spacing, & + tint) BIND(c, name='DrawTextEx') + IMPORT :: C_CHAR, C_FLOAT, color_, font_, vector2_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + CHARACTER(kind=C_CHAR), INTENT(in) :: text + TYPE(vector2_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size + REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextEx + +! void DrawTextPro(Font font, const char *text, Vector2 position, Vector2 origin, float rotation, float fontSize, float spacing, Color tint) + SUBROUTINE DrawTextPro(font, text, position, origin, rotation, & + font_size, spacing, tint) & + BIND(c, name='DrawTextPro') + IMPORT :: C_CHAR, C_FLOAT, color_, font_, vector2_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + CHARACTER(kind=C_CHAR), INTENT(in) :: text + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(vector2_), INTENT(in), VALUE :: origin + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size + REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextPro + +! void DrawTexture(Texture2D texture, int posX, int posY, Color tint) + SUBROUTINE DrawTexture(texture, pos_x, pos_y, tint) BIND(c, name='DrawTexture') + IMPORT :: C_INT, color_, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTexture + +! void DrawTextureEx(Texture2D texture, Vector2 position, float rotation, float scale, Color tint) + SUBROUTINE DrawTextureEx(texture, position, rotation, scale, tint & + ) BIND(c, name='DrawTextureEx') + IMPORT :: C_FLOAT, color_, texture2d_, vector2_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(vector2_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextureEx + +! void DrawTextureNPatch(Texture2D texture, NPatchInfo nPatchInfo, Rectangle dest, Vector2 origin, float rotation, Color tint) + SUBROUTINE DrawTextureNPatch(texture, npatch_info, dest, origin, & + rotation, tint) & + BIND(c, name='DrawTextureNPatch') + IMPORT :: C_FLOAT, color_, npatch_info_, rectangle_, texture2d_, vector2_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(npatch_info_), INTENT(in), VALUE :: npatch_info + TYPE(rectangle_), INTENT(in), VALUE :: dest + TYPE(vector2_), INTENT(in), VALUE :: origin + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextureNPatch + +! void DrawTexturePro(Texture2D texture, Rectangle source, Rectangle dest, Vector2 origin, float rotation, Color tint) + SUBROUTINE DrawTexturePro(texture, source, dest, origin, rotation & + , tint) BIND(c, name='DrawTexturePro') + IMPORT :: C_FLOAT, color_, rectangle_, texture2d_, vector2_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(rectangle_), INTENT(in), VALUE :: source + TYPE(rectangle_), INTENT(in), VALUE :: dest + TYPE(vector2_), INTENT(in), VALUE :: origin + REAL(kind=C_FLOAT), INTENT(in), VALUE :: rotation + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTexturePro + +! void DrawTextureRec(Texture2D texture, Rectangle source, Vector2 position, Color tint) + SUBROUTINE DrawTextureRec(texture, source, position, tint) BIND(c & + , name='DrawTextureRec') + IMPORT :: color_, rectangle_, texture2d_, vector2_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(rectangle_), INTENT(in), VALUE :: source + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextureRec + +! void DrawTextureV(Texture2D texture, Vector2 position, Color tint) + SUBROUTINE DrawTextureV(texture, position, tint) BIND(c, & + name='DrawTextureV') + IMPORT :: color_, texture2d_, vector2_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE DrawTextureV + +! void DrawTriangle(Vector2 v1, Vector2 v2, Vector2 v3, Color color) + SUBROUTINE DrawTriangle(v1, v2, v3, color) BIND(c, name='DrawTriangle') + IMPORT :: color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + TYPE(vector2_), INTENT(in), VALUE :: v3 + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawTriangle + +! void DrawTriangle3D(Vector3 v1, Vector3 v2, Vector3 v3, Color color) + SUBROUTINE DrawTriangle3D(v1, v2, v3, color) BIND(c, name='DrawTriangle3D') + IMPORT :: color_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_), INTENT(in), VALUE :: v3 + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawTriangle3D + +! void DrawTriangleFan(Vector2 *points, int pointCount, Color color) + SUBROUTINE DrawTriangleFan(points, point_count, color) BIND(c, & + name='DrawTriangleFan') + IMPORT :: C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawTriangleFan + +! void DrawTriangleLines(Vector2 v1, Vector2 v2, Vector2 v3, Color color) + SUBROUTINE DrawTriangleLines(v1, v2, v3, color) BIND(c, & + name='DrawTriangleLines') + IMPORT :: color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + TYPE(vector2_), INTENT(in), VALUE :: v3 + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawTriangleLines + +! void DrawTriangleStrip(Vector2 *points, int pointCount, Color color) + SUBROUTINE DrawTriangleStrip(points, point_count, color) BIND(c, & + name='DrawTriangleStrip') + IMPORT :: C_INT, color_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in) :: points(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: point_count + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE DrawTriangleStrip + +END INTERFACE + +END MODULE RaylibDrawMethods diff --git a/src/modules/RaylibInterface/src/RaylibEnums.F90 b/src/modules/RaylibInterface/src/RaylibEnums.F90 new file mode 100644 index 000000000..b3998211c --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibEnums.F90 @@ -0,0 +1,403 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC +! +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-02 +! summary: I have subdivided the big raylib module into smaller modules + +MODULE RaylibEnums +USE, INTRINSIC :: ISO_C_BINDING +IMPLICIT NONE +PRIVATE + +! ConfigFlags +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_VSYNC_HINT = INT(z'00000040') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_FULLSCREEN_MODE & + = INT(z'00000002') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_RESIZABLE & + = INT(z'00000004') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_UNDECORATED & + = INT(z'00000008') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_HIDDEN & + = INT(z'00000080') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_MINIMIZED & + = INT(z'00000200') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_MAXIMIZED & + = INT(z'00000400') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_UNFOCUSED & + = INT(z'00000800') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_TOPMOST & + = INT(z'00001000') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_ALWAYS_RUN & + = INT(z'00000100') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_TRANSPARENT & + = INT(z'00000010') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_HIGHDPI & + = INT(z'00002000') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_WINDOW_MOUSE_PASSTHROUGH & + = INT(z'00004000') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_BORDERLESS_WINDOWED_MODE & + = INT(z'00008000') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_MSAA_4X_HINT & + = INT(z'00000020') +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FLAG_INTERLACED_HINT & + = INT(z'00010000') + +! TraceLogLevel +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_ALL = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_TRACE = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_DEBUG = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_INFO = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_WARNING = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_ERROR = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_FATAL = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: LOG_NONE = 7 + +! KeyboardKey +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_NULL = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_APOSTROPHE = 39 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_COMMA = 44 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_MINUS = 45 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PERIOD = 46 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SLASH = 47 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ZERO = 48 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ONE = 49 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_TWO = 50 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_THREE = 51 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_FOUR = 52 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_FIVE = 53 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SIX = 54 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SEVEN = 55 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_EIGHT = 56 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_NINE = 57 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SEMICOLON = 59 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_EQUAL = 61 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_A = 65 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_B = 66 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_C = 67 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_D = 68 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_E = 69 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F = 70 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_G = 71 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_H = 72 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_I = 73 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_J = 74 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_K = 75 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_L = 76 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_M = 77 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_N = 78 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_O = 79 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_P = 80 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_Q = 81 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_R = 82 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_S = 83 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_T = 84 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_U = 85 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_V = 86 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_W = 87 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_X = 88 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_Y = 89 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_Z = 90 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_BRACKET = 91 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_BACKSLASH = 92 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_BRACKET = 93 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_GRAVE = 96 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SPACE = 32 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ESCAPE = 256 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_ENTER = 257 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_TAB = 258 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_BACKSPACE = 259 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_INSERT = 260 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_DELETE = 261 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT = 262 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT = 263 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_DOWN = 264 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_UP = 265 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PAGE_UP = 266 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PAGE_DOWN = 267 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_HOME = 268 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_END = 269 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_CAPS_LOCK = 280 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_SCROLL_LOCK = 281 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_NUM_LOCK = 282 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PRINT_SCREEN = 283 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_PAUSE = 284 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F1 = 290 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F2 = 291 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F3 = 292 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F4 = 293 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F5 = 294 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F6 = 295 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F7 = 296 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F8 = 297 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F9 = 298 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F10 = 299 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F11 = 300 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_F12 = 301 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_SHIFT = 340 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_CONTROL = 341 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_ALT = 342 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_LEFT_SUPER = 343 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_SHIFT = 344 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_CONTROL = 345 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_ALT = 346 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_RIGHT_SUPER = 347 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KB_MENU = 348 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_0 = 320 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_1 = 321 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_2 = 322 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_3 = 323 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_4 = 324 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_5 = 325 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_6 = 326 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_7 = 327 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_8 = 328 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_9 = 329 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_DECIMAL = 330 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_DIVIDE = 331 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_MULTIPLY = 332 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_SUBTRACT = 333 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_ADD = 334 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_ENTER = 335 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_KP_EQUAL = 336 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_BACK = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_MENU = 82 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_VOLUME_UP = 24 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: KEY_VOLUME_DOWN = 25 + +! MouseButton +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_LEFT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_RIGHT = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_MIDDLE = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_SIDE = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_EXTRA = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_FORWARD = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_BUTTON_BACK = 6 + +! MouseCursor +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_DEFAULT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_ARROW = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_IBEAM = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_CROSSHAIR = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_POINTING_HAND = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_EW = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_NS = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_NWSE = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_NESW = 8 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_RESIZE_ALL = 9 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MOUSE_CURSOR_NOT_ALLOWED = 10 + +! GamepadButton +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_UNKNOWN = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_UP = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_RIGHT = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_DOWN = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_FACE_LEFT = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_UP = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_RIGHT = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_DOWN = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_FACE_LEFT = 8 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_TRIGGER_1 = 9 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_TRIGGER_2 = 10 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_TRIGGER_1 = 11 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_TRIGGER_2 = 12 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_MIDDLE_LEFT = 13 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_MIDDLE = 14 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_MIDDLE_RIGHT = 15 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_LEFT_THUMB = 16 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_BUTTON_RIGHT_THUMB = 17 + +! GamepadAxis +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_LEFT_X = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_LEFT_Y = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_RIGHT_X = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_RIGHT_Y = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_LEFT_TRIGGER = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GAMEPAD_AXIS_RIGHT_TRIGGER = 5 + +! MaterialMapIndex +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_ALBEDO = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_METALNESS = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_NORMAL = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_ROUGHNESS = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_OCCLUSION = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_EMISSION = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_HEIGHT = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_CUBEMAP = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_IRRADIANCE = 8 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_PREFILTER = 9 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_BRDF = 10 + +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_DIFFUSE = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: MATERIAL_MAP_SPECULAR = 1 + +! ShaderLocationIndex +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_POSITION = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_TEXCOORD01 = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_TEXCOORD02 = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_NORMAL = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_TANGENT = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VERTEX_COLOR = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_MVP = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_VIEW = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_PROJECTION = 8 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_MODEL = 9 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MATRIX_NORMAL = 10 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_VECTOR_VIEW = 11 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_COLOR_DIFFUSE = 12 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_COLOR_SPECULAR = 13 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_COLOR_AMBIENT = 14 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_ALBEDO = 15 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_METALNESS = 16 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_NORMAL = 17 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_ROUGHNESS = 18 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_OCCLUSION = 19 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_EMISSION = 20 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_HEIGHT = 21 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_CUBEMAP = 22 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_IRRADIANCE = 23 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_PREFILTER = 24 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_LOC_MAP_BRDF = 25 + +! ShaderUniformDataType +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_FLOAT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_VEC2 = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_VEC3 = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_VEC4 = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_INT = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_IVEC2 = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_IVEC3 = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_IVEC4 = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_UNIFORM_SAMPLER2D = 8 + +! ShaderAttributeDataType +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_FLOAT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_VEC2 = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_VEC3 = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: SHADER_ATTRIB_VEC4 = 3 + +! PixelFormat +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_GRAYSCALE & + = 1 +integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_GRAY_ALPHA & + = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R5G6B5 & + = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R8G8B8 & + = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R5G5B5A1 & + = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R4G4B4A4 & + = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R8G8B8A8 & + = 7 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R32 & + = 8 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R32G32B32 & + = 9 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & + PIXELFORMAT_UNCOMPRESSED_R32G32B32A32 = 10 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R16 & + = 11 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_UNCOMPRESSED_R16G16B16 & + = 12 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & + PIXELFORMAT_UNCOMPRESSED_R16G16B16A16 = 13 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT1_RGB & + = 14 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT1_RGBA & + = 15 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT3_RGBA & + = 16 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_DXT5_RGBA & + = 17 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_ETC1_RGB & + = 18 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_ETC2_RGB & + = 19 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & + PIXELFORMAT_COMPRESSED_ETC2_EAC_RGBA = 20 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_PVRT_RGB & + = 21 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: PIXELFORMAT_COMPRESSED_PVRT_RGBA & + = 22 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & + PIXELFORMAT_COMPRESSED_ASTC_4x4_RGBA = 23 + +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: & + PIXELFORMAT_COMPRESSED_ASTC_8x8_RGBA = 24 + +! TextureFilter +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_POINT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_BILINEAR = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_TRILINEAR = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_ANISOTROPIC_4X = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_ANISOTROPIC_8X = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_FILTER_ANISOTROPIC_16X = 5 + +! TextureWrap +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_REPEAT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_CLAMP = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_MIRROR_REPEAT = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: TEXTURE_WRAP_MIRROR_CLAMP = 3 + +! CubemapLayout +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_AUTO_DETECT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_LINE_VERTICAL = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_LINE_HORIZONTAL = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_CROSS_THREE_BY_FOUR & + = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_CROSS_FOUR_BY_THREE & + = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CUBEMAP_LAYOUT_PANORAMA = 5 + +! FontType +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FONT_DEFAULT = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FONT_BITMAP = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: FONT_SDF = 2 + +! BlendMode +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ALPHA = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ADDITIVE = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_MULTIPLIED = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ADD_COLORS = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_SUBTRACT_COLORS = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_ALPHA_PREMULTIPLY = 5 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_CUSTOM = 6 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: BLEND_CUSTOM_SEPARATE = 7 + +! Gesture +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_NONE = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_TAP = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_DOUBLETAP = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_HOLD = 4 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_DRAG = 8 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_RIGHT = 16 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_LEFT = 32 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_UP = 64 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_SWIPE_DOWN = 128 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_PINCH_IN = 256 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: GESTURE_PINCH_OUT = 512 + +! CameraMode +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_CUSTOM = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_FREE = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_ORBITAL = 2 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_FIRST_PERSON = 3 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_THIRD_PERSON = 4 + +! CameraProjection +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_PERSPECTIVE = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: CAMERA_ORTHOGRAPHIC = 1 + +! NPatchLayout +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: NPATCH_NINE_PATCH = 0 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: NPATCH_THREE_PATCH_VERTICAL = 1 +INTEGER(kind=C_INT), PARAMETER, PUBLIC :: NPATCH_THREE_PATCH_HORIZONTAL = 2 + +END MODULE RaylibEnums diff --git a/src/modules/RaylibInterface/src/RaylibGenMethods.F90 b/src/modules/RaylibInterface/src/RaylibGenMethods.F90 new file mode 100644 index 000000000..641e5952d --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibGenMethods.F90 @@ -0,0 +1,283 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibGenMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: GenImageCellular +PUBLIC :: GenImageChecked +PUBLIC :: GenImageColor +PUBLIC :: GenImageFontAtlas +PUBLIC :: GenImageGradientLinear +PUBLIC :: GenImageGradientRadial +PUBLIC :: GenImageGradientSquare +PUBLIC :: GenImageWhiteNoise +PUBLIC :: GenImagePerlinNoise +PUBLIC :: GenImageText +PUBLIC :: GenMeshCone +PUBLIC :: GenMeshCube +PUBLIC :: GenMeshCubicmap +PUBLIC :: GenMeshCylinder +PUBLIC :: GenMeshHeightmap +PUBLIC :: GenMeshHemiSphere +PUBLIC :: GenMeshKnot +PUBLIC :: GenMeshPlane +PUBLIC :: GenMeshPoly +PUBLIC :: GenMeshSphere +PUBLIC :: GenMeshTangents +PUBLIC :: GenMeshTorus +PUBLIC :: GenTextureMipmaps + +INTERFACE + + ! Image GenImageCellular(int width, int height, int tileSize) + function GenImageCellular(width, height, tile_size) bind(c, name='GenImageCellular') + IMPORT :: C_INT, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: tile_size + TYPE(image_) :: GenImageCellular + END FUNCTION GenImageCellular + + ! Image GenImageChecked(int width, int height, int checksX, int checksY, Color col1, Color col2) + function GenImageChecked(width, height, checks_x, checks_y, col1, col2) bind(c, name='GenImageChecked') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: checks_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: checks_y + TYPE(color_), INTENT(in), VALUE :: col1 + TYPE(color_), INTENT(in), VALUE :: col2 + TYPE(image_) :: GenImageChecked + END FUNCTION GenImageChecked + + ! Image GenImageColor(int width, int height, Color color) + FUNCTION GenImageColor(width, height, color) BIND(c, name='GenImageColor') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(color_), INTENT(in), VALUE :: color + TYPE(image_) :: GenImageColor + END FUNCTION GenImageColor + + ! Image GenImageFontAtlas(const GlyphInfo *glyphs, Rectangle **glyphRecs, int glyphCount, int fontSize, int padding, int packMethod) + function GenImageFontAtlas(glyphs, glyph_recs, glyph_count, font_size, padding, pack_method) & + BIND(c, name='GenImageFontAtlas') + IMPORT :: C_INT, glyph_info_, image_, rectangle_ + IMPLICIT NONE + TYPE(glyph_info_), INTENT(inout) :: glyphs + TYPE(rectangle_), INTENT(inout) :: glyph_recs(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: glyph_count + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + INTEGER(kind=C_INT), INTENT(in), VALUE :: padding + INTEGER(kind=C_INT), INTENT(in), VALUE :: pack_method + TYPE(image_) :: GenImageFontAtlas + END FUNCTION GenImageFontAtlas + + ! Image GenImageGradientLinear(int width, int height, int direction, Color start, Color end) + function GenImageGradientLinear(width, height, direction, start, end) bind(c, name='GenImageGradientLinear') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: direction + TYPE(color_), INTENT(in), VALUE :: start + TYPE(color_), INTENT(in), VALUE :: END + TYPE(image_) :: GenImageGradientLinear + END FUNCTION GenImageGradientLinear + + ! Image GenImageGradientRadial(int width, int height, float density, Color inner, Color outer) + function GenImageGradientRadial(width, height, density, inner, outer) bind(c, name='GenImageGradientRadial') + IMPORT :: C_FLOAT, C_INT, color_, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + REAL(kind=C_FLOAT), INTENT(in), VALUE :: density + TYPE(color_), INTENT(in), VALUE :: inner + TYPE(color_), INTENT(in), VALUE :: outer + TYPE(image_) :: GenImageGradientRadial + END FUNCTION GenImageGradientRadial + + ! Image GenImageGradientSquare(int width, int height, float density, Color inner, Color outer) + function GenImageGradientSquare(width, height, density, inner, outer) bind(c, name='GenImageGradientSquare') + IMPORT :: C_FLOAT, C_INT, color_, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + REAL(kind=C_FLOAT), INTENT(in), VALUE :: density + TYPE(color_), INTENT(in), VALUE :: inner + TYPE(color_), INTENT(in), VALUE :: outer + TYPE(image_) :: GenImageGradientSquare + END FUNCTION GenImageGradientSquare + + ! Image GenImageWhiteNoise(int width, int height, float factor) + function GenImageWhiteNoise(width, height, factor) bind(c, name='GenImageWhiteNoise') + IMPORT :: C_FLOAT, C_INT, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + REAL(kind=C_FLOAT), INTENT(in), VALUE :: factor + TYPE(image_) :: GenImageWhiteNoise + END FUNCTION GenImageWhiteNoise + + ! Image GenImagePerlinNoise(int width, int height, int offsetX, int offsetY, float scale) + function GenImagePerlinNoise(width, height, offset_x, offset_y, scale) bind(c, name='GenImagePerlinNoise') + IMPORT :: C_FLOAT, C_INT, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale + TYPE(image_) :: GenImagePerlinNoise + END FUNCTION GenImagePerlinNoise + + ! Image GenImageText(int width, int height, const char *text) + FUNCTION GenImageText(width, height, text) BIND(c, name='GenImageText') + IMPORT :: C_CHAR, C_INT, image_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + CHARACTER(kind=C_CHAR), INTENT(in) :: text + TYPE(image_) :: GenImageText + END FUNCTION GenImageText + + ! Mesh GenMeshCone(float radius, float height, int slices) + FUNCTION GenMeshCone(radius, height, slices) BIND(c, name='GenMeshCone') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(mesh_) :: GenMeshCone + END FUNCTION GenMeshCone + + ! Mesh GenMeshCube(float width, float height, float length) + FUNCTION GenMeshCube(width, height, length) BIND(c, name='GenMeshCube') + IMPORT :: C_FLOAT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: width + REAL(kind=C_FLOAT), INTENT(in), VALUE :: height + REAL(kind=C_FLOAT), INTENT(in), VALUE :: length + TYPE(mesh_) :: GenMeshCube + END FUNCTION GenMeshCube + + ! Mesh GenMeshCubicmap(Image cubicmap, Vector3 cubeSize) + FUNCTION GenMeshCubicmap(cubicmap, cube_size) BIND(c, name='GenMeshCubicmap') + IMPORT :: image_, mesh_, vector3_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: cubicmap + TYPE(vector3_), INTENT(in), VALUE :: cube_size + TYPE(mesh_) :: GenMeshCubicmap + END FUNCTION GenMeshCubicmap + + ! Mesh GenMeshCylinder(float radius, float height, int slices) + function GenMeshCylinder(radius, height, slices) bind(c, name='GenMeshCylinder') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(mesh_) :: GenMeshCylinder + END FUNCTION GenMeshCylinder + + ! Mesh GenMeshHeightmap(Image heightmap, Vector3 size) + FUNCTION GenMeshHeightmap(heightmap, size) BIND(c, name='GenMeshHeightmap') + IMPORT :: image_, mesh_, vector3_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: heightmap + TYPE(vector3_), INTENT(in), VALUE :: size + TYPE(mesh_) :: GenMeshHeightmap + END FUNCTION GenMeshHeightmap + + ! Mesh GenMeshHemiSphere(float radius, int rings, int slices) + function GenMeshHemiSphere(radius, rings, slices) bind(c, name='GenMeshHemiSphere') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: rings + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(mesh_) :: GenMeshHemiSphere + END FUNCTION GenMeshHemiSphere + + ! Mesh GenMeshKnot(float radius, float size, int radSeg, int sides) +FUNCTION GenMeshKnot(radius, size, rad_seg, sides) BIND(c, name='GenMeshKnot') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: size + INTEGER(kind=C_INT), INTENT(in), VALUE :: rad_seg + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + TYPE(mesh_) :: GenMeshKnot + END FUNCTION GenMeshKnot + + ! Mesh GenMeshPlane(float width, float length, int resX, int resZ) + function GenMeshPlane(width, length, res_x, res_z) bind(c, name='GenMeshPlane') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: width + REAL(kind=C_FLOAT), INTENT(in), VALUE :: length + INTEGER(kind=C_INT), INTENT(in), VALUE :: res_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: res_z + TYPE(mesh_) :: GenMeshPlane + END FUNCTION GenMeshPlane + + ! Mesh GenMeshPoly(int sides, float radius) + FUNCTION GenMeshPoly(sides, radius) BIND(c, name='GenMeshPoly') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(mesh_) :: GenMeshPoly + END FUNCTION GenMeshPoly + + ! Mesh GenMeshSphere(float radius, int rings, int slices) + FUNCTION GenMeshSphere(radius, rings, slices) BIND(c, name='GenMeshSphere') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + INTEGER(kind=C_INT), INTENT(in), VALUE :: rings + INTEGER(kind=C_INT), INTENT(in), VALUE :: slices + TYPE(mesh_) :: GenMeshSphere + END FUNCTION GenMeshSphere + + ! void GenMeshTangents(Mesh *mesh) + SUBROUTINE GenMeshTangents(mesh) BIND(c, name='GenMeshTangents') + IMPORT :: mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in) :: mesh + END SUBROUTINE GenMeshTangents + + ! Mesh GenMeshTorus(float radius, float size, int radSeg, int sides) + function GenMeshTorus(radius, size, rad_seg, sides) bind(c, name='GenMeshTorus') + IMPORT :: C_FLOAT, C_INT, mesh_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + REAL(kind=C_FLOAT), INTENT(in), VALUE :: size + INTEGER(kind=C_INT), INTENT(in), VALUE :: rad_seg + INTEGER(kind=C_INT), INTENT(in), VALUE :: sides + TYPE(mesh_) :: GenMeshTorus + END FUNCTION GenMeshTorus + + ! void GenTextureMipmaps(Texture2D *texture) + SUBROUTINE GenTextureMipmaps(texture) BIND(c, name='GenTextureMipmaps') + IMPORT :: texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(inout) :: texture + END SUBROUTINE GenTextureMipmaps + +END INTERFACE + +END MODULE RaylibGenMethods diff --git a/src/modules/RaylibInterface/src/RaylibGetMethods.F90 b/src/modules/RaylibInterface/src/RaylibGetMethods.F90 new file mode 100644 index 000000000..eeb26d7df --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibGetMethods.F90 @@ -0,0 +1,794 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibGetMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetWorldToScreen2D +PUBLIC :: GetWorkingDirectory +PUBLIC :: GetWindowHandle +PUBLIC :: GetTouchY +PUBLIC :: GetTouchX +PUBLIC :: GetTouchPointId +PUBLIC :: GetTouchPointCount +PUBLIC :: GetTime +PUBLIC :: GetSplinePointLinear +PUBLIC :: GetSplinePointCatmullRom +PUBLIC :: GetSplinePointBezierQuad +PUBLIC :: GetSplinePointBezierCubic +PUBLIC :: GetSplinePointBasis +PUBLIC :: GetShaderLocationAttrib +PUBLIC :: GetShaderLocation +PUBLIC :: GetScreenWidth + +PUBLIC :: GetScreenToWorld2D +PUBLIC :: GetScreenHeight +PUBLIC :: GetRenderWidth +PUBLIC :: GetRenderHeight +PUBLIC :: GetRayCollisionTriangle +PUBLIC :: GetRayCollisionSphere +PUBLIC :: GetRayCollisionQuad +PUBLIC :: GetRayCollisionMesh +PUBLIC :: GetRayCollisionBox +PUBLIC :: GetRandomValue + +PUBLIC :: GetPrevDirectoryPath +PUBLIC :: GetPixelDataSize +PUBLIC :: GetPixelColor +PUBLIC :: GetMusicTimePlayed +PUBLIC :: GetMusicTimeLength +PUBLIC :: GetMouseY +PUBLIC :: GetMouseX +PUBLIC :: GetMouseWheelMove +PUBLIC :: GetMouseRay +PUBLIC :: GetMousePosition +PUBLIC :: GetMouseDelta +PUBLIC :: GetMonitorWidth +PUBLIC :: GetMonitorRefreshRate +PUBLIC :: GetMonitorPhysicalWidth +PUBLIC :: GetMonitorPhysicalHeight +PUBLIC :: GetMonitorName + +PUBLIC :: GetMonitorHeight +PUBLIC :: GetMonitorCount +PUBLIC :: GetModelBoundingBox +PUBLIC :: GetMeshBoundingBox +PUBLIC :: GetMasterVolume +PUBLIC :: GetKeyPressed +PUBLIC :: GetImageColor +PUBLIC :: GetImageAlphaBorder +PUBLIC :: GetGlyphInfo +PUBLIC :: GetGlyphIndex +PUBLIC :: GetGlyphAtlasRec +PUBLIC :: GetGesturePinchAngle +PUBLIC :: GetGestureHoldDuration +PUBLIC :: GetGestureDragAngle +PUBLIC :: GetGestureDetected +PUBLIC :: GetGamepadName +PUBLIC :: GetGamepadButtonPressed +PUBLIC :: GetGamepadAxisMovement +PUBLIC :: GetGamepadAxisCount +PUBLIC :: GetFrameTime + +PUBLIC :: GetFPS +PUBLIC :: GetFontDefault +PUBLIC :: GetFileNameWithoutExt +PUBLIC :: GetFileName +PUBLIC :: GetFileModTime +PUBLIC :: GetFileLength +PUBLIC :: GetFileExtension +PUBLIC :: GetDirectoryPath +PUBLIC :: GetCurrentMonitor +PUBLIC :: GetColor +PUBLIC :: GetCollisionRec +PUBLIC :: GetCodepointPrevious +PUBLIC :: GetCodepointNext +PUBLIC :: GetCodepointCount +PUBLIC :: GetCodepoint +PUBLIC :: GetClipboardText +PUBLIC :: GetCharPressed +PUBLIC :: GetCameraMatrix2D +PUBLIC :: GetCameraMatrix +PUBLIC :: GetApplicationDirectory + +INTERFACE + + FUNCTION GetApplicationDirectory() BIND(c, name='GetApplicationDirectory') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR) :: GetApplicationDirectory + END FUNCTION GetApplicationDirectory + + ! Matrix GetCameraMatrix(Camera camera) + FUNCTION GetCameraMatrix(camera) BIND(c, name='GetCameraMatrix') + IMPORT :: camera3d_, matrix_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(in), VALUE :: camera + TYPE(matrix_) :: GetCameraMatrix + END FUNCTION GetCameraMatrix + + ! Matrix GetCameraMatrix2D(Camera2D camera) + FUNCTION GetCameraMatrix2D(camera) BIND(c, name='GetCameraMatrix2D') + IMPORT :: camera2d_, matrix_ + IMPLICIT NONE + TYPE(camera2d_), INTENT(in), VALUE :: camera + TYPE(matrix_) :: GetCameraMatrix2D + END FUNCTION GetCameraMatrix2D + + ! int GetCharPressed(void) + FUNCTION GetCharPressed() BIND(c, name='GetCharPressed') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetCharPressed + END FUNCTION GetCharPressed + + ! const char *GetClipboardText(void) + FUNCTION GetClipboardText() BIND(c, name='GetClipboardText') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR) :: GetClipboardText + END FUNCTION GetClipboardText + + ! int GetCodepoint(const char *text, int *codepointSize) + FUNCTION GetCodepoint(text, codepoint_size) BIND(c, name='GetCodepoint') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(out) :: codepoint_size + INTEGER(kind=C_INT) :: GetCodepoint + END FUNCTION GetCodepoint + + ! int GetCodepointCount(const char *text) + FUNCTION GetCodepointCount(text) BIND(c, name='GetCodepointCount') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT) :: GetCodepointCount + END FUNCTION GetCodepointCount + + ! int GetCodepointNext(const char *text, int *codepointSize) + FUNCTION GetCodepointNext(text, codepoint_size) BIND(c, name='GetCodepointNext') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(out) :: codepoint_size + INTEGER(kind=C_INT) :: GetCodepointNext + END FUNCTION GetCodepointNext + + ! int GetCodepointPrevious(const char *text, int *codepointSize) + FUNCTION GetCodepointPrevious(text, codepoint_size) & + BIND(c, name='GetCodepointPrevious') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(out) :: codepoint_size + INTEGER(kind=C_INT) :: GetCodepointPrevious + END FUNCTION GetCodepointPrevious + + ! Rectangle GetCollisionRec(Rectangle rec1, Rectangle rec2) + FUNCTION GetCollisionRec(rec1, rec2) BIND(c, name='GetCollisionRec') + IMPORT :: rectangle_ + IMPLICIT NONE + TYPE(rectangle_), INTENT(in), VALUE :: rec1 + TYPE(rectangle_), INTENT(in), VALUE :: rec2 + TYPE(rectangle_) :: GetCollisionRec + END FUNCTION GetCollisionRec + + ! Color GetColor(unsigned int hexValue) + FUNCTION GetColor(hex_value) BIND(c, name='GetColor') + IMPORT :: c_unsigned_int, color_ + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: hex_value + TYPE(color_) :: GetColor + END FUNCTION GetColor + + ! int GetCurrentMonitor(void) + FUNCTION GetCurrentMonitor() BIND(c, name='GetCurrentMonitor') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetCurrentMonitor + END FUNCTION GetCurrentMonitor + + ! const char *GetDirectoryPath(const char *filePath) + FUNCTION GetDirectoryPath(file_path) BIND(c, name='GetDirectoryPath') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_path + TYPE(C_PTR) :: GetDirectoryPath + END FUNCTION GetDirectoryPath + + ! int GetFPS(void) + FUNCTION GetFPS() BIND(c, name='GetFPS') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetFPS + END FUNCTION GetFPS + + ! const char *GetFileExtension(const char *fileName) + FUNCTION GetFileExtension(file_name) BIND(c, name='GetFileExtension') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(C_PTR) :: GetFileExtension + END FUNCTION GetFileExtension + + ! int GetFileLength(const char *fileName) + FUNCTION GetFileLength(file_name) BIND(c, name='GetFileLength') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_INT) :: GetFileLength + END FUNCTION GetFileLength + + ! long GetFileModTime(const char *fileName) + FUNCTION GetFileModTime(file_name) BIND(c, name='GetFileModTime') + IMPORT :: C_CHAR, C_LONG + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_LONG) :: GetFileModTime + END FUNCTION GetFileModTime + + ! const char *GetFileName(const char *filePath) + FUNCTION GetFileName(file_path) BIND(c, name='GetFileName') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_path + TYPE(C_PTR) :: GetFileName + END FUNCTION GetFileName + + ! const char *GetFileNameWithoutExt(const char *filePath) + FUNCTION GetFileNameWithoutExt(file_path) BIND(c, name='GetFileNameWithoutExt') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_path + TYPE(C_PTR) :: GetFileNameWithoutExt + END FUNCTION GetFileNameWithoutExt + + ! Font GetFontDefault(void) + FUNCTION GetFontDefault() BIND(c, name='GetFontDefault') + IMPORT :: font_ + IMPLICIT NONE + TYPE(font_) :: GetFontDefault + END FUNCTION GetFontDefault + + ! float GetFrameTime(void) + FUNCTION GetFrameTime() BIND(c, name='GetFrameTime') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT) :: GetFrameTime + END FUNCTION GetFrameTime + + ! int GetGamepadAxisCount(int gamepad) + FUNCTION GetGamepadAxisCount(gamepad) BIND(c, name='GetGamepadAxisCount') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + INTEGER(kind=C_INT) :: GetGamepadAxisCount + END FUNCTION GetGamepadAxisCount + + ! float GetGamepadAxisMovement(int gamepad, int axis) + FUNCTION GetGamepadAxisMovement(gamepad, axis) BIND(c, name='GetGamepadAxisMovement') + IMPORT :: C_FLOAT, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + INTEGER(kind=C_INT), INTENT(in), VALUE :: axis + REAL(kind=C_FLOAT) :: GetGamepadAxisMovement + END FUNCTION GetGamepadAxisMovement + + ! int GetGamepadButtonPressed(void) + FUNCTION GetGamepadButtonPressed() BIND(c, name='GetGamepadButtonPressed') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetGamepadButtonPressed + END FUNCTION GetGamepadButtonPressed + + ! const char *GetGamepadName(int gamepad) + FUNCTION GetGamepadName(gamepad) BIND(c, name='GetGamepadName') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + TYPE(C_PTR) :: GetGamepadName + END FUNCTION GetGamepadName + + ! int GetGestureDetected(void) + FUNCTION GetGestureDetected() BIND(c, name='GetGestureDetected') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetGestureDetected + END FUNCTION GetGestureDetected + + ! float GetGestureDragAngle(void) + FUNCTION GetGestureDragAngle() BIND(c, name='GetGestureDragAngle') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT) :: GetGestureDragAngle + END FUNCTION GetGestureDragAngle + + ! float GetGestureHoldDuration(void) + FUNCTION GetGestureHoldDuration() BIND(c, name='GetGestureHoldDuration') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT) :: GetGestureHoldDuration + END FUNCTION GetGestureHoldDuration + + ! float GetGesturePinchAngle(void) + FUNCTION GetGesturePinchAngle() BIND(c, name='GetGesturePinchAngle') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT) :: GetGesturePinchAngle + END FUNCTION GetGesturePinchAngle + + ! Rectangle GetGlyphAtlasRec(Font font, int codepoint) + FUNCTION GetGlyphAtlasRec(font, codepoint) BIND(c, name='GetGlyphAtlasRec') + IMPORT :: C_INT, font_, rectangle_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint + TYPE(rectangle_) :: GetGlyphAtlasRec + END FUNCTION GetGlyphAtlasRec + + ! int GetGlyphIndex(Font font, int codepoint) + FUNCTION GetGlyphIndex(font, codepoint) BIND(c, name='GetGlyphIndex') + IMPORT :: C_INT, font_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint + INTEGER(kind=C_INT) :: GetGlyphIndex + END FUNCTION GetGlyphIndex + + ! GlyphInfo GetGlyphInfo(Font font, int codepoint) + FUNCTION GetGlyphInfo(font, codepoint) BIND(c, name='GetGlyphInfo') + IMPORT :: C_INT, font_, glyph_info_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint + TYPE(glyph_info_) :: GetGlyphInfo + END FUNCTION GetGlyphInfo + + ! float GetMasterVolume(void) + FUNCTION GetMasterVolume() BIND(c, name='GetMasterVolume') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT) :: GetMasterVolume + END FUNCTION GetMasterVolume + + ! Rectangle GetImageAlphaBorder(Image image, float threshold) + FUNCTION GetImageAlphaBorder(image, threshold) BIND(c, name='GetImageAlphaBorder') + IMPORT :: C_FLOAT, image_, rectangle_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + REAL(kind=C_FLOAT), INTENT(in), VALUE :: threshold + TYPE(rectangle_) :: GetImageAlphaBorder + END FUNCTION GetImageAlphaBorder + + ! Vector2 GetSplinePointBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) + FUNCTION GetSplinePointBasis(p1, p2, p3, p4, t) BIND(c, & + name='GetSplinePointBasis') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: p2 + TYPE(vector2_), INTENT(in), VALUE :: p3 + TYPE(vector2_), INTENT(in), VALUE :: p4 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: t + TYPE(vector2_) :: GetSplinePointBasis + END FUNCTION GetSplinePointBasis + + ! Vector2 GetSplinePointBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float t) + FUNCTION GetSplinePointBezierCubic(p1, c2, c3, p4, t) BIND(c, & + name='GetSplinePointBezierCubic') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: c2 + TYPE(vector2_), INTENT(in), VALUE :: c3 + TYPE(vector2_), INTENT(in), VALUE :: p4 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: t + TYPE(vector2_) :: GetSplinePointBezierCubic + END FUNCTION GetSplinePointBezierCubic + + ! Vector2 GetSplinePointBezierQuad(Vector2 p1, Vector2 c2, Vector2 p3, float t) + FUNCTION GetSplinePointBezierQuad(p1, c2, p3, t) BIND(c, name='GetSplinePointBezierQuad') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: c2 + TYPE(vector2_), INTENT(in), VALUE :: p3 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: t + TYPE(vector2_) :: GetSplinePointBezierQuad + END FUNCTION GetSplinePointBezierQuad + + ! Vector2 GetSplinePointCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) + FUNCTION GetSplinePointCatmullRom(p1, p2, p3, p4, t) BIND(c, & + name='GetSplinePointCatmullRom') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p1 + TYPE(vector2_), INTENT(in), VALUE :: p2 + TYPE(vector2_), INTENT(in), VALUE :: p3 + TYPE(vector2_), INTENT(in), VALUE :: p4 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: t + TYPE(vector2_) :: GetSplinePointCatmullRom + END FUNCTION GetSplinePointCatmullRom + + ! Vector2 GetSplinePointLinear(Vector2 startPos, Vector2 endPos, float t) + FUNCTION GetSplinePointLinear(start_pos, end_pos, t) BIND(c, name='GetSplinePointLinear') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: start_pos + TYPE(vector2_), INTENT(in), VALUE :: end_pos + REAL(kind=C_FLOAT), INTENT(in), VALUE :: t + TYPE(vector2_) :: GetSplinePointLinear + END FUNCTION GetSplinePointLinear + + ! Color GetImageColor(Image image, int x, int y) + FUNCTION GetImageColor(image, x, y) BIND(c, name='GetImageColor') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: x + INTEGER(kind=C_INT), INTENT(in), VALUE :: y + TYPE(color_) :: GetImageColor + END FUNCTION GetImageColor + + ! int GetKeyPressed(void) + FUNCTION GetKeyPressed() BIND(c, name='GetKeyPressed') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetKeyPressed + END FUNCTION GetKeyPressed + + ! BoundingBox GetMeshBoundingBox(Mesh mesh) + FUNCTION GetMeshBoundingBox(mesh) BIND(c, name='GetMeshBoundingBox') + IMPORT :: bounding_box_, mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in), VALUE :: mesh + TYPE(bounding_box_) :: GetMeshBoundingBox + END FUNCTION GetMeshBoundingBox + + ! BoundingBox GetModelBoundingBox(Model model) + FUNCTION GetModelBoundingBox(model) BIND(c, name='GetModelBoundingBox') + IMPORT :: bounding_box_, model_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + TYPE(bounding_box_) :: GetModelBoundingBox + END FUNCTION GetModelBoundingBox + + ! int GetMonitorCount(void) + FUNCTION GetMonitorCount() BIND(c, name='GetMonitorCount') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetMonitorCount + END FUNCTION GetMonitorCount + + ! int GetMonitorHeight(int monitor) + FUNCTION GetMonitorHeight(monitor) BIND(c, name='GetMonitorHeight') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor + INTEGER(kind=C_INT) :: GetMonitorHeight + END FUNCTION GetMonitorHeight + + ! const char *GetMonitorName(int monitor) + FUNCTION GetMonitorName(monitor) BIND(c, name='GetMonitorName') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor + TYPE(C_PTR) :: GetMonitorName + END FUNCTION GetMonitorName + + ! int GetMonitorPhysicalHeight(int monitor) + FUNCTION GetMonitorPhysicalHeight(monitor) BIND(c, name='GetMonitorPhysicalHeight') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor + INTEGER(kind=C_INT) :: GetMonitorPhysicalHeight + END FUNCTION GetMonitorPhysicalHeight + + ! int GetMonitorPhysicalWidth(int monitor) + FUNCTION GetMonitorPhysicalWidth(monitor) BIND(c, name='GetMonitorPhysicalWidth') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor + INTEGER(kind=C_INT) :: GetMonitorPhysicalWidth + END FUNCTION GetMonitorPhysicalWidth + + ! int GetMonitorRefreshRate(int monitor) + FUNCTION GetMonitorRefreshRate(monitor) BIND(c, name='GetMonitorRefreshRate') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor + INTEGER(kind=C_INT) :: GetMonitorRefreshRate + END FUNCTION GetMonitorRefreshRate + + ! int GetMonitorWidth(int monitor) + FUNCTION GetMonitorWidth(monitor) BIND(c, name='GetMonitorWidth') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor + INTEGER(kind=C_INT) :: GetMonitorWidth + END FUNCTION GetMonitorWidth + + ! Vector2 GetMouseDelta(void) + FUNCTION GetMouseDelta() BIND(c, name='GetMouseDelta') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_) :: GetMouseDelta + END FUNCTION GetMouseDelta + + ! Vector2 GetMousePosition(void) + FUNCTION GetMousePosition() BIND(c, name='GetMousePosition') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_) :: GetMousePosition + END FUNCTION GetMousePosition + + ! Ray GetMouseRay(Vector2 mousePosition, Camera camera) + FUNCTION GetMouseRay(mouse_position, camera) BIND(c, name='GetMouseRay') + IMPORT :: camera3d_, ray_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: mouse_position + TYPE(camera3d_), INTENT(in), VALUE :: camera + TYPE(ray_) :: GetMouseRay + END FUNCTION GetMouseRay + + ! float GetMouseWheelMove(void) + FUNCTION GetMouseWheelMove() BIND(c, name='GetMouseWheelMove') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT) :: GetMouseWheelMove + END FUNCTION GetMouseWheelMove + + ! int GetMouseX(void) + FUNCTION GetMouseX() BIND(c, name='GetMouseX') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetMouseX + END FUNCTION GetMouseX + + ! int GetMouseY(void) + FUNCTION GetMouseY() BIND(c, name='GetMouseY') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetMouseY + END FUNCTION GetMouseY + + ! float GetMusicTimeLength(Music music) + FUNCTION GetMusicTimeLength(music) BIND(c, name='GetMusicTimeLength') + IMPORT :: C_FLOAT, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + REAL(kind=C_FLOAT) :: GetMusicTimeLength + END FUNCTION GetMusicTimeLength + + ! float GetMusicTimePlayed(Music music) + FUNCTION GetMusicTimePlayed(music) BIND(c, name='GetMusicTimePlayed') + IMPORT :: C_FLOAT, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + REAL(kind=C_FLOAT) :: GetMusicTimePlayed + END FUNCTION GetMusicTimePlayed + + ! Color GetPixelColor(void *srcPtr, int format) + FUNCTION GetPixelColor(src_ptr, FORMAT) BIND(c, name='GetPixelColor') + IMPORT :: C_INT, C_PTR, color_ + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: src_ptr + INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT + TYPE(color_) :: GetPixelColor + END FUNCTION GetPixelColor + + ! int GetPixelDataSize(int width, int height, int format) + FUNCTION GetPixelDataSize(width, height, FORMAT) BIND(c, name='GetPixelDataSize') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT + INTEGER(kind=C_INT) :: GetPixelDataSize + END FUNCTION GetPixelDataSize + + ! const char *GetPrevDirectoryPath(const char *dirPath) + FUNCTION GetPrevDirectoryPath(dir_path) BIND(c, & + name='GetPrevDirectoryPath') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: dir_path + TYPE(C_PTR) :: GetPrevDirectoryPath + END FUNCTION GetPrevDirectoryPath + + ! int GetRandomValue(int min, int max) + FUNCTION GetRandomValue(min, max) BIND(c, name='GetRandomValue') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: min + INTEGER(kind=C_INT), INTENT(in), VALUE :: max + INTEGER(kind=C_INT) :: GetRandomValue + END FUNCTION GetRandomValue + + ! RayCollision GetRayCollisionBox(Ray ray, BoundingBox box) + FUNCTION GetRayCollisionBox(ray, box) BIND(c, name='GetRayCollisionBox') + IMPORT :: bounding_box_, ray_collision_, ray_ + IMPLICIT NONE + TYPE(ray_), INTENT(in), VALUE :: ray + TYPE(bounding_box_), INTENT(in), VALUE :: box + TYPE(ray_collision_) :: GetRayCollisionBox + END FUNCTION GetRayCollisionBox + + ! RayCollision GetRayCollisionMesh(Ray ray, Mesh mesh, Matrix transform) + FUNCTION GetRayCollisionMesh(ray, mesh, transform) & + BIND(c, name='GetRayCollisionMesh') + IMPORT :: matrix_, mesh_, ray_collision_, ray_ + IMPLICIT NONE + TYPE(ray_), INTENT(in), VALUE :: ray + TYPE(mesh_), INTENT(in), VALUE :: mesh + TYPE(matrix_), INTENT(in), VALUE :: transform + TYPE(ray_collision_) :: GetRayCollisionMesh + END FUNCTION GetRayCollisionMesh + + ! RayCollision GetRayCollisionQuad(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3, Vector3 p4) + FUNCTION GetRayCollisionQuad(ray, p1, p2, p3, p4) & + BIND(c, name='GetRayCollisionQuad') + IMPORT :: ray_collision_, ray_, vector3_ + IMPLICIT NONE + TYPE(ray_), INTENT(in), VALUE :: ray + TYPE(vector3_), INTENT(in), VALUE :: p1 + TYPE(vector3_), INTENT(in), VALUE :: p2 + TYPE(vector3_), INTENT(in), VALUE :: p3 + TYPE(vector3_), INTENT(in), VALUE :: p4 + TYPE(ray_collision_) :: GetRayCollisionQuad + END FUNCTION GetRayCollisionQuad + + ! RayCollision GetRayCollisionSphere(Ray ray, Vector3 center, float radius) + FUNCTION GetRayCollisionSphere(ray, center, radius) & + BIND(c, name='GetRayCollisionSphere') + IMPORT :: C_FLOAT, ray_collision_, ray_, vector3_ + IMPLICIT NONE + TYPE(ray_), INTENT(in), VALUE :: ray + TYPE(vector3_), INTENT(in), VALUE :: center + REAL(kind=C_FLOAT), INTENT(in), VALUE :: radius + TYPE(ray_collision_) :: GetRayCollisionSphere + END FUNCTION GetRayCollisionSphere + + ! RayCollision GetRayCollisionTriangle(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3) + FUNCTION GetRayCollisionTriangle(ray, p1, p2, p3) & + BIND(c, name='GetRayCollisionTriangle') + IMPORT :: ray_collision_, ray_, vector3_ + IMPLICIT NONE + TYPE(ray_), INTENT(in), VALUE :: ray + TYPE(vector3_), INTENT(in), VALUE :: p1 + TYPE(vector3_), INTENT(in), VALUE :: p2 + TYPE(vector3_), INTENT(in), VALUE :: p3 + TYPE(ray_collision_) :: GetRayCollisionTriangle + END FUNCTION GetRayCollisionTriangle + + ! int GetRenderHeight(void) + FUNCTION GetRenderHeight() BIND(c, name='GetRenderHeight') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetRenderHeight + END FUNCTION GetRenderHeight + + ! int GetRenderWidth(void) + FUNCTION GetRenderWidth() BIND(c, name='GetRenderWidth') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetRenderWidth + END FUNCTION GetRenderWidth + + ! int GetScreenHeight(void) + FUNCTION GetScreenHeight() BIND(c, name='GetScreenHeight') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetScreenHeight + END FUNCTION GetScreenHeight + + ! Vector2 GetScreenToWorld2D(Vector2 position, Camera2D camera) + FUNCTION GetScreenToWorld2D(position, camera) & + BIND(c, name='GetScreenToWorld2D') + IMPORT :: camera2d_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(camera2d_), INTENT(in), VALUE :: camera + TYPE(vector2_) :: GetScreenToWorld2D + END FUNCTION GetScreenToWorld2D + + ! int GetScreenWidth(void) + FUNCTION GetScreenWidth() BIND(c, name='GetScreenWidth') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetScreenWidth + END FUNCTION GetScreenWidth + + ! int GetShaderLocation(Shader shader, const char *uniformName) + FUNCTION GetShaderLocation(shader, uniform_name) & + BIND(c, name='GetShaderLocation') + IMPORT :: C_CHAR, C_INT, shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + CHARACTER(kind=C_CHAR), INTENT(in) :: uniform_name + INTEGER(kind=C_INT) :: GetShaderLocation + END FUNCTION GetShaderLocation + + ! int GetShaderLocationAttrib(Shader shader, const char *attribName) + FUNCTION GetShaderLocationAttrib(shader, attrib_name) & + BIND(c, name='GetShaderLocationAttrib') + IMPORT :: C_CHAR, C_INT, shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + CHARACTER(kind=C_CHAR), INTENT(in) :: attrib_name + INTEGER(kind=C_INT) :: GetShaderLocationAttrib + END FUNCTION GetShaderLocationAttrib + + ! double GetTime(void) + FUNCTION GetTime() BIND(c, name='GetTime') + IMPORT :: C_DOUBLE + IMPLICIT NONE + REAL(kind=C_DOUBLE) :: GetTime + END FUNCTION GetTime + + ! int GetTouchPointCount(void) + FUNCTION GetTouchPointCount() BIND(c, name='GetTouchPointCount') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetTouchPointCount + END FUNCTION GetTouchPointCount + + ! int GetTouchPointId(int index) + FUNCTION GetTouchPointId(index) BIND(c, name='GetTouchPointId') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: index + INTEGER(kind=C_INT) :: GetTouchPointId + END FUNCTION GetTouchPointId + + ! int GetTouchX(void) + FUNCTION GetTouchX() BIND(c, name='GetTouchX') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetTouchX + END FUNCTION GetTouchX + + ! int GetTouchY(void) + FUNCTION GetTouchY() BIND(c, name='GetTouchY') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: GetTouchY + END FUNCTION GetTouchY + + ! void *GetWindowHandle(void) + FUNCTION GetWindowHandle() BIND(c, name='GetWindowHandle') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR) :: GetWindowHandle + END FUNCTION GetWindowHandle + + ! const char *GetWorkingDirectory(void) + FUNCTION GetWorkingDirectory() BIND(c, name='GetWorkingDirectory') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR) :: GetWorkingDirectory + END FUNCTION GetWorkingDirectory + + ! Vector2 GetWorldToScreen2D(Vector2 position, Camera2D camera) + FUNCTION GetWorldToScreen2D(position, camera) & + BIND(c, name='GetWorldToScreen2D') + IMPORT :: camera2d_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(camera2d_), INTENT(in), VALUE :: camera + TYPE(vector2_) :: GetWorldToScreen2D + END FUNCTION GetWorldToScreen2D + +END INTERFACE + +END MODULE RaylibGetMethods diff --git a/src/modules/RaylibInterface/src/RaylibImageMethods.F90 b/src/modules/RaylibInterface/src/RaylibImageMethods.F90 new file mode 100644 index 000000000..9368d4d16 --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibImageMethods.F90 @@ -0,0 +1,477 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibImageMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: ImageToPOT +PUBLIC :: ImageTextEx +PUBLIC :: ImageText +PUBLIC :: ImageRotateCW +PUBLIC :: ImageRotateCCW +PUBLIC :: ImageRotate +PUBLIC :: ImageResizeNN +PUBLIC :: ImageResizeCanvas +PUBLIC :: ImageResize +PUBLIC :: ImageMipmaps +PUBLIC :: ImageKernelConvolution +PUBLIC :: ImageFromImage +PUBLIC :: ImageFormat +PUBLIC :: ImageFlipVertical +PUBLIC :: ImageFlipHorizontal +PUBLIC :: ImageDrawTextEx +PUBLIC :: ImageDrawText +PUBLIC :: ImageDrawRectangleV +PUBLIC :: ImageDrawRectangleRec +PUBLIC :: ImageDrawRectangleLines +PUBLIC :: ImageDrawRectangle +PUBLIC :: ImageDrawPixelV +PUBLIC :: ImageDrawPixel +PUBLIC :: ImageDrawLineV +PUBLIC :: ImageDrawLine +PUBLIC :: ImageDrawCircleV +PUBLIC :: ImageDrawCircleLinesV +PUBLIC :: ImageDrawCircleLines +PUBLIC :: ImageDrawCircle +PUBLIC :: ImageDraw +PUBLIC :: ImageDither +PUBLIC :: ImageCrop +PUBLIC :: ImageCopy +PUBLIC :: ImageColorTint +PUBLIC :: ImageColorReplace +PUBLIC :: ImageColorInvert +PUBLIC :: ImageColorGrayscale +PUBLIC :: ImageColorContrast +PUBLIC :: ImageColorBrightness +PUBLIC :: ImageClearBackground +PUBLIC :: ImageBlurGaussian +PUBLIC :: ImageAlphaPremultiply +PUBLIC :: ImageAlphaMask +PUBLIC :: ImageAlphaCrop +PUBLIC :: ImageAlphaClear + +INTERFACE + + ! void ImageBlurGaussian(Image *image, int blurSize) + SUBROUTINE ImageBlurGaussian(image, blur_size) BIND(c, name='ImageBlurGaussian') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: blur_size + END SUBROUTINE ImageBlurGaussian + + ! void ImageAlphaClear(Image *image, Color color, float threshold) + subroutine ImageAlphaClear(image, color, threshold) bind(c, name='ImageAlphaClear') + IMPORT :: C_FLOAT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + TYPE(color_), INTENT(in), VALUE :: color + REAL(kind=C_FLOAT), INTENT(in), VALUE :: threshold + END SUBROUTINE ImageAlphaClear + + ! void ImageAlphaCrop(Image *image, float threshold) + SUBROUTINE ImageAlphaCrop(image, threshold) BIND(c, name='ImageAlphaCrop') + IMPORT :: C_FLOAT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + REAL(kind=C_FLOAT), INTENT(in), VALUE :: threshold + END SUBROUTINE ImageAlphaCrop + + ! void ImageAlphaMask(Image *image, Image alphaMask) + SUBROUTINE ImageAlphaMask(image, alpha_mask) BIND(c, name='ImageAlphaMask') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + TYPE(image_), INTENT(in), VALUE :: alpha_mask + END SUBROUTINE ImageAlphaMask + + ! void ImageAlphaPremultiply(Image *image) + SUBROUTINE ImageAlphaPremultiply(image) BIND(c, name='ImageAlphaPremultiply') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageAlphaPremultiply + + ! void ImageClearBackground(Image *dst, Color color) + subroutine ImageClearBackground(dst, color) bind(c, name='ImageClearBackground') + IMPORT :: color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageClearBackground + + ! void ImageColorBrightness(Image *image, int brightness) + subroutine ImageColorBrightness(image, brightness) bind(c, name='ImageColorBrightness') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: brightness + END SUBROUTINE ImageColorBrightness + + ! void ImageColorContrast(Image *image, float contrast) + subroutine ImageColorContrast(image, contrast) bind(c, name='ImageColorContrast') + IMPORT :: C_FLOAT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + REAL(kind=C_FLOAT), INTENT(in), VALUE :: contrast + END SUBROUTINE ImageColorContrast + + ! void ImageColorGrayscale(Image *image) + SUBROUTINE ImageColorGrayscale(image) BIND(c, name='ImageColorGrayscale') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageColorGrayscale + + ! void ImageColorInvert(Image *image) + SUBROUTINE ImageColorInvert(image) BIND(c, name='ImageColorInvert') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageColorInvert + + ! void ImageColorReplace(Image *image, Color color, Color replace) + subroutine ImageColorReplace(image, color, replace) bind(c, name='ImageColorReplace') + IMPORT :: color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + TYPE(color_), INTENT(in), VALUE :: color + TYPE(color_), INTENT(in), VALUE :: replace + END SUBROUTINE ImageColorReplace + + ! void ImageColorTint(Image *image, Color color) + SUBROUTINE ImageColorTint(image, color) BIND(c, name='ImageColorTint') + IMPORT :: color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageColorTint + + ! Image ImageCopy(Image image) + FUNCTION ImageCopy(image) BIND(c, name='ImageCopy') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + TYPE(image_) :: ImageCopy + END FUNCTION ImageCopy + + ! void ImageCrop(Image *image, Rectangle crop) + SUBROUTINE ImageCrop(image, crop) BIND(c, name='ImageCrop') + IMPORT :: image_, rectangle_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + TYPE(rectangle_), INTENT(in), VALUE :: crop + END SUBROUTINE ImageCrop + + ! void ImageDither(Image *image, int rBpp, int gBpp, int bBpp, int aBpp) + subroutine ImageDither(image, r_bpp, g_bpp, b_bpp, a_bpp) bind(c, name='ImageDither') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: r_bpp + INTEGER(kind=C_INT), INTENT(in), VALUE :: g_bpp + INTEGER(kind=C_INT), INTENT(in), VALUE :: b_bpp + INTEGER(kind=C_INT), INTENT(in), VALUE :: a_bpp + END SUBROUTINE ImageDither + + ! void ImageDraw(Image *dst, Image src, Rectangle srcRec, Rectangle dstRec, Color tint) + subroutine ImageDraw(dst, src, src_rec, dst_rec, tint) bind(c, name='ImageDraw') + IMPORT :: color_, image_, rectangle_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(image_), INTENT(in), VALUE :: src + TYPE(rectangle_), INTENT(in), VALUE :: src_rec + TYPE(rectangle_), INTENT(in), VALUE :: dst_rec + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE ImageDraw + + ! void ImageDrawCircle(Image *dst, int centerX, int centerY, int radius, Color color) + subroutine ImageDrawCircle(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircle') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawCircle + + ! void ImageDrawCircleLines(Image *dst, int centerX, int centerY, int radius, Color color) + subroutine ImageDrawCircleLines(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircleLines') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: center_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawCircleLines + + ! void ImageDrawCircleLinesV(Image *dst, Vector2 center, int radius, Color color) + subroutine ImageDrawCircleLinesV(dst, center, radius, color) bind(c, name='ImageDrawCircleLinesV') + IMPORT :: C_INT, color_, image_, vector2_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(vector2_), INTENT(in), VALUE :: center + INTEGER(kind=C_INT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawCircleLinesV + + ! void ImageDrawCircleV(Image *dst, Vector2 center, int radius, Color color) + subroutine ImageDrawCircleV(dst, center, radius, color) bind(c, name='ImageDrawCircleV') + IMPORT :: C_INT, color_, image_, vector2_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(vector2_), INTENT(in), VALUE :: center + INTEGER(kind=C_INT), INTENT(in), VALUE :: radius + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawCircleV + + ! void ImageDrawLine(Image *dst, int startPosX, int startPosY, int endPosX, int endPosY, Color color) + subroutine ImageDrawLine(dst, start_pos_x, start_pos_y, end_pos_x, end_pos_y, color) & + BIND(c, name='ImageDrawLine') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: start_pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: end_pos_y + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawLine + + ! void ImageDrawLineV(Image *dst, Vector2 start, Vector2 end, Color color) + subroutine ImageDrawLineV(dst, start, end, color) bind(c, name='ImageDrawLineV') + IMPORT :: color_, image_, vector2_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(vector2_), INTENT(in), VALUE :: start + TYPE(vector2_), INTENT(in), VALUE :: END + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawLineV + + ! void ImageDrawPixel(Image *dst, int posX, int posY, Color color) + subroutine ImageDrawPixel(dst, pos_x, pos_y, color) bind(c, name='ImageDrawPixel') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawPixel + + ! void ImageDrawPixelV(Image *dst, Vector2 position, Color color) + subroutine ImageDrawPixelV(dst, position, color) bind(c, name='ImageDrawPixelV') + IMPORT :: color_, image_, vector2_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawPixelV + + ! void ImageDrawRectangle(Image *dst, int posX, int posY, int width, int height, Color color) + subroutine ImageDrawRectangle(dst, pos_x, pos_y, width, height, color) bind(c, name='ImageDrawRectangle') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawRectangle + + ! void ImageDrawRectangleLines(Image *dst, Rectangle rec, int thick, Color color) + subroutine ImageDrawRectangleLines(dst, rec, thick, color) bind(c, name='ImageDrawRectangleLines') + IMPORT :: C_INT, color_, image_, rectangle_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(rectangle_), INTENT(in), VALUE :: rec + INTEGER(kind=C_INT), INTENT(in), VALUE :: thick + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawRectangleLines + + ! void ImageDrawRectangleRec(Image *dst, Rectangle rec, Color color) + subroutine ImageDrawRectangleRec(dst, rec, color) bind(c, name='ImageDrawRectangleRec') + IMPORT :: color_, image_, rectangle_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(rectangle_), INTENT(in), VALUE :: rec + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawRectangleRec + + ! void ImageDrawRectangleV(Image *dst, Vector2 position, Vector2 size, Color color) + subroutine ImageDrawRectangleV(dst, position, size, color) bind(c, name='ImageDrawRectangleV') + IMPORT :: color_, image_, vector2_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(vector2_), INTENT(in), VALUE :: position + TYPE(vector2_), INTENT(in), VALUE :: size + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawRectangleV + + ! void ImageDrawText(Image *dst, const char *text, int posX, int posY, int fontSize, Color color) + subroutine ImageDrawText(dst, text, pos_x, pos_y, font_size, color) bind(c, name='ImageDrawText') + IMPORT :: C_CHAR, C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: pos_y + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ImageDrawText + + ! void ImageDrawTextEx(Image *dst, Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) + subroutine ImageDrawTextEx(dst, font, text, position, font_size, spacing, tint) bind(c, name='ImageDrawTextEx') + IMPORT :: C_CHAR, C_FLOAT, color_, font_, image_, vector2_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: dst + TYPE(font_), INTENT(in), VALUE :: font + CHARACTER(kind=C_CHAR), INTENT(in) :: text + TYPE(vector2_), INTENT(in), VALUE :: position + REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size + REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing + TYPE(color_), INTENT(in), VALUE :: tint + END SUBROUTINE ImageDrawTextEx + + ! void ImageFlipHorizontal(Image *image) + SUBROUTINE ImageFlipHorizontal(image) BIND(c, name='ImageFlipHorizontal') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageFlipHorizontal + + ! void ImageFlipVertical(Image *image) + SUBROUTINE ImageFlipVertical(image) BIND(c, name='ImageFlipVertical') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageFlipVertical + + ! void ImageFormat(Image *image, int newFormat) + SUBROUTINE ImageFormat(image, new_format) BIND(c, name='ImageFormat') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: new_format + END SUBROUTINE ImageFormat + + ! Image ImageFromImage(Image image, Rectangle rec) + FUNCTION ImageFromImage(image, rec) BIND(c, name='ImageFromImage') + IMPORT :: image_, rectangle_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + TYPE(rectangle_), INTENT(in), VALUE :: rec + TYPE(image_) :: ImageFromImage + END FUNCTION ImageFromImage + + ! void ImageKernelConvolution(Image *image, float *kernel, int kernelSize) + subroutine ImageKernelConvolution(image, kernel, kernel_size) bind(c, name='ImageKernelConvolution') + IMPORT :: C_FLOAT, C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + REAL(kind=C_FLOAT), INTENT(inout) :: kernel + INTEGER(kind=C_INT), INTENT(in), VALUE :: kernel_size + END SUBROUTINE ImageKernelConvolution + + ! void ImageMipmaps(Image *image) + SUBROUTINE ImageMipmaps(image) BIND(c, name='ImageMipmaps') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageMipmaps + + ! void ImageResize(Image *image, int newWidth, int newHeight) + subroutine ImageResize(image, new_width, new_height) bind(c, name='ImageResize') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: new_width + INTEGER(kind=C_INT), INTENT(in), VALUE :: new_height + END SUBROUTINE ImageResize + + ! void ImageResizeCanvas(Image *image, int newWidth, int newHeight, int offsetX, int offsetY, Color fill) + subroutine ImageResizeCanvas(image, new_width, new_height, offset_x, offset_y, fill) bind(c, name='ImageResizeCanvas') + IMPORT :: C_INT, color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: new_width + INTEGER(kind=C_INT), INTENT(in), VALUE :: new_height + INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_y + TYPE(color_), INTENT(in), VALUE :: fill + END SUBROUTINE ImageResizeCanvas + + ! void ImageResizeNN(Image *image, int newWidth,int newHeight) + subroutine ImageResizeNN(image, new_width, new_height) bind(c, name='ImageResizeNN') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: new_width + INTEGER(kind=C_INT), INTENT(in), VALUE :: new_height + END SUBROUTINE ImageResizeNN + + ! void ImageRotate(Image *image, int degrees) + SUBROUTINE ImageRotate(image, degrees) BIND(c, name='ImageRotate') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: degrees + END SUBROUTINE ImageRotate + + ! void ImageRotateCCW(Image *image) + SUBROUTINE ImageRotateCCW(image) BIND(c, name='ImageRotateCCW') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageRotateCCW + + ! void ImageRotateCW(Image *image) + SUBROUTINE ImageRotateCW(image) BIND(c, name='ImageRotateCW') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + END SUBROUTINE ImageRotateCW + + ! Image ImageText(const char *text, int fontSize, Color color) + FUNCTION ImageText(text, font_size, color) BIND(c, name='ImageText') + IMPORT :: C_CHAR, C_INT, color_, image_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + TYPE(color_), INTENT(in), VALUE :: color + TYPE(image_) :: ImageText + END FUNCTION ImageText + + ! Image ImageTextEx(Font font, const char *text, float fontSize, float spacing, Color tint) + function ImageTextEx(font, text, font_size, spacing, tint) bind(c, name='ImageTextEx') + IMPORT :: C_CHAR, C_FLOAT, color_, font_, image_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + CHARACTER(kind=C_CHAR), INTENT(in) :: text + REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size + REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing + TYPE(color_), INTENT(in), VALUE :: tint + TYPE(image_) :: ImageTextEx + END FUNCTION ImageTextEx + + ! void ImageToPOT(Image *image, Color fill) + SUBROUTINE ImageToPOT(image, fill) BIND(c, name='ImageToPOT') + IMPORT :: color_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: image + TYPE(color_), INTENT(in), VALUE :: fill + END SUBROUTINE ImageToPOT +END INTERFACE + +END MODULE RaylibImageMethods diff --git a/src/modules/RaylibInterface/src/RaylibIsMethods.F90 b/src/modules/RaylibInterface/src/RaylibIsMethods.F90 new file mode 100644 index 000000000..dd3f36ed3 --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibIsMethods.F90 @@ -0,0 +1,419 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibIsMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: IsWindowState +PUBLIC :: IsWindowResized +PUBLIC :: IsWindowReady +PUBLIC :: IsWindowMinimized +PUBLIC :: IsWindowMaximized +PUBLIC :: IsWindowHidden +PUBLIC :: IsWindowFullscreen +PUBLIC :: IsWindowFocused +PUBLIC :: IsWaveReady +PUBLIC :: IsTextureReady +PUBLIC :: IsSoundReady +PUBLIC :: IsSoundPlaying +PUBLIC :: IsShaderReady +PUBLIC :: IsRenderTextureReady +PUBLIC :: IsPathFile +PUBLIC :: IsMusicStreamPlaying +PUBLIC :: IsMusicReady +PUBLIC :: IsMouseButtonUp +PUBLIC :: IsMouseButtonReleased +PUBLIC :: IsMouseButtonPressed +PUBLIC :: IsMouseButtonDown +PUBLIC :: IsModelReady +PUBLIC :: IsModelAnimationValid +PUBLIC :: IsMaterialReady +PUBLIC :: IsKeyUp +PUBLIC :: IsKeyReleased +PUBLIC :: IsKeyPressedRepeat +PUBLIC :: IsKeyPressed +PUBLIC :: IsKeyDown +PUBLIC :: IsImageReady +PUBLIC :: IsGestureDetected +PUBLIC :: IsGamepadButtonUp +PUBLIC :: IsGamepadButtonReleased +PUBLIC :: IsGamepadButtonPressed +PUBLIC :: IsGamepadButtonDown +PUBLIC :: IsGamepadAvailable +PUBLIC :: IsFontReady +PUBLIC :: IsFileExtension +PUBLIC :: IsFileDropped +PUBLIC :: IsCursorOnScreen +PUBLIC :: IsCursorHidden +PUBLIC :: IsAudioStreamReady +PUBLIC :: IsAudioStreamProcessed +PUBLIC :: IsAudioStreamPlaying +PUBLIC :: IsAudioDeviceReady + +INTERFACE + ! bool IsAudioDeviceReady(void) + FUNCTION IsAudioDeviceReady() BIND(c, name='IsAudioDeviceReady') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsAudioDeviceReady + END FUNCTION IsAudioDeviceReady + + ! bool IsAudioStreamPlaying(AudioStream stream) + FUNCTION IsAudioStreamPlaying(stream) BIND(c, name='IsAudioStreamPlaying') + IMPORT :: audio_stream_, C_BOOL + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + LOGICAL(kind=C_BOOL) :: IsAudioStreamPlaying + END FUNCTION IsAudioStreamPlaying + + ! bool IsAudioStreamProcessed(AudioStream stream) +FUNCTION IsAudioStreamProcessed(stream) BIND(c, name='IsAudioStreamProcessed') + IMPORT :: audio_stream_, C_BOOL + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + LOGICAL(kind=C_BOOL) :: IsAudioStreamProcessed + END FUNCTION IsAudioStreamProcessed + + ! bool IsAudioStreamReady(AudioStream stream) + FUNCTION IsAudioStreamReady(stream) BIND(c, name='IsAudioStreamReady') + IMPORT :: audio_stream_, C_BOOL + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + LOGICAL(kind=C_BOOL) :: IsAudioStreamReady + END FUNCTION IsAudioStreamReady + + ! bool IsCursorHidden(void) + FUNCTION IsCursorHidden() BIND(c, name='IsCursorHidden') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsCursorHidden + END FUNCTION IsCursorHidden + + ! bool IsCursorOnScreen(void) + FUNCTION IsCursorOnScreen() BIND(c, name='IsCursorOnScreen') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsCursorOnScreen + END FUNCTION IsCursorOnScreen + + ! bool IsFileDropped(void) + FUNCTION IsFileDropped() BIND(c, name='IsFileDropped') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsFileDropped + END FUNCTION IsFileDropped + + ! bool IsFileExtension(const char *fileName, const char *ext) + FUNCTION IsFileExtension(file_name, ext) BIND(c, name='IsFileExtension') + IMPORT :: C_BOOL, C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + CHARACTER(kind=C_CHAR), INTENT(in) :: ext + LOGICAL(kind=C_BOOL) :: IsFileExtension + END FUNCTION IsFileExtension + + ! bool IsFontReady(Font font) + FUNCTION IsFontReady(font) BIND(c, name='IsFontReady') + IMPORT :: C_BOOL, font_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + LOGICAL(kind=C_BOOL) :: IsFontReady + END FUNCTION IsFontReady + + ! bool IsGamepadAvailable(int gamepad) + FUNCTION IsGamepadAvailable(gamepad) BIND(c, name='IsGamepadAvailable') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + LOGICAL(kind=C_BOOL) :: IsGamepadAvailable + END FUNCTION IsGamepadAvailable + + ! bool IsGamepadButtonDown(int gamepad, int button) + function IsGamepadButtonDown(gamepad, button) bind(c, name='IsGamepadButtonDown') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsGamepadButtonDown + END FUNCTION IsGamepadButtonDown + + ! bool IsGamepadButtonPressed(int gamepad, int button) + function IsGamepadButtonPressed(gamepad, button) bind(c, name='IsGamepadButtonPressed') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsGamepadButtonPressed + END FUNCTION IsGamepadButtonPressed + + ! bool IsGamepadButtonReleased(int gamepad, int button) + function IsGamepadButtonReleased(gamepad, button) bind(c, name='IsGamepadButtonReleased') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsGamepadButtonReleased + END FUNCTION IsGamepadButtonReleased + + ! bool IsGamepadButtonUp(int gamepad, int button) + FUNCTION IsGamepadButtonUp(gamepad, button) BIND(c, name='IsGamepadButtonUp') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: gamepad + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsGamepadButtonUp + END FUNCTION IsGamepadButtonUp + + ! bool IsGestureDetected(unsigned int gesture) + FUNCTION IsGestureDetected(gesture) BIND(c, name='IsGestureDetected') + IMPORT :: C_BOOL, c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: gesture + LOGICAL(kind=C_BOOL) :: IsGestureDetected + END FUNCTION IsGestureDetected + + ! bool IsImageReady(Image image) + FUNCTION IsImageReady(image) BIND(c, name='IsImageReady') + IMPORT :: C_BOOL, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + LOGICAL(kind=C_BOOL) :: IsImageReady + END FUNCTION IsImageReady + + ! bool IsKeyDown(int key) + FUNCTION IsKeyDown(key) BIND(c, name='IsKeyDown') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key + LOGICAL(kind=C_BOOL) :: IsKeyDown + END FUNCTION IsKeyDown + + ! bool IsKeyPressed(int key) + FUNCTION IsKeyPressed(key) BIND(c, name='IsKeyPressed') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key + LOGICAL(kind=C_BOOL) :: IsKeyPressed + END FUNCTION IsKeyPressed + + ! bool IsKeyPressedRepeat(int key) + FUNCTION IsKeyPressedRepeat(key) BIND(c, name='IsKeyPressedRepeat') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key + LOGICAL(kind=C_BOOL) :: IsKeyPressedRepeat + END FUNCTION IsKeyPressedRepeat + + ! bool IsKeyReleased(int key) + FUNCTION IsKeyReleased(key) BIND(c, name='IsKeyReleased') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key + LOGICAL(kind=C_BOOL) :: IsKeyReleased + END FUNCTION IsKeyReleased + + ! bool IsKeyUp(int key) + FUNCTION IsKeyUp(key) BIND(c, name='IsKeyUp') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key + LOGICAL(kind=C_BOOL) :: IsKeyUp + END FUNCTION IsKeyUp + + ! bool IsMaterialReady(Material material) + FUNCTION IsMaterialReady(material) BIND(c, name='IsMaterialReady') + IMPORT :: C_BOOL, material_ + IMPLICIT NONE + TYPE(material_), INTENT(in), VALUE :: material + LOGICAL(kind=C_BOOL) :: IsMaterialReady + END FUNCTION IsMaterialReady + + ! bool IsModelAnimationValid(Model model, ModelAnimation anim) + function IsModelAnimationValid(model, anim) bind(c, name='IsModelAnimationValid') + IMPORT :: C_BOOL, model_animation_, model_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + TYPE(model_animation_), INTENT(in), VALUE :: anim + LOGICAL(kind=C_BOOL) :: IsModelAnimationValid + END FUNCTION IsModelAnimationValid + + ! bool IsModelReady(Model model) + FUNCTION IsModelReady(model) BIND(c, name='IsModelReady') + IMPORT :: C_BOOL, model_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + LOGICAL(kind=C_BOOL) :: IsModelReady + END FUNCTION IsModelReady + + ! bool IsMouseButtonDown(int button) + FUNCTION IsMouseButtonDown(button) BIND(c, name='IsMouseButtonDown') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsMouseButtonDown + END FUNCTION IsMouseButtonDown + + ! bool IsMouseButtonPressed(int button) + FUNCTION IsMouseButtonPressed(button) BIND(c, name='IsMouseButtonPressed') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsMouseButtonPressed + END FUNCTION IsMouseButtonPressed + + ! bool IsMouseButtonReleased(int button) + FUNCTION IsMouseButtonReleased(button) BIND(c, name='IsMouseButtonReleased') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsMouseButtonReleased + END FUNCTION IsMouseButtonReleased + + ! bool IsMouseButtonUp(int button) + FUNCTION IsMouseButtonUp(button) BIND(c, name='IsMouseButtonUp') + IMPORT :: C_BOOL, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: button + LOGICAL(kind=C_BOOL) :: IsMouseButtonUp + END FUNCTION IsMouseButtonUp + + ! bool IsMusicReady(Music music) + FUNCTION IsMusicReady(music) BIND(c, name='IsMusicReady') + IMPORT :: C_BOOL, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + LOGICAL(kind=C_BOOL) :: IsMusicReady + END FUNCTION IsMusicReady + + ! bool IsMusicStreamPlaying(Music music) + FUNCTION IsMusicStreamPlaying(music) BIND(c, name='IsMusicStreamPlaying') + IMPORT :: C_BOOL, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + LOGICAL(kind=C_BOOL) :: IsMusicStreamPlaying + END FUNCTION IsMusicStreamPlaying + + ! bool IsPathFile(const char *path) + FUNCTION IsPathFile(path) BIND(c, name='IsPathFile') + IMPORT :: C_BOOL, C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: path + LOGICAL(kind=C_BOOL) :: IsPathFile + END FUNCTION IsPathFile + + ! bool IsRenderTextureReady(RenderTexture2D target) + FUNCTION IsRenderTextureReady(TARGET) BIND(c, name='IsRenderTextureReady') + IMPORT :: C_BOOL, render_texture2d_ + IMPLICIT NONE + TYPE(render_texture2d_), INTENT(in), VALUE :: TARGET + LOGICAL(kind=C_BOOL) :: IsRenderTextureReady + END FUNCTION IsRenderTextureReady + + ! bool IsShaderReady(Shader shader) + FUNCTION IsShaderReady(shader) BIND(c, name='IsShaderReady') + IMPORT :: C_BOOL, shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + LOGICAL(kind=C_BOOL) :: IsShaderReady + END FUNCTION IsShaderReady + + ! bool IsSoundPlaying(Sound sound) + FUNCTION IsSoundPlaying(sound) BIND(c, name='IsSoundPlaying') + IMPORT :: C_BOOL, sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + LOGICAL(kind=C_BOOL) :: IsSoundPlaying + END FUNCTION IsSoundPlaying + + ! bool IsSoundReady(Sound sound) + FUNCTION IsSoundReady(sound) BIND(c, name='IsSoundReady') + IMPORT :: C_BOOL, sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + LOGICAL(kind=C_BOOL) :: IsSoundReady + END FUNCTION IsSoundReady + + ! bool IsTextureReady(Texture2D texture) + FUNCTION IsTextureReady(texture) BIND(c, name='IsTextureReady') + IMPORT :: C_BOOL, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + LOGICAL(kind=C_BOOL) :: IsTextureReady + END FUNCTION IsTextureReady + + ! bool IsWaveReady(Wave wave) + FUNCTION IsWaveReady(wave) BIND(c, name='IsWaveReady') + IMPORT :: C_BOOL, wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in), VALUE :: wave + LOGICAL(kind=C_BOOL) :: IsWaveReady + END FUNCTION IsWaveReady + + ! bool IsWindowFocused(void) + FUNCTION IsWindowFocused() BIND(c, name='IsWindowFocused') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsWindowFocused + END FUNCTION IsWindowFocused + + ! bool IsWindowFullscreen(void) + FUNCTION IsWindowFullscreen() BIND(c, name='IsWindowFullscreen') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsWindowFullscreen + END FUNCTION IsWindowFullscreen + + ! bool IsWindowHidden(void) + FUNCTION IsWindowHidden() BIND(c, name='IsWindowHidden') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsWindowHidden + END FUNCTION IsWindowHidden + + ! bool IsWindowMaximized(void) + FUNCTION IsWindowMaximized() BIND(c, name='IsWindowMaximized') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsWindowMaximized + END FUNCTION IsWindowMaximized + + ! bool IsWindowMinimized(void) + FUNCTION IsWindowMinimized() BIND(c, name='IsWindowMinimized') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsWindowMinimized + END FUNCTION IsWindowMinimized + + ! bool IsWindowReady(void) + FUNCTION IsWindowReady() BIND(c, name='IsWindowReady') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsWindowReady + END FUNCTION IsWindowReady + + ! bool IsWindowResized(void) + FUNCTION IsWindowResized() BIND(c, name='IsWindowResized') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: IsWindowResized + END FUNCTION IsWindowResized + + ! bool IsWindowState(unsigned int flag) + FUNCTION IsWindowState(flag) BIND(c, name='IsWindowState') + IMPORT :: C_BOOL, c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flag + LOGICAL(kind=C_BOOL) :: IsWindowState + END FUNCTION IsWindowState +END INTERFACE + +END MODULE RaylibIsMethods diff --git a/src/modules/RaylibInterface/src/RaylibLoadMethods.F90 b/src/modules/RaylibInterface/src/RaylibLoadMethods.F90 new file mode 100644 index 000000000..6e5c34e77 --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibLoadMethods.F90 @@ -0,0 +1,450 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibLoadMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: LoadWaveSamples +PUBLIC :: LoadWaveFromMemory +PUBLIC :: LoadWave +PUBLIC :: LoadVrStereoConfig +PUBLIC :: LoadUTF8 +PUBLIC :: LoadTextureFromImage +PUBLIC :: LoadTextureCubemap +PUBLIC :: LoadTexture +PUBLIC :: LoadSoundFromWave +PUBLIC :: LoadSoundAlias +PUBLIC :: LoadSound +PUBLIC :: LoadShaderFromMemory +PUBLIC :: LoadShader +PUBLIC :: LoadRenderTexture +PUBLIC :: LoadRandomSequence +PUBLIC :: LoadMusicStreamFromMemory +PUBLIC :: LoadMusicStream +PUBLIC :: LoadModelFromMesh +PUBLIC :: LoadModelAnimations +PUBLIC :: LoadModel +PUBLIC :: LoadMaterials +PUBLIC :: LoadMaterialDefault +PUBLIC :: LoadImageSvg +PUBLIC :: LoadImageRaw +PUBLIC :: LoadImagePalette +PUBLIC :: LoadImageFromTexture +PUBLIC :: LoadImageFromScreen +PUBLIC :: LoadImageFromMemory +PUBLIC :: LoadImageColors +PUBLIC :: LoadImageAnim +PUBLIC :: LoadImage +PUBLIC :: LoadFontFromMemory +PUBLIC :: LoadFontFromImage +PUBLIC :: LoadFontEx +PUBLIC :: LoadFontData +PUBLIC :: LoadFont +PUBLIC :: LoadFileText +PUBLIC :: LoadFileData +PUBLIC :: LoadDroppedFiles +PUBLIC :: LoadDirectoryFilesEx +PUBLIC :: LoadDirectoryFiles +PUBLIC :: LoadCodepoints +PUBLIC :: LoadAudioStream + +INTERFACE + ! AudioStream LoadAudioStream(unsigned int sampleRate, unsigned int sampleSize, unsigned int channels) + function LoadAudioStream(sample_rate, sample_size, channels) bind(c, name='LoadAudioStream') + IMPORT :: audio_stream_, c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: sample_rate + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: sample_size + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: channels + TYPE(audio_stream_) :: LoadAudioStream + END FUNCTION LoadAudioStream + + ! int *LoadCodepoints(const char *text, int *count) + FUNCTION LoadCodepoints(text, count) BIND(c, name='LoadCodepoints') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(out) :: count + TYPE(C_PTR) :: LoadCodepoints + END FUNCTION LoadCodepoints + + ! FilePathList LoadDirectoryFiles(const char *dirPath) + FUNCTION LoadDirectoryFiles(dir_path) BIND(c, name='LoadDirectoryFiles') + IMPORT :: C_CHAR, file_path_list_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: dir_path + TYPE(file_path_list_) :: LoadDirectoryFiles + END FUNCTION LoadDirectoryFiles + + ! FilePathList LoadDirectoryFilesEx(const char *basePath, const char *filter, bool scanSubdirs) + function LoadDirectoryFilesEx(base_path, filter, scan_subdirs) bind(c, name='LoadDirectoryFilesEx') + IMPORT :: C_BOOL, C_CHAR, file_path_list_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: base_path + CHARACTER(kind=C_CHAR), INTENT(in) :: filter + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: scan_subdirs + TYPE(file_path_list_) :: LoadDirectoryFilesEx + END FUNCTION LoadDirectoryFilesEx + + ! FilePathList LoadDroppedFiles(void) + FUNCTION LoadDroppedFiles() BIND(c, name='LoadDroppedFiles') + IMPORT :: file_path_list_ + IMPLICIT NONE + TYPE(file_path_list_) :: LoadDroppedFiles + END FUNCTION LoadDroppedFiles + + ! unsigned char *LoadFileData(const char *fileName, int *dataSize) + FUNCTION LoadFileData(file_name, data_size) BIND(c, name='LoadFileData') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_INT), INTENT(out) :: data_size + TYPE(C_PTR) :: LoadFileData + END FUNCTION LoadFileData + + ! char *LoadFileText(const char *fileName) + FUNCTION LoadFileText(file_name) BIND(c, name='LoadFileText') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(C_PTR) :: LoadFileText + END FUNCTION LoadFileText + + ! Font LoadFont(const char *fileName) + FUNCTION LoadFont(file_name) BIND(c, name='LoadFont') + IMPORT :: C_CHAR, font_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(font_) :: LoadFont + END FUNCTION LoadFont + + ! GlyphInfo *LoadFontData(const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount, int type) + function LoadFontData(file_data, data_size, font_size, codepoints, codepoints_count, type) & + BIND(c, name='LoadFontData') + IMPORT :: C_INT, C_PTR, c_unsigned_char, glyph_info_ + IMPLICIT NONE + INTEGER(kind=c_unsigned_char), INTENT(inout) :: file_data + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoints_count + INTEGER(kind=C_INT), INTENT(in), VALUE :: TYPE + TYPE(C_PTR) :: LoadFontData + END FUNCTION LoadFontData + + ! Font LoadFontEx(const char *fileName, int fontSize, int *codepoints, int codepointsCount) + function LoadFontEx(file_name, font_size, codepoints, codepoints_count) bind(c, name='LoadFontEx') + IMPORT :: C_CHAR, C_INT, font_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoints_count + TYPE(font_) :: LoadFontEx + END FUNCTION LoadFontEx + + ! Font LoadFontFromImage(Image image, Color key, int firstChar) + function LoadFontFromImage(image, key, first_char) bind(c, name='LoadFontFromImage') + IMPORT :: C_INT, color_, font_, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + TYPE(color_), INTENT(in), VALUE :: key + INTEGER(kind=C_INT), INTENT(in), VALUE :: first_char + TYPE(font_) :: LoadFontFromImage + END FUNCTION LoadFontFromImage + + ! Font LoadFontFromMemory(const char *fileType, const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount) + function LoadFontFromMemory(file_, file_data, data_size, font_size, codepoints, codepoints_count) & + BIND(c, name='LoadFontFromMemory') + IMPORT :: C_CHAR, C_INT, c_unsigned_char, font_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_ + INTEGER(kind=c_unsigned_char), INTENT(in) :: file_data + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoints_count + TYPE(font_) :: LoadFontFromMemory + END FUNCTION LoadFontFromMemory + + ! Image LoadImage(const char *fileName) + FUNCTION LoadImage(file_name) BIND(c, name='LoadImage') + IMPORT :: C_CHAR, image_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(image_) :: LoadImage + END FUNCTION LoadImage + + ! Image LoadImageAnim(const char *fileName, int *frames) + FUNCTION LoadImageAnim(file_name, frames) BIND(c, name='LoadImageAnim') + IMPORT :: C_CHAR, C_INT, image_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_INT), INTENT(out) :: frames + TYPE(image_) :: LoadImageAnim + END FUNCTION LoadImageAnim + + ! Color *LoadImageColors(Image image) + FUNCTION LoadImageColors(image) BIND(c, name='LoadImageColors') + IMPORT :: C_PTR, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + TYPE(C_PTR) :: LoadImageColors + END FUNCTION LoadImageColors + + ! Image LoadImageFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) + function LoadImageFromMemory(file_, file_data, data_size) bind(c, name='LoadImageFromMemory') + IMPORT :: C_CHAR, C_INT, c_unsigned_char, image_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_ + INTEGER(kind=c_unsigned_char), INTENT(in) :: file_data + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + TYPE(image_) :: LoadImageFromMemory + END FUNCTION LoadImageFromMemory + + ! Image LoadImageFromScreen(void) + FUNCTION LoadImageFromScreen() BIND(c, name='LoadImageFromScreen') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_) :: LoadImageFromScreen + END FUNCTION LoadImageFromScreen + + ! Image LoadImageFromTexture(Texture2D texture) + FUNCTION LoadImageFromTexture(texture) BIND(c, name='LoadImageFromTexture') + IMPORT :: image_, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(image_) :: LoadImageFromTexture + END FUNCTION LoadImageFromTexture + + ! Color *LoadImagePalette(Image image, int maxPaletteSize, int *colorCount) + function LoadImagePalette(image, max_palette_size, color_count) bind(c, name='LoadImagePalette') + IMPORT :: C_INT, C_PTR, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: max_palette_size + INTEGER(kind=C_INT), INTENT(out) :: color_count + TYPE(C_PTR) :: LoadImagePalette + END FUNCTION LoadImagePalette + + ! Image LoadImageRaw(const char *fileName, int width, int height, int format, int headerSize) + function LoadImageRaw(file_name, width, height, format, header_size) bind(c, name='LoadImageRaw') + IMPORT :: C_CHAR, C_INT, image_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT + INTEGER(kind=C_INT), INTENT(in), VALUE :: header_size + TYPE(image_) :: LoadImageRaw + END FUNCTION LoadImageRaw + + ! Image LoadImageSvg(const char *fileNameOrString, int width, int height) + function LoadImageSvg(file_name_or_string, width, height) bind(c, name='LoadImageSvg') + IMPORT :: C_CHAR, C_INT, image_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name_or_string + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(image_) :: LoadImageSvg + END FUNCTION LoadImageSvg + + ! Material LoadMaterialDefault(void) + FUNCTION LoadMaterialDefault() BIND(c, name='LoadMaterialDefault') + IMPORT :: material_ + IMPLICIT NONE + TYPE(material_) :: LoadMaterialDefault + END FUNCTION LoadMaterialDefault + + ! Material *LoadMaterials(const char *fileName, int *materialCount) + function LoadMaterials(file_name, material_count) bind(c, name='LoadMaterials') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_INT), INTENT(out) :: material_count + TYPE(C_PTR) :: LoadMaterials + END FUNCTION LoadMaterials + + ! Model LoadModel(const char *fileName) + FUNCTION LoadModel(file_name) BIND(c, name='LoadModel') + IMPORT :: C_CHAR, model_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(model_) :: LoadModel + END FUNCTION LoadModel + + ! ModelAnimation *LoadModelAnimations(const char *fileName, int *animCount) + function LoadModelAnimations(file_name, anim_count) bind(c, name='LoadModelAnimations') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + INTEGER(kind=C_INT), INTENT(out) :: anim_count + TYPE(C_PTR) :: LoadModelAnimations + END FUNCTION LoadModelAnimations + + ! Model LoadModelFromMesh(Mesh mesh) + FUNCTION LoadModelFromMesh(mesh) BIND(c, name='LoadModelFromMesh') + IMPORT :: mesh_, model_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in), VALUE :: mesh + TYPE(model_) :: LoadModelFromMesh + END FUNCTION LoadModelFromMesh + + ! Music LoadMusicStream(const char *fileName) + FUNCTION LoadMusicStream(file_name) BIND(c, name='LoadMusicStream') + IMPORT :: C_CHAR, music_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(music_) :: LoadMusicStream + END FUNCTION LoadMusicStream + + ! Music LoadMusicStreamFromMemory(const char *fileType, const unsigned char *data, int dataSize) + function LoadMusicStreamFromMemory(file_, data, data_size) bind(c, name='LoadMusicStreamFromMemory') + IMPORT :: C_CHAR, C_INT, c_unsigned_char, music_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_ + INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + TYPE(music_) :: LoadMusicStreamFromMemory + END FUNCTION LoadMusicStreamFromMemory + + ! int *LoadRandomSequence(unsigned int count, int min, int max) + function LoadRandomSequence(count, min, max) bind(c, name='LoadRandomSequence') + IMPORT :: C_INT, C_PTR, c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: count + INTEGER(kind=C_INT), INTENT(in), VALUE :: min + INTEGER(kind=C_INT), INTENT(in), VALUE :: max + TYPE(C_PTR) :: LoadRandomSequence + END FUNCTION LoadRandomSequence + + ! RenderTexture2D LoadRenderTexture(int width, int height) + FUNCTION LoadRenderTexture(width, height) BIND(c, name='LoadRenderTexture') + IMPORT :: C_INT, render_texture2d_ + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + TYPE(render_texture2d_) :: LoadRenderTexture + END FUNCTION LoadRenderTexture + + ! Shader LoadShader(const char *vsFileName, const char *fsFileName) + FUNCTION LoadShader(vs_file_name, fs_file_name) BIND(c, name='LoadShader') + IMPORT :: C_CHAR, shader_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: vs_file_name + CHARACTER(kind=C_CHAR), INTENT(in) :: fs_file_name + TYPE(shader_) :: LoadShader + END FUNCTION LoadShader + + ! Shader LoadShaderFromMemory(const char *vsCode, const char *fsCode) + function LoadShaderFromMemory(vs_code, fs_code) bind(c, name='LoadShaderFromMemory') + IMPORT :: C_CHAR, shader_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: vs_code + CHARACTER(kind=C_CHAR), INTENT(in) :: fs_code + TYPE(shader_) :: LoadShaderFromMemory + END FUNCTION LoadShaderFromMemory + + ! Sound LoadSound(const char *fileName) + FUNCTION LoadSound(file_name) BIND(c, name='LoadSound') + IMPORT :: C_CHAR, sound_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(sound_) :: LoadSound + END FUNCTION LoadSound + + ! Sound LoadSoundAlias(Sound source) + FUNCTION LoadSoundAlias(source) BIND(c, name='LoadSoundAlias') + IMPORT :: sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: source + TYPE(sound_) :: LoadSoundAlias + END FUNCTION LoadSoundAlias + + ! Sound LoadSoundFromWave(Wave wave) + FUNCTION LoadSoundFromWave(wave) BIND(c, name='LoadSoundFromWave') + IMPORT :: sound_, wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in), VALUE :: wave + TYPE(sound_) :: LoadSoundFromWave + END FUNCTION LoadSoundFromWave + + ! Texture2D LoadTexture(const char *fileName) + FUNCTION LoadTexture(file_name) BIND(c, name='LoadTexture') + IMPORT :: C_CHAR, texture2d_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(texture2d_) :: LoadTexture + END FUNCTION LoadTexture + + ! TextureCubemap LoadTextureCubemap(Image image, int layout) + FUNCTION LoadTextureCubemap(image, layout) BIND(c, name='LoadTextureCubemap') + IMPORT :: C_INT, image_, texture_cubemap_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + INTEGER(kind=C_INT), INTENT(in), VALUE :: layout + TYPE(texture_cubemap_) :: LoadTextureCubemap + END FUNCTION LoadTextureCubemap + + ! Texture2D LoadTextureFromImage(Image image) + FUNCTION LoadTextureFromImage(image) BIND(c, name='LoadTextureFromImage') + IMPORT :: image_, texture2d_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + TYPE(texture2d_) :: LoadTextureFromImage + END FUNCTION LoadTextureFromImage + + ! char *LoadUTF8(const int *codepoints, int length) + FUNCTION LoadUTF8(codepoints, length) BIND(c, name='LoadUTF8') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(out) :: codepoints(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: length + TYPE(C_PTR) :: LoadUTF8 + END FUNCTION LoadUTF8 + + ! VrStereoConfig LoadVrStereoConfig(VrDeviceInfo device) + FUNCTION LoadVrStereoConfig(device) BIND(c, name='LoadVrStereoConfig') + IMPORT :: vr_device_info_, vr_stereo_config_ + IMPLICIT NONE + TYPE(vr_device_info_), INTENT(in), VALUE :: device + TYPE(vr_stereo_config_) :: LoadVrStereoConfig + END FUNCTION LoadVrStereoConfig + + ! Wave LoadWave(const char *fileName) + FUNCTION LoadWave(file_name) BIND(c, name='LoadWave') + IMPORT :: C_CHAR, wave_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(wave_) :: LoadWave + END FUNCTION LoadWave + + ! Wave LoadWaveFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) + function LoadWaveFromMemory(file_, file_data, data_size) bind(c, name='LoadWaveFromMemory') + IMPORT :: C_CHAR, C_INT, c_unsigned_char, wave_ + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_ + INTEGER(kind=c_unsigned_char), INTENT(in) :: file_data + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + TYPE(wave_) :: LoadWaveFromMemory + END FUNCTION LoadWaveFromMemory + + ! float *LoadWaveSamples(Wave wave) + FUNCTION LoadWaveSamples(wave) BIND(c, name='LoadWaveSamples') + IMPORT :: C_PTR, wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in), VALUE :: wave + TYPE(C_PTR) :: LoadWaveSamples + END FUNCTION LoadWaveSamples +END INTERFACE + +END MODULE RaylibLoadMethods diff --git a/src/modules/RaylibInterface/src/RaylibMath.F90 b/src/modules/RaylibInterface/src/RaylibMath.F90 new file mode 100644 index 000000000..5353f951c --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibMath.F90 @@ -0,0 +1,1140 @@ +! raylib_math.f90 +! +! Fortran 2018 interface bindings to `raymath.h`. +! +! Author: Philipp Engel +! Licence: ISC +MODULE raylib_math +USE, INTRINSIC :: ISO_C_BINDING +USE :: raylib +IMPLICIT NONE(TYPE, EXTERNAL) +PRIVATE + +! float3 +TYPE, BIND(c), PUBLIC :: float3_ + REAL(kind=C_FLOAT) :: v(0:2) = 0.0 +END TYPE float3_ + +! float16 +TYPE, BIND(c), PUBLIC :: float16_ + REAL(kind=C_FLOAT) :: v(0:15) = 0.0 +END TYPE float16_ + +PUBLIC :: clamp +PUBLIC :: float_equals +PUBLIC :: lerp +PUBLIC :: matrix_add +PUBLIC :: matrix_determinant +PUBLIC :: matrix_frustum +PUBLIC :: matrix_identity +PUBLIC :: matrix_invert +PUBLIC :: matrix_look_at +PUBLIC :: matrix_multiply +PUBLIC :: matrix_ortho +PUBLIC :: matrix_perspective +PUBLIC :: matrix_rotate +PUBLIC :: matrix_rotate_x +PUBLIC :: matrix_rotate_xyz +PUBLIC :: matrix_rotate_y +PUBLIC :: matrix_rotate_z +PUBLIC :: matrix_rotate_zyx +PUBLIC :: matrix_scale +PUBLIC :: matrix_subtract +PUBLIC :: matrix_to_float_v +PUBLIC :: matrix_trace +PUBLIC :: matrix_translate +PUBLIC :: matrix_transpose +PUBLIC :: normalize +PUBLIC :: quaternion_add +PUBLIC :: quaternion_add_value +PUBLIC :: quaternion_divide +PUBLIC :: quaternion_equals +PUBLIC :: quaternion_from_axis_angle +PUBLIC :: quaternion_from_euler +PUBLIC :: quaternion_from_matrix +PUBLIC :: quaternion_from_vector3_to_vector3 +PUBLIC :: quaternion_identity +PUBLIC :: quaternion_invert +PUBLIC :: quaternion_length +PUBLIC :: quaternion_lerp +PUBLIC :: quaternion_multiply +PUBLIC :: quaternion_nlerp +PUBLIC :: quaternion_normalize +PUBLIC :: quaternion_scale +PUBLIC :: quaternion_slerp +PUBLIC :: quaternion_subtract +PUBLIC :: quaternion_subtract_value +PUBLIC :: quaternion_to_axis_angle +PUBLIC :: quaternion_to_euler +PUBLIC :: quaternion_to_matrix +PUBLIC :: quaternion_transform +PUBLIC :: remap +PUBLIC :: vector2_add +PUBLIC :: vector2_add_value +PUBLIC :: vector2_angle +PUBLIC :: vector2_clamp +PUBLIC :: vector2_clamp_value +PUBLIC :: vector2_distance +PUBLIC :: vector2_distance_sqr +PUBLIC :: vector2_divide +PUBLIC :: vector2_dot_product +PUBLIC :: vector2_equals +PUBLIC :: vector2_invert +PUBLIC :: vector2_length +PUBLIC :: vector2_length_sqr +PUBLIC :: vector2_lerp +PUBLIC :: vector2_line_angle +PUBLIC :: vector2_move_towards +PUBLIC :: vector2_multiply +PUBLIC :: vector2_negate +PUBLIC :: vector2_normalize +PUBLIC :: vector2_one +PUBLIC :: vector2_reflect +PUBLIC :: vector2_rotate +PUBLIC :: vector2_scale +PUBLIC :: vector2_subtract +PUBLIC :: vector2_subtract_value +PUBLIC :: vector2_transform +PUBLIC :: vector2_zero +PUBLIC :: vector3_add +PUBLIC :: vector3_add_value +PUBLIC :: vector3_angle +PUBLIC :: vector3_barycenter +PUBLIC :: vector3_clamp +PUBLIC :: vector3_clamp_value +PUBLIC :: vector3_cross_product +PUBLIC :: vector3_distance +PUBLIC :: vector3_distance_sqr +PUBLIC :: vector3_divide +PUBLIC :: vector3_dot_product +PUBLIC :: vector3_equals +PUBLIC :: vector3_invert +PUBLIC :: vector3_length +PUBLIC :: vector3_length_sqr +PUBLIC :: vector3_lerp +PUBLIC :: vector3_max +PUBLIC :: vector3_min +PUBLIC :: vector3_multiply +PUBLIC :: vector3_negate +PUBLIC :: vector3_normalize +PUBLIC :: vector3_one +PUBLIC :: vector3_ortho_normalize +PUBLIC :: vector3_perpendicular +PUBLIC :: vector3_reflect +PUBLIC :: vector3_refract +PUBLIC :: vector3_rotate_by_axis_angle +PUBLIC :: vector3_rotate_by_quaternion +PUBLIC :: vector3_scale +PUBLIC :: vector3_subtract +PUBLIC :: vector3_subtract_value +PUBLIC :: vector3_to_float_v +PUBLIC :: vector3_transform +PUBLIC :: vector3_unproject +PUBLIC :: vector3_zero +PUBLIC :: wrap + +INTERFACE + ! float Clamp(float value, float min, float max) + FUNCTION clamp(VALUE, min, max) BIND(c, name='Clamp') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: min + REAL(kind=C_FLOAT), INTENT(in), VALUE :: max + REAL(kind=C_FLOAT) :: clamp + END FUNCTION clamp + + ! int FloatEquals(float x, float y) + FUNCTION float_equals(x, y) BIND(c, name='FloatEquals') + IMPORT :: C_FLOAT, C_INT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: x + REAL(kind=C_FLOAT), INTENT(in), VALUE :: y + INTEGER(kind=C_INT) :: float_equals + END FUNCTION float_equals + + ! float Lerp(float start, float end, float amount) + FUNCTION lerp(start, END, amount) BIND(c, name='Lerp') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start + REAL(kind=C_FLOAT), INTENT(in), VALUE :: END + REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount + REAL(kind=C_FLOAT) :: lerp + END FUNCTION lerp + + ! Matrix MatrixAdd(Matrix left, Matrix right) + FUNCTION matrix_add(left, right) BIND(c, name='MatrixAdd') + IMPORT :: matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: left + TYPE(matrix_), INTENT(in), VALUE :: right + TYPE(matrix_) :: matrix_add + END FUNCTION matrix_add + + ! float MatrixDeterminant(Matrix mat) + FUNCTION matrix_determinant(mat) BIND(c, name='MatrixDeterminant') + IMPORT :: C_FLOAT, matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: mat + REAL(kind=C_FLOAT) :: matrix_determinant + END FUNCTION matrix_determinant + + ! Matrix MatrixFrustum(double left, double right, double bottom, double top, double near, double far) + function matrix_frustum(left, right, bottom, top, near, far) bind(c, name='MatrixFrustum') + IMPORT :: C_DOUBLE, matrix_ + IMPLICIT NONE + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: left + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: right + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: bottom + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: top + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: near + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: far + TYPE(matrix_) :: matrix_frustum + END FUNCTION matrix_frustum + + ! Matrix MatrixIdentity(void) + FUNCTION matrix_identity() BIND(c, name='MatrixIdentity') + IMPORT :: matrix_ + IMPLICIT NONE + TYPE(matrix_) :: matrix_identity + END FUNCTION matrix_identity + + ! Matrix MatrixInvert(Matrix mat) + FUNCTION matrix_invert(mat) BIND(c, name='MatrixInvert') + IMPORT :: matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: mat + TYPE(matrix_) :: matrix_invert + END FUNCTION matrix_invert + + ! Matrix MatrixLookAt(Vector3 eye, Vector3 target, Vector3 up) + FUNCTION matrix_look_at(eye, TARGET, up) BIND(c, name='MatrixLookAt') + IMPORT :: matrix_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: eye + TYPE(vector3_), INTENT(in), VALUE :: TARGET + TYPE(vector3_), INTENT(in), VALUE :: up + TYPE(matrix_) :: matrix_look_at + END FUNCTION matrix_look_at + + ! Matrix MatrixMultiply(Matrix left, Matrix right) + FUNCTION matrix_multiply(left, right) BIND(c, name='MatrixMultiply') + IMPORT :: matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: left + TYPE(matrix_), INTENT(in), VALUE :: right + TYPE(matrix_) :: matrix_multiply + END FUNCTION matrix_multiply + + ! Matrix MatrixOrtho(double left, double right, double bottom, double top, double near, double far) + function matrix_ortho(left, right, bottom, top, near, far) bind(c, name='MatrixOrtho') + IMPORT :: C_DOUBLE, matrix_ + IMPLICIT NONE + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: left + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: right + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: bottom + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: top + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: near + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: far + TYPE(matrix_) :: matrix_ortho + END FUNCTION matrix_ortho + + ! Matrix MatrixPerspective(double fovy, double aspect, double near, double far) + function matrix_perspective(fovy, aspect, near, far) bind(c, name='MatrixPerspective') + IMPORT :: C_DOUBLE, matrix_ + IMPLICIT NONE + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: fovy + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: aspect + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: near + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: far + TYPE(matrix_) :: matrix_perspective + END FUNCTION matrix_perspective + + ! Matrix MatrixRotate(Vector3 axis, float angle) + FUNCTION matrix_rotate(axis, angle) BIND(c, name='MatrixRotate') + IMPORT :: C_FLOAT, matrix_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: axis + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + TYPE(matrix_) :: matrix_rotate + END FUNCTION matrix_rotate + + ! Matrix MatrixRotateX(float angle) + FUNCTION matrix_rotate_x(angle) BIND(c, name='MatrixRotateX') + IMPORT :: C_FLOAT, matrix_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + TYPE(matrix_) :: matrix_rotate_x + END FUNCTION matrix_rotate_x + + ! Matrix MatrixRotateXYZ(Vector3 angle) + FUNCTION matrix_rotate_xyz(angle) BIND(c, name='MatrixRotateXYZ') + IMPORT :: matrix_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: angle + TYPE(matrix_) :: matrix_rotate_xyz + END FUNCTION matrix_rotate_xyz + + ! Matrix MatrixRotateY(float angle) + FUNCTION matrix_rotate_y(angle) BIND(c, name='MatrixRotateY') + IMPORT :: C_FLOAT, matrix_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + TYPE(matrix_) :: matrix_rotate_y + END FUNCTION matrix_rotate_y + + ! Matrix MatrixRotateZ(float angle) + FUNCTION matrix_rotate_z(angle) BIND(c, name='MatrixRotateZ') + IMPORT :: C_FLOAT, matrix_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + TYPE(matrix_) :: matrix_rotate_z + END FUNCTION matrix_rotate_z + + ! Matrix MatrixRotateZYX(Vector3 angle) + FUNCTION matrix_rotate_zyx(angle) BIND(c, name='MatrixRotateZYX') + IMPORT :: matrix_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: angle + TYPE(matrix_) :: matrix_rotate_zyx + END FUNCTION matrix_rotate_zyx + + ! Matrix MatrixScale(float x, float y, float z) + FUNCTION matrix_scale(x, y, z) BIND(c, name='MatrixScale') + IMPORT :: C_FLOAT, matrix_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: x + REAL(kind=C_FLOAT), INTENT(in), VALUE :: y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: z + TYPE(matrix_) :: matrix_scale + END FUNCTION matrix_scale + + ! Matrix MatrixSubtract(Matrix left, Matrix right) + FUNCTION matrix_subtract(left, right) BIND(c, name='MatrixSubtract') + IMPORT :: matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: left + TYPE(matrix_), INTENT(in), VALUE :: right + TYPE(matrix_) :: matrix_subtract + END FUNCTION matrix_subtract + + ! float16 MatrixToFloatV(Matrix mat) + FUNCTION matrix_to_float_v(mat) BIND(c, name='MatrixToFloatV') + IMPORT :: float16_, matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: mat + TYPE(float16_) :: matrix_to_float_v + END FUNCTION matrix_to_float_v + + ! float MatrixTrace(Matrix mat) + FUNCTION matrix_trace(mat) BIND(c, name='MatrixTrace') + IMPORT :: C_FLOAT, matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: mat + REAL(kind=C_FLOAT) :: matrix_trace + END FUNCTION matrix_trace + + ! Matrix MatrixTranslate(float x, float y, float z) + FUNCTION matrix_translate(x, y, z) BIND(c, name='MatrixTranslate') + IMPORT :: C_FLOAT, matrix_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: x + REAL(kind=C_FLOAT), INTENT(in), VALUE :: y + REAL(kind=C_FLOAT), INTENT(in), VALUE :: z + TYPE(matrix_) :: matrix_translate + END FUNCTION matrix_translate + + ! Matrix MatrixTranspose(Matrix mat) + FUNCTION matrix_transpose(mat) BIND(c, name='MatrixTranspose') + IMPORT :: matrix_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: mat + TYPE(matrix_) :: matrix_transpose + END FUNCTION matrix_transpose + + ! float Normalize(float value, float start, float end) + FUNCTION normalize(VALUE, start, END) BIND(c, name='Normalize') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: start + REAL(kind=C_FLOAT), INTENT(in), VALUE :: END + REAL(kind=C_FLOAT) :: normalize + END FUNCTION normalize + + ! Quaternion QuaternionAdd(Quaternion q1, Quaternion q2) + FUNCTION quaternion_add(q1, q2) BIND(c, name='QuaternionAdd') + IMPORT :: quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q1 + TYPE(quaternion_), INTENT(in), VALUE :: q2 + TYPE(quaternion_) :: quaternion_add + END FUNCTION quaternion_add + + ! Quaternion QuaternionAddValue(Quaternion q, float add) + FUNCTION quaternion_add_value(q, add) BIND(c, name='QuaternionAddValue') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + REAL(kind=C_FLOAT), INTENT(in), VALUE :: add + TYPE(quaternion_) :: quaternion_add_value + END FUNCTION quaternion_add_value + + ! Quaternion QuaternionDivide(Quaternion q1, Quaternion q2) + FUNCTION quaternion_divide(q1, q2) BIND(c, name='QuaternionDivide') + IMPORT :: quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q1 + TYPE(quaternion_), INTENT(in), VALUE :: q2 + TYPE(quaternion_) :: quaternion_divide + END FUNCTION quaternion_divide + + ! int QuaternionEquals(Quaternion p, Quaternion q) + FUNCTION quaternion_equals(p, q) BIND(c, name='QuaternionEquals') + IMPORT :: C_INT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: p + TYPE(quaternion_), INTENT(in), VALUE :: q + INTEGER(kind=C_INT) :: quaternion_equals + END FUNCTION quaternion_equals + + ! Quaternion QuaternionFromAxisAngle(Vector3 axis, float angle) + function quaternion_from_axis_angle(axis, angle) bind(c, name='QuaternionFromAxisAngle') + IMPORT :: C_FLOAT, quaternion_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: axis + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + TYPE(quaternion_) :: quaternion_from_axis_angle + END FUNCTION quaternion_from_axis_angle + + ! Quaternion QuaternionFromEuler(float pitch, float yaw, float roll) + function quaternion_from_euler(pitch, yaw, roll) bind(c, name='QuaternionFromEuler') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch + REAL(kind=C_FLOAT), INTENT(in), VALUE :: yaw + REAL(kind=C_FLOAT), INTENT(in), VALUE :: roll + TYPE(quaternion_) :: quaternion_from_euler + END FUNCTION quaternion_from_euler + + ! Quaternion QuaternionFromMatrix(Matrix mat) + FUNCTION quaternion_from_matrix(mat) BIND(c, name='QuaternionFromMatrix') + IMPORT :: matrix_, quaternion_ + IMPLICIT NONE + TYPE(matrix_), INTENT(in), VALUE :: mat + TYPE(quaternion_) :: quaternion_from_matrix + END FUNCTION quaternion_from_matrix + + ! Quaternion QuaternionFromVector3ToVector3(Vector3 from, Vector3 to) + function quaternion_from_vector3_to_vector3(from, to) bind(c, name='QuaternionFromVector3ToVector3') + IMPORT :: quaternion_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: from + TYPE(vector3_), INTENT(in), VALUE :: to + TYPE(quaternion_) :: quaternion_from_vector3_to_vector3 + END FUNCTION quaternion_from_vector3_to_vector3 + + ! Quaternion QuaternionIdentity(void) + FUNCTION quaternion_identity() BIND(c, name='QuaternionIdentity') + IMPORT :: quaternion_ + IMPLICIT NONE + TYPE(quaternion_) :: quaternion_identity + END FUNCTION quaternion_identity + + ! Quaternion QuaternionInvert(Quaternion q) + FUNCTION quaternion_invert(q) BIND(c, name='QuaternionInvert') + IMPORT :: quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + TYPE(quaternion_) :: quaternion_invert + END FUNCTION quaternion_invert + + ! float QuaternionLength(Quaternion q) + FUNCTION quaternion_length(q) BIND(c, name='QuaternionLength') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + REAL(kind=C_FLOAT) :: quaternion_length + END FUNCTION quaternion_length + + ! Quaternion QuaternionLerp(Quaternion q1, Quaternion q2, float amount) + FUNCTION quaternion_lerp(q1, q2, amount) BIND(c, name='QuaternionLerp') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q1 + TYPE(quaternion_), INTENT(in), VALUE :: q2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount + TYPE(quaternion_) :: quaternion_lerp + END FUNCTION quaternion_lerp + + ! Quaternion QuaternionMultiply(Quaternion q1, Quaternion q2) + FUNCTION quaternion_multiply(q1, q2) BIND(c, name='QuaternionMultiply') + IMPORT :: quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q1 + TYPE(quaternion_), INTENT(in), VALUE :: q2 + TYPE(quaternion_) :: quaternion_multiply + END FUNCTION quaternion_multiply + + ! Quaternion QuaternionNlerp(Quaternion q1, Quaternion q2, float amount) + FUNCTION quaternion_nlerp(q1, q2, amount) BIND(c, name='QuaternionNlerp') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q1 + TYPE(quaternion_), INTENT(in), VALUE :: q2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount + TYPE(quaternion_) :: quaternion_nlerp + END FUNCTION quaternion_nlerp + + ! Quaternion QuaternionNormalize(Quaternion q) + FUNCTION quaternion_normalize(q) BIND(c, name='QuaternionNormalize') + IMPORT :: quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + TYPE(quaternion_) :: quaternion_normalize + END FUNCTION quaternion_normalize + + ! Quaternion QuaternionScale(Quaternion q, float mul) + FUNCTION quaternion_scale(q, mul) BIND(c, name='QuaternionScale') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + REAL(kind=C_FLOAT), INTENT(in), VALUE :: mul + TYPE(quaternion_) :: quaternion_scale + END FUNCTION quaternion_scale + + ! Quaternion QuaternionSlerp(Quaternion q1, Quaternion q2, float amount) + FUNCTION quaternion_slerp(q1, q2, amount) BIND(c, name='QuaternionSlerp') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q1 + TYPE(quaternion_), INTENT(in), VALUE :: q2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount + TYPE(quaternion_) :: quaternion_slerp + END FUNCTION quaternion_slerp + + ! Quaternion QuaternionSubtract(Quaternion q1, Quaternion q2) + FUNCTION quaternion_subtract(q1, q2) BIND(c, name='QuaternionSubtract') + IMPORT :: quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q1 + TYPE(quaternion_), INTENT(in), VALUE :: q2 + TYPE(quaternion_) :: quaternion_subtract + END FUNCTION quaternion_subtract + + ! Quaternion QuaternionSubtractValue(Quaternion q, float sub) + function quaternion_subtract_value(q, sub) bind(c, name='QuaternionSubtractValue') + IMPORT :: C_FLOAT, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + REAL(kind=C_FLOAT), INTENT(in), VALUE :: sub + TYPE(quaternion_) :: quaternion_subtract_value + END FUNCTION quaternion_subtract_value + + ! void QuaternionToAxisAngle(Quaternion q, Vector3 *outAxis, float *outAngle) + subroutine quaternion_to_axis_angle(q, out_axis, out_angle) bind(c, name='QuaternionToAxisAngle') + IMPORT :: C_FLOAT, quaternion_, vector3_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + TYPE(vector3_), INTENT(inout) :: out_axis(*) + REAL(kind=C_FLOAT), INTENT(out) :: out_angle + END SUBROUTINE quaternion_to_axis_angle + + ! Vector3 QuaternionToEuler(Quaternion q) + FUNCTION quaternion_to_euler(q) BIND(c, name='QuaternionToEuler') + IMPORT :: quaternion_, vector3_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + TYPE(vector3_) :: quaternion_to_euler + END FUNCTION quaternion_to_euler + + ! Matrix QuaternionToMatrix(Quaternion q) + FUNCTION quaternion_to_matrix(q) BIND(c, name='QuaternionToMatrix') + IMPORT :: matrix_, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + TYPE(matrix_) :: quaternion_to_matrix + END FUNCTION quaternion_to_matrix + + ! Quaternion QuaternionTransform(Quaternion q, Matrix mat) + FUNCTION quaternion_transform(q, mat) BIND(c, name='QuaternionTransform') + IMPORT :: matrix_, quaternion_ + IMPLICIT NONE + TYPE(quaternion_), INTENT(in), VALUE :: q + TYPE(matrix_), INTENT(in), VALUE :: mat + TYPE(quaternion_) :: quaternion_transform + END FUNCTION quaternion_transform + + ! float Remap(float value, float inputStart, float inputEnd, float outputStart, float outputEnd) + function remap(value, input_start, input_end, output_start, output_end) bind(c, name='Remap') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: input_start + REAL(kind=C_FLOAT), INTENT(in), VALUE :: input_end + REAL(kind=C_FLOAT), INTENT(in), VALUE :: output_start + REAL(kind=C_FLOAT), INTENT(in), VALUE :: output_end + REAL(kind=C_FLOAT) :: remap + END FUNCTION remap + + ! Vector2 Vector2Add(Vector2 v1, Vector2 v2) + FUNCTION vector2_add(v1, v2) BIND(c, name='Vector2Add') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + TYPE(vector2_) :: vector2_add + END FUNCTION vector2_add + + ! Vector2 Vector2AddValue(Vector2 v, float add) + FUNCTION vector2_add_value(v, add) BIND(c, name='Vector2AddValue') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: add + TYPE(vector2_) :: vector2_add_value + END FUNCTION vector2_add_value + + ! float Vector2Angle(Vector2 v1, Vector2 v2) + FUNCTION vector2_angle(v1, v2) BIND(c, name='Vector2Angle') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector2_angle + END FUNCTION vector2_angle + + ! Vector2 Vector2Clamp(Vector2 v, Vector2 min, Vector2 max) + FUNCTION vector2_clamp(v, min, max) BIND(c, name='Vector2Clamp') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + TYPE(vector2_), INTENT(in), VALUE :: min + TYPE(vector2_), INTENT(in), VALUE :: max + TYPE(vector2_) :: vector2_clamp + END FUNCTION vector2_clamp + + ! Vector2 Vector2ClampValue(Vector2 v, float min, float max) + FUNCTION vector2_clamp_value(v, min, max) BIND(c, name='Vector2ClampValue') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: min + REAL(kind=C_FLOAT), INTENT(in), VALUE :: max + TYPE(vector2_) :: vector2_clamp_value + END FUNCTION vector2_clamp_value + + ! float Vector2Distance(Vector2 v1, Vector2 v2) + FUNCTION vector2_distance(v1, v2) BIND(c, name='Vector2Distance') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector2_distance + END FUNCTION vector2_distance + + ! float Vector2DistanceSqr(Vector2 v1, Vector2 v2) + FUNCTION vector2_distance_sqr(v1, v2) BIND(c, name='Vector2DistanceSqr') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector2_distance_sqr + END FUNCTION vector2_distance_sqr + + ! Vector2 Vector2Divide(Vector2 v1, Vector2 v2) + FUNCTION vector2_divide(v1, v2) BIND(c, name='Vector2Divide') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + TYPE(vector2_) :: vector2_divide + END FUNCTION vector2_divide + + ! float Vector2DotProduct(Vector2 v1, Vector2 v2) + FUNCTION vector2_dot_product(v1, v2) BIND(c, name='Vector2DotProduct') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector2_dot_product + END FUNCTION vector2_dot_product + + ! int Vector2Equals(Vector2 p, Vector2 q) + FUNCTION vector2_equals(p, q) BIND(c, name='Vector2Equals') + IMPORT :: C_INT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: p + TYPE(vector2_), INTENT(in), VALUE :: q + INTEGER(kind=C_INT) :: vector2_equals + END FUNCTION vector2_equals + + ! Vector2 Vector2Invert(Vector2 v) + FUNCTION vector2_invert(v) BIND(c, name='Vector2Invert') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + TYPE(vector2_) :: vector2_invert + END FUNCTION vector2_invert + + ! float Vector2Length(Vector2 v) + FUNCTION vector2_length(v) BIND(c, name='Vector2Length') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT) :: vector2_length + END FUNCTION vector2_length + + ! float Vector2LengthSqr(Vector2 v) + FUNCTION vector2_length_sqr(v) BIND(c, name='Vector2LengthSqr') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT) :: vector2_length_sqr + END FUNCTION vector2_length_sqr + + ! Vector2 Vector2Lerp(Vector2 v1, Vector2 v2, float amount) + FUNCTION vector2_lerp(v1, v2, amount) BIND(c, name='Vector2Lerp') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount + TYPE(vector2_) :: vector2_lerp + END FUNCTION vector2_lerp + + ! float Vector2LineAngle(Vector2 start, Vector2 end) + FUNCTION vector2_line_angle(start, END) BIND(c, name='Vector2LineAngle') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: start + TYPE(vector2_), INTENT(in), VALUE :: END + REAL(kind=C_FLOAT) :: vector2_line_angle + END FUNCTION vector2_line_angle + + ! Vector2 Vector2MoveTowards(Vector2 v, Vector2 target, float maxDistance) + function vector2_move_towards(v, target, max_distance) bind(c, name='Vector2MoveTowards') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + TYPE(vector2_), INTENT(in), VALUE :: TARGET + REAL(kind=C_FLOAT), INTENT(in), VALUE :: max_distance + TYPE(vector2_) :: vector2_move_towards + END FUNCTION vector2_move_towards + + ! Vector2 Vector2Multiply(Vector2 v1, Vector2 v2) + FUNCTION vector2_multiply(v1, v2) BIND(c, name='Vector2Multiply') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + TYPE(vector2_) :: vector2_multiply + END FUNCTION vector2_multiply + + ! Vector2 Vector2Negate(Vector2 v) + FUNCTION vector2_negate(v) BIND(c, name='Vector2Negate') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + TYPE(vector2_) :: vector2_negate + END FUNCTION vector2_negate + + ! Vector2 Vector2Normalize(Vector2 v) + FUNCTION vector2_normalize(v) BIND(c, name='Vector2Normalize') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + TYPE(vector2_) :: vector2_normalize + END FUNCTION vector2_normalize + + ! Vector2 Vector2One(void) + FUNCTION vector2_one() BIND(c, name='Vector2One') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_) :: vector2_one + END FUNCTION vector2_one + + ! Vector2 Vector2Reflect(Vector2 v, Vector2 normal) + FUNCTION vector2_reflect(v, normal) BIND(c, name='Vector2Reflect') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + TYPE(vector2_), INTENT(in), VALUE :: normal + TYPE(vector2_) :: vector2_reflect + END FUNCTION vector2_reflect + + ! Vector2 Vector2Rotate(Vector2 v, float angle) + FUNCTION vector2_rotate(v, angle) BIND(c, name='Vector2Rotate') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + TYPE(vector2_) :: vector2_rotate + END FUNCTION vector2_rotate + + ! Vector2 Vector2Scale(Vector2 v, float scale) + FUNCTION vector2_scale(v, scale) BIND(c, name='Vector2Scale') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale + TYPE(vector2_) :: vector2_scale + END FUNCTION vector2_scale + + ! Vector2 Vector2Subtract(Vector2 v1, Vector2 v2) + FUNCTION vector2_subtract(v1, v2) BIND(c, name='Vector2Subtract') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v1 + TYPE(vector2_), INTENT(in), VALUE :: v2 + TYPE(vector2_) :: vector2_subtract + END FUNCTION vector2_subtract + + ! Vector2 Vector2SubtractValue(Vector2 v, float sub) + FUNCTION vector2_subtract_value(v, sub) BIND(c, name='Vector2SubtractValue') + IMPORT :: C_FLOAT, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: sub + TYPE(vector2_) :: vector2_subtract_value + END FUNCTION vector2_subtract_value + + ! Vector2 Vector2Transform(Vector2 v, Matrix mat) + FUNCTION vector2_transform(v, mat) BIND(c, name='Vector2Transform') + IMPORT :: matrix_, vector2_ + IMPLICIT NONE + TYPE(vector2_), INTENT(in), VALUE :: v + TYPE(matrix_), INTENT(in), VALUE :: mat + TYPE(vector2_) :: vector2_transform + END FUNCTION vector2_transform + + ! Vector2 Vector2Zero(void) + FUNCTION vector2_zero() BIND(c, name='Vector2Zero') + IMPORT :: vector2_ + IMPLICIT NONE + TYPE(vector2_) :: vector2_zero + END FUNCTION vector2_zero + + ! Vector3 Vector3Add(Vector3 v1, Vector3 v2) + FUNCTION vector3_add(v1, v2) BIND(c, name='Vector3Add') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_) :: vector3_add + END FUNCTION vector3_add + + ! Vector3 Vector3AddValue(Vector3 v, float add) + FUNCTION vector3_add_value(v, add) BIND(c, name='Vector3AddValue') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: add + TYPE(vector3_) :: vector3_add_value + END FUNCTION vector3_add_value + + ! float Vector3Angle(Vector3 v1, Vector3 v2) + FUNCTION vector3_angle(v1, v2) BIND(c, name='Vector3Angle') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector3_angle + END FUNCTION vector3_angle + + ! Vector3 Vector3Barycenter(Vector3 p, Vector3 a, Vector3 b, Vector3 c) + FUNCTION vector3_barycenter(p, a, b, c) BIND(c, name='Vector3Barycenter') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: p + TYPE(vector3_), INTENT(in), VALUE :: a + TYPE(vector3_), INTENT(in), VALUE :: b + TYPE(vector3_), INTENT(in), VALUE :: c + TYPE(vector3_) :: vector3_barycenter + END FUNCTION vector3_barycenter + + ! Vector3 Vector3Clamp(Vector3 v, Vector3 min, Vector3 max) + FUNCTION vector3_clamp(v, min, max) BIND(c, name='Vector3Clamp') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_), INTENT(in), VALUE :: min + TYPE(vector3_), INTENT(in), VALUE :: max + TYPE(vector3_) :: vector3_clamp + END FUNCTION vector3_clamp + + ! Vector3 Vector3ClampValue(Vector3 v, float min, float max) + FUNCTION vector3_clamp_value(v, min, max) BIND(c, name='Vector3ClampValue') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: min + REAL(kind=C_FLOAT), INTENT(in), VALUE :: max + TYPE(vector3_) :: vector3_clamp_value + END FUNCTION vector3_clamp_value + + ! Vector3 Vector3CrossProduct(Vector3 v1, Vector3 v2) + FUNCTION vector3_cross_product(v1, v2) BIND(c, name='Vector3CrossProduct') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_) :: vector3_cross_product + END FUNCTION vector3_cross_product + + ! float Vector3Distance(Vector3 v1, Vector3 v2) + FUNCTION vector3_distance(v1, v2) BIND(c, name='Vector3Distance') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector3_distance + END FUNCTION vector3_distance + + ! float Vector3DistanceSqr(Vector3 v1, Vector3 v2) + FUNCTION vector3_distance_sqr(v1, v2) BIND(c, name='Vector3DistanceSqr') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector3_distance_sqr + END FUNCTION vector3_distance_sqr + + ! Vector3 Vector3Divide(Vector3 v1, Vector3 v2) + FUNCTION vector3_divide(v1, v2) BIND(c, name='Vector3Divide') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_) :: vector3_divide + END FUNCTION vector3_divide + + ! float Vector3DotProduct(Vector3 v1, Vector3 v2) + FUNCTION vector3_dot_product(v1, v2) BIND(c, name='Vector3DotProduct') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT) :: vector3_dot_product + END FUNCTION vector3_dot_product + + ! int Vector3Equals(Vector3 p, Vector3 q) + FUNCTION vector3_equals(p, q) BIND(c, name='Vector3Equals') + IMPORT :: C_INT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: p + TYPE(vector3_), INTENT(in), VALUE :: q + INTEGER(kind=C_INT) :: vector3_equals + END FUNCTION vector3_equals + + ! Vector3 Vector3Invert(Vector3 v) + FUNCTION vector3_invert(v) BIND(c, name='Vector3Invert') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_) :: vector3_invert + END FUNCTION vector3_invert + + ! float Vector3Length(const Vector3 v) + FUNCTION vector3_length(v) BIND(c, name='Vector3Length') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT) :: vector3_length + END FUNCTION vector3_length + + ! float Vector3LengthSqr(const Vector3 v) + FUNCTION vector3_length_sqr(v) BIND(c, name='Vector3LengthSqr') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT) :: vector3_length_sqr + END FUNCTION vector3_length_sqr + + ! Vector3 Vector3Lerp(Vector3 v1, Vector3 v2, float amount) + FUNCTION vector3_lerp(v1, v2, amount) BIND(c, name='Vector3Lerp') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + REAL(kind=C_FLOAT), INTENT(in), VALUE :: amount + TYPE(vector3_) :: vector3_lerp + END FUNCTION vector3_lerp + + ! Vector3 Vector3Max(Vector3 v1, Vector3 v2) + FUNCTION vector3_max(v1, v2) BIND(c, name='Vector3Max') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_) :: vector3_max + END FUNCTION vector3_max + + ! Vector3 Vector3Min(Vector3 v1, Vector3 v2) + FUNCTION vector3_min(v1, v2) BIND(c, name='Vector3Min') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_) :: vector3_min + END FUNCTION vector3_min + + ! Vector3 Vector3Multiply(Vector3 v1, Vector3 v2) + FUNCTION vector3_multiply(v1, v2) BIND(c, name='Vector3Multiply') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_) :: vector3_multiply + END FUNCTION vector3_multiply + + ! Vector3 Vector3Negate(Vector3 v) + FUNCTION vector3_negate(v) BIND(c, name='Vector3Negate') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_) :: vector3_negate + END FUNCTION vector3_negate + + ! Vector3 Vector3Normalize(Vector3 v) + FUNCTION vector3_normalize(v) BIND(c, name='Vector3Normalize') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_) :: vector3_normalize + END FUNCTION vector3_normalize + + ! Vector3 Vector3One(void) + FUNCTION vector3_one() BIND(c, name='Vector3One') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_) :: vector3_one + END FUNCTION vector3_one + + ! void Vector3OrthoNormalize(Vector3 *v1, Vector3 *v2) + subroutine vector3_ortho_normalize(v1, v2) bind(c, name='Vector3OrthoNormalize') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(inout) :: v1(*) + TYPE(vector3_), INTENT(inout) :: v2(*) + END SUBROUTINE vector3_ortho_normalize + + ! Vector3 Vector3Perpendicular(Vector3 v) + FUNCTION vector3_perpendicular(v) BIND(c, name='Vector3Perpendicular') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_) :: vector3_perpendicular + END FUNCTION vector3_perpendicular + + ! Vector3 Vector3Reflect(Vector3 v, Vector3 normal) + FUNCTION vector3_reflect(v, normal) BIND(c, name='Vector3Reflect') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_), INTENT(in), VALUE :: normal + TYPE(vector3_) :: vector3_reflect + END FUNCTION vector3_reflect + + ! Vector3 Vector3Refract(Vector3 v, Vector3 n, float r) + FUNCTION vector3_refract(v, n, r) BIND(c, name='Vector3Refract') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_), INTENT(in), VALUE :: n + REAL(kind=C_FLOAT), INTENT(in), VALUE :: r + TYPE(vector3_) :: vector3_refract + END FUNCTION vector3_refract + + ! Vector3 Vector3RotateByAxisAngle(Vector3 v, Vector3 axis, float angle) + function vector3_rotate_by_axis_angle(v, axis, angle) bind(c, name='Vector3RotateByAxisAngle') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(vector3_), INTENT(in), VALUE :: axis + REAL(kind=C_FLOAT), INTENT(in), VALUE :: angle + TYPE(vector3_) :: vector3_rotate_by_axis_angle + END FUNCTION vector3_rotate_by_axis_angle + + ! Vector3 Vector3RotateByQuaternion(Vector3 v, Quaternion q) + function vector3_rotate_by_quaternion(v, q) bind(c, name='Vector3RotateByQuaternion') + IMPORT :: quaternion_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(quaternion_), INTENT(in), VALUE :: q + TYPE(vector3_) :: vector3_rotate_by_quaternion + END FUNCTION vector3_rotate_by_quaternion + + ! Vector3 Vector3Scale(Vector3 v, float scalar) + FUNCTION vector3_scale(v, scalar) BIND(c, name='Vector3Scale') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scalar + TYPE(vector3_) :: vector3_scale + END FUNCTION vector3_scale + + ! Vector3 Vector3Subtract(Vector3 v1, Vector3 v2) + FUNCTION vector3_subtract(v1, v2) BIND(c, name='Vector3Subtract') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v1 + TYPE(vector3_), INTENT(in), VALUE :: v2 + TYPE(vector3_) :: vector3_subtract + END FUNCTION vector3_subtract + + ! Vector3 Vector3SubtractValue(Vector3 v, float sub) + FUNCTION vector3_subtract_value(v, sub) BIND(c, name='Vector3SubtractValue') + IMPORT :: C_FLOAT, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + REAL(kind=C_FLOAT), INTENT(in), VALUE :: sub + TYPE(vector3_) :: vector3_subtract_value + END FUNCTION vector3_subtract_value + + ! float3 Vector3ToFloatV(Vector3 v) + FUNCTION vector3_to_float_v(v) BIND(c, name='Vector3ToFloatV') + IMPORT :: float3_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(float3_) :: vector3_to_float_v + END FUNCTION vector3_to_float_v + + ! Vector3 Vector3Transform(Vector3 v, Matrix mat) + FUNCTION vector3_transform(v, mat) BIND(c, name='Vector3Transform') + IMPORT :: matrix_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: v + TYPE(matrix_), INTENT(in), VALUE :: mat + TYPE(vector3_) :: vector3_transform + END FUNCTION vector3_transform + + ! Vector3 Vector3Unproject(Vector3 source, Matrix projection, Matrix view) + function vector3_unproject(source, projection, view) bind(c, name='Vector3Unproject') + IMPORT :: matrix_, vector3_ + IMPLICIT NONE + TYPE(vector3_), INTENT(in), VALUE :: source + TYPE(matrix_), INTENT(in), VALUE :: projection + TYPE(matrix_), INTENT(in), VALUE :: view + TYPE(vector3_) :: vector3_unproject + END FUNCTION vector3_unproject + + ! Vector3 Vector3Zero(void) + FUNCTION vector3_zero() BIND(c, name='Vector3Zero') + IMPORT :: vector3_ + IMPLICIT NONE + TYPE(vector3_) :: vector3_zero + END FUNCTION vector3_zero + + ! float Wrap(float value, float min, float max) + FUNCTION wrap(VALUE, min, max) BIND(c, name='Wrap') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: min + REAL(kind=C_FLOAT), INTENT(in), VALUE :: max + REAL(kind=C_FLOAT) :: wrap + END FUNCTION wrap +END INTERFACE +END MODULE raylib_math diff --git a/src/modules/RaylibInterface/src/RaylibMethods.F90 b/src/modules/RaylibInterface/src/RaylibMethods.F90 new file mode 100644 index 000000000..88e2a1c6d --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibMethods.F90 @@ -0,0 +1,1060 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: AttachAudioMixedProcessor +PUBLIC :: AttachAudioStreamProcessor +PUBLIC :: BeginBlendMode +PUBLIC :: BeginDrawing +PUBLIC :: BeginMode2D +PUBLIC :: BeginMode3D +PUBLIC :: BeginScissorMode +PUBLIC :: BeginShaderMode +PUBLIC :: BeginTextureMode +PUBLIC :: BeginVrStereoMode +PUBLIC :: ChangeDirectory +PUBLIC :: ClearBackground +PUBLIC :: ClearWindowState +PUBLIC :: CloseAudioDevice +PUBLIC :: CloseWindow +PUBLIC :: CodepointToUTF8 +PUBLIC :: ColorAlpha +PUBLIC :: ColorAlphaBlend +PUBLIC :: ColorBrightness +PUBLIC :: ColorContrast +PUBLIC :: ColorFromHSV +PUBLIC :: ColorFromNormalized +PUBLIC :: ColorTint +PUBLIC :: ColorToInt +PUBLIC :: CompressData +PUBLIC :: DecodeDataBase64 +PUBLIC :: DecompressData +PUBLIC :: DetachAudioMixedProcessor +PUBLIC :: DetachAudioStreamProcessor +PUBLIC :: DirectoryExists +PUBLIC :: DisableCursor +PUBLIC :: DisableEventWaiting +PUBLIC :: EnableCursor +PUBLIC :: EnableEventWaiting +PUBLIC :: EncodeDataBase64 +PUBLIC :: EndBlendMode +PUBLIC :: EndDrawing +PUBLIC :: EndMode2D +PUBLIC :: EndMode3D +PUBLIC :: EndScissorMode +PUBLIC :: EndShaderMode +PUBLIC :: EndTextureMode +PUBLIC :: EndVrStereoMode +PUBLIC :: ExportDataAsCode +PUBLIC :: ExportFontAsCode +PUBLIC :: ExportImage +PUBLIC :: ExportImageAsCode + +PUBLIC :: ExportImageToMemory +PUBLIC :: ExportMesh +PUBLIC :: ExportWave +PUBLIC :: ExportWaveAsCode +PUBLIC :: fade +PUBLIC :: FileExists +PUBLIC :: HideCursor +PUBLIC :: InitAudioDevice +PUBLIC :: InitWindow +PUBLIC :: MaximizeWindow +PUBLIC :: MeasureText +PUBLIC :: MeasureTextEx +PUBLIC :: MemAlloc +PUBLIC :: MemFree +PUBLIC :: MemRealloc +PUBLIC :: MinimizeWindow +PUBLIC :: OpenURL +PUBLIC :: PauseAudioStream +PUBLIC :: PauseMusicStream +PUBLIC :: PauseSound +PUBLIC :: PlayAudioStream +PUBLIC :: PlayMusicStream +PUBLIC :: PlaySound +PUBLIC :: PollInputEvents +PUBLIC :: RestoreWindow +PUBLIC :: ResumeAudioStream +PUBLIC :: ResumeMusicStream +PUBLIC :: ResumeSound +PUBLIC :: SaveFileData +PUBLIC :: SaveFileText +PUBLIC :: SeekMusicStream +PUBLIC :: ShowCursor +PUBLIC :: StopAudioStream +PUBLIC :: StopMusicStream +PUBLIC :: StopSound +PUBLIC :: SwapScreenBuffer +PUBLIC :: TakeScreenshot + +PUBLIC :: TextAppend +PUBLIC :: TextCopy +PUBLIC :: TextFindIndex +PUBLIC :: TextInsert +PUBLIC :: TextIsEqual +PUBLIC :: TextJoin +PUBLIC :: TextLength +PUBLIC :: TextReplace +PUBLIC :: TextSplit +PUBLIC :: TextSubtext +PUBLIC :: TextToInteger +PUBLIC :: TextToLower +PUBLIC :: TextToPascal +PUBLIC :: TextToUpper + +PUBLIC :: ToggleBorderlessWindowed +PUBLIC :: ToggleFullscreen +PUBLIC :: TraceLog + +PUBLIC :: UpdateAudioStream +PUBLIC :: UpdateCamera +PUBLIC :: UpdateMeshBuffer +PUBLIC :: UpdateModelAnimation +PUBLIC :: UpdateMusicStream +PUBLIC :: UpdateSound +PUBLIC :: UpdateTexture +PUBLIC :: UpdateTextureRec + +PUBLIC :: UploadMesh +PUBLIC :: WaitTime +PUBLIC :: WaveCopy +PUBLIC :: WaveCrop +PUBLIC :: WaveFormat +PUBLIC :: WindowShouldClose + +PUBLIC :: load_file_data_callback +PUBLIC :: SaveFileData_callback +PUBLIC :: load_file_text_callback +PUBLIC :: SaveFileText_callback +PUBLIC :: TraceLog_callback + +PUBLIC :: deg2rad +PUBLIC :: rad2deg + +ABSTRACT INTERFACE + ! unsigned char *(*LoadFileDataCallback)(const char *fileName, unsigned int *bytesRead) + FUNCTION load_file_data_callback(file_name, bytes_read) BIND(c) + IMPORT :: C_PTR, c_unsigned_int + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: file_name + INTEGER(kind=c_unsigned_int), INTENT(out) :: bytes_read + TYPE(C_PTR) :: load_file_data_callback + END FUNCTION load_file_data_callback + + ! bool (*SaveFileDataCallback)(const char *fileName, void *data, unsigned int bytesToWrite) + FUNCTION SaveFileData_callback(file_name, DATA, bytes_to_write) BIND(c) + IMPORT :: C_BOOL, C_PTR, c_unsigned_int + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: file_name + TYPE(C_PTR), INTENT(in), VALUE :: DATA + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: bytes_to_write + LOGICAL(kind=C_BOOL) :: SaveFileData_callback + END FUNCTION SaveFileData_callback + + ! char *(*LoadFileTextCallback)(const char *fileName) + FUNCTION load_file_text_callback(file_name) BIND(c) + IMPORT :: C_PTR, c_unsigned_int + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: file_name + TYPE(C_PTR) :: load_file_text_callback + END FUNCTION load_file_text_callback + + ! bool (*SaveFileTextCallback)(const char *fileName, char *text) + FUNCTION SaveFileText_callback(file_name, text) BIND(c) + IMPORT :: C_BOOL, C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: file_name + TYPE(C_PTR), INTENT(in), VALUE :: text + LOGICAL(kind=C_BOOL) :: SaveFileText_callback + END FUNCTION SaveFileText_callback + + ! void (*TraceLogCallback)(int logLevel, const char *text, va_list args) + SUBROUTINE TraceLog_callback(log_level, text, args) BIND(c) + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: log_level + TYPE(C_PTR), INTENT(in), VALUE :: text + TYPE(C_PTR), INTENT(in) :: args(*) + END SUBROUTINE TraceLog_callback +END INTERFACE + +INTERFACE + ! void AttachAudioMixedProcessor(AudioCallback processor) + subroutine AttachAudioMixedProcessor(processor) bind(c, name='AttachAudioMixedProcessor') + IMPORT :: C_FUNPTR + IMPLICIT NONE + TYPE(C_FUNPTR), INTENT(in), VALUE :: processor + END SUBROUTINE AttachAudioMixedProcessor + + ! void AttachAudioStreamProcessor(AudioStream stream, AudioCallback processor) + subroutine AttachAudioStreamProcessor(stream, processor) bind(c, name='AttachAudioStreamProcessor') + IMPORT :: audio_stream_, C_FUNPTR + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + TYPE(C_FUNPTR), INTENT(in), VALUE :: processor + END SUBROUTINE AttachAudioStreamProcessor + + ! void BeginBlendMode(int mode) + SUBROUTINE BeginBlendMode(mode) BIND(c, name='BeginBlendMode') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: mode + END SUBROUTINE BeginBlendMode + + ! void BeginDrawing(void) + SUBROUTINE BeginDrawing() BIND(c, name='BeginDrawing') + END SUBROUTINE BeginDrawing + + ! void BeginMode2D(Camera2D camera) + SUBROUTINE BeginMode2D(camera) BIND(c, name='BeginMode2D') + IMPORT :: camera2d_ + IMPLICIT NONE + TYPE(camera2d_), INTENT(in), VALUE :: camera + END SUBROUTINE BeginMode2D + + ! void BeginMode3D(Camera3D camera) + SUBROUTINE BeginMode3D(camera) BIND(c, name='BeginMode3D') + IMPORT :: camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(in), VALUE :: camera + END SUBROUTINE BeginMode3D + + ! void BeginScissorMode(int x, int y, int width, int height) + subroutine BeginScissorMode(x, y, width, height) bind(c, name='BeginScissorMode') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: x + INTEGER(kind=C_INT), INTENT(in), VALUE :: y + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + END SUBROUTINE BeginScissorMode + + ! void BeginShaderMode(Shader shader) + SUBROUTINE BeginShaderMode(shader) BIND(c, name='BeginShaderMode') + IMPORT :: shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + END SUBROUTINE BeginShaderMode + + ! void BeginTextureMode(RenderTexture2D target) + SUBROUTINE BeginTextureMode(TARGET) BIND(c, name='BeginTextureMode') + IMPORT :: render_texture2d_ + IMPLICIT NONE + TYPE(render_texture2d_), INTENT(in), VALUE :: TARGET + END SUBROUTINE BeginTextureMode + + ! void BeginVrStereoMode(VrStereoConfig config) + SUBROUTINE BeginVrStereoMode(config) BIND(c, name='BeginVrStereoMode') + IMPORT :: vr_stereo_config_ + IMPLICIT NONE + TYPE(vr_stereo_config_), INTENT(in), VALUE :: config + END SUBROUTINE BeginVrStereoMode + + ! bool ChangeDirectory(const char *dir) + FUNCTION ChangeDirectory(dir) BIND(c, name='ChangeDirectory') + IMPORT :: C_BOOL, C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: dir + LOGICAL(kind=C_BOOL) :: ChangeDirectory + END FUNCTION ChangeDirectory + + ! void ClearBackground(Color color) + SUBROUTINE ClearBackground(color) BIND(c, name='ClearBackground') + IMPORT :: color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: color + END SUBROUTINE ClearBackground + + ! void ClearWindowState(unsigned int flags) + SUBROUTINE ClearWindowState(flags) BIND(c, name='ClearWindowState') + IMPORT :: c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags + END SUBROUTINE ClearWindowState + + ! void CloseAudioDevice(void) + SUBROUTINE CloseAudioDevice() BIND(c, name='CloseAudioDevice') + END SUBROUTINE CloseAudioDevice + + ! void CloseWindow(void) + SUBROUTINE CloseWindow() BIND(c, name='CloseWindow') + END SUBROUTINE CloseWindow + + ! const char *CodepointToUTF8(int codepoint, int *utf8Size) +FUNCTION CodepointToUTF8(codepoint, utf8_size) BIND(c, name='CodepointToUTF8') + IMPORT :: C_INT, C_PTR + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: codepoint + INTEGER(kind=C_INT), INTENT(out) :: utf8_size + TYPE(C_PTR) :: CodepointToUTF8 + END FUNCTION CodepointToUTF8 + + ! Color ColorAlpha(Color color, float alpha) + FUNCTION ColorAlpha(color, alpha) BIND(c, name='ColorAlpha') + IMPORT :: C_FLOAT, color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: color + REAL(kind=C_FLOAT), INTENT(in), VALUE :: alpha + TYPE(color_) :: ColorAlpha + END FUNCTION ColorAlpha + + ! Color ColorAlphaBlend(Color dst, Color src, Color tint) + FUNCTION ColorAlphaBlend(dst, src, tint) BIND(c, name='ColorAlphaBlend') + IMPORT :: color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: dst + TYPE(color_), INTENT(in), VALUE :: src + TYPE(color_), INTENT(in), VALUE :: tint + TYPE(color_) :: ColorAlphaBlend + END FUNCTION ColorAlphaBlend + + ! Color ColorBrightness(Color color, float factor) + FUNCTION ColorBrightness(color, factor) BIND(c, name='ColorBrightness') + IMPORT :: C_FLOAT, color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: color + REAL(kind=C_FLOAT), INTENT(in), VALUE :: factor + TYPE(color_) :: ColorBrightness + END FUNCTION ColorBrightness + + ! Color ColorContrast(Color color, float contrast) + FUNCTION ColorContrast(color, contrast) BIND(c, name='ColorContrast') + IMPORT :: C_FLOAT, color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: color + REAL(kind=C_FLOAT), INTENT(in), VALUE :: contrast + TYPE(color_) :: ColorContrast + END FUNCTION ColorContrast + + ! Color ColorFromHSV(float hue, float saturation, float value) + FUNCTION ColorFromHSV(hue, saturation, VALUE) BIND(c, name='ColorFromHSV') + IMPORT :: C_FLOAT, color_ + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: hue + REAL(kind=C_FLOAT), INTENT(in), VALUE :: saturation + REAL(kind=C_FLOAT), INTENT(in), VALUE :: VALUE + TYPE(color_) :: ColorFromHSV + END FUNCTION ColorFromHSV + + ! Color ColorFromNormalized(Vector4 normalized) + FUNCTION ColorFromNormalized(normalized) BIND(c, name='ColorFromNormalized') + IMPORT :: color_, vector4_ + IMPLICIT NONE + TYPE(vector4_), INTENT(in), VALUE :: normalized + TYPE(color_) :: ColorFromNormalized + END FUNCTION ColorFromNormalized + + ! Color ColorTint(Color color, Color tint) + FUNCTION ColorTint(color, tint) BIND(c, name='ColorTint') + IMPORT :: color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: color + TYPE(color_), INTENT(in), VALUE :: tint + TYPE(color_) :: ColorTint + END FUNCTION ColorTint + + ! int ColorToInt(Color color) + FUNCTION ColorToInt(color) BIND(c, name='ColorToInt') + IMPORT :: C_INT, color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: color + INTEGER(kind=C_INT) :: ColorToInt + END FUNCTION ColorToInt + + ! unsigned char *CompressData(const unsigned char *data, int dataSize, int *compDataSize) + function CompressData(data, data_size, comp_data_size) bind(c, name='CompressData') + IMPORT :: C_INT, C_PTR, c_unsigned_char + IMPLICIT NONE + INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + INTEGER(kind=C_INT), INTENT(out) :: comp_data_size + TYPE(C_PTR) :: CompressData + END FUNCTION CompressData + + ! unsigned char *DecodeDataBase64(const unsigned char *data, int *outputSize) + FUNCTION DecodeDataBase64(DATA, output_size) BIND(c, name='DecodeDataBase64') + IMPORT :: C_INT, c_unsigned_char, C_PTR + IMPLICIT NONE + INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA + INTEGER(kind=C_INT), INTENT(out) :: output_size + TYPE(C_PTR) :: DecodeDataBase64 + END FUNCTION DecodeDataBase64 + + ! unsigned char *DecompressData(const unsigned char *compData, int compDataSize, int *dataSize) + function DecompressData(comp_data, comp_data_size, data_size) bind(c, name='DecompressData') + IMPORT :: C_INT, C_PTR, c_unsigned_char + IMPLICIT NONE + INTEGER(kind=c_unsigned_char), INTENT(in) :: comp_data + INTEGER(kind=C_INT), INTENT(in), VALUE :: comp_data_size + INTEGER(kind=C_INT), INTENT(out) :: data_size + TYPE(C_PTR) :: DecompressData + END FUNCTION DecompressData + + ! void DetachAudioMixedProcessor(AudioCallback processor) + subroutine DetachAudioMixedProcessor(processor) bind(c, name='DetachAudioMixedProcessor') + IMPORT :: C_FUNPTR + IMPLICIT NONE + TYPE(C_FUNPTR), INTENT(in), VALUE :: processor + END SUBROUTINE DetachAudioMixedProcessor + + ! void DetachAudioStreamProcessor(AudioStream stream, AudioCallback processor) + subroutine DetachAudioStreamProcessor(stream, processor) bind(c, name='DetachAudioStreamProcessor') + IMPORT :: audio_stream_, C_FUNPTR + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + TYPE(C_FUNPTR), INTENT(in), VALUE :: processor + END SUBROUTINE DetachAudioStreamProcessor + + ! bool DirectoryExists(const char *dirPath) + FUNCTION DirectoryExists(dir_path) BIND(c, name='DirectoryExists') + IMPORT :: C_BOOL, C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: dir_path + LOGICAL(kind=C_BOOL) :: DirectoryExists + END FUNCTION DirectoryExists + + ! void DisableCursor(void) + SUBROUTINE DisableCursor() BIND(c, name='DisableCursor') + END SUBROUTINE DisableCursor + + ! void DisableEventWaiting(void) + SUBROUTINE DisableEventWaiting() BIND(c, name='DisableEventWaiting') + END SUBROUTINE DisableEventWaiting + + ! void EnableCursor(void) + SUBROUTINE EnableCursor() BIND(c, name='EnableCursor') + END SUBROUTINE EnableCursor + + ! void EnableEventWaiting(void) + SUBROUTINE EnableEventWaiting() BIND(c, name='EnableEventWaiting') + END SUBROUTINE EnableEventWaiting + + ! char *EncodeDataBase64(const unsigned char *data, int dataSize, int *outputSize) + function EncodeDataBase64(data, data_size, output_size) bind(c, name='EncodeDataBase64') + IMPORT :: C_INT, c_unsigned_char, C_PTR + IMPLICIT NONE + INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + INTEGER(kind=C_INT), INTENT(out) :: output_size + TYPE(C_PTR) :: EncodeDataBase64 + END FUNCTION EncodeDataBase64 + + ! void EndBlendMode(void) + SUBROUTINE EndBlendMode() BIND(c, name='EndBlendMode') + END SUBROUTINE EndBlendMode + + ! void EndDrawing(void) + SUBROUTINE EndDrawing() BIND(c, name='EndDrawing') + END SUBROUTINE EndDrawing + + ! void EndMode2D(void) + SUBROUTINE EndMode2D() BIND(c, name='EndMode2D') + END SUBROUTINE EndMode2D + + ! void EndMode3D(void) + SUBROUTINE EndMode3D() BIND(c, name='EndMode3D') + END SUBROUTINE EndMode3D + + ! void EndScissorMode(void) + SUBROUTINE EndScissorMode() BIND(c, name='EndScissorMode') + END SUBROUTINE EndScissorMode + + ! void EndShaderMode(void) + SUBROUTINE EndShaderMode() BIND(c, name='EndShaderMode') + END SUBROUTINE EndShaderMode + + ! void EndTextureMode(void) + SUBROUTINE EndTextureMode() BIND(c, name='EndTextureMode') + END SUBROUTINE EndTextureMode + + ! void EndVrStereoMode(void) + SUBROUTINE EndVrStereoMode() BIND(c, name='EndVrStereoMode') + END SUBROUTINE EndVrStereoMode + + ! bool ExportDataAsCode(const unsigned char *data, int dataSize, const char *fileName) + function ExportDataAsCode(data, data_size, file_name) bind(c, name='ExportDataAsCode') + IMPORT :: C_BOOL, C_CHAR, C_INT, c_unsigned_char + IMPLICIT NONE + INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: ExportDataAsCode + END FUNCTION ExportDataAsCode + + ! bool ExportFontAsCode(Font font, const char *fileName) + FUNCTION ExportFontAsCode(font, file_name) BIND(c, name='ExportFontAsCode') + IMPORT :: C_BOOL, C_CHAR, font_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: ExportFontAsCode + END FUNCTION ExportFontAsCode + + ! bool ExportImage(Image image, const char *fileName) + FUNCTION ExportImage(image, file_name) BIND(c, name='ExportImage') + IMPORT :: C_BOOL, C_CHAR, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: ExportImage + END FUNCTION ExportImage + + ! bool ExportImageAsCode(Image image, const char *fileName) +FUNCTION ExportImageAsCode(image, file_name) BIND(c, name='ExportImageAsCode') + IMPORT :: C_BOOL, C_CHAR, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: ExportImageAsCode + END FUNCTION ExportImageAsCode + + ! unsigned char *ExportImageToMemory(Image image, const char *fileType, int *fileSize) + function ExportImageToMemory(image, file_, file_size) bind(c, name='ExportImageToMemory') + IMPORT :: C_CHAR, C_INT, C_PTR, image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + CHARACTER(kind=C_CHAR), INTENT(in) :: file_ + INTEGER(kind=C_INT), INTENT(out) :: file_size + TYPE(C_PTR) :: ExportImageToMemory + END FUNCTION ExportImageToMemory + + ! bool ExportMesh(Mesh mesh, const char *fileName) + FUNCTION ExportMesh(mesh, file_name) BIND(c, name='ExportMesh') + IMPORT :: C_BOOL, C_CHAR, mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in), VALUE :: mesh + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: ExportMesh + END FUNCTION ExportMesh + + ! bool ExportWave(Wave wave, const char *fileName) + FUNCTION ExportWave(wave, file_name) BIND(c, name='ExportWave') + IMPORT :: C_BOOL, C_CHAR, wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in), VALUE :: wave + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: ExportWave + END FUNCTION ExportWave + + ! bool ExportWaveAsCode(Wave wave, const char *fileName) + FUNCTION ExportWaveAsCode(wave, file_name) BIND(c, name='ExportWaveAsCode') + IMPORT :: C_BOOL, C_CHAR, wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in), VALUE :: wave + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: ExportWaveAsCode + END FUNCTION ExportWaveAsCode + + ! Color Fade(Color color, float alpha) + FUNCTION fade(color, alpha) BIND(c, name='Fade') + IMPORT :: C_FLOAT, color_ + IMPLICIT NONE + TYPE(color_), INTENT(in), VALUE :: color + REAL(kind=C_FLOAT), INTENT(in), VALUE :: alpha + TYPE(color_) :: fade + END FUNCTION fade + + ! bool FileExists(const char *fileName) + FUNCTION FileExists(file_name) BIND(c, name='FileExists') + IMPORT :: C_BOOL, C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + LOGICAL(kind=C_BOOL) :: FileExists + END FUNCTION FileExists + + ! void HideCursor(void) + SUBROUTINE HideCursor() BIND(c, name='HideCursor') + END SUBROUTINE HideCursor + + ! void InitAudioDevice(void) + SUBROUTINE InitAudioDevice() BIND(c, name='InitAudioDevice') + END SUBROUTINE InitAudioDevice + + ! void InitWindow(int width, int height, const char *title) + SUBROUTINE InitWindow(width, height, title) BIND(c, name='InitWindow') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + CHARACTER(kind=C_CHAR), INTENT(in) :: title + END SUBROUTINE InitWindow + + ! void MaximizeWindow(void) + SUBROUTINE MaximizeWindow() BIND(c, name='MaximizeWindow') + END SUBROUTINE MaximizeWindow + + ! int MeasureText(const char *text, int fontSize) + FUNCTION MeasureText(text, font_size) BIND(c, name='MeasureText') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(in), VALUE :: font_size + INTEGER(kind=C_INT) :: MeasureText + END FUNCTION MeasureText + + ! Vector2 MeasureTextEx(Font font, const char *text, float fontSize, float spacing) + function MeasureTextEx(font, text, font_size, spacing) bind(c, name='MeasureTextEx') + IMPORT :: C_CHAR, C_FLOAT, font_, vector2_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + CHARACTER(kind=C_CHAR), INTENT(in) :: text + REAL(kind=C_FLOAT), INTENT(in), VALUE :: font_size + REAL(kind=C_FLOAT), INTENT(in), VALUE :: spacing + TYPE(vector2_) :: MeasureTextEx + END FUNCTION MeasureTextEx + + ! void *MemAlloc(unsigned int size) + FUNCTION MemAlloc(size) BIND(c, name='MemAlloc') + IMPORT :: C_PTR, c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: size + TYPE(C_PTR) :: MemAlloc + END FUNCTION MemAlloc + + ! void MemFree(void *ptr) + SUBROUTINE MemFree(ptr) BIND(c, name='MemFree') + IMPORT :: C_PTR + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: ptr + END SUBROUTINE MemFree + + ! void *MemRealloc(void *ptr, unsigned int size) + FUNCTION MemRealloc(ptr, size) BIND(c, name='MemRealloc') + IMPORT :: C_PTR, c_unsigned_int + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: ptr + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: size + TYPE(C_PTR) :: MemRealloc + END FUNCTION MemRealloc + + ! void MinimizeWindow(void) + SUBROUTINE MinimizeWindow() BIND(c, name='MinimizeWindow') + END SUBROUTINE MinimizeWindow + + ! void OpenURL(const char *url) + SUBROUTINE OpenURL(url) BIND(c, name='OpenURL') + IMPORT :: C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: url + END SUBROUTINE OpenURL + + ! void PauseAudioStream(AudioStream stream) + SUBROUTINE PauseAudioStream(stream) BIND(c, name='PauseAudioStream') + IMPORT :: audio_stream_ + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + END SUBROUTINE PauseAudioStream + + ! void PauseMusicStream(Music music) + SUBROUTINE PauseMusicStream(music) BIND(c, name='PauseMusicStream') + IMPORT :: music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + END SUBROUTINE PauseMusicStream + + ! void PauseSound(Sound sound) + SUBROUTINE PauseSound(sound) BIND(c, name='PauseSound') + IMPORT :: sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + END SUBROUTINE PauseSound + + ! void PlayAudioStream(AudioStream stream) + SUBROUTINE PlayAudioStream(stream) BIND(c, name='PlayAudioStream') + IMPORT :: audio_stream_ + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + END SUBROUTINE PlayAudioStream + + ! void PlayMusicStream(Music music) + SUBROUTINE PlayMusicStream(music) BIND(c, name='PlayMusicStream') + IMPORT :: music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + END SUBROUTINE PlayMusicStream + + ! void PlaySound(Sound sound) + SUBROUTINE PlaySound(sound) BIND(c, name='PlaySound') + IMPORT :: sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + END SUBROUTINE PlaySound + + ! void PollInputEvents(void) + SUBROUTINE PollInputEvents() BIND(c, name='PollInputEvents') + END SUBROUTINE PollInputEvents + + ! void RestoreWindow(void) + SUBROUTINE RestoreWindow() BIND(c, name='RestoreWindow') + END SUBROUTINE RestoreWindow + + ! void ResumeAudioStream(AudioStream stream) + SUBROUTINE ResumeAudioStream(stream) BIND(c, name='ResumeAudioStream') + IMPORT :: audio_stream_ + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + END SUBROUTINE ResumeAudioStream + + ! void ResumeMusicStream(Music music) + SUBROUTINE ResumeMusicStream(music) BIND(c, name='ResumeMusicStream') + IMPORT :: music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + END SUBROUTINE ResumeMusicStream + + ! void ResumeSound(Sound sound) + SUBROUTINE ResumeSound(sound) BIND(c, name='ResumeSound') + IMPORT :: sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + END SUBROUTINE ResumeSound + + ! bool SaveFileData(const char *fileName, void *data, int dataSize) +FUNCTION SaveFileData(file_name, DATA, data_size) BIND(c, name='SaveFileData') + IMPORT :: C_BOOL, C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + TYPE(C_PTR), INTENT(in), VALUE :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + LOGICAL(kind=C_BOOL) :: SaveFileData + END FUNCTION SaveFileData + + ! bool SaveFileText(const char *fileName, char *text) + FUNCTION SaveFileText(file_name, text) BIND(c, name='SaveFileText') + IMPORT :: C_BOOL, C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + CHARACTER(kind=C_CHAR), INTENT(in) :: text + LOGICAL(kind=C_BOOL) :: SaveFileText + END FUNCTION SaveFileText + + ! void SeekMusicStream(Music music, float position) + SUBROUTINE SeekMusicStream(music, position) BIND(c, name='SeekMusicStream') + IMPORT :: C_FLOAT, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + REAL(kind=C_FLOAT), INTENT(in), VALUE :: position + END SUBROUTINE SeekMusicStream + + ! void ShowCursor(void) + SUBROUTINE ShowCursor() BIND(c, name='ShowCursor') + END SUBROUTINE ShowCursor + + ! void StopAudioStream(AudioStream stream) + SUBROUTINE StopAudioStream(stream) BIND(c, name='StopAudioStream') + IMPORT :: audio_stream_ + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + END SUBROUTINE StopAudioStream + + ! void StopMusicStream(Music music) + SUBROUTINE StopMusicStream(music) BIND(c, name='StopMusicStream') + IMPORT :: music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + END SUBROUTINE StopMusicStream + + ! void StopSound(Sound sound) + SUBROUTINE StopSound(sound) BIND(c, name='StopSound') + IMPORT :: sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + END SUBROUTINE StopSound + + ! void SwapScreenBuffer(void) + SUBROUTINE SwapScreenBuffer() BIND(c, name='SwapScreenBuffer') + END SUBROUTINE SwapScreenBuffer + + ! void TakeScreenshot(const char *fileName) + SUBROUTINE TakeScreenshot(file_name) BIND(c, name='TakeScreenshot') + IMPORT :: C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: file_name + END SUBROUTINE TakeScreenshot + + ! void TextAppend(char *text, const char *append, int *position) + SUBROUTINE TextAppend(text, append, position) BIND(c, name='TextAppend') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + CHARACTER(kind=C_CHAR), INTENT(in) :: append + INTEGER(kind=C_INT), INTENT(in) :: position + END SUBROUTINE TextAppend + + ! int TextCopy(char *dst, const char *src) + FUNCTION TextCopy(dst, src) BIND(c, name='TextCopy') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: dst + CHARACTER(kind=C_CHAR), INTENT(in) :: src + INTEGER(kind=C_INT) :: TextCopy + END FUNCTION TextCopy + + ! int TextFindIndex(const char *text, const char *find) + FUNCTION TextFindIndex(text, find) BIND(c, name='TextFindIndex') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + CHARACTER(kind=C_CHAR), INTENT(in) :: find + INTEGER(kind=C_INT) :: TextFindIndex + END FUNCTION TextFindIndex + + ! char *TextInsert(const char *text, const char *insert, int position) + FUNCTION TextInsert(text, insert, position) BIND(c, name='TextInsert') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + CHARACTER(kind=C_CHAR), INTENT(in) :: insert + INTEGER(kind=C_INT), INTENT(in), VALUE :: position + TYPE(C_PTR) :: TextInsert + END FUNCTION TextInsert + + ! bool TextIsEqual(const char *text1, const char *text2) + FUNCTION TextIsEqual(text1, text2) BIND(c, name='TextIsEqual') + IMPORT :: C_BOOL, C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text1 + CHARACTER(kind=C_CHAR), INTENT(in) :: text2 + LOGICAL(kind=C_BOOL) :: TextIsEqual + END FUNCTION TextIsEqual + + ! const char *TextJoin(const char **textList, int count, const char *delimiter) + FUNCTION TextJoin(text_list, count, delimiter) BIND(c, name='TextJoin') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text_list(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: count + CHARACTER(kind=C_CHAR), INTENT(in) :: delimiter + TYPE(C_PTR) :: TextJoin + END FUNCTION TextJoin + + ! unsigned int TextLength(const char *text) + FUNCTION TextLength(text) BIND(c, name='TextLength') + IMPORT :: C_CHAR, c_unsigned_int + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=c_unsigned_int) :: TextLength + END FUNCTION TextLength + + ! char *TextReplace(char *text, const char *replace, const char *by) + FUNCTION TextReplace(text, replace, by) BIND(c, name='TextReplace') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + CHARACTER(kind=C_CHAR), INTENT(in) :: replace + CHARACTER(kind=C_CHAR), INTENT(in) :: by + TYPE(C_PTR) :: TextReplace + END FUNCTION TextReplace + + ! const char **TextSplit(const char *text, char delimiter, int *count) + FUNCTION TextSplit(text, delimiter, count) BIND(c, name='TextSplit') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + CHARACTER(kind=C_CHAR), INTENT(in), VALUE :: delimiter + INTEGER(kind=C_INT), INTENT(out) :: count + TYPE(C_PTR) :: TextSplit + END FUNCTION TextSplit + + ! const char *TextSubtext(const char *text, int position, int length) + FUNCTION TextSubtext(text, position, length) BIND(c, name='TextSubtext') + IMPORT :: C_CHAR, C_INT, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT), INTENT(in), VALUE :: position + INTEGER(kind=C_INT), INTENT(in), VALUE :: length + TYPE(C_PTR) :: TextSubtext + END FUNCTION TextSubtext + + ! int TextToInteger(const char *text) + FUNCTION TextToInteger(text) BIND(c, name='TextToInteger') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + INTEGER(kind=C_INT) :: TextToInteger + END FUNCTION TextToInteger + + ! const char *TextToLower(const char *text) + FUNCTION TextToLower(text) BIND(c, name='TextToLower') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + TYPE(C_PTR) :: TextToLower + END FUNCTION TextToLower + + ! const char *TextToPascal(const char *text) + FUNCTION TextToPascal(text) BIND(c, name='TextToPascal') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + TYPE(C_PTR) :: TextToPascal + END FUNCTION TextToPascal + + ! const char *TextToUpper(const char *text) + FUNCTION TextToUpper(text) BIND(c, name='TextToUpper') + IMPORT :: C_CHAR, C_PTR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + TYPE(C_PTR) :: TextToUpper + END FUNCTION TextToUpper + + ! void ToggleBorderlessWindowed(void) +SUBROUTINE ToggleBorderlessWindowed() BIND(c, name='ToggleBorderlessWindowed') + END SUBROUTINE ToggleBorderlessWindowed + + ! void ToggleFullscreen(void) + SUBROUTINE ToggleFullscreen() BIND(c, name='ToggleFullscreen') + END SUBROUTINE ToggleFullscreen + + ! void TraceLog(int logLevel, const char *text) + SUBROUTINE TraceLog(log_level, text) BIND(c, name='TraceLog') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: log_level + CHARACTER(kind=C_CHAR), INTENT(in) :: text + END SUBROUTINE TraceLog + + ! void UpdateAudioStream(AudioStream stream, const void *data, int frameCount) + subroutine UpdateAudioStream(stream, data, frame_count) bind(c, name='UpdateAudioStream') + IMPORT :: audio_stream_, C_INT, C_PTR + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + TYPE(C_PTR), INTENT(in), VALUE :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: frame_count + END SUBROUTINE UpdateAudioStream + + ! void UpdateCamera(Camera *camera, int mode) + SUBROUTINE UpdateCamera(camera, mode) BIND(c, name='UpdateCamera') + IMPORT :: camera3d_, C_INT + IMPLICIT NONE + TYPE(camera3d_), INTENT(inout) :: camera + INTEGER(kind=C_INT), INTENT(in), VALUE :: mode + END SUBROUTINE UpdateCamera + + ! void UpdateMeshBuffer(Mesh mesh, int index, const void *data, int dataSize, int offset) + subroutine UpdateMeshBuffer(mesh, index, data, data_size, offset) bind(c, name='UpdateMeshBuffer') + IMPORT :: C_INT, C_PTR, mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in), VALUE :: mesh + INTEGER(kind=C_INT), INTENT(in), VALUE :: index + TYPE(C_PTR), INTENT(in), VALUE :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: data_size + INTEGER(kind=C_INT), INTENT(in), VALUE :: offset + END SUBROUTINE UpdateMeshBuffer + + ! void UpdateModelAnimation(Model model, ModelAnimation anim, int frame) + subroutine UpdateModelAnimation(model, anim, frame) bind(c, name='UpdateModelAnimation') + IMPORT :: C_INT, model_animation_, model_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + TYPE(model_animation_), INTENT(in), VALUE :: anim + INTEGER(kind=C_INT), INTENT(in), VALUE :: frame + END SUBROUTINE UpdateModelAnimation + + ! void UpdateMusicStream(Music music) + SUBROUTINE UpdateMusicStream(music) BIND(c, name='UpdateMusicStream') + IMPORT :: music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + END SUBROUTINE UpdateMusicStream + + ! void UpdateSound(Sound sound, const void *data, int sampleCount) + SUBROUTINE UpdateSound(sound, DATA, sample_count) BIND(c, name='UpdateSound') + IMPORT :: C_INT, C_PTR, sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + TYPE(C_PTR), INTENT(in), VALUE :: DATA + INTEGER(kind=C_INT), INTENT(in), VALUE :: sample_count + END SUBROUTINE UpdateSound + + ! void UpdateTexture(Texture2D texture, const void *pixels) + SUBROUTINE UpdateTexture(texture, pixels) BIND(c, name='UpdateTexture') + IMPORT :: C_PTR, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(C_PTR), INTENT(in), VALUE :: pixels + END SUBROUTINE UpdateTexture + + ! void UpdateTextureRec(Texture2D texture, Rectangle rec, const void *pixels) + subroutine UpdateTextureRec(texture, rec, pixels) bind(c, name='UpdateTextureRec') + IMPORT :: C_PTR, rectangle_, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(rectangle_), INTENT(in), VALUE :: rec + TYPE(C_PTR), INTENT(in), VALUE :: pixels + END SUBROUTINE UpdateTextureRec + + ! void UploadMesh(Mesh *mesh, bool dynamic) + SUBROUTINE UploadMesh(mesh, dynamic) BIND(c, name='UploadMesh') + IMPORT :: C_BOOL, mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(inout) :: mesh + LOGICAL(kind=C_BOOL), INTENT(in), VALUE :: dynamic + END SUBROUTINE UploadMesh + + ! void WaitTime(double seconds) + SUBROUTINE WaitTime(seconds) BIND(c, name='WaitTime') + IMPORT :: C_DOUBLE + IMPLICIT NONE + REAL(kind=C_DOUBLE), INTENT(in), VALUE :: seconds + END SUBROUTINE WaitTime + + ! Wave WaveCopy(Wave wave) + FUNCTION WaveCopy(wave) BIND(c, name='WaveCopy') + IMPORT :: wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in), VALUE :: wave + TYPE(wave_) :: WaveCopy + END FUNCTION WaveCopy + + ! void WaveCrop(Wave *wave, int initSample, int finalSample) + SUBROUTINE WaveCrop(wave, init_sample, final_sample) BIND(c, name='WaveCrop') + IMPORT :: C_INT, wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in) :: wave + INTEGER(kind=C_INT), INTENT(in), VALUE :: init_sample + INTEGER(kind=C_INT), INTENT(in), VALUE :: final_sample + END SUBROUTINE WaveCrop + + ! void WaveFormat(Wave *wave, int sampleRate, int sampleSize, int channels) + subroutine WaveFormat(wave, sample_rate, sample_size, channels) bind(c, name='WaveFormat') + IMPORT :: C_INT, wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in) :: wave + INTEGER(kind=C_INT), INTENT(in), VALUE :: sample_rate + INTEGER(kind=C_INT), INTENT(in), VALUE :: sample_size + INTEGER(kind=C_INT), INTENT(in), VALUE :: channels + END SUBROUTINE WaveFormat + + ! bool WindowShouldClose(void) + FUNCTION WindowShouldClose() BIND(c, name='WindowShouldClose') + IMPORT :: C_BOOL + IMPLICIT NONE + LOGICAL(kind=C_BOOL) :: WindowShouldClose + END FUNCTION WindowShouldClose +END INTERFACE +CONTAINS +ELEMENTAL REAL FUNCTION deg2rad(d) RESULT(r) + REAL, INTENT(in) :: d + + r = d * (PI / 180.0) +END FUNCTION deg2rad + +ELEMENTAL REAL FUNCTION rad2deg(r) RESULT(d) + REAL, INTENT(in) :: r + + d = r * (180.0 / PI) +END FUNCTION rad2deg +END MODULE RaylibMethods diff --git a/src/modules/RaylibInterface/src/RaylibSetMethods.F90 b/src/modules/RaylibInterface/src/RaylibSetMethods.F90 new file mode 100644 index 000000000..947be0d0a --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibSetMethods.F90 @@ -0,0 +1,503 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibSetMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: SetWindowTitle +PUBLIC :: SetWindowState +PUBLIC :: SetWindowSize +PUBLIC :: SetWindowPosition +PUBLIC :: SetWindowOpacity +PUBLIC :: SetWindowMonitor +PUBLIC :: SetWindowMinSize +PUBLIC :: SetWindowMaxSize +PUBLIC :: SetWindowIcons +PUBLIC :: SetWindowIcon +PUBLIC :: SetWindowFocused +PUBLIC :: SetTraceLogLevel +PUBLIC :: SetTraceLogCallback +PUBLIC :: SetTextureWrap +PUBLIC :: SetTextureFilter +PUBLIC :: SetTextLineSpacing +PUBLIC :: SetTargetFPS +PUBLIC :: SetSoundVolume +PUBLIC :: SetSoundPitch +PUBLIC :: SetSoundPan +PUBLIC :: SetShapesTexture +PUBLIC :: SetShaderValueV +PUBLIC :: SetShaderValueTexture +PUBLIC :: SetShaderValueMatrix +PUBLIC :: SetShaderValue +PUBLIC :: SetSaveFileTextCallback +PUBLIC :: SetSaveFileDataCallback +PUBLIC :: SetRandomSeed +PUBLIC :: SetPixelColor +PUBLIC :: SetMusicVolume +PUBLIC :: SetMusicPitch +PUBLIC :: SetMusicPan +PUBLIC :: SetMouseScale +PUBLIC :: SetMousePosition +PUBLIC :: SetMouseOffset +PUBLIC :: SetMouseCursor +PUBLIC :: SetModelMeshMaterial +PUBLIC :: SetMaterialTexture +PUBLIC :: SetMasterVolume +PUBLIC :: SetLoadFileTextCallback +PUBLIC :: SetLoadFileDataCallback +PUBLIC :: SetGesturesEnabled +PUBLIC :: SetGamepadMappings +PUBLIC :: SetExitKey +PUBLIC :: SetConfigFlags +PUBLIC :: SetClipboardText +PUBLIC :: SetCameraSmoothZoomControl +PUBLIC :: SetCameraPanControl +PUBLIC :: SetCameraMoveControls +PUBLIC :: SetCameraMode +PUBLIC :: SetCameraAltControl +PUBLIC :: SetAudioStreamVolume +PUBLIC :: SetAudioStreamPitch +PUBLIC :: SetAudioStreamPan +PUBLIC :: SetAudioStreamBufferSizeDefault + +INTERFACE + + ! void SetAudioStreamBufferSizeDefault(int size) + subroutine SetAudioStreamBufferSizeDefault(size) bind(c, name='SetAudioStreamBufferSizeDefault') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: size + END SUBROUTINE SetAudioStreamBufferSizeDefault + + ! void SetAudioStreamPan(AudioStream stream, float pan) + SUBROUTINE SetAudioStreamPan(stream, pan) BIND(c, name='SetAudioStreamPan') + IMPORT :: audio_stream_, C_FLOAT + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + REAL(kind=C_FLOAT), INTENT(in), VALUE :: pan + END SUBROUTINE SetAudioStreamPan + + ! void SetAudioStreamPitch(AudioStream stream, float pitch) + subroutine SetAudioStreamPitch(stream, pitch) bind(c, name='SetAudioStreamPitch') + IMPORT :: audio_stream_, C_FLOAT + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch + END SUBROUTINE SetAudioStreamPitch + + ! void SetAudioStreamVolume(AudioStream stream, float volume) + subroutine SetAudioStreamVolume(stream, volume) bind(c, name='SetAudioStreamVolume') + IMPORT :: audio_stream_, C_FLOAT + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume + END SUBROUTINE SetAudioStreamVolume + + ! void SetCameraAltControl(int keyAlt) + SUBROUTINE SetCameraAltControl(key_alt) BIND(c, name='SetCameraAltControl') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_alt + END SUBROUTINE SetCameraAltControl + + ! void SetCameraMode(Camera camera, int mode) + SUBROUTINE SetCameraMode(camera, mode) BIND(c, name='SetCameraMode') + IMPORT :: C_INT, camera3d_ + IMPLICIT NONE + TYPE(camera3d_), INTENT(in), VALUE :: camera + INTEGER(kind=C_INT), INTENT(in), VALUE :: mode + END SUBROUTINE SetCameraMode + + ! void SetCameraMoveControls(int keyFront, int keyBack, int keyRight, int keyLeft, int keyUp, int keyDown) + subroutine SetCameraMoveControls(key_front, key_back, key_right, key_left, key_up, key_down) & + BIND(c, name='SetCameraMoveControls') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_front + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_back + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_right + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_left + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_up + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_down + END SUBROUTINE SetCameraMoveControls + + ! void SetCameraPanControl(int keyPan) + SUBROUTINE SetCameraPanControl(key_pan) BIND(c, name='SetCameraPanControl') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_pan + END SUBROUTINE SetCameraPanControl + + ! void SetCameraSmoothZoomControl(int keySmoothZoom) + subroutine SetCameraSmoothZoomControl(key_smooth_zoom) bind(c, name='SetCameraSmoothZoomControl') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key_smooth_zoom + END SUBROUTINE SetCameraSmoothZoomControl + + ! void SetClipboardText(const char *text) + SUBROUTINE SetClipboardText(text) BIND(c, name='SetClipboardText') + IMPORT :: C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + END SUBROUTINE SetClipboardText + + ! void SetConfigFlags(unsigned int flags) + SUBROUTINE SetConfigFlags(flags) BIND(c, name='SetConfigFlags') + IMPORT :: c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags + END SUBROUTINE SetConfigFlags + + ! void SetExitKey(int key) + SUBROUTINE SetExitKey(key) BIND(c, name='SetExitKey') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: key + END SUBROUTINE SetExitKey + + ! int SetGamepadMappings(const char *mappings) + FUNCTION SetGamepadMappings(mappings) BIND(c, name='SetGamepadMappings') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: mappings + INTEGER(kind=C_INT) :: SetGamepadMappings + END FUNCTION SetGamepadMappings + + ! void SetGesturesEnabled(unsigned int flags) + SUBROUTINE SetGesturesEnabled(flags) BIND(c, name='SetGesturesEnabled') + IMPORT :: c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags + END SUBROUTINE SetGesturesEnabled + + ! void SetLoadFileDataCallback(LoadFileDataCallback callback) + subroutine SetLoadFileDataCallback(callback) bind(c, name='SetLoadFileDataCallback') + IMPORT :: C_FUNPTR + IMPLICIT NONE + TYPE(C_FUNPTR), INTENT(in), VALUE :: callback + END SUBROUTINE SetLoadFileDataCallback + + ! void SetLoadFileTextCallback(LoadFileTextCallback callback) + subroutine SetLoadFileTextCallback(callback) bind(c, name='SetLoadFileTextCallback') + IMPORT :: C_FUNPTR + IMPLICIT NONE + TYPE(C_FUNPTR), INTENT(in), VALUE :: callback + END SUBROUTINE SetLoadFileTextCallback + + ! void SetMasterVolume(float volume) + SUBROUTINE SetMasterVolume(volume) BIND(c, name='SetMasterVolume') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume + END SUBROUTINE SetMasterVolume + + ! void SetMaterialTexture(Material *material, int mapType, Texture2D texture) + subroutine SetMaterialTexture(material, map_, texture) bind(c, name='SetMaterialTexture') + IMPORT :: C_INT, material_, texture2d_ + IMPLICIT NONE + TYPE(material_), INTENT(inout) :: material + INTEGER(kind=C_INT), INTENT(in), VALUE :: map_ + TYPE(texture2d_), INTENT(in), VALUE :: texture + END SUBROUTINE SetMaterialTexture + + ! void SetModelMeshMaterial(Model *model, int meshId, int materialId) + subroutine SetModelMeshMaterial(model, mesh_id, material_id) bind(c, name='SetModelMeshMaterial') + IMPORT :: C_INT, model_ + IMPLICIT NONE + TYPE(model_), INTENT(inout) :: model + INTEGER(kind=C_INT), INTENT(in), VALUE :: mesh_id + INTEGER(kind=C_INT), INTENT(in), VALUE :: material_id + END SUBROUTINE SetModelMeshMaterial + + ! void SetMouseCursor(int cursor) + SUBROUTINE SetMouseCursor(cursor) BIND(c, name='SetMouseCursor') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: cursor + END SUBROUTINE SetMouseCursor + + ! void SetMouseOffset(int offsetX, int offsetY) + SUBROUTINE SetMouseOffset(offset_x, offset_y) BIND(c, name='SetMouseOffset') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_x + INTEGER(kind=C_INT), INTENT(in), VALUE :: offset_y + END SUBROUTINE SetMouseOffset + + ! void SetMousePosition(int x, int y) + SUBROUTINE SetMousePosition(x, y) BIND(c, name='SetMousePosition') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: x + INTEGER(kind=C_INT), INTENT(in), VALUE :: y + END SUBROUTINE SetMousePosition + + ! void SetMouseScale(float scaleX, float scaleY) + SUBROUTINE SetMouseScale(scale_x, scale_y) BIND(c, name='SetMouseScale') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale_x + REAL(kind=C_FLOAT), INTENT(in), VALUE :: scale_y + END SUBROUTINE SetMouseScale + + ! void SetMusicPan(Music music, float pan) + SUBROUTINE SetMusicPan(music, pan) BIND(c, name='SetMusicPan') + IMPORT :: C_FLOAT, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + REAL(kind=C_FLOAT), INTENT(in), VALUE :: pan + END SUBROUTINE SetMusicPan + + ! void SetMusicPitch(Music music, float pitch) + SUBROUTINE SetMusicPitch(music, pitch) BIND(c, name='SetMusicPitch') + IMPORT :: C_FLOAT, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch + END SUBROUTINE SetMusicPitch + + ! void SetMusicVolume(Music music, float volume) + SUBROUTINE SetMusicVolume(music, volume) BIND(c, name='SetMusicVolume') + IMPORT :: C_FLOAT, music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume + END SUBROUTINE SetMusicVolume + + ! void SetPixelColor(void *dstPtr, Color color, int format) +SUBROUTINE SetPixelColor(dst_ptr, color, FORMAT) BIND(c, name='SetPixelColor') + IMPORT :: C_INT, C_PTR, color_ + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: dst_ptr + TYPE(color_), INTENT(in), VALUE :: color + INTEGER(kind=C_INT), INTENT(in), VALUE :: FORMAT + END SUBROUTINE SetPixelColor + + ! void SetRandomSeed(unsigned int seed) + SUBROUTINE SetRandomSeed(seed) BIND(c, name='SetRandomSeed') + IMPORT :: c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: seed + END SUBROUTINE SetRandomSeed + + ! void SetSaveFileDataCallback(SaveFileDataCallback callback) + subroutine SetSaveFileDataCallback(callback) bind(c, name='SetSaveFileDataCallback') + IMPORT :: C_FUNPTR + IMPLICIT NONE + TYPE(C_FUNPTR), INTENT(in), VALUE :: callback + END SUBROUTINE SetSaveFileDataCallback + + ! void SetSaveFileTextCallback(SaveFileTextCallback callback) + subroutine SetSaveFileTextCallback(callback) bind(c, name='SetSaveFileTextCallback') + IMPORT :: C_FUNPTR + IMPLICIT NONE + TYPE(C_FUNPTR), INTENT(in), VALUE :: callback + END SUBROUTINE SetSaveFileTextCallback + + ! void SetShaderValue(Shader shader, int locIndex, const void *value, int uniformType) + subroutine SetShaderValue(shader, loc_index, value, uniform_) bind(c, name='SetShaderValue') + IMPORT :: C_INT, C_PTR, shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index + TYPE(C_PTR), INTENT(in), VALUE :: VALUE + INTEGER(kind=C_INT), INTENT(in), VALUE :: uniform_ + END SUBROUTINE SetShaderValue + + ! void SetShaderValueMatrix(Shader shader, int locIndex, Matrix mat) + subroutine SetShaderValueMatrix(shader, loc_index, mat) bind(c, name='SetShaderValueMatrix') + IMPORT :: C_INT, matrix_, shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index + TYPE(matrix_), INTENT(in), VALUE :: mat + END SUBROUTINE SetShaderValueMatrix + + ! void SetShaderValueTexture(Shader shader, int locIndex, Texture2D texture) + subroutine SetShaderValueTexture(shader, loc_index, texture) bind(c, name='SetShaderValueTexture') + IMPORT :: C_INT, shader_, texture2d_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index + TYPE(texture2d_), INTENT(in), VALUE :: texture + END SUBROUTINE SetShaderValueTexture + + ! void SetShaderValueV(Shader shader, int locIndex, const void *value, int uniformType, int count) + subroutine SetShaderValueV(shader, loc_index, value, uniform_, count) bind(c, name='SetShaderValueV') + IMPORT :: C_INT, C_PTR, shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + INTEGER(kind=C_INT), INTENT(in), VALUE :: loc_index + TYPE(C_PTR), INTENT(in), VALUE :: VALUE + INTEGER(kind=C_INT), INTENT(in), VALUE :: uniform_ + INTEGER(kind=C_INT), INTENT(in), VALUE :: count + END SUBROUTINE SetShaderValueV + + ! void SetShapesTexture(Texture2D texture, Rectangle source) + SUBROUTINE SetShapesTexture(texture, source) BIND(c, name='SetShapesTexture') + IMPORT :: rectangle_, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + TYPE(rectangle_), INTENT(in), VALUE :: source + END SUBROUTINE SetShapesTexture + + ! void SetSoundPan(Sound sound, float pan) + SUBROUTINE SetSoundPan(sound, pan) BIND(c, name='SetSoundPan') + IMPORT :: C_FLOAT, sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + REAL(kind=C_FLOAT), INTENT(in), VALUE :: pan + END SUBROUTINE SetSoundPan + + ! void SetSoundPitch(Sound sound, float pitch) + SUBROUTINE SetSoundPitch(sound, pitch) BIND(c, name='SetSoundPitch') + IMPORT :: C_FLOAT, sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + REAL(kind=C_FLOAT), INTENT(in), VALUE :: pitch + END SUBROUTINE SetSoundPitch + + ! void SetSoundVolume(Sound sound, float volume) + SUBROUTINE SetSoundVolume(sound, volume) BIND(c, name='SetSoundVolume') + IMPORT :: C_FLOAT, sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + REAL(kind=C_FLOAT), INTENT(in), VALUE :: volume + END SUBROUTINE SetSoundVolume + + ! void SetTargetFPS(int fps) + SUBROUTINE SetTargetFPS(fps) BIND(c, name='SetTargetFPS') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: fps + END SUBROUTINE SetTargetFPS + + ! void SetTextLineSpacing(int spacing) + SUBROUTINE SetTextLineSpacing(spacing) BIND(c, name='SetTextLineSpacing') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: spacing + END SUBROUTINE SetTextLineSpacing + + ! void SetTextureFilter(Texture2D texture, int filter) + SUBROUTINE SetTextureFilter(texture, filter) BIND(c, name='SetTextureFilter') + IMPORT :: C_INT, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + INTEGER(kind=C_INT), INTENT(in), VALUE :: filter + END SUBROUTINE SetTextureFilter + + ! void SetTextureWrap(Texture2D texture, int wrap) + SUBROUTINE SetTextureWrap(texture, wrap) BIND(c, name='SetTextureWrap') + IMPORT :: C_INT, texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + INTEGER(kind=C_INT), INTENT(in), VALUE :: wrap + END SUBROUTINE SetTextureWrap + + ! void SetTraceLogCallback(TraceLogCallback callback) + SUBROUTINE SetTraceLogCallback(callback) BIND(c, name='SetTraceLogCallback') + IMPORT :: C_FUNPTR + IMPLICIT NONE + TYPE(C_FUNPTR), INTENT(in), VALUE :: callback + END SUBROUTINE SetTraceLogCallback + + ! void SetTraceLogLevel(int logLevel) + SUBROUTINE SetTraceLogLevel(log_level) BIND(c, name='SetTraceLogLevel') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: log_level + END SUBROUTINE SetTraceLogLevel + + ! void SetWindowFocused(void) + SUBROUTINE SetWindowFocused() BIND(c, name='SetWindowFocused') + END SUBROUTINE SetWindowFocused + + ! void SetWindowIcon(Image image) + SUBROUTINE SetWindowIcon(image) BIND(c, name='SetWindowIcon') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + END SUBROUTINE SetWindowIcon + + ! void SetWindowIcons(Image *images, int count) + SUBROUTINE SetWindowIcons(images, count) BIND(c, name='SetWindowIcons') + IMPORT :: C_INT, image_ + IMPLICIT NONE + TYPE(image_), INTENT(inout) :: images + INTEGER(kind=C_INT), INTENT(in), VALUE :: count + END SUBROUTINE SetWindowIcons + + ! void SetWindowMaxSize(int width, int height) + SUBROUTINE SetWindowMaxSize(width, height) BIND(c, name='SetWindowMaxSize') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + END SUBROUTINE SetWindowMaxSize + + ! void SetWindowMinSize(int width, int height) + SUBROUTINE SetWindowMinSize(width, height) BIND(c, name='SetWindowMinSize') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + END SUBROUTINE SetWindowMinSize + + ! void SetWindowMonitor(int monitor) + SUBROUTINE SetWindowMonitor(monitor) BIND(c, name='SetWindowMonitor') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: monitor + END SUBROUTINE SetWindowMonitor + + ! void SetWindowOpacity(float opacity) + SUBROUTINE SetWindowOpacity(opacity) BIND(c, name='SetWindowOpacity') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(in), VALUE :: opacity + END SUBROUTINE SetWindowOpacity + + ! void SetWindowPosition(int x, int y) + SUBROUTINE SetWindowPosition(x, y) BIND(c, name='SetWindowPosition') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: x + INTEGER(kind=C_INT), INTENT(in), VALUE :: y + END SUBROUTINE SetWindowPosition + + ! void SetWindowSize(int width, int height) + SUBROUTINE SetWindowSize(width, height) BIND(c, name='SetWindowSize') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(in), VALUE :: width + INTEGER(kind=C_INT), INTENT(in), VALUE :: height + END SUBROUTINE SetWindowSize + + ! void SetWindowState(unsigned int flags) + SUBROUTINE SetWindowState(flags) BIND(c, name='SetWindowState') + IMPORT :: c_unsigned_int + IMPLICIT NONE + INTEGER(kind=c_unsigned_int), INTENT(in), VALUE :: flags + END SUBROUTINE SetWindowState + + ! void SetWindowTitle(const char *title) + SUBROUTINE SetWindowTitle(title) BIND(c, name='SetWindowTitle') + IMPORT :: C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: title + END SUBROUTINE SetWindowTitle + +END INTERFACE + +END MODULE RaylibSetMethods diff --git a/src/modules/RaylibInterface/src/RaylibTypes.F90 b/src/modules/RaylibInterface/src/RaylibTypes.F90 new file mode 100644 index 000000000..52f7725ad --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibTypes.F90 @@ -0,0 +1,380 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-02 +! summary: I have subdivided the big raylib module into smaller modules + +MODULE RaylibTypes +USE, INTRINSIC :: ISO_C_BINDING +IMPLICIT NONE +PRIVATE + +INTEGER, PARAMETER, PUBLIC :: c_unsigned_int = C_INT +INTEGER, PARAMETER, PUBLIC :: c_unsigned_char = C_SIGNED_CHAR + +REAL, PARAMETER, PUBLIC :: PI = ACOS(-1.0) + +! Vector2 +TYPE, BIND(c), PUBLIC :: vector2_ + REAL(kind=C_FLOAT) :: x = 0.0 + REAL(kind=C_FLOAT) :: y = 0.0 +END TYPE vector2_ + +! Vector3 +TYPE, BIND(c), PUBLIC :: vector3_ + REAL(kind=C_FLOAT) :: x = 0.0 + REAL(kind=C_FLOAT) :: y = 0.0 + REAL(kind=C_FLOAT) :: z = 0.0 +END TYPE vector3_ + +! Vector4 +TYPE, BIND(c), PUBLIC :: vector4_ + REAL(kind=C_FLOAT) :: x = 0.0 + REAL(kind=C_FLOAT) :: y = 0.0 + REAL(kind=C_FLOAT) :: z = 0.0 + REAL(kind=C_FLOAT) :: w = 0.0 +END TYPE vector4_ + +! Quaternion +TYPE, BIND(c), PUBLIC :: quaternion_ + REAL(kind=C_FLOAT) :: x = 0.0 + REAL(kind=C_FLOAT) :: y = 0.0 + REAL(kind=C_FLOAT) :: z = 0.0 + REAL(kind=C_FLOAT) :: w = 0.0 +END TYPE quaternion_ + +! Matrix +TYPE, BIND(c), PUBLIC :: matrix_ + REAL(kind=C_FLOAT) :: m0 = 0.0, m4 = 0.0, m8 = 0.0, m12 = 0.0 + REAL(kind=C_FLOAT) :: m1 = 0.0, m5 = 0.0, m9 = 0.0, m13 = 0.0 + REAL(kind=C_FLOAT) :: m2 = 0.0, m6 = 0.0, m10 = 0.0, m14 = 0.0 + REAL(kind=C_FLOAT) :: m3 = 0.0, m7 = 0.0, m11 = 0.0, m15 = 0.0 +END TYPE matrix_ + +! Color +TYPE, BIND(c), PUBLIC :: color_ + INTEGER(kind=c_unsigned_char) :: r = 0_C_UNSIGNED_CHAR + INTEGER(kind=c_unsigned_char) :: g = 0_C_UNSIGNED_CHAR + INTEGER(kind=c_unsigned_char) :: b = 0_C_UNSIGNED_CHAR + INTEGER(kind=c_unsigned_char) :: a = 255_C_UNSIGNED_CHAR +END TYPE color_ + +! Rectangle +TYPE, BIND(c), PUBLIC :: rectangle_ + REAL(kind=C_FLOAT) :: x = 0.0 + REAL(kind=C_FLOAT) :: y = 0.0 + REAL(kind=C_FLOAT) :: width = 0.0 + REAL(kind=C_FLOAT) :: height = 0.0 +END TYPE rectangle_ + +! Image +TYPE, BIND(c), PUBLIC :: image_ + TYPE(C_PTR) :: DATA = C_NULL_PTR !! void * + INTEGER(kind=C_INT) :: width = 0 + INTEGER(kind=C_INT) :: height = 0 + INTEGER(kind=C_INT) :: mipmaps = 0 + INTEGER(kind=C_INT) :: FORMAT = 0 +END TYPE image_ + +! Texture2D +TYPE, BIND(c), PUBLIC :: texture2d_ + INTEGER(kind=c_unsigned_int) :: id = 0 + INTEGER(kind=C_INT) :: width = 0 + INTEGER(kind=C_INT) :: height = 0 + INTEGER(kind=C_INT) :: mipmaps = 0 + INTEGER(kind=C_INT) :: FORMAT = 0 +END TYPE texture2d_ + +! TextureCubemap +TYPE, BIND(c), PUBLIC :: texture_cubemap_ + INTEGER(kind=c_unsigned_int) :: id = 0_C_UNSIGNED_INT + INTEGER(kind=C_INT) :: width = 0 + INTEGER(kind=C_INT) :: height = 0 + INTEGER(kind=C_INT) :: mipmaps = 0 + INTEGER(kind=C_INT) :: FORMAT = 0 +END TYPE texture_cubemap_ + +! RenderTexture +TYPE, BIND(c), PUBLIC :: render_texture_ + INTEGER(kind=c_unsigned_int) :: id = 0_C_UNSIGNED_INT + TYPE(texture2d_) :: texture + TYPE(texture2d_) :: depth +END TYPE render_texture_ + +! RenderTexture2D +TYPE, BIND(c), PUBLIC :: render_texture2d_ + INTEGER(kind=c_unsigned_int) :: id = 0_C_UNSIGNED_INT + TYPE(texture2d_) :: texture + TYPE(texture2d_) :: depth +END TYPE render_texture2d_ + +! NPatchInfo +TYPE, BIND(c), PUBLIC :: npatch_info_ + TYPE(rectangle_) :: source + INTEGER(kind=C_INT) :: left = 0 + INTEGER(kind=C_INT) :: top = 0 + INTEGER(kind=C_INT) :: right = 0 + INTEGER(kind=C_INT) :: bottom = 0 + INTEGER(kind=C_INT) :: layout = 0 +END TYPE npatch_info_ + +! GlyphInfo +TYPE, BIND(c), PUBLIC :: glyph_info_ + INTEGER(kind=C_INT) :: VALUE = 0 + INTEGER(kind=C_INT) :: offset_x = 0 + INTEGER(kind=C_INT) :: offset_y = 0 + INTEGER(kind=C_INT) :: advance_x = 0 + TYPE(image_) :: image +END TYPE glyph_info_ + +! Font +TYPE, BIND(c), PUBLIC :: font_ + INTEGER(kind=C_INT) :: base_size = 0 + INTEGER(kind=C_INT) :: glyph_count = 0 + INTEGER(kind=C_INT) :: glyph_padding = 0 + TYPE(texture2d_) :: texture + TYPE(C_PTR) :: recs = C_NULL_PTR !! Rectangle * + TYPE(C_PTR) :: glyphs = C_NULL_PTR !! GlyphInfo * +END TYPE font_ + +! Camera, Camera3D +TYPE, BIND(c), PUBLIC :: camera3d_ + TYPE(vector3_) :: position + TYPE(vector3_) :: TARGET + TYPE(vector3_) :: up + REAL(kind=C_FLOAT) :: fovy = 0.0 + INTEGER(kind=C_INT) :: projection = 0 +END TYPE camera3d_ + +! Camera2D +TYPE, BIND(c), PUBLIC :: camera2d_ + TYPE(vector2_) :: offset + TYPE(vector2_) :: TARGET + REAL(kind=C_FLOAT) :: rotation = 0.0 + REAL(kind=C_FLOAT) :: zoom = 0.0 +END TYPE camera2d_ + +! Mesh +TYPE, BIND(c), PUBLIC :: mesh_ + INTEGER(kind=C_INT) :: vertex_count = 0 + INTEGER(kind=C_INT) :: triangle_count = 0 + TYPE(C_PTR) :: vertices = C_NULL_PTR !! float * + TYPE(C_PTR) :: texcoords = C_NULL_PTR !! float * + TYPE(C_PTR) :: texcoords2 = C_NULL_PTR !! float * + TYPE(C_PTR) :: normals = C_NULL_PTR !! float * + TYPE(C_PTR) :: tangents = C_NULL_PTR !! float * + TYPE(C_PTR) :: colors = C_NULL_PTR !! unsigned char * + TYPE(C_PTR) :: indices = C_NULL_PTR !! unsigned short * + TYPE(C_PTR) :: anim_vertices = C_NULL_PTR !! float * + TYPE(C_PTR) :: anim_normals = C_NULL_PTR !! float * + TYPE(C_PTR) :: bone_ids = C_NULL_PTR !! unsigned char * + TYPE(C_PTR) :: bone_weights = C_NULL_PTR !! float * + INTEGER(kind=c_unsigned_int) :: vao_id = 0_C_UNSIGNED_INT + TYPE(C_PTR) :: vbo_id = C_NULL_PTR !! unsigned int * +END TYPE mesh_ + +! Shader +TYPE, BIND(c), PUBLIC :: shader_ + INTEGER(kind=c_unsigned_int) :: id = 0 + TYPE(C_PTR) :: locs = C_NULL_PTR !! int * +END TYPE shader_ + +! MaterialMap +TYPE, BIND(c), PUBLIC :: material_map_ + TYPE(texture2d_) :: texture + TYPE(color_) :: color + REAL(kind=C_FLOAT) :: VALUE = 0 +END TYPE material_map_ + +! Material +TYPE, BIND(c), PUBLIC :: material_ + TYPE(shader_) :: shader + TYPE(C_PTR) :: maps = C_NULL_PTR !! MaterialMap * + REAL(kind=C_FLOAT) :: params(0:3) = 0.0 +END TYPE material_ + +! Transform +TYPE, BIND(c), PUBLIC :: transform_ + TYPE(vector3_) :: translation + TYPE(quaternion_) :: rotation + TYPE(vector3_) :: scale +END TYPE transform_ + +! BoneInfo +TYPE, BIND(c), PUBLIC :: bone_info_ + CHARACTER(kind=C_CHAR) :: name(0:31) = C_NULL_CHAR + INTEGER(kind=C_INT) :: parent = 0 +END TYPE bone_info_ + +! Model +TYPE, BIND(c), PUBLIC :: model_ + TYPE(matrix_) :: transform + INTEGER(kind=C_INT) :: mesh_count = 0 + INTEGER(kind=C_INT) :: material_count = 0 + TYPE(C_PTR) :: meshes = C_NULL_PTR !! Mesh * + TYPE(C_PTR) :: materials = C_NULL_PTR !! Material * + TYPE(C_PTR) :: mesh_material = C_NULL_PTR !! int * + INTEGER(kind=C_INT) :: bone_count = 0 + TYPE(C_PTR) :: bones = C_NULL_PTR !! BoneInfo * + TYPE(C_PTR) :: bind_pose = C_NULL_PTR !! Transform * +END TYPE model_ + +! ModelAnimation +TYPE, BIND(c), PUBLIC :: model_animation_ + INTEGER(kind=C_INT) :: bone_count = 0 + INTEGER(kind=C_INT) :: frame_count = 0 + TYPE(C_PTR) :: bones = C_NULL_PTR !! BoneInfo * + TYPE(C_PTR) :: frame_poses = C_NULL_PTR !! Transform ** + CHARACTER(kind=C_CHAR) :: name(0:31) = C_NULL_CHAR +END TYPE model_animation_ + +! Ray +TYPE, BIND(c), PUBLIC :: ray_ + TYPE(vector3_) :: position + TYPE(vector3_) :: direction +END TYPE ray_ + +! RayCollision +TYPE, BIND(c), PUBLIC :: ray_collision_ + LOGICAL(kind=C_BOOL) :: hit = .FALSE._C_BOOL + REAL(kind=C_FLOAT) :: distance = 0.0 + TYPE(vector3_) :: point + TYPE(vector3_) :: normal +END TYPE ray_collision_ + +! BoundingBox +TYPE, BIND(c), PUBLIC :: bounding_box_ + TYPE(vector3_) :: min + TYPE(vector3_) :: max +END TYPE bounding_box_ + +! Wave +TYPE, BIND(c), PUBLIC :: wave_ + INTEGER(kind=c_unsigned_int) :: frame_count = 0_C_UNSIGNED_INT + INTEGER(kind=c_unsigned_int) :: sample_rate = 0_C_UNSIGNED_INT + INTEGER(kind=c_unsigned_int) :: sample_size = 0_C_UNSIGNED_INT + INTEGER(kind=c_unsigned_int) :: channels = 0_C_UNSIGNED_INT + TYPE(C_PTR) :: DATA = C_NULL_PTR !! void * +END TYPE wave_ + +! AudioStream +TYPE, BIND(c), PUBLIC :: audio_stream_ + TYPE(C_PTR) :: buffer = C_NULL_PTR !! rAudioBuffer * + TYPE(C_PTR) :: processor = C_NULL_PTR !! rAudioProcessor * + INTEGER(kind=c_unsigned_int) :: sample_rate = 0_C_UNSIGNED_INT + INTEGER(kind=c_unsigned_int) :: sample_size = 0_C_UNSIGNED_INT + INTEGER(kind=c_unsigned_int) :: channels = 0_C_UNSIGNED_INT +END TYPE audio_stream_ + +! Sound +TYPE, BIND(c), PUBLIC :: sound_ + TYPE(audio_stream_) :: stream + INTEGER(kind=c_unsigned_int) :: frame_count = 0 +END TYPE sound_ + +! Music +TYPE, BIND(c), PUBLIC :: music_ + TYPE(audio_stream_) :: stream + INTEGER(kind=c_unsigned_int) :: frame_count = 0_C_UNSIGNED_INT + LOGICAL(kind=C_BOOL) :: looping = .FALSE._C_BOOL + INTEGER(kind=C_INT) :: ctx_ = 0 + TYPE(C_PTR) :: ctx_data = C_NULL_PTR !! void * +END TYPE music_ + +! VrDeviceInfo +TYPE, BIND(c), PUBLIC :: vr_device_info_ + INTEGER(kind=C_INT) :: h_resolution = 0 + INTEGER(kind=C_INT) :: v_resolution = 0 + REAL(kind=C_FLOAT) :: h_screen_size = 0.0 + REAL(kind=C_FLOAT) :: v_screen_size = 0.0 + REAL(kind=C_FLOAT) :: v_screen_center = 0.0 + REAL(kind=C_FLOAT) :: eye_to_screen_distance = 0.0 + REAL(kind=C_FLOAT) :: lens_separation_distance = 0.0 + REAL(kind=C_FLOAT) :: interpupillary_distance = 0.0 + REAL(kind=C_FLOAT) :: lens_distortion_values(0:3) = 0.0 + REAL(kind=C_FLOAT) :: chroma_ab_correction(0:3) = 0.0 +END TYPE vr_device_info_ + +! VrStereoConfig +TYPE, BIND(c), PUBLIC :: vr_stereo_config_ + TYPE(matrix_) :: projection(0:1) + TYPE(matrix_) :: view_offset(0:1) + REAL(kind=C_FLOAT) :: left_lens_center(0:1) = 0.0 + REAL(kind=C_FLOAT) :: right_lens_center(0:1) = 0.0 + REAL(kind=C_FLOAT) :: left_screen_center(0:1) = 0.0 + REAL(kind=C_FLOAT) :: right_screen_center(0:1) = 0.0 + REAL(kind=C_FLOAT) :: SCALE(0:1) = 0.0 + REAL(kind=C_FLOAT) :: scale_in(0:1) = 0.0 +END TYPE vr_stereo_config_ + +! FilePathList +TYPE, BIND(c), PUBLIC :: file_path_list_ + INTEGER(kind=c_unsigned_int) :: capacity = 0_C_UNSIGNED_INT + INTEGER(kind=c_unsigned_int) :: count = 0_C_UNSIGNED_INT + TYPE(C_PTR) :: paths = C_NULL_PTR !! char ** +END TYPE file_path_list_ + +TYPE(color_), PARAMETER, PUBLIC :: LIGHTGRAY = & + color_(200_C_UNSIGNED_CHAR, & + 200_C_UNSIGNED_CHAR, 200_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: GRAY = color_(130_C_UNSIGNED_CHAR, & + 130_C_UNSIGNED_CHAR, 130_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: DARKGRAY = color_(80_C_UNSIGNED_CHAR, & + 80_C_UNSIGNED_CHAR, 80_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: YELLOW = color_(253_C_UNSIGNED_CHAR, & + 249_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: GOLD = color_(255_C_UNSIGNED_CHAR, & + 203_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: ORANGE = color_(255_C_UNSIGNED_CHAR, & + 161_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: PINK = color_(255_C_UNSIGNED_CHAR, & + 109_C_UNSIGNED_CHAR, 194_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: RED = color_(230_C_UNSIGNED_CHAR, & + 41_C_UNSIGNED_CHAR, 55_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: MAROON = color_(190_C_UNSIGNED_CHAR, & + 33_C_UNSIGNED_CHAR, 55_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: GREEN = color_(0_C_UNSIGNED_CHAR, & + 228_C_UNSIGNED_CHAR, 48_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: LIME = color_(0_C_UNSIGNED_CHAR, & + 158_C_UNSIGNED_CHAR, 47_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: DARKGREEN = color_(0_C_UNSIGNED_CHAR, & + 117_C_UNSIGNED_CHAR, 44_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: SKYBLUE = & + color_(102_C_UNSIGNED_CHAR, & + 191_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: BLUE = color_(0_C_UNSIGNED_CHAR, & + 121_C_UNSIGNED_CHAR, 241_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: DARKBLUE = color_(0_C_UNSIGNED_CHAR, & + 82_C_UNSIGNED_CHAR, 172_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: PURPLE = color_(200_C_UNSIGNED_CHAR, & + 122_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: VIOLET = color_(135_C_UNSIGNED_CHAR, & + 60_C_UNSIGNED_CHAR, 190_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: DARKPURPLE = & + color_(112_C_UNSIGNED_CHAR, & + 31_C_UNSIGNED_CHAR, 126_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: BEIGE = color_(211_C_UNSIGNED_CHAR, & + 176_C_UNSIGNED_CHAR, 131_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: BROWN = color_(127_C_UNSIGNED_CHAR, & + 106_C_UNSIGNED_CHAR, 79_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: DARKBROWN = color_(76_C_UNSIGNED_CHAR, & + 63_C_UNSIGNED_CHAR, 47_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: WHITE = color_(255_C_UNSIGNED_CHAR, & + 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: BLACK = color_(0_C_UNSIGNED_CHAR, & + 0_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: BLANK = color_(0_C_UNSIGNED_CHAR, & + 0_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR, 0_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: MAGENTA = color_(255_C_UNSIGNED_CHAR, & + 0_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) +TYPE(color_), PARAMETER, PUBLIC :: RAYWHITE = & + color_(245_C_UNSIGNED_CHAR, & + 245_C_UNSIGNED_CHAR, 245_C_UNSIGNED_CHAR, 255_C_UNSIGNED_CHAR) + +END MODULE RaylibTypes diff --git a/src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 b/src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 new file mode 100644 index 000000000..8323ef135 --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibUnloadMethods.F90 @@ -0,0 +1,237 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE RaylibUnloadMethods +USE, INTRINSIC :: ISO_C_BINDING +USE RaylibTypes +USE RaylibEnums +IMPLICIT NONE +PRIVATE + +PUBLIC :: UnloadWaveSamples +PUBLIC :: UnloadWave +PUBLIC :: UnloadVrStereoConfig +PUBLIC :: UnloadUTF8 +PUBLIC :: UnloadTexture +PUBLIC :: UnloadSoundAlias +PUBLIC :: UnloadSound +PUBLIC :: UnloadShader +PUBLIC :: UnloadRenderTexture +PUBLIC :: UnloadRandomSequence +PUBLIC :: UnloadMusicStream +PUBLIC :: UnloadModelAnimations +PUBLIC :: UnloadModelAnimation +PUBLIC :: UnloadModel +PUBLIC :: UnloadMesh +PUBLIC :: UnloadMaterial +PUBLIC :: UnloadImagePalette +PUBLIC :: UnloadImageColors +PUBLIC :: UnloadImage +PUBLIC :: UnloadFontData +PUBLIC :: UnloadFont +PUBLIC :: UnloadFileText +PUBLIC :: UnloadFileData +PUBLIC :: UnloadDroppedFiles +PUBLIC :: UnloadDirectoryFiles +PUBLIC :: UnloadCodepoints +PUBLIC :: UnloadAudioStream + +INTERFACE + ! void UnloadAudioStream(AudioStream stream) + SUBROUTINE UnloadAudioStream(stream) BIND(c, name='UnloadAudioStream') + IMPORT :: audio_stream_ + IMPLICIT NONE + TYPE(audio_stream_), INTENT(in), VALUE :: stream + END SUBROUTINE UnloadAudioStream + + ! void UnloadCodepoints(int *codepoints) + SUBROUTINE UnloadCodepoints(codepoints) BIND(c, name='UnloadCodepoints') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(inout) :: codepoints(*) + END SUBROUTINE UnloadCodepoints + + ! void UnloadDirectoryFiles(FilePathList files) + SUBROUTINE UnloadDirectoryFiles(files) BIND(c, name='UnloadDirectoryFiles') + IMPORT :: file_path_list_ + IMPLICIT NONE + TYPE(file_path_list_), INTENT(in), VALUE :: files + END SUBROUTINE UnloadDirectoryFiles + + ! void UnloadDroppedFiles(FilePathList files) + SUBROUTINE UnloadDroppedFiles(files) BIND(c, name='UnloadDroppedFiles') + IMPORT :: file_path_list_ + IMPLICIT NONE + TYPE(file_path_list_), INTENT(in), VALUE :: files + END SUBROUTINE UnloadDroppedFiles + + ! void UnloadFileData(unsigned char *data) + SUBROUTINE UnloadFileData(DATA) BIND(c, name='UnloadFileData') + IMPORT :: c_unsigned_char + IMPLICIT NONE + INTEGER(kind=c_unsigned_char), INTENT(in) :: DATA + END SUBROUTINE UnloadFileData + + ! void UnloadFileText(char *text) + SUBROUTINE UnloadFileText(text) BIND(c, name='UnloadFileText') + IMPORT :: C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + END SUBROUTINE UnloadFileText + + ! void UnloadFont(Font font) + SUBROUTINE UnloadFont(font) BIND(c, name='UnloadFont') + IMPORT :: font_ + IMPLICIT NONE + TYPE(font_), INTENT(in), VALUE :: font + END SUBROUTINE UnloadFont + + ! void UnloadFontData(GlyphInfo *glyphs, int glyphCount) + SUBROUTINE UnloadFontData(glyphs, glyph_count) BIND(c, name='UnloadFontData') + IMPORT :: C_INT, glyph_info_ + IMPLICIT NONE + TYPE(glyph_info_), INTENT(inout) :: glyphs + INTEGER(kind=C_INT), INTENT(in), VALUE :: glyph_count + END SUBROUTINE UnloadFontData + + ! void UnloadImage(Image image) + SUBROUTINE UnloadImage(image) BIND(c, name='UnloadImage') + IMPORT :: image_ + IMPLICIT NONE + TYPE(image_), INTENT(in), VALUE :: image + END SUBROUTINE UnloadImage + + ! void UnloadImageColors(Color *colors) + SUBROUTINE UnloadImageColors(colors) BIND(c, name='UnloadImageColors') + IMPORT :: color_ + IMPLICIT NONE + TYPE(color_), INTENT(inout) :: colors(*) + END SUBROUTINE UnloadImageColors + + ! void UnloadImagePalette(Color *colors) + SUBROUTINE UnloadImagePalette(colors) BIND(c, name='UnloadImagePalette') + IMPORT :: color_ + IMPLICIT NONE + TYPE(color_), INTENT(inout) :: colors(*) + END SUBROUTINE UnloadImagePalette + + ! void UnloadMaterial(Material material) + SUBROUTINE UnloadMaterial(material) BIND(c, name='UnloadMaterial') + IMPORT :: material_ + IMPLICIT NONE + TYPE(material_), INTENT(in), VALUE :: material + END SUBROUTINE UnloadMaterial + + ! void UnloadMesh(Mesh mesh) + SUBROUTINE UnloadMesh(mesh) BIND(c, name='UnloadMesh') + IMPORT :: mesh_ + IMPLICIT NONE + TYPE(mesh_), INTENT(in), VALUE :: mesh + END SUBROUTINE UnloadMesh + + ! void UnloadModel(Model model) + SUBROUTINE UnloadModel(model) BIND(c, name='UnloadModel') + IMPORT :: model_ + IMPLICIT NONE + TYPE(model_), INTENT(in), VALUE :: model + END SUBROUTINE UnloadModel + + ! void UnloadModelAnimation(ModelAnimation anim) + SUBROUTINE UnloadModelAnimation(anim) BIND(c, name='UnloadModelAnimation') + IMPORT :: model_animation_ + IMPLICIT NONE + TYPE(model_animation_), INTENT(in), VALUE :: anim + END SUBROUTINE UnloadModelAnimation + + ! void UnloadModelAnimations(ModelAnimation *animations, int count) + subroutine UnloadModelAnimations(animations, count) bind(c, name='UnloadModelAnimations') + IMPORT :: C_INT, model_animation_ + IMPLICIT NONE + TYPE(model_animation_), INTENT(inout) :: animations(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: count + END SUBROUTINE UnloadModelAnimations + + ! void UnloadMusicStream(Music music) + SUBROUTINE UnloadMusicStream(music) BIND(c, name='UnloadMusicStream') + IMPORT :: music_ + IMPLICIT NONE + TYPE(music_), INTENT(in), VALUE :: music + END SUBROUTINE UnloadMusicStream + + ! void UnloadRandomSequence(int *sequence) +SUBROUTINE UnloadRandomSequence(SEQUENCE) BIND(c, name='UnloadRandomSequence') + IMPORT :: C_INT + IMPLICIT NONE + INTEGER(kind=C_INT), INTENT(inout) :: SEQUENCE(*) + END SUBROUTINE UnloadRandomSequence + + ! void UnloadRenderTexture(RenderTexture2D target) + SUBROUTINE UnloadRenderTexture(TARGET) BIND(c, name='UnloadRenderTexture') + IMPORT :: render_texture2d_ + IMPLICIT NONE + TYPE(render_texture2d_), INTENT(in), VALUE :: TARGET + END SUBROUTINE UnloadRenderTexture + + ! void UnloadShader(Shader shader) + SUBROUTINE UnloadShader(shader) BIND(c, name='UnloadShader') + IMPORT :: shader_ + IMPLICIT NONE + TYPE(shader_), INTENT(in), VALUE :: shader + END SUBROUTINE UnloadShader + + ! void UnloadSound(Sound sound) + SUBROUTINE UnloadSound(sound) BIND(c, name='UnloadSound') + IMPORT :: sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: sound + END SUBROUTINE UnloadSound + + ! void UnloadSoundAlias(Sound alias) + SUBROUTINE UnloadSoundAlias(alias) BIND(c, name='UnloadSoundAlias') + IMPORT :: sound_ + IMPLICIT NONE + TYPE(sound_), INTENT(in), VALUE :: alias + END SUBROUTINE UnloadSoundAlias + + ! void UnloadTexture(Texture2D texture) + SUBROUTINE UnloadTexture(texture) BIND(c, name='UnloadTexture') + IMPORT :: texture2d_ + IMPLICIT NONE + TYPE(texture2d_), INTENT(in), VALUE :: texture + END SUBROUTINE UnloadTexture + + ! void UnloadUTF8(char *text) + SUBROUTINE UnloadUTF8(text) BIND(c, name='UnloadUTF8') + IMPORT :: C_CHAR + IMPLICIT NONE + CHARACTER(kind=C_CHAR), INTENT(in) :: text + END SUBROUTINE UnloadUTF8 + + ! void UnloadVrStereoConfig(VrStereoConfig config) + SUBROUTINE UnloadVrStereoConfig(config) BIND(c, name='UnloadVrStereoConfig') + IMPORT :: vr_stereo_config_ + IMPLICIT NONE + TYPE(vr_stereo_config_), INTENT(in), VALUE :: config + END SUBROUTINE UnloadVrStereoConfig + + ! void UnloadWave(Wave wave) + SUBROUTINE UnloadWave(wave) BIND(c, name='UnloadWave') + IMPORT :: wave_ + IMPLICIT NONE + TYPE(wave_), INTENT(in), VALUE :: wave + END SUBROUTINE UnloadWave + + ! void UnloadWaveSamples(float *samples) + SUBROUTINE UnloadWaveSamples(samples) BIND(c, name='UnloadWaveSamples') + IMPORT :: C_FLOAT + IMPLICIT NONE + REAL(kind=C_FLOAT), INTENT(inout) :: samples(*) + END SUBROUTINE UnloadWaveSamples +END INTERFACE + +END MODULE RaylibUnloadMethods diff --git a/src/modules/RaylibInterface/src/RaylibUtil.F90 b/src/modules/RaylibInterface/src/RaylibUtil.F90 new file mode 100644 index 000000000..3606e904d --- /dev/null +++ b/src/modules/RaylibInterface/src/RaylibUtil.F90 @@ -0,0 +1,48 @@ +! raylib_util.f90 +! +! Utility procedures for C inter-operability with raylib. +! +! Author: Philipp Engel +! Licence: ISC + +MODULE raylib_util +USE, INTRINSIC :: ISO_C_BINDING +IMPLICIT NONE(TYPE, EXTERNAL) +PRIVATE + +INTERFACE + FUNCTION c_strlen(str) BIND(c, name='strlen') + IMPORT :: C_PTR, C_SIZE_T + IMPLICIT NONE + TYPE(C_PTR), INTENT(in), VALUE :: str + INTEGER(kind=C_SIZE_T) :: c_strlen + END FUNCTION c_strlen +END INTERFACE + +PUBLIC :: c_f_str_ptr +CONTAINS +SUBROUTINE c_f_str_ptr(c_str, f_str) + !! Copies a C string, passed as a C pointer, to a Fortran string. + TYPE(C_PTR), INTENT(in) :: c_str + CHARACTER(:), ALLOCATABLE, INTENT(out) :: f_str + + CHARACTER(kind=C_CHAR), POINTER :: ptrs(:) + INTEGER(kind=C_SIZE_T) :: i, sz + + copy_block: BLOCK + IF (.NOT. C_ASSOCIATED(c_str)) EXIT copy_block + sz = c_strlen(c_str) + IF (sz < 0) EXIT copy_block + CALL C_F_POINTER(c_str, ptrs, [sz]) + ALLOCATE (CHARACTER(len=sz) :: f_str) + + DO i = 1, sz + f_str(i:i) = ptrs(i) + END DO + + RETURN + END BLOCK copy_block + + IF (.NOT. ALLOCATED(f_str)) f_str = '' +END SUBROUTINE c_f_str_ptr +END MODULE raylib_util diff --git a/src/modules/RaylibInterface/src/__Raylib.F90 b/src/modules/RaylibInterface/src/__Raylib.F90 new file mode 100644 index 000000000..5fa6177af --- /dev/null +++ b/src/modules/RaylibInterface/src/__Raylib.F90 @@ -0,0 +1,5913 @@ +! raylib.f90 +! +! A collection of auto-generated Fortran 2018 interface bindings to +! raylib 5.1. +! +! Author: Philipp Engel +! Licence: ISC + +module Raylib + use, intrinsic :: iso_c_binding + implicit none (type, external) + private + + integer, parameter, public :: c_unsigned_int = c_int + integer, parameter, public :: c_unsigned_char = c_signed_char + + real, parameter, public :: PI = acos(-1.0) + + ! Vector2 + type, bind(c), public :: vector2_type + real(kind=c_float) :: x = 0.0 + real(kind=c_float) :: y = 0.0 + end type vector2_type + + ! Vector3 + type, bind(c), public :: vector3_type + real(kind=c_float) :: x = 0.0 + real(kind=c_float) :: y = 0.0 + real(kind=c_float) :: z = 0.0 + end type vector3_type + + ! Vector4 + type, bind(c), public :: vector4_type + real(kind=c_float) :: x = 0.0 + real(kind=c_float) :: y = 0.0 + real(kind=c_float) :: z = 0.0 + real(kind=c_float) :: w = 0.0 + end type vector4_type + + ! Quaternion + type, bind(c), public :: quaternion_type + real(kind=c_float) :: x = 0.0 + real(kind=c_float) :: y = 0.0 + real(kind=c_float) :: z = 0.0 + real(kind=c_float) :: w = 0.0 + end type quaternion_type + + ! Matrix + type, bind(c), public :: matrix_type + real(kind=c_float) :: m0 = 0.0, m4 = 0.0, m8 = 0.0, m12 = 0.0 + real(kind=c_float) :: m1 = 0.0, m5 = 0.0, m9 = 0.0, m13 = 0.0 + real(kind=c_float) :: m2 = 0.0, m6 = 0.0, m10 = 0.0, m14 = 0.0 + real(kind=c_float) :: m3 = 0.0, m7 = 0.0, m11 = 0.0, m15 = 0.0 + end type matrix_type + + ! Color + type, bind(c), public :: color_type + integer(kind=c_unsigned_char) :: r = 0_c_unsigned_int + integer(kind=c_unsigned_char) :: g = 0_c_unsigned_int + integer(kind=c_unsigned_char) :: b = 0_c_unsigned_int + integer(kind=c_unsigned_char) :: a = 255_c_unsigned_int + end type color_type + + ! Rectangle + type, bind(c), public :: rectangle_type + real(kind=c_float) :: x = 0.0 + real(kind=c_float) :: y = 0.0 + real(kind=c_float) :: width = 0.0 + real(kind=c_float) :: height = 0.0 + end type rectangle_type + + ! Image + type, bind(c), public :: image_type + type(c_ptr) :: data = c_null_ptr !! void * + integer(kind=c_int) :: width = 0 + integer(kind=c_int) :: height = 0 + integer(kind=c_int) :: mipmaps = 0 + integer(kind=c_int) :: format = 0 + end type image_type + + ! Texture2D + type, bind(c), public :: texture2d_type + integer(kind=c_unsigned_int) :: id = 0 + integer(kind=c_int) :: width = 0 + integer(kind=c_int) :: height = 0 + integer(kind=c_int) :: mipmaps = 0 + integer(kind=c_int) :: format = 0 + end type texture2d_type + + ! TextureCubemap + type, bind(c), public :: texture_cubemap_type + integer(kind=c_unsigned_int) :: id = 0_c_unsigned_int + integer(kind=c_int) :: width = 0 + integer(kind=c_int) :: height = 0 + integer(kind=c_int) :: mipmaps = 0 + integer(kind=c_int) :: format = 0 + end type texture_cubemap_type + + ! RenderTexture + type, bind(c), public :: render_texture_type + integer(kind=c_unsigned_int) :: id = 0_c_unsigned_int + type(texture2d_type) :: texture + type(texture2d_type) :: depth + end type render_texture_type + + ! RenderTexture2D + type, bind(c), public :: render_texture2d_type + integer(kind=c_unsigned_int) :: id = 0_c_unsigned_int + type(texture2d_type) :: texture + type(texture2d_type) :: depth + end type render_texture2d_type + + ! NPatchInfo + type, bind(c), public :: npatch_info_type + type(rectangle_type) :: source + integer(kind=c_int) :: left = 0 + integer(kind=c_int) :: top = 0 + integer(kind=c_int) :: right = 0 + integer(kind=c_int) :: bottom = 0 + integer(kind=c_int) :: layout = 0 + end type npatch_info_type + + ! GlyphInfo + type, bind(c), public :: glyph_info_type + integer(kind=c_int) :: value = 0 + integer(kind=c_int) :: offset_x = 0 + integer(kind=c_int) :: offset_y = 0 + integer(kind=c_int) :: advance_x = 0 + type(image_type) :: image + end type glyph_info_type + + ! Font + type, bind(c), public :: font_type + integer(kind=c_int) :: base_size = 0 + integer(kind=c_int) :: glyph_count = 0 + integer(kind=c_int) :: glyph_padding = 0 + type(texture2d_type) :: texture + type(c_ptr) :: recs = c_null_ptr !! Rectangle * + type(c_ptr) :: glyphs = c_null_ptr !! GlyphInfo * + end type font_type + + ! Camera, Camera3D + type, bind(c), public :: camera3d_type + type(vector3_type) :: position + type(vector3_type) :: target + type(vector3_type) :: up + real(kind=c_float) :: fov_y = 0.0 + integer(kind=c_int) :: projection = 0 + end type camera3d_type + + ! Camera2D + type, bind(c), public :: camera2d_type + type(vector2_type) :: offset + type(vector2_type) :: target + real(kind=c_float) :: rotation = 0.0 + real(kind=c_float) :: zoom = 0.0 + end type camera2d_type + + ! Mesh + type, bind(c), public :: mesh_type + integer(kind=c_int) :: vertex_count = 0 + integer(kind=c_int) :: triangle_count = 0 + type(c_ptr) :: vertices = c_null_ptr !! float * + type(c_ptr) :: texcoords = c_null_ptr !! float * + type(c_ptr) :: texcoords2 = c_null_ptr !! float * + type(c_ptr) :: normals = c_null_ptr !! float * + type(c_ptr) :: tangents = c_null_ptr !! float * + type(c_ptr) :: colors = c_null_ptr !! unsigned char * + type(c_ptr) :: indices = c_null_ptr !! unsigned short * + type(c_ptr) :: anim_vertices = c_null_ptr !! float * + type(c_ptr) :: anim_normals = c_null_ptr !! float * + type(c_ptr) :: bone_ids = c_null_ptr !! unsigned char * + type(c_ptr) :: bone_weights = c_null_ptr !! float * + integer(kind=c_unsigned_int) :: vao_id = 0_c_unsigned_int + type(c_ptr) :: vbo_id = c_null_ptr !! unsigned int * + end type mesh_type + + ! Shader + type, bind(c), public :: shader_type + integer(kind=c_unsigned_int) :: id = 0 + type(c_ptr) :: locs = c_null_ptr !! int * + end type shader_type + + ! MaterialMap + type, bind(c), public :: material_map_type + type(texture2d_type) :: texture + type(color_type) :: color + real(kind=c_float) :: value = 0 + end type material_map_type + + ! Material + type, bind(c), public :: material_type + type(shader_type) :: shader + type(c_ptr) :: maps = c_null_ptr !! MaterialMap * + real(kind=c_float) :: params(0:3) = 0.0 + end type material_type + + ! Transform + type, bind(c), public :: transform_type + type(vector3_type) :: translation + type(quaternion_type) :: rotation + type(vector3_type) :: scale + end type transform_type + + ! BoneInfo + type, bind(c), public :: bone_info_type + character(kind=c_char) :: name(0:31) = c_null_char + integer(kind=c_int) :: parent = 0 + end type bone_info_type + + ! Model + type, bind(c), public :: model_type + type(matrix_type) :: transform + integer(kind=c_int) :: mesh_count = 0 + integer(kind=c_int) :: material_count = 0 + type(c_ptr) :: meshes = c_null_ptr !! Mesh * + type(c_ptr) :: materials = c_null_ptr !! Material * + type(c_ptr) :: mesh_material = c_null_ptr !! int * + integer(kind=c_int) :: bone_count = 0 + type(c_ptr) :: bones = c_null_ptr !! BoneInfo * + type(c_ptr) :: bind_pose = c_null_ptr !! Transform * + end type model_type + + ! ModelAnimation + type, bind(c), public :: model_animation_type + integer(kind=c_int) :: bone_count = 0 + integer(kind=c_int) :: frame_count = 0 + type(c_ptr) :: bones = c_null_ptr !! BoneInfo * + type(c_ptr) :: frame_poses = c_null_ptr !! Transform ** + character(kind=c_char) :: name(0:31) = c_null_char + end type model_animation_type + + ! Ray + type, bind(c), public :: ray_type + type(vector3_type) :: position + type(vector3_type) :: direction + end type ray_type + + ! RayCollision + type, bind(c), public :: ray_collision_type + logical(kind=c_bool) :: hit = .false._c_bool + real(kind=c_float) :: distance = 0.0 + type(vector3_type) :: point + type(vector3_type) :: normal + end type ray_collision_type + + ! BoundingBox + type, bind(c), public :: bounding_box_type + type(vector3_type) :: min + type(vector3_type) :: max + end type bounding_box_type + + ! Wave + type, bind(c), public :: wave_type + integer(kind=c_unsigned_int) :: frame_count = 0_c_unsigned_int + integer(kind=c_unsigned_int) :: sample_rate = 0_c_unsigned_int + integer(kind=c_unsigned_int) :: sample_size = 0_c_unsigned_int + integer(kind=c_unsigned_int) :: channels = 0_c_unsigned_int + type(c_ptr) :: data = c_null_ptr !! void * + end type wave_type + + ! AudioStream + type, bind(c), public :: audio_stream_type + type(c_ptr) :: buffer = c_null_ptr !! rAudioBuffer * + type(c_ptr) :: processor = c_null_ptr !! rAudioProcessor * + integer(kind=c_unsigned_int) :: sample_rate = 0_c_unsigned_int + integer(kind=c_unsigned_int) :: sample_size = 0_c_unsigned_int + integer(kind=c_unsigned_int) :: channels = 0_c_unsigned_int + end type audio_stream_type + + ! Sound + type, bind(c), public :: sound_type + type(audio_stream_type) :: stream + integer(kind=c_unsigned_int) :: frame_count = 0 + end type sound_type + + ! Music + type, bind(c), public :: music_type + type(audio_stream_type) :: stream + integer(kind=c_unsigned_int) :: frame_count = 0_c_unsigned_int + logical(kind=c_bool) :: looping = .false._c_bool + integer(kind=c_int) :: ctx_type = 0 + type(c_ptr) :: ctx_data = c_null_ptr !! void * + end type music_type + + ! VrDeviceInfo + type, bind(c), public :: vr_device_info_type + integer(kind=c_int) :: h_resolution = 0 + integer(kind=c_int) :: v_resolution = 0 + real(kind=c_float) :: h_screen_size = 0.0 + real(kind=c_float) :: v_screen_size = 0.0 + real(kind=c_float) :: v_screen_center = 0.0 + real(kind=c_float) :: eye_to_screen_distance = 0.0 + real(kind=c_float) :: lens_separation_distance = 0.0 + real(kind=c_float) :: interpupillary_distance = 0.0 + real(kind=c_float) :: lens_distortion_values(0:3) = 0.0 + real(kind=c_float) :: chroma_ab_correction(0:3) = 0.0 + end type vr_device_info_type + + ! VrStereoConfig + type, bind(c), public :: vr_stereo_config_type + type(matrix_type) :: projection(0:1) + type(matrix_type) :: view_offset(0:1) + real(kind=c_float) :: left_lens_center(0:1) = 0.0 + real(kind=c_float) :: right_lens_center(0:1) = 0.0 + real(kind=c_float) :: left_screen_center(0:1) = 0.0 + real(kind=c_float) :: right_screen_center(0:1) = 0.0 + real(kind=c_float) :: scale(0:1) = 0.0 + real(kind=c_float) :: scale_in(0:1) = 0.0 + end type vr_stereo_config_type + + ! FilePathList + type, bind(c), public :: file_path_list_type + integer(kind=c_unsigned_int) :: capacity = 0_c_unsigned_int + integer(kind=c_unsigned_int) :: count = 0_c_unsigned_int + type(c_ptr) :: paths = c_null_ptr !! char ** + end type file_path_list_type + + type(color_type), parameter, public :: LIGHTGRAY = color_type(200, 200, 200, 255) + type(color_type), parameter, public :: GRAY = color_type(130, 130, 130, 255) + type(color_type), parameter, public :: DARKGRAY = color_type( 80, 80, 80, 255) + type(color_type), parameter, public :: YELLOW = color_type(253, 249, 0, 255) + type(color_type), parameter, public :: GOLD = color_type(255, 203, 0, 255) + type(color_type), parameter, public :: ORANGE = color_type(255, 161, 0, 255) + type(color_type), parameter, public :: PINK = color_type(255, 109, 194, 255) + type(color_type), parameter, public :: RED = color_type(230, 41, 55, 255) + type(color_type), parameter, public :: MAROON = color_type(190, 33, 55, 255) + type(color_type), parameter, public :: GREEN = color_type( 0, 228, 48, 255) + type(color_type), parameter, public :: LIME = color_type( 0, 158, 47, 255) + type(color_type), parameter, public :: DARKGREEN = color_type( 0, 117, 44, 255) + type(color_type), parameter, public :: SKYBLUE = color_type(102, 191, 255, 255) + type(color_type), parameter, public :: BLUE = color_type( 0, 121, 241, 255) + type(color_type), parameter, public :: DARKBLUE = color_type( 0, 82, 172, 255) + type(color_type), parameter, public :: PURPLE = color_type(200, 122, 255, 255) + type(color_type), parameter, public :: VIOLET = color_type(135, 60, 190, 255) + type(color_type), parameter, public :: DARKPURPLE = color_type(112, 31, 126, 255) + type(color_type), parameter, public :: BEIGE = color_type(211, 176, 131, 255) + type(color_type), parameter, public :: BROWN = color_type(127, 106, 79, 255) + type(color_type), parameter, public :: DARKBROWN = color_type( 76, 63, 47, 255) + type(color_type), parameter, public :: WHITE = color_type(255, 255, 255, 255) + type(color_type), parameter, public :: BLACK = color_type( 0, 0, 0, 255) + type(color_type), parameter, public :: BLANK = color_type( 0, 0, 0, 0) + type(color_type), parameter, public :: MAGENTA = color_type(255, 0, 255, 255) + type(color_type), parameter, public :: RAYWHITE = color_type(245, 245, 245, 255) + + ! ConfigFlags + integer(kind=c_int), parameter, public :: FLAG_VSYNC_HINT = int(z'00000040') + integer(kind=c_int), parameter, public :: FLAG_FULLSCREEN_MODE = int(z'00000002') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_RESIZABLE = int(z'00000004') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_UNDECORATED = int(z'00000008') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_HIDDEN = int(z'00000080') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_MINIMIZED = int(z'00000200') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_MAXIMIZED = int(z'00000400') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_UNFOCUSED = int(z'00000800') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_TOPMOST = int(z'00001000') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_ALWAYS_RUN = int(z'00000100') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_TRANSPARENT = int(z'00000010') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_HIGHDPI = int(z'00002000') + integer(kind=c_int), parameter, public :: FLAG_WINDOW_MOUSE_PASSTHROUGH = int(z'00004000') + integer(kind=c_int), parameter, public :: FLAG_BORDERLESS_WINDOWED_MODE = int(z'00008000') + integer(kind=c_int), parameter, public :: FLAG_MSAA_4X_HINT = int(z'00000020') + integer(kind=c_int), parameter, public :: FLAG_INTERLACED_HINT = int(z'00010000') + + ! TraceLogLevel + integer(kind=c_int), parameter, public :: LOG_ALL = 0 + integer(kind=c_int), parameter, public :: LOG_TRACE = 1 + integer(kind=c_int), parameter, public :: LOG_DEBUG = 2 + integer(kind=c_int), parameter, public :: LOG_INFO = 3 + integer(kind=c_int), parameter, public :: LOG_WARNING = 4 + integer(kind=c_int), parameter, public :: LOG_ERROR = 5 + integer(kind=c_int), parameter, public :: LOG_FATAL = 6 + integer(kind=c_int), parameter, public :: LOG_NONE = 7 + + ! KeyboardKey + integer(kind=c_int), parameter, public :: KEY_NULL = 0 + integer(kind=c_int), parameter, public :: KEY_APOSTROPHE = 39 + integer(kind=c_int), parameter, public :: KEY_COMMA = 44 + integer(kind=c_int), parameter, public :: KEY_MINUS = 45 + integer(kind=c_int), parameter, public :: KEY_PERIOD = 46 + integer(kind=c_int), parameter, public :: KEY_SLASH = 47 + integer(kind=c_int), parameter, public :: KEY_ZERO = 48 + integer(kind=c_int), parameter, public :: KEY_ONE = 49 + integer(kind=c_int), parameter, public :: KEY_TWO = 50 + integer(kind=c_int), parameter, public :: KEY_THREE = 51 + integer(kind=c_int), parameter, public :: KEY_FOUR = 52 + integer(kind=c_int), parameter, public :: KEY_FIVE = 53 + integer(kind=c_int), parameter, public :: KEY_SIX = 54 + integer(kind=c_int), parameter, public :: KEY_SEVEN = 55 + integer(kind=c_int), parameter, public :: KEY_EIGHT = 56 + integer(kind=c_int), parameter, public :: KEY_NINE = 57 + integer(kind=c_int), parameter, public :: KEY_SEMICOLON = 59 + integer(kind=c_int), parameter, public :: KEY_EQUAL = 61 + integer(kind=c_int), parameter, public :: KEY_A = 65 + integer(kind=c_int), parameter, public :: KEY_B = 66 + integer(kind=c_int), parameter, public :: KEY_C = 67 + integer(kind=c_int), parameter, public :: KEY_D = 68 + integer(kind=c_int), parameter, public :: KEY_E = 69 + integer(kind=c_int), parameter, public :: KEY_F = 70 + integer(kind=c_int), parameter, public :: KEY_G = 71 + integer(kind=c_int), parameter, public :: KEY_H = 72 + integer(kind=c_int), parameter, public :: KEY_I = 73 + integer(kind=c_int), parameter, public :: KEY_J = 74 + integer(kind=c_int), parameter, public :: KEY_K = 75 + integer(kind=c_int), parameter, public :: KEY_L = 76 + integer(kind=c_int), parameter, public :: KEY_M = 77 + integer(kind=c_int), parameter, public :: KEY_N = 78 + integer(kind=c_int), parameter, public :: KEY_O = 79 + integer(kind=c_int), parameter, public :: KEY_P = 80 + integer(kind=c_int), parameter, public :: KEY_Q = 81 + integer(kind=c_int), parameter, public :: KEY_R = 82 + integer(kind=c_int), parameter, public :: KEY_S = 83 + integer(kind=c_int), parameter, public :: KEY_T = 84 + integer(kind=c_int), parameter, public :: KEY_U = 85 + integer(kind=c_int), parameter, public :: KEY_V = 86 + integer(kind=c_int), parameter, public :: KEY_W = 87 + integer(kind=c_int), parameter, public :: KEY_X = 88 + integer(kind=c_int), parameter, public :: KEY_Y = 89 + integer(kind=c_int), parameter, public :: KEY_Z = 90 + integer(kind=c_int), parameter, public :: KEY_LEFT_BRACKET = 91 + integer(kind=c_int), parameter, public :: KEY_BACKSLASH = 92 + integer(kind=c_int), parameter, public :: KEY_RIGHT_BRACKET = 93 + integer(kind=c_int), parameter, public :: KEY_GRAVE = 96 + integer(kind=c_int), parameter, public :: KEY_SPACE = 32 + integer(kind=c_int), parameter, public :: KEY_ESCAPE = 256 + integer(kind=c_int), parameter, public :: KEY_ENTER = 257 + integer(kind=c_int), parameter, public :: KEY_TAB = 258 + integer(kind=c_int), parameter, public :: KEY_BACKSPACE = 259 + integer(kind=c_int), parameter, public :: KEY_INSERT = 260 + integer(kind=c_int), parameter, public :: KEY_DELETE = 261 + integer(kind=c_int), parameter, public :: KEY_RIGHT = 262 + integer(kind=c_int), parameter, public :: KEY_LEFT = 263 + integer(kind=c_int), parameter, public :: KEY_DOWN = 264 + integer(kind=c_int), parameter, public :: KEY_UP = 265 + integer(kind=c_int), parameter, public :: KEY_PAGE_UP = 266 + integer(kind=c_int), parameter, public :: KEY_PAGE_DOWN = 267 + integer(kind=c_int), parameter, public :: KEY_HOME = 268 + integer(kind=c_int), parameter, public :: KEY_END = 269 + integer(kind=c_int), parameter, public :: KEY_CAPS_LOCK = 280 + integer(kind=c_int), parameter, public :: KEY_SCROLL_LOCK = 281 + integer(kind=c_int), parameter, public :: KEY_NUM_LOCK = 282 + integer(kind=c_int), parameter, public :: KEY_PRINT_SCREEN = 283 + integer(kind=c_int), parameter, public :: KEY_PAUSE = 284 + integer(kind=c_int), parameter, public :: KEY_F1 = 290 + integer(kind=c_int), parameter, public :: KEY_F2 = 291 + integer(kind=c_int), parameter, public :: KEY_F3 = 292 + integer(kind=c_int), parameter, public :: KEY_F4 = 293 + integer(kind=c_int), parameter, public :: KEY_F5 = 294 + integer(kind=c_int), parameter, public :: KEY_F6 = 295 + integer(kind=c_int), parameter, public :: KEY_F7 = 296 + integer(kind=c_int), parameter, public :: KEY_F8 = 297 + integer(kind=c_int), parameter, public :: KEY_F9 = 298 + integer(kind=c_int), parameter, public :: KEY_F10 = 299 + integer(kind=c_int), parameter, public :: KEY_F11 = 300 + integer(kind=c_int), parameter, public :: KEY_F12 = 301 + integer(kind=c_int), parameter, public :: KEY_LEFT_SHIFT = 340 + integer(kind=c_int), parameter, public :: KEY_LEFT_CONTROL = 341 + integer(kind=c_int), parameter, public :: KEY_LEFT_ALT = 342 + integer(kind=c_int), parameter, public :: KEY_LEFT_SUPER = 343 + integer(kind=c_int), parameter, public :: KEY_RIGHT_SHIFT = 344 + integer(kind=c_int), parameter, public :: KEY_RIGHT_CONTROL = 345 + integer(kind=c_int), parameter, public :: KEY_RIGHT_ALT = 346 + integer(kind=c_int), parameter, public :: KEY_RIGHT_SUPER = 347 + integer(kind=c_int), parameter, public :: KEY_KB_MENU = 348 + integer(kind=c_int), parameter, public :: KEY_KP_0 = 320 + integer(kind=c_int), parameter, public :: KEY_KP_1 = 321 + integer(kind=c_int), parameter, public :: KEY_KP_2 = 322 + integer(kind=c_int), parameter, public :: KEY_KP_3 = 323 + integer(kind=c_int), parameter, public :: KEY_KP_4 = 324 + integer(kind=c_int), parameter, public :: KEY_KP_5 = 325 + integer(kind=c_int), parameter, public :: KEY_KP_6 = 326 + integer(kind=c_int), parameter, public :: KEY_KP_7 = 327 + integer(kind=c_int), parameter, public :: KEY_KP_8 = 328 + integer(kind=c_int), parameter, public :: KEY_KP_9 = 329 + integer(kind=c_int), parameter, public :: KEY_KP_DECIMAL = 330 + integer(kind=c_int), parameter, public :: KEY_KP_DIVIDE = 331 + integer(kind=c_int), parameter, public :: KEY_KP_MULTIPLY = 332 + integer(kind=c_int), parameter, public :: KEY_KP_SUBTRACT = 333 + integer(kind=c_int), parameter, public :: KEY_KP_ADD = 334 + integer(kind=c_int), parameter, public :: KEY_KP_ENTER = 335 + integer(kind=c_int), parameter, public :: KEY_KP_EQUAL = 336 + integer(kind=c_int), parameter, public :: KEY_BACK = 4 + integer(kind=c_int), parameter, public :: KEY_MENU = 82 + integer(kind=c_int), parameter, public :: KEY_VOLUME_UP = 24 + integer(kind=c_int), parameter, public :: KEY_VOLUME_DOWN = 25 + + ! MouseButton + integer(kind=c_int), parameter, public :: MOUSE_BUTTON_LEFT = 0 + integer(kind=c_int), parameter, public :: MOUSE_BUTTON_RIGHT = 1 + integer(kind=c_int), parameter, public :: MOUSE_BUTTON_MIDDLE = 2 + integer(kind=c_int), parameter, public :: MOUSE_BUTTON_SIDE = 3 + integer(kind=c_int), parameter, public :: MOUSE_BUTTON_EXTRA = 4 + integer(kind=c_int), parameter, public :: MOUSE_BUTTON_FORWARD = 5 + integer(kind=c_int), parameter, public :: MOUSE_BUTTON_BACK = 6 + + ! MouseCursor + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_DEFAULT = 0 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_ARROW = 1 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_IBEAM = 2 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_CROSSHAIR = 3 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_POINTING_HAND = 4 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_EW = 5 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_NS = 6 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_NWSE = 7 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_NESW = 8 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_RESIZE_ALL = 9 + integer(kind=c_int), parameter, public :: MOUSE_CURSOR_NOT_ALLOWED = 10 + + ! GamepadButton + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_UNKNOWN = 0 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_UP = 1 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_RIGHT = 2 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_DOWN = 3 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_FACE_LEFT = 4 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_UP = 5 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_RIGHT = 6 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_DOWN = 7 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_FACE_LEFT = 8 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_TRIGGER_1 = 9 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_TRIGGER_2 = 10 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_TRIGGER_1 = 11 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_TRIGGER_2 = 12 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_MIDDLE_LEFT = 13 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_MIDDLE = 14 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_MIDDLE_RIGHT = 15 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_LEFT_THUMB = 16 + integer(kind=c_int), parameter, public :: GAMEPAD_BUTTON_RIGHT_THUMB = 17 + + ! GamepadAxis + integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_LEFT_X = 0 + integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_LEFT_Y = 1 + integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_RIGHT_X = 2 + integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_RIGHT_Y = 3 + integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_LEFT_TRIGGER = 4 + integer(kind=c_int), parameter, public :: GAMEPAD_AXIS_RIGHT_TRIGGER = 5 + + ! MaterialMapIndex + integer(kind=c_int), parameter, public :: MATERIAL_MAP_ALBEDO = 0 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_METALNESS = 1 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_NORMAL = 2 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_ROUGHNESS = 3 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_OCCLUSION = 4 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_EMISSION = 5 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_HEIGHT = 6 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_CUBEMAP = 7 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_IRRADIANCE = 8 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_PREFILTER = 9 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_BRDF = 10 + + integer(kind=c_int), parameter, public :: MATERIAL_MAP_DIFFUSE = 0 + integer(kind=c_int), parameter, public :: MATERIAL_MAP_SPECULAR = 1 + + ! ShaderLocationIndex + integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_POSITION = 0 + integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_TEXCOORD01 = 1 + integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_TEXCOORD02 = 2 + integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_NORMAL = 3 + integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_TANGENT = 4 + integer(kind=c_int), parameter, public :: SHADER_LOC_VERTEX_COLOR = 5 + integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_MVP = 6 + integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_VIEW = 7 + integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_PROJECTION = 8 + integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_MODEL = 9 + integer(kind=c_int), parameter, public :: SHADER_LOC_MATRIX_NORMAL = 10 + integer(kind=c_int), parameter, public :: SHADER_LOC_VECTOR_VIEW = 11 + integer(kind=c_int), parameter, public :: SHADER_LOC_COLOR_DIFFUSE = 12 + integer(kind=c_int), parameter, public :: SHADER_LOC_COLOR_SPECULAR = 13 + integer(kind=c_int), parameter, public :: SHADER_LOC_COLOR_AMBIENT = 14 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_ALBEDO = 15 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_METALNESS = 16 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_NORMAL = 17 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_ROUGHNESS = 18 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_OCCLUSION = 19 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_EMISSION = 20 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_HEIGHT = 21 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_CUBEMAP = 22 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_IRRADIANCE = 23 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_PREFILTER = 24 + integer(kind=c_int), parameter, public :: SHADER_LOC_MAP_BRDF = 25 + + ! ShaderUniformDataType + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_FLOAT = 0 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_VEC2 = 1 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_VEC3 = 2 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_VEC4 = 3 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_INT = 4 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_IVEC2 = 5 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_IVEC3 = 6 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_IVEC4 = 7 + integer(kind=c_int), parameter, public :: SHADER_UNIFORM_SAMPLER2D = 8 + + ! ShaderAttributeDataType + integer(kind=c_int), parameter, public :: SHADER_ATTRIB_FLOAT = 0 + integer(kind=c_int), parameter, public :: SHADER_ATTRIB_VEC2 = 1 + integer(kind=c_int), parameter, public :: SHADER_ATTRIB_VEC3 = 2 + integer(kind=c_int), parameter, public :: SHADER_ATTRIB_VEC4 = 3 + + ! PixelFormat + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_GRAYSCALE = 1 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_GRAY_ALPHA = 2 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R5G6B5 = 3 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R8G8B8 = 4 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R5G5B5A1 = 5 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R4G4B4A4 = 6 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R8G8B8A8 = 7 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R32 = 8 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R32G32B32 = 9 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R32G32B32A32 = 10 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R16 = 11 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R16G16B16 = 12 + integer(kind=c_int), parameter, public :: PIXELFORMAT_UNCOMPRESSED_R16G16B16A16 = 13 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT1_RGB = 14 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT1_RGBA = 15 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT3_RGBA = 16 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_DXT5_RGBA = 17 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ETC1_RGB = 18 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ETC2_RGB = 19 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ETC2_EAC_RGBA = 20 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_PVRT_RGB = 21 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_PVRT_RGBA = 22 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ASTC_4x4_RGBA = 23 + integer(kind=c_int), parameter, public :: PIXELFORMAT_COMPRESSED_ASTC_8x8_RGBA = 24 + + ! TextureFilter + integer(kind=c_int), parameter, public :: TEXTURE_FILTER_POINT = 0 + integer(kind=c_int), parameter, public :: TEXTURE_FILTER_BILINEAR = 1 + integer(kind=c_int), parameter, public :: TEXTURE_FILTER_TRILINEAR = 2 + integer(kind=c_int), parameter, public :: TEXTURE_FILTER_ANISOTROPIC_4X = 3 + integer(kind=c_int), parameter, public :: TEXTURE_FILTER_ANISOTROPIC_8X = 4 + integer(kind=c_int), parameter, public :: TEXTURE_FILTER_ANISOTROPIC_16X = 5 + + ! TextureWrap + integer(kind=c_int), parameter, public :: TEXTURE_WRAP_REPEAT = 0 + integer(kind=c_int), parameter, public :: TEXTURE_WRAP_CLAMP = 1 + integer(kind=c_int), parameter, public :: TEXTURE_WRAP_MIRROR_REPEAT = 2 + integer(kind=c_int), parameter, public :: TEXTURE_WRAP_MIRROR_CLAMP = 3 + + ! CubemapLayout + integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_AUTO_DETECT = 0 + integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_LINE_VERTICAL = 1 + integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_LINE_HORIZONTAL = 2 + integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_CROSS_THREE_BY_FOUR = 3 + integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_CROSS_FOUR_BY_THREE = 4 + integer(kind=c_int), parameter, public :: CUBEMAP_LAYOUT_PANORAMA = 5 + + ! FontType + integer(kind=c_int), parameter, public :: FONT_DEFAULT = 0 + integer(kind=c_int), parameter, public :: FONT_BITMAP = 1 + integer(kind=c_int), parameter, public :: FONT_SDF = 2 + + ! BlendMode + integer(kind=c_int), parameter, public :: BLEND_ALPHA = 0 + integer(kind=c_int), parameter, public :: BLEND_ADDITIVE = 1 + integer(kind=c_int), parameter, public :: BLEND_MULTIPLIED = 2 + integer(kind=c_int), parameter, public :: BLEND_ADD_COLORS = 3 + integer(kind=c_int), parameter, public :: BLEND_SUBTRACT_COLORS = 4 + integer(kind=c_int), parameter, public :: BLEND_ALPHA_PREMULTIPLY = 5 + integer(kind=c_int), parameter, public :: BLEND_CUSTOM = 6 + integer(kind=c_int), parameter, public :: BLEND_CUSTOM_SEPARATE = 7 + + ! Gesture + integer(kind=c_int), parameter, public :: GESTURE_NONE = 0 + integer(kind=c_int), parameter, public :: GESTURE_TAP = 1 + integer(kind=c_int), parameter, public :: GESTURE_DOUBLETAP = 2 + integer(kind=c_int), parameter, public :: GESTURE_HOLD = 4 + integer(kind=c_int), parameter, public :: GESTURE_DRAG = 8 + integer(kind=c_int), parameter, public :: GESTURE_SWIPE_RIGHT = 16 + integer(kind=c_int), parameter, public :: GESTURE_SWIPE_LEFT = 32 + integer(kind=c_int), parameter, public :: GESTURE_SWIPE_UP = 64 + integer(kind=c_int), parameter, public :: GESTURE_SWIPE_DOWN = 128 + integer(kind=c_int), parameter, public :: GESTURE_PINCH_IN = 256 + integer(kind=c_int), parameter, public :: GESTURE_PINCH_OUT = 512 + + ! CameraMode + integer(kind=c_int), parameter, public :: CAMERA_CUSTOM = 0 + integer(kind=c_int), parameter, public :: CAMERA_FREE = 1 + integer(kind=c_int), parameter, public :: CAMERA_ORBITAL = 2 + integer(kind=c_int), parameter, public :: CAMERA_FIRST_PERSON = 3 + integer(kind=c_int), parameter, public :: CAMERA_THIRD_PERSON = 4 + + ! CameraProjection + integer(kind=c_int), parameter, public :: CAMERA_PERSPECTIVE = 0 + integer(kind=c_int), parameter, public :: CAMERA_ORTHOGRAPHIC = 1 + + ! NPatchLayout + integer(kind=c_int), parameter, public :: NPATCH_NINE_PATCH = 0 + integer(kind=c_int), parameter, public :: NPATCH_THREE_PATCH_VERTICAL = 1 + integer(kind=c_int), parameter, public :: NPATCH_THREE_PATCH_HORIZONTAL = 2 + + public :: attach_audio_mixed_processor + public :: attach_audio_stream_processor + public :: begin_blend_mode + public :: begin_drawing + public :: begin_mode2d + public :: begin_mode3d + public :: begin_scissor_mode + public :: begin_shader_mode + public :: begin_texture_mode + public :: begin_vr_stereo_mode + public :: change_directory + public :: check_collision_box_sphere + public :: check_collision_boxes + public :: check_collision_circle_rec + public :: check_collision_circles + public :: check_collision_lines + public :: check_collision_point_circle + public :: check_collision_point_line + public :: check_collision_point_poly + public :: check_collision_point_rec + public :: check_collision_point_triangle + public :: check_collision_recs + public :: check_collision_spheres + public :: clear_background + public :: clear_window_state + public :: close_audio_device + public :: close_window + public :: codepoint_to_utf8 + public :: color_alpha + public :: color_alpha_blend + public :: color_brightness + public :: color_contrast + public :: color_from_hsv + public :: color_from_normalized + public :: color_tint + public :: color_to_int + public :: compress_data + public :: decode_data_base64 + public :: decompress_data + public :: detach_audio_mixed_processor + public :: detach_audio_stream_processor + public :: directory_exists + public :: disable_cursor + public :: disable_event_waiting + public :: draw_billboard + public :: draw_billboard_pro + public :: draw_billboard_rec + public :: draw_bounding_box + public :: draw_capsule + public :: draw_capsule_wires + public :: draw_circle + public :: draw_circle3d + public :: draw_circle_gradient + public :: draw_circle_lines + public :: draw_circle_lines_v + public :: draw_circle_sector + public :: draw_circle_sector_lines + public :: draw_circle_v + public :: draw_cube + public :: draw_cube_v + public :: draw_cube_wires + public :: draw_cube_wires_v + public :: draw_cylinder + public :: draw_cylinder_ex + public :: draw_cylinder_wires + public :: draw_cylinder_wires_ex + public :: draw_ellipse + public :: draw_ellipse_lines + public :: draw_fps + public :: draw_grid + public :: draw_line + public :: draw_line3d + public :: draw_line_bezier + public :: draw_line_ex + public :: draw_line_strip + public :: draw_line_v + public :: draw_mesh + public :: draw_mesh_instanced + public :: draw_model + public :: draw_model_ex + public :: draw_model_wires + public :: draw_model_wires_ex + public :: draw_pixel + public :: draw_pixel_v + public :: draw_plane + public :: draw_point3d + public :: draw_poly + public :: draw_poly_lines + public :: draw_poly_lines_ex + public :: draw_ray + public :: draw_rectangle + public :: draw_rectangle_gradient_ex + public :: draw_rectangle_gradient_h + public :: draw_rectangle_gradient_v + public :: draw_rectangle_lines + public :: draw_rectangle_lines_ex + public :: draw_rectangle_pro + public :: draw_rectangle_rec + public :: draw_rectangle_rounded + public :: draw_rectangle_rounded_lines + public :: draw_rectangle_v + public :: draw_ring + public :: draw_ring_lines + public :: draw_sphere + public :: draw_sphere_ex + public :: draw_sphere_wires + public :: draw_spline_basis + public :: draw_spline_bezier_cubic + public :: draw_spline_bezier_quadratic + public :: draw_spline_catmull_rom + public :: draw_spline_linear + public :: draw_spline_segment_basis + public :: draw_spline_segment_bezier_cubic + public :: draw_spline_segment_bezier_quadratic + public :: draw_spline_segment_catmull_rom + public :: draw_spline_segment_linear + public :: draw_text + public :: draw_text_codepoint + public :: draw_text_codepoints + public :: draw_text_ex + public :: draw_text_pro + public :: draw_texture + public :: draw_texture_ex + public :: draw_texture_npatch + public :: draw_texture_pro + public :: draw_texture_rec + public :: draw_texture_v + public :: draw_triangle + public :: draw_triangle3d + public :: draw_triangle_fan + public :: draw_triangle_lines + public :: draw_triangle_strip + public :: draw_triangle_strip3d + public :: enable_cursor + public :: enable_event_waiting + public :: encode_data_base64 + public :: end_blend_mode + public :: end_drawing + public :: end_mode2d + public :: end_mode3d + public :: end_scissor_mode + public :: end_shader_mode + public :: end_texture_mode + public :: end_vr_stereo_mode + public :: export_data_as_code + public :: export_font_as_code + public :: export_image + public :: export_image_as_code + public :: export_image_to_memory + public :: export_mesh + public :: export_wave + public :: export_wave_as_code + public :: fade + public :: file_exists + public :: gen_image_cellular + public :: gen_image_checked + public :: gen_image_color + public :: gen_image_font_atlas + public :: gen_image_gradient_linear + public :: gen_image_gradient_radial + public :: gen_image_gradient_square + public :: gen_image_perlin_noise + public :: gen_image_text + public :: gen_image_white_noise + public :: gen_mesh_cone + public :: gen_mesh_cube + public :: gen_mesh_cubicmap + public :: gen_mesh_cylinder + public :: gen_mesh_heightmap + public :: gen_mesh_hemi_sphere + public :: gen_mesh_knot + public :: gen_mesh_plane + public :: gen_mesh_poly + public :: gen_mesh_sphere + public :: gen_mesh_tangents + public :: gen_mesh_torus + public :: gen_texture_mipmaps + public :: get_application_directory + public :: get_camera_matrix + public :: get_camera_matrix2d + public :: get_char_pressed + public :: get_clipboard_text + public :: get_codepoint + public :: get_codepoint_count + public :: get_codepoint_next + public :: get_codepoint_previous + public :: get_collision_rec + public :: get_color + public :: get_current_monitor + public :: get_directory_path + public :: get_file_extension + public :: get_file_length + public :: get_file_mod_time + public :: get_file_name + public :: get_file_name_without_ext + public :: get_font_default + public :: get_fps + public :: get_frame_time + public :: get_gamepad_axis_count + public :: get_gamepad_axis_movement + public :: get_gamepad_button_pressed + public :: get_gamepad_name + public :: get_gesture_detected + public :: get_gesture_drag_angle + public :: get_gesture_hold_duration + public :: get_gesture_pinch_angle + public :: get_glyph_atlas_rec + public :: get_glyph_index + public :: get_glyph_info + public :: get_image_alpha_border + public :: get_image_color + public :: get_key_pressed + public :: get_master_volume + public :: get_mesh_bounding_box + public :: get_model_bounding_box + public :: get_monitor_count + public :: get_monitor_height + public :: get_monitor_name + public :: get_monitor_physical_height + public :: get_monitor_physical_width + public :: get_monitor_refresh_rate + public :: get_monitor_width + public :: get_mouse_delta + public :: get_mouse_position + public :: get_mouse_ray + public :: get_mouse_wheel_move + public :: get_mouse_x + public :: get_mouse_y + public :: get_music_time_length + public :: get_music_time_played + public :: get_pixel_color + public :: get_pixel_data_size + public :: get_prev_directory_path + public :: get_random_value + public :: get_ray_collision_box + public :: get_ray_collision_mesh + public :: get_ray_collision_quad + public :: get_ray_collision_sphere + public :: get_ray_collision_triangle + public :: get_render_height + public :: get_render_width + public :: get_screen_height + public :: get_screen_to_world2d + public :: get_screen_width + public :: get_shader_location + public :: get_shader_location_attrib + public :: get_spline_point_basis + public :: get_spline_point_bezier_cubic + public :: get_spline_point_bezier_quad + public :: get_spline_point_catmull_rom + public :: get_spline_point_linear + public :: get_time + public :: get_touch_point_count + public :: get_touch_point_id + public :: get_touch_x + public :: get_touch_y + public :: get_window_handle + public :: get_working_directory + public :: get_world_to_screen2d + public :: hide_cursor + public :: image_alpha_clear + public :: image_alpha_crop + public :: image_alpha_mask + public :: image_alpha_premultiply + public :: image_blur_gaussian + public :: image_clear_background + public :: image_color_brightness + public :: image_color_contrast + public :: image_color_grayscale + public :: image_color_invert + public :: image_color_replace + public :: image_color_tint + public :: image_copy + public :: image_crop + public :: image_dither + public :: image_draw + public :: image_draw_circle + public :: image_draw_circle_lines + public :: image_draw_circle_lines_v + public :: image_draw_circle_v + public :: image_draw_line + public :: image_draw_line_v + public :: image_draw_pixel + public :: image_draw_pixel_v + public :: image_draw_rectangle + public :: image_draw_rectangle_lines + public :: image_draw_rectangle_rec + public :: image_draw_rectangle_v + public :: image_draw_text + public :: image_draw_text_ex + public :: image_flip_horizontal + public :: image_flip_vertical + public :: image_format + public :: image_from_image + public :: image_kernel_convolution + public :: image_mipmaps + public :: image_resize + public :: image_resize_canvas + public :: image_resize_nn + public :: image_rotate + public :: image_rotate_ccw + public :: image_rotate_cw + public :: image_text + public :: image_text_ex + public :: image_to_pot + public :: init_audio_device + public :: init_window + public :: is_audio_device_ready + public :: is_audio_stream_playing + public :: is_audio_stream_processed + public :: is_audio_stream_ready + public :: is_cursor_hidden + public :: is_cursor_on_screen + public :: is_file_dropped + public :: is_file_extension + public :: is_font_ready + public :: is_gamepad_available + public :: is_gamepad_button_down + public :: is_gamepad_button_pressed + public :: is_gamepad_button_released + public :: is_gamepad_button_up + public :: is_gesture_detected + public :: is_image_ready + public :: is_key_down + public :: is_key_pressed + public :: is_key_pressed_repeat + public :: is_key_released + public :: is_key_up + public :: is_material_ready + public :: is_model_animation_valid + public :: is_model_ready + public :: is_mouse_button_down + public :: is_mouse_button_pressed + public :: is_mouse_button_released + public :: is_mouse_button_up + public :: is_music_ready + public :: is_music_stream_playing + public :: is_path_file + public :: is_render_texture_ready + public :: is_shader_ready + public :: is_sound_playing + public :: is_sound_ready + public :: is_texture_ready + public :: is_wave_ready + public :: is_window_focused + public :: is_window_fullscreen + public :: is_window_hidden + public :: is_window_maximized + public :: is_window_minimized + public :: is_window_ready + public :: is_window_resized + public :: is_window_state + public :: load_audio_stream + public :: load_codepoints + public :: load_directory_files + public :: load_directory_files_ex + public :: load_dropped_files + public :: load_file_data + public :: load_file_text + public :: load_font + public :: load_font_data + public :: load_font_ex + public :: load_font_from_image + public :: load_font_from_memory + public :: load_image + public :: load_image_anim + public :: load_image_colors + public :: load_image_from_memory + public :: load_image_from_screen + public :: load_image_from_texture + public :: load_image_palette + public :: load_image_raw + public :: load_image_svg + public :: load_material_default + public :: load_materials + public :: load_model + public :: load_model_animations + public :: load_model_from_mesh + public :: load_music_stream + public :: load_music_stream_from_memory + public :: load_random_sequence + public :: load_render_texture + public :: load_shader + public :: load_shader_from_memory + public :: load_sound + public :: load_sound_alias + public :: load_sound_from_wave + public :: load_texture + public :: load_texture_cubemap + public :: load_texture_from_image + public :: load_utf8 + public :: load_vr_stereo_config + public :: load_wave + public :: load_wave_from_memory + public :: load_wave_samples + public :: maximize_window + public :: measure_text + public :: measure_text_ex + public :: mem_alloc + public :: mem_free + public :: mem_realloc + public :: minimize_window + public :: open_url + public :: pause_audio_stream + public :: pause_music_stream + public :: pause_sound + public :: play_audio_stream + public :: play_music_stream + public :: play_sound + public :: poll_input_events + public :: restore_window + public :: resume_audio_stream + public :: resume_music_stream + public :: resume_sound + public :: save_file_data + public :: save_file_text + public :: seek_music_stream + public :: set_audio_stream_buffer_size_default + public :: set_audio_stream_pan + public :: set_audio_stream_pitch + public :: set_audio_stream_volume + public :: set_camera_alt_control + public :: set_camera_mode + public :: set_camera_move_controls + public :: set_camera_pan_control + public :: set_camera_smooth_zoom_control + public :: set_clipboard_text + public :: set_config_flags + public :: set_exit_key + public :: set_gamepad_mappings + public :: set_gestures_enabled + public :: set_load_file_data_callback + public :: set_load_file_text_callback + public :: set_master_volume + public :: set_material_texture + public :: set_model_mesh_material + public :: set_mouse_cursor + public :: set_mouse_offset + public :: set_mouse_position + public :: set_mouse_scale + public :: set_music_pan + public :: set_music_pitch + public :: set_music_volume + public :: set_pixel_color + public :: set_random_seed + public :: set_save_file_data_callback + public :: set_save_file_text_callback + public :: set_shader_value + public :: set_shader_value_matrix + public :: set_shader_value_texture + public :: set_shader_value_v + public :: set_shapes_texture + public :: set_sound_pan + public :: set_sound_pitch + public :: set_sound_volume + public :: set_target_fps + public :: set_text_line_spacing + public :: set_texture_filter + public :: set_texture_wrap + public :: set_trace_log_callback + public :: set_trace_log_level + public :: set_window_focused + public :: set_window_icon + public :: set_window_icons + public :: set_window_max_size + public :: set_window_min_size + public :: set_window_monitor + public :: set_window_opacity + public :: set_window_position + public :: set_window_size + public :: set_window_state + public :: set_window_title + public :: show_cursor + public :: stop_audio_stream + public :: stop_music_stream + public :: stop_sound + public :: swap_screen_buffer + public :: take_screenshot + public :: text_append + public :: text_copy + public :: text_find_index + public :: text_insert + public :: text_is_equal + public :: text_join + public :: text_length + public :: text_replace + public :: text_split + public :: text_subtext + public :: text_to_integer + public :: text_to_lower + public :: text_to_pascal + public :: text_to_upper + public :: toggle_borderless_windowed + public :: toggle_fullscreen + public :: trace_log + public :: unload_audio_stream + public :: unload_codepoints + public :: unload_directory_files + public :: unload_dropped_files + public :: unload_file_data + public :: unload_file_text + public :: unload_font + public :: unload_font_data + public :: unload_image + public :: unload_image_colors + public :: unload_image_palette + public :: unload_material + public :: unload_mesh + public :: unload_model + public :: unload_model_animation + public :: unload_model_animations + public :: unload_music_stream + public :: unload_random_sequence + public :: unload_render_texture + public :: unload_shader + public :: unload_sound + public :: unload_sound_alias + public :: unload_texture + public :: unload_utf8 + public :: unload_vr_stereo_config + public :: unload_wave + public :: unload_wave_samples + public :: update_audio_stream + public :: update_camera + public :: update_mesh_buffer + public :: update_model_animation + public :: update_music_stream + public :: update_sound + public :: update_texture + public :: update_texture_rec + public :: upload_mesh + public :: wait_time + public :: wave_copy + public :: wave_crop + public :: wave_format + public :: window_should_close + + public :: load_file_data_callback + public :: save_file_data_callback + public :: load_file_text_callback + public :: save_file_text_callback + public :: trace_log_callback + + public :: deg2rad + public :: rad2deg + + abstract interface + ! unsigned char *(*LoadFileDataCallback)(const char *fileName, unsigned int *bytesRead) + function load_file_data_callback(file_name, bytes_read) bind(c) + import :: c_ptr, c_unsigned_int + implicit none + type(c_ptr), intent(in), value :: file_name + integer(kind=c_unsigned_int), intent(out) :: bytes_read + type(c_ptr) :: load_file_data_callback + end function load_file_data_callback + + ! bool (*SaveFileDataCallback)(const char *fileName, void *data, unsigned int bytesToWrite) + function save_file_data_callback(file_name, data, bytes_to_write) bind(c) + import :: c_bool, c_ptr, c_unsigned_int + implicit none + type(c_ptr), intent(in), value :: file_name + type(c_ptr), intent(in), value :: data + integer(kind=c_unsigned_int), intent(in), value :: bytes_to_write + logical(kind=c_bool) :: save_file_data_callback + end function save_file_data_callback + + ! char *(*LoadFileTextCallback)(const char *fileName) + function load_file_text_callback(file_name) bind(c) + import :: c_ptr, c_unsigned_int + implicit none + type(c_ptr), intent(in), value :: file_name + type(c_ptr) :: load_file_text_callback + end function load_file_text_callback + + ! bool (*SaveFileTextCallback)(const char *fileName, char *text) + function save_file_text_callback(file_name, text) bind(c) + import :: c_bool, c_ptr + implicit none + type(c_ptr), intent(in), value :: file_name + type(c_ptr), intent(in), value :: text + logical(kind=c_bool) :: save_file_text_callback + end function save_file_text_callback + + ! void (*TraceLogCallback)(int logLevel, const char *text, va_list args) + subroutine trace_log_callback(log_level, text, args) bind(c) + import :: c_int, c_ptr + implicit none + integer(kind=c_int), intent(in), value :: log_level + type(c_ptr), intent(in), value :: text + type(c_ptr), intent(in) :: args(*) + end subroutine trace_log_callback + end interface + + interface + ! void AttachAudioMixedProcessor(AudioCallback processor) + subroutine attach_audio_mixed_processor(processor) bind(c, name='AttachAudioMixedProcessor') + import :: c_funptr + implicit none + type(c_funptr), intent(in), value :: processor + end subroutine attach_audio_mixed_processor + + ! void AttachAudioStreamProcessor(AudioStream stream, AudioCallback processor) + subroutine attach_audio_stream_processor(stream, processor) bind(c, name='AttachAudioStreamProcessor') + import :: audio_stream_type, c_funptr + implicit none + type(audio_stream_type), intent(in), value :: stream + type(c_funptr), intent(in), value :: processor + end subroutine attach_audio_stream_processor + + ! void BeginBlendMode(int mode) + subroutine begin_blend_mode(mode) bind(c, name='BeginBlendMode') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: mode + end subroutine begin_blend_mode + + ! void BeginDrawing(void) + subroutine begin_drawing() bind(c, name='BeginDrawing') + end subroutine begin_drawing + + ! void BeginMode2D(Camera2D camera) + subroutine begin_mode2d(camera) bind(c, name='BeginMode2D') + import :: camera2d_type + implicit none + type(camera2d_type), intent(in), value :: camera + end subroutine begin_mode2d + + ! void BeginMode3D(Camera3D camera) + subroutine begin_mode3d(camera) bind(c, name='BeginMode3D') + import :: camera3d_type + implicit none + type(camera3d_type), intent(in), value :: camera + end subroutine begin_mode3d + + ! void BeginScissorMode(int x, int y, int width, int height) + subroutine begin_scissor_mode(x, y, width, height) bind(c, name='BeginScissorMode') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: x + integer(kind=c_int), intent(in), value :: y + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + end subroutine begin_scissor_mode + + ! void BeginShaderMode(Shader shader) + subroutine begin_shader_mode(shader) bind(c, name='BeginShaderMode') + import :: shader_type + implicit none + type(shader_type), intent(in), value :: shader + end subroutine begin_shader_mode + + ! void BeginTextureMode(RenderTexture2D target) + subroutine begin_texture_mode(target) bind(c, name='BeginTextureMode') + import :: render_texture2d_type + implicit none + type(render_texture2d_type), intent(in), value :: target + end subroutine begin_texture_mode + + ! void BeginVrStereoMode(VrStereoConfig config) + subroutine begin_vr_stereo_mode(config) bind(c, name='BeginVrStereoMode') + import :: vr_stereo_config_type + implicit none + type(vr_stereo_config_type), intent(in), value :: config + end subroutine begin_vr_stereo_mode + + ! bool ChangeDirectory(const char *dir) + function change_directory(dir) bind(c, name='ChangeDirectory') + import :: c_bool, c_char + implicit none + character(kind=c_char), intent(in) :: dir + logical(kind=c_bool) :: change_directory + end function change_directory + + ! bool CheckCollisionBoxSphere(BoundingBox box, Vector3 center, float radius) + function check_collision_box_sphere(box, center, radius) bind(c, name='CheckCollisionBoxSphere') + import :: bounding_box_type, c_bool, c_float, vector3_type + implicit none + type(bounding_box_type), intent(in), value :: box + type(vector3_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + logical(kind=c_bool) :: check_collision_box_sphere + end function check_collision_box_sphere + + ! bool CheckCollisionBoxes(BoundingBox box1, BoundingBox box2) + function check_collision_boxes(box1, box2) bind(c, name='CheckCollisionBoxes') + import :: bounding_box_type, c_bool + implicit none + type(bounding_box_type), intent(in), value :: box1 + type(bounding_box_type), intent(in), value :: box2 + logical(kind=c_bool) :: check_collision_boxes + end function check_collision_boxes + + ! bool CheckCollisionCircleRec(Vector2 center, float radius, Rectangle rec) + function check_collision_circle_rec(center, radius, rec) bind(c, name='CheckCollisionCircleRec') + import :: c_bool, c_float, rectangle_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + type(rectangle_type), intent(in), value :: rec + logical(kind=c_bool) :: check_collision_circle_rec + end function check_collision_circle_rec + + ! bool CheckCollisionCircles(Vector2 center1, float radius1, Vector2 center2, float radius2) + function check_collision_circles(center1, radius1, center2, radius2) bind(c, name='CheckCollisionCircles') + import :: c_bool, c_float, vector2_type + implicit none + type(vector2_type), intent(in), value :: center1 + real(kind=c_float), intent(in), value :: radius1 + type(vector2_type), intent(in), value :: center2 + real(kind=c_float), intent(in), value :: radius2 + logical(kind=c_bool) :: check_collision_circles + end function check_collision_circles + + ! bool CheckCollisionLines(Vector2 startPos1, Vector2 endPos1, Vector2 startPos2, Vector2 endPos2, Vector2 *collisionPoint) + function check_collision_lines(start_pos1, end_pos1, start_pos2, end_pos2, collision_point) & + bind(c, name='CheckCollisionLines') + import :: c_bool, vector2_type + implicit none + type(vector2_type), intent(in), value :: start_pos1 + type(vector2_type), intent(in), value :: end_pos1 + type(vector2_type), intent(in), value :: start_pos2 + type(vector2_type), intent(in), value :: end_pos2 + type(vector2_type), intent(out) :: collision_point + logical(kind=c_bool) :: check_collision_lines + end function check_collision_lines + + ! bool CheckCollisionPointCircle(Vector2 point, Vector2 center, float radius) + function check_collision_point_circle(point, center, radius) bind(c, name='CheckCollisionPointCircle') + import :: c_bool, c_float, vector2_type + implicit none + type(vector2_type), intent(in), value :: point + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + logical(kind=c_bool) :: check_collision_point_circle + end function check_collision_point_circle + + ! bool CheckCollisionPointLine(Vector2 point, Vector2 p1, Vector2 p2, int threshold) + function check_collision_point_line(point, p1, p2, threshold) bind(c, name='CheckCollisionPointLine') + import :: c_bool, c_int, vector2_type + implicit none + type(vector2_type), intent(in), value :: point + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: p2 + integer(kind=c_int), intent(in), value :: threshold + logical(kind=c_bool) :: check_collision_point_line + end function check_collision_point_line + + ! bool CheckCollisionPointPoly(Vector2 point, Vector2 *points, int pointCount) + function check_collision_point_poly(point, points, point_count) bind(c, name='CheckCollisionPointPoly') + import :: c_bool, c_int, vector2_type + implicit none + type(vector2_type), intent(in), value :: point + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + logical(kind=c_bool) :: check_collision_point_poly + end function check_collision_point_poly + + ! bool CheckCollisionPointRec(Vector2 point, Rectangle rec) + function check_collision_point_rec(point, rec) bind(c, name='CheckCollisionPointRec') + import :: c_bool, rectangle_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: point + type(rectangle_type), intent(in), value :: rec + logical(kind=c_bool) :: check_collision_point_rec + end function check_collision_point_rec + + ! bool CheckCollisionPointTriangle(Vector2 point, Vector2 p1, Vector2 p2, Vector2 p3) + function check_collision_point_triangle(point, p1, p2, p3) bind(c, name='CheckCollisionPointTriangle') + import :: c_bool, vector2_type + implicit none + type(vector2_type), intent(in), value :: point + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: p2 + type(vector2_type), intent(in), value :: p3 + logical(kind=c_bool) :: check_collision_point_triangle + end function check_collision_point_triangle + + ! bool CheckCollisionRecs(Rectangle rec1, Rectangle rec2) + function check_collision_recs(rec1, rec2) bind(c, name='CheckCollisionRecs') + import :: c_bool, rectangle_type + implicit none + type(rectangle_type), intent(in), value :: rec1 + type(rectangle_type), intent(in), value :: rec2 + logical(kind=c_bool) :: check_collision_recs + end function check_collision_recs + + ! bool CheckCollisionSpheres(Vector3 center1, float radius1, Vector3 center2, float radius2) + function check_collision_spheres(center1, radius1, center2, radius2) bind(c, name='CheckCollisionSpheres') + import :: c_bool, c_float, vector3_type + implicit none + type(vector3_type), intent(in), value :: center1 + real(kind=c_float), intent(in), value :: radius1 + type(vector3_type), intent(in), value :: center2 + real(kind=c_float), intent(in), value :: radius2 + logical(kind=c_bool) :: check_collision_spheres + end function check_collision_spheres + + ! void ClearBackground(Color color) + subroutine clear_background(color) bind(c, name='ClearBackground') + import :: color_type + implicit none + type(color_type), intent(in), value :: color + end subroutine clear_background + + ! void ClearWindowState(unsigned int flags) + subroutine clear_window_state(flags) bind(c, name='ClearWindowState') + import :: c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: flags + end subroutine clear_window_state + + ! void CloseAudioDevice(void) + subroutine close_audio_device() bind(c, name='CloseAudioDevice') + end subroutine close_audio_device + + ! void CloseWindow(void) + subroutine close_window() bind(c, name='CloseWindow') + end subroutine close_window + + ! const char *CodepointToUTF8(int codepoint, int *utf8Size) + function codepoint_to_utf8(codepoint, utf8_size) bind(c, name='CodepointToUTF8') + import :: c_int, c_ptr + implicit none + integer(kind=c_int), intent(in), value :: codepoint + integer(kind=c_int), intent(out) :: utf8_size + type(c_ptr) :: codepoint_to_utf8 + end function codepoint_to_utf8 + + ! Color ColorAlpha(Color color, float alpha) + function color_alpha(color, alpha) bind(c, name='ColorAlpha') + import :: c_float, color_type + implicit none + type(color_type), intent(in), value :: color + real(kind=c_float), intent(in), value :: alpha + type(color_type) :: color_alpha + end function color_alpha + + ! Color ColorAlphaBlend(Color dst, Color src, Color tint) + function color_alpha_blend(dst, src, tint) bind(c, name='ColorAlphaBlend') + import :: color_type + implicit none + type(color_type), intent(in), value :: dst + type(color_type), intent(in), value :: src + type(color_type), intent(in), value :: tint + type(color_type) :: color_alpha_blend + end function color_alpha_blend + + ! Color ColorBrightness(Color color, float factor) + function color_brightness(color, factor) bind(c, name='ColorBrightness') + import :: c_float, color_type + implicit none + type(color_type), intent(in), value :: color + real(kind=c_float), intent(in), value :: factor + type(color_type) :: color_brightness + end function color_brightness + + ! Color ColorContrast(Color color, float contrast) + function color_contrast(color, contrast) bind(c, name='ColorContrast') + import :: c_float, color_type + implicit none + type(color_type), intent(in), value :: color + real(kind=c_float), intent(in), value :: contrast + type(color_type) :: color_contrast + end function color_contrast + + ! Color ColorFromHSV(float hue, float saturation, float value) + function color_from_hsv(hue, saturation, value) bind(c, name='ColorFromHSV') + import :: c_float, color_type + implicit none + real(kind=c_float), intent(in), value :: hue + real(kind=c_float), intent(in), value :: saturation + real(kind=c_float), intent(in), value :: value + type(color_type) :: color_from_hsv + end function color_from_hsv + + ! Color ColorFromNormalized(Vector4 normalized) + function color_from_normalized(normalized) bind(c, name='ColorFromNormalized') + import :: color_type, vector4_type + implicit none + type(vector4_type), intent(in), value :: normalized + type(color_type) :: color_from_normalized + end function color_from_normalized + + ! Color ColorTint(Color color, Color tint) + function color_tint(color, tint) bind(c, name='ColorTint') + import :: color_type + implicit none + type(color_type), intent(in), value :: color + type(color_type), intent(in), value :: tint + type(color_type) :: color_tint + end function color_tint + + ! int ColorToInt(Color color) + function color_to_int(color) bind(c, name='ColorToInt') + import :: c_int, color_type + implicit none + type(color_type), intent(in), value :: color + integer(kind=c_int) :: color_to_int + end function color_to_int + + ! unsigned char *CompressData(const unsigned char *data, int dataSize, int *compDataSize) + function compress_data(data, data_size, comp_data_size) bind(c, name='CompressData') + import :: c_int, c_ptr, c_unsigned_char + implicit none + integer(kind=c_unsigned_char), intent(in) :: data + integer(kind=c_int), intent(in), value :: data_size + integer(kind=c_int), intent(out) :: comp_data_size + type(c_ptr) :: compress_data + end function compress_data + + ! unsigned char *DecodeDataBase64(const unsigned char *data, int *outputSize) + function decode_data_base64(data, output_size) bind(c, name='DecodeDataBase64') + import :: c_int, c_unsigned_char, c_ptr + implicit none + integer(kind=c_unsigned_char), intent(in) :: data + integer(kind=c_int), intent(out) :: output_size + type(c_ptr) :: decode_data_base64 + end function decode_data_base64 + + ! unsigned char *DecompressData(const unsigned char *compData, int compDataSize, int *dataSize) + function decompress_data(comp_data, comp_data_size, data_size) bind(c, name='DecompressData') + import :: c_int, c_ptr, c_unsigned_char + implicit none + integer(kind=c_unsigned_char), intent(in) :: comp_data + integer(kind=c_int), intent(in), value :: comp_data_size + integer(kind=c_int), intent(out) :: data_size + type(c_ptr) :: decompress_data + end function decompress_data + + ! void DetachAudioMixedProcessor(AudioCallback processor) + subroutine detach_audio_mixed_processor(processor) bind(c, name='DetachAudioMixedProcessor') + import :: c_funptr + implicit none + type(c_funptr), intent(in), value :: processor + end subroutine detach_audio_mixed_processor + + ! void DetachAudioStreamProcessor(AudioStream stream, AudioCallback processor) + subroutine detach_audio_stream_processor(stream, processor) bind(c, name='DetachAudioStreamProcessor') + import :: audio_stream_type, c_funptr + implicit none + type(audio_stream_type), intent(in), value :: stream + type(c_funptr), intent(in), value :: processor + end subroutine detach_audio_stream_processor + + ! bool DirectoryExists(const char *dirPath) + function directory_exists(dir_path) bind(c, name='DirectoryExists') + import :: c_bool, c_char + implicit none + character(kind=c_char), intent(in) :: dir_path + logical(kind=c_bool) :: directory_exists + end function directory_exists + + ! void DisableCursor(void) + subroutine disable_cursor() bind(c, name='DisableCursor') + end subroutine disable_cursor + + ! void DisableEventWaiting(void) + subroutine disable_event_waiting() bind(c, name='DisableEventWaiting') + end subroutine disable_event_waiting + + ! void DrawBillboard(Camera camera, Texture2D texture, Vector3 position, float size, Color tint) + subroutine draw_billboard(camera, texture, position, size, tint) bind(c, name='DrawBillboard') + import :: c_float, camera3d_type, color_type, texture2d_type, vector3_type + implicit none + type(camera3d_type), intent(in), value :: camera + type(texture2d_type), intent(in), value :: texture + type(vector3_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: size + type(color_type), intent(in), value :: tint + end subroutine draw_billboard + + ! void DrawBillboardPro(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector3 up, Vector2 size, Vector2 origin, float rotation, Color tint) + subroutine draw_billboard_pro(camera, texture, source, position, up, size, origin, rotation, tint) & + bind(c, name='DrawBillboardPro') + import :: c_float, camera3d_type, color_type, rectangle_type, texture2d_type, vector2_type, vector3_type + implicit none + type(camera3d_type), intent(in), value :: camera + type(texture2d_type), intent(in), value :: texture + type(rectangle_type), intent(in), value :: source + type(vector3_type), intent(in), value :: position + type(vector3_type), intent(in), value :: up + type(vector2_type), intent(in), value :: size + type(vector2_type), intent(in), value :: origin + real(kind=c_float), intent(in), value :: rotation + type(color_type), intent(in), value :: tint + end subroutine draw_billboard_pro + + ! void DrawBillboardRec(Camera camera, Texture2D texture, Rectangle source, Vector3 position, Vector2 size, Color tint) + subroutine draw_billboard_rec(camera, texture, source, position, size, tint) bind(c, name='DrawBillboardRec') + import :: camera3d_type, color_type, rectangle_type, texture2d_type, vector2_type, vector3_type + implicit none + type(camera3d_type), intent(in), value :: camera + type(texture2d_type), intent(in), value :: texture + type(rectangle_type), intent(in), value :: source + type(vector3_type), intent(in), value :: position + type(vector2_type), intent(in), value :: size + type(color_type), intent(in), value :: tint + end subroutine draw_billboard_rec + + ! void DrawBoundingBox(BoundingBox box, Color color) + subroutine draw_bounding_box(box, color) bind(c, name='DrawBoundingBox') + import :: bounding_box_type, color_type + implicit none + type(bounding_box_type), intent(in), value :: box + type(color_type), intent(in), value :: color + end subroutine draw_bounding_box + + ! void DrawCapsule(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) + subroutine draw_capsule(start_pos, end_pos, radius, slices, rings, color) bind(c, name='DrawCapsule') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: start_pos + type(vector3_type), intent(in), value :: end_pos + real(kind=c_float), intent(in), value :: radius + integer(kind=c_int), intent(in), value :: slices + integer(kind=c_int), intent(in), value :: rings + type(color_type), intent(in), value :: color + end subroutine draw_capsule + + ! void DrawCapsuleWires(Vector3 startPos, Vector3 endPos, float radius, int slices, int rings, Color color) + subroutine draw_capsule_wires(start_pos, end_pos, radius, slices, rings, color) bind(c, name='DrawCapsuleWires') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: start_pos + type(vector3_type), intent(in), value :: end_pos + real(kind=c_float), intent(in), value :: radius + integer(kind=c_int), intent(in), value :: slices + integer(kind=c_int), intent(in), value :: rings + type(color_type), intent(in), value :: color + end subroutine draw_capsule_wires + + ! void DrawCircle(int centerX, int centerY, float radius, Color color) + subroutine draw_circle(center_x, center_y, radius, color) bind(c, name='DrawCircle') + import :: c_float, c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: center_x + integer(kind=c_int), intent(in), value :: center_y + real(kind=c_float), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine draw_circle + + ! void DrawCircle3D(Vector3 center, float radius, Vector3 rotationAxis, float rotationAngle, Color color) + subroutine draw_circle3d(center, radius, rotation_axis, rotation_angle, color) bind(c, name='DrawCircle3D') + import :: c_float, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + type(vector3_type), intent(in), value :: rotation_axis + real(kind=c_float), intent(in), value :: rotation_angle + type(color_type), intent(in), value :: color + end subroutine draw_circle3d + + ! void DrawCircleGradient(int centerX, int centerY, float radius, Color color1, Color color2) + subroutine draw_circle_gradient(center_x, center_y, radius, color1, color2) bind(c, name='DrawCircleGradient') + import :: c_float, c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: center_x + integer(kind=c_int), intent(in), value :: center_y + real(kind=c_float), intent(in), value :: radius + type(color_type), intent(in), value :: color1 + type(color_type), intent(in), value :: color2 + end subroutine draw_circle_gradient + + ! void DrawCircleLines(int centerX, int centerY, float radius, Color color) + subroutine draw_circle_lines(center_x, center_y, radius, color) bind(c, name='DrawCircleLines') + import :: c_float, c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: center_x + integer(kind=c_int), intent(in), value :: center_y + real(kind=c_float), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine draw_circle_lines + + ! void DrawCircleLinesV(Vector2 center, float radius, Color color) + subroutine draw_circle_lines_v(center, radius, color) bind(c, name='DrawCircleLinesV') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine draw_circle_lines_v + + ! void DrawCircleSector(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) + subroutine draw_circle_sector(center, radius, start_angle, end_angle, segments, color) & + bind(c, name='DrawCircleSector') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + real(kind=c_float) , intent(in), value :: start_angle + real(kind=c_float), intent(in), value :: end_angle + integer(kind=c_int), intent(in), value :: segments + type(color_type), intent(in), value :: color + end subroutine draw_circle_sector + + ! void DrawCircleSectorLines(Vector2 center, float radius, float startAngle, float endAngle, int segments, Color color) + subroutine draw_circle_sector_lines(center, radius, start_angle, end_angle, segments, color) & + bind(c, name='DrawCircleSectorLines') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: start_angle + real(kind=c_float), intent(in), value :: end_angle + integer(kind=c_int), intent(in), value :: segments + type(color_type), intent(in), value :: color + end subroutine draw_circle_sector_lines + + ! void DrawCircleV(Vector2 center, float radius, Color color) + subroutine draw_circle_v(center, radius, color) bind(c, name='DrawCircleV') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine draw_circle_v + + ! void DrawCube(Vector3 position, float width, float height, float length, Color color) + subroutine draw_cube(position, width, height, length, color) bind(c, name='DrawCube') + import :: c_float, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: width + real(kind=c_float), intent(in), value :: height + real(kind=c_float), intent(in), value :: length + type(color_type), intent(in), value :: color + end subroutine draw_cube + + ! void DrawCubeV(Vector3 position, Vector3 size, Color color) + subroutine draw_cube_v(position, size, color) bind(c, name='DrawCubeV') + import :: color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: position + type(vector3_type), intent(in), value :: size + type(color_type), intent(in), value :: color + end subroutine draw_cube_v + + ! void DrawCubeWires(Vector3 position, float width, float height, float length, Color color) + subroutine draw_cube_wires(position, width, height, length, color) bind(c, name='DrawCubeWires') + import :: c_float, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: width + real(kind=c_float), intent(in), value :: height + real(kind=c_float), intent(in), value :: length + type(color_type), intent(in), value :: color + end subroutine draw_cube_wires + + ! void DrawCubeWiresV(Vector3 position, Vector3 size, Color color) + subroutine draw_cube_wires_v(position, size, color) bind(c, name='DrawCubeWiresV') + import :: color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: position + type(vector3_type), intent(in), value :: size + type(color_type), intent(in), value :: color + end subroutine draw_cube_wires_v + + ! void DrawCylinder(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) + subroutine draw_cylinder(position, radius_top, radius_bottom, height, slices, color) bind(c, name='DrawCylinder') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: radius_top + real(kind=c_float), intent(in), value :: radius_bottom + real(kind=c_float), intent(in), value :: height + integer(kind=c_int), intent(in), value :: slices + type(color_type), intent(in), value :: color + end subroutine draw_cylinder + + ! void DrawCylinderEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) + subroutine draw_cylinder_ex(start_pos, end_pos, start_radius, end_radius, sides, color) bind(c, name='DrawCylinderEx') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: start_pos + type(vector3_type), intent(in), value :: end_pos + real(kind=c_float), intent(in), value :: start_radius + real(kind=c_float), intent(in), value :: end_radius + integer(kind=c_int), intent(in), value :: sides + type(color_type), intent(in), value :: color + end subroutine draw_cylinder_ex + + ! void DrawCylinderWires(Vector3 position, float radiusTop, float radiusBottom, float height, int slices, Color color) + subroutine draw_cylinder_wires(position, radius_top, radius_bottom, height, slices, color) & + bind(c, name='DrawCylinderWires') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: radius_top + real(kind=c_float), intent(in), value :: radius_bottom + real(kind=c_float), intent(in), value :: height + integer(kind=c_int), intent(in), value :: slices + type(color_type), intent(in), value :: color + end subroutine draw_cylinder_wires + + ! void DrawCylinderWiresEx(Vector3 startPos, Vector3 endPos, float startRadius, float endRadius, int sides, Color color) + subroutine draw_cylinder_wires_ex(start_pos, end_pos, start_radius, end_radius, sides, color) & + bind(c, name='DrawCylinderWiresEx') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: start_pos + type(vector3_type), intent(in), value :: end_pos + real(kind=c_float), intent(in), value :: start_radius + real(kind=c_float), intent(in), value :: end_radius + integer(kind=c_int), intent(in), value :: sides + type(color_type), intent(in), value :: color + end subroutine draw_cylinder_wires_ex + + ! void DrawEllipse(int centerX, int centerY, float radiusH, float radiusV, Color color) + subroutine draw_ellipse(center_x, center_y, radius_h, radius_v, color) bind(c, name='DrawEllipse') + import :: c_float, c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: center_x + integer(kind=c_int), intent(in), value :: center_y + real(kind=c_float), intent(in), value :: radius_h + real(kind=c_float), intent(in), value :: radius_v + type(color_type), intent(in), value :: color + end subroutine draw_ellipse + + ! void DrawEllipseLines(int centerX, int centerY, float radiusH, float radiusV, Color color) + subroutine draw_ellipse_lines(center_x, center_y, radius_h, radius_v, color) bind(c, name='DrawEllipseLines') + import :: c_float, c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: center_x + integer(kind=c_int), intent(in), value :: center_y + real(kind=c_float), intent(in), value :: radius_h + real(kind=c_float), intent(in), value :: radius_v + type(color_type), intent(in), value :: color + end subroutine draw_ellipse_lines + + ! void DrawFPS(int posX, int posY) + subroutine draw_fps(pos_x, pos_y) bind(c, name='DrawFPS') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + end subroutine draw_fps + + ! void DrawGrid(int slices, float spacing) + subroutine draw_grid(slices, spacing) bind(c, name='DrawGrid') + import :: c_float, c_int + implicit none + integer(kind=c_int), intent(in), value :: slices + real(kind=c_float), intent(in), value :: spacing + end subroutine draw_grid + + ! void DrawLine(int startPosX, int startPosY, int endPosX, int endPosY, Color color) + subroutine draw_line(start_pos_x, start_pos_y, end_pos_x, end_pos_y, color) bind(c, name='DrawLine') + import :: c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: start_pos_x + integer(kind=c_int), intent(in), value :: start_pos_y + integer(kind=c_int), intent(in), value :: end_pos_x + integer(kind=c_int), intent(in), value :: end_pos_y + type(color_type), intent(in), value :: color + end subroutine draw_line + + ! void DrawLine3D(Vector3 startPos, Vector3 endPos, Color color) + subroutine draw_line3d(start_pos, end_pos, color) bind(c, name='DrawLine3D') + import :: color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: start_pos + type(vector3_type), intent(in), value :: end_pos + type(color_type), intent(in), value :: color + end subroutine draw_line3d + + ! void DrawLineBezier(Vector2 startPos, Vector2 endPos, float thick, Color color) + subroutine draw_line_bezier(start_pos, end_pos, thick, color) bind(c, name='DrawLineBezier') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: start_pos + type(vector2_type), intent(in), value :: end_pos + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_line_bezier + + ! void DrawLineEx(Vector2 startPos, Vector2 endPos, float thick, Color color) + subroutine draw_line_ex(start_pos, end_pos, thick, color) bind(c, name='DrawLineEx') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: start_pos + type(vector2_type), intent(in), value :: end_pos + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_line_ex + + ! void DrawLineStrip(Vector2 *points, int pointCount, Color color) + subroutine draw_line_strip(points, point_count, color) bind(c, name='DrawLineStrip') + import :: c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + type(color_type), intent(in), value :: color + end subroutine draw_line_strip + + ! void DrawLineV(Vector2 startPos, Vector2 endPos, Color color) + subroutine draw_line_v(start_pos, end_pos, color) bind(c, name='DrawLineV') + import :: color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: start_pos + type(vector2_type), intent(in), value :: end_pos + type(color_type), intent(in), value :: color + end subroutine draw_line_v + + ! void DrawMesh(Mesh mesh, Material material, Matrix transform) + subroutine draw_mesh(mesh, material, transform) bind(c, name='DrawMesh') + import :: material_type, matrix_type, mesh_type + implicit none + type(mesh_type), intent(in), value :: mesh + type(material_type), intent(in), value :: material + type(matrix_type), intent(in), value :: transform + end subroutine draw_mesh + + ! void DrawMeshInstanced(Mesh mesh, Material material, const Matrix *transforms, int instances) + subroutine draw_mesh_instanced(mesh, material, transforms, instances) bind(c, name='DrawMeshInstanced') + import :: c_int, material_type, matrix_type, mesh_type + implicit none + type(mesh_type), intent(in), value :: mesh + type(material_type), intent(in), value :: material + type(matrix_type), intent(inout) :: transforms + integer(kind=c_int), intent(in), value :: instances + end subroutine draw_mesh_instanced + + ! void DrawModel(Model model, Vector3 position, float scale, Color tint) + subroutine draw_model(model, position, scale, tint) bind(c, name='DrawModel') + import :: c_float, color_type, model_type, vector3_type + implicit none + type(model_type), intent(in), value :: model + type(vector3_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: scale + type(color_type), intent(in), value :: tint + end subroutine draw_model + + ! void DrawModelEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) + subroutine draw_model_ex(model, position, rotation_axis, rotation_angle, scale, tint) & + bind(c, name='DrawModelEx') + import :: c_float, color_type, model_type, vector3_type + implicit none + type(model_type), intent(in), value :: model + type(vector3_type), intent(in), value :: position + type(vector3_type), intent(in), value :: rotation_axis + real(kind=c_float), intent(in), value :: rotation_angle + type(vector3_type), intent(in), value :: scale + type(color_type), intent(in), value :: tint + end subroutine draw_model_ex + + ! void DrawModelWires(Model model, Vector3 position, float scale, Color tint) + subroutine draw_model_wires(model, position, scale, tint) bind(c, name='DrawModelWires') + import :: c_float, color_type, model_type, vector3_type + implicit none + type(model_type), intent(in), value :: model + type(vector3_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: scale + type(color_type), intent(in), value :: tint + end subroutine draw_model_wires + + ! void DrawModelWiresEx(Model model, Vector3 position, Vector3 rotationAxis, float rotationAngle, Vector3 scale, Color tint) + subroutine draw_model_wires_ex(model, position, rotation_axis, rotation_angle, scale, tint) & + bind(c, name='DrawModelWiresEx') + import :: c_float, color_type, model_type, vector3_type + implicit none + type(model_type), intent(in), value :: model + type(vector3_type), intent(in), value :: position + type(vector3_type), intent(in), value :: rotation_axis + real(kind=c_float), intent(in), value :: rotation_angle + type(vector3_type), intent(in), value :: scale + type(color_type), intent(in), value :: tint + end subroutine draw_model_wires_ex + + ! void DrawPixel(int posX, int posY, Color color) + subroutine draw_pixel(pos_x, pos_y, color) bind(c, name='DrawPixel') + import :: c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + type(color_type), intent(in), value :: color + end subroutine draw_pixel + + ! void DrawPixelV(Vector2 position, Color color) + subroutine draw_pixel_v(position, color) bind(c, name='DrawPixelV') + import :: color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: position + type(color_type), intent(in), value :: color + end subroutine draw_pixel_v + + ! void DrawPlane(Vector3 centerPos, Vector2 size, Color color) + subroutine draw_plane(center_pos, size, color) bind(c, name='DrawPlane') + import :: color_type, vector2_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: center_pos + type(vector2_type), intent(in), value :: size + type(color_type), intent(in), value :: color + end subroutine draw_plane + + ! void DrawPoint3D(Vector3 position, Color color) + subroutine draw_point3d(position, color) bind(c, name='DrawPoint3D') + import :: color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: position + type(color_type), intent(in), value :: color + end subroutine draw_point3d + + ! void DrawPoly(Vector2 center, int sides, float radius, float rotation, Color color) + subroutine draw_poly(center, sides, radius, rotation, color) bind(c, name='DrawPoly') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + integer(kind=c_int), intent(in), value :: sides + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: rotation + type(color_type), intent(in), value :: color + end subroutine draw_poly + + ! void DrawPolyLines(Vector2 center, int sides, float radius, float rotation, Color color) + subroutine draw_poly_lines(center, sides, radius, rotation, color) bind(c, name='DrawPolyLines') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + integer(kind=c_int), intent(in), value :: sides + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: rotation + type(color_type), intent(in), value :: color + end subroutine draw_poly_lines + + ! void DrawPolyLinesEx(Vector2 center, int sides, float radius, float rotation, float lineThick, Color color) + subroutine draw_poly_lines_ex(center, sides, radius, rotation, line_thick, color) & + bind(c, name='DrawPolyLinesEx') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + integer(kind=c_int), intent(in), value :: sides + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: rotation + real(kind=c_float), intent(in), value :: line_thick + type(color_type), intent(in), value :: color + end subroutine draw_poly_lines_ex + + ! void DrawRay(Ray ray, Color color) + subroutine draw_ray(ray, color) bind(c, name='DrawRay') + import :: color_type, ray_type + implicit none + type(ray_type), intent(in), value :: ray + type(color_type), intent(in), value :: color + end subroutine draw_ray + + ! void DrawRectangle(int posX, int posY, int width, int height, Color color) + subroutine draw_rectangle(pos_x, pos_y, width, height, color) bind(c, name='DrawRectangle') + import :: c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(color_type), intent(in), value :: color + end subroutine draw_rectangle + + ! void DrawRectangleGradientEx(Rectangle rec, Color col1, Color col2, Color col3, Color col4) + subroutine draw_rectangle_gradient_ex(rec, col1, col2, col3, col4) bind(c, name='DrawRectangleGradientEx') + import :: color_type, rectangle_type + implicit none + type(rectangle_type), intent(in), value :: rec + type(color_type), intent(in), value :: col1 + type(color_type), intent(in), value :: col2 + type(color_type), intent(in), value :: col3 + type(color_type), intent(in), value :: col4 + end subroutine draw_rectangle_gradient_ex + + ! void DrawRectangleGradientH(int posX, int posY, int width, int height, Color color1, Color color2) + subroutine draw_rectangle_gradient_h(pos_x, pos_y, width, height, color1, color2) & + bind(c, name='DrawRectangleGradientH') + import :: c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(color_type), intent(in), value :: color1 + type(color_type), intent(in), value :: color2 + end subroutine draw_rectangle_gradient_h + + ! void DrawRectangleGradientV(int posX, int posY, int width, int height, Color color1, Color color2) + subroutine draw_rectangle_gradient_v(pos_x, pos_y, width, height, color1, color2) & + bind(c, name='DrawRectangleGradientV') + import :: c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(color_type), intent(in), value :: color1 + type(color_type), intent(in), value :: color2 + end subroutine draw_rectangle_gradient_v + + ! void DrawRectangleLines(int posX, int posY, int width, int height, Color color) + subroutine draw_rectangle_lines(pos_x, pos_y, width, height, color) bind(c, name='DrawRectangleLines') + import :: c_int, color_type + implicit none + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(color_type), intent(in), value :: color + end subroutine draw_rectangle_lines + + ! void DrawRectangleLinesEx(Rectangle rec, float lineThick, Color color) + subroutine draw_rectangle_lines_ex(rec, line_thick, color) bind(c, name='DrawRectangleLinesEx') + import :: c_float, color_type, rectangle_type + implicit none + type(rectangle_type), intent(in), value :: rec + real(kind=c_float), intent(in), value :: line_thick + type(color_type), intent(in), value :: color + end subroutine draw_rectangle_lines_ex + + ! void DrawRectanglePro(Rectangle rec, Vector2 origin, float rotation, Color color) + subroutine draw_rectangle_pro(rec, origin, rotation, color) bind(c, name='DrawRectanglePro') + import :: c_float, color_type, rectangle_type, vector2_type + implicit none + type(rectangle_type), intent(in), value :: rec + type(vector2_type), intent(in), value :: origin + real(kind=c_float), intent(in), value :: rotation + type(color_type), intent(in), value :: color + end subroutine draw_rectangle_pro + + ! void DrawRectangleRec(Rectangle rec, Color color) + subroutine draw_rectangle_rec(rec, color) bind(c, name='DrawRectangleRec') + import :: color_type, rectangle_type + implicit none + type(rectangle_type), intent(in), value :: rec + type(color_type), intent(in), value :: color + end subroutine draw_rectangle_rec + + ! void DrawRectangleRounded(Rectangle rec, float roundness, int segments, Color color) + subroutine draw_rectangle_rounded(rec, roundness, segments, color) bind(c, name='DrawRectangleRounded') + import :: c_float, c_int, color_type, rectangle_type + implicit none + type(rectangle_type), intent(in), value :: rec + real(kind=c_float), intent(in), value :: roundness + integer(kind=c_int), intent(in), value :: segments + type(color_type), intent(in), value :: color + end subroutine draw_rectangle_rounded + + ! void DrawRectangleRoundedLines(Rectangle rec, float roundness, int segments, float lineThick, Color color) + subroutine draw_rectangle_rounded_lines(rec, roundness, segments, line_thick, color) & + bind(c, name='DrawRectangleRoundedLines') + import :: c_float, c_int, color_type, rectangle_type + implicit none + type(rectangle_type), intent(in), value :: rec + real(kind=c_float), intent(in), value :: roundness + integer(kind=c_int), intent(in), value :: segments + real(kind=c_float), intent(in), value :: line_thick + type(color_type), intent(in), value :: color + end subroutine draw_rectangle_rounded_lines + + ! void DrawRectangleV(Vector2 position, Vector2 size, Color color) + subroutine draw_rectangle_v(position, size, color) bind(c, name='DrawRectangleV') + import :: color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: position + type(vector2_type), intent(in), value :: size + type(color_type), intent(in), value :: color + end subroutine draw_rectangle_v + + ! void DrawRing(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) + subroutine draw_ring(center, inner_radius, outer_radius, start_angle, end_angle, segments, color) & + bind(c, name='DrawRing') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: inner_radius + real(kind=c_float), intent(in), value :: outer_radius + real(kind=c_float), intent(in), value :: start_angle + real(kind=c_float), intent(in), value :: end_angle + integer(kind=c_int), intent(in), value :: segments + type(color_type), intent(in), value :: color + end subroutine draw_ring + + ! void DrawRingLines(Vector2 center, float innerRadius, float outerRadius, float startAngle, float endAngle, int segments, Color color) + subroutine draw_ring_lines(center, inner_radius, outer_radius, start_angle, end_angle, segments, color) & + bind(c, name='DrawRingLines') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: inner_radius + real(kind=c_float), intent(in), value :: outer_radius + real(kind=c_float), intent(in), value :: start_angle + real(kind=c_float), intent(in), value :: end_angle + integer(kind=c_int), intent(in), value :: segments + type(color_type), intent(in), value :: color + end subroutine draw_ring_lines + + ! void DrawSphere(Vector3 centerPos, float radius, Color color) + subroutine draw_sphere(center_pos, radius, color) bind(c, name='DrawSphere') + import :: c_float, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: center_pos + real(kind=c_float), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine draw_sphere + + ! void DrawSphereEx(Vector3 centerPos, float radius, int rings, int slices, Color color) + subroutine draw_sphere_ex(center_pos, radius, rings, slices, color) bind(c, name='DrawSphereEx') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: center_pos + real(kind=c_float), intent(in), value :: radius + integer(kind=c_int), intent(in), value :: rings + integer(kind=c_int), intent(in), value :: slices + type(color_type), intent(in), value :: color + end subroutine draw_sphere_ex + + ! void DrawSphereWires(Vector3 centerPos, float radius, int rings, int slices, Color color) + subroutine draw_sphere_wires(center_pos, radius, rings, slices, color) bind(c, name='DrawSphereWires') + import :: c_float, c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: center_pos + real(kind=c_float), intent(in), value :: radius + integer(kind=c_int), intent(in), value :: rings + integer(kind=c_int), intent(in), value :: slices + type(color_type), intent(in), value :: color + end subroutine draw_sphere_wires + + ! void DrawSplineBasis(Vector2 *points, int pointCount, float thick, Color color) + subroutine draw_spline_basis(points, point_count, thick, color) bind(c, name='DrawSplineBasis') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_basis + + ! void DrawSplineBezierCubic(Vector2 *points, int pointCount, float thick, Color color) + subroutine draw_spline_bezier_cubic(points, point_count, thick, color) bind(c, name='DrawSplineBezierCubic') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_bezier_cubic + + ! void DrawSplineBezierQuadratic(Vector2 *points, int pointCount, float thick, Color color) + subroutine draw_spline_bezier_quadratic(points, point_count, thick, color) bind(c, name='DrawSplineBezierQuadratic') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_bezier_quadratic + + ! void DrawSplineCatmullRom(Vector2 *points, int pointCount, float thick, Color color) + subroutine draw_spline_catmull_rom(points, point_count, thick, color) bind(c, name='DrawSplineCatmullRom') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_catmull_rom + + ! void DrawSplineLinear(Vector2 *points, int pointCount, float thick, Color color) + subroutine draw_spline_linear(points, point_count, thick, color) bind(c, name='DrawSplineLinear') + import :: c_float, c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_linear + + ! void DrawSplineSegmentBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) + subroutine draw_spline_segment_basis(p1, p2, p3, p4, thick, color) bind(c, name='DrawSplineSegmentBasis') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: p2 + type(vector2_type), intent(in), value :: p3 + type(vector2_type), intent(in), value :: p4 + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_segment_basis + + ! void DrawSplineSegmentBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float thick, Color color) + subroutine draw_spline_segment_bezier_cubic(p1, c2, c3, p4, thick, color) bind(c, name='DrawSplineSegmentBezierCubic') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: c2 + type(vector2_type), intent(in), value :: c3 + type(vector2_type), intent(in), value :: p4 + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_segment_bezier_cubic + + ! void DrawSplineSegmentBezierQuadratic(Vector2 p1, Vector2 c2, Vector2 p3, float thick, Color color) + subroutine draw_spline_segment_bezier_quadratic(p1, c2, p3, thick, color) bind(c, name='DrawSplineSegmentBezierQuadratic') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: c2 + type(vector2_type), intent(in), value :: p3 + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_segment_bezier_quadratic + + ! void DrawSplineSegmentCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float thick, Color color) + subroutine draw_spline_segment_catmull_rom(p1, p2, p3, p4, thick, color) bind(c, name='DrawSplineSegmentCatmullRom') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: p2 + type(vector2_type), intent(in), value :: p3 + type(vector2_type), intent(in), value :: p4 + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_segment_catmull_rom + + ! void DrawSplineSegmentLinear(Vector2 p1, Vector2 p2, float thick, Color color) + subroutine draw_spline_segment_linear(p1, p2, thick, color) bind(c, name='DrawSplineSegmentLinear') + import :: c_float, color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: p2 + real(kind=c_float), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine draw_spline_segment_linear + + ! void DrawTriangleStrip3D(Vector3 *points, int pointCount, Color color) + subroutine draw_triangle_strip3d(points, point_count, color) bind(c, name='DrawTriangleStrip3D') + import :: c_int, color_type, vector3_type + implicit none + type(vector3_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + type(color_type), intent(in), value :: color + end subroutine draw_triangle_strip3d + + ! void DrawText(const char *text, int posX, int posY, int fontSize, Color color) + subroutine draw_text(text, pos_x, pos_y, font_size, color) bind(c, name='DrawText') + import :: c_char, c_int, color_type + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + integer(kind=c_int), intent(in), value :: font_size + type(color_type), intent(in), value :: color + end subroutine draw_text + + ! void DrawTextCodepoint(Font font, int codepoint, Vector2 position, float fontSize, Color tint) + subroutine draw_text_codepoint(font, codepoint, position, font_size, tint) bind(c, name='DrawTextCodepoint') + import :: c_float, c_int, color_type, font_type, vector2_type + implicit none + type(font_type), intent(in), value :: font + integer(kind=c_int), intent(in), value :: codepoint + type(vector2_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: font_size + type(color_type), intent(in), value :: tint + end subroutine draw_text_codepoint + + ! void DrawTextCodepoints(Font font, const int *codepoints, int codepointCount, Vector2 position, float fontSize, float spacing, Color tint) + subroutine draw_text_codepoints(font, codepoints, codepointCount, position, font_size, spacing, tint) & + bind(c, name='DrawTextCodepoints') + import :: c_float, c_int, color_type, font_type, vector2_type + implicit none + type(font_type), intent(in), value :: font + integer(kind=c_int), intent(inout) :: codepoints(*) + integer(kind=c_int), intent(in), value :: codepointCount + type(vector2_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: font_size + real(kind=c_float), intent(in), value :: spacing + type(color_type), intent(in), value :: tint + end subroutine draw_text_codepoints + + ! void DrawTextEx(Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) + subroutine draw_text_ex(font, text, position, font_size, spacing, tint) bind(c, name='DrawTextEx') + import :: c_char, c_float, color_type, font_type, vector2_type + implicit none + type(font_type), intent(in), value :: font + character(kind=c_char), intent(in) :: text + type(vector2_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: font_size + real(kind=c_float), intent(in), value :: spacing + type(color_type), intent(in), value :: tint + end subroutine draw_text_ex + + ! void DrawTextPro(Font font, const char *text, Vector2 position, Vector2 origin, float rotation, float fontSize, float spacing, Color tint) + subroutine draw_text_pro(font, text, position, origin, rotation, font_size, spacing, tint) & + bind(c, name='DrawTextPro') + import :: c_char, c_float, color_type, font_type, vector2_type + implicit none + type(font_type), intent(in), value :: font + character(kind=c_char), intent(in) :: text + type(vector2_type), intent(in), value :: position + type(vector2_type), intent(in), value :: origin + real(kind=c_float), intent(in), value :: rotation + real(kind=c_float), intent(in), value :: font_size + real(kind=c_float), intent(in), value :: spacing + type(color_type), intent(in), value :: tint + end subroutine draw_text_pro + + ! void DrawTexture(Texture2D texture, int posX, int posY, Color tint) + subroutine draw_texture(texture, pos_x, pos_y, tint) bind(c, name='DrawTexture') + import :: c_int, color_type, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + type(color_type), intent(in), value :: tint + end subroutine draw_texture + + ! void DrawTextureEx(Texture2D texture, Vector2 position, float rotation, float scale, Color tint) + subroutine draw_texture_ex(texture, position, rotation, scale, tint) bind(c, name='DrawTextureEx') + import :: c_float, color_type, texture2d_type, vector2_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(vector2_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: rotation + real(kind=c_float), intent(in), value :: scale + type(color_type), intent(in), value :: tint + end subroutine draw_texture_ex + + ! void DrawTextureNPatch(Texture2D texture, NPatchInfo nPatchInfo, Rectangle dest, Vector2 origin, float rotation, Color tint) + subroutine draw_texture_npatch(texture, npatch_info, dest, origin, rotation, tint) & + bind(c, name='DrawTextureNPatch') + import :: c_float, color_type, npatch_info_type, rectangle_type, texture2d_type, vector2_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(npatch_info_type), intent(in), value :: npatch_info + type(rectangle_type), intent(in), value :: dest + type(vector2_type), intent(in), value :: origin + real(kind=c_float), intent(in), value :: rotation + type(color_type), intent(in), value :: tint + end subroutine draw_texture_npatch + + ! void DrawTexturePro(Texture2D texture, Rectangle source, Rectangle dest, Vector2 origin, float rotation, Color tint) + subroutine draw_texture_pro(texture, source, dest, origin, rotation, tint) bind(c, name='DrawTexturePro') + import :: c_float, color_type, rectangle_type, texture2d_type, vector2_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(rectangle_type), intent(in), value :: source + type(rectangle_type), intent(in), value :: dest + type(vector2_type), intent(in), value :: origin + real(kind=c_float), intent(in), value :: rotation + type(color_type), intent(in), value :: tint + end subroutine draw_texture_pro + + ! void DrawTextureRec(Texture2D texture, Rectangle source, Vector2 position, Color tint) + subroutine draw_texture_rec(texture, source, position, tint) bind(c, name='DrawTextureRec') + import :: color_type, rectangle_type, texture2d_type, vector2_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(rectangle_type), intent(in), value :: source + type(vector2_type), intent(in), value :: position + type(color_type), intent(in), value :: tint + end subroutine draw_texture_rec + + ! void DrawTextureV(Texture2D texture, Vector2 position, Color tint) + subroutine draw_texture_v(texture, position, tint) bind(c, name='DrawTextureV') + import :: color_type, texture2d_type, vector2_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(vector2_type), intent(in), value :: position + type(color_type), intent(in), value :: tint + end subroutine draw_texture_v + + ! void DrawTriangle(Vector2 v1, Vector2 v2, Vector2 v3, Color color) + subroutine draw_triangle(v1, v2, v3, color) bind(c, name='DrawTriangle') + import :: color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: v1 + type(vector2_type), intent(in), value :: v2 + type(vector2_type), intent(in), value :: v3 + type(color_type), intent(in), value :: color + end subroutine draw_triangle + + ! void DrawTriangle3D(Vector3 v1, Vector3 v2, Vector3 v3, Color color) + subroutine draw_triangle3d(v1, v2, v3, color) bind(c, name='DrawTriangle3D') + import :: color_type, vector3_type + implicit none + type(vector3_type), intent(in), value :: v1 + type(vector3_type), intent(in), value :: v2 + type(vector3_type), intent(in), value :: v3 + type(color_type), intent(in), value :: color + end subroutine draw_triangle3d + + ! void DrawTriangleFan(Vector2 *points, int pointCount, Color color) + subroutine draw_triangle_fan(points, point_count, color) bind(c, name='DrawTriangleFan') + import :: c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + type(color_type), intent(in), value :: color + end subroutine draw_triangle_fan + + ! void DrawTriangleLines(Vector2 v1, Vector2 v2, Vector2 v3, Color color) + subroutine draw_triangle_lines(v1, v2, v3, color) bind(c, name='DrawTriangleLines') + import :: color_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: v1 + type(vector2_type), intent(in), value :: v2 + type(vector2_type), intent(in), value :: v3 + type(color_type), intent(in), value :: color + end subroutine draw_triangle_lines + + ! void DrawTriangleStrip(Vector2 *points, int pointCount, Color color) + subroutine draw_triangle_strip(points, point_count, color) bind(c, name='DrawTriangleStrip') + import :: c_int, color_type, vector2_type + implicit none + type(vector2_type), intent(in) :: points(*) + integer(kind=c_int), intent(in), value :: point_count + type(color_type), intent(in), value :: color + end subroutine draw_triangle_strip + + ! void EnableCursor(void) + subroutine enable_cursor() bind(c, name='EnableCursor') + end subroutine enable_cursor + + ! void EnableEventWaiting(void) + subroutine enable_event_waiting() bind(c, name='EnableEventWaiting') + end subroutine enable_event_waiting + + ! char *EncodeDataBase64(const unsigned char *data, int dataSize, int *outputSize) + function encode_data_base64(data, data_size, output_size) bind(c, name='EncodeDataBase64') + import :: c_int, c_unsigned_char, c_ptr + implicit none + integer(kind=c_unsigned_char), intent(in) :: data + integer(kind=c_int), intent(in), value :: data_size + integer(kind=c_int), intent(out) :: output_size + type(c_ptr) :: encode_data_base64 + end function encode_data_base64 + + ! void EndBlendMode(void) + subroutine end_blend_mode() bind(c, name='EndBlendMode') + end subroutine end_blend_mode + + ! void EndDrawing(void) + subroutine end_drawing() bind(c, name='EndDrawing') + end subroutine end_drawing + + ! void EndMode2D(void) + subroutine end_mode2d() bind(c, name='EndMode2D') + end subroutine end_mode2d + + ! void EndMode3D(void) + subroutine end_mode3d() bind(c, name='EndMode3D') + end subroutine end_mode3d + + ! void EndScissorMode(void) + subroutine end_scissor_mode() bind(c, name='EndScissorMode') + end subroutine end_scissor_mode + + ! void EndShaderMode(void) + subroutine end_shader_mode() bind(c, name='EndShaderMode') + end subroutine end_shader_mode + + ! void EndTextureMode(void) + subroutine end_texture_mode() bind(c, name='EndTextureMode') + end subroutine end_texture_mode + + ! void EndVrStereoMode(void) + subroutine end_vr_stereo_mode() bind(c, name='EndVrStereoMode') + end subroutine end_vr_stereo_mode + + ! bool ExportDataAsCode(const unsigned char *data, int dataSize, const char *fileName) + function export_data_as_code(data, data_size, file_name) bind(c, name='ExportDataAsCode') + import :: c_bool, c_char, c_int, c_unsigned_char + implicit none + integer(kind=c_unsigned_char), intent(in) :: data + integer(kind=c_int), intent(in), value :: data_size + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: export_data_as_code + end function export_data_as_code + + ! bool ExportFontAsCode(Font font, const char *fileName) + function export_font_as_code(font, file_name) bind(c, name='ExportFontAsCode') + import :: c_bool, c_char, font_type + implicit none + type(font_type), intent(in), value :: font + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: export_font_as_code + end function export_font_as_code + + ! bool ExportImage(Image image, const char *fileName) + function export_image(image, file_name) bind(c, name='ExportImage') + import :: c_bool, c_char, image_type + implicit none + type(image_type), intent(in), value :: image + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: export_image + end function export_image + + ! bool ExportImageAsCode(Image image, const char *fileName) + function export_image_as_code(image, file_name) bind(c, name='ExportImageAsCode') + import :: c_bool, c_char, image_type + implicit none + type(image_type), intent(in), value :: image + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: export_image_as_code + end function export_image_as_code + + ! unsigned char *ExportImageToMemory(Image image, const char *fileType, int *fileSize) + function export_image_to_memory(image, file_type, file_size) bind(c, name='ExportImageToMemory') + import :: c_char, c_int, c_ptr, image_type + implicit none + type(image_type), intent(in), value :: image + character(kind=c_char), intent(in) :: file_type + integer(kind=c_int), intent(out) :: file_size + type(c_ptr) :: export_image_to_memory + end function export_image_to_memory + + ! bool ExportMesh(Mesh mesh, const char *fileName) + function export_mesh(mesh, file_name) bind(c, name='ExportMesh') + import :: c_bool, c_char, mesh_type + implicit none + type(mesh_type), intent(in), value :: mesh + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: export_mesh + end function export_mesh + + ! bool ExportWave(Wave wave, const char *fileName) + function export_wave(wave, file_name) bind(c, name='ExportWave') + import :: c_bool, c_char, wave_type + implicit none + type(wave_type), intent(in), value :: wave + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: export_wave + end function export_wave + + ! bool ExportWaveAsCode(Wave wave, const char *fileName) + function export_wave_as_code(wave, file_name) bind(c, name='ExportWaveAsCode') + import :: c_bool, c_char, wave_type + implicit none + type(wave_type), intent(in), value :: wave + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: export_wave_as_code + end function export_wave_as_code + + ! Color Fade(Color color, float alpha) + function fade(color, alpha) bind(c, name='Fade') + import :: c_float, color_type + implicit none + type(color_type), intent(in), value :: color + real(kind=c_float), intent(in), value :: alpha + type(color_type) :: fade + end function fade + + ! bool FileExists(const char *fileName) + function file_exists(file_name) bind(c, name='FileExists') + import :: c_bool, c_char + implicit none + character(kind=c_char), intent(in) :: file_name + logical(kind=c_bool) :: file_exists + end function file_exists + + ! Image GenImageCellular(int width, int height, int tileSize) + function gen_image_cellular(width, height, tile_size) bind(c, name='GenImageCellular') + import :: c_int, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + integer(kind=c_int), intent(in), value :: tile_size + type(image_type) :: gen_image_cellular + end function gen_image_cellular + + ! Image GenImageChecked(int width, int height, int checksX, int checksY, Color col1, Color col2) + function gen_image_checked(width, height, checks_x, checks_y, col1, col2) bind(c, name='GenImageChecked') + import :: c_int, color_type, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + integer(kind=c_int), intent(in), value :: checks_x + integer(kind=c_int), intent(in), value :: checks_y + type(color_type), intent(in), value :: col1 + type(color_type), intent(in), value :: col2 + type(image_type) :: gen_image_checked + end function gen_image_checked + + ! Image GenImageColor(int width, int height, Color color) + function gen_image_color(width, height, color) bind(c, name='GenImageColor') + import :: c_int, color_type, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(color_type), intent(in), value :: color + type(image_type) :: gen_image_color + end function gen_image_color + + ! Image GenImageFontAtlas(const GlyphInfo *glyphs, Rectangle **glyphRecs, int glyphCount, int fontSize, int padding, int packMethod) + function gen_image_font_atlas(glyphs, glyph_recs, glyph_count, font_size, padding, pack_method) & + bind(c, name='GenImageFontAtlas') + import :: c_int, glyph_info_type, image_type, rectangle_type + implicit none + type(glyph_info_type), intent(inout) :: glyphs + type(rectangle_type), intent(inout) :: glyph_recs(*) + integer(kind=c_int), intent(in), value :: glyph_count + integer(kind=c_int), intent(in), value :: font_size + integer(kind=c_int), intent(in), value :: padding + integer(kind=c_int), intent(in), value :: pack_method + type(image_type) :: gen_image_font_atlas + end function gen_image_font_atlas + + ! Image GenImageGradientLinear(int width, int height, int direction, Color start, Color end) + function gen_image_gradient_linear(width, height, direction, start, end) bind(c, name='GenImageGradientLinear') + import :: c_int, color_type, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + integer(kind=c_int), intent(in), value :: direction + type(color_type), intent(in), value :: start + type(color_type), intent(in), value :: end + type(image_type) :: gen_image_gradient_linear + end function gen_image_gradient_linear + + ! Image GenImageGradientRadial(int width, int height, float density, Color inner, Color outer) + function gen_image_gradient_radial(width, height, density, inner, outer) bind(c, name='GenImageGradientRadial') + import :: c_float, c_int, color_type, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + real(kind=c_float), intent(in), value :: density + type(color_type), intent(in), value :: inner + type(color_type), intent(in), value :: outer + type(image_type) :: gen_image_gradient_radial + end function gen_image_gradient_radial + + ! Image GenImageGradientSquare(int width, int height, float density, Color inner, Color outer) + function gen_image_gradient_square(width, height, density, inner, outer) bind(c, name='GenImageGradientSquare') + import :: c_float, c_int, color_type, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + real(kind=c_float), intent(in), value :: density + type(color_type), intent(in), value :: inner + type(color_type), intent(in), value :: outer + type(image_type) :: gen_image_gradient_square + end function gen_image_gradient_square + + ! Image GenImageWhiteNoise(int width, int height, float factor) + function gen_image_white_noise(width, height, factor) bind(c, name='GenImageWhiteNoise') + import :: c_float, c_int, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + real(kind=c_float), intent(in), value :: factor + type(image_type) :: gen_image_white_noise + end function gen_image_white_noise + + ! Image GenImagePerlinNoise(int width, int height, int offsetX, int offsetY, float scale) + function gen_image_perlin_noise(width, height, offset_x, offset_y, scale) bind(c, name='GenImagePerlinNoise') + import :: c_float, c_int, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + integer(kind=c_int), intent(in), value :: offset_x + integer(kind=c_int), intent(in), value :: offset_y + real(kind=c_float), intent(in), value :: scale + type(image_type) :: gen_image_perlin_noise + end function gen_image_perlin_noise + + ! Image GenImageText(int width, int height, const char *text) + function gen_image_text(width, height, text) bind(c, name='GenImageText') + import :: c_char, c_int, image_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + character(kind=c_char), intent(in) :: text + type(image_type) :: gen_image_text + end function gen_image_text + + ! Mesh GenMeshCone(float radius, float height, int slices) + function gen_mesh_cone(radius, height, slices) bind(c, name='GenMeshCone') + import :: c_float, c_int, mesh_type + implicit none + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: height + integer(kind=c_int), intent(in), value :: slices + type(mesh_type) :: gen_mesh_cone + end function gen_mesh_cone + + ! Mesh GenMeshCube(float width, float height, float length) + function gen_mesh_cube(width, height, length) bind(c, name='GenMeshCube') + import :: c_float, mesh_type + implicit none + real(kind=c_float), intent(in), value :: width + real(kind=c_float), intent(in), value :: height + real(kind=c_float), intent(in), value :: length + type(mesh_type) :: gen_mesh_cube + end function gen_mesh_cube + + ! Mesh GenMeshCubicmap(Image cubicmap, Vector3 cubeSize) + function gen_mesh_cubicmap(cubicmap, cube_size) bind(c, name='GenMeshCubicmap') + import :: image_type, mesh_type, vector3_type + implicit none + type(image_type), intent(in), value :: cubicmap + type(vector3_type), intent(in), value :: cube_size + type(mesh_type) :: gen_mesh_cubicmap + end function gen_mesh_cubicmap + + ! Mesh GenMeshCylinder(float radius, float height, int slices) + function gen_mesh_cylinder(radius, height, slices) bind(c, name='GenMeshCylinder') + import :: c_float, c_int, mesh_type + implicit none + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: height + integer(kind=c_int), intent(in), value :: slices + type(mesh_type) :: gen_mesh_cylinder + end function gen_mesh_cylinder + + ! Mesh GenMeshHeightmap(Image heightmap, Vector3 size) + function gen_mesh_heightmap(heightmap, size) bind(c, name='GenMeshHeightmap') + import :: image_type, mesh_type, vector3_type + implicit none + type(image_type), intent(in), value :: heightmap + type(vector3_type), intent(in), value :: size + type(mesh_type) :: gen_mesh_heightmap + end function gen_mesh_heightmap + + ! Mesh GenMeshHemiSphere(float radius, int rings, int slices) + function gen_mesh_hemi_sphere(radius, rings, slices) bind(c, name='GenMeshHemiSphere') + import :: c_float, c_int, mesh_type + implicit none + real(kind=c_float), intent(in), value :: radius + integer(kind=c_int), intent(in), value :: rings + integer(kind=c_int), intent(in), value :: slices + type(mesh_type) :: gen_mesh_hemi_sphere + end function gen_mesh_hemi_sphere + + ! Mesh GenMeshKnot(float radius, float size, int radSeg, int sides) + function gen_mesh_knot(radius, size, rad_seg, sides) bind(c, name='GenMeshKnot') + import :: c_float, c_int, mesh_type + implicit none + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: size + integer(kind=c_int), intent(in), value :: rad_seg + integer(kind=c_int), intent(in), value :: sides + type(mesh_type) :: gen_mesh_knot + end function gen_mesh_knot + + ! Mesh GenMeshPlane(float width, float length, int resX, int resZ) + function gen_mesh_plane(width, length, res_x, res_z) bind(c, name='GenMeshPlane') + import :: c_float, c_int, mesh_type + implicit none + real(kind=c_float), intent(in), value :: width + real(kind=c_float), intent(in), value :: length + integer(kind=c_int), intent(in), value :: res_x + integer(kind=c_int), intent(in), value :: res_z + type(mesh_type) :: gen_mesh_plane + end function gen_mesh_plane + + ! Mesh GenMeshPoly(int sides, float radius) + function gen_mesh_poly(sides, radius) bind(c, name='GenMeshPoly') + import :: c_float, c_int, mesh_type + implicit none + integer(kind=c_int), intent(in), value :: sides + real(kind=c_float), intent(in), value :: radius + type(mesh_type) :: gen_mesh_poly + end function gen_mesh_poly + + ! Mesh GenMeshSphere(float radius, int rings, int slices) + function gen_mesh_sphere(radius, rings, slices) bind(c, name='GenMeshSphere') + import :: c_float, c_int, mesh_type + implicit none + real(kind=c_float), intent(in), value :: radius + integer(kind=c_int), intent(in), value :: rings + integer(kind=c_int), intent(in), value :: slices + type(mesh_type) :: gen_mesh_sphere + end function gen_mesh_sphere + + ! void GenMeshTangents(Mesh *mesh) + subroutine gen_mesh_tangents(mesh) bind(c, name='GenMeshTangents') + import :: mesh_type + implicit none + type(mesh_type), intent(in) :: mesh + end subroutine gen_mesh_tangents + + ! Mesh GenMeshTorus(float radius, float size, int radSeg, int sides) + function gen_mesh_torus(radius, size, rad_seg, sides) bind(c, name='GenMeshTorus') + import :: c_float, c_int, mesh_type + implicit none + real(kind=c_float), intent(in), value :: radius + real(kind=c_float), intent(in), value :: size + integer(kind=c_int), intent(in), value :: rad_seg + integer(kind=c_int), intent(in), value :: sides + type(mesh_type) :: gen_mesh_torus + end function gen_mesh_torus + + ! void GenTextureMipmaps(Texture2D *texture) + subroutine gen_texture_mipmaps(texture) bind(c, name='GenTextureMipmaps') + import :: texture2d_type + implicit none + type(texture2d_type), intent(inout) :: texture + end subroutine gen_texture_mipmaps + + ! const char *GetApplicationDirectory(void) + function get_application_directory() bind(c, name='GetApplicationDirectory') + import :: c_ptr + implicit none + type(c_ptr) :: get_application_directory + end function get_application_directory + + ! Matrix GetCameraMatrix(Camera camera) + function get_camera_matrix(camera) bind(c, name='GetCameraMatrix') + import :: camera3d_type, matrix_type + implicit none + type(camera3d_type), intent(in), value :: camera + type(matrix_type) :: get_camera_matrix + end function get_camera_matrix + + ! Matrix GetCameraMatrix2D(Camera2D camera) + function get_camera_matrix2d(camera) bind(c, name='GetCameraMatrix2D') + import :: camera2d_type, matrix_type + implicit none + type(camera2d_type), intent(in), value :: camera + type(matrix_type) :: get_camera_matrix2d + end function get_camera_matrix2d + + ! int GetCharPressed(void) + function get_char_pressed() bind(c, name='GetCharPressed') + import :: c_int + implicit none + integer(kind=c_int) :: get_char_pressed + end function get_char_pressed + + ! const char *GetClipboardText(void) + function get_clipboard_text() bind(c, name='GetClipboardText') + import :: c_ptr + implicit none + type(c_ptr) :: get_clipboard_text + end function get_clipboard_text + + ! int GetCodepoint(const char *text, int *codepointSize) + function get_codepoint(text, codepoint_size) bind(c, name='GetCodepoint') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(out) :: codepoint_size + integer(kind=c_int) :: get_codepoint + end function get_codepoint + + ! int GetCodepointCount(const char *text) + function get_codepoint_count(text) bind(c, name='GetCodepointCount') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int) :: get_codepoint_count + end function get_codepoint_count + + ! int GetCodepointNext(const char *text, int *codepointSize) + function get_codepoint_next(text, codepoint_size) bind(c, name='GetCodepointNext') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(out) :: codepoint_size + integer(kind=c_int) :: get_codepoint_next + end function get_codepoint_next + + ! int GetCodepointPrevious(const char *text, int *codepointSize) + function get_codepoint_previous(text, codepoint_size) bind(c, name='GetCodepointPrevious') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(out) :: codepoint_size + integer(kind=c_int) :: get_codepoint_previous + end function get_codepoint_previous + + ! Rectangle GetCollisionRec(Rectangle rec1, Rectangle rec2) + function get_collision_rec(rec1, rec2) bind(c, name='GetCollisionRec') + import :: rectangle_type + implicit none + type(rectangle_type), intent(in), value :: rec1 + type(rectangle_type), intent(in), value :: rec2 + type(rectangle_type) :: get_collision_rec + end function get_collision_rec + + ! Color GetColor(unsigned int hexValue) + function get_color(hex_value) bind(c, name='GetColor') + import :: c_unsigned_int, color_type + implicit none + integer(kind=c_unsigned_int), intent(in), value :: hex_value + type(color_type) :: get_color + end function get_color + + ! int GetCurrentMonitor(void) + function get_current_monitor() bind(c, name='GetCurrentMonitor') + import :: c_int + implicit none + integer(kind=c_int) :: get_current_monitor + end function get_current_monitor + + ! const char *GetDirectoryPath(const char *filePath) + function get_directory_path(file_path) bind(c, name='GetDirectoryPath') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_path + type(c_ptr) :: get_directory_path + end function get_directory_path + + ! int GetFPS(void) + function get_fps() bind(c, name='GetFPS') + import :: c_int + implicit none + integer(kind=c_int) :: get_fps + end function get_fps + + ! const char *GetFileExtension(const char *fileName) + function get_file_extension(file_name) bind(c, name='GetFileExtension') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_name + type(c_ptr) :: get_file_extension + end function get_file_extension + + ! int GetFileLength(const char *fileName) + function get_file_length(file_name) bind(c, name='GetFileLength') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_int) :: get_file_length + end function get_file_length + + ! long GetFileModTime(const char *fileName) + function get_file_mod_time(file_name) bind(c, name='GetFileModTime') + import :: c_char, c_long + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_long) :: get_file_mod_time + end function get_file_mod_time + + ! const char *GetFileName(const char *filePath) + function get_file_name(file_path) bind(c, name='GetFileName') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_path + type(c_ptr) :: get_file_name + end function get_file_name + + ! const char *GetFileNameWithoutExt(const char *filePath) + function get_file_name_without_ext(file_path) bind(c, name='GetFileNameWithoutExt') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_path + type(c_ptr) :: get_file_name_without_ext + end function get_file_name_without_ext + + ! Font GetFontDefault(void) + function get_font_default() bind(c, name='GetFontDefault') + import :: font_type + implicit none + type(font_type) :: get_font_default + end function get_font_default + + ! float GetFrameTime(void) + function get_frame_time() bind(c, name='GetFrameTime') + import :: c_float + implicit none + real(kind=c_float) :: get_frame_time + end function get_frame_time + + ! int GetGamepadAxisCount(int gamepad) + function get_gamepad_axis_count(gamepad) bind(c, name='GetGamepadAxisCount') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: gamepad + integer(kind=c_int) :: get_gamepad_axis_count + end function get_gamepad_axis_count + + ! float GetGamepadAxisMovement(int gamepad, int axis) + function get_gamepad_axis_movement(gamepad, axis) bind(c, name='GetGamepadAxisMovement') + import :: c_float, c_int + implicit none + integer(kind=c_int), intent(in), value :: gamepad + integer(kind=c_int), intent(in), value :: axis + real(kind=c_float) :: get_gamepad_axis_movement + end function get_gamepad_axis_movement + + ! int GetGamepadButtonPressed(void) + function get_gamepad_button_pressed() bind(c, name='GetGamepadButtonPressed') + import :: c_int + implicit none + integer(kind=c_int) :: get_gamepad_button_pressed + end function get_gamepad_button_pressed + + ! const char *GetGamepadName(int gamepad) + function get_gamepad_name(gamepad) bind(c, name='GetGamepadName') + import :: c_char, c_int, c_ptr + implicit none + integer(kind=c_int), intent(in), value :: gamepad + type(c_ptr) :: get_gamepad_name + end function get_gamepad_name + + ! int GetGestureDetected(void) + function get_gesture_detected() bind(c, name='GetGestureDetected') + import :: c_int + implicit none + integer(kind=c_int) :: get_gesture_detected + end function get_gesture_detected + + ! float GetGestureDragAngle(void) + function get_gesture_drag_angle() bind(c, name='GetGestureDragAngle') + import :: c_float + implicit none + real(kind=c_float) :: get_gesture_drag_angle + end function get_gesture_drag_angle + + ! float GetGestureHoldDuration(void) + function get_gesture_hold_duration() bind(c, name='GetGestureHoldDuration') + import :: c_float + implicit none + real(kind=c_float) :: get_gesture_hold_duration + end function get_gesture_hold_duration + + ! float GetGesturePinchAngle(void) + function get_gesture_pinch_angle() bind(c, name='GetGesturePinchAngle') + import :: c_float + implicit none + real(kind=c_float) :: get_gesture_pinch_angle + end function get_gesture_pinch_angle + + ! Rectangle GetGlyphAtlasRec(Font font, int codepoint) + function get_glyph_atlas_rec(font, codepoint) bind(c, name='GetGlyphAtlasRec') + import :: c_int, font_type, rectangle_type + implicit none + type(font_type), intent(in), value :: font + integer(kind=c_int), intent(in), value :: codepoint + type(rectangle_type) :: get_glyph_atlas_rec + end function get_glyph_atlas_rec + + ! int GetGlyphIndex(Font font, int codepoint) + function get_glyph_index(font, codepoint) bind(c, name='GetGlyphIndex') + import :: c_int, font_type + implicit none + type(font_type), intent(in), value :: font + integer(kind=c_int), intent(in), value :: codepoint + integer(kind=c_int) :: get_glyph_index + end function get_glyph_index + + ! GlyphInfo GetGlyphInfo(Font font, int codepoint) + function get_glyph_info(font, codepoint) bind(c, name='GetGlyphInfo') + import :: c_int, font_type, glyph_info_type + implicit none + type(font_type), intent(in), value :: font + integer(kind=c_int), intent(in), value :: codepoint + type(glyph_info_type) :: get_glyph_info + end function get_glyph_info + + ! float GetMasterVolume(void) + function get_master_volume() bind(c, name='GetMasterVolume') + import :: c_float + implicit none + real(kind=c_float) :: get_master_volume + end function get_master_volume + + ! Rectangle GetImageAlphaBorder(Image image, float threshold) + function get_image_alpha_border(image, threshold) bind(c, name='GetImageAlphaBorder') + import :: c_float, image_type, rectangle_type + implicit none + type(image_type), intent(in), value :: image + real(kind=c_float), intent(in), value :: threshold + type(rectangle_type) :: get_image_alpha_border + end function get_image_alpha_border + + ! Vector2 GetSplinePointBasis(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) + function get_spline_point_basis(p1, p2, p3, p4, t) bind(c, name='GetSplinePointBasis') + import :: c_float, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: p2 + type(vector2_type), intent(in), value :: p3 + type(vector2_type), intent(in), value :: p4 + real(kind=c_float), intent(in), value :: t + type(vector2_type) :: get_spline_point_basis + end function get_spline_point_basis + + ! Vector2 GetSplinePointBezierCubic(Vector2 p1, Vector2 c2, Vector2 c3, Vector2 p4, float t) + function get_spline_point_bezier_cubic(p1, c2, c3, p4, t) bind(c, name='GetSplinePointBezierCubic') + import :: c_float, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: c2 + type(vector2_type), intent(in), value :: c3 + type(vector2_type), intent(in), value :: p4 + real(kind=c_float), intent(in), value :: t + type(vector2_type) :: get_spline_point_bezier_cubic + end function get_spline_point_bezier_cubic + + ! Vector2 GetSplinePointBezierQuad(Vector2 p1, Vector2 c2, Vector2 p3, float t) + function get_spline_point_bezier_quad(p1, c2, p3, t) bind(c, name='GetSplinePointBezierQuad') + import :: c_float, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: c2 + type(vector2_type), intent(in), value :: p3 + real(kind=c_float), intent(in), value :: t + type(vector2_type) :: get_spline_point_bezier_quad + end function get_spline_point_bezier_quad + + ! Vector2 GetSplinePointCatmullRom(Vector2 p1, Vector2 p2, Vector2 p3, Vector2 p4, float t) + function get_spline_point_catmull_rom(p1, p2, p3, p4, t) bind(c, name='GetSplinePointCatmullRom') + import :: c_float, vector2_type + implicit none + type(vector2_type), intent(in), value :: p1 + type(vector2_type), intent(in), value :: p2 + type(vector2_type), intent(in), value :: p3 + type(vector2_type), intent(in), value :: p4 + real(kind=c_float), intent(in), value :: t + type(vector2_type) :: get_spline_point_catmull_rom + end function get_spline_point_catmull_rom + + ! Vector2 GetSplinePointLinear(Vector2 startPos, Vector2 endPos, float t) + function get_spline_point_linear(start_pos, end_pos, t) bind(c, name='GetSplinePointLinear') + import :: c_float, vector2_type + implicit none + type(vector2_type), intent(in), value :: start_pos + type(vector2_type), intent(in), value :: end_pos + real(kind=c_float), intent(in), value :: t + type(vector2_type) :: get_spline_point_linear + end function get_spline_point_linear + + ! void ImageBlurGaussian(Image *image, int blurSize) + subroutine image_blur_gaussian(image, blur_size) bind(c, name='ImageBlurGaussian') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: blur_size + end subroutine image_blur_gaussian + + ! Color GetImageColor(Image image, int x, int y) + function get_image_color(image, x, y) bind(c, name='GetImageColor') + import :: c_int, color_type, image_type + implicit none + type(image_type), intent(in), value :: image + integer(kind=c_int), intent(in), value :: x + integer(kind=c_int), intent(in), value :: y + type(color_type) :: get_image_color + end function get_image_color + + ! int GetKeyPressed(void) + function get_key_pressed() bind(c, name='GetKeyPressed') + import :: c_int + implicit none + integer(kind=c_int) :: get_key_pressed + end function get_key_pressed + + ! BoundingBox GetMeshBoundingBox(Mesh mesh) + function get_mesh_bounding_box(mesh) bind(c, name='GetMeshBoundingBox') + import :: bounding_box_type, mesh_type + implicit none + type(mesh_type), intent(in), value :: mesh + type(bounding_box_type) :: get_mesh_bounding_box + end function get_mesh_bounding_box + + ! BoundingBox GetModelBoundingBox(Model model) + function get_model_bounding_box(model) bind(c, name='GetModelBoundingBox') + import :: bounding_box_type, model_type + implicit none + type(model_type), intent(in), value :: model + type(bounding_box_type) :: get_model_bounding_box + end function get_model_bounding_box + + ! int GetMonitorCount(void) + function get_monitor_count() bind(c, name='GetMonitorCount') + import :: c_int + implicit none + integer(kind=c_int) :: get_monitor_count + end function get_monitor_count + + ! int GetMonitorHeight(int monitor) + function get_monitor_height(monitor) bind(c, name='GetMonitorHeight') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: monitor + integer(kind=c_int) :: get_monitor_height + end function get_monitor_height + + ! const char *GetMonitorName(int monitor) + function get_monitor_name(monitor) bind(c, name='GetMonitorName') + import :: c_int, c_ptr + implicit none + integer(kind=c_int), intent(in), value :: monitor + type(c_ptr) :: get_monitor_name + end function get_monitor_name + + ! int GetMonitorPhysicalHeight(int monitor) + function get_monitor_physical_height(monitor) bind(c, name='GetMonitorPhysicalHeight') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: monitor + integer(kind=c_int) :: get_monitor_physical_height + end function get_monitor_physical_height + + ! int GetMonitorPhysicalWidth(int monitor) + function get_monitor_physical_width(monitor) bind(c, name='GetMonitorPhysicalWidth') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: monitor + integer(kind=c_int) :: get_monitor_physical_width + end function get_monitor_physical_width + + ! int GetMonitorRefreshRate(int monitor) + function get_monitor_refresh_rate(monitor) bind(c, name='GetMonitorRefreshRate') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: monitor + integer(kind=c_int) :: get_monitor_refresh_rate + end function get_monitor_refresh_rate + + ! int GetMonitorWidth(int monitor) + function get_monitor_width(monitor) bind(c, name='GetMonitorWidth') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: monitor + integer(kind=c_int) :: get_monitor_width + end function get_monitor_width + + ! Vector2 GetMouseDelta(void) + function get_mouse_delta() bind(c, name='GetMouseDelta') + import :: vector2_type + implicit none + type(vector2_type) :: get_mouse_delta + end function get_mouse_delta + + ! Vector2 GetMousePosition(void) + function get_mouse_position() bind(c, name='GetMousePosition') + import :: vector2_type + implicit none + type(vector2_type) :: get_mouse_position + end function get_mouse_position + + ! Ray GetMouseRay(Vector2 mousePosition, Camera camera) + function get_mouse_ray(mouse_position, camera) bind(c, name='GetMouseRay') + import :: camera3d_type, ray_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: mouse_position + type(camera3d_type),intent(in), value :: camera + type(ray_type) :: get_mouse_ray + end function get_mouse_ray + + ! float GetMouseWheelMove(void) + function get_mouse_wheel_move() bind(c, name='GetMouseWheelMove') + import :: c_float + implicit none + real(kind=c_float) :: get_mouse_wheel_move + end function get_mouse_wheel_move + + ! int GetMouseX(void) + function get_mouse_x() bind(c, name='GetMouseX') + import :: c_int + implicit none + integer(kind=c_int) :: get_mouse_x + end function get_mouse_x + + ! int GetMouseY(void) + function get_mouse_y() bind(c, name='GetMouseY') + import :: c_int + implicit none + integer(kind=c_int) :: get_mouse_y + end function get_mouse_y + + ! float GetMusicTimeLength(Music music) + function get_music_time_length(music) bind(c, name='GetMusicTimeLength') + import :: c_float, music_type + implicit none + type(music_type), intent(in), value :: music + real(kind=c_float) :: get_music_time_length + end function get_music_time_length + + ! float GetMusicTimePlayed(Music music) + function get_music_time_played(music) bind(c, name='GetMusicTimePlayed') + import :: c_float, music_type + implicit none + type(music_type), intent(in), value :: music + real(kind=c_float) :: get_music_time_played + end function get_music_time_played + + ! Color GetPixelColor(void *srcPtr, int format) + function get_pixel_color(src_ptr, format) bind(c, name='GetPixelColor') + import :: c_int, c_ptr, color_type + implicit none + type(c_ptr), intent(in), value :: src_ptr + integer(kind=c_int), intent(in), value :: format + type(color_type) :: get_pixel_color + end function get_pixel_color + + ! int GetPixelDataSize(int width, int height, int format) + function get_pixel_data_size(width, height, format) bind(c, name='GetPixelDataSize') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + integer(kind=c_int), intent(in), value :: format + integer(kind=c_int) :: get_pixel_data_size + end function get_pixel_data_size + + ! const char *GetPrevDirectoryPath(const char *dirPath) + function get_prev_directory_path(dir_path) bind(c, name='GetPrevDirectoryPath') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: dir_path + type(c_ptr) :: get_prev_directory_path + end function get_prev_directory_path + + ! int GetRandomValue(int min, int max) + function get_random_value(min, max) bind(c, name='GetRandomValue') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: min + integer(kind=c_int), intent(in), value :: max + integer(kind=c_int) :: get_random_value + end function get_random_value + + ! RayCollision GetRayCollisionBox(Ray ray, BoundingBox box) + function get_ray_collision_box(ray, box) bind(c, name='GetRayCollisionBox') + import :: bounding_box_type, ray_collision_type, ray_type + implicit none + type(ray_type), intent(in), value :: ray + type(bounding_box_type), intent(in), value :: box + type(ray_collision_type) :: get_ray_collision_box + end function get_ray_collision_box + + ! RayCollision GetRayCollisionMesh(Ray ray, Mesh mesh, Matrix transform) + function get_ray_collision_mesh(ray, mesh, transform) bind(c, name='GetRayCollisionMesh') + import :: matrix_type, mesh_type, ray_collision_type, ray_type + implicit none + type(ray_type), intent(in), value :: ray + type(mesh_type), intent(in), value :: mesh + type(matrix_type), intent(in), value :: transform + type(ray_collision_type) :: get_ray_collision_mesh + end function get_ray_collision_mesh + + ! RayCollision GetRayCollisionQuad(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3, Vector3 p4) + function get_ray_collision_quad(ray, p1, p2, p3, p4) bind(c, name='GetRayCollisionQuad') + import :: ray_collision_type, ray_type, vector3_type + implicit none + type(ray_type), intent(in), value :: ray + type(vector3_type), intent(in), value :: p1 + type(vector3_type), intent(in), value :: p2 + type(vector3_type), intent(in), value :: p3 + type(vector3_type), intent(in), value :: p4 + type(ray_collision_type) :: get_ray_collision_quad + end function get_ray_collision_quad + + ! RayCollision GetRayCollisionSphere(Ray ray, Vector3 center, float radius) + function get_ray_collision_sphere(ray, center, radius) bind(c, name='GetRayCollisionSphere') + import :: c_float, ray_collision_type, ray_type, vector3_type + implicit none + type(ray_type), intent(in), value :: ray + type(vector3_type), intent(in), value :: center + real(kind=c_float), intent(in), value :: radius + type(ray_collision_type) :: get_ray_collision_sphere + end function get_ray_collision_sphere + + ! RayCollision GetRayCollisionTriangle(Ray ray, Vector3 p1, Vector3 p2, Vector3 p3) + function get_ray_collision_triangle(ray, p1, p2, p3) bind(c, name='GetRayCollisionTriangle') + import :: ray_collision_type, ray_type, vector3_type + implicit none + type(ray_type), intent(in), value :: ray + type(vector3_type), intent(in), value :: p1 + type(vector3_type), intent(in), value :: p2 + type(vector3_type), intent(in), value :: p3 + type(ray_collision_type) :: get_ray_collision_triangle + end function get_ray_collision_triangle + + ! int GetRenderHeight(void) + function get_render_height() bind(c, name='GetRenderHeight') + import :: c_int + implicit none + integer(kind=c_int) :: get_render_height + end function get_render_height + + ! int GetRenderWidth(void) + function get_render_width() bind(c, name='GetRenderWidth') + import :: c_int + implicit none + integer(kind=c_int) :: get_render_width + end function get_render_width + + ! int GetScreenHeight(void) + function get_screen_height() bind(c, name='GetScreenHeight') + import :: c_int + implicit none + integer(kind=c_int) :: get_screen_height + end function get_screen_height + + ! Vector2 GetScreenToWorld2D(Vector2 position, Camera2D camera) + function get_screen_to_world2d(position, camera) bind(c, name='GetScreenToWorld2D') + import :: camera2d_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: position + type(camera2d_type), intent(in), value :: camera + type(vector2_type) :: get_screen_to_world2d + end function get_screen_to_world2d + + ! int GetScreenWidth(void) + function get_screen_width() bind(c, name='GetScreenWidth') + import :: c_int + implicit none + integer(kind=c_int) :: get_screen_width + end function get_screen_width + + ! int GetShaderLocation(Shader shader, const char *uniformName) + function get_shader_location(shader, uniform_name) bind(c, name='GetShaderLocation') + import :: c_char, c_int, shader_type + implicit none + type(shader_type), intent(in), value :: shader + character(kind=c_char), intent(in) :: uniform_name + integer(kind=c_int) :: get_shader_location + end function get_shader_location + + ! int GetShaderLocationAttrib(Shader shader, const char *attribName) + function get_shader_location_attrib(shader, attrib_name) bind(c, name='GetShaderLocationAttrib') + import :: c_char, c_int, shader_type + implicit none + type(shader_type), intent(in), value :: shader + character(kind=c_char), intent(in) :: attrib_name + integer(kind=c_int) :: get_shader_location_attrib + end function get_shader_location_attrib + + ! double GetTime(void) + function get_time() bind(c, name='GetTime') + import :: c_double + implicit none + real(kind=c_double) :: get_time + end function get_time + + ! int GetTouchPointCount(void) + function get_touch_point_count() bind(c, name='GetTouchPointCount') + import :: c_int + implicit none + integer(kind=c_int) :: get_touch_point_count + end function get_touch_point_count + + ! int GetTouchPointId(int index) + function get_touch_point_id(index) bind(c, name='GetTouchPointId') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: index + integer(kind=c_int) :: get_touch_point_id + end function get_touch_point_id + + ! int GetTouchX(void) + function get_touch_x() bind(c, name='GetTouchX') + import :: c_int + implicit none + integer(kind=c_int) :: get_touch_x + end function get_touch_x + + ! int GetTouchY(void) + function get_touch_y() bind(c, name='GetTouchY') + import :: c_int + implicit none + integer(kind=c_int) :: get_touch_y + end function get_touch_y + + ! void *GetWindowHandle(void) + function get_window_handle() bind(c, name='GetWindowHandle') + import :: c_ptr + implicit none + type(c_ptr) :: get_window_handle + end function get_window_handle + + ! const char *GetWorkingDirectory(void) + function get_working_directory() bind(c, name='GetWorkingDirectory') + import :: c_ptr + implicit none + type(c_ptr) :: get_working_directory + end function get_working_directory + + ! Vector2 GetWorldToScreen2D(Vector2 position, Camera2D camera) + function get_world_to_screen2d(position, camera) bind(c, name='GetWorldToScreen2D') + import :: camera2d_type, vector2_type + implicit none + type(vector2_type), intent(in), value :: position + type(camera2d_type), intent(in), value :: camera + type(vector2_type) :: get_world_to_screen2d + end function get_world_to_screen2d + + ! void HideCursor(void) + subroutine hide_cursor() bind(c, name='HideCursor') + end subroutine hide_cursor + + ! void ImageAlphaClear(Image *image, Color color, float threshold) + subroutine image_alpha_clear(image, color, threshold) bind(c, name='ImageAlphaClear') + import :: c_float, color_type, image_type + implicit none + type(image_type), intent(inout) :: image + type(color_type), intent(in), value :: color + real(kind=c_float), intent(in), value :: threshold + end subroutine image_alpha_clear + + ! void ImageAlphaCrop(Image *image, float threshold) + subroutine image_alpha_crop(image, threshold) bind(c, name='ImageAlphaCrop') + import :: c_float, image_type + implicit none + type(image_type), intent(inout) :: image + real(kind=c_float), intent(in), value :: threshold + end subroutine image_alpha_crop + + ! void ImageAlphaMask(Image *image, Image alphaMask) + subroutine image_alpha_mask(image, alpha_mask) bind(c, name='ImageAlphaMask') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + type(image_type), intent(in), value :: alpha_mask + end subroutine image_alpha_mask + + ! void ImageAlphaPremultiply(Image *image) + subroutine image_alpha_premultiply(image) bind(c, name='ImageAlphaPremultiply') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_alpha_premultiply + + ! void ImageClearBackground(Image *dst, Color color) + subroutine image_clear_background(dst, color) bind(c, name='ImageClearBackground') + import :: color_type, image_type + implicit none + type(image_type), intent(inout) :: dst + type(color_type), intent(in), value :: color + end subroutine image_clear_background + + ! void ImageColorBrightness(Image *image, int brightness) + subroutine image_color_brightness(image, brightness) bind(c, name='ImageColorBrightness') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: brightness + end subroutine image_color_brightness + + ! void ImageColorContrast(Image *image, float contrast) + subroutine image_color_contrast(image, contrast) bind(c, name='ImageColorContrast') + import :: c_float, image_type + implicit none + type(image_type), intent(inout) :: image + real(kind=c_float), intent(in), value :: contrast + end subroutine image_color_contrast + + ! void ImageColorGrayscale(Image *image) + subroutine image_color_grayscale(image) bind(c, name='ImageColorGrayscale') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_color_grayscale + + ! void ImageColorInvert(Image *image) + subroutine image_color_invert(image) bind(c, name='ImageColorInvert') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_color_invert + + ! void ImageColorReplace(Image *image, Color color, Color replace) + subroutine image_color_replace(image, color, replace) bind(c, name='ImageColorReplace') + import :: color_type, image_type + implicit none + type(image_type), intent(inout) :: image + type(color_type), intent(in), value :: color + type(color_type), intent(in), value :: replace + end subroutine image_color_replace + + ! void ImageColorTint(Image *image, Color color) + subroutine image_color_tint(image, color) bind(c, name='ImageColorTint') + import :: color_type, image_type + implicit none + type(image_type), intent(inout) :: image + type(color_type), intent(in), value :: color + end subroutine image_color_tint + + ! Image ImageCopy(Image image) + function image_copy(image) bind(c, name='ImageCopy') + import :: image_type + implicit none + type(image_type), intent(in), value :: image + type(image_type) :: image_copy + end function image_copy + + ! void ImageCrop(Image *image, Rectangle crop) + subroutine image_crop(image, crop) bind(c, name='ImageCrop') + import :: image_type, rectangle_type + implicit none + type(image_type), intent(inout) :: image + type(rectangle_type), intent(in), value :: crop + end subroutine image_crop + + ! void ImageDither(Image *image, int rBpp, int gBpp, int bBpp, int aBpp) + subroutine image_dither(image, r_bpp, g_bpp, b_bpp, a_bpp) bind(c, name='ImageDither') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: r_bpp + integer(kind=c_int), intent(in), value :: g_bpp + integer(kind=c_int), intent(in), value :: b_bpp + integer(kind=c_int), intent(in), value :: a_bpp + end subroutine image_dither + + ! void ImageDraw(Image *dst, Image src, Rectangle srcRec, Rectangle dstRec, Color tint) + subroutine image_draw(dst, src, src_rec, dst_rec, tint) bind(c, name='ImageDraw') + import :: color_type, image_type, rectangle_type + implicit none + type(image_type), intent(inout) :: dst + type(image_type), intent(in), value :: src + type(rectangle_type), intent(in), value :: src_rec + type(rectangle_type), intent(in), value :: dst_rec + type(color_type), intent(in), value :: tint + end subroutine image_draw + + ! void ImageDrawCircle(Image *dst, int centerX, int centerY, int radius, Color color) + subroutine image_draw_circle(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircle') + import :: c_int, color_type, image_type + implicit none + type(image_type), intent(inout) :: dst + integer(kind=c_int), intent(in), value :: center_x + integer(kind=c_int), intent(in), value :: center_y + integer(kind=c_int), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine image_draw_circle + + ! void ImageDrawCircleLines(Image *dst, int centerX, int centerY, int radius, Color color) + subroutine image_draw_circle_lines(dst, center_x, center_y, radius, color) bind(c, name='ImageDrawCircleLines') + import :: c_int, color_type, image_type + implicit none + type(image_type), intent(inout) :: dst + integer(kind=c_int), intent(in), value :: center_x + integer(kind=c_int), intent(in), value :: center_y + integer(kind=c_int), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine image_draw_circle_lines + + ! void ImageDrawCircleLinesV(Image *dst, Vector2 center, int radius, Color color) + subroutine image_draw_circle_lines_v(dst, center, radius, color) bind(c, name='ImageDrawCircleLinesV') + import :: c_int, color_type, image_type, vector2_type + implicit none + type(image_type), intent(inout) :: dst + type(vector2_type), intent(in), value :: center + integer(kind=c_int), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine image_draw_circle_lines_v + + ! void ImageDrawCircleV(Image *dst, Vector2 center, int radius, Color color) + subroutine image_draw_circle_v(dst, center, radius, color) bind(c, name='ImageDrawCircleV') + import :: c_int, color_type, image_type, vector2_type + implicit none + type(image_type), intent(inout) :: dst + type(vector2_type), intent(in), value :: center + integer(kind=c_int), intent(in), value :: radius + type(color_type), intent(in), value :: color + end subroutine image_draw_circle_v + + ! void ImageDrawLine(Image *dst, int startPosX, int startPosY, int endPosX, int endPosY, Color color) + subroutine image_draw_line(dst, start_pos_x, start_pos_y, end_pos_x, end_pos_y, color) & + bind(c, name='ImageDrawLine') + import :: c_int, color_type, image_type + implicit none + type(image_type), intent(inout) :: dst + integer(kind=c_int), intent(in), value :: start_pos_x + integer(kind=c_int), intent(in), value :: start_pos_y + integer(kind=c_int), intent(in), value :: end_pos_x + integer(kind=c_int), intent(in), value :: end_pos_y + type(color_type), intent(in), value :: color + end subroutine image_draw_line + + ! void ImageDrawLineV(Image *dst, Vector2 start, Vector2 end, Color color) + subroutine image_draw_line_v(dst, start, end, color) bind(c, name='ImageDrawLineV') + import :: color_type, image_type, vector2_type + implicit none + type(image_type), intent(inout) :: dst + type(vector2_type), intent(in), value :: start + type(vector2_type), intent(in), value :: end + type(color_type) , intent(in), value :: color + end subroutine image_draw_line_v + + ! void ImageDrawPixel(Image *dst, int posX, int posY, Color color) + subroutine image_draw_pixel(dst, pos_x, pos_y, color) bind(c, name='ImageDrawPixel') + import :: c_int, color_type, image_type + implicit none + type(image_type), intent(inout) :: dst + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + type(color_type), intent(in), value :: color + end subroutine image_draw_pixel + + ! void ImageDrawPixelV(Image *dst, Vector2 position, Color color) + subroutine image_draw_pixel_v(dst, position, color) bind(c, name='ImageDrawPixelV') + import :: color_type, image_type, vector2_type + implicit none + type(image_type), intent(inout) :: dst + type(vector2_type), intent(in), value :: position + type(color_type), intent(in), value :: color + end subroutine image_draw_pixel_v + + ! void ImageDrawRectangle(Image *dst, int posX, int posY, int width, int height, Color color) + subroutine image_draw_rectangle(dst, pos_x, pos_y, width, height, color) bind(c, name='ImageDrawRectangle') + import :: c_int, color_type, image_type + implicit none + type(image_type), intent(inout) :: dst + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(color_type), intent(in), value :: color + end subroutine image_draw_rectangle + + ! void ImageDrawRectangleLines(Image *dst, Rectangle rec, int thick, Color color) + subroutine image_draw_rectangle_lines(dst, rec, thick, color) bind(c, name='ImageDrawRectangleLines') + import :: c_int, color_type, image_type, rectangle_type + implicit none + type(image_type), intent(inout) :: dst + type(rectangle_type), intent(in), value :: rec + integer(kind=c_int), intent(in), value :: thick + type(color_type), intent(in), value :: color + end subroutine image_draw_rectangle_lines + + ! void ImageDrawRectangleRec(Image *dst, Rectangle rec, Color color) + subroutine image_draw_rectangle_rec(dst, rec, color) bind(c, name='ImageDrawRectangleRec') + import :: color_type, image_type, rectangle_type + implicit none + type(image_type), intent(inout) :: dst + type(rectangle_type), intent(in), value :: rec + type(color_type), intent(in), value :: color + end subroutine image_draw_rectangle_rec + + ! void ImageDrawRectangleV(Image *dst, Vector2 position, Vector2 size, Color color) + subroutine image_draw_rectangle_v(dst, position, size, color) bind(c, name='ImageDrawRectangleV') + import :: color_type, image_type, vector2_type + implicit none + type(image_type), intent(inout) :: dst + type(vector2_type), intent(in), value :: position + type(vector2_type), intent(in), value :: size + type(color_type), intent(in), value :: color + end subroutine image_draw_rectangle_v + + ! void ImageDrawText(Image *dst, const char *text, int posX, int posY, int fontSize, Color color) + subroutine image_draw_text(dst, text, pos_x, pos_y, font_size, color) bind(c, name='ImageDrawText') + import :: c_char, c_int, color_type, image_type + implicit none + type(image_type), intent(inout) :: dst + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(in), value :: pos_x + integer(kind=c_int), intent(in), value :: pos_y + integer(kind=c_int), intent(in), value :: font_size + type(color_type), intent(in), value :: color + end subroutine image_draw_text + + ! void ImageDrawTextEx(Image *dst, Font font, const char *text, Vector2 position, float fontSize, float spacing, Color tint) + subroutine image_draw_text_ex(dst, font, text, position, font_size, spacing, tint) bind(c, name='ImageDrawTextEx') + import :: c_char, c_float, color_type, font_type, image_type, vector2_type + implicit none + type(image_type), intent(inout) :: dst + type(font_type), intent(in), value :: font + character(kind=c_char), intent(in) :: text + type(vector2_type), intent(in), value :: position + real(kind=c_float), intent(in), value :: font_size + real(kind=c_float), intent(in), value :: spacing + type(color_type), intent(in), value :: tint + end subroutine image_draw_text_ex + + ! void ImageFlipHorizontal(Image *image) + subroutine image_flip_horizontal(image) bind(c, name='ImageFlipHorizontal') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_flip_horizontal + + ! void ImageFlipVertical(Image *image) + subroutine image_flip_vertical(image) bind(c, name='ImageFlipVertical') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_flip_vertical + + ! void ImageFormat(Image *image, int newFormat) + subroutine image_format(image, new_format) bind(c, name='ImageFormat') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: new_format + end subroutine image_format + + ! Image ImageFromImage(Image image, Rectangle rec) + function image_from_image(image, rec) bind(c, name='ImageFromImage') + import :: image_type, rectangle_type + implicit none + type(image_type), intent(in), value :: image + type(rectangle_type), intent(in), value :: rec + type(image_type) :: image_from_image + end function image_from_image + + ! void ImageKernelConvolution(Image *image, float *kernel, int kernelSize) + subroutine image_kernel_convolution(image, kernel, kernel_size) bind(c, name='ImageKernelConvolution') + import :: c_float, c_int, image_type + implicit none + type(image_type), intent(inout) :: image + real(kind=c_float), intent(inout) :: kernel + integer(kind=c_int), intent(in), value :: kernel_size + end subroutine image_kernel_convolution + + ! void ImageMipmaps(Image *image) + subroutine image_mipmaps(image) bind(c, name='ImageMipmaps') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_mipmaps + + ! void ImageResize(Image *image, int newWidth, int newHeight) + subroutine image_resize(image, new_width, new_height) bind(c, name='ImageResize') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: new_width + integer(kind=c_int), intent(in), value :: new_height + end subroutine image_resize + + ! void ImageResizeCanvas(Image *image, int newWidth, int newHeight, int offsetX, int offsetY, Color fill) + subroutine image_resize_canvas(image, new_width, new_height, offset_x, offset_y, fill) bind(c, name='ImageResizeCanvas') + import :: c_int, color_type, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: new_width + integer(kind=c_int), intent(in), value :: new_height + integer(kind=c_int), intent(in), value :: offset_x + integer(kind=c_int), intent(in), value :: offset_y + type(color_type), intent(in), value :: fill + end subroutine image_resize_canvas + + ! void ImageResizeNN(Image *image, int newWidth,int newHeight) + subroutine image_resize_nn(image, new_width, new_height) bind(c, name='ImageResizeNN') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: new_width + integer(kind=c_int), intent(in), value :: new_height + end subroutine image_resize_nn + + ! void ImageRotate(Image *image, int degrees) + subroutine image_rotate(image, degrees) bind(c, name='ImageRotate') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: image + integer(kind=c_int), intent(in), value :: degrees + end subroutine image_rotate + + ! void ImageRotateCCW(Image *image) + subroutine image_rotate_ccw(image) bind(c, name='ImageRotateCCW') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_rotate_ccw + + ! void ImageRotateCW(Image *image) + subroutine image_rotate_cw(image) bind(c, name='ImageRotateCW') + import :: image_type + implicit none + type(image_type), intent(inout) :: image + end subroutine image_rotate_cw + + ! Image ImageText(const char *text, int fontSize, Color color) + function image_text(text, font_size, color) bind(c, name='ImageText') + import :: c_char, c_int, color_type, image_type + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(in), value :: font_size + type(color_type), intent(in), value :: color + type(image_type) :: image_text + end function image_text + + ! Image ImageTextEx(Font font, const char *text, float fontSize, float spacing, Color tint) + function image_text_ex(font, text, font_size, spacing, tint) bind(c, name='ImageTextEx') + import :: c_char, c_float, color_type, font_type, image_type + implicit none + type(font_type), intent(in), value :: font + character(kind=c_char), intent(in) :: text + real(kind=c_float), intent(in), value :: font_size + real(kind=c_float), intent(in), value :: spacing + type(color_type), intent(in), value :: tint + type(image_type) :: image_text_ex + end function image_text_ex + + ! void ImageToPOT(Image *image, Color fill) + subroutine image_to_pot(image, fill) bind(c, name='ImageToPOT') + import :: color_type, image_type + implicit none + type(image_type), intent(inout) :: image + type(color_type), intent(in), value :: fill + end subroutine image_to_pot + + ! void InitAudioDevice(void) + subroutine init_audio_device() bind(c, name='InitAudioDevice') + end subroutine init_audio_device + + ! void InitWindow(int width, int height, const char *title) + subroutine init_window(width, height, title) bind(c, name='InitWindow') + import :: c_char, c_int + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + character(kind=c_char), intent(in) :: title + end subroutine init_window + + ! bool IsAudioDeviceReady(void) + function is_audio_device_ready() bind(c, name='IsAudioDeviceReady') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_audio_device_ready + end function is_audio_device_ready + + ! bool IsAudioStreamPlaying(AudioStream stream) + function is_audio_stream_playing(stream) bind(c, name='IsAudioStreamPlaying') + import :: audio_stream_type, c_bool + implicit none + type(audio_stream_type), intent(in), value :: stream + logical(kind=c_bool) :: is_audio_stream_playing + end function is_audio_stream_playing + + ! bool IsAudioStreamProcessed(AudioStream stream) + function is_audio_stream_processed(stream) bind(c, name='IsAudioStreamProcessed') + import :: audio_stream_type, c_bool + implicit none + type(audio_stream_type), intent(in), value :: stream + logical(kind=c_bool) :: is_audio_stream_processed + end function is_audio_stream_processed + + ! bool IsAudioStreamReady(AudioStream stream) + function is_audio_stream_ready(stream) bind(c, name='IsAudioStreamReady') + import :: audio_stream_type, c_bool + implicit none + type(audio_stream_type), intent(in), value :: stream + logical(kind=c_bool) :: is_audio_stream_ready + end function is_audio_stream_ready + + ! bool IsCursorHidden(void) + function is_cursor_hidden() bind(c, name='IsCursorHidden') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_cursor_hidden + end function is_cursor_hidden + + ! bool IsCursorOnScreen(void) + function is_cursor_on_screen() bind(c, name='IsCursorOnScreen') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_cursor_on_screen + end function is_cursor_on_screen + + ! bool IsFileDropped(void) + function is_file_dropped() bind(c, name='IsFileDropped') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_file_dropped + end function is_file_dropped + + ! bool IsFileExtension(const char *fileName, const char *ext) + function is_file_extension(file_name, ext) bind(c, name='IsFileExtension') + import :: c_bool, c_char + implicit none + character(kind=c_char), intent(in) :: file_name + character(kind=c_char), intent(in) :: ext + logical(kind=c_bool) :: is_file_extension + end function is_file_extension + + ! bool IsFontReady(Font font) + function is_font_ready(font) bind(c, name='IsFontReady') + import :: c_bool, font_type + implicit none + type(font_type), intent(in), value :: font + logical(kind=c_bool) :: is_font_ready + end function is_font_ready + + ! bool IsGamepadAvailable(int gamepad) + function is_gamepad_available(gamepad) bind(c, name='IsGamepadAvailable') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: gamepad + logical(kind=c_bool) :: is_gamepad_available + end function is_gamepad_available + + ! bool IsGamepadButtonDown(int gamepad, int button) + function is_gamepad_button_down(gamepad, button) bind(c, name='IsGamepadButtonDown') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: gamepad + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_gamepad_button_down + end function is_gamepad_button_down + + ! bool IsGamepadButtonPressed(int gamepad, int button) + function is_gamepad_button_pressed(gamepad, button) bind(c, name='IsGamepadButtonPressed') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: gamepad + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_gamepad_button_pressed + end function is_gamepad_button_pressed + + ! bool IsGamepadButtonReleased(int gamepad, int button) + function is_gamepad_button_released(gamepad, button) bind(c, name='IsGamepadButtonReleased') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: gamepad + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_gamepad_button_released + end function is_gamepad_button_released + + ! bool IsGamepadButtonUp(int gamepad, int button) + function is_gamepad_button_up(gamepad, button) bind(c, name='IsGamepadButtonUp') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: gamepad + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_gamepad_button_up + end function is_gamepad_button_up + + ! bool IsGestureDetected(unsigned int gesture) + function is_gesture_detected(gesture) bind(c, name='IsGestureDetected') + import :: c_bool, c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: gesture + logical(kind=c_bool) :: is_gesture_detected + end function is_gesture_detected + + ! bool IsImageReady(Image image) + function is_image_ready(image) bind(c, name='IsImageReady') + import :: c_bool, image_type + implicit none + type(image_type), intent(in), value :: image + logical(kind=c_bool) :: is_image_ready + end function is_image_ready + + ! bool IsKeyDown(int key) + function is_key_down(key) bind(c, name='IsKeyDown') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: key + logical(kind=c_bool) :: is_key_down + end function is_key_down + + ! bool IsKeyPressed(int key) + function is_key_pressed(key) bind(c, name='IsKeyPressed') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: key + logical(kind=c_bool) :: is_key_pressed + end function is_key_pressed + + ! bool IsKeyPressedRepeat(int key) + function is_key_pressed_repeat(key) bind(c, name='IsKeyPressedRepeat') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: key + logical(kind=c_bool) :: is_key_pressed_repeat + end function is_key_pressed_repeat + + ! bool IsKeyReleased(int key) + function is_key_released(key) bind(c, name='IsKeyReleased') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: key + logical(kind=c_bool) :: is_key_released + end function is_key_released + + ! bool IsKeyUp(int key) + function is_key_up(key) bind(c, name='IsKeyUp') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: key + logical(kind=c_bool) :: is_key_up + end function is_key_up + + ! bool IsMaterialReady(Material material) + function is_material_ready(material) bind(c, name='IsMaterialReady') + import :: c_bool, material_type + implicit none + type(material_type), intent(in), value :: material + logical(kind=c_bool) :: is_material_ready + end function is_material_ready + + ! bool IsModelAnimationValid(Model model, ModelAnimation anim) + function is_model_animation_valid(model, anim) bind(c, name='IsModelAnimationValid') + import :: c_bool, model_animation_type, model_type + implicit none + type(model_type), intent(in), value :: model + type(model_animation_type), intent(in), value :: anim + logical(kind=c_bool) :: is_model_animation_valid + end function is_model_animation_valid + + ! bool IsModelReady(Model model) + function is_model_ready(model) bind(c, name='IsModelReady') + import :: c_bool, model_type + implicit none + type(model_type), intent(in), value :: model + logical(kind=c_bool) :: is_model_ready + end function is_model_ready + + ! bool IsMouseButtonDown(int button) + function is_mouse_button_down(button) bind(c, name='IsMouseButtonDown') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_mouse_button_down + end function is_mouse_button_down + + ! bool IsMouseButtonPressed(int button) + function is_mouse_button_pressed(button) bind(c, name='IsMouseButtonPressed') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_mouse_button_pressed + end function is_mouse_button_pressed + + ! bool IsMouseButtonReleased(int button) + function is_mouse_button_released(button) bind(c, name='IsMouseButtonReleased') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_mouse_button_released + end function is_mouse_button_released + + ! bool IsMouseButtonUp(int button) + function is_mouse_button_up(button) bind(c, name='IsMouseButtonUp') + import :: c_bool, c_int + implicit none + integer(kind=c_int), intent(in), value :: button + logical(kind=c_bool) :: is_mouse_button_up + end function is_mouse_button_up + + ! bool IsMusicReady(Music music) + function is_music_ready(music) bind(c, name='IsMusicReady') + import :: c_bool, music_type + implicit none + type(music_type), intent(in), value :: music + logical(kind=c_bool) :: is_music_ready + end function is_music_ready + + ! bool IsMusicStreamPlaying(Music music) + function is_music_stream_playing(music) bind(c, name='IsMusicStreamPlaying') + import :: c_bool, music_type + implicit none + type(music_type), intent(in), value :: music + logical(kind=c_bool) :: is_music_stream_playing + end function is_music_stream_playing + + ! bool IsPathFile(const char *path) + function is_path_file(path) bind(c, name='IsPathFile') + import :: c_bool, c_char + implicit none + character(kind=c_char), intent(in) :: path + logical(kind=c_bool) :: is_path_file + end function is_path_file + + ! bool IsRenderTextureReady(RenderTexture2D target) + function is_render_texture_ready(target) bind(c, name='IsRenderTextureReady') + import :: c_bool, render_texture2d_type + implicit none + type(render_texture2d_type), intent(in), value :: target + logical(kind=c_bool) :: is_render_texture_ready + end function is_render_texture_ready + + ! bool IsShaderReady(Shader shader) + function is_shader_ready(shader) bind(c, name='IsShaderReady') + import :: c_bool, shader_type + implicit none + type(shader_type), intent(in), value :: shader + logical(kind=c_bool) :: is_shader_ready + end function is_shader_ready + + ! bool IsSoundPlaying(Sound sound) + function is_sound_playing(sound) bind(c, name='IsSoundPlaying') + import :: c_bool, sound_type + implicit none + type(sound_type), intent(in), value :: sound + logical(kind=c_bool) :: is_sound_playing + end function is_sound_playing + + ! bool IsSoundReady(Sound sound) + function is_sound_ready(sound) bind(c, name='IsSoundReady') + import :: c_bool, sound_type + implicit none + type(sound_type), intent(in), value :: sound + logical(kind=c_bool) :: is_sound_ready + end function is_sound_ready + + ! bool IsTextureReady(Texture2D texture) + function is_texture_ready(texture) bind(c, name='IsTextureReady') + import :: c_bool, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + logical(kind=c_bool) :: is_texture_ready + end function is_texture_ready + + ! bool IsWaveReady(Wave wave) + function is_wave_ready(wave) bind(c, name='IsWaveReady') + import :: c_bool, wave_type + implicit none + type(wave_type), intent(in), value :: wave + logical(kind=c_bool) :: is_wave_ready + end function is_wave_ready + + ! bool IsWindowFocused(void) + function is_window_focused() bind(c, name='IsWindowFocused') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_window_focused + end function is_window_focused + + ! bool IsWindowFullscreen(void) + function is_window_fullscreen() bind(c, name='IsWindowFullscreen') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_window_fullscreen + end function is_window_fullscreen + + ! bool IsWindowHidden(void) + function is_window_hidden() bind(c, name='IsWindowHidden') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_window_hidden + end function is_window_hidden + + ! bool IsWindowMaximized(void) + function is_window_maximized() bind(c, name='IsWindowMaximized') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_window_maximized + end function is_window_maximized + + ! bool IsWindowMinimized(void) + function is_window_minimized() bind(c, name='IsWindowMinimized') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_window_minimized + end function is_window_minimized + + ! bool IsWindowReady(void) + function is_window_ready() bind(c, name='IsWindowReady') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_window_ready + end function is_window_ready + + ! bool IsWindowResized(void) + function is_window_resized() bind(c, name='IsWindowResized') + import :: c_bool + implicit none + logical(kind=c_bool) :: is_window_resized + end function is_window_resized + + ! bool IsWindowState(unsigned int flag) + function is_window_state(flag) bind(c, name='IsWindowState') + import :: c_bool, c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: flag + logical(kind=c_bool) :: is_window_state + end function is_window_state + + ! AudioStream LoadAudioStream(unsigned int sampleRate, unsigned int sampleSize, unsigned int channels) + function load_audio_stream(sample_rate, sample_size, channels) bind(c, name='LoadAudioStream') + import :: audio_stream_type, c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: sample_rate + integer(kind=c_unsigned_int), intent(in), value :: sample_size + integer(kind=c_unsigned_int), intent(in), value :: channels + type(audio_stream_type) :: load_audio_stream + end function load_audio_stream + + ! int *LoadCodepoints(const char *text, int *count) + function load_codepoints(text, count) bind(c, name='LoadCodepoints') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(out) :: count + type(c_ptr) :: load_codepoints + end function load_codepoints + + ! FilePathList LoadDirectoryFiles(const char *dirPath) + function load_directory_files(dir_path) bind(c, name='LoadDirectoryFiles') + import :: c_char, file_path_list_type + implicit none + character(kind=c_char), intent(in) :: dir_path + type(file_path_list_type) :: load_directory_files + end function load_directory_files + + ! FilePathList LoadDirectoryFilesEx(const char *basePath, const char *filter, bool scanSubdirs) + function load_directory_files_ex(base_path, filter, scan_subdirs) bind(c, name='LoadDirectoryFilesEx') + import :: c_bool, c_char, file_path_list_type + implicit none + character(kind=c_char), intent(in) :: base_path + character(kind=c_char), intent(in) :: filter + logical(kind=c_bool), intent(in), value :: scan_subdirs + type(file_path_list_type) :: load_directory_files_ex + end function load_directory_files_ex + + ! FilePathList LoadDroppedFiles(void) + function load_dropped_files() bind(c, name='LoadDroppedFiles') + import :: file_path_list_type + implicit none + type(file_path_list_type) :: load_dropped_files + end function load_dropped_files + + ! unsigned char *LoadFileData(const char *fileName, int *dataSize) + function load_file_data(file_name, data_size) bind(c, name='LoadFileData') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_int), intent(out) :: data_size + type(c_ptr) :: load_file_data + end function load_file_data + + ! char *LoadFileText(const char *fileName) + function load_file_text(file_name) bind(c, name='LoadFileText') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_name + type(c_ptr) :: load_file_text + end function load_file_text + + ! Font LoadFont(const char *fileName) + function load_font(file_name) bind(c, name='LoadFont') + import :: c_char, font_type + implicit none + character(kind=c_char), intent(in) :: file_name + type(font_type) :: load_font + end function load_font + + ! GlyphInfo *LoadFontData(const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount, int type) + function load_font_data(file_data, data_size, font_size, codepoints, codepoints_count, type) & + bind(c, name='LoadFontData') + import :: c_int, c_ptr, c_unsigned_char, glyph_info_type + implicit none + integer(kind=c_unsigned_char), intent(inout) :: file_data + integer(kind=c_int), intent(in), value :: data_size + integer(kind=c_int), intent(in), value :: font_size + integer(kind=c_int), intent(inout) :: codepoints(*) + integer(kind=c_int), intent(in), value :: codepoints_count + integer(kind=c_int), intent(in), value :: type + type(c_ptr) :: load_font_data + end function load_font_data + + ! Font LoadFontEx(const char *fileName, int fontSize, int *codepoints, int codepointsCount) + function load_font_ex(file_name, font_size, codepoints, codepoints_count) bind(c, name='LoadFontEx') + import :: c_char, c_int, font_type + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_int), intent(in), value :: font_size + integer(kind=c_int), intent(inout) :: codepoints(*) + integer(kind=c_int), intent(in), value :: codepoints_count + type(font_type) :: load_font_ex + end function load_font_ex + + ! Font LoadFontFromImage(Image image, Color key, int firstChar) + function load_font_from_image(image, key, first_char) bind(c, name='LoadFontFromImage') + import :: c_int, color_type, font_type, image_type + implicit none + type(image_type), intent(in), value :: image + type(color_type), intent(in), value :: key + integer(kind=c_int), intent(in), value :: first_char + type(font_type) :: load_font_from_image + end function load_font_from_image + + ! Font LoadFontFromMemory(const char *fileType, const unsigned char *fileData, int dataSize, int fontSize, int *codepoints, int codepointsCount) + function load_font_from_memory(file_type, file_data, data_size, font_size, codepoints, codepoints_count) & + bind(c, name='LoadFontFromMemory') + import :: c_char, c_int, c_unsigned_char, font_type + implicit none + character(kind=c_char), intent(in) :: file_type + integer(kind=c_unsigned_char), intent(in) :: file_data + integer(kind=c_int), intent(in), value :: data_size + integer(kind=c_int), intent(in), value :: font_size + integer(kind=c_int), intent(inout) :: codepoints(*) + integer(kind=c_int), intent(in), value :: codepoints_count + type(font_type) :: load_font_from_memory + end function load_font_from_memory + + ! Image LoadImage(const char *fileName) + function load_image(file_name) bind(c, name='LoadImage') + import :: c_char, image_type + implicit none + character(kind=c_char), intent(in) :: file_name + type(image_type) :: load_image + end function load_image + + ! Image LoadImageAnim(const char *fileName, int *frames) + function load_image_anim(file_name, frames) bind(c, name='LoadImageAnim') + import :: c_char, c_int, image_type + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_int), intent(out) :: frames + type(image_type) :: load_image_anim + end function load_image_anim + + ! Color *LoadImageColors(Image image) + function load_image_colors(image) bind(c, name='LoadImageColors') + import :: c_ptr, image_type + implicit none + type(image_type), intent(in), value :: image + type(c_ptr) :: load_image_colors + end function load_image_colors + + ! Image LoadImageFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) + function load_image_from_memory(file_type, file_data, data_size) bind(c, name='LoadImageFromMemory') + import :: c_char, c_int, c_unsigned_char, image_type + implicit none + character(kind=c_char), intent(in) :: file_type + integer(kind=c_unsigned_char), intent(in) :: file_data + integer(kind=c_int), intent(in), value :: data_size + type(image_type) :: load_image_from_memory + end function load_image_from_memory + + ! Image LoadImageFromScreen(void) + function load_image_from_screen() bind(c, name='LoadImageFromScreen') + import :: image_type + implicit none + type(image_type) :: load_image_from_screen + end function load_image_from_screen + + ! Image LoadImageFromTexture(Texture2D texture) + function load_image_from_texture(texture) bind(c, name='LoadImageFromTexture') + import :: image_type, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(image_type) :: load_image_from_texture + end function load_image_from_texture + + ! Color *LoadImagePalette(Image image, int maxPaletteSize, int *colorCount) + function load_image_palette(image, max_palette_size, color_count) bind(c, name='LoadImagePalette') + import :: c_int, c_ptr, image_type + implicit none + type(image_type), intent(in), value :: image + integer(kind=c_int), intent(in), value :: max_palette_size + integer(kind=c_int), intent(out) :: color_count + type(c_ptr) :: load_image_palette + end function load_image_palette + + ! Image LoadImageRaw(const char *fileName, int width, int height, int format, int headerSize) + function load_image_raw(file_name, width, height, format, header_size) bind(c, name='LoadImageRaw') + import :: c_char, c_int, image_type + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + integer(kind=c_int), intent(in), value :: format + integer(kind=c_int), intent(in), value :: header_size + type(image_type) :: load_image_raw + end function load_image_raw + + ! Image LoadImageSvg(const char *fileNameOrString, int width, int height) + function load_image_svg(file_name_or_string, width, height) bind(c, name='LoadImageSvg') + import :: c_char, c_int, image_type + implicit none + character(kind=c_char), intent(in) :: file_name_or_string + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(image_type) :: load_image_svg + end function load_image_svg + + ! Material LoadMaterialDefault(void) + function load_material_default() bind(c, name='LoadMaterialDefault') + import :: material_type + implicit none + type(material_type) :: load_material_default + end function load_material_default + + ! Material *LoadMaterials(const char *fileName, int *materialCount) + function load_materials(file_name, material_count) bind(c, name='LoadMaterials') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_int), intent(out) :: material_count + type(c_ptr) :: load_materials + end function load_materials + + ! Model LoadModel(const char *fileName) + function load_model(file_name) bind(c, name='LoadModel') + import :: c_char, model_type + implicit none + character(kind=c_char), intent(in) :: file_name + type(model_type) :: load_model + end function load_model + + ! ModelAnimation *LoadModelAnimations(const char *fileName, int *animCount) + function load_model_animations(file_name, anim_count) bind(c, name='LoadModelAnimations') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_name + integer(kind=c_int), intent(out) :: anim_count + type(c_ptr) :: load_model_animations + end function load_model_animations + + ! Model LoadModelFromMesh(Mesh mesh) + function load_model_from_mesh(mesh) bind(c, name='LoadModelFromMesh') + import :: mesh_type, model_type + implicit none + type(mesh_type), intent(in), value :: mesh + type(model_type) :: load_model_from_mesh + end function load_model_from_mesh + + ! Music LoadMusicStream(const char *fileName) + function load_music_stream(file_name) bind(c, name='LoadMusicStream') + import :: c_char, music_type + implicit none + character(kind=c_char), intent(in) :: file_name + type(music_type) :: load_music_stream + end function load_music_stream + + ! Music LoadMusicStreamFromMemory(const char *fileType, const unsigned char *data, int dataSize) + function load_music_stream_from_memory(file_type, data, data_size) bind(c, name='LoadMusicStreamFromMemory') + import :: c_char, c_int, c_unsigned_char, music_type + implicit none + character(kind=c_char), intent(in) :: file_type + integer(kind=c_unsigned_char), intent(in) :: data + integer(kind=c_int), intent(in), value :: data_size + type(music_type) :: load_music_stream_from_memory + end function load_music_stream_from_memory + + ! int *LoadRandomSequence(unsigned int count, int min, int max) + function load_random_sequence(count, min, max) bind(c, name='LoadRandomSequence') + import :: c_int, c_ptr, c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: count + integer(kind=c_int), intent(in), value :: min + integer(kind=c_int), intent(in), value :: max + type(c_ptr) :: load_random_sequence + end function load_random_sequence + + ! RenderTexture2D LoadRenderTexture(int width, int height) + function load_render_texture(width, height) bind(c, name='LoadRenderTexture') + import :: c_int, render_texture2d_type + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + type(render_texture2d_type) :: load_render_texture + end function load_render_texture + + ! Shader LoadShader(const char *vsFileName, const char *fsFileName) + function load_shader(vs_file_name, fs_file_name) bind(c, name='LoadShader') + import :: c_char, shader_type + implicit none + character(kind=c_char), intent(in) :: vs_file_name + character(kind=c_char), intent(in) :: fs_file_name + type(shader_type) :: load_shader + end function load_shader + + ! Shader LoadShaderFromMemory(const char *vsCode, const char *fsCode) + function load_shader_from_memory(vs_code, fs_code) bind(c, name='LoadShaderFromMemory') + import :: c_char, shader_type + implicit none + character(kind=c_char), intent(in) :: vs_code + character(kind=c_char), intent(in) :: fs_code + type(shader_type) :: load_shader_from_memory + end function load_shader_from_memory + + ! Sound LoadSound(const char *fileName) + function load_sound(file_name) bind(c, name='LoadSound') + import :: c_char, sound_type + implicit none + character(kind=c_char), intent(in) :: file_name + type(sound_type) :: load_sound + end function load_sound + + ! Sound LoadSoundAlias(Sound source) + function load_sound_alias(source) bind(c, name='LoadSoundAlias') + import :: sound_type + implicit none + type(sound_type), intent(in), value :: source + type(sound_type) :: load_sound_alias + end function load_sound_alias + + ! Sound LoadSoundFromWave(Wave wave) + function load_sound_from_wave(wave) bind(c, name='LoadSoundFromWave') + import :: sound_type, wave_type + implicit none + type(wave_type), intent(in), value :: wave + type(sound_type) :: load_sound_from_wave + end function load_sound_from_wave + + ! Texture2D LoadTexture(const char *fileName) + function load_texture(file_name) bind(c, name='LoadTexture') + import :: c_char, texture2d_type + implicit none + character(kind=c_char), intent(in) :: file_name + type(texture2d_type) :: load_texture + end function load_texture + + ! TextureCubemap LoadTextureCubemap(Image image, int layout) + function load_texture_cubemap(image, layout) bind(c, name='LoadTextureCubemap') + import :: c_int, image_type, texture_cubemap_type + implicit none + type(image_type), intent(in), value :: image + integer(kind=c_int), intent(in), value :: layout + type(texture_cubemap_type) :: load_texture_cubemap + end function load_texture_cubemap + + ! Texture2D LoadTextureFromImage(Image image) + function load_texture_from_image(image) bind(c, name='LoadTextureFromImage') + import :: image_type, texture2d_type + implicit none + type(image_type), intent(in), value :: image + type(texture2d_type) :: load_texture_from_image + end function load_texture_from_image + + ! char *LoadUTF8(const int *codepoints, int length) + function load_utf8(codepoints, length) bind(c, name='LoadUTF8') + import :: c_int, c_ptr + implicit none + integer(kind=c_int), intent(out) :: codepoints(*) + integer(kind=c_int), intent(in), value :: length + type(c_ptr) :: load_utf8 + end function load_utf8 + + ! VrStereoConfig LoadVrStereoConfig(VrDeviceInfo device) + function load_vr_stereo_config(device) bind(c, name='LoadVrStereoConfig') + import :: vr_device_info_type, vr_stereo_config_type + implicit none + type(vr_device_info_type), intent(in), value :: device + type(vr_stereo_config_type) :: load_vr_stereo_config + end function load_vr_stereo_config + + ! Wave LoadWave(const char *fileName) + function load_wave(file_name) bind(c, name='LoadWave') + import :: c_char, wave_type + implicit none + character(kind=c_char), intent(in) :: file_name + type(wave_type) :: load_wave + end function load_wave + + ! Wave LoadWaveFromMemory(const char *fileType, const unsigned char *fileData, int dataSize) + function load_wave_from_memory(file_type, file_data, data_size) bind(c, name='LoadWaveFromMemory') + import :: c_char, c_int, c_unsigned_char, wave_type + implicit none + character(kind=c_char), intent(in) :: file_type + integer(kind=c_unsigned_char), intent(in) :: file_data + integer(kind=c_int), intent(in), value :: data_size + type(wave_type) :: load_wave_from_memory + end function load_wave_from_memory + + ! float *LoadWaveSamples(Wave wave) + function load_wave_samples(wave) bind(c, name='LoadWaveSamples') + import :: c_ptr, wave_type + implicit none + type(wave_type), intent(in), value :: wave + type(c_ptr) :: load_wave_samples + end function load_wave_samples + + ! void MaximizeWindow(void) + subroutine maximize_window() bind(c, name='MaximizeWindow') + end subroutine maximize_window + + ! int MeasureText(const char *text, int fontSize) + function measure_text(text, font_size) bind(c, name='MeasureText') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(in), value :: font_size + integer(kind=c_int) :: measure_text + end function measure_text + + ! Vector2 MeasureTextEx(Font font, const char *text, float fontSize, float spacing) + function measure_text_ex(font, text, font_size, spacing) bind(c, name='MeasureTextEx') + import :: c_char, c_float, font_type, vector2_type + implicit none + type(font_type), intent(in), value :: font + character(kind=c_char), intent(in) :: text + real(kind=c_float), intent(in), value :: font_size + real(kind=c_float), intent(in), value :: spacing + type(vector2_type) :: measure_text_ex + end function measure_text_ex + + ! void *MemAlloc(unsigned int size) + function mem_alloc(size) bind(c, name='MemAlloc') + import :: c_ptr, c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: size + type(c_ptr) :: mem_alloc + end function mem_alloc + + ! void MemFree(void *ptr) + subroutine mem_free(ptr) bind(c, name='MemFree') + import :: c_ptr + implicit none + type(c_ptr), intent(in), value :: ptr + end subroutine mem_free + + ! void *MemRealloc(void *ptr, unsigned int size) + function mem_realloc(ptr, size) bind(c, name='MemRealloc') + import :: c_ptr, c_unsigned_int + implicit none + type(c_ptr), intent(in), value :: ptr + integer(kind=c_unsigned_int), intent(in), value :: size + type(c_ptr) :: mem_realloc + end function mem_realloc + + ! void MinimizeWindow(void) + subroutine minimize_window() bind(c, name='MinimizeWindow') + end subroutine minimize_window + + ! void OpenURL(const char *url) + subroutine open_url(url) bind(c, name='OpenURL') + import :: c_char + implicit none + character(kind=c_char), intent(in) :: url + end subroutine open_url + + ! void PauseAudioStream(AudioStream stream) + subroutine pause_audio_stream(stream) bind(c, name='PauseAudioStream') + import :: audio_stream_type + implicit none + type(audio_stream_type), intent(in), value :: stream + end subroutine pause_audio_stream + + ! void PauseMusicStream(Music music) + subroutine pause_music_stream(music) bind(c, name='PauseMusicStream') + import :: music_type + implicit none + type(music_type), intent(in), value :: music + end subroutine pause_music_stream + + ! void PauseSound(Sound sound) + subroutine pause_sound(sound) bind(c, name='PauseSound') + import :: sound_type + implicit none + type(sound_type), intent(in), value :: sound + end subroutine pause_sound + + ! void PlayAudioStream(AudioStream stream) + subroutine play_audio_stream(stream) bind(c, name='PlayAudioStream') + import :: audio_stream_type + implicit none + type(audio_stream_type), intent(in), value :: stream + end subroutine play_audio_stream + + ! void PlayMusicStream(Music music) + subroutine play_music_stream(music) bind(c, name='PlayMusicStream') + import :: music_type + implicit none + type(music_type), intent(in), value :: music + end subroutine play_music_stream + + ! void PlaySound(Sound sound) + subroutine play_sound(sound) bind(c, name='PlaySound') + import :: sound_type + implicit none + type(sound_type), intent(in), value :: sound + end subroutine play_sound + + ! void PollInputEvents(void) + subroutine poll_input_events() bind(c, name='PollInputEvents') + end subroutine poll_input_events + + ! void RestoreWindow(void) + subroutine restore_window() bind(c, name='RestoreWindow') + end subroutine restore_window + + ! void ResumeAudioStream(AudioStream stream) + subroutine resume_audio_stream(stream) bind(c, name='ResumeAudioStream') + import :: audio_stream_type + implicit none + type(audio_stream_type), intent(in), value :: stream + end subroutine resume_audio_stream + + ! void ResumeMusicStream(Music music) + subroutine resume_music_stream(music) bind(c, name='ResumeMusicStream') + import :: music_type + implicit none + type(music_type), intent(in), value :: music + end subroutine resume_music_stream + + ! void ResumeSound(Sound sound) + subroutine resume_sound(sound) bind(c, name='ResumeSound') + import :: sound_type + implicit none + type(sound_type), intent(in), value :: sound + end subroutine resume_sound + + ! bool SaveFileData(const char *fileName, void *data, int dataSize) + function save_file_data(file_name, data, data_size) bind(c, name='SaveFileData') + import :: c_bool, c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: file_name + type(c_ptr), intent(in), value :: data + integer(kind=c_int), intent(in), value :: data_size + logical(kind=c_bool) :: save_file_data + end function save_file_data + + ! bool SaveFileText(const char *fileName, char *text) + function save_file_text(file_name, text) bind(c, name='SaveFileText') + import :: c_bool, c_char + implicit none + character(kind=c_char), intent(in) :: file_name + character(kind=c_char), intent(in) :: text + logical(kind=c_bool) :: save_file_text + end function save_file_text + + ! void SeekMusicStream(Music music, float position) + subroutine seek_music_stream(music, position) bind(c, name='SeekMusicStream') + import :: c_float, music_type + implicit none + type(music_type), intent(in), value :: music + real(kind=c_float), intent(in), value :: position + end subroutine seek_music_stream + + ! void SetAudioStreamBufferSizeDefault(int size) + subroutine set_audio_stream_buffer_size_default(size) bind(c, name='SetAudioStreamBufferSizeDefault') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: size + end subroutine set_audio_stream_buffer_size_default + + ! void SetAudioStreamPan(AudioStream stream, float pan) + subroutine set_audio_stream_pan(stream, pan) bind(c, name='SetAudioStreamPan') + import :: audio_stream_type, c_float + implicit none + type(audio_stream_type), intent(in), value :: stream + real(kind=c_float), intent(in), value :: pan + end subroutine set_audio_stream_pan + + ! void SetAudioStreamPitch(AudioStream stream, float pitch) + subroutine set_audio_stream_pitch(stream, pitch) bind(c, name='SetAudioStreamPitch') + import :: audio_stream_type, c_float + implicit none + type(audio_stream_type), intent(in), value :: stream + real(kind=c_float), intent(in), value :: pitch + end subroutine set_audio_stream_pitch + + ! void SetAudioStreamVolume(AudioStream stream, float volume) + subroutine set_audio_stream_volume(stream, volume) bind(c, name='SetAudioStreamVolume') + import :: audio_stream_type, c_float + implicit none + type(audio_stream_type), intent(in), value :: stream + real(kind=c_float), intent(in), value :: volume + end subroutine set_audio_stream_volume + + ! void SetCameraAltControl(int keyAlt) + subroutine set_camera_alt_control(key_alt) bind(c, name='SetCameraAltControl') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: key_alt + end subroutine set_camera_alt_control + + ! void SetCameraMode(Camera camera, int mode) + subroutine set_camera_mode(camera, mode) bind(c, name='SetCameraMode') + import :: c_int, camera3d_type + implicit none + type(camera3d_type), intent(in), value :: camera + integer(kind=c_int), intent(in), value :: mode + end subroutine set_camera_mode + + ! void SetCameraMoveControls(int keyFront, int keyBack, int keyRight, int keyLeft, int keyUp, int keyDown) + subroutine set_camera_move_controls(key_front, key_back, key_right, key_left, key_up, key_down) & + bind(c, name='SetCameraMoveControls') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: key_front + integer(kind=c_int), intent(in), value :: key_back + integer(kind=c_int), intent(in), value :: key_right + integer(kind=c_int), intent(in), value :: key_left + integer(kind=c_int), intent(in), value :: key_up + integer(kind=c_int), intent(in), value :: key_down + end subroutine set_camera_move_controls + + ! void SetCameraPanControl(int keyPan) + subroutine set_camera_pan_control(key_pan) bind(c, name='SetCameraPanControl') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: key_pan + end subroutine set_camera_pan_control + + ! void SetCameraSmoothZoomControl(int keySmoothZoom) + subroutine set_camera_smooth_zoom_control(key_smooth_zoom) bind(c, name='SetCameraSmoothZoomControl') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: key_smooth_zoom + end subroutine set_camera_smooth_zoom_control + + ! void SetClipboardText(const char *text) + subroutine set_clipboard_text(text) bind(c, name='SetClipboardText') + import :: c_char + implicit none + character(kind=c_char), intent(in) :: text + end subroutine set_clipboard_text + + ! void SetConfigFlags(unsigned int flags) + subroutine set_config_flags(flags) bind(c, name='SetConfigFlags') + import :: c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: flags + end subroutine set_config_flags + + ! void SetExitKey(int key) + subroutine set_exit_key(key) bind(c, name='SetExitKey') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: key + end subroutine set_exit_key + + ! int SetGamepadMappings(const char *mappings) + function set_gamepad_mappings(mappings) bind(c, name='SetGamepadMappings') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: mappings + integer(kind=c_int) :: set_gamepad_mappings + end function set_gamepad_mappings + + ! void SetGesturesEnabled(unsigned int flags) + subroutine set_gestures_enabled(flags) bind(c, name='SetGesturesEnabled') + import :: c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: flags + end subroutine set_gestures_enabled + + ! void SetLoadFileDataCallback(LoadFileDataCallback callback) + subroutine set_load_file_data_callback(callback) bind(c, name='SetLoadFileDataCallback') + import :: c_funptr + implicit none + type(c_funptr), intent(in), value :: callback + end subroutine set_load_file_data_callback + + ! void SetLoadFileTextCallback(LoadFileTextCallback callback) + subroutine set_load_file_text_callback(callback) bind(c, name='SetLoadFileTextCallback') + import :: c_funptr + implicit none + type(c_funptr), intent(in), value :: callback + end subroutine set_load_file_text_callback + + ! void SetMasterVolume(float volume) + subroutine set_master_volume(volume) bind(c, name='SetMasterVolume') + import :: c_float + implicit none + real(kind=c_float), intent(in), value :: volume + end subroutine set_master_volume + + ! void SetMaterialTexture(Material *material, int mapType, Texture2D texture) + subroutine set_material_texture(material, map_type, texture) bind(c, name='SetMaterialTexture') + import :: c_int, material_type, texture2d_type + implicit none + type(material_type), intent(inout) :: material + integer(kind=c_int), intent(in), value :: map_type + type(texture2d_type), intent(in), value :: texture + end subroutine set_material_texture + + ! void SetModelMeshMaterial(Model *model, int meshId, int materialId) + subroutine set_model_mesh_material(model, mesh_id, material_id) bind(c, name='SetModelMeshMaterial') + import :: c_int, model_type + implicit none + type(model_type), intent(inout) :: model + integer(kind=c_int), intent(in), value :: mesh_id + integer(kind=c_int), intent(in), value :: material_id + end subroutine set_model_mesh_material + + ! void SetMouseCursor(int cursor) + subroutine set_mouse_cursor(cursor) bind(c, name='SetMouseCursor') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: cursor + end subroutine set_mouse_cursor + + ! void SetMouseOffset(int offsetX, int offsetY) + subroutine set_mouse_offset(offset_x, offset_y) bind(c, name='SetMouseOffset') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: offset_x + integer(kind=c_int), intent(in), value :: offset_y + end subroutine set_mouse_offset + + ! void SetMousePosition(int x, int y) + subroutine set_mouse_position(x, y) bind(c, name='SetMousePosition') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: x + integer(kind=c_int), intent(in), value :: y + end subroutine set_mouse_position + + ! void SetMouseScale(float scaleX, float scaleY) + subroutine set_mouse_scale(scale_x, scale_y) bind(c, name='SetMouseScale') + import :: c_float + implicit none + real(kind=c_float), intent(in), value :: scale_x + real(kind=c_float), intent(in), value :: scale_y + end subroutine set_mouse_scale + + ! void SetMusicPan(Music music, float pan) + subroutine set_music_pan(music, pan) bind(c, name='SetMusicPan') + import :: c_float, music_type + implicit none + type(music_type), intent(in), value :: music + real(kind=c_float), intent(in), value :: pan + end subroutine set_music_pan + + ! void SetMusicPitch(Music music, float pitch) + subroutine set_music_pitch(music, pitch) bind(c, name='SetMusicPitch') + import :: c_float, music_type + implicit none + type(music_type), intent(in), value :: music + real(kind=c_float), intent(in), value :: pitch + end subroutine set_music_pitch + + ! void SetMusicVolume(Music music, float volume) + subroutine set_music_volume(music, volume) bind(c, name='SetMusicVolume') + import :: c_float, music_type + implicit none + type(music_type), intent(in), value :: music + real(kind=c_float), intent(in), value :: volume + end subroutine set_music_volume + + ! void SetPixelColor(void *dstPtr, Color color, int format) + subroutine set_pixel_color(dst_ptr, color, format) bind(c, name='SetPixelColor') + import :: c_int, c_ptr, color_type + implicit none + type(c_ptr), intent(in), value :: dst_ptr + type(color_type), intent(in), value :: color + integer(kind=c_int), intent(in), value :: format + end subroutine set_pixel_color + + ! void SetRandomSeed(unsigned int seed) + subroutine set_random_seed(seed) bind(c, name='SetRandomSeed') + import :: c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: seed + end subroutine set_random_seed + + ! void SetSaveFileDataCallback(SaveFileDataCallback callback) + subroutine set_save_file_data_callback(callback) bind(c, name='SetSaveFileDataCallback') + import :: c_funptr + implicit none + type(c_funptr), intent(in), value :: callback + end subroutine set_save_file_data_callback + + ! void SetSaveFileTextCallback(SaveFileTextCallback callback) + subroutine set_save_file_text_callback(callback) bind(c, name='SetSaveFileTextCallback') + import :: c_funptr + implicit none + type(c_funptr), intent(in), value :: callback + end subroutine set_save_file_text_callback + + ! void SetShaderValue(Shader shader, int locIndex, const void *value, int uniformType) + subroutine set_shader_value(shader, loc_index, value, uniform_type) bind(c, name='SetShaderValue') + import :: c_int, c_ptr, shader_type + implicit none + type(shader_type), intent(in), value :: shader + integer(kind=c_int), intent(in), value :: loc_index + type(c_ptr), intent(in), value :: value + integer(kind=c_int), intent(in), value :: uniform_type + end subroutine set_shader_value + + ! void SetShaderValueMatrix(Shader shader, int locIndex, Matrix mat) + subroutine set_shader_value_matrix(shader, loc_index, mat) bind(c, name='SetShaderValueMatrix') + import :: c_int, matrix_type, shader_type + implicit none + type(shader_type), intent(in), value :: shader + integer(kind=c_int), intent(in), value :: loc_index + type(matrix_type), intent(in), value :: mat + end subroutine set_shader_value_matrix + + ! void SetShaderValueTexture(Shader shader, int locIndex, Texture2D texture) + subroutine set_shader_value_texture(shader, loc_index, texture) bind(c, name='SetShaderValueTexture') + import :: c_int, shader_type, texture2d_type + implicit none + type(shader_type), intent(in), value :: shader + integer(kind=c_int), intent(in), value :: loc_index + type(texture2d_type), intent(in), value :: texture + end subroutine set_shader_value_texture + + ! void SetShaderValueV(Shader shader, int locIndex, const void *value, int uniformType, int count) + subroutine set_shader_value_v(shader, loc_index, value, uniform_type, count) bind(c, name='SetShaderValueV') + import :: c_int, c_ptr, shader_type + implicit none + type(shader_type), intent(in), value :: shader + integer(kind=c_int), intent(in), value :: loc_index + type(c_ptr), intent(in), value :: value + integer(kind=c_int), intent(in), value :: uniform_type + integer(kind=c_int), intent(in), value :: count + end subroutine set_shader_value_v + + ! void SetShapesTexture(Texture2D texture, Rectangle source) + subroutine set_shapes_texture(texture, source) bind(c, name='SetShapesTexture') + import :: rectangle_type, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(rectangle_type), intent(in), value :: source + end subroutine set_shapes_texture + + ! void SetSoundPan(Sound sound, float pan) + subroutine set_sound_pan(sound, pan) bind(c, name='SetSoundPan') + import :: c_float, sound_type + implicit none + type(sound_type), intent(in), value :: sound + real(kind=c_float), intent(in), value :: pan + end subroutine set_sound_pan + + ! void SetSoundPitch(Sound sound, float pitch) + subroutine set_sound_pitch(sound, pitch) bind(c, name='SetSoundPitch') + import :: c_float, sound_type + implicit none + type(sound_type), intent(in), value :: sound + real(kind=c_float), intent(in), value :: pitch + end subroutine set_sound_pitch + + ! void SetSoundVolume(Sound sound, float volume) + subroutine set_sound_volume(sound, volume) bind(c, name='SetSoundVolume') + import :: c_float, sound_type + implicit none + type(sound_type), intent(in), value :: sound + real(kind=c_float), intent(in), value :: volume + end subroutine set_sound_volume + + ! void SetTargetFPS(int fps) + subroutine set_target_fps(fps) bind(c, name='SetTargetFPS') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: fps + end subroutine set_target_fps + + ! void SetTextLineSpacing(int spacing) + subroutine set_text_line_spacing(spacing) bind(c, name='SetTextLineSpacing') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: spacing + end subroutine set_text_line_spacing + + ! void SetTextureFilter(Texture2D texture, int filter) + subroutine set_texture_filter(texture, filter) bind(c, name='SetTextureFilter') + import :: c_int, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + integer(kind=c_int), intent(in), value :: filter + end subroutine set_texture_filter + + ! void SetTextureWrap(Texture2D texture, int wrap) + subroutine set_texture_wrap(texture, wrap) bind(c, name='SetTextureWrap') + import :: c_int, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + integer(kind=c_int), intent(in), value :: wrap + end subroutine set_texture_wrap + + ! void SetTraceLogCallback(TraceLogCallback callback) + subroutine set_trace_log_callback(callback) bind(c, name='SetTraceLogCallback') + import :: c_funptr + implicit none + type(c_funptr), intent(in), value :: callback + end subroutine set_trace_log_callback + + ! void SetTraceLogLevel(int logLevel) + subroutine set_trace_log_level(log_level) bind(c, name='SetTraceLogLevel') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: log_level + end subroutine set_trace_log_level + + ! void SetWindowFocused(void) + subroutine set_window_focused() bind(c, name='SetWindowFocused') + end subroutine set_window_focused + + ! void SetWindowIcon(Image image) + subroutine set_window_icon(image) bind(c, name='SetWindowIcon') + import :: image_type + implicit none + type(image_type), intent(in), value :: image + end subroutine set_window_icon + + ! void SetWindowIcons(Image *images, int count) + subroutine set_window_icons(images, count) bind(c, name='SetWindowIcons') + import :: c_int, image_type + implicit none + type(image_type), intent(inout) :: images + integer(kind=c_int), intent(in), value :: count + end subroutine set_window_icons + + ! void SetWindowMaxSize(int width, int height) + subroutine set_window_max_size(width, height) bind(c, name='SetWindowMaxSize') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + end subroutine set_window_max_size + + ! void SetWindowMinSize(int width, int height) + subroutine set_window_min_size(width, height) bind(c, name='SetWindowMinSize') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + end subroutine set_window_min_size + + ! void SetWindowMonitor(int monitor) + subroutine set_window_monitor(monitor) bind(c, name='SetWindowMonitor') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: monitor + end subroutine set_window_monitor + + ! void SetWindowOpacity(float opacity) + subroutine set_window_opacity(opacity) bind(c, name='SetWindowOpacity') + import :: c_float + implicit none + real(kind=c_float), intent(in), value :: opacity + end subroutine set_window_opacity + + ! void SetWindowPosition(int x, int y) + subroutine set_window_position(x, y) bind(c, name='SetWindowPosition') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: x + integer(kind=c_int), intent(in), value :: y + end subroutine set_window_position + + ! void SetWindowSize(int width, int height) + subroutine set_window_size(width, height) bind(c, name='SetWindowSize') + import :: c_int + implicit none + integer(kind=c_int), intent(in), value :: width + integer(kind=c_int), intent(in), value :: height + end subroutine set_window_size + + ! void SetWindowState(unsigned int flags) + subroutine set_window_state(flags) bind(c, name='SetWindowState') + import :: c_unsigned_int + implicit none + integer(kind=c_unsigned_int), intent(in), value :: flags + end subroutine set_window_state + + ! void SetWindowTitle(const char *title) + subroutine set_window_title(title) bind(c, name='SetWindowTitle') + import :: c_char + implicit none + character(kind=c_char), intent(in) :: title + end subroutine set_window_title + + ! void ShowCursor(void) + subroutine show_cursor() bind(c, name='ShowCursor') + end subroutine show_cursor + + ! void StopAudioStream(AudioStream stream) + subroutine stop_audio_stream(stream) bind(c, name='StopAudioStream') + import :: audio_stream_type + implicit none + type(audio_stream_type), intent(in), value :: stream + end subroutine stop_audio_stream + + ! void StopMusicStream(Music music) + subroutine stop_music_stream(music) bind(c, name='StopMusicStream') + import :: music_type + implicit none + type(music_type), intent(in), value :: music + end subroutine stop_music_stream + + ! void StopSound(Sound sound) + subroutine stop_sound(sound) bind(c, name='StopSound') + import :: sound_type + implicit none + type(sound_type), intent(in), value :: sound + end subroutine stop_sound + + ! void SwapScreenBuffer(void) + subroutine swap_screen_buffer() bind(c, name='SwapScreenBuffer') + end subroutine swap_screen_buffer + + ! void TakeScreenshot(const char *fileName) + subroutine take_screenshot(file_name) bind(c, name='TakeScreenshot') + import :: c_char + implicit none + character(kind=c_char), intent(in) :: file_name + end subroutine take_screenshot + + ! void TextAppend(char *text, const char *append, int *position) + subroutine text_append(text, append, position) bind(c, name='TextAppend') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + character(kind=c_char), intent(in) :: append + integer(kind=c_int), intent(in) :: position + end subroutine text_append + + ! int TextCopy(char *dst, const char *src) + function text_copy(dst, src) bind(c, name='TextCopy') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: dst + character(kind=c_char), intent(in) :: src + integer(kind=c_int) :: text_copy + end function text_copy + + ! int TextFindIndex(const char *text, const char *find) + function text_find_index(text, find) bind(c, name='TextFindIndex') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + character(kind=c_char), intent(in) :: find + integer(kind=c_int) :: text_find_index + end function text_find_index + + ! char *TextInsert(const char *text, const char *insert, int position) + function text_insert(text, insert, position) bind(c, name='TextInsert') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + character(kind=c_char), intent(in) :: insert + integer(kind=c_int), intent(in), value :: position + type(c_ptr) :: text_insert + end function text_insert + + ! bool TextIsEqual(const char *text1, const char *text2) + function text_is_equal(text1, text2) bind(c, name='TextIsEqual') + import :: c_bool, c_char + implicit none + character(kind=c_char), intent(in) :: text1 + character(kind=c_char), intent(in) :: text2 + logical(kind=c_bool) :: text_is_equal + end function text_is_equal + + ! const char *TextJoin(const char **textList, int count, const char *delimiter) + function text_join(text_list, count, delimiter) bind(c, name='TextJoin') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: text_list(*) + integer(kind=c_int), intent(in), value :: count + character(kind=c_char), intent(in) :: delimiter + type(c_ptr) :: text_join + end function text_join + + ! unsigned int TextLength(const char *text) + function text_length(text) bind(c, name='TextLength') + import :: c_char, c_unsigned_int + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_unsigned_int) :: text_length + end function text_length + + ! char *TextReplace(char *text, const char *replace, const char *by) + function text_replace(text, replace, by) bind(c, name='TextReplace') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + character(kind=c_char), intent(in) :: replace + character(kind=c_char), intent(in) :: by + type(c_ptr) :: text_replace + end function text_replace + + ! const char **TextSplit(const char *text, char delimiter, int *count) + function text_split(text, delimiter, count) bind(c, name='TextSplit') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + character(kind=c_char), intent(in), value :: delimiter + integer(kind=c_int), intent(out) :: count + type(c_ptr) :: text_split + end function text_split + + ! const char *TextSubtext(const char *text, int position, int length) + function text_subtext(text, position, length) bind(c, name='TextSubtext') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int), intent(in), value :: position + integer(kind=c_int), intent(in), value :: length + type(c_ptr) :: text_subtext + end function text_subtext + + ! int TextToInteger(const char *text) + function text_to_integer(text) bind(c, name='TextToInteger') + import :: c_char, c_int + implicit none + character(kind=c_char), intent(in) :: text + integer(kind=c_int) :: text_to_integer + end function text_to_integer + + ! const char *TextToLower(const char *text) + function text_to_lower(text) bind(c, name='TextToLower') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + type(c_ptr) :: text_to_lower + end function text_to_lower + + ! const char *TextToPascal(const char *text) + function text_to_pascal(text) bind(c, name='TextToPascal') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + type(c_ptr) :: text_to_pascal + end function text_to_pascal + + ! const char *TextToUpper(const char *text) + function text_to_upper(text) bind(c, name='TextToUpper') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: text + type(c_ptr) :: text_to_upper + end function text_to_upper + + ! void ToggleBorderlessWindowed(void) + subroutine toggle_borderless_windowed() bind(c, name='ToggleBorderlessWindowed') + end subroutine toggle_borderless_windowed + + ! void ToggleFullscreen(void) + subroutine toggle_fullscreen() bind(c, name='ToggleFullscreen') + end subroutine toggle_fullscreen + + ! void TraceLog(int logLevel, const char *text) + subroutine trace_log(log_level, text) bind(c, name='TraceLog') + import :: c_char, c_int + implicit none + integer(kind=c_int), intent(in), value :: log_level + character(kind=c_char), intent(in) :: text + end subroutine trace_log + + ! void UnloadAudioStream(AudioStream stream) + subroutine unload_audio_stream(stream) bind(c, name='UnloadAudioStream') + import :: audio_stream_type + implicit none + type(audio_stream_type), intent(in), value :: stream + end subroutine unload_audio_stream + + ! void UnloadCodepoints(int *codepoints) + subroutine unload_codepoints(codepoints) bind(c, name='UnloadCodepoints') + import :: c_int + implicit none + integer(kind=c_int), intent(inout) :: codepoints(*) + end subroutine unload_codepoints + + ! void UnloadDirectoryFiles(FilePathList files) + subroutine unload_directory_files(files) bind(c, name='UnloadDirectoryFiles') + import :: file_path_list_type + implicit none + type(file_path_list_type), intent(in), value :: files + end subroutine unload_directory_files + + ! void UnloadDroppedFiles(FilePathList files) + subroutine unload_dropped_files(files) bind(c, name='UnloadDroppedFiles') + import :: file_path_list_type + implicit none + type(file_path_list_type), intent(in), value :: files + end subroutine unload_dropped_files + + ! void UnloadFileData(unsigned char *data) + subroutine unload_file_data(data) bind(c, name='UnloadFileData') + import :: c_unsigned_char + implicit none + integer(kind=c_unsigned_char), intent(in) :: data + end subroutine unload_file_data + + ! void UnloadFileText(char *text) + subroutine unload_file_text(text) bind(c, name='UnloadFileText') + import :: c_char + implicit none + character(kind=c_char), intent(in) :: text + end subroutine unload_file_text + + ! void UnloadFont(Font font) + subroutine unload_font(font) bind(c, name='UnloadFont') + import :: font_type + implicit none + type(font_type), intent(in), value :: font + end subroutine unload_font + + ! void UnloadFontData(GlyphInfo *glyphs, int glyphCount) + subroutine unload_font_data(glyphs, glyph_count) bind(c, name='UnloadFontData') + import :: c_int, glyph_info_type + implicit none + type(glyph_info_type), intent(inout) :: glyphs + integer(kind=c_int), intent(in), value :: glyph_count + end subroutine unload_font_data + + ! void UnloadImage(Image image) + subroutine unload_image(image) bind(c, name='UnloadImage') + import :: image_type + implicit none + type(image_type), intent(in), value :: image + end subroutine unload_image + + ! void UnloadImageColors(Color *colors) + subroutine unload_image_colors(colors) bind(c, name='UnloadImageColors') + import :: color_type + implicit none + type(color_type), intent(inout) :: colors(*) + end subroutine unload_image_colors + + ! void UnloadImagePalette(Color *colors) + subroutine unload_image_palette(colors) bind(c, name='UnloadImagePalette') + import :: color_type + implicit none + type(color_type), intent(inout) :: colors(*) + end subroutine unload_image_palette + + ! void UnloadMaterial(Material material) + subroutine unload_material(material) bind(c, name='UnloadMaterial') + import :: material_type + implicit none + type(material_type), intent(in), value :: material + end subroutine unload_material + + ! void UnloadMesh(Mesh mesh) + subroutine unload_mesh(mesh) bind(c, name='UnloadMesh') + import :: mesh_type + implicit none + type(mesh_type), intent(in), value :: mesh + end subroutine unload_mesh + + ! void UnloadModel(Model model) + subroutine unload_model(model) bind(c, name='UnloadModel') + import :: model_type + implicit none + type(model_type), intent(in), value :: model + end subroutine unload_model + + ! void UnloadModelAnimation(ModelAnimation anim) + subroutine unload_model_animation(anim) bind(c, name='UnloadModelAnimation') + import :: model_animation_type + implicit none + type(model_animation_type), intent(in), value :: anim + end subroutine unload_model_animation + + ! void UnloadModelAnimations(ModelAnimation *animations, int count) + subroutine unload_model_animations(animations, count) bind(c, name='UnloadModelAnimations') + import :: c_int, model_animation_type + implicit none + type(model_animation_type), intent(inout) :: animations(*) + integer(kind=c_int), intent(in), value :: count + end subroutine unload_model_animations + + ! void UnloadMusicStream(Music music) + subroutine unload_music_stream(music) bind(c, name='UnloadMusicStream') + import :: music_type + implicit none + type(music_type), intent(in), value :: music + end subroutine unload_music_stream + + ! void UnloadRandomSequence(int *sequence) + subroutine unload_random_sequence(sequence) bind(c, name='UnloadRandomSequence') + import :: c_int + implicit none + integer(kind=c_int), intent(inout) :: sequence(*) + end subroutine unload_random_sequence + + ! void UnloadRenderTexture(RenderTexture2D target) + subroutine unload_render_texture(target) bind(c, name='UnloadRenderTexture') + import :: render_texture2d_type + implicit none + type(render_texture2d_type), intent(in), value :: target + end subroutine unload_render_texture + + ! void UnloadShader(Shader shader) + subroutine unload_shader(shader) bind(c, name='UnloadShader') + import :: shader_type + implicit none + type(shader_type), intent(in), value :: shader + end subroutine unload_shader + + ! void UnloadSound(Sound sound) + subroutine unload_sound(sound) bind(c, name='UnloadSound') + import :: sound_type + implicit none + type(sound_type), intent(in), value :: sound + end subroutine unload_sound + + ! void UnloadSoundAlias(Sound alias) + subroutine unload_sound_alias(alias) bind(c, name='UnloadSoundAlias') + import :: sound_type + implicit none + type(sound_type), intent(in), value :: alias + end subroutine unload_sound_alias + + ! void UnloadTexture(Texture2D texture) + subroutine unload_texture(texture) bind(c, name='UnloadTexture') + import :: texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + end subroutine unload_texture + + ! void UnloadUTF8(char *text) + subroutine unload_utf8(text) bind(c, name='UnloadUTF8') + import :: c_char + implicit none + character(kind=c_char), intent(in) :: text + end subroutine unload_utf8 + + ! void UnloadVrStereoConfig(VrStereoConfig config) + subroutine unload_vr_stereo_config(config) bind(c, name='UnloadVrStereoConfig') + import :: vr_stereo_config_type + implicit none + type(vr_stereo_config_type), intent(in), value :: config + end subroutine unload_vr_stereo_config + + ! void UnloadWave(Wave wave) + subroutine unload_wave(wave) bind(c, name='UnloadWave') + import :: wave_type + implicit none + type(wave_type), intent(in), value :: wave + end subroutine unload_wave + + ! void UnloadWaveSamples(float *samples) + subroutine unload_wave_samples(samples) bind(c, name='UnloadWaveSamples') + import :: c_float + implicit none + real(kind=c_float), intent(inout) :: samples(*) + end subroutine unload_wave_samples + + ! void UpdateAudioStream(AudioStream stream, const void *data, int frameCount) + subroutine update_audio_stream(stream, data, frame_count) bind(c, name='UpdateAudioStream') + import :: audio_stream_type, c_int, c_ptr + implicit none + type(audio_stream_type), intent(in), value :: stream + type(c_ptr), intent(in), value :: data + integer(kind=c_int), intent(in), value :: frame_count + end subroutine update_audio_stream + + ! void UpdateCamera(Camera *camera, int mode) + subroutine update_camera(camera, mode) bind(c, name='UpdateCamera') + import :: camera3d_type, c_int + implicit none + type(camera3d_type), intent(inout) :: camera + integer(kind=c_int), intent(in), value :: mode + end subroutine update_camera + + ! void UpdateMeshBuffer(Mesh mesh, int index, const void *data, int dataSize, int offset) + subroutine update_mesh_buffer(mesh, index, data, data_size, offset) bind(c, name='UpdateMeshBuffer') + import :: c_int, c_ptr, mesh_type + implicit none + type(mesh_type), intent(in), value :: mesh + integer(kind=c_int), intent(in), value :: index + type(c_ptr), intent(in), value :: data + integer(kind=c_int), intent(in), value :: data_size + integer(kind=c_int), intent(in), value :: offset + end subroutine update_mesh_buffer + + ! void UpdateModelAnimation(Model model, ModelAnimation anim, int frame) + subroutine update_model_animation(model, anim, frame) bind(c, name='UpdateModelAnimation') + import :: c_int, model_animation_type, model_type + implicit none + type(model_type), intent(in), value :: model + type(model_animation_type), intent(in), value :: anim + integer(kind=c_int), intent(in), value :: frame + end subroutine update_model_animation + + ! void UpdateMusicStream(Music music) + subroutine update_music_stream(music) bind(c, name='UpdateMusicStream') + import :: music_type + implicit none + type(music_type), intent(in), value :: music + end subroutine update_music_stream + + ! void UpdateSound(Sound sound, const void *data, int sampleCount) + subroutine update_sound(sound, data, sample_count) bind(c, name='UpdateSound') + import :: c_int, c_ptr, sound_type + implicit none + type(sound_type), intent(in), value :: sound + type(c_ptr), intent(in), value :: data + integer(kind=c_int), intent(in), value :: sample_count + end subroutine update_sound + + ! void UpdateTexture(Texture2D texture, const void *pixels) + subroutine update_texture(texture, pixels) bind(c, name='UpdateTexture') + import :: c_ptr, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(c_ptr), intent(in), value :: pixels + end subroutine update_texture + + ! void UpdateTextureRec(Texture2D texture, Rectangle rec, const void *pixels) + subroutine update_texture_rec(texture, rec, pixels) bind(c, name='UpdateTextureRec') + import :: c_ptr, rectangle_type, texture2d_type + implicit none + type(texture2d_type), intent(in), value :: texture + type(rectangle_type), intent(in), value :: rec + type(c_ptr), intent(in), value :: pixels + end subroutine update_texture_rec + + ! void UploadMesh(Mesh *mesh, bool dynamic) + subroutine upload_mesh(mesh, dynamic) bind(c, name='UploadMesh') + import :: c_bool, mesh_type + implicit none + type(mesh_type), intent(inout) :: mesh + logical(kind=c_bool), intent(in), value :: dynamic + end subroutine upload_mesh + + ! void WaitTime(double seconds) + subroutine wait_time(seconds) bind(c, name='WaitTime') + import :: c_double + implicit none + real(kind=c_double), intent(in), value :: seconds + end subroutine wait_time + + ! Wave WaveCopy(Wave wave) + function wave_copy(wave) bind(c, name='WaveCopy') + import :: wave_type + implicit none + type(wave_type), intent(in), value :: wave + type(wave_type) :: wave_copy + end function wave_copy + + ! void WaveCrop(Wave *wave, int initSample, int finalSample) + subroutine wave_crop(wave, init_sample, final_sample) bind(c, name='WaveCrop') + import :: c_int, wave_type + implicit none + type(wave_type), intent(in) :: wave + integer(kind=c_int), intent(in), value :: init_sample + integer(kind=c_int), intent(in), value :: final_sample + end subroutine wave_crop + + ! void WaveFormat(Wave *wave, int sampleRate, int sampleSize, int channels) + subroutine wave_format(wave, sample_rate, sample_size, channels) bind(c, name='WaveFormat') + import :: c_int, wave_type + implicit none + type(wave_type), intent(in) :: wave + integer(kind=c_int), intent(in), value :: sample_rate + integer(kind=c_int), intent(in), value :: sample_size + integer(kind=c_int), intent(in), value :: channels + end subroutine wave_format + + ! bool WindowShouldClose(void) + function window_should_close() bind(c, name='WindowShouldClose') + import :: c_bool + implicit none + logical(kind=c_bool) :: window_should_close + end function window_should_close + end interface +contains + elemental real function deg2rad(d) result(r) + real, intent(in) :: d + + r = d * (PI / 180.0) + end function deg2rad + + elemental real function rad2deg(r) result(d) + real, intent(in) :: r + + d = r * (180.0 / PI) + end function rad2deg +end module Raylib diff --git a/src/modules/RealMatrix/CMakeLists.txt b/src/modules/RealMatrix/CMakeLists.txt new file mode 100644 index 000000000..cfd218414 --- /dev/null +++ b/src/modules/RealMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/RealMatrix_Method.F90 +) diff --git a/src/modules/RealMatrix/src/RealMatrix_Method.F90 b/src/modules/RealMatrix/src/RealMatrix_Method.F90 new file mode 100644 index 000000000..79fdc3b4c --- /dev/null +++ b/src/modules/RealMatrix/src/RealMatrix_Method.F90 @@ -0,0 +1,1360 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains methods for [[RealMatrix_]] data type + +MODULE RealMatrix_Method +USE GlobalData +USE BaSetype +IMPLICIT NONE +PRIVATE + +PUBLIC :: Shape +PUBLIC :: Size +PUBLIC :: TotalDimension +PUBLIC :: SetTotalDimension +PUBLIC :: ALLOCATE +PUBLIC :: DEALLOCATE +PUBLIC :: Initiate +PUBLIC :: RealMatrix +PUBLIC :: Eye +PUBLIC :: Convert +PUBLIC :: RealMatrix_Pointer +PUBLIC :: SYM +PUBLIC :: SkewSym +PUBLIC :: MakeDiagonalCopies +PUBLIC :: RANDOM_NUMBER +PUBLIC :: TestMatrix +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: GetPointer +PUBLIC :: Copy +PUBLIC :: Get +PUBLIC :: Display +PUBLIC :: LinearSolver_CG +PUBLIC :: Matmul +PUBLIC :: Set +PUBLIC :: Add + +!---------------------------------------------------------------------------- +! Shape@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Return Shape of [[RealMatrix_]] +! +!# Introduction +! +! This function return Shape of [[RealMatrix_]] +! +!### Usage +! +! ```fortran +! s = Shape( obj ) +! ``` + +INTERFACE Shape + MODULE PURE FUNCTION Get_Shape(obj) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + INTEGER(I4B) :: Ans(2) + END FUNCTION Get_Shape +END INTERFACE Shape + +!---------------------------------------------------------------------------- +! Size@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Return size of [[RealMatrix_]] +! +!# Introduction +! +! This function return size of `RealMatrix_` +! - If `Dims` is present and equal to 1 then total number of rows (m) +! - If `Dims` is present and equal to 2 then total number of cols (n) +! - If `Dimes` is absent then Ans = m * n +! +!### Usage +! +!```fortran +! trow = SIZE( obj, 1 ) +! tcol = SIZE( obj, 2 ) +! t = SIZE( obj ) +!``` + +INTERFACE Size + MODULE PURE FUNCTION Get_size(obj, Dims) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims + INTEGER(I4B) :: Ans + END FUNCTION Get_size +END INTERFACE Size + +!---------------------------------------------------------------------------- +! TotalDimension@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Returns the total dimension of an array +! +!# Introduction +! +! This function returns the total dimension (or rank) of an array, + +INTERFACE TotalDimension + MODULE PURE FUNCTION Get_tdimension(obj) RESULT(Ans) + CLASS(RealMatrix_), INTENT(IN) :: obj + INTEGER(I4B) :: Ans + END FUNCTION Get_tdimension +END INTERFACE TotalDimension + +!---------------------------------------------------------------------------- +! SetTotalDimension@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine Set the total dimension (rank) of an array +! +!# Introduction +! +! This subroutine Sets the rank(total dimension) of an array + +INTERFACE SetTotalDimension + MODULE PURE SUBROUTINE Set_tdimension(obj, tDimension) + CLASS(RealMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tDimension + END SUBROUTINE Set_tdimension +END INTERFACE SetTotalDimension + +!---------------------------------------------------------------------------- +! Allocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine allocate memory for [[RealMatrix_]] +! +! +!### Usage +! +! ```fortran +! call Allocate( obj, Dims ) +! ``` + +INTERFACE ALLOCATE + MODULE PURE SUBROUTINE Allocate_Data(obj, Dims) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Dims(2) + END SUBROUTINE Allocate_Data +END INTERFACE ALLOCATE + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Deallocate data in [[RealMatrix_]] +! +!# Introduction +! +! This routine deallocates data stored in obj +! +!### Usage +! +! ```fortran +! call Deallocate( obj ) +! ``` + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE Deallocate_Data(obj) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + END SUBROUTINE Deallocate_Data +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine Initiate `obj` with Shape `Dims` +! +!### Usage +! +!```fortran +! call Initiate( obj, [2,3] ) +!``` +! The above call will Initiate a matrix of Shape (2,3) + +INTERFACE Initiate + MODULE PURE SUBROUTINE realmat_Initiate1(obj, Dims) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Dims(2) + END SUBROUTINE realmat_Initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine Initiate `obj` with Shape `Dims` +! +!### Usage +! +!```fortran +! call Initiate( obj, [2,3] ) +!``` +! The above call will Initiate a matrix of Shape (2,3) + +INTERFACE Initiate + MODULE PURE SUBROUTINE realmat_Initiate2(obj, nrow, ncol) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nrow + INTEGER(I4B), INTENT(IN) :: ncol + END SUBROUTINE realmat_Initiate2 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Initiate vector of [[realmatrix_]] with Shape `Dims` +! +!### Usage +! +!```fortran +! type( realmatrix_ ) :: obj( 4 ) +! call Initiate( obj, [2,3] ) +!``` +! The above call will Initiate `obj` vector of matrices of Shape (2,3) + +INTERFACE Initiate + MODULE PURE SUBROUTINE realmat_Initiate3(obj, Dims) + TYPE(RealMatrix_), INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: Dims(2) + END SUBROUTINE realmat_Initiate3 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Initiate an instance of [[RealMatrix_]] +! +!# Introduction +! +! This subroutine Initiate vector of [[realmatrix_]] with matrices of +! different Shapes given in `Dims` +! - `Dims` has two columns; the first column denotes the number of rows, and +! second column denotes the number of columns in a matrix +! - irow of `Dims` corresponds to the Shape of `obj(irow)` +! - in this way `SIZE(obj)` should be equal to the SIZE(Dims, 1) +! +!### Usage +! +!```fortran +! type( realmatrix_ ) :: obj( 3 ) +! integer( i4b ) :: Dims( 3, 2 ) +! +! Dims( 1, : ) = [2,2] +! Dims( 2, : ) = [4,4] +! Dims( 3, : ) = [4,4] +! call Initiate( obj, Dims ) +!``` +! +! - The above call will Initiate a obj( 1 ) with Shape (2,2) +! - The above call will Initiate a obj( 2 ) with Shape (4,4) +! - The above call will Initiate a obj( 3 ) with Shape (4,4) + +INTERFACE Initiate + MODULE PURE SUBROUTINE realmat_Initiate4(obj, Dims) + TYPE(RealMatrix_), INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: Dims(:, :) + END SUBROUTINE realmat_Initiate4 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine performs `obj%l = Val` +! +!### Usage +! +! ```fortran +! call Initiate( obj, val ) +! ``` + +INTERFACE Initiate + MODULE PURE SUBROUTINE realmat_Initiate5(obj, Val) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :) + END SUBROUTINE realmat_Initiate5 +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE realmat_Initiate5 +END INTERFACE + +!---------------------------------------------------------------------------- +! Matrix@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Constructor function for [[RealMatrix_]] +! +!# Introduction +! +! This function returns an instance of [[realmatrix_]] +! +!### Usage +! +!```fortran +! obj = RealMatrix( [2,2] ) +!``` + +INTERFACE RealMatrix + MODULE PURE FUNCTION Constructor1(Dims) RESULT(obj) + TYPE(RealMatrix_) :: obj + INTEGER(I4B), INTENT(IN) :: Dims(2) + END FUNCTION Constructor1 +END INTERFACE RealMatrix + +!---------------------------------------------------------------------------- +! Eye@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-11-04 +! summary: Return identity matrix of type [[realmatrix_]] +! +!# Introduction +! +! This function returns identity matrix of type [[realmatrix_]] +! +!### Usage +! +! ```fortran +! obj = eye( 3, typeRealMatrix ) +! ``` + +INTERFACE + + MODULE PURE FUNCTION realMat_eye1(m, dataType) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: m + TYPE(RealMatrix_), INTENT(IN) :: dataType + TYPE(RealMatrix_) :: Ans + END FUNCTION realMat_eye1 +END INTERFACE + +INTERFACE Eye + MODULE PROCEDURE realMat_eye1 +END INTERFACE Eye + +!---------------------------------------------------------------------------- +! Convert@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Rearrange the dofs in finite element matrix +! +!# Introduction +! +! This subroutine changes the storage pattern of a two-d matrix +! - Usually element matrix in easifem are stored in `FMT_DOF` +! - Global matrices/tanmat, however, are stored in `FMT_Nodes` +! - This subroutine is, therefore, in Settings or Adding values in +! [[SparseMatrix_]]. +! +! > This subroutine converts changes the storage format of dense matrix. +! Usually, elemental finite element matrix is stored in `DOF_FMT`, and global +! matrix/ tanmat, may be stored in `Nodes_FMT`. +! + +INTERFACE Convert + MODULE PURE SUBROUTINE realmat_convert_1(From, To, Conversion, & + & nns, tdof) + TYPE(RealMatrix_), INTENT(IN) :: From + !! Matrix in one format + TYPE(RealMatrix_), INTENT(INOUT) :: To + !! Matrix in one format + INTEGER(I4B), INTENT(IN) :: Conversion + !! `Conversion` can be `NodesToDOF` or `DOFToNodes` + INTEGER(I4B), INTENT(IN) :: nns, tdof + END SUBROUTINE realmat_convert_1 +END INTERFACE Convert + +!---------------------------------------------------------------------------- +! Matrix_Pointer@ConstructorMethods +!---------------------------------------------------------------------------- + +INTERFACE RealMatrix_Pointer + MODULE PURE FUNCTION Constructor_1(Dims) RESULT(obj) + CLASS(RealMatrix_), POINTER :: obj + INTEGER(I4B), INTENT(IN) :: Dims(2) + END FUNCTION Constructor_1 +END INTERFACE RealMatrix_Pointer + +!---------------------------------------------------------------------------- +! Sym@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Return sym(obj) = 0.5*(obj + transpose( obj ) ) +! +!# Introduction +! +! Return symmetric part of obj +! +!### Usage +! +! ```fortran +! realMat = Sym( obj ) +! ``` + +INTERFACE Sym + MODULE PURE FUNCTION sym_obj(obj) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + !! Real matrix + TYPE(RealMatrix_) :: Ans + !! Symmetric real matrix + END FUNCTION sym_obj +END INTERFACE Sym + +!---------------------------------------------------------------------------- +! Sym@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Return sym(obj) = 0.5*(obj + transpose( obj ) ) +! +!# Introduction +! +! Return symmetric part of obj +! +!### Usage +! +!```fortran +! realMat = Sym( obj ) +!``` + +INTERFACE Sym + MODULE PURE FUNCTION sym_array(obj) RESULT(Ans) + REAL(DFP), INTENT(IN) :: obj(:, :) + !! Two dimensiona array + REAL(DFP) :: Ans(SIZE(obj, 1), SIZE(obj, 2)) + !! Symmetric array + END FUNCTION sym_array +END INTERFACE Sym + +!---------------------------------------------------------------------------- +! SkewSym@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Return SkewSymmetric part of obj +! +!### Usage +! +!```fortran +! realMat = SkewSym( obj ) +!``` + +INTERFACE SkewSym + MODULE PURE FUNCTION SkewSym_obj(obj) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + !! Real matrix + TYPE(RealMatrix_) :: Ans + !! SkewSymmetric real matrix + END FUNCTION SkewSym_obj +END INTERFACE SkewSym + +!---------------------------------------------------------------------------- +! SkewSym@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Return SkewSym(obj) = 0.5*(obj + transpose( obj ) ) +! +!# Introduction +! +! Return SkewSymmetric part of obj +! +!### Usage +! +!```fortran +! realMat = SkewSym( obj ) +!``` + +INTERFACE SkewSym + MODULE PURE FUNCTION SkewSym_array(obj) RESULT(Ans) + REAL(DFP), INTENT(IN) :: obj(:, :) + !! Two dimensiona array + REAL(DFP) :: Ans(SIZE(obj, 1), SIZE(obj, 2)) + !! SkewSymmetric array + END FUNCTION SkewSym_array +END INTERFACE SkewSym + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Make diagonal copies of Matrix +! +!# Introduction +! +! This subroutine makes `nCopy` diagonal copies of `Mat` The size of `Mat` on +! return is nCopy * SIZE( Mat, 1 ) +! +!### Usage +! +!```fortran +! call MakeDiagonalCopies( Mat, nCopy ) +!``` + +INTERFACE MakeDiagonalCopies + MODULE PURE SUBROUTINE realmat_make_diag_Copy1(Mat, nCopy) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: nCopy + END SUBROUTINE realmat_make_diag_Copy1 +END INTERFACE MakeDiagonalCopies + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Make diagonal copies of Matrix +! +! This subroutine makes `nCopy` diagonal copies of `Mat` +! +!### Usage +! +!```fortran +! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy ) +!``` + +INTERFACE MakeDiagonalCopies + MODULE PURE SUBROUTINE realmat_make_diag_Copy2(From, To, nCopy) + REAL(DFP), INTENT(IN) :: From(:, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) + INTEGER(I4B), INTENT(IN) :: nCopy + END SUBROUTINE realmat_make_diag_Copy2 +END INTERFACE MakeDiagonalCopies + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Make diagonal copies of [[realmatrix_]] +! +! This subroutine makes `nCopy` diagonal copies of `Mat`, The size of `Mat` +! on return is nCopy * SIZE( Mat, 1 ) +! +!### Usage +! +!```fortran +! call MakeDiagonalCopies( Mat, nCopy ) +!``` + +INTERFACE MakeDiagonalCopies + MODULE PURE SUBROUTINE realmat_make_diag_Copy3(Mat, nCopy) + TYPE(RealMatrix_), INTENT(INOUT) :: Mat + INTEGER(I4B), INTENT(IN) :: nCopy + END SUBROUTINE realmat_make_diag_Copy3 +END INTERFACE MakeDiagonalCopies + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Make diagonal copies of Matrix +! +!# Introduction +! +! This subroutine makes `nCopy` diagonal copies of `Mat` +! +!### Usage +! +!```fortran +! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy ) +!``` + +INTERFACE MakeDiagonalCopies + MODULE PURE SUBROUTINE realmat_make_diag_Copy4(From, To, nCopy) + TYPE(RealMatrix_), INTENT(IN) :: From + TYPE(RealMatrix_), INTENT(INOUT) :: To + INTEGER(I4B), INTENT(IN) :: nCopy + END SUBROUTINE realmat_make_diag_Copy4 +END INTERFACE MakeDiagonalCopies + +!---------------------------------------------------------------------------- +! Random_number@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Set a values in [[realmatrix_]] obj to random values +! +!# Introduction +! +! This subroutine Set values in `obj%Val` to random +! - This subroutine calls `RANDOM_NUMBER()` function from Fortran + +INTERFACE Random_number + MODULE SUBROUTINE realmat_random_number(obj, m, n) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), OPTIONAL, INTENT(IN) :: m, n + END SUBROUTINE realmat_random_number +END INTERFACE Random_number + +!---------------------------------------------------------------------------- +! TestMatrix@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 7 March 2021 +! summary: This function returns the example matrix + +INTERFACE + MODULE FUNCTION TestMatrix(matNo) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: matNo + REAL(DFP), ALLOCATABLE :: Ans(:, :) + END FUNCTION TestMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns the values of [[RealMatrix_]] obj in 2D array +! +!# Introduction +! +! This function returns the value stored in `obj%l` in a 2D fortran array +! +!### Usage +! +!```fortran +! Val = Get( obj, 1.0_dfp ) +!``` + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get1(obj, dataType) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: dataType + REAL(DFP), ALLOCATABLE :: Ans(:, :) + END FUNCTION realmat_Get1 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns the values of [[RealMatrix_]] obj in 2D array +! +!# Introduction +! +! This function returns the value stored in `obj%l` in a 2D fortran array +! +!### Usage +! +!```fortran +! Val = Get( obj, 1.0_dfp ) +!``` + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get1b(obj) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE :: Ans(:, :) + END FUNCTION realmat_Get1b +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns the values of [[RealMatrix_]] obj in 2D array +! +!# Introduction +! +! This function returns a section of `obj%l` in a 2D fortran array. This +! is equivalent to `Val = obj%l(RIndx, CIndx)` +! +!### Usage +! +!```fortran +! integer( i4b ) :: r( 2 ), c( 2 ) +! type( RealMatrix_ ) :: obj +! call Initiate( obj, [4,4] ) +! call random_number( obj ); r=[1,2]; c=[2,3] +! Val = Get( obj, R, C, 1.0_dfp ) +!``` +! +! The above call will return `obj%Val[1:2, 2:3]` + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get2(obj, RIndx, CIndx, dataType) & + & RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: RIndx(:), CIndx(:) + REAL(DFP), INTENT(IN) :: dataType + REAL(DFP), ALLOCATABLE :: Ans(:, :) + END FUNCTION realmat_Get2 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns the values of [[RealMatrix_]] obj in 2D array +! +!# Introduction +! +! This function returns a section of `obj%l` in a 2D fortran array. This +! is equivalent to `Val = obj%l(is:ie:s, is:ie:s)` +! +!### Usage +! +!```fortran +! integer( i4b ) :: r( 2 ), c( 2 ) +! type( RealMatrix_ ) :: obj +! call Initiate( obj, [4,4] ) +! call random_number( obj ) +! Val = Get( obj, 1, 2, 1, 1.0_dfp ) +!``` +! +! The above call will return `obj%Val[1:2:1, 1:2:1]` + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get3(obj, iStart, iEnd, Stride, & + & dataType) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + REAL(DFP), INTENT(IN) :: dataType + REAL(DFP), ALLOCATABLE :: Ans(:, :) + END FUNCTION realmat_Get3 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns [[RealMatrix_]] obj from [[realmatrix_]] + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get4(obj, dataType) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + TYPE(RealMatrix_), INTENT(IN) :: dataType + TYPE(RealMatrix_) :: Ans + END FUNCTION realmat_Get4 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns [[RealMatrix_]] obj from a section of [[realmatrix_]] +! +!# Introduction +! +! This function is essentially Copy method `Ans=obj(RIndx, CIndx)` + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get5(obj, RIndx, CIndx, dataType) & + & RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: RIndx(:), CIndx(:) + TYPE(RealMatrix_), INTENT(IN) :: dataType + TYPE(RealMatrix_) :: Ans + END FUNCTION realmat_Get5 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns [[RealMatrix_]] obj from a section of [[realmatrix_]] +! +!# Introduction +! This function is essentially Copy method `Ans=obj(is:ie, is:ie)` + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get6(obj, iStart, iEnd, & + & Stride, dataType) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride + TYPE(RealMatrix_), INTENT(IN) :: dataType + TYPE(RealMatrix_) :: Ans + END FUNCTION realmat_Get6 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns values in 2D fortran array from [[realmatrix_]] +! +!# Introduction +! +! This function combines all [[realmatrix_]] value of `obj` and +! returns a 2D fortrn array + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get7(obj, dataType) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj(:, :) + REAL(DFP), INTENT(IN) :: dataType + REAL(DFP), ALLOCATABLE :: Ans(:, :) + END FUNCTION realmat_Get7 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns [[realmatrix_]] object from a 2D array of [[realmatrix_]] +! +!# Introduction +! +! This function combines all [[realmatrix_]] value of `obj` and +! returns a [[realmatrix_]] object + +INTERFACE Get + MODULE PURE FUNCTION realmat_Get8(obj, dataType) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj(:, :) + TYPE(RealMatrix_), INTENT(IN) :: dataType + TYPE(RealMatrix_) :: Ans + END FUNCTION realmat_Get8 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Copy@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Copy from [[realmatrix_]] to 2D fortran array +! +!# Introduction +! +! This subroutine Copy the contents of [[realmatrix_]] object into a 2D +! fortran array + +INTERFACE Copy + MODULE PURE SUBROUTINE realmat_Copy1(From, To) + TYPE(RealMatrix_), INTENT(IN) :: From + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) + END SUBROUTINE realmat_Copy1 +END INTERFACE Copy + +INTERFACE Convert + MODULE PROCEDURE realmat_Copy1 +END INTERFACE Convert + +!---------------------------------------------------------------------------- +! Copy@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Copy from RealMatrix to another RealMatrix +! +!# Introduction +! +! This subroutine Copy the contents of RealMatrix object to another +! RealMatrix object + +INTERFACE Copy + MODULE PURE SUBROUTINE realmat_Copy2(From, To) + TYPE(RealMatrix_), INTENT(IN) :: From + TYPE(RealMatrix_), INTENT(INOUT) :: To + END SUBROUTINE realmat_Copy2 +END INTERFACE Copy + +INTERFACE Convert + MODULE PROCEDURE realmat_Copy2 +END INTERFACE Convert + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE realmat_Copy2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Copy@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Copy from 2D fortran array to RealMatrix +! +!# Introduction +! +! This subroutine Copy the contents of a 2D fortran array to RealMatrix +! object + +INTERFACE Copy + MODULE PURE SUBROUTINE realmat_Copy3(From, To) + REAL(DFP), INTENT(IN) :: From(:, :) + TYPE(RealMatrix_), INTENT(INOUT) :: To + END SUBROUTINE realmat_Copy3 +END INTERFACE Copy + +INTERFACE Convert + MODULE PROCEDURE realmat_Copy3 +END INTERFACE Convert + +!---------------------------------------------------------------------------- +! ArrayPointer@GetValuesMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Get pointer to the values stored inside [[realmatrix_]] +! +!# Introduction +! +! This function returns the pointer to the values stored inside the +! [[realmatrix_]] + +INTERFACE GetPointer + MODULE FUNCTION realmat_GetPointer(obj, dataType) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN), TARGET :: obj + REAL(DFP), INTENT(IN) :: dataType + REAL(DFP), POINTER :: Ans(:, :) + END FUNCTION realmat_GetPointer +END INTERFACE GetPointer + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Display content of [[realmatrix_]] + +INTERFACE Display + MODULE SUBROUTINE realmat_Display1(obj, Msg, UnitNo) + TYPE(RealMatrix_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: Msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + END SUBROUTINE realmat_Display1 +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Display content of [[realmatrix_]] + +INTERFACE Display + MODULE SUBROUTINE realmat_Display2(obj, Msg, UnitNo) + TYPE(RealMatrix_), INTENT(IN) :: obj(:) + CHARACTER(*), INTENT(IN) :: Msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + END SUBROUTINE realmat_Display2 +END INTERFACE Display + +!---------------------------------------------------------------------------- +! CG@IterativeSolverMethods +!---------------------------------------------------------------------------- + +INTERFACE LinearSolver_CG + MODULE PURE SUBROUTINE realmat_CG_1(mat, rhs, sol, maxIter, & + & rtol, atol, convergenceIn, relativeToRHS, & + & restartAfter) + REAL(DFP), INTENT(IN) :: mat(:, :) + !! Symmetric matrix + REAL(DFP), INTENT(IN) :: rhs(:) + REAL(DFP), INTENT(INOUT) :: sol(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: maxIter + !! maximum number of iteration + !! if maxIter < 0 then maxIter=infinite + !! if maxIter is absent then min( size(mat,1), 10 ) + REAL(DFP), OPTIONAL, INTENT(IN) :: rtol + !! relative tolerance, default is 1.0E-6 + REAL(DFP), OPTIONAL, INTENT(IN) :: atol + !! absolute tolerance, default is 0.0 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: convergenceIn + !! convergenceInRes <-- default + !! convergenceInSol + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: relativeToRHS + !! FALSE <--- relative converfence is checked with respect to ||res|| + !! TRUE Convergence is checked with respect to ||rhs|| + INTEGER(I4B), OPTIONAL, INTENT(IN) :: restartAfter + !! recompute residual by using b-Ax + END SUBROUTINE realmat_CG_1 +END INTERFACE LinearSolver_CG + +!---------------------------------------------------------------------------- +! MatMul@MatrixMultiplication +!---------------------------------------------------------------------------- + +INTERFACE Matmul + MODULE PURE FUNCTION realmat_MatMul1(obj1, obj2) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj1, obj2 + TYPE(RealMatrix_) :: Ans + END FUNCTION realmat_MatMul1 +END INTERFACE Matmul + +!---------------------------------------------------------------------------- +! MatMul@MatrixMultiplication +!---------------------------------------------------------------------------- + +INTERFACE Matmul + MODULE PURE FUNCTION realmat_MatMul2(obj, Vec) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Vec(:) + REAL(DFP), ALLOCATABLE :: Ans(:) + END FUNCTION realmat_MatMul2 +END INTERFACE Matmul + +!---------------------------------------------------------------------------- +! MatMul@MatrixMultiplication +!---------------------------------------------------------------------------- + +INTERFACE Matmul + MODULE PURE FUNCTION realmat_MatMul3(obj, Vec) RESULT(Ans) + TYPE(RealMatrix_), INTENT(IN) :: obj + TYPE(RealVector_), INTENT(IN) :: Vec + TYPE(RealVector_) :: Ans + END FUNCTION realmat_MatMul3 +END INTERFACE Matmul + +!---------------------------------------------------------------------------- +! SetValues@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Add values in [[realmatrix_]] +! +!# Introduction +! +! This subroutine Set `obj%val` to `Val` + +INTERFACE Set + MODULE PURE SUBROUTINE realmat_Set_1(obj, Val) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :) + END SUBROUTINE realmat_Set_1 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! SetValues@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Set values in [[realmatrix_]] + +!> author: Dr. Vikas Sharma +! +! This subroutine Set values in `obj%l` +! `obj%l( i, j ) = Val` + +INTERFACE Set + MODULE PURE SUBROUTINE realmat_Set_2(obj, Val, Row, Col) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + INTEGER(I4B), INTENT(IN) :: Col, Row + END SUBROUTINE realmat_Set_2 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! SetValues@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Set values in [[realmatrix_]] +! +!# Introduction +! +! This subroutine Set values in `obj%l` +! + +INTERFACE Set + MODULE PURE SUBROUTINE realmat_Set_3(obj, Val, Row, Col) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :) + INTEGER(I4B), INTENT(IN) :: Col(:), Row(:) + END SUBROUTINE realmat_Set_3 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! SetValues@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Set values in [[realmatrix_]] +! +!# Introduction +! +! This subroutine Set values in `obj%l` +! - If `ExtraOption=MATRIX_DIAGONAL` then diagonal values are Set; and `Indx` +! denotes diagonal number with `0` being the main diagonal +! - If `Extraoption=MATRIX_ROW` then row values are Set; `Indx` then denotes +! row number +! - If `Extraoption=MATRIX_COLUMN` then col values are Set; `Indx` then +! denotes col number + +INTERFACE Set + MODULE PURE SUBROUTINE realmat_Set_4(obj, Val, Indx, ExtraOption) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: Indx + INTEGER(I4B), INTENT(IN) :: ExtraOption + END SUBROUTINE realmat_Set_4 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! SetValues@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Set values in [[realmatrix_]] +! +!# Introduction +! +! This subroutine Set values in `obj%l` +! - If `ExtraOption=MATRIX_DIAGONAL` then diagonal values are Set; and `Indx` +! denotes the diagonal number with `0` being the main diagonal +! - If `Extraoption=ROW` then row values are Set; `Indx` then denotes row +! number +! - If `Extraoption=COLUMN` then col values are Set; `Indx` then denotes col +! number + +INTERFACE Set + MODULE PURE SUBROUTINE realmat_Set_5(obj, Val, Indx, ExtraOption) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :) + INTEGER(I4B), INTENT(IN) :: Indx(:), ExtraOption + END SUBROUTINE realmat_Set_5 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! SetValues@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Add values in [[realmatrix_]] +! +!# Introduction +! +! This subroutine Set `obj%l` to `Val` + +INTERFACE Set + MODULE PURE SUBROUTINE realmat_Set_6(obj, Val) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + END SUBROUTINE realmat_Set_6 +END INTERFACE Set + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE realmat_Set_6 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! AddContribution@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Add contribution in values of [[realmatrix_]] +! +!# Introduction +! +! This subroutine Adds contribution in values of `obj%l`. This subroutine +! performs following task: +! +! $$obj = obj scale * val $$ +! +! Here `op` can be `+, -, *, /`. +! +!@todo +! Use Blas routines or OpenMP support? +!@endtodo + +INTERFACE Add + MODULE PURE SUBROUTINE realmat_Add_1(obj, Val, Scale, Op) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :) + REAL(DFP), INTENT(IN) :: Scale + !! Scaling for `Val` + CHARACTER(1), INTENT(IN) :: Op + !! operator symbol; `+, -, *, /` + END SUBROUTINE realmat_Add_1 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! AddContribution@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Add contribution in values of [[Realmatrix_]] +! +!# Introduction +! +! This subroutine Adds contribution in values of `obj%l` +! +!```fortran +! obj%l = obj%v%*Op* scale * val +!``` + +INTERFACE Add + MODULE PURE SUBROUTINE realmat_Add_2(obj, Val, Row, Col, Scale, Op) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val + REAL(DFP), INTENT(IN) :: Scale + INTEGER(I4B), INTENT(IN) :: Row + INTEGER(I4B), INTENT(IN) :: Col + CHARACTER(1), INTENT(IN) :: Op + END SUBROUTINE realmat_Add_2 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! AddContribution@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Add contribution in values of [[realmatrix_]] +! +!# Introduction +! +! This subroutine Adds contribution in values of `obj%l` +! +!```fortran +! obj%l = obj%v%*Op* scale * val +!``` + +INTERFACE Add + MODULE PURE SUBROUTINE realmat_Add_3(obj, Val, Row, Col, Scale, Op) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :) + REAL(DFP), INTENT(IN) :: Scale + INTEGER(I4B), INTENT(IN) :: Row(:) + INTEGER(I4B), INTENT(IN) :: Col(:) + CHARACTER(1), INTENT(IN) :: Op + END SUBROUTINE realmat_Add_3 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! AddContribution@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Add contribution in values of [[Realmatrix_]] +! +!# Introduction +! +! This subroutine Adds contribution in values of `obj%l` +! +! ```fortran +! obj%l = obj%v%*Op* scale * val +! ``` + +INTERFACE Add + MODULE PURE SUBROUTINE realmat_Add_4(obj, Val, Indx, ExtraOption, Scale, Op) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:), Scale + INTEGER(I4B), INTENT(IN) :: Indx + INTEGER(I4B), INTENT(IN) :: ExtraOption + CHARACTER(1), INTENT(IN) :: Op + END SUBROUTINE realmat_Add_4 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! AddContribution@SetValues +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Add contribution in values of [[realmatrix_]] +! +!# Introduction +! +! This subroutine Adds contribution in values of `obj%l` +! +!```fortran +! obj%l = obj%v%*Op* scale * val +!``` + +INTERFACE Add + MODULE PURE SUBROUTINE realmat_Add_5(obj, Val, Indx, ExtraOption, & + & Scale, Op) + TYPE(RealMatrix_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:, :), Scale + INTEGER(I4B), INTENT(IN) :: Indx(:) + INTEGER(I4B), INTENT(IN) :: ExtraOption + CHARACTER(1), INTENT(IN) :: Op + END SUBROUTINE realmat_Add_5 +END INTERFACE Add + +END MODULE RealMatrix_Method diff --git a/src/modules/RealVector/CMakeLists.txt b/src/modules/RealVector/CMakeLists.txt new file mode 100644 index 000000000..0389b0111 --- /dev/null +++ b/src/modules/RealVector/CMakeLists.txt @@ -0,0 +1,35 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/RealVector_Method.F90 + ${src_path}/RealVector_AddMethods.F90 + ${src_path}/RealVector_AppendMethods.F90 + ${src_path}/RealVector_AssignMethods.F90 + ${src_path}/RealVector_Blas1Methods.F90 + ${src_path}/RealVector_ComparisonMethods.F90 + ${src_path}/RealVector_ConstructorMethods.F90 + ${src_path}/RealVector_GetMethods.F90 + ${src_path}/RealVector_GetValueMethods.F90 + ${src_path}/RealVector_IOMethods.F90 + ${src_path}/RealVector_Norm2ErrorMethods.F90 + ${src_path}/RealVector_Norm2Methods.F90 + ${src_path}/RealVector_SetMethods.F90 + ${src_path}/RealVector_ShallowCopyMethods.F90 +) diff --git a/src/modules/RealVector/src/RealVector_AddMethods.F90 b/src/modules/RealVector/src/RealVector_AddMethods.F90 new file mode 100644 index 000000000..9ee9b14dc --- /dev/null +++ b/src/modules/RealVector/src/RealVector_AddMethods.F90 @@ -0,0 +1,717 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_AddMethods +USE GlobalData, ONLY: DFP, I4B +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Add all values to given scalar +! +!# Introduction +! +!@note +! We call F77_AXPY in this method +!@endnote + +INTERFACE Add + MODULE SUBROUTINE obj_Add1(obj, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add1 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Add all values by given vector +! +!@note +! We call F95_AXPY in this method +!@endnote + +INTERFACE Add + MODULE SUBROUTINE obj_Add2(obj, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + !! obj = obj + scale*VALUE + REAL(DFP), INTENT(IN) :: VALUE(:) + !! Size of value should be equal to the size of obj + REAL(DFP), INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_Add2 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Jan 2022 +! summary: Add selected values + +INTERFACE Add + MODULE SUBROUTINE obj_Add3(obj, nodenum, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add3 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add4(obj, nodenum, VALUE, scale) + TYPE(Realvector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add4 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Jan 2022 +! summary: Add selected values + +INTERFACE Add + MODULE SUBROUTINE obj_Add5(obj, nodenum, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add5 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Add range of values to a scalar +! +!@note +! We call F77_AXPY in this method +!@endnote + +INTERFACE Add + MODULE SUBROUTINE obj_Add6(obj, istart, iend, stride, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to be added + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + REAL(DFP), INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_Add6 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Add range of values to a vector +! +!@note! +! We call F77_AXPY +!@endnote + +INTERFACE Add + MODULE SUBROUTINE obj_Add7(obj, istart, iend, stride, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add7 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add8(obj, dofobj, nodenum, VALUE, & + scale, conversion) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: conversion(1) + END SUBROUTINE obj_Add8 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add9(obj, dofobj, nodenum, VALUE, & + scale) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add9 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add10(obj, dofobj, nodenum, VALUE, & + scale, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add10 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add11(obj, dofobj, nodenum, VALUE, & + scale, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add11 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add12(obj, dofobj, nodenum, VALUE, & + scale, ivar, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add12 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add13(obj, dofobj, nodenum, VALUE, & + scale, ivar, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add13 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add14(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add14 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add15(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add15 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add16(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + END SUBROUTINE obj_Add16 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add17(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + END SUBROUTINE obj_Add17 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add18(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add18 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Add2]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add19(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add19 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add20(obj, dofobj, nodenum, VALUE, & + scale) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add20 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add21(obj, dofobj, nodenum, VALUE, & + scale, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add21 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add22(obj, dofobj, nodenum, VALUE, & + scale, ivar, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_Add22 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add23(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add23 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add24(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo(:) + END SUBROUTINE obj_Add24 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Add1]] + +INTERFACE Add + MODULE SUBROUTINE obj_Add25(obj, dofobj, nodenum, VALUE, & + scale, ivar, spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + INTEGER(I4B), INTENT(IN) :: timecompo + END SUBROUTINE obj_Add25 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 June 2022 +! summary: obj1=obj2 + +INTERFACE Add + MODULE SUBROUTINE obj_Add26(obj, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + CLASS(RealVector_), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add26 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-29 +! summary: obj = obj + scale*VALUE +! +!# Introduction +! +! Value contains the nodal values of all dofs +! Number of cols in values should be at least equal to the total dof in obj +! Number of rows in values should be at least equal to the total nodes in obj + +INTERFACE Add + MODULE SUBROUTINE obj_Add27(obj, dofobj, VALUE, scale) + CLASS(RealVector_), INTENT(INOUT) :: obj + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + REAL(DFP), INTENT(IN) :: VALUE(:, :) + !! number of cols should be equal to the total dof in obj + !! number of rows should be equal to the total nodes in obj + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE obj_Add27 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-29 +! summary: obj = obj + scale*VALUE + +INTERFACE Add + MODULE SUBROUTINE obj_Add28(obj, dofobj, VALUE, scale, idof) + CLASS(RealVector_), INTENT(INOUT) :: obj + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + REAL(DFP), INTENT(IN) :: VALUE(:) + !! number of cols should be equal to the total dof in obj + !! number of rows should be equal to the total nodes in obj + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom in dofobj + END SUBROUTINE obj_Add28 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-29 +! summary: obj = obj + scale*VALUE + +INTERFACE Add + MODULE SUBROUTINE obj_Add29(obj1, dofobj1, idof1, obj2, dofobj2, idof2, & + scale) + TYPE(RealVector_), INTENT(INOUT) :: obj1 + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj1 + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof1 + !! global degree of freedom in dof1 + TYPE(RealVector_), INTENT(IN) :: obj2 + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj2 + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof2 + !! global degree of freedom in dof2 + REAL(DFP), INTENT(IN) :: scale + !! Scale + END SUBROUTINE obj_Add29 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-30 +! summary: Add range of values to a scalar + +INTERFACE Add + MODULE SUBROUTINE obj_Add30(obj, dofobj, istart, iend, stride, VALUE, & + idof, scale) + TYPE(RealVector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE + !! Scalar value + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + REAL(DFP), INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_Add30 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-30 +! summary: Add range of values to a vector + +INTERFACE Add + MODULE SUBROUTINE obj_Add31(obj, dofobj, istart, iend, stride, VALUE, & + idof, scale) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! ob(istart:iend:stride)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + REAL(DFP), INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_Add31 +END INTERFACE Add + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-30 +! summary: Add range of values to a vector + +INTERFACE Add + MODULE SUBROUTINE obj_Add32(obj, istart, iend, stride, VALUE, & + istart_value, iend_value, stride_value, scale) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! ob(istart:iend:stride)=VALUE + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value + !! range of values to set + REAL(DFP), INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_Add32 +END INTERFACE Add + +END MODULE RealVector_AddMethods diff --git a/src/modules/RealVector/src/RealVector_AppendMethods.F90 b/src/modules/RealVector/src/RealVector_AppendMethods.F90 new file mode 100644 index 000000000..a0970a40b --- /dev/null +++ b/src/modules/RealVector/src/RealVector_AppendMethods.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 RealVector_AppendMethods +USE GlobalData, ONLY: DFP +USE BaseType, ONLY: RealVector_ + +IMPLICIT NONE + +PRIVATE +PUBLIC :: Append + +!---------------------------------------------------------------------------- +! Append@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This subroutine appends value to [[RealVector_]] + +INTERFACE Append + MODULE PURE SUBROUTINE obj_Append1(obj, VALUE) + CLASS(RealVector_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE obj_Append1 +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This subroutine appends value to [[RealVector_]] + +INTERFACE Append + MODULE PURE SUBROUTINE obj_Append2(obj, VALUE) + CLASS(RealVector_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: VALUE(:) + END SUBROUTINE obj_Append2 +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This subroutine appends value to [[RealVector_]] + +INTERFACE Append + MODULE PURE SUBROUTINE obj_Append3(obj, anotherobj) + CLASS(RealVector_), INTENT(INOUT) :: obj + CLASS(RealVector_), INTENT(IN) :: anotherobj + END SUBROUTINE obj_Append3 +END INTERFACE Append + +END MODULE RealVector_AppendMethods diff --git a/src/modules/RealVector/src/RealVector_AssignMethods.F90 b/src/modules/RealVector/src/RealVector_AssignMethods.F90 new file mode 100644 index 000000000..d3d6d4502 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_AssignMethods.F90 @@ -0,0 +1,129 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_AssignMethods +USE GlobalData, ONLY: DFP, I4B, REAL32, REAL64 +USE BaseType, ONLY: RealVector_ + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign1(lhs, rhs) + CLASS(RealVector_), INTENT(INOUT) :: lhs + CLASS(RealVector_), INTENT(IN) :: rhs + END SUBROUTINE obj_assign1 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign2(lhs, rhs) + CLASS(RealVector_), INTENT(INOUT) :: lhs + CLASS(RealVector_), INTENT(IN) :: rhs(:) + END SUBROUTINE obj_assign2 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign3a(lhs, rhs) + CLASS(RealVector_), INTENT(INOUT) :: lhs + REAL(REAL32), INTENT(IN) :: rhs(:) + END SUBROUTINE obj_assign3a + + MODULE PURE SUBROUTINE obj_assign3b(lhs, rhs) + CLASS(RealVector_), INTENT(INOUT) :: lhs + REAL(REAL64), INTENT(IN) :: rhs(:) + END SUBROUTINE obj_assign3b +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign4a(lhs, rhs) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: lhs(:) + CLASS(RealVector_), INTENT(IN) :: rhs + END SUBROUTINE obj_assign4a + MODULE PURE SUBROUTINE obj_assign4b(lhs, rhs) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: lhs(:) + CLASS(RealVector_), INTENT(IN) :: rhs + END SUBROUTINE obj_assign4b +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign5a(lhs, rhs) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: lhs(:) + CLASS(RealVector_), INTENT(IN) :: rhs(:) + END SUBROUTINE obj_assign5a + MODULE PURE SUBROUTINE obj_assign5b(lhs, rhs) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: lhs(:) + CLASS(RealVector_), INTENT(IN) :: rhs(:) + END SUBROUTINE obj_assign5b +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign6(lhs, rhs) + CLASS(RealVector_), INTENT(INOUT) :: lhs + INTEGER(I4B), INTENT(IN) :: rhs(:) + END SUBROUTINE obj_assign6 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign7(lhs, rhs) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: lhs(:) + CLASS(RealVector_), INTENT(IN) :: rhs + END SUBROUTINE obj_assign7 +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Assign@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_assign8(lhs, rhs) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: lhs(:) + CLASS(RealVector_), INTENT(IN) :: rhs(:) + END SUBROUTINE obj_assign8 +END INTERFACE ASSIGNMENT(=) + +END MODULE RealVector_AssignMethods diff --git a/src/modules/RealVector/src/RealVector_Blas1Methods.F90 b/src/modules/RealVector/src/RealVector_Blas1Methods.F90 new file mode 100644 index 000000000..939e95f13 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_Blas1Methods.F90 @@ -0,0 +1,810 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 7 March 2021 +! summary: This module contains BLAS1 methods + +MODULE RealVector_Blas1Methods +USE GlobalData, ONLY: DFP, I4B, LGT, REAL32, REAL64 +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: ASUM +PUBLIC :: AXPY +PUBLIC :: COPY +PUBLIC :: Compact +PUBLIC :: DOT_PRODUCT +PUBLIC :: NORM2 +PUBLIC :: NORM1 +PUBLIC :: NORMi +PUBLIC :: SWAP +PUBLIC :: SCAL +PUBLIC :: PMUL +PUBLIC :: PDIV +PUBLIC :: Reciprocal + +!---------------------------------------------------------------------------- +! ASUM@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function computes the absolute sum of a vector +! +!# Introduction +! +! This function computes the absolute sum of a vector. +! +! $$\left| \left| V\right| \right|_{1} =\sum^{N}_{i=1} \left( \ +! \left| V_{i}\right| \right)$$ +! +!@note +! This function calls BLAS function ASUM. +!@endnote +! +!@todo +! subroutine test1 +! type( RealVector_ ) :: obj +! real( dfp ) :: ans +! obj = RealVector(arange(1,1000,1)) +! ans = ASUM(obj) +! call display( ans-sum(obj%val), "test1: 0 if correct : " ) +! end +!@endtodo + +INTERFACE ASUM + MODULE FUNCTION ASUMScalar(obj) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION ASUMScalar +END INTERFACE ASUM + +!---------------------------------------------------------------------------- +! ASUM@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function computes the absolute sum of a vector +!# Introduction +! +! This function computes the absolute sum of a vector. +! +! $$\left| \left| V\right| \right|_{1} =\sum^{N}_{i=1} \left( \ +! \left| V_{i}\right| \right)$$ +! +!@note +! This function calls [[ASUMScalar]] method +!@endnote +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 10, m=5 +! integer( i4b ) :: i +! type( RealVector_ ) :: obj( m ) +! real( dfp ) :: ans_l(m), ans +! do i = 1, m +! obj( i ) = RealVector(arange(1,n,1)) +! end do +! ans = 0.0 +! !$omp parallel default(shared) private( i ) reduction(+:ans) +! CALL OMP_INITIATE +! !$omp do +! do i = 1, m +! ans = ans + ASUM(obj(i)) !! no parallel +! enddo +! !$omp enddo +! CALL OMP_FINALIZE +! !$omp end parallel +! call display( ans - (m*sum(obj(1)%val)), "test2: 0 if correct : " ) +!``` +! +! Another example +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 100, m=5 +! integer( i4b ) :: i +! type( RealVector_ ) :: obj( m ) +! real( dfp ) :: ans_l(m), ans +! do i = 1, m +! obj( i ) = RealVector(arange(1,n,1)) +! end do +! ans = ASUM(obj) +! call display( ans - (m*sum(obj(1)%val)), "test3: 0 if correct : " ) +!``` + +INTERFACE ASUM + MODULE FUNCTION ASUMvector(obj) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj(:) + REAL(DFP) :: ans + END FUNCTION ASUMvector +END INTERFACE ASUM + +!---------------------------------------------------------------------------- +! AXPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 March 2021 +! summary: This subroutine computes AXPY +! +!# Introduction +! +! This subroutine performs following task +! +! $$Y=Y+A*X$$ +! +! Y = Y + A*X +! +! Here A is an scalar +! +!@note +! In joined state this subroutine creates new threads and share the work. +! If this subroutine is called within parallel block (i.e., forked state) +! then it does not create any new threads. Each thread will call this +! subroutine while X, Y, A treated as shared type. +!@endnote +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 100 +! integer( i4b ) :: i +! real( dfp ) :: a = 1.0_DFP +! type( RealVector_ ) :: x, y, z +! call random_number( x, n ) +! call random_number( y, n ) +! z%val = y%val + a * x%val +! call AXPY( x = x, y = y, A = a ) +! call display( ASUM(y%val - z%val), "test4: 0 if correct : " ) +!``` + +INTERFACE AXPY + MODULE SUBROUTINE scalarAXPYscalar(X, Y, A) + CLASS(RealVector_), INTENT(IN) :: X + CLASS(RealVector_), INTENT(INOUT) :: Y + REAL(DFP), INTENT(IN) :: A + END SUBROUTINE scalarAXPYscalar +END INTERFACE AXPY + +!---------------------------------------------------------------------------- +! AXPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 March 2021 +! summary: This subroutine computes AXPY +! +!# Introduction +! This subroutine performs following task +! +! $$Y=Y+A*X$$ +! +! Here A is an scalar +! +!@note +! In joined state this subroutine creates new threads and share the work. +! If this subroutine is called within parallel block (i.e., forked state) +! then it does not create any new threads. Each thread will call this +! subroutine while X, Y, A treated as shared type. +!@endnote +! + +INTERFACE AXPY + MODULE SUBROUTINE scalarAXPYintrinsic(X, Y, A) + REAL(DFP), INTENT(IN) :: X(:) + CLASS(RealVector_), INTENT(INOUT) :: Y + REAL(DFP), INTENT(IN) :: A + END SUBROUTINE scalarAXPYintrinsic +END INTERFACE AXPY + +!---------------------------------------------------------------------------- +! AXPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 March 2021 +! summary: This subroutine computes AXPY +! +!# Introduction +! This subroutine performs `AXPY` operation. It performs the following task. +! +! $$Y(i)=Y(i)+A(i)*X(i)$$ +! +! Here A is an vector of length same as size of `X` or `Y`. +! +!@note +! In joined state this subroutine creates new threads and share the work. +! If this subroutine is called within parallel block (i.e., forked state) +! then it does not create any new threads. Each thread will call this +! subroutine while X, Y, A treated as shared type. +!@endnote +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 100, m = 4 +! integer( i4b ) :: i, tsize(m) +! real( dfp ) :: a( m ), ans +! type( RealVector_ ), allocatable :: x( : ), y( : ), z( : ) +! tsize = m; a = 1.0 +! call random_number( x, tsize ) +! call random_number( y, tsize ) +! call initiate( z, tsize ) +! do i = 1, m +! z(i)%val = y(i)%val + a( i ) * x(i)%val +! end do +! call AXPY( x = x, y = y, A = a ) +! ans = 0.0 +! do i = 1, m +! ans = ans + ASUM( y(i)%val - z(i)%val ) +! end do +! call display( ans, "test5: 0 if correct : " ) +!``` + +INTERFACE AXPY + MODULE SUBROUTINE vectorAXPYvector(X, Y, A) + CLASS(RealVector_), INTENT(IN) :: X(:) + CLASS(RealVector_), INTENT(INOUT) :: Y(:) + REAL(DFP), INTENT(IN) :: A(:) + END SUBROUTINE vectorAXPYvector +END INTERFACE AXPY + +!---------------------------------------------------------------------------- +! COPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine copies one vector into another +! +!# Introduction +! This subroutine copies one [[RealVector_]] object into another object, i.e. +! `Y=X`. See figure given below: +! +! drawing +! +!@note +! This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. +!@endnote +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 10000 +! type( RealVector_ ) :: x, y +! real( dfp ), allocatable :: z( : ) +! call random_number( x, n ) +! call COPY( x = x, y = y ) +! call display( ASUM( x%val - y%val ), "test6: 0 if correct : " ) +! call COPY( y=z, x=x ) +! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) +! call COPY( y=x, x=z ) +! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) +!``` + +INTERFACE COPY + MODULE SUBROUTINE scalarCOPYscalar(Y, X) + TYPE(RealVector_), INTENT(INOUT) :: Y + CLASS(RealVector_), INTENT(IN) :: X + END SUBROUTINE scalarCOPYscalar +END INTERFACE COPY + +!---------------------------------------------------------------------------- +! COPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine copies one vector into another +! +!# Introduction +! This subroutine COPY a fortran vector into [[RealVector_]] obj, i.e. `Y=X` +! +!@note +! This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. +!@endnote +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 10000 +! type( RealVector_ ) :: x, y +! real( dfp ), allocatable :: z( : ) +! call random_number( x, n ) +! call COPY( x = x, y = y ) +! call display( ASUM( x%val - y%val ), "test6: 0 if correct : " ) +! call COPY( y=z, x=x ) +! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) +! call COPY( y=x, x=z ) +! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) +!``` + +INTERFACE COPY + MODULE SUBROUTINE scalarCOPYintrinsic_1a(Y, X) + CLASS(RealVector_), INTENT(INOUT) :: Y + REAL(REAL32), INTENT(IN) :: X(:) + END SUBROUTINE scalarCOPYintrinsic_1a +END INTERFACE COPY + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE COPY + MODULE SUBROUTINE scalarCOPYintrinsic_1b(Y, X) + CLASS(RealVector_), INTENT(INOUT) :: Y + REAL(REAL64), INTENT(IN) :: X(:) + END SUBROUTINE scalarCOPYintrinsic_1b +END INTERFACE COPY + +!---------------------------------------------------------------------------- +! COPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine copies one vector into another +! +!# Introduction +! This subroutine COPY an instance of [[RealVector_]] in another fortran +! vector, i.e. `Val=obj` +! +!@note +! This subroutine internally calls [[intrinsicCOPYintrinsic]]. Also `Val` +! is allocatable. +!@endnote +! +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 10000 +! type( RealVector_ ) :: x, y +! real( dfp ), allocatable :: z( : ) +! call random_number( x, n ) +! call COPY( x = x, y = y ) +! call display( ASUM( x%val - y%val ), "test6: 0 if correct : " ) +! call COPY( y=z, x=x ) +! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) +! call COPY( y=x, x=z ) +! call display( ASUM( z - x%val ), "test6: 0 if correct : " ) +!``` + +INTERFACE COPY + MODULE SUBROUTINE intrinsicCOPYscalar_1a(Y, X) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X + END SUBROUTINE intrinsicCOPYscalar_1a +END INTERFACE COPY + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE COPY + MODULE SUBROUTINE intrinsicCOPYscalar_1b(Y, X) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X + END SUBROUTINE intrinsicCOPYscalar_1b +END INTERFACE + +!---------------------------------------------------------------------------- +! COPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine copies one vector into another +! +!# Introduction +! This subroutine COPY a vector of [[RealVector_]] into another vector, i.e. +! `obj1=obj2` see the figure below: +! +! drawing +! +!@note +!This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. Also +! note that `obj1` and `obj2` are vectors of [[RealVector_]] data type. +!@endnote +! +! +!### Usage +! +!```fortran +! integer( i4b ), parameter :: n = 10000, m = 5 +! type( RealVector_ ), allocatable :: x( : ), y( : ) +! integer( i4b ) :: tsize( m ), i +! real( dfp ), allocatable :: z( : ) +! real( dfp ) :: ans +! tsize = n +! call random_number(x, tsize) +! call COPY( x = x, y = y ) +! ans = 0.0 +! do i = 1, size( x ) +! ans = ans + ASUM( x(i)%val - y(i)%val ) +! end do +! call display( ans, "test7: 0 if correct : " ) +!``` + +INTERFACE COPY + MODULE SUBROUTINE vectorCOPYvector(Y, X) + TYPE(RealVector_), INTENT(INOUT), ALLOCATABLE :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X(:) + END SUBROUTINE vectorCOPYvector +END INTERFACE COPY + +!---------------------------------------------------------------------------- +! COPY@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine copies one vector into another +! +!# Introduction +! This subroutine copies a vector of [[RealVector_]] into a scalar instance +! of [[RealVector_]]. See Figure below: +! +! drawing +! +!@note +! This subroutine internally uses [[intrinsicCOPYintrinsic]] routine. +!@endnote +! +!@todo +! need parallel +!@endtodo + +INTERFACE COPY + MODULE SUBROUTINE scalarCOPYvector(Y, X) + TYPE(RealVector_), INTENT(INOUT) :: Y + CLASS(RealVector_), INTENT(IN) :: X(:) + END SUBROUTINE scalarCOPYvector +END INTERFACE COPY + +!---------------------------------------------------------------------------- +! Compact@BLAS1V +!---------------------------------------------------------------------------- + +INTERFACE Compact + MODULE SUBROUTINE Compact_real_1(Val, row) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Val(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE +END INTERFACE Compact + +!---------------------------------------------------------------------------- +! Compact@BLAS1V +!---------------------------------------------------------------------------- + +INTERFACE Compact + MODULE SUBROUTINE Compact_int_1(Val, row) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Val(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE +END INTERFACE Compact + +!---------------------------------------------------------------------------- +! DOT@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine returns dot product of two [[RealVector_]] +! +!@todo +! type(_obj_) :: obj1, obj2 +! call RANDOM_NUMBER( obj1, 100 ) +! call RANDOM_NUMBER( obj2, 100 ) +! CALL Display( DOT(obj1, obj2), "dot 1=" ) +!@endtodo + +INTERFACE DOT_PRODUCT + MODULE PURE FUNCTION scalarDOTscalar(obj1, obj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj1, obj2 + REAL(DFP) :: ans + END FUNCTION scalarDOTscalar +END INTERFACE DOT_PRODUCT + +!---------------------------------------------------------------------------- +! DOT@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine computes dot product of a fortran array and scalar +! instance of [[RealVector_]] +! +!@todo +! type(_obj_) :: obj1 +! real( dfp ) :: val( 100 ) +! call RANDOM_NUMBER( obj1, 100 ) +! call RANDOM_NUMBER( val ) +! CALL Display( DOT(obj1, val), "dot =" ) +!@endtodo + +INTERFACE DOT_PRODUCT + MODULE PURE FUNCTION scalarDOTintrinsic(obj, Val) RESULT(ans) + REAL(DFP), INTENT(IN) :: Val(:) + CLASS(RealVector_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION scalarDOTintrinsic +END INTERFACE DOT_PRODUCT + +!---------------------------------------------------------------------------- +! DOT@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routines returns the dot product of vector of +! [[RealVector_]] data type. +! +!@todo +! type(_obj_) :: obj1(2), obj2(2) +! call RANDOM_NUMBER( obj1(1), 100 ) +! call RANDOM_NUMBER( obj1(2), 100 ) +! obj2 = obj1 +! CALL Display( DOT(obj1, obj2), "dot =" ) +!@endtodo + +INTERFACE DOT_PRODUCT + MODULE PURE FUNCTION vectorDOTvector(obj1, obj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj1(:), obj2(:) + REAL(DFP) :: ans + END FUNCTION vectorDOTvector +END INTERFACE DOT_PRODUCT + +!---------------------------------------------------------------------------- +! DOT@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine computes dot product of a vector of [[RealVector_]] +! and scalar of [[RealVector_]] +! +!@todo +! type(_obj_) :: obj1(2), obj2(2) +! call RANDOM_NUMBER( obj1(1), 100 ) +! call RANDOM_NUMBER( obj1(2), 100 ) +! obj2 = obj1 +! CALL Display( DOT(obj1, obj2), "dot =" ) +!@endtodo + +INTERFACE DOT_PRODUCT + MODULE PURE FUNCTION vectorDOTscalar(obj1, obj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj1(:), obj2 + REAL(DFP) :: ans + END FUNCTION vectorDOTscalar +END INTERFACE DOT_PRODUCT + +!---------------------------------------------------------------------------- +! DOT@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine computes dot product of a scalar of [[RealVector_]] +! and vector of [[RealVector_]] +! +!### Usage +! +!```fortran +! type(_obj_) :: obj1 +! real( dfp ) :: val( 100 ) +! call RANDOM_NUMBER( obj1, 100 ) +! call RANDOM_NUMBER( val ) +! CALL Display( DOT(obj1, val), "dot =" ) +!``` + +INTERFACE DOT_PRODUCT + MODULE PURE FUNCTION scalarDOTvector(obj1, obj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj1, obj2(:) + REAL(DFP) :: ans + END FUNCTION scalarDOTvector +END INTERFACE DOT_PRODUCT + +!---------------------------------------------------------------------------- +! Norm2@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function computes Euclidean norm of [[RealVector_]] +! +!# Introduction +! +! L2 norm of a vector is give by +! +! $$\left| \left| \bf{V} \right| \right| =\sqrt{\bf{V} \cdot \bf{V} }$$ +! +!@note +! This subroutine uses DOT function. +!@endnote +! +!### Usage +! +!```fortran +!s = NORM2(obj) +!``` + +INTERFACE NORM2 + MODULE PURE FUNCTION NRM2scalar(obj) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION NRM2scalar +END INTERFACE NORM2 + +!---------------------------------------------------------------------------- +! Norm2@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This routine computes the L2 norm of [[RealVector_]] +! +!# Introduction +! +! This routine computes L2 norm of a vector of [[RealVector_]]. +! +!@note +! This function employs DOT function. +!@endnote +! +!@todo +! type(_obj_) :: obj1 +! real( dfp ) :: val( 100 ) +! call RANDOM_NUMBER( obj1, 100 ) +! call RANDOM_NUMBER( val ) +! CALL Display( DOT(obj1, val), "dot =" ) +!@endtodo + +INTERFACE NORM2 + MODULE PURE FUNCTION NRM2vector(obj) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj(:) + REAL(DFP) :: ans + END FUNCTION NRM2vector +END INTERFACE NORM2 + +!---------------------------------------------------------------------------- +! Norm2@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function computes the l1 norm + +INTERFACE NORM1 + MODULE FUNCTION obj_NORM1(obj) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION obj_NORM1 +END INTERFACE NORM1 + +!---------------------------------------------------------------------------- +! Norm2@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function computes the l1 norm + +INTERFACE NORMi + MODULE FUNCTION obj_NORMi(obj) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + REAL(DFP) :: ans + END FUNCTION obj_NORMi +END INTERFACE NORMi + +!---------------------------------------------------------------------------- +! SWAP@BLAS1 +!---------------------------------------------------------------------------- + +INTERFACE SWAP + MODULE PURE SUBROUTINE scalarSWAPscalar(X, Y) + CLASS(RealVector_), INTENT(INOUT) :: X + CLASS(RealVector_), INTENT(INOUT) :: Y + END SUBROUTINE scalarSWAPscalar + + MODULE PURE SUBROUTINE vectorSWAPvector(X, Y) + CLASS(RealVector_), INTENT(INOUT) :: X(:) + CLASS(RealVector_), INTENT(INOUT) :: Y(:) + END SUBROUTINE vectorSWAPvector + + MODULE PURE SUBROUTINE scalarSWAPintrinsic(X, Y) + CLASS(RealVector_), INTENT(INOUT) :: X + REAL(DFP), INTENT(INOUT) :: Y(:) + END SUBROUTINE scalarSWAPintrinsic +END INTERFACE SWAP + +!---------------------------------------------------------------------------- +! SCALE@BLAS1 +!---------------------------------------------------------------------------- + +INTERFACE SCAL + MODULE PURE SUBROUTINE SCALscalar(X, A) + CLASS(RealVector_), INTENT(INOUT) :: X + REAL(DFP), INTENT(IN) :: A + END SUBROUTINE SCALscalar + + MODULE PURE SUBROUTINE SCALvector(X, A) + CLASS(RealVector_), INTENT(INOUT) :: X(:) + REAL(DFP), INTENT(IN) :: A + END SUBROUTINE SCALvector +END INTERFACE SCAL + +!---------------------------------------------------------------------------- +! PMUL@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-28 +! summary: obj = obj1 * obj2 + +INTERFACE PMUL + MODULE SUBROUTINE obj_PMUL1(obj, obj1, obj2) + CLASS(RealVector_), INTENT(INOUT) :: obj + CLASS(RealVector_), INTENT(IN) :: obj1 + CLASS(RealVector_), INTENT(IN) :: obj2 + END SUBROUTINE obj_PMUL1 +END INTERFACE PMUL + +!---------------------------------------------------------------------------- +! PMUL@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-28 +! summary: obj = obj1 / obj2 + +INTERFACE PDIV + MODULE SUBROUTINE obj_PDIV1(obj, obj1, obj2, check_divide_by_zero) + CLASS(RealVector_), INTENT(INOUT) :: obj + CLASS(RealVector_), INTENT(IN) :: obj1 + CLASS(RealVector_), INTENT(IN) :: obj2 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: check_divide_by_zero + END SUBROUTINE obj_PDIV1 +END INTERFACE PDIV + +!---------------------------------------------------------------------------- +! PMUL@BLAS1 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-28 +! summary: Reciprocal obj1 = 1.0/obj2 + +INTERFACE Reciprocal + MODULE SUBROUTINE obj_Reciprocal1(obj1, obj2, check_divide_by_zero) + CLASS(RealVector_), INTENT(INOUT) :: obj1 + CLASS(RealVector_), INTENT(IN) :: obj2 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: check_divide_by_zero + END SUBROUTINE obj_Reciprocal1 +END INTERFACE Reciprocal + +END MODULE RealVector_Blas1Methods diff --git a/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 b/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 new file mode 100644 index 000000000..2d6bfd5da --- /dev/null +++ b/src/modules/RealVector/src/RealVector_ComparisonMethods.F90 @@ -0,0 +1,40 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE RealVector_ComparisonMethods +USE GlobalData, ONLY: LGT +USE BaseType, ONLY: RealVector_ + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: OPERATOR(.EQ.) + +!---------------------------------------------------------------------------- +! EQ +!---------------------------------------------------------------------------- + +INTERFACE OPERATOR(.EQ.) + MODULE PURE FUNCTION obj_isEqual(obj, obj2) RESULT(Ans) + CLASS(RealVector_), INTENT(IN) :: obj + CLASS(RealVector_), INTENT(IN) :: obj2 + LOGICAL(LGT) :: ans + END FUNCTION obj_isEqual +END INTERFACE OPERATOR(.EQ.) + +END MODULE RealVector_ComparisonMethods diff --git a/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 b/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 new file mode 100644 index 000000000..90259cff1 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_ConstructorMethods.F90 @@ -0,0 +1,453 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_ConstructorMethods +USE GlobalData, ONLY: I4B, DFP, LGT +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Shape +PUBLIC :: SIZE +PUBLIC :: GetTotalDimension +PUBLIC :: SetTotalDimension +PUBLIC :: ALLOCATE +PUBLIC :: DEALLOCATE +PUBLIC :: Initiate +PUBLIC :: RANDOM_NUMBER +PUBLIC :: RealVector +PUBLIC :: RealVector_Pointer +PUBLIC :: Reallocate +PUBLIC :: isAllocated +PUBLIC :: isInitiated + +!---------------------------------------------------------------------------- +! isAllocated@EnquireMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! summary: Returns true if the instance is allocated + +INTERFACE isAllocated + MODULE PURE FUNCTION obj_isAllocated(obj) RESULT(Ans) + CLASS(RealVector_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION obj_isAllocated +END INTERFACE isAllocated + +INTERFACE isInitiated + MODULE PROCEDURE obj_isAllocated +END INTERFACE isInitiated + +!---------------------------------------------------------------------------- +! Shape@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Feb 2021 +! summary: This function returns the shape of RealVector_ + +INTERFACE Shape + MODULE PURE FUNCTION obj_shape(obj) RESULT(Ans) + CLASS(RealVector_), INTENT(IN) :: obj + INTEGER(I4B) :: Ans(1) + END FUNCTION obj_shape +END INTERFACE Shape + +!---------------------------------------------------------------------------- +! SIZE@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Feb 2021 +! summary: This function returns the size of RealVector_ + +INTERFACE Size + MODULE PURE FUNCTION obj_size(obj, Dims) RESULT(Ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims + INTEGER(I4B) :: Ans + END FUNCTION obj_size +END INTERFACE Size + +!---------------------------------------------------------------------------- +! TotalDimension@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Returns the total dimension of an array +! +!# Introduction +! +! This function returns the total dimension (or rank) of an array, + +INTERFACE GetTotalDimension + MODULE PURE FUNCTION RealVec_GetTotalDimension(obj) RESULT(Ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION RealVec_GetTotalDimension +END INTERFACE GetTotalDimension + +!---------------------------------------------------------------------------- +! SetTotalDimension@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine Set the total dimension (rank) of an array +! +!# Introduction +! +! This subroutine Sets the rank(total dimension) of an array + +INTERFACE SetTotalDimension + MODULE PURE SUBROUTINE RealVec_SetTotalDimension(obj, tDimension) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tDimension + END SUBROUTINE RealVec_SetTotalDimension +END INTERFACE SetTotalDimension + +!---------------------------------------------------------------------------- +! Allocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Feb 2021 +! summary: This subroutine allocates memory for RealVector + +INTERFACE ALLOCATE + MODULE PURE SUBROUTINE obj_Allocate(obj, Dims) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Dims + END SUBROUTINE obj_Allocate +END INTERFACE ALLOCATE + +!---------------------------------------------------------------------------- +! Reallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Allocate memory for the vector + +INTERFACE Reallocate + MODULE PURE SUBROUTINE obj_Reallocate(obj, row) + TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE obj_Reallocate +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Deallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Feb 2021 +! summary: This subroutine deallocates the data in RealVector_ + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE obj_Deallocate(obj) + CLASS(RealVector_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Feb 2021 +! summary: This subroutine allocates the memory for RealVector_ +! +!# Introduction This subroutine allocates the memeory for RealVector_ +! +!@note +! This subroutine is an alias for Allocate_Data +!@endnote + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_initiate1(obj, tSize) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tSize + END SUBROUTINE obj_initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Feb 2021 +! summary: This subroutine allocate the memory for a vector of type +! RealVector_ +! +!# Introduction +! This subroutine allocate the memory for a vector of type RealVector_ +!@note +! The size of `obj` would be same as the size of `tSize` +!@endnote + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_Initiate2(obj, tSize) + TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: tSize(:) + END SUBROUTINE obj_Initiate2 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Feb 2021 +! summary: This subroutine allocate the memory for an instance of +! RealVector_ +! +!# Introduction +! This subroutine allocate the memory for an instance of RealVector_. +! User can specify the lowerbounds and upper bounds. + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_Initiate3(obj, a, b) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: a, b + END SUBROUTINE obj_Initiate3 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Initiate RealVector_ using dof_ object +! +!# Introduction +! +! This subroutine initiate RealVector_ using the information stored inside +! dof_ object. It Gets the information of total size of RealVector_ +! from DOF_ and call RealVector_Method:Initiate routine. +! All values of RealVector_ is Set to zero. + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_Initiate4(obj, dofobj) + CLASS(RealVector_), INTENT(INOUT) :: obj + CLASS(DOF_), INTENT(IN) :: dofobj + END SUBROUTINE obj_Initiate4 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct, 2021 +! summary: Initiate a vector of realvector_ from dof_ object +! +!# Introduction +! +! This subroutine initiates a vector of realvector_ object. +! The size of `val` will be total number of degrees of freedom inside +! the DOF_ object. Therefore, each `val( idof )` denotes the +! nodal vector of correrponding to a degree of freedom number `idof` + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_Initiate5(obj, dofobj) + TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + CLASS(DOF_), INTENT(IN) :: dofobj + END SUBROUTINE obj_Initiate5 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Random_number@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This routine computes radom_number +! +!# Introduction +! +! This routine calls `RANDOM_NUMBER` to generate a random instnance of +! RealVector_ + +INTERFACE RANDOM_NUMBER + MODULE SUBROUTINE obj_Random_Number1(obj, tsize) + CLASS(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tsize + END SUBROUTINE obj_Random_Number1 +END INTERFACE RANDOM_NUMBER + +!---------------------------------------------------------------------------- +! Random_number@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This routine computes radom_number +! +!# Introduction +! +! This routine calls `RANDOM_NUMBER` to generate a random instnance of +! RealVector_ +! +!@note +! Here argument `obj` is a vector of RealVector_ data-types. +!@endnote + +INTERFACE RANDOM_NUMBER + MODULE SUBROUTINE obj_Random_Number2(obj, tsize) + TYPE(RealVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: tsize(:) + END SUBROUTINE obj_Random_Number2 +END INTERFACE RANDOM_NUMBER + +!---------------------------------------------------------------------------- +! RealVector@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns an instance of RealVector_ +! +!# Introduction +! +! This function returns an instance of RealVector_ + +INTERFACE RealVector + MODULE PURE FUNCTION obj_Constructor1(tSize) RESULT(obj) + TYPE(RealVector_) :: obj + INTEGER(I4B), INTENT(IN) :: tSize + END FUNCTION obj_Constructor1 +END INTERFACE RealVector + +!---------------------------------------------------------------------------- +! RealVector@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns an instance of RealVector_ +! +!# Introduction +! This function returns an instance of RealVector_ by copying the +! contents of a fortran integer vector. +! +!@note +! This routine internally calls RealVector_Method:COPY routine. +!@endnote + +INTERFACE RealVector + MODULE PURE FUNCTION obj_Constructor2(Val) RESULT(obj) + TYPE(RealVector_) :: obj + INTEGER(I4B), INTENT(IN) :: Val(:) + END FUNCTION obj_Constructor2 +END INTERFACE RealVector + +!---------------------------------------------------------------------------- +! RealVector@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns an instance of RealVector_ +! +!# Introduction +! This function returns an instance of RealVector_ by copying the +! contents of a fortran real vector. +! +!@note +! This routine internally calls RealVector_Method:COPY routine. +!@endnote + +INTERFACE RealVector + MODULE PURE FUNCTION obj_Constructor3(Val) RESULT(obj) + TYPE(RealVector_) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + END FUNCTION obj_Constructor3 +END INTERFACE RealVector + +!---------------------------------------------------------------------------- +! RealVector_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returnt the pointer to a newly created instance of +! RealVector_ +! +!# Introduction +! This function returnt the pointer to a newly created instance of +! RealVector_ + +INTERFACE RealVector_Pointer + MODULE PURE FUNCTION obj_Constructor_1(tSize) RESULT(obj) + CLASS(RealVector_), POINTER :: obj + INTEGER(I4B), INTENT(IN) :: tSize + END FUNCTION obj_Constructor_1 +END INTERFACE RealVector_Pointer + +!---------------------------------------------------------------------------- +! RealVector_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns the pointer to an instance ofRealVector_ +! +!# Introduction +! This function returns a pointer to an newly created instance of +! RealVector_ by copying the contents of a fortran integer vector. +! +!@note +! This routine internally calls RealVector_Method:COPY routine. +!@endnote + +INTERFACE RealVector_Pointer + MODULE PURE FUNCTION obj_Constructor_2(Val) RESULT(obj) + CLASS(RealVector_), POINTER :: obj + INTEGER(I4B), INTENT(IN) :: Val(:) + END FUNCTION obj_Constructor_2 +END INTERFACE RealVector_Pointer + +!---------------------------------------------------------------------------- +! RealVector_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns the pointer to an instance ofRealVector_ +! +!# Introduction +! This function returns a pointer to an newly created instance of +! RealVector_ by copying the contents of a fortran real vector. +! +!@note +! This routine internally calls RealVector_Method:COPY routine. +!@endnote + +INTERFACE RealVector_Pointer + MODULE PURE FUNCTION obj_Constructor_3(Val) RESULT(obj) + CLASS(RealVector_), POINTER :: obj + REAL(DFP), INTENT(IN) :: Val(:) + END FUNCTION obj_Constructor_3 +END INTERFACE RealVector_Pointer + +END MODULE RealVector_ConstructorMethods diff --git a/src/modules/RealVector/src/RealVector_GetMethods.F90 b/src/modules/RealVector/src/RealVector_GetMethods.F90 new file mode 100644 index 000000000..fed8f2c22 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_GetMethods.F90 @@ -0,0 +1,708 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_GetMethods +USE GlobalData, ONLY: DFP, I4B, LGT, REAL32, REAL64 + +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetIndex +PUBLIC :: Get +PUBLIC :: IsPresent +PUBLIC :: GetPointer + +!---------------------------------------------------------------------------- +! GetPointer@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: Returns the pointer to vector of real numbers in [[RealVector_]] +! +!# Introduction +! +! This function returns the pointer to vector of real numbers stored +! inside [[RealVector_]] + +INTERFACE GetPointer + MODULE FUNCTION obj_GetPointer1(obj) RESULT(val) + TYPE(RealVector_), INTENT(IN), TARGET :: obj + REAL(DFP), POINTER :: val(:) + END FUNCTION obj_GetPointer1 +END INTERFACE GetPointer + +!---------------------------------------------------------------------------- +! GetPointer@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: Returns the pointer to vector of real numbers +! +!# Introduction +! This function returns the pointer to vector of real numbers stored +! inside [[RealVector_]] for a given degree of freedom + +INTERFACE GetPointer + MODULE FUNCTION obj_GetPointer2(obj, dofobj, idof) RESULT(val) + TYPE(RealVector_), INTENT(IN), TARGET :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), POINTER :: val(:) + END FUNCTION obj_GetPointer2 +END INTERFACE GetPointer + +!---------------------------------------------------------------------------- +! GetIndex@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function finds location of value inside the [[RealVector_]] +! +!# Introduction +! +! This function finds the location of `value` inside the instance of +! [[RealVector_]] + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex1(obj, VALUE, tol) RESULT(Ans) + TYPE(RealVector_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + INTEGER(I4B) :: Ans + END FUNCTION obj_GetIndex1 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! IndexOf@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: Returns location of values inside the [[RealVector_]] +! +!# Introduction +! +! This function returns the nearest location of values inside the +! [[RealVector_]] + +INTERFACE GetIndex + MODULE PURE FUNCTION obj_GetIndex2(obj, VALUE, tol) RESULT(Ans) + TYPE(RealVector_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + INTEGER(I4B), ALLOCATABLE :: Ans(:) + END FUNCTION obj_GetIndex2 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! IsPresent@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: Returns true if value is present inside [[RealVector_]] + +INTERFACE IsPresent + MODULE PURE FUNCTION obj_IsPresent1(obj, VALUE, tol) RESULT(Ans) + TYPE(RealVector_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION obj_IsPresent1 +END INTERFACE IsPresent + +!---------------------------------------------------------------------------- +! IsPresentGetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: Returns true if value is present inside [[RealVector_]] + +INTERFACE IsPresent + MODULE PURE FUNCTION obj_IsPresent2(obj, VALUE, tol) RESULT(Ans) + TYPE(RealVector_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: VALUE(:) + REAL(DFP), OPTIONAL, INTENT(IN) :: tol + LOGICAL(LGT), ALLOCATABLE :: Ans(:) + END FUNCTION obj_IsPresent2 +END INTERFACE IsPresent + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of Integer from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get1(obj, dataType) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: dataType + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get1 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of integer from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get2(obj, nodenum, dataType) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: dataType + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get2 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of integer from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get3(obj, istart, iend, stride, dataType) & + RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(I4B), INTENT(IN) :: dataType + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get3 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get4a(obj, dataType) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + REAL(REAL32), INTENT(IN) :: dataType + REAL(REAL32), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get4a + + MODULE PURE FUNCTION obj_Get4b(obj, dataType) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + REAL(REAL64), INTENT(IN) :: dataType + REAL(REAL64), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get4b +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get5a(obj, nodenum, dataType) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(REAL32), INTENT(IN) :: dataType + REAL(REAL32), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get5a + MODULE PURE FUNCTION obj_Get5b(obj, nodenum, dataType) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(REAL64), INTENT(IN) :: dataType + REAL(REAL64), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get5b +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get6(obj, istart, iend, stride, dataType) & + RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + REAL(DFP), INTENT(IN) :: dataType + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get6 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns the vector of integer from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get7(obj, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: dataType + INTEGER(I4B), ALLOCATABLE :: val(:) + END FUNCTION obj_Get7 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of integer from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get8(obj, nodenum, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: dataType + INTEGER(I4B), ALLOCATABLE :: val(:) + END FUNCTION obj_Get8 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns an integer vector from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get9(obj, istart, iend, stride, dataType) & + RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: istart + INTEGER(I4B), INTENT(IN) :: iend + INTEGER(I4B), INTENT(IN) :: stride + INTEGER(I4B), INTENT(IN) :: dataType + INTEGER(I4B), ALLOCATABLE :: val(:) + END FUNCTION obj_Get9 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get10a(obj, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + REAL(REAL32), INTENT(IN) :: dataType + REAL(REAL32), ALLOCATABLE :: val(:) + END FUNCTION obj_Get10a + + MODULE PURE FUNCTION obj_Get10b(obj, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + REAL(REAL64), INTENT(IN) :: dataType + REAL(REAL64), ALLOCATABLE :: val(:) + END FUNCTION obj_Get10b +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get11a(obj, nodenum, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + REAL(REAL32), INTENT(IN) :: dataType + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(REAL32), ALLOCATABLE :: val(:) + END FUNCTION obj_Get11a + + MODULE PURE FUNCTION obj_Get11b(obj, nodenum, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + REAL(REAL64), INTENT(IN) :: dataType + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(REAL64), ALLOCATABLE :: val(:) + END FUNCTION obj_Get11b +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get12a(obj, istart, iend, stride, dataType) & + RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + REAL(REAL32), INTENT(IN) :: dataType + REAL(REAL32), ALLOCATABLE :: val(:) + END FUNCTION obj_Get12a + + MODULE PURE FUNCTION obj_Get12b(obj, istart, iend, stride, & + & dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + REAL(REAL64), INTENT(IN) :: dataType + REAL(REAL64), ALLOCATABLE :: val(:) + END FUNCTION obj_Get12b +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns the instance of [[RealVector_]] +! +!# Introduction +! This function returns an scalar instance of [[RealVector_]] by +! combining different entries of a vector of [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get13(obj, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + TYPE(RealVector_), INTENT(IN) :: dataType + TYPE(RealVector_) :: val + END FUNCTION obj_Get13 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns the instance of [[RealVector_]] +! +!# Introduction +! This function returns the instance of [[RealVector_]] from the vector of +! [[RealVector_]]. + +INTERFACE Get + MODULE PURE FUNCTION obj_Get14(obj, nodenum, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: nodenum(:) + TYPE(RealVector_), INTENT(IN) :: dataType + TYPE(RealVector_) :: val + END FUNCTION obj_Get14 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns the instance of [[RealVector_]] +! +!# Introduction +! This function returns the instance of [[RealVector_]] from the vector of +! [[RealVector_]]. + +INTERFACE Get + MODULE PURE FUNCTION obj_Get15(obj, istart, iend, stride, & + dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + TYPE(RealVector_), INTENT(IN) :: dataType + TYPE(RealVector_) :: val + END FUNCTION obj_Get15 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns an instance of [[RealVector_]] +! +!# Introduction +! +! This function returns an instance of [[RealVector_]] by using selective +! from `obj` + +INTERFACE Get + MODULE PURE FUNCTION obj_Get16(obj, nodenum, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + TYPE(RealVector_), INTENT(IN) :: dataType + TYPE(RealVector_) :: val + END FUNCTION obj_Get16 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns the instance of [[RealVector_]] +! +!# Introduction +! This function returns the instance of [[RealVector_]] using istart, iend, +! stride values + +INTERFACE Get + MODULE PURE FUNCTION obj_Get17(obj, istart, iend, stride, & + dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + TYPE(RealVector_), INTENT(IN) :: dataType + TYPE(RealVector_) :: val + END FUNCTION obj_Get17 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION obj_Get18a(obj, nodenum, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(REAL32), INTENT(IN) :: dataType + REAL(REAL32) :: val + END FUNCTION obj_Get18a + + MODULE PURE FUNCTION obj_Get18b(obj, nodenum, dataType) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + REAL(REAL64), INTENT(IN) :: dataType + REAL(REAL64) :: val + END FUNCTION obj_Get18b +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get19(obj) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get19 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get20(obj, nodenum) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get20 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get21(obj, istart, iend, stride) & + RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get21 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get22(obj) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE :: val(:) + END FUNCTION obj_Get22 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get23(obj, nodenum) RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), ALLOCATABLE :: val(:) + END FUNCTION obj_Get23 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get24(obj, istart, iend, stride) & + RESULT(val) + TYPE(RealVector_), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + REAL(DFP), ALLOCATABLE :: val(:) + END FUNCTION obj_Get24 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get25(obj, dofobj, nodenum, ivar, idof) & + RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP) :: ans + END FUNCTION obj_Get25 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get26(obj, dofobj, nodenum, ivar, idof) & + RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP) :: ans(SIZE(nodenum)) + END FUNCTION obj_Get26 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get27(obj, dofobj, nodenum, ivar) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get27 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get28(obj, dofobj, nodenum, & + ivar, spacecompo, timecompo) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spacecompo + INTEGER(I4B), INTENT(IN) :: timecompo + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get28 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Feb 2021 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE Get + MODULE PURE FUNCTION obj_Get29(obj, dofobj, idof) RESULT(ans) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: idof + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION obj_Get29 +END INTERFACE Get + +END MODULE RealVector_GetMethods diff --git a/src/modules/RealVector/src/RealVector_GetValueMethods.F90 b/src/modules/RealVector/src/RealVector_GetValueMethods.F90 new file mode 100644 index 000000000..cff868762 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_GetValueMethods.F90 @@ -0,0 +1,1168 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_GetValueMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: DOF_, RealVector_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetValue +PUBLIC :: GetValue_ + +INTERFACE GetValue_ +MODULE PROCEDURE obj_GetValue1, obj_GetValue2, obj_GetValue3, obj_GetValue4, & + obj_GetValue5, obj_GetValue6, obj_GetValue7, obj_GetValue8, & + obj_GetValue9, obj_GetValue10, obj_GetValue11, obj_GetValue15, & + obj_GetValue24 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. +! +!@note +! We call set method +!@endnote + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue1(obj, VALUE, istart, iend, stride) + TYPE(RealVector_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + TYPE(RealVector_), INTENT(INOUT) :: VALUE + END SUBROUTINE obj_GetValue1 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. +! +!@note +! We call set method +!@endnote + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue2(obj, dofobj, VALUE, idof) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_GetValue2 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue3(obj, dofobj, VALUE, ivar, idof) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_GetValue3 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue4(obj, dofobj, VALUE, ivar, & + spaceCompo, timeCompo) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spaceCompo + INTEGER(I4B), INTENT(IN) :: timeCompo + END SUBROUTINE obj_GetValue4 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue5(obj, dofobj, idofobj, & + VALUE, dofvalue, idofvalue) + TYPE(RealVector_), INTENT(IN) :: obj + !! Real vector whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! DOF for obj + INTEGER(I4B), INTENT(IN) :: idofobj + !! idof for obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + !! real vector to be returned + TYPE(DOF_), INTENT(IN) :: dofvalue + !! dof for value + INTEGER(I4B), INTENT(IN) :: idofvalue + !! idof for value + END SUBROUTINE obj_GetValue5 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. +! +!@note +! The size of idofobj and idofvalue should be equal. +!@endnote + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue6(obj, dofobj, idofobj, & + VALUE, dofvalue, idofvalue) + TYPE(RealVector_), INTENT(IN) :: obj + !! Real vector whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! DOF for obj + INTEGER(I4B), INTENT(IN) :: idofobj(:) + !! idof for obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + !! values to be returned + TYPE(DOF_), INTENT(IN) :: dofvalue + !! dof for value + INTEGER(I4B), INTENT(IN) :: idofvalue(:) + !! idof for value + END SUBROUTINE obj_GetValue6 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue7(obj, dofobj, ivarobj, idofobj, & + VALUE, dofvalue, ivarvalue, idofvalue) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object for obj + INTEGER(I4B), INTENT(IN) :: ivarobj + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: idofobj + !! local degree of freedom of physical variable for obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + TYPE(DOF_), INTENT(IN) :: dofvalue + !! degree of freedom object for value + INTEGER(I4B), INTENT(IN) :: ivarvalue + !! physical variable for value + INTEGER(I4B), INTENT(IN) :: idofvalue + !! local degree of freedom of physical variable for value + END SUBROUTINE obj_GetValue7 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. +! +!@note +! The size of idofobj and idofvalue should be equal. +!@endnote + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue8(obj, dofobj, ivarobj, idofobj, & + VALUE, dofvalue, ivarvalue, idofvalue) + TYPE(RealVector_), INTENT(IN) :: obj + !! Real vector whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object for obj + INTEGER(I4B), INTENT(IN) :: ivarobj + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: idofobj(:) + !! local degree of freedom of physical variable for obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + !! values to be returned + TYPE(DOF_), INTENT(IN) :: dofvalue + !! degree of freedom object for value + INTEGER(I4B), INTENT(IN) :: ivarvalue + !! physical variable for value + INTEGER(I4B), INTENT(IN) :: idofvalue(:) + !! local degree of freedom of physical variable for value + END SUBROUTINE obj_GetValue8 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue9(obj, dofobj, ivarobj, & + spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, & + spaceCompoValue, timeCompoValue) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivarobj + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: spaceCompoObj + !! space component for obj + INTEGER(I4B), INTENT(IN) :: timeCompoObj + !! time component for obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + !! values to be returned + TYPE(DOF_), INTENT(IN) :: dofvalue + !! dof for value + INTEGER(I4B), INTENT(IN) :: ivarvalue + !! physical variable for value + INTEGER(I4B), INTENT(IN) :: spaceCompoValue + !! space component for value + INTEGER(I4B), INTENT(IN) :: timeCompoValue + !! time component for value + END SUBROUTINE obj_GetValue9 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue10(obj, dofobj, ivarobj, & + spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, & + spaceCompoValue, timeCompoValue) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivarobj + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: spaceCompoObj + !! space component for obj + INTEGER(I4B), INTENT(IN) :: timeCompoObj(:) + !! time component for obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + !! values to be returned + TYPE(DOF_), INTENT(IN) :: dofvalue + !! dof value + INTEGER(I4B), INTENT(IN) :: ivarvalue + !! physical variable for value + INTEGER(I4B), INTENT(IN) :: spaceCompoValue + !! space compoenent for value + INTEGER(I4B), INTENT(IN) :: timeCompoValue(:) + !! time component for value + END SUBROUTINE obj_GetValue10 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Jan 2022 +! summary: Returns a vector of real from [[RealVector_]] +! +!# Introduction +! +! This routine returns a RealVector from a subset of another +! RealVector. +! +! Both obj and value should be allocated. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue11(obj, dofobj, ivarobj, & + spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, & + spaceCompoValue, timeCompoValue) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivarobj + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: spaceCompoObj(:) + !! space component for obj + INTEGER(I4B), INTENT(IN) :: timeCompoObj + !! time component for obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + !! values to be returned + TYPE(DOF_), INTENT(IN) :: dofvalue + !! dof value + INTEGER(I4B), INTENT(IN) :: ivarvalue + !! physical variable for value + INTEGER(I4B), INTENT(IN) :: spaceCompoValue(:) + !! psace component for value + INTEGER(I4B), INTENT(IN) :: timeCompoValue + !! time component for value + END SUBROUTINE obj_GetValue11 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue12(obj, dofobj, idof, VALUE, & + storageFMT, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! global degree of freedom for obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(IN) :: storageFMT + !! storage format + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! nodenum + END SUBROUTINE obj_GetValue12 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue13(obj, dofobj, idof, VALUE, & + storageFMT) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(IN) :: storageFMT + !! stroage format + END SUBROUTINE obj_GetValue13 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue14(obj, dofobj, idof, VALUE, & + force3D) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:, :) + !! values to be returned + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D + !! force 3D + END SUBROUTINE obj_GetValue14 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue15(obj, dofobj, ivar, idof, & + VALUE, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: idof + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE + !! values to be returned + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number + END SUBROUTINE obj_GetValue15 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue16(obj, dofobj, ivar, idof, & + VALUE, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: idof + !! idof for obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + END SUBROUTINE obj_GetValue16 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue17(obj, dofobj, ivar, VALUE, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable for obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + END SUBROUTINE obj_GetValue17 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue18(obj, dofobj, ivar, spaceCompo, & + timeCompo, VALUE, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spaceCompo + INTEGER(I4B), INTENT(IN) :: timeCompo + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(IN) :: nodenum(:) + END SUBROUTINE obj_GetValue18 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue19(obj, dofobj, VALUE, idof) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_GetValue19 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue20(obj, dofobj, VALUE, ivar, idof) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_GetValue20 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue21(obj, dofobj, VALUE, ivar, & + spaceCompo, timeCompo) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spaceCompo + INTEGER(I4B), INTENT(IN) :: timeCompo + END SUBROUTINE obj_GetValue21 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue22(obj, dofobj, idof, VALUE, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: idof(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(IN) :: nodenum(:) + END SUBROUTINE obj_GetValue22 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue23(obj, dofobj, idof, VALUE) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: idof(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:) + END SUBROUTINE obj_GetValue23 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 May 2022 +! summary: copy a realvector into another realvector + +INTERFACE GetValue + MODULE SUBROUTINE obj_GetValue24(obj, VALUE) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(RealVector_), INTENT(INOUT) :: VALUE + END SUBROUTINE obj_GetValue24 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! +! This routine is similar to the ob_GetValue12 but it does not allocate +! extra memory for value. + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_12(obj, dofobj, idof, VALUE, & + tsize, storageFMT, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total entries written to value + INTEGER(I4B), INTENT(IN) :: storageFMT + !! storage format + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! nodenum + END SUBROUTINE obj_GetValue_12 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! +! This routine is similar to the ob_GetValue13 but it does not allocate +! extra memory for value. + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_13(obj, dofobj, idof, VALUE, & + tsize, storageFMT) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total entries written to value + INTEGER(I4B), INTENT(IN) :: storageFMT + !! stroage format + END SUBROUTINE obj_GetValue_13 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! +! This routine is similar to the ob_GetValue14 but it does not allocate +! extra memory for value. + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_14(obj, dofobj, idof, VALUE, & + nrow, ncol, force3D) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to value + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: force3D + !! force 3D + END SUBROUTINE obj_GetValue_14 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_16(obj, dofobj, ivar, idof, & + VALUE, tsize, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: idof + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written to value + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + END SUBROUTINE obj_GetValue_16 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: This function returns a vector of real from [[RealVector_]] +! +!# Introduction +! +!@note +! This routine first computes the IDOF and then +! This routine calls obj_GetValue_12 +!@endnote + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_17(obj, dofobj, ivar, VALUE, & + tsize, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj whose value is to be extracted + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written to value + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + END SUBROUTINE obj_GetValue_17 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_18(obj, dofobj, ivar, spaceCompo, & + timeCompo, VALUE, tsize, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom for obj + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable for obj + INTEGER(I4B), INTENT(IN) :: spaceCompo + !! space component for obj + INTEGER(I4B), INTENT(IN) :: timeCompo + !! time component for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written to value + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number + END SUBROUTINE obj_GetValue_18 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_19(obj, dofobj, VALUE, tsize, idof) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(OUT) :: tsize + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_GetValue_19 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_20(obj, dofobj, VALUE, tsize, & + ivar, idof) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(OUT) :: tsize + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: idof + END SUBROUTINE obj_GetValue_20 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: This function returns a vector of real from [[RealVector_]] + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_21(obj, dofobj, VALUE, tsize, ivar, & + spaceCompo, timeCompo) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(OUT) :: tsize + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: spaceCompo + INTEGER(I4B), INTENT(IN) :: timeCompo + END SUBROUTINE obj_GetValue_21 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-25 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_22(obj, dofobj, idof, VALUE, & + tsize, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: idof(:) + REAL(DFP), INTENT(INOUT) :: VALUE(:) + INTEGER(I4B), INTENT(OUT) :: tsize + INTEGER(I4B), INTENT(IN) :: nodenum(:) + END SUBROUTINE obj_GetValue_22 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_23(obj, dofobj, idof, VALUE, tsize) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of entries written to value + END SUBROUTINE obj_GetValue_23 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_24(obj, dofobj, idof, VALUE, nrow, ncol, & + storageFMT, nodenum) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: nrow + !! number of rows written to value + INTEGER(I4B), INTENT(OUT) :: ncol + !! number of columns written to value + INTEGER(I4B), INTENT(IN) :: storageFMT + !! storage format can be DOF_FMT or Nodes_FMT + !! if DOF_FMT then nrow size(nodenum) and ncol size(idof) + !! if Nodes_FMT then nrow is size(idof) and ncol is size(nodenum) + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node numbers + END SUBROUTINE obj_GetValue_24 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Returns the values of degrees of freedom in a single vector +! +!# Introduction +! This subroutine extracts the values from `val` corresponding to +! degrees of freedom specified by `idof(:)` and return it in `V` +! +! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage +! format of returned vector. + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_25(obj, dofobj, idof, VALUE, nrow, ncol, & + storageFMT) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + TYPE(DOF_), INTENT(IN) :: dofobj + !! dof for obj + INTEGER(I4B), INTENT(IN) :: idof(:) + !! idof for obj + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: nrow + !! number of rows written to value + INTEGER(I4B), INTENT(OUT) :: ncol + !! number of columns written to value + INTEGER(I4B), INTENT(IN) :: storageFMT + !! storage format can be DOF_FMT or Nodes_FMT + !! if DOF_FMT then nrow size(nodenum) and ncol size(idof) + !! if Nodes_FMT then nrow is size(idof) and ncol is size(nodenum) + END SUBROUTINE obj_GetValue_25 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Get multiple values + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_26(obj, nodenum, VALUE, tsize) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! index + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written to value + END SUBROUTINE obj_GetValue_26 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Get multiple values + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_27(obj, istart, iend, stride, VALUE, tsize) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! index + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written to value + END SUBROUTINE obj_GetValue_27 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Get multiple values + +INTERFACE GetValue_ + MODULE SUBROUTINE obj_GetValue_28(obj, istart, iend, stride, VALUE, & + tsize, istart_value, iend_value, stride_value) + TYPE(RealVector_), INTENT(IN) :: obj + !! obj to extract values + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! index + REAL(DFP), INTENT(INOUT) :: VALUE(:) + !! values to be returned + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size written to value + INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value + END SUBROUTINE obj_GetValue_28 +END INTERFACE GetValue_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE RealVector_GetValueMethods diff --git a/src/modules/RealVector/src/RealVector_IOMethods.F90 b/src/modules/RealVector/src/RealVector_IOMethods.F90 new file mode 100644 index 000000000..7d073fd6a --- /dev/null +++ b/src/modules/RealVector/src/RealVector_IOMethods.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 RealVector_IOMethods +USE GlobalData, ONLY: I4B +USE BaseType, ONLY: RealVector_ + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +INTERFACE Display + MODULE SUBROUTINE obj_display1(obj, msg, unitno) + CLASS(RealVector_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + END SUBROUTINE obj_display1 +END INTERFACE Display + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +INTERFACE Display + MODULE SUBROUTINE obj_display2(obj, msg, unitno) + CLASS(RealVector_), INTENT(IN) :: obj(:) + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno + END SUBROUTINE obj_display2 +END INTERFACE Display + +END MODULE RealVector_IOMethods diff --git a/src/modules/RealVector/src/RealVector_Method.F90 b/src/modules/RealVector/src/RealVector_Method.F90 new file mode 100644 index 000000000..db109b577 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_Method.F90 @@ -0,0 +1,45 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 24 Feb 2021 +! summary: This module contains methods of [[RealVector_]] data type. +! +!###Introduction +! +! This module contains methods of [[RealVector_]] data type. +! This module only contains the definition of the interfaces of these +! methods. The actual implementation is given inside the submodules. This +! modules has following submodules: +! +!@todo Documentation, testing, usage + +MODULE RealVector_Method +USE RealVector_AddMethods +USE RealVector_AppendMethods +USE RealVector_AssignMethods +USE RealVector_ComparisonMethods +USE RealVector_ConstructorMethods +USE RealVector_GetMethods +USE RealVector_GetValueMethods +USE RealVector_IOMethods +USE RealVector_Norm2Methods +USE RealVector_Norm2ErrorMethods +USE RealVector_SetMethods +USE RealVector_ShallowCopyMethods +USE RealVector_Blas1Methods +END MODULE RealVector_Method diff --git a/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 b/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 new file mode 100644 index 000000000..38ccc8bd6 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_Norm2ErrorMethods.F90 @@ -0,0 +1,165 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_Norm2ErrorMethods +USE GlobalData, ONLY: I4B, DFP +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Norm2Error + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +INTERFACE Norm2Error + MODULE PURE FUNCTION obj_norm2error_1(obj, dofobj, ivarobj, & + idofobj, obj2, dofobj2, ivarobj2, idofobj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: ivarobj + INTEGER(I4B), INTENT(IN) :: idofobj + CLASS(RealVector_), INTENT(IN) :: obj2 + TYPE(DOF_), INTENT(IN) :: dofobj2 + INTEGER(I4B), INTENT(IN) :: ivarobj2 + INTEGER(I4B), INTENT(IN) :: idofobj2 + REAL(DFP) :: ans + END FUNCTION obj_norm2error_1 +END INTERFACE Norm2Error + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +INTERFACE Norm2Error + MODULE PURE FUNCTION obj_norm2error_2(obj, dofobj, ivarobj, & + idofobj, obj2, dofobj2, ivarobj2, idofobj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: ivarobj + INTEGER(I4B), INTENT(IN) :: idofobj(:) + CLASS(RealVector_), INTENT(IN) :: obj2 + TYPE(DOF_), INTENT(IN) :: dofobj2 + INTEGER(I4B), INTENT(IN) :: ivarobj2 + INTEGER(I4B), INTENT(IN) :: idofobj2(:) + REAL(DFP) :: ans + END FUNCTION obj_norm2error_2 +END INTERFACE Norm2Error + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +INTERFACE Norm2Error + MODULE PURE FUNCTION obj_norm2error_3(obj, dofobj, idofobj, obj2, & + dofobj2, idofobj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: idofobj + CLASS(RealVector_), INTENT(IN) :: obj2 + TYPE(DOF_), INTENT(IN) :: dofobj2 + INTEGER(I4B), INTENT(IN) :: idofobj2 + REAL(DFP) :: ans + END FUNCTION obj_norm2error_3 +END INTERFACE Norm2Error + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +INTERFACE Norm2Error + MODULE PURE FUNCTION obj_norm2error_4(obj, dofobj, idofobj, obj2, & + dofobj2, idofobj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: idofobj(:) + CLASS(RealVector_), INTENT(IN) :: obj2 + TYPE(DOF_), INTENT(IN) :: dofobj2 + INTEGER(I4B), INTENT(IN) :: idofobj2(:) + REAL(DFP) :: ans + END FUNCTION obj_norm2error_4 +END INTERFACE Norm2Error + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +INTERFACE Norm2Error + MODULE PURE FUNCTION obj_norm2error_5(obj, dofobj, ivarobj, & + spaceCompoObj, timeCompoObj, obj2, dofobj2, ivarobj2, & + spaceCompoobj2, timeCompoobj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: ivarobj + INTEGER(I4B), INTENT(IN) :: spaceCompoObj + INTEGER(I4B), INTENT(IN) :: timeCompoObj + CLASS(RealVector_), INTENT(IN) :: obj2 + TYPE(DOF_), INTENT(IN) :: dofobj2 + INTEGER(I4B), INTENT(IN) :: ivarobj2 + INTEGER(I4B), INTENT(IN) :: spaceCompoobj2 + INTEGER(I4B), INTENT(IN) :: timeCompoobj2 + REAL(DFP) :: ans + END FUNCTION obj_norm2error_5 +END INTERFACE Norm2Error + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +INTERFACE Norm2Error + MODULE PURE FUNCTION obj_norm2error_6(obj, dofobj, ivarobj, & + spaceCompoObj, timeCompoObj, obj2, dofobj2, ivarobj2, & + spaceCompoobj2, timeCompoobj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: ivarobj + INTEGER(I4B), INTENT(IN) :: spaceCompoObj + INTEGER(I4B), INTENT(IN) :: timeCompoObj(:) + CLASS(RealVector_), INTENT(IN) :: obj2 + TYPE(DOF_), INTENT(IN) :: dofobj2 + INTEGER(I4B), INTENT(IN) :: ivarobj2 + INTEGER(I4B), INTENT(IN) :: spaceCompoobj2 + INTEGER(I4B), INTENT(IN) :: timeCompoobj2(:) + REAL(DFP) :: ans + END FUNCTION obj_norm2error_6 +END INTERFACE Norm2Error + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +INTERFACE Norm2Error + MODULE PURE FUNCTION obj_norm2error_7(obj, dofobj, ivarobj, & + spaceCompoObj, timeCompoObj, obj2, dofobj2, ivarobj2, & + spaceCompoobj2, timeCompoobj2) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + INTEGER(I4B), INTENT(IN) :: ivarobj + INTEGER(I4B), INTENT(IN) :: spaceCompoObj(:) + INTEGER(I4B), INTENT(IN) :: timeCompoObj + CLASS(RealVector_), INTENT(IN) :: obj2 + TYPE(DOF_), INTENT(IN) :: dofobj2 + INTEGER(I4B), INTENT(IN) :: ivarobj2 + INTEGER(I4B), INTENT(IN) :: spaceCompoobj2(:) + INTEGER(I4B), INTENT(IN) :: timeCompoobj2 + REAL(DFP) :: ans + END FUNCTION obj_norm2error_7 +END INTERFACE Norm2Error + +END MODULE RealVector_Norm2ErrorMethods diff --git a/src/modules/RealVector/src/RealVector_Norm2Methods.F90 b/src/modules/RealVector/src/RealVector_Norm2Methods.F90 new file mode 100644 index 000000000..63cef3d0e --- /dev/null +++ b/src/modules/RealVector/src/RealVector_Norm2Methods.F90 @@ -0,0 +1,153 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_Norm2Methods +USE GlobalData, ONLY: DFP, I4B +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Norm2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +INTERFACE Norm2 + MODULE PURE FUNCTION obj_norm2_1(obj, dof, ivar, idof) & + RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dof + !! degree of freedom + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom + REAL(DFP) :: ans + END FUNCTION obj_norm2_1 +END INTERFACE Norm2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +INTERFACE Norm2 + MODULE PURE FUNCTION obj_norm2_2(obj, dof, ivar, idof) & + RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dof + !! degree of freedom + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof(:) + !! local degree of freedom + REAL(DFP) :: ans + END FUNCTION obj_norm2_2 +END INTERFACE Norm2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +INTERFACE Norm2 + MODULE PURE FUNCTION obj_norm2_3(obj, dof, idof) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dof + !! degree of freedom + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom + REAL(DFP) :: ans + END FUNCTION obj_norm2_3 +END INTERFACE Norm2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +INTERFACE Norm2 + MODULE PURE FUNCTION obj_norm2_4(obj, dof, idof) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dof + !! degree of freedom + INTEGER(I4B), INTENT(IN) :: idof(:) + !! global degree of freedom + REAL(DFP) :: ans + END FUNCTION obj_norm2_4 +END INTERFACE Norm2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +INTERFACE Norm2 + MODULE PURE FUNCTION obj_norm2_5(obj, dof, ivar, & + spaceCompo, timeCompo) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dof + !! degree of freedom + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spaceCompo + !! space component of degree of physical variable + INTEGER(I4B), INTENT(IN) :: timeCompo + !! time component of degree of physical variable + REAL(DFP) :: ans + END FUNCTION obj_norm2_5 +END INTERFACE Norm2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +INTERFACE Norm2 + MODULE PURE FUNCTION obj_norm2_6(obj, dof, ivar, & + spaceCompo, timeCompo) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dof + !! degree of freedom + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spaceCompo + !! space component of degree of physical variable + INTEGER(I4B), INTENT(IN) :: timeCompo(:) + !! time component of degree of physical variable + REAL(DFP) :: ans + END FUNCTION obj_norm2_6 +END INTERFACE Norm2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +INTERFACE Norm2 + MODULE PURE FUNCTION obj_norm2_7(obj, dof, ivar, & + spaceCompo, timeCompo) RESULT(ans) + CLASS(RealVector_), INTENT(IN) :: obj + TYPE(DOF_), INTENT(IN) :: dof + !! degree of freedom + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spaceCompo(:) + !! space component of degree of physical variable + INTEGER(I4B), INTENT(IN) :: timeCompo + !! time component of degree of physical variable + REAL(DFP) :: ans + END FUNCTION obj_norm2_7 +END INTERFACE Norm2 + +END MODULE RealVector_Norm2Methods diff --git a/src/modules/RealVector/src/RealVector_SetMethods.F90 b/src/modules/RealVector/src/RealVector_SetMethods.F90 new file mode 100644 index 000000000..9510aad40 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_SetMethods.F90 @@ -0,0 +1,772 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_SetMethods +USE GlobalData, ONLY: DFP, I4B +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Set all values to given scalar +! +!# Introduction +! +!@note +! F77_Copy method from F77_Blas is called. +!@endnote + +INTERFACE Set + MODULE SUBROUTINE obj_Set1(obj, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: VALUE + END SUBROUTINE obj_Set1 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Set all values by given vector (obj=value) +! +!# Introduction +! +!@note +! F95_Copy method from F95_Blas is called. +!@endnote + +INTERFACE Set + MODULE SUBROUTINE obj_Set2(obj, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: VALUE(:) + !! the length of the vector must be equal to the length of the object + END SUBROUTINE obj_Set2 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Jan 2022 +! summary: set selected values (obj(nodenum)=VALUE) + +INTERFACE Set + MODULE SUBROUTINE obj_Set3(obj, nodenum, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + END SUBROUTINE obj_Set3 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set4(obj, nodenum, VALUE) + TYPE(Realvector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + END SUBROUTINE obj_Set4 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Jan 2022 +! summary: set selected values + +INTERFACE Set + MODULE SUBROUTINE obj_Set5(obj, nodenum, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value, the size of value should be equal to tdof * size(nodenum) + END SUBROUTINE obj_Set5 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Set range of values to a scalar + +INTERFACE Set + MODULE SUBROUTINE obj_Set6(obj, istart, iend, stride, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE + !! Scalar value + END SUBROUTINE obj_Set6 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: Set range of values to a vector + +INTERFACE Set + MODULE SUBROUTINE obj_Set7(obj, istart, iend, stride, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! ob(istart:iend:stride)=VALUE + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + END SUBROUTINE obj_Set7 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set8(obj, dofobj, nodenum, VALUE, conversion) + TYPE(Realvector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + INTEGER(I4B), INTENT(IN) :: conversion(1) + !! conversion factor, NodesToDOF, DOFToNodes + END SUBROUTINE obj_Set8 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set9(obj, dofobj, nodenum, VALUE) + TYPE(Realvector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + END SUBROUTINE obj_Set9 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set10(obj, dofobj, nodenum, VALUE, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value, + !! the size of value should be equal to size(nodenum) + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + END SUBROUTINE obj_Set10 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set11(obj, dofobj, nodenum, VALUE, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + END SUBROUTINE obj_Set11 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set12(obj, dofobj, nodenum, VALUE, ivar, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + !! the size of value should be equal to size(nodenum) + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom number in physical variable + END SUBROUTINE obj_Set12 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set13(obj, dofobj, nodenum, VALUE, ivar, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + !! obj(nodenum)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom number in physical variable + END SUBROUTINE obj_Set13 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set14(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + !! the size of value should be equal to size(nodenum) + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component number + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component number + END SUBROUTINE obj_Set14 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set15(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component number + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component number + END SUBROUTINE obj_Set15 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set16(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + !! the size of value should be equal to size(nodenum)*size(timecompo) + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component number + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time component number + END SUBROUTINE obj_Set16 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set17(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component number + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time component number + END SUBROUTINE obj_Set17 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set18(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + !! the size of value should be equal to size(nodenum)*size(spacecompo) + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! space component number of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component number of physical variable + END SUBROUTINE obj_Set18 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 June 2021 +! summary: See [[DOF_Method::dof_Set2]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set19(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! space component number of physical variable + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component number of physical variable + END SUBROUTINE obj_Set19 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set20(obj, dofobj, nodenum, VALUE) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + END SUBROUTINE obj_Set20 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set21(obj, dofobj, nodenum, VALUE, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + END SUBROUTINE obj_Set21 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set22(obj, dofobj, nodenum, VALUE, ivar, idof) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: idof + !! local degree of freedom number in physical variable + END SUBROUTINE obj_Set22 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set23(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component number + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component number + END SUBROUTINE obj_Set23 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set24(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo + !! space component number + INTEGER(I4B), INTENT(IN) :: timecompo(:) + !! time component number + END SUBROUTINE obj_Set24 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 June 2021 +! summary: See [[DOF_Method::dof_Set1]] + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set25(obj, dofobj, nodenum, VALUE, ivar, & + spacecompo, timecompo) + TYPE(Realvector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: nodenum + !! node number to set the value + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value + INTEGER(I4B), INTENT(IN) :: ivar + !! physical variable number + INTEGER(I4B), INTENT(IN) :: spacecompo(:) + !! space component number + INTEGER(I4B), INTENT(IN) :: timecompo + !! time component number + END SUBROUTINE obj_Set25 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 June 2022 +! summary: obj1=obj2 + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set26(obj, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + TYPE(RealVector_), INTENT(IN) :: VALUE + END SUBROUTINE obj_Set26 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-29 +! summary: obj = Value +! +!# Introduction +! +! Value contains the nodal values of all dofs +! Number of cols in values should be at least equal to the total dof in obj +! Number of rows in values should be at least equal to the total nodes in obj + +INTERFACE Set + MODULE SUBROUTINE obj_Set27(obj, dofobj, VALUE) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + REAL(DFP), INTENT(IN) :: VALUE(:, :) + !! number of cols should be equal to the total dof in obj + !! number of rows should be equal to the total nodes in obj + END SUBROUTINE obj_Set27 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-29 +! summary: obj = obj + scale*VALUE + +INTERFACE Set + MODULE SUBROUTINE obj_Set28(obj, dofobj, VALUE, idof) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + REAL(DFP), INTENT(IN) :: VALUE(:) + !! number of cols should be equal to the total dof in obj + !! number of rows should be equal to the total nodes in obj + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom in dofobj + END SUBROUTINE obj_Set28 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-29 +! summary: obj = obj + scale*VALUE + +INTERFACE Set + MODULE SUBROUTINE obj_Set29(obj1, dofobj1, idof1, obj2, dofobj2, idof2) + TYPE(RealVector_), INTENT(INOUT) :: obj1 + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj1 + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof1 + !! global degree of freedom in dof1 + TYPE(RealVector_), INTENT(IN) :: obj2 + !! real vector + TYPE(DOF_), INTENT(IN) :: dofobj2 + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: idof2 + !! global degree of freedom in dof2 + END SUBROUTINE obj_Set29 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-30 +! summary: Set range of values to a scalar + +INTERFACE Set + MODULE SUBROUTINE obj_Set30(obj, dofobj, istart, iend, stride, VALUE, idof) + TYPE(RealVector_), INTENT(INOUT) :: obj + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE + !! Scalar value + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + END SUBROUTINE obj_Set30 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-30 +! summary: Set range of values to a vector + +INTERFACE Set + MODULE SUBROUTINE obj_Set31(obj, dofobj, istart, iend, stride, VALUE, idof) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! ob(istart:iend:stride)=VALUE + TYPE(DOF_), INTENT(IN) :: dofobj + !! degree of freedom object + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + INTEGER(I4B), INTENT(IN) :: idof + !! global degree of freedom number + END SUBROUTINE obj_Set31 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-30 +! summary: Set range of values to a vector + +INTERFACE Set + MODULE SUBROUTINE obj_Set32(obj, istart, iend, stride, VALUE, & + istart_value, iend_value, stride_value) + TYPE(RealVector_), INTENT(INOUT) :: obj + !! ob(istart:iend:stride)=VALUE + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + !! range of values to set + REAL(DFP), INTENT(IN) :: VALUE(:) + !! vector value + INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value + !! range of values to set + END SUBROUTINE obj_Set32 +END INTERFACE Set + +END MODULE RealVector_SetMethods diff --git a/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 b/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 new file mode 100644 index 000000000..57663b4a1 --- /dev/null +++ b/src/modules/RealVector/src/RealVector_ShallowCopyMethods.F90 @@ -0,0 +1,159 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 RealVector_ShallowCopyMethods +USE GlobalData, ONLY: DFP, I4B, REAL32, REAL64 +USE BaseType, ONLY: RealVector_, DOF_ + +IMPLICIT NONE + +PRIVATE +PUBLIC :: ShallowCopy + +!---------------------------------------------------------------------------- +! ShallowCopy@ShallowCopyMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-28 +! summary: Copy only the structure for Y = X + +INTERFACE ShallowCopy + MODULE PURE SUBROUTINE obj_ShallowCopy1a(Y, X) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) + REAL(REAL32), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy1a + + MODULE PURE SUBROUTINE obj_ShallowCopy1b(Y, X) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) + REAL(REAL64), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy1b + + MODULE PURE SUBROUTINE obj_ShallowCopy1c(Y, X) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) + REAL(REAL32), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy1c + + MODULE PURE SUBROUTINE obj_ShallowCopy1d(Y, X) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) + REAL(REAL64), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy1d +END INTERFACE ShallowCopy + +!---------------------------------------------------------------------------- +! ShallowCopy@ShallowCopyMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 |June 2021 +! summary: Copy only the structure for Y = X + +INTERFACE ShallowCopy + MODULE PURE SUBROUTINE obj_ShallowCopy2(Y, X) + TYPE(RealVector_), INTENT(INOUT) :: Y + CLASS(RealVector_), INTENT(IN) :: X + END SUBROUTINE obj_ShallowCopy2 +END INTERFACE ShallowCopy + +!---------------------------------------------------------------------------- +! ShallowCopy@ShallowCopyMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 |June 2021 +! summary: Copy only the structure for Y = X + +INTERFACE ShallowCopy + MODULE PURE SUBROUTINE obj_ShallowCopy3(Y, X) + TYPE(RealVector_), INTENT(INOUT), ALLOCATABLE :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy3 +END INTERFACE ShallowCopy + +!---------------------------------------------------------------------------- +! ShallowCopy@ShallowCopyMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 |June 2021 +! summary: Copy only the structure for Y = X + +INTERFACE ShallowCopy + MODULE PURE SUBROUTINE obj_ShallowCopy4(Y, X) + TYPE(RealVector_), INTENT(INOUT) :: Y + CLASS(RealVector_), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy4 +END INTERFACE ShallowCopy + +!---------------------------------------------------------------------------- +! ShallowCopy@ShallowCopyMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 |June 2021 +! summary: Copy only the structure for Y = X + +INTERFACE ShallowCopy + MODULE PURE SUBROUTINE obj_ShallowCopy5a(Y, X) + CLASS(RealVector_), INTENT(INOUT) :: Y + REAL(REAL32), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy5a + MODULE PURE SUBROUTINE obj_ShallowCopy5b(Y, X) + CLASS(RealVector_), INTENT(INOUT) :: Y + REAL(REAL64), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy5b +END INTERFACE ShallowCopy + +!---------------------------------------------------------------------------- +! ShallowCopy@ShallowCopyMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 |June 2021 +! summary: Copy only the structure for Y = X + +INTERFACE ShallowCopy + MODULE PURE SUBROUTINE obj_ShallowCopy6a(Y, X) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X + END SUBROUTINE obj_ShallowCopy6a + MODULE PURE SUBROUTINE obj_ShallowCopy6b(Y, X) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X + END SUBROUTINE obj_ShallowCopy6b +END INTERFACE ShallowCopy + +!---------------------------------------------------------------------------- +! ShallowCopy@ShallowCopyMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 26 |June 2021 +! summary: Copy only the structure for Y = X + +INTERFACE ShallowCopy + MODULE PURE SUBROUTINE obj_ShallowCopy7a(Y, X) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy7a + MODULE PURE SUBROUTINE obj_ShallowCopy7b(Y, X) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Y(:) + CLASS(RealVector_), INTENT(IN) :: X(:) + END SUBROUTINE obj_ShallowCopy7b +END INTERFACE ShallowCopy + +END MODULE RealVector_ShallowCopyMethods diff --git a/src/modules/STConvectiveMatrix/CMakeLists.txt b/src/modules/STConvectiveMatrix/CMakeLists.txt new file mode 100644 index 000000000..1728f6122 --- /dev/null +++ b/src/modules/STConvectiveMatrix/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}/STConvectiveMatrix_Method.F90 +) diff --git a/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 b/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 new file mode 100644 index 000000000..1ce08aefa --- /dev/null +++ b/src/modules/STConvectiveMatrix/src/STConvectiveMatrix_Method.F90 @@ -0,0 +1,294 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE STConvectiveMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_1(test, trial, & + & term1, term2, opt, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! This option is used to create + !! ncopy Mii(I,J,a,b) + !! and Mi1(I,J,a,b) + !! and M1i(I,J,a,b) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_1 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_1 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_2(test, trial, c, crank, & + & term1, term2, opt, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! scalar FEVariable + TYPE(FEVariableScalar_), INTENT( IN ) :: crank + !! scalar variable + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! This option is used to create + !! ncopy Mii(I,J,a,b) + !! and Mi1(I,J,a,b) + !! and M1i(I,J,a,b) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_2 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_2 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_3(test, trial, c, crank, & + & term1, term2, opt, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! vector FEVariable, convective velocity + TYPE(FEVariableVector_), INTENT( IN ) :: crank + !! convective velocity + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! This option is used to create + !! ncopy Mii(I,J,a,b) + !! and Mi1(I,J,a,b) + !! and M1i(I,J,a,b) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + !! it is needed only when + !! term1=term2= {del_x, del_y, del_z, del_x_all} + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_3 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_3 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_4(test, trial, c1, c2, & + & c1rank, c2rank, term1, term2, opt, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + !! Scalar FE variable + TYPE(FEVariable_), INTENT(IN) :: c2 + !! convective velocity, vector FEVariable, + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + !! Scalar FE variable + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! vector FEVariable, + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! This option is used to create + !! ncopy Mii(I,J,a,b) + !! and Mi1(I,J,a,b) + !! and M1i(I,J,a,b) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_4 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_4 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array +! +! This is a special matrix +! it calls STCM_13a, STCM_13b, STCM_13c, STCM_13d +! it calls STCM_14a, STCM_14b, STCM_14c, STCM_14d + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_5(test, trial, c, crank, & + & term1, term2, opt) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + TYPE(FEVariableVector_), INTENT(IN) :: crank + !! convective velocity + INTEGER(I4B), INTENT(IN) :: term1 + !! + INTEGER(I4B), INTENT(IN) :: term2 + !! + INTEGER( I4B ), INTENT( IN ) :: opt(1) + !! 1 --> v(i) dNTdXt(:,:,j) + !! 2 --> dNTdXt(:,:,i) v(j) + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_5 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_5 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array +! +! This is a special matrix +! it calls STCM_15a, STCM_15b, STCM_15c, STCM_15d +! it calls STCM_16a, STCM_16b, STCM_16c, STCM_16d +! it calls STCM_17a, STCM_17b, STCM_17c, STCM_17d + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_6(test, trial, c1, & + & c2, c1rank, c2rank, term1, term2, opt, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + !! scalar FEVariable + TYPE(FEVariable_), INTENT(IN) :: c2 + !! vector FEVariable + TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank + !! scalar FEvariable + TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + !! vector FEVariable + INTEGER(I4B), INTENT(IN) :: term1 + !! + INTEGER(I4B), INTENT(IN) :: term2 + !! + INTEGER( I4B ), INTENT( IN ) :: opt(1) + !! 1 --> v(i) dNTdXt(:,:,j) + !! 2 --> dNTdXt(:,:,i) v(j) + CHARACTER(LEN=*), OPTIONAL, INTENT( IN ) :: projecton + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_6 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_6 +END INTERFACE STConvectiveMatrix + +END MODULE STConvectiveMatrix_Method diff --git a/src/modules/STConvectiveMatrix/src/del.inc b/src/modules/STConvectiveMatrix/src/del.inc new file mode 100644 index 000000000..2b1418c88 --- /dev/null +++ b/src/modules/STConvectiveMatrix/src/del.inc @@ -0,0 +1,540 @@ + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_1(test, trial, c, & + & term1, term2, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! convective velocity + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_1 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_1 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_2(test, trial, c1, c2, & + & term1, term2, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + !! Scalar FE variable + TYPE(FEVariable_), INTENT(IN) :: c2 + !! convective velocity, vector FEVariable, + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_2 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_2 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_3(test, trial, c, & + & term1, term2, ncopy, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! convective velocity + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), INTENT( IN ) :: ncopy + !! number of diagonal copies + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_3 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_3 +END INTERFACE STConvectiveMatrix + + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_4(test, trial, c1, c2, & + & term1, term2, ncopy, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + !! Scalar FE variable + TYPE(FEVariable_), INTENT(IN) :: c2 + !! convective velocity, vector FEVariable, + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), INTENT( IN ) :: ncopy + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_4 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_4 +END INTERFACE STConvectiveMatrix + + + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix + +INTERFACE + MODULE PURE FUNCTION Mat2_STConvectiveMatrix_1(test, trial, c, crank, & + & term1, term2, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Mat2_STConvectiveMatrix_1 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE Mat2_STConvectiveMatrix_1 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-06 +! update: 2021-12-06 +! summary: Returns the space-time convective matrix + +INTERFACE + MODULE PURE FUNCTION Mat2_STConvectiveMatrix_2(test, trial, c1, c2, & + & term1, term2, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Mat2_STConvectiveMatrix_2 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE Mat2_STConvectiveMatrix_2 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix + +INTERFACE + MODULE PURE FUNCTION Mat2_STConvectiveMatrix_3(test, trial, c, & + & term1, term2, ncopy, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER( I4B ), INTENT( IN ) :: ncopy + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Mat2_STConvectiveMatrix_3 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE Mat2_STConvectiveMatrix_3 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-06 +! update: 2021-12-06 +! summary: Returns the space-time convective matrix + +INTERFACE + MODULE PURE FUNCTION Mat2_STConvectiveMatrix_4(test, trial, c1, c2, & + & term1, term2, ncopy, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), INTENT(IN) :: ncopy + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Mat2_STConvectiveMatrix_4 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE Mat2_STConvectiveMatrix_4 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix + +INTERFACE + MODULE PURE FUNCTION Mat2_STConvectiveMatrix_5(test, trial, c, & + & term1, term2, opt) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER( I4B ), INTENT( IN ) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Mat2_STConvectiveMatrix_5 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE Mat2_STConvectiveMatrix_5 +END INTERFACE ConvectiveMatrix + +!---------------------------------------------------------------------------- +! ConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-06 +! update: 2021-12-06 +! summary: Returns the space-time convective matrix + +INTERFACE + MODULE PURE FUNCTION Mat2_STConvectiveMatrix_6(test, trial, c1, c2, & + & term1, term2, opt) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), INTENT(IN) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Mat2_STConvectiveMatrix_6 +END INTERFACE + +INTERFACE ConvectiveMatrix + MODULE PROCEDURE Mat2_STConvectiveMatrix_6 +END INTERFACE ConvectiveMatrix + + + +! !---------------------------------------------------------------------------- +! ! ConvectiveMatrix +! !---------------------------------------------------------------------------- + +! MODULE PROCEDURE Mat2_STConvectiveMatrix_1 +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! m4 = STConvectiveMatrix(test=test, trial=trial, term1=term1, & +! & term2=term2, c=c, projecton=projecton) +! CALL convert(from=m4, to=ans) +! DEALLOCATE (m4) +! END PROCEDURE Mat2_STConvectiveMatrix_1 + +! !---------------------------------------------------------------------------- +! ! ConvectiveMatrix +! !---------------------------------------------------------------------------- + +! MODULE PROCEDURE Mat2_STConvectiveMatrix_2 +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! m4 = STConvectiveMatrix(test=test, trial=trial, term1=term1, & +! & term2=term2, c1=c1, c2=c2, projecton=projecton) +! CALL convert(from=m4, to=ans) +! DEALLOCATE (m4) +! END PROCEDURE Mat2_STConvectiveMatrix_2 + +! !---------------------------------------------------------------------------- +! ! ConvectiveMatrix +! !---------------------------------------------------------------------------- + +! MODULE PROCEDURE Mat2_STConvectiveMatrix_3 +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! m4 = STConvectiveMatrix(test=test, trial=trial, term1=term1, & +! & term2=term2, ncopy=ncopy, c=c, projecton=projecton) +! CALL convert(from=m4, to=ans) +! DEALLOCATE (m4) +! END PROCEDURE Mat2_STConvectiveMatrix_3 + +! !---------------------------------------------------------------------------- +! ! ConvectiveMatrix +! !---------------------------------------------------------------------------- + +! MODULE PROCEDURE Mat2_STConvectiveMatrix_4 +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! m4 = STConvectiveMatrix(test=test, trial=trial, & +! & c1=c1, c2=c2, term1=term1, & +! & term2=term2, ncopy=ncopy, projecton=projecton) +! CALL convert(from=m4, to=ans) +! DEALLOCATE (m4) +! END PROCEDURE Mat2_STConvectiveMatrix_4 + + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_5(test, trial, c, crank, & + & term1, term2, opt, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + TYPE(FEVariableVector_), INTENT( IN ) :: crank + !! vector fevariable + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), INTENT( IN ) :: opt + !! number of diagonal copies + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_5 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_5 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_6(test, trial, c, crank, & + & term1, term2, ncopy, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! scalar fevariable + TYPE(FEVariableScalar_), INTENT( IN ) :: crank + !! scalar fevariable + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), INTENT( IN ) :: ncopy + !! number of diagonal copies + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_6 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_6 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_7(test, trial, & + & term1, term2, ncopy, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), INTENT( IN ) :: ncopy + !! number of diagonal copies + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_7 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_7 +END INTERFACE STConvectiveMatrix + +!---------------------------------------------------------------------------- +! STConvectiveMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-22 +! update: 2021-11-22 +! summary: Returns the space-time convective matrix in rank-4 array + +INTERFACE + MODULE PURE FUNCTION Mat4_STConvectiveMatrix_8(test, trial, c1, c2, & + & c1rank, c2rank, term1, term2, ncopy, projecton) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + !! Scalar FE variable + TYPE(FEVariable_), INTENT(IN) :: c2 + !! convective velocity, vector FEVariable, + TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank + TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + INTEGER(I4B), INTENT(IN) :: term1 + !! term1 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + INTEGER(I4B), INTENT(IN) :: term2 + !! term2 denotes first order derivative in space or time + !! DEL_NONE => no derivative + !! DEL_X, DEL_Y, DEL_Z, DEL_X_ALL => space derivative + !! DEL_t => time derivative + INTEGER( I4B ), INTENT( IN ) :: ncopy + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + !! "trial" take projection of C on trial + !! "test" take projection of C on test + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + !! returned finite element matrix. + END FUNCTION Mat4_STConvectiveMatrix_8 +END INTERFACE + +INTERFACE STConvectiveMatrix + MODULE PROCEDURE Mat4_STConvectiveMatrix_8 +END INTERFACE STConvectiveMatrix diff --git a/src/modules/STDiffusionMatrix/CMakeLists.txt b/src/modules/STDiffusionMatrix/CMakeLists.txt new file mode 100644 index 000000000..ddfe703f4 --- /dev/null +++ b/src/modules/STDiffusionMatrix/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}/STDiffusionMatrix_Method.F90 +) diff --git a/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 b/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 new file mode 100644 index 000000000..333d0c149 --- /dev/null +++ b/src/modules/STDiffusionMatrix/src/STDiffusionMatrix_Method.F90 @@ -0,0 +1,449 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE STDiffusionMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_1(test, trial, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_1 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_1 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_2(test, trial, k, krank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableScalar_), INTENT( IN ) :: krank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_2 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_2 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_3(test, trial, k, krank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableVector_), INTENT( IN ) :: krank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_3 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_3 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_4(test, trial, k, krank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableMatrix_), INTENT( IN ) :: krank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_4 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_4 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_5(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank + TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_5 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_5 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_6(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank + TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_6 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_6 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_7(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank + TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_7 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_7 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_8(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableVector_), INTENT( IN ) :: c1rank + TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_8 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_8 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_9(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableVector_), INTENT( IN ) :: c1rank + TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_9 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_9 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_10(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableVector_), INTENT( IN ) :: c1rank + TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_10 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_10 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_11(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableMatrix_), INTENT( IN ) :: c1rank + TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_11 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_11 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_12(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableMatrix_), INTENT( IN ) :: c1rank + TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_12 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_12 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_13(test, trial, c1, c2, & + & c1rank, c2rank, opt) & + & RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableMatrix_), INTENT( IN ) :: c1rank + TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_13 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_13 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_14(test, trial, k, krank, & + & opt) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableScalar_), INTENT( IN ) :: krank + !! scalar + INTEGER( I4B ), INTENT( IN ) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_14 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_14 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_15(test, trial, k, krank, & + & opt) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableVector_), INTENT( IN ) :: krank + !! Vector + INTEGER( I4B ), INTENT( IN ) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_15 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_15 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_16(test, trial, c1, c2, & + & c1rank, c2rank, opt) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank + !! scalar + TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank + !! scalar + INTEGER( I4B ), INTENT( IN ) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_16 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_16 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! STDiffusionMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-17 +! update: 2021-12-17 +! summary: Space-time diffusion matrix + +INTERFACE + MODULE PURE FUNCTION mat4_STDiffusionMatrix_17(test, trial, c1, c2, & + & c1rank, c2rank, opt) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank + !! Scalar + TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + !! Vector + INTEGER( I4B ), INTENT( IN ) :: opt(1) + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STDiffusionMatrix_17 +END INTERFACE + +INTERFACE STDiffusionMatrix + MODULE PROCEDURE mat4_STDiffusionMatrix_17 +END INTERFACE STDiffusionMatrix + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +END MODULE STDiffusionMatrix_Method diff --git a/src/modules/STForceVector/CMakeLists.txt b/src/modules/STForceVector/CMakeLists.txt new file mode 100644 index 000000000..8636615f8 --- /dev/null +++ b/src/modules/STForceVector/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}/STForceVector_Method.F90 +) diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 new file mode 100644 index 000000000..ca9504944 --- /dev/null +++ b/src/modules/STForceVector/src/STForceVector_Method.F90 @@ -0,0 +1,533 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 STForceVector_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: STForceVector + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE FUNCTION STForceVector_1(test) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test( : ) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_1 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_1 +END INTERFACE STForceVector + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_2 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION STForceVector_3 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION STForceVector_4 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_5 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION STForceVector_6 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION STForceVector_7 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_7 +END INTERFACE STForceVector + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE FUNCTION STForceVector_8(test, term1) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test( : ) + INTEGER( I4B ), INTENT( IN ) :: term1 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_8 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_8 +END INTERFACE STForceVector + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_9 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION STForceVector_10 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION STForceVector_11 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_12 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION STForceVector_13 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION STForceVector_14 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_14 +END INTERFACE STForceVector + + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_15 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_15 +END INTERFACE STForceVector + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_16 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_16 +END INTERFACE STForceVector + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION STForceVector_17 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_17 +END INTERFACE STForceVector + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION STForceVector_18 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION STForceVector_19 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION STForceVector_20 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE 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 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION STForceVector_21 +END INTERFACE + +INTERFACE STForceVector + MODULE PROCEDURE STForceVector_21 +END INTERFACE STForceVector + +END MODULE STForceVector_Method \ No newline at end of file diff --git a/src/modules/STMassMatrix/CMakeLists.txt b/src/modules/STMassMatrix/CMakeLists.txt new file mode 100644 index 000000000..c50dadd9f --- /dev/null +++ b/src/modules/STMassMatrix/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}/STMassMatrix_Method.F90 +) diff --git a/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 b/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 new file mode 100644 index 000000000..a00403b9a --- /dev/null +++ b/src/modules/STMassMatrix/src/STMassMatrix_Method.F90 @@ -0,0 +1,218 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE STMassMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: STMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE STMassMatrix + MODULE PURE FUNCTION mat4_STMassMatrix_1(test, trial, term1, term2, opt) & + & RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t, del_none + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STMassMatrix_1 +END INTERFACE STMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE STMassMatrix + MODULE PURE FUNCTION mat4_STMassMatrix_2(test, trial, term1, term2, & + & rho, rhorank, opt) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t, del_none + CLASS(FEVariable_), INTENT(IN) :: rho + TYPE(FEVariableScalar_), INTENT(IN) :: rhorank + !! Scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STMassMatrix_2 +END INTERFACE STMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE STMassMatrix + MODULE PURE FUNCTION mat4_STMassMatrix_3(test, trial, term1, term2, & + & rho, rhorank, opt) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t, del_none + CLASS(FEVariable_), INTENT(IN) :: rho + TYPE(FEVariableVector_), INTENT(IN) :: rhorank + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! 1, 2, 3, 4 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STMassMatrix_3 +END INTERFACE STMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE STMassMatrix + MODULE PURE FUNCTION mat4_STMassMatrix_4(test, trial, term1, term2, & + & rho, rhorank) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t, del_none + CLASS(FEVariable_), INTENT(IN) :: rho + TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank + !! Matrix + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STMassMatrix_4 +END INTERFACE STMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE STMassMatrix + MODULE PURE FUNCTION mat4_STMassMatrix_5(test, trial, term1, term2, & + & c1, c1rank, c2, c2rank, opt) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t, del_none + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + !! Scalar + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + !! Scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! ncopy + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STMassMatrix_5 +END INTERFACE STMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE STMassMatrix + MODULE PURE FUNCTION mat4_STMassMatrix_6(test, trial, term1, term2, & + & c1, c1rank, c2, c2rank, opt) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t, del_none + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + !! Scalar + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! 1,2,3,4 + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STMassMatrix_6 +END INTERFACE STMassMatrix + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine makes mass matrix in space domain + +INTERFACE STMassMatrix + MODULE PURE FUNCTION mat4_STMassMatrix_7(test, trial, term1, term2, & + & c1, c1rank, c2, c2rank) RESULT(Ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t, del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t, del_none + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + !! Scalar + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + !! Matrix + REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) + END FUNCTION mat4_STMassMatrix_7 +END INTERFACE STMassMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE STMassMatrix_Method diff --git a/src/modules/StiffnessMatrix/CMakeLists.txt b/src/modules/StiffnessMatrix/CMakeLists.txt new file mode 100644 index 000000000..8a927fe44 --- /dev/null +++ b/src/modules/StiffnessMatrix/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}/StiffnessMatrix_Method.F90 +) diff --git a/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 b/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 new file mode 100644 index 000000000..2f9b0479a --- /dev/null +++ b/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 @@ -0,0 +1,104 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 6 March 2021 +! summary: This module contains method to construct finite element matrices + +MODULE StiffnessMatrix_Method +USE BaseType +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: StiffnessMatrix + +!---------------------------------------------------------------------------- +! StiffnessMatrix@StiffnessMatrixMethods +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix + MODULE PURE FUNCTION obj_StiffnessMatrix1(test, trial, Cijkl) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + CLASS(FEVariable_), INTENT(IN) :: Cijkl + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_StiffnessMatrix1 +END INTERFACE StiffnessMatrix + +!---------------------------------------------------------------------------- +! StiffnessMatrix@StiffnessMatrixMethods +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix + MODULE PURE FUNCTION obj_StiffnessMatrix2(test, trial, lambda, mu, & + & isLambdaYoungsModulus) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + !! Shape function data + CLASS(FEVariable_), INTENT(IN) :: lambda, mu + !! Two elastic parameters + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isLambdaYoungsModulus + !! if it is true then lambda is YoungsModulus + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_StiffnessMatrix2 +END INTERFACE StiffnessMatrix + +!---------------------------------------------------------------------------- +! StiffnessMatrix@StiffnessMatrixMethods +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix + MODULE PURE FUNCTION obj_StiffnessMatrix3(test, trial, lambda, & + & mu) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: lambda, mu + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_StiffnessMatrix3 +END INTERFACE StiffnessMatrix + +!---------------------------------------------------------------------------- +! StiffnessMatrix@StiffnessMatrixMethods +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix + MODULE PURE FUNCTION obj_StiffnessMatrix4(test, trial, Cijkl) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: Cijkl(:, :) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_StiffnessMatrix4 +END INTERFACE StiffnessMatrix + +!---------------------------------------------------------------------------- +! StiffnessMatrix@StiffnessMatrixMethods +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix + MODULE PURE FUNCTION obj_StiffnessMatrix5(test, trial, lambda, mu) & + & RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: lambda(:) + REAL(DFP), INTENT(IN) :: mu(:) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_StiffnessMatrix5 +END INTERFACE StiffnessMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE StiffnessMatrix_Method diff --git a/src/modules/String/CMakeLists.txt b/src/modules/String/CMakeLists.txt new file mode 100644 index 000000000..353c59c03 --- /dev/null +++ b/src/modules/String/CMakeLists.txt @@ -0,0 +1,38 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/String_Class.F90 + ${src_path}/String_Method.F90 +) + +# set variables used for compile definitions of targets after support check +INCLUDE(CheckFortranSourceRuns) +check_fortran_source_runs( + "program r16p_support; + integer, parameter :: r16p = selected_real_kind(33, 4931); + if(r16p < 0) stop 1; + end program r16p_support" + R16P_SUPPORTED + SRC_EXT f90) +IF(R16P_SUPPORTED) + SET(r16p_supported "-D_R16P") +ENDIF() + +LIST( APPEND TARGET_COMPILE_DEF ${r16p_supported} ) \ No newline at end of file diff --git a/src/modules/String/src/String_Class.F90 b/src/modules/String/src/String_Class.F90 new file mode 100644 index 000000000..d186c7b07 --- /dev/null +++ b/src/modules/String/src/String_Class.F90 @@ -0,0 +1,5680 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 21 Oct 2021 +! summary: String datatype + +MODULE String_Class +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_EOR, stdout => OUTPUT_UNIT +USE BeFor64, ONLY: b64_decode, b64_encode +USE FACE, ONLY: colorize +USE PENF, ONLY: I1P, I2P, I4P, I8P, R4P, R8P, R16P, str +IMPLICIT NONE +PRIVATE +!! +! INTEGER, PARAMETER, PUBLIC :: CK = SELECTED_CHAR_KIND('DEFAULT') +INTEGER, PARAMETER :: CK = SELECTED_CHAR_KIND('DEFAULT') +! internal parameters +CHARACTER(kind=CK, len=26), PARAMETER :: UPPER_ALPHABET = & + & 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +CHARACTER(kind=CK, len=26), PARAMETER :: LOWER_ALPHABET = & + & 'abcdefghijklmnopqrstuvwxyz' +CHARACTER(kind=CK, len=1), PARAMETER :: SPACE = ' ' +CHARACTER(kind=CK, len=1), PARAMETER :: TAB = ACHAR(9) +CHARACTER(kind=CK, len=1), PARAMETER :: UIX_DIR_SEP = CHAR(47) +CHARACTER(kind=CK, len=1), PARAMETER :: BACKSLASH = CHAR(92) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE strjoin + MODULE PROCEDURE strjoin_strings, strjoin_characters, & + & strjoin_strings_array, strjoin_characters_array +END INTERFACE strjoin + +PUBLIC :: strjoin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! builtin overloading +INTERFACE adjustl + !< Builtin adjustl overloading. + MODULE PROCEDURE sadjustl_character +END INTERFACE adjustl + +PUBLIC :: adjustl + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE adjustr + !< Builtin adjustr overloading. + MODULE PROCEDURE sadjustr_character +END INTERFACE adjustr + +PUBLIC :: adjustr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE count + !< Builtin count overloading. + MODULE PROCEDURE count_substring +END INTERFACE + +PUBLIC :: count + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE index + MODULE PROCEDURE sindex_string_string, sindex_string_character, & + & sindex_character_string +END INTERFACE index + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE len + MODULE PROCEDURE slen +END INTERFACE len + +PUBLIC :: LEN + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE len_trim + !< Builtin len_trim overloading. + MODULE PROCEDURE slen_trim +END INTERFACE len_trim + +PUBLIC :: len_trim + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE repeat + MODULE PROCEDURE srepeat_string_string +END INTERFACE repeat + +PUBLIC :: repeat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE scan + MODULE PROCEDURE sscan_string_string, sscan_string_character, & + & sscan_character_string +END INTERFACE scan + +PUBLIC :: scan + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE trim + MODULE PROCEDURE strim +END INTERFACE trim + +PUBLIC :: trim + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE verify + MODULE PROCEDURE sverify_string_string, sverify_string_character, & + & sverify_character_string +END INTERFACE verify + +PUBLIC :: verify + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE string + MODULE PROCEDURE constructor1, constructor2 +END INTERFACE string + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE display + MODULE PROCEDURE display_str +END INTERFACE display + +PUBLIC :: display + +INTERFACE Reallocate + MODULE PROCEDURE String_Reallocate1, String_Reallocate2 +END INTERFACE Reallocate + +PUBLIC :: Reallocate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 Oct 2021 +! summary: String data type +! +!# Introduction +! {!pages/docs-api/String/String_.md} + +TYPE :: String + !< OOP designed string class. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw + !! Raw data. +CONTAINS + ! public methods + ! builtins replacements + PROCEDURE, PASS(self) :: adjustl => sadjustl + !! Adjustl replacement. + PROCEDURE, PASS(self) :: adjustr => sadjustr + !! Adjustr replacement. + PROCEDURE, PASS(self) :: count => scount + !! Count replacement. + GENERIC :: index => sindex_string_string, & + sindex_string_character + !! Index replacement. + PROCEDURE, PASS(self) :: len => slen + !! Len replacement. + PROCEDURE, PASS(self) :: len_trim => slen_trim + !! Len_trim replacement. + GENERIC :: repeat => srepeat_string_string, & + srepeat_character_string + !! Repeat replacement. + GENERIC :: scan => sscan_string_string, & + sscan_string_character + !! Scan replacement. + PROCEDURE, PASS(self) :: trim => strim + !! Trim replacement. + GENERIC :: verify => sverify_string_string, & + sverify_string_character + !! Verify replacement. + ! auxiliary methods + PROCEDURE, PASS(self) :: basedir + !! Return the base directory name of a string containing a file name. + PROCEDURE, PASS(self) :: basename + !! Return the base file name of a string containing a file name. + PROCEDURE, PASS(self) :: camelcase + !! Return a string with all words capitalized without spaces. + PROCEDURE, PASS(self) :: capitalize + !! Return a string with its first character capitalized and the rest + !! lowercased. + PROCEDURE, PASS(self) :: chars + !! Return the raw characters data. + GENERIC :: colorize => colorize_str + !! Colorize and stylize strings. + PROCEDURE, PASS(self) :: decode + !! Decode string. + PROCEDURE, PASS(self) :: encode + !! Encode string. + PROCEDURE, PASS(self) :: escape + !! Escape backslashes (or custom escape character). + PROCEDURE, PASS(self) :: extension + !! Return the extension of a string containing a file name. + PROCEDURE, PASS(self) :: fill + !! Pad string on the left (or right) with zeros (or other char) to fill + !! width. + PROCEDURE, PASS(self) :: free + !! Free dynamic memory. + GENERIC :: glob => & + glob_character, & + glob_string + !! Glob search, finds all the pathnames matching a given pattern. + GENERIC :: insert => & + insert_string, & + insert_character + !! Insert substring into string at a specified position. + GENERIC :: join => & + join_strings, & + join_characters + !! Return a string that is a join of an array of strings or characters. + GENERIC :: strjoin => & + strjoin_strings, & + strjoin_characters, & + strjoin_strings_array, & + strjoin_characters_array + !! Return a string that is a join of an array of strings or characters; + !! Return join 1D string array of an 2D array of strings or + !! characters in columns or rows. + PROCEDURE, PASS(self) :: lower + !! Return a string with all lowercase characters. + PROCEDURE, PASS(self) :: partition + !! Split string at separator and return the 3 parts (before, the + !! separator and after). + PROCEDURE, PASS(self) :: read_file + !! Read a file a single string stream. + GENERIC, PUBLIC :: readFile => read_file + !! Generic function for reading file + PROCEDURE, PASS(self) :: read_line + !! Read line (record) from a connected unit. + GENERIC, PUBLIC :: readLine => read_line + !! Generic method for reading a record from file + PROCEDURE, PASS(self) :: read_lines + !! Read (all) lines (records) from a connected unit as a single ascii + !! stream. + GENERIC, PUBLIC :: readLines => read_lines + !! Generic method for reading all lines from a file + PROCEDURE, PASS(self) :: replace + !! Return a string with all occurrences of substring old replaced by new. + PROCEDURE, PASS(self) :: reverse + !! Return a reversed string. + PROCEDURE, PASS(self) :: search + !! Search for *tagged* record into string. + PROCEDURE, PASS(self) :: slice + !! Return the raw characters data sliced. + PROCEDURE, PASS(self) :: snakecase + !! Return a string with all words lowercase separated by "_". + PROCEDURE, PASS(self) :: split + !! Return a list of substring in the string, using sep as the + !! delimiter string. + PROCEDURE, PASS(self) :: split_chunked + !! Return a list of substring in the string, using sep as the + !! delimiter string. + PROCEDURE, PASS(self) :: startcase + !! Return a string with all words capitalized, e.g. title case. + PROCEDURE, PASS(self) :: strip + !! Return a string with the leading and trailing characters removed. + PROCEDURE, PASS(self) :: swapcase + !! Return a string with uppercase chars converted to lowercase + !! and vice versa. + PROCEDURE, PASS(self) :: tempname + !! Return a safe temporary name suitable for temporary file + !! or directories. + GENERIC :: to_number => & + to_integer_I1P, & +#ifndef _NVF + to_integer_I2P, & +#endif + to_integer_I4P, & + to_integer_I8P, & +#ifdef _R16P + to_real_R16P, & +#endif + to_real_R8P, & + to_real_R4P + !! Cast string to number. + PROCEDURE, PASS(self) :: unescape + !! Unescape double backslashes (or custom escaped character). + PROCEDURE, PASS(self) :: unique + !! Reduce to one (unique) multiple occurrences of a substring into + !! a string. + PROCEDURE, PASS(self) :: upper + !! Return a string with all uppercase characters. + PROCEDURE, PASS(self) :: write_file + !! Write a single string stream into file. + PROCEDURE, PASS(self) :: write_line + !! Write line (record) to a connected unit. + PROCEDURE, PASS(self) :: write_lines + !! Write lines (records) to a connected unit. + ! inquire methods + PROCEDURE, PASS(self) :: end_with + !! Return true if a string ends with a specified suffix. + PROCEDURE, PASS(self) :: is_allocated + !! Return true if the string is allocated. + PROCEDURE, PASS(self) :: is_digit + !! Return true if all characters in the string are digits. + PROCEDURE, PASS(self) :: is_integer + !! Return true if the string contains an integer. + PROCEDURE, PASS(self) :: is_number + !! Return true if the string contains a number (real or integer). + PROCEDURE, PASS(self) :: is_real + !! Return true if the string contains an real. + PROCEDURE, PASS(self) :: is_logical + !! Return true if the string contains logical. + PROCEDURE, PASS(self) :: is_lower + !! Return true if all characters in the string are lowercase. + PROCEDURE, PASS(self) :: is_upper + !! Return true if all characters in the string are uppercase. + PROCEDURE, PASS(self) :: start_with + !! Return true if a string starts with a specified prefix. + ! operators + GENERIC :: ASSIGNMENT(=) => string_assign_string, & + string_assign_character, & + string_assign_integer_I1P, & + string_assign_integer_I2P, & + string_assign_integer_I4P, & + string_assign_integer_I8P, & +#ifdef _R16P + string_assign_real_R16P, & +#endif + string_assign_real_R8P, & + string_assign_real_R4P + !! Assignment operator overloading. + GENERIC :: OPERATOR(//) => & + & string_concat_string, & + & string_concat_character, & + & character_concat_string + !! Concatenation operator overloading. + GENERIC :: OPERATOR(.cat.) => & + & string_concat_string_string, & + & string_concat_character_string, & + & character_concat_string_string + !! Concatenation operator (string output) overloading. + GENERIC :: OPERATOR(==) => string_eq_string, & + string_eq_character, & + character_eq_string + !! Equal operator overloading. + GENERIC :: OPERATOR(/=) => string_ne_string, & + string_ne_character, & + character_ne_string + !! Not equal operator overloading. + GENERIC :: OPERATOR(<) => string_lt_string, & + string_lt_character, & + character_lt_string + !! Lower than operator overloading. + GENERIC :: OPERATOR(<=) => string_le_string, & + string_le_character, & + character_le_string + !! Lower equal than operator overloading. + GENERIC :: OPERATOR(>=) => string_ge_string, & + string_ge_character, & + character_ge_string + !! Greater equal than operator overloading. + GENERIC :: OPERATOR(>) => string_gt_string, & + string_gt_character, & + character_gt_string + !! Greater than operator overloading. + ! IO + GENERIC :: READ (formatted) => read_formatted + !! Formatted input. + GENERIC :: WRITE (formatted) => write_formatted + !! Formatted output. + GENERIC :: READ (unformatted) => read_unformatted + !! Unformatted input. + GENERIC :: WRITE (unformatted) => write_unformatted + !! Unformatted output. + PROCEDURE, PUBLIC, PASS(self) :: Display => display_str + ! private methods + ! builtins replacements + PROCEDURE, PRIVATE, PASS(self) :: sindex_string_string + !! Index replacement. + PROCEDURE, PRIVATE, PASS(self) :: sindex_string_character + !! Index replacement. + PROCEDURE, PRIVATE, PASS(self) :: srepeat_string_string + !! Repeat replacement. + PROCEDURE, PRIVATE, NOPASS :: srepeat_character_string + !! Repeat replacement. + PROCEDURE, PRIVATE, PASS(self) :: sscan_string_string + !! Scan replacement. + PROCEDURE, PRIVATE, PASS(self) :: sscan_string_character + !! Scan replacement. + PROCEDURE, PRIVATE, PASS(self) :: sverify_string_string + !! Verify replacement. + PROCEDURE, PRIVATE, PASS(self) :: sverify_string_character + !! Verify replacement. + ! auxiliary methods + PROCEDURE, PRIVATE, PASS(self) :: colorize_str + !! Colorize and stylize strings. + PROCEDURE, PRIVATE, PASS(self) :: glob_character + !! Glob search (character output). + PROCEDURE, PRIVATE, PASS(self) :: glob_string + !! Glob search (string output). + PROCEDURE, PRIVATE, PASS(self) :: insert_string + !! Insert substring into string at a specified position. + PROCEDURE, PRIVATE, PASS(self) :: insert_character + !! Insert substring into string at a specified position. + PROCEDURE, PRIVATE, PASS(self) :: join_strings + !! Return join string of an array of strings. + PROCEDURE, PRIVATE, PASS(self) :: join_characters + !! Return join string of an array of characters. + PROCEDURE, PRIVATE, NOPASS :: strjoin_strings + !! Return join string of an array of strings. + PROCEDURE, PRIVATE, NOPASS :: strjoin_characters + !! Return join string of an array of strings. + PROCEDURE, PRIVATE, NOPASS :: strjoin_strings_array + !! Return join 1D string array of an 2D array of strings in columns + !! or rows. + PROCEDURE, PRIVATE, NOPASS :: strjoin_characters_array + !! Return join 1D string array of an 2D array of characters in columns + !! or rows. + PROCEDURE, PRIVATE, PASS(self) :: to_integer_I1P + !! Cast string to integer. +#ifndef _NVF + PROCEDURE, PRIVATE, PASS(self) :: to_integer_I2P + !! Cast string to integer. +#endif + PROCEDURE, PRIVATE, PASS(self) :: to_integer_I4P + !! Cast string to integer. + PROCEDURE, PRIVATE, PASS(self) :: to_integer_I8P + !! Cast string to integer. + PROCEDURE, PRIVATE, PASS(self) :: to_real_R4P + !! Cast string to real. + PROCEDURE, PRIVATE, PASS(self) :: to_real_R8P + !! Cast string to real. + PROCEDURE, PRIVATE, PASS(self) :: to_real_R16P + !! Cast string to real. + PROCEDURE, PUBLIC, PASS(self) :: to_logical + !! Convert a string to logical + ! assignments + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_string + !! Assignment operator from string input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_character + !! Assignment operator from character input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I1P + !! Assignment operator from integer input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I2P + !! Assignment operator from integer input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I4P + !! Assignment operator from integer input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_integer_I8P + !! Assignment operator from integer input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_real_R4P + !! Assignment operator from real input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_real_R8P + !! Assignment operator from real input. + PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_real_R16P + !! Assignment operator from real input. + ! concatenation operators + PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_string + !! Concatenation with string. + PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_character + !! Concatenation with character. + PROCEDURE, PRIVATE, PASS(rhs) :: character_concat_string + !! Concatenation with character (inverted). + PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_string_string + !! Concatenation with string (string output). + PROCEDURE, PRIVATE, PASS(lhs) :: string_concat_character_string + !! Concatenation with character (string output). + PROCEDURE, PRIVATE, PASS(rhs) :: character_concat_string_string + !! Concatenation with character (inverted, string output). + !! logical operators + PROCEDURE, PRIVATE, PASS(lhs) :: string_eq_string + !! Equal to string logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_eq_character + !! Equal to character logical operator. + PROCEDURE, PRIVATE, PASS(rhs) :: character_eq_string + !! Equal to character (inverted) logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_ne_string + !! Not equal to string logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_ne_character + !! Not equal to character logical operator. + PROCEDURE, PRIVATE, PASS(rhs) :: character_ne_string + !! Not equal to character (inverted) logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_lt_string + !! Lower than to string logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_lt_character + !! Lower than to character logical operator. + PROCEDURE, PRIVATE, PASS(rhs) :: character_lt_string + !! Lower than to character (inverted) logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_le_string + !! Lower equal than to string logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_le_character + !! Lower equal than to character logical operator. + PROCEDURE, PRIVATE, PASS(rhs) :: character_le_string + !! Lower equal than to character (inverted) logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_ge_string + !! Greater equal than to string logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_ge_character + !! Greater equal than to character logical operator. + PROCEDURE, PRIVATE, PASS(rhs) :: character_ge_string + !! Greater equal than to character (inverted) logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_gt_string + !! Greater than to string logical operator. + PROCEDURE, PRIVATE, PASS(lhs) :: string_gt_character + !! Greater than to character logical operator. + PROCEDURE, PRIVATE, PASS(rhs) :: character_gt_string + !! Greater than to character (inverted) logical operator. + !! IO + PROCEDURE, PRIVATE, PASS(dtv) :: read_formatted + !! Formatted input. + PROCEDURE, PRIVATE, PASS(dtv) :: read_delimited + !! Read a delimited input. + PROCEDURE, PRIVATE, PASS(dtv) :: read_undelimited + !! Read an undelimited input. + PROCEDURE, PRIVATE, PASS(dtv) :: read_undelimited_listdirected + !! Read an undelimited list directed input. + PROCEDURE, PRIVATE, PASS(dtv) :: write_formatted + !! Formatted output. + PROCEDURE, PRIVATE, PASS(dtv) :: read_unformatted + !! Unformatted input. + PROCEDURE, PRIVATE, PASS(dtv) :: write_unformatted + !! Unformatted output. + PROCEDURE, PRIVATE, PASS(self) :: replace_one_occurrence + !! Replace the first occurrence of substring old by new. + PROCEDURE, PRIVATE, PASS(obj) :: nmatchstr_1, nmatchstr_2 + GENERIC, PUBLIC :: nmatchstr => nmatchstr_1, nmatchstr_2 + PROCEDURE, PRIVATE, PASS(obj) :: strfind_1, strfind_2 + GENERIC, PUBLIC :: strfind => strfind_1, strfind_2 +END TYPE string + +PUBLIC :: String + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE(String), PUBLIC, PARAMETER :: TypeString = String(raw=NULL()) + +TYPE :: StringPointer_ + CLASS(String), POINTER :: ptr => NULL() +END TYPE StringPointer_ +PUBLIC :: StringPointer_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 26 July 2022 +! summary: Overloading glob procedure. +! +! +!```fortran +! type(string) :: astring +! character(len=:), allocatable :: alist_chr(:) +! type(string), allocatable :: alist_str(:) +! integer, parameter :: Nf=5 +! character(14) :: files(1:Nf) +! integer :: file_unit +! integer :: f +! integer :: ff +! logical :: test_passed +! do f=1, Nf +! files(f) = astring%tempname(prefix='foo-') +! open(newunit=file_unit, file=files(f)) +! write(file_unit, *)f +! close(unit=file_unit) +! enddo +! call glob(self=astring, pattern='foo-*', list=alist_chr) +! call glob(self=astring, pattern='foo-*', list=alist_str) +! do f=1, Nf +! open(newunit=file_unit, file=files(f)) +! close(unit=file_unit, status='delete') +! enddo +! test_passed = .false. +! outer_chr: do f=1, size(alist_chr, dim=1) +! do ff=1, Nf +! test_passed = alist_chr(f) == files(ff) +! if (test_passed) cycle outer_chr +! enddo +! enddo outer_chr +! if (test_passed) then +! test_passed = .false. +! outer_str: do f=1, size(alist_str, dim=1) +! do ff=1, Nf +! test_passed = alist_str(f) == files(ff) +! if (test_passed) cycle outer_str +! enddo +! enddo outer_str +! endif +! print '(L1)', test_passed +!``` + +INTERFACE glob + MODULE PROCEDURE glob_character, glob_string +END INTERFACE glob + +PUBLIC :: glob + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS +! public non TBP + +! creator +PURE FUNCTION string_(c) + !< Return a string given a character input. + !< + !<```fortran + !< print "(L1)", string('Hello World')//''=='Hello World' + !<``` + !=> T <<< + CHARACTER(*), INTENT(IN) :: c !< Character. + TYPE(string) :: string_ !< String. + + string_%raw = c +END FUNCTION string_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! builtins replacements +PURE FUNCTION sadjustl_character(s) RESULT(adjusted) + !< Left adjust a string by removing leading spaces (character output). + !< + !<```fortran + !< type(string) :: astring + !< astring = ' Hello World!' + !< print "(L1)", adjustl(astring)=='Hello World! ' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: s !< String. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: adjusted !< Adjusted string. + + IF (ALLOCATED(s%raw)) adjusted = ADJUSTL(s%raw) +END FUNCTION sadjustl_character + +PURE FUNCTION sadjustr_character(s) RESULT(adjusted) + !< Right adjust a string by removing leading spaces (character output). + !< + !<```fortran + !< type(string) :: astring + !< astring = 'Hello World! ' + !< print "(L1)", adjustr(astring)==' Hello World!' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: s !< String. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: adjusted !< Adjusted string. + + IF (ALLOCATED(s%raw)) adjusted = ADJUSTR(s%raw) +END FUNCTION sadjustr_character + +ELEMENTAL FUNCTION count_substring(s, substring) RESULT(No) + !< Count the number of occurences of a substring into a string. + !< + !<```fortran + !< print "(L1)", count('hello', substring='ll')==1 + !<``` + !=> T <<< + CHARACTER(*), INTENT(IN) :: s !< String. + CHARACTER(*), INTENT(IN) :: substring !< Substring. + INTEGER(I4P) :: No !< Number of occurrences. + INTEGER(I4P) :: c1 !< Counters. + INTEGER(I4P) :: c2 !< Counters. + + No = 0 + IF (LEN(substring) > LEN(s)) RETURN + c1 = 1 + DO + c2 = INDEX(string=s(c1:), substring=substring) + IF (c2 == 0) RETURN + No = No + 1 + c1 = c1 + c2 + LEN(substring) + END DO +END FUNCTION count_substring + +ELEMENTAL FUNCTION sindex_character_string(s, substring, back) RESULT(i) + !< Return the position of the start of the first occurrence of string `substring` as a substring in `string`, counting from one. + !< If `substring` is not present in `string`, zero is returned. If the back argument is present and true, the return value is + !< the start of the last occurrence rather than the first. + !< + !<```fortran + !< type(string) :: string1 + !< logical :: test_passed(2) + !< string1 = 'llo' + !< test_passed(1) = index(s='Hello World Hello!', substring=string1)==index(string='Hello World Hello!', substring='llo') + !< test_passed(2) = index(s='Hello World Hello!', substring=string1, back=.true.)==index(string='Hello World Hello!', & + !< substring='llo', back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: s !< String. + TYPE(string), INTENT(IN) :: substring !< Searched substring. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(substring%raw)) THEN + i = INDEX(string=s, substring=substring%raw, back=back) + ELSE + i = 0 + END IF +END FUNCTION sindex_character_string + +ELEMENTAL FUNCTION sscan_character_string(s, set, back) RESULT(i) + !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is in `set`. + !< + !<```fortran + !< type(string) :: string1 + !< logical :: test_passed(2) + !< string1 = 'llo' + !< test_passed(1) = scan(s='Hello World Hello!', set=string1)==scan(string='Hello World Hello!', set='llo') + !< test_passed(2) = scan(s='Hello World Hello!', set=string1, back=.true.)==scan(string='Hello World Hello!', & + !< set='llo', back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: s !< String. + TYPE(string), INTENT(IN) :: set !< Searched set. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(set%raw)) THEN + i = SCAN(string=s, set=set%raw, back=back) + ELSE + i = 0 + END IF +END FUNCTION sscan_character_string + +ELEMENTAL FUNCTION sverify_character_string(s, set, back) RESULT(i) + !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is not + !< in `set`. If all characters of `string` are found in `set`, the result is zero. + !< + !<```fortran + !< type(string) :: string1 + !< logical :: test_passed(2) + !< string1 = 'ell' + !< test_passed(1) = verify(s='Hello World Hello!', set=string1)==verify(string='Hello World Hello!', set='llo') + !< test_passed(2) = verify(s='Hello World Hello!', set=string1, back=.true.)==verify(string='Hello World Hello!', set='llo', & + !< back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: s !< String. + TYPE(string), INTENT(IN) :: set !< Searched set. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(set%raw)) THEN + i = VERIFY(string=s, set=set%raw, back=back) + ELSE + i = 0 + END IF +END FUNCTION sverify_character_string + +! public methods + +! builtins replacements +ELEMENTAL FUNCTION sadjustl(self) RESULT(adjusted) + !< Left adjust a string by removing leading spaces. + !< + !<```fortran + !< type(string) :: astring + !< astring = ' Hello World!' + !< print "(L1)", astring%adjustl()//''=='Hello World! ' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: adjusted !< Adjusted string. + + adjusted = self + IF (ALLOCATED(adjusted%raw)) adjusted%raw = ADJUSTL(adjusted%raw) +END FUNCTION sadjustl + +ELEMENTAL FUNCTION sadjustr(self) RESULT(adjusted) + !< Right adjust a string by removing leading spaces. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'Hello World! ' + !< print "(L1)", astring%adjustr()//''==' Hello World!' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: adjusted !< Adjusted string. + + adjusted = self + IF (ALLOCATED(adjusted%raw)) adjusted%raw = ADJUSTR(adjusted%raw) +END FUNCTION sadjustr + +ELEMENTAL FUNCTION scount(self, substring, ignore_isolated) RESULT(No) + !< Count the number of occurences of a substring into a string. + !< + !< @note If `ignore_isolated` is set to true the eventual "isolated" occurences are ignored: an isolated occurrences are those + !< occurrences happening at the start of string (thus not having a left companion) or at the end of the string (thus not having a + !< right companion). + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(4) + !< astring = ' Hello World ! ' + !< test_passed(1) = astring%count(substring=' ')==10 + !< astring = 'Hello World ! ' + !< test_passed(2) = astring%count(substring=' ', ignore_isolated=.true.)==6 + !< astring = ' Hello World !' + !< test_passed(3) = astring%count(substring=' ', ignore_isolated=.true.)==6 + !< astring = ' Hello World ! ' + !< test_passed(4) = astring%count(substring=' ', ignore_isolated=.true.)==8 + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(*), INTENT(IN) :: substring !< Substring. + LOGICAL, INTENT(IN), OPTIONAL :: ignore_isolated !< Ignore "isolated" occurrences. + INTEGER :: No !< Number of occurrences. + LOGICAL :: ignore_isolated_ !< Ignore "isolated" occurrences, local variable. + INTEGER :: c1 !< Counter. + INTEGER :: c2 !< Counter. + + No = 0 + IF (ALLOCATED(self%raw)) THEN + IF (LEN(substring) > LEN(self%raw)) RETURN + ignore_isolated_ = .FALSE.; IF (PRESENT(ignore_isolated)) ignore_isolated_ = ignore_isolated + c1 = 1 + DO + c2 = INDEX(string=self%raw(c1:), substring=substring) + IF (c2 == 0) RETURN + IF (.NOT. ignore_isolated_) THEN + No = No + 1 + ELSE + IF (.NOT. ((c1 == 1 .AND. c2 == 1) & + & .OR. (c1 == LEN(self%raw) - LEN(substring) + 1))) THEN + No = No + 1 + END IF + END IF + c1 = c1 + c2 - 1 + LEN(substring) + END DO + END IF +END FUNCTION scount + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION sindex_string_string(self, substring, back) RESULT(i) + !< Return the position of the start of the first occurrence of string `substring` as a substring in `string`, counting from one. + !< If `substring` is not present in `string`, zero is returned. If the back argument is present and true, the return value is + !< the start of the last occurrence rather than the first. + !< + !<```fortran + !< type(string) :: string1 + !< type(string) :: string2 + !< logical :: test_passed(2) + !< string1 = 'Hello World Hello!' + !< string2 = 'llo' + !< test_passed(1) = string1%index(substring=string2)==index(string='Hello World Hello!', substring='llo') + !< test_passed(2) = string1%index(substring=string2, back=.true.)==index(string='Hello World Hello!', substring='llo', & + !< back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string), INTENT(IN) :: substring !< Searched substring. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(self%raw)) THEN + i = INDEX(string=self%raw, substring=substring%raw, back=back) + ELSE + i = 0 + END IF +END FUNCTION sindex_string_string + +ELEMENTAL FUNCTION sindex_string_character(self, substring, back) RESULT(i) + !< Return the position of the start of the first occurrence of string `substring` as a substring in `string`, counting from one. + !< If `substring` is not present in `string`, zero is returned. If the back argument is present and true, the return value is + !< the start of the last occurrence rather than the first. + !< + !<```fortran + !< type(string) :: string1 + !< logical :: test_passed(2) + !< string1 = 'Hello World Hello!' + !< test_passed(1) = string1%index(substring='llo')==index(string='Hello World Hello!', substring='llo') + !< test_passed(2) = string1%index(substring='llo', back=.true.)==index(string='Hello World Hello!', substring='llo', back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: substring !< Searched substring. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(self%raw)) THEN + i = INDEX(string=self%raw, substring=substring, back=back) + ELSE + i = 0 + END IF +END FUNCTION sindex_string_character + +ELEMENTAL FUNCTION slen(self) RESULT(l) + !< Return the length of a string. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'Hello World! ' + !< print "(L1)", astring%len()==len('Hello World! ') + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + INTEGER :: l !< String length. + + IF (ALLOCATED(self%raw)) THEN + l = LEN(string=self%raw) + ELSE + l = 0 + END IF +END FUNCTION slen + +ELEMENTAL FUNCTION slen_trim(self) RESULT(l) + !< Return the length of a string, ignoring any trailing blanks. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'Hello World! ' + !< print "(L1)", astring%len_trim()==len_trim('Hello World! ') + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + INTEGER :: l !< String length. + + IF (ALLOCATED(self%raw)) THEN + l = LEN_TRIM(string=self%raw) + ELSE + l = 0 + END IF +END FUNCTION slen_trim + +ELEMENTAL FUNCTION srepeat_string_string(self, ncopies) RESULT(repeated) + !< Concatenates several copies of an input string. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'x' + !< print "(L1)", astring%repeat(5)//''=='xxxxx' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< String to be repeated. + INTEGER, INTENT(IN) :: ncopies !< Number of string copies. + TYPE(string) :: repeated !< Repeated string. +#ifdef _NVF + CHARACTER(9999) :: nvf_bug !< Work around for NVFortran bug. +#endif + +#ifdef _NVF + nvf_bug = self%raw + repeated%raw = REPEAT(string=TRIM(nvf_bug), ncopies=ncopies) +#else + repeated%raw = REPEAT(string=self%raw, ncopies=ncopies) +#endif +END FUNCTION srepeat_string_string + +ELEMENTAL FUNCTION srepeat_character_string(rstring, ncopies) RESULT(repeated) + !< Concatenates several copies of an input string. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'y' + !< print "(L1)", astring%repeat('x', 5)//''=='xxxxx' + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: rstring !< String to be repeated. + INTEGER, INTENT(IN) :: ncopies !< Number of string copies. + TYPE(string) :: repeated !< Repeated string. + + repeated%raw = REPEAT(string=rstring, ncopies=ncopies) +END FUNCTION srepeat_character_string + +ELEMENTAL FUNCTION sscan_string_string(self, set, back) RESULT(i) + !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is in `set`. + !< + !<```fortran + !< type(string) :: string1 + !< type(string) :: string2 + !< logical :: test_passed(2) + !< string1 = 'Hello World Hello!' + !< string2 = 'llo' + !< test_passed(1) = string1%scan(set=string2)==scan(string='Hello World Hello!', set='llo') + !< test_passed(2) = string1%scan(set=string2, back=.true.)==scan(string='Hello World Hello!', set='llo', back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string), INTENT(IN) :: set !< Searched set. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(self%raw) .AND. ALLOCATED(set%raw)) THEN + i = SCAN(string=self%raw, set=set%raw, back=back) + ELSE + i = 0 + END IF +END FUNCTION sscan_string_string + +ELEMENTAL FUNCTION sscan_string_character(self, set, back) RESULT(i) + !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is in `set`. + !< + !<```fortran + !< type(string) :: string1 + !< logical :: test_passed(2) + !< string1 = 'Hello World Hello!' + !< test_passed(1) = string1%scan(set='llo')==scan(string='Hello World Hello!', set='llo') + !< test_passed(2) = string1%scan(set='llo', back=.true.)==scan(string='Hello World Hello!', set='llo', back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: set !< Searched set. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(self%raw)) THEN + i = SCAN(string=self%raw, set=set, back=back) + ELSE + i = 0 + END IF +END FUNCTION sscan_string_character + +ELEMENTAL FUNCTION strim(self) RESULT(trimmed) + !< Remove trailing spaces. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'Hello World! ' + !< print "(L1)", astring%trim()==trim('Hello World! ') + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: trimmed !< Trimmed string. + + trimmed = self + IF (ALLOCATED(trimmed%raw)) trimmed%raw = TRIM(trimmed%raw) +END FUNCTION strim + +ELEMENTAL FUNCTION sverify_string_string(self, set, back) RESULT(i) + !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is not + !< in `set`. If all characters of `string` are found in `set`, the result is zero. + !< + !<```fortran + !< type(string) :: string1 + !< type(string) :: string2 + !< logical :: test_passed(2) + !< string1 = 'Hello World Hello!' + !< string2 = 'llo' + !< test_passed(1) = string1%verify(set=string2)==verify(string='Hello World Hello!', set='llo') + !< test_passed(2) = string1%verify(set=string2, back=.true.)==verify(string='Hello World Hello!', set='llo', back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string), INTENT(IN) :: set !< Searched set. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(self%raw) .AND. ALLOCATED(set%raw)) THEN + i = VERIFY(string=self%raw, set=set%raw, back=back) + ELSE + i = 0 + END IF +END FUNCTION sverify_string_string + +ELEMENTAL FUNCTION sverify_string_character(self, set, back) RESULT(i) + !< Return the leftmost (if `back` is either absent or equals false, otherwise the rightmost) character of string that is not + !< in `set`. If all characters of `string` are found in `set`, the result is zero. + !< + !<```fortran + !< type(string) :: string1 + !< logical :: test_passed(2) + !< string1 = 'Hello World Hello!' + !< test_passed(1) = string1%verify(set='llo')==verify(string='Hello World Hello!', set='llo') + !< test_passed(2) = string1%verify(set='llo', back=.true.)==verify(string='Hello World Hello!', set='llo', back=.true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: set !< Searched set. + LOGICAL, INTENT(IN), OPTIONAL :: back !< Start of the last occurrence rather than the first. + INTEGER :: i !< Result of the search. + + IF (ALLOCATED(self%raw)) THEN + i = VERIFY(string=self%raw, set=set, back=back) + ELSE + i = 0 + END IF +END FUNCTION sverify_string_character + +! auxiliary methods +ELEMENTAL FUNCTION basedir(self, sep) + !< Return the base directory name of a string containing a file name. + !< + !<```fortran + !< type(string) :: string1 + !< logical :: test_passed(4) + !< string1 = '/bar/foo.tar.bz2' + !< test_passed(1) = string1%basedir()//''=='/bar' + !< string1 = './bar/foo.tar.bz2' + !< test_passed(2) = string1%basedir()//''=='./bar' + !< string1 = 'bar/foo.tar.bz2' + !< test_passed(3) = string1%basedir()//''=='bar' + !< string1 = '\bar\foo.tar.bz2' + !< test_passed(4) = string1%basedir(sep='\')//''=='\bar' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Directory separator. + TYPE(string) :: basedir !< Base directory name. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + INTEGER :: pos !< Character position. + + IF (ALLOCATED(self%raw)) THEN + sep_ = UIX_DIR_SEP; IF (PRESENT(sep)) sep_ = sep + basedir = self + pos = INDEX(self%raw, sep_, back=.TRUE.) + IF (pos > 0) basedir%raw = self%raw(1:pos - 1) + END IF +END FUNCTION basedir + +ELEMENTAL FUNCTION basename(self, sep, extension, strip_last_extension) + !< Return the base file name of a string containing a file name. + !< + !< Optionally, the extension is also stripped if provided or the last one if required, e.g. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(5) + !< astring = 'bar/foo.tar.bz2' + !< test_passed(1) = astring%basename()//''=='foo.tar.bz2' + !< test_passed(2) = astring%basename(extension='.tar.bz2')//''=='foo' + !< test_passed(3) = astring%basename(strip_last_extension=.true.)//''=='foo.tar' + !< astring = '\bar\foo.tar.bz2' + !< test_passed(4) = astring%basename(sep='\')//''=='foo.tar.bz2' + !< astring = 'bar' + !< test_passed(5) = astring%basename(strip_last_extension=.true.)//''=='bar' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Directory separator. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: extension !< File extension. + LOGICAL, INTENT(IN), OPTIONAL :: strip_last_extension !< Flag to enable the stripping of last extension. + TYPE(string) :: basename !< Base file name. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + INTEGER :: pos !< Character position. + + IF (ALLOCATED(self%raw)) THEN + sep_ = UIX_DIR_SEP; IF (PRESENT(sep)) sep_ = sep + basename = self + pos = INDEX(basename%raw, sep_, back=.TRUE.) + IF (pos > 0) basename%raw = self%raw(pos + 1:) + IF (PRESENT(extension)) THEN + pos = INDEX(basename%raw, extension, back=.TRUE.) + IF (pos > 0) basename%raw = basename%raw(1:pos - 1) + ELSEIF (PRESENT(strip_last_extension)) THEN + IF (strip_last_extension) THEN + pos = INDEX(basename%raw, '.', back=.TRUE.) + IF (pos > 0) basename%raw = basename%raw(1:pos - 1) + END IF + END IF + END IF +END FUNCTION basename + +ELEMENTAL FUNCTION camelcase(self, sep) + !< Return a string with all words capitalized without spaces. + !< + !< @note Multiple subsequent separators are collapsed to one occurence. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'caMeL caSe var' + !< print '(L1)', astring%camelcase()//''=='CamelCaseVar' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + TYPE(string) :: camelcase !< Camel case string. + TYPE(string), ALLOCATABLE :: tokens(:) !< String tokens. + + IF (ALLOCATED(self%raw)) THEN + CALL self%split(tokens=tokens, sep=sep) + tokens = tokens%capitalize() + camelcase = camelcase%join(array=tokens) + END IF +END FUNCTION camelcase + +ELEMENTAL FUNCTION capitalize(self) RESULT(capitalized) + !< Return a string with its first character capitalized and the rest lowercased. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'say all Hello WorLD!' + !< print '(L1)', astring%capitalize()//''=='Say all hello world!' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: capitalized !< Upper case string. + INTEGER :: c !< Character counter. + + IF (ALLOCATED(self%raw)) THEN + capitalized = self%lower() + c = INDEX(LOWER_ALPHABET, capitalized%raw(1:1)) + IF (c > 0) capitalized%raw(1:1) = UPPER_ALPHABET(c:c) + END IF +END FUNCTION capitalize + +PURE FUNCTION chars(self) RESULT(raw) + !< Return the raw characters data. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'say all Hello WorLD!' + !< print '(L1)', astring%chars()=='say all Hello WorLD!' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw !< Raw characters data. + + IF (ALLOCATED(self%raw)) THEN + raw = self%raw + ELSE + raw = '' + END IF +END FUNCTION chars + +PURE FUNCTION colorize_str(self, color_fg, color_bg, style) RESULT(colorized) + !< Colorize and stylize strings, DEFAULT kind. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'say all Hello WorLD!' + !< print '(L1)', astring%colorize(color_fg='red')=='say all Hello WorLD!' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: color_fg !< Foreground color definition. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: color_bg !< Background color definition. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: style !< Style definition. + CHARACTER(len=:), ALLOCATABLE :: colorized !< Colorized string. + + colorized = colorize(string=self%chars(), color_fg=color_fg, color_bg=color_bg, style=style) +END FUNCTION colorize_str + +ELEMENTAL FUNCTION decode(self, codec) RESULT(decoded) + !< Return a string decoded accordingly the codec. + !< + !< @note Only BASE64 codec is currently available. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'SG93IGFyZSB5b3U/' + !< print '(L1)', astring%decode(codec='base64')//''=='How are you?' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: codec !< Encoding codec. + TYPE(string) :: decoded !< Decoded string. + TYPE(string) :: codec_u !< Encoding codec in upper case string. + + IF (ALLOCATED(self%raw)) THEN + decoded = self + codec_u = codec + SELECT CASE (codec_u%upper()//'') + CASE ('BASE64') + CALL b64_decode(code=self%raw, s=decoded%raw) + END SELECT + decoded = decoded%strip(remove_nulls=.TRUE.) + END IF +END FUNCTION decode + +ELEMENTAL FUNCTION encode(self, codec) RESULT(encoded) + !< Return a string encoded accordingly the codec. + !< + !< @note Only BASE64 codec is currently available. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'How are you?' + !< print '(L1)', astring%encode(codec='base64')//''=='SG93IGFyZSB5b3U/' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: codec !< Encoding codec. + TYPE(string) :: encoded !< Encoded string. + + IF (ALLOCATED(self%raw)) THEN + encoded = codec + SELECT CASE (encoded%upper()//'') + CASE ('BASE64') + CALL b64_encode(s=self%raw, code=encoded%raw) + END SELECT + END IF +END FUNCTION encode + +ELEMENTAL FUNCTION escape(self, to_escape, esc) RESULT(escaped) + !< Escape backslashes (or custom escape character). + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(2) + !< astring = '^\s \d+\s*' + !< test_passed(1) = astring%escape(to_escape='\')//''=='^\\s \\d+\\s*' + !< test_passed(2) = astring%escape(to_escape='\', esc='|')//''=='^|\s |\d+|\s*' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=1), INTENT(IN) :: to_escape !< Character to be escaped. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: esc !< Character used to escape. + TYPE(string) :: escaped !< Escaped string. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: esc_ !< Character to escape, local variable. + INTEGER :: c !< Character counter. + + IF (ALLOCATED(self%raw)) THEN + esc_ = BACKSLASH; IF (PRESENT(esc)) esc_ = esc + escaped%raw = '' + DO c = 1, LEN(self%raw) + IF (self%raw(c:c) == to_escape) THEN + escaped%raw = escaped%raw//esc_//to_escape + ELSE + escaped%raw = escaped%raw//self%raw(c:c) + END IF + END DO + END IF +END FUNCTION escape + +ELEMENTAL FUNCTION extension(self) + !< Return the extension of a string containing a file name. + !< + !<```fortran + !< type(string) :: astring + !< astring = '/bar/foo.tar.bz2' + !< print '(L1)', astring%extension()//''=='.bz2' + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: extension !< Extension file name. + INTEGER :: pos !< Character position. + + IF (ALLOCATED(self%raw)) THEN + extension = '' + pos = INDEX(self%raw, '.', back=.TRUE.) + IF (pos > 0) extension%raw = self%raw(pos:) + END IF +END FUNCTION extension + +ELEMENTAL FUNCTION fill(self, width, right, filling_char) RESULT(filled) + !< Pad string on the left (or right) with zeros (or other char) to fill width. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(4) + !< astring = 'this is string example....wow!!!' + !< test_passed(1) = astring%fill(width=40)//''=='00000000this is string example....wow!!!' + !< test_passed(2) = astring%fill(width=50)//''=='000000000000000000this is string example....wow!!!' + !< test_passed(3) = astring%fill(width=50, right=.true.)//''=='this is string example....wow!!!000000000000000000' + !< test_passed(4) = astring%fill(width=40, filling_char='*')//''=='********this is string example....wow!!!' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + INTEGER, INTENT(IN) :: width !< Final width of filled string. + LOGICAL, INTENT(IN), OPTIONAL :: right !< Fill on the right instead of left. + CHARACTER(kind=CK, len=1), INTENT(IN), OPTIONAL :: filling_char !< Filling character (default "0"). + TYPE(string) :: filled !< Filled string. + LOGICAL :: right_ !< Fill on the right instead of left, local variable. + CHARACTER(kind=CK, len=1) :: filling_char_ !< Filling character (default "0"), local variable. + + IF (ALLOCATED(self%raw)) THEN + IF (width > LEN(self%raw)) THEN + right_ = .FALSE.; IF (PRESENT(right)) right_ = right + filling_char_ = '0'; IF (PRESENT(filling_char)) filling_char_ = filling_char + IF (.NOT. right_) THEN + filled%raw = REPEAT(filling_char_, width - LEN(self%raw))//self%raw + ELSE + filled%raw = self%raw//REPEAT(filling_char_, width - LEN(self%raw)) + END IF + END IF + END IF +END FUNCTION fill + +ELEMENTAL SUBROUTINE free(self) + !< Free dynamic memory. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'this is string example....wow!!!' + !< call astring%free + !< print '(L1)', astring%is_allocated().eqv..false. + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: self !< The string. + + IF (ALLOCATED(self%raw)) DEALLOCATE (self%raw) +END SUBROUTINE free + +SUBROUTINE glob_character(self, pattern, list) + !< Glob search (character output), finds all the pathnames matching a given pattern according to the rules used by the Unix shell. + !< + !< @note Method not portable: works only on Unix/GNU Linux OS. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: alist_chr(:) + !< integer, parameter :: Nf=5 + !< character(14) :: files(1:Nf) + !< integer :: file_unit + !< integer :: f + !< integer :: ff + !< logical :: test_passed + !< do f=1, Nf + !< files(f) = astring%tempname(prefix='foo-') + !< open(newunit=file_unit, file=files(f)) + !< write(file_unit, *)f + !< close(unit=file_unit) + !< enddo + !< call astring%glob(pattern='foo-*', list=alist_chr) + !< do f=1, Nf + !< open(newunit=file_unit, file=files(f)) + !< close(unit=file_unit, status='delete') + !< enddo + !< test_passed = .false. + !< outer_chr: do f=1, size(alist_chr, dim=1) + !< do ff=1, Nf + !< test_passed = alist_chr(f) == files(ff) + !< if (test_passed) cycle outer_chr + !< enddo + !< enddo outer_chr + !< print '(L1)', test_passed + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(*), INTENT(IN) :: pattern !< Given pattern. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: list(:) !< List of matching pathnames. + TYPE(string), ALLOCATABLE :: list_(:) !< List of matching pathnames. + INTEGER(I4P) :: max_len !< Maximum length. + INTEGER(I4P) :: matches_number !< Matches number. + INTEGER(I4P) :: m !< Counter. + + CALL self%glob(pattern=pattern, list=list_) + IF (ALLOCATED(list_)) THEN + matches_number = SIZE(list_, dim=1) + max_len = 0 + DO m = 1, matches_number + max_len = MAX(max_len, list_(m)%LEN()) + END DO + ALLOCATE (CHARACTER(max_len) :: list(1:matches_number)) + DO m = 1, matches_number + list(m) = list_(m)%chars() + END DO + END IF +END SUBROUTINE glob_character + +SUBROUTINE glob_string(self, pattern, list) + !< Glob search (string output), finds all the pathnames matching a given pattern according to the rules used by the Unix shell. + !< + !< @note Method not portable: works only on Unix/GNU Linux OS. + !< + !<```fortran + !< type(string) :: astring + !< type(string), allocatable :: alist_str(:) + !< integer, parameter :: Nf=5 + !< character(14) :: files(1:Nf) + !< integer :: file_unit + !< integer :: f + !< integer :: ff + !< logical :: test_passed + !< + !< do f=1, Nf + !< files(f) = astring%tempname(prefix='foo-') + !< open(newunit=file_unit, file=files(f)) + !< write(file_unit, *)f + !< close(unit=file_unit) + !< enddo + !< call astring%glob(pattern='foo-*', list=alist_str) + !< do f=1, Nf + !< open(newunit=file_unit, file=files(f)) + !< close(unit=file_unit, status='delete') + !< enddo + !< test_passed = .false. + !< outer_str: do f=1, size(alist_str, dim=1) + !< do ff=1, Nf + !< test_passed = alist_str(f) == files(ff) + !< if (test_passed) cycle outer_str + !< enddo + !< enddo outer_str + !< print '(L1)', test_passed + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(*), INTENT(IN) :: pattern !< Given pattern. + TYPE(string), ALLOCATABLE, INTENT(out) :: list(:) !< List of matching pathnames. + TYPE(string) :: tempfile !< Safe temporary file. + CHARACTER(len=:), ALLOCATABLE :: tempname !< Safe temporary name. + INTEGER(I4P) :: tempunit !< Unit of temporary file. + + tempname = self%tempname() + CALL execute_command_LINE('ls -1 '//TRIM(ADJUSTL(pattern))//' > '//tempname) + CALL tempfile%read_file(file=tempname) + CALL tempfile%split(sep=NEW_LINE('a'), tokens=list) + OPEN (newunit=tempunit, file=tempname) + CLOSE (unit=tempunit, status='delete') +END SUBROUTINE glob_string + +ELEMENTAL FUNCTION insert_character(self, substring, pos) RESULT(inserted) + !< Insert substring into string at a specified position. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(5) + !< astring = 'this is string example wow!!!' + !< acharacter = '... ' + !< test_passed(1) = astring%insert(substring=acharacter, pos=1)//''=='... this is string example wow!!!' + !< test_passed(2) = astring%insert(substring=acharacter, pos=23)//''=='this is string example... wow!!!' + !< test_passed(3) = astring%insert(substring=acharacter, pos=29)//''=='this is string example wow!!!... ' + !< test_passed(4) = astring%insert(substring=acharacter, pos=-1)//''=='... this is string example wow!!!' + !< test_passed(5) = astring%insert(substring=acharacter, pos=100)//''=='this is string example wow!!!... ' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(len=*), INTENT(IN) :: substring !< Substring. + INTEGER, INTENT(IN) :: pos !< Position from which insert substring. + TYPE(string) :: inserted !< Inserted string. + INTEGER :: safepos !< Safe position from which insert substring. + + IF (ALLOCATED(self%raw)) THEN + inserted = self + safepos = MIN(MAX(1, pos), LEN(self%raw)) + IF (safepos == 1) THEN + inserted%raw = substring//self%raw + ELSEIF (safepos == LEN(self%raw)) THEN + inserted%raw = self%raw//substring + ELSE + inserted%raw = self%raw(1:safepos - 1)//substring//self%raw(safepos:) + END IF + ELSE + inserted%raw = substring + END IF +END FUNCTION insert_character + +ELEMENTAL FUNCTION insert_string(self, substring, pos) RESULT(inserted) + !< Insert substring into string at a specified position. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(5) + !< astring = 'this is string example wow!!!' + !< anotherstring = '... ' + !< test_passed(1) = astring%insert(substring=anotherstring, pos=1)//''=='... this is string example wow!!!' + !< test_passed(2) = astring%insert(substring=anotherstring, pos=23)//''=='this is string example... wow!!!' + !< test_passed(3) = astring%insert(substring=anotherstring, pos=29)//''=='this is string example wow!!!... ' + !< test_passed(4) = astring%insert(substring=anotherstring, pos=-1)//''=='... this is string example wow!!!' + !< test_passed(5) = astring%insert(substring=anotherstring, pos=100)//''=='this is string example wow!!!... ' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string), INTENT(IN) :: substring !< Substring. + INTEGER, INTENT(IN) :: pos !< Position from which insert substring. + TYPE(string) :: inserted !< Inserted string. + INTEGER :: safepos !< Safe position from which insert substring. + + IF (ALLOCATED(self%raw)) THEN + inserted = self + IF (ALLOCATED(substring%raw)) THEN + safepos = MIN(MAX(1, pos), LEN(self%raw)) + IF (safepos == 1) THEN + inserted%raw = substring%raw//self%raw + ELSEIF (safepos == LEN(self%raw)) THEN + inserted%raw = self%raw//substring%raw + ELSE + inserted%raw = self%raw(1:safepos - 1)//substring%raw//self%raw(safepos:) + END IF + END IF + ELSE + IF (ALLOCATED(substring%raw)) inserted%raw = substring%raw + END IF +END FUNCTION insert_string + +PURE FUNCTION join_strings(self, array, sep) RESULT(join) + !< Return a string that is a join of an array of strings. + !< + !< The join-separator is set equals to self if self has a value or it is set to a null string ''. This value can be overridden + !< passing a custom separator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: strings(3) + !< logical :: test_passed(5) + !< strings(1) = 'one' + !< strings(2) = 'two' + !< strings(3) = 'three' + !< test_passed(1) = (astring%join(array=strings)//''==strings(1)//strings(2)//strings(3)) + !< test_passed(2) = (astring%join(array=strings, sep='-')//''==strings(1)//'-'//strings(2)//'-'//strings(3)) + !< call strings(1)%free + !< strings(2) = 'two' + !< strings(3) = 'three' + !< test_passed(3) = (astring%join(array=strings, sep='-')//''==strings(2)//'-'//strings(3)) + !< strings(1) = 'one' + !< strings(2) = 'two' + !< call strings(3)%free + !< test_passed(4) = (astring%join(array=strings, sep='-')//''==strings(1)//'-'//strings(2)) + !< strings(1) = 'one' + !< call strings(2)%free + !< strings(3) = 'three' + !< test_passed(5) = (astring%join(array=strings, sep='-')//''==strings(1)//'-'//strings(3)) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string), INTENT(IN) :: array(1:) !< Array to be joined. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + TYPE(string) :: join !< The join of array. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + INTEGER :: a !< Counter. + + IF (ALLOCATED(self%raw)) THEN + sep_ = self%raw + ELSE + sep_ = '' + END IF + IF (PRESENT(sep)) sep_ = sep + join = '' + DO a = 2, SIZE(array, dim=1) + IF (ALLOCATED(array(a)%raw)) join%raw = join%raw//sep_//array(a)%raw + END DO + IF (ALLOCATED(array(1)%raw)) THEN + join%raw = array(1)%raw//join%raw + ELSE + join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) + END IF +END FUNCTION join_strings + +PURE FUNCTION join_characters(self, array, sep) RESULT(join) + !< Return a string that is a join of an array of characters. + !< + !< The join-separator is set equals to self if self has a value or it is set to a null string ''. This value can be overridden + !< passing a custom separator. + !< + !<```fortran + !< type(string) :: astring + !< character(5) :: characters(3) + !< logical :: test_passed(6) + !< characters(1) = 'one' + !< characters(2) = 'two' + !< characters(3) = 'three' + !< test_passed(1) = (astring%join(array=characters)//''==characters(1)//characters(2)//characters(3)) + !< test_passed(2) = (astring%join(array=characters, sep='-')//''==characters(1)//'-'//characters(2)//'-'//characters(3)) + !< characters(1) = '' + !< characters(2) = 'two' + !< characters(3) = 'three' + !< test_passed(3) = (astring%join(array=characters, sep='-')//''==characters(2)//'-'//characters(3)) + !< characters(1) = 'one' + !< characters(2) = 'two' + !< characters(3) = '' + !< test_passed(4) = (astring%join(array=characters, sep='-')//''==characters(1)//'-'//characters(2)) + !< characters(1) = 'one' + !< characters(2) = '' + !< characters(3) = 'three' + !< test_passed(5) = (astring%join(array=characters, sep='-')//''==characters(1)//'-'//characters(3)) + !< characters(1) = 'one' + !< characters(2) = 'two' + !< characters(3) = 'three' + !< astring = '_' + !< test_passed(6) = (astring%join(array=characters)//''==characters(1)//'_'//characters(2)//'_'//characters(3)) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: array(1:) !< Array to be joined. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + TYPE(string) :: join !< The join of array. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + INTEGER :: a !< Counter. + + IF (ALLOCATED(self%raw)) THEN + sep_ = self%raw + ELSE + sep_ = '' + END IF + IF (PRESENT(sep)) sep_ = sep + join = '' + DO a = 2, SIZE(array, dim=1) + IF (array(a) /= '') join%raw = join%raw//sep_//array(a) + END DO + IF (array(1) /= '') THEN + join%raw = array(1)//join%raw + ELSE + join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) + END IF +END FUNCTION join_characters + +PURE FUNCTION strjoin_strings(array, sep) RESULT(join) + !< Return a string that is a join of an array of strings. + !< + !< The join-separator is set equals to a null string '' if custom separator isn't specified. + !< + !<```fortran + !< type(string) :: strings(3) + !< logical :: test_passed(5) + !< strings(1) = 'one' + !< strings(2) = 'two' + !< strings(3) = 'three' + !< test_passed(1) = (strjoin(array=strings)//''==strings(1)//strings(2)//strings(3)) + !< test_passed(2) = (strjoin(array=strings, sep='-')//''==strings(1)//'-'//strings(2)//'-'//strings(3)) + !< call strings(1)%free + !< strings(2) = 'two' + !< strings(3) = 'three' + !< test_passed(3) = (strjoin(array=strings, sep='-')//''==strings(2)//'-'//strings(3)) + !< strings(1) = 'one' + !< strings(2) = 'two' + !< call strings(3)%free + !< test_passed(4) = (strjoin(array=strings, sep='-')//''==strings(1)//'-'//strings(2)) + !< strings(1) = 'one' + !< call strings(2)%free + !< strings(3) = 'three' + !< test_passed(5) = (strjoin(array=strings, sep='-')//''==strings(1)//'-'//strings(3)) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: array(1:) !< Array to be joined. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + TYPE(string) :: join !< The join of array. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + INTEGER :: a !< Counter. + + sep_ = '' + IF (PRESENT(sep)) sep_ = sep + join = '' + DO a = 2, SIZE(array, dim=1) + IF (ALLOCATED(array(a)%raw)) join%raw = join%raw//sep_//array(a)%raw + END DO + IF (ALLOCATED(array(1)%raw)) THEN + join%raw = array(1)%raw//join%raw + ELSE + join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) + END IF +END FUNCTION strjoin_strings + +PURE FUNCTION strjoin_characters(array, sep, is_trim) RESULT(join) + !< Return a string that is a join of an array of characters. + !< + !< The join-separator is set equals to a null string '' if custom separator isn't specified. + !< The trim function is applied to array items if optional logical is_trim variable isn't set to .false. + !< + !<```fortran + !< character(5) :: characters(3) + !< logical :: test_passed(13) + !< characters(1) = 'one' + !< characters(2) = 'two' + !< characters(3) = 'three' + !< test_passed(1) = (strjoin(array=characters)//''==trim(characters(1))//trim(characters(2))//trim(characters(3))) + !< test_passed(2) = (strjoin(array=characters, sep='-')//''==trim(characters(1))//'-'//trim(characters(2))//'-'//trim(characters(3))) + !< test_passed(3) = ( strjoin(array=characters, is_trim=.false.)//''==characters(1)//characters(2)//characters(3)) + !< test_passed(4) = ( strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(1)//'-'//characters(2)//'-'//characters(3)) + !< characters(1) = '' + !< characters(2) = 'two' + !< characters(3) = 'three' + !< test_passed(5) = (strjoin(array=characters)//''==trim(characters(2))//trim(characters(3))) + !< characters(1) = 'one' + !< characters(2) = 'two' + !< characters(3) = '' + !< test_passed(6) = (strjoin(array=characters)//''==trim(characters(1))//trim(characters(2))) + !< characters(1) = 'one' + !< characters(2) = '' + !< characters(3) = 'three' + !< test_passed(7) = (strjoin(array=characters)//''==trim(characters(1))//trim(characters(3))) + !< characters(1) = '' + !< characters(2) = 'two' + !< characters(3) = 'three' + !< test_passed(8) = (strjoin(array=characters, sep='-')//''==trim(characters(2))//'-'//trim(characters(3))) + !< characters(1) = 'one' + !< characters(2) = 'two' + !< characters(3) = '' + !< test_passed(9) = (strjoin(array=characters, sep='-')//''==trim(characters(1))//'-'//trim(characters(2))) + !< characters(1) = 'one' + !< characters(2) = '' + !< characters(3) = 'three' + !< test_passed(10) = (strjoin(array=characters, sep='-')//''==trim(characters(1))//'-'//trim(characters(3))) + !< characters(1) = '' + !< characters(2) = 'two' + !< characters(3) = 'three' + !< test_passed(11) = (strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(2)//'-'//characters(3)) + !< characters(1) = 'one' + !< characters(2) = 'two' + !< characters(3) = '' + !< test_passed(12) = (strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(1)//'-'//characters(2)) + !< characters(1) = 'one' + !< characters(2) = '' + !< characters(3) = 'three' + !< test_passed(13) = (strjoin(array=characters, sep='-', is_trim=.false.)//''==characters(1)//'-'//characters(3)) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: array(1:) !< Array to be joined. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + LOGICAL, INTENT(IN), OPTIONAL :: is_trim !< Flag to setup trim character or not + TYPE(string) :: join !< The join of array. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + LOGICAL :: is_trim_ !< Flag to setup trim character or not + INTEGER :: a !< Counter. + + sep_ = '' + IF (PRESENT(sep)) sep_ = sep + is_trim_ = .TRUE.; IF (PRESENT(is_trim)) is_trim_ = is_trim + join = '' + + IF (is_trim_) THEN + DO a = 2, SIZE(array, dim=1) + IF (TRIM(array(a)) /= '') join%raw = join%raw//sep_//TRIM(array(a)) + END DO + IF (TRIM(array(1)) /= '') THEN + join%raw = TRIM(array(1))//join%raw + ELSE + join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) + END IF + ELSE + DO a = 2, SIZE(array, dim=1) + IF (array(a) /= '') join%raw = join%raw//sep_//array(a) + END DO + IF (array(1) /= '') THEN + join%raw = array(1)//join%raw + ELSE + join%raw = join%raw(LEN(sep_) + 1:LEN(join%raw)) + END IF + END IF +END FUNCTION strjoin_characters + +PURE FUNCTION strjoin_strings_array(array, sep, is_col) RESULT(join) + !< Return a string that is a join of columns or rows of an array of strings. + !< + !< The join-separator is set equals to a null string '' if custom separator isn't specified. + !< The is_col is setup the direction of join: within default columns (.true.) or rows(.false.). + !< + !<```fortran + !< type(string), allocatable :: strings_arr(:, :) + !< logical :: test_passed(5) + !< + !< strings_arr = reshape( source = & + !< [string('one'), string('two'), string('three'), & + !< string('ONE'), string('TWO'), string('THREE')], & + !< shape = [3, 2] ) + !< + !< test_passed(1) = all( strjoin(array=strings_arr) == & + !< reshape([string('onetwothree'), string('ONETWOTHREE')], & + !< shape = [2]) ) + !< + !< test_passed(2) = all( strjoin(array=strings_arr, sep='_') == & + !< reshape([string('one_two_three'), string('ONE_TWO_THREE')], & + !< shape = [2]) ) + !< + !< test_passed(3) = all( strjoin(array=strings_arr, is_col=.false.) == & + !< reshape([string('oneONE'), string('twoTWO'), string('threeTHREE')], & + !< shape = [3]) ) + !< + !< test_passed(4) = all( strjoin(array=strings_arr, sep='_', is_col=.false.) == & + !< reshape([string('one_ONE'), string('two_TWO'), string('three_THREE')], & + !< shape = [3]) ) + !< + !< call strings_arr(2, 1)%free + !< test_passed(5) = all( strjoin(array=strings_arr, sep='_', is_col=.false.) == & + !< reshape([string('one_ONE'), string('TWO'), string('three_THREE')], & + !< shape = [3]) ) + !< + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: array(1:, 1:) !< Array to be joined. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + LOGICAL, INTENT(IN), OPTIONAL :: is_col !< Direction: 'columns' if .true. or 'rows' if .false. + TYPE(string), ALLOCATABLE :: join(:) !< The join of array. + TYPE(string), ALLOCATABLE :: slice(:) !< The column or row slice of array + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + LOGICAL :: is_col_ !< Direction, default value. + INTEGER :: a, join_size, slice_size !< Counter, sizes of join vector and of slice of array + + sep_ = ''; IF (PRESENT(sep)) sep_ = sep + is_col_ = .TRUE.; IF (PRESENT(is_col)) is_col_ = is_col + + IF (is_col_) THEN + join_size = SIZE(array, dim=2) + slice_size = SIZE(array, dim=1) + + IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) + IF (.NOT. ALLOCATED(slice)) ALLOCATE (slice(slice_size)) + DO a = 1, join_size + slice(:) = array(:, a) + join(a) = strjoin_strings(slice, sep_) + END DO + ELSE + join_size = SIZE(array, dim=1) + slice_size = SIZE(array, dim=2) + + IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) + IF (.NOT. ALLOCATED(slice)) ALLOCATE (slice(slice_size)) + DO a = 1, join_size + slice(:) = array(a, :) + join(a) = strjoin_strings(slice, sep_) + END DO + END IF +END FUNCTION strjoin_strings_array + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 21 July 2022 +! summary: Return a string that is a join of columns or rows of an array of characters +! +!# Introduction +! +! The join-separator is set equals to a null string '' if custom separator +! isn't specified. +! The trim function is applied to array items if optional logical is_trim +! variable isn't set to .false. +! The is_col is setup the direction of join: within default columns (.true.) +! or rows(.false.). +! +!```fortran +! character(len=10) :: chars_arr(3, 2) +! logical :: test_passed(9) +! chars_arr(:, 1) = ['one ', 'two ', 'three '] +! chars_arr(:, 2) = ['ONE ', 'TWO ', 'THREE '] +! +! test_passed(1) = all( strjoin(array=chars_arr) == & +! reshape([string('onetwothree'), string +! ('ONETWOTHREE')], & +! shape = [2]) ) +! +! test_passed(2) = all( strjoin(array=chars_arr, is_trim=.false.) == & +! reshape([string('one two three '), & +! string('ONE TWO THREE ')], & +! shape = [2]) ) +! +! test_passed(3) = all( strjoin(array=chars_arr, sep='_') == & +! reshape([string('one_two_three'), string +! ('ONE_TWO_THREE')], & +! shape = [2]) ) +! +! test_passed(4) = all( strjoin(array=chars_arr, sep='_', is_trim=.false.) +! == & +! reshape([string('one _two _three +! '), & +! string('ONE _TWO _THREE +! ')], & +! shape = [2]) ) +! +! test_passed(5) = all( strjoin(array=chars_arr, is_col=.false.) == & +! reshape([string('oneONE'), string('twoTWO'), string +! ('threeTHREE')], & +! shape = [3]) ) +! +! test_passed(6) = all( strjoin(array=chars_arr, is_trim=.false., is_col=. +! false.) == & +! reshape([string('one ONE '), & +! string('two TWO '), & +! string('three THREE ')], & +! shape = [3]) ) +! +! test_passed(7) = all( strjoin(array=chars_arr, sep='_', is_col=.false.) == & +! reshape([string('one_ONE'), string('two_TWO'), string +! ('three_THREE')], & +! shape = [3]) ) +! +! test_passed(8) = all( strjoin(array=chars_arr, sep='_', is_trim=.false., +! is_col=.false.) == & +! reshape([string('one _ONE '), & +! string('two _TWO '), & +! string('three _THREE ')], & +! shape = [3]) ) +! +! chars_arr(2,1) = '' +! test_passed(9) = all( strjoin(array=chars_arr, sep='_', is_col=.false.) +! == & +! reshape([string('one_ONE'), & +! string('TWO'), & +! string('three_THREE')], & +! shape = [3]) ) +! +! print '(L1)', all(test_passed) +!``` + +PURE FUNCTION strjoin_characters_array(array, sep, is_trim, is_col) & + & RESULT(join) + !! + CHARACTER(kind=CK, len=*), INTENT(IN) :: array(1:, 1:) + !! Array to be joined. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep + !! Separator. + LOGICAL, INTENT(IN), OPTIONAL :: is_trim + !! Flag to setup trim character or not + LOGICAL, INTENT(IN), OPTIONAL :: is_col + !! Direction: 'columns' if .true. or 'rows' if .false. + TYPE(string), ALLOCATABLE :: join(:) + !! The join of array. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: slice(:) + !! The column or row slice of array + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ + !! Separator, default value. + LOGICAL :: is_trim_ + !! Flag to setup trim character or not + LOGICAL :: is_col_ + !! Direction, default value. + INTEGER :: a, join_size, slice_size + !! Counter, sizes of join vector and of slice of array + INTEGER :: item_len + !! Length of array item (all items of character array have equal lengths) + !! + !! + item_len = LEN(array(1, 1)) + !! + !! all items of character array have equal lengths + !! + sep_ = ''; IF (PRESENT(sep)) sep_ = sep + is_trim_ = .TRUE.; IF (PRESENT(is_trim)) is_trim_ = is_trim + is_col_ = .TRUE.; IF (PRESENT(is_col)) is_col_ = is_col + !! + IF (is_col_) THEN + join_size = SIZE(array, dim=2) + slice_size = SIZE(array, dim=1) + !! + IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) + IF (.NOT. ALLOCATED(slice)) & + & ALLOCATE (CHARACTER(len=item_len) :: slice(slice_size)) + !! + DO a = 1, join_size + slice(:) = array(:, a) + join(a) = strjoin_characters(slice, sep_, is_trim_) + END DO + !! + ELSE + !! + join_size = SIZE(array, dim=1) + slice_size = SIZE(array, dim=2) + !! + IF (.NOT. ALLOCATED(join)) ALLOCATE (join(join_size)) + IF (.NOT. ALLOCATED(slice)) & + & ALLOCATE (CHARACTER(len=item_len) :: slice(slice_size)) + !! + DO a = 1, join_size + slice(:) = array(a, :) + join(a) = strjoin_characters(slice, sep_, is_trim_) + END DO + END IF + !! +END FUNCTION strjoin_characters_array + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION lower(self) + !< Return a string with all lowercase characters. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 'Hello WorLD!' + !< test_passed(1) = astring%lower()//''=='hello world!' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: lower !< Upper case string. + INTEGER :: n1 !< Characters counter. + INTEGER :: n2 !< Characters counter. + + IF (ALLOCATED(self%raw)) THEN + lower = self + DO n1 = 1, LEN(self%raw) + n2 = INDEX(UPPER_ALPHABET, self%raw(n1:n1)) + IF (n2 > 0) lower%raw(n1:n1) = LOWER_ALPHABET(n2:n2) + END DO + END IF +END FUNCTION lower + +PURE FUNCTION partition(self, sep) RESULT(partitions) + !< Split string at separator and return the 3 parts (before, the separator and after). + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: strings(3) + !< logical :: test_passed(3) + !< astring = 'Hello WorLD!' + !< strings = astring%partition(sep='lo Wo') + !< test_passed(1) = (strings(1)//''=='Hel'.and.strings(2)//''=='lo Wo'.and.strings(3)//''=='rLD!') + !< strings = astring%partition(sep='Hello') + !< test_passed(2) = (strings(1)//''==''.and.strings(2)//''=='Hello'.and.strings(3)//''==' WorLD!') + !< astring = 'Hello WorLD!' + !< strings = astring%partition() + !< test_passed(3) = (strings(1)//''=='Hello'.and.strings(2)//''==' '.and.strings(3)//''=='WorLD!') + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + TYPE(string) :: partitions(1:3) !< Partions: before the separator, the separator itsels and + !< after the separator. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + INTEGER :: c !< Character counter. + + IF (ALLOCATED(self%raw)) THEN + sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep + + partitions(1) = self + partitions(2) = sep_ + partitions(3) = '' + IF (LEN(sep_) >= LEN(self%raw)) RETURN + c = INDEX(self%raw, sep_) + IF (c > 0) THEN + partitions(1)%raw = self%raw(1:c - 1) + partitions(2)%raw = self%raw(c:c + LEN(sep_) - 1) + partitions(3)%raw = self%raw(c + LEN(sep_):) + END IF + END IF +END FUNCTION partition + +!--------------------------------------------------------------------------- +! ReadFile +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 2022-12-16 +! summary: Read a file +! +!# Introduction +! +! Read a file as a single string stream. +! +! @note All the lines are stored into the string self as a single +! ascii stream. Each line (record) is separated by a `new_line` +! character. +! +!@note +! For unformatted read only `access='stream'` is supported +! with new_line as line terminator. +! +!@note +! *Fast* file reading allows a very efficient reading of +! streamed file, but it dumps file as single streamed string. +! +!```fortran +! type(string) :: astring +! type(string), allocatable :: strings(:) +! type(string) :: line(3) +! integer :: iostat +! character(len=99) :: iomsg +! integer :: scratch +! integer :: l +! logical :: test_passed(9) +! line(1) = ' Hello World! ' +! line(2) = 'How are you? ' +! line(3) = ' All say: "Fine thanks"' +! open(newunit=scratch, file='read_file_test.tmp') +! write(scratch, "(A)") line(1)%chars() +! write(scratch, "(A)") line(2)%chars() +! write(scratch, "(A)") line(3)%chars() +! close(scratch) +! call astring%read_file(file='read_file_test.tmp', & +! & iostat=iostat, iomsg=iomsg) +! call astring%split(tokens=strings, sep=new_line('a')) +! test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) +! do l=1, size(strings, dim=1) +! test_passed(l+1) = (strings(l)==line(l)) +! enddo +! open(newunit=scratch, file='read_file_test.tmp', & +! & form='UNFORMATTED', access='STREAM') +! write(scratch) line(1)%chars()//new_line('a') +! write(scratch) line(2)%chars()//new_line('a') +! write(scratch) line(3)%chars()//new_line('a') +! close(scratch) +! call astring%read_file(file='read_file_test.tmp', form='unformatted', & +! & iostat=iostat, iomsg=iomsg) +! call astring%split(tokens=strings, sep=new_line('a')) +! test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) +! do l=1, size(strings, dim=1) +! test_passed(l+5) = (strings(l)==line(l)) +! enddo +! open(newunit=scratch, file='read_file_test.tmp', form='UNFORMATTED', & +! & access='STREAM') +! close(scratch, status='DELETE') +! call astring%read_file(file='read_file_test.tmp', iostat=iostat) +! test_passed(9) = (iostat/=0) +! print '(L1)', all(test_passed) +!``` + +SUBROUTINE read_file(self, file, is_fast, form, iostat, iomsg) + CLASS(string), INTENT(inout) :: self + !! The string. + CHARACTER(len=*), INTENT(IN) :: file + !! File name. + LOGICAL, INTENT(IN), OPTIONAL :: is_fast + !! Flag to enable (super) fast file reading. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: form + !! Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat + !! IO status code. + CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg + !! IO status message. + ! + ! internal variables + ! + LOGICAL :: is_fast_ + !! Flag to enable (super) fast file reading, local variable. + TYPE(string) :: form_ + !! Format of unit, local variable. + INTEGER :: iostat_ + !! IO status code, local variable. + CHARACTER(len=:), ALLOCATABLE :: iomsg_ + !! IO status message, local variable. + INTEGER :: unit + !! Logical unit. + LOGICAL :: does_exist + !! Check if file exist. + INTEGER(I4P) :: filesize + !! Size of the file for fast reading. + ! + ! main program + ! + iomsg_ = REPEAT(' ', 99) + IF (PRESENT(iomsg)) iomsg_ = iomsg + INQUIRE (file=file, iomsg=iomsg_, iostat=iostat_, exist=does_exist) + ! + IF (does_exist) THEN + is_fast_ = .FALSE.; + IF (PRESENT(is_fast)) is_fast_ = is_fast + IF (is_fast_) THEN + OPEN (newunit=unit, file=file, & + & access='STREAM', form='UNFORMATTED', iomsg=iomsg_, iostat=iostat_) + INQUIRE (file=file, size=filesize) + IF (ALLOCATED(self%raw)) DEALLOCATE (self%raw) + ALLOCATE (CHARACTER(len=filesize) :: self%raw) + READ (unit=unit, iostat=iostat_, iomsg=iomsg_) self%raw + CLOSE (unit) + ELSE + form_ = 'FORMATTED' + IF (PRESENT(form)) form_ = form + form_ = form_%upper() + SELECT CASE (form_%chars()) + CASE ('FORMATTED') + OPEN (newunit=unit, file=file, status='OLD', & + & action='READ', iomsg=iomsg_, iostat=iostat_, err=10) + CASE ('UNFORMATTED') + OPEN (newunit=unit, file=file, status='OLD', & + & action='READ', form='UNFORMATTED', access='STREAM', & + & iomsg=iomsg_, iostat=iostat_, err=10) + END SELECT + CALL self%read_lines(unit=unit, form=form, iomsg=iomsg_, iostat=iostat_) +10 CLOSE (unit) + END IF + ELSE + iostat_ = 1 + iomsg_ = 'file not found' + END IF + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE read_file + +!---------------------------------------------------------------------------- +! readLine +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 2022-12-16 +! summary: 2022-12-16 +! +!# Introduction +! +! Read line (record) from a connected unit. +! +! The line is read as an ascii stream read until the eor +! is reached. +! +!@note +! For unformatted read only `access='stream'` is +! supported with new_line as line terminator. +!@endnote +! +!```fortran +! type(string) :: astring +! type(string) :: line(3) +! integer :: iostat +! character(len=99) :: iomsg +! integer :: scratch +! integer :: l +! logical :: test_passed(6) +! line(1) = ' Hello World! ' +! line(2) = 'How are you? ' +! line(3) = ' All say: "Fine thanks"' +! open(newunit=scratch, status='SCRATCH') +! write(scratch, "(A)") line(1)%chars() +! write(scratch, "(A)") line(2)%chars() +! write(scratch, "(A)") line(3)%chars() +! rewind(scratch) +! l = 0 +! iostat = 0 +! do +! l = l + 1 +! call astring%read_line(unit=scratch, & +! & iostat=iostat, iomsg=iomsg) +! if (iostat/=0.and..not.is_iostat_eor(iostat)) then +! exit +! else +! test_passed(l) = (astring==line(l)) +! endif +! enddo +! close(scratch) +! open(newunit=scratch, status='SCRATCH', form='UNFORMATTED', access='STREAM') +! write(scratch) line(1)%chars()//new_line('a') +! write(scratch) line(2)%chars()//new_line('a') +! write(scratch) line(3)%chars()//new_line('a') +! rewind(scratch) +! l = 0 +! iostat = 0 +! do +! l = l + 1 +! call astring%read_line(unit=scratch, & +! & iostat=iostat, iomsg=iomsg, form='UnfORMatteD') +! if (iostat/=0.and..not.is_iostat_eor(iostat)) then +! exit +! else +! test_passed(l+3) = (astring==line(l)) +! endif +! enddo +! close(scratch) +! print '(L1)', all(test_passed) +!``` + +SUBROUTINE read_line(self, unit, form, iostat, iomsg) + CLASS(string), INTENT(inout) :: self + !! The string. + INTEGER, INTENT(IN) :: unit + !! Logical unit. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: form + !! Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat + !! IO status code. + CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg + !! IO status message. + TYPE(string) :: form_ + !! Format of unit, local variable. + INTEGER :: iostat_ + !! IO status code, local variable. + CHARACTER(len=:), ALLOCATABLE :: iomsg_ + !! IO status message, local variable. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: line + !! Line storage. + CHARACTER(kind=CK, len=1) :: ch + !! Character storage. + + form_ = 'FORMATTED' + IF (PRESENT(form)) form_ = form + form_ = form_%upper() + iomsg_ = REPEAT(' ', 99) + IF (PRESENT(iomsg)) iomsg_ = iomsg + line = '' + SELECT CASE (form_%chars()) + CASE ('FORMATTED') + DO + !! + READ (unit, "(A)", advance='no', iostat=iostat_, & + & iomsg=iomsg_, err=10, END=10, eor=10) & + & ch + line = line//ch + END DO + CASE ('UNFORMATTED') + DO + READ (unit, iostat=iostat_, iomsg=iomsg_, & + & err=10, END=10) ch + IF (ch == NEW_LINE('a')) THEN + iostat_ = IOSTAT_EOR + EXIT + END IF + line = line//ch + END DO + END SELECT +10 IF (line /= '') self%raw = line + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE read_line + +! Read (all) lines (records) from a connected unit as a single ascii stream. +! +!@note +! All the lines are stored into the string self as a single ascii stream. +! Each line (record) is separated by a `new_line` +! character. The line is read as an ascii stream read until the eor +! is reached. +!@endnote +! +!@note +! The connected unit is rewinded. +! At a successful exit current record is at eof, +! at the beginning otherwise. +!@endnote +! +!@note +! For unformatted read only `access='stream'` is +! supported with new_line as line terminator. +!@endnote +! +!```fortran +! type(string) :: astring +! type(string), allocatable :: strings(:) +! type(string) :: line(3) +! integer :: iostat +! character(len=99) :: iomsg +! integer :: scratch +! integer :: l +! logical :: test_passed(8) +! +! line(1) = ' Hello World! ' +! line(2) = 'How are you? ' +! line(3) = ' All say: "Fine thanks"' +! open(newunit=scratch, status='SCRATCH') +! write(scratch, "(A)") line(1)%chars() +! write(scratch, "(A)") line(2)%chars() +! write(scratch, "(A)") line(3)%chars() +! call astring%read_lines(unit=scratch, iostat=iostat, iomsg=iomsg) +! call astring%split(tokens=strings, sep=new_line('a')) +! test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) +! do l=1, size(strings, dim=1) +! test_passed(l+1) = (strings(l)==line(l)) +! enddo +! close(scratch) +! open(newunit=scratch, status='SCRATCH', form='UNFORMATTED', access='STREAM') +! write(scratch) line(1)%chars()//new_line('a') +! write(scratch) line(2)%chars()//new_line('a') +! write(scratch) line(3)%chars()//new_line('a') +! call astring%read_lines(unit=scratch, & +! form='unformatted', iostat=iostat, iomsg=iomsg) +! call astring%split(tokens=strings, sep=new_line('a')) +! test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) +! do l=1, size(strings, dim=1) +! test_passed(l+5) = (strings(l)==line(l)) +! enddo +! close(scratch) +! print '(L1)', all(test_passed) +!``` + +SUBROUTINE read_lines(self, unit, form, iostat, iomsg) + CLASS(string), INTENT(inout) :: self + !! The string. + INTEGER, INTENT(IN) :: unit + !! Logical unit. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: form + !! Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat + !! IO status code. + CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg + !! IO status message. + INTEGER :: iostat_ + !! IO status code, local variable. + CHARACTER(len=:), ALLOCATABLE :: iomsg_ + !! IO status message, local variable. + TYPE(string) :: lines + !! Lines storage. + TYPE(string) :: line + !! Line storage. + + iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg + REWIND (unit) + iostat_ = 0 + lines%raw = '' + DO + line%raw = '' + CALL line%read_line(unit=unit, form=form, iostat=iostat_, iomsg=iomsg_) + IF (iostat_ /= 0 .AND. .NOT. is_iostat_eor(iostat_)) THEN + EXIT + ELSEIF (line /= '') THEN + lines%raw = lines%raw//line%raw//NEW_LINE('a') + END IF + END DO + IF (lines%raw /= '') self%raw = lines%raw + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE read_lines + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION replace(self, old, NEW, count) RESULT(replaced) + !< Return a string with all occurrences of substring old replaced by new. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(3) + !< astring = 'When YOU are sad YOU should think to me :-)' + !< test_passed(1) = (astring%replace(old='YOU', new='THEY')//''=='When THEY are sad THEY should think to me :-)') + !< test_passed(2) = (astring%replace(old='YOU', new='THEY', count=1)//''=='When THEY are sad YOU should think to me :-)') + !< astring = repeat(new_line('a')//'abcd', 20) + !< astring = astring%replace(old=new_line('a'), new='|cr|') + !< astring = astring%replace(old='|cr|', new=new_line('a')//' ') + !< test_passed(3) = (astring//''==repeat(new_line('a')//' '//'abcd', 20)) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: old !< Old substring. + CHARACTER(kind=CK, len=*), INTENT(IN) :: NEW !< New substring. + INTEGER, INTENT(IN), OPTIONAL :: count !< Number of old occurences to be replaced. + TYPE(string) :: replaced !< The string with old replaced by new. + INTEGER :: r !< Counter. + + IF (ALLOCATED(self%raw)) THEN + replaced = self + r = 0 + DO + IF (INDEX(replaced%raw, old) > 0) THEN + replaced = replaced%replace_one_occurrence(old=old, NEW=NEW) + r = r + 1 + IF (PRESENT(count)) THEN + IF (r >= count) EXIT + END IF + ELSE + EXIT + END IF + END DO + END IF +END FUNCTION replace + +ELEMENTAL FUNCTION reverse(self) RESULT(reversed) + !< Return a reversed string. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(2) + !< astring = 'abcdefghilmnopqrstuvz' + !< test_passed(1) = (astring%reverse()//''=='zvutsrqponmlihgfedcba') + !< astring = '0123456789' + !< test_passed(2) = (astring%reverse()//''=='9876543210') + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: reversed !< The reversed string. + INTEGER :: length !< Length of the string. + INTEGER :: c !< Counter. + + IF (ALLOCATED(self%raw)) THEN + reversed = self + length = LEN(self%raw) + DO c = 1, length + reversed%raw(c:c) = self%raw(length - c + 1:length - c + 1) + END DO + END IF +END FUNCTION reverse + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION search(self, tag_start, tag_end, in_string, in_character, & + & istart, iend) RESULT(tag) + !< Search for *tagged* record into string, return the first record found (if any) matching the tags. + !< + !< Optionally, returns the indexes of tag start/end, thus this is not an `elemental` function. + !< + !< @note The tagged record is searched into self if allocated otherwise into `in_string` if passed or, eventually, into + !< `in_character` is passed. If tag is not found the return string is not allocated and the start/end indexes (if requested) are + !< zero. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< character(len=:), allocatable :: acharacter + !< integer :: istart + !< integer :: iend + !< logical :: test_passed(5) + !< astring = ' hello not the first ' + !< anotherstring = astring%search(tag_start='', tag_end='') + !< test_passed(1) = anotherstring//''==' hello ' + !< astring = ' the nested a ' + !< anotherstring = astring%search(tag_start='', tag_end='') + !< test_passed(2) = anotherstring//''==' the nested a ' + !< call astring%free + !< anotherstring = ' the nested a ' + !< astring = astring%search(in_string=anotherstring, tag_start='', tag_end='') + !< test_passed(3) = astring//''==' the nested a ' + !< call astring%free + !< acharacter = ' the nested a ' + !< astring = astring%search(in_character=acharacter, tag_start='', tag_end='') + !< test_passed(4) = astring//''==' the nested a ' + !< acharacter = ' hello not the first ' + !< astring = astring%search(in_character=acharacter, tag_start='', tag_end='', istart=istart, iend=iend) + !< test_passed(5) = astring//''==acharacter(31:67) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: tag_start !< Start tag. + CHARACTER(kind=CK, len=*), INTENT(IN) :: tag_end !< End tag. + TYPE(string), INTENT(IN), OPTIONAL :: in_string !< Search into this string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: in_character !< Search into this character string. + INTEGER, INTENT(out), OPTIONAL :: istart !< Starting index of tag inside the string. + INTEGER, INTENT(out), OPTIONAL :: iend !< Ending index of tag inside the string. + TYPE(string) :: tag !< First tag found. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw !< Raw string into which search the tag. + INTEGER :: istart_ !< Starting index of tag inside the string, local variable. + INTEGER :: iend_ !< Ending index of tag inside the string, local variable. + INTEGER :: nested_tags !< Number of nested tags inside tag. + INTEGER :: t !< Counter. + + raw = '' + IF (PRESENT(in_string)) THEN + raw = in_string%raw + ELSEIF (PRESENT(in_character)) THEN + raw = in_character + ELSE + IF (ALLOCATED(self%raw)) raw = self%raw + END IF + istart_ = 0 + iend_ = 0 + IF (raw /= '') THEN + istart_ = INDEX(raw, tag_start) + iend_ = INDEX(raw, tag_end) + IF (istart_ > 0 .AND. iend_ > 0) THEN + iend_ = iend_ + LEN(tag_end) - 1 + tag%raw = raw(istart_:iend_) + nested_tags = tag%COUNT(tag_start) + IF (nested_tags > 1) THEN + DO t = 2, nested_tags + iend_ = iend_ + LEN(tag_end) - 1 + INDEX(raw(iend_ + 1:), tag_end) + END DO + tag%raw = raw(istart_:iend_) + END IF + END IF + END IF + IF (PRESENT(istart)) istart = istart_ + IF (PRESENT(iend)) iend = iend_ +END FUNCTION search + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION slice(self, istart, iend) RESULT(raw) + !< Return the raw characters data sliced. + !< + !<```fortran + !< type(string) :: astring + !< astring = 'the Quick Brown fox Jumps over the Lazy Dog.' + !< print "(A)", astring%slice(11,25) + !<``` + !=> Brown fox Jumps <<< + CLASS(string), INTENT(IN) :: self !< The string. + INTEGER, INTENT(IN) :: istart !< Slice start index. + INTEGER, INTENT(IN) :: iend !< Slice end index. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: raw !< Raw characters data. + + IF (ALLOCATED(self%raw)) THEN + raw = self%raw(istart:iend) + ELSE + raw = '' + END IF +END FUNCTION slice + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION snakecase(self, sep) + !< Return a string with all words lowercase separated by "_". + !< + !< @note Multiple subsequent separators are collapsed to one occurence. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 'the Quick Brown fox Jumps over the Lazy Dog.' + !< test_passed(1) = astring%snakecase()//''=='the_quick_brown_fox_jumps_over_the_lazy_dog.' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + TYPE(string) :: snakecase !< Snake case string. + TYPE(string), ALLOCATABLE :: tokens(:) !< String tokens. + + IF (ALLOCATED(self%raw)) THEN + CALL self%split(tokens=tokens, sep=sep) + tokens = tokens%lower() + snakecase = snakecase%join(array=tokens, sep='_') + END IF +END FUNCTION snakecase + +!---------------------------------------------------------------------------- +! Split +!---------------------------------------------------------------------------- + +!> author: Szaghi +! date: 11 May 2022 +! summary: Return a list of substring in the string +! +!# Introduction +! +! Return a list of substring in the string, using sep as the delimiter string +! +!@note +! Multiple subsequent separators are collapsed to one occurrence. +!@endnote +! +!@note +! If `max_tokens` is passed the returned number of tokens is either +! `max_tokens` or `max_tokens + 1`. +!@endnote +! +!```fortran +! type(string) :: astring +! type(string), allocatable :: strings(:) +! logical :: test_passed(11) +! astring = '+ab-++cre-++cre-ab+' +! call astring%split(tokens=strings, sep='+') +! test_passed(1) = (strings(1)//''=='ab-'.and.strings(2)//''=='cre-'.and. +! strings(3)//''=='cre-ab') +! astring = 'ab-++cre-++cre-ab+' +! call astring%split(tokens=strings, sep='+') +! test_passed(2) = (strings(1)//''=='ab-'.and.strings(2)//''=='cre-'.and. +! strings(3)//''=='cre-ab') +! astring = 'ab-++cre-++cre-ab' +! call astring%split(tokens=strings, sep='+') +! test_passed(3) = (strings(1)//''=='ab-'.and.strings(2)//''=='cre-'.and. +! strings(3)//''=='cre-ab') +! astring = 'Hello '//new_line('a')//'World!' +! call astring%split(tokens=strings, sep=new_line('a')) +! test_passed(4) = (strings(1)//''=='Hello '.and.strings(2)//''=='World!') +! astring = 'Hello World!' +! call astring%split(tokens=strings) +! test_passed(5) = (strings(1)//''=='Hello'.and.strings(2)//''=='World!') +! astring = '+ab-' +! call astring%split(tokens=strings, sep='+') +! test_passed(6) = (strings(1)//''=='ab-') +! astring = '+ab-' +! call astring%split(tokens=strings, sep='-') +! test_passed(7) = (strings(1)//''=='+ab') +! astring = '+ab-+cd-' +! call astring%split(tokens=strings, sep='+') +! test_passed(8) = (strings(1)//''=='ab-'.and.strings(2)//''=='cd-') +! astring = 'ab-+cd-+' +! call astring%split(tokens=strings, sep='+') +! test_passed(9) = (strings(1)//''=='ab-'.and.strings(2)//''=='cd-') +! astring = '+ab-+cd-+' +! call astring%split(tokens=strings, sep='+') +! test_passed(10) = (strings(1)//''=='ab-'.and.strings(2)//''=='cd-') +! astring = '1-2-3-4-5-6-7-8' +! call astring%split(tokens=strings, sep='-', max_tokens=3) +! test_passed(11) = (strings(1)//''=='1'.and.strings(2)//''=='2'.and.strings +! (3)//''=='3'.and.strings(4)//''=='4-5-6-7-8') +! print '(L1)', all(test_passed) +!``` + +PURE SUBROUTINE split(self, tokens, sep, max_tokens) + CLASS(string), INTENT(IN) :: self + !! The string. + TYPE(string), ALLOCATABLE, INTENT(out) :: tokens(:) + !! Tokens substring. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep + !! Separator. + INTEGER, INTENT(IN), OPTIONAL :: max_tokens + !! Fix the maximum number of returned tokens. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ + !! Separator, default value. + INTEGER :: No + !! Number of occurrences of sep. + INTEGER :: t + !! Character counter. + TYPE(string) :: temporary + !! Temporary storage. + TYPE(string), ALLOCATABLE :: temp_toks(:, :) + !! Temporary tokens substring. + !! + !! + !! + IF (ALLOCATED(self%raw)) THEN + !! + sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep + !! + temporary = self%unique(sep_) + No = temporary%COUNT(sep_) + !! + IF (No > 0) THEN + IF (PRESENT(max_tokens)) THEN + IF (max_tokens < No .AND. max_tokens > 0) No = max_tokens + END IF + ALLOCATE (temp_toks(3, No)) + temp_toks(:, 1) = temporary%partition(sep_) + IF (No > 1) THEN + DO t = 2, No + temp_toks(:, t) = temp_toks(3, t - 1)%partition(sep_) + END DO + END IF + !! + IF (temp_toks(1, 1)%raw /= '' .AND. temp_toks(3, No)%raw /= '') THEN + ALLOCATE (tokens(No + 1)) + DO t = 1, No + IF (t == No) THEN + tokens(t) = temp_toks(1, t) + tokens(t + 1) = temp_toks(3, t) + ELSE + tokens(t) = temp_toks(1, t) + END IF + END DO + ELSEIF (temp_toks(1, 1)%raw /= '') THEN + ALLOCATE (tokens(No)) + DO t = 1, No + tokens(t) = temp_toks(1, t) + END DO + ELSEIF (temp_toks(3, No)%raw /= '') THEN + ALLOCATE (tokens(No)) + DO t = 1, No - 1 + tokens(t) = temp_toks(1, t + 1) + END DO + tokens(No) = temp_toks(3, No) + ELSE + ALLOCATE (tokens(No - 1)) + DO t = 2, No + tokens(t - 1) = temp_toks(1, t) + END DO + END IF + !! + ELSE + ALLOCATE (tokens(1)) + tokens(1) = self + END IF + END IF +END SUBROUTINE split + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Szaghi +! date: 21 July 2022 +! summary: Return substrings +! +!# Introduction +! +! Return a list of substring in the string, using sep as the delimiter +! string, chunked (memory-efficient) algorithm. +! +!@note +! Multiple subsequent separators are collapsed to one occurrence. +!@endnote +! +!@note +! The split is performed in chunks of `#chunks` to avoid excessive memory +! consumption. +!@endnote +! +!```fortran +! type(string) :: astring +! type(string), allocatable :: strings(:) +! logical :: test_passed(1) +! astring = '-1-2-3-4-5-6-7-8-' +! call astring%split_chunked(tokens=strings, sep='-', chunks=3) +! test_passed(1) = (strings(1)//''=='1'.and.strings(2)//''=='2'.and.strings +! (3)//''=='3'.and.strings(4)//''=='4'.and. & +! strings(5)//''=='5'.and.strings(6)//''=='6'.and.strings +! (7)//''=='7'.and.strings(8)//''=='8') +! print '(L1)', all(test_passed) +!``` + +PURE SUBROUTINE split_chunked(self, tokens, chunks, sep) + !! + CLASS(string), INTENT(IN) :: self + !! The string. + TYPE(string), ALLOCATABLE, INTENT(out) :: tokens(:) + !! Tokens substring. + INTEGER, INTENT(IN) :: chunks + !! Number of chunks. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep + !! Separator. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ + !! Separator, default value. + INTEGER :: Nt + !! Number of actual tokens. + INTEGER :: t + !! Counter. + LOGICAL :: isok + !! + !! + !! + IF (ALLOCATED(self%raw)) THEN + sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep + !! + Nt = self%COUNT(sep_) + IF (self%start_with(prefix=sep_)) Nt = Nt - 1 + IF (self%end_with(suffix=sep_)) Nt = Nt - 1 + t = 0 + CALL self%split(tokens=tokens, sep=sep_, max_tokens=chunks) + DO + t = SIZE(tokens, dim=1) + IF (t > Nt) EXIT + CALL split_last_token(tokens=tokens, max_tokens=chunks, isok=isok) + IF (isok) THEN + ELSE + EXIT + END IF + END DO + !! + t = SIZE(tokens, dim=1) + IF (tokens(t)%COUNT(sep_) > 0) THEN + CALL split_last_token(tokens=tokens, isok=isok) + END IF + END IF + !! +CONTAINS + !! + PURE SUBROUTINE split_last_token(tokens, max_tokens, isok) + !! Split last token. + TYPE(string), ALLOCATABLE, INTENT(inout) :: tokens(:) + !! Tokens substring. + INTEGER, INTENT(IN), OPTIONAL :: max_tokens + !! Max tokens returned. + TYPE(string), ALLOCATABLE :: tokens_(:) + !! Temporary tokens. + TYPE(string), ALLOCATABLE :: tokens_swap(:) + !! Swap tokens. + INTEGER :: Nt_ + !! Number of last created tokens. + LOGICAL, INTENT(out) :: isok + !! + isok = .TRUE. + CALL tokens(t)%split(tokens=tokens_, sep=sep_, max_tokens=max_tokens) + IF (ALLOCATED(tokens_)) THEN + Nt_ = SIZE(tokens_, dim=1) + IF (Nt_ >= 1) THEN + ALLOCATE (tokens_swap(1:t - 1 + Nt_)) + tokens_swap(1:t - 1) = tokens(1:t - 1) + tokens_swap(t:) = tokens_(:) + CALL MOVE_ALLOC(from=tokens_swap, to=tokens) + END IF + IF (Nt_ == 1) THEN + isok = .FALSE. + END IF + DEALLOCATE (tokens_) + END IF + END SUBROUTINE split_last_token + !! +END SUBROUTINE split_chunked + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION startcase(self, sep) + !< Return a string with all words capitalized, e.g. title case. + !< + !< @note Multiple subsequent separators are collapsed to one occurence. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 'the Quick Brown fox Jumps over the Lazy Dog.' + !< test_passed(1) = astring%startcase()//''=='The Quick Brown Fox Jumps Over The Lazy Dog.' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: sep !< Separator. + TYPE(string) :: startcase !< Start case string. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: sep_ !< Separator, default value. + TYPE(string), ALLOCATABLE :: tokens(:) !< String tokens. + + IF (ALLOCATED(self%raw)) THEN + sep_ = SPACE; IF (PRESENT(sep)) sep_ = sep + CALL self%split(tokens=tokens, sep=sep_) + tokens = tokens%capitalize() + startcase = startcase%join(array=tokens, sep=sep_) + END IF +END FUNCTION startcase + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION strip(self, remove_nulls) + !< Return a copy of the string with the leading and trailing characters removed. + !< + !< @note Multiple subsequent separators are collapsed to one occurence. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = ' Hello World! ' + !< test_passed(1) = astring%strip()//''=='Hello World!' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + LOGICAL, INTENT(IN), OPTIONAL :: remove_nulls !< Remove null characters at the end. + TYPE(string) :: strip !< The stripped string. + INTEGER :: c !< Counter. + + IF (ALLOCATED(self%raw)) THEN + strip = self%ADJUSTL() + strip = strip%TRIM() + IF (PRESENT(remove_nulls)) THEN + IF (remove_nulls) THEN + c = INDEX(self%raw, CHAR(0)) + IF (c > 0) strip%raw = strip%raw(1:c - 1) + END IF + END IF + END IF +END FUNCTION strip + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION swapcase(self) + !< Return a copy of the string with uppercase characters converted to lowercase and vice versa. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = ' Hello World! ' + !< test_passed(1) = astring%swapcase()//''==' hELLO wORLD! ' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: swapcase !< Upper case string. + INTEGER :: n1 !< Characters counter. + INTEGER :: n2 !< Characters counter. + + IF (ALLOCATED(self%raw)) THEN + swapcase = self + DO n1 = 1, LEN(self%raw) + n2 = INDEX(UPPER_ALPHABET, self%raw(n1:n1)) + IF (n2 > 0) THEN + swapcase%raw(n1:n1) = LOWER_ALPHABET(n2:n2) + ELSE + n2 = INDEX(LOWER_ALPHABET, self%raw(n1:n1)) + IF (n2 > 0) swapcase%raw(n1:n1) = UPPER_ALPHABET(n2:n2) + END IF + END DO + END IF +END FUNCTION swapcase + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION tempname(self, is_file, prefix, path) + !< Return a safe temporary name suitable for temporary file or directories. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: tmpname + !< logical :: test_passed(5) + !< tmpname = astring%tempname() + !< inquire(file=tmpname, exist=test_passed(1)) + !< test_passed(1) = .not.test_passed(1) + !< tmpname = astring%tempname(is_file=.false.) + !< inquire(file=tmpname, exist=test_passed(2)) + !< test_passed(2) = .not.test_passed(2) + !< tmpname = astring%tempname(path='./') + !< inquire(file=tmpname, exist=test_passed(3)) + !< test_passed(3) = .not.test_passed(3) + !< astring = 'me-' + !< tmpname = astring%tempname() + !< inquire(file=tmpname, exist=test_passed(4)) + !< test_passed(4) = .not.test_passed(4) + !< tmpname = astring%tempname(prefix='you-') + !< inquire(file=tmpname, exist=test_passed(5)) + !< test_passed(5) = .not.test_passed(5) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + LOGICAL, INTENT(IN), OPTIONAL :: is_file !< True if tempname should be used for file (the default). + CHARACTER(*), INTENT(IN), OPTIONAL :: prefix !< Name prefix, otherwise self is used (if allocated). + CHARACTER(*), INTENT(IN), OPTIONAL :: path !< Path where file/directory should be used, default `./`. + CHARACTER(len=:), ALLOCATABLE :: tempname !< Safe (unique) temporary name. + LOGICAL :: is_file_ !< True if tempname should be used for file (the default). + CHARACTER(len=:), ALLOCATABLE :: prefix_ !< Name prefix, otherwise self is used (if allocated). + CHARACTER(len=:), ALLOCATABLE :: path_ !< Path where file/directory should be used, default `./`. + LOGICAL, SAVE :: is_initialized = .FALSE. !< Status of random seed initialization. + REAL(R4P) :: random_real !< Random number (real). + INTEGER(I4P) :: random_integer !< Random number (integer). + LOGICAL :: is_hold !< Flag to check if a safe tempname has been found. + + is_file_ = .TRUE.; IF (PRESENT(is_file)) is_file_ = is_file + path_ = ''; IF (PRESENT(path)) path_ = path + prefix_ = '' + IF (PRESENT(prefix)) THEN + prefix_ = prefix + ELSEIF (ALLOCATED(self%raw)) THEN + prefix_ = self%raw + END IF + IF (.NOT. is_initialized) THEN + CALL random_seed + is_initialized = .TRUE. + END IF + tempname = REPEAT(' ', LEN(path_) + LEN(prefix_) + 10) ! [path_] + [prefix_] + 6 random chars + [.tmp] + DO + CALL RANDOM_NUMBER(random_real) + random_integer = TRANSFER(random_real, random_integer) + random_integer = IAND(random_integer, 16777215_I4P) + IF (is_file_) THEN + WRITE (tempname, '(A,Z6.6,A)') path_//prefix_, random_integer, '.tmp' + ELSE + WRITE (tempname, '(A,Z6.6)') path_//prefix_, random_integer + tempname = TRIM(tempname) + END IF + INQUIRE (file=tempname, exist=is_hold) + IF (.NOT. is_hold) EXIT + END DO +END FUNCTION tempname + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2022 +! summary: Cast string to integer (I1P). +! +!# Introduction +! +!```fortran +! use penf +! type(string) :: astring +! integer(I1P) :: integer_ +! logical :: test_passed(1) +! astring = '127' +! integer_ = astring%to_number(kind=1_I1P) +! test_passed(1) = integer_==127_I1P +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION to_integer_I1P(self, kind) RESULT(to_number) + CLASS(string), INTENT(IN) :: self + !! The string. + INTEGER(I1P), INTENT(IN) :: kind + !! Mold parameter for kind detection. + INTEGER(I1P) :: to_number + !! The number into the string. + IF (ALLOCATED(self%raw)) THEN + IF (self%is_integer()) READ (self%raw, *) to_number + END IF +END FUNCTION to_integer_I1P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#ifndef _NVF +!> author: Vikas Sharma, Ph. D. +! date: 22 July 2023 +! summary: Cast string to integer (I2P). +! +!# Introduction +! +!```fortran +! use penf +! type(string) :: astring +! integer(I2P) :: integer_ +! logical :: test_passed(1) +! astring = '127' +! integer_ = astring%to_number(kind=1_I2P) +! test_passed(1) = integer_==127_I2P +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION to_integer_I2P(self, kind) RESULT(to_number) + CLASS(string), INTENT(IN) :: self + !! The string. + INTEGER(I2P), INTENT(IN) :: kind + !! Mold parameter for kind detection. + INTEGER(I2P) :: to_number + !! The number into the string. + IF (ALLOCATED(self%raw)) THEN + IF (self%is_integer()) READ (self%raw, *) to_number + END IF +END FUNCTION to_integer_I2P +#endif + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2022 +! summary: Cast string to integer (I4P). +! +!# Introduction +! +! +!```fortran +! use penf +! type(string) :: astring +! integer(I4P) :: integer_ +! logical :: test_passed(1) +! astring = '127' +! integer_ = astring%to_number(kind=1_I4P) +! test_passed(1) = integer_==127_I4P +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION to_integer_I4P(self, kind) RESULT(to_number) + CLASS(string), INTENT(IN) :: self + !! The string. + INTEGER(I4P), INTENT(IN) :: kind + !! Mold parameter for kind detection. + INTEGER(I4P) :: to_number + !! The number into the string. + IF (ALLOCATED(self%raw)) THEN + IF (self%is_integer()) READ (self%raw, *) to_number + END IF +END FUNCTION to_integer_I4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2023 +! summary: Cast string to integer (I8P). +! +!# Introduction +! +!```fortran +! use penf +! type(string) :: astring +! integer(I8P) :: integer_ +! logical :: test_passed(1) +! astring = '127' +! integer_ = astring%to_number(kind=1_I8P) +! test_passed(1) = integer_==127_I8P +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION to_integer_I8P(self, kind) RESULT(to_number) + CLASS(string), INTENT(IN) :: self + !! The string. + INTEGER(I8P), INTENT(IN) :: kind + !! Mold parameter for kind detection. + INTEGER(I8P) :: to_number + !! The number into the string. + IF (ALLOCATED(self%raw)) THEN + IF (self%is_integer()) READ (self%raw, *) to_number + END IF +END FUNCTION to_integer_I8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Cast string to real (R4P). +! +!# Introduction +! +!```fortran +! use penf +! type(string) :: astring +! real(R4P) :: real_ +! logical :: test_passed(1) +! astring = '3.4e9' +! real_ = astring%to_number(kind=1._R4P) +! test_passed(1) = real_==3.4e9_R4P +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION to_real_R4P(self, kind) RESULT(to_number) + CLASS(string), INTENT(IN) :: self + !! The string. + REAL(R4P), INTENT(IN) :: kind + !! Mold parameter for kind detection. + REAL(R4P) :: to_number + !! The number into the string. + IF (ALLOCATED(self%raw)) THEN + IF (self%is_real()) READ (self%raw, *) to_number + END IF +END FUNCTION to_real_R4P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Cast string to real (R8P). +! +!# Introduction +! +!```fortran +! use penf +! type(string) :: astring +! real(R8P) :: real_ +! logical :: test_passed(1) +! astring = '3.4e9' +! real_ = astring%to_number(kind=1._R8P) +! test_passed(1) = real_==3.4e9_R8P +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION to_real_R8P(self, kind) RESULT(to_number) + CLASS(string), INTENT(IN) :: self + !! The string. + REAL(R8P), INTENT(IN) :: kind + !! Mold parameter for kind detection. + REAL(R8P) :: to_number + !! The number into the string. + IF (ALLOCATED(self%raw)) THEN + IF (self%is_real()) READ (self%raw, *) to_number + END IF +END FUNCTION to_real_R8P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION to_real_R16P(self, kind) RESULT(to_number) + !< Cast string to real (R16P). + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< real(R16P) :: real_ + !< logical :: test_passed(1) + !< astring = '3.4e9' + !< real_ = astring%to_number(kind=1._R16P) + !< test_passed(1) = real_==3.4e9_R16P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + REAL(R16P), INTENT(IN) :: kind !< Mold parameter for kind detection. + REAL(R16P) :: to_number !< The number into the string. + + IF (ALLOCATED(self%raw)) THEN + IF (self%is_real()) READ (self%raw, *) to_number + END IF +END FUNCTION to_real_R16P + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2022 +! summary: Convert a string to boolean + +ELEMENTAL FUNCTION to_logical(self) RESULT(ans) + CLASS(string), INTENT(IN) :: self + !! The string. + LOGICAL :: ans + !! + TYPE(String) :: tmp + ! True and False options (all lowercase): + CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: true_str = ['1 ', & + 't ', & + 'true ', & + '.true.'] + CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: false_str = ['0 ', & + 'f ', & + 'false ', & + '.false.'] + !! + IF (ALLOCATED(self%raw)) THEN + tmp = self%lower() + IF (ANY(tmp .EQ. true_str)) THEN + ans = .TRUE. + ELSEIF (ANY(tmp .EQ. false_str)) THEN + ans = .FALSE. + ELSE + ans = .FALSE. + END IF + END IF + !! +END FUNCTION to_logical + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION unescape(self, to_unescape, unesc) RESULT(unescaped) + !< Unescape double backslashes (or custom escaped character). + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(2) + !< astring = '^\\s \\d+\\s*' + !< test_passed(1) = (astring%unescape(to_unescape='\')//''=='^\s \d+\s*') + !< test_passed(2) = (astring%unescape(to_unescape='s')//''=='^\s \\d+\s*') + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self + !! The string. + CHARACTER(kind=CK, len=1), INTENT(IN) :: to_unescape + !! Character to be unescaped. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: unesc + !! Character used to unescape. + TYPE(string) :: unescaped + !! Escaped string. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: unesc_ + !! Character to unescape, local variable. + INTEGER :: c + !! Character counter. + + IF (ALLOCATED(self%raw)) THEN + unesc_ = ''; IF (PRESENT(unesc)) unesc_ = unesc + unescaped%raw = '' + c = 1 + DO + IF (c > LEN(self%raw)) EXIT + IF (c == LEN(self%raw)) THEN + unescaped%raw = unescaped%raw//self%raw(c:c) + EXIT + ELSE + IF (self%raw(c:c + 1) == BACKSLASH//to_unescape) THEN + unescaped%raw = unescaped%raw//to_unescape + c = c + 2 + ELSE + unescaped%raw = unescaped%raw//self%raw(c:c) + c = c + 1 + END IF + END IF + END DO + END IF +END FUNCTION unescape + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION unique(self, substring) RESULT(uniq) + !< Reduce to one (unique) multiple (sequential) occurrences of a substring into a string. + !< + !< For example the string ' ab-cre-cre-ab' is reduce to 'ab-cre-ab' if the substring is '-cre'. + !< @note Eventual multiple trailing white space are not reduced to one occurrence. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = '+++ab-++cre-++cre-ab+++++' + !< test_passed(1) = astring%unique(substring='+')//''=='+ab-+cre-+cre-ab+' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self + !! The string. + CHARACTER(kind=CK, len=*), INTENT(IN), OPTIONAL :: substring + !! Substring which multiple occurences must be reduced to one. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: substring_ + !! Substring, default value. + TYPE(string) :: uniq + !! String parsed. +#ifdef _NVF + CHARACTER(9999) :: nvf_bug + !! Work around for NVFortran bug. +#endif + + IF (ALLOCATED(self%raw)) THEN + substring_ = SPACE; IF (PRESENT(substring)) substring_ = substring + + uniq = self + DO +#ifdef _NVF + nvf_bug = substring_ + IF (.NOT. uniq%INDEX(REPEAT(TRIM(nvf_bug), 2)) > 0) EXIT + uniq = uniq%replace(old=REPEAT(TRIM(nvf_bug), 2), NEW=substring_) +#else + IF (.NOT. uniq%INDEX(REPEAT(substring_, 2)) > 0) EXIT + uniq = uniq%replace(old=REPEAT(substring_, 2), NEW=substring_) +#endif + END DO + END IF +END FUNCTION unique + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION upper(self) + !< Return a string with all uppercase characters. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 'Hello WorLD!' + !< test_passed(1) = astring%upper()//''=='HELLO WORLD!' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + TYPE(string) :: upper !< Upper case string. + INTEGER :: n1 !< Characters counter. + INTEGER :: n2 !< Characters counter. + + IF (ALLOCATED(self%raw)) THEN + upper = self + DO n1 = 1, LEN(self%raw) + n2 = INDEX(LOWER_ALPHABET, self%raw(n1:n1)) + IF (n2 > 0) upper%raw(n1:n1) = UPPER_ALPHABET(n2:n2) + END DO + END IF +END FUNCTION upper + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE write_file(self, file, form, iostat, iomsg) + !< Write a single string stream into file. + !< + !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< type(string), allocatable :: strings(:) + !< type(string) :: line(3) + !< integer :: iostat + !< character(len=99) :: iomsg + !< integer :: scratch + !< integer :: l + !< logical :: test_passed(8) + !< line(1) = ' Hello World! ' + !< line(2) = 'How are you? ' + !< line(3) = ' All say: "Fine thanks"' + !< anotherstring = anotherstring%join(array=line, sep=new_line('a')) + !< call anotherstring%write_file(file='write_file_test.tmp', iostat=iostat, iomsg=iomsg) + !< call astring%read_file(file='write_file_test.tmp', iostat=iostat, iomsg=iomsg) + !< call astring%split(tokens=strings, sep=new_line('a')) + !< test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) + !< do l=1, size(strings, dim=1) + !< test_passed(l+1) = (strings(l)==line(l)) + !< enddo + !< call anotherstring%write_file(file='write_file_test.tmp', form='unformatted', iostat=iostat, iomsg=iomsg) + !< call astring%read_file(file='write_file_test.tmp', form='unformatted', iostat=iostat, iomsg=iomsg) + !< call astring%split(tokens=strings, sep=new_line('a')) + !< test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) + !< do l=1, size(strings, dim=1) + !< test_passed(l+5) = (strings(l)==line(l)) + !< enddo + !< open(newunit=scratch, file='write_file_test.tmp') + !< close(unit=scratch, status='delete') + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(len=*), INTENT(IN) :: file !< File name. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: form !< Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. + CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. + TYPE(string) :: form_ !< Format of unit, local variable. + INTEGER :: iostat_ !< IO status code, local variable. + CHARACTER(len=:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. + INTEGER :: unit !< Logical unit. + + iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg + form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() + SELECT CASE (form_%chars()) + CASE ('FORMATTED') + OPEN (newunit=unit, file=file, action='WRITE', iomsg=iomsg_, iostat=iostat_, err=10) + CASE ('UNFORMATTED') + OPEN (newunit=unit, file=file, action='WRITE', form='UNFORMATTED', access='STREAM', iomsg=iomsg_, iostat=iostat_, err=10) + END SELECT + CALL self%write_lines(unit=unit, form=form, iomsg=iomsg_, iostat=iostat_) +10 CLOSE (unit) + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE write_file + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE write_line(self, unit, form, iostat, iomsg) + !< Write line (record) to a connected unit. + !< + !< @note If the connected unit is unformatted a `new_line()` character is added at the end (if necessary) to mark the end of line. + !< + !< @note There is no doctests, this being tested by means of [[string:write_file]] doctests. + CLASS(string), INTENT(IN) :: self !< The string. + INTEGER, INTENT(IN) :: unit !< Logical unit. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: form !< Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. + CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. + TYPE(string) :: form_ !< Format of unit, local variable. + INTEGER :: iostat_ !< IO status code, local variable. + CHARACTER(len=:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. + + iostat_ = 0 + iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg + IF (ALLOCATED(self%raw)) THEN + form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() + SELECT CASE (form_%chars()) + CASE ('FORMATTED') + WRITE (unit, "(A)", iostat=iostat_, iomsg=iomsg_) self%raw + CASE ('UNFORMATTED') + IF (self%end_with(NEW_LINE('a'))) THEN + WRITE (unit, iostat=iostat_, iomsg=iomsg_) self%raw + ELSE + WRITE (unit, iostat=iostat_, iomsg=iomsg_) self%raw//NEW_LINE('a') + END IF + END SELECT + END IF + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE write_line + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Write lines (records) to a connected unit. +! +!# Introduction +! +! +! This method checks if self contains more than one line (records) and writes +! them as lines (records). +! +! @note If the connected unit is unformatted a `new_line()` character is +! added at the end (if necessary) to mark the end of line. +! +! @note There is no doctests, this being tested by means of +! [[string:write_file]] doctests. + +SUBROUTINE write_lines(self, unit, form, iostat, iomsg) + CLASS(string), INTENT(IN) :: self + !! The string. + INTEGER, INTENT(IN) :: unit + !! Logical unit. + CHARACTER(len=*), INTENT(IN), OPTIONAL :: form + !! Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat + !! IO status code. + CHARACTER(len=*), INTENT(inout), OPTIONAL :: iomsg + !! IO status message. + TYPE(string), ALLOCATABLE :: lines(:) + !! Lines. + INTEGER :: l + !! Counter. + !! + IF (ALLOCATED(self%raw)) THEN + CALL self%split(tokens=lines, sep=NEW_LINE('a')) + DO l = 1, SIZE(lines, dim=1) + CALL lines(l)%write_line(unit=unit, form=form, iostat=iostat, iomsg=iomsg) + END DO + END IF +END SUBROUTINE write_lines + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Return true if a string ends with a specified suffix. +! +!# Introduction +! +!```fortran +! type(string) :: astring +! logical :: test_passed(5) +! astring = 'Hello WorLD!' +! test_passed(1) = astring%end_with(suffix='LD!').eqv..true. +! test_passed(2) = astring%end_with(suffix='lD!').eqv..false. +! test_passed(3) = astring%end_with(suffix='orLD!', start=5).eqv..true. +! test_passed(4) = astring%end_with(suffix='orLD!', start=8, end=12).eqv.. +! true. +! test_passed(5) = astring%end_with(suffix='!').eqv..true. +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION end_with(self, suffix, start, END, ignore_null_eof) + CLASS(string), INTENT(IN) :: self + !! The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: suffix + !! Searched suffix. + INTEGER, INTENT(IN), OPTIONAL :: start + !! Start position into the string. + INTEGER, INTENT(IN), OPTIONAL :: END + !! End position into the string. + LOGICAL, INTENT(IN), OPTIONAL :: ignore_null_eof + !! Ignore null character at the end of file. + LOGICAL :: end_with + !! Result of the test. + INTEGER :: start_ + !! Start position into the string, local variable. + INTEGER :: end_ + !! End position into the string, local variable. + LOGICAL :: ignore_null_eof_ + !! Ignore null character at the end of file, local variable. + !! + end_with = .FALSE. + IF (ALLOCATED(self%raw)) THEN + start_ = 1; IF (PRESENT(start)) start_ = start + end_ = LEN(self%raw); IF (PRESENT(END)) end_ = END + ignore_null_eof_ = .FALSE.; + IF (PRESENT(ignore_null_eof)) ignore_null_eof_ = ignore_null_eof + IF (ignore_null_eof_ .AND. (self%raw(end_:end_) == CHAR(0))) end_ = end_ - 1 + IF (LEN(suffix) <= LEN(self%raw(start_:end_))) THEN + end_with = self%raw(end_ - LEN(suffix) + 1:end_) == suffix + END IF + END IF +END FUNCTION end_with + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Return true if the string is allocated. +! +!# Introduction +! +!```fortran +! type(string) :: astring +! logical :: test_passed(2) +! test_passed(1) = astring%is_allocated().eqv..false. +! astring = 'hello' +! test_passed(2) = astring%is_allocated().eqv..true. +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION is_allocated(self) + CLASS(string), INTENT(IN) :: self + !! The string. + LOGICAL :: is_allocated + !! Result of the test. + is_allocated = ALLOCATED(self%raw) +END FUNCTION is_allocated + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Return true if all characters in the string are digits. +! +!# Introduction +! +!```fortran +! type(string) :: astring +! logical :: test_passed(2) +! astring = ' -1212112.3 ' +! test_passed(1) = astring%is_digit().eqv..false. +! astring = '12121123' +! test_passed(2) = astring%is_digit().eqv..true. +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION is_digit(self) + CLASS(string), INTENT(IN) :: self + !! The string. + LOGICAL :: is_digit + !! Result of the test. + INTEGER :: c + !! Character counter. + is_digit = .FALSE. + IF (ALLOCATED(self%raw)) THEN + DO c = 1, LEN(self%raw) + SELECT CASE (self%raw(c:c)) + CASE ('0':'9') + is_digit = .TRUE. + CASE default + is_digit = .FALSE. + EXIT + END SELECT + END DO + END IF +END FUNCTION is_digit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Return true if the string contains an integer. +! +!# Introduction +! +! +! The regular expression is `\s*[\+\-]?\d+([eE]\+?\d+)?\s*`. The parse +! algorithm is done in stages: +! +! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | +! |-----|---------|-----|------|-----|-----|-----| +! |`\s*`|`[\+\-]?`|`\d+`|`[eE]`|`\+?`|`\d+`|`\s*`| +! +! Exit on stages-parsing results in: +! +! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | +! |----|----|----|----|----|----|----| +! | F | F | T | F | F | T | T | +! +! @note This implementation is courtesy of +! [tomedunn](https://github.com/tomedunn/fortran-string-utility-module/blob/ +! master/src/string_utility_module.f90#L294) +! +!```fortran +! type(string) :: astring +! logical :: test_passed(6) +! astring = ' -1212112 ' +! test_passed(1) = astring%is_integer().eqv..true. +! astring = ' -1212112' +! test_passed(2) = astring%is_integer(allow_spaces=.false.).eqv..false. +! astring = '-1212112 ' +! test_passed(3) = astring%is_integer(allow_spaces=.false.).eqv..false. +! astring = '+2e20' +! test_passed(4) = astring%is_integer().eqv..true. +! astring = ' -2E13 ' +! test_passed(5) = astring%is_integer().eqv..true. +! astring = ' -2 E13 ' +! test_passed(6) = astring%is_integer().eqv..false. +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION is_integer(self, allow_spaces) + CLASS(string), INTENT(IN) :: self + !! The string. + LOGICAL, INTENT(IN), OPTIONAL :: allow_spaces + !! Allow leading-trailing spaces. + LOGICAL :: is_integer + !! Result of the test. + LOGICAL :: allow_spaces_ + !! Allow leading-trailing spaces, local variable. + INTEGER :: stage + !! Stages counter. + INTEGER :: c + !! Character counter. + !! + IF (ALLOCATED(self%raw)) THEN + allow_spaces_ = .TRUE. + IF (PRESENT(allow_spaces)) allow_spaces_ = allow_spaces + stage = 0 + is_integer = .TRUE. + DO c = 1, LEN(self%raw) + SELECT CASE (self%raw(c:c)) + CASE (SPACE, TAB) + SELECT CASE (stage) + CASE (0, 6) + is_integer = allow_spaces_ + CASE (2, 5) + is_integer = allow_spaces_ + stage = 6 + CASE default + is_integer = .FALSE. + END SELECT + CASE ('-') + SELECT CASE (stage) + CASE (0) + stage = 1 + CASE default + is_integer = .FALSE. + END SELECT + CASE ('+') + SELECT CASE (stage) + CASE (0) + stage = 1 + CASE (3) + stage = 4 + CASE default + is_integer = .FALSE. + END SELECT + CASE ('0':'9') + SELECT CASE (stage) + CASE (0:1) + stage = 2 + CASE (3:4) + stage = 5 + CASE default + CONTINUE + END SELECT + CASE ('e', 'E') + SELECT CASE (stage) + CASE (2) + stage = 3 + CASE default + is_integer = .FALSE. + END SELECT + CASE default + is_integer = .FALSE. + END SELECT + IF (.NOT. is_integer) EXIT + END DO + END IF + IF (is_integer) THEN + SELECT CASE (stage) + CASE (2, 5, 6) + is_integer = .TRUE. + CASE default + is_integer = .FALSE. + END SELECT + END IF +END FUNCTION is_integer + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Return true if the string contains a number (real or integer). +! +!# Introduction +! +!```fortran +! type(string) :: astring +! logical :: test_passed(7) +! astring = ' -1212112 ' +! test_passed(1) = astring%is_number().eqv..true. +! astring = ' -121.2112 ' +! test_passed(2) = astring%is_number().eqv..true. +! astring = ' -1212112' +! test_passed(3) = astring%is_number(allow_spaces=.false.).eqv..false. +! astring = '-12121.12 ' +! test_passed(4) = astring%is_number(allow_spaces=.false.).eqv..false. +! astring = '+2e20' +! test_passed(5) = astring%is_number().eqv..true. +! astring = ' -2.4E13 ' +! test_passed(6) = astring%is_number().eqv..true. +! astring = ' -2 E13 ' +! test_passed(7) = astring%is_number().eqv..false. +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION is_number(self, allow_spaces) + CLASS(string), INTENT(IN) :: self + !! The string. + LOGICAL, INTENT(IN), OPTIONAL :: allow_spaces + !! Allow leading-trailing spaces. + LOGICAL :: is_number !< Result of the test. + !! + is_number = (self%is_integer(allow_spaces=allow_spaces) & + & .OR. self%is_real(allow_spaces=allow_spaces)) + !! +END FUNCTION is_number + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Return true if the string contains a real. +! +!# Introduction +! +! The regular expression is `\s*[\+\-]?\d*(|\.?\d*([deDE][\+\-]?\d+)?)\s*`. The parse algorithm is done in stages: +! +! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | +! |-----|---------|-----|-----|-----|--------|---------|-----|-----| +! |`\s*`|`[\+\-]?`|`\d*`|`\.?`|`\d*`|`[deDE]`|`[\+\-]?`|`\d*`|`\s*`| +! +! Exit on stages-parsing results in: +! +! | S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | +! |----|----|----|----|----|----|----|----|----| +! | F | F | T | T | T | F | F | T | T | +! +! @note This implementation is courtesy of +! [tomedunn](https://github.com/tomedunn/fortran-string-utility-module/blob/ +! master/src/string_utility_module.f90#L614) +! +!```fortran +! type(string) :: astring +! logical :: test_passed(6) +! astring = ' -1212112.d0 ' +! test_passed(1) = astring%is_real().eqv..true. +! astring = ' -1212112.d0' +! test_passed(2) = astring%is_real(allow_spaces=.false.).eqv..false. +! astring = '-1212112.d0 ' +! test_passed(3) = astring%is_real(allow_spaces=.false.).eqv..false. +! astring = '+2.e20' +! test_passed(4) = astring%is_real().eqv..true. +! astring = ' -2.01E13 ' +! test_passed(5) = astring%is_real().eqv..true. +! astring = ' -2.01 E13 ' +! test_passed(6) = astring%is_real().eqv..false. +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION is_real(self, allow_spaces) + CLASS(string), INTENT(IN) :: self + !! The string. + LOGICAL, INTENT(IN), OPTIONAL :: allow_spaces + !! Allow leading-trailing spaces. + LOGICAL :: is_real + !! Result of the test. + LOGICAL :: allow_spaces_ + !! Allow leading-trailing spaces, local variable. + LOGICAL :: has_leading_digit + !! Check the presence of leading digits. + INTEGER :: stage + !! Stages counter. + INTEGER :: c + !! Character counter. + IF (ALLOCATED(self%raw)) THEN + allow_spaces_ = .TRUE. + IF (PRESENT(allow_spaces)) allow_spaces_ = allow_spaces + stage = 0 + is_real = .TRUE. + has_leading_digit = .FALSE. + DO c = 1, LEN(self%raw) + SELECT CASE (self%raw(c:c)) + CASE (SPACE, TAB) + SELECT CASE (stage) + CASE (0, 8) + is_real = allow_spaces_ + CONTINUE + CASE (2:4, 7) + is_real = allow_spaces_ + stage = 8 + CASE default + is_real = .FALSE. + END SELECT + CASE ('+', '-') + SELECT CASE (stage) + CASE (0) + stage = 1 + CASE (5) + stage = 6 + CASE default + is_real = .FALSE. + END SELECT + CASE ('0':'9') + SELECT CASE (stage) + CASE (0:1) + stage = 2 + has_leading_digit = .TRUE. + CASE (3) + stage = 4 + CASE (5:6) + stage = 7 + CASE default + CONTINUE + END SELECT + CASE ('.') + SELECT CASE (stage) + CASE (0:2) + stage = 3 + CASE default + is_real = .FALSE. + END SELECT + CASE ('e', 'E', 'd', 'D') + SELECT CASE (stage) + CASE (2:4) + stage = 5 + CASE default + is_real = .FALSE. + END SELECT + CASE default + is_real = .FALSE. + END SELECT + IF (.NOT. is_real) EXIT + END DO + END IF + IF (is_real) THEN + SELECT CASE (stage) + CASE (2, 4, 7, 8) + is_real = .TRUE. + CASE (3) + is_real = has_leading_digit + CASE default + is_real = .FALSE. + END SELECT + END IF +END FUNCTION is_real + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2022 +! summary: Returns true if string contains boolean character +! +!# Introduction +! + +ELEMENTAL FUNCTION is_logical(self) + CLASS(string), INTENT(IN) :: self + !! The string. + LOGICAL :: is_logical + !! + TYPE(String) :: tmp + ! True and False options (all lowercase): + CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: true_str = ['1 ', & + 't ', & + 'true ', & + '.true.'] + CHARACTER(LEN=*), DIMENSION(4), PARAMETER :: false_str = ['0 ', & + 'f ', & + 'false ', & + '.false.'] + IF (ALLOCATED(self%raw)) THEN + tmp = self%lower() + IF (ANY(tmp .EQ. true_str)) THEN + is_logical = .TRUE. + ELSEIF (ANY(tmp .EQ. false_str)) THEN + is_logical = .FALSE. + ELSE + is_logical = .FALSE. + END IF + END IF + !! +END FUNCTION is_logical + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 23 July 2022 +! summary: Return true if all characters in the string are lowercase. +! +!# Introduction +! +! +!```fortran +! type(string) :: astring +! logical :: test_passed(3) +! astring = ' Hello World' +! test_passed(1) = astring%is_lower().eqv..false. +! astring = ' HELLO WORLD' +! test_passed(2) = astring%is_lower().eqv..false. +! astring = ' hello world' +! test_passed(3) = astring%is_lower().eqv..true. +! print '(L1)', all(test_passed) +!``` + +ELEMENTAL FUNCTION is_lower(self) + CLASS(string), INTENT(IN) :: self !< The string. + LOGICAL :: is_lower !< Result of the test. + INTEGER :: c !< Character counter. + + is_lower = .FALSE. + IF (ALLOCATED(self%raw)) THEN + is_lower = .TRUE. + DO c = 1, LEN(self%raw) + IF (INDEX(UPPER_ALPHABET, self%raw(c:c)) > 0) THEN + is_lower = .FALSE. + EXIT + END IF + END DO + END IF +END FUNCTION is_lower + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ELEMENTAL FUNCTION is_upper(self) + !< Return true if all characters in the string are uppercase. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(3) + !< astring = ' Hello World' + !< test_passed(1) = astring%is_upper().eqv..false. + !< astring = ' HELLO WORLD' + !< test_passed(2) = astring%is_upper().eqv..true. + !< astring = ' hello world' + !< test_passed(3) = astring%is_upper().eqv..false. + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + LOGICAL :: is_upper !< Result of the test. + INTEGER :: c !< Character counter. + + is_upper = .FALSE. + IF (ALLOCATED(self%raw)) THEN + is_upper = .TRUE. + DO c = 1, LEN(self%raw) + IF (INDEX(LOWER_ALPHABET, self%raw(c:c)) > 0) THEN + is_upper = .FALSE. + EXIT + END IF + END DO + END IF +END FUNCTION is_upper + +ELEMENTAL FUNCTION start_with(self, prefix, start, END) + !< Return true if a string starts with a specified prefix. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(4) + !< astring = 'Hello WorLD!' + !< test_passed(1) = astring%start_with(prefix='Hello').eqv..true. + !< test_passed(2) = astring%start_with(prefix='hell').eqv..false. + !< test_passed(3) = astring%start_with(prefix='llo Wor', start=3).eqv..true. + !< test_passed(4) = astring%start_with(prefix='lo W', start=4, end=7).eqv..true. + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: self !< The string. + CHARACTER(kind=CK, len=*), INTENT(IN) :: prefix !< Searched prefix. + INTEGER, INTENT(IN), OPTIONAL :: start !< Start position into the string. + INTEGER, INTENT(IN), OPTIONAL :: END !< End position into the string. + LOGICAL :: start_with !< Result of the test. + INTEGER :: start_ !< Start position into the string, local variable. + INTEGER :: end_ !< End position into the string, local variable. + + start_with = .FALSE. + IF (ALLOCATED(self%raw)) THEN + start_ = 1; IF (PRESENT(start)) start_ = start + end_ = LEN(self%raw); IF (PRESENT(END)) end_ = END + IF (LEN(prefix) <= LEN(self%raw(start_:end_))) THEN + start_with = INDEX(self%raw(start_:end_), prefix) == 1 + END IF + END IF +END FUNCTION start_with + +! private methods + +! assignments +PURE SUBROUTINE string_assign_string(lhs, rhs) + !< Assignment operator from string input. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(1) + !< astring = 'hello' + !< anotherstring = astring + !< test_passed(1) = astring%chars()==anotherstring%chars() + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + + IF (ALLOCATED(rhs%raw)) lhs%raw = rhs%raw +END SUBROUTINE string_assign_string + +PURE SUBROUTINE string_assign_character(lhs, rhs) + !< Assignment operator from character input. + !< + !<```fortran + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 'hello' + !< test_passed(1) = astring%chars()=='hello' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = rhs +END SUBROUTINE string_assign_character + +PURE SUBROUTINE string_assign_integer_I1P(lhs, rhs) + !< Assignment operator from integer input. + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 127_I1P + !< test_passed(1) = astring%to_number(kind=1_I1P)==127_I1P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + INTEGER(I1P), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = TRIM(str(rhs)) +END SUBROUTINE string_assign_integer_I1P + +PURE SUBROUTINE string_assign_integer_I2P(lhs, rhs) + !< Assignment operator from integer input. + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 127_I2P + !< test_passed(1) = astring%to_number(kind=1_I2P)==127_I2P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + INTEGER(I2P), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = TRIM(str(rhs)) +END SUBROUTINE string_assign_integer_I2P + +PURE SUBROUTINE string_assign_integer_I4P(lhs, rhs) + !< Assignment operator from integer input. + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 127_I4P + !< test_passed(1) = astring%to_number(kind=1_I4P)==127_I4P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + INTEGER(I4P), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = TRIM(str(rhs)) +END SUBROUTINE string_assign_integer_I4P + +PURE SUBROUTINE string_assign_integer_I8P(lhs, rhs) + !< Assignment operator from integer input. + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 127_I8P + !< test_passed(1) = astring%to_number(kind=1_I8P)==127_I8P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + INTEGER(I8P), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = TRIM(str(rhs)) +END SUBROUTINE string_assign_integer_I8P + +PURE SUBROUTINE string_assign_real_R4P(lhs, rhs) + !< Assignment operator from real input. + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 3.021e6_R4P + !< test_passed(1) = astring%to_number(kind=1._R4P)==3.021e6_R4P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + REAL(R4P), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = TRIM(str(rhs)) +END SUBROUTINE string_assign_real_R4P + +PURE SUBROUTINE string_assign_real_R8P(lhs, rhs) + !< Assignment operator from real input. + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 3.021e6_R8P + !< test_passed(1) = astring%to_number(kind=1._R8P)==3.021e6_R8P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + REAL(R8P), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = TRIM(str(rhs)) +END SUBROUTINE string_assign_real_R8P + +PURE SUBROUTINE string_assign_real_R16P(lhs, rhs) + !< Assignment operator from real input. + !< + !<```fortran + !< use penf + !< type(string) :: astring + !< logical :: test_passed(1) + !< astring = 3.021e6_R8P + !< test_passed(1) = astring%to_number(kind=1._R8P)==3.021e6_R8P + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(inout) :: lhs !< Left hand side. + REAL(R16P), INTENT(IN) :: rhs !< Right hand side. + + lhs%raw = TRIM(str(rhs)) +END SUBROUTINE string_assign_real_R16P + +! contatenation operators +PURE FUNCTION string_concat_string(lhs, rhs) RESULT(concat) + !< Concatenation with string. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(1) + !< astring = 'Hello ' + !< anotherstring = 'Bye bye' + !< test_passed(1) = astring//anotherstring=='Hello Bye bye' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: concat !< Concatenated string. + + concat = '' + IF (ALLOCATED(lhs%raw)) concat = lhs%raw + IF (ALLOCATED(rhs%raw)) concat = concat//rhs%raw +END FUNCTION string_concat_string + +PURE FUNCTION string_concat_character(lhs, rhs) RESULT(concat) + !< Concatenation with character. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(1) + !< astring = 'Hello ' + !< acharacter = 'World!' + !< test_passed(1) = astring//acharacter=='Hello World!' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: concat !< Concatenated string. + + IF (ALLOCATED(lhs%raw)) THEN + concat = lhs%raw//rhs + ELSE + concat = rhs + END IF +END FUNCTION string_concat_character + +PURE FUNCTION character_concat_string(lhs, rhs) RESULT(concat) + !< Concatenation with character (inverted). + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(1) + !< astring = 'Hello ' + !< acharacter = 'World!' + !< test_passed(1) = acharacter//astring=='World!Hello ' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: concat !< Concatenated string. + + IF (ALLOCATED(rhs%raw)) THEN + concat = lhs//rhs%raw + ELSE + concat = lhs + END IF +END FUNCTION character_concat_string + +ELEMENTAL FUNCTION string_concat_string_string(lhs, rhs) RESULT(concat) + !< Concatenation with string. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< type(string) :: yetanotherstring + !< logical :: test_passed(1) + !< astring = 'Hello ' + !< anotherstring = 'Bye bye' + !< yetanotherstring = astring.cat.anotherstring + !< test_passed(1) = yetanotherstring%chars()=='Hello Bye bye' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + TYPE(string) :: concat !< Concatenated string. + CHARACTER(kind=CK, len=:), ALLOCATABLE :: temporary !< Temporary concatenated string. + + temporary = '' + IF (ALLOCATED(lhs%raw)) temporary = lhs%raw + IF (ALLOCATED(rhs%raw)) temporary = temporary//rhs%raw + IF (temporary /= '') concat%raw = temporary +END FUNCTION string_concat_string_string + +ELEMENTAL FUNCTION string_concat_character_string(lhs, rhs) RESULT(concat) + !< Concatenation with character. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: yetanotherstring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(1) + !< astring = 'Hello ' + !< acharacter = 'World!' + !< yetanotherstring = astring.cat.acharacter + !< test_passed(1) = yetanotherstring%chars()=='Hello World!' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + TYPE(string) :: concat !< Concatenated string. + + IF (ALLOCATED(lhs%raw)) THEN + concat%raw = lhs%raw//rhs + ELSE + concat%raw = rhs + END IF +END FUNCTION string_concat_character_string + +ELEMENTAL FUNCTION character_concat_string_string(lhs, rhs) RESULT(concat) + !< Concatenation with character (inverted). + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: yetanotherstring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(1) + !< astring = 'Hello ' + !< acharacter = 'World!' + !< yetanotherstring = acharacter.cat.astring + !< test_passed(1) = yetanotherstring%chars()=='World!Hello ' + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + TYPE(string) :: concat !< Concatenated string. + + IF (ALLOCATED(rhs%raw)) THEN + concat%raw = lhs//rhs%raw + ELSE + concat%raw = lhs + END IF +END FUNCTION character_concat_string_string + +! logical operators +ELEMENTAL FUNCTION string_eq_string(lhs, rhs) RESULT(is_it) + !< Equal to string logical operator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(2) + !< astring = ' one ' + !< anotherstring = 'two' + !< test_passed(1) = ((astring==anotherstring).eqv..false.) + !< astring = 'the same ' + !< anotherstring = 'the same ' + !< test_passed(2) = ((astring==anotherstring).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw == rhs%raw +END FUNCTION string_eq_string + +ELEMENTAL FUNCTION string_eq_character(lhs, rhs) RESULT(is_it) + !< Equal to character logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = ' one ' + !< acharacter = 'three' + !< test_passed(1) = ((astring==acharacter).eqv..false.) + !< astring = 'the same ' + !< acharacter = 'the same ' + !< test_passed(2) = ((astring==acharacter).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw == rhs +END FUNCTION string_eq_character + +ELEMENTAL FUNCTION character_eq_string(lhs, rhs) RESULT(is_it) + !< Equal to character (inverted) logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = ' one ' + !< acharacter = 'three' + !< test_passed(1) = ((acharacter==astring).eqv..false.) + !< astring = 'the same ' + !< acharacter = 'the same ' + !< test_passed(2) = ((acharacter==astring).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = rhs%raw == lhs +END FUNCTION character_eq_string + +ELEMENTAL FUNCTION string_ne_string(lhs, rhs) RESULT(is_it) + !< Not equal to string logical operator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(2) + !< astring = ' one ' + !< anotherstring = 'two' + !< test_passed(1) = ((astring/=anotherstring).eqv..true.) + !< astring = 'the same ' + !< anotherstring = 'the same ' + !< test_passed(2) = ((astring/=anotherstring).eqv..false.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw /= rhs%raw +END FUNCTION string_ne_string + +ELEMENTAL FUNCTION string_ne_character(lhs, rhs) RESULT(is_it) + !< Not equal to character logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = ' one ' + !< acharacter = 'three' + !< test_passed(1) = ((astring/=acharacter).eqv..true.) + !< astring = 'the same ' + !< acharacter = 'the same ' + !< test_passed(2) = ((astring/=acharacter).eqv..false.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw /= rhs +END FUNCTION string_ne_character + +ELEMENTAL FUNCTION character_ne_string(lhs, rhs) RESULT(is_it) + !< Not equal to character (inverted) logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = ' one ' + !< acharacter = 'three' + !< test_passed(1) = ((acharacter/=astring).eqv..true.) + !< astring = 'the same ' + !< acharacter = 'the same ' + !< test_passed(2) = ((acharacter/=astring).eqv..false.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = rhs%raw /= lhs +END FUNCTION character_ne_string + +ELEMENTAL FUNCTION string_lt_string(lhs, rhs) RESULT(is_it) + !< Lower than to string logical operator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(2) + !< astring = 'one' + !< anotherstring = 'ONE' + !< test_passed(1) = ((astring T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw < rhs%raw +END FUNCTION string_lt_string + +ELEMENTAL FUNCTION string_lt_character(lhs, rhs) RESULT(is_it) + !< Lower than to character logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((astring T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw < rhs +END FUNCTION string_lt_character + +ELEMENTAL FUNCTION character_lt_string(lhs, rhs) RESULT(is_it) + !< Lower than to character (inverted) logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((acharacter T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs < rhs%raw +END FUNCTION character_lt_string + +ELEMENTAL FUNCTION string_le_string(lhs, rhs) RESULT(is_it) + !< Lower equal than to string logical operator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(3) + !< astring = 'one' + !< anotherstring = 'ONE' + !< test_passed(1) = ((astring<=anotherstring).eqv..false.) + !< astring = 'ONE' + !< anotherstring = 'one' + !< test_passed(2) = ((astring<=anotherstring).eqv..true.) + !< astring = 'ONE' + !< anotherstring = 'ONE' + !< test_passed(3) = ((astring<=anotherstring).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw <= rhs%raw +END FUNCTION string_le_string + +ELEMENTAL FUNCTION string_le_character(lhs, rhs) RESULT(is_it) + !< Lower equal than to character logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(3) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((astring<=acharacter).eqv..false.) + !< astring = 'ONE' + !< acharacter = 'one' + !< test_passed(2) = ((astring<=acharacter).eqv..true.) + !< astring = 'ONE' + !< acharacter = 'ONE' + !< test_passed(3) = ((astring<=acharacter).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw <= rhs +END FUNCTION string_le_character + +ELEMENTAL FUNCTION character_le_string(lhs, rhs) RESULT(is_it) + !< Lower equal than to character (inverted) logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(3) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((acharacter<=astring).eqv..true.) + !< astring = 'ONE' + !< acharacter = 'one' + !< test_passed(2) = ((acharacter<=astring).eqv..false.) + !< astring = 'ONE' + !< acharacter = 'ONE' + !< test_passed(3) = ((acharacter<=astring).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs <= rhs%raw +END FUNCTION character_le_string + +ELEMENTAL FUNCTION string_ge_string(lhs, rhs) RESULT(is_it) + !< Greater equal than to string logical operator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(3) + !< astring = 'one' + !< anotherstring = 'ONE' + !< test_passed(1) = ((astring>=anotherstring).eqv..true.) + !< astring = 'ONE' + !< anotherstring = 'one' + !< test_passed(2) = ((astring>=anotherstring).eqv..false.) + !< astring = 'ONE' + !< anotherstring = 'ONE' + !< test_passed(3) = ((astring>=anotherstring).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw >= rhs%raw +END FUNCTION string_ge_string + +ELEMENTAL FUNCTION string_ge_character(lhs, rhs) RESULT(is_it) + !< Greater equal than to character logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(3) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((astring>=acharacter).eqv..true.) + !< astring = 'ONE' + !< acharacter = 'one' + !< test_passed(2) = ((astring>=acharacter).eqv..false.) + !< astring = 'ONE' + !< acharacter = 'ONE' + !< test_passed(3) = ((astring>=acharacter).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw >= rhs +END FUNCTION string_ge_character + +ELEMENTAL FUNCTION character_ge_string(lhs, rhs) RESULT(is_it) + !< Greater equal than to character (inverted) logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(3) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((acharacter>=astring).eqv..false.) + !< astring = 'ONE' + !< acharacter = 'one' + !< test_passed(2) = ((acharacter>=astring).eqv..true.) + !< astring = 'ONE' + !< acharacter = 'ONE' + !< test_passed(3) = ((acharacter>=astring).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs >= rhs%raw +END FUNCTION character_ge_string + +ELEMENTAL FUNCTION string_gt_string(lhs, rhs) RESULT(is_it) + !< Greater than to string logical operator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< logical :: test_passed(2) + !< astring = 'one' + !< anotherstring = 'ONE' + !< test_passed(1) = ((astring>anotherstring).eqv..true.) + !< astring = 'ONE' + !< anotherstring = 'one' + !< test_passed(2) = ((astring>anotherstring).eqv..false.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + TYPE(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw > rhs%raw +END FUNCTION string_gt_string + +ELEMENTAL FUNCTION string_gt_character(lhs, rhs) RESULT(is_it) + !< Greater than to character logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((astring>acharacter).eqv..true.) + !< astring = 'ONE' + !< acharacter = 'one' + !< test_passed(2) = ((astring>acharacter).eqv..false.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CLASS(string), INTENT(IN) :: lhs !< Left hand side. + CHARACTER(kind=CK, len=*), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs%raw > rhs +END FUNCTION string_gt_character + +ELEMENTAL FUNCTION character_gt_string(lhs, rhs) RESULT(is_it) + !< Greater than to character (inverted) logical operator. + !< + !<```fortran + !< type(string) :: astring + !< character(len=:), allocatable :: acharacter + !< logical :: test_passed(2) + !< astring = 'one' + !< acharacter = 'ONE' + !< test_passed(1) = ((acharacter>astring).eqv..false.) + !< astring = 'ONE' + !< acharacter = 'one' + !< test_passed(2) = ((acharacter>astring).eqv..true.) + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(kind=CK, len=*), INTENT(IN) :: lhs !< Left hand side. + CLASS(string), INTENT(IN) :: rhs !< Right hand side. + LOGICAL :: is_it !< Opreator test result. + + is_it = lhs > rhs%raw +END FUNCTION character_gt_string + +! IO +SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + !< Formatted input. + !< + !< @bug Change temporary acks: find a more precise length of the input string and avoid the trimming! + !< + !< @bug Read listdirected with and without delimiters does not work. + CLASS(string), INTENT(inout) :: dtv !< The string. + INTEGER, INTENT(IN) :: unit !< Logical unit. + CHARACTER(len=*), INTENT(IN) :: iotype !< Edit descriptor. + INTEGER, INTENT(IN) :: v_list(:) !< Edit descriptor list. + INTEGER, INTENT(out) :: iostat !< IO status code. + CHARACTER(len=*), INTENT(inout) :: iomsg !< IO status message. + CHARACTER(len=LEN(iomsg)) :: local_iomsg !< Local variant of iomsg, so it doesn't get inappropriately redefined. + CHARACTER(kind=CK, len=1) :: delim !< String delimiter, if any. + CHARACTER(kind=CK, len=100) :: temporary !< Temporary storage string. + + IF (iotype == 'LISTDIRECTED') THEN + CALL get_next_non_blank_character_any_record(unit=unit, ch=delim, iostat=iostat, iomsg=iomsg) + IF (iostat /= 0) RETURN + IF (delim == '"' .OR. delim == "'") THEN + CALL dtv%read_delimited(unit=unit, delim=delim, iostat=iostat, iomsg=local_iomsg) + ELSE + ! step back before the non-blank + READ (unit, "(TL1)", iostat=iostat, iomsg=iomsg) + IF (iostat /= 0) RETURN + CALL dtv%read_undelimited_listdirected(unit=unit, iostat=iostat, iomsg=local_iomsg) + END IF + IF (is_iostat_eor(iostat)) THEN + ! suppress IOSTAT_EOR + iostat = 0 + ELSEIF (iostat /= 0) THEN + iomsg = local_iomsg + END IF + RETURN + ELSE + READ (unit, "(A)", iostat=iostat, iomsg=iomsg) temporary + dtv%raw = TRIM(temporary) + END IF +END SUBROUTINE read_formatted + +SUBROUTINE read_delimited(dtv, unit, delim, iostat, iomsg) + !< Read a delimited string from a unit connected for formatted input. + !< + !< If the closing delimiter is followed by end of record, then we return end of record. + !< + !< @note This does not need a doctest, it being tested by [[string::read_formatted]]. + CLASS(string), INTENT(out) :: dtv !< The string. + INTEGER, INTENT(IN) :: unit !< Logical unit. + CHARACTER(kind=CK, len=1), INTENT(IN) :: delim !< String delimiter. + INTEGER, INTENT(out) :: iostat !< IO status code. + CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg !< IO status message. + CHARACTER(kind=CK, len=1) :: ch !< A character read. + LOGICAL :: was_delim !< Indicates that the last character read was a delimiter. + + was_delim = .FALSE. + dtv%raw = '' + DO + READ (unit, "(A)", iostat=iostat, iomsg=iomsg) ch + IF (is_iostat_eor(iostat)) THEN + IF (was_delim) THEN + ! end of delimited string followed by end of record is end of the string. Pass back the + ! end of record condition to the caller + RETURN + ELSE + ! end of record without terminating delimiter - move along + CYCLE + END IF + ELSEIF (iostat /= 0) THEN + RETURN + END IF + IF (ch == delim) THEN + IF (was_delim) THEN + ! doubled delimiter is one delimiter in the value + dtv%raw = dtv%raw//ch + was_delim = .FALSE. + ELSE + ! need to test next character to see what is happening + was_delim = .TRUE. + END IF + ELSEIF (was_delim) THEN + ! the previous character was actually the delimiter for the end of the string. Put back this character + READ (unit, "(TL1)", iostat=iostat, iomsg=iomsg) + RETURN + ELSE + dtv%raw = dtv%raw//ch + END IF + END DO +END SUBROUTINE read_delimited + +SUBROUTINE read_undelimited_listdirected(dtv, unit, iostat, iomsg) + !< Read an undelimited (no leading apostrophe or double quote) character value according to the rules for list directed input. + !< + !< A blank, comma/semicolon (depending on the decimal mode), slash or end of record terminates the string. + !< + !< If input is terminated by end of record, then this procedure returns an end-of-record condition. + CLASS(string), INTENT(inout) :: dtv !< The string. + INTEGER, INTENT(IN) :: unit !< Logical unit. + INTEGER, INTENT(out) :: iostat !< IO status code. + CHARACTER(len=*), INTENT(inout) :: iomsg !< IO status message. + LOGICAL :: decimal_point ! 0) THEN + IF (pos == 1) THEN + replaced%raw = NEW//self%raw(LEN(old) + 1:) + ELSE + replaced%raw = self%raw(1:pos - 1)//NEW//self%raw(pos + LEN(old):) + END IF + END IF + END IF +END FUNCTION replace_one_occurrence + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 21 July 2021 +! summary: Get the DELIM changeable connection mode for the given unit. +! +!# Introduction +! +! If the unit is connected to an internal file, then the default value of +! NONE is always returned. + +! non type-bound-procedures +SUBROUTINE get_delimiter_mode(unit, delim, iostat, iomsg) + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_INQUIRE_INTERNAL_UNIT + INTEGER, INTENT(IN) :: unit + !! The unit for the connection. + CHARACTER(len=1, kind=CK), INTENT(out) :: delim + !! Represents the value of the DELIM mode. + INTEGER, INTENT(out) :: iostat + !! IOSTAT error code, non-zero on error. + CHARACTER(*), INTENT(inout) :: iomsg + !! IOMSG explanatory message - only defined if iostat is non-zero. + CHARACTER(10) :: delim_buffer + !! Buffer for INQUIRE about DELIM, sized for APOSTROHPE. + CHARACTER(LEN(iomsg)) :: local_iomsg + !! Local variant of iomsg, so it doesn't get inappropriately redefined. + !! + !! get the string representation of the changeable mode + !! + INQUIRE (unit, delim=delim_buffer, iostat=iostat, iomsg=local_iomsg) + !! + IF (iostat == IOSTAT_INQUIRE_INTERNAL_UNIT) THEN + ! no way of determining the DELIM mode for an internal file + iostat = 0 + delim = '' + RETURN + ELSEIF (iostat /= 0) THEN + iomsg = local_iomsg + RETURN + END IF + ! interpret the DELIM string + IF (delim_buffer == 'QUOTE') THEN + delim = '"' + ELSEIF (delim_buffer == 'APOSTROPHE') THEN + delim = '''' + ELSE + delim = '"' + END IF +END SUBROUTINE get_delimiter_mode + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 21 July 2022 +! summary: Get the next non-blank character in the current record. + +SUBROUTINE get_next_non_blank_character_this_record(unit, ch, iostat, iomsg) + INTEGER, INTENT(IN) :: unit + !! Logical unit. + CHARACTER(kind=CK, len=1), INTENT(out) :: ch + !! The non-blank character read. Not valid if IOSTAT is non-zero. + INTEGER, INTENT(out) :: iostat + !! IO status code. + CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg + !! IO status message. + !! + DO + ! we spcify non-advancing, just in case we want this callable outside the + ! context of a child input statement + ! the PAD specifier simply saves the need for the READ statement to + ! define ch if EOR is hit + ! read(unit, "(A)", iostat=iostat, iomsg=iomsg, advance='NO') ch + ! ...but that causes ifort to blow up at runtime + READ (unit, "(A)", iostat=iostat, iomsg=iomsg, pad='NO') ch + IF (iostat .NE. 0) RETURN + IF (ch .NE. '') EXIT + END DO +END SUBROUTINE get_next_non_blank_character_this_record + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 21 July 2022 +! summary: Get the next non-blank character, advancing records if necessary. + +SUBROUTINE get_next_non_blank_character_any_record(unit, ch, iostat, iomsg) + INTEGER, INTENT(IN) :: unit + !! Logical unit. + CHARACTER(kind=CK, len=1), INTENT(out) :: ch + !! The non-blank character read. Not valid if IOSTAT is non-zero. + INTEGER, INTENT(out) :: iostat + !! IO status code. + CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg + !! IO status message. + CHARACTER(LEN(iomsg)) :: local_iomsg + !! Local variant of iomsg, so it doesn't get inappropriately redefined. + !! + DO + CALL get_next_non_blank_character_this_record(unit=unit, ch=ch, & + & iostat=iostat, iomsg=local_iomsg) + IF (IS_IOSTAT_EOR(iostat)) THEN + ! try again on the next record + READ (unit, "(/)", iostat=iostat, iomsg=iomsg) + IF (iostat .NE. 0) RETURN + ELSEIF (iostat .NE. 0) THEN + ! some sort of problem + iomsg = local_iomsg + RETURN + ELSE + ! got it + EXIT + END IF + END DO +END SUBROUTINE get_next_non_blank_character_any_record + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Stefano Zaghi, https://github.com/szaghi +! date: 21 July 2022 +! summary: Get the DECIMAL changeable connection mode for the given unit. +! +!# Introduction +! +! If the unit is connected to an internal file, +! then the default value of DECIMAL is always returned. +! This may not be the actual value in force at the time of the call +! to this procedure. + +SUBROUTINE get_decimal_mode(unit, decimal_point, iostat, iomsg) + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_INQUIRE_INTERNAL_UNIT + INTEGER, INTENT(IN) :: unit + !! Logical unit. + LOGICAL, INTENT(out) :: decimal_point + !! True if the decimal mode is POINT, false otherwise. + INTEGER, INTENT(out) :: iostat + !! IO status code. + CHARACTER(kind=CK, len=*), INTENT(inout) :: iomsg + !! IO status message. + CHARACTER(5) :: decimal_buffer + !! Buffer for INQUIRE about DECIMAL, sized for POINT or COMMA. + CHARACTER(LEN(iomsg)) :: local_iomsg + !! Local iomsg, so it doesn't get inappropriately redefined. + !! + !! + INQUIRE (unit, decimal=decimal_buffer, iostat=iostat, iomsg=local_iomsg) + !! + IF (iostat .EQ. IOSTAT_INQUIRE_INTERNAL_UNIT) THEN + ! no way of determining the decimal mode for an internal file + iostat = 0 + decimal_point = .TRUE. + RETURN + ELSE IF (iostat .NE. 0) THEN + iomsg = local_iomsg + RETURN + END IF + decimal_point = decimal_buffer == 'POINT' +END SUBROUTINE get_decimal_mode + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 July 2022 +! summary: Display the contents of a given string +! +!# Introduction +! +!```fortran +! type(string) :: astring +! astring = ' Hello World!' +! call display( astring, "hello-world" ) +!``` + +SUBROUTINE display_str(self, msg, unitno, advance) + CLASS(String), INTENT(IN) :: self + CHARACTER(LEN=*), INTENT(IN) :: msg + INTEGER(I4P), OPTIONAL, INTENT(IN) :: unitno + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: advance + !! + TYPE(String) :: adv0 + INTEGER(i4p) :: i + !! + IF (PRESENT(advance)) THEN + adv0 = TRIM(advance) + ELSE + adv0 = "YES" + END IF + !! + IF (PRESENT(unitno)) THEN + i = unitno + ELSE + i = stdout + END IF + !! + WRITE (i, "(A)", ADVANCE=adv0%chars()) TRIM(msg)//self%chars() +END SUBROUTINE display_str + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION constructor1(c) RESULT(self) + !< Constructor of string from intrinsic fortran data type + !< + !<```fortran + !< type(string) :: astring + !< astring = String('hello') + !< astring = String( 1 ) + !< astring = String( 1.0 ) + !<``` + !=> T <<< + TYPE(string) :: self + CLASS(*), INTENT(IN) :: c + SELECT TYPE (c) + TYPE is (CHARACTER(*)) + self = c + TYPE is (REAL(r4p)) + self = c + TYPE is (REAL(r8p)) + self = c +#if defined _R16P + TYPE is (REAL(r16p)) + self = c +#endif + TYPE is (INTEGER(i1p)) + self = str(c, .TRUE.) + TYPE is (INTEGER(i2p)) + self = str(c, .TRUE.) + TYPE is (INTEGER(i4p)) + self = str(c, .TRUE.) + TYPE is (INTEGER(i8p)) + self = str(c, .TRUE.) + TYPE is (string) + self = c + END SELECT +END FUNCTION constructor1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION constructor2(c) RESULT(self) + CLASS(*), INTENT(IN) :: c(:) + TYPE(string) :: self(SIZE(c)) + ! internal + INTEGER(I4P) :: ii, tsize + + tsize = SIZE(c) + + DO ii = 1, tsize + self(ii) = String(c(ii)) + END DO +END FUNCTION constructor2 + +!---------------------------------------------------------------------------- +! NmatchStr +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 May 2021 +! summary: Returns the total number of times the substring pattern is found +! +!### Introduction +! Returns the total number of times the substring @c pattern is found in +! string. +! +!@note +! Does not handle trailing spaces that can be eliminated by TRIM() so +! strings should be trimmed when passing into function. +!@endnote + +PURE FUNCTION nmatchstr_1(obj, pattern) RESULT(ans) + CLASS(String), INTENT(IN) :: obj + !! the string to search + CHARACTER(LEN=*), INTENT(IN) :: pattern + !! the pattern to be searched + INTEGER(I4P) :: ans + !! number of mathces + INTEGER(I4P) :: ii, n + + ans = 0; n = obj%LEN() + DO ii = 1, n + IF ((ii + LEN(pattern) - 1) .GT. n) EXIT + IF (obj%raw(ii:ii + LEN(pattern) - 1) .EQ. pattern) ans = ans + 1 + END DO +END FUNCTION nmatchstr_1 + +!---------------------------------------------------------------------------- +! NmatchStr +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 May 2021 +! summary: Returns the total number of times the substring pattern is found +! +!### Introduction +! Returns the total number of times the substring @c pattern is found in +! string. +! +!@note +! Does not handle trailing spaces that can be eliminated by TRIM() so +! strings should be trimmed when passing into function. +!@endnote + +PURE FUNCTION nmatchstr_2(obj, pattern) RESULT(ans) + CLASS(String), INTENT(IN) :: obj + !! the string to search + TYPE(String), INTENT(IN) :: pattern + !! the pattern to be searched + INTEGER(I4P) :: ans + !! number of mathces + INTEGER(I4P) :: ii, n, m + + ans = 0; n = obj%LEN(); m = pattern%LEN() + DO ii = 1, n + IF ((ii + m - 1) .GT. n) EXIT + IF (obj%raw(ii:ii + m - 1) .EQ. pattern%raw(1:m)) ans = ans + 1 + END DO +END FUNCTION nmatchstr_2 + +!---------------------------------------------------------------------------- +! findStr +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 May 2021 +! summary: Returns the indices in a string where substring pattern are found +! +!### Introduction +! Function returns the indices in a string where substring pattern is found. + +PURE SUBROUTINE strfind_1(obj, pattern, indices) + CLASS(String), INTENT(IN) :: obj + CHARACTER(LEN=*), INTENT(IN) :: pattern + INTEGER(I4P), ALLOCATABLE, INTENT(OUT) :: indices(:) + ! Internal variables + INTEGER(I4P) :: i, n, m, count + + n = obj%LEN(); m = LEN(pattern); count = 0 + IF (ALLOCATED(indices)) DEALLOCATE (indices) + ALLOCATE (indices(obj%nmatchstr(pattern))) + DO i = 1, n + IF ((i + m - 1) .GT. n) EXIT + IF (obj%raw(i:i + m - 1) .EQ. pattern(1:m)) THEN + count = count + 1 + indices(count) = i + END IF + END DO +END SUBROUTINE strfind_1 + +!---------------------------------------------------------------------------- +! strfind +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 9 May 2021 +! summary: Returns the indices in a string where substring pattern are found +! +!### Introduction +! Function returns the indices in a string where substring pattern is found. + +PURE SUBROUTINE strfind_2(obj, pattern, indices) + CLASS(String), INTENT(IN) :: obj + CLASS(String), INTENT(IN) :: pattern + INTEGER(I4P), ALLOCATABLE, INTENT(OUT) :: indices(:) + ! Internal variables + CALL strfind_1(obj, TRIM(pattern%chars()), indices) +END SUBROUTINE strfind_2 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2022 +! summary: Reallocate string + +PURE SUBROUTINE String_Reallocate1(obj, row) + TYPE(String), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4P), INTENT(IN) :: row + INTEGER(I4P) :: ii + + IF (ALLOCATED(obj)) THEN + IF (SIZE(obj) .NE. row) THEN + DEALLOCATE (obj) + ALLOCATE (obj(row)) + END IF + ELSE + ALLOCATE (obj(row)) + END IF + + DO ii = 1, row + obj(ii) = "" + END DO +END SUBROUTINE String_Reallocate1 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2022 +! summary: Reallocate string + +PURE SUBROUTINE String_Reallocate2(obj, row, col) + TYPE(String), ALLOCATABLE, INTENT(INOUT) :: obj(:, :) + INTEGER(I4P), INTENT(IN) :: row + INTEGER(I4P), INTENT(IN) :: col + !! + INTEGER(I4P) :: ii, jj + + IF (ALLOCATED(obj)) THEN + IF (ANY(SHAPE(obj) .NE. [row, col])) THEN + DEALLOCATE (obj) + ALLOCATE (obj(row, col)) + END IF + ELSE + ALLOCATE (obj(row, col)) + END IF + + DO jj = 1, col + DO ii = 1, row + obj(ii, jj) = "" + END DO + END DO +END SUBROUTINE String_Reallocate2 + +END MODULE String_Class + +!! Changed stringifor_string_t to StringiFor_Class diff --git a/src/modules/String/src/String_Method.F90 b/src/modules/String/src/String_Method.F90 new file mode 100644 index 000000000..0fd29514e --- /dev/null +++ b/src/modules/String/src/String_Method.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 +! + +!> author: Vikas Sharma, Ph. D. +! date: 21 Oct 2021 +! summary: Additional String Methods + +MODULE String_Method +USE String_Class, ONLY: repeat, string +IMPLICIT NONE +PRIVATE +! expose StingiFor new procedures +PUBLIC :: read_file, read_lines, write_file, write_lines + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE read_file(file, lines, form, iostat, iomsg) + !< Read a file as a single string stream. + !< + !< The lines are returned as an array of strings that are read until the eof is reached. + !< The line is read as an ascii stream read until the eor is reached. + !< + !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. + !< + !<```fortran + !< type(string) :: astring + !< type(string), allocatable :: strings(:) + !< type(string) :: line(3) + !< integer :: iostat + !< character(99) :: iomsg + !< integer :: scratch + !< integer :: l + !< logical :: test_passed(8) + !< line(1) = ' Hello World! ' + !< line(2) = 'How are you? ' + !< line(3) = ' All say: "Fine thanks"' + !< open(newunit=scratch, file='read_file_test.tmp') + !< write(scratch, "(A)") line(1)%chars() + !< write(scratch, "(A)") line(2)%chars() + !< write(scratch, "(A)") line(3)%chars() + !< close(scratch) + !< call read_file(file='read_file_test.tmp', lines=strings, iostat=iostat, iomsg=iomsg) + !< test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) + !< do l=1, size(strings, dim=1) + !< test_passed(l+1) = (strings(l)==line(l)) + !< enddo + !< open(newunit=scratch, file='read_file_test.tmp', form='UNFORMATTED', access='STREAM') + !< write(scratch) line(1)%chars()//new_line('a') + !< write(scratch) line(2)%chars()//new_line('a') + !< write(scratch) line(3)%chars()//new_line('a') + !< close(scratch) + !< call read_file(file='read_file_test.tmp', lines=strings, form='unformatted', iostat=iostat, iomsg=iomsg) + !< test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) + !< do l=1, size(strings, dim=1) + !< test_passed(l+5) = (strings(l)==line(l)) + !< enddo + !< open(newunit=scratch, file='read_file_test.tmp', form='UNFORMATTED', access='STREAM') + !< close(scratch, status='DELETE') + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: file !< File name. + TYPE(string), INTENT(out), ALLOCATABLE :: lines(:) !< The lines. + CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. + CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. + TYPE(string) :: form_ !< Format of unit, local variable. + INTEGER :: iostat_ !< IO status code, local variable. + CHARACTER(:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. + INTEGER :: unit !< Logical unit. + LOGICAL :: does_exist !< Check if file exist. + + iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg + INQUIRE (file=file, iomsg=iomsg_, iostat=iostat_, exist=does_exist) + IF (does_exist) THEN + form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() + SELECT CASE (form_%chars()) + CASE ('FORMATTED') + open (newunit=unit, file=file, status='OLD', action='READ', iomsg=iomsg_, iostat=iostat_, err=10) + CASE ('UNFORMATTED') + open (newunit=unit, file=file, status='OLD', action='READ', form='UNFORMATTED', access='STREAM', & + iomsg=iomsg_, iostat=iostat_, err=10) + END SELECT + CALL read_lines(unit=unit, lines=lines, form=form, iomsg=iomsg_, & + & iostat=iostat_) +10 CLOSE (unit) + END IF + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE read_file + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE read_lines(unit, lines, form, iostat, iomsg) + !< Read lines (records) from a connected-formatted unit. + !< + !< @note The connected unit is rewinded. At a successful exit current record is at eof, at the beginning otherwise. + !< + !< The lines are returned as an array of strings that are read until the eof is reached. + !< The line is read as an ascii stream read until the eor is reached. + !< + !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. + !< + !< @note There is no doctests, this being tested by means of [[read_file]] doctests. + INTEGER, INTENT(in) :: unit !< Logical unit. + TYPE(string), INTENT(out), ALLOCATABLE :: lines(:) !< The lines. + CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. + CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. + TYPE(string) :: form_ !< Format of unit, local variable. + INTEGER :: iostat_ !< IO status code, local variable. + CHARACTER(:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. + CHARACTER(1) :: ch !< Character storage. + INTEGER :: l !< Counter. + + form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() + iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg + REWIND (unit) + SELECT CASE (form_%chars()) + CASE ('FORMATTED') + l = 0 + DO + READ (unit, *, err=10, END=10) + l = l + 1 + END DO + CASE ('UNFORMATTED') + l = 0 + DO + READ (unit, err=10, END=10) ch + IF (ch == NEW_LINE('a')) l = l + 1 + END DO + END SELECT +10 REWIND (unit) + IF (l > 0) THEN + ALLOCATE (lines(1:l)) + l = 1 + iostat_ = 0 + DO + CALL lines(l)%read_line(unit=unit, form=form, iostat=iostat_, iomsg=iomsg_) + if ((iostat_ /= 0 .and. .not. is_iostat_eor(iostat_)) .or. (l >= size(lines, dim=1))) then + EXIT + END IF + l = l + 1 + END DO + END IF + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE read_lines + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE write_file(file, lines, form, iostat, iomsg) + !< Write a single string stream into file. + !< + !< @note For unformatted read only `access='stream'` is supported with new_line as line terminator. + !< + !<```fortran + !< type(string) :: astring + !< type(string) :: anotherstring + !< type(string), allocatable :: strings(:) + !< type(string) :: line(3) + !< integer :: iostat + !< character(99) :: iomsg + !< integer :: scratch + !< integer :: l + !< logical :: test_passed(8) + !< line(1) = ' Hello World! ' + !< line(2) = 'How are you? ' + !< line(3) = ' All say: "Fine thanks"' + !< anotherstring = anotherstring%join(array=line, sep=new_line('a')) + !< call write_file(file='write_file_test.tmp', lines=line, iostat=iostat, iomsg=iomsg) + !< call astring%read_file(file='write_file_test.tmp', iostat=iostat, iomsg=iomsg) + !< call astring%split(tokens=strings, sep=new_line('a')) + !< test_passed(1) = (size(strings, dim=1)==size(line, dim=1)) + !< do l=1, size(strings, dim=1) + !< test_passed(l+1) = (strings(l)==line(l)) + !< enddo + !< call write_file(file='write_file_test.tmp', lines=line, form='unformatted', iostat=iostat, iomsg=iomsg) + !< call astring%read_file(file='write_file_test.tmp', form='unformatted', iostat=iostat, iomsg=iomsg) + !< call astring%split(tokens=strings, sep=new_line('a')) + !< test_passed(5) = (size(strings, dim=1)==size(line, dim=1)) + !< do l=1, size(strings, dim=1) + !< test_passed(l+5) = (strings(l)==line(l)) + !< enddo + !< open(newunit=scratch, file='write_file_test.tmp') + !< close(scratch, status='DELETE') + !< print '(L1)', all(test_passed) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: file !< File name. + TYPE(string), INTENT(in) :: lines(1:) !< The lines. + CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. + CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. + TYPE(string) :: form_ !< Format of unit, local variable. + INTEGER :: iostat_ !< IO status code, local variable. + CHARACTER(:), ALLOCATABLE :: iomsg_ !< IO status message, local variable. + INTEGER :: unit !< Logical unit. + + iomsg_ = REPEAT(' ', 99); IF (PRESENT(iomsg)) iomsg_ = iomsg + form_ = 'FORMATTED'; IF (PRESENT(form)) form_ = form; form_ = form_%upper() + SELECT CASE (form_%chars()) + CASE ('FORMATTED') + open (newunit=unit, file=file, action='WRITE', iomsg=iomsg_, iostat=iostat_, err=10) + CASE ('UNFORMATTED') + open (newunit=unit, file=file, action='WRITE', form='UNFORMATTED', access='STREAM', iomsg=iomsg_, iostat=iostat_, err=10) + END SELECT + call write_lines(unit=unit, lines=lines, form=form, iomsg=iomsg_, iostat=iostat_) +10 CLOSE (unit) + IF (PRESENT(iostat)) iostat = iostat_ + IF (PRESENT(iomsg)) iomsg = iomsg_ +END SUBROUTINE write_file + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE write_lines(unit, lines, form, iostat, iomsg) + !< Write lines (records) to a connected-formatted unit. + !< + !< @note There is no doctests, this being tested by means of [[write_file]] doctests. + INTEGER, INTENT(in) :: unit !< Logical unit. + TYPE(string), INTENT(in) :: lines(1:) !< The lines. + CHARACTER(*), INTENT(in), OPTIONAL :: form !< Format of unit. + INTEGER, INTENT(out), OPTIONAL :: iostat !< IO status code. + CHARACTER(*), INTENT(inout), OPTIONAL :: iomsg !< IO status message. + INTEGER :: l !< Counter. + + DO l = 1, SIZE(lines, dim=1) + CALL lines(l)%write_line(unit=unit, form=form, iostat=iostat, iomsg=iomsg) + END DO +END SUBROUTINE write_lines +END MODULE String_Method diff --git a/src/modules/SuperLUInterface/CMakeLists.txt b/src/modules/SuperLUInterface/CMakeLists.txt new file mode 100644 index 000000000..5ad0d4d3c --- /dev/null +++ b/src/modules/SuperLUInterface/CMakeLists.txt @@ -0,0 +1,38 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +IF(USE_SUPERLU) + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/SuperLU_Types.F90 + ${src_path}/SuperLU_Enums.F90 + ${src_path}/SuperLU_Util_Methods.F90 + ${src_path}/SuperLU_dUtil_Methods.F90 + ${src_path}/SuperLU_dgssv_Methods.F90 + ${src_path}/SuperLU_dgssvx_Methods.F90 + ${src_path}/SuperLU_dgsitrf_Methods.F90 + ${src_path}/SuperLU_dgsisx_Methods.F90 + ${src_path}/SuperLU_dgstrf_Methods.F90 + ${src_path}/SuperLU_dgstrs_Methods.F90 + ${src_path}/SuperLU_dgscon_Methods.F90 + ${src_path}/SuperLU_dgsequ_Methods.F90 + ${src_path}/SuperLU_dlaqgs_Methods.F90 + ${src_path}/SuperLU_dgsrfs_Methods.F90 + ${src_path}/SuperLUInterface.F90 + ) +ENDIF() diff --git a/src/modules/SuperLUInterface/src/SuperLUInterface.F90 b/src/modules/SuperLUInterface/src/SuperLUInterface.F90 new file mode 100644 index 000000000..c963bcbc7 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLUInterface.F90 @@ -0,0 +1,34 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE SuperLUInterface +USE SuperLU_Types +USE SuperLU_Util_Methods +USE SuperLU_dUtil_Methods +USE SuperLU_dgssv_Methods +USE SuperLU_dgssvx_Methods +USE SuperLU_dgsitrf_Methods +USE SuperLU_dgsisx_Methods +USE SuperLU_dgstrf_Methods +USE SuperLU_dgstrs_Methods +USE SuperLU_dgstrs_Methods +USE SuperLU_dgscon_Methods +USE SuperLU_dgsequ_Methods +USE SuperLU_dlaqgs_Methods +USE SuperLU_dgsrfs_Methods +IMPLICIT NONE +END MODULE SuperLUInterface diff --git a/src/modules/SuperLUInterface/src/SuperLU_Enums.F90 b/src/modules/SuperLUInterface/src/SuperLU_Enums.F90 new file mode 100644 index 000000000..9ed1265b1 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_Enums.F90 @@ -0,0 +1,320 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE SuperLU_Enums +USE ISO_C_BINDING, ONLY: C_INT, C_DOUBLE, C_CHAR, C_FLOAT, C_PTR +IMPLICIT NONE + +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {NO, YES} yes_no_t; + +ENUM, BIND(c) + ENUMERATOR :: NO, YES +END ENUM + +PUBLIC :: NO, YES + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED} fact_t; + +ENUM, BIND(c) + ENUMERATOR :: DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED +END ENUM + +PUBLIC :: DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef ENUM{NOROWPERM, LargeDiag_MC64, LargeDiag_HWPM, MY_PERMR}rowperm_t; +ENUM, BIND(C) + ENUMERATOR :: NOROWPERM, LargeDiag_MC64, LargeDiag_HWPM, MY_PERMR +END ENUM + +PUBLIC :: NOROWPERM, LargeDiag_MC64, LargeDiag_HWPM, MY_PERMR + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {NATURAL, MMD_ATA, MMD_AT_PLUS_A, COLAMD, +! METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC} colperm_t; + +ENUM, BIND(c) + ENUMERATOR :: NATURAL, MMD_ATA, MMD_AT_PLUS_A, COLAMD, & + & METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC +END ENUM + +PUBLIC :: NATURAL, MMD_ATA, MMD_AT_PLUS_A, COLAMD, & +& METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {NOTRANS, TRANS, CONJ} trans_t; + +ENUM, BIND(C) + ENUMERATOR :: NOTRANS, TRANS, CONJ +END ENUM + +PUBLIC :: NOTRANS, TRANS, CONJ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {NOEQUIL, ROW, COL, BOTH} DiagScale_t; +ENUM, BIND(C) + ENUMERATOR :: NOEQUIL, ROW, COL, BOTH +END ENUM + +PUBLIC :: NOEQUIL, ROW, COL, BOTH + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {NOREFINE, SLU_SINGLE=1, SLU_DOUBLE, SLU_EXTRA} IterRefine_t; + +ENUM, BIND(C) + ENUMERATOR :: NOREFINE, SLU_SINGLE = 1, SLU_DOUBLE, SLU_EXTRA +END ENUM + +PUBLIC :: NOREFINE, SLU_SINGLE, SLU_DOUBLE, SLU_EXTRA + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE} MemType; + +ENUM, BIND(C) + ENUMERATOR :: USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE +END ENUM + +PUBLIC :: USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {HEAD, TAIL} stack_end_t; + +ENUM, BIND(C) + ENUMERATOR :: HEAD, TAIL +END ENUM + +PUBLIC :: HEAD, TAIL + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {SYSTEM, USER} LU_space_t; + +ENUM, BIND(c) + ENUMERATOR :: SYSTEM, USER +END ENUM + +PUBLIC :: SYSTEM, USER + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {ONE_NORM, TWO_NORM, INF_NORM} norm_t; + +ENUM, BIND(C) + ENUMERATOR :: ONE_NORM, TWO_NORM, INF_NORM +END ENUM + +PUBLIC :: ONE_NORM, TWO_NORM, INF_NORM + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {SILU, SMILU_1, SMILU_2, SMILU_3} milu_t; +ENUM, BIND(C) + ENUMERATOR :: SILU, SMILU_1, SMILU_2, SMILU_3 +END ENUM + +PUBLIC :: SILU, SMILU_1, SMILU_2, SMILU_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! /* +! * The following enumerate type is used by the statistics variable +! * to keep track of flop count and time spent at various stages. +! * +! * Note that not all of the fields are disjoint. +! */ +! typedef enum { +! COLPERM, /* find a column ordering that minimizes fills */ +! ROWPERM, /* find a row ordering maximizes diagonal. */ +! RELAX, /* find artificial supernodes */ +! ETREE, /* compute column etree */ +! EQUIL, /* equilibrate the original matrix */ +! SYMBFAC, /* symbolic factorization. */ +! DIST, /* distribute matrix. */ +! FACT, /* perform LU factorization */ +! COMM, /* communication for factorization */ +! COMM_DIAG, /* Bcast diagonal block to process column */ +! COMM_RIGHT, /* communicate L panel */ +! COMM_DOWN, /* communicate U panel */ +! SOL_COMM,/* communication for solve */ +! SOL_GEMM,/* gemm for solve */ +! SOL_TRSM,/* trsm for solve */ +! SOL_TOT, /* LU-solve time*/ +! RCOND, /* estimate reciprocal condition number */ +! SOLVE, /* forward and back solves */ +! REFINE, /* perform iterative refinement */ +! TRSV, /* fraction of FACT spent in xTRSV */ +! GEMV, /* fraction of FACT spent in xGEMV */ +! FERR, /* estimate error bounds after iterative refinement */ +! NPHASES /* total number of phases */ +! } PhaseType; + +ENUM, BIND(C) + ENUMERATOR :: COLPERM, ROWPERM, RELAX, ETREE, EQUIL, SYMBFAC, & + & DIST, FACT, COMM, COMM_DIAG, COMM_RIGHT, COMM_DOWN,& + & SOL_COMM, SOL_GEMM, SOL_TRSM, SOL_TOT, RCOND, SOLVE, REFINE, & + & TRSV, GEMV, FERR, NPHASES +END ENUM + +PUBLIC :: COLPERM, ROWPERM, RELAX, ETREE, EQUIL, SYMBFAC, & + & DIST, FACT, COMM, COMM_DIAG, COMM_RIGHT, COMM_DOWN,& + & SOL_COMM, SOL_GEMM, SOL_TRSM, SOL_TOT, RCOND, SOLVE, REFINE, & + & TRSV, GEMV, FERR, NPHASES + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-21 +! summary: Stype_t enums +! +!# Introduction +! +! typedef enum { +! SLU_NC, /* column-wise, no supernode */ +! SLU_NCP, /* column-wise, column-permuted, no supernode +! (The consecutive columns of nonzeros, after permutation, +! may not be stored contiguously.) */ +! SLU_NR, /* row-wize, no supernode */ +! SLU_SC, /* column-wise, supernode */ +! SLU_SCP, /* supernode, column-wise, permuted */ +! SLU_SR, /* row-wise, supernode */ +! SLU_DN, /* Fortran style column-wise storage for dense matrix */ +! SLU_NR_loc /* distributed compressed row format */ +! } Stype_t; +! +ENUM, BIND(C) + ENUMERATOR :: SLU_NC + ENUMERATOR :: SLU_NCP + ENUMERATOR :: SLU_NR + ENUMERATOR :: SLU_SC + ENUMERATOR :: SLU_SCP + ENUMERATOR :: SLU_SR + ENUMERATOR :: SLU_DN + ENUMERATOR :: SLU_NR_loc +END ENUM + +PUBLIC :: SLU_NC, SLU_NCP, SLU_NR, SLU_SC, SLU_SCP, SLU_SR, & + & SLU_DN, SLU_NR_loc + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-21 +! summary: Dtype_t +! +!# Introduction +! +!```c +! typedef enum { +! SLU_S, /* single */ +! SLU_D, /* double */ +! SLU_C, /* single complex */ +! SLU_Z /* double complex */ +! } Dtype_t; +!``` + +ENUM, BIND(c) + ENUMERATOR :: SLU_S + ENUMERATOR :: SLU_D + ENUMERATOR :: SLU_C + ENUMERATOR :: SLU_Z +END ENUM + +PUBLIC :: SLU_S, SLU_D, SLU_C, SLU_Z + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-21 +! summary: MType_t +! +!# Introduction +! +!```c +! typedef enum { +! SLU_GE, /* general */ +! SLU_TRLU, /* lower triangular, unit diagonal */ +! SLU_TRUU, /* upper triangular, unit diagonal */ +! SLU_TRL, /* lower triangular */ +! SLU_TRU, /* upper triangular */ +! SLU_SYL, /* symmetric, store lower half */ +! SLU_SYU, /* symmetric, store upper half */ +! SLU_HEL, /* Hermitian, store lower half */ +! SLU_HEU /* Hermitian, store upper half */ +! } Mtype_t; +!``` + +ENUM, BIND(c) + ENUMERATOR :: SLU_GE + ENUMERATOR :: SLU_TRLU + ENUMERATOR :: SLU_TRUU + ENUMERATOR :: SLU_TRL + ENUMERATOR :: SLU_TRU + ENUMERATOR :: SLU_SYL + ENUMERATOR :: SLU_SYU + ENUMERATOR :: SLU_HEL + ENUMERATOR :: SLU_HEU +END ENUM + +PUBLIC :: SLU_GE, SLU_TRLU, SLU_TRUU, SLU_TRL, SLU_TRU, SLU_SYL, & + & SLU_SYU, SLU_HEL, SLU_HEU + +END MODULE SuperLU_Enums diff --git a/src/modules/SuperLUInterface/src/SuperLU_Types.F90 b/src/modules/SuperLUInterface/src/SuperLU_Types.F90 new file mode 100644 index 000000000..7db388c16 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_Types.F90 @@ -0,0 +1,668 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_Types +USE ISO_C_BINDING, ONLY: C_INT, C_DOUBLE, C_CHAR, C_FLOAT, C_PTR +USE SuperLU_Enums +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: yes_no_ + INTEGER(C_INT) :: no, yes +END TYPE + +TYPE(yes_no_), PUBLIC, PARAMETER :: yes_no_t = yes_no_(no=no, yes=yes) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: fact_ + INTEGER(C_INT) :: DOFACT, SamePattern, SamePattern_SameRowPerm, FACTORED +END TYPE fact_ + +TYPE(fact_), PARAMETER, PUBLIC :: fact_t = fact_(& + & DOFACT=DOFACT, & + & SamePattern=SamePattern, & + & SamePattern_SameRowPerm=SamePattern_SameRowPerm, & + & FACTORED=FACTORED & + &) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: rowperm_ + INTEGER(C_INT) :: NOROWPERM + INTEGER(C_INT) :: LargeDiag_MC64 + INTEGER(C_INT) :: LargeDiag_HWPM + INTEGER(C_INT) :: MY_PERMR +END TYPE rowperm_ + +TYPE(rowperm_), PUBLIC, PARAMETER :: rowperm_t = rowperm_(& + & NOROWPERM=NOROWPERM, & + & LargeDiag_MC64=LargeDiag_MC64, & + & LargeDiag_HWPM=LargeDiag_HWPM, & + & MY_PERMR=MY_PERMR & + & ) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: colperm_ + INTEGER(C_INT) :: NATURAL, MMD_ATA, MMD_AT_PLUS_A, & + & COLAMD, METIS_AT_PLUS_A, PARMETIS, ZOLTAN, MY_PERMC +END TYPE colperm_ + +TYPE(colperm_), PUBLIC, PARAMETER :: colperm_t = colperm_(& + & NATURAL=NATURAL, & + & MMD_ATA=MMD_ATA, & + & MMD_AT_PLUS_A=MMD_AT_PLUS_A, & + & COLAMD=COLAMD, & + & METIS_AT_PLUS_A=METIS_AT_PLUS_A, & + & PARMETIS=PARMETIS, & + & ZOLTAN=ZOLTAN, & + & MY_PERMC=MY_PERMC & + &) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: trans_ + INTEGER(C_INT) :: NOTRANS, TRANS, CONJ +END TYPE trans_ + +TYPE(trans_), PARAMETER, PUBLIC :: trans_t = trans_(& + & NOTRANS=NOTRANS, trans=trans, conj=conj) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: DiagScale_ + INTEGER(C_INT) :: NOEQUIL, ROW, COL, BOTH +END TYPE DiagScale_ + +TYPE(DiagScale_), PARAMETER, PUBLIC :: DiagScale_t = DiagScale_(& + & NOEQUIL=NOEQUIL, ROW=ROW, COL=COL, BOTH=BOTH) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {NOREFINE, SLU_SINGLE=1, SLU_DOUBLE, SLU_EXTRA} IterRefine_t; + +TYPE :: IterRefine_ + INTEGER(C_INT) :: NOREFINE, SLU_SINGLE = 1, SLU_DOUBLE, SLU_EXTRA +END TYPE + +TYPE(IterRefine_), PARAMETER, PUBLIC :: IterRefine_t = IterRefine_(& +& NOREFINE, SLU_SINGLE, SLU_DOUBLE, SLU_EXTRA) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: MemType_ + INTEGER(C_INT) :: USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE +END TYPE + +TYPE(MemType_), PUBLIC, PARAMETER :: MemType_t = MemType_( & +& USUB, LSUB, UCOL, LUSUP, LLVL, ULVL, NO_MEMTYPE) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef enum {HEAD, TAIL} stack_end_t; + +TYPE :: stack_end_ + INTEGER(C_INT) :: HEAD, TAIL +END TYPE + +TYPE(stack_end_), PUBLIC, PARAMETER :: stack_end_t = stack_end_(& +& HEAD, TAIL) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: LU_space_ + INTEGER(C_INT) :: SYSTEM + INTEGER(C_INT) :: USER +END TYPE LU_space_ + +TYPE(LU_space_), PARAMETER, PUBLIC :: LU_space_t = LU_space_(& + & SYSTEM=SYSTEM, & + & USER=USER & + & ) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: Stype_ + INTEGER(C_INT) :: SLU_NC + INTEGER(C_INT) :: SLU_NCP + INTEGER(C_INT) :: SLU_NR + INTEGER(C_INT) :: SLU_SC + INTEGER(C_INT) :: SLU_SCP + INTEGER(C_INT) :: SLU_SR + INTEGER(C_INT) :: SLU_DN + INTEGER(C_INT) :: SLU_NR_LOC +END TYPE Stype_ + +TYPE(Stype_), PARAMETER, PUBLIC :: Stype_t = Stype_(& + & SLU_NC=SLU_NC, & + & SLU_NCP=SLU_NCP, & + & SLU_NR=SLU_NR, & + & SLU_SC=SLU_SC, & + & SLU_SCP=SLU_SCP, & + & SLU_SR=SLU_SR, & + & SLU_DN=SLU_DN, & + & SLU_NR_LOC=SLU_NR_LOC & + & ) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: Dtype_ + INTEGER(C_INT) :: SLU_S + INTEGER(C_INT) :: SLU_D + INTEGER(C_INT) :: SLU_C + INTEGER(C_INT) :: SLU_Z +END TYPE Dtype_ + +TYPE(Dtype_), PARAMETER, PUBLIC :: Dtype_t = Dtype_(& + & SLU_S=SLU_S, & + & SLU_D=SLU_D, & + & SLU_C=SLU_C, & + & SLU_Z=SLU_Z) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE :: Mtype_ + INTEGER(C_INT) :: SLU_GE + INTEGER(C_INT) :: SLU_TRLU + INTEGER(C_INT) :: SLU_TRUU + INTEGER(C_INT) :: SLU_TRL + INTEGER(C_INT) :: SLU_TRU + INTEGER(C_INT) :: SLU_SYL + INTEGER(C_INT) :: SLU_SYU + INTEGER(C_INT) :: SLU_HEL + INTEGER(C_INT) :: SLU_HEU +END TYPE Mtype_ + +TYPE(Mtype_), PUBLIC, PARAMETER :: Mtype_t = Mtype_(& + & SLU_GE=SLU_GE, & + & SLU_TRLU=SLU_TRLU, & + & SLU_TRUU=SLU_TRUU, & + & SLU_TRL=SLU_TRL, & + & SLU_TRU=SLU_TRU, & + & SLU_SYL=SLU_SYL, & + & SLU_SYU=SLU_SYU, & + & SLU_HEL=SLU_HEL, & + & SLU_HEU=SLU_HEU) + +!---------------------------------------------------------------------------- +! superlu_options_t +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-21 +! summary: SuperLU options +! +!# Introduction +! + +! typedef struct { +! fact_t Fact; +! yes_no_t Equil; +! colperm_t ColPerm; +! trans_t Trans; +! IterRefine_t IterRefine; +! double DiagPivotThresh; +! yes_no_t SymmetricMode; +! yes_no_t PivotGrowth; +! yes_no_t ConditionNumber; +! rowperm_t RowPerm; +! int ILU_DropRule; +! double ILU_DropTol; /* threshold for dropping */ +! double ILU_FillFactor; /* gamma in the secondary dropping */ +! norm_t ILU_Norm; /* infinity-norm, 1-norm, or 2-norm */ +! double ILU_FillTol; /* threshold for zero pivot perturbation */ +! milu_t ILU_MILU; +! double ILU_MILU_Dim; /* Dimension of PDE (if available) */ +! yes_no_t ParSymbFact; +! yes_no_t ReplaceTinyPivot; /* used in SuperLU_DIST */ +! yes_no_t SolveInitialized; +! yes_no_t RefineInitialized; +! yes_no_t PrintStat; +! int nnzL, nnzU; /* used to store nnzs for now */ +! int num_lookaheads; /* num of levels in look-ahead */ +! yes_no_t lookahead_etree; /* use etree computed from the +! serial symbolic factorization */ +! yes_no_t SymPattern; /* symmetric factorization */ +! } superlu_options_t; +! + +TYPE, BIND(C) :: superlu_options_t + INTEGER(C_INT) :: Fact + INTEGER(C_INT) :: Equil + INTEGER(C_INT) :: ColPerm + INTEGER(C_INT) :: Trans + INTEGER(C_INT) :: IterRefine + REAL(C_DOUBLE) :: DiagPivotThresh + INTEGER(C_INT) :: SymmetricMode + INTEGER(C_INT) :: PivotGrowth + INTEGER(C_INT) :: ConditionNumber + INTEGER(C_INT) :: RowPerm + INTEGER(C_INT) :: ILU_DropRule + REAL(C_DOUBLE) :: ILU_DropTol + REAL(C_DOUBLE) :: ILU_FillFactor + INTEGER(C_INT) :: ILU_Norm + REAL(C_DOUBLE) :: ILU_FillTol + INTEGER(C_INT) :: ILU_MILU; + REAL(C_DOUBLE) :: ILU_MILU_Dim + INTEGER(C_INT) :: ParSymbFact + INTEGER(C_INT) :: ReplaceTinyPivot + INTEGER(C_INT) :: SolveInitialized + INTEGER(C_INT) :: RefineInitialized + INTEGER(C_INT) :: PrintStat = 0 + INTEGER(C_INT) :: nnzL + INTEGER(C_INT) :: nnzU + INTEGER(C_INT) :: num_lookaheads + INTEGER(C_INT) :: lookahead_etree + INTEGER(C_INT) :: SymPattern +END TYPE superlu_options_t + +PUBLIC :: superlu_options_t + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct e_node { +! int size; /* length of the memory that has been used */ +! void *mem; /* pointer to the new malloc'd store */ +! } ExpHeader; + +TYPE, BIND(c) :: ExpHeader + INTEGER(C_INT) :: size + TYPE(C_PTR) :: mem +END TYPE ExpHeader + +PUBLIC :: ExpHeader + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int size; +! int used; +! int top1; /* grow upward, relative to &array[0] */ +! int top2; /* grow downward */ +! void *array; +! } LU_stack_t; + +TYPE, BIND(c) :: LU_stack_t + INTEGER(C_INT) :: size + INTEGER(C_INT) :: used + INTEGER(C_INT) :: top1 + INTEGER(C_INT) :: top2 + TYPE(C_PTR) :: array +END TYPE LU_stack_t + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int *panel_histo; /* histogram of panel size distribution */ +! double *utime; /* running time at various phases */ +! flops_t *ops; /* operation count at various phases */ +! int TinyPivots; /* number of tiny pivots */ +! int RefineSteps; /* number of iterative refinement steps */ +! int expansions; /* number of memory expansions */ +! } SuperLUStat_t; + +TYPE, BIND(C) :: SuperLUStat_t + ! INTEGER(C_INT), POINTER :: panel_histo(:) + ! REAL(C_DOUBLE), POINTER :: utime(:) + ! REAL(C_FLOAT), POINTER :: ops(:) + TYPE(C_PTR) :: panel_histo + TYPE(C_PTR) :: utime + TYPE(C_PTR) :: ops + INTEGER(C_INT) :: TinyPivots + INTEGER(C_INT) :: RefineSteps + INTEGER(C_INT) :: expansions +END TYPE SuperLUStat_t + +PUBLIC :: SuperLUStat_t + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! float for_lu; +! float total_needed; +! } mem_usage_t; + +TYPE, BIND(C) :: mem_usage_t + REAL(C_FLOAT) :: for_lu + REAL(C_FLOAT) :: total_needed +END TYPE mem_usage_t + +PUBLIC :: mem_usage_t + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct{ +! int * xsup; /*supernode and column mapping*/ +! int * supno; +! int * lsub; /*compressed L subscripts*/ +! int * xlsub; +! void * lusup; /*L supernodes*/ +! int * xlusup; +! void * ucol; /*U columns*/ +! int * usub; +! int * xusub; +! int nzlmax; /*current max size of lsub*/ +! int nzumax; int nzlumax; int n; /*number of columns in the matrix*/ +! LU_space_t MemModel; int num_expansions; +! ExpHeader * expanders; /*Array of pointers to 4 types of memory*/ +! LU_stack_t stack; /*USE user supplied memory*/ +! }GlobalLU_t; + +TYPE, BIND(c) :: GlobalLU_t + TYPE(C_PTR) :: xsup, supno, lsub, xlsub, lusup, xlusup, ucol, usub + TYPE(C_PTR) :: xusub + INTEGER(C_INT) :: nzlmax, nzumax, nzlumax, n, num_expansions + INTEGER(C_INT) :: MemModel + TYPE(ExpHeader) :: expanders + TYPE(LU_stack_t) :: stack +END TYPE GlobalLU_t + +PUBLIC :: GlobalLU_t + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! Stype_t Stype; /* Storage type: interprets the storage structure +! pointed to by *Store. */ +! Dtype_t Dtype; /* Data type. */ +! Mtype_t Mtype; /* Matrix type: describes the mathematical property of +! the matrix. */ +! int_t nrow; /* number of rows */ +! int_t ncol; /* number of columns */ +! void *Store; /* pointer to the actual storage of the matrix */ +! } SuperMatrix; + +TYPE, BIND(C) :: SuperMatrix + INTEGER(C_INT) :: Stype; + INTEGER(C_INT) :: Dtype; + INTEGER(C_INT) :: Mtype; + INTEGER(C_INT) :: nrow + INTEGER(C_INT) :: ncol + TYPE(C_PTR) :: Store +END TYPE SuperMatrix + +PUBLIC :: SuperMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int_t nnz; /* number of nonzeros in the matrix */ +! void *nzval; /* pointer to array of nonzero values, packed by column */ +! int_t *rowind; /* pointer to array of row indices of the nonzeros */ +! int_t *colptr; /* pointer to array of beginning of columns in nzval[] +! and rowind[] */ +! /* Note: +! Zero-based indexing is used; +! colptr[] has ncol+1 entries, the last one pointing +! beyond the last column, so that colptr[ncol] = nnz. */ +! } NCformat; + +TYPE, BIND(c) :: NCformat + INTEGER(C_INT) :: nnz + TYPE(C_PTR) :: nzval + TYPE(C_PTR) :: rowind + TYPE(C_PTR) :: colptr +END TYPE NCformat + +PUBLIC :: NCformat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int_t nnz; /* number of nonzeros in the matrix */ +! void *nzval; /* pointer to array of nonzero values, packed by raw */ +! int_t *colind; /* pointer to array of columns indices of the nonzeros */ +! int_t *rowptr; /* pointer to array of beginning of rows in nzval[] +! and colind[] */ +! /* Note: +! Zero-based indexing is used; +! rowptr[] has nrow+1 entries, the last one pointing +! beyond the last row, so that rowptr[nrow] = nnz. */ +! } NRformat; + +TYPE, BIND(c) :: NRformat + INTEGER(C_INT) :: nnz + TYPE(C_PTR) :: nzval + TYPE(C_PTR) :: colind + TYPE(C_PTR) :: rowptr +END TYPE NRformat + +PUBLIC :: NRformat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int_t nnz; /* number of nonzeros in the matrix */ +! int_t nsuper; /* number of supernodes, minus 1 */ +! void *nzval; /* pointer to array of nonzero values, packed by column */ +! int_t *nzval_colptr; /* pointer to array of beginning of columns in nzval[] */ +! int_t *rowind; /* pointer to array of compressed row indices of +! rectangular supernodes */ +! int_t +! *rowind_colptr; /* pointer to array of beginning of columns in rowind[] */ +! int_t *col_to_sup; /* col_to_sup[j] is the supernode number to which column +! j belongs; mapping from column to supernode number. */ +! int_t *sup_to_col; /* sup_to_col[s] points to the start of the s-th +! supernode; mapping from supernode number to column. +! e.g.: col_to_sup: 0 1 2 2 3 3 3 4 4 4 4 4 4 (ncol=12) +! sup_to_col: 0 1 2 4 7 12 (nsuper=4) */ +! /* Note: +! Zero-based indexing is used; +! nzval_colptr[], rowind_colptr[], col_to_sup and +! sup_to_col[] have ncol+1 entries, the last one +! pointing beyond the last column. +! For col_to_sup[], only the first ncol entries are +! defined. For sup_to_col[], only the first nsuper+2 +! entries are defined. */ +! } SCformat; +! + +TYPE, BIND(c) :: SCformat + INTEGER(C_INT) :: nnz + INTEGER(C_INT) :: nsuper + TYPE(C_PTR) :: nzval + TYPE(C_PTR) :: nzval_colptr + TYPE(C_PTR) :: rowind + TYPE(C_PTR) :: rowind_colptr + TYPE(C_PTR) :: col_to_sup + TYPE(C_PTR) :: sup_to_col +END TYPE SCformat + +PUBLIC :: SCformat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int_t nnz; /* number of nonzeros in the matrix */ +! int_t nsuper; /* number of supernodes */ +! void *nzval; /* pointer to array of nonzero values, packed by column */ +! int_t *nzval_colbeg; /* nzval_colbeg[j] points to beginning of column j +! in nzval[] */ +! int_t *nzval_colend; /* nzval_colend[j] points to one past the last element +! of column j in nzval[] */ +! int_t *rowind; /* pointer to array of compressed row indices of +! rectangular supernodes */ +! int_t *rowind_colbeg; /* rowind_colbeg[j] points to beginning of column j +! in rowind[] */ +! int_t *rowind_colend; /* rowind_colend[j] points to one past the last element +! of column j in rowind[] */ +! int_t *col_to_sup; /* col_to_sup[j] is the supernode number to which column +! j belongs; mapping from column to supernode. */ +! int_t *sup_to_colbeg; /* sup_to_colbeg[s] points to the start of the s-th +! supernode; mapping from supernode to column.*/ +! int_t *sup_to_colend; /* sup_to_colend[s] points to one past the end of the +! s-th supernode; mapping from supernode number to +! column. +! e.g.: col_to_sup: 0 1 2 2 3 3 3 4 4 4 4 4 4 (ncol=12) +! sup_to_colbeg: 0 1 2 4 7 (nsuper=4) +! sup_to_colend: 1 2 4 7 12 */ +! /* Note: +! Zero-based indexing is used; +! nzval_colptr[], rowind_colptr[], col_to_sup and +! sup_to_col[] have ncol+1 entries, the last one +! pointing beyond the last column. */ +! } SCPformat; + +TYPE, BIND(c) :: SCPformat + INTEGER(C_INT) :: nnz, nsuper + TYPE(C_PTR) :: nzval, nzval_colbeg, nzval_colend, rowind, & + & rowind_colbeg, rowindx_colend, col_to_sup, sup_to_colbeg, & + & sup_to_colend +END TYPE SCPformat + +PUBLIC :: SCPformat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int_t nnz; /* number of nonzeros in the matrix */ +! void *nzval; /* pointer to array of nonzero values, packed by column */ +! int_t *rowind; /* pointer to array of row indices of the nonzeros */ +! /* Note: nzval[]/rowind[] always have the same length */ +! int_t *colbeg; /* colbeg[j] points to the beginning of column j in nzval[] +! and rowind[] */ +! int_t *colend; /* colend[j] points to one past the last element of column +! j in nzval[] and rowind[] */ +! /* Note: +! Zero-based indexing is used; +! The consecutive columns of the nonzeros may not be +! contiguous in storage, because the matrix has been +! postmultiplied by a column permutation matrix. */ +! } NCPformat; + +TYPE, BIND(c) :: NCPformat + INTEGER(C_INT) :: nnz + TYPE(C_PTR) :: nzval, rowindx, colbeg, colend +END TYPE NCPformat + +PUBLIC :: NCPformat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int_t lda; /* leading dimension */ +! void *nzval; /* array of size lda*ncol to represent a dense matrix */ +! } DNformat; + +TYPE, BIND(c) :: DNformat + INTEGER(C_INT) :: lda + TYPE(C_PTR) :: nzval +END TYPE DNformat + +PUBLIC :: DNformat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct { +! int_t nnz_loc; /* number of nonzeros in the local submatrix */ +! int_t m_loc; /* number of rows local to this processor */ +! int_t fst_row; /* global index of the first row */ +! void *nzval; /* pointer to array of nonzero values, packed by row */ +! int_t *rowptr; /* pointer to array of beginning of rows in nzval[] +! and colind[] */ +! int_t *colind; /* pointer to array of column indices of the nonzeros */ +! /* Note: +! Zero-based indexing is used; +! rowptr[] has n_loc + 1 entries, the last one pointing +! beyond the last row, so that rowptr[n_loc] = nnz_loc.*/ +! } NRformat_loc; + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! typedef struct NRformat_loc3d { +! NRformat_loc *A_nfmt; // Gathered A matrix on 2D grid-0 +! void *B3d; // on the entire 3D process grid +! int ldb; // relative to 3D process grid +! int nrhs; +! int m_loc; // relative to 3D process grid +! void *B2d; // on 2D process layer grid-0 +! +! int *row_counts_int; // these counts are stored on 2D layer grid-0, +! int *row_disp; // but count the number of {A, B} rows along Z-dimension +! int *nnz_counts_int; +! int *nnz_disp; +! int *b_counts_int; +! int *b_disp; +! +! /* The following 4 structures are used for scattering +! solution X from 2D grid-0 back to 3D processes */ +! int num_procs_to_send; +! int *procs_to_send_list; +! int *send_count_list; +! int num_procs_to_recv; +! int *procs_recv_from_list; +! int *recv_count_list; +! } NRformat_loc3d; + +END MODULE SuperLU_Types diff --git a/src/modules/SuperLUInterface/src/SuperLU_Util_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_Util_Methods.F90 new file mode 100644 index 000000000..c239952e4 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_Util_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 +! + +MODULE SuperLU_Util_Methods +USE ISO_C_BINDING, ONLY: C_PTR, C_INT, C_DOUBLE, C_CHAR, C_FLOAT, & + & C_SIZE_T +USE SuperLU_Types +IMPLICIT NONE + +PRIVATE + +#include "./include/macros.inc" + +!---------------------------------------------------------------------------- +! set_default_options +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE set_default_options(options) BIND(C, & + & NAME='set_default_options') + IMPORT superlu_options_t + TYPE(superlu_options_t), INTENT(INOUT) :: options + END SUBROUTINE set_default_options +END INTERFACE + +PUBLIC :: set_default_options + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Set the default values for the options argument for ILU. +! void ilu_set_default_options(superlu_options_t *options) + +INTERFACE + SUBROUTINE ilu_set_default_options(options) & + & BIND(C, name="ilu_set_default_options") + IMPORT :: superlu_options_t + TYPE(superlu_options_t), INTENT(inout) :: options + END SUBROUTINE ilu_set_default_options +END INTERFACE + +PUBLIC :: ilu_set_default_options + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! brief Print the options setting. +! void print_options(superlu_options_t *options) + +INTERFACE + SUBROUTINE print_options(options) & + & BIND(C, name="print_options") + IMPORT :: superlu_options_t + TYPE(superlu_options_t), INTENT(IN) :: options + END SUBROUTINE print_options +END INTERFACE + +PUBLIC :: print_options + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Print the options setting. +! void print_ilu_options(superlu_options_t *options) + +INTERFACE + SUBROUTINE print_ilu_options(options) & + & BIND(C, name="print_ilu_options") + IMPORT :: superlu_options_t + TYPE(superlu_options_t), INTENT(IN) :: options + END SUBROUTINE print_ilu_options +END INTERFACE + +PUBLIC :: print_ilu_options + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Deallocate the structure pointing to the actual storage of the matrix. */ +! void +! Destroy_SuperMatrix_Store(SuperMatrix *A) + +INTERFACE + SUBROUTINE Destroy_SuperMatrix_Store(A) & + & BIND(C, name="Destroy_SuperMatrix_Store") + IMPORT :: C_PTR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(IN) :: A +#else + TYPE(SuperMatrix), INTENT(INOUT) :: A +#endif + END SUBROUTINE Destroy_SuperMatrix_Store +END INTERFACE + +PUBLIC :: Destroy_SuperMatrix_Store + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Deallocate the structure pointing to the actual storage of the matrix. */ +! void +! extern void Destroy_CompCol_Matrix(SuperMatrix *); + +INTERFACE + SUBROUTINE Destroy_CompCol_Matrix(A) & + & BIND(C, name="Destroy_CompCol_Matrix") + IMPORT :: C_PTR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(INOUT) :: A +#else + TYPE(SuperMatrix), INTENT(INOUT) :: A +#endif + END SUBROUTINE Destroy_CompCol_Matrix +END INTERFACE + +PUBLIC :: Destroy_CompCol_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Deallocate the structure pointing to the actual storage of the matrix. */ +! void +! Destroy_SuperMatrix_Store(SuperMatrix *A) + +INTERFACE + SUBROUTINE Destroy_CompRow_Matrix(A) & + & BIND(C, name="Destroy_CompRow_Matrix") + IMPORT :: C_PTR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(INOUT) :: A +#else + TYPE(SuperMatrix), INTENT(INOUT) :: A +#endif + END SUBROUTINE Destroy_CompRow_Matrix +END INTERFACE + +PUBLIC :: Destroy_CompRow_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Deallocate the structure pointing to the actual storage of the matrix. */ +! void +! Destroy_SuperMatrix_Store(SuperMatrix *A) + +INTERFACE + SUBROUTINE Destroy_SuperNode_Matrix(A) & + & BIND(C, name="Destroy_SuperNode_Matrix") + IMPORT :: C_PTR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(INOUT) :: A +#else + TYPE(SuperMatrix), INTENT(INOUT) :: A +#endif + END SUBROUTINE Destroy_SuperNode_Matrix +END INTERFACE + +PUBLIC :: Destroy_SuperNode_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Deallocate the structure pointing to the actual storage of the matrix. */ +! void +! Destroy_SuperMatrix_Store(SuperMatrix *A) + +INTERFACE + SUBROUTINE Destroy_CompCol_Permuted(A) & + & BIND(C, name="Destroy_CompCol_Permuted") + IMPORT :: C_PTR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(INOUT) :: A +#else + TYPE(SuperMatrix), INTENT(INOUT) :: A +#endif + END SUBROUTINE Destroy_CompCol_Permuted +END INTERFACE + +PUBLIC :: Destroy_CompCol_Permuted + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE Destroy_Dense_Matrix(A) & + & BIND(C, name="Destroy_Dense_Matrix") + IMPORT :: C_PTR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(INOUT) :: A +#else + TYPE(SuperMatrix), INTENT(INOUT) :: A +#endif + END SUBROUTINE Destroy_Dense_Matrix +END INTERFACE + +PUBLIC :: Destroy_Dense_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Count the total number of nonzeros in factors L and U, and in the symmetrically reduced L. +! void +! countnz(const int n, int *xprune, int *nnzL, int *nnzU, GlobalLU_t *Glu) + +INTERFACE + SUBROUTINE countnz(n, xprune, nnzL, nnzU, Glu) & + & BIND(C, name="countnz") + IMPORT :: C_INT, C_PTR, GlobalLU_t + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), INTENT(IN) :: xprune(*) + INTEGER(C_INT), INTENT(INOUT) :: nnzL + INTEGER(C_INT), INTENT(INOUT) :: nnzU + TYPE(GlobalLU_t), INTENT(IN) :: Glu + END SUBROUTINE countnz +END INTERFACE + +PUBLIC :: countnz + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! !brief Count the total number of nonzeros in factors L and U. +! void +! ilu_countnz(const int n, int *nnzL, int *nnzU, GlobalLU_t *Glu) + +INTERFACE + SUBROUTINE ilu_countnz(n, nnzL, nnzU, Glu) & + & BIND(C, name="ilu_countnz") + IMPORT :: C_INT, C_PTR, GlobalLU_t + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), INTENT(INOUT) :: nnzL + INTEGER(C_INT), INTENT(INOUT) :: nnzU + TYPE(GlobalLU_t), INTENT(IN) :: Glu + END SUBROUTINE ilu_countnz +END INTERFACE + +PUBLIC :: ilu_countnz + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! TODO + +!brief Diagnostic print of segment info after panel_dfs(). +! void print_panel_seg(int n, int w, int jcol, int nseg, +! int *segrep, int *repfnz) + +!---------------------------------------------------------------------------- +! +!--------------------------------------------------------------------------- + +! void +! StatInit(SuperLUStat_t *stat) + +INTERFACE + SUBROUTINE StatInit(stat) & + & BIND(C, name="StatInit") +#ifdef SUPERLU_CPTR_ONLY + IMPORT :: C_PTR + TYPE(C_PTR), INTENT(IN) :: stat +#else + IMPORT :: SuperLUStat_t + TYPE(SuperLUStat_t), INTENT(IN) :: stat +#endif + END SUBROUTINE StatInit +END INTERFACE + +PUBLIC :: StatInit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! StatPrint(SuperLUStat_t *stat) + +INTERFACE + SUBROUTINE StatPrint(stat) & + & BIND(C, name="StatPrint") + IMPORT :: C_PTR, SuperLUStat_t +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(IN) :: stat +#else + TYPE(SuperLUStat_t), INTENT(IN) :: stat +#endif + END SUBROUTINE StatPrint +END INTERFACE + +PUBLIC :: StatPrint + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! StatFree(SuperLUStat_t *stat) + +INTERFACE + SUBROUTINE StatFree(stat) & + & BIND(C, name="StatFree") + IMPORT :: C_PTR, SuperLUStat_t +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(IN) :: stat +#else + TYPE(SuperLUStat_t), INTENT(IN) :: stat +#endif + END SUBROUTINE StatFree +END INTERFACE + +PUBLIC :: StatFree + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! flops_t +! LUFactFlops(SuperLUStat_t *stat) + +INTERFACE + FUNCTION LUFactFlops(stat) RESULT(ans) & + & BIND(C, name="LUFactFlops") + IMPORT :: C_PTR + TYPE(C_PTR), INTENT(IN) :: stat + TYPE(C_PTR) :: ans + END FUNCTION LUFactFlops +END INTERFACE + +PUBLIC :: LUFactFlops + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! flops_t +! LUSolveFlops(SuperLUStat_t *stat) + +INTERFACE + FUNCTION LUSolveFlops(stat) RESULT(ans) & + & BIND(C, name="LUSolveFlops") + IMPORT :: C_PTR + TYPE(C_PTR), INTENT(IN) :: stat + TYPE(C_PTR) :: ans + END FUNCTION LUSolveFlops +END INTERFACE + +PUBLIC :: LUSolveFlops + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Fills an integer array with a given value. +! void ifill(int *a, int alen, int ival) + +INTERFACE + SUBROUTINE ifill(a, alen, ival) & + & BIND(C, name="ifill") + IMPORT :: C_INT + INTEGER(C_INT), INTENT(INOUT) :: a(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: alen + INTEGER(C_INT), VALUE, INTENT(IN) :: ival + END SUBROUTINE ifill +END INTERFACE + +PUBLIC :: ifill + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Get the statistics of the supernodes +! void super_stats(int nsuper, int *xsup) + +INTERFACE + SUBROUTINE super_stats(nsuper, xsup) & + & BIND(C, name="super_stats") + IMPORT :: C_INT + INTEGER(C_INT), VALUE, INTENT(IN) :: nsuper + INTEGER(C_INT), INTENT(IN) :: xsup(*) + END SUBROUTINE super_stats +END INTERFACE + +PUBLIC :: super_stats + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! float SpaSize(int n, int np, float sum_npw) + +INTERFACE + SUBROUTINE SpaSize(n, np, sum_npw) & + & BIND(C, name="SpaSize") + IMPORT :: C_INT, C_FLOAT + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), VALUE, INTENT(IN) :: np + REAL(C_FLOAT), VALUE, INTENT(IN) :: sum_npw + END SUBROUTINE SpaSize +END INTERFACE + +PUBLIC :: SpaSize + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! float DenseSize(int n, float sum_nw) + +INTERFACE + FUNCTION DenseSize(n, sum_nw) RESULT(ans) & + & BIND(C, name="DenseSize") + IMPORT :: C_INT, C_FLOAT + INTEGER(C_INT), VALUE, INTENT(IN) :: n + REAL(C_FLOAT), VALUE, INTENT(IN) :: sum_nw + REAL(C_FLOAT) :: ans + END FUNCTION DenseSize +END INTERFACE + +PUBLIC :: DenseSize + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Check whether repfnz[] == EMPTY after reset. +! void check_repfnz(int n, int w, int jcol, int *repfnz) + +INTERFACE + + SUBROUTINE check_repfnz(n, w, jcol, repfnz) & + & BIND(C, name="check_repfnz") + IMPORT :: C_INT + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), VALUE, INTENT(IN) :: w + INTEGER(C_INT), VALUE, INTENT(IN) :: jcol + INTEGER(C_INT), INTENT(IN) :: repfnz(*) + END SUBROUTINE check_repfnz +END INTERFACE + +PUBLIC :: check_repfnz + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Print a summary of the testing results. */ +! void +! PrintSumm(char *type, int nfail, int nrun, int nerrs) + +INTERFACE + SUBROUTINE PrintSumm(type_, nfail, nrun, nerrs) & + & BIND(C, name="PrintSumm") + IMPORT :: C_CHAR, C_INT + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: type_(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: nfail + INTEGER(C_INT), VALUE, INTENT(IN) :: nrun + INTEGER(C_INT), VALUE, INTENT(IN) :: nerrs + END SUBROUTINE PrintSumm +END INTERFACE + +PUBLIC :: PrintSumm + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! int print_int_vec(char *what, int n, int *vec) + +INTERFACE + FUNCTION print_int_vec(what, n, vec) RESULT(ans) & + & BIND(C, name="print_int_vec") + IMPORT :: C_CHAR, C_INT + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: what(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), INTENT(IN) :: vec(*) + INTEGER(C_INT) :: ans + END FUNCTION print_int_vec +END INTERFACE + +PUBLIC :: print_int_vec + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! int slu_PrintInt10(char *name, int len, int *x) + +INTERFACE + FUNCTION slu_PrintInt10(name, len, x) RESULT(ans) & + & BIND(C, name="print_int_vec") + IMPORT :: C_CHAR, C_INT + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: name(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: len + INTEGER(C_INT), INTENT(IN) :: x(*) + INTEGER(C_INT) :: ans + END FUNCTION slu_PrintInt10 +END INTERFACE + +PUBLIC :: slu_PrintInt10 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE superlu_free(addr) & + & BIND(C, name="superlu_free") + IMPORT :: C_PTR + TYPE(C_PTR), INTENT(in) :: addr + END SUBROUTINE superlu_free +END INTERFACE + +PUBLIC :: superlu_free + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION superlu_malloc(size) RESULT(ans) & + & BIND(C, name="superlu_malloc") + IMPORT :: C_PTR, C_SIZE_T + TYPE(C_PTR) :: ans + INTEGER(C_SIZE_T) :: size + END FUNCTION superlu_malloc +END INTERFACE + +PUBLIC :: superlu_malloc + +END MODULE SuperLU_Util_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 new file mode 100644 index 000000000..98cdf2d05 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dUtil_Methods.F90 @@ -0,0 +1,470 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#include "./include/macros.inc" + +MODULE SuperLU_dUtil_Methods +USE ISO_C_BINDING, ONLY: C_PTR, C_INT, C_DOUBLE, C_CHAR +USE SuperLU_Types +IMPLICIT NONE + +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern void +! dCreate_CompCol_Matrix(SuperMatrix *, int, int, int, double *, +! int *, int *, Stype_t, Dtype_t, Mtype_t); + +INTERFACE + SUBROUTINE dCreate_CompCol_Matrix(A, m, n, nnz, nzval, rowind, colptr, & + & stype, dtype, mtype) BIND(C, name="dCreate_CompCol_Matrix") + IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix + TYPE(SuperMatrix), INTENT(INOUT) :: A + INTEGER(C_INT), VALUE, INTENT(IN) :: m + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), VALUE, INTENT(IN) :: nnz + REAL(C_DOUBLE), INTENT(INOUT) :: nzval(*) + INTEGER(C_INT), INTENT(INOUT) :: rowind(*) + INTEGER(C_INT), INTENT(INOUT) :: colptr(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: stype + INTEGER(C_INT), VALUE, INTENT(IN) :: dtype + INTEGER(C_INT), VALUE, INTENT(IN) :: mtype + END SUBROUTINE dCreate_CompCol_Matrix +END INTERFACE + +PUBLIC :: dCreate_CompCol_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dCreate_CompRow_Matrix(SuperMatrix *A, int m, int n, int nnz, +! double *nzval, int *colind, int *rowptr, +! Stype_t stype, Dtype_t dtype, Mtype_t mtype) + +INTERFACE + SUBROUTINE dCreate_CompRow_Matrix(A, m, n, nnz, nzval, colind, rowptr, & + & stype, dtype, mtype) BIND(C, name="dCreate_CompCol_Matrix") + IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix + TYPE(SuperMatrix), INTENT(INOUT) :: A + INTEGER(C_INT), VALUE, INTENT(IN) :: m + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), VALUE, INTENT(IN) :: nnz + REAL(C_DOUBLE), INTENT(IN) :: nzval(*) + INTEGER(C_INT), INTENT(IN) :: colind(*) + INTEGER(C_INT), INTENT(IN) :: rowptr(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: stype + INTEGER(C_INT), VALUE, INTENT(IN) :: dtype + INTEGER(C_INT), VALUE, INTENT(IN) :: mtype + END SUBROUTINE dCreate_CompRow_Matrix +END INTERFACE + +PUBLIC :: dCreate_CompRow_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! /*! \brief Copy matrix A into matrix B. */ +! void +! dCopy_CompCol_Matrix(SuperMatrix *A, SuperMatrix *B) + +INTERFACE + SUBROUTINE dCopy_CompCol_Matrix(A, B) BIND(C, name="dCopy_CompCol_Matrix") + IMPORT :: C_PTR, SuperMatrix + TYPE(SuperMatrix), INTENT(INOUT) :: A, B + END SUBROUTINE dCopy_CompCol_Matrix +END INTERFACE + +PUBLIC :: dCopy_CompCol_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dCreate_Dense_Matrix(SuperMatrix *X, int m, int n, double *x, int ldx, +! Stype_t stype, Dtype_t dtype, Mtype_t mtype) +INTERFACE + SUBROUTINE dCreate_Dense_Matrix(A, m, n, x, ldx, stype, dtype, mtype) & + & BIND(C, name="dCreate_Dense_Matrix") + IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix + TYPE(SuperMatrix), INTENT(INOUT) :: A + INTEGER(C_INT), VALUE, INTENT(IN) :: m + INTEGER(C_INT), VALUE, INTENT(IN) :: n + REAL(C_DOUBLE), INTENT(INOUT) :: x(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: ldx + INTEGER(C_INT), VALUE, INTENT(IN) :: stype + INTEGER(C_INT), VALUE, INTENT(IN) :: dtype + INTEGER(C_INT), VALUE, INTENT(IN) :: mtype + END SUBROUTINE dCreate_Dense_Matrix +END INTERFACE + +PUBLIC :: dCreate_Dense_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dCopy_Dense_Matrix(int M, int N, double *X, int ldx, +! double *Y, int ldy) +! { +! /*! \brief Copies a two-dimensional matrix X to another matrix Y. +! */ + +INTERFACE + SUBROUTINE dCopy_Dense_Matrix(M, N, X, ldx, Y, ldy) & + & BIND(C, name="dCopy_Dense_Matrix") + IMPORT :: C_INT, C_DOUBLE + INTEGER(C_INT), VALUE, INTENT(IN) :: M + INTEGER(C_INT), VALUE, INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(IN) :: X(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: ldx + REAL(C_DOUBLE), INTENT(INOUT) :: Y(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: ldy + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dCreate_SuperNode_Matrix(SuperMatrix *L, int m, int n, int nnz, +! double *nzval, int *nzval_colptr, int *rowind, +! int *rowind_colptr, int *col_to_sup, int *sup_to_col, +! Stype_t stype, Dtype_t dtype, Mtype_t mtype) + +INTERFACE + SUBROUTINE dCreate_SuperNode_Matrix(L, m, n, nnz, nzval, nzval_colptr, & + & rowind, rowind_colptr, col_to_sup, sup_to_col, stype, dtype, mtype) & + & BIND(C, name="dCreate_SuperNode_Matrix") + IMPORT :: C_PTR, C_INT, C_DOUBLE, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(INOUT) :: L +#else + TYPE(SuperMatrix), INTENT(INOUT) :: L +#endif + INTEGER(C_INT), VALUE, INTENT(IN) :: m + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), VALUE, INTENT(IN) :: nnz + REAL(C_DOUBLE), INTENT(IN) :: nzval(*) + INTEGER(C_INT), INTENT(IN) :: nzval_colptr(*) + INTEGER(C_INT), INTENT(IN) :: rowind(*) + INTEGER(C_INT), INTENT(IN) :: rowind_colptr(*) + INTEGER(C_INT), INTENT(IN) :: col_to_sup(*) + INTEGER(C_INT), INTENT(IN) :: sup_to_col(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: stype + INTEGER(C_INT), VALUE, INTENT(IN) :: dtype + INTEGER(C_INT), VALUE, INTENT(IN) :: mtype + END SUBROUTINE dCreate_SuperNode_Matrix +END INTERFACE + +PUBLIC :: dCreate_SuperNode_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dCompRow_to_CompCol(int m, int n, int nnz, +! double *a, int *colind, int *rowptr, +! double **at, int **rowind, int **colptr) +! brief Convert a row compressed storage into a column +! compressed storage. + +INTERFACE + SUBROUTINE dCompRow_to_CompCol(m, n, nnz, a, colind, rowptr, & + & at, rowind, colptr) BIND(C, name="dCompRow_to_CompCol") + IMPORT :: C_INT, C_DOUBLE, C_PTR + INTEGER(C_INT), VALUE, INTENT(IN) :: m + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), VALUE, INTENT(IN) :: nnz + REAL(C_DOUBLE), INTENT(IN) :: a(*) + INTEGER(C_INT), INTENT(IN) :: colind(*) + INTEGER(C_INT), INTENT(IN) :: rowptr(*) + TYPE(C_PTR), INTENT(INOUT) :: at + TYPE(C_PTR), INTENT(INOUT) :: rowind + TYPE(C_PTR), INTENT(INOUT) :: colptr + END SUBROUTINE dCompRow_to_CompCol +END INTERFACE + +PUBLIC :: dCompRow_to_CompCol + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! dPrint_CompCol_Matrix(char *what, SuperMatrix *A) + +INTERFACE + SUBROUTINE dPrint_CompCol_Matrix(what, A) BIND(C, name="dPrint_CompCol_Matrix") + IMPORT :: C_PTR, C_CHAR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(IN) :: A +#else + TYPE(SuperMatrix), INTENT(IN) :: A +#endif + CHARACTER(1, kind=C_CHAR), INTENT(in) :: what(*) + END SUBROUTINE dPrint_CompCol_Matrix +END INTERFACE + +PUBLIC :: dPrint_CompCol_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dPrint_SuperNode_Matrix(char *what, SuperMatrix *A) + +INTERFACE + SUBROUTINE dPrint_SuperNode_Matrix(what, A) & + & BIND(C, name="dPrint_SuperNode_Matrix") + IMPORT :: C_PTR, C_CHAR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(IN) :: A +#else + TYPE(SuperMatrix), INTENT(IN) :: A +#endif + CHARACTER(1, kind=C_CHAR), INTENT(in) :: what(*) + END SUBROUTINE dPrint_SuperNode_Matrix +END INTERFACE + +PUBLIC :: dPrint_SuperNode_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dPrint_Dense_Matrix(char *what, SuperMatrix *A) + +INTERFACE + SUBROUTINE dPrint_Dense_Matrix(what, A) & + & BIND(C, name="dPrint_Dense_Matrix") + IMPORT :: C_PTR, C_CHAR, SuperMatrix +#ifdef SUPERLU_CPTR_ONLY + TYPE(C_PTR), INTENT(IN) :: A +#else + TYPE(SuperMatrix), INTENT(IN) :: A +#endif + CHARACTER(1, kind=C_CHAR), INTENT(in) :: what(*) + END SUBROUTINE dPrint_Dense_Matrix +END INTERFACE + +PUBLIC :: dPrint_Dense_Matrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! brief Diagnostic print of column "jcol" in the U/L factor. +! void +! dprint_lu_col(char *msg, int jcol, int pivrow, int *xprune, GlobalLU_t *Glu) + +INTERFACE + SUBROUTINE dprint_lu_col(msg, jcol, pivrow, xprune, Glu) & + & BIND(C, name="dprint_lu_col") + IMPORT :: C_CHAR, C_INT, C_PTR + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: msg + INTEGER(C_INT), VALUE, INTENT(IN) :: jcol + INTEGER(C_INT), VALUE, INTENT(IN) :: pivrow + INTEGER(C_INT), INTENT(IN) :: xprune(*) + TYPE(C_PTR), INTENT(IN) :: Glu + END SUBROUTINE dprint_lu_col +END INTERFACE + +PUBLIC :: dprint_lu_col + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! brief Check whether tempv[] == 0. This should be true before and +! after calling any numeric routines, i.e., "panel_bmod" and "column_bmod". +! void dcheck_tempv(int n, double *tempv) + +INTERFACE + SUBROUTINE dcheck_tempv(n, tempv) & + & BIND(C, name="dcheck_tempv") + IMPORT :: C_INT, C_DOUBLE + INTEGER(C_INT), VALUE, INTENT(IN) :: n + REAL(C_DOUBLE), INTENT(IN) :: tempv(*) + END SUBROUTINE dcheck_tempv +END INTERFACE + +PUBLIC :: dcheck_tempv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! void +! dGenXtrue(int n, int nrhs, double *x, int ldx) + +INTERFACE + SUBROUTINE dGenXtrue(n, nrhs, x, ldx) & + & BIND(C, name="dGenXtrue") + IMPORT :: C_INT, C_DOUBLE + INTEGER(C_INT), VALUE, INTENT(IN) :: n + INTEGER(C_INT), VALUE, INTENT(IN) :: nrhs + REAL(C_DOUBLE), INTENT(INOUT) :: x(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: ldx + END SUBROUTINE dGenXtrue +END INTERFACE + +PUBLIC :: dGenXtrue + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!brief Let rhs[i] = sum of i-th row of A, so the solution vector is all 1's +! void +! dFillRHS(trans_t trans, int nrhs, double *x, int ldx, +! SuperMatrix *A, SuperMatrix *B) + +INTERFACE + SUBROUTINE dFillRHS(trans, nrhs, x, ldx, A, B) & + & BIND(C, name="dFillRHS") + IMPORT :: C_INT, C_DOUBLE, SuperMatrix + INTEGER(C_INT), VALUE, INTENT(IN) :: trans + INTEGER(C_INT), VALUE, INTENT(IN) :: nrhs + REAL(C_DOUBLE), INTENT(INOUT) :: x(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: ldx + TYPE(SuperMatrix), INTENT(IN) :: A + TYPE(SuperMatrix), INTENT(IN) :: B + END SUBROUTINE dFillRHS +END INTERFACE + +PUBLIC :: dFillRHS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! ! \brief Fills a double precision array with a given value. +! void +! dfill(double *a, int alen, double dval) + +INTERFACE + SUBROUTINE dfill(a, alen, dval) & + & BIND(C, name="dfill") + IMPORT :: C_DOUBLE, C_INT + REAL(C_DOUBLE), INTENT(INOUT) :: a(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: alen + REAL(C_DOUBLE), VALUE, INTENT(IN) :: dval + END SUBROUTINE dfill +END INTERFACE + +PUBLIC :: dfill + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! brief Check the inf-norm of the error vector +! void dinf_norm_error(int nrhs, SuperMatrix *X, double *xtrue) + +INTERFACE + SUBROUTINE dinf_norm_error(nrhs, X, xtrue) & + & BIND(C, name="dinf_norm_error") + IMPORT :: C_INT, C_PTR, C_DOUBLE + INTEGER(C_INT), VALUE, INTENT(IN) :: nrhs + TYPE(C_PTR), INTENT(IN) :: X + REAL(C_DOUBLE), INTENT(IN) :: xtrue(*) + END SUBROUTINE dinf_norm_error +END INTERFACE + +PUBLIC :: dinf_norm_error + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! brief Print performance of the code. +! void +! dPrintPerf(SuperMatrix *L, SuperMatrix *U, mem_usage_t *mem_usage, +! double rpg, double rcond, double *ferr, +! double *berr, char *equed, SuperLUStat_t *stat) + +INTERFACE + SUBROUTINE dPrintPerf(L, U, mem_usage, rpg, rcond, ferr, & + & berr, equed, stat) & + & BIND(C, name="dPrintPerf") + IMPORT :: C_PTR, C_DOUBLE, C_CHAR + TYPE(C_PTR), INTENT(IN) :: L + TYPE(C_PTR), INTENT(IN) :: U + TYPE(C_PTR), INTENT(IN) :: mem_usage + REAL(C_DOUBLE), VALUE, INTENT(IN) :: rpg + REAL(C_DOUBLE), VALUE, INTENT(in) :: rcond + REAL(C_DOUBLE), INTENT(IN) :: ferr(*) + REAL(C_DOUBLE), INTENT(IN) :: berr(*) + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: equed(*) + TYPE(C_PTR), INTENT(IN) :: stat + END SUBROUTINE dPrintPerf +END INTERFACE + +PUBLIC :: dPrintPerf + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! int +! print_double_vec(char *what, int n, double *vec) + +INTERFACE + SUBROUTINE print_double_vec(what, n, vec) & + & BIND(C, name="print_double_vec") + IMPORT :: C_CHAR, C_INT, C_DOUBLE + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: what(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: n + REAL(C_DOUBLE), INTENT(IN) :: vec(*) + END SUBROUTINE print_double_vec +END INTERFACE + +PUBLIC :: print_double_vec + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! extern int dQuerySpace (SuperMatrix *, SuperMatrix *, mem_usage_t *); + +INTERFACE + SUBROUTINE dQuerySpace(A, B, mem) & + & BIND(C, name="dQuerySpace") + IMPORT :: SuperMatrix, mem_usage_t + TYPE(SuperMatrix), INTENT(in) :: A, B + TYPE(mem_usage_t), INTENT(in) :: mem + END SUBROUTINE dQuerySpace +END INTERFACE + +PUBLIC :: dQuerySpace + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SuperLU_dUtil_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 new file mode 100644 index 000000000..5387f5c5d --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgscon_Methods.F90 @@ -0,0 +1,95 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dgscon_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! * Purpose +! * ======= +! * +! * DGSCON estimates the reciprocal of the condition number of a general +! * real matrix A, in either the 1-norm or the infinity-norm, using +! * the LU factorization computed by DGETRF. * +! * +! * An estimate is obtained for norm(inv(A)), and the reciprocal of the +! * condition number is computed as +! * RCOND = 1 / ( norm(A) * norm(inv(A)) ). +! * +! * See supermatrix.h for the definition of 'SuperMatrix' structure. +! * +! * Arguments +! * ========= +! * +! * NORM (input) char* +! * Specifies whether the 1-norm condition number or the +! * infinity-norm condition number is required: +! * = '1' or 'O': 1-norm; +! * = 'I': Infinity-norm. +! * +! * L (input) SuperMatrix* +! * The factor L from the factorization Pr*A*Pc=L*U as computed by +! * dgstrf(). Use compressed row subscripts storage for supernodes, +! * i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. +! * +! * U (input) SuperMatrix* +! * The factor U from the factorization Pr*A*Pc=L*U as computed by +! * dgstrf(). Use column-wise storage scheme, i.e., U has types: +! * Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. +! * +! * ANORM (input) double +! * If NORM = '1' or 'O', the 1-norm of the original matrix A. +! * If NORM = 'I', the infinity-norm of the original matrix A. +! * +! * RCOND (output) double* +! * The reciprocal of the condition number of the matrix A, +! * computed as RCOND = 1/(norm(A) * norm(inv(A))). +! * +! * INFO (output) int* +! * = 0: successful exit +! * < 0: if INFO = -i, the i-th argument had an illegal value +! * +! * ===================================================================== + +! void +! dgscon(char *norm, SuperMatrix *L, SuperMatrix *U, +! double anorm, double *rcond, SuperLUStat_t *stat, int *info) + +INTERFACE + SUBROUTINE dgscon(norm, L, U, anorm, rcond, stat, info) & + & BIND(C, name="dgscon") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix, C_CHAR, C_DOUBLE + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: norm + TYPE(SuperMatrix), INTENT(INOUT) :: L + TYPE(SuperMatrix), INTENT(INOUT) :: U + REAL(C_DOUBLE), VALUE, INTENT(IN) :: anorm + REAL(C_DOUBLE), INTENT(INOUT) :: rcond + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + INTEGER(C_INT), INTENT(INOUT) :: info + END SUBROUTINE dgscon +END INTERFACE + +PUBLIC :: dgscon + +END MODULE SuperLU_dgscon_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 new file mode 100644 index 000000000..e66e057e2 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgsequ_Methods.F90 @@ -0,0 +1,108 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dgsequ_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! * Purpose +! * ======= +! * +! * DGSEQU computes row and column scalings intended to equilibrate an +! * M-by-N sparse matrix A and reduce its condition number. R returns the row +! * scale factors and C the column scale factors, chosen to try to make +! * the largest element in each row and column of the matrix B with +! * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. +! * +! * R(i) and C(j) are restricted to be between SMLNUM = smallest safe +! * number and BIGNUM = largest safe number. Use of these scaling +! * factors is not guaranteed to reduce the condition number of A but +! * works well in practice. +! * +! * See supermatrix.h for the definition of 'SuperMatrix' structure. +! * +! * Arguments +! * ========= +! * +! * A (input) SuperMatrix* +! * The matrix of dimension (A->nrow, A->ncol) whose equilibration +! * factors are to be computed. The type of A can be: +! * Stype = SLU_NC; Dtype = SLU_D; Mtype = SLU_GE. +! * +! * R (output) double*, size A->nrow +! * If INFO = 0 or INFO > M, R contains the row scale factors +! * for A. +! * +! * C (output) double*, size A->ncol +! * If INFO = 0, C contains the column scale factors for A. +! * +! * ROWCND (output) double* +! * If INFO = 0 or INFO > M, ROWCND contains the ratio of the +! * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +! * AMAX is neither too large nor too small, it is not worth +! * scaling by R. +! * +! * COLCND (output) double* +! * If INFO = 0, COLCND contains the ratio of the smallest +! * C(i) to the largest C(i). If COLCND >= 0.1, it is not +! * worth scaling by C. +! * +! * AMAX (output) double* +! * Absolute value of largest matrix element. If AMAX is very +! * close to overflow or very close to underflow, the matrix +! * should be scaled. +! * +! * INFO (output) int* +! * = 0: successful exit +! * < 0: if INFO = -i, the i-th argument had an illegal value +! * > 0: if INFO = i, and i is +! * <= A->nrow: the i-th row of A is exactly zero +! * > A->ncol: the (i-M)-th column of A is exactly zero +! * +! +! void +! dgsequ(SuperMatrix *A, double *r, double *c, double *rowcnd, +! double *colcnd, double *amax, int *info) + +INTERFACE + SUBROUTINE dgsequ(A, r, c, rowcnd, colcnd, amax, info)& + & BIND(C, name="dgsequ") + IMPORT :: SuperMatrix, C_DOUBLE, C_INT + + TYPE(SuperMatrix), INTENT(INOUT) :: A + REAL(C_DOUBLE), INTENT(INOUT) :: r(*) + REAL(C_DOUBLE), INTENT(INOUT) :: c(*) + REAL(C_DOUBLE), INTENT(INOUT) :: rowcnd + REAL(C_DOUBLE), INTENT(INOUT) :: colcnd + REAL(C_DOUBLE), INTENT(INOUT) :: amax + INTEGER(C_INT), INTENT(inout) :: info + END SUBROUTINE dgsequ +END INTERFACE + +PUBLIC :: dgsequ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SuperLU_dgsequ_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 new file mode 100644 index 000000000..040c8d2ba --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgsisx_Methods.F90 @@ -0,0 +1,446 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dgsisx_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +! +! +! * Purpose +! * ======= +! * +! * DGSISX computes an approximate solutions of linear equations +! * A*X=B or A'*X=B, using the ILU factorization from dgsitrf(). +! * An estimation of the condition number is provided. +! * The routine performs the following steps: +! * +! * 1. If A is stored column-wise (A->Stype = SLU_NC): +! * +! * 1.1. If options->Equil = YES or options->RowPerm = LargeDiag_MC64, scaling +! * factors are computed to equilibrate the system: +! * options->Trans = NOTRANS: +! * diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +! * options->Trans = TRANS: +! * (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +! * options->Trans = CONJ: +! * (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +! * Whether or not the system will be equilibrated depends on the +! * scaling of the matrix A, but if equilibration is used, A is +! * overwritten by diag(R)*A*diag(C) and B by diag(R)*B +! * (if options->Trans=NOTRANS) or diag(C)*B (if options->Trans +! * = TRANS or CONJ). +! * +! * 1.2. Permute columns of A, forming A*Pc, where Pc is a permutation +! * matrix that usually preserves sparsity. +! * For more details of this step, see sp_preorder.c. +! * +! * 1.3. If options->Fact != FACTORED, the LU decomposition is used to +! * factor the matrix A (after equilibration if options->Equil = YES) +! * as Pr*A*Pc = L*U, with Pr determined by partial pivoting. +! * +! * 1.4. Compute the reciprocal pivot growth factor. +! * +! * 1.5. If some U(i,i) = 0, so that U is exactly singular, then the +! * routine fills a small number on the diagonal entry, that is +! * U(i,i) = ||A(:,i)||_oo * options->ILU_FillTol ** (1 - i / n), +! * and info will be increased by 1. The factored form of A is used +! * to estimate the condition number of the preconditioner. If the +! * reciprocal of the condition number is less than machine precision, +! * info = A->ncol+1 is returned as a warning, but the routine still +! * goes on to solve for X. +! * +! * 1.6. The system of equations is solved for X using the factored form +! * of A. +! * +! * 1.7. options->IterRefine is not used +! * +! * 1.8. If equilibration was used, the matrix X is premultiplied by +! * diag(C) (if options->Trans = NOTRANS) or diag(R) +! * (if options->Trans = TRANS or CONJ) so that it solves the +! * original system before equilibration. +! * +! * 1.9. options for ILU only +! * 1) If options->RowPerm = LargeDiag_MC64, MC64 is used to scale and +! * permute the matrix to an I-matrix, that is Pr*Dr*A*Dc has +! * entries of modulus 1 on the diagonal and off-diagonal entries +! * of modulus at most 1. If MC64 fails, dgsequ() is used to +! * equilibrate the system. +! * ( Default: LargeDiag_MC64 ) +! * 2) options->ILU_DropTol = tau is the threshold for dropping. +! * For L, it is used directly (for the whole row in a supernode); +! * For U, ||A(:,i)||_oo * tau is used as the threshold +! * for the i-th column. +! * If a secondary dropping rule is required, tau will +! * also be used to compute the second threshold. +! * ( Default: 1e-4 ) +! * 3) options->ILU_FillFactor = gamma, used as the initial guess +! * of memory growth. +! * If a secondary dropping rule is required, it will also +! * be used as an upper bound of the memory. +! * ( Default: 10 ) +! * 4) options->ILU_DropRule specifies the dropping rule. +! * Option Meaning +! * ====== =========== +! * DROP_BASIC: Basic dropping rule, supernodal based ILUTP(tau). +! * DROP_PROWS: Supernodal based ILUTP(p,tau), p = gamma*nnz(A)/n. +! * DROP_COLUMN: Variant of ILUTP(p,tau), for j-th column, +! * p = gamma * nnz(A(:,j)). +! * DROP_AREA: Variation of ILUTP, for j-th column, use +! * nnz(F(:,1:j)) / nnz(A(:,1:j)) to control memory. +! * DROP_DYNAMIC: Modify the threshold tau during factorizaion: +! * If nnz(L(:,1:j)) / nnz(A(:,1:j)) > gamma +! * tau_L(j) := MIN(tau_0, tau_L(j-1) * 2); +! * Otherwise +! * tau_L(j) := MAX(tau_0, tau_L(j-1) / 2); +! * tau_U(j) uses the similar rule. +! * NOTE: the thresholds used by L and U are separate. +! * DROP_INTERP: Compute the second dropping threshold by +! * interpolation instead of sorting (default). +! * In this case, the actual fill ratio is not +! * guaranteed smaller than gamma. +! * DROP_PROWS, DROP_COLUMN and DROP_AREA are mutually exclusive. +! * ( Default: DROP_BASIC | DROP_AREA ) +! * 5) options->ILU_Norm is the criterion of measuring the magnitude +! * of a row in a supernode of L. ( Default is INF_NORM ) +! * options->ILU_Norm RowSize(x[1:n]) +! * ================= =============== +! * ONE_NORM ||x||_1 / n +! * TWO_NORM ||x||_2 / sqrt(n) +! * INF_NORM max{|x[i]|} +! * 6) options->ILU_MILU specifies the type of MILU's variation. +! * = SILU: do not perform Modified ILU; +! * = SMILU_1 (not recommended): +! * U(i,i) := U(i,i) + sum(dropped entries); +! * = SMILU_2: +! * U(i,i) := U(i,i) + SGN(U(i,i)) * sum(dropped entries); +! * = SMILU_3: +! * U(i,i) := U(i,i) + SGN(U(i,i)) * sum(|dropped entries|); +! * NOTE: Even SMILU_1 does not preserve the column sum because of +! * late dropping. +! * ( Default: SILU ) +! * 7) options->ILU_FillTol is used as the perturbation when +! * encountering zero pivots. If some U(i,i) = 0, so that U is +! * exactly singular, then +! * U(i,i) := ||A(:,i)|| * options->ILU_FillTol ** (1 - i / n). +! * ( Default: 1e-2 ) +! * +! * 2. If A is stored row-wise (A->Stype = SLU_NR), apply the above algorithm +! * to the transpose of A: +! * +! * 2.1. If options->Equil = YES or options->RowPerm = LargeDiag_MC64, scaling +! * factors are computed to equilibrate the system: +! * options->Trans = NOTRANS: +! * diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +! * options->Trans = TRANS: +! * (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +! * options->Trans = CONJ: +! * (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +! * Whether or not the system will be equilibrated depends on the +! * scaling of the matrix A, but if equilibration is used, A' is +! * overwritten by diag(R)*A'*diag(C) and B by diag(R)*B +! * (if trans='N') or diag(C)*B (if trans = 'T' or 'C'). +! * +! * 2.2. Permute columns of transpose(A) (rows of A), +! * forming transpose(A)*Pc, where Pc is a permutation matrix that +! * usually preserves sparsity. +! * For more details of this step, see sp_preorder.c. +! * +! * 2.3. If options->Fact != FACTORED, the LU decomposition is used to +! * factor the transpose(A) (after equilibration if +! * options->Fact = YES) as Pr*transpose(A)*Pc = L*U with the +! * permutation Pr determined by partial pivoting. +! * +! * 2.4. Compute the reciprocal pivot growth factor. +! * +! * 2.5. If some U(i,i) = 0, so that U is exactly singular, then the +! * routine fills a small number on the diagonal entry, that is +! * U(i,i) = ||A(:,i)||_oo * options->ILU_FillTol ** (1 - i / n). +! * And info will be increased by 1. The factored form of A is used +! * to estimate the condition number of the preconditioner. If the +! * reciprocal of the condition number is less than machine precision, +! * info = A->ncol+1 is returned as a warning, but the routine still +! * goes on to solve for X. +! * +! * 2.6. The system of equations is solved for X using the factored form +! * of transpose(A). +! * +! * 2.7. If options->IterRefine is not used. +! * +! * 2.8. If equilibration was used, the matrix X is premultiplied by +! * diag(C) (if options->Trans = NOTRANS) or diag(R) +! * (if options->Trans = TRANS or CONJ) so that it solves the +! * original system before equilibration. +! * +! * See supermatrix.h for the definition of 'SuperMatrix' structure. +! * +! * Arguments +! * ========= +! * +! * options (input) superlu_options_t* +! * The structure defines the input parameters to control +! * how the LU decomposition will be performed and how the +! * system will be solved. +! * +! * A (input/output) SuperMatrix* +! * Matrix A in A*X=B, of dimension (A->nrow, A->ncol). The number +! * of the linear equations is A->nrow. Currently, the type of A can be: +! * Stype = SLU_NC or SLU_NR, Dtype = SLU_D, Mtype = SLU_GE. +! * In the future, more general A may be handled. +! * +! * On entry, If options->Fact = FACTORED and equed is not 'N', +! * then A must have been equilibrated by the scaling factors in +! * R and/or C. +! * On exit, A is not modified +! * if options->Equil = NO, or +! * if options->Equil = YES but equed = 'N' on exit, or +! * if options->RowPerm = NO. +! * +! * Otherwise, if options->Equil = YES and equed is not 'N', +! * A is scaled as follows: +! * If A->Stype = SLU_NC: +! * equed = 'R': A := diag(R) * A +! * equed = 'C': A := A * diag(C) +! * equed = 'B': A := diag(R) * A * diag(C). +! * If A->Stype = SLU_NR: +! * equed = 'R': transpose(A) := diag(R) * transpose(A) +! * equed = 'C': transpose(A) := transpose(A) * diag(C) +! * equed = 'B': transpose(A) := diag(R) * transpose(A) * diag(C). +! * +! * If options->RowPerm = LargeDiag_MC64, MC64 is used to scale and permute +! * the matrix to an I-matrix, that is A is modified as follows: +! * P*Dr*A*Dc has entries of modulus 1 on the diagonal and +! * off-diagonal entries of modulus at most 1. P is a permutation +! * obtained from MC64. +! * If MC64 fails, dgsequ() is used to equilibrate the system, +! * and A is scaled as above, but no permutation is involved. +! * On exit, A is restored to the orginal row numbering, so +! * Dr*A*Dc is returned. +! * +! * perm_c (input/output) int* +! * If A->Stype = SLU_NC, Column permutation vector of size A->ncol, +! * which defines the permutation matrix Pc; perm_c[i] = j means +! * column i of A is in position j in A*Pc. +! * On exit, perm_c may be overwritten by the product of the input +! * perm_c and a permutation that postorders the elimination tree +! * of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree +! * is already in postorder. +! * +! * If A->Stype = SLU_NR, column permutation vector of size A->nrow, +! * which describes permutation of columns of transpose(A) +! * (rows of A) as described above. +! * +! * perm_r (input/output) int* +! * If A->Stype = SLU_NC, row permutation vector of size A->nrow, +! * which defines the permutation matrix Pr, and is determined +! * by MC64 first then followed by partial pivoting. +! * perm_r[i] = j means row i of A is in position j in Pr*A. +! * +! * If A->Stype = SLU_NR, permutation vector of size A->ncol, which +! * determines permutation of rows of transpose(A) +! * (columns of A) as described above. +! * +! * If options->Fact = SamePattern_SameRowPerm, the pivoting routine +! * will try to use the input perm_r, unless a certain threshold +! * criterion is violated. In that case, perm_r is overwritten by a +! * new permutation determined by partial pivoting or diagonal +! * threshold pivoting. +! * Otherwise, perm_r is output argument. +! * +! * etree (input/output) int*, dimension (A->ncol) +! * Elimination tree of Pc'*A'*A*Pc. +! * If options->Fact != FACTORED and options->Fact != DOFACT, +! * etree is an input argument, otherwise it is an output argument. +! * Note: etree is a vector of parent pointers for a forest whose +! * vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. +! * +! * equed (input/output) char* +! * Specifies the form of equilibration that was done. +! * = 'N': No equilibration. +! * = 'R': Row equilibration, i.e., A was premultiplied by diag(R). +! * = 'C': Column equilibration, i.e., A was postmultiplied by diag(C). +! * = 'B': Both row and column equilibration, i.e., A was replaced +! * by diag(R)*A*diag(C). +! * If options->Fact = FACTORED, equed is an input argument, +! * otherwise it is an output argument. +! * +! * R (input/output) double*, dimension (A->nrow) +! * The row scale factors for A or transpose(A). +! * If equed = 'R' or 'B', A (if A->Stype = SLU_NC) or transpose(A) +! * (if A->Stype = SLU_NR) is multiplied on the left by diag(R). +! * If equed = 'N' or 'C', R is not accessed. +! * If options->Fact = FACTORED, R is an input argument, +! * otherwise, R is output. +! * If options->Fact = FACTORED and equed = 'R' or 'B', each element +! * of R must be positive. +! * +! * C (input/output) double*, dimension (A->ncol) +! * The column scale factors for A or transpose(A). +! * If equed = 'C' or 'B', A (if A->Stype = SLU_NC) or transpose(A) +! * (if A->Stype = SLU_NR) is multiplied on the right by diag(C). +! * If equed = 'N' or 'R', C is not accessed. +! * If options->Fact = FACTORED, C is an input argument, +! * otherwise, C is output. +! * If options->Fact = FACTORED and equed = 'C' or 'B', each element +! * of C must be positive. +! * +! * L (output) SuperMatrix* +! * The factor L from the factorization +! * Pr*A*Pc=L*U (if A->Stype SLU_= NC) or +! * Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). +! * Uses compressed row subscripts storage for supernodes, i.e., +! * L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. +! * +! * U (output) SuperMatrix* +! * The factor U from the factorization +! * Pr*A*Pc=L*U (if A->Stype = SLU_NC) or +! * Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). +! * Uses column-wise storage scheme, i.e., U has types: +! * Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. +! * +! * work (workspace/output) void*, size (lwork) (in bytes) +! * User supplied workspace, should be large enough +! * to hold data structures for factors L and U. +! * On exit, if fact is not 'F', L and U point to this array. +! * +! * lwork (input) int +! * Specifies the size of work array in bytes. +! * = 0: allocate space internally by system malloc; +! * > 0: use user-supplied work array of length lwork in bytes, +! * returns error if space runs out. +! * = -1: the routine guesses the amount of space needed without +! * performing the factorization, and returns it in +! * mem_usage->total_needed; no other side effects. +! * +! * See argument 'mem_usage' for memory usage statistics. +! * +! * B (input/output) SuperMatrix* +! * B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. +! * On entry, the right hand side matrix. +! * If B->ncol = 0, only LU decomposition is performed, the triangular +! * solve is skipped. +! * On exit, +! * if equed = 'N', B is not modified; otherwise +! * if A->Stype = SLU_NC: +! * if options->Trans = NOTRANS and equed = 'R' or 'B', +! * B is overwritten by diag(R)*B; +! * if options->Trans = TRANS or CONJ and equed = 'C' of 'B', +! * B is overwritten by diag(C)*B; +! * if A->Stype = SLU_NR: +! * if options->Trans = NOTRANS and equed = 'C' or 'B', +! * B is overwritten by diag(C)*B; +! * if options->Trans = TRANS or CONJ and equed = 'R' of 'B', +! * B is overwritten by diag(R)*B. +! * +! * X (output) SuperMatrix* +! * X has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. +! * If info = 0 or info = A->ncol+1, X contains the solution matrix +! * to the original system of equations. Note that A and B are modified +! * on exit if equed is not 'N', and the solution to the equilibrated +! * system is inv(diag(C))*X if options->Trans = NOTRANS and +! * equed = 'C' or 'B', or inv(diag(R))*X if options->Trans = 'T' or 'C' +! * and equed = 'R' or 'B'. +! * +! * recip_pivot_growth (output) double* +! * The reciprocal pivot growth factor max_j( norm(A_j)/norm(U_j) ). +! * The infinity norm is used. If recip_pivot_growth is much less +! * than 1, the stability of the LU factorization could be poor. +! * +! * rcond (output) double* +! * The estimate of the reciprocal condition number of the matrix A +! * after equilibration (if done). If rcond is less than the machine +! * precision (in particular, if rcond = 0), the matrix is singular +! * to working precision. This condition is indicated by a return +! * code of info > 0. +! * +! * mem_usage (output) mem_usage_t* +! * Record the memory usage statistics, consisting of following fields: +! * - for_lu (float) +! * The amount of space used in bytes for L\U data structures. +! * - total_needed (float) +! * The amount of space needed in bytes to perform factorization. +! * - expansions (int) +! * The number of memory expansions during the LU factorization. +! * +! * stat (output) SuperLUStat_t* +! * Record the statistics on runtime and floating-point operation count. +! * See slu_util.h for the definition of 'SuperLUStat_t'. +! * +! * info (output) int* +! * = 0: successful exit +! * < 0: if info = -i, the i-th argument had an illegal value +! * > 0: if info = i, and i is +! * <= A->ncol: number of zero pivots. They are replaced by small +! * entries due to options->ILU_FillTol. +! * = A->ncol+1: U is nonsingular, but RCOND is less than machine +! * precision, meaning that the matrix is singular to +! * working precision. Nevertheless, the solution and +! * error bounds are computed because there are a number +! * of situations where the computed solution can be more +! * accurate than the value of RCOND would suggest. +! * > A->ncol+1: number of bytes allocated when memory allocation +! * failure occurred, plus A->ncol. +! * +! */ +! +! void +! dgsisx(superlu_options_t *options, SuperMatrix *A, int *perm_c, int *perm_r, +! int *etree, char *equed, double *R, double *C, +! SuperMatrix *L, SuperMatrix *U, void *work, int lwork, +! SuperMatrix *B, SuperMatrix *X, +! double *recip_pivot_growth, double *rcond, +! GlobalLU_t *Glu, mem_usage_t *mem_usage, SuperLUStat_t *stat, int *info) + +INTERFACE + SUBROUTINE dgsisx(options, A, perm_c, perm_r, etree, & + & equed, R, C, L, U, work, lwork, B, X, recip_pivot_growth, & + & rcond, Glu, mem_usage, stat, info) & + & BIND(C, name="dgsisx") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix, GlobalLU_t, C_CHAR, C_DOUBLE, mem_usage_t + ! + TYPE(superlu_options_t), INTENT(IN) :: options + TYPE(SuperMatrix), INTENT(INOUT) :: A + INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) + INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) + INTEGER(C_INT), INTENT(INOUT) :: etree(*) + CHARACTER(1, kind=C_CHAR), INTENT(IN) :: equed + REAL(C_DOUBLE), INTENT(INOUT) :: R(*) + REAL(C_DOUBLE), INTENT(INOUT) :: C(*) + TYPE(SuperMatrix), INTENT(INOUT) :: L + TYPE(SuperMatrix), INTENT(INOUT) :: U + TYPE(C_PTR), INTENT(inout) :: work + INTEGER(C_INT), VALUE, INTENT(IN) :: lwork + TYPE(SuperMatrix), INTENT(INOUT) :: B + TYPE(SuperMatrix), INTENT(INOUT) :: X + REAL(C_DOUBLE), INTENT(INOUT) :: recip_pivot_growth + REAL(C_DOUBLE), INTENT(INOUT) :: rcond + TYPE(GlobalLU_t), INTENT(inout) :: Glu + TYPE(mem_usage_t), INTENT(INOUT) :: mem_usage + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + INTEGER(C_INT), INTENT(INOUT) :: info + END SUBROUTINE dgsisx +END INTERFACE + +PUBLIC :: dgsisx + +END MODULE SuperLU_dgsisx_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsitrf_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsitrf_Methods.F90 new file mode 100644 index 000000000..ecee97e3a --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgsitrf_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 +! + +MODULE SuperLU_dgsitrf_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +! +! +! DGSITRF computes an ILU factorization of a general sparse m-by-n +! matrix A using partial pivoting with row interchanges. +! The factorization has the form +! Pr * A = L * U +! where Pr is a row permutation matrix, L is lower triangular with unit +! diagonal elements (lower trapezoidal if A->nrow > A->ncol), and U is upper +! triangular (upper trapezoidal if A->nrow < A->ncol). +! +! See supermatrix.h for the definition of 'SuperMatrix' structure. +! +! ====================================================================== +! +! Local Working Arrays: +! ====================== +! m = number of rows in the matrix +! n = number of columns in the matrix +! +! marker[0:3*m-1]: marker[i] = j means that node i has been +! reached when working on column j. +! Storage: relative to original row subscripts +! NOTE: There are 4 of them: +! marker/marker1 are used for panel dfs, see (ilu_)dpanel_dfs.c; +! marker2 is used for inner-factorization, see (ilu)_dcolumn_dfs.c; +! marker_relax(has its own space) is used for relaxed supernodes. +! +! parent[0:m-1]: parent vector used during dfs +! Storage: relative to new row subscripts +! +! xplore[0:m-1]: xplore[i] gives the location of the next (dfs) +! unexplored neighbor of i in lsub[*] +! +! segrep[0:nseg-1]: contains the list of supernodal representatives +! in topological order of the dfs. A supernode representative is the +! last column of a supernode. +! The maximum size of segrep[] is n. +! +! repfnz[0:W*m-1]: for a nonzero segment U[*,j] that ends at a +! supernodal representative r, repfnz[r] is the location of the first +! nonzero in this segment. It is also used during the dfs: repfnz[r]>0 +! indicates the supernode r has been explored. +! NOTE: There are W of them, each used for one column of a panel. +! +! panel_lsub[0:W*m-1]: temporary for the nonzeros row indices below +! the panel diagonal. These are filled in during dpanel_dfs(), and are +! used later in the inner LU factorization within the panel. +! panel_lsub[]/dense[] pair forms the SPA data structure. +! NOTE: There are W of them. +! +! dense[0:W*m-1]: sparse accumulating (SPA) vector for intermediate values; +! NOTE: there are W of them. +! +! tempv[0:*]: real temporary used for dense numeric kernels; +! The size of this array is defined by NUM_TEMPV() in slu_util.h. +! It is also used by the dropping routine ilu_ddrop_row(). +! +! void +! dgsitrf(superlu_options_t *options, SuperMatrix *A, int relax, int panel_size, +! int *etree, void *work, int lwork, int *perm_c, int *perm_r, +! SuperMatrix *L, SuperMatrix *U, +! GlobalLU_t *Glu, /* persistent to facilitate multiple factorizations */ +! SuperLUStat_t *stat, int *info) + +INTERFACE + SUBROUTINE dgsitrf(options, A, relax, panel_size, etree, & + & work, lwork, perm_c, perm_r, & + & L, U, & + & Glu, stat, info) & + & BIND(C, name="dgsitrf") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix, GlobalLU_t, C_CHAR, C_DOUBLE + ! + TYPE(superlu_options_t), INTENT(IN) :: options + ! options (input) superlu_options_t* + ! The structure defines the input parameters to control + ! how the ILU decomposition will be performed. + TYPE(SuperMatrix), INTENT(INOUT) :: A + ! A (input) SuperMatrix* + ! Original matrix A, permuted by columns, of dimension + ! (A->nrow, A->ncol). The type of A can be: + ! Stype = SLU_NCP; Dtype = SLU_D; Mtype = SLU_GE. + INTEGER(C_INT), VALUE, INTENT(IN) :: relax + ! relax (input) int + ! To control degree of relaxing supernodes. If the number + ! of nodes (columns) in a subtree of the elimination tree is less + ! than relax, this subtree is considered as one supernode, + ! regardless of the row structures of those columns. + INTEGER(C_INT), VALUE, INTENT(IN) :: panel_size + ! panel_size (input) int + ! A panel consists of at most panel_size consecutive columns. + INTEGER(C_INT), INTENT(INOUT) :: etree(*) + ! etree (input) int*, dimension (A->ncol) + ! Elimination tree of A'*A. + ! Note: etree is a vector of parent pointers for a forest whose + ! vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. + ! On input, the columns of A should be permuted so that the + ! etree is in a certain postorder. + TYPE(C_PTR), INTENT(inout) :: work + ! work (input/output) void*, size (lwork) (in bytes) + ! User-supplied work space and space for the output data structures. + ! Not referenced if lwork = 0; + INTEGER(C_INT), VALUE, INTENT(IN) :: lwork + ! lwork (input) int + ! Specifies the size of work array in bytes. + ! = 0: allocate space internally by system malloc; + ! > 0: use user-supplied work array of length lwork in bytes, + ! returns error if space runs out. + ! = -1: the routine guesses the amount of space needed without + ! performing the factorization, and returns it in + ! *info; no other side effects. + INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) + ! perm_c (input) int*, dimension (A->ncol) + ! Column permutation vector, which defines the + ! permutation matrix Pc; perm_c[i] = j means column i of A is + ! in position j in A*Pc. + ! When searching for diagonal, perm_c[*] is applied to the + ! row subscripts of A, so that diagonal threshold pivoting + ! can find the diagonal of A, rather than that of A*Pc. + INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) + ! perm_r (input/output) int*, dimension (A->nrow) + ! Row permutation vector which defines the permutation matrix Pr, + ! perm_r[i] = j means row i of A is in position j in Pr*A. + ! If options->Fact = SamePattern_SameRowPerm, the pivoting routine + ! will try to use the input perm_r, unless a certain threshold + ! criterion is violated. In that case, perm_r is overwritten by + ! a new permutation determined by partial pivoting or diagonal + ! threshold pivoting. + ! Otherwise, perm_r is output argument; + TYPE(SuperMatrix), INTENT(INOUT) :: L + ! L (output) SuperMatrix* + ! The factor L from the factorization Pr*A=L*U; use compressed row + ! subscripts storage for supernodes, i.e., L has type: + ! Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. + TYPE(SuperMatrix), INTENT(INOUT) :: U + ! U (output) SuperMatrix* + ! The factor U from the factorization Pr*A*Pc=L*U. Use column-wise + ! storage scheme, i.e., U has types: Stype = SLU_NC, + ! Dtype = SLU_D, Mtype = SLU_TRU. + TYPE(GlobalLU_t), INTENT(inout) :: Glu + ! Glu (input/output) GlobalLU_t * + ! If options->Fact == SamePattern_SameRowPerm, it is an input; + ! The matrix A will be factorized assuming that a + ! factorization of a matrix with the same sparsity pattern + ! and similar numerical values was performed prior to this one. + ! Therefore, this factorization will reuse both row and column + ! scaling factors R and C, both row and column permutation + ! vectors perm_r and perm_c, and the L & U data structures + ! set up from the previous factorization. + ! Otherwise, it is an output. + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + ! stat (output) SuperLUStat_t* + ! Record the statistics on runtime and floating-point operation count. + ! See slu_util.h for the definition of 'SuperLUStat_t'. + INTEGER(C_INT), INTENT(INOUT) :: info + ! info (output) int* + ! = 0: successful exit + ! < 0: if info = -i, the i-th argument had an illegal value + ! > 0: if info = i, and i is + ! <= A->ncol: number of zero pivots. They are replaced by small + ! entries according to options->ILU_FillTol. + ! > A->ncol: number of bytes allocated when memory allocation + ! failure occurred, plus A->ncol. If lwork = -1, it is + ! the estimated amount of space needed, plus A->ncol. + END SUBROUTINE dgsitrf +END INTERFACE + +PUBLIC :: dgsitrf + +END MODULE SuperLU_dgsitrf_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 new file mode 100644 index 000000000..f158aa7d7 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgsrfs_Methods.F90 @@ -0,0 +1,165 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dgsrfs_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! * Purpose +! * ======= +! * +! * DGSRFS improves the computed solution to a system of linear +! * equations and provides error bounds and backward error estimates for +! * the solution. +! * +! * If equilibration was performed, the system becomes: +! * (diag(R)*A_original*diag(C)) * X = diag(R)*B_original. +! * +! * See supermatrix.h for the definition of 'SuperMatrix' structure. +! * +! * Arguments +! * ========= +! * +! * trans (input) trans_t +! * Specifies the form of the system of equations: +! * = NOTRANS: A * X = B (No transpose) +! * = TRANS: A'* X = B (Transpose) +! * = CONJ: A**H * X = B (Conjugate transpose) +! * +! * A (input) SuperMatrix* +! * The original matrix A in the system, or the scaled A if +! * equilibration was done. The type of A can be: +! * Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_GE. +! * +! * L (input) SuperMatrix* +! * The factor L from the factorization Pr*A*Pc=L*U. Use +! * compressed row subscripts storage for supernodes, +! * i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. +! * +! * U (input) SuperMatrix* +! * The factor U from the factorization Pr*A*Pc=L*U as computed by +! * dgstrf(). Use column-wise storage scheme, +! * i.e., U has types: Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. +! * +! * perm_c (input) int*, dimension (A->ncol) +! * Column permutation vector, which defines the +! * permutation matrix Pc; perm_c[i] = j means column i of A is +! * in position j in A*Pc. +! * +! * perm_r (input) int*, dimension (A->nrow) +! * Row permutation vector, which defines the permutation matrix Pr; +! * perm_r[i] = j means row i of A is in position j in Pr*A. +! * +! * equed (input) Specifies the form of equilibration that was done. +! * = 'N': No equilibration. +! * = 'R': Row equilibration, i.e., A was premultiplied by diag(R). +! * = 'C': Column equilibration, i.e., A was postmultiplied by +! * diag(C). +! * = 'B': Both row and column equilibration, i.e., A was replaced +! * by diag(R)*A*diag(C). +! * +! * R (input) double*, dimension (A->nrow) +! * The row scale factors for A. +! * If equed = 'R' or 'B', A is premultiplied by diag(R). +! * If equed = 'N' or 'C', R is not accessed. +! * +! * C (input) double*, dimension (A->ncol) +! * The column scale factors for A. +! * If equed = 'C' or 'B', A is postmultiplied by diag(C). +! * If equed = 'N' or 'R', C is not accessed. +! * +! * B (input) SuperMatrix* +! * B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. +! * The right hand side matrix B. +! * if equed = 'R' or 'B', B is premultiplied by diag(R). +! * +! * X (input/output) SuperMatrix* +! * X has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. +! * On entry, the solution matrix X, as computed by dgstrs(). +! * On exit, the improved solution matrix X. +! * if *equed = 'C' or 'B', X should be premultiplied by diag(C) +! * in order to obtain the solution to the original system. +! * +! * FERR (output) double*, dimension (B->ncol) +! * The estimated forward error bound for each solution vector +! * X(j) (the j-th column of the solution matrix X). +! * If XTRUE is the true solution corresponding to X(j), FERR(j) +! * is an estimated upper bound for the magnitude of the largest +! * element in (X(j) - XTRUE) divided by the magnitude of the +! * largest element in X(j). The estimate is as reliable as +! * the estimate for RCOND, and is almost always a slight +! * overestimate of the true error. +! * +! * BERR (output) double*, dimension (B->ncol) +! * The componentwise relative backward error of each solution +! * vector X(j) (i.e., the smallest relative change in +! * any element of A or B that makes X(j) an exact solution). +! * +! * stat (output) SuperLUStat_t* +! * Record the statistics on runtime and floating-point operation count. +! * See util.h for the definition of 'SuperLUStat_t'. +! * +! * info (output) int* +! * = 0: successful exit +! * < 0: if INFO = -i, the i-th argument had an illegal value +! * +! * Internal Parameters +! * =================== +! * +! * ITMAX is the maximum number of steps of iterative refinement. +! * +! void +! dgsrfs(trans_t trans, SuperMatrix *A, SuperMatrix *L, SuperMatrix *U, +! int *perm_c, int *perm_r, char *equed, double *R, double *C, +! SuperMatrix *B, SuperMatrix *X, double *ferr, double *berr, +! SuperLUStat_t *stat, int *info) + +INTERFACE + SUBROUTINE dgsrfs(trans, A, L, U, perm_c, perm_r, & + & equed, R, C, B, X, ferr, berr, & + & stat, info) & + & BIND(C, name="dgsrfs") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix, GlobalLU_t, mem_usage_t, C_CHAR, C_DOUBLE + ! + INTEGER(C_INT), VALUE, INTENT(IN) :: trans + TYPE(SuperMatrix), INTENT(INOUT) :: A + TYPE(SuperMatrix), INTENT(INOUT) :: L + TYPE(SuperMatrix), INTENT(INOUT) :: U + INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) + INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) + CHARACTER(1, kind=C_CHAR), INTENT(inout) :: equed(*) + REAL(C_DOUBLE), INTENT(inout) :: R(*) + REAL(C_DOUBLE), INTENT(inout) :: C(*) + TYPE(SuperMatrix), INTENT(INOUT) :: B + TYPE(SuperMatrix), INTENT(INOUT) :: X + REAL(C_DOUBLE), INTENT(inout) :: ferr(*) + REAL(C_DOUBLE), INTENT(inout) :: berr(*) + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + INTEGER(C_INT), INTENT(INOUT) :: info + END SUBROUTINE dgsrfs +END INTERFACE + +PUBLIC :: dgsrfs + +END MODULE SuperLU_dgsrfs_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 new file mode 100644 index 000000000..6a8d413e0 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgssv_Methods.F90 @@ -0,0 +1,150 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dgssv_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +! +! DGSSV solves the system of linear equations A*X=B, using the +! LU factorization from DGSTRF. It performs the following steps: +! +! 1. If A is stored column-wise (A->Stype = SLU_NC): +! +! 1.1. Permute the columns of A, forming A*Pc, where Pc +! is a permutation matrix. For more details of this step, +! see sp_preorder.c. +! +! 1.2. Factor A as Pr*A*Pc=L*U with the permutation Pr determined +! by Gaussian elimination with partial pivoting. +! L is unit lower triangular with offdiagonal entries +! bounded by 1 in magnitude, and U is upper triangular. +! +! 1.3. Solve the system of equations A*X=B using the factored +! form of A. +! +! 2. If A is stored row-wise (A->Stype = SLU_NR), apply the +! above algorithm to the transpose of A: +! +! 2.1. Permute columns of transpose(A) (rows of A), +! forming transpose(A)*Pc, where Pc is a permutation matrix. +! For more details of this step, see sp_preorder.c. +! +! 2.2. Factor A as Pr*transpose(A)*Pc=L*U with the permutation Pr +! determined by Gaussian elimination with partial pivoting. +! L is unit lower triangular with offdiagonal entries +! bounded by 1 in magnitude, and U is upper triangular. +! +! 2.3. Solve the system of equations A*X=B using the factored +! form of A. +! +! See supermatrix.h for the definition of 'SuperMatrix' structure. +! +! void +! dgssv(superlu_options_t *options, SuperMatrix *A, int *perm_c, int *perm_r, +! SuperMatrix *L, SuperMatrix *U, SuperMatrix *B, +! SuperLUStat_t *stat, int *info ) + +INTERFACE + SUBROUTINE dgssv(options, A, perm_c, perm_r, L, U, B, stat, info) & + & BIND(C, name="dgssv") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix + TYPE(superlu_options_t), INTENT(INOUT) :: options + ! options (input) superlu_options_t* + ! The structure defines the input parameters to control + ! how the LU decomposition will be performed and how the + ! system will be solved. + TYPE(SuperMatrix), INTENT(INOUT) :: A + ! A (input) SuperMatrix* + ! Matrix A in A*X=B, of dimension (A->nrow, A->ncol). The number + ! of linear equations is A->nrow. Currently, the type of A can be: + ! Stype = SLU_NC or SLU_NR; Dtype = SLU_D; Mtype = SLU_GE. + ! In the future, more general A may be handled. + INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) + ! perm_c (input/output) int* + ! If A->Stype = SLU_NC, column permutation vector of size A->ncol + ! which defines the permutation matrix Pc; perm_c[i] = j means + ! column i of A is in position j in A*Pc. + ! If A->Stype = SLU_NR, column permutation vector of size A->nrow + ! which describes permutation of columns of transpose(A) + ! (rows of A) as described above. + ! + ! If options->ColPerm = MY_PERMC or options->Fact = SamePattern or + ! options->Fact = SamePattern_SameRowPerm, it is an input argument. + ! On exit, perm_c may be overwritten by the product of the input + ! perm_c and a permutation that postorders the elimination tree + ! of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree + ! is already in postorder. + ! Otherwise, it is an output argument. + INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) + ! perm_r (input/output) int* + ! If A->Stype = SLU_NC, row permutation vector of size A->nrow, + ! which defines the permutation matrix Pr, and is determined + ! by partial pivoting. perm_r[i] = j means row i of A is in + ! position j in Pr*A. + ! If A->Stype = SLU_NR, permutation vector of size A->ncol, which + ! determines permutation of rows of transpose(A) + ! (columns of A) as described above. + ! + ! If options->RowPerm = MY_PERMR or + ! options->Fact = SamePattern_SameRowPerm, perm_r is an + ! input argument. + ! otherwise it is an output argument. + TYPE(SuperMatrix), INTENT(INOUT) :: L + ! L (output) SuperMatrix* + ! The factor L from the factorization + ! Pr*A*Pc=L*U (if A->Stype = SLU_NC) or + ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). + ! Uses compressed row subscripts storage for supernodes, i.e., + ! L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. + TYPE(SuperMatrix), INTENT(INOUT) :: U + ! U (output) SuperMatrix* + ! The factor U from the factorization + ! Pr*A*Pc=L*U (if A->Stype = SLU_NC) or + ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). + ! Uses column-wise storage scheme, i.e., U has types: + ! Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. + TYPE(SuperMatrix), INTENT(INOUT) :: B + ! B (input/output) SuperMatrix* + ! B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. + ! On entry, the right hand side matrix. + ! On exit, the solution matrix if info = 0; + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + ! stat (output) SuperLUStat_t* + ! Record the statistics on runtime and floating-point operation count. + ! See util.h for the definition of 'SuperLUStat_t'. + INTEGER(C_INT), INTENT(INOUT) :: info + ! info (output) int* + ! = 0: successful exit + ! > 0: if info = i, and i is + ! <= A->ncol: U(i,i) is exactly zero. The factorization has + ! been completed, but the factor U is exactly singular, + ! so the solution could not be computed. + ! > A->ncol: number of bytes allocated when memory allocation + ! failure occurred, plus A->ncol. + END SUBROUTINE dgssv +END INTERFACE + +PUBLIC :: dgssv + +END MODULE diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 new file mode 100644 index 000000000..afb8ed926 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgssvx_Methods.F90 @@ -0,0 +1,375 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dgssvx_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR, C_SIZE_T +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +! +! +! DGSSVX solves the system of linear equations A*X=B or A'*X=B, using +! the LU factorization from dgstrf(). Error bounds on the solution and +! a condition estimate are also provided. It performs the following steps: +! +! 1. If A is stored column-wise (A->Stype = SLU_NC): +! +! 1.1. If options->Equil = YES, scaling factors are computed to +! equilibrate the system: +! options->Trans = NOTRANS: +! diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +! options->Trans = TRANS: +! (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +! options->Trans = CONJ: +! (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +! Whether or not the system will be equilibrated depends on the +! scaling of the matrix A, but if equilibration is used, A is +! overwritten by diag(R)*A*diag(C) and B by diag(R)*B +! (if options->Trans=NOTRANS) or diag(C)*B (if options->Trans +! = TRANS or CONJ). +! +! 1.2. Permute columns of A, forming A*Pc, where Pc is a permutation +! matrix that usually preserves sparsity. +! For more details of this step, see sp_preorder.c. +! +! 1.3. If options->Fact != FACTORED, the LU decomposition is used to +! factor the matrix A (after equilibration if options->Equil = YES) +! as Pr*A*Pc = L*U, with Pr determined by partial pivoting. +! +! 1.4. Compute the reciprocal pivot growth factor. +! +! 1.5. If some U(i,i) = 0, so that U is exactly singular, then the +! routine returns with info = i. Otherwise, the factored form of +! A is used to estimate the condition number of the matrix A. If +! the reciprocal of the condition number is less than machine +! precision, info = A->ncol+1 is returned as a warning, but the +! routine still goes on to solve for X and computes error bounds +! as described below. +! +! 1.6. The system of equations is solved for X using the factored form +! of A. +! +! 1.7. If options->IterRefine != NOREFINE, iterative refinement is +! applied to improve the computed solution matrix and calculate +! error bounds and backward error estimates for it. +! +! 1.8. If equilibration was used, the matrix X is premultiplied by +! diag(C) (if options->Trans = NOTRANS) or diag(R) +! (if options->Trans = TRANS or CONJ) so that it solves the +! original system before equilibration. +! +! 2. If A is stored row-wise (A->Stype = SLU_NR), apply the above algorithm +! to the transpose of A: +! +! 2.1. If options->Equil = YES, scaling factors are computed to +! equilibrate the system: +! options->Trans = NOTRANS: +! diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +! options->Trans = TRANS: +! (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +! options->Trans = CONJ: +! (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +! Whether or not the system will be equilibrated depends on the +! scaling of the matrix A, but if equilibration is used, A' is +! overwritten by diag(R)*A'*diag(C) and B by diag(R)*B +! (if trans='N') or diag(C)*B (if trans = 'T' or 'C'). +! +! 2.2. Permute columns of transpose(A) (rows of A), +! forming transpose(A)*Pc, where Pc is a permutation matrix that +! usually preserves sparsity. +! For more details of this step, see sp_preorder.c. +! +! 2.3. If options->Fact != FACTORED, the LU decomposition is used to +! factor the transpose(A) (after equilibration if +! options->Fact = YES) as Pr*transpose(A)*Pc = L*U with the +! permutation Pr determined by partial pivoting. +! +! 2.4. Compute the reciprocal pivot growth factor. +! +! 2.5. If some U(i,i) = 0, so that U is exactly singular, then the +! routine returns with info = i. Otherwise, the factored form +! of transpose(A) is used to estimate the condition number of the +! matrix A. If the reciprocal of the condition number +! is less than machine precision, info = A->nrow+1 is returned as +! a warning, but the routine still goes on to solve for X and +! computes error bounds as described below. +! +! 2.6. The system of equations is solved for X using the factored form +! of transpose(A). +! +! 2.7. If options->IterRefine != NOREFINE, iterative refinement is +! applied to improve the computed solution matrix and calculate +! error bounds and backward error estimates for it. +! +! 2.8. If equilibration was used, the matrix X is premultiplied by +! diag(C) (if options->Trans = NOTRANS) or diag(R) +! (if options->Trans = TRANS or CONJ) so that it solves the +! original system before equilibration. +! +! See supermatrix.h for the definition of 'SuperMatrix' structure. +! +! void +! dgssvx(superlu_options_t *options, SuperMatrix *A, int *perm_c, int *perm_r, +! int *etree, char *equed, double *R, double *C, +! SuperMatrix *L, SuperMatrix *U, void *work, int lwork, +! SuperMatrix *B, SuperMatrix *X, double *recip_pivot_growth, +! double *rcond, double *ferr, double *berr, +! GlobalLU_t *Glu, mem_usage_t *mem_usage, SuperLUStat_t *stat, int *info ) + +INTERFACE + SUBROUTINE dgssvx(options, A, perm_c, perm_r, & + & etree, equed, R, C, L, U, work, lwork, & + & B, X, recip_pivot_growth, rcond, ferr, berr, & + & Glu, mem_usage, stat, info) & + & BIND(C, name="dgssvx") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix, GlobalLU_t, mem_usage_t, C_CHAR, C_DOUBLE, & + & C_SIZE_T + ! + TYPE(superlu_options_t), INTENT(IN) :: options + ! options (input) superlu_options_t* + ! The structure defines the input parameters to control + ! how the LU decomposition will be performed and how the + ! system will be solved. + TYPE(SuperMatrix), INTENT(INOUT) :: A + ! A (input/output) SuperMatrix* + ! Matrix A in A*X=B, of dimension (A->nrow, A->ncol). The number + ! of the linear equations is A->nrow. Currently, the type of A can be: + ! Stype = SLU_NC or SLU_NR, Dtype = SLU_D, Mtype = SLU_GE. + ! In the future, more general A may be handled. + ! + ! On entry, If options->Fact = FACTORED and equed is not 'N', + ! then A must have been equilibrated by the scaling factors in + ! R and/or C. + ! On exit, A is not modified if options->Equil = NO, or if + ! options->Equil = YES but equed = 'N' on exit. + ! Otherwise, if options->Equil = YES and equed is not 'N', + ! A is scaled as follows: + ! If A->Stype = SLU_NC: + ! equed = 'R': A := diag(R) * A + ! equed = 'C': A := A * diag(C) + ! equed = 'B': A := diag(R) * A * diag(C). + ! If A->Stype = SLU_NR: + ! equed = 'R': transpose(A) := diag(R) * transpose(A) + ! equed = 'C': transpose(A) := transpose(A) * diag(C) + ! equed = 'B': transpose(A) := diag(R) * transpose(A) * diag(C). + INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) + ! perm_c (input/output) int* + ! If A->Stype = SLU_NC, Column permutation vector of size A->ncol, + ! which defines the permutation matrix Pc; perm_c[i] = j means + ! column i of A is in position j in A*Pc. + ! On exit, perm_c may be overwritten by the product of the input + ! perm_c and a permutation that postorders the elimination tree + ! of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree + ! is already in postorder. + ! + ! If A->Stype = SLU_NR, column permutation vector of size A->nrow, + ! which describes permutation of columns of transpose(A) + ! (rows of A) as described above. + INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) + ! perm_r (input/output) int* + ! If A->Stype = SLU_NC, row permutation vector of size A->nrow, + ! which defines the permutation matrix Pr, and is determined + ! by partial pivoting. perm_r[i] = j means row i of A is in + ! position j in Pr*A. + ! + ! If A->Stype = SLU_NR, permutation vector of size A->ncol, which + ! determines permutation of rows of transpose(A) + ! (columns of A) as described above. + ! + ! If options->Fact = SamePattern_SameRowPerm, the pivoting routine + ! will try to use the input perm_r, unless a certain threshold + ! criterion is violated. In that case, perm_r is overwritten by a + ! new permutation determined by partial pivoting or diagonal + ! threshold pivoting. + ! Otherwise, perm_r is output argument. + INTEGER(C_INT), INTENT(INOUT) :: etree(*) + ! etree (input/output) int*, dimension (A->ncol) + ! Elimination tree of Pc'*A'*A*Pc. + ! If options->Fact != FACTORED and options->Fact != DOFACT, + ! etree is an input argument, otherwise it is an output argument. + ! Note: etree is a vector of parent pointers for a forest whose + ! vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. + CHARACTER(1, kind=C_CHAR), INTENT(inout) :: equed(*) + ! equed (input/output) char* + ! Specifies the form of equilibration that was done. + ! = 'N': No equilibration. + ! = 'R': Row equilibration, i.e., A was premultiplied by diag(R). + ! = 'C': Column equilibration, i.e., A was postmultiplied by diag(C). + ! = 'B': Both row and column equilibration, i.e., A was replaced + ! by diag(R)*A*diag(C). + ! If options->Fact = FACTORED, equed is an input argument, + ! otherwise it is an output argument. + REAL(C_DOUBLE), INTENT(inout) :: R(*) + ! R (input/output) double*, dimension (A->nrow) + ! The row scale factors for A or transpose(A). + ! If equed = 'R' or 'B', A (if A->Stype = SLU_NC) or transpose(A) + ! (if A->Stype = SLU_NR) is multiplied on the left by diag(R). + ! If equed = 'N' or 'C', R is not accessed. + ! If options->Fact = FACTORED, R is an input argument, + ! otherwise, R is output. + ! If options->Fact = FACTORED and equed = 'R' or 'B', each element + ! of R must be positive. + REAL(C_DOUBLE), INTENT(inout) :: C(*) + ! C (input/output) double*, dimension (A->ncol) + ! The column scale factors for A or transpose(A). + ! If equed = 'C' or 'B', A (if A->Stype = SLU_NC) or transpose(A) + ! (if A->Stype = SLU_NR) is multiplied on the right by diag(C). + ! If equed = 'N' or 'R', C is not accessed. + ! If options->Fact = FACTORED, C is an input argument, + ! otherwise, C is output. + ! If options->Fact = FACTORED and equed = 'C' or 'B', each element + ! of C must be positive. + TYPE(SuperMatrix), INTENT(INOUT) :: L + ! L (output) SuperMatrix* + ! The factor L from the factorization + ! Pr*A*Pc=L*U (if A->Stype SLU_= NC) or + ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). + ! Uses compressed row subscripts storage for supernodes, i.e., + ! L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. + TYPE(SuperMatrix), INTENT(INOUT) :: U + ! U (output) SuperMatrix* + ! The factor U from the factorization + ! Pr*A*Pc=L*U (if A->Stype = SLU_NC) or + ! Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR). + ! Uses column-wise storage scheme, i.e., U has types: + ! Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. + TYPE(C_PTR), INTENT(inout) :: work + ! work (workspace/output) void*, size (lwork) (in bytes) + ! User supplied workspace, should be large enough + ! to hold data structures for factors L and U. + ! On exit, if fact is not 'F', L and U point to this array. + ! + INTEGER(C_SIZE_T), VALUE, INTENT(IN) :: lwork + ! lwork (input) int + ! Specifies the size of work array in bytes. + ! = 0: allocate space internally by system malloc; + ! > 0: use user-supplied work array of length lwork in bytes, + ! returns error if space runs out. + ! = -1: the routine guesses the amount of space needed without + ! performing the factorization, and returns it in + ! mem_usage->total_needed; no other side effects. + ! + ! See argument 'mem_usage' for memory usage statistics. + TYPE(SuperMatrix), INTENT(INOUT) :: B + ! B (input/output) SuperMatrix* + ! B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. + ! On entry, the right hand side matrix. + ! If B->ncol = 0, only LU decomposition is performed, the triangular + ! solve is skipped. + ! On exit, + ! if equed = 'N', B is not modified; otherwise + ! if A->Stype = SLU_NC: + ! if options->Trans = NOTRANS and equed = 'R' or 'B', + ! B is overwritten by diag(R)*B; + ! if options->Trans = TRANS or CONJ and equed = 'C' of 'B', + ! B is overwritten by diag(C)*B; + ! if A->Stype = SLU_NR: + ! if options->Trans = NOTRANS and equed = 'C' or 'B', + ! B is overwritten by diag(C)*B; + ! if options->Trans = TRANS or CONJ and equed = 'R' of 'B', + ! B is overwritten by diag(R)*B. + TYPE(SuperMatrix), INTENT(INOUT) :: X + ! (output) SuperMatrix* + ! X has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. + ! If info = 0 or info = A->ncol+1, X contains the solution matrix + ! to the original system of equations. Note that A and B are modified + ! on exit if equed is not 'N', and the solution to the equilibrated + ! system is inv(diag(C))*X if options->Trans = NOTRANS and + ! equed = 'C' or 'B', or inv(diag(R))*X if options->Trans = 'T' or 'C' + ! and equed = 'R' or 'B'. + ! + REAL(C_DOUBLE), INTENT(INOUT) :: recip_pivot_growth + ! recip_pivot_growth (output) double* + ! The reciprocal pivot growth factor max_j( norm(A_j)/norm(U_j) ). + ! The infinity norm is used. If recip_pivot_growth is much less + ! than 1, the stability of the LU factorization could be poor. + REAL(C_DOUBLE), INTENT(inout) :: rcond + ! rcond (output) double* + ! The estimate of the reciprocal condition number of the matrix A + ! after equilibration (if done). If rcond is less than the machine + ! precision (in particular, if rcond = 0), the matrix is singular + ! to working precision. This condition is indicated by a return + ! code of info > 0. + REAL(C_DOUBLE), INTENT(inout) :: ferr(*) + ! FERR (output) double*, dimension (B->ncol) + ! The estimated forward error bound for each solution vector + ! X(j) (the j-th column of the solution matrix X). + ! If XTRUE is the true solution corresponding to X(j), FERR(j) + ! is an estimated upper bound for the magnitude of the largest + ! element in (X(j) - XTRUE) divided by the magnitude of the + ! largest element in X(j). The estimate is as reliable as + ! the estimate for RCOND, and is almost always a slight + ! overestimate of the true error. + ! If options->IterRefine = NOREFINE, ferr = 1.0. + REAL(C_DOUBLE), INTENT(inout) :: berr(*) + ! BERR (output) double*, dimension (B->ncol) + ! The componentwise relative backward error of each solution + ! vector X(j) (i.e., the smallest relative change in + ! any element of A or B that makes X(j) an exact solution). + ! If options->IterRefine = NOREFINE, berr = 1.0. + TYPE(GlobalLU_t), INTENT(inout) :: Glu + ! Glu (input/output) GlobalLU_t * + ! If options->Fact == SamePattern_SameRowPerm, it is an input; + ! The matrix A will be factorized assuming that a + ! factorization of a matrix with the same sparsity pattern + ! and similar numerical values was performed prior to this one. + ! Therefore, this factorization will reuse both row and column + ! scaling factors R and C, both row and column permutation + ! vectors perm_r and perm_c, and the L & U data structures + ! set up from the previous factorization. + ! Otherwise, it is an output. + TYPE(mem_usage_t), INTENT(inout) :: mem_usage + ! mem_usage (output) mem_usage_t* + ! Record the memory usage statistics, consisting of following fields: + ! - for_lu (float) + ! The amount of space used in bytes for L\U data structures. + ! - total_needed (float) + ! The amount of space needed in bytes to perform factorization. + ! - expansions (int) + ! The number of memory expansions during the LU factorization. + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + ! stat (output) SuperLUStat_t* + ! Record the statistics on runtime and floating-point operation count. + ! See slu_util.h for the definition of 'SuperLUStat_t'. + INTEGER(C_SIZE_T), INTENT(INOUT) :: info + ! info (output) int* + ! = 0: successful exit + ! < 0: if info = -i, the i-th argument had an illegal value + ! > 0: if info = i, and i is + ! <= A->ncol: U(i,i) is exactly zero. The factorization has + ! been completed, but the factor U is exactly + ! singular, so the solution and error bounds + ! could not be computed. + ! = A->ncol+1: U is nonsingular, but RCOND is less than machine + ! precision, meaning that the matrix is singular to + ! working precision. Nevertheless, the solution and + ! error bounds are computed because there are a number + ! of situations where the computed solution can be more + ! accurate than the value of RCOND would suggest. + ! > A->ncol+1: number of bytes allocated when memory allocation + ! failure occurred, plus A->ncol. + END SUBROUTINE dgssvx +END INTERFACE + +PUBLIC :: dgssvx + +END MODULE SuperLU_dgssvx_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.F90 new file mode 100644 index 000000000..3eb8725e7 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgstrf_Methods.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 +! + +MODULE SuperLU_dgstrf_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23-01-23 +! summary: +! +!# Introduction +! +! * Purpose +! * ======= +! * +! * DGSTRF computes an LU factorization of a general sparse m-by-n +! * matrix A using partial pivoting with row interchanges. +! * The factorization has the form +! * Pr * A = L * U +! * where Pr is a row permutation matrix, L is lower triangular with unit +! * diagonal elements (lower trapezoidal if A->nrow > A->ncol), and U is upper +! * triangular (upper trapezoidal if A->nrow < A->ncol). +! * +! * See supermatrix.h for the definition of 'SuperMatrix' structure. +! * +! * Arguments +! * ========= +! * +! * options (input) superlu_options_t* +! * The structure defines the input parameters to control +! * how the LU decomposition will be performed. +! * +! * A (input) SuperMatrix* +! * Original matrix A, permuted by columns, of dimension +! * (A->nrow, A->ncol). The type of A can be: +! * Stype = SLU_NCP; Dtype = SLU_D; Mtype = SLU_GE. +! * +! * relax (input) int +! * To control degree of relaxing supernodes. If the number +! * of nodes (columns) in a subtree of the elimination tree is less +! * than relax, this subtree is considered as one supernode, +! * regardless of the row structures of those columns. +! * +! * panel_size (input) int +! * A panel consists of at most panel_size consecutive columns. +! * +! * etree (input) int*, dimension (A->ncol) +! * Elimination tree of A'*A. +! * Note: etree is a vector of parent pointers for a forest whose +! * vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. +! * On input, the columns of A should be permuted so that the +! * etree is in a certain postorder. +! * +! * work (input/output) void*, size (lwork) (in bytes) +! * User-supplied work space and space for the output data structures. +! * Not referenced if lwork = 0; +! * +! * lwork (input) int +! * Specifies the size of work array in bytes. +! * = 0: allocate space internally by system malloc; +! * > 0: use user-supplied work array of length lwork in bytes, +! * returns error if space runs out. +! * = -1: the routine guesses the amount of space needed without +! * performing the factorization, and returns it in +! * *info; no other side effects. +! * +! * perm_c (input) int*, dimension (A->ncol) +! * Column permutation vector, which defines the +! * permutation matrix Pc; perm_c[i] = j means column i of A is +! * in position j in A*Pc. +! * When searching for diagonal, perm_c[*] is applied to the +! * row subscripts of A, so that diagonal threshold pivoting +! * can find the diagonal of A, rather than that of A*Pc. +! * +! * perm_r (input/output) int*, dimension (A->nrow) +! * Row permutation vector which defines the permutation matrix Pr, +! * perm_r[i] = j means row i of A is in position j in Pr*A. +! * If options->Fact == SamePattern_SameRowPerm, the pivoting routine +! * will try to use the input perm_r, unless a certain threshold +! * criterion is violated. In that case, perm_r is overwritten by +! * a new permutation determined by partial pivoting or diagonal +! * threshold pivoting. +! * Otherwise, perm_r is output argument; +! * +! * L (output) SuperMatrix* +! * The factor L from the factorization Pr*A=L*U; use compressed row +! * subscripts storage for supernodes, i.e., L has type: +! * Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. +! * +! * U (output) SuperMatrix* +! * The factor U from the factorization Pr*A*Pc=L*U. Use column-wise +! * storage scheme, i.e., U has types: Stype = SLU_NC, +! * Dtype = SLU_D, Mtype = SLU_TRU. +! * +! * Glu (input/output) GlobalLU_t * +! * If options->Fact == SamePattern_SameRowPerm, it is an input; +! * The matrix A will be factorized assuming that a +! * factorization of a matrix with the same sparsity pattern +! * and similar numerical values was performed prior to this one. +! * Therefore, this factorization will reuse both row and column +! * scaling factors R and C, both row and column permutation +! * vectors perm_r and perm_c, and the L & U data structures +! * set up from the previous factorization. +! * Otherwise, it is an output. +! * +! * stat (output) SuperLUStat_t* +! * Record the statistics on runtime and floating-point operation count. +! * See slu_util.h for the definition of 'SuperLUStat_t'. +! * +! * info (output) int* +! * = 0: successful exit +! * < 0: if info = -i, the i-th argument had an illegal value +! * > 0: if info = i, and i is +! * <= A->ncol: U(i,i) is exactly zero. The factorization has +! * been completed, but the factor U is exactly singular, +! * and division by zero will occur if it is used to solve a +! * system of equations. +! * > A->ncol: number of bytes allocated when memory allocation +! * failure occurred, plus A->ncol. If lwork = -1, it is +! * the estimated amount of space needed, plus A->ncol. +! * +! * ====================================================================== +! * +! * Local Working Arrays: +! * ====================== +! * m = number of rows in the matrix +! * n = number of columns in the matrix +! * +! * xprune[0:n-1]: xprune[*] points to locations in subscript +! * vector lsub[*]. For column i, xprune[i] denotes the point where +! * structural pruning begins. I.e. only xlsub[i],..,xprune[i]-1 need +! * to be traversed for symbolic factorization. +! * +! * marker[0:3*m-1]: marker[i] = j means that node i has been +! * reached when working on column j. +! * Storage: relative to original row subscripts +! * NOTE: There are 3 of them: marker/marker1 are used for panel dfs, +! * see dpanel_dfs.c; marker2 is used for inner-factorization, +! * see dcolumn_dfs.c. +! * +! * parent[0:m-1]: parent vector used during dfs +! * Storage: relative to new row subscripts +! * +! * xplore[0:m-1]: xplore[i] gives the location of the next (dfs) +! * unexplored neighbor of i in lsub[*] +! * +! * segrep[0:nseg-1]: contains the list of supernodal representatives +! * in topological order of the dfs. A supernode representative is the +! * last column of a supernode. +! * The maximum size of segrep[] is n. +! * +! * repfnz[0:W*m-1]: for a nonzero segment U[*,j] that ends at a +! * supernodal representative r, repfnz[r] is the location of the first +! * nonzero in this segment. It is also used during the dfs: repfnz[r]>0 +! * indicates the supernode r has been explored. +! * NOTE: There are W of them, each used for one column of a panel. +! * +! * panel_lsub[0:W*m-1]: temporary for the nonzeros row indices below +! * the panel diagonal. These are filled in during dpanel_dfs(), and are +! * used later in the inner LU factorization within the panel. +! * panel_lsub[]/dense[] pair forms the SPA data structure. +! * NOTE: There are W of them. +! * +! * dense[0:W*m-1]: sparse accumulating (SPA) vector for intermediate values; +! * NOTE: there are W of them. +! * +! * tempv[0:*]: real temporary used for dense numeric kernels; +! * The size of this array is defined by NUM_TEMPV() in slu_ddefs.h. +! void +! dgstrf (superlu_options_t *options, SuperMatrix *A, +! int relax, int panel_size, int *etree, void *work, int lwork, +! int *perm_c, int *perm_r, SuperMatrix *L, SuperMatrix *U, +! GlobalLU_t *Glu, /* persistent to facilitate multiple factorizations */ +! SuperLUStat_t *stat, int *info) + +INTERFACE + SUBROUTINE dgstrf(options, A, relax, panel_size, etree, & + & work, lwork, perm_c, perm_r, & + & L, U, & + & Glu, stat, info) & + & BIND(C, name="dgstrf") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix, GlobalLU_t, C_CHAR, C_DOUBLE + ! + TYPE(superlu_options_t), INTENT(IN) :: options + ! options (input) superlu_options_t* + ! The structure defines the input parameters to control + ! how the ILU decomposition will be performed. + TYPE(SuperMatrix), INTENT(INOUT) :: A + ! A (input) SuperMatrix* + ! Original matrix A, permuted by columns, of dimension + ! (A->nrow, A->ncol). The type of A can be: + ! Stype = SLU_NCP; Dtype = SLU_D; Mtype = SLU_GE. + INTEGER(C_INT), VALUE, INTENT(IN) :: relax + ! relax (input) int + ! To control degree of relaxing supernodes. If the number + ! of nodes (columns) in a subtree of the elimination tree is less + ! than relax, this subtree is considered as one supernode, + ! regardless of the row structures of those columns. + INTEGER(C_INT), VALUE, INTENT(IN) :: panel_size + ! panel_size (input) int + ! A panel consists of at most panel_size consecutive columns. + INTEGER(C_INT), INTENT(INOUT) :: etree(*) + ! etree (input) int*, dimension (A->ncol) + ! Elimination tree of A'*A. + ! Note: etree is a vector of parent pointers for a forest whose + ! vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol. + ! On input, the columns of A should be permuted so that the + ! etree is in a certain postorder. + TYPE(C_PTR), INTENT(inout) :: work + ! work (input/output) void*, size (lwork) (in bytes) + ! User-supplied work space and space for the output data structures. + ! Not referenced if lwork = 0; + INTEGER(C_INT), VALUE, INTENT(IN) :: lwork + ! lwork (input) int + ! Specifies the size of work array in bytes. + ! = 0: allocate space internally by system malloc; + ! > 0: use user-supplied work array of length lwork in bytes, + ! returns error if space runs out. + ! = -1: the routine guesses the amount of space needed without + ! performing the factorization, and returns it in + ! *info; no other side effects. + INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) + ! perm_c (input) int*, dimension (A->ncol) + ! Column permutation vector, which defines the + ! permutation matrix Pc; perm_c[i] = j means column i of A is + ! in position j in A*Pc. + ! When searching for diagonal, perm_c[*] is applied to the + ! row subscripts of A, so that diagonal threshold pivoting + ! can find the diagonal of A, rather than that of A*Pc. + INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) + ! perm_r (input/output) int*, dimension (A->nrow) + ! Row permutation vector which defines the permutation matrix Pr, + ! perm_r[i] = j means row i of A is in position j in Pr*A. + ! If options->Fact = SamePattern_SameRowPerm, the pivoting routine + ! will try to use the input perm_r, unless a certain threshold + ! criterion is violated. In that case, perm_r is overwritten by + ! a new permutation determined by partial pivoting or diagonal + ! threshold pivoting. + ! Otherwise, perm_r is output argument; + TYPE(SuperMatrix), INTENT(INOUT) :: L + ! L (output) SuperMatrix* + ! The factor L from the factorization Pr*A=L*U; use compressed row + ! subscripts storage for supernodes, i.e., L has type: + ! Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. + TYPE(SuperMatrix), INTENT(INOUT) :: U + ! U (output) SuperMatrix* + ! The factor U from the factorization Pr*A*Pc=L*U. Use column-wise + ! storage scheme, i.e., U has types: Stype = SLU_NC, + ! Dtype = SLU_D, Mtype = SLU_TRU. + TYPE(GlobalLU_t), INTENT(inout) :: Glu + ! Glu (input/output) GlobalLU_t * + ! If options->Fact == SamePattern_SameRowPerm, it is an input; + ! The matrix A will be factorized assuming that a + ! factorization of a matrix with the same sparsity pattern + ! and similar numerical values was performed prior to this one. + ! Therefore, this factorization will reuse both row and column + ! scaling factors R and C, both row and column permutation + ! vectors perm_r and perm_c, and the L & U data structures + ! set up from the previous factorization. + ! Otherwise, it is an output. + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + ! stat (output) SuperLUStat_t* + ! Record the statistics on runtime and floating-point operation count. + ! See slu_util.h for the definition of 'SuperLUStat_t'. + INTEGER(C_INT), INTENT(INOUT) :: info + ! info (output) int* + ! = 0: successful exit + ! < 0: if info = -i, the i-th argument had an illegal value + ! > 0: if info = i, and i is + ! <= A->ncol: number of zero pivots. They are replaced by small + ! entries according to options->ILU_FillTol. + ! > A->ncol: number of bytes allocated when memory allocation + ! failure occurred, plus A->ncol. If lwork = -1, it is + ! the estimated amount of space needed, plus A->ncol. + END SUBROUTINE dgstrf +END INTERFACE + +PUBLIC :: dgstrf + +END MODULE SuperLU_dgstrf_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 new file mode 100644 index 000000000..f275be4de --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dgstrs_Methods.F90 @@ -0,0 +1,101 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dgstrs_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Purpose +! ======= +! +! DGSTRS solves a system of linear equations A*X=B or A'*X=B +! with A sparse and B dense, using the LU factorization computed by +! DGSTRF. +! +! See supermatrix.h for the definition of 'SuperMatrix' structure. +! +! Arguments +! ========= +! +! trans (input) trans_t +! Specifies the form of the system of equations: +! = NOTRANS: A * X = B (No transpose) +! = TRANS: A'* X = B (Transpose) +! = CONJ: A**H * X = B (Conjugate transpose) +! +! L (input) SuperMatrix* +! The factor L from the factorization Pr*A*Pc=L*U as computed by +! dgstrf(). Use compressed row subscripts storage for supernodes, +! i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU. +! +! U (input) SuperMatrix* +! The factor U from the factorization Pr*A*Pc=L*U as computed by +! dgstrf(). Use column-wise storage scheme, i.e., U has types: +! Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU. +! +! perm_c (input) int*, dimension (L->ncol) +! Column permutation vector, which defines the +! permutation matrix Pc; perm_c[i] = j means column i of A is +! in position j in A*Pc. +! +! perm_r (input) int*, dimension (L->nrow) +! Row permutation vector, which defines the permutation matrix Pr; +! perm_r[i] = j means row i of A is in position j in Pr*A. +! +! B (input/output) SuperMatrix* +! B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE. +! On entry, the right hand side matrix. +! On exit, the solution matrix if info = 0; +! +! stat (output) SuperLUStat_t* +! Record the statistics on runtime and floating-point operation count. +! See util.h for the definition of 'SuperLUStat_t'. +! +! info (output) int* +! = 0: successful exit +! < 0: if info = -i, the i-th argument had an illegal value +! +! void +! dgstrs (trans_t trans, SuperMatrix *L, SuperMatrix *U, +! int *perm_c, int *perm_r, SuperMatrix *B, +! SuperLUStat_t *stat, int *info) + +INTERFACE + SUBROUTINE dgstrs(trans, L, U, perm_c, perm_r, B, stat, info) & + & BIND(C, name="dgstrs") + IMPORT :: superlu_options_t, SuperLUStat_t, C_INT, C_PTR, & + & SuperMatrix + INTEGER(C_INT), VALUE, INTENT(IN) :: trans + TYPE(SuperMatrix), INTENT(INOUT) :: L + TYPE(SuperMatrix), INTENT(INOUT) :: U + INTEGER(C_INT), INTENT(INOUT) :: perm_c(*) + INTEGER(C_INT), INTENT(INOUT) :: perm_r(*) + TYPE(SuperMatrix), INTENT(INOUT) :: B + TYPE(SuperLUStat_t), INTENT(INOUT) :: stat + INTEGER(C_INT), INTENT(INOUT) :: info + END SUBROUTINE dgstrs +END INTERFACE + +PUBLIC :: dgstrs + +END MODULE SuperLU_dgstrs_Methods diff --git a/src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 b/src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 new file mode 100644 index 000000000..578d170e0 --- /dev/null +++ b/src/modules/SuperLUInterface/src/SuperLU_dlaqgs_Methods.F90 @@ -0,0 +1,101 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SuperLU_dlaqgs_Methods +USE SuperLU_Types +USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_DOUBLE, C_PTR +IMPLICIT NONE +PRIVATE + +! * Purpose +! * ======= +! * +! * DLAQGS equilibrates a general sparse M by N matrix A using the row and +! * scaling factors in the vectors R and C. +! * +! * See supermatrix.h for the definition of 'SuperMatrix' structure. +! * +! * Arguments +! * ========= +! * +! * A (input/output) SuperMatrix* +! * On exit, the equilibrated matrix. See EQUED for the form of +! * the equilibrated matrix. The type of A can be: +! * Stype = NC; Dtype = SLU_D; Mtype = GE. +! * +! * R (input) double*, dimension (A->nrow) +! * The row scale factors for A. +! * +! * C (input) double*, dimension (A->ncol) +! * The column scale factors for A. +! * +! * ROWCND (input) double +! * Ratio of the smallest R(i) to the largest R(i). +! * +! * COLCND (input) double +! * Ratio of the smallest C(i) to the largest C(i). +! * +! * AMAX (input) double +! * Absolute value of largest matrix entry. +! * +! * EQUED (output) char* +! * Specifies the form of equilibration that was done. +! * = 'N': No equilibration +! * = 'R': Row equilibration, i.e., A has been premultiplied by +! * diag(R). +! * = 'C': Column equilibration, i.e., A has been postmultiplied +! * by diag(C). +! * = 'B': Both row and column equilibration, i.e., A has been +! * replaced by diag(R) * A * diag(C). +! * +! * Internal Parameters +! * =================== +! * +! * THRESH is a threshold value used to decide if row or column scaling +! * should be done based on the ratio of the row or column scaling +! * factors. If ROWCND < THRESH, row scaling is done, and if +! * COLCND < THRESH, column scaling is done. +! * +! * LARGE and SMALL are threshold values used to decide if row scaling +! * should be done based on the absolute size of the largest matrix +! * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. +! * +! * ===================================================================== +! +! void +! dlaqgs(SuperMatrix *A, double *r, double *c, +! double rowcnd, double colcnd, double amax, char *equed) +! + +INTERFACE + SUBROUTINE dlaqgs(A, r, c, rowcnd, colcnd, amax, equed)& + & BIND(C, name="dlaqgs") + IMPORT :: SuperMatrix, C_DOUBLE, C_CHAR + + TYPE(SuperMatrix), INTENT(INOUT) :: A + REAL(C_DOUBLE), INTENT(INOUT) :: r(*) + REAL(C_DOUBLE), INTENT(INOUT) :: c(*) + REAL(C_DOUBLE), VALUE, INTENT(IN) :: rowcnd + REAL(C_DOUBLE), VALUE, INTENT(IN) :: colcnd + REAL(C_DOUBLE), VALUE, INTENT(IN) :: amax + CHARACTER(1, kind=C_CHAR), INTENT(INOUT) :: equed + END SUBROUTINE dlaqgs +END INTERFACE + +PUBLIC :: dlaqgs + +END MODULE SuperLU_dlaqgs_Methods diff --git a/src/modules/SuperLUInterface/src/include/macros.inc b/src/modules/SuperLUInterface/src/include/macros.inc new file mode 100644 index 000000000..20c770285 --- /dev/null +++ b/src/modules/SuperLUInterface/src/include/macros.inc @@ -0,0 +1,18 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SUPERLU_CPTR_ONLY diff --git a/src/modules/System/CMakeLists.txt b/src/modules/System/CMakeLists.txt new file mode 100644 index 000000000..801f528f7 --- /dev/null +++ b/src/modules/System/CMakeLists.txt @@ -0,0 +1,43 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/System_Method.F90) + + +set(subproject_name "easifemSystem") + +add_library(${subproject_name} STATIC ${src_path}/System_Method.c) + +target_link_libraries(${PROJECT_NAME} PUBLIC ${subproject_name}) + +# target properties + +set_target_properties( + ${subproject_name} + PROPERTIES POSITION_INDEPENDENT_CODE 1 + SOVERSION ${VERSION_MAJOR} + # OUTPUT_NAME ${PROJECT_NAME} + LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + MACOSX_RPATH ON + WINDOWS_EXPORT_ALL_SYMBOLS ON + LINKER_LANGUAGE C) + + +list(APPEND C_PROJECTS ${subproject_name}) diff --git a/src/modules/System/src/System_Method.F90 b/src/modules/System/src/System_Method.F90 new file mode 100755 index 000000000..a39ca633f --- /dev/null +++ b/src/modules/System/src/System_Method.F90 @@ -0,0 +1,5427 @@ +! This program is a part of EASIFEM library. +! This program is directly taken from the +! source: https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> +!##NAME +! M_system(3fm) - [M_system::INTRO] Fortran interface to C system interface +! (LICENSE:PD) +!##SYNOPSIS +! +! Public objects: +! +! ! ENVIRONMENT +! use M_system, only : set_environment_variable, system_unsetenv, & +! system_putenv, system_getenv +! +! use M_system, only : system_intenv, system_readenv, system_clearenv +! ! FILE SYSTEM +! use M_system, only : system_getcwd, system_link, & +! system_mkfifo, system_remove, system_rename, & +! system_umask, system_unlink, fileglob, & +! system_rmdir, system_chdir, system_mkdir, & +! system_stat, system_isdir, system_islnk, system_isreg, & +! system_isblk, system_ischr, system_isfifo, & +! system_realpath, & +! system_access, & +! system_utime, & +! system_issock, system_perm, & +! system_dir, & +! system_memcpy +! +! !!use M_system, only : system_getc, system_putc +! ! ERROR PROCESSING +! use M_system, only : system_errno, system_perror +! ! INFO +! use M_system, only : system_getegid, system_geteuid, system_getgid, & +! system_gethostname, system_getpid, system_getppid, system_setsid, & +! system_getsid, system_getuid, system_uname +! ! SIGNALS +! use M_system, only : system_kill,system_signal +! ! RANDOM NUMBERS +! use M_system, only : system_rand, system_srand +! ! PROCESS INFORMATION +! use M_system, only : system_cpu_time +! +!##DESCRIPTION +! M_system(3fm) is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. +! +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. +! +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. +!##ENVIRONMENT ACCESS +! o system_putenv(3f): call putenv(3c) +! o system_getenv(3f): function call to get_environment_variable(3f) +! o system_unsetenv(3f): call unsetenv(3c) to remove variable from environment +! o set_environment_variable(3f): set environment variable by calling setenv(3c) +! +! o system_initenv(3f): initialize environment table for reading +! o system_readenv(3f): read next entry from environment table +! o system_clearenv(3f): emulate clearenv(3c) to clear environment +!##FILE SYSTEM +! o system_chdir(3f): call chdir(3c) to change current directory of a process +! o system_getcwd(3f): call getcwd(3c) to get pathname of current working directory +! +! o system_stat(3f): determine system information of file by name +! o system_perm(3f): create string representing file permission and type +! o system_access(3f): determine filename access or existence +! o system_isdir(3f): determine if filename is a directory +! o system_islnk(3f): determine if filename is a link +! o system_isreg(3f): determine if filename is a regular file +! o system_isblk(3f): determine if filename is a block device +! o system_ischr(3f): determine if filename is a character device +! o system_isfifo(3f): determine if filename is a fifo - named pipe +! o system_issock(3f): determine if filename is a socket +! o system_realpath(3f): resolve a pathname +! +! o system_chmod(3f): call chmod(3c) to set file permission mode +! o system_chown(3f): call chown(3c) to set file owner +! o system_getumask(3f): call umask(3c) to get process permission mask +! o system_setumask(3f): call umask(3c) to set process permission mask +! +! o system_mkdir(3f): call mkdir(3c) to create empty directory +! o system_mkfifo(3f): call mkfifo(3c) to create a special FIFO file +! o system_link(3f): call link(3c) to create a filename link +! +! o system_rename(3f): call rename(3c) to change filename +! +! o system_remove(3f): call remove(3c) to remove file +! o system_rmdir(3f): call rmdir(3c) to remove empty directory +! o system_unlink(3f): call unlink(3c) to remove a link to a file +! o system_utime(3f): call utime(3c) to set file access and modification times +! o system_dir(3f): read name of files in specified directory matching a wildcard string +! +! o fileglob(3f): Returns list of files using a file globbing pattern +! +!##STREAM IO +! o system_getc(3f): get a character from stdin +! o system_putc(3f): put a character on stdout +!##RANDOM NUMBERS +! o system_srand(3f): call srand(3c) +! o system_rand(3f): call rand(3c) +!##C ERROR INFORMATION +! o system_errno(3f): return errno(3c) +! o system_perror(3f): call perror(3c) to display last C error message +!##QUERIES +! o system_geteuid(3f): call geteuid(3c) +! o system_getuid(3f): call getuid(3c) +! o system_getegid(3f): call getegid(3c) +! o system_getgid(3f): call getgid(3c) +! o system_getpid(3f): call getpid(3c) +! o system_getppid(3f): call getppid(3c) +! o system_gethostname(3f): get name of current host +! o system_uname(3f): call my_uname(3c) which calls uname(3c) +! o system_getlogin(3f): get login name +! o system_getpwuid(3f): get login name associated with given UID +! o system_getgrgid(3f): get group name associated with given GID +! o system_cpu_time(3f) : get processor time in seconds using times(3c) +! +!##FUTURE DIRECTIONS +! A good idea of what system routines are commonly required is to refer +! to the POSIX binding standards. (Note: IEEE 1003.9-1992 was withdrawn 6 +! February 2003.) The IEEE standard covering Fortran 77 POSIX bindings +! is available online, though currently (unfortunately) only from +! locations with appropriate subscriptions to the IEEE server (e.g., +! many university networks). For those who do have such access, the link +! is: POSIX Fortran 77 Language Interfaces (IEEE Std 1003.9-1992) (pdf) +! +!##SEE ALSO +! Some vendors provide their own way to access POSIX functions and make +! those available as modules; for instance ... +! +! o the IFPORT module of Intel +! o or the f90_* modules of NAG. +! o There are also other compiler-independent efforts to make the +! POSIX procedures accessible from Fortran... +! +! o Posix90 (doc), +! o flib.a platform/files and directories, +! o fortranposix. + +MODULE System_Method +USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR +use,intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer, c_null_char, c_null_ptr +USE, INTRINSIC :: ISO_C_BINDING +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT8, INT16, INT32, INT64 +!!, real32, real64, real128, dp=>real128 + +IMPLICIT NONE +PRIVATE +! C types. Might be platform dependent +INTEGER, PARAMETER, PUBLIC :: mode_t = INT32 + +PUBLIC :: system_rand +PUBLIC :: system_srand + +!-!public :: system_getc +!-!public :: system_putc + +PUBLIC :: system_getpid ! return process ID +PUBLIC :: system_getppid ! return parent process ID +PUBLIC :: system_getuid, system_geteuid ! return user ID +PUBLIC :: system_getgid, system_getegid ! return group ID +PUBLIC :: system_setsid +PUBLIC :: system_getsid +PUBLIC :: system_kill ! (pid, signal) kill process (defaults: pid=0, signal=SIGTERM) +PUBLIC :: system_signal ! (signal,[handler]) install signal handler subroutine + +PUBLIC :: system_errno +PUBLIC :: system_perror + +PUBLIC :: system_putenv +PUBLIC :: system_getenv +PUBLIC :: set_environment_variable +PUBLIC :: system_unsetenv + +PUBLIC :: system_initenv +PUBLIC :: system_readenv +PUBLIC :: system_clearenv + +PUBLIC :: system_stat ! call stat(3c) to determine system information of file by name +PUBLIC :: system_perm ! create string representing file permission and type +PUBLIC :: system_access ! determine filename access or existence +PUBLIC :: system_isdir ! determine if filename is a directory +PUBLIC :: system_islnk ! determine if filename is a link +PUBLIC :: system_isreg ! determine if filename is a regular file +PUBLIC :: system_isblk ! determine if filename is a block device +PUBLIC :: system_ischr ! determine if filename is a character device +PUBLIC :: system_isfifo ! determine if filename is a fifo - named pipe +PUBLIC :: system_issock ! determine if filename is a socket +PUBLIC :: system_realpath ! resolve pathname + +PUBLIC :: system_chdir +PUBLIC :: system_rmdir +PUBLIC :: system_remove +PUBLIC :: system_rename + +PUBLIC :: system_mkdir +PUBLIC :: system_mkfifo +PUBLIC :: system_chmod +PUBLIC :: system_chown +PUBLIC :: system_link +PUBLIC :: system_unlink +PUBLIC :: system_utime + +PUBLIC :: system_setumask +PUBLIC :: system_getumask +PUBLIC :: system_umask + +PUBLIC :: system_getcwd + +PUBLIC :: system_opendir +PUBLIC :: system_readdir +PUBLIC :: system_rewinddir +PUBLIC :: system_closedir + +PUBLIC :: system_cpu_time + +PUBLIC :: system_uname +PUBLIC :: system_gethostname +PUBLIC :: system_getlogin +PUBLIC :: system_getpwuid +PUBLIC :: system_getgrgid +PUBLIC :: fileglob + +PUBLIC :: system_alarm +PUBLIC :: system_calloc +PUBLIC :: system_clock +PUBLIC :: system_time +!public :: system_time +!public :: system_qsort + +PUBLIC :: system_realloc +PUBLIC :: system_malloc +PUBLIC :: system_free +PUBLIC :: system_memcpy + +PUBLIC :: system_dir + +public :: R_GRP,R_OTH,R_USR,RWX_G,RWX_O,RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR,DEFFILEMODE,ACCESSPERMS +PUBLIC :: R_OK, W_OK, X_OK, F_OK ! for system_access + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: dirent_SYSTEMA + INTEGER(C_LONG) :: d_ino + INTEGER(C_LONG) :: d_off; ! __off_t, check size + INTEGER(C_SHORT) :: d_reclen + CHARACTER(len=1, kind=C_CHAR) :: d_name(256) +END TYPE + +TYPE, BIND(C) :: dirent_CYGWIN + INTEGER(C_INT) :: d_version + INTEGER(C_LONG) :: d_ino + CHARACTER(kind=C_CHAR) :: d_type + CHARACTER(kind=C_CHAR) :: d_unused1(3) + INTEGER(C_INT) :: d_internal1 + CHARACTER(len=1, kind=C_CHAR) :: d_name(256) +END TYPE + +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + FUNCTION system_alarm(seconds) BIND(c, name="alarm") + IMPORT C_INT + INTEGER(kind=C_INT), VALUE :: seconds + INTEGER(kind=C_INT) system_alarm + END FUNCTION system_alarm +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + FUNCTION system_calloc(nelem, elsize) BIND(c, name="calloc") + IMPORT C_SIZE_T, C_INTPTR_T + INTEGER(C_SIZE_T), VALUE :: nelem, elsize + INTEGER(C_INTPTR_T) system_calloc + END FUNCTION system_calloc +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + PURE FUNCTION SYSTEM_CLOCK() BIND(c, name="clock") + IMPORT C_LONG + INTEGER(C_LONG) system_clock + END FUNCTION system_clock +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. +! extern void *memcpy (void *dest, const void *src, size_t n); +INTERFACE + SUBROUTINE system_memcpy(dest, src, n) BIND(C, name='memcpy') + IMPORT C_INTPTR_T, C_SIZE_T + INTEGER(C_INTPTR_T), VALUE :: dest + INTEGER(C_INTPTR_T), VALUE :: src + INTEGER(C_SIZE_T), VALUE :: n + END SUBROUTINE system_memcpy +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + SUBROUTINE system_free(ptr) BIND(c, name="free") + IMPORT C_INTPTR_T + INTEGER(C_INTPTR_T), VALUE :: ptr + END SUBROUTINE system_free +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + FUNCTION system_malloc(size) BIND(c, name="malloc") + IMPORT C_SIZE_T, C_INTPTR_T + INTEGER(C_SIZE_T), VALUE :: size + INTEGER(C_INTPTR_T) system_malloc + END FUNCTION system_malloc +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + FUNCTION system_realloc(ptr, size) BIND(c, name="realloc") + IMPORT C_SIZE_T, C_INTPTR_T + INTEGER(C_INTPTR_T), VALUE :: ptr + INTEGER(C_SIZE_T), VALUE :: size + INTEGER(C_INTPTR_T) system_realloc + END FUNCTION system_realloc +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + FUNCTION system_time(tloc) BIND(c, name="time") + ! tloc argument should be loaded via C_LOC from iso_c_binding + IMPORT C_PTR, C_LONG + TYPE(C_PTR), VALUE :: tloc + INTEGER(C_LONG) system_time + END FUNCTION system_time +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +! abstract interface +! integer(4) function compar_iface(a, b) +! import c_int +! integer, intent(in) :: a, b +!-! Until implement TYPE(*) +! integer(kind=c_int) :: compar_iface +! end function compar_iface +! end interface +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +! interface +! subroutine system_qsort(base, nel, width, compar) bind(c, name="qsort") +! import C_SIZE_T, compar_iface +! integer :: base +!-! Until implement TYPE(*) +! integer(C_SIZE_T), value :: nel, width +! procedure(compar_iface) compar +! end subroutine system_qsort +! end interface +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_srand(3f) - [M_system:PSEUDORANDOM] set seed for pseudo-random number generator system_rand(3f) +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine system_srand() +!! +!!##DESCRIPTION +!! system_srand(3f) calls the C routine srand(3c) The +!! srand(3c)/system_srand(3f) function uses its argument as the seed +!! for a new sequence of pseudo-random integers to be returned by +!! system_rand(3f)/rand(3c). These sequences are repeatable by calling +!! system_srand(3f) with the same seed value. If no seed value is +!! provided, the system_rand(3f) function is automatically seeded with +!! a value of 1. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_srand +!! use M_system, only : system_srand, system_rand +!! implicit none +!! integer :: i,j +!! do j=1,2 +!! call system_srand(1001) +!! do i=1,10 +!! write(*,*)system_rand() +!! enddo +!! write(*,*) +!! enddo +!! end program demo_system_srand +!! expected results: +!! +!! 1512084687 +!! 1329390995 +!! 1874040748 +!! 60731048 +!! 239808950 +!! 2017891911 +!! 22055588 +!! 1105177318 +!! 347750200 +!! 1729645355 +!! +!! 1512084687 +!! 1329390995 +!! 1874040748 +!! 60731048 +!! 239808950 +!! 2017891911 +!! 22055588 +!! 1105177318 +!! 347750200 +!! 1729645355 +!! +!!##SEE ALSO +!! drand48(3c), random(3c) +! void srand_system(int *seed) +INTERFACE + SUBROUTINE system_srand(seed) BIND(c, name='srand') + IMPORT C_INT + INTEGER(kind=C_INT), INTENT(in) :: seed + END SUBROUTINE system_srand +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_kill(3f) - [M_system:SIGNALS] send a signal to a process or a group of processes +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_kill(pid,sig) +!! +!! integer,intent(in) :: pid +!! integer,intent(in) :: sig +!! +!!##DESCRIPTION +!! +!! The kill() function shall send a signal to a process or a group of +!! processes specified by pid. The signal to be sent is specified by sig +!! and is either one from the list given in or 0. If sig is 0 +!! (the null signal), error checking is performed but no signal is actually +!! sent. The null signal can be used to check the validity of pid. +!! +!! For a process to have permission to send a signal to a process designated +!! by pid, unless the sending process has appropriate privileges, the real +!! or effective user ID of the sending process shall match the real or +!! saved set-user-ID of the receiving process. +!! +!! If pid is greater than 0, sig shall be sent to the process whose process +!! ID is equal to pid. +!! +!! If pid is 0, sig shall be sent to all processes (excluding an unspecified +!! set of system processes) whose process group ID is equal to the process +!! group ID of the sender, and for which the process has permission to send +!! a signal. +!! +!! If pid is -1, sig shall be sent to all processes (excluding an unspecified +!! set of system processes) for which the process has permission to send +!! that signal. +!! +!! If pid is negative, but not -1, sig shall be sent to all processes +!! (excluding an unspecified set of system processes) whose process group +!! ID is equal to the absolute value of pid, and for which the process has +!! permission to send a signal. +!! +!! If the value of pid causes sig to be generated for the sending process, +!! and if sig is not blocked for the calling thread and if no other thread +!! has sig unblocked or is waiting in a sigwait() function for sig, either +!! sig or at least one pending unblocked signal shall be delivered to the +!! sending thread before kill() returns. +!! +!! The user ID tests described above shall not be applied when sending +!! SIGCONT to a process that is a member of the same session as the sending +!! process. +!! +!! An implementation that provides extended security controls may impose +!! further implementation-defined restrictions on the sending of signals, +!! including the null signal. In particular, the system may deny the +!! existence of some or all of the processes specified by pid. +!! +!! The kill() function is successful if the process has permission to send +!! sig to any of the processes specified by pid. If kill() fails, no signal +!! shall be sent. +!! +!! +!!##RETURN VALUE +!! +!! Upon successful completion, 0 shall be returned. Otherwise, -1 shall be +!! returned and errno set to indicate the error. +!! +!!##ERRORS +!! The kill() function shall fail if: +!! +!! EINVAL The value of the sig argument is an invalid or unsupported +!! signal number. +!! EPERM The process does not have permission to send the signal to +!! any receiving process. +!! ESRCH No process or process group can be found corresponding to +!! that specified by pid. The following sections are informative. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_kill +!! use M_system, only : system_kill +!! use M_system, only : system_perror +!! implicit none +!! integer :: i,pid,ios,ierr,signal=9 +!! character(len=80) :: argument +!! +!! do i=1,command_argument_count() +!! ! get arguments from command line +!! call get_command_argument(i, argument) +!! ! convert arguments to integers assuming they are PID numbers +!! read(argument,'(i80)',iostat=ios) pid +!! if(ios.ne.0)then +!! write(*,*)'bad PID=',trim(argument) +!! else +!! write(*,*)'kill SIGNAL=',signal,' PID=',pid +!! ! send signal SIGNAL to pid PID +!! ierr=system_kill(pid,signal) +!! ! write message if an error was detected +!! if(ierr.ne.0)then +!! call system_perror('*demo_system_kill*') +!! endif +!! endif +!! enddo +!! end program demo_system_kill +!! +!!##SEE ALSO +!! getpid(), raise(), setsid(), sigaction(), sigqueue(), + +! int kill(pid_t pid, int sig); +INTERFACE + FUNCTION system_kill(c_pid, c_signal) BIND(c, name="kill") RESULT(c_ierr) + IMPORT C_INT + INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_pid + INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_signal + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_errno(3f) - [M_system:ERROR_PROCESSING] C error return value +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_errno() +!! +!!##DESCRIPTION +!! Many C routines return an error code which can be queried by errno. +!! The M_system(3fm) is primarily composed of Fortran routines that call +!! C routines. In the cases where an error code is returned vi system_errno(3f) +!! these routines will indicate it. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_errno +!! use M_system, only : system_errno, system_unlink, system_perror +!! implicit none +!! integer :: stat +!! stat=system_unlink('not there/OR/anywhere') +!! if(stat.ne.0)then +!! write(*,*)'err=',system_errno() +!! call system_perror('*demo_system_errno*') +!! endif +!! end program demo_system_errno +!! +!! Typical Results: +!! +!! err= 2 +!! *demo_system_errno*: No such file or directory + +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_errno() BIND(C, name="my_errno") + IMPORT C_INT + END FUNCTION system_errno +END INTERFACE +!-! if a macro on XLF +!-! interface system_errno +!-! function ierrno_() bind(c, name="ierrno_") +!-! import c_int +!-! integer(kind=c_int) :: ierrno_ +!-! end function system_errno +!-! end interface +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_geteuid(3f) - [M_system:QUERY] get effective UID of current process from Fortran by calling geteuid(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_geteuid() +!! +!!##DESCRIPTION +!! The system_geteuid(3f) function shall return the effective user +!! ID of the calling process. The geteuid() function shall always be +!! successful and no return value is reserved to indicate the error. +!!##EXAMPLE +!! +!! Get group ID from Fortran: +!! +!! program demo_system_geteuid +!! use M_system, only : system_geteuid +!! implicit none +!! write(*,*)'EFFECTIVE UID=',system_geteuid() +!! end program demo_system_geteuid +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_geteuid() BIND(C, name="geteuid") + IMPORT C_INT + END FUNCTION system_geteuid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getuid(3f) - [M_system:QUERY] get real UID of current process from Fortran by calling getuid(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_getuid() +!! +!!##DESCRIPTION +!! The system_getuid(3f) function shall return the real user ID +!! of the calling process. The getuid() function shall always be +!! successful and no return value is reserved to indicate the error. +!!##EXAMPLE +!! +!! Get group ID from Fortran: +!! +!! program demo_system_getuid +!! use M_system, only : system_getuid +!! implicit none +!! write(*,*)'UID=',system_getuid() +!! end program demo_system_getuid +!! +!! Results: +!! +!! UID= 197609 +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_getuid() BIND(C, name="getuid") + IMPORT C_INT + END FUNCTION system_getuid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getegid(3f) - [M_system:QUERY] get the effective group ID (GID) of current process from Fortran by calling getegid(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_getegid() +!!##DESCRIPTION +!! The getegid() function returns the effective group ID of the +!! calling process. +!! +!!##RETURN VALUE +!! The getegid() should always be successful and no return value is +!! reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(), +!! setregid(), setreuid(), setuid() +!! +!!##EXAMPLE +!! +!! Get group ID from Fortran +!! +!! program demo_system_getegid +!! use M_system, only : system_getegid +!! implicit none +!! write(*,*)'GID=',system_getegid() +!! end program demo_system_getegid +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_getegid() BIND(C, name="getegid") + IMPORT C_INT + END FUNCTION system_getegid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getgid(3f) - [M_system:QUERY] get the real group ID (GID) of current process from Fortran by calling getgid(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_getgid() +!!##DESCRIPTION +!! The getgid() function returns the real group ID of the calling process. +!! +!!##RETURN VALUE +!! The getgid() should always be successful and no return value is +!! reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(), +!! setregid(), setreuid(), setuid() +!! +!!##EXAMPLE +!! +!! Get group ID from Fortran +!! +!! program demo_system_getgid +!! use M_system, only : system_getgid +!! implicit none +!! write(*,*)'GID=',system_getgid() +!! end program demo_system_getgid +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_getgid() BIND(C, name="getgid") + IMPORT C_INT + END FUNCTION system_getgid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_setsid(3f) - [M_system:QUERY] create session and set the process group ID of a session leader +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_setsid(pid) +!! integer(kind=c_int) :: pid +!!##DESCRIPTION +!! The setsid() function creates a new session, if the calling process is not a process group leader. Upon return the +!! calling process shall be the session leader of this new session, shall be the process group leader of a new process +!! group, and shall have no controlling terminal. The process group ID of the calling process shall be set equal to the +!! process ID of the calling process. The calling process shall be the only process in the new process group and the only +!! process in the new session. +!! +!!##RETURN VALUE +!! Upon successful completion, setsid() shall return the value of the new process group ID of the calling process. Otherwise, +!! it shall return �-1 and set errno to indicate the error. +!!##ERRORS +!! The setsid() function shall fail if: +!! +!! o The calling process is already a process group leader +!! o the process group ID of a process other than the calling process matches the process ID of the calling process. +!!##EXAMPLE +!! +!! Set SID from Fortran +!! +!! program demo_system_setsid +!! use M_system, only : system_setsid +!! implicit none +!! write(*,*)'SID=',system_setsid() +!! end program demo_system_setsid +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_setsid() BIND(C, name="setsid") + IMPORT C_INT + END FUNCTION system_setsid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getsid(3f) - [M_system:QUERY] get the process group ID of a session leader +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_getsid(pid) +!! integer(kind=c_int) :: pid +!!##DESCRIPTION +!! The system_getsid() function obtains the process group ID of the +!! process that is the session leader of the process specified by pid. +!! If pid is 0, it specifies the calling process. +!!##RETURN VALUE +!! Upon successful completion, system_getsid() shall return the process group +!! ID of the session leader of the specified process. Otherwise, +!! it shall return -1 and set errno to indicate the error. +!!##EXAMPLE +!! +!! Get SID from Fortran +!! +!! program demo_system_getsid +!! use M_system, only : system_getsid +!! use ISO_C_BINDING, only : c_int +!! implicit none +!! write(*,*)'SID=',system_getsid(0_c_int) +!! end program demo_system_getsid +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_getsid(c_pid) BIND(C, name="getsid") + IMPORT C_INT + INTEGER(kind=C_INT) :: c_pid + END FUNCTION system_getsid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getpid(3f) - [M_system:QUERY] get PID (process ID) of current process from Fortran by calling getpid(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer function system_getpid() +!!##DESCRIPTION +!! The system_getpid() function returns the process ID of the +!! calling process. +!!##RETURN VALUE +!! The value returned is the integer process ID. The system_getpid() +!! function shall always be successful and no return value is reserved +!! to indicate an error. +!!##EXAMPLE +!! +!! Get process PID from Fortran +!! +!! program demo_system_getpid +!! use M_system, only : system_getpid +!! implicit none +!! write(*,*)'PID=',system_getpid() +!! end program demo_system_getpid + +INTERFACE + PURE INTEGER(kind=C_INT) FUNCTION system_getpid() BIND(C, name="getpid") + IMPORT C_INT + END FUNCTION system_getpid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getppid(3f) - [M_system:QUERY] get parent process ID (PPID) of current process from Fortran by calling getppid(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_getppid() +!!##DESCRIPTION +!! The system_getppid() function returns the parent process ID of +!! the calling process. +!! +!!##RETURN VALUE +!! The system_getppid() function should always be successful and no +!! return value is reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! exec, fork(), getpgid(), getpgrp(), getpid(), kill(), +!! setpgid(), setsid() +!! +!!##EXAMPLE +!! +!! Get parent process PID (PPID) from Fortran +!! +!! program demo_system_getppid +!! use M_system, only : system_getppid +!! implicit none +!! write(*,*)'PPID=',system_getppid() +!! end program demo_system_getppid +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_getppid() BIND(C, name="getppid") + IMPORT C_INT + END FUNCTION system_getppid +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_umask(3fp) - [M_system] set and get the file mode creation mask +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) function system_umask(umask_value) +!! +!!##DESCRIPTION +!! The system_umask() function shall set the file mode creation mask of the +!! process to cmask and return the previous value of the mask. Only +!! the file permission bits of cmask (see ) are used; +!! the meaning of the other bits is implementation-defined. +!! +!! The file mode creation mask of the process is used to turn off +!! permission bits in the mode argument supplied during calls to +!! the following functions: +!! +!! * open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat() +!! * mknod(), mknodat() +!! * mq_open() +!! * sem_open() +!! +!! Bit positions that are set in cmask are cleared in the mode of the created file. +!! +!!##RETURN VALUE +!! The file permission bits in the value returned by umask() shall be +!! the previous value of the file mode creation mask. The state of any +!! other bits in that value is unspecified, except that a subsequent +!! call to umask() with the returned value as cmask shall leave the +!! state of the mask the same as its state before the first call, +!! including any unspecified use of those bits. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_umask +!! use M_system, only : system_getumask, system_setumask +!! implicit none +!! integer value +!! integer mask +!! mask=O'002' +!! value=system_setumask(mask) +!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'OLD VALUE=',value,value +!! value=system_getumask() +!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'MASK=',mask,mask +!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'NEW VALUE=',value,value +!! end program demo_system_umask +!! +!! Expected results: +!! +!! OLD VALUE=octal=0022 decimal=18 +!! MASK=octal=0002 decimal=2 +!! NEW VALUE=octal=0002 decimal=2 +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_umask(umask_value) BIND(C, name="umask") + IMPORT C_INT + INTEGER(kind=C_INT), VALUE :: umask_value + END FUNCTION system_umask +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_rand(3f) - [M_system:PSEUDORANDOM] call pseudo-random number generator rand(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer(kind=c_int) :: function system_rand() +!!##DESCRIPTION +!! Use rand(3c) to generate pseudo-random numbers. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_rand +!! use M_system, only : system_srand, system_rand +!! implicit none +!! integer :: i +!! +!! call system_srand(1001) +!! do i=1,10 +!! write(*,*)system_rand() +!! enddo +!! write(*,*) +!! +!! end program demo_system_rand +!! expected results: +!! +!! 1512084687 +!! 1329390995 +!! 1874040748 +!! 60731048 +!! 239808950 +!! 2017891911 +!! 22055588 +!! 1105177318 +!! 347750200 +!! 1729645355 +!! +!! 1512084687 +!! 1329390995 +!! 1874040748 +!! 60731048 +!! 239808950 +!! 2017891911 +!! 22055588 +!! 1105177318 +!! 347750200 +!! 1729645355 +INTERFACE + INTEGER(kind=C_INT) FUNCTION system_rand() BIND(C, name="rand") + IMPORT C_INT + END FUNCTION system_rand +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + SUBROUTINE c_flush() BIND(C, name="my_flush") + END SUBROUTINE c_flush +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_initenv(3f) - [M_system:ENVIRONMENT] initialize environment table pointer and size so table can be read by readenv(3f) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_initenv() +!!##DESCRIPTION +!! A simple interface allows reading the environment variable table +!! of the process. Call system_initenv(3f) to initialize reading the +!! environment table, then call system_readenv(3f) until a blank line +!! is returned. If more than one thread reads the environment or the +!! environment is changed while being read the results are undefined. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_initenv +!! use M_system, only : system_initenv, system_readenv +!! character(len=:),allocatable :: string +!! call system_initenv() +!! do +!! string=system_readenv() +!! if(string.eq.'')then +!! exit +!! else +!! write(*,'(a)')string +!! endif +!! enddo +!! end program demo_system_initenv +!! +!! Sample results: +!! +!! USERDOMAIN_ROAMINGPROFILE=buzz +!! HOMEPATH=\Users\JSU +!! APPDATA=C:\Users\JSU\AppData\Roaming +!! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man::: +!! DISPLAYNUM=0 +!! ProgramW6432=C:\Program Files +!! HOSTNAME=buzz +!! XKEYSYMDB=/usr/share/X11/XKeysymDB +!! PUBLISH_CMD= +!! OnlineServices=Online Services +!! : +!! : +!! : + +integer(kind=c_long),bind(c,name="longest_env_variable") :: longest_env_variable + +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +INTERFACE + SUBROUTINE system_initenv() BIND(C, NAME='my_initenv') + END SUBROUTINE system_initenv +END INTERFACE +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!-!type(c_ptr),bind(c,name="environ") :: c_environ + +INTEGER(kind=mode_t), BIND(c, name="FS_IRGRP") :: R_GRP +INTEGER(kind=mode_t), BIND(c, name="FS_IROTH") :: R_OTH +INTEGER(kind=mode_t), BIND(c, name="FS_IRUSR") :: R_USR +INTEGER(kind=mode_t), BIND(c, name="FS_IRWXG") :: RWX_G +INTEGER(kind=mode_t), BIND(c, name="FS_IRWXO") :: RWX_O +INTEGER(kind=mode_t), BIND(c, name="FS_IRWXU") :: RWX_U +INTEGER(kind=mode_t), BIND(c, name="FS_IWGRP") :: W_GRP +INTEGER(kind=mode_t), BIND(c, name="FS_IWOTH") :: W_OTH +INTEGER(kind=mode_t), BIND(c, name="FS_IWUSR") :: W_USR +INTEGER(kind=mode_t), BIND(c, name="FS_IXGRP") :: X_GRP +INTEGER(kind=mode_t), BIND(c, name="FS_IXOTH") :: X_OTH +INTEGER(kind=mode_t), BIND(c, name="FS_IXUSR") :: X_USR +INTEGER(kind=mode_t), BIND(c, name="FDEFFILEMODE") :: DEFFILEMODE +INTEGER(kind=mode_t), BIND(c, name="FACCESSPERMS") :: ACCESSPERMS + +! Host names are limited to {HOST_NAME_MAX} bytes. +INTEGER(kind=mode_t), BIND(c, name="FHOST_NAME_MAX") :: HOST_NAME_MAX +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +! for system_access(3f) +!integer(kind=c_int),bind(c,name="F_OK") :: F_OK +!integer(kind=c_int),bind(c,name="R_OK") :: R_OK +!integer(kind=c_int),bind(c,name="W_OK") :: W_OK +!integer(kind=c_int),bind(c,name="X_OK") :: X_OK +! not sure these will be the same on all systems, but above did not work +INTEGER(kind=C_INT), PARAMETER :: F_OK = 0 +INTEGER(kind=C_INT), PARAMETER :: R_OK = 4 +INTEGER(kind=C_INT), PARAMETER :: W_OK = 2 +INTEGER(kind=C_INT), PARAMETER :: X_OK = 1 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +ABSTRACT INTERFACE ! mold for signal handler to be installed by system_signal + SUBROUTINE handler(signum) + INTEGER :: signum + END SUBROUTINE handler +END INTERFACE +TYPE handler_pointer + PROCEDURE(handler), POINTER, NOPASS :: sub +END TYPE handler_pointer +INTEGER, PARAMETER :: no_of_signals = 64 ! obtained with command: kill -l +TYPE(handler_pointer), DIMENSION(no_of_signals) :: handler_ptr_array +!=================================================================================================================================== +CONTAINS +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_signal(3f) - [M_system:SIGNALS] install a signal handler +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine system_signal(sig,handler) +!! +!! integer,intent(in) :: sig +!! interface +!! subroutine handler(signum) +!! integer :: signum +!! end subroutine handler +!! end interface +!! optional :: handler +!! +!!##DESCRIPTION +!! Calling system_signal(NUMBER, HANDLER) causes user-defined +!! subroutine HANDLER to be executed when the signal NUMBER is +!! caught. The same subroutine HANDLER maybe installed to handle +!! different signals. HANDLER takes only one integer argument which +!! is assigned the signal number that is caught. See sample program +!! below for illustration. +!! +!! Calling system_signal(NUMBER) installs a do-nothing handler. This +!! is not equivalent to ignoring the signal NUMBER though, because +!! the signal can still interrupt any sleep or idle-wait. +!! +!! Note that the signals SIGKILL and SIGSTOP cannot be handled +!! this way. +!! +!! [Compare signal(2) and the GNU extension signal in gfortran.] +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_signal +!! use M_system, only : system_signal +!! implicit none +!! logical :: loop=.true. +!! integer, parameter :: SIGINT=2,SIGQUIT=3 +!! call system_signal(SIGINT,exitloop) +!! call system_signal(SIGQUIT,quit) +!! write(*,*)'Starting infinite loop. Press Ctrl+C to exit.' +!! do while(loop) +!! enddo +!! write(*,*)'Reporting from outside the infinite loop.' +!! write(*,*)'Starting another loop. Do Ctrl+\ anytime to quit.' +!! loop=.true. +!! call system_signal(2) +!! write(*,*)'Just installed do-nothing handler for SIGINT. Try Ctrl+C to test.' +!! do while(loop) +!! enddo +!! write(*,*)'You should never see this line when running this demo.' +!! +!! contains +!! +!! subroutine exitloop(signum) +!! integer :: signum +!! write(*,*)'Caught SIGINT. Exiting infinite loop.' +!! loop=.false. +!! end subroutine exitloop +!! +!! subroutine quit(signum) +!! integer :: signum +!! STOP 'Caught SIGQUIT. Stopping demo.' +!! end subroutine quit +!! end program demo_system_signal +!! +!!##AUTHOR +!! Somajit Dey +!! +!!##LICENSE +!! Public Domain +SUBROUTINE system_signal(signum, handler_routine) + INTEGER, INTENT(in) :: signum + PROCEDURE(handler), OPTIONAL :: handler_routine + TYPE(C_FUNPTR) :: ret, c_handler + + INTERFACE + FUNCTION c_signal(signal, sighandler) BIND(c, name='signal') + IMPORT :: C_INT, C_FUNPTR + INTEGER(C_INT), VALUE, INTENT(in) :: signal + TYPE(C_FUNPTR), VALUE, INTENT(in) :: sighandler + TYPE(C_FUNPTR) :: c_signal + END FUNCTION c_signal + END INTERFACE + + IF (PRESENT(handler_routine)) THEN + handler_ptr_array(signum)%sub => handler_routine + ELSE + !!handler_ptr_array(signum)%sub => null(handler_ptr_array(signum)%sub) + handler_ptr_array(signum)%sub => NULL() + END IF + c_handler = C_FUNLOC(f_handler) + ret = c_signal(signum, c_handler) +END SUBROUTINE system_signal + +SUBROUTINE f_handler(signum) BIND(c) + INTEGER(C_INT), INTENT(in), VALUE :: signum + if(associated(handler_ptr_array(signum)%sub))call handler_ptr_array(signum)%sub(signum) +END SUBROUTINE f_handler +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_access(3f) - [M_system:QUERY_FILE] checks accessibility or existence of a pathname +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_access(pathname,amode) +!! +!! character(len=*),intent(in) :: pathname +!! integer,intent(in) :: amode +!! +!!##DESCRIPTION +!! +!! The system_access(3f) function checks pathname existence and access +!! permissions. The function checks the pathname for accessibility +!! according to the bit pattern contained in amode, using the real user +!! ID in place of the effective user ID and the real group ID in place +!! of the effective group ID. +!! +!! The value of amode is either the bitwise-inclusive OR of the access +!! permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). +!! +!!##OPTIONS +!! pathname a character string representing a directory pathname. Trailing spaces are ignored. +!! amode bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. +!! +!!##RETURN VALUE +!! If not true an error occurred or the requested access is not granted +!! +!!##EXAMPLE +!! +!! check if filename is accessible +!! +!! Sample program: +!! +!! program demo_system_access +!! use M_system, only : system_access, F_OK, R_OK, W_OK, X_OK +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! '/usr/bin/bash ', & +!! '/tmp/NOTTHERE ', & +!! '/usr/local ', & +!! '. ', & +!! 'PROBABLY_NOT '] +!! do i=1,size(names) +!! write(*,*)' does ',trim(names(i)),' exist? ', system_access(names(i),F_OK) +!! write(*,*)' is ',trim(names(i)),' readable? ', system_access(names(i),R_OK) +!! write(*,*)' is ',trim(names(i)),' writable? ', system_access(names(i),W_OK) +!! write(*,*)' is ',trim(names(i)),' executable? ', system_access(names(i),X_OK) +!! enddo +!! end program demo_system_access +ELEMENTAL impure FUNCTION system_access(pathname, amode) + IMPLICIT NONE + +! ident_1="@(#)M_system::system_access(3f): checks accessibility or existence of a pathname" + + CHARACTER(len=*), INTENT(in) :: pathname + INTEGER, INTENT(in) :: amode + LOGICAL :: system_access + + INTERFACE + function c_access(c_pathname,c_amode) bind (C,name="my_access") result (c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) + INTEGER(kind=C_INT), VALUE :: c_amode + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_access + END INTERFACE + + IF (c_access(str2_carr(TRIM(pathname)), INT(amode, kind=C_INT)) .EQ. 0) THEN + system_access = .TRUE. + ELSE + system_access = .FALSE. + !!if(system_errno().ne.0)then + !! call perror('*system_access*') + !!endif + END IF + +END FUNCTION system_access +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_utime(3f) - [M_system:FILE_SYSTEM] set file access and modification times +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function utime(pathname,times) +!! +!! character(len=*),intent(in) :: pathname +!! integer,intent(in),optional :: times(2) +!! logical :: utime +!! +!!##DESCRIPTION +!! The system_utime(3f) function sets the access and modification +!! times of the file named by the path argument by calling utime(3c). +!! +!! If times() is not present the access and modification times of +!! the file shall be set to the current time. +!! +!! To use system_utime(3f) the effective user ID of the process must +!! match the owner of the file, or the process has to have write +!! permission to the file or have appropriate privileges, +!! +!!##OPTIONS +!! times If present, the values will be interpreted as the access +!! and modification times as Unix Epoch values. That is, +!! they are times measured in seconds since the Unix Epoch. +!! +!! pathname name of the file whose access and modification times +!! are to be updated. +!! +!!##RETURN VALUE +!! Upon successful completion .TRUE. is returned. Otherwise, +!! .FALSE. is returned and errno shall be set to indicate the error, +!! and the file times remain unaffected. +!! +!!##ERRORS +!! The underlying utime(3c) function fails if: +!! +!! EACCES Search permission is denied by a component of the path +!! prefix; or the times argument is a null pointer and the +!! effective user ID of the process does not match the owner +!! of the file, the process does not have write permission +!! for the file, and the process does not have appropriate +!! privileges. +!! +!! ELOOP A loop exists in symbolic links encountered during +!! resolution of the path argument. +!! +!! ENAMETOOLONG The length of a component of a pathname is longer +!! than {NAME_MAX}. +!! +!! ENOENT A component of path does not name an existing file +!! or path is an empty string. +!! +!! ENOTDIR A component of the path prefix names an existing file +!! that is neither a directory nor a symbolic link to a +!! directory, or the path argument contains at least one +!! non- character and ends with one or more trailing +!! characters and the last pathname component +!! names an existing file that is neither a directory nor +!! a symbolic link to a directory. +!! +!! EPERM The times argument is not a null pointer and the effective +!! user ID of the calling process does not match the owner +!! of the file and the calling process does not have +!! appropriate privileges. +!! +!! EROFS The file system containing the file is read-only. +!! +!! The utime() function may fail if: +!! +!! ELOOP More than {SYMLOOP_MAX} symbolic links were encountered +!! during resolution of the path argument. +!! +!! ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, or +!! pathname resolution of a symbolic link produced +!! an intermediate result with a length that exceeds +!! {PATH_MAX}. +!! +!!##EXAMPLES +!! +!! Sample program +!! +!! program demo_system_utime +!! use M_system, only : system_utime, system_perror +!! implicit none +!! character(len=4096) :: pathname +!! integer :: times(2) +!! integer :: i +!! do i=1,command_argument_count() +!! call get_command_argument(i, pathname) +!! if(.not.system_utime(pathname,times))then +!! call system_perror('*demo_system_utime*') +!! endif +!! enddo +!! end program demo_system_utime +FUNCTION system_utime(pathname, times) + IMPLICIT NONE + +! ident_2="@(#)M_system::system_utime(3f): set access and modification times of a pathname" + + CHARACTER(len=*), INTENT(in) :: pathname + INTEGER, INTENT(in), OPTIONAL :: times(2) + INTEGER :: times_local(2) + LOGICAL :: system_utime + +!-! int my_utime(const char *path, int times[2]) + INTERFACE + FUNCTION c_utime(c_pathname, c_times) BIND(C, name="my_utime") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) + INTEGER(kind=C_INT), INTENT(in) :: c_times(2) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_utime + END INTERFACE + IF (PRESENT(times)) THEN + times_local = times + ELSE + times_local = timestamp() + END IF + if(c_utime(str2_carr(trim(pathname)),int(times_local,kind=c_int)).eq.0)then + system_utime = .TRUE. + ELSE + system_utime = .FALSE. + !!if(system_errno().ne.0)then + !! call perror('*system_utime*') + !!endif + END IF + +END FUNCTION system_utime +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +FUNCTION timestamp() RESULT(epoch) + USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_LONG + IMPLICIT NONE + INTEGER(kind=8) :: epoch + INTERFACE + ! time_t time(time_t *tloc) + FUNCTION c_time(tloc) BIND(c, name='time') + IMPORT :: C_LONG + INTEGER(kind=C_LONG), INTENT(in), VALUE :: tloc + INTEGER(kind=C_LONG) :: c_time + END FUNCTION c_time + END INTERFACE + epoch = c_time(INT(0, kind=8)) +END FUNCTION timestamp +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_realpath(3f) - [M_system:FILE_SYSTEM] call realpath(3c) to resolve a pathname +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function system_realpath(input) result(output) +!! +!! character(len=*),intent(in) :: input +!! character(len=:),allocatable :: output +!!##DESCRIPTION +!! system_realpath(3f) calls the C routine realpath(3c) to obtain the absolute pathname of given path +!!##OPTIONS +!! +!! INPUT pathname to resolve +!! +!!##RETURN VALUE +!! OUTPUT The absolute pathname of the given input pathname. +!! The pathname shall contain no components that are dot +!! or dot-dot, or are symbolic links. It is equal to the +!! NULL character if an error occurred. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_realpath +!! use M_system, only : system_realpath, system_perror +!! implicit none +!! ! resolve each pathname given on command line +!! character(len=:),allocatable :: pathi,patho +!! integer :: i +!! integer :: filename_length +!! do i = 1, command_argument_count() +!! ! get pathname from command line arguments +!! call get_command_argument (i , length=filename_length) +!! if(allocated(pathi))deallocate(pathi) +!! allocate(character(len=filename_length) :: pathi) +!! call get_command_argument (i , value=pathi) +!! ! +!! ! resolve each pathname +!! patho=system_realpath(pathi) +!! if(patho.ne.char(0))then +!! write(*,*)trim(pathi),'=>',trim(patho) +!! else +!! call system_perror('*system_realpath* error for pathname '//trim(pathi)//':') +!! write(*,*)trim(pathi),'=>',trim(patho) +!! endif +!! deallocate(pathi) +!! enddo +!! ! if there were no pathnames given resolve the pathname "." +!! if(i.eq.1)then +!! patho=system_realpath('.') +!! write(*,*)'.=>',trim(patho) +!! endif +!! end program demo_system_realpath +!! +!! Example usage: +!! +!! demo_system_realpath +!! .=>/home/urbanjs/V600 +!! +!! cd /usr/share/man +!! demo_system_realpath . .. NotThere +!! .=>/usr/share/man +!! ..=>/usr/share +!! *system_realpath* error for pathname NotThere:: No such file or directory +!! NotThere=>NotThere +FUNCTION system_realpath(input) RESULT(string) + +! ident_3="@(#)M_system::system_realpath(3f):call realpath(3c) to get pathname of current working directory" + + CHARACTER(len=*), INTENT(in) :: input + TYPE(C_PTR) :: c_output + CHARACTER(len=:), ALLOCATABLE :: string + INTERFACE + FUNCTION c_realpath(c_input) BIND(c, name="my_realpath") RESULT(c_buffer) + IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT + CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) + TYPE(C_PTR) :: c_buffer + END FUNCTION + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + c_output = c_realpath(str2_carr(TRIM(input))) + IF (.NOT. C_ASSOCIATED(c_output)) THEN + string = CHAR(0) + ELSE + string = C2F_string(c_output) + END IF +END FUNCTION system_realpath +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_issock(3f) - [M_system:QUERY_FILE] checks if argument is a socket +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_issock(pathname) +!! +!! character(len=*),intent(in) :: pathname +!! logical :: system_issock +!! +!!##DESCRIPTION +!! The issock(3f) function checks if path is a path to a socket +!! +!!##OPTIONS +!! path a character string representing a socket pathname. Trailing spaces are ignored. +!! +!!##RETURN VALUE +!! The system_issock() function should always be successful and no +!! return value is reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) +!! +!!##EXAMPLE +!! +!! check if filename is a socket +!! +!! program demo_system_issock +!! use M_system, only : system_issock +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! '/tmp ', & +!! '/tmp/NOTTHERE ', & +!! '/usr/local ', & +!! '. ', & +!! 'sock.test ', & +!! 'PROBABLY_NOT '] +!! do i=1,size(names) +!! write(*,*)' is ',trim(names(i)),' a socket? ', system_issock(names(i)) +!! enddo +!! end program demo_system_issock +FUNCTION system_issock(pathname) + IMPLICIT NONE + +! ident_4="@(#)M_system::system_issock(3f): determine if pathname is a socket" + + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: system_issock + + INTERFACE + FUNCTION c_issock(pathname) BIND(C, name="my_issock") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_issock + END INTERFACE + + IF (c_issock(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_issock = .TRUE. + ELSE + system_issock = .FALSE. + END IF + +END FUNCTION system_issock +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_isfifo(3f) - [M_system:QUERY_FILE] checks if argument is a fifo - named pipe +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_isfifo(pathname) +!! +!! character(len=*),intent(in) :: pathname +!! logical :: system_isfifo +!! +!!##DESCRIPTION +!! The isfifo(3f) function checks if path is a path to a fifo - named pipe. +!! +!!##OPTIONS +!! path a character string representing a fifo - named pipe pathname. Trailing spaces are ignored. +!! +!!##RETURN VALUE +!! The system_isfifo() function should always be successful and no +!! return value is reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) +!! +!!##EXAMPLE +!! +!! check if filename is a FIFO file +!! +!! program demo_system_isfifo +!! use M_system, only : system_isfifo +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! '/tmp ', & +!! '/tmp/NOTTHERE ', & +!! '/usr/local ', & +!! '. ', & +!! 'fifo.test ', & +!! 'PROBABLY_NOT '] +!! do i=1,size(names) +!! write(*,*)' is ',trim(names(i)),' a fifo(named pipe)? ', system_isfifo(names(i)) +!! enddo +!! end program demo_system_isfifo +ELEMENTAL impure FUNCTION system_isfifo(pathname) + IMPLICIT NONE + +! ident_5="@(#)M_system::system_isfifo(3f): determine if pathname is a fifo(named pipe)" + + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: system_isfifo + + INTERFACE + FUNCTION c_isfifo(pathname) BIND(C, name="my_isfifo") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isfifo + END INTERFACE + + IF (c_isfifo(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_isfifo = .TRUE. + ELSE + system_isfifo = .FALSE. + END IF + +END FUNCTION system_isfifo +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_ischr(3f) - [M_system:QUERY_FILE] checks if argument is a character device +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_ischr(pathname) +!! +!! character(len=*),intent(in) :: pathname +!! logical :: system_ischr +!! +!!##DESCRIPTION +!! The ischr(3f) function checks if path is a path to a character device. +!! +!!##OPTIONS +!! path a character string representing a character device pathname. Trailing spaces are ignored. +!! +!!##RETURN VALUE +!! The system_ischr() function should always be successful and no +!! return value is reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) +!! +!!##EXAMPLE +!! +!! check if filename is a character file +!! +!! program demo_system_ischr +!! use M_system, only : system_ischr +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! '/tmp ', & +!! '/tmp/NOTTHERE ', & +!! '/usr/local ', & +!! '. ', & +!! 'char_dev.test ', & +!! 'PROBABLY_NOT '] +!! do i=1,size(names) +!! write(*,*)' is ',trim(names(i)),' a character device? ', system_ischr(names(i)) +!! enddo +!! end program demo_system_ischr +!! +!! Results: +ELEMENTAL impure FUNCTION system_ischr(pathname) + IMPLICIT NONE + +! ident_6="@(#)M_system::system_ischr(3f): determine if pathname is a link" + + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: system_ischr + + INTERFACE + FUNCTION c_ischr(pathname) BIND(C, name="my_ischr") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_ischr + END INTERFACE + + IF (c_ischr(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_ischr = .TRUE. + ELSE + system_ischr = .FALSE. + END IF + +END FUNCTION system_ischr +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_isreg(3f) - [M_system:QUERY_FILE] checks if argument is a regular file +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_isreg(pathname) +!! +!! character(len=*),intent(in) :: pathname +!! logical :: system_isreg +!! +!!##DESCRIPTION +!! The isreg(3f) function checks if path is a regular file +!! +!!##OPTIONS +!! path a character string representing a pathname. Trailing spaces are ignored. +!! +!!##RETURN VALUE +!! The system_isreg() function should always be successful and no +!! return value is reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! system_islnk(3f), system_stat(3f), system_isdir(3f), system_perm(3f) +!! +!!##EXAMPLE +!! +!! check if filename is a regular file +!! +!! program simple +!! use M_system, only : system_isreg +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! '/tmp ', & +!! 'test.txt ', & +!! '~/.bashrc ', & +!! '.bashrc ', & +!! '. '] +!! do i=1,size(names) +!! write(*,*)' is ',trim(names(i)),' a regular file? ', system_isreg(names(i)) +!! enddo +!! end program simple +!! +!! EXTENDED EXAMPLE +!! list readable non-hidden regular files and links in current directory +!! +!! program demo_system_isreg +!! use M_system, only : isreg=>system_isreg, islnk=>system_islnk +!! use M_system, only : access=>system_access, R_OK +!! use M_system, only : system_dir +!! implicit none +!! character(len=1024),allocatable :: filenames(:) ! BUG: cannot use len=: in gfortran 8.3.1 +!! logical,allocatable :: mymask(:) +!! integer :: i +!! ! list readable non-hidden regular files and links in current directory +!! filenames=system_dir(pattern='*') ! make list of all files in current directory +!! mymask= isreg(filenames).or.islnk(filenames) ! select regular files and links +!! where(mymask) mymask=filenames(:)(1:1).ne.'.' ! skip hidden directories in those +!! where(mymask) mymask=access(filenames,R_OK) ! select readable files in those +!! filenames=pack(filenames,mask=mymask) +!! write(*,'(a)')(trim(filenames(i)),i=1,size(filenames)) +!! end program demo_system_isreg +ELEMENTAL impure FUNCTION system_isreg(pathname) + IMPLICIT NONE + +! ident_7="@(#)M_system::system_isreg(3f): determine if pathname is a regular file" + + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: system_isreg + + INTERFACE + FUNCTION c_isreg(pathname) BIND(C, name="my_isreg") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isreg + END INTERFACE + + IF (c_isreg(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_isreg = .TRUE. + ELSE + system_isreg = .FALSE. + END IF + +END FUNCTION system_isreg +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_islnk(3f) - [M_system:QUERY_FILE] checks if argument is a link +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_islnk(pathname) +!! +!! character(len=*),intent(in) :: pathname +!! logical :: system_islnk +!! +!!##DESCRIPTION +!! The islnk(3f) function checks if path is a path to a link. +!! +!!##OPTIONS +!! path a character string representing a link +!! pathname. Trailing spaces are ignored. +!! +!!##RETURN VALUE +!! system_islnk The system_islnk() function should always be +!! successful and no return value is reserved to +!! indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) +!! +!!##EXAMPLE +!! +!! +!! Sample program: +!! +!! program demo_system_islnk +!! use M_system, only : system_islnk +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! '/tmp ', & +!! '/tmp/NOTTHERE ', & +!! '/usr/local ', & +!! '. ', & +!! 'link.test ', & +!! 'PROBABLY_NOT '] +!! do i=1,size(names) +!! write(*,*)' is ',trim(names(i)),' a link? ', system_islnk(names(i)) +!! enddo +!! end program demo_system_islnk +!! +!! Results: +ELEMENTAL impure FUNCTION system_islnk(pathname) + IMPLICIT NONE + +! ident_8="@(#)M_system::system_islnk(3f): determine if pathname is a link" + + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: system_islnk + + INTERFACE + FUNCTION c_islnk(pathname) BIND(C, name="my_islnk") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_islnk + END INTERFACE + + IF (c_islnk(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_islnk = .TRUE. + ELSE + system_islnk = .FALSE. + END IF + +END FUNCTION system_islnk +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_isblk(3f) - [M_system:QUERY_FILE] checks if argument is a block device +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_isblk(pathname) +!! +!! character(len=*),intent(in) :: pathname +!! logical :: system_isblk +!! +!!##DESCRIPTION +!! The isblk(3f) function checks if path is a path to a block device. +!! +!!##OPTIONS +!! path a character string representing a block device pathname. Trailing spaces are ignored. +!! +!!##RETURN VALUE +!! The system_isblk() function should always be successful and no +!! return value is reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) +!! +!!##EXAMPLE +!! +!! check if filename is a block device +!! +!! program demo_system_isblk +!! use M_system, only : system_isblk +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! '/tmp ', & +!! '/tmp/NOTTHERE ', & +!! '/usr/local ', & +!! '. ', & +!! 'block_device.tst', & +!! 'PROBABLY_NOT '] +!! do i=1,size(names) +!! write(*,*)' is ',trim(names(i)),' a block device? ', system_isblk(names(i)) +!! enddo +!! end program demo_system_isblk +!! +!! Results: +ELEMENTAL impure FUNCTION system_isblk(pathname) + IMPLICIT NONE + +! ident_9="@(#)M_system::system_isblk(3f): determine if pathname is a block device" + + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: system_isblk + + INTERFACE + FUNCTION c_isblk(pathname) BIND(C, name="my_isblk") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isblk + END INTERFACE + + IF (c_isblk(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_isblk = .TRUE. + ELSE + system_isblk = .FALSE. + END IF + +END FUNCTION system_isblk +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_isdir(3f) - [M_system:QUERY_FILE] checks if argument is a directory path +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_isdir(pathname) +!! +!! character(len=*),intent(in) :: pathname +!! logical :: system_isdir +!! +!!##DESCRIPTION +!! The system_isdir(3f) function checks if path is a directory. +!! +!!##OPTIONS +!! path a character string representing a directory pathname. Trailing spaces are ignored. +!! +!!##RETURN VALUE +!! The system_isdir() function should always be successful and no +!! return value is reserved to indicate an error. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##SEE ALSO +!! system_islnk(3f), system_stat(3f), isreg(3f), system_perm(3f) +!! +!!##EXAMPLE +!! +!! +!! Sample program +!! +!! program demo_system_isdir +!! use M_system, only : system_isdir +!! use M_system, only : access=>system_access, R_OK +!! use M_system, only : system_dir +!! implicit none +!! character(len=1024),allocatable :: filenames(:) ! BUG: cannot use len=: in gfortran 8.3.1 +!! integer :: i +!! character(len=80),parameter :: names(*)=[ & +!! & '/tmp ', & +!! & '/tmp/NOTTHERE ', & +!! & '/usr/local ', & +!! & '. ', & +!! & 'PROBABLY_NOT '] +!! ! +!! do i=1,size(names) +!! write(*,*)' is ',trim(names(i)),' a directory? ', system_isdir(names(i)) +!! enddo +!! ! +!! ! EXTENDED EXAMPLE: list readable non-hidden directories in current directory +!! filenames=system_dir(pattern='*') ! list all files in current directory +!! ! select readable directories +!! filenames=pack(filenames,system_isdir(filenames).and.access(filenames,R_OK)) +!! filenames=pack(filenames,filenames(:)(1:1) .ne.'.') ! skip hidden directories +!! do i=1,size(filenames) +!! write(*,*)' ',trim(filenames(i)),' is a directory' +!! enddo +!! ! +!! end program demo_system_isdir +!! +!! +!! Results: +!! +!! is /tmp a directory? T +!! is /tmp/NOTTHERE a directory? F +!! is /usr/local a directory? T +!! is . a directory? T +!! is PROBABLY_NOT a directory? F +!! +!! TEST is a directory +!! EXAMPLE is a directory +ELEMENTAL impure FUNCTION system_isdir(dirname) + IMPLICIT NONE + +! ident_10="@(#)M_system::system_isdir(3f): determine if DIRNAME is a directory name" + + CHARACTER(len=*), INTENT(in) :: dirname + LOGICAL :: system_isdir + + INTERFACE + FUNCTION c_isdir(dirname) BIND(C, name="my_isdir") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: dirname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isdir + END INTERFACE + + IF (c_isdir(str2_carr(TRIM(dirname))) .EQ. 1) THEN + system_isdir = .TRUE. + ELSE + system_isdir = .FALSE. + END IF + +END FUNCTION system_isdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_chown(3f) - [M_system:FILE_SYSTEM] change file owner and group +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure logical function system_chown(path,owner,group) +!! +!! character(len=*),intent(in) :: path +!! integer,intent(in) :: owner +!! integer,intent(in) :: group +!! +!!##DESCRIPTION +!! The chown(3f) function changes owner and group of a file +!! +!! The path argument points to a pathname naming a file. The +!! user ID and group ID of the named file shall be set to the numeric +!! values contained in owner and group, respectively. +!! +!! Only processes with an effective user ID equal to the user ID of +!! the file or with appropriate privileges may change the ownership +!! of a file. +!! +!!##OPTIONS +!! path a character string representing a file pathname. +!! Trailing spaces are ignored. +!! owner UID of owner that ownership is to be changed to +!! group GID of group that ownership is to be changed to +!! +!!##RETURN VALUE +!! The system_chown(3f) function should return zero 0 if successful. +!! Otherwise, these functions shall return 1 and set errno to +!! indicate the error. If 1 is returned, no changes are made in +!! the user ID and group ID of the file. +!! +!!##EXAMPLE +!! +!! +!! Sample program: +!! +!! program demo_system_chown +!! use M_system, only : system_chown +!! use M_system, only : system_getuid +!! use M_system, only : system_getgid +!! use M_system, only : system_perror +!! implicit none +!! integer :: i +!! character(len=80),parameter :: names(*)=[character(len=80) :: 'myfile1','/usr/local'] +!! do i=1,size(names) +!! if(.not. system_chown(& +!! & trim(names(i)), & +!! & system_getuid(), & +!! & system_getgid()) & +!! )then +!! call system_perror('*demo_system_chown* '//trim(names(i))) +!! endif +!! enddo +!! end program demo_system_chown +ELEMENTAL impure FUNCTION system_chown(dirname, owner, group) + IMPLICIT NONE + +! ident_11="@(#)M_system::system_chown(3f): change owner and group of a file relative to directory file descriptor" + + CHARACTER(len=*), INTENT(in) :: dirname + INTEGER, INTENT(in) :: owner + INTEGER, INTENT(in) :: group + LOGICAL :: system_chown + +! int chown(const char *path, uid_t owner, gid_t group); + INTERFACE + function c_chown(c_dirname,c_owner,c_group) bind (C,name="my_chown") result (c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_dirname(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: c_owner + INTEGER(kind=C_INT), INTENT(in), VALUE :: c_group + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_chown + END INTERFACE + + if(c_chown(str2_carr(trim(dirname)),int(owner,kind=c_int),int(group,kind=c_int)).eq.1)then + system_chown = .TRUE. + ELSE + system_chown = .FALSE. + END IF + +END FUNCTION system_chown +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_cpu_time(3f) - [M_system] get processor time by calling times(3c) +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine system_cpu_time(c_user, c_system, c_total) +!! +!! real,intent(out) :: c_total +!! real,intent(out) :: c_user +!! real,intent(out) :: c_system +!! +!!##DESCRIPTION +!! +!!##OUTPUT +!! c_total total processor time ( c_user + c_system ) +!! c_user processor user time +!! c_system processor system time +!! +!!##ERRORS +!! No errors are defined. +!! +!!##EXAMPLES +!! +!! +!! Sample program: +!! +!! program demo_system_cpu_time +!! +!! use M_system, only : system_cpu_time +!! use ISO_C_BINDING, only : c_float +!! implicit none +!! real :: user_start, system_start, total_start +!! real :: user_finish, system_finish, total_finish +!! integer :: i +!! integer :: itimes=1000000 +!! real :: value +!! +!! call system_cpu_time(total_start,user_start,system_start) +!! +!! value=0.0 +!! do i=1,itimes +!! value=sqrt(real(i)+value) +!! enddo +!! write(10,*)value +!! flush(10) +!! write(*,*)'average sqrt value=',value/itimes +!! call system_cpu_time(total_finish,user_finish,system_finish) +!! write(*,*)'USER ......',user_finish-user_start +!! write(*,*)'SYSTEM ....',system_finish-system_start +!! write(*,*)'TOTAL .....',total_finish-total_start +!! +!! end program demo_system_cpu_time +!! +!! Typical Results: +!-! GET ERRORS ABOUT MISSING LONGEST_ENV_VARIABLE IN GFORTRAN 6.4.0 IF JUST USE INTERFACE INSTEAD OF MAKING SUBROUTINE +!-!interface +!-! subroutine system_cpu_time(c_total,c_user,c_system) bind (C,NAME='my_cpu_time') +!-! import c_float +!-! real(kind=c_float) :: c_user,c_system,c_total +!-! end subroutine system_cpu_time +!-!end interface +SUBROUTINE system_cpu_time(total, user, system) + + REAL, INTENT(out) :: user, system, total + REAL(kind=C_FLOAT) :: c_user, c_system, c_total + + INTERFACE + SUBROUTINE c_cpu_time(c_total, c_user, c_system) BIND(C, NAME='my_cpu_time') + IMPORT C_FLOAT + REAL(kind=C_FLOAT) :: c_total, c_user, c_system + END SUBROUTINE c_cpu_time + END INTERFACE + + CALL c_cpu_time(c_total, c_user, c_system) + user = c_user + system = c_system + total = c_total +END SUBROUTINE system_cpu_time +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_link(3f) - [M_system:FILE_SYSTEM] link one file to another +!! file relative to two directory file descriptors +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure integer function link(oldpath,newpath); +!! +!! character(len=*),intent(in) :: oldpath +!! character(len=*),intent(in) :: newpath +!! +!!##DESCRIPTION +!! The link() function shall create a new link (directory entry) +!! for the existing file, path1. +!! +!! The path1 argument points to a pathname naming an existing +!! file. The path2 argument points to a pathname naming the +!! new directory entry to be created. The link() function shall +!! atomically create a new link for the existing file and the link +!! count of the file shall be incremented by one. +!! +!! If path1 names a directory, link() shall fail unless the process +!! has appropriate privileges and the implementation supports using +!! link() on directories. +!! +!! If path1 names a symbolic link, it is implementation-defined +!! whether link() follows the symbolic link, or creates a new link +!! to the symbolic link itself. +!! +!! Upon successful completion, link() shall mark for update the +!! last file status change timestamp of the file. Also, the last +!! data modification and last file status change timestamps of the +!! directory that contains the new entry shall be marked for update. +!! +!! If link() fails, no link shall be created and the link count of +!! the file shall remain unchanged. +!! +!! The implementation may require that the calling process has +!! permission to access the existing file. +!! +!! The linkat() function shall be equivalent to the link() function +!! except that symbolic links shall be handled as specified by the +!! value of flag (see below) and except in the case where either path1 +!! or path2 or both are relative paths. In this case a relative path +!! path1 is interpreted relative to the directory associated with +!! the file descriptor fd1 instead of the current working directory +!! and similarly for path2 and the file descriptor fd2. If the +!! file descriptor was opened without O_SEARCH, the function shall +!! check whether directory searches are permitted using the current +!! permissions of the directory underlying the file descriptor. If +!! the file descriptor was opened with O_SEARCH, the function shall +!! not perform the check. +!! +!! Values for flag are constructed by a bitwise-inclusive OR of +!! flags from the following list, defined in : +!! +!! AT_SYMLINK_FOLLOW +!! If path1 names a symbolic link, a new link for the target +!! of the symbolic link is created. +!! +!! If linkat() is passed the special value AT_FDCWD in the fd1 or +!! fd2 parameter, the current working directory shall be used for the +!! respective path argument. If both fd1 and fd2 have value AT_FDCWD, +!! the behavior shall be identical to a call to link(), except that +!! symbolic links shall be handled as specified by the value of flag. +!! +!! Some implementations do allow links between file systems. +!! +!! If path1 refers to a symbolic link, application developers should +!! use linkat() with appropriate flags to select whether or not the +!! symbolic link should be resolved. +!! +!! If the AT_SYMLINK_FOLLOW flag is clear in the flag argument and +!! the path1 argument names a symbolic link, a new link is created +!! for the symbolic link path1 and not its target. +!! +!!##RETURN VALUE +!! Upon successful completion, these functions shall return +!! 0. Otherwise, these functions shall return -1 and set errno to +!! indicate the error. +!! +!!##EXAMPLES +!! +!! Creating a Link to a File +!! +!! program demo_system_link +!! use M_system, only : system_link, system_perror +!! integer :: ierr +!! ierr = system_link('myfile1','myfile2') +!! if(ierr.ne.0)then +!! call system_perror('*demo_system_link*') +!! endif +!! end program demo_system_link +ELEMENTAL impure FUNCTION system_link(oldname, newname) RESULT(ierr) + +! ident_12="@(#)M_system::system_link(3f): call link(3c) to create a file link" + + CHARACTER(len=*), INTENT(in) :: oldname + CHARACTER(len=*), INTENT(in) :: newname + INTEGER :: ierr + INTEGER(kind=C_INT) :: c_ierr + + INTERFACE + FUNCTION c_link(c_oldname, c_newname) BIND(C, name="link") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_link + END INTERFACE + + c_ierr = c_link(str2_carr(TRIM(oldname)), str2_carr(TRIM(newname))) + ierr = c_ierr + +END FUNCTION system_link +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_unlink(3f) - [M_system:FILE_SYSTEM] remove a directory +!! entry relative to directory file descriptor +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure integer function unlink(path); +!! +!! character(len=*) :: path +!! +!!##DESCRIPTION +!! The unlink() function shall remove a link to a file. If path names a +!! symbolic link, unlink() shall remove the symbolic link named by path +!! and shall not affect any file or directory named by the contents of +!! the symbolic link. Otherwise, unlink() shall remove the link named by +!! the pathname pointed to by path and shall decrement the link count of +!! the file referenced by the link. +!! +!! When the files link count becomes 0 and no process has the file open, +!! the space occupied by the file shall be freed and the file shall no +!! longer be accessible. If one or more processes have the file open when +!! the last link is removed, the link shall be removed before unlink() +!! returns, but the removal of the file contents shall be postponed until +!! all references to the file are closed. +!! +!! The path argument shall not name a directory unless the process has +!! appropriate privileges and the implementation supports using unlink() +!! on directories. +!! +!! Upon successful completion, unlink() shall mark for update the last +!! data modification and last file status change timestamps of the parent +!! directory. Also, if the file link count is not 0, the last file status +!! change timestamp of the file shall be marked for update. +!! +!! Values for flag are constructed by a bitwise-inclusive OR of flags from +!! the following list, defined in : +!! +!! AT_REMOVEDIR +!! +!! Remove the directory entry specified by fd and path as a +!! directory, not a normal file. +!! +!!##RETURN VALUE +!! +!! Upon successful completion, these functions shall return 0. Otherwise, +!! these functions shall return -1 and set errno to indicate the error. If +!! -1 is returned, the named file shall not be changed. +!! +!!##EXAMPLES +!! +!! Removing a link to a file +!! +!! program demo_system_unlink +!! use M_system, only : system_unlink, system_perror +!! integer :: ierr +!! ierr = system_unlink('myfile1') +!! if(ierr.ne.0)then +!! call system_perror('*demo_system_unlink*') +!! endif +!! end program demo_system_unlink +ELEMENTAL impure FUNCTION system_unlink(fname) RESULT(ierr) + +! ident_13="@(#)M_system::system_unlink(3f): call unlink(3c) to rm file link" + + CHARACTER(len=*), INTENT(in) :: fname + INTEGER :: ierr + + INTERFACE + FUNCTION c_unlink(c_fname) BIND(C, name="unlink") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_unlink + END INTERFACE + ierr = c_unlink(str2_carr(TRIM(fname))) +END FUNCTION system_unlink +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_setumask(3f) - [M_system:FILE_SYSTEM] set the file mode creation umask +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer function system_setumask(new_umask) result (old_umask) +!! +!! integer,intent(in) :: new_umask +!! integer(kind=c_int) :: umask_c +!! +!!##DESCRIPTION +!! The system_umask(3f) function sets the file mode creation mask of the +!! process to cmask and return the previous value of the mask. Only +!! the file permission bits of cmask (see ) are used; +!! the meaning of the other bits is implementation-defined. +!! +!! The file mode creation mask of the process is used to turn off +!! permission bits in the mode argument supplied during calls to +!! the following functions: +!! +!! * open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat() +!! * mknod(), mknodat() +!! * mq_open() +!! * sem_open() +!! +!! Bit positions that are set in cmask are cleared in the mode of +!! the created file. +!! +!!##RETURN VALUE +!! The file permission bits in the value returned by umask() shall be +!! the previous value of the file mode creation mask. The state of any +!! other bits in that value is unspecified, except that a subsequent +!! call to umask() with the returned value as cmask shall leave the +!! state of the mask the same as its state before the first call, +!! including any unspecified use of those bits. +!! +!!##ERRORS +!! No errors are defined. +!! +!!##EXAMPLE +!! +!! Sample program +!! +!! program demo_setumask +!! use M_system, only : system_getumask, system_setumask +!! integer :: newmask +!! integer :: i +!! integer :: old_umask +!! write(*,101)(system_getumask(),i=1,4) +!! 101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'") +!! newmask=63 +!! old_umask=system_setumask(newmask) +!! write(*,*)'NEW' +!! write(*,101)(system_getumask(),i=1,4) +!! end program demo_setumask +!! +!! Expected output +!! +!! 18 O'022' Z"12' B'000010010" +!! NEW +!! 63 O'077' Z"3F' B'000111111" +INTEGER FUNCTION system_setumask(umask_value) RESULT(old_umask) + INTEGER, INTENT(in) :: umask_value + INTEGER(kind=C_INT) :: umask_c + + umask_c = umask_value + old_umask = system_umask(umask_c) ! set current umask + +END FUNCTION system_setumask +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getumask(3f) - [M_system:QUERY_FILE] get current umask +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! integer function system_getumask() result (umask_value) +!!##DESCRIPTION +!! The return value from getumask(3f) is the value of the file +!! creation mask, obtained by using umask(3c). +!!##EXAMPLE +!! +!! Sample program +!! +!! program demo_getumask +!! use M_system, only : system_getumask, system_setumask +!! integer :: i +!! write(*,101)(system_getumask(),i=1,4) +!! 101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'") +!! end program demo_getumask +!! +!! Expected output +!! +!! 18 O'022' Z"12' B'000010010" +INTEGER FUNCTION system_getumask() RESULT(umask_value) +! The return value from umask() is just the previous value of the file +! creation mask, so that this system call can be used both to get and +! set the required values. Sadly, however, there is no way to get the old +! umask value without setting a new value at the same time. + +! This means that in order just to see the current value, it is necessary +! to execute a piece of code like the following function: + INTEGER :: idum + INTEGER(kind=C_INT) :: old_umask + old_umask = system_umask(0_C_INT) ! get current umask but by setting umask to 0 (a conservative mask so no vulnerability is open) + idum = system_umask(old_umask) ! set back to original mask + umask_value = old_umask +END FUNCTION system_getumask +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! perror(3f) - [M_system:ERROR_PROCESSING] print error message for last C error on stderr +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_perror(prefix) +!! +!! character(len=*),intent(in) :: prefix +!! +!!##DESCRIPTION +!! Use system_perror(3f) to print an error message on stderr +!! corresponding to the current value of the C global variable errno. +!! Unless you use NULL as the argument prefix, the error message will +!! begin with the prefix string, followed by a colon and a space +!! (:). The remainder of the error message produced is one of the +!! strings described for strerror(3c). +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_perror +!! use M_system, only : system_perror,system_rmdir +!! implicit none +!! character(len=:),allocatable :: DIRNAME +!! DIRNAME='/NOT/THERE/OR/ANYWHERE' +!! ! generate an error with a routine that supports errno and perror(3c) +!! if(system_rmdir(DIRNAME).ne.0)then +!! call system_perror('*demo_system_perror*:'//DIRNAME) +!! endif +!! write(*,'(a)')"That is all Folks!" +!! end program demo_system_perror +!! +!! Expected results: +!! +!! *demo_system_perror*:/NOT/THERE/OR/ANYWHERE: No such file or directory +!! That is all Folks! +SUBROUTINE system_perror(prefix) + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT ! access computing environment + +! ident_14="@(#)M_system::system_perror(3f): call perror(3c) to display error message" + + CHARACTER(len=*), INTENT(in) :: prefix + INTEGER :: ios + + INTERFACE + SUBROUTINE c_perror(c_prefix) BIND(C, name="perror") + IMPORT C_CHAR + CHARACTER(kind=C_CHAR) :: c_prefix(*) + END SUBROUTINE c_perror + END INTERFACE + + FLUSH (unit=ERROR_UNIT, iostat=ios) + FLUSH (unit=OUTPUT_UNIT, iostat=ios) + FLUSH (unit=INPUT_UNIT, iostat=ios) + CALL c_perror(str2_carr((TRIM(prefix)))) + CALL c_flush() + +END SUBROUTINE system_perror +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_chdir(3f) - [M_system_FILE_SYSTEM] call chdir(3c) from Fortran to change working directory +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_chdir(path, err) +!! +!! character(len=*) :: path +!! integer, optional, intent(out) :: err +!! +!!##DESCRIPTION +!! +!! system_chdir(3f) changes the current working directory of the calling +!! process to the directory specified in path. The current working +!! directory is the starting point for interpreting relative pathnames +!! (those not starting with '/'). +!! +!!##RETURN VALUE +!! +!! On success, zero is returned. On error, -1 is returned, and errno is +!! set appropriately. +!! +!! +!! Depending on the file system, other errors can be returned. The more +!! general errors for chdir() are listed below, by their C definitions: +!! +!! Errors +!! EACCES Search permission is denied for one of the components of path. +!! (See also path_resolution(7).) +!! EFAULT path points outside your accessible address space. +!! EIO An I/O error occurred. +!! ELOOP Too many symbolic links were encountered in resolving path. +!! ENAMETOOLONG path is too long. +!! ENOENT The file does not exist. +!! ENOMEM Insufficient kernel memory was available. +!! ENOTDIR A component of path is not a directory. +!! +!!##SEE ALSO +!! +!! chroot(2), getcwd(3), path_resolution(7) +!! +!!##EXAMPLE +!! +!! Change working directory from Fortran +!! +!! program demo_system_chdir +!! use M_system, only : system_chdir +!! implicit none +!! integer :: ierr +!! +!! call execute_command_line('pwd') +!! call system_chdir('/tmp',ierr) +!! call execute_command_line('pwd') +!! write(*,*)'*CHDIR TEST* IERR=',ierr +!! +!! end program demo_system_chdir +!! +!!##RESULTS: +!! Sample run output: +!! +!! /home/urbanjs/V600 +!! /tmp +!! *CHDIR TEST* IERR= 0 +SUBROUTINE system_chdir(path, err) + +! ident_15="@(#)M_system::system_chdir(3f): call chdir(3c)" + + CHARACTER(len=*) :: path + INTEGER, OPTIONAL, INTENT(out) :: err + + INTERFACE + INTEGER(kind=C_INT) FUNCTION c_chdir(c_path) BIND(C, name="chdir") + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR) :: c_path(*) + END FUNCTION + END INTERFACE + INTEGER :: loc_err +!----------------------------------------------------------------------------------------------------------------------------------- + loc_err = c_chdir(str2_carr(TRIM(path))) + IF (PRESENT(err)) THEN + err = loc_err + END IF +END SUBROUTINE system_chdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_remove(3f) - [M_system_FILE_SYSTEM] call remove(3c) to remove file +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! elemental impure function system_remove(path) result(err) +!! +!! character(*),intent(in) :: path +!! integer(c_int) :: err +!! +!!##DESCRIPTION +!! Fortran supports scratch files via the OPEN(3c) command; but does +!! not otherwise allow for removing files. The system_remove(3f) command +!! allows for removing files by name that the user has the authority to +!! remove by calling the C remove(3c) function. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_remove +!! use M_system, only : system_remove +!! character(len=*),parameter :: FILE='MyJunkFile.txt' +!! integer :: ierr +!! write(*,*)'BEFORE CREATED '//FILE +!! call execute_command_line('ls -l '//FILE) +!! write(*,*) +!! +!! ! note intentionally causes error if file exists +!! open(unit=10,file=FILE,status='NEW') +!! write(*,*)'AFTER OPENED '//FILE +!! call execute_command_line('ls -l '//FILE) +!! write(*,*) +!! +!! write(10,'(a)') 'This is a file I want to delete' +!! close(unit=10) +!! write(*,*)'AFTER CLOSED ' +!! call execute_command_line('ls -l '//FILE) +!! write(*,*) +!! +!! ierr=system_remove(FILE) +!! write(*,*)'AFTER REMOVED',IERR +!! call execute_command_line('ls -l '//FILE) +!! write(*,*) +!! +!! end program demo_system_remove +!! +!! Expected Results: +!! +!! > BEFORE CREATED MyJunkFile.txt +!! > ls: cannot access 'MyJunkFile.txt': No such file or directory +!! > +!! > AFTER OPENED MyJunkFile.txt +!! > -rw-r--r-- 1 JSU None 0 Nov 19 19:32 MyJunkFile.txt +!! > +!! > AFTER CLOSED +!! > -rw-r--r-- 1 JSU None 32 Nov 19 19:32 MyJunkFile.txt +!! > +!! > AFTER REMOVED 0 +!! > ls: cannot access 'MyJunkFile.txt': No such file or directory +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +ELEMENTAL impure FUNCTION system_remove(path) RESULT(err) + +! ident_16="@(#)M_system::system_remove(3f): call remove(3c) to remove file" + + CHARACTER(*), INTENT(in) :: path + INTEGER(C_INT) :: err + + INTERFACE + FUNCTION c_remove(c_path) BIND(c, name="remove") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) + INTEGER(C_INT) :: c_err + END FUNCTION + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + err = c_remove(str2_carr(TRIM(path))) +END FUNCTION system_remove +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_rename(3f) - [M_system_FILE_SYSTEM] call rename(3c) to rename a system file +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function system_rename(input,output) result(ierr) +!! +!! character(*),intent(in) :: input,output +!! integer :: ierr +!!##DESCRIPTION +!! Rename a file by calling rename(3c). It is not recommended that the +!! rename occur while either filename is being used on a file currently +!! OPEN(3f) by the program. +!! +!! Both the old and new names must be on the same device. +!!##OPTIONS +!! INPUT system filename of an existing file to rename +!! OUTPUT system filename to be created or overwritten by INPUT file. +!! Must be on the same device as the INPUT file. +!!##RETURNS +!! IERR zero (0) if no error occurs. If not zero a call to +!! system_errno(3f) or system_perror(3f) is supported +!! to diagnose error +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_rename +!! use M_system, only : system_rename +!! use M_system, only : system_remove +!! use M_system, only : system_perror +!! implicit none +!! character(len=256) :: string +!! integer :: ios, ierr +!! +!! ! try to remove junk files just in case +!! ierr=system_remove('_scratch_file_') +!! write(*,'(a,i0)') 'should not be zero ',ierr +!! call system_perror('*demo_system_rename*') +!! ierr=system_remove('_renamed_scratch_file_') +!! write(*,'(a,i0)') 'should not be zero ',ierr +!! call system_perror('*demo_system_rename*') +!! +!! ! create scratch file to rename +!! open(unit=10,file='_scratch_file_',status='new') +!! write(10,'(a)') 'Test by renaming "_scratch_file_" to "_renamed_scratch_file_"' +!! write(10,'(a)') 'IF YOU SEE THIS ON OUTPUT THE RENAME WORKED' +!! close(10) +!! ! rename scratch file +!! ierr=system_rename('_scratch_file_','_renamed_scratch_file_') +!! if(ierr.ne.0)then +!! write(*,*)'ERROR RENAMING FILE ',ierr +!! endif +!! ! read renamed file +!! open(unit=11,file='_renamed_scratch_file_',status='old') +!! INFINITE: do +!! read(11,'(a)',iostat=ios)string +!! if(ios.ne.0)exit INFINITE +!! write(*,'(a)')trim(string) +!! enddo INFINITE +!! close(unit=11) +!! +!! ! clean up +!! ierr=system_remove('_scratch_file_') +!! write(*,'(a,i0)') 'should not be zero ',ierr +!! ierr=system_remove('_renamed_scratch_file_') +!! write(*,'(a,i0)') 'should be zero ',ierr +!! +!! end program demo_system_rename +!! +!! Expected output: +!! +!! > should not be zero -1 +!! > *demo_system_rename*: No such file or directory +!! > should not be zero -1 +!! > *demo_system_rename*: No such file or directory +!! > Test by renaming "_scratch_file_" to "_renamed_scratch_file_" +!! > IF YOU SEE THIS ON OUTPUT THE RENAME WORKED +!! > should not be zero -1 +!! > should be zero 0 +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_rename(input, output) RESULT(ierr) + +! ident_17="@(#)M_system::system_rename(3f): call rename(3c) to change filename" + + CHARACTER(*), INTENT(in) :: input, output + INTEGER :: ierr + INTERFACE + FUNCTION c_rename(c_input, c_output) BIND(c, name="rename") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) + CHARACTER(kind=C_CHAR), INTENT(in) :: c_output(*) + INTEGER(C_INT) :: c_err + END FUNCTION + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + ierr = c_rename(str2_carr(TRIM(input)), str2_carr(TRIM(output))) +END FUNCTION system_rename +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_chmod(3f) - [M_system_FILE_SYSTEM] call chmod(3c) to change +!! permission mode of a file relative to directory file descriptor +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function system_chmod(filename,mode) result(ierr) +!! +!! character(len=*),intent(in) :: filename +!! integer,value,intent(in) :: mode +!! integer :: ierr +!! +!!##DESCRIPTION +!! The system_chmod(3f) function shall change UID, _ISGID, S_ISVTX, and the +!! file permission bits of the file named by the pathname pointed +!! to by the path argument to the corresponding bits in the mode +!! argument. The application shall ensure that the effective user +!! ID of the process matches the owner of the file or the process +!! has appropriate privileges in order to do this. +!! +!! S_ISUID, S_ISGID, S_ISVTX, and the file permission bits are +!! described in . +!! +!! If the calling process does not have appropriate privileges, +!! and if the group ID of the file does not match the effective +!! group ID or one of the supplementary group IDs and if the file +!! is a regular file, bit S_ISGID (set-group-ID on execution) in the +!! file mode shall be cleared upon successful return from chmod(). +!! +!! Additional implementation-defined restrictions may cause the +!! S_ISUID and S_ISGID bits in mode to be ignored. +!! +!! Upon successful completion, system_chmod() marks for update the +!! last file status change timestamp of the file. +!! +!! Values for flag are constructed by a bitwise-inclusive OR of +!! flags from the following list, defined in : +!! +!! AT_SYMLINK_NOFOLLOW +!! If path names a symbolic link, then the mode of the symbolic +!! link is changed. +!! +!! +!!##RETURN VALUE +!! Upon successful completion, system_chmod(3f) returns 0. +!! Otherwise, it returns -1 and sets errno to indicate the error. If +!! -1 is returned, no change to the file mode occurs. +!! +!!##EXAMPLES +!! +!! Sample program: +!! +!! program demo_system_chmod +!! use M_system, only : system_chmod +!! use M_system, only : system_stat +!! use M_system, only : R_GRP,R_OTH,R_USR, RWX_G, RWX_U, W_OTH, X_GRP +!! !use M_system, only : RWX_O, W_GRP,W_USR,X_OTH,X_USR +!! !use M_system, only : DEFFILEMODE, ACCESSPERMS +!! use,intrinsic :: iso_fortran_env, only : int64 +!! implicit none +!! integer :: ierr +!! integer :: status +!! integer(kind=int64) :: buffer(13) +!! !Setting Read Permissions for User, Group, and Others +!! ! The following example sets read permissions for the owner, group, and others. +!! open(file='_test1',unit=10) +!! write(10,*)'TEST FILE 1' +!! close(unit=10) +!! ierr=system_chmod('_test1', IANY([R_USR,R_GRP,R_OTH])) +!! +!! !Setting Read, Write, and Execute Permissions for the Owner Only +!! ! The following example sets read, write, and execute permissions for the owner, and no permissions for group and others. +!! open(file='_test2',unit=10) +!! write(10,*)'TEST FILE 2' +!! close(unit=10) +!! ierr=system_chmod('_test2', RWX_U) +!! +!! !Setting Different Permissions for Owner, Group, and Other +!! ! The following example sets owner permissions for CHANGEFILE to read, write, and execute, group permissions to read and +!! ! execute, and other permissions to read. +!! open(file='_test3',unit=10) +!! write(10,*)'TEST FILE 3' +!! close(unit=10) +!! ierr=system_chmod('_test3', IANY([RWX_U,R_GRP,X_GRP,R_OTH])); +!! +!! !Setting and Checking File Permissions +!! ! The following example sets the file permission bits for a file named /home/cnd/mod1, then calls the stat() function to +!! ! verify the permissions. +!! +!! ierr=system_chmod("home/cnd/mod1", IANY([RWX_U,RWX_G,R_OTH,W_OTH])) +!! call system_stat("home/cnd/mod1", buffer,status) +!! +!! ! In order to ensure that the S_ISUID and S_ISGID bits are set, an application requiring this should use stat() after a +!! ! successful chmod() to verify this. +!! +!! ! Any files currently open could possibly become invalid if the mode +!! ! of the file is changed to a value which would deny access to +!! ! that process. +!! +!! end program demo_system_chmod +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_chmod(filename, mode) RESULT(ierr) + CHARACTER(len=*), INTENT(in) :: filename + INTEGER, VALUE, INTENT(in) :: mode + INTEGER :: ierr + INTERFACE + FUNCTION c_chmod(c_filename, c_mode) BIND(c, name="chmod") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR), INTENT(in) :: c_filename(*) + INTEGER(C_INT), VALUE, INTENT(in) :: c_mode + INTEGER(C_INT) :: c_err + END FUNCTION + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + ierr = c_chmod(str2_carr(TRIM(filename)), INT(mode, KIND(0_C_INT))) +END FUNCTION system_chmod +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getcwd(3f) - [M_system:QUERY_FILE] call getcwd(3c) to get the pathname of the current working directory +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_getcwd(output,ierr) +!! +!! character(len=:),allocatable,intent(out) :: output +!! integer,intent(out) :: ierr +!!##DESCRIPTION +!! system_getcwd(3f) calls the C routine getcwd(3c) to obtain the absolute pathname of the current working directory. +!! +!!##RETURN VALUE +!! OUTPUT The absolute pathname of the current working directory +!! The pathname shall contain no components that are dot or dot-dot, +!! or are symbolic links. +!! IERR is not zero if an error occurs. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_getcwd +!! use M_system, only : system_getcwd +!! implicit none +!! character(len=:),allocatable :: dirname +!! integer :: ierr +!! call system_getcwd(dirname,ierr) +!! if(ierr.eq.0)then +!! write(*,*)'CURRENT DIRECTORY ',trim(dirname) +!! else +!! write(*,*)'ERROR OBTAINING CURRENT DIRECTORY NAME' +!! endif +!! end program demo_system_getcwd +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_getcwd(output, ierr) + +! ident_18="@(#)M_system::system_getcwd(3f):call getcwd(3c) to get pathname of current working directory" + + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output + INTEGER, INTENT(out) :: ierr + INTEGER(kind=C_LONG), PARAMETER :: length = 4097_C_LONG + CHARACTER(kind=C_CHAR, len=1) :: buffer(length) + TYPE(C_PTR) :: buffer2 + INTERFACE + FUNCTION c_getcwd(buffer, size) BIND(c, name="getcwd") RESULT(buffer_result) + IMPORT C_CHAR, C_SIZE_T, C_PTR + CHARACTER(kind=C_CHAR), INTENT(out) :: buffer(*) + INTEGER(C_SIZE_T), VALUE, INTENT(in) :: size + TYPE(C_PTR) :: buffer_result + END FUNCTION + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + buffer = ' ' + buffer2 = c_getcwd(buffer, length) + IF (.NOT. C_ASSOCIATED(buffer2)) THEN + output = '' + ierr = -1 + ELSE + output = TRIM(arr2str(buffer)) + ierr = 0 + END IF +END SUBROUTINE system_getcwd +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_rmdir(3f) - [M_system:FILE_SYSTEM] call rmdir(3c) to remove empty directories +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function system_rmdir(dirname) result(err) +!! +!! character(*),intent(in) :: dirname +!! integer(c_int) :: err +!! +!!##DESCRIPTION +!! DIRECTORY The name of a directory to remove if it is empty +!! err zero (0) if no error occurred +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_rmdir +!! use M_system, only : system_perror +!! use M_system, only : system_rmdir, system_mkdir +!! use M_system, only : RWX_U +!! implicit none +!! integer :: ierr +!! write(*,*)'BEFORE TRY TO CREATE _scratch/' +!! call execute_command_line('ls -ld _scratch') +!! +!! write(*,*)'TRY TO CREATE _scratch/' +!! ierr=system_mkdir('_scratch',RWX_U) +!! write(*,*)'IERR=',ierr +!! call execute_command_line('ls -ld _scratch') +!! +!! write(*,*)'TRY TO REMOVE _scratch/' +!! ierr=system_rmdir('_scratch') +!! write(*,*)'IERR=',ierr +!! call execute_command_line('ls -ld _scratch') +!! +!! write(*,*)'TRY TO REMOVE _scratch when it should be gone/' +!! ierr=system_rmdir('_scratch') +!! call system_perror('*test of system_rmdir*') +!! write(*,*)'IERR=',ierr +!! call execute_command_line('ls -ld _scratch') +!! +!! end program demo_system_rmdir +!! +!! Expected output: +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_rmdir(dirname) RESULT(err) + +! ident_19="@(#)M_system::system_rmdir(3f): call rmdir(3c) to remove empty directory" + + CHARACTER(*), INTENT(in) :: dirname + INTEGER(C_INT) :: err + + INTERFACE + FUNCTION c_rmdir(c_path) BIND(c, name="rmdir") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) + INTEGER(C_INT) :: c_err + END FUNCTION + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + err = c_rmdir(str2_carr(TRIM(dirname))) + IF (err .NE. 0) err = system_errno() +END FUNCTION system_rmdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_mkfifo(3f) - [M_system:FILE_SYSTEM] make a FIFO special file relative to directory file descriptor +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function system_mkfifo(pathname,mode) result(ierr) +!! +!! character(len=*),intent(in) :: pathname +!! integer,intent(in) :: mode +!! integer :: ierr +!! +!!##DESCRIPTION +!! A regular pipe can only connect two related processes. It is created by +!! a process and will vanish when the last process closes it. +!! +!! A named pipe, also called a FIFO for its behavior, can be used to connect +!! two unrelated processes and exists independently of the processes; +!! meaning it can exist even if no one is using it. A FIFO is created using +!! the mkfifo() library function. +!! +!! The mkfifo() function creates a new FIFO special file named by the +!! pathname. +!! +!! The file permission bits of the new FIFO are initialized from mode. +!! +!! The file permission bits of the mode argument are modified by the +!! process file creation mask. +!! +!! When bits in mode other than the file permission bits are set, the +!! effect is implementation-defined. +!! +!! If path names a symbolic link, mkfifo() shall fail and set errno to +!! [EEXIST]. +!! +!! The FIFOs user ID will be set to the process effective user ID. +!! +!! The FIFOs group ID shall be set to the group ID of the parent +!! directory or to the effective group ID of the process. +!! +!! Implementations shall provide a way to initialize the FIFOs group +!! ID to the group ID of the parent directory. +!! +!! Implementations may, but need not, provide an implementation-defined +!! way to initialize the FIFOs group ID to the effective group ID of +!! the calling process. +!! +!! Upon successful completion, mkfifo() shall mark for update the +!! last data access, last data modification, and last file status change +!! timestamps of the file. +!! +!! Also, the last data modification and last file status change +!! timestamps of the directory that contains the new entry shall be +!! marked for update. +!! +!! Predefined variables are typically used to set permission modes. +!! +!! You can bytewise-OR together these variables to create the most +!! common permissions mode: +!! +!! User: R_USR (read), W_USR (write), X_USR(execute) +!! Group: R_GRP (read), W_GRP (write), X_GRP(execute) +!! Others: R_OTH (read), W_OTH (write), X_OTH(execute) +!! +!! Additionally, some shortcuts are provided (basically a bitwise-OR +!! combination of the above): +!! +!! Read + Write + Execute: RWX_U (User), RWX_G (Group), RWX_O (Others) +!! DEFFILEMODE: Equivalent of 0666 =rw-rw-rw- +!! ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx +!! +!! Therefore, to give only the user rwx (read+write+execute) rights whereas +!! group members and others may not do anything, you can use any of the +!! following mkfifo() calls equivalently: +!! +!! ierr= mkfifo("myfile", IANY([R_USR, W_USR, X_USR])); +!! ierr= mkfifo("myfile", RWX_U); +!! +!! In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can +!! use any of the following calls equivalently: +!! +!! ierr= mkfifo("myfile",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH])); +!! ierr= mkfifo("myfile",IANY([RWX_U,RWX_G,RWX_O])); +!! ierr= mkfifo("myfile",ACCESSPERMS); +!!##RETURN VALUE +!! Upon successful completion, return 0. +!! Otherwise, return -1 and set errno to indicate the error. +!! If -1 is returned, no FIFO is created. +!! +!!##EXAMPLES +!! +!! The following example shows how to create a FIFO file named +!! /home/cnd/mod_done, with read/write permissions for owner, and +!! with read permissions for group and others. +!! +!! program demo_system_mkfifo +!! use M_system, only : system_mkfifo, system_perror +!! !use M_system, only : R_GRP,R_OTH,R_USR,RWX_G,RWX_O +!! !use M_system, only : RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR +!! !use M_system, only : DEFFILEMODE, ACCESSPERMS +!! use M_system, only : W_USR, R_USR, R_GRP, R_OTH +!! implicit none +!! integer :: status +!! status = system_mkfifo("/tmp/buffer", IANY([W_USR, R_USR, R_GRP, R_OTH])) +!! if(status.ne.0)then +!! call system_perror('*mkfifo* error:') +!! endif +!! end program demo_system_mkfifo +!! +!! Now some other process (or this one) can read from /tmp/buffer while this program +!! is running or after, consuming the data as it is read. +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_mkfifo(pathname, mode) RESULT(err) + +! ident_20="@(#)M_system::system_mkfifo(3f): call mkfifo(3c) to create a new FIFO special file" + + CHARACTER(len=*), INTENT(in) :: pathname + INTEGER, INTENT(in) :: mode + INTEGER :: c_mode + INTEGER :: err + + INTERFACE + FUNCTION c_mkfifo(c_path, c_mode) BIND(c, name="mkfifo") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) + INTEGER(C_INT), INTENT(in), VALUE :: c_mode + INTEGER(C_INT) :: c_err + END FUNCTION c_mkfifo + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + c_mode = mode + err = c_mkfifo(str2_carr(TRIM(pathname)), c_mode) +END FUNCTION system_mkfifo +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_mkdir(3f) - [M_system:FILE_SYSTEM] call mkdir(3c) to create a new directory +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!!##DESCRIPTION +!! +!! Predefined variables are typically used to set permission modes. +!! You can bytewise-OR together these variables to create the most common +!! permissions mode: +!! +!! User: R_USR (read), W_USR (write), X_USR(execute) +!! Group: R_GRP (read), W_GRP (write), X_GRP(execute) +!! Others: R_OTH (read), W_OTH (write), X_OTH(execute) +!! +!! Additionally, some shortcuts are provided (basically a bitwise-OR combination of the above): +!! +!! Read + Write + Execute: RWX_U (User), RWX_G (Group), RWX_O (Others) +!! DEFFILEMODE: Equivalent of 0666 =rw-rw-rw- +!! ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx +!! +!! Therefore, to give only the user rwx (read+write+execute) rights whereas +!! group members and others may not do anything, you can use any of the +!! following mkdir() calls equivalently: +!! +!! ierr= mkdir("mydir", IANY([R_USR, W_USR, X_USR])); +!! ierr= mkdir("mydir", RWX_U); +!! +!! In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can +!! use any of the following calls equivalently: +!! +!! ierr= mkdir("mydir",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH])); +!! ierr= mkdir("mydir",IANY([RWX_U,RWX_G,RWX_O])); +!! ierr= mkdir("mydir",ACCESSPERMS); +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_mkdir +!! use M_system, only : system_perror +!! use M_system, only : system_mkdir +!! use M_system, only : R_GRP,R_OTH,R_USR,RWX_G,RWX_O +!! use M_system, only : RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR +!! use M_system, only : DEFFILEMODE, ACCESSPERMS +!! implicit none +!! integer :: ierr +!! ierr=system_mkdir('_scratch',IANY([R_USR,W_USR,X_USR])) +!! end program demo_system_mkdir +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_mkdir(dirname, mode) RESULT(ierr) + +! ident_21="@(#)M_system::system_mkdir(3f): call mkdir(3c) to create empty directory" + + CHARACTER(len=*), INTENT(in) :: dirname + INTEGER, INTENT(in) :: mode + INTEGER :: c_mode + INTEGER(kind=C_INT) :: err + INTEGER :: ierr + + INTERFACE + FUNCTION c_mkdir(c_path, c_mode) BIND(c, name="mkdir") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) + INTEGER(C_INT), INTENT(in), VALUE :: c_mode + INTEGER(C_INT) :: c_err + END FUNCTION c_mkdir + END INTERFACE + INTERFACE + SUBROUTINE my_mkdir(string, c_mode, c_err) BIND(C, name="my_mkdir") + USE ISO_C_BINDING, ONLY: C_CHAR, C_INT + CHARACTER(kind=C_CHAR) :: string(*) + INTEGER(C_INT), INTENT(in), VALUE :: c_mode + INTEGER(C_INT) :: c_err + END SUBROUTINE my_mkdir + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + c_mode = mode + IF (INDEX(dirname, '/') .NE. 0) THEN + CALL my_mkdir(str2_carr(TRIM(dirname)), c_mode, err) + ELSE + err = c_mkdir(str2_carr(TRIM(dirname)), c_mode) + END IF + ierr = err ! c_int to default integer kind +END FUNCTION system_mkdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_opendir(3f) - [M_system:QUERY_FILE] open directory stream by calling opendir(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_opendir(dirname,dir,ierr) +!! +!! character(len=*), intent(in) :: dirname +!! type(c_ptr) :: dir +!! integer,intent(out) :: ierr +!! +!!##DESCRIPTION +!! The system_opendir(3f) procedure opens a directory stream +!! corresponding to the directory named by the dirname argument. +!! The directory stream is positioned at the first entry. +!! +!!##RETURN VALUE +!! Upon successful completion, a pointer to a C dir type is returned. +!! Otherwise, these functions shall return a null pointer and set +!! IERR to indicate the error. +!! +!!##ERRORS +!! +!! An error corresponds to a condition described in opendir(3c): +!! +!! EACCES Search permission is denied for the component of the +!! path prefix of dirname or read permission is denied +!! for dirname. +!! +!! ELOOP A loop exists in symbolic links encountered during +!! resolution of the dirname argument. +!! +!! ENAMETOOLONG The length of a component of a pathname is longer than {NAME_MAX}. +!! +!! ENOENT A component of dirname does not name an existing directory or dirname is an empty string. +!! +!! ENOTDIR A component of dirname names an existing file that is neither a directory nor a symbolic link to a directory. +!! +!! ELOOP More than {SYMLOOP_MAX} symbolic links were encountered during resolution of the dirname argument. +!! +!! EMFILE All file descriptors available to the process are currently open. +!! +!! ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, +!! or pathname resolution of a symbolic link produced an intermediate +!! result with a length that exceeds {PATH_MAX}. +!! +!! ENFILE Too many files are currently open in the system. +!! +!!##APPLICATION USAGE +!! The opendir() function should be used in conjunction with readdir(), closedir(), and rewinddir() to examine the contents +!! of the directory (see the EXAMPLES section in readdir()). This method is recommended for portability. +!!##OPTIONS +!! dirname name of directory to open a directory stream for +!!##RETURNS +!! dir pointer to directory stream. If an +!! error occurred, it will not be associated. +!! ierr 0 indicates no error occurred +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_opendir +!! use M_system, only : system_opendir,system_readdir +!! use M_system, only : system_closedir +!! use iso_c_binding +!! implicit none +!! type(c_ptr) :: dir +!! character(len=:),allocatable :: filename +!! integer :: ierr +!! !--- open directory stream to read from +!! call system_opendir('.',dir,ierr) +!! if(ierr.eq.0)then +!! !--- read directory stream +!! do +!! call system_readdir(dir,filename,ierr) +!! if(filename.eq.' ')exit +!! write(*,*)filename +!! enddo +!! endif +!! !--- close directory stream +!! call system_closedir(dir,ierr) +!! end program demo_system_opendir +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_opendir(dirname, dir, ierr) + CHARACTER(len=*), INTENT(in) :: dirname + TYPE(C_PTR) :: dir + INTEGER, INTENT(out) :: ierr + + INTERFACE + FUNCTION c_opendir(c_dirname) BIND(c, name="opendir") RESULT(c_dir) + IMPORT C_CHAR, C_INT, C_PTR + CHARACTER(kind=C_CHAR), INTENT(in) :: c_dirname(*) + TYPE(C_PTR) :: c_dir + END FUNCTION c_opendir + END INTERFACE + + ierr = 0 + dir = c_opendir(str2_carr(TRIM(dirname))) + IF (.NOT. C_ASSOCIATED(dir)) THEN + WRITE (*, '(a)') '*system_opendir* Error opening '//TRIM(dirname) + ierr = -1 + END IF + +END SUBROUTINE system_opendir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_readdir(3f) - [M_system:QUERY_FILE] read a directory using readdir(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_readdir(dir,filename,ierr) +!! +!! type(c_ptr),value :: dir +!! character(len=:),intent(out),allocatable :: filename +!! integer,intent(out) :: ierr +!! +!!##DESCRIPTION +!! +!! system_readdir(3f) returns the name of the directory entry at the +!! current position in the directory stream specified by the argument +!! DIR, and positions the directory stream at the next entry. It returns +!! a null name upon reaching the end of the directory stream. +!! +!!##OPTIONS +!! +!! DIR A pointer to the directory opened by system_opendir(3f). +!! +!!##RETURNS +!! +!! FILENAME the name of the directory entry at the current position in +!! the directory stream specified by the argument DIR, and +!! positions the directory stream at the next entry. +!! +!! The readdir() function does not return directory entries +!! containing empty names. If entries for dot or dot-dot exist, +!! one entry is returned for dot and one entry is returned +!! for dot-dot. +!! +!! The entry is marked for update of the last data access +!! timestamp each time it is read. +!! +!! reaching the end of the directory stream, the name is a blank name. +!! +!! IERR If IERR is set to non-zero on return, an error occurred. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_readdir +!! use M_system, only : system_opendir,system_readdir +!! use M_system, only : system_rewinddir,system_closedir +!! use iso_c_binding +!! implicit none +!! +!! type(c_ptr) :: dir +!! character(len=:),allocatable :: filename +!! integer :: i, ierr +!! !--- open directory stream to read from +!! call system_opendir('.',dir,ierr) +!! if(ierr.eq.0)then +!! !--- read directory stream twice +!! do i=1,2 +!! write(*,'(a,i0)')'PASS ',i +!! do +!! call system_readdir(dir,filename,ierr) +!! if(filename.eq.' ')exit +!! write(*,*)filename +!! enddo +!! call system_rewinddir(dir) +!! enddo +!! endif +!! !--- close directory stream +!! call system_closedir(dir,ierr) +!! +!! end program demo_system_readdir +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_readdir(dir, filename, ierr) + TYPE(C_PTR), VALUE :: dir + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: filename + INTEGER, INTENT(out) :: ierr + INTEGER(kind=C_INT) :: ierr_local + + CHARACTER(kind=C_CHAR, len=1) :: buf(4097) + + INTERFACE + SUBROUTINE c_readdir(c_dir, c_filename, c_ierr) BIND(C, NAME='my_readdir') + IMPORT C_CHAR, C_INT, C_PTR + TYPE(C_PTR), VALUE :: c_dir + CHARACTER(kind=C_CHAR) :: c_filename(*) + INTEGER(kind=C_INT) :: c_ierr + END SUBROUTINE c_readdir + END INTERFACE + + buf = ' ' + ierr_local = 0 + CALL c_readdir(dir, buf, ierr_local) + filename = TRIM(arr2str(buf)) + ierr = ierr_local + +END SUBROUTINE system_readdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_rewinddir(3f) - [M_system:QUERY_FILE] call rewinddir(3c) to rewind directory stream +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_rewinddir(dir) +!! +!! type(c_ptr),value :: dir +!! +!!##DESCRIPTION +!! Return to pointer to the beginning of the list for a currently open directory list. +!! +!!##OPTIONS +!! DIR A C_pointer assumed to have been allocated by a call to SYSTEM_OPENDIR(3f). +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_rewinddir +!! use M_system, only : system_opendir,system_readdir +!! use M_system, only : system_rewinddir,system_closedir +!! use iso_c_binding +!! implicit none +!! +!! type(c_ptr) :: dir +!! character(len=:),allocatable :: filename +!! integer :: i, ierr +!! !>>> open directory stream to read from +!! call system_opendir('.',dir,ierr) +!! !>>> read directory stream twice +!! do i=1,2 +!! write(*,'(a,i0)')'PASS ',i +!! do +!! call system_readdir(dir,filename,ierr) +!! if(filename.eq.' ')exit +!! write(*,*)filename +!! enddo +!! !>>> rewind directory stream +!! call system_rewinddir(dir) +!! enddo +!! !>>> close directory stream +!! call system_closedir(dir,ierr) +!! +!! end program demo_system_rewinddir +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_rewinddir(dir) + TYPE(C_PTR), VALUE :: dir + + INTERFACE + SUBROUTINE c_rewinddir(c_dir) BIND(c, name="rewinddir") + IMPORT C_CHAR, C_INT, C_PTR + TYPE(C_PTR), VALUE :: c_dir + END SUBROUTINE c_rewinddir + END INTERFACE + + CALL c_rewinddir(dir) + +END SUBROUTINE system_rewinddir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_closedir(3f) - [M_system:QUERY_FILE] close a directory stream by calling closedir(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_closedir(dir,ierr) +!! +!! type(c_ptr) :: dir +!! integer,intent(out) :: ierr +!!##DESCRIPTION +!! The SYSTEM_CLOSEDIR(3f) function closes the directory stream referred to by the argument DIR. +!! Upon return, the value of DIR may no longer point to an accessible object. +!!##OPTIONS +!! dir directory stream pointer opened by SYSTEM_OPENDIR(3f). +!! ierr Upon successful completion, SYSTEM_CLOSEDIR(3f) returns 0; +!! otherwise, an error has occurred. +!!##ERRORS +!! system_closedir(3f) may fail if: +!! +!! EBADF The dirp argument does not refer to an open directory stream. +!! EINTR The closedir() function was interrupted by a signal. +!!##EXAMPLE +!! +!! Sample program +!! +!! program demo_system_closedir +!! use M_system, only : system_opendir,system_readdir +!! use M_system, only : system_closedir, system_rewinddir +!! use iso_c_binding, only : c_ptr +!! implicit none +!! type(c_ptr) :: dir +!! character(len=:),allocatable :: filename +!! integer :: ierr +!! !--- open directory stream to read from +!! call system_opendir('.',dir,ierr) +!! !--- read directory stream +!! do +!! call system_readdir(dir,filename,ierr) +!! if(filename.eq.' ')exit +!! write(*,*)filename +!! enddo +!! call system_rewinddir(dir) +!! !--- close directory stream +!! call system_closedir(dir,ierr) +!! end program demo_system_closedir +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_closedir(dir, ierr) + USE ISO_C_BINDING + TYPE(C_PTR), VALUE :: dir + INTEGER, INTENT(out), OPTIONAL :: ierr + INTEGER :: ierr_local + + INTERFACE + FUNCTION c_closedir(c_dir) BIND(c, name="closedir") RESULT(c_err) + IMPORT C_CHAR, C_INT, C_PTR + TYPE(C_PTR), VALUE :: c_dir + INTEGER(kind=C_INT) :: c_err + END FUNCTION c_closedir + END INTERFACE + + ierr_local = c_closedir(dir) + IF (PRESENT(ierr)) THEN + ierr = ierr_local + ELSE + IF (ierr_local /= 0) THEN + PRINT *, "*system_closedir* error", ierr_local + STOP 3 + END IF + END IF + +END SUBROUTINE system_closedir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_putenv(3f) - [M_system:ENVIRONMENT] set environment variable from Fortran by calling putenv(3c) +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine system_putenv(string, err) +!! +!! character(len=*),intent(in) :: string +!! integer, optional, intent(out) :: err +!! +!!##DESCRIPTION +!! The system_putenv() function adds or changes the value of environment variables. +!! +!!##OPTIONS +!! string string of format "NAME=value". +!! If name does not already exist in the environment, then string is added to the environment. +!! If name does exist, then the value of name in the environment is changed to value. +!! The string passed to putenv(3c) becomes part of the environment, +!! so this routine creates a string each time it is called that increases the amount of +!! memory the program uses. +!! err The system_putenv() function returns zero on success, or nonzero if an error occurs. +!! A non-zero error usually indicates sufficient memory does not exist to store the +!! variable. +!! +!!##EXAMPLE +!! +!! Sample setting an environment variable from Fortran: +!! +!! program demo_system_putenv +!! use M_system, only : system_putenv +!! use iso_c_binding +!! implicit none +!! integer :: ierr +!! ! +!! write(*,'(a)')'no environment variables containing "GRU":' +!! call execute_command_line('env|grep GRU') +!! ! +!! call system_putenv('GRU=this is the value',ierr) +!! write(*,'(a,i0)')'now "GRU" should be defined: ',ierr +!! call execute_command_line('env|grep GRU') +!! ! +!! call system_putenv('GRU2=this is the second value',ierr) +!! write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined: ',ierr +!! call execute_command_line('env|grep GRU') +!! ! +!! call system_putenv('GRU2',ierr) +!! call system_putenv('GRU',ierr) +!! write(*,'(a,i0)')'should be gone, varies with different putenv(3c): ',ierr +!! call execute_command_line('env|grep GRU') +!! write(*,'(a)')'system_unsetenv(3f) is a better way to remove variables' +!! ! +!! end program demo_system_putenv +!! +!! Results: +!! +!! no environment variables containing "GRU": +!! now "GRU" should be defined: 0 +!! GRU=this is the value +!! now "GRU" and "GRU2" should be defined: 0 +!! GRU2=this is the second value +!! GRU=this is the value +!! should be gone, varies with different putenv(3c): 0 +!! system_unsetenv(3f) is a better way to remove variables +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_putenv(string, err) + +! ident_22="@(#)M_system::system_putenv(3f): call putenv(3c)" + + INTERFACE + INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: c_string(*) + END FUNCTION + END INTERFACE + + CHARACTER(len=*), INTENT(in) :: string + INTEGER, OPTIONAL, INTENT(out) :: err + INTEGER :: loc_err + INTEGER :: i + + ! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit + CHARACTER(len=1, kind=C_CHAR), SAVE, POINTER :: memleak(:) + + ALLOCATE (memleak(LEN(string) + 1)) + DO i = 1, LEN(string) + memleak(i) = string(i:i) + END DO + memleak(LEN(string) + 1) = C_NULL_CHAR + + loc_err = c_putenv(memleak) + IF (PRESENT(err)) err = loc_err + +END SUBROUTINE system_putenv +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getenv(3f) - [M_system:ENVIRONMENT] get environment variable +!! from Fortran by calling get_environment_variable(3f) +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function system_getenv(name,default) +!! +!! character(len=:),allocatable :: system_getenv +!! character(len=*),intent(in) :: name +!! character(len=*),intent(in),optional :: default +!! +!!##DESCRIPTION +!! The system_getenv() function gets the value of an environment variable. +!! +!!##OPTIONS +!! name Return the value of the specified environment variable or +!! blank if the variable is not defined. +!! default If the value returned would be blank this value will be used +!! instead. +!! +!!##EXAMPLE +!! +!! Sample setting an environment variable from Fortran: +!! +!! program demo_system_getenv +!! use M_system, only : system_getenv +!! implicit none +!! write(*,'("USER : ",a)')system_getenv('USER') +!! write(*,'("LOGNAME : ",a)')system_getenv('LOGNAME') +!! write(*,'("USERNAME : ",a)')system_getenv('USERNAME') +!! end program demo_system_getenv +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_getenv(name, default) RESULT(VALUE) + +! ident_23="@(#)M_system::system_getenv(3f): call get_environment_variable as a function with a default value(3f)" + + CHARACTER(len=*), INTENT(in) :: name + CHARACTER(len=*), INTENT(in), OPTIONAL :: default + INTEGER :: howbig + INTEGER :: stat + CHARACTER(len=:), ALLOCATABLE :: VALUE + + IF (NAME .NE. '') THEN + call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value + IF (howbig .NE. 0) THEN + SELECT CASE (stat) + CASE (1) ! print *, NAME, " is not defined in the environment. Strange..." + VALUE = '' + CASE (2) ! print *, "This processor doesn't support environment variables. Boooh!" + VALUE = '' + CASE default ! make string to hold value of sufficient size and get value + IF (ALLOCATED(VALUE)) DEALLOCATE (VALUE) + ALLOCATE (CHARACTER(len=MAX(howbig, 1)) :: VALUE) + CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, status=stat, trim_name=.TRUE.) + IF (stat .NE. 0) VALUE = '' + END SELECT + ELSE + VALUE = '' + END IF + ELSE + VALUE = '' + END IF + IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default + +END FUNCTION system_getenv +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! set_environment_variable(3f) - [M_system:ENVIRONMENT] call setenv(3c) to set environment variable +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine set_environment_variable(NAME, VALUE, STATUS) +!! +!! character(len=*) :: NAME +!! character(len=*) :: VALUE +!! integer, optional, intent(out) :: STATUS +!! +!!##DESCRIPTION +!! The set_environment_variable() procedure adds or changes the value of environment variables. +!! +!!##OPTIONS +!! NAME If name does not already exist in the environment, then string is added to the environment. +!! If name does exist, then the value of name in the environment is changed to value. +!! VALUE Value to assign to environment variable NAME +!! STATUS returns zero on success, or nonzero if an error occurs. +!! A non-zero error usually indicates sufficient memory does not exist to store the +!! variable. +!! +!!##EXAMPLE +!! +!! Sample setting an environment variable from Fortran: +!! +!! program demo_set_environment_variable +!! use M_system, only : set_environment_variable +!! use iso_c_binding +!! implicit none +!! integer :: ierr +!! !! +!! write(*,'(a)')'no environment variables containing "GRU":' +!! call execute_command_line('env|grep GRU') +!! !! +!! call set_environment_variable('GRU','this is the value',ierr) +!! write(*,'(a,i0)')'now "GRU" should be defined, status=',ierr +!! call execute_command_line('env|grep GRU') +!! !! +!! call set_environment_variable('GRU2','this is the second value',ierr) +!! write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined, status =',ierr +!! !! +!! call execute_command_line('env|grep GRU') +!! end program demo_set_environment_variable +!! +!! Results: +!! +!! no environment variables containing "GRU": +!! now "GRU" should be defined, status=0 +!! GRU=this is the value +!! now "GRU" and "GRU2" should be defined, status =0 +!! GRU2=this is the second value +!! GRU=this is the value +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE set_environment_variable(NAME, VALUE, STATUS) + +! ident_24="@(#)M_system::set_environment_variable(3f): call setenv(3c) to set environment variable" + + CHARACTER(len=*) :: NAME + CHARACTER(len=*) :: VALUE + INTEGER, OPTIONAL, INTENT(out) :: STATUS + INTEGER :: loc_err + + INTERFACE + INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: c_name(*) + CHARACTER(kind=C_CHAR) :: c_VALUE(*) + END FUNCTION + END INTERFACE + + loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) + IF (PRESENT(STATUS)) STATUS = loc_err +END SUBROUTINE set_environment_variable +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_clearenv(3f) - [M_system:ENVIRONMENT] clear environment by calling clearenv(3c) +!! (LICENSE:PD) +!! +!! +!!##SYNOPSIS +!! +!! subroutine system_clearenv(ierr) +!! +!! integer,intent(out),optional :: ierr +!! +!!##DESCRIPTION +!! The clearenv() procedure clears the environment of all name-value +!! pairs. Typically used in security-conscious applications or ones where +!! configuration control requires ensuring specific variables are set. +!! +!!##RETURN VALUES +!! ierr returns zero on success, and a nonzero value on failure. Optional. +!! If not present and an error occurs the program stops. +!! +!!##EXAMPLE +!! +!! +!! Sample program: +!! +!! program demo_system_clearenv +!! use M_system, only : system_clearenv +!! implicit none +!! ! environment before clearing +!! call execute_command_line('env|wc') +!! ! environment after clearing (not necessarily blank!!) +!! call system_clearenv() +!! call execute_command_line('env') +!! end program demo_system_clearenv +!! +!! Typical output: +!! +!! 89 153 7427 +!! PWD=/home/urbanjs/V600 +!! SHLVL=1 +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_clearenv(ierr) +! emulating because not available on some platforms + +! ident_25="@(#)M_system::system_clearenv(3f): emulate clearenv(3c) to clear environment" + + INTEGER, INTENT(out), OPTIONAL :: ierr + CHARACTER(len=:), ALLOCATABLE :: string + INTEGER :: ierr_local1, ierr_local2 + ierr_local2 = 0 + INFINITE: DO + CALL system_initenv() ! important -- changing table causes undefined behavior so reset after each unsetenv + string = system_readenv() ! get first name=value pair + IF (string .EQ. '') EXIT INFINITE + CALL system_unsetenv(string(1:INDEX(string, '=') - 1), ierr_local1) ! remove first name=value pair + IF (ierr_local1 .NE. 0) ierr_local2 = ierr_local1 + END DO INFINITE + IF (PRESENT(ierr)) THEN + ierr = ierr_local2 + ELSEIF (ierr_local2 .NE. 0) THEN ! if error occurs and not being returned, stop + WRITE (*, *) '*system_clearenv* error=', ierr_local2 + STOP + END IF +END SUBROUTINE system_clearenv +!--subroutine system_clearenv(ierr) +!--! clearenv(3c) not available on some systems I tried +!--! Found reference that if it is unavailable the assignment +! "environ = NULL;" will probably do but emulating instead +!--$@ (#)M_system::system_clearenv(3f): call clearenv(3c) to clear +! "environment" +!--integer,intent(out),optional :: ierr +!-- integer :: ierr_local +!-- +!--interface +!-- integer(kind=c_int) function c_clearenv() bind(C,NAME="clearenv") +!-- import c_int +!-- end function +!--end interface +!-- +!-- ierr_local = c_clearenv() +!-- if(present(ierr))then +!-- ierr=ierr_local +!-- elseif(ierr_local.ne.0)then ! if error occurs and not being returned, stop +!-- write(*,*)'*system_clearenv* error=',ierr_local +!-- stop +!-- endif +!-- +!--end subroutine system_clearenv +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_unsetenv(3f) - [M_system:ENVIRONMENT] delete an environment variable by calling unsetenv(3c) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_unsetenv(name,ierr) +!! +!! character(len=*),intent(in) :: name +!! integer,intent(out),optional :: ierr +!! +!!##DESCRIPTION +!! +!! The system_unsetenv(3f) function deletes the variable name from the +!! environment. +!! +!!##OPTIONS +!! name name of variable to delete. +!! If name does not exist in the environment, then the +!! function succeeds, and the environment is unchanged. +!! +!! ierr The system_unsetenv(3f) function returns zero on success, or -1 on error. +!! name is NULL, points to a string of length 0, or contains an '=' character. +!! Insufficient memory to add a new variable to the environment. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_unsetenv +!! use M_system, only : system_unsetenv, system_putenv +!! implicit none +!! call system_putenv('GRU=this is the value') +!! write(*,'(a)')'The variable GRU should be set' +!! call execute_command_line('env|grep GRU') +!! call system_unsetenv('GRU') +!! write(*,'(a)')'The variable GRU should not be set' +!! call execute_command_line('env|grep GRU') +!! end program demo_system_unsetenv +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_unsetenv(name, ierr) + +! ident_26="@(#)M_system::system_unsetenv(3f): call unsetenv(3c) to remove variable from environment" + + CHARACTER(len=*), INTENT(in) :: name + INTEGER, INTENT(out), OPTIONAL :: ierr + INTEGER :: ierr_local + +! int unsetenv(void) + INTERFACE + INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") + IMPORT C_INT, C_CHAR + CHARACTER(len=1, kind=C_CHAR) :: c_name(*) + END FUNCTION + END INTERFACE + + ierr_local = c_unsetenv(str2_carr(TRIM(NAME))) + + IF (PRESENT(ierr)) THEN + ierr = ierr_local + ELSEIF (ierr_local .NE. 0) THEN ! if error occurs and not being returned, stop + WRITE (*, *) '*system_unsetenv* error=', ierr_local + STOP + END IF + +END SUBROUTINE system_unsetenv +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_readenv(3f) - [M_system:ENVIRONMENT] step thru and read environment table +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function system_readenv() result(string) +!! +!! character(len=:),allocatable :: string +!!##DESCRIPTION +!! A simple interface allows reading the environment variable table of the process. Call +!! system_initenv(3f) to initialize reading the environment table, then call system_readenv(3f) can +!! be called until a blank line is returned. If more than one thread +!! reads the environment or the environment is changed while being read the results are undefined. +!!##OPTIONS +!! string the string returned from the environment of the form "NAME=VALUE" +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_readenv +!! use M_system, only : system_initenv, system_readenv +!! character(len=:),allocatable :: string +!! call system_initenv() +!! do +!! string=system_readenv() +!! if(string.eq.'')then +!! exit +!! else +!! write(*,'(a)')string +!! endif +!! enddo +!! end program demo_system_readenv +!! +!! Sample results: +!! +!! USERDOMAIN_ROAMINGPROFILE=buzz +!! HOMEPATH=\Users\JSU +!! APPDATA=C:\Users\JSU\AppData\Roaming +!! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man::: +!! DISPLAYNUM=0 +!! ProgramW6432=C:\Program Files +!! HOSTNAME=buzz +!! XKEYSYMDB=/usr/share/X11/XKeysymDB +!! PUBLISH_CMD= +!! OnlineServices=Online Services +!! : +!! : +!! : +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_readenv() RESULT(string) + +! ident_27="@(#)M_system::system_readenv(3f): read next entry from environment table" + + CHARACTER(len=:), ALLOCATABLE :: string + CHARACTER(kind=C_CHAR) :: c_buff(longest_env_variable + 1) + + INTERFACE + SUBROUTINE c_readenv(c_string) BIND(C, NAME='my_readenv') + IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T + CHARACTER(kind=C_CHAR), INTENT(out) :: c_string(*) + END SUBROUTINE c_readenv + END INTERFACE + + c_buff = ' ' + c_buff(longest_env_variable + 1:longest_env_variable + 1) = C_NULL_CHAR + CALL c_readenv(c_buff) + string = TRIM(arr2str(c_buff)) + +END FUNCTION system_readenv +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! fileglob(3f) - [M_system:QUERY_FILE] Read output of an ls(1) command from Fortran +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine fileglob(glob,list) +!! +!! character(len=*),intent(in) :: glob +!! character(len=*),pointer :: list(:) +!! +!!##DESCRIPTION +!! Non-portable procedure uses the shell and the ls(1) command to expand a filename +!! and returns a pointer to a list of expanded filenames. +!! +!!##OPTIONS +!! glob Pattern for the filenames (like: *.txt) +!! list Allocated list of filenames (returned), the caller must deallocate it. +!! +!!##EXAMPLE +!! +!! Read output of an ls(1) command from Fortran +!! +!! program demo_fileglob ! simple unit test +!! call tryit('*.*') +!! call tryit('/tmp/__notthere.txt') +!! contains +!! +!! subroutine tryit(string) +!! use M_system, only : fileglob +!! character(len=255),pointer :: list(:) +!! character(len=*) :: string +!! call fileglob(string, list) +!! write(*,*)'Files:',size(list) +!! write(*,'(a)')(trim(list(i)),i=1,size(list)) +!! deallocate(list) +!! end subroutine tryit +!! +!! end program demo_fileglob ! simple unit test +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE fileglob(glob, list) ! NON-PORTABLE AT THIS POINT. REQUIRES ls(1) command, assumes 1 line per file +! The length of the character strings in list() must be long enough for the filenames. +! The list can be zero names long, it is still allocated. + IMPLICIT NONE + +! ident_28="@(#)M_system::fileglob(3f): Returns list of files using a file globbing pattern" + +!----------------------------------------------------------------------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: glob ! Pattern for the filenames (like: *.txt) + CHARACTER(len=*), POINTER :: list(:) ! Allocated list of filenames (returned), the caller must deallocate it. +!----------------------------------------------------------------------------------------------------------------------------------- + CHARACTER(len=255) :: tmpfile ! scratch filename to hold expanded file list + CHARACTER(len=255) :: cmd ! string to build system command in + INTEGER :: iotmp ! needed to open unique scratch file for holding file list + INTEGER :: i, ios, icount + write(tmpfile,'(*(g0))')'/tmp/__filelist_',timestamp(),'_',system_getpid() ! preliminary scratch file name + cmd = 'ls -d '//TRIM(glob)//'>'//TRIM(tmpfile)//' ' ! build command string + CALL execute_command_line(cmd) ! Execute the command specified by the string. + OPEN (newunit=iotmp, file=tmpfile, iostat=ios) ! open unique scratch filename + IF (ios .NE. 0) RETURN ! the open failed + icount = 0 ! number of filenames in expanded list + DO ! count the number of lines (assumed ==files) so know what to allocate + READ (iotmp, '(a)', iostat=ios) ! move down a line in the file to count number of lines + IF (ios .NE. 0) EXIT ! hopefully, this is because end of file was encountered so done + icount = icount + 1 ! increment line count + END DO + REWIND (iotmp) ! rewind file list so can read and store it + ALLOCATE (list(icount)) ! allocate and fill the array + DO i = 1, icount + READ (iotmp, '(a)') list(i) ! read a filename from a line + END DO + CLOSE (iotmp, status='delete', iostat=ios) ! close and delete scratch file +END SUBROUTINE fileglob +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_uname(3f) - [M_system] call a C wrapper that calls uname(3c) to get current system information from Fortran +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_uname(WHICH,NAMEOUT) +!! +!! character(KIND=C_CHAR),intent(in) :: WHICH +!! character(len=*),intent(out) :: NAMEOUT +!!##DESCRIPTION +!! Given a letter, return a corresponding description of the current operating system. +!! The NAMEOUT variable is assumed sufficiently large enough to hold the value. +!! +!! s return the kernel name +!! r return the kernel release +!! v return the kernel version +!! n return the network node hostname +!! m return the machine hardware name +!! T test mode -- print all information, in the following order - srvnm +!! +!!##EXAMPLE +!! +!! Call uname(3c) from Fortran +!! +!! program demo_system_uname +!! use M_system, only : system_uname +!! implicit none +!! integer,parameter :: is=100 +!! integer :: i +!! character(len=*),parameter :: letters='srvnmxT' +!! character(len=is) :: string=' ' +!! +!! do i=1,len(letters) +!! write(*,'(80("="))') +!! call system_uname(letters(i:i),string) +!! write(*,*)'=====> TESTING system_uname('//letters(i:i)//')--->'//trim(string) +!! enddo +!! +!! end program demo_system_uname +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_uname(WHICH, NAMEOUT) + IMPLICIT NONE + +! ident_29="@(#)M_system::system_uname(3f): call my_uname(3c) which calls uname(3c)" + + CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH + CHARACTER(len=*), INTENT(out) :: NAMEOUT + +! describe the C routine to Fortran +! void system_uname(char *which, char *buf, int *buflen); + INTERFACE + SUBROUTINE system_uname_c(WHICH, BUF, BUFLEN) BIND(C, NAME='my_uname') + IMPORT C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH + CHARACTER(KIND=C_CHAR), INTENT(out) :: BUF(*) + INTEGER(kind=C_INT), INTENT(in) :: BUFLEN + END SUBROUTINE system_uname_c + END INTERFACE + + NAMEOUT = 'unknown' + CALL system_uname_c(WHICH, NAMEOUT, INT(LEN(NAMEOUT), KIND(0_C_INT))) + +END SUBROUTINE system_uname +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_gethostname(3f) - [M_system:QUERY] get name of current host +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine system_gethostname(string,ierr) +!! +!! character(len=:),allocatable,intent(out) :: NAME +!! integer,intent(out) :: IERR +!!##DESCRIPTION +!! The system_gethostname(3f) procedure returns the standard host +!! name for the current machine. +!! +!!##OPTIONS +!! string returns the hostname. Must be an allocatable CHARACTER variable. +!! ierr Upon successful completion, 0 shall be returned; otherwise, -1 +!! shall be returned. +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_gethostname +!! use M_system, only : system_gethostname +!! implicit none +!! character(len=:),allocatable :: name +!! integer :: ierr +!! call system_gethostname(name,ierr) +!! if(ierr.eq.0)then +!! write(*,'("hostname[",a,"]")')name +!! else +!! write(*,'(a)')'ERROR: could not get hostname' +!! endif +!! end program demo_system_gethostname +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_gethostname(NAME, IERR) + IMPLICIT NONE + +! ident_30="@(#)M_system::system_gethostname(3f): get name of current host by calling gethostname(3c)" + + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: NAME + INTEGER, INTENT(out) :: IERR + CHARACTER(kind=C_CHAR, len=1) :: C_BUFF(HOST_NAME_MAX + 1) + +! describe the C routine to Fortran +!int gethostname(char *name, size_t namelen); + INTERFACE + FUNCTION system_gethostname_c(c_buf, c_buflen) BIND(C, NAME='gethostname') + IMPORT C_CHAR, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: system_gethostname_c + CHARACTER(KIND=C_CHAR), INTENT(out) :: c_buf(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: c_buflen + END FUNCTION system_gethostname_c + END INTERFACE + + C_BUFF = ' ' + ierr = system_gethostname_c(C_BUFF, HOST_NAME_MAX) ! Host names are limited to {HOST_NAME_MAX} bytes. + NAME = TRIM(arr2str(C_BUFF)) + +END SUBROUTINE system_gethostname +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getlogin(3f) - [M_system:QUERY] get login name +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function system_getlogin() result (fname) +!! +!! character(len=:),allocatable :: FNAME +!! +!!##DESCRIPTION +!! +!! The system_getlogin(3f) function returns a string containing the user +!! name associated by the login activity with the controlling terminal +!! of the current process. Otherwise, it returns a null string and sets +!! errno to indicate the error. +!! +!! Three names associated with the current process can be determined: +!! +!! o system_getpwuid(system_getuid()) returns the name associated with the real user ID of the process. +!! o system_getpwuid(system_geteuid()) returns the name associated with the effective user ID of the process +!! o system_getlogin() returns the name associated with the current login activity +!! +!!##RETURN VALUE +!! fname returns the login name. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_getlogin +!! use M_system, only : system_getlogin +!! implicit none +!! character(len=:),allocatable :: name +!! name=system_getlogin() +!! write(*,'("login[",a,"]")')name +!! end program demo_system_getlogin +!! +!! Results: +!! +!! login[JSU] +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +!-- The following example calls the getlogin() function to obtain the name of the user associated with the calling process, +!-- and passes this information to the getpwnam() function to get the associated user database information. +!-- ... +!-- char *lgn; +!-- struct passwd *pw; +!-- ... +!-- if ((lgn = getlogin()) == NULL || (pw = getpwnam(lgn)) == NULL) { +!-- fprintf(stderr, "Get of user information failed.\n"); exit(1); +!-- } +!--APPLICATION USAGE +!--SEE ALSO +!-- getpwnam(), getpwuid(), system_geteuid(), getuid() +FUNCTION system_getlogin() RESULT(fname) + CHARACTER(len=:), ALLOCATABLE :: fname + TYPE(C_PTR) :: username + + INTERFACE + FUNCTION c_getlogin() BIND(c, name="getlogin") RESULT(c_username) + IMPORT C_INT, C_PTR + TYPE(C_PTR) :: c_username + END FUNCTION c_getlogin + END INTERFACE + + username = c_getlogin() + IF (.NOT. C_ASSOCIATED(username)) THEN + !! in windows 10 subsystem running Ubunto does not work + !!write(*,'(a)')'*system_getlogin* Error getting username. not associated' + !!fname=c_null_char + fname = system_getpwuid(system_geteuid()) + ELSE + fname = c2f_string(username) + END IF + +END FUNCTION system_getlogin +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_perm(3f) - [M_system:QUERY_FILE] get file type and permission as a string +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function system_perm(mode) result (perms) +!! +!! integer(kind=int64),intent(in) :: MODE +!! character(len=:),allocatable :: PERMS +!! +!!##DESCRIPTION +!! +!! The system_perm(3f) function returns a string containing the type +!! and permission of a file implied by the value of the mode value. +!! +!!##RETURN VALUE +!! PERMS returns the permission string in a format similar to that +!! used by Unix commands such as ls(1). +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_perm +!! use M_system, only : system_perm, system_stat +!! use,intrinsic :: iso_fortran_env, only : int64 +!! implicit none +!! character(len=4096) :: string +!! integer(kind=int64) :: values(13) +!! integer :: ierr +!! character(len=:),allocatable :: perms +!! values=0 +!! ! get pathname from command line +!! call get_command_argument(1, string) +!! ! get pathname information +!! call system_stat(string,values,ierr) +!! if(ierr.eq.0)then +!! ! convert permit mode to a string +!! perms=system_perm(values(3)) +!! ! print permits as a string, decimal value, and octal value +!! write(*,'("for ",a," permits[",a,"]",1x,i0,1x,o0)') & +!! & trim(string),perms,values(3),values(3) +!! endif +!! end program demo_system_perm +!! +!! Results: +!! +!! demo_system_perm /tmp +!! +!! for /tmp permits[drwxrwxrwx --S] 17407 41777 +!! +!!##AUTHOR +!! John S. Urban +!! +!!##LICENSE +!! Public Domain +FUNCTION system_perm(mode) RESULT(perms) + CLASS(*), INTENT(in) :: mode + CHARACTER(len=:), ALLOCATABLE :: perms + TYPE(C_PTR) :: permissions + INTEGER(kind=C_LONG) :: mode_local + INTERFACE + FUNCTION c_perm(c_mode) BIND(c, name="my_get_perm") RESULT(c_permissions) + IMPORT C_INT, C_PTR, C_LONG + INTEGER(kind=C_LONG), VALUE :: c_mode + TYPE(C_PTR) :: c_permissions + END FUNCTION c_perm + END INTERFACE + + mode_local = INT(anyinteger_to_64bit(mode), kind=C_LONG) + permissions = c_perm(mode_local) + IF (.NOT. C_ASSOCIATED(permissions)) THEN + WRITE (*, '(a)') '*system_perm* Error getting permissions. not associated' + perms = C_NULL_CHAR + ELSE + perms = c2f_string(permissions) + END IF + +END FUNCTION system_perm +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getgrgid(3f) - [M_system:QUERY] get groupd name associated with a GID +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function system_getgrgid(gid) result (gname) +!! +!! class(*),intent(in) :: gid ! any INTEGER type +!! character(len=:),allocatable :: gname +!! +!!##DESCRIPTION +!! +!! The system_getlogin() function returns a string containing the group +!! name associated with the given GID. If no match is found +!! it returns a null string and sets errno to indicate the error. +!! +!!##OPTION +!! gid GID to try to look up associated group for. Can be of any +!! INTEGER type. +!! +!!##RETURN VALUE +!! gname returns the group name. Blank if an error occurs +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_getgrgid +!! use M_system, only : system_getgrgid +!! use M_system, only : system_getgid +!! implicit none +!! character(len=:),allocatable :: name +!! name=system_getgrgid( system_getgid() ) +!! write(*,'("group[",a,"] for ",i0)')name,system_getgid() +!! end program demo_system_getgrgid +!! +!! Results: +!! +!! group[default] for 197121 +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_getgrgid(gid) RESULT(gname) + CLASS(*), INTENT(in) :: gid + CHARACTER(len=:), ALLOCATABLE :: gname + CHARACTER(kind=C_CHAR, len=1) :: groupname(4097) ! assumed long enough for any groupname + INTEGER :: ierr + INTEGER(kind=C_LONG_LONG) :: gid_local + + INTERFACE + function c_getgrgid(c_gid,c_groupname) bind(c,name="my_getgrgid") result(c_ierr) + IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG + INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_gid + CHARACTER(kind=C_CHAR), INTENT(out) :: c_groupname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_getgrgid + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + gid_local = anyinteger_to_64bit(gid) + ierr = c_getgrgid(gid_local, groupname) + IF (ierr .EQ. 0) THEN + gname = TRIM(arr2str(groupname)) + ELSE + gname = '' + END IF +!----------------------------------------------------------------------------------------------------------------------------------- +END FUNCTION system_getgrgid +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_getpwuid(3f) - [M_system:QUERY] get login name associated with a UID +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function system_getpwuid(uid) result (uname) +!! +!! class(*),intent(in) :: uid ! any INTEGER type +!! character(len=:),allocatable :: uname +!! +!!##DESCRIPTION +!! +!! The system_getpwuid() function returns a string containing the user +!! name associated with the given UID. If no match is found it returns +!! a null string and sets errno to indicate the error. +!! +!!##OPTION +!! uid UID to try to look up associated username for. Can be of any +!! INTEGER type. +!! +!!##RETURN VALUE +!! uname returns the login name. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_getpwuid +!! use M_system, only : system_getpwuid +!! use M_system, only : system_getuid +!! use,intrinsic :: iso_fortran_env, only : int64 +!! implicit none +!! character(len=:),allocatable :: name +!! integer(kind=int64) :: uid +!! uid=system_getuid() +!! name=system_getpwuid(uid) +!! write(*,'("login[",a,"] has UID ",i0)')name,uid +!! end program demo_system_getpwuid +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +FUNCTION system_getpwuid(uid) RESULT(uname) + CLASS(*), INTENT(in) :: uid + CHARACTER(len=:), ALLOCATABLE :: uname + CHARACTER(kind=C_CHAR, len=1) :: username(4097) ! assumed long enough for any username + INTEGER :: ierr + INTEGER(kind=C_LONG_LONG) :: uid_local + + INTERFACE + function c_getpwuid(c_uid,c_username) bind(c,name="my_getpwuid") result(c_ierr) + IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG + INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_uid + CHARACTER(kind=C_CHAR), INTENT(out) :: c_username(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_getpwuid + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + uid_local = anyinteger_to_64bit(uid) + ierr = c_getpwuid(uid_local, username) + IF (ierr .EQ. 0) THEN + uname = TRIM(arr2str(username)) + ELSE + uname = '' + END IF +!----------------------------------------------------------------------------------------------------------------------------------- +END FUNCTION system_getpwuid +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +PURE FUNCTION arr2str(array) RESULT(string) + +! ident_31="@(#)M_system::arr2str(3fp): function copies null-terminated char array to string" + + CHARACTER(len=1), INTENT(in) :: array(:) + CHARACTER(len=SIZE(array)) :: string + INTEGER :: i + + string = ' ' + DO i = 1, SIZE(array) + IF (array(i) .EQ. CHAR(0)) THEN + EXIT + ELSE + string(i:i) = array(i) + END IF + END DO + +END FUNCTION arr2str +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +PURE FUNCTION str2_carr(string) RESULT(array) + +! ident_32="@(#)M_system::str2_carr(3fp): function copies string to null terminated char array" + + CHARACTER(len=*), INTENT(in) :: string + CHARACTER(len=1, kind=C_CHAR) :: array(LEN(string) + 1) + INTEGER :: i + + DO i = 1, LEN_TRIM(string) + array(i) = string(i:i) + END DO + array(i:i) = C_NULL_CHAR + +END FUNCTION str2_carr +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +FUNCTION C2F_string(c_string_pointer) RESULT(f_string) + +! gets a C string (pointer), and returns the corresponding Fortran string up to 4096(max_len) characters; +! If the C string is null, it returns string C "null" character: + + TYPE(C_PTR), INTENT(in) :: c_string_pointer + CHARACTER(len=:), ALLOCATABLE :: f_string + CHARACTER(kind=C_CHAR), DIMENSION(:), POINTER :: char_array_pointer => NULL() + INTEGER, PARAMETER :: max_len = 4096 + CHARACTER(len=max_len) :: aux_string + INTEGER :: i + INTEGER :: length + + length = 0 + CALL C_F_POINTER(c_string_pointer, char_array_pointer, [max_len]) + + IF (.NOT. ASSOCIATED(char_array_pointer)) THEN + IF (ALLOCATED(f_string)) DEALLOCATE (f_string) + ALLOCATE (CHARACTER(len=4) :: f_string) + f_string = C_NULL_CHAR + RETURN + END IF + + aux_string = " " + + DO i = 1, max_len + IF (char_array_pointer(i) == C_NULL_CHAR) THEN + length = i - 1; EXIT + END IF + aux_string(i:i) = char_array_pointer(i) + END DO + + IF (ALLOCATED(f_string)) DEALLOCATE (f_string) + ALLOCATE (CHARACTER(len=length) :: f_string) + f_string = aux_string(1:length) +END FUNCTION C2F_string +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! SYSTEM_STAT - [M_system:QUERY_FILE] Get file status information +!! (LICENSE:PD) +!! +!!##SYNTAX +!! CALL SYSTEM_STAT(NAME, VALUES [, STATUS],[DEBUG]) +!! +!! character(len=*),intent(in) :: NAME +!! integer(kind=int64),intent(out) :: values(13) +!! integer,optional,intent(out) :: status +!! integer,intent(in) :: debug +!! +!!##DESCRIPTION +!! +!! This function returns information about a file. No permissions are +!! required on the file itself, but execute (search) permission is required +!! on all of the directories in path that lead to the file. The elements +!! that are obtained and stored in the array VALUES: +!! +!! VALUES(1) Device ID +!! VALUES(2) Inode number +!! VALUES(3) File mode +!! VALUES(4) Number of links +!! VALUES(5) Owner uid +!! VALUES(6) Owner gid +!! VALUES(7) ID of device containing directory entry for file (0 if not available) +!! VALUES(8) File size (bytes) +!! VALUES(9) Last access time as a Unix Epoch time rounded to seconds +!! VALUES(10) Last modification time as a Unix Epoch time rounded to seconds +!! VALUES(11) Last file status change time as a Unix Epoch time rounded to seconds +!! VALUES(12) Preferred I/O block size (-1 if not available) +!! VALUES(13) Number of blocks allocated (-1 if not available) +!! +!! Not all these elements are relevant on all systems. If an element is +!! not relevant, it is returned as 0. +!! +!!##OPTIONS +!! +!! NAME The type shall be CHARACTER, of the default kind and a valid +!! path within the file system. +!! VALUES The type shall be INTEGER(8), DIMENSION(13). +!! STATUS (Optional) status flag of type INTEGER(4). Returns 0 on success +!! and a system specific error code otherwise. +!! DEBUG (Optional) print values being returned from C routine being +!! called if value of 0 is used +!! +!!##EXAMPLE +!! +!! program demo_system_stat +!! +!! use M_system, only : system_stat, system_getpwuid, system_getgrgid +!! use M_time, only : fmtdate, u2d +!! use, intrinsic :: iso_fortran_env, only : int32, int64 +!! implicit none +!! +!! integer(kind=int64) :: buff(13) +!! integer(kind=int32) :: status +!! character(len=*),parameter :: fmt_date='year-month-day hour:minute:second' +!! +!! integer(kind=int64) :: & +!! Device_ID, Inode_number, File_mode, Number_of_links, +!! Owner_uid, & +!! Owner_gid, Directory_device, File_size, Last_access, +!! Last_modification,& +!! Last_status_change, Preferred_block_size, Number_of_blocks_allocated +!! equivalence & +!! ( buff(1) , Device_ID ) , & +!! ( buff(2) , Inode_number ) , & +!! ( buff(3) , File_mode ) , & +!! ( buff(4) , Number_of_links ) , & +!! ( buff(5) , Owner_uid ) , & +!! ( buff(6) , Owner_gid ) , & +!! ( buff(7) , Directory_device ) , & +!! ( buff(8) , File_size ) , & +!! ( buff(9) , Last_access ) , & +!! ( buff(10) , Last_modification ) , & +!! ( buff(11) , Last_status_change ) , & +!! ( buff(12) , Preferred_block_size ) , & +!! ( buff(13) , Number_of_blocks_allocated ) +!! +!! CALL SYSTEM_STAT("/etc/hosts", buff, status) +!! +!! if (status == 0) then +!! write (*, FMT="('Device ID(hex/decimal):', & +!! & T30, Z0,'h/',I0,'d')") buff(1),buff(1) +!! write (*, FMT="('Inode number:', & +!! & T30, I0)") buff(2) +!! write (*, FMT="('File mode (octal):', & +!! & T30, O19)") buff(3) +!! write (*, FMT="('Number of links:', & +!! & T30, I0)") buff(4) +!! write (*, FMT="('Owner''s uid/username:', & +!! & T30, I0,1x, A)") buff(5), system_getpwuid(buff(5)) +!! write (*, FMT="('Owner''s gid/group:', & +!! & T30, I0,1x, A)") buff(6), system_getgrgid(buff(6)) +!! write (*, FMT="('Device where located:', & +!! & T30, I0)") buff(7) +!! write (*, FMT="('File size(bytes):', & +!! & T30, I0)") buff(8) +!! write (*, FMT="('Last access time:', & +!! & T30, I0,1x, A)") buff(9), fmtdate(u2d(int(buff(9))),fmt_date) +!! write (*, FMT="('Last modification time:', & +!! & T30, I0,1x, A)") buff(10),fmtdate(u2d(int(buff(10))),fmt_date) +!! write (*, FMT="('Last status change time:', & +!! & T30, I0,1x, A)") buff(11),fmtdate(u2d(int(buff(11))),fmt_date) +!! write (*, FMT="('Preferred block size(bytes):', & +!! & T30, I0)") buff(12) +!! write (*, FMT="('No. of blocks allocated:', & +!! & T30, I0)") buff(13) +!! endif +!! +!! end program demo_system_stat +!! +!! Results: +!! +!! Device ID(hex/decimal): 3E6BE045h/1047257157d +!! Inode number: 1407374886070599 +!! File mode (octal): 100750 +!! Number of links: 1 +!! Owner uid/username: 18 SYSTEM +!! Owner gid/group: 18 SYSTEM +!! Device where located: 0 +!! File size(bytes): 824 +!! Last access time: 1557983191 2019-05-16 01:06:31 +!! Last modification time: 1557983191 2019-05-16 01:06:31 +!! Last status change time: 1557983532 2019-05-16 01:12:12 +!! Preferred block size(bytes): 65536 +!! No. of blocks allocated: 4 +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +SUBROUTINE system_stat(pathname, values, ierr) + IMPLICIT NONE + +! ident_33="@(#)M_system::system_stat(3f): call stat(3c) to get pathname information" + + CHARACTER(len=*), INTENT(in) :: pathname + + INTEGER(kind=INT64), INTENT(out) :: values(13) + INTEGER(kind=C_LONG) :: cvalues(13) + + INTEGER, OPTIONAL, INTENT(out) :: ierr + INTEGER(kind=C_INT) :: cierr + + INTERFACE + SUBROUTINE c_stat(buffer, cvalues, cierr, cdebug) BIND(c, name="my_stat") + IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT, C_LONG + CHARACTER(kind=C_CHAR), INTENT(in) :: buffer(*) + INTEGER(kind=C_LONG), INTENT(out) :: cvalues(*) + INTEGER(kind=C_INT) :: cierr + INTEGER(kind=C_INT), INTENT(in) :: cdebug + END SUBROUTINE c_stat + END INTERFACE +!----------------------------------------------------------------------------------------------------------------------------------- + CALL c_stat(str2_carr(TRIM(pathname)), cvalues, cierr, 0_C_INT) + values = cvalues + IF (PRESENT(ierr)) THEN + ierr = cierr + END IF +END SUBROUTINE system_stat +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! system_dir(3f) - [M_io] return filenames in a directory matching specified wildcard string +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function system_dir(directory,pattern) +!! +!! character(len=*),intent(in),optional :: directory +!! character(len=*),intent(in),optional :: pattern +!! character(len=:),allocatable :: system_dir(:) +!! +!!##DESCRIPTION +!! returns an array of filenames in the specified directory matching +!! the wildcard string (which defaults to "*"). +!! +!!##OPTIONS +!! DIRECTORY name of directory to match filenames in. Defaults to ".". +!! PATTERN wildcard string matching the rules of the matchw(3f) function. Basically +!! o "*" matches anything +!! o "?" matches any single character +!! +!!##RETURNS +!! system_dir An array right-padded to the length of the longest +!! filename. Note that this means filenames actually containing +!! trailing spaces in their names may be incorrect. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_system_dir +!! use M_system, only : system_dir +!! implicit none +!! write(*, '(a)')system_dir(pattern='*.F90') +!! end program demo_system_dir +!! +!!##AUTHOR +!! John S. Urban +!! +!!##LICENSE +!! Public Domain +FUNCTION system_dir(directory, pattern) +!use M_system, only : system_opendir, system_readdir, system_rewinddir, system_closedir + USE ISO_C_BINDING + IMPLICIT NONE + CHARACTER(len=*), INTENT(in), OPTIONAL :: directory + CHARACTER(len=*), INTENT(in), OPTIONAL :: pattern + CHARACTER(len=:), ALLOCATABLE :: system_dir(:) + CHARACTER(len=:), ALLOCATABLE :: wild + TYPE(C_PTR) :: dir + CHARACTER(len=:), ALLOCATABLE :: filename + INTEGER :: i, ierr, icount, longest + longest = 0 + icount = 0 + IF (PRESENT(pattern)) THEN + wild = pattern + ELSE + wild = '*' + END IF + IF (PRESENT(directory)) THEN !--- open directory stream to read from + CALL system_opendir(directory, dir, ierr) + ELSE + CALL system_opendir('.', dir, ierr) + END IF + IF (ierr .EQ. 0) THEN + DO i = 1, 2 !--- read directory stream twice, first time to get size + DO + CALL system_readdir(dir, filename, ierr) + IF (filename .EQ. ' ') EXIT + IF (wild .NE. '*') THEN + IF (.NOT. matchw(filename, wild)) CYCLE ! Call a wildcard matching routine. + END IF + icount = icount + 1 + SELECT CASE (i) + CASE (1) + longest = MAX(longest, LEN(filename)) + CASE (2) + system_dir(icount) = filename + END SELECT + END DO + IF (i .EQ. 1) THEN + CALL system_rewinddir(dir) + IF (ALLOCATED(system_dir)) DEALLOCATE (system_dir) + ALLOCATE (CHARACTER(len=longest) :: system_dir(icount)) + icount = 0 + END IF + END DO + END IF + CALL system_closedir(dir, ierr) !--- close directory stream +END FUNCTION system_dir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +! copied from M_strings.ff to make stand-alone github version +FUNCTION matchw(tame, wild) + +! ident_34="@(#)M_strings::matchw(3f): function compares text strings, one of which can have wildcards ('*' or '?')." + + LOGICAL :: matchw + CHARACTER(len=*) :: tame ! A string without wildcards + CHARACTER(len=*) :: wild ! A (potentially) corresponding string with wildcards + CHARACTER(len=LEN(tame) + 1) :: tametext + CHARACTER(len=LEN(wild) + 1) :: wildtext + CHARACTER(len=1), PARAMETER :: NULL = CHAR(0) + INTEGER :: wlen + INTEGER :: ti, wi + INTEGER :: i + CHARACTER(len=:), ALLOCATABLE :: tbookmark, wbookmark +! These two values are set when we observe a wildcard character. They +! represent the locations, in the two strings, from which we start once we've observed it. + tametext = tame//NULL + wildtext = wild//NULL + tbookmark = NULL + wbookmark = NULL + wlen = LEN(wild) + wi = 1 + ti = 1 + DO ! Walk the text strings one character at a time. + IF (wildtext(wi:wi) == '*') THEN ! How do you match a unique text string? + DO i = wi, wlen ! Easy: unique up on it! + IF (wildtext(wi:wi) .EQ. '*') THEN + wi = wi + 1 + ELSE + EXIT + END IF + END DO + IF (wildtext(wi:wi) .EQ. NULL) THEN ! "x" matches "*" + matchw = .TRUE. + RETURN + END IF + IF (wildtext(wi:wi) .NE. '?') THEN + ! Fast-forward to next possible match. + DO WHILE (tametext(ti:ti) .NE. wildtext(wi:wi)) + ti = ti + 1 + IF (tametext(ti:ti) .EQ. NULL) THEN + matchw = .FALSE. + RETURN ! "x" doesn't match "*y*" + END IF + END DO + END IF + wbookmark = wildtext(wi:) + tbookmark = tametext(ti:) + elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then + ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. + IF (wbookmark .NE. NULL) THEN + IF (wildtext(wi:) .NE. wbookmark) THEN + wildtext = wbookmark; + wlen = LEN_TRIM(wbookmark) + wi = 1 + ! Don't go this far back again. + IF (tametext(ti:ti) .NE. wildtext(wi:wi)) THEN + tbookmark = tbookmark(2:) + tametext = tbookmark + ti = 1 + CYCLE ! "xy" matches "*y" + ELSE + wi = wi + 1 + END IF + END IF + IF (tametext(ti:ti) .NE. NULL) THEN + ti = ti + 1 + CYCLE ! "mississippi" matches "*sip*" + END IF + END IF + matchw = .FALSE. + RETURN ! "xy" doesn't match "x" + END IF + ti = ti + 1 + wi = wi + 1 + IF (tametext(ti:ti) .EQ. NULL) THEN ! How do you match a tame text string? + IF (wildtext(wi:wi) .NE. NULL) THEN + DO WHILE (wildtext(wi:wi) == '*') ! The tame way: unique up on it! + wi = wi + 1 ! "x" matches "x*" + IF (wildtext(wi:wi) .EQ. NULL) EXIT + END DO + END IF + IF (wildtext(wi:wi) .EQ. NULL) THEN + matchw = .TRUE. + RETURN ! "x" matches "x" + END IF + matchw = .FALSE. + RETURN ! "x" doesn't match "xy" + END IF + END DO +END FUNCTION matchw +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!>NAME +!! +!! anyinteger_to_64bit(3f) - [M_anything] convert integer any kind to integer(kind=int64) +!! (LICENSE:PD) +!! +!!SYNOPSIS +!! +!! pure elemental function anyinteger_to_64bit(intin) result(ii38) +!! +!! integer(kind=int64) function anyinteger_to_64bit(value) +!! class(*),intent(in) :: intin +!! integer(kind=int8|int16|int32|int64) :: value +!! +!!DESCRIPTION +!! +!! This function uses polymorphism to allow arguments of different types +!! generically. It is used to create other procedures that can take +!! many scalar arguments as input options, equivalent to passing the +!! parameter VALUE as int(VALUE,0_int64). +!! +!!OPTIONS +!! +!! VALUEIN input argument of a procedure to convert to type INTEGER(KIND=int64). +!! May be of KIND kind=int8, kind=int16, kind=int32, kind=int64. +!!RESULTS +!! The value of VALUIN converted to INTEGER(KIND=INT64). +!!EXAMPLE +!! Sample program +!! +!! program demo_anyinteger_to_64bit +!! use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 +!! implicit none +!! ! call same function with many scalar input types +!! write(*,*)squarei(huge(0_int8)),huge(0_int8) , & +!! & '16129' +!! write(*,*)squarei(huge(0_int16)),huge(0_int16) , & +!! & '1073676289' +!! write(*,*)squarei(huge(0_int32)),huge(0_int32) , & +!! & '4611686014132420609' +!! write(*,*)squarei(huge(0_int64)),huge(0_int64) , & +!! & '85070591730234615847396907784232501249' +!! contains +!! ! +!! function squarei(invalue) +!! use M_anything, only : anyinteger_to_64bit +!! class(*),intent(in) :: invalue +!! doubleprecision :: invalue_local +!! doubleprecision :: squarei +!! invalue_local=anyinteger_to_64bit(invalue) +!! squarei=invalue_local*invalue_local +!! end function squarei +!! ! +!! end program demo_anyinteger_to_64bit +!! +!! Results +!! +!! 16129.000000000000 127 \ +!! 16129 +!! 1073676289.0000000 32767 \ +!! 1073676289 +!! 4.6116860141324206E+018 2147483647 \ +!! 4611686014132420609 +!! 8.5070591730234616E+037 9223372036854775807 \ +!! 85070591730234615847396907784232501249 +!! 2.8948022309329049E+076 170141183460469231731687303715884105727 \ +!! 28948022309329048855892746252171976962977213799489202546401021394546514198529 +!! +!!AUTHOR +!! John S. Urban +!!LICENSE +!! Public Domain +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +PURE ELEMENTAL FUNCTION anyinteger_to_64bit(intin) RESULT(ii38) + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT !! ,input_unit,output_unit + IMPLICIT NONE + +!!@(#) M_anything::anyinteger_to_64(3f): convert integer parameter of any kind to 64-bit integer + + CLASS(*), INTENT(in) :: intin + INTEGER(kind=INT64) :: ii38 + SELECT TYPE (intin) + TYPE is (INTEGER(kind=INT8)); ii38 = INT(intin, kind=INT64) + TYPE is (INTEGER(kind=INT16)); ii38 = INT(intin, kind=INT64) + TYPE is (INTEGER(kind=INT32)); ii38 = intin + TYPE is (INTEGER(kind=INT64)); ii38 = intin + !class default + !write(error_unit,*)'ERROR: unknown integer type' + !stop 'ERROR: *anyinteger_to_64* unknown integer type' + END SELECT +END FUNCTION anyinteger_to_64bit +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +END MODULE System_Method diff --git a/src/modules/System/src/System_Method.c b/src/modules/System/src/System_Method.c new file mode 100755 index 000000000..795659d2d --- /dev/null +++ b/src/modules/System/src/System_Method.c @@ -0,0 +1,641 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#ifndef __USE_POSIX +#define __USE_POSIX +#endif + +#include + +#ifndef HZ +#define HZ 60 +#endif + +#define MIN(x, y) ((x) < (y) ? (x) : (y)) + +extern char **environ; + +#ifdef Linux_SYSTEM +// extern int HOST_NAME_MAX; +int FHOST_NAME_MAX = HOST_NAME_MAX; +#endif + +#ifdef Darwin_SYSTEM +#define HOST_NAME_MAX 255 +int FHOST_NAME_MAX = HOST_NAME_MAX; +#endif + +extern mode_t FS_IRGRP; +extern mode_t FS_IROTH; +extern mode_t FS_IRUSR; +extern mode_t FS_IRWXG; +extern mode_t FS_IRWXO; +extern mode_t FS_IRWXU; +extern mode_t FS_IWGRP; +extern mode_t FS_IWOTH; +extern mode_t FS_IWUSR; +extern mode_t FS_IXGRP; +extern mode_t FS_IXOTH; +extern mode_t FS_IXUSR; +extern mode_t FDEFFILEMODE; +extern mode_t FACCESSPERMS; + +mode_t FS_IRGRP = S_IRGRP; +mode_t FS_IROTH = S_IROTH; +mode_t FS_IRUSR = S_IRUSR; +mode_t FS_IRWXG = S_IRWXG; +mode_t FS_IRWXO = S_IRWXO; +mode_t FS_IRWXU = S_IRWXU; +mode_t FS_IWGRP = S_IWGRP; +mode_t FS_IWOTH = S_IWOTH; +mode_t FS_IWUSR = S_IWUSR; +mode_t FS_IXGRP = S_IXGRP; +mode_t FS_IXOTH = S_IXOTH; +mode_t FS_IXUSR = S_IXUSR; +mode_t FDEFFILEMODE = DEFFILEMODE; +mode_t FACCESSPERMS = ACCESSPERMS; + +char **ep; + +extern long int longest_env_variable; +long int longest_env_variable = 0L; +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + wrapper around access(3c) for a call from Fortran +*/ +int my_access(const char *pathname, int which) { + int n; + /*fprintf(stdout," which values = %d %d %d %d + * %d\n",F_OK,R_OK,W_OK,X_OK,which);*/ + n = access(pathname, which); + return (n); +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* does a recursive mkdir(3c) for a POSIX pathname */ +void my_mkdir(char *dir, int mode, int *ier) { + char *p = NULL; + char buf[4096]; + size_t len; + + snprintf(buf, sizeof(buf), "%s", dir); + len = strlen(buf); + if (buf[len - 1] == '/') { + buf[len - 1] = 0; + } + for (p = buf + 1; *p; p++) { + if (*p == '/') { + *p = 0; + mkdir(buf, mode); + *p = '/'; + } + } + *ier = mkdir(buf, mode); +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + wrapper around utime(3c) for a call from Fortran +*/ +int my_utime(const char *file, int times[2]) { + struct utimbuf ut; + /* time_t ut[2]; */ + int n; + + ut.actime = (time_t)times[0]; + ut.modtime = (time_t)times[1]; + n = utime(file, &ut); + /* + ut[0] = times[0]; + ut[1] = times[l]; + n = utime (file, ut); + */ + return (n); +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + wrapper around chown(3c) for a call from Fortran +*/ +int my_chown(char *filename, long long int uid, long long int gid) { + return chown(filename, (uid_t)uid, (gid_t)gid); +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + wrapper around readdir(3c) for a call from Fortran +*/ +void my_readdir(DIR *dirp, char *filename, int *ierr) { + + struct dirent *dp; + int length; + + *ierr = 0; + length = 0; + + if ((dp = readdir(dirp)) != NULL) { + length = (int)strlen(dp->d_name) + 1; + memcpy(filename, dp->d_name, length); + } else { + *ierr = -1; /*When the end of the directory is encountered, a null pointer + is returned and errno is not changed.*/ + } +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + flush stdin and stderr and all files open in C +*/ +void my_flush(void) { + fflush(NULL); + /* For good measure */ + fflush(stdin); + fflush(stdout); +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +char *my_realpath(char *symlinkpath) { return (realpath(symlinkpath, NULL)); } +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + wrapper to step through environment table +*/ +/*--------------------------------------------------------------------------------------------------------------------------------*/ +void my_initenv() { + /* + Set pointer into environment table to beginning of table, + but find longest current variable length so can make buffer + big enough by scanning current table. There is probably a + C variable that defines this length; but hopefully this + entire method of reading the environment table will be + superseded if I can figure out what is wrong with the + version that returns an arbitrary string length directly. + See: + xargs --show-limits + */ + long int newlength; + ep = environ; + longest_env_variable = 4096; + while ((*ep)) { + newlength = (long int)strlen(*ep); + if (newlength > longest_env_variable) { + longest_env_variable = newlength; + } + *ep++; + } + ep = environ; +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +void my_readenv(char *variable) { + size_t length_in; + size_t length_out; + size_t length_copy; + if (*ep == NULL) { + strncpy(variable, "", 1); + /* + fprintf(stdout,"%s [%s]\n","REWIND TABLE",variable); + */ + my_initenv(); /* reset pointer to start of table */ + } else { + length_in = strlen(variable); + length_out = strlen(*ep); + length_copy = MIN(length_in, length_out); + + memcpy(variable, *ep, length_copy + 1); + *ep++; + } +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +int my_getgrgid(long long int id, char *groupname) { + struct group *grp; + + errno = 0; + + if ((grp = getgrgid((gid_t)id)) != NULL) { + strcpy(groupname, grp->gr_name); + } else { + strncpy(groupname, "", 1); + perror("getgrgid"); + } + return errno; +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +int my_getpwuid(long long int id, char *username) { + struct passwd *pwd; + + errno = 0; + + if ((pwd = getpwuid((uid_t)id)) != NULL) { + strcpy(username, pwd->pw_name); + } else { + strncpy(username, "", 1); + perror("getpwuid"); + } + return errno; +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + return last error number for functions that explicitly state they set it + use a function as this might be a macro +*/ +int my_errno() { return (errno); } +/*--------------------------------------------------------------------------------------------------------------------------------*/ +void system_unbuffer() { + /* + This routine turns off buffering of standard input so that Kevin + Serafini can control both input and output so that he can control + USH from the xush(1) X11 windows GUI program using forked pipes + */ + char ident[] = "@(#)system_unbuffer(3c): FORTRAN-callable call to turn off " + "buffering of stdin"; + + if (setvbuf(stdin, NULL, _IOLBF, 0) != 0) { + perror("setvbuf"); + exit(5); + } + if (setvbuf(stdout, NULL, _IOLBF, 0) != 0) { + perror("setvbuf"); + exit(5); + } + fprintf(stderr, "IN THE BUFF!\n"); +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + my_uname -- return system information from uname(3c) to Fortran subroutine +*/ +void my_uname(char *which, char *string, int *stringlen) { + struct utsname name; + int j; + if (uname(&name) == -1) { + fprintf(stderr, "*my_uname* cannot get system name\n"); + strncpy(string, "UNKNOWN", *stringlen); + } else { + switch (*which) { + case 's': + strncpy(string, name.sysname, *stringlen); + break; + case 'n': + strncpy(string, name.nodename, *stringlen); + break; + case 'r': + strncpy(string, name.release, *stringlen); + break; + case 'v': + strncpy(string, name.version, *stringlen); + break; + case 'm': + strncpy(string, name.machine, *stringlen); + break; + case 'T': + fprintf(stderr, "*my_uname* sysname: %s\n", name.sysname); + fprintf(stderr, "*my_uname* nodename: %s\n", name.nodename); + fprintf(stderr, "*my_uname* release: %s\n", name.release); + fprintf(stderr, "*my_uname* version: %s\n", name.version); + fprintf(stderr, "*my_uname* machine: %s\n", name.machine); + strncpy(string, "", *stringlen); + break; + default: + fprintf(stderr, "*my_uname* error: unknown switch %c \n", *which); + fprintf(stderr, "*my_uname* my_uname:%s:%c:%d\n", string, *which, + *stringlen); + strncpy(string, "UNKNOWN", *stringlen); + } + } + /* + remove null string terminator and fill string with blanks for Fortran + */ + for (j = strlen(string); j < *stringlen; j++) { + string[j] = ' '; + } +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* + Use unix routine times(3c) to measure user execution time between + calls in seconds. +*/ + +void my_cpu_time(float *c, float *u, float *s) { +#include +#include + clock_t t; + struct tms mytime; + + t = times(&mytime); /* call "times" */ + *u = ((float)mytime.tms_utime) / + ((float)HZ); /* user time in 1/HZ seconds is in tms_utime */ + *s = ((float)mytime.tms_stime) / ((float)HZ); /* HZ is in sys/param.h */ + *c = *u + *s; + return; +} +/*--------------------------------------------------------------------------------------------------------------------------------*/ +/* ===============================================================================================================================*/ +/* + * Decides whether a given file name is a directory. + * return 1 if file exists and is a directory + */ +int my_isdir(const char *path) { + struct stat sb; + return stat(path, &sb) == 0 && S_ISDIR(sb.st_mode); +} +/* ===============================================================================================================================*/ +/* Check for regular file. */ +int my_isreg(const char *path) { + struct stat sb; + return stat(path, &sb) == 0 && S_ISREG(sb.st_mode); +} +/* ===============================================================================================================================*/ +/* determine if filename is a block device */ +int my_isblk(const char *path) { + struct stat sb; + return stat(path, &sb) == 0 && S_ISBLK(sb.st_mode); +} +/* ===============================================================================================================================*/ +/* determine if filename is a character device */ +int my_ischr(const char *path) { + struct stat sb; + return stat(path, &sb) == 0 && S_ISCHR(sb.st_mode); +} +/* ===============================================================================================================================*/ +/* determine if filename is a fifo - named pipe */ +int my_isfifo(const char *path) { + struct stat sb; + return stat(path, &sb) == 0 && S_ISFIFO(sb.st_mode); +} +/* ===============================================================================================================================*/ +/* determine if filename is a socket */ +int my_issock(const char *path) { + struct stat sb; + return stat(path, &sb) == 0 && S_ISSOCK(sb.st_mode); +} +/* ===============================================================================================================================*/ +/* + * Decides whether a given file name is a symbolic link. + * return 1 if file exists and is a symlink, 0 otherwise. + */ +int my_islnk(const char *fname) { + struct stat statbuf; + + if (lstat(fname, &statbuf)) { + return 0; + } else { + return S_ISLNK(statbuf.st_mode); + } +} +/* ===============================================================================================================================*/ +/* + * Checks whether a given file exists. + * return 1 if file exists, 0 otherwise. + */ +int my_file_exists(const char *fname) { + struct stat statbuf; + return !stat(fname, &statbuf); +} +/* ===============================================================================================================================*/ +#include +#include +#include +#include +#include + +void my_stat(char *file, long int *values, int *ierr, int debug) { + struct stat *buf = + malloc(sizeof(struct stat)); /* allocates memory for stat structure. */ + struct passwd *pwd; + struct group *grp; + struct tm *tm; + char datestring[256]; + static char local_buff[17] = {0}; + int i; + + errno = 0; /* always set errno to zero first. */ + if (stat(file, buf) != 0) { + perror(file); /* if stat does not work, print a diagnostic. */ + *ierr = 1; + return; + } + + *ierr = 0; + values[0] = buf->st_dev; /* st_dev device file currently resides on. */ + values[1] = buf->st_ino; /* st_ino The inode for the file */ + values[2] = buf->st_mode; /* st_mode The current permissions on the file. */ + values[3] = buf->st_nlink; /* st_nlink number of links to this file. */ + values[4] = buf->st_uid; /* st_uid The User ID for the file. */ + values[5] = buf->st_gid; /* st_gid The Group ID for the file. */ + values[6] = buf->st_rdev; /* st_rdev ID of device containing directory entry + for file (0 if not available) */ + values[7] = buf->st_size; /* st_size file size in bytes */ + values[8] = + buf->st_atime + 0.5; /* st_atime most recent time file was accessed. */ + values[9] = buf->st_mtime + + 0.5; /* st_mtime most recent time file contents modified. */ + values[10] = buf->st_ctime + + 0.5; /* st_ctime most recent time file permissions changed. */ + values[11] = buf->st_blksize; /* Preferred I/O block size (-1 if not + available) */ + values[12] = buf->st_blocks; /* Number of blocks allocated (-1 if + not available) */ + + if (debug == 0) { + printf("Information for %s ", file); + printf("(The file %s a symbolic link)\n", + (S_ISLNK(buf->st_mode)) ? "is" : "is not"); + printf("---------------------------\n"); + printf("File Size ........................ %jd bytes\n", + (intmax_t)buf->st_size); /* st_size file size in bytes */ + printf("Number of Links .................. %ld\n", + buf->st_nlink); /* st_nlink number of links to this file. */ + printf("File inode ....................... %ld\n", + buf->st_ino); /* st_ino The inode for the file */ + + i = 0; + /* + This varies, but at least one ls(1) command uses this convention: + + The file type is one of the following characters: + - regular file + b block special file + c character special file + C high performance ( contiguous data ) file + d directory + D door (Solaris 2.5 and up) + l symbolic link + M off-line ( migrated ) file (Cray DMF) + n network special file (HP-UX) + p FIFO (named pipe) + P port (Solaris 10 and up) + s socket + ? some other file type + The file mode bits listed are similar to symbolic mode specifications + (*note Symbolic Modes::). But ls(1) combines multiple bits into the third + character of each set of permissions as follows: s If the set-user-ID + or set-group-ID bit and the corresponding executable bit are both set. S + If the set-user-ID or set-group-ID bit is set but the corresponding + executable bit is not set. t If the restricted deletion flag or sticky + bit, and the other-executable bit, are both set. The restricted deletion + flag is another name for the sticky bit. *Note Mode Structure::. + T If the restricted deletion flag or sticky bit is set but the + other-executable bit is not set. x If the executable bit is set and + none of the above apply. + - Otherwise. + Following the file mode bits is a single character that specifies + whether an alternate access method such as an access control list + applies to the file. When the character following the file mode + bits is a space, there is no alternate access method. When it is a + printing character, then there is such a method. + + GNU ls(1) uses a . character to indicate a file with a security context, + but no other alternate access method. + + A file with any other combination of alternate access methods is marked + with a + character. + + */ + if (S_ISDIR(buf->st_mode)) { /* st_mode The current permissions on the + file. */ + local_buff[i] = 'd'; + } else if (S_ISCHR(buf->st_mode)) { + local_buff[i] = 'c'; + } else if (S_ISLNK(buf->st_mode)) { + local_buff[i] = 'l'; + } else if (S_ISBLK(buf->st_mode)) { + local_buff[i] = 'b'; + } else if (S_ISFIFO(buf->st_mode)) { + local_buff[i] = 'p'; + } else if (S_ISSOCK(buf->st_mode)) { + local_buff[i] = 's'; + } else if (S_ISREG(buf->st_mode)) { + local_buff[i] = '-'; + } else { + local_buff[i] = '?'; + } + i++; + local_buff[i] = (buf->st_mode & S_IRUSR) ? 'r' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IWUSR) ? 'w' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IXUSR) ? 'x' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IRGRP) ? 'r' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IWGRP) ? 'w' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IXGRP) ? 'x' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IROTH) ? 'r' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IWOTH) ? 'w' : '-'; + i++; + local_buff[i] = (buf->st_mode & S_IXOTH) ? 'x' : '-'; + i++; + local_buff[i] = '\0'; + printf("File Permissions ................. %s\n", local_buff); + printf("Owner ID ........................ %-8d\n", buf->st_uid); + + /* Print out owner name if found using getpwuid(). */ + if ((pwd = getpwuid(buf->st_uid)) != + NULL) { /* st_uid The User ID for the file. */ + printf("Owner ........................... %-8s\n", pwd->pw_name); + } + printf("Owner ID ........................ %-8d\n", buf->st_uid); + /* Print out group name if found using getgrgid(). */ + if ((grp = getgrgid(buf->st_gid)) != + NULL) { /* st_gid The Group ID for the file. */ + printf("Group name ...................... %-8s\n", grp->gr_name); + } + printf("Group ID ........................ %-8d\n", buf->st_gid); + + tm = localtime(&buf->st_mtime); /* st_mtime most recent time file contents + modified. */ + strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), + tm); /* Get localized date string. */ + printf("file contents last modified ..... %s\n", datestring); + + tm = localtime( + &buf->st_atime); /* st_atime most recent time file was accessed. */ + strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), + tm); /* Get localized date string. */ + printf("file contents last accessed ..... %s\n", datestring); + + tm = localtime(&buf->st_ctime); /* st_ctime most recent time file + permissions changed. */ + strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), + tm); /* Get localized date string. */ + printf("file permissions last changed ... %s\n", datestring); + + printf("device .......................... %ld\n", + buf->st_dev); /* st_dev device file currently resides on. */ + } +} +/* ===============================================================================================================================*/ +/* +int main () { + printf ("input.txt is a regular file? %s\n", + check_reg ("input.txt") ? "yes" : "no"); + printf ("docs is a directory? %s\n", check_dir ("docs") ? "yes" : "no"); + printf ("/input.txt is a regular file? %s\n", + check_reg ("/input.txt") ? "yes" : "no"); + printf ("/docs is a directory? %s\n", check_dir ("/docs") ? "yes" : "no"); + return 0; +} +*/ +/* ===============================================================================================================================*/ +const char *my_get_perm(long int imode) { + static char perms_buff[15]; + char ftype = '?'; + mode_t mode; + + mode = (mode_t)imode; + if (S_ISREG(mode)) + ftype = '-'; + if (S_ISLNK(mode)) + ftype = 'l'; + if (S_ISDIR(mode)) + ftype = 'd'; + if (S_ISBLK(mode)) + ftype = 'b'; + if (S_ISCHR(mode)) + ftype = 'c'; + if (S_ISFIFO(mode)) + ftype = 'p'; +#ifdef S_ISDOOR + if (S_ISDOOR(mode)) + ftype = 'D'; /* Solaris 2.6, etc. */ +#endif + + sprintf(perms_buff, "%c%c%c%c%c%c%c%c%c%c %c%c%c", ftype, + mode & S_IRUSR ? 'r' : '-', mode & S_IWUSR ? 'w' : '-', + mode & S_IXUSR ? 'x' : '-', + + mode & S_IRGRP ? 'r' : '-', mode & S_IWGRP ? 'w' : '-', + mode & S_IXGRP ? 'x' : '-', + + mode & S_IROTH ? 'r' : '-', mode & S_IWOTH ? 'w' : '-', + mode & S_IXOTH ? 'x' : '-', + + mode & S_ISUID ? 'U' : '-', mode & S_ISGID ? 'G' : '-', + mode & S_ISVTX ? 'S' : '-'); + + return perms_buff; +} +/* ===============================================================================================================================*/ +/* + To get stream I/O out of stdin and stdout, make a getc and putc callable from + Fortran +*/ +char getkeyC(void) { + /* @(#) Driver for reading a character from stdin */ + char c; + read(0, &c, 1); + return (c); +} + +int putkeyC(char c) { + /* @(#) Driver for writing a character to stdout */ + write(1, &c, 1); + return (c); +} +/* ===============================================================================================================================*/ diff --git a/src/modules/Test/CMakeLists.txt b/src/modules/Test/CMakeLists.txt new file mode 100644 index 000000000..b54f0c97e --- /dev/null +++ b/src/modules/Test/CMakeLists.txt @@ -0,0 +1,26 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/Test_Base.F90 ${src_path}/Test_Planning.F90 + ${src_path}/Test_Is.F90 ${src_path}/Test_More.F90 + ${src_path}/Test_Method.F90) + diff --git a/src/modules/Test/src/README.txt b/src/modules/Test/src/README.txt new file mode 100644 index 000000000..e8c75ec15 --- /dev/null +++ b/src/modules/Test/src/README.txt @@ -0,0 +1,486 @@ +A Fortran implementation of http://testanything.org/ (TAP) +========================================================== + +Testing does not have to be complicated. + +TAP stands for Test Anything Protocol, and is a textual +protocol supported by many testing tools, and build servers +such as Jenkins. + +This is a TAP producer module, test, inspired by Perl's +Test::More module, and comes with a small command line TAP +consumer program that works as a simple test harness for +bare needs. + +Perl's prove(1) can also be used for now as long as one remember +to let the test programs have the suffix ".t" + +The test module has some additions for comparing floating point +numbers: absolute and relative comparison with the subroutines +isabs and isrel, in addition to isnear, which uses division +instead of subtraction as isabs. + +Other than that compile time overloading is used for the +subroutines is and isnt. There is no support for subtests. They +would be nice to have, but you can just write more test programs +or use plain old subroutines to divide the work, so most likely +they will not be implemented. + +There are also 2 public streams for test output and diagnostic +notes, which by default are assigned to OUTPUT_UNIT and +ERROR_UNIT. + +See http://testanything.org/tap-specification.html to understand +the output that the test module is supposed to produce. The +subroutines are transparent and easy to understand once you +understand the simple test protocol (TAP). + +The philosophy behind this implementation is to have something +simple to quickly get on with testing while at the same +time it is easy to modify and extend for one's own purpose: +All too often it is too difficult to remove something from +a library. It's better to strike a balance, and make it easy +to add to a library while still having an implementation that +takes care of the most common things. + +Fortran-testanything comes with the OpenBSD/ISC license. + +Tectonics +--------- + +See the Makefile. The Fortran 2008 source file test.f08 includes +the is_i.inc and is_r.inc files, so they should stay together, +or the *.inc files should be in a directory in the include search +path (-I option). Compile tests with test.f08, and that is it. + +See test_examples.f08 for an example of use. + +Synopsis +-------- + +use test + +call plan(23) +! or +call skip_all(reason) +! or see done_testing + +! Various ways to say 'ok' +call ok(got .eq. expected, test_name) ! test names are optional + +call is(got, expected, test_name) +call isnt(got, expected, test_name) + +call isabs(got, expected, epsilon, test_name) +call isrel(got, expected, epsilon, test_name) +call isnear(got, expected, test_name) + +! Rather than WRITE (ERROR_UNIT,'(A)') "# here's what went wrong" +call diag("here's what went wrong") + +if (.not. have_some_feature()) then + call skip(why, how_many) ! how_many is optional and default 1 +else + call ok(foo(), test_name) + call is(foo(42), 23, test_name) + ! ... +end if + +call todo(why, how_many) +call ok(foo(), test_name) +call is(foo(42), 23, test_name) +! ... + +call pass(test_name) +call fail(test_name) + +! Stop test program after writing why rather than ERROR STOP +call bail_out(why) + +Description +----------- + +Subroutines + + * plan/skip_all + * done_testing + * ok + * is/isnt + * isabs/isntabs + * isrel/isntrel + * isnear/isntnear + * pass/fail + * skip/todo + * note/diag + * bail_out + +The examples use "=>" in a comment to indicate output. + +See http://search.cpan.org/~mschwern/Test-Simple/lib/Test/More.pm for +a more detailed explanation and raison d'être of the test routines. + +To plan or not to plan +---------------------- + +The number of tests to run is part of a test program, so that the test +harness (TAP consumer) can report if any test wasn't run at all. + +You indicate this either at the beginning or at the end of a test +program. The number of tests can be calculated in both instances. + +Calling skip_all stops the test immediately after writing the reason why +on test output. + +Examples: + +call plan(23) +! => 1..23 + +call plan(size(keys) * 3) ! Given size(keys) = 4 +! => 1..12 + +call skip_all("Only relevant on OpenBSD") +! => 1..0 # Skipped: Only relevant on OpenBSD + +call done_testing ! Simply does nothing if you planned ahead + +call done_testing(11) +! => 1..11 + +call done_testing(cases * 5) ! Given cases = 6 +! => 1..30 + +Test names +---------- + +Test names are optional, and by default nothing more than test result +"ok" or "not ok" including a test number is output. Including them gives +you an idea of what failed. + +What would you rather see? + +ok 34 - basic standard variance +not ok 35 - root mean square +ok 36 - volt == ampere * ohm + +or + +ok 34 +not ok 35 +ok 36 + +It also makes it easier to find tests in your program, e.g. it's easier +to search for "root mean square" than "35". On the other hand the test +number uniquely identifies a test. + +Examples: + +call ok(3 == 3, 'Integer equivalence') +! => ok 1 - Integer equivalence + +call ok(leq("Dines", "Dennis")) +! => not ok 2 + +call is(5, 2+2, '2 + 2 == 5') +! => not ok 3 - 2 + 2 == 5 +! => # Failed test '2 + 2 == 5' +! => # got: 4 +! => # expected: 5 + +A failed test outputs some more diagnostic output about why. Diagnostic +output lines begins with a number sign (octothorpe), "#". + +How tests do comparisons +------------------------ + +You can stick to using routine ok to do tests, but some convenient +routines are supplied for easier comparison of different types. In +particular the "is" routine is overloaded for different types. + +There are also a few special is routines for comparison of +floating point numbers whose representation by definition +is inexact: isabs, isrel, and isnear. The routine isabs is +good for comparison of small numbers while isrel is good +for comparison of large numbers. They both take an optional +epsilon which by default is the intrinsic epsilon(expected) - 1. +The routine isnear is similar to isabs, but uses division intead +of subtraction. Originally the routine was supposed to use the +intrinsic nearest(x, s), which returns the nearest different +machine number in the direction given by the sign of the real s, +but then I discovered 2 ways of doing relative comparisons of +floating point numbers. One can still use nearest to compare +the floating point numbers A and B: + + call ok(nearest(A, -1.0) <= B .and. B <= nearest(A, +1.0)) + +Using nearest in such a way considers a near miss to be a hit, +but it seems more fragile than analyzing the calculation and +taking precision and accuracy into account. + +For other values, just use the routine is with the result as +first argument and the expected result as second argument. + +Examples: + +call is(3, 3) +call is("Dines", "Dines") +call is(.true., .false.) +call is(point(2, 3), point(2, 3)) ! Given operator(==) is overloaded. + +call isabs(sqrt(2.0), 1.4142, 0.5e-3) ! 3 decimal digit precision +call isrel(10023.0, 10025.0, 0.5e-4) ! 4 largest digits precision + +In summary: + +is(a,b): is a equal to b? +isabs(a, b): abs(a) - abs(b) < e, where e = eps +isrel(a, b): abs(a) - abs(b) < e, where e = (abs(a) + abs(b)) * eps +isnear(a,b): abs(abs(a) / abs(b) - 1) <= e, where e = eps + +Complex numbers cannot be compared directly with relative +operators or equality operators. In that case use either the +intrinsic functions real and imag, or the pseudo-components +(since Fortran 2003) re and im to compare the real and imaginary +parts of a complex number. + +Examples: + +call is(real(a), real(b)) +call is(imag(a), imag(b)) +call is(a%re, b%re) +call is(a%im, b%im) + +Testing arrays +-------------- + +Deep comparison of elements in arrays or derived types doesn't +make a lot of sense in Fortran, in part because it can be +overloaded on derived types, but also because very often better +comparison techniques can be used instead. It depends on the +problem. Hence they are not as useful, and has not implemented. + +Complex tests +------------- + +This test module does not implement subtests. They could be useful, but +on the other hand they would require so much more to set up that it would +defeat the purpose. Separating stuff into test programs will handle most +cases with easy anyway, and the rest with minimal pain. It is possible +to use program generation if need be or just plain old subroutines. + +If having complicated tests, one can use the routines pass and fail, +which are synonymous with ok(.true.) and ok(.false.) to tell whether a +test is to pass or fail. + +Examples: + +call pass +! => ok 40 +call pass("support for linear regression") +! => ok 41 - support for linear regression +call fail +! => not ok 42 +call fail("hairy numbers does not work") +! => not ok 43 - hairy numbers does not work + +In that case it is also useful to write one's own notes and +diagnostics. Both the routines note and diag outputs a string +as a single line preceded with a number sign (octothorpe), +"#", but note does it on the test output, which will not be +seen in a test harness, while diag does it on the diagnostic +output which is always visible. By default test output unit is +OUTPUT_UNIT, and diagnostic output is ERROR_UNIT. + +call note("Tempfile is " // tempfile) +! => # Tempfile is XYZ123456 +call diag("There is no XYZ, check that /etc/XYZ.ini is set up right") +! => # There is no XYZ, check that /etc/XYZ.ini is set up right + +Currently there is no overloaded subroutine that will take several +strings for several lines, since that has not been very useful, but +maybe in the future. + +Conditional tests +----------------- + +One can skip a test if there is insufficient conditions to run it, or +it doesn't make sense, or it's impossible to do so. In that case one +calls skip _instead of_ the test routines. Skipped tests are always +reported as being ok. Please note that calling skip unconditionally, +i.e. outside an if block or similar is surely a mistake. If the test +program is planned, this mistake will be caught by the test harness, +or simply by the test program failing by error. + +One does not skip tests with failures or tests with only stubbed-out +code to be tested. For that one uses todo tests. + +One can indicate a test as unfinished and yet to be done by calling the +routine todo. The test must still be run, and it is expected to fail. Any +todo test that passes is supposed to be reported by any test harness as +unexpectedly passing, so one can remove the todo status, once the work +is done. + +Both skip and todo routines take an optional test_name and an optional +how_many, which is default 1. + +Examples: + +call skip +! => ok 50 # Skipped +call skip("No test data on the network") +! => ok 51 # SKIP: No test data on the network +call skip("No APP_DATA directory", 3) +! => ok 52 # SKIP: No APP_DATA directory +! => ok 53 # SKIP: No APP_DATA directory +! => ok 54 # SKIP: No APP_DATA directory +call skip(2) +! => ok 55 # SKIP +! => ok 56 # SKIP + +call todo +call ok(.false.) +! => not ok 57 - # TODO +call todo("Lookup details in the cryptic article") +call ok(.false.) +! => not ok 58 - # TODO: Lookup details in the cryptic article +call todo +call ok(.false., "Monte carlo test set up") +! => not ok 59 - Monte carlo test set up # TODO +call todo("Resolve learning problems") +call is(supervise(data), 97.0, "Bayes with 97% class") +! => not ok 60 - Bayes with 97% class # TODO: Resolve learning problems + +call todo("Halting problem unsolved", 3) +call ok(.false., "Infinite loop") +call ok(.false., "Infinite recursion") +call ok(.false., "Infinite Turing tape") +! => not ok 61 - Infinite loop # TODO: Halting problem unsolved +! => not ok 62 - Infinite recursion # TODO: Halting problem unsolved +! => not ok 63 - Infinite Turing tape # TODO: Halting problem unsolved +call todo(2) +call ok(.false., "Stubbed-out") +call ok(.false., "Stubbed-out") +! => not ok 64 - # TODO +! => not ok 65 - # TODO + +Skipping a todo test has not been implemented yet. Maybe it'll be useful, +maybe not. Currently skipping a test means also skipping a todo test. + +Diagnostic output +----------------- + +The note routine writes a string on the TEST_UNIT (default OUTPUT_UNIT), +also known as the TAP stream, together with the other test lines without +interfering with the test harness. The output is not visible when run +from a test harness. It is useful for notes, headlines, error correction, +and other things that are not exactly problems. + +The diag routine writes a string on the DIAG_UNIT (default ERROR_UNIT), +and is always visible, even when run from a test harness. Output about +gotten and expected outputs are written this way. It is useful for +diagnostic output in complex tests (see "Complex tests" above) + +The TEST_UNIT and DIAG_UNIT can be set to other unit for the purpose +of redirecting the TAP or diagnostic stream elsewhere for particular +testing purposes: They are public from the test module. + +Stopping a test +--------------- + +The bail_out routine does an error stop after writing an optional message. + +Examples: + +call bail_out +! => Bail out! + +call bail_out("PostgreSQL is not running") +! => Bail out! PostgreSQL is not running + +Caveats +------- + +The test module is not thread safe. You can run test programs in parallel +or use test routines with coarrays, but the test module itself "is thread +ignorant" and is inherently sequential. You can of course divide your +tests into subroutines, and are encouraged to do so. + +Exit codes +---------- + +The status/exit code has some historical complications both +for test programs as well as for Fortran in general, so it's +not supported at all. A test program exits with status code 0 +(zero) on those platforms that have such a thing, but in reality +it depends on the fortran processor (compiler). + +History +------- + +The test module was inspired by Perl's simple Test, Test::More and +Test Anything Protocol (TAP) that Perl's Test::Harness handles. In Perl +the tool prove(1) handles TAP. + +The great idea is to separate tests from test result consumers via a +simple text based protocol. + +It turns out that the Test Anything Protocol is easy, simple, and +transparent to implement in Fortran itself. There is no need for +heavy tooling even in big, elaborate test suites. Perl itself is +proof of that. It is customary for a perl module uploaded to the +Comprehensive Perl Archive Network (CPAN) to be accompanied with +tests, and currently there are beyond 25000 modules on CPAN. + +There is a curious lack of Fortran test libraries written +in Fortran itself. They usually requires a preprocessor or a +scripting language to do collection, preprocessing, transcription +and processing of the tests. Examples of popular ones are Fruit, +ftunit, pFUnit, flibs, FortUnit, FUnit, and objecxxFTK: + + * Fruit (fortranxunit): Fortran Unit Test Framework, BSD-like + license, requires Ruby, active in 2015, + * ftunit (NASA): NASA open source license 1.3, requires Ruby, + active in 2015, + * pFUnit (NASA): NASA open source license 1.3, requires Python, + * flibs (Arjen Markus): BSD-like license, requires Tcl, + stopped in 2008, + * FortUnit: GPLv2 license, requires Perl, stopped in 2004 and + seems gone (no source), + * FUnit: requires Ruby, stopped in 2009, + * objecxxFTK: requires Python; perpetual, royalty-free license + for source allowing client modifications - modest license fee. + +Fortran-testanything is pure Modern Fortran, and does not require +any scripting language. This is due to the separation between +test producers and test consumers. While one can use Perl's +prove(1) tool as a test harness, one can also use any other test +harness written in any other programming language implementation, +e.g. the plugins in the Jenkins build server to handle the TAP +streams and make pretty reports. Fortran-testanything comes +with its own little test harness if one does not have or does +not want to install Perl. + +Frameworks such as pFUnit comes with much more support +for things such as MPI, OpenMP, and MPICH; array tools +for checking size, rank, and shape; preprocessing; and +OO-support. Fortran-testanything on the other hand tries to be +small and easily modifiable. Adding small functions and test +subroutines to supplement specific use cases is easy. + +Testing does not have to be complicated. + +License +------- + +Fortran-testanything comes with the OpenBSD/ISC license, +i.e. the ISC license anno 2003, the one without the "and/or" +conjunction. Lawyers have told me that it does not make any legal +difference in its context, which is already quite clear, and so +a simpler language is preferred, hence just the "and" junction +as in the original license. By the way, the original ISC license +is extremely close to the words of the original BSD license, +but without any words made unnecessary by the Berne Convention. + +It is one of the least restrictive licenses under the Berne +Convention. + diff --git a/src/modules/Test/src/Test_Base.F90 b/src/modules/Test/src/Test_Base.F90 new file mode 100644 index 000000000..6cfabed09 --- /dev/null +++ b/src/modules/Test/src/Test_Base.F90 @@ -0,0 +1,170 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE Test_Base +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT, ERROR_UNIT +IMPLICIT NONE + +! Kept as variables instead of aliases, +! so that test output or diagonostic output can be redirected +INTEGER :: test_unit = OUTPUT_UNIT, diago_unit = ERROR_UNIT + +INTEGER :: tests = 0, todos = 0 +CHARACTER(120) :: todomsg = "" + +INTERFACE todo + MODULE PROCEDURE todo_i, todo_s, todo_s_i, todo +END INTERFACE + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE diago(msg) + CHARACTER(*), INTENT(in) :: msg + WRITE (diago_unit, '("# ",A)') TRIM(msg) ! only trailing spaces +END SUBROUTINE diago + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE note(msg) + CHARACTER(*), INTENT(in) :: msg + WRITE (test_unit, '("# ",A)') TRIM(msg) +END SUBROUTINE note + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE testline(ok, msg, idmsg, gotmsg, expectedmsg) + LOGICAL, INTENT(in) :: ok + CHARACTER(*), INTENT(in) :: msg, idmsg, gotmsg, expectedmsg + + tests = tests + 1 + IF (.NOT. ok) CALL out("not ") + WRITE (test_unit, '("ok ",I0)', advance="NO") tests + + IF (msg /= "" .OR. todos > 0) CALL out(" - ") + + IF (msg /= "") CALL out(TRIM(msg)) + + IF (todos > 0) THEN + todos = todos - 1 + IF (msg /= "") CALL out(" ") + CALL out("# TODO") + IF (todomsg .NE. "") THEN + CALL out(": ") + CALL out(TRIM(todomsg)) + END IF + END IF + IF (todos == 0) todomsg = "" + + WRITE (test_unit, *) "" + + IF (.NOT. ok) THEN + ! 3 spaces prepended = 4 spaces indentation after # on diago + IF (idmsg /= "") CALL diago(" "//idmsg) + IF (gotmsg /= "") CALL diago(" "//gotmsg) + IF (expectedmsg /= "") CALL diago(" "//expectedmsg) + END IF +CONTAINS + SUBROUTINE out(str) + CHARACTER(*), INTENT(in) :: str + WRITE (test_unit, '(A)', advance="NO") str + END +END SUBROUTINE testline + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE ok(condition, msg) + LOGICAL, INTENT(in) :: condition + CHARACTER(*), INTENT(in), OPTIONAL :: msg + IF (PRESENT(msg)) THEN + CALL testline(condition, msg, "", "", "") + ELSE + CALL testline(condition, "", "", "", "") + END IF +END SUBROUTINE ok + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE PASS(msg) + CHARACTER(*), INTENT(in), OPTIONAL :: msg + CALL ok(.TRUE., msg) +END SUBROUTINE PASS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE fail(msg) + CHARACTER(*), INTENT(in), OPTIONAL :: msg + CALL ok(.FALSE., msg) +END SUBROUTINE fail + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE todo_s_i(msg, howmany) + CHARACTER(*), INTENT(in) :: msg + INTEGER, INTENT(in) :: howmany + todomsg = msg + todos = howmany +END SUBROUTINE todo_s_i + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE todo + CALL todo_s_i("", 1) +END SUBROUTINE todo + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE todo_s(msg) + CHARACTER(*), INTENT(in) :: msg + CALL todo_s_i(msg, 1) +END SUBROUTINE todo_s + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE todo_i(howmany) + INTEGER, INTENT(in) :: howmany + CALL todo_s_i("", howmany) +END SUBROUTINE todo_i + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE Test_Base diff --git a/src/modules/Test/src/Test_Is.F90 b/src/modules/Test/src/Test_Is.F90 new file mode 100644 index 000000000..c9a194409 --- /dev/null +++ b/src/modules/Test/src/Test_Is.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 +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE is_i8_mod +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT8 +USE, NON_INTRINSIC :: test_base, ONLY: testline, tests +CONTAINS +INCLUDE "is_i.inc" +END MODULE is_i8_mod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_i16_mod +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT16 +USE, NON_INTRINSIC :: test_base, ONLY: testline, tests +CONTAINS +INCLUDE "is_i.inc" +END MODULE is_i16_mod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_i32_mod +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT32 +USE, NON_INTRINSIC :: test_base, ONLY: testline, tests +CONTAINS +INCLUDE "is_i.inc" +END MODULE is_i32_mod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_i64_mod +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => INT64 +USE, NON_INTRINSIC :: test_base, ONLY: testline, tests +CONTAINS +INCLUDE "is_i.inc" +END MODULE is_i64_mod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_i +USE is_i8_mod, ONLY: is_i8 => is +USE is_i16_mod, ONLY: is_i16 => is +USE is_i32_mod, ONLY: is_i32 => is +USE is_i64_mod, ONLY: is_i64 => is +INTERFACE is + MODULE PROCEDURE is_i8, is_i16, is_i32, is_i64 +END INTERFACE +END MODULE is_i + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_r32_mod +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => REAL32 +USE, NON_INTRINSIC :: test_base, ONLY: testline, tests +CONTAINS +INCLUDE "is_r.inc" +END MODULE is_r32_mod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_r64_mod +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => REAL64 +USE, NON_INTRINSIC :: test_base, ONLY: testline, tests +CONTAINS +INCLUDE "is_r.inc" +END MODULE is_r64_mod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_r128_mod +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: wp => REAL128 +USE, NON_INTRINSIC :: test_base, ONLY: testline, tests +CONTAINS +INCLUDE "is_r.inc" +END MODULE is_r128_mod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE is_r +USE is_r32_mod, ONLY: isrel_r32 => isrel, isabs_r32 => isabs, & + & isnear_r32 => isnear +USE is_r64_mod, ONLY: isrel_r64 => isrel, isabs_r64 => isabs, & + & isnear_r64 => isnear +USE is_r128_mod, ONLY: isrel_r128 => isrel, isabs_r128 => isabs, & + & isnear_r128 => isnear +INTERFACE isrel + MODULE PROCEDURE isrel_r32, isrel_r64, isrel_r128 +END INTERFACE + +INTERFACE isabs + MODULE PROCEDURE isabs_r32, isabs_r64, isabs_r128 +END INTERFACE + +INTERFACE isnear + MODULE PROCEDURE isnear_r32, isnear_r64, isnear_r128 +END INTERFACE + +END MODULE is_r diff --git a/src/modules/Test/src/Test_Method.F90 b/src/modules/Test/src/Test_Method.F90 new file mode 100644 index 000000000..3e96c581a --- /dev/null +++ b/src/modules/Test/src/Test_Method.F90 @@ -0,0 +1,27 @@ +! Copyright 2015 Dennis Decker Jensen +! See and +! Tectonics: gfortran -g -Wall -Wextra -std=f2008ts -c test.f08 +! +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 Test_Method +USE Test_Base, ONLY: test_unit, diago_unit, & + & ok, diago, note, PASS, fail, todo +USE Test_Planning, ONLY: plan, done_testing, skip_all, bail_out +USE Test_More, ONLY: is, isabs, isrel, isnear, skip +END MODULE Test_Method diff --git a/src/modules/Test/src/Test_More.F90 b/src/modules/Test/src/Test_More.F90 new file mode 100644 index 000000000..d382baf8f --- /dev/null +++ b/src/modules/Test/src/Test_More.F90 @@ -0,0 +1,154 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE Test_More +USE test_base, ONLY: testline, tests, test_unit +USE test_planning, ONLY: bail_out ! for negative skips +USE is_i, ONLY: is, is_i8, is_i16, is_i32, is_i64 +USE is_r, ONLY: isabs, isrel, isnear, & + & isabs_r32, isrel_r32, isnear_r32, & + & isabs_r64, isrel_r64, isnear_r64, & + & isabs_r128, isrel_r128, isnear_r128 + +! Complex numbers cannot be compared, hence no is_c module + +IMPLICIT NONE + +INTERFACE skip + MODULE PROCEDURE skip_i, skip_s, skip_s_i, skip +END INTERFACE + +INTERFACE is + MODULE PROCEDURE is_s, is_l +END INTERFACE + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE skip_s_i(msg, howmany) + CHARACTER(*), INTENT(in) :: msg + INTEGER, INTENT(in) :: howmany + CHARACTER(120) skipmsg + INTEGER i + + IF (howmany <= 0) THEN + CALL bail_out("Skipped non-positive number of tests") + END IF + + IF (msg == "") THEN + skipmsg = "# SKIP" + ELSE + skipmsg = "# SKIP: "//TRIM(msg) + END IF + + DO i = 1, howmany + tests = tests + 1 + WRITE (test_unit, '("ok ",I0," ",A)') tests, TRIM(skipmsg) + END DO +END SUBROUTINE skip_s_i + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE skip + CALL skip_s_i("", 1) +END SUBROUTINE skip + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE skip_s(msg) + CHARACTER(*), INTENT(in) :: msg + CALL skip_s_i(msg, 1) +END SUBROUTINE skip_s + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE skip_i(howmany) + INTEGER, INTENT(in) :: howmany + CALL skip_s_i("", howmany) +END SUBROUTINE skip_i + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! Duplicates of is_i routines in file is_i.inc and ditto is_r +! They are not factored any further, because it is easier +! to see all the output together rather than in separate routines + +SUBROUTINE is_s(got, expected, msg) + CHARACTER(*), INTENT(in) :: got + CHARACTER(*), INTENT(in) :: expected + CHARACTER(*), INTENT(in), OPTIONAL :: msg + CHARACTER(:), ALLOCATABLE :: testmsg, idmsg + CHARACTER(120) gotmsg, expectedmsg + LOGICAL good + + IF (PRESENT(msg)) THEN + ALLOCATE (CHARACTER(LEN_TRIM(msg) + 20) :: testmsg, idmsg) + WRITE (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', TRIM(msg), '"' + testmsg = TRIM(msg) + ELSE + ALLOCATE (CHARACTER(30) :: testmsg, idmsg) + WRITE (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + END IF + WRITE (unit=gotmsg, fmt='(A,A,A)') ' got: "', got, '"' + WRITE (unit=expectedmsg, fmt='(A,A,A)') 'expected: "', expected, '"' + + good = got == expected + CALL testline(good, testmsg, idmsg, gotmsg, expectedmsg) +END SUBROUTINE is_s + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE is_l(got, expected, msg) + LOGICAL, INTENT(in) :: got, expected + CHARACTER(*), INTENT(in), OPTIONAL :: msg + CHARACTER(:), ALLOCATABLE :: testmsg, idmsg + CHARACTER(120) gotmsg, expectedmsg + LOGICAL good + + IF (PRESENT(msg)) THEN + ALLOCATE (CHARACTER(LEN_TRIM(msg) + 20) :: testmsg, idmsg) + WRITE (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', TRIM(msg), '"' + testmsg = TRIM(msg) + ELSE + ALLOCATE (CHARACTER(30) :: testmsg, idmsg) + WRITE (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + END IF + WRITE (unit=gotmsg, fmt='(A,L1)') ' got: ', got + WRITE (unit=expectedmsg, fmt='(A,L1)') 'expected: ', expected + + good = got .EQV. expected + CALL testline(good, testmsg, idmsg, gotmsg, expectedmsg) +END SUBROUTINE is_l + +END MODULE Test_More diff --git a/src/modules/Test/src/Test_Planning.F90 b/src/modules/Test/src/Test_Planning.F90 new file mode 100644 index 000000000..7b8c59c83 --- /dev/null +++ b/src/modules/Test/src/Test_Planning.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 +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE Test_Planning +USE test_base, ONLY: test_unit, tests +IMPLICIT NONE + +INTEGER, PRIVATE :: planned = 0 + +CONTAINS + +SUBROUTINE bail_out(msg) + CHARACTER(*), INTENT(in), OPTIONAL :: msg + IF (PRESENT(msg)) THEN + WRITE (test_unit, '("Bail out! ",A)') msg + ELSE + WRITE (test_unit, '("Bail out!")') + END IF + STOP +END SUBROUTINE bail_out + +SUBROUTINE plan(tests) + INTEGER, INTENT(in) :: tests + + SELECT CASE (tests) + CASE (:-1) + CALL bail_out("A plan with a negative number of tests") + CASE (0) + WRITE (test_unit, '("1..0")') + STOP ! The same as skip_all without a given reason + CASE (1:) + IF (planned > 0) & + & CALL bail_out("More than one plan in test output") + planned = tests + WRITE (test_unit, '("1..",I0)') planned + END SELECT +END SUBROUTINE plan + +SUBROUTINE done_testing(howmany) + INTEGER, INTENT(in), OPTIONAL :: howmany + + ! Put plan at the end of test output + IF (PRESENT(howmany)) THEN + CALL plan(howmany) + ELSE + IF (planned == 0) CALL plan(tests) + ! else - We already have a plan + END IF +END SUBROUTINE done_testing + +SUBROUTINE skip_all(msg) + CHARACTER(*), INTENT(in), OPTIONAL :: msg + IF (PRESENT(msg)) THEN + WRITE (test_unit, '("1..0 # Skipped: ",A)') msg + ELSE + WRITE (test_unit, '("1..0 # Skipped all")') + END IF + STOP +END SUBROUTINE skip_all + +END MODULE Test_Planning diff --git a/src/modules/Test/src/is_i.inc b/src/modules/Test/src/is_i.inc new file mode 100644 index 000000000..7f98a0908 --- /dev/null +++ b/src/modules/Test/src/is_i.inc @@ -0,0 +1,24 @@ +! Template parameter: wp (working precision) +! Template free identifiers: testline, tests +subroutine is(got, expected, msg) + integer(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,I0)') ' got: ', got + write (unit=expectedmsg, fmt='(A,I0)') 'expected: ', expected + + good = got == expected + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) +end diff --git a/src/modules/Test/src/is_r.inc b/src/modules/Test/src/is_r.inc new file mode 100644 index 000000000..98599716b --- /dev/null +++ b/src/modules/Test/src/is_r.inc @@ -0,0 +1,83 @@ +! Template parameter: wp (working precision) +! Template free identifiers: testline, tests +subroutine isabs(got, expected, eps, msg) + real(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + real(kind=wp), intent(in), optional :: eps + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + real(kind=wp) tolerance + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,G0)') ' got: ', got + write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected + + if (present(eps)) then + tolerance = eps + else + tolerance = epsilon(got) + end if + ! eps = 0.5e-10_wp + ! Absolute accuracy within the 10 least significant digits + good = abs(got - expected) < tolerance + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) +end + +subroutine isrel(got, expected, eps, msg) + real(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + real(kind=wp), intent(in), optional :: eps + real(kind=wp) tolerance + + ! eps = (abs(a) + abs(b)) * 0.5e-10_wp + ! Relative accuracy within the 10 most significant digits + tolerance = (abs(got) + abs(expected)) + if (present(eps)) then + tolerance = tolerance * eps + else + tolerance = tolerance * epsilon(got) + end if + call isabs(got, expected, tolerance, msg) +end + +subroutine isnear(got, expected, eps, msg) + real(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + real(kind=wp), intent(in), optional :: eps + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + real(kind=wp) tolerance + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,G0)') ' got: ', got + write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected + + if (present(eps)) then + tolerance = eps + else + tolerance = epsilon(got) ! minimun eps for which 1 + eps /= 1 + end if + ! Relative accuracy around 1.0_wp + ! Semantics of isnear means using <=, and not <, c.f. epsilon(got) + good = abs(got / expected - 1.0_wp) <= tolerance + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) +end + diff --git a/src/modules/TriangleInterface/CMakeLists.txt b/src/modules/TriangleInterface/CMakeLists.txt new file mode 100644 index 000000000..90f73fd70 --- /dev/null +++ b/src/modules/TriangleInterface/CMakeLists.txt @@ -0,0 +1,63 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} PRIVATE ${src_path}/TriangleInterface.F90) + +add_library(easifemTriangle STATIC + ${src_path}/triangle.c + ${src_path}/report.c +) + +target_link_libraries(${PROJECT_NAME} PUBLIC easifemTriangle) + +list(APPEND TRIANGLE_COMPILE_DEF "-DTRILIBRARY" "-DANSI_DECLARATORS" +"-DNO_TIMER") + +if(USE_Real64) + list(APPEND TRIANGLE_COMPILE_DEF "-DUSE_Real64") +endif() + +if(LINUX) + list(APPEND TRIANGLE_COMPILE_DEF "-DLINUX") + +elseif(WIN32) + list(APPEND TRIANGLE_COMPILE_DEF "-DCPU86") + +endif() + +target_compile_definitions(easifemTriangle PRIVATE ${TRIANGLE_COMPILE_DEF}) + +list(APPEND TRIANGLE_COMPILE_OPTIONS "-O3") + +target_compile_options(easifemTriangle PRIVATE ${TRIANGLE_COMPILE_OPTIONS}) + +# target properties +set_target_properties( + easifemTriangle + PROPERTIES POSITION_INDEPENDENT_CODE 1 + SOVERSION ${VERSION_MAJOR} + # OUTPUT_NAME ${PROJECT_NAME} + LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + MACOSX_RPATH ON + WINDOWS_EXPORT_ALL_SYMBOLS ON + LINKER_LANGUAGE C ) + +list(APPEND C_PROJECTS "easifemTriangle") diff --git a/src/modules/TriangleInterface/src/TriangleInterface.F90 b/src/modules/TriangleInterface/src/TriangleInterface.F90 new file mode 100644 index 000000000..27a631956 --- /dev/null +++ b/src/modules/TriangleInterface/src/TriangleInterface.F90 @@ -0,0 +1,257 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE TriangleInterface +USE ISO_C_BINDING, ONLY: C_INT, C_CHAR, C_PTR, C_NULL_PTR +USE GlobalData, ONLY: DFP, I4B, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: TriangulateIO_ +PUBLIC :: Triangulate +PUBLIC :: TriangleReport +PUBLIC :: TriangleFree +PUBLIC :: TriangleDeallocate +PUBLIC :: TriangleSetParam +PUBLIC :: TriangleGetParam +PUBLIC :: TriangleNullify +PUBLIC :: TriangleDisplay +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! TriangulateIO_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-09 +! summary: TringulateIO + +TYPE, BIND(c) :: TriangulateIO_ + TYPE(C_PTR) :: pointlist = C_NULL_PTR + TYPE(C_PTR) :: pointattributelist = C_NULL_PTR + TYPE(C_PTR) :: pointmarkerlist = C_NULL_PTR + INTEGER(C_INT) :: numberofpoints = 0 + INTEGER(C_INT) :: numberofpointattributes = 0 + + TYPE(C_PTR) :: trianglelist = C_NULL_PTR + TYPE(C_PTR) :: triangleattributelist = C_NULL_PTR + TYPE(C_PTR) :: trianglearealist = C_NULL_PTR + !! In + TYPE(C_PTR) :: neighborlist = C_NULL_PTR + !! Out + INTEGER(C_INT) :: numberoftriangles = 0 + INTEGER(C_INT) :: numberofcorners = 0 + INTEGER(C_INT) :: numberoftriangleattributes = 0 + + TYPE(C_PTR) :: segmentlist = C_NULL_PTR + !! Inout + TYPE(C_PTR) :: segmentmarkerlist = C_NULL_PTR + !! Inout + INTEGER(C_INT) :: numberofsegments = 0 + !! Inout + + TYPE(C_PTR) :: holelist = C_NULL_PTR + !! In, but pointer to array copied out + INTEGER(C_INT) :: numberofholes = 0 + !! In, but copied out + + TYPE(C_PTR) :: regionlist = C_NULL_PTR + !! In, but pointer to array copied out + INTEGER(C_INT) :: numberofregions = 0 + !! In but copied out + + TYPE(C_PTR) :: edgelist = C_NULL_PTR + !! Out only + TYPE(C_PTR) :: edgemarkerlist = C_NULL_PTR + !! Not used with Voronoi diagram, out only + TYPE(C_PTR) :: normlist = C_NULL_PTR + !! Used only with Voronoi diagram, out only + INTEGER(C_INT) :: numberofedges = 0 + !! Out only + +END TYPE TriangulateIO_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + ! void triangulate(char *, struct triangulateio *, struct triangulateio *, + ! struct triangulateio *) + SUBROUTINE Triangulate(triswitches, in, out, vorout) & + BIND(c, name='triangulate') + IMPORT :: C_CHAR, TriangulateIO_ + CHARACTER(kind=C_CHAR), INTENT(IN) :: triswitches + TYPE(TriangulateIO_), INTENT(INOUT) :: in + TYPE(TriangulateIO_), INTENT(INOUT) :: out + TYPE(TriangulateIO_), INTENT(INOUT) :: vorout + END SUBROUTINE Triangulate +END INTERFACE + +!---------------------------------------------------------------------------- +! TriangleReport +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE TriangleReport(io, markers, reporttriangles, & + reportneighbors, reportsegments, reportedges, reportnorms) & + BIND(c, name="report") + IMPORT :: TriangulateIO_, C_INT + TYPE(TriangulateIO_), INTENT(IN) :: io + INTEGER(C_INT), VALUE, INTENT(IN) :: markers + INTEGER(C_INT), VALUE, INTENT(IN) :: reporttriangles + INTEGER(C_INT), VALUE, INTENT(IN) :: reportneighbors + INTEGER(C_INT), VALUE, INTENT(IN) :: reportsegments + INTEGER(C_INT), VALUE, INTENT(IN) :: reportedges + INTEGER(C_INT), VALUE, INTENT(IN) :: reportnorms + END SUBROUTINE TriangleReport +END INTERFACE + +!---------------------------------------------------------------------------- +! TriangleReport +!---------------------------------------------------------------------------- + +INTERFACE TriangleFree + SUBROUTINE TriangleFree1(io) BIND(c, name="trianglefree") + IMPORT :: TriangulateIO_ + TYPE(TriangulateIO_), INTENT(INOUT) :: io + END SUBROUTINE TriangleFree1 +END INTERFACE TriangleFree + +!---------------------------------------------------------------------------- +! TriangleReport +!---------------------------------------------------------------------------- + +INTERFACE TriangleFree + SUBROUTINE TriangleFree2(io) BIND(c, name="trifree") + IMPORT :: C_PTR + TYPE(C_PTR), VALUE, INTENT(IN) :: io + END SUBROUTINE TriangleFree2 +END INTERFACE TriangleFree + +!---------------------------------------------------------------------------- +! TriangleReport@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE TriangleDeallocate(obj) + TYPE(TriangulateIO_), INTENT(INOUT) :: obj + END SUBROUTINE TriangleDeallocate +END INTERFACE + +!---------------------------------------------------------------------------- +! TriangleSetPointList +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE TriangleSetParam(obj, pointList, pointattributelist, & + pointmarkerlist, numberofpoints, numberofpointattributes, & + trianglelist, triangleattributelist, trianglearealist, neighborlist, & +numberoftriangles, numberofcorners, numberoftriangleattributes, segmentlist, & + segmentmarkerlist, numberofsegments, holelist, numberofholes, regionlist, & + numberofregions, edgelist, edgemarkerlist, normlist, numberofedges) + TYPE(TriangulateIO_), INTENT(INOUT) :: obj + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: pointList(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: pointattributelist(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: pointmarkerlist(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofpoints + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofpointattributes + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: trianglelist(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: triangleattributelist(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: trianglearealist(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: neighborlist(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberoftriangles + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofcorners + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberoftriangleattributes + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: segmentlist(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: segmentmarkerlist(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofsegments + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: holelist(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofholes + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: regionlist(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofregions + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: edgelist(:) + INTEGER(I4B), OPTIONAL, TARGET, INTENT(IN) :: edgemarkerlist(:) + REAL(DFP), OPTIONAL, TARGET, INTENT(IN) :: normlist(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: numberofedges + END SUBROUTINE TriangleSetParam +END INTERFACE + +!---------------------------------------------------------------------------- +! TriangleSetPointList +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE TriangleGetParam(obj, pointlist, pointattributelist, & + pointmarkerlist, numberofpoints, numberofpointattributes, & + trianglelist, triangleattributelist, trianglearealist, neighborlist, & +numberoftriangles, numberofcorners, numberoftriangleattributes, segmentlist, & + segmentmarkerlist, numberofsegments, holelist, numberofholes, regionlist, & + numberofregions, edgelist, edgemarkerlist, normlist, numberofedges) + TYPE(TriangulateIO_), INTENT(IN) :: obj + REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: pointlist(:) + REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: pointattributelist(:) + INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: pointmarkerlist(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofpoints + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofpointattributes + INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: trianglelist(:) + REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: triangleattributelist(:) + REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: trianglearealist(:) + INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: neighborlist(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberoftriangles + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofcorners + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberoftriangleattributes + INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: segmentlist(:) + INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: segmentmarkerlist(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofsegments + REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: holelist(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofholes + REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: regionlist(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofregions + INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: edgelist(:) + INTEGER(I4B), OPTIONAL, POINTER, INTENT(INOUT) :: edgemarkerlist(:) + REAL(DFP), OPTIONAL, POINTER, INTENT(INOUT) :: normlist(:) + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: numberofedges + END SUBROUTINE TriangleGetParam +END INTERFACE + +!---------------------------------------------------------------------------- +! TriangleNullify +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE TriangleNullify(obj) + TYPE(TriangulateIO_), INTENT(INOUT) :: obj + END SUBROUTINE TriangleNullify +END INTERFACE + +!---------------------------------------------------------------------------- +! TriangleDisplay +!---------------------------------------------------------------------------- + +INTERFACE Display + MODULE SUBROUTINE TriangleDisplay(obj, msg, unitno) + TYPE(TriangulateIO_), INTENT(INOUT) :: obj + CHARACTER(*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + END SUBROUTINE TriangleDisplay +END INTERFACE Display + +END MODULE TriangleInterface diff --git a/src/modules/TriangleInterface/src/report.c b/src/modules/TriangleInterface/src/report.c new file mode 100644 index 000000000..e7a89f0e6 --- /dev/null +++ b/src/modules/TriangleInterface/src/report.c @@ -0,0 +1,126 @@ +/* The next line is used to outsmart some very stupid compilers. If your */ +/* compiler is smarter, feel free to replace the "int" with "void". */ +/* Not that it matters. */ + +#define VOID int + +// this void is also defined in triangle.c + +#include "triangle.h" +#include +#include + +void report(struct triangulateio *, int, int, int, int, int, int); +void trianglefree(struct triangulateio *); + +void report(io, markers, reporttriangles, reportneighbors, reportsegments, + reportedges, reportnorms) struct triangulateio *io; +int markers; +int reporttriangles; +int reportneighbors; +int reportsegments; +int reportedges; +int reportnorms; +{ + int i, j; + + for (i = 0; i < io->numberofpoints; i++) { + printf("Point %4d:", i); + for (j = 0; j < 2; j++) { + printf(" %.6g", io->pointlist[i * 2 + j]); + } + if (io->numberofpointattributes > 0) { + printf(" attributes"); + } + for (j = 0; j < io->numberofpointattributes; j++) { + printf(" %.6g", + io->pointattributelist[i * io->numberofpointattributes + j]); + } + if (markers) { + printf(" marker %d\n", io->pointmarkerlist[i]); + } else { + printf("\n"); + } + } + printf("\n"); + + if (reporttriangles || reportneighbors) { + for (i = 0; i < io->numberoftriangles; i++) { + if (reporttriangles) { + printf("Triangle %4d points:", i); + for (j = 0; j < io->numberofcorners; j++) { + printf(" %4d", io->trianglelist[i * io->numberofcorners + j]); + } + if (io->numberoftriangleattributes > 0) { + printf(" attributes"); + } + for (j = 0; j < io->numberoftriangleattributes; j++) { + printf(" %.6g", + io->triangleattributelist[i * io->numberoftriangleattributes + + j]); + } + printf("\n"); + } + if (reportneighbors) { + printf("Triangle %4d neighbors:", i); + for (j = 0; j < 3; j++) { + printf(" %4d", io->neighborlist[i * 3 + j]); + } + printf("\n"); + } + } + printf("\n"); + } + + if (reportsegments) { + for (i = 0; i < io->numberofsegments; i++) { + printf("Segment %4d points:", i); + for (j = 0; j < 2; j++) { + printf(" %4d", io->segmentlist[i * 2 + j]); + } + if (markers) { + printf(" marker %d\n", io->segmentmarkerlist[i]); + } else { + printf("\n"); + } + } + printf("\n"); + } + + if (reportedges) { + for (i = 0; i < io->numberofedges; i++) { + printf("Edge %4d points:", i); + for (j = 0; j < 2; j++) { + printf(" %4d", io->edgelist[i * 2 + j]); + } + if (reportnorms && (io->edgelist[i * 2 + 1] == -1)) { + for (j = 0; j < 2; j++) { + printf(" %.6g", io->normlist[i * 2 + j]); + } + } + if (markers) { + printf(" marker %d\n", io->edgemarkerlist[i]); + } else { + printf("\n"); + } + } + printf("\n"); + } +} + +void trianglefree(struct triangulateio *io) { + + free(io->pointlist); + free(io->pointattributelist); + free(io->pointmarkerlist); + free(io->trianglelist); + free(io->triangleattributelist); + free(io->trianglearealist); + free(io->neighborlist); + free(io->segmentlist); + free(io->segmentmarkerlist); + free(io->holelist); + free(io->regionlist); + free(io->edgelist); + free(io->edgemarkerlist); +} diff --git a/src/modules/TriangleInterface/src/triangle.c b/src/modules/TriangleInterface/src/triangle.c new file mode 100644 index 000000000..4ff0e0270 --- /dev/null +++ b/src/modules/TriangleInterface/src/triangle.c @@ -0,0 +1,15737 @@ +/*****************************************************************************/ +/* */ +/* 888888888 ,o, / 888 */ +/* 888 88o88o " o8888o 88o8888o o88888o 888 o88888o */ +/* 888 888 888 88b 888 888 888 888 888 d888 88b */ +/* 888 888 888 o88^o888 888 888 "88888" 888 8888oo888 */ +/* 888 888 888 C888 888 888 888 / 888 q888 */ +/* 888 888 888 "88o^888 888 888 Cb 888 "88oooo" */ +/* "8oo8D */ +/* */ +/* A Two-Dimensional Quality Mesh Generator and Delaunay Triangulator. */ +/* (triangle.c) */ +/* */ +/* Version 1.6 */ +/* July 28, 2005 */ +/* */ +/* Copyright 1993, 1995, 1997, 1998, 2002, 2005 */ +/* Jonathan Richard Shewchuk */ +/* 2360 Woolsey #H */ +/* Berkeley, California 94705-1927 */ +/* jrs@cs.berkeley.edu */ +/* */ +/* This program may be freely redistributed under the condition that the */ +/* copyright notices (including this entire header and the copyright */ +/* notice printed when the `-h' switch is selected) are not removed, and */ +/* no compensation is received. Private, research, and institutional */ +/* use is free. You may distribute modified versions of this code UNDER */ +/* THE CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE TO IT IN THE */ +/* SAME FILE REMAIN UNDER COPYRIGHT OF THE ORIGINAL AUTHOR, BOTH SOURCE */ +/* AND OBJECT CODE ARE MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR */ +/* NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution of this code as */ +/* part of a commercial system is permissible ONLY BY DIRECT ARRANGEMENT */ +/* WITH THE AUTHOR. (If you are not directly supplying this code to a */ +/* customer, and you are instead telling them how they can obtain it for */ +/* free, then you are not required to make any arrangement with me.) */ +/* */ +/* Hypertext instructions for Triangle are available on the Web at */ +/* */ +/* http://www.cs.cmu.edu/~quake/triangle.html */ +/* */ +/* Disclaimer: Neither I nor Carnegie Mellon warrant this code in any way */ +/* whatsoever. This code is provided "as-is". Use at your own risk. */ +/* */ +/* Some of the references listed below are marked with an asterisk. [*] */ +/* These references are available for downloading from the Web page */ +/* */ +/* http://www.cs.cmu.edu/~quake/triangle.research.html */ +/* */ +/* Three papers discussing aspects of Triangle are available. A short */ +/* overview appears in "Triangle: Engineering a 2D Quality Mesh */ +/* Generator and Delaunay Triangulator," in Applied Computational */ +/* Geometry: Towards Geometric Engineering, Ming C. Lin and Dinesh */ +/* Manocha, editors, Lecture Notes in Computer Science volume 1148, */ +/* pages 203-222, Springer-Verlag, Berlin, May 1996 (from the First ACM */ +/* Workshop on Applied Computational Geometry). [*] */ +/* */ +/* The algorithms are discussed in the greatest detail in "Delaunay */ +/* Refinement Algorithms for Triangular Mesh Generation," Computational */ +/* Geometry: Theory and Applications 22(1-3):21-74, May 2002. [*] */ +/* */ +/* More detail about the data structures may be found in my dissertation: */ +/* "Delaunay Refinement Mesh Generation," Ph.D. thesis, Technical Report */ +/* CMU-CS-97-137, School of Computer Science, Carnegie Mellon University, */ +/* Pittsburgh, Pennsylvania, 18 May 1997. [*] */ +/* */ +/* Triangle was created as part of the Quake Project in the School of */ +/* Computer Science at Carnegie Mellon University. For further */ +/* information, see Hesheng Bao, Jacobo Bielak, Omar Ghattas, Loukas F. */ +/* Kallivokas, David R. O'Hallaron, Jonathan R. Shewchuk, and Jifeng Xu, */ +/* "Large-scale Simulation of Elastic Wave Propagation in Heterogeneous */ +/* Media on Parallel Computers," Computer Methods in Applied Mechanics */ +/* and Engineering 152(1-2):85-102, 22 January 1998. */ +/* */ +/* Triangle's Delaunay refinement algorithm for quality mesh generation is */ +/* a hybrid of one due to Jim Ruppert, "A Delaunay Refinement Algorithm */ +/* for Quality 2-Dimensional Mesh Generation," Journal of Algorithms */ +/* 18(3):548-585, May 1995 [*], and one due to L. Paul Chew, "Guaranteed- */ +/* Quality Mesh Generation for Curved Surfaces," Proceedings of the Ninth */ +/* Annual Symposium on Computational Geometry (San Diego, California), */ +/* pages 274-280, Association for Computing Machinery, May 1993, */ +/* http://portal.acm.org/citation.cfm?id=161150 . */ +/* */ +/* The Delaunay refinement algorithm has been modified so that it meshes */ +/* domains with small input angles well, as described in Gary L. Miller, */ +/* Steven E. Pav, and Noel J. Walkington, "When and Why Ruppert's */ +/* Algorithm Works," Twelfth International Meshing Roundtable, pages */ +/* 91-102, Sandia National Laboratories, September 2003. [*] */ +/* */ +/* My implementation of the divide-and-conquer and incremental Delaunay */ +/* triangulation algorithms follows closely the presentation of Guibas */ +/* and Stolfi, even though I use a triangle-based data structure instead */ +/* of their quad-edge data structure. (In fact, I originally implemented */ +/* Triangle using the quad-edge data structure, but the switch to a */ +/* triangle-based data structure sped Triangle by a factor of two.) The */ +/* mesh manipulation primitives and the two aforementioned Delaunay */ +/* triangulation algorithms are described by Leonidas J. Guibas and Jorge */ +/* Stolfi, "Primitives for the Manipulation of General Subdivisions and */ +/* the Computation of Voronoi Diagrams," ACM Transactions on Graphics */ +/* 4(2):74-123, April 1985, http://portal.acm.org/citation.cfm?id=282923 .*/ +/* */ +/* Their O(n log n) divide-and-conquer algorithm is adapted from Der-Tsai */ +/* Lee and Bruce J. Schachter, "Two Algorithms for Constructing the */ +/* Delaunay Triangulation," International Journal of Computer and */ +/* Information Science 9(3):219-242, 1980. Triangle's improvement of the */ +/* divide-and-conquer algorithm by alternating between vertical and */ +/* horizontal cuts was introduced by Rex A. Dwyer, "A Faster Divide-and- */ +/* Conquer Algorithm for Constructing Delaunay Triangulations," */ +/* Algorithmica 2(2):137-151, 1987. */ +/* */ +/* The incremental insertion algorithm was first proposed by C. L. Lawson, */ +/* "Software for C1 Surface Interpolation," in Mathematical Software III, */ +/* John R. Rice, editor, Academic Press, New York, pp. 161-194, 1977. */ +/* For point location, I use the algorithm of Ernst P. Mucke, Isaac */ +/* Saias, and Binhai Zhu, "Fast Randomized Point Location Without */ +/* Preprocessing in Two- and Three-Dimensional Delaunay Triangulations," */ +/* Proceedings of the Twelfth Annual Symposium on Computational Geometry, */ +/* ACM, May 1996. [*] If I were to randomize the order of vertex */ +/* insertion (I currently don't bother), their result combined with the */ +/* result of Kenneth L. Clarkson and Peter W. Shor, "Applications of */ +/* Random Sampling in Computational Geometry II," Discrete & */ +/* Computational Geometry 4(1):387-421, 1989, would yield an expected */ +/* O(n^{4/3}) bound on running time. */ +/* */ +/* The O(n log n) sweepline Delaunay triangulation algorithm is taken from */ +/* Steven Fortune, "A Sweepline Algorithm for Voronoi Diagrams", */ +/* Algorithmica 2(2):153-174, 1987. A random sample of edges on the */ +/* boundary of the triangulation are maintained in a splay tree for the */ +/* purpose of point location. Splay trees are described by Daniel */ +/* Dominic Sleator and Robert Endre Tarjan, "Self-Adjusting Binary Search */ +/* Trees," Journal of the ACM 32(3):652-686, July 1985, */ +/* http://portal.acm.org/citation.cfm?id=3835 . */ +/* */ +/* The algorithms for exact computation of the signs of determinants are */ +/* described in Jonathan Richard Shewchuk, "Adaptive Precision Floating- */ +/* Point Arithmetic and Fast Robust Geometric Predicates," Discrete & */ +/* Computational Geometry 18(3):305-363, October 1997. (Also available */ +/* as Technical Report CMU-CS-96-140, School of Computer Science, */ +/* Carnegie Mellon University, Pittsburgh, Pennsylvania, May 1996.) [*] */ +/* An abbreviated version appears as Jonathan Richard Shewchuk, "Robust */ +/* Adaptive Floating-Point Geometric Predicates," Proceedings of the */ +/* Twelfth Annual Symposium on Computational Geometry, ACM, May 1996. [*] */ +/* Many of the ideas for my exact arithmetic routines originate with */ +/* Douglas M. Priest, "Algorithms for Arbitrary Precision Floating Point */ +/* Arithmetic," Tenth Symposium on Computer Arithmetic, pp. 132-143, IEEE */ +/* Computer Society Press, 1991. [*] Many of the ideas for the correct */ +/* evaluation of the signs of determinants are taken from Steven Fortune */ +/* and Christopher J. Van Wyk, "Efficient Exact Arithmetic for Computa- */ +/* tional Geometry," Proceedings of the Ninth Annual Symposium on */ +/* Computational Geometry, ACM, pp. 163-172, May 1993, and from Steven */ +/* Fortune, "Numerical Stability of Algorithms for 2D Delaunay Triangu- */ +/* lations," International Journal of Computational Geometry & Applica- */ +/* tions 5(1-2):193-213, March-June 1995. */ +/* */ +/* The method of inserting new vertices off-center (not precisely at the */ +/* circumcenter of every poor-quality triangle) is from Alper Ungor, */ +/* "Off-centers: A New Type of Steiner Points for Computing Size-Optimal */ +/* Quality-Guaranteed Delaunay Triangulations," Proceedings of LATIN */ +/* 2004 (Buenos Aires, Argentina), April 2004. */ +/* */ +/* For definitions of and results involving Delaunay triangulations, */ +/* constrained and conforming versions thereof, and other aspects of */ +/* triangular mesh generation, see the excellent survey by Marshall Bern */ +/* and David Eppstein, "Mesh Generation and Optimal Triangulation," in */ +/* Computing and Euclidean Geometry, Ding-Zhu Du and Frank Hwang, */ +/* editors, World Scientific, Singapore, pp. 23-90, 1992. [*] */ +/* */ +/* The time for incrementally adding PSLG (planar straight line graph) */ +/* segments to create a constrained Delaunay triangulation is probably */ +/* O(t^2) per segment in the worst case and O(t) per segment in the */ +/* common case, where t is the number of triangles that intersect the */ +/* segment before it is inserted. This doesn't count point location, */ +/* which can be much more expensive. I could improve this to O(d log d) */ +/* time, but d is usually quite small, so it's not worth the bother. */ +/* (This note does not apply when the -s switch is used, invoking a */ +/* different method is used to insert segments.) */ +/* */ +/* The time for deleting a vertex from a Delaunay triangulation is O(d^2) */ +/* in the worst case and O(d) in the common case, where d is the degree */ +/* of the vertex being deleted. I could improve this to O(d log d) time, */ +/* but d is usually quite small, so it's not worth the bother. */ +/* */ +/* Ruppert's Delaunay refinement algorithm typically generates triangles */ +/* at a linear rate (constant time per triangle) after the initial */ +/* triangulation is formed. There may be pathological cases where */ +/* quadratic time is required, but these never arise in practice. */ +/* */ +/* The geometric predicates (circumcenter calculations, segment */ +/* intersection formulae, etc.) appear in my "Lecture Notes on Geometric */ +/* Robustness" at http://www.cs.berkeley.edu/~jrs/mesh . */ +/* */ +/* If you make any improvements to this code, please please please let me */ +/* know, so that I may obtain the improvements. Even if you don't change */ +/* the code, I'd still love to hear what it's being used for. */ +/* */ +/*****************************************************************************/ + +/* For single precision (which will save some memory and reduce paging), */ +/* define the symbol SINGLE by using the -DSINGLE compiler switch or by */ +/* writing "#define SINGLE" below. */ +/* */ +/* For double precision (which will allow you to refine meshes to a smaller */ +/* edge length), leave SINGLE undefined. */ +/* */ +/* Double precision uses more memory, but improves the resolution of the */ +/* meshes you can generate with Triangle. It also reduces the likelihood */ +/* of a floating exception due to overflow. Finally, it is much faster */ +/* than single precision on 64-bit architectures like the DEC Alpha. I */ +/* recommend double precision unless you want to generate a mesh for which */ +/* you do not have enough memory. */ + +/* #define SINGLE */ + +#ifdef USE_Real64 +#define REAL double +#else +#define REAL float +#endif + +/* If yours is not a Unix system, define the NO_TIMER compiler switch to */ +/* remove the Unix-specific timing code. */ + +/* #define NO_TIMER */ + +/* To insert lots of self-checks for internal errors, define the SELF_CHECK */ +/* symbol. This will slow down the program significantly. It is best to */ +/* define the symbol using the -DSELF_CHECK compiler switch, but you could */ +/* write "#define SELF_CHECK" below. If you are modifying this code, I */ +/* recommend you turn self-checks on until your work is debugged. */ + +/* #define SELF_CHECK */ + +/* To compile Triangle as a callable object library (triangle.o), define the */ +/* TRILIBRARY symbol. Read the file triangle.h for details on how to call */ +/* the procedure triangulate() that results. */ + +/* #define TRILIBRARY */ + +/* It is possible to generate a smaller version of Triangle using one or */ +/* both of the following symbols. Define the REDUCED symbol to eliminate */ +/* all features that are primarily of research interest; specifically, the */ +/* -i, -F, -s, and -C switches. Define the CDT_ONLY symbol to eliminate */ +/* all meshing algorithms above and beyond constrained Delaunay */ +/* triangulation; specifically, the -r, -q, -a, -u, -D, -S, and -s */ +/* switches. These reductions are most likely to be useful when */ +/* generating an object library (triangle.o) by defining the TRILIBRARY */ +/* symbol. */ + +/* #define REDUCED */ +/* #define CDT_ONLY */ + +/* On some machines, my exact arithmetic routines might be defeated by the */ +/* use of internal extended precision floating-point registers. The best */ +/* way to solve this problem is to set the floating-point registers to use */ +/* single or double precision internally. On 80x86 processors, this may */ +/* be accomplished by setting the CPU86 symbol for the Microsoft C */ +/* compiler, or the LINUX symbol for the gcc compiler running on Linux. */ +/* */ +/* An inferior solution is to declare certain values as `volatile', thus */ +/* forcing them to be stored to memory and rounded off. Unfortunately, */ +/* this solution might slow Triangle down quite a bit. To use volatile */ +/* values, write "#define INEXACT volatile" below. Normally, however, */ +/* INEXACT should be defined to be nothing. ("#define INEXACT".) */ +/* */ +/* For more discussion, see http://www.cs.cmu.edu/~quake/robust.pc.html . */ +/* For yet more discussion, see Section 5 of my paper, "Adaptive Precision */ +/* Floating-Point Arithmetic and Fast Robust Geometric Predicates" (also */ +/* available as Section 6.6 of my dissertation). */ + +/* #define CPU86 */ +/* #define LINUX */ + +#define INEXACT /* Nothing */ +/* #define INEXACT volatile */ + +/* Maximum number of characters in a file name (including the null). */ + +#define FILENAMESIZE 2048 + +/* Maximum number of characters in a line read from a file (including the */ +/* null). */ + +#define INPUTLINESIZE 1024 + +/* For efficiency, a variety of data structures are allocated in bulk. The */ +/* following constants determine how many of each structure is allocated */ +/* at once. */ + +#define TRIPERBLOCK 4092 /* Number of triangles allocated at once. */ +#define SUBSEGPERBLOCK 508 /* Number of subsegments allocated at once. */ +#define VERTEXPERBLOCK 4092 /* Number of vertices allocated at once. */ +#define VIRUSPERBLOCK 1020 /* Number of virus triangles allocated at once. */ +/* Number of encroached subsegments allocated at once. */ +#define BADSUBSEGPERBLOCK 252 +/* Number of skinny triangles allocated at once. */ +#define BADTRIPERBLOCK 4092 +/* Number of flipped triangles allocated at once. */ +#define FLIPSTACKERPERBLOCK 252 +/* Number of splay tree nodes allocated at once. */ +#define SPLAYNODEPERBLOCK 508 + +/* The vertex types. A DEADVERTEX has been deleted entirely. An */ +/* UNDEADVERTEX is not part of the mesh, but is written to the output */ +/* .node file and affects the node indexing in the other output files. */ + +#define INPUTVERTEX 0 +#define SEGMENTVERTEX 1 +#define FREEVERTEX 2 +#define DEADVERTEX -32768 +#define UNDEADVERTEX -32767 + +/* The next line is used to outsmart some very stupid compilers. If your */ +/* compiler is smarter, feel free to replace the "int" with "void". */ +/* Not that it matters. */ + +#define VOID int + +/* Two constants for algorithms based on random sampling. Both constants */ +/* have been chosen empirically to optimize their respective algorithms. */ + +/* Used for the point location scheme of Mucke, Saias, and Zhu, to decide */ +/* how large a random sample of triangles to inspect. */ + +#define SAMPLEFACTOR 11 + +/* Used in Fortune's sweepline Delaunay algorithm to determine what fraction */ +/* of boundary edges should be maintained in the splay tree for point */ +/* location on the front. */ + +#define SAMPLERATE 10 + +/* A number that speaks for itself, every kissable digit. */ + +#define PI 3.141592653589793238462643383279502884197169399375105820974944592308 + +/* Another fave. */ + +#define SQUAREROOTTWO 1.4142135623730950488016887242096980785696718753769480732 + +/* And here's one for those of you who are intimidated by math. */ + +#define ONETHIRD 0.333333333333333333333333333333333333333333333333333333333333 + +#include +#include +#include +#include +#ifndef NO_TIMER +#include +#endif /* not NO_TIMER */ +#ifdef CPU86 +#include +#endif /* CPU86 */ +#ifdef LINUX +#include +#endif /* LINUX */ +#ifdef TRILIBRARY +#include "triangle.h" +#endif /* TRILIBRARY */ + +/* A few forward declarations. */ + +#ifndef TRILIBRARY +char *readline(); +char *findfield(); +#endif /* not TRILIBRARY */ + +/* Labels that signify the result of point location. The result of a */ +/* search indicates that the point falls in the interior of a triangle, on */ +/* an edge, on a vertex, or outside the mesh. */ + +enum locateresult { INTRIANGLE, ONEDGE, ONVERTEX, OUTSIDE }; + +/* Labels that signify the result of vertex insertion. The result indicates */ +/* that the vertex was inserted with complete success, was inserted but */ +/* encroaches upon a subsegment, was not inserted because it lies on a */ +/* segment, or was not inserted because another vertex occupies the same */ +/* location. */ + +enum insertvertexresult { + SUCCESSFULVERTEX, + ENCROACHINGVERTEX, + VIOLATINGVERTEX, + DUPLICATEVERTEX +}; + +/* Labels that signify the result of direction finding. The result */ +/* indicates that a segment connecting the two query points falls within */ +/* the direction triangle, along the left edge of the direction triangle, */ +/* or along the right edge of the direction triangle. */ + +enum finddirectionresult { WITHIN, LEFTCOLLINEAR, RIGHTCOLLINEAR }; + +/*****************************************************************************/ +/* */ +/* The basic mesh data structures */ +/* */ +/* There are three: vertices, triangles, and subsegments (abbreviated */ +/* `subseg'). These three data structures, linked by pointers, comprise */ +/* the mesh. A vertex simply represents a mesh vertex and its properties. */ +/* A triangle is a triangle. A subsegment is a special data structure used */ +/* to represent an impenetrable edge of the mesh (perhaps on the outer */ +/* boundary, on the boundary of a hole, or part of an internal boundary */ +/* separating two triangulated regions). Subsegments represent boundaries, */ +/* defined by the user, that triangles may not lie across. */ +/* */ +/* A triangle consists of a list of three vertices, a list of three */ +/* adjoining triangles, a list of three adjoining subsegments (when */ +/* segments exist), an arbitrary number of optional user-defined */ +/* floating-point attributes, and an optional area constraint. The latter */ +/* is an upper bound on the permissible area of each triangle in a region, */ +/* used for mesh refinement. */ +/* */ +/* For a triangle on a boundary of the mesh, some or all of the neighboring */ +/* triangles may not be present. For a triangle in the interior of the */ +/* mesh, often no neighboring subsegments are present. Such absent */ +/* triangles and subsegments are never represented by NULL pointers; they */ +/* are represented by two special records: `dummytri', the triangle that */ +/* fills "outer space", and `dummysub', the omnipresent subsegment. */ +/* `dummytri' and `dummysub' are used for several reasons; for instance, */ +/* they can be dereferenced and their contents examined without violating */ +/* protected memory. */ +/* */ +/* However, it is important to understand that a triangle includes other */ +/* information as well. The pointers to adjoining vertices, triangles, and */ +/* subsegments are ordered in a way that indicates their geometric relation */ +/* to each other. Furthermore, each of these pointers contains orientation */ +/* information. Each pointer to an adjoining triangle indicates which face */ +/* of that triangle is contacted. Similarly, each pointer to an adjoining */ +/* subsegment indicates which side of that subsegment is contacted, and how */ +/* the subsegment is oriented relative to the triangle. */ +/* */ +/* The data structure representing a subsegment may be thought to be */ +/* abutting the edge of one or two triangle data structures: either */ +/* sandwiched between two triangles, or resting against one triangle on an */ +/* exterior boundary or hole boundary. */ +/* */ +/* A subsegment consists of a list of four vertices--the vertices of the */ +/* subsegment, and the vertices of the segment it is a part of--a list of */ +/* two adjoining subsegments, and a list of two adjoining triangles. One */ +/* of the two adjoining triangles may not be present (though there should */ +/* always be one), and neighboring subsegments might not be present. */ +/* Subsegments also store a user-defined integer "boundary marker". */ +/* Typically, this integer is used to indicate what boundary conditions are */ +/* to be applied at that location in a finite element simulation. */ +/* */ +/* Like triangles, subsegments maintain information about the relative */ +/* orientation of neighboring objects. */ +/* */ +/* Vertices are relatively simple. A vertex is a list of floating-point */ +/* numbers, starting with the x, and y coordinates, followed by an */ +/* arbitrary number of optional user-defined floating-point attributes, */ +/* followed by an integer boundary marker. During the segment insertion */ +/* phase, there is also a pointer from each vertex to a triangle that may */ +/* contain it. Each pointer is not always correct, but when one is, it */ +/* speeds up segment insertion. These pointers are assigned values once */ +/* at the beginning of the segment insertion phase, and are not used or */ +/* updated except during this phase. Edge flipping during segment */ +/* insertion will render some of them incorrect. Hence, don't rely upon */ +/* them for anything. */ +/* */ +/* Other than the exception mentioned above, vertices have no information */ +/* about what triangles, subfacets, or subsegments they are linked to. */ +/* */ +/*****************************************************************************/ + +/*****************************************************************************/ +/* */ +/* Handles */ +/* */ +/* The oriented triangle (`otri') and oriented subsegment (`osub') data */ +/* structures defined below do not themselves store any part of the mesh. */ +/* The mesh itself is made of `triangle's, `subseg's, and `vertex's. */ +/* */ +/* Oriented triangles and oriented subsegments will usually be referred to */ +/* as "handles." A handle is essentially a pointer into the mesh; it */ +/* allows you to "hold" one particular part of the mesh. Handles are used */ +/* to specify the regions in which one is traversing and modifying the mesh.*/ +/* A single `triangle' may be held by many handles, or none at all. (The */ +/* latter case is not a memory leak, because the triangle is still */ +/* connected to other triangles in the mesh.) */ +/* */ +/* An `otri' is a handle that holds a triangle. It holds a specific edge */ +/* of the triangle. An `osub' is a handle that holds a subsegment. It */ +/* holds either the left or right side of the subsegment. */ +/* */ +/* Navigation about the mesh is accomplished through a set of mesh */ +/* manipulation primitives, further below. Many of these primitives take */ +/* a handle and produce a new handle that holds the mesh near the first */ +/* handle. Other primitives take two handles and glue the corresponding */ +/* parts of the mesh together. The orientation of the handles is */ +/* important. For instance, when two triangles are glued together by the */ +/* bond() primitive, they are glued at the edges on which the handles lie. */ +/* */ +/* Because vertices have no information about which triangles they are */ +/* attached to, I commonly represent a vertex by use of a handle whose */ +/* origin is the vertex. A single handle can simultaneously represent a */ +/* triangle, an edge, and a vertex. */ +/* */ +/*****************************************************************************/ + +/* The triangle data structure. Each triangle contains three pointers to */ +/* adjoining triangles, plus three pointers to vertices, plus three */ +/* pointers to subsegments (declared below; these pointers are usually */ +/* `dummysub'). It may or may not also contain user-defined attributes */ +/* and/or a floating-point "area constraint." It may also contain extra */ +/* pointers for nodes, when the user asks for high-order elements. */ +/* Because the size and structure of a `triangle' is not decided until */ +/* runtime, I haven't simply declared the type `triangle' as a struct. */ + +typedef REAL **triangle; /* Really: typedef triangle *triangle */ + +/* An oriented triangle: includes a pointer to a triangle and orientation. */ +/* The orientation denotes an edge of the triangle. Hence, there are */ +/* three possible orientations. By convention, each edge always points */ +/* counterclockwise about the corresponding triangle. */ + +struct otri { + triangle *tri; + int orient; /* Ranges from 0 to 2. */ +}; + +/* The subsegment data structure. Each subsegment contains two pointers to */ +/* adjoining subsegments, plus four pointers to vertices, plus two */ +/* pointers to adjoining triangles, plus one boundary marker, plus one */ +/* segment number. */ + +typedef REAL **subseg; /* Really: typedef subseg *subseg */ + +/* An oriented subsegment: includes a pointer to a subsegment and an */ +/* orientation. The orientation denotes a side of the edge. Hence, there */ +/* are two possible orientations. By convention, the edge is always */ +/* directed so that the "side" denoted is the right side of the edge. */ + +struct osub { + subseg *ss; + int ssorient; /* Ranges from 0 to 1. */ +}; + +/* The vertex data structure. Each vertex is actually an array of REALs. */ +/* The number of REALs is unknown until runtime. An integer boundary */ +/* marker, and sometimes a pointer to a triangle, is appended after the */ +/* REALs. */ + +typedef REAL *vertex; + +/* A queue used to store encroached subsegments. Each subsegment's vertices */ +/* are stored so that we can check whether a subsegment is still the same. */ + +struct badsubseg { + subseg encsubseg; /* An encroached subsegment. */ + vertex subsegorg, subsegdest; /* Its two vertices. */ +}; + +/* A queue used to store bad triangles. The key is the square of the cosine */ +/* of the smallest angle of the triangle. Each triangle's vertices are */ +/* stored so that one can check whether a triangle is still the same. */ + +struct badtriang { + triangle poortri; /* A skinny or too-large triangle. */ + REAL key; /* cos^2 of smallest (apical) angle. */ + vertex triangorg, triangdest, triangapex; /* Its three vertices. */ + struct badtriang *nexttriang; /* Pointer to next bad triangle. */ +}; + +/* A stack of triangles flipped during the most recent vertex insertion. */ +/* The stack is used to undo the vertex insertion if the vertex encroaches */ +/* upon a subsegment. */ + +struct flipstacker { + triangle flippedtri; /* A recently flipped triangle. */ + struct flipstacker *prevflip; /* Previous flip in the stack. */ +}; + +/* A node in a heap used to store events for the sweepline Delaunay */ +/* algorithm. Nodes do not point directly to their parents or children in */ +/* the heap. Instead, each node knows its position in the heap, and can */ +/* look up its parent and children in a separate array. The `eventptr' */ +/* points either to a `vertex' or to a triangle (in encoded format, so */ +/* that an orientation is included). In the latter case, the origin of */ +/* the oriented triangle is the apex of a "circle event" of the sweepline */ +/* algorithm. To distinguish site events from circle events, all circle */ +/* events are given an invalid (smaller than `xmin') x-coordinate `xkey'. */ + +struct event { + REAL xkey, ykey; /* Coordinates of the event. */ + VOID *eventptr; /* Can be a vertex or the location of a circle event. */ + int heapposition; /* Marks this event's position in the heap. */ +}; + +/* A node in the splay tree. Each node holds an oriented ghost triangle */ +/* that represents a boundary edge of the growing triangulation. When a */ +/* circle event covers two boundary edges with a triangle, so that they */ +/* are no longer boundary edges, those edges are not immediately deleted */ +/* from the tree; rather, they are lazily deleted when they are next */ +/* encountered. (Since only a random sample of boundary edges are kept */ +/* in the tree, lazy deletion is faster.) `keydest' is used to verify */ +/* that a triangle is still the same as when it entered the splay tree; if */ +/* it has been rotated (due to a circle event), it no longer represents a */ +/* boundary edge and should be deleted. */ + +struct splaynode { + struct otri keyedge; /* Lprev of an edge on the front. */ + vertex keydest; /* Used to verify that splay node is still live. */ + struct splaynode *lchild, *rchild; /* Children in splay tree. */ +}; + +/* A type used to allocate memory. firstblock is the first block of items. */ +/* nowblock is the block from which items are currently being allocated. */ +/* nextitem points to the next slab of free memory for an item. */ +/* deaditemstack is the head of a linked list (stack) of deallocated items */ +/* that can be recycled. unallocateditems is the number of items that */ +/* remain to be allocated from nowblock. */ +/* */ +/* Traversal is the process of walking through the entire list of items, and */ +/* is separate from allocation. Note that a traversal will visit items on */ +/* the "deaditemstack" stack as well as live items. pathblock points to */ +/* the block currently being traversed. pathitem points to the next item */ +/* to be traversed. pathitemsleft is the number of items that remain to */ +/* be traversed in pathblock. */ +/* */ +/* alignbytes determines how new records should be aligned in memory. */ +/* itembytes is the length of a record in bytes (after rounding up). */ +/* itemsperblock is the number of items allocated at once in a single */ +/* block. itemsfirstblock is the number of items in the first block, */ +/* which can vary from the others. items is the number of currently */ +/* allocated items. maxitems is the maximum number of items that have */ +/* been allocated at once; it is the current number of items plus the */ +/* number of records kept on deaditemstack. */ + +struct memorypool { + VOID **firstblock, **nowblock; + VOID *nextitem; + VOID *deaditemstack; + VOID **pathblock; + VOID *pathitem; + int alignbytes; + int itembytes; + int itemsperblock; + int itemsfirstblock; + long items, maxitems; + int unallocateditems; + int pathitemsleft; +}; + +/* Global constants. */ + +REAL splitter; /* Used to split REAL factors for exact multiplication. */ +REAL epsilon; /* Floating-point machine epsilon. */ +REAL resulterrbound; +REAL ccwerrboundA, ccwerrboundB, ccwerrboundC; +REAL iccerrboundA, iccerrboundB, iccerrboundC; +REAL o3derrboundA, o3derrboundB, o3derrboundC; + +/* Random number seed is not constant, but I've made it global anyway. */ + +unsigned long randomseed; /* Current random number seed. */ + +/* Mesh data structure. Triangle operates on only one mesh, but the mesh */ +/* structure is used (instead of global variables) to allow reentrancy. */ + +struct mesh { + + /* Variables used to allocate memory for triangles, subsegments, vertices, */ + /* viri (triangles being eaten), encroached segments, bad (skinny or too */ + /* large) triangles, and splay tree nodes. */ + + struct memorypool triangles; + struct memorypool subsegs; + struct memorypool vertices; + struct memorypool viri; + struct memorypool badsubsegs; + struct memorypool badtriangles; + struct memorypool flipstackers; + struct memorypool splaynodes; + + /* Variables that maintain the bad triangle queues. The queues are */ + /* ordered from 4095 (highest priority) to 0 (lowest priority). */ + + struct badtriang *queuefront[4096]; + struct badtriang *queuetail[4096]; + int nextnonemptyq[4096]; + int firstnonemptyq; + + /* Variable that maintains the stack of recently flipped triangles. */ + + struct flipstacker *lastflip; + + /* Other variables. */ + + REAL xmin, xmax, ymin, ymax; /* x and y bounds. */ + REAL xminextreme; /* Nonexistent x value used as a flag in sweepline. */ + int invertices; /* Number of input vertices. */ + int inelements; /* Number of input triangles. */ + int insegments; /* Number of input segments. */ + int holes; /* Number of input holes. */ + int regions; /* Number of input regions. */ + int undeads; /* Number of input vertices that don't appear in the mesh. */ + long edges; /* Number of output edges. */ + int mesh_dim; /* Dimension (ought to be 2). */ + int nextras; /* Number of attributes per vertex. */ + int eextras; /* Number of attributes per triangle. */ + long hullsize; /* Number of edges in convex hull. */ + int steinerleft; /* Number of Steiner points not yet used. */ + int vertexmarkindex; /* Index to find boundary marker of a vertex. */ + int vertex2triindex; /* Index to find a triangle adjacent to a vertex. */ + int highorderindex; /* Index to find extra nodes for high-order elements. */ + int elemattribindex; /* Index to find attributes of a triangle. */ + int areaboundindex; /* Index to find area bound of a triangle. */ + int checksegments; /* Are there segments in the triangulation yet? */ + int checkquality; /* Has quality triangulation begun yet? */ + int readnodefile; /* Has a .node file been read? */ + long samples; /* Number of random samples for point location. */ + + long incirclecount; /* Number of incircle tests performed. */ + long counterclockcount; /* Number of counterclockwise tests performed. */ + long orient3dcount; /* Number of 3D orientation tests performed. */ + long hyperbolacount; /* Number of right-of-hyperbola tests performed. */ + long circumcentercount; /* Number of circumcenter calculations performed. */ + long circletopcount; /* Number of circle top calculations performed. */ + + /* Triangular bounding box vertices. */ + + vertex infvertex1, infvertex2, infvertex3; + + /* Pointer to the `triangle' that occupies all of "outer space." */ + + triangle *dummytri; + triangle *dummytribase; /* Keep base address so we can free() it later. */ + + /* Pointer to the omnipresent subsegment. Referenced by any triangle or */ + /* subsegment that isn't really connected to a subsegment at that */ + /* location. */ + + subseg *dummysub; + subseg *dummysubbase; /* Keep base address so we can free() it later. */ + + /* Pointer to a recently visited triangle. Improves point location if */ + /* proximate vertices are inserted sequentially. */ + + struct otri recenttri; + +}; /* End of `struct mesh'. */ + +/* Data structure for command line switches and file names. This structure */ +/* is used (instead of global variables) to allow reentrancy. */ + +struct behavior { + + /* Switches for the triangulator. */ + /* poly: -p switch. refine: -r switch. */ + /* quality: -q switch. */ + /* minangle: minimum angle bound, specified after -q switch. */ + /* goodangle: cosine squared of minangle. */ + /* offconstant: constant used to place off-center Steiner points. */ + /* vararea: -a switch without number. */ + /* fixedarea: -a switch with number. */ + /* maxarea: maximum area bound, specified after -a switch. */ + /* usertest: -u switch. */ + /* regionattrib: -A switch. convex: -c switch. */ + /* weighted: 1 for -w switch, 2 for -W switch. jettison: -j switch */ + /* firstnumber: inverse of -z switch. All items are numbered starting */ + /* from `firstnumber'. */ + /* edgesout: -e switch. voronoi: -v switch. */ + /* neighbors: -n switch. geomview: -g switch. */ + /* nobound: -B switch. nopolywritten: -P switch. */ + /* nonodewritten: -N switch. noelewritten: -E switch. */ + /* noiterationnum: -I switch. noholes: -O switch. */ + /* noexact: -X switch. */ + /* order: element order, specified after -o switch. */ + /* nobisect: count of how often -Y switch is selected. */ + /* steiner: maximum number of Steiner points, specified after -S switch. */ + /* incremental: -i switch. sweepline: -F switch. */ + /* dwyer: inverse of -l switch. */ + /* splitseg: -s switch. */ + /* conformdel: -D switch. docheck: -C switch. */ + /* quiet: -Q switch. verbose: count of how often -V switch is selected. */ + /* usesegments: -p, -r, -q, or -c switch; determines whether segments are */ + /* used at all. */ + /* */ + /* Read the instructions to find out the meaning of these switches. */ + + int poly, refine, quality, vararea, fixedarea, usertest; + int regionattrib, convex, weighted, jettison; + int firstnumber; + int edgesout, voronoi, neighbors, geomview; + int nobound, nopolywritten, nonodewritten, noelewritten, noiterationnum; + int noholes, noexact, conformdel; + int incremental, sweepline, dwyer; + int splitseg; + int docheck; + int quiet, verbose; + int usesegments; + int order; + int nobisect; + int steiner; + REAL minangle, goodangle, offconstant; + REAL maxarea; + + /* Variables for file names. */ + +#ifndef TRILIBRARY + char innodefilename[FILENAMESIZE]; + char inelefilename[FILENAMESIZE]; + char inpolyfilename[FILENAMESIZE]; + char areafilename[FILENAMESIZE]; + char outnodefilename[FILENAMESIZE]; + char outelefilename[FILENAMESIZE]; + char outpolyfilename[FILENAMESIZE]; + char edgefilename[FILENAMESIZE]; + char vnodefilename[FILENAMESIZE]; + char vedgefilename[FILENAMESIZE]; + char neighborfilename[FILENAMESIZE]; + char offfilename[FILENAMESIZE]; +#endif /* not TRILIBRARY */ + +}; /* End of `struct behavior'. */ + +/*****************************************************************************/ +/* */ +/* Mesh manipulation primitives. Each triangle contains three pointers to */ +/* other triangles, with orientations. Each pointer points not to the */ +/* first byte of a triangle, but to one of the first three bytes of a */ +/* triangle. It is necessary to extract both the triangle itself and the */ +/* orientation. To save memory, I keep both pieces of information in one */ +/* pointer. To make this possible, I assume that all triangles are aligned */ +/* to four-byte boundaries. The decode() routine below decodes a pointer, */ +/* extracting an orientation (in the range 0 to 2) and a pointer to the */ +/* beginning of a triangle. The encode() routine compresses a pointer to a */ +/* triangle and an orientation into a single pointer. My assumptions that */ +/* triangles are four-byte-aligned and that the `unsigned long' type is */ +/* long enough to hold a pointer are two of the few kludges in this program.*/ +/* */ +/* Subsegments are manipulated similarly. A pointer to a subsegment */ +/* carries both an address and an orientation in the range 0 to 1. */ +/* */ +/* The other primitives take an oriented triangle or oriented subsegment, */ +/* and return an oriented triangle or oriented subsegment or vertex; or */ +/* they change the connections in the data structure. */ +/* */ +/* Below, triangles and subsegments are denoted by their vertices. The */ +/* triangle abc has origin (org) a, destination (dest) b, and apex (apex) */ +/* c. These vertices occur in counterclockwise order about the triangle. */ +/* The handle abc may simultaneously denote vertex a, edge ab, and triangle */ +/* abc. */ +/* */ +/* Similarly, the subsegment ab has origin (sorg) a and destination (sdest) */ +/* b. If ab is thought to be directed upward (with b directly above a), */ +/* then the handle ab is thought to grasp the right side of ab, and may */ +/* simultaneously denote vertex a and edge ab. */ +/* */ +/* An asterisk (*) denotes a vertex whose identity is unknown. */ +/* */ +/* Given this notation, a partial list of mesh manipulation primitives */ +/* follows. */ +/* */ +/* */ +/* For triangles: */ +/* */ +/* sym: Find the abutting triangle; same edge. */ +/* sym(abc) -> ba* */ +/* */ +/* lnext: Find the next edge (counterclockwise) of a triangle. */ +/* lnext(abc) -> bca */ +/* */ +/* lprev: Find the previous edge (clockwise) of a triangle. */ +/* lprev(abc) -> cab */ +/* */ +/* onext: Find the next edge counterclockwise with the same origin. */ +/* onext(abc) -> ac* */ +/* */ +/* oprev: Find the next edge clockwise with the same origin. */ +/* oprev(abc) -> a*b */ +/* */ +/* dnext: Find the next edge counterclockwise with the same destination. */ +/* dnext(abc) -> *ba */ +/* */ +/* dprev: Find the next edge clockwise with the same destination. */ +/* dprev(abc) -> cb* */ +/* */ +/* rnext: Find the next edge (counterclockwise) of the adjacent triangle. */ +/* rnext(abc) -> *a* */ +/* */ +/* rprev: Find the previous edge (clockwise) of the adjacent triangle. */ +/* rprev(abc) -> b** */ +/* */ +/* org: Origin dest: Destination apex: Apex */ +/* org(abc) -> a dest(abc) -> b apex(abc) -> c */ +/* */ +/* bond: Bond two triangles together at the resepective handles. */ +/* bond(abc, bad) */ +/* */ +/* */ +/* For subsegments: */ +/* */ +/* ssym: Reverse the orientation of a subsegment. */ +/* ssym(ab) -> ba */ +/* */ +/* spivot: Find adjoining subsegment with the same origin. */ +/* spivot(ab) -> a* */ +/* */ +/* snext: Find next subsegment in sequence. */ +/* snext(ab) -> b* */ +/* */ +/* sorg: Origin sdest: Destination */ +/* sorg(ab) -> a sdest(ab) -> b */ +/* */ +/* sbond: Bond two subsegments together at the respective origins. */ +/* sbond(ab, ac) */ +/* */ +/* */ +/* For interacting tetrahedra and subfacets: */ +/* */ +/* tspivot: Find a subsegment abutting a triangle. */ +/* tspivot(abc) -> ba */ +/* */ +/* stpivot: Find a triangle abutting a subsegment. */ +/* stpivot(ab) -> ba* */ +/* */ +/* tsbond: Bond a triangle to a subsegment. */ +/* tsbond(abc, ba) */ +/* */ +/*****************************************************************************/ + +/********* Mesh manipulation primitives begin here *********/ +/** **/ +/** **/ + +/* Fast lookup arrays to speed some of the mesh manipulation primitives. */ + +int plus1mod3[3] = {1, 2, 0}; +int minus1mod3[3] = {2, 0, 1}; + +/********* Primitives for triangles *********/ +/* */ +/* */ + +/* decode() converts a pointer to an oriented triangle. The orientation is */ +/* extracted from the two least significant bits of the pointer. */ + +#define decode(ptr, otri) \ + (otri).orient = (int)((unsigned long)(ptr) & (unsigned long)3l); \ + (otri).tri = (triangle *)((unsigned long)(ptr) ^ (unsigned long)(otri).orient) + +/* encode() compresses an oriented triangle into a single pointer. It */ +/* relies on the assumption that all triangles are aligned to four-byte */ +/* boundaries, so the two least significant bits of (otri).tri are zero. */ + +#define encode(otri) \ + (triangle)((unsigned long)(otri).tri | (unsigned long)(otri).orient) + +/* The following handle manipulation primitives are all described by Guibas */ +/* and Stolfi. However, Guibas and Stolfi use an edge-based data */ +/* structure, whereas I use a triangle-based data structure. */ + +/* sym() finds the abutting triangle, on the same edge. Note that the edge */ +/* direction is necessarily reversed, because the handle specified by an */ +/* oriented triangle is directed counterclockwise around the triangle. */ + +#define sym(otri1, otri2) \ + ptr = (otri1).tri[(otri1).orient]; \ + decode(ptr, otri2); + +#define symself(otri) \ + ptr = (otri).tri[(otri).orient]; \ + decode(ptr, otri); + +/* lnext() finds the next edge (counterclockwise) of a triangle. */ + +#define lnext(otri1, otri2) \ + (otri2).tri = (otri1).tri; \ + (otri2).orient = plus1mod3[(otri1).orient] + +#define lnextself(otri) (otri).orient = plus1mod3[(otri).orient] + +/* lprev() finds the previous edge (clockwise) of a triangle. */ + +#define lprev(otri1, otri2) \ + (otri2).tri = (otri1).tri; \ + (otri2).orient = minus1mod3[(otri1).orient] + +#define lprevself(otri) (otri).orient = minus1mod3[(otri).orient] + +/* onext() spins counterclockwise around a vertex; that is, it finds the */ +/* next edge with the same origin in the counterclockwise direction. This */ +/* edge is part of a different triangle. */ + +#define onext(otri1, otri2) \ + lprev(otri1, otri2); \ + symself(otri2); + +#define onextself(otri) \ + lprevself(otri); \ + symself(otri); + +/* oprev() spins clockwise around a vertex; that is, it finds the next edge */ +/* with the same origin in the clockwise direction. This edge is part of */ +/* a different triangle. */ + +#define oprev(otri1, otri2) \ + sym(otri1, otri2); \ + lnextself(otri2); + +#define oprevself(otri) \ + symself(otri); \ + lnextself(otri); + +/* dnext() spins counterclockwise around a vertex; that is, it finds the */ +/* next edge with the same destination in the counterclockwise direction. */ +/* This edge is part of a different triangle. */ + +#define dnext(otri1, otri2) \ + sym(otri1, otri2); \ + lprevself(otri2); + +#define dnextself(otri) \ + symself(otri); \ + lprevself(otri); + +/* dprev() spins clockwise around a vertex; that is, it finds the next edge */ +/* with the same destination in the clockwise direction. This edge is */ +/* part of a different triangle. */ + +#define dprev(otri1, otri2) \ + lnext(otri1, otri2); \ + symself(otri2); + +#define dprevself(otri) \ + lnextself(otri); \ + symself(otri); + +/* rnext() moves one edge counterclockwise about the adjacent triangle. */ +/* (It's best understood by reading Guibas and Stolfi. It involves */ +/* changing triangles twice.) */ + +#define rnext(otri1, otri2) \ + sym(otri1, otri2); \ + lnextself(otri2); \ + symself(otri2); + +#define rnextself(otri) \ + symself(otri); \ + lnextself(otri); \ + symself(otri); + +/* rprev() moves one edge clockwise about the adjacent triangle. */ +/* (It's best understood by reading Guibas and Stolfi. It involves */ +/* changing triangles twice.) */ + +#define rprev(otri1, otri2) \ + sym(otri1, otri2); \ + lprevself(otri2); \ + symself(otri2); + +#define rprevself(otri) \ + symself(otri); \ + lprevself(otri); \ + symself(otri); + +/* These primitives determine or set the origin, destination, or apex of a */ +/* triangle. */ + +#define org(otri, vertexptr) \ + vertexptr = (vertex)(otri).tri[plus1mod3[(otri).orient] + 3] + +#define dest(otri, vertexptr) \ + vertexptr = (vertex)(otri).tri[minus1mod3[(otri).orient] + 3] + +#define apex(otri, vertexptr) vertexptr = (vertex)(otri).tri[(otri).orient + 3] + +#define setorg(otri, vertexptr) \ + (otri).tri[plus1mod3[(otri).orient] + 3] = (triangle)vertexptr + +#define setdest(otri, vertexptr) \ + (otri).tri[minus1mod3[(otri).orient] + 3] = (triangle)vertexptr + +#define setapex(otri, vertexptr) \ + (otri).tri[(otri).orient + 3] = (triangle)vertexptr + +/* Bond two triangles together. */ + +#define bond(otri1, otri2) \ + (otri1).tri[(otri1).orient] = encode(otri2); \ + (otri2).tri[(otri2).orient] = encode(otri1) + +/* Dissolve a bond (from one side). Note that the other triangle will still */ +/* think it's connected to this triangle. Usually, however, the other */ +/* triangle is being deleted entirely, or bonded to another triangle, so */ +/* it doesn't matter. */ + +#define dissolve(otri) (otri).tri[(otri).orient] = (triangle)m->dummytri + +/* Copy an oriented triangle. */ + +#define otricopy(otri1, otri2) \ + (otri2).tri = (otri1).tri; \ + (otri2).orient = (otri1).orient + +/* Test for equality of oriented triangles. */ + +#define otriequal(otri1, otri2) \ + (((otri1).tri == (otri2).tri) && ((otri1).orient == (otri2).orient)) + +/* Primitives to infect or cure a triangle with the virus. These rely on */ +/* the assumption that all subsegments are aligned to four-byte boundaries.*/ + +#define infect(otri) \ + (otri).tri[6] = (triangle)((unsigned long)(otri).tri[6] | (unsigned long)2l) + +#define uninfect(otri) \ + (otri).tri[6] = (triangle)((unsigned long)(otri).tri[6] & ~(unsigned long)2l) + +/* Test a triangle for viral infection. */ + +#define infected(otri) \ + (((unsigned long)(otri).tri[6] & (unsigned long)2l) != 0l) + +/* Check or set a triangle's attributes. */ + +#define elemattribute(otri, attnum) \ + ((REAL *)(otri).tri)[m->elemattribindex + (attnum)] + +#define setelemattribute(otri, attnum, value) \ + ((REAL *)(otri).tri)[m->elemattribindex + (attnum)] = value + +/* Check or set a triangle's maximum area bound. */ + +#define areabound(otri) ((REAL *)(otri).tri)[m->areaboundindex] + +#define setareabound(otri, value) \ + ((REAL *)(otri).tri)[m->areaboundindex] = value + +/* Check or set a triangle's deallocation. Its second pointer is set to */ +/* NULL to indicate that it is not allocated. (Its first pointer is used */ +/* for the stack of dead items.) Its fourth pointer (its first vertex) */ +/* is set to NULL in case a `badtriang' structure points to it. */ + +#define deadtri(tria) ((tria)[1] == (triangle)NULL) + +#define killtri(tria) \ + (tria)[1] = (triangle)NULL; \ + (tria)[3] = (triangle)NULL + +/********* Primitives for subsegments *********/ +/* */ +/* */ + +/* sdecode() converts a pointer to an oriented subsegment. The orientation */ +/* is extracted from the least significant bit of the pointer. The two */ +/* least significant bits (one for orientation, one for viral infection) */ +/* are masked out to produce the real pointer. */ + +#define sdecode(sptr, osub) \ + (osub).ssorient = (int)((unsigned long)(sptr) & (unsigned long)1l); \ + (osub).ss = (subseg *)((unsigned long)(sptr) & ~(unsigned long)3l) + +/* sencode() compresses an oriented subsegment into a single pointer. It */ +/* relies on the assumption that all subsegments are aligned to two-byte */ +/* boundaries, so the least significant bit of (osub).ss is zero. */ + +#define sencode(osub) \ + (subseg)((unsigned long)(osub).ss | (unsigned long)(osub).ssorient) + +/* ssym() toggles the orientation of a subsegment. */ + +#define ssym(osub1, osub2) \ + (osub2).ss = (osub1).ss; \ + (osub2).ssorient = 1 - (osub1).ssorient + +#define ssymself(osub) (osub).ssorient = 1 - (osub).ssorient + +/* spivot() finds the other subsegment (from the same segment) that shares */ +/* the same origin. */ + +#define spivot(osub1, osub2) \ + sptr = (osub1).ss[(osub1).ssorient]; \ + sdecode(sptr, osub2) + +#define spivotself(osub) \ + sptr = (osub).ss[(osub).ssorient]; \ + sdecode(sptr, osub) + +/* snext() finds the next subsegment (from the same segment) in sequence; */ +/* one whose origin is the input subsegment's destination. */ + +#define snext(osub1, osub2) \ + sptr = (osub1).ss[1 - (osub1).ssorient]; \ + sdecode(sptr, osub2) + +#define snextself(osub) \ + sptr = (osub).ss[1 - (osub).ssorient]; \ + sdecode(sptr, osub) + +/* These primitives determine or set the origin or destination of a */ +/* subsegment or the segment that includes it. */ + +#define sorg(osub, vertexptr) vertexptr = (vertex)(osub).ss[2 + (osub).ssorient] + +#define sdest(osub, vertexptr) \ + vertexptr = (vertex)(osub).ss[3 - (osub).ssorient] + +#define setsorg(osub, vertexptr) \ + (osub).ss[2 + (osub).ssorient] = (subseg)vertexptr + +#define setsdest(osub, vertexptr) \ + (osub).ss[3 - (osub).ssorient] = (subseg)vertexptr + +#define segorg(osub, vertexptr) \ + vertexptr = (vertex)(osub).ss[4 + (osub).ssorient] + +#define segdest(osub, vertexptr) \ + vertexptr = (vertex)(osub).ss[5 - (osub).ssorient] + +#define setsegorg(osub, vertexptr) \ + (osub).ss[4 + (osub).ssorient] = (subseg)vertexptr + +#define setsegdest(osub, vertexptr) \ + (osub).ss[5 - (osub).ssorient] = (subseg)vertexptr + +/* These primitives read or set a boundary marker. Boundary markers are */ +/* used to hold user-defined tags for setting boundary conditions in */ +/* finite element solvers. */ + +#define mark(osub) (*(int *)((osub).ss + 8)) + +#define setmark(osub, value) *(int *)((osub).ss + 8) = value + +/* Bond two subsegments together. */ + +#define sbond(osub1, osub2) \ + (osub1).ss[(osub1).ssorient] = sencode(osub2); \ + (osub2).ss[(osub2).ssorient] = sencode(osub1) + +/* Dissolve a subsegment bond (from one side). Note that the other */ +/* subsegment will still think it's connected to this subsegment. */ + +#define sdissolve(osub) (osub).ss[(osub).ssorient] = (subseg)m->dummysub + +/* Copy a subsegment. */ + +#define subsegcopy(osub1, osub2) \ + (osub2).ss = (osub1).ss; \ + (osub2).ssorient = (osub1).ssorient + +/* Test for equality of subsegments. */ + +#define subsegequal(osub1, osub2) \ + (((osub1).ss == (osub2).ss) && ((osub1).ssorient == (osub2).ssorient)) + +/* Check or set a subsegment's deallocation. Its second pointer is set to */ +/* NULL to indicate that it is not allocated. (Its first pointer is used */ +/* for the stack of dead items.) Its third pointer (its first vertex) */ +/* is set to NULL in case a `badsubseg' structure points to it. */ + +#define deadsubseg(sub) ((sub)[1] == (subseg)NULL) + +#define killsubseg(sub) \ + (sub)[1] = (subseg)NULL; \ + (sub)[2] = (subseg)NULL + +/********* Primitives for interacting triangles and subsegments *********/ +/* */ +/* */ + +/* tspivot() finds a subsegment abutting a triangle. */ + +#define tspivot(otri, osub) \ + sptr = (subseg)(otri).tri[6 + (otri).orient]; \ + sdecode(sptr, osub) + +/* stpivot() finds a triangle abutting a subsegment. It requires that the */ +/* variable `ptr' of type `triangle' be defined. */ + +#define stpivot(osub, otri) \ + ptr = (triangle)(osub).ss[6 + (osub).ssorient]; \ + decode(ptr, otri) + +/* Bond a triangle to a subsegment. */ + +#define tsbond(otri, osub) \ + (otri).tri[6 + (otri).orient] = (triangle)sencode(osub); \ + (osub).ss[6 + (osub).ssorient] = (subseg)encode(otri) + +/* Dissolve a bond (from the triangle side). */ + +#define tsdissolve(otri) (otri).tri[6 + (otri).orient] = (triangle)m->dummysub + +/* Dissolve a bond (from the subsegment side). */ + +#define stdissolve(osub) (osub).ss[6 + (osub).ssorient] = (subseg)m->dummytri + +/********* Primitives for vertices *********/ +/* */ +/* */ + +#define vertexmark(vx) ((int *)(vx))[m->vertexmarkindex] + +#define setvertexmark(vx, value) ((int *)(vx))[m->vertexmarkindex] = value + +#define vertextype(vx) ((int *)(vx))[m->vertexmarkindex + 1] + +#define setvertextype(vx, value) ((int *)(vx))[m->vertexmarkindex + 1] = value + +#define vertex2tri(vx) ((triangle *)(vx))[m->vertex2triindex] + +#define setvertex2tri(vx, value) ((triangle *)(vx))[m->vertex2triindex] = value + +/** **/ +/** **/ +/********* Mesh manipulation primitives end here *********/ + +/********* User-defined triangle evaluation routine begins here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* triunsuitable() Determine if a triangle is unsuitable, and thus must */ +/* be further refined. */ +/* */ +/* You may write your own procedure that decides whether or not a selected */ +/* triangle is too big (and needs to be refined). There are two ways to do */ +/* this. */ +/* */ +/* (1) Modify the procedure `triunsuitable' below, then recompile */ +/* Triangle. */ +/* */ +/* (2) Define the symbol EXTERNAL_TEST (either by adding the definition */ +/* to this file, or by using the appropriate compiler switch). This way, */ +/* you can compile triangle.c separately from your test. Write your own */ +/* `triunsuitable' procedure in a separate C file (using the same prototype */ +/* as below). Compile it and link the object code with triangle.o. */ +/* */ +/* This procedure returns 1 if the triangle is too large and should be */ +/* refined; 0 otherwise. */ +/* */ +/*****************************************************************************/ + +#ifdef EXTERNAL_TEST + +int triunsuitable(); + +#else /* not EXTERNAL_TEST */ + +#ifdef ANSI_DECLARATORS +int triunsuitable(vertex triorg, vertex tridest, vertex triapex, REAL area) +#else /* not ANSI_DECLARATORS */ +int triunsuitable(triorg, tridest, triapex, area) +vertex triorg; /* The triangle's origin vertex. */ +vertex tridest; /* The triangle's destination vertex. */ +vertex triapex; /* The triangle's apex vertex. */ +REAL area; /* The area of the triangle. */ +#endif /* not ANSI_DECLARATORS */ + +{ + REAL dxoa, dxda, dxod; + REAL dyoa, dyda, dyod; + REAL oalen, dalen, odlen; + REAL maxlen; + + dxoa = triorg[0] - triapex[0]; + dyoa = triorg[1] - triapex[1]; + dxda = tridest[0] - triapex[0]; + dyda = tridest[1] - triapex[1]; + dxod = triorg[0] - tridest[0]; + dyod = triorg[1] - tridest[1]; + /* Find the squares of the lengths of the triangle's three edges. */ + oalen = dxoa * dxoa + dyoa * dyoa; + dalen = dxda * dxda + dyda * dyda; + odlen = dxod * dxod + dyod * dyod; + /* Find the square of the length of the longest edge. */ + maxlen = (dalen > oalen) ? dalen : oalen; + maxlen = (odlen > maxlen) ? odlen : maxlen; + + if (maxlen > 0.05 * (triorg[0] * triorg[0] + triorg[1] * triorg[1]) + 0.02) { + return 1; + } else { + return 0; + } +} + +#endif /* not EXTERNAL_TEST */ + +/** **/ +/** **/ +/********* User-defined triangle evaluation routine ends here *********/ + +/********* Memory allocation and program exit wrappers begin here *********/ +/** **/ +/** **/ + +#ifdef ANSI_DECLARATORS +void triexit(int status) +#else /* not ANSI_DECLARATORS */ +void triexit(status) int status; +#endif /* not ANSI_DECLARATORS */ + +{ + exit(status); +} + +#ifdef ANSI_DECLARATORS +VOID *trimalloc(int size) +#else /* not ANSI_DECLARATORS */ +VOID *trimalloc(size) +int size; +#endif /* not ANSI_DECLARATORS */ + +{ + VOID *memptr; + + memptr = (VOID *)malloc((unsigned int)size); + if (memptr == (VOID *)NULL) { + printf("Error: Out of memory.\n"); + triexit(1); + } + return (memptr); +} + +#ifdef ANSI_DECLARATORS +void trifree(VOID *memptr) +#else /* not ANSI_DECLARATORS */ +void trifree(memptr) VOID *memptr; +#endif /* not ANSI_DECLARATORS */ + +{ + free(memptr); +} + +/** **/ +/** **/ +/********* Memory allocation and program exit wrappers end here *********/ + +/********* User interaction routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* syntax() Print list of command line switches. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +void syntax() { +#ifdef CDT_ONLY +#ifdef REDUCED + printf("triangle [-pAcjevngBPNEIOXzo_lQVh] input_file\n"); +#else /* not REDUCED */ + printf("triangle [-pAcjevngBPNEIOXzo_iFlCQVh] input_file\n"); +#endif /* not REDUCED */ +#else /* not CDT_ONLY */ +#ifdef REDUCED + printf("triangle [-prq__a__uAcDjevngBPNEIOXzo_YS__lQVh] input_file\n"); +#else /* not REDUCED */ + printf("triangle [-prq__a__uAcDjevngBPNEIOXzo_YS__iFlsCQVh] input_file\n"); +#endif /* not REDUCED */ +#endif /* not CDT_ONLY */ + + printf(" -p Triangulates a Planar Straight Line Graph (.poly file).\n"); +#ifndef CDT_ONLY + printf(" -r Refines a previously generated mesh.\n"); + printf( + " -q Quality mesh generation. A minimum angle may be specified.\n"); + printf(" -a Applies a maximum triangle area constraint.\n"); + printf(" -u Applies a user-defined triangle constraint.\n"); +#endif /* not CDT_ONLY */ + printf( + " -A Applies attributes to identify triangles in certain regions.\n"); + printf(" -c Encloses the convex hull with segments.\n"); +#ifndef CDT_ONLY + printf(" -D Conforming Delaunay: all triangles are truly Delaunay.\n"); +#endif /* not CDT_ONLY */ + /* + printf(" -w Weighted Delaunay triangulation.\n"); + printf(" -W Regular triangulation (lower hull of a height field).\n"); + */ + printf(" -j Jettison unused vertices from output .node file.\n"); + printf(" -e Generates an edge list.\n"); + printf(" -v Generates a Voronoi diagram.\n"); + printf(" -n Generates a list of triangle neighbors.\n"); + printf(" -g Generates an .off file for Geomview.\n"); + printf(" -B Suppresses output of boundary information.\n"); + printf(" -P Suppresses output of .poly file.\n"); + printf(" -N Suppresses output of .node file.\n"); + printf(" -E Suppresses output of .ele file.\n"); + printf(" -I Suppresses mesh iteration numbers.\n"); + printf(" -O Ignores holes in .poly file.\n"); + printf(" -X Suppresses use of exact arithmetic.\n"); + printf(" -z Numbers all items starting from zero (rather than one).\n"); + printf(" -o2 Generates second-order subparametric elements.\n"); +#ifndef CDT_ONLY + printf(" -Y Suppresses boundary segment splitting.\n"); + printf(" -S Specifies maximum number of added Steiner points.\n"); +#endif /* not CDT_ONLY */ +#ifndef REDUCED + printf(" -i Uses incremental method, rather than divide-and-conquer.\n"); + printf(" -F Uses Fortune's sweepline algorithm, rather than d-and-c.\n"); +#endif /* not REDUCED */ + printf(" -l Uses vertical cuts only, rather than alternating cuts.\n"); +#ifndef REDUCED +#ifndef CDT_ONLY + printf(" -s Force segments into mesh by splitting (instead of using " + "CDT).\n"); +#endif /* not CDT_ONLY */ + printf(" -C Check consistency of final mesh.\n"); +#endif /* not REDUCED */ + printf(" -Q Quiet: No terminal output except errors.\n"); + printf(" -V Verbose: Detailed information on what I'm doing.\n"); + printf(" -h Help: Detailed instructions for Triangle.\n"); + triexit(0); +} + +#endif /* not TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* info() Print out complete instructions. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +void info() { + printf("Triangle\n"); + printf( + "A Two-Dimensional Quality Mesh Generator and Delaunay Triangulator.\n"); + printf("Version 1.6\n\n"); + printf("Copyright 1993, 1995, 1997, 1998, 2002, 2005 Jonathan Richard " + "Shewchuk\n"); + printf("2360 Woolsey #H / Berkeley, California 94705-1927\n"); + printf("Bugs/comments to jrs@cs.berkeley.edu\n"); + printf("Created as part of the Quake project (tools for earthquake " + "simulation).\n"); + printf("Supported in part by NSF Grant CMS-9318163 and an NSERC 1967 " + "Scholarship.\n"); + printf("There is no warranty whatsoever. Use at your own risk.\n"); +#ifdef SINGLE + printf("This executable is compiled for single precision arithmetic.\n\n\n"); +#else /* not SINGLE */ + printf("This executable is compiled for double precision arithmetic.\n\n\n"); +#endif /* not SINGLE */ + printf("Triangle generates exact Delaunay triangulations, constrained " + "Delaunay\n"); + printf("triangulations, conforming Delaunay triangulations, Voronoi " + "diagrams, and\n"); + printf("high-quality triangular meshes. The latter can be generated with no " + "small\n"); + printf("or large angles, and are thus suitable for finite element analysis. " + "If no\n"); + printf("command line switch is specified, your .node input file is read, and " + "the\n"); + printf("Delaunay triangulation is returned in .node and .ele output files. " + "The\n"); + printf("command syntax is:\n\n"); + printf("triangle [-prq__a__uAcDjevngBPNEIOXzo_YS__iFlsCQVh] input_file\n\n"); + printf("Underscores indicate that numbers may optionally follow certain " + "switches.\n"); + printf( + "Do not leave any space between a switch and its numeric parameter.\n"); + printf("input_file must be a file with extension .node, or extension .poly " + "if the\n"); + printf("-p switch is used. If -r is used, you must supply .node and .ele " + "files,\n"); + printf("and possibly a .poly file and an .area file as well. The formats of " + "these\n"); + printf("files are described below.\n\n"); + printf("Command Line Switches:\n\n"); + printf(" -p Reads a Planar Straight Line Graph (.poly file), which can " + "specify\n"); + printf(" vertices, segments, holes, regional attributes, and regional " + "area\n"); + printf(" constraints. Generates a constrained Delaunay triangulation " + "(CDT)\n"); + printf(" fitting the input; or, if -s, -q, -a, or -u is used, a " + "conforming\n"); + printf(" constrained Delaunay triangulation (CCDT). If you want a " + "truly\n"); + printf(" Delaunay (not just constrained Delaunay) triangulation, use " + "-D as\n"); + printf(" well. When -p is not used, Triangle reads a .node file by " + "default.\n"); + printf(" -r Refines a previously generated mesh. The mesh is read from " + "a .node\n"); + printf(" file and an .ele file. If -p is also used, a .poly file is " + "read\n"); + printf(" and used to constrain segments in the mesh. If -a is also " + "used\n"); + printf(" (with no number following), an .area file is read and used " + "to\n"); + printf(" impose area constraints on the mesh. Further details on " + "refinement\n"); + printf(" appear below.\n"); + printf(" -q Quality mesh generation by Delaunay refinement (a hybrid of " + "Paul\n"); + printf(" Chew's and Jim Ruppert's algorithms). Adds vertices to the " + "mesh to\n"); + printf( + " ensure that all angles are between 20 and 140 degrees. An\n"); + printf(" alternative bound on the minimum angle, replacing 20 " + "degrees, may\n"); + printf(" be specified after the `q'. The specified angle may include " + "a\n"); + printf(" decimal point, but not exponential notation. Note that a " + "bound of\n"); + printf( + " theta degrees on the smallest angle also implies a bound of\n"); + printf(" (180 - 2 theta) on the largest angle. If the minimum angle " + "is 28.6\n"); + printf( + " degrees or smaller, Triangle is mathematically guaranteed to\n"); + printf(" terminate (assuming infinite precision arithmetic--Triangle " + "may\n"); + printf(" fail to terminate if you run out of precision). In " + "practice,\n"); + printf(" Triangle often succeeds for minimum angles up to 34 degrees. " + " For\n"); + printf(" some meshes, however, you might need to reduce the minimum " + "angle to\n"); + printf( + " avoid problems associated with insufficient floating-point\n"); + printf(" precision.\n"); + printf(" -a Imposes a maximum triangle area. If a number follows the " + "`a', no\n"); + printf(" triangle is generated whose area is larger than that number. " + " If no\n"); + printf(" number is specified, an .area file (if -r is used) or .poly " + "file\n"); + printf(" (if -r is not used) specifies a set of maximum area " + "constraints.\n"); + printf( + " An .area file contains a separate area constraint for each\n"); + printf(" triangle, and is useful for refining a finite element mesh " + "based on\n"); + printf(" a posteriori error estimates. A .poly file can optionally " + "contain\n"); + printf( + " an area constraint for each segment-bounded region, thereby\n"); + printf(" controlling triangle densities in a first triangulation of a " + "PSLG.\n"); + printf(" You can impose both a fixed area constraint and a varying " + "area\n"); + printf(" constraint by invoking the -a switch twice, once with and " + "once\n"); + printf(" without a number following. Each area specified may include " + "a\n"); + printf(" decimal point.\n"); + printf(" -u Imposes a user-defined constraint on triangle size. There " + "are two\n"); + printf(" ways to use this feature. One is to edit the " + "triunsuitable()\n"); + printf(" procedure in triangle.c to encode any constraint you like, " + "then\n"); + printf(" recompile Triangle. The other is to compile triangle.c with " + "the\n"); + printf(" EXTERNAL_TEST symbol set (compiler switch -DEXTERNAL_TEST), " + "then\n"); + printf(" link Triangle with a separate object file that implements\n"); + printf(" triunsuitable(). In either case, the -u switch causes the " + "user-\n"); + printf(" defined test to be applied to every triangle.\n"); + printf(" -A Assigns an additional floating-point attribute to each " + "triangle\n"); + printf(" that identifies what segment-bounded region each triangle " + "belongs\n"); + printf(" to. Attributes are assigned to regions by the .poly file. " + "If a\n"); + printf(" region is not explicitly marked by the .poly file, triangles " + "in\n"); + printf(" that region are assigned an attribute of zero. The -A " + "switch has\n"); + printf(" an effect only when the -p switch is used and the -r switch " + "is not.\n"); + printf(" -c Creates segments on the convex hull of the triangulation. " + "If you\n"); + printf(" are triangulating a vertex set, this switch causes a .poly " + "file to\n"); + printf(" be written, containing all edges of the convex hull. If you " + "are\n"); + printf(" triangulating a PSLG, this switch specifies that the whole " + "convex\n"); + printf( + " hull of the PSLG should be triangulated, regardless of what\n"); + printf( + " segments the PSLG has. If you do not use this switch when\n"); + printf(" triangulating a PSLG, Triangle assumes that you have " + "identified the\n"); + printf(" region to be triangulated by surrounding it with segments of " + "the\n"); + printf(" input PSLG. Beware: if you are not careful, this switch " + "can cause\n"); + printf(" the introduction of an extremely thin angle between a PSLG " + "segment\n"); + printf(" and a convex hull segment, which can cause overrefinement " + "(and\n"); + printf(" possibly failure if Triangle runs out of precision). If you " + "are\n"); + printf(" refining a mesh, the -c switch works differently: it causes " + "a\n"); + printf(" .poly file to be written containing the boundary edges of " + "the mesh\n"); + printf(" (useful if no .poly file was read).\n"); + printf(" -D Conforming Delaunay triangulation: use this switch if you " + "want to\n"); + printf(" ensure that all the triangles in the mesh are Delaunay, and " + "not\n"); + printf(" merely constrained Delaunay; or if you want to ensure that " + "all the\n"); + printf(" Voronoi vertices lie within the triangulation. (Some finite " + "volume\n"); + printf(" methods have this requirement.) This switch invokes " + "Ruppert's\n"); + printf(" original algorithm, which splits every subsegment whose " + "diametral\n"); + printf(" circle is encroached. It usually increases the number of " + "vertices\n"); + printf(" and triangles.\n"); + printf(" -j Jettisons vertices that are not part of the final " + "triangulation\n"); + printf( + " from the output .node file. By default, Triangle copies all\n"); + printf(" vertices in the input .node file to the output .node file, " + "in the\n"); + printf(" same order, so their indices do not change. The -j switch " + "prevents\n"); + printf(" duplicated input vertices, or vertices `eaten' by holes, " + "from\n"); + printf(" appearing in the output .node file. Thus, if two input " + "vertices\n"); + printf(" have exactly the same coordinates, only the first appears in " + "the\n"); + printf(" output. If any vertices are jettisoned, the vertex " + "numbering in\n"); + printf(" the output .node file differs from that of the input .node " + "file.\n"); + printf(" -e Outputs (to an .edge file) a list of edges of the " + "triangulation.\n"); + printf(" -v Outputs the Voronoi diagram associated with the " + "triangulation.\n"); + printf(" Does not attempt to detect degeneracies, so some Voronoi " + "vertices\n"); + printf(" may be duplicated. See the discussion of Voronoi diagrams " + "below.\n"); + printf(" -n Outputs (to a .neigh file) a list of triangles neighboring " + "each\n"); + printf(" triangle.\n"); + printf(" -g Outputs the mesh to an Object File Format (.off) file, " + "suitable for\n"); + printf(" viewing with the Geometry Center's Geomview package.\n"); + printf(" -B No boundary markers in the output .node, .poly, and .edge " + "output\n"); + printf(" files. See the detailed discussion of boundary markers " + "below.\n"); + printf(" -P No output .poly file. Saves disk space, but you lose the " + "ability\n"); + printf(" to maintain constraining segments on later refinements of " + "the mesh.\n"); + printf(" -N No output .node file.\n"); + printf(" -E No output .ele file.\n"); + printf(" -I No iteration numbers. Suppresses the output of .node and " + ".poly\n"); + printf(" files, so your input files won't be overwritten. (If your " + "input is\n"); + printf(" a .poly file only, a .node file is written.) Cannot be used " + "with\n"); + printf(" the -r switch, because that would overwrite your input .ele " + "file.\n"); + printf(" Shouldn't be used with the -q, -a, -u, or -s switch if you " + "are\n"); + printf(" using a .node file for input, because no .node file is " + "written, so\n"); + printf(" there is no record of any added Steiner points.\n"); + printf(" -O No holes. Ignores the holes in the .poly file.\n"); + printf(" -X No exact arithmetic. Normally, Triangle uses exact " + "floating-point\n"); + printf(" arithmetic for certain tests if it thinks the inexact tests " + "are not\n"); + printf(" accurate enough. Exact arithmetic ensures the robustness of " + "the\n"); + printf(" triangulation algorithms, despite floating-point roundoff " + "error.\n"); + printf( + " Disabling exact arithmetic with the -X switch causes a small\n"); + printf(" improvement in speed and creates the possibility that " + "Triangle will\n"); + printf(" fail to produce a valid mesh. Not recommended.\n"); + printf(" -z Numbers all items starting from zero (rather than one). " + "Note that\n"); + printf(" this switch is normally overridden by the value used to " + "number the\n"); + printf(" first vertex of the input .node or .poly file. However, " + "this\n"); + printf( + " switch is useful when calling Triangle from another program.\n"); + printf(" -o2 Generates second-order subparametric elements with six nodes " + "each.\n"); + printf(" -Y No new vertices on the boundary. This switch is useful when " + "the\n"); + printf( + " mesh boundary must be preserved so that it conforms to some\n"); + printf(" adjacent mesh. Be forewarned that you will probably " + "sacrifice much\n"); + printf(" of the quality of the mesh; Triangle will try, but the " + "resulting\n"); + printf(" mesh may contain poorly shaped triangles. Works well if all " + "the\n"); + printf(" boundary vertices are closely spaced. Specify this switch " + "twice\n"); + printf( + " (`-YY') to prevent all segment splitting, including internal\n"); + printf(" boundaries.\n"); + printf(" -S Specifies the maximum number of Steiner points (vertices " + "that are\n"); + printf(" not in the input, but are added to meet the constraints on " + "minimum\n"); + printf(" angle and maximum area). The default is to allow an " + "unlimited\n"); + printf( + " number. If you specify this switch with no number after it,\n"); + printf(" the limit is set to zero. Triangle always adds vertices at " + "segment\n"); + printf(" intersections, even if it needs to use more vertices than " + "the limit\n"); + printf(" you set. When Triangle inserts segments by splitting (-s), " + "it\n"); + printf(" always adds enough vertices to ensure that all the segments " + "of the\n"); + printf(" PLSG are recovered, ignoring the limit if necessary.\n"); + printf(" -i Uses an incremental rather than a divide-and-conquer " + "algorithm to\n"); + printf(" construct a Delaunay triangulation. Try it if the " + "divide-and-\n"); + printf(" conquer algorithm fails.\n"); + printf(" -F Uses Steven Fortune's sweepline algorithm to construct a " + "Delaunay\n"); + printf(" triangulation. Warning: does not use exact arithmetic for " + "all\n"); + printf(" calculations. An exact result is not guaranteed.\n"); + printf(" -l Uses only vertical cuts in the divide-and-conquer algorithm. " + " By\n"); + printf(" default, Triangle alternates between vertical and horizontal " + "cuts,\n"); + printf(" which usually improve the speed except with vertex sets that " + "are\n"); + printf(" small or short and wide. This switch is primarily of " + "theoretical\n"); + printf(" interest.\n"); + printf(" -s Specifies that segments should be forced into the " + "triangulation by\n"); + printf(" recursively splitting them at their midpoints, rather than " + "by\n"); + printf(" generating a constrained Delaunay triangulation. Segment " + "splitting\n"); + printf(" is true to Ruppert's original algorithm, but can create " + "needlessly\n"); + printf(" small triangles. This switch is primarily of theoretical " + "interest.\n"); + printf(" -C Check the consistency of the final mesh. Uses exact " + "arithmetic for\n"); + printf(" checking, even if the -X switch is used. Useful if you " + "suspect\n"); + printf(" Triangle is buggy.\n"); + printf(" -Q Quiet: Suppresses all explanation of what Triangle is " + "doing,\n"); + printf(" unless an error occurs.\n"); + printf(" -V Verbose: Gives detailed information about what Triangle is " + "doing.\n"); + printf( + " Add more `V's for increasing amount of detail. `-V' is most\n"); + printf(" useful; itgives information on algorithmic progress and much " + "more\n"); + printf(" detailed statistics. `-VV' gives vertex-by-vertex details, " + "and\n"); + printf(" prints so much that Triangle runs much more slowly. `-VVVV' " + "gives\n"); + printf(" information only a debugger could love.\n"); + printf(" -h Help: Displays these instructions.\n"); + printf("\n"); + printf("Definitions:\n"); + printf("\n"); + printf( + " A Delaunay triangulation of a vertex set is a triangulation whose\n"); + printf(" vertices are the vertex set, that covers the convex hull of the " + "vertex\n"); + printf(" set. A Delaunay triangulation has the property that no vertex " + "lies\n"); + printf(" inside the circumscribing circle (circle that passes through all " + "three\n"); + printf(" vertices) of any triangle in the triangulation.\n\n"); + printf(" A Voronoi diagram of a vertex set is a subdivision of the plane " + "into\n"); + printf(" polygonal cells (some of which may be unbounded, meaning " + "infinitely\n"); + printf(" large), where each cell is the set of points in the plane that are " + "closer\n"); + printf(" to some input vertex than to any other input vertex. The Voronoi " + "diagram\n"); + printf(" is a geometric dual of the Delaunay triangulation.\n\n"); + printf(" A Planar Straight Line Graph (PSLG) is a set of vertices and " + "segments.\n"); + printf(" Segments are simply edges, whose endpoints are all vertices in the " + "PSLG.\n"); + printf(" Segments may intersect each other only at their endpoints. The " + "file\n"); + printf(" format for PSLGs (.poly files) is described below.\n\n"); + printf(" A constrained Delaunay triangulation (CDT) of a PSLG is similar to " + "a\n"); + printf(" Delaunay triangulation, but each PSLG segment is present as a " + "single edge\n"); + printf( + " of the CDT. (A constrained Delaunay triangulation is not truly a\n"); + printf( + " Delaunay triangulation, because some of its triangles might not be\n"); + printf(" Delaunay.) By definition, a CDT does not have any vertices other " + "than\n"); + printf(" those specified in the input PSLG. Depending on context, a CDT " + "might\n"); + printf(" cover the convex hull of the PSLG, or it might cover only a " + "segment-\n"); + printf(" bounded region (e.g. a polygon).\n\n"); + printf(" A conforming Delaunay triangulation of a PSLG is a triangulation " + "in which\n"); + printf(" each triangle is truly Delaunay, and each PSLG segment is " + "represented by\n"); + printf(" a linear contiguous sequence of edges of the triangulation. New " + "vertices\n"); + printf(" (not part of the PSLG) may appear, and each input segment may have " + "been\n"); + printf(" subdivided into shorter edges (subsegments) by these additional " + "vertices.\n"); + printf( + " The new vertices are frequently necessary to maintain the Delaunay\n"); + printf(" property while ensuring that every segment is represented.\n\n"); + printf(" A conforming constrained Delaunay triangulation (CCDT) of a PSLG " + "is a\n"); + printf(" triangulation of a PSLG whose triangles are constrained Delaunay. " + "New\n"); + printf(" vertices may appear, and input segments may be subdivided into\n"); + printf(" subsegments, but not to guarantee that segments are respected; " + "rather, to\n"); + printf(" improve the quality of the triangles. The high-quality meshes " + "produced\n"); + printf(" by the -q switch are usually CCDTs, but can be made conforming " + "Delaunay\n"); + printf(" with the -D switch.\n\n"); + printf("File Formats:\n\n"); + printf(" All files may contain comments prefixed by the character '#'. " + "Vertices,\n"); + printf(" triangles, edges, holes, and maximum area constraints must be " + "numbered\n"); + printf(" consecutively, starting from either 1 or 0. Whichever you choose, " + "all\n"); + printf(" input files must be consistent; if the vertices are numbered from " + "1, so\n"); + printf(" must be all other objects. Triangle automatically detects your " + "choice\n"); + printf(" while reading the .node (or .poly) file. (When calling Triangle " + "from\n"); + printf(" another program, use the -z switch if you wish to number objects " + "from\n"); + printf(" zero.) Examples of these file formats are given below.\n\n"); + printf(" .node files:\n"); + printf(" First line: <# of vertices> <# of " + "attributes>\n"); + printf(" <# of boundary markers (0 " + "or 1)>\n"); + printf(" Remaining lines: [attributes] [boundary " + "marker]\n"); + printf("\n"); + printf(" The attributes, which are typically floating-point values of " + "physical\n"); + printf(" quantities (such as mass or conductivity) associated with the " + "nodes of\n"); + printf(" a finite element mesh, are copied unchanged to the output mesh. " + "If -q,\n"); + printf(" -a, -u, -D, or -s is selected, each new Steiner point added to " + "the mesh\n"); + printf(" has attributes assigned to it by linear interpolation.\n\n"); + printf(" If the fourth entry of the first line is `1', the last column of " + "the\n"); + printf(" remainder of the file is assumed to contain boundary markers. " + "Boundary\n"); + printf(" markers are used to identify boundary vertices and vertices " + "resting on\n"); + printf(" PSLG segments; a complete description appears in a section " + "below. The\n"); + printf(" .node file produced by Triangle contains boundary markers in the " + "last\n"); + printf(" column unless they are suppressed by the -B switch.\n\n"); + printf(" .ele files:\n"); + printf(" First line: <# of triangles> <# of " + "attributes>\n"); + printf(" Remaining lines: ... " + "[attributes]\n"); + printf("\n"); + printf(" Nodes are indices into the corresponding .node file. The first " + "three\n"); + printf(" nodes are the corner vertices, and are listed in " + "counterclockwise order\n"); + printf(" around each triangle. (The remaining nodes, if any, depend on " + "the type\n"); + printf(" of finite element used.)\n\n"); + printf(" The attributes are just like those of .node files. Because " + "there is no\n"); + printf(" simple mapping from input to output triangles, Triangle attempts " + "to\n"); + printf(" interpolate attributes, and may cause a lot of diffusion of " + "attributes\n"); + printf(" among nearby triangles as the triangulation is refined. " + "Attributes do\n"); + printf(" not diffuse across segments, so attributes used to identify\n"); + printf(" segment-bounded regions remain intact.\n\n"); + printf(" In .ele files produced by Triangle, each triangular element has " + "three\n"); + printf(" nodes (vertices) unless the -o2 switch is used, in which case\n"); + printf(" subparametric quadratic elements with six nodes each are " + "generated.\n"); + printf(" The first three nodes are the corners in counterclockwise order, " + "and\n"); + printf(" the fourth, fifth, and sixth nodes lie on the midpoints of the " + "edges\n"); + printf(" opposite the first, second, and third vertices, respectively.\n"); + printf("\n"); + printf(" .poly files:\n"); + printf(" First line: <# of vertices> <# of " + "attributes>\n"); + printf(" <# of boundary markers (0 " + "or 1)>\n"); + printf(" Following lines: [attributes] [boundary " + "marker]\n"); + printf(" One line: <# of segments> <# of boundary markers (0 or 1)>\n"); + printf(" Following lines: [boundary " + "marker]\n"); + printf(" One line: <# of holes>\n"); + printf(" Following lines: \n"); + printf(" Optional line: <# of regional attributes and/or area " + "constraints>\n"); + printf(" Optional following lines: \n"); + printf("\n"); + printf(" A .poly file represents a PSLG, as well as some additional " + "information.\n"); + printf(" The first section lists all the vertices, and is identical to " + "the\n"); + printf(" format of .node files. <# of vertices> may be set to zero to " + "indicate\n"); + printf(" that the vertices are listed in a separate .node file; .poly " + "files\n"); + printf(" produced by Triangle always have this format. A vertex set " + "represented\n"); + printf(" this way has the advantage that it may easily be triangulated " + "with or\n"); + printf(" without segments (depending on whether the -p switch is " + "invoked).\n"); + printf("\n"); + printf( + " The second section lists the segments. Segments are edges whose\n"); + printf(" presence in the triangulation is enforced. (Depending on the " + "choice of\n"); + printf( + " switches, segment might be subdivided into smaller edges). Each\n"); + printf(" segment is specified by listing the indices of its two " + "endpoints. This\n"); + printf(" means that you must include its endpoints in the vertex list. " + "Each\n"); + printf(" segment, like each point, may have a boundary marker.\n\n"); + printf(" If -q, -a, -u, and -s are not selected, Triangle produces a " + "constrained\n"); + printf(" Delaunay triangulation (CDT), in which each segment appears as a " + "single\n"); + printf(" edge in the triangulation. If -q, -a, -u, or -s is selected, " + "Triangle\n"); + printf(" produces a conforming constrained Delaunay triangulation (CCDT), " + "in\n"); + printf( + " which segments may be subdivided into smaller edges. If -D is\n"); + printf(" selected, Triangle produces a conforming Delaunay triangulation, " + "so\n"); + printf(" that every triangle is Delaunay, and not just constrained " + "Delaunay.\n"); + printf("\n"); + printf(" The third section lists holes (and concavities, if -c is " + "selected) in\n"); + printf(" the triangulation. Holes are specified by identifying a point " + "inside\n"); + printf(" each hole. After the triangulation is formed, Triangle creates " + "holes\n"); + printf(" by eating triangles, spreading out from each hole point until " + "its\n"); + printf(" progress is blocked by segments in the PSLG. You must be " + "careful to\n"); + printf(" enclose each hole in segments, or your whole triangulation might " + "be\n"); + printf(" eaten away. If the two triangles abutting a segment are eaten, " + "the\n"); + printf( + " segment itself is also eaten. Do not place a hole directly on a\n"); + printf(" segment; if you do, Triangle chooses one side of the segment\n"); + printf(" arbitrarily.\n\n"); + printf(" The optional fourth section lists regional attributes (to be " + "assigned\n"); + printf(" to all triangles in a region) and regional constraints on the " + "maximum\n"); + printf(" triangle area. Triangle reads this section only if the -A " + "switch is\n"); + printf(" used or the -a switch is used without a number following it, and " + "the -r\n"); + printf(" switch is not used. Regional attributes and area constraints " + "are\n"); + printf(" propagated in the same manner as holes: you specify a point for " + "each\n"); + printf( + " attribute and/or constraint, and the attribute and/or constraint\n"); + printf(" affects the whole region (bounded by segments) containing the " + "point.\n"); + printf(" If two values are written on a line after the x and y " + "coordinate, the\n"); + printf(" first such value is assumed to be a regional attribute (but is " + "only\n"); + printf(" applied if the -A switch is selected), and the second value is " + "assumed\n"); + printf(" to be a regional area constraint (but is only applied if the -a " + "switch\n"); + printf(" is selected). You may specify just one value after the " + "coordinates,\n"); + printf(" which can serve as both an attribute and an area constraint, " + "depending\n"); + printf(" on the choice of switches. If you are using the -A and -a " + "switches\n"); + printf(" simultaneously and wish to assign an attribute to some region " + "without\n"); + printf(" imposing an area constraint, use a negative maximum area.\n\n"); + printf(" When a triangulation is created from a .poly file, you must " + "either\n"); + printf(" enclose the entire region to be triangulated in PSLG segments, " + "or\n"); + printf(" use the -c switch, which automatically creates extra segments " + "that\n"); + printf(" enclose the convex hull of the PSLG. If you do not use the -c " + "switch,\n"); + printf(" Triangle eats all triangles that are not enclosed by segments; " + "if you\n"); + printf(" are not careful, your whole triangulation may be eaten away. If " + "you do\n"); + printf(" use the -c switch, you can still produce concavities by the " + "appropriate\n"); + printf( + " placement of holes just inside the boundary of the convex hull.\n"); + printf("\n"); + printf(" An ideal PSLG has no intersecting segments, nor any vertices " + "that lie\n"); + printf(" upon segments (except, of course, the endpoints of each " + "segment). You\n"); + printf(" aren't required to make your .poly files ideal, but you should " + "be aware\n"); + printf(" of what can go wrong. Segment intersections are relatively " + "safe--\n"); + printf(" Triangle calculates the intersection points for you and adds " + "them to\n"); + printf(" the triangulation--as long as your machine's floating-point " + "precision\n"); + printf(" doesn't become a problem. You are tempting the fates if you " + "have three\n"); + printf(" segments that cross at the same location, and expect Triangle to " + "figure\n"); + printf(" out where the intersection point is. Thanks to floating-point " + "roundoff\n"); + printf(" error, Triangle will probably decide that the three segments " + "intersect\n"); + printf(" at three different points, and you will find a minuscule " + "triangle in\n"); + printf(" your output--unless Triangle tries to refine the tiny triangle, " + "uses\n"); + printf(" up the last bit of machine precision, and fails to terminate at " + "all.\n"); + printf(" You're better off putting the intersection point in the input " + "files,\n"); + printf(" and manually breaking up each segment into two. Similarly, if " + "you\n"); + printf(" place a vertex at the middle of a segment, and hope that " + "Triangle will\n"); + printf(" break up the segment at that vertex, you might get lucky. On " + "the other\n"); + printf(" hand, Triangle might decide that the vertex doesn't lie " + "precisely on\n"); + printf(" the segment, and you'll have a needle-sharp triangle in your " + "output--or\n"); + printf(" a lot of tiny triangles if you're generating a quality mesh.\n"); + printf("\n"); + printf(" When Triangle reads a .poly file, it also writes a .poly file, " + "which\n"); + printf( + " includes all the subsegments--the edges that are parts of input\n"); + printf( + " segments. If the -c switch is used, the output .poly file also\n"); + printf(" includes all of the edges on the convex hull. Hence, the output " + ".poly\n"); + printf(" file is useful for finding edges associated with input segments " + "and for\n"); + printf(" setting boundary conditions in finite element simulations. " + "Moreover,\n"); + printf(" you will need the output .poly file if you plan to refine the " + "output\n"); + printf(" mesh, and don't want segments to be missing in later " + "triangulations.\n"); + printf("\n"); + printf(" .area files:\n"); + printf(" First line: <# of triangles>\n"); + printf(" Following lines: \n"); + printf("\n"); + printf(" An .area file associates with each triangle a maximum area that " + "is used\n"); + printf(" for mesh refinement. As with other file formats, every triangle " + "must\n"); + printf(" be represented, and the triangles must be numbered " + "consecutively. A\n"); + printf(" triangle may be left unconstrained by assigning it a negative " + "maximum\n"); + printf(" area.\n\n"); + printf(" .edge files:\n"); + printf(" First line: <# of edges> <# of boundary markers (0 or 1)>\n"); + printf(" Following lines: [boundary " + "marker]\n"); + printf("\n"); + printf(" Endpoints are indices into the corresponding .node file. " + "Triangle can\n"); + printf(" produce .edge files (use the -e switch), but cannot read them. " + "The\n"); + printf(" optional column of boundary markers is suppressed by the -B " + "switch.\n"); + printf("\n"); + printf(" In Voronoi diagrams, one also finds a special kind of edge that " + "is an\n"); + printf(" infinite ray with only one endpoint. For these edges, a " + "different\n"); + printf(" format is used:\n\n"); + printf(" -1 \n\n"); + printf(" The `direction' is a floating-point vector that indicates the " + "direction\n"); + printf(" of the infinite ray.\n\n"); + printf(" .neigh files:\n"); + printf(" First line: <# of triangles> <# of neighbors per triangle " + "(always 3)>\n"); + printf( + " Following lines: \n"); + printf("\n"); + printf(" Neighbors are indices into the corresponding .ele file. An " + "index of -1\n"); + printf(" indicates no neighbor (because the triangle is on an exterior\n"); + printf(" boundary). The first neighbor of triangle i is opposite the " + "first\n"); + printf(" corner of triangle i, and so on.\n\n"); + printf(" Triangle can produce .neigh files (use the -n switch), but " + "cannot read\n"); + printf(" them.\n\n"); + printf("Boundary Markers:\n\n"); + printf(" Boundary markers are tags used mainly to identify which output " + "vertices\n"); + printf(" and edges are associated with which PSLG segment, and to identify " + "which\n"); + printf(" vertices and edges occur on a boundary of the triangulation. A " + "common\n"); + printf(" use is to determine where boundary conditions should be applied to " + "a\n"); + printf(" finite element mesh. You can prevent boundary markers from being " + "written\n"); + printf(" into files produced by Triangle by using the -B switch.\n\n"); + printf(" The boundary marker associated with each segment in an output " + ".poly file\n"); + printf(" and each edge in an output .edge file is chosen as follows:\n"); + printf(" - If an output edge is part or all of a PSLG segment with a " + "nonzero\n"); + printf(" boundary marker, then the edge is assigned the same marker.\n"); + printf( + " - Otherwise, if the edge lies on a boundary of the triangulation\n"); + printf(" (even the boundary of a hole), then the edge is assigned the " + "marker\n"); + printf(" one (1).\n"); + printf(" - Otherwise, the edge is assigned the marker zero (0).\n"); + printf(" The boundary marker associated with each vertex in an output .node " + "file\n"); + printf(" is chosen as follows:\n"); + printf(" - If a vertex is assigned a nonzero boundary marker in the input " + "file,\n"); + printf( + " then it is assigned the same marker in the output .node file.\n"); + printf(" - Otherwise, if the vertex lies on a PSLG segment (even if it is " + "an\n"); + printf(" endpoint of the segment) with a nonzero boundary marker, then " + "the\n"); + printf(" vertex is assigned the same marker. If the vertex lies on " + "several\n"); + printf(" such segments, one of the markers is chosen arbitrarily.\n"); + printf(" - Otherwise, if the vertex occurs on a boundary of the " + "triangulation,\n"); + printf(" then the vertex is assigned the marker one (1).\n"); + printf(" - Otherwise, the vertex is assigned the marker zero (0).\n"); + printf("\n"); + printf(" If you want Triangle to determine for you which vertices and edges " + "are on\n"); + printf(" the boundary, assign them the boundary marker zero (or use no " + "markers at\n"); + printf(" all) in your input files. In the output files, all boundary " + "vertices,\n"); + printf(" edges, and segments will be assigned the value one.\n\n"); + printf("Triangulation Iteration Numbers:\n\n"); + printf( + " Because Triangle can read and refine its own triangulations, input\n"); + printf(" and output files have iteration numbers. For instance, Triangle " + "might\n"); + printf(" read the files mesh.3.node, mesh.3.ele, and mesh.3.poly, refine " + "the\n"); + printf( + " triangulation, and output the files mesh.4.node, mesh.4.ele, and\n"); + printf(" mesh.4.poly. Files with no iteration number are treated as if\n"); + printf(" their iteration number is zero; hence, Triangle might read the " + "file\n"); + printf(" points.node, triangulate it, and produce the files points.1.node " + "and\n"); + printf(" points.1.ele.\n\n"); + printf(" Iteration numbers allow you to create a sequence of successively " + "finer\n"); + printf(" meshes suitable for multigrid methods. They also allow you to " + "produce a\n"); + printf(" sequence of meshes using error estimate-driven mesh refinement.\n"); + printf("\n"); + printf(" If you're not using refinement or quality meshing, and you don't " + "like\n"); + printf(" iteration numbers, use the -I switch to disable them. This switch " + "also\n"); + printf(" disables output of .node and .poly files to prevent your input " + "files from\n"); + printf(" being overwritten. (If the input is a .poly file that contains " + "its own\n"); + printf( + " points, a .node file is written. This can be quite convenient for\n"); + printf(" computing CDTs or quality meshes.)\n\n"); + printf("Examples of How to Use Triangle:\n\n"); + printf(" `triangle dots' reads vertices from dots.node, and writes their " + "Delaunay\n"); + printf(" triangulation to dots.1.node and dots.1.ele. (dots.1.node is " + "identical\n"); + printf(" to dots.node.) `triangle -I dots' writes the triangulation to " + "dots.ele\n"); + printf(" instead. (No additional .node file is needed, so none is " + "written.)\n"); + printf("\n"); + printf(" `triangle -pe object.1' reads a PSLG from object.1.poly (and " + "possibly\n"); + printf(" object.1.node, if the vertices are omitted from object.1.poly) and " + "writes\n"); + printf(" its constrained Delaunay triangulation to object.2.node and " + "object.2.ele.\n"); + printf(" The segments are copied to object.2.poly, and all edges are " + "written to\n"); + printf(" object.2.edge.\n\n"); + printf(" `triangle -pq31.5a.1 object' reads a PSLG from object.poly (and " + "possibly\n"); + printf(" object.node), generates a mesh whose angles are all between 31.5 " + "and 117\n"); + printf(" degrees and whose triangles all have areas of 0.1 or less, and " + "writes the\n"); + printf(" mesh to object.1.node and object.1.ele. Each segment may be " + "broken up\n"); + printf(" into multiple subsegments; these are written to object.1.poly.\n"); + printf("\n"); + printf(" Here is a sample file `box.poly' describing a square with a square " + "hole:\n"); + printf("\n"); + printf(" # A box with eight vertices in 2D, no attributes, one boundary " + "marker.\n"); + printf(" 8 2 0 1\n"); + printf(" # Outer box has these vertices:\n"); + printf(" 1 0 0 0\n"); + printf(" 2 0 3 0\n"); + printf(" 3 3 0 0\n"); + printf(" 4 3 3 33 # A special marker for this vertex.\n"); + printf(" # Inner square has these vertices:\n"); + printf(" 5 1 1 0\n"); + printf(" 6 1 2 0\n"); + printf(" 7 2 1 0\n"); + printf(" 8 2 2 0\n"); + printf(" # Five segments with boundary markers.\n"); + printf(" 5 1\n"); + printf(" 1 1 2 5 # Left side of outer box.\n"); + printf(" # Square hole has these segments:\n"); + printf(" 2 5 7 0\n"); + printf(" 3 7 8 0\n"); + printf(" 4 8 6 10\n"); + printf(" 5 6 5 0\n"); + printf(" # One hole in the middle of the inner square.\n"); + printf(" 1\n"); + printf(" 1 1.5 1.5\n"); + printf("\n"); + printf(" Note that some segments are missing from the outer square, so you " + "must\n"); + printf(" use the `-c' switch. After `triangle -pqc box.poly', here is the " + "output\n"); + printf(" file `box.1.node', with twelve vertices. The last four vertices " + "were\n"); + printf(" added to meet the angle constraint. Vertices 1, 2, and 9 have " + "markers\n"); + printf(" from segment 1. Vertices 6 and 8 have markers from segment 4. " + "All the\n"); + printf(" other vertices but 4 have been marked to indicate that they lie on " + "a\n"); + printf(" boundary.\n\n"); + printf(" 12 2 0 1\n"); + printf(" 1 0 0 5\n"); + printf(" 2 0 3 5\n"); + printf(" 3 3 0 1\n"); + printf(" 4 3 3 33\n"); + printf(" 5 1 1 1\n"); + printf(" 6 1 2 10\n"); + printf(" 7 2 1 1\n"); + printf(" 8 2 2 10\n"); + printf(" 9 0 1.5 5\n"); + printf(" 10 1.5 0 1\n"); + printf(" 11 3 1.5 1\n"); + printf(" 12 1.5 3 1\n"); + printf(" # Generated by triangle -pqc box.poly\n"); + printf("\n"); + printf(" Here is the output file `box.1.ele', with twelve triangles.\n"); + printf("\n"); + printf(" 12 3 0\n"); + printf(" 1 5 6 9\n"); + printf(" 2 10 3 7\n"); + printf(" 3 6 8 12\n"); + printf(" 4 9 1 5\n"); + printf(" 5 6 2 9\n"); + printf(" 6 7 3 11\n"); + printf(" 7 11 4 8\n"); + printf(" 8 7 5 10\n"); + printf(" 9 12 2 6\n"); + printf(" 10 8 7 11\n"); + printf(" 11 5 1 10\n"); + printf(" 12 8 4 12\n"); + printf(" # Generated by triangle -pqc box.poly\n\n"); + printf(" Here is the output file `box.1.poly'. Note that segments have " + "been added\n"); + printf(" to represent the convex hull, and some segments have been " + "subdivided by\n"); + printf(" newly added vertices. Note also that <# of vertices> is set to " + "zero to\n"); + printf(" indicate that the vertices should be read from the .node file.\n"); + printf("\n"); + printf(" 0 2 0 1\n"); + printf(" 12 1\n"); + printf(" 1 1 9 5\n"); + printf(" 2 5 7 1\n"); + printf(" 3 8 7 1\n"); + printf(" 4 6 8 10\n"); + printf(" 5 5 6 1\n"); + printf(" 6 3 10 1\n"); + printf(" 7 4 11 1\n"); + printf(" 8 2 12 1\n"); + printf(" 9 9 2 5\n"); + printf(" 10 10 1 1\n"); + printf(" 11 11 3 1\n"); + printf(" 12 12 4 1\n"); + printf(" 1\n"); + printf(" 1 1.5 1.5\n"); + printf(" # Generated by triangle -pqc box.poly\n"); + printf("\n"); + printf("Refinement and Area Constraints:\n"); + printf("\n"); + printf( + " The -r switch causes a mesh (.node and .ele files) to be read and\n"); + printf(" refined. If the -p switch is also used, a .poly file is read and " + "used to\n"); + printf(" specify edges that are constrained and cannot be eliminated " + "(although\n"); + printf(" they can be subdivided into smaller edges) by the refinement " + "process.\n"); + printf("\n"); + printf(" When you refine a mesh, you generally want to impose tighter " + "constraints.\n"); + printf( + " One way to accomplish this is to use -q with a larger angle, or -a\n"); + printf(" followed by a smaller area than you used to generate the mesh you " + "are\n"); + printf(" refining. Another way to do this is to create an .area file, " + "which\n"); + printf( + " specifies a maximum area for each triangle, and use the -a switch\n"); + printf(" (without a number following). Each triangle's area constraint is " + "applied\n"); + printf( + " to that triangle. Area constraints tend to diffuse as the mesh is\n"); + printf(" refined, so if there are large variations in area constraint " + "between\n"); + printf(" adjacent triangles, you may not get the results you want. In that " + "case,\n"); + printf(" consider instead using the -u switch and writing a C procedure " + "that\n"); + printf(" determines which triangles are too large.\n\n"); + printf(" If you are refining a mesh composed of linear (three-node) " + "elements, the\n"); + printf(" output mesh contains all the nodes present in the input mesh, in " + "the same\n"); + printf(" order, with new nodes added at the end of the .node file. " + "However, the\n"); + printf(" refinement is not hierarchical: there is no guarantee that each " + "output\n"); + printf(" element is contained in a single input element. Often, an output " + "element\n"); + printf(" can overlap two or three input elements, and some input edges are " + "not\n"); + printf(" present in the output mesh. Hence, a sequence of refined meshes " + "forms a\n"); + printf(" hierarchy of nodes, but not a hierarchy of elements. If you " + "refine a\n"); + printf(" mesh of higher-order elements, the hierarchical property applies " + "only to\n"); + printf(" the nodes at the corners of an element; the midpoint nodes on each " + "edge\n"); + printf(" are discarded before the mesh is refined.\n\n"); + printf(" Maximum area constraints in .poly files operate differently from " + "those in\n"); + printf( + " .area files. A maximum area in a .poly file applies to the whole\n"); + printf(" (segment-bounded) region in which a point falls, whereas a maximum " + "area\n"); + printf(" in an .area file applies to only one triangle. Area constraints " + "in .poly\n"); + printf( + " files are used only when a mesh is first generated, whereas area\n"); + printf(" constraints in .area files are used only to refine an existing " + "mesh, and\n"); + printf(" are typically based on a posteriori error estimates resulting from " + "a\n"); + printf(" finite element simulation on that mesh.\n\n"); + printf(" `triangle -rq25 object.1' reads object.1.node and object.1.ele, " + "then\n"); + printf(" refines the triangulation to enforce a 25 degree minimum angle, " + "and then\n"); + printf(" writes the refined triangulation to object.2.node and " + "object.2.ele.\n"); + printf("\n"); + printf(" `triangle -rpaa6.2 z.3' reads z.3.node, z.3.ele, z.3.poly, and " + "z.3.area.\n"); + printf(" After reconstructing the mesh and its subsegments, Triangle " + "refines the\n"); + printf(" mesh so that no triangle has area greater than 6.2, and " + "furthermore the\n"); + printf(" triangles satisfy the maximum area constraints in z.3.area. No " + "angle\n"); + printf(" bound is imposed at all. The output is written to z.4.node, " + "z.4.ele, and\n"); + printf(" z.4.poly.\n\n"); + printf(" The sequence `triangle -qa1 x', `triangle -rqa.3 x.1', `triangle " + "-rqa.1\n"); + printf(" x.2' creates a sequence of successively finer meshes x.1, x.2, and " + "x.3,\n"); + printf(" suitable for multigrid.\n\n"); + printf("Convex Hulls and Mesh Boundaries:\n\n"); + printf(" If the input is a vertex set (not a PSLG), Triangle produces its " + "convex\n"); + printf(" hull as a by-product in the output .poly file if you use the -c " + "switch.\n"); + printf(" There are faster algorithms for finding a two-dimensional convex " + "hull\n"); + printf(" than triangulation, of course, but this one comes for free.\n\n"); + printf(" If the input is an unconstrained mesh (you are using the -r switch " + "but\n"); + printf( + " not the -p switch), Triangle produces a list of its boundary edges\n"); + printf(" (including hole boundaries) as a by-product when you use the -c " + "switch.\n"); + printf(" If you also use the -p switch, the output .poly file contains all " + "the\n"); + printf(" segments from the input .poly file as well.\n\n"); + printf("Voronoi Diagrams:\n\n"); + printf(" The -v switch produces a Voronoi diagram, in files suffixed " + ".v.node and\n"); + printf(" .v.edge. For example, `triangle -v points' reads points.node, " + "produces\n"); + printf( + " its Delaunay triangulation in points.1.node and points.1.ele, and\n"); + printf(" produces its Voronoi diagram in points.1.v.node and " + "points.1.v.edge. The\n"); + printf(" .v.node file contains a list of all Voronoi vertices, and the " + ".v.edge\n"); + printf(" file contains a list of all Voronoi edges, some of which may be " + "infinite\n"); + printf(" rays. (The choice of filenames makes it easy to run the set of " + "Voronoi\n"); + printf(" vertices through Triangle, if so desired.)\n\n"); + printf(" This implementation does not use exact arithmetic to compute the " + "Voronoi\n"); + printf(" vertices, and does not check whether neighboring vertices are " + "identical.\n"); + printf( + " Be forewarned that if the Delaunay triangulation is degenerate or\n"); + printf(" near-degenerate, the Voronoi diagram may have duplicate vertices " + "or\n"); + printf(" crossing edges.\n\n"); + printf(" The result is a valid Voronoi diagram only if Triangle's output is " + "a true\n"); + printf(" Delaunay triangulation. The Voronoi output is usually meaningless " + "(and\n"); + printf(" may contain crossing edges and other pathology) if the output is a " + "CDT or\n"); + printf(" CCDT, or if it has holes or concavities. If the triangulated " + "domain is\n"); + printf(" convex and has no holes, you can use -D switch to force Triangle " + "to\n"); + printf(" construct a conforming Delaunay triangulation instead of a CCDT, " + "so the\n"); + printf(" Voronoi diagram will be valid.\n\n"); + printf("Mesh Topology:\n\n"); + printf(" You may wish to know which triangles are adjacent to a certain " + "Delaunay\n"); + printf(" edge in an .edge file, which Voronoi cells are adjacent to a " + "certain\n"); + printf(" Voronoi edge in a .v.edge file, or which Voronoi cells are " + "adjacent to\n"); + printf(" each other. All of this information can be found by " + "cross-referencing\n"); + printf(" output files with the recollection that the Delaunay triangulation " + "and\n"); + printf(" the Voronoi diagram are planar duals.\n\n"); + printf(" Specifically, edge i of an .edge file is the dual of Voronoi edge " + "i of\n"); + printf(" the corresponding .v.edge file, and is rotated 90 degrees " + "counterclock-\n"); + printf(" wise from the Voronoi edge. Triangle j of an .ele file is the " + "dual of\n"); + printf(" vertex j of the corresponding .v.node file. Voronoi cell k is the " + "dual\n"); + printf(" of vertex k of the corresponding .node file.\n\n"); + printf(" Hence, to find the triangles adjacent to a Delaunay edge, look at " + "the\n"); + printf( + " vertices of the corresponding Voronoi edge. If the endpoints of a\n"); + printf(" Voronoi edge are Voronoi vertices 2 and 6 respectively, then " + "triangles 2\n"); + printf(" and 6 adjoin the left and right sides of the corresponding " + "Delaunay edge,\n"); + printf(" respectively. To find the Voronoi cells adjacent to a Voronoi " + "edge, look\n"); + printf(" at the endpoints of the corresponding Delaunay edge. If the " + "endpoints of\n"); + printf(" a Delaunay edge are input vertices 7 and 12, then Voronoi cells 7 " + "and 12\n"); + printf( + " adjoin the right and left sides of the corresponding Voronoi edge,\n"); + printf(" respectively. To find which Voronoi cells are adjacent to each " + "other,\n"); + printf(" just read the list of Delaunay edges.\n\n"); + printf(" Triangle does not write a list of the edges adjoining each Voronoi " + "cell,\n"); + printf(" but you can reconstructed it straightforwardly. For instance, to " + "find\n"); + printf(" all the edges of Voronoi cell 1, search the output .edge file for " + "every\n"); + printf(" edge that has input vertex 1 as an endpoint. The corresponding " + "dual\n"); + printf(" edges in the output .v.edge file form the boundary of Voronoi cell " + "1.\n"); + printf("\n"); + printf( + " For each Voronoi vertex, the .neigh file gives a list of the three\n"); + printf(" Voronoi vertices attached to it. You might find this more " + "convenient\n"); + printf(" than the .v.edge file.\n\n"); + printf("Quadratic Elements:\n\n"); + printf(" Triangle generates meshes with subparametric quadratic elements if " + "the\n"); + printf(" -o2 switch is specified. Quadratic elements have six nodes per " + "element,\n"); + printf(" rather than three. `Subparametric' means that the edges of the " + "triangles\n"); + printf( + " are always straight, so that subparametric quadratic elements are\n"); + printf(" geometrically identical to linear elements, even though they can " + "be used\n"); + printf(" with quadratic interpolating functions. The three extra nodes of " + "an\n"); + printf(" element fall at the midpoints of the three edges, with the fourth, " + "fifth,\n"); + printf(" and sixth nodes appearing opposite the first, second, and third " + "corners\n"); + printf(" respectively.\n\n"); + printf("Domains with Small Angles:\n\n"); + printf(" If two input segments adjoin each other at a small angle, clearly " + "the -q\n"); + printf(" switch cannot remove the small angle. Moreover, Triangle may have " + "no\n"); + printf(" choice but to generate additional triangles whose smallest angles " + "are\n"); + printf(" smaller than the specified bound. However, these triangles only " + "appear\n"); + printf(" between input segments separated by small angles. Moreover, if " + "you\n"); + printf(" request a minimum angle of theta degrees, Triangle will generally " + "produce\n"); + printf(" no angle larger than 180 - 2 theta, even if it is forced to " + "compromise on\n"); + printf(" the minimum angle.\n\n"); + printf("Statistics:\n\n"); + printf(" After generating a mesh, Triangle prints a count of entities in " + "the\n"); + printf(" output mesh, including the number of vertices, triangles, edges, " + "exterior\n"); + printf(" boundary edges (i.e. subsegments on the boundary of the " + "triangulation,\n"); + printf(" including hole boundaries), interior boundary edges (i.e. " + "subsegments of\n"); + printf(" input segments not on the boundary), and total subsegments. If " + "you've\n"); + printf(" forgotten the statistics for an existing mesh, run Triangle on " + "that mesh\n"); + printf(" with the -rNEP switches to read the mesh and print the statistics " + "without\n"); + printf(" writing any files. Use -rpNEP if you've got a .poly file for the " + "mesh.\n"); + printf("\n"); + printf(" The -V switch produces extended statistics, including a rough " + "estimate\n"); + printf(" of memory use, the number of calls to geometric predicates, and\n"); + printf(" histograms of the angles and the aspect ratios of the triangles in " + "the\n"); + printf(" mesh.\n\n"); + printf("Exact Arithmetic:\n\n"); + printf(" Triangle uses adaptive exact arithmetic to perform what " + "computational\n"); + printf(" geometers call the `orientation' and `incircle' tests. If the " + "floating-\n"); + printf(" point arithmetic of your machine conforms to the IEEE 754 standard " + "(as\n"); + printf(" most workstations do), and does not use extended precision " + "internal\n"); + printf( + " floating-point registers, then your output is guaranteed to be an\n"); + printf(" absolutely true Delaunay or constrained Delaunay triangulation, " + "roundoff\n"); + printf(" error notwithstanding. The word `adaptive' implies that these " + "arithmetic\n"); + printf(" routines compute the result only to the precision necessary to " + "guarantee\n"); + printf(" correctness, so they are usually nearly as fast as their " + "approximate\n"); + printf(" counterparts.\n\n"); + printf( + " May CPUs, including Intel x86 processors, have extended precision\n"); + printf(" floating-point registers. These must be reconfigured so their " + "precision\n"); + printf(" is reduced to memory precision. Triangle does this if it is " + "compiled\n"); + printf(" correctly. See the makefile for details.\n\n"); + printf(" The exact tests can be disabled with the -X switch. On most " + "inputs, this\n"); + printf(" switch reduces the computation time by about eight percent--it's " + "not\n"); + printf(" worth the risk. There are rare difficult inputs (having many " + "collinear\n"); + printf(" and cocircular vertices), however, for which the difference in " + "speed\n"); + printf(" could be a factor of two. Be forewarned that these are precisely " + "the\n"); + printf(" inputs most likely to cause errors if you use the -X switch. " + "Hence, the\n"); + printf(" -X switch is not recommended.\n\n"); + printf(" Unfortunately, the exact tests don't solve every numerical " + "problem.\n"); + printf(" Exact arithmetic is not used to compute the positions of new " + "vertices,\n"); + printf(" because the bit complexity of vertex coordinates would grow " + "without\n"); + printf(" bound. Hence, segment intersections aren't computed exactly; in " + "very\n"); + printf(" unusual cases, roundoff error in computing an intersection point " + "might\n"); + printf(" actually lead to an inverted triangle and an invalid " + "triangulation.\n"); + printf(" (This is one reason to specify your own intersection points in " + "your .poly\n"); + printf(" files.) Similarly, exact arithmetic is not used to compute the " + "vertices\n"); + printf(" of the Voronoi diagram.\n\n"); + printf(" Another pair of problems not solved by the exact arithmetic " + "routines is\n"); + printf(" underflow and overflow. If Triangle is compiled for double " + "precision\n"); + printf(" arithmetic, I believe that Triangle's geometric predicates work " + "correctly\n"); + printf(" if the exponent of every input coordinate falls in the range " + "[-148, 201].\n"); + printf(" Underflow can silently prevent the orientation and incircle tests " + "from\n"); + printf(" being performed exactly, while overflow typically causes a " + "floating\n"); + printf(" exception.\n\n"); + printf("Calling Triangle from Another Program:\n\n"); + printf(" Read the file triangle.h for details.\n\n"); + printf("Troubleshooting:\n\n"); + printf(" Please read this section before mailing me bugs.\n\n"); + printf(" `My output mesh has no triangles!'\n\n"); + printf(" If you're using a PSLG, you've probably failed to specify a " + "proper set\n"); + printf(" of bounding segments, or forgotten to use the -c switch. Or you " + "may\n"); + printf(" have placed a hole badly, thereby eating all your triangles. To " + "test\n"); + printf(" these possibilities, try again with the -c and -O switches.\n"); + printf(" Alternatively, all your input vertices may be collinear, in " + "which case\n"); + printf(" you can hardly expect to triangulate them.\n\n"); + printf(" `Triangle doesn't terminate, or just crashes.'\n\n"); + printf(" Bad things can happen when triangles get so small that the " + "distance\n"); + printf(" between their vertices isn't much larger than the precision of " + "your\n"); + printf(" machine's arithmetic. If you've compiled Triangle for " + "single-precision\n"); + printf(" arithmetic, you might do better by recompiling it for " + "double-precision.\n"); + printf(" Then again, you might just have to settle for more lenient " + "constraints\n"); + printf( + " on the minimum angle and the maximum area than you had planned.\n"); + printf("\n"); + printf(" You can minimize precision problems by ensuring that the origin " + "lies\n"); + printf( + " inside your vertex set, or even inside the densest part of your\n"); + printf(" mesh. If you're triangulating an object whose x-coordinates all " + "fall\n"); + printf(" between 6247133 and 6247134, you're not leaving much " + "floating-point\n"); + printf(" precision for Triangle to work with.\n\n"); + printf(" Precision problems can occur covertly if the input PSLG contains " + "two\n"); + printf(" segments that meet (or intersect) at an extremely small angle, " + "or if\n"); + printf(" such an angle is introduced by the -c switch. If you don't " + "realize\n"); + printf( + " that a tiny angle is being formed, you might never discover why\n"); + printf(" Triangle is crashing. To check for this possibility, use the -S " + "switch\n"); + printf(" (with an appropriate limit on the number of Steiner points, " + "found by\n"); + printf(" trial-and-error) to stop Triangle early, and view the output " + ".poly file\n"); + printf(" with Show Me (described below). Look carefully for regions " + "where dense\n"); + printf(" clusters of vertices are forming and for small angles between " + "segments.\n"); + printf(" Zoom in closely, as such segments might look like a single " + "segment from\n"); + printf(" a distance.\n\n"); + printf( + " If some of the input values are too large, Triangle may suffer a\n"); + printf( + " floating exception due to overflow when attempting to perform an\n"); + printf(" orientation or incircle test. (Read the section on exact " + "arithmetic\n"); + printf(" above.) Again, I recommend compiling Triangle for double " + "(rather\n"); + printf(" than single) precision arithmetic.\n\n"); + printf(" Unexpected problems can arise if you use quality meshing (-q, " + "-a, or\n"); + printf(" -u) with an input that is not segment-bounded--that is, if your " + "input\n"); + printf(" is a vertex set, or you're using the -c switch. If the convex " + "hull of\n"); + printf(" your input vertices has collinear vertices on its boundary, an " + "input\n"); + printf(" vertex that you think lies on the convex hull might actually lie " + "just\n"); + printf(" inside the convex hull. If so, the vertex and the nearby convex " + "hull\n"); + printf(" edge form an extremely thin triangle. When Triangle tries to " + "refine\n"); + printf(" the mesh to enforce angle and area constraints, Triangle might " + "generate\n"); + printf(" extremely tiny triangles, or it might fail because of " + "insufficient\n"); + printf(" floating-point precision.\n\n"); + printf(" `The numbering of the output vertices doesn't match the input " + "vertices.'\n"); + printf("\n"); + printf(" You may have had duplicate input vertices, or you may have eaten " + "some\n"); + printf(" of your input vertices with a hole, or by placing them outside " + "the area\n"); + printf(" enclosed by segments. In any case, you can solve the problem by " + "not\n"); + printf(" using the -j switch.\n\n"); + printf(" `Triangle executes without incident, but when I look at the " + "resulting\n"); + printf(" mesh, it has overlapping triangles or other geometric " + "inconsistencies.'\n"); + printf("\n"); + printf(" If you select the -X switch, Triangle occasionally makes " + "mistakes due\n"); + printf(" to floating-point roundoff error. Although these errors are " + "rare,\n"); + printf(" don't use the -X switch. If you still have problems, please " + "report the\n"); + printf(" bug.\n\n"); + printf(" `Triangle executes without incident, but when I look at the " + "resulting\n"); + printf(" Voronoi diagram, it has overlapping edges or other geometric\n"); + printf(" inconsistencies.'\n"); + printf("\n"); + printf(" If your input is a PSLG (-p), you can only expect a meaningful " + "Voronoi\n"); + printf(" diagram if the domain you are triangulating is convex and free " + "of\n"); + printf(" holes, and you use the -D switch to construct a conforming " + "Delaunay\n"); + printf(" triangulation (instead of a CDT or CCDT).\n\n"); + printf(" Strange things can happen if you've taken liberties with your " + "PSLG. Do\n"); + printf(" you have a vertex lying in the middle of a segment? Triangle " + "sometimes\n"); + printf(" copes poorly with that sort of thing. Do you want to lay out a " + "collinear\n"); + printf( + " row of evenly spaced, segment-connected vertices? Have you simply\n"); + printf(" defined one long segment connecting the leftmost vertex to the " + "rightmost\n"); + printf(" vertex, and a bunch of vertices lying along it? This method " + "occasionally\n"); + printf( + " works, especially with horizontal and vertical lines, but often it\n"); + printf(" doesn't, and you'll have to connect each adjacent pair of vertices " + "with a\n"); + printf(" separate segment. If you don't like it, tough.\n\n"); + printf(" Furthermore, if you have segments that intersect other than at " + "their\n"); + printf(" endpoints, try not to let the intersections fall extremely close " + "to PSLG\n"); + printf(" vertices or each other.\n\n"); + printf(" If you have problems refining a triangulation not produced by " + "Triangle:\n"); + printf(" Are you sure the triangulation is geometrically valid? Is it " + "formatted\n"); + printf(" correctly for Triangle? Are the triangles all listed so the first " + "three\n"); + printf(" vertices are their corners in counterclockwise order? Are all of " + "the\n"); + printf(" triangles constrained Delaunay? Triangle's Delaunay refinement " + "algorithm\n"); + printf(" assumes that it starts with a CDT.\n\n"); + printf("Show Me:\n\n"); + printf(" Triangle comes with a separate program named `Show Me', whose " + "primary\n"); + printf(" purpose is to draw meshes on your screen or in PostScript. Its " + "secondary\n"); + printf(" purpose is to check the validity of your input files, and do so " + "more\n"); + printf(" thoroughly than Triangle does. Unlike Triangle, Show Me requires " + "that\n"); + printf(" you have the X Windows system. Sorry, Microsoft Windows users.\n"); + printf("\n"); + printf("Triangle on the Web:\n"); + printf("\n"); + printf(" To see an illustrated version of these instructions, check out\n"); + printf("\n"); + printf(" http://www.cs.cmu.edu/~quake/triangle.html\n"); + printf("\n"); + printf("A Brief Plea:\n"); + printf("\n"); + printf(" If you use Triangle, and especially if you use it to accomplish " + "real\n"); + printf(" work, I would like very much to hear from you. A short letter or " + "email\n"); + printf(" (to jrs@cs.berkeley.edu) describing how you use Triangle will mean " + "a lot\n"); + printf(" to me. The more people I know are using this program, the more " + "easily I\n"); + printf(" can justify spending time on improvements, which in turn will " + "benefit\n"); + printf(" you. Also, I can put you on a list to receive email whenever a " + "new\n"); + printf(" version of Triangle is available.\n\n"); + printf(" If you use a mesh generated by Triangle in a publication, please " + "include\n"); + printf(" an acknowledgment as well. And please spell Triangle with a " + "capital `T'!\n"); + printf( + " If you want to include a citation, use `Jonathan Richard Shewchuk,\n"); + printf( + " ``Triangle: Engineering a 2D Quality Mesh Generator and Delaunay\n"); + printf(" Triangulator,'' in Applied Computational Geometry: Towards " + "Geometric\n"); + printf(" Engineering (Ming C. Lin and Dinesh Manocha, editors), volume 1148 " + "of\n"); + printf( + " Lecture Notes in Computer Science, pages 203-222, Springer-Verlag,\n"); + printf(" Berlin, May 1996. (From the First ACM Workshop on Applied " + "Computational\n"); + printf(" Geometry.)'\n\n"); + printf("Research credit:\n\n"); + printf(" Of course, I can take credit for only a fraction of the ideas that " + "made\n"); + printf(" this mesh generator possible. Triangle owes its existence to the " + "efforts\n"); + printf(" of many fine computational geometers and other researchers, " + "including\n"); + printf(" Marshall Bern, L. Paul Chew, Kenneth L. Clarkson, Boris Delaunay, " + "Rex A.\n"); + printf(" Dwyer, David Eppstein, Steven Fortune, Leonidas J. Guibas, Donald " + "E.\n"); + printf(" Knuth, Charles L. Lawson, Der-Tsai Lee, Gary L. Miller, Ernst P. " + "Mucke,\n"); + printf(" Steven E. Pav, Douglas M. Priest, Jim Ruppert, Isaac Saias, Bruce " + "J.\n"); + printf(" Schachter, Micha Sharir, Peter W. Shor, Daniel D. Sleator, Jorge " + "Stolfi,\n"); + printf(" Robert E. Tarjan, Alper Ungor, Christopher J. Van Wyk, Noel J.\n"); + printf(" Walkington, and Binhai Zhu. See the comments at the beginning of " + "the\n"); + printf(" source code for references.\n\n"); + triexit(0); +} + +#endif /* not TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* internalerror() Ask the user to send me the defective product. Exit. */ +/* */ +/*****************************************************************************/ + +void internalerror() { + printf(" Please report this bug to jrs@cs.berkeley.edu\n"); + printf(" Include the message above, your input data set, and the exact\n"); + printf(" command line you used to run Triangle.\n"); + triexit(1); +} + +/*****************************************************************************/ +/* */ +/* parsecommandline() Read the command line, identify switches, and set */ +/* up options and file names. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void parsecommandline(int argc, char **argv, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void parsecommandline(argc, argv, b) int argc; +char **argv; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ +#ifdef TRILIBRARY +#define STARTINDEX 0 +#else /* not TRILIBRARY */ +#define STARTINDEX 1 + int increment; + int meshnumber; +#endif /* not TRILIBRARY */ + int i, j, k; + char workstring[FILENAMESIZE]; + + b->poly = b->refine = b->quality = 0; + b->vararea = b->fixedarea = b->usertest = 0; + b->regionattrib = b->convex = b->weighted = b->jettison = 0; + b->firstnumber = 1; + b->edgesout = b->voronoi = b->neighbors = b->geomview = 0; + b->nobound = b->nopolywritten = b->nonodewritten = b->noelewritten = 0; + b->noiterationnum = 0; + b->noholes = b->noexact = 0; + b->incremental = b->sweepline = 0; + b->dwyer = 1; + b->splitseg = 0; + b->docheck = 0; + b->nobisect = 0; + b->conformdel = 0; + b->steiner = -1; + b->order = 1; + b->minangle = 0.0; + b->maxarea = -1.0; + b->quiet = b->verbose = 0; +#ifndef TRILIBRARY + b->innodefilename[0] = '\0'; +#endif /* not TRILIBRARY */ + + for (i = STARTINDEX; i < argc; i++) { +#ifndef TRILIBRARY + if (argv[i][0] == '-') { +#endif /* not TRILIBRARY */ + for (j = STARTINDEX; argv[i][j] != '\0'; j++) { + if (argv[i][j] == 'p') { + b->poly = 1; + } +#ifndef CDT_ONLY + if (argv[i][j] == 'r') { + b->refine = 1; + } + if (argv[i][j] == 'q') { + b->quality = 1; + if (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || + (argv[i][j + 1] == '.')) { + k = 0; + while (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || + (argv[i][j + 1] == '.')) { + j++; + workstring[k] = argv[i][j]; + k++; + } + workstring[k] = '\0'; + b->minangle = (REAL)strtod(workstring, (char **)NULL); + } else { + b->minangle = 20.0; + } + } + if (argv[i][j] == 'a') { + b->quality = 1; + if (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || + (argv[i][j + 1] == '.')) { + b->fixedarea = 1; + k = 0; + while (((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) || + (argv[i][j + 1] == '.')) { + j++; + workstring[k] = argv[i][j]; + k++; + } + workstring[k] = '\0'; + b->maxarea = (REAL)strtod(workstring, (char **)NULL); + if (b->maxarea <= 0.0) { + printf("Error: Maximum area must be greater than zero.\n"); + triexit(1); + } + } else { + b->vararea = 1; + } + } + if (argv[i][j] == 'u') { + b->quality = 1; + b->usertest = 1; + } +#endif /* not CDT_ONLY */ + if (argv[i][j] == 'A') { + b->regionattrib = 1; + } + if (argv[i][j] == 'c') { + b->convex = 1; + } + if (argv[i][j] == 'w') { + b->weighted = 1; + } + if (argv[i][j] == 'W') { + b->weighted = 2; + } + if (argv[i][j] == 'j') { + b->jettison = 1; + } + if (argv[i][j] == 'z') { + b->firstnumber = 0; + } + if (argv[i][j] == 'e') { + b->edgesout = 1; + } + if (argv[i][j] == 'v') { + b->voronoi = 1; + } + if (argv[i][j] == 'n') { + b->neighbors = 1; + } + if (argv[i][j] == 'g') { + b->geomview = 1; + } + if (argv[i][j] == 'B') { + b->nobound = 1; + } + if (argv[i][j] == 'P') { + b->nopolywritten = 1; + } + if (argv[i][j] == 'N') { + b->nonodewritten = 1; + } + if (argv[i][j] == 'E') { + b->noelewritten = 1; + } +#ifndef TRILIBRARY + if (argv[i][j] == 'I') { + b->noiterationnum = 1; + } +#endif /* not TRILIBRARY */ + if (argv[i][j] == 'O') { + b->noholes = 1; + } + if (argv[i][j] == 'X') { + b->noexact = 1; + } + if (argv[i][j] == 'o') { + if (argv[i][j + 1] == '2') { + j++; + b->order = 2; + } + } +#ifndef CDT_ONLY + if (argv[i][j] == 'Y') { + b->nobisect++; + } + if (argv[i][j] == 'S') { + b->steiner = 0; + while ((argv[i][j + 1] >= '0') && (argv[i][j + 1] <= '9')) { + j++; + b->steiner = b->steiner * 10 + (int)(argv[i][j] - '0'); + } + } +#endif /* not CDT_ONLY */ +#ifndef REDUCED + if (argv[i][j] == 'i') { + b->incremental = 1; + } + if (argv[i][j] == 'F') { + b->sweepline = 1; + } +#endif /* not REDUCED */ + if (argv[i][j] == 'l') { + b->dwyer = 0; + } +#ifndef REDUCED +#ifndef CDT_ONLY + if (argv[i][j] == 's') { + b->splitseg = 1; + } + if ((argv[i][j] == 'D') || (argv[i][j] == 'L')) { + b->quality = 1; + b->conformdel = 1; + } +#endif /* not CDT_ONLY */ + if (argv[i][j] == 'C') { + b->docheck = 1; + } +#endif /* not REDUCED */ + if (argv[i][j] == 'Q') { + b->quiet = 1; + } + if (argv[i][j] == 'V') { + b->verbose++; + } +#ifndef TRILIBRARY + if ((argv[i][j] == 'h') || (argv[i][j] == 'H') || (argv[i][j] == '?')) { + info(); + } +#endif /* not TRILIBRARY */ + } +#ifndef TRILIBRARY + } else { + strncpy(b->innodefilename, argv[i], FILENAMESIZE - 1); + b->innodefilename[FILENAMESIZE - 1] = '\0'; + } +#endif /* not TRILIBRARY */ + } +#ifndef TRILIBRARY + if (b->innodefilename[0] == '\0') { + syntax(); + } + if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 5], ".node")) { + b->innodefilename[strlen(b->innodefilename) - 5] = '\0'; + } + if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 5], ".poly")) { + b->innodefilename[strlen(b->innodefilename) - 5] = '\0'; + b->poly = 1; + } +#ifndef CDT_ONLY + if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 4], ".ele")) { + b->innodefilename[strlen(b->innodefilename) - 4] = '\0'; + b->refine = 1; + } + if (!strcmp(&b->innodefilename[strlen(b->innodefilename) - 5], ".area")) { + b->innodefilename[strlen(b->innodefilename) - 5] = '\0'; + b->refine = 1; + b->quality = 1; + b->vararea = 1; + } +#endif /* not CDT_ONLY */ +#endif /* not TRILIBRARY */ + b->usesegments = b->poly || b->refine || b->quality || b->convex; + b->goodangle = cos(b->minangle * PI / 180.0); + if (b->goodangle == 1.0) { + b->offconstant = 0.0; + } else { + b->offconstant = 0.475 * sqrt((1.0 + b->goodangle) / (1.0 - b->goodangle)); + } + b->goodangle *= b->goodangle; + if (b->refine && b->noiterationnum) { + printf("Error: You cannot use the -I switch when refining a " + "triangulation.\n"); + triexit(1); + } + /* Be careful not to allocate space for element area constraints that */ + /* will never be assigned any value (other than the default -1.0). */ + if (!b->refine && !b->poly) { + b->vararea = 0; + } + /* Be careful not to add an extra attribute to each element unless the */ + /* input supports it (PSLG in, but not refining a preexisting mesh). */ + if (b->refine || !b->poly) { + b->regionattrib = 0; + } + /* Regular/weighted triangulations are incompatible with PSLGs */ + /* and meshing. */ + if (b->weighted && (b->poly || b->quality)) { + b->weighted = 0; + if (!b->quiet) { + printf("Warning: weighted triangulations (-w, -W) are incompatible\n"); + printf(" with PSLGs (-p) and meshing (-q, -a, -u). Weights ignored.\n"); + } + } + if (b->jettison && b->nonodewritten && !b->quiet) { + printf("Warning: -j and -N switches are somewhat incompatible.\n"); + printf(" If any vertices are jettisoned, you will need the output\n"); + printf(" .node file to reconstruct the new node indices."); + } + +#ifndef TRILIBRARY + strcpy(b->inpolyfilename, b->innodefilename); + strcpy(b->inelefilename, b->innodefilename); + strcpy(b->areafilename, b->innodefilename); + increment = 0; + strcpy(workstring, b->innodefilename); + j = 1; + while (workstring[j] != '\0') { + if ((workstring[j] == '.') && (workstring[j + 1] != '\0')) { + increment = j + 1; + } + j++; + } + meshnumber = 0; + if (increment > 0) { + j = increment; + do { + if ((workstring[j] >= '0') && (workstring[j] <= '9')) { + meshnumber = meshnumber * 10 + (int)(workstring[j] - '0'); + } else { + increment = 0; + } + j++; + } while (workstring[j] != '\0'); + } + if (b->noiterationnum) { + strcpy(b->outnodefilename, b->innodefilename); + strcpy(b->outelefilename, b->innodefilename); + strcpy(b->edgefilename, b->innodefilename); + strcpy(b->vnodefilename, b->innodefilename); + strcpy(b->vedgefilename, b->innodefilename); + strcpy(b->neighborfilename, b->innodefilename); + strcpy(b->offfilename, b->innodefilename); + strcat(b->outnodefilename, ".node"); + strcat(b->outelefilename, ".ele"); + strcat(b->edgefilename, ".edge"); + strcat(b->vnodefilename, ".v.node"); + strcat(b->vedgefilename, ".v.edge"); + strcat(b->neighborfilename, ".neigh"); + strcat(b->offfilename, ".off"); + } else if (increment == 0) { + strcpy(b->outnodefilename, b->innodefilename); + strcpy(b->outpolyfilename, b->innodefilename); + strcpy(b->outelefilename, b->innodefilename); + strcpy(b->edgefilename, b->innodefilename); + strcpy(b->vnodefilename, b->innodefilename); + strcpy(b->vedgefilename, b->innodefilename); + strcpy(b->neighborfilename, b->innodefilename); + strcpy(b->offfilename, b->innodefilename); + strcat(b->outnodefilename, ".1.node"); + strcat(b->outpolyfilename, ".1.poly"); + strcat(b->outelefilename, ".1.ele"); + strcat(b->edgefilename, ".1.edge"); + strcat(b->vnodefilename, ".1.v.node"); + strcat(b->vedgefilename, ".1.v.edge"); + strcat(b->neighborfilename, ".1.neigh"); + strcat(b->offfilename, ".1.off"); + } else { + workstring[increment] = '%'; + workstring[increment + 1] = 'd'; + workstring[increment + 2] = '\0'; + sprintf(b->outnodefilename, workstring, meshnumber + 1); + strcpy(b->outpolyfilename, b->outnodefilename); + strcpy(b->outelefilename, b->outnodefilename); + strcpy(b->edgefilename, b->outnodefilename); + strcpy(b->vnodefilename, b->outnodefilename); + strcpy(b->vedgefilename, b->outnodefilename); + strcpy(b->neighborfilename, b->outnodefilename); + strcpy(b->offfilename, b->outnodefilename); + strcat(b->outnodefilename, ".node"); + strcat(b->outpolyfilename, ".poly"); + strcat(b->outelefilename, ".ele"); + strcat(b->edgefilename, ".edge"); + strcat(b->vnodefilename, ".v.node"); + strcat(b->vedgefilename, ".v.edge"); + strcat(b->neighborfilename, ".neigh"); + strcat(b->offfilename, ".off"); + } + strcat(b->innodefilename, ".node"); + strcat(b->inpolyfilename, ".poly"); + strcat(b->inelefilename, ".ele"); + strcat(b->areafilename, ".area"); +#endif /* not TRILIBRARY */ +} + +/** **/ +/** **/ +/********* User interaction routines begin here *********/ + +/********* Debugging routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* printtriangle() Print out the details of an oriented triangle. */ +/* */ +/* I originally wrote this procedure to simplify debugging; it can be */ +/* called directly from the debugger, and presents information about an */ +/* oriented triangle in digestible form. It's also used when the */ +/* highest level of verbosity (`-VVV') is specified. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void printtriangle(struct mesh *m, struct behavior *b, struct otri *t) +#else /* not ANSI_DECLARATORS */ +void printtriangle(m, b, t) struct mesh *m; +struct behavior *b; +struct otri *t; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri printtri; + struct osub printsh; + vertex printvertex; + + printf("triangle x%lx with orientation %d:\n", (unsigned long)t->tri, + t->orient); + decode(t->tri[0], printtri); + if (printtri.tri == m->dummytri) { + printf(" [0] = Outer space\n"); + } else { + printf(" [0] = x%lx %d\n", (unsigned long)printtri.tri, + printtri.orient); + } + decode(t->tri[1], printtri); + if (printtri.tri == m->dummytri) { + printf(" [1] = Outer space\n"); + } else { + printf(" [1] = x%lx %d\n", (unsigned long)printtri.tri, + printtri.orient); + } + decode(t->tri[2], printtri); + if (printtri.tri == m->dummytri) { + printf(" [2] = Outer space\n"); + } else { + printf(" [2] = x%lx %d\n", (unsigned long)printtri.tri, + printtri.orient); + } + + org(*t, printvertex); + if (printvertex == (vertex)NULL) + printf(" Origin[%d] = NULL\n", (t->orient + 1) % 3 + 3); + else + printf(" Origin[%d] = x%lx (%.12g, %.12g)\n", (t->orient + 1) % 3 + 3, + (unsigned long)printvertex, printvertex[0], printvertex[1]); + dest(*t, printvertex); + if (printvertex == (vertex)NULL) + printf(" Dest [%d] = NULL\n", (t->orient + 2) % 3 + 3); + else + printf(" Dest [%d] = x%lx (%.12g, %.12g)\n", (t->orient + 2) % 3 + 3, + (unsigned long)printvertex, printvertex[0], printvertex[1]); + apex(*t, printvertex); + if (printvertex == (vertex)NULL) + printf(" Apex [%d] = NULL\n", t->orient + 3); + else + printf(" Apex [%d] = x%lx (%.12g, %.12g)\n", t->orient + 3, + (unsigned long)printvertex, printvertex[0], printvertex[1]); + + if (b->usesegments) { + sdecode(t->tri[6], printsh); + if (printsh.ss != m->dummysub) { + printf(" [6] = x%lx %d\n", (unsigned long)printsh.ss, + printsh.ssorient); + } + sdecode(t->tri[7], printsh); + if (printsh.ss != m->dummysub) { + printf(" [7] = x%lx %d\n", (unsigned long)printsh.ss, + printsh.ssorient); + } + sdecode(t->tri[8], printsh); + if (printsh.ss != m->dummysub) { + printf(" [8] = x%lx %d\n", (unsigned long)printsh.ss, + printsh.ssorient); + } + } + + if (b->vararea) { + printf(" Area constraint: %.4g\n", areabound(*t)); + } +} + +/*****************************************************************************/ +/* */ +/* printsubseg() Print out the details of an oriented subsegment. */ +/* */ +/* I originally wrote this procedure to simplify debugging; it can be */ +/* called directly from the debugger, and presents information about an */ +/* oriented subsegment in digestible form. It's also used when the highest */ +/* level of verbosity (`-VVV') is specified. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void printsubseg(struct mesh *m, struct behavior *b, struct osub *s) +#else /* not ANSI_DECLARATORS */ +void printsubseg(m, b, s) struct mesh *m; +struct behavior *b; +struct osub *s; +#endif /* not ANSI_DECLARATORS */ + +{ + struct osub printsh; + struct otri printtri; + vertex printvertex; + + printf("subsegment x%lx with orientation %d and mark %d:\n", + (unsigned long)s->ss, s->ssorient, mark(*s)); + sdecode(s->ss[0], printsh); + if (printsh.ss == m->dummysub) { + printf(" [0] = No subsegment\n"); + } else { + printf(" [0] = x%lx %d\n", (unsigned long)printsh.ss, printsh.ssorient); + } + sdecode(s->ss[1], printsh); + if (printsh.ss == m->dummysub) { + printf(" [1] = No subsegment\n"); + } else { + printf(" [1] = x%lx %d\n", (unsigned long)printsh.ss, printsh.ssorient); + } + + sorg(*s, printvertex); + if (printvertex == (vertex)NULL) + printf(" Origin[%d] = NULL\n", 2 + s->ssorient); + else + printf(" Origin[%d] = x%lx (%.12g, %.12g)\n", 2 + s->ssorient, + (unsigned long)printvertex, printvertex[0], printvertex[1]); + sdest(*s, printvertex); + if (printvertex == (vertex)NULL) + printf(" Dest [%d] = NULL\n", 3 - s->ssorient); + else + printf(" Dest [%d] = x%lx (%.12g, %.12g)\n", 3 - s->ssorient, + (unsigned long)printvertex, printvertex[0], printvertex[1]); + + decode(s->ss[6], printtri); + if (printtri.tri == m->dummytri) { + printf(" [6] = Outer space\n"); + } else { + printf(" [6] = x%lx %d\n", (unsigned long)printtri.tri, + printtri.orient); + } + decode(s->ss[7], printtri); + if (printtri.tri == m->dummytri) { + printf(" [7] = Outer space\n"); + } else { + printf(" [7] = x%lx %d\n", (unsigned long)printtri.tri, + printtri.orient); + } + + segorg(*s, printvertex); + if (printvertex == (vertex)NULL) + printf(" Segment origin[%d] = NULL\n", 4 + s->ssorient); + else + printf(" Segment origin[%d] = x%lx (%.12g, %.12g)\n", 4 + s->ssorient, + (unsigned long)printvertex, printvertex[0], printvertex[1]); + segdest(*s, printvertex); + if (printvertex == (vertex)NULL) + printf(" Segment dest [%d] = NULL\n", 5 - s->ssorient); + else + printf(" Segment dest [%d] = x%lx (%.12g, %.12g)\n", 5 - s->ssorient, + (unsigned long)printvertex, printvertex[0], printvertex[1]); +} + +/** **/ +/** **/ +/********* Debugging routines end here *********/ + +/********* Memory management routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* poolzero() Set all of a pool's fields to zero. */ +/* */ +/* This procedure should never be called on a pool that has any memory */ +/* allocated to it, as that memory would leak. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void poolzero(struct memorypool *pool) +#else /* not ANSI_DECLARATORS */ +void poolzero(pool) struct memorypool *pool; +#endif /* not ANSI_DECLARATORS */ + +{ + pool->firstblock = (VOID **)NULL; + pool->nowblock = (VOID **)NULL; + pool->nextitem = (VOID *)NULL; + pool->deaditemstack = (VOID *)NULL; + pool->pathblock = (VOID **)NULL; + pool->pathitem = (VOID *)NULL; + pool->alignbytes = 0; + pool->itembytes = 0; + pool->itemsperblock = 0; + pool->itemsfirstblock = 0; + pool->items = 0; + pool->maxitems = 0; + pool->unallocateditems = 0; + pool->pathitemsleft = 0; +} + +/*****************************************************************************/ +/* */ +/* poolrestart() Deallocate all items in a pool. */ +/* */ +/* The pool is returned to its starting state, except that no memory is */ +/* freed to the operating system. Rather, the previously allocated blocks */ +/* are ready to be reused. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void poolrestart(struct memorypool *pool) +#else /* not ANSI_DECLARATORS */ +void poolrestart(pool) struct memorypool *pool; +#endif /* not ANSI_DECLARATORS */ + +{ + unsigned long alignptr; + + pool->items = 0; + pool->maxitems = 0; + + /* Set the currently active block. */ + pool->nowblock = pool->firstblock; + /* Find the first item in the pool. Increment by the size of (VOID *). */ + alignptr = (unsigned long)(pool->nowblock + 1); + /* Align the item on an `alignbytes'-byte boundary. */ + pool->nextitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - + (alignptr % (unsigned long)pool->alignbytes)); + /* There are lots of unallocated items left in this block. */ + pool->unallocateditems = pool->itemsfirstblock; + /* The stack of deallocated items is empty. */ + pool->deaditemstack = (VOID *)NULL; +} + +/*****************************************************************************/ +/* */ +/* poolinit() Initialize a pool of memory for allocation of items. */ +/* */ +/* This routine initializes the machinery for allocating items. A `pool' */ +/* is created whose records have size at least `bytecount'. Items will be */ +/* allocated in `itemcount'-item blocks. Each item is assumed to be a */ +/* collection of words, and either pointers or floating-point values are */ +/* assumed to be the "primary" word type. (The "primary" word type is used */ +/* to determine alignment of items.) If `alignment' isn't zero, all items */ +/* will be `alignment'-byte aligned in memory. `alignment' must be either */ +/* a multiple or a factor of the primary word size; powers of two are safe. */ +/* `alignment' is normally used to create a few unused bits at the bottom */ +/* of each item's pointer, in which information may be stored. */ +/* */ +/* Don't change this routine unless you understand it. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void poolinit(struct memorypool *pool, int bytecount, int itemcount, + int firstitemcount, int alignment) +#else /* not ANSI_DECLARATORS */ +void poolinit(pool, bytecount, itemcount, firstitemcount, + alignment) struct memorypool *pool; +int bytecount; +int itemcount; +int firstitemcount; +int alignment; +#endif /* not ANSI_DECLARATORS */ + +{ + /* Find the proper alignment, which must be at least as large as: */ + /* - The parameter `alignment'. */ + /* - sizeof(VOID *), so the stack of dead items can be maintained */ + /* without unaligned accesses. */ + if (alignment > sizeof(VOID *)) { + pool->alignbytes = alignment; + } else { + pool->alignbytes = sizeof(VOID *); + } + pool->itembytes = ((bytecount - 1) / pool->alignbytes + 1) * pool->alignbytes; + pool->itemsperblock = itemcount; + if (firstitemcount == 0) { + pool->itemsfirstblock = itemcount; + } else { + pool->itemsfirstblock = firstitemcount; + } + + /* Allocate a block of items. Space for `itemsfirstblock' items and one */ + /* pointer (to point to the next block) are allocated, as well as space */ + /* to ensure alignment of the items. */ + pool->firstblock = + (VOID **)trimalloc(pool->itemsfirstblock * pool->itembytes + + (int)sizeof(VOID *) + pool->alignbytes); + /* Set the next block pointer to NULL. */ + *(pool->firstblock) = (VOID *)NULL; + poolrestart(pool); +} + +/*****************************************************************************/ +/* */ +/* pooldeinit() Free to the operating system all memory taken by a pool. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void pooldeinit(struct memorypool *pool) +#else /* not ANSI_DECLARATORS */ +void pooldeinit(pool) struct memorypool *pool; +#endif /* not ANSI_DECLARATORS */ + +{ + while (pool->firstblock != (VOID **)NULL) { + pool->nowblock = (VOID **)*(pool->firstblock); + trifree((VOID *)pool->firstblock); + pool->firstblock = pool->nowblock; + } +} + +/*****************************************************************************/ +/* */ +/* poolalloc() Allocate space for an item. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +VOID *poolalloc(struct memorypool *pool) +#else /* not ANSI_DECLARATORS */ +VOID *poolalloc(pool) +struct memorypool *pool; +#endif /* not ANSI_DECLARATORS */ + +{ + VOID *newitem; + VOID **newblock; + unsigned long alignptr; + + /* First check the linked list of dead items. If the list is not */ + /* empty, allocate an item from the list rather than a fresh one. */ + if (pool->deaditemstack != (VOID *)NULL) { + newitem = pool->deaditemstack; /* Take first item in list. */ + pool->deaditemstack = *(VOID **)pool->deaditemstack; + } else { + /* Check if there are any free items left in the current block. */ + if (pool->unallocateditems == 0) { + /* Check if another block must be allocated. */ + if (*(pool->nowblock) == (VOID *)NULL) { + /* Allocate a new block of items, pointed to by the previous block. */ + newblock = (VOID **)trimalloc(pool->itemsperblock * pool->itembytes + + (int)sizeof(VOID *) + pool->alignbytes); + *(pool->nowblock) = (VOID *)newblock; + /* The next block pointer is NULL. */ + *newblock = (VOID *)NULL; + } + + /* Move to the new block. */ + pool->nowblock = (VOID **)*(pool->nowblock); + /* Find the first item in the block. */ + /* Increment by the size of (VOID *). */ + alignptr = (unsigned long)(pool->nowblock + 1); + /* Align the item on an `alignbytes'-byte boundary. */ + pool->nextitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - + (alignptr % (unsigned long)pool->alignbytes)); + /* There are lots of unallocated items left in this block. */ + pool->unallocateditems = pool->itemsperblock; + } + + /* Allocate a new item. */ + newitem = pool->nextitem; + /* Advance `nextitem' pointer to next free item in block. */ + pool->nextitem = (VOID *)((char *)pool->nextitem + pool->itembytes); + pool->unallocateditems--; + pool->maxitems++; + } + pool->items++; + return newitem; +} + +/*****************************************************************************/ +/* */ +/* pooldealloc() Deallocate space for an item. */ +/* */ +/* The deallocated space is stored in a queue for later reuse. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void pooldealloc(struct memorypool *pool, VOID *dyingitem) +#else /* not ANSI_DECLARATORS */ +void pooldealloc(pool, dyingitem) struct memorypool *pool; +VOID *dyingitem; +#endif /* not ANSI_DECLARATORS */ + +{ + /* Push freshly killed item onto stack. */ + *((VOID **)dyingitem) = pool->deaditemstack; + pool->deaditemstack = dyingitem; + pool->items--; +} + +/*****************************************************************************/ +/* */ +/* traversalinit() Prepare to traverse the entire list of items. */ +/* */ +/* This routine is used in conjunction with traverse(). */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void traversalinit(struct memorypool *pool) +#else /* not ANSI_DECLARATORS */ +void traversalinit(pool) struct memorypool *pool; +#endif /* not ANSI_DECLARATORS */ + +{ + unsigned long alignptr; + + /* Begin the traversal in the first block. */ + pool->pathblock = pool->firstblock; + /* Find the first item in the block. Increment by the size of (VOID *). */ + alignptr = (unsigned long)(pool->pathblock + 1); + /* Align with item on an `alignbytes'-byte boundary. */ + pool->pathitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - + (alignptr % (unsigned long)pool->alignbytes)); + /* Set the number of items left in the current block. */ + pool->pathitemsleft = pool->itemsfirstblock; +} + +/*****************************************************************************/ +/* */ +/* traverse() Find the next item in the list. */ +/* */ +/* This routine is used in conjunction with traversalinit(). Be forewarned */ +/* that this routine successively returns all items in the list, including */ +/* deallocated ones on the deaditemqueue. It's up to you to figure out */ +/* which ones are actually dead. Why? I don't want to allocate extra */ +/* space just to demarcate dead items. It can usually be done more */ +/* space-efficiently by a routine that knows something about the structure */ +/* of the item. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +VOID *traverse(struct memorypool *pool) +#else /* not ANSI_DECLARATORS */ +VOID *traverse(pool) +struct memorypool *pool; +#endif /* not ANSI_DECLARATORS */ + +{ + VOID *newitem; + unsigned long alignptr; + + /* Stop upon exhausting the list of items. */ + if (pool->pathitem == pool->nextitem) { + return (VOID *)NULL; + } + + /* Check whether any untraversed items remain in the current block. */ + if (pool->pathitemsleft == 0) { + /* Find the next block. */ + pool->pathblock = (VOID **)*(pool->pathblock); + /* Find the first item in the block. Increment by the size of (VOID *). */ + alignptr = (unsigned long)(pool->pathblock + 1); + /* Align with item on an `alignbytes'-byte boundary. */ + pool->pathitem = (VOID *)(alignptr + (unsigned long)pool->alignbytes - + (alignptr % (unsigned long)pool->alignbytes)); + /* Set the number of items left in the current block. */ + pool->pathitemsleft = pool->itemsperblock; + } + + newitem = pool->pathitem; + /* Find the next item in the block. */ + pool->pathitem = (VOID *)((char *)pool->pathitem + pool->itembytes); + pool->pathitemsleft--; + return newitem; +} + +/*****************************************************************************/ +/* */ +/* dummyinit() Initialize the triangle that fills "outer space" and the */ +/* omnipresent subsegment. */ +/* */ +/* The triangle that fills "outer space," called `dummytri', is pointed to */ +/* by every triangle and subsegment on a boundary (be it outer or inner) of */ +/* the triangulation. Also, `dummytri' points to one of the triangles on */ +/* the convex hull (until the holes and concavities are carved), making it */ +/* possible to find a starting triangle for point location. */ +/* */ +/* The omnipresent subsegment, `dummysub', is pointed to by every triangle */ +/* or subsegment that doesn't have a full complement of real subsegments */ +/* to point to. */ +/* */ +/* `dummytri' and `dummysub' are generally required to fulfill only a few */ +/* invariants: their vertices must remain NULL and `dummytri' must always */ +/* be bonded (at offset zero) to some triangle on the convex hull of the */ +/* mesh, via a boundary edge. Otherwise, the connections of `dummytri' and */ +/* `dummysub' may change willy-nilly. This makes it possible to avoid */ +/* writing a good deal of special-case code (in the edge flip, for example) */ +/* for dealing with the boundary of the mesh, places where no subsegment is */ +/* present, and so forth. Other entities are frequently bonded to */ +/* `dummytri' and `dummysub' as if they were real mesh entities, with no */ +/* harm done. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void dummyinit(struct mesh *m, struct behavior *b, int trianglebytes, + int subsegbytes) +#else /* not ANSI_DECLARATORS */ +void dummyinit(m, b, trianglebytes, subsegbytes) struct mesh *m; +struct behavior *b; +int trianglebytes; +int subsegbytes; +#endif /* not ANSI_DECLARATORS */ + +{ + unsigned long alignptr; + + /* Set up `dummytri', the `triangle' that occupies "outer space." */ + m->dummytribase = + (triangle *)trimalloc(trianglebytes + m->triangles.alignbytes); + /* Align `dummytri' on a `triangles.alignbytes'-byte boundary. */ + alignptr = (unsigned long)m->dummytribase; + m->dummytri = + (triangle *)(alignptr + (unsigned long)m->triangles.alignbytes - + (alignptr % (unsigned long)m->triangles.alignbytes)); + /* Initialize the three adjoining triangles to be "outer space." These */ + /* will eventually be changed by various bonding operations, but their */ + /* values don't really matter, as long as they can legally be */ + /* dereferenced. */ + m->dummytri[0] = (triangle)m->dummytri; + m->dummytri[1] = (triangle)m->dummytri; + m->dummytri[2] = (triangle)m->dummytri; + /* Three NULL vertices. */ + m->dummytri[3] = (triangle)NULL; + m->dummytri[4] = (triangle)NULL; + m->dummytri[5] = (triangle)NULL; + + if (b->usesegments) { + /* Set up `dummysub', the omnipresent subsegment pointed to by any */ + /* triangle side or subsegment end that isn't attached to a real */ + /* subsegment. */ + m->dummysubbase = (subseg *)trimalloc(subsegbytes + m->subsegs.alignbytes); + /* Align `dummysub' on a `subsegs.alignbytes'-byte boundary. */ + alignptr = (unsigned long)m->dummysubbase; + m->dummysub = (subseg *)(alignptr + (unsigned long)m->subsegs.alignbytes - + (alignptr % (unsigned long)m->subsegs.alignbytes)); + /* Initialize the two adjoining subsegments to be the omnipresent */ + /* subsegment. These will eventually be changed by various bonding */ + /* operations, but their values don't really matter, as long as they */ + /* can legally be dereferenced. */ + m->dummysub[0] = (subseg)m->dummysub; + m->dummysub[1] = (subseg)m->dummysub; + /* Four NULL vertices. */ + m->dummysub[2] = (subseg)NULL; + m->dummysub[3] = (subseg)NULL; + m->dummysub[4] = (subseg)NULL; + m->dummysub[5] = (subseg)NULL; + /* Initialize the two adjoining triangles to be "outer space." */ + m->dummysub[6] = (subseg)m->dummytri; + m->dummysub[7] = (subseg)m->dummytri; + /* Set the boundary marker to zero. */ + *(int *)(m->dummysub + 8) = 0; + + /* Initialize the three adjoining subsegments of `dummytri' to be */ + /* the omnipresent subsegment. */ + m->dummytri[6] = (triangle)m->dummysub; + m->dummytri[7] = (triangle)m->dummysub; + m->dummytri[8] = (triangle)m->dummysub; + } +} + +/*****************************************************************************/ +/* */ +/* initializevertexpool() Calculate the size of the vertex data structure */ +/* and initialize its memory pool. */ +/* */ +/* This routine also computes the `vertexmarkindex' and `vertex2triindex' */ +/* indices used to find values within each vertex. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void initializevertexpool(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void initializevertexpool(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + int vertexsize; + + /* The index within each vertex at which the boundary marker is found, */ + /* followed by the vertex type. Ensure the vertex marker is aligned to */ + /* a sizeof(int)-byte address. */ + m->vertexmarkindex = + ((m->mesh_dim + m->nextras) * sizeof(REAL) + sizeof(int) - 1) / + sizeof(int); + vertexsize = (m->vertexmarkindex + 2) * sizeof(int); + if (b->poly) { + /* The index within each vertex at which a triangle pointer is found. */ + /* Ensure the pointer is aligned to a sizeof(triangle)-byte address. */ + m->vertex2triindex = (vertexsize + sizeof(triangle) - 1) / sizeof(triangle); + vertexsize = (m->vertex2triindex + 1) * sizeof(triangle); + } + + /* Initialize the pool of vertices. */ + poolinit(&m->vertices, vertexsize, VERTEXPERBLOCK, + m->invertices > VERTEXPERBLOCK ? m->invertices : VERTEXPERBLOCK, + sizeof(REAL)); +} + +/*****************************************************************************/ +/* */ +/* initializetrisubpools() Calculate the sizes of the triangle and */ +/* subsegment data structures and initialize */ +/* their memory pools. */ +/* */ +/* This routine also computes the `highorderindex', `elemattribindex', and */ +/* `areaboundindex' indices used to find values within each triangle. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void initializetrisubpools(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void initializetrisubpools(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + int trisize; + + /* The index within each triangle at which the extra nodes (above three) */ + /* associated with high order elements are found. There are three */ + /* pointers to other triangles, three pointers to corners, and possibly */ + /* three pointers to subsegments before the extra nodes. */ + m->highorderindex = 6 + (b->usesegments * 3); + /* The number of bytes occupied by a triangle. */ + trisize = ((b->order + 1) * (b->order + 2) / 2 + (m->highorderindex - 3)) * + sizeof(triangle); + /* The index within each triangle at which its attributes are found, */ + /* where the index is measured in REALs. */ + m->elemattribindex = (trisize + sizeof(REAL) - 1) / sizeof(REAL); + /* The index within each triangle at which the maximum area constraint */ + /* is found, where the index is measured in REALs. Note that if the */ + /* `regionattrib' flag is set, an additional attribute will be added. */ + m->areaboundindex = m->elemattribindex + m->eextras + b->regionattrib; + /* If triangle attributes or an area bound are needed, increase the number */ + /* of bytes occupied by a triangle. */ + if (b->vararea) { + trisize = (m->areaboundindex + 1) * sizeof(REAL); + } else if (m->eextras + b->regionattrib > 0) { + trisize = m->areaboundindex * sizeof(REAL); + } + /* If a Voronoi diagram or triangle neighbor graph is requested, make */ + /* sure there's room to store an integer index in each triangle. This */ + /* integer index can occupy the same space as the subsegment pointers */ + /* or attributes or area constraint or extra nodes. */ + if ((b->voronoi || b->neighbors) && + (trisize < 6 * sizeof(triangle) + sizeof(int))) { + trisize = 6 * sizeof(triangle) + sizeof(int); + } + + /* Having determined the memory size of a triangle, initialize the pool. */ + poolinit(&m->triangles, trisize, TRIPERBLOCK, + (2 * m->invertices - 2) > TRIPERBLOCK ? (2 * m->invertices - 2) + : TRIPERBLOCK, + 4); + + if (b->usesegments) { + /* Initialize the pool of subsegments. Take into account all eight */ + /* pointers and one boundary marker. */ + poolinit(&m->subsegs, 8 * sizeof(triangle) + sizeof(int), SUBSEGPERBLOCK, + SUBSEGPERBLOCK, 4); + + /* Initialize the "outer space" triangle and omnipresent subsegment. */ + dummyinit(m, b, m->triangles.itembytes, m->subsegs.itembytes); + } else { + /* Initialize the "outer space" triangle. */ + dummyinit(m, b, m->triangles.itembytes, 0); + } +} + +/*****************************************************************************/ +/* */ +/* triangledealloc() Deallocate space for a triangle, marking it dead. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void triangledealloc(struct mesh *m, triangle *dyingtriangle) +#else /* not ANSI_DECLARATORS */ +void triangledealloc(m, dyingtriangle) struct mesh *m; +triangle *dyingtriangle; +#endif /* not ANSI_DECLARATORS */ + +{ + /* Mark the triangle as dead. This makes it possible to detect dead */ + /* triangles when traversing the list of all triangles. */ + killtri(dyingtriangle); + pooldealloc(&m->triangles, (VOID *)dyingtriangle); +} + +/*****************************************************************************/ +/* */ +/* triangletraverse() Traverse the triangles, skipping dead ones. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +triangle *triangletraverse(struct mesh *m) +#else /* not ANSI_DECLARATORS */ +triangle *triangletraverse(m) +struct mesh *m; +#endif /* not ANSI_DECLARATORS */ + +{ + triangle *newtriangle; + + do { + newtriangle = (triangle *)traverse(&m->triangles); + if (newtriangle == (triangle *)NULL) { + return (triangle *)NULL; + } + } while (deadtri(newtriangle)); /* Skip dead ones. */ + return newtriangle; +} + +/*****************************************************************************/ +/* */ +/* subsegdealloc() Deallocate space for a subsegment, marking it dead. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void subsegdealloc(struct mesh *m, subseg *dyingsubseg) +#else /* not ANSI_DECLARATORS */ +void subsegdealloc(m, dyingsubseg) struct mesh *m; +subseg *dyingsubseg; +#endif /* not ANSI_DECLARATORS */ + +{ + /* Mark the subsegment as dead. This makes it possible to detect dead */ + /* subsegments when traversing the list of all subsegments. */ + killsubseg(dyingsubseg); + pooldealloc(&m->subsegs, (VOID *)dyingsubseg); +} + +/*****************************************************************************/ +/* */ +/* subsegtraverse() Traverse the subsegments, skipping dead ones. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +subseg *subsegtraverse(struct mesh *m) +#else /* not ANSI_DECLARATORS */ +subseg *subsegtraverse(m) +struct mesh *m; +#endif /* not ANSI_DECLARATORS */ + +{ + subseg *newsubseg; + + do { + newsubseg = (subseg *)traverse(&m->subsegs); + if (newsubseg == (subseg *)NULL) { + return (subseg *)NULL; + } + } while (deadsubseg(newsubseg)); /* Skip dead ones. */ + return newsubseg; +} + +/*****************************************************************************/ +/* */ +/* vertexdealloc() Deallocate space for a vertex, marking it dead. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void vertexdealloc(struct mesh *m, vertex dyingvertex) +#else /* not ANSI_DECLARATORS */ +void vertexdealloc(m, dyingvertex) struct mesh *m; +vertex dyingvertex; +#endif /* not ANSI_DECLARATORS */ + +{ + /* Mark the vertex as dead. This makes it possible to detect dead */ + /* vertices when traversing the list of all vertices. */ + setvertextype(dyingvertex, DEADVERTEX); + pooldealloc(&m->vertices, (VOID *)dyingvertex); +} + +/*****************************************************************************/ +/* */ +/* vertextraverse() Traverse the vertices, skipping dead ones. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +vertex vertextraverse(struct mesh *m) +#else /* not ANSI_DECLARATORS */ +vertex vertextraverse(m) +struct mesh *m; +#endif /* not ANSI_DECLARATORS */ + +{ + vertex newvertex; + + do { + newvertex = (vertex)traverse(&m->vertices); + if (newvertex == (vertex)NULL) { + return (vertex)NULL; + } + } while (vertextype(newvertex) == DEADVERTEX); /* Skip dead ones. */ + return newvertex; +} + +/*****************************************************************************/ +/* */ +/* badsubsegdealloc() Deallocate space for a bad subsegment, marking it */ +/* dead. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void badsubsegdealloc(struct mesh *m, struct badsubseg *dyingseg) +#else /* not ANSI_DECLARATORS */ +void badsubsegdealloc(m, dyingseg) struct mesh *m; +struct badsubseg *dyingseg; +#endif /* not ANSI_DECLARATORS */ + +{ + /* Set subsegment's origin to NULL. This makes it possible to detect dead */ + /* badsubsegs when traversing the list of all badsubsegs . */ + dyingseg->subsegorg = (vertex)NULL; + pooldealloc(&m->badsubsegs, (VOID *)dyingseg); +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* badsubsegtraverse() Traverse the bad subsegments, skipping dead ones. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +struct badsubseg *badsubsegtraverse(struct mesh *m) +#else /* not ANSI_DECLARATORS */ +struct badsubseg *badsubsegtraverse(m) +struct mesh *m; +#endif /* not ANSI_DECLARATORS */ + +{ + struct badsubseg *newseg; + + do { + newseg = (struct badsubseg *)traverse(&m->badsubsegs); + if (newseg == (struct badsubseg *)NULL) { + return (struct badsubseg *)NULL; + } + } while (newseg->subsegorg == (vertex)NULL); /* Skip dead ones. */ + return newseg; +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* getvertex() Get a specific vertex, by number, from the list. */ +/* */ +/* The first vertex is number 'firstnumber'. */ +/* */ +/* Note that this takes O(n) time (with a small constant, if VERTEXPERBLOCK */ +/* is large). I don't care to take the trouble to make it work in constant */ +/* time. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +vertex getvertex(struct mesh *m, struct behavior *b, int number) +#else /* not ANSI_DECLARATORS */ +vertex getvertex(m, b, number) +struct mesh *m; +struct behavior *b; +int number; +#endif /* not ANSI_DECLARATORS */ + +{ + VOID **getblock; + char *foundvertex; + unsigned long alignptr; + int current; + + getblock = m->vertices.firstblock; + current = b->firstnumber; + + /* Find the right block. */ + if (current + m->vertices.itemsfirstblock <= number) { + getblock = (VOID **)*getblock; + current += m->vertices.itemsfirstblock; + while (current + m->vertices.itemsperblock <= number) { + getblock = (VOID **)*getblock; + current += m->vertices.itemsperblock; + } + } + + /* Now find the right vertex. */ + alignptr = (unsigned long)(getblock + 1); + foundvertex = (char *)(alignptr + (unsigned long)m->vertices.alignbytes - + (alignptr % (unsigned long)m->vertices.alignbytes)); + return (vertex)(foundvertex + m->vertices.itembytes * (number - current)); +} + +/*****************************************************************************/ +/* */ +/* triangledeinit() Free all remaining allocated memory. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void triangledeinit(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void triangledeinit(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + pooldeinit(&m->triangles); + trifree((VOID *)m->dummytribase); + if (b->usesegments) { + pooldeinit(&m->subsegs); + trifree((VOID *)m->dummysubbase); + } + pooldeinit(&m->vertices); +#ifndef CDT_ONLY + if (b->quality) { + pooldeinit(&m->badsubsegs); + if ((b->minangle > 0.0) || b->vararea || b->fixedarea || b->usertest) { + pooldeinit(&m->badtriangles); + pooldeinit(&m->flipstackers); + } + } +#endif /* not CDT_ONLY */ +} + +/** **/ +/** **/ +/********* Memory management routines end here *********/ + +/********* Constructors begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* maketriangle() Create a new triangle with orientation zero. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void maketriangle(struct mesh *m, struct behavior *b, struct otri *newotri) +#else /* not ANSI_DECLARATORS */ +void maketriangle(m, b, newotri) struct mesh *m; +struct behavior *b; +struct otri *newotri; +#endif /* not ANSI_DECLARATORS */ + +{ + int i; + + newotri->tri = (triangle *)poolalloc(&m->triangles); + /* Initialize the three adjoining triangles to be "outer space". */ + newotri->tri[0] = (triangle)m->dummytri; + newotri->tri[1] = (triangle)m->dummytri; + newotri->tri[2] = (triangle)m->dummytri; + /* Three NULL vertices. */ + newotri->tri[3] = (triangle)NULL; + newotri->tri[4] = (triangle)NULL; + newotri->tri[5] = (triangle)NULL; + if (b->usesegments) { + /* Initialize the three adjoining subsegments to be the omnipresent */ + /* subsegment. */ + newotri->tri[6] = (triangle)m->dummysub; + newotri->tri[7] = (triangle)m->dummysub; + newotri->tri[8] = (triangle)m->dummysub; + } + for (i = 0; i < m->eextras; i++) { + setelemattribute(*newotri, i, 0.0); + } + if (b->vararea) { + setareabound(*newotri, -1.0); + } + + newotri->orient = 0; +} + +/*****************************************************************************/ +/* */ +/* makesubseg() Create a new subsegment with orientation zero. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void makesubseg(struct mesh *m, struct osub *newsubseg) +#else /* not ANSI_DECLARATORS */ +void makesubseg(m, newsubseg) struct mesh *m; +struct osub *newsubseg; +#endif /* not ANSI_DECLARATORS */ + +{ + newsubseg->ss = (subseg *)poolalloc(&m->subsegs); + /* Initialize the two adjoining subsegments to be the omnipresent */ + /* subsegment. */ + newsubseg->ss[0] = (subseg)m->dummysub; + newsubseg->ss[1] = (subseg)m->dummysub; + /* Four NULL vertices. */ + newsubseg->ss[2] = (subseg)NULL; + newsubseg->ss[3] = (subseg)NULL; + newsubseg->ss[4] = (subseg)NULL; + newsubseg->ss[5] = (subseg)NULL; + /* Initialize the two adjoining triangles to be "outer space." */ + newsubseg->ss[6] = (subseg)m->dummytri; + newsubseg->ss[7] = (subseg)m->dummytri; + /* Set the boundary marker to zero. */ + setmark(*newsubseg, 0); + + newsubseg->ssorient = 0; +} + +/** **/ +/** **/ +/********* Constructors end here *********/ + +/********* Geometric primitives begin here *********/ +/** **/ +/** **/ + +/* The adaptive exact arithmetic geometric predicates implemented herein are */ +/* described in detail in my paper, "Adaptive Precision Floating-Point */ +/* Arithmetic and Fast Robust Geometric Predicates." See the header for a */ +/* full citation. */ + +/* Which of the following two methods of finding the absolute values is */ +/* fastest is compiler-dependent. A few compilers can inline and optimize */ +/* the fabs() call; but most will incur the overhead of a function call, */ +/* which is disastrously slow. A faster way on IEEE machines might be to */ +/* mask the appropriate bit, but that's difficult to do in C without */ +/* forcing the value to be stored to memory (rather than be kept in the */ +/* register to which the optimizer assigned it). */ + +#define Absolute(a) ((a) >= 0.0 ? (a) : -(a)) +/* #define Absolute(a) fabs(a) */ + +/* Many of the operations are broken up into two pieces, a main part that */ +/* performs an approximate operation, and a "tail" that computes the */ +/* roundoff error of that operation. */ +/* */ +/* The operations Fast_Two_Sum(), Fast_Two_Diff(), Two_Sum(), Two_Diff(), */ +/* Split(), and Two_Product() are all implemented as described in the */ +/* reference. Each of these macros requires certain variables to be */ +/* defined in the calling routine. The variables `bvirt', `c', `abig', */ +/* `_i', `_j', `_k', `_l', `_m', and `_n' are declared `INEXACT' because */ +/* they store the result of an operation that may incur roundoff error. */ +/* The input parameter `x' (or the highest numbered `x_' parameter) must */ +/* also be declared `INEXACT'. */ + +#define Fast_Two_Sum_Tail(a, b, x, y) \ + bvirt = x - a; \ + y = b - bvirt + +#define Fast_Two_Sum(a, b, x, y) \ + x = (REAL)(a + b); \ + Fast_Two_Sum_Tail(a, b, x, y) + +#define Two_Sum_Tail(a, b, x, y) \ + bvirt = (REAL)(x - a); \ + avirt = x - bvirt; \ + bround = b - bvirt; \ + around = a - avirt; \ + y = around + bround + +#define Two_Sum(a, b, x, y) \ + x = (REAL)(a + b); \ + Two_Sum_Tail(a, b, x, y) + +#define Two_Diff_Tail(a, b, x, y) \ + bvirt = (REAL)(a - x); \ + avirt = x + bvirt; \ + bround = bvirt - b; \ + around = a - avirt; \ + y = around + bround + +#define Two_Diff(a, b, x, y) \ + x = (REAL)(a - b); \ + Two_Diff_Tail(a, b, x, y) + +#define Split(a, ahi, alo) \ + c = (REAL)(splitter * a); \ + abig = (REAL)(c - a); \ + ahi = c - abig; \ + alo = a - ahi + +#define Two_Product_Tail(a, b, x, y) \ + Split(a, ahi, alo); \ + Split(b, bhi, blo); \ + err1 = x - (ahi * bhi); \ + err2 = err1 - (alo * bhi); \ + err3 = err2 - (ahi * blo); \ + y = (alo * blo) - err3 + +#define Two_Product(a, b, x, y) \ + x = (REAL)(a * b); \ + Two_Product_Tail(a, b, x, y) + +/* Two_Product_Presplit() is Two_Product() where one of the inputs has */ +/* already been split. Avoids redundant splitting. */ + +#define Two_Product_Presplit(a, b, bhi, blo, x, y) \ + x = (REAL)(a * b); \ + Split(a, ahi, alo); \ + err1 = x - (ahi * bhi); \ + err2 = err1 - (alo * bhi); \ + err3 = err2 - (ahi * blo); \ + y = (alo * blo) - err3 + +/* Square() can be done more quickly than Two_Product(). */ + +#define Square_Tail(a, x, y) \ + Split(a, ahi, alo); \ + err1 = x - (ahi * ahi); \ + err3 = err1 - ((ahi + ahi) * alo); \ + y = (alo * alo) - err3 + +#define Square(a, x, y) \ + x = (REAL)(a * a); \ + Square_Tail(a, x, y) + +/* Macros for summing expansions of various fixed lengths. These are all */ +/* unrolled versions of Expansion_Sum(). */ + +#define Two_One_Sum(a1, a0, b, x2, x1, x0) \ + Two_Sum(a0, b, _i, x0); \ + Two_Sum(a1, _i, x2, x1) + +#define Two_One_Diff(a1, a0, b, x2, x1, x0) \ + Two_Diff(a0, b, _i, x0); \ + Two_Sum(a1, _i, x2, x1) + +#define Two_Two_Sum(a1, a0, b1, b0, x3, x2, x1, x0) \ + Two_One_Sum(a1, a0, b0, _j, _0, x0); \ + Two_One_Sum(_j, _0, b1, x3, x2, x1) + +#define Two_Two_Diff(a1, a0, b1, b0, x3, x2, x1, x0) \ + Two_One_Diff(a1, a0, b0, _j, _0, x0); \ + Two_One_Diff(_j, _0, b1, x3, x2, x1) + +/* Macro for multiplying a two-component expansion by a single component. */ + +#define Two_One_Product(a1, a0, b, x3, x2, x1, x0) \ + Split(b, bhi, blo); \ + Two_Product_Presplit(a0, b, bhi, blo, _i, x0); \ + Two_Product_Presplit(a1, b, bhi, blo, _j, _0); \ + Two_Sum(_i, _0, _k, x1); \ + Fast_Two_Sum(_j, _k, x3, x2) + +/*****************************************************************************/ +/* */ +/* exactinit() Initialize the variables used for exact arithmetic. */ +/* */ +/* `epsilon' is the largest power of two such that 1.0 + epsilon = 1.0 in */ +/* floating-point arithmetic. `epsilon' bounds the relative roundoff */ +/* error. It is used for floating-point error analysis. */ +/* */ +/* `splitter' is used to split floating-point numbers into two half- */ +/* length significands for exact multiplication. */ +/* */ +/* I imagine that a highly optimizing compiler might be too smart for its */ +/* own good, and somehow cause this routine to fail, if it pretends that */ +/* floating-point arithmetic is too much like real arithmetic. */ +/* */ +/* Don't change this routine unless you fully understand it. */ +/* */ +/*****************************************************************************/ + +void exactinit() { + REAL half; + REAL check, lastcheck; + int every_other; +#ifdef LINUX + int cword; +#endif /* LINUX */ + +#ifdef CPU86 +#ifdef SINGLE + _control87(_PC_24, _MCW_PC); /* Set FPU control word for single precision. */ +#else /* not SINGLE */ + _control87(_PC_53, _MCW_PC); /* Set FPU control word for double precision. */ +#endif /* not SINGLE */ +#endif /* CPU86 */ +#ifdef LINUX +#ifdef SINGLE + /* cword = 4223; */ + cword = 4210; /* set FPU control word for single precision */ +#else /* not SINGLE */ + /* cword = 4735; */ + cword = 4722; /* set FPU control word for double precision */ +#endif /* not SINGLE */ + _FPU_SETCW(cword); +#endif /* LINUX */ + + every_other = 1; + half = 0.5; + epsilon = 1.0; + splitter = 1.0; + check = 1.0; + /* Repeatedly divide `epsilon' by two until it is too small to add to */ + /* one without causing roundoff. (Also check if the sum is equal to */ + /* the previous sum, for machines that round up instead of using exact */ + /* rounding. Not that these routines will work on such machines.) */ + do { + lastcheck = check; + epsilon *= half; + if (every_other) { + splitter *= 2.0; + } + every_other = !every_other; + check = 1.0 + epsilon; + } while ((check != 1.0) && (check != lastcheck)); + splitter += 1.0; + /* Error bounds for orientation and incircle tests. */ + resulterrbound = (3.0 + 8.0 * epsilon) * epsilon; + ccwerrboundA = (3.0 + 16.0 * epsilon) * epsilon; + ccwerrboundB = (2.0 + 12.0 * epsilon) * epsilon; + ccwerrboundC = (9.0 + 64.0 * epsilon) * epsilon * epsilon; + iccerrboundA = (10.0 + 96.0 * epsilon) * epsilon; + iccerrboundB = (4.0 + 48.0 * epsilon) * epsilon; + iccerrboundC = (44.0 + 576.0 * epsilon) * epsilon * epsilon; + o3derrboundA = (7.0 + 56.0 * epsilon) * epsilon; + o3derrboundB = (3.0 + 28.0 * epsilon) * epsilon; + o3derrboundC = (26.0 + 288.0 * epsilon) * epsilon * epsilon; +} + +/*****************************************************************************/ +/* */ +/* fast_expansion_sum_zeroelim() Sum two expansions, eliminating zero */ +/* components from the output expansion. */ +/* */ +/* Sets h = e + f. See my Robust Predicates paper for details. */ +/* */ +/* If round-to-even is used (as with IEEE 754), maintains the strongly */ +/* nonoverlapping property. (That is, if e is strongly nonoverlapping, h */ +/* will be also.) Does NOT maintain the nonoverlapping or nonadjacent */ +/* properties. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +int fast_expansion_sum_zeroelim(int elen, REAL *e, int flen, REAL *f, REAL *h) +#else /* not ANSI_DECLARATORS */ +int fast_expansion_sum_zeroelim(elen, e, flen, f, h) /* h cannot be e or f. */ +int elen; +REAL *e; +int flen; +REAL *f; +REAL *h; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL Q; + INEXACT REAL Qnew; + INEXACT REAL hh; + INEXACT REAL bvirt; + REAL avirt, bround, around; + int eindex, findex, hindex; + REAL enow, fnow; + + enow = e[0]; + fnow = f[0]; + eindex = findex = 0; + if ((fnow > enow) == (fnow > -enow)) { + Q = enow; + enow = e[++eindex]; + } else { + Q = fnow; + fnow = f[++findex]; + } + hindex = 0; + if ((eindex < elen) && (findex < flen)) { + if ((fnow > enow) == (fnow > -enow)) { + Fast_Two_Sum(enow, Q, Qnew, hh); + enow = e[++eindex]; + } else { + Fast_Two_Sum(fnow, Q, Qnew, hh); + fnow = f[++findex]; + } + Q = Qnew; + if (hh != 0.0) { + h[hindex++] = hh; + } + while ((eindex < elen) && (findex < flen)) { + if ((fnow > enow) == (fnow > -enow)) { + Two_Sum(Q, enow, Qnew, hh); + enow = e[++eindex]; + } else { + Two_Sum(Q, fnow, Qnew, hh); + fnow = f[++findex]; + } + Q = Qnew; + if (hh != 0.0) { + h[hindex++] = hh; + } + } + } + while (eindex < elen) { + Two_Sum(Q, enow, Qnew, hh); + enow = e[++eindex]; + Q = Qnew; + if (hh != 0.0) { + h[hindex++] = hh; + } + } + while (findex < flen) { + Two_Sum(Q, fnow, Qnew, hh); + fnow = f[++findex]; + Q = Qnew; + if (hh != 0.0) { + h[hindex++] = hh; + } + } + if ((Q != 0.0) || (hindex == 0)) { + h[hindex++] = Q; + } + return hindex; +} + +/*****************************************************************************/ +/* */ +/* scale_expansion_zeroelim() Multiply an expansion by a scalar, */ +/* eliminating zero components from the */ +/* output expansion. */ +/* */ +/* Sets h = be. See my Robust Predicates paper for details. */ +/* */ +/* Maintains the nonoverlapping property. If round-to-even is used (as */ +/* with IEEE 754), maintains the strongly nonoverlapping and nonadjacent */ +/* properties as well. (That is, if e has one of these properties, so */ +/* will h.) */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +int scale_expansion_zeroelim(int elen, REAL *e, REAL b, REAL *h) +#else /* not ANSI_DECLARATORS */ +int scale_expansion_zeroelim(elen, e, b, h) /* e and h cannot be the same. */ +int elen; +REAL *e; +REAL b; +REAL *h; +#endif /* not ANSI_DECLARATORS */ + +{ + INEXACT REAL Q, sum; + REAL hh; + INEXACT REAL product1; + REAL product0; + int eindex, hindex; + REAL enow; + INEXACT REAL bvirt; + REAL avirt, bround, around; + INEXACT REAL c; + INEXACT REAL abig; + REAL ahi, alo, bhi, blo; + REAL err1, err2, err3; + + Split(b, bhi, blo); + Two_Product_Presplit(e[0], b, bhi, blo, Q, hh); + hindex = 0; + if (hh != 0) { + h[hindex++] = hh; + } + for (eindex = 1; eindex < elen; eindex++) { + enow = e[eindex]; + Two_Product_Presplit(enow, b, bhi, blo, product1, product0); + Two_Sum(Q, product0, sum, hh); + if (hh != 0) { + h[hindex++] = hh; + } + Fast_Two_Sum(product1, sum, Q, hh); + if (hh != 0) { + h[hindex++] = hh; + } + } + if ((Q != 0.0) || (hindex == 0)) { + h[hindex++] = Q; + } + return hindex; +} + +/*****************************************************************************/ +/* */ +/* estimate() Produce a one-word estimate of an expansion's value. */ +/* */ +/* See my Robust Predicates paper for details. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +REAL estimate(int elen, REAL *e) +#else /* not ANSI_DECLARATORS */ +REAL estimate(elen, e) +int elen; +REAL *e; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL Q; + int eindex; + + Q = e[0]; + for (eindex = 1; eindex < elen; eindex++) { + Q += e[eindex]; + } + return Q; +} + +/*****************************************************************************/ +/* */ +/* counterclockwise() Return a positive value if the points pa, pb, and */ +/* pc occur in counterclockwise order; a negative */ +/* value if they occur in clockwise order; and zero */ +/* if they are collinear. The result is also a rough */ +/* approximation of twice the signed area of the */ +/* triangle defined by the three points. */ +/* */ +/* Uses exact arithmetic if necessary to ensure a correct answer. The */ +/* result returned is the determinant of a matrix. This determinant is */ +/* computed adaptively, in the sense that exact arithmetic is used only to */ +/* the degree it is needed to ensure that the returned value has the */ +/* correct sign. Hence, this function is usually quite fast, but will run */ +/* more slowly when the input points are collinear or nearly so. */ +/* */ +/* See my Robust Predicates paper for details. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +REAL counterclockwiseadapt(vertex pa, vertex pb, vertex pc, REAL detsum) +#else /* not ANSI_DECLARATORS */ +REAL counterclockwiseadapt(pa, pb, pc, detsum) +vertex pa; +vertex pb; +vertex pc; +REAL detsum; +#endif /* not ANSI_DECLARATORS */ + +{ + INEXACT REAL acx, acy, bcx, bcy; + REAL acxtail, acytail, bcxtail, bcytail; + INEXACT REAL detleft, detright; + REAL detlefttail, detrighttail; + REAL det, errbound; + REAL B[4], C1[8], C2[12], D[16]; + INEXACT REAL B3; + int C1length, C2length, Dlength; + REAL u[4]; + INEXACT REAL u3; + INEXACT REAL s1, t1; + REAL s0, t0; + + INEXACT REAL bvirt; + REAL avirt, bround, around; + INEXACT REAL c; + INEXACT REAL abig; + REAL ahi, alo, bhi, blo; + REAL err1, err2, err3; + INEXACT REAL _i, _j; + REAL _0; + + acx = (REAL)(pa[0] - pc[0]); + bcx = (REAL)(pb[0] - pc[0]); + acy = (REAL)(pa[1] - pc[1]); + bcy = (REAL)(pb[1] - pc[1]); + + Two_Product(acx, bcy, detleft, detlefttail); + Two_Product(acy, bcx, detright, detrighttail); + + Two_Two_Diff(detleft, detlefttail, detright, detrighttail, B3, B[2], B[1], + B[0]); + B[3] = B3; + + det = estimate(4, B); + errbound = ccwerrboundB * detsum; + if ((det >= errbound) || (-det >= errbound)) { + return det; + } + + Two_Diff_Tail(pa[0], pc[0], acx, acxtail); + Two_Diff_Tail(pb[0], pc[0], bcx, bcxtail); + Two_Diff_Tail(pa[1], pc[1], acy, acytail); + Two_Diff_Tail(pb[1], pc[1], bcy, bcytail); + + if ((acxtail == 0.0) && (acytail == 0.0) && (bcxtail == 0.0) && + (bcytail == 0.0)) { + return det; + } + + errbound = ccwerrboundC * detsum + resulterrbound * Absolute(det); + det += (acx * bcytail + bcy * acxtail) - (acy * bcxtail + bcx * acytail); + if ((det >= errbound) || (-det >= errbound)) { + return det; + } + + Two_Product(acxtail, bcy, s1, s0); + Two_Product(acytail, bcx, t1, t0); + Two_Two_Diff(s1, s0, t1, t0, u3, u[2], u[1], u[0]); + u[3] = u3; + C1length = fast_expansion_sum_zeroelim(4, B, 4, u, C1); + + Two_Product(acx, bcytail, s1, s0); + Two_Product(acy, bcxtail, t1, t0); + Two_Two_Diff(s1, s0, t1, t0, u3, u[2], u[1], u[0]); + u[3] = u3; + C2length = fast_expansion_sum_zeroelim(C1length, C1, 4, u, C2); + + Two_Product(acxtail, bcytail, s1, s0); + Two_Product(acytail, bcxtail, t1, t0); + Two_Two_Diff(s1, s0, t1, t0, u3, u[2], u[1], u[0]); + u[3] = u3; + Dlength = fast_expansion_sum_zeroelim(C2length, C2, 4, u, D); + + return (D[Dlength - 1]); +} + +#ifdef ANSI_DECLARATORS +REAL counterclockwise(struct mesh *m, struct behavior *b, vertex pa, vertex pb, + vertex pc) +#else /* not ANSI_DECLARATORS */ +REAL counterclockwise(m, b, pa, pb, pc) +struct mesh *m; +struct behavior *b; +vertex pa; +vertex pb; +vertex pc; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL detleft, detright, det; + REAL detsum, errbound; + + m->counterclockcount++; + + detleft = (pa[0] - pc[0]) * (pb[1] - pc[1]); + detright = (pa[1] - pc[1]) * (pb[0] - pc[0]); + det = detleft - detright; + + if (b->noexact) { + return det; + } + + if (detleft > 0.0) { + if (detright <= 0.0) { + return det; + } else { + detsum = detleft + detright; + } + } else if (detleft < 0.0) { + if (detright >= 0.0) { + return det; + } else { + detsum = -detleft - detright; + } + } else { + return det; + } + + errbound = ccwerrboundA * detsum; + if ((det >= errbound) || (-det >= errbound)) { + return det; + } + + return counterclockwiseadapt(pa, pb, pc, detsum); +} + +/*****************************************************************************/ +/* */ +/* incircle() Return a positive value if the point pd lies inside the */ +/* circle passing through pa, pb, and pc; a negative value if */ +/* it lies outside; and zero if the four points are cocircular.*/ +/* The points pa, pb, and pc must be in counterclockwise */ +/* order, or the sign of the result will be reversed. */ +/* */ +/* Uses exact arithmetic if necessary to ensure a correct answer. The */ +/* result returned is the determinant of a matrix. This determinant is */ +/* computed adaptively, in the sense that exact arithmetic is used only to */ +/* the degree it is needed to ensure that the returned value has the */ +/* correct sign. Hence, this function is usually quite fast, but will run */ +/* more slowly when the input points are cocircular or nearly so. */ +/* */ +/* See my Robust Predicates paper for details. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +REAL incircleadapt(vertex pa, vertex pb, vertex pc, vertex pd, REAL permanent) +#else /* not ANSI_DECLARATORS */ +REAL incircleadapt(pa, pb, pc, pd, permanent) +vertex pa; +vertex pb; +vertex pc; +vertex pd; +REAL permanent; +#endif /* not ANSI_DECLARATORS */ + +{ + INEXACT REAL adx, bdx, cdx, ady, bdy, cdy; + REAL det, errbound; + + INEXACT REAL bdxcdy1, cdxbdy1, cdxady1, adxcdy1, adxbdy1, bdxady1; + REAL bdxcdy0, cdxbdy0, cdxady0, adxcdy0, adxbdy0, bdxady0; + REAL bc[4], ca[4], ab[4]; + INEXACT REAL bc3, ca3, ab3; + REAL axbc[8], axxbc[16], aybc[8], ayybc[16], adet[32]; + int axbclen, axxbclen, aybclen, ayybclen, alen; + REAL bxca[8], bxxca[16], byca[8], byyca[16], bdet[32]; + int bxcalen, bxxcalen, bycalen, byycalen, blen; + REAL cxab[8], cxxab[16], cyab[8], cyyab[16], cdet[32]; + int cxablen, cxxablen, cyablen, cyyablen, clen; + REAL abdet[64]; + int ablen; + REAL fin1[1152], fin2[1152]; + REAL *finnow, *finother, *finswap; + int finlength; + + REAL adxtail, bdxtail, cdxtail, adytail, bdytail, cdytail; + INEXACT REAL adxadx1, adyady1, bdxbdx1, bdybdy1, cdxcdx1, cdycdy1; + REAL adxadx0, adyady0, bdxbdx0, bdybdy0, cdxcdx0, cdycdy0; + REAL aa[4], bb[4], cc[4]; + INEXACT REAL aa3, bb3, cc3; + INEXACT REAL ti1, tj1; + REAL ti0, tj0; + REAL u[4], v[4]; + INEXACT REAL u3, v3; + REAL temp8[8], temp16a[16], temp16b[16], temp16c[16]; + REAL temp32a[32], temp32b[32], temp48[48], temp64[64]; + int temp8len, temp16alen, temp16blen, temp16clen; + int temp32alen, temp32blen, temp48len, temp64len; + REAL axtbb[8], axtcc[8], aytbb[8], aytcc[8]; + int axtbblen, axtcclen, aytbblen, aytcclen; + REAL bxtaa[8], bxtcc[8], bytaa[8], bytcc[8]; + int bxtaalen, bxtcclen, bytaalen, bytcclen; + REAL cxtaa[8], cxtbb[8], cytaa[8], cytbb[8]; + int cxtaalen, cxtbblen, cytaalen, cytbblen; + REAL axtbc[8], aytbc[8], bxtca[8], bytca[8], cxtab[8], cytab[8]; + int axtbclen, aytbclen, bxtcalen, bytcalen, cxtablen, cytablen; + REAL axtbct[16], aytbct[16], bxtcat[16], bytcat[16], cxtabt[16], cytabt[16]; + int axtbctlen, aytbctlen, bxtcatlen, bytcatlen, cxtabtlen, cytabtlen; + REAL axtbctt[8], aytbctt[8], bxtcatt[8]; + REAL bytcatt[8], cxtabtt[8], cytabtt[8]; + int axtbcttlen, aytbcttlen, bxtcattlen, bytcattlen, cxtabttlen, cytabttlen; + REAL abt[8], bct[8], cat[8]; + int abtlen, bctlen, catlen; + REAL abtt[4], bctt[4], catt[4]; + int abttlen, bcttlen, cattlen; + INEXACT REAL abtt3, bctt3, catt3; + REAL negate; + + INEXACT REAL bvirt; + REAL avirt, bround, around; + INEXACT REAL c; + INEXACT REAL abig; + REAL ahi, alo, bhi, blo; + REAL err1, err2, err3; + INEXACT REAL _i, _j; + REAL _0; + + adx = (REAL)(pa[0] - pd[0]); + bdx = (REAL)(pb[0] - pd[0]); + cdx = (REAL)(pc[0] - pd[0]); + ady = (REAL)(pa[1] - pd[1]); + bdy = (REAL)(pb[1] - pd[1]); + cdy = (REAL)(pc[1] - pd[1]); + + Two_Product(bdx, cdy, bdxcdy1, bdxcdy0); + Two_Product(cdx, bdy, cdxbdy1, cdxbdy0); + Two_Two_Diff(bdxcdy1, bdxcdy0, cdxbdy1, cdxbdy0, bc3, bc[2], bc[1], bc[0]); + bc[3] = bc3; + axbclen = scale_expansion_zeroelim(4, bc, adx, axbc); + axxbclen = scale_expansion_zeroelim(axbclen, axbc, adx, axxbc); + aybclen = scale_expansion_zeroelim(4, bc, ady, aybc); + ayybclen = scale_expansion_zeroelim(aybclen, aybc, ady, ayybc); + alen = fast_expansion_sum_zeroelim(axxbclen, axxbc, ayybclen, ayybc, adet); + + Two_Product(cdx, ady, cdxady1, cdxady0); + Two_Product(adx, cdy, adxcdy1, adxcdy0); + Two_Two_Diff(cdxady1, cdxady0, adxcdy1, adxcdy0, ca3, ca[2], ca[1], ca[0]); + ca[3] = ca3; + bxcalen = scale_expansion_zeroelim(4, ca, bdx, bxca); + bxxcalen = scale_expansion_zeroelim(bxcalen, bxca, bdx, bxxca); + bycalen = scale_expansion_zeroelim(4, ca, bdy, byca); + byycalen = scale_expansion_zeroelim(bycalen, byca, bdy, byyca); + blen = fast_expansion_sum_zeroelim(bxxcalen, bxxca, byycalen, byyca, bdet); + + Two_Product(adx, bdy, adxbdy1, adxbdy0); + Two_Product(bdx, ady, bdxady1, bdxady0); + Two_Two_Diff(adxbdy1, adxbdy0, bdxady1, bdxady0, ab3, ab[2], ab[1], ab[0]); + ab[3] = ab3; + cxablen = scale_expansion_zeroelim(4, ab, cdx, cxab); + cxxablen = scale_expansion_zeroelim(cxablen, cxab, cdx, cxxab); + cyablen = scale_expansion_zeroelim(4, ab, cdy, cyab); + cyyablen = scale_expansion_zeroelim(cyablen, cyab, cdy, cyyab); + clen = fast_expansion_sum_zeroelim(cxxablen, cxxab, cyyablen, cyyab, cdet); + + ablen = fast_expansion_sum_zeroelim(alen, adet, blen, bdet, abdet); + finlength = fast_expansion_sum_zeroelim(ablen, abdet, clen, cdet, fin1); + + det = estimate(finlength, fin1); + errbound = iccerrboundB * permanent; + if ((det >= errbound) || (-det >= errbound)) { + return det; + } + + Two_Diff_Tail(pa[0], pd[0], adx, adxtail); + Two_Diff_Tail(pa[1], pd[1], ady, adytail); + Two_Diff_Tail(pb[0], pd[0], bdx, bdxtail); + Two_Diff_Tail(pb[1], pd[1], bdy, bdytail); + Two_Diff_Tail(pc[0], pd[0], cdx, cdxtail); + Two_Diff_Tail(pc[1], pd[1], cdy, cdytail); + if ((adxtail == 0.0) && (bdxtail == 0.0) && (cdxtail == 0.0) && + (adytail == 0.0) && (bdytail == 0.0) && (cdytail == 0.0)) { + return det; + } + + errbound = iccerrboundC * permanent + resulterrbound * Absolute(det); + det += + ((adx * adx + ady * ady) * + ((bdx * cdytail + cdy * bdxtail) - (bdy * cdxtail + cdx * bdytail)) + + 2.0 * (adx * adxtail + ady * adytail) * (bdx * cdy - bdy * cdx)) + + ((bdx * bdx + bdy * bdy) * + ((cdx * adytail + ady * cdxtail) - (cdy * adxtail + adx * cdytail)) + + 2.0 * (bdx * bdxtail + bdy * bdytail) * (cdx * ady - cdy * adx)) + + ((cdx * cdx + cdy * cdy) * + ((adx * bdytail + bdy * adxtail) - (ady * bdxtail + bdx * adytail)) + + 2.0 * (cdx * cdxtail + cdy * cdytail) * (adx * bdy - ady * bdx)); + if ((det >= errbound) || (-det >= errbound)) { + return det; + } + + finnow = fin1; + finother = fin2; + + if ((bdxtail != 0.0) || (bdytail != 0.0) || (cdxtail != 0.0) || + (cdytail != 0.0)) { + Square(adx, adxadx1, adxadx0); + Square(ady, adyady1, adyady0); + Two_Two_Sum(adxadx1, adxadx0, adyady1, adyady0, aa3, aa[2], aa[1], aa[0]); + aa[3] = aa3; + } + if ((cdxtail != 0.0) || (cdytail != 0.0) || (adxtail != 0.0) || + (adytail != 0.0)) { + Square(bdx, bdxbdx1, bdxbdx0); + Square(bdy, bdybdy1, bdybdy0); + Two_Two_Sum(bdxbdx1, bdxbdx0, bdybdy1, bdybdy0, bb3, bb[2], bb[1], bb[0]); + bb[3] = bb3; + } + if ((adxtail != 0.0) || (adytail != 0.0) || (bdxtail != 0.0) || + (bdytail != 0.0)) { + Square(cdx, cdxcdx1, cdxcdx0); + Square(cdy, cdycdy1, cdycdy0); + Two_Two_Sum(cdxcdx1, cdxcdx0, cdycdy1, cdycdy0, cc3, cc[2], cc[1], cc[0]); + cc[3] = cc3; + } + + if (adxtail != 0.0) { + axtbclen = scale_expansion_zeroelim(4, bc, adxtail, axtbc); + temp16alen = scale_expansion_zeroelim(axtbclen, axtbc, 2.0 * adx, temp16a); + + axtcclen = scale_expansion_zeroelim(4, cc, adxtail, axtcc); + temp16blen = scale_expansion_zeroelim(axtcclen, axtcc, bdy, temp16b); + + axtbblen = scale_expansion_zeroelim(4, bb, adxtail, axtbb); + temp16clen = scale_expansion_zeroelim(axtbblen, axtbb, -cdy, temp16c); + + temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (adytail != 0.0) { + aytbclen = scale_expansion_zeroelim(4, bc, adytail, aytbc); + temp16alen = scale_expansion_zeroelim(aytbclen, aytbc, 2.0 * ady, temp16a); + + aytbblen = scale_expansion_zeroelim(4, bb, adytail, aytbb); + temp16blen = scale_expansion_zeroelim(aytbblen, aytbb, cdx, temp16b); + + aytcclen = scale_expansion_zeroelim(4, cc, adytail, aytcc); + temp16clen = scale_expansion_zeroelim(aytcclen, aytcc, -bdx, temp16c); + + temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (bdxtail != 0.0) { + bxtcalen = scale_expansion_zeroelim(4, ca, bdxtail, bxtca); + temp16alen = scale_expansion_zeroelim(bxtcalen, bxtca, 2.0 * bdx, temp16a); + + bxtaalen = scale_expansion_zeroelim(4, aa, bdxtail, bxtaa); + temp16blen = scale_expansion_zeroelim(bxtaalen, bxtaa, cdy, temp16b); + + bxtcclen = scale_expansion_zeroelim(4, cc, bdxtail, bxtcc); + temp16clen = scale_expansion_zeroelim(bxtcclen, bxtcc, -ady, temp16c); + + temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (bdytail != 0.0) { + bytcalen = scale_expansion_zeroelim(4, ca, bdytail, bytca); + temp16alen = scale_expansion_zeroelim(bytcalen, bytca, 2.0 * bdy, temp16a); + + bytcclen = scale_expansion_zeroelim(4, cc, bdytail, bytcc); + temp16blen = scale_expansion_zeroelim(bytcclen, bytcc, adx, temp16b); + + bytaalen = scale_expansion_zeroelim(4, aa, bdytail, bytaa); + temp16clen = scale_expansion_zeroelim(bytaalen, bytaa, -cdx, temp16c); + + temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (cdxtail != 0.0) { + cxtablen = scale_expansion_zeroelim(4, ab, cdxtail, cxtab); + temp16alen = scale_expansion_zeroelim(cxtablen, cxtab, 2.0 * cdx, temp16a); + + cxtbblen = scale_expansion_zeroelim(4, bb, cdxtail, cxtbb); + temp16blen = scale_expansion_zeroelim(cxtbblen, cxtbb, ady, temp16b); + + cxtaalen = scale_expansion_zeroelim(4, aa, cdxtail, cxtaa); + temp16clen = scale_expansion_zeroelim(cxtaalen, cxtaa, -bdy, temp16c); + + temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (cdytail != 0.0) { + cytablen = scale_expansion_zeroelim(4, ab, cdytail, cytab); + temp16alen = scale_expansion_zeroelim(cytablen, cytab, 2.0 * cdy, temp16a); + + cytaalen = scale_expansion_zeroelim(4, aa, cdytail, cytaa); + temp16blen = scale_expansion_zeroelim(cytaalen, cytaa, bdx, temp16b); + + cytbblen = scale_expansion_zeroelim(4, bb, cdytail, cytbb); + temp16clen = scale_expansion_zeroelim(cytbblen, cytbb, -adx, temp16c); + + temp32alen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16clen, temp16c, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + + if ((adxtail != 0.0) || (adytail != 0.0)) { + if ((bdxtail != 0.0) || (bdytail != 0.0) || (cdxtail != 0.0) || + (cdytail != 0.0)) { + Two_Product(bdxtail, cdy, ti1, ti0); + Two_Product(bdx, cdytail, tj1, tj0); + Two_Two_Sum(ti1, ti0, tj1, tj0, u3, u[2], u[1], u[0]); + u[3] = u3; + negate = -bdy; + Two_Product(cdxtail, negate, ti1, ti0); + negate = -bdytail; + Two_Product(cdx, negate, tj1, tj0); + Two_Two_Sum(ti1, ti0, tj1, tj0, v3, v[2], v[1], v[0]); + v[3] = v3; + bctlen = fast_expansion_sum_zeroelim(4, u, 4, v, bct); + + Two_Product(bdxtail, cdytail, ti1, ti0); + Two_Product(cdxtail, bdytail, tj1, tj0); + Two_Two_Diff(ti1, ti0, tj1, tj0, bctt3, bctt[2], bctt[1], bctt[0]); + bctt[3] = bctt3; + bcttlen = 4; + } else { + bct[0] = 0.0; + bctlen = 1; + bctt[0] = 0.0; + bcttlen = 1; + } + + if (adxtail != 0.0) { + temp16alen = scale_expansion_zeroelim(axtbclen, axtbc, adxtail, temp16a); + axtbctlen = scale_expansion_zeroelim(bctlen, bct, adxtail, axtbct); + temp32alen = + scale_expansion_zeroelim(axtbctlen, axtbct, 2.0 * adx, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (bdytail != 0.0) { + temp8len = scale_expansion_zeroelim(4, cc, adxtail, temp8); + temp16alen = + scale_expansion_zeroelim(temp8len, temp8, bdytail, temp16a); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, + temp16a, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (cdytail != 0.0) { + temp8len = scale_expansion_zeroelim(4, bb, -adxtail, temp8); + temp16alen = + scale_expansion_zeroelim(temp8len, temp8, cdytail, temp16a); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, + temp16a, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + + temp32alen = + scale_expansion_zeroelim(axtbctlen, axtbct, adxtail, temp32a); + axtbcttlen = scale_expansion_zeroelim(bcttlen, bctt, adxtail, axtbctt); + temp16alen = + scale_expansion_zeroelim(axtbcttlen, axtbctt, 2.0 * adx, temp16a); + temp16blen = + scale_expansion_zeroelim(axtbcttlen, axtbctt, adxtail, temp16b); + temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32b); + temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, + temp32b, temp64); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, + temp64, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (adytail != 0.0) { + temp16alen = scale_expansion_zeroelim(aytbclen, aytbc, adytail, temp16a); + aytbctlen = scale_expansion_zeroelim(bctlen, bct, adytail, aytbct); + temp32alen = + scale_expansion_zeroelim(aytbctlen, aytbct, 2.0 * ady, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + + temp32alen = + scale_expansion_zeroelim(aytbctlen, aytbct, adytail, temp32a); + aytbcttlen = scale_expansion_zeroelim(bcttlen, bctt, adytail, aytbctt); + temp16alen = + scale_expansion_zeroelim(aytbcttlen, aytbctt, 2.0 * ady, temp16a); + temp16blen = + scale_expansion_zeroelim(aytbcttlen, aytbctt, adytail, temp16b); + temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32b); + temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, + temp32b, temp64); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, + temp64, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + if ((bdxtail != 0.0) || (bdytail != 0.0)) { + if ((cdxtail != 0.0) || (cdytail != 0.0) || (adxtail != 0.0) || + (adytail != 0.0)) { + Two_Product(cdxtail, ady, ti1, ti0); + Two_Product(cdx, adytail, tj1, tj0); + Two_Two_Sum(ti1, ti0, tj1, tj0, u3, u[2], u[1], u[0]); + u[3] = u3; + negate = -cdy; + Two_Product(adxtail, negate, ti1, ti0); + negate = -cdytail; + Two_Product(adx, negate, tj1, tj0); + Two_Two_Sum(ti1, ti0, tj1, tj0, v3, v[2], v[1], v[0]); + v[3] = v3; + catlen = fast_expansion_sum_zeroelim(4, u, 4, v, cat); + + Two_Product(cdxtail, adytail, ti1, ti0); + Two_Product(adxtail, cdytail, tj1, tj0); + Two_Two_Diff(ti1, ti0, tj1, tj0, catt3, catt[2], catt[1], catt[0]); + catt[3] = catt3; + cattlen = 4; + } else { + cat[0] = 0.0; + catlen = 1; + catt[0] = 0.0; + cattlen = 1; + } + + if (bdxtail != 0.0) { + temp16alen = scale_expansion_zeroelim(bxtcalen, bxtca, bdxtail, temp16a); + bxtcatlen = scale_expansion_zeroelim(catlen, cat, bdxtail, bxtcat); + temp32alen = + scale_expansion_zeroelim(bxtcatlen, bxtcat, 2.0 * bdx, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (cdytail != 0.0) { + temp8len = scale_expansion_zeroelim(4, aa, bdxtail, temp8); + temp16alen = + scale_expansion_zeroelim(temp8len, temp8, cdytail, temp16a); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, + temp16a, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (adytail != 0.0) { + temp8len = scale_expansion_zeroelim(4, cc, -bdxtail, temp8); + temp16alen = + scale_expansion_zeroelim(temp8len, temp8, adytail, temp16a); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, + temp16a, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + + temp32alen = + scale_expansion_zeroelim(bxtcatlen, bxtcat, bdxtail, temp32a); + bxtcattlen = scale_expansion_zeroelim(cattlen, catt, bdxtail, bxtcatt); + temp16alen = + scale_expansion_zeroelim(bxtcattlen, bxtcatt, 2.0 * bdx, temp16a); + temp16blen = + scale_expansion_zeroelim(bxtcattlen, bxtcatt, bdxtail, temp16b); + temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32b); + temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, + temp32b, temp64); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, + temp64, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (bdytail != 0.0) { + temp16alen = scale_expansion_zeroelim(bytcalen, bytca, bdytail, temp16a); + bytcatlen = scale_expansion_zeroelim(catlen, cat, bdytail, bytcat); + temp32alen = + scale_expansion_zeroelim(bytcatlen, bytcat, 2.0 * bdy, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + + temp32alen = + scale_expansion_zeroelim(bytcatlen, bytcat, bdytail, temp32a); + bytcattlen = scale_expansion_zeroelim(cattlen, catt, bdytail, bytcatt); + temp16alen = + scale_expansion_zeroelim(bytcattlen, bytcatt, 2.0 * bdy, temp16a); + temp16blen = + scale_expansion_zeroelim(bytcattlen, bytcatt, bdytail, temp16b); + temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32b); + temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, + temp32b, temp64); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, + temp64, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + if ((cdxtail != 0.0) || (cdytail != 0.0)) { + if ((adxtail != 0.0) || (adytail != 0.0) || (bdxtail != 0.0) || + (bdytail != 0.0)) { + Two_Product(adxtail, bdy, ti1, ti0); + Two_Product(adx, bdytail, tj1, tj0); + Two_Two_Sum(ti1, ti0, tj1, tj0, u3, u[2], u[1], u[0]); + u[3] = u3; + negate = -ady; + Two_Product(bdxtail, negate, ti1, ti0); + negate = -adytail; + Two_Product(bdx, negate, tj1, tj0); + Two_Two_Sum(ti1, ti0, tj1, tj0, v3, v[2], v[1], v[0]); + v[3] = v3; + abtlen = fast_expansion_sum_zeroelim(4, u, 4, v, abt); + + Two_Product(adxtail, bdytail, ti1, ti0); + Two_Product(bdxtail, adytail, tj1, tj0); + Two_Two_Diff(ti1, ti0, tj1, tj0, abtt3, abtt[2], abtt[1], abtt[0]); + abtt[3] = abtt3; + abttlen = 4; + } else { + abt[0] = 0.0; + abtlen = 1; + abtt[0] = 0.0; + abttlen = 1; + } + + if (cdxtail != 0.0) { + temp16alen = scale_expansion_zeroelim(cxtablen, cxtab, cdxtail, temp16a); + cxtabtlen = scale_expansion_zeroelim(abtlen, abt, cdxtail, cxtabt); + temp32alen = + scale_expansion_zeroelim(cxtabtlen, cxtabt, 2.0 * cdx, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (adytail != 0.0) { + temp8len = scale_expansion_zeroelim(4, bb, cdxtail, temp8); + temp16alen = + scale_expansion_zeroelim(temp8len, temp8, adytail, temp16a); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, + temp16a, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (bdytail != 0.0) { + temp8len = scale_expansion_zeroelim(4, aa, -cdxtail, temp8); + temp16alen = + scale_expansion_zeroelim(temp8len, temp8, bdytail, temp16a); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp16alen, + temp16a, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + + temp32alen = + scale_expansion_zeroelim(cxtabtlen, cxtabt, cdxtail, temp32a); + cxtabttlen = scale_expansion_zeroelim(abttlen, abtt, cdxtail, cxtabtt); + temp16alen = + scale_expansion_zeroelim(cxtabttlen, cxtabtt, 2.0 * cdx, temp16a); + temp16blen = + scale_expansion_zeroelim(cxtabttlen, cxtabtt, cdxtail, temp16b); + temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32b); + temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, + temp32b, temp64); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, + temp64, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (cdytail != 0.0) { + temp16alen = scale_expansion_zeroelim(cytablen, cytab, cdytail, temp16a); + cytabtlen = scale_expansion_zeroelim(abtlen, abt, cdytail, cytabt); + temp32alen = + scale_expansion_zeroelim(cytabtlen, cytabt, 2.0 * cdy, temp32a); + temp48len = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp32alen, + temp32a, temp48); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp48len, + temp48, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + + temp32alen = + scale_expansion_zeroelim(cytabtlen, cytabt, cdytail, temp32a); + cytabttlen = scale_expansion_zeroelim(abttlen, abtt, cdytail, cytabtt); + temp16alen = + scale_expansion_zeroelim(cytabttlen, cytabtt, 2.0 * cdy, temp16a); + temp16blen = + scale_expansion_zeroelim(cytabttlen, cytabtt, cdytail, temp16b); + temp32blen = fast_expansion_sum_zeroelim(temp16alen, temp16a, temp16blen, + temp16b, temp32b); + temp64len = fast_expansion_sum_zeroelim(temp32alen, temp32a, temp32blen, + temp32b, temp64); + finlength = fast_expansion_sum_zeroelim(finlength, finnow, temp64len, + temp64, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + + return finnow[finlength - 1]; +} + +#ifdef ANSI_DECLARATORS +REAL incircle(struct mesh *m, struct behavior *b, vertex pa, vertex pb, + vertex pc, vertex pd) +#else /* not ANSI_DECLARATORS */ +REAL incircle(m, b, pa, pb, pc, pd) +struct mesh *m; +struct behavior *b; +vertex pa; +vertex pb; +vertex pc; +vertex pd; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL adx, bdx, cdx, ady, bdy, cdy; + REAL bdxcdy, cdxbdy, cdxady, adxcdy, adxbdy, bdxady; + REAL alift, blift, clift; + REAL det; + REAL permanent, errbound; + + m->incirclecount++; + + adx = pa[0] - pd[0]; + bdx = pb[0] - pd[0]; + cdx = pc[0] - pd[0]; + ady = pa[1] - pd[1]; + bdy = pb[1] - pd[1]; + cdy = pc[1] - pd[1]; + + bdxcdy = bdx * cdy; + cdxbdy = cdx * bdy; + alift = adx * adx + ady * ady; + + cdxady = cdx * ady; + adxcdy = adx * cdy; + blift = bdx * bdx + bdy * bdy; + + adxbdy = adx * bdy; + bdxady = bdx * ady; + clift = cdx * cdx + cdy * cdy; + + det = alift * (bdxcdy - cdxbdy) + blift * (cdxady - adxcdy) + + clift * (adxbdy - bdxady); + + if (b->noexact) { + return det; + } + + permanent = (Absolute(bdxcdy) + Absolute(cdxbdy)) * alift + + (Absolute(cdxady) + Absolute(adxcdy)) * blift + + (Absolute(adxbdy) + Absolute(bdxady)) * clift; + errbound = iccerrboundA * permanent; + if ((det > errbound) || (-det > errbound)) { + return det; + } + + return incircleadapt(pa, pb, pc, pd, permanent); +} + +/*****************************************************************************/ +/* */ +/* orient3d() Return a positive value if the point pd lies below the */ +/* plane passing through pa, pb, and pc; "below" is defined so */ +/* that pa, pb, and pc appear in counterclockwise order when */ +/* viewed from above the plane. Returns a negative value if */ +/* pd lies above the plane. Returns zero if the points are */ +/* coplanar. The result is also a rough approximation of six */ +/* times the signed volume of the tetrahedron defined by the */ +/* four points. */ +/* */ +/* Uses exact arithmetic if necessary to ensure a correct answer. The */ +/* result returned is the determinant of a matrix. This determinant is */ +/* computed adaptively, in the sense that exact arithmetic is used only to */ +/* the degree it is needed to ensure that the returned value has the */ +/* correct sign. Hence, this function is usually quite fast, but will run */ +/* more slowly when the input points are coplanar or nearly so. */ +/* */ +/* See my Robust Predicates paper for details. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +REAL orient3dadapt(vertex pa, vertex pb, vertex pc, vertex pd, REAL aheight, + REAL bheight, REAL cheight, REAL dheight, REAL permanent) +#else /* not ANSI_DECLARATORS */ +REAL orient3dadapt(pa, pb, pc, pd, aheight, bheight, cheight, dheight, + permanent) +vertex pa; +vertex pb; +vertex pc; +vertex pd; +REAL aheight; +REAL bheight; +REAL cheight; +REAL dheight; +REAL permanent; +#endif /* not ANSI_DECLARATORS */ + +{ + INEXACT REAL adx, bdx, cdx, ady, bdy, cdy, adheight, bdheight, cdheight; + REAL det, errbound; + + INEXACT REAL bdxcdy1, cdxbdy1, cdxady1, adxcdy1, adxbdy1, bdxady1; + REAL bdxcdy0, cdxbdy0, cdxady0, adxcdy0, adxbdy0, bdxady0; + REAL bc[4], ca[4], ab[4]; + INEXACT REAL bc3, ca3, ab3; + REAL adet[8], bdet[8], cdet[8]; + int alen, blen, clen; + REAL abdet[16]; + int ablen; + REAL *finnow, *finother, *finswap; + REAL fin1[192], fin2[192]; + int finlength; + + REAL adxtail, bdxtail, cdxtail; + REAL adytail, bdytail, cdytail; + REAL adheighttail, bdheighttail, cdheighttail; + INEXACT REAL at_blarge, at_clarge; + INEXACT REAL bt_clarge, bt_alarge; + INEXACT REAL ct_alarge, ct_blarge; + REAL at_b[4], at_c[4], bt_c[4], bt_a[4], ct_a[4], ct_b[4]; + int at_blen, at_clen, bt_clen, bt_alen, ct_alen, ct_blen; + INEXACT REAL bdxt_cdy1, cdxt_bdy1, cdxt_ady1; + INEXACT REAL adxt_cdy1, adxt_bdy1, bdxt_ady1; + REAL bdxt_cdy0, cdxt_bdy0, cdxt_ady0; + REAL adxt_cdy0, adxt_bdy0, bdxt_ady0; + INEXACT REAL bdyt_cdx1, cdyt_bdx1, cdyt_adx1; + INEXACT REAL adyt_cdx1, adyt_bdx1, bdyt_adx1; + REAL bdyt_cdx0, cdyt_bdx0, cdyt_adx0; + REAL adyt_cdx0, adyt_bdx0, bdyt_adx0; + REAL bct[8], cat[8], abt[8]; + int bctlen, catlen, abtlen; + INEXACT REAL bdxt_cdyt1, cdxt_bdyt1, cdxt_adyt1; + INEXACT REAL adxt_cdyt1, adxt_bdyt1, bdxt_adyt1; + REAL bdxt_cdyt0, cdxt_bdyt0, cdxt_adyt0; + REAL adxt_cdyt0, adxt_bdyt0, bdxt_adyt0; + REAL u[4], v[12], w[16]; + INEXACT REAL u3; + int vlength, wlength; + REAL negate; + + INEXACT REAL bvirt; + REAL avirt, bround, around; + INEXACT REAL c; + INEXACT REAL abig; + REAL ahi, alo, bhi, blo; + REAL err1, err2, err3; + INEXACT REAL _i, _j, _k; + REAL _0; + + adx = (REAL)(pa[0] - pd[0]); + bdx = (REAL)(pb[0] - pd[0]); + cdx = (REAL)(pc[0] - pd[0]); + ady = (REAL)(pa[1] - pd[1]); + bdy = (REAL)(pb[1] - pd[1]); + cdy = (REAL)(pc[1] - pd[1]); + adheight = (REAL)(aheight - dheight); + bdheight = (REAL)(bheight - dheight); + cdheight = (REAL)(cheight - dheight); + + Two_Product(bdx, cdy, bdxcdy1, bdxcdy0); + Two_Product(cdx, bdy, cdxbdy1, cdxbdy0); + Two_Two_Diff(bdxcdy1, bdxcdy0, cdxbdy1, cdxbdy0, bc3, bc[2], bc[1], bc[0]); + bc[3] = bc3; + alen = scale_expansion_zeroelim(4, bc, adheight, adet); + + Two_Product(cdx, ady, cdxady1, cdxady0); + Two_Product(adx, cdy, adxcdy1, adxcdy0); + Two_Two_Diff(cdxady1, cdxady0, adxcdy1, adxcdy0, ca3, ca[2], ca[1], ca[0]); + ca[3] = ca3; + blen = scale_expansion_zeroelim(4, ca, bdheight, bdet); + + Two_Product(adx, bdy, adxbdy1, adxbdy0); + Two_Product(bdx, ady, bdxady1, bdxady0); + Two_Two_Diff(adxbdy1, adxbdy0, bdxady1, bdxady0, ab3, ab[2], ab[1], ab[0]); + ab[3] = ab3; + clen = scale_expansion_zeroelim(4, ab, cdheight, cdet); + + ablen = fast_expansion_sum_zeroelim(alen, adet, blen, bdet, abdet); + finlength = fast_expansion_sum_zeroelim(ablen, abdet, clen, cdet, fin1); + + det = estimate(finlength, fin1); + errbound = o3derrboundB * permanent; + if ((det >= errbound) || (-det >= errbound)) { + return det; + } + + Two_Diff_Tail(pa[0], pd[0], adx, adxtail); + Two_Diff_Tail(pb[0], pd[0], bdx, bdxtail); + Two_Diff_Tail(pc[0], pd[0], cdx, cdxtail); + Two_Diff_Tail(pa[1], pd[1], ady, adytail); + Two_Diff_Tail(pb[1], pd[1], bdy, bdytail); + Two_Diff_Tail(pc[1], pd[1], cdy, cdytail); + Two_Diff_Tail(aheight, dheight, adheight, adheighttail); + Two_Diff_Tail(bheight, dheight, bdheight, bdheighttail); + Two_Diff_Tail(cheight, dheight, cdheight, cdheighttail); + + if ((adxtail == 0.0) && (bdxtail == 0.0) && (cdxtail == 0.0) && + (adytail == 0.0) && (bdytail == 0.0) && (cdytail == 0.0) && + (adheighttail == 0.0) && (bdheighttail == 0.0) && (cdheighttail == 0.0)) { + return det; + } + + errbound = o3derrboundC * permanent + resulterrbound * Absolute(det); + det += + (adheight * + ((bdx * cdytail + cdy * bdxtail) - (bdy * cdxtail + cdx * bdytail)) + + adheighttail * (bdx * cdy - bdy * cdx)) + + (bdheight * + ((cdx * adytail + ady * cdxtail) - (cdy * adxtail + adx * cdytail)) + + bdheighttail * (cdx * ady - cdy * adx)) + + (cdheight * + ((adx * bdytail + bdy * adxtail) - (ady * bdxtail + bdx * adytail)) + + cdheighttail * (adx * bdy - ady * bdx)); + if ((det >= errbound) || (-det >= errbound)) { + return det; + } + + finnow = fin1; + finother = fin2; + + if (adxtail == 0.0) { + if (adytail == 0.0) { + at_b[0] = 0.0; + at_blen = 1; + at_c[0] = 0.0; + at_clen = 1; + } else { + negate = -adytail; + Two_Product(negate, bdx, at_blarge, at_b[0]); + at_b[1] = at_blarge; + at_blen = 2; + Two_Product(adytail, cdx, at_clarge, at_c[0]); + at_c[1] = at_clarge; + at_clen = 2; + } + } else { + if (adytail == 0.0) { + Two_Product(adxtail, bdy, at_blarge, at_b[0]); + at_b[1] = at_blarge; + at_blen = 2; + negate = -adxtail; + Two_Product(negate, cdy, at_clarge, at_c[0]); + at_c[1] = at_clarge; + at_clen = 2; + } else { + Two_Product(adxtail, bdy, adxt_bdy1, adxt_bdy0); + Two_Product(adytail, bdx, adyt_bdx1, adyt_bdx0); + Two_Two_Diff(adxt_bdy1, adxt_bdy0, adyt_bdx1, adyt_bdx0, at_blarge, + at_b[2], at_b[1], at_b[0]); + at_b[3] = at_blarge; + at_blen = 4; + Two_Product(adytail, cdx, adyt_cdx1, adyt_cdx0); + Two_Product(adxtail, cdy, adxt_cdy1, adxt_cdy0); + Two_Two_Diff(adyt_cdx1, adyt_cdx0, adxt_cdy1, adxt_cdy0, at_clarge, + at_c[2], at_c[1], at_c[0]); + at_c[3] = at_clarge; + at_clen = 4; + } + } + if (bdxtail == 0.0) { + if (bdytail == 0.0) { + bt_c[0] = 0.0; + bt_clen = 1; + bt_a[0] = 0.0; + bt_alen = 1; + } else { + negate = -bdytail; + Two_Product(negate, cdx, bt_clarge, bt_c[0]); + bt_c[1] = bt_clarge; + bt_clen = 2; + Two_Product(bdytail, adx, bt_alarge, bt_a[0]); + bt_a[1] = bt_alarge; + bt_alen = 2; + } + } else { + if (bdytail == 0.0) { + Two_Product(bdxtail, cdy, bt_clarge, bt_c[0]); + bt_c[1] = bt_clarge; + bt_clen = 2; + negate = -bdxtail; + Two_Product(negate, ady, bt_alarge, bt_a[0]); + bt_a[1] = bt_alarge; + bt_alen = 2; + } else { + Two_Product(bdxtail, cdy, bdxt_cdy1, bdxt_cdy0); + Two_Product(bdytail, cdx, bdyt_cdx1, bdyt_cdx0); + Two_Two_Diff(bdxt_cdy1, bdxt_cdy0, bdyt_cdx1, bdyt_cdx0, bt_clarge, + bt_c[2], bt_c[1], bt_c[0]); + bt_c[3] = bt_clarge; + bt_clen = 4; + Two_Product(bdytail, adx, bdyt_adx1, bdyt_adx0); + Two_Product(bdxtail, ady, bdxt_ady1, bdxt_ady0); + Two_Two_Diff(bdyt_adx1, bdyt_adx0, bdxt_ady1, bdxt_ady0, bt_alarge, + bt_a[2], bt_a[1], bt_a[0]); + bt_a[3] = bt_alarge; + bt_alen = 4; + } + } + if (cdxtail == 0.0) { + if (cdytail == 0.0) { + ct_a[0] = 0.0; + ct_alen = 1; + ct_b[0] = 0.0; + ct_blen = 1; + } else { + negate = -cdytail; + Two_Product(negate, adx, ct_alarge, ct_a[0]); + ct_a[1] = ct_alarge; + ct_alen = 2; + Two_Product(cdytail, bdx, ct_blarge, ct_b[0]); + ct_b[1] = ct_blarge; + ct_blen = 2; + } + } else { + if (cdytail == 0.0) { + Two_Product(cdxtail, ady, ct_alarge, ct_a[0]); + ct_a[1] = ct_alarge; + ct_alen = 2; + negate = -cdxtail; + Two_Product(negate, bdy, ct_blarge, ct_b[0]); + ct_b[1] = ct_blarge; + ct_blen = 2; + } else { + Two_Product(cdxtail, ady, cdxt_ady1, cdxt_ady0); + Two_Product(cdytail, adx, cdyt_adx1, cdyt_adx0); + Two_Two_Diff(cdxt_ady1, cdxt_ady0, cdyt_adx1, cdyt_adx0, ct_alarge, + ct_a[2], ct_a[1], ct_a[0]); + ct_a[3] = ct_alarge; + ct_alen = 4; + Two_Product(cdytail, bdx, cdyt_bdx1, cdyt_bdx0); + Two_Product(cdxtail, bdy, cdxt_bdy1, cdxt_bdy0); + Two_Two_Diff(cdyt_bdx1, cdyt_bdx0, cdxt_bdy1, cdxt_bdy0, ct_blarge, + ct_b[2], ct_b[1], ct_b[0]); + ct_b[3] = ct_blarge; + ct_blen = 4; + } + } + + bctlen = fast_expansion_sum_zeroelim(bt_clen, bt_c, ct_blen, ct_b, bct); + wlength = scale_expansion_zeroelim(bctlen, bct, adheight, w); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + + catlen = fast_expansion_sum_zeroelim(ct_alen, ct_a, at_clen, at_c, cat); + wlength = scale_expansion_zeroelim(catlen, cat, bdheight, w); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + + abtlen = fast_expansion_sum_zeroelim(at_blen, at_b, bt_alen, bt_a, abt); + wlength = scale_expansion_zeroelim(abtlen, abt, cdheight, w); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + + if (adheighttail != 0.0) { + vlength = scale_expansion_zeroelim(4, bc, adheighttail, v); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, vlength, v, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (bdheighttail != 0.0) { + vlength = scale_expansion_zeroelim(4, ca, bdheighttail, v); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, vlength, v, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (cdheighttail != 0.0) { + vlength = scale_expansion_zeroelim(4, ab, cdheighttail, v); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, vlength, v, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + + if (adxtail != 0.0) { + if (bdytail != 0.0) { + Two_Product(adxtail, bdytail, adxt_bdyt1, adxt_bdyt0); + Two_One_Product(adxt_bdyt1, adxt_bdyt0, cdheight, u3, u[2], u[1], u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (cdheighttail != 0.0) { + Two_One_Product(adxt_bdyt1, adxt_bdyt0, cdheighttail, u3, u[2], u[1], + u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + if (cdytail != 0.0) { + negate = -adxtail; + Two_Product(negate, cdytail, adxt_cdyt1, adxt_cdyt0); + Two_One_Product(adxt_cdyt1, adxt_cdyt0, bdheight, u3, u[2], u[1], u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (bdheighttail != 0.0) { + Two_One_Product(adxt_cdyt1, adxt_cdyt0, bdheighttail, u3, u[2], u[1], + u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + } + if (bdxtail != 0.0) { + if (cdytail != 0.0) { + Two_Product(bdxtail, cdytail, bdxt_cdyt1, bdxt_cdyt0); + Two_One_Product(bdxt_cdyt1, bdxt_cdyt0, adheight, u3, u[2], u[1], u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (adheighttail != 0.0) { + Two_One_Product(bdxt_cdyt1, bdxt_cdyt0, adheighttail, u3, u[2], u[1], + u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + if (adytail != 0.0) { + negate = -bdxtail; + Two_Product(negate, adytail, bdxt_adyt1, bdxt_adyt0); + Two_One_Product(bdxt_adyt1, bdxt_adyt0, cdheight, u3, u[2], u[1], u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (cdheighttail != 0.0) { + Two_One_Product(bdxt_adyt1, bdxt_adyt0, cdheighttail, u3, u[2], u[1], + u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + } + if (cdxtail != 0.0) { + if (adytail != 0.0) { + Two_Product(cdxtail, adytail, cdxt_adyt1, cdxt_adyt0); + Two_One_Product(cdxt_adyt1, cdxt_adyt0, bdheight, u3, u[2], u[1], u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (bdheighttail != 0.0) { + Two_One_Product(cdxt_adyt1, cdxt_adyt0, bdheighttail, u3, u[2], u[1], + u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + if (bdytail != 0.0) { + negate = -cdxtail; + Two_Product(negate, bdytail, cdxt_bdyt1, cdxt_bdyt0); + Two_One_Product(cdxt_bdyt1, cdxt_bdyt0, adheight, u3, u[2], u[1], u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + if (adheighttail != 0.0) { + Two_One_Product(cdxt_bdyt1, cdxt_bdyt0, adheighttail, u3, u[2], u[1], + u[0]); + u[3] = u3; + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, 4, u, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + } + } + + if (adheighttail != 0.0) { + wlength = scale_expansion_zeroelim(bctlen, bct, adheighttail, w); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (bdheighttail != 0.0) { + wlength = scale_expansion_zeroelim(catlen, cat, bdheighttail, w); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + if (cdheighttail != 0.0) { + wlength = scale_expansion_zeroelim(abtlen, abt, cdheighttail, w); + finlength = + fast_expansion_sum_zeroelim(finlength, finnow, wlength, w, finother); + finswap = finnow; + finnow = finother; + finother = finswap; + } + + return finnow[finlength - 1]; +} + +#ifdef ANSI_DECLARATORS +REAL orient3d(struct mesh *m, struct behavior *b, vertex pa, vertex pb, + vertex pc, vertex pd, REAL aheight, REAL bheight, REAL cheight, + REAL dheight) +#else /* not ANSI_DECLARATORS */ +REAL orient3d(m, b, pa, pb, pc, pd, aheight, bheight, cheight, dheight) +struct mesh *m; +struct behavior *b; +vertex pa; +vertex pb; +vertex pc; +vertex pd; +REAL aheight; +REAL bheight; +REAL cheight; +REAL dheight; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL adx, bdx, cdx, ady, bdy, cdy, adheight, bdheight, cdheight; + REAL bdxcdy, cdxbdy, cdxady, adxcdy, adxbdy, bdxady; + REAL det; + REAL permanent, errbound; + + m->orient3dcount++; + + adx = pa[0] - pd[0]; + bdx = pb[0] - pd[0]; + cdx = pc[0] - pd[0]; + ady = pa[1] - pd[1]; + bdy = pb[1] - pd[1]; + cdy = pc[1] - pd[1]; + adheight = aheight - dheight; + bdheight = bheight - dheight; + cdheight = cheight - dheight; + + bdxcdy = bdx * cdy; + cdxbdy = cdx * bdy; + + cdxady = cdx * ady; + adxcdy = adx * cdy; + + adxbdy = adx * bdy; + bdxady = bdx * ady; + + det = adheight * (bdxcdy - cdxbdy) + bdheight * (cdxady - adxcdy) + + cdheight * (adxbdy - bdxady); + + if (b->noexact) { + return det; + } + + permanent = (Absolute(bdxcdy) + Absolute(cdxbdy)) * Absolute(adheight) + + (Absolute(cdxady) + Absolute(adxcdy)) * Absolute(bdheight) + + (Absolute(adxbdy) + Absolute(bdxady)) * Absolute(cdheight); + errbound = o3derrboundA * permanent; + if ((det > errbound) || (-det > errbound)) { + return det; + } + + return orient3dadapt(pa, pb, pc, pd, aheight, bheight, cheight, dheight, + permanent); +} + +/*****************************************************************************/ +/* */ +/* nonregular() Return a positive value if the point pd is incompatible */ +/* with the circle or plane passing through pa, pb, and pc */ +/* (meaning that pd is inside the circle or below the */ +/* plane); a negative value if it is compatible; and zero if */ +/* the four points are cocircular/coplanar. The points pa, */ +/* pb, and pc must be in counterclockwise order, or the sign */ +/* of the result will be reversed. */ +/* */ +/* If the -w switch is used, the points are lifted onto the parabolic */ +/* lifting map, then they are dropped according to their weights, then the */ +/* 3D orientation test is applied. If the -W switch is used, the points' */ +/* heights are already provided, so the 3D orientation test is applied */ +/* directly. If neither switch is used, the incircle test is applied. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +REAL nonregular(struct mesh *m, struct behavior *b, vertex pa, vertex pb, + vertex pc, vertex pd) +#else /* not ANSI_DECLARATORS */ +REAL nonregular(m, b, pa, pb, pc, pd) +struct mesh *m; +struct behavior *b; +vertex pa; +vertex pb; +vertex pc; +vertex pd; +#endif /* not ANSI_DECLARATORS */ + +{ + if (b->weighted == 0) { + return incircle(m, b, pa, pb, pc, pd); + } else if (b->weighted == 1) { + return orient3d(m, b, pa, pb, pc, pd, pa[0] * pa[0] + pa[1] * pa[1] - pa[2], + pb[0] * pb[0] + pb[1] * pb[1] - pb[2], + pc[0] * pc[0] + pc[1] * pc[1] - pc[2], + pd[0] * pd[0] + pd[1] * pd[1] - pd[2]); + } else { + return orient3d(m, b, pa, pb, pc, pd, pa[2], pb[2], pc[2], pd[2]); + } +} + +/*****************************************************************************/ +/* */ +/* findcircumcenter() Find the circumcenter of a triangle. */ +/* */ +/* The result is returned both in terms of x-y coordinates and xi-eta */ +/* (barycentric) coordinates. The xi-eta coordinate system is defined in */ +/* terms of the triangle: the origin of the triangle is the origin of the */ +/* coordinate system; the destination of the triangle is one unit along the */ +/* xi axis; and the apex of the triangle is one unit along the eta axis. */ +/* This procedure also returns the square of the length of the triangle's */ +/* shortest edge. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void findcircumcenter(struct mesh *m, struct behavior *b, vertex torg, + vertex tdest, vertex tapex, vertex circumcenter, REAL *xi, + REAL *eta, int offcenter) +#else /* not ANSI_DECLARATORS */ +void findcircumcenter(m, b, torg, tdest, tapex, circumcenter, xi, eta, + offcenter) struct mesh *m; +struct behavior *b; +vertex torg; +vertex tdest; +vertex tapex; +vertex circumcenter; +REAL *xi; +REAL *eta; +int offcenter; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL xdo, ydo, xao, yao; + REAL dodist, aodist, dadist; + REAL denominator; + REAL dx, dy, dxoff, dyoff; + + m->circumcentercount++; + + /* Compute the circumcenter of the triangle. */ + xdo = tdest[0] - torg[0]; + ydo = tdest[1] - torg[1]; + xao = tapex[0] - torg[0]; + yao = tapex[1] - torg[1]; + dodist = xdo * xdo + ydo * ydo; + aodist = xao * xao + yao * yao; + dadist = (tdest[0] - tapex[0]) * (tdest[0] - tapex[0]) + + (tdest[1] - tapex[1]) * (tdest[1] - tapex[1]); + if (b->noexact) { + denominator = 0.5 / (xdo * yao - xao * ydo); + } else { + /* Use the counterclockwise() routine to ensure a positive (and */ + /* reasonably accurate) result, avoiding any possibility of */ + /* division by zero. */ + denominator = 0.5 / counterclockwise(m, b, tdest, tapex, torg); + /* Don't count the above as an orientation test. */ + m->counterclockcount--; + } + dx = (yao * dodist - ydo * aodist) * denominator; + dy = (xdo * aodist - xao * dodist) * denominator; + + /* Find the (squared) length of the triangle's shortest edge. This */ + /* serves as a conservative estimate of the insertion radius of the */ + /* circumcenter's parent. The estimate is used to ensure that */ + /* the algorithm terminates even if very small angles appear in */ + /* the input PSLG. */ + if ((dodist < aodist) && (dodist < dadist)) { + if (offcenter && (b->offconstant > 0.0)) { + /* Find the position of the off-center, as described by Alper Ungor. */ + dxoff = 0.5 * xdo - b->offconstant * ydo; + dyoff = 0.5 * ydo + b->offconstant * xdo; + /* If the off-center is closer to the origin than the */ + /* circumcenter, use the off-center instead. */ + if (dxoff * dxoff + dyoff * dyoff < dx * dx + dy * dy) { + dx = dxoff; + dy = dyoff; + } + } + } else if (aodist < dadist) { + if (offcenter && (b->offconstant > 0.0)) { + dxoff = 0.5 * xao + b->offconstant * yao; + dyoff = 0.5 * yao - b->offconstant * xao; + /* If the off-center is closer to the origin than the */ + /* circumcenter, use the off-center instead. */ + if (dxoff * dxoff + dyoff * dyoff < dx * dx + dy * dy) { + dx = dxoff; + dy = dyoff; + } + } + } else { + if (offcenter && (b->offconstant > 0.0)) { + dxoff = + 0.5 * (tapex[0] - tdest[0]) - b->offconstant * (tapex[1] - tdest[1]); + dyoff = + 0.5 * (tapex[1] - tdest[1]) + b->offconstant * (tapex[0] - tdest[0]); + /* If the off-center is closer to the destination than the */ + /* circumcenter, use the off-center instead. */ + if (dxoff * dxoff + dyoff * dyoff < + (dx - xdo) * (dx - xdo) + (dy - ydo) * (dy - ydo)) { + dx = xdo + dxoff; + dy = ydo + dyoff; + } + } + } + + circumcenter[0] = torg[0] + dx; + circumcenter[1] = torg[1] + dy; + + /* To interpolate vertex attributes for the new vertex inserted at */ + /* the circumcenter, define a coordinate system with a xi-axis, */ + /* directed from the triangle's origin to its destination, and */ + /* an eta-axis, directed from its origin to its apex. */ + /* Calculate the xi and eta coordinates of the circumcenter. */ + *xi = (yao * dx - xao * dy) * (2.0 * denominator); + *eta = (xdo * dy - ydo * dx) * (2.0 * denominator); +} + +/** **/ +/** **/ +/********* Geometric primitives end here *********/ + +/*****************************************************************************/ +/* */ +/* triangleinit() Initialize some variables. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void triangleinit(struct mesh *m) +#else /* not ANSI_DECLARATORS */ +void triangleinit(m) struct mesh *m; +#endif /* not ANSI_DECLARATORS */ + +{ + poolzero(&m->vertices); + poolzero(&m->triangles); + poolzero(&m->subsegs); + poolzero(&m->viri); + poolzero(&m->badsubsegs); + poolzero(&m->badtriangles); + poolzero(&m->flipstackers); + poolzero(&m->splaynodes); + + m->recenttri.tri = (triangle *)NULL; /* No triangle has been visited yet. */ + m->undeads = 0; /* No eliminated input vertices yet. */ + m->samples = 1; /* Point location should take at least one sample. */ + m->checksegments = 0; /* There are no segments in the triangulation yet. */ + m->checkquality = 0; /* The quality triangulation stage has not begun. */ + m->incirclecount = m->counterclockcount = m->orient3dcount = 0; + m->hyperbolacount = m->circletopcount = m->circumcentercount = 0; + randomseed = 1; + + exactinit(); /* Initialize exact arithmetic constants. */ +} + +/*****************************************************************************/ +/* */ +/* randomnation() Generate a random number between 0 and `choices' - 1. */ +/* */ +/* This is a simple linear congruential random number generator. Hence, it */ +/* is a bad random number generator, but good enough for most randomized */ +/* geometric algorithms. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +unsigned long randomnation(unsigned int choices) +#else /* not ANSI_DECLARATORS */ +unsigned long randomnation(choices) +unsigned int choices; +#endif /* not ANSI_DECLARATORS */ + +{ + randomseed = (randomseed * 1366l + 150889l) % 714025l; + return randomseed / (714025l / choices + 1); +} + +/********* Mesh quality testing routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* checkmesh() Test the mesh for topological consistency. */ +/* */ +/*****************************************************************************/ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void checkmesh(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void checkmesh(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri triangleloop; + struct otri oppotri, oppooppotri; + vertex triorg, tridest, triapex; + vertex oppoorg, oppodest; + int horrors; + int saveexact; + triangle ptr; /* Temporary variable used by sym(). */ + + /* Temporarily turn on exact arithmetic if it's off. */ + saveexact = b->noexact; + b->noexact = 0; + if (!b->quiet) { + printf(" Checking consistency of mesh...\n"); + } + horrors = 0; + /* Run through the list of triangles, checking each one. */ + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + while (triangleloop.tri != (triangle *)NULL) { + /* Check all three edges of the triangle. */ + for (triangleloop.orient = 0; triangleloop.orient < 3; + triangleloop.orient++) { + org(triangleloop, triorg); + dest(triangleloop, tridest); + if (triangleloop.orient == 0) { /* Only test for inversion once. */ + /* Test if the triangle is flat or inverted. */ + apex(triangleloop, triapex); + if (counterclockwise(m, b, triorg, tridest, triapex) <= 0.0) { + printf(" !! !! Inverted "); + printtriangle(m, b, &triangleloop); + horrors++; + } + } + /* Find the neighboring triangle on this edge. */ + sym(triangleloop, oppotri); + if (oppotri.tri != m->dummytri) { + /* Check that the triangle's neighbor knows it's a neighbor. */ + sym(oppotri, oppooppotri); + if ((triangleloop.tri != oppooppotri.tri) || + (triangleloop.orient != oppooppotri.orient)) { + printf(" !! !! Asymmetric triangle-triangle bond:\n"); + if (triangleloop.tri == oppooppotri.tri) { + printf(" (Right triangle, wrong orientation)\n"); + } + printf(" First "); + printtriangle(m, b, &triangleloop); + printf(" Second (nonreciprocating) "); + printtriangle(m, b, &oppotri); + horrors++; + } + /* Check that both triangles agree on the identities */ + /* of their shared vertices. */ + org(oppotri, oppoorg); + dest(oppotri, oppodest); + if ((triorg != oppodest) || (tridest != oppoorg)) { + printf( + " !! !! Mismatched edge coordinates between two triangles:\n"); + printf(" First mismatched "); + printtriangle(m, b, &triangleloop); + printf(" Second mismatched "); + printtriangle(m, b, &oppotri); + horrors++; + } + } + } + triangleloop.tri = triangletraverse(m); + } + if (horrors == 0) { + if (!b->quiet) { + printf(" In my studied opinion, the mesh appears to be consistent.\n"); + } + } else if (horrors == 1) { + printf(" !! !! !! !! Precisely one festering wound discovered.\n"); + } else { + printf(" !! !! !! !! %d abominations witnessed.\n", horrors); + } + /* Restore the status of exact arithmetic. */ + b->noexact = saveexact; +} + +#endif /* not REDUCED */ + +/*****************************************************************************/ +/* */ +/* checkdelaunay() Ensure that the mesh is (constrained) Delaunay. */ +/* */ +/*****************************************************************************/ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void checkdelaunay(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void checkdelaunay(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri triangleloop; + struct otri oppotri; + struct osub opposubseg; + vertex triorg, tridest, triapex; + vertex oppoapex; + int shouldbedelaunay; + int horrors; + int saveexact; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + /* Temporarily turn on exact arithmetic if it's off. */ + saveexact = b->noexact; + b->noexact = 0; + if (!b->quiet) { + printf(" Checking Delaunay property of mesh...\n"); + } + horrors = 0; + /* Run through the list of triangles, checking each one. */ + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + while (triangleloop.tri != (triangle *)NULL) { + /* Check all three edges of the triangle. */ + for (triangleloop.orient = 0; triangleloop.orient < 3; + triangleloop.orient++) { + org(triangleloop, triorg); + dest(triangleloop, tridest); + apex(triangleloop, triapex); + sym(triangleloop, oppotri); + apex(oppotri, oppoapex); + /* Only test that the edge is locally Delaunay if there is an */ + /* adjoining triangle whose pointer is larger (to ensure that */ + /* each pair isn't tested twice). */ + shouldbedelaunay = + (oppotri.tri != m->dummytri) && !deadtri(oppotri.tri) && + (triangleloop.tri < oppotri.tri) && (triorg != m->infvertex1) && + (triorg != m->infvertex2) && (triorg != m->infvertex3) && + (tridest != m->infvertex1) && (tridest != m->infvertex2) && + (tridest != m->infvertex3) && (triapex != m->infvertex1) && + (triapex != m->infvertex2) && (triapex != m->infvertex3) && + (oppoapex != m->infvertex1) && (oppoapex != m->infvertex2) && + (oppoapex != m->infvertex3); + if (m->checksegments && shouldbedelaunay) { + /* If a subsegment separates the triangles, then the edge is */ + /* constrained, so no local Delaunay test should be done. */ + tspivot(triangleloop, opposubseg); + if (opposubseg.ss != m->dummysub) { + shouldbedelaunay = 0; + } + } + if (shouldbedelaunay) { + if (nonregular(m, b, triorg, tridest, triapex, oppoapex) > 0.0) { + if (!b->weighted) { + printf(" !! !! Non-Delaunay pair of triangles:\n"); + printf(" First non-Delaunay "); + printtriangle(m, b, &triangleloop); + printf(" Second non-Delaunay "); + } else { + printf(" !! !! Non-regular pair of triangles:\n"); + printf(" First non-regular "); + printtriangle(m, b, &triangleloop); + printf(" Second non-regular "); + } + printtriangle(m, b, &oppotri); + horrors++; + } + } + } + triangleloop.tri = triangletraverse(m); + } + if (horrors == 0) { + if (!b->quiet) { + printf(" By virtue of my perceptive intelligence, I declare the mesh " + "Delaunay.\n"); + } + } else if (horrors == 1) { + printf( + " !! !! !! !! Precisely one terrifying transgression identified.\n"); + } else { + printf(" !! !! !! !! %d obscenities viewed with horror.\n", horrors); + } + /* Restore the status of exact arithmetic. */ + b->noexact = saveexact; +} + +#endif /* not REDUCED */ + +/*****************************************************************************/ +/* */ +/* enqueuebadtriang() Add a bad triangle data structure to the end of a */ +/* queue. */ +/* */ +/* The queue is actually a set of 4096 queues. I use multiple queues to */ +/* give priority to smaller angles. I originally implemented a heap, but */ +/* the queues are faster by a larger margin than I'd suspected. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void enqueuebadtriang(struct mesh *m, struct behavior *b, + struct badtriang *badtri) +#else /* not ANSI_DECLARATORS */ +void enqueuebadtriang(m, b, badtri) struct mesh *m; +struct behavior *b; +struct badtriang *badtri; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL length, multiplier; + int exponent, expincrement; + int queuenumber; + int posexponent; + int i; + + if (b->verbose > 2) { + printf(" Queueing bad triangle:\n"); + printf(" (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", + badtri->triangorg[0], badtri->triangorg[1], badtri->triangdest[0], + badtri->triangdest[1], badtri->triangapex[0], badtri->triangapex[1]); + } + + /* Determine the appropriate queue to put the bad triangle into. */ + /* Recall that the key is the square of its shortest edge length. */ + if (badtri->key >= 1.0) { + length = badtri->key; + posexponent = 1; + } else { + /* `badtri->key' is 2.0 to a negative exponent, so we'll record that */ + /* fact and use the reciprocal of `badtri->key', which is > 1.0. */ + length = 1.0 / badtri->key; + posexponent = 0; + } + /* `length' is approximately 2.0 to what exponent? The following code */ + /* determines the answer in time logarithmic in the exponent. */ + exponent = 0; + while (length > 2.0) { + /* Find an approximation by repeated squaring of two. */ + expincrement = 1; + multiplier = 0.5; + while (length * multiplier * multiplier > 1.0) { + expincrement *= 2; + multiplier *= multiplier; + } + /* Reduce the value of `length', then iterate if necessary. */ + exponent += expincrement; + length *= multiplier; + } + /* `length' is approximately squareroot(2.0) to what exponent? */ + exponent = 2.0 * exponent + (length > SQUAREROOTTWO); + /* `exponent' is now in the range 0...2047 for IEEE double precision. */ + /* Choose a queue in the range 0...4095. The shortest edges have the */ + /* highest priority (queue 4095). */ + if (posexponent) { + queuenumber = 2047 - exponent; + } else { + queuenumber = 2048 + exponent; + } + + /* Are we inserting into an empty queue? */ + if (m->queuefront[queuenumber] == (struct badtriang *)NULL) { + /* Yes, we are inserting into an empty queue. */ + /* Will this become the highest-priority queue? */ + if (queuenumber > m->firstnonemptyq) { + /* Yes, this is the highest-priority queue. */ + m->nextnonemptyq[queuenumber] = m->firstnonemptyq; + m->firstnonemptyq = queuenumber; + } else { + /* No, this is not the highest-priority queue. */ + /* Find the queue with next higher priority. */ + i = queuenumber + 1; + while (m->queuefront[i] == (struct badtriang *)NULL) { + i++; + } + /* Mark the newly nonempty queue as following a higher-priority queue. */ + m->nextnonemptyq[queuenumber] = m->nextnonemptyq[i]; + m->nextnonemptyq[i] = queuenumber; + } + /* Put the bad triangle at the beginning of the (empty) queue. */ + m->queuefront[queuenumber] = badtri; + } else { + /* Add the bad triangle to the end of an already nonempty queue. */ + m->queuetail[queuenumber]->nexttriang = badtri; + } + /* Maintain a pointer to the last triangle of the queue. */ + m->queuetail[queuenumber] = badtri; + /* Newly enqueued bad triangle has no successor in the queue. */ + badtri->nexttriang = (struct badtriang *)NULL; +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* enqueuebadtri() Add a bad triangle to the end of a queue. */ +/* */ +/* Allocates a badtriang data structure for the triangle, then passes it to */ +/* enqueuebadtriang(). */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void enqueuebadtri(struct mesh *m, struct behavior *b, struct otri *enqtri, + REAL minedge, vertex enqapex, vertex enqorg, vertex enqdest) +#else /* not ANSI_DECLARATORS */ +void enqueuebadtri(m, b, enqtri, minedge, enqapex, enqorg, + enqdest) struct mesh *m; +struct behavior *b; +struct otri *enqtri; +REAL minedge; +vertex enqapex; +vertex enqorg; +vertex enqdest; +#endif /* not ANSI_DECLARATORS */ + +{ + struct badtriang *newbad; + + /* Allocate space for the bad triangle. */ + newbad = (struct badtriang *)poolalloc(&m->badtriangles); + newbad->poortri = encode(*enqtri); + newbad->key = minedge; + newbad->triangapex = enqapex; + newbad->triangorg = enqorg; + newbad->triangdest = enqdest; + enqueuebadtriang(m, b, newbad); +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* dequeuebadtriang() Remove a triangle from the front of the queue. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +struct badtriang *dequeuebadtriang(struct mesh *m) +#else /* not ANSI_DECLARATORS */ +struct badtriang *dequeuebadtriang(m) +struct mesh *m; +#endif /* not ANSI_DECLARATORS */ + +{ + struct badtriang *result; + + /* If no queues are nonempty, return NULL. */ + if (m->firstnonemptyq < 0) { + return (struct badtriang *)NULL; + } + /* Find the first triangle of the highest-priority queue. */ + result = m->queuefront[m->firstnonemptyq]; + /* Remove the triangle from the queue. */ + m->queuefront[m->firstnonemptyq] = result->nexttriang; + /* If this queue is now empty, note the new highest-priority */ + /* nonempty queue. */ + if (result == m->queuetail[m->firstnonemptyq]) { + m->firstnonemptyq = m->nextnonemptyq[m->firstnonemptyq]; + } + return result; +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* checkseg4encroach() Check a subsegment to see if it is encroached; add */ +/* it to the list if it is. */ +/* */ +/* A subsegment is encroached if there is a vertex in its diametral lens. */ +/* For Ruppert's algorithm (-D switch), the "diametral lens" is the */ +/* diametral circle. For Chew's algorithm (default), the diametral lens is */ +/* just big enough to enclose two isosceles triangles whose bases are the */ +/* subsegment. Each of the two isosceles triangles has two angles equal */ +/* to `b->minangle'. */ +/* */ +/* Chew's algorithm does not require diametral lenses at all--but they save */ +/* time. Any vertex inside a subsegment's diametral lens implies that the */ +/* triangle adjoining the subsegment will be too skinny, so it's only a */ +/* matter of time before the encroaching vertex is deleted by Chew's */ +/* algorithm. It's faster to simply not insert the doomed vertex in the */ +/* first place, which is why I use diametral lenses with Chew's algorithm. */ +/* */ +/* Returns a nonzero value if the subsegment is encroached. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +int checkseg4encroach(struct mesh *m, struct behavior *b, + struct osub *testsubseg) +#else /* not ANSI_DECLARATORS */ +int checkseg4encroach(m, b, testsubseg) +struct mesh *m; +struct behavior *b; +struct osub *testsubseg; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri neighbortri; + struct osub testsym; + struct badsubseg *encroachedseg; + REAL dotproduct; + int encroached; + int sides; + vertex eorg, edest, eapex; + triangle ptr; /* Temporary variable used by stpivot(). */ + + encroached = 0; + sides = 0; + + sorg(*testsubseg, eorg); + sdest(*testsubseg, edest); + /* Check one neighbor of the subsegment. */ + stpivot(*testsubseg, neighbortri); + /* Does the neighbor exist, or is this a boundary edge? */ + if (neighbortri.tri != m->dummytri) { + sides++; + /* Find a vertex opposite this subsegment. */ + apex(neighbortri, eapex); + /* Check whether the apex is in the diametral lens of the subsegment */ + /* (the diametral circle if `conformdel' is set). A dot product */ + /* of two sides of the triangle is used to check whether the angle */ + /* at the apex is greater than (180 - 2 `minangle') degrees (for */ + /* lenses; 90 degrees for diametral circles). */ + dotproduct = (eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + + (eorg[1] - eapex[1]) * (edest[1] - eapex[1]); + if (dotproduct < 0.0) { + if (b->conformdel || + (dotproduct * dotproduct >= + (2.0 * b->goodangle - 1.0) * (2.0 * b->goodangle - 1.0) * + ((eorg[0] - eapex[0]) * (eorg[0] - eapex[0]) + + (eorg[1] - eapex[1]) * (eorg[1] - eapex[1])) * + ((edest[0] - eapex[0]) * (edest[0] - eapex[0]) + + (edest[1] - eapex[1]) * (edest[1] - eapex[1])))) { + encroached = 1; + } + } + } + /* Check the other neighbor of the subsegment. */ + ssym(*testsubseg, testsym); + stpivot(testsym, neighbortri); + /* Does the neighbor exist, or is this a boundary edge? */ + if (neighbortri.tri != m->dummytri) { + sides++; + /* Find the other vertex opposite this subsegment. */ + apex(neighbortri, eapex); + /* Check whether the apex is in the diametral lens of the subsegment */ + /* (or the diametral circle, if `conformdel' is set). */ + dotproduct = (eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + + (eorg[1] - eapex[1]) * (edest[1] - eapex[1]); + if (dotproduct < 0.0) { + if (b->conformdel || + (dotproduct * dotproduct >= + (2.0 * b->goodangle - 1.0) * (2.0 * b->goodangle - 1.0) * + ((eorg[0] - eapex[0]) * (eorg[0] - eapex[0]) + + (eorg[1] - eapex[1]) * (eorg[1] - eapex[1])) * + ((edest[0] - eapex[0]) * (edest[0] - eapex[0]) + + (edest[1] - eapex[1]) * (edest[1] - eapex[1])))) { + encroached += 2; + } + } + } + + if (encroached && (!b->nobisect || ((b->nobisect == 1) && (sides == 2)))) { + if (b->verbose > 2) { + printf( + " Queueing encroached subsegment (%.12g, %.12g) (%.12g, %.12g).\n", + eorg[0], eorg[1], edest[0], edest[1]); + } + /* Add the subsegment to the list of encroached subsegments. */ + /* Be sure to get the orientation right. */ + encroachedseg = (struct badsubseg *)poolalloc(&m->badsubsegs); + if (encroached == 1) { + encroachedseg->encsubseg = sencode(*testsubseg); + encroachedseg->subsegorg = eorg; + encroachedseg->subsegdest = edest; + } else { + encroachedseg->encsubseg = sencode(testsym); + encroachedseg->subsegorg = edest; + encroachedseg->subsegdest = eorg; + } + } + + return encroached; +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* testtriangle() Test a triangle for quality and size. */ +/* */ +/* Tests a triangle to see if it satisfies the minimum angle condition and */ +/* the maximum area condition. Triangles that aren't up to spec are added */ +/* to the bad triangle queue. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void testtriangle(struct mesh *m, struct behavior *b, struct otri *testtri) +#else /* not ANSI_DECLARATORS */ +void testtriangle(m, b, testtri) struct mesh *m; +struct behavior *b; +struct otri *testtri; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri tri1, tri2; + struct osub testsub; + vertex torg, tdest, tapex; + vertex base1, base2; + vertex org1, dest1, org2, dest2; + vertex joinvertex; + REAL dxod, dyod, dxda, dyda, dxao, dyao; + REAL dxod2, dyod2, dxda2, dyda2, dxao2, dyao2; + REAL apexlen, orglen, destlen, minedge; + REAL angle; + REAL area; + REAL dist1, dist2; + subseg sptr; /* Temporary variable used by tspivot(). */ + triangle ptr; /* Temporary variable used by oprev() and dnext(). */ + + org(*testtri, torg); + dest(*testtri, tdest); + apex(*testtri, tapex); + dxod = torg[0] - tdest[0]; + dyod = torg[1] - tdest[1]; + dxda = tdest[0] - tapex[0]; + dyda = tdest[1] - tapex[1]; + dxao = tapex[0] - torg[0]; + dyao = tapex[1] - torg[1]; + dxod2 = dxod * dxod; + dyod2 = dyod * dyod; + dxda2 = dxda * dxda; + dyda2 = dyda * dyda; + dxao2 = dxao * dxao; + dyao2 = dyao * dyao; + /* Find the lengths of the triangle's three edges. */ + apexlen = dxod2 + dyod2; + orglen = dxda2 + dyda2; + destlen = dxao2 + dyao2; + + if ((apexlen < orglen) && (apexlen < destlen)) { + /* The edge opposite the apex is shortest. */ + minedge = apexlen; + /* Find the square of the cosine of the angle at the apex. */ + angle = dxda * dxao + dyda * dyao; + angle = angle * angle / (orglen * destlen); + base1 = torg; + base2 = tdest; + otricopy(*testtri, tri1); + } else if (orglen < destlen) { + /* The edge opposite the origin is shortest. */ + minedge = orglen; + /* Find the square of the cosine of the angle at the origin. */ + angle = dxod * dxao + dyod * dyao; + angle = angle * angle / (apexlen * destlen); + base1 = tdest; + base2 = tapex; + lnext(*testtri, tri1); + } else { + /* The edge opposite the destination is shortest. */ + minedge = destlen; + /* Find the square of the cosine of the angle at the destination. */ + angle = dxod * dxda + dyod * dyda; + angle = angle * angle / (apexlen * orglen); + base1 = tapex; + base2 = torg; + lprev(*testtri, tri1); + } + + if (b->vararea || b->fixedarea || b->usertest) { + /* Check whether the area is larger than permitted. */ + area = 0.5 * (dxod * dyda - dyod * dxda); + if (b->fixedarea && (area > b->maxarea)) { + /* Add this triangle to the list of bad triangles. */ + enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); + return; + } + + /* Nonpositive area constraints are treated as unconstrained. */ + if ((b->vararea) && (area > areabound(*testtri)) && + (areabound(*testtri) > 0.0)) { + /* Add this triangle to the list of bad triangles. */ + enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); + return; + } + + if (b->usertest) { + /* Check whether the user thinks this triangle is too large. */ + if (triunsuitable(torg, tdest, tapex, area)) { + enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); + return; + } + } + } + + /* Check whether the angle is smaller than permitted. */ + if (angle > b->goodangle) { + /* Use the rules of Miller, Pav, and Walkington to decide that certain */ + /* triangles should not be split, even if they have bad angles. */ + /* A skinny triangle is not split if its shortest edge subtends a */ + /* small input angle, and both endpoints of the edge lie on a */ + /* concentric circular shell. For convenience, I make a small */ + /* adjustment to that rule: I check if the endpoints of the edge */ + /* both lie in segment interiors, equidistant from the apex where */ + /* the two segments meet. */ + /* First, check if both points lie in segment interiors. */ + if ((vertextype(base1) == SEGMENTVERTEX) && + (vertextype(base2) == SEGMENTVERTEX)) { + /* Check if both points lie in a common segment. If they do, the */ + /* skinny triangle is enqueued to be split as usual. */ + tspivot(tri1, testsub); + if (testsub.ss == m->dummysub) { + /* No common segment. Find a subsegment that contains `torg'. */ + otricopy(tri1, tri2); + do { + oprevself(tri1); + tspivot(tri1, testsub); + } while (testsub.ss == m->dummysub); + /* Find the endpoints of the containing segment. */ + segorg(testsub, org1); + segdest(testsub, dest1); + /* Find a subsegment that contains `tdest'. */ + do { + dnextself(tri2); + tspivot(tri2, testsub); + } while (testsub.ss == m->dummysub); + /* Find the endpoints of the containing segment. */ + segorg(testsub, org2); + segdest(testsub, dest2); + /* Check if the two containing segments have an endpoint in common. */ + joinvertex = (vertex)NULL; + if ((dest1[0] == org2[0]) && (dest1[1] == org2[1])) { + joinvertex = dest1; + } else if ((org1[0] == dest2[0]) && (org1[1] == dest2[1])) { + joinvertex = org1; + } + if (joinvertex != (vertex)NULL) { + /* Compute the distance from the common endpoint (of the two */ + /* segments) to each of the endpoints of the shortest edge. */ + dist1 = ((base1[0] - joinvertex[0]) * (base1[0] - joinvertex[0]) + + (base1[1] - joinvertex[1]) * (base1[1] - joinvertex[1])); + dist2 = ((base2[0] - joinvertex[0]) * (base2[0] - joinvertex[0]) + + (base2[1] - joinvertex[1]) * (base2[1] - joinvertex[1])); + /* If the two distances are equal, don't split the triangle. */ + if ((dist1 < 1.001 * dist2) && (dist1 > 0.999 * dist2)) { + /* Return now to avoid enqueueing the bad triangle. */ + return; + } + } + } + } + + /* Add this triangle to the list of bad triangles. */ + enqueuebadtri(m, b, testtri, minedge, tapex, torg, tdest); + } +} + +#endif /* not CDT_ONLY */ + +/** **/ +/** **/ +/********* Mesh quality testing routines end here *********/ + +/********* Point location routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* makevertexmap() Construct a mapping from vertices to triangles to */ +/* improve the speed of point location for segment */ +/* insertion. */ +/* */ +/* Traverses all the triangles, and provides each corner of each triangle */ +/* with a pointer to that triangle. Of course, pointers will be */ +/* overwritten by other pointers because (almost) each vertex is a corner */ +/* of several triangles, but in the end every vertex will point to some */ +/* triangle that contains it. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void makevertexmap(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void makevertexmap(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri triangleloop; + vertex triorg; + + if (b->verbose) { + printf(" Constructing mapping from vertices to triangles.\n"); + } + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + while (triangleloop.tri != (triangle *)NULL) { + /* Check all three vertices of the triangle. */ + for (triangleloop.orient = 0; triangleloop.orient < 3; + triangleloop.orient++) { + org(triangleloop, triorg); + setvertex2tri(triorg, encode(triangleloop)); + } + triangleloop.tri = triangletraverse(m); + } +} + +/*****************************************************************************/ +/* */ +/* preciselocate() Find a triangle or edge containing a given point. */ +/* */ +/* Begins its search from `searchtri'. It is important that `searchtri' */ +/* be a handle with the property that `searchpoint' is strictly to the left */ +/* of the edge denoted by `searchtri', or is collinear with that edge and */ +/* does not intersect that edge. (In particular, `searchpoint' should not */ +/* be the origin or destination of that edge.) */ +/* */ +/* These conditions are imposed because preciselocate() is normally used in */ +/* one of two situations: */ +/* */ +/* (1) To try to find the location to insert a new point. Normally, we */ +/* know an edge that the point is strictly to the left of. In the */ +/* incremental Delaunay algorithm, that edge is a bounding box edge. */ +/* In Ruppert's Delaunay refinement algorithm for quality meshing, */ +/* that edge is the shortest edge of the triangle whose circumcenter */ +/* is being inserted. */ +/* */ +/* (2) To try to find an existing point. In this case, any edge on the */ +/* convex hull is a good starting edge. You must screen out the */ +/* possibility that the vertex sought is an endpoint of the starting */ +/* edge before you call preciselocate(). */ +/* */ +/* On completion, `searchtri' is a triangle that contains `searchpoint'. */ +/* */ +/* This implementation differs from that given by Guibas and Stolfi. It */ +/* walks from triangle to triangle, crossing an edge only if `searchpoint' */ +/* is on the other side of the line containing that edge. After entering */ +/* a triangle, there are two edges by which one can leave that triangle. */ +/* If both edges are valid (`searchpoint' is on the other side of both */ +/* edges), one of the two is chosen by drawing a line perpendicular to */ +/* the entry edge (whose endpoints are `forg' and `fdest') passing through */ +/* `fapex'. Depending on which side of this perpendicular `searchpoint' */ +/* falls on, an exit edge is chosen. */ +/* */ +/* This implementation is empirically faster than the Guibas and Stolfi */ +/* point location routine (which I originally used), which tends to spiral */ +/* in toward its target. */ +/* */ +/* Returns ONVERTEX if the point lies on an existing vertex. `searchtri' */ +/* is a handle whose origin is the existing vertex. */ +/* */ +/* Returns ONEDGE if the point lies on a mesh edge. `searchtri' is a */ +/* handle whose primary edge is the edge on which the point lies. */ +/* */ +/* Returns INTRIANGLE if the point lies strictly within a triangle. */ +/* `searchtri' is a handle on the triangle that contains the point. */ +/* */ +/* Returns OUTSIDE if the point lies outside the mesh. `searchtri' is a */ +/* handle whose primary edge the point is to the right of. This might */ +/* occur when the circumcenter of a triangle falls just slightly outside */ +/* the mesh due to floating-point roundoff error. It also occurs when */ +/* seeking a hole or region point that a foolish user has placed outside */ +/* the mesh. */ +/* */ +/* If `stopatsubsegment' is nonzero, the search will stop if it tries to */ +/* walk through a subsegment, and will return OUTSIDE. */ +/* */ +/* WARNING: This routine is designed for convex triangulations, and will */ +/* not generally work after the holes and concavities have been carved. */ +/* However, it can still be used to find the circumcenter of a triangle, as */ +/* long as the search is begun from the triangle in question. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +enum locateresult preciselocate(struct mesh *m, struct behavior *b, + vertex searchpoint, struct otri *searchtri, + int stopatsubsegment) +#else /* not ANSI_DECLARATORS */ +enum locateresult preciselocate(m, b, searchpoint, searchtri, stopatsubsegment) +struct mesh *m; +struct behavior *b; +vertex searchpoint; +struct otri *searchtri; +int stopatsubsegment; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri backtracktri; + struct osub checkedge; + vertex forg, fdest, fapex; + REAL orgorient, destorient; + int moveleft; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + if (b->verbose > 2) { + printf(" Searching for point (%.12g, %.12g).\n", searchpoint[0], + searchpoint[1]); + } + /* Where are we? */ + org(*searchtri, forg); + dest(*searchtri, fdest); + apex(*searchtri, fapex); + while (1) { + if (b->verbose > 2) { + printf(" At (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", forg[0], + forg[1], fdest[0], fdest[1], fapex[0], fapex[1]); + } + /* Check whether the apex is the point we seek. */ + if ((fapex[0] == searchpoint[0]) && (fapex[1] == searchpoint[1])) { + lprevself(*searchtri); + return ONVERTEX; + } + /* Does the point lie on the other side of the line defined by the */ + /* triangle edge opposite the triangle's destination? */ + destorient = counterclockwise(m, b, forg, fapex, searchpoint); + /* Does the point lie on the other side of the line defined by the */ + /* triangle edge opposite the triangle's origin? */ + orgorient = counterclockwise(m, b, fapex, fdest, searchpoint); + if (destorient > 0.0) { + if (orgorient > 0.0) { + /* Move left if the inner product of (fapex - searchpoint) and */ + /* (fdest - forg) is positive. This is equivalent to drawing */ + /* a line perpendicular to the line (forg, fdest) and passing */ + /* through `fapex', and determining which side of this line */ + /* `searchpoint' falls on. */ + moveleft = (fapex[0] - searchpoint[0]) * (fdest[0] - forg[0]) + + (fapex[1] - searchpoint[1]) * (fdest[1] - forg[1]) > + 0.0; + } else { + moveleft = 1; + } + } else { + if (orgorient > 0.0) { + moveleft = 0; + } else { + /* The point we seek must be on the boundary of or inside this */ + /* triangle. */ + if (destorient == 0.0) { + lprevself(*searchtri); + return ONEDGE; + } + if (orgorient == 0.0) { + lnextself(*searchtri); + return ONEDGE; + } + return INTRIANGLE; + } + } + + /* Move to another triangle. Leave a trace `backtracktri' in case */ + /* floating-point roundoff or some such bogey causes us to walk */ + /* off a boundary of the triangulation. */ + if (moveleft) { + lprev(*searchtri, backtracktri); + fdest = fapex; + } else { + lnext(*searchtri, backtracktri); + forg = fapex; + } + sym(backtracktri, *searchtri); + + if (m->checksegments && stopatsubsegment) { + /* Check for walking through a subsegment. */ + tspivot(backtracktri, checkedge); + if (checkedge.ss != m->dummysub) { + /* Go back to the last triangle. */ + otricopy(backtracktri, *searchtri); + return OUTSIDE; + } + } + /* Check for walking right out of the triangulation. */ + if (searchtri->tri == m->dummytri) { + /* Go back to the last triangle. */ + otricopy(backtracktri, *searchtri); + return OUTSIDE; + } + + apex(*searchtri, fapex); + } +} + +/*****************************************************************************/ +/* */ +/* locate() Find a triangle or edge containing a given point. */ +/* */ +/* Searching begins from one of: the input `searchtri', a recently */ +/* encountered triangle `recenttri', or from a triangle chosen from a */ +/* random sample. The choice is made by determining which triangle's */ +/* origin is closest to the point we are searching for. Normally, */ +/* `searchtri' should be a handle on the convex hull of the triangulation. */ +/* */ +/* Details on the random sampling method can be found in the Mucke, Saias, */ +/* and Zhu paper cited in the header of this code. */ +/* */ +/* On completion, `searchtri' is a triangle that contains `searchpoint'. */ +/* */ +/* Returns ONVERTEX if the point lies on an existing vertex. `searchtri' */ +/* is a handle whose origin is the existing vertex. */ +/* */ +/* Returns ONEDGE if the point lies on a mesh edge. `searchtri' is a */ +/* handle whose primary edge is the edge on which the point lies. */ +/* */ +/* Returns INTRIANGLE if the point lies strictly within a triangle. */ +/* `searchtri' is a handle on the triangle that contains the point. */ +/* */ +/* Returns OUTSIDE if the point lies outside the mesh. `searchtri' is a */ +/* handle whose primary edge the point is to the right of. This might */ +/* occur when the circumcenter of a triangle falls just slightly outside */ +/* the mesh due to floating-point roundoff error. It also occurs when */ +/* seeking a hole or region point that a foolish user has placed outside */ +/* the mesh. */ +/* */ +/* WARNING: This routine is designed for convex triangulations, and will */ +/* not generally work after the holes and concavities have been carved. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +enum locateresult locate(struct mesh *m, struct behavior *b, vertex searchpoint, + struct otri *searchtri) +#else /* not ANSI_DECLARATORS */ +enum locateresult locate(m, b, searchpoint, searchtri) +struct mesh *m; +struct behavior *b; +vertex searchpoint; +struct otri *searchtri; +#endif /* not ANSI_DECLARATORS */ + +{ + VOID **sampleblock; + char *firsttri; + struct otri sampletri; + vertex torg, tdest; + unsigned long alignptr; + REAL searchdist, dist; + REAL ahead; + long samplesperblock, totalsamplesleft, samplesleft; + long population, totalpopulation; + triangle ptr; /* Temporary variable used by sym(). */ + + if (b->verbose > 2) { + printf(" Randomly sampling for a triangle near point (%.12g, %.12g).\n", + searchpoint[0], searchpoint[1]); + } + /* Record the distance from the suggested starting triangle to the */ + /* point we seek. */ + org(*searchtri, torg); + searchdist = (searchpoint[0] - torg[0]) * (searchpoint[0] - torg[0]) + + (searchpoint[1] - torg[1]) * (searchpoint[1] - torg[1]); + if (b->verbose > 2) { + printf(" Boundary triangle has origin (%.12g, %.12g).\n", torg[0], + torg[1]); + } + + /* If a recently encountered triangle has been recorded and has not been */ + /* deallocated, test it as a good starting point. */ + if (m->recenttri.tri != (triangle *)NULL) { + if (!deadtri(m->recenttri.tri)) { + org(m->recenttri, torg); + if ((torg[0] == searchpoint[0]) && (torg[1] == searchpoint[1])) { + otricopy(m->recenttri, *searchtri); + return ONVERTEX; + } + dist = (searchpoint[0] - torg[0]) * (searchpoint[0] - torg[0]) + + (searchpoint[1] - torg[1]) * (searchpoint[1] - torg[1]); + if (dist < searchdist) { + otricopy(m->recenttri, *searchtri); + searchdist = dist; + if (b->verbose > 2) { + printf(" Choosing recent triangle with origin (%.12g, %.12g).\n", + torg[0], torg[1]); + } + } + } + } + + /* The number of random samples taken is proportional to the cube root of */ + /* the number of triangles in the mesh. The next bit of code assumes */ + /* that the number of triangles increases monotonically (or at least */ + /* doesn't decrease enough to matter). */ + while (SAMPLEFACTOR * m->samples * m->samples * m->samples < + m->triangles.items) { + m->samples++; + } + + /* We'll draw ceiling(samples * TRIPERBLOCK / maxitems) random samples */ + /* from each block of triangles (except the first)--until we meet the */ + /* sample quota. The ceiling means that blocks at the end might be */ + /* neglected, but I don't care. */ + samplesperblock = (m->samples * TRIPERBLOCK - 1) / m->triangles.maxitems + 1; + /* We'll draw ceiling(samples * itemsfirstblock / maxitems) random samples */ + /* from the first block of triangles. */ + samplesleft = + (m->samples * m->triangles.itemsfirstblock - 1) / m->triangles.maxitems + + 1; + totalsamplesleft = m->samples; + population = m->triangles.itemsfirstblock; + totalpopulation = m->triangles.maxitems; + sampleblock = m->triangles.firstblock; + sampletri.orient = 0; + while (totalsamplesleft > 0) { + /* If we're in the last block, `population' needs to be corrected. */ + if (population > totalpopulation) { + population = totalpopulation; + } + /* Find a pointer to the first triangle in the block. */ + alignptr = (unsigned long)(sampleblock + 1); + firsttri = (char *)(alignptr + (unsigned long)m->triangles.alignbytes - + (alignptr % (unsigned long)m->triangles.alignbytes)); + + /* Choose `samplesleft' randomly sampled triangles in this block. */ + do { + sampletri.tri = + (triangle *)(firsttri + (randomnation((unsigned int)population) * + m->triangles.itembytes)); + if (!deadtri(sampletri.tri)) { + org(sampletri, torg); + dist = (searchpoint[0] - torg[0]) * (searchpoint[0] - torg[0]) + + (searchpoint[1] - torg[1]) * (searchpoint[1] - torg[1]); + if (dist < searchdist) { + otricopy(sampletri, *searchtri); + searchdist = dist; + if (b->verbose > 2) { + printf(" Choosing triangle with origin (%.12g, %.12g).\n", + torg[0], torg[1]); + } + } + } + + samplesleft--; + totalsamplesleft--; + } while ((samplesleft > 0) && (totalsamplesleft > 0)); + + if (totalsamplesleft > 0) { + sampleblock = (VOID **)*sampleblock; + samplesleft = samplesperblock; + totalpopulation -= population; + population = TRIPERBLOCK; + } + } + + /* Where are we? */ + org(*searchtri, torg); + dest(*searchtri, tdest); + /* Check the starting triangle's vertices. */ + if ((torg[0] == searchpoint[0]) && (torg[1] == searchpoint[1])) { + return ONVERTEX; + } + if ((tdest[0] == searchpoint[0]) && (tdest[1] == searchpoint[1])) { + lnextself(*searchtri); + return ONVERTEX; + } + /* Orient `searchtri' to fit the preconditions of calling preciselocate(). */ + ahead = counterclockwise(m, b, torg, tdest, searchpoint); + if (ahead < 0.0) { + /* Turn around so that `searchpoint' is to the left of the */ + /* edge specified by `searchtri'. */ + symself(*searchtri); + } else if (ahead == 0.0) { + /* Check if `searchpoint' is between `torg' and `tdest'. */ + if (((torg[0] < searchpoint[0]) == (searchpoint[0] < tdest[0])) && + ((torg[1] < searchpoint[1]) == (searchpoint[1] < tdest[1]))) { + return ONEDGE; + } + } + return preciselocate(m, b, searchpoint, searchtri, 0); +} + +/** **/ +/** **/ +/********* Point location routines end here *********/ + +/********* Mesh transformation routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* insertsubseg() Create a new subsegment and insert it between two */ +/* triangles. */ +/* */ +/* The new subsegment is inserted at the edge described by the handle */ +/* `tri'. Its vertices are properly initialized. The marker `subsegmark' */ +/* is applied to the subsegment and, if appropriate, its vertices. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void insertsubseg(struct mesh *m, struct behavior *b, struct otri *tri, + int subsegmark) +#else /* not ANSI_DECLARATORS */ +void insertsubseg(m, b, tri, subsegmark) struct mesh *m; +struct behavior *b; +struct otri *tri; /* Edge at which to insert the new subsegment. */ +int subsegmark; /* Marker for the new subsegment. */ +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri oppotri; + struct osub newsubseg; + vertex triorg, tridest; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + org(*tri, triorg); + dest(*tri, tridest); + /* Mark vertices if possible. */ + if (vertexmark(triorg) == 0) { + setvertexmark(triorg, subsegmark); + } + if (vertexmark(tridest) == 0) { + setvertexmark(tridest, subsegmark); + } + /* Check if there's already a subsegment here. */ + tspivot(*tri, newsubseg); + if (newsubseg.ss == m->dummysub) { + /* Make new subsegment and initialize its vertices. */ + makesubseg(m, &newsubseg); + setsorg(newsubseg, tridest); + setsdest(newsubseg, triorg); + setsegorg(newsubseg, tridest); + setsegdest(newsubseg, triorg); + /* Bond new subsegment to the two triangles it is sandwiched between. */ + /* Note that the facing triangle `oppotri' might be equal to */ + /* `dummytri' (outer space), but the new subsegment is bonded to it */ + /* all the same. */ + tsbond(*tri, newsubseg); + sym(*tri, oppotri); + ssymself(newsubseg); + tsbond(oppotri, newsubseg); + setmark(newsubseg, subsegmark); + if (b->verbose > 2) { + printf(" Inserting new "); + printsubseg(m, b, &newsubseg); + } + } else { + if (mark(newsubseg) == 0) { + setmark(newsubseg, subsegmark); + } + } +} + +/*****************************************************************************/ +/* */ +/* Terminology */ +/* */ +/* A "local transformation" replaces a small set of triangles with another */ +/* set of triangles. This may or may not involve inserting or deleting a */ +/* vertex. */ +/* */ +/* The term "casing" is used to describe the set of triangles that are */ +/* attached to the triangles being transformed, but are not transformed */ +/* themselves. Think of the casing as a fixed hollow structure inside */ +/* which all the action happens. A "casing" is only defined relative to */ +/* a single transformation; each occurrence of a transformation will */ +/* involve a different casing. */ +/* */ +/*****************************************************************************/ + +/*****************************************************************************/ +/* */ +/* flip() Transform two triangles to two different triangles by flipping */ +/* an edge counterclockwise within a quadrilateral. */ +/* */ +/* Imagine the original triangles, abc and bad, oriented so that the */ +/* shared edge ab lies in a horizontal plane, with the vertex b on the left */ +/* and the vertex a on the right. The vertex c lies below the edge, and */ +/* the vertex d lies above the edge. The `flipedge' handle holds the edge */ +/* ab of triangle abc, and is directed left, from vertex a to vertex b. */ +/* */ +/* The triangles abc and bad are deleted and replaced by the triangles cdb */ +/* and dca. The triangles that represent abc and bad are NOT deallocated; */ +/* they are reused for dca and cdb, respectively. Hence, any handles that */ +/* may have held the original triangles are still valid, although not */ +/* directed as they were before. */ +/* */ +/* Upon completion of this routine, the `flipedge' handle holds the edge */ +/* dc of triangle dca, and is directed down, from vertex d to vertex c. */ +/* (Hence, the two triangles have rotated counterclockwise.) */ +/* */ +/* WARNING: This transformation is geometrically valid only if the */ +/* quadrilateral adbc is convex. Furthermore, this transformation is */ +/* valid only if there is not a subsegment between the triangles abc and */ +/* bad. This routine does not check either of these preconditions, and */ +/* it is the responsibility of the calling routine to ensure that they are */ +/* met. If they are not, the streets shall be filled with wailing and */ +/* gnashing of teeth. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void flip(struct mesh *m, struct behavior *b, struct otri *flipedge) +#else /* not ANSI_DECLARATORS */ +void flip(m, b, flipedge) struct mesh *m; +struct behavior *b; +struct otri *flipedge; /* Handle for the triangle abc. */ +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri botleft, botright; + struct otri topleft, topright; + struct otri top; + struct otri botlcasing, botrcasing; + struct otri toplcasing, toprcasing; + struct osub botlsubseg, botrsubseg; + struct osub toplsubseg, toprsubseg; + vertex leftvertex, rightvertex, botvertex; + vertex farvertex; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + /* Identify the vertices of the quadrilateral. */ + org(*flipedge, rightvertex); + dest(*flipedge, leftvertex); + apex(*flipedge, botvertex); + sym(*flipedge, top); +#ifdef SELF_CHECK + if (top.tri == m->dummytri) { + printf("Internal error in flip(): Attempt to flip on boundary.\n"); + lnextself(*flipedge); + return; + } + if (m->checksegments) { + tspivot(*flipedge, toplsubseg); + if (toplsubseg.ss != m->dummysub) { + printf("Internal error in flip(): Attempt to flip a segment.\n"); + lnextself(*flipedge); + return; + } + } +#endif /* SELF_CHECK */ + apex(top, farvertex); + + /* Identify the casing of the quadrilateral. */ + lprev(top, topleft); + sym(topleft, toplcasing); + lnext(top, topright); + sym(topright, toprcasing); + lnext(*flipedge, botleft); + sym(botleft, botlcasing); + lprev(*flipedge, botright); + sym(botright, botrcasing); + /* Rotate the quadrilateral one-quarter turn counterclockwise. */ + bond(topleft, botlcasing); + bond(botleft, botrcasing); + bond(botright, toprcasing); + bond(topright, toplcasing); + + if (m->checksegments) { + /* Check for subsegments and rebond them to the quadrilateral. */ + tspivot(topleft, toplsubseg); + tspivot(botleft, botlsubseg); + tspivot(botright, botrsubseg); + tspivot(topright, toprsubseg); + if (toplsubseg.ss == m->dummysub) { + tsdissolve(topright); + } else { + tsbond(topright, toplsubseg); + } + if (botlsubseg.ss == m->dummysub) { + tsdissolve(topleft); + } else { + tsbond(topleft, botlsubseg); + } + if (botrsubseg.ss == m->dummysub) { + tsdissolve(botleft); + } else { + tsbond(botleft, botrsubseg); + } + if (toprsubseg.ss == m->dummysub) { + tsdissolve(botright); + } else { + tsbond(botright, toprsubseg); + } + } + + /* New vertex assignments for the rotated quadrilateral. */ + setorg(*flipedge, farvertex); + setdest(*flipedge, botvertex); + setapex(*flipedge, rightvertex); + setorg(top, botvertex); + setdest(top, farvertex); + setapex(top, leftvertex); + if (b->verbose > 2) { + printf(" Edge flip results in left "); + printtriangle(m, b, &top); + printf(" and right "); + printtriangle(m, b, flipedge); + } +} + +/*****************************************************************************/ +/* */ +/* unflip() Transform two triangles to two different triangles by */ +/* flipping an edge clockwise within a quadrilateral. Reverses */ +/* the flip() operation so that the data structures representing */ +/* the triangles are back where they were before the flip(). */ +/* */ +/* Imagine the original triangles, abc and bad, oriented so that the */ +/* shared edge ab lies in a horizontal plane, with the vertex b on the left */ +/* and the vertex a on the right. The vertex c lies below the edge, and */ +/* the vertex d lies above the edge. The `flipedge' handle holds the edge */ +/* ab of triangle abc, and is directed left, from vertex a to vertex b. */ +/* */ +/* The triangles abc and bad are deleted and replaced by the triangles cdb */ +/* and dca. The triangles that represent abc and bad are NOT deallocated; */ +/* they are reused for cdb and dca, respectively. Hence, any handles that */ +/* may have held the original triangles are still valid, although not */ +/* directed as they were before. */ +/* */ +/* Upon completion of this routine, the `flipedge' handle holds the edge */ +/* cd of triangle cdb, and is directed up, from vertex c to vertex d. */ +/* (Hence, the two triangles have rotated clockwise.) */ +/* */ +/* WARNING: This transformation is geometrically valid only if the */ +/* quadrilateral adbc is convex. Furthermore, this transformation is */ +/* valid only if there is not a subsegment between the triangles abc and */ +/* bad. This routine does not check either of these preconditions, and */ +/* it is the responsibility of the calling routine to ensure that they are */ +/* met. If they are not, the streets shall be filled with wailing and */ +/* gnashing of teeth. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void unflip(struct mesh *m, struct behavior *b, struct otri *flipedge) +#else /* not ANSI_DECLARATORS */ +void unflip(m, b, flipedge) struct mesh *m; +struct behavior *b; +struct otri *flipedge; /* Handle for the triangle abc. */ +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri botleft, botright; + struct otri topleft, topright; + struct otri top; + struct otri botlcasing, botrcasing; + struct otri toplcasing, toprcasing; + struct osub botlsubseg, botrsubseg; + struct osub toplsubseg, toprsubseg; + vertex leftvertex, rightvertex, botvertex; + vertex farvertex; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + /* Identify the vertices of the quadrilateral. */ + org(*flipedge, rightvertex); + dest(*flipedge, leftvertex); + apex(*flipedge, botvertex); + sym(*flipedge, top); +#ifdef SELF_CHECK + if (top.tri == m->dummytri) { + printf("Internal error in unflip(): Attempt to flip on boundary.\n"); + lnextself(*flipedge); + return; + } + if (m->checksegments) { + tspivot(*flipedge, toplsubseg); + if (toplsubseg.ss != m->dummysub) { + printf("Internal error in unflip(): Attempt to flip a subsegment.\n"); + lnextself(*flipedge); + return; + } + } +#endif /* SELF_CHECK */ + apex(top, farvertex); + + /* Identify the casing of the quadrilateral. */ + lprev(top, topleft); + sym(topleft, toplcasing); + lnext(top, topright); + sym(topright, toprcasing); + lnext(*flipedge, botleft); + sym(botleft, botlcasing); + lprev(*flipedge, botright); + sym(botright, botrcasing); + /* Rotate the quadrilateral one-quarter turn clockwise. */ + bond(topleft, toprcasing); + bond(botleft, toplcasing); + bond(botright, botlcasing); + bond(topright, botrcasing); + + if (m->checksegments) { + /* Check for subsegments and rebond them to the quadrilateral. */ + tspivot(topleft, toplsubseg); + tspivot(botleft, botlsubseg); + tspivot(botright, botrsubseg); + tspivot(topright, toprsubseg); + if (toplsubseg.ss == m->dummysub) { + tsdissolve(botleft); + } else { + tsbond(botleft, toplsubseg); + } + if (botlsubseg.ss == m->dummysub) { + tsdissolve(botright); + } else { + tsbond(botright, botlsubseg); + } + if (botrsubseg.ss == m->dummysub) { + tsdissolve(topright); + } else { + tsbond(topright, botrsubseg); + } + if (toprsubseg.ss == m->dummysub) { + tsdissolve(topleft); + } else { + tsbond(topleft, toprsubseg); + } + } + + /* New vertex assignments for the rotated quadrilateral. */ + setorg(*flipedge, botvertex); + setdest(*flipedge, farvertex); + setapex(*flipedge, leftvertex); + setorg(top, farvertex); + setdest(top, botvertex); + setapex(top, rightvertex); + if (b->verbose > 2) { + printf(" Edge unflip results in left "); + printtriangle(m, b, flipedge); + printf(" and right "); + printtriangle(m, b, &top); + } +} + +/*****************************************************************************/ +/* */ +/* insertvertex() Insert a vertex into a Delaunay triangulation, */ +/* performing flips as necessary to maintain the Delaunay */ +/* property. */ +/* */ +/* The point `insertvertex' is located. If `searchtri.tri' is not NULL, */ +/* the search for the containing triangle begins from `searchtri'. If */ +/* `searchtri.tri' is NULL, a full point location procedure is called. */ +/* If `insertvertex' is found inside a triangle, the triangle is split into */ +/* three; if `insertvertex' lies on an edge, the edge is split in two, */ +/* thereby splitting the two adjacent triangles into four. Edge flips are */ +/* used to restore the Delaunay property. If `insertvertex' lies on an */ +/* existing vertex, no action is taken, and the value DUPLICATEVERTEX is */ +/* returned. On return, `searchtri' is set to a handle whose origin is the */ +/* existing vertex. */ +/* */ +/* Normally, the parameter `splitseg' is set to NULL, implying that no */ +/* subsegment should be split. In this case, if `insertvertex' is found to */ +/* lie on a segment, no action is taken, and the value VIOLATINGVERTEX is */ +/* returned. On return, `searchtri' is set to a handle whose primary edge */ +/* is the violated subsegment. */ +/* */ +/* If the calling routine wishes to split a subsegment by inserting a */ +/* vertex in it, the parameter `splitseg' should be that subsegment. In */ +/* this case, `searchtri' MUST be the triangle handle reached by pivoting */ +/* from that subsegment; no point location is done. */ +/* */ +/* `segmentflaws' and `triflaws' are flags that indicate whether or not */ +/* there should be checks for the creation of encroached subsegments or bad */ +/* quality triangles. If a newly inserted vertex encroaches upon */ +/* subsegments, these subsegments are added to the list of subsegments to */ +/* be split if `segmentflaws' is set. If bad triangles are created, these */ +/* are added to the queue if `triflaws' is set. */ +/* */ +/* If a duplicate vertex or violated segment does not prevent the vertex */ +/* from being inserted, the return value will be ENCROACHINGVERTEX if the */ +/* vertex encroaches upon a subsegment (and checking is enabled), or */ +/* SUCCESSFULVERTEX otherwise. In either case, `searchtri' is set to a */ +/* handle whose origin is the newly inserted vertex. */ +/* */ +/* insertvertex() does not use flip() for reasons of speed; some */ +/* information can be reused from edge flip to edge flip, like the */ +/* locations of subsegments. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +enum insertvertexresult insertvertex(struct mesh *m, struct behavior *b, + vertex newvertex, struct otri *searchtri, + struct osub *splitseg, int segmentflaws, + int triflaws) +#else /* not ANSI_DECLARATORS */ +enum insertvertexresult insertvertex(m, b, newvertex, searchtri, splitseg, + segmentflaws, triflaws) +struct mesh *m; +struct behavior *b; +vertex newvertex; +struct otri *searchtri; +struct osub *splitseg; +int segmentflaws; +int triflaws; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri horiz; + struct otri top; + struct otri botleft, botright; + struct otri topleft, topright; + struct otri newbotleft, newbotright; + struct otri newtopright; + struct otri botlcasing, botrcasing; + struct otri toplcasing, toprcasing; + struct otri testtri; + struct osub botlsubseg, botrsubseg; + struct osub toplsubseg, toprsubseg; + struct osub brokensubseg; + struct osub checksubseg; + struct osub rightsubseg; + struct osub newsubseg; + struct badsubseg *encroached; + struct flipstacker *newflip; + vertex first; + vertex leftvertex, rightvertex, botvertex, topvertex, farvertex; + vertex segmentorg, segmentdest; + REAL attrib; + REAL area; + enum insertvertexresult success; + enum locateresult intersect; + int doflip; + int mirrorflag; + int enq; + int i; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by spivot() and tspivot(). */ + + if (b->verbose > 1) { + printf(" Inserting (%.12g, %.12g).\n", newvertex[0], newvertex[1]); + } + + if (splitseg == (struct osub *)NULL) { + /* Find the location of the vertex to be inserted. Check if a good */ + /* starting triangle has already been provided by the caller. */ + if (searchtri->tri == m->dummytri) { + /* Find a boundary triangle. */ + horiz.tri = m->dummytri; + horiz.orient = 0; + symself(horiz); + /* Search for a triangle containing `newvertex'. */ + intersect = locate(m, b, newvertex, &horiz); + } else { + /* Start searching from the triangle provided by the caller. */ + otricopy(*searchtri, horiz); + intersect = preciselocate(m, b, newvertex, &horiz, 1); + } + } else { + /* The calling routine provides the subsegment in which */ + /* the vertex is inserted. */ + otricopy(*searchtri, horiz); + intersect = ONEDGE; + } + + if (intersect == ONVERTEX) { + /* There's already a vertex there. Return in `searchtri' a triangle */ + /* whose origin is the existing vertex. */ + otricopy(horiz, *searchtri); + otricopy(horiz, m->recenttri); + return DUPLICATEVERTEX; + } + if ((intersect == ONEDGE) || (intersect == OUTSIDE)) { + /* The vertex falls on an edge or boundary. */ + if (m->checksegments && (splitseg == (struct osub *)NULL)) { + /* Check whether the vertex falls on a subsegment. */ + tspivot(horiz, brokensubseg); + if (brokensubseg.ss != m->dummysub) { + /* The vertex falls on a subsegment, and hence will not be inserted. */ + if (segmentflaws) { + enq = b->nobisect != 2; + if (enq && (b->nobisect == 1)) { + /* This subsegment may be split only if it is an */ + /* internal boundary. */ + sym(horiz, testtri); + enq = testtri.tri != m->dummytri; + } + if (enq) { + /* Add the subsegment to the list of encroached subsegments. */ + encroached = (struct badsubseg *)poolalloc(&m->badsubsegs); + encroached->encsubseg = sencode(brokensubseg); + sorg(brokensubseg, encroached->subsegorg); + sdest(brokensubseg, encroached->subsegdest); + if (b->verbose > 2) { + printf(" Queueing encroached subsegment (%.12g, %.12g) (%.12g, " + "%.12g).\n", + encroached->subsegorg[0], encroached->subsegorg[1], + encroached->subsegdest[0], encroached->subsegdest[1]); + } + } + } + /* Return a handle whose primary edge contains the vertex, */ + /* which has not been inserted. */ + otricopy(horiz, *searchtri); + otricopy(horiz, m->recenttri); + return VIOLATINGVERTEX; + } + } + + /* Insert the vertex on an edge, dividing one triangle into two (if */ + /* the edge lies on a boundary) or two triangles into four. */ + lprev(horiz, botright); + sym(botright, botrcasing); + sym(horiz, topright); + /* Is there a second triangle? (Or does this edge lie on a boundary?) */ + mirrorflag = topright.tri != m->dummytri; + if (mirrorflag) { + lnextself(topright); + sym(topright, toprcasing); + maketriangle(m, b, &newtopright); + } else { + /* Splitting a boundary edge increases the number of boundary edges. */ + m->hullsize++; + } + maketriangle(m, b, &newbotright); + + /* Set the vertices of changed and new triangles. */ + org(horiz, rightvertex); + dest(horiz, leftvertex); + apex(horiz, botvertex); + setorg(newbotright, botvertex); + setdest(newbotright, rightvertex); + setapex(newbotright, newvertex); + setorg(horiz, newvertex); + for (i = 0; i < m->eextras; i++) { + /* Set the element attributes of a new triangle. */ + setelemattribute(newbotright, i, elemattribute(botright, i)); + } + if (b->vararea) { + /* Set the area constraint of a new triangle. */ + setareabound(newbotright, areabound(botright)); + } + if (mirrorflag) { + dest(topright, topvertex); + setorg(newtopright, rightvertex); + setdest(newtopright, topvertex); + setapex(newtopright, newvertex); + setorg(topright, newvertex); + for (i = 0; i < m->eextras; i++) { + /* Set the element attributes of another new triangle. */ + setelemattribute(newtopright, i, elemattribute(topright, i)); + } + if (b->vararea) { + /* Set the area constraint of another new triangle. */ + setareabound(newtopright, areabound(topright)); + } + } + + /* There may be subsegments that need to be bonded */ + /* to the new triangle(s). */ + if (m->checksegments) { + tspivot(botright, botrsubseg); + if (botrsubseg.ss != m->dummysub) { + tsdissolve(botright); + tsbond(newbotright, botrsubseg); + } + if (mirrorflag) { + tspivot(topright, toprsubseg); + if (toprsubseg.ss != m->dummysub) { + tsdissolve(topright); + tsbond(newtopright, toprsubseg); + } + } + } + + /* Bond the new triangle(s) to the surrounding triangles. */ + bond(newbotright, botrcasing); + lprevself(newbotright); + bond(newbotright, botright); + lprevself(newbotright); + if (mirrorflag) { + bond(newtopright, toprcasing); + lnextself(newtopright); + bond(newtopright, topright); + lnextself(newtopright); + bond(newtopright, newbotright); + } + + if (splitseg != (struct osub *)NULL) { + /* Split the subsegment into two. */ + setsdest(*splitseg, newvertex); + segorg(*splitseg, segmentorg); + segdest(*splitseg, segmentdest); + ssymself(*splitseg); + spivot(*splitseg, rightsubseg); + insertsubseg(m, b, &newbotright, mark(*splitseg)); + tspivot(newbotright, newsubseg); + setsegorg(newsubseg, segmentorg); + setsegdest(newsubseg, segmentdest); + sbond(*splitseg, newsubseg); + ssymself(newsubseg); + sbond(newsubseg, rightsubseg); + ssymself(*splitseg); + /* Transfer the subsegment's boundary marker to the vertex */ + /* if required. */ + if (vertexmark(newvertex) == 0) { + setvertexmark(newvertex, mark(*splitseg)); + } + } + + if (m->checkquality) { + poolrestart(&m->flipstackers); + m->lastflip = (struct flipstacker *)poolalloc(&m->flipstackers); + m->lastflip->flippedtri = encode(horiz); + m->lastflip->prevflip = (struct flipstacker *)&insertvertex; + } + +#ifdef SELF_CHECK + if (counterclockwise(m, b, rightvertex, leftvertex, botvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle prior to edge vertex insertion (bottom).\n"); + } + if (mirrorflag) { + if (counterclockwise(m, b, leftvertex, rightvertex, topvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle prior to edge vertex insertion (top).\n"); + } + if (counterclockwise(m, b, rightvertex, topvertex, newvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf( + " Clockwise triangle after edge vertex insertion (top right).\n"); + } + if (counterclockwise(m, b, topvertex, leftvertex, newvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf( + " Clockwise triangle after edge vertex insertion (top left).\n"); + } + } + if (counterclockwise(m, b, leftvertex, botvertex, newvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf( + " Clockwise triangle after edge vertex insertion (bottom left).\n"); + } + if (counterclockwise(m, b, botvertex, rightvertex, newvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf( + " Clockwise triangle after edge vertex insertion (bottom right).\n"); + } +#endif /* SELF_CHECK */ + if (b->verbose > 2) { + printf(" Updating bottom left "); + printtriangle(m, b, &botright); + if (mirrorflag) { + printf(" Updating top left "); + printtriangle(m, b, &topright); + printf(" Creating top right "); + printtriangle(m, b, &newtopright); + } + printf(" Creating bottom right "); + printtriangle(m, b, &newbotright); + } + + /* Position `horiz' on the first edge to check for */ + /* the Delaunay property. */ + lnextself(horiz); + } else { + /* Insert the vertex in a triangle, splitting it into three. */ + lnext(horiz, botleft); + lprev(horiz, botright); + sym(botleft, botlcasing); + sym(botright, botrcasing); + maketriangle(m, b, &newbotleft); + maketriangle(m, b, &newbotright); + + /* Set the vertices of changed and new triangles. */ + org(horiz, rightvertex); + dest(horiz, leftvertex); + apex(horiz, botvertex); + setorg(newbotleft, leftvertex); + setdest(newbotleft, botvertex); + setapex(newbotleft, newvertex); + setorg(newbotright, botvertex); + setdest(newbotright, rightvertex); + setapex(newbotright, newvertex); + setapex(horiz, newvertex); + for (i = 0; i < m->eextras; i++) { + /* Set the element attributes of the new triangles. */ + attrib = elemattribute(horiz, i); + setelemattribute(newbotleft, i, attrib); + setelemattribute(newbotright, i, attrib); + } + if (b->vararea) { + /* Set the area constraint of the new triangles. */ + area = areabound(horiz); + setareabound(newbotleft, area); + setareabound(newbotright, area); + } + + /* There may be subsegments that need to be bonded */ + /* to the new triangles. */ + if (m->checksegments) { + tspivot(botleft, botlsubseg); + if (botlsubseg.ss != m->dummysub) { + tsdissolve(botleft); + tsbond(newbotleft, botlsubseg); + } + tspivot(botright, botrsubseg); + if (botrsubseg.ss != m->dummysub) { + tsdissolve(botright); + tsbond(newbotright, botrsubseg); + } + } + + /* Bond the new triangles to the surrounding triangles. */ + bond(newbotleft, botlcasing); + bond(newbotright, botrcasing); + lnextself(newbotleft); + lprevself(newbotright); + bond(newbotleft, newbotright); + lnextself(newbotleft); + bond(botleft, newbotleft); + lprevself(newbotright); + bond(botright, newbotright); + + if (m->checkquality) { + poolrestart(&m->flipstackers); + m->lastflip = (struct flipstacker *)poolalloc(&m->flipstackers); + m->lastflip->flippedtri = encode(horiz); + m->lastflip->prevflip = (struct flipstacker *)NULL; + } + +#ifdef SELF_CHECK + if (counterclockwise(m, b, rightvertex, leftvertex, botvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle prior to vertex insertion.\n"); + } + if (counterclockwise(m, b, rightvertex, leftvertex, newvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle after vertex insertion (top).\n"); + } + if (counterclockwise(m, b, leftvertex, botvertex, newvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle after vertex insertion (left).\n"); + } + if (counterclockwise(m, b, botvertex, rightvertex, newvertex) < 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle after vertex insertion (right).\n"); + } +#endif /* SELF_CHECK */ + if (b->verbose > 2) { + printf(" Updating top "); + printtriangle(m, b, &horiz); + printf(" Creating left "); + printtriangle(m, b, &newbotleft); + printf(" Creating right "); + printtriangle(m, b, &newbotright); + } + } + + /* The insertion is successful by default, unless an encroached */ + /* subsegment is found. */ + success = SUCCESSFULVERTEX; + /* Circle around the newly inserted vertex, checking each edge opposite */ + /* it for the Delaunay property. Non-Delaunay edges are flipped. */ + /* `horiz' is always the edge being checked. `first' marks where to */ + /* stop circling. */ + org(horiz, first); + rightvertex = first; + dest(horiz, leftvertex); + /* Circle until finished. */ + while (1) { + /* By default, the edge will be flipped. */ + doflip = 1; + + if (m->checksegments) { + /* Check for a subsegment, which cannot be flipped. */ + tspivot(horiz, checksubseg); + if (checksubseg.ss != m->dummysub) { + /* The edge is a subsegment and cannot be flipped. */ + doflip = 0; +#ifndef CDT_ONLY + if (segmentflaws) { + /* Does the new vertex encroach upon this subsegment? */ + if (checkseg4encroach(m, b, &checksubseg)) { + success = ENCROACHINGVERTEX; + } + } +#endif /* not CDT_ONLY */ + } + } + + if (doflip) { + /* Check if the edge is a boundary edge. */ + sym(horiz, top); + if (top.tri == m->dummytri) { + /* The edge is a boundary edge and cannot be flipped. */ + doflip = 0; + } else { + /* Find the vertex on the other side of the edge. */ + apex(top, farvertex); + /* In the incremental Delaunay triangulation algorithm, any of */ + /* `leftvertex', `rightvertex', and `farvertex' could be vertices */ + /* of the triangular bounding box. These vertices must be */ + /* treated as if they are infinitely distant, even though their */ + /* "coordinates" are not. */ + if ((leftvertex == m->infvertex1) || (leftvertex == m->infvertex2) || + (leftvertex == m->infvertex3)) { + /* `leftvertex' is infinitely distant. Check the convexity of */ + /* the boundary of the triangulation. 'farvertex' might be */ + /* infinite as well, but trust me, this same condition should */ + /* be applied. */ + doflip = + counterclockwise(m, b, newvertex, rightvertex, farvertex) > 0.0; + } else if ((rightvertex == m->infvertex1) || + (rightvertex == m->infvertex2) || + (rightvertex == m->infvertex3)) { + /* `rightvertex' is infinitely distant. Check the convexity of */ + /* the boundary of the triangulation. 'farvertex' might be */ + /* infinite as well, but trust me, this same condition should */ + /* be applied. */ + doflip = + counterclockwise(m, b, farvertex, leftvertex, newvertex) > 0.0; + } else if ((farvertex == m->infvertex1) || + (farvertex == m->infvertex2) || + (farvertex == m->infvertex3)) { + /* `farvertex' is infinitely distant and cannot be inside */ + /* the circumcircle of the triangle `horiz'. */ + doflip = 0; + } else { + /* Test whether the edge is locally Delaunay. */ + doflip = incircle(m, b, leftvertex, newvertex, rightvertex, + farvertex) > 0.0; + } + if (doflip) { + /* We made it! Flip the edge `horiz' by rotating its containing */ + /* quadrilateral (the two triangles adjacent to `horiz'). */ + /* Identify the casing of the quadrilateral. */ + lprev(top, topleft); + sym(topleft, toplcasing); + lnext(top, topright); + sym(topright, toprcasing); + lnext(horiz, botleft); + sym(botleft, botlcasing); + lprev(horiz, botright); + sym(botright, botrcasing); + /* Rotate the quadrilateral one-quarter turn counterclockwise. */ + bond(topleft, botlcasing); + bond(botleft, botrcasing); + bond(botright, toprcasing); + bond(topright, toplcasing); + if (m->checksegments) { + /* Check for subsegments and rebond them to the quadrilateral. */ + tspivot(topleft, toplsubseg); + tspivot(botleft, botlsubseg); + tspivot(botright, botrsubseg); + tspivot(topright, toprsubseg); + if (toplsubseg.ss == m->dummysub) { + tsdissolve(topright); + } else { + tsbond(topright, toplsubseg); + } + if (botlsubseg.ss == m->dummysub) { + tsdissolve(topleft); + } else { + tsbond(topleft, botlsubseg); + } + if (botrsubseg.ss == m->dummysub) { + tsdissolve(botleft); + } else { + tsbond(botleft, botrsubseg); + } + if (toprsubseg.ss == m->dummysub) { + tsdissolve(botright); + } else { + tsbond(botright, toprsubseg); + } + } + /* New vertex assignments for the rotated quadrilateral. */ + setorg(horiz, farvertex); + setdest(horiz, newvertex); + setapex(horiz, rightvertex); + setorg(top, newvertex); + setdest(top, farvertex); + setapex(top, leftvertex); + for (i = 0; i < m->eextras; i++) { + /* Take the average of the two triangles' attributes. */ + attrib = 0.5 * (elemattribute(top, i) + elemattribute(horiz, i)); + setelemattribute(top, i, attrib); + setelemattribute(horiz, i, attrib); + } + if (b->vararea) { + if ((areabound(top) <= 0.0) || (areabound(horiz) <= 0.0)) { + area = -1.0; + } else { + /* Take the average of the two triangles' area constraints. */ + /* This prevents small area constraints from migrating a */ + /* long, long way from their original location due to flips. */ + area = 0.5 * (areabound(top) + areabound(horiz)); + } + setareabound(top, area); + setareabound(horiz, area); + } + + if (m->checkquality) { + newflip = (struct flipstacker *)poolalloc(&m->flipstackers); + newflip->flippedtri = encode(horiz); + newflip->prevflip = m->lastflip; + m->lastflip = newflip; + } + +#ifdef SELF_CHECK + if (newvertex != (vertex)NULL) { + if (counterclockwise(m, b, leftvertex, newvertex, rightvertex) < + 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle prior to edge flip (bottom).\n"); + } + /* The following test has been removed because constrainededge() */ + /* sometimes generates inverted triangles that insertvertex() */ + /* removes. */ + /* + if (counterclockwise(m, b, rightvertex, farvertex, + leftvertex) < 0.0) { printf("Internal error in + insertvertex():\n"); printf(" Clockwise triangle prior to edge + flip (top).\n"); + } + */ + if (counterclockwise(m, b, farvertex, leftvertex, newvertex) < + 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle after edge flip (left).\n"); + } + if (counterclockwise(m, b, newvertex, rightvertex, farvertex) < + 0.0) { + printf("Internal error in insertvertex():\n"); + printf(" Clockwise triangle after edge flip (right).\n"); + } + } +#endif /* SELF_CHECK */ + if (b->verbose > 2) { + printf(" Edge flip results in left "); + lnextself(topleft); + printtriangle(m, b, &topleft); + printf(" and right "); + printtriangle(m, b, &horiz); + } + /* On the next iterations, consider the two edges that were */ + /* exposed (this is, are now visible to the newly inserted */ + /* vertex) by the edge flip. */ + lprevself(horiz); + leftvertex = farvertex; + } + } + } + if (!doflip) { + /* The handle `horiz' is accepted as locally Delaunay. */ +#ifndef CDT_ONLY + if (triflaws) { + /* Check the triangle `horiz' for quality. */ + testtriangle(m, b, &horiz); + } +#endif /* not CDT_ONLY */ + /* Look for the next edge around the newly inserted vertex. */ + lnextself(horiz); + sym(horiz, testtri); + /* Check for finishing a complete revolution about the new vertex, or */ + /* falling outside of the triangulation. The latter will happen */ + /* when a vertex is inserted at a boundary. */ + if ((leftvertex == first) || (testtri.tri == m->dummytri)) { + /* We're done. Return a triangle whose origin is the new vertex. */ + lnext(horiz, *searchtri); + lnext(horiz, m->recenttri); + return success; + } + /* Finish finding the next edge around the newly inserted vertex. */ + lnext(testtri, horiz); + rightvertex = leftvertex; + dest(horiz, leftvertex); + } + } +} + +/*****************************************************************************/ +/* */ +/* triangulatepolygon() Find the Delaunay triangulation of a polygon that */ +/* has a certain "nice" shape. This includes the */ +/* polygons that result from deletion of a vertex or */ +/* insertion of a segment. */ +/* */ +/* This is a conceptually difficult routine. The starting assumption is */ +/* that we have a polygon with n sides. n - 1 of these sides are currently */ +/* represented as edges in the mesh. One side, called the "base", need not */ +/* be. */ +/* */ +/* Inside the polygon is a structure I call a "fan", consisting of n - 1 */ +/* triangles that share a common origin. For each of these triangles, the */ +/* edge opposite the origin is one of the sides of the polygon. The */ +/* primary edge of each triangle is the edge directed from the origin to */ +/* the destination; note that this is not the same edge that is a side of */ +/* the polygon. `firstedge' is the primary edge of the first triangle. */ +/* From there, the triangles follow in counterclockwise order about the */ +/* polygon, until `lastedge', the primary edge of the last triangle. */ +/* `firstedge' and `lastedge' are probably connected to other triangles */ +/* beyond the extremes of the fan, but their identity is not important, as */ +/* long as the fan remains connected to them. */ +/* */ +/* Imagine the polygon oriented so that its base is at the bottom. This */ +/* puts `firstedge' on the far right, and `lastedge' on the far left. */ +/* The right vertex of the base is the destination of `firstedge', and the */ +/* left vertex of the base is the apex of `lastedge'. */ +/* */ +/* The challenge now is to find the right sequence of edge flips to */ +/* transform the fan into a Delaunay triangulation of the polygon. Each */ +/* edge flip effectively removes one triangle from the fan, committing it */ +/* to the polygon. The resulting polygon has one fewer edge. If `doflip' */ +/* is set, the final flip will be performed, resulting in a fan of one */ +/* (useless?) triangle. If `doflip' is not set, the final flip is not */ +/* performed, resulting in a fan of two triangles, and an unfinished */ +/* triangular polygon that is not yet filled out with a single triangle. */ +/* On completion of the routine, `lastedge' is the last remaining triangle, */ +/* or the leftmost of the last two. */ +/* */ +/* Although the flips are performed in the order described above, the */ +/* decisions about what flips to perform are made in precisely the reverse */ +/* order. The recursive triangulatepolygon() procedure makes a decision, */ +/* uses up to two recursive calls to triangulate the "subproblems" */ +/* (polygons with fewer edges), and then performs an edge flip. */ +/* */ +/* The "decision" it makes is which vertex of the polygon should be */ +/* connected to the base. This decision is made by testing every possible */ +/* vertex. Once the best vertex is found, the two edges that connect this */ +/* vertex to the base become the bases for two smaller polygons. These */ +/* are triangulated recursively. Unfortunately, this approach can take */ +/* O(n^2) time not only in the worst case, but in many common cases. It's */ +/* rarely a big deal for vertex deletion, where n is rarely larger than */ +/* ten, but it could be a big deal for segment insertion, especially if */ +/* there's a lot of long segments that each cut many triangles. I ought to */ +/* code a faster algorithm some day. */ +/* */ +/* The `edgecount' parameter is the number of sides of the polygon, */ +/* including its base. `triflaws' is a flag that determines whether the */ +/* new triangles should be tested for quality, and enqueued if they are */ +/* bad. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void triangulatepolygon(struct mesh *m, struct behavior *b, + struct otri *firstedge, struct otri *lastedge, + int edgecount, int doflip, int triflaws) +#else /* not ANSI_DECLARATORS */ +void triangulatepolygon(m, b, firstedge, lastedge, edgecount, doflip, + triflaws) struct mesh *m; +struct behavior *b; +struct otri *firstedge; +struct otri *lastedge; +int edgecount; +int doflip; +int triflaws; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri testtri; + struct otri besttri; + struct otri tempedge; + vertex leftbasevertex, rightbasevertex; + vertex testvertex; + vertex bestvertex; + int bestnumber; + int i; + triangle ptr; /* Temporary variable used by sym(), onext(), and oprev(). */ + + /* Identify the base vertices. */ + apex(*lastedge, leftbasevertex); + dest(*firstedge, rightbasevertex); + if (b->verbose > 2) { + printf(" Triangulating interior polygon at edge\n"); + printf(" (%.12g, %.12g) (%.12g, %.12g)\n", leftbasevertex[0], + leftbasevertex[1], rightbasevertex[0], rightbasevertex[1]); + } + /* Find the best vertex to connect the base to. */ + onext(*firstedge, besttri); + dest(besttri, bestvertex); + otricopy(besttri, testtri); + bestnumber = 1; + for (i = 2; i <= edgecount - 2; i++) { + onextself(testtri); + dest(testtri, testvertex); + /* Is this a better vertex? */ + if (incircle(m, b, leftbasevertex, rightbasevertex, bestvertex, + testvertex) > 0.0) { + otricopy(testtri, besttri); + bestvertex = testvertex; + bestnumber = i; + } + } + if (b->verbose > 2) { + printf(" Connecting edge to (%.12g, %.12g)\n", bestvertex[0], + bestvertex[1]); + } + if (bestnumber > 1) { + /* Recursively triangulate the smaller polygon on the right. */ + oprev(besttri, tempedge); + triangulatepolygon(m, b, firstedge, &tempedge, bestnumber + 1, 1, triflaws); + } + if (bestnumber < edgecount - 2) { + /* Recursively triangulate the smaller polygon on the left. */ + sym(besttri, tempedge); + triangulatepolygon(m, b, &besttri, lastedge, edgecount - bestnumber, 1, + triflaws); + /* Find `besttri' again; it may have been lost to edge flips. */ + sym(tempedge, besttri); + } + if (doflip) { + /* Do one final edge flip. */ + flip(m, b, &besttri); +#ifndef CDT_ONLY + if (triflaws) { + /* Check the quality of the newly committed triangle. */ + sym(besttri, testtri); + testtriangle(m, b, &testtri); + } +#endif /* not CDT_ONLY */ + } + /* Return the base triangle. */ + otricopy(besttri, *lastedge); +} + +/*****************************************************************************/ +/* */ +/* deletevertex() Delete a vertex from a Delaunay triangulation, ensuring */ +/* that the triangulation remains Delaunay. */ +/* */ +/* The origin of `deltri' is deleted. The union of the triangles adjacent */ +/* to this vertex is a polygon, for which the Delaunay triangulation is */ +/* found. Two triangles are removed from the mesh. */ +/* */ +/* Only interior vertices that do not lie on segments or boundaries may be */ +/* deleted. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void deletevertex(struct mesh *m, struct behavior *b, struct otri *deltri) +#else /* not ANSI_DECLARATORS */ +void deletevertex(m, b, deltri) struct mesh *m; +struct behavior *b; +struct otri *deltri; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri countingtri; + struct otri firstedge, lastedge; + struct otri deltriright; + struct otri lefttri, righttri; + struct otri leftcasing, rightcasing; + struct osub leftsubseg, rightsubseg; + vertex delvertex; + vertex neworg; + int edgecount; + triangle ptr; /* Temporary variable used by sym(), onext(), and oprev(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + org(*deltri, delvertex); + if (b->verbose > 1) { + printf(" Deleting (%.12g, %.12g).\n", delvertex[0], delvertex[1]); + } + vertexdealloc(m, delvertex); + + /* Count the degree of the vertex being deleted. */ + onext(*deltri, countingtri); + edgecount = 1; + while (!otriequal(*deltri, countingtri)) { +#ifdef SELF_CHECK + if (countingtri.tri == m->dummytri) { + printf("Internal error in deletevertex():\n"); + printf(" Attempt to delete boundary vertex.\n"); + internalerror(); + } +#endif /* SELF_CHECK */ + edgecount++; + onextself(countingtri); + } + +#ifdef SELF_CHECK + if (edgecount < 3) { + printf("Internal error in deletevertex():\n Vertex has degree %d.\n", + edgecount); + internalerror(); + } +#endif /* SELF_CHECK */ + if (edgecount > 3) { + /* Triangulate the polygon defined by the union of all triangles */ + /* adjacent to the vertex being deleted. Check the quality of */ + /* the resulting triangles. */ + onext(*deltri, firstedge); + oprev(*deltri, lastedge); + triangulatepolygon(m, b, &firstedge, &lastedge, edgecount, 0, !b->nobisect); + } + /* Splice out two triangles. */ + lprev(*deltri, deltriright); + dnext(*deltri, lefttri); + sym(lefttri, leftcasing); + oprev(deltriright, righttri); + sym(righttri, rightcasing); + bond(*deltri, leftcasing); + bond(deltriright, rightcasing); + tspivot(lefttri, leftsubseg); + if (leftsubseg.ss != m->dummysub) { + tsbond(*deltri, leftsubseg); + } + tspivot(righttri, rightsubseg); + if (rightsubseg.ss != m->dummysub) { + tsbond(deltriright, rightsubseg); + } + + /* Set the new origin of `deltri' and check its quality. */ + org(lefttri, neworg); + setorg(*deltri, neworg); + if (!b->nobisect) { + testtriangle(m, b, deltri); + } + + /* Delete the two spliced-out triangles. */ + triangledealloc(m, lefttri.tri); + triangledealloc(m, righttri.tri); +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* undovertex() Undo the most recent vertex insertion. */ +/* */ +/* Walks through the list of transformations (flips and a vertex insertion) */ +/* in the reverse of the order in which they were done, and undoes them. */ +/* The inserted vertex is removed from the triangulation and deallocated. */ +/* Two triangles (possibly just one) are also deallocated. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void undovertex(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void undovertex(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri fliptri; + struct otri botleft, botright, topright; + struct otri botlcasing, botrcasing, toprcasing; + struct otri gluetri; + struct osub botlsubseg, botrsubseg, toprsubseg; + vertex botvertex, rightvertex; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + /* Walk through the list of transformations (flips and a vertex insertion) */ + /* in the reverse of the order in which they were done, and undo them. */ + while (m->lastflip != (struct flipstacker *)NULL) { + /* Find a triangle involved in the last unreversed transformation. */ + decode(m->lastflip->flippedtri, fliptri); + + /* We are reversing one of three transformations: a trisection of one */ + /* triangle into three (by inserting a vertex in the triangle), a */ + /* bisection of two triangles into four (by inserting a vertex in an */ + /* edge), or an edge flip. */ + if (m->lastflip->prevflip == (struct flipstacker *)NULL) { + /* Restore a triangle that was split into three triangles, */ + /* so it is again one triangle. */ + dprev(fliptri, botleft); + lnextself(botleft); + onext(fliptri, botright); + lprevself(botright); + sym(botleft, botlcasing); + sym(botright, botrcasing); + dest(botleft, botvertex); + + setapex(fliptri, botvertex); + lnextself(fliptri); + bond(fliptri, botlcasing); + tspivot(botleft, botlsubseg); + tsbond(fliptri, botlsubseg); + lnextself(fliptri); + bond(fliptri, botrcasing); + tspivot(botright, botrsubseg); + tsbond(fliptri, botrsubseg); + + /* Delete the two spliced-out triangles. */ + triangledealloc(m, botleft.tri); + triangledealloc(m, botright.tri); + } else if (m->lastflip->prevflip == (struct flipstacker *)&insertvertex) { + /* Restore two triangles that were split into four triangles, */ + /* so they are again two triangles. */ + lprev(fliptri, gluetri); + sym(gluetri, botright); + lnextself(botright); + sym(botright, botrcasing); + dest(botright, rightvertex); + + setorg(fliptri, rightvertex); + bond(gluetri, botrcasing); + tspivot(botright, botrsubseg); + tsbond(gluetri, botrsubseg); + + /* Delete the spliced-out triangle. */ + triangledealloc(m, botright.tri); + + sym(fliptri, gluetri); + if (gluetri.tri != m->dummytri) { + lnextself(gluetri); + dnext(gluetri, topright); + sym(topright, toprcasing); + + setorg(gluetri, rightvertex); + bond(gluetri, toprcasing); + tspivot(topright, toprsubseg); + tsbond(gluetri, toprsubseg); + + /* Delete the spliced-out triangle. */ + triangledealloc(m, topright.tri); + } + + /* This is the end of the list, sneakily encoded. */ + m->lastflip->prevflip = (struct flipstacker *)NULL; + } else { + /* Undo an edge flip. */ + unflip(m, b, &fliptri); + } + + /* Go on and process the next transformation. */ + m->lastflip = m->lastflip->prevflip; + } +} + +#endif /* not CDT_ONLY */ + +/** **/ +/** **/ +/********* Mesh transformation routines end here *********/ + +/********* Divide-and-conquer Delaunay triangulation begins here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* The divide-and-conquer bounding box */ +/* */ +/* I originally implemented the divide-and-conquer and incremental Delaunay */ +/* triangulations using the edge-based data structure presented by Guibas */ +/* and Stolfi. Switching to a triangle-based data structure doubled the */ +/* speed. However, I had to think of a few extra tricks to maintain the */ +/* elegance of the original algorithms. */ +/* */ +/* The "bounding box" used by my variant of the divide-and-conquer */ +/* algorithm uses one triangle for each edge of the convex hull of the */ +/* triangulation. These bounding triangles all share a common apical */ +/* vertex, which is represented by NULL and which represents nothing. */ +/* The bounding triangles are linked in a circular fan about this NULL */ +/* vertex, and the edges on the convex hull of the triangulation appear */ +/* opposite the NULL vertex. You might find it easiest to imagine that */ +/* the NULL vertex is a point in 3D space behind the center of the */ +/* triangulation, and that the bounding triangles form a sort of cone. */ +/* */ +/* This bounding box makes it easy to represent degenerate cases. For */ +/* instance, the triangulation of two vertices is a single edge. This edge */ +/* is represented by two bounding box triangles, one on each "side" of the */ +/* edge. These triangles are also linked together in a fan about the NULL */ +/* vertex. */ +/* */ +/* The bounding box also makes it easy to traverse the convex hull, as the */ +/* divide-and-conquer algorithm needs to do. */ +/* */ +/*****************************************************************************/ + +/*****************************************************************************/ +/* */ +/* vertexsort() Sort an array of vertices by x-coordinate, using the */ +/* y-coordinate as a secondary key. */ +/* */ +/* Uses quicksort. Randomized O(n log n) time. No, I did not make any of */ +/* the usual quicksort mistakes. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void vertexsort(vertex *sortarray, int arraysize) +#else /* not ANSI_DECLARATORS */ +void vertexsort(sortarray, arraysize) vertex *sortarray; +int arraysize; +#endif /* not ANSI_DECLARATORS */ + +{ + int left, right; + int pivot; + REAL pivotx, pivoty; + vertex temp; + + if (arraysize == 2) { + /* Recursive base case. */ + if ((sortarray[0][0] > sortarray[1][0]) || + ((sortarray[0][0] == sortarray[1][0]) && + (sortarray[0][1] > sortarray[1][1]))) { + temp = sortarray[1]; + sortarray[1] = sortarray[0]; + sortarray[0] = temp; + } + return; + } + /* Choose a random pivot to split the array. */ + pivot = (int)randomnation((unsigned int)arraysize); + pivotx = sortarray[pivot][0]; + pivoty = sortarray[pivot][1]; + /* Split the array. */ + left = -1; + right = arraysize; + while (left < right) { + /* Search for a vertex whose x-coordinate is too large for the left. */ + do { + left++; + } while ((left <= right) && ((sortarray[left][0] < pivotx) || + ((sortarray[left][0] == pivotx) && + (sortarray[left][1] < pivoty)))); + /* Search for a vertex whose x-coordinate is too small for the right. */ + do { + right--; + } while ((left <= right) && ((sortarray[right][0] > pivotx) || + ((sortarray[right][0] == pivotx) && + (sortarray[right][1] > pivoty)))); + if (left < right) { + /* Swap the left and right vertices. */ + temp = sortarray[left]; + sortarray[left] = sortarray[right]; + sortarray[right] = temp; + } + } + if (left > 1) { + /* Recursively sort the left subset. */ + vertexsort(sortarray, left); + } + if (right < arraysize - 2) { + /* Recursively sort the right subset. */ + vertexsort(&sortarray[right + 1], arraysize - right - 1); + } +} + +/*****************************************************************************/ +/* */ +/* vertexmedian() An order statistic algorithm, almost. Shuffles an */ +/* array of vertices so that the first `median' vertices */ +/* occur lexicographically before the remaining vertices. */ +/* */ +/* Uses the x-coordinate as the primary key if axis == 0; the y-coordinate */ +/* if axis == 1. Very similar to the vertexsort() procedure, but runs in */ +/* randomized linear time. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void vertexmedian(vertex *sortarray, int arraysize, int median, int axis) +#else /* not ANSI_DECLARATORS */ +void vertexmedian(sortarray, arraysize, median, axis) vertex *sortarray; +int arraysize; +int median; +int axis; +#endif /* not ANSI_DECLARATORS */ + +{ + int left, right; + int pivot; + REAL pivot1, pivot2; + vertex temp; + + if (arraysize == 2) { + /* Recursive base case. */ + if ((sortarray[0][axis] > sortarray[1][axis]) || + ((sortarray[0][axis] == sortarray[1][axis]) && + (sortarray[0][1 - axis] > sortarray[1][1 - axis]))) { + temp = sortarray[1]; + sortarray[1] = sortarray[0]; + sortarray[0] = temp; + } + return; + } + /* Choose a random pivot to split the array. */ + pivot = (int)randomnation((unsigned int)arraysize); + pivot1 = sortarray[pivot][axis]; + pivot2 = sortarray[pivot][1 - axis]; + /* Split the array. */ + left = -1; + right = arraysize; + while (left < right) { + /* Search for a vertex whose x-coordinate is too large for the left. */ + do { + left++; + } while ((left <= right) && ((sortarray[left][axis] < pivot1) || + ((sortarray[left][axis] == pivot1) && + (sortarray[left][1 - axis] < pivot2)))); + /* Search for a vertex whose x-coordinate is too small for the right. */ + do { + right--; + } while ((left <= right) && ((sortarray[right][axis] > pivot1) || + ((sortarray[right][axis] == pivot1) && + (sortarray[right][1 - axis] > pivot2)))); + if (left < right) { + /* Swap the left and right vertices. */ + temp = sortarray[left]; + sortarray[left] = sortarray[right]; + sortarray[right] = temp; + } + } + /* Unlike in vertexsort(), at most one of the following */ + /* conditionals is true. */ + if (left > median) { + /* Recursively shuffle the left subset. */ + vertexmedian(sortarray, left, median, axis); + } + if (right < median - 1) { + /* Recursively shuffle the right subset. */ + vertexmedian(&sortarray[right + 1], arraysize - right - 1, + median - right - 1, axis); + } +} + +/*****************************************************************************/ +/* */ +/* alternateaxes() Sorts the vertices as appropriate for the divide-and- */ +/* conquer algorithm with alternating cuts. */ +/* */ +/* Partitions by x-coordinate if axis == 0; by y-coordinate if axis == 1. */ +/* For the base case, subsets containing only two or three vertices are */ +/* always sorted by x-coordinate. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void alternateaxes(vertex *sortarray, int arraysize, int axis) +#else /* not ANSI_DECLARATORS */ +void alternateaxes(sortarray, arraysize, axis) vertex *sortarray; +int arraysize; +int axis; +#endif /* not ANSI_DECLARATORS */ + +{ + int divider; + + divider = arraysize >> 1; + if (arraysize <= 3) { + /* Recursive base case: subsets of two or three vertices will be */ + /* handled specially, and should always be sorted by x-coordinate. */ + axis = 0; + } + /* Partition with a horizontal or vertical cut. */ + vertexmedian(sortarray, arraysize, divider, axis); + /* Recursively partition the subsets with a cross cut. */ + if (arraysize - divider >= 2) { + if (divider >= 2) { + alternateaxes(sortarray, divider, 1 - axis); + } + alternateaxes(&sortarray[divider], arraysize - divider, 1 - axis); + } +} + +/*****************************************************************************/ +/* */ +/* mergehulls() Merge two adjacent Delaunay triangulations into a */ +/* single Delaunay triangulation. */ +/* */ +/* This is similar to the algorithm given by Guibas and Stolfi, but uses */ +/* a triangle-based, rather than edge-based, data structure. */ +/* */ +/* The algorithm walks up the gap between the two triangulations, knitting */ +/* them together. As they are merged, some of their bounding triangles */ +/* are converted into real triangles of the triangulation. The procedure */ +/* pulls each hull's bounding triangles apart, then knits them together */ +/* like the teeth of two gears. The Delaunay property determines, at each */ +/* step, whether the next "tooth" is a bounding triangle of the left hull */ +/* or the right. When a bounding triangle becomes real, its apex is */ +/* changed from NULL to a real vertex. */ +/* */ +/* Only two new triangles need to be allocated. These become new bounding */ +/* triangles at the top and bottom of the seam. They are used to connect */ +/* the remaining bounding triangles (those that have not been converted */ +/* into real triangles) into a single fan. */ +/* */ +/* On entry, `farleft' and `innerleft' are bounding triangles of the left */ +/* triangulation. The origin of `farleft' is the leftmost vertex, and */ +/* the destination of `innerleft' is the rightmost vertex of the */ +/* triangulation. Similarly, `innerright' and `farright' are bounding */ +/* triangles of the right triangulation. The origin of `innerright' and */ +/* destination of `farright' are the leftmost and rightmost vertices. */ +/* */ +/* On completion, the origin of `farleft' is the leftmost vertex of the */ +/* merged triangulation, and the destination of `farright' is the rightmost */ +/* vertex. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void mergehulls(struct mesh *m, struct behavior *b, struct otri *farleft, + struct otri *innerleft, struct otri *innerright, + struct otri *farright, int axis) +#else /* not ANSI_DECLARATORS */ +void mergehulls(m, b, farleft, innerleft, innerright, farright, + axis) struct mesh *m; +struct behavior *b; +struct otri *farleft; +struct otri *innerleft; +struct otri *innerright; +struct otri *farright; +int axis; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri leftcand, rightcand; + struct otri baseedge; + struct otri nextedge; + struct otri sidecasing, topcasing, outercasing; + struct otri checkedge; + vertex innerleftdest; + vertex innerrightorg; + vertex innerleftapex, innerrightapex; + vertex farleftpt, farrightpt; + vertex farleftapex, farrightapex; + vertex lowerleft, lowerright; + vertex upperleft, upperright; + vertex nextapex; + vertex checkvertex; + int changemade; + int badedge; + int leftfinished, rightfinished; + triangle ptr; /* Temporary variable used by sym(). */ + + dest(*innerleft, innerleftdest); + apex(*innerleft, innerleftapex); + org(*innerright, innerrightorg); + apex(*innerright, innerrightapex); + /* Special treatment for horizontal cuts. */ + if (b->dwyer && (axis == 1)) { + org(*farleft, farleftpt); + apex(*farleft, farleftapex); + dest(*farright, farrightpt); + apex(*farright, farrightapex); + /* The pointers to the extremal vertices are shifted to point to the */ + /* topmost and bottommost vertex of each hull, rather than the */ + /* leftmost and rightmost vertices. */ + while (farleftapex[1] < farleftpt[1]) { + lnextself(*farleft); + symself(*farleft); + farleftpt = farleftapex; + apex(*farleft, farleftapex); + } + sym(*innerleft, checkedge); + apex(checkedge, checkvertex); + while (checkvertex[1] > innerleftdest[1]) { + lnext(checkedge, *innerleft); + innerleftapex = innerleftdest; + innerleftdest = checkvertex; + sym(*innerleft, checkedge); + apex(checkedge, checkvertex); + } + while (innerrightapex[1] < innerrightorg[1]) { + lnextself(*innerright); + symself(*innerright); + innerrightorg = innerrightapex; + apex(*innerright, innerrightapex); + } + sym(*farright, checkedge); + apex(checkedge, checkvertex); + while (checkvertex[1] > farrightpt[1]) { + lnext(checkedge, *farright); + farrightapex = farrightpt; + farrightpt = checkvertex; + sym(*farright, checkedge); + apex(checkedge, checkvertex); + } + } + /* Find a line tangent to and below both hulls. */ + do { + changemade = 0; + /* Make innerleftdest the "bottommost" vertex of the left hull. */ + if (counterclockwise(m, b, innerleftdest, innerleftapex, innerrightorg) > + 0.0) { + lprevself(*innerleft); + symself(*innerleft); + innerleftdest = innerleftapex; + apex(*innerleft, innerleftapex); + changemade = 1; + } + /* Make innerrightorg the "bottommost" vertex of the right hull. */ + if (counterclockwise(m, b, innerrightapex, innerrightorg, innerleftdest) > + 0.0) { + lnextself(*innerright); + symself(*innerright); + innerrightorg = innerrightapex; + apex(*innerright, innerrightapex); + changemade = 1; + } + } while (changemade); + /* Find the two candidates to be the next "gear tooth." */ + sym(*innerleft, leftcand); + sym(*innerright, rightcand); + /* Create the bottom new bounding triangle. */ + maketriangle(m, b, &baseedge); + /* Connect it to the bounding boxes of the left and right triangulations. */ + bond(baseedge, *innerleft); + lnextself(baseedge); + bond(baseedge, *innerright); + lnextself(baseedge); + setorg(baseedge, innerrightorg); + setdest(baseedge, innerleftdest); + /* Apex is intentionally left NULL. */ + if (b->verbose > 2) { + printf(" Creating base bounding "); + printtriangle(m, b, &baseedge); + } + /* Fix the extreme triangles if necessary. */ + org(*farleft, farleftpt); + if (innerleftdest == farleftpt) { + lnext(baseedge, *farleft); + } + dest(*farright, farrightpt); + if (innerrightorg == farrightpt) { + lprev(baseedge, *farright); + } + /* The vertices of the current knitting edge. */ + lowerleft = innerleftdest; + lowerright = innerrightorg; + /* The candidate vertices for knitting. */ + apex(leftcand, upperleft); + apex(rightcand, upperright); + /* Walk up the gap between the two triangulations, knitting them together. */ + while (1) { + /* Have we reached the top? (This isn't quite the right question, */ + /* because even though the left triangulation might seem finished now, */ + /* moving up on the right triangulation might reveal a new vertex of */ + /* the left triangulation. And vice-versa.) */ + leftfinished = + counterclockwise(m, b, upperleft, lowerleft, lowerright) <= 0.0; + rightfinished = + counterclockwise(m, b, upperright, lowerleft, lowerright) <= 0.0; + if (leftfinished && rightfinished) { + /* Create the top new bounding triangle. */ + maketriangle(m, b, &nextedge); + setorg(nextedge, lowerleft); + setdest(nextedge, lowerright); + /* Apex is intentionally left NULL. */ + /* Connect it to the bounding boxes of the two triangulations. */ + bond(nextedge, baseedge); + lnextself(nextedge); + bond(nextedge, rightcand); + lnextself(nextedge); + bond(nextedge, leftcand); + if (b->verbose > 2) { + printf(" Creating top bounding "); + printtriangle(m, b, &nextedge); + } + /* Special treatment for horizontal cuts. */ + if (b->dwyer && (axis == 1)) { + org(*farleft, farleftpt); + apex(*farleft, farleftapex); + dest(*farright, farrightpt); + apex(*farright, farrightapex); + sym(*farleft, checkedge); + apex(checkedge, checkvertex); + /* The pointers to the extremal vertices are restored to the */ + /* leftmost and rightmost vertices (rather than topmost and */ + /* bottommost). */ + while (checkvertex[0] < farleftpt[0]) { + lprev(checkedge, *farleft); + farleftapex = farleftpt; + farleftpt = checkvertex; + sym(*farleft, checkedge); + apex(checkedge, checkvertex); + } + while (farrightapex[0] > farrightpt[0]) { + lprevself(*farright); + symself(*farright); + farrightpt = farrightapex; + apex(*farright, farrightapex); + } + } + return; + } + /* Consider eliminating edges from the left triangulation. */ + if (!leftfinished) { + /* What vertex would be exposed if an edge were deleted? */ + lprev(leftcand, nextedge); + symself(nextedge); + apex(nextedge, nextapex); + /* If nextapex is NULL, then no vertex would be exposed; the */ + /* triangulation would have been eaten right through. */ + if (nextapex != (vertex)NULL) { + /* Check whether the edge is Delaunay. */ + badedge = + incircle(m, b, lowerleft, lowerright, upperleft, nextapex) > 0.0; + while (badedge) { + /* Eliminate the edge with an edge flip. As a result, the */ + /* left triangulation will have one more boundary triangle. */ + lnextself(nextedge); + sym(nextedge, topcasing); + lnextself(nextedge); + sym(nextedge, sidecasing); + bond(nextedge, topcasing); + bond(leftcand, sidecasing); + lnextself(leftcand); + sym(leftcand, outercasing); + lprevself(nextedge); + bond(nextedge, outercasing); + /* Correct the vertices to reflect the edge flip. */ + setorg(leftcand, lowerleft); + setdest(leftcand, NULL); + setapex(leftcand, nextapex); + setorg(nextedge, NULL); + setdest(nextedge, upperleft); + setapex(nextedge, nextapex); + /* Consider the newly exposed vertex. */ + upperleft = nextapex; + /* What vertex would be exposed if another edge were deleted? */ + otricopy(sidecasing, nextedge); + apex(nextedge, nextapex); + if (nextapex != (vertex)NULL) { + /* Check whether the edge is Delaunay. */ + badedge = incircle(m, b, lowerleft, lowerright, upperleft, + nextapex) > 0.0; + } else { + /* Avoid eating right through the triangulation. */ + badedge = 0; + } + } + } + } + /* Consider eliminating edges from the right triangulation. */ + if (!rightfinished) { + /* What vertex would be exposed if an edge were deleted? */ + lnext(rightcand, nextedge); + symself(nextedge); + apex(nextedge, nextapex); + /* If nextapex is NULL, then no vertex would be exposed; the */ + /* triangulation would have been eaten right through. */ + if (nextapex != (vertex)NULL) { + /* Check whether the edge is Delaunay. */ + badedge = + incircle(m, b, lowerleft, lowerright, upperright, nextapex) > 0.0; + while (badedge) { + /* Eliminate the edge with an edge flip. As a result, the */ + /* right triangulation will have one more boundary triangle. */ + lprevself(nextedge); + sym(nextedge, topcasing); + lprevself(nextedge); + sym(nextedge, sidecasing); + bond(nextedge, topcasing); + bond(rightcand, sidecasing); + lprevself(rightcand); + sym(rightcand, outercasing); + lnextself(nextedge); + bond(nextedge, outercasing); + /* Correct the vertices to reflect the edge flip. */ + setorg(rightcand, NULL); + setdest(rightcand, lowerright); + setapex(rightcand, nextapex); + setorg(nextedge, upperright); + setdest(nextedge, NULL); + setapex(nextedge, nextapex); + /* Consider the newly exposed vertex. */ + upperright = nextapex; + /* What vertex would be exposed if another edge were deleted? */ + otricopy(sidecasing, nextedge); + apex(nextedge, nextapex); + if (nextapex != (vertex)NULL) { + /* Check whether the edge is Delaunay. */ + badedge = incircle(m, b, lowerleft, lowerright, upperright, + nextapex) > 0.0; + } else { + /* Avoid eating right through the triangulation. */ + badedge = 0; + } + } + } + } + if (leftfinished || + (!rightfinished && (incircle(m, b, upperleft, lowerleft, lowerright, + upperright) > 0.0))) { + /* Knit the triangulations, adding an edge from `lowerleft' */ + /* to `upperright'. */ + bond(baseedge, rightcand); + lprev(rightcand, baseedge); + setdest(baseedge, lowerleft); + lowerright = upperright; + sym(baseedge, rightcand); + apex(rightcand, upperright); + } else { + /* Knit the triangulations, adding an edge from `upperleft' */ + /* to `lowerright'. */ + bond(baseedge, leftcand); + lnext(leftcand, baseedge); + setorg(baseedge, lowerright); + lowerleft = upperleft; + sym(baseedge, leftcand); + apex(leftcand, upperleft); + } + if (b->verbose > 2) { + printf(" Connecting "); + printtriangle(m, b, &baseedge); + } + } +} + +/*****************************************************************************/ +/* */ +/* divconqrecurse() Recursively form a Delaunay triangulation by the */ +/* divide-and-conquer method. */ +/* */ +/* Recursively breaks down the problem into smaller pieces, which are */ +/* knitted together by mergehulls(). The base cases (problems of two or */ +/* three vertices) are handled specially here. */ +/* */ +/* On completion, `farleft' and `farright' are bounding triangles such that */ +/* the origin of `farleft' is the leftmost vertex (breaking ties by */ +/* choosing the highest leftmost vertex), and the destination of */ +/* `farright' is the rightmost vertex (breaking ties by choosing the */ +/* lowest rightmost vertex). */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void divconqrecurse(struct mesh *m, struct behavior *b, vertex *sortarray, + int vertices, int axis, struct otri *farleft, + struct otri *farright) +#else /* not ANSI_DECLARATORS */ +void divconqrecurse(m, b, sortarray, vertices, axis, farleft, + farright) struct mesh *m; +struct behavior *b; +vertex *sortarray; +int vertices; +int axis; +struct otri *farleft; +struct otri *farright; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri midtri, tri1, tri2, tri3; + struct otri innerleft, innerright; + REAL area; + int divider; + + if (b->verbose > 2) { + printf(" Triangulating %d vertices.\n", vertices); + } + if (vertices == 2) { + /* The triangulation of two vertices is an edge. An edge is */ + /* represented by two bounding triangles. */ + maketriangle(m, b, farleft); + setorg(*farleft, sortarray[0]); + setdest(*farleft, sortarray[1]); + /* The apex is intentionally left NULL. */ + maketriangle(m, b, farright); + setorg(*farright, sortarray[1]); + setdest(*farright, sortarray[0]); + /* The apex is intentionally left NULL. */ + bond(*farleft, *farright); + lprevself(*farleft); + lnextself(*farright); + bond(*farleft, *farright); + lprevself(*farleft); + lnextself(*farright); + bond(*farleft, *farright); + if (b->verbose > 2) { + printf(" Creating "); + printtriangle(m, b, farleft); + printf(" Creating "); + printtriangle(m, b, farright); + } + /* Ensure that the origin of `farleft' is sortarray[0]. */ + lprev(*farright, *farleft); + return; + } else if (vertices == 3) { + /* The triangulation of three vertices is either a triangle (with */ + /* three bounding triangles) or two edges (with four bounding */ + /* triangles). In either case, four triangles are created. */ + maketriangle(m, b, &midtri); + maketriangle(m, b, &tri1); + maketriangle(m, b, &tri2); + maketriangle(m, b, &tri3); + area = counterclockwise(m, b, sortarray[0], sortarray[1], sortarray[2]); + if (area == 0.0) { + /* Three collinear vertices; the triangulation is two edges. */ + setorg(midtri, sortarray[0]); + setdest(midtri, sortarray[1]); + setorg(tri1, sortarray[1]); + setdest(tri1, sortarray[0]); + setorg(tri2, sortarray[2]); + setdest(tri2, sortarray[1]); + setorg(tri3, sortarray[1]); + setdest(tri3, sortarray[2]); + /* All apices are intentionally left NULL. */ + bond(midtri, tri1); + bond(tri2, tri3); + lnextself(midtri); + lprevself(tri1); + lnextself(tri2); + lprevself(tri3); + bond(midtri, tri3); + bond(tri1, tri2); + lnextself(midtri); + lprevself(tri1); + lnextself(tri2); + lprevself(tri3); + bond(midtri, tri1); + bond(tri2, tri3); + /* Ensure that the origin of `farleft' is sortarray[0]. */ + otricopy(tri1, *farleft); + /* Ensure that the destination of `farright' is sortarray[2]. */ + otricopy(tri2, *farright); + } else { + /* The three vertices are not collinear; the triangulation is one */ + /* triangle, namely `midtri'. */ + setorg(midtri, sortarray[0]); + setdest(tri1, sortarray[0]); + setorg(tri3, sortarray[0]); + /* Apices of tri1, tri2, and tri3 are left NULL. */ + if (area > 0.0) { + /* The vertices are in counterclockwise order. */ + setdest(midtri, sortarray[1]); + setorg(tri1, sortarray[1]); + setdest(tri2, sortarray[1]); + setapex(midtri, sortarray[2]); + setorg(tri2, sortarray[2]); + setdest(tri3, sortarray[2]); + } else { + /* The vertices are in clockwise order. */ + setdest(midtri, sortarray[2]); + setorg(tri1, sortarray[2]); + setdest(tri2, sortarray[2]); + setapex(midtri, sortarray[1]); + setorg(tri2, sortarray[1]); + setdest(tri3, sortarray[1]); + } + /* The topology does not depend on how the vertices are ordered. */ + bond(midtri, tri1); + lnextself(midtri); + bond(midtri, tri2); + lnextself(midtri); + bond(midtri, tri3); + lprevself(tri1); + lnextself(tri2); + bond(tri1, tri2); + lprevself(tri1); + lprevself(tri3); + bond(tri1, tri3); + lnextself(tri2); + lprevself(tri3); + bond(tri2, tri3); + /* Ensure that the origin of `farleft' is sortarray[0]. */ + otricopy(tri1, *farleft); + /* Ensure that the destination of `farright' is sortarray[2]. */ + if (area > 0.0) { + otricopy(tri2, *farright); + } else { + lnext(*farleft, *farright); + } + } + if (b->verbose > 2) { + printf(" Creating "); + printtriangle(m, b, &midtri); + printf(" Creating "); + printtriangle(m, b, &tri1); + printf(" Creating "); + printtriangle(m, b, &tri2); + printf(" Creating "); + printtriangle(m, b, &tri3); + } + return; + } else { + /* Split the vertices in half. */ + divider = vertices >> 1; + /* Recursively triangulate each half. */ + divconqrecurse(m, b, sortarray, divider, 1 - axis, farleft, &innerleft); + divconqrecurse(m, b, &sortarray[divider], vertices - divider, 1 - axis, + &innerright, farright); + if (b->verbose > 1) { + printf(" Joining triangulations with %d and %d vertices.\n", divider, + vertices - divider); + } + /* Merge the two triangulations into one. */ + mergehulls(m, b, farleft, &innerleft, &innerright, farright, axis); + } +} + +#ifdef ANSI_DECLARATORS +long removeghosts(struct mesh *m, struct behavior *b, struct otri *startghost) +#else /* not ANSI_DECLARATORS */ +long removeghosts(m, b, startghost) +struct mesh *m; +struct behavior *b; +struct otri *startghost; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri searchedge; + struct otri dissolveedge; + struct otri deadtriangle; + vertex markorg; + long hullsize; + triangle ptr; /* Temporary variable used by sym(). */ + + if (b->verbose) { + printf(" Removing ghost triangles.\n"); + } + /* Find an edge on the convex hull to start point location from. */ + lprev(*startghost, searchedge); + symself(searchedge); + m->dummytri[0] = encode(searchedge); + /* Remove the bounding box and count the convex hull edges. */ + otricopy(*startghost, dissolveedge); + hullsize = 0; + do { + hullsize++; + lnext(dissolveedge, deadtriangle); + lprevself(dissolveedge); + symself(dissolveedge); + /* If no PSLG is involved, set the boundary markers of all the vertices */ + /* on the convex hull. If a PSLG is used, this step is done later. */ + if (!b->poly) { + /* Watch out for the case where all the input vertices are collinear. */ + if (dissolveedge.tri != m->dummytri) { + org(dissolveedge, markorg); + if (vertexmark(markorg) == 0) { + setvertexmark(markorg, 1); + } + } + } + /* Remove a bounding triangle from a convex hull triangle. */ + dissolve(dissolveedge); + /* Find the next bounding triangle. */ + sym(deadtriangle, dissolveedge); + /* Delete the bounding triangle. */ + triangledealloc(m, deadtriangle.tri); + } while (!otriequal(dissolveedge, *startghost)); + return hullsize; +} + +/*****************************************************************************/ +/* */ +/* divconqdelaunay() Form a Delaunay triangulation by the divide-and- */ +/* conquer method. */ +/* */ +/* Sorts the vertices, calls a recursive procedure to triangulate them, and */ +/* removes the bounding box, setting boundary markers as appropriate. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +long divconqdelaunay(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +long divconqdelaunay(m, b) +struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + vertex *sortarray; + struct otri hullleft, hullright; + int divider; + int i, j; + + if (b->verbose) { + printf(" Sorting vertices.\n"); + } + + /* Allocate an array of pointers to vertices for sorting. */ + sortarray = (vertex *)trimalloc(m->invertices * (int)sizeof(vertex)); + traversalinit(&m->vertices); + for (i = 0; i < m->invertices; i++) { + sortarray[i] = vertextraverse(m); + } + /* Sort the vertices. */ + vertexsort(sortarray, m->invertices); + /* Discard duplicate vertices, which can really mess up the algorithm. */ + i = 0; + for (j = 1; j < m->invertices; j++) { + if ((sortarray[i][0] == sortarray[j][0]) && + (sortarray[i][1] == sortarray[j][1])) { + if (!b->quiet) { + printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " + "was ignored.\n", + sortarray[j][0], sortarray[j][1]); + } + setvertextype(sortarray[j], UNDEADVERTEX); + m->undeads++; + } else { + i++; + sortarray[i] = sortarray[j]; + } + } + i++; + if (b->dwyer) { + /* Re-sort the array of vertices to accommodate alternating cuts. */ + divider = i >> 1; + if (i - divider >= 2) { + if (divider >= 2) { + alternateaxes(sortarray, divider, 1); + } + alternateaxes(&sortarray[divider], i - divider, 1); + } + } + + if (b->verbose) { + printf(" Forming triangulation.\n"); + } + + /* Form the Delaunay triangulation. */ + divconqrecurse(m, b, sortarray, i, 0, &hullleft, &hullright); + trifree((VOID *)sortarray); + + return removeghosts(m, b, &hullleft); +} + +/** **/ +/** **/ +/********* Divide-and-conquer Delaunay triangulation ends here *********/ + +/********* Incremental Delaunay triangulation begins here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* boundingbox() Form an "infinite" bounding triangle to insert vertices */ +/* into. */ +/* */ +/* The vertices at "infinity" are assigned finite coordinates, which are */ +/* used by the point location routines, but (mostly) ignored by the */ +/* Delaunay edge flip routines. */ +/* */ +/*****************************************************************************/ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void boundingbox(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void boundingbox(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri inftri; /* Handle for the triangular bounding box. */ + REAL width; + + if (b->verbose) { + printf(" Creating triangular bounding box.\n"); + } + /* Find the width (or height, whichever is larger) of the triangulation. */ + width = m->xmax - m->xmin; + if (m->ymax - m->ymin > width) { + width = m->ymax - m->ymin; + } + if (width == 0.0) { + width = 1.0; + } + /* Create the vertices of the bounding box. */ + m->infvertex1 = (vertex)trimalloc(m->vertices.itembytes); + m->infvertex2 = (vertex)trimalloc(m->vertices.itembytes); + m->infvertex3 = (vertex)trimalloc(m->vertices.itembytes); + m->infvertex1[0] = m->xmin - 50.0 * width; + m->infvertex1[1] = m->ymin - 40.0 * width; + m->infvertex2[0] = m->xmax + 50.0 * width; + m->infvertex2[1] = m->ymin - 40.0 * width; + m->infvertex3[0] = 0.5 * (m->xmin + m->xmax); + m->infvertex3[1] = m->ymax + 60.0 * width; + + /* Create the bounding box. */ + maketriangle(m, b, &inftri); + setorg(inftri, m->infvertex1); + setdest(inftri, m->infvertex2); + setapex(inftri, m->infvertex3); + /* Link dummytri to the bounding box so we can always find an */ + /* edge to begin searching (point location) from. */ + m->dummytri[0] = (triangle)inftri.tri; + if (b->verbose > 2) { + printf(" Creating "); + printtriangle(m, b, &inftri); + } +} + +#endif /* not REDUCED */ + +/*****************************************************************************/ +/* */ +/* removebox() Remove the "infinite" bounding triangle, setting boundary */ +/* markers as appropriate. */ +/* */ +/* The triangular bounding box has three boundary triangles (one for each */ +/* side of the bounding box), and a bunch of triangles fanning out from */ +/* the three bounding box vertices (one triangle for each edge of the */ +/* convex hull of the inner mesh). This routine removes these triangles. */ +/* */ +/* Returns the number of edges on the convex hull of the triangulation. */ +/* */ +/*****************************************************************************/ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +long removebox(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +long removebox(m, b) +struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri deadtriangle; + struct otri searchedge; + struct otri checkedge; + struct otri nextedge, finaledge, dissolveedge; + vertex markorg; + long hullsize; + triangle ptr; /* Temporary variable used by sym(). */ + + if (b->verbose) { + printf(" Removing triangular bounding box.\n"); + } + /* Find a boundary triangle. */ + nextedge.tri = m->dummytri; + nextedge.orient = 0; + symself(nextedge); + /* Mark a place to stop. */ + lprev(nextedge, finaledge); + lnextself(nextedge); + symself(nextedge); + /* Find a triangle (on the boundary of the vertex set) that isn't */ + /* a bounding box triangle. */ + lprev(nextedge, searchedge); + symself(searchedge); + /* Check whether nextedge is another boundary triangle */ + /* adjacent to the first one. */ + lnext(nextedge, checkedge); + symself(checkedge); + if (checkedge.tri == m->dummytri) { + /* Go on to the next triangle. There are only three boundary */ + /* triangles, and this next triangle cannot be the third one, */ + /* so it's safe to stop here. */ + lprevself(searchedge); + symself(searchedge); + } + /* Find a new boundary edge to search from, as the current search */ + /* edge lies on a bounding box triangle and will be deleted. */ + m->dummytri[0] = encode(searchedge); + hullsize = -2l; + while (!otriequal(nextedge, finaledge)) { + hullsize++; + lprev(nextedge, dissolveedge); + symself(dissolveedge); + /* If not using a PSLG, the vertices should be marked now. */ + /* (If using a PSLG, markhull() will do the job.) */ + if (!b->poly) { + /* Be careful! One must check for the case where all the input */ + /* vertices are collinear, and thus all the triangles are part of */ + /* the bounding box. Otherwise, the setvertexmark() call below */ + /* will cause a bad pointer reference. */ + if (dissolveedge.tri != m->dummytri) { + org(dissolveedge, markorg); + if (vertexmark(markorg) == 0) { + setvertexmark(markorg, 1); + } + } + } + /* Disconnect the bounding box triangle from the mesh triangle. */ + dissolve(dissolveedge); + lnext(nextedge, deadtriangle); + sym(deadtriangle, nextedge); + /* Get rid of the bounding box triangle. */ + triangledealloc(m, deadtriangle.tri); + /* Do we need to turn the corner? */ + if (nextedge.tri == m->dummytri) { + /* Turn the corner. */ + otricopy(dissolveedge, nextedge); + } + } + triangledealloc(m, finaledge.tri); + + trifree((VOID *)m->infvertex1); /* Deallocate the bounding box vertices. */ + trifree((VOID *)m->infvertex2); + trifree((VOID *)m->infvertex3); + + return hullsize; +} + +#endif /* not REDUCED */ + +/*****************************************************************************/ +/* */ +/* incrementaldelaunay() Form a Delaunay triangulation by incrementally */ +/* inserting vertices. */ +/* */ +/* Returns the number of edges on the convex hull of the triangulation. */ +/* */ +/*****************************************************************************/ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +long incrementaldelaunay(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +long incrementaldelaunay(m, b) +struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri starttri; + vertex vertexloop; + + /* Create a triangular bounding box. */ + boundingbox(m, b); + if (b->verbose) { + printf(" Incrementally inserting vertices.\n"); + } + traversalinit(&m->vertices); + vertexloop = vertextraverse(m); + while (vertexloop != (vertex)NULL) { + starttri.tri = m->dummytri; + if (insertvertex(m, b, vertexloop, &starttri, (struct osub *)NULL, 0, 0) == + DUPLICATEVERTEX) { + if (!b->quiet) { + printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " + "was ignored.\n", + vertexloop[0], vertexloop[1]); + } + setvertextype(vertexloop, UNDEADVERTEX); + m->undeads++; + } + vertexloop = vertextraverse(m); + } + /* Remove the bounding box. */ + return removebox(m, b); +} + +#endif /* not REDUCED */ + +/** **/ +/** **/ +/********* Incremental Delaunay triangulation ends here *********/ + +/********* Sweepline Delaunay triangulation begins here *********/ +/** **/ +/** **/ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void eventheapinsert(struct event **heap, int heapsize, struct event *newevent) +#else /* not ANSI_DECLARATORS */ +void eventheapinsert(heap, heapsize, newevent) struct event **heap; +int heapsize; +struct event *newevent; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL eventx, eventy; + int eventnum; + int parent; + int notdone; + + eventx = newevent->xkey; + eventy = newevent->ykey; + eventnum = heapsize; + notdone = eventnum > 0; + while (notdone) { + parent = (eventnum - 1) >> 1; + if ((heap[parent]->ykey < eventy) || + ((heap[parent]->ykey == eventy) && (heap[parent]->xkey <= eventx))) { + notdone = 0; + } else { + heap[eventnum] = heap[parent]; + heap[eventnum]->heapposition = eventnum; + + eventnum = parent; + notdone = eventnum > 0; + } + } + heap[eventnum] = newevent; + newevent->heapposition = eventnum; +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void eventheapify(struct event **heap, int heapsize, int eventnum) +#else /* not ANSI_DECLARATORS */ +void eventheapify(heap, heapsize, eventnum) struct event **heap; +int heapsize; +int eventnum; +#endif /* not ANSI_DECLARATORS */ + +{ + struct event *thisevent; + REAL eventx, eventy; + int leftchild, rightchild; + int smallest; + int notdone; + + thisevent = heap[eventnum]; + eventx = thisevent->xkey; + eventy = thisevent->ykey; + leftchild = 2 * eventnum + 1; + notdone = leftchild < heapsize; + while (notdone) { + if ((heap[leftchild]->ykey < eventy) || + ((heap[leftchild]->ykey == eventy) && + (heap[leftchild]->xkey < eventx))) { + smallest = leftchild; + } else { + smallest = eventnum; + } + rightchild = leftchild + 1; + if (rightchild < heapsize) { + if ((heap[rightchild]->ykey < heap[smallest]->ykey) || + ((heap[rightchild]->ykey == heap[smallest]->ykey) && + (heap[rightchild]->xkey < heap[smallest]->xkey))) { + smallest = rightchild; + } + } + if (smallest == eventnum) { + notdone = 0; + } else { + heap[eventnum] = heap[smallest]; + heap[eventnum]->heapposition = eventnum; + heap[smallest] = thisevent; + thisevent->heapposition = smallest; + + eventnum = smallest; + leftchild = 2 * eventnum + 1; + notdone = leftchild < heapsize; + } + } +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void eventheapdelete(struct event **heap, int heapsize, int eventnum) +#else /* not ANSI_DECLARATORS */ +void eventheapdelete(heap, heapsize, eventnum) struct event **heap; +int heapsize; +int eventnum; +#endif /* not ANSI_DECLARATORS */ + +{ + struct event *moveevent; + REAL eventx, eventy; + int parent; + int notdone; + + moveevent = heap[heapsize - 1]; + if (eventnum > 0) { + eventx = moveevent->xkey; + eventy = moveevent->ykey; + do { + parent = (eventnum - 1) >> 1; + if ((heap[parent]->ykey < eventy) || + ((heap[parent]->ykey == eventy) && (heap[parent]->xkey <= eventx))) { + notdone = 0; + } else { + heap[eventnum] = heap[parent]; + heap[eventnum]->heapposition = eventnum; + + eventnum = parent; + notdone = eventnum > 0; + } + } while (notdone); + } + heap[eventnum] = moveevent; + moveevent->heapposition = eventnum; + eventheapify(heap, heapsize - 1, eventnum); +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void createeventheap(struct mesh *m, struct event ***eventheap, + struct event **events, struct event **freeevents) +#else /* not ANSI_DECLARATORS */ +void createeventheap(m, eventheap, events, freeevents) struct mesh *m; +struct event ***eventheap; +struct event **events; +struct event **freeevents; +#endif /* not ANSI_DECLARATORS */ + +{ + vertex thisvertex; + int maxevents; + int i; + + maxevents = (3 * m->invertices) / 2; + *eventheap = + (struct event **)trimalloc(maxevents * (int)sizeof(struct event *)); + *events = (struct event *)trimalloc(maxevents * (int)sizeof(struct event)); + traversalinit(&m->vertices); + for (i = 0; i < m->invertices; i++) { + thisvertex = vertextraverse(m); + (*events)[i].eventptr = (VOID *)thisvertex; + (*events)[i].xkey = thisvertex[0]; + (*events)[i].ykey = thisvertex[1]; + eventheapinsert(*eventheap, i, *events + i); + } + *freeevents = (struct event *)NULL; + for (i = maxevents - 1; i >= m->invertices; i--) { + (*events)[i].eventptr = (VOID *)*freeevents; + *freeevents = *events + i; + } +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +int rightofhyperbola(struct mesh *m, struct otri *fronttri, vertex newsite) +#else /* not ANSI_DECLARATORS */ +int rightofhyperbola(m, fronttri, newsite) +struct mesh *m; +struct otri *fronttri; +vertex newsite; +#endif /* not ANSI_DECLARATORS */ + +{ + vertex leftvertex, rightvertex; + REAL dxa, dya, dxb, dyb; + + m->hyperbolacount++; + + dest(*fronttri, leftvertex); + apex(*fronttri, rightvertex); + if ((leftvertex[1] < rightvertex[1]) || + ((leftvertex[1] == rightvertex[1]) && (leftvertex[0] < rightvertex[0]))) { + if (newsite[0] >= rightvertex[0]) { + return 1; + } + } else { + if (newsite[0] <= leftvertex[0]) { + return 0; + } + } + dxa = leftvertex[0] - newsite[0]; + dya = leftvertex[1] - newsite[1]; + dxb = rightvertex[0] - newsite[0]; + dyb = rightvertex[1] - newsite[1]; + return dya * (dxb * dxb + dyb * dyb) > dyb * (dxa * dxa + dya * dya); +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +REAL circletop(struct mesh *m, vertex pa, vertex pb, vertex pc, REAL ccwabc) +#else /* not ANSI_DECLARATORS */ +REAL circletop(m, pa, pb, pc, ccwabc) +struct mesh *m; +vertex pa; +vertex pb; +vertex pc; +REAL ccwabc; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL xac, yac, xbc, ybc, xab, yab; + REAL aclen2, bclen2, ablen2; + + m->circletopcount++; + + xac = pa[0] - pc[0]; + yac = pa[1] - pc[1]; + xbc = pb[0] - pc[0]; + ybc = pb[1] - pc[1]; + xab = pa[0] - pb[0]; + yab = pa[1] - pb[1]; + aclen2 = xac * xac + yac * yac; + bclen2 = xbc * xbc + ybc * ybc; + ablen2 = xab * xab + yab * yab; + return pc[1] + + (xac * bclen2 - xbc * aclen2 + sqrt(aclen2 * bclen2 * ablen2)) / + (2.0 * ccwabc); +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +void check4deadevent(struct otri *checktri, struct event **freeevents, + struct event **eventheap, int *heapsize) +#else /* not ANSI_DECLARATORS */ +void check4deadevent(checktri, freeevents, eventheap, + heapsize) struct otri *checktri; +struct event **freeevents; +struct event **eventheap; +int *heapsize; +#endif /* not ANSI_DECLARATORS */ + +{ + struct event *deadevent; + vertex eventvertex; + int eventnum; + + org(*checktri, eventvertex); + if (eventvertex != (vertex)NULL) { + deadevent = (struct event *)eventvertex; + eventnum = deadevent->heapposition; + deadevent->eventptr = (VOID *)*freeevents; + *freeevents = deadevent; + eventheapdelete(eventheap, *heapsize, eventnum); + (*heapsize)--; + setorg(*checktri, NULL); + } +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +struct splaynode *splay(struct mesh *m, struct splaynode *splaytree, + vertex searchpoint, struct otri *searchtri) +#else /* not ANSI_DECLARATORS */ +struct splaynode *splay(m, splaytree, searchpoint, searchtri) +struct mesh *m; +struct splaynode *splaytree; +vertex searchpoint; +struct otri *searchtri; +#endif /* not ANSI_DECLARATORS */ + +{ + struct splaynode *child, *grandchild; + struct splaynode *lefttree, *righttree; + struct splaynode *leftright; + vertex checkvertex; + int rightofroot, rightofchild; + + if (splaytree == (struct splaynode *)NULL) { + return (struct splaynode *)NULL; + } + dest(splaytree->keyedge, checkvertex); + if (checkvertex == splaytree->keydest) { + rightofroot = rightofhyperbola(m, &splaytree->keyedge, searchpoint); + if (rightofroot) { + otricopy(splaytree->keyedge, *searchtri); + child = splaytree->rchild; + } else { + child = splaytree->lchild; + } + if (child == (struct splaynode *)NULL) { + return splaytree; + } + dest(child->keyedge, checkvertex); + if (checkvertex != child->keydest) { + child = splay(m, child, searchpoint, searchtri); + if (child == (struct splaynode *)NULL) { + if (rightofroot) { + splaytree->rchild = (struct splaynode *)NULL; + } else { + splaytree->lchild = (struct splaynode *)NULL; + } + return splaytree; + } + } + rightofchild = rightofhyperbola(m, &child->keyedge, searchpoint); + if (rightofchild) { + otricopy(child->keyedge, *searchtri); + grandchild = splay(m, child->rchild, searchpoint, searchtri); + child->rchild = grandchild; + } else { + grandchild = splay(m, child->lchild, searchpoint, searchtri); + child->lchild = grandchild; + } + if (grandchild == (struct splaynode *)NULL) { + if (rightofroot) { + splaytree->rchild = child->lchild; + child->lchild = splaytree; + } else { + splaytree->lchild = child->rchild; + child->rchild = splaytree; + } + return child; + } + if (rightofchild) { + if (rightofroot) { + splaytree->rchild = child->lchild; + child->lchild = splaytree; + } else { + splaytree->lchild = grandchild->rchild; + grandchild->rchild = splaytree; + } + child->rchild = grandchild->lchild; + grandchild->lchild = child; + } else { + if (rightofroot) { + splaytree->rchild = grandchild->lchild; + grandchild->lchild = splaytree; + } else { + splaytree->lchild = child->rchild; + child->rchild = splaytree; + } + child->lchild = grandchild->rchild; + grandchild->rchild = child; + } + return grandchild; + } else { + lefttree = splay(m, splaytree->lchild, searchpoint, searchtri); + righttree = splay(m, splaytree->rchild, searchpoint, searchtri); + + pooldealloc(&m->splaynodes, (VOID *)splaytree); + if (lefttree == (struct splaynode *)NULL) { + return righttree; + } else if (righttree == (struct splaynode *)NULL) { + return lefttree; + } else if (lefttree->rchild == (struct splaynode *)NULL) { + lefttree->rchild = righttree->lchild; + righttree->lchild = lefttree; + return righttree; + } else if (righttree->lchild == (struct splaynode *)NULL) { + righttree->lchild = lefttree->rchild; + lefttree->rchild = righttree; + return lefttree; + } else { + /* printf("Holy Toledo!!!\n"); */ + leftright = lefttree->rchild; + while (leftright->rchild != (struct splaynode *)NULL) { + leftright = leftright->rchild; + } + leftright->rchild = righttree; + return lefttree; + } + } +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +struct splaynode *splayinsert(struct mesh *m, struct splaynode *splayroot, + struct otri *newkey, vertex searchpoint) +#else /* not ANSI_DECLARATORS */ +struct splaynode *splayinsert(m, splayroot, newkey, searchpoint) +struct mesh *m; +struct splaynode *splayroot; +struct otri *newkey; +vertex searchpoint; +#endif /* not ANSI_DECLARATORS */ + +{ + struct splaynode *newsplaynode; + + newsplaynode = (struct splaynode *)poolalloc(&m->splaynodes); + otricopy(*newkey, newsplaynode->keyedge); + dest(*newkey, newsplaynode->keydest); + if (splayroot == (struct splaynode *)NULL) { + newsplaynode->lchild = (struct splaynode *)NULL; + newsplaynode->rchild = (struct splaynode *)NULL; + } else if (rightofhyperbola(m, &splayroot->keyedge, searchpoint)) { + newsplaynode->lchild = splayroot; + newsplaynode->rchild = splayroot->rchild; + splayroot->rchild = (struct splaynode *)NULL; + } else { + newsplaynode->lchild = splayroot->lchild; + newsplaynode->rchild = splayroot; + splayroot->lchild = (struct splaynode *)NULL; + } + return newsplaynode; +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +struct splaynode * +circletopinsert(struct mesh *m, struct behavior *b, struct splaynode *splayroot, + struct otri *newkey, vertex pa, vertex pb, vertex pc, REAL topy) +#else /* not ANSI_DECLARATORS */ +struct splaynode *circletopinsert(m, b, splayroot, newkey, pa, pb, pc, topy) +struct mesh *m; +struct behavior *b; +struct splaynode *splayroot; +struct otri *newkey; +vertex pa; +vertex pb; +vertex pc; +REAL topy; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL ccwabc; + REAL xac, yac, xbc, ybc; + REAL aclen2, bclen2; + REAL searchpoint[2]; + struct otri dummytri; + + ccwabc = counterclockwise(m, b, pa, pb, pc); + xac = pa[0] - pc[0]; + yac = pa[1] - pc[1]; + xbc = pb[0] - pc[0]; + ybc = pb[1] - pc[1]; + aclen2 = xac * xac + yac * yac; + bclen2 = xbc * xbc + ybc * ybc; + searchpoint[0] = pc[0] - (yac * bclen2 - ybc * aclen2) / (2.0 * ccwabc); + searchpoint[1] = topy; + return splayinsert(m, splay(m, splayroot, (vertex)searchpoint, &dummytri), + newkey, (vertex)searchpoint); +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +struct splaynode *frontlocate(struct mesh *m, struct splaynode *splayroot, + struct otri *bottommost, vertex searchvertex, + struct otri *searchtri, int *farright) +#else /* not ANSI_DECLARATORS */ +struct splaynode *frontlocate(m, splayroot, bottommost, searchvertex, searchtri, + farright) +struct mesh *m; +struct splaynode *splayroot; +struct otri *bottommost; +vertex searchvertex; +struct otri *searchtri; +int *farright; +#endif /* not ANSI_DECLARATORS */ + +{ + int farrightflag; + triangle ptr; /* Temporary variable used by onext(). */ + + otricopy(*bottommost, *searchtri); + splayroot = splay(m, splayroot, searchvertex, searchtri); + + farrightflag = 0; + while (!farrightflag && rightofhyperbola(m, searchtri, searchvertex)) { + onextself(*searchtri); + farrightflag = otriequal(*searchtri, *bottommost); + } + *farright = farrightflag; + return splayroot; +} + +#endif /* not REDUCED */ + +#ifndef REDUCED + +#ifdef ANSI_DECLARATORS +long sweeplinedelaunay(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +long sweeplinedelaunay(m, b) +struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct event **eventheap; + struct event *events; + struct event *freeevents; + struct event *nextevent; + struct event *newevent; + struct splaynode *splayroot; + struct otri bottommost; + struct otri searchtri; + struct otri fliptri; + struct otri lefttri, righttri, farlefttri, farrighttri; + struct otri inserttri; + vertex firstvertex, secondvertex; + vertex nextvertex, lastvertex; + vertex connectvertex; + vertex leftvertex, midvertex, rightvertex; + REAL lefttest, righttest; + int heapsize; + int check4events, farrightflag; + triangle ptr; /* Temporary variable used by sym(), onext(), and oprev(). */ + + poolinit(&m->splaynodes, sizeof(struct splaynode), SPLAYNODEPERBLOCK, + SPLAYNODEPERBLOCK, 0); + splayroot = (struct splaynode *)NULL; + + if (b->verbose) { + printf(" Placing vertices in event heap.\n"); + } + createeventheap(m, &eventheap, &events, &freeevents); + heapsize = m->invertices; + + if (b->verbose) { + printf(" Forming triangulation.\n"); + } + maketriangle(m, b, &lefttri); + maketriangle(m, b, &righttri); + bond(lefttri, righttri); + lnextself(lefttri); + lprevself(righttri); + bond(lefttri, righttri); + lnextself(lefttri); + lprevself(righttri); + bond(lefttri, righttri); + firstvertex = (vertex)eventheap[0]->eventptr; + eventheap[0]->eventptr = (VOID *)freeevents; + freeevents = eventheap[0]; + eventheapdelete(eventheap, heapsize, 0); + heapsize--; + do { + if (heapsize == 0) { + printf("Error: Input vertices are all identical.\n"); + triexit(1); + } + secondvertex = (vertex)eventheap[0]->eventptr; + eventheap[0]->eventptr = (VOID *)freeevents; + freeevents = eventheap[0]; + eventheapdelete(eventheap, heapsize, 0); + heapsize--; + if ((firstvertex[0] == secondvertex[0]) && + (firstvertex[1] == secondvertex[1])) { + if (!b->quiet) { + printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " + "was ignored.\n", + secondvertex[0], secondvertex[1]); + } + setvertextype(secondvertex, UNDEADVERTEX); + m->undeads++; + } + } while ((firstvertex[0] == secondvertex[0]) && + (firstvertex[1] == secondvertex[1])); + setorg(lefttri, firstvertex); + setdest(lefttri, secondvertex); + setorg(righttri, secondvertex); + setdest(righttri, firstvertex); + lprev(lefttri, bottommost); + lastvertex = secondvertex; + while (heapsize > 0) { + nextevent = eventheap[0]; + eventheapdelete(eventheap, heapsize, 0); + heapsize--; + check4events = 1; + if (nextevent->xkey < m->xmin) { + decode(nextevent->eventptr, fliptri); + oprev(fliptri, farlefttri); + check4deadevent(&farlefttri, &freeevents, eventheap, &heapsize); + onext(fliptri, farrighttri); + check4deadevent(&farrighttri, &freeevents, eventheap, &heapsize); + + if (otriequal(farlefttri, bottommost)) { + lprev(fliptri, bottommost); + } + flip(m, b, &fliptri); + setapex(fliptri, NULL); + lprev(fliptri, lefttri); + lnext(fliptri, righttri); + sym(lefttri, farlefttri); + + if (randomnation(SAMPLERATE) == 0) { + symself(fliptri); + dest(fliptri, leftvertex); + apex(fliptri, midvertex); + org(fliptri, rightvertex); + splayroot = circletopinsert(m, b, splayroot, &lefttri, leftvertex, + midvertex, rightvertex, nextevent->ykey); + } + } else { + nextvertex = (vertex)nextevent->eventptr; + if ((nextvertex[0] == lastvertex[0]) && + (nextvertex[1] == lastvertex[1])) { + if (!b->quiet) { + printf("Warning: A duplicate vertex at (%.12g, %.12g) appeared and " + "was ignored.\n", + nextvertex[0], nextvertex[1]); + } + setvertextype(nextvertex, UNDEADVERTEX); + m->undeads++; + check4events = 0; + } else { + lastvertex = nextvertex; + + splayroot = frontlocate(m, splayroot, &bottommost, nextvertex, + &searchtri, &farrightflag); + /* + otricopy(bottommost, searchtri); + farrightflag = 0; + while (!farrightflag && rightofhyperbola(m, &searchtri, + nextvertex)) { onextself(searchtri); farrightflag = + otriequal(searchtri, bottommost); + } + */ + + check4deadevent(&searchtri, &freeevents, eventheap, &heapsize); + + otricopy(searchtri, farrighttri); + sym(searchtri, farlefttri); + maketriangle(m, b, &lefttri); + maketriangle(m, b, &righttri); + dest(farrighttri, connectvertex); + setorg(lefttri, connectvertex); + setdest(lefttri, nextvertex); + setorg(righttri, nextvertex); + setdest(righttri, connectvertex); + bond(lefttri, righttri); + lnextself(lefttri); + lprevself(righttri); + bond(lefttri, righttri); + lnextself(lefttri); + lprevself(righttri); + bond(lefttri, farlefttri); + bond(righttri, farrighttri); + if (!farrightflag && otriequal(farrighttri, bottommost)) { + otricopy(lefttri, bottommost); + } + + if (randomnation(SAMPLERATE) == 0) { + splayroot = splayinsert(m, splayroot, &lefttri, nextvertex); + } else if (randomnation(SAMPLERATE) == 0) { + lnext(righttri, inserttri); + splayroot = splayinsert(m, splayroot, &inserttri, nextvertex); + } + } + } + nextevent->eventptr = (VOID *)freeevents; + freeevents = nextevent; + + if (check4events) { + apex(farlefttri, leftvertex); + dest(lefttri, midvertex); + apex(lefttri, rightvertex); + lefttest = counterclockwise(m, b, leftvertex, midvertex, rightvertex); + if (lefttest > 0.0) { + newevent = freeevents; + freeevents = (struct event *)freeevents->eventptr; + newevent->xkey = m->xminextreme; + newevent->ykey = + circletop(m, leftvertex, midvertex, rightvertex, lefttest); + newevent->eventptr = (VOID *)encode(lefttri); + eventheapinsert(eventheap, heapsize, newevent); + heapsize++; + setorg(lefttri, newevent); + } + apex(righttri, leftvertex); + org(righttri, midvertex); + apex(farrighttri, rightvertex); + righttest = counterclockwise(m, b, leftvertex, midvertex, rightvertex); + if (righttest > 0.0) { + newevent = freeevents; + freeevents = (struct event *)freeevents->eventptr; + newevent->xkey = m->xminextreme; + newevent->ykey = + circletop(m, leftvertex, midvertex, rightvertex, righttest); + newevent->eventptr = (VOID *)encode(farrighttri); + eventheapinsert(eventheap, heapsize, newevent); + heapsize++; + setorg(farrighttri, newevent); + } + } + } + + pooldeinit(&m->splaynodes); + lprevself(bottommost); + return removeghosts(m, b, &bottommost); +} + +#endif /* not REDUCED */ + +/** **/ +/** **/ +/********* Sweepline Delaunay triangulation ends here *********/ + +/********* General mesh construction routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* delaunay() Form a Delaunay triangulation. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +long delaunay(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +long delaunay(m, b) +struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + long hulledges; + + m->eextras = 0; + initializetrisubpools(m, b); + +#ifdef REDUCED + if (!b->quiet) { + printf( + "Constructing Delaunay triangulation by divide-and-conquer method.\n"); + } + hulledges = divconqdelaunay(m, b); +#else /* not REDUCED */ + if (!b->quiet) { + printf("Constructing Delaunay triangulation "); + if (b->incremental) { + printf("by incremental method.\n"); + } else if (b->sweepline) { + printf("by sweepline method.\n"); + } else { + printf("by divide-and-conquer method.\n"); + } + } + if (b->incremental) { + hulledges = incrementaldelaunay(m, b); + } else if (b->sweepline) { + hulledges = sweeplinedelaunay(m, b); + } else { + hulledges = divconqdelaunay(m, b); + } +#endif /* not REDUCED */ + + if (m->triangles.items == 0) { + /* The input vertices were all collinear, so there are no triangles. */ + return 0l; + } else { + return hulledges; + } +} + +/*****************************************************************************/ +/* */ +/* reconstruct() Reconstruct a triangulation from its .ele (and possibly */ +/* .poly) file. Used when the -r switch is used. */ +/* */ +/* Reads an .ele file and reconstructs the original mesh. If the -p switch */ +/* is used, this procedure will also read a .poly file and reconstruct the */ +/* subsegments of the original mesh. If the -a switch is used, this */ +/* procedure will also read an .area file and set a maximum area constraint */ +/* on each triangle. */ +/* */ +/* Vertices that are not corners of triangles, such as nodes on edges of */ +/* subparametric elements, are discarded. */ +/* */ +/* This routine finds the adjacencies between triangles (and subsegments) */ +/* by forming one stack of triangles for each vertex. Each triangle is on */ +/* three different stacks simultaneously. Each triangle's subsegment */ +/* pointers are used to link the items in each stack. This memory-saving */ +/* feature makes the code harder to read. The most important thing to keep */ +/* in mind is that each triangle is removed from a stack precisely when */ +/* the corresponding pointer is adjusted to refer to a subsegment rather */ +/* than the next triangle of the stack. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +int reconstruct(struct mesh *m, struct behavior *b, int *trianglelist, + REAL *triangleattriblist, REAL *trianglearealist, int elements, + int corners, int attribs, int *segmentlist, + int *segmentmarkerlist, int numberofsegments) +#else /* not ANSI_DECLARATORS */ +int reconstruct(m, b, trianglelist, triangleattriblist, trianglearealist, + elements, corners, attribs, segmentlist, segmentmarkerlist, + numberofsegments) +struct mesh *m; +struct behavior *b; +int *trianglelist; +REAL *triangleattriblist; +REAL *trianglearealist; +int elements; +int corners; +int attribs; +int *segmentlist; +int *segmentmarkerlist; +int numberofsegments; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +long reconstruct(struct mesh *m, struct behavior *b, char *elefilename, + char *areafilename, char *polyfilename, FILE *polyfile) +#else /* not ANSI_DECLARATORS */ +long reconstruct(m, b, elefilename, areafilename, polyfilename, polyfile) +struct mesh *m; +struct behavior *b; +char *elefilename; +char *areafilename; +char *polyfilename; +FILE *polyfile; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + int vertexindex; + int attribindex; +#else /* not TRILIBRARY */ + FILE *elefile; + FILE *areafile; + char inputline[INPUTLINESIZE]; + char *stringptr; + int areaelements; +#endif /* not TRILIBRARY */ + struct otri triangleloop; + struct otri triangleleft; + struct otri checktri; + struct otri checkleft; + struct otri checkneighbor; + struct osub subsegloop; + triangle *vertexarray; + triangle *prevlink; + triangle nexttri; + vertex tdest, tapex; + vertex checkdest, checkapex; + vertex shorg; + vertex killvertex; + vertex segmentorg, segmentdest; + REAL area; + int corner[3]; + int end[2]; + int killvertexindex; + int incorners; + int segmentmarkers; + int boundmarker; + int aroundvertex; + long hullsize; + int notfound; + long elementnumber, segmentnumber; + int i, j; + triangle ptr; /* Temporary variable used by sym(). */ + +#ifdef TRILIBRARY + m->inelements = elements; + incorners = corners; + if (incorners < 3) { + printf("Error: Triangles must have at least 3 vertices.\n"); + triexit(1); + } + m->eextras = attribs; +#else /* not TRILIBRARY */ + /* Read the triangles from an .ele file. */ + if (!b->quiet) { + printf("Opening %s.\n", elefilename); + } + elefile = fopen(elefilename, "r"); + if (elefile == (FILE *)NULL) { + printf(" Error: Cannot access file %s.\n", elefilename); + triexit(1); + } + /* Read number of triangles, number of vertices per triangle, and */ + /* number of triangle attributes from .ele file. */ + stringptr = readline(inputline, elefile, elefilename); + m->inelements = (int)strtol(stringptr, &stringptr, 0); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + incorners = 3; + } else { + incorners = (int)strtol(stringptr, &stringptr, 0); + if (incorners < 3) { + printf("Error: Triangles in %s must have at least 3 vertices.\n", + elefilename); + triexit(1); + } + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + m->eextras = 0; + } else { + m->eextras = (int)strtol(stringptr, &stringptr, 0); + } +#endif /* not TRILIBRARY */ + + initializetrisubpools(m, b); + + /* Create the triangles. */ + for (elementnumber = 1; elementnumber <= m->inelements; elementnumber++) { + maketriangle(m, b, &triangleloop); + /* Mark the triangle as living. */ + triangleloop.tri[3] = (triangle)triangleloop.tri; + } + + segmentmarkers = 0; + if (b->poly) { +#ifdef TRILIBRARY + m->insegments = numberofsegments; + segmentmarkers = segmentmarkerlist != (int *)NULL; +#else /* not TRILIBRARY */ + /* Read number of segments and number of segment */ + /* boundary markers from .poly file. */ + stringptr = readline(inputline, polyfile, b->inpolyfilename); + m->insegments = (int)strtol(stringptr, &stringptr, 0); + stringptr = findfield(stringptr); + if (*stringptr != '\0') { + segmentmarkers = (int)strtol(stringptr, &stringptr, 0); + } +#endif /* not TRILIBRARY */ + + /* Create the subsegments. */ + for (segmentnumber = 1; segmentnumber <= m->insegments; segmentnumber++) { + makesubseg(m, &subsegloop); + /* Mark the subsegment as living. */ + subsegloop.ss[2] = (subseg)subsegloop.ss; + } + } + +#ifdef TRILIBRARY + vertexindex = 0; + attribindex = 0; +#else /* not TRILIBRARY */ + if (b->vararea) { + /* Open an .area file, check for consistency with the .ele file. */ + if (!b->quiet) { + printf("Opening %s.\n", areafilename); + } + areafile = fopen(areafilename, "r"); + if (areafile == (FILE *)NULL) { + printf(" Error: Cannot access file %s.\n", areafilename); + triexit(1); + } + stringptr = readline(inputline, areafile, areafilename); + areaelements = (int)strtol(stringptr, &stringptr, 0); + if (areaelements != m->inelements) { + printf("Error: %s and %s disagree on number of triangles.\n", + elefilename, areafilename); + triexit(1); + } + } +#endif /* not TRILIBRARY */ + + if (!b->quiet) { + printf("Reconstructing mesh.\n"); + } + /* Allocate a temporary array that maps each vertex to some adjacent */ + /* triangle. I took care to allocate all the permanent memory for */ + /* triangles and subsegments first. */ + vertexarray = + (triangle *)trimalloc(m->vertices.items * (int)sizeof(triangle)); + /* Each vertex is initially unrepresented. */ + for (i = 0; i < m->vertices.items; i++) { + vertexarray[i] = (triangle)m->dummytri; + } + + if (b->verbose) { + printf(" Assembling triangles.\n"); + } + /* Read the triangles from the .ele file, and link */ + /* together those that share an edge. */ + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + elementnumber = b->firstnumber; + while (triangleloop.tri != (triangle *)NULL) { +#ifdef TRILIBRARY + /* Copy the triangle's three corners. */ + for (j = 0; j < 3; j++) { + corner[j] = trianglelist[vertexindex++]; + if ((corner[j] < b->firstnumber) || + (corner[j] >= b->firstnumber + m->invertices)) { + printf("Error: Triangle %ld has an invalid vertex index.\n", + elementnumber); + triexit(1); + } + } +#else /* not TRILIBRARY */ + /* Read triangle number and the triangle's three corners. */ + stringptr = readline(inputline, elefile, elefilename); + for (j = 0; j < 3; j++) { + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Triangle %ld is missing vertex %d in %s.\n", + elementnumber, j + 1, elefilename); + triexit(1); + } else { + corner[j] = (int)strtol(stringptr, &stringptr, 0); + if ((corner[j] < b->firstnumber) || + (corner[j] >= b->firstnumber + m->invertices)) { + printf("Error: Triangle %ld has an invalid vertex index.\n", + elementnumber); + triexit(1); + } + } + } +#endif /* not TRILIBRARY */ + + /* Find out about (and throw away) extra nodes. */ + for (j = 3; j < incorners; j++) { +#ifdef TRILIBRARY + killvertexindex = trianglelist[vertexindex++]; +#else /* not TRILIBRARY */ + stringptr = findfield(stringptr); + if (*stringptr != '\0') { + killvertexindex = (int)strtol(stringptr, &stringptr, 0); +#endif /* not TRILIBRARY */ + if ((killvertexindex >= b->firstnumber) && + (killvertexindex < b->firstnumber + m->invertices)) { + /* Delete the non-corner vertex if it's not already deleted. */ + killvertex = getvertex(m, b, killvertexindex); + if (vertextype(killvertex) != DEADVERTEX) { + vertexdealloc(m, killvertex); + } + } +#ifndef TRILIBRARY + } +#endif /* not TRILIBRARY */ + } + + /* Read the triangle's attributes. */ + for (j = 0; j < m->eextras; j++) { +#ifdef TRILIBRARY + setelemattribute(triangleloop, j, triangleattriblist[attribindex++]); +#else /* not TRILIBRARY */ + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + setelemattribute(triangleloop, j, 0); + } else { + setelemattribute(triangleloop, j, + (REAL)strtod(stringptr, &stringptr)); + } +#endif /* not TRILIBRARY */ + } + + if (b->vararea) { +#ifdef TRILIBRARY + area = trianglearealist[elementnumber - b->firstnumber]; +#else /* not TRILIBRARY */ + /* Read an area constraint from the .area file. */ + stringptr = readline(inputline, areafile, areafilename); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + area = -1.0; /* No constraint on this triangle. */ + } else { + area = (REAL)strtod(stringptr, &stringptr); + } +#endif /* not TRILIBRARY */ + setareabound(triangleloop, area); + } + + /* Set the triangle's vertices. */ + triangleloop.orient = 0; + setorg(triangleloop, getvertex(m, b, corner[0])); + setdest(triangleloop, getvertex(m, b, corner[1])); + setapex(triangleloop, getvertex(m, b, corner[2])); + /* Try linking the triangle to others that share these vertices. */ + for (triangleloop.orient = 0; triangleloop.orient < 3; + triangleloop.orient++) { + /* Take the number for the origin of triangleloop. */ + aroundvertex = corner[triangleloop.orient]; + /* Look for other triangles having this vertex. */ + nexttri = vertexarray[aroundvertex - b->firstnumber]; + /* Link the current triangle to the next one in the stack. */ + triangleloop.tri[6 + triangleloop.orient] = nexttri; + /* Push the current triangle onto the stack. */ + vertexarray[aroundvertex - b->firstnumber] = encode(triangleloop); + decode(nexttri, checktri); + if (checktri.tri != m->dummytri) { + dest(triangleloop, tdest); + apex(triangleloop, tapex); + /* Look for other triangles that share an edge. */ + do { + dest(checktri, checkdest); + apex(checktri, checkapex); + if (tapex == checkdest) { + /* The two triangles share an edge; bond them together. */ + lprev(triangleloop, triangleleft); + bond(triangleleft, checktri); + } + if (tdest == checkapex) { + /* The two triangles share an edge; bond them together. */ + lprev(checktri, checkleft); + bond(triangleloop, checkleft); + } + /* Find the next triangle in the stack. */ + nexttri = checktri.tri[6 + checktri.orient]; + decode(nexttri, checktri); + } while (checktri.tri != m->dummytri); + } + } + triangleloop.tri = triangletraverse(m); + elementnumber++; +} + +#ifdef TRILIBRARY +vertexindex = 0; +#else /* not TRILIBRARY */ + fclose(elefile); + if (b->vararea) { + fclose(areafile); + } +#endif /* not TRILIBRARY */ + +hullsize = 0; /* Prepare to count the boundary edges. */ +if (b->poly) { + if (b->verbose) { + printf(" Marking segments in triangulation.\n"); + } + /* Read the segments from the .poly file, and link them */ + /* to their neighboring triangles. */ + boundmarker = 0; + traversalinit(&m->subsegs); + subsegloop.ss = subsegtraverse(m); + segmentnumber = b->firstnumber; + while (subsegloop.ss != (subseg *)NULL) { +#ifdef TRILIBRARY + end[0] = segmentlist[vertexindex++]; + end[1] = segmentlist[vertexindex++]; + if (segmentmarkers) { + boundmarker = segmentmarkerlist[segmentnumber - b->firstnumber]; + } +#else /* not TRILIBRARY */ + /* Read the endpoints of each segment, and possibly a boundary marker. + */ + stringptr = readline(inputline, polyfile, b->inpolyfilename); + /* Skip the first (segment number) field. */ + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Segment %ld has no endpoints in %s.\n", segmentnumber, + polyfilename); + triexit(1); + } else { + end[0] = (int)strtol(stringptr, &stringptr, 0); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Segment %ld is missing its second endpoint in %s.\n", + segmentnumber, polyfilename); + triexit(1); + } else { + end[1] = (int)strtol(stringptr, &stringptr, 0); + } + if (segmentmarkers) { + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + boundmarker = 0; + } else { + boundmarker = (int)strtol(stringptr, &stringptr, 0); + } + } +#endif /* not TRILIBRARY */ + for (j = 0; j < 2; j++) { + if ((end[j] < b->firstnumber) || + (end[j] >= b->firstnumber + m->invertices)) { + printf("Error: Segment %ld has an invalid vertex index.\n", + segmentnumber); + triexit(1); + } + } + + /* set the subsegment's vertices. */ + subsegloop.ssorient = 0; + segmentorg = getvertex(m, b, end[0]); + segmentdest = getvertex(m, b, end[1]); + setsorg(subsegloop, segmentorg); + setsdest(subsegloop, segmentdest); + setsegorg(subsegloop, segmentorg); + setsegdest(subsegloop, segmentdest); + setmark(subsegloop, boundmarker); + /* Try linking the subsegment to triangles that share these vertices. */ + for (subsegloop.ssorient = 0; subsegloop.ssorient < 2; + subsegloop.ssorient++) { + /* Take the number for the destination of subsegloop. */ + aroundvertex = end[1 - subsegloop.ssorient]; + /* Look for triangles having this vertex. */ + prevlink = &vertexarray[aroundvertex - b->firstnumber]; + nexttri = vertexarray[aroundvertex - b->firstnumber]; + decode(nexttri, checktri); + sorg(subsegloop, shorg); + notfound = 1; + /* Look for triangles having this edge. Note that I'm only */ + /* comparing each triangle's destination with the subsegment; */ + /* each triangle's apex is handled through a different vertex. */ + /* Because each triangle appears on three vertices' lists, each */ + /* occurrence of a triangle on a list can (and does) represent */ + /* an edge. In this way, most edges are represented twice, and */ + /* every triangle-subsegment bond is represented once. */ + while (notfound && (checktri.tri != m->dummytri)) { + dest(checktri, checkdest); + if (shorg == checkdest) { + /* We have a match. Remove this triangle from the list. */ + *prevlink = checktri.tri[6 + checktri.orient]; + /* Bond the subsegment to the triangle. */ + tsbond(checktri, subsegloop); + /* Check if this is a boundary edge. */ + sym(checktri, checkneighbor); + if (checkneighbor.tri == m->dummytri) { + /* The next line doesn't insert a subsegment (because there's */ + /* already one there), but it sets the boundary markers of */ + /* the existing subsegment and its vertices. */ + insertsubseg(m, b, &checktri, 1); + hullsize++; + } + notfound = 0; + } + /* Find the next triangle in the stack. */ + prevlink = &checktri.tri[6 + checktri.orient]; + nexttri = checktri.tri[6 + checktri.orient]; + decode(nexttri, checktri); + } + } + subsegloop.ss = subsegtraverse(m); + segmentnumber++; + } +} + +/* Mark the remaining edges as not being attached to any subsegment. */ +/* Also, count the (yet uncounted) boundary edges. */ +for (i = 0; i < m->vertices.items; i++) { + /* Search the stack of triangles adjacent to a vertex. */ + nexttri = vertexarray[i]; + decode(nexttri, checktri); + while (checktri.tri != m->dummytri) { + /* Find the next triangle in the stack before this */ + /* information gets overwritten. */ + nexttri = checktri.tri[6 + checktri.orient]; + /* No adjacent subsegment. (This overwrites the stack info.) */ + tsdissolve(checktri); + sym(checktri, checkneighbor); + if (checkneighbor.tri == m->dummytri) { + insertsubseg(m, b, &checktri, 1); + hullsize++; + } + decode(nexttri, checktri); + } +} + +trifree((VOID *)vertexarray); +return hullsize; +} + +#endif /* not CDT_ONLY */ + +/** **/ +/** **/ +/********* General mesh construction routines end here *********/ + +/********* Segment insertion begins here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* finddirection() Find the first triangle on the path from one point */ +/* to another. */ +/* */ +/* Finds the triangle that intersects a line segment drawn from the */ +/* origin of `searchtri' to the point `searchpoint', and returns the result */ +/* in `searchtri'. The origin of `searchtri' does not change, even though */ +/* the triangle returned may differ from the one passed in. This routine */ +/* is used to find the direction to move in to get from one point to */ +/* another. */ +/* */ +/* The return value notes whether the destination or apex of the found */ +/* triangle is collinear with the two points in question. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +enum finddirectionresult finddirection(struct mesh *m, struct behavior *b, + struct otri *searchtri, + vertex searchpoint) +#else /* not ANSI_DECLARATORS */ +enum finddirectionresult finddirection(m, b, searchtri, searchpoint) +struct mesh *m; +struct behavior *b; +struct otri *searchtri; +vertex searchpoint; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri checktri; + vertex startvertex; + vertex leftvertex, rightvertex; + REAL leftccw, rightccw; + int leftflag, rightflag; + triangle ptr; /* Temporary variable used by onext() and oprev(). */ + + org(*searchtri, startvertex); + dest(*searchtri, rightvertex); + apex(*searchtri, leftvertex); + /* Is `searchpoint' to the left? */ + leftccw = counterclockwise(m, b, searchpoint, startvertex, leftvertex); + leftflag = leftccw > 0.0; + /* Is `searchpoint' to the right? */ + rightccw = counterclockwise(m, b, startvertex, searchpoint, rightvertex); + rightflag = rightccw > 0.0; + if (leftflag && rightflag) { + /* `searchtri' faces directly away from `searchpoint'. We could go left */ + /* or right. Ask whether it's a triangle or a boundary on the left. */ + onext(*searchtri, checktri); + if (checktri.tri == m->dummytri) { + leftflag = 0; + } else { + rightflag = 0; + } + } + while (leftflag) { + /* Turn left until satisfied. */ + onextself(*searchtri); + if (searchtri->tri == m->dummytri) { + printf("Internal error in finddirection(): Unable to find a\n"); + printf(" triangle leading from (%.12g, %.12g) to", startvertex[0], + startvertex[1]); + printf(" (%.12g, %.12g).\n", searchpoint[0], searchpoint[1]); + internalerror(); + } + apex(*searchtri, leftvertex); + rightccw = leftccw; + leftccw = counterclockwise(m, b, searchpoint, startvertex, leftvertex); + leftflag = leftccw > 0.0; + } + while (rightflag) { + /* Turn right until satisfied. */ + oprevself(*searchtri); + if (searchtri->tri == m->dummytri) { + printf("Internal error in finddirection(): Unable to find a\n"); + printf(" triangle leading from (%.12g, %.12g) to", startvertex[0], + startvertex[1]); + printf(" (%.12g, %.12g).\n", searchpoint[0], searchpoint[1]); + internalerror(); + } + dest(*searchtri, rightvertex); + leftccw = rightccw; + rightccw = counterclockwise(m, b, startvertex, searchpoint, rightvertex); + rightflag = rightccw > 0.0; + } + if (leftccw == 0.0) { + return LEFTCOLLINEAR; + } else if (rightccw == 0.0) { + return RIGHTCOLLINEAR; + } else { + return WITHIN; + } +} + +/*****************************************************************************/ +/* */ +/* segmentintersection() Find the intersection of an existing segment */ +/* and a segment that is being inserted. Insert */ +/* a vertex at the intersection, splitting an */ +/* existing subsegment. */ +/* */ +/* The segment being inserted connects the apex of splittri to endpoint2. */ +/* splitsubseg is the subsegment being split, and MUST adjoin splittri. */ +/* Hence, endpoints of the subsegment being split are the origin and */ +/* destination of splittri. */ +/* */ +/* On completion, splittri is a handle having the newly inserted */ +/* intersection point as its origin, and endpoint1 as its destination. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void segmentintersection(struct mesh *m, struct behavior *b, + struct otri *splittri, struct osub *splitsubseg, + vertex endpoint2) +#else /* not ANSI_DECLARATORS */ +void segmentintersection(m, b, splittri, splitsubseg, endpoint2) struct mesh *m; +struct behavior *b; +struct otri *splittri; +struct osub *splitsubseg; +vertex endpoint2; +#endif /* not ANSI_DECLARATORS */ + +{ + struct osub opposubseg; + vertex endpoint1; + vertex torg, tdest; + vertex leftvertex, rightvertex; + vertex newvertex; + enum insertvertexresult success; + enum finddirectionresult collinear; + REAL ex, ey; + REAL tx, ty; + REAL etx, ety; + REAL split, denom; + int i; + triangle ptr; /* Temporary variable used by onext(). */ + subseg sptr; /* Temporary variable used by snext(). */ + + /* Find the other three segment endpoints. */ + apex(*splittri, endpoint1); + org(*splittri, torg); + dest(*splittri, tdest); + /* Segment intersection formulae; see the Antonio reference. */ + tx = tdest[0] - torg[0]; + ty = tdest[1] - torg[1]; + ex = endpoint2[0] - endpoint1[0]; + ey = endpoint2[1] - endpoint1[1]; + etx = torg[0] - endpoint2[0]; + ety = torg[1] - endpoint2[1]; + denom = ty * ex - tx * ey; + if (denom == 0.0) { + printf("Internal error in segmentintersection():"); + printf(" Attempt to find intersection of parallel segments.\n"); + internalerror(); + } + split = (ey * etx - ex * ety) / denom; + /* Create the new vertex. */ + newvertex = (vertex)poolalloc(&m->vertices); + /* Interpolate its coordinate and attributes. */ + for (i = 0; i < 2 + m->nextras; i++) { + newvertex[i] = torg[i] + split * (tdest[i] - torg[i]); + } + setvertexmark(newvertex, mark(*splitsubseg)); + setvertextype(newvertex, INPUTVERTEX); + if (b->verbose > 1) { + printf(" Splitting subsegment (%.12g, %.12g) (%.12g, %.12g) at (%.12g, " + "%.12g).\n", + torg[0], torg[1], tdest[0], tdest[1], newvertex[0], newvertex[1]); + } + /* Insert the intersection vertex. This should always succeed. */ + success = insertvertex(m, b, newvertex, splittri, splitsubseg, 0, 0); + if (success != SUCCESSFULVERTEX) { + printf("Internal error in segmentintersection():\n"); + printf(" Failure to split a segment.\n"); + internalerror(); + } + /* Record a triangle whose origin is the new vertex. */ + setvertex2tri(newvertex, encode(*splittri)); + if (m->steinerleft > 0) { + m->steinerleft--; + } + + /* Divide the segment into two, and correct the segment endpoints. */ + ssymself(*splitsubseg); + spivot(*splitsubseg, opposubseg); + sdissolve(*splitsubseg); + sdissolve(opposubseg); + do { + setsegorg(*splitsubseg, newvertex); + snextself(*splitsubseg); + } while (splitsubseg->ss != m->dummysub); + do { + setsegorg(opposubseg, newvertex); + snextself(opposubseg); + } while (opposubseg.ss != m->dummysub); + + /* Inserting the vertex may have caused edge flips. We wish to rediscover */ + /* the edge connecting endpoint1 to the new intersection vertex. */ + collinear = finddirection(m, b, splittri, endpoint1); + dest(*splittri, rightvertex); + apex(*splittri, leftvertex); + if ((leftvertex[0] == endpoint1[0]) && (leftvertex[1] == endpoint1[1])) { + onextself(*splittri); + } else if ((rightvertex[0] != endpoint1[0]) || + (rightvertex[1] != endpoint1[1])) { + printf("Internal error in segmentintersection():\n"); + printf(" Topological inconsistency after splitting a segment.\n"); + internalerror(); + } + /* `splittri' should have destination endpoint1. */ +} + +/*****************************************************************************/ +/* */ +/* scoutsegment() Scout the first triangle on the path from one endpoint */ +/* to another, and check for completion (reaching the */ +/* second endpoint), a collinear vertex, or the */ +/* intersection of two segments. */ +/* */ +/* Returns one if the entire segment is successfully inserted, and zero if */ +/* the job must be finished by conformingedge() or constrainededge(). */ +/* */ +/* If the first triangle on the path has the second endpoint as its */ +/* destination or apex, a subsegment is inserted and the job is done. */ +/* */ +/* If the first triangle on the path has a destination or apex that lies on */ +/* the segment, a subsegment is inserted connecting the first endpoint to */ +/* the collinear vertex, and the search is continued from the collinear */ +/* vertex. */ +/* */ +/* If the first triangle on the path has a subsegment opposite its origin, */ +/* then there is a segment that intersects the segment being inserted. */ +/* Their intersection vertex is inserted, splitting the subsegment. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +int scoutsegment(struct mesh *m, struct behavior *b, struct otri *searchtri, + vertex endpoint2, int newmark) +#else /* not ANSI_DECLARATORS */ +int scoutsegment(m, b, searchtri, endpoint2, newmark) +struct mesh *m; +struct behavior *b; +struct otri *searchtri; +vertex endpoint2; +int newmark; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri crosstri; + struct osub crosssubseg; + vertex leftvertex, rightvertex; + enum finddirectionresult collinear; + subseg sptr; /* Temporary variable used by tspivot(). */ + + collinear = finddirection(m, b, searchtri, endpoint2); + dest(*searchtri, rightvertex); + apex(*searchtri, leftvertex); + if (((leftvertex[0] == endpoint2[0]) && (leftvertex[1] == endpoint2[1])) || + ((rightvertex[0] == endpoint2[0]) && (rightvertex[1] == endpoint2[1]))) { + /* The segment is already an edge in the mesh. */ + if ((leftvertex[0] == endpoint2[0]) && (leftvertex[1] == endpoint2[1])) { + lprevself(*searchtri); + } + /* Insert a subsegment, if there isn't already one there. */ + insertsubseg(m, b, searchtri, newmark); + return 1; + } else if (collinear == LEFTCOLLINEAR) { + /* We've collided with a vertex between the segment's endpoints. */ + /* Make the collinear vertex be the triangle's origin. */ + lprevself(*searchtri); + insertsubseg(m, b, searchtri, newmark); + /* Insert the remainder of the segment. */ + return scoutsegment(m, b, searchtri, endpoint2, newmark); + } else if (collinear == RIGHTCOLLINEAR) { + /* We've collided with a vertex between the segment's endpoints. */ + insertsubseg(m, b, searchtri, newmark); + /* Make the collinear vertex be the triangle's origin. */ + lnextself(*searchtri); + /* Insert the remainder of the segment. */ + return scoutsegment(m, b, searchtri, endpoint2, newmark); + } else { + lnext(*searchtri, crosstri); + tspivot(crosstri, crosssubseg); + /* Check for a crossing segment. */ + if (crosssubseg.ss == m->dummysub) { + return 0; + } else { + /* Insert a vertex at the intersection. */ + segmentintersection(m, b, &crosstri, &crosssubseg, endpoint2); + otricopy(crosstri, *searchtri); + insertsubseg(m, b, searchtri, newmark); + /* Insert the remainder of the segment. */ + return scoutsegment(m, b, searchtri, endpoint2, newmark); + } + } +} + +/*****************************************************************************/ +/* */ +/* conformingedge() Force a segment into a conforming Delaunay */ +/* triangulation by inserting a vertex at its midpoint, */ +/* and recursively forcing in the two half-segments if */ +/* necessary. */ +/* */ +/* Generates a sequence of subsegments connecting `endpoint1' to */ +/* `endpoint2'. `newmark' is the boundary marker of the segment, assigned */ +/* to each new splitting vertex and subsegment. */ +/* */ +/* Note that conformingedge() does not always maintain the conforming */ +/* Delaunay property. Once inserted, segments are locked into place; */ +/* vertices inserted later (to force other segments in) may render these */ +/* fixed segments non-Delaunay. The conforming Delaunay property will be */ +/* restored by enforcequality() by splitting encroached subsegments. */ +/* */ +/*****************************************************************************/ + +#ifndef REDUCED +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void conformingedge(struct mesh *m, struct behavior *b, vertex endpoint1, + vertex endpoint2, int newmark) +#else /* not ANSI_DECLARATORS */ +void conformingedge(m, b, endpoint1, endpoint2, newmark) struct mesh *m; +struct behavior *b; +vertex endpoint1; +vertex endpoint2; +int newmark; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri searchtri1, searchtri2; + struct osub brokensubseg; + vertex newvertex; + vertex midvertex1, midvertex2; + enum insertvertexresult success; + int i; + subseg sptr; /* Temporary variable used by tspivot(). */ + + if (b->verbose > 2) { + printf("Forcing segment into triangulation by recursive splitting:\n"); + printf(" (%.12g, %.12g) (%.12g, %.12g)\n", endpoint1[0], endpoint1[1], + endpoint2[0], endpoint2[1]); + } + /* Create a new vertex to insert in the middle of the segment. */ + newvertex = (vertex)poolalloc(&m->vertices); + /* Interpolate coordinates and attributes. */ + for (i = 0; i < 2 + m->nextras; i++) { + newvertex[i] = 0.5 * (endpoint1[i] + endpoint2[i]); + } + setvertexmark(newvertex, newmark); + setvertextype(newvertex, SEGMENTVERTEX); + /* No known triangle to search from. */ + searchtri1.tri = m->dummytri; + /* Attempt to insert the new vertex. */ + success = + insertvertex(m, b, newvertex, &searchtri1, (struct osub *)NULL, 0, 0); + if (success == DUPLICATEVERTEX) { + if (b->verbose > 2) { + printf(" Segment intersects existing vertex (%.12g, %.12g).\n", + newvertex[0], newvertex[1]); + } + /* Use the vertex that's already there. */ + vertexdealloc(m, newvertex); + org(searchtri1, newvertex); + } else { + if (success == VIOLATINGVERTEX) { + if (b->verbose > 2) { + printf(" Two segments intersect at (%.12g, %.12g).\n", newvertex[0], + newvertex[1]); + } + /* By fluke, we've landed right on another segment. Split it. */ + tspivot(searchtri1, brokensubseg); + success = insertvertex(m, b, newvertex, &searchtri1, &brokensubseg, 0, 0); + if (success != SUCCESSFULVERTEX) { + printf("Internal error in conformingedge():\n"); + printf(" Failure to split a segment.\n"); + internalerror(); + } + } + /* The vertex has been inserted successfully. */ + if (m->steinerleft > 0) { + m->steinerleft--; + } + } + otricopy(searchtri1, searchtri2); + /* `searchtri1' and `searchtri2' are fastened at their origins to */ + /* `newvertex', and will be directed toward `endpoint1' and `endpoint2' */ + /* respectively. First, we must get `searchtri2' out of the way so it */ + /* won't be invalidated during the insertion of the first half of the */ + /* segment. */ + finddirection(m, b, &searchtri2, endpoint2); + if (!scoutsegment(m, b, &searchtri1, endpoint1, newmark)) { + /* The origin of searchtri1 may have changed if a collision with an */ + /* intervening vertex on the segment occurred. */ + org(searchtri1, midvertex1); + conformingedge(m, b, midvertex1, endpoint1, newmark); + } + if (!scoutsegment(m, b, &searchtri2, endpoint2, newmark)) { + /* The origin of searchtri2 may have changed if a collision with an */ + /* intervening vertex on the segment occurred. */ + org(searchtri2, midvertex2); + conformingedge(m, b, midvertex2, endpoint2, newmark); + } +} + +#endif /* not CDT_ONLY */ +#endif /* not REDUCED */ + +/*****************************************************************************/ +/* */ +/* delaunayfixup() Enforce the Delaunay condition at an edge, fanning out */ +/* recursively from an existing vertex. Pay special */ +/* attention to stacking inverted triangles. */ +/* */ +/* This is a support routine for inserting segments into a constrained */ +/* Delaunay triangulation. */ +/* */ +/* The origin of fixuptri is treated as if it has just been inserted, and */ +/* the local Delaunay condition needs to be enforced. It is only enforced */ +/* in one sector, however, that being the angular range defined by */ +/* fixuptri. */ +/* */ +/* This routine also needs to make decisions regarding the "stacking" of */ +/* triangles. (Read the description of constrainededge() below before */ +/* reading on here, so you understand the algorithm.) If the position of */ +/* the new vertex (the origin of fixuptri) indicates that the vertex before */ +/* it on the polygon is a reflex vertex, then "stack" the triangle by */ +/* doing nothing. (fixuptri is an inverted triangle, which is how stacked */ +/* triangles are identified.) */ +/* */ +/* Otherwise, check whether the vertex before that was a reflex vertex. */ +/* If so, perform an edge flip, thereby eliminating an inverted triangle */ +/* (popping it off the stack). The edge flip may result in the creation */ +/* of a new inverted triangle, depending on whether or not the new vertex */ +/* is visible to the vertex three edges behind on the polygon. */ +/* */ +/* If neither of the two vertices behind the new vertex are reflex */ +/* vertices, fixuptri and fartri, the triangle opposite it, are not */ +/* inverted; hence, ensure that the edge between them is locally Delaunay. */ +/* */ +/* `leftside' indicates whether or not fixuptri is to the left of the */ +/* segment being inserted. (Imagine that the segment is pointing up from */ +/* endpoint1 to endpoint2.) */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void delaunayfixup(struct mesh *m, struct behavior *b, struct otri *fixuptri, + int leftside) +#else /* not ANSI_DECLARATORS */ +void delaunayfixup(m, b, fixuptri, leftside) struct mesh *m; +struct behavior *b; +struct otri *fixuptri; +int leftside; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri neartri; + struct otri fartri; + struct osub faredge; + vertex nearvertex, leftvertex, rightvertex, farvertex; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + lnext(*fixuptri, neartri); + sym(neartri, fartri); + /* Check if the edge opposite the origin of fixuptri can be flipped. */ + if (fartri.tri == m->dummytri) { + return; + } + tspivot(neartri, faredge); + if (faredge.ss != m->dummysub) { + return; + } + /* Find all the relevant vertices. */ + apex(neartri, nearvertex); + org(neartri, leftvertex); + dest(neartri, rightvertex); + apex(fartri, farvertex); + /* Check whether the previous polygon vertex is a reflex vertex. */ + if (leftside) { + if (counterclockwise(m, b, nearvertex, leftvertex, farvertex) <= 0.0) { + /* leftvertex is a reflex vertex too. Nothing can */ + /* be done until a convex section is found. */ + return; + } + } else { + if (counterclockwise(m, b, farvertex, rightvertex, nearvertex) <= 0.0) { + /* rightvertex is a reflex vertex too. Nothing can */ + /* be done until a convex section is found. */ + return; + } + } + if (counterclockwise(m, b, rightvertex, leftvertex, farvertex) > 0.0) { + /* fartri is not an inverted triangle, and farvertex is not a reflex */ + /* vertex. As there are no reflex vertices, fixuptri isn't an */ + /* inverted triangle, either. Hence, test the edge between the */ + /* triangles to ensure it is locally Delaunay. */ + if (incircle(m, b, leftvertex, farvertex, rightvertex, nearvertex) <= 0.0) { + return; + } + /* Not locally Delaunay; go on to an edge flip. */ + } /* else fartri is inverted; remove it from the stack by flipping. */ + flip(m, b, &neartri); + lprevself(*fixuptri); /* Restore the origin of fixuptri after the flip. */ + /* Recursively process the two triangles that result from the flip. */ + delaunayfixup(m, b, fixuptri, leftside); + delaunayfixup(m, b, &fartri, leftside); +} + +/*****************************************************************************/ +/* */ +/* constrainededge() Force a segment into a constrained Delaunay */ +/* triangulation by deleting the triangles it */ +/* intersects, and triangulating the polygons that */ +/* form on each side of it. */ +/* */ +/* Generates a single subsegment connecting `endpoint1' to `endpoint2'. */ +/* The triangle `starttri' has `endpoint1' as its origin. `newmark' is the */ +/* boundary marker of the segment. */ +/* */ +/* To insert a segment, every triangle whose interior intersects the */ +/* segment is deleted. The union of these deleted triangles is a polygon */ +/* (which is not necessarily monotone, but is close enough), which is */ +/* divided into two polygons by the new segment. This routine's task is */ +/* to generate the Delaunay triangulation of these two polygons. */ +/* */ +/* You might think of this routine's behavior as a two-step process. The */ +/* first step is to walk from endpoint1 to endpoint2, flipping each edge */ +/* encountered. This step creates a fan of edges connected to endpoint1, */ +/* including the desired edge to endpoint2. The second step enforces the */ +/* Delaunay condition on each side of the segment in an incremental manner: */ +/* proceeding along the polygon from endpoint1 to endpoint2 (this is done */ +/* independently on each side of the segment), each vertex is "enforced" */ +/* as if it had just been inserted, but affecting only the previous */ +/* vertices. The result is the same as if the vertices had been inserted */ +/* in the order they appear on the polygon, so the result is Delaunay. */ +/* */ +/* In truth, constrainededge() interleaves these two steps. The procedure */ +/* walks from endpoint1 to endpoint2, and each time an edge is encountered */ +/* and flipped, the newly exposed vertex (at the far end of the flipped */ +/* edge) is "enforced" upon the previously flipped edges, usually affecting */ +/* only one side of the polygon (depending upon which side of the segment */ +/* the vertex falls on). */ +/* */ +/* The algorithm is complicated by the need to handle polygons that are not */ +/* convex. Although the polygon is not necessarily monotone, it can be */ +/* triangulated in a manner similar to the stack-based algorithms for */ +/* monotone polygons. For each reflex vertex (local concavity) of the */ +/* polygon, there will be an inverted triangle formed by one of the edge */ +/* flips. (An inverted triangle is one with negative area - that is, its */ +/* vertices are arranged in clockwise order - and is best thought of as a */ +/* wrinkle in the fabric of the mesh.) Each inverted triangle can be */ +/* thought of as a reflex vertex pushed on the stack, waiting to be fixed */ +/* later. */ +/* */ +/* A reflex vertex is popped from the stack when a vertex is inserted that */ +/* is visible to the reflex vertex. (However, if the vertex behind the */ +/* reflex vertex is not visible to the reflex vertex, a new inverted */ +/* triangle will take its place on the stack.) These details are handled */ +/* by the delaunayfixup() routine above. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void constrainededge(struct mesh *m, struct behavior *b, struct otri *starttri, + vertex endpoint2, int newmark) +#else /* not ANSI_DECLARATORS */ +void constrainededge(m, b, starttri, endpoint2, newmark) struct mesh *m; +struct behavior *b; +struct otri *starttri; +vertex endpoint2; +int newmark; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri fixuptri, fixuptri2; + struct osub crosssubseg; + vertex endpoint1; + vertex farvertex; + REAL area; + int collision; + int done; + triangle ptr; /* Temporary variable used by sym() and oprev(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + org(*starttri, endpoint1); + lnext(*starttri, fixuptri); + flip(m, b, &fixuptri); + /* `collision' indicates whether we have found a vertex directly */ + /* between endpoint1 and endpoint2. */ + collision = 0; + done = 0; + do { + org(fixuptri, farvertex); + /* `farvertex' is the extreme point of the polygon we are "digging" */ + /* to get from endpoint1 to endpoint2. */ + if ((farvertex[0] == endpoint2[0]) && (farvertex[1] == endpoint2[1])) { + oprev(fixuptri, fixuptri2); + /* Enforce the Delaunay condition around endpoint2. */ + delaunayfixup(m, b, &fixuptri, 0); + delaunayfixup(m, b, &fixuptri2, 1); + done = 1; + } else { + /* Check whether farvertex is to the left or right of the segment */ + /* being inserted, to decide which edge of fixuptri to dig */ + /* through next. */ + area = counterclockwise(m, b, endpoint1, endpoint2, farvertex); + if (area == 0.0) { + /* We've collided with a vertex between endpoint1 and endpoint2. */ + collision = 1; + oprev(fixuptri, fixuptri2); + /* Enforce the Delaunay condition around farvertex. */ + delaunayfixup(m, b, &fixuptri, 0); + delaunayfixup(m, b, &fixuptri2, 1); + done = 1; + } else { + if (area > 0.0) { /* farvertex is to the left of the segment. */ + oprev(fixuptri, fixuptri2); + /* Enforce the Delaunay condition around farvertex, on the */ + /* left side of the segment only. */ + delaunayfixup(m, b, &fixuptri2, 1); + /* Flip the edge that crosses the segment. After the edge is */ + /* flipped, one of its endpoints is the fan vertex, and the */ + /* destination of fixuptri is the fan vertex. */ + lprevself(fixuptri); + } else { /* farvertex is to the right of the segment. */ + delaunayfixup(m, b, &fixuptri, 0); + /* Flip the edge that crosses the segment. After the edge is */ + /* flipped, one of its endpoints is the fan vertex, and the */ + /* destination of fixuptri is the fan vertex. */ + oprevself(fixuptri); + } + /* Check for two intersecting segments. */ + tspivot(fixuptri, crosssubseg); + if (crosssubseg.ss == m->dummysub) { + flip(m, b, &fixuptri); /* May create inverted triangle at left. */ + } else { + /* We've collided with a segment between endpoint1 and endpoint2. */ + collision = 1; + /* Insert a vertex at the intersection. */ + segmentintersection(m, b, &fixuptri, &crosssubseg, endpoint2); + done = 1; + } + } + } + } while (!done); + /* Insert a subsegment to make the segment permanent. */ + insertsubseg(m, b, &fixuptri, newmark); + /* If there was a collision with an interceding vertex, install another */ + /* segment connecting that vertex with endpoint2. */ + if (collision) { + /* Insert the remainder of the segment. */ + if (!scoutsegment(m, b, &fixuptri, endpoint2, newmark)) { + constrainededge(m, b, &fixuptri, endpoint2, newmark); + } + } +} + +/*****************************************************************************/ +/* */ +/* insertsegment() Insert a PSLG segment into a triangulation. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void insertsegment(struct mesh *m, struct behavior *b, vertex endpoint1, + vertex endpoint2, int newmark) +#else /* not ANSI_DECLARATORS */ +void insertsegment(m, b, endpoint1, endpoint2, newmark) struct mesh *m; +struct behavior *b; +vertex endpoint1; +vertex endpoint2; +int newmark; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri searchtri1, searchtri2; + triangle encodedtri; + vertex checkvertex; + triangle ptr; /* Temporary variable used by sym(). */ + + if (b->verbose > 1) { + printf(" Connecting (%.12g, %.12g) to (%.12g, %.12g).\n", endpoint1[0], + endpoint1[1], endpoint2[0], endpoint2[1]); + } + + /* Find a triangle whose origin is the segment's first endpoint. */ + checkvertex = (vertex)NULL; + encodedtri = vertex2tri(endpoint1); + if (encodedtri != (triangle)NULL) { + decode(encodedtri, searchtri1); + org(searchtri1, checkvertex); + } + if (checkvertex != endpoint1) { + /* Find a boundary triangle to search from. */ + searchtri1.tri = m->dummytri; + searchtri1.orient = 0; + symself(searchtri1); + /* Search for the segment's first endpoint by point location. */ + if (locate(m, b, endpoint1, &searchtri1) != ONVERTEX) { + printf( + "Internal error in insertsegment(): Unable to locate PSLG vertex\n"); + printf(" (%.12g, %.12g) in triangulation.\n", endpoint1[0], + endpoint1[1]); + internalerror(); + } + } + /* Remember this triangle to improve subsequent point location. */ + otricopy(searchtri1, m->recenttri); + /* Scout the beginnings of a path from the first endpoint */ + /* toward the second. */ + if (scoutsegment(m, b, &searchtri1, endpoint2, newmark)) { + /* The segment was easily inserted. */ + return; + } + /* The first endpoint may have changed if a collision with an intervening */ + /* vertex on the segment occurred. */ + org(searchtri1, endpoint1); + + /* Find a triangle whose origin is the segment's second endpoint. */ + checkvertex = (vertex)NULL; + encodedtri = vertex2tri(endpoint2); + if (encodedtri != (triangle)NULL) { + decode(encodedtri, searchtri2); + org(searchtri2, checkvertex); + } + if (checkvertex != endpoint2) { + /* Find a boundary triangle to search from. */ + searchtri2.tri = m->dummytri; + searchtri2.orient = 0; + symself(searchtri2); + /* Search for the segment's second endpoint by point location. */ + if (locate(m, b, endpoint2, &searchtri2) != ONVERTEX) { + printf( + "Internal error in insertsegment(): Unable to locate PSLG vertex\n"); + printf(" (%.12g, %.12g) in triangulation.\n", endpoint2[0], + endpoint2[1]); + internalerror(); + } + } + /* Remember this triangle to improve subsequent point location. */ + otricopy(searchtri2, m->recenttri); + /* Scout the beginnings of a path from the second endpoint */ + /* toward the first. */ + if (scoutsegment(m, b, &searchtri2, endpoint1, newmark)) { + /* The segment was easily inserted. */ + return; + } + /* The second endpoint may have changed if a collision with an intervening */ + /* vertex on the segment occurred. */ + org(searchtri2, endpoint2); + +#ifndef REDUCED +#ifndef CDT_ONLY + if (b->splitseg) { + /* Insert vertices to force the segment into the triangulation. */ + conformingedge(m, b, endpoint1, endpoint2, newmark); + } else { +#endif /* not CDT_ONLY */ +#endif /* not REDUCED */ + /* Insert the segment directly into the triangulation. */ + constrainededge(m, b, &searchtri1, endpoint2, newmark); +#ifndef REDUCED +#ifndef CDT_ONLY + } +#endif /* not CDT_ONLY */ +#endif /* not REDUCED */ +} + +/*****************************************************************************/ +/* */ +/* markhull() Cover the convex hull of a triangulation with subsegments. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void markhull(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void markhull(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri hulltri; + struct otri nexttri; + struct otri starttri; + triangle ptr; /* Temporary variable used by sym() and oprev(). */ + + /* Find a triangle handle on the hull. */ + hulltri.tri = m->dummytri; + hulltri.orient = 0; + symself(hulltri); + /* Remember where we started so we know when to stop. */ + otricopy(hulltri, starttri); + /* Go once counterclockwise around the convex hull. */ + do { + /* Create a subsegment if there isn't already one here. */ + insertsubseg(m, b, &hulltri, 1); + /* To find the next hull edge, go clockwise around the next vertex. */ + lnextself(hulltri); + oprev(hulltri, nexttri); + while (nexttri.tri != m->dummytri) { + otricopy(nexttri, hulltri); + oprev(hulltri, nexttri); + } + } while (!otriequal(hulltri, starttri)); +} + +/*****************************************************************************/ +/* */ +/* formskeleton() Create the segments of a triangulation, including PSLG */ +/* segments and edges on the convex hull. */ +/* */ +/* The PSLG segments are read from a .poly file. The return value is the */ +/* number of segments in the file. */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void formskeleton(struct mesh *m, struct behavior *b, int *segmentlist, + int *segmentmarkerlist, int numberofsegments) +#else /* not ANSI_DECLARATORS */ + void formskeleton(m, b, segmentlist, segmentmarkerlist, + numberofsegments) struct mesh *m; + struct behavior *b; + int *segmentlist; + int *segmentmarkerlist; + int numberofsegments; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +void formskeleton(struct mesh *m, struct behavior *b, FILE *polyfile, + char *polyfilename) +#else /* not ANSI_DECLARATORS */ +void formskeleton(m, b, polyfile, polyfilename) struct mesh *m; +struct behavior *b; +FILE *polyfile; +char *polyfilename; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + char polyfilename[6]; + int index; +#else /* not TRILIBRARY */ + char inputline[INPUTLINESIZE]; + char *stringptr; +#endif /* not TRILIBRARY */ + vertex endpoint1, endpoint2; + int segmentmarkers; + int end1, end2; + int boundmarker; + int i; + + if (b->poly) { + if (!b->quiet) { + printf("Recovering segments in Delaunay triangulation.\n"); + } +#ifdef TRILIBRARY + strcpy(polyfilename, "input"); + m->insegments = numberofsegments; + segmentmarkers = segmentmarkerlist != (int *)NULL; + index = 0; +#else /* not TRILIBRARY */ + /* Read the segments from a .poly file. */ + /* Read number of segments and number of boundary markers. */ + stringptr = readline(inputline, polyfile, polyfilename); + m->insegments = (int)strtol(stringptr, &stringptr, 0); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + segmentmarkers = 0; + } else { + segmentmarkers = (int)strtol(stringptr, &stringptr, 0); + } +#endif /* not TRILIBRARY */ + /* If the input vertices are collinear, there is no triangulation, */ + /* so don't try to insert segments. */ + if (m->triangles.items == 0) { + return; + } + + /* If segments are to be inserted, compute a mapping */ + /* from vertices to triangles. */ + if (m->insegments > 0) { + makevertexmap(m, b); + if (b->verbose) { + printf(" Recovering PSLG segments.\n"); + } + } + + boundmarker = 0; + /* Read and insert the segments. */ + for (i = 0; i < m->insegments; i++) { +#ifdef TRILIBRARY + end1 = segmentlist[index++]; + end2 = segmentlist[index++]; + if (segmentmarkers) { + boundmarker = segmentmarkerlist[i]; + } +#else /* not TRILIBRARY */ + stringptr = readline(inputline, polyfile, b->inpolyfilename); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Segment %d has no endpoints in %s.\n", + b->firstnumber + i, polyfilename); + triexit(1); + } else { + end1 = (int)strtol(stringptr, &stringptr, 0); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Segment %d is missing its second endpoint in %s.\n", + b->firstnumber + i, polyfilename); + triexit(1); + } else { + end2 = (int)strtol(stringptr, &stringptr, 0); + } + if (segmentmarkers) { + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + boundmarker = 0; + } else { + boundmarker = (int)strtol(stringptr, &stringptr, 0); + } + } +#endif /* not TRILIBRARY */ + if ((end1 < b->firstnumber) || (end1 >= b->firstnumber + m->invertices)) { + if (!b->quiet) { + printf("Warning: Invalid first endpoint of segment %d in %s.\n", + b->firstnumber + i, polyfilename); + } + } else if ((end2 < b->firstnumber) || + (end2 >= b->firstnumber + m->invertices)) { + if (!b->quiet) { + printf("Warning: Invalid second endpoint of segment %d in %s.\n", + b->firstnumber + i, polyfilename); + } + } else { + /* Find the vertices numbered `end1' and `end2'. */ + endpoint1 = getvertex(m, b, end1); + endpoint2 = getvertex(m, b, end2); + if ((endpoint1[0] == endpoint2[0]) && (endpoint1[1] == endpoint2[1])) { + if (!b->quiet) { + printf("Warning: Endpoints of segment %d are coincident in %s.\n", + b->firstnumber + i, polyfilename); + } + } else { + insertsegment(m, b, endpoint1, endpoint2, boundmarker); + } + } + } + } else { + m->insegments = 0; + } + if (b->convex || !b->poly) { + /* Enclose the convex hull with subsegments. */ + if (b->verbose) { + printf(" Enclosing convex hull with segments.\n"); + } + markhull(m, b); + } +} + +/** **/ +/** **/ +/********* Segment insertion ends here *********/ + +/********* Carving out holes and concavities begins here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* infecthull() Virally infect all of the triangles of the convex hull */ +/* that are not protected by subsegments. Where there are */ +/* subsegments, set boundary markers as appropriate. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void infecthull(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void infecthull(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri hulltri; + struct otri nexttri; + struct otri starttri; + struct osub hullsubseg; + triangle **deadtriangle; + vertex horg, hdest; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + if (b->verbose) { + printf(" Marking concavities (external triangles) for elimination.\n"); + } + /* Find a triangle handle on the hull. */ + hulltri.tri = m->dummytri; + hulltri.orient = 0; + symself(hulltri); + /* Remember where we started so we know when to stop. */ + otricopy(hulltri, starttri); + /* Go once counterclockwise around the convex hull. */ + do { + /* Ignore triangles that are already infected. */ + if (!infected(hulltri)) { + /* Is the triangle protected by a subsegment? */ + tspivot(hulltri, hullsubseg); + if (hullsubseg.ss == m->dummysub) { + /* The triangle is not protected; infect it. */ + if (!infected(hulltri)) { + infect(hulltri); + deadtriangle = (triangle **)poolalloc(&m->viri); + *deadtriangle = hulltri.tri; + } + } else { + /* The triangle is protected; set boundary markers if appropriate. */ + if (mark(hullsubseg) == 0) { + setmark(hullsubseg, 1); + org(hulltri, horg); + dest(hulltri, hdest); + if (vertexmark(horg) == 0) { + setvertexmark(horg, 1); + } + if (vertexmark(hdest) == 0) { + setvertexmark(hdest, 1); + } + } + } + } + /* To find the next hull edge, go clockwise around the next vertex. */ + lnextself(hulltri); + oprev(hulltri, nexttri); + while (nexttri.tri != m->dummytri) { + otricopy(nexttri, hulltri); + oprev(hulltri, nexttri); + } + } while (!otriequal(hulltri, starttri)); +} + +/*****************************************************************************/ +/* */ +/* plague() Spread the virus from all infected triangles to any neighbors */ +/* not protected by subsegments. Delete all infected triangles. */ +/* */ +/* This is the procedure that actually creates holes and concavities. */ +/* */ +/* This procedure operates in two phases. The first phase identifies all */ +/* the triangles that will die, and marks them as infected. They are */ +/* marked to ensure that each triangle is added to the virus pool only */ +/* once, so the procedure will terminate. */ +/* */ +/* The second phase actually eliminates the infected triangles. It also */ +/* eliminates orphaned vertices. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void plague(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void plague(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri testtri; + struct otri neighbor; + triangle **virusloop; + triangle **deadtriangle; + struct osub neighborsubseg; + vertex testvertex; + vertex norg, ndest; + vertex deadorg, deaddest, deadapex; + int killorg; + triangle ptr; /* Temporary variable used by sym() and onext(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + if (b->verbose) { + printf(" Marking neighbors of marked triangles.\n"); + } + /* Loop through all the infected triangles, spreading the virus to */ + /* their neighbors, then to their neighbors' neighbors. */ + traversalinit(&m->viri); + virusloop = (triangle **)traverse(&m->viri); + while (virusloop != (triangle **)NULL) { + testtri.tri = *virusloop; + /* A triangle is marked as infected by messing with one of its pointers */ + /* to subsegments, setting it to an illegal value. Hence, we have to */ + /* temporarily uninfect this triangle so that we can examine its */ + /* adjacent subsegments. */ + uninfect(testtri); + if (b->verbose > 2) { + /* Assign the triangle an orientation for convenience in */ + /* checking its vertices. */ + testtri.orient = 0; + org(testtri, deadorg); + dest(testtri, deaddest); + apex(testtri, deadapex); + printf(" Checking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", + deadorg[0], deadorg[1], deaddest[0], deaddest[1], deadapex[0], + deadapex[1]); + } + /* Check each of the triangle's three neighbors. */ + for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { + /* Find the neighbor. */ + sym(testtri, neighbor); + /* Check for a subsegment between the triangle and its neighbor. */ + tspivot(testtri, neighborsubseg); + /* Check if the neighbor is nonexistent or already infected. */ + if ((neighbor.tri == m->dummytri) || infected(neighbor)) { + if (neighborsubseg.ss != m->dummysub) { + /* There is a subsegment separating the triangle from its */ + /* neighbor, but both triangles are dying, so the subsegment */ + /* dies too. */ + subsegdealloc(m, neighborsubseg.ss); + if (neighbor.tri != m->dummytri) { + /* Make sure the subsegment doesn't get deallocated again */ + /* later when the infected neighbor is visited. */ + uninfect(neighbor); + tsdissolve(neighbor); + infect(neighbor); + } + } + } else { /* The neighbor exists and is not infected. */ + if (neighborsubseg.ss == m->dummysub) { + /* There is no subsegment protecting the neighbor, so */ + /* the neighbor becomes infected. */ + if (b->verbose > 2) { + org(neighbor, deadorg); + dest(neighbor, deaddest); + apex(neighbor, deadapex); + printf(" Marking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", + deadorg[0], deadorg[1], deaddest[0], deaddest[1], + deadapex[0], deadapex[1]); + } + infect(neighbor); + /* Ensure that the neighbor's neighbors will be infected. */ + deadtriangle = (triangle **)poolalloc(&m->viri); + *deadtriangle = neighbor.tri; + } else { /* The neighbor is protected by a subsegment. */ + /* Remove this triangle from the subsegment. */ + stdissolve(neighborsubseg); + /* The subsegment becomes a boundary. Set markers accordingly. */ + if (mark(neighborsubseg) == 0) { + setmark(neighborsubseg, 1); + } + org(neighbor, norg); + dest(neighbor, ndest); + if (vertexmark(norg) == 0) { + setvertexmark(norg, 1); + } + if (vertexmark(ndest) == 0) { + setvertexmark(ndest, 1); + } + } + } + } + /* Remark the triangle as infected, so it doesn't get added to the */ + /* virus pool again. */ + infect(testtri); + virusloop = (triangle **)traverse(&m->viri); + } + + if (b->verbose) { + printf(" Deleting marked triangles.\n"); + } + + traversalinit(&m->viri); + virusloop = (triangle **)traverse(&m->viri); + while (virusloop != (triangle **)NULL) { + testtri.tri = *virusloop; + + /* Check each of the three corners of the triangle for elimination. */ + /* This is done by walking around each vertex, checking if it is */ + /* still connected to at least one live triangle. */ + for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { + org(testtri, testvertex); + /* Check if the vertex has already been tested. */ + if (testvertex != (vertex)NULL) { + killorg = 1; + /* Mark the corner of the triangle as having been tested. */ + setorg(testtri, NULL); + /* Walk counterclockwise about the vertex. */ + onext(testtri, neighbor); + /* Stop upon reaching a boundary or the starting triangle. */ + while ((neighbor.tri != m->dummytri) && + (!otriequal(neighbor, testtri))) { + if (infected(neighbor)) { + /* Mark the corner of this triangle as having been tested. */ + setorg(neighbor, NULL); + } else { + /* A live triangle. The vertex survives. */ + killorg = 0; + } + /* Walk counterclockwise about the vertex. */ + onextself(neighbor); + } + /* If we reached a boundary, we must walk clockwise as well. */ + if (neighbor.tri == m->dummytri) { + /* Walk clockwise about the vertex. */ + oprev(testtri, neighbor); + /* Stop upon reaching a boundary. */ + while (neighbor.tri != m->dummytri) { + if (infected(neighbor)) { + /* Mark the corner of this triangle as having been tested. */ + setorg(neighbor, NULL); + } else { + /* A live triangle. The vertex survives. */ + killorg = 0; + } + /* Walk clockwise about the vertex. */ + oprevself(neighbor); + } + } + if (killorg) { + if (b->verbose > 1) { + printf(" Deleting vertex (%.12g, %.12g)\n", testvertex[0], + testvertex[1]); + } + setvertextype(testvertex, UNDEADVERTEX); + m->undeads++; + } + } + } + + /* Record changes in the number of boundary edges, and disconnect */ + /* dead triangles from their neighbors. */ + for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { + sym(testtri, neighbor); + if (neighbor.tri == m->dummytri) { + /* There is no neighboring triangle on this edge, so this edge */ + /* is a boundary edge. This triangle is being deleted, so this */ + /* boundary edge is deleted. */ + m->hullsize--; + } else { + /* Disconnect the triangle from its neighbor. */ + dissolve(neighbor); + /* There is a neighboring triangle on this edge, so this edge */ + /* becomes a boundary edge when this triangle is deleted. */ + m->hullsize++; + } + } + /* Return the dead triangle to the pool of triangles. */ + triangledealloc(m, testtri.tri); + virusloop = (triangle **)traverse(&m->viri); + } + /* Empty the virus pool. */ + poolrestart(&m->viri); +} + +/*****************************************************************************/ +/* */ +/* regionplague() Spread regional attributes and/or area constraints */ +/* (from a .poly file) throughout the mesh. */ +/* */ +/* This procedure operates in two phases. The first phase spreads an */ +/* attribute and/or an area constraint through a (segment-bounded) region. */ +/* The triangles are marked to ensure that each triangle is added to the */ +/* virus pool only once, so the procedure will terminate. */ +/* */ +/* The second phase uninfects all infected triangles, returning them to */ +/* normal. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void regionplague(struct mesh *m, struct behavior *b, REAL attribute, REAL area) +#else /* not ANSI_DECLARATORS */ +void regionplague(m, b, attribute, area) struct mesh *m; +struct behavior *b; +REAL attribute; +REAL area; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri testtri; + struct otri neighbor; + triangle **virusloop; + triangle **regiontri; + struct osub neighborsubseg; + vertex regionorg, regiondest, regionapex; + triangle ptr; /* Temporary variable used by sym() and onext(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + if (b->verbose > 1) { + printf(" Marking neighbors of marked triangles.\n"); + } + /* Loop through all the infected triangles, spreading the attribute */ + /* and/or area constraint to their neighbors, then to their neighbors' */ + /* neighbors. */ + traversalinit(&m->viri); + virusloop = (triangle **)traverse(&m->viri); + while (virusloop != (triangle **)NULL) { + testtri.tri = *virusloop; + /* A triangle is marked as infected by messing with one of its pointers */ + /* to subsegments, setting it to an illegal value. Hence, we have to */ + /* temporarily uninfect this triangle so that we can examine its */ + /* adjacent subsegments. */ + uninfect(testtri); + if (b->regionattrib) { + /* Set an attribute. */ + setelemattribute(testtri, m->eextras, attribute); + } + if (b->vararea) { + /* Set an area constraint. */ + setareabound(testtri, area); + } + if (b->verbose > 2) { + /* Assign the triangle an orientation for convenience in */ + /* checking its vertices. */ + testtri.orient = 0; + org(testtri, regionorg); + dest(testtri, regiondest); + apex(testtri, regionapex); + printf(" Checking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", + regionorg[0], regionorg[1], regiondest[0], regiondest[1], + regionapex[0], regionapex[1]); + } + /* Check each of the triangle's three neighbors. */ + for (testtri.orient = 0; testtri.orient < 3; testtri.orient++) { + /* Find the neighbor. */ + sym(testtri, neighbor); + /* Check for a subsegment between the triangle and its neighbor. */ + tspivot(testtri, neighborsubseg); + /* Make sure the neighbor exists, is not already infected, and */ + /* isn't protected by a subsegment. */ + if ((neighbor.tri != m->dummytri) && !infected(neighbor) && + (neighborsubseg.ss == m->dummysub)) { + if (b->verbose > 2) { + org(neighbor, regionorg); + dest(neighbor, regiondest); + apex(neighbor, regionapex); + printf(" Marking (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", + regionorg[0], regionorg[1], regiondest[0], regiondest[1], + regionapex[0], regionapex[1]); + } + /* Infect the neighbor. */ + infect(neighbor); + /* Ensure that the neighbor's neighbors will be infected. */ + regiontri = (triangle **)poolalloc(&m->viri); + *regiontri = neighbor.tri; + } + } + /* Remark the triangle as infected, so it doesn't get added to the */ + /* virus pool again. */ + infect(testtri); + virusloop = (triangle **)traverse(&m->viri); + } + + /* Uninfect all triangles. */ + if (b->verbose > 1) { + printf(" Unmarking marked triangles.\n"); + } + traversalinit(&m->viri); + virusloop = (triangle **)traverse(&m->viri); + while (virusloop != (triangle **)NULL) { + testtri.tri = *virusloop; + uninfect(testtri); + virusloop = (triangle **)traverse(&m->viri); + } + /* Empty the virus pool. */ + poolrestart(&m->viri); +} + +/*****************************************************************************/ +/* */ +/* carveholes() Find the holes and infect them. Find the area */ +/* constraints and infect them. Infect the convex hull. */ +/* Spread the infection and kill triangles. Spread the */ +/* area constraints. */ +/* */ +/* This routine mainly calls other routines to carry out all these */ +/* functions. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void carveholes(struct mesh *m, struct behavior *b, REAL *holelist, int holes, + REAL *regionlist, int regions) +#else /* not ANSI_DECLARATORS */ +void carveholes(m, b, holelist, holes, regionlist, regions) struct mesh *m; +struct behavior *b; +REAL *holelist; +int holes; +REAL *regionlist; +int regions; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri searchtri; + struct otri triangleloop; + struct otri *regiontris; + triangle **holetri; + triangle **regiontri; + vertex searchorg, searchdest; + enum locateresult intersect; + int i; + triangle ptr; /* Temporary variable used by sym(). */ + + if (!(b->quiet || (b->noholes && b->convex))) { + printf("Removing unwanted triangles.\n"); + if (b->verbose && (holes > 0)) { + printf(" Marking holes for elimination.\n"); + } + } + + if (regions > 0) { + /* Allocate storage for the triangles in which region points fall. */ + regiontris = (struct otri *)trimalloc(regions * (int)sizeof(struct otri)); + } else { + regiontris = (struct otri *)NULL; + } + + if (((holes > 0) && !b->noholes) || !b->convex || (regions > 0)) { + /* Initialize a pool of viri to be used for holes, concavities, */ + /* regional attributes, and/or regional area constraints. */ + poolinit(&m->viri, sizeof(triangle *), VIRUSPERBLOCK, VIRUSPERBLOCK, 0); + } + + if (!b->convex) { + /* Mark as infected any unprotected triangles on the boundary. */ + /* This is one way by which concavities are created. */ + infecthull(m, b); + } + + if ((holes > 0) && !b->noholes) { + /* Infect each triangle in which a hole lies. */ + for (i = 0; i < 2 * holes; i += 2) { + /* Ignore holes that aren't within the bounds of the mesh. */ + if ((holelist[i] >= m->xmin) && (holelist[i] <= m->xmax) && + (holelist[i + 1] >= m->ymin) && (holelist[i + 1] <= m->ymax)) { + /* Start searching from some triangle on the outer boundary. */ + searchtri.tri = m->dummytri; + searchtri.orient = 0; + symself(searchtri); + /* Ensure that the hole is to the left of this boundary edge; */ + /* otherwise, locate() will falsely report that the hole */ + /* falls within the starting triangle. */ + org(searchtri, searchorg); + dest(searchtri, searchdest); + if (counterclockwise(m, b, searchorg, searchdest, &holelist[i]) > 0.0) { + /* Find a triangle that contains the hole. */ + intersect = locate(m, b, &holelist[i], &searchtri); + if ((intersect != OUTSIDE) && (!infected(searchtri))) { + /* Infect the triangle. This is done by marking the triangle */ + /* as infected and including the triangle in the virus pool. */ + infect(searchtri); + holetri = (triangle **)poolalloc(&m->viri); + *holetri = searchtri.tri; + } + } + } + } + } + + /* Now, we have to find all the regions BEFORE we carve the holes, because */ + /* locate() won't work when the triangulation is no longer convex. */ + /* (Incidentally, this is the reason why regional attributes and area */ + /* constraints can't be used when refining a preexisting mesh, which */ + /* might not be convex; they can only be used with a freshly */ + /* triangulated PSLG.) */ + if (regions > 0) { + /* Find the starting triangle for each region. */ + for (i = 0; i < regions; i++) { + regiontris[i].tri = m->dummytri; + /* Ignore region points that aren't within the bounds of the mesh. */ + if ((regionlist[4 * i] >= m->xmin) && (regionlist[4 * i] <= m->xmax) && + (regionlist[4 * i + 1] >= m->ymin) && + (regionlist[4 * i + 1] <= m->ymax)) { + /* Start searching from some triangle on the outer boundary. */ + searchtri.tri = m->dummytri; + searchtri.orient = 0; + symself(searchtri); + /* Ensure that the region point is to the left of this boundary */ + /* edge; otherwise, locate() will falsely report that the */ + /* region point falls within the starting triangle. */ + org(searchtri, searchorg); + dest(searchtri, searchdest); + if (counterclockwise(m, b, searchorg, searchdest, ®ionlist[4 * i]) > + 0.0) { + /* Find a triangle that contains the region point. */ + intersect = locate(m, b, ®ionlist[4 * i], &searchtri); + if ((intersect != OUTSIDE) && (!infected(searchtri))) { + /* Record the triangle for processing after the */ + /* holes have been carved. */ + otricopy(searchtri, regiontris[i]); + } + } + } + } + } + + if (m->viri.items > 0) { + /* Carve the holes and concavities. */ + plague(m, b); + } + /* The virus pool should be empty now. */ + + if (regions > 0) { + if (!b->quiet) { + if (b->regionattrib) { + if (b->vararea) { + printf("Spreading regional attributes and area constraints.\n"); + } else { + printf("Spreading regional attributes.\n"); + } + } else { + printf("Spreading regional area constraints.\n"); + } + } + if (b->regionattrib && !b->refine) { + /* Assign every triangle a regional attribute of zero. */ + traversalinit(&m->triangles); + triangleloop.orient = 0; + triangleloop.tri = triangletraverse(m); + while (triangleloop.tri != (triangle *)NULL) { + setelemattribute(triangleloop, m->eextras, 0.0); + triangleloop.tri = triangletraverse(m); + } + } + for (i = 0; i < regions; i++) { + if (regiontris[i].tri != m->dummytri) { + /* Make sure the triangle under consideration still exists. */ + /* It may have been eaten by the virus. */ + if (!deadtri(regiontris[i].tri)) { + /* Put one triangle in the virus pool. */ + infect(regiontris[i]); + regiontri = (triangle **)poolalloc(&m->viri); + *regiontri = regiontris[i].tri; + /* Apply one region's attribute and/or area constraint. */ + regionplague(m, b, regionlist[4 * i + 2], regionlist[4 * i + 3]); + /* The virus pool should be empty now. */ + } + } + } + if (b->regionattrib && !b->refine) { + /* Note the fact that each triangle has an additional attribute. */ + m->eextras++; + } + } + + /* Free up memory. */ + if (((holes > 0) && !b->noholes) || !b->convex || (regions > 0)) { + pooldeinit(&m->viri); + } + if (regions > 0) { + trifree((VOID *)regiontris); + } +} + +/** **/ +/** **/ +/********* Carving out holes and concavities ends here *********/ + +/********* Mesh quality maintenance begins here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* tallyencs() Traverse the entire list of subsegments, and check each */ +/* to see if it is encroached. If so, add it to the list. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void tallyencs(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ + void tallyencs(m, b) struct mesh *m; + struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct osub subsegloop; + int dummy; + + traversalinit(&m->subsegs); + subsegloop.ssorient = 0; + subsegloop.ss = subsegtraverse(m); + while (subsegloop.ss != (subseg *)NULL) { + /* If the segment is encroached, add it to the list. */ + dummy = checkseg4encroach(m, b, &subsegloop); + subsegloop.ss = subsegtraverse(m); + } +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* precisionerror() Print an error message for precision problems. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +void precisionerror() { + printf("Try increasing the area criterion and/or reducing the minimum\n"); + printf(" allowable angle so that tiny triangles are not created.\n"); +#ifdef SINGLE + printf("Alternatively, try recompiling me with double precision\n"); + printf(" arithmetic (by removing \"#define SINGLE\" from the\n"); + printf(" source file or \"-DSINGLE\" from the makefile).\n"); +#endif /* SINGLE */ +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* splitencsegs() Split all the encroached subsegments. */ +/* */ +/* Each encroached subsegment is repaired by splitting it - inserting a */ +/* vertex at or near its midpoint. Newly inserted vertices may encroach */ +/* upon other subsegments; these are also repaired. */ +/* */ +/* `triflaws' is a flag that specifies whether one should take note of new */ +/* bad triangles that result from inserting vertices to repair encroached */ +/* subsegments. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void splitencsegs(struct mesh *m, struct behavior *b, int triflaws) +#else /* not ANSI_DECLARATORS */ + void splitencsegs(m, b, triflaws) struct mesh *m; + struct behavior *b; + int triflaws; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri enctri; + struct otri testtri; + struct osub testsh; + struct osub currentenc; + struct badsubseg *encloop; + vertex eorg, edest, eapex; + vertex newvertex; + enum insertvertexresult success; + REAL segmentlength, nearestpoweroftwo; + REAL split; + REAL multiplier, divisor; + int acuteorg, acuteorg2, acutedest, acutedest2; + int dummy; + int i; + triangle ptr; /* Temporary variable used by stpivot(). */ + subseg sptr; /* Temporary variable used by snext(). */ + + /* Note that steinerleft == -1 if an unlimited number */ + /* of Steiner points is allowed. */ + while ((m->badsubsegs.items > 0) && (m->steinerleft != 0)) { + traversalinit(&m->badsubsegs); + encloop = badsubsegtraverse(m); + while ((encloop != (struct badsubseg *)NULL) && (m->steinerleft != 0)) { + sdecode(encloop->encsubseg, currentenc); + sorg(currentenc, eorg); + sdest(currentenc, edest); + /* Make sure that this segment is still the same segment it was */ + /* when it was determined to be encroached. If the segment was */ + /* enqueued multiple times (because several newly inserted */ + /* vertices encroached it), it may have already been split. */ + if (!deadsubseg(currentenc.ss) && (eorg == encloop->subsegorg) && + (edest == encloop->subsegdest)) { + /* To decide where to split a segment, we need to know if the */ + /* segment shares an endpoint with an adjacent segment. */ + /* The concern is that, if we simply split every encroached */ + /* segment in its center, two adjacent segments with a small */ + /* angle between them might lead to an infinite loop; each */ + /* vertex added to split one segment will encroach upon the */ + /* other segment, which must then be split with a vertex that */ + /* will encroach upon the first segment, and so on forever. */ + /* To avoid this, imagine a set of concentric circles, whose */ + /* radii are powers of two, about each segment endpoint. */ + /* These concentric circles determine where the segment is */ + /* split. (If both endpoints are shared with adjacent */ + /* segments, split the segment in the middle, and apply the */ + /* concentric circles for later splittings.) */ + + /* Is the origin shared with another segment? */ + stpivot(currentenc, enctri); + lnext(enctri, testtri); + tspivot(testtri, testsh); + acuteorg = testsh.ss != m->dummysub; + /* Is the destination shared with another segment? */ + lnextself(testtri); + tspivot(testtri, testsh); + acutedest = testsh.ss != m->dummysub; + + /* If we're using Chew's algorithm (rather than Ruppert's) */ + /* to define encroachment, delete free vertices from the */ + /* subsegment's diametral circle. */ + if (!b->conformdel && !acuteorg && !acutedest) { + apex(enctri, eapex); + while ((vertextype(eapex) == FREEVERTEX) && + ((eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + + (eorg[1] - eapex[1]) * (edest[1] - eapex[1]) < + 0.0)) { + deletevertex(m, b, &testtri); + stpivot(currentenc, enctri); + apex(enctri, eapex); + lprev(enctri, testtri); + } + } + + /* Now, check the other side of the segment, if there's a triangle */ + /* there. */ + sym(enctri, testtri); + if (testtri.tri != m->dummytri) { + /* Is the destination shared with another segment? */ + lnextself(testtri); + tspivot(testtri, testsh); + acutedest2 = testsh.ss != m->dummysub; + acutedest = acutedest || acutedest2; + /* Is the origin shared with another segment? */ + lnextself(testtri); + tspivot(testtri, testsh); + acuteorg2 = testsh.ss != m->dummysub; + acuteorg = acuteorg || acuteorg2; + + /* Delete free vertices from the subsegment's diametral circle. */ + if (!b->conformdel && !acuteorg2 && !acutedest2) { + org(testtri, eapex); + while ((vertextype(eapex) == FREEVERTEX) && + ((eorg[0] - eapex[0]) * (edest[0] - eapex[0]) + + (eorg[1] - eapex[1]) * (edest[1] - eapex[1]) < + 0.0)) { + deletevertex(m, b, &testtri); + sym(enctri, testtri); + apex(testtri, eapex); + lprevself(testtri); + } + } + } + + /* Use the concentric circles if exactly one endpoint is shared */ + /* with another adjacent segment. */ + if (acuteorg || acutedest) { + segmentlength = sqrt((edest[0] - eorg[0]) * (edest[0] - eorg[0]) + + (edest[1] - eorg[1]) * (edest[1] - eorg[1])); + /* Find the power of two that most evenly splits the segment. */ + /* The worst case is a 2:1 ratio between subsegment lengths. */ + nearestpoweroftwo = 1.0; + while (segmentlength > 3.0 * nearestpoweroftwo) { + nearestpoweroftwo *= 2.0; + } + while (segmentlength < 1.5 * nearestpoweroftwo) { + nearestpoweroftwo *= 0.5; + } + /* Where do we split the segment? */ + split = nearestpoweroftwo / segmentlength; + if (acutedest) { + split = 1.0 - split; + } + } else { + /* If we're not worried about adjacent segments, split */ + /* this segment in the middle. */ + split = 0.5; + } + + /* Create the new vertex. */ + newvertex = (vertex)poolalloc(&m->vertices); + /* Interpolate its coordinate and attributes. */ + for (i = 0; i < 2 + m->nextras; i++) { + newvertex[i] = eorg[i] + split * (edest[i] - eorg[i]); + } + + if (!b->noexact) { + /* Roundoff in the above calculation may yield a `newvertex' */ + /* that is not precisely collinear with `eorg' and `edest'. */ + /* Improve collinearity by one step of iterative refinement. */ + multiplier = counterclockwise(m, b, eorg, edest, newvertex); + divisor = ((eorg[0] - edest[0]) * (eorg[0] - edest[0]) + + (eorg[1] - edest[1]) * (eorg[1] - edest[1])); + if ((multiplier != 0.0) && (divisor != 0.0)) { + multiplier = multiplier / divisor; + /* Watch out for NANs. */ + if (multiplier == multiplier) { + newvertex[0] += multiplier * (edest[1] - eorg[1]); + newvertex[1] += multiplier * (eorg[0] - edest[0]); + } + } + } + + setvertexmark(newvertex, mark(currentenc)); + setvertextype(newvertex, SEGMENTVERTEX); + if (b->verbose > 1) { + printf(" Splitting subsegment (%.12g, %.12g) (%.12g, %.12g) at " + "(%.12g, %.12g).\n", + eorg[0], eorg[1], edest[0], edest[1], newvertex[0], + newvertex[1]); + } + /* Check whether the new vertex lies on an endpoint. */ + if (((newvertex[0] == eorg[0]) && (newvertex[1] == eorg[1])) || + ((newvertex[0] == edest[0]) && (newvertex[1] == edest[1]))) { + printf("Error: Ran out of precision at (%.12g, %.12g).\n", + newvertex[0], newvertex[1]); + printf("I attempted to split a segment to a smaller size than\n"); + printf(" can be accommodated by the finite precision of\n"); + printf(" floating point arithmetic.\n"); + precisionerror(); + triexit(1); + } + /* Insert the splitting vertex. This should always succeed. */ + success = + insertvertex(m, b, newvertex, &enctri, ¤tenc, 1, triflaws); + if ((success != SUCCESSFULVERTEX) && (success != ENCROACHINGVERTEX)) { + printf("Internal error in splitencsegs():\n"); + printf(" Failure to split a segment.\n"); + internalerror(); + } + if (m->steinerleft > 0) { + m->steinerleft--; + } + /* Check the two new subsegments to see if they're encroached. */ + dummy = checkseg4encroach(m, b, ¤tenc); + snextself(currentenc); + dummy = checkseg4encroach(m, b, ¤tenc); + } + + badsubsegdealloc(m, encloop); + encloop = badsubsegtraverse(m); + } + } +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* tallyfaces() Test every triangle in the mesh for quality measures. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void tallyfaces(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ + void tallyfaces(m, b) struct mesh *m; + struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri triangleloop; + + if (b->verbose) { + printf(" Making a list of bad triangles.\n"); + } + traversalinit(&m->triangles); + triangleloop.orient = 0; + triangleloop.tri = triangletraverse(m); + while (triangleloop.tri != (triangle *)NULL) { + /* If the triangle is bad, enqueue it. */ + testtriangle(m, b, &triangleloop); + triangleloop.tri = triangletraverse(m); + } +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* splittriangle() Inserts a vertex at the circumcenter of a triangle. */ +/* Deletes the newly inserted vertex if it encroaches */ +/* upon a segment. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void splittriangle(struct mesh *m, struct behavior *b, struct badtriang *badtri) +#else /* not ANSI_DECLARATORS */ + void splittriangle(m, b, badtri) struct mesh *m; + struct behavior *b; + struct badtriang *badtri; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri badotri; + vertex borg, bdest, bapex; + vertex newvertex; + REAL xi, eta; + enum insertvertexresult success; + int errorflag; + int i; + + decode(badtri->poortri, badotri); + org(badotri, borg); + dest(badotri, bdest); + apex(badotri, bapex); + /* Make sure that this triangle is still the same triangle it was */ + /* when it was tested and determined to be of bad quality. */ + /* Subsequent transformations may have made it a different triangle. */ + if (!deadtri(badotri.tri) && (borg == badtri->triangorg) && + (bdest == badtri->triangdest) && (bapex == badtri->triangapex)) { + if (b->verbose > 1) { + printf(" Splitting this triangle at its circumcenter:\n"); + printf(" (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", borg[0], + borg[1], bdest[0], bdest[1], bapex[0], bapex[1]); + } + + errorflag = 0; + /* Create a new vertex at the triangle's circumcenter. */ + newvertex = (vertex)poolalloc(&m->vertices); + findcircumcenter(m, b, borg, bdest, bapex, newvertex, &xi, &eta, 1); + + /* Check whether the new vertex lies on a triangle vertex. */ + if (((newvertex[0] == borg[0]) && (newvertex[1] == borg[1])) || + ((newvertex[0] == bdest[0]) && (newvertex[1] == bdest[1])) || + ((newvertex[0] == bapex[0]) && (newvertex[1] == bapex[1]))) { + if (!b->quiet) { + printf( + "Warning: New vertex (%.12g, %.12g) falls on existing vertex.\n", + newvertex[0], newvertex[1]); + errorflag = 1; + } + vertexdealloc(m, newvertex); + } else { + for (i = 2; i < 2 + m->nextras; i++) { + /* Interpolate the vertex attributes at the circumcenter. */ + newvertex[i] = + borg[i] + xi * (bdest[i] - borg[i]) + eta * (bapex[i] - borg[i]); + } + /* The new vertex must be in the interior, and therefore is a */ + /* free vertex with a marker of zero. */ + setvertexmark(newvertex, 0); + setvertextype(newvertex, FREEVERTEX); + + /* Ensure that the handle `badotri' does not represent the longest */ + /* edge of the triangle. This ensures that the circumcenter must */ + /* fall to the left of this edge, so point location will work. */ + /* (If the angle org-apex-dest exceeds 90 degrees, then the */ + /* circumcenter lies outside the org-dest edge, and eta is */ + /* negative. Roundoff error might prevent eta from being */ + /* negative when it should be, so I test eta against xi.) */ + if (eta < xi) { + lprevself(badotri); + } + + /* Insert the circumcenter, searching from the edge of the triangle, */ + /* and maintain the Delaunay property of the triangulation. */ + success = + insertvertex(m, b, newvertex, &badotri, (struct osub *)NULL, 1, 1); + if (success == SUCCESSFULVERTEX) { + if (m->steinerleft > 0) { + m->steinerleft--; + } + } else if (success == ENCROACHINGVERTEX) { + /* If the newly inserted vertex encroaches upon a subsegment, */ + /* delete the new vertex. */ + undovertex(m, b); + if (b->verbose > 1) { + printf(" Rejecting (%.12g, %.12g).\n", newvertex[0], newvertex[1]); + } + vertexdealloc(m, newvertex); + } else if (success == VIOLATINGVERTEX) { + /* Failed to insert the new vertex, but some subsegment was */ + /* marked as being encroached. */ + vertexdealloc(m, newvertex); + } else { /* success == DUPLICATEVERTEX */ + /* Couldn't insert the new vertex because a vertex is already there. */ + if (!b->quiet) { + printf( + "Warning: New vertex (%.12g, %.12g) falls on existing vertex.\n", + newvertex[0], newvertex[1]); + errorflag = 1; + } + vertexdealloc(m, newvertex); + } + } + if (errorflag) { + if (b->verbose) { + printf(" The new vertex is at the circumcenter of triangle\n"); + printf(" (%.12g, %.12g) (%.12g, %.12g) (%.12g, %.12g)\n", borg[0], + borg[1], bdest[0], bdest[1], bapex[0], bapex[1]); + } + printf("This probably means that I am trying to refine triangles\n"); + printf(" to a smaller size than can be accommodated by the finite\n"); + printf(" precision of floating point arithmetic. (You can be\n"); + printf(" sure of this if I fail to terminate.)\n"); + precisionerror(); + } + } +} + +#endif /* not CDT_ONLY */ + +/*****************************************************************************/ +/* */ +/* enforcequality() Remove all the encroached subsegments and bad */ +/* triangles from the triangulation. */ +/* */ +/*****************************************************************************/ + +#ifndef CDT_ONLY + +#ifdef ANSI_DECLARATORS +void enforcequality(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ + void enforcequality(m, b) struct mesh *m; + struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct badtriang *badtri; + int i; + + if (!b->quiet) { + printf("Adding Steiner points to enforce quality.\n"); + } + /* Initialize the pool of encroached subsegments. */ + poolinit(&m->badsubsegs, sizeof(struct badsubseg), BADSUBSEGPERBLOCK, + BADSUBSEGPERBLOCK, 0); + if (b->verbose) { + printf(" Looking for encroached subsegments.\n"); + } + /* Test all segments to see if they're encroached. */ + tallyencs(m, b); + if (b->verbose && (m->badsubsegs.items > 0)) { + printf(" Splitting encroached subsegments.\n"); + } + /* Fix encroached subsegments without noting bad triangles. */ + splitencsegs(m, b, 0); + /* At this point, if we haven't run out of Steiner points, the */ + /* triangulation should be (conforming) Delaunay. */ + + /* Next, we worry about enforcing triangle quality. */ + if ((b->minangle > 0.0) || b->vararea || b->fixedarea || b->usertest) { + /* Initialize the pool of bad triangles. */ + poolinit(&m->badtriangles, sizeof(struct badtriang), BADTRIPERBLOCK, + BADTRIPERBLOCK, 0); + /* Initialize the queues of bad triangles. */ + for (i = 0; i < 4096; i++) { + m->queuefront[i] = (struct badtriang *)NULL; + } + m->firstnonemptyq = -1; + /* Test all triangles to see if they're bad. */ + tallyfaces(m, b); + /* Initialize the pool of recently flipped triangles. */ + poolinit(&m->flipstackers, sizeof(struct flipstacker), FLIPSTACKERPERBLOCK, + FLIPSTACKERPERBLOCK, 0); + m->checkquality = 1; + if (b->verbose) { + printf(" Splitting bad triangles.\n"); + } + while ((m->badtriangles.items > 0) && (m->steinerleft != 0)) { + /* Fix one bad triangle by inserting a vertex at its circumcenter. */ + badtri = dequeuebadtriang(m); + splittriangle(m, b, badtri); + if (m->badsubsegs.items > 0) { + /* Put bad triangle back in queue for another try later. */ + enqueuebadtriang(m, b, badtri); + /* Fix any encroached subsegments that resulted. */ + /* Record any new bad triangles that result. */ + splitencsegs(m, b, 1); + } else { + /* Return the bad triangle to the pool. */ + pooldealloc(&m->badtriangles, (VOID *)badtri); + } + } + } + /* At this point, if the "-D" switch was selected and we haven't run out */ + /* of Steiner points, the triangulation should be (conforming) Delaunay */ + /* and have no low-quality triangles. */ + + /* Might we have run out of Steiner points too soon? */ + if (!b->quiet && b->conformdel && (m->badsubsegs.items > 0) && + (m->steinerleft == 0)) { + printf("\nWarning: I ran out of Steiner points, but the mesh has\n"); + if (m->badsubsegs.items == 1) { + printf(" one encroached subsegment, and therefore might not be truly\n"); + } else { + printf(" %ld encroached subsegments, and therefore might not be truly\n", + m->badsubsegs.items); + } + printf(" Delaunay. If the Delaunay property is important to you,\n"); + printf(" try increasing the number of Steiner points (controlled by\n"); + printf(" the -S switch) slightly and try again.\n\n"); + } +} + +#endif /* not CDT_ONLY */ + +/** **/ +/** **/ +/********* Mesh quality maintenance ends here *********/ + +/*****************************************************************************/ +/* */ +/* highorder() Create extra nodes for quadratic subparametric elements. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void highorder(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void highorder(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri triangleloop, trisym; + struct osub checkmark; + vertex newvertex; + vertex torg, tdest; + int i; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + + if (!b->quiet) { + printf("Adding vertices for second-order triangles.\n"); + } + /* The following line ensures that dead items in the pool of nodes */ + /* cannot be allocated for the extra nodes associated with high */ + /* order elements. This ensures that the primary nodes (at the */ + /* corners of elements) will occur earlier in the output files, and */ + /* have lower indices, than the extra nodes. */ + m->vertices.deaditemstack = (VOID *)NULL; + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + /* To loop over the set of edges, loop over all triangles, and look at */ + /* the three edges of each triangle. If there isn't another triangle */ + /* adjacent to the edge, operate on the edge. If there is another */ + /* adjacent triangle, operate on the edge only if the current triangle */ + /* has a smaller pointer than its neighbor. This way, each edge is */ + /* considered only once. */ + while (triangleloop.tri != (triangle *)NULL) { + for (triangleloop.orient = 0; triangleloop.orient < 3; + triangleloop.orient++) { + sym(triangleloop, trisym); + if ((triangleloop.tri < trisym.tri) || (trisym.tri == m->dummytri)) { + org(triangleloop, torg); + dest(triangleloop, tdest); + /* Create a new node in the middle of the edge. Interpolate */ + /* its attributes. */ + newvertex = (vertex)poolalloc(&m->vertices); + for (i = 0; i < 2 + m->nextras; i++) { + newvertex[i] = 0.5 * (torg[i] + tdest[i]); + } + /* Set the new node's marker to zero or one, depending on */ + /* whether it lies on a boundary. */ + setvertexmark(newvertex, trisym.tri == m->dummytri); + setvertextype(newvertex, + trisym.tri == m->dummytri ? FREEVERTEX : SEGMENTVERTEX); + if (b->usesegments) { + tspivot(triangleloop, checkmark); + /* If this edge is a segment, transfer the marker to the new node. */ + if (checkmark.ss != m->dummysub) { + setvertexmark(newvertex, mark(checkmark)); + setvertextype(newvertex, SEGMENTVERTEX); + } + } + if (b->verbose > 1) { + printf(" Creating (%.12g, %.12g).\n", newvertex[0], newvertex[1]); + } + /* Record the new node in the (one or two) adjacent elements. */ + triangleloop.tri[m->highorderindex + triangleloop.orient] = + (triangle)newvertex; + if (trisym.tri != m->dummytri) { + trisym.tri[m->highorderindex + trisym.orient] = (triangle)newvertex; + } + } + } + triangleloop.tri = triangletraverse(m); + } +} + +/********* File I/O routines begin here *********/ +/** **/ +/** **/ + +/*****************************************************************************/ +/* */ +/* readline() Read a nonempty line from a file. */ +/* */ +/* A line is considered "nonempty" if it contains something that looks like */ +/* a number. Comments (prefaced by `#') are ignored. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +#ifdef ANSI_DECLARATORS +char *readline(char *string, FILE *infile, char *infilename) +#else /* not ANSI_DECLARATORS */ + char *readline(string, infile, infilename) char *string; + FILE *infile; + char *infilename; +#endif /* not ANSI_DECLARATORS */ + +{ + char *result; + + /* Search for something that looks like a number. */ + do { + result = fgets(string, INPUTLINESIZE, infile); + if (result == (char *)NULL) { + printf(" Error: Unexpected end of file in %s.\n", infilename); + triexit(1); + } + /* Skip anything that doesn't look like a number, a comment, */ + /* or the end of a line. */ + while ((*result != '\0') && (*result != '#') && (*result != '.') && + (*result != '+') && (*result != '-') && + ((*result < '0') || (*result > '9'))) { + result++; + } + /* If it's a comment or end of line, read another line and try again. */ + } while ((*result == '#') || (*result == '\0')); + return result; +} + +#endif /* not TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* findfield() Find the next field of a string. */ +/* */ +/* Jumps past the current field by searching for whitespace, then jumps */ +/* past the whitespace to find the next field. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +#ifdef ANSI_DECLARATORS +char *findfield(char *string) +#else /* not ANSI_DECLARATORS */ + char *findfield(string) char *string; +#endif /* not ANSI_DECLARATORS */ + +{ + char *result; + + result = string; + /* Skip the current field. Stop upon reaching whitespace. */ + while ((*result != '\0') && (*result != '#') && (*result != ' ') && + (*result != '\t')) { + result++; + } + /* Now skip the whitespace and anything else that doesn't look like a */ + /* number, a comment, or the end of a line. */ + while ((*result != '\0') && (*result != '#') && (*result != '.') && + (*result != '+') && (*result != '-') && + ((*result < '0') || (*result > '9'))) { + result++; + } + /* Check for a comment (prefixed with `#'). */ + if (*result == '#') { + *result = '\0'; + } + return result; +} + +#endif /* not TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* readnodes() Read the vertices from a file, which may be a .node or */ +/* .poly file. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void readnodes(struct mesh *m, struct behavior *b, char *nodefilename, + char *polyfilename, FILE **polyfile) +#else /* not ANSI_DECLARATORS */ + void readnodes(m, b, nodefilename, polyfilename, polyfile) struct mesh *m; + struct behavior *b; + char *nodefilename; + char *polyfilename; + FILE **polyfile; +#endif /* not ANSI_DECLARATORS */ + +{ + FILE *infile; + vertex vertexloop; + char inputline[INPUTLINESIZE]; + char *stringptr; + char *infilename; + REAL x, y; + int firstnode; + int nodemarkers; + int currentmarker; + int i, j; + + if (b->poly) { + /* Read the vertices from a .poly file. */ + if (!b->quiet) { + printf("Opening %s.\n", polyfilename); + } + *polyfile = fopen(polyfilename, "r"); + if (*polyfile == (FILE *)NULL) { + printf(" Error: Cannot access file %s.\n", polyfilename); + triexit(1); + } + /* Read number of vertices, number of dimensions, number of vertex */ + /* attributes, and number of boundary markers. */ + stringptr = readline(inputline, *polyfile, polyfilename); + m->invertices = (int)strtol(stringptr, &stringptr, 0); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + m->mesh_dim = 2; + } else { + m->mesh_dim = (int)strtol(stringptr, &stringptr, 0); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + m->nextras = 0; + } else { + m->nextras = (int)strtol(stringptr, &stringptr, 0); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + nodemarkers = 0; + } else { + nodemarkers = (int)strtol(stringptr, &stringptr, 0); + } + if (m->invertices > 0) { + infile = *polyfile; + infilename = polyfilename; + m->readnodefile = 0; + } else { + /* If the .poly file claims there are zero vertices, that means that */ + /* the vertices should be read from a separate .node file. */ + m->readnodefile = 1; + infilename = nodefilename; + } + } else { + m->readnodefile = 1; + infilename = nodefilename; + *polyfile = (FILE *)NULL; + } + + if (m->readnodefile) { + /* Read the vertices from a .node file. */ + if (!b->quiet) { + printf("Opening %s.\n", nodefilename); + } + infile = fopen(nodefilename, "r"); + if (infile == (FILE *)NULL) { + printf(" Error: Cannot access file %s.\n", nodefilename); + triexit(1); + } + /* Read number of vertices, number of dimensions, number of vertex */ + /* attributes, and number of boundary markers. */ + stringptr = readline(inputline, infile, nodefilename); + m->invertices = (int)strtol(stringptr, &stringptr, 0); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + m->mesh_dim = 2; + } else { + m->mesh_dim = (int)strtol(stringptr, &stringptr, 0); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + m->nextras = 0; + } else { + m->nextras = (int)strtol(stringptr, &stringptr, 0); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + nodemarkers = 0; + } else { + nodemarkers = (int)strtol(stringptr, &stringptr, 0); + } + } + + if (m->invertices < 3) { + printf("Error: Input must have at least three input vertices.\n"); + triexit(1); + } + if (m->mesh_dim != 2) { + printf("Error: Triangle only works with two-dimensional meshes.\n"); + triexit(1); + } + if (m->nextras == 0) { + b->weighted = 0; + } + + initializevertexpool(m, b); + + /* Read the vertices. */ + for (i = 0; i < m->invertices; i++) { + vertexloop = (vertex)poolalloc(&m->vertices); + stringptr = readline(inputline, infile, infilename); + if (i == 0) { + firstnode = (int)strtol(stringptr, &stringptr, 0); + if ((firstnode == 0) || (firstnode == 1)) { + b->firstnumber = firstnode; + } + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Vertex %d has no x coordinate.\n", b->firstnumber + i); + triexit(1); + } + x = (REAL)strtod(stringptr, &stringptr); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Vertex %d has no y coordinate.\n", b->firstnumber + i); + triexit(1); + } + y = (REAL)strtod(stringptr, &stringptr); + vertexloop[0] = x; + vertexloop[1] = y; + /* Read the vertex attributes. */ + for (j = 2; j < 2 + m->nextras; j++) { + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + vertexloop[j] = 0.0; + } else { + vertexloop[j] = (REAL)strtod(stringptr, &stringptr); + } + } + if (nodemarkers) { + /* Read a vertex marker. */ + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + setvertexmark(vertexloop, 0); + } else { + currentmarker = (int)strtol(stringptr, &stringptr, 0); + setvertexmark(vertexloop, currentmarker); + } + } else { + /* If no markers are specified in the file, they default to zero. */ + setvertexmark(vertexloop, 0); + } + setvertextype(vertexloop, INPUTVERTEX); + /* Determine the smallest and largest x and y coordinates. */ + if (i == 0) { + m->xmin = m->xmax = x; + m->ymin = m->ymax = y; + } else { + m->xmin = (x < m->xmin) ? x : m->xmin; + m->xmax = (x > m->xmax) ? x : m->xmax; + m->ymin = (y < m->ymin) ? y : m->ymin; + m->ymax = (y > m->ymax) ? y : m->ymax; + } + } + if (m->readnodefile) { + fclose(infile); + } + + /* Nonexistent x value used as a flag to mark circle events in sweepline */ + /* Delaunay algorithm. */ + m->xminextreme = 10 * m->xmin - 9 * m->xmax; +} + +#endif /* not TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* transfernodes() Read the vertices from memory. */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void transfernodes(struct mesh *m, struct behavior *b, REAL *pointlist, + REAL *pointattriblist, int *pointmarkerlist, + int numberofpoints, int numberofpointattribs) +#else /* not ANSI_DECLARATORS */ + void transfernodes(m, b, pointlist, pointattriblist, pointmarkerlist, + numberofpoints, numberofpointattribs) struct mesh *m; + struct behavior *b; + REAL *pointlist; + REAL *pointattriblist; + int *pointmarkerlist; + int numberofpoints; + int numberofpointattribs; +#endif /* not ANSI_DECLARATORS */ + +{ + vertex vertexloop; + REAL x, y; + int i, j; + int coordindex; + int attribindex; + + m->invertices = numberofpoints; + m->mesh_dim = 2; + m->nextras = numberofpointattribs; + m->readnodefile = 0; + if (m->invertices < 3) { + printf("Error: Input must have at least three input vertices.\n"); + triexit(1); + } + if (m->nextras == 0) { + b->weighted = 0; + } + + initializevertexpool(m, b); + + /* Read the vertices. */ + coordindex = 0; + attribindex = 0; + for (i = 0; i < m->invertices; i++) { + vertexloop = (vertex)poolalloc(&m->vertices); + /* Read the vertex coordinates. */ + x = vertexloop[0] = pointlist[coordindex++]; + y = vertexloop[1] = pointlist[coordindex++]; + /* Read the vertex attributes. */ + for (j = 0; j < numberofpointattribs; j++) { + vertexloop[2 + j] = pointattriblist[attribindex++]; + } + if (pointmarkerlist != (int *)NULL) { + /* Read a vertex marker. */ + setvertexmark(vertexloop, pointmarkerlist[i]); + } else { + /* If no markers are specified, they default to zero. */ + setvertexmark(vertexloop, 0); + } + setvertextype(vertexloop, INPUTVERTEX); + /* Determine the smallest and largest x and y coordinates. */ + if (i == 0) { + m->xmin = m->xmax = x; + m->ymin = m->ymax = y; + } else { + m->xmin = (x < m->xmin) ? x : m->xmin; + m->xmax = (x > m->xmax) ? x : m->xmax; + m->ymin = (y < m->ymin) ? y : m->ymin; + m->ymax = (y > m->ymax) ? y : m->ymax; + } + } + + /* Nonexistent x value used as a flag to mark circle events in sweepline */ + /* Delaunay algorithm. */ + m->xminextreme = 10 * m->xmin - 9 * m->xmax; +} + +#endif /* TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* readholes() Read the holes, and possibly regional attributes and area */ +/* constraints, from a .poly file. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void readholes(struct mesh *m, struct behavior *b, FILE *polyfile, + char *polyfilename, REAL **hlist, int *holes, REAL **rlist, + int *regions) +#else /* not ANSI_DECLARATORS */ + void readholes(m, b, polyfile, polyfilename, hlist, holes, rlist, + regions) struct mesh *m; + struct behavior *b; + FILE *polyfile; + char *polyfilename; + REAL **hlist; + int *holes; + REAL **rlist; + int *regions; +#endif /* not ANSI_DECLARATORS */ + +{ + REAL *holelist; + REAL *regionlist; + char inputline[INPUTLINESIZE]; + char *stringptr; + int index; + int i; + + /* Read the holes. */ + stringptr = readline(inputline, polyfile, polyfilename); + *holes = (int)strtol(stringptr, &stringptr, 0); + if (*holes > 0) { + holelist = (REAL *)trimalloc(2 * *holes * (int)sizeof(REAL)); + *hlist = holelist; + for (i = 0; i < 2 * *holes; i += 2) { + stringptr = readline(inputline, polyfile, polyfilename); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Hole %d has no x coordinate.\n", + b->firstnumber + (i >> 1)); + triexit(1); + } else { + holelist[i] = (REAL)strtod(stringptr, &stringptr); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Hole %d has no y coordinate.\n", + b->firstnumber + (i >> 1)); + triexit(1); + } else { + holelist[i + 1] = (REAL)strtod(stringptr, &stringptr); + } + } + } else { + *hlist = (REAL *)NULL; + } + +#ifndef CDT_ONLY + if ((b->regionattrib || b->vararea) && !b->refine) { + /* Read the area constraints. */ + stringptr = readline(inputline, polyfile, polyfilename); + *regions = (int)strtol(stringptr, &stringptr, 0); + if (*regions > 0) { + regionlist = (REAL *)trimalloc(4 * *regions * (int)sizeof(REAL)); + *rlist = regionlist; + index = 0; + for (i = 0; i < *regions; i++) { + stringptr = readline(inputline, polyfile, polyfilename); + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Region %d has no x coordinate.\n", + b->firstnumber + i); + triexit(1); + } else { + regionlist[index++] = (REAL)strtod(stringptr, &stringptr); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf("Error: Region %d has no y coordinate.\n", + b->firstnumber + i); + triexit(1); + } else { + regionlist[index++] = (REAL)strtod(stringptr, &stringptr); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + printf( + "Error: Region %d has no region attribute or area constraint.\n", + b->firstnumber + i); + triexit(1); + } else { + regionlist[index++] = (REAL)strtod(stringptr, &stringptr); + } + stringptr = findfield(stringptr); + if (*stringptr == '\0') { + regionlist[index] = regionlist[index - 1]; + } else { + regionlist[index] = (REAL)strtod(stringptr, &stringptr); + } + index++; + } + } + } else { + /* Set `*regions' to zero to avoid an accidental free() later. */ + *regions = 0; + *rlist = (REAL *)NULL; + } +#endif /* not CDT_ONLY */ + + fclose(polyfile); +} + +#endif /* not TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* finishfile() Write the command line to the output file so the user */ +/* can remember how the file was generated. Close the file. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void finishfile(FILE *outfile, int argc, char **argv) +#else /* not ANSI_DECLARATORS */ + void finishfile(outfile, argc, argv) FILE *outfile; + int argc; + char **argv; +#endif /* not ANSI_DECLARATORS */ + +{ + int i; + + fprintf(outfile, "# Generated by"); + for (i = 0; i < argc; i++) { + fprintf(outfile, " "); + fputs(argv[i], outfile); + } + fprintf(outfile, "\n"); + fclose(outfile); +} + +#endif /* not TRILIBRARY */ + +/*****************************************************************************/ +/* */ +/* writenodes() Number the vertices and write them to a .node file. */ +/* */ +/* To save memory, the vertex numbers are written over the boundary markers */ +/* after the vertices are written to a file. */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void writenodes(struct mesh *m, struct behavior *b, REAL **pointlist, + REAL **pointattriblist, int **pointmarkerlist) +#else /* not ANSI_DECLARATORS */ + void writenodes(m, b, pointlist, pointattriblist, + pointmarkerlist) struct mesh *m; + struct behavior *b; + REAL **pointlist; + REAL **pointattriblist; + int **pointmarkerlist; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +void writenodes(struct mesh *m, struct behavior *b, char *nodefilename, + int argc, char **argv) +#else /* not ANSI_DECLARATORS */ +void writenodes(m, b, nodefilename, argc, argv) struct mesh *m; +struct behavior *b; +char *nodefilename; +int argc; +char **argv; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + REAL *plist; + REAL *palist; + int *pmlist; + int coordindex; + int attribindex; +#else /* not TRILIBRARY */ + FILE *outfile; +#endif /* not TRILIBRARY */ + vertex vertexloop; + long outvertices; + int vertexnumber; + int i; + + if (b->jettison) { + outvertices = m->vertices.items - m->undeads; + } else { + outvertices = m->vertices.items; + } + +#ifdef TRILIBRARY + if (!b->quiet) { + printf("Writing vertices.\n"); + } + /* Allocate memory for output vertices if necessary. */ + if (*pointlist == (REAL *)NULL) { + *pointlist = (REAL *)trimalloc((int)(outvertices * 2 * sizeof(REAL))); + } + /* Allocate memory for output vertex attributes if necessary. */ + if ((m->nextras > 0) && (*pointattriblist == (REAL *)NULL)) { + *pointattriblist = + (REAL *)trimalloc((int)(outvertices * m->nextras * sizeof(REAL))); + } + /* Allocate memory for output vertex markers if necessary. */ + if (!b->nobound && (*pointmarkerlist == (int *)NULL)) { + *pointmarkerlist = (int *)trimalloc((int)(outvertices * sizeof(int))); + } + plist = *pointlist; + palist = *pointattriblist; + pmlist = *pointmarkerlist; + coordindex = 0; + attribindex = 0; +#else /* not TRILIBRARY */ + if (!b->quiet) { + printf("Writing %s.\n", nodefilename); + } + outfile = fopen(nodefilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", nodefilename); + triexit(1); + } + /* Number of vertices, number of dimensions, number of vertex attributes, */ + /* and number of boundary markers (zero or one). */ + fprintf(outfile, "%ld %d %d %d\n", outvertices, m->mesh_dim, m->nextras, + 1 - b->nobound); +#endif /* not TRILIBRARY */ + + traversalinit(&m->vertices); + vertexnumber = b->firstnumber; + vertexloop = vertextraverse(m); + while (vertexloop != (vertex)NULL) { + if (!b->jettison || (vertextype(vertexloop) != UNDEADVERTEX)) { +#ifdef TRILIBRARY + /* X and y coordinates. */ + plist[coordindex++] = vertexloop[0]; + plist[coordindex++] = vertexloop[1]; + /* Vertex attributes. */ + for (i = 0; i < m->nextras; i++) { + palist[attribindex++] = vertexloop[2 + i]; + } + if (!b->nobound) { + /* Copy the boundary marker. */ + pmlist[vertexnumber - b->firstnumber] = vertexmark(vertexloop); + } +#else /* not TRILIBRARY */ + /* Vertex number, x and y coordinates. */ + fprintf(outfile, "%4d %.17g %.17g", vertexnumber, vertexloop[0], + vertexloop[1]); + for (i = 0; i < m->nextras; i++) { + /* Write an attribute. */ + fprintf(outfile, " %.17g", vertexloop[i + 2]); + } + if (b->nobound) { + fprintf(outfile, "\n"); + } else { + /* Write the boundary marker. */ + fprintf(outfile, " %d\n", vertexmark(vertexloop)); + } +#endif /* not TRILIBRARY */ + + setvertexmark(vertexloop, vertexnumber); + vertexnumber++; + } + vertexloop = vertextraverse(m); + } + +#ifndef TRILIBRARY + finishfile(outfile, argc, argv); +#endif /* not TRILIBRARY */ +} + +/*****************************************************************************/ +/* */ +/* numbernodes() Number the vertices. */ +/* */ +/* Each vertex is assigned a marker equal to its number. */ +/* */ +/* Used when writenodes() is not called because no .node file is written. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void numbernodes(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void numbernodes(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + vertex vertexloop; + int vertexnumber; + + traversalinit(&m->vertices); + vertexnumber = b->firstnumber; + vertexloop = vertextraverse(m); + while (vertexloop != (vertex)NULL) { + setvertexmark(vertexloop, vertexnumber); + if (!b->jettison || (vertextype(vertexloop) != UNDEADVERTEX)) { + vertexnumber++; + } + vertexloop = vertextraverse(m); + } +} + +/*****************************************************************************/ +/* */ +/* writeelements() Write the triangles to an .ele file. */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void writeelements(struct mesh *m, struct behavior *b, int **trianglelist, + REAL **triangleattriblist) +#else /* not ANSI_DECLARATORS */ + void writeelements(m, b, trianglelist, triangleattriblist) struct mesh *m; + struct behavior *b; + int **trianglelist; + REAL **triangleattriblist; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +void writeelements(struct mesh *m, struct behavior *b, char *elefilename, + int argc, char **argv) +#else /* not ANSI_DECLARATORS */ +void writeelements(m, b, elefilename, argc, argv) struct mesh *m; +struct behavior *b; +char *elefilename; +int argc; +char **argv; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + int *tlist; + REAL *talist; + int vertexindex; + int attribindex; +#else /* not TRILIBRARY */ + FILE *outfile; +#endif /* not TRILIBRARY */ + struct otri triangleloop; + vertex p1, p2, p3; + vertex mid1, mid2, mid3; + long elementnumber; + int i; + +#ifdef TRILIBRARY + if (!b->quiet) { + printf("Writing triangles.\n"); + } + /* Allocate memory for output triangles if necessary. */ + if (*trianglelist == (int *)NULL) { + *trianglelist = (int *)trimalloc( + (int)(m->triangles.items * ((b->order + 1) * (b->order + 2) / 2) * + sizeof(int))); + } + /* Allocate memory for output triangle attributes if necessary. */ + if ((m->eextras > 0) && (*triangleattriblist == (REAL *)NULL)) { + *triangleattriblist = (REAL *)trimalloc( + (int)(m->triangles.items * m->eextras * sizeof(REAL))); + } + tlist = *trianglelist; + talist = *triangleattriblist; + vertexindex = 0; + attribindex = 0; +#else /* not TRILIBRARY */ + if (!b->quiet) { + printf("Writing %s.\n", elefilename); + } + outfile = fopen(elefilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", elefilename); + triexit(1); + } + /* Number of triangles, vertices per triangle, attributes per triangle. */ + fprintf(outfile, "%ld %d %d\n", m->triangles.items, + (b->order + 1) * (b->order + 2) / 2, m->eextras); +#endif /* not TRILIBRARY */ + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + triangleloop.orient = 0; + elementnumber = b->firstnumber; + while (triangleloop.tri != (triangle *)NULL) { + org(triangleloop, p1); + dest(triangleloop, p2); + apex(triangleloop, p3); + if (b->order == 1) { +#ifdef TRILIBRARY + tlist[vertexindex++] = vertexmark(p1); + tlist[vertexindex++] = vertexmark(p2); + tlist[vertexindex++] = vertexmark(p3); +#else /* not TRILIBRARY */ + /* Triangle number, indices for three vertices. */ + fprintf(outfile, "%4ld %4d %4d %4d", elementnumber, vertexmark(p1), + vertexmark(p2), vertexmark(p3)); +#endif /* not TRILIBRARY */ + } else { + mid1 = (vertex)triangleloop.tri[m->highorderindex + 1]; + mid2 = (vertex)triangleloop.tri[m->highorderindex + 2]; + mid3 = (vertex)triangleloop.tri[m->highorderindex]; +#ifdef TRILIBRARY + tlist[vertexindex++] = vertexmark(p1); + tlist[vertexindex++] = vertexmark(p2); + tlist[vertexindex++] = vertexmark(p3); + tlist[vertexindex++] = vertexmark(mid1); + tlist[vertexindex++] = vertexmark(mid2); + tlist[vertexindex++] = vertexmark(mid3); +#else /* not TRILIBRARY */ + /* Triangle number, indices for six vertices. */ + fprintf(outfile, "%4ld %4d %4d %4d %4d %4d %4d", elementnumber, + vertexmark(p1), vertexmark(p2), vertexmark(p3), vertexmark(mid1), + vertexmark(mid2), vertexmark(mid3)); +#endif /* not TRILIBRARY */ + } + +#ifdef TRILIBRARY + for (i = 0; i < m->eextras; i++) { + talist[attribindex++] = elemattribute(triangleloop, i); + } +#else /* not TRILIBRARY */ + for (i = 0; i < m->eextras; i++) { + fprintf(outfile, " %.17g", elemattribute(triangleloop, i)); + } + fprintf(outfile, "\n"); +#endif /* not TRILIBRARY */ + + triangleloop.tri = triangletraverse(m); + elementnumber++; + } + +#ifndef TRILIBRARY + finishfile(outfile, argc, argv); +#endif /* not TRILIBRARY */ +} + +/*****************************************************************************/ +/* */ +/* writepoly() Write the segments and holes to a .poly file. */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void writepoly(struct mesh *m, struct behavior *b, int **segmentlist, + int **segmentmarkerlist) +#else /* not ANSI_DECLARATORS */ + void writepoly(m, b, segmentlist, segmentmarkerlist) struct mesh *m; + struct behavior *b; + int **segmentlist; + int **segmentmarkerlist; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +void writepoly(struct mesh *m, struct behavior *b, char *polyfilename, + REAL *holelist, int holes, REAL *regionlist, int regions, + int argc, char **argv) +#else /* not ANSI_DECLARATORS */ +void writepoly(m, b, polyfilename, holelist, holes, regionlist, regions, argc, + argv) struct mesh *m; +struct behavior *b; +char *polyfilename; +REAL *holelist; +int holes; +REAL *regionlist; +int regions; +int argc; +char **argv; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + int *slist; + int *smlist; + int index; +#else /* not TRILIBRARY */ + FILE *outfile; + long holenumber, regionnumber; +#endif /* not TRILIBRARY */ + struct osub subsegloop; + vertex endpoint1, endpoint2; + long subsegnumber; + +#ifdef TRILIBRARY + if (!b->quiet) { + printf("Writing segments.\n"); + } + /* Allocate memory for output segments if necessary. */ + if (*segmentlist == (int *)NULL) { + *segmentlist = (int *)trimalloc((int)(m->subsegs.items * 2 * sizeof(int))); + } + /* Allocate memory for output segment markers if necessary. */ + if (!b->nobound && (*segmentmarkerlist == (int *)NULL)) { + *segmentmarkerlist = + (int *)trimalloc((int)(m->subsegs.items * sizeof(int))); + } + slist = *segmentlist; + smlist = *segmentmarkerlist; + index = 0; +#else /* not TRILIBRARY */ + if (!b->quiet) { + printf("Writing %s.\n", polyfilename); + } + outfile = fopen(polyfilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", polyfilename); + triexit(1); + } + /* The zero indicates that the vertices are in a separate .node file. */ + /* Followed by number of dimensions, number of vertex attributes, */ + /* and number of boundary markers (zero or one). */ + fprintf(outfile, "%d %d %d %d\n", 0, m->mesh_dim, m->nextras, + 1 - b->nobound); + /* Number of segments, number of boundary markers (zero or one). */ + fprintf(outfile, "%ld %d\n", m->subsegs.items, 1 - b->nobound); +#endif /* not TRILIBRARY */ + + traversalinit(&m->subsegs); + subsegloop.ss = subsegtraverse(m); + subsegloop.ssorient = 0; + subsegnumber = b->firstnumber; + while (subsegloop.ss != (subseg *)NULL) { + sorg(subsegloop, endpoint1); + sdest(subsegloop, endpoint2); +#ifdef TRILIBRARY + /* Copy indices of the segment's two endpoints. */ + slist[index++] = vertexmark(endpoint1); + slist[index++] = vertexmark(endpoint2); + if (!b->nobound) { + /* Copy the boundary marker. */ + smlist[subsegnumber - b->firstnumber] = mark(subsegloop); + } +#else /* not TRILIBRARY */ + /* Segment number, indices of its two endpoints, and possibly a marker. */ + if (b->nobound) { + fprintf(outfile, "%4ld %4d %4d\n", subsegnumber, + vertexmark(endpoint1), vertexmark(endpoint2)); + } else { + fprintf(outfile, "%4ld %4d %4d %4d\n", subsegnumber, + vertexmark(endpoint1), vertexmark(endpoint2), mark(subsegloop)); + } +#endif /* not TRILIBRARY */ + + subsegloop.ss = subsegtraverse(m); + subsegnumber++; + } + +#ifndef TRILIBRARY +#ifndef CDT_ONLY + fprintf(outfile, "%d\n", holes); + if (holes > 0) { + for (holenumber = 0; holenumber < holes; holenumber++) { + /* Hole number, x and y coordinates. */ + fprintf(outfile, "%4ld %.17g %.17g\n", b->firstnumber + holenumber, + holelist[2 * holenumber], holelist[2 * holenumber + 1]); + } + } + if (regions > 0) { + fprintf(outfile, "%d\n", regions); + for (regionnumber = 0; regionnumber < regions; regionnumber++) { + /* Region number, x and y coordinates, attribute, maximum area. */ + fprintf(outfile, "%4ld %.17g %.17g %.17g %.17g\n", + b->firstnumber + regionnumber, regionlist[4 * regionnumber], + regionlist[4 * regionnumber + 1], + regionlist[4 * regionnumber + 2], + regionlist[4 * regionnumber + 3]); + } + } +#endif /* not CDT_ONLY */ + + finishfile(outfile, argc, argv); +#endif /* not TRILIBRARY */ +} + +/*****************************************************************************/ +/* */ +/* writeedges() Write the edges to an .edge file. */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void writeedges(struct mesh *m, struct behavior *b, int **edgelist, + int **edgemarkerlist) +#else /* not ANSI_DECLARATORS */ + void writeedges(m, b, edgelist, edgemarkerlist) struct mesh *m; + struct behavior *b; + int **edgelist; + int **edgemarkerlist; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +void writeedges(struct mesh *m, struct behavior *b, char *edgefilename, + int argc, char **argv) +#else /* not ANSI_DECLARATORS */ +void writeedges(m, b, edgefilename, argc, argv) struct mesh *m; +struct behavior *b; +char *edgefilename; +int argc; +char **argv; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + int *elist; + int *emlist; + int index; +#else /* not TRILIBRARY */ + FILE *outfile; +#endif /* not TRILIBRARY */ + struct otri triangleloop, trisym; + struct osub checkmark; + vertex p1, p2; + long edgenumber; + triangle ptr; /* Temporary variable used by sym(). */ + subseg sptr; /* Temporary variable used by tspivot(). */ + +#ifdef TRILIBRARY + if (!b->quiet) { + printf("Writing edges.\n"); + } + /* Allocate memory for edges if necessary. */ + if (*edgelist == (int *)NULL) { + *edgelist = (int *)trimalloc((int)(m->edges * 2 * sizeof(int))); + } + /* Allocate memory for edge markers if necessary. */ + if (!b->nobound && (*edgemarkerlist == (int *)NULL)) { + *edgemarkerlist = (int *)trimalloc((int)(m->edges * sizeof(int))); + } + elist = *edgelist; + emlist = *edgemarkerlist; + index = 0; +#else /* not TRILIBRARY */ + if (!b->quiet) { + printf("Writing %s.\n", edgefilename); + } + outfile = fopen(edgefilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", edgefilename); + triexit(1); + } + /* Number of edges, number of boundary markers (zero or one). */ + fprintf(outfile, "%ld %d\n", m->edges, 1 - b->nobound); +#endif /* not TRILIBRARY */ + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + edgenumber = b->firstnumber; + /* To loop over the set of edges, loop over all triangles, and look at */ + /* the three edges of each triangle. If there isn't another triangle */ + /* adjacent to the edge, operate on the edge. If there is another */ + /* adjacent triangle, operate on the edge only if the current triangle */ + /* has a smaller pointer than its neighbor. This way, each edge is */ + /* considered only once. */ + while (triangleloop.tri != (triangle *)NULL) { + for (triangleloop.orient = 0; triangleloop.orient < 3; + triangleloop.orient++) { + sym(triangleloop, trisym); + if ((triangleloop.tri < trisym.tri) || (trisym.tri == m->dummytri)) { + org(triangleloop, p1); + dest(triangleloop, p2); +#ifdef TRILIBRARY + elist[index++] = vertexmark(p1); + elist[index++] = vertexmark(p2); +#endif /* TRILIBRARY */ + if (b->nobound) { +#ifndef TRILIBRARY + /* Edge number, indices of two endpoints. */ + fprintf(outfile, "%4ld %d %d\n", edgenumber, vertexmark(p1), + vertexmark(p2)); +#endif /* not TRILIBRARY */ + } else { + /* Edge number, indices of two endpoints, and a boundary marker. */ + /* If there's no subsegment, the boundary marker is zero. */ + if (b->usesegments) { + tspivot(triangleloop, checkmark); + if (checkmark.ss == m->dummysub) { +#ifdef TRILIBRARY + emlist[edgenumber - b->firstnumber] = 0; +#else /* not TRILIBRARY */ + fprintf(outfile, "%4ld %d %d %d\n", edgenumber, + vertexmark(p1), vertexmark(p2), 0); +#endif /* not TRILIBRARY */ + } else { +#ifdef TRILIBRARY + emlist[edgenumber - b->firstnumber] = mark(checkmark); +#else /* not TRILIBRARY */ + fprintf(outfile, "%4ld %d %d %d\n", edgenumber, + vertexmark(p1), vertexmark(p2), mark(checkmark)); +#endif /* not TRILIBRARY */ + } + } else { +#ifdef TRILIBRARY + emlist[edgenumber - b->firstnumber] = trisym.tri == m->dummytri; +#else /* not TRILIBRARY */ + fprintf(outfile, "%4ld %d %d %d\n", edgenumber, vertexmark(p1), + vertexmark(p2), trisym.tri == m->dummytri); +#endif /* not TRILIBRARY */ + } + } + edgenumber++; + } + } + triangleloop.tri = triangletraverse(m); + } + +#ifndef TRILIBRARY + finishfile(outfile, argc, argv); +#endif /* not TRILIBRARY */ +} + +/*****************************************************************************/ +/* */ +/* writevoronoi() Write the Voronoi diagram to a .v.node and .v.edge */ +/* file. */ +/* */ +/* The Voronoi diagram is the geometric dual of the Delaunay triangulation. */ +/* Hence, the Voronoi vertices are listed by traversing the Delaunay */ +/* triangles, and the Voronoi edges are listed by traversing the Delaunay */ +/* edges. */ +/* */ +/* WARNING: In order to assign numbers to the Voronoi vertices, this */ +/* procedure messes up the subsegments or the extra nodes of every */ +/* element. Hence, you should call this procedure last. */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void writevoronoi(struct mesh *m, struct behavior *b, REAL **vpointlist, + REAL **vpointattriblist, int **vpointmarkerlist, + int **vedgelist, int **vedgemarkerlist, REAL **vnormlist) +#else /* not ANSI_DECLARATORS */ + void writevoronoi(m, b, vpointlist, vpointattriblist, vpointmarkerlist, + vedgelist, vedgemarkerlist, vnormlist) struct mesh *m; + struct behavior *b; + REAL **vpointlist; + REAL **vpointattriblist; + int **vpointmarkerlist; + int **vedgelist; + int **vedgemarkerlist; + REAL **vnormlist; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +void writevoronoi(struct mesh *m, struct behavior *b, char *vnodefilename, + char *vedgefilename, int argc, char **argv) +#else /* not ANSI_DECLARATORS */ +void writevoronoi(m, b, vnodefilename, vedgefilename, argc, + argv) struct mesh *m; +struct behavior *b; +char *vnodefilename; +char *vedgefilename; +int argc; +char **argv; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + REAL *plist; + REAL *palist; + int *elist; + REAL *normlist; + int coordindex; + int attribindex; +#else /* not TRILIBRARY */ + FILE *outfile; +#endif /* not TRILIBRARY */ + struct otri triangleloop, trisym; + vertex torg, tdest, tapex; + REAL circumcenter[2]; + REAL xi, eta; + long vnodenumber, vedgenumber; + int p1, p2; + int i; + triangle ptr; /* Temporary variable used by sym(). */ + +#ifdef TRILIBRARY + if (!b->quiet) { + printf("Writing Voronoi vertices.\n"); + } + /* Allocate memory for Voronoi vertices if necessary. */ + if (*vpointlist == (REAL *)NULL) { + *vpointlist = + (REAL *)trimalloc((int)(m->triangles.items * 2 * sizeof(REAL))); + } + /* Allocate memory for Voronoi vertex attributes if necessary. */ + if (*vpointattriblist == (REAL *)NULL) { + *vpointattriblist = (REAL *)trimalloc( + (int)(m->triangles.items * m->nextras * sizeof(REAL))); + } + *vpointmarkerlist = (int *)NULL; + plist = *vpointlist; + palist = *vpointattriblist; + coordindex = 0; + attribindex = 0; +#else /* not TRILIBRARY */ + if (!b->quiet) { + printf("Writing %s.\n", vnodefilename); + } + outfile = fopen(vnodefilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", vnodefilename); + triexit(1); + } + /* Number of triangles, two dimensions, number of vertex attributes, */ + /* no markers. */ + fprintf(outfile, "%ld %d %d %d\n", m->triangles.items, 2, m->nextras, 0); +#endif /* not TRILIBRARY */ + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + triangleloop.orient = 0; + vnodenumber = b->firstnumber; + while (triangleloop.tri != (triangle *)NULL) { + org(triangleloop, torg); + dest(triangleloop, tdest); + apex(triangleloop, tapex); + findcircumcenter(m, b, torg, tdest, tapex, circumcenter, &xi, &eta, 0); +#ifdef TRILIBRARY + /* X and y coordinates. */ + plist[coordindex++] = circumcenter[0]; + plist[coordindex++] = circumcenter[1]; + for (i = 2; i < 2 + m->nextras; i++) { + /* Interpolate the vertex attributes at the circumcenter. */ + palist[attribindex++] = + torg[i] + xi * (tdest[i] - torg[i]) + eta * (tapex[i] - torg[i]); + } +#else /* not TRILIBRARY */ + /* Voronoi vertex number, x and y coordinates. */ + fprintf(outfile, "%4ld %.17g %.17g", vnodenumber, circumcenter[0], + circumcenter[1]); + for (i = 2; i < 2 + m->nextras; i++) { + /* Interpolate the vertex attributes at the circumcenter. */ + fprintf(outfile, " %.17g", + torg[i] + xi * (tdest[i] - torg[i]) + eta * (tapex[i] - torg[i])); + } + fprintf(outfile, "\n"); +#endif /* not TRILIBRARY */ + + *(int *)(triangleloop.tri + 6) = (int)vnodenumber; + triangleloop.tri = triangletraverse(m); + vnodenumber++; + } + +#ifndef TRILIBRARY + finishfile(outfile, argc, argv); +#endif /* not TRILIBRARY */ + +#ifdef TRILIBRARY + if (!b->quiet) { + printf("Writing Voronoi edges.\n"); + } + /* Allocate memory for output Voronoi edges if necessary. */ + if (*vedgelist == (int *)NULL) { + *vedgelist = (int *)trimalloc((int)(m->edges * 2 * sizeof(int))); + } + *vedgemarkerlist = (int *)NULL; + /* Allocate memory for output Voronoi norms if necessary. */ + if (*vnormlist == (REAL *)NULL) { + *vnormlist = (REAL *)trimalloc((int)(m->edges * 2 * sizeof(REAL))); + } + elist = *vedgelist; + normlist = *vnormlist; + coordindex = 0; +#else /* not TRILIBRARY */ + if (!b->quiet) { + printf("Writing %s.\n", vedgefilename); + } + outfile = fopen(vedgefilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", vedgefilename); + triexit(1); + } + /* Number of edges, zero boundary markers. */ + fprintf(outfile, "%ld %d\n", m->edges, 0); +#endif /* not TRILIBRARY */ + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + vedgenumber = b->firstnumber; + /* To loop over the set of edges, loop over all triangles, and look at */ + /* the three edges of each triangle. If there isn't another triangle */ + /* adjacent to the edge, operate on the edge. If there is another */ + /* adjacent triangle, operate on the edge only if the current triangle */ + /* has a smaller pointer than its neighbor. This way, each edge is */ + /* considered only once. */ + while (triangleloop.tri != (triangle *)NULL) { + for (triangleloop.orient = 0; triangleloop.orient < 3; + triangleloop.orient++) { + sym(triangleloop, trisym); + if ((triangleloop.tri < trisym.tri) || (trisym.tri == m->dummytri)) { + /* Find the number of this triangle (and Voronoi vertex). */ + p1 = *(int *)(triangleloop.tri + 6); + if (trisym.tri == m->dummytri) { + org(triangleloop, torg); + dest(triangleloop, tdest); +#ifdef TRILIBRARY + /* Copy an infinite ray. Index of one endpoint, and -1. */ + elist[coordindex] = p1; + normlist[coordindex++] = tdest[1] - torg[1]; + elist[coordindex] = -1; + normlist[coordindex++] = torg[0] - tdest[0]; +#else /* not TRILIBRARY */ + /* Write an infinite ray. Edge number, index of one endpoint, -1, */ + /* and x and y coordinates of a vector representing the */ + /* direction of the ray. */ + fprintf(outfile, "%4ld %d %d %.17g %.17g\n", vedgenumber, p1, + -1, tdest[1] - torg[1], torg[0] - tdest[0]); +#endif /* not TRILIBRARY */ + } else { + /* Find the number of the adjacent triangle (and Voronoi vertex). */ + p2 = *(int *)(trisym.tri + 6); + /* Finite edge. Write indices of two endpoints. */ +#ifdef TRILIBRARY + elist[coordindex] = p1; + normlist[coordindex++] = 0.0; + elist[coordindex] = p2; + normlist[coordindex++] = 0.0; +#else /* not TRILIBRARY */ + fprintf(outfile, "%4ld %d %d\n", vedgenumber, p1, p2); +#endif /* not TRILIBRARY */ + } + vedgenumber++; + } + } + triangleloop.tri = triangletraverse(m); + } + +#ifndef TRILIBRARY + finishfile(outfile, argc, argv); +#endif /* not TRILIBRARY */ +} + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void writeneighbors(struct mesh *m, struct behavior *b, int **neighborlist) +#else /* not ANSI_DECLARATORS */ + void writeneighbors(m, b, neighborlist) struct mesh *m; + struct behavior *b; + int **neighborlist; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +void writeneighbors(struct mesh *m, struct behavior *b, char *neighborfilename, + int argc, char **argv) +#else /* not ANSI_DECLARATORS */ +void writeneighbors(m, b, neighborfilename, argc, argv) struct mesh *m; +struct behavior *b; +char *neighborfilename; +int argc; +char **argv; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ +#ifdef TRILIBRARY + int *nlist; + int index; +#else /* not TRILIBRARY */ + FILE *outfile; +#endif /* not TRILIBRARY */ + struct otri triangleloop, trisym; + long elementnumber; + int neighbor1, neighbor2, neighbor3; + triangle ptr; /* Temporary variable used by sym(). */ + +#ifdef TRILIBRARY + if (!b->quiet) { + printf("Writing neighbors.\n"); + } + /* Allocate memory for neighbors if necessary. */ + if (*neighborlist == (int *)NULL) { + *neighborlist = + (int *)trimalloc((int)(m->triangles.items * 3 * sizeof(int))); + } + nlist = *neighborlist; + index = 0; +#else /* not TRILIBRARY */ + if (!b->quiet) { + printf("Writing %s.\n", neighborfilename); + } + outfile = fopen(neighborfilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", neighborfilename); + triexit(1); + } + /* Number of triangles, three neighbors per triangle. */ + fprintf(outfile, "%ld %d\n", m->triangles.items, 3); +#endif /* not TRILIBRARY */ + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + triangleloop.orient = 0; + elementnumber = b->firstnumber; + while (triangleloop.tri != (triangle *)NULL) { + *(int *)(triangleloop.tri + 6) = (int)elementnumber; + triangleloop.tri = triangletraverse(m); + elementnumber++; + } + *(int *)(m->dummytri + 6) = -1; + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + elementnumber = b->firstnumber; + while (triangleloop.tri != (triangle *)NULL) { + triangleloop.orient = 1; + sym(triangleloop, trisym); + neighbor1 = *(int *)(trisym.tri + 6); + triangleloop.orient = 2; + sym(triangleloop, trisym); + neighbor2 = *(int *)(trisym.tri + 6); + triangleloop.orient = 0; + sym(triangleloop, trisym); + neighbor3 = *(int *)(trisym.tri + 6); +#ifdef TRILIBRARY + nlist[index++] = neighbor1; + nlist[index++] = neighbor2; + nlist[index++] = neighbor3; +#else /* not TRILIBRARY */ + /* Triangle number, neighboring triangle numbers. */ + fprintf(outfile, "%4ld %d %d %d\n", elementnumber, neighbor1, + neighbor2, neighbor3); +#endif /* not TRILIBRARY */ + + triangleloop.tri = triangletraverse(m); + elementnumber++; + } + +#ifndef TRILIBRARY + finishfile(outfile, argc, argv); +#endif /* not TRILIBRARY */ +} + +/*****************************************************************************/ +/* */ +/* writeoff() Write the triangulation to an .off file. */ +/* */ +/* OFF stands for the Object File Format, a format used by the Geometry */ +/* Center's Geomview package. */ +/* */ +/*****************************************************************************/ + +#ifndef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void writeoff(struct mesh *m, struct behavior *b, char *offfilename, int argc, + char **argv) +#else /* not ANSI_DECLARATORS */ + void writeoff(m, b, offfilename, argc, argv) struct mesh *m; + struct behavior *b; + char *offfilename; + int argc; + char **argv; +#endif /* not ANSI_DECLARATORS */ + +{ + FILE *outfile; + struct otri triangleloop; + vertex vertexloop; + vertex p1, p2, p3; + long outvertices; + + if (!b->quiet) { + printf("Writing %s.\n", offfilename); + } + + if (b->jettison) { + outvertices = m->vertices.items - m->undeads; + } else { + outvertices = m->vertices.items; + } + + outfile = fopen(offfilename, "w"); + if (outfile == (FILE *)NULL) { + printf(" Error: Cannot create file %s.\n", offfilename); + triexit(1); + } + /* Number of vertices, triangles, and edges. */ + fprintf(outfile, "OFF\n%ld %ld %ld\n", outvertices, m->triangles.items, + m->edges); + + /* Write the vertices. */ + traversalinit(&m->vertices); + vertexloop = vertextraverse(m); + while (vertexloop != (vertex)NULL) { + if (!b->jettison || (vertextype(vertexloop) != UNDEADVERTEX)) { + /* The "0.0" is here because the OFF format uses 3D coordinates. */ + fprintf(outfile, " %.17g %.17g %.17g\n", vertexloop[0], vertexloop[1], + 0.0); + } + vertexloop = vertextraverse(m); + } + + /* Write the triangles. */ + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + triangleloop.orient = 0; + while (triangleloop.tri != (triangle *)NULL) { + org(triangleloop, p1); + dest(triangleloop, p2); + apex(triangleloop, p3); + /* The "3" means a three-vertex polygon. */ + fprintf(outfile, " 3 %4d %4d %4d\n", vertexmark(p1) - b->firstnumber, + vertexmark(p2) - b->firstnumber, vertexmark(p3) - b->firstnumber); + triangleloop.tri = triangletraverse(m); + } + finishfile(outfile, argc, argv); +} + +#endif /* not TRILIBRARY */ + +/** **/ +/** **/ +/********* File I/O routines end here *********/ + +/*****************************************************************************/ +/* */ +/* quality_statistics() Print statistics about the quality of the mesh. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void quality_statistics(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void quality_statistics(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + struct otri triangleloop; + vertex p[3]; + REAL cossquaretable[8]; + REAL ratiotable[16]; + REAL dx[3], dy[3]; + REAL edgelength[3]; + REAL dotproduct; + REAL cossquare; + REAL triarea; + REAL shortest, longest; + REAL trilongest2; + REAL smallestarea, biggestarea; + REAL triminaltitude2; + REAL minaltitude; + REAL triaspect2; + REAL worstaspect; + REAL smallestangle, biggestangle; + REAL radconst, degconst; + int angletable[18]; + int aspecttable[16]; + int aspectindex; + int tendegree; + int acutebiggest; + int i, ii, j, k; + + printf("Mesh quality statistics:\n\n"); + radconst = PI / 18.0; + degconst = 180.0 / PI; + for (i = 0; i < 8; i++) { + cossquaretable[i] = cos(radconst * (REAL)(i + 1)); + cossquaretable[i] = cossquaretable[i] * cossquaretable[i]; + } + for (i = 0; i < 18; i++) { + angletable[i] = 0; + } + + ratiotable[0] = 1.5; + ratiotable[1] = 2.0; + ratiotable[2] = 2.5; + ratiotable[3] = 3.0; + ratiotable[4] = 4.0; + ratiotable[5] = 6.0; + ratiotable[6] = 10.0; + ratiotable[7] = 15.0; + ratiotable[8] = 25.0; + ratiotable[9] = 50.0; + ratiotable[10] = 100.0; + ratiotable[11] = 300.0; + ratiotable[12] = 1000.0; + ratiotable[13] = 10000.0; + ratiotable[14] = 100000.0; + ratiotable[15] = 0.0; + for (i = 0; i < 16; i++) { + aspecttable[i] = 0; + } + + worstaspect = 0.0; + minaltitude = m->xmax - m->xmin + m->ymax - m->ymin; + minaltitude = minaltitude * minaltitude; + shortest = minaltitude; + longest = 0.0; + smallestarea = minaltitude; + biggestarea = 0.0; + worstaspect = 0.0; + smallestangle = 0.0; + biggestangle = 2.0; + acutebiggest = 1; + + traversalinit(&m->triangles); + triangleloop.tri = triangletraverse(m); + triangleloop.orient = 0; + while (triangleloop.tri != (triangle *)NULL) { + org(triangleloop, p[0]); + dest(triangleloop, p[1]); + apex(triangleloop, p[2]); + trilongest2 = 0.0; + + for (i = 0; i < 3; i++) { + j = plus1mod3[i]; + k = minus1mod3[i]; + dx[i] = p[j][0] - p[k][0]; + dy[i] = p[j][1] - p[k][1]; + edgelength[i] = dx[i] * dx[i] + dy[i] * dy[i]; + if (edgelength[i] > trilongest2) { + trilongest2 = edgelength[i]; + } + if (edgelength[i] > longest) { + longest = edgelength[i]; + } + if (edgelength[i] < shortest) { + shortest = edgelength[i]; + } + } + + triarea = counterclockwise(m, b, p[0], p[1], p[2]); + if (triarea < smallestarea) { + smallestarea = triarea; + } + if (triarea > biggestarea) { + biggestarea = triarea; + } + triminaltitude2 = triarea * triarea / trilongest2; + if (triminaltitude2 < minaltitude) { + minaltitude = triminaltitude2; + } + triaspect2 = trilongest2 / triminaltitude2; + if (triaspect2 > worstaspect) { + worstaspect = triaspect2; + } + aspectindex = 0; + while ((triaspect2 > ratiotable[aspectindex] * ratiotable[aspectindex]) && + (aspectindex < 15)) { + aspectindex++; + } + aspecttable[aspectindex]++; + + for (i = 0; i < 3; i++) { + j = plus1mod3[i]; + k = minus1mod3[i]; + dotproduct = dx[j] * dx[k] + dy[j] * dy[k]; + cossquare = dotproduct * dotproduct / (edgelength[j] * edgelength[k]); + tendegree = 8; + for (ii = 7; ii >= 0; ii--) { + if (cossquare > cossquaretable[ii]) { + tendegree = ii; + } + } + if (dotproduct <= 0.0) { + angletable[tendegree]++; + if (cossquare > smallestangle) { + smallestangle = cossquare; + } + if (acutebiggest && (cossquare < biggestangle)) { + biggestangle = cossquare; + } + } else { + angletable[17 - tendegree]++; + if (acutebiggest || (cossquare > biggestangle)) { + biggestangle = cossquare; + acutebiggest = 0; + } + } + } + triangleloop.tri = triangletraverse(m); + } + + shortest = sqrt(shortest); + longest = sqrt(longest); + minaltitude = sqrt(minaltitude); + worstaspect = sqrt(worstaspect); + smallestarea *= 0.5; + biggestarea *= 0.5; + if (smallestangle >= 1.0) { + smallestangle = 0.0; + } else { + smallestangle = degconst * acos(sqrt(smallestangle)); + } + if (biggestangle >= 1.0) { + biggestangle = 180.0; + } else { + if (acutebiggest) { + biggestangle = degconst * acos(sqrt(biggestangle)); + } else { + biggestangle = 180.0 - degconst * acos(sqrt(biggestangle)); + } + } + + printf(" Smallest area: %16.5g | Largest area: %16.5g\n", smallestarea, + biggestarea); + printf(" Shortest edge: %16.5g | Longest edge: %16.5g\n", shortest, + longest); + printf(" Shortest altitude: %12.5g | Largest aspect ratio: %8.5g\n\n", + minaltitude, worstaspect); + + printf(" Triangle aspect ratio histogram:\n"); + printf(" 1.1547 - %-6.6g : %8d | %6.6g - %-6.6g : %8d\n", + ratiotable[0], aspecttable[0], ratiotable[7], ratiotable[8], + aspecttable[8]); + for (i = 1; i < 7; i++) { + printf(" %6.6g - %-6.6g : %8d | %6.6g - %-6.6g : %8d\n", + ratiotable[i - 1], ratiotable[i], aspecttable[i], ratiotable[i + 7], + ratiotable[i + 8], aspecttable[i + 8]); + } + printf(" %6.6g - %-6.6g : %8d | %6.6g - : %8d\n", + ratiotable[6], ratiotable[7], aspecttable[7], ratiotable[14], + aspecttable[15]); + printf(" (Aspect ratio is longest edge divided by shortest altitude)\n\n"); + + printf(" Smallest angle: %15.5g | Largest angle: %15.5g\n\n", + smallestangle, biggestangle); + + printf(" Angle histogram:\n"); + for (i = 0; i < 9; i++) { + printf(" %3d - %3d degrees: %8d | %3d - %3d degrees: %8d\n", + i * 10, i * 10 + 10, angletable[i], i * 10 + 90, i * 10 + 100, + angletable[i + 9]); + } + printf("\n"); +} + +/*****************************************************************************/ +/* */ +/* statistics() Print all sorts of cool facts. */ +/* */ +/*****************************************************************************/ + +#ifdef ANSI_DECLARATORS +void statistics(struct mesh *m, struct behavior *b) +#else /* not ANSI_DECLARATORS */ +void statistics(m, b) struct mesh *m; +struct behavior *b; +#endif /* not ANSI_DECLARATORS */ + +{ + printf("\nStatistics:\n\n"); + printf(" Input vertices: %d\n", m->invertices); + if (b->refine) { + printf(" Input triangles: %d\n", m->inelements); + } + if (b->poly) { + printf(" Input segments: %d\n", m->insegments); + if (!b->refine) { + printf(" Input holes: %d\n", m->holes); + } + } + + printf("\n Mesh vertices: %ld\n", m->vertices.items - m->undeads); + printf(" Mesh triangles: %ld\n", m->triangles.items); + printf(" Mesh edges: %ld\n", m->edges); + printf(" Mesh exterior boundary edges: %ld\n", m->hullsize); + if (b->poly || b->refine) { + printf(" Mesh interior boundary edges: %ld\n", + m->subsegs.items - m->hullsize); + printf(" Mesh subsegments (constrained edges): %ld\n", m->subsegs.items); + } + printf("\n"); + + if (b->verbose) { + quality_statistics(m, b); + printf("Memory allocation statistics:\n\n"); + printf(" Maximum number of vertices: %ld\n", m->vertices.maxitems); + printf(" Maximum number of triangles: %ld\n", m->triangles.maxitems); + if (m->subsegs.maxitems > 0) { + printf(" Maximum number of subsegments: %ld\n", m->subsegs.maxitems); + } + if (m->viri.maxitems > 0) { + printf(" Maximum number of viri: %ld\n", m->viri.maxitems); + } + if (m->badsubsegs.maxitems > 0) { + printf(" Maximum number of encroached subsegments: %ld\n", + m->badsubsegs.maxitems); + } + if (m->badtriangles.maxitems > 0) { + printf(" Maximum number of bad triangles: %ld\n", + m->badtriangles.maxitems); + } + if (m->flipstackers.maxitems > 0) { + printf(" Maximum number of stacked triangle flips: %ld\n", + m->flipstackers.maxitems); + } + if (m->splaynodes.maxitems > 0) { + printf(" Maximum number of splay tree nodes: %ld\n", + m->splaynodes.maxitems); + } + printf(" Approximate heap memory use (bytes): %ld\n\n", + m->vertices.maxitems * m->vertices.itembytes + + m->triangles.maxitems * m->triangles.itembytes + + m->subsegs.maxitems * m->subsegs.itembytes + + m->viri.maxitems * m->viri.itembytes + + m->badsubsegs.maxitems * m->badsubsegs.itembytes + + m->badtriangles.maxitems * m->badtriangles.itembytes + + m->flipstackers.maxitems * m->flipstackers.itembytes + + m->splaynodes.maxitems * m->splaynodes.itembytes); + + printf("Algorithmic statistics:\n\n"); + if (!b->weighted) { + printf(" Number of incircle tests: %ld\n", m->incirclecount); + } else { + printf(" Number of 3D orientation tests: %ld\n", m->orient3dcount); + } + printf(" Number of 2D orientation tests: %ld\n", m->counterclockcount); + if (m->hyperbolacount > 0) { + printf(" Number of right-of-hyperbola tests: %ld\n", m->hyperbolacount); + } + if (m->circletopcount > 0) { + printf(" Number of circle top computations: %ld\n", m->circletopcount); + } + if (m->circumcentercount > 0) { + printf(" Number of triangle circumcenter computations: %ld\n", + m->circumcentercount); + } + printf("\n"); + } +} + +/*****************************************************************************/ +/* */ +/* main() or triangulate() Gosh, do everything. */ +/* */ +/* The sequence is roughly as follows. Many of these steps can be skipped, */ +/* depending on the command line switches. */ +/* */ +/* - Initialize constants and parse the command line. */ +/* - Read the vertices from a file and either */ +/* - triangulate them (no -r), or */ +/* - read an old mesh from files and reconstruct it (-r). */ +/* - Insert the PSLG segments (-p), and possibly segments on the convex */ +/* hull (-c). */ +/* - Read the holes (-p), regional attributes (-pA), and regional area */ +/* constraints (-pa). Carve the holes and concavities, and spread the */ +/* regional attributes and area constraints. */ +/* - Enforce the constraints on minimum angle (-q) and maximum area (-a). */ +/* Also enforce the conforming Delaunay property (-q and -a). */ +/* - Compute the number of edges in the resulting mesh. */ +/* - Promote the mesh's linear triangles to higher order elements (-o). */ +/* - Write the output files and print the statistics. */ +/* - Check the consistency and Delaunay property of the mesh (-C). */ +/* */ +/*****************************************************************************/ + +#ifdef TRILIBRARY + +#ifdef ANSI_DECLARATORS +void triangulate(char *triswitches, struct triangulateio *in, + struct triangulateio *out, struct triangulateio *vorout) +#else /* not ANSI_DECLARATORS */ + void triangulate(triswitches, in, out, vorout) char *triswitches; + struct triangulateio *in; + struct triangulateio *out; + struct triangulateio *vorout; +#endif /* not ANSI_DECLARATORS */ + +#else /* not TRILIBRARY */ + +#ifdef ANSI_DECLARATORS +int main(int argc, char **argv) +#else /* not ANSI_DECLARATORS */ +int main(argc, argv) +int argc; +char **argv; +#endif /* not ANSI_DECLARATORS */ + +#endif /* not TRILIBRARY */ + +{ + struct mesh m; + struct behavior b; + REAL *holearray; /* Array of holes. */ + REAL *regionarray; /* Array of regional attributes and area constraints. */ +#ifndef TRILIBRARY + FILE *polyfile; +#endif /* not TRILIBRARY */ +#ifndef NO_TIMER + /* Variables for timing the performance of Triangle. The types are */ + /* defined in sys/time.h. */ + struct timeval tv0, tv1, tv2, tv3, tv4, tv5, tv6; + struct timezone tz; +#endif /* not NO_TIMER */ + +#ifndef NO_TIMER + gettimeofday(&tv0, &tz); +#endif /* not NO_TIMER */ + + triangleinit(&m); +#ifdef TRILIBRARY + parsecommandline(1, &triswitches, &b); +#else /* not TRILIBRARY */ + parsecommandline(argc, argv, &b); +#endif /* not TRILIBRARY */ + m.steinerleft = b.steiner; + +#ifdef TRILIBRARY + transfernodes(&m, &b, in->pointlist, in->pointattributelist, + in->pointmarkerlist, in->numberofpoints, + in->numberofpointattributes); +#else /* not TRILIBRARY */ + readnodes(&m, &b, b.innodefilename, b.inpolyfilename, &polyfile); +#endif /* not TRILIBRARY */ + +#ifndef NO_TIMER + if (!b.quiet) { + gettimeofday(&tv1, &tz); + } +#endif /* not NO_TIMER */ + +#ifdef CDT_ONLY + m.hullsize = delaunay(&m, &b); /* Triangulate the vertices. */ +#else /* not CDT_ONLY */ + if (b.refine) { + /* Read and reconstruct a mesh. */ +#ifdef TRILIBRARY + m.hullsize = reconstruct(&m, &b, in->trianglelist, + in->triangleattributelist, in->trianglearealist, + in->numberoftriangles, in->numberofcorners, + in->numberoftriangleattributes, in->segmentlist, + in->segmentmarkerlist, in->numberofsegments); +#else /* not TRILIBRARY */ + m.hullsize = reconstruct(&m, &b, b.inelefilename, b.areafilename, + b.inpolyfilename, polyfile); +#endif /* not TRILIBRARY */ + } else { + m.hullsize = delaunay(&m, &b); /* Triangulate the vertices. */ + } +#endif /* not CDT_ONLY */ + +#ifndef NO_TIMER + if (!b.quiet) { + gettimeofday(&tv2, &tz); + if (b.refine) { + printf("Mesh reconstruction"); + } else { + printf("Delaunay"); + } + printf(" milliseconds: %ld\n", 1000l * (tv2.tv_sec - tv1.tv_sec) + + (tv2.tv_usec - tv1.tv_usec) / 1000l); + } +#endif /* not NO_TIMER */ + + /* Ensure that no vertex can be mistaken for a triangular bounding */ + /* box vertex in insertvertex(). */ + m.infvertex1 = (vertex)NULL; + m.infvertex2 = (vertex)NULL; + m.infvertex3 = (vertex)NULL; + + if (b.usesegments) { + m.checksegments = 1; /* Segments will be introduced next. */ + if (!b.refine) { + /* Insert PSLG segments and/or convex hull segments. */ +#ifdef TRILIBRARY + formskeleton(&m, &b, in->segmentlist, in->segmentmarkerlist, + in->numberofsegments); +#else /* not TRILIBRARY */ + formskeleton(&m, &b, polyfile, b.inpolyfilename); +#endif /* not TRILIBRARY */ + } + } + +#ifndef NO_TIMER + if (!b.quiet) { + gettimeofday(&tv3, &tz); + if (b.usesegments && !b.refine) { + printf("Segment milliseconds: %ld\n", + 1000l * (tv3.tv_sec - tv2.tv_sec) + + (tv3.tv_usec - tv2.tv_usec) / 1000l); + } + } +#endif /* not NO_TIMER */ + + if (b.poly && (m.triangles.items > 0)) { +#ifdef TRILIBRARY + holearray = in->holelist; + m.holes = in->numberofholes; + regionarray = in->regionlist; + m.regions = in->numberofregions; +#else /* not TRILIBRARY */ + readholes(&m, &b, polyfile, b.inpolyfilename, &holearray, &m.holes, + ®ionarray, &m.regions); +#endif /* not TRILIBRARY */ + if (!b.refine) { + /* Carve out holes and concavities. */ + carveholes(&m, &b, holearray, m.holes, regionarray, m.regions); + } + } else { + /* Without a PSLG, there can be no holes or regional attributes */ + /* or area constraints. The following are set to zero to avoid */ + /* an accidental free() later. */ + m.holes = 0; + m.regions = 0; + } + +#ifndef NO_TIMER + if (!b.quiet) { + gettimeofday(&tv4, &tz); + if (b.poly && !b.refine) { + printf("Hole milliseconds: %ld\n", + 1000l * (tv4.tv_sec - tv3.tv_sec) + + (tv4.tv_usec - tv3.tv_usec) / 1000l); + } + } +#endif /* not NO_TIMER */ + +#ifndef CDT_ONLY + if (b.quality && (m.triangles.items > 0)) { + enforcequality(&m, &b); /* Enforce angle and area constraints. */ + } +#endif /* not CDT_ONLY */ + +#ifndef NO_TIMER + if (!b.quiet) { + gettimeofday(&tv5, &tz); +#ifndef CDT_ONLY + if (b.quality) { + printf("Quality milliseconds: %ld\n", + 1000l * (tv5.tv_sec - tv4.tv_sec) + + (tv5.tv_usec - tv4.tv_usec) / 1000l); + } +#endif /* not CDT_ONLY */ + } +#endif /* not NO_TIMER */ + + /* Calculate the number of edges. */ + m.edges = (3l * m.triangles.items + m.hullsize) / 2l; + + if (b.order > 1) { + highorder(&m, &b); /* Promote elements to higher polynomial order. */ + } + if (!b.quiet) { + printf("\n"); + } + +#ifdef TRILIBRARY + if (b.jettison) { + out->numberofpoints = m.vertices.items - m.undeads; + } else { + out->numberofpoints = m.vertices.items; + } + out->numberofpointattributes = m.nextras; + out->numberoftriangles = m.triangles.items; + out->numberofcorners = (b.order + 1) * (b.order + 2) / 2; + out->numberoftriangleattributes = m.eextras; + out->numberofedges = m.edges; + if (b.usesegments) { + out->numberofsegments = m.subsegs.items; + } else { + out->numberofsegments = m.hullsize; + } + if (vorout != (struct triangulateio *)NULL) { + vorout->numberofpoints = m.triangles.items; + vorout->numberofpointattributes = m.nextras; + vorout->numberofedges = m.edges; + } +#endif /* TRILIBRARY */ + /* If not using iteration numbers, don't write a .node file if one was */ + /* read, because the original one would be overwritten! */ + if (b.nonodewritten || (b.noiterationnum && m.readnodefile)) { + if (!b.quiet) { +#ifdef TRILIBRARY + printf("NOT writing vertices.\n"); +#else /* not TRILIBRARY */ + printf("NOT writing a .node file.\n"); +#endif /* not TRILIBRARY */ + } + numbernodes(&m, &b); /* We must remember to number the vertices. */ + } else { + /* writenodes() numbers the vertices too. */ +#ifdef TRILIBRARY + writenodes(&m, &b, &out->pointlist, &out->pointattributelist, + &out->pointmarkerlist); +#else /* not TRILIBRARY */ + writenodes(&m, &b, b.outnodefilename, argc, argv); +#endif /* TRILIBRARY */ + } + if (b.noelewritten) { + if (!b.quiet) { +#ifdef TRILIBRARY + printf("NOT writing triangles.\n"); +#else /* not TRILIBRARY */ + printf("NOT writing an .ele file.\n"); +#endif /* not TRILIBRARY */ + } + } else { +#ifdef TRILIBRARY + writeelements(&m, &b, &out->trianglelist, &out->triangleattributelist); +#else /* not TRILIBRARY */ + writeelements(&m, &b, b.outelefilename, argc, argv); +#endif /* not TRILIBRARY */ + } + /* The -c switch (convex switch) causes a PSLG to be written */ + /* even if none was read. */ + if (b.poly || b.convex) { + /* If not using iteration numbers, don't overwrite the .poly file. */ + if (b.nopolywritten || b.noiterationnum) { + if (!b.quiet) { +#ifdef TRILIBRARY + printf("NOT writing segments.\n"); +#else /* not TRILIBRARY */ + printf("NOT writing a .poly file.\n"); +#endif /* not TRILIBRARY */ + } + } else { +#ifdef TRILIBRARY + writepoly(&m, &b, &out->segmentlist, &out->segmentmarkerlist); + out->numberofholes = m.holes; + out->numberofregions = m.regions; + if (b.poly) { + out->holelist = in->holelist; + out->regionlist = in->regionlist; + } else { + out->holelist = (REAL *)NULL; + out->regionlist = (REAL *)NULL; + } +#else /* not TRILIBRARY */ + writepoly(&m, &b, b.outpolyfilename, holearray, m.holes, regionarray, + m.regions, argc, argv); +#endif /* not TRILIBRARY */ + } + } +#ifndef TRILIBRARY +#ifndef CDT_ONLY + if (m.regions > 0) { + trifree((VOID *)regionarray); + } +#endif /* not CDT_ONLY */ + if (m.holes > 0) { + trifree((VOID *)holearray); + } + if (b.geomview) { + writeoff(&m, &b, b.offfilename, argc, argv); + } +#endif /* not TRILIBRARY */ + if (b.edgesout) { +#ifdef TRILIBRARY + writeedges(&m, &b, &out->edgelist, &out->edgemarkerlist); +#else /* not TRILIBRARY */ + writeedges(&m, &b, b.edgefilename, argc, argv); +#endif /* not TRILIBRARY */ + } + if (b.voronoi) { +#ifdef TRILIBRARY + writevoronoi(&m, &b, &vorout->pointlist, &vorout->pointattributelist, + &vorout->pointmarkerlist, &vorout->edgelist, + &vorout->edgemarkerlist, &vorout->normlist); +#else /* not TRILIBRARY */ + writevoronoi(&m, &b, b.vnodefilename, b.vedgefilename, argc, argv); +#endif /* not TRILIBRARY */ + } + if (b.neighbors) { +#ifdef TRILIBRARY + writeneighbors(&m, &b, &out->neighborlist); +#else /* not TRILIBRARY */ + writeneighbors(&m, &b, b.neighborfilename, argc, argv); +#endif /* not TRILIBRARY */ + } + + if (!b.quiet) { +#ifndef NO_TIMER + gettimeofday(&tv6, &tz); + printf("\nOutput milliseconds: %ld\n", + 1000l * (tv6.tv_sec - tv5.tv_sec) + + (tv6.tv_usec - tv5.tv_usec) / 1000l); + printf("Total running milliseconds: %ld\n", + 1000l * (tv6.tv_sec - tv0.tv_sec) + + (tv6.tv_usec - tv0.tv_usec) / 1000l); +#endif /* not NO_TIMER */ + + statistics(&m, &b); + } + +#ifndef REDUCED + if (b.docheck) { + checkmesh(&m, &b); + checkdelaunay(&m, &b); + } +#endif /* not REDUCED */ + + triangledeinit(&m, &b); +#ifndef TRILIBRARY + return 0; +#endif /* not TRILIBRARY */ +} diff --git a/src/modules/TriangleInterface/src/triangle.h b/src/modules/TriangleInterface/src/triangle.h new file mode 100644 index 000000000..1d80a5e71 --- /dev/null +++ b/src/modules/TriangleInterface/src/triangle.h @@ -0,0 +1,297 @@ +/*****************************************************************************/ +/* */ +/* (triangle.h) */ +/* */ +/* Include file for programs that call Triangle. */ +/* */ +/* Accompanies Triangle Version 1.6 */ +/* July 28, 2005 */ +/* */ +/* Copyright 1996, 2005 */ +/* Jonathan Richard Shewchuk */ +/* 2360 Woolsey #H */ +/* Berkeley, California 94705-1927 */ +/* jrs@cs.berkeley.edu */ +/* */ +/*****************************************************************************/ + +/*****************************************************************************/ +/* */ +/* How to call Triangle from another program */ +/* */ +/* */ +/* If you haven't read Triangle's instructions (run "triangle -h" to read */ +/* them), you won't understand what follows. */ +/* */ +/* Triangle must be compiled into an object file (triangle.o) with the */ +/* TRILIBRARY symbol defined (generally by using the -DTRILIBRARY compiler */ +/* switch). The makefile included with Triangle will do this for you if */ +/* you run "make trilibrary". The resulting object file can be called via */ +/* the procedure triangulate(). */ +/* */ +/* If the size of the object file is important to you, you may wish to */ +/* generate a reduced version of triangle.o. The REDUCED symbol gets rid */ +/* of all features that are primarily of research interest. Specifically, */ +/* the -DREDUCED switch eliminates Triangle's -i, -F, -s, and -C switches. */ +/* The CDT_ONLY symbol gets rid of all meshing algorithms above and beyond */ +/* constrained Delaunay triangulation. Specifically, the -DCDT_ONLY switch */ +/* eliminates Triangle's -r, -q, -a, -u, -D, -Y, -S, and -s switches. */ +/* */ +/* IMPORTANT: These definitions (TRILIBRARY, REDUCED, CDT_ONLY) must be */ +/* made in the makefile or in triangle.c itself. Putting these definitions */ +/* in this file (triangle.h) will not create the desired effect. */ +/* */ +/* */ +/* The calling convention for triangulate() follows. */ +/* */ +/* void triangulate(triswitches, in, out, vorout) */ +/* char *triswitches; */ +/* struct triangulateio *in; */ +/* struct triangulateio *out; */ +/* struct triangulateio *vorout; */ +/* */ +/* `triswitches' is a string containing the command line switches you wish */ +/* to invoke. No initial dash is required. Some suggestions: */ +/* */ +/* - You'll probably find it convenient to use the `z' switch so that */ +/* points (and other items) are numbered from zero. This simplifies */ +/* indexing, because the first item of any type always starts at index */ +/* [0] of the corresponding array, whether that item's number is zero or */ +/* one. */ +/* - You'll probably want to use the `Q' (quiet) switch in your final code, */ +/* but you can take advantage of Triangle's printed output (including the */ +/* `V' switch) while debugging. */ +/* - If you are not using the `q', `a', `u', `D', `j', or `s' switches, */ +/* then the output points will be identical to the input points, except */ +/* possibly for the boundary markers. If you don't need the boundary */ +/* markers, you should use the `N' (no nodes output) switch to save */ +/* memory. (If you do need boundary markers, but need to save memory, a */ +/* good nasty trick is to set out->pointlist equal to in->pointlist */ +/* before calling triangulate(), so that Triangle overwrites the input */ +/* points with identical copies.) */ +/* - The `I' (no iteration numbers) and `g' (.off file output) switches */ +/* have no effect when Triangle is compiled with TRILIBRARY defined. */ +/* */ +/* `in', `out', and `vorout' are descriptions of the input, the output, */ +/* and the Voronoi output. If the `v' (Voronoi output) switch is not used, */ +/* `vorout' may be NULL. `in' and `out' may never be NULL. */ +/* */ +/* Certain fields of the input and output structures must be initialized, */ +/* as described below. */ +/* */ +/*****************************************************************************/ + +/*****************************************************************************/ +/* */ +/* The `triangulateio' structure. */ +/* */ +/* Used to pass data into and out of the triangulate() procedure. */ +/* */ +/* */ +/* Arrays are used to store points, triangles, markers, and so forth. In */ +/* all cases, the first item in any array is stored starting at index [0]. */ +/* However, that item is item number `1' unless the `z' switch is used, in */ +/* which case it is item number `0'. Hence, you may find it easier to */ +/* index points (and triangles in the neighbor list) if you use the `z' */ +/* switch. Unless, of course, you're calling Triangle from a Fortran */ +/* program. */ +/* */ +/* Description of fields (except the `numberof' fields, which are obvious): */ +/* */ +/* `pointlist': An array of point coordinates. The first point's x */ +/* coordinate is at index [0] and its y coordinate at index [1], followed */ +/* by the coordinates of the remaining points. Each point occupies two */ +/* REALs. */ +/* `pointattributelist': An array of point attributes. Each point's */ +/* attributes occupy `numberofpointattributes' REALs. */ +/* `pointmarkerlist': An array of point markers; one int per point. */ +/* */ +/* `trianglelist': An array of triangle corners. The first triangle's */ +/* first corner is at index [0], followed by its other two corners in */ +/* counterclockwise order, followed by any other nodes if the triangle */ +/* represents a nonlinear element. Each triangle occupies */ +/* `numberofcorners' ints. */ +/* `triangleattributelist': An array of triangle attributes. Each */ +/* triangle's attributes occupy `numberoftriangleattributes' REALs. */ +/* `trianglearealist': An array of triangle area constraints; one REAL per */ +/* triangle. Input only. */ +/* `neighborlist': An array of triangle neighbors; three ints per */ +/* triangle. Output only. */ +/* */ +/* `segmentlist': An array of segment endpoints. The first segment's */ +/* endpoints are at indices [0] and [1], followed by the remaining */ +/* segments. Two ints per segment. */ +/* `segmentmarkerlist': An array of segment markers; one int per segment. */ +/* */ +/* `holelist': An array of holes. The first hole's x and y coordinates */ +/* are at indices [0] and [1], followed by the remaining holes. Two */ +/* REALs per hole. Input only, although the pointer is copied to the */ +/* output structure for your convenience. */ +/* */ +/* `regionlist': An array of regional attributes and area constraints. */ +/* The first constraint's x and y coordinates are at indices [0] and [1], */ +/* followed by the regional attribute at index [2], followed by the */ +/* maximum area at index [3], followed by the remaining area constraints. */ +/* Four REALs per area constraint. Note that each regional attribute is */ +/* used only if you select the `A' switch, and each area constraint is */ +/* used only if you select the `a' switch (with no number following), but */ +/* omitting one of these switches does not change the memory layout. */ +/* Input only, although the pointer is copied to the output structure for */ +/* your convenience. */ +/* */ +/* `edgelist': An array of edge endpoints. The first edge's endpoints are */ +/* at indices [0] and [1], followed by the remaining edges. Two ints per */ +/* edge. Output only. */ +/* `edgemarkerlist': An array of edge markers; one int per edge. Output */ +/* only. */ +/* `normlist': An array of normal vectors, used for infinite rays in */ +/* Voronoi diagrams. The first normal vector's x and y magnitudes are */ +/* at indices [0] and [1], followed by the remaining vectors. For each */ +/* finite edge in a Voronoi diagram, the normal vector written is the */ +/* zero vector. Two REALs per edge. Output only. */ +/* */ +/* */ +/* Any input fields that Triangle will examine must be initialized. */ +/* Furthermore, for each output array that Triangle will write to, you */ +/* must either provide space by setting the appropriate pointer to point */ +/* to the space you want the data written to, or you must initialize the */ +/* pointer to NULL, which tells Triangle to allocate space for the results. */ +/* The latter option is preferable, because Triangle always knows exactly */ +/* how much space to allocate. The former option is provided mainly for */ +/* people who need to call Triangle from Fortran code, though it also makes */ +/* possible some nasty space-saving tricks, like writing the output to the */ +/* same arrays as the input. */ +/* */ +/* Triangle will not free() any input or output arrays, including those it */ +/* allocates itself; that's up to you. You should free arrays allocated by */ +/* Triangle by calling the trifree() procedure defined below. (By default, */ +/* trifree() just calls the standard free() library procedure, but */ +/* applications that call triangulate() may replace trimalloc() and */ +/* trifree() in triangle.c to use specialized memory allocators.) */ +/* */ +/* Here's a guide to help you decide which fields you must initialize */ +/* before you call triangulate(). */ +/* */ +/* `in': */ +/* */ +/* - `pointlist' must always point to a list of points; `numberofpoints' */ +/* and `numberofpointattributes' must be properly set. */ +/* `pointmarkerlist' must either be set to NULL (in which case all */ +/* markers default to zero), or must point to a list of markers. If */ +/* `numberofpointattributes' is not zero, `pointattributelist' must */ +/* point to a list of point attributes. */ +/* - If the `r' switch is used, `trianglelist' must point to a list of */ +/* triangles, and `numberoftriangles', `numberofcorners', and */ +/* `numberoftriangleattributes' must be properly set. If */ +/* `numberoftriangleattributes' is not zero, `triangleattributelist' */ +/* must point to a list of triangle attributes. If the `a' switch is */ +/* used (with no number following), `trianglearealist' must point to a */ +/* list of triangle area constraints. `neighborlist' may be ignored. */ +/* - If the `p' switch is used, `segmentlist' must point to a list of */ +/* segments, `numberofsegments' must be properly set, and */ +/* `segmentmarkerlist' must either be set to NULL (in which case all */ +/* markers default to zero), or must point to a list of markers. */ +/* - If the `p' switch is used without the `r' switch, then */ +/* `numberofholes' and `numberofregions' must be properly set. If */ +/* `numberofholes' is not zero, `holelist' must point to a list of */ +/* holes. If `numberofregions' is not zero, `regionlist' must point to */ +/* a list of region constraints. */ +/* - If the `p' switch is used, `holelist', `numberofholes', */ +/* `regionlist', and `numberofregions' is copied to `out'. (You can */ +/* nonetheless get away with not initializing them if the `r' switch is */ +/* used.) */ +/* - `edgelist', `edgemarkerlist', `normlist', and `numberofedges' may be */ +/* ignored. */ +/* */ +/* `out': */ +/* */ +/* - `pointlist' must be initialized (NULL or pointing to memory) unless */ +/* the `N' switch is used. `pointmarkerlist' must be initialized */ +/* unless the `N' or `B' switch is used. If `N' is not used and */ +/* `in->numberofpointattributes' is not zero, `pointattributelist' must */ +/* be initialized. */ +/* - `trianglelist' must be initialized unless the `E' switch is used. */ +/* `neighborlist' must be initialized if the `n' switch is used. If */ +/* the `E' switch is not used and (`in->numberofelementattributes' is */ +/* not zero or the `A' switch is used), `elementattributelist' must be */ +/* initialized. `trianglearealist' may be ignored. */ +/* - `segmentlist' must be initialized if the `p' or `c' switch is used, */ +/* and the `P' switch is not used. `segmentmarkerlist' must also be */ +/* initialized under these circumstances unless the `B' switch is used. */ +/* - `edgelist' must be initialized if the `e' switch is used. */ +/* `edgemarkerlist' must be initialized if the `e' switch is used and */ +/* the `B' switch is not. */ +/* - `holelist', `regionlist', `normlist', and all scalars may be ignored.*/ +/* */ +/* `vorout' (only needed if `v' switch is used): */ +/* */ +/* - `pointlist' must be initialized. If `in->numberofpointattributes' */ +/* is not zero, `pointattributelist' must be initialized. */ +/* `pointmarkerlist' may be ignored. */ +/* - `edgelist' and `normlist' must both be initialized. */ +/* `edgemarkerlist' may be ignored. */ +/* - Everything else may be ignored. */ +/* */ +/* After a call to triangulate(), the valid fields of `out' and `vorout' */ +/* will depend, in an obvious way, on the choice of switches used. Note */ +/* that when the `p' switch is used, the pointers `holelist' and */ +/* `regionlist' are copied from `in' to `out', but no new space is */ +/* allocated; be careful that you don't free() the same array twice. On */ +/* the other hand, Triangle will never copy the `pointlist' pointer (or any */ +/* others); new space is allocated for `out->pointlist', or if the `N' */ +/* switch is used, `out->pointlist' remains uninitialized. */ +/* */ +/* All of the meaningful `numberof' fields will be properly set; for */ +/* instance, `numberofedges' will represent the number of edges in the */ +/* triangulation whether or not the edges were written. If segments are */ +/* not used, `numberofsegments' will indicate the number of boundary edges. */ +/* */ +/*****************************************************************************/ + +#ifdef USE_Real64 +#define REAL double +#else +#define REAL float +#endif + +struct triangulateio { + REAL *pointlist; /* In / out */ + REAL *pointattributelist; /* In / out */ + int *pointmarkerlist; /* In / out */ + int numberofpoints; /* In / out */ + int numberofpointattributes; /* In / out */ + + int *trianglelist; /* In / out */ + REAL *triangleattributelist; /* In / out */ + REAL *trianglearealist; /* In only */ + int *neighborlist; /* Out only */ + int numberoftriangles; /* In / out */ + int numberofcorners; /* In / out */ + int numberoftriangleattributes; /* In / out */ + + int *segmentlist; /* In / out */ + int *segmentmarkerlist; /* In / out */ + int numberofsegments; /* In / out */ + + REAL *holelist; /* In / pointer to array copied out */ + int numberofholes; /* In / copied out */ + + REAL *regionlist; /* In / pointer to array copied out */ + int numberofregions; /* In / copied out */ + + int *edgelist; /* Out only */ + int *edgemarkerlist; /* Not used with Voronoi diagram; out only */ + REAL *normlist; /* Used only with Voronoi diagram; out only */ + int numberofedges; /* Out only */ +}; + +#ifdef ANSI_DECLARATORS +void triangulate(char *, struct triangulateio *, struct triangulateio *, + struct triangulateio *); +void trifree(VOID *memptr); +#else /* not ANSI_DECLARATORS */ +void triangulate(); +void trifree(); +#endif /* not ANSI_DECLARATORS */ + +void report(struct triangulateio *, int, int, int, int, int, int); diff --git a/src/modules/Utility/CMakeLists.txt b/src/modules/Utility/CMakeLists.txt new file mode 100644 index 000000000..3428baa00 --- /dev/null +++ b/src/modules/Utility/CMakeLists.txt @@ -0,0 +1,56 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/MappingUtility.F90 + ${src_path}/BinomUtility.F90 + ${src_path}/AppendUtility.F90 + ${src_path}/ApproxUtility.F90 + ${src_path}/AssertUtility.F90 + ${src_path}/HeadUtility.F90 + ${src_path}/TailUtility.F90 + ${src_path}/SplitUtility.F90 + ${src_path}/ArangeUtility.F90 + ${src_path}/GridPointUtility.F90 + ${src_path}/OnesUtility.F90 + ${src_path}/ZerosUtility.F90 + ${src_path}/EyeUtility.F90 + ${src_path}/DiagUtility.F90 + ${src_path}/HashingUtility.F90 + ${src_path}/InputUtility.F90 + ${src_path}/InvUtility.F90 + ${src_path}/MatmulUtility.F90 + ${src_path}/ContractionUtility.F90 + ${src_path}/MiscUtility.F90 + ${src_path}/ProductUtility.F90 + ${src_path}/ReallocateUtility.F90 + ${src_path}/PartitionUtility.F90 + ${src_path}/MedianUtility.F90 + ${src_path}/SortUtility.F90 + ${src_path}/StringUtility.F90 + ${src_path}/SwapUtility.F90 + ${src_path}/ConvertUtility.F90 + ${src_path}/IntegerUtility.F90 + ${src_path}/PushPopUtility.F90 + ${src_path}/EigenUtility.F90 + ${src_path}/SymUtility.F90 + ${src_path}/TriagUtility.F90 + ${src_path}/LinearAlgebraUtility.F90 + ${src_path}/SafeSizeUtility.F90 + ${src_path}/Utility.F90) diff --git a/src/modules/Utility/src/AppendUtility.F90 b/src/modules/Utility/src/AppendUtility.F90 new file mode 100644 index 000000000..a607a3083 --- /dev/null +++ b/src/modules/Utility/src/AppendUtility.F90 @@ -0,0 +1,799 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2024-04-11 +! summary: This module contains method for appending to vectors and martrix +! +!{!|page|/AppendUtility/index.md!} +! +MODULE AppendUtility + +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: ColConcat +PUBLIC :: OPERATOR(.ColConcat.) +PUBLIC :: RowConcat +PUBLIC :: OPERATOR(.RowConcat.) +PUBLIC :: Append +PUBLIC :: OPERATOR(.Append.) +PUBLIC :: Expand + +!---------------------------------------------------------------------------- +! Expand@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 July 2022 +! summary: Expand the vector +! +!# Introduction +! Expand the vector and add an element. +! +! reference +! https://github.com/jacobwilliams/fortran-csv-module/blob/master/src/ +! csv_utilities.f90 +! +!{!|page|/AppendUtility/Expand.md!} + +INTERFACE Expand + MODULE PURE SUBROUTINE expand_int8(vec, n, chunk_size, val, finished) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: vec(:) + INTEGER(I4B), INTENT(INOUT) :: n + !! counter for last element added to `vec`. + !! must be initialized to `size(vec)` + !! (or 0 if not allocated) before first call + INTEGER(I4B), INTENT(IN) :: chunk_size + !! allocate `vec` in blocks of this size (>0) + INTEGER(INT8), OPTIONAL, INTENT(IN) :: val + !! the value to add to `vec` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished + !! set to true to return `vec` + !! as its correct size (`n`) + END SUBROUTINE expand_int8 + + MODULE PURE SUBROUTINE expand_int16(vec, n, chunk_size, val, finished) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: vec(:) + INTEGER(I4B), INTENT(INOUT) :: n + !! counter for last element added to `vec`. + !! must be initialized to `size(vec)` + !! (or 0 if not allocated) before first call + INTEGER(I4B), INTENT(IN) :: chunk_size + !! allocate `vec` in blocks of this size (>0) + INTEGER(INT16), OPTIONAL, INTENT(IN) :: val + !! the value to add to `vec` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished + !! set to true to return `vec` + !! as its correct size (`n`) + END SUBROUTINE expand_int16 + + MODULE PURE SUBROUTINE expand_int32(vec, n, chunk_size, val, finished) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: vec(:) + INTEGER(I4B), INTENT(INOUT) :: n + !! counter for last element added to `vec`. + !! must be initialized to `size(vec)` + !! (or 0 if not allocated) before first call + INTEGER(I4B), INTENT(IN) :: chunk_size + !! allocate `vec` in blocks of this size (>0) + INTEGER(INT32), OPTIONAL, INTENT(IN) :: val + !! the value to add to `vec` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished + !! set to true to return `vec` + !! as its correct size (`n`) + END SUBROUTINE expand_int32 + + MODULE PURE SUBROUTINE expand_int64(vec, n, chunk_size, val, finished) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: vec(:) + INTEGER(I4B), INTENT(INOUT) :: n + !! counter for last element added to `vec`. + !! must be initialized to `size(vec)` + !! (or 0 if not allocated) before first call + INTEGER(I4B), INTENT(IN) :: chunk_size + !! allocate `vec` in blocks of this size (>0) + INTEGER(INT64), OPTIONAL, INTENT(IN) :: val + !! the value to add to `vec` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished + !! set to true to return `vec` + !! as its correct size (`n`) + END SUBROUTINE expand_int64 +END INTERFACE Expand + +!---------------------------------------------------------------------------- +! Expand@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 July 2022 +! summary: Expand the real vector + +INTERFACE Expand + MODULE PURE SUBROUTINE expand_real32(vec, n, chunk_size, val, finished) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: vec(:) + INTEGER(I4B), INTENT(INOUT) :: n + !! counter for last element added to `vec`. + !! must be initialized to `size(vec)` + !! (or 0 if not allocated) before first call + INTEGER(I4B), INTENT(IN) :: chunk_size + !! allocate `vec` in blocks of this size (>0) + REAL(REAL32), OPTIONAL, INTENT(IN) :: val + !! the value to add to `vec` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished + !! set to true to return `vec` + !! as its correct size (`n`) + END SUBROUTINE expand_real32 + + MODULE PURE SUBROUTINE expand_real64(vec, n, chunk_size, val, finished) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: vec(:) + INTEGER(I4B), INTENT(INOUT) :: n + !! counter for last element added to `vec`. + !! must be initialized to `size(vec)` + !! (or 0 if not allocated) before first call + INTEGER(I4B), INTENT(IN) :: chunk_size + !! allocate `vec` in blocks of this size (>0) + REAL(REAL64), OPTIONAL, INTENT(IN) :: val + !! the value to add to `vec` + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: finished + !! set to true to return `vec` + !! as its correct size (`n`) + END SUBROUTINE expand_real64 +END INTERFACE Expand + +!---------------------------------------------------------------------------- +! Append@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Append a scalar or vector to vector +! +!# Introduction +! +!- Append a scalar integer to an integer vector +!- Append a integer vector and scalar to an integer vector +!- Append a scalar real to an real vector +!- Append a real vector to a real vector + +INTERFACE Append + ! Append a scalar int to a vector of int + MODULE PURE SUBROUTINE Append_1a(A, ENTRY) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), INTENT(IN) :: ENTRY + END SUBROUTINE Append_1a + + ! Append a scalar real to a vector of real + MODULE PURE SUBROUTINE Append_1b(A, ENTRY) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) + REAL(DFP), INTENT(IN) :: ENTRY + END SUBROUTINE Append_1b + + ! Append a scalar and vector int to a vector of int + MODULE PURE SUBROUTINE Append_1c(C, A, B) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) + INTEGER(I4B), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: B + END SUBROUTINE Append_1c + + ! Append a scalar and vector real to a vector of real + MODULE PURE SUBROUTINE Append_1d(C, A, B) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), INTENT(IN) :: B + END SUBROUTINE Append_1d +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Append two vectors of real or int +! +!# Introduction +! +!- Append a vector of int to another vector of int +!- Append a vector of real to another vector of real +!- Append two vectors of int to another vector of int +!- Append two vector of real to another vector of real + +INTERFACE Append + MODULE PURE SUBROUTINE Append_2a(A, ENTRY) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), INTENT(IN) :: ENTRY(:) + END SUBROUTINE Append_2a + + MODULE PURE SUBROUTINE Append_2b(A, ENTRY) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) + REAL(DFP), INTENT(IN) :: ENTRY(:) + END SUBROUTINE Append_2b + + MODULE PURE SUBROUTINE Append_2c(C, A, B) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) + INTEGER(I4B), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: B(:) + END SUBROUTINE Append_2c + + MODULE PURE SUBROUTINE Append_2d(C, A, B) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), INTENT(IN) :: B(:) + END SUBROUTINE Append_2d + + MODULE PURE SUBROUTINE Append_2e(D, C, A, B) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: D(:) + INTEGER(I4B), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: B(:) + INTEGER(I4B), INTENT(IN) :: C(:) + END SUBROUTINE Append_2e + + MODULE PURE SUBROUTINE Append_2f(D, C, A, B) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: D(:) + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), INTENT(IN) :: B(:) + REAL(DFP), INTENT(IN) :: C(:) + END SUBROUTINE Append_2f + +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Masked append +! +!# Introduction +! +!- Append a scalar integer to a vector of int +!- Append a scalar real to a vector of reals +!- Append a scalar and vector of int to another vector of int +!- Append a scalar and vector real to another vector of real + +INTERFACE Append + MODULE PURE SUBROUTINE Append_3a(A, ENTRY, mask) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), INTENT(IN) :: ENTRY + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE Append_3a + + MODULE PURE SUBROUTINE Append_3b(A, ENTRY, mask) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) + REAL(DFP), INTENT(IN) :: ENTRY + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE Append_3b + + MODULE PURE SUBROUTINE Append_3c(C, A, B, mask) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) + INTEGER(I4B), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: B + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE Append_3c + + MODULE PURE SUBROUTINE Append_3d(C, A, B, mask) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), INTENT(IN) :: B + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE Append_3d +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Masked append two vectors to another vector of int/real +! +!# Introduction +! +!- Append a vector of int to another vector of int +!- Append a vector of real to another vector of real + +INTERFACE Append + MODULE PURE SUBROUTINE Append_4a(A, ENTRY, mask) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), INTENT(IN) :: ENTRY(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE Append_4a + + MODULE PURE SUBROUTINE Append_4b(A, ENTRY, mask) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) + REAL(DFP), INTENT(IN) :: ENTRY(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE Append_4b + + MODULE PURE SUBROUTINE Append_4c(C, A, B, mask) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: C(:) + INTEGER(I4B), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: B(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE Append_4c + + MODULE PURE SUBROUTINE Append_4d(C, A, B, mask) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: C(:) + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), INTENT(IN) :: B(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE Append_4d +END INTERFACE Append + +!---------------------------------------------------------------------------- +! Append@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Append a scalar INTEGER to INTEGER vec tor + +INTERFACE OPERATOR(.Append.) + MODULE PURE FUNCTION func_Append_1a(A, ENTRY) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: ENTRY + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION func_Append_1a + + MODULE PURE FUNCTION func_Append_1b(A, ENTRY) RESULT(ans) + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), INTENT(IN) :: ENTRY + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION func_Append_1b +END INTERFACE + +!---------------------------------------------------------------------------- +! Append@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Append two vectors of INTEGER + +INTERFACE OPERATOR(.APPEND.) + MODULE PURE FUNCTION func_Append_2a(A, ENTRY) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: A(:) + INTEGER(I4B), INTENT(IN) :: ENTRY(:) + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION func_Append_2a + + MODULE PURE FUNCTION func_Append_2b(A, ENTRY) RESULT(ans) + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), INTENT(IN) :: ENTRY(:) + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION func_Append_2b + +END INTERFACE + +!---------------------------------------------------------------------------- +! ColConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat columns of two vectors + +INTERFACE ColConcat + MODULE PURE FUNCTION colConcat_1a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:) + REAL(REAL32), INTENT(IN) :: b(:) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_1a + + MODULE PURE FUNCTION colConcat_1b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:) + REAL(REAL64), INTENT(IN) :: b(:) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_1b + + MODULE PURE FUNCTION colConcat_1c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_1c + + MODULE PURE FUNCTION colConcat_1d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_1d + + MODULE PURE FUNCTION colConcat_1e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_1e + + MODULE PURE FUNCTION colConcat_1f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_1f +END INTERFACE ColConcat + +INTERFACE OPERATOR(.ColConcat.) + MODULE PROCEDURE colConcat_1a, colConcat_1b, colConcat_1c, & + & colConcat_1d, colConcat_1e, colConcat_1f +END INTERFACE + +!---------------------------------------------------------------------------- +! ColConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat columns of a matrix and a vector + +INTERFACE ColConcat + MODULE PURE FUNCTION colConcat_2a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:, :) + REAL(REAL32), INTENT(IN) :: b(:) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_2a + + MODULE PURE FUNCTION colConcat_2b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:, :) + REAL(REAL64), INTENT(IN) :: b(:) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_2b + + MODULE PURE FUNCTION colConcat_2c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:, :) + INTEGER(INT64), INTENT(IN) :: b(:) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_2c + + MODULE PURE FUNCTION colConcat_2d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:, :) + INTEGER(INT32), INTENT(IN) :: b(:) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_2d + + MODULE PURE FUNCTION colConcat_2e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:, :) + INTEGER(INT16), INTENT(IN) :: b(:) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_2e + + MODULE PURE FUNCTION colConcat_2f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:, :) + INTEGER(INT8), INTENT(IN) :: b(:) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_2f +END INTERFACE ColConcat + +INTERFACE OPERATOR(.ColConcat.) + MODULE PROCEDURE colConcat_2a, colConcat_2b, colConcat_2c, & + & colConcat_2d, colConcat_2e, colConcat_2f +END INTERFACE + +!---------------------------------------------------------------------------- +! ColConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat columns of rank1 and rank2 array + +INTERFACE ColConcat + MODULE PURE FUNCTION colConcat_3a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:) + REAL(REAL32), INTENT(IN) :: b(:, :) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_3a + + MODULE PURE FUNCTION colConcat_3b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:) + REAL(REAL64), INTENT(IN) :: b(:, :) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_3b + + MODULE PURE FUNCTION colConcat_3c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:, :) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_3c + + MODULE PURE FUNCTION colConcat_3d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:, :) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_3d + + MODULE PURE FUNCTION colConcat_3e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:, :) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_3e + + MODULE PURE FUNCTION colConcat_3f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:, :) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_3f +END INTERFACE ColConcat + +INTERFACE OPERATOR(.ColConcat.) + MODULE PROCEDURE colConcat_3a, colConcat_3b, colConcat_3c, & + & colConcat_3d, colConcat_3e, colConcat_3f +END INTERFACE + +!---------------------------------------------------------------------------- +! ColConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat columns of rank2 and rank2 array + +INTERFACE ColConcat + MODULE PURE FUNCTION colConcat_4a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:, :) + REAL(REAL32), INTENT(IN) :: b(:, :) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_4a + + MODULE PURE FUNCTION colConcat_4b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:, :) + REAL(REAL64), INTENT(IN) :: b(:, :) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_4b + + MODULE PURE FUNCTION colConcat_4c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:, :) + INTEGER(INT64), INTENT(IN) :: b(:, :) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_4c + + MODULE PURE FUNCTION colConcat_4d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:, :) + INTEGER(INT32), INTENT(IN) :: b(:, :) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_4d + + MODULE PURE FUNCTION colConcat_4e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:, :) + INTEGER(INT16), INTENT(IN) :: b(:, :) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_4e + + MODULE PURE FUNCTION colConcat_4f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:, :) + INTEGER(INT8), INTENT(IN) :: b(:, :) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION colConcat_4f +END INTERFACE ColConcat + +INTERFACE OPERATOR(.ColConcat.) + MODULE PROCEDURE colConcat_4a, colConcat_4b, colConcat_4c, & + & colConcat_4d, colConcat_4e, colConcat_4f +END INTERFACE + +!---------------------------------------------------------------------------- +! ColConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat rows of two vectors + +INTERFACE RowConcat + MODULE PURE FUNCTION rowConcat_1a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:) + REAL(REAL32), INTENT(IN) :: b(:) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_1a + + MODULE PURE FUNCTION rowConcat_1b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:) + REAL(REAL64), INTENT(IN) :: b(:) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_1b + + MODULE PURE FUNCTION rowConcat_1c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_1c + + MODULE PURE FUNCTION rowConcat_1d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_1d + + MODULE PURE FUNCTION rowConcat_1e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_1e + + MODULE PURE FUNCTION rowConcat_1f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_1f +END INTERFACE RowConcat + +INTERFACE OPERATOR(.rowConcat.) + MODULE PROCEDURE rowConcat_1a, rowConcat_1b, rowConcat_1c, & + & rowConcat_1d, rowConcat_1e, rowConcat_1f +END INTERFACE + +!---------------------------------------------------------------------------- +! rowConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat rows of a matrix and a vector + +INTERFACE RowConcat + MODULE PURE FUNCTION rowConcat_2a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:, :) + REAL(REAL32), INTENT(IN) :: b(:) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_2a + + MODULE PURE FUNCTION rowConcat_2b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:, :) + REAL(REAL64), INTENT(IN) :: b(:) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_2b + + MODULE PURE FUNCTION rowConcat_2c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:, :) + INTEGER(INT64), INTENT(IN) :: b(:) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_2c + + MODULE PURE FUNCTION rowConcat_2d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:, :) + INTEGER(INT32), INTENT(IN) :: b(:) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_2d + + MODULE PURE FUNCTION rowConcat_2e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:, :) + INTEGER(INT16), INTENT(IN) :: b(:) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_2e + + MODULE PURE FUNCTION rowConcat_2f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:, :) + INTEGER(INT8), INTENT(IN) :: b(:) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_2f +END INTERFACE RowConcat + +INTERFACE OPERATOR(.rowConcat.) + MODULE PROCEDURE rowConcat_2a, rowConcat_2b, rowConcat_2c, & + & rowConcat_2d, rowConcat_2e, rowConcat_2f +END INTERFACE + +!---------------------------------------------------------------------------- +! rowConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat rows of rank1 and rank2 array + +INTERFACE RowConcat + MODULE PURE FUNCTION rowConcat_3a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:) + REAL(REAL32), INTENT(IN) :: b(:, :) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_3a + + MODULE PURE FUNCTION rowConcat_3b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:) + REAL(REAL64), INTENT(IN) :: b(:, :) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_3b + + MODULE PURE FUNCTION rowConcat_3c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:, :) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_3c + + MODULE PURE FUNCTION rowConcat_3d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:, :) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_3d + + MODULE PURE FUNCTION rowConcat_3e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:, :) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_3e + + MODULE PURE FUNCTION rowConcat_3f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:, :) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_3f +END INTERFACE RowConcat + +INTERFACE OPERATOR(.rowConcat.) + MODULE PROCEDURE rowConcat_3a, rowConcat_3b, rowConcat_3c, & + & rowConcat_3d, rowConcat_3e, rowConcat_3f +END INTERFACE + +!---------------------------------------------------------------------------- +! rowConcat@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-24 +! update: 2021-11-24 +! summary: Concat rows of rank2 and rank2 array + +INTERFACE RowConcat + MODULE PURE FUNCTION rowConcat_4a(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a(:, :) + REAL(REAL32), INTENT(IN) :: b(:, :) + REAL(REAL32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_4a + + MODULE PURE FUNCTION rowConcat_4b(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a(:, :) + REAL(REAL64), INTENT(IN) :: b(:, :) + REAL(REAL64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_4b + + MODULE PURE FUNCTION rowConcat_4c(a, b) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: a(:, :) + INTEGER(INT64), INTENT(IN) :: b(:, :) + INTEGER(INT64), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_4c + + MODULE PURE FUNCTION rowConcat_4d(a, b) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: a(:, :) + INTEGER(INT32), INTENT(IN) :: b(:, :) + INTEGER(INT32), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_4d + + MODULE PURE FUNCTION rowConcat_4e(a, b) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: a(:, :) + INTEGER(INT16), INTENT(IN) :: b(:, :) + INTEGER(INT16), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_4e + + MODULE PURE FUNCTION rowConcat_4f(a, b) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: a(:, :) + INTEGER(INT8), INTENT(IN) :: b(:, :) + INTEGER(INT8), ALLOCATABLE :: ans(:, :) + END FUNCTION rowConcat_4f +END INTERFACE RowConcat + +INTERFACE OPERATOR(.rowConcat.) + MODULE PROCEDURE rowConcat_4a, rowConcat_4b, rowConcat_4c, & + & rowConcat_4d, rowConcat_4e, rowConcat_4f +END INTERFACE + +END MODULE AppendUtility diff --git a/src/modules/Utility/src/ApproxUtility.F90 b/src/modules/Utility/src/ApproxUtility.F90 new file mode 100644 index 000000000..465dd2fbf --- /dev/null +++ b/src/modules/Utility/src/ApproxUtility.F90 @@ -0,0 +1,385 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 ApproxUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: OPERATOR(.APPROXEQ.) +PUBLIC :: OPERATOR(.APPROXEQA.) +PUBLIC :: OPERATOR(.APPROXEQR.) +PUBLIC :: OPERATOR(.APPROXEQF.) +PUBLIC :: OPERATOR(.APPROXLE.) +PUBLIC :: OPERATOR(.APPROXGE.) +PUBLIC :: SOFTEQ +PUBLIC :: SOFTEQR +PUBLIC :: SOFTLE +PUBLIC :: SOFTLT +PUBLIC :: SOFTGE +PUBLIC :: SOFTGT +PUBLIC :: OPERATOR(==) +PUBLIC :: OPERATOR(/=) +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: isNumeric + +!---------------------------------------------------------------------------- +! APPROXEQ@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Apr 2021 +! summary: returns true if a and b are approximately equal +! +!# Introduction +! +! This routine just does a simple absolute comparison using an epsilon +! that is a compile time constant. +! It should be used whenever possible because it has +! the least overhead. +! However, it is not appropriate to use when a and b +! are either very large or very small. + +INTERFACE OPERATOR(.APPROXEQ.) + MODULE PURE ELEMENTAL FUNCTION approxeq_1(a, b) RESULT(ans) + REAL(REAL64), INTENT(IN) :: a, b + LOGICAL(LGT) :: ans + END FUNCTION approxeq_1 +END INTERFACE OPERATOR(.APPROXEQ.) + +INTERFACE OPERATOR(.APPROXEQ.) + MODULE PURE ELEMENTAL FUNCTION approxeq_2(a, b) RESULT(ans) + REAL(REAL32), INTENT(IN) :: a, b + LOGICAL(LGT) :: ans + END FUNCTION approxeq_2 +END INTERFACE OPERATOR(.APPROXEQ.) + +INTERFACE OPERATOR(.APPROXEQA.) + MODULE PROCEDURE approxeq_1, approxeq_2 +END INTERFACE + +!---------------------------------------------------------------------------- +! APPROXR@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: returns bool logical indicating if a and b are approximately equal +! +!# Introduction +! This performs a relative comparison by scaling the default epsilon value to +! the size of the larger of the two. It should be used when c and b are of +! the same magnitude and very large or very small. If either c a or c b is +! zero (exactly) then this routine is equivalent to an absolute comparison. + +INTERFACE OPERATOR(.APPROXEQR.) + MODULE PURE ELEMENTAL FUNCTION approxeqr_1(a, b) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: a, b + LOGICAL(LGT) :: Ans + END FUNCTION approxeqr_1 + + MODULE PURE ELEMENTAL FUNCTION approxeqr_2(a, b) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: a, b + LOGICAL(LGT) :: Ans + END FUNCTION approxeqr_2 +END INTERFACE OPERATOR(.APPROXEQR.) + +!---------------------------------------------------------------------------- +! APPROXEQF@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Apr 2021 +! summary: returns bool logical indicating if a and b are approximately equal +! +!# Introduction +! This performs a comparison of the binary representation of the two reals +! to compare the binary units in the last place (ULP). If the two reals differ +! on the floating point number line by 10 or less representable floating point +! reals then they are considered equal. In theory, this is the most +! appropriate comparison to use, but will break down near zero. +! +! - TODO change the name to approxeqf_1 +! - TODO add support for the real32 and real64 + +INTERFACE OPERATOR(.APPROXEQF.) + MODULE PURE ELEMENTAL FUNCTION approxeq_ulp_real(a, b) RESULT(Ans) + REAL(DFP), INTENT(IN) :: a, b + LOGICAL(LGT) :: Ans + END FUNCTION approxeq_ulp_real +END INTERFACE + +!---------------------------------------------------------------------------- +! APPROXLE@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Apr 2021 +! summary: Defines the operator .APPROXLE. + +INTERFACE OPERATOR(.APPROXLE.) + MODULE PURE ELEMENTAL FUNCTION approxle_1(r1, r2) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + LOGICAL(LGT) :: Ans + END FUNCTION approxle_1 + + MODULE PURE ELEMENTAL FUNCTION approxle_2(r1, r2) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + LOGICAL(LGT) :: Ans + END FUNCTION approxle_2 +END INTERFACE + +!---------------------------------------------------------------------------- +! APPROXGE@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Defines the operation when comparing two single precision reals + +INTERFACE OPERATOR(.APPROXGE.) + MODULE PURE ELEMENTAL FUNCTION approxge_1(r1, r2) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + LOGICAL(LGT) :: Ans + END FUNCTION approxge_1 + + MODULE PURE ELEMENTAL FUNCTION approxge_2(r1, r2) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + LOGICAL(LGT) :: Ans + END FUNCTION approxge_2 +END INTERFACE OPERATOR(.APPROXGE.) + +!---------------------------------------------------------------------------- +! SOFTEQ@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Defines the operator SOFTEQ + +INTERFACE softeq + MODULE PURE ELEMENTAL FUNCTION softeq_1(r1, r2, tol) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + REAL(REAL32), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softeq_1 + + MODULE PURE ELEMENTAL FUNCTION softeq_2(r1, r2, tol) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + REAL(REAL64), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softeq_2 +END INTERFACE softeq + +!---------------------------------------------------------------------------- +! SOFTEQR@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Defines the operator SOFTEQR + +INTERFACE SOFTEQR + MODULE PURE ELEMENTAL FUNCTION softeqr_1(r1, r2, tol) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + REAL(REAL32), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softeqr_1 + + MODULE PURE ELEMENTAL FUNCTION softeqr_2(r1, r2, tol) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + REAL(REAL64), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softeqr_2 +END INTERFACE SOFTEQR + +!---------------------------------------------------------------------------- +! SOFTLE@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: SOFTLE + +INTERFACE SOFTLE + MODULE PURE ELEMENTAL FUNCTION softle_1(r1, r2, tol) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + REAL(REAL32), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softle_1 + + MODULE PURE ELEMENTAL FUNCTION softle_2(r1, r2, tol) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + REAL(REAL64), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softle_2 +END INTERFACE SOFTLE + +!---------------------------------------------------------------------------- +! SOFTLT@ApproxMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Defines the operation for SOFTLT + +INTERFACE SOFTLT + MODULE PURE ELEMENTAL FUNCTION softlt_1(r1, r2, tol) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + REAL(REAL32), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softlt_1 + + MODULE PURE ELEMENTAL FUNCTION softlt_2(r1, r2, tol) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + REAL(REAL64), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softlt_2 +END INTERFACE SOFTLT + +!---------------------------------------------------------------------------- +! SOFTGE@ApproxMethods +!---------------------------------------------------------------------------- + +INTERFACE SOFTGE + MODULE PURE ELEMENTAL FUNCTION softge_1(r1, r2, tol) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + REAL(REAL32), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softge_1 + + MODULE PURE ELEMENTAL FUNCTION softge_2(r1, r2, tol) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + REAL(REAL64), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softge_2 +END INTERFACE SOFTGE + +!---------------------------------------------------------------------------- +! SOFTGT@ApproxMethods +!---------------------------------------------------------------------------- + +INTERFACE SOFTGT + MODULE PURE ELEMENTAL FUNCTION softgt_1(r1, r2, tol) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: r1 + REAL(REAL32), INTENT(IN) :: r2 + REAL(REAL32), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softgt_1 + + MODULE PURE ELEMENTAL FUNCTION softgt_2(r1, r2, tol) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: r1 + REAL(REAL64), INTENT(IN) :: r2 + REAL(REAL64), INTENT(IN) :: tol + LOGICAL(LGT) :: Ans + END FUNCTION softgt_2 +END INTERFACE SOFTGT + +!---------------------------------------------------------------------------- +! EQ@ApproxMethods +!---------------------------------------------------------------------------- + +INTERFACE OPERATOR(==) + MODULE PURE ELEMENTAL FUNCTION equalto_logical(l1, l2) RESULT(Ans) + LOGICAL(LGT), INTENT(IN) :: l1 + LOGICAL(LGT), INTENT(IN) :: l2 + LOGICAL(LGT) :: Ans + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! EQ@ApproxMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE ELEMENTAL FUNCTION notequalto_logical(l1, l2) RESULT(Ans) + LOGICAL(LGT), INTENT(IN) :: l1 + LOGICAL(LGT), INTENT(IN) :: l2 + LOGICAL(LGT) :: Ans + END FUNCTION +END INTERFACE + +INTERFACE OPERATOR(/=) + MODULE PROCEDURE notequalto_logical +END INTERFACE + +!---------------------------------------------------------------------------- +! ASSIGN@ApproxMethods +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_int8(i, c) + INTEGER(INT8), INTENT(OUT) :: i + CHARACTER(*), INTENT(IN) :: c + END SUBROUTINE assign_char_to_int8 + + MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Int16(i, c) + INTEGER(INT16), INTENT(OUT) :: i + CHARACTER(*), INTENT(IN) :: c + END SUBROUTINE assign_char_to_Int16 + + MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Int32(i, c) + INTEGER(INT32), INTENT(OUT) :: i + CHARACTER(*), INTENT(IN) :: c + END SUBROUTINE assign_char_to_Int32 + + MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Int64(i, c) + INTEGER(INT64), INTENT(OUT) :: i + CHARACTER(*), INTENT(IN) :: c + END SUBROUTINE assign_char_to_Int64 + + MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Real32(s, c) + REAL(REAL32), INTENT(OUT) :: s + CHARACTER(*), INTENT(IN) :: c + END SUBROUTINE assign_char_to_Real32 + + MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_Real64(s, c) + REAL(REAL64), INTENT(OUT) :: s + CHARACTER(*), INTENT(IN) :: c + END SUBROUTINE assign_char_to_Real64 + + MODULE PURE ELEMENTAL SUBROUTINE assign_char_to_bool(b, c) + LOGICAL(LGT), INTENT(OUT) :: b + CHARACTER(*), INTENT(IN) :: c + END SUBROUTINE assign_char_to_bool +END INTERFACE + +!---------------------------------------------------------------------------- +! @ApproxMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION isNumeric(char_str) RESULT(bool) + CHARACTER(*), INTENT(IN) :: char_str + LOGICAL(LGT) :: bool + END FUNCTION +END INTERFACE + +END MODULE ApproxUtility diff --git a/src/modules/Utility/src/ArangeUtility.F90 b/src/modules/Utility/src/ArangeUtility.F90 new file mode 100644 index 000000000..be366b0ca --- /dev/null +++ b/src/modules/Utility/src/ArangeUtility.F90 @@ -0,0 +1,115 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 ArangeUtility +USE GlobalData +IMPLICIT NONE +PUBLIC :: arange + +!---------------------------------------------------------------------------- +! arange@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: Returns a vector of reals given `start`, `end`, and `increment` +! values. + +INTERFACE arange + MODULE PURE FUNCTION arange_Real64(istart, iend, increment) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: istart + !! Start value of the array + REAL(REAL64), INTENT(IN) :: iend + !! End value of the array + REAL(REAL64), INTENT(IN), OPTIONAL :: increment + !! Array increment + REAL(REAL64), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION arange_Real64 +END INTERFACE arange + +!---------------------------------------------------------------------------- +! arange@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: Returns a vector of reals given `start`, `end`, and `increment` +! values. + +INTERFACE arange + MODULE PURE FUNCTION arange_Real32(istart, iend, increment) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: istart + !! Start value of the array + REAL(REAL32), INTENT(IN) :: iend + !! End value of the array + REAL(REAL32), INTENT(IN), OPTIONAL :: increment + !! Array increment + REAL(REAL32), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION arange_Real32 +END INTERFACE arange + +!---------------------------------------------------------------------------- +! arange@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: Returns a vector of integer +! +!# Introduction +! Returns an array of integers given `istart`, `iend`, and +! `increment` values. Default value of increment is 1 +! This function belongs to the generic function [[Utility:arange]] +! +!### Usage +! +!```fortran +! arange(1,10,1) +! arange(1,10,2) +!``` + +INTERFACE arange + MODULE PURE FUNCTION arange_Int8(istart, iend, increment) RESULT(Ans) + INTEGER(Int8), INTENT(IN) :: istart + INTEGER(Int8), INTENT(IN) :: iend + INTEGER(Int8), INTENT(IN), OPTIONAL :: increment + INTEGER(Int8), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION arange_Int8 + + MODULE PURE FUNCTION arange_Int16(istart, iend, increment) RESULT(Ans) + INTEGER(Int16), INTENT(IN) :: istart + INTEGER(Int16), INTENT(IN) :: iend + INTEGER(Int16), INTENT(IN), OPTIONAL :: increment + INTEGER(Int16), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION arange_Int16 + + MODULE PURE FUNCTION arange_Int32(istart, iend, increment) RESULT(Ans) + INTEGER(Int32), INTENT(IN) :: istart + INTEGER(Int32), INTENT(IN) :: iend + INTEGER(Int32), INTENT(IN), OPTIONAL :: increment + INTEGER(Int32), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION arange_Int32 + + MODULE PURE FUNCTION arange_Int64(istart, iend, increment) RESULT(Ans) + INTEGER(Int64), INTENT(IN) :: istart + INTEGER(Int64), INTENT(IN) :: iend + INTEGER(Int64), INTENT(IN), OPTIONAL :: increment + INTEGER(Int64), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION arange_Int64 +END INTERFACE arange + +END MODULE ArangeUtility diff --git a/src/modules/Utility/src/AssertUtility.F90 b/src/modules/Utility/src/AssertUtility.F90 new file mode 100644 index 000000000..b2d673b79 --- /dev/null +++ b/src/modules/Utility/src/AssertUtility.F90 @@ -0,0 +1,146 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 AssertUtility +USE GlobalData, ONLY: I4B, DFP +IMPLICIT NONE +PRIVATE +PUBLIC :: ASSERT +PUBLIC :: ASSERT_EQ + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT_EQ + MODULE FUNCTION assert_eq2(n1, n2, string) + INTEGER(I4B), INTENT(IN) :: n1, n2 + CHARACTER(*), INTENT(IN) :: string + INTEGER(I4B) :: assert_eq2 + END FUNCTION +END INTERFACE ASSERT_EQ + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT_EQ + MODULE FUNCTION assert_eq3(n1, n2, n3, string) + INTEGER(I4B), INTENT(IN) :: n1, n2, n3 + CHARACTER(*), INTENT(IN) :: string + INTEGER(I4B) :: assert_eq3 + END FUNCTION +END INTERFACE ASSERT_EQ + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT_EQ + MODULE FUNCTION assert_eq4(n1, n2, n3, n4, string) + INTEGER(I4B), INTENT(IN) :: n1, n2, n3, n4 + CHARACTER(*), INTENT(IN) :: string + INTEGER(I4B) :: assert_eq4 + END FUNCTION +END INTERFACE ASSERT_EQ + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT_EQ + MODULE FUNCTION assert_eqn(nn, string) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn + CHARACTER(*), INTENT(IN) :: string + INTEGER(I4B) :: assert_eqn + END FUNCTION +END INTERFACE ASSERT_EQ + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT + MODULE SUBROUTINE assert_shape_2(Mat, s, msg, file, line, routine) + REAL(DFP), INTENT(IN) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: s(2) + INTEGER(I4B), INTENT(IN) :: line + CHARACTER(*), INTENT(IN) :: msg, file, routine + END SUBROUTINE +END INTERFACE ASSERT + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT + MODULE SUBROUTINE assert_shape_3(Mat, s, msg, file, line, routine) + REAL(DFP), INTENT(IN) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: s(3) + INTEGER(I4B), INTENT(IN) :: line + CHARACTER(*), INTENT(IN) :: msg, file, routine + END SUBROUTINE +END INTERFACE ASSERT + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT + MODULE SUBROUTINE assert_shape_4(Mat, s, msg, file, line, routine) + REAL(DFP), INTENT(IN) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(4) + INTEGER(I4B), INTENT(IN) :: line + CHARACTER(*), INTENT(IN) :: msg, file, routine + END SUBROUTINE +END INTERFACE ASSERT + +!---------------------------------------------------------------------------- +! Assert@Assert +!---------------------------------------------------------------------------- + +INTERFACE ASSERT + MODULE SUBROUTINE assert_2(n1, n2, msg, file, line, routine) + INTEGER(I4B), INTENT(IN) :: n1, n2 + INTEGER(I4B), INTENT(IN) :: line + CHARACTER(*), INTENT(IN) :: msg, file, routine + END SUBROUTINE assert_2 + + MODULE SUBROUTINE assert_3(n1, n2, n3, msg, file, line, routine) + INTEGER(I4B), INTENT(IN) :: n1, n2, n3 + INTEGER(I4B), INTENT(IN) :: line + CHARACTER(*), INTENT(IN) :: msg, file, routine + END SUBROUTINE assert_3 + + MODULE SUBROUTINE assert_4(n1, n2, n3, n4, msg, file, line, routine) + INTEGER(I4B), INTENT(IN) :: n1, n2, n3, n4 + INTEGER(I4B), INTENT(IN) :: line + CHARACTER(*), INTENT(IN) :: msg, file, routine + END SUBROUTINE assert_4 + + MODULE SUBROUTINE assert_n(nn, msg, file, line, routine) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn + INTEGER(I4B), INTENT(IN) :: line + CHARACTER(*), INTENT(IN) :: msg, file, routine + END SUBROUTINE assert_n +END INTERFACE ASSERT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE AssertUtility diff --git a/src/modules/Utility/src/BinomUtility.F90 b/src/modules/Utility/src/BinomUtility.F90 new file mode 100644 index 000000000..4959014f5 --- /dev/null +++ b/src/modules/Utility/src/BinomUtility.F90 @@ -0,0 +1,132 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 BinomUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Binom + +!---------------------------------------------------------------------------- +! Binom +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Compute the Binomial coefficient +! +!# Introduction +! +! This routine calculates the bionomial coefficient $C_{k}^{n}$ +! +! Usages is given below +! +! +!## Usage +! +!```fortran +! ans = Binom( n=10, k=2 ) +!``` + +INTERFACE + MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int8(n, k, kind) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: n + !! n is integer, should be a positive number and greater or equal to k + INTEGER(INT8), INTENT(IN) :: k + REAL(REAL32), INTENT(IN) :: kind + REAL(REAL32) :: ans + END FUNCTION Real32_Binom_Int8 +END INTERFACE + +!---------------------------------------------------------------------------- +! Binom +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int16(n, k, kind) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: n + INTEGER(INT16), INTENT(IN) :: k + REAL(REAL32), INTENT(IN) :: kind + REAL(REAL32) :: ans + END FUNCTION Real32_Binom_Int16 +END INTERFACE + +!---------------------------------------------------------------------------- +! Binom +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int32(n, k, kind) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: n + INTEGER(INT32), INTENT(IN) :: k + REAL(REAL32), INTENT(IN) :: kind + REAL(REAL32) :: ans + END FUNCTION Real32_Binom_Int32 + !! + MODULE RECURSIVE PURE FUNCTION Real32_Binom_Int64(n, k, kind) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: n + INTEGER(INT64), INTENT(IN) :: k + REAL(REAL32), INTENT(IN) :: kind + REAL(REAL32) :: ans + END FUNCTION Real32_Binom_Int64 +END INTERFACE + +INTERFACE Binom + MODULE PROCEDURE Real32_Binom_Int8, Real32_Binom_Int16, & + & Real32_Binom_Int32, Real32_Binom_Int64 +END INTERFACE Binom + +!---------------------------------------------------------------------------- +! Binom +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int8(n, k, kind) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: n + INTEGER(INT8), INTENT(IN) :: k + REAL(REAL64), INTENT(IN) :: kind + REAL(REAL64) :: ans + END FUNCTION Real64_Binom_Int8 + !! + MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int16(n, k, kind) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: n + INTEGER(INT16), INTENT(IN) :: k + REAL(REAL64), INTENT(IN) :: kind + REAL(REAL64) :: ans + END FUNCTION Real64_Binom_Int16 + !! + MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int32(n, k, kind) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: n + INTEGER(INT32), INTENT(IN) :: k + REAL(REAL64), INTENT(IN) :: kind + REAL(REAL64) :: ans + END FUNCTION Real64_Binom_Int32 + !! + MODULE RECURSIVE PURE FUNCTION Real64_Binom_Int64(n, k, kind) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: n + INTEGER(INT64), INTENT(IN) :: k + REAL(REAL64), INTENT(IN) :: kind + REAL(REAL64) :: ans + END FUNCTION Real64_Binom_Int64 +END INTERFACE + +INTERFACE Binom + MODULE PROCEDURE Real64_Binom_Int8, Real64_Binom_Int16, & + & Real64_Binom_Int32, Real64_Binom_Int64 +END INTERFACE Binom + +END MODULE BinomUtility diff --git a/src/modules/Utility/src/ContractionUtility.F90 b/src/modules/Utility/src/ContractionUtility.F90 new file mode 100644 index 000000000..45f15dce3 --- /dev/null +++ b/src/modules/Utility/src/ContractionUtility.F90 @@ -0,0 +1,416 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 ContractionUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j,k) = a1(i,j,k,l)*a2(l)` + +INTERFACE + MODULE PURE FUNCTION Contraction_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)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r4_r1 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j) = a1(i,j,k,l)*a2(k,l)` + +INTERFACE + MODULE PURE FUNCTION Contraction_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)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r4_r2 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(i) = a1(i,j,k,l)*a2(j,k,l)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r4_r3(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP) :: ans(SIZE(a1, 1)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r4_r3 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans = a1(i,j,k,l)*a2(i,j,k,l)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r4_r4(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP) :: ans + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r4_r4 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank3 and rank1 array +! +!# Introduction +! +! This fuction performs following task +! `ans(i,j) = a1(i,j,k)*a2(k)` + +INTERFACE + MODULE PURE FUNCTION Contraction_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)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r3_r1 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank3 and rank2 +! +!# Introduction +! This fuction performs following task +! `ans(i) = a1(i,j,k)*a2(j,k)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r3_r2(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :) + REAL(DFP) :: ans(SIZE(a1, 1)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r3_r2 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans = a1(i,j,k) * a2(i,j,k)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r3_r3(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP) :: ans + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r3_r3 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(l) = a1(i,j,k) * a2(i,j,k,l)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r3_r4(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP) :: ans(SIZE(a2, 4)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r3_r4 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank3 and rank1 array +! +!# Introduction +! +! This fuction performs following task +! `ans(i) = a1(i,j)*a2(j)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r2_r1(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :) + REAL(DFP), INTENT(IN) :: a2(:) + REAL(DFP) :: ans(SIZE(a1, 1)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r2_r1 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank3 and rank2 +! +!# Introduction +! This fuction performs following task +! `ans = a1(i,j)*a2(i,j)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r2_r2(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :) + REAL(DFP), INTENT(IN) :: a2(:, :) + REAL(DFP) :: ans + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r2_r2 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(k) = a1(i,j) * a2(i,j,k)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r2_r3(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP) :: ans(SIZE(a2, 3)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r2_r3 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(k,l) = a1(i,j) * a2(i,j,k,l)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r2_r4(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP) :: ans(SIZE(a2, 3), SIZE(a2, 4)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r2_r4 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank3 and rank1 array +! +!# Introduction +! +! This fuction performs following task +! `ans = a1(i)*a2(i)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r1_r1(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:) + REAL(DFP), INTENT(IN) :: a2(:) + REAL(DFP) :: ans + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r1_r1 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank3 and rank2 +! +!# Introduction +! This fuction performs following task +! `ans(j) = a1(i)*a2(i,j)` + +INTERFACE + MODULE PURE FUNCTION Contraction_r1_r2(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:) + REAL(DFP), INTENT(IN) :: a2(:, :) + REAL(DFP) :: ans(SIZE(a2, 2)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r1_r2 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(j,k) = a1(i) * a2(i,j,k)` + +INTERFACE + MODULE PURE FUNCTION Contraction_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)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r1_r3 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! Contraction@Contraction +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Contraction for rank4 and rank1 array +! +!# Introduction +! +! `ans(j, k,l) = a1(i) * a2(i,j,k,l)` + +INTERFACE + MODULE PURE FUNCTION Contraction_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)) + END FUNCTION +END INTERFACE + +INTERFACE Contraction + MODULE PROCEDURE Contraction_r1_r4 +END INTERFACE Contraction + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ContractionUtility diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90 new file mode 100644 index 000000000..9deec4303 --- /dev/null +++ b/src/modules/Utility/src/ConvertUtility.F90 @@ -0,0 +1,151 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 ConvertUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Convert +PUBLIC :: ConvertSafe + +!---------------------------------------------------------------------------- +! Convert@ConvertMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Rearrange the degrees of freedom in a finite element matrix +! +!# Introduction +! +! This subroutine changes the storage pattern of a two-d matrix +! - Usually element matrix in easifem are stored in `FMT_DOF` +! - Global matrices/tanmat, however, are stored in `FMT_Nodes` +! - This subroutine is, therefore, in settings or adding values in +! [[SparseMatrix_]]. +! +! > This subroutine converts changes the storage format of dense matrix. +! Usually, elemental finite element matrix is stored in `DOF_FMT`, and global +! matrix/ tanmat, may be stored in `Nodes_FMT`. +! +!@note +! All dof should have the same order of interpolation, therefore, +! this routine works when matrix is square. +!@endnote + +INTERFACE Convert + MODULE PURE SUBROUTINE convert_1(From, To, Conversion, nns, tdof) + REAL(DFP), INTENT(IN) :: From(:, :) + !! Matrix in one format + 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) :: nns, tdof + END SUBROUTINE convert_1 +END INTERFACE Convert + +!---------------------------------------------------------------------------- +! Convert@ConvertMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Rearrange the degrees of freedom in a finite element matrix +! +!# Introduction +! +! This subroutine changes the storage pattern of a two-d matrix +! - Usually element matrix in easifem are stored in `FMT_DOF` +! - Global matrices/tanmat, however, are stored in `FMT_Nodes` +! - This subroutine is, therefore, in settings or adding values in +! [[SparseMatrix_]]. +! +! > This subroutine converts changes the storage format of dense matrix. +! Usually, elemental finite element matrix is stored in `DOF_FMT`, and global +! matrix/ tanmat, may be stored in `Nodes_FMT`. +! +!@note +! All dof should have the same order of interpolation, therefore, +! this routine works when matrix is square. +!@endnote + +INTERFACE ConvertSafe + MODULE PURE SUBROUTINE convert_1_safe(From, To, Conversion, nns, tdof) + 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 + END SUBROUTINE convert_1_safe +END INTERFACE ConvertSafe + +!---------------------------------------------------------------------------- +! Convert@ConvertMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine converts rank4 matrix to rank2 matrix +! +!# Introduction +! +! 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 +! +! - In this way `From(:, :, a, b)` denotes the `a,b` block 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 +END INTERFACE Convert + +!---------------------------------------------------------------------------- +! Convert@ConvertMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: This subroutine converts rank4 matrix to rank2 matrix +! + +INTERFACE Convert + MODULE PURE SUBROUTINE convert_3(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 convert_3 +END INTERFACE Convert + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ConvertUtility diff --git a/src/modules/Utility/src/DiagUtility.F90 b/src/modules/Utility/src/DiagUtility.F90 new file mode 100644 index 000000000..84dc81844 --- /dev/null +++ b/src/modules/Utility/src/DiagUtility.F90 @@ -0,0 +1,441 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 DiagUtility +USE GlobalData, ONLY: I4B, INT8, INT16, INT32, INT64, & +& REAL32, REAL64, DFP +#ifdef USE_Int128 +USE GlobaData, ONLY: Int128 +#endif +IMPLICIT NONE +PRIVATE + +PUBLIC :: Diag +PUBLIC :: SetDiag +PUBLIC :: DiagSize +PUBLIC :: DiagIndx +PUBLIC :: TriDiag +PUBLIC :: SetTriDiag + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-11 +! summary: Make a Diagonal matrix from int8 vector + +INTERFACE + MODULE PURE FUNCTION Diag_1(a) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a(:) + REAL(DFP) :: ans(SIZE(a), SIZE(a)) + END FUNCTION Diag_1 + + MODULE PURE FUNCTION Diag_2(a) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a(:) + REAL(DFP) :: ans(SIZE(a), SIZE(a)) + END FUNCTION Diag_2 + + MODULE PURE FUNCTION Diag_3(a) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a(:) + REAL(DFP) :: ans(SIZE(a), SIZE(a)) + END FUNCTION Diag_3 + + MODULE PURE FUNCTION Diag_4(a) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a(:) + REAL(DFP) :: ans(SIZE(a), SIZE(a)) + END FUNCTION Diag_4 + + MODULE PURE FUNCTION Diag_5(a) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: a(:) + REAL(DFP) :: ans(SIZE(a), SIZE(a)) + END FUNCTION Diag_5 + + MODULE PURE FUNCTION Diag_6(a) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: a(:) + REAL(DFP) :: ans(SIZE(a), SIZE(a)) + END FUNCTION Diag_6 +END INTERFACE + +INTERFACE Diag + MODULE PROCEDURE Diag_1, Diag_2, Diag_3, Diag_4, Diag_5, & + & Diag_6 +END INTERFACE Diag + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-11 +! summary: Make diagonal matrix from Int128 vector. + +INTERFACE + MODULE PURE FUNCTION Diag_7(a) RESULT(Ans) + INTEGER(Int128), INTENT(IN) :: a(:) + REAL(DFP) :: ans(SIZE(a), SIZE(a)) + END FUNCTION Diag_7 +END INTERFACE + +INTERFACE Diag + MODULE PROCEDURE Diag_7 +END INTERFACE Diag + +#endif + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-11 +! summary: Get the diagNo of matrix +! +!# Introduction +! +!- This routine returns the diagonal of matrix. +!- `diagNo=0` denotes main diagonal +!- `diagNo>0` denotes the super-diagonal +!- `diagNo<0` denotes the sub-diagonal +!- `d` is a one dimesional vector of default Reals (DFP) + +INTERFACE + MODULE PURE FUNCTION Diag_8(mat, diagNo) RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(:, :) + !! matrix + INTEGER(I4B), INTENT(IN) :: diagNo + !! diagonal number + REAL(DFP), ALLOCATABLE :: ans(:) + !! diagonal + END FUNCTION Diag_8 + +END INTERFACE + +INTERFACE Diag + MODULE PROCEDURE Diag_8 +END INTERFACE Diag + +!---------------------------------------------------------------------------- +! SetDiag +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-11 +! summary: Set the diagNo of matrix +! +!# Introduction +! +!- This routine sets the diagonal of matrix. +! +!- `diagNo=0` denotes main diagonal +!- `diagNo>0` denotes the super-diagonal +!- `diagNo<0` denotes the sub-diagonal +! +!- `d` is a one dimesional vector of (Int or float) +!- if `size(d)=1`, then all entries of the diagonal will be set to this +! value. +!- if `size(d) .ne. 1`, then the size of `d` should be atleast the size of +! diagonal number `diag`. + +INTERFACE + MODULE PURE SUBROUTINE SetDiag1(mat, d, diagNo) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + INTEGER(INT8), INTENT(IN) :: d(:) + INTEGER(I4B), INTENT(IN) :: diagNo + END SUBROUTINE SetDiag1 + MODULE PURE SUBROUTINE SetDiag2(mat, d, diagNo) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + INTEGER(INT16), INTENT(IN) :: d(:) + INTEGER(I4B), INTENT(IN) :: diagNo + END SUBROUTINE SetDiag2 + MODULE PURE SUBROUTINE SetDiag3(mat, d, diagNo) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + INTEGER(INT32), INTENT(IN) :: d(:) + INTEGER(I4B), INTENT(IN) :: diagNo + END SUBROUTINE SetDiag3 + MODULE PURE SUBROUTINE SetDiag4(mat, d, diagNo) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + INTEGER(INT64), INTENT(IN) :: d(:) + INTEGER(I4B), INTENT(IN) :: diagNo + END SUBROUTINE SetDiag4 + MODULE PURE SUBROUTINE SetDiag5(mat, d, diagNo) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + REAL(REAL32), INTENT(IN) :: d(:) + INTEGER(I4B), INTENT(IN) :: diagNo + END SUBROUTINE SetDiag5 + MODULE PURE SUBROUTINE SetDiag6(mat, d, diagNo) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + REAL(REAL64), INTENT(IN) :: d(:) + INTEGER(I4B), INTENT(IN) :: diagNo + END SUBROUTINE SetDiag6 +END INTERFACE + +INTERFACE SetDiag + MODULE PROCEDURE SetDiag1, SetDiag2, SetDiag3, SetDiag4, & + & SetDiag5, SetDiag6 +END INTERFACE SetDiag + +!---------------------------------------------------------------------------- +! DiagSize +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION DiagSize1(n, diagNo) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! size of matrix + INTEGER(I4B), INTENT(IN) :: diagNo + !! diagonal number + INTEGER(I4B) :: ans + !! size of diagonal + END FUNCTION DiagSize1 +END INTERFACE + +INTERFACE DiagSize + MODULE PROCEDURE DiagSize1 +END INTERFACE DiagSize + +!---------------------------------------------------------------------------- +! DiagSize +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION DiagSize2(m, n, diagNo) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + !! number of rows in matrix + INTEGER(I4B), INTENT(IN) :: n + !! number of columns in a matrix + INTEGER(I4B), INTENT(IN) :: diagNo + !! diagonal number + INTEGER(I4B) :: ans + !! size of diagonal + END FUNCTION DiagSize2 +END INTERFACE + +INTERFACE DiagSize + MODULE PROCEDURE DiagSize2 +END INTERFACE DiagSize + +!---------------------------------------------------------------------------- +! DiagSize +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION DiagIndx(m, n, diagNo) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + !! number of rows in matrix + INTEGER(I4B), INTENT(IN) :: n + !! number of columns in a matrix + INTEGER(I4B), INTENT(IN) :: diagNo + !! diagonal number + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + !! size of diagonal + END FUNCTION DiagIndx +END INTERFACE + +!---------------------------------------------------------------------------- +! SetTriDiag +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-11 +! summary: Set the diagNo of tri diagonal matrix +! +!# Introduction +! +!- This routine sets the diagonals of a tridiagonal matrix. +! +!- `d` denotes main diagonal +!- `da` denotes the super-diagonal +!- `db` denotes the sub-diagonal +! +!- `d, da, db` are one dimesional vectors of (Int or float) +!- if `size(d/da/db)=1`, then all entries of the diagonal will be set to this +! value. +!- if `size(d/da/db) .ne. 1`, then the size of `d/da/db` should be atleast +! the size of respective diagonals. + +INTERFACE + MODULE PURE SUBROUTINE SetTriDiag1(mat, d, da, db) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + !! tri diagonal matrix dense form + INTEGER(INT8), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT8), INTENT(IN) :: da(:) + !! super-diagonal, (a, for above) + INTEGER(INT8), INTENT(IN) :: db(:) + !! sub-diagonal (b for below) + END SUBROUTINE SetTriDiag1 + + MODULE PURE SUBROUTINE SetTriDiag2(mat, d, da, db) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + !! tri diagonal matrix dense form + INTEGER(INT16), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT16), INTENT(IN) :: da(:) + !! super-diagonal, (a, for above) + INTEGER(INT16), INTENT(IN) :: db(:) + !! sub-diagonal (b for below) + END SUBROUTINE SetTriDiag2 + + MODULE PURE SUBROUTINE SetTriDiag3(mat, d, da, db) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + !! tri diagonal matrix dense form + INTEGER(INT32), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT32), INTENT(IN) :: da(:) + !! super-diagonal, (a, for above) + INTEGER(INT32), INTENT(IN) :: db(:) + !! sub-diagonal (b for below) + END SUBROUTINE SetTriDiag3 + + MODULE PURE SUBROUTINE SetTriDiag4(mat, d, da, db) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + !! tri diagonal matrix dense form + INTEGER(INT64), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT64), INTENT(IN) :: da(:) + !! super-diagonal, (a, for above) + INTEGER(INT64), INTENT(IN) :: db(:) + !! sub-diagonal (b for below) + END SUBROUTINE SetTriDiag4 + + MODULE PURE SUBROUTINE SetTriDiag5(mat, d, da, db) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + !! tri diagonal matrix dense form + REAL(REAL32), INTENT(IN) :: d(:) + !! main diagonal + REAL(REAL32), INTENT(IN) :: da(:) + !! super-diagonal, (a, for above) + REAL(REAL32), INTENT(IN) :: db(:) + !! sub-diagonal (b for below) + END SUBROUTINE SetTriDiag5 + + MODULE PURE SUBROUTINE SetTriDiag6(mat, d, da, db) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + !! tri diagonal matrix dense form + REAL(REAL64), INTENT(IN) :: d(:) + !! main diagonal + REAL(REAL64), INTENT(IN) :: da(:) + !! super-diagonal, (a, for above) + REAL(REAL64), INTENT(IN) :: db(:) + !! sub-diagonal (b for below) + END SUBROUTINE SetTriDiag6 + +END INTERFACE + +INTERFACE SetTriDiag + MODULE PROCEDURE SetTriDiag1, SetTriDiag2, SetTriDiag3, SetTriDiag4, & + & SetTriDiag5, SetTriDiag6 +END INTERFACE SetTriDiag + +!---------------------------------------------------------------------------- +! Tridiag +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-11 +! summary: Make a Tridiagonal matrix from main, sub, super diagonal + +INTERFACE + MODULE PURE FUNCTION Tridiag_1(d, da, db, diagNo) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT8), INTENT(IN) :: da(:) + !! super diagonal + INTEGER(INT8), INTENT(IN) :: db(:) + !! subdiagonal + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! sub and super diagonal number, default is 1 + !! diagNo should be positive + REAL(DFP) :: ans(SIZE(d), SIZE(d)) + END FUNCTION Tridiag_1 + + MODULE PURE FUNCTION Tridiag_2(d, da, db, diagNo) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT16), INTENT(IN) :: da(:) + !! super diagonal + INTEGER(INT16), INTENT(IN) :: db(:) + !! subdiagonal + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! sub and super diagonal number, default is 1 + !! diagNo should be positive + REAL(DFP) :: ans(SIZE(d), SIZE(d)) + END FUNCTION Tridiag_2 + + MODULE PURE FUNCTION Tridiag_3(d, da, db, diagNo) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT32), INTENT(IN) :: da(:) + !! super diagonal + INTEGER(INT32), INTENT(IN) :: db(:) + !! subdiagonal + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! sub and super diagonal number, default is 1 + !! diagNo should be positive + REAL(DFP) :: ans(SIZE(d), SIZE(d)) + END FUNCTION Tridiag_3 + + MODULE PURE FUNCTION Tridiag_4(d, da, db, diagNo) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: d(:) + !! main diagonal + INTEGER(INT64), INTENT(IN) :: da(:) + !! super diagonal + INTEGER(INT64), INTENT(IN) :: db(:) + !! subdiagonal + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! sub and super diagonal number, default is 1 + !! diagNo should be positive + REAL(DFP) :: ans(SIZE(d), SIZE(d)) + END FUNCTION Tridiag_4 + + MODULE PURE FUNCTION Tridiag_5(d, da, db, diagNo) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: d(:) + !! main diagonal + REAL(REAL32), INTENT(IN) :: da(:) + !! super diagonal + REAL(REAL32), INTENT(IN) :: db(:) + !! subdiagonal + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! sub and super diagonal number, default is 1 + !! diagNo should be positive + REAL(DFP) :: ans(SIZE(d), SIZE(d)) + END FUNCTION Tridiag_5 + + MODULE PURE FUNCTION Tridiag_6(d, da, db, diagNo) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: d(:) + !! main diagonal + REAL(REAL64), INTENT(IN) :: da(:) + !! super diagonal + REAL(REAL64), INTENT(IN) :: db(:) + !! subdiagonal + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! sub and super diagonal number, default is 1 + !! diagNo should be positive + REAL(DFP) :: ans(SIZE(d), SIZE(d)) + END FUNCTION Tridiag_6 + +END INTERFACE + +INTERFACE Tridiag + MODULE PROCEDURE Tridiag_1, Tridiag_2, Tridiag_3, Tridiag_4, Tridiag_5, & + & Tridiag_6 +END INTERFACE Tridiag + +END MODULE DiagUtility diff --git a/src/modules/Utility/src/EigenUtility.F90 b/src/modules/Utility/src/EigenUtility.F90 new file mode 100644 index 000000000..1995d8b4b --- /dev/null +++ b/src/modules/Utility/src/EigenUtility.F90 @@ -0,0 +1,187 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 EigenUtility +USE GlobalData +IMPLICIT NONE + +PUBLIC :: SymEigenValues2by2 +PUBLIC :: SymEigenValues3by3 +PUBLIC :: SymEigenValuesUpto3 +PUBLIC :: SymEigenValues +PUBLIC :: GetSymEigenValues +PUBLIC :: GetSymEigenValues_ +PUBLIC :: GetSymEigenJacobi + +!---------------------------------------------------------------------------- +! SymEigen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-26 +! summary: Eigenvalue of 2 by 2 symmetric matrix + +INTERFACE + MODULE PURE FUNCTION SymEigenValues2by2(mat) RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(2, 2) + REAL(DFP) :: ans(2) + END FUNCTION SymEigenValues2by2 +END INTERFACE + +!---------------------------------------------------------------------------- +! SymEigen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-26 +! summary: Eigenvalue of 3 by 3 symmetric matrix + +INTERFACE + MODULE PURE FUNCTION SymEigenValues3by3(mat) RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(3, 3) + REAL(DFP) :: ans(3) + END FUNCTION SymEigenValues3by3 +END INTERFACE + +!---------------------------------------------------------------------------- +! SymEigen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-26 +! summary: Eigenvalue of 3 by 3 or 2 by 2 symmetric matrix + +INTERFACE + MODULE PURE FUNCTION SymEigenValuesUpto3(mat) RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(:, :) + !! size(mat, 1) = [1,2,3] + REAL(DFP) :: ans(SIZE(mat, 1)) + END FUNCTION SymEigenValuesUpto3 +END INTERFACE + +!---------------------------------------------------------------------------- +! SymEigen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Nov 2022 +! summary: Compute eigenvalues of matrix +! +!# Introduction +! +! Calculate eigenvalues of symetric matrix. +! +!- If `n=2` call SymEigenValues2by2 +!- If `n=3` call SymEigenValues3by3 +!- If `n>=4` call SYEV from Lapack, It needs Lapack95 interface + +INTERFACE + MODULE FUNCTION SymEigenValues(mat) RESULT(ans) + REAL(DFP), INTENT(IN) :: mat(:, :) + !! for n=2, we call SymEigenValues2by2 + !! for n=3, we call SymEigenValues3by3 + !! for n>=4, we call Lapack + REAL(DFP) :: ans(SIZE(mat, 1)) + END FUNCTION SymEigenValues +END INTERFACE + +!---------------------------------------------------------------------------- +! GetSymEigen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Nov 2022 +! summary: Compute eigenvalues of matrix +! +!# Introduction +! +! Calculate eigenvalues of symetric matrix. +! +!- If `n=2` call SymEigenValues2by2 +!- If `n=3` call SymEigenValues3by3 +!- If `n>=4` call SYEV from Lapack, It needs Lapack95 interface + +INTERFACE + MODULE SUBROUTINE GetSymEigenValues(mat, eigenValues) + REAL(DFP), INTENT(IN) :: mat(:, :) + REAL(DFP), INTENT(OUT) :: eigenValues(:) + END SUBROUTINE GetSymEigenValues +END INTERFACE + +!---------------------------------------------------------------------------- +! GetSymEigen +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Nov 2022 +! summary: Compute eigenvalues of matrix +! +!# Introduction +! +! Calculate eigenvalues of symetric matrix. +! +!- If `n=2` call SymEigenValues2by2 +!- If `n=3` call SymEigenValues3by3 +!- If `n>=4` call SYEV from Lapack, It needs Lapack95 interface +! +!- mat will be destroyed. + +INTERFACE + MODULE SUBROUTINE GetSymEigenValues_(mat, eigenValues) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + REAL(DFP), INTENT(OUT) :: eigenValues(:) + END SUBROUTINE GetSymEigenValues_ +END INTERFACE + +!---------------------------------------------------------------------------- +! GetSymEigenJacobi@LAPACK +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 March 2021 +! summary: Returns all the eigenvalues of symmetric matrix +! +!# Introduction +! +! This subroutine computes all eigenvalues and eigenvectors of a real +! symmetric N × N matrix `Mat`. +! - On output, elements of `Mat` above the diagonal are destroyed. +! - `eigenvalues` is a vector of length N that returns the eigenvalues of +! `Mat`. +! - `EigenVectors` is an `N × N` matrix whose columns contain on output, +! the normalized eigenvectors (directions) of `Mat`. +! - `maxIter` returns the number of Jacobi rotations that were required. +! +! ### Reference:: Numerical Reciepe in Fortran, Page 1225 +! +! TODO: Remove this subroutine, instead call Lapack. + +INTERFACE + MODULE PURE SUBROUTINE GetSymEigenJacobi(mat, eigenValues, eigenVectors, & + & maxIter) + REAL(DFP), INTENT(IN) :: mat(:, :) + REAL(DFP), INTENT(INOUT) :: eigenValues(:) + REAL(DFP), INTENT(INOUT) :: eigenVectors(:, :) + INTEGER(I4B), INTENT(IN) :: maxIter + END SUBROUTINE GetSymEigenJacobi +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE EigenUtility diff --git a/src/modules/Utility/src/EyeUtility.F90 b/src/modules/Utility/src/EyeUtility.F90 new file mode 100644 index 000000000..d9e77b7bd --- /dev/null +++ b/src/modules/Utility/src/EyeUtility.F90 @@ -0,0 +1,140 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 EyeUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Eye + +!---------------------------------------------------------------------------- +! Eye@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-26 +! summary: Return an identity matrix of an integers + +INTERFACE + MODULE PURE FUNCTION int_eye_1(m, DataType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8) :: ans(m, m) + END FUNCTION int_eye_1 + + MODULE PURE FUNCTION int_eye_2(m, DataType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16) :: ans(m, m) + END FUNCTION int_eye_2 + + MODULE PURE FUNCTION int_eye_3(m, DataType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32) :: ans(m, m) + END FUNCTION int_eye_3 + + MODULE PURE FUNCTION int_eye_4(m, DataType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64) :: ans(m, m) + END FUNCTION int_eye_4 +END INTERFACE + +INTERFACE Eye + MODULE PROCEDURE int_eye_1, int_eye_2, int_eye_3, int_eye_4 +END INTERFACE Eye + +#ifdef USE_Int128 +INTERFACE + MODULE PURE FUNCTION int_eye_5(m, DataType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + INTEGER(Int128), INTENT(IN) :: DataType + INTEGER(Int128) :: ans(m, m) + END FUNCTION int_eye_5 +END INTERFACE + +INTERFACE Eye + MODULE PROCEDURE int_eye_5 +END INTERFACE Eye +#endif + +!---------------------------------------------------------------------------- +! Eye@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-26 +! summary: Return identity matrix of real numbers +INTERFACE + + MODULE PURE FUNCTION real_eye_1(m, DataType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + REAL(REAL64) :: ans(m, m) + REAL(REAL64), INTENT(IN) :: DataType + END FUNCTION real_eye_1 +END INTERFACE + +INTERFACE Eye + MODULE PROCEDURE real_eye_1 +END INTERFACE Eye + +!---------------------------------------------------------------------------- +! Eye@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-26 +! summary: Return identity matrix of real number +INTERFACE + + MODULE PURE FUNCTION real_eye_2(m) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + REAL(DFP) :: ans(m, m) + END FUNCTION real_eye_2 +END INTERFACE + +INTERFACE Eye + MODULE PROCEDURE real_eye_2 +END INTERFACE Eye + +!---------------------------------------------------------------------------- +! Eye@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-26 +! summary: Return identity matrix of real numbers +INTERFACE + + MODULE PURE FUNCTION real_eye_3(m, DataType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + REAL(REAL32) :: ans(m, m) + REAL(REAL32), INTENT(IN) :: DataType + END FUNCTION real_eye_3 +END INTERFACE + +INTERFACE Eye + MODULE PROCEDURE real_eye_3 +END INTERFACE Eye + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE EyeUtility diff --git a/src/modules/Utility/src/GridPointUtility.F90 b/src/modules/Utility/src/GridPointUtility.F90 new file mode 100644 index 000000000..dbc2b8feb --- /dev/null +++ b/src/modules/Utility/src/GridPointUtility.F90 @@ -0,0 +1,282 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 GridPointUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: ExpMesh +PUBLIC :: Linspace +PUBLIC :: Logspace +PUBLIC :: MeshGrid + +!---------------------------------------------------------------------------- +! ExpMesh@FunctionalFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Sept 2021 +! summary: Exponential mesh + +INTERFACE ExpMesh + MODULE PURE FUNCTION ExpMesh_Real64(rmin, rmax, a, N) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: rmin + !! left end of 1D domain + REAL(REAL64), INTENT(IN) :: rmax + !! right end of 1D domain + REAL(REAL64), INTENT(IN) :: a + !! Ratio of largest to smallest element, a should be positive + !! a = 1, then we get uniform mesh + INTEGER(I4B), INTENT(IN) :: N + !! Number of elements present in mesh + REAL(REAL64) :: ans(N + 1) + !! Number of nodes in mesh + END FUNCTION ExpMesh_Real64 +END INTERFACE ExpMesh + +!---------------------------------------------------------------------------- +! ExpMesh@FunctionalFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Sept 2021 +! summary: Exponential mesh + +INTERFACE ExpMesh + MODULE PURE FUNCTION ExpMesh_Real32(rmin, rmax, a, N) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: rmin + !! left end of 1D domain + REAL(REAL32), INTENT(IN) :: rmax + !! right end of 1D domain + REAL(REAL32), INTENT(IN) :: a + !! Ratio of largest to smallest element, a should be positive + !! a = 1, then we get uniform mesh + INTEGER(I4B), INTENT(IN) :: N + !! Number of elements present in mesh + REAL(REAL32) :: ans(N + 1) + !! Number of nodes in mesh + END FUNCTION ExpMesh_Real32 +END INTERFACE ExpMesh + +!---------------------------------------------------------------------------- +! Linspace@FunctionalFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Sept 2021 +! summary: linspace + +INTERFACE LinSpace + MODULE PURE FUNCTION Linspace_Real64(a, b, N) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: a + !! left end of 1D domain + REAL(REAL64), INTENT(IN) :: b + !! right end of 1D domain + INTEGER(I4B), OPTIONAL, INTENT(IN) :: N + !! Number of points including a and b + REAL(REAL64), ALLOCATABLE :: ans(:) + !! Number of nodes in mesh + END FUNCTION Linspace_Real64 +END INTERFACE LinSpace + +!---------------------------------------------------------------------------- +! Linspace@FunctionalFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Sept 2021 +! summary: Returns a linearly spaced vector +! +!# Introduction +! Returns a linearly spaced vector with n points in [a, b] +! if n is omitted, 100 points will be considered + +INTERFACE LinSpace + MODULE PURE FUNCTION Linspace_Real32(a, b, N) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: a + !! left end of 1D domain + REAL(REAL32), INTENT(IN) :: b + !! right end of 1D domain + INTEGER(I4B), OPTIONAL, INTENT(IN) :: N + !! Number of points including a and b + REAL(REAL32), ALLOCATABLE :: ans(:) + !! Number of nodes in mesh + END FUNCTION Linspace_Real32 +END INTERFACE LinSpace + +!---------------------------------------------------------------------------- +! Logspace@FunctionalFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Sept 2021 +! summary: Logspace + +INTERFACE + MODULE PURE FUNCTION Logspace_Real64(a, b, N, endPoint, base) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: a + !! left end of 1D domain + REAL(REAL64), INTENT(IN) :: b + !! right end of 1D domain + INTEGER(I4B), OPTIONAL, INTENT(IN) :: N + !! Number of points including a and b + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: endPoint + !! default is true, if true then include endpoint + INTEGER(I4B), OPTIONAL, INTENT(IN) :: base + !! default is 10 + REAL(REAL64), ALLOCATABLE :: ans(:) + !! Number of nodes in mesh + END FUNCTION Logspace_Real64 +END INTERFACE + +INTERFACE Logspace + MODULE PROCEDURE Logspace_Real64 +END INTERFACE Logspace + +!---------------------------------------------------------------------------- +! Logspace@FunctionalFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Sept 2021 +! summary: Logspace + +INTERFACE + MODULE PURE FUNCTION Logspace_Real32(a, b, N, endPoint, base) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: a + !! left end of 1D domain + REAL(REAL32), INTENT(IN) :: b + !! right end of 1D domain + INTEGER(I4B), OPTIONAL, INTENT(IN) :: N + !! Number of points including a and b, default is 100 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: endPoint + !! default is true, if true then include endpoint + INTEGER(I4B), OPTIONAL, INTENT(IN) :: base + !! default is 10 + REAL(REAL32), ALLOCATABLE :: ans(:) + !! Number of nodes in mesh + END FUNCTION Logspace_Real32 +END INTERFACE + +INTERFACE Logspace + MODULE PROCEDURE Logspace_Real32 +END INTERFACE Logspace + +!---------------------------------------------------------------------------- +! MeshGrid@FunctionalFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 16 Sept 2021 +! summary: meshgrid generate mesh grid over a rectangular domain +! +!# Introduction +! +! Meshgrid generate mesh grid over a rectangular domain of +! [xmin xmax, ymin, ymax] +! - xgv, ygv are grid vectors in form of full grid data +! - X and Y are matrix each of size [ny by nx] contains the grid data. +! - The coordinates of point (i,j) is [X(i,j), Y(i,j)] +! +!### Usage +! +!```fortran +! call meshgrid(X, Y, [0.,1.,2.,3.],[5.,6.,7.,8.]) +! +! X = +! [0.0, 1.0, 2.0, 3.0, +! 0.0, 1.0, 2.0, 3.0, +! 0.0, 1.0, 2.0, 3.0, +! 0.0, 1.0, 2.0, 3.0] +! +! Y = +! [ 5.0, 5.0, 5.0, 5.0, +! 6.0, 6.0, 6.0, 6.0, +! 7.0, 7.0, 7.0, 7.0, +! 8.0, 8.0, 8.0, 8.0] +!``` + +INTERFACE + MODULE PURE SUBROUTINE MeshGrid2D_Real64(x, y, xgv, ygv) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: x(:, :) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: y(:, :) + REAL(REAL64), INTENT(IN) :: xgv(:) + REAL(REAL64), INTENT(IN) :: ygv(:) + END SUBROUTINE MeshGrid2D_Real64 +END INTERFACE + +INTERFACE MeshGrid + MODULE PROCEDURE MeshGrid2D_Real64 +END INTERFACE MeshGrid + +!---------------------------------------------------------------------------- +! MeshGrid@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE MeshGrid2D_Real32(x, y, xgv, ygv) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: x(:, :) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: y(:, :) + REAL(REAL32), INTENT(IN) :: xgv(:) + REAL(REAL32), INTENT(IN) :: ygv(:) + END SUBROUTINE MeshGrid2D_Real32 +END INTERFACE + +INTERFACE MeshGrid + MODULE PROCEDURE MeshGrid2D_Real32 +END INTERFACE MeshGrid + +!---------------------------------------------------------------------------- +! MeshGrid@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE MeshGrid3D_Real64(x, y, z, xgv, ygv, zgv) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: x(:, :, :) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: y(:, :, :) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: z(:, :, :) + REAL(REAL64), INTENT(IN) :: xgv(:) + REAL(REAL64), INTENT(IN) :: ygv(:) + REAL(REAL64), INTENT(IN) :: zgv(:) + END SUBROUTINE MeshGrid3D_Real64 +END INTERFACE + +INTERFACE MeshGrid + MODULE PROCEDURE MeshGrid3D_Real64 +END INTERFACE MeshGrid + +!---------------------------------------------------------------------------- +! MeshGrid@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE MeshGrid3D_Real32(x, y, z, xgv, ygv, zgv) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: x(:, :, :) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: y(:, :, :) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: z(:, :, :) + REAL(REAL32), INTENT(IN) :: xgv(:) + REAL(REAL32), INTENT(IN) :: ygv(:) + REAL(REAL32), INTENT(IN) :: zgv(:) + END SUBROUTINE MeshGrid3D_Real32 +END INTERFACE + +INTERFACE MeshGrid + MODULE PROCEDURE MeshGrid3D_Real32 +END INTERFACE MeshGrid + +END MODULE GridPointUtility diff --git a/src/modules/Utility/src/HashingUtility.F90 b/src/modules/Utility/src/HashingUtility.F90 new file mode 100644 index 000000000..dd989eab2 --- /dev/null +++ b/src/modules/Utility/src/HashingUtility.F90 @@ -0,0 +1,54 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 HashingUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! StringToUID@HashingMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 Aug 2021 +! summary: This function returns a unique number for a given string +! +!# Introduction +! This function returns a unique number for a given string +! +! Reference +! https://cp-algorithms.com/string/string-hashing.html + +INTERFACE + MODULE PURE FUNCTION StringToUID_PolyRoll(charVar) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: charVar + INTEGER(I4B) :: ans + END FUNCTION StringToUID_PolyRoll +END INTERFACE + +INTERFACE StringToUID + MODULE PROCEDURE StringToUID_PolyRoll +END INTERFACE StringToUID + +PUBLIC :: StringToUID + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE HashingUtility diff --git a/src/modules/Utility/src/HeadUtility.F90 b/src/modules/Utility/src/HeadUtility.F90 new file mode 100644 index 000000000..78dec1675 --- /dev/null +++ b/src/modules/Utility/src/HeadUtility.F90 @@ -0,0 +1,90 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 HeadUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: HEAD + +!---------------------------------------------------------------------------- +! Head +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns the first element of array `x`. + +INTERFACE HEAD + MODULE PURE FUNCTION head_Int8(x) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: x(:) + INTEGER(INT8) :: Ans + END FUNCTION head_Int8 + + MODULE PURE FUNCTION head_Int16(x) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: x(:) + INTEGER(INT16) :: Ans + END FUNCTION head_Int16 + + MODULE PURE FUNCTION head_Int32(x) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: x(:) + INTEGER(INT32) :: Ans + END FUNCTION head_Int32 + + MODULE PURE FUNCTION head_Int64(x) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: x(:) + INTEGER(INT64) :: Ans + END FUNCTION head_Int64 +END INTERFACE HEAD + +!---------------------------------------------------------------------------- +! Head +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns the first element of array `x`. + +INTERFACE HEAD + MODULE PURE FUNCTION head_Real32(x) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: x(:) + REAL(REAL32) :: Ans + END FUNCTION head_Real32 + + MODULE PURE FUNCTION head_Real64(x) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: x(:) + REAL(REAL64) :: Ans + END FUNCTION head_Real64 +END INTERFACE HEAD + +!---------------------------------------------------------------------------- +! Head +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns the first element of array `x`. + +INTERFACE HEAD + MODULE PURE FUNCTION head_char(x) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: x + CHARACTER(1) :: Ans + END FUNCTION +END INTERFACE HEAD + +END MODULE HeadUtility diff --git a/src/modules/Utility/src/InputUtility.F90 b/src/modules/Utility/src/InputUtility.F90 new file mode 100644 index 000000000..253c0408c --- /dev/null +++ b/src/modules/Utility/src/InputUtility.F90 @@ -0,0 +1,266 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 InputUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_Int8(default, option) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: default + INTEGER(INT8), OPTIONAL, INTENT(IN) :: option + INTEGER(INT8) :: Ans + END FUNCTION input_Int8 + MODULE PURE FUNCTION input_Int16(default, option) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: default + INTEGER(INT16), OPTIONAL, INTENT(IN) :: option + INTEGER(INT16) :: Ans + END FUNCTION input_Int16 + MODULE PURE FUNCTION input_Int32(default, option) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: default + INTEGER(INT32), OPTIONAL, INTENT(IN) :: option + INTEGER(INT32) :: Ans + END FUNCTION input_Int32 + MODULE PURE FUNCTION input_Int64(default, option) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: default + INTEGER(INT64), OPTIONAL, INTENT(IN) :: option + INTEGER(INT64) :: Ans + END FUNCTION input_Int64 +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_Int8, input_Int16, input_Int32, input_Int64 +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_Real32(default, option) RESULT(ans) + REAL(REAL32), INTENT(in) :: default + REAL(REAL32), OPTIONAL, INTENT(in) :: option + REAL(REAL32) :: ans + END FUNCTION input_Real32 + MODULE PURE FUNCTION input_Real64(default, option) RESULT(ans) + REAL(REAL64), INTENT(in) :: default + REAL(REAL64), OPTIONAL, INTENT(in) :: option + REAL(REAL64) :: ans + END FUNCTION input_Real64 +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_Real32, input_Real64 +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_Int8Vec(default, option) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: default(:) + INTEGER(INT8), OPTIONAL, INTENT(IN) :: option(:) + INTEGER(INT8) :: ans(SIZE(default)) + END FUNCTION input_Int8Vec + MODULE PURE FUNCTION input_Int16Vec(default, option) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: default(:) + INTEGER(INT16), OPTIONAL, INTENT(IN) :: option(:) + INTEGER(INT16) :: ans(SIZE(default)) + END FUNCTION input_Int16Vec + MODULE PURE FUNCTION input_Int32Vec(default, option) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: default(:) + INTEGER(INT32), OPTIONAL, INTENT(IN) :: option(:) + INTEGER(INT32) :: ans(SIZE(default)) + END FUNCTION input_Int32Vec + MODULE PURE FUNCTION input_Int64Vec(default, option) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: default(:) + INTEGER(INT64), OPTIONAL, INTENT(IN) :: option(:) + INTEGER(INT64) :: ans(SIZE(default)) + END FUNCTION input_Int64Vec +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_Int8Vec, input_Int16Vec, input_Int32Vec, & + & input_Int64Vec +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_Real32vec(default, option) RESULT(ans) + REAL(REAL32), INTENT(IN) :: default(:) + REAL(REAL32), OPTIONAL, INTENT(IN) :: option(:) + REAL(REAL32) :: ans(SIZE(default)) + END FUNCTION + MODULE PURE FUNCTION input_Real64vec(default, option) RESULT(ans) + REAL(REAL64), INTENT(IN) :: default(:) + REAL(REAL64), OPTIONAL, INTENT(IN) :: option(:) + REAL(REAL64) :: ans(SIZE(default)) + END FUNCTION +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_Real32vec, input_Real64vec +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_Int8Array(default, option) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: default(:, :) + INTEGER(INT8), OPTIONAL, INTENT(IN) :: option(:, :) + INTEGER(INT8) :: ans(SIZE(default, 1), SIZE(default, 2)) + END FUNCTION input_Int8Array + MODULE PURE FUNCTION input_Int16Array(default, option) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: default(:, :) + INTEGER(INT16), OPTIONAL, INTENT(IN) :: option(:, :) + INTEGER(INT16) :: ans(SIZE(default, 1), SIZE(default, 2)) + END FUNCTION input_Int16Array + MODULE PURE FUNCTION input_Int32Array(default, option) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: default(:, :) + INTEGER(INT32), OPTIONAL, INTENT(IN) :: option(:, :) + INTEGER(INT32) :: ans(SIZE(default, 1), SIZE(default, 2)) + END FUNCTION input_Int32Array + MODULE PURE FUNCTION input_Int64Array(default, option) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: default(:, :) + INTEGER(INT64), OPTIONAL, INTENT(IN) :: option(:, :) + INTEGER(INT64) :: ans(SIZE(default, 1), SIZE(default, 2)) + END FUNCTION input_Int64Array +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_Int8Array, input_Int16Array, input_Int32Array, & + & input_Int64Array +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_Real32Array(default, option) RESULT(ans) + REAL(REAL32), INTENT(IN) :: default(:, :) + REAL(REAL32), OPTIONAL, INTENT(IN) :: option(:, :) + REAL(REAL32) :: ans(SIZE(default, 1), SIZE(default, 2)) + END FUNCTION input_Real32Array + MODULE PURE FUNCTION input_Real64Array(default, option) RESULT(ans) + REAL(REAL64), INTENT(IN) :: default(:, :) + REAL(REAL64), OPTIONAL, INTENT(IN) :: option(:, :) + REAL(REAL64) :: ans(SIZE(default, 1), SIZE(default, 2)) + END FUNCTION input_Real64Array +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_Real32Array, input_Real64Array +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_String(default, option) RESULT(ans) + CHARACTER(*), INTENT(IN) :: default + CHARACTER(*), OPTIONAL, INTENT(IN) :: option + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_String +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +! INTERFACE +! MODULE PURE FUNCTION input_StringVec(default, option) RESULT(ans) +! CHARACTER(*), INTENT(IN) :: default(:) +! CHARACTER(*), OPTIONAL, INTENT(IN) :: option(:) +! CHARACTER(:), ALLOCATABLE :: ans(:) +! END FUNCTION input_StringVec +! END INTERFACE + +! INTERFACE Input +! MODULE PROCEDURE input_StringVec +! END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_logical(default, option) RESULT(ans) + LOGICAL(LGT), INTENT(IN) :: default + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: option + LOGICAL(LGT) :: ans + END FUNCTION +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_logical +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_logicalvec(default, option) RESULT(ans) + LOGICAL(LGT), INTENT(IN) :: default(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: option(:) + LOGICAL(LGT) :: ans(SIZE(default)) + END FUNCTION +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_logicalvec +END INTERFACE Input + +!---------------------------------------------------------------------------- +! Input@Input +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION input_logicalArray(default, option) RESULT(ans) + LOGICAL(LGT), INTENT(IN) :: default(:, :) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: option(:, :) + LOGICAL(LGT) :: ans(SIZE(default, 1), SIZE(default, 2)) + END FUNCTION +END INTERFACE + +INTERFACE Input + MODULE PROCEDURE input_logicalArray +END INTERFACE Input + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE InputUtility diff --git a/src/modules/Utility/src/IntegerUtility.F90 b/src/modules/Utility/src/IntegerUtility.F90 new file mode 100644 index 000000000..b52c57a50 --- /dev/null +++ b/src/modules/Utility/src/IntegerUtility.F90 @@ -0,0 +1,537 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IntegerUtility +USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, & + REAL32, REAL64 +IMPLICIT NONE +PRIVATE + +PUBLIC :: OPERATOR(.in.) +PUBLIC :: OPERATOR(.isin.) +PUBLIC :: RemoveDuplicates +PUBLIC :: RemoveDuplicates_ +PUBLIC :: Repeat +PUBLIC :: SIZE +PUBLIC :: GetMultiIndices +PUBLIC :: GetIndex +PUBLIC :: Get +PUBLIC :: GetIntersection +PUBLIC :: Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE Size + MODULE PURE FUNCTION obj_Size1(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + INTEGER(I4B) :: ans + END FUNCTION obj_Size1 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE Size + MODULE PURE FUNCTION obj_Size2(n, d, upto) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B) :: ans + END FUNCTION obj_Size2 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices + +INTERFACE GetMultiIndices + MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices1(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices1 +END INTERFACE GetMultiIndices + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices upto order n + +INTERFACE GetMultiIndices + MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices2 +END INTERFACE GetMultiIndices + +!---------------------------------------------------------------------------- +! Operator(.in.)@IntegerMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another + +INTERFACE OPERATOR(.in.) + MODULE PURE FUNCTION in_1a(a, b) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1a + + MODULE PURE FUNCTION in_1b(a, b) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1b + + MODULE PURE FUNCTION in_1c(a, b) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1c + + MODULE PURE FUNCTION in_1d(a, b) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1d + +END INTERFACE OPERATOR(.in.) + +!---------------------------------------------------------------------------- +! Operator(.in.)@IntegerMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another +! +!# Introduction +! +! This function returns a vector of booleans +! if a(i) is inside the b, then ans(i) is true, otherwise false. + +INTERFACE OPERATOR(.isin.) + MODULE PURE FUNCTION isin_1a(a, b) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1a + + MODULE PURE FUNCTION isin_1b(a, b) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1b + + MODULE PURE FUNCTION isin_1c(a, b) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1c + + MODULE PURE FUNCTION isin_1d(a, b) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1d +END INTERFACE OPERATOR(.isin.) + +!---------------------------------------------------------------------------- +! Operator(.in.)@IntegerMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another + +INTERFACE OPERATOR(.in.) + + MODULE PURE FUNCTION in_2a(a, b) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a + INTEGER(INT8), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2a + + MODULE PURE FUNCTION in_2b(a, b) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a + INTEGER(INT16), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2b + + MODULE PURE FUNCTION in_2c(a, b) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a + INTEGER(INT32), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2c + + MODULE PURE FUNCTION in_2d(a, b) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a + INTEGER(INT64), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2d + +END INTERFACE OPERATOR(.in.) + +INTERFACE OPERATOR(.isin.) + MODULE PROCEDURE in_2a, in_2b, in_2c, in_2d +END INTERFACE OPERATOR(.isin.) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-12 +! summary: Remove duplicates entries + +INTERFACE RemoveDuplicates + MODULE PURE SUBROUTINE RemoveDuplicates_1a(obj) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1a + MODULE PURE SUBROUTINE RemoveDuplicates_1b(obj) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1b + MODULE PURE SUBROUTINE RemoveDuplicates_1c(obj) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1c + MODULE PURE SUBROUTINE RemoveDuplicates_1d(obj) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1d +END INTERFACE RemoveDuplicates + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-12 +! summary: Remove duplicates with no allocation + +INTERFACE RemoveDuplicates_ + MODULE PURE SUBROUTINE RemoveDuplicates_1a_(obj, tsize, isSorted) + INTEGER(INT8), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1a_ + + MODULE PURE SUBROUTINE RemoveDuplicates_1b_(obj, tsize, isSorted) + INTEGER(INT16), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1b_ + + MODULE PURE SUBROUTINE RemoveDuplicates_1c_(obj, tsize, isSorted) + INTEGER(INT32), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1c_ + + MODULE PURE SUBROUTINE RemoveDuplicates_1d_(obj, tsize, isSorted) + INTEGER(INT64), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1d_ + +END INTERFACE RemoveDuplicates_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Repeat + MODULE PURE FUNCTION Repeat_1a(Val, rtimes) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT8) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1a + MODULE PURE FUNCTION Repeat_1b(Val, rtimes) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT16) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1b + MODULE PURE FUNCTION Repeat_1c(Val, rtimes) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT32) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1c + MODULE PURE FUNCTION Repeat_1d(Val, rtimes) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT64) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1d + MODULE PURE FUNCTION Repeat_1e(Val, rtimes) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + REAL(REAL32) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1e + MODULE PURE FUNCTION Repeat_1f(Val, rtimes) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + REAL(REAL64) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1f +END INTERFACE Repeat + +!---------------------------------------------------------------------------- +! getIndex@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PURE FUNCTION GetIndex1(obj, val) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: val + INTEGER(I4B) :: ans + END FUNCTION GetIndex1 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! getIndex@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PURE FUNCTION GetIndex2(obj, Val) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: Val(:) + INTEGER(I4B), ALLOCATABLE :: Ans(:) + END FUNCTION GetIndex2 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION Get1_Int8(val, indx) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT8) :: ans + END FUNCTION Get1_Int8 + + MODULE PURE FUNCTION Get1_Int16(val, indx) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT16) :: ans + END FUNCTION Get1_Int16 + + MODULE PURE FUNCTION Get1_Int32(val, indx) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT32) :: ans + END FUNCTION Get1_Int32 + + MODULE PURE FUNCTION Get1_Int64(val, indx) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT64) :: ans + END FUNCTION Get1_Int64 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION Get2_Int8(val, indx) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT8) :: ans(SIZE(indx)) + END FUNCTION Get2_Int8 + + MODULE PURE FUNCTION Get2_Int16(val, indx) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT16) :: ans(SIZE(indx)) + END FUNCTION Get2_Int16 + + MODULE PURE FUNCTION Get2_Int32(val, indx) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT32) :: ans(SIZE(indx)) + END FUNCTION Get2_Int32 + + MODULE PURE FUNCTION Get2_Int64(val, indx) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT64) :: ans(SIZE(indx)) + END FUNCTION Get2_Int64 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION Get3_Int8(val, istart, iend, stride) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT8) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int8 + + MODULE PURE FUNCTION Get3_Int16(val, istart, iend, stride) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT16) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int16 + + MODULE PURE FUNCTION Get3_Int32(val, istart, iend, stride) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT32) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int32 + + MODULE PURE FUNCTION Get3_Int64(val, istart, iend, stride) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT64) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int64 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! GetIntersection +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-22 +! summary: Get the intersection fo two integer vectors + +INTERFACE GetIntersection + MODULE PURE SUBROUTINE GetIntersection1(a, b, c, tsize) + INTEGER(INT8), INTENT(IN) :: a(:), b(:) + INTEGER(INT8), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection1 + + MODULE PURE SUBROUTINE GetIntersection2(a, b, c, tsize) + INTEGER(INT16), INTENT(IN) :: a(:), b(:) + INTEGER(INT16), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection2 + + MODULE PURE SUBROUTINE GetIntersection3(a, b, c, tsize) + INTEGER(INT32), INTENT(IN) :: a(:), b(:) + INTEGER(INT32), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection3 + + MODULE PURE SUBROUTINE GetIntersection4(a, b, c, tsize) + INTEGER(INT64), INTENT(IN) :: a(:), b(:) + INTEGER(INT64), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection4 +END INTERFACE GetIntersection + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j) to ans from Fortran2D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom2DFortranIndex(i, j, dim1, dim2) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom2DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j,k) to ans from Fortran3D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom3DFortranIndex(i, j, k, dim1, dim2, & + dim3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: k + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom3DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Get1DIndexFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j,k,l) to ans from Fortran4D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom4DFortranIndex(i, j, k, l, dim1, dim2, & + dim3, dim4) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: k + INTEGER(I4B), INTENT(IN) :: l + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom4DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE IntegerUtility diff --git a/src/modules/Utility/src/InvUtility.F90 b/src/modules/Utility/src/InvUtility.F90 new file mode 100644 index 000000000..0a2f3a961 --- /dev/null +++ b/src/modules/Utility/src/InvUtility.F90 @@ -0,0 +1,94 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 InvUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: DET +PUBLIC :: INV + +!---------------------------------------------------------------------------- +! Det@InverseMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION det_2D(A) RESULT(Ans) + REAL(DFP), INTENT(IN) :: A(:, :) + REAL(DFP) :: Ans + END FUNCTION det_2D +END INTERFACE + +INTERFACE Det + MODULE PROCEDURE det_2D +END INTERFACE Det + +!---------------------------------------------------------------------------- +! Det@InverseMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION det_3D(A) RESULT(Ans) + REAL(DFP), INTENT(IN) :: A(:, :, :) + REAL(DFP), ALLOCATABLE :: Ans(:) + END FUNCTION det_3D +END INTERFACE + +INTERFACE Det + MODULE PROCEDURE det_3D +END INTERFACE Det + +!---------------------------------------------------------------------------- +! INV@InverseMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of small matrix upto size 4 + +INTERFACE + MODULE PURE SUBROUTINE Inv_2D(invA, A) + REAL(DFP), INTENT(INOUT) :: invA(:, :) + REAL(DFP), INTENT(IN) :: A(:, :) + END SUBROUTINE +END INTERFACE + +INTERFACE Inv + MODULE PROCEDURE Inv_2D +END INTERFACE Inv + +!---------------------------------------------------------------------------- +! INV@InverseMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of small matrix upto size 4 + +INTERFACE + MODULE PURE SUBROUTINE Inv_3D(invA, A) + REAL(DFP), INTENT(INOUT) :: invA(:, :, :) + REAL(DFP), INTENT(IN) :: A(:, :, :) + END SUBROUTINE +END INTERFACE + +INTERFACE Inv + MODULE PROCEDURE Inv_3D +END INTERFACE Inv + +END MODULE InvUtility diff --git a/src/modules/Utility/src/LinearAlgebraUtility.F90 b/src/modules/Utility/src/LinearAlgebraUtility.F90 new file mode 100644 index 000000000..0eb48c5df --- /dev/null +++ b/src/modules/Utility/src/LinearAlgebraUtility.F90 @@ -0,0 +1,48 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 LinearAlgebraUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: InvHilbertMatrix +PUBLIC :: HilbertMatrix + +!---------------------------------------------------------------------------- +! InvHilbertMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION InvHilbertMatrix(n) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: Ans(n, n) + END FUNCTION InvHilbertMatrix +END INTERFACE + +!---------------------------------------------------------------------------- +! HilbertMatrix@Methods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION HilbertMatrix(n) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: Ans(n, n) + END FUNCTION HilbertMatrix +END INTERFACE + +END MODULE LinearAlgebraUtility diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 new file mode 100644 index 000000000..9ad5c7125 --- /dev/null +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -0,0 +1,966 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Some methods related to standard mapping are defined +! +!{!pages/MappingUtility_.md!} + +MODULE MappingUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: FromBiunitLine2Segment +PUBLIC :: FromBiUnitLine2UnitLine +PUBLIC :: FromUnitLine2BiUnitLine +PUBLIC :: FromLine2Line_ + +PUBLIC :: FromBiUnitQuadrangle2Quadrangle +PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle +PUBLIC :: FromUnitQuadrangle2BiUnitQuadrangle + +PUBLIC :: FromBiUnitHexahedron2Hexahedron +PUBLIC :: FromBiUnitHexahedron2UnitHexahedron +PUBLIC :: FromUnitHexahedron2BiUnitHexahedron + +PUBLIC :: FromBiUnitTriangle2BiUnitSqr +PUBLIC :: FromBiUnitTriangle2BiUnitQuadrangle + +PUBLIC :: FromBiUnitSqr2BiUnitTriangle +PUBLIC :: FromBiUnitQuadrangle2BiUnitTriangle + +PUBLIC :: FromUnitTriangle2BiUnitSqr +PUBLIC :: FromUnitTriangle2BiUnitQuadrangle + +PUBLIC :: FromBiUnitSqr2UnitTriangle +PUBLIC :: FromBiUnitQuadrangle2UnitTriangle + +PUBLIC :: FromTriangle2Square_ + +PUBLIC :: FromUnitTriangle2Triangle + +PUBLIC :: BarycentricCoordUnitTriangle +!! This is function +PUBLIC :: BarycentricCoordBiUnitTriangle +!! This is function +PUBLIC :: BarycentricCoordTriangle +!! This is function +PUBLIC :: BarycentricCoordTriangle_ +!! This is a subroutine without allocation + +PUBLIC :: FromBiUnitTriangle2UnitTriangle +PUBLIC :: FromUnitTriangle2BiUnitTriangle + +PUBLIC :: FromTriangle2Triangle_ + +PUBLIC :: FromUnitTetrahedron2BiUnitTetrahedron +PUBLIC :: FromBiUnitTetrahedron2UnitTetrahedron +PUBLIC :: FromUnitTetrahedron2Tetrahedron +PUBLIC :: FromBiUnitTetrahedron2Tetrahedron +PUBLIC :: BarycentricCoordUnitTetrahedron +PUBLIC :: BarycentricCoordBiUnitTetrahedron +PUBLIC :: BarycentricCoordTetrahedron +PUBLIC :: FromBiUnitTetrahedron2BiUnitHexahedron +PUBLIC :: FromBiUnitHexahedron2BiUnitTetrahedron +PUBLIC :: FromUnitTetrahedron2BiUnitHexahedron +PUBLIC :: FromBiUnitHexahedron2UnitTetrahedron + +PUBLIC :: JacobianLine +PUBLIC :: JacobianTriangle +PUBLIC :: JacobianQuadrangle +PUBLIC :: JacobianHexahedron +PUBLIC :: JacobianTetrahedron +! PUBLIC :: JacobianPrism +! PUBLIC :: JacobianPyramid + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE + MODULE PURE FUNCTION FromBiunitLine2Segment1(xin, x1, x2) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in [-1,1] + REAL(DFP), INTENT(IN) :: x1 + !! x1 of physical domain + REAL(DFP), INTENT(IN) :: x2 + !! x2 of physical domain + REAL(DFP) :: ans(SIZE(xin)) + !! mapped coordinates of xin in physical domain + END FUNCTION FromBiunitLine2Segment1 +END INTERFACE + +INTERFACE FromBiunitLine2Segment + MODULE PROCEDURE FromBiunitLine2Segment1 +END INTERFACE FromBiunitLine2Segment + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE + MODULE PURE FUNCTION FromBiunitLine2Segment2(xin, x1, x2) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in [-1,1], SIZE(xin) = n + REAL(DFP), INTENT(IN) :: x1(:) + !! x1 of physical domain, SIZE(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! x2 of physical domain, SIZE(x2) = nsd + REAL(DFP) :: ans(SIZE(x1), SIZE(xin)) + !! returned coordinates in physical space + !! ans is in xij format + END FUNCTION FromBiunitLine2Segment2 +END INTERFACE + +INTERFACE FromBiunitLine2Segment + MODULE PROCEDURE FromBiunitLine2Segment2 +END INTERFACE FromBiunitLine2Segment + +!---------------------------------------------------------------------------- +! FromUnitTriangle2Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE FromUnitTriangle2Triangle + MODULE PURE FUNCTION FromUnitTriangle2Triangle1(xin, x1, x2, x3) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of unit triangle + !! (0,0), (1,0), (0,1) + !! shape(xin) = (2,N) + REAL(DFP), INTENT(IN) :: x1(:) + !! x1 of physical domain, size(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! x2 of physical domain, size(x2) = nsd + REAL(DFP), INTENT(IN) :: x3(:) + !! x3 of physical domain, size(x3) = nsd + REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromUnitTriangle2Triangle1 +END INTERFACE FromUnitTriangle2Triangle + +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE FromBiUnitQuadrangle2UnitQuadrangle + MODULE PURE FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1(xin) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Quadrangle in xij format + !! SIZE(xin,1) = 2 + REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1 +END INTERFACE FromBiUnitQuadrangle2UnitQuadrangle + +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE FromUnitQuadrangle2BiUnitQuadrangle + MODULE PURE FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1(xin) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Quadrangle in xij format + !! SIZE(xin,1) = 2 + REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1 +END INTERFACE FromUnitQuadrangle2BiUnitQuadrangle + +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE FromBiUnitQuadrangle2Quadrangle + MODULE PURE FUNCTION FromBiUnitQuadrangle2Quadrangle1(xin, x1, x2, x3, x4) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Quadrangle in xij format + !! SIZE(xin,1) = 2 + REAL(DFP), INTENT(IN) :: x1(:) + !! vertex x1 of physical domain, size(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! vertex x2 of physical domain, size(x2) = nsd + REAL(DFP), INTENT(IN) :: x3(:) + !! vertex x3 of physical domain, size(x3) = nsd + REAL(DFP), INTENT(IN) :: x4(:) + !! vertex x4 of physical domain, size(x4) = nsd + REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromBiUnitQuadrangle2Quadrangle1 +END INTERFACE FromBiUnitQuadrangle2Quadrangle + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE FromBiUnitHexahedron2Hexahedron + MODULE PURE FUNCTION FromBiUnitHexahedron2Hexahedron1(xin, & + & x1, x2, x3, x4, x5, x6, x7, x8) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Hexahedron in xij format + !! SIZE(xin,1) = 3 + REAL(DFP), INTENT(IN) :: x1(:) + !! vertex x1 of physical domain, size(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! vertex x2 of physical domain, size(x2) = nsd + REAL(DFP), INTENT(IN) :: x3(:) + !! vertex x3 of physical domain, size(x3) = nsd + REAL(DFP), INTENT(IN) :: x4(:) + !! vertex x4 of physical domain, size(x4) = nsd + REAL(DFP), INTENT(IN) :: x5(:) + !! vertex x5 of physical domain, size(x5) = nsd + REAL(DFP), INTENT(IN) :: x6(:) + !! vertex x6 of physical domain, size(x6) = nsd + REAL(DFP), INTENT(IN) :: x7(:) + !! vertex x7 of physical domain, size(x7) = nsd + REAL(DFP), INTENT(IN) :: x8(:) + !! vertex x8 of physical domain, size(x8) = nsd + REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromBiUnitHexahedron2Hexahedron1 +END INTERFACE FromBiUnitHexahedron2Hexahedron + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit hexahedron to unit hexahedron + +INTERFACE FromBiUnitHexahedron2UnitHexahedron + MODULE PURE FUNCTION FromBiUnitHexahedron2UnitHexahedron1(xin) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Hexahedron in xij format + !! SIZE(xin,1) = 3 + REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromBiUnitHexahedron2UnitHexahedron1 +END INTERFACE FromBiUnitHexahedron2UnitHexahedron + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit hexahedron to biunit hexahedron + +INTERFACE FromUnitHexahedron2BiUnitHexahedron + MODULE PURE FUNCTION FromUnitHexahedron2BiUnitHexahedron1(xin) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Hexahedron in xij format + !! SIZE(xin,1) = 3 + REAL(DFP) :: ans(SIZE(xin, 1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromUnitHexahedron2BiUnitHexahedron1 +END INTERFACE FromUnitHexahedron2BiUnitHexahedron + +!---------------------------------------------------------------------------- +! FromBiUnitLine2UnitLine +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit line to unit line +! +!# Introduction +! +!- Bi unit line is defined by -1 to 1. +!- Unit line is defined by 0 to 1 + +INTERFACE + MODULE PURE FUNCTION FromBiUnitLine2UnitLine(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in biunit line + REAL(DFP) :: ans(SIZE(xin)) + !! mapped coordinates of xin in unit line + END FUNCTION FromBiUnitLine2UnitLine +END INTERFACE + +!---------------------------------------------------------------------------- +! FromUnitLine2BiUnitLine +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to biunit line +! +!# Introduction +! +!- Bi unit line is defined by -1 to 1. +!- Unit line is defined by 0 to 1 + +INTERFACE + MODULE PURE FUNCTION FromUnitLine2BiUnitLine(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in unit line + REAL(DFP) :: ans(SIZE(xin)) + !! mapped coordinates of xin in biunit line + END FUNCTION FromUnitLine2BiUnitLine +END INTERFACE + +!---------------------------------------------------------------------------- +! FromLine2Line_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-27 +! summary: Map line to line + +INTERFACE + MODULE PURE SUBROUTINE FromLine2Line_(xin, ans, from, to) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in unit line + REAL(DFP), INTENT(INOUT) :: ans(:) + !! mapped coordinates of xin in biunit line + CHARACTER(*), INTENT(IN) :: from + CHARACTER(*), INTENT(IN) :: to + END SUBROUTINE FromLine2Line_ +END INTERFACE + +!---------------------------------------------------------------------------- +! FromBiUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Bi unit triangle is defined by (-1,-1), (1,-1), and (-1,1) +!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE FromBiUnitTriangle2BiUnitQuadrangle + MODULE PURE FUNCTION FromBiUnitTriangle2BiUnitSqr(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in biunit triangle in xij format + !! bi unit triangle is defined by + !! (-1,-1), (1,-1), (-1,1) + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! mapped coordinates of xin in biunit sqr + END FUNCTION FromBiUnitTriangle2BiUnitSqr +END INTERFACE FromBiUnitTriangle2BiUnitQuadrangle + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2BiUnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Bi unit triangle is defined by (-1,-1), (1,-1), and (-1,1) +!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE FromBiUnitQuadrangle2BiUnitTriangle + MODULE PURE FUNCTION FromBiUnitSqr2BiUnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit square in xij coordinate + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! coordinates in biunit triangle + END FUNCTION FromBiUnitSqr2BiUnitTriangle +END INTERFACE FromBiUnitQuadrangle2BiUnitTriangle + +!---------------------------------------------------------------------------- +! FromUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Unit triangle is defined by (0,0), (0,1), and (1,0) +!- Biunit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE FromUnitTriangle2BiUnitQuadrangle + MODULE PURE FUNCTION FromUnitTriangle2BiUnitSqr(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in biunit triangle in xij format + !! bi unit triangle is defined by + !! (-1,-1), (1,-1), (-1,1) + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! mapped coordinates of xin in biunit sqr + END FUNCTION FromUnitTriangle2BiUnitSqr +END INTERFACE FromUnitTriangle2BiUnitQuadrangle + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2UnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Unit triangle is defined by (0,0), (0,1), and (1,0) +!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE FromBiUnitQuadrangle2UnitTriangle + MODULE PURE FUNCTION FromBiUnitSqr2UnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit square in xij coordinate + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! coordinates in biunit triangle + END FUNCTION FromBiUnitSqr2UnitTriangle +END INTERFACE FromBiUnitQuadrangle2UnitTriangle + +!---------------------------------------------------------------------------- +! FromTriangle2Triangle_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from triangle to square + +INTERFACE + MODULE PURE SUBROUTINE FromTriangle2Triangle_(xin, ans, from, to, x1, x2, x3) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit square in xij coordinate + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(2, SIZE(xin, 2)) + !! coordinates in biunit triangle + CHARACTER(*), INTENT(IN) :: from + CHARACTER(*), INTENT(IN) :: to + REAL(DFP), OPTIONAL, INTENT(IN) :: x1(:) + !! x1 of physical domain, size(x1) = nsd + REAL(DFP), OPTIONAL, INTENT(IN) :: x2(:) + !! x2 of physical domain, size(x2) = nsd + REAL(DFP), OPTIONAL, INTENT(IN) :: x3(:) + !! x3 of physical domain, size(x3) = nsd + END SUBROUTINE FromTriangle2Triangle_ +END INTERFACE + +!---------------------------------------------------------------------------- +! FromTriangle2Square_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from triangle to square + +INTERFACE + MODULE PURE SUBROUTINE FromTriangle2Square_(xin, ans, from, to) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit square in xij coordinate + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(2, SIZE(xin, 2)) + !! coordinates in biunit triangle + CHARACTER(*), INTENT(IN) :: from + CHARACTER(*), INTENT(IN) :: to + END SUBROUTINE FromTriangle2Square_ +END INTERFACE + +!---------------------------------------------------------------------------- +! FromSquare2Triangle_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from triangle to square + +INTERFACE + MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit square in xij coordinate + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(2, SIZE(xin, 2)) + !! coordinates in biunit triangle + CHARACTER(*), INTENT(IN) :: from + CHARACTER(*), INTENT(IN) :: to + END SUBROUTINE FromSquare2Triangle_ +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCoordUnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordUnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION BarycentricCoordUnitTriangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCoordBiUnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordBiUnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION BarycentricCoordBiUnitTriangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCoordTriangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordTriangle(xin, refTriangle) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(3, SIZE(xin, 2)) + CHARACTER(*), INTENT(IN) :: refTriangle + !! "UNIT" + !! "BIUNIT" + END FUNCTION BarycentricCoordTriangle +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCoordTriangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCoordTriangle_(xin, refTriangle, ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans(3, SIZE(xin, 2)) + CHARACTER(*), INTENT(IN) :: refTriangle + !! "UNIT" + !! "BIUNIT" + END SUBROUTINE BarycentricCoordTriangle_ +END INTERFACE + +!---------------------------------------------------------------------------- +! FromBiUnitTriangle2UnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION FromBiUnitTriangle2UnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(2, SIZE(xin, 2)) + END FUNCTION FromBiUnitTriangle2UnitTriangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FromUnitTriangle2BiUnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION FromUnitTriangle2BiUnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(2, SIZE(xin, 2)) + END FUNCTION FromUnitTriangle2BiUnitTriangle +END INTERFACE + +!---------------------------------------------------------------------------- +! FromBiUnitTetrahedron2UnitTetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Biunit Tetrahedron to Unit tetrahedron + +INTERFACE + MODULE PURE FUNCTION FromBiUnitTetrahedron2UnitTetrahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION FromBiUnitTetrahedron2UnitTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2BiUnitTetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Unit Tetrahedron to biunit tetrahedron + +INTERFACE + MODULE PURE FUNCTION FromUnitTetrahedron2BiUnitTetrahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION FromUnitTetrahedron2BiUnitTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FromBiUnitTetrahedron2Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Biunit Tetrahedron to tetrahedron + +INTERFACE + MODULE PURE FUNCTION FromBiUnitTetrahedron2Tetrahedron( & + & xin, & + & x1, & + & x2, & + & x3, & + & x4) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(IN) :: x1(3) + !! Coordinate of tetrahedron node 1 + REAL(DFP), INTENT(IN) :: x2(3) + !! Coordinate of tetrahedron node 2 + REAL(DFP), INTENT(IN) :: x3(3) + !! Coordinate of tetrahedron node 3 + REAL(DFP), INTENT(IN) :: x4(3) + !! Coordinate of tetrahedron node 4 + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION FromBiUnitTetrahedron2Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-27 +! summary: Unit Tetrahedron to tetrahedron + +INTERFACE + MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron( & + & xin, & + & x1, & + & x2, & + & x3, & + & x4) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(IN) :: x1(3) + !! Coordinate of tetrahedron node 1 + REAL(DFP), INTENT(IN) :: x2(3) + !! Coordinate of tetrahedron node 2 + REAL(DFP), INTENT(IN) :: x3(3) + !! Coordinate of tetrahedron node 3 + REAL(DFP), INTENT(IN) :: x4(3) + !! Coordinate of tetrahedron node 4 + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION FromUnitTetrahedron2Tetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCoordUnitTetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordUnitTetrahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(4, SIZE(xin, 2)) + END FUNCTION BarycentricCoordUnitTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCoordBiUnitTetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordBiUnitTetrahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(4, SIZE(xin, 2)) + END FUNCTION BarycentricCoordBiUnitTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCoordTetrahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordTetrahedron(xin, refTetrahedron) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(4, SIZE(xin, 2)) + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" + !! "BIUNIT" + END FUNCTION BarycentricCoordTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FromBiUnitTetrahedron2BiUnitHexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-27 +! summary: Map from biunit tetrahedron to bi-unit Hexahedron + +INTERFACE + MODULE PURE FUNCTION FromBiUnitTetrahedron2BiUnitHexahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in biunit tetrahedron in xij format + REAL(DFP) :: ans(3, SIZE(xin, 2)) + !! mapped coordinates of xin in biunit hexahedron + END FUNCTION FromBiUnitTetrahedron2BiUnitHexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2BiUnitTetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-27 +! summary: Map from biunit hexahedron to biunit tetrahedron + +INTERFACE + MODULE PURE FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit hexahedron in xij coordinate + REAL(DFP) :: ans(3, SIZE(xin, 2)) + !! coordinates in biunit tetrahedron + END FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2BiUnitHexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-27 +! summary: Map from unit tetrahedron to bi-unit Hexahedron + +INTERFACE + MODULE PURE FUNCTION FromUnitTetrahedron2BiUnitHexahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in unit tetrahedron in xij format + REAL(DFP) :: ans(3, SIZE(xin, 2)) + !! mapped coordinates of xin in biunit hexahedron + END FUNCTION FromUnitTetrahedron2BiUnitHexahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2BiUnitTetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-27 +! summary: Map from unit hexahedron to biunit tetrahedron + +INTERFACE + MODULE PURE FUNCTION FromBiUnitHexahedron2UnitTetrahedron(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in biunit hexahedron in xij coordinate + REAL(DFP) :: ans(3, SIZE(xin, 2)) + !! coordinates in unit tetrahedron + END FUNCTION FromBiUnitHexahedron2UnitTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobianLine +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION JacobianLine(from, to, xij) RESULT(ans) + CHARACTER(*), INTENT(IN) :: from + !! BIUNIT + !! UNIT + !! LINE + CHARACTER(*), INTENT(IN) :: to + !! BIUNIT + !! UNIT + !! LINE + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of general line (segment) + !! number of rows=1 + !! number of cols=2 + !! xij is needed when from or to are LINE + !! both from and to cannot be LINE + REAL(DFP) :: ans + END FUNCTION JacobianLine +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobianTriangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION JacobianTriangle(from, to, xij) RESULT(ans) + CHARACTER(*), INTENT(IN) :: from + !! BIUNIT + !! UNIT + !! TRIANGLE + CHARACTER(*), INTENT(IN) :: to + !! BIUNIT + !! UNIT + !! TRIANGLE + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of general TRIANGLE + !! number of rows=nsd + !! number of cols=3 + !! xij is needed when `from` or `to` is TRIANGLE + !! both `from` and to `cannot` be TRIANGLE + REAL(DFP) :: ans + END FUNCTION JacobianTriangle +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobianQuadrangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION JacobianQuadrangle(from, to, xij) RESULT(ans) + CHARACTER(*), INTENT(IN) :: from + !! BIUNIT + !! UNIT + !! QUADRANGLE + CHARACTER(*), INTENT(IN) :: to + !! BIUNIT + !! UNIT + !! QUADRANGLE + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of general QUADRANGLE + !! number of rows=nsd + !! number of cols=4 + !! xij is needed when `from` or `to` is QUADRANGLE + !! both `from` and to `cannot` be QUADRANGLE + REAL(DFP) :: ans + END FUNCTION JacobianQuadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobianTetrahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION JacobianTetrahedron(from, to, xij) RESULT(ans) + CHARACTER(*), INTENT(IN) :: from + !! BIUNIT + !! UNIT + !! TETRAHEDRON + CHARACTER(*), INTENT(IN) :: to + !! BIUNIT + !! UNIT + !! TETRAHEDRON + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of general TETRAHEDRON + !! number of rows=nsd + !! number of cols=4 + !! xij is needed when `from` or `to` is TETRAHEDRON + !! both `from` and to `cannot` be TETRAHEDRON + REAL(DFP) :: ans + END FUNCTION JacobianTetrahedron +END INTERFACE + +!---------------------------------------------------------------------------- +! JacobianHexahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION JacobianHexahedron(from, to, xij) RESULT(ans) + CHARACTER(*), INTENT(IN) :: from + !! BIUNIT + !! UNIT + !! HEXAHEDRON + CHARACTER(*), INTENT(IN) :: to + !! BIUNIT + !! UNIT + !! HEXAHEDRON + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of general HEXAHEDRON + !! number of rows=nsd + !! number of cols=4 + !! xij is needed when `from` or `to` is HEXAHEDRON + !! both `from` and to `cannot` be HEXAHEDRON + REAL(DFP) :: ans + END FUNCTION JacobianHexahedron +END INTERFACE + +! !---------------------------------------------------------------------------- +! ! JacobianPrism +! !---------------------------------------------------------------------------- +! +! INTERFACE +! MODULE PURE FUNCTION JacobianPrism(from, to) RESULT(ans) +! CHARACTER(*), INTENT(IN) :: from +! CHARACTER(*), INTENT(IN) :: to +! REAL(DFP) :: ans +! END FUNCTION JacobianPrism +! END INTERFACE +! +! !---------------------------------------------------------------------------- +! ! JacobianPyramid +! !---------------------------------------------------------------------------- +! +! INTERFACE +! MODULE PURE FUNCTION JacobianPyramid(from, to) RESULT(ans) +! CHARACTER(*), INTENT(IN) :: from +! CHARACTER(*), INTENT(IN) :: to +! REAL(DFP) :: ans +! END FUNCTION JacobianPyramid +! END INTERFACE + +END MODULE MappingUtility diff --git a/src/modules/Utility/src/MatmulUtility.F90 b/src/modules/Utility/src/MatmulUtility.F90 new file mode 100644 index 000000000..1fb96640e --- /dev/null +++ b/src/modules/Utility/src/MatmulUtility.F90 @@ -0,0 +1,352 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 MatmulUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: MATMUL + +!---------------------------------------------------------------------------- +! 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 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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r4_r1 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j,k,m) = a1(i,j,k,l)*a2(l,m)` + +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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r4_r2 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j,k,m,n) = a1(i,j,k,l)*a2(l,m,n)` + +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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r4_r3 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j,k,m,n,o) = a1(i,j,k,l)*a2(l,m,n,o)` + +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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r4_r4 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank3 and rank1 array +! +!# Introduction +! +! This fuction performs following task +! `ans(i,j) = a1(i,j,k)*a2(k)` + +INTERFACE + 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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r3_r1 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank3 and rank2 +! +!# Introduction +! This fuction performs following task +! `ans(i,j,l) = a1(i,j,k)*a2(k,l)` + +INTERFACE + 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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r3_r2 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j,l,m) = a1(i,j,k) * a2(k,l,m)` + +INTERFACE + MODULE PURE FUNCTION matmul_r3_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(a2, 2), size(a2, 3)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r3_r3 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j,l,m,n) = a1(i,j,k) * a2(k,l,m,n)` + +INTERFACE + MODULE PURE FUNCTION matmul_r3_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(a2, 2), size(a2, 3), size(a2, 4)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r3_r4 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank2 and rank3 array +! +!# Introduction +! +! This fuction performs following task +! `ans(i,k,l) = a1(i,j)*a2(j,k,l)` + +INTERFACE + 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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r2_r3 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank2 and rank3 array +! +!# Introduction +! +! This fuction performs following task +! `ans(i,k,l,m) = a1(i,j)*a2(j,k,l,m)` + +INTERFACE + 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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r2_r4 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank1 and rank3 array +! +!# Introduction +! +! This fuction performs following task +! `ans = a1(i)*a2(i)` + +INTERFACE + MODULE PURE FUNCTION matmul_r1_r1(a1, a2) RESULT(ans) + REAL(DFP), INTENT(IN) :: a1(:) + REAL(DFP), INTENT(IN) :: a2(:) + REAL(DFP) :: ans + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r1_r1 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank1 and rank3 array +! +!# Introduction +! +! This fuction performs following task +! `ans(j,k) = a1(i)*a2(i,j,k)` + +INTERFACE + 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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r1_r3 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! Matmul@Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank4 and rank1 array +! +!# Introduction +! +! `ans(j,k,l) = a1(i) * a2(i,j,k,l)` + +INTERFACE + 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)) + END FUNCTION +END INTERFACE + +INTERFACE MATMUL + MODULE PROCEDURE matmul_r1_r4 +END INTERFACE MATMUL + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE MatmulUtility \ No newline at end of file diff --git a/src/modules/Utility/src/MedianUtility.F90 b/src/modules/Utility/src/MedianUtility.F90 new file mode 100644 index 000000000..e98bf452d --- /dev/null +++ b/src/modules/Utility/src/MedianUtility.F90 @@ -0,0 +1,131 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 MedianUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: Median +PUBLIC :: ArgMedian + +!---------------------------------------------------------------------------- +! Median +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Given three numbers, find their median and sort at the same time + +INTERFACE Median + MODULE PURE SUBROUTINE Median_Int8(this, left, mid, right) + INTEGER(INT8), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE Median_Int8 + + MODULE PURE SUBROUTINE Median_Int16(this, left, mid, right) + INTEGER(INT16), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE Median_Int16 + + MODULE PURE SUBROUTINE Median_Int32(this, left, mid, right) + INTEGER(INT32), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE Median_Int32 + + MODULE PURE SUBROUTINE Median_Int64(this, left, mid, right) + INTEGER(INT64), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE Median_Int64 + + MODULE PURE SUBROUTINE Median_Real32(this, left, mid, right) + REAL(REAL32), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE Median_Real32 + + MODULE PURE SUBROUTINE Median_Real64(this, left, mid, right) + REAL(REAL64), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE Median_Real64 +END INTERFACE Median + +!---------------------------------------------------------------------------- +! ArgMedian +!---------------------------------------------------------------------------- + +INTERFACE ArgMedian + MODULE PURE SUBROUTINE ArgMedian_Int8(this, indx, left, mid, right) + INTEGER(INT8), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: indx(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE ArgMedian_Int8 + + MODULE PURE SUBROUTINE ArgMedian_Int16(this, indx, left, mid, right) + INTEGER(INT16), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: indx(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE ArgMedian_Int16 + + MODULE PURE SUBROUTINE ArgMedian_Int32(this, indx, left, mid, right) + INTEGER(INT32), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: indx(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE ArgMedian_Int32 + + MODULE PURE SUBROUTINE ArgMedian_Int64(this, indx, left, mid, right) + INTEGER(INT64), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: indx(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE ArgMedian_Int64 + + MODULE PURE SUBROUTINE ArgMedian_Real32(this, indx, left, mid, right) + REAL(REAL32), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: indx(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE ArgMedian_Real32 + + MODULE PURE SUBROUTINE ArgMedian_Real64(this, indx, left, mid, right) + REAL(REAL64), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: indx(:) + INTEGER(I4B), INTENT(IN) :: left + INTEGER(I4B), INTENT(IN) :: mid + INTEGER(I4B), INTENT(IN) :: right + END SUBROUTINE ArgMedian_Real64 +END INTERFACE ArgMedian + +END MODULE MedianUtility diff --git a/src/modules/Utility/src/MiscUtility.F90 b/src/modules/Utility/src/MiscUtility.F90 new file mode 100644 index 000000000..b50d156f3 --- /dev/null +++ b/src/modules/Utility/src/MiscUtility.F90 @@ -0,0 +1,384 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 MiscUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: radian +PUBLIC :: Degrees +PUBLIC :: SearchNearestCoord +PUBLIC :: ExecuteCommand +PUBLIC :: getUnitNo +PUBLIC :: Factorial +PUBLIC :: Int2Str +PUBLIC :: Real2Str +PUBLIC :: ARTH +PUBLIC :: outerdiff +PUBLIC :: IMAXLOC +PUBLIC :: IMINLOC +PUBLIC :: IMG + +!---------------------------------------------------------------------------- +! Radian@MISC +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! Convert degrees into radian + +INTERFACE + MODULE PURE FUNCTION radian_dfp(deg) RESULT(Ans) + REAL(DFP), INTENT(IN) :: deg + REAL(DFP) :: Ans + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! Radian@MISC +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! Converts degrees into radian + +INTERFACE + MODULE PURE FUNCTION radian_int(deg) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: deg + REAL(DFP) :: Ans + END FUNCTION +END INTERFACE + +INTERFACE radian + MODULE PROCEDURE radian_dfp, radian_int +END INTERFACE + +!---------------------------------------------------------------------------- +! Degrees@MISC +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This function converts radian into degrees +! Belongs to `Degrees` + +INTERFACE + MODULE PURE FUNCTION degrees_dfp(rad) RESULT(Ans) + REAL(DFP), INTENT(IN) :: rad + REAL(DFP) :: Ans + END FUNCTION +END INTERFACE + +INTERFACE Degrees + MODULE PROCEDURE degrees_dfp +END INTERFACE Degrees + +!---------------------------------------------------------------------------- +! @MISC +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Search the loc of nearest point to x in the array +! +!# Introduction +! +! This subroutine search the location of nearest point to x in the +! array of coordinates; Array +! +! ## Usage +! ```fortran +! real( dfp ) :: xij( 2, 20 ), x( 2 ) +! integer( i4b ) :: id +! +! call random_number( xij ) +! x = [11.0, 100.0] +! xij( 1:2, 15 ) = x +! id = searchNearestCoord(Array=xij, x=x) +! call display( id==15, "test4:: " ) +!``` + +INTERFACE + MODULE FUNCTION Loc_Nearest_Point(Array, x) RESULT(id) + REAL(DFP), INTENT(IN) :: Array(:, :) + !! Nodal coordinates in XiJ format + REAL(DFP), INTENT(IN) :: x(:) + INTEGER(I4B) :: id + END FUNCTION +END INTERFACE + +INTERFACE LOC_NearestPoint + MODULE PROCEDURE Loc_Nearest_Point +END INTERFACE LOC_NearestPoint + +PUBLIC :: LOC_NearestPoint + +INTERFACE SearchNearestCoord + MODULE PROCEDURE Loc_Nearest_Point +END INTERFACE SearchNearestCoord + +!---------------------------------------------------------------------------- +! ExecuteCommand@MISC +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: This subroutine run a system commoand on terminal + +INTERFACE + MODULE SUBROUTINE exe_cmd(CMD, Str) + CHARACTER(LEN=*), INTENT(IN) :: CMD, Str + END SUBROUTINE +END INTERFACE + +INTERFACE ExecuteCommand + MODULE PROCEDURE exe_cmd +END INTERFACE ExecuteCommand + +!---------------------------------------------------------------------------- +! getUnitNo@MISC +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION getUnitNo_1() RESULT(ans) + INTEGER(I4B) :: ans + END FUNCTION getUnitNo_1 +END INTERFACE + +INTERFACE getUnitNo + MODULE PROCEDURE getUnitNo_1 +END INTERFACE getUnitNo + +!---------------------------------------------------------------------------- +! Factorial@MISC +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: This FUNCTION computes the factorial of an INTEGER + +INTERFACE + MODULE PURE RECURSIVE FUNCTION Factorial(N) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: N + INTEGER(I4B) :: Ans + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! Int2STR@MISC +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Convert INTEGER to string + +INTERFACE + MODULE PURE FUNCTION Int2Str(I) + INTEGER(I4B), INTENT(IN) :: I + CHARACTER(LEN=15) :: Int2Str + END FUNCTION +END INTERFACE + +!---------------------------------------------------------------------------- +! Real2Str@MISC +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION SP2Str(I) + REAL(SP), INTENT(IN) :: I + CHARACTER(LEN=20) :: SP2Str + END FUNCTION +END INTERFACE + +INTERFACE + MODULE FUNCTION DP2Str(I) + REAL(DP), INTENT(IN) :: I + CHARACTER(LEN=20) :: DP2Str + END FUNCTION +END INTERFACE + +INTERFACE Real2Str + MODULE PROCEDURE SP2Str, DP2Str +END INTERFACE Real2Str + +!---------------------------------------------------------------------------- +! ARTH +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION arth_r(first, increment, n) + REAL(SP), INTENT(IN) :: first, increment + INTEGER(I4B), INTENT(IN) :: n + REAL(SP) :: arth_r(n) + END FUNCTION +END INTERFACE + +INTERFACE + MODULE PURE FUNCTION arth_d(first, increment, n) + REAL(DP), INTENT(IN) :: first, increment + INTEGER(I4B), INTENT(IN) :: n + REAL(DP) :: arth_d(n) + END FUNCTION +END INTERFACE + +INTERFACE + MODULE PURE FUNCTION arth_i(first, increment, n) + INTEGER(I4B), INTENT(IN) :: first, increment, n + INTEGER(I4B) :: arth_i(n) + END FUNCTION +END INTERFACE + +INTERFACE ARTH + MODULE PROCEDURE arth_d, arth_i, arth_r +END INTERFACE ARTH + +!---------------------------------------------------------------------------- +! outerdiff@MISC +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION outerdiff_r(a, b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a, b + 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 + 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 + END FUNCTION +END INTERFACE + +INTERFACE outerdiff + MODULE PROCEDURE outerdiff_r, outerdiff_i, outerdiff_d +END INTERFACE + +!---------------------------------------------------------------------------- +! IMAXLOC@MISC +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION imaxloc_r(arr) + REAL(DFP), INTENT(IN) :: arr(:) + INTEGER(I4B) :: imaxloc_r + END FUNCTION +END INTERFACE + +INTERFACE + MODULE PURE FUNCTION imaxloc_i(iarr) + INTEGER(I4B), INTENT(IN) :: iarr(:) + INTEGER(I4B) :: imaxloc_i + END FUNCTION +END INTERFACE + +INTERFACE IMAXLOC + MODULE PROCEDURE imaxloc_r, imaxloc_i +END INTERFACE + +!---------------------------------------------------------------------------- +! IMIN@MISC +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION iminloc_r(arr) + REAL(DFP), INTENT(IN) :: arr(:) + INTEGER(I4B) :: iminloc_r + END FUNCTION +END INTERFACE + +INTERFACE IMINLOC + MODULE PROCEDURE iminloc_r +END INTERFACE IMINLOC + +!---------------------------------------------------------------------------- +! IMG +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2022 +! summary: Return imaginary part of complex value + +INTERFACE + MODULE ELEMENTAL FUNCTION IMG_1(x) RESULT(ans) + COMPLEX(Real32), INTENT(IN) :: x + REAL(Real32) :: ans + END FUNCTION IMG_1 +END INTERFACE + +INTERFACE IMG + MODULE PROCEDURE IMG_1 +END INTERFACE IMG + +!---------------------------------------------------------------------------- +! IMG +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2022 +! summary: Return imaginary part of complex value + +INTERFACE + MODULE ELEMENTAL FUNCTION IMG_2(x) RESULT(ans) + COMPLEX(Real64), INTENT(IN) :: x + REAL(Real64) :: ans + END FUNCTION IMG_2 +END INTERFACE + +INTERFACE IMG + MODULE PROCEDURE IMG_2 +END INTERFACE IMG + +!---------------------------------------------------------------------------- +! safe_ACOS +!---------------------------------------------------------------------------- + +INTERFACE + MODULE ELEMENTAL FUNCTION safe_ACOS(c) RESULT(ans) + REAL(DFP), INTENT(IN) :: c + REAL(DFP) :: ans + END FUNCTION safe_ACOS +END INTERFACE + +PUBLIC :: safe_ACOS + +!---------------------------------------------------------------------------- +! safe_ASIN +!---------------------------------------------------------------------------- + +INTERFACE + MODULE ELEMENTAL FUNCTION safe_ASIN(s) RESULT(ans) + REAL(DFP), INTENT(IN) :: s + REAL(DFP) :: ans + END FUNCTION safe_ASIN +END INTERFACE + +PUBLIC :: safe_ASIN + +!---------------------------------------------------------------------------- +! Factorial@MISC +!---------------------------------------------------------------------------- + +END MODULE MiscUtility diff --git a/src/modules/Utility/src/OnesUtility.F90 b/src/modules/Utility/src/OnesUtility.F90 new file mode 100644 index 000000000..1712606ce --- /dev/null +++ b/src/modules/Utility/src/OnesUtility.F90 @@ -0,0 +1,363 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE OnesUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: ones +! +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_1( dim1, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1) +END FUNCTION ones_1 +!! +MODULE PURE FUNCTION ones_2( dim1, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1) +END FUNCTION ones_2 +!! +MODULE PURE FUNCTION ones_3( dim1, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1) +END FUNCTION ones_3 +!! +MODULE PURE FUNCTION ones_4( dim1, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1) +END FUNCTION ones_4 + +#ifdef USE_Int128 +!! +MODULE PURE FUNCTION ones_5( dim1, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1) +END FUNCTION ones_5 +#endif +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_1, ones_2, ones_3, ones_4 +END INTERFACE ones + +#ifdef USE_Int128 +INTERFACE ones + MODULE PROCEDURE ones_5 +END INTERFACE ones +#endif + +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_6( dim1, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1) +END FUNCTION ones_6 +!! +MODULE PURE FUNCTION ones_7( dim1, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1) +END FUNCTION ones_7 +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_6, ones_7 +END INTERFACE ones + +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_8( dim1, dim2, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1, dim2) +END FUNCTION ones_8 +!! +MODULE PURE FUNCTION ones_9( dim1, dim2, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1, dim2) +END FUNCTION ones_9 +!! +MODULE PURE FUNCTION ones_10( dim1, dim2, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1, dim2) +END FUNCTION ones_10 +!! +MODULE PURE FUNCTION ones_11( dim1, dim2, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1, dim2) +END FUNCTION ones_11 +!! +#ifdef USE_Int128 +!! +MODULE PURE FUNCTION ones_12( dim1, dim2, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2) +END FUNCTION ones_12 +#endif +!! +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_8, ones_9, ones_10, ones_11 +END INTERFACE ones + +#ifdef USE_Int128 +INTERFACE ones + MODULE PROCEDURE ones_12 +END INTERFACE ones +#endif + +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_13( dim1, dim2, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1, dim2) +END FUNCTION ones_13 +!! +MODULE PURE FUNCTION ones_14( dim1, dim2, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1, dim2) +END FUNCTION ones_14 +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_13, ones_14 +END INTERFACE ones + +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_15( dim1, dim2, dim3, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1, dim2, dim3) +END FUNCTION ones_15 +!! +MODULE PURE FUNCTION ones_16( dim1, dim2, dim3, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1, dim2, dim3) +END FUNCTION ones_16 +!! +MODULE PURE FUNCTION ones_17( dim1, dim2, dim3, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1, dim2, dim3) +END FUNCTION ones_17 +!! +MODULE PURE FUNCTION ones_18( dim1, dim2, dim3, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1, dim2, dim3) +END FUNCTION ones_18 + +#ifdef USE_Int128 + !! +MODULE PURE FUNCTION ones_19( dim1, dim2, dim3, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2, dim3) +END FUNCTION ones_19 +#endif +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_15, ones_16, ones_17, ones_18 +END INTERFACE ones + +#ifdef USE_Int128 +INTERFACE ones + MODULE PROCEDURE ones_19 +END INTERFACE ones +#endif + +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_20( dim1, dim2, dim3, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1, dim2, dim3) +END FUNCTION ones_20 +!! +MODULE PURE FUNCTION ones_21( dim1, dim2, dim3, datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1, dim2, dim3) +END FUNCTION ones_21 +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_20, ones_21 +END INTERFACE ones + +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_22( dim1, dim2, dim3, dim4,& + & datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1, dim2, dim3, dim4) +END FUNCTION ones_22 +!! +MODULE PURE FUNCTION ones_23( dim1, dim2, dim3, dim4,& + & datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1, dim2, dim3, dim4) +END FUNCTION ones_23 +!! +MODULE PURE FUNCTION ones_24( dim1, dim2, dim3, dim4,& + & datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1, dim2, dim3, dim4) +END FUNCTION ones_24 +!! +MODULE PURE FUNCTION ones_25( dim1, dim2, dim3, dim4,& + & datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1, dim2, dim3, dim4) +END FUNCTION ones_25 + +#ifdef USE_Int128 +!! +MODULE PURE FUNCTION ones_26( dim1, dim2, dim3, dim4, & + & datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2, dim3, dim4) +END FUNCTION ones_26 +#endif +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_22, ones_23, ones_24, ones_25 +END INTERFACE ones + +#ifdef USE_Int128 +INTERFACE ones + MODULE PROCEDURE ones_26 +END INTERFACE ones +#endif + +!---------------------------------------------------------------------------- +! Ones@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE FUNCTION ones_27( dim1, dim2, dim3, dim4, & + & datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1, dim2, dim3, dim4) +END FUNCTION ones_27 +!! +MODULE PURE FUNCTION ones_28( dim1, dim2, dim3, dim4, & + & datatype ) RESULT( Ans ) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1, dim2, dim3, dim4) +END FUNCTION ones_28 +END INTERFACE + +INTERFACE ones + MODULE PROCEDURE ones_27, ones_28 +END INTERFACE ones + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE OnesUtility \ No newline at end of file diff --git a/src/modules/Utility/src/PartitionUtility.F90 b/src/modules/Utility/src/PartitionUtility.F90 new file mode 100644 index 000000000..3fb18eced --- /dev/null +++ b/src/modules/Utility/src/PartitionUtility.F90 @@ -0,0 +1,174 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2023-06-27 +! summary: Partition methods for quicksorting and quickselect +! +!# Introduction +! +! This module contains Hoare's style partitioning algorithm used +! for quicksorting and quickselect routines. +! +! Reference: +! +! https://github.com/leonfoks/coretran/blob/master/src/core/m_partition.f90 + +MODULE PartitionUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: partition +PUBLIC :: argPartition + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Partitioning used for quickSort and quickSelect routines + +INTERFACE partition + MODULE PURE SUBROUTINE partition_Real32(this, left, right, iPivot) + REAL(REAL32), INTENT(inout) :: this(:) + !! 1D array + INTEGER(I4B), INTENT(in) :: left + !! Left index + INTEGER(I4B), INTENT(in) :: right + !! Right index + INTEGER(I4B), INTENT(inout) :: iPivot + !! Pivoting index + END SUBROUTINE + + MODULE PURE SUBROUTINE partition_Real64(this, left, right, iPivot) + REAL(REAL64), INTENT(inout) :: this(:) + !! 1D array + INTEGER(I4B), INTENT(in) :: left + !! Left index + INTEGER(I4B), INTENT(in) :: right + !! Right index + INTEGER(I4B), INTENT(inout) :: iPivot + !! Pivoting index + END SUBROUTINE + + MODULE PURE SUBROUTINE partition_Int8(this, left, right, iPivot) + INTEGER(INT8), INTENT(inout) :: this(:) + !! 1D array + INTEGER(I4B), INTENT(in) :: left + !! Left index + INTEGER(I4B), INTENT(in) :: right + !! Right index + INTEGER(I4B), INTENT(inout) :: iPivot + !! Pivoting index + END SUBROUTINE + + MODULE PURE SUBROUTINE partition_Int16(this, left, right, iPivot) + INTEGER(INT16), INTENT(inout) :: this(:) + !! 1D array + INTEGER(I4B), INTENT(in) :: left + !! Left index + INTEGER(I4B), INTENT(in) :: right + !! Right index + INTEGER(I4B), INTENT(inout) :: iPivot + !! Pivoting index + END SUBROUTINE + + MODULE PURE SUBROUTINE partition_Int32(this, left, right, iPivot) + INTEGER(INT32), INTENT(inout) :: this(:) + !! 1D array + INTEGER(I4B), INTENT(in) :: left + !! Left index + INTEGER(I4B), INTENT(in) :: right + !! Right index + INTEGER(I4B), INTENT(inout) :: iPivot + !! Pivoting index + END SUBROUTINE + + MODULE PURE SUBROUTINE partition_int64(this, left, right, iPivot) + INTEGER(INT64), INTENT(inout) :: this(:) + !! 1D array + INTEGER(I4B), INTENT(in) :: left + !! Left index + INTEGER(I4B), INTENT(in) :: right + !! Right index + INTEGER(I4B), INTENT(inout) :: iPivot + !! Pivoting index + END SUBROUTINE + +END INTERFACE + +!---------------------------------------------------------------------------- +! argPartition +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Partitioning used for argQuicksort routines + +INTERFACE argPartition + MODULE PURE SUBROUTINE argPartition_Real32(this, idx, left, right, i) + REAL(REAL32), INTENT(in) :: this(:) + INTEGER(I4B), INTENT(inout) :: idx(:) + INTEGER(I4B), INTENT(in) :: left + INTEGER(I4B), INTENT(in) :: right + INTEGER(I4B), INTENT(inout) :: i + END SUBROUTINE + + MODULE PURE SUBROUTINE argPartition_Real64(this, idx, left, right, i) + REAL(REAL64), INTENT(in) :: this(:) + INTEGER(I4B), INTENT(inout) :: idx(:) + INTEGER(I4B), INTENT(in) :: left + INTEGER(I4B), INTENT(in) :: right + INTEGER(I4B), INTENT(inout) :: i + END SUBROUTINE + + MODULE PURE SUBROUTINE argPartition_Int8(this, idx, left, right, i) + INTEGER(INT8), INTENT(in) :: this(:) + INTEGER(I4B), INTENT(inout) :: idx(:) + INTEGER(I4B), INTENT(in) :: left + INTEGER(I4B), INTENT(in) :: right + INTEGER(I4B), INTENT(inout) :: i + END SUBROUTINE + + MODULE PURE SUBROUTINE argPartition_Int16(this, idx, left, right, i) + INTEGER(INT16), INTENT(in) :: this(:) + INTEGER(I4B), INTENT(inout) :: idx(:) + INTEGER(I4B), INTENT(in) :: left + INTEGER(I4B), INTENT(in) :: right + INTEGER(I4B), INTENT(inout) :: i + END SUBROUTINE + + MODULE PURE SUBROUTINE argPartition_Int32(this, idx, left, right, i) + INTEGER(INT32), INTENT(in) :: this(:) + INTEGER(I4B), INTENT(inout) :: idx(:) + INTEGER(I4B), INTENT(in) :: left + INTEGER(I4B), INTENT(in) :: right + INTEGER(I4B), INTENT(inout) :: i + END SUBROUTINE + + MODULE PURE SUBROUTINE argPartition_Int64(this, idx, left, right, i) + INTEGER(INT64), INTENT(in) :: this(:) + INTEGER(I4B), INTENT(inout) :: idx(:) + INTEGER(I4B), INTENT(in) :: left + INTEGER(I4B), INTENT(in) :: right + INTEGER(I4B), INTENT(inout) :: i + END SUBROUTINE + +END INTERFACE argPartition + +END MODULE PartitionUtility diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 new file mode 100644 index 000000000..8bbe18966 --- /dev/null +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -0,0 +1,1413 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 ProductUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: OUTERPROD +PUBLIC :: Cross_Product +PUBLIC :: Vector_Product +PUBLIC :: VectorProduct + +!---------------------------------------------------------------------------- +! Cross_Product@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This FUNCTION evaluate vectors product +! +!# Introduction +! This FUNCTION evaluate vectors products +! $$\mathbf{ans} = \mathbf{a} \times \mathbf{b}$$ + +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 + +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 Cross_Product + MODULE PROCEDURE vectorProduct_1, vectorProduct_2 +END INTERFACE Cross_Product + +INTERFACE Vector_Product + MODULE PROCEDURE vectorProduct_1, vectorProduct_2 +END INTERFACE Vector_Product + +INTERFACE VectorProduct + MODULE PROCEDURE vectorProduct_1, vectorProduct_2 +END INTERFACE VectorProduct + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This FUNCTION returns outerproduct(matrix) of two vectors +! +!# Introduction +! +! $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ + +INTERFACE + MODULE PURE FUNCTION outerprod_r1r1(a, b) RESULT(ans) + 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 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This FUNCTION returns outerproduct +! +!# Introduction +! +! This FUNCTION returns outerproduct(matrix) of two vectors +! - $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ +! - If `Sym` is .true. THEN symmetric part is returned + +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 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r1r5 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r5 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This FUNCTION returns outerproduct + +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 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +INTERFACE + MODULE PURE FUNCTION outerprod_r2r2(a, b) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(b, 1),& + & SIZE(b, 2)) + END FUNCTION outerprod_r2r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r2 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> 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)) + END FUNCTION outerprod_r2r3 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r3 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r2r4 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r4 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r3r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r3r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r3r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r3r2 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r3r3 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r3r3 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r4r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r4r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r4r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r4r2 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +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)) + END FUNCTION outerprod_r5r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r5r1 +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 FUNCTION outerprod_r1r1r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(c, 1)) + END FUNCTION outerprod_r1r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r1 +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 FUNCTION outerprod_r1r1r2(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(c, 1),& + & SIZE(c, 2)) + END FUNCTION outerprod_r1r1r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r2 +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 FUNCTION outerprod_r1r1r3(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:, :, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(c, 1),& + & SIZE(c, 2),& + & SIZE(c, 3)) + END FUNCTION outerprod_r1r1r3 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r3 +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 FUNCTION outerprod_r1r1r4(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:, :, :, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(c, 1),& + & SIZE(c, 2),& + & SIZE(c, 3),& + & SIZE(c, 4)) + END FUNCTION outerprod_r1r1r4 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r4 +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 FUNCTION outerprod_r1r2r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(c, 1)) + END FUNCTION outerprod_r1r2r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r2r1 +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 FUNCTION outerprod_r1r2r2(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(IN) :: c(:, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(c, 1),& + & SIZE(c, 2)) + END FUNCTION outerprod_r1r2r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r2r2 +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 FUNCTION outerprod_r1r2r3(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(IN) :: c(:, :, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(c, 1),& + & SIZE(c, 2),& + & SIZE(c, 3)) + END FUNCTION outerprod_r1r2r3 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r2r3 +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 FUNCTION outerprod_r1r3r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:, :, :) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(b, 3),& + & SIZE(c, 1)) + END FUNCTION outerprod_r1r3r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r3r1 +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 FUNCTION outerprod_r1r3r2(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:, :, :) + REAL(DFP), INTENT(IN) :: c(:, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(b, 3),& + & SIZE(c, 1),& + & SIZE(c, 2)) + END FUNCTION outerprod_r1r3r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r3r2 +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 FUNCTION outerprod_r1r4r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:, :, :, :) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(b, 3),& + & SIZE(b, 4),& + & SIZE(c, 1)) + END FUNCTION outerprod_r1r4r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r4r1 +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 FUNCTION outerprod_r2r1r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(b, 1),& + & SIZE(c, 1)) + END FUNCTION outerprod_r2r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_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 FUNCTION outerprod_r2r1r2(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(b, 1),& + & SIZE(c, 1),& + & SIZE(c, 2)) + END FUNCTION outerprod_r2r1r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r1r2 +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 FUNCTION outerprod_r2r1r3(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:, :, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(b, 1),& + & SIZE(c, 1),& + & SIZE(c, 2),& + & SIZE(c, 3)) + END FUNCTION outerprod_r2r1r3 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r1r3 +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 FUNCTION outerprod_r2r2r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(c, 1)) + END FUNCTION outerprod_r2r2r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r2r1 +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 FUNCTION outerprod_r2r2r2(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(IN) :: c(:, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(c, 1),& + & SIZE(c, 2)) + END FUNCTION outerprod_r2r2r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r2r2 +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 FUNCTION outerprod_r3r1r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(a, 3),& + & SIZE(b, 1),& + & SIZE(c, 1)) + END FUNCTION outerprod_r3r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r3r1r1 +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 FUNCTION outerprod_r3r1r2(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:, :) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(a, 3),& + & SIZE(b, 1),& + & SIZE(c, 1),& + & SIZE(c, 2)) + END FUNCTION outerprod_r3r1r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r3r1r2 +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 FUNCTION outerprod_r3r2r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :, :) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(a, 3),& + & SIZE(b, 1),& + & SIZE(b, 2),& + & SIZE(c, 1)) + END FUNCTION outerprod_r3r2r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r3r2r1 +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 FUNCTION outerprod_r4r1r1(a, b, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(:, :, :, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP) :: ans( & + & SIZE(a, 1),& + & SIZE(a, 2),& + & SIZE(a, 3),& + & SIZE(a, 4),& + & SIZE(b, 1),& + & SIZE(c, 1)) + END FUNCTION outerprod_r4r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r4r1r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r1r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r1r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r1r1r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r1r2 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r1r1r3 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r1r3 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r1r2r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r2r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r1r2r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r2r2 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r1r3r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r1r3r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r2r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r2r1r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r2r1r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r2r1r2 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r2r2r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r2r2r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r1r3r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r1r3r1r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r2r1r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r1r1r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r2r1r1r2 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r1r1r2 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r2r1r2r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r1r2r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r2r2r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r2r2r1r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! OUTERPROD@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c d + +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)) + END FUNCTION outerprod_r3r1r1r1 +END INTERFACE + +INTERFACE OUTERPROD + MODULE PROCEDURE outerprod_r3r1r1r1 +END INTERFACE OUTERPROD + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ProductUtility diff --git a/src/modules/Utility/src/PushPopUtility.F90 b/src/modules/Utility/src/PushPopUtility.F90 new file mode 100644 index 000000000..3738796ec --- /dev/null +++ b/src/modules/Utility/src/PushPopUtility.F90 @@ -0,0 +1,272 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE PushPopUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Push +PUBLIC :: Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int8(vec, pos, value) RESULT(ans) + INTEGER(Int8), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int8), INTENT(IN) :: value + INTEGER(Int8) :: ans(SIZE(vec) + 1) + END FUNCTION push_int8 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int8 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int16(vec, pos, value) RESULT(ans) + INTEGER(Int16), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int16), INTENT(IN) :: value + INTEGER(Int16) :: ans(SIZE(vec) + 1) + END FUNCTION push_int16 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int16 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int32(vec, pos, value) RESULT(ans) + INTEGER(Int32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int32), INTENT(IN) :: value + INTEGER(Int32) :: ans(SIZE(vec) + 1) + END FUNCTION push_int32 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int32 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int64(vec, pos, value) RESULT(ans) + INTEGER(Int64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int64), INTENT(IN) :: value + INTEGER(Int64) :: ans(SIZE(vec) + 1) + END FUNCTION push_int64 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int64 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_real32(vec, pos, value) RESULT(ans) + REAL(Real32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real32), INTENT(IN) :: value + REAL(Real32) :: ans(SIZE(vec) + 1) + END FUNCTION push_real32 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_real32 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_real64(vec, pos, value) RESULT(ans) + REAL(Real64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real64), INTENT(IN) :: value + REAL(Real64) :: ans(SIZE(vec) + 1) + END FUNCTION push_real64 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_real64 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int8(vec, pos) RESULT(ans) + INTEGER(Int8), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int8) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int8 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int8 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int16(vec, pos) RESULT(ans) + INTEGER(Int16), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int16) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int16 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int16 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int32(vec, pos) RESULT(ans) + INTEGER(Int32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int32) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int32 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int32 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int64(vec, pos) RESULT(ans) + INTEGER(Int64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int64) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int64 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int64 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_real32(vec, pos) RESULT(ans) + REAL(Real32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real32) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_real32 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_real32 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_real64(vec, pos) RESULT(ans) + REAL(Real64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real64) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_real64 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_real64 +END INTERFACE Pop + +END MODULE PushPopUtility diff --git a/src/modules/Utility/src/ReallocateUtility.F90 b/src/modules/Utility/src/ReallocateUtility.F90 new file mode 100644 index 000000000..132063cdf --- /dev/null +++ b/src/modules/Utility/src/ReallocateUtility.F90 @@ -0,0 +1,801 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 ReallocateUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_logical(Mat, row) + LOGICAL(LGT), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE Reallocate_logical +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R1(Mat, row) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE Reallocate_Real64_R1 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R1b(Mat, s) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real64_R1b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R1(Mat, row) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE Reallocate_Real32_R1 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R1b(Mat, s) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real32_R1b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R2(Mat, row, col) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: row, col + END SUBROUTINE Reallocate_Real64_R2 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R2b(Mat, s) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real64_R2b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R2(Mat, row, col) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: row, col + END SUBROUTINE Reallocate_Real32_R2 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R2b(Mat, s) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real32_R2b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R3(Mat, i1, i2, i3) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + END SUBROUTINE Reallocate_Real64_R3 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R3b(Mat, s) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real64_R3b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R3(Mat, i1, i2, i3) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + END SUBROUTINE Reallocate_Real32_R3 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R3b(Mat, s) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real32_R3b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R4(Mat, i1, i2, i3, i4) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + END SUBROUTINE Reallocate_Real64_R4 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R4b(Mat, s) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real64_R4b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R4(Mat, i1, i2, i3, i4) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + END SUBROUTINE Reallocate_Real32_R4 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R4b(Mat, s) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real32_R4b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R5(Mat, i1, i2, i3, i4, i5) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + END SUBROUTINE Reallocate_Real64_R5 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R5b(Mat, s) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real64_R5b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R5(Mat, i1, i2, i3, i4, i5) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + END SUBROUTINE Reallocate_Real32_R5 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R5b(Mat, s) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real32_R5b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R6(Mat, i1, i2, i3, i4, i5, i6) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + END SUBROUTINE Reallocate_Real64_R6 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R6b(Mat, s) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real64_R6b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R6(Mat, i1, i2, i3, i4, i5, i6) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + END SUBROUTINE Reallocate_Real32_R6 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R6b(Mat, s) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real32_R6b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R7(Mat, i1, i2, i3, i4, i5, & + & i6, i7) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + END SUBROUTINE Reallocate_Real64_R7 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R7b(Mat, s) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real64_R7b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R7(Mat, i1, i2, i3, i4, i5, i6, i7) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + END SUBROUTINE Reallocate_Real32_R7 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R7b(Mat, s) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Real32_R7b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R1(Mat, row) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE Reallocate_Int64_R1 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE Reallocate_Int64_R1b(Mat, s) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int64_R1b +END INTERFACE + +INTERFACE Reallocate + MODULE PROCEDURE Reallocate_Int64_R1b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R1(Mat, row) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE Reallocate_Int32_R1 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R1b(Mat, s) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int32_R1b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int16_R1(Mat, row) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE Reallocate_Int16_R1 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int16_R1b(Mat, s) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int16_R1b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int8_R1(Mat, row) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: row + END SUBROUTINE Reallocate_Int8_R1 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int8_R1b(Mat, s) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int8_R1b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R2(Mat, row, col) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: row, col + END SUBROUTINE Reallocate_Int64_R2 + + MODULE PURE SUBROUTINE Reallocate_Int64_R2b(Mat, s) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int64_R2b + + MODULE PURE SUBROUTINE Reallocate_Int32_R2(Mat, row, col) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: row, col + END SUBROUTINE Reallocate_Int32_R2 + + MODULE PURE SUBROUTINE Reallocate_Int32_R2b(Mat, s) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int32_R2b + + MODULE PURE SUBROUTINE Reallocate_Int16_R2(Mat, row, col) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: row, col + END SUBROUTINE Reallocate_Int16_R2 + + MODULE PURE SUBROUTINE Reallocate_Int16_R2b(Mat, s) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int16_R2b + + MODULE PURE SUBROUTINE Reallocate_Int8_R2(Mat, row, col) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: row, col + END SUBROUTINE Reallocate_Int8_R2 + + MODULE PURE SUBROUTINE Reallocate_Int8_R2b(Mat, s) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int8_R2b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R3(Mat, i1, i2, i3) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + END SUBROUTINE Reallocate_Int64_R3 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R3b(Mat, s) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int64_R3b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R3(Mat, i1, i2, i3) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + END SUBROUTINE Reallocate_Int32_R3 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R3b(Mat, s) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int32_R3b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R4(Mat, i1, i2, i3, i4) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + END SUBROUTINE Reallocate_Int64_R4 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R4b(Mat, s) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int64_R4b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R4(Mat, i1, i2, i3, i4) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + END SUBROUTINE Reallocate_Int32_R4 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R4b(Mat, s) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int32_R4b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R5(Mat, i1, i2, i3, i4, i5) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + END SUBROUTINE Reallocate_Int64_R5 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R5b(Mat, s) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int64_R5b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R5(Mat, i1, i2, i3, i4, i5) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + END SUBROUTINE Reallocate_Int32_R5 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R5b(Mat, s) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int32_R5b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R6(Mat, i1, i2, i3, i4, i5, i6) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + END SUBROUTINE Reallocate_Int64_R6 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R6b(Mat, s) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int64_R6b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R6(Mat, i1, i2, i3, i4, i5, i6) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + END SUBROUTINE Reallocate_Int32_R6 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R6b(Mat, s) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int32_R6b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R7(Mat, i1, i2, i3, i4, i5, & + & i6, i7) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + END SUBROUTINE Reallocate_Int64_R7 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int64_R7b(Mat, s) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int64_R7b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R7(Mat, i1, i2, i3, i4, i5, i6, i7) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + END SUBROUTINE Reallocate_Int32_R7 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R7b(Mat, s) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + INTEGER(I4B), INTENT(IN) :: s(:) + END SUBROUTINE Reallocate_Int32_R7b +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Int32_R1_6(Vec1, n1, Vec2, n2, Vec3, & + & n3, Vec4, n4, Vec5, n5, Vec6, n6) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) + INTEGER(I4B), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & + & Vec4(:), Vec5(:), Vec6(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 + END SUBROUTINE Reallocate_Int32_R1_6 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_R1_6(Vec1, n1, Vec2, & + & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) + REAL(REAL64), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & + & Vec4(:), Vec5(:), Vec6(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 + END SUBROUTINE Reallocate_Real64_R1_6 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_R1_6(Vec1, n1, Vec2, & + & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) + REAL(REAL32), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & + & Vec4(:), Vec5(:), Vec6(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 + END SUBROUTINE Reallocate_Real32_R1_6 +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_AIJ(A, nA, IA, nIA, JA, nJA) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:) + INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA + END SUBROUTINE Reallocate_Real64_AIJ +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_AIJ(A, nA, IA, nIA, JA, nJA) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:) + INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA + END SUBROUTINE Reallocate_Real32_AIJ +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real64_AI(A, nA, IA, nIA) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:) + INTEGER(I4B), INTENT(IN) :: nA, nIA + END SUBROUTINE Reallocate_Real64_AI +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate@ReallocateMethods +!---------------------------------------------------------------------------- + +INTERFACE Reallocate + MODULE PURE SUBROUTINE Reallocate_Real32_AI(A, nA, IA, nIA) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:) + INTEGER(I4B), INTENT(IN) :: nA, nIA + END SUBROUTINE Reallocate_Real32_AI +END INTERFACE Reallocate + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +END MODULE ReallocateUtility diff --git a/src/modules/Utility/src/SafeSizeUtility.F90 b/src/modules/Utility/src/SafeSizeUtility.F90 new file mode 100644 index 000000000..b5f98207a --- /dev/null +++ b/src/modules/Utility/src/SafeSizeUtility.F90 @@ -0,0 +1,64 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE SafeSizeUtility +USE GlobalData, ONLY: INT8, INT16, INT32, REAL32, REAL64, I4B +IMPLICIT NONE + +PRIVATE + +PUBLIC :: SafeSize + +!---------------------------------------------------------------------------- +! SafeSize +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-08 +! summary: Like size but safe for unallocatable + +INTERFACE SafeSize + MODULE PURE FUNCTION SafeSize1(VALUE) RESULT(ans) + INTEGER(INT8), ALLOCATABLE, INTENT(IN) :: VALUE(:) + INTEGER(I4B) :: ans + END FUNCTION SafeSize1 + + MODULE PURE FUNCTION SafeSize2(VALUE) RESULT(ans) + INTEGER(INT16), ALLOCATABLE, INTENT(IN) :: VALUE(:) + INTEGER(I4B) :: ans + END FUNCTION SafeSize2 + + MODULE PURE FUNCTION SafeSize3(VALUE) RESULT(ans) + INTEGER(INT32), ALLOCATABLE, INTENT(IN) :: VALUE(:) + INTEGER(I4B) :: ans + END FUNCTION SafeSize3 + + MODULE PURE FUNCTION SafeSize4(VALUE) RESULT(ans) + REAL(REAL32), ALLOCATABLE, INTENT(IN) :: VALUE(:) + INTEGER(I4B) :: ans + END FUNCTION SafeSize4 + + MODULE PURE FUNCTION SafeSize5(VALUE) RESULT(ans) + REAL(REAL64), ALLOCATABLE, INTENT(IN) :: VALUE(:) + INTEGER(I4B) :: ans + END FUNCTION SafeSize5 + +END INTERFACE SafeSize + +END MODULE SafeSizeUtility diff --git a/src/modules/Utility/src/SortUtility.F90 b/src/modules/Utility/src/SortUtility.F90 new file mode 100644 index 000000000..392e60538 --- /dev/null +++ b/src/modules/Utility/src/SortUtility.F90 @@ -0,0 +1,808 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SortUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: ArgHeapSort +PUBLIC :: HeapSort +PUBLIC :: QuickSort +PUBLIC :: Sort +PUBLIC :: ArgSort +PUBLIC :: InsertionSort +PUBLIC :: ArgInsertionSort +PUBLIC :: IntroSort +PUBLIC :: ArgIntroSort + +!---------------------------------------------------------------------------- +! IntroSort +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Sorting by insertion algorithm + +INTERFACE + MODULE PURE SUBROUTINE IntroSort_Int8(array) + INTEGER(INT8), INTENT(INOUT) :: array(:) + END SUBROUTINE IntroSort_Int8 + MODULE PURE SUBROUTINE IntroSort_Int16(array) + INTEGER(INT16), INTENT(INOUT) :: array(:) + END SUBROUTINE IntroSort_Int16 + MODULE PURE SUBROUTINE IntroSort_Int32(array) + INTEGER(INT32), INTENT(INOUT) :: array(:) + END SUBROUTINE IntroSort_Int32 + MODULE PURE SUBROUTINE IntroSort_Int64(array) + INTEGER(INT64), INTENT(INOUT) :: array(:) + END SUBROUTINE IntroSort_Int64 + MODULE PURE SUBROUTINE IntroSort_Real32(array) + REAL(REAL32), INTENT(INOUT) :: array(:) + END SUBROUTINE IntroSort_Real32 + MODULE PURE SUBROUTINE IntroSort_Real64(array) + REAL(REAL64), INTENT(INOUT) :: array(:) + END SUBROUTINE IntroSort_Real64 +END INTERFACE + +INTERFACE IntroSort + MODULE PROCEDURE & + & IntroSort_Int8, & + & IntroSort_Int16, & + & IntroSort_Int32, & + & IntroSort_Int64, & + & IntroSort_Real32, & + & IntroSort_Real64 +END INTERFACE IntroSort + +!---------------------------------------------------------------------------- +! ArgIntroSort +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Indirect sorting by insertion sort + +INTERFACE + MODULE PURE SUBROUTINE ArgIntroSort_Int8(array, arg) + INTEGER(INT8), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + END SUBROUTINE ArgIntroSort_Int8 + + MODULE PURE SUBROUTINE ArgIntroSort_Int16(array, arg) + INTEGER(INT16), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + END SUBROUTINE ArgIntroSort_Int16 + + MODULE PURE SUBROUTINE ArgIntroSort_Int32(array, arg) + INTEGER(INT32), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + END SUBROUTINE ArgIntroSort_Int32 + + MODULE PURE SUBROUTINE ArgIntroSort_Int64(array, arg) + INTEGER(INT64), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + END SUBROUTINE ArgIntroSort_Int64 + + MODULE PURE SUBROUTINE ArgIntroSort_Real32(array, arg) + REAL(REAL32), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + END SUBROUTINE ArgIntroSort_Real32 + + MODULE PURE SUBROUTINE ArgIntroSort_Real64(array, arg) + REAL(REAL64), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + END SUBROUTINE ArgIntroSort_Real64 +END INTERFACE + +INTERFACE ArgIntroSort + MODULE PROCEDURE & + & ArgIntroSort_Int8, & + & ArgIntroSort_Int16, & + & ArgIntroSort_Int32, & + & ArgIntroSort_Int64, & + & ArgIntroSort_Real32, & + & ArgIntroSort_Real64 +END INTERFACE ArgIntroSort + +!---------------------------------------------------------------------------- +! IntroSort +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Sorting by insertion algorithm + +INTERFACE + MODULE PURE SUBROUTINE InsertionSort_Int8(array, low, high) + INTEGER(INT8), INTENT(INOUT) :: array(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE InsertionSort_Int8 + MODULE PURE SUBROUTINE InsertionSort_Int16(array, low, high) + INTEGER(INT16), INTENT(INOUT) :: array(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE InsertionSort_Int16 + MODULE PURE SUBROUTINE InsertionSort_Int32(array, low, high) + INTEGER(INT32), INTENT(INOUT) :: array(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE InsertionSort_Int32 + MODULE PURE SUBROUTINE InsertionSort_Int64(array, low, high) + INTEGER(INT64), INTENT(INOUT) :: array(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE InsertionSort_Int64 + MODULE PURE SUBROUTINE InsertionSort_Real32(array, low, high) + REAL(REAL32), INTENT(INOUT) :: array(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE InsertionSort_Real32 + MODULE PURE SUBROUTINE InsertionSort_Real64(array, low, high) + REAL(REAL64), INTENT(INOUT) :: array(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE InsertionSort_Real64 +END INTERFACE + +INTERFACE InsertionSort + MODULE PROCEDURE & + & InsertionSort_Int8, & + & InsertionSort_Int16, & + & InsertionSort_Int32, & + & InsertionSort_Int64, & + & InsertionSort_Real32, & + & InsertionSort_Real64 +END INTERFACE InsertionSort + +!---------------------------------------------------------------------------- +! ArgInsertionSort +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Indirect sorting by insertion sort + +INTERFACE + MODULE PURE SUBROUTINE ArgInsertionSort_Int8(array, arg, low, high) + INTEGER(INT8), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE ArgInsertionSort_Int8 + + MODULE PURE SUBROUTINE ArgInsertionSort_Int16(array, arg, low, high) + INTEGER(INT16), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE ArgInsertionSort_Int16 + + MODULE PURE SUBROUTINE ArgInsertionSort_Int32(array, arg, low, high) + INTEGER(INT32), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE ArgInsertionSort_Int32 + + MODULE PURE SUBROUTINE ArgInsertionSort_Int64(array, arg, low, high) + INTEGER(INT64), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE ArgInsertionSort_Int64 + + MODULE PURE SUBROUTINE ArgInsertionSort_Real32(array, arg, low, high) + REAL(REAL32), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE ArgInsertionSort_Real32 + + MODULE PURE SUBROUTINE ArgInsertionSort_Real64(array, arg, low, high) + REAL(REAL64), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(INOUT) :: arg(:) + INTEGER(I4B), INTENT(IN) :: low + INTEGER(I4B), INTENT(IN) :: high + END SUBROUTINE ArgInsertionSort_Real64 +END INTERFACE + +INTERFACE ArgInsertionSort + MODULE PROCEDURE & + & ArgInsertionSort_Int8, & + & ArgInsertionSort_Int16, & + & ArgInsertionSort_Int32, & + & ArgInsertionSort_Int64, & + & ArgInsertionSort_Real32, & + & ArgInsertionSort_Real64 +END INTERFACE ArgInsertionSort + +!---------------------------------------------------------------------------- +! HeapSort +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Heap Sort + +INTERFACE + MODULE PURE SUBROUTINE HeapSort_Int8(array) + INTEGER(INT8), INTENT(INOUT) :: array(:) + END SUBROUTINE HeapSort_Int8 + MODULE PURE SUBROUTINE HeapSort_Int16(array) + INTEGER(INT16), INTENT(INOUT) :: array(:) + END SUBROUTINE HeapSort_Int16 + MODULE PURE SUBROUTINE HeapSort_Int32(array) + INTEGER(INT32), INTENT(INOUT) :: array(:) + END SUBROUTINE HeapSort_Int32 + MODULE PURE SUBROUTINE HeapSort_Int64(array) + INTEGER(INT64), INTENT(INOUT) :: array(:) + END SUBROUTINE HeapSort_Int64 + MODULE PURE SUBROUTINE HeapSort_Real32(array) + REAL(REAL32), INTENT(INOUT) :: array(:) + END SUBROUTINE HeapSort_Real32 + MODULE PURE SUBROUTINE HeapSort_Real64(array) + REAL(REAL64), INTENT(INOUT) :: array(:) + END SUBROUTINE HeapSort_Real64 +END INTERFACE + +INTERFACE HeapSort + MODULE PROCEDURE HeapSort_Int8, HeapSort_Int16, HeapSort_Int32, & + & HeapSort_Int64, HeapSort_Real32, HeapSort_Real64 +END INTERFACE HeapSort + +!---------------------------------------------------------------------------- +! ArgHeapSort +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Heap Sort + +INTERFACE + MODULE PURE SUBROUTINE ArgHeapSort_Int8(array, arg) + INTEGER(INT8), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(OUT) :: arg(0:) + END SUBROUTINE ArgHeapSort_Int8 + + MODULE PURE SUBROUTINE ArgHeapSort_Int16(array, arg) + INTEGER(INT16), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(OUT) :: arg(0:) + END SUBROUTINE ArgHeapSort_Int16 + + MODULE PURE SUBROUTINE ArgHeapSort_Int32(array, arg) + INTEGER(INT32), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(OUT) :: arg(0:) + END SUBROUTINE ArgHeapSort_Int32 + + MODULE PURE SUBROUTINE ArgHeapSort_Int64(array, arg) + INTEGER(INT64), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(OUT) :: arg(0:) + END SUBROUTINE ArgHeapSort_Int64 + + MODULE PURE SUBROUTINE ArgHeapSort_Real32(array, arg) + REAL(REAL32), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(OUT) :: arg(0:) + END SUBROUTINE ArgHeapSort_Real32 + + MODULE PURE SUBROUTINE ArgHeapSort_Real64(array, arg) + REAL(REAL64), INTENT(IN) :: array(:) + INTEGER(I4B), INTENT(OUT) :: arg(0:) + END SUBROUTINE ArgHeapSort_Real64 +END INTERFACE + +INTERFACE ArgHeapSort + MODULE PROCEDURE ArgHeapSort_Int8, ArgHeapSort_Int16, ArgHeapSort_Int32, & + & ArgHeapSort_Int64, ArgHeapSort_Real32, ArgHeapSort_Real64 +END INTERFACE ArgHeapSort + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt8(vect1, low, high) + INTEGER(INT8), INTENT(INOUT) :: vect1(:) + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE QuickSort1vectInt8 + MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt16(vect1, low, high) + INTEGER(INT16), INTENT(INOUT) :: vect1(:) + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE QuickSort1vectInt16 + MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt32(vect1, low, high) + INTEGER(INT32), INTENT(INOUT) :: vect1(:) + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE QuickSort1vectInt32 + MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt64(vect1, low, high) + INTEGER(INT64), INTENT(INOUT) :: vect1(:) + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE QuickSort1vectInt64 + MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectReal32(vect1, low, high) + REAL(REAL32), INTENT(INOUT) :: vect1(:) + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE QuickSort1vectReal32 + MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectReal64(vect1, low, high) + REAL(REAL64), INTENT(INOUT) :: vect1(:) + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE QuickSort1vectReal64 +END INTERFACE + +INTERFACE QuickSort + MODULE PROCEDURE QuickSort1vectInt8, QuickSort1vectInt16, & + & QuickSort1vectInt32, QuickSort1vectInt64 + MODULE PROCEDURE QuickSort1vectReal32, QuickSort1vectReal64 +END INTERFACE QuickSort + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE RECURSIVE PURE SUBROUTINE QuickSort2vectIR(vect1, vect2, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectII(vect1, vect2, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRI(vect1, vect2, low, high) + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRR(vect1, vect2, low, high) + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIII(vect1, vect2, vect3, & + & low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIIR(vect1, vect2, vect3, & + & low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRR(vect1, vect2, vect3, & + & low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRI(vect1, vect2, vect3, & + & low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRR(vect1, vect2, vect3, & + & low, high) + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRI(vect1, vect2, vect3, & + & low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRIR(vect1, vect2, vect3, & + & low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRII(vect1, vect2, vect3, & + & low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIII(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIIR(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRI(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRR(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRR(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRI(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect4 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRIR(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRII(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRR(vect1, vect2, vect3, & + & vect4, low, high) + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRI(vect1, vect2, & + & vect3, vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect4 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRIR(vect1, vect2, & + & vect3, vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRII(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3, vect4 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRR(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRI(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect4 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIIR(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect4 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +!---------------------------------------------------------------------------- +! QuickSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIII(vect1, vect2, vect3, & + & vect4, low, high) + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4 + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 + INTEGER(I4B), INTENT(IN) :: low, high + END SUBROUTINE +END INTERFACE + +INTERFACE QuickSort + MODULE PROCEDURE QuickSort2vectII, & + & QuickSort2vectIR, QuickSort2vectRR, QuickSort2vectRI, & + & QuickSort3vectIII, QuickSort3vectIIR, QuickSort3vectIRI, & + & QuickSort3vectIRR, QuickSort3vectRRR, QuickSort3vectRRI, & + & QuickSort3vectRIR, QuickSort3vectRII, QuickSort4vectIIII, & + & QuickSort4vectIIIR, QuickSort4vectIIRI, QuickSort4vectIIRR, & + & QuickSort4vectIRII, QuickSort4vectIRIR, QuickSort4vectIRRI, & + & QuickSort4vectIRRR, QuickSort4vectRIII, QuickSort4vectRIIR, & + & QuickSort4vectRIRI, QuickSort4vectRIRR, QuickSort4vectRRII, & + & QuickSort4vectRRIR, QuickSort4vectRRRI, QuickSort4vectRRRR +END INTERFACE QuickSort + +!---------------------------------------------------------------------------- +! Sort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Sort_Int8(x, name) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(INT8) :: ans(SIZE(x)) + END FUNCTION Sort_Int8 + MODULE PURE FUNCTION Sort_Int16(x, name) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(INT16) :: ans(SIZE(x)) + END FUNCTION Sort_Int16 + MODULE PURE FUNCTION Sort_Int32(x, name) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(INT32) :: ans(SIZE(x)) + END FUNCTION Sort_Int32 + MODULE PURE FUNCTION Sort_Int64(x, name) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(INT64) :: ans(SIZE(x)) + END FUNCTION Sort_Int64 + MODULE PURE FUNCTION Sort_Real32(x, name) RESULT(ans) + REAL(REAL32), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + REAL(REAL32) :: ans(SIZE(x)) + END FUNCTION Sort_Real32 + MODULE PURE FUNCTION Sort_Real64(x, name) RESULT(ans) + REAL(REAL64), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + REAL(REAL64) :: ans(SIZE(x)) + END FUNCTION Sort_Real64 +END INTERFACE + +INTERFACE Sort + MODULE PROCEDURE Sort_Int8, Sort_Int16, Sort_Int32, Sort_Int64 + MODULE PROCEDURE Sort_Real32, Sort_Real64 +END INTERFACE Sort + +!---------------------------------------------------------------------------- +! ArgSort +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ArgSort_Int8(x, name) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(I4B) :: ans(SIZE(x)) + END FUNCTION ArgSort_Int8 + MODULE PURE FUNCTION ArgSort_Int16(x, name) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(I4B) :: ans(SIZE(x)) + END FUNCTION ArgSort_Int16 + MODULE PURE FUNCTION ArgSort_Int32(x, name) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(I4B) :: ans(SIZE(x)) + END FUNCTION ArgSort_Int32 + MODULE PURE FUNCTION ArgSort_Int64(x, name) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(I4B) :: ans(SIZE(x)) + END FUNCTION ArgSort_Int64 + MODULE PURE FUNCTION ArgSort_Real32(x, name) RESULT(ans) + REAL(REAL32), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(I4B) :: ans(SIZE(x)) + END FUNCTION ArgSort_Real32 + MODULE PURE FUNCTION ArgSort_Real64(x, name) RESULT(ans) + REAL(REAL64), INTENT(IN) :: x(:) + CHARACTER(*), OPTIONAL, INTENT(IN) :: name + INTEGER(I4B) :: ans(SIZE(x)) + END FUNCTION ArgSort_Real64 +END INTERFACE + +INTERFACE ArgSort + MODULE PROCEDURE ArgSort_Int8, ArgSort_Int16, ArgSort_Int32, ArgSort_Int64 + MODULE PROCEDURE ArgSort_Real32, ArgSort_Real64 +END INTERFACE ArgSort + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SortUtility diff --git a/src/modules/Utility/src/SplitUtility.F90 b/src/modules/Utility/src/SplitUtility.F90 new file mode 100644 index 000000000..44c40a849 --- /dev/null +++ b/src/modules/Utility/src/SplitUtility.F90 @@ -0,0 +1,129 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SplitUtility +USE GlobalData +IMPLICIT NONE +PRIVATE +PUBLIC :: SPLIT + +!---------------------------------------------------------------------------- +! SPLIT +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns the first half of the array `x` if `section == 1` +! +!# Introduction +! +! Returns the first half of the array `x` if `section == 1`, the second half +! of the array `x` if `section == 2`, and an empty array otherwise. If `size +! (x) == 1`, `split(x, 1)` returns and empty array, and `split(x, 2)` +! returns `x(1)`. + +INTERFACE SPLIT + MODULE PURE FUNCTION split_Int8(x, section) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: x(:) + !! Input array + INTEGER(I4B), INTENT(IN) :: section + !! Array section to return + INTEGER(INT8), ALLOCATABLE :: Ans(:) + END FUNCTION split_Int8 + + MODULE PURE FUNCTION split_Int16(x, section) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: x(:) + !! Input array + INTEGER(I4B), INTENT(IN) :: section + !! Array section to return + INTEGER(INT16), ALLOCATABLE :: Ans(:) + END FUNCTION split_Int16 + + MODULE PURE FUNCTION split_Int32(x, section) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: x(:) + !! Input array + INTEGER(I4B), INTENT(IN) :: section + !! Array section to return + INTEGER(INT32), ALLOCATABLE :: Ans(:) + END FUNCTION split_Int32 + + MODULE PURE FUNCTION split_Int64(x, section) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: x(:) + !! Input array + INTEGER(I4B), INTENT(IN) :: section + !! Array section to return + INTEGER(INT64), ALLOCATABLE :: Ans(:) + END FUNCTION split_Int64 +END INTERFACE SPLIT + +!---------------------------------------------------------------------------- +! SPLIT +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns the first half of the array `x` if `section == 1`, +! +!# Introduction +! +! Returns the first half of the array `x` if `section == 1`, the second half +! of the array `x` if `section == 2`, and an empty array otherwise. If `size +! (x) == 1`, `split(x, 1)` returns and empty array, and `split(x, 2)` +! returns `x(1)`. + +INTERFACE SPLIT + MODULE PURE FUNCTION split_Real32(x, section) RESULT(Ans) + REAL(REAL32), DIMENSION(:), INTENT(IN) :: x !! Input array + INTEGER(I4B), INTENT(IN) :: section !! Array section to return + REAL(REAL32), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION split_Real32 + + MODULE PURE FUNCTION split_Real64(x, section) RESULT(Ans) + REAL(REAL64), DIMENSION(:), INTENT(IN) :: x !! Input array + INTEGER(I4B), INTENT(IN) :: section !! Array section to return + REAL(REAL64), DIMENSION(:), ALLOCATABLE :: Ans + END FUNCTION split_Real64 +END INTERFACE SPLIT + +!---------------------------------------------------------------------------- +! SPLIT +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Returns the first half of the array `x` if `section == 1`, +! +!# Introduction +! +! Returns the first half of the array `x` if `section == 1`, the second half +! of the array `x` if `section == 2`, and an empty array otherwise. If `size +! (x) == 1`, `split(x, 1)` returns and empty array, and `split(x, 2)` +! returns `x(1)`. + +INTERFACE SPLIT + MODULE PURE FUNCTION split_char(x, section) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: x !! Input array + INTEGER(I4B), INTENT(IN) :: section !! Array section to return + CHARACTER(:), ALLOCATABLE :: Ans + END FUNCTION split_char +END INTERFACE SPLIT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SplitUtility diff --git a/src/modules/Utility/src/StringUtility.F90 b/src/modules/Utility/src/StringUtility.F90 new file mode 100644 index 000000000..b4ad84c41 --- /dev/null +++ b/src/modules/Utility/src/StringUtility.F90 @@ -0,0 +1,448 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 StringUtility +USE GlobalData, ONLY: I4B, LGT +USE String_Class, ONLY: String + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: FindReplace +PUBLIC :: GetFileParts +PUBLIC :: GetPath +PUBLIC :: GetFileName +PUBLIC :: GetFileNameExt +PUBLIC :: GetExtension +PUBLIC :: GetField +PUBLIC :: LowerCase +PUBLIC :: ToLowerCase +PUBLIC :: IsWhiteChar +PUBLIC :: IsBlank +PUBLIC :: NumStrings +PUBLIC :: NumMatchStr +PUBLIC :: IsPresent +PUBLIC :: StrFind +PUBLIC :: SlashRep +PUBLIC :: ToUpperCase +PUBLIC :: UpperCase + +PUBLIC :: PathJoin +PUBLIC :: PathBase +PUBLIC :: PathDir + +!---------------------------------------------------------------------------- +! PathBase +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Returns the base of the path +! +!# Introduction +! +! Base returns the last element of path. +! Trailing slashes are removed before extracting the +! last element. +! If the path is empty, Base returns ".". +! If the path consists entirely of slashes, Base returns "/". +! +! func main() { +! fmt.Println(path.Base("/a/b")) +! fmt.Println(path.Base("/")) +! fmt.Println(path.Base("")) +! } +! b +! / +! . + +INTERFACE + MODULE PURE FUNCTION PathBase(path) RESULT(ans) + CHARACTER(*), INTENT(in) :: path + CHARACTER(LEN=:), ALLOCATABLE :: ans + END FUNCTION PathBase +END INTERFACE + +!---------------------------------------------------------------------------- +! PathJoin +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Join two paths + +INTERFACE PathJoin + MODULE PURE FUNCTION PathJoin1(path1, path2) RESULT(ans) + CHARACTER(*), INTENT(in) :: path1 + CHARACTER(*), INTENT(in) :: path2 + CHARACTER(LEN=:), ALLOCATABLE :: ans + END FUNCTION PathJoin1 +END INTERFACE PathJoin + +!---------------------------------------------------------------------------- +! PathJoin +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Join two paths + +INTERFACE PathJoin + MODULE PURE FUNCTION PathJoin2(paths) RESULT(ans) + TYPE(String), INTENT(IN) :: paths(:) + CHARACTER(LEN=:), ALLOCATABLE :: ans + END FUNCTION PathJoin2 +END INTERFACE PathJoin + +!---------------------------------------------------------------------------- +! GetPath@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-17 +! summary: Returns the parent directory +! +!# Introduction +! +! Dir returns all but the last element of path, +! typically the path's directory. +! After dropping the final element using Split, +! the path is Cleaned and trailing slashes are removed. +! If the path is empty, Dir returns ".". +! If the path consists entirely of slashes followed by non-slash bytes, +! Dir returns a single slash. +! In any other case, the returned path does not end in a slash. + +INTERFACE + MODULE PURE FUNCTION PathDir(path) RESULT(ans) + CHARACTER(*), INTENT(IN) :: path + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION PathDir +END INTERFACE + +!---------------------------------------------------------------------------- +! GetPath@StringMethods +!---------------------------------------------------------------------------- + +INTERFACE GetPath + MODULE PURE SUBROUTINE GetPath_chars(chars, path) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(OUT) :: path + END SUBROUTINE GetPath_chars +END INTERFACE GetPath + +!---------------------------------------------------------------------------- +! UpperCase@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2021 +! summary: Returns the upperCase version of chars + +INTERFACE UpperCase + MODULE PURE FUNCTION UpperCase_char(chars) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(len=:), ALLOCATABLE :: ans + END FUNCTION UpperCase_char +END INTERFACE UpperCase + +!---------------------------------------------------------------------------- +! ToUpperCase@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2021 +! summary: Returns the upperCase version of chars + +INTERFACE ToUpperCase + MODULE PURE SUBROUTINE ToUpperCase_Char(chars) + CHARACTER(*), INTENT(INOUT) :: chars + END SUBROUTINE ToUpperCase_Char +END INTERFACE ToUpperCase + +!---------------------------------------------------------------------------- +! LowerCase@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2021 +! summary: Returns the LowerCase version of chars + +INTERFACE LowerCase + MODULE PURE FUNCTION LowerCase_char(chars) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION LowerCase_char +END INTERFACE LowerCase + +!---------------------------------------------------------------------------- +! ToLowerCase@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2021 +! summary: Returns the LowerCase version of chars + +INTERFACE ToLowerCase + MODULE PURE SUBROUTINE ToLowerCase_Char(chars) + CHARACTER(*), INTENT(INOUT) :: chars + END SUBROUTINE ToLowerCase_Char +END INTERFACE ToLowerCase + +!---------------------------------------------------------------------------- +! IsWhiteChar@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2021 +! summary: Returns true if the char is a space(32) or a tab(9). + +INTERFACE IsWhiteChar + MODULE PURE FUNCTION IsWhiteChar_char(char) RESULT(Ans) + CHARACTER(1), INTENT(IN) :: char + LOGICAL(LGT) :: ans + END FUNCTION IsWhiteChar_char +END INTERFACE IsWhiteChar + +!---------------------------------------------------------------------------- +! IsBlank@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2021 +! summary: Returns true of the entire string is blank + +INTERFACE IsBlank + MODULE PURE FUNCTION IsBlank_chars(chars) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: chars + LOGICAL(LGT) :: ans + END FUNCTION IsBlank_chars +END INTERFACE IsBlank + +!---------------------------------------------------------------------------- +! numString@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2021 +! summary: Returns number of substrings contained in input string 'chars' +! delimited by white space. +! +!# Introduction +! Returns number of substrings contained in input string 'chars' delimited by +! white space. +! This routien has been adopted from +! [https://github.com/CASL/Futility/blob/master/src/IO_Strings.F90] +! (https://github.com/CASL/Futility/blob/master/src/IO_Strings.F90) +! + +INTERFACE NumStrings + MODULE PURE FUNCTION NumStrings_chars(chars) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: chars + INTEGER(I4B) :: ans + END FUNCTION NumStrings_chars +END INTERFACE NumStrings + +!---------------------------------------------------------------------------- +! nmatchstr@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 sept 2021 +! summary: Returns the total number of times the substring pattern is +! found in the main string + +INTERFACE numMatchStr + MODULE PURE FUNCTION numMatchStr_chars(chars, pattern) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(IN) :: pattern + INTEGER(I4B) :: ans + END FUNCTION numMatchStr_chars +END INTERFACE numMatchStr + +!---------------------------------------------------------------------------- +! isPresent@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 sept 2021 +! summary: Returns whether or not a substring pattern is found within string +! +!# Introduction +! Returns whether or not a substring pattern is found within string +! +!@note +! Does not handle trailing spaces that can be eliminated by TRIM() so +! strings should be trimmed when passing into function. +!@endnote + +INTERFACE isPresent + MODULE PURE FUNCTION isPresent_chars(chars, pattern) RESULT(Ans) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(IN) :: pattern + LOGICAL(LGT) :: ans + END FUNCTION isPresent_chars +END INTERFACE isPresent + +!---------------------------------------------------------------------------- +! StrFind@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 sept 2021 +! summary: Function returns the indices in a string where substring pattern + +INTERFACE StrFind + MODULE PURE SUBROUTINE strFind_chars(chars, pattern, indices) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(IN) :: pattern + INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: indices(:) + END SUBROUTINE strFind_chars +END INTERFACE strFind + +!---------------------------------------------------------------------------- +! FindReplace@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 sept 2021 +! summary: Replaces a substring pattern with a different substring in a string +! +!# Introduction +! Replaces a substring pattern with a different substring in a string. +! - chars the string which will have substrings replaced. +! - findp the substring pattern to find and replace +! - repp the new substring that will be replace parts of string +! +!@note +! repp can be larger than findp and as long as the size of string can +! accomodate the increased length of all replacements. Trailing and preceding +! spaces are counted in all strings. +!@endnote + +INTERFACE FindReplace + MODULE PURE SUBROUTINE FindReplace_chars(chars, findp, repp) + CHARACTER(*), INTENT(INOUT) :: chars + CHARACTER(*), INTENT(IN) :: findp + CHARACTER(*), INTENT(IN) :: repp + END SUBROUTINE FindReplace_chars +END INTERFACE FindReplace + +!---------------------------------------------------------------------------- +! GetField@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 sept 2021 +! summary: Replaces a substring pattern with a different substring in a string + +INTERFACE GetField + MODULE PURE SUBROUTINE GetField_chars(i, chars, field, ierr) + INTEGER(I4B), INTENT(IN) :: i + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(:), ALLOCATABLE, INTENT(OUT) :: field + INTEGER(I4B), INTENT(OUT), OPTIONAL :: ierr + END SUBROUTINE GetField_chars +END INTERFACE GetField + +!---------------------------------------------------------------------------- +! SlashRep@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 sept 2021 +! summary: routine replaces slash character in file path names with +! the system appropriate file separator slash. +! +!# Introduction +! This routine returns the path, filename, and extension. + +INTERFACE SlashRep + MODULE PURE SUBROUTINE SlashRep_chars(chars) + CHARACTER(*), INTENT(INOUT) :: chars + END SUBROUTINE SlashRep_chars +END INTERFACE SlashRep + +!---------------------------------------------------------------------------- +! GetFileParts@StringMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 sept 2021 +! summary: Returns the path,filename, and extension +! +!# Introduction +! This routine returns the path, filename, and extension. + +INTERFACE GetFileParts + MODULE PURE SUBROUTINE GetFileParts_chars(chars, path, fname, ext) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(OUT) :: path + CHARACTER(*), INTENT(OUT) :: fname + CHARACTER(*), INTENT(OUT) :: ext + END SUBROUTINE GetFileParts_chars +END INTERFACE GetFileParts + +!---------------------------------------------------------------------------- +! GetFileName@StringMethods +!---------------------------------------------------------------------------- + +INTERFACE GetFileName + MODULE PURE SUBROUTINE GetFileName_chars(chars, fname) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(OUT) :: fname + END SUBROUTINE GetFileName_chars +END INTERFACE GetFileName + +!---------------------------------------------------------------------------- +! GetFileNameExt@StringMethods +!---------------------------------------------------------------------------- + +INTERFACE GetFileNameExt + MODULE PURE SUBROUTINE GetFileNameExt_chars(chars, ext) + CHARACTER(*), INTENT(IN) :: chars + CHARACTER(*), INTENT(OUT) :: ext + END SUBROUTINE GetFileNameExt_chars +END INTERFACE GetFileNameExt + +!---------------------------------------------------------------------------- +! GetExtension@StringMethods +!---------------------------------------------------------------------------- + +!> author: Dr. Vikas Sharma +! +! This function Get the extension from a file +! +! ## Usage +! ```fortran +! call display( GetExtension("helloworld.F90") .EQ. "f90", & +! & msg="test1:: ") +! ``` + +INTERFACE GetExtension + MODULE FUNCTION GetExtension_chars(char) RESULT(ext) + CHARACTER(*), INTENT(IN) :: char + CHARACTER(:), ALLOCATABLE :: ext + END FUNCTION +END INTERFACE GetExtension + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE StringUtility diff --git a/src/modules/Utility/src/SwapUtility.F90 b/src/modules/Utility/src/SwapUtility.F90 new file mode 100644 index 000000000..0375e0f00 --- /dev/null +++ b/src/modules/Utility/src/SwapUtility.F90 @@ -0,0 +1,830 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 SwapUtility +USE GlobalData, ONLY: INT8, INT16, INT32, INT64, REAL32, REAL64, & + DFPC, LGT, I4B + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: Swap +PUBLIC :: Swap_ + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two integer + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_Int8(a, b) + INTEGER(INT8), INTENT(INOUT) :: a, b + END SUBROUTINE Swap_Int8 + MODULE PURE SUBROUTINE Swap_Int16(a, b) + INTEGER(INT16), INTENT(INOUT) :: a, b + END SUBROUTINE Swap_Int16 + MODULE PURE SUBROUTINE Swap_Int32(a, b) + INTEGER(INT32), INTENT(INOUT) :: a, b + END SUBROUTINE Swap_Int32 + MODULE PURE SUBROUTINE Swap_Int64(a, b) + INTEGER(INT64), INTENT(INOUT) :: a, b + END SUBROUTINE Swap_Int64 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two real + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_r32(a, b) + REAL(REAL32), INTENT(INOUT) :: a, b + END SUBROUTINE Swap_r32 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two real + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_r64(a, b) + REAL(REAL64), INTENT(INOUT) :: a, b + END SUBROUTINE Swap_r64 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> 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_r32v(a, b) + REAL(REAL32), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_r32v + + MODULE PURE SUBROUTINE Swap_r64v(a, b) + REAL(REAL64), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_r64v +END INTERFACE Swap +#endif + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two integer vectors + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_Int8v(a, b) + INTEGER(INT8), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_Int8v + MODULE PURE SUBROUTINE Swap_Int16v(a, b) + INTEGER(INT16), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_Int16v + MODULE PURE SUBROUTINE Swap_Int32v(a, b) + INTEGER(INT32), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_Int32v + MODULE PURE SUBROUTINE Swap_Int64v(a, b) + INTEGER(INT64), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_Int64v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_Int128v(a, b) + INTEGER(INT128), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_Int128v +END INTERFACE Swap +#endif + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Subroutine for interchanging two complex numbers + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_c(a, b) + COMPLEX(DFPC), INTENT(INOUT) :: a, b + END SUBROUTINE Swap_c +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +#ifndef USE_BLAS95 +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_cv(a, b) + COMPLEX(DFPC), INTENT(INOUT) :: a(:), b(:) + END SUBROUTINE Swap_cv +END INTERFACE Swap +#endif + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_cm(a, b) + COMPLEX(DFPC), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_cm +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two matrix of real numbers + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_r32m(a, b) + REAL(REAL32), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_r32m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two real matrix + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_r64m(a, b) + REAL(REAL64), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_r64m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two integer matrix + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_Int8m(a, b) + INTEGER(INT8), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_Int8m + + MODULE PURE SUBROUTINE Swap_Int16m(a, b) + INTEGER(INT16), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_Int16m + + MODULE PURE SUBROUTINE Swap_Int32m(a, b) + INTEGER(INT32), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_Int32m + + MODULE PURE SUBROUTINE Swap_Int64m(a, b) + INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_Int64m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_Int128m(a, b) + INTEGER(Int128), INTENT(INOUT) :: a(:, :), b(:, :) + END SUBROUTINE Swap_Int128m +END INTERFACE Swap +#endif + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two scalars with masking + +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_r32s(a, b, mask) + REAL(REAL32), INTENT(INOUT) :: a, b + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE masked_Swap_r32s +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two scalars with masking + +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_r64s(a, b, mask) + REAL(REAL64), INTENT(INOUT) :: a, b + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE masked_Swap_r64s +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two scalars with masking + +INTERFACE Swap + 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 + + 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 + + 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 + + MODULE PURE SUBROUTINE masked_Swap_Int64s(a, b, mask) + INTEGER(INT64), INTENT(INOUT) :: a, b + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE masked_Swap_Int64s +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two scalars with masking + +#ifdef USE_Int128 +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_Int128s(a, b, mask) + INTEGER(Int128), INTENT(INOUT) :: a, b + LOGICAL(LGT), INTENT(IN) :: mask + END SUBROUTINE masked_Swap_Int128s +END INTERFACE Swap +#endif + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two vectors with masking + +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_r32v(a, b, mask) + REAL(REAL32), INTENT(INOUT) :: a(:), b(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE masked_Swap_r32v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two vectors with masking + +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_r64v(a, b, mask) + REAL(REAL64), INTENT(INOUT) :: a(:), b(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE masked_Swap_r64v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two vectors with masking + +INTERFACE Swap + 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 + + 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 + + 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 + + MODULE PURE SUBROUTINE masked_Swap_Int64v(a, b, mask) + INTEGER(INT64), INTENT(INOUT) :: a(:), b(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE masked_Swap_Int64v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two vectors with masking + +#ifdef USE_Int128 +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_Int128v(a, b, mask) + INTEGER(Int128), INTENT(INOUT) :: a(:), b(:) + LOGICAL(LGT), INTENT(IN) :: mask(:) + END SUBROUTINE masked_Swap_Int128v +END INTERFACE Swap +#endif + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two matrices with masking + +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_r32m(a, b, mask) + REAL(REAL32), INTENT(INOUT) :: a(:, :), b(:, :) + LOGICAL(LGT), INTENT(IN) :: mask(:, :) + END SUBROUTINE masked_Swap_r32m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two matrices with masking + +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_r64m(a, b, mask) + REAL(REAL64), INTENT(INOUT) :: a(:, :), b(:, :) + LOGICAL(LGT), INTENT(IN) :: mask(:, :) + END SUBROUTINE masked_Swap_r64m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two matrices with masking + +INTERFACE Swap + 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 + + 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 + + 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 + + MODULE PURE SUBROUTINE masked_Swap_Int64m(a, b, mask) + INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :) + LOGICAL(LGT), INTENT(IN) :: mask(:, :) + END SUBROUTINE masked_Swap_Int64m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two matrices with masking + +#ifdef USE_Int128 +INTERFACE Swap + MODULE PURE SUBROUTINE masked_Swap_Int128m(a, b, mask) + INTEGER(Int128), INTENT(INOUT) :: a(:, :), b(:, :) + LOGICAL(LGT), INTENT(IN) :: mask(:, :) + END SUBROUTINE masked_Swap_Int128m +END INTERFACE Swap +#endif + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-20 +! summary: Swap the index, it is like taking transpose. +! +!# Introduction +! +! - This routine returns an matrix by chaning the dimensions of input matrix +! `b`. +! - This routine does not check the shape, so make sure the shape of +! `a` and `b` are appropriate,. +! + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_index1(a, b, i1, i2) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :) + !! the returned array + REAL(REAL32), INTENT(IN) :: b(:, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 2 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 2 + END SUBROUTINE Swap_index1 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> 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_index2(a, b, i1, i2) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :) + !! the returned array + REAL(REAL64), INTENT(IN) :: b(:, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 2 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 2 + END SUBROUTINE Swap_index2 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-20 +! summary: Swap the index, it is like taking transpose. +! +!# Introduction +! +! - This routine returns an matrix by chaning the dimensions of input matrix +! `b`. +! - This routine does not check the shape, so make sure the shape of +! `a` and `b` are appropriate,. +! + +INTERFACE Swap_ + MODULE PURE SUBROUTINE Swap_index_1(a, b, i1, i2) + REAL(REAL32), INTENT(INOUT) :: a(:, :) + !! the returned array + REAL(REAL32), INTENT(IN) :: b(:, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 2 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 2 + END SUBROUTINE Swap_index_1 + + MODULE PURE SUBROUTINE Swap_index_2(a, b, i1, i2) + REAL(REAL64), INTENT(INOUT) :: a(:, :) + !! the returned array + REAL(REAL64), INTENT(IN) :: b(:, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 2 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 2 + END SUBROUTINE Swap_index_2 +END INTERFACE Swap_ + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> 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_index3(a, b, i1, i2, i3) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :) + !! the returned array + REAL(REAL32), INTENT(IN) :: b(:, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 3 + END SUBROUTINE Swap_index3 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> 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_3(a, b, i1, i2, i3) + REAL(REAL32), INTENT(INOUT) :: a(:, :, :) + !! the returned array + REAL(REAL32), INTENT(IN) :: b(:, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 3 + END SUBROUTINE Swap_index_3 + + MODULE PURE SUBROUTINE Swap_index_4(a, b, i1, i2, i3) + REAL(REAL64), INTENT(INOUT) :: a(:, :, :) + !! the returned array + REAL(REAL64), INTENT(IN) :: b(:, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 3 + END SUBROUTINE Swap_index_4 +END INTERFACE Swap_ + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-20 +! update: 2021-11-20 +! summary: Swap the index, it is like taking transpose. +! +!# Introduction +! +! - This routine returns an matrix by chaning the dimensions of input matrix +! `b`. +! - This routine does not check the shape, so make sure the shape of +! `a` and `b` are appropriate,. +! + +INTERFACE Swap + MODULE PURE SUBROUTINE Swap_index4(a, b, i1, i2, i3) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :) + !! the returned array + REAL(REAL64), INTENT(IN) :: b(:, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 3 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 3 + END SUBROUTINE Swap_index4 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> 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_index5(a, b, i1, i2, i3, i4) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) + !! the returned array + REAL(REAL64), INTENT(IN) :: b(:, :, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i4 + !! index 4 is Swapped with index `i4` + !! make sure i4 is less than or equal to 4 + END SUBROUTINE Swap_index5 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> 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_index6(a, b, i1, i2, i3, i4) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) + !! the returned array + REAL(REAL32), INTENT(IN) :: b(:, :, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i4 + !! index 4 is Swapped with index `i4` + !! make sure i4 is less than or equal to 4 + END SUBROUTINE Swap_index6 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@SwapMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-20 +! update: 2021-11-20 +! summary: Swap the index, it is like taking transpose. +! +!# Introduction +! +! - This routine returns an matrix by chaning the dimensions of input matrix +! `b`. +! - This routine does not check the shape, so make sure the shape of +! `a` and `b` are appropriate,. + +INTERFACE Swap_ + MODULE PURE SUBROUTINE Swap_index_5(a, b, i1, i2, i3, i4) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) + !! the returned array + REAL(REAL32), INTENT(IN) :: b(:, :, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i4 + !! index 4 is Swapped with index `i4` + !! make sure i4 is less than or equal to 4 + END SUBROUTINE Swap_index_5 + + MODULE PURE SUBROUTINE Swap_index_6(a, b, i1, i2, i3, i4) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) + !! the returned array + REAL(REAL64), INTENT(IN) :: b(:, :, :, :) + !! input array, it will be untouched + INTEGER(I4B), INTENT(IN) :: i1 + !! index 1 is Swapped with index `i1` + !! make sure i1 is lesser than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i2 + !! index 2 is Swapped with index `i2` + !! make sure i2 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i3 + !! index 3 is Swapped with index `i3` + !! make sure i3 is less than or equal to 4 + INTEGER(I4B), INTENT(IN) :: i4 + !! index 4 is Swapped with index `i4` + !! make sure i4 is less than or equal to 4 + END SUBROUTINE Swap_index_6 +END INTERFACE Swap_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SwapUtility diff --git a/src/modules/Utility/src/SymUtility.F90 b/src/modules/Utility/src/SymUtility.F90 new file mode 100644 index 000000000..34eb9062c --- /dev/null +++ b/src/modules/Utility/src/SymUtility.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 +! + +MODULE SymUtility +USE GlobalData, ONLY: DFP, I4B, REAL32, REAL64, INT32, INT64, INT8, INT16 +IMPLICIT NONE +PRIVATE +PUBLIC :: Sym +PUBLIC :: GetSym + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-12 +! summary: Make symmetric matrix form lower or upper triangular matrix +! +!# Introduction +! +! This method returns a symmetric matrix from the lower or upper +! triangular part of a given square dense matrix. +! +! If `from = U`, then upper triangle part of mat is used +! If `from = L`, then lower triangle part of mat is used + +INTERFACE + !! + MODULE PURE FUNCTION Sym_Int8(mat, from) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + INTEGER(INT8) :: ans(SIZE(mat, 1), SIZE(mat, 2)) + END FUNCTION Sym_Int8 + !! + MODULE PURE FUNCTION Sym_Int16(mat, from) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + INTEGER(INT16) :: ans(SIZE(mat, 1), SIZE(mat, 2)) + END FUNCTION Sym_Int16 + !! + MODULE PURE FUNCTION Sym_Int32(mat, from) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + INTEGER(INT32) :: ans(SIZE(mat, 1), SIZE(mat, 2)) + END FUNCTION Sym_Int32 + !! + MODULE PURE FUNCTION Sym_Int64(mat, from) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + INTEGER(INT64) :: ans(SIZE(mat, 1), SIZE(mat, 2)) + END FUNCTION Sym_Int64 + !! + MODULE PURE FUNCTION Sym_Real32(mat, from) RESULT(ans) + REAL(REAL32), INTENT(IN) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + REAL(REAL32) :: ans(SIZE(mat, 1), SIZE(mat, 2)) + END FUNCTION Sym_Real32 + !! + MODULE PURE FUNCTION Sym_Real64(mat, from) RESULT(ans) + REAL(REAL64), INTENT(IN) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + REAL(REAL64) :: ans(SIZE(mat, 1), SIZE(mat, 2)) + END FUNCTION Sym_Real64 + !! +END INTERFACE + +INTERFACE Sym + MODULE PROCEDURE Sym_Int8, Sym_Int16, Sym_Int32, & + & Sym_Int64, Sym_Real32, Sym_Real64 +END INTERFACE Sym + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-12 +! summary: Make symmetric matrix form lower or upper triangular matrix +! +!# Introduction +! +! This method returns a symmetric matrix from the lower or upper +! triangular part of a given square dense matrix. +! +! If `from = U`, then upper triangle part of mat is used +! If `from = L`, then lower triangle part of mat is used + +INTERFACE + MODULE PURE SUBROUTINE GetSym_Int8(mat, from) + INTEGER(INT8), INTENT(INOUT) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + END SUBROUTINE GetSym_Int8 + !! + MODULE PURE SUBROUTINE GetSym_Int16(mat, from) + INTEGER(INT16), INTENT(INOUT) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + END SUBROUTINE GetSym_Int16 + !! + MODULE PURE SUBROUTINE GetSym_Int32(mat, from) + INTEGER(INT32), INTENT(INOUT) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + END SUBROUTINE GetSym_Int32 + !! + MODULE PURE SUBROUTINE GetSym_Int64(mat, from) + INTEGER(INT64), INTENT(INOUT) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + END SUBROUTINE GetSym_Int64 + !! + MODULE PURE SUBROUTINE GetSym_Real32(mat, from) + REAL(REAL32), INTENT(INOUT) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + END SUBROUTINE GetSym_Real32 + !! + MODULE PURE SUBROUTINE GetSym_Real64(mat, from) + REAL(REAL64), INTENT(INOUT) :: mat(:, :) + CHARACTER(1), INTENT(IN) :: from + !! from = "U", then upper triangular part must be provided + !! from = "L", then lower triangular part must be provided + END SUBROUTINE GetSym_Real64 +END INTERFACE + +INTERFACE GetSym + MODULE PROCEDURE GetSym_Int8, GetSym_Int16, GetSym_Int32, & + & GetSym_Int64, GetSym_Real32, GetSym_Real64 +END INTERFACE GetSym + +END MODULE SymUtility diff --git a/src/modules/Utility/src/TailUtility.F90 b/src/modules/Utility/src/TailUtility.F90 new file mode 100644 index 000000000..957907374 --- /dev/null +++ b/src/modules/Utility/src/TailUtility.F90 @@ -0,0 +1,132 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 TailUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: TAIL +PUBLIC :: LAST + +!---------------------------------------------------------------------------- +! Tail +!---------------------------------------------------------------------------- + +INTERFACE TAIL + MODULE PURE FUNCTION tail_Int8(x) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: x(:) + INTEGER(INT8) :: ans(SIZE(x) - 1) + END FUNCTION tail_Int8 + + MODULE PURE FUNCTION tail_Int16(x) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: x(:) + INTEGER(INT16) :: ans(SIZE(x) - 1) + END FUNCTION tail_Int16 + + MODULE PURE FUNCTION tail_Int32(x) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: x(:) + INTEGER(INT32) :: ans(SIZE(x) - 1) + END FUNCTION tail_Int32 + + MODULE PURE FUNCTION tail_Int64(x) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: x(:) + INTEGER(INT64) :: ans(SIZE(x) - 1) + END FUNCTION tail_Int64 +END INTERFACE TAIL + +!---------------------------------------------------------------------------- +! Tail +!---------------------------------------------------------------------------- + +INTERFACE TAIL + MODULE PURE FUNCTION tail_Real32(x) RESULT(ans) + REAL(REAL32), INTENT(IN) :: x(:) + REAL(REAL32) :: ans(SIZE(x) - 1) + END FUNCTION tail_Real32 + + MODULE PURE FUNCTION tail_Real64(x) RESULT(ans) + REAL(REAL64), INTENT(IN) :: x(:) + REAL(REAL64) :: ans(SIZE(x) - 1) + END FUNCTION tail_Real64 +END INTERFACE TAIL + +!---------------------------------------------------------------------------- +! Tail +!---------------------------------------------------------------------------- + +INTERFACE TAIL + MODULE PURE FUNCTION tail_char(x) RESULT(ans) + CHARACTER(*), INTENT(IN) :: x + CHARACTER(LEN(x) - 1) :: ans + END FUNCTION tail_char +END INTERFACE TAIL + +!---------------------------------------------------------------------------- +! Last +!---------------------------------------------------------------------------- + +INTERFACE LAST + MODULE PURE FUNCTION last_Int8(x) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: x(:) + INTEGER(INT8) :: ans + END FUNCTION last_Int8 + + MODULE PURE FUNCTION last_Int16(x) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: x(:) + INTEGER(INT16) :: ans + END FUNCTION last_Int16 + + MODULE PURE FUNCTION last_Int32(x) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: x(:) + INTEGER(INT32) :: ans + END FUNCTION last_Int32 + + MODULE PURE FUNCTION last_Int64(x) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: x(:) + INTEGER(INT64) :: ans + END FUNCTION last_Int64 +END INTERFACE LAST + +!---------------------------------------------------------------------------- +! Last +!---------------------------------------------------------------------------- + +INTERFACE LAST + MODULE PURE FUNCTION last_Real32(x) RESULT(ans) + REAL(REAL32), INTENT(IN) :: x(:) + REAL(REAL32) :: ans + END FUNCTION last_Real32 + + MODULE PURE FUNCTION last_Real64(x) RESULT(ans) + REAL(REAL64), INTENT(IN) :: x(:) + REAL(REAL64) :: ans + END FUNCTION last_Real64 +END INTERFACE LAST + +!---------------------------------------------------------------------------- +! Last +!---------------------------------------------------------------------------- + +INTERFACE LAST + MODULE PURE FUNCTION last_char(x) RESULT(ans) + CHARACTER(*), INTENT(IN) :: x + CHARACTER(1) :: ans + END FUNCTION last_char +END INTERFACE LAST + +END MODULE TailUtility diff --git a/src/modules/Utility/src/TriagUtility.F90 b/src/modules/Utility/src/TriagUtility.F90 new file mode 100644 index 000000000..fb54e66dc --- /dev/null +++ b/src/modules/Utility/src/TriagUtility.F90 @@ -0,0 +1,1081 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2022-12-21 +! summary: Module for getting triangular parts of matrix +! +!# Introduction +! +! This module provides methods for getting and setting +! lower and upper triangular part of the matrix. +! +! This module is inspired by the same functionality avaiable in +! numpy +! +! Following methods are implemented or planned +! +! - TriuIndx() +! - TrilIndx() +! - Triu() +! - Tril() +! - GetTriu() +! - GetTril() +! - SetTriu() +! - SetTril() +! +!## TriuIndx +! +!```fortran +! TriuIndx(m=3, n=5, k = 0) !! matrix of shape (3,5) , diag = 0 +! TriuIndx(m=3, n=5, k = 1) !! matrix of shape (3,5) , diag = 1 +! TriuIndx(m=3, n=5, k = -1) !! matrix of shape (3,5) , diag = -1 +! TriuIndx(m=4, k = 0) !! square matrix of shape (4,4), diag = 0 +! TriuIndx(A, k=0) !! A is a matrix (square or rectangle) +!``` +!## TrilIndx +! +!```fortran +! TrilIndx(m=3, n=5, k = 0) !! matrix of shape (3,5) , diag = 0 +! TrilIndx(m=4, k = 0) !! square matrix of shape (4,4), diag = 0 +! TrilIndx(A, k=0) !! A is a matrix (square or rectangle) +!``` + +MODULE TriagUtility +USE GlobalData, ONLY: DFP, REAL32, REAL64, I4B, INT8, INT16, INT32, INT64, & + & LGT +IMPLICIT NONE +PRIVATE + +PUBLIC :: TriuIndx +PUBLIC :: TrilIndx +PUBLIC :: Tril +PUBLIC :: Triu +PUBLIC :: GetTril +PUBLIC :: GetTriu +PUBLIC :: SetTril +PUBLIC :: SetTriu + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the indices of upper triangle in an int vector +! +!# Introduction +! +! This function returns the indices of upper triangle in a integer vec +! starting from diag number k. +! +! k denotes the diag number +! k = 0 => main diag +! k > 0 => super diag +! k < 0 => sub diag + +INTERFACE + MODULE PURE FUNCTION TriuIndx_1(m, n, diagNo) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + !! number of rows + INTEGER(I4B), OPTIONAL, INTENT(IN) :: n + !! number of columns, default = m + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION TriuIndx_1 +END INTERFACE + +INTERFACE TriuIndx + MODULE PROCEDURE TriuIndx_1 +END INTERFACE TriuIndx + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the indices of upper triangle in an int vector +! +!# Introduction +! +! This function returns the indices of upper triangle in a integer vec +! starting from diag number k. Please read at TriuIndx_1 +! + +INTERFACE + MODULE PURE FUNCTION TriuIndx_2(A, diagNo) RESULT(ans) + CLASS(*), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION TriuIndx_2 +END INTERFACE + +INTERFACE TriuIndx + MODULE PROCEDURE TriuIndx_2 +END INTERFACE TriuIndx + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the indices of lower triangle part of a matrix + +INTERFACE + MODULE PURE FUNCTION TrilIndx_1(m, n, diagNo) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: m + !! number of rows + INTEGER(I4B), OPTIONAL, INTENT(IN) :: n + !! number of columns, default = m + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + !! ans(:,1) contains the row indices + !! ans(:,2) contains the col indices + END FUNCTION TrilIndx_1 +END INTERFACE + +INTERFACE TrilIndx + MODULE PROCEDURE TrilIndx_1 +END INTERFACE TrilIndx + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the indices of lower triangle part of a matrix + +INTERFACE + MODULE PURE FUNCTION TrilIndx_2(A, diagNo) RESULT(ans) + CLASS(*), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + !! ans(:,1) contains the row indices + !! ans(:,2) contains the col indices + END FUNCTION TrilIndx_2 +END INTERFACE + +INTERFACE TrilIndx + MODULE PROCEDURE TrilIndx_2 +END INTERFACE TrilIndx + +!---------------------------------------------------------------------------- +! Triu +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the upper triangle part of a matrix. + +INTERFACE + MODULE PURE FUNCTION Triu_1(A, diagNo) RESULT(ans) + REAL(REAL32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL32) :: ans(SIZE(A, 1), SIZE(A, 2)) + END FUNCTION Triu_1 + + MODULE PURE FUNCTION Triu_2(A, diagNo) RESULT(ans) + REAL(REAL64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL64) :: ans(SIZE(A, 1), SIZE(A, 2)) + END FUNCTION Triu_2 + + MODULE PURE FUNCTION Triu_3(A, diagNo) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT8) :: ans(SIZE(A, 1), SIZE(A, 2)) + END FUNCTION Triu_3 + + MODULE PURE FUNCTION Triu_4(A, diagNo) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT16) :: ans(SIZE(A, 1), SIZE(A, 2)) + END FUNCTION Triu_4 + + MODULE PURE FUNCTION Triu_5(A, diagNo) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT32) :: ans(SIZE(A, 1), SIZE(A, 2)) + END FUNCTION Triu_5 + + MODULE PURE FUNCTION Triu_6(A, diagNo) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT64) :: ans(SIZE(A, 1), SIZE(A, 2)) + END FUNCTION Triu_6 +END INTERFACE + +INTERFACE Triu + MODULE PROCEDURE Triu_1, Triu_2, Triu_3, Triu_4, Triu_5, Triu_6 +END INTERFACE Triu + +!---------------------------------------------------------------------------- +! Triu +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the lower triangle part of an int vector + +INTERFACE + MODULE PURE FUNCTION Triu_7(A, flate, diagNo) RESULT(ans) + REAL(REAL32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL32), ALLOCATABLE :: ans(:) + END FUNCTION Triu_7 + MODULE PURE FUNCTION Triu_8(A, flate, diagNo) RESULT(ans) + REAL(REAL64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL64), ALLOCATABLE :: ans(:) + END FUNCTION Triu_8 + MODULE PURE FUNCTION Triu_9(A, flate, diagNo) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT8), ALLOCATABLE :: ans(:) + END FUNCTION Triu_9 + MODULE PURE FUNCTION Triu_10(A, flate, diagNo) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT16), ALLOCATABLE :: ans(:) + END FUNCTION Triu_10 + MODULE PURE FUNCTION Triu_11(A, flate, diagNo) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT32), ALLOCATABLE :: ans(:) + END FUNCTION Triu_11 + MODULE PURE FUNCTION Triu_12(A, flate, diagNo) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT64), ALLOCATABLE :: ans(:) + END FUNCTION Triu_12 +END INTERFACE + +INTERFACE Triu + MODULE PROCEDURE Triu_7, Triu_8, Triu_9, Triu_10, Triu_11, Triu_12 +END INTERFACE Triu + +!---------------------------------------------------------------------------- +! Tril +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the lower triangle part of a matrix + +INTERFACE + MODULE PURE FUNCTION Tril_1(A, diagNo) RESULT(ans) + REAL(REAL32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL32) :: ans(SIZE(A, 1), SIZE(A, 2)) + !! Lower trianglular matrix + END FUNCTION Tril_1 + + MODULE PURE FUNCTION Tril_2(A, diagNo) RESULT(ans) + REAL(REAL64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL64) :: ans(SIZE(A, 1), SIZE(A, 2)) + !! Lower trianglular matrix + END FUNCTION Tril_2 + + MODULE PURE FUNCTION Tril_3(A, diagNo) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT8) :: ans(SIZE(A, 1), SIZE(A, 2)) + !! Lower trianglular matrix + END FUNCTION Tril_3 + + MODULE PURE FUNCTION Tril_4(A, diagNo) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT16) :: ans(SIZE(A, 1), SIZE(A, 2)) + !! Lower trianglular matrix + END FUNCTION Tril_4 + + MODULE PURE FUNCTION Tril_5(A, diagNo) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT32) :: ans(SIZE(A, 1), SIZE(A, 2)) + !! Lower trianglular matrix + END FUNCTION Tril_5 + + MODULE PURE FUNCTION Tril_6(A, diagNo) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT64) :: ans(SIZE(A, 1), SIZE(A, 2)) + !! Lower trianglular matrix + END FUNCTION Tril_6 +END INTERFACE + +INTERFACE Tril + MODULE PROCEDURE Tril_1, Tril_2, Tril_3, Tril_4, Tril_5, Tril_6 +END INTERFACE Tril + +!---------------------------------------------------------------------------- +! Tril +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the lower triangle part of a matrix + +INTERFACE + MODULE PURE FUNCTION Tril_7(A, flate, diagNo) RESULT(ans) + REAL(REAL32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL32), ALLOCATABLE :: ans(:) + END FUNCTION Tril_7 + MODULE PURE FUNCTION Tril_8(A, flate, diagNo) RESULT(ans) + REAL(REAL64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + REAL(REAL64), ALLOCATABLE :: ans(:) + END FUNCTION Tril_8 + MODULE PURE FUNCTION Tril_9(A, flate, diagNo) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT8), ALLOCATABLE :: ans(:) + END FUNCTION Tril_9 + MODULE PURE FUNCTION Tril_10(A, flate, diagNo) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT16), ALLOCATABLE :: ans(:) + END FUNCTION Tril_10 + MODULE PURE FUNCTION Tril_11(A, flate, diagNo) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT32), ALLOCATABLE :: ans(:) + END FUNCTION Tril_11 + MODULE PURE FUNCTION Tril_12(A, flate, diagNo) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + !! diagNo>0 means super diagonal + !! diagNo<0 means subdiagonal + INTEGER(INT64), ALLOCATABLE :: ans(:) + END FUNCTION Tril_12 +END INTERFACE + +INTERFACE Tril + MODULE PROCEDURE Tril_7, Tril_8, Tril_9, Tril_10, Tril_11, Tril_12 +END INTERFACE Tril + +!---------------------------------------------------------------------------- +! GetTriu +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the upper triangle part of a matrix + +INTERFACE + MODULE PURE SUBROUTINE GetTriu_1(A, diagNo, lu) + REAL(REAL32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTriu_1 + + MODULE PURE SUBROUTINE GetTriu_2(A, diagNo, lu) + REAL(REAL64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTriu_2 + + MODULE PURE SUBROUTINE GetTriu_3(A, diagNo, lu) + INTEGER(INT8), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTriu_3 + + MODULE PURE SUBROUTINE GetTriu_4(A, diagNo, lu) + INTEGER(INT16), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTriu_4 + + MODULE PURE SUBROUTINE GetTriu_5(A, diagNo, lu) + INTEGER(INT32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTriu_5 + + MODULE PURE SUBROUTINE GetTriu_6(A, diagNo, lu) + INTEGER(INT64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTriu_6 +END INTERFACE + +INTERFACE GetTriu + MODULE PROCEDURE GetTriu_1, GetTriu_2, GetTriu_3, GetTriu_4, & + & GetTriu_5, GetTriu_6 +END INTERFACE GetTriu + +!---------------------------------------------------------------------------- +! GetTriu +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the upper triangle part of an int vector + +INTERFACE + MODULE PURE SUBROUTINE GetTriu_7(A, flate, diagNo, lu) + REAL(REAL32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTriu_7 + MODULE PURE SUBROUTINE GetTriu_8(A, flate, diagNo, lu) + REAL(REAL64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTriu_8 + MODULE PURE SUBROUTINE GetTriu_9(A, flate, diagNo, lu) + INTEGER(INT8), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTriu_9 + MODULE PURE SUBROUTINE GetTriu_10(A, flate, diagNo, lu) + INTEGER(INT16), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTriu_10 + MODULE PURE SUBROUTINE GetTriu_11(A, flate, diagNo, lu) + INTEGER(INT32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTriu_11 + MODULE PURE SUBROUTINE GetTriu_12(A, flate, diagNo, lu) + INTEGER(INT64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTriu_12 +END INTERFACE + +INTERFACE GetTriu + MODULE PROCEDURE GetTriu_7, GetTriu_8, GetTriu_9, GetTriu_10, & + & GetTriu_11, GetTriu_12 +END INTERFACE GetTriu + +!---------------------------------------------------------------------------- +! GetTril +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the lower triangle part of an int vector + +INTERFACE + MODULE PURE SUBROUTINE GetTril_1(A, diagNo, lu) + REAL(REAL32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTril_1 + + MODULE PURE SUBROUTINE GetTril_2(A, diagNo, lu) + REAL(REAL64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTril_2 + + MODULE PURE SUBROUTINE GetTril_3(A, diagNo, lu) + INTEGER(INT8), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTril_3 + + MODULE PURE SUBROUTINE GetTril_4(A, diagNo, lu) + INTEGER(INT16), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTril_4 + + MODULE PURE SUBROUTINE GetTril_5(A, diagNo, lu) + INTEGER(INT32), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTril_5 + + MODULE PURE SUBROUTINE GetTril_6(A, diagNo, lu) + INTEGER(INT64), INTENT(IN) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), INTENT(OUT) :: lu(SIZE(A, 1), SIZE(A, 2)) + END SUBROUTINE GetTril_6 +END INTERFACE + +INTERFACE GetTril + MODULE PROCEDURE GetTril_1, GetTril_2, GetTril_3, GetTril_4, & + & GetTril_5, GetTril_6 +END INTERFACE GetTril + +!---------------------------------------------------------------------------- +! GetTril +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the lower triangle part of an int vector + +INTERFACE + MODULE PURE SUBROUTINE GetTril_7(A, flate, diagNo, lu) + REAL(REAL32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTril_7 + MODULE PURE SUBROUTINE GetTril_8(A, flate, diagNo, lu) + REAL(REAL64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTril_8 + MODULE PURE SUBROUTINE GetTril_9(A, flate, diagNo, lu) + INTEGER(INT8), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTril_9 + MODULE PURE SUBROUTINE GetTril_10(A, flate, diagNo, lu) + INTEGER(INT16), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTril_10 + MODULE PURE SUBROUTINE GetTril_11(A, flate, diagNo, lu) + INTEGER(INT32), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTril_11 + MODULE PURE SUBROUTINE GetTril_12(A, flate, diagNo, lu) + INTEGER(INT64), INTENT(IN) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), ALLOCATABLE, INTENT(OUT) :: lu(:) + END SUBROUTINE GetTril_12 +END INTERFACE + +INTERFACE GetTril + MODULE PROCEDURE GetTril_7, GetTril_8, GetTril_9, GetTril_10, & + & GetTril_11, GetTril_12 +END INTERFACE GetTril + +!---------------------------------------------------------------------------- +! SetTriu +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the upper triangle part of an int vector + +INTERFACE + MODULE PURE SUBROUTINE SetTriu_1(A, lu, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTriu_1 + + MODULE PURE SUBROUTINE SetTriu_2(A, lu, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTriu_2 + + MODULE PURE SUBROUTINE SetTriu_3(A, lu, diagNo) + INTEGER(INT8), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTriu_3 + + MODULE PURE SUBROUTINE SetTriu_4(A, lu, diagNo) + INTEGER(INT16), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTriu_4 + + MODULE PURE SUBROUTINE SetTriu_5(A, lu, diagNo) + INTEGER(INT32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTriu_5 + + MODULE PURE SUBROUTINE SetTriu_6(A, lu, diagNo) + INTEGER(INT64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTriu_6 +END INTERFACE + +INTERFACE SetTriu + MODULE PROCEDURE SetTriu_1, SetTriu_2, SetTriu_3, SetTriu_4, & + & SetTriu_5, SetTriu_6 +END INTERFACE SetTriu + +!---------------------------------------------------------------------------- +! SetTriu +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the upper triangle part of an int vector + +INTERFACE + MODULE PURE SUBROUTINE SetTriu_7(A, flate, lu, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: lu(:) + END SUBROUTINE SetTriu_7 + MODULE PURE SUBROUTINE SetTriu_8(A, flate, lu, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: lu(:) + END SUBROUTINE SetTriu_8 + MODULE PURE SUBROUTINE SetTriu_9(A, flate, lu, diagNo) + INTEGER(INT8), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), INTENT(IN) :: lu(:) + END SUBROUTINE SetTriu_9 + MODULE PURE SUBROUTINE SetTriu_10(A, flate, lu, diagNo) + INTEGER(INT16), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), INTENT(IN) :: lu(:) + END SUBROUTINE SetTriu_10 + MODULE PURE SUBROUTINE SetTriu_11(A, flate, lu, diagNo) + INTEGER(INT32), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), INTENT(IN) :: lu(:) + END SUBROUTINE SetTriu_11 + MODULE PURE SUBROUTINE SetTriu_12(A, flate, lu, diagNo) + INTEGER(INT64), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), INTENT(IN) :: lu(:) + END SUBROUTINE SetTriu_12 +END INTERFACE + +INTERFACE SetTriu + MODULE PROCEDURE SetTriu_7, SetTriu_8, SetTriu_9, SetTriu_10, & + & SetTriu_11, SetTriu_12 +END INTERFACE SetTriu + +!---------------------------------------------------------------------------- +! SetTriu +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Set the upper triangle part to a scalar value + +INTERFACE + + MODULE PURE SUBROUTINE SetTriu_13(A, val, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: val + END SUBROUTINE SetTriu_13 + + MODULE PURE SUBROUTINE SetTriu_14(A, val, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: val + END SUBROUTINE SetTriu_14 + + MODULE PURE SUBROUTINE SetTriu_15(A, val, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(I4B), INTENT(IN) :: val + END SUBROUTINE SetTriu_15 + + MODULE PURE SUBROUTINE SetTriu_16(A, val, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: val + END SUBROUTINE SetTriu_16 + + MODULE PURE SUBROUTINE SetTriu_17(A, val, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: val + END SUBROUTINE SetTriu_17 + + MODULE PURE SUBROUTINE SetTriu_18(A, val, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(I4B), INTENT(IN) :: val + END SUBROUTINE SetTriu_18 + +END INTERFACE + +INTERFACE SetTriu + MODULE PROCEDURE SetTriu_13, SetTriu_14, SetTriu_15, & + & SetTriu_16, SetTriu_17, SetTriu_18 +END INTERFACE SetTriu + +!---------------------------------------------------------------------------- +! SetTril +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the upper triangle part of an int vector + +INTERFACE + MODULE PURE SUBROUTINE SetTril_1(A, lu, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTril_1 + + MODULE PURE SUBROUTINE SetTril_2(A, lu, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTril_2 + + MODULE PURE SUBROUTINE SetTril_3(A, lu, diagNo) + INTEGER(INT8), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTril_3 + + MODULE PURE SUBROUTINE SetTril_4(A, lu, diagNo) + INTEGER(INT16), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTril_4 + + MODULE PURE SUBROUTINE SetTril_5(A, lu, diagNo) + INTEGER(INT32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTril_5 + + MODULE PURE SUBROUTINE SetTril_6(A, lu, diagNo) + INTEGER(INT64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), INTENT(IN) :: lu(:, :) + END SUBROUTINE SetTril_6 +END INTERFACE + +INTERFACE SetTril + MODULE PROCEDURE SetTril_1, SetTril_2, SetTril_3, SetTril_4, & + & SetTril_5, SetTril_6 +END INTERFACE SetTril + +!---------------------------------------------------------------------------- +! SetTril +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Returns the upper triangle part of an int vector + +INTERFACE + MODULE PURE SUBROUTINE SetTril_7(A, flate, lu, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: lu(:) + END SUBROUTINE SetTril_7 + MODULE PURE SUBROUTINE SetTril_8(A, flate, lu, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: lu(:) + END SUBROUTINE SetTril_8 + MODULE PURE SUBROUTINE SetTril_9(A, flate, lu, diagNo) + INTEGER(INT8), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT8), INTENT(IN) :: lu(:) + END SUBROUTINE SetTril_9 + MODULE PURE SUBROUTINE SetTril_10(A, flate, lu, diagNo) + INTEGER(INT16), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT16), INTENT(IN) :: lu(:) + END SUBROUTINE SetTril_10 + MODULE PURE SUBROUTINE SetTril_11(A, flate, lu, diagNo) + INTEGER(INT32), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT32), INTENT(IN) :: lu(:) + END SUBROUTINE SetTril_11 + MODULE PURE SUBROUTINE SetTril_12(A, flate, lu, diagNo) + INTEGER(INT64), INTENT(INOUT) :: A(:, :) + LOGICAL(LGT), INTENT(IN) :: flate + !! This variable is only for creating unique interface + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(INT64), INTENT(IN) :: lu(:) + END SUBROUTINE SetTril_12 +END INTERFACE + +INTERFACE SetTril + MODULE PROCEDURE SetTril_7, SetTril_8, SetTril_9, SetTril_10, & + & SetTril_11, SetTril_12 +END INTERFACE SetTril + +!---------------------------------------------------------------------------- +! SetTril +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: Set lower triangle part to a scalar value + +INTERFACE + + MODULE PURE SUBROUTINE SetTril_13(A, val, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: val + END SUBROUTINE SetTril_13 + + MODULE PURE SUBROUTINE SetTril_14(A, val, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: val + END SUBROUTINE SetTril_14 + + MODULE PURE SUBROUTINE SetTril_15(A, val, diagNo) + REAL(REAL32), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(I4B), INTENT(IN) :: val + END SUBROUTINE SetTril_15 + + MODULE PURE SUBROUTINE SetTril_16(A, val, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL32), INTENT(IN) :: val + END SUBROUTINE SetTril_16 + + MODULE PURE SUBROUTINE SetTril_17(A, val, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + REAL(REAL64), INTENT(IN) :: val + END SUBROUTINE SetTril_17 + + MODULE PURE SUBROUTINE SetTril_18(A, val, diagNo) + REAL(REAL64), INTENT(INOUT) :: A(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: diagNo + !! diagonal number, default = 0 + INTEGER(I4B), INTENT(IN) :: val + END SUBROUTINE SetTril_18 + +END INTERFACE + +INTERFACE SetTril + MODULE PROCEDURE SetTril_13, SetTril_14, SetTril_15, & + & SetTril_16, SetTril_17, SetTril_18 +END INTERFACE SetTril + +END MODULE TriagUtility diff --git a/src/modules/Utility/src/Utility.F90 b/src/modules/Utility/src/Utility.F90 new file mode 100755 index 000000000..09c856099 --- /dev/null +++ b/src/modules/Utility/src/Utility.F90 @@ -0,0 +1,59 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2024-04-11 +! summary: This module contains several utility modules +! +!{!pages/Utility/index.md!} + +MODULE Utility +USE AppendUtility +USE ApproxUtility +USE ArangeUtility +USE AssertUtility +USE BinomUtility +USE ContractionUtility +USE ConvertUtility +USE DiagUtility +USE EigenUtility +USE EyeUtility +USE HeadUtility +USE TailUtility +USE SplitUtility +USE GridPointUtility +USE HashingUtility +USE InputUtility +USE IntegerUtility +USE InvUtility +USE LinearAlgebraUtility +USE MappingUtility +USE MatmulUtility +USE MedianUtility +USE MiscUtility +USE OnesUtility +USE PartitionUtility +USE ProductUtility +USE PushPopUtility +USE ReallocateUtility +USE SortUtility +USE StringUtility +USE SwapUtility +USE SymUtility +USE TriagUtility +USE ZerosUtility +USE SafeSizeUtility +END MODULE Utility diff --git a/src/modules/Utility/src/ZerosUtility.F90 b/src/modules/Utility/src/ZerosUtility.F90 new file mode 100644 index 000000000..606fb4599 --- /dev/null +++ b/src/modules/Utility/src/ZerosUtility.F90 @@ -0,0 +1,400 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE ZerosUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Zeros + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_1(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8) :: ans(dim1) + END FUNCTION Zeros_1 + + MODULE PURE FUNCTION Zeros_2(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16) :: ans(dim1) + END FUNCTION Zeros_2 + + MODULE PURE FUNCTION Zeros_3(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32) :: ans(dim1) + END FUNCTION Zeros_3 + + MODULE PURE FUNCTION Zeros_4(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64) :: ans(dim1) + END FUNCTION Zeros_4 + +#ifdef USE_Int128 + MODULE PURE FUNCTION Zeros_5(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1) + END FUNCTION Zeros_5 +#endif +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_1, Zeros_2, Zeros_3, Zeros_4 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_5 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_6(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + REAL(REAL32), INTENT(IN) :: datatype + REAL(REAL32) :: ans(dim1) + END FUNCTION Zeros_6 +!! + MODULE PURE FUNCTION Zeros_7(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + REAL(REAL64), INTENT(IN) :: datatype + REAL(REAL64) :: ans(dim1) + END FUNCTION Zeros_7 +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_6, Zeros_7 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_8(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8) :: ans(dim1, dim2) + END FUNCTION Zeros_8 +!! + MODULE PURE FUNCTION Zeros_9(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16) :: ans(dim1, dim2) + END FUNCTION Zeros_9 +!! + MODULE PURE FUNCTION Zeros_10(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32) :: ans(dim1, dim2) + END FUNCTION Zeros_10 +!! + MODULE PURE FUNCTION Zeros_11(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64) :: ans(dim1, dim2) + END FUNCTION Zeros_11 +!! +#ifdef USE_Int128 +!! + MODULE PURE FUNCTION Zeros_12(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2) + END FUNCTION Zeros_12 +#endif +!! +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_8, Zeros_9, Zeros_10, Zeros_11 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_12 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_13(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + REAL(REAL32), INTENT(IN) :: datatype + REAL(REAL32) :: ans(dim1, dim2) + END FUNCTION Zeros_13 +!! + MODULE PURE FUNCTION Zeros_14(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + REAL(REAL64), INTENT(IN) :: datatype + REAL(REAL64) :: ans(dim1, dim2) + END FUNCTION Zeros_14 +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_13, Zeros_14 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_15(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_15 +!! + MODULE PURE FUNCTION Zeros_16(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_16 +!! + MODULE PURE FUNCTION Zeros_17(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_17 +!! + MODULE PURE FUNCTION Zeros_18(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_18 + +#ifdef USE_Int128 + !! + MODULE PURE FUNCTION Zeros_19(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_19 +#endif +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_15, Zeros_16, Zeros_17, Zeros_18 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_19 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_20(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + REAL(REAL32), INTENT(IN) :: datatype + REAL(REAL32) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_20 +!! + MODULE PURE FUNCTION Zeros_21(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + REAL(REAL64), INTENT(IN) :: datatype + REAL(REAL64) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_21 +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_20, Zeros_21 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_22(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_22 +!! + MODULE PURE FUNCTION Zeros_23(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_23 +!! + MODULE PURE FUNCTION Zeros_24(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_24 +!! + MODULE PURE FUNCTION Zeros_25(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_25 + +#ifdef USE_Int128 +!! + MODULE PURE FUNCTION Zeros_26(dim1, dim2, dim3, dim4, & + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_26 +#endif +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_22, Zeros_23, Zeros_24, Zeros_25 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_26 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE Zeros + MODULE PURE FUNCTION Zeros_27(dim1, dim2, dim3, dim4, & + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + REAL(REAL32), INTENT(IN) :: datatype + REAL(REAL32) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_27 +!! + MODULE PURE FUNCTION Zeros_28(dim1, dim2, dim3, dim4, & + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + REAL(REAL64), INTENT(IN) :: datatype + REAL(REAL64) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_28 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +INTERFACE Zeros + MODULE PURE FUNCTION Zeros_29_Int8(s, datatype) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: s(:) + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8) :: ans(s(1), s(2)) + END FUNCTION Zeros_29_Int8 + + MODULE PURE FUNCTION Zeros_29_Int16(s, datatype) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: s(:) + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16) :: ans(s(1), s(2)) + END FUNCTION Zeros_29_Int16 + + MODULE PURE FUNCTION Zeros_29_Int32(s, datatype) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: s(:) + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32) :: ans(s(1), s(2)) + END FUNCTION Zeros_29_Int32 + + MODULE PURE FUNCTION Zeros_29_Int64(s, datatype) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: s(:) + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64) :: ans(s(1), s(2)) + END FUNCTION Zeros_29_Int64 + + MODULE PURE FUNCTION Zeros_29_Real32(s, datatype) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: s(:) + REAL(REAL32), INTENT(IN) :: datatype + REAL(REAL32) :: ans(s(1), s(2)) + END FUNCTION Zeros_29_Real32 + + MODULE PURE FUNCTION Zeros_29_Real64(s, datatype) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: s(:) + REAL(REAL64), INTENT(IN) :: datatype + REAL(REAL64) :: ans(s(1), s(2)) + END FUNCTION Zeros_29_Real64 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ZerosUtility diff --git a/src/modules/Utility/src/refs/mathPlantFEM.inc b/src/modules/Utility/src/refs/mathPlantFEM.inc new file mode 100644 index 000000000..03082a63f --- /dev/null +++ b/src/modules/Utility/src/refs/mathPlantFEM.inc @@ -0,0 +1,2713 @@ +module MathClass + use, intrinsic :: iso_fortran_env + !use OouraFFT + use StringClass + implicit none + + + integer(int32) :: i_i = 0 + integer(int32) :: j_j = 0 + integer(int32) :: k_k = 0 + + logical :: true = .True. + logical :: False = .False. + !integer(int32) :: i_i = 0 + + type :: Math_ + real(real64) :: PI = 3.141592653589793d0 + real(real64) :: E = 2.718281828459045d0 + complex(kind(0d0)) :: i = (0.0d0, 1.0d0) + complex(kind(0d0)) :: j = (0.0d0, 1.0d0) + end type + + + type :: Real64Ptr_ + real(real64), pointer :: ptr + end type Real64Ptr_ + + integer(int32),parameter :: complex64 = real64 + !real(real64) :: pi=3.141592653589793238d0 + ! + interface nchoosek + module procedure comb + end interface + + interface choose + module procedure comb + end interface + + interface fact + module procedure factorialInt32, factorialReal64 + end interface + + interface imag + module procedure imaginary_partComplex64, imaginary_partComplex32 + end interface + + interface factorial + module procedure factorialInt32, factorialReal64 + end interface factorial + + interface heapsort + module procedure :: heapsortInt32, heapsortReal64,heapsortReal32 + end interface + + interface str + module procedure fstring_Int, fstring_Real,fstring_Real32, & + fstring_complex, fstring_Int_len, fstring_Real_len, fstring_logical, fstring_String,stringFromChar + end interface str + + interface fstring + module procedure fstring_Int, fstring_Real, fstring_Int_len, fstring_Real_len, fstring_logical + end interface fstring + + interface input + module procedure input_Int,input_Real,input_Real32,input_Complex,input_IntVec,& + input_RealVec,input_IntArray,input_RealArray,input_String,input_logical + end interface input + + interface zeroif + module procedure zeroif_Int,zeroif_Real + end interface zeroif + + interface removeWord + module procedure removeWord_String + end interface + + interface radian + module procedure radianreal32,radianreal64, radianint + end interface + + interface array + module procedure arrayDim1Real64,arrayDim2Real64,arrayDim3Real64 + end interface + + interface RickerFunction + module procedure RickerFunctionReal64 + end interface + + interface derivative + module procedure derivative_scalar,derivative_vector + end interface + + interface der + module procedure derivative_scalar,derivative_vector + end interface + + interface d_dx + module procedure derivative_scalar,derivative_vector + end interface +contains + +! ############################################### +function FFT(x,T) result(hatx) + complex(kind(0d0)) ,intent(in) :: x(:) + complex(kind(0d0)) ,allocatable :: hatx(:) + type(Math_) :: Math + real(real64),optional,intent(in) :: T(2) ! range + real(real64) :: Trange(1:2),dt + integer(int32) :: N + + + N = size(x) + if(present(T) )then + dt = abs(T(2) - T(1) )/dble(N) + else + dt = 1.0d0 + endif + + hatx = FFT_core(x) + + hatx = dt*hatx + +end function + +! ############################################### + +! ############################################### +recursive function FFT_core(x) result(hatx) + complex(kind(0d0)) ,intent(in) :: x(:) + !real(real64) ,optional,intent(in) :: T(2) ! range + complex(kind(0d0)) ,allocatable :: hatx(:),W(:),L(:),R(:) + real(real64),allocatable :: a(:), wo(:) + !real(real64) :: Trange(2) ,dt + integer(int32),allocatable :: ip(:) + integer(int32) :: N, i, itr,isgn + integer(int32),allocatable :: k(:) + type(Math_) :: Math + + ! This FFT is + ! Fw(m dw) = T/N \sum_{n=0}^{N-1} f(n dt) e^{-i 2 \pi k/N m n} + + N = size(x) + allocate(hatx(N)) + + + hatx(:) = 0.0d0 + allocate(k(N/2) ) + allocate(W(N/2) ) + allocate(L(N/2) ) + allocate(R(N/2) ) + + do i=1,size(k) + k(i) = i-1 + !print *, exp(-1*Math%i * 2.0d0* Math%PI * k(i)/dble(N)) + W(i) = exp(-1*Math%i * 2.0d0* Math%PI * k(i) /dble(N) ) + enddo + + if(N==2)then + ! butterfly operation + hatx(1) = x(1) + x(2) + hatx(2) = x(1) - x(2) + return + endif + + if(N>=4)then + itr=0 + do i=1, N, 2 + itr=itr+1 + + if(itr > size(L) )then + exit + endif + L(itr) = x(i) + enddo + + itr=0 + do i=2, N, 2 + itr=itr+1 + if(itr > size(R) )then + exit + endif + R(itr) = x(i) + enddo + + L = FFT_core(L) + R = FFT_core(R) + + do i=1,N/2 + hatx(i) = L(i) + W(i)*R(i) + enddo + do i=N/2+1, N + if(i-N/2 > size(L) )then + exit + endif + hatx(i) = L(i-N/2) - W(i-N/2)*R(i-N/2) + enddo + return + endif +end function +! ############################################### +function IFFT(x,T) result(hatx) + complex(kind(0d0)) ,intent(in) :: x(:) + complex(kind(0d0)) ,allocatable :: hatx(:) + type(Math_) :: Math + real(real64) ,optional,intent(in) :: T(2) ! range + real(real64) :: Trange(2) ,TT + integer(int32) :: N + + ! This IFFT is + ! ft(n dt) = 1/T \sum_{n=0}^{N-1} Fw(m dw) e^{i 2 \pi k/N m n} + + N = size(x) + if(present(T) )then + TT = abs(T(2) - T(1) ) + else + TT = dble(N) + endif + + hatx = IFFT_core(x) + + hatx = 1.0d0/TT*hatx + +end function + +! ############################################### +recursive function IFFT_core(x) result(hatx) + complex(kind(0d0)) ,intent(in) :: x(:) + complex(kind(0d0)) ,allocatable :: hatx(:),W(:),L(:),R(:) + real(real64),allocatable :: a(:), wo(:) + integer(int32),allocatable :: ip(:) + integer(int32) :: N, i, itr,isgn + integer(int32),allocatable :: k(:) + type(Math_) :: Math + + !!! call Ooura-FFT + !n = size(x)/2 + !allocate(a(0:2*n-1) ) + !allocate(wo(0:2*n-1) ) + !a(0:2*n-1) = x(1:2*n) + !isgn = n + !call cdft(2*n,isgn,a(0:2*n-1),ip,wo(0:n/2-1) ) + !hatx = a + ! + !return + !!! + N = size(x) + + allocate(hatx(N)) + + hatx(:) = 0.0d0 + allocate(k(N/2) ) + allocate(W(N/2) ) + allocate(L(N/2) ) + allocate(R(N/2) ) + + do i=1,size(k) + k(i) = i-1 + !print *, exp(-1*Math%i * 2.0d0* Math%PI * k(i)/dble(N)) + W(i) = exp(Math%i * 2.0d0* Math%PI * k(i) /dble(N) ) + enddo + + if(N==2)then + ! butterfly operation + hatx(1) = x(1) + x(2) + hatx(2) = x(1) - x(2) + return + endif + + if(N>=4)then + itr=0 + do i=1, N, 2 + itr=itr+1 + + if(itr > size(L) )then + exit + endif + L(itr) = x(i) + enddo + + itr=0 + do i=2, N, 2 + itr=itr+1 + if(itr > size(R) )then + exit + endif + R(itr) = x(i) + enddo + + L = IFFT_core(L) + R = IFFT_core(R) + + do i=1,N/2 + hatx(i) = L(i) + W(i)*R(i) + enddo + do i=N/2+1, N + if(i-N/2 > size(L) )then + exit + endif + hatx(i) = L(i-N/2) - W(i-N/2)*R(i-N/2) + enddo + return + endif + + +end function +! ############################################### + +! ############################################### +function arrayDim1Real64(size1) result(ret) + integer(int32),intent(in) :: size1 + real(real64),allocatable :: ret(:) + + allocate(ret(size1) ) + + ret(:) = 0.0d0 + +end function +! ############################################### + + +! ############################################### +function arrayDim2Real64(size1,size2) result(ret) + integer(int32),intent(in) :: size1,size2 + real(real64),allocatable :: ret(:,:) + + allocate(ret(size1,size2) ) + + ret(:,:) = 0.0d0 + + +end function +! ############################################### + + +! ############################################### +function arrayDim3Real64(size1,size2,size3) result(ret) + integer(int32),intent(in) :: size1,size2,size3 + real(real64),allocatable :: ret(:,:,:) + + allocate(ret(size1,size2,size3) ) + + ret(:,:,:) = 0.0d0 + + +end function +! ############################################### + +! ############################################### +function radianreal32(deg) result(ret) + real(real32),intent(in) :: deg + real(real64) :: ret + ret = deg/180.0d0*3.1415926535d0 +end function +! ############################################### + +! ############################################### +function radianreal64(deg) result(ret) + real(real64),intent(in) :: deg + real(real64) :: ret + ret = deg/180.0d0*3.1415926535d0 +end function +! ############################################### + +! ############################################### +function radianint(deg) result(ret) + integer(int32),intent(in) :: deg + real(real64) :: ret + ret = dble(deg)/180.0d0*3.1415926535d0 +end function +! ############################################### + +! ############################################### +function degrees(rad) result(ret) + real(real64),intent(in) :: rad + real(real64) :: ret + ret = rad/3.1415926535d0*180.0d0 +end function +! ############################################### + + +!######################################## +function norm(vec) result(a) + real(real64),intent(in)::vec(:) + integer(int32) :: n + real(real64) :: a + + n=size(vec) + a=dsqrt(dot_product(vec,vec) ) + +end function +!######################################## + + + + + +!######################################## +pure function SearchNearestValueID(Vector,x) result(id) + real(real64),intent(in) :: Vector(:) + real(real64),intent(in) :: x + integer(int32) :: id,i + + id = 1 + do i=1,size(vector) + if( abs(vector(id)-x) > abs(vector(i)-x) )then + id = i + cycle + endif + enddo + +end function +!######################################## + + +!######################################## +function SearchNearestValueIDs(Vector,x,num) result(id) + real(real64),intent(in) :: Vector(:) + real(real64),intent(in) :: x + integer(int32),intent(in) :: num + integer(int32) :: id(num),i,j + + id(:) = 1 + do j=1,num + do i=1,size(vector) + if(j>=2 )then + if(abs(minval(id(1:j-1) - i ))==0) cycle + endif + if( abs(vector(id(j) )-x) > abs(vector(i)-x) )then + id(j) = i + cycle + endif + enddo + enddo +end function +!######################################## + +!######################################## +function SearchNearestValue(Vector,x) result(val) + real(real64),intent(in) :: Vector(:) + real(real64),intent(in) :: x + integer(int32) :: id, i + real(real64) :: val + + id = 1 + do i=1,size(vector) + if( abs(vector(id)-x) > abs(vector(i)-x) )then + id = i + cycle + endif + enddo + + val = vector(id) +end function +!######################################## + + +!######################################## +function SearchNearestCoord(Array,x) result(id) + real(real64),intent(in) :: Array(:,:) + real(real64),intent(in) :: x(:) + integer(int32),allocatable::xr(:) + + integer(int32) :: i,id,n,m,norm,tr_norm + + n=size(Array,1) + m=size(Array,2) + if(m/=size(x) )then + stop "ERROR :: SearchNearestCoord >> size(Array,2) should be =size(x)" + endif + + allocate(xr(m) ) + do i=1,n + xr(:)=Array(i,:) + tr_norm=dot_product(xr-x,xr-x) + if(i==1)then + norm=tr_norm + id =i + else + if(norm > tr_norm)then + norm=tr_norm + id =i + else + cycle + endif + endif + enddo + + + +end function +!######################################## + +!################################################## +function SearchIDIntVec(Vec,val) result(id_) + integer(int32),intent(in) :: Vec(:) + integer(int32),intent(in) :: val + + integer(int32) :: i,id_ + + do i=1,size(Vec) + if(Vec(i)==val )then + id_=i + return + endif + enddo + +end function +!################################################## + +!################################################## +subroutine heapsortReal64(n,array,val) + integer(int32),intent(in) :: n + real(real64),intent(inout) :: array(1:n)! rearrange order by this array + real(real64),optional,intent(inout) :: val(1:n) ! linked data + real(real64) :: t_real + integer(int32) ::i,k,j,l + real(real64) :: t + + if(n.le.0)then + write(6,*)"Error, at heapsort"; stop + endif + if(n.eq.1)return + + l=n/2+1 + k=n + do while(k.ne.1) + if(l.gt.1)then + l=l-1 + t=array(L) + if(present(val) )then + t_real=val(L) + endif + else + t=array(k) + if(present(val) )then + t_real=val(k) + endif + + array(k)=array(1) + if(present(val) )then + val(k) = val(1) + endif + + k=k-1 + if(k.eq.1) then + array(1)=t + if(present(val) )then + val(1) = t_real + endif + exit + endif + endif + i=l + j=l+l + do while(j.le.k) + if(j.lt.k)then + if(array(j).lt.array(j+1))j=j+1 + + endif + if (t.lt.array(j))then + array(i)=array(j) + if(present(val) )then + val(i)=val(j) + endif + i=j + j=j+j + else + j=k+1 + endif + enddo + array(i)=t + if(present(val) )then + val(i)=t_real + endif + enddo + +end subroutine heapsortReal64 + +!################################################## +subroutine heapsortReal32(n,array,val) + integer(int32),intent(in) :: n + real(real32),intent(inout) :: array(1:n)! rearrange order by this array + real(real32),optional,intent(inout) :: val(1:n) ! linked data + real(real32) :: t_real + integer(int32) ::i,k,j,l + real(real32) :: t + + if(n.le.0)then + write(6,*)"Error, at heapsort"; stop + endif + if(n.eq.1)return + + l=n/2+1 + k=n + do while(k.ne.1) + if(l.gt.1)then + l=l-1 + t=array(L) + if(present(val) )then + t_real=val(L) + endif + else + t=array(k) + if(present(val) )then + t_real=val(k) + endif + + array(k)=array(1) + if(present(val) )then + val(k) = val(1) + endif + + k=k-1 + if(k.eq.1) then + array(1)=t + if(present(val) )then + val(1) = t_real + endif + exit + endif + endif + i=l + j=l+l + do while(j.le.k) + if(j.lt.k)then + if(array(j).lt.array(j+1))j=j+1 + + endif + if (t.lt.array(j))then + array(i)=array(j) + if(present(val) )then + val(i)=val(j) + endif + i=j + j=j+j + else + j=k+1 + endif + enddo + array(i)=t + if(present(val) )then + val(i)=t_real + endif + enddo + +end subroutine heapsortReal32 + + + +!################################################## +subroutine heapsortInt32(n,array,val) + integer(int32),intent(in) :: n + integer(int32),intent(inout) :: array(1:n)! rearrange order by this array + real(real64),optional,intent(inout) :: val(1:n) ! linked data + real(real64) :: t_real + integer(int32) ::i,k,j,l + integer(int32) :: t + + if(n.le.0)then + write(6,*)"Error, at heapsort"; stop + endif + if(n.eq.1)return + + l=n/2+1 + k=n + do while(k.ne.1) + if(l.gt.1)then + l=l-1 + t=array(L) + if(present(val) )then + t_real=val(L) + endif + else + t=array(k) + if(present(val) )then + t_real=val(k) + endif + + array(k)=array(1) + if(present(val) )then + val(k) = val(1) + endif + + k=k-1 + if(k.eq.1) then + array(1)=t + if(present(val) )then + val(1) = t_real + endif + exit + endif + endif + i=l + j=l+l + do while(j.le.k) + if(j.lt.k)then + if(array(j).lt.array(j+1))j=j+1 + + endif + if (t.lt.array(j))then + array(i)=array(j) + if(present(val) )then + val(i)=val(j) + endif + i=j + j=j+j + else + j=k+1 + endif + enddo + array(i)=t + if(present(val) )then + val(i)=t_real + endif + enddo + +end subroutine heapsortInt32 + +!========================================================== +!calculate cross product +!--------------------------- +pure function cross_product(a,b) result (c) + real(real64), intent(in) :: a(:),b(:) + real(real64), allocatable :: c(:) + + if(size(a) /= 3 .or. size(b)/= 3 ) then + !stop "wrong number on size a, b" + return + endif + + allocate(c(size(a,1))) + if(size(c,1)==3) then + c(1) = a(2)*b(3) - a(3)*b(2) + c(2) = a(3)*b(1) - a(1)*b(3) + c(3) = a(1)*b(2) - a(2)*b(1) + else + !stop "wrong number at cross_product" + return + endif + +end function cross_product +!========================================================= +!calculate diadic +!---------------------- +function diadic(a,b) result(c) + real(real64), intent(in) :: a(:), b(:) + real(real64), allocatable :: c(:,:) + + integer(int32) n,i,j + + allocate(c(size(a),size(b) ) ) + do i=1,size(a) + do j=1,size(b) + c(i,j)=a(i)*b(j) + enddo + enddo + +end function diadic +!========================================================== +!========================================================= +!calculate diadic +!---------------------- +function tensor_product(a,b) result(c) + real(real64), intent(in) :: a(:), b(:) + real(real64), allocatable :: c(:,:) + + integer(int32) n,i,j + + allocate(c(size(a),size(b) ) ) + do i=1,size(a) + do j=1,size(b) + c(i,j)=a(i)*b(j) + enddo + enddo + + end function tensor_product + !========================================================== +!calculate gz +!-------------- +subroutine calcgz(x2,x11,x12,nod_coord,gzi) + real(real64), intent(in) :: nod_coord(:,:) + real(real64),intent(out) :: gzi + integer(int32),intent(in):: x2,x11,x12 + real(real64) l + real(real64),allocatable::avec(:) + + allocate(avec(2)) + l = dot_product( nod_coord(x12,1:2) - nod_coord(x11,1:2), & + nod_coord(x12,1:2) - nod_coord(x11,1:2) ) + l=l**(1.0d0/2.0d0) + + avec(1:2) = ( nod_coord(x12,1:2) - nod_coord(x11,1:2) )/l + + if(l==0.0d0)then + print *, "calcgz l=0" + gzi=0.0d0 + else + gzi=1.0d0/l*dot_product( nod_coord(x2,1:2) -nod_coord(x11,1:2),avec(1:2) ) + endif + + deallocate(avec) + +end subroutine calcgz +!========================================================== +function arg(comp) result(theta) + complex,intent(in) :: comp + real(real64) :: theta,re,im + real(real64) ::pi=3.141592653589793d0 + + re = dble(real(comp) ) + im = dble(aimag(comp) ) + + if(re>0.0d0 )then + theta = atan(im/re) + elseif(re<0.0d0 .and. im>=0.0d0)then + theta = atan(im/re+pi) + elseif(re<0.0d0 .and. im<0.0d0)then + theta = atan(im/re-pi) + elseif(re==0.0d0 .and. im>0.0d0)then + theta = pi/2.0d0 + elseif(re==0.0d0 .and. im<0.0d0)then + theta = -pi/2.0d0 + else + print *, "arg :: indeterminate" + stop + endif + + +end function +!========================================================== + + +function cubic_equation(a,b,c,d) result(x) + real(real64),intent(in) :: a,b,c,d + real(real64) :: x(3),theta + real(real64) ::Deq,A_,B_,C_,p,q + real(real64) ::pi=3.141592653589793d0 + complex :: comp + !https://qiita.com/yotapoon/items/42b1749b69c264d6f486 + + A_ = b/a + B_ = c/a + C_ = d/a + p = B_ - A_*A_/3.0d0 + q = 2.0d0*A_*A_*A_/27.0d0 - A_*B_/3.0d0 + C_ + Deq = q*q/4.0d0 + p*p*p/27.0d0 + + if(Deq > 0.0d0)then + print *, "D > 0 :: not implemented now." + elseif(Deq==0)then + print *, "D == 0 " + x(1) = -2.0d0*(p/2.0d0)**(3) + x(2) = (p/2.0d0)**(3) + x(3) = (p/2.0d0)**(3) + return + else + print *, "D < 0 " + comp = cmplx(-q/2.0d0, sqrt(-Deq) ) + theta=arg(comp) + x(1) = 2.0d0*sqrt(-p/3.0d0)*cos(theta) + x(2) = 2.0d0*sqrt(-p/3.0d0)*cos( (theta+2.0d0*pi)/3.0d0 ) + x(3) = 2.0d0*sqrt(-p/3.0d0)*cos( (theta+4.0d0*pi)/3.0d0 ) + endif + + +end function + +!========================================================== +subroutine eigen_2d(Amat,eigenvector) + real(real64),intent(in)::Amat(:,:) + real(real64),allocatable,intent(inout)::eigenvector(:,:) + real(real64)::b,c,phy,eigenvalue(2) + integer(int32) i,j + + eigenvalue=array(size(Amat,1) ) + eigenvector=array(size(Amat,1),size(Amat,1)) + + b=-1.0d0*(Amat(1,1)+Amat(2,2)) + c=Amat(1,1)*Amat(2,2)-Amat(1,2)*Amat(1,2) + + if(Amat(1,2)/=Amat(2,1) )then + stop "input matrice is not symmetric" + endif + + do i=1,2 + eigenvalue(i)=(-1.0d0*b+((-1.0d0)**dble(i))*(b*b-4.0d0*c)**(1.0d0/2.0d0))*(0.50d0) + enddo + + do i=1,2 + if(Amat(1,2)==0 )then + cycle + elseif(Amat(1,2)/=0 )then + phy=atan( (eigenvalue(i)-Amat(1,1))/Amat(1,2) ) + + do j=1,2 + eigenvector(i,1:2)=(/cos(phy),sin(phy)/) + enddo + endif + enddo + + do i=1,2 + eigenvector(i,:)=eigenvalue(i)*eigenvector(i,:) + enddo +end subroutine eigen_2d +!========================================================== +function signmm(a) result(b) + real(real64),intent(in)::a + real(real64) b + + if(a>0)then + b=1.0d0 + elseif(a<0)then + b=-1.0d0 + elseif(a==0)then + b=0.0d0 + else + stop "ERROR: Invalid real(real64) in function_signm" + endif + +end function signmm +!========================================================== + +! ################################################################ +! From 数値計算のためのFortran90/95プログラミング入門 単行本（ソフトカバー） – +! This function is not presented with GPL or any licenses. +! this function will be replaced by LAPACK. + +recursive function det_mat(a,n) result(det) + integer(int32), intent(in) :: n + real(real64), intent(in) :: a(n, n) + real(real64) det, b(n-1, n-1) + integer(int32) i + if (n > 1) then + det = 0.0d0 + do i = 1, n + b(1:i-1, 1:n-1) = a(1:i-1, 2:n) + b(i:n-1, 1:n-1) = a(i+1:n, 2:n) + det = det + (-1.0d0) ** (i + 1) & + * a(i, 1) * det_mat(b, n-1) + + enddo + else + det = a(1,1) + endif +end function det_mat +!===================================================================================== + +!========================================================== +recursive function det(a,n) result(det_v) + integer(int32), intent(in) :: n + real(real64), intent(in) :: a(n, n) + real(real64) det_v, b(n-1, n-1) + integer(int32) i + if (n > 1) then + det_v = 0.0d0 + do i = 1, n + b(1:i-1, 1:n-1) = a(1:i-1, 2:n) + b(i:n-1, 1:n-1) = a(i+1:n, 2:n) + det_v = det_v + (-1.0d0) ** (i + 1) & + * a(i, 1) * det(b, n-1) + + enddo + else + det_v = a(1,1) + endif +end function det +!===================================================================================== +subroutine trans_rank_2(A,A_T) + real(real64),intent(in)::A(:,:) + real(real64),allocatable,intent(out)::A_T(:,:) + integer(int32) n,m,i,j + + n=size(A,1) + m=size(A,2) + if(.not. allocated(A_T) )allocate(A_T(m,n)) + + do i=1,n + do j=1, m + A_T(j,i)=A(i,j) + enddo + enddo + + end subroutine trans_rank_2 +!================================================================================== +function trans1(A) result(A_T) + real(real64),intent(in)::A(:) + real(real64),allocatable::A_T(:,:) + integer(int32) n,m,i,j + + n=size(A) + if(.not. allocated(A_T) )allocate(A_T(1,n)) + + do i=1,n + A_T(1,i)=A(i) + enddo + + end function trans1 +!================================================================================== +function trans2(A) result(A_T) + real(real64),intent(in)::A(:,:) + real(real64),allocatable::A_T(:,:) + integer(int32) n,m,i,j + + n=size(A,1) + m=size(A,2) + if(.not. allocated(A_T) )allocate(A_T(m,n)) + + do i=1,n + do j=1, m + A_T(j,i)=A(i,j) + enddo + enddo + + end function trans2 +!================================================================================== +subroutine inverse_rank_2(A,A_inv) + real(real64),intent(in)::A(:,:) + real(real64),allocatable::A_inv(:,:) + real(real64) detA,detA_1 + integer(int32) m,n + + m=size(A,1) + n=size(A,2) + if(.not. allocated(A_inv) )allocate(A_inv(m,n)) + detA=det_mat(A,n) + if(detA==0.0d0) stop "ERROR: inverse, detA=0" + detA_1=1.0d0/detA + if(n==2)then + A_inv(1,1)=detA_1*A(2,2) + A_inv(1,2)=-detA_1*A(1,2) + A_inv(2,1)=-detA_1*A(2,1) + A_inv(2,2)=detA_1*A(1,1) + elseif(n==3)then + A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) + A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3)) + A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2)) + A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3)) + A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1)) + A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3)) + A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) + A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2)) + A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1)) + else + print *, "ERROR: Aij with i=j=",n,"/=2or3" + endif + + end subroutine inverse_rank_2 +!================================================================================== +!================================================================================== +function inverse(A) result(A_inv) + real(real64),intent(in)::A(:,:) + real(real64),allocatable::A_inv(:,:) + real(real64) detA,detA_1 + integer(int32) m,n + + m=size(A,1) + n=size(A,2) + if(.not. allocated(A_inv) )allocate(A_inv(m,n)) + detA=det_mat(A,n) + if(detA==0.0d0) stop "ERROR: inverse, detA=0" + detA_1=1.0d0/detA + if(n==2)then + A_inv(1,1)=detA_1*A(2,2) + A_inv(1,2)=-detA_1*A(1,2) + A_inv(2,1)=-detA_1*A(2,1) + A_inv(2,2)=detA_1*A(1,1) + elseif(n==3)then + A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) + A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3)) + A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2)) + A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3)) + A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1)) + A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3)) + A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) + A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2)) + A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1)) + else + print *, "ERROR: Aij with i=j=",n,"/=2or3" + endif + + end function inverse +!================================================================================== +subroutine tensor_exponential(A,expA,TOL,itr_tol) + real(real64),intent(in)::A(:,:),TOL + real(real64),allocatable,intent(inout)::expA(:,:) + integer(int32), intent(in)::itr_tol + real(real64),allocatable::increA(:,:) + real(real64) increment,NN + integer(int32) i,j,n + + if(.not. allocated(expA) )allocate(expA(size(A,1),size(A,2) )) + allocate(increA(size(A,1),size(A,2) )) + if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix" + + expA(:,:)=0.0d0 + do n=1,size(expA,1) + expA(n,n)=1.0d0 + enddo + NN=1.0d0 + increA(:,:)=expA(:,:) + do n=1,itr_tol + if(n>1)then + NN = NN*(NN+1.0d0) + endif + increA(:,:)=matmul(increA,A) + expA(:,:)= expA(:,:)+1.0d0/NN*increA(:,:) + + increment=0.0d0 + do i=1,size(A,1) + do j=1,size(A,2) + increment=increment+1.0d0/NN*increA(i,j)*increA(i,j) + enddo + enddo + + if(increment<=TOL)then + exit + else + if(n>=itr_tol)then + stop "tensor exponential is not converged" + endif + cycle + endif + enddo + + deallocate(increA) + +end subroutine tensor_exponential +!================================================================================== +function identity_matrix(n) result(mat) + integer(int32),intent(in) :: n ! rank + real(real64) :: mat(n,n) + integer(int32) :: i + mat(:,:)=0.0d0 + do i=1,n + mat(i,i)=1.0d0 + enddo + +end function +!================================================================================== + +!================================================================================== +function zero_matrix(n) result(mat) + integer(int32),intent(in) :: n ! rank + real(real64) :: mat(n,n) + mat(:,:)=0.0d0 + +end function +!================================================================================== +subroutine tensor_expo_der(A,expA_A,TOL,itr_tol) + real(real64),intent(in)::A(:,:),TOL + real(real64),allocatable,intent(inout)::expA_A(:,:,:,:) + integer(int32), intent(in)::itr_tol + real(real64),allocatable::increA_1(:,:),increA_2(:,:),increA_3(:,:,:,:),I_ij(:,:),A_inv(:,:) + real(real64) increment,NN + integer(int32) i,j,k,l,n,m,o + + if(.not. allocated(expA_A) )allocate(expA_A(size(A,1),size(A,1),size(A,1),size(A,1) )) + allocate(I_ij(size(A,1),size(A,1) )) + allocate(increA_1(size(A,1),size(A,1) )) + allocate(increA_2(size(A,1),size(A,1) )) + allocate(increA_3(size(A,1),size(A,1),size(A,1),size(A,1) ) ) + if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix" + + call inverse_rank_2(A,A_inv) + + I_ij(:,:)=0.0d0 + do n=1,size(expA_A,1) + I_ij(n,n)=1.0d0 + enddo + NN=1.0d0 + + do i=1,size(A,1) + do j=1,size(A,1) + do k=1, size(A,1) + do l=1, size(A,1) + expA_A(i,j,k,l)=I_ij(i,k)*I_ij(l,j) + enddo + enddo + enddo + enddo + + increA_1(:,:)=I_ij(:,:) + increA_2(:,:)=I_ij(:,:) + do n=1,itr_tol + if(n>2)then + NN = NN*(NN+1.0d0) + endif + increA_1(:,:)=A_inv(:,:) + increA_2(:,:)=matmul(increA_2,A) + + increA_3(:,:,:,:)=0.0d0 + do m=1,n + increA_1(:,:)=matmul(increA_1,A ) + + increA_2(:,:)=matmul(increA_2,A_inv) + + do i=1,size(A,1) + do j=1,size(A,1) + do k=1, size(A,1) + do l=1, size(A,1) + increA_3(i,j,k,l)=increA_3(i,j,k,l)+increA_1(i,k)*increA_2(l,j) + expA_A(i,j,k,l)=expA_A(i,j,k,l)+1.0d0/NN*increA_3(i,j,k,l) + enddo + enddo + enddo + enddo + enddo + + do i=1,size(A,1) + do j=1,size(A,1) + do k=1, size(A,1) + do l=1, size(A,1) + increment=increment+1.0d0/NN*increA_3(i,j,k,l)& + *increA_3(i,j,k,l)& + *increA_3(i,j,k,l)& + *increA_3(i,j,k,l) + enddo + enddo + enddo + enddo + + if(increment<=TOL)then + exit + else + if(n>=itr_tol)then + stop "tensor exponential is not converged" + endif + cycle + endif + enddo + + deallocate(increA_1,increA_2,increA_3,I_ij,A_inv) + +end subroutine tensor_expo_der +!================================================================================== + +function GetNormRe(a) result(b) + real(real64),intent(in)::a(:) + real(real64) :: b + b=dot_product(a,a) +end function +!================================================================================== + +function GetNormMatRe(a) result(b) + real(real64),intent(in)::a(:,:) + real(real64) :: b + integer(int32) :: i,j + b=0 + do i=1,size(a,1) + do j=1,size(a,2) + b=b+a(i,j)*a(i,j) + enddo + enddo +end function +!================================================================================== + +function trace(a) result(b) + real(real64),intent(in)::a(:,:) + real(real64) :: b + integer(int32) :: i,j + b=0 + do i=1,size(a,1) + b=b+a(i,i) + enddo +end function + +!================================================================================== +function sym(a,n) result(ret) + real(real64),intent(in) :: a(:,:) + real(real64) :: ret(n,n) + integer(int32) :: i,n + + ret = 0.50d0*(a) + 0.50d0*transpose(a) + +end function +!================================================================================== + +!================================================================================== +function asym(a,n) result(ret) + real(real64),intent(in) :: a(:,:) + real(real64) :: ret(n,n) + integer(int32) :: i,n + + ret = 0.50d0*(a) - 0.50d0*transpose(a) + +end function +!================================================================================== + +function pi_value(n) result(res) + integer(int32),intent(in)::n + real(real64) :: ptr + real(real64) :: an,bn,tn,pn + real(real64) :: atr,btr,ttr + real(real64) :: res + + integer(int32) :: i + + an=1.0d0 + bn=1.0d0/sqrt(2.0d0) + tn=0.250d0 + pn=1.00d0 + do i=1,n + atr=0.50d0*(an+bn) + btr=dsqrt(an*bn) + ttr=tn-pn*(atr-an)*(atr-an) + ptr=2.0d0*pn + + an=atr + bn=btr + tn=ttr + pn=ptr + + res=(atr+btr)*(atr+btr)/4.0d0/ttr + enddo + +end function +!================================================================================== + + + + +!================================================================================== +function fstring_int(x) result(a) + integer(int32),intent(in) :: x + character(len=20):: b + character(len=:),allocatable :: a + + write(b,*) x + a = trim(adjustl(b)) + +end function +!================================================================================== + +!================================================================================== +function fstring_logical(x) result(a) + logical,intent(in) :: x + character(len=5) :: a + + write(a,*) x + +end function +!================================================================================== + + + +!================================================================================== +function fstring_String(x) result(a) + type(String_),intent(in) :: x + character(len=:),allocatable :: a + + a = trim(x%all) +end function +!================================================================================== + + + +!================================================================================== +function fstring_int_len(x,length) result(a) + integer(int32),intent(in) :: x + integer(int32),intent(in) :: length + character(len=length) :: a + + if(x/=x .or. abs(x) >= HUGE(int32) )then + a="" + return + endif + + write(a,*) x + a = adjustl(a) +end function +!================================================================================== + + + +!================================================================================== +function fstring_real(x) result(a) + real(real64),intent(in) :: x + character(len=20):: b + character(len=:),allocatable :: a + + if(x/=x .or. abs(x) >= HUGE(real64) )then + a="" + return + endif + + write(b,'(f0.8)') x + a = trim(adjustl(b)) + + + +end function +!================================================================================== + +!================================================================================== +function fstring_real32(x) result(a) + real(real32),intent(in) :: x + character(len=20):: b + character(len=:),allocatable :: a + + if(x/=x .or. abs(x) >= HUGE(real64) )then + a="" + return + endif + + write(b,'(f0.8)') x + a = trim(adjustl(b)) + + + +end function +!================================================================================== + +!================================================================================== +function fstring_complex(x) result(a) + complex(kind(0d0) ),intent(in) :: x + character(len=30):: b + character(len=:),allocatable :: a + + if(x/=x .or. abs(x) >= HUGE(real64) )then + a="" + return + endif + + write(b,fmt = '(F0.0,SP,F0.0,"i")') x + a = trim(adjustl(b)) +end function +!================================================================================== + + +!================================================================================== +function fstring_real_len(x,length) result(a) + real(real64),intent(in) :: x + integer(int32),intent(in) :: length + character(len=60) :: a + character*40 :: form + + if(x/=x .or. abs(x) >= HUGE(real64))then + a="" + return + endif + + write(a,'(f0.10)') x + a = adjustl(a) +end function +!================================================================================== + + + +!================================================================================== +function fint(ch) result(a) + character(*),intent(in) :: ch + integer(int32) :: a + + read(ch,*,err=1000) a + return +1000 a = 0 + +end function +!================================================================================== + +!================================================================================== +function fint16(ch) result(a) + character(*),intent(in) :: ch + integer(int16) :: a + + read(ch,*,err=1001) a + return +1001 a = 0 + +end function +!================================================================================== + + + +!================================================================================== +function fint32(ch) result(a) + character(*),intent(in) :: ch + integer(int32) :: a + + read(ch,*,err=1002) a + return +1002 a = 0 + +end function +!================================================================================== + + +!================================================================================== +function fint64(ch) result(a) + character(*),intent(in) :: ch + integer(int64) :: a + + read(ch,*,err=1003) a + return +1003 a = 0 + +end function +!================================================================================== + + + + +!================================================================================== +function freal(ch) result(a) + character(*),intent(in) :: ch + real(real64) :: a + + read(ch,*,err=1004) a + return +1004 a = 0.0d0 + +end function +!================================================================================== + + +!================================================================================== +function freal32(ch) result(a) + character(*),intent(in) :: ch + real(real32) :: a + + read(ch,*,err=1005) a + return +1005 a = 0 + +end function +!================================================================================== + + +!================================================================================== +function freal64(ch) result(a) + character(*),intent(in) :: ch + real(real64) :: a + + read(ch,*,err=1006) a + return +1006 a = 0 + +end function +!================================================================================== + + +!================================================================================== +function freal128(ch) result(a) + character(*),intent(in) :: ch + real(real64) :: a + + read(ch,*,err=1007) a + return +1007 a = 0 + +end function +!================================================================================== + + + + + +!================================================================================== +function input_Int(default,option) result(val) + integer(int32),intent(in) :: default + integer(int32),optional,intent(in)::option + integer(int32) :: val + + if(present(option) )then + val=option + else + val=default + endif + +end function +!================================================================================== + + + + +!================================================================================== +function input_Real(default,option) result(val) + real(real64),intent(in) :: default + real(real64),optional,intent(in)::option + real(real64) :: val + + if(present(option) )then + val=option + else + val=default + endif + +end function +!================================================================================== + + + +!================================================================================== +function input_Real32(default,option) result(val) + real(real32),intent(in) :: default + real(real32),optional,intent(in)::option + real(real32) :: val + + if(present(option) )then + val=option + else + val=default + endif + +end function +!================================================================================== + + +!================================================================================== +function input_Complex(default,option) result(val) + complex(real64),intent(in) :: default + complex(real64),optional,intent(in)::option + complex(real64) :: val + + if(present(option) )then + val=option + else + val=default + endif + +end function +!================================================================================== + + + + +!================================================================================== +function input_IntVec(default,option) result(val) + integer(int32),intent(in) :: default(:) + integer(int32),optional,intent(in)::option(:) + integer(int32),allocatable :: val(:) + integer(int32) :: n,m + + if(present(option) )then + n=size(option,1) + allocate(val(n) ) + val(:)=option(:) + else + n=size(default,1) + allocate(val(n) ) + val(:)=default(:) + endif + +end function +!================================================================================== + +!================================================================================== +function input_Realvec(default,option) result(val) + real(real64),intent(in) :: default(:) + real(real64),optional,intent(in)::option(:) + real(real64),allocatable :: val(:) + integer(int32) :: n,m + + if(present(option) )then + n=size(option,1) + allocate(val(n) ) + val(:)=option(:) + else + n=size(default,1) + allocate(val(n) ) + val(:)=default(:) + endif + +end function +!================================================================================== + + + + +!================================================================================== +function input_IntArray(default,option) result(val) + integer(int32),intent(in) :: default(:,:) + integer(int32),optional,intent(in)::option(:,:) + integer(int32),allocatable :: val(:,:) + integer(int32) :: n,m + + if(present(option) )then + n=size(option,1) + m=size(option,2) + allocate(val(n,m) ) + val(:,:)=option(:,:) + else + n=size(default,1) + m=size(default,2) + allocate(val(n,m) ) + val(:,:)=default(:,:) + endif + +end function +!================================================================================== + +!================================================================================== +function input_RealArray(default,option) result(val) + real(real64),intent(in) :: default(:,:) + real(real64),optional,intent(in)::option(:,:) + real(real64),allocatable :: val(:,:) + integer(int32) :: n,m + + if(present(option) )then + n=size(option,1) + m=size(option,2) + allocate(val(n,m) ) + val(:,:)=option(:,:) + else + n=size(default,1) + m=size(default,2) + allocate(val(n,m) ) + val(:,:)=default(:,:) + endif + +end function +!================================================================================== + + +!================================================================================== +function input_String(default,option) result(val) + character(*),intent(in) :: default + character(*),optional,intent(in)::option + character(200 ) :: val + + if(present(option) )then + val=option + else + val=default + endif + +end function +!================================================================================== + +!================================================================================== +function input_logical(default,option) result(val) + logical,intent(in) :: default + logical,optional,intent(in)::option + logical :: val + + if(present(option) )then + val=option + else + val=default + endif + +end function +!================================================================================== + +function zeroif_Int(val,negative,positive) result(retval) + integer(int32),intent(in)::val + integer(int32) :: retval + logical,optional,intent(in) :: negative,positive + + if(val/=val)then + print *, "ERROR :: MAthClass >> zeroif_Int is invalid" + endif + retval=val + if(present(negative) )then + if(negative .eqv. .true.)then + if(val<0)then + retval=0 + endif + endif + endif + + if(present(positive) )then + if(positive .eqv. .true.)then + if(val>0)then + retval=0 + endif + endif + endif + +end function + + +function zeroif_Real(val,negative,positive) result(retval) + real(real64),intent(in)::val + real(real64) :: retval + logical,optional,intent(in) :: negative,positive + + if(val/=val)then + print *, "ERROR :: MAthClass >> zeroif_Int is invalid" + endif + retval=val + if(present(negative) )then + if(negative .eqv. .true.)then + if(val<0.0d0)then + retval=0.0d0 + endif + endif + endif + + if(present(positive) )then + if(positive .eqv. .true.)then + if(val>0.0d0)then + retval=0.0d0 + endif + endif + endif + +end function + +! ######################################################## +subroutine removeWord_String(str,keyword,itr,Compare) + character(*),intent(inout)::str + character(*),intent(in )::keyword + + integer(int32) :: len_total,len_kw,i,j,n,itr_max + integer(int32),optional,intent(in)::itr + logical,optional,intent(in)::Compare + logical :: bk + + + if(present(Compare))then + if(Compare .eqv. .true.)then + print *, "Before :: ",str + endif + endif + + itr_max=input(default=1,option=itr) + bk=.false. + len_total=len(str) + len_kw =len(keyword) + + do i=1,itr_max + n=index(str,keyword) + do j=n,n+len_kw + str(j:j)=" " + enddo + if(n==0)then + exit + endif + enddo + + if(present(Compare))then + if(Compare .eqv. .true.)then + print *, "After :: ",str + endif + endif + + + +end subroutine +! ######################################################## + + +! ######################################################## +function Invariant_I1(sigma) result(I1) + real(real64),intent(in) :: sigma(:,:) + real(real64) :: I1 + integer(int32) :: i,j + + I1=0.0d0 + do i=1,size(sigma,1) + I1=I1+sigma(i,i) + enddo + +end function +! ######################################################## + + +! ######################################################## +function Invariant_J2(sigma) result(J2) + real(real64),intent(in) :: sigma(:,:) + real(real64) :: I1,J2,delta(3,3),M_d(3,3) + integer(int32) :: i,j + + delta(:,:)=0.0d0 + delta(1,1)=1.0d0 + delta(2,2)=1.0d0 + delta(3,3)=1.0d0 + + I1=Invariant_I1(sigma) + M_d(:,:)=sigma(:,:)-I1/3.0d0*delta(:,:) + J2=0.0d0 + do i=1,size(sigma,1) + do j=1,size(sigma,1) + J2=J2+0.50d0*M_d(i,j)*M_d(i,j) + enddo + enddo + +end function +! ######################################################## + + +! ######################################################## +function Invariant_J3(sigma) result(J3) + real(real64),intent(in) :: sigma(:,:) + real(real64) :: I1,J3,delta(3,3),M_d(3,3) + integer(int32) :: i,j,k + + delta(:,:)=0.0d0 + delta(1,1)=1.0d0 + delta(2,2)=1.0d0 + delta(3,3)=1.0d0 + + I1=Invariant_I1(sigma) + M_d(:,:)=sigma(:,:)-I1/3.0d0*delta(:,:) + J3=0.0d0 + + do i=1,size(sigma,1) + do j=1,size(sigma,1) + do k=1,size(sigma,1) + J3=J3+1.0d0/3.0d0*M_d(i,j)*M_d(j,k)*M_d(k,i) + enddo + enddo + enddo + +end function +! ######################################################## + +! ######################################################## +function Invariant_theta(sigma) result(theta) + real(real64),intent(in) :: sigma(:,:) + real(real64) :: I1,J2,J3,delta(3,3),M_d(3,3),theta + integer(int32) :: i,j,k + + delta(:,:)=0.0d0 + delta(1,1)=1.0d0 + delta(2,2)=1.0d0 + delta(3,3)=1.0d0 + J2=Invariant_J2(sigma) + J3=Invariant_J3(sigma) + theta=1.0d0/3.0d0*asin(-3.0d0*sqrt(3.0d0)*0.50d0*J3/J2/sqrt(J2) ) + +end function +! ######################################################## + +! ######################################################## +function inv_mod(a_in,m_in,ItrMax) result(x) + integer(int32),intent(in) :: a_in,m_in + integer(int32),optional,intent(in) :: ItrMax + integer(int32) :: d, q,t, Kmat_n(2,2),Kmat_npp(2,2),k,itr_tol,r0,r1,r2,i,x,y,m0 + integer(int32) :: a,m + + a=a_in + m=m_in + + itr_tol=input(default=10000,option=ItrMax) + ! inverse modula by Extended Euclidean algorithm + ! d = e^-1 (mod (lambda)) + ! d*e = 1 (mod (lambda)) + ! one integer q + ! d*e - q*lambda = 1, e, lambda are known, d, q are unknown. + ! get d, q by extended Euclidean algorithm + ! gcd(e, lambda) = 1 + !Kmat_npp(1,1)=1 + !Kmat_npp(1,2)=0 + !Kmat_npp(2,1)=0 + !Kmat_npp(2,2)=1 + !r0=e + !r1=lambda + !do i=1, itr_tol + ! r2=mod(r0,r1) + ! if(r2==0)then + ! print *, "gcd of ",e," and",lambda,"is", r1 + ! exit + ! endif + ! k=(r0-r2)/r1 + ! Kmat_n(1,1)=0 + ! Kmat_n(1,2)=1 + ! Kmat_n(2,1)=1 + ! Kmat_n(2,2)=-k + ! a=matmul(Kmat_npp,Kmat_n) + ! Kmat_npp=a + ! print *, r0,"=",k,"*",r1,"+",r2 + ! r0=r1 + ! r1=r2 + !enddo + !d = Kmat_npp(1,2) + !print *, "Kmat_npp=",Kmat_npp + ! cited by https://www.geeksforgeeks.org/multiplicative-inverse-under-modulo-m/ + m0=m + y=0 + x=1 + if(gcd(a,m)/=1 )then + a = mod(a,m) + do x=1,m + if( mod(a*x,m)==1)then + return + endif + enddo + endif + if(m==1)then + return + endif + + do i=1,itr_tol + if(a > 1)then + q=(a -mod(a,m))/m + + t=m + + m= mod(a,m) + a=t + t=y + + y=x - q*y + x=t + else + exit + endif + enddo + if(x < 0)then + x = x+m0 + endif + +end function +! ######################################################## + +! ######################################################## +function gcd(a,b,ItrMax) result(c) + integer(int32),intent(in) :: a,b + integer(int32),optional,intent(in) :: ItrMax + integer(int32) :: i,r0,r1,r2,k,itr_tol,c + c=1 + itr_tol=input(default=10000,option=ItrMax) + r0=a + r1=b + do i=1, itr_tol + r2=mod(r0,r1) + if(r2==0)then + !print *, "gcd of ",a," and",b,"is", r1 + exit + endif + k=(r0-r2)/r1 + !print *, r0,"=",k,"*",r1,"+",r2 + r0=r1 + r1=r2 + enddo + c=r1 + +end function +! ######################################################## + + +! ######################################################## +function lcm(a,b,ItrMax) result(c) + integer(int32),intent(in) :: a,b + integer(int32),optional,intent(in) :: ItrMax + integer(int32) :: i,r0,r1,r2,k,itr_tol,c + + itr_tol=input(default=10000,option=ItrMax) + r0=a + r1=b + do i=1, itr_tol + r2=mod(r0,r1) + if(r2==0)then + !print *, "gcd of ",a," and",b,"is", r1 + exit + endif + k=(r0-r2)/r1 + !print *, r0,"=",k,"*",r1,"+",r2 + r0=r1 + r1=r2 + enddo + c=a*b/r1 + + +end function +! ######################################################## + + +! ######################################################## +function convertStringToInteger(message) result(ret) + character(*),intent(in):: message + character(1) :: x + character(2*len(message) ) :: ret + integer(int32) :: i + ret = "" + !allocate(ret(len(message)*2 ) ) + do i=1,len(message) + x = message(i:i) + select case(x) + case(" ") + cycle + case("a","A") + ret(2*i-1:2*i) = "01" + case("b","B") + ret(2*i-1:2*i) = "02" + case("c","C") + ret(2*i-1:2*i) = "03" + case("d","D") + ret(2*i-1:2*i) = "04" + case("e","E") + ret(2*i-1:2*i) = "05" + case("f","F") + ret(2*i-1:2*i) = "06" + case("g","G") + ret(2*i-1:2*i) = "07" + case("h","H") + ret(2*i-1:2*i) = "08" + case("i","I") + ret(2*i-1:2*i) = "09" + case("j","J") + ret(2*i-1:2*i) = "10" + case("k","K") + ret(2*i-1:2*i) = "11" + case("l","L") + ret(2*i-1:2*i) = "12" + case("m","M") + ret(2*i-1:2*i) = "13" + case("n","N") + ret(2*i-1:2*i) = "14" + case("o","O") + ret(2*i-1:2*i) = "15" + case("p","P") + ret(2*i-1:2*i) = "16" + case("q","Q") + ret(2*i-1:2*i) = "17" + case("r","R") + ret(2*i-1:2*i) = "18" + case("s","S") + ret(2*i-1:2*i) = "19" + case("t","T") + ret(2*i-1:2*i) = "20" + case("u","U") + ret(2*i-1:2*i) = "21" + case("v","V") + ret(2*i-1:2*i) = "22" + case("w","W") + ret(2*i-1:2*i) = "23" + case("x","X") + ret(2*i-1:2*i) = "24" + case("y","Y") + ret(2*i-1:2*i) = "25" + case("z","Z") + ret(2*i-1:2*i) = "26" + end select + enddo + +end function +! ######################################################## + + +! ######################################################## +function convertIntegerToString(message) result(ret) + character(*),intent(in):: message + character(2) :: x + character(len(message) ) :: ret + integer(int32) :: i + ret = "" + !allocate(ret(len(message)*2 ) ) + do i=1,len(message) + x(1:2) = message(2*i-1:2*i) + select case(x) + case("99") + cycle + case(" ") + cycle + case("01") + ret(i:i) = "a" + case("02") + ret(i:i) = "b" + case("03") + ret(i:i) = "c" + case("04") + ret(i:i) = "d" + case("05") + ret(i:i) = "e" + case("06") + ret(i:i) = "f" + case("07") + ret(i:i) = "g" + case("08") + ret(i:i) = "h" + case("09") + ret(i:i) = "i" + case("10") + ret(i:i) = "j" + case("11") + ret(i:i) = "k" + case("12") + ret(i:i) = "l" + case("13") + ret(i:i) = "m" + case("14") + ret(i:i) = "n" + case("15") + ret(i:i) = "o" + case("16") + ret(i:i) = "p" + case("17") + ret(i:i) = "q" + case("18") + ret(i:i) = "r" + case("19") + ret(i:i) = "s" + case("20") + ret(i:i) = "t" + case("21") + ret(i:i) = "u" + case("22") + ret(i:i) = "v" + case("23") + ret(i:i) = "w" + case("24") + ret(i:i) = "x" + case("25") + ret(i:i) = "y" + case("26") + ret(i:i) = "z" + end select + enddo + +end function +! ######################################################## +! ######################################################## +subroutine rsa_keygen(prime1,prime2,seed,id_rsa,id_rsa_pub) + integer(int32),intent(in) :: prime1,prime2,seed + integer(int32),intent(out) :: id_rsa(2),id_rsa_pub(2) + integer(int32) :: n,e,lambda,d,p,q + + p=prime1 + q=prime2 + + n=p*q + lambda=(p-1)*(q-1)/gcd(p-1,q-1) + !print *, "lambda=",lambda + + id_rsa_pub(1)=n + id_rsa_pub(2)=seed + + id_rsa(1)=n + id_rsa(2)=inv_mod(seed, lambda) !get d + + print *, "#######################################################" + print *, "Encrypted by RSA algorithm, public keys " + print *, "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^" + print *, "Multiplication of two prime numbers is ",id_rsa_pub(1) + print *, "Seed value (1 < seed < ",id_rsa_pub(1),") is", id_rsa_pub(2) + print *, "Notice:: message should be (1 < seed < ",id_rsa_pub(1),")." + print *, "#######################################################" + + +end subroutine +! ######################################################## + +! ######################################################## +function rsa_encrypt(id_rsa_pub,message) result(ciphertext) + integer(int32),intent(in) ::id_rsa_pub(2),message + integer(int32) :: ciphertext,i + + ciphertext = 1 + do i=1, id_rsa_pub(2) + ciphertext= mod(ciphertext* message, id_rsa_pub(1) ) + enddo + +end function +! ######################################################## + +! ######################################################## +function rsa_decrypt(id_rsa,ciphertext) result(message) + integer(int32),intent(in) ::id_rsa(2),ciphertext + integer(int32) :: d,n,e,message,i + + + message = 1 + do i=1, id_rsa(2) + message= mod(message* ciphertext, id_rsa(1) ) + enddo + +end function +! ######################################################## + +function IsItNumber(char) result(res) + character(*),intent(inout) :: char + logical :: res + integer :: i + character(1) :: firstchar + + res=.false. + ! search all + firstchar=trim(adjustl(char(1:1))) + + if(firstchar == "1" )then + res=.true. + return + elseif(firstchar == "2" )then + res=.true. + return + elseif(firstchar == "3" )then + res=.true. + return + elseif(firstchar == "4" )then + res=.true. + return + elseif(firstchar == "5" )then + res=.true. + return + elseif(firstchar == "6" )then + res=.true. + return + elseif(firstchar == "7" )then + res=.true. + return + elseif(firstchar == "8" )then + res=.true. + return + elseif(firstchar == "9" )then + res=.true. + return + elseif(firstchar == "0" )then + res=.true. + return + elseif(firstchar == "." )then + res=.true. + return + else + return + endif + + +end function IsItNumber + + +! BitInversion +!recursive function BitInversion(i,numBit) result(ret) +! integer(int32),intent(in) :: i +! integer(int32),intent(in) :: numBit +! +! if(numBit==1)then +! ! 1 Bit 0 or 1 +! +! elseif(numBit==2)then +! elseif(numBit==3)then +! if(numBit > 3) then +! endif +! +!end function + +! Window functions + +function RectangularWindow(Width,DataSize) result(ret) + integer(int32),intent(in) :: Width,DataSize + real(real64) :: ret(DataSize) + + ret = 0.0d0 + ret(DataSize/2-Width/2:DataSize/2+Width/2) = 1 + +end function + +function HanningWindow(Width,DataSize) result(ret) + integer(int32),intent(in) :: Width,DataSize + real(real64) :: ret(DataSize) + type(Math_) :: math + integer(int32) :: i + + print *, "[CAUTION] EXPERIMENTAL!" + + ret = 0.0d0 + do i=1,width/2 + ret(DataSize/2-i) & + = 0.50d0 - 0.50d0*cos(2.0d0*Math%PI*i/(Width/2) ) + ret(DataSize/2+i) & + = 0.50d0 - 0.50d0*cos(2.0d0*Math%PI*i/(Width/2) ) + enddo + +end function + + +function HammingWindow(Width,DataSize) result(ret) + integer(int32),intent(in) :: Width,DataSize + real(real64) :: ret(DataSize) + type(Math_) :: math + integer(int32) :: i + + print *, "[CAUTION] EXPERIMENTAL!" + + + ret = 0.0d0 + do i=1,width/2 + ret(DataSize/2-i) & + = 0.540d0 - 0.46d0*cos(2.0d0*Math%PI*i/(Width/2) ) + ret(DataSize/2+i) & + = 0.540d0 - 0.46d0*cos(2.0d0*Math%PI*i/(Width/2) ) + enddo + +end function +! ####################################################################### +function log2(x) result(ret) + real(real64),intent(in) :: x + real(real64) :: ret + + ret = log(x)/log(2.0d0) + +end function +! ####################################################################### + + +! ####################################################################### +pure function day(unit) result(ret) + character(*),intent(in):: unit + real(real64) :: ret + + if(unit(1:1)=="S" .or. unit(1:1)=="s")then + ! day to second + ret = 24.0d0*60.0d0*60.0d0 + return + endif + + if(unit(1:1)=="M" .or. unit(1:1)=="m")then + ! day to minutes + ret = 24.0d0*60.0d0 + return + endif + + if(unit(1:1)=="H" .or. unit(1:1)=="h")then + ! hour to minutes + ret = 24.0d0 + return + endif + + if(unit(1:1)=="D" .or. unit(1:1)=="d")then + ! day to minutes + ret = 1.0d0 + return + endif + + if(unit(1:1)=="Y" .or. unit(1:1)=="y")then + ! day to year + ret = 1.0d0/365.0d0 + return + endif + +end function +! ####################################################################### + +! ####################################################################### +pure recursive function factorialInt32(n) result(ret) + integer(int32),intent(in) :: n + integer(int64) :: i,ret + + ret=1 + do i=1,n + ret = ret*i + enddo + +end function +! ####################################################################### + +! ####################################################################### +pure recursive function factorialReal64(n) result(ret) + real(real64),intent(in) :: n + real(real64) :: ret + integeR(int32) :: i + + ret=1.0d0 + do i=1,int(n) + ret = ret*dble(i) + enddo + +end function +! ####################################################################### + +pure function comb(n,r) result(ret) + integer(int32),intent(in) :: n,r + real(real64) :: ret + integer(int32) :: i + real(real64),allocatable :: buf1(:),buf2(:),buf3(:) + + if(n-r<0)then + ret = 0.0d0 + return + endif + + if(n<=10)then + ret = factorial(n)/(factorial(r)*factorial(n-r)) + else + allocate(buf1(n),buf2(n),buf3(n)) + do concurrent (i=1:n) + buf1(i) = i + end do + do concurrent (i=1:r) + buf2(i) = i + end do + do concurrent (i=1:n-r) + buf3(i) = i + end do + + do concurrent (i=1:r) + buf1(i) = buf1(i)/buf2(i) + end do + do concurrent (i=1:n-r) + buf1(i) = buf1(i)/buf3(i) + end do + + ret=1.0d0 + do i=1,n + ret = ret * buf1(i) + enddo + ret =dble(nint(ret)) + + !by array + endif + +end function + +function stringFromChar(charval) result(ret) + character(*),intent(in):: charval + type(String_) :: ret + + ret = charval + +end function +! ####################################################################### + +function zfill(intval, n) result(ret) + integer(int32),intent(in) :: intval,n + character(n) :: ret + character(:),allocatable :: fmt + + fmt = '(I'//str(n)//'.'//str(n)//')' + write(ret(1:n),fmt) intval + +end function + +! ######################################################################## +pure function imaginary_partComplex64(complexValue) result(imgpart) + complex(real64),intent(in) :: complexValue + real(real64) :: imgpart + type(Math_) :: math + + imgpart = real(complexvalue*math%i) + +end function +! ######################################################################## + +! ######################################################################## +pure function imaginary_partComplex32(complexValue) result(imgpart) + complex(real32),intent(in) :: complexValue + real(real32) :: imgpart + type(Math_) :: math + + imgpart = - real(complexvalue*math%i) + +end function +! ######################################################################## + + +function hilbert(wave) result(h_top_wave) + complex(real64),intent(in) :: wave(:) + complex(real64),allocatable :: h_top_wave(:),spectre(:) + + spectre = fft(wave) + spectre(1:size(spectre)/2 ) = 2.0d0*spectre(1:size(spectre)/2 ) + spectre(size(spectre)/2+1: ) = 0.0d0 + h_top_wave = ifft(spectre) + +end function +! ######################################################################## + +function short_time_FFT(wave,frame) result(spectre) + complex(real64),intent(in) :: wave(:) + complex(real64),allocatable :: spectre(:,:) + integer(int32),intent(in) :: frame + integer(int32) :: i,from,to + + ! short-time FFT for n=frame length + allocate(spectre(size(wave),2*frame)) + !$OMP parallel do private(from,to) + do i=1,size(wave) + from = i-frame + to = i+frame-1 + if(from size(wave)-frame )then + cycle + endif + spectre(i,:) = fft(wave(i-frame:i+frame-1)) + enddo + !$OMP end parallel do + +end function +! ######################################################################## + +pure function RickerFunctionReal64(t, sigma, center) result(ft) + real(real64),intent(in) :: t, sigma + real(real64),optional,intent(in) :: center + type(Math_) :: math + real(real64) ::ft128 + real(real64) :: ft, b + + if(present(center) )then + b=center + else + b=0.0d0 + endif + + ft128 = 2.0d0/(sqrt(3.0d0*sigma)*math%pi**(0.25) )*& + (1.0d0-((t-b)/sigma)*((t-b)/sigma) )*exp(-(t-b)*(t-b)/2.0d0/sigma/sigma) + + ft = dble(ft128) + +end function +! ######################################################################## + + +! ######################################################## +real(real64) function derivative_scalar(func,x,eps) + ! >>> Define func() + interface + real(real64) function func(x) + use iso_fortran_env + real(real64),intent(in) :: x + end function + end interface + + ! <<< + + ! >>> arg + real(real64),intent(in) :: x + real(real64),optional,intent(in) :: eps + ! <<< + + real(real64) :: eps_val =dble(1.0e-4) + if(present(eps) )then + eps_val = eps + endif + + ! >>> operation + ! numerical derivative + + derivative_scalar = (func(x+eps_val) - func(x-eps_val) )/(2.0d0*eps_val) + ! <<< + +end function + +! ######################################################## +function derivative_vector(func,x,dim_num,eps) result(ret) + integer(int32),intent(in) :: dim_num + ! >>> Define func() + interface + function func(x) result(ret) + use iso_fortran_env + real(real64),intent(in) :: x(:) + real(real64),allocatable :: ret(:) + end function + end interface + ! <<< + + ! >>> arg + real(real64),intent(in) :: x(1:dim_num) + real(real64),optional,intent(in) :: eps + ! <<< + + ! >>> output + real(real64),allocatable :: ret(:) + ! <<< + + real(real64) :: x_f(1:dim_num) + real(real64) :: x_b(1:dim_num) + real(real64) :: eps_val =dble(1.0e-4) + + if(present(eps) )then + eps_val = eps + endif + + ret = x + x_f = x + x_f(:) = x_f(:) + eps_val + x_b = x + x_b(:) = x_b(:) - eps_val + + ! >>> operation + ! numerical derivative + + ret = (func(x_f) - func(x_b) )/(2.0d0*eps_val) + ! <<< + +end function +! ######################################################## + +real(real64) function polynomial(x,params) + real(real64),intent(in) :: x + real(real64),intent(in) :: params(:) + integer(int32) :: i , n ,order_ + + n = size(params) + ! (n-1)-order polynomial + polynomial = 0.0d0 + order_ = 0 + do i=n-1,0,-1 + order_ = order_ + 1 + polynomial = polynomial + params(order_) * (x**i) + enddo + +end function + +! ########################################################### +real(real64) function sigmoid(x,params) + real(real64),intent(in) :: x,params(:) + + if(size(params)==0 )then + sigmoid = 1.0d0/(1.0d0 + exp(- (x) ) ) + elseif(size(params)==1 )then + sigmoid = 1.0d0/(1.0d0 + exp(- params(1)*(x) ) ) + elseif(size(params)==2 )then + sigmoid = 1.0d0/(1.0d0 + exp(- params(1)*(x-params(2)) ) ) + else + sigmoid = 1.0d0/(1.0d0 + exp(- params(1)*(x-params(2)) ) )*params(3) + endif + +end function +! ########################################################### + +! ########################################################### +real(real64) function logit(x,params) + real(real64),intent(in) :: x,params(:) + + logit = log(x/(1-x) ) + +end function +! ########################################################### + + + +end module MathClass \ No newline at end of file diff --git a/src/modules/Vector3D/CMakeLists.txt b/src/modules/Vector3D/CMakeLists.txt new file mode 100644 index 000000000..2441dc0d5 --- /dev/null +++ b/src/modules/Vector3D/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/Vector3D_Method.F90 +) \ No newline at end of file diff --git a/src/modules/Vector3D/src/Vector3D_Method.F90 b/src/modules/Vector3D/src/Vector3D_Method.F90 new file mode 100644 index 000000000..205cbf461 --- /dev/null +++ b/src/modules/Vector3D/src/Vector3D_Method.F90 @@ -0,0 +1,1019 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 24 Feb 2021 +! summary: This module contains method for [[Vector3D_]] data type +! +!# Introduction +!This module contains method for [[Vector3D_]] data type. It contains following submodules: +! +! * `Vector3D_Method@Constructor.F90` +! * `Vector3D_Method@Misc.F90` +! + +MODULE Vector3D_Method +USE GlobalData, ONLY: DFP, I4B, LGT, stdout +USE BaseType, ONLY: Vector3D_ +IMPLICIT NONE + +PRIVATE + +!---------------------------------------------------------------------------- +! Shape@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This function returns the shape of [[Vector3D_]] +! +!# Introduction +! This routine returns the shape of [[Vector3D_]] +! +!### Usage +! +!```fortran +! s = SHAPE(obj) +!``` + +INTERFACE + MODULE PURE FUNCTION get_shape(obj) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj + INTEGER(I4B) :: Ans(1) + END FUNCTION get_shape +END INTERFACE + +INTERFACE Shape + MODULE PROCEDURE get_shape +END INTERFACE Shape + +PUBLIC :: Shape + +!---------------------------------------------------------------------------- +! SIZE@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This routine returns the size of [[Vector3D_]] + +INTERFACE + MODULE PURE FUNCTION get_size(obj, Dims) RESULT(Ans) + TYPE(Vector3D_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims + INTEGER(I4B) :: Ans + END FUNCTION get_size +END INTERFACE + +INTERFACE SIZE + MODULE PROCEDURE get_size +END INTERFACE SIZE + +PUBLIC :: SIZE + +!---------------------------------------------------------------------------- +! TotalDimension@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: Returns the total dimension of an array +! +!# Introduction +! +! This function returns the total dimension (or rank) of an array, + +INTERFACE + MODULE PURE FUNCTION Vec3D_getTotalDimension(obj) RESULT(Ans) + TYPE(Vector3D_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION Vec3D_getTotalDimension +END INTERFACE + +INTERFACE getTotalDimension + MODULE PROCEDURE Vec3D_getTotalDimension +END INTERFACE getTotalDimension + +PUBLIC :: getTotalDimension + +!---------------------------------------------------------------------------- +! setTotalDimension@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 23 Feb 2021 +! summary: This subroutine set the total dimension (rank) of an array +! +!# Introduction +! +! This subroutine sets the rank(total dimension) of an array + +INTERFACE + MODULE PURE SUBROUTINE Vec3D_setTotalDimension(obj, tDimension) + CLASS(Vector3D_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: tDimension + END SUBROUTINE Vec3D_setTotalDimension +END INTERFACE + +INTERFACE setTotalDimension + MODULE PROCEDURE Vec3D_setTotalDimension +END INTERFACE setTotalDimension + +PUBLIC :: setTotalDimension + +!---------------------------------------------------------------------------- +! Allocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This routine allocate the data for [[Vector3D_]] +! +!# Introduction +! This subroutine reset the instance of [[Vector3D_]] to zero +! + +INTERFACE + MODULE PURE SUBROUTINE Allocate_Data(obj, Dims) + CLASS(Vector3D_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: Dims + END SUBROUTINE Allocate_Data +END INTERFACE + +INTERFACE ALLOCATE + MODULE PROCEDURE Allocate_Data +END INTERFACE ALLOCATE + +PUBLIC :: ALLOCATE + +!---------------------------------------------------------------------------- +! Deallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This subroutine reset the instance of [[Vector3D_]] + +INTERFACE + MODULE PURE SUBROUTINE Deallocate_Data(obj) + CLASS(Vector3D_), INTENT(INOUT) :: obj + END SUBROUTINE Deallocate_Data +END INTERFACE + +INTERFACE DEALLOCATE + MODULE PROCEDURE Deallocate_Data +END INTERFACE DEALLOCATE + +PUBLIC :: DEALLOCATE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This routine initiate the instance of [[Vector3D_]] +! +!# Introduction +! +! This routine initiate the instance of [[Vector3D_]]. If `Val` is 1D or 2D vector then the rest of the components of instance of [[Vector3D_]] will be set to zero. If `SIZE(Val)>=4` then only first 3 components are used to construct the instance. +! +!### Usage +! +!```fortran +!... +! type( Vector3D_ ) :: obj +! call initiate( obj, [1.0_DFP, 2.0_DFP, 3.0_DFP]) +! call display(obj, "test1=") +! ... +!``` + +INTERFACE + MODULE PURE SUBROUTINE initiate_obj_from_val(obj, Val) + CLASS(Vector3D_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + END SUBROUTINE initiate_obj_from_val +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This routine initiate the instance of [[Vector3D_]] from another object, basically it is a copy operation +! +!# Introduction +! This routine initiate the instance of [[Vector3D_]] from another object, basically it is a copy operation. +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj, obj2 +! call initiate( obj, [1.0_DFP, 2.0_DFP, 3.0_DFP]) +! call initiate( obj2, obj ) +! call display(obj2, "test2=") +!``` + +INTERFACE + MODULE PURE SUBROUTINE initiate_obj_from_obj(obj, Anotherobj) + CLASS(Vector3D_), INTENT(INOUT) :: obj + CLASS(Vector3D_), INTENT(IN) :: Anotherobj + END SUBROUTINE initiate_obj_from_obj +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: Generic procedure to initiate the instance of [[Vector3D_]] object + +INTERFACE Initiate + MODULE PROCEDURE initiate_obj_from_val, initiate_obj_from_obj +END INTERFACE Initiate + +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! COPY@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: Generic procedure to copy one instance of [[Vector3D_]] into another instance + +INTERFACE COPY + MODULE PROCEDURE initiate_obj_from_obj +END INTERFACE COPY + +PUBLIC :: COPY + +!---------------------------------------------------------------------------- +! Assignment@Constructor +!---------------------------------------------------------------------------- + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE initiate_obj_from_obj, initiate_obj_from_val +END INTERFACE + +PUBLIC :: ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Vector3D@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: Function to create an instance of [[vector3d_]] +! +!# Introduction +! +! This function creates an instance of [[vector3d_]] from given fortran vector of real numbers +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj +! obj = Vector3D([1.0_DFP]) +! call display( obj, "test5=") +!``` + +INTERFACE + MODULE PURE FUNCTION Constructor1(Val) RESULT(Ans) + REAL(DFP), INTENT(IN) :: Val(:) + TYPE(Vector3D_) :: Ans + END FUNCTION Constructor1 +END INTERFACE + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: Generic function to create an instance of [[Vector3D_]] + +INTERFACE Vector3D + MODULE PROCEDURE Constructor1 +END INTERFACE Vector3D + +PUBLIC :: Vector3D + +!---------------------------------------------------------------------------- +! Vector3D_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This function returns the pointer to an instance of [[Vector3D_]] +! +!# Introduction +! +! This function returns pointer to an instance of [[Vector3D_]] +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ), pointer :: obj +! obj => Vector3D_Pointer([1.0_DFP]) +! call display(obj, "test6=") +!``` + +INTERFACE + MODULE FUNCTION Constructor_1(Val) RESULT(Ans) + REAL(DFP), INTENT(IN) :: Val(:) + CLASS(Vector3D_), POINTER :: Ans + END FUNCTION Constructor_1 +END INTERFACE + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This function returns the pointer to an instance of [[Vector3D_]] +! +!### Usage +! +!```fortran +! type( Vector3D_ ), pointer :: obj +! obj => Vector3D_Pointer([1.0_DFP]) +! call display(obj, "test6=") +!``` + +INTERFACE + MODULE FUNCTION Constructor_2(obj) RESULT(Ans) + TYPE(Vector3D_), INTENT(IN) :: obj + CLASS(Vector3D_), POINTER :: Ans + END FUNCTION Constructor_2 +END INTERFACE + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This generic function returns pointer to an instance of [[Vector3D_]] + +INTERFACE Vector3D_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2 +END INTERFACE Vector3D_Pointer + +PUBLIC :: Vector3D_Pointer + +!---------------------------------------------------------------------------- +! Display@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This subroutine display [[Vector3D_]] +! +!### Usage +! +!```fortran +! type( Vector3D_ ), pointer :: obj +! obj => Vector3D_Pointer([1.0_DFP]) +! call display(obj, "test6=") +!``` + +INTERFACE + MODULE SUBROUTINE Display_obj(obj, Msg, UnitNo) + CLASS(Vector3D_), INTENT(IN) :: obj + CHARACTER(LEN=*), INTENT(IN) :: Msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + END SUBROUTINE Display_obj +END INTERFACE + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: Generic routine to display an object + +INTERFACE Display + MODULE PROCEDURE Display_obj +END INTERFACE Display + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! DOT_PRODUCT@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This funtion computes dot product of two [[Vector3D_]] object +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj1, obj2 +! obj1 = [1.0_dfp, 2.0_dfp, 3.0_dfp] +! obj2 = [1.0_dfp, 0.0_dfp, 3.0_dfp] +! CALL Equalline() +! CALL Display( "test7" ) +! CALL Display( obj1, "obj1 = " ) +! CALL Display( obj2, "obj2 = " ) +! CALL Display( DOT_PRODUCT( obj1, obj2 ), "dot_product = " ) +! CALL Display( obj1 .DOT. obj2, "dot_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION dot_product_1(obj1, obj2) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj1 + CLASS(Vector3D_), INTENT(IN) :: obj2 + REAL(DFP) :: Ans + END FUNCTION dot_product_1 +END INTERFACE + +!---------------------------------------------------------------------------- +! DOT_PRODUCT@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This funtion computes dot product of a [[Vector3D_]] object and fortran vector +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj +! real( dfp ) :: val(3) +! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] +! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] +! CALL Equalline() +! CALL Display( "test8" ) +! CALL Display( obj, "obj1 = " ) +! CALL Display( val, "val = " ) +! CALL Display( DOT_PRODUCT( obj=obj, val=val ), "dot_product = " ) +! CALL Display( obj.DOT. val, "dot_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION dot_product_2(obj, Val) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + REAL(DFP) :: Ans + END FUNCTION dot_product_2 +END INTERFACE + +!---------------------------------------------------------------------------- +! DOT_PRODUCT@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This funtion computes dot product of a [[Vector3D_]] object and fortran vector +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj +! real( dfp ) :: val(3) +! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] +! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] +! CALL Equalline() +! CALL Display( "test8" ) +! CALL Display( obj, "obj1 = " ) +! CALL Display( val, "val = " ) +! CALL Display( DOT_PRODUCT( obj=obj, val=val ), "dot_product = " ) +! CALL Display( obj.DOT. val, "dot_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION dot_product_3(Val, obj) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + REAL(DFP) :: Ans + END FUNCTION dot_product_3 +END INTERFACE + +!---------------------------------------------------------------------------- +! DOT_PRODUCT@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function returns the box product (triple scalar product) of three vector. +! +!# Introduction +! +! Box product or triple scalar product is defined as: +! +! $$\mathbf{u} \cdot (\mathbf{v} \times \mathbf{w})=[\mathbf{u}, \mathbf{v}, \mathbf{w}]$$ +! +! This function computes the box product. +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj1, obj2, obj3 +! obj1 = [1.0_dfp, 0.0_dfp, 0.0_dfp] +! obj2 = [0.0_dfp, 1.0_dfp, 0.0_dfp] +! obj3 = [1.0_dfp, 2.0_dfp, 1.0_dfp] +! CALL Equalline() +! CALL Display( "test12" ) +! CALL Display( DOT_PRODUCT( obj1, obj2, obj3 ), "dot_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION dot_product_4(u, v, w) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: u + CLASS(Vector3D_), INTENT(IN) :: v + CLASS(Vector3D_), INTENT(IN) :: w + REAL(DFP) :: Ans + END FUNCTION dot_product_4 +END INTERFACE + +!---------------------------------------------------------------------------- +! DOT_PRODUCT@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This Generic function computes dot product of [[Vector3D_]] object. + +INTERFACE DOT_PRODUCT + MODULE PROCEDURE dot_product_1, dot_product_2, dot_product_4 +END INTERFACE DOT_PRODUCT + +PUBLIC :: DOT_PRODUCT + +INTERFACE OPERATOR(.DOT.) + MODULE PROCEDURE dot_product_1, dot_product_2, dot_product_3 +END INTERFACE + +PUBLIC :: OPERATOR(.DOT.) + +!---------------------------------------------------------------------------- +! Vector_Product@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This function computes the vector product +! +!# Introduction +! +! Ths function computes the vector product of two [[Vector3D_]] object and returns another [[Vector3D_]] object. +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj1, obj2, obj3 +! obj1 = [1.0_dfp, 2.0_dfp, 3.0_dfp] +! obj2 = [1.0_dfp, 0.0_dfp, 3.0_dfp] +! CALL Equalline() +! CALL Display( "test9" ) +! CALL Display( obj1, "obj1 = " ) +! CALL Display( obj2, "obj2 = " ) +! CALL Display( VECTOR_PRODUCT( obj1, obj2 ), "vector_product = " ) +! CALL Display( obj1 .X. obj2, "vector_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION vector_product_1(obj1, obj2) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj1 + CLASS(Vector3D_), INTENT(IN) :: obj2 + TYPE(Vector3D_) :: Ans + END FUNCTION vector_product_1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Vector_Product@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This function computes the vector product +! +!# Introduction +! +! Ths function computes the vector product of a [[Vector3D_]] object and a fortran vector, and returns another [[Vector3D_]] object. +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj +! real( dfp ) :: val(3) +! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] +! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] +! CALL Equalline() +! CALL Display( "test10" ) +! CALL Display( obj, "obj1 = " ) +! CALL Display( val, "val = " ) +! CALL Display( Vector_PRODUCT( obj=obj, val=val ), "vector_product = " ) +! CALL Display( obj .X. val, "vector_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION vector_product_2(obj, Val) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + TYPE(Vector3D_) :: Ans + END FUNCTION vector_product_2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Vector_Product@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This function computes the vector product +! +!# Introduction +! +! Ths function computes the vector product of a [[Vector3D_]] object and a fortran vector, and returns another [[Vector3D_]] object. +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj +! real( dfp ) :: val(3) +! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] +! val = [1.0_dfp, 0.0_dfp, 3.0_dfp] +! CALL Equalline() +! CALL Display( "test10" ) +! CALL Display( obj, "obj1 = " ) +! CALL Display( val, "val = " ) +! CALL Display( Vector_PRODUCT( obj=obj, val=val ), "vector_product = " ) +! CALL Display( obj .X. val, "vector_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION vector_product_3(Val, obj) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: Val(:) + TYPE(Vector3D_) :: Ans + END FUNCTION vector_product_3 +END INTERFACE + +!---------------------------------------------------------------------------- +! Vector_Product@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function performs vector triple product +! +!# Introduction +! +! This function performs vector triple product, and returns the resultant [[Vector3D_]] object; +! +! $$\mathbf{u} \times (\mathbf{v} \times \mathbf{w}) = (\mathbf{u} \cdot \mathbf{w}) \mathbf{v} - (\mathbf{u} \cdot \mathbf{v}) \mathbf{w}$$ +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj1, obj2, obj3 +! obj1 = [1.0_dfp, 0.0_dfp, 0.0_dfp] +! obj2 = [0.0_dfp, 1.0_dfp, 0.0_dfp] +! obj3 = [1.0_dfp, 2.0_dfp, 1.0_dfp] +! +! CALL Equalline() +! CALL Display( "test11" ) +! CALL Display( Vector_PRODUCT( obj1, obj2, obj3 ), "vector_product = " ) +! CALL Display( obj1 .X. (obj2 .X. obj3), "vector_product = " ) +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION vector_product_4(u, v, w) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: u + CLASS(Vector3D_), INTENT(IN) :: v + CLASS(Vector3D_), INTENT(IN) :: w + TYPE(Vector3D_) :: Ans + END FUNCTION vector_product_4 +END INTERFACE + +!---------------------------------------------------------------------------- +! Vector_Product@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 Feb 2021 +! summary: This generic function computes the vector product + +INTERFACE Vector_Product + MODULE PROCEDURE vector_product_1, vector_product_2, vector_product_4 +END INTERFACE Vector_Product + +PUBLIC :: Vector_Product + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: A generic procedure to perform vector product + +INTERFACE OPERATOR(.X.) + MODULE PROCEDURE vector_product_1, vector_product_2, vector_product_3 +END INTERFACE OPERATOR(.X.) + +PUBLIC :: OPERATOR(.X.) + +!---------------------------------------------------------------------------- +! NORM2@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function creates Norm2 of a vector +! +!# Introduction +! This function computes second norm of [[vector3d_]] object. +! +! $$\vert \mathbf(u) \vert = \sqrt{\matbf{u} \cdot \mathbf{v}}$$ +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj +! obj = [1.0_dfp, 2.0_dfp, 3.0_dfp] +! CALL Equalline() +! CALL Display( "test13" ) +! CALL Display( NORM2( obj ), "NORM2 = " ) +! CALL Display( .NORM. obj, ".Norm. obj = ") +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION Norm2_obj(obj) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj + REAL(DFP) :: Ans + END FUNCTION Norm2_obj +END INTERFACE + +INTERFACE OPERATOR(.NORM.) + MODULE PROCEDURE Norm2_obj +END INTERFACE OPERATOR(.NORM.) + +PUBLIC :: OPERATOR(.NORM.) + +INTERFACE Norm2 + MODULE PROCEDURE Norm2_obj +END INTERFACE Norm2 + +PUBLIC :: Norm2 + +!---------------------------------------------------------------------------- +! UnitVector@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Returnt the unit vector from a given vector +! +!### Usage +! +!```fortran +! +!``` + +INTERFACE + MODULE PURE FUNCTION get_unitVector(obj) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: obj + TYPE(Vector3D_) :: Ans + END FUNCTION get_unitVector +END INTERFACE + +INTERFACE UnitVector + MODULE PROCEDURE get_unitVector +END INTERFACE UnitVector + +PUBLIC :: UnitVector + +INTERFACE Hat + MODULE PROCEDURE get_unitVector +END INTERFACE Hat + +PUBLIC :: Hat + +INTERFACE OPERATOR(.HAT.) + MODULE PROCEDURE get_unitVector +END INTERFACE OPERATOR(.HAT.) + +PUBLIC :: OPERATOR(.HAT.) + +!---------------------------------------------------------------------------- +! Angle@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This function returns the angle beteen two vectors +! +!# Introduction +! Angle between two vectors $\mathbf{u}$ and $\mathbf{v}$ is given by: +! +! $$\cos \theta = \frac{\mathbf{u} \cdot \mathbf{v}}{\vert \mathbf{u} \vert \cdot \vert \mathbf{v} \vert}$$ +! +! This function computes the angle between the two vectors and returnt the result in radians. +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj1, obj2 +! obj1 = [0.0_dfp, 2.0_dfp, 3.0_dfp] +! obj2 = [1.0_dfp, 0.0_dfp] +! CALL Equalline() +! CALL Display( "test14" ) +! CALL Display( ANGLE( obj1, obj2), "Angle = " ) +! CALL Display( obj1 .ANGLE. obj2, ".Angle. = ") +! CALL Display( DEGREES( obj1 .ANGLE. obj2 ), "In degrees :: ") +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION get_angle(u, v) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: u + CLASS(Vector3D_), INTENT(IN) :: v + REAL(DFP) :: Ans + END FUNCTION get_angle +END INTERFACE + +INTERFACE OPERATOR(.Angle.) + MODULE PROCEDURE get_angle +END INTERFACE OPERATOR(.Angle.) + +PUBLIC :: OPERATOR(.Angle.) + +INTERFACE Angle + MODULE PROCEDURE get_angle +END INTERFACE Angle + +PUBLIC :: Angle + +!---------------------------------------------------------------------------- +! ProjectionVector@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Returns the vector of projection from u onto v +! +!# Introduction +! Projetion of a vector $\mathbf{u}$ on \mathbf{v} is given by +! +! $$\mathbf{p} =\left( \frac{\bf{u}\cdot \bf{v}}{\bf{v} \cdot \bf{v}} \right) \bf{v}$$ +! +! This function computes $\mathbf{p}$. +! +!@note +! `.PARALLEL.` operator is alias of `.ProjectionVector.` +!@endnote +! +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj1, obj2 +! obj1 = [4.0_dfp, 2.0_dfp, 3.0_dfp] +! obj2 = [2.0_dfp, 0.0_dfp] +! CALL Equalline() +! CALL Display( "test15" ) +! CALL Display( ProjectionVector( obj1, obj2), "PROJECTIONVector = " ) +! CALL Display( obj1 .PROJECTIONVector. obj2, ".PROJECTIONVector. = ") +! CALL Display( PROJECTION(obj1, obj2), "PROJECTION = " ) +! CALL Display( obj1 .PROJECTION. obj2, ".PROJECTION. = ") +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION get_projection_vector_obj(u, v) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: u + CLASS(Vector3D_), INTENT(IN) :: v + TYPE(Vector3D_) :: Ans + END FUNCTION get_projection_vector_obj +END INTERFACE + +INTERFACE ProjectionVector + MODULE PROCEDURE get_projection_vector_obj +END INTERFACE ProjectionVector + +PUBLIC :: ProjectionVector + +INTERFACE OPERATOR(.ProjectionVector.) + MODULE PROCEDURE get_projection_vector_obj +END INTERFACE OPERATOR(.ProjectionVector.) + +PUBLIC :: OPERATOR(.ProjectionVector.) + +INTERFACE OPERATOR(.Parallel.) + MODULE PROCEDURE get_projection_vector_obj +END INTERFACE OPERATOR(.Parallel.) + +PUBLIC :: OPERATOR(.Parallel.) + +!---------------------------------------------------------------------------- +! Normal@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Returns the component of u normal to v. +! +!# Introduction +! +! The component of u normal to v is given by: +! +! $$\bf{n} =\bf{u} -(\bf{u} \cdot \hat{\bf{v} } )\hat{\bf{v} }$$ +! +! This subroutine return the component of u normal to v +! +!### Usage +! +!```fortran +! +!``` + +INTERFACE + MODULE PURE FUNCTION getNormal_Vector(u, v) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: u + CLASS(Vector3D_), INTENT(IN) :: v + TYPE(Vector3D_) :: Ans + END FUNCTION getNormal_Vector +END INTERFACE + +INTERFACE OPERATOR(.Normal.) + MODULE PROCEDURE getNormal_Vector +END INTERFACE OPERATOR(.Normal.) + +PUBLIC :: OPERATOR(.Normal.) + +INTERFACE Normal + MODULE PROCEDURE getNormal_Vector +END INTERFACE Normal + +PUBLIC :: Normal + +!---------------------------------------------------------------------------- +! Projection@Misc +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: Returns the projection from u onto v +! +!# Introduction +! Projetion of a vector $\mathbf{u}$ on \mathbf{v} is given by +! +! $$p = \mathbf{u} \cdot \hat{\mathbf{v}}$$ +! +! This function computes $p$ +! +! +!### Usage +! +!```fortran +! type( Vector3D_ ) :: obj1, obj2 +! obj1 = [4.0_dfp, 2.0_dfp, 3.0_dfp] +! obj2 = [2.0_dfp, 0.0_dfp] +! CALL Equalline() +! CALL Display( "test15" ) +! CALL Display( ProjectionVector( obj1, obj2), "PROJECTIONVector = " ) +! CALL Display( obj1 .PROJECTIONVector. obj2, ".PROJECTIONVector. = ") +! CALL Display( PROJECTION(obj1, obj2), "PROJECTION = " ) +! CALL Display( obj1 .PROJECTION. obj2, ".PROJECTION. = ") +! CALL DotLine() +!``` + +INTERFACE + MODULE PURE FUNCTION get_projection_obj(u, v) RESULT(Ans) + CLASS(Vector3D_), INTENT(IN) :: u + CLASS(Vector3D_), INTENT(IN) :: v + REAL(DFP) :: Ans + END FUNCTION get_projection_obj +END INTERFACE + +INTERFACE Projection + MODULE PROCEDURE get_projection_obj +END INTERFACE Projection + +PUBLIC :: Projection + +INTERFACE OPERATOR(.Projection.) + MODULE PROCEDURE get_projection_obj +END INTERFACE OPERATOR(.Projection.) + +PUBLIC :: OPERATOR(.Projection.) + +END MODULE Vector3D_Method diff --git a/src/modules/VoigtRank2Tensor/CMakeLists.txt b/src/modules/VoigtRank2Tensor/CMakeLists.txt new file mode 100644 index 000000000..d2dcd2ce3 --- /dev/null +++ b/src/modules/VoigtRank2Tensor/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/VoigtRank2Tensor_Method.F90 +) \ No newline at end of file diff --git a/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 b/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 new file mode 100644 index 000000000..0f0665c7f --- /dev/null +++ b/src/modules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method.F90 @@ -0,0 +1,297 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 10 March 2021 +! summary: This module contains methods for [[VoigtRank2Tensor_]] + +MODULE VoigtRank2Tensor_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: Initiate [[VoigtRank2Tensor_]] using Vector +! +!# Introduction +! +! Initiate [[VoigtRank2Tensor_]] from a given vector. +! +! +!### Usage +! +!```fortran +! type( VoigtRank2Tensor_ ) :: obj +! real( dfp ) :: vec( 6 ) +! call random_number( vec ) +! call display( vec, "vec:", orient="row" ) +! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) +! call display( obj, "stress type voigt") +! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) +! call display( obj, "stress type voigt") +!``` + +INTERFACE +MODULE PURE SUBROUTINE init_from_vec( obj, Vec, VoigtType ) + CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Vec( 6 ) + INTEGER( I4B ), INTENT( IN ) :: VoigtType +END SUBROUTINE init_from_vec +END INTERFACE + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: Initiate [[VoigtRank2Tensor_]] from a rank2 matrix +! +! +!### Usage +! +!```fortran +! type( VoigtRank2Tensor_ ) :: obj +! real( dfp ) :: vec( 6 ) +! call random_number( vec ) +! call display( vec, "vec:", orient="row" ) +! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) +! call display( obj, "stress type voigt") +! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) +! call display( obj, "stress type voigt") +!``` + +INTERFACE +MODULE PURE SUBROUTINE init_from_mat( obj, T, VoigtType ) + CLASS( VoigtRank2Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: T( 3, 3 ) + INTEGER( I4B ), INTENT( IN ) :: VoigtType +END SUBROUTINE init_from_mat +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE init_from_vec, init_from_mat +END INTERFACE Initiate + +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: This function returns an instance of [[VoigtRank2Tensor_]]. +! +!### Usage +! +!```fortran +! type( VoigtRank2Tensor_ ) :: obj +! real( dfp ) :: vec( 6 ) +! call random_number( vec ) +! call display( vec, "vec:", orient="row" ) +! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) +! call display( obj, "stress type voigt") +! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) +! call display( obj, "stress type voigt") +!``` +INTERFACE +MODULE PURE FUNCTION constructor1( Vec, VoigtType ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: Vec( : ) + INTEGER( I4B ), INTENT( IN ) :: VoigtType + TYPE( VoigtRank2Tensor_ ) :: Ans +END FUNCTION constructor1 +END INTERFACE + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: This function returns an instance of [[VoigtRank2Tensor_]]. +! +!### Usage +! +!```fortran +! type( VoigtRank2Tensor_ ) :: obj +! real( dfp ) :: vec( 6 ) +! call random_number( vec ) +! call display( vec, "vec:", orient="row" ) +! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) +! call display( obj, "stress type voigt") +! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) +! call display( obj, "stress type voigt") +!``` + +INTERFACE +MODULE PURE FUNCTION constructor2( T, VoigtType ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: T( 3, 3 ) + INTEGER( I4B ), INTENT( IN ) :: VoigtType + TYPE( VoigtRank2Tensor_ ) :: Ans +END FUNCTION constructor2 +END INTERFACE + +INTERFACE VoigtRank2Tensor + MODULE PROCEDURE constructor1, constructor2 +END INTERFACE VoigtRank2Tensor + +PUBLIC :: VoigtRank2Tensor + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: This function returns an instance of [[VoigtRank2Tensor_]]. +! +!### Usage +! +!```fortran +! type( VoigtRank2Tensor_ ) :: obj +! real( dfp ) :: vec( 6 ) +! call random_number( vec ) +! call display( vec, "vec:", orient="row" ) +! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) +! call display( obj, "stress type voigt") +! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) +! call display( obj, "stress type voigt") +!``` + +INTERFACE +MODULE PURE FUNCTION constructor_1( Vec, VoigtType ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: Vec( : ) + INTEGER( I4B ), INTENT( IN ) :: VoigtType + CLASS( VoigtRank2Tensor_ ), POINTER :: Ans +END FUNCTION constructor_1 +END INTERFACE + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor_Pointer@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: This function returns a pointer to an instance of [[VoigtRank2Tensor_]] +! +!### Usage +! +!```fortran +! type( VoigtRank2Tensor_ ) :: obj +! real( dfp ) :: vec( 6 ) +! call random_number( vec ) +! call display( vec, "vec:", orient="row" ) +! obj = VoigtRank2Tensor(vec, VoigtType=StressTypeVoigt) +! call display( obj, "stress type voigt") +! obj = VoigtRank2Tensor(vec, VoigtType=StrainTypeVoigt) +! call display( obj, "stress type voigt") +!``` + +INTERFACE +MODULE PURE FUNCTION constructor_2( T, VoigtType ) RESULT( Ans ) + REAL( DFP ), INTENT( IN ) :: T( 3, 3 ) + INTEGER( I4B ), INTENT( IN ) :: VoigtType + CLASS( VoigtRank2Tensor_ ), POINTER :: Ans +END FUNCTION constructor_2 +END INTERFACE + +INTERFACE VoigtRank2Tensor_Pointer + MODULE PROCEDURE constructor_1, constructor_2 +END INTERFACE VoigtRank2Tensor_Pointer + +PUBLIC :: VoigtRank2Tensor_Pointer + +!---------------------------------------------------------------------------- +! Assignment@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: This subroutine converts [[VoigtRank2Tensor_]] into Mat(3,3) +! +!### Usage +! +!```fortran +! type( VoigtRank2Tensor_ ) :: obj +! real( dfp ) :: T( 3, 3 ), W( 3, 3 ) +! call random_number( T ) +! T = 0.5*(T + transpose(T)) +! call display( T, "T = " ) +! obj = VoigtRank2Tensor(T, VoigtType=StressTypeVoigt) +! call display( obj, "stress type voigt") +! W = obj +! call display( W, "W=obj (stress type): ") +! obj = VoigtRank2Tensor(T, VoigtType=StrainTypeVoigt) +! call display( obj, "strain type voigt") +! W = obj +! call display( W, "W=obj (strain type): ") +!``` + +INTERFACE +MODULE PURE SUBROUTINE mat_eq_obj( T, obj ) + REAL( DFP ), INTENT( INOUT ) :: T( 3, 3 ) + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj +END SUBROUTINE mat_eq_obj +END INTERFACE + +!---------------------------------------------------------------------------- +! Assignment@Constructor +!---------------------------------------------------------------------------- + +INTERFACE +MODULE PURE SUBROUTINE vec_eq_obj( vec, obj ) + REAL( DFP ), INTENT( INOUT ) :: vec( 6 ) + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj +END SUBROUTINE vec_eq_obj +END INTERFACE + +INTERFACE ASSIGNMENT( = ) + MODULE PROCEDURE mat_eq_obj, vec_eq_obj +END INTERFACE ASSIGNMENT( = ) + +PUBLIC :: ASSIGNMENT( = ) + +!---------------------------------------------------------------------------- +! Display@IO +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 March 2021 +! summary: This routine displays the content of [[VoigtRank2Tensor_]] + +INTERFACE +MODULE SUBROUTINE display_obj( obj, Msg, UnitNo ) + CLASS( VoigtRank2Tensor_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: Msg + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo +END SUBROUTINE display_obj +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE display_obj +END INTERFACE Display + +PUBLIC :: Display + +END MODULE VoigtRank2Tensor_Method diff --git a/src/modules/easifemBase/CMakeLists.txt b/src/modules/easifemBase/CMakeLists.txt new file mode 100644 index 000000000..eb73eafac --- /dev/null +++ b/src/modules/easifemBase/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 16/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/easifemBase.F90 +) \ No newline at end of file diff --git a/src/modules/easifemBase/src/easifemBase.F90 b/src/modules/easifemBase/src/easifemBase.F90 new file mode 100644 index 000000000..784b31b2e --- /dev/null +++ b/src/modules/easifemBase/src/easifemBase.F90 @@ -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 +! + +MODULE easifemBase +USE BaseType +USE BaseMethod +END MODULE easifemBase \ No newline at end of file diff --git a/src/submodules/ARPACK/CMakeLists.txt b/src/submodules/ARPACK/CMakeLists.txt new file mode 100644 index 000000000..f1d2bb96e --- /dev/null +++ b/src/submodules/ARPACK/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}/ARPACK_SAUPD@Methods.F90 +) \ No newline at end of file diff --git a/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 b/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 new file mode 100644 index 000000000..e995059f5 --- /dev/null +++ b/src/submodules/ARPACK/src/ARPACK_SAUPD@Methods.F90 @@ -0,0 +1,617 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ARPACK_SAUPD) Methods +USE BaseMethod, ONLY: ErrorMsg, Input, F77_SAUPD, F77_SEUPD, Display, & + & SymGetLU, SymLUSolve, Tostring +USE GlobalData, ONLY: stdout, zero + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +MODULE PROCEDURE SAUPD_ErrorMsg +SELECT CASE (INFO) +CASE (1) + ans = "ERROR [from SAUPD]: : Maximum number of iterations reached" +CASE (2) + ans = "ERROR [from SAUPD]: : No longer an informational error. & + & Deprecated starting with release 2 of ARPACK." +CASE (3) + ans = "ERROR [from SAUPD]: : No shifts could be applied during implicit, & + & Arnoldi update, try increasing NCV." +CASE (-1) + ans = "ERROR [from SAUPD]: : N must be positive." +CASE (-2) + ans = "ERROR [from SAUPD]: : NEV must be positive." +CASE (-3) + ans = "ERROR [from SAUPD]: : NCV must be greater than NEV and less & + & than or equal to N." +CASE (-4) + ans = "ERROR [from SAUPD]: : The maximum number of Arnoldi update & + & iterations allowed must be greater than zero." +CASE (-5) + ans = "ERROR [from SAUPD]: : WHICH must be one of 'LM', 'SM', & + & 'LA', 'SA', 'BE'" +CASE (-6) + ans = "ERROR [from SAUPD]: : BMAT must be one of 'I' or 'G'." +CASE (-7) + ans = "ERROR [from SAUPD]: : Length of private work array WORKL & + & is not sufficient." +CASE (-8) + ans = "ERROR [from SAUPD]: : Error return from trid. & + & eigenvalue calculation. Informatinal & + & error from LAPACK routine SSTEQR." +CASE (-9) + ans = "ERROR [from SAUPD]: : Starting vector is zero." +CASE (-10) + ans = "ERROR [from SAUPD]: : IPARAM(7) must be 1" +CASE (-11) + ans = "ERROR [from SAUPD]: : IPARAM(7) = 1 and BMAT = 'G' & + & are incompatible." +CASE (-12) + ans = "ERROR [from SAUPD]: : IPARAM(1) must be equal to 0 or 1." +CASE (-13) + ans = "ERROR [from SAUPD]: : NEV and WHICH = 'BE' are incompatible." +CASE (-9999) + ans = "ERROR [from SAUPD]: : Could not build an Arnoldi factorization. & + & IPARAM(5) returns the size of the current Arnoldi factorization. & + & The user is advised to check that enough workspace and & + & array storage has been allocated." +CASE DEFAULT + ans = "ERROR [from SAUPD]: : Unknown error has occured!" +END SELECT +END PROCEDURE SAUPD_ErrorMsg + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SEUPD_ErrorMsg +SELECT CASE (INFO) +CASE (-1) + ans = "ERROR [from SEUPD]: : N must be positive." +CASE (-2) + ans = "ERROR [from SEUPD]: : NEV must be positive." +CASE (-3) + ans = "ERROR [from SEUPD]: : NCV must be greater than NEV and less & + & than or equal to N." +CASE (-5) + ans = "ERROR [from SEUPD]: : WHICH must be one of 'LM', 'SM', & + & 'LA', 'SA', 'BE'" +CASE (-6) + ans = "ERROR [from SEUPD]: : BMAT must be one of 'I' or 'G'." +CASE (-7) + ans = "ERROR [from SEUPD]: : Length of private work array WORKL & + & is not sufficient." +CASE (-8) + ans = "ERROR [from SEUPD]: : Error return from trid. & + & eigenvalue calculation. Informatinal & + & error from LAPACK routine SSTEQR." +CASE (-9) + ans = "ERROR [from SEUPD]: : Starting vector is zero." +CASE (-10) + ans = "ERROR [from SEUPD]: : IPARAM(7) must be 1" +CASE (-11) + ans = "ERROR [from SEUPD]: : IPARAM(7) = 1 and BMAT = 'G' & + & are incompatible." +CASE (-12) + ans = "ERROR [from SEUPD]: : NEV and WHICH = 'BE' are incompatible." +CASE (-14) + ans = "ERROR [from SEUPD]: : SSAUPD did not find any eigenvalues & + & to sufficient accuracy." +CASE (-15) + ans = "ERROR [from SEUPD]: : HOWMNY must be one of 'A' or 'S' & + & if RVEC = .true." +CASE (-16) + ans = "ERROR [from SEUPD]: : HOWMNY = 'S' not yet implemented" +CASE (-17) + ans = "ERROR [from SEUPD]: : SSEUPD got a different count of the & + & number of converged Ritz values than SSAUPD got. & + & This indicates the user probably made an error in & + & passing data from SSAUPD to SSEUPD or that the data was & + & modified before entering SSEUPD." +CASE DEFAULT + ans = "ERROR [from SEUPD]: : Unknown error has occured!" +END SELECT +END PROCEDURE SEUPD_ErrorMsg + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLargestEigenVal1 +CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal1" +!! +!! Internal variables +!! +INTEGER(I4B), PARAMETER :: nev = 1 +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0 +CHARACTER(1), PARAMETER :: bmat = "I" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, d(nev), sigma +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +!! +!! int scalar +!! +which0 = INPUT(default="LA", option=which) +n = SIZE(mat, 1) +ncv0 = input(default=MIN(20_I4B, n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +!! +!! iparam +!! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 1 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +!! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + !! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + !! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + !! + !! Perform MatVec Mult + !! y = MATMUL(mat, X) + !! x => WORKD(ipntr(1):ipntr(1)+N-1) + !! y => WORKD(ipntr(2):ipntr(2)+N-1) + !! + workd(ipntr(2):ipntr(2)+n-1) = MATMUL(mat, workd(ipntr(1):ipntr(1)+n-1)) + !! + ELSE + EXIT + END IF +END DO +!! +!! we are not getting rvec, therefore ldz=1, +!! othereise ldz = N +!! +CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=d, z=v, ldz=1, sigma=sigma, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) +!! +IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(INFO) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP +ELSE + ans = d(1) +END IF +!! +END PROCEDURE SymLargestEigenVal1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLargestEigenVal2 +CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal2" +!! +!! Internal variables +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0 +CHARACTER(1), PARAMETER :: bmat = "I" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, sigma +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +!! +!! int scalar +!! +which0 = INPUT(default="LA", option=which) +n = SIZE(mat, 1) +ncv0 = input(default=MIN(MAX(20_I4B, 2 * nev + 1), n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +!! +!! iparam +!! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 1 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +!! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + !! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + !! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + !! + !! Perform MatVec Mult + !! y = MATMUL(mat, X) + !! x => WORKD(ipntr(1):ipntr(1)+N-1) + !! y => WORKD(ipntr(2):ipntr(2)+N-1) + !! + workd(ipntr(2):ipntr(2)+n-1) = MATMUL(mat, workd(ipntr(1):ipntr(1)+n-1)) + !! + ELSE + EXIT + END IF +END DO +!! +!! we are not getting rvec, therefore ldz=1, +!! othereise ldz = N +!! +CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=ans, z=v, ldz=1, sigma=sigma, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) +!! +IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(INFO) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP +END IF +!! +END PROCEDURE SymLargestEigenVal2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymSmallestEigenVal1 +CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal1" +!! +!! Internal variables +!! +INTEGER(I4B), PARAMETER :: nev = 1 +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0, ii +CHARACTER(1), PARAMETER :: bmat = "I", uplo = "U" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, d(nev), sigma0 +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +REAL(DFP) :: mat0(SIZE(mat, 1), SIZE(mat, 2)) +INTEGER(I4B) :: ipiv(SIZE(mat, 1)), info1 +!! +!! int scalar +!! +sigma0 = INPUT(default=0.0_DFP, option=sigma) +!! +!! note to get smallest value, we transform the problem to +!! find largest value. +!! +IF (PRESENT(which)) THEN + which0 = "L"//which(2:2) +ELSE + which0 = "LA" +END IF +!! +n = SIZE(mat, 1) +ncv0 = input(default=MIN(20_I4B, n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +!! +!! iparam +!! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 3 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +!! +!! make a copy of mat in mat0 +!! we will then form mat - sigma*I +!! then we will compute LU decomposition +!! +mat0 = mat +DO CONCURRENT(ii=1:n) + mat0(ii, ii) = mat0(ii, ii) - sigma0 +END DO +!! +CALL SymGetLU(A=mat0, IPIV=ipiv, UPLO=uplo, INFO=info1) +!! +IF (info1 .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymSmallestEigenVal1()") + STOP +END IF +!! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + !! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + !! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + !! + !! LU Solve + !! mat0 * y = x + !! x => WORKD(ipntr(1):ipntr(1)+N-1) + !! y => WORKD(ipntr(2):ipntr(2)+N-1) + !! + WORKD(ipntr(2):ipntr(2) + N - 1) = & + & WORKD(ipntr(1):ipntr(1) + N - 1) + !! + CALL SymLUSolve(A=mat0, B=WORKD(ipntr(2):ipntr(2) + N - 1), & + & IPIV=ipiv, UPLO=uplo, INFO=info1) + !! + IF (info1 .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymSmallestEigenVal1()") + STOP + END IF + !! + ELSE + EXIT + END IF +END DO +!! +!! we are not getting rvec, therefore ldz=1, +!! othereise ldz = N +!! +IF (info .EQ. 0) THEN + CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=d, z=v, ldz=1, sigma=sigma0, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) + !! + IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + STOP + ELSE + ans = d(1) + END IF +END IF +!! +END PROCEDURE SymSmallestEigenVal1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymSmallestEigenVal2 +CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal2" +!! +!! Internal variables +!! +INTEGER(I4B), PARAMETER :: nev = 1 +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0, ii +CHARACTER(1), PARAMETER :: bmat = "I", uplo = "U" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, d(nev), sigma0 +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +REAL(DFP) :: mat0(SIZE(mat, 1), SIZE(mat, 2)) +INTEGER(I4B) :: ipiv0(SIZE(mat, 1)), info1 +!! +!! int scalar +!! +sigma0 = INPUT(default=0.0_DFP, option=sigma) +!! +!! note to get smallest value, we transform the problem to +!! find largest value. +!! +IF (PRESENT(which)) THEN + which0 = "L"//which(2:2) +ELSE + which0 = "LA" +END IF +!! +n = SIZE(mat, 1) +ncv0 = input(default=MIN(20_I4B, n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +!! +!! iparam +!! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 3 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +!! +!! make a copy of mat in mat0 +!! we will then form mat - sigma*I +!! then we will compute LU decomposition +!! +IF (.NOT. isFactor) THEN + !! + DO CONCURRENT(ii=1:n) + mat(ii, ii) = mat(ii, ii) - sigma0 + END DO + !! + CALL SymGetLU(A=mat, IPIV=ipiv0, UPLO=uplo, INFO=info1) + !! + IF (info1 .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymSmallestEigenVal2()") + STOP + END IF + !! +ELSE + !! + IF (.NOT. PRESENT(ipiv)) THEN + CALL ErrorMsg( & + & msg="When isFactor is True, then ipiv should be provided", & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymSmallestEigenVal2()") + STOP + !! + ELSE + ipiv0(1:n) = ipiv(1:n) + END IF + !! +END IF +!! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + !! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + STOP + END IF + !! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + !! + !! LU Solve + !! mat0 * y = x + !! x => WORKD(ipntr(1):ipntr(1)+N-1) + !! y => WORKD(ipntr(2):ipntr(2)+N-1) + !! + WORKD(ipntr(2):ipntr(2) + N - 1) = & + & WORKD(ipntr(1):ipntr(1) + N - 1) + !! + CALL SymLUSolve(A=mat, B=WORKD(ipntr(2):ipntr(2) + N - 1), & + & IPIV=ipiv0, UPLO=uplo, INFO=info1) + !! + IF (info1 .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error occured in SymGetLU() errorCode="//tostring(info1), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymSmallestEigenVal2()") + STOP + END IF + !! + ELSE + EXIT + END IF +END DO +!! +!! we are not getting rvec, therefore ldz=1, +!! othereise ldz = N +!! +IF (info .EQ. 0) THEN + CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=d, z=v, ldz=1, sigma=sigma0, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) + !! + IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ELSE + ans = d(1) + END IF +END IF +!! +END PROCEDURE SymSmallestEigenVal2 + +END SUBMODULE Methods diff --git a/src/submodules/BoundingBox/CMakeLists.txt b/src/submodules/BoundingBox/CMakeLists.txt new file mode 100644 index 000000000..b5b155b73 --- /dev/null +++ b/src/submodules/BoundingBox/CMakeLists.txt @@ -0,0 +1,26 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/BoundingBox_Method@ConstructorMethods.F90 + ${src_path}/BoundingBox_Method@SetMethods.F90 + ${src_path}/BoundingBox_Method@GetMethods.F90 + ${src_path}/BoundingBox_Method@IOMethods.F90 + ${src_path}/BoundingBox_Method@TomlMethods.F90 +) diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 new file mode 100644 index 000000000..4d3f08049 --- /dev/null +++ b/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 @@ -0,0 +1,180 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(BoundingBox_Method) ConstructorMethods +USE Display_Method, ONLY: BlankLines +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_1 +obj%nsd = nsd +obj%box(1, 1) = lim(1) !xmin +obj%box(1, 2) = lim(3) !ymin +obj%box(1, 3) = lim(5) !zmin +obj%box(2, 1) = lim(2) !xmax +obj%box(2, 2) = lim(4) !ymax +obj%box(2, 3) = lim(6) !zmax +obj%l(1) = lim(2) - lim(1) +obj%l(2) = lim(4) - lim(3) +obj%l(3) = lim(6) - lim(5) +END PROCEDURE Initiate_1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_2 +obj%box = anotherobj%box +obj%nsd = anotherobj%nsd +obj%l = anotherobj%l +END PROCEDURE Initiate_2 + +!--------------------------------------------------------------------------- +! Initiate +!--------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_3 +INTEGER(I4B) :: ii, tsize +tsize = SIZE(anotherobj) +DO ii = 1, tsize + obj(ii) = anotherobj(ii) +END DO +END PROCEDURE Initiate_3 + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_1 +INTEGER(I4B) :: tsize1, tsize2 +TYPE(BoundingBox_), ALLOCATABLE :: tempbox(:) + +tsize2 = SIZE(VALUE) +IF (ALLOCATED(obj)) THEN + tsize1 = SIZE(obj) + ALLOCATE (tempbox(tsize1)) + CALL Initiate(obj=tempbox, anotherobj=obj) + CALL DEALLOCATE (obj) + ALLOCATE (obj(tsize1 + tsize2)) + CALL Initiate(obj(1:tsize1), tempbox) + CALL Initiate(obj(tsize1 + 1:), VALUE) + CALL DEALLOCATE (tempbox) + RETURN + +END IF + +tsize1 = 0 +ALLOCATE (obj(tsize1 + tsize2)) +CALL Initiate(obj(tsize1 + 1:), VALUE) +END PROCEDURE Append_1 + +!---------------------------------------------------------------------------- +! BoundingBox +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor1 +CALL Initiate(ans, nsd, lim) +END PROCEDURE Constructor1 + +!---------------------------------------------------------------------------- +! Bounding box +!---------------------------------------------------------------------------- +MODULE PROCEDURE Constructor2 +CALL Initiate(ans, anotherobj) +END PROCEDURE Constructor2 + +!---------------------------------------------------------------------------- +! Bounding box +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor3 +REAL(DFP) :: lim(6) +INTEGER(I4B) :: nsd + +lim = 0.0_DFP +nsd = SIZE(xij, 1) + +SELECT CASE (nsd) +CASE (1) + lim(1) = MINVAL(xij(1, :)) + lim(2) = MAXVAL(xij(1, :)) +CASE (2) + lim(1) = MINVAL(xij(1, :)) + lim(2) = MAXVAL(xij(1, :)) + lim(3) = MINVAL(xij(2, :)) + lim(4) = MAXVAL(xij(2, :)) +CASE (3) + lim(1) = MINVAL(xij(1, :)) + lim(2) = MAXVAL(xij(1, :)) + lim(3) = MINVAL(xij(2, :)) + lim(4) = MAXVAL(xij(2, :)) + lim(5) = MINVAL(xij(3, :)) + lim(6) = MAXVAL(xij(3, :)) +END SELECT + +CALL Initiate(obj=ans, nsd=nsd, lim=lim) +END PROCEDURE Constructor3 + +!---------------------------------------------------------------------------- +! BoundingBox_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor_1 +ALLOCATE (ans) +CALL Initiate(ans, nsd, lim) +END PROCEDURE Constructor_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor_2 +ALLOCATE (ans) +CALL Initiate(ans, anotherobj) +END PROCEDURE Constructor_2 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BB_Deallocate +obj%nsd = 0 +obj%box = 0.0_DFP +obj%l = 0.0_DFP +END PROCEDURE BB_Deallocate + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE bb_deallocate2 +INTEGER(I4B) :: ii +IF (ALLOCATED(obj)) THEN + DO ii = 1, SIZE(obj) + CALL DEALLOCATE (obj(ii)) + END DO + DEALLOCATE (obj) +END IF +END PROCEDURE bb_deallocate2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +END SUBMODULE ConstructorMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 new file mode 100644 index 000000000..e0955bfac --- /dev/null +++ b/src/submodules/BoundingBox/src/BoundingBox_Method@GetMethods.F90 @@ -0,0 +1,300 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(BoundingBox_Method) GetMethods +USE GlobalData, ONLY: zero +USE ApproxUtility +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getXmin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getXmin +ans = obj%box(1, 1) +END PROCEDURE getXmin + +!---------------------------------------------------------------------------- +! getXmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getXmax +ans = obj%box(2, 1) +END PROCEDURE getXmax + +!---------------------------------------------------------------------------- +! getYmin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getYmin +ans = obj%box(1, 2) +END PROCEDURE getYmin + +!---------------------------------------------------------------------------- +! getYmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getYmax +ans = obj%box(2, 2) +END PROCEDURE getYmax + +!---------------------------------------------------------------------------- +! getZmin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getZmin +ans = obj%box(1, 3) +END PROCEDURE getZmin + +!---------------------------------------------------------------------------- +! getZmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getZmax +ans = obj%box(2, 3) +END PROCEDURE getZmax + +!---------------------------------------------------------------------------- +! is_intersect_in_X +!---------------------------------------------------------------------------- + +MODULE PROCEDURE is_intersect_in_X +! Define internal variables +REAL(DFP) :: min1, max1, min2, max2 +LOGICAL(LGT) :: Left, Right + +min1 = .Xmin.obj; max1 = .Xmax.obj +min2 = .Xmin.obj2; max2 = .Xmax.obj2 + +Right = (min2 .GE. min1) .AND. (min2 .LE. max1) +Left = (max2 .GE. min1) .AND. (max2 .LE. max1) + +IF (Left .OR. Right) THEN + ans = .TRUE. +ELSE + ans = .FALSE. +END IF +END PROCEDURE is_intersect_in_X + +!---------------------------------------------------------------------------- +! is_intersect_in_Y +!---------------------------------------------------------------------------- + +MODULE PROCEDURE is_intersect_in_Y +! Define internal variables +REAL(DFP) :: min1, max1, min2, max2 +LOGICAL(LGT) :: Left, Right + +min1 = .Ymin.obj; max1 = .Ymax.obj +min2 = .Ymin.obj2; max2 = .Ymax.obj2 + +Right = (min2 .GE. min1) .AND. (min2 .LE. max1) +Left = (max2 .GE. min1) .AND. (max2 .LE. max1) + +IF (Left .OR. Right) THEN + ans = .TRUE. +ELSE + ans = .FALSE. +END IF +END PROCEDURE is_intersect_in_Y + +!---------------------------------------------------------------------------- +! is_intersect_in_Z +!---------------------------------------------------------------------------- + +MODULE PROCEDURE is_intersect_in_Z +! Define internal variables +REAL(DFP) :: min1, max1, min2, max2 +LOGICAL(LGT) :: Left, Right + +min1 = .Zmin.obj; max1 = .Zmax.obj +min2 = .Zmin.obj2; max2 = .Zmax.obj2 + +Right = (min2 .GE. min1) .AND. (min2 .LE. max1) +Left = (max2 .GE. min1) .AND. (max2 .LE. max1) + +IF (Left .OR. Right) THEN + ans = .TRUE. +ELSE + ans = .FALSE. +END IF +END PROCEDURE is_intersect_in_Z + +!---------------------------------------------------------------------------- +! is_intersect +!---------------------------------------------------------------------------- + +MODULE PROCEDURE is_intersect +ans = isIntersectInX(obj, obj2) & + & .AND. isIntersectInY(obj, obj2) & + & .AND. isIntersectInZ(obj, obj2) +END PROCEDURE is_intersect + +!---------------------------------------------------------------------------- +! isEmpty +!---------------------------------------------------------------------------- + +MODULE PROCEDURE bbox_isEmpty +ans = .TRUE. +IF (ANY(obj%l .GT. zero)) ans = .FALSE. +END PROCEDURE bbox_isEmpty + +!---------------------------------------------------------------------------- +! get_intersection +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_intersection +INTEGER(I4B) :: nsd +REAL(DFP) :: lim(6) + +nsd = MAX(obj%nsd, obj2%nsd) +lim = 0.0_DFP + +lim(1) = MAX(obj%box(1, 1), obj2%box(1, 1)) +lim(2) = MIN(obj%box(2, 1), obj2%box(2, 1)) + +lim(3) = MAX(obj%box(1, 2), obj2%box(1, 2)) +lim(4) = MIN(obj%box(2, 2), obj2%box(2, 2)) + +lim(5) = MAX(obj%box(1, 3), obj2%box(1, 3)) +lim(6) = MIN(obj%box(2, 3), obj2%box(2, 3)) + +CALL Initiate(obj=ans, nsd=nsd, lim=lim) + +END PROCEDURE get_intersection + +!---------------------------------------------------------------------------- +! Union +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_union +! Define Internal variables +INTEGER(I4B) :: nsd +REAL(DFP) :: val(6), val1, val2 + +nsd = MAX(obj%nsd, obj2%nsd) + +val1 = .Xmin.obj; val2 = .Xmin.obj2 +val(1) = MIN(val1, val2) + +val1 = .Xmax.obj; val2 = .Xmax.obj2 +val(2) = MAX(val1, val2) + +val1 = .Ymin.obj; val2 = .Ymin.obj2 +val(3) = MIN(val1, val2) + +val1 = .Ymax.obj; val2 = .Ymax.obj2 +val(4) = MAX(val1, val2) + +val1 = .Zmin.obj; val2 = .Zmin.obj2 +val(5) = MIN(val1, val2) + +val1 = .Zmax.obj; val2 = .Zmax.obj2 +val(6) = MAX(val1, val2) + +CALL Initiate(obj=ans, nsd=nsd, lim=val) +END PROCEDURE get_union + +!---------------------------------------------------------------------------- +! Center +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_Center +ans(1) = SUM(obj%box(:, 1)) / 2.0_DFP +ans(2) = SUM(obj%box(:, 2)) / 2.0_DFP +ans(3) = SUM(obj%box(:, 3)) / 2.0_DFP +END PROCEDURE get_Center + +!---------------------------------------------------------------------------- +! IsInside +!---------------------------------------------------------------------------- + +MODULE PROCEDURE is_Inside +INTEGER(I4B) :: ii + +ans = .FALSE. +DO ii = 1, SIZE(val) + ans = xyz(val(ii), obj%box(1, ii), obj%box(2, ii)) + IF (.NOT. ans) RETURN +END DO + +CONTAINS +PURE ELEMENTAL FUNCTION xyz(x, y, z) RESULT(ans) + REAL(DFP), INTENT(IN) :: x, y, z + LOGICAL(LGT) :: ans + ans = .FALSE. + IF ((x.APPROXGE.y) .AND. (x.APPROXLE.z)) ans = .TRUE. +END FUNCTION xyz +END PROCEDURE is_Inside + +!---------------------------------------------------------------------------- +! getNptrs +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_nptrs +INTEGER(I4B) :: n, i +LOGICAL(LGT), ALLOCATABLE :: msk(:) +INTEGER(I4B), ALLOCATABLE :: Indx(:) + +n = SIZE(xij, 2) +ALLOCATE (msk(n), Indx(n)) +DO i = 1, n + msk(i) = isInside(obj, xij(:, i)) + Indx(i) = i +END DO +ans = PACK(Indx, msk) +DEALLOCATE (msk, Indx) +END PROCEDURE get_nptrs + +!---------------------------------------------------------------------------- +! GetDiameter +!---------------------------------------------------------------------------- + +MODULE PROCEDURE bbox_GetDiameterSqr +ans = obj%l(1)**2 + obj%l(2)**2 + obj%l(3)**2 +END PROCEDURE bbox_GetDiameterSqr + +!---------------------------------------------------------------------------- +! GetDiameter +!---------------------------------------------------------------------------- + +MODULE PROCEDURE bbox_GetDiameter +ans = SQRT(bbox_GetDiameterSqr(obj)) +END PROCEDURE bbox_GetDiameter + +!---------------------------------------------------------------------------- +! GetRadius +!---------------------------------------------------------------------------- + +MODULE PROCEDURE bbox_GetRadius +ans = bbox_GetDiameter(obj) * 0.5_DFP +END PROCEDURE bbox_GetRadius + +!---------------------------------------------------------------------------- +! GetRadius +!---------------------------------------------------------------------------- + +MODULE PROCEDURE bbox_GetRadiusSqr +ans = 0.25_DFP * bbox_GetDiameterSqr(obj) +END PROCEDURE bbox_GetRadiusSqr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE GetMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 new file mode 100644 index 000000000..246ab3bd7 --- /dev/null +++ b/src/submodules/BoundingBox/src/BoundingBox_Method@IOMethods.F90 @@ -0,0 +1,41 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(BoundingBox_Method) IOMethods +USE Display_Method +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE display_obj +CALL Display(msg, unitNo=unitNo) +CALL Display(obj%nsd, msg="NSD :: ", unitNo=unitNo) +CALL Display(.Xmin.obj, msg="Xmin :: ", unitNo=unitNo) +CALL Display(.Xmax.obj, msg="Xmax :: ", unitNo=unitNo) +CALL Display(.Ymin.obj, msg="Ymin :: ", unitNo=unitNo) +CALL Display(.Ymax.obj, msg="Ymax :: ", unitNo=unitNo) +CALL Display(.Zmin.obj, msg="Zmin :: ", unitNo=unitNo) +CALL Display(.Zmax.obj, msg="Zmax :: ", unitNo=unitNo) +CALL Display(obj%l(1), msg="Lx :: ", unitNo=unitNo) +CALL Display(obj%l(2), msg="Ly :: ", unitNo=unitNo) +CALL Display(obj%l(3), msg="Lz :: ", unitNo=unitNo) +END PROCEDURE display_obj + +END SUBMODULE IOMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 new file mode 100644 index 000000000..8261a4518 --- /dev/null +++ b/src/submodules/BoundingBox/src/BoundingBox_Method@SetMethods.F90 @@ -0,0 +1,70 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(BoundingBox_Method) SetMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setXmin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setXmin +obj%box(1, 1) = val +END PROCEDURE setXmin + +!---------------------------------------------------------------------------- +! setXmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setXmax +obj%box(2, 1) = val +END PROCEDURE setXmax + +!---------------------------------------------------------------------------- +! setYmin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setYmin +obj%box(1, 2) = val +END PROCEDURE setYmin + +!---------------------------------------------------------------------------- +! setYmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setYmax +obj%box(2, 2) = val +END PROCEDURE setYmax + +!---------------------------------------------------------------------------- +! setZmin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setZmin +obj%box(1, 3) = val +END PROCEDURE setZmin + +!---------------------------------------------------------------------------- +! setZmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setZmax +obj%box(2, 3) = val +END PROCEDURE setZmax + +END SUBMODULE SetMethods diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 new file mode 100644 index 000000000..682a2e1b2 --- /dev/null +++ b/src/submodules/BoundingBox/src/BoundingBox_Method@TomlMethods.F90 @@ -0,0 +1,86 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(BoundingBox_Method) TomlMethods +USE tomlf, ONLY: & + ! & toml_error, & + ! & toml_load, & + ! & toml_parser_config, & + ! & toml_serialize, & + & toml_get => get_value, & + & toml_len => len, & + ! & toml_context, & + ! & toml_terminal, & + ! & toml_load, & + ! & toml_stat, & + & toml_array +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE toml_get_bbox_r0 +REAL(DFP) :: lim(6) +lim = 0.0 +CALL toml_get(table, "xmin", lim(1), origin=origin, stat=stat) +CALL toml_get(table, "ymin", lim(2), origin=origin, stat=stat) +CALL toml_get(table, "zmin", lim(3), origin=origin, stat=stat) +CALL toml_get(table, "xmax", lim(4), origin=origin, stat=stat) +CALL toml_get(table, "ymax", lim(5), origin=origin, stat=stat) +CALL toml_get(table, "zmax", lim(6), origin=origin, stat=stat) +CALL Initiate(obj=VALUE, nsd=3_I4B, lim=lim) +END PROCEDURE toml_get_bbox_r0 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE toml_get_bbox_r1 +TYPE(toml_array), POINTER :: array +TYPE(toml_table), POINTER :: child +LOGICAL(LGT) :: isFound0 +INTEGER(I4B) :: ii, tsize + +child => NULL() +array => NULL() +isFound0 = .FALSE. +CALL DEALLOCATE (VALUE) + +CALL toml_get(table, key, array, origin=origin, & + & stat=stat, requested=.FALSE.) + +IF (ASSOCIATED(array)) THEN + isFound0 = .TRUE. + tsize = toml_len(array) + ALLOCATE (VALUE(tsize)) + DO ii = 1, tsize + CALL toml_get(array, ii, child) + CALL toml_get_bbox_r0(table=child, key="", VALUE=VALUE(ii), & + & origin=origin, stat=stat) + END DO +END IF + +IF (PRESENT(isFound)) isFound = isFound0 +NULLIFY (array, child) +END PROCEDURE toml_get_bbox_r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE TomlMethods diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt new file mode 100644 index 000000000..c6af0f192 --- /dev/null +++ b/src/submodules/CMakeLists.txt @@ -0,0 +1,130 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +# TriangleInterface +include(${CMAKE_CURRENT_LIST_DIR}/TriangleInterface/CMakeLists.txt) + +# Hashing +include(${CMAKE_CURRENT_LIST_DIR}/Hashing/CMakeLists.txt) + +# MdEncode +include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) + +# Utility +include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) + +# Polynomial +include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) + +# MultiIndices +include(${CMAKE_CURRENT_LIST_DIR}/MultiIndices/CMakeLists.txt) + +# OpenMP +include(${CMAKE_CURRENT_LIST_DIR}/OpenMP/CMakeLists.txt) + +# Random +include(${CMAKE_CURRENT_LIST_DIR}/Random/CMakeLists.txt) + +# BoundingBox +include(${CMAKE_CURRENT_LIST_DIR}/BoundingBox/CMakeLists.txt) + +# IntVector +include(${CMAKE_CURRENT_LIST_DIR}/IntVector/CMakeLists.txt) + +# IndexValue +include(${CMAKE_CURRENT_LIST_DIR}/IndexValue/CMakeLists.txt) + +# IterationData +include(${CMAKE_CURRENT_LIST_DIR}/IterationData/CMakeLists.txt) + +# KeyValue +include(${CMAKE_CURRENT_LIST_DIR}/KeyValue/CMakeLists.txt) + +# Vector3D +include(${CMAKE_CURRENT_LIST_DIR}/Vector3D/CMakeLists.txt) + +# Lapack +include(${CMAKE_CURRENT_LIST_DIR}/Lapack/CMakeLists.txt) + +# ARPACK +include(${CMAKE_CURRENT_LIST_DIR}/ARPACK/CMakeLists.txt) + +# RealVector +include(${CMAKE_CURRENT_LIST_DIR}/RealVector/CMakeLists.txt) + +# DOF +include(${CMAKE_CURRENT_LIST_DIR}/DOF/CMakeLists.txt) + +# Geometry +include(${CMAKE_CURRENT_LIST_DIR}/Geometry/CMakeLists.txt) + +# QuadraturePoint +include(${CMAKE_CURRENT_LIST_DIR}/QuadraturePoint/CMakeLists.txt) + +# FEVariable +include(${CMAKE_CURRENT_LIST_DIR}/FEVariable/CMakeLists.txt) + +# ElemShapeData +include(${CMAKE_CURRENT_LIST_DIR}/ElemshapeData/CMakeLists.txt) + +# RealMatrix +include(${CMAKE_CURRENT_LIST_DIR}/RealMatrix/CMakeLists.txt) + +# MassMatrix +include(${CMAKE_CURRENT_LIST_DIR}/MassMatrix/CMakeLists.txt) + +# STMassMatrix +include(${CMAKE_CURRENT_LIST_DIR}/STMassMatrix/CMakeLists.txt) + +# DiffusionMatrix +include(${CMAKE_CURRENT_LIST_DIR}/DiffusionMatrix/CMakeLists.txt) + +# STDiffusionMatrix +include(${CMAKE_CURRENT_LIST_DIR}/STDiffusionMatrix/CMakeLists.txt) + +# ConvectiveMatrix +include(${CMAKE_CURRENT_LIST_DIR}/ConvectiveMatrix/CMakeLists.txt) + +# STConvectiveMatrix +include(${CMAKE_CURRENT_LIST_DIR}/STConvectiveMatrix/CMakeLists.txt) + +# StiffnessMatrix +include(${CMAKE_CURRENT_LIST_DIR}/StiffnessMatrix/CMakeLists.txt) + +# ElasticNitscheMatrix +include(${CMAKE_CURRENT_LIST_DIR}/ElasticNitscheMatrix/CMakeLists.txt) + +# FacetMatrix +include(${CMAKE_CURRENT_LIST_DIR}/FacetMatrix/CMakeLists.txt) + +# ForceVector +include(${CMAKE_CURRENT_LIST_DIR}/ForceVector/CMakeLists.txt) + +# STForceVector +include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt) + +# VoigtRank2Tensor +include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt) + +# Rank2Tensor +include(${CMAKE_CURRENT_LIST_DIR}/Rank2Tensor/CMakeLists.txt) + +# CSRSparsity +include(${CMAKE_CURRENT_LIST_DIR}/CSRSparsity/CMakeLists.txt) + +# CSRMatrix +include(${CMAKE_CURRENT_LIST_DIR}/CSRMatrix/CMakeLists.txt) diff --git a/src/submodules/CSRMatrix/CMakeLists.txt b/src/submodules/CSRMatrix/CMakeLists.txt new file mode 100644 index 000000000..9687b24e2 --- /dev/null +++ b/src/submodules/CSRMatrix/CMakeLists.txt @@ -0,0 +1,47 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/CSRMatrix_AddMethods@Methods.F90 + ${src_path}/CSRMatrix_ConstructorMethods@Methods.F90 + ${src_path}/CSRMatrix_DiagonalScalingMethods@Methods.F90 + ${src_path}/CSRMatrix_GetBlockColMethods@Methods.F90 + ${src_path}/CSRMatrix_GetColMethods@Methods.F90 + ${src_path}/CSRMatrix_GetMethods@Methods.F90 + ${src_path}/CSRMatrix_GetRowMethods@Methods.F90 + ${src_path}/CSRMatrix_GetSubMatrixMethods@Methods.F90 + ${src_path}/CSRMatrix_ILUMethods@Methods.F90 + ${src_path}/CSRMatrix_IOMethods@Methods.F90 + ${src_path}/CSRMatrix_LUSolveMethods@Methods.F90 + ${src_path}/CSRMatrix_MatVecMethods@Methods.F90 + ${src_path}/CSRMatrix_SymMatmulMethods@Methods.F90 + ${src_path}/CSRMatrix_ReorderingMethods@Methods.F90 + ${src_path}/CSRMatrix_SetBlockColMethods@Methods.F90 + ${src_path}/CSRMatrix_SetBlockRowMethods@Methods.F90 + ${src_path}/CSRMatrix_SetColMethods@Methods.F90 + ${src_path}/CSRMatrix_SetRowMethods@Methods.F90 + ${src_path}/CSRMatrix_SetMethods@Methods.F90 + ${src_path}/CSRMatrix_SparsityMethods@Methods.F90 + ${src_path}/CSRMatrix_UnaryMethods@Methods.F90 + ${src_path}/CSRMatrix_SpectralMethods@Methods.F90 + ${src_path}/CSRMatrix_MatrixMarketIO@Methods.F90 + ${src_path}/CSRMatrix_DBCMethods@Methods.F90 + ${src_path}/CSRMatrix_LinSolveMethods@Methods.F90 + ${src_path}/CSRMatrix_SuperLU@Methods.F90 + ${src_path}/CSRMatrix_SchurMethods@Methods.F90) diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 new file mode 100644 index 000000000..15664fcb3 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 @@ -0,0 +1,420 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: It contains method for setting values in [[CSRMatrix_]] + +SUBMODULE(CSRMatrix_AddMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! AddContribution +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add0 +! Internal variables +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) + +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 +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +END PROCEDURE obj_Add0 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add1 +REAL(DFP), ALLOCATABLE :: m2(:, :) +INTEGER(I4B) :: tdof + +tdof = .tdof.obj%csr%idof +SELECT CASE (storageFMT) +CASE (FMT_NODES) + IF ((obj.StorageFMT.1) .EQ. FMT_NODES) THEN + m2 = VALUE + ELSE + CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, & + & 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) + END IF +END SELECT + +CALL Add(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale) +IF (ALLOCATED(m2)) DEALLOCATE (m2) + +END PROCEDURE obj_Add1 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add2 +obj%A = obj%A + scale * VALUE +END PROCEDURE obj_Add2 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +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 +END DO +END PROCEDURE obj_Add3 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +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) +! +END PROCEDURE obj_Add4 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add5 +REAL(DFP), ALLOCATABLE :: m2(:, :) +INTEGER(I4B) :: tdof1, tdof2 +tdof1 = .tdof.obj%csr%idof +tdof2 = .tdof.obj%csr%jdof +ALLOCATE (m2(tdof1 * SIZE(nodenum), tdof2 * SIZE(nodenum))) +m2 = VALUE +CALL Add(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale) +DEALLOCATE (m2) +END PROCEDURE obj_Add5 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_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) + +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 + +DEALLOCATE (row, col) + +END PROCEDURE obj_Add6 + +!---------------------------------------------------------------------------- +! 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) +! +END PROCEDURE obj_Add7 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +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) + +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 + +DEALLOCATE (row, col) +END PROCEDURE obj_Add8 + +!---------------------------------------------------------------------------- +! 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) +END PROCEDURE obj_Add9 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +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 + +DEALLOCATE (row, col) +END PROCEDURE obj_Add10 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +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 + +DEALLOCATE (row, col) + +END PROCEDURE obj_Add11 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +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) + +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 + +DEALLOCATE (row, col) +END PROCEDURE obj_Add12 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add13 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj, kk + +row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + & spacecompo=ispacecompo, timecompo=itimecompo) + +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 + +DEALLOCATE (row, col) + +END PROCEDURE obj_Add13 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add14 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj, kk + +row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + & spacecompo=ispacecompo, timecompo=itimecompo) + +col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + & spacecompo=jspacecompo, timecompo=jtimecompo) + +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 + +DEALLOCATE (row, col) + +END PROCEDURE obj_Add14 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add15 +LOGICAL(LGT) :: sameStructure0, isSorted0 +INTEGER(I4B) :: nrow, ncol, nzmax, ierr + +sameStructure0 = Input(default=.FALSE., option=isSameStructure) + +IF (sameStructure0) THEN + obj%A = obj%A + scale * VALUE%A + RETURN +END IF + +isSorted0 = Input(default=.FALSE., option=isSorted) + +nrow = SIZE(obj, 1) +ncol = SIZE(obj, 2) +nzmax = 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) +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) +END IF + +IF (ierr .EQ. 0) THEN + CALL Errormsg( & + & "Some error occured while calling CSRMarixAPLSB.", & + & __FILE__, & + & "obj_Add15()", & + & __LINE__, & + & stderr) + STOP +END IF +END PROCEDURE obj_Add15 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 new file mode 100644 index 000000000..f16fcdd21 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_ConstructorMethods@Methods.F90 @@ -0,0 +1,382 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: This submodule contains method for constructing [[CSRMatrix_]] + +SUBMODULE(CSRMatrix_ConstructorMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Shape +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Shape +Ans = [obj%csr%nrow, obj%csr%ncol] +END PROCEDURE obj_Shape + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size +IF (PRESENT(Dims)) THEN + IF (Dims .EQ. 1) THEN + Ans = obj%csr%nrow + ELSE + Ans = obj%csr%ncol + END IF +ELSE + Ans = obj%csr%nrow * obj%csr%ncol +END IF +END PROCEDURE obj_Size + +!---------------------------------------------------------------------------- +! TotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_TotalDimension +ans = obj%tDimension +END PROCEDURE obj_TotalDimension + +!---------------------------------------------------------------------------- +! SetTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SetTotalDimension +obj%tDimension = tDimension +END PROCEDURE obj_SetTotalDimension + +!---------------------------------------------------------------------------- +! getNNZ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_getNNZ +Ans = obj%csr%nnz +END PROCEDURE obj_getNNZ + +!---------------------------------------------------------------------------- +! Allocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Allocate +CALL Initiate(obj=obj, ncol=dims(2), nrow=dims(1), matrixProp=matrixProp) +END PROCEDURE obj_Allocate + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Deallocate +CALL DEALLOCATE (obj%csr) +obj%csrOwnership = .FALSE. +obj%tDimension = 2 +obj%MatrixProp = 'UNSYM' +IF (ALLOCATED(obj%A)) DEALLOCATE (obj%A) +#ifdef USE_SuperLU +CALL SuperluDeallocate(obj) +#endif +END PROCEDURE obj_Deallocate + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate1 +CALL DEALLOCATE (obj) +obj%csrOwnership = .TRUE. +IF (PRESENT(matrixProp)) obj%matrixProp = TRIM(matrixProp) +CALL Initiate(obj=obj%csr, ncol=ncol, nrow=nrow, idof=idof, jdof=jdof, & +& nnz=nnz) +CALL Reallocate(obj%A, obj%csr%nnz) +CALL SetTotalDimension(obj, 2_I4B) +END PROCEDURE obj_Initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate2 +IF (.NOT. csr%isInitiated) THEN + CALL ErrorMSG( & + & "Instance of CSRSparsity is not Initiated!", & + & __FILE__, & + & "obj_Initiate2()", & + & __LINE__, stderr) + STOP +END IF + +CALL DEALLOCATE (obj) +obj%csrOwnership = .TRUE. +IF (PRESENT(matrixProp)) obj%matrixProp = TRIM(matrixProp) +obj%csr = csr +CALL Reallocate(obj%A, obj%csr%nnz) +CALL SetTotalDimension(obj, 2_I4B) + +END PROCEDURE obj_Initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate3 +CALL Initiate(obj=obj%csr, IA=IA, JA=JA, ncol=ncol) +obj%csrOwnership = .TRUE. +IF (PRESENT(matrixProp)) obj%matrixProp = TRIM(matrixProp) +CALL Reallocate(obj%A, SIZE(A)) +#ifdef USE_BLAS95 +CALL Copy(y=obj%A, x=A) +#else +obj%A = A +#endif +CALL SetTotalDimension(obj, 2_I4B) +CALL SetSparsity(obj) +END PROCEDURE obj_Initiate3 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate4 +CALL DEALLOCATE (obj) +obj%csr = obj2%csr +obj%tDimension = obj2%tDimension +obj%csrOwnership = obj2%csrOwnership +obj%matrixProp = obj2%matrixProp +IF (ALLOCATED(obj2%A)) obj%A = obj2%A +END PROCEDURE obj_Initiate4 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate5 +INTEGER(I4B) :: nrow, ncol, nnz, job +INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) +REAL(DFP), ALLOCATABLE :: A(:) + +job = 1 +nrow = i2 - i1 + 1 +ncol = j2 - j1 + 1 +nnz = obj2%csr%nnz +ALLOCATE (A(nnz), IA(nrow + 1), JA(nnz)) +A = 0.0; IA = 0; JA = 0 +!! calling from Sparsekit +CALL SUBMAT(job, i1, i2, j1, j2, obj2%A, obj2%csr%JA, obj2%csr%IA,& + & nrow, ncol, A, JA, IA) +!! +nnz = IA(nrow + 1) - 1 +CALL Initiate(obj=obj, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +obj%csr%ncol = ncol +DEALLOCATE (IA, JA, A) +END PROCEDURE obj_Initiate5 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate6 +CALL obj_Initiate4(obj=obj, obj2=obj2) +END PROCEDURE obj_Initiate6 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate7 +INTEGER(I4B) :: nzmax, nrow, ncol, ierr +TYPE(DOF_), POINTER :: idof, jdof +LOGICAL(LGT) :: case1, case2, isSorted0 + +nzmax = GetNNZ(obj1=obj1%csr, obj2=obj2%csr, isSorted=isSorted, op="+") + +nrow = SIZE(obj1, 1) +ncol = SIZE(obj2, 2) + +NULLIFY (idof, jdof) +idof => GetDOFPointer(obj1, 1) +jdof => GetDOFPointer(obj1, 2) + +case1 = ASSOCIATED(idof) +case2 = ASSOCIATED(jdof) + +IF (case1 .AND. case2) THEN + CALL Initiate(obj=obj, ncol=ncol, nrow=nrow, idof=idof, & + & jdof=jdof, nnz=nzmax) +ELSEIF (case1 .AND. .NOT. case2) THEN + CALL Initiate(obj=obj, ncol=ncol, nrow=nrow, idof=idof, nnz=nzmax) +ELSEIF (.NOT. case1 .AND. case2) THEN + CALL Initiate(obj=obj, ncol=ncol, nrow=nrow, jdof=jdof, nnz=nzmax) +ELSE + CALL Errormsg( & + & "Some error occured while getting idof and jdof", & + & __FILE__, & + & "obj_Initiate7()", & + & __LINE__, & + & unitno=stderr) + RETURN +END IF + +isSorted0 = Input(default=.FALSE., option=isSorted) + +IF (isSorted0) THEN + CALL obj_aplsb_sorted(nrow=nrow, ncol=ncol, & + & a=obj1%A, ja=obj1%csr%JA, ia=obj1%csr%IA, s=scale, & + & b=obj2%A, jb=obj2%csr%JA, ib=obj2%csr%IA, & + & c=obj%A, jc=obj%csr%JA, ic=obj%csr%IA, nzmax=nzmax, ierr=ierr) +ELSE + CALL obj_aplsb(nrow=nrow, ncol=ncol, & + & a=obj1%A, ja=obj1%csr%JA, ia=obj1%csr%IA, s=scale, & + & b=obj2%A, jb=obj2%csr%JA, ib=obj2%csr%IA, & + & c=obj%A, jc=obj%csr%JA, ic=obj%csr%IA, nzmax=nzmax, ierr=ierr) +END IF + +IF (ierr .NE. 0) THEN + CALL Errormsg( & + & "Some error occured while calling obj_aplsb(_sorted) method", & + & __FILE__, & + & "obj_Initiate7()", & + & __LINE__, & + & unitno=stderr) + RETURN +END IF + +END PROCEDURE obj_Initiate7 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_aplsb +! internal variables +INTEGER(I4B) :: tsize, j, ii, ka, jcol, kb, jpos, iw(ncol), k + +ierr = 0 +tsize = 0 +ic(1) = 1 +iw = 0 + +DO ii = 1, nrow + ! copy row ii to C + DO ka = ia(ii), ia(ii + 1) - 1 + tsize = tsize + 1 + jcol = ja(ka) + IF (tsize .GT. nzmax) THEN + ierr = ii + RETURN + END IF + jc(tsize) = jcol + c(tsize) = a(ka) + iw(jcol) = tsize + END DO + + DO kb = ib(ii), ib(ii + 1) - 1 + jcol = jb(kb) + jpos = iw(jcol) + IF (jpos .EQ. 0) THEN + tsize = tsize + 1 + IF (tsize .GT. nzmax) THEN + ierr = ii + RETURN + END IF + jc(tsize) = jcol + c(tsize) = s * b(kb) + iw(jcol) = tsize + ELSE + c(jpos) = c(jpos) + s * b(kb) + END IF + END DO + DO k = ic(ii), tsize + iw(jc(k)) = 0 + END DO + ic(ii + 1) = tsize + 1 +END DO + +END PROCEDURE obj_aplsb + +!---------------------------------------------------------------------------- +! CSRMatrixAPLSBSorted +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_aplsb_sorted +! internal variables +INTEGER(I4B) :: len, i, ka, kb, kc, & + & kamax, kbmax, j1, jj2 +LOGICAL(LGT) :: isok + +ierr = 0 +kc = 1 +ic(1) = kc + +DO i = 1, nrow + ka = ia(i) + kb = ib(i) + kamax = ia(i + 1) - 1 + kbmax = ib(i + 1) - 1 + + DO + isok = ka .LE. kamax .OR. kb .LE. kbmax + IF (.NOT. isok) THEN + ic(i + 1) = kc + EXIT + END IF + + IF (ka .LE. kamax) THEN + j1 = ja(ka) + ELSE + ! take j1 large enough that always jj2 .lt. j1 + j1 = ncol + 1 + END IF + + IF (kb .LE. kbmax) THEN + jj2 = jb(kb) + ELSE + ! similarly take jj2 large enough that always j1 .lt. jj2 + jj2 = ncol + 1 + END IF + + IF (j1 .EQ. jj2) THEN + c(kc) = a(ka) + s * b(kb) + jc(kc) = j1 + ka = ka + 1 + kb = kb + 1 + kc = kc + 1 + ELSE IF (j1 .LT. jj2) THEN + jc(kc) = j1 + c(kc) = a(ka) + ka = ka + 1 + kc = kc + 1 + ELSE IF (j1 .GT. jj2) THEN + jc(kc) = jj2 + c(kc) = s * b(kb) + kb = kb + 1 + kc = kc + 1 + END IF + + IF (kc .GT. nzmax) THEN + ierr = i + RETURN + END IF + END DO +END DO + +END PROCEDURE obj_aplsb_sorted + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 new file mode 100644 index 000000000..83e6b7807 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.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 +! + +!> author: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_DBCMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_ApplyDBC +INTEGER(I4B) :: i, ii, nrow +LOGICAL(LGT), ALLOCATABLE :: mask(:) +REAL(DFP), ALLOCATABLE :: diag_entries(:) + +ASSOCIATE (IA => obj%csr%IA, JA => obj%csr%JA, A => obj%A) + + nrow = SIZE(obj, 1) + ALLOCATE (mask(nrow)) + mask = .FALSE. + mask(dbcPtrs) = .TRUE. + + ! make row zeros + + DO CONCURRENT(i=1:SIZE(dbcPtrs)) + ii = dbcPtrs(i) + A(IA(ii):IA(ii + 1) - 1) = 0.0_DFP + END DO + + DO CONCURRENT(i=1:nrow) + DO ii = IA(i), IA(i + 1) - 1 + IF (mask(JA(ii))) THEN + A(ii) = 0.0_DFP + END IF + END DO + END DO + + IF (obj%csr%isDiagStored) THEN + A(obj%csr%idiag(dbcPtrs)) = 1.0_DFP + ELSE + CALL GetDiagonal(obj=obj, diag=diag_entries) + A(obj%csr%idiag(dbcPtrs)) = 1.0_DFP + DEALLOCATE (diag_entries) + END IF + + DEALLOCATE (mask) + +END ASSOCIATE + +END PROCEDURE csrMat_ApplyDBC + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 new file mode 100644 index 000000000..fec9c27a9 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_DiagonalScalingMethods@Methods.F90 @@ -0,0 +1,166 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(CSRMatrix_DiagonalScalingMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! DiagonalScaling +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrmat_DiagonalScaling_1 +REAL(DFP), ALLOCATABLE :: diag_(:) +CALL getDiagonal(obj=obj, diag=diag_) +CALL DiagonalScaling(obj=obj, diag=diag_, OPERATOR=OPERATOR, side=side) +IF (ALLOCATED(diag_)) DEALLOCATE (diag_) +END PROCEDURE csrmat_DiagonalScaling_1 + +!---------------------------------------------------------------------------- +! DiagonalScaling +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrmat_DiagonalScaling_2 +INTEGER(I4B) :: ii, jj +CHARACTER(:), ALLOCATABLE :: op +REAL(DFP) :: avar + +IF (PRESENT(OPERATOR)) THEN + op = OPERATOR +ELSE + op = 'SQRT' +END IF + +SELECT CASE (TRIM(side)) + +CASE ('LEFT', 'Left', 'left') + + SELECT CASE (TRIM(op)) + + CASE ('SQRT') + + DO ii = 1, obj%csr%nrow + + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + IF (ABS(diag(ii)) .GT. zero) THEN + obj%A(jj) = obj%A(jj) / SQRT(ABS(diag(ii))) + END IF + + END DO + END DO + + CASE ('NONE') + ! + DO ii = 1, obj%csr%nrow + ! + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + ! + obj%A(jj) = obj%A(jj) / diag(ii) + ! + END DO + END DO + ! + END SELECT + ! + ! + ! +CASE ('RIGHT', 'Right', 'right') + ! + ! + SELECT CASE (TRIM(op)) + ! + ! + ! + CASE ('SQRT') + ! + DO ii = 1, obj%csr%nrow + ! + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + ! + obj%A(jj) = obj%A(jj) / SQRT(ABS(diag(obj%csr%JA(jj)))) + ! + END DO + END DO + ! + ! + ! + CASE ('NONE') + ! + DO ii = 1, obj%csr%nrow + ! + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + ! + obj%A(jj) = obj%A(jj) / diag(obj%csr%JA(jj)) + ! + END DO + END DO + ! + END SELECT + ! + ! + ! +CASE ('BOTH', 'Both', 'both') + ! + ! + SELECT CASE (TRIM(op)) + ! + ! + ! + CASE ('SQRT') + ! + DO ii = 1, obj%csr%nrow + ! + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + ! + avar = ABS(diag(ii) * diag(obj%csr%JA(jj))) + + IF (avar .GT. zero) THEN + obj%A(jj) = obj%A(jj) / SQRT(avar) + END IF + ! + END DO + END DO + ! + ! + ! + CASE ('NONE') + ! + DO ii = 1, obj%csr%nrow + ! + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + ! + obj%A(jj) = obj%A(jj) / diag(ii) / diag(obj%csr%JA(jj)) + ! + END DO + END DO + ! + END SELECT + ! + ! + ! +END SELECT +! +! +! +END PROCEDURE csrmat_DiagonalScaling_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 new file mode 100644 index 000000000..44e431b33 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockColMethods@Methods.F90 @@ -0,0 +1,318 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!! authors: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_GetBlockColMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn1 +INTEGER(I4B) :: jj, ii, c(3), row_start, row_end +REAL(DFP) :: alpha + !! +#ifdef DEBUG_VER + !! + !!check + !! +IF (SIZE(VALUE) .LT. obj%csr%nrow) THEN + CALL ErrorMSG( & + & Msg="SIZE of column vector is less than the number of row & + & in sparse matrix", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockColumn1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF (icolumn .GT. SIZE(obj, 2)) THEN + CALL ErrorMSG( & + & Msg="icolumn is out of Bound", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockColumn1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF (ivar .GT. (.tNames.obj%csr%idof)) THEN + CALL ErrorMSG( & + & Msg="ivar is out of Bound", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockColumn1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF ((obj.StorageFMT.ivar) .NE. FMT_DOF) THEN + CALL ErrorMSG( & + & Msg="For this rotuine storage format should FMT_DOF", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockColumn1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! + !! start, end, stride + !! +c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFStartIndex.ivar)) +row_start = c(1) ! start +c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFEndIndex.ivar)) +row_end = c(2) ! end + !! +IF (PRESENT(addContribution)) THEN + !! + !! + !! + alpha = INPUT(Default=1.0_DFP, Option=scale) + !! + DO ii = row_start, row_end + VALUE(ii) = 0.0_DFP + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + IF (obj%csr%JA(jj) .EQ. icolumn) THEN + VALUE(ii) = VALUE(ii) + alpha * obj%A(jj) + EXIT + END IF + END DO + END DO + !! + !! + !! +ELSE + !! + DO ii = row_start, row_end + VALUE(ii) = 0.0_DFP + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + IF (obj%csr%JA(jj) .EQ. icolumn) THEN + VALUE(ii) = obj%A(jj) + EXIT + END IF + END DO + END DO + !! +END IF + !! +END PROCEDURE csrMat_getBlockColumn1 + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn1b +INTEGER(I4B) :: ii, jj, kk, c(3), row_start, row_end +REAL(DFP) :: alpha + !! + !! start, end, stride + !! +c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFStartIndex.ivar)) +row_start = c(1) ! start +c = getNodeLoc(obj=obj%csr%idof, idof=(obj%csr%idof.DOFEndIndex.ivar)) +row_end = c(2) ! end + !! +IF (PRESENT(addContribution)) THEN + !! + alpha = INPUT(Default=1.0_DFP, Option=scale) + !! + DO ii = row_start, row_end + VALUE(ii) = 0.0_DFP + DO kk = 1, SIZE(icolumn) + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + IF (obj%csr%JA(jj) .EQ. icolumn(kk)) THEN + VALUE(ii) = VALUE(ii) + alpha * obj%A(jj) + EXIT + END IF + END DO + END DO + END DO + !! +ELSE + !! + DO ii = row_start, row_end + VALUE(ii) = 0.0_DFP + DO kk = 1, SIZE(icolumn) + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + IF (obj%csr%JA(jj) .EQ. icolumn(kk)) THEN + VALUE(ii) = obj%A(jj) + EXIT + END IF + END DO + END DO + END DO + !! +END IF + !! +END PROCEDURE csrMat_getBlockColumn1b + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn2 + !! +CALL getBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & idof=idof), & + & VALUE=VALUE, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getBlockColumn2 + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn3 + !! +CALL getBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(& + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & idof=idof), & + & VALUE=VALUE, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getBlockColumn3 + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn4 + !! +CALL getBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(& + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & VALUE=VALUE, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getBlockColumn4 + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn5 + !! +CALL getBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(& + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & VALUE=VALUE, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getBlockColumn5 + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn6 + !! +CALL getBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(& + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & VALUE=VALUE, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getBlockColumn6 + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn7 + !! +CALL getBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(& + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & VALUE=VALUE, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getBlockColumn7 + +!---------------------------------------------------------------------------- +! getBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockColumn8 + !! +CALL getBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(& + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & VALUE=VALUE, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getBlockColumn8 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 new file mode 100644 index 000000000..ad16465ba --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetBlockRowMethods@Methods.F90 @@ -0,0 +1,291 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!! authors: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_GetBlockRowMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow1 +INTEGER(I4B) :: jj, c(3), col_start, col_end +REAL(DFP) :: alpha + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (SIZE(value) .LT. obj%csr%ncol) THEN + CALL ErrorMSG( & + & Msg="SIZE of row vector should be less & + & than the number of col & + & in sparse matrix", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockRow1", Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF (irow .GT. SIZE(obj, 1)) THEN + CALL ErrorMSG( & + & Msg="irow is out of Bound", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockRow1", Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF (jvar .GT. (.tNames.obj%csr%jdof)) THEN + CALL ErrorMSG( & + & Msg="jVar is out of Bound", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockRow1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF ((.StorageFMT.obj) .NE. FMT_DOF) THEN + CALL ErrorMSG( & + & Msg="For this rotuine storage format should FMT_DOF", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getBlockRow1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! + !! start, end, stride of idof + !! +c = getNodeLoc(obj=obj%csr%jdof, idof=(obj%csr%jdof.DOFStartIndex.jvar)) +col_start = c(1) ! start +c = getNodeLoc(obj%csr%jdof, (obj%csr%jdof.DOFEndIndex.jvar)) +col_end = c(2) ! end + !! + !! + !! +IF (PRESENT(addContribution)) THEN + !! + alpha = INPUT(Default=1.0_DFP, Option=scale) + !! + DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 + IF ((jj .GE. col_start) .AND. (jj .LE. col_end)) & + & value(obj%csr%JA(jj)) = value(obj%csr%JA(jj)) + alpha * obj%A(jj) + END DO + !! + !! + !! +ELSE + !! + value = 0.0_DFP + !! + DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 + IF ((jj .GE. col_start) .AND. jj .LE. col_end) & + & value(obj%csr%JA(jj)) = obj%A(jj) + END DO + !! +END IF + !! +END PROCEDURE csrMat_getBlockRow1 + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow1b +INTEGER(I4B) :: ii, jj, c(3), col_start, col_end +REAL(DFP) :: alpha + !! + !! start, end, stride of idof + !! +c = getNodeLoc(obj=obj%csr%jdof, idof=(obj%csr%jdof.DOFStartIndex.jvar)) +col_start = c(1) ! start +c = getNodeLoc(obj%csr%jdof, (obj%csr%jdof.DOFEndIndex.jvar)) +col_end = c(2) ! end + !! + !! + !! +IF (PRESENT(addContribution)) THEN + !! + alpha = INPUT(Default=1.0_DFP, Option=scale) + !! + DO ii = 1, size(irow) + DO jj = obj%csr%IA(irow(ii)), obj%csr%IA(irow(ii) + 1) - 1 + IF ((jj .GE. col_start) .AND. (jj .LE. col_end)) & + & value(obj%csr%JA(jj)) = value(obj%csr%JA(jj)) + alpha * obj%A(jj) + END DO + END DO + !! + !! + !! +ELSE + !! + value = 0.0_DFP + !! + DO ii = 1, size(irow) + DO jj = obj%csr%IA(irow(ii)), obj%csr%IA(irow(ii) + 1) - 1 + IF ((jj .GE. col_start) .AND. jj .LE. col_end) & + & value(obj%csr%JA(jj)) = obj%A(jj) + END DO + END DO + !! +END IF + !! +END PROCEDURE csrMat_getBlockRow1b + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow2 +CALL GetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & idof=idof), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getBlockRow2 + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow3 +CALL GetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc(& + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & idof=idof), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getBlockRow3 + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow4 +CALL GetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getBlockRow4 + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow5 +CALL GetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getBlockRow5 + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow6 +CALL GetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getBlockRow6 + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow7 +CALL GetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getBlockRow7 + +!---------------------------------------------------------------------------- +! getBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getBlockRow8 +CALL GetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getBlockRow8 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 new file mode 100644 index 000000000..59456b075 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetColMethods@Methods.F90 @@ -0,0 +1,238 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!! authors: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_GetColMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn1 +INTEGER(I4B) :: i, j +REAL(DFP) :: alpha + !! +#ifdef DEBUG_VER + !! +IF (SIZE(value) .LT. obj%csr%nrow .OR. iColumn .GT. SIZE(obj, 2)) THEN + CALL ErrorMSG( & + & Msg="SIZE of column vector should be same as number of & + & rows in sparse matrix", & + & File="CSRMatrix_Method@getMethod.F90", & + & Routine="csrMat_getColumn1", Line=__LINE__, UnitNo=stdout) + RETURN +END IF +#endif + !! +IF (PRESENT(addContribution)) THEN + !! + alpha = INPUT(default=1.0_DFP, option=scale) + !! + DO i = 1, obj%csr%nrow + !! + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + !! + IF (obj%csr%JA(j) .EQ. iColumn) THEN + value(i) = value(i) + alpha * obj%A(j) + EXIT + END IF + !! + END DO + !! + END DO + !! +ELSE + !! + DO i = 1, obj%csr%nrow + !! + value(i) = 0.0_DFP + !! + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + IF (obj%csr%JA(j) .EQ. iColumn) THEN + value(i) = obj%A(j) + EXIT + END IF + END DO + !! + END DO + !! +END IF + !! +END PROCEDURE csrMat_getColumn1 + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn1b +INTEGER(I4B) :: i, j, k +REAL(DFP) :: alpha + !! + !! + !! +IF (PRESENT(addContribution)) THEN + !! + alpha = INPUT(default=1.0_DFP, option=scale) + !! + DO i = 1, obj%csr%nrow + DO k = 1, size(iColumn) + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + IF (obj%csr%JA(j) .EQ. iColumn(k)) THEN + value(i) = value(i) + alpha * obj%A(j) + EXIT + END IF + END DO + END DO + END DO + !! +ELSE + !! + DO i = 1, obj%csr%nrow + value(i) = 0.0_DFP + DO k = 1, size(iColumn) + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + IF (obj%csr%JA(j) .EQ. iColumn(k)) THEN + value(i) = obj%A(j) + EXIT + END IF + END DO + END DO + END DO + !! +END IF + !! +END PROCEDURE csrMat_getColumn1b + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn2 +CALL GetColumn(obj=obj, & + & iColumn=getNodeLoc(obj=obj%csr%jdof, idof=idof, nodenum=nodenum), & + & value=value, scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getColumn2 + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn3 +CALL GetColumn(obj=obj, & + & iColumn=getNodeLoc(obj=obj%csr%jdof, & + & ivar=ivar, idof=idof, nodenum=nodenum), & + & value=value, scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getColumn3 + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn4 +CALL GetColumn(obj=obj, & + & iColumn=getNodeLoc(obj=obj%csr%jdof, & + & ivar=ivar, spacecompo=spacecompo, & + & timecompo=timecompo, nodenum=nodenum), & + & value=value, scale=scale, & + & addContribution=addContribution) +END PROCEDURE csrMat_getColumn4 + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn5 + !! +CALL GetColumn(obj=obj, & + & iColumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getColumn5 + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn6 + !! +CALL GetColumn(obj=obj, & + & iColumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getColumn6 + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn7 + !! +CALL GetColumn(obj=obj, & + & iColumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo, & + & nodenum=nodenum), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getColumn7 + +!---------------------------------------------------------------------------- +! getColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getColumn8 + !! +CALL GetColumn(obj=obj, & + & iColumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo, & + & nodenum=nodenum), & + & value=value, & + & scale=scale, & + & addContribution=addContribution) + !! +END PROCEDURE csrMat_getColumn8 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 new file mode 100644 index 000000000..d87d4cf31 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 @@ -0,0 +1,522 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!! authors: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_GetMethods) Methods +USE CSRSparsity_Method +USE ConvertUtility +USE InputUtility +USE BaseType, ONLY: DOF_ +USE DOF_GetMethods +USE CSRMatrix_GetMethods +USE CSRMatrix_SetMethods +USE ErrorHandling +USE GlobalData, ONLY: DofToNodes, NodesToDOF, FMT_NODES, FMT_DOF, stderr +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetIA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIA +ans = GetIA(obj%csr, irow) +END PROCEDURE obj_GetIA + +!---------------------------------------------------------------------------- +! GetJA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetJA +ans = GetJA(obj%csr, indx) +END PROCEDURE obj_GetJA + +!---------------------------------------------------------------------------- +! GetSingleValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSingleValue +ans = obj%A(indx) +END PROCEDURE obj_GetSingleValue + +!---------------------------------------------------------------------------- +! GetSeveralValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSeveralValue +INTEGER(I4B) :: ii, tsize +tsize = SIZE(indx) +DO ii = 1, tsize; ans(ii) = obj%A(indx(ii)); END DO +END PROCEDURE obj_GetSeveralValue + +!---------------------------------------------------------------------------- +! GetStorageFMT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetStorageFMT +IF (i .EQ. 1) THEN + ans = obj%csr%idof%storageFMT +ELSE + ans = obj%csr%jdof%storageFMT +END IF +END PROCEDURE obj_GetStorageFMT + +!---------------------------------------------------------------------------- +! GetMatrixProp +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMatrixProp +ans = TRIM(obj%matrixProp) +END PROCEDURE obj_GetMatrixProp + +!---------------------------------------------------------------------------- +! GetDOFPointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetDOFPointer +IF (i .EQ. 1) THEN + ans => obj%csr%idof +ELSE + ans => obj%csr%jdof +END IF +END PROCEDURE obj_GetDOFPointer + +!---------------------------------------------------------------------------- +! isSquare +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isSquare +IF (obj%csr%nrow .EQ. obj%csr%ncol) THEN + ans = .TRUE. +ELSE + ans = .FALSE. +END IF +END PROCEDURE obj_isSquare + +!---------------------------------------------------------------------------- +! isRectangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isRectangle +IF (obj%csr%nrow .EQ. obj%csr%ncol) THEN + ans = .FALSE. +ELSE + ans = .TRUE. +END IF +END PROCEDURE obj_isRectangle + +!---------------------------------------------------------------------------- +! GetColNumber +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetColNumber +ans = GetColNumber(obj%csr, indx) +END PROCEDURE obj_GetColNumber + +!---------------------------------------------------------------------------- +! GetColIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetColIndex +ans = GetColIndex(obj%csr, irow) +END PROCEDURE obj_GetColIndex + +!---------------------------------------------------------------------------- +! startColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_startColumn +ans = obj%csr.startColumn.irow +END PROCEDURE obj_startColumn + +!---------------------------------------------------------------------------- +! endColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_endColumn +ans = obj%csr.endColumn.irow +END PROCEDURE obj_endColumn + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get0 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj + +row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum) +col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum) +VALUE = 0.0_DFP +DO ii = 1, SIZE(row) + DO jj = 1, SIZE(col) + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & + & icolumn=col(jj)) + END DO +END DO + +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +END PROCEDURE obj_Get0 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get1 +REAL(DFP) :: m2(SIZE(VALUE, 1), SIZE(VALUE, 2)) +INTEGER(I4B) :: tdof, nns, myfmt + +CALL GetValue(obj=obj, nodenum=nodenum, VALUE=m2, nrow=nrow, ncol=ncol) + +myfmt = GetStorageFMT(obj, 1) + +IF (myfmt .EQ. storageFMT) THEN + VALUE(1:nrow, 1:ncol) = m2(1:nrow, 1:ncol) + RETURN +END IF + +tdof = .tdof. (obj%csr%idof) +nns = SIZE(nodenum) + +SELECT CASE (storageFMT) + +CASE (FMT_NODES) + + CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), & + Conversion=DOFToNodes, nns=nns, tDOF=tdof) + +CASE (FMT_DOF) + + CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), & + Conversion=NodesToDOF, nns=nns, tDOF=tdof) + +END SELECT + +END PROCEDURE obj_Get1 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get2 +INTEGER(I4B) :: j + +! VALUE = 0.0_DFP +DO j = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 + IF (obj%csr%JA(j) .EQ. icolumn) THEN + VALUE = obj%A(j) + EXIT + END IF +END DO + +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 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get3 +INTEGER(I4B) :: irow, icolumn +irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, idof=iDOF) +icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, idof=jDOF) +CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) +END PROCEDURE obj_Get3 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get4 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj + +row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar) +col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar) + +nrow = SIZE(row) +ncol = SIZE(col) + +DO ii = 1, nrow + DO jj = 1, ncol + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & + icolumn=col(jj)) + END DO +END DO + +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +END PROCEDURE obj_Get4 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get5 +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 GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) +END PROCEDURE obj_Get5 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get6 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj + +row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof) +col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof) + +nrow = SIZE(row) +ncol = SIZE(col) + +DO ii = 1, nrow + DO jj = 1, ncol + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & + icolumn=col(jj)) + END DO +END DO + +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +END PROCEDURE obj_Get6 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! 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 +CLASS(DOF_), POINTER :: dof_obj +LOGICAL(LGT) :: problem + +! 1 ivar +! 2 ispacecompo +! 3 itimecompo +! 4 jvar +! 5 jspacecompo +! 6 jtimecompo + +IF (PRESENT(ierr)) ierr = 0 + +myindx(1, 1) = Input(default=1, option=ivar1) +myindx(2, 1) = Input(default=1, option=ispacecompo1) +myindx(3, 1) = Input(default=1, option=itimecompo1) +myindx(4, 1) = Input(default=1, option=jvar1) +myindx(5, 1) = Input(default=1, option=jspacecompo1) +myindx(6, 1) = Input(default=1, option=jtimecompo1) + +myindx(1, 2) = Input(default=1, option=ivar2) +myindx(2, 2) = Input(default=1, option=ispacecompo2) +myindx(3, 2) = Input(default=1, option=itimecompo2) +myindx(4, 2) = Input(default=1, option=jvar2) +myindx(5, 2) = Input(default=1, option=jspacecompo2) +myindx(6, 2) = Input(default=1, option=jtimecompo2) + +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)) +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)) +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)) +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)) +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) + +END PROCEDURE obj_Get8 + +!---------------------------------------------------------------------------- +! CSR2CSRGetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSR2CSR_Get_Master +INTEGER(I4B) :: ii, jj +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) + END DO +END DO + +END PROCEDURE CSR2CSR_Get_Master + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 new file mode 100644 index 000000000..f925c4771 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetRowMethods@Methods.F90 @@ -0,0 +1,195 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +! authors: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_GetRowMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow1 +INTEGER(I4B) :: a, b +REAL(DFP) :: alpha + +#ifdef DEBUG_VER +IF (SIZE(VALUE) .LT. obj%csr%ncol .OR. irow .GT. SIZE(obj, 1)) THEN + CALL ErrorMSG( & + & Msg="SIZE of row vector should be same as number of col & + & in sparse matrix or irow is out of bound", & + & File="CSRMatrix_Method@GetMethod.F90", & + & Routine="obj_GetRow1", Line=__LINE__, UnitNo=stdout) + RETURN +END IF +#endif + +a = obj%csr%IA(irow) +b = obj%csr%IA(irow + 1) - 1 + +IF (PRESENT(addContribution)) THEN + alpha = INPUT(Default=1.0_DFP, Option=scale) + VALUE(obj%csr%JA(a:b)) = VALUE(obj%csr%JA(a:b)) + alpha * obj%A(a:b) +ELSE + VALUE = 0.0_DFP + VALUE(obj%csr%JA(a:b)) = obj%A(a:b) +END IF + +END PROCEDURE obj_GetRow1 + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow1b +INTEGER(I4B) :: a, b, ii +REAL(DFP) :: alpha + +IF (PRESENT(addContribution)) THEN + alpha = INPUT(Default=1.0_DFP, Option=scale) + DO ii = 1, SIZE(irow) + a = obj%csr%IA(irow(ii)) + b = obj%csr%IA(irow(ii) + 1) - 1 + VALUE(obj%csr%JA(a:b)) = VALUE(obj%csr%JA(a:b)) + alpha * obj%A(a:b) + END DO +ELSE + VALUE = 0.0_DFP + DO ii = 1, SIZE(irow) + a = obj%csr%IA(irow(ii)) + b = obj%csr%IA(irow(ii) + 1) - 1 + VALUE(obj%csr%JA(a:b)) = obj%A(a:b) + END DO +END IF +END PROCEDURE obj_GetRow1b + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow2 +CALL GetRow(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & idof=idof, & + & nodenum=nodenum), & + & VALUE=VALUE, scale=scale, addContribution=addContribution) +END PROCEDURE obj_GetRow2 + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow3 +CALL GetRow(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & ivar=ivar, & + & idof=idof, & + & nodenum=nodenum), & + & VALUE=VALUE, scale=scale, addContribution=addContribution) +END PROCEDURE obj_GetRow3 + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow4 +CALL GetRow(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & ivar=ivar, & + & spacecompo=spacecompo,& + & timecompo=timecompo, & + & nodenum=nodenum), & + & VALUE=VALUE, scale=scale, & + & addContribution=addContribution) +END PROCEDURE obj_GetRow4 + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow5 +CALL GetRow(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & ivar=ivar, & + & spacecompo=spacecompo,& + & timecompo=timecompo, & + & nodenum=nodenum), & + & VALUE=VALUE, scale=scale, & + & addContribution=addContribution) +END PROCEDURE obj_GetRow5 + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow6 +CALL GetRow(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & ivar=ivar, & + & spacecompo=spacecompo,& + & timecompo=timecompo, & + & nodenum=nodenum), & + & VALUE=VALUE, scale=scale, & + & addContribution=addContribution) +END PROCEDURE obj_GetRow6 + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow7 +CALL GetRow(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & ivar=ivar, & + & spacecompo=spacecompo,& + & timecompo=timecompo, & + & nodenum=nodenum), & + & VALUE=VALUE, scale=scale, & + & addContribution=addContribution) +END PROCEDURE obj_GetRow7 + +!---------------------------------------------------------------------------- +! GetRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetRow8 +CALL GetRow(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & ivar=ivar, & + & spacecompo=spacecompo,& + & timecompo=timecompo, & + & nodenum=nodenum), & + & VALUE=VALUE, scale=scale, & + & addContribution=addContribution) +END PROCEDURE obj_GetRow8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 new file mode 100644 index 000000000..57773f75f --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 @@ -0,0 +1,124 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(CSRMatrix_GetSubMatrixMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetSubMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSubMatrix1 +LOGICAL(LGT), ALLOCATABLE :: selectCol(:) +INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), & +& icol, jj +REAL(DFP) :: aval +TYPE(String) :: astr + +nnz = GetNNZ(obj=obj) +nrow = SIZE(obj, 1) +ncol = SIZE(obj, 2) + +CALL Reallocate(selectCol, ncol) + +selectCol = .FALSE. + +nn = SIZE(cols) +DO ii = 1, nn + jj = cols(ii) + IF (jj .GT. ncol) THEN + astr = "Error cols( "//tostring(ii)//") is greater than "// & + & "ncol = "//tostring(ncol) + CALL ErrorMSG( & + & astr%chars(), & + & "CSRMatrix_GetSubMatrixMethods@Methods.F90", & + & "obj_GetSubMatrix1()", & + & __LINE__, stderr) + STOP + END IF + selectCol(jj) = .TRUE. +END DO + +submat_nnz = 0 +DO irow = 1, nrow + colIndx = GetColIndex(obj=obj, irow=irow) + DO ii = colIndx(1), colIndx(2) + icol = GetColNumber(obj, ii) + IF (selectCol(icol)) submat_nnz = submat_nnz + 1 + END DO +END DO + +CALL Reallocate(subIndices, submat_nnz) +CALL Initiate(obj=submat, ncol=ncol, nrow=nrow, nnz=submat_nnz) + +submat_nnz = 1 +CALL SetIA(obj=submat, irow=1, VALUE=submat_nnz) + +DO irow = 1, nrow + colIndx = GetColIndex(obj=obj, irow=irow) + jj = 0 + DO ii = colIndx(1), colIndx(2) + icol = 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) + 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) + +END PROCEDURE obj_GetSubMatrix1 + +!---------------------------------------------------------------------------- +! GetSubMatrix1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSubMatrix2 +LOGICAL(LGT) :: isok + +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 + +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) + +END PROCEDURE obj_GetSubMatrix2 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 new file mode 100644 index 000000000..ab770b532 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_ILUMethods@Methods.F90 @@ -0,0 +1,486 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_ILUMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getILUT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getILUT1 +INTEGER(I4B) :: nnz, s(2), ierr, IWK +INTEGER(I4B), ALLOCATABLE :: JW(:) +REAL(DFP), ALLOCATABLE :: W(:) + +s = SHAPE(obj) +nnz = getNNZ(obj) +ALLOCATE (JW(2 * s(1)), W(s(1) + 1)) +CALL Reallocate(JU, s(1)) +IWK = 2 * (lfil + 1) * s(1) +! +CALL Reallocate(ALU, IWK, JLU, IWK) +! +CALL ILUT(s(1), obj%A, obj%csr%JA, obj%csr%IA, lfil, droptol, & + & ALU, JLU, JU, IWK, W, JW, ierr) +! +SELECT CASE (ierr) +CASE (1:) + CALL ErrorMSG( & + & "zero pivot encountered at step number = "//tostring(ierr), & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUT1()", & + & __LINE__, stderr) + STOP +CASE (-1) + CALL ErrorMSG( & + & "Input matrix may be wrong. (The elimination process has generated a & + & row in L or U whose length is .gt. n.)", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUT1()", & + & __LINE__, stderr) + STOP +CASE (-2) + CALL ErrorMSG( & + & "The matrix L overflows the array ALU", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUT1()", & + & __LINE__, stderr) + STOP +CASE (-3) + CALL ErrorMSG( & + & "The matrix U overflows the array ALU", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUT1()", & + & __LINE__, stderr) + STOP +CASE (-4) + CALL ErrorMSG( & + & "Illegal value for lfil.", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUT1()", & + & __LINE__, stderr) + STOP +CASE (-5) + CALL ErrorMSG( & + & "zero row encountered", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUT1()", & + & __LINE__, stderr) + STOP +END SELECT +DEALLOCATE (JW, W) +END PROCEDURE csrMat_getILUT1 + +!---------------------------------------------------------------------------- +! getILUT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getILUT2 +REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) +INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) +INTEGER(I4B) :: s(2), ii, nnz + +CALL csrMat_getILUT1(obj=obj, ALU=ALU, JLU=JLU, JU=JU, lfil=lfil, & + & droptol=droptol) +s = SHAPE(obj) +DO ii = 1, s(1) + IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE + ALU(ii) = 1.0 / ALU(ii) +END DO +nnz = JLU(s(1) + 1) +CALL Reallocate(WK, s(1), IWK, s(1) + 1) +CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) +CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) +nnz = IA(s(1) + 1) - 1 +CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) +END PROCEDURE csrMat_getILUT2 + +!---------------------------------------------------------------------------- +! getILUTP +!---------------------------------------------------------------------------- + +! subroutine ilutp(n,a,ja,ia,lfil,droptol,permtol,mbloc,alu, +! jlu,ju,iwk,w,jw,iperm,ierr) + +MODULE PROCEDURE csrMat_getILUTP1 +INTEGER(I4B) :: nnz, s(2), ierr, IWK +! INTEGER( I4B ):: k +INTEGER(I4B), ALLOCATABLE :: JW(:) +REAL(DFP), ALLOCATABLE :: W(:) + +s = SHAPE(obj) +nnz = getNNZ(obj) +ALLOCATE (JW(2 * s(1)), W(s(1))) +CALL Reallocate(JU, s(1), IPERM, 2 * s(1)) +IWK = nnz + INT(nnz / 10, kind=I4B) +! +DO + CALL Reallocate(ALU, IWK, JLU, IWK) + CALL ILUTP(s(1), obj%A, obj%csr%JA, obj%csr%IA, lfil, droptol, & + & permtol, mbloc, ALU, JLU, JU, IWK, W, JW, IPERM, ierr) + IF (ierr .EQ. -2 .OR. ierr .EQ. -3) THEN + IWK = IWK + INT(2 * IWK / 10, kind=I4B) + ELSE + EXIT + END IF +END DO +! +SELECT CASE (ierr) +CASE (-1) + CALL ErrorMSG( & + & "Input matrix may be wrong. (The elimination process has generated a & + & row in L or U whose length is .gt. n.)", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUTP1()", & + & __LINE__, stderr) + STOP +CASE (-2) + CALL ErrorMSG( & + & "The matrix L overflows the array AL", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUTP1()", & + & __LINE__, stderr) + STOP +CASE (-3) + CALL ErrorMSG( & + & "The matrix U overflows the array ALU", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUTP1()", & + & __LINE__, stderr) + STOP +CASE (-4) + CALL ErrorMSG( & + & "Illegal value for lfil.", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUTP1()", & + & __LINE__, stderr) + STOP +CASE (-5) + CALL ErrorMSG( & + & "zero row encountered", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUTP1()", & + & __LINE__, stderr) + STOP +END SELECT +! +! DO k=obj%csr%IA(1), obj%csr%IA(s(1)+1)-1 +! obj%csr%JA(k) = IPERM(obj%csr%JA(k)) +! END DO +! +DEALLOCATE (JW, W) +END PROCEDURE csrMat_getILUTP1 + +!---------------------------------------------------------------------------- +! getILUTP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getILUTP2 +REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) +INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) +INTEGER(I4B) :: s(2), ii, nnz + +CALL csrMat_getILUTP1(obj, ALU, JLU, JU, lfil, droptol, permtol, mbloc, & + & IPERM) +s = SHAPE(obj) +DO ii = 1, s(1) + IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE + ALU(ii) = 1.0 / ALU(ii) +END DO +nnz = JLU(s(1) + 1) +CALL Reallocate(WK, s(1), IWK, s(1) + 1) +CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) +CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) +nnz = IA(s(1) + 1) - 1 +CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) +END PROCEDURE csrMat_getILUTP2 + +!---------------------------------------------------------------------------- +! getILUD +!---------------------------------------------------------------------------- + +!> subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr) + +MODULE PROCEDURE csrMat_getILUD1 +INTEGER(I4B) :: nnz, s(2), ierr, IWK, k, iter +INTEGER(I4B), ALLOCATABLE :: JW(:) +REAL(DFP), ALLOCATABLE :: W(:) +INTEGER(I4B), PARAMETER :: maxIter = 5 +! +s = SHAPE(obj) +nnz = getNNZ(obj) +ALLOCATE (JW(2 * s(1)), W(2 * s(1))) +CALL Reallocate(JU, s(1)) +IWK = nnz + INT(nnz / 10, kind=I4B) +! +DO iter = 1, maxIter + CALL Reallocate(ALU, IWK, JLU, IWK) + CALL ILUD(s(1), obj%A, obj%csr%JA, obj%csr%IA, alpha, droptol, & + & ALU, JLU, JU, IWK, W, JW, ierr) + IF (ierr .EQ. -2) THEN + IWK = IWK + INT(IWK / 10, kind=I4B) + ELSE + EXIT + END IF +END DO +! +SELECT CASE (ierr) +CASE (1:) + CALL ErrorMSG( & + & "zero pivot encountered at step number = "//tostring(ierr), & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUD1()", & + & __LINE__, stderr) + STOP +CASE (-1) + CALL ErrorMSG( & + & "Input matrix may be wrong. (The elimination process has generated a & + & row in L or U whose length is .gt. n.)", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUD1()", & + & __LINE__, stderr) + STOP +CASE (-2) + CALL ErrorMSG( & + & "The matrix L overflows the array AL", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUD1()", & + & __LINE__, stderr) + STOP +CASE (-3) + CALL ErrorMSG( & + & "zero row encountered", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUD1()", & + & __LINE__, stderr) + STOP +END SELECT +DEALLOCATE (JW, W) +END PROCEDURE csrMat_getILUD1 + +!---------------------------------------------------------------------------- +! getILUD +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getILUD2 +REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) +INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) +INTEGER(I4B) :: s(2), ii, nnz + +CALL csrMat_getILUD1(obj, ALU, JLU, JU, alpha, droptol) +s = SHAPE(obj) +DO ii = 1, s(1) + IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE + ALU(ii) = 1.0 / ALU(ii) +END DO +nnz = JLU(s(1) + 1) +CALL Reallocate(WK, s(1), IWK, s(1) + 1) +CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) +CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) +nnz = IA(s(1) + 1) - 1 +CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) +END PROCEDURE csrMat_getILUD2 + +!---------------------------------------------------------------------------- +! getILUDP +!---------------------------------------------------------------------------- + +!> subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr) + +MODULE PROCEDURE csrMat_getILUDP1 +INTEGER(I4B) :: nnz, s(2), ierr, IWK, k +INTEGER(I4B), ALLOCATABLE :: JW(:) +REAL(DFP), ALLOCATABLE :: W(:) +! +s = SHAPE(obj) +nnz = getNNZ(obj) +ALLOCATE (JW(2 * s(1)), W(2 * s(1))) +CALL Reallocate(JU, s(1), IPERM, 2 * s(1)) +IWK = 1.1 * nnz +! +DO + CALL Reallocate(ALU, IWK, JLU, IWK) + CALL ILUDP(s(1), obj%A, obj%csr%JA, obj%csr%IA, alpha, droptol, permtol,& + & mbloc, ALU, JLU, JU, IWK, W, JW, IPERM, ierr) + IF (ierr .EQ. -2 .OR. ierr .EQ. -3) THEN + IWK = 1.2 * IWK + ELSE + EXIT + END IF +END DO +! +SELECT CASE (ierr) +CASE (-1) + CALL ErrorMSG( & + & "Input matrix may be wrong. (The elimination process has generated a & + & row in L or U whose length is .gt. n.)", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUDP1()", & + & __LINE__, stderr) + STOP +CASE (-2) + CALL ErrorMSG( & + & "The L/U matrix overflows the arrays ALU,JLU", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUDP1()", & + & __LINE__, stderr) + STOP +CASE (-3) + CALL ErrorMSG( & + & "zero row encountered", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUDP1()", & + & __LINE__, stderr) + STOP +END SELECT +DEALLOCATE (JW, W) +END PROCEDURE csrMat_getILUDP1 + +!---------------------------------------------------------------------------- +! getILUDP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getILUDP2 +REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) +INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) +INTEGER(I4B) :: s(2), ii, nnz + +CALL csrMat_getILUDP1(obj, ALU, JLU, JU, alpha, droptol, permtol, mbloc, & + & IPERM) +s = SHAPE(obj) +DO ii = 1, s(1) + IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE + ALU(ii) = 1.0 / ALU(ii) +END DO +nnz = JLU(s(1) + 1) +CALL Reallocate(WK, s(1), IWK, s(1) + 1) +CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) +CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) +nnz = IA(s(1) + 1) - 1 +CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) +END PROCEDURE csrMat_getILUDP2 + +!---------------------------------------------------------------------------- +! getILUDP +!---------------------------------------------------------------------------- + +!> subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr) +! iluk(n,a,ja,ia,lfil,alu,jlu,ju,levs,iwk,w,jw,ierr) + +MODULE PROCEDURE csrMat_getILUK1 +INTEGER(I4B) :: nnz, s(2), ierr, IWK, k +INTEGER(I4B), ALLOCATABLE :: JW(:) +REAL(DFP), ALLOCATABLE :: W(:) +! +s = SHAPE(obj) +nnz = getNNZ(obj) +ALLOCATE (JW(3 * s(1)), W(s(1))) +CALL Reallocate(JU, s(1)) +IWK = 1.1 * nnz +! +DO + CALL Reallocate(ALU, IWK, JLU, IWK, LEVS, IWK) + CALL ILUK(s(1), obj%A, obj%csr%JA, obj%csr%IA, lfil, ALU, JLU, JU, LEVS,& + & IWK, W, JW, ierr) + IF (ierr .EQ. -2 .OR. ierr .EQ. -3) THEN + IWK = 1.2 * IWK + ELSE + EXIT + END IF +END DO +! +SELECT CASE (ierr) +CASE (-1) + CALL ErrorMSG( & + & "Input matrix may be wrong. (The elimination process has generated a & + & row in L or U whose length is .gt. n.)", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUK1()", & + & __LINE__, stderr) + STOP +CASE (-2) + CALL ErrorMSG( & + & "The matrix L overflows the array AL ", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUK1()", & + & __LINE__, stderr) + STOP +CASE (-3) + CALL ErrorMSG( & + & "The matrix U overflows the array ALU", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUK1()", & + & __LINE__, stderr) + STOP +CASE (-4) + CALL ErrorMSG( & + & "Illegal value for lfil.", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUK1()", & + & __LINE__, stderr) + STOP +CASE (-5) + CALL ErrorMSG( & + & "zero row encountered", & + & "CSRMatrix_Method@ILUMethods.F90", & + & "csrMat_getILUK1()", & + & __LINE__, stderr) + STOP +END SELECT +DEALLOCATE (JW, W) +END PROCEDURE csrMat_getILUK1 + +!---------------------------------------------------------------------------- +! getILUK +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_getILUK2 +REAL(DFP), ALLOCATABLE :: ALU(:), A(:), WK(:) +INTEGER(I4B), ALLOCATABLE :: JLU(:), JU(:), JA(:), IA(:), IWK(:) +INTEGER(I4B) :: s(2), ii, nnz + +CALL csrMat_getILUK1(obj, ALU, JLU, JU, lfil, LEVS) +s = SHAPE(obj) +DO ii = 1, s(1) + IF (ALU(ii) .APPROXEQ.0.0_DFP) CYCLE + ALU(ii) = 1.0 / ALU(ii) +END DO +nnz = JLU(s(1) + 1) +CALL Reallocate(WK, s(1), IWK, s(1) + 1) +CALL Reallocate(A, nnz, JA, nnz, IA, s(1) + 1) +CALL MSRCSR(s(1), ALU, JLU, A, JA, IA, WK, IWK) +nnz = IA(s(1) + 1) - 1 +CALL Initiate(obj=Pmat, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (ALU, A, JLU, JU, JA, IA, WK, IWK) +END PROCEDURE csrMat_getILUK2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 new file mode 100644 index 000000000..5d7005e3a --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_IOMethods@Methods.F90 @@ -0,0 +1,353 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_IOMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Display +INTEGER(I4B) :: I +I = INPUT(Option=UnitNo, Default=stdout) +CALL Display(msg, unitNo=I) +CALL Display(obj%csrOwnership, "CSR OWNERSHIP : ") +CALL Display(obj%tDimension, "TOTAL DIMENSION : ") +CALL Display(obj%MatrixProp, "MATRIX PROPERTY : ") +CALL Display(obj=obj%csr, msg="CSR SPARSITY : ", unitNo=I) +IF (ALLOCATED(obj%A)) THEN + CALL DUMP(1, obj%csr%nrow, .TRUE., obj%A, obj%csr%JA, obj%csr%IA, I) +ELSE + CALL DUMP(1, obj%csr%nrow, .FALSE., obj%A, obj%csr%JA, obj%csr%IA, I) +END IF +END PROCEDURE obj_Display + +!---------------------------------------------------------------------------- +! Spy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SPY +SELECT CASE (TRIM(ext)) +CASE ("gp", ".gp", ".GP", "GP") + CALL obj_SPY_gnuplot(obj, filename) +CASE ("pdf", ".pdf") + CALL obj_SPY_PLPLOT(obj, filename, ext, "pdf") +CASE ("svg", ".svg") + CALL obj_SPY_PLPLOT(obj, filename, ext, "svg") +CASE ("eps", ".eps") + CALL obj_SPY_PLPLOT(obj, filename, ext, "epscairo") +CASE ("png", ".png") + CALL obj_SPY_PLPLOT(obj, filename, ext, "pngcairo") +CASE ("ps", ".ps") + CALL obj_SPY_PLPLOT(obj, filename, ext, "ps") +CASE DEFAULT +END SELECT +END PROCEDURE obj_SPY + +!---------------------------------------------------------------------------- +! obj_SPY_PLPLOT +!---------------------------------------------------------------------------- + +SUBROUTINE obj_SPY_PLPLOT(obj, filename, ext, driver) + TYPE(CSRMatrix_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: filename + CHARACTER(*), INTENT(IN) :: ext + CHARACTER(*), INTENT(IN) :: driver +#ifdef USE_PLPLOT + !> Internal + REAL(DFP), ALLOCATABLE :: X(:), Y(:) !, A( : )! + REAL(DFP) :: xmin, xmax, ymin, ymax + INTEGER(I4B) :: ii, jj, kk + !> main + CALL Reallocate(X, obj%csr%nnz, Y, obj%csr%nnz) + kk = 0 + DO ii = 1, obj%csr%nrow + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + kk = kk + 1 + X(kk) = obj%csr%JA(jj) + Y(kk) = ii + ! A(kk) = obj%A(jj) + END DO + END DO + ! + xmin = 1 - obj%csr%ncol * 0.1 + xmax = obj%csr%ncol + obj%csr%ncol * 0.1 + ymin = obj%csr%nrow + obj%csr%nrow * 0.1 + ymax = 1 - obj%csr%nrow * 0.1 + ! + CALL PLSDEV(TRIM(driver)) + IF (ext(1:1) .EQ. ".") THEN + CALL PLSFNAM(TRIM(filename)//TRIM(ext)) + ELSE + CALL PLSFNAM(TRIM(filename)//"."//TRIM(ext)) + END IF + !> + CALL PLSCOLBG(255, 255, 255) + CALL PLINIT + CALL PLSCOL0(0, 0, 0, 0) + CALL PLCOL0(0) + CALL PLENV(xmin, xmax, ymin, ymax, 1, -1) + ! CALL PLBOX('bcgnst', 0.0_DFP, 2, 'bcgnstv', 0.0_DFP, 2) + ! I am removing grids, if you want them then please activate + ! above line of code, and comment the following line. + ! I am deactivating the numerical labels + ! I am deactivating the subticks + + CALL PLBOX('bcx', 0.0_DFP, 2, 'bcx', 0.0_DFP, 2) + CALL PLLAB("COLUMN", "ROW", "STRUCTURE OF SPARSE MATRIX") + CALL PLSSYM(0.0_DFP, 0.2_DFP) + CALL PLCOL0(9) + CALL PLPOIN(X, Y, 3) + CALL PLEND + IF (ALLOCATED(X)) DEALLOCATE (X) + IF (ALLOCATED(Y)) DEALLOCATE (Y) + ! IF( ALLOCATED(A) ) DEALLOCATE(A) +#endif +END SUBROUTINE obj_SPY_PLPLOT + +!---------------------------------------------------------------------------- +! obj_SPY_gnuplot +!---------------------------------------------------------------------------- + +SUBROUTINE obj_SPY_gnuplot(obj, filename) + TYPE(CSRMatrix_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: filename + ! internal variable + INTEGER(I4B) :: i, nrow, j, m, ncol, nnz, unitno, a, b, IOSTAT + CHARACTER(256) :: scripFile + LOGICAL(LGT) :: isOpen + !> main + OPEN (FILE=TRIM(filename)//".txt", NEWUNIT=unitno, STATUS="REPLACE", & + & ACTION="WRITE", IOSTAT=IOSTAT) + !> check + IF (IOSTAT .NE. 0) THEN + CALL ErrorMSG(Msg="Error opening "//TRIM(filename)//".txt file", & + & File=__FILE__, Routine="obj_SPY_gnuplot()", & + & LINE=__LINE__) + STOP + END IF + nrow = obj%csr%nrow; ncol = obj%csr%ncol; nnz = obj%csr%nnz + CALL Display("#m = "//TOSTRING(nrow), unitNo=unitNo) + CALL Display("#n = "//TOSTRING(ncol), unitNo=unitNo) + CALL Display("#nnz = "//TOSTRING(nnz), unitNo=unitNo) + !> write data in txt file + !> columns are in x direction + !> rows are in y direction + DO i = 1, nrow + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + WRITE (unitNo, '(I6, 2X, I6, 2X, G14.6)') & + & obj%csr%JA(j), i, obj%A(j) + END DO + END DO + CLOSE (unitno) + !> open gnuplot script file + OPEN (FILE=TRIM(filename)//".gp", NEWUNIT=unitno, STATUS="REPLACE", & + & ACTION="WRITE", IOSTAT=IOSTAT) + !> check + IF (IOSTAT .NE. 0) THEN + CALL ErrorMSG(Msg="Error opening "//TRIM(filename)//".gp file", & + & File=__FILE__, Routine="obj_SPY_gnuplot()", & + & LINE=__LINE__) + STOP + END IF + CALL Display('# Gnuplot script file', unitNo=unitNo) + CALL Display('# Generated by :: EASIFEM', unitNo=unitNo) + CALL Display( & + & "set terminal postscript eps enhance color font 'Helvetica,10'", & + & unitNo=unitNo) + + CALL Display( & + & "set output '"//TRIM(filename)//".eps'", & + & unitNo=unitNo) + + CALL Display( & + & "set xlabel 'Col(J)'", & + & unitNo=unitNo) + + CALL Display( & + & "set ylabel 'Row(I)'", & + & unitNo=unitNo) + + CALL Display( & + & "set size ratio -1", & + & unitNo=unitNo) + + CALL Display( & + & "set title 'NNZ = "//TRIM(INT2STR(nnz))//"'", & + & unitNo=unitNo) + + a = 1 - ncol * 0.1 + b = ncol + ncol * 0.1 + + CALL Display( & + & 'set xrange['//TOSTRING(a)//':' & + & //TOSTRING(b)//"]", & + & unitNo=unitNo) + + a = 1 - nrow * 0.1 + b = nrow + nrow * 0.1 + + CALL Display( & + & 'set yrange['//TOSTRING(b)//':' & + & //TOSTRING(a)//"]", & + & unitNo=unitNo) + + WRITE (unitNo, '(A)') 'set mxtics 5' + WRITE (unitNo, '(A)') 'set mytics 5' + WRITE (unitNo, '(A)') 'set grid xtics ytics mxtics mytics' + WRITE (unitNo, "(A)") & + & "plot"//"'"//TRIM(filename)//".txt"//"' with points pt 7 ps 1.0" + CLOSE (unitno) +END SUBROUTINE obj_SPY_gnuplot + +!---------------------------------------------------------------------------- +! IMPORT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_IMPORT +INTEGER(I4B) :: iostat, unitno, rows, cols, nnz, ii +INTEGER(I4B), ALLOCATABLE :: indx(:), jndx(:), IA(:), JA(:) +REAL(DFP), ALLOCATABLE :: A(:), rval(:) +TYPE(String) :: aline +CHARACTER(1024) :: iomsg +CHARACTER(50) :: rep, field, symm + +! Open file +OPEN (FILE=filename, NEWUNIT=unitno, STATUS="OLD", ACTION="READ", & + & IOSTAT=iostat, iomsg=iomsg) + +IF (iostat .NE. 0) THEN + CALL ErrorMSG(& + & msg="Error in opening file, following msg = "//TRIM(iomsg), & + & file=__FILE__, & + & routine="obj_IMPORT()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +CALL MMRead(unitno=unitno, rep=rep, field=field, symm=symm, rows=rows, & + & cols=cols, nnz=nnz, indx=indx, jndx=jndx, rval=rval) + +CALL toUpperCase(symm) +IF (symm .EQ. "SYMMETRIC") THEN + symm = "SYM" +ELSEIF (symm .EQ. "SKEW-SYMMETRIC") THEN + symm = "SKEWSYM" +ELSE + symm = "UNSYM" +END IF + +ALLOCATE (IA(rows + 1), JA(nnz), A(nnz)) + +! Call COOCSR from sparsekit +CALL COOCSR(rows, nnz, rval, indx, jndx, A, JA, IA) +CALL Initiate(obj=obj, A=A, IA=IA, JA=JA, MatrixProp=symm) + +CLOSE (unitNo) +DEALLOCATE (indx, jndx, rval, IA, JA, A) +END PROCEDURE obj_IMPORT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE deprecated_obj_IMPORT +INTEGER(I4B) :: iostat, unitNo, nrow, ncol, nnz, ii +INTEGER(I4B), ALLOCATABLE :: ROW(:), COL(:), IA(:), JA(:) +REAL(DFP), ALLOCATABLE :: A(:), X(:) +TYPE(String) :: aline +CHARACTER(1024) :: iomsg +! +OPEN (FILE=filename, NEWUNIT=unitNo, STATUS="OLD", ACTION="READ", & + & IOSTAT=iostat, iomsg=iomsg) +! +IF (iostat .NE. 0) THEN + CALL ErrorMSG(& + & msg="Error in opening file, following msg = "//TRIM(iomsg), & + & file=__FILE__, & + & routine="obj_IMPORT()", & + & line=__LINE__, & + & unitno=stderr) +END IF +! +CALL aline%read_line(unit=unitNo, iostat=iostat, iomsg=iomsg) +! +IF (iostat .NE. 0) THEN + CALL ErrorMSG(& + & msg="Error while calling read_line method from String Class, & + & following msg is returned "//TRIM(iomsg), & + & file=__FILE__, & + & routine="obj_IMPORT()", & + & line=__LINE__, & + & unitno=stderr) +END IF +! +iostat = 0 +READ (unitNo, *, iostat=iostat, iomsg=iomsg) nrow, ncol, nnz +! +IF (iostat .NE. 0) THEN + CALL ErrorMSG(& + & msg="Error while reading nrow, ncol, nnz from the given file, & + & following msg is returned "//TRIM(iomsg), & + & file=__FILE__, & + & routine="obj_IMPORT()", & + & line=__LINE__, & + & unitno=stderr) +END IF +! +ALLOCATE (ROW(nnz), COL(nnz), X(nnz)) +! +iostat = 0 +DO ii = 1, nnz + READ (unitNo, *, iostat=iostat, iomsg=iomsg) ROW(ii), COL(ii), X(ii) + IF (iostat .NE. 0) EXIT +END DO +! +IF (iostat .NE. 0) THEN + CALL ErrorMSG(& + & msg="Error while reading row(ii), col(ii), x(ii) from the given file, & + & following msg is returned "//TRIM(iomsg), & + & file=__FILE__, & + & routine="obj_IMPORT()", & + & line=__LINE__, & + & unitno=stderr) +END IF +! +ALLOCATE (IA(nrow + 1), JA(nnz), A(nnz)) +! +! Call COOCSR from sparsekit +! +CALL COOCSR(nrow, nnz, X, ROW, COL, A, JA, IA) +! +CALL Initiate(obj=obj, A=A, IA=IA, JA=JA) +! +DEALLOCATE (ROW, COL, X, IA, JA, A) +CLOSE (unitNo) +END PROCEDURE deprecated_obj_IMPORT + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 new file mode 100644 index 000000000..8b422c0a5 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_LUSolveMethods@Methods.F90 @@ -0,0 +1,51 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 14 July 2021 +! summary: This submodule contains methods fors solving LU x = y + +SUBMODULE(CSRMatrix_LUSolveMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! LUSOLVE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_LUSOLVE +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + CALL LUTSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) + ELSE + CALL LUSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) + END IF +ELSE + CALL LUSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) +END IF +END PROCEDURE csrMat_LUSOLVE + +!---------------------------------------------------------------------------- +! LUTSOLVE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_LUTSOLVE +CALL LUTSOL(SIZE(rhs), rhs, sol, alu, jlu, ju) +END PROCEDURE csrMat_LUTSOLVE + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 new file mode 100644 index 000000000..7212d58aa --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_LinSolveMethods@Methods.F90 @@ -0,0 +1,607 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _x1 IPAR(8) +#define _x2 IPAR(8) + n - 1 +#define _y1 IPAR(9) +#define _y2 IPAR(9) + n - 1 + +SUBMODULE(CSRMatrix_LinSolveMethods) Methods +! USE BaseMethod +USE GlobalData +USE Display_Method +USE InputUtility +USE CSRMatrix_MatVecMethods +USE CSRMatrix_ConstructorMethods +USE ReallocateUtility +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetLinSolverCodeFromName +SELECT CASE (TRIM(name)) +CASE ("SUPERLU") !1 + ans = LIS_SUPERLU +CASE ("CG") !1 + ans = LIS_CG +CASE ("BICG") !2 + ans = LIS_BICG +CASE ("CGS") !3 + ans = LIS_CGS +CASE ("BICGSTAB") !4 + ans = LIS_BICGSTAB +CASE ("BICGSTABL") !5 + ans = LIS_BICGSTABL +CASE ("GPBICG") !6 + ans = LIS_GPBICG +CASE ("TFQMR") !7 + ans = LIS_TFQMR +CASE ("OMN", "FOM", "ORTHOMIN") !8 + ans = LIS_OMN +CASE ("GMRES", "GMR") !9 + ans = LIS_GMRES +CASE ("JACOBI") !10 + ans = LIS_JACOBI +CASE ("GS") !11 + ans = LIS_GS +CASE ("SOR") !12 + ans = LIS_SOR +CASE ("BICGSAFE") !13 + ans = LIS_BICGSAFE +CASE ("CR") !14 + ans = LIS_CR +CASE ("BICR") !15 + ans = LIS_BICR +CASE ("CRS") !16 + ans = LIS_CRS +CASE ("BICRSTAB") !17 + ans = LIS_BICRSTAB +CASE ("GPBICR") !18 + ans = LIS_GPBICR +CASE ("BICRSAFE") !19 + ans = LIS_BICRSAFE +CASE ("FGMRES") !20 + ans = LIS_FGMRES +CASE ("IDRS") !21 + ans = LIS_IDRS +CASE ("IDR1") !22 + ans = LIS_IDR1 +CASE ("MINRES") !23 + ans = LIS_MINRES +CASE ("COCG") !24 + ans = LIS_COCG +CASE ("COCR") !25 + ans = LIS_COCR +CASE ("CGNR", "CGN") !26 + ans = LIS_CGNR +CASE ("DBICG") !27 + ans = LIS_DBICG +CASE ("DQGMRES") !28 + ans = LIS_DQGMRES +END SELECT +END PROCEDURE GetLinSolverCodeFromName + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetLinSolverNameFromCode +SELECT CASE (name) +CASE (LIS_SUPERLU) + ans = "SUPERLU" !1 +CASE (LIS_CG) + ans = "CG" !1 +CASE (LIS_BICG) + ans = "BICG" !2 +CASE (LIS_CGS) + ans = "CGS" !3 +CASE (LIS_BICGSTAB) + ans = "BICGSTAB" !4 +CASE (LIS_BICGSTABL) + ans = "BICGSTABL" !5 +CASE (LIS_GPBICG) + ans = "GPBICG" !6 +CASE (LIS_TFQMR) + ans = "TFQMR" !7 +CASE (LIS_OMN) + ans = "ORTHOMIN" !8 +CASE (LIS_GMRES) + ans = "GMRES" !9 +CASE (LIS_JACOBI) + ans = "JACOBI" !10 +CASE (LIS_GS) + ans = "GS" !11 +CASE (LIS_SOR) + ans = "SOR" !12 +CASE (LIS_BICGSAFE) + ans = "BICGSAFE" !13 +CASE (LIS_CR) + ans = "CR" !14 +CASE (LIS_BICR) + ans = "BICR" !15 +CASE (LIS_CRS) + ans = "CRS" !16 +CASE (LIS_BICRSTAB) + ans = "BICRSTAB" !17 +CASE (LIS_GPBICR) + ans = "GPBICR" !18 +CASE (LIS_BICRSAFE) + ans = "BICRSAFE" !19 +CASE (LIS_FGMRES) + ans = "FGMRES" !20 +CASE (LIS_IDRS) + ans = "IDRS" !21 +CASE (LIS_IDR1) + ans = "IDR1" !22 +CASE (LIS_MINRES) + ans = "MINRES" !23 +CASE (LIS_COCG) + ans = "COCG" !24 +CASE (LIS_COCR) + ans = "COCR" !25 +CASE (LIS_CGNR) + ans = "CGNR" !26 +CASE (LIS_DBICG) + ans = "DBICG" !27 +CASE (LIS_DQGMRES) + ans = "DQGMRES" !28 +END SELECT +END PROCEDURE GetLinSolverNameFromCode + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE SetPreconditionOption(IPAR, PRECOND_TYPE) + INTEGER(I4B), INTENT(INOUT) :: IPAR(:) + INTEGER(I4B), INTENT(IN) :: PRECOND_TYPE + + SELECT CASE (PRECOND_TYPE) + CASE (NO_PRECONDITION) + IPAR(2) = 0 + CASE (LEFT_PRECONDITION) + IPAR(2) = 1 + CASE (RIGHT_PRECONDITION) + IPAR(2) = 2 + CASE (LEFT_RIGHT_PRECONDITION) + IPAR(2) = 3 + END SELECT +END SUBROUTINE SetPreconditionOption + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE SetKrylovSubspaceSize(IPAR, m) + INTEGER(I4B), INTENT(INOUT) :: IPAR(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: m + IPAR(5) = Input(default=15, option=m) +END SUBROUTINE SetKrylovSubspaceSize + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE SetMaxIter(IPAR, maxIter) + INTEGER(I4B), INTENT(INOUT) :: IPAR(:) + INTEGER(I4B), INTENT(IN) :: maxIter + IPAR(6) = maxIter +END SUBROUTINE SetMaxIter + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE SetConvergenceType(IPAR, convergenceIn, convergenceType, & + & relativeToRHS) + INTEGER(I4B), INTENT(INOUT) :: IPAR(:) + INTEGER(I4B), INTENT(IN) :: convergenceIn + INTEGER(I4B), INTENT(IN) :: convergenceType + LOGICAL(LGT), INTENT(IN) :: relativeToRHS + + IPAR(3) = 1 + SELECT CASE (convergenceType) + + CASE (absoluteConvergence) + IF (convergenceIn .EQ. convergenceInSol) THEN + IPAR(3) = -1 + ELSE IF (convergenceIn .EQ. convergenceInRes) THEN + IPAR(3) = 1 + END IF + + CASE (relativeConvergence) + + IF (convergenceIn .EQ. convergenceInSol) THEN + IF (relativeToRHS) THEN + IPAR(3) = -2 + ELSE + IPAR(3) = -1 + END IF + + ELSE IF (convergenceIn .EQ. convergenceInRes) THEN + IF (relativeToRHS) THEN + IPAR(3) = 2 + ELSE + IPAR(3) = 1 + END IF + END IF + + END SELECT +END SUBROUTINE SetConvergenceType + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE PERFORM_TASK(Amat, y, x, ierr) + ! intent of dummy variables + CLASS(CSRMatrix_), INTENT(INOUT) :: Amat + REAL(DFP), INTENT(INOUT) :: y(:) + REAL(DFP), INTENT(IN) :: x(:) + INTEGER(I4B), INTENT(IN) :: ierr + + SELECT CASE (ierr) + CASE (1) + ! MatVec, y=Ax + CALL Matvec(obj=Amat, y=y, x=x, isTranspose=.FALSE.) + CASE (2) + ! Transposed MatVec + CALL Matvec(obj=Amat, y=y, x=x, isTranspose=.TRUE.) + CASE (3, 5) + ! LEFT/RIGHT PRECONDITIONER SOLVER + ! The preconditioners are inside the Amat + ! CALL Amat%ILUSOLVE(sol=y, rhs=x, isTranspose=.FALSE.) + CALL Display("File = "//__FILE__) + CALL Display("Precondition is not supported yet!!!") + STOP + + CASE (4, 6) + ! LEFT/RIGHT PRECONDITIONER SOLVER + ! The preconditioners are inside the Amat + ! CALL Amat%ILUSOLVE(sol=y, rhs=x, isTranspose=.TRUE.) + CALL Display("File = "//__FILE__) + CALL Display("Precondition is not supported yet!!!") + STOP + END SELECT +END SUBROUTINE PERFORM_TASK + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE CHECKERROR(IPAR, FPAR) + INTEGER(I4B), INTENT(IN) :: IPAR(:) + REAL(DFP), INTENT(IN) :: FPAR(:) + INTEGER(I4B) :: ierr, unitNo + + ierr = IPAR(1) + + SELECT CASE (ierr) + CASE (-1) + unitNo = stdout + CALL EqualLine(unitNo=unitNo) + CALL Display(IPAR(7), "Number of Matrix-Vector Multiplication: ",& + & unitNo=unitNo) + CALL Display(FPAR(3), "Initial residual/error norm: ",& + & unitNo=unitNo) + CALL Display(FPAR(4), "Target residual/error norm: ",& + & unitNo=unitNo) + CALL Display(FPAR(6), "Current residual/error norm: ",& + & unitNo=unitNo) + CALL Display(FPAR(5), "Current residual norm: ",& + & unitNo=unitNo) + CALL Display(FPAR(7), "Convergence rate: ",& + & unitNo=unitNo) + CALL EqualLine(unitNo=unitNo) + CALL Display("Termination because iteration number exceeds the limit", & + & unitno) + CASE (-2) + CALL Display("Return due to insufficient work space", & + & unitno) + CASE (-3) + CALL Display("Return due to anticipated break-down / divide by zero", & + & unitno) + CASE (-4) + CALL Display( & + & "The values of `fpar(1)` and `fpar(2)` are both <= 0"// & + & "the valid ranges are 0 <= fpar(1) < 1, 0 <= fpar(2)"// & + & "and they can not be zero at the same time", unitno) + CASE (-9) + CALL Display( & + & "While trying to detect a break-down, "// & + & "an abnormal number is detected", unitno) + CASE (-10) + CALL Display( & + & "Return due to some non-numerical reasons, "// & + & "e.g. invalid floating-point numbers etc", unitno) + CASE DEFAULT + CALL Display( & + & "Unknown error encountered. Cannot read the error message", & + & unitno) + END SELECT +END SUBROUTINE CHECKERROR + +!---------------------------------------------------------------------------- +! DisplayConvergence +!---------------------------------------------------------------------------- + +SUBROUTINE DisplayConvergence(iter, FPAR) + INTEGER(I4B), INTENT(IN) :: iter + REAL(DFP), INTENT(IN) :: FPAR(:) + INTEGER(I4B) :: unitno + + unitno = stdout + + CALL Display('Convergence is achieved 🎖', unitNo) + CALL Blanklines(nol=2, unitno=unitno) + CALL Display(iter, "Number of Matrix-Vector Multiplication: ",& + & unitno=unitno) + CALL Display(fpar(3), "Initial residual/error norm: ",& + & unitno=unitno) + CALL Display(fpar(4), "Target residual/error norm: ",& + & unitno=unitno) + CALL Display(fpar(6), "Current residual/error norm: ",& + & unitno=unitno) + CALL Display(fpar(5), "Current residual norm: ",& + & unitno=unitno) + CALL Display(fpar(7), "Convergence rate: ",& + & unitno=unitno) +END SUBROUTINE DisplayConvergence + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> authors: Vikas Sharma, Ph. D. +! date: 16 July 2021 +! summary: This subroutine allocates the workspace required for the linear solver +! +! Introduction +! +! This routine allocates the workspace required for the linear solver + +SUBROUTINE AllocateWorkSpace(W, IPAR, solverName, n) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: W(:) + INTEGER(I4B), INTENT(INOUT) :: IPAR(:) + INTEGER(I4B), INTENT(IN) :: solverName + INTEGER(I4B), INTENT(IN) :: n + + INTEGER(I4B) :: i, m + + SELECT CASE (solverName) + CASE (LIS_CG, LIS_CGNR) + i = 5 * n + CASE (LIS_BICG) + i = 7 * n + CASE (LIS_DBICG) + i = 11 * n + CASE (LIS_BICGSTAB) + i = 8 * n + CASE (LIS_TFQMR) + i = 11 * n + CASE (LIS_ORTHOMIN, LIS_GMRES) + m = Input(default=15, option=IPAR(5)) + i = (n + 3) * (m + 2) + (m + 1) * m / 2 + CASE (LIS_FGMRES) + m = Input(default=15, option=IPAR(5)) + i = 2 * n * (m + 1) + (m + 1) * m / 2 + 3 * m + 2 + CASE (LIS_DQGMRES) + m = Input(default=15, option=IPAR(5)) + 1 + i = n + m * (2 * n + 4) + END SELECT + IPAR(4) = i + CALL Reallocate(W, i) +END SUBROUTINE AllocateWorkSpace + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrix_LinSolve_Initiate +INTEGER(I4B), PARAMETER :: default_maxiter = -1_I4B, & + default_preconditionOption = NO_PRECONDITION, & + default_convergenceIn = ConvergenceInRes, & + default_convergenceType = RelativeConvergence, & + default_KrylovSubspaceSize = 5, & + default_solverName = LIS_CG +LOGICAL(LGT), PARAMETER :: default_relativeToRHS = .FALSE. +REAL(DFP), PARAMETER :: default_atol = 1.0E-10, & + default_rtol = 1.0E-10 + +IF (.NOT. ALLOCATED(ipar)) ALLOCATE (ipar(13)) +IF (.NOT. ALLOCATED(fpar)) ALLOCATE (fpar(13)) + +CALL SetPreconditionOption( & + ipar=ipar, & + PRECOND_TYPE=Input(option=preconditionOption, & + default=default_preconditionOption)) + +CALL SetConvergenceType(ipar=ipar, & + convergenceIn=Input(option=convergenceIn, & + default=default_convergenceIn), & + convergenceType=Input(option=convergenceType, & + default=default_convergenceType), & + relativeToRHS=Input(option=relativeToRHS, & + default=default_relativeToRHS)) + +IPAR(5) = Input(option=KrylovSubspaceSize, default=default_KrylovSubspaceSize) + +CALL SetMaxIter(ipar, Input(option=maxIter, default=default_maxiter)) + +fpar = 0.0_DFP + +fpar(1) = Input(option=rtol, default=default_rtol) +fpar(2) = Input(option=atol, default=default_atol) + +IF (.NOT. ALLOCATED(W)) THEN + CALL AllocateWorkSpace(W, ipar, & + Input(default=default_solverName, option=solverName), n) +END IF + +END PROCEDURE CSRMatrix_LinSolve_Initiate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrix_GMRES +INTEGER(I4B) :: n +! REAL(DFP) :: error0, error, tol, normRes +! INTEGER(I4B) :: ierr, iter + +IPAR(1) = 0 +FPAR(11) = 0.0_DFP +n = SIZE(obj, 1) +IPAR(7) = 1 + +DO + CALL GMRES(n, rhs, sol, ipar, fpar, W) + ! obj%RES(ipar(7)) = fpar(6) + + IF (ipar(1) .GT. 0) THEN + CALL PERFORM_TASK(obj, y=W(_y1:_y2), x=W(_x1:_x2), & + & ierr=ipar(1)) + + ELSE IF (ipar(1) .LT. 0) THEN + CALL CHECKERROR(IPAR=ipar, FPAR=fpar) + EXIT + + ELSE IF (ipar(1) .EQ. 0) THEN + ! ierr = ipar(1) + ! iter = ipar(7) + CALL DisplayConvergence(ipar(7), fpar) + EXIT + + END IF +END DO + +! Initial residual/error norm +! error0 = fpar(3) +! Target residual/error norm +! tol = fpar(4) +! Current residual/error norm +! error = fpar(6) +! Current residual norm +! normRes = fpar(5) + +END PROCEDURE CSRMatrix_GMRES + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrix_CG +INTEGER(I4B) :: n +! REAL(DFP) :: error0, error, tol, normRes +! INTEGER(I4B) :: ierr, iter + +IPAR(1) = 0 +FPAR(11) = 0.0_DFP +n = SIZE(obj, 1) +IPAR(7) = 1 + +DO + CALL CG(n, rhs, sol, ipar, fpar, W) + ! obj%RES(ipar(7)) = fpar(6) + + IF (ipar(1) .GT. 0) THEN + CALL PERFORM_TASK(obj, y=W(_y1:_y2), x=W(_x1:_x2), & + & ierr=ipar(1)) + + ELSE IF (ipar(1) .LT. 0) THEN + CALL CHECKERROR(IPAR=ipar, FPAR=fpar) + EXIT + + ELSE IF (ipar(1) .EQ. 0) THEN + ! ierr = ipar(1) + ! iter = ipar(7) + CALL DisplayConvergence(ipar(7), fpar) + EXIT + + END IF +END DO + +! Initial residual/error norm +! error0 = fpar(3) +! Target residual/error norm +! tol = fpar(4) +! Current residual/error norm +! error = fpar(6) +! Current residual norm +! normRes = fpar(5) + +END PROCEDURE CSRMatrix_CG + +!---------------------------------------------------------------------------- +! BiCGStab +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrix_BiCGStab +INTEGER(I4B) :: n +! REAL(DFP) :: error0, error, tol, normRes +! INTEGER(I4B) :: ierr, iter + +IPAR(1) = 0 +FPAR(11) = 0.0_DFP +n = SIZE(obj, 1) +IPAR(7) = 1 + +DO + CALL BCGSTAB(n, rhs, sol, ipar, fpar, W) + ! obj%RES(ipar(7)) = fpar(6) + + IF (ipar(1) .GT. 0) THEN + CALL PERFORM_TASK(obj, y=W(_y1:_y2), x=W(_x1:_x2), & + & ierr=ipar(1)) + + ELSE IF (ipar(1) .LT. 0) THEN + CALL CHECKERROR(IPAR=ipar, FPAR=fpar) + EXIT + + ELSE IF (ipar(1) .EQ. 0) THEN + ! ierr = ipar(1) + ! iter = ipar(7) + CALL DisplayConvergence(ipar(7), fpar) + EXIT + + END IF +END DO + +! Initial residual/error norm +! error0 = fpar(3) +! Target residual/error norm +! tol = fpar(4) +! Current residual/error norm +! error = fpar(6) +! Current residual norm +! normRes = fpar(5) + +END PROCEDURE CSRMatrix_BiCGStab + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods + +#undef _x1 +#undef _x2 +#undef _y1 +#undef _y2 diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 new file mode 100644 index 000000000..ae4631d4d --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 @@ -0,0 +1,265 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_MatVecMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrixATMUX1 +INTEGER(I4B) :: i, k + +y = 0.0_DFP + +DO i = 1, n + DO k = ia(i), ia(i + 1) - 1 + y(ja(k)) = y(ja(k)) + x(i) * a(k) + END DO +END DO + +END PROCEDURE CSRMatrixATMUX1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrixATMUX2 +INTEGER(I4B) :: i, k + +y = 0.0_DFP + +DO i = 1, n + DO k = ia(i), ia(i + 1) - 1 + y(ja(k)) = y(ja(k)) + x(i) * a(k) * s + END DO +END DO + +END PROCEDURE CSRMatrixATMUX2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrixATMUX_Add_1 +INTEGER(I4B) :: i, k + +DO i = 1, n + DO k = ia(i), ia(i + 1) - 1 + y(ja(k)) = y(ja(k)) + x(i) * a(k) * s + END DO +END DO + +END PROCEDURE CSRMatrixATMUX_Add_1 + +!---------------------------------------------------------------------------- +! CSRMatrixAMUX +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrixAMUX1 +REAL(DFP) :: t +INTEGER(I4B) :: i, k + +DO i = 1, n + ! compute the inner product of row i with vector x + t = 0.0 + DO k = ia(i), ia(i + 1) - 1 + t = t + a(k) * x(ja(k)) + END DO + ! store result in y(i) + y(i) = t +END DO +END PROCEDURE CSRMatrixAMUX1 + +!---------------------------------------------------------------------------- +! CSRMatrixAMUX +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrixAMUX2 +REAL(DFP) :: t +INTEGER(I4B) :: i, k + +DO i = 1, n + ! compute the inner product of row i with vector x + t = 0.0 + DO k = ia(i), ia(i + 1) - 1 + t = t + a(k) * x(ja(k)) + END DO + ! store result in y(i) + y(i) = s * t +END DO +END PROCEDURE CSRMatrixAMUX2 + +!---------------------------------------------------------------------------- +! CSRMatrixAMUX +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CSRMatrixAMUX_Add_1 +REAL(DFP) :: t +INTEGER(I4B) :: i, k + +DO i = 1, n + ! compute the inner product of row i with vector x + t = 0.0 + DO k = ia(i), ia(i + 1) - 1 + t = t + a(k) * x(ja(k)) + END DO + ! store result in y(i) + y(i) = y(i) + s * t +END DO +END PROCEDURE CSRMatrixAMUX_Add_1 + +!---------------------------------------------------------------------------- +! AMatvec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_AMatvec1 +LOGICAL(LGT) :: add0 +REAL(DFP) :: scale0 +INTEGER(I4B) :: tsize + +add0 = input(default=.FALSE., option=addContribution) +scale0 = input(default=1.0_DFP, option=scale) +tsize = SIZE(y) + +IF (add0) THEN + CALL CSRMatrixAMUX_Add(n=tsize, x=x, y=y, a=obj%A, & + & ja=obj%csr%JA, ia=obj%csr%IA, s=scale0) + RETURN +END IF + +CALL CSRMatrixAMUX(n=tsize, x=x, y=y, a=obj%A, & + & ja=obj%csr%JA, ia=obj%csr%IA, s=scale0) + +END PROCEDURE csrMat_AMatvec1 + +!---------------------------------------------------------------------------- +! AMatvec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_AMatvec2 +REAL(DFP) :: y0(SIZE(y)) +LOGICAL(LGT) :: add0 +REAL(DFP) :: scale0 +INTEGER(I4B) :: tsize + +add0 = input(default=.FALSE., option=addContribution) +scale0 = input(default=1.0_DFP, option=scale) +tsize = SIZE(y) + +IF (add0) THEN + CALL AMUXMS(tsize, x, y0, A, JA) + CALL AXPY(X=y0, Y=y, A=scale0) + RETURN +END IF + +CALL AMUXMS(tsize, x, y, A, JA) +CALL SCAL(X=y, A=scale0) +END PROCEDURE csrMat_AMatvec2 + +!---------------------------------------------------------------------------- +! AtMatvec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_AtMatvec +REAL(DFP) :: y0(SIZE(y)) +LOGICAL(LGT) :: add0 +REAL(DFP) :: scale0 +INTEGER(I4B) :: ty, tx, nrow, ncol +LOGICAL(LGT) :: squareCase, problem, rectCase + +add0 = INPUT(default=.FALSE., option=addContribution) +scale0 = input(default=1.0_DFP, option=scale) +ty = SIZE(y) +tx = SIZE(x) +squareCase = isSquare(obj) +rectCase = isRectangle(obj) + +ncol = SIZE(obj, 2) !ncol +nrow = SIZE(obj, 1) !nrow + +problem = tx .NE. nrow .OR. ty .NE. ncol + +IF (add0 .AND. squareCase) THEN + CALL ATMUX(nrow, x, y0, obj%A, obj%csr%JA, obj%csr%IA) + CALL AXPY(X=y0, Y=y, A=scale0) + RETURN +END IF + +IF (add0 .AND. rectCase .AND. problem) THEN + CALL Errormsg( & + & msg="Mismatch in shapes... nrow = "//tostring(nrow)// & + & " ncol = "//tostring(ncol)//" size(x) = "//tostring(tx)// & + & " size(y) = "//tostring(ty), & + & file=__FILE__, & + & routine="csrMat_AtMatvec()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +IF (add0 .AND. rectCase) THEN + CALL ATMUXR(ncol, nrow, x, y0, obj%A, obj%csr%JA, obj%csr%IA) + CALL AXPY(X=y0, Y=y, A=scale0) + RETURN +END IF + +IF (squareCase) THEN + CALL ATMUX(nrow, x, y, obj%A, obj%csr%JA, obj%csr%IA) + CALL SCAL(X=y, A=scale0) + RETURN +END IF + +CALL ATMUXR(ncol, nrow, x, y, obj%A, obj%csr%JA, obj%csr%IA) +CALL SCAL(X=y, A=scale0) +END PROCEDURE csrMat_AtMatvec + +!---------------------------------------------------------------------------- +! MatVec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_MatVec1 +LOGICAL(LGT) :: trans +trans = INPUT(option=isTranspose, default=.FALSE.) + +IF (trans) THEN + CALL AtMatvec(obj=obj, x=x, y=y, addContribution=addContribution, & + & scale=scale) + RETURN +END IF + +CALL AMatvec(obj=obj, x=x, y=y, addContribution=addContribution, & + & scale=scale) +END PROCEDURE csrMat_MatVec1 + +!---------------------------------------------------------------------------- +! MatVec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_MatVec2 +CALL AMatvec(A=A, JA=JA, x=x, y=y, addContribution=addContribution, & + & scale=scale) +END PROCEDURE csrMat_MatVec2 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 new file mode 100644 index 000000000..32b1fc957 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_MatrixMarketIO@Methods.F90 @@ -0,0 +1,340 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(CSRMatrix_MatrixMarketIO) Methods +USE String_Class, ONLY: String +USE BaseMethod, ONLY: Tostring, ErrorMsg, ToUpperCase, Display, Reallocate +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE parse_first_dataline(aline, intvar, ierr, errmsg) + CHARACTER(*), INTENT(IN) :: aline + INTEGER(I4B), ALLOCATABLE, INTENT(OUT) :: intvar(:) + INTEGER(I4B), INTENT(OUT) :: ierr + CHARACTER(*), INTENT(OUT) :: errmsg + ! + TYPE(string) :: astr + TYPE(string), ALLOCATABLE :: tokens(:) + INTEGER(I4B) :: n, ii + ! + astr = TRIM(aline) + CALL astr%split(tokens=tokens) + IF (.NOT. ALLOCATED(tokens)) THEN + ierr = -10 + errmsg = "Tokenization failed while parsing first data line" + RETURN + END IF + ! + n = SIZE(tokens) + CALL reallocate(intvar, n) + ! + DO ii = 1, n + intvar(ii) = tokens(ii)%to_number(1_I4B) + END DO + ! + ierr = 0 + errmsg = "" + ! + DEALLOCATE (tokens) + astr = "" +END SUBROUTINE parse_first_dataline + +!---------------------------------------------------------------------------- +! ParseHeader +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ParseHeader +TYPE(String) :: astr +TYPE(String), ALLOCATABLE :: tokens(:) +INTEGER(I4B) :: n, ii + +astr = aline +CALL astr%split(tokens=tokens) + +IF (ALLOCATED(tokens)) THEN + n = SIZE(tokens) +ELSE + ierr = -10 + errmsg = "Cannot create tokens from header" + RETURN +END IF + +IF (n .EQ. 5) THEN + h1 = tokens(1)%chars() + h2 = tokens(2)%chars() + h3 = tokens(3)%chars() + h4 = tokens(4)%chars() + h5 = tokens(5)%chars() + ierr = 0 + errmsg = "" + DEALLOCATE (tokens) + RETURN +ELSE IF (n .GT. 5) THEN + ierr = n + errmsg = "Number of tokens are greater than 5" + DEALLOCATE (tokens) + RETURN +ELSE IF (n .LT. 5) THEN + ierr = n + errmsg = "Number of tokens are "//Tostring(n)//" , which is less than 5; " + DEALLOCATE (tokens) + RETURN +END IF + +END PROCEDURE ParseHeader + +!---------------------------------------------------------------------------- +! MMRead +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MMRead +CHARACTER(1024) :: aline, errmsg, iomsg +INTEGER(I4B) :: ierr, iostat, ii +INTEGER(I4B), ALLOCATABLE :: aint_vec(:) +CHARACTER(15) :: h1 +CHARACTER(6) :: h2 +CHARACTER(10) :: h3 +CHARACTER(7) :: h4 +CHARACTER(19) :: h5 + +READ (unitno, "(A)", iostat=iostat, iomsg=iomsg) aline + +IF (iostat .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error while reading the header of given file", & + & file=__FILE__, line=__LINE__, & + & routine="MMRead()", & + & unitno=stdout) + RETURN +END IF + +CALL ParseHeader(aline, h1, h2, h3, h4, h5, ierr, errmsg) + +IF (ierr .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error while parsing the header: msg = "//TRIM(errmsg), & + & file=__FILE__, line=__LINE__, & + & routine="MMRead()", & + & unitno=stdout) + RETURN +END IF + +CALL ToUpperCase(h2) + +IF (h2 .NE. "MATRIX") THEN + CALL ErrorMsg( & + & msg="The second arg of header is "//TRIM(h2)//" it should be matrix.", & + & file=__FILE__, line=__LINE__, & + & routine="MMRead()", & + & unitno=stdout) + RETURN +END IF + +field = TRIM(h4) +CALL ToUpperCase(h4) +IF (h4 .NE. "REAL" .AND. h4 .NE. "INTEGER" & + & .AND. h4 .NE. "COMPLEX" .AND. h4 .NE. "PATTERN") THEN + CALL ErrorMsg( & + & msg="The fourth arg of header is "//TRIM(h4)//", it should real or & + & INTEGER.", & + & file=__FILE__, line=__LINE__, & + & routine="MMRead() ", & + & unitno=stdout) + RETURN +END IF + +rep = TRIM(h3) +CALL ToUpperCase(h3) + +IF (h3 .NE. "COORDINATE" .AND. h3 .NE. "ARRAY") THEN + CALL ErrorMsg( & + & msg="The third arg of header is "//TRIM(h3)// & + & ", it should coordinate or array.", & + & file=__FILE__, line=__LINE__, & + & routine="MMRead()", & + & unitno=stdout) + RETURN +END IF + +symm = TRIM(h5) +CALL ToUpperCase(h5) + +IF (h5 .NE. 'GENERAL' .AND. h5 .NE. 'SYMMETRIC' & + & .AND. h5 .NE. 'HERMITIAN' & + & .AND. h5 .NE. 'SKEW-SYMMETRIC') THEN + CALL ErrorMsg( & + & msg="The 5th arg of header is "//TRIM(h5)//", & + & it should be ['geneal', 'symmetric', & + & 'skew-symmetric'].", & + & file=__FILE__, line=__LINE__, & + & routine="MMRead()", & + & unitno=stdout) + RETURN +END IF +! +! Read comments +! +DO + READ (unitno, "(A)", iostat=iostat, iomsg=iomsg) aline + + IF (aline(1:1) .NE. "%") THEN + EXIT + END IF + + IF (IS_IOSTAT_END(iostat)) THEN + EXIT + ELSE IF (iostat .NE. 0) THEN + CALL ErrorMsg(& + & msg="Error while reading comments in file; msg = "//TRIM(iomsg), & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + +END DO +! +! Read the main data +! +BACKSPACE (unitno) +READ (unitno, "(A)", iostat=iostat, iomsg=iomsg) aline + +IF (iostat .NE. 0) THEN + CALL ErrorMsg(& + & msg="Error while reading first line of data (after comments); msg = "& + & //TRIM(iomsg), & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN +END IF + +CALL parse_first_dataline(aline, aint_vec, ierr, errmsg) + +IF (ierr .NE. 0) THEN + CALL ErrorMsg(& + & msg="Error while reading first line of data (after comments); msg = " & + & //TRIM(errmsg), & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN +END IF + +IF (h3 .EQ. "COORDINATE") THEN + IF (SIZE(aint_vec) .NE. 3) THEN + CALL ErrorMsg(& + & msg="For sparse matrix three args should be defined & + & in first row of data (below comments)", & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + rows = aint_vec(1) + cols = aint_vec(2) + nnz = aint_vec(3) +ELSEIF (h3 .EQ. "ARRAY") THEN + IF (SIZE(aint_vec) .NE. 2) THEN + CALL ErrorMsg(& + & msg="For dense matrix two args should be defined & + & in first row of data (below comments)", & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + rows = aint_vec(1) + cols = aint_vec(2) + nnz = rows * cols +END IF + +CALL Reallocate(indx, nnz, jndx, nnz) + +IF (h4 .EQ. "REAL") THEN + IF (.NOT. PRESENT(rval)) THEN + CALL ErrorMsg(& + & msg="rval should be present for real field", & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + CALL Reallocate(rval, nnz) + ! + DO ii = 1, nnz + READ (unitno, *, iostat=iostat, iomsg=iomsg) indx(ii), jndx(ii), rval(ii) + IF (IS_IOSTAT_END(iostat)) THEN + EXIT + ELSE IF (iostat .NE. 0) THEN + CALL ErrorMsg(& + & msg="Error while reading "//Tostring(ii)// & + & "th nonzero entry from the file; msg = "//TRIM(iomsg), & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + END DO +ELSEIF (h4 .EQ. "INTEGER") THEN + IF (.NOT. PRESENT(ival)) THEN + CALL ErrorMsg(& + & msg="ival should be present for integer field", & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + CALL Reallocate(ival, nnz) + ! + DO ii = 1, nnz + READ (unitno, *, iostat=iostat, iomsg=iomsg) indx(ii), jndx(ii), ival(ii) + IF (IS_IOSTAT_END(iostat)) THEN + EXIT + ELSE IF (iostat .NE. 0) THEN + CALL ErrorMsg(& + & msg="Error while reading "//Tostring(ii)// & + & "th nonzero entry from the file; msg = "//TRIM(iomsg), & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + END DO +ELSEIF (h4 .EQ. "COMPLEX") THEN + CALL ErrorMsg(& + & msg="Currently complex field is not supported", & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + ! +ELSEIF (h4 .EQ. "pattern") THEN + DO ii = 1, nnz + READ (unitno, *, iostat=iostat, iomsg=iomsg) indx(ii), jndx(ii) + IF (IS_IOSTAT_END(iostat)) THEN + EXIT + ELSE IF (iostat .NE. 0) THEN + CALL ErrorMsg(& + & msg="Error while reading "//Tostring(ii)// & + & "th nonzero entry from the file; msg = "//TRIM(iomsg), & + & file=__FILE__, routine="MMRead()", & + & line=__LINE__, unitno=stdout) + RETURN + END IF + END DO +END IF + +IF (ALLOCATED(aint_vec)) DEALLOCATE (aint_vec) + +END PROCEDURE MMRead + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 new file mode 100644 index 000000000..83677aef9 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_ReorderingMethods@Methods.F90 @@ -0,0 +1,95 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(CSRMatrix_ReorderingMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! NestedDissect +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_NestedDissect +#ifdef USE_METIS +INTEGER(I4B) :: nrow, ncol, nnz, ii, jj, kk, nbr, ll +INTEGER(I4B), ALLOCATABLE :: XADJ(:), ADJNCY(:) +! +nrow = SIZE(csrMat, 1) +ncol = SIZE(csrMat, 2) +nnz = getNNZ(csrMat) +CALL REALLOCATE(XADJ, nrow + 1, ADJNCY, nnz) +CALL REALLOCATE(reorder%PERM, nrow, reorder%IPERM, nrow) +reorder%name = 'NodeND' +XADJ(1) = 1 +kk = 0 +DO ii = 1, nrow + nbr = 0 + DO jj = csrMat%csr%IA(ii), csrMat%csr%IA(ii + 1) - 1 + ll = csrMat%csr%JA(jj) + IF (ll .NE. ii) THEN + nbr = nbr + 1 + kk = kk + 1 + ADJNCY(kk) = ll + END IF + END DO + XADJ(ii + 1) = XADJ(ii) + nbr +END DO +ll = XADJ(SIZE(xadj)) - 1 +CALL MetisNodeND(XADJ=XADJ, ADJNCY=ADJNCY(1:ll), PERM=reorder%PERM, & + & IPERM=reorder%IPERM) +IF (ALLOCATED(XADJ)) DEALLOCATE (XADJ) +IF (ALLOCATED(ADJNCY)) DEALLOCATE (ADJNCY) +#else +CALL ErrorMSG( & + & Msg="Metis library not installed!", & + & File="CSRMatrix_ReorderingMethods@Methods.F90", & + & Routine="csrMat_NestedDissect()", & + & Line=__LINE__, & + & UnitNo=stdout) +STOP +#endif +END PROCEDURE csrMat_NestedDissect + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_reorderDisplay +INTEGER(I4B) :: I +I = INPUT(Default=stdout, Option=unitNo) +CALL Display(obj%name, "# NAME : ") +CALL DISP(x=obj%PERM, title="PERM=", advance="NO", unit=I, & + & style='left') +CALL DISP(x=obj%IPERM, title="IPERM=", advance="DOUBLE", & + & unit=I, style='left') +END PROCEDURE csrMat_reorderDisplay + +!---------------------------------------------------------------------------- +! Permute +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_Permute2 +ans = Permute(obj=obj, rowPERM=rowPERM%IPERM, colPERM=colPERM%IPERM, & + & isValues=.TRUE.) +END PROCEDURE csrMat_Permute2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 new file mode 100644 index 000000000..089f37184 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SchurMethods@Methods.F90 @@ -0,0 +1,322 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_SchurMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! AMatvec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_AMatvec +REAL(DFP), ALLOCATABLE :: dummyVec(:) +INTEGER(I4B) :: m, n + +n = SIZE(B, 1) +m = SIZE(B, 2) + +IF (n .NE. SIZE(A, 1) & + & .OR. SIZE(A, 2) .NE. n & + & .OR. SIZE(x) .NE. m & + & .OR. SIZE(y) .NE. m) THEN + CALL Errormsg( & + & msg="Shape of A and B are not compatible", & + & file=__FILE__, & + & routine="csrMat_AMatvec()", & + & line=__LINE__, & + & unitno=stderr) + STOP +END IF + +ALLOCATE (dummyVec(n)) + +CALL MatVec(obj=B, x=x, y=dummyVec, isTranspose=.FALSE.) +CALL LinSolve(A=A, B=dummyVec, isTranspose=.FALSE., isFactored=.TRUE.) +CALL MatVec(obj=B, x=dummyVec, y=y, isTranspose=.TRUE.) + +DEALLOCATE (dummyVec) + +END PROCEDURE csrMat_AMatvec + +!---------------------------------------------------------------------------- +! AtMatvec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_AtMatVec +REAL(DFP), ALLOCATABLE :: dummyVec(:) +INTEGER(I4B) :: m, n +LOGICAL(LGT) :: isASym0 + +n = SIZE(B, 1) +m = SIZE(B, 2) + +IF (n .NE. SIZE(A, 1) & + & .OR. SIZE(A, 2) .NE. n & + & .OR. SIZE(x) .NE. m & + & .OR. SIZE(y) .NE. m) THEN + CALL Errormsg( & + & msg="Shape of A and B are not compatible", & + & file=__FILE__, & + & routine="csrMat_AtMatvec()", & + & line=__LINE__, & + & unitno=stderr) + STOP +END IF + +isASym0 = Input(option=isASym, default=.FALSE.) + +ALLOCATE (dummyVec(n)) + +CALL MatVec(obj=B, x=x, y=dummyVec, isTranspose=.FALSE.) + +CALL LinSolve( & + & A=A, & + & B=dummyVec, & + & isTranspose=(.NOT. isASym0), & + & isFactored=.TRUE.) + +CALL MatVec( & + & obj=B, & + & x=dummyVec, & + & y=y, & + & isTranspose=.TRUE.) + +DEALLOCATE (dummyVec) + +END PROCEDURE csrMat_AtMatVec + +!---------------------------------------------------------------------------- +! MatVec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_SchurMatVec +LOGICAL(LGT) :: trans +trans = INPUT(option=isTranspose, default=.FALSE.) +IF (trans) THEN + CALL csrMat_AtMatvec(A=A, B=B, x=x, y=y, isASym=isASym) +ELSE + CALL csrMat_AMatvec(A=A, B=B, x=x, y=y) +END IF +END PROCEDURE csrMat_SchurMatVec + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymSchurLargestEigenVal1 +CHARACTER(*), PARAMETER :: myName = "SymSchurLargestEigenVal1" +INTEGER(I4B), PARAMETER :: nev = 1 +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0 +CHARACTER(1), PARAMETER :: bmat = "I" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, d(nev), sigma +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +! +! int scalar +! +which0 = INPUT(default="LA", option=which) +n = SIZE(B, 2) +ncv0 = input(default=MIN(20_I4B, n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +! +! iparam +! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 1 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + ! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + ! + ! Perform MatVec Mult + ! y = MATMUL(mat, X) + ! x => WORKD(ipntr(1):ipntr(1)+N-1) + ! y => WORKD(ipntr(2):ipntr(2)+N-1) + ! + CALL SchurMatVec( & + & A=A, & + & B=B, & + & x=workd(ipntr(1):ipntr(1) + n - 1), & + & y=workd(ipntr(2):ipntr(2) + n - 1), & + & isTranspose=.FALSE., & + & isASym=.TRUE.) + ! + ELSE + EXIT + END IF +END DO +! +! we are not getting rvec, therefore ldz=1, +! othereise ldz = N +! +CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=d, z=v, ldz=1, sigma=sigma, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) +! +IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(INFO) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP +ELSE + ans = d(1) +END IF +! +DEALLOCATE (resid, v, workd, workl, SELECT) +! +END PROCEDURE SymSchurLargestEigenVal1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymSchurLargestEigenVal2 +CHARACTER(*), PARAMETER :: myName = "SymSchurLargestEigenVal2" +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0 +CHARACTER(1), PARAMETER :: bmat = "I" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, sigma +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +! +! int scalar +! +which0 = INPUT(default="LA", option=which) +n = SIZE(B, 2) + +ncv0 = input(default=MIN(MAX(20_I4B, 2 * nev + 1), n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +! +! iparam +! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 1 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + ! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + ! + ! Perform MatVec Mult + ! y = MATMUL(mat, X) + ! x => WORKD(ipntr(1):ipntr(1)+N-1) + ! y => WORKD(ipntr(2):ipntr(2)+N-1) + ! + CALL SchurMatVec( & + & A=A, & + & B=B, & + & x=workd(ipntr(1):ipntr(1) + n - 1), & + & y=workd(ipntr(2):ipntr(2) + n - 1), & + & isTranspose=.FALSE., & + & isASym=.TRUE.) + ! + ELSE + EXIT + END IF +END DO +! +! we are not getting rvec, therefore ldz=1, +! othereise ldz = N +! +CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=ans, z=v, ldz=1, sigma=sigma, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) +!! +IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(INFO) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP +END IF +! +DEALLOCATE (resid, v, workd, workl, SELECT) +! +END PROCEDURE SymSchurLargestEigenVal2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 new file mode 100644 index 000000000..eb22c1361 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockColMethods@Methods.F90 @@ -0,0 +1,241 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!! authors: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_SetBlockColMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockColumn1 +INTEGER(I4B) :: ii, jj, c(3), row_start, row_end +CLASS(DOF_), POINTER :: idofobj + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (icolumn .GT. SIZE(obj, 2)) THEN + CALL ErrorMSG( & + & Msg="icolumn is out of Bound", & + & File="CSRMatrix_Method@SetBlockColMethods.F90", & + & Routine="csrMat_setBlockColumn1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! +idofobj => GetDOFPointer(obj, 1) + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (ivar .GT. (.tNames.idofobj)) THEN + CALL ErrorMSG( & + & Msg="ivar is out of Bound", & + & File="CSRMatrix_Method@SetBlockColMethods.F90", & + & Routine="csrMat_setBlockColumn1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF ((obj.StorageFMT.1) .NE. FMT_DOF) THEN + CALL ErrorMSG( & + & Msg="For this rotuine storage format should FMT_DOF", & + & File="CSRMatrix_Method@SetBlockColMethods.F90", & + & Routine="csrMat_setBlockColumn1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! + !! start, end, stride of idof + !! +c = getNodeLoc(obj=idofobj, idof=(idofobj.DOFStartIndex.ivar)) +row_start = c(1) ! start +c = getNodeLoc(idofobj, (idofobj.DOFEndIndex.ivar)) +row_end = c(2) ! end + !! +DO ii = row_start, row_end + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + IF (obj%csr%JA(jj) .EQ. icolumn) & + & obj%A(jj) = value + END DO +END DO + !! +idofobj => NULL() + !! +END PROCEDURE csrMat_setBlockColumn1 + +!---------------------------------------------------------------------------- +! setBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockColumn2 +INTEGER(I4B) :: ii, c(3), row_start, row_end, jj +CLASS(DOF_), POINTER :: idofobj + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (SIZE(value) .LT. obj%csr%ncol) THEN + CALL ErrorMSG( & + & Msg="SIZE of row vector should be less than the number of col & + & in sparse matrix", & + & File="CSRMatrix_Method@SetBlockColMethods.F90", & + & Routine="csrMat_setBlockColumn2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF (icolumn .GT. SIZE(obj, 2)) THEN + CALL ErrorMSG( & + & Msg="icolumn is out of Bound", & + & File="CSRMatrix_Method@SetBlockColMethods.F90", & + & Routine="csrMat_setBlockColumn2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! +idofobj => GetDOFPointer(obj, 1) + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (ivar .GT. (.tNames.idofobj)) THEN + CALL ErrorMSG( & + & Msg="jVar is out of Bound", & + & File="CSRMatrix_Method@SetBlockColMethods.F90", & + & Routine="csrMat_setBlockColumn2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF ((obj.StorageFMT.1) .NE. FMT_DOF) THEN + CALL ErrorMSG( & + & Msg="For this rotuine storage format should FMT_DOF", & + & File="CSRMatrix_Method@SetBlockColMethods.F90", & + & Routine="csrMat_setBlockColumn2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! + !! start, end, stride + !! +c = getNodeLoc(obj=idofobj, idof=(idofobj.DOFStartIndex.ivar)) +row_start = c(1) ! start +c = getNodeLoc(obj=idofobj, idof=(idofobj.DOFEndIndex.ivar)) +row_end = c(2) ! end + !! +DO ii = row_start, row_end + DO jj = obj%csr%IA(ii), obj%csr%IA(ii + 1) - 1 + IF (obj%csr%JA(jj) .EQ. icolumn) & + & obj%A(jj) = value(ii) + END DO +END DO + !! +idofobj => NULL() + !! +END PROCEDURE csrMat_setBlockColumn2 + +!---------------------------------------------------------------------------- +! setBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockColumn3 +CALL SetBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(obj=obj%csr%jdof, nodeNum=nodenum, & + & ivar=jvar, idof=idof), & + & value=value) +END PROCEDURE csrMat_setBlockColumn3 + +!---------------------------------------------------------------------------- +! setBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockColumn4 +CALL SetBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getNodeLoc(obj=obj%csr%jdof, nodeNum=nodenum, & + & ivar=jvar, idof=idof), & + & value=value) +END PROCEDURE csrMat_setBlockColumn4 + +!---------------------------------------------------------------------------- +! setBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockColumn5 +CALL SetBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getIndex( & + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) +END PROCEDURE csrMat_setBlockColumn5 + +!---------------------------------------------------------------------------- +! setBlockColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockColumn6 +CALL SetBlockColumn( & + & obj=obj, & + & ivar=ivar, & + & icolumn=getIndex( & + & obj=obj%csr%jdof, & + & nodeNum=nodenum, & + & ivar=jvar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) +END PROCEDURE csrMat_setBlockColumn6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 new file mode 100644 index 000000000..36eb0d321 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetBlockRowMethods@Methods.F90 @@ -0,0 +1,233 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!! authors: Vikas Sharma, Ph. D. +! date: 14 July 2021 +! summary: This submodule contains the methods for sparse matrix + +SUBMODULE(CSRMatrix_SetBlockRowMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockRow1 +INTEGER(I4B) :: jj, c(3), col_start, col_end +CLASS(DOF_), POINTER :: jdofobj + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (irow .GT. SIZE(obj, 1)) THEN + CALL ErrorMSG( & + & Msg="irow is out of Bound", & + & File="CSRMatrix_Method@SetBlockRowMethods.F90", & + & Routine="csrMat_setBlockRow1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! +jdofobj => GetDOFPointer(obj, 2) + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (jvar .GT. (.tNames.jdofobj)) THEN + CALL ErrorMSG( & + & Msg="jVar is out of Bound", & + & File="CSRMatrix_Method@SetBlockRowMethods.F90", & + & Routine="csrMat_setBlockRow1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF ((obj.StorageFMT.2) .NE. FMT_DOF) THEN + CALL ErrorMSG( & + & Msg="For this rotuine storage format should FMT_DOF", & + & File="CSRMatrix_Method@SetBlockRowMethods.F90", & + & Routine="csrMat_setBlockRow1", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif +!! +!! start, end, stride of idof +!! +c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFStartIndex.jvar)) +col_start = c(1) ! start +c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFEndIndex.jvar)) +col_end = c(2) ! end +!! +DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 + IF ((jj .GE. col_start) .AND. jj .LE. col_end) & + & obj%A(jj) = value +END DO + !! +jdofobj => NULL() + !! +END PROCEDURE csrMat_setBlockRow1 + +!---------------------------------------------------------------------------- +! setBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockRow2 +INTEGER(I4B) :: jj, c(3), col_start, col_end +CLASS(DOF_), POINTER :: jdofobj + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (SIZE(value) .LT. obj%csr%ncol) THEN + CALL ErrorMSG( & + & Msg="SIZE of row vector should be less than the number of col & + & in sparse matrix", & + & File="CSRMatrix_Method@SetBlockRowMethods.F90", & + & Routine="csrMat_setBlockRow2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF (irow .GT. SIZE(obj, 1)) THEN + CALL ErrorMSG( & + & Msg="irow is out of Bound", & + & File="CSRMatrix_Method@SetBlockRowMethods.F90", & + & Routine="csrMat_setBlockRow2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! +jdofobj => GetDOFPointer(obj, 2) + !! +#ifdef DEBUG_VER + !! + !! check + !! +IF (jvar .GT. (.tNames.jdofobj)) THEN + CALL ErrorMSG( & + & Msg="jVar is out of Bound", & + & File="CSRMatrix_Method@SetBlockRowMethods.F90", & + & Routine="csrMat_setBlockRow2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! + !! check + !! +IF ((obj.StorageFMT.2) .NE. FMT_DOF) THEN + CALL ErrorMSG( & + & Msg="For this rotuine storage format should FMT_DOF", & + & File="CSRMatrix_Method@SetBlockRowMethods.F90", & + & Routine="csrMat_setBlockRow2", & + & Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! + !! start, end, stride of idof + !! +c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFStartIndex.jvar)) +col_start = c(1) ! start +c = getNodeLoc(obj=jdofobj, idof=(jdofobj.DOFEndIndex.jvar)) +col_end = c(2) ! end + !! +DO jj = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 + IF ((jj .GE. col_start) .AND. jj .LE. col_end) & + & obj%A(jj) = value(obj%csr%JA(jj)) +END DO +!! +jdofobj => NULL() +!! +END PROCEDURE csrMat_setBlockRow2 + +!---------------------------------------------------------------------------- +! setBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockRow3 +CALL SetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc(obj=obj%csr%idof, nodeNum=nodenum, & + & ivar=ivar, idof=idof), & + & value=value) +END PROCEDURE csrMat_setBlockRow3 + +!---------------------------------------------------------------------------- +! setBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockRow4 +CALL SetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getNodeLoc(obj=obj%csr%idof, nodeNum=nodenum, & + & ivar=ivar, idof=idof), & + & value=value) +END PROCEDURE csrMat_setBlockRow4 + +!---------------------------------------------------------------------------- +! setBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockRow5 +CALL SetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getIndex( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) +END PROCEDURE csrMat_setBlockRow5 + +!---------------------------------------------------------------------------- +! setBlockRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setBlockRow6 +CALL SetBlockRow( & + & obj=obj, & + & jvar=jvar, & + & irow=getIndex( & + & obj=obj%csr%idof, & + & nodeNum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) +END PROCEDURE csrMat_setBlockRow6 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 new file mode 100644 index 000000000..954e8a246 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetColMethods@Methods.F90 @@ -0,0 +1,351 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: It contains method for setting values in [[CSRMatrix_]] + +SUBMODULE(CSRMatrix_SetColMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn1 + !! +INTEGER(I4B) :: i, j + !! +#ifdef DEBUG_VER + !! +IF (SIZE(value) .LT. obj%csr%nrow .OR. icolumn .GT. SIZE(obj, 2)) THEN + CALL ErrorMSG(Msg="SIZE of column vector should be same as number of & + & rows in sparse matrix", & + & File="CSRMatrix_Method@setMethod.F90", & + & Routine="csrMat_setColumn1", Line=__LINE__, UnitNo=stdout) + RETURN +END IF + !! +#endif + !! +DO i = 1, obj%csr%nrow + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + IF (obj%csr%JA(j) .EQ. icolumn) THEN + obj%A(j) = value(i) + EXIT + END IF + END DO +END DO + !! +END PROCEDURE csrMat_setColumn1 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn1b + !! +INTEGER(I4B) :: i, j, k + !! +DO i = 1, obj%csr%nrow + DO k = 1, SIZE(icolumn) + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + IF (obj%csr%JA(j) .EQ. icolumn(k)) THEN + obj%A(j) = value(i) + EXIT + END IF + END DO + END DO +END DO + !! +END PROCEDURE csrMat_setColumn1b + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn2 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & idof=idof), & + & value=value) + !! +END PROCEDURE csrMat_setColumn2 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn3 + !! +INTEGER(I4B) :: i, j + !! +DO i = 1, obj%csr%nrow + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + IF (obj%csr%JA(j) .EQ. icolumn) obj%A(j) = value + END DO +END DO + !! +END PROCEDURE csrMat_setColumn3 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn3b + !! +INTEGER(I4B) :: i, j, k + !! +DO i = 1, obj%csr%nrow + DO k = 1, SIZE(icolumn) + DO j = obj%csr%IA(i), obj%csr%IA(i + 1) - 1 + IF (obj%csr%JA(j) .EQ. icolumn(k)) THEN + obj%A(j) = value + EXIT + END IF + END DO + END DO +END DO + !! +END PROCEDURE csrMat_setColumn3b + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn4 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & idof=idof),& + & value=value) + !! +END PROCEDURE csrMat_setColumn4 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn5 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, idof=idof), & + & value=value) + !! +END PROCEDURE csrMat_setColumn5 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn6 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & idof=idof), & + & value=value) + !! +END PROCEDURE csrMat_setColumn6 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn7 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn7 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn8 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn8 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn9 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn9 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn10 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn10 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn11 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn11 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn12 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn12 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn13 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn13 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn14 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn14 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn15 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn15 + +!---------------------------------------------------------------------------- +! setColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setColumn16 + !! +CALL SetColumn(obj=obj, & + & icolumn=getNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setColumn16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 new file mode 100644 index 000000000..8283f5447 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 @@ -0,0 +1,403 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: It contains method for setting values in [[CSRMatrix_]] + +SUBMODULE(CSRMatrix_SetMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SetSingleValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SetSingleValue +obj%A(indx) = VALUE +END PROCEDURE obj_SetSingleValue + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set0 +! Internal variables +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) +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) = VALUE(ii, kk) + EXIT + END IF + END DO + END DO +END DO +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +END PROCEDURE obj_set0 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set1 +REAL(DFP), ALLOCATABLE :: m2(:, :) +INTEGER(I4B) :: tdof + +tdof = .tdof.obj%csr%idof +SELECT CASE (storageFMT) +CASE (FMT_NODES) + IF ((obj.StorageFMT.1) .EQ. FMT_NODES) THEN + m2 = VALUE + ELSE + CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, & + & 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) + END IF +END SELECT +CALL Set(obj=obj, nodenum=nodenum, VALUE=m2) +IF (ALLOCATED(m2)) DEALLOCATE (m2) +END PROCEDURE obj_set1 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set2 +obj%A = VALUE +END PROCEDURE obj_set2 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set3 +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) = VALUE +END DO +! +END PROCEDURE obj_set3 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set4 +CALL set(obj=obj, & + & irow=GetNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=iNodeNum, idof=iDOF), & + & icolumn=GetNodeLoc( & + & obj=obj%csr%jdof, & + & nodenum=jNodeNum, idof=jDOF), & + & VALUE=VALUE) +END PROCEDURE obj_set4 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set5 +REAL(DFP), ALLOCATABLE :: m2(:, :) +INTEGER(I4B) :: tdof1, tdof2 +! +tdof1 = .tdof. (obj%csr%idof) +tdof2 = .tdof. (obj%csr%jdof) +! +CALL Reallocate(m2, tdof1 * SIZE(nodenum), tdof2 * SIZE(nodenum)) +m2 = VALUE +CALL Set(obj=obj, nodenum=nodenum, VALUE=m2) +! +DEALLOCATE (m2) +END PROCEDURE obj_set5 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set6 +! 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) = VALUE(ii, kk) + EXIT + END IF + END DO + END DO +END DO +! +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +! +END PROCEDURE obj_set6 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set7 +CALL set(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) +END PROCEDURE obj_set7 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set8 +! 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) +! +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) = VALUE(ii, kk) + EXIT + END IF + END DO + END DO +END DO +! +DEALLOCATE (row, col) +! +END PROCEDURE obj_set8 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set9 +CALL set(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) +END PROCEDURE obj_set9 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set10 +! 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) = VALUE + EXIT + END IF + END DO + END DO +END DO +! +DEALLOCATE (row, col) +! +END PROCEDURE obj_set10 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set11 +! 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) = VALUE + EXIT + END IF + END DO + END DO +END DO +! +DEALLOCATE (row, col) +! +END PROCEDURE obj_set11 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set12 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj, kk +! +row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + & spacecompo=ispacecompo, timecompo=itimecompo) +col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + & spacecompo=jspacecompo, timecompo=jtimecompo) +! +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) = VALUE + EXIT + END IF + END DO + END DO +END DO +! +DEALLOCATE (row, col) +! +END PROCEDURE obj_set12 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set13 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj, kk +! +row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + & spacecompo=ispacecompo, timecompo=itimecompo) +col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + & spacecompo=jspacecompo, timecompo=jtimecompo) +! +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) = VALUE + EXIT + END IF + END DO + END DO +END DO +! +DEALLOCATE (row, col) +! +END PROCEDURE obj_set13 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set14 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B) :: ii, jj, kk + +row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + & spacecompo=ispacecompo, timecompo=itimecompo) +col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + & spacecompo=jspacecompo, timecompo=jtimecompo) +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) = VALUE + EXIT + END IF + END DO + END DO +END DO +DEALLOCATE (row, col) +END PROCEDURE obj_set14 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set15 +CALL COPY(Y=obj%A, X=VALUE%A) +IF (PRESENT(scale)) THEN + CALL SCAL(X=obj%A, A=scale) +END IF +END PROCEDURE obj_set15 + +!---------------------------------------------------------------------------- +! SetIA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SetIA +CALL SetIA(obj%csr, irow, VALUE) +END PROCEDURE obj_SetIA + +!---------------------------------------------------------------------------- +! SetJA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SetJA +CALL SetJA(obj%csr, indx, VALUE) +END PROCEDURE obj_SetJA + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 new file mode 100644 index 000000000..ea518429f --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetRowMethods@Methods.F90 @@ -0,0 +1,314 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: It contains method for setting values in [[CSRMatrix_]] + +SUBMODULE(CSRMatrix_SetRowMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow1 + !! +#ifdef DEBUG_VER + !! +IF (SIZE(value) .LT. obj%csr%ncol .OR. irow .GT. SIZE(obj, 1)) THEN + CALL ErrorMSG( & + & Msg="SIZE of value vector should be same as number of col & + & in sparse matrix or irow is out of bound", & + & File="CSRMatrix_Method@setMethod.F90", & + & Routine="csrMat_setRow1", Line=__LINE__, UnitNo=stdout) + RETURN +END IF +#endif + !! +obj%A(obj%csr%IA(irow):obj%csr%IA(irow + 1) - 1) = value( & + & obj%csr%JA(obj%csr%IA(irow):obj%csr%IA(irow + 1) - 1)) + !! +END PROCEDURE csrMat_setRow1 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow1b +INTEGER(I4B) :: ii + !! +DO ii = 1, size(irow) + !! + obj%A(obj%csr%IA(irow(ii)):obj%csr%IA(irow(ii) + 1) - 1) & + & = value(obj%csr%JA(obj%csr%IA(irow(ii)) & + & :obj%csr%IA(irow(ii) + 1) - 1)) + !! +END DO + !! +END PROCEDURE csrMat_setRow1b + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow2 +CALL csrMat_setRow1( & + & obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & idof=idof), & + & value=value) +END PROCEDURE csrMat_setRow2 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow3 +obj%A(obj%csr%IA(irow):obj%csr%IA(irow + 1) - 1) = value +END PROCEDURE csrMat_setRow3 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow3b +INTEGER(I4B) :: ii + !! +DO ii = 1, size(irow) + obj%A(obj%csr%IA(irow(ii)):obj%csr%IA(irow(ii) + 1) - 1) = value +END DO + !! +END PROCEDURE csrMat_setRow3b + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow4 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc(obj=obj%csr%idof, nodenum=nodenum, idof=idof),& + & value=value) + !! +END PROCEDURE csrMat_setRow4 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow5 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc(obj=obj%csr%idof, nodenum=nodenum, ivar=ivar, & + & idof=idof), & + & value=value) + !! +END PROCEDURE csrMat_setRow5 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow6 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc(obj=obj%csr%idof, nodenum=nodenum, ivar=ivar, & + & idof=idof), & + & value=value) + !! +END PROCEDURE csrMat_setRow6 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow7 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow7 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow8 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow8 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow9 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow9 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow10 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow10 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow11 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow11 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow12 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow12 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow13 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow13 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow14 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow14 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow15 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow15 + +!---------------------------------------------------------------------------- +! setRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_setRow16 + !! +CALL SetRow(obj=obj, & + & irow=getNodeLoc( & + & obj=obj%csr%idof, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo), & + & value=value) + !! +END PROCEDURE csrMat_setRow16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 new file mode 100644 index 000000000..339f0bc13 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SparsityMethods@Methods.F90 @@ -0,0 +1,96 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: It contains method for setting values in [[CSRMatrix_]] + +SUBMODULE(CSRMatrix_SparsityMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity1 +CALL setSparsity(obj=obj%csr, row=row, col=col) +END PROCEDURE obj_setSparsity1 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity2 +CALL setSparsity(obj=obj%csr, row=row, col=col) +END PROCEDURE obj_setSparsity2 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity3 +CALL setSparsity(obj=obj%csr, row=row, col=col, ivar=ivar, jvar=jvar) +END PROCEDURE obj_setSparsity3 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity4 +CALL setSparsity(obj=obj%csr, row=row, col=col, ivar=ivar, jvar=jvar) +END PROCEDURE obj_setSparsity4 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity_final +REAL(DFP), ALLOCATABLE :: tempA(:) +INTEGER(I4B) :: m +! +IF (.NOT. obj%csr%isSparsityLock) CALL setSparsity(obj%csr) +IF (ALLOCATED(obj%A)) THEN + m = SIZE(obj%A) + IF (m .EQ. 0) THEN + CALL Reallocate(obj%A, obj%csr%nnz) + ELSE IF (m .NE. obj%csr%nnz) THEN + tempA = obj%A + CALL Reallocate(obj%A, obj%csr%nnz) + IF (SIZE(obj%A) .GE. SIZE(tempA)) THEN + obj%A(1:SIZE(tempA)) = tempA(:) + ELSE + obj%A(1:obj%csr%nnz) = tempA(1:obj%csr%nnz) + END IF + DEALLOCATE (tempA) + END IF +ELSE + CALL Reallocate(obj%A, obj%csr%nnz) +END IF +!> Sort entries according to their column index +CALL CSORT(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, .TRUE.) +obj%csr%isSorted = .TRUE. +obj%csr%isSparsityLock = .FALSE. +CALL setSparsity(obj%csr) +END PROCEDURE obj_setSparsity_final + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 new file mode 100644 index 000000000..70aed6273 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SpectralMethods@Methods.F90 @@ -0,0 +1,458 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(CSRMatrix_SpectralMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SymSmallestEigenVal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLargestEigenVal1 +CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal1" +INTEGER(I4B), PARAMETER :: nev = 1 +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0 +CHARACTER(1), PARAMETER :: bmat = "I" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, d(nev), sigma +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +! +! int scalar +! +which0 = INPUT(default="LA", option=which) +n = SIZE(mat, 1) +ncv0 = input(default=MIN(20_I4B, n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +! +! iparam +! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 1 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + ! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + ! + ! Perform MatVec Mult + ! y = MATMUL(mat, X) + ! x => WORKD(ipntr(1):ipntr(1)+N-1) + ! y => WORKD(ipntr(2):ipntr(2)+N-1) + ! + CALL MatVec( & + & obj=mat, & + & x=workd(ipntr(1):ipntr(1) + n - 1), & + & y=workd(ipntr(2):ipntr(2) + n - 1)) + ! + ELSE + EXIT + END IF +END DO +! +! we are not getting rvec, therefore ldz=1, +! othereise ldz = N +! +CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=d, z=v, ldz=1, sigma=sigma, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) +! +IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(INFO) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP +ELSE + ans = d(1) +END IF +! +DEALLOCATE (resid, v, workd, workl, SELECT) +! +END PROCEDURE SymLargestEigenVal1 + +!---------------------------------------------------------------------------- +! SymLargestEigenVal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLargestEigenVal2 +CHARACTER(*), PARAMETER :: myName = "SymLargestEigenVal2" +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0 +CHARACTER(1), PARAMETER :: bmat = "I" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, sigma +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +! +! int scalar +! +which0 = INPUT(default="LA", option=which) +n = SIZE(mat, 1) +ncv0 = input(default=MIN(MAX(20_I4B, 2 * nev + 1), n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +! +! iparam +! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 1 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +! +DO + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + ! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + ! + ! Perform MatVec Mult + ! y = MATMUL(mat, X) + ! x => WORKD(ipntr(1):ipntr(1)+N-1) + ! y => WORKD(ipntr(2):ipntr(2)+N-1) + ! + CALL MatVec( & + & obj=mat, & + & x=workd(ipntr(1):ipntr(1) + n - 1), & + & y=workd(ipntr(2):ipntr(2) + n - 1)) + ! + ELSE + EXIT + END IF +END DO +! +! we are not getting rvec, therefore ldz=1, +! othereise ldz = N +! +CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=ans, z=v, ldz=1, sigma=sigma, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) +!! +IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(INFO) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP +END IF +! +DEALLOCATE (resid, v, workd, workl, SELECT) +! +END PROCEDURE SymLargestEigenVal2 + +!---------------------------------------------------------------------------- +! SymSmallestEigenVal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymSmallestEigenVal1 +CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal1" +INTEGER(I4B), PARAMETER :: nev = 1 +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), ipntr(11), maxIter0, n, & + & ncv0, ii +CHARACTER(1), PARAMETER :: bmat = "I", uplo = "U" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, d(nev), sigma0 +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +INTEGER(I4B) :: info1 +! +! int scalar +! +sigma0 = 0.0_DFP +! +! note to get smallest value, we transform the problem to +! find largest value. +! +IF (PRESENT(which)) THEN + which0 = "L"//which(2:2) +ELSE + which0 = "LA" +END IF +! +n = SIZE(mat, 1) +ncv0 = input(default=MIN(20_I4B, n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +! +! iparam +! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 3 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +! +DO + ! + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + EXIT + END IF + ! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + ! + ! LU Solve + ! mat0 * y = x + ! x => WORKD(ipntr(1):ipntr(1)+N-1) + ! y => WORKD(ipntr(2):ipntr(2)+N-1) + ! + CALL LinSolve( & + & A=mat, & + & X=WORKD(ipntr(2):ipntr(2) + N - 1), & + & B=WORKD(ipntr(1):ipntr(1) + N - 1), & + & isTranspose=.FALSE., & + & isFactored=.TRUE., & + & PrintStat=yes_no_t%NO, & + & info=info1) + ! + IF (info1 .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error occured in LinSolve() errorCode="//tostring(info1), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymSmallestEigenVal1()") + STOP + END IF + !! + ELSE + EXIT + END IF +END DO +! +! we are not getting rvec, therefore ldz=1, +! othereise ldz = N +! +IF (info .EQ. 0) THEN + CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=d, z=v, ldz=1, sigma=sigma0, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + STOP + ELSE + ans = d(1) + END IF +END IF +! +DEALLOCATE (resid, v, workd, workl, SELECT) +! +END PROCEDURE SymSmallestEigenVal1 + +!---------------------------------------------------------------------------- +! SymSmallestEigenVal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymSmallestEigenVal2 +CHARACTER(*), PARAMETER :: myName = "SymSmallestEigenVal2" +INTEGER(I4B) :: ido, lworkl, ldv, info, iparam(11), & + & ipntr(11), maxIter0, n, ncv0, ii +CHARACTER(1), PARAMETER :: bmat = "I" +CHARACTER(2) :: which0 +REAL(DFP) :: tol0, sigma0 +REAL(DFP), ALLOCATABLE :: resid(:), v(:, :), workd(:), workl(:) +TYPE(String) :: err_msg +LOGICAL(LGT), ALLOCATABLE :: SELECT(:) +INTEGER(I4B) :: info1 +! +! int scalar +! +sigma0 = 0.0_DFP +! sigma0 = INPUT(default=0.0_DFP, option=sigma) +! +! note to get smallest value, we transform the problem to +! find largest value. +! +IF (PRESENT(which)) THEN + which0 = "L"//which(2:2) +ELSE + which0 = "LA" +END IF +! +n = SIZE(mat, 1) +ncv0 = input(default=MIN(20_I4B, n), option=ncv) +lworkl = ncv0 * (ncv0 + 8) +ALLOCATE (resid(n), v(n, ncv0), workd(3 * n), workl(lworkl), SELECT(ncv0)) +ldv = SIZE(v, 1) +ido = 0 +info = 0 +maxIter0 = INPUT(option=maxIter, default=10 * n) +tol0 = INPUT(option=tol, default=zero) +! +! iparam +! +iparam(1) = 1 !! ishift +iparam(3) = maxIter0 !! maxiter +iparam(4) = 1 !! nb +iparam(7) = 3 !! mode +iparam(2) = 0 !! deprecated +iparam(5) = 0 !! out +iparam(6) = 0 !! iupd, deprecated +iparam(8) = 0 !! np, na +iparam(9:11) = 0 !! OUT +ipntr = 0 +! +DO + ! + CALL F77_SAUPD( & + & ido=ido, bmat=bmat, n=n, which=which0, nev=nev, & + & tol=tol0, resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, workl=workl, & + & lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SAUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0_DFP + STOP + END IF + ! + IF (ido .EQ. -1 .OR. ido .EQ. 1) THEN + ! + ! LU Solve + ! mat0 * y = x + ! x => WORKD(ipntr(1):ipntr(1)+N-1) + ! y => WORKD(ipntr(2):ipntr(2)+N-1) + ! + CALL LinSolve( & + & A=mat, & + & X=WORKD(ipntr(2):ipntr(2) + N - 1), & + & B=WORKD(ipntr(1):ipntr(1) + N - 1), & + & isTranspose=.FALSE., & + & isFactored=.TRUE., & + & PrintStat=yes_no_t%NO, & + & info=info1) + ! + IF (info1 .NE. 0) THEN + CALL ErrorMsg( & + & msg="Error occured in LinSolve() errorCode="//tostring(info1), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymSmallestEigenVal2()") + STOP + END IF + !! + ELSE + EXIT + END IF +END DO +! +! we are not getting rvec, therefore ldz=1, +! othereise ldz = N +! +IF (info .EQ. 0) THEN + CALL F77_SEUPD( & + & rvec=.FALSE., howmny='All', SELECT=SELECT, & + & d=ans, z=v, ldz=1, sigma=sigma0, & + & bmat=bmat, n=n, which=which0, nev=nev, tol=tol0, & + & resid=resid, ncv=ncv0, v=v, ldv=ldv, & + & iparam=iparam, ipntr=ipntr, workd=workd, & + & workl=workl, lworkl=lworkl, info=info) + ! + IF (info .NE. 0) THEN + err_msg = SEUPD_ErrorMsg(info) + CALL Display(err_msg, msg="", unitno=stdout) + ans = 0.0 + END IF +END IF +! +! Cleanup +! +DEALLOCATE (resid, v, workd, workl, SELECT) +! +END PROCEDURE SymSmallestEigenVal2 + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 new file mode 100644 index 000000000..b88889eaf --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SuperLU@Methods.F90 @@ -0,0 +1,1584 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(CSRMatrix_Superlu) Methods +USE BaseMethod +USE GlobalData, ONLY: stderr +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! CheckErrorCSRMatrix +!---------------------------------------------------------------------------- + +SUBROUTINE CheckErrorCSRMatrix(obj, lineNo, routine) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: lineNo + CHARACTER(*), INTENT(IN) :: routine + ! + IF (.NOT. ALLOCATED(obj%A)) THEN + CALL ErrorMsg(& + & msg="CSRMatrix_::obj%A is not allocated", & + & file=__FILE__, & + & routine=routine, & + & line=lineNo, & + & unitno=stderr & + & ) + STOP + END IF + + IF (.NOT. obj%csr%isInitiated) THEN + CALL ErrorMsg(& + & msg="CSRMatrix_::obj%csr is not initiated", & + & file=__FILE__, & + & routine=routine, & + & line=lineNo, & + & unitno=stderr & + & ) + STOP + END IF + + IF (.NOT. obj%csr%isSparsityLock) THEN + CALL ErrorMsg(& + & msg="CSRMatrix_::obj%csr%isSparsityLock is not True", & + & file=__FILE__, & + & routine=routine, & + & line=lineNo, & + & unitno=stderr & + & ) + STOP + END IF + +END SUBROUTINE CheckErrorCSRMatrix + +!---------------------------------------------------------------------------- +! InitiateSuperluA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InitiateSuperluA +#ifdef USE_SuperLU +! check if csr is initiated +! check if csr sparsity is locked +! check if A is allocated +INTEGER(I4B) :: nnz, m, n, ii +! +CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & +& routine="InitiateSuperluA()") +! +IF (ALLOCATED(obj%slu%nzval) & + & .OR. ALLOCATED(obj%slu%ia) & + & .OR. ALLOCATED(obj%slu%ja)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu nzval, ia, ja are already allocated", & + & file=__FILE__, & + & routine="InitiateSuperluA()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (obj%slu%isAInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%A is already Initiated", & + & file=__FILE__, & + & routine="InitiateSuperluA()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +obj%slu%isAInitiated = .TRUE. + +nnz = SIZE(obj%A) +m = SIZE(obj, 1) +n = SIZE(obj, 2) + +CALL Reallocate(obj%slu%nzval, nnz) +CALL Reallocate(obj%slu%ia, m + 1) +CALL Reallocate(obj%slu%ja, nnz) + +CALL Copy(x=obj%A, y=obj%slu%nzval) + +DO CONCURRENT(ii=1:m + 1) + obj%slu%ia(ii) = obj%csr%ia(ii) - 1 +END DO + +DO CONCURRENT(ii=1:nnz) + obj%slu%ja(ii) = obj%csr%ja(ii) - 1 +END DO + +CALL dCreate_CompCol_Matrix( & + & A=obj%slu%A, & + & m=m, & + & n=n, & + & nnz=nnz, & + & nzval=obj%slu%nzval, & + & rowind=obj%slu%ja, & + & colptr=obj%slu%ia, & + & stype=stype_t%SLU_NC, & + & dtype=dtype_t%SLU_D, & + & mtype=mtype_t%SLU_GE) + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="InitiateSuperluA()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif + +END PROCEDURE InitiateSuperluA + +!---------------------------------------------------------------------------- +! SetSuperluA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetSuperluA +#ifdef USE_SuperLU +! check if csr is initiated +! check if csr sparsity is locked +! check if A is allocated +INTEGER(I4B) :: nnz, m, n +! +CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & +& routine="SetSuperluA()") +! +IF (.NOT. ALLOCATED(obj%slu%nzval) & + & .OR. .NOT. ALLOCATED(obj%slu%ia) & + & .OR. .NOT. ALLOCATED(obj%slu%ja)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu nzval, ia, ja are not allocated", & + & file=__FILE__, & + & routine="SetSuperluA()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. obj%slu%isAInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%A is not Initiated", & + & file=__FILE__, & + & routine="SetSuperluA()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +nnz = SIZE(obj%A) +m = SIZE(obj, 1) +n = SIZE(obj, 2) + +IF (SIZE(obj%slu%nzval) .NE. nnz & + & .OR. SIZE(obj%slu%ia) .NE. m + 1 & + & .OR. SIZE(obj%slu%ja) .NE. nnz) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu nzval, ia, ja are allocated & + & but there is some issue with size and shape", & + & file=__FILE__, & + & routine="SetSuperluA()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL Copy(x=obj%A, y=obj%slu%nzval) + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="SetSuperluA()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif + +END PROCEDURE SetSuperluA + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InitiateSuperluRHS1 +#ifdef USE_SuperLU +INTEGER(I4B) :: nrhs, m, ii + +IF (obj%slu%isBInitiated .OR. obj%slu%isXInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%B or obj%slu%x is already Initiated", & + & file=__FILE__, & + & routine="InitiateSuperluRHS1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +obj%slu%isBInitiated = .TRUE. +obj%slu%isXInitiated = .TRUE. + +IF (ALLOCATED(obj%slu%rhs) .OR. ALLOCATED(obj%slu%sol)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%rhs or obj%slu%sol is already Allocated", & + & file=__FILE__, & + & routine="InitiateSuperluRHS1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & + & routine="InitiateSuperluRHS1()") + +nrhs = 1 +m = SIZE(rhs, 1) + +CALL Reallocate(obj%slu%rhs, m, nrhs) +CALL Reallocate(obj%slu%sol, m, nrhs) + +DO CONCURRENT(ii=1:m) + obj%slu%rhs(ii, 1) = rhs(ii) +END DO + +CALL dCreate_Dense_Matrix( & + & A=obj%slu%B, & + & m=m, & + & n=nrhs, & + & x=obj%slu%rhs, & + & ldx=m, & + & stype=stype_t%SLU_DN, & + & dtype=dtype_t%SLU_D, & + & mtype=mtype_t%SLU_GE) + +CALL dCreate_Dense_Matrix( & + & A=obj%slu%X, & + & m=m, & + & n=nrhs, & + & x=obj%slu%sol, & + & ldx=m, & + & stype=stype_t%SLU_DN, & + & dtype=dtype_t%SLU_D, & + & mtype=mtype_t%SLU_GE) + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="InitiateSuperlu()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif +END PROCEDURE InitiateSuperluRHS1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InitiateSuperluRHS2 +#ifdef USE_SuperLU +INTEGER(I4B) :: nrhs, m, ii, jj + +IF (obj%slu%isBInitiated .OR. obj%slu%isXInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%B is already Initiated", & + & file=__FILE__, & + & routine="InitiateSuperluRHS2()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +obj%slu%isBInitiated = .TRUE. +obj%slu%isXInitiated = .TRUE. + +IF (ALLOCATED(obj%slu%rhs) .OR. ALLOCATED(obj%slu%sol)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%rhs obj%slu%sol is already Allocated", & + & file=__FILE__, & + & routine="InitiateSuperluRHS1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & + & routine="InitiateSuperluRHS2()") + +nrhs = SIZE(rhs, 2) +m = SIZE(rhs, 1) + +CALL Reallocate(obj%slu%rhs, m, nrhs) +CALL Reallocate(obj%slu%sol, m, nrhs) + +DO CONCURRENT(ii=1:m, jj=1:nrhs) + obj%slu%rhs(ii, jj) = rhs(ii, jj) +END DO + +CALL dCreate_Dense_Matrix( & + & A=obj%slu%B, & + & m=m, & + & n=nrhs, & + & x=obj%slu%rhs, & + & ldx=m, & + & stype=stype_t%SLU_DN, & + & dtype=dtype_t%SLU_D, & + & mtype=mtype_t%SLU_GE) + +CALL dCreate_Dense_Matrix( & + & A=obj%slu%X, & + & m=m, & + & n=nrhs, & + & x=obj%slu%sol, & + & ldx=m, & + & stype=stype_t%SLU_DN, & + & dtype=dtype_t%SLU_D, & + & mtype=mtype_t%SLU_GE) + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="InitiateSuperlu()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif + +END PROCEDURE InitiateSuperluRHS2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetSuperluRHS1 +#ifdef USE_SuperLU +INTEGER(I4B) :: nrhs, m, ii + +IF (.NOT. obj%slu%isBInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%B is not Initiated", & + & file=__FILE__, & + & routine="SetSuperluRHS1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%rhs)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%rhs is not Allocated", & + & file=__FILE__, & + & routine="SetSuperluRHS1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL CheckErrorCSRMatrix(& + & obj=obj, & + & lineNo=__LINE__, & + & routine="SetSuperluRHS1()") + +nrhs = 1 +m = SIZE(rhs, 1) + +IF (SIZE(obj%slu%rhs, 1) .NE. m .OR. SIZE(obj%slu%rhs, 2) .NE. nrhs) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%rhs Allocated but shape does not match", & + & file=__FILE__, & + & routine="SetSuperluRHS1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +DO CONCURRENT(ii=1:m) + obj%slu%rhs(ii, 1) = rhs(ii) +END DO + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="InitiateSuperlu()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif +END PROCEDURE SetSuperluRHS1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetSuperluRHS2 +#ifdef USE_SuperLU +INTEGER(I4B) :: nrhs, m, ii, jj + +IF (.NOT. obj%slu%isBInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%B is not Initiated", & + & file=__FILE__, & + & routine="SetSuperluRHS2()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%rhs)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%rhs is not Allocated", & + & file=__FILE__, & + & routine="InitiateSuperluRHS1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL CheckErrorCSRMatrix(obj=obj, lineNo=__LINE__, & + & routine="SetSuperluRHS2()") + +nrhs = SIZE(rhs, 2) +m = SIZE(rhs, 1) + +IF (SIZE(obj%slu%rhs, 1) .NE. m .OR. SIZE(obj%slu%rhs, 2) .NE. nrhs) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%rhs Allocated but shape does not match", & + & file=__FILE__, & + & routine="SetSuperluRHS2()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +DO CONCURRENT(ii=1:m, jj=1:nrhs) + obj%slu%rhs(ii, jj) = rhs(ii, jj) +END DO + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="InitiateSuperlu()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif + +END PROCEDURE SetSuperluRHS2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetSuperluX1 +#ifdef USE_SuperLU +INTEGER(I4B) :: nrhs, m, ii + +IF (.NOT. obj%slu%isXInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%X is NOT Initiated", & + & file=__FILE__, & + & routine="GetSuperluX1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%sol)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%sol is not Allocated", & + & file=__FILE__, & + & routine="GetSuperluX1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL CheckErrorCSRMatrix( & + & obj=obj, lineNo=__LINE__, & + & routine="GetSuperluX1()") + +nrhs = 1 +m = SIZE(x, 1) + +IF (SIZE(obj%slu%sol, 1) .NE. m .OR. SIZE(obj%slu%sol, 2) .NE. nrhs) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%rhs Allocated but shape does not match", & + & file=__FILE__, & + & routine="GetSuperluX1()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +DO CONCURRENT(ii=1:m) + x(ii) = obj%slu%sol(ii, 1) +END DO + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="GetSuperluX1()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif +END PROCEDURE GetSuperluX1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetSuperluX2 +#ifdef USE_SuperLU +INTEGER(I4B) :: nrhs, m, ii, jj + +IF (.NOT. obj%slu%isXInitiated) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%X is not Initiated", & + & file=__FILE__, & + & routine="GetSuperluX2()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%sol)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%sol is not Allocated", & + & file=__FILE__, & + & routine="GetSuperluX2()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL CheckErrorCSRMatrix( & + & obj=obj, lineNo=__LINE__, & + & routine="GetSuperluX2()") + +m = SIZE(x, 1) +nrhs = SIZE(x, 2) + +IF (SIZE(obj%slu%sol, 1) .NE. m .OR. SIZE(obj%slu%sol, 2) .NE. nrhs) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%sol Allocated but shape does not match", & + & file=__FILE__, & + & routine="GetSuperluX2()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +DO CONCURRENT(ii=1:m, jj=1:nrhs) + x(ii, jj) = obj%slu%sol(ii, jj) +END DO + +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="GetSuperluX2()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif + +END PROCEDURE GetSuperluX2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InitiateSuperLuOptions +#ifdef USE_SuperLU +CALL set_default_options(obj%slu%options) +obj%slu%options%Equil = yes_no_t%YES +obj%slu%options%Trans = Trans_t%TRANS +obj%slu%options%ColPerm = colperm_t%COLAMD +obj%slu%options%Fact = Fact_t%DOFACT +obj%slu%options%IterRefine = IterRefine_t%SLU_DOUBLE +obj%slu%options%PivotGrowth = yes_no_t%YES +obj%slu%options%DiagPivotThresh = 1.0 +obj%slu%options%ConditionNumber = yes_no_t%YES +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="InitiateSuperLuOptions()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif +END PROCEDURE InitiateSuperLuOptions + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetSuperluOptions +#ifdef USE_SuperLU + +IF (PRESENT(Fact)) THEN + obj%slu%options%Fact = Fact +END IF + +IF (PRESENT(Equil)) THEN + obj%slu%options%Equil = Equil +END IF + +IF (PRESENT(ColPerm)) THEN + obj%slu%options%ColPerm = ColPerm +END IF + +IF (PRESENT(Trans)) THEN + obj%slu%options%Trans = Trans +END IF + +IF (PRESENT(IterRefine)) THEN + obj%slu%options%IterRefine = IterRefine +END IF + +IF (PRESENT(DiagPivotThresh)) THEN + obj%slu%options%DiagPivotThresh = DiagPivotThresh +END IF + +IF (PRESENT(SymmetricMode)) THEN + obj%slu%options%SymmetricMode = SymmetricMode +END IF + +IF (PRESENT(PivotGrowth)) THEN + obj%slu%options%PivotGrowth = PivotGrowth +END IF + +IF (PRESENT(ConditionNumber)) THEN + obj%slu%options%ConditionNumber = ConditionNumber +END IF + +IF (PRESENT(RowPerm)) THEN + obj%slu%options%RowPerm = RowPerm +END IF + +IF (PRESENT(ILU_DropRule)) THEN + obj%slu%options%ILU_DropRule = ILU_DropRule +END IF + +IF (PRESENT(ILU_DropTol)) THEN + obj%slu%options%ILU_DropTol = ILU_DropTol +END IF + +IF (PRESENT(ILU_FillFactor)) THEN + obj%slu%options%ILU_FillFactor = ILU_FillFactor +END IF + +IF (PRESENT(ILU_MILU)) THEN + obj%slu%options%ILU_MILU = ILU_MILU +END IF + +IF (PRESENT(PrintStat)) THEN + obj%slu%options%PrintStat = PrintStat +END IF + +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="SetSuperluOptions()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE SetSuperluOptions + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SuperluDGSSVX +#ifdef USE_SuperLU + +! SUBROUTINE dgssvx(options, A, perm_c, perm_r, & +! & etree, equed, R, C, L, U, work, lwork, & +! & B, X, recip_pivot_growth, rcond, ferr, berr, & +! & Glu, mem_usage, stat, info) & + +IF (.NOT. ALLOCATED(obj%slu%perm_c)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%perm_c is not allocated", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%perm_r)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%perm_r is not allocated", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%etree)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%etree is not allocated", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%R)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%R is not allocated", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%C)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%C is not allocated", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%ferr)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%ferr is not allocated", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +IF (.NOT. ALLOCATED(obj%slu%berr)) THEN + CALL ErrorMsg(& + & msg="Superlu_::obj%slu%berr is not allocated", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) + STOP +END IF + +CALL dgssvx(& + & options=obj%slu%options, & + & A=obj%slu%A, & + & perm_c=obj%slu%perm_c, & + & perm_r=obj%slu%perm_r, & + & etree=obj%slu%etree, & + & equed=obj%slu%equed, & + & R=obj%slu%R, & + & C=obj%slu%C, & + & L=obj%slu%L, & + & U=obj%slu%U, & + & Work=obj%slu%Work, & + & B=obj%slu%B, & + & X=obj%slu%X, & + & recip_pivot_growth=obj%slu%recip_pivot_growth, & + & rcond=obj%slu%rcond, & + & ferr=obj%slu%ferr, & + & berr=obj%slu%berr, & + & Glu=obj%slu%Glu, & + & mem_usage=obj%slu%mem_usage, & + & stat=obj%slu%stat, & + & lwork=obj%slu%lwork, & + & info=obj%slu%info) + +obj%slu%isLInitiated = .TRUE. +obj%slu%isUInitiated = .TRUE. +obj%slu%isGluInitiated = .TRUE. + +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="SuperluDGSSVX()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE SuperluDGSSVX + +!---------------------------------------------------------------------------- +! InitiateSuperluDGSSVXParam +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-01-27 +! summary: Initiate Superlu dgssvx variables + +MODULE PROCEDURE InitiateSuperluDGSSVXParam +#ifdef USE_SuperLU +INTEGER(I4B) :: m, n, nnz, nrhs + +m = SIZE(obj, 1) +n = SIZE(obj, 2) +nnz = GetNNZ(obj) +nrhs = SIZE(obj%slu%rhs, 2) + +CALL Reallocate(obj%slu%perm_c, n) +CALL Reallocate(obj%slu%perm_r, m) +CALL Reallocate(obj%slu%etree, n) +CALL Reallocate(obj%slu%R, m) +CALL Reallocate(obj%slu%C, n) +CALL Reallocate(obj%slu%ferr, nrhs) +CALL Reallocate(obj%slu%berr, nrhs) + +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="InitiateSuperluDGSSVXParam()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE InitiateSuperluDGSSVXParam + +!---------------------------------------------------------------------------- +! SuperluDisplayStat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SuperluDisplayStat +#ifdef USE_SuperLU +INTEGER(I4B) :: ii, nrhs + +IF (obj%slu%options%PrintStat .EQ. yes_no_t%YES) THEN + IF (obj%slu%options%PivotGrowth .EQ. yes_no_t%YES) THEN + CALL Display(obj%slu%recip_pivot_growth, "recip_pivot_growth=") + END IF + + IF (obj%slu%options%ConditionNumber .EQ. yes_no_t%YES) THEN + CALL Display(obj%slu%rcond, "rcond=") + END IF + + IF (obj%slu%options%IterRefine .NE. IterRefine_t%NOREFINE) THEN + CALL Display("rhs, Steps, Ferr, Berr") + nrhs = SIZE(obj%slu%rhs, 2) + DO ii = 1, nrhs + CALL Display(& + & [& + & REAL(ii, kind=DFP), & + & REAL(obj%slu%stat%RefineSteps, kind=DFP), & + & obj%slu%Ferr(ii), & + & obj%slu%Berr(ii) & + & ], "", orient="row") + END DO + END IF + CALL StatPrint(obj%slu%stat) + CALL Display(obj%slu%mem_usage%total_needed / 1.0E+6, "total size needed = ") + ! WRITE (*, *) "total needed = ", A%slu%mem_usage%total_needed +END IF + +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="SuperluDisplayStat()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE SuperluDisplayStat + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SuperluDeallocate +#ifdef USE_SuperLU +CHARACTER(LEN=*), PARAMETER :: myName = "SuperluDeallocate()" +IF (ASSOCIATED(obj%slu)) THEN + IF (ALLOCATED(obj%slu%rhs)) DEALLOCATE (obj%slu%rhs) + IF (ALLOCATED(obj%slu%sol)) DEALLOCATE (obj%slu%sol) + IF (ALLOCATED(obj%slu%etree)) DEALLOCATE (obj%slu%etree) + IF (ALLOCATED(obj%slu%perm_r)) DEALLOCATE (obj%slu%perm_r) + IF (ALLOCATED(obj%slu%perm_c)) DEALLOCATE (obj%slu%perm_c) + IF (ALLOCATED(obj%slu%R)) DEALLOCATE (obj%slu%R) + IF (ALLOCATED(obj%slu%C)) DEALLOCATE (obj%slu%C) + IF (ALLOCATED(obj%slu%ferr)) DEALLOCATE (obj%slu%ferr) + IF (ALLOCATED(obj%slu%berr)) DEALLOCATE (obj%slu%berr) + IF (ALLOCATED(obj%slu%ia)) DEALLOCATE (obj%slu%ia) + IF (ALLOCATED(obj%slu%ja)) DEALLOCATE (obj%slu%ja) + IF (ALLOCATED(obj%slu%nzval)) DEALLOCATE (obj%slu%nzval) + IF (obj%slu%isAInitiated) THEN + CALL Destroy_SuperMatrix_Store(obj%slu%A) + END IF + IF (obj%slu%isBInitiated) THEN + CALL Destroy_SuperMatrix_Store(obj%slu%B) + END IF + IF (obj%slu%isXInitiated) THEN + CALL Destroy_SuperMatrix_Store(obj%slu%X) + END IF + IF (obj%slu%isLInitiated) THEN + CALL Destroy_SuperNode_Matrix(obj%slu%L) + END IF + IF (obj%slu%isUInitiated) THEN + CALL Destroy_CompCol_Matrix(obj%slu%U) + END IF + IF (obj%slu%lwork .NE. 0) THEN + CALL Superlu_Free(obj%slu%work) + END IF + IF (obj%slu%isStatInitiated) THEN + CALL StatFree(obj%slu%stat) + END IF + obj%slu%lwork = 0 + obj%slu%info = 0 + obj%slu%recip_pivot_growth = 0.0_DFP + obj%slu%rcond = 0.0_DFP + obj%slu%isAInitiated = .FALSE. + obj%slu%isBInitiated = .FALSE. + obj%slu%isXInitiated = .FALSE. + obj%slu%isLInitiated = .FALSE. + obj%slu%isUInitiated = .FALSE. + obj%slu%isGluInitiated = .FALSE. + obj%slu%isStatInitiated = .FALSE. + DEALLOCATE (obj%slu) + obj%slu => NULL() +END IF +#else +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="SuperluDeallocate()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP +#endif +END PROCEDURE SuperluDeallocate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LinSolve1 +#ifdef USE_SuperLU +LOGICAL(LGT) :: isFactored0, isTranspose0 +INTEGER(I4B) :: Trans0 +REAL(DFP) :: DiagPivotThresh0 +INTEGER(I4B) :: ColPerm0 +INTEGER(I4B) :: IterRefine0 +INTEGER(I4B) :: PivotGrowth0 +INTEGER(I4B) :: ConditionNumber0 +INTEGER(I4B) :: Equil0 +INTEGER(I4B) :: SymmetricMode0 +INTEGER(I4B) :: PrintStat0 + +CALL CheckErrorCSRMatrix( & + & obj=A, & + & lineNo=__LINE__, & + & routine="LinSolve1()") + +isTranspose0 = input(option=isTranspose, default=.FALSE.) + +IF (isTranspose0) THEN + Trans0 = Trans_t%NOTRANS +ELSE + Trans0 = Trans_t%TRANS +END IF + +Equil0 = input(option=Equil, default=yes_no_t%YES) +ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) +IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) +DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) +PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) +ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) +SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) +PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) + +! First call +! if obj%slu%A is not initiated + +IF (.NOT. ASSOCIATED(A%slu)) THEN + ALLOCATE (A%slu) +END IF + +IF (.NOT. A%slu%isAInitiated) THEN + CALL InitiateSuperluA(obj=A) + CALL InitiateSuperluRHS(obj=A, rhs=B) + CALL InitiateSuperLuOptions(obj=A) + CALL SetSuperluOptions( & + & obj=A, & + & Equil=Equil0, & + & Trans=Trans0, & + & ColPerm=ColPerm0, & + & Fact=Fact_t%DOFACT, & + & IterRefine=IterRefine0, & + & PivotGrowth=PivotGrowth0, & + & DiagPivotThresh=DiagPivotThresh0, & + & SymmetricMode=SymmetricMode0, & + & PrintStat=PrintStat0, & + & ConditionNumber=ConditionNumber0 & + & ) + CALL InitiateSuperluDGSSVXParam(obj=A) + CALL StatInit(A%slu%stat) + A%slu%isStatInitiated = .TRUE. + +ELSE + isFactored0 = input(option=isFactored, default=.FALSE.) + IF (isFactored0) THEN + ! + ! WE dont perform factorization + ! + CALL SetSuperluRHS(obj=A, rhs=B) + ! CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & + ! & Trans=Trans0) + CALL SetSuperluOptions( & + & obj=A, & + & Equil=Equil0, & + & Trans=Trans0, & + & ColPerm=ColPerm0, & + & Fact=Fact_t%FACTORED, & + & IterRefine=IterRefine0, & + & PivotGrowth=PivotGrowth0, & + & DiagPivotThresh=DiagPivotThresh0, & + & SymmetricMode=SymmetricMode0, & + & PrintStat=PrintStat0, & + & ConditionNumber=ConditionNumber0 & + & ) + ELSE + ! + ! perform factorization + ! only value has changed, sparsity is the same + ! Because sparsity is the same we do not + ! call InitiateSuperluDGSSVXParam + ! + CALL SetSuperluA(obj=A) + CALL SetSuperluRHS(obj=A, rhs=B) + ! CALL SetSuperluOptions(& + ! & obj=A, & + ! & Fact=Fact_t%SamePattern, & + ! & Trans=Trans0) + ! + CALL SetSuperluOptions( & + & obj=A, & + & Equil=Equil0, & + & Trans=Trans0, & + & ColPerm=ColPerm0, & + & Fact=Fact_t%SamePattern, & + & IterRefine=IterRefine0, & + & PivotGrowth=PivotGrowth0, & + & DiagPivotThresh=DiagPivotThresh0, & + & SymmetricMode=SymmetricMode0, & + & PrintStat=PrintStat0, & + & ConditionNumber=ConditionNumber0 & + & ) + END IF + +END IF + +CALL SuperluDGSSVX(obj=A) +CALL Copy(x=A%slu%sol(:, 1), y=x) +IF (PRESENT(info)) info = A%slu%info +CALL SuperluDisplayStat(obj=A) + +IF (A%slu%lwork .EQ. 0) THEN + IF (A%slu%isLInitiated) THEN + CALL Destroy_SuperNode_Matrix(A%slu%L) + A%slu%isLInitiated = .FALSE. + END IF + IF (A%slu%isUInitiated) THEN + CALL Destroy_CompCol_Matrix(A%slu%U) + A%slu%isUInitiated = .FALSE. + END IF +END IF + +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="LinSolve1()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE LinSolve1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LinSolve2 +#ifdef USE_SuperLU +LOGICAL(LGT) :: isFactored0, isTranspose0 +INTEGER(I4B) :: Trans0 +REAL(DFP) :: DiagPivotThresh0 +INTEGER(I4B) :: ColPerm0 +INTEGER(I4B) :: IterRefine0 +INTEGER(I4B) :: PivotGrowth0 +INTEGER(I4B) :: ConditionNumber0 +INTEGER(I4B) :: Equil0 +INTEGER(I4B) :: SymmetricMode0 +INTEGER(I4B) :: PrintStat0 +INTEGER(I4B) :: ii, nrhs + +CALL CheckErrorCSRMatrix( & + & obj=A, & + & lineNo=__LINE__, & + & routine="LinSolve2()") + +isTranspose0 = input(option=isTranspose, default=.FALSE.) + +IF (isTranspose0) THEN + Trans0 = Trans_t%NOTRANS +ELSE + Trans0 = Trans_t%TRANS +END IF + +Equil0 = input(option=Equil, default=yes_no_t%YES) +ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) +IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) +DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) +PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) +ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) +SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) +PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) + +! First call +! if obj%slu%A is not initiated + +IF (.NOT. ASSOCIATED(A%slu)) THEN + ALLOCATE (A%slu) +END IF + +IF (.NOT. A%slu%isAInitiated) THEN + CALL InitiateSuperluA(obj=A) + CALL InitiateSuperluRHS(obj=A, rhs=B) + CALL InitiateSuperLuOptions(obj=A) + CALL SetSuperluOptions( & + & obj=A, & + & Equil=Equil0, & + & Trans=Trans0, & + & ColPerm=ColPerm0, & + & Fact=Fact_t%DOFACT, & + & IterRefine=IterRefine0, & + & PivotGrowth=PivotGrowth0, & + & DiagPivotThresh=DiagPivotThresh0, & + & SymmetricMode=SymmetricMode0, & + & PrintStat=PrintStat0, & + & ConditionNumber=ConditionNumber0 & + & ) + CALL InitiateSuperluDGSSVXParam(obj=A) + CALL StatInit(A%slu%stat) + A%slu%isStatInitiated = .TRUE. +ELSE + isFactored0 = input(option=isFactored, default=.FALSE.) + IF (isFactored0) THEN + ! + ! WE dont perform factorization + ! + CALL SetSuperluRHS(obj=A, rhs=B) + CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & + & Trans=Trans0) + ELSE + ! + ! perform factorization + ! only value has changed, sparsity is the same + ! Because sparsity is the same we do not + ! call InitiateSuperluDGSSVXParam + ! + CALL SetSuperluA(obj=A) + CALL SetSuperluRHS(obj=A, rhs=B) + CALL SetSuperluOptions(& + & obj=A, & + & Fact=Fact_t%SamePattern, & + & Trans=Trans0) + ! + END IF + +END IF + +CALL SuperluDGSSVX(obj=A) +nrhs = SIZE(x, 2) +DO ii = 1, nrhs + CALL Copy(x=A%slu%sol(:, ii), y=x(:, ii)) +END DO +IF (PRESENT(info)) info = A%slu%info +CALL SuperluDisplayStat(obj=A) + +IF (A%slu%lwork .EQ. 0) THEN + IF (A%slu%isLInitiated) THEN + CALL Destroy_SuperNode_Matrix(A%slu%L) + A%slu%isLInitiated = .FALSE. + END IF + IF (A%slu%isUInitiated) THEN + CALL Destroy_CompCol_Matrix(A%slu%U) + A%slu%isUInitiated = .FALSE. + END IF +END IF + +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="LinSolve2()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE LinSolve2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LinSolve3 +#ifdef USE_SuperLU +LOGICAL(LGT) :: isFactored0, isTranspose0 +INTEGER(I4B) :: Trans0 +REAL(DFP) :: DiagPivotThresh0 +INTEGER(I4B) :: ColPerm0 +INTEGER(I4B) :: IterRefine0 +INTEGER(I4B) :: PivotGrowth0 +INTEGER(I4B) :: ConditionNumber0 +INTEGER(I4B) :: Equil0 +INTEGER(I4B) :: SymmetricMode0 +INTEGER(I4B) :: PrintStat0 + +CALL CheckErrorCSRMatrix( & + & obj=A, & + & lineNo=__LINE__, & + & routine="LinSolve3()") + +isTranspose0 = input(option=isTranspose, default=.FALSE.) + +IF (isTranspose0) THEN + Trans0 = Trans_t%NOTRANS +ELSE + Trans0 = Trans_t%TRANS +END IF + +Equil0 = input(option=Equil, default=yes_no_t%YES) +ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) +IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) +DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) +PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) +ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) +SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) +PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) + +! First call +! if obj%slu%A is not initiated + +IF (.NOT. ASSOCIATED(A%slu)) THEN + ALLOCATE (A%slu) +END IF + +IF (.NOT. A%slu%isAInitiated) THEN + CALL InitiateSuperluA(obj=A) + CALL InitiateSuperluRHS(obj=A, rhs=B) + CALL InitiateSuperLuOptions(obj=A) + CALL SetSuperluOptions( & + & obj=A, & + & Equil=Equil0, & + & Trans=Trans0, & + & ColPerm=ColPerm0, & + & Fact=Fact_t%DOFACT, & + & IterRefine=IterRefine0, & + & PivotGrowth=PivotGrowth0, & + & DiagPivotThresh=DiagPivotThresh0, & + & SymmetricMode=SymmetricMode0, & + & PrintStat=PrintStat0, & + & ConditionNumber=ConditionNumber0 & + & ) + CALL InitiateSuperluDGSSVXParam(obj=A) + CALL StatInit(A%slu%stat) + A%slu%isStatInitiated = .TRUE. +ELSE + isFactored0 = input(option=isFactored, default=.FALSE.) + IF (isFactored0) THEN + ! + ! WE dont perform factorization + ! + CALL SetSuperluRHS(obj=A, rhs=B) + CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & + & Trans=Trans0) + ELSE + ! + ! perform factorization + ! only value has changed, sparsity is the same + ! Because sparsity is the same we do not + ! call InitiateSuperluDGSSVXParam + ! + CALL SetSuperluA(obj=A) + CALL SetSuperluRHS(obj=A, rhs=B) + CALL SetSuperluOptions(& + & obj=A, & + & Fact=Fact_t%SamePattern, & + & Trans=Trans0) + ! + END IF + +END IF + +CALL SuperluDGSSVX(obj=A) +CALL Copy(x=A%slu%sol(:, 1), y=B) +IF (PRESENT(info)) info = A%slu%info +CALL SuperluDisplayStat(obj=A) +IF (A%slu%lwork .EQ. 0) THEN + IF (A%slu%isLInitiated) THEN + CALL Destroy_SuperNode_Matrix(A%slu%L) + A%slu%isLInitiated = .FALSE. + END IF + IF (A%slu%isUInitiated) THEN + CALL Destroy_CompCol_Matrix(A%slu%U) + A%slu%isUInitiated = .FALSE. + END IF +END IF +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="LinSolve3()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE LinSolve3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LinSolve4 +#ifdef USE_SuperLU +LOGICAL(LGT) :: isFactored0, isTranspose0 +INTEGER(I4B) :: Trans0 +REAL(DFP) :: DiagPivotThresh0 +INTEGER(I4B) :: ColPerm0 +INTEGER(I4B) :: IterRefine0 +INTEGER(I4B) :: PivotGrowth0 +INTEGER(I4B) :: ConditionNumber0 +INTEGER(I4B) :: Equil0 +INTEGER(I4B) :: SymmetricMode0 +INTEGER(I4B) :: PrintStat0 +INTEGER(I4B) :: ii, nrhs + +CALL CheckErrorCSRMatrix( & + & obj=A, & + & lineNo=__LINE__, & + & routine="LinSolve4()") + +isTranspose0 = input(option=isTranspose, default=.FALSE.) + +IF (isTranspose0) THEN + Trans0 = Trans_t%NOTRANS +ELSE + Trans0 = Trans_t%TRANS +END IF + +Equil0 = input(option=Equil, default=yes_no_t%YES) +ColPerm0 = input(option=ColPerm, default=colperm_t%COLAMD) +IterRefine0 = input(option=IterRefine, default=IterRefine_t%SLU_DOUBLE) +DiagPivotThresh0 = input(option=DiagPivotThresh, default=1.0_DFP) +PivotGrowth0 = input(option=PivotGrowth, default=yes_no_t%NO) +ConditionNumber0 = input(option=ConditionNumber, default=yes_no_t%NO) +SymmetricMode0 = input(option=SymmetricMode, default=yes_no_t%NO) +PrintStat0 = input(option=PrintStat, default=yes_no_t%NO) + +! First call +! if obj%slu%A is not initiated + +IF (.NOT. ASSOCIATED(A%slu)) THEN + ALLOCATE (A%slu) +END IF + +IF (.NOT. A%slu%isAInitiated) THEN + CALL InitiateSuperluA(obj=A) + CALL InitiateSuperluRHS(obj=A, rhs=B) + CALL InitiateSuperLuOptions(obj=A) + CALL SetSuperluOptions( & + & obj=A, & + & Equil=Equil0, & + & Trans=Trans0, & + & ColPerm=ColPerm0, & + & Fact=Fact_t%DOFACT, & + & IterRefine=IterRefine0, & + & PivotGrowth=PivotGrowth0, & + & DiagPivotThresh=DiagPivotThresh0, & + & SymmetricMode=SymmetricMode0, & + & PrintStat=PrintStat0, & + & ConditionNumber=ConditionNumber0 & + & ) + CALL InitiateSuperluDGSSVXParam(obj=A) + CALL StatInit(A%slu%stat) + A%slu%isStatInitiated = .TRUE. + + ! new thing here + ! A%slu%lwork = -1 + ! CALL SuperluDGSSVX(obj=A) + ! A%slu%lwork = INT(A%slu%mem_usage%total_needed, kind=C_SIZE_T) + ! A%slu%work = superlu_malloc(A%slu%lwork) + ! STOP + ! new thing stop here +ELSE + isFactored0 = input(option=isFactored, default=.FALSE.) + IF (isFactored0) THEN + ! + ! WE dont perform factorization + ! + CALL SetSuperluRHS(obj=A, rhs=B) + CALL SetSuperluOptions(obj=A, Fact=Fact_t%FACTORED, & + & Trans=Trans0) + ELSE + ! + ! perform factorization + ! only value has changed, sparsity is the same + ! Because sparsity is the same we do not + ! call InitiateSuperluDGSSVXParam + ! + CALL SetSuperluA(obj=A) + CALL SetSuperluRHS(obj=A, rhs=B) + CALL SetSuperluOptions(& + & obj=A, & + & Fact=Fact_t%SamePattern, & + & Trans=Trans0) + ! + END IF + +END IF + +CALL SuperluDGSSVX(obj=A) +nrhs = SIZE(B, 2) +DO ii = 1, nrhs + CALL Copy(x=A%slu%sol(:, ii), y=B(:, ii)) +END DO +IF (PRESENT(info)) info = A%slu%info +CALL SuperluDisplayStat(obj=A) +IF (A%slu%lwork .EQ. 0) THEN + IF (A%slu%isLInitiated) THEN + CALL Destroy_SuperNode_Matrix(A%slu%L) + A%slu%isLInitiated = .FALSE. + END IF + IF (A%slu%isUInitiated) THEN + CALL Destroy_CompCol_Matrix(A%slu%U) + A%slu%isUInitiated = .FALSE. + END IF +END IF +#else + +CALL ErrorMsg(& + & msg="This routine requires Superlu library, and & + & it seems this library is not linked with the easifemBase", & + & file=__FILE__, & + & routine="LinSolve4()", & + & line=__LINE__, & + & unitno=stderr & + & ) +STOP + +#endif +END PROCEDURE LinSolve4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 new file mode 100644 index 000000000..b80019268 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SymMatmulMethods@Methods.F90 @@ -0,0 +1,57 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(CSRMatrix_SymMatmulMethods) Methods +USE Display_Method +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SymMatSquare +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SymMatSquare +CALL Display("obj_SymMatSquare in "//__FILE__//" is under development.") +STOP + +! INTEGER(I4B) :: ii, jj, nrow, ncol, c1, c2, c, nnz_irow +! REAL(DFP) :: irow(A%max_nnz_row, A%max_nnz_col) +! +! ASSOCIATE (csr2 => obj%csr, csr1 => A%csr, A2 => obj%A, A1 => A%A) +! DO ii = 1, nrow +! c1 = csr1.startColumn.ii +! c2 = csr1.endColumn.ii +! +! ! nnz_row = c2 - c1 +! ! DO jj = 1, nnz_row +! ! tempRow(jj) = A1(c1 + jj - 1) +! ! END DO +! CALL GetCompactRow(obj=obj, VALUE=irow, irow=ii, n=nnz_irow) +! +! DO c = c1, c2 +! jj = csr2%JA(c) +! CALL GetCompactRow(obj=obj, VALUE=jrow, irow=jj, n=nnz_jrow) +! +! A(c) = DOT_PRODUCT() +! +! END DO +! END DO +! END ASSOCIATE + +END PROCEDURE obj_SymMatSquare + +END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 new file mode 100644 index 000000000..0b07a93f9 --- /dev/null +++ b/src/submodules/CSRMatrix/src/CSRMatrix_UnaryMethods@Methods.F90 @@ -0,0 +1,855 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(CSRMatrix_UnaryMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Scal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Scal +CALL SCAL(X=obj%A, A=a) +END PROCEDURE obj_Scal + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Convert1 +INTEGER(I4B) :: i, j, nrow +nrow = SIZE(IA) - 1 +CALL Reallocate(mat, nrow, nrow) +DO i = 1, nrow + DO j = IA(i), IA(i + 1) - 1 + mat(i, JA(j)) = A(j) + END DO +END DO +END PROCEDURE obj_Convert1 + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Convert2 +INTEGER(I4B) :: i, j, nrow, ncol +!! +nrow = SIZE(obj=From, dims=1) +ncol = SIZE(obj=From, dims=2) +!! +CALL Reallocate(To, nrow, ncol) +!! +DO i = 1, nrow + DO j = From%csr%IA(i), From%csr%IA(i + 1) - 1 + To(i, From%csr%JA(j)) = From%A(j) + END DO +END DO +!! +END PROCEDURE obj_Convert2 + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Convert3 +CALL Convert(From=From, To=To%val) +! CALL Convert(A=From%A, IA=From%csr%IA, JA=From%csr%JA, & +! & mat=To%val) +CALL setTotalDimension(To, 2_I4B) +END PROCEDURE obj_Convert3 + +!---------------------------------------------------------------------------- +! ColSORT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ColumnSORT +CALL CSORT(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, & + & INPUT(Option=isValues, Default=.TRUE.)) +obj%csr%isSorted = .TRUE. +END PROCEDURE obj_ColumnSORT + +!---------------------------------------------------------------------------- +! RemoveDuplicates +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_RemoveDuplicates +INTEGER(I4B), ALLOCATABLE :: iwk(:), UT(:) +CALL Reallocate(UT, obj%csr%nrow, iwk, obj%csr%nrow + 1) +CALL CLNCSR(1, 1, obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, UT, iwk) +!> Some entries are removed so fix sparsity +obj%csr%isSparsityLock = .FALSE. +CALL setSparsity(obj) +DEALLOCATE (iwk, UT) +END PROCEDURE obj_RemoveDuplicates + +!---------------------------------------------------------------------------- +! Clean +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Clean +INTEGER(I4B), ALLOCATABLE :: iwk(:), UT(:) +INTEGER(I4B) :: value2 + +IF (INPUT(option=isValues, default=.TRUE.)) THEN + value2 = 1 +ELSE + value2 = 0 +END IF +CALL Reallocate(UT, obj%csr%nrow, iwk, obj%csr%nrow + 1) +CALL CLNCSR(INPUT(option=ExtraOption, default=1), value2, obj%csr%nrow, & + & obj%A, obj%csr%JA, obj%csr%IA, UT, iwk) +!> Some entries are removed so fix sparsity +obj%csr%isSparsityLock = .FALSE. +CALL setSparsity(obj) +DEALLOCATE (iwk, UT) +END PROCEDURE obj_Clean + +!---------------------------------------------------------------------------- +! Copy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Copy +To = From +END PROCEDURE obj_Copy + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get1 +INTERFACE + FUNCTION GETELM(I, J, A, JA, IA, IADD, SORTED) + INTEGER :: I, J, IA(*), JA(*), IADD + LOGICAL :: SORTED + DOUBLE PRECISION :: GETELM, A(*) + END FUNCTION GETELM +END INTERFACE +INTEGER(I4B) :: iadd0 +Ans = GETELM(I, J, obj%A, obj%csr%JA, obj%csr%IA, iadd0, obj%csr%isSorted) +END PROCEDURE obj_Get1 + +!---------------------------------------------------------------------------- +! Filter +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_DropEntry +INTEGER(I4B) :: ierr, nnz +INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) +REAL(DFP), ALLOCATABLE :: A(:) +ALLOCATE (IA(objIn%csr%nrow + 1), JA(objIn%csr%nnz), & + & A(objIn%csr%nnz)) +CALL FILTER(objIn%csr%nrow, INPUT(option=option, default=1), & + & droptol, objIn%A, objIn%csr%JA, objIn%csr%IA, A, JA, IA,& + & objIn%csr%nnz, ierr) +nnz = IA(objIn%csr%nrow + 1) - 1 +CALL Initiate(obj=objOut, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (IA, JA, A) +END PROCEDURE obj_DropEntry + +!---------------------------------------------------------------------------- +! Transpose +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Transpose +INTEGER(I4B), ALLOCATABLE :: iwk(:) +INTEGER(I4B) :: ierr +TYPE(DOF_) :: dofobj +CALL Reallocate(iwk, obj%csr%nnz) +CALL TRANSP(obj%csr%nrow,obj%csr%ncol,obj%A,obj%csr%JA,obj%csr%IA,iwk,ierr) +IF (ierr .NE. 0) THEN + CALL ErrorMSG( & + & msg="Error occured during transposing!", & + & file="CSRMatrix_Method@UnaryMethods.F90", & + & routine="obj_Transpose()", & + & line=__LINE__, & + & unitno=stderr) + STOP +END IF +CALL ColumnSORT(obj) +dofobj = obj%csr%idof +obj%csr%jdof = obj%csr%idof +obj%csr%idof = dofobj +CALL DEALLOCATE (dofobj) +DEALLOCATE (iwk) +END PROCEDURE obj_Transpose + +!---------------------------------------------------------------------------- +! getDiagonal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_getDiagonal1 +CALL getDiagonal(obj=obj%csr, A=obj%A, diag=diag, idiag=idiag, & + & offset=offset) +END PROCEDURE obj_getDiagonal1 + +!---------------------------------------------------------------------------- +! getDiagonal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_getDiagonal2 +CALL getDiagonal(obj=obj%csr, A=obj%A, diag=diag, offset=offset) +END PROCEDURE obj_getDiagonal2 + +!---------------------------------------------------------------------------- +! getLowerTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_getLowerTriangle +REAL(DFP), ALLOCATABLE :: A(:) +INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) +INTEGER(I4B) :: nnz, nrow +nrow = obj%csr%nrow; nnz = obj%csr%nnz +ALLOCATE (A(nnz), JA(nnz), IA(nrow + 1)) +CALL GETL(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, A, JA, IA) +nnz = IA(nrow + 1) - 1 +CALL Initiate(obj=L, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (A, IA, JA) +END PROCEDURE obj_getLowerTriangle + +!---------------------------------------------------------------------------- +! getUpperTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_getUpperTriangle +REAL(DFP), ALLOCATABLE :: A(:) +INTEGER(I4B), ALLOCATABLE :: IA(:), JA(:) +INTEGER(I4B) :: nnz, nrow +nrow = obj%csr%nrow; nnz = obj%csr%nnz +ALLOCATE (A(nnz), JA(nnz), IA(nrow + 1)) +CALL GETU(obj%csr%nrow, obj%A, obj%csr%JA, obj%csr%IA, A, JA, IA) +nnz = IA(nrow + 1) - 1 +CALL Initiate(obj=U, A=A(1:nnz), IA=IA, JA=JA(1:nnz)) +DEALLOCATE (A, IA, JA) +END PROCEDURE obj_getUpperTriangle + +!---------------------------------------------------------------------------- +! PermuteRow +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_PermuteRow +INTEGER(I4B) :: nrow, job +nrow = SIZE(obj, 1); job = 1 +IF (PRESENT(isValues)) THEN + IF (.NOT. isValues) job = 0 +END IF +CALL initiate(ans, obj, .TRUE.) +CALL RPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, ans%csr%JA, & + & ans%csr%IA, PERM, job) +END PROCEDURE obj_PermuteRow + +!---------------------------------------------------------------------------- +! PermuteColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_PermuteColumn +INTEGER(I4B) :: nrow, job +nrow = SIZE(obj, 1); job = 1 +IF (PRESENT(isValues)) THEN + IF (.NOT. isValues) job = 0 +END IF +CALL initiate(ans, obj, .TRUE.) +CALL CPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, ans%csr%JA, & + & ans%csr%IA, PERM, job) +END PROCEDURE obj_PermuteColumn + +!---------------------------------------------------------------------------- +! Permute +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Permute +INTEGER(I4B) :: nrow, job +LOGICAL(LGT) :: isSymPERM +! +nrow = SIZE(obj, 1) +CALL initiate(ans, obj, .TRUE.) +! +IF (PRESENT(symPERM)) THEN + isSymPERM = symPERM +ELSE + isSymPERM = .FALSE. +END IF +! +IF (PRESENT(rowPERM) .AND. PRESENT(colPERM)) THEN + job = 3 + IF (PRESENT(isValues)) THEN + IF (.NOT. isValues) job = 4 + END IF + CALL DPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, & + & ans%csr%JA, ans%csr%IA, rowPERM, colPERM, job) + RETURN +END IF +! +IF (PRESENT(rowPERM)) THEN + IF (isSymPERM) THEN + job = 1 + IF (PRESENT(isValues)) THEN + IF (.NOT. isValues) job = 2 + END IF + CALL DPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, & + & ans%csr%JA, ans%csr%IA, rowPERM, rowPERM, job) + RETURN + ELSE + ans = PermuteRow(obj=obj, PERM=rowPERM, isValues=isValues) + RETURN + END IF +END IF +! +IF (PRESENT(colPERM)) THEN + IF (isSymPERM) THEN + job = 1 + IF (PRESENT(isValues)) THEN + IF (.NOT. isValues) job = 2 + END IF + CALL DPERM(nrow, obj%A, obj%csr%JA, obj%csr%IA, ans%A, & + & ans%csr%JA, ans%csr%IA, colPERM, colPERM, job) + RETURN + ELSE + ans = PermuteColumn(obj=obj, PERM=colPERM, isValues=isValues) + RETURN + END IF +END IF +END PROCEDURE obj_Permute + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE obj_GetSymU1(obj, symobj, A, symA) + TYPE(CSRSparsity_), INTENT(IN) :: obj + TYPE(CSRSparsity_), INTENT(INOUT) :: symobj + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: symA(:) + ! + INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzU, ncol, & + & nnzD, al, ar, ad + INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & + & JA_csc(:), idiag(:) + REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:) + ! + nnz_parts = GetNNZ(obj, [""]) + nrow = obj%nrow + ncol = obj%ncol + nnzU = nnz_parts(1) + nnzD = nnz_parts(3) + ! + CALL Reallocate(JA_csr, nnzU, IA_csr, nrow + 1) + CALL Reallocate(idiag, nrow) + CALL Reallocate(A_csc, nnzU) + CALL Reallocate(A_csr, nnzU) + ! + indx = 0 + ! + DO ii = 1, nrow + ! + IA_csr(ii) = indx + 1 + IA_csr(ii + 1) = IA_csr(ii) + ! + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + jj = obj%JA(rindx) + IF (ii .LT. jj) THEN + indx = indx + 1 + IA_csr(ii + 1) = IA_csr(ii + 1) + 1 + JA_csr(indx) = jj + A_csr(indx) = A(rindx) + ELSE IF (ii .EQ. jj) THEN + idiag(ii) = rindx + END IF + END DO + ! + END DO + ! + CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzU) + CALL Reallocate(A_csc, nnzU) + ! + CALL csrcsc( & + & nrow, & + & 1, & + & 1, & + & A_csr, & + & JA_csr, & + & IA_csr, & + & A_csc, & + & JA_csc, & + & IA_csc) + ! + symobj%nnz = nnzU * 2 + nnzD + symobj%ncol = ncol + symobj%nrow = nrow + symobj%isSorted = obj%isSorted + symobj%isInitiated = obj%isInitiated + symobj%isSparsityLock = obj%isSparsityLock + symobj%isDiagStored = .TRUE. + symobj%idof = obj%idof + symobj%jdof = obj%jdof + ! + CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) + CALL Reallocate(symobj%JA, symobj%nnz) + CALL Reallocate(symA, symobj%nnz) + ! + indx = 0 + ! + DO ii = 1, symobj%nrow + ar = IA_csr(ii + 1) - IA_csr(ii) + al = IA_csc(ii + 1) - IA_csr(ii) + IF (idiag(ii) .NE. 0) THEN + ad = 1 + ELSE + ad = 0 + END IF + ! + symobj%IA(ii) = indx + 1 + symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad + ! + DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csc(rindx) + symA(indx) = A_csc(rindx) + END DO + ! + IF (idiag(ii) .NE. 0) THEN + indx = indx + 1 + symobj%JA(indx) = ii !!obj%JA(idiag(ii)) + symobj%idiag(ii) = indx + symA(indx) = A(idiag(ii)) + END IF + ! + DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csr(rindx) + symA(indx) = A_csr(rindx) + END DO + ! + END DO + ! + ! Clean up + ! + DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, A_csc) + ! +END SUBROUTINE obj_GetSymU1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE obj_GetSymU2(obj, A) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) + ! + INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzU, ncol, & + & nnzD, al, ar, ad + INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & + & JA_csc(:), idiag(:) + REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:), A_diag(:) + ! + nnz_parts = GetNNZ(obj, [""]) + nrow = obj%nrow + ncol = obj%ncol + nnzU = nnz_parts(1) + nnzD = nnz_parts(3) + ! + CALL Reallocate(JA_csr, nnzU, IA_csr, nrow + 1) + CALL Reallocate(idiag, nrow) + CALL Reallocate(A_csc, nnzU) + CALL Reallocate(A_csr, nnzU) + CALL Reallocate(A_diag, nrow) + ! + indx = 0 + ! + DO ii = 1, nrow + ! + IA_csr(ii) = indx + 1 + IA_csr(ii + 1) = IA_csr(ii) + ! + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + jj = obj%JA(rindx) + IF (ii .LT. jj) THEN + indx = indx + 1 + IA_csr(ii + 1) = IA_csr(ii + 1) + 1 + JA_csr(indx) = jj + A_csr(indx) = A(rindx) + ELSE IF (ii .EQ. jj) THEN + idiag(ii) = rindx + A_diag(ii) = A(rindx) + END IF + END DO + ! + END DO + ! + CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzU) + CALL Reallocate(A_csc, nnzU) + ! + CALL csrcsc( & + & nrow, & + & 1, & + & 1, & + & A_csr, & + & JA_csr, & + & IA_csr, & + & A_csc, & + & JA_csc, & + & IA_csc) + ! + obj%nnz = nnz_parts(1) * 2 + nnz_parts(3) + obj%isDiagStored = .TRUE. + ! + CALL Reallocate(obj%IA, nrow + 1, obj%idiag, nrow) + CALL Reallocate(obj%JA, obj%nnz) + CALL Reallocate(A, obj%nnz) + ! + indx = 0 + ! + DO ii = 1, obj%nrow + ar = IA_csr(ii + 1) - IA_csr(ii) + al = IA_csc(ii + 1) - IA_csr(ii) + IF (idiag(ii) .NE. 0) THEN + ad = 1 + ELSE + ad = 0 + END IF + ! + obj%IA(ii) = indx + 1 + obj%IA(ii + 1) = obj%IA(ii) + ar + al + ad + ! + DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 + indx = indx + 1 + obj%JA(indx) = JA_csc(rindx) + A(indx) = A_csc(rindx) + END DO + ! + IF (idiag(ii) .NE. 0) THEN + indx = indx + 1 + obj%JA(indx) = ii !!obj%JA(idiag(ii)) + obj%idiag(ii) = indx + A(indx) = A_diag(ii) + END IF + ! + DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 + indx = indx + 1 + obj%JA(indx) = JA_csr(rindx) + A(indx) = A_csr(rindx) + END DO + ! + END DO + ! + ! Clean up + ! + DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, & + & A_csc, A_diag) + ! +END SUBROUTINE obj_GetSymU2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE obj_GetSymL1(obj, symobj, A, symA) + TYPE(CSRSparsity_), INTENT(IN) :: obj + TYPE(CSRSparsity_), INTENT(INOUT) :: symobj + REAL(DFP), INTENT(IN) :: A(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: symA(:) + ! + INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzL, ncol, & + & nnzD, al, ar, ad + INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & + & JA_csc(:), idiag(:) + REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:), A_diag(:) + ! + nnz_parts = GetNNZ(obj, [""]) + nrow = obj%nrow + ncol = obj%ncol + nnzL = nnz_parts(2) + nnzD = nnz_parts(3) + ! + CALL Reallocate(JA_csr, nnzL, IA_csr, nrow + 1) + CALL Reallocate(idiag, nrow) + CALL Reallocate(A_csr, nnzL) + CALL Reallocate(A_diag, nrow) + ! + indx = 0 + ! + DO ii = 1, nrow + IA_csr(ii) = indx + 1 + IA_csr(ii + 1) = IA_csr(ii) + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + jj = obj%JA(rindx) + IF (ii .GT. jj) THEN + indx = indx + 1 + IA_csr(ii + 1) = IA_csr(ii + 1) + 1 + JA_csr(indx) = jj + A_csr(indx) = A(rindx) + ELSE IF (ii .EQ. jj) THEN + idiag(ii) = rindx + A_diag(ii) = A(rindx) + END IF + END DO + END DO + ! + CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzL) + CALL Reallocate(A_csc, nnzL) + ! + CALL csrcsc( & + & nrow, & + & 1, & + & 1, & + & A_csr, & + & JA_csr, & + & IA_csr, & + & A_csc, & + & JA_csc, & + & IA_csc) + ! + symobj%nnz = nnzL * 2 + nnzD + symobj%ncol = ncol + symobj%nrow = nrow + symobj%isSorted = obj%isSorted + symobj%isInitiated = obj%isInitiated + symobj%isSparsityLock = obj%isSparsityLock + symobj%isDiagStored = .TRUE. + symobj%idof = obj%idof + symobj%jdof = obj%jdof + ! + CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) + CALL Reallocate(symobj%JA, symobj%nnz) + CALL Reallocate(symA, symobj%nnz) + ! + indx = 0 + ! + DO ii = 1, symobj%nrow + al = IA_csr(ii + 1) - IA_csr(ii) + ar = IA_csc(ii + 1) - IA_csc(ii) + IF (idiag(ii) .NE. 0) THEN + ad = 1 + ELSE + ad = 0 + END IF + ! + symobj%IA(ii) = indx + 1 + symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad + ! + DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csr(rindx) + symA(indx) = A_csr(rindx) + END DO + ! + IF (idiag(ii) .NE. 0) THEN + indx = indx + 1 + symobj%JA(indx) = ii !!obj%JA(idiag(ii)) + symobj%idiag(ii) = indx + symA(indx) = A_diag(ii) + END IF + ! + DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csc(rindx) + symA(indx) = A_csc(rindx) + END DO + ! + END DO + ! + ! Clean up + ! + DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, A_csc, A_diag) + ! +END SUBROUTINE obj_GetSymL1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE obj_GetSymL2(obj, A) + TYPE(CSRSparsity_), INTENT(INOUT) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: A(:) + ! + INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzL, ncol, & + & nnzD, al, ar, ad + INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & + & JA_csc(:), idiag(:) + REAL(DFP), ALLOCATABLE :: A_csr(:), A_csc(:), A_diag(:) + ! + nnz_parts = GetNNZ(obj, [""]) + nrow = obj%nrow + ncol = obj%ncol + nnzL = nnz_parts(2) + nnzD = nnz_parts(3) + ! + CALL Reallocate(JA_csr, nnzL, IA_csr, nrow + 1) + CALL Reallocate(idiag, nrow) + CALL Reallocate(A_csr, nnzL) + CALL Reallocate(A_Diag, nrow) + ! + indx = 0 + ! + DO ii = 1, nrow + IA_csr(ii) = indx + 1 + IA_csr(ii + 1) = IA_csr(ii) + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + jj = obj%JA(rindx) + IF (ii .GT. jj) THEN + indx = indx + 1 + IA_csr(ii + 1) = IA_csr(ii + 1) + 1 + JA_csr(indx) = jj + A_csr(indx) = A(rindx) + ELSE IF (ii .EQ. jj) THEN + idiag(ii) = rindx + A_diag(ii) = A(rindx) + END IF + END DO + END DO + ! + CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzL) + CALL Reallocate(A_csc, nnzL) + ! + CALL csrcsc( & + & nrow, & + & 1, & + & 1, & + & A_csr, & + & JA_csr, & + & IA_csr, & + & A_csc, & + & JA_csc, & + & IA_csc) + ! + obj%nnz = nnzL * 2 + nnzD + obj%ncol = ncol + obj%nrow = nrow + obj%isSorted = obj%isSorted + obj%isInitiated = obj%isInitiated + obj%isSparsityLock = obj%isSparsityLock + obj%isDiagStored = .TRUE. + obj%idof = obj%idof + obj%jdof = obj%jdof + ! + CALL Reallocate(obj%IA, nrow + 1, obj%idiag, nrow) + CALL Reallocate(obj%JA, obj%nnz) + CALL Reallocate(A, obj%nnz) + ! + indx = 0 + ! + DO ii = 1, obj%nrow + al = IA_csr(ii + 1) - IA_csr(ii) + ar = IA_csc(ii + 1) - IA_csc(ii) + ! + IF (idiag(ii) .NE. 0) THEN + ad = 1 + ELSE + ad = 0 + END IF + ! + obj%IA(ii) = indx + 1 + obj%IA(ii + 1) = obj%IA(ii) + ar + al + ad + ! + DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 + indx = indx + 1 + obj%JA(indx) = JA_csr(rindx) + A(indx) = A_csr(rindx) + END DO + ! + IF (idiag(ii) .NE. 0) THEN + indx = indx + 1 + obj%JA(indx) = ii + obj%idiag(ii) = indx + A(indx) = A_diag(ii) + END IF + ! + DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 + indx = indx + 1 + obj%JA(indx) = JA_csc(rindx) + A(indx) = A_csc(rindx) + END DO + ! + END DO + ! + ! Clean up + ! + DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag, A_csr, A_csc, A_diag) + ! +END SUBROUTINE obj_GetSymL2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSym1 +INTEGER(I4B) :: ii, jj, nrow, rindx +REAL(DFP) :: VALUE +! +! Matrix should be square +! +symObj%csrOwnership = obj%csrOwnership +symObj%tDimension = obj%tDimension +symObj%matrixProp = "SYM" + +IF (ALLOCATED(obj%A)) THEN + SELECT CASE (from) + CASE ("U", "u") + CALL obj_GetSymU1(obj=obj%csr, symobj=symobj%csr, A=obj%A, & + & symA=symobj%A) + CASE ("L", "l") + CALL obj_GetSymL1(obj=obj%csr, symobj=symobj%csr, A=obj%A, & + & symA=symobj%A) + CASE DEFAULT + CALL Errormsg(& + & msg="No match found for given from = "//from, & + & file=__FILE__, & + & routine="obj_GetSym1()", & + & line=__LINE__, & + & unitno=stderr) + STOP + END SELECT +END IF + +END PROCEDURE obj_GetSym1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSym2 +INTEGER(I4B) :: ii, jj, nrow, rindx +REAL(DFP) :: VALUE +! +! Matrix should be square +! +obj%matrixProp = "SYM" + +IF (ALLOCATED(obj%A)) THEN + SELECT CASE (from) + CASE ("U", "u") + CALL obj_GetSymU2(obj=obj%csr, A=obj%A) + CASE ("L", "l") + CALL obj_GetSymL2(obj=obj%csr, A=obj%A) + CASE DEFAULT + CALL Errormsg(& + & msg="No match found for given from = "//from, & + & file=__FILE__, & + & routine="obj_GetSym2()", & + & line=__LINE__, & + & unitno=stderr) + STOP + END SELECT +END IF + +END PROCEDURE obj_GetSym2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +END SUBMODULE Methods diff --git a/src/submodules/CSRSparsity/CMakeLists.txt b/src/submodules/CSRSparsity/CMakeLists.txt new file mode 100644 index 000000000..47a07b4d1 --- /dev/null +++ b/src/submodules/CSRSparsity/CMakeLists.txt @@ -0,0 +1,25 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2023 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/CSRSparsity_Method@ConstructorMethods.F90 + ${src_path}/CSRSparsity_Method@IOMethods.F90 + ${src_path}/CSRSparsity_Method@SetMethods.F90 + ${src_path}/CSRSparsity_Method@GetMethods.F90 + ${src_path}/CSRSparsity_Method@SymMethods.F90) diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 new file mode 100644 index 000000000..4f0a1cf4a --- /dev/null +++ b/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 @@ -0,0 +1,204 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 13 July 2021 +! summary: Methods related to CSR sparsity + +SUBMODULE(CSRSparsity_Method) ConstructorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate1 +#ifdef DEBUG_VER +INTEGER(I4B) :: tNodes1, tNodes2 +LOGICAL(LGT) :: isok, problem +#endif + +#ifdef DEBUG_VER + +problem = PRESENT(idof) .AND. (.NOT. PRESENT(jdof)) +IF (problem) THEN + CALL ErrorMSG( & + & "When idof is present, jdof should be present too.", & + & "CSRSparsity_Method@Constructor.F90", & + & "obj_initiate1()", & + & __LINE__, stderr) + STOP +END IF + +problem = PRESENT(jdof) .AND. (.NOT. PRESENT(idof)) +IF (problem) THEN + CALL ErrorMSG( & + & "When jdof is present, idof should be present too.", & + & "CSRSparsity_Method@Constructor.F90", & + & "obj_initiate1()", & + & __LINE__, stderr) + STOP +END IF + +isok = PRESENT(idof) +IF (isok) THEN + tnodes1 = .tNodes.idof + tnodes2 = .tNodes.jdof + problem = tnodes1 .NE. nrow .OR. tnodes2 .NE. ncol + IF (problem) THEN + CALL ErrorMSG( & + & "Size of the matrix does not conform with the dof data! "// & + & "tNodes1 = "//tostring(tnodes1)//" tNodes2="//tostring(tNodes2), & + & "CSRSparsity_Method@Constructor.F90", & + & "obj_initiate1()", & + & __LINE__, stderr) + STOP + END IF +END IF +#endif + +CALL DEALLOCATE (obj) + +obj%isInitiated = .TRUE. + +obj%nnz = Input(default=0_I4B, option=nnz) +obj%ncol = ncol +obj%nrow = nrow + +IF (PRESENT(idof)) THEN + obj%idof = idof +ELSE + CALL Initiate(obj=obj%idof, tNodes=[nrow], names=['K'], & + & spacecompo=[1], timecompo=[1], storageFMT=NODES_FMT) +END IF + +IF (PRESENT(jdof)) THEN + obj%jdof = jdof +ELSE + CALL Initiate(obj=obj%jdof, tNodes=[ncol], names=['K'], & + & spacecompo=[1], timecompo=[1], storageFMT=NODES_FMT) +END IF + +CALL Reallocate(obj%IA, nrow + 1) +CALL Reallocate(obj%idiag, nrow) + +IF (obj%nnz .GT. 0) THEN + CALL Reallocate(obj%JA, obj%nnz) +END IF + +END PROCEDURE obj_initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate2 +INTEGER(I4B) :: ii, n + +CALL DEALLOCATE (obj) +obj%nnz = obj2%nnz +obj%ncol = obj2%ncol +obj%nrow = obj2%nrow +obj%isSorted = obj2%isSorted +obj%isInitiated = obj2%isInitiated +obj%isSparsityLock = obj2%isSparsityLock +obj%isDiagStored = obj2%isDiagStored +IF (ALLOCATED(obj2%IA)) obj%IA = obj2%IA +IF (ALLOCATED(obj2%JA)) obj%JA = obj2%JA +IF (ALLOCATED(obj2%idiag)) obj%idiag = obj2%idiag +IF (ALLOCATED(obj%row)) THEN + n = SIZE(obj%row) + DO ii = 1, n + obj%row(ii) = obj2%row(ii) + END DO +END IF +obj%idof = obj2%idof +obj%jdof = obj2%jdof +END PROCEDURE obj_initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate3 +INTEGER(I4B) :: nrow, ncol0, nnz + +nrow = SIZE(IA) - 1 +ncol0 = Input(default=nrow, option=ncol) +nnz = SIZE(JA) +CALL Initiate(obj=obj, nrow=nrow, ncol=ncol0, nnz=nnz) +obj%IA = IA +obj%JA = JA +END PROCEDURE obj_Initiate3 + +!---------------------------------------------------------------------------- +! CSRSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_constructor1 +CALL Initiate(obj=ans, ncol=ncol, nrow=nrow, idof=idof, jdof=jdof) +END PROCEDURE obj_constructor1 + +!---------------------------------------------------------------------------- +! CSRSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_constructor2 +CALL Initiate(obj=ans, IA=IA, JA=JA) +END PROCEDURE obj_constructor2 + +!---------------------------------------------------------------------------- +! CSRSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_constructor_1 +ALLOCATE (CSRSparsity_ :: ans) +CALL Initiate(obj=ans, ncol=ncol, nrow=nrow, idof=idof, jdof=jdof) +END PROCEDURE obj_constructor_1 + +!---------------------------------------------------------------------------- +! CSRSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_constructor_2 +ALLOCATE (CSRSparsity_ :: ans) +CALL Initiate(obj=ans, IA=IA, JA=JA) +END PROCEDURE obj_constructor_2 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Deallocate +IF (ALLOCATED(obj%IA)) DEALLOCATE (obj%IA) +IF (ALLOCATED(obj%JA)) DEALLOCATE (obj%JA) +IF (ALLOCATED(obj%idiag)) DEALLOCATE (obj%idiag) +IF (ALLOCATED(obj%Row)) DEALLOCATE (obj%Row) +CALL DEALLOCATE (obj%idof) +CALL DEALLOCATE (obj%jdof) +obj%nnz = 0 +obj%nrow = 0 +obj%ncol = 0 +obj%isSorted = .FALSE. +obj%isInitiated = .FALSE. +obj%isSparsityLock = .FALSE. +obj%isDiagStored = .FALSE. +END PROCEDURE obj_Deallocate + +END SUBMODULE ConstructorMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 new file mode 100644 index 000000000..661012ffe --- /dev/null +++ b/src/submodules/CSRSparsity/src/CSRSparsity_Method@GetMethods.F90 @@ -0,0 +1,345 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 13 Jul 2021 +! summary: Input output related methods + +SUBMODULE(CSRSparsity_Method) GetMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Shape +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_shape +Ans = [obj%nrow, obj%ncol] +END PROCEDURE obj_shape + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_size +IF (PRESENT(Dims)) THEN + IF (Dims .EQ. 1) THEN + Ans = obj%nrow + ELSE + Ans = obj%ncol + END IF +ELSE + Ans = obj%nrow * obj%ncol +END IF +END PROCEDURE obj_size + +!---------------------------------------------------------------------------- +! GetNNZ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNNZ +Ans = obj%nnz +END PROCEDURE obj_GetNNZ + +!---------------------------------------------------------------------------- +! GetNNZ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNNZ_from_operation +INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isSorted0 + +isSorted0 = Input(default=.FALSE., option=isSorted) + +SELECT CASE (op) +CASE ("+", "-") + nrow = SIZE(obj1, 1) + ncol = SIZE(obj1, 2) + IF (isSorted0) THEN + ans = GetNNZ_Add_Subtract_sorted(nrow=nrow, ncol=ncol, ja=obj1%JA, & + & ia=obj1%IA, jb=obj2%JA, ib=obj2%IA) + ELSE + ans = GetNNZ_Add_Subtract(nrow=nrow, ncol=ncol, ja=obj1%JA, & + & ia=obj1%IA, jb=obj2%JA, ib=obj2%IA) + END IF +END SELECT +END PROCEDURE obj_GetNNZ_from_operation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetNNZ_Add_Subtract +INTEGER(I4B) :: ii, jcol, kb, ka +LOGICAL(LGT) :: iw(ncol) +ans = 0 + +DO ii = 1, nrow + iw = .FALSE. + DO ka = ia(ii), ia(ii + 1) - 1 + ans = ans + 1 + jcol = ja(ka) + iw(jcol) = .TRUE. + END DO + + DO kb = ib(ii), ib(ii + 1) - 1 + jcol = jb(kb) + IF (.NOT. iw(jcol)) THEN + ans = ans + 1 + iw(jcol) = .TRUE. + END IF + END DO +END DO +END PROCEDURE GetNNZ_Add_Subtract + +!---------------------------------------------------------------------------- +! GetNNZ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetNNZ_Add_Subtract_sorted +! internal variables +INTEGER(I4B) :: len, i, ka, kb, kc, & + & kamax, kbmax, j1, jj2 +LOGICAL(LGT) :: isok + +kc = 1 +DO i = 1, nrow + ka = ia(i) + kb = ib(i) + kamax = ia(i + 1) - 1 + kbmax = ib(i + 1) - 1 + + DO + isok = ka .LE. kamax .OR. kb .LE. kbmax + IF (.NOT. isok) EXIT + + IF (ka .LE. kamax) THEN + j1 = ja(ka) + ELSE + ! take j1 large enough that always jj2 .lt. j1 + j1 = ncol + 1 + END IF + + IF (kb .LE. kbmax) THEN + jj2 = jb(kb) + ELSE + ! similarly take jj2 large enough that always j1 .lt. jj2 + jj2 = ncol + 1 + END IF + + IF (j1 .EQ. jj2) THEN + ka = ka + 1 + kb = kb + 1 + kc = kc + 1 + ELSE IF (j1 .LT. jj2) THEN + ka = ka + 1 + kc = kc + 1 + ELSE IF (j1 .GT. jj2) THEN + kb = kb + 1 + kc = kc + 1 + END IF + END DO +END DO + +ans = kc - 1 +END PROCEDURE GetNNZ_Add_Subtract_sorted + +!---------------------------------------------------------------------------- +! GetNNZ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNNZ1 +INTEGER(I4B) :: ii, rindx +IF (obj%isInitiated) THEN + ans = 0 + SELECT CASE (from) + CASE ("L", "l") + DO ii = 1, obj%nrow + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + IF (ii .GT. obj%JA(rindx)) ans = ans + 1 + END DO + END DO + + CASE ("U", "u") + DO ii = 1, obj%nrow + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + IF (ii .LT. obj%JA(rindx)) ans = ans + 1 + END DO + END DO + + CASE ("D", "d") + DO ii = 1, obj%nrow + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + IF (ii .EQ. obj%JA(rindx)) ans = ans + 1 + END DO + END DO + CASE default + ans = obj%nnz + END SELECT +ELSE + ans = 0 +END IF +END PROCEDURE obj_GetNNZ1 + +!---------------------------------------------------------------------------- +! GetNNZ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNNZ2 +INTEGER(I4B) :: ii, rindx +IF (obj%isInitiated) THEN + ans = 0 + + DO ii = 1, obj%nrow + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + IF (ii .LT. obj%JA(rindx)) THEN + ! U + ans(1) = ans(1) + 1 + ELSEIF (ii .GT. obj%JA(rindx)) THEN + ! L + ans(2) = ans(2) + 1 + ELSEIF (ii .EQ. obj%JA(rindx)) THEN + ! D + ans(3) = ans(3) + 1 + END IF + END DO + END DO +ELSE + ans = 0 +END IF +END PROCEDURE obj_GetNNZ2 + +!---------------------------------------------------------------------------- +! GetDiagonal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetDiagonal1 +INTEGER(I4B) :: len0 +CALL Reallocate(diag, obj%nrow, idiag, obj%nrow) +CALL GetDIA( & + & obj%nrow,& + & obj%ncol,& + & 0,& + & A,& + & obj%JA,& + & obj%IA,& + & len0,& + & diag,& + & idiag,& + & INPUT(option=offSet, default=0)) +END PROCEDURE obj_GetDiagonal1 + +!---------------------------------------------------------------------------- +! GetDiagonal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetDiagonal2 +INTEGER(I4B) :: ii + +IF (obj%isDiagStored) THEN + + CALL Reallocate(diag, obj%nrow) + DO ii = 1, SIZE(diag) + diag(ii) = A(obj%idiag(ii)) + END DO + +ELSE + CALL Reallocate(diag, obj%nrow) + CALL GetDIA( & + & obj%nrow,& + & obj%ncol,& + & 0,& + & A,& + & obj%JA,& + & obj%IA,& + & ii,& + & diag,& + & obj%idiag,& + & INPUT(option=offSet, default=0)) + obj%isDiagStored = .TRUE. +END IF + +END PROCEDURE obj_GetDiagonal2 + +!---------------------------------------------------------------------------- +! GetColNumber +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetColNumber1 +ans = obj%JA(indx) +END PROCEDURE obj_GetColNumber1 + +!---------------------------------------------------------------------------- +! GetColIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetColIndex1 +ans(1) = obj%IA(irow) +ans(2) = obj%IA(irow + 1) - 1 +END PROCEDURE obj_GetColIndex1 + +!---------------------------------------------------------------------------- +! startColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_startColumn1 +ans = obj%IA(irow) +END PROCEDURE obj_startColumn1 + +!---------------------------------------------------------------------------- +! endColumn +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_endColumn1 +ans = obj%IA(irow + 1) - 1 +END PROCEDURE obj_endColumn1 + +!---------------------------------------------------------------------------- +! GetIA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIA +ans = obj%IA(irow) +END PROCEDURE obj_GetIA + +!---------------------------------------------------------------------------- +! GetJA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetJA +ans = obj%JA(indx) +END PROCEDURE obj_GetJA + +END SUBMODULE GetMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 new file mode 100644 index 000000000..752cc138b --- /dev/null +++ b/src/submodules/CSRSparsity/src/CSRSparsity_Method@IOMethods.F90 @@ -0,0 +1,65 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 13 Jul 2021 +! summary: Input output related methods + +SUBMODULE(CSRSparsity_Method) IOMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Display +CALL Display(Msg, unitNo=unitNo) +CALL Display(obj%nnz, "# NNZ : ", unitNo=unitNo) +CALL Display(obj%ncol, "# NCOL : ", unitNo=unitNo) +CALL Display(obj%nrow, "# NROW : ", unitNo=unitNo) +CALL Display(obj%idof, "# iDOF : ", unitNo=unitNo) +CALL Display(obj%jdof, "# jDOF : ", unitNo=unitNo) +!! +IF (ALLOCATED(obj%IA)) THEN + CALL Display(obj%IA, "# IA : ", unitNo=unitNo, advance="NO") +ELSE + CALL Display("# IA is not allocated", UnitNo=UnitNo) +END IF +!! +IF (ALLOCATED(obj%JA)) THEN + CALL Display(obj%JA, "# JA : ", unitNo=unitNo, advance="NO") +ELSE + CALL Display("# JA is not allocated", UnitNo=UnitNo) +END IF +!! +CALL Display("", unitNo=UnitNo, advance=.TRUE.) +!! +IF (ALLOCATED(obj%idiag)) THEN + CALL Display(obj%idiag, "# idiag : ", unitNo=unitNo) +ELSE + CALL Display("# idiag is not allocated", UnitNo=UnitNo) +END IF +!! +IF (ALLOCATED(obj%row)) THEN + CALL Display(obj%row, "# ROW : ", unitNo=unitNo, orient="ROW") +END IF +!! +END PROCEDURE obj_Display + +END SUBMODULE IOMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 new file mode 100644 index 000000000..3f7c4c094 --- /dev/null +++ b/src/submodules/CSRSparsity/src/CSRSparsity_Method@SetMethods.F90 @@ -0,0 +1,341 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 13 Jul 2021 +! summary: Input output related methods + +SUBMODULE(CSRSparsity_Method) SetMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity1 +INTEGER(I4B) :: ii !n, a, b, m, tdof +INTEGER(I4B), ALLOCATABLE :: n2ntemp(:), rowIndex(:) +! +#ifdef DEBUG_VER +! +! check +! +IF (.NOT. obj%isInitiated) THEN + CALL ErrorMSG( & + & "Instance of CSRSparsity is not initiated!", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity1()", & + & __LINE__, stderr) + STOP +END IF +! +! check +! +IF (obj%isSparsityLock) THEN + CALL ErrorMSG( & + & "Instance of CSRSparsity is locked for setting sparsity pattern!", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity1()", & + & __LINE__, stderr) + STOP +END IF +#endif +! +IF (.NOT. ALLOCATED(obj%row)) ALLOCATE (obj%row(obj%nrow)) +! +IF (SIZE(Col) .GT. 0) THEN + n2ntemp = SORT(getIndex(obj=obj%jdof, nodeNum=Col)) + rowIndex = SORT(getIndex(obj=obj%idof, nodeNum=Row)) + obj%nnz = obj%nnz + SIZE(Col) * (.tdof.obj%jdof) * SIZE(rowIndex) + ! + DO ii = 1, SIZE(rowIndex) + CALL APPEND(obj%Row(rowIndex(ii)), n2ntemp) + END DO + ! +END IF +! +IF (ALLOCATED(n2ntemp)) DEALLOCATE (n2ntemp) +IF (ALLOCATED(rowIndex)) DEALLOCATE (rowIndex) +! +END PROCEDURE obj_setSparsity1 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity2 +INTEGER(I4B) :: i +DO i = 1, SIZE(Row) + CALL setSparsity(obj, Row(i), Col(i)%Val) +END DO +END PROCEDURE obj_setSparsity2 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity3 +INTEGER(I4B) :: ii +INTEGER(I4B), ALLOCATABLE :: n2ntemp(:), rowIndex(:) +! +#ifdef DEBUG_VER +! +! check +! +IF (.NOT. obj%isInitiated) THEN + CALL ErrorMSG( & + & "Instance of CSRSparsity is not initiated!", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity3()", & + & __LINE__, stderr) + STOP +END IF +! +! check +! +IF (obj%isSparsityLock) THEN + CALL ErrorMSG( & + & "Instance of CSRSparsity is locked for setting sparsity pattern!", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity3()", & + & __LINE__, stderr) + STOP +END IF +! +! check +! +IF (obj%idof%StorageFMT .EQ. NODES_FMT) THEN + CALL ErrorMSG( & + & "This subroutine works for storage format FMT_DOF, only", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity3()", & + & __LINE__, stderr) + STOP +END IF + +IF (obj%jdof%StorageFMT .EQ. NODES_FMT) THEN + CALL ErrorMSG( & + & "This subroutine works for storage format FMT_DOF, only", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity3()", & + & __LINE__, stderr) + STOP +END IF +#endif +! +! cleaning +! +IF (.NOT. ALLOCATED(obj%row)) ALLOCATE (obj%row(obj%nrow)) +! +IF (SIZE(col) .GT. 0) THEN + ! + n2ntemp = SORT(getIndex(obj=obj%jdof, nodeNum=Col, iVar=jvar)) + rowIndex = SORT(getIndex(obj=obj%idof, nodeNum=Row, iVar=ivar)) + obj%nnz = obj%nnz + SIZE(Col) * (obj%jdof.tdof.jvar) * SIZE(rowIndex) + DO ii = 1, SIZE(rowIndex) + CALL APPEND(obj%Row(rowIndex(ii)), n2ntemp) + END DO + ! +END IF +! +IF (ALLOCATED(n2ntemp)) DEALLOCATE (n2ntemp) +IF (ALLOCATED(rowIndex)) DEALLOCATE (rowIndex) +END PROCEDURE obj_setSparsity3 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity4 +INTEGER(I4B) :: i +DO i = 1, SIZE(Row) + CALL setSparsity(obj, Row(i), Col(i)%Val, ivar, jvar) +END DO +END PROCEDURE obj_setSparsity4 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity5 +INTEGER(I4B), ALLOCATABLE :: row(:), graphT(:, :) +TYPE(IntVector_), ALLOCATABLE :: col(:) +INTEGER(I4B) :: ii, jj, kk, nn, nrow, ncol +! +nrow = SIZE(graph, 1) +ncol = SIZE(graph, 2) +graphT = TRANSPOSE(graph) +! +CALL Reallocate(row, nrow) +ALLOCATE (col(nrow)) +! +DO ii = 1, nrow + row(ii) = ii + nn = COUNT(graphT(:, ii) .NE. 0) + CALL ALLOCATE (col(ii), nn) + kk = 0 + DO jj = 1, ncol + IF (graphT(jj, ii) .NE. 0) THEN + kk = kk + 1 + CALL Set(col(ii), indx=kk, VALUE=jj) + END IF + END DO +END DO +! +CALL setSparsity(obj=obj, row=row, col=col) +! +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +IF (ALLOCATED(graphT)) DEALLOCATE (graphT) +! +END PROCEDURE obj_setSparsity5 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity6 +INTEGER(I4B), ALLOCATABLE :: row(:) +LOGICAL(LGT), ALLOCATABLE :: graphT(:, :) +TYPE(IntVector_), ALLOCATABLE :: col(:) +INTEGER(I4B) :: ii, jj, kk, nn, nrow, ncol +! +nrow = SIZE(graph, 1) +ncol = SIZE(graph, 2) +graphT = TRANSPOSE(graph) +! +CALL Reallocate(row, nrow) +ALLOCATE (col(nrow)) +! +DO ii = 1, nrow + row(ii) = ii + nn = COUNT(graphT(:, ii)) + CALL ALLOCATE (col(ii), nn) + kk = 0 + DO jj = 1, ncol + IF (graphT(jj, ii)) THEN + kk = kk + 1 + CALL Set(col(ii), indx=kk, VALUE=jj) + END IF + END DO +END DO +! +CALL setSparsity(obj=obj, row=row, col=col) +! +IF (ALLOCATED(row)) DEALLOCATE (row) +IF (ALLOCATED(col)) DEALLOCATE (col) +IF (ALLOCATED(graphT)) DEALLOCATE (graphT) +! +END PROCEDURE obj_setSparsity6 + +!---------------------------------------------------------------------------- +! setSparsity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_setSparsity_final +INTEGER(I4B) :: i, j, k +INTEGER(I4B), ALLOCATABLE :: intvec(:) +! +IF (.NOT. obj%isInitiated) THEN + CALL ErrorMSG( & + & "Instance of CSRSparsity is not initiated!", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity_final()", & + & __LINE__, stderr) + STOP +END IF +! +IF (obj%isSparsityLock) THEN + CALL WarningMSG( & + & "Instance of CSRSparsity is locked for setting sparsity pattern!", & + & "CSRSparsity_Method@SetMethods.F90", & + & "obj_setSparsity_final()", & + & __LINE__, stderr) + RETURN +ELSE + obj%isSparsityLock = .TRUE. +END IF +! +! Remove duplicate entries in obj%Row( irow )%Col +! +IF (ALLOCATED(obj%Row)) THEN + k = 0 + DO i = 1, obj%nrow + CALL RemoveDuplicates(obj%Row(i)) + k = k + SIZE(obj%Row(i)) + END DO + ! + ! update nnz: number of non zeros + ! + obj%nnz = k + ! + ! allocate obj%JA and obj%A + ! + CALL Reallocate(obj%JA, obj%nnz) + ! + ! convert data into IA, JA + ! + obj%IA(1) = 1 + ! + DO i = 1, obj%nrow + ! obj%RowSize( i ) = SIZE( obj%Row( i ) ) + k = SIZE(obj%Row(i)) + obj%IA(i + 1) = obj%IA(i) + k + IF (k .NE. 0) & + & obj%JA(obj%IA(i):obj%IA(i + 1) - 1) = obj%Row(i)%Val + END DO + ! + DEALLOCATE (obj%Row) + ! +END IF +! +j = SIZE(obj%JA) +! +IF (j .GT. obj%nnz) THEN + ! + intvec = obj%JA(1:obj%nnz) + CALL Reallocate(obj%JA, obj%nnz) + obj%JA = intvec + CALL Reallocate(intvec, obj%ncol) + ! +END IF +! +END PROCEDURE obj_setSparsity_final + +!---------------------------------------------------------------------------- +! SetIA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SetIA +obj%IA(irow) = VALUE +END PROCEDURE obj_SetIA + +!---------------------------------------------------------------------------- +! SetJA +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SetJA +obj%JA(indx) = VALUE +END PROCEDURE obj_SetJA + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE SetMethods diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 new file mode 100644 index 000000000..0ead15731 --- /dev/null +++ b/src/submodules/CSRSparsity/src/CSRSparsity_Method@SymMethods.F90 @@ -0,0 +1,263 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 13 Jul 2021 +! summary: Input output related methods + +SUBMODULE(CSRSparsity_Method) SymMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE obj_GetSymU1(obj, symobj) + TYPE(CSRSparsity_), INTENT(IN) :: obj + TYPE(CSRSparsity_), INTENT(INOUT) :: symobj + ! + INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzU, ncol, & + & nnzD, al, ar, ad + INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & + & JA_csc(:), idiag(:) + REAL(DFP) :: real_dummy(1) + ! + nnz_parts = GetNNZ(obj, [""]) + nrow = obj%nrow + ncol = obj%ncol + nnzU = nnz_parts(1) + nnzD = nnz_parts(3) + ! + CALL Reallocate(JA_csr, nnzU, IA_csr, nrow + 1) + CALL Reallocate(idiag, nrow) + ! + indx = 0 + ! + DO ii = 1, nrow + IA_csr(ii) = indx + 1 + IA_csr(ii + 1) = IA_csr(ii) + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + jj = obj%JA(rindx) + IF (ii .LT. jj) THEN + indx = indx + 1 + IA_csr(ii + 1) = IA_csr(ii + 1) + 1 + JA_csr(indx) = jj + ELSE IF (ii .EQ. jj) THEN + idiag(ii) = rindx + END IF + END DO + END DO + ! + CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzU) + ! + CALL csrcsc( & + & nrow, & + & 0, & + & 1, & + & real_dummy, & + & JA_csr, & + & IA_csr, & + & real_dummy, & + & JA_csc, & + & IA_csc) + ! + symobj%nnz = nnz_parts(1) * 2 + nnz_parts(3) + symobj%ncol = ncol + symobj%nrow = nrow + symobj%isSorted = obj%isSorted + symobj%isInitiated = obj%isInitiated + symobj%isSparsityLock = obj%isSparsityLock + symobj%isDiagStored = .TRUE. + symobj%idof = obj%idof + symobj%jdof = obj%jdof + ! + CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) + CALL Reallocate(symobj%JA, symobj%nnz) + ! + indx = 0 + ! + DO ii = 1, symobj%nrow + ar = IA_csr(ii + 1) - IA_csr(ii) + al = IA_csc(ii + 1) - IA_csr(ii) + IF (idiag(ii) .NE. 0) THEN + ad = 1 + ELSE + ad = 0 + END IF + ! + symobj%IA(ii) = indx + 1 + symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad + ! + DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csc(rindx) + END DO + ! + IF (idiag(ii) .NE. 0) THEN + indx = indx + 1 + symobj%JA(indx) = obj%JA(idiag(ii)) + symobj%idiag(ii) = indx + END IF + ! + DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csr(rindx) + END DO + ! + END DO + ! + ! Clean up + ! + DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag) + ! +END SUBROUTINE obj_GetSymU1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE obj_GetSymL1(obj, symobj) + TYPE(CSRSparsity_), INTENT(IN) :: obj + TYPE(CSRSparsity_), INTENT(INOUT) :: symobj + ! + INTEGER(I4B) :: nnz_parts(3), ii, jj, rindx, indx, nrow, nnzL, ncol, & + & nnzD, al, ar, ad + INTEGER(I4B), ALLOCATABLE :: IA_csr(:), IA_csc(:), JA_csr(:), & + & JA_csc(:), idiag(:) + REAL(DFP) :: real_dummy(1) + ! + nnz_parts = GetNNZ(obj, [""]) + nrow = obj%nrow + ncol = obj%ncol + nnzL = nnz_parts(2) + nnzD = nnz_parts(3) + ! + CALL Reallocate(JA_csr, nnzL, IA_csr, nrow + 1) + CALL Reallocate(idiag, nrow) + ! + indx = 0 + ! + DO ii = 1, nrow + IA_csr(ii) = indx + 1 + IA_csr(ii + 1) = IA_csr(ii) + DO rindx = obj%IA(ii), obj%IA(ii + 1) - 1 + jj = obj%JA(rindx) + IF (ii .GT. jj) THEN + indx = indx + 1 + IA_csr(ii + 1) = IA_csr(ii + 1) + 1 + JA_csr(indx) = jj + ELSE IF (ii .EQ. jj) THEN + idiag(ii) = rindx + END IF + END DO + END DO + ! + CALL Reallocate(IA_csc, ncol + 1, JA_csc, nnzL) + ! + CALL csrcsc( & + & nrow, & + & 0, & + & 1, & + & real_dummy, & + & JA_csr, & + & IA_csr, & + & real_dummy, & + & JA_csc, & + & IA_csc) + ! + symobj%nnz = nnzL * 2 + nnzD + symobj%ncol = ncol + symobj%nrow = nrow + symobj%isSorted = obj%isSorted + symobj%isInitiated = obj%isInitiated + symobj%isSparsityLock = obj%isSparsityLock + symobj%isDiagStored = .TRUE. + symobj%idof = obj%idof + symobj%jdof = obj%jdof + ! + CALL Reallocate(symobj%IA, nrow + 1, symobj%idiag, nrow) + CALL Reallocate(symobj%JA, symobj%nnz) + ! + indx = 0 + ! + DO ii = 1, symobj%nrow + al = IA_csr(ii + 1) - IA_csr(ii) + ar = IA_csc(ii + 1) - IA_csc(ii) + IF (idiag(ii) .NE. 0) THEN + ad = 1 + ELSE + ad = 0 + END IF + ! + symobj%IA(ii) = indx + 1 + symobj%IA(ii + 1) = symobj%IA(ii) + ar + al + ad + ! + DO rindx = IA_csr(ii), IA_csr(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csr(rindx) + END DO + ! + IF (idiag(ii) .NE. 0) THEN + indx = indx + 1 + symobj%JA(indx) = obj%JA(idiag(ii)) + symobj%idiag(ii) = indx + END IF + ! + DO rindx = IA_csc(ii), IA_csc(ii + 1) - 1 + indx = indx + 1 + symobj%JA(indx) = JA_csc(rindx) + END DO + ! + END DO + ! + ! Clean up + ! + DEALLOCATE (IA_csr, IA_csc, JA_csr, JA_csc, idiag) + ! +END SUBROUTINE obj_GetSymL1 + +!---------------------------------------------------------------------------- +! GetSym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSym1 +SELECT CASE (from) +CASE ("U", "u") + CALL obj_GetSymU1(obj=obj, symobj=symobj) +CASE ("L", "l") + CALL obj_GetSymL1(obj=obj, symobj=symobj) +CASE default + CALL Errormsg( & + & msg="No case found for given from = "//from, & + & file=__FILE__, & + & routine="obj_GetSym1()", & + & line=__LINE__, & + & unitno=stderr) +END SELECT +END PROCEDURE obj_GetSym1 + +!---------------------------------------------------------------------------- +! GetSym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSym2 + +END PROCEDURE obj_GetSym2 + +END SUBMODULE SymMethods diff --git a/src/submodules/ConvectiveMatrix/CMakeLists.txt b/src/submodules/ConvectiveMatrix/CMakeLists.txt new file mode 100644 index 000000000..1450545c3 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/ConvectiveMatrix_Method@Methods.F90 + ) diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part new file mode 100755 index 000000000..cc963bef2 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/Constructor.part @@ -0,0 +1,99 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Row, Col, NIP ) + +!. . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( Row, Col ); Obj % SD( NIP ) +!. . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( ConvectiveMatrix_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIP + + ALLOCATE( Constructor_1 ) + + ALLOCATE( Constructor_1 % Mat2( row, col ) ) + Constructor_1 % Mat2 = 0.0_DFP + CALL Constructor_1 % Initiate( NIP = NIP ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( ConvectiveMatrix_ ), POINTER :: Constructor_2 + ALLOCATE( Constructor_2 ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Row, Col, NIP ) + +!. . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( Row, Col ); Obj % SD( NIP ) +!. . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( ConvectiveMatrix_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIP + + ALLOCATE( Constructor1 % Mat2( row, col ) ) + Constructor1 % Mat2 = 0.0_DFP + CALL Constructor1 % Initiate( NIP = NIP ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( ConvectiveMatrix_ ) :: Constructor2 + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part new file mode 100755 index 000000000..9894eeaca --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_10.part @@ -0,0 +1,170 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_10.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ConvectiveMatrix_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getConvectiveMatrix_10 +!------------------------------------------------------------------------------ +! +SUBROUTINE getConvectiveMatrix_10( Obj, A, Term1, Term2, XType, MultiVar ) + + !. . . . . . . . . . . . . . . . + ! 1. A is constant in space + !. . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef SpaceMat + CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M + INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) + REAL( DFP ) :: RealVal + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_10(), Flag-1", & + "ConvectiveMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1 ) % getNNS( ) + NSD = Obj % SD( 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_10()", & + "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) + Error_Flag = .TRUE. + RETURN + END IF + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_10()", & + "XType is dx, therefore, NSD cannot be less than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_10()", & + "XType is dx, therefore, NSD cannot be less than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_10()", & + "XType is dx, therefore, NSD cannot be less than 3" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE DEFAULT + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_10()", & + "No case found for given Xtype, & + & Make sure it is in the set & + & [dx, dX, dx1, dX1, x, X, x1, X1], & + & [dy, dY, dx2, dX2, y, Y, x2, X2], & + & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + + ALLOCATE( RC( M, 2 ) ) + DO i = 1, M + RC( i, 1 ) = ( i - 1 ) * NNS + 1 + RC( i, 2 ) = i * NNS + END DO + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + Indx = 1_I4B + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + Indx = 2_I4B + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + Indx = 3_I4B + CASE DEFAULT + Indx = 0_I4B + END SELECT + + IF( Term1 .EQ. 1 ) THEN + Aij = TRANSPOSE( A ) + ELSE + Aij = A + END IF + + DO IPS = 1, NIPS + + RealVal = Obj % SD( IPS ) % Ws & + & * Obj % SD( IPS ) % Js_Xi2Xt & + & * Obj % SD( IPS ) % Thickness + + IF( Term1 .EQ. 1 ) THEN + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & + & b = Obj % SD( IPS ) % N ) + ELSE + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & + & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) + END IF + + DO j = 1, M + DO i = 1, M + Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & + & RC( j, 1 ) : RC( j, 2 ) ) = & + & Aij( i, j ) * RealVal * Mat2 + END DO + END DO + + END DO + + DEALLOCATE( Mat2, RC, Indx, Aij ) + +END SUBROUTINE getConvectiveMatrix_10 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part new file mode 100755 index 000000000..852c64c2c --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_11.part @@ -0,0 +1,191 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_11.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_11 +!------------------------------------------------------------------------------ + +SUBROUTINE getConvectiveMatrix_11( Obj, A, A0, Term1, Term2, XType, MultiVar ) + + !. . . . . . . . . . . . . . . . + ! 1. - Returns mass matrix; C is a 2D array of Space Nodal Values + ! The first index is for spatial component and second index is + ! is for spatial nodal values. + !. . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef SpaceMat + CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A, A0 + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M + INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) + REAL( DFP ) :: RealVal + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11(), Flag-1", & + "ConvectiveMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1 ) % getNNS( ) + NSD = Obj % SD( 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + IF( SIZE( A, 3 ) .NE. NIPS ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "SIZE( A, 3 ) should be equal to the NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( A0, 3 ) .NE. NIPS ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "SIZE( A0, 3 ) should be equal to the NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "SIZE( A0, 1 ) should be equal to SIZE( A0, 2 )" ) + Error_Flag = .TRUE. + RETURN + END IF + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "XType is dx, therefore, NSD cannot be less than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "XType is dx, therefore, NSD cannot be less than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "XType is dx, therefore, NSD cannot be less than 3" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE DEFAULT + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "No case found for given Xtype, & + & Make sure it is in the set & + & [dx, dX, dx1, dX1, x, X, x1, X1], & + & [dy, dY, dx2, dX2, y, Y, x2, X2], & + & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + + ALLOCATE( RC( M, 2 ) ) + DO i = 1, M + RC( i, 1 ) = ( i - 1 ) * NNS + 1 + RC( i, 2 ) = i * NNS + END DO + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + Indx = 1_I4B + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + Indx = 2_I4B + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + Indx = 3_I4B + CASE DEFAULT + Indx = 0_I4B + END SELECT + + DO IPS = 1, NIPS + + RealVal = Obj % SD( IPS ) % Ws & + & * Obj % SD( IPS ) % Js_Xi2Xt & + & * Obj % SD( IPS ) % Thickness + + IF( Term1 .EQ. 1 ) THEN + ! A^T A0 + Aij = MATMUL( TRANSPOSE( A( :, :, IPS ) ), A0( :, :, IPS ) ) + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & + & b = Obj % SD( IPS ) % N ) + ELSE + ! A0^T A + Aij = MATMUL( TRANSPOSE( A0( :, :, IPS ) ), A( :, :, IPS ) ) + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & + & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) + END IF + + DO j = 1, M + DO i = 1, M + Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & + & RC( j, 1 ) : RC( j, 2 ) ) = & + & Aij( i, j ) * RealVal * Mat2 + END DO + END DO + + END DO + + DEALLOCATE( Mat2, RC, Indx, Aij ) + +END SUBROUTINE getConvectiveMatrix_11 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part new file mode 100755 index 000000000..cb2e3ca5f --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_12.part @@ -0,0 +1,180 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_12.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_12 +!------------------------------------------------------------------------------ + +SUBROUTINE getConvectiveMatrix_12( Obj, A, A0, Term1, Term2, XType, MultiVar ) + + !------------------------------------------------------------------------------ + ! 1. - Returns mass matrix; C is a 2D array of Space Nodal Values + ! The first index is for spatial component and second index is + ! is for spatial nodal values. + !------------------------------------------------------------------------------ + + ! Define intent of dummy variables +#ifdef SpaceMat + CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, A0 + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M + INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) + REAL( DFP ) :: RealVal + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12(), Flag-1", & + "ConvectiveMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1 ) % getNNS( ) + NSD = Obj % SD( 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "SIZE( A0, 1 ) should be equal to SIZE( A0, 2 )" ) + Error_Flag = .TRUE. + RETURN + END IF + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "XType is dx, therefore, NSD cannot be less than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "XType is dx, therefore, NSD cannot be less than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "XType is dx, therefore, NSD cannot be less than 3" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE DEFAULT + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "No case found for given Xtype, & + & Make sure it is in the set & + & [dx, dX, dx1, dX1, x, X, x1, X1], & + & [dy, dY, dx2, dX2, y, Y, x2, X2], & + & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + + ALLOCATE( RC( M, 2 ) ) + DO i = 1, M + RC( i, 1 ) = ( i - 1 ) * NNS + 1 + RC( i, 2 ) = i * NNS + END DO + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + Indx = 1_I4B + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + Indx = 2_I4B + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + Indx = 3_I4B + CASE DEFAULT + Indx = 0_I4B + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) + Obj % Mat2 = 0.0_DFP + + IF( Term1 .EQ. 1 ) THEN + Aij = MATMUL( TRANSPOSE( A ), A0 ) + ELSE + Aij = MATMUL( TRANSPOSE( A0 ), A ) + END IF + + DO IPS = 1, NIPS + + RealVal = Obj % SD( IPS ) % Ws & + & * Obj % SD( IPS ) % Js_Xi2Xt & + & * Obj % SD( IPS ) % Thickness + + IF( Term1 .EQ. 1 ) THEN + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & + & b = Obj % SD( IPS ) % N ) + ELSE + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & + & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) + END IF + + DO j = 1, M + DO i = 1, M + Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & + & RC( j, 1 ) : RC( j, 2 ) ) = & + & Aij( i, j ) * RealVal * Mat2 + END DO + END DO + + END DO + + DEALLOCATE( Mat2, RC, Indx, Aij ) + +END SUBROUTINE getConvectiveMatrix_12 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part new file mode 100755 index 000000000..f2e1b3623 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_9.part @@ -0,0 +1,173 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_9.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_9 +!------------------------------------------------------------------------------ + +SUBROUTINE getConvectiveMatrix_9( Obj, A, Term1, Term2, XType, MultiVar ) + + !. . . . . . . . . . . . . . . . + ! 1. A changes in space; + !. . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef SpaceMat + CLASS( SpaceMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NIPS, IPS, NSD, i, j, M + INTEGER( I4B ), ALLOCATABLE :: RC( :, : ), Indx + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Aij( :, : ) + REAL( DFP ) :: RealVal + +#ifdef DEBU_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9(), Flag-1", & + "ConvectiveMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1 ) % getNNS( ) + NSD = Obj % SD( 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + IF( SIZE( A, 3 ) .NE. NIPS ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "SIZE( A, 3 ) should be equal to the NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "SIZE( A, 1 ) should be equal to SIZE( A, 2 )" ) + Error_Flag = .TRUE. + RETURN + END IF + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "XType is dx, therefore, NSD cannot be less than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "XType is dx, therefore, NSD cannot be less than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "XType is dx, therefore, NSD cannot be less than 3" ) + Error_Flag = .TRUE. + RETURN + END IF + CASE DEFAULT + CALL Err_Msg("ConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "No case found for given Xtype, & + & Make sure it is in the set & + & [dx, dX, dx1, dX1, x, X, x1, X1], & + & [dy, dY, dx2, dX2, y, Y, x2, X2], & + & [dz, dZ, dx3, dX3, z, Z, x3, X3]" ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + + ALLOCATE( RC( M, 2 ) ) + DO i = 1, M + RC( i, 1 ) = ( i - 1 ) * NNS + 1 + RC( i, 2 ) = i * NNS + END DO + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*M, NNS*M ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1" ) + Indx = 1_I4B + CASE( "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2" ) + Indx = 2_I4B + CASE( "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + Indx = 3_I4B + CASE DEFAULT + Indx = 0_I4B + END SELECT + + DO IPS = 1, NIPS + + RealVal = Obj % SD( IPS ) % Ws & + & * Obj % SD( IPS ) % Js_Xi2Xt & + & * Obj % SD( IPS ) % Thickness + + IF( Term1 .EQ. 1 ) THEN + Aij = TRANSPOSE( A( :, :, IPS ) ) + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % dNdXt( :, Indx ), & + & b = Obj % SD( IPS ) % N ) + ELSE + Aij = A( :, :, IPS ) + Mat2 = OUTERPROD( a = Obj % SD( IPS ) % N, & + & b = Obj % SD( IPS ) % dNdXt( :, Indx ) ) + END IF + + DO j = 1, M + DO i = 1, M + Obj % Mat2( RC( i, 1 ) : RC( i, 2 ), & + & RC( j, 1 ) : RC( j, 2 ) ) = & + & Aij( i, j ) * RealVal * Mat2 + END DO + END DO + + END DO + + DEALLOCATE( Mat2, RC, Indx, Aij ) + +END SUBROUTINE getConvectiveMatrix_9 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 new file mode 100755 index 000000000..5285e3e53 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/ConvectiveMatrix_Class.f90 @@ -0,0 +1,81 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_Class.f90 +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - ElemShapeData_ Class is extended for computing the Convection or +! Advection matrix. +!============================================================================== + +MODULE ConvectiveMatrix_Class + USE IO + USE GlobalData + USE Utility, ONLY : OUTERPROD + + USE ElemShapeData_Class + USE ShapeData_Class + + IMPLICIT NONE + PRIVATE + PUBLIC :: ConvectiveMatrix_, ConvectiveMatrix, ConvectiveMatrix_Pointer + +!------------------------------------------------------------------------------ +! ElemShapeData_ +!------------------------------------------------------------------------------ + +TYPE, EXTENDS( ElemShapeData_ ) :: ConvectiveMatrix_ + +!. . . . . . . . . . . . . . . . . . . . +! 1. This class for computation of convective matrix +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + PROCEDURE, PUBLIC, PASS( Obj ) :: & +#include "./MethodNames.part" + +END TYPE ConvectiveMatrix_ + +!------------------------------------------------------------------------------ +! Constructor +!------------------------------------------------------------------------------ + + INTERFACE ConvectiveMatrix_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2 + END INTERFACE + + INTERFACE ConvectiveMatrix + MODULE PROCEDURE Constructor1, Constructor2 + END INTERFACE + +!------------------------------------------------------------------------------ +! CONTAINS +!------------------------------------------------------------------------------ + +CONTAINS + +#include "./Constructor.part" +#include "./ConvectiveMatrix_1.part" +#include "./ConvectiveMatrix_2.part" +#include "./ConvectiveMatrix_3.part" +#include "./ConvectiveMatrix_4.part" +#include "./ConvectiveMatrix_5.part" +#include "./ConvectiveMatrix_6.part" +#include "./ConvectiveMatrix_7.part" +#include "./ConvectiveMatrix_8.part" +#include "./ConvectiveMatrix_9.part" +#include "./ConvectiveMatrix_10.part" +#include "./ConvectiveMatrix_11.part" +#include "./ConvectiveMatrix_12.part" + +END MODULE ConvectiveMatrix_Class +! diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md new file mode 100755 index 000000000..e943a33ed --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MdFiles/ConvectiveMatrix_Class.md @@ -0,0 +1,1036 @@ +# Convective Matrix Class + +## Structure + +## Constructor methods + +There are two methods to initiate `ConvectiveMatrix_` object. + +```fortran +ElemSD => ConvectiveMatrix() +``` + +This will just allocate the pointer to the convective matrix object. This will not allocate any arrays in the field of convective matrix object. There is another way to do this where we can descibe the sizes of various array. + +```fortran +ElemSD => ConvectiveMatrix( row = row, col = col, NIP = NIP) +``` + +We can also use the `initiate` method which is inherited from the `ElemShapeData_` object. This will allocate the shapedata object at given number of integration points. The sentence is given below. + +```fortran +CALL ElemSD % initiate( NIP = NIP ) +``` + +## Theory + +Consider the following terms in PDE. + +_scalar unknown_ + +$$\frac{\partial u}{\partial t} + c_k \frac{\partial u}{\partial x_k} + \cdots$$ + +_vector unknown_ + +$$\frac{\partial u_i}{\partial t} + c_k \frac{\partial u_i}{\partial x_k} + \cdots$$ + +In this case we want to compute the following finite element matrices + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ + +> These tasks are performed using the following methods; `getConvectiveMatrix_1()`, `getConvectiveMatrix_2()`, `getConvectiveMatrix_3()`, `getConvectiveMatrix_4()`, `getConvectiveMatrix_5()`, `getConvectiveMatrix_6()`. + +Now consider the following terms in PDE. + +_scalar unknown_ + +$$\frac{\partial u}{\partial t}+\frac{\partial f(u)}{\partial x} + \frac{\partial g(u)}{\partial y} + \frac{\partial h(u)}{\partial z} + \cdots$$ + +_vector unknown_ + +$$\frac{\partial \mathbf{U}}{\partial t} + \frac{\partial \mathbf{f(U)} }{\partial x} + \frac{\partial \mathbf{g(u)}}{\partial y} + \frac{\partial \mathbf{h(u)}}{\partial z} + \cdots$$ + +Now we want to compute the following matrices. + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial x} d{\Omega} \quad f_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad f_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial y} d{\Omega} \quad g_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad g_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial z} d{\Omega} \quad h_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad h_{iJ}$$ + +> These tasks are performed by the following methods; `getConvectiveMatrix_7()`, `getConvectiveMatrix_8()` + +Now consider the following terms in a PDE. + +$$\frac{\partial \mathbf{U}}{\partial t} + [\mathbf{A_1}] \frac{\partial \mathbf{U} }{\partial x} + [\mathbf{A_2}] \frac{\partial \mathbf{U}}{\partial y} + [\mathbf{A_3}] \frac{\partial \mathbf{U}}{\partial z} + \cdots$$ + +where, $\mathbf{U} \in R^m$, and $[\mathbf{A_i}] \in R^{(m\times m)}$. + +For this we may need to compute the following matrices. + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_1}]_{ij} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ji} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_2}]_{ij} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ji} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_3}]_{ij} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ji} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad U_{jJ}$$ + +> This task is performed using the following the methods; `getConvectiveMatrix_9()`, `getConvectiveMatrix_10()` + +Now consider the following terms in the pde. + +$$[\mathbf{B}] \frac{\partial \mathbf{U}}{\partial t} + [\mathbf{A_1}] \frac{\partial \mathbf{U} }{\partial x} + [\mathbf{A_2}] \frac{\partial \mathbf{U}}{\partial y} + [\mathbf{A_3}] \frac{\partial \mathbf{U}}{\partial z} + \cdots$$ + + +We may want to compute following matrices + + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_1}]_{kj} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ki} \frac{\partial N^I}{\partial x} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_2}]_{kj} [\mathbf{B}]_{kj} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ki} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_3}]_{kj} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ki} \frac{\partial N^I}{\partial z} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ + +> This task is performed using the following methods; `getConvectiveMatrix_11()`, `getConvectiveMatrix_12()` + + +## Methods + +### getConvectiveMatrix_1() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_1( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- `C(:,:)` is a two dimensional array. It represents the spatial nodal values of _convective velocity_. The shape of `C` is `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial nodal number. In this case, _convective velocity_ varies in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0 ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) +CALL Check_Error( "Main-Program", " CALL ElemSD % getConvectiveMatrix_1()") + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_1( C = DummyMat2, Term1 = 0, Term2 = 1 )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + -0.6666667 0.1666667 0.3333333 0.1666667 + -0.5000000 0.000000 0.5000000 0.000000 + -0.3333333 -0.1666667 0.6666667 -0.1666667 + -0.5000000 0.000000 0.5000000 0.000000 +``` + +```fortran +CALL ElemSD % getConvectiveMatrix_1( C = DummyMat2, Term1 = 1, & +Term2 = 0 ) +CALL Check_Error( "Main-Program", " CALL ElemSD % getConvectiveMatrix_1()") + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, & +Term2 = 0 )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0 ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.6666667 -0.5000000 -0.3333333 -0.5000000 + 0.1666667 0.000000 -0.1666667 0.000000 + 0.3333333 0.5000000 0.6666667 0.5000000 + 0.1666667 0.000000 -0.1666667 0.000000 +``` + +> These matrices are transpose of each other, therefore we will consider the first one only. + +### getConvectiveMatrix_2() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_2( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- `C(:)` is a vector. It represents the spatial coordinates of _convective velocity_. The shape of `C` is `(NSD)`. The first index of `C` denotes the spatial coordinates. In this case, _convective velocity_ remains constant in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1 ) +CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 1, Term2 = 0 ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, & +Term2 = 1 ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_2( C = DummyVec, Term1 = 0, Term2 = 1 )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1 ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.6666667 0.1666667 0.3333333 0.1666667 + -0.5000000 0.000000 0.5000000 0.000000 + -0.3333333 -0.1666667 0.6666667 -0.1666667 + -0.5000000 0.000000 0.5000000 0.000000 +``` + +### getConvectiveMatrix_3() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_3( Obj, C, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy +``` + +DESCRIPTION + +- `C(:)` is a vector. It represents the spatial coordinates of _convective velocity_. The shape of `C` is `(NSD)`. The first index of `C` denotes the spatial coordinates. In this case, _convective velocity_ remains constant in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `nCopy` is an integer; which copies the matrix to ncopy diagonal. + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0, nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.6666667 0.1666667 0.3333333 0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.3333333 -0.1666667 0.6666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.6666667 0.1666667 0.3333333 0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 -0.1666667 0.6666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 +``` + +### getConvectiveMatrix_4() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_4( Obj, C, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy +``` + +DESCRIPTION + +- `C(:,:)` is a two dimensional array. It represents the spatial nodal values of _convective velocity_. The shape of `C` is `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial nodal number. In this case, _convective velocity_ varies in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `nCopy` is an integer; which copies the matrix to ncopy diagonal. + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 ) +CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 1, Term2 = 0, nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_4( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 )" +CALL ElemSD % DisplayMatrix() +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_4( C = DummyVec, Term1 = 0, Term2 = 1, nCopy = 2 ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.6666667 0.1666667 0.3333333 0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.3333333 -0.1666667 0.6666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.6666667 0.1666667 0.3333333 0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 -0.1666667 0.6666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 +``` + +### getConvectiveMatrix_5() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_5( Obj, C, Term1, Term2, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +- `C(:,:)` is a two dimensional array. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, SpaceNodalValues, Space Nodal Values]` then `C` denotes the spatial nodal values. In this case, its shape should be `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-node number. + - If `CType` is in the set `[Integration IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of convective velocity at the spatial integration points. In this case its shape should be `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-integration points. +- In this case, _convective velocity_ varies in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad' ) +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0, Ctype = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIP ) ) +DummyMat2 = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad' )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad' ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.6666667 0.1666667 0.3333333 0.1666667 + -0.5000000 0.000000 0.5000000 0.000000 + -0.3333333 -0.1666667 0.6666667 -0.1666667 + -0.5000000 0.000000 0.5000000 0.000000 +``` + +### getConvectiveMatrix_6() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_5( Obj, C, Term1, Term2, CType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +- `C(:,:)` is a two dimensional array. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, SpaceNodalValues, Space Nodal Values]` then `C` denotes the spatial nodal values. In this case, its shape should be `(NSD, NNS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-node number. + - If `CType` is in the set `[Integration IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of convective velocity at the spatial integration points. In this case its shape should be `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinates. The second index denotes the spatial-integration points. +- In this case, _convective velocity_ varies in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `nCopy` is an integer; which copies the matrix to ncopy diagonal. + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad', nCopy = 2 ) +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 1, Term2 = 0, Ctype = 'Quad', nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} N^I c_k \frac{\partial N^J}{\partial x_k} d{\Omega} \quad u_{iJ}$$ + +$${}^{2}M(I,J) = \partial u_{iI} \int_{\Omega} c_k \frac{\partial N^I}{\partial x_k} N^J d{\Omega} \quad u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIP ) ) +DummyMat2 = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad', nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, & +Term1 = 0, Term2 = 1, CType = 'Quad', nCopy = 2 )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_5( C = DummyMat2, Term1 = 0, Term2 = 1, CType = 'Quad', nCopy = 2 ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.6666667 0.1666667 0.3333333 0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.3333333 -0.1666667 0.6666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.5000000 0.000000 0.5000000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.6666667 0.1666667 0.3333333 0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 -0.1666667 0.6666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.5000000 0.000000 0.5000000 0.000000 +``` + +### getConvectiveMatrix_7() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_7( Obj, Term1, Term2, XType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType +``` + +DESCRIPTION + +- In this case, _convective velocity_ varies in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `XType` is string type, it denotes the type of spatial gradient. +- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. +- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. +- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. + + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx') +CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx') +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial x} d{\Omega} \quad f_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad f_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial y} d{\Omega} \quad g_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad g_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial z} d{\Omega} \quad h_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad h_{iJ}$$ + +TESTING + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx' ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_7( Term1 = 0, Term2 = 1, XType = 'dx' )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_7( Term1 = 0, Term2 = 1, XType = 'dx' ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.3333333 0.3333333 0.1666667 -0.1666667 + -0.3333333 0.3333333 0.1666667 -0.1666667 + -0.1666667 0.1666667 0.3333333 -0.3333333 + -0.1666667 0.1666667 0.3333333 -0.3333333 +``` + +### getConvectiveMatrix_8() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_8( Obj, Term1, Term2, XType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: XType +``` + +DESCRIPTION + +- In this case, _convective velocity_ varies in the space. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `XType` is string type, it denotes the type of spatial gradient. +- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. +- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. +- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. +- `nCopy` is the number of copies to be placed on the diagonal. + + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx', nCopy = 2) +CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx', nCopy = 2) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial x} d{\Omega} \quad f_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad f_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial y} d{\Omega} \quad g_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad g_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I \frac{\partial N^J}{\partial z} d{\Omega} \quad h_{iJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad h_{iJ}$$ + +TESTING + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_8( Term1 = 0, Term2 = 1, XType = 'dx', nCopy = 2 )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_8( Term1 = 0, Term2 = 1, XType = 'dx', nCopy = 2 ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 +``` + +### getConvectiveMatrix_9() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_9( Obj, A, Term1, Term2, XType, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:,:)` is a three dimensional array. The shape of `A` is `(M,M,NIPS)`. This array is defined at spatial-integration points. This array is responsible for coupling between different unknowns. In this method, `A` varies in the spatial domain. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `XType` is string type, it denotes the type of spatial gradient. +- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. +- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. +- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. +- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. + + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat3) +CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat3) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( 2,2, NIP ) ) +DummyMat3 = 0.0_DFP +DummyMat3( 1, 1, : ) = 1.0_DFP; DummyMat3( 2, 2, : ) = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, MultiVar = .TRUE. ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, & +XType = 'dx', A = DummyMat3, MultiVar = .TRUE. )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, & +XType = 'dx', A = DummyMat3, MultiVar = .TRUE. ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 +``` + +### getConvectiveMatrix_10() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_10( Obj, A, Term1, Term2, XType, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:)` is a two dimensional array. The shape of `A` is `(M,M)`. This array is responsible for coupling between different unknowns. The array is constant in the spatial domain. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `XType` is string type, it denotes the type of spatial gradient. +- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. +- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. +- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. +- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. + + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat2) +CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, Xtype = 'dx', MultiVar = .TRUE., A = DummyMat2) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_1}]_{ij} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ji} \frac{\partial N^I}{\partial x} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_2}]_{ij} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ji} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} N^I [\mathbf{A_3}]_{ij} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ji} \frac{\partial N^I}{\partial z} N^J d{\Omega} \quad U_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( 2,2 ) ) +DummyMat2 = 0.0_DFP +DummyMat2( 1, 1 ) = 1.0_DFP; DummyMat3( 2, 2 ) = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, MultiVar = .TRUE. ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_10( Term1 = 0, Term2 = 1, & +XType = 'dx', A = DummyMat2, MultiVar = .TRUE. )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat2, MultiVar = .TRUE. ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 +``` + +### getConvectiveMatrix_11() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_11( Obj, A, A0, Term1, Term2, XType, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ) :: A0, A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:,:)` and `A0(:,:,:)` are three dimensional array. The shape of `A` and `A0` is `(M,M,NIPS)`. This array is defined at spatial-integration points. This array is responsible for coupling between different unknowns. In this method, `A` and `A0` vary in the spatial domain. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `XType` is string type, it denotes the type of spatial gradient. +- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. +- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. +- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. +- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. + + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) +CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_1}]_{kj} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ki} \frac{\partial N^I}{\partial x} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_2}]_{kj} [\mathbf{B}]_{kj} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ki} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_3}]_{kj} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ki} \frac{\partial N^I}{\partial z} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( 2,2, NIP ) ) +DummyMat3 = 0.0_DFP +DummyMat3( 1, 1, : ) = 1.0_DFP; DummyMat3( 2, 2, : ) = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', & +A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, & +XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat3, A0 = DummyMat3, MultiVar = .TRUE. ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 +``` + +### getConvectiveMatrix_12() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_11( Obj, A, A0, Term1, Term2, XType, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( ConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ) :: A0, A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:)` and `A0(:,:)` are two dimensional array. The shape of `A` and `A0` is `(M,M)`. This array is responsible for coupling between different unknowns. In this method, `A` and `A0` do not vary in the spatial domain. +- `Term1` and `Term2` can have integer values, either 0 or 1. They denote the spatial derivative. If it is 1 then it means the first derivative and if it is 0 then it means no derivative. +- `XType` is string type, it denotes the type of spatial gradient. +- If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means that the spatial gradient is with respect to the `x` coordinate. +- If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means that the spatial gradient is with respect to the `y` coordinate. +- If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means that the spatial gradient is with respect to the `z` coordinate. +- `MultiVar` is a logical value which has no effect on the functionality of the method; this just for letting compiler know that this method has different interface. + + +CODE SNIPPET + +```fortran +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) +CALL ElemSD % getConvectiveMatrix( Term1 = 1, Term2 = 0, XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) +``` + +SYMBOLIC CALCULATION + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_1}]_{kj} \frac{\partial N^J}{\partial x} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_1}]_{ki} \frac{\partial N^I}{\partial x} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_2}]_{kj} [\mathbf{B}]_{kj} \frac{\partial N^J}{\partial y} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_2}]_{ki} \frac{\partial N^I}{\partial y} N^J d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{B}]_{ki} N^I [\mathbf{A_3}]_{kj} \frac{\partial N^J}{\partial z} d{\Omega} \quad U_{jJ}$$ + +$${}^{2}M(I,J) = \delta U_{iI} \int_{\Omega} [\mathbf{A_3}]_{ki} \frac{\partial N^I}{\partial z} [\mathbf{B}]_{kj} N^J d{\Omega} \quad U_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( 2,2 ) ) +DummyMat2 = 0.0_DFP +DummyMat2( 1, 1 ) = 1.0_DFP; DummyMat2( 2, 2 ) = 1.0_DFP +CALL ElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = 'dx', & +A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) + +CALL BlankLines( ) +WRITE( *, "(A)" ) "CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, & +XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. )" +CALL ElemSD % DisplayMatrix( ) +``` + +**NIP = 4** + +```fortran +CALL ElemSD % getConvectiveMatrix_11( Term1 = 0, Term2 = 1, XType = 'dx', A = DummyMat2, A0 = DummyMat2, MultiVar = .TRUE. ) + +MATRIX STORED IN ELEMENT SHAPE DATA :: + +NIPS :: 4 + +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.3333333 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.3333333 -0.3333333 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.3333333 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.3333333 -0.3333333 +``` \ No newline at end of file diff --git a/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part new file mode 100644 index 000000000..b3652b763 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/ConvectiveMatrix-old/MethodNames.part @@ -0,0 +1,12 @@ +getConvectiveMatrix_1, & +getConvectiveMatrix_2, & +getConvectiveMatrix_3, & +getConvectiveMatrix_4, & +getConvectiveMatrix_5, & +getConvectiveMatrix_6, & +getConvectiveMatrix_7, & +getConvectiveMatrix_8, & +getConvectiveMatrix_9, & +getConvectiveMatrix_10, & +getConvectiveMatrix_11, & +getConvectiveMatrix_12 \ No newline at end of file diff --git a/src/submodules/ConvectiveMatrix/src/CM_1.inc b/src/submodules/ConvectiveMatrix/src/CM_1.inc new file mode 100644 index 000000000..b72de1350 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_1.inc @@ -0,0 +1,59 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_1(ans, test, trial, c, term1, term2, opt) + !! Intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + !! Vector variable denoting the convective variable + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z, del_x_all + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips + REAL(DFP), ALLOCATABLE :: p(:, :) + REAL(DFP), ALLOCATABLE :: realVal(:) + !! + !! main + !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + !! projection on trial + !! + CALL GetProjectionOfdNdXt(obj=trial, cdNdXt=p, val=c) + !! + DO ips = 1, SIZE(trial%N, 2) + ans = ans + outerprod(a=test%N(:, ips), & + & b=p(:, ips)) * realval(ips) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! cleanup + DEALLOCATE (p, realval) +END SUBROUTINE CM_1 diff --git a/src/submodules/ConvectiveMatrix/src/CM_10.inc b/src/submodules/ConvectiveMatrix/src/CM_10.inc new file mode 100644 index 000000000..8d647f718 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_10.inc @@ -0,0 +1,76 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_10(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + ! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + ! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + ! del_x_all + INTEGER(I4B), INTENT(IN) :: term2 + ! del_none + INTEGER(I4B), INTENT(IN) :: opt + ! + ! Define internal variables + ! + INTEGER(I4B) :: ips, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + ! + ! main + ! + realval = trial%js * trial%ws * trial%thickness + ! + IF (opt .EQ. 1) THEN + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & trial%refelem%nsd, 1) + ! + DO ips = 1, SIZE(realval) + DO ii = 1, SIZE(m4, 3) + m4(:, :, ii, 1) = m4(:, :, ii, 1) + outerprod( & + & a=test%dNdXt(:, ii, ips), & + & b=trial%N(:, ips)) * realval(ips) + END DO + END DO + ELSE + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & 1, trial%refelem%nsd) + ! + DO ips = 1, SIZE(realval) + DO ii = 1, SIZE(m4, 4) + m4(:, :, 1, ii) = m4(:, :, 1, ii) + outerprod( & + & a=test%dNdXt(:, ii, ips), & + & b=trial%N(:, ips)) * realval(ips) + END DO + END DO + END IF + ! + CALL Convert(from=m4, to=ans) + ! + DEALLOCATE (realval, m4) + ! +END SUBROUTINE CM_10 diff --git a/src/submodules/ConvectiveMatrix/src/CM_2.inc b/src/submodules/ConvectiveMatrix/src/CM_2.inc new file mode 100644 index 000000000..345c2a243 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_2.inc @@ -0,0 +1,42 @@ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_2(ans, test, trial, c, term1, term2, opt) + !! Intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + !! Vector variable denoting the convective variable + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z, del_x_all + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips + REAL(DFP), ALLOCATABLE :: p(:, :), realVal(:) + !! + !! main + !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + !! projection on test + !! + CALL GetProjectionOfdNdXt(obj=test, cdNdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + ans = ans + outerprod(a=p(:, ips), & + & b=trial%N(:, ips)) * realval(ips) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! cleanup + DEALLOCATE (realval, p) +END SUBROUTINE CM_2 diff --git a/src/submodules/ConvectiveMatrix/src/CM_3.inc b/src/submodules/ConvectiveMatrix/src/CM_3.inc new file mode 100644 index 000000000..4095c3ac6 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_3.inc @@ -0,0 +1,41 @@ + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_3(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: c + !! A scalar finite element variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + CALL GetInterpolation(obj=trial, val=c, interpol=realval) + !! + realval = trial%js * trial%ws * trial%thickness * realval + !! + DO ips = 1, SIZE(realval) + ans = ans + outerprod(a=test%N(:, ips), & + & b=trial%dNdXt(:, term2, ips)) * realval(ips) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! cleanup + DEALLOCATE (realval) +END SUBROUTINE CM_3 diff --git a/src/submodules/ConvectiveMatrix/src/CM_4.inc b/src/submodules/ConvectiveMatrix/src/CM_4.inc new file mode 100644 index 000000000..91c1be600 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_4.inc @@ -0,0 +1,42 @@ + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_4(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + TYPE(FEVariable_), INTENT(IN) :: c + !! A scalar finite element variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! Define internal variables + !! + INTEGER(I4B) :: ips + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + CALL GetInterpolation(obj=trial, val=c, interpol=realval) + !! + realval = trial%js * trial%ws * trial%thickness * realval + !! + !! derivative in test + !! + DO ips = 1, SIZE(realval) + ans = ans + outerprod(a=test%dNdXt(:, term1, ips), & + & b=trial%N(:, ips)) * realval(ips) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! cleanup + DEALLOCATE (realval) +END SUBROUTINE CM_4 diff --git a/src/submodules/ConvectiveMatrix/src/CM_5.inc b/src/submodules/ConvectiveMatrix/src/CM_5.inc new file mode 100644 index 000000000..a4cfc20a8 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_5.inc @@ -0,0 +1,77 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all + TYPE(FEVariable_), INTENT(IN) :: c + !! A scalar finite element variable + INTEGER( I4B ), INTENT( IN ) :: opt + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, val=c, interpol=realval) + !! + realval = trial%js * trial%ws * trial%thickness * realval + !! + if( opt .eq. 1 ) then + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & trial%refelem%nsd, 1) + !! + !! test: rowConcat + !! + DO ips = 1, SIZE(realval) + m4(:,:,:,1) = m4(:,:,:,1) + outerprod(a=test%N(:, ips), & + & b=trial%dNdXt(:, :, ips)) * realval(ips) + END DO + else + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & 1, trial%refelem%nsd) + !! + !! test: rowConcat + !! + DO ips = 1, SIZE(realval) + m4(:,:,1, :) = m4(:,:,1, :) + outerprod(a=test%N(:, ips), & + & b=trial%dNdXt(:, :, ips)) * realval(ips) + END DO + end if + !! + CALL Convert(from=m4, to=ans) + !! cleanup + DEALLOCATE (realval, m4) +END SUBROUTINE CM_5 diff --git a/src/submodules/ConvectiveMatrix/src/CM_6.inc b/src/submodules/ConvectiveMatrix/src/CM_6.inc new file mode 100644 index 000000000..06cfb876f --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_6.inc @@ -0,0 +1,79 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + TYPE(FEVariable_), INTENT(IN) :: c + !! A scalar finite element variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, val=c, interpol=realval) + !! + realval = trial%js * trial%ws * trial%thickness * realval + !! + if( opt .eq. 1 ) then + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & trial%refelem%nsd, 1) + !! + DO ips = 1, SIZE(realval) + do ii = 1, size(m4, 3) + m4(:,:,ii, 1) = m4(:,:,ii, 1) + outerprod( & + & a=test%dNdXt(:, ii, ips), & + & b=trial%N(:, ips)) * realval(ips) + end do + END DO + else + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & 1, trial%refelem%nsd) + !! + DO ips = 1, SIZE(realval) + do ii = 1, size(m4, 4) + m4(:,:,1,ii) = m4(:,:,1,ii) + outerprod( & + & a=test%dNdXt(:, ii, ips), & + & b=trial%N(:, ips)) * realval(ips) + end do + END DO + end if + !! + CALL Convert(from=m4, to=ans) + !! + DEALLOCATE (realval, m4) +END SUBROUTINE CM_6 diff --git a/src/submodules/ConvectiveMatrix/src/CM_7.inc b/src/submodules/ConvectiveMatrix/src/CM_7.inc new file mode 100644 index 000000000..f914a0777 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_7.inc @@ -0,0 +1,56 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_7(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + DO ips = 1, SIZE(realval) + ans = ans + outerprod(a=test%N(:, ips), & + & b=trial%dNdXt(:, term2, ips)) * realval(ips) + END DO + !! + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies(ans, opt) + END IF + !! cleanup + DEALLOCATE (realval) +END SUBROUTINE CM_7 diff --git a/src/submodules/ConvectiveMatrix/src/CM_8.inc b/src/submodules/ConvectiveMatrix/src/CM_8.inc new file mode 100644 index 000000000..c175db8a3 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_8.inc @@ -0,0 +1,58 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_8(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + !! derivative in test + !! + DO ips = 1, SIZE(realval) + ans = ans + outerprod(a=test%dNdXt(:, term1, ips), & + & b=trial%N(:, ips)) * realval(ips) + END DO + !! + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies(ans, opt) + END IF + !! cleanup + DEALLOCATE (realval) +END SUBROUTINE CM_8 diff --git a/src/submodules/ConvectiveMatrix/src/CM_9.inc b/src/submodules/ConvectiveMatrix/src/CM_9.inc new file mode 100644 index 000000000..d7cb134f9 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/CM_9.inc @@ -0,0 +1,73 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM_9(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test functions + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial functions + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all + INTEGER( I4B ), INTENT( IN ) :: opt + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + !! + !! main + !! + realval = trial%js * trial%ws * trial%thickness + !! + IF( opt .EQ. 1 ) THEN + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & trial%refelem%nsd, 1) + !! + DO ips = 1, SIZE(realval) + DO ii = 1, SIZE(m4, 3) + m4(:,:,ii,1) = m4(:,:,ii,1) + outerprod(test%N(:, ips), & + & trial%dNdXt(:, ii, ips)) * realval(ips) + END DO + END DO + ELSE + CALL Reallocate(m4, & + & SIZE(test%N, 1), & + & SIZE(trial%N, 1), & + & 1, trial%refelem%nsd) + !! + DO ips = 1, SIZE(realval) + DO ii = 1, SIZE( m4, 4) + m4(:,:,1, ii) = m4(:,:,1, ii) + outerprod(a=test%N(:, ips), & + & b=trial%dNdXt(:, ii, ips)) * realval(ips) + END DO + END DO + END IF + !! + CALL Convert(from=m4, to=ans) + !! + DEALLOCATE (realval, m4) +END SUBROUTINE CM_9 diff --git a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 new file mode 100644 index 000000000..838cc5b12 --- /dev/null +++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 @@ -0,0 +1,137 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ConvectiveMatrix_Method) Methods +USE BaseMethod +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" + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ConvectiveMatrix_1 +IF( term1 .EQ. DEL_NONE ) THEN +!! +!! +!! +!! + IF( term2 .EQ. DEL_X_ALL ) THEN + !! + !! del_none + !! del_x_all + !! + CALL CM_9(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, opt=opt) + !! + ELSE + !! + !! del_none + !! del_x, del_y, del_z + !! + CALL CM_7(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, opt=opt) + !! + END IF +!! +!! +!! +!! +ELSE + !! + !! term2 .eq. del_none + !! + IF( term1 .EQ. del_x_all ) THEN + !! + !! del_x_all + !! del_none + !! + CALL CM_10(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, opt=opt) + !! + ELSE + !! + !! del_x, del_y, del_z + !! del_none + !! + CALL CM_8(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, opt=opt) + !! + END IF +END IF +!! +END PROCEDURE ConvectiveMatrix_1 + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ConvectiveMatrix_2 + !! + !! scalar + !! + IF( term1 .EQ. del_none ) THEN + IF( term2 .EQ. del_x_all ) THEN + CALL CM_5(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) + ELSE + CALL CM_3(ans=ans, test=test, trial=trial, c=c, & + & term1=term2, term2=term2, opt=opt) + END IF + ELSE + IF( term1 .EQ. del_x_all ) THEN + CALL CM_6(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) + ELSE + CALL CM_4(ans=ans, test=test, trial=trial, c=c, & + & term1=term2, term2=term2, opt=opt) + END IF + END IF + !! +END PROCEDURE ConvectiveMatrix_2 + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ConvectiveMatrix_3 + !! + IF( term1 .EQ. del_none ) THEN + CALL CM_1(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) + ELSE + CALL CM_2(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) + END IF + !! +END PROCEDURE ConvectiveMatrix_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/DOF/CMakeLists.txt b/src/submodules/DOF/CMakeLists.txt new file mode 100644 index 000000000..094198779 --- /dev/null +++ b/src/submodules/DOF/CMakeLists.txt @@ -0,0 +1,27 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/DOF_ConstructorMethods@Methods.F90 + ${src_path}/DOF_IOMethods@Methods.F90 + ${src_path}/DOF_SetMethods@Methods.F90 + ${src_path}/DOF_AddMethods@Methods.F90 + ${src_path}/DOF_GetMethods@Methods.F90 + ${src_path}/DOF_GetValueMethods@Methods.F90) diff --git a/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 b/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 new file mode 100644 index 000000000..554acf4bc --- /dev/null +++ b/src/submodules/DOF/src/DOF_AddMethods@Methods.F90 @@ -0,0 +1,433 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(DOF_AddMethods) Methods +USE DOF_GetMethods, ONLY: GetNodeLoc, & + OPERATOR(.tdof.), & + GetNodeLoc_, & + GetIndex_, & + GetIDOF + +USE GlobalData, ONLY: NodesToDOF, DOFToNodes, NODES_FMT, DOF_FMT + +USE SafeSizeUtility, ONLY: SafeSize + +USE ReallocateUtility, ONLY: Reallocate + +IMPLICIT NONE + +INTEGER(I4B), PARAMETER :: PARAM_EXPAND_FACTOR_TEMP_INTVEC = 2 +INTEGER(I4B), PARAMETER :: PARAM_TEMP_INTVEC_SIZE = 1024 +INTEGER(I4B) :: tempIntVec(PARAM_TEMP_INTVEC_SIZE) +!$OMP THREADPRIVATE(tempIntVec) + +INTEGER(I4B), ALLOCATABLE :: tempAllocIntVec(:) +!$OMP THREADPRIVATE(tempAllocIntVec) + +CONTAINS + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add1 +INTEGER(I4B) :: tdof, idof, i, n, m + +tdof = .tdof.obj +n = SIZE(nodenum) +m = SIZE(VALUE) + +SELECT CASE (obj%StorageFMT) + +CASE (DOF_FMT) + + IF (m .EQ. n) THEN + + DO CONCURRENT(idof=1:tdof, i=1:n) + vec(obj%valmap(idof) - 1 + nodenum(i)) = & + vec(obj%valmap(idof) - 1 + nodenum(i)) + scale * VALUE(i) + END DO + + RETURN + END IF + + ! vec( nodenum ) += scale * value( 1 ) + IF (m .EQ. 1) THEN + + DO CONCURRENT(idof=1:tdof, i=1:n) + vec(obj%valmap(idof) - 1 + nodenum(i)) = & + vec(obj%valmap(idof) - 1 + nodenum(i)) + scale * VALUE(1) + END DO + + RETURN + END IF + + ! Vec_obj_i( nodenum ) += scale * val_obj_i( : ) + ! IF (m .EQ. tdof * n) THEN + IF (conversion(1) .EQ. NodesToDOF) THEN + + DO CONCURRENT(idof=1:tdof, i=1:n) + vec(obj%valmap(idof) - 1 + nodenum(i)) = & + vec(obj%valmap(idof) - 1 + nodenum(i)) & + + scale * VALUE((i - 1) * tdof + idof) + END DO + + RETURN + + END IF + + ! Vec_obj_i( nodenum ) += scale * val_obj_i( : ) + ! IF (m .EQ. tdof * n) THEN + DO CONCURRENT(idof=1:tdof, i=1:n) + + vec(obj%valmap(idof) - 1 + nodenum(i)) = & + vec(obj%valmap(idof) - 1 + nodenum(i)) & + + scale * VALUE((idof - 1) * n + i) + + END DO + + RETURN + +CASE (NODES_FMT) + + IF (m .EQ. n) THEN + + DO CONCURRENT(idof=1:tdof, i=1:n) + + vec((nodenum(i) - 1) * tdof + idof) & + = vec((nodenum(i) - 1) * tdof + idof) & + + scale * VALUE(i) + + END DO + + RETURN + + END IF + + IF (m .EQ. 1) THEN + + DO idof = 1, tdof + vec((nodenum - 1) * tdof + idof) & + & = vec((nodenum - 1) * tdof + idof) & + & + scale * VALUE(1) + END DO + + RETURN + END IF + + ! ELSE IF (m .EQ. tdof * n) THEN + + IF (conversion(1) .EQ. DOFToNodes) THEN + + DO CONCURRENT(idof=1:tdof, i=1:n) + + vec((nodenum(i) - 1) * tdof + idof) & + = vec((nodenum(i) - 1) * tdof + idof) & + + scale * VALUE((idof - 1) * n + i) + + END DO + + RETURN + + END IF + + DO CONCURRENT(idof=1:tdof, i=1:n) + vec((nodenum(i) - 1) * tdof + idof) & + = vec((nodenum(i) - 1) * tdof + idof) & + + scale * VALUE((i - 1) * tdof + idof) + END DO + RETURN + + ! END IF + +END SELECT + +END PROCEDURE obj_Add1 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add2 +INTEGER(I4B) :: tsize +tsize = (.tdof.obj) * SIZE(nodenum) + +IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN + + IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN + CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) + END IF + + CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, tsize=tsize) + CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, indx=tempAllocIntVec) + + RETURN +END IF + +CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempIntVec, tsize=tsize) +CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempIntVec) + +END PROCEDURE obj_Add2 + +!---------------------------------------------------------------------------- +! obj_add_help_1 +!---------------------------------------------------------------------------- + +PURE SUBROUTINE obj_add_help_1(vec, scale, VALUE, tsize, indx) + REAL(DFP), INTENT(INOUT) :: vec(:) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: VALUE + INTEGER(I4B), INTENT(IN) :: tsize + INTEGER(I4B), INTENT(IN) :: indx(:) + + INTEGER(I4B) :: ii + + DO CONCURRENT(ii=1:tsize) + vec(indx(ii)) = vec(indx(ii)) + scale * VALUE + END DO + +END SUBROUTINE obj_add_help_1 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add3 +INTEGER(I4B) :: tsize + +tsize = SIZE(nodenum) + +IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN + + IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN + CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) + END IF + + CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, & + tsize=tsize, idof=idof) + + CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempAllocIntVec) + + RETURN +END IF + +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, & + tsize=tsize, idof=idof) +CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempIntVec) + +END PROCEDURE obj_Add3 + +!---------------------------------------------------------------------------- +! obj_add_help_2 +!---------------------------------------------------------------------------- + +PURE SUBROUTINE obj_add_help_2(vec, scale, VALUE, tsize, indx) + REAL(DFP), INTENT(INOUT) :: vec(:) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: VALUE(:) + INTEGER(I4B), INTENT(IN) :: tsize + INTEGER(I4B), INTENT(IN) :: indx(:) + + INTEGER(I4B) :: ii, n + + n = SIZE(VALUE) + + IF (n .EQ. 1) THEN + + DO CONCURRENT(ii=1:tsize) + vec(indx(ii)) = vec(indx(ii)) + scale * VALUE(1) + END DO + + RETURN + + END IF + + DO CONCURRENT(ii=1:tsize) + vec(indx(ii)) = vec(indx(ii)) + scale * VALUE(ii) + END DO + +END SUBROUTINE obj_add_help_2 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add4 +INTEGER(I4B) :: global_idof +global_idof = GetIDOF(obj=obj, ivar=ivar, idof=idof) +CALL obj_Add3(vec=vec, obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, & + idof=global_idof) +END PROCEDURE obj_Add4 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add5 +INTEGER(I4B) :: global_idof +global_idof = GetIDOF(obj=obj, ivar=ivar, spaceCompo=spaceCompo, & + timeCompo=timeCompo) +CALL obj_Add3(vec=vec, obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, & + idof=global_idof) +END PROCEDURE obj_Add5 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add6 +INTEGER(I4B) :: tsize + +tsize = SIZE(nodenum) + +IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN + + IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN + CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) + END IF + + CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, & + tsize=tsize, ivar=ivar, spacecompo=spacecompo, & + timecompo=timecompo) + + CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempAllocIntVec) + + RETURN +END IF + +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, & + tsize=tsize, ivar=ivar, spacecompo=spacecompo, & + timecompo=timecompo) +CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempIntVec) + +END PROCEDURE obj_Add6 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add7 +INTEGER(I4B) :: tsize + +tsize = SIZE(nodenum) + +IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN + + IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN + CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC) + END IF + + CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, & + tsize=tsize, ivar=ivar, spacecompo=spacecompo, & + timecompo=timecompo) + + CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempAllocIntVec) + + RETURN +END IF + +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, & + tsize=tsize, ivar=ivar, spacecompo=spacecompo, & + timecompo=timecompo) +CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempIntVec) + +END PROCEDURE obj_Add7 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add8 +INTEGER(I4B) :: tsize +CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempIntVec, tsize=tsize) +CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempIntVec) +END PROCEDURE obj_Add8 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add9 +INTEGER(I4B) :: indx +indx = GetNodeLoc(obj=obj, nodenum=nodenum, idof=idof) +vec(indx) = vec(indx) + scale * VALUE +END PROCEDURE obj_Add9 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add10 +INTEGER(I4B) :: indx +indx = GetNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, idof=idof) +vec(indx) = vec(indx) + scale * VALUE +END PROCEDURE obj_Add10 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add11 +INTEGER(I4B) :: indx +indx = GetNodeLoc( obj=obj, nodenum=nodenum, ivar=ivar, spacecompo=spacecompo, & + timecompo=timecompo) +vec(indx) = vec(indx) + scale * VALUE +END PROCEDURE obj_Add11 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add12 +INTEGER(I4B) :: tsize + +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, & + spacecompo=spacecompo, timecompo=timecompo, ans=tempIntVec, tsize=tsize) + +CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempIntVec) + +END PROCEDURE obj_Add12 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add13 +INTEGER(I4B) :: tsize + +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, & + spacecompo=spacecompo, timecompo=timecompo, ans=tempIntVec, tsize=tsize) + +CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, & + indx=tempIntVec) + +END PROCEDURE obj_Add13 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 b/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 new file mode 100644 index 000000000..0209dd6ef --- /dev/null +++ b/src/submodules/DOF/src/DOF_ConstructorMethods@Methods.F90 @@ -0,0 +1,136 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(DOF_ConstructorMethods) Methods +USE ReallocateUtility, ONLY: Reallocate +USE DOF_GetMethods, ONLY: OPERATOR(.tNodes.) + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate1 +INTEGER(I4B) :: n, i, k, j +!> main +obj%StorageFMT = StorageFMT; n = SIZE(Names) +CALL Reallocate(obj%Map, n + 1, 6) +ASSOCIATE (Map => obj%Map) + + !<- Names in ascii code + Map(1:n, 1) = ICHAR(Names(1:n)) + Map(1 + n, 1) = 0 + + !<- Space components; -1 if scalar component like pressure + Map(1:n, 2) = spacecompo + Map(1 + n, 2) = 0 + + ! <- Time component; 1 if time invariant + Map(1:n, 3) = timecompo + Map(1 + n, 3) = 0 + + !<- tDOF for each physical name + DO i = 1, n + IF (spacecompo(i) .LT. 0) THEN + Map(i, 4) = timecompo(i) + ELSE + Map(i, 4) = timecompo(i) * spacecompo(i) + END IF + END DO + Map(n + 1, 4) = SUM(Map(1:n, 4)) + + !<- Here we set Indx + Map(1, 5) = 1 + DO i = 2, n + 1 + Map(i, 5) = Map(i - 1, 5) + Map(i - 1, 4) + END DO + + !<- tNodes + Map(1:n, 6) = tNodes + Map(n + 1, 6) = SUM(Map(1:n, 6) * Map(1:n, 4)) + + !<- ValMap( tDOF + 1, 2 ) + CALL Reallocate(obj%ValMap, Map(n + 1, 4) + 1) + obj%ValMap(1) = 1; k = 1 + DO i = 1, n + DO j = 1, Map(i, 4) + k = k + 1 + obj%ValMap(k) = obj%ValMap(k - 1) + Map(i, 6) + END DO + END DO +END ASSOCIATE +END PROCEDURE obj_initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate2 +CALL Reallocate(Val, .tNodes.obj) +END PROCEDURE obj_initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate3 +CALL Reallocate(Val1, .tNodes.obj, Val2, .tNodes.obj) +END PROCEDURE obj_initiate3 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate4 +obj1%StorageFMT = obj2%StorageFMT +IF (ALLOCATED(obj2%valmap)) obj1%valmap = obj2%valmap +IF (ALLOCATED(obj2%map)) obj1%map = obj2%map +END PROCEDURE obj_initiate4 + +!---------------------------------------------------------------------------- +! DOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor1 +CALL Initiate(obj=obj, Names=Names, tNodes=tNodes, & + & spacecompo=spacecompo, timecompo=timecompo, & + & StorageFMT=StorageFMT) +END PROCEDURE obj_Constructor1 + +!---------------------------------------------------------------------------- +! DOF_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor_1 +ALLOCATE (obj) +CALL Initiate(obj=obj, Names=Names, tNodes=tNodes, & + & spacecompo=spacecompo, timecompo=timecompo, & + & StorageFMT=StorageFMT) +END PROCEDURE obj_Constructor_1 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Deallocate +IF (ALLOCATED(obj%Map)) DEALLOCATE (obj%Map) +IF (ALLOCATED(obj%ValMap)) DEALLOCATE (obj%ValMap) +END PROCEDURE obj_Deallocate + +END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 new file mode 100644 index 000000000..1c00e54ca --- /dev/null +++ b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 @@ -0,0 +1,827 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(DOF_GetMethods) Methods +USE ReallocateUtility, ONLY: Reallocate +USE ArangeUtility, ONLY: Arange +USE GlobalData, ONLY: NODES_FMT, DOF_FMT, FMT_DOF, FMT_NODES + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! DOFStartIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_DOFStartIndex +ans = obj%map(ivar, 5) +END PROCEDURE obj_DOFStartIndex + +!---------------------------------------------------------------------------- +! DOFEndIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_DOFEndIndex +ans = obj%map(ivar + 1, 5) - 1 +END PROCEDURE obj_DOFEndIndex + +!---------------------------------------------------------------------------- +! tNodes +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tNodes1 +ans = 0 +IF (ALLOCATED(obj%map)) ans = obj%map(SIZE(obj%map, 1), 6) +END PROCEDURE obj_tNodes1 + +!---------------------------------------------------------------------------- +! tNodes +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tNodes2 +ans = 0 +IF (ALLOCATED(obj%valmap)) ans = obj%valmap(idof + 1) - obj%valmap(idof) +END PROCEDURE obj_tNodes2 + +!---------------------------------------------------------------------------- +! tNodes +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tNodes3 +ans = obj.tNodes. (NameToIndex(obj, varName)) +END PROCEDURE obj_tNodes3 + +!---------------------------------------------------------------------------- +! tNodes +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tNodes4 +INTEGER(I4B) :: ii +ans = 0 +DO ii = 1, SIZE(idof) + ans = ans + (obj.tNodes.idof(ii)) +END DO +END PROCEDURE obj_tNodes4 + +!---------------------------------------------------------------------------- +! tDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tdof1 + +#ifdef DEBUG_VER + +ans = 0 +IF (ALLOCATED(obj%map)) ans = obj%map(SIZE(obj%map, 1), 4) + +#else + +ans = obj%map(SIZE(obj%map, 1), 4) + +#endif +END PROCEDURE obj_tdof1 + +!---------------------------------------------------------------------------- +! tDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tdof2 +INTEGER(I4B) :: i, k +ans = 0 +IF (ALLOCATED(obj%map)) THEN + k = ICHAR(Name) + DO i = 1, SIZE(obj%map, 1) - 1 + IF (obj%map(i, 1) .EQ. k) ans = obj%map(i, 4) + END DO +END IF +END PROCEDURE obj_tdof2 + +!---------------------------------------------------------------------------- +! tDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tdof3 +#ifdef DEBUG_VER +INTEGER(I4B) :: i +LOGICAL(LGT) :: isok +ans = 0 + +i = SIZE(obj%map, 1) - 1 +isok = ALLOCATED(obj%map) .AND. (ivar .LE. i) +IF (isok) ans = obj%map(ivar, 4) + +#else +ans = obj%map(ivar, 4) +#endif + +END PROCEDURE obj_tdof3 + +!---------------------------------------------------------------------------- +! tDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tdof4 +INTEGER(I4B) :: ii +ans = 0 +DO ii = 1, SIZE(ivar) + ans = ans + obj%map(ii, 4) +END DO +END PROCEDURE obj_tdof4 + +!---------------------------------------------------------------------------- +! tNames +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tNames +ans = 0 +IF (ALLOCATED(obj%map)) ans = SIZE(obj%map, 1) - 1 +END PROCEDURE obj_tNames + +!---------------------------------------------------------------------------- +! Names +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_names1 +INTEGER(I4B) :: ii, n + +n = SIZE(obj%map, 1) - 1 +ALLOCATE (ans(n)) + +DO ii = 1, n + ans(ii) = ACHAR(obj%map(ii, 1)) +END DO +END PROCEDURE obj_names1 + +!---------------------------------------------------------------------------- +! Names +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_names2 +ans = ACHAR(obj%map(ii, 1)) +END PROCEDURE obj_names2 + +!---------------------------------------------------------------------------- +! IndexOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE NameToIndex +INTEGER(I4B) :: n, i, ic +n = SIZE(obj%map, 1) - 1 +ic = ICHAR(Name) +ans = 0 +DO i = 1, n + IF (obj%map(i, 1) .EQ. ic) THEN + ans = i + EXIT + END IF +END DO +END PROCEDURE NameToIndex + +!---------------------------------------------------------------------------- +! tspacecomponents +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_tspacecomponents +INTEGER(I4B) :: n, i +n = SIZE(obj%map, 1) - 1 +ans = 0 +DO i = 1, n + IF (obj%map(i, 2) .GT. 0) ans = ans + 1 +END DO +END PROCEDURE obj_tspacecomponents + +!---------------------------------------------------------------------------- +! spacecomponents +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_spacecomponents1 +INTEGER(I4B) :: n, i +CALL Reallocate(ans, SIZE(obj%map, 1) - 1) +DO i = 1, SIZE(ans) + ans(i) = obj%map(i, 2) +END DO +END PROCEDURE obj_spacecomponents1 + +!---------------------------------------------------------------------------- +! spacecomponents +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_spacecomponents2 +ans = obj%map(ivar, 2) +END PROCEDURE obj_spacecomponents2 + +!---------------------------------------------------------------------------- +! ttimecomponents +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ttimecomponents +INTEGER(I4B) :: n, i +n = SIZE(obj%map, 1) - 1 +ans = 0 +DO i = 1, n + IF (obj%map(i, 3) .GT. 1) ans = ans + 1 +END DO +END PROCEDURE obj_ttimecomponents + +!---------------------------------------------------------------------------- +! timecomponents +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_timecomponents1 +INTEGER(I4B) :: n, i +CALL Reallocate(ans, SIZE(obj%map, 1) - 1) +DO i = 1, SIZE(ans) + ans(i) = obj%map(i, 3) +END DO +END PROCEDURE obj_timecomponents1 + +!---------------------------------------------------------------------------- +! timecomponents +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_timecomponents2 +ans = obj%map(ivar, 3) +END PROCEDURE obj_timecomponents2 + +!---------------------------------------------------------------------------- +! EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isEqual +ans = .TRUE. +IF (obj1%storageFMT .NE. obj2%storageFMT) ans = .FALSE. +IF (ANY(obj1%map(:, 2:) .NE. obj2%map(:, 2:))) ans = .FALSE. +IF (ANY(obj1%valmap .NE. obj2%valmap)) ans = .FALSE. +END PROCEDURE obj_isEqual + +!---------------------------------------------------------------------------- +! NE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isNE +ans = .NOT. (obj_isEqual(obj1, obj2)) +END PROCEDURE obj_isNE + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF1 +ans = spacecompo + (timecompo - 1) * tspacecompo +END PROCEDURE obj_GetIDOF1 + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF2 +ans = (obj.DOFStartIndex.ivar) & + + spacecompo - 1 & + + (timecompo - 1) * (obj.spacecomponents.ivar) +END PROCEDURE obj_GetIDOF2 + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF3 +ans = (obj.DOFStartIndex.ivar) & + + spacecompo - 1 & + + (timecompo - 1) * (obj.spacecomponents.ivar) +END PROCEDURE obj_GetIDOF3 + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF4 +ans = (obj.DOFStartIndex.ivar) & + + spacecompo - 1 & + + (timecompo - 1) * (obj.spacecomponents.ivar) +END PROCEDURE obj_GetIDOF4 + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF5 +ans = spacecompo + (timecompo - 1) * tspacecompo +END PROCEDURE obj_GetIDOF5 + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF6 +ans = spacecompo + (timecompo - 1) * tspacecompo +END PROCEDURE obj_GetIDOF6 + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF7 +ans = (obj.DOFStartIndex.ivar) + idof - 1 +END PROCEDURE obj_GetIDOF7 + +!---------------------------------------------------------------------------- +! GetIDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIDOF8 +ans = (obj.DOFStartIndex.ivar) + Arange(1, obj.tdof.ivar) - 1 +END PROCEDURE obj_GetIDOF8 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc1 +IF (obj%storageFMT .EQ. NODES_FMT) THEN + ans = (nodenum - 1) * (.tdof.obj) + idof +ELSE + ans = obj%valmap(idof) + nodenum - 1 +END IF +END PROCEDURE obj_GetNodeLoc1 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc2 +INTEGER(I4B) :: tsize +CALL obj_getnodeloc_2(obj, nodenum, idof, ans, tsize) +END PROCEDURE obj_GetNodeLoc2 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_2 +tsize = SIZE(nodenum) +IF (obj%storageFMT .EQ. NODES_FMT) THEN + ans(1:tsize) = (nodenum - 1) * (.tdof.obj) + idof +ELSE + ans(1:tsize) = obj%valmap(idof) - 1 + nodenum +END IF +END PROCEDURE obj_GetNodeLoc_2 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc3 +INTEGER(I4B) :: tsize +CALL obj_getnodeloc_3(obj, nodenum, idof, ans, tsize) +END PROCEDURE obj_GetNodeLoc3 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_3 +tsize = SIZE(idof) +IF (obj%storageFMT .EQ. NODES_FMT) THEN + ans(1:tsize) = (nodenum - 1) * (.tdof.obj) + idof +ELSE + ans(1:tsize) = obj%valmap(idof) - 1 + nodenum +END IF +END PROCEDURE obj_GetNodeLoc_3 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc4 +IF (obj%storageFMT .EQ. NODES_FMT) THEN + ans = [idof, .tnodes.obj, .tdof.obj] +ELSE + ans = [obj%valmap(idof), obj%valmap(idof + 1) - 1, 1] +END IF +END PROCEDURE obj_GetNodeLoc4 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc5 +IF (obj%storageFMT .EQ. DOF_FMT) THEN + ans = obj%valmap(obj%map(ivar, 5) - 1 + idof) + nodenum - 1 +ELSE + ans = (nodenum - 1) * (.tdof.obj) + (obj%map(ivar, 5) - 1 + idof) +END IF +END PROCEDURE obj_GetNodeLoc5 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc6 +INTEGER(I4B) :: tsize +CALL obj_GetNodeLoc_6(obj, nodenum, ivar, idof, ans, tsize) +END PROCEDURE obj_GetNodeLoc6 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_6 +INTEGER(I4B) :: a, b + +tsize = SIZE(nodenum) +a = obj%map(ivar, 5) - 1 + idof + +IF (obj%storageFMT .EQ. DOF_FMT) THEN + ans(1:tsize) = obj%valmap(a) + nodenum - 1 + RETURN +END IF + +b = .tdof.obj +ans(1:tsize) = (nodenum - 1) * b + a +END PROCEDURE obj_GetNodeLoc_6 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc7 +ans = GetNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, & + idof=GetIDOF(spacecompo=spacecompo, & + timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar)) +END PROCEDURE obj_GetNodeLoc7 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc8 +INTEGER(I4B) :: tsize +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & + idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar)) +END PROCEDURE obj_GetNodeLoc8 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_8 +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & + idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar)) +END PROCEDURE obj_GetNodeLoc_8 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc9 +INTEGER(I4B) :: tsize +CALL obj_GetNodeLoc_9(obj, nodenum, ivar, idof, ans, tsize) +END PROCEDURE obj_GetNodeLoc9 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_9 +INTEGER(I4B) :: ii, a, b + +tsize = SIZE(idof) +a = obj%map(ivar, 5) - 1 +b = nodenum - 1 + +IF (obj%storageFMT .EQ. DOF_FMT) THEN + + DO ii = 1, tsize + ans(ii) = obj%valmap(a + idof(ii)) + b + END DO + +ELSE + + b = b * (.tdof.obj) + b = b + a + + DO ii = 1, tsize + ans(ii) = b + idof(ii) + END DO + +END IF + +END PROCEDURE obj_GetNodeLoc_9 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc10 +INTEGER(I4B) :: tsize +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & + idof=GetIDOF(spacecompo=spacecompo, & + timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar)) +END PROCEDURE obj_GetNodeLoc10 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_10 +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & + idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar)) +END PROCEDURE obj_GetNodeLoc_10 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc11 +INTEGER(I4B) :: tsize +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & + idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar)) +END PROCEDURE obj_GetNodeLoc11 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_11 +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & + idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar)) +END PROCEDURE obj_GetNodeLoc_11 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc12 +INTEGER(I4B) :: tsize +CALL obj_GetNodeLoc_12(obj, nodenum, ivar, spacecompo, & + timecompo, ans, tsize) +END PROCEDURE obj_GetNodeLoc12 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_12 +INTEGER(I4B) :: idofs(SIZE(timecompo)), ii, tempsize, tnode + +tempsize = SIZE(timecompo) +tnode = SIZE(nodenum) +tsize = tempsize * tnode + +idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar) + +tsize = 1 +DO ii = 1, tnode + CALL GetNodeLoc_(obj=obj, nodenum=nodenum(ii), ivar=ivar, idof=idofs, & + ans=ans(tsize:), tsize=tempsize) + tsize = tsize + tempsize +END DO + +tsize = tsize - 1 + +END PROCEDURE obj_GetNodeLoc_12 + +!---------------------------------------------------------------------------- +! GetNodeLoc +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc13 +INTEGER(I4B) :: tsize +CALL obj_GetNodeLoc_13(obj, nodenum, ivar, spacecompo, & + timecompo, ans, tsize) +END PROCEDURE obj_GetNodeLoc13 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_13 +INTEGER(I4B) :: idofs(SIZE(spacecompo)), ii, tempsize, tnode + +tempsize = SIZE(spacecompo) +tnode = SIZE(nodenum) +tsize = tempsize * tnode + +idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=obj.spacecomponents.ivar) + +tsize = 1 +DO ii = 1, tnode + CALL GetNodeLoc_(obj=obj, nodenum=nodenum(ii), ivar=ivar, idof=idofs, & + ans=ans(tsize:), tsize=tempsize) + tsize = tsize + tempsize +END DO + +tsize = tsize - 1 + +END PROCEDURE obj_GetNodeLoc_13 + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex1 +INTEGER(I4B) :: tsize +tsize = .tdof.obj +ALLOCATE (ans(tsize)) +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, idof=Arange(1, tsize), & + ans=ans, tsize=tsize) +END PROCEDURE obj_GetIndex1 + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex_1 +tsize = .tdof.obj +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, idof=Arange(1, tsize), & + ans=ans, tsize=tsize) +END PROCEDURE obj_GetIndex_1 + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex2 +INTEGER(I4B) :: tsize +tsize = obj.tdof.ivar +ALLOCATE (ans(tsize)) +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=ans, tsize=tsize, & + idof=Arange(obj.DOFStartIndex.ivar, obj.DOFEndIndex.ivar)) +END PROCEDURE obj_GetIndex2 + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex_2 +CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=ans, tsize=tsize, & + idof=Arange(obj.DOFStartIndex.ivar, obj.DOFEndIndex.ivar)) +END PROCEDURE obj_GetIndex_2 + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex3 +ans = GetIndex(obj=obj, ivar=NameToIndex(obj, varName), nodenum=nodenum) +END PROCEDURE obj_GetIndex3 + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex4 +INTEGER(I4B) :: tsize + +tsize = .tdof.obj +tsize = tsize * SIZE(nodenum) + +ALLOCATE (ans(tsize)) + +CALL obj_GetIndex_4(obj, nodenum, ans, tsize) + +END PROCEDURE obj_GetIndex4 + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex_4 +INTEGER(I4B) :: jj, ii, tdof, nn, tempsize + +nn = SIZE(nodenum) + +IF (obj%storageFMT .EQ. FMT_NODES) THEN + + tsize = 1 + + DO ii = 1, nn + CALL GetIndex_(obj=obj, nodenum=nodenum(ii), & + ans=ans(tsize:), tsize=tempsize) + tsize = tsize + tempsize + END DO + + tsize = tsize - 1 + RETURN + +END IF + +tdof = .tdof.obj +tsize = tdof * nn + +DO jj = 1, tdof + DO ii = 1, nn + ans((jj - 1) * nn + ii) = GetNodeLoc(obj=obj, nodenum=nodenum(ii), idof=jj) + END DO +END DO + +END PROCEDURE obj_GetIndex_4 + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex5 +INTEGER(I4B) :: tsize +tsize = obj.tdof.ivar +tsize = tsize * SIZE(nodenum) +ALLOCATE (ans(tsize)) +CALL obj_GetIndex_5(obj, nodenum, ivar, ans, tsize) +END PROCEDURE obj_GetIndex5 + +!---------------------------------------------------------------------------- +! GetIndex_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex_5 +INTEGER(I4B) :: jj, ii, tdof, nn, tempsize + +tdof = obj.tdof.ivar +nn = SIZE(nodenum) + +IF (obj%storageFMT .EQ. FMT_NODES) THEN + + tsize = 1 + DO ii = 1, nn + CALL GetIndex_(obj=obj, nodenum=nodenum(ii), ivar=ivar, ans=ans(tsize:), & + tsize=tempsize) + tsize = tsize + tempsize + + END DO + tsize = tsize - 1 + + RETURN + +END IF + +tsize = tdof * nn +tdof = 0 ! using tdof as counter +DO jj = (obj.DOFStartIndex.ivar), (obj.DOFEndIndex.ivar) + tdof = tdof + 1 + DO ii = 1, nn + ans((tdof - 1) * nn + ii) = GetNodeLoc(obj=obj, nodenum=nodenum(ii), & + idof=jj) + ! here tdof is local counter + END DO +END DO + +END PROCEDURE obj_GetIndex_5 + +!---------------------------------------------------------------------------- +! GetIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex6 +ans = GetIndex(obj=obj, ivar=NameToIndex(obj, varName), nodenum=nodenum) +END PROCEDURE obj_GetIndex6 + +!---------------------------------------------------------------------------- +! GetNodeLoc_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetNodeLoc_14 +INTEGER(I4B) :: jj + +IF (storageFMT .EQ. NODES_FMT) THEN + + ncol = SIZE(nodenum) + DO jj = 1, ncol + CALL GetNodeLoc_(obj=obj, nodenum=nodenum(jj), idof=idof, & + ans=ans(:, jj), tsize=nrow) + END DO + + RETURN +END IF + +ncol = SIZE(idof) +DO jj = 1, ncol + CALL GetNodeLoc_(obj=obj, nodenum=nodenum, idof=idof(jj), & + ans=ans(:, jj), tsize=nrow) +END DO + +END PROCEDURE obj_GetNodeLoc_14 + +END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 new file mode 100644 index 000000000..bbf0d7a77 --- /dev/null +++ b/src/submodules/DOF/src/DOF_GetValueMethods@Methods.F90 @@ -0,0 +1,368 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(DOF_GetValueMethods) Methods +USE GlobalData, ONLY: DOF_FMT, NODES_FMT + +USE ReallocateUtility, ONLY: Reallocate + +USE DOF_GetMethods, ONLY: OPERATOR(.tdof.), & + GetNodeLoc, & + GetIndex_, & + GetIDOF, & + OPERATOR(.tNodes.), & + GetNodeLoc + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! getArrayvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue1 +INTEGER(I4B) :: tsize +CALL Reallocate(v, SIZE(idof) * SIZE(nodenum)) +CALL GetValue_(v, tsize, val, obj, idof, storageFMT, & + nodenum) +END PROCEDURE obj_GetValue1 + +!---------------------------------------------------------------------------- +! getArrayvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue2 +INTEGER(I4B) :: m, n, i, k +LOGICAL(LGT) :: abool + +k = obj%valmap(idof(1) + 1) - obj%valmap(idof(1)) +m = SIZE(idof) + +DO i = 1, m + k = MAX(k, obj%valmap(idof(i) + 1) - obj%valmap(idof(i))) +END DO + +abool = PRESENT(force3D) .AND. (m .LT. 3) +IF (abool) m = 3 + +CALL Reallocate(v, m, k) +CALL GetValue_(v, val, m, k, obj, idof, force3D) + +END PROCEDURE obj_GetValue2 + +!---------------------------------------------------------------------------- +! getArrayvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue3 +INTEGER(I4B) :: i, k + +k = 0 +DO i = 1, SIZE(idof) + k = k + obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) +END DO + +CALL Reallocate(v, k) +CALL GetValue_(v, k, val, obj, idof, storageFMT) + +END PROCEDURE obj_GetValue3 + +!---------------------------------------------------------------------------- +! Arrayvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_get1 +CALL GetValue(v=ans, val=val, obj=obj, idof=idof, nodenum=nodenum, & + StorageFMT=StorageFMT) +END PROCEDURE obj_get1 + +!---------------------------------------------------------------------------- +! Arrayvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_get2 +CALL GetValue(v=ans, val=val, obj=obj, idof=idof, StorageFMT=StorageFMT) +END PROCEDURE obj_get2 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_1 +INTEGER(I4B) :: m, n, i, k, tdof +m = SIZE(idof) +n = SIZE(nodenum) + +tsize = m * n + +SELECT CASE (obj%StorageFMT) + +CASE (DOF_FMT) + + ! Returned storage format is NOT same as the storage format of the object + ! that is NODES_FMT + IF (StorageFMT .EQ. NODES_FMT) THEN + + DO CONCURRENT(i=1:m, k=1:n) + v((k - 1) * m + i) = val(nodenum(k) + obj%valmap(idof(i)) - 1) + END DO + + RETURN + + END IF + + ! Returned storage format is same as the storage format of the object + ! that is DOF_FMT + DO CONCURRENT(i=1:m) + v((i - 1) * n + 1:i * n) = val(nodenum + obj%valmap(idof(i)) - 1) + END DO + +CASE (NODES_FMT) + + tdof = .tdof.obj + + ! Returned storage format is NOT same as the storage format of the object + ! that is DOF_FMT + IF (StorageFMT .EQ. DOF_FMT) THEN + + DO CONCURRENT(i=1:n, k=1:m) + v((k - 1) * n + i) = val((nodenum(i) - 1) * tdof + idof(k)) + END DO + + RETURN + + END IF + + ! Returned storage format is same as the storage format of the object + ! that is NODES_FMT + DO CONCURRENT(i=1:n, k=1:m) + v((i - 1) * m + k) = val((nodenum(i) - 1) * tdof + idof(k)) + END DO + +END SELECT + +END PROCEDURE obj_GetValue_1 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_2 +INTEGER(I4B) :: m, n, i, k, tdof +LOGICAL(LGT) :: abool + +k = obj%valmap(idof(1) + 1) - obj%valmap(idof(1)) +m = SIZE(idof) + +DO i = 1, m + k = MAX(k, obj%valmap(idof(i) + 1) - obj%valmap(idof(i))) +END DO +ncol = k + +nrow = m +abool = PRESENT(force3D) .AND. (m .LT. 3) +IF (abool) nrow = 3 + +tdof = .tdof.obj + +SELECT CASE (obj%StorageFMT) + +CASE (DOF_FMT) + + DO i = 1, m + n = obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) + ! length of idof( i ) + DO k = 1, n + v(i, k) = val(k + obj%valmap(idof(i)) - 1) + END DO + END DO + +CASE (NODES_FMT) + + n = obj%valmap(2) - obj%valmap(1) ! size of dof; homogenous + DO i = 1, n + DO k = 1, m + v(k, i) = val((i - 1) * tdof + idof(k)) + END DO + END DO + +END SELECT + +END PROCEDURE obj_GetValue_2 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_3 +INTEGER(I4B) :: m, n, i, k, tdof, tsize_idof + +tsize_idof = SIZE(idof) + +k = 0 +DO i = 1, tsize_idof + k = k + obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) +END DO + +tsize = k + +SELECT CASE (obj%StorageFMT) + +CASE (DOF_FMT) + + IF (StorageFMT .EQ. NODES_FMT) THEN + + tdof = .tdof.obj + m = tsize_idof + DO i = 1, m + n = obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) + DO k = 1, n + v((k - 1) * m + i) = val(k + obj%valmap(idof(i)) - 1) + END DO + END DO + + RETURN + + END IF + + m = 0; n = 0 + DO i = 1, tsize_idof + m = n + 1 + n = n + obj%valmap(idof(i) + 1) - obj%valmap(idof(i)) + v(m:n) = & + val(obj%valmap(idof(i)):obj%valmap(idof(i + 1) - 1)) + END DO + +CASE (Nodes_FMT) + + tdof = .tdof.obj + m = tsize_idof + + IF (StorageFMT .EQ. DOF_FMT) THEN + n = obj%valmap(2) - obj%valmap(1) + DO i = 1, n + DO k = 1, m + v((k - 1) * n + i) = val((i - 1) * tdof + idof(k)) + END DO + END DO + RETURN + END IF + + DO i = 1, obj%valmap(2) - obj%valmap(1) + DO k = 1, m + v((i - 1) * m + k) & + = val((i - 1) * tdof + idof(k)) + END DO + END DO + +END SELECT + +END PROCEDURE obj_GetValue_3 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_4 +INTEGER(I4B) :: ii, jj + +tsize = .tdof.obj + +DO ii = 1, tsize + jj = GetNodeLoc(obj=obj, nodenum=nodenum, idof=ii) + v(ii) = val(jj) +END DO + +END PROCEDURE obj_GetValue_4 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_5 +INTEGER(I4B) :: ii, jj, kk + +tsize = obj.tdof.ivar + +DO ii = 1, tsize + kk = GetIDOF(obj=obj, ivar=ivar, idof=ii) + jj = GetNodeLoc(obj=obj, nodenum=nodenum, idof=kk) + v(ii) = val(jj) +END DO + +END PROCEDURE obj_GetValue_5 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_6 +INTEGER(I4B) :: ii, jj, kk +INTEGER(I4B), ALLOCATABLE :: indx(:) + +tsize = .tdof.obj +tsize = tsize * SIZE(nodenum) +ALLOCATE (indx(tsize)) +CALL GetIndex_(obj=obj, nodenum=nodenum, ans=indx, tsize=tsize) + +DO CONCURRENT(ii=1:tsize) + v(ii) = val(indx(ii)) +END DO + +DEALLOCATE (indx) + +END PROCEDURE obj_GetValue_6 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_7 +INTEGER(I4B) :: ii, jj + +tsize = SIZE(nodenum) + +DO ii = 1, tsize + jj = GetNodeLoc(obj=obj, nodenum=nodenum(ii), idof=idof) + v(ii) = val(jj) +END DO + +END PROCEDURE obj_GetValue_7 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_8 +INTEGER(I4B) :: ii, jj, s(3) + +tsize = obj.tNodes.idof +s = GetNodeLoc(obj=obj, idof=idof) + +DO CONCURRENT(jj=s(1):s(2):s(3)) + ii = INT((jj - s(1) + s(3)) / s(3)) + v(ii) = val(jj) +END DO + +END PROCEDURE obj_GetValue_8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 new file mode 100644 index 000000000..5fda02d7e --- /dev/null +++ b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 @@ -0,0 +1,94 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 28 Feb 2021 +! summary: This submodule contains IO method for [[DOF_]] + +SUBMODULE(DOF_IOMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dof_Display1 +INTEGER(I4B) :: n, j + +IF (LEN_TRIM(msg) .NE. 0) THEN + CALL Display("# "//TRIM(msg), unitNo=unitNo) +END IF +IF (ALLOCATED(obj%Map)) THEN + ASSOCIATE (Map => obj%Map, ValMap => obj%ValMap) + n = SIZE(Map, 1) - 1 + CALL Display(n, "# Total Physical Variables :", unitNo=unitNo) + DO j = 1, n + CALL Display("# Name : "//CHAR(Map(j, 1)), unitNo=unitNo) + IF (Map(j, 2) .LT. 0) THEN + CALL Display("# Space Components : "//"Scalar", unitNo=unitNo) + ELSE + CALL Display(Map(j, 2), "# Space Components : ", unitNo=unitNo) + END IF + CALL Display(Map(j, 3), "# Time Components : ", unitNo=unitNo) + CALL Display(Map(j, 6), "# Total Nodes : ", unitNo=unitNo) + END DO + SELECT CASE (obj%StorageFMT) + CASE (DOF_FMT) + CALL Display("# Storage Format : DOF", unitNo=unitNo) + CASE (Nodes_FMT) + CALL Display("# Storage Format : Nodes", unitNo=unitNo) + END SELECT + CALL Display(obj%ValMap, "# Value Map : ", unitNo=unitNo) + END ASSOCIATE +ELSE + CALL Display("# obj%Map : NOT ALLOCATED") +END IF +END PROCEDURE dof_Display1 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dof_display2 +INTEGER(I4B) :: jj, tnames, idof, a(3) +!> main +CALL Display(obj, '# DOF data : ', unitNo=unitNo) +tnames = .tNames.obj +DO jj = 1, tnames + 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") + END DO + CALL Display(" ", unitNo=unitNo, advance=.TRUE.) +END DO +END PROCEDURE dof_display2 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +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 SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 new file mode 100644 index 000000000..7171df3cd --- /dev/null +++ b/src/submodules/DOF/src/DOF_SetMethods@Methods.F90 @@ -0,0 +1,319 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(DOF_SetMethods) Methods +USE DOF_GetMethods, ONLY: GetIndex, & + GetNodeLoc, & + OPERATOR(.tdof.) +USE GlobalData, ONLY: DOF_FMT, NODES_FMT, NodesToDOF, DOFToNodes +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set1 +INTEGER(I4B) :: tdof, idof, i, n, m + +tdof = .tdof.obj +n = SIZE(nodenum) +m = SIZE(VALUE) + +ASSOCIATE (vm => obj%valmap) + SELECT CASE (obj%StorageFMT) + CASE (DOF_FMT) + IF (m .NE. n) THEN + IF (m .EQ. 1) THEN + DO idof = 1, tdof + Vec(vm(idof) - 1 + nodenum) = VALUE(1) + END DO + ELSE IF (m .EQ. tdof * n) THEN + IF (Conversion(1) .EQ. NodesToDOF) THEN + DO idof = 1, tdof + DO i = 1, n + Vec(vm(idof) - 1 + nodenum(i)) = & + & VALUE((i - 1) * tdof + idof) + END DO + END DO + ELSE + DO idof = 1, tdof + Vec(vm(idof) - 1 + nodenum) = & + & VALUE((idof - 1) * n + 1:idof * n) + END DO + END IF + END IF + ELSE + DO idof = 1, tdof + Vec(vm(idof) - 1 + nodenum) = VALUE(:) + END DO + END IF + + CASE (NODES_FMT) + IF (m .NE. n) THEN + IF (m .EQ. 1) THEN + DO idof = 1, tdof + Vec((nodenum - 1) * tdof + idof) = VALUE(1) + END DO + ELSE IF (m .EQ. tdof * n) THEN + IF (Conversion(1) .EQ. DOFToNodes) THEN + DO idof = 1, tdof + DO i = 1, n + Vec((nodenum(i) - 1) * tdof + idof) & + & = VALUE((idof - 1) * n + i) + END DO + END DO + ELSE + DO idof = 1, tdof + DO i = 1, n + Vec((nodenum(i) - 1) * tdof + idof) & + & = VALUE((i - 1) * tdof + idof) + END DO + END DO + END IF + END IF + ELSE + DO idof = 1, tdof + Vec((nodenum - 1) * tdof + idof) = VALUE(:) + END DO + END IF + END SELECT +END ASSOCIATE +END PROCEDURE obj_set1 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set2 +vec(GetIndex(obj=obj, nodenum=nodenum)) = VALUE +END PROCEDURE obj_set2 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set3 + +IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN + Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & idof=idof)) = VALUE(:) + RETURN +END IF + +Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & idof=idof)) = VALUE(1) + +END PROCEDURE obj_set3 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set4 + +IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN + Vec( & + & GetIndex( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & idof=idof)) & + & = VALUE(:) + RETURN +END IF + +Vec( & + & GetIndex( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & idof=idof)) & + & = VALUE(1) + +END PROCEDURE obj_set4 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set5 + +IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN + + Vec(GetNodeLoc(& + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) & + & = VALUE(:) + RETURN +END IF + +Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) & + & = VALUE(1) + +END PROCEDURE obj_set5 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set6 + +IF (SIZE(nodenum) .EQ. SIZE(VALUE) * SIZE(timecompo)) THEN + Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) & + & = VALUE(:) + RETURN +END IF + +Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) & + & = VALUE(1) + +END PROCEDURE obj_set6 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set7 + +IF (SIZE(nodenum) .EQ. SIZE(VALUE) * SIZE(spacecompo)) THEN + Vec(GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) & + & = VALUE(:) + RETURN +END IF + +Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) & + & = VALUE(1) + +END PROCEDURE obj_set7 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set8 +vec( & + & GetIndex( & + & obj=obj, & + & nodenum=nodenum)) = VALUE +END PROCEDURE obj_set8 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set9 +Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & idof=idof)) = VALUE +END PROCEDURE obj_set9 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set10 +Vec( & + & GetNodeLoc( & + & obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & idof=idof)) = VALUE +END PROCEDURE obj_set10 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set11 +Vec(GetNodeLoc(obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) = VALUE +END PROCEDURE obj_set11 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set12 +Vec(GetNodeLoc(obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) = VALUE +END PROCEDURE obj_set12 + +!---------------------------------------------------------------------------- +! setvalue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_set13 +Vec(GetNodeLoc(obj=obj, & + & nodenum=nodenum, & + & ivar=ivar, & + & spacecompo=spacecompo, & + & timecompo=timecompo)) = VALUE +END PROCEDURE obj_set13 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/DiffusionMatrix/CMakeLists.txt b/src/submodules/DiffusionMatrix/CMakeLists.txt new file mode 100644 index 000000000..38ed8ff50 --- /dev/null +++ b/src/submodules/DiffusionMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/DiffusionMatrix_Method@Methods.F90 + ) diff --git a/src/submodules/DiffusionMatrix/src/DM_1.inc b/src/submodules/DiffusionMatrix/src/DM_1.inc new file mode 100644 index 000000000..9517abe0d --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_1.inc @@ -0,0 +1,55 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE DM_1(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! a scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + !! + !! internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + !! + realval = trial%js * trial%ws * trial%thickness * kbar + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + DO ii = 1, SIZE(realval) + !! + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + !! + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (kbar, realval) +END SUBROUTINE DM_1 diff --git a/src/submodules/DiffusionMatrix/src/DM_10.inc b/src/submodules/DiffusionMatrix/src/DM_10.inc new file mode 100644 index 000000000..040bbf3c3 --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_10.inc @@ -0,0 +1,59 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! vector +!! matrix +!! +PURE SUBROUTINE DM_10(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c1 + !! vector variable + TYPE(FEVariable_), INTENT(IN) :: c2 + !! matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! internal variable + REAL(DFP), ALLOCATABLE :: matbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + TYPE(FEVariable_) :: k + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) + CALL getInterpolation(obj=trial, interpol=matbar, val=c2) + CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) + !! + DO ii = 1, SIZE(c2bar, 2) + c1bar(:,ii) = MATMUL(c2bar(:,ii), matbar(:,:,ii)) + END DO + !! + k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) + realval = trial%js * trial%ws * trial%thickness + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval, matbar) +END SUBROUTINE DM_10 diff --git a/src/submodules/DiffusionMatrix/src/DM_2.inc b/src/submodules/DiffusionMatrix/src/DM_2.inc new file mode 100644 index 000000000..95eaf72a7 --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_2.inc @@ -0,0 +1,56 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE DM_2(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! a vector variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + !! + !! internal variable + !! + REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) + !! + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) + !! + realval = trial%js * trial%ws * trial%thickness + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval) +END SUBROUTINE DM_2 diff --git a/src/submodules/DiffusionMatrix/src/DM_3.inc b/src/submodules/DiffusionMatrix/src/DM_3.inc new file mode 100644 index 000000000..5e67de895 --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_3.inc @@ -0,0 +1,55 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE DM_3(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! a matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + !! + !! internal variable + REAL(DFP), ALLOCATABLE :: kbar(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + !! + realval = trial%js * trial%ws * trial%thickness + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(& + & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (kbar, realval) + !! +END SUBROUTINE DM_3 diff --git a/src/submodules/DiffusionMatrix/src/DM_4.inc b/src/submodules/DiffusionMatrix/src/DM_4.inc new file mode 100644 index 000000000..6968f1073 --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_4.inc @@ -0,0 +1,60 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- +!! +!! vector +!! vector +!! +PURE SUBROUTINE DM_4(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! a vector variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! a vector variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) + !! + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) + !! + realval = trial%js * trial%ws * trial%thickness + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval) + !! +END SUBROUTINE DM_4 diff --git a/src/submodules/DiffusionMatrix/src/DM_5.inc b/src/submodules/DiffusionMatrix/src/DM_5.inc new file mode 100644 index 000000000..19137878e --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_5.inc @@ -0,0 +1,60 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- +!! +!! scalar +!! matrix +!! +PURE SUBROUTINE DM_5(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! a scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! a matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: kbar(:, :,:), realval(:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL getInterpolation(obj=trial, Interpol=realval, val=c1) + !! + CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) + !! + realval = realval * trial%js * trial%ws * trial%thickness + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(& + & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE(realval, kbar) + !! +END SUBROUTINE DM_5 diff --git a/src/submodules/DiffusionMatrix/src/DM_6.inc b/src/submodules/DiffusionMatrix/src/DM_6.inc new file mode 100644 index 000000000..1219d3a13 --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_6.inc @@ -0,0 +1,55 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- +!! +!! scalar +!! scalar +!! +PURE SUBROUTINE DM_6(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! a scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! a scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) + CALL getInterpolation(obj=trial, Interpol=realval, val=c2) + realval = realval * trial%js * trial%ws * trial%thickness * cbar + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (cbar, realval) +END SUBROUTINE DM_6 diff --git a/src/submodules/DiffusionMatrix/src/DM_7.inc b/src/submodules/DiffusionMatrix/src/DM_7.inc new file mode 100644 index 000000000..079844613 --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_7.inc @@ -0,0 +1,54 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- +!! +!! scalar +!! vector +!! +PURE SUBROUTINE DM_7(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! a scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! a vector variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! internal variable + REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) + INTEGER(I4B) :: ii + !! main + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) + CALL getInterpolation(obj=trial, interpol=realval, val=c1) + realval = realval * trial%js * trial%ws * trial%thickness + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval) +END SUBROUTINE DM_7 diff --git a/src/submodules/DiffusionMatrix/src/DM_8.inc b/src/submodules/DiffusionMatrix/src/DM_8.inc new file mode 100644 index 000000000..9fac7662e --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_8.inc @@ -0,0 +1,63 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- +!! +!! matrix +!! matrix +!! +PURE SUBROUTINE DM_8(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! a matrix variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! a matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! internal variable + REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) + !! + CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) + !! + realval = trial%js * trial%ws * trial%thickness + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + DO ii = 1, SIZE(realval) + !! + ans = ans + realval(ii) * MATMUL( & + & MATMUL(test%dNdXt(:, :, ii),& + & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + !! + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (k1bar, k2bar, realval) + !! +END SUBROUTINE DM_8 diff --git a/src/submodules/DiffusionMatrix/src/DM_9.inc b/src/submodules/DiffusionMatrix/src/DM_9.inc new file mode 100644 index 000000000..c2367cc8d --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DM_9.inc @@ -0,0 +1,59 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! matrix +!! vector +!! +PURE SUBROUTINE DM_9(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c1 + !! matrix variable + TYPE(FEVariable_), INTENT(IN) :: c2 + !! vector variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! internal variable + REAL(DFP), ALLOCATABLE :: matbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + TYPE(FEVariable_) :: k + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, interpol=matbar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) + !! + DO ii = 1, SIZE(c2bar, 2) + c1bar(:,ii) = MATMUL(matbar(:,:,ii), c2bar(:,ii)) + END DO + !! + k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) + realval = trial%js * trial%ws * trial%thickness + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval, matbar) +END SUBROUTINE DM_9 diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 new file mode 100644 index 000000000..755daed8f --- /dev/null +++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 @@ -0,0 +1,548 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(DiffusionMatrix_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_1 + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + realval = trial%js * trial%ws * trial%thickness + DO ii = 1, SIZE(trial%N, 2) + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (realval) + !! +END PROCEDURE DiffusionMatrix_1 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_2 + REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + !! + realval = trial%js * trial%ws * trial%thickness * kbar + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + DO ii = 1, SIZE(realval) + !! + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + !! + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (kbar, realval) +END PROCEDURE DiffusionMatrix_2 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_3 + !! + REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) + !! + realval = trial%js * trial%ws * trial%thickness + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval) + !! +END PROCEDURE DiffusionMatrix_3 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_4 + ! CALL DM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) + !! internal variable + REAL(DFP), ALLOCATABLE :: kbar(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + !! + realval = trial%js * trial%ws * trial%thickness + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(& + & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (kbar, realval) + !! +END PROCEDURE DiffusionMatrix_4 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_5 + !! scalar + !! scalar + !! CALL DM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) + CALL getInterpolation(obj=trial, Interpol=realval, val=c2) + realval = realval * trial%js * trial%ws * trial%thickness * cbar + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (cbar, realval) +END PROCEDURE DiffusionMatrix_5 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_6 + !! scalar + !! vector + !! CALL DM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! + REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) + INTEGER(I4B) :: ii + !! main + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) + CALL getInterpolation(obj=trial, interpol=realval, val=c1) + realval = realval * trial%js * trial%ws * trial%thickness + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval) + !! +END PROCEDURE DiffusionMatrix_6 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_7 + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: kbar(:, :,:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL getInterpolation(obj=trial, Interpol=realval, val=c1) + CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) + realval = realval * trial%js * trial%ws * trial%thickness + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(& + & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + DEALLOCATE(realval, kbar) + !! +END PROCEDURE DiffusionMatrix_7 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_8 + !! + ans = DiffusionMatrix( & + & test=test, & + & trial=trial, & + & c1=c2, & + & c2=c1, & + & c1rank=TypeFEVariableScalar, & + & c2rank=TypeFEVariableVector, & + & opt=opt) + !! +END PROCEDURE DiffusionMatrix_8 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_9 + !! Internal variable + REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) + INTEGER(I4B) :: ii + !! + !! main + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) + realval = trial%js * trial%ws * trial%thickness + !! + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + DEALLOCATE (c1bar, c2bar, realval) + !! +END PROCEDURE DiffusionMatrix_9 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_10 + !! internal variable + REAL(DFP), ALLOCATABLE :: matbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + TYPE(FEVariable_) :: k + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) + CALL getInterpolation(obj=trial, interpol=matbar, val=c2) + CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) + !! + DO ii = 1, SIZE(c2bar, 2) + c1bar(:,ii) = MATMUL(c2bar(:,ii), matbar(:,:,ii)) + END DO + !! + k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) + realval = trial%js * trial%ws * trial%thickness + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval, matbar) + !! +END PROCEDURE DiffusionMatrix_10 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_11 + !! + ans = DiffusionMatrix( & + & test=test, & + & trial=trial, & + & c1=c2, c2=c1, & + & c1rank=TypeFEVariableScalar, & + & c2rank=TypeFEVariableMatrix, & + & opt=opt ) + !! +END PROCEDURE DiffusionMatrix_11 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_12 + !! internal variable + REAL(DFP), ALLOCATABLE :: matbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + TYPE(FEVariable_) :: k + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, interpol=matbar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) + !! + DO ii = 1, SIZE(c2bar, 2) + c1bar(:,ii) = MATMUL(matbar(:,:,ii), c2bar(:,ii)) + END DO + !! + k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) + CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) + CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) + realval = trial%js * trial%ws * trial%thickness + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (c1bar, c2bar, realval, matbar) +END PROCEDURE DiffusionMatrix_12 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_13 + !! internal variable + REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) + INTEGER(I4B) :: ii + !! main + CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) + CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + realval = trial%js * trial%ws * trial%thickness + !! + DO ii = 1, SIZE(realval) + !! + ans = ans + realval(ii) * MATMUL( & + & MATMUL(test%dNdXt(:, :, ii),& + & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) + !! + END DO + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + DEALLOCATE (k1bar, k2bar, realval) +END PROCEDURE DiffusionMatrix_13 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_14 + !! + SELECT CASE( opt(1) ) + CASE( 1 ) + CALL DiffusionMatrix_14a( test, trial, ans ) + CASE( 2 ) + CALL DiffusionMatrix_14b( test, trial, ans ) + END SELECT + !! +END PROCEDURE DiffusionMatrix_14 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE DiffusionMatrix_14a( test, trial, ans ) + !! + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + !! + REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : ) + INTEGER(I4B) :: ii, jj, nsd, ips + !! + realval = trial%js * trial%ws * trial%thickness + nsd = test%refelem%nsd + CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + !! + DO ips = 1, SIZE(trial%N, 2) + DO jj = 1, nsd + DO ii = 1, nsd + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & test%dNdXt( :, ii, ips ), & + & trial%dNdXt(:, jj, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE (realval, m4) + !! +END SUBROUTINE DiffusionMatrix_14a + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE DiffusionMatrix_14b( test, trial, ans ) + !! + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + !! + REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : ) + INTEGER(I4B) :: ii, jj, nsd, ips + !! + realval = trial%js * trial%ws * trial%thickness + nsd = test%refelem%nsd + CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + !! + DO ips = 1, SIZE(trial%N, 2) + DO jj = 1, nsd + DO ii = 1, nsd + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & test%dNdXt( :, jj, ips ), & + & trial%dNdXt(:, ii, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE (realval, m4) + !! +END SUBROUTINE DiffusionMatrix_14b + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix_15 + !! + SELECT CASE( opt(1) ) + CASE( 1 ) + CALL DiffusionMatrix_15a( test, trial, k, ans ) + CASE( 2 ) + CALL DiffusionMatrix_15b( test, trial, k, ans ) + END SELECT + !! +END PROCEDURE DiffusionMatrix_15 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE DiffusionMatrix_15a( test, trial, k, ans ) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! scalar + REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + !! + !! internal variables + !! + REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : ) + INTEGER(I4B) :: ii, jj, nsd, ips + !! + !! main + !! + nsd = test%refelem%nsd + CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + realval = trial%js * trial%ws * trial%thickness * kbar + !! + DO ips = 1, SIZE(trial%N, 2) + DO jj = 1, nsd + DO ii = 1, nsd + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & test%dNdXt( :, ii, ips ), & + & trial%dNdXt(:, jj, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE (kbar, realval, m4) + !! +END SUBROUTINE DiffusionMatrix_15a + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE DiffusionMatrix_15b( test, trial, k, ans ) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! scalar + REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + !! + !! internal variables + !! + REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : ) + INTEGER(I4B) :: ii, jj, nsd, ips + !! + !! main + !! + nsd = test%refelem%nsd + CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + realval = trial%js * trial%ws * trial%thickness * kbar + !! + DO ips = 1, SIZE(trial%N, 2) + DO jj = 1, nsd + DO ii = 1, nsd + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & test%dNdXt( :, jj, ips ), & + & trial%dNdXt(:, ii, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE (kbar, realval, m4) + !! +END SUBROUTINE DiffusionMatrix_15b + +END SUBMODULE Methods diff --git a/src/submodules/ElasticNitscheMatrix/CMakeLists.txt b/src/submodules/ElasticNitscheMatrix/CMakeLists.txt new file mode 100644 index 000000000..8d42f639f --- /dev/null +++ b/src/submodules/ElasticNitscheMatrix/CMakeLists.txt @@ -0,0 +1,26 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/ElasticNitscheMatrix_Method@Matrix1.F90 + ${src_path}/ElasticNitscheMatrix_Method@Matrix2.F90 + ${src_path}/ElasticNitscheMatrix_Method@Matrix3.F90 + ${src_path}/ElasticNitscheMatrix_Method@MatrixNormal.F90 + ${src_path}/ElasticNitscheMatrix_Method@MatrixTangent.F90 + ) diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 new file mode 100644 index 000000000..8a82a9b17 --- /dev/null +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 @@ -0,0 +1,312 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ElasticNitscheMatrix_Method) Matrix1 +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! NitscheMatrix +!---------------------------------------------------------------------------- + +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) +DEALLOCATE (lamBar, muBar, evecBar) +END PROCEDURE ElasticNitscheMatrix1a + +!---------------------------------------------------------------------------- +! NitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1b +REAL(DFP), ALLOCATABLE :: evecBar(:, :) +CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +ans = ElasticNitscheMatrix( & +& test=test, & +& trial=trial, & +& lambda=lambda, & +& mu=mu, & +& evec=evecBar) +DEALLOCATE (evecBar) +END PROCEDURE ElasticNitscheMatrix1b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1c +REAL(DFP), ALLOCATABLE :: evecBar(:, :) +CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +ans = ElasticNitscheMatrix(test=test, trial=trial, & + & lambda=lambda, mu=mu, evec=evecBar) +DEALLOCATE (evecBar) +END PROCEDURE ElasticNitscheMatrix1c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1d +REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i +REAL(DFP) :: dd(3, 3) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +realval = trial%Ws * trial%Js * trial%Thickness +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP + +DO ips = 1, nips + dd(1:nsd, 1:nsd) = & + & lambda(ips) * realval(ips) & + & * DOT_PRODUCT(trial%normal(1:nsd, ips), evec(1:nsd, ips)) & + & * Eye3(1:nsd, 1:nsd) & + & + 2.0 * mu(ips) * realval(ips) & + & * OUTERPROD(a=trial%normal(1:nsd, ips), & + & b=evec(1:nsd, ips), & + & Sym=.TRUE.) + + ff = OUTERPROD( & + & test%N(1:nns1, ips), & + & RESHAPE( & + & MATMUL( & + & trial%dNdXt(1:nns2, 1:nsd, ips), & + & dd(1:nsd, 1:nsd) & + & ), & + & [nsd * nns2] & + & ) & + & ) + + r1 = 0; r2 = 0 + DO i = 1, nsd + r1 = r2 + 1; r2 = i * nns1 + ans(r1:r2, :) = ans(r1:r2, :) + evec(i, ips) * ff + END DO +END DO + +DEALLOCATE (realval, ff) + +END PROCEDURE ElasticNitscheMatrix1d + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1e +REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j +REAL(DFP) :: dd(3, 3) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +realval = trial%Ws * trial%Js * trial%Thickness +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +ans = 0.0_DFP + +DO ips = 1, nips + dd(1:nsd, 1:nsd) = & + & lambda * realval(ips) & + & * DOT_PRODUCT(trial%normal(1:nsd, ips), evec(1:nsd, ips)) & + & * Eye3(1:nsd, 1:nsd) & + & + 2.0 * mu * realval(ips) & + & * OUTERPROD(a=trial%normal(1:nsd, ips), & + & b=evec(1:nsd, ips), & + & Sym=.TRUE.) + + ff = OUTERPROD( & + & test%N(1:nns1, ips), & + & RESHAPE( & + & MATMUL( & + & trial%dNdXt(1:nns2, 1:nsd, ips), & + & dd(1:nsd, 1:nsd) & + & ), & + & [nsd * nns2] & + & ) & + & ) + + r1 = 0; r2 = 0 + DO i = 1, nsd + r1 = r2 + 1; r2 = i * nns1 + ans(r1:r2, :) = ans(r1:r2, :) + evec(i, ips) * ff + END DO +END DO + +DEALLOCATE (realval, ff) + +END PROCEDURE ElasticNitscheMatrix1e + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1f +REAL(DFP), ALLOCATABLE :: evecBar(:, :) +INTEGER(I4B) :: ii, nips +nips = SIZE(trial%N, 2) +ALLOCATE (evecBar(SIZE(evec), nips)) +DO ii = 1, nips + evecBar(:, ii) = evec +END DO +ans = ElasticNitscheMatrix(test=test, trial=trial, & + & lambda=lambda, mu=mu, evec=evecBar) +DEALLOCATE (evecBar) +END PROCEDURE ElasticNitscheMatrix1f + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1g +REAL(DFP), ALLOCATABLE :: evecBar(:, :) +INTEGER(I4B) :: ii, nips +nips = SIZE(trial%N, 2) +ALLOCATE (evecBar(SIZE(evec), nips)) +DO ii = 1, nips + evecBar(:, ii) = evec +END DO +ans = ElasticNitscheMatrix(test=test, trial=trial, & + & lambda=lambda, mu=mu, evec=evecBar) +DEALLOCATE (evecBar) +END PROCEDURE ElasticNitscheMatrix1g + +!---------------------------------------------------------------------------- +! ElasticNitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1h +REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i +REAL(DFP) :: dd(3, 3) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +realval = trial%Ws * trial%Js * trial%Thickness +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +ans = 0.0_DFP + +r1 = 1; r2 = dim * nns1 + +DO ips = 1, nips + + dd(1:nsd, 1:nsd) = & + & lambda(ips) * realval(ips) * trial%normal(dim, ips) & + & * Eye3(1:nsd, 1:nsd) & + & + 2.0 * mu(ips) * realval(ips) & + & * OUTERPROD(a=trial%normal(1:nsd, ips), & + & b=Eye3(1:nsd, dim), & + & Sym=.TRUE.) + + ff = OUTERPROD( & + & test%N(1:nns1, ips), & + & RESHAPE( & + & MATMUL( & + & trial%dNdXt(1:nns2, 1:nsd, ips), & + & dd(1:nsd, 1:nsd) & + & ), & + & [nsd * nns2] & + & ) & + & ) + + ans(r1:r2, :) = ans(r1:r2, :) + ff +END DO + +DEALLOCATE (realval, ff) + +END PROCEDURE ElasticNitscheMatrix1h + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix1i +REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i +REAL(DFP) :: dd(3, 3) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +realval = trial%Ws * trial%Js * trial%Thickness +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +ans = 0.0_DFP + +r1 = 1; r2 = dim * nns1 + +DO ips = 1, nips + + dd(1:nsd, 1:nsd) = & + & lambda * realval(ips) * trial%normal(dim, ips) & + & * Eye3(1:nsd, 1:nsd) & + & + 2.0 * mu * realval(ips) & + & * OUTERPROD(a=trial%normal(1:nsd, ips), & + & b=Eye3(1:nsd, dim), & + & Sym=.TRUE.) + + ff = OUTERPROD( & + & test%N(1:nns1, ips), & + & RESHAPE( & + & MATMUL( & + & trial%dNdXt(1:nns2, 1:nsd, ips), & + & dd(1:nsd, 1:nsd) & + & ), & + & [nsd * nns2] & + & ) & + & ) + + ans(r1:r2, :) = ans(r1:r2, :) + ff +END DO + +DEALLOCATE (realval, ff) + +END PROCEDURE ElasticNitscheMatrix1i + +!---------------------------------------------------------------------------- +! NitscheMatrix +!---------------------------------------------------------------------------- + +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) +DEALLOCATE (lamBar, muBar) +END PROCEDURE ElasticNitscheMatrix1j + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Matrix1 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 new file mode 100644 index 000000000..efb294ac2 --- /dev/null +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 @@ -0,0 +1,154 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ElasticNitscheMatrix_Method) Matrix2 +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! NitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix2a +REAL(DFP), ALLOCATABLE :: realval(:), SBar(:), cdNdXt(:, :) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2 + +nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd +!<--- make integration parameters +realval = trial%Ws * trial%Thickness * trial%Js +!<--- allocate ans +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP +ALLOCATE (cdNdXt(SIZE(trial%N, 1), SIZE(trial%N, 2))) +DO i = 1, SIZE(trial%N, 2) + cdNdXt(:, i) = MATMUL(trial%dNdXt(:, :, i), trial%Normal(1:nsd, i)) +END DO + +DO ips = 1, nips + c1 = 0; c2 = 0 + DO j = 1, nsd + c1 = c2 + 1; c2 = j * nns2 + r1 = 0; r2 = 0 + DO i = 1, nsd + r1 = r2 + 1; r2 = i * nns1 + IF (i .EQ. j) THEN + SBar = lambda * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & + & + mu * cdNdXt(:, ips) & + & + mu * trial%normal(j, ips) * trial%dNdXt(:, i, ips) + ELSE + SBar = lambda * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & + & + mu * trial%normal(j, ips) * trial%dNdXt(:, i, ips) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) & + & + realval(ips) * OUTERPROD(test%N(:, ips), SBar) + END DO + END DO +END DO + +DEALLOCATE (realval, SBar, cdNdXt) +END PROCEDURE ElasticNitscheMatrix2a + +!---------------------------------------------------------------------------- +! NitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix2b +REAL(DFP), ALLOCATABLE :: realval(:), SBar(:), cdNdXt(:, :), & + & lamBar(:), muBar(:) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2 + +nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd + +SELECT CASE (lambda%VarType) +CASE (Constant) + + ALLOCATE (lamBar(nips)) + lamBar = Get(lambda, TypeFEVariableScalar, & + & TypeFEVariableConstant) + +CASE (Space) + + realval = Get(lambda, TypeFEVariableScalar, & + & TypeFEVariableSpace) + + IF (lambda%DefineOn .EQ. Nodal) THEN + lamBar = Interpolation(trial, realval) + ELSE + lamBar = realval + END IF +END SELECT + +SELECT CASE (mu%VarType) +CASE (Constant) + + ALLOCATE (muBar(nips)) + muBar = Get(mu, TypeFEVariableScalar, & + & TypeFEVariableConstant) + +CASE (Space) + + realval = Get(mu, TypeFEVariableScalar, & + & TypeFEVariableSpace) + + IF (mu%DefineOn .EQ. Nodal) THEN + muBar = Interpolation(trial, realval) + ELSE + muBar = realval + END IF +END SELECT + +!<--- make integration parameters +realval = trial%Ws * trial%Thickness * trial%Js +!<--- allocate ans +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP +ALLOCATE (cdNdXt(SIZE(trial%N, 1), SIZE(trial%N, 2))) +DO i = 1, SIZE(trial%N, 2) + cdNdXt(:, i) = MATMUL(trial%dNdXt(:, :, i), trial%Normal(1:nsd, i)) +END DO + +DO ips = 1, nips + c1 = 0; c2 = 0 + DO j = 1, nsd + c1 = c2 + 1; c2 = j * nns2 + r1 = 0; r2 = 0 + DO i = 1, nsd + r1 = r2 + 1; r2 = i * nns1 + IF (i .EQ. j) THEN + SBar = lamBar(ips) * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & + & + muBar(ips) * cdNdXt(:, ips) & + & + muBar(ips) * trial%normal(j, ips) * trial%dNdXt(:, i, ips) + ELSE + SBar = lamBar(ips) * trial%normal(i, ips) * trial%dNdXt(:, j, ips) & + & + muBar(ips) * trial%normal(j, ips) * trial%dNdXt(:, i, ips) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) & + & + realval(ips) * OUTERPROD(test%N(:, ips), SBar) + END DO + END DO +END DO + +DEALLOCATE (realval, SBar, cdNdXt, lamBar, muBar) +END PROCEDURE ElasticNitscheMatrix2b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Matrix2 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 new file mode 100644 index 000000000..f18d33209 --- /dev/null +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 @@ -0,0 +1,240 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ElasticNitscheMatrix_Method) Matrix3 +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! NitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix3a +REAL(DFP), ALLOCATABLE :: alphaBar(:), evecBar(:, :) +CALL getInterpolation(obj=trial, interpol=alphaBar, val=alpha) +CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +ans = ElasticNitscheMatrix( & +& test=test, trial=trial, alpha=alphaBar, evec=evecBar) +DEALLOCATE (alphaBar, evecBar) +END PROCEDURE ElasticNitscheMatrix3a + +!---------------------------------------------------------------------------- +! NitscheMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix3b +REAL(DFP), ALLOCATABLE :: evecBar(:, :) +CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +ans = ElasticNitscheMatrix( & +& test=test, trial=trial, alpha=alpha, evec=evecBar) +DEALLOCATE (evecBar) +END PROCEDURE ElasticNitscheMatrix3b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix3c +INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, i, j, r1, r2, c1, c2 +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: dd(:, :) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +realval = trial%Ws * trial%Js * trial%Thickness * alpha +ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) +ans = 0.0_DFP + +DO ips = 1, nips + + dd = realval(ips) * & + & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) + + c1 = 0; c2 = 0 + DO j = 1, nsd + c1 = c2 + 1 + c2 = j * nns2 + r1 = 0 + r2 = r1 + DO i = 1, nsd + r1 = r2 + 1 + r2 = i * nns1 + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & + & evec(i, ips) * evec(j, ips) * dd + END DO + END DO +END DO + +DEALLOCATE (realval, dd) + +END PROCEDURE ElasticNitscheMatrix3c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix3d +INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, i, j, r1, r2, c1, c2 +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: dd(:, :) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +realval = trial%Ws * trial%Js * trial%Thickness * alpha +ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) +ans = 0.0_DFP + +DO ips = 1, nips + + dd = realval(ips) * & + & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) + + c1 = 0; c2 = 0 + DO j = 1, nsd + c1 = c2 + 1 + c2 = j * nns2 + r1 = 0 + r2 = r1 + DO i = 1, nsd + r1 = r2 + 1 + r2 = i * nns1 + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & + & evec(i, ips) * evec(j, ips) * dd + END DO + END DO +END DO + +DEALLOCATE (realval, dd) + +END PROCEDURE ElasticNitscheMatrix3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix3e +INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, i, j, r1, r2, c1, c2 +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: dd(:, :) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +realval = trial%Ws * trial%Js * trial%Thickness * alpha +ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) +ans = 0.0_DFP + +DO ips = 1, nips + + dd = realval(ips) * & + & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) + + c1 = 0; c2 = 0 + DO j = 1, nsd + c1 = c2 + 1 + c2 = j * nns2 + r1 = 0 + r2 = r1 + DO i = 1, nsd + r1 = r2 + 1 + r2 = i * nns1 + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & + & evec(i) * evec(j) * dd + END DO + END DO +END DO + +DEALLOCATE (realval, dd) + +END PROCEDURE ElasticNitscheMatrix3e + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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) +DEALLOCATE (alphaBar) +END PROCEDURE ElasticNitscheMatrix3f + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix3g +INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, r1, r2, c1, c2 +REAL(DFP), ALLOCATABLE :: realval(:) +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +realval = trial%Ws * trial%Js * trial%Thickness * alpha +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +ans = 0.0_DFP +r1 = (dim - 1) * nns1 + 1 +r2 = dim * nns1 +c1 = (dim - 1) * nns2 + 1 +c2 = dim * nns2 +DO ips = 1, nips + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & + & realval(ips) * & + & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) +END DO +DEALLOCATE (realval) +END PROCEDURE ElasticNitscheMatrix3g + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrix3h +INTEGER(I4B) :: nns1, nns2, nsd, nips, ips, r1, r2, c1, c2 +REAL(DFP), ALLOCATABLE :: realval(:) +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +realval = trial%Ws * trial%Js * trial%Thickness * alpha +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +ans = 0.0_DFP +r1 = (dim - 1) * nns1 + 1 +r2 = dim * nns1 +c1 = (dim - 1) * nns2 + 1 +c2 = dim * nns2 +DO ips = 1, nips + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + & + & realval(ips) * & + & OUTERPROD(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips)) +END DO +DEALLOCATE (realval) +END PROCEDURE ElasticNitscheMatrix3h + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Matrix3 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 new file mode 100644 index 000000000..73d82b6a7 --- /dev/null +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 @@ -0,0 +1,137 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ElasticNitscheMatrix_Method) MatrixNormal +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! ElasticityNitscheMatrixNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrixNormal1a +REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i +REAL(DFP) :: dd(3, 3) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +realval = trial%Ws * trial%Js * trial%Thickness +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +ans = 0.0_DFP + +DO ips = 1, nips + dd(1:nsd, 1:nsd) = & + & lambda(ips) * realval(ips) & + & * Eye3(1:nsd, 1:nsd) & + & + 2.0 * mu(ips) * realval(ips) & + & * OUTERPROD(a=trial%normal(1:nsd, ips), & + & b=trial%normal(1:nsd, ips)) + + ff = OUTERPROD( & + & test%N(1:nns1, ips), & + & RESHAPE( & + & MATMUL( & + & trial%dNdXt(1:nns2, 1:nsd, ips), & + & dd(1:nsd, 1:nsd) & + & ), & + & [nsd * nns2] & + & ) & + & ) + + r1 = 0; r2 = 0 + DO i = 1, nsd + r1 = r2 + 1; r2 = i * nns1 + ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff + END DO +END DO + +DEALLOCATE (realval, ff) + +END PROCEDURE ElasticNitscheMatrixNormal1a + +!---------------------------------------------------------------------------- +! ElasticityNitscheMatrixNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrixNormal1b +REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i +REAL(DFP) :: dd(3, 3) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = trial%refElem%nsd +ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +realval = trial%Ws * trial%Js * trial%Thickness +ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +ans = 0.0_DFP + +DO ips = 1, nips + dd(1:nsd, 1:nsd) = & + & lambda * realval(ips) & + & * Eye3(1:nsd, 1:nsd) & + & + 2.0 * mu * realval(ips) & + & * OUTERPROD(a=trial%normal(1:nsd, ips), & + & b=trial%normal(1:nsd, ips)) + + ff = OUTERPROD( & + & test%N(1:nns1, ips), & + & RESHAPE( & + & MATMUL( & + & trial%dNdXt(1:nns2, 1:nsd, ips), & + & dd(1:nsd, 1:nsd) & + & ), & + & [nsd * nns2] & + & ) & + & ) + + r1 = 0; r2 = 0 + DO i = 1, nsd + r1 = r2 + 1; r2 = i * nns1 + ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff + END DO +END DO + +DEALLOCATE (realval, ff) + +END PROCEDURE ElasticNitscheMatrixNormal1b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElasticNitscheMatrixNormal1c +REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:) +CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda) +CALL getInterpolation(obj=trial, interpol=muBar, val=mu) +ans = ElasticNitscheMatrixNormal( & +& test=test, trial=trial, lambda=lamBar, mu=muBar) +DEALLOCATE (lamBar, muBar) +END PROCEDURE ElasticNitscheMatrixNormal1c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE MatrixNormal diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 new file mode 100644 index 000000000..677cb68ab --- /dev/null +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 @@ -0,0 +1,132 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ElasticNitscheMatrix_Method) MatrixTangent +USE BaseMethod +IMPLICIT NONE + +CONTAINS +! +! !---------------------------------------------------------------------------- +! ! ElasticityNitscheMatrixTangent +! !---------------------------------------------------------------------------- +! +! MODULE PROCEDURE ElasticNitscheMatrixTangent1a +! REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +! INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i +! REAL(DFP) :: dd(3, 3), s(3) +! +! nns1 = SIZE(test%N, 1) +! nns2 = SIZE(trial%N, 1) +! nips = SIZE(trial%N, 2) +! nsd = trial%refElem%nsd +! ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +! realval = trial%Ws * trial%Js * trial%Thickness +! ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +! ans = 0.0_DFP +! +! DO ips = 1, nips +! dd(1:nsd, 1:nsd) = & +! & 2.0 * mu(ips) * realval(ips) & +! & * OUTERPROD(a=trial%normal(1:nsd, ips), & +! & b=trial%normal(1:nsd, ips)) +! +! ff = OUTERPROD( & +! & test%N(1:nns1, ips), & +! & RESHAPE( & +! & MATMUL( & +! & trial%dNdXt(1:nns2, 1:nsd, ips), & +! & dd(1:nsd, 1:nsd) & +! & ), & +! & [nsd * nns2] & +! & ) & +! & ) +! +! r1 = 0; r2 = 0 +! DO i = 1, nsd +! r1 = r2 + 1; r2 = i * nns1 +! ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff +! END DO +! END DO +! +! DEALLOCATE (realval, ff) +! +! END PROCEDURE ElasticNitscheMatrixTangent1a +! +! !---------------------------------------------------------------------------- +! ! ElasticityNitscheMatrixTangent +! !---------------------------------------------------------------------------- +! +! MODULE PROCEDURE ElasticNitscheMatrixTangent1b +! REAL(DFP), ALLOCATABLE :: realval(:), ff(:, :) +! INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i +! REAL(DFP) :: dd(3, 3) +! +! nns1 = SIZE(test%N, 1) +! nns2 = SIZE(trial%N, 1) +! nips = SIZE(trial%N, 2) +! nsd = trial%refElem%nsd +! ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) +! realval = trial%Ws * trial%Js * trial%Thickness +! ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) +! ans = 0.0_DFP +! +! DO ips = 1, nips +! dd(1:nsd, 1:nsd) = & +! & 2.0 * mu * realval(ips) & +! & * OUTERPROD(a=trial%normal(1:nsd, ips), & +! & b=trial%normal(1:nsd, ips)) +! +! ff = OUTERPROD( & +! & test%N(1:nns1, ips), & +! & RESHAPE( & +! & MATMUL( & +! & trial%dNdXt(1:nns2, 1:nsd, ips), & +! & dd(1:nsd, 1:nsd) & +! & ), & +! & [nsd * nns2] & +! & ) & +! & ) +! +! r1 = 0; r2 = 0 +! DO i = 1, nsd +! r1 = r2 + 1; r2 = i * nns1 +! ans(r1:r2, :) = ans(r1:r2, :) + trial%normal(i, ips) * ff +! END DO +! END DO +! +! DEALLOCATE (realval, ff) +! +! END PROCEDURE ElasticNitscheMatrixTangent1b +! +! !---------------------------------------------------------------------------- +! ! +! !---------------------------------------------------------------------------- +! +! MODULE PROCEDURE ElasticNitscheMatrixTangent1c +! REAL(DFP), ALLOCATABLE :: muBar(:) +! CALL getInterpolation(obj=trial, interpol=muBar, val=mu) +! ans = ElasticNitscheMatrixTangent( & +! & test=test, trial=trial, mu=muBar) +! DEALLOCATE (muBar) +! END PROCEDURE ElasticNitscheMatrixTangent1c +! +! !---------------------------------------------------------------------------- +! ! +! !---------------------------------------------------------------------------- +! +END SUBMODULE MatrixTangent diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt new file mode 100644 index 000000000..ca148d457 --- /dev/null +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -0,0 +1,63 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/ElemshapeData_ConstructorMethods@Methods.F90 + ${src_path}/ElemshapeData_DivergenceMethods@Methods.F90 + ${src_path}/ElemshapeData_GetMethods@Methods.F90 + ${src_path}/ElemshapeData_GradientMethods@Methods.F90 + + ${src_path}/H1/ElemshapeData_H1Methods@HermitMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 + + ${src_path}/DG/ElemshapeData_DGMethods@HermitMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 + + ${src_path}/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 + + ${src_path}/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 + + ${src_path}/ElemshapeData_HminHmaxMethods@Methods.F90 + ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90 + ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90 + ${src_path}/ElemshapeData_InterpolMethods@Methods.F90 + ${src_path}/ElemshapeData_IOMethods@Methods.F90 + ${src_path}/ElemshapeData_LocalDivergenceMethods@Methods.F90 + ${src_path}/ElemshapeData_LocalGradientMethods@Methods.F90 + ${src_path}/ElemshapeData_ProjectionMethods@Methods.F90 + ${src_path}/ElemshapeData_SetMethods@Methods.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods@SUGN3.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 + ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90 +) diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 new file mode 100644 index 000000000..837582c82 --- /dev/null +++ b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_DGMethods) HermitMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DG_Hermit1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="DG_Hermit1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE DG_Hermit1 + +END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 new file mode 100644 index 000000000..6bbaaf471 --- /dev/null +++ b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_DGMethods) HierarchyMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DG_Hierarchy1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="DG_Hierarchy1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE DG_Hierarchy1 + +END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 new file mode 100644 index 000000000..498e21a3c --- /dev/null +++ b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_DGMethods) LagrangeMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DG_Lagrange1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="DG_Lagrange1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE DG_Lagrange1 + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 new file mode 100644 index 000000000..895c90a5b --- /dev/null +++ b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_DGMethods) OrthogonalMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DG_Orthogonal1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="DG_Orthogonal1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE DG_Orthogonal1 + +END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 new file mode 100644 index 000000000..64b93834d --- /dev/null +++ b/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 @@ -0,0 +1,35 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_DGMethods) SerendipityMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DG_Serendipity1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="DG_Serendipity1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE DG_Serendipity1 + +END SUBMODULE SerendipityMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 new file mode 100755 index 000000000..6c88af6d2 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 @@ -0,0 +1,362 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 4 March 2021 +! summary: Constructor method for ElemshapeData_ and STElemshapeData_ + +SUBMODULE(ElemshapeData_ConstructorMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Allocate +CALL reallocate(obj%N, nns, nips) +CALL reallocate(obj%dNdXi, nns, xidim, nips) +CALL reallocate(obj%Normal, 3, nips) +CALL reallocate(obj%dNdXt, nns, nsd, nips) +CALL reallocate(obj%Jacobian, nsd, xidim, nips) +CALL reallocate(obj%Js, nips) +CALL reallocate(obj%Thickness, nips) +obj%Thickness = 1.0_DFP +CALL reallocate(obj%Coord, nsd, nips) +END PROCEDURE elemsd_Allocate + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Initiate1 + +CALL ErrorMSG( & + & Msg="[WORK IN PROGRESS]", & + & File=__FILE__, & + & Routine="elemsd_Initiate1()", & + & Line=__LINE__, & + & UnitNo=stdout) +STOP + +! SELECT CASE (TRIM(interpolType)//TRIM(continuityType)) +! CASE ("LagrangeInterpolation"//"H1") +! CALL Initiate( & +! & obj=obj, & +! & quad=quad, & +! & refElem=refElem, & +! & continuityType=TypeH1, & +! & interpolType=TypeLagrangeInterpolation) +! +! CASE ("LagrangeInterpolation"//"HDiv") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: LagrangeInterpolation & +! & BaseContinuityType: HDiv", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("LagrangeInterpolation"//"HCurl") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: LagrangeInterpolation & +! & BaseContinuityType: HCurl", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("LagrangeInterpolation"//"DG") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: LagrangeInterpolation & +! & BaseContinuityType: DG", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HermitInterpolation"//"H1") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HermitInterpolation & +! & BaseContinuityType: H1", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HermitInterpolation"//"HDiv") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HermitInterpolation & +! & BaseContinuityType: HDiv", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HermitInterpolation"//"HCurl") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HermitInterpolation & +! & BaseContinuityType: HCurl", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HermitInterpolation"//"DG") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HermitInterpolation & +! & BaseContinuityType: DG", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("SerendipityInterpolation"//"H1") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: SerendipityInterpolation & +! & BaseContinuityType: H1", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("SerendipityInterpolation"//"HDiv") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: SerendipityInterpolation & +! & BaseContinuityType: HDiv", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("SerendipityInterpolation"//"HCurl") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: SerendipityInterpolation & +! & BaseContinuityType: HCurl", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("SerendipityInterpolation"//"DG") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: SerendipityInterpolation & +! & BaseContinuityType: DG", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HierarchyInterpolation"//"H1") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HierarchyInterpolation & +! & BaseContinuityType: H1", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HierarchyInterpolation"//"HDiv") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HierarchyInterpolation & +! & BaseContinuityType: HDiv", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HierarchyInterpolation"//"HCurl") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HierarchyInterpolation & +! & BaseContinuityType: HCurl", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE ("HierarchyInterpolation"//"DG") +! CALL ErrorMSG( & +! & Msg="BaseInterpolation: HierarchyInterpolation & +! & BaseContinuityType: DG", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! STOP +! +! CASE DEFAULT +! CALL ErrorMSG( & +! & Msg="Unknown child name of BaseInterpolation & +! & and BaseContinuityType", & +! & File="ElemshapeData_Method@Constructor.F90", & +! & Routine="elemsd_Initiate1()", & +! & Line=__LINE__, & +! & UnitNo=stdout) +! END SELECT + +END PROCEDURE elemsd_Initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_initiate2 +IF (ALLOCATED(obj2%N)) obj1%N = obj2%N +IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi +IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian +IF (ALLOCATED(obj2%js)) obj1%js = obj2%js +IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws +IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt +IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness +IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord +IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal +obj1%refElem = obj2%refElem +END PROCEDURE elemsd_initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_initiate3 +IF (ALLOCATED(obj2%N)) obj1%N = obj2%N +IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi +IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian +IF (ALLOCATED(obj2%js)) obj1%js = obj2%js +IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws +IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt +IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness +IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord +IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal +obj1%refElem = obj2%refElem +END PROCEDURE elemsd_initiate3 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_initiate4 +IF (ALLOCATED(obj2%N)) obj1%N = obj2%N +IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi +IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian +IF (ALLOCATED(obj2%js)) obj1%js = obj2%js +IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws +IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt +IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness +IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord +IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal +obj1%refElem = obj2%refElem +END PROCEDURE elemsd_initiate4 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_initiate5 +IF (ALLOCATED(obj2%N)) obj1%N = obj2%N +IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi +IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian +IF (ALLOCATED(obj2%js)) obj1%js = obj2%js +IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws +IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt +IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness +IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord +IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal +obj1%refElem = obj2%refElem +obj1%wt = obj2%wt +obj1%theta = obj2%theta +obj1%jt = obj2%jt +IF (ALLOCATED(obj2%T)) obj1%T = obj2%T +IF (ALLOCATED(obj2%dTdTheta)) obj1%dTdTheta = obj2%dTdTheta +IF (ALLOCATED(obj2%dNTdt)) obj1%dNTdt = obj2%dNTdt +IF (ALLOCATED(obj2%dNTdXt)) obj1%dNTdXt = obj2%dNTdXt +END PROCEDURE elemsd_initiate5 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE stsd_initiate +INTEGER(I4B) :: tip, ip +REAL(DFP) :: x(3) + +tip = SIZE(elemsd%N, 2) +IF (ALLOCATED(obj)) THEN + DO ip = 1, SIZE(obj) + CALL DEALLOCATE (obj(ip)) + END DO + DEALLOCATE (obj) +END IF + +ALLOCATE (obj(tip)) +DO ip = 1, tip + obj(ip)%T = elemsd%N(:, ip) + obj(ip)%dTdTheta = elemsd%dNdXi(:, 1, ip) + obj(ip)%Jt = elemsd%Js(ip) + CALL getQuadraturePoints( & + & obj=elemsd%quad, & + & weights=obj(ip)%wt,& + & points=x, & + & num=ip) + obj(ip)%theta = x(1) +END DO +END PROCEDURE stsd_initiate + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Deallocate +IF (ALLOCATED(obj%Normal)) DEALLOCATE (obj%Normal) +IF (ALLOCATED(obj%N)) DEALLOCATE (obj%N) +IF (ALLOCATED(obj%dNdXi)) DEALLOCATE (obj%dNdXi) +IF (ALLOCATED(obj%dNdXt)) DEALLOCATE (obj%dNdXt) +IF (ALLOCATED(obj%Jacobian)) DEALLOCATE (obj%Jacobian) +IF (ALLOCATED(obj%Js)) DEALLOCATE (obj%Js) +IF (ALLOCATED(obj%Ws)) DEALLOCATE (obj%Ws) +IF (ALLOCATED(obj%Thickness)) DEALLOCATE (obj%Thickness) +IF (ALLOCATED(obj%Coord)) DEALLOCATE (obj%Coord) +CALL DEALLOCATE (obj%Quad) +CALL DEALLOCATE (obj%refelem) +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + IF (ALLOCATED(obj%T)) DEALLOCATE (obj%T) + IF (ALLOCATED(obj%dTdTheta)) DEALLOCATE (obj%dTdTheta) + IF (ALLOCATED(obj%dNTdt)) DEALLOCATE (obj%dNTdt) + IF (ALLOCATED(obj%dNTdXt)) DEALLOCATE (obj%dNTdXt) +END SELECT +END PROCEDURE elemsd_Deallocate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 new file mode 100644 index 000000000..7f245d9b9 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 @@ -0,0 +1,205 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_DivergenceMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_1 +lg = Contraction(a1=TRANSPOSE(val), a2=obj%dNdXt) +END PROCEDURE elemsd_getDivergence_1 + +!---------------------------------------------------------------------------- +! getDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_2 +REAL(DFP), ALLOCATABLE :: r3(:, :, :) +!! main +SELECT TYPE (obj) +TYPE IS (STElemshapeData_) + CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1) + lg = Contraction(r3, obj%dNTdXt) + DEALLOCATE (r3) +END SELECT +END PROCEDURE elemsd_getDivergence_2 + +!---------------------------------------------------------------------------- +! getDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_3 +SELECT CASE (val%varType) +CASE (constant) + CALL reallocate(lg, SIZE(obj%N, 2)) +CASE (space) + CALL getDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getDivergence_3 + +!---------------------------------------------------------------------------- +! getDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_4 +INTEGER(I4B) :: ii, n +!! +n = SIZE(obj%N, 2) +CALL reallocate(lg, SIZE(val, 1), n) +DO ii = 1, n + lg(:, ii) = contraction(val, TRANSPOSE(obj%dNdXt(:, :, ii))) +END DO +END PROCEDURE elemsd_getDivergence_4 + +!---------------------------------------------------------------------------- +! getDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_5 +REAL(DFP), ALLOCATABLE :: r4(:, :, :, :) +INTEGER(I4B) :: ii +!! +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + CALL SWAP(a=r4, b=val, i1=3, i2=4, i3=2, i4=1) + CALL Reallocate(lg, size(obj%N, 2), size(val, 1)) + DO ii = 1, SIZE(r4, 4) + lg(:, ii) = Contraction(a1=r4(:, :, :, ii), a2=obj%dNTdXt) + END DO + lg = TRANSPOSE(lg) + Deallocate (r4) +END SELECT +!! +END PROCEDURE elemsd_getDivergence_5 + +!---------------------------------------------------------------------------- +! getDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_6 +INTEGER(I4B) :: s(2) +!! +SELECT CASE (val%varType) +CASE (constant) + s = SHAPE(val) + CALL reallocate(lg, s(1), SIZE(obj%N, 2)) +CASE (space) + CALL getDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getDivergence_6 + +!---------------------------------------------------------------------------- +! getDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_7 +REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :) +!! +SELECT CASE (val%rank) +CASE (vector) + CALL getDivergence(obj=obj, lg=r1, val=val) + lg = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace) + DEALLOCATE (r1) +CASE (matrix) + CALL getDivergence(obj=obj, lg=r2, val=val) + lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) +END SELECT +END PROCEDURE elemsd_getDivergence_7 + +!---------------------------------------------------------------------------- +! Divergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getDivergence_8 +REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :) +INTEGER(I4B) :: ii +!! +SELECT CASE (val%rank) +!! +!! vector +!! +CASE (vector) + DO ii = 1, SIZE(obj) + CALL getDivergence(obj=obj(ii), lg=r1, val=val) + IF (.NOT. ALLOCATED(r2)) THEN + CALL reallocate(r2, SIZE(r1, 1), SIZE(obj)) + END IF + !! + r2(:, ii) = r1 + END DO + lg = QuadratureVariable(r2, typeFEVariableScalar,& + & typeFEVariableSpaceTime) + DEALLOCATE (r2, r1) +!! +!! matrix +!! +CASE (matrix) + DO ii = 1, SIZE(obj) + CALL getDivergence(obj=obj(ii), lg=r2, val=val) + IF (.NOT. ALLOCATED(r3)) THEN + CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) + END IF + !! + r3(:, :, ii) = r2 + END DO + lg = QuadratureVariable(r3, typeFEVariableVector,& + & typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) +END SELECT +END PROCEDURE elemsd_getDivergence_8 + +!---------------------------------------------------------------------------- +! Divergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Divergence_1 +CALL getDivergence(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_Divergence_1 + +!---------------------------------------------------------------------------- +! Divergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Divergence_2 +CALL getDivergence(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_Divergence_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 new file mode 100644 index 000000000..15a59dba9 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 @@ -0,0 +1,95 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_GetMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getnormal_1 +IF (PRESENT(nsd)) THEN + normal = obj%normal(1:nsd, :) +ELSE + normal = obj%normal +END IF +END PROCEDURE elemsd_GetNormal_1 + +!---------------------------------------------------------------------------- +! getNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getnormal_2 +IF (PRESENT(nsd)) THEN + normal = QuadratureVariable(obj%normal(1:nsd, :), & + & TypeFEVariableVector, & + & TypeFEVariableSpace) +ELSE + normal = QuadratureVariable(obj%normal, & + & TypeFEVariableVector, & + & TypeFEVariableSpace) +END IF +END PROCEDURE elemsd_getnormal_2 + +!---------------------------------------------------------------------------- +! getNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getnormal_3 + !! +REAL(DFP), ALLOCATABLE :: m3(:, :, :) +INTEGER(I4B) :: ii + !! +IF (PRESENT(nsd)) THEN + !! + CALL Reallocate(m3, & + & nsd, & + & SIZE(obj(1)%normal, 2), & + & SIZE(obj)) + !! + DO ii = 1, SIZE(obj) + m3(1:nsd, :, ii) = obj(ii)%normal(1:nsd, :) + END DO + !! +ELSE + !! + CALL Reallocate(m3, & + & SIZE(obj(1)%normal, 1), & + & SIZE(obj(1)%normal, 2), & + & SIZE(obj)) + !! + DO ii = 1, SIZE(obj) + m3(:, :, ii) = obj(ii)%normal + END DO + !! +END IF + !! +normal = QuadratureVariable(m3, TypeFEVariableVector, & + & TypeFEVariableSpaceTime) + !! +DEALLOCATE (m3) + !! +END PROCEDURE elemsd_getnormal_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 new file mode 100644 index 000000000..62717e546 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 @@ -0,0 +1,284 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemshapeData_GradientMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_1 +IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + lg = MATMUL(Val, obj%dNdXt) +ELSE + CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) +END IF +END PROCEDURE elemsd_getSpatialGradient_1 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_2 +IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + lg = MATMUL(Val, obj%dNdXt) +ELSE + CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, & + & SIZE(obj%N, 2)) +END IF +END PROCEDURE elemsd_getSpatialGradient_2 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_3 +SELECT TYPE (obj) +TYPE IS (STElemshapeData_) + IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + lg = Contraction(val, obj%dNTdXt) + ELSE + CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) + END IF +END SELECT +END PROCEDURE elemsd_getSpatialGradient_3 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_4 +INTEGER(I4B) :: ii, jj, ips +REAL(DFP), ALLOCATABLE :: r3(:, :, :) + !! +CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, & + & SIZE(obj%N, 2)) + !! +SELECT TYPE (obj) +TYPE IS (STElemshapeData_) + IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1) + DO ips = 1, SIZE(lg, 3) + DO jj = 1, SIZE(lg, 2) + DO ii = 1, SIZE(lg, 1) + lg(ii, jj, ips) = contraction(a1=r3(:, :, ii), & + & a2=obj%dNTdXt(:, :, jj, ips)) + END DO + END DO + END DO + DEALLOCATE (r3) + END IF +END SELECT +END PROCEDURE elemsd_getSpatialGradient_4 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_5 +SELECT CASE (val%varType) +CASE (constant) + CALL reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) +CASE (space) + CALL getSpatialGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE IS (STElemShapeData_) + CALL getSpatialGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getSpatialGradient_5 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_6 +INTEGER(I4B) :: s(1) +SELECT CASE (val%varType) +CASE (constant) + s = SHAPE(val) + CALL reallocate(lg, s(1), obj%refelem%nsd, & + & SIZE(obj%N, 2)) +CASE (space) + CALL getSpatialGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getSpatialGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getSpatialGradient_6 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_7 +IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + lg = MATMUL(Val, obj%dNdXt) +ELSE + CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), & + & obj%refelem%nsd, SIZE(obj%N, 2)) +END IF +END PROCEDURE elemsd_getSpatialGradient_7 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_8 +INTEGER(I4B) :: ii, jj + !! +CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%refelem%nsd, & + & SIZE(obj%N, 2)) +SELECT TYPE (obj) +TYPE IS (STElemshapeData_) + IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + DO jj = 1, SIZE(lg, 4) + DO ii = 1, SIZE(lg, 3) + lg(:, :, ii, jj) = contraction(a1=val, & + & a2=obj%dNTdXt(:, :, ii, jj)) + END DO + END DO + END IF +END SELECT +END PROCEDURE elemsd_getSpatialGradient_8 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_9 +INTEGER(I4B) :: s(2) +SELECT CASE (val%varType) +CASE (constant) + s = SHAPE(val) + CALL reallocate(lg, s(1), s(2), & + & obj%refelem%nsd, SIZE(obj%N, 2)) +CASE (space) + CALL getSpatialGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getSpatialGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getSpatialGradient_9 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_10 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) + !! +SELECT CASE (val%rank) +CASE (scalar) + CALL getSpatialGradient(obj=obj, lg=r2, val=val) + lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) +CASE (vector) + CALL getSpatialGradient(obj=obj, lg=r3, val=val) + lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r3) +CASE (matrix) + !! BUG Implement gradient of matrix + !! TODO Extend FEVariable to support r3, which is necessary to keep + !! the gradient of rank02 tensors +END SELECT +END PROCEDURE elemsd_getSpatialGradient_10 + +!---------------------------------------------------------------------------- +! getSpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSpatialGradient_11 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) +INTEGER(I4B) :: ii + !! +SELECT CASE (val%rank) + !! + !! scalar + !! +CASE (scalar) + DO ii = 1, SIZE(obj) + CALL getSpatialGradient(obj=obj(ii), lg=r2, val=val) + IF (.NOT. ALLOCATED(r3)) THEN + CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) + END IF + !! + r3(:, :, ii) = r2(:, :) + END DO + lg = QuadratureVariable(r3, typeFEVariableVector,& + & typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) + !! + !! vector + !! +CASE (vector) + DO ii = 1, SIZE(obj) + CALL getSpatialGradient(obj=obj(ii), lg=r3, val=val) + IF (.NOT. ALLOCATED(r4)) THEN + CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) + END IF + !! + r4(:, :, :, ii) = r3(:, :, :) + END DO + lg = QuadratureVariable(r4, typeFEVariableMatrix,& + & typeFEVariableSpaceTime) + DEALLOCATE (r3, r4) + !! + !! matrix TODO + !! +CASE (matrix) + !! BUG Implement gradient of matrix + !! TODO Extend FEVariable to support r3, which is necessary to keep + !! the gradient of rank02 tensors +END SELECT +END PROCEDURE elemsd_getSpatialGradient_11 + +!---------------------------------------------------------------------------- +! SpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SpatialGradient_1 +CALL getSpatialGradient(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_SpatialGradient_1 + +!---------------------------------------------------------------------------- +! SpatialGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SpatialGradient_2 +CALL getSpatialGradient(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_SpatialGradient_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 new file mode 100644 index 000000000..97ba604d5 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 @@ -0,0 +1,217 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HRGNParamMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getHRGNParam +!---------------------------------------------------------------------------- + +PURE SUBROUTINE elemsd_getHRGNParam_a(obj, h, val, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! define internal variables + !! + INTEGER(I4B) :: ii + REAL(DFP) :: areal + REAL(DFP), ALLOCATABLE :: q(:, :), hmin(:), hmax(:) + !! rdNdXt; (I,ips) => projection of dNdXt on unit normal + TYPE(FEVariable_) :: rvar + !! vector variable for keeping r + !! + !! Main + !! + CALL Reallocate(h, SIZE(obj%N, 2)) + !! + !! Get unitNormal in q + !! + CALL GetUnitNormal(obj=obj, val=val, r=q) + !! + !! Convert unit normal to [[FEVariable_]] + !! + rvar = QuadratureVariable(q, TypeFEVariableVector, TypeFEVariableSpace) + !! + !! Call get projection of dNdXt in q + !! + CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) + !! + !! Calculate hmin and hmax + !! + CALL GetHminHmax(obj=obj, hmax=hmax, hmin=hmin) + !! + DO ii = 1, SIZE(h) + areal = SUM(ABS(q(:, ii))) + IF (areal.APPROXEQ.zero) THEN + h(ii) = hmin(ii) + ELSE + h(ii) = 2.0_DFP / areal + END IF + END DO + !! + IF (ALLOCATED(q)) DEALLOCATE (q) + IF (ALLOCATED(hmin)) DEALLOCATE (hmin) + IF (ALLOCATED(hmax)) DEALLOCATE (hmax) + CALL DEALLOCATE (rvar) + !! +END SUBROUTINE elemsd_getHRGNParam_a + +!---------------------------------------------------------------------------- +! getHRGNParam +!---------------------------------------------------------------------------- + +PURE SUBROUTINE elemsd_getHRGNParam_b(obj, h, val, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: h(:) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! internal variables + !! + INTEGER(I4B) :: ii + REAL(DFP) :: areal + REAL(DFP), ALLOCATABLE :: r(:, :), hmin(:), hmax(:) + REAL(DFP), ALLOCATABLE :: q(:, :, :) + !! rdNTdXt; (I,a,ips)m => projection of dNTdXt on unit normal + TYPE(FEVariable_) :: rvar + !! + !! main + !! + CALL Reallocate(h, SIZE(obj%N, 2)) + !! + !! Get unitNormal in r + !! + CALL GetUnitNormal(obj=obj, val=val, r=r) + !! + !! Make [[FEVariable_]] + !! + rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) + !! + !! Get Projection of dNTdXt in q + !! + CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar) + !! + !! Calculate hmin and hmax + !! + CALL GetHminHmax(obj=obj, hmax=hmax, hmin=hmin) + !! + DO ii = 1, SIZE(h, 1) + areal = SUM(ABS(q(:, :, ii))) + IF (areal.APPROXEQ.zero) THEN + h(ii) = hmin(ii) + ELSE + h(ii) = 2.0_DFP / areal + END IF + END DO + !! + IF (ALLOCATED(r)) DEALLOCATE (r) + IF (ALLOCATED(q)) DEALLOCATE (q) + CALL DEALLOCATE (rvar) + !! +END SUBROUTINE elemsd_getHRGNParam_b + +!---------------------------------------------------------------------------- +! getHRGNParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getHRGNParam1 +SELECT TYPE (obj) +!! +TYPE IS (ElemshapeData_) + !! + CALL elemsd_getHRGNParam_a( & + & obj=obj, & + & h=h, & + & val=val, & + & opt=opt) + !! +CLASS IS (STElemshapeData_) + !! + CALL elemsd_getHRGNParam_b( & + & obj=obj, & + & h=h, & + & val=val, & + & opt=opt) + !! +END SELECT +END PROCEDURE elemsd_getHRGNParam1 + +!---------------------------------------------------------------------------- +! getHRGNParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHRGNParam2 +REAL(DFP), ALLOCATABLE :: ans(:) +!! +CALL GetHRGNParam(obj=obj, h=ans, val=val, opt=opt) +h = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) +IF (ALLOCATED(ans)) DEALLOCATE (ans) +!! +END PROCEDURE elemsd_GetHRGNParam2 + +!---------------------------------------------------------------------------- +! getHRGNParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHRGNParam3 +INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: avec(:) +!! +!! main +!! +CALL Reallocate(h, SIZE(obj(1)%N, 2), SIZE(obj)) +!! +DO ii = 1, SIZE(obj) + CALL GetHRGNParam( & + & obj=obj(ii), & + & h=avec, & + & val=val, & + & opt=opt) + !! + h(:, ii) = avec(:) +END DO +!! +IF (ALLOCATED(avec)) DEALLOCATE (avec) +END PROCEDURE elemsd_GetHRGNParam3 + +!---------------------------------------------------------------------------- +! getHRGNParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHRGNParam4 +REAL(DFP), ALLOCATABLE :: ans(:, :) +!! +CALL GetHRGNParam(obj=obj, h=ans, val=val, opt=opt) +!! +h = QuadratureVariable( & + & ans, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +IF (ALLOCATED(ans)) DEALLOCATE (ans) +END PROCEDURE elemsd_GetHRGNParam4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 new file mode 100644 index 000000000..915f5b7f5 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 @@ -0,0 +1,664 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HRQIParamMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getHRQIParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getHRQIParam1 +INTEGER(I4B) :: ii, nips, nsd +REAL(DFP), ALLOCATABLE :: r0(:, :) +!! unitNormal (nsd, nips) +REAL(DFP), ALLOCATABLE :: G(:, :, :) +!! shape is (nsd, nsd, nips), it contains inverse of FFT +REAL(DFP), ALLOCATABLE :: FFT(:, :) +!! (nsd, nsd) +REAL(DFP), ALLOCATABLE :: rr(:, :) +!! outer product of unitNormal (nsd, nsd) +REAL(DFP) :: areal +LOGICAL(LGT) :: ismin, ismax +!! +!! Main +!! +nips = SIZE(obj%N, 2) +nsd = obj%refelem%nsd +CALL Reallocate(h, nips) +CALL Reallocate(G, nsd, nsd, nips) +CALL Reallocate(FFT, nsd, nsd) +!! +!! hmax +!! +IF (PRESENT(hmax)) THEN + CALL Reallocate(hmax, nips) + ismax = .TRUE. +ELSE + ismax = .FALSE. +END IF +!! +!! hmin +!! +IF (PRESENT(hmin)) THEN + CALL Reallocate(hmin, nips) + ismin = .TRUE. +ELSE + ismin = .FALSE. +END IF +!! +!! r and unitNormal +!! +CALL GetUnitNormal(obj=obj, val=val, r=r0) +IF (PRESENT(r)) r = r0 +!! +!! FFT and G +!! +DO ii = 1, nips + !! + FFT = MATMUL(obj%jacobian(:, :, ii), & + & TRANSPOSE(obj%jacobian(:, :, ii))) + !! + CALL Inv(invA=G(:, :, ii), A=FFT) + !! + rr = OUTERPROD(a=r0(1:nsd, ii), b=r0(1:nsd, ii)) + !! + areal = Contraction(a1=G(:, :, ii), a2=rr) + !! + IF (areal.APPROXEQ.zero) THEN + h(ii) = 0.0_DFP + ELSE + h(ii) = 2.0_DFP / SQRT(areal) + END IF + !! +END DO +!! +!! reset FFT to reuse it +!! +FFT = 0.0_DFP; r0 = 0.0_DFP +!! +IF (ismin .OR. ismax) THEN + DO ii = 1, nips + r0(:, ii) = SymEigenValuesUpto3(G(:, :, ii)) + END DO +END IF +!! +IF (ismax) THEN + DO ii = 1, nips + hmax(ii) = 2.0_DFP / SQRT(MINVAL(r0(:, ii))) + END DO +END IF +!! +IF (ismin) THEN + DO ii = 1, nips + hmin(ii) = 2.0_DFP / SQRT(MAXVAL(r0(:, ii))) + END DO +END IF +!! +DEALLOCATE (r0, G, FFT, rr) +END PROCEDURE elemsd_getHRQIParam1 + +!---------------------------------------------------------------------------- +! getHRQIParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHRQIParam2 + !! +INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: h0(:), hmax0(:), hmin0(:), r0(:, :) +CHARACTER(LEN=3) :: cod + !! + !! main + !! +cod = "FFF" + !! +IF (PRESENT(hmax)) THEN + cod(1:1) = "T" +END IF + !! +IF (PRESENT(hmin)) THEN + cod(2:2) = "T" +END IF + !! +IF (PRESENT(r)) THEN + cod(3:3) = "T" +END IF + !! +SELECT CASE (cod) +CASE ("FFF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + !! +CASE ("TFF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + !! +CASE ("FTF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmin=hmin0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + !! +CASE ("TTF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & hmin=hmin0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + !! +CASE ("FFT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) + !! +CASE ("TFT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) + !! +CASE ("FTT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmin=hmin0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) + !! +CASE ("TTT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & hmin=hmin0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable(h0, TypeFEVariableScalar, TypeFEVariableSpace) + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) + r = QuadratureVariable(r0, TypeFEVariableVector, TypeFEVariableSpace) + !! +END SELECT + !! +IF (ALLOCATED(h0)) DEALLOCATE (h0) +IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) +IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) +IF (ALLOCATED(r0)) DEALLOCATE (r0) + !! +END PROCEDURE elemsd_GetHRQIParam2 + +!---------------------------------------------------------------------------- +! getHRQIParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHRQIParam3 + !! +INTEGER(I4B) :: ii, nips, nipt, nsd +REAL(DFP), ALLOCATABLE :: h0(:), hmax0(:), hmin0(:), r0(:, :) +CHARACTER(LEN=3) :: cod + !! + !! main + !! +nips = SIZE(obj(1)%N, 2) +nipt = SIZE(obj) +nsd = obj(1)%refelem%nsd + !! +CALL Reallocate(h, nips, nipt) + !! +cod = "FFF" + !! +IF (PRESENT(hmax)) THEN + CALL Reallocate(hmax, nips, nipt) + cod(1:1) = "T" +END IF + !! +IF (PRESENT(hmin)) THEN + CALL Reallocate(hmin, nips, nipt) + cod(2:2) = "T" +END IF + !! +IF (PRESENT(r)) THEN + CALL Reallocate(r, nsd, nips, nipt) + cod(3:3) = "T" +END IF + !! +SELECT CASE (cod) +CASE ("FFF") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + !! + END DO + !! +CASE ("TFF") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & hmax=hmax0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + hmax(:, ii) = hmax0(:) + !! + END DO + !! +CASE ("FTF") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & hmin=hmin0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + hmin(:, ii) = hmin0(:) + !! + END DO + !! +CASE ("TTF") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & hmax=hmax0, & + & hmin=hmin0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + hmax(:, ii) = hmax0(:) + hmin(:, ii) = hmin0(:) + !! + END DO + !! +CASE ("FFT") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + r(:, :, ii) = r0(:, :) + !! + END DO + !! +CASE ("TFT") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & hmax=hmax0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + hmax(:, ii) = hmax0(:) + r(:, :, ii) = r0(:, :) + !! + END DO + !! +CASE ("FTT") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & hmin=hmin0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + hmin(:, ii) = hmin0(:) + r(:, :, ii) = r0(:, :) + !! + END DO + !! +CASE ("TTT") + !! + DO ii = 1, SIZE(obj) + !! + CALL GetHRQIParam( & + & obj=obj(ii), & + & h=h0, & + & hmax=hmax0, & + & hmin=hmin0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h(:, ii) = h0(:) + hmax(:, ii) = hmax0(:) + hmin(:, ii) = hmin0(:) + r(:, :, ii) = r0(:, :) + !! + END DO + !! +END SELECT + !! +IF (ALLOCATED(h0)) DEALLOCATE (h0) +IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) +IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) +IF (ALLOCATED(r0)) DEALLOCATE (r0) + !! +END PROCEDURE elemsd_GetHRQIParam3 + +!---------------------------------------------------------------------------- +! getHRQIParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHRQIParam4 + !! +REAL(DFP), ALLOCATABLE :: h0(:, :), hmax0(:, :), hmin0(:, :), & + & r0(:, :, :) +CHARACTER(LEN=3) :: cod + !! + !! main + !! +cod = "FFF" + !! +IF (PRESENT(hmax)) THEN + cod(1:1) = "T" +END IF + !! +IF (PRESENT(hmin)) THEN + cod(2:2) = "T" +END IF + !! +IF (PRESENT(r)) THEN + cod(3:3) = "T" +END IF + !! +SELECT CASE (cod) +CASE ("FFF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + !! +CASE ("TFF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + hmax = QuadratureVariable( & + & hmax0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! +CASE ("FTF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmin=hmin0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + hmin = QuadratureVariable( & + & hmin0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! +CASE ("TTF") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & hmin=hmin0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + hmax = QuadratureVariable( & + & hmax0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + hmin = QuadratureVariable( & + & hmin0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! +CASE ("FFT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + r = QuadratureVariable( & + & r0, & + & TypeFEVariableVector, & + & TypeFEVariableSpaceTime) + !! +CASE ("TFT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + hmax = QuadratureVariable( & + & hmax0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + r = QuadratureVariable( & + & r0, & + & TypeFEVariableVector, & + & TypeFEVariableSpaceTime) + !! +CASE ("FTT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmin=hmin0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + hmin = QuadratureVariable( & + & hmin0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + r = QuadratureVariable( & + & r0, & + & TypeFEVariableVector, & + & TypeFEVariableSpaceTime) + !! +CASE ("TTT") + !! + CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & hmax=hmax0, & + & hmin=hmin0, & + & r=r0, & + & val=val, & + & opt=opt) + !! + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + hmin = QuadratureVariable( & + & hmin0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + !! + hmax = QuadratureVariable( & + & hmax0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + r = QuadratureVariable( & + & r0, & + & TypeFEVariableVector, & + & TypeFEVariableSpaceTime) + !! +END SELECT + !! +IF (ALLOCATED(h0)) DEALLOCATE (h0) +IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) +IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) +IF (ALLOCATED(r0)) DEALLOCATE (r0) + !! +END PROCEDURE elemsd_GetHRQIParam4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 new file mode 100644 index 000000000..3828c6c28 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 @@ -0,0 +1,216 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HminHmaxMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetHminHmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax1 +INTEGER(I4B) :: ii, nips, nsd +REAL(DFP), ALLOCATABLE :: G(:, :), w(:) +!! shape is (nsd, nsd, nips), it contains inverse of FFT +REAL(DFP) :: areal +!! +!! Main +!! +nips = SIZE(obj%N, 2) +nsd = obj%refelem%nsd +!! +CALL Reallocate(G, nsd, nsd) +CALL Reallocate(w, nsd) +CALL Reallocate(hmax, nips, hmin, nips) +!! +!! FFT and G +!! +DO ii = 1, nips + !! + CALL Inv(invA=G, A=MATMUL(obj%jacobian(:, :, ii), & + & TRANSPOSE(obj%jacobian(:, :, ii)))) + !! + w = SymEigenValuesUpto3(G) + !! + hmax(ii) = 2.0_DFP / SQRT(MINVAL(w)) + hmin(ii) = 2.0_DFP / SQRT(MAXVAL(w)) +END DO +!! +DEALLOCATE (w, G) +!! +END PROCEDURE elemsd_GetHminHmax1 + +!---------------------------------------------------------------------------- +! GetHminHmax +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax2 +INTEGER(I4B) :: ii, nips, nsd +REAL(DFP), ALLOCATABLE :: w(:) +!! shape is (nsd, nsd, nips), it contains inverse of FFT +!! +!! Main +!! +nips = SIZE(obj%N, 2) +nsd = obj%refelem%nsd +!! +CALL Reallocate(w, nsd) +CALL Reallocate(hmax, nips, hmin, nips) +!! +!! FFT and G +!! +DO ii = 1, nips + w = SymEigenValuesUpto3(G(:, :, ii)) + hmax(ii) = 2.0_DFP / SQRT(MINVAL(w)) + hmin(ii) = 2.0_DFP / SQRT(MAXVAL(w)) +END DO +!! +DEALLOCATE (w) +!! +END PROCEDURE elemsd_GetHminHmax2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax3 +REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) +!! +CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0) +!! +hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END PROCEDURE elemsd_GetHminHmax3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax6 +REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) +!! +CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0, G=G) +!! +hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END PROCEDURE elemsd_GetHminHmax6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax4 +INTEGER(I4B) :: ii, nips, nipt +REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) +!! +nips = SIZE(obj(1)%N, 2) +nipt = SIZE(obj) +!! +CALL Reallocate(hmax, nips, nipt) +CALL Reallocate(hmin, nips, nipt) +!! +DO ii = 1, SIZE(obj) + CALL GetHminHmax(obj=obj(ii), hmax=hmax0, hmin=hmin0) + hmax(:, ii) = hmax0(:) + hmin(:, ii) = hmin0(:) +END DO +!! +IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) +IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) +END PROCEDURE elemsd_GetHminHmax4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax7 +INTEGER(I4B) :: ii, nips, nipt +REAL(DFP), ALLOCATABLE :: hmax0(:), hmin0(:) +!! +nips = SIZE(obj(1)%N, 2) +nipt = SIZE(obj) +!! +CALL Reallocate(hmax, nips, nipt) +CALL Reallocate(hmin, nips, nipt) +!! +DO ii = 1, SIZE(obj) + CALL GetHminHmax(obj=obj(ii), hmax=hmax0, hmin=hmin0, G=G(:, :, :, ii)) + hmax(:, ii) = hmax0(:) + hmin(:, ii) = hmin0(:) +END DO +!! +IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) +IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) +END PROCEDURE elemsd_GetHminHmax7 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax5 +REAL(DFP), ALLOCATABLE :: hmax0(:, :), hmin0(:, :) +!! +CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0) +!! +hmin = QuadratureVariable( & + & hmin0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +hmax = QuadratureVariable( & + & hmax0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) +IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) +END PROCEDURE elemsd_GetHminHmax5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetHminHmax8 +REAL(DFP), ALLOCATABLE :: hmax0(:, :), hmin0(:, :) +!! +CALL GetHminHmax(obj=obj, hmax=hmax0, hmin=hmin0, G=G) +!! +hmin = QuadratureVariable( & + & hmin0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +hmax = QuadratureVariable( & + & hmax0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +IF (ALLOCATED(hmax0)) DEALLOCATE (hmax0) +IF (ALLOCATED(hmin0)) DEALLOCATE (hmin0) +END PROCEDURE elemsd_GetHminHmax8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 new file mode 100644 index 000000000..9b91a6d5a --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 @@ -0,0 +1,270 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 4 March 2021 +! summary: Methods for IO of [[elemshapedata_]] and [[stelemshapedata_]] + +SUBMODULE(ElemshapeData_IOMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElemshapeData_ReactEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElemshapeData_ReactEncode + +END PROCEDURE ElemshapeData_ReactEncode + +!---------------------------------------------------------------------------- +! ElemshapeData_MdEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElemshapeData_MdEncode +INTEGER(I4B) :: ii +TYPE(String), ALLOCATABLE :: rh(:), ch(:) + +ans = MdEncode(obj%quad)//CHAR_LF2 + +IF (ALLOCATED(obj%N)) THEN + CALL Reallocate(rh, SIZE(obj%N, 1)) + CALL Reallocate(ch, SIZE(obj%N, 2)) + DO ii = 1, SIZE(obj%N, 1) + rh(ii) = "$N_{"//tostring(ii)//"}$" + END DO + DO ii = 1, SIZE(obj%N, 2) + ch(ii) = "$ips_{"//tostring(ii)//"}$" + END DO + ans = ans//"**N**"//CHAR_LF2//MdEncode(val=obj%N, rh=rh, ch=ch)//CHAR_LF2 +ELSE + ans = ans//"**N Not ALLOCATED**"//CHAR_LF2 +END IF + +IF (ALLOCATED(obj%dNdXi)) THEN + CALL Reallocate(rh, SIZE(obj%dNdXi, 1)) + CALL Reallocate(ch, SIZE(obj%dNdXi, 2)) + DO ii = 1, SIZE(obj%dNdXi, 1) + rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial \xi}$" + END DO + DO ii = 1, SIZE(obj%dNdXi, 2) + ch(ii) = "$\frac{\partial N}{\partial \xi_{"//tostring(ii)//"}}$" + END DO + DO ii = 1, SIZE(obj%dNdXi, 3) + ans = ans//"**dNdXi(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & + & MdEncode(val=obj%dNdXi(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 + END DO +ELSE + ans = ans//"**dNdXi Not ALLOCATED**"//CHAR_LF2 +END IF + +IF (ALLOCATED(obj%dNdXt)) THEN + CALL Reallocate(rh, SIZE(obj%dNdXt, 1)) + CALL Reallocate(ch, SIZE(obj%dNdXt, 2)) + DO ii = 1, SIZE(obj%dNdXt, 1) + rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial x}$" + END DO + DO ii = 1, SIZE(obj%dNdXt, 2) + ch(ii) = "$\frac{\partial N}{\partial {x}_{"//tostring(ii)//"}}$" + END DO + DO ii = 1, SIZE(obj%dNdXt, 3) + ans = ans//"**dNdXt(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & + & MdEncode(val=obj%dNdXt(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 + END DO +ELSE + ans = ans//"**dNdXt Not ALLOCATED**"//CHAR_LF2 +END IF + +IF (ALLOCATED(obj%jacobian)) THEN + CALL Reallocate(rh, SIZE(obj%jacobian, 1)) + CALL Reallocate(ch, SIZE(obj%jacobian, 2)) + DO ii = 1, SIZE(obj%jacobian, 1) + rh(ii) = "row-"//tostring(ii) + END DO + DO ii = 1, SIZE(obj%jacobian, 2) + ch(ii) = "col-"//tostring(ii) + END DO + DO ii = 1, SIZE(obj%jacobian, 3) + ans = ans//"**jacobian(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & + & MdEncode(val=obj%jacobian(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 + END DO +ELSE + ans = ans//"**jacobian Not ALLOCATED**"//CHAR_LF2 +END IF + +IF (ALLOCATED(obj%js)) THEN + CALL Reallocate(rh, 1) + CALL Reallocate(ch, SIZE(obj%js, 1)) + rh(1) = "js" + DO ii = 1, SIZE(obj%js, 1) + ch(ii) = "$js_{"//tostring(ii)//"}$" + END DO + ans = ans//"**Js**"//CHAR_LF2//MdEncode(val=obj%js, rh=rh, ch=ch)//CHAR_LF2 +ELSE + ans = ans//"**js Not ALLOCATED**"//CHAR_LF2 +END IF + +IF (ALLOCATED(obj%thickness)) THEN + CALL Reallocate(rh, 1) + CALL Reallocate(ch, SIZE(obj%thickness, 1)) + rh(1) = "thickness" + DO ii = 1, SIZE(obj%thickness, 1) + ch(ii) = "thickness${}_{"//tostring(ii)//"}$" + END DO + ans = ans//"**thickness**"//CHAR_LF2// & + & MdEncode(val=obj%thickness, rh=rh, ch=ch)//CHAR_LF2 +ELSE + ans = ans//"**thickness Not ALLOCATED**"//CHAR_LF2 +END IF + +IF (ALLOCATED(obj%normal)) THEN + CALL Reallocate(rh, SIZE(obj%normal, 1)) + CALL Reallocate(ch, SIZE(obj%normal, 2)) + DO ii = 1, SIZE(obj%normal, 1) + rh(ii) = "$n_{"//tostring(ii)//"}$" + END DO + DO ii = 1, SIZE(obj%normal, 2) + ch(ii) = "$ips_{"//tostring(ii)//"}$" + END DO + ans = ans//"**normal**"//CHAR_LF2// & + & MdEncode(val=obj%normal, rh=rh, ch=ch)//CHAR_LF2 +ELSE + ans = ans//"**normal not ALLOCATED**"//CHAR_LF2 +END IF + +! SELECT TYPE (obj); TYPE IS (STElemShapeData_) +! CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno) +! CALL Display(obj%jt, "# jt: ", unitno=unitno) +! CALL Display(obj%theta, "# theta: ", unitno=unitno) +! CALL Display(obj%wt, "# wt: ", unitno=unitno) +! IF (ALLOCATED(obj%T)) THEN +! CALL Display(obj%T, "# T: ", unitno=unitno) +! ELSE +! CALL Display("# T: NOT ALLOCATED", unitno=unitno) +! END IF +! IF (ALLOCATED(obj%dTdTheta)) THEN +! CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno) +! ELSE +! CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno) +! END IF +! IF (ALLOCATED(obj%dNTdt)) THEN +! CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno) +! ELSE +! CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno) +! END IF +! IF (ALLOCATED(obj%dNTdXt)) THEN +! CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno) +! ELSE +! CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno) +! END IF +! END SELECT +END PROCEDURE ElemshapeData_MdEncode + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_display_1 +CALL Display(msg, unitno=unitno) +CALL Display("# SHAPE FUNCTION IN SPACE: ", unitno=unitno) +CALL Display(obj%Quad, "# Quadrature Point: ", unitno=unitno) +IF (ALLOCATED(obj%N)) THEN + CALL Display(obj%N, "# N: ", unitno) +ELSE + CALL Display("# N: NOT ALLOCATED", unitno) +END IF +IF (ALLOCATED(obj%dNdXi)) THEN + CALL Display(obj%dNdXi, "# dNdXi: ", unitno) +ELSE + CALL Display("# dNdXi: NOT ALLOCATED", unitno) +END IF +IF (ALLOCATED(obj%dNdXt)) THEN + CALL Display(obj%dNdXt, "# dNdXt: ", unitno) +ELSE + CALL Display("# dNdXt: NOT ALLOCATED", unitno) +END IF +IF (ALLOCATED(obj%jacobian)) THEN + CALL Display(obj%Jacobian, "# jacobian: ", unitno) +ELSE + CALL Display("# jacobian: NOT ALLOCATED", unitno) +END IF +IF (ALLOCATED(obj%js)) THEN + CALL Display(obj%js, "# js: ", unitno) +ELSE + CALL Display("# js: NOT ALLOCATED", unitno) +END IF +IF (ALLOCATED(obj%thickness)) THEN + CALL Display(obj%thickness, "# thickness: ", unitno) +ELSE + CALL Display("# thickness: NOT ALLOCATED", unitno) +END IF +IF (ALLOCATED(obj%coord)) THEN + CALL Display(obj%coord, "# coord: ", unitno) +ELSE + CALL Display("# coord: NOT ALLOCATED", unitno) +END IF +IF (ALLOCATED(obj%normal)) THEN + CALL Display(obj%normal, "# normal: ", unitno) +ELSE + CALL Display("# normal: NOT ALLOCATED", unitno) +END IF +SELECT TYPE (obj); TYPE IS (STElemShapeData_) + CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno) + CALL Display(obj%jt, "# jt: ", unitno=unitno) + CALL Display(obj%theta, "# theta: ", unitno=unitno) + CALL Display(obj%wt, "# wt: ", unitno=unitno) + IF (ALLOCATED(obj%T)) THEN + CALL Display(obj%T, "# T: ", unitno=unitno) + ELSE + CALL Display("# T: NOT ALLOCATED", unitno=unitno) + END IF + IF (ALLOCATED(obj%dTdTheta)) THEN + CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno) + ELSE + CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno) + END IF + IF (ALLOCATED(obj%dNTdt)) THEN + CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno) + ELSE + CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno) + END IF + IF (ALLOCATED(obj%dNTdXt)) THEN + CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno) + ELSE + CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno) + END IF +END SELECT +END PROCEDURE elemsd_display_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_display_2 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(obj) + CALL Display(obj=obj(ii), msg=TRIM(msg)//"("//tostring(ii)//"): ", & + & unitno=unitno) +END DO +END PROCEDURE elemsd_display_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 new file mode 100644 index 000000000..3b6cc592c --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -0,0 +1,594 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_InterpolMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalar_getinterpolation_1 +interpol = MATMUL(val, obj%N) +END PROCEDURE scalar_getinterpolation_1 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalar_getinterpolation_5 +INTEGER(I4B) :: ii +! REAL(DFP), ALLOCATABLE :: m1(:) +! !! main +! CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj)) +! DO ii = 1, SIZE(obj) +! CALL getInterpolation(obj=obj(ii), interpol=m1, val=val) +! interpol(:, ii) = m1 +! END DO +! DEALLOCATE (m1) +CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj)) +!! +SELECT CASE (val%vartype) +!! +!! +!! +!! +CASE (Constant) + !! + interpol = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) +!! +!! +!! +!! +CASE (Space) + !! + IF (val%DefineOn .EQ. Nodal) THEN + !! + DO ii = 1, SIZE(obj) + interpol(:, ii) = Interpolation(obj(ii), & + & Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) + END DO + !! + ELSE + !! + interpol(:, 1) = Get(val, TypeFEVariableScalar, TypeFEVariableSpace) + !! + DO ii = 2, SIZE(obj) + interpol(:, ii) = interpol(:, 1) + END DO + !! + END IF +!! +!! +!! +!! +CASE (SpaceTime) + !! + IF (val%DefineOn .EQ. Nodal) THEN + !! + DO ii = 1, SIZE(obj) + interpol(:, ii) = STinterpolation(obj(ii), & + & Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) + END DO + !! + ELSE + interpol = Get(val, TypeFEVariableScalar, typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT +!! +END PROCEDURE scalar_getinterpolation_5 + +!--------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation_1 +interpol = MATMUL(val, obj%N) +END PROCEDURE vector_getinterpolation_1 + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation_2 +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + interpol = MATMUL(MATMUL(val, obj%T), obj%N) +END SELECT +END PROCEDURE vector_getinterpolation_2 + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation_3 +INTEGER(I4B) :: ipt +!! +CALL reallocate(interpol, SIZE(val, 1), SIZE(obj(1)%N, 2), SIZE(obj)) +DO ipt = 1, SIZE(obj) + interpol(:, :, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N) +END DO +END PROCEDURE vector_getinterpolation_3 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation_1 +interpol = MATMUL(val, obj%N) +END PROCEDURE matrix_getinterpolation_1 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +END PROCEDURE master_getinterpolation_1 + +!---------------------------------------------------------------------------- +! getInterpolation +!---------------------------------------------------------------------------- + +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 +!! +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) +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_LocalDivergenceMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 new file mode 100644 index 000000000..3f1743805 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_LocalDivergenceMethods@Methods.F90 @@ -0,0 +1,200 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_LocalDivergenceMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getLocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalDivergence_1 +lg = Contraction(a1=TRANSPOSE(val), a2=obj%dNdXi) +END PROCEDURE elemsd_getLocalDivergence_1 + +!---------------------------------------------------------------------------- +! getLocalDivergence +!----------------------------------------------------------------------------z + +MODULE PROCEDURE elemsd_getLocalDivergence_2 +SELECT TYPE (obj) +TYPE IS (STElemshapeData_) + lg = Contraction(a1=TRANSPOSE(MATMUL(Val, obj%T)), & + & a2=obj%dNdXi) +END SELECT +END PROCEDURE elemsd_getLocalDivergence_2 + +!---------------------------------------------------------------------------- +! getLocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalDivergence_3 +SELECT CASE (val%varType) +CASE (constant) + CALL reallocate(lg, SIZE(obj%N, 2)) +CASE (space) + CALL getLocalDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getLocalDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getLocalDivergence_3 + +!---------------------------------------------------------------------------- +! getLocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalDivergence_4 +INTEGER(I4B) :: ii, n +n = SIZE(obj%N, 2) +CALL reallocate(lg, SIZE(val, 1), n) +DO ii = 1, n + lg(:, ii) = contraction(val, TRANSPOSE(obj%dNdXi(:, :, ii))) +END DO +END PROCEDURE elemsd_getLocalDivergence_4 + +!---------------------------------------------------------------------------- +! getLocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalDivergence_5 +INTEGER(I4B) :: ii, n +REAL(DFP), ALLOCATABLE :: r3(:, :, :) +!! +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + n = SIZE(obj%N, 2) + CALL reallocate(lg, SIZE(val, 1), n) + r3 = MATMUL(val, obj%T) + DO ii = 1, n + lg(:, ii) = contraction(r3, TRANSPOSE(obj%dNdXi(:, :, ii))) + END DO +END SELECT +!! +IF (ALLOCATED(r3)) DEALLOCATE (r3) +END PROCEDURE elemsd_getLocalDivergence_5 + +!---------------------------------------------------------------------------- +! getLocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalDivergence_6 +INTEGER(I4B) :: s(2) +SELECT CASE (val%varType) +CASE (constant) + s = SHAPE(val) + CALL reallocate(lg, s(1), SIZE(obj%N, 2)) +CASE (space) + CALL getLocalDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getLocalDivergence(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getLocalDivergence_6 + +!---------------------------------------------------------------------------- +! getLocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalDivergence_7 +REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :) +!! +SELECT CASE (val%rank) +CASE (vector) + CALL getLocalDivergence(obj=obj, lg=r1, val=val) + lg = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace) + DEALLOCATE (r1) +CASE (matrix) + CALL getLocalDivergence(obj=obj, lg=r2, val=val) + lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) +END SELECT +END PROCEDURE elemsd_getLocalDivergence_7 + +!---------------------------------------------------------------------------- +! LocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalDivergence_8 +REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :) +INTEGER(I4B) :: ii +!! +SELECT CASE (val%rank) +!! +!! vector +!! +CASE (vector) + DO ii = 1, SIZE(obj) + CALL getLocalDivergence(obj=obj(ii), lg=r1, val=val) + IF (.NOT. ALLOCATED(r2)) THEN + CALL reallocate(r2, SIZE(r1, 1), SIZE(obj)) + END IF + !! + r2(:, ii) = r1 + END DO + lg = QuadratureVariable(r2, typeFEVariableScalar,& + & typeFEVariableSpaceTime) + DEALLOCATE (r2, r1) +!! +!! matrix +!! +CASE (matrix) + DO ii = 1, SIZE(obj) + CALL getLocalDivergence(obj=obj(ii), lg=r2, val=val) + IF (.NOT. ALLOCATED(r3)) THEN + CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) + END IF + !! + r3(:, :, ii) = r2 + END DO + lg = QuadratureVariable(r3, typeFEVariableVector,& + & typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) +END SELECT +END PROCEDURE elemsd_getLocalDivergence_8 + +!---------------------------------------------------------------------------- +! LocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_LocalDivergence_1 +CALL getLocalDivergence(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_LocalDivergence_1 + +!---------------------------------------------------------------------------- +! LocalDivergence +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_LocalDivergence_2 +CALL getLocalDivergence(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_LocalDivergence_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 new file mode 100644 index 000000000..82ee7c65f --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 @@ -0,0 +1,244 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_LocalGradientMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_1 +lg = MATMUL(Val, obj%dNdXi) +!! matmul r1 r3 +END PROCEDURE elemsd_getLocalGradient_1 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_2 +lg = MATMUL(Val, obj%dNdXi) +!! matmul r2 r3 +END PROCEDURE elemsd_getLocalGradient_2 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_3 +SELECT TYPE (obj) +TYPE IS (STElemshapeData_) + lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) + !! matmul r1 r3 +END SELECT +END PROCEDURE elemsd_getLocalGradient_3 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_4 +SELECT TYPE (obj) +TYPE IS (STElemshapeData_) + lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) + !! (r3.r1).r3 => r2.r3 +END SELECT +END PROCEDURE elemsd_getLocalGradient_4 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_5 +SELECT CASE (val%varType) +CASE (constant) + CALL reallocate(lg, obj%refelem%xidimension, SIZE(obj%N, 2)) +CASE (space) + CALL getLocalGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getLocalGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getLocalGradient_5 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_6 +INTEGER(I4B) :: s(1) +!! +SELECT CASE (val%varType) +CASE (constant) + s = SHAPE(val) + CALL reallocate(lg, s(1), obj%refelem%xidimension, SIZE(obj%N, 2)) +CASE (space) + CALL getLocalGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getLocalGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getLocalGradient_6 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_7 +lg = MATMUL(val, obj%dNdXi) +!! r3.r4 +END PROCEDURE elemsd_getLocalGradient_7 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_8 +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) + !! (r4.r1).r3 +END SELECT +END PROCEDURE elemsd_getLocalGradient_8 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_9 +INTEGER(I4B) :: s(2) +SELECT CASE (val%varType) +CASE (constant) + s = SHAPE(val) + CALL reallocate(lg, s(1), s(2), & + & obj%refelem%xidimension, SIZE(obj%N, 2)) +CASE (space) + CALL getLocalGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) +CASE (spacetime) + SELECT TYPE (obj) + TYPE is (STElemShapeData_) + CALL getLocalGradient(obj=obj, lg=lg, & + & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) + END SELECT +END SELECT +END PROCEDURE elemsd_getLocalGradient_9 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_10 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) +!! +SELECT CASE (val%rank) +CASE (scalar) + CALL getLocalGradient(obj=obj, lg=r2, val=val) + lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) +CASE (vector) + CALL getLocalGradient(obj=obj, lg=r3, val=val) + lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r3) +CASE (matrix) + !! BUG Implement gradient of matrix + !! TODO Extend FEVariable to support r3, which is necessary to keep + !! the gradient of rank02 tensors +END SELECT +END PROCEDURE elemsd_getLocalGradient_10 + +!---------------------------------------------------------------------------- +! getLocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getLocalGradient_11 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) +INTEGER(I4B) :: ii +!! +SELECT CASE (val%rank) +!! +!! scalar +!! +CASE (scalar) + DO ii = 1, SIZE(obj) + CALL getLocalGradient(obj=obj(ii), lg=r2, val=val) + IF (.NOT. ALLOCATED(r3)) THEN + CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) + END IF + !! + r3(:, :, ii) = r2(:, :) + END DO + lg = QuadratureVariable(r3, typeFEVariableVector,& + & typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) +!! +!! vector +!! +CASE (vector) + DO ii = 1, SIZE(obj) + CALL getLocalGradient(obj=obj(ii), lg=r3, val=val) + IF (.NOT. ALLOCATED(r4)) THEN + CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) + END IF + !! + r4(:, :, :, ii) = r3(:, :, :) + END DO + lg = QuadratureVariable(r4, typeFEVariableMatrix,& + & typeFEVariableSpaceTime) + DEALLOCATE (r3, r4) +!! +!! matrix TODO +!! +CASE (matrix) + !! BUG Implement gradient of matrix + !! TODO Extend FEVariable to support r3, which is necessary to keep + !! the gradient of rank02 tensors +END SELECT +END PROCEDURE elemsd_getLocalGradient_11 + +!---------------------------------------------------------------------------- +! LocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_LocalGradient_1 +CALL getLocalGradient(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_LocalGradient_1 + +!---------------------------------------------------------------------------- +! LocalGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_LocalGradient_2 +CALL getLocalGradient(obj=obj, lg=ans, val=val) +END PROCEDURE elemsd_LocalGradient_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 new file mode 100644 index 000000000..2998cf756 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -0,0 +1,167 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_ProjectionMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! getProjectionOfdNdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getProjectionOfdNdXt_2 +INTEGER(I4B) :: ii, nsd +REAL(DFP), ALLOCATABLE :: cbar(:, :) + !! + !! main + !! +CALL getInterpolation(obj=obj, val=val, interpol=cbar) +CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3)) +nsd = SIZE(obj%dNdXt, 2) +DO ii = 1, SIZE(cdNdXt, 2) + cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), cbar(1:nsd, ii)) +END DO + !! +DEALLOCATE (cbar) + !! +END PROCEDURE getProjectionOfdNdXt_2 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! getProjectionOfdNTdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getProjectionOfdNTdXt_1 +INTEGER(I4B) :: ii, nsd + !! + !! main + !! +CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & + & SIZE(obj%dNTdXt, 4)) +nsd = SIZE(obj%dNTdXt, 3) + !! +DO ii = 1, SIZE(cdNTdXt, 3) + cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), Val(1:nsd)) +END DO + !! +END PROCEDURE getProjectionOfdNTdXt_1 + +!---------------------------------------------------------------------------- +! getProjectionOfdNTdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getProjectionOfdNTdXt_2 + !! +INTEGER(I4B) :: ii, nsd +REAL(DFP), ALLOCATABLE :: cbar(:, :) + !! + !! main + !! +CALL getInterpolation(obj=obj, val=val, interpol=cbar) +CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & + & SIZE(obj%dNTdXt, 4)) +nsd = SIZE(obj%dNTdXt, 3) + !! +DO ii = 1, SIZE(cdNTdXt, 3) + cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), cbar(1:nsd, ii)) +END DO + !! +DEALLOCATE (cbar) +END PROCEDURE getProjectionOfdNTdXt_2 + +!---------------------------------------------------------------------------- +! getProjectionOfdNTdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getProjectionOfdNTdXt_3 + !! +INTEGER(I4B) :: ii, jj, nsd +REAL(DFP), ALLOCATABLE :: cbar(:, :, :) + !! + !! main + !! +CALL getInterpolation(obj=obj, val=val, interpol=cbar) + !! +CALL Reallocate(cdNTdXt, & + & SIZE(obj(1)%dNTdXt, 1), & + & SIZE(obj(1)%dNTdXt, 2), & + & SIZE(obj(1)%dNTdXt, 4), SIZE(obj)) + !! +! CALL Reallocate( & +! & cdNTdXt, & +! & SIZE(obj(1)%N, 1), & +! & SIZE(obj(1)%T), & +! & SIZE(obj(1)%N, 2), & +! & SIZE(obj) ) + !! +nsd = SIZE(obj(1)%dNTdXt, 3) + !! +DO jj = 1, SIZE(cbar, 3) + DO ii = 1, SIZE(cbar, 2) + !! + cdNTdXt(:, :, ii, jj) = MATMUL( & + & obj(jj)%dNTdXt(:, :, :, ii), & + & cbar(1:nsd, ii, jj)) + !! + END DO +END DO + !! +DEALLOCATE (cbar) + !! +END PROCEDURE getProjectionOfdNTdXt_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 new file mode 100644 index 000000000..2353d3d0f --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -0,0 +1,285 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_SetMethods) Methods +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! SetThickness +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SetThickness +obj%Thickness = MATMUL(val, N) +END PROCEDURE elemsd_SetThickness + +!---------------------------------------------------------------------------- +! SetThickness +!---------------------------------------------------------------------------- + +MODULE PROCEDURE stsd_SetThickness +CALL SetThickness(obj=obj, val=MATMUL(val, T), N=N) +END PROCEDURE stsd_SetThickness + +!---------------------------------------------------------------------------- +! SetBarycentricCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SetBarycentricCoord +obj%Coord = MATMUL(val, N) +END PROCEDURE elemsd_SetBarycentricCoord + +!---------------------------------------------------------------------------- +! SetBarycentricCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE stsd_SetBarycentricCoord +CALL SetBarycentricCoord(obj=obj, val=MATMUL(val, T), N=N) +END PROCEDURE stsd_SetBarycentricCoord + +!---------------------------------------------------------------------------- +! SetJs +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SetJs +! Define internal variable +INTEGER(I4B) :: xidim, nsd, nips, ips +REAL(DFP) :: aa, bb, ab +! +xidim = obj%RefElem%XiDimension +nsd = obj%RefElem%nsd +nips = SIZE(obj%N, 2) +! +DO ips = 1, nips + IF (nsd .EQ. xidim) THEN + obj%Js(ips) = det(obj%Jacobian(:, :, ips)) + ELSE IF (xidim .EQ. 1 .AND. xidim .NE. nsd) THEN + obj%Js(ips) = & + & SQRT(DOT_PRODUCT(obj%Jacobian(:, 1, ips), & + & obj%Jacobian(:, 1, ips))) + ELSE IF (xidim .EQ. 2 .AND. xidim .NE. nsd) THEN + aa = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 1, ips)) + bb = DOT_PRODUCT(obj%Jacobian(:, 2, ips), obj%Jacobian(:, 2, ips)) + ab = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 2, ips)) + obj%Js(ips) = SQRT(aa * bb - ab * ab) + END IF +END DO +END PROCEDURE elemsd_SetJs + +!---------------------------------------------------------------------------- +! SetdNdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SetdNdXt +! Define internal variables +INTEGER(I4B) :: NSD, XiDim, ips, nips +REAL(DFP), ALLOCATABLE :: InvJacobian(:, :, :) + +NSD = obj%RefElem%NSD +XiDim = obj%RefElem%XiDimension +IF (NSD .NE. XiDim) THEN + obj%dNdXt = 0.0_DFP +ELSE + ! Compute inverse of Jacobian + nips = SIZE(obj%N, 2) + ALLOCATE (InvJacobian(NSD, NSD, nips)) + CALL Inv(InvA=InvJacobian, A=obj%Jacobian) + DO ips = 1, nips + obj%dNdXt(:, :, ips) = & + & MATMUL(obj%dNdXi(:, :, ips), InvJacobian(:, :, ips)) + END DO + DEALLOCATE (InvJacobian) +END IF +END PROCEDURE elemsd_SetdNdXt + +!---------------------------------------------------------------------------- +! SetJacobian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SetJacobian +obj%jacobian = MATMUL(val, dNdXi) +END PROCEDURE elemsd_SetJacobian + +!---------------------------------------------------------------------------- +! SetJacobian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE stsd_SetJacobian +obj%jacobian = MATMUL(MATMUL(val, T), dNdXi) +END PROCEDURE stsd_SetJacobian + +!---------------------------------------------------------------------------- +! SetdNTdt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE stsd_SetdNTdt +REAL(DFP), ALLOCATABLE :: v(:, :) +INTEGER(I4B) :: ip + +! get mesh velocity at space integration points +v = MATMUL(MATMUL(val, obj%dTdTheta / obj%Jt), obj%N) +CALL Reallocate(obj%dNTdt, SIZE(obj%N, 1), SIZE(obj%T), & + & SIZE(obj%N, 2)) +DO ip = 1, SIZE(obj%N, 2) + obj%dNTdt(:, :, ip) = OUTERPROD(obj%N(:, ip), obj%dTdTheta / obj%Jt) & + & - MATMUL(obj%dNTdXt(:, :, :, ip), v(:, ip)) +END DO +END PROCEDURE stsd_SetdNTdt + +!---------------------------------------------------------------------------- +! SetdNTdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE stsd_SetdNTdXt +! +INTEGER(I4B) :: ip, j +REAL(DFP), ALLOCATABLE :: Q(:, :), Temp(:, :) +! +CALL Reallocate(obj%dNTdXt, SIZE(obj%N, 1), SIZE(obj%T), & + & SIZE(obj%Jacobian, 1), SIZE(obj%N, 2)) +! +IF (obj%RefElem%XiDimension .NE. obj%RefElem%NSD) THEN + RETURN +END IF +! +Q = obj%Jacobian(:, :, 1) +! +DO ip = 1, SIZE(obj%N, 2) + CALL INV(A=obj%Jacobian(:, :, ip), INVA=Q) + Temp = MATMUL(obj%dNdXi(:, :, ip), Q) + DO j = 1, SIZE(Q, 1) + obj%dNTdXt(:, :, j, ip) = OUTERPROD(Temp(:, j), obj%T) + END DO +END DO +! +DEALLOCATE (Q, Temp) +! +END PROCEDURE stsd_SetdNTdXt + +!---------------------------------------------------------------------------- +! SetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Set1 +CALL SetJacobian(obj=obj, val=val, dNdXi=dNdXi) +CALL SetJs(obj=obj) +CALL SetdNdXt(obj=obj) +CALL SetBarycentricCoord(obj=obj, val=val, N=N) +END PROCEDURE elemsd_Set1 + +!---------------------------------------------------------------------------- +! SetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Set2 +INTEGER(I4B), ALLOCATABLE :: facetNptrs(:) + +CALL SetJacobian(obj=cellobj, val=cellVal, dNdXi=celldNdXi) +CALL SetJs(obj=cellobj) +CALL SetdNdXt(obj=cellobj) +CALL SetBarycentricCoord(obj=cellobj, val=cellval, N=cellN) + +facetNptrs = GetConnectivity(facetobj%refelem) + +CALL SetJacobian(obj=facetobj, val=cellVal(:, facetNptrs), & + & dNdXi=facetdNdXi) +CALL SetJs(obj=facetobj) +CALL SetBarycentricCoord(obj=facetobj, val=cellval(:, facetNptrs), & + & 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 + +! I am copying normal Js from facet to cell +! In this way, we can use cellobj to construct the element matrix + +cellobj%normal = facetobj%normal +cellobj%Js = facetobj%Js +cellobj%Ws = facetobj%Ws + +IF (ALLOCATED(facetNptrs)) DEALLOCATE (facetNptrs) +END PROCEDURE elemsd_Set2 + +!---------------------------------------------------------------------------- +! SetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_Set3 +! +CALL Set( & + & facetobj=masterFacetObj, & + & cellobj=masterCellObj, & + & cellVal=masterCellVal, & + & cellN=masterCellN, & + & celldNdXi=masterCelldNdXi, & + & facetN=masterFacetN, & + & facetdNdXi=masterFacetdNdXi) +! +CALL Set( & + & facetobj=slaveFacetObj, & + & cellobj=slaveCellObj, & + & cellVal=slaveCellVal, & + & cellN=slaveCellN, & + & celldNdXi=slaveCelldNdXi, & + & facetN=slaveFacetN, & + & facetdNdXi=slaveFacetdNdXi) +! +END PROCEDURE elemsd_Set3 + +!---------------------------------------------------------------------------- +! SetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE stelemsd_Set1 +CALL SetJacobian(obj=obj, val=val, dNdXi=dNdXi, T=T) +CALL SetJs(obj=obj) +CALL SetdNdXt(obj=obj) +CALL SetBarycentricCoord(obj=obj, val=val, N=N, T=T) +CALL SetdNTdXt(obj=obj) +CALL SetdNTdt(obj=obj, val=val) +END PROCEDURE stelemsd_Set1 + +!---------------------------------------------------------------------------- +! SetNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_SetNormal +REAL(DFP) :: vec(3, 3) +INTEGER(I4B) :: i, xidim, nsd +vec = 0.0_DFP +vec(3, 2) = 1.0_DFP +xidim = obj%RefElem%XiDimension +nsd = obj%refElem%nsd +DO i = 1, SIZE(obj%N, 2) + Vec(1:nsd, 1:xidim) = obj%Jacobian(1:nsd, 1:xidim, i) + obj%Normal(:, i) = & + & VectorProduct(Vec(:, 1), Vec(:, 2)) / obj%Js(i) +END DO +END PROCEDURE elemsd_SetNormal + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 new file mode 100644 index 000000000..a9bda718e --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 @@ -0,0 +1,147 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_StabilizationParamMethods) SUGN3 +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getSUGN3Param +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_1 +REAL(DFP), ALLOCATABLE :: h0(:), nubar(:) +INTEGER(I4B) :: ii +!! +CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) +!! +IF (PRESENT(h)) THEN + h = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +!! +CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +!! +DO ii = 1, SIZE(h0) + h0(ii) = h0(ii)**2 / nubar(ii) / 4.0_DFP +END DO +!! +tau = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +!! +DEALLOCATE (h0, nubar) +END PROCEDURE elemsd_GetSUGN3Param_1 + +!---------------------------------------------------------------------------- +! getSUGN3Param +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_2 +INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: h0(:, :), nubar(:, :) +!! +!! main +!! +CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) +!! +IF (PRESENT(h)) THEN + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +!! +CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +!! +DO ii = 1, SIZE(obj) + h0(:, ii) = h0(:, ii)**2 / nubar(:, ii) / 4.0_DFP +END DO +!! +tau = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +IF (ALLOCATED(h0)) DEALLOCATE (h0) +IF (ALLOCATED(nubar)) DEALLOCATE (nubar) +!! +END PROCEDURE elemsd_GetSUGN3Param_2 + +!---------------------------------------------------------------------------- +! getSUGN3Param +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_3 +REAL(DFP), ALLOCATABLE :: h0(:) +INTEGER(I4B) :: ii +!! +CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) +!! +IF (PRESENT(h)) THEN + h = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +!! +DO ii = 1, SIZE(h0) + h0(ii) = h0(ii)**2 / nu / 4.0_DFP +END DO +!! +tau = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +!! +DEALLOCATE (h0) +!! +END PROCEDURE elemsd_GetSUGN3Param_3 + +!---------------------------------------------------------------------------- +! getSUGN3Param +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_4 +INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: h0(:, :) +!! +!! main +!! +CALL GetHRGNParam(obj=obj, h=h0, val=val, opt=opt) +!! +IF (PRESENT(h)) THEN + h = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +!! +DO ii = 1, SIZE(obj) + h0(:, ii) = h0(:, ii)**2 / nu / 4.0_DFP +END DO +!! +tau = QuadratureVariable( & + & h0, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +IF (ALLOCATED(h0)) DEALLOCATE (h0) +!! +END PROCEDURE elemsd_GetSUGN3Param_4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE SUGN3 diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 new file mode 100644 index 000000000..db36aea62 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 @@ -0,0 +1,567 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_StabilizationParamMethods) SUPG +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getSUPGParam +!---------------------------------------------------------------------------- + +PURE SUBROUTINE elemsd_getSUPGParam_a(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! element shape data + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! stabilizing parameters + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + !! vector variable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution + TYPE(FEVariable_), INTENT(IN) :: nu + !! diffusivity coefficient + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k + !! permeability + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi + !! porosity + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time step size + !! default value is zero + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default=1 + !! if opt=1, then we use `SQRT(1.0_DFP / (t1**2 + t2**2 + t3**2 + t4**2))` + !! if opt=2, then we use `1.0_DFP / (t1 + t2 + t3 + t4)` + !! + !! + !! define internal variables + !! + INTEGER(I4B) :: ii, opt0 + REAL(DFP) :: t1, t2, t3, t4 + REAL(DFP), ALLOCATABLE :: p(:, :) + !! cdNdXt + REAL(DFP), ALLOCATABLE :: r(:, :) + !! unit normal + REAL(DFP), ALLOCATABLE :: q(:, :) + !! rdNdXt + REAL(DFP), ALLOCATABLE :: ans(:) + !! result + REAL(DFP), ALLOCATABLE :: nubar(:), kbar(:), phibar(:) + !! value of nu at space quadrature points + TYPE(FEVariable_) :: rvar + !! vector variable for keeping r + !! + !! Main + !! + opt0 = INPUT(default=1_I4B, option=opt) + !! + CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c) + !! + CALL GetUnitNormal(obj=obj, val=val, r=r) + rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) + CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) + !! + CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) + !! + IF (PRESENT(k)) THEN + CALL GetInterpolation(obj=obj, val=k, interpol=kbar) + CALL GetInterpolation(obj=obj, val=phi, interpol=phibar) + ELSE + ALLOCATE (kbar(SIZE(nubar))) + ALLOCATE (phibar(SIZE(nubar))) + kbar = MaxDFP !! very large number + phibar = 1.0_DFP + END IF + !! + t2 = 0.0_DFP + IF (PRESENT(dt)) THEN + IF (dt .GT. zero) t2 = 2.0_DFP / dt + END IF + !! + CALL Reallocate(ans, SIZE(obj%N, 2)) + !! + IF (opt0 .EQ. 1_I4B) THEN + DO ii = 1, SIZE(ans) + t1 = SUM(ABS(p(:, ii))) + t3 = nubar(ii) * (SUM(ABS(q(:, ii))))**2 + t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) + ans(ii) = SQRT(1.0_DFP / (t1**2 + t2**2 + t3**2 + t4**2)) + END DO + ELSE + DO ii = 1, SIZE(ans) + t1 = SUM(ABS(p(:, ii))) + t3 = nubar(ii) * (SUM(ABS(q(:, ii))))**2 + t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) + ans(ii) = 1.0_DFP / (t1 + t2 + t3 + t4) + END DO + END IF + !! + tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) + !! + !! cleanup + IF (ALLOCATED(p)) DEALLOCATE (p) + IF (ALLOCATED(r)) DEALLOCATE (r) + IF (ALLOCATED(q)) DEALLOCATE (q) + IF (ALLOCATED(ans)) DEALLOCATE (ans) + IF (ALLOCATED(nubar)) DEALLOCATE (nubar) + IF (ALLOCATED(kbar)) DEALLOCATE (kbar) + IF (ALLOCATED(phibar)) DEALLOCATE (phibar) + CALL DEALLOCATE (rvar) +END SUBROUTINE elemsd_getSUPGParam_a + +!---------------------------------------------------------------------------- +! getSUPGParam +!---------------------------------------------------------------------------- + +PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj + !! space-time element shape data + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! stabilization parameter + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + !! vector variable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution + !! scalar/vector variable + TYPE(FEVariable_), INTENT(IN) :: nu + !! diffusivity + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: k + !! permeability + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: phi + !! porosity + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time-step size + !! This parameter is not used currently. + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default=1 + !! opt=1, then `ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2))` + !! opt=2, then `ans(ii) = 1.0_DFP / (t12 + t3 + t4)` + !! + !! INTERNAL VARIABLES + !! + INTEGER(I4B) :: ii, opt0 + REAL(DFP) :: t12, t3, t4 + REAL(DFP), ALLOCATABLE :: p(:, :, :) + !! cdNTdxt + REAL(DFP), ALLOCATABLE :: r(:, :) + !! vector at space quad points + REAL(DFP), ALLOCATABLE :: q(:, :, :) + !! + REAL(DFP), ALLOCATABLE :: ans(:) + REAL(DFP), ALLOCATABLE :: nubar(:) + REAL(DFP), ALLOCATABLE :: kbar(:) + REAL(DFP), ALLOCATABLE :: phibar(:) + TYPE(FEVariable_) :: rvar + !! + !! MAIN + !! + opt0 = INPUT(option=opt, default=1_I4B) + !! + CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c) + !! + !! make cdNTdxt + dNTdt + !! + p = p + obj%dNTdt + !! + 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) + !! + IF (PRESENT(k)) THEN + CALL GetInterpolation(obj=obj, val=k, interpol=kbar) + CALL GetInterpolation(obj=obj, val=phi, interpol=phibar) + ELSE + ALLOCATE (kbar(SIZE(nubar))) + ALLOCATE (phibar(SIZE(nubar))) + kbar = MaxDFP !! very large number + phibar = 1.0_DFP + END IF + !! + CALL reallocate(ans, SIZE(obj%N, 2)) + !! + IF (opt0 .EQ. 1_I4B) THEN + DO ii = 1, SIZE(ans, 1) + t12 = SUM(ABS(p(:, :, ii))) + t3 = nubar(ii) * (SUM(ABS(q(:, :, ii))))**2 + t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) + ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2)) + END DO + ELSE + DO ii = 1, SIZE(ans, 1) + t12 = SUM(ABS(p(:, :, ii))) + t3 = nubar(ii) * (SUM(ABS(q(:, :, ii))))**2 + t4 = 2.0_DFP * phibar(ii) * nubar(ii) / kbar(ii) + ans(ii) = 1.0_DFP / (t12 + t3 + t4) + END DO + END IF + !! + tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) + !! + !! cleanup + !! + IF (ALLOCATED(p)) DEALLOCATE (p) + IF (ALLOCATED(r)) DEALLOCATE (r) + IF (ALLOCATED(q)) DEALLOCATE (q) + IF (ALLOCATED(ans)) DEALLOCATE (ans) + IF (ALLOCATED(nubar)) DEALLOCATE (nubar) + IF (ALLOCATED(kbar)) DEALLOCATE (kbar) + IF (ALLOCATED(phibar)) DEALLOCATE (phibar) + CALL DEALLOCATE (rvar) +END SUBROUTINE elemsd_getSUPGParam_b + +!---------------------------------------------------------------------------- +! getSUPGParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSUPGParam1 +SELECT TYPE (obj) +TYPE IS (ElemshapeData_) + !! + CALL elemsd_getSUPGParam_a( & + & obj=obj, & + & tau=tau, & + & c=c, & + & val=val, & + & nu=nu, & + & k=k, & + & phi=phi, & + & dt=dt, & + & opt=opt) + !! +CLASS IS (STElemshapeData_) + !! + CALL elemsd_getSUPGParam_b( & + & obj=obj, & + & tau=tau, & + & c=c, & + & val=val, & + & nu=nu, & + & k=k, & + & phi=phi, & + & dt=dt, & + & opt=opt) + !! +END SELECT +END PROCEDURE elemsd_getSUPGParam1 + +!---------------------------------------------------------------------------- +! GetSUPGParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUPGParam2 +INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: ans(:, :) +TYPE(FEVariable_) :: a +!! +!! main +!! +CALL Reallocate(ans, SIZE(obj(1)%N, 2), SIZE(obj)) +!! +DO ii = 1, SIZE(obj) + !! + CALL elemsd_getSUPGParam_b( & + & obj=obj(ii), & + & tau=a, & + & c=c, & + & val=val, & + & nu=nu, & + & k=k, & + & phi=phi, & + & dt=dt, & + & opt=opt) + !! + ans(:, ii) = Get(a, TypeFEVariableScalar, TypeFEVariableSpace) + !! +END DO +!! +tau = QuadratureVariable( & + & ans, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +!! +CALL DEALLOCATE (a); DEALLOCATE (ans) +END PROCEDURE elemsd_GetSUPGParam2 + +!---------------------------------------------------------------------------- +! getSUPGParam +!---------------------------------------------------------------------------- + +PURE SUBROUTINE elemsd_getSUPGParam_c(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(ElemshapeData_), INTENT(IN) :: obj + !! element shape data + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! stabilizing parameters + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + !! vector variable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution + REAL(DFP), INTENT(IN) :: nu + !! diffusivity coefficient + REAL(DFP), OPTIONAL, INTENT(IN) :: k + !! permeability + REAL(DFP), OPTIONAL, INTENT(IN) :: phi + !! porosity + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time step size + !! default value is zero + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default = 1 + !! opt=1 + !! opt=2 + ! + !! + !! internal variables + !! + INTEGER(I4B) :: ii, opt0 + REAL(DFP) :: t1, t2, t3, t4, kbar, phibar + REAL(DFP), ALLOCATABLE :: p(:, :) + !! cdNdXt + REAL(DFP), ALLOCATABLE :: r(:, :) + !! unit normal + REAL(DFP), ALLOCATABLE :: q(:, :) + !! rdNdXt + REAL(DFP), ALLOCATABLE :: ans(:) + !! result + !! value of nu at space quadrature points + TYPE(FEVariable_) :: rvar + !! vector variable for keeping r + !! + !! MAIN + !! + opt0 = INPUT(default=1_I4B, option=opt) + !! + CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c) + !! + CALL GetUnitNormal(obj=obj, val=val, r=r) + rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) + CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) + !! + IF (PRESENT(k)) THEN + kbar = k + phibar = phi + ELSE + kbar = MaxDFP + phibar = 1.0_DFP + END IF + !! + t2 = 0.0_DFP + IF (PRESENT(dt)) THEN + t2 = 2.0_DFP / dt + END IF + !! + CALL Reallocate(ans, SIZE(obj%N, 2)) + !! + IF (opt0 .EQ. 1_I4B) THEN + DO ii = 1, SIZE(ans) + t1 = SUM(ABS(p(:, ii))) + t3 = nu * (SUM(ABS(q(:, ii))))**2 + t4 = 2.0_DFP * phibar * nu / kbar + ans(ii) = SQRT(1.0_DFP / (t1**2 + t2**2 + t3**2 + t4**2)) + END DO + ELSE + DO ii = 1, SIZE(ans) + t1 = SUM(ABS(p(:, ii))) + t3 = nu * (SUM(ABS(q(:, ii))))**2 + t4 = 2.0_DFP * phibar * nu / kbar + ans(ii) = 1.0_DFP / (t1 + t2 + t3 + t4) + END DO + END IF + !! + tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) + !! + !! cleanup + DEALLOCATE (p, r, q, ans) + CALL DEALLOCATE (rvar) +END SUBROUTINE elemsd_getSUPGParam_c + +!---------------------------------------------------------------------------- +! getSUPGParam +!---------------------------------------------------------------------------- + +PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, & + & phi, dt, opt) + CLASS(STElemshapeData_), INTENT(IN) :: obj + !! space-time element shape data + TYPE(FEVariable_), INTENT(INOUT) :: tau + !! stabilization parameter + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + !! vector variable + TYPE(FEVariable_), INTENT(IN) :: val + !! solution + !! scalar/vector variable + REAL(DFP), INTENT(IN) :: nu + !! diffusivity + REAL(DFP), OPTIONAL, INTENT(IN) :: k + !! permeability + REAL(DFP), OPTIONAL, INTENT(IN) :: phi + !! porosity + REAL(DFP), OPTIONAL, INTENT(IN) :: dt + !! time-step size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! default=1 + !! opt=1, + !! opt=2 + !! + !! INTERNAL VARIABLES + !! + INTEGER(I4B) :: ii, opt0 + REAL(DFP) :: t12, t3, t4, kbar, phibar + REAL(DFP), ALLOCATABLE :: p(:, :, :) + !! cdNTdxt + REAL(DFP), ALLOCATABLE :: r(:, :) + !! vector at space quad points + REAL(DFP), ALLOCATABLE :: q(:, :, :) + !! + REAL(DFP), ALLOCATABLE :: ans(:) + TYPE(FEVariable_) :: rvar + !! + !! MAIN + !! + opt0 = INPUT(default=1_I4B, option=opt) + !! + CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c) + !! + !! make cdNTdxt + dNTdt + !! + p = p + obj%dNTdt + !! + CALL GetUnitNormal(obj=obj, val=val, r=r) + rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) + CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar) + !! + IF (PRESENT(k)) THEN + kbar = k + phibar = phi + ELSE + kbar = MaxDFP + phibar = 1.0_DFP + END IF + !! + !! + CALL reallocate(ans, SIZE(obj%N, 2)) + !! + IF (opt0 .EQ. 1_I4B) THEN + DO ii = 1, SIZE(ans, 1) + t12 = SUM(ABS(p(:, :, ii))) + t3 = nu * (SUM(ABS(q(:, :, ii))))**2 + t4 = 2.0_DFP * phibar * nu / kbar + ans(ii) = SQRT(1.0_DFP / (t12**2 + t3**2 + t4**2)) + END DO + ELSE + DO ii = 1, SIZE(ans, 1) + t12 = SUM(ABS(p(:, :, ii))) + t3 = nu * (SUM(ABS(q(:, :, ii))))**2 + t4 = 2.0_DFP * phibar * nu / kbar + ans(ii) = 1.0_DFP / (t12 + t3 + t4) + END DO + END IF + !! + tau = QuadratureVariable(ans, TypeFEVariableScalar, TypeFEVariableSpace) + !! + !! cleanup + !! + DEALLOCATE (p, r, q, ans) + CALL DEALLOCATE (rvar) +END SUBROUTINE elemsd_getSUPGParam_d + +!---------------------------------------------------------------------------- +! getSUPGParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_getSUPGParam3 +SELECT TYPE (obj) +TYPE IS (ElemshapeData_) + !! + CALL elemsd_getSUPGParam_c( & + & obj=obj, & + & tau=tau, & + & c=c, & + & val=val, & + & nu=nu, & + & k=k, & + & phi=phi, & + & dt=dt, & + & opt=opt) + !! +CLASS IS (STElemshapeData_) + !! + CALL elemsd_getSUPGParam_d( & + & obj=obj, & + & tau=tau, & + & c=c, & + & val=val, & + & nu=nu, & + & k=k, & + & phi=phi, & + & dt=dt, & + & opt=opt) + !! +END SELECT +END PROCEDURE elemsd_getSUPGParam3 + +!---------------------------------------------------------------------------- +! GetSUPGParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUPGParam4 +INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: ans(:, :) +TYPE(FEVariable_) :: a + !! + !! main + !! +CALL Reallocate(ans, SIZE(obj(1)%N, 2), SIZE(obj)) + !! +DO ii = 1, SIZE(obj) + !! + CALL elemsd_getSUPGParam_d( & + & obj=obj(ii), & + & tau=a, & + & c=c, & + & val=val, & + & nu=nu, & + & k=k, & + & phi=phi, & + & dt=dt, & + & opt=opt) + !! + ans(:, ii) = Get(a, TypeFEVariableScalar, TypeFEVariableSpace) + !! +END DO + !! +tau = QuadratureVariable( & + & ans, & + & TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) + !! + !! +CALL DEALLOCATE (a) +DEALLOCATE (ans) +END PROCEDURE elemsd_GetSUPGParam4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE SUPG diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 new file mode 100644 index 000000000..6d5a80042 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 @@ -0,0 +1,284 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +SUBMODULE(ElemshapeData_StabilizationParamMethods) Takizawa2018 +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_1 +! +REAL(DFP), ALLOCATABLE :: nubar(:), h0(:), hmax0(:), hmin0(:), & + & r0(:, :), tau0(:) +INTEGER(I4B) :: ii, nips +REAL(DFP) :: areal, r2 +! +CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & val=val, & + & hmax=hmax0, & + & hmin=hmin0, & + & r=r0, & + & opt=opt) +! +IF (PRESENT(h)) THEN + h = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +! +IF (PRESENT(hmax)) THEN + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +! +IF (PRESENT(hmin)) THEN + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +! +CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +CALL Reallocate(tau0, SIZE(h0)) +! +DO ii = 1, SIZE(h0) + ! + r2 = DOT_PRODUCT(r0(:, ii), r0(:, ii)) + ! + IF (h0(ii) .APPROXEQ.zero) THEN + tau0(ii) = 4.0_DFP * nubar(ii) * & + & (1.0_DFP - r2) / hmin0(ii)**2 + ELSE + tau0(ii) = 4.0_DFP * nubar(ii) * & + & ((1.0_DFP - r2) / hmin0(ii)**2 & + & + 1.0_DFP / h0(ii)**2) + END IF + ! + tau0(ii) = 1.0_DFP / tau0(ii) + ! +END DO +! +tau = QuadratureVariable(tau0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +! +DEALLOCATE (nubar, h0, hmax0, hmin0, r0, tau0) +! +END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_1 + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_2 +! +REAL(DFP), ALLOCATABLE :: nubar(:, :), h0(:, :), hmax0(:, :), & + & hmin0(:, :), r0(:, :, :), tau0(:, :) +INTEGER(I4B) :: ii, nipt, nips, ipt +REAL(DFP) :: areal, r2 +! +nipt = SIZE(obj) +! +CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & val=val, & + & hmax=hmax0, & + & hmin=hmin0, & + & r=r0, & + & opt=opt) +! +IF (PRESENT(h)) THEN + h = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +! +IF (PRESENT(hmax)) THEN + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +! +IF (PRESENT(hmin)) THEN + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +! +nips = SIZE(h0, 1) +! +CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +CALL Reallocate(tau0, nips, nipt) +! +DO ipt = 1, nipt + DO ii = 1, nips + ! + r2 = DOT_PRODUCT(r0(:, ii, ipt), r0(:, ii, ipt)) + ! + IF (h0(ii, ipt) .APPROXEQ.zero) THEN + tau0(ii, ipt) = 4.0_DFP * nubar(ii, ipt) * & + & (1.0_DFP - r2) / hmin0(ii, ipt)**2 + ELSE + tau0(ii, ipt) = 4.0_DFP * nubar(ii, ipt) * & + & ((1.0_DFP - r2) / hmin0(ii, ipt)**2 & + & + 1.0_DFP / h0(ii, ipt)**2) + END IF + ! + tau0(ii, ipt) = 1.0_DFP / tau0(ii, ipt) + ! + END DO +END DO +! +tau = QuadratureVariable(tau0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +! +DEALLOCATE (nubar, h0, hmax0, hmin0, r0, tau0) +! +END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_2 + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_3 +! +REAL(DFP), ALLOCATABLE :: h0(:), hmax0(:), hmin0(:), & + & r0(:, :), tau0(:) +INTEGER(I4B) :: ii +REAL(DFP) :: areal, r2 +! +CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & val=val, & + & hmax=hmax0, & + & hmin=hmin0, & + & r=r0, & + & opt=opt) +! +IF (PRESENT(h)) THEN + h = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +! +IF (PRESENT(hmax)) THEN + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +! +IF (PRESENT(hmin)) THEN + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +END IF +! +CALL Reallocate(tau0, SIZE(h0)) +! +DO ii = 1, SIZE(h0) + ! + r2 = DOT_PRODUCT(r0(:, ii), r0(:, ii)) + ! + IF (h0(ii) .APPROXEQ.zero) THEN + tau0(ii) = 4.0_DFP * nu * & + & (1.0_DFP - r2) / hmin0(ii)**2 + ELSE + tau0(ii) = 4.0_DFP * nu * & + & ((1.0_DFP - r2) / hmin0(ii)**2 & + & + 1.0_DFP / h0(ii)**2) + END IF + ! + tau0(ii) = 1.0_DFP / tau0(ii) + ! +END DO +! +tau = QuadratureVariable(tau0, TypeFEVariableScalar, & + & TypeFEVariableSpace) +! +DEALLOCATE (h0, hmax0, hmin0, r0, tau0) +! +END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_3 + +!---------------------------------------------------------------------------- +! getSUGN3Param_Takizawa2018 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_4 +! +REAL(DFP), ALLOCATABLE :: h0(:, :), hmax0(:, :), & + & hmin0(:, :), r0(:, :, :), tau0(:, :) +INTEGER(I4B) :: ii, nipt, nips, ipt +REAL(DFP) :: areal, r2 +! +nipt = SIZE(obj) +! +CALL GetHRQIParam( & + & obj=obj, & + & h=h0, & + & val=val, & + & hmax=hmax0, & + & hmin=hmin0, & + & r=r0, & + & opt=opt) +! +IF (PRESENT(h)) THEN + h = QuadratureVariable(h0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +! +IF (PRESENT(hmax)) THEN + hmax = QuadratureVariable(hmax0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +! +IF (PRESENT(hmin)) THEN + hmin = QuadratureVariable(hmin0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +END IF +! +nips = SIZE(h0, 1) +! +CALL Reallocate(tau0, nips, nipt) +! +DO ipt = 1, nipt + DO ii = 1, nips + ! + r2 = DOT_PRODUCT(r0(:, ii, ipt), r0(:, ii, ipt)) + ! + IF (h0(ii, ipt) .APPROXEQ.zero) THEN + tau0(ii, ipt) = 4.0_DFP * nu * & + & (1.0_DFP - r2) / hmin0(ii, ipt)**2 + ELSE + tau0(ii, ipt) = 4.0_DFP * nu * & + & ((1.0_DFP - r2) / hmin0(ii, ipt)**2 & + & + 1.0_DFP / h0(ii, ipt)**2) + END IF + ! + tau0(ii, ipt) = 1.0_DFP / tau0(ii, ipt) + ! + END DO +END DO +! +tau = QuadratureVariable(tau0, TypeFEVariableScalar, & + & TypeFEVariableSpaceTime) +! +DEALLOCATE (h0, hmax0, hmin0, r0, tau0) +! +END PROCEDURE elemsd_GetSUGN3Param_Takizawa2018_4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Takizawa2018 diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 new file mode 100644 index 000000000..07a7d5fae --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 @@ -0,0 +1,168 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_UnitNormalMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getUnitNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getUnitNormal_1 +! Define internal variables +REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) +INTEGER(I4B) :: ii +!! main +CALL getInterpolation(obj=obj, Val=val, Interpol=p) +CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) +CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2)) +pnorm = NORM2(dp, DIM=1) +!! +DO ii = 1, SIZE(p) + IF (pnorm(ii) .GT. zero) THEN + IF (p(ii) .GE. 0.0_DFP) THEN + R(:, ii) = dp(:, ii) / pnorm(ii) + ELSE + R(:, ii) = -dp(:, ii) / pnorm(ii) + END IF + END IF +END DO +!! +IF (ALLOCATED(dp)) DEALLOCATE (dp) +IF (ALLOCATED(p)) DEALLOCATE (p) +IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) +END PROCEDURE getUnitNormal_1 + +!---------------------------------------------------------------------------- +! getUnitNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getUnitNormal_2 +REAL(DFP), ALLOCATABLE :: dp(:, :, :) +REAL(DFP), ALLOCATABLE :: p(:, :) +REAL(DFP), ALLOCATABLE :: mv(:) +REAL(DFP), ALLOCATABLE :: pnorm(:) +REAL(DFP) :: nrm +INTEGER(I4B) :: i +!! main +!! interpolate the vector +CALL getInterpolation(obj=obj, Interpol=p, Val=val) +!! get gradient of nodal values +CALL getSpatialGradient(obj=obj, lg=dp, Val=val) +pnorm = NORM2(p, DIM=1) +CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2)) +DO i = 1, SIZE(pnorm) + IF (pnorm(i) .GT. Zero) THEN + p(:, i) = p(:, i) / pnorm(i) + ELSE + p(:, i) = 1.0 + END IF + mv = MATMUL(p(:, i), dp(:, :, i)) + nrm = NORM2(mv) + IF (nrm .GT. Zero) THEN + R(:, i) = mv / nrm + END IF +END DO +IF (ALLOCATED(dp)) DEALLOCATE (dp) +IF (ALLOCATED(p)) DEALLOCATE (p) +IF (ALLOCATED(mv)) DEALLOCATE (mv) +IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) +END PROCEDURE getUnitNormal_2 + +!---------------------------------------------------------------------------- +! getUnitNormal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getUnitNormal_3 + !! +IF (val%rank .EQ. scalar) THEN + CALL scalar_getUnitNormal_3(obj=obj, r=r, val=val) +ELSEIF (val%rank .EQ. vector) THEN + CALL vector_getUnitNormal_3(obj=obj, r=r, val=val) +END IF + !! +CONTAINS + !! +PURE SUBROUTINE scalar_getUnitNormal_3(obj, r, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :) + TYPE(FEVariable_), INTENT(IN) :: val +! Define internal variables +REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) +INTEGER(I4B) :: ii +!! main +CALL getInterpolation(obj=obj, Val=val, Interpol=p) +CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) +CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2)) +pnorm = NORM2(dp, DIM=1) +!! +DO ii = 1, SIZE(p) + IF (pnorm(ii) .GT. zero) THEN + IF (p(ii) .GE. 0.0_DFP) THEN + R(:, ii) = dp(:, ii) / pnorm(ii) + ELSE + R(:, ii) = -dp(:, ii) / pnorm(ii) + END IF + END IF +END DO +!! +IF (ALLOCATED(dp)) DEALLOCATE (dp) +IF (ALLOCATED(p)) DEALLOCATE (p) +IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) +END SUBROUTINE scalar_getUnitNormal_3 + !! +PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :) + TYPE(FEVariable_), INTENT(IN) :: val +!! Define internal variables +REAL(DFP), ALLOCATABLE :: dp(:, :, :) +REAL(DFP), ALLOCATABLE :: p(:, :) +REAL(DFP), ALLOCATABLE :: mv(:) +REAL(DFP), ALLOCATABLE :: pnorm(:) +REAL(DFP) :: nrm +INTEGER(I4B) :: i +!! main +!! interpolate the vector +CALL getInterpolation(obj=obj, Interpol=p, Val=val) +!! get gradient of nodal values +CALL getSpatialGradient(obj=obj, lg=dp, Val=val) +pnorm = NORM2(p, DIM=1) +CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2)) +DO i = 1, SIZE(pnorm) + IF (pnorm(i) .GT. Zero) THEN + p(:, i) = p(:, i) / pnorm(i) + ELSE + p(:, i) = 1.0 + END IF + mv = MATMUL(p(:, i), dp(:, :, i)) + nrm = NORM2(mv) + IF (nrm .GT. Zero) THEN + R(:, i) = mv / nrm + END IF +END DO +IF (ALLOCATED(dp)) DEALLOCATE (dp) +IF (ALLOCATED(p)) DEALLOCATE (p) +IF (ALLOCATED(mv)) DEALLOCATE (mv) +IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) +END SUBROUTINE vector_getUnitNormal_3 + !! +END PROCEDURE getUnitNormal_3 + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 new file mode 100644 index 000000000..169aefe21 --- /dev/null +++ b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 @@ -0,0 +1,33 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(ElemShapeData_H1Methods) HermitMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- +MODULE PROCEDURE H1_Hermit1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="H1_Hermit1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE H1_Hermit1 + +END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 new file mode 100644 index 000000000..80d203300 --- /dev/null +++ b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 @@ -0,0 +1,127 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(ElemShapeData_H1Methods) HierarchyMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE H1_Hierarchy1 +REAL(DFP), ALLOCATABLE :: xij(:, :) +REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) +REAL(DFP), ALLOCATABLE :: N(:, :) +INTEGER(I4B) :: nsd, xidim + +CALL DEALLOCATE (obj) +CALL Initiate(obj%refelem, refelem) +nsd = refelem%nsd +xidim = refelem%xiDimension +CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws) +obj%quad = quad + +CALL ALLOCATE ( & + & obj=obj, & + & nsd=nsd, & + & xidim=xidim, & + & nns=LagrangeDOF(order=order, elemType=refelem%name), & + & nips=SIZE(quad, 2)) + +SELECT CASE (refelem%name) +CASE (Line) + N = HeirarchicalBasis_Line( & + & order=order, & + & xij=xij, & + & refLine=refelem%domainName) + + dNdXi = HeirarchicalGradientBasis_Line( & + & order=order, & + & xij=xij, & + & refLine=refelem%domainName) + +CASE (Triangle) + N = HeirarchicalBasis_Triangle( & + & order=order, & + & pe1=order, & + & pe2=order, & + & pe3=order, & + & xij=xij, & + & refTriangle=refelem%domainName) + + dNdXi = HeirarchicalBasisGradient_Triangle( & + & order=order, & + & pe1=order, & + & pe2=order, & + & pe3=order, & + & xij=xij, & + & refTriangle=refelem%domainName) + +CASE (Quadrangle) + N = HeirarchicalBasis_Quadrangle( & + & p=order, & + & q=order, & + & xij=xij) + + dNdXi = HeirarchicalBasisGradient_Quadrangle( & + & p=order, & + & q=order, & + & xij=xij) + +CASE (Tetrahedron) + N = HeirarchicalBasis_Tetrahedron( & + & order=order, & + & xij=xij, & + & refTetrahedron=refelem%domainName) + + dNdXi = HeirarchicalBasisGradient_Tetrahedron( & + & order=order, & + & xij=xij, & + & refTetrahedron=refelem%domainName) + +CASE (Hexahedron) + N = HeirarchicalBasis_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=xij) + + dNdXi = HeirarchicalBasisGradient_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=xij) + +CASE DEFAULT + CALL Errormsg( & + & msg="[NO CASE FOUND] no case found for elemType", & + & unitno=stderr, & + & routine="H1_Hierarchy1()", & + & file=__FILE__, & + & line=__LINE__) +END SELECT + +obj%N = TRANSPOSE(N) +CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) + +IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) +IF (ALLOCATED(N)) DEALLOCATE (N) +IF (ALLOCATED(xij)) DEALLOCATE (xij) +END PROCEDURE H1_Hierarchy1 + +END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 new file mode 100644 index 000000000..39cc8ade3 --- /dev/null +++ b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 @@ -0,0 +1,133 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_H1Methods) LagrangeMethods +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE H1_Lagrange1 +REAL(DFP), ALLOCATABLE :: pt(:, :), xij(:, :), dNdXi(:, :, :), coeff0(:, :) +INTEGER(I4B) :: nsd, xidim, ipType0, basisType0 + +ipType0 = Input(default=Equidistance, option=ipType) +basisType0 = Input(default=Monomial, option=basisType) + +! CALL DEALLOCATE (obj) +CALL Initiate(obj%refelem, refelem) +nsd = refelem%nsd +xidim = refelem%xiDimension +CALL GetQuadraturePoints(obj=quad, points=pt, weights=obj%ws) +obj%quad = quad + +CALL ALLOCATE ( & + & obj=obj, & + & nsd=nsd, & + & xidim=xidim, & + & nns=LagrangeDOF(order=order, elemType=refelem%name), & + & nips=SIZE(quad, 2)) + +xij = InterpolationPoint( & + & order=order, & + & elemType=refelem%name, & + & ipType=ipType0, & + & layout="VEFC", & + & xij=refelem%xij(1:xidim, :), & + & alpha=alpha, beta=beta, lambda=lambda) + +CALL Reallocate(coeff0, SIZE(xij, 2), SIZE(xij, 2)) + +IF (PRESENT(coeff)) THEN + obj%N = TRANSPOSE(LagrangeEvalAll( & + & order=order, & + & elemType=refelem%name, & + & x=pt(1:xidim, :), & + & xij=xij, & + & domainName=refelem%domainName, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & coeff=coeff, & + & firstCall=firstCall)) + + dNdXi = LagrangeGradientEvalAll( & + & order=order, & + & elemType=refelem%name, & + & x=pt(1:xidim, :), & + & xij=xij, & + & domainName=refelem%domainName, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & coeff=coeff, & + & firstCall=.FALSE.) + + CALL SWAP( & + & a=obj%dNdXi, & + & b=dNdXi, & + & i1=2, i2=3, i3=1) + +ELSE + + obj%N = TRANSPOSE(LagrangeEvalAll( & + & order=order, & + & elemType=refelem%name, & + & x=pt(1:xidim, :), & + & xij=xij, & + & domainName=refelem%domainName, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & coeff=coeff0, & + & firstCall=.TRUE.)) + + dNdXi = LagrangeGradientEvalAll( & + & order=order, & + & elemType=refelem%name, & + & x=pt(1:xidim, :), & + & xij=xij, & + & domainName=refelem%domainName, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & coeff=coeff0, & + & firstCall=.FALSE.) + + CALL SWAP( & + & a=obj%dNdXi, & + & b=dNdXi, & + & i1=2, i2=3, i3=1) + +END IF + +IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) +IF (ALLOCATED(xij)) DEALLOCATE (xij) +IF (ALLOCATED(pt)) DEALLOCATE (pt) +IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0) + +END PROCEDURE H1_Lagrange1 + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 new file mode 100644 index 000000000..f104a5c00 --- /dev/null +++ b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 @@ -0,0 +1,169 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_H1Methods) OrthogonalMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE H1_Orthogonal1 +REAL(DFP), ALLOCATABLE :: xij(:, :) +REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) +REAL(DFP), ALLOCATABLE :: N(:, :) +INTEGER(I4B) :: nsd, xidim, basisType0 + +basisType0 = Input(option=basisType, default=Legendre) +CALL DEALLOCATE (obj) +CALL Initiate(obj%refelem, refelem) +nsd = refelem%nsd +xidim = refelem%xiDimension +CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws) +obj%quad = quad + +CALL ALLOCATE ( & + & obj=obj, & + & nsd=nsd, & + & xidim=xidim, & + & nns=LagrangeDOF(order=order, elemType=refelem%name), & + & nips=SIZE(quad, 2)) + +SELECT CASE (refelem%name) +CASE (Line) + N = OrthogonalBasis_Line( & + & order=order, & + & xij=xij, & + & refLine=refelem%domainName, & + & basisType=basisType0, & + & alpha=alpha, beta=beta, lambda=lambda) + + dNdXi = OrthogonalBasisGradient_Line( & + & order=order, & + & xij=xij, & + & refLine=refelem%domainName, & + & basisType=basisType0, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE (Triangle) + N = OrthogonalBasis_Triangle( & + & order=order, & + & xij=xij, & + & refTriangle=refelem%domainName) + + dNdXi = OrthogonalBasisGradient_Triangle( & + & order=order, & + & xij=xij, & + & refTriangle=refelem%domainName) + +CASE (Quadrangle) + N = OrthogonalBasis_Quadrangle( & + & p=order, & + & q=order, & + & xij=xij, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & alpha1 = alpha, & + & beta1 = beta, & + & alpha2 = alpha, & + & beta2 = beta, & + & lambda1 = lambda, & + & lambda2 = lambda ) + + dNdXi = OrthogonalBasisGradient_Quadrangle( & + & p=order, & + & q=order, & + & xij=xij, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & alpha1 = alpha, & + & beta1 = beta, & + & alpha2 = alpha, & + & beta2 = beta, & + & lambda1 = lambda, & + & lambda2 = lambda ) + +CASE (Tetrahedron) + N = OrthogonalBasis_Tetrahedron( & + & order=order, & + & xij=xij, & + & refTetrahedron=refelem%domainName) + + dNdXi = OrthogonalBasisGradient_Tetrahedron( & + & order=order, & + & xij=xij, & + & refTetrahedron=refelem%domainName) + +CASE (Hexahedron) + N = OrthogonalBasis_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=xij, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & basisType3=basisType0, & + & alpha1 = alpha, & + & beta1 = beta, & + & lambda1 = lambda, & + & alpha2 = alpha, & + & beta2 = beta, & + & lambda2 = lambda, & + & alpha3 = alpha, & + & beta3 = beta, & + & lambda3 = lambda & + & ) + + dNdXi = OrthogonalBasisGradient_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=xij, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & basisType3=basisType0, & + & alpha1 = alpha, & + & beta1 = beta, & + & lambda1 = lambda, & + & alpha2 = alpha, & + & beta2 = beta, & + & lambda2 = lambda, & + & alpha3 = alpha, & + & beta3 = beta, & + & lambda3 = lambda & + & ) + +CASE DEFAULT + CALL Errormsg( & + & msg="[NO CASE FOUND] no case found for elemType", & + & unitno=stderr, & + & routine="H1_Hierarchy1()", & + & file=__FILE__, & + & line=__LINE__) +END SELECT + +obj%N = TRANSPOSE(N) +CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) + +IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) +IF (ALLOCATED(N)) DEALLOCATE (N) +IF (ALLOCATED(xij)) DEALLOCATE (xij) +END PROCEDURE H1_Orthogonal1 + +END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 new file mode 100644 index 000000000..79ed8bb3e --- /dev/null +++ b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_H1Methods) SerendipityMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE H1_Serendipity1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="H1_Serendipity()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE H1_Serendipity1 + +END SUBMODULE SerendipityMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 new file mode 100644 index 000000000..be6cfd29a --- /dev/null +++ b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HCurlMethods) HermitMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HCurl_Hermit1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HCurl_Hermit1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HCurl_Hermit1 + +END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 new file mode 100644 index 000000000..e468ebc6c --- /dev/null +++ b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HCurlMethods) HierarchyMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HCurl_Hierarchy1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HCurl_Hierarchy1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HCurl_Hierarchy1 + +END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 new file mode 100644 index 000000000..427af424f --- /dev/null +++ b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HCurlMethods) LagrangeMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HCurl_Lagrange1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HCurl_Lagrange1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HCurl_Lagrange1 + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 new file mode 100644 index 000000000..b60ebdd09 --- /dev/null +++ b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HCurlMethods) OrthogonalMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HCurl_Orthogonal1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HCurl_Orthogonal1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HCurl_Orthogonal1 + +END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 new file mode 100644 index 000000000..cb555a1dd --- /dev/null +++ b/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HCurlMethods) SerendipityMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HCurl_Serendipity1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HCurl_Serendipity1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HCurl_Serendipity1 + +END SUBMODULE SerendipityMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 new file mode 100644 index 000000000..7f48189b1 --- /dev/null +++ b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HDivMethods) HermitMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HDiv_Hermit1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HDiv_Hermit1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HDiv_Hermit1 + +END SUBMODULE HermitMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 new file mode 100644 index 000000000..da0230faf --- /dev/null +++ b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HDivMethods) HierarchyMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HDiv_Hierarchy1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HDiv_Hierarchy1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HDiv_Hierarchy1 + +END SUBMODULE HierarchyMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 new file mode 100644 index 000000000..6c0f64c3f --- /dev/null +++ b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HDivMethods) LagrangeMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HDiv_Lagrange1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HDiv_Lagrange1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HDiv_Lagrange1 + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 new file mode 100644 index 000000000..9474719f8 --- /dev/null +++ b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HDivMethods) OrthogonalMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HDiv_Orthogonal1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HDiv_Orthogonal1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HDiv_Orthogonal1 + +END SUBMODULE OrthogonalMethods diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 new file mode 100644 index 000000000..84a972676 --- /dev/null +++ b/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 @@ -0,0 +1,35 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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_HDivMethods) SerendipityMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HDiv_Serendipity1 +CALL Errormsg( & + & msg="[WORK IN PROGRESS] This method is currently not available", & + & line=__LINE__, & + & routine="HDiv_Serendipity1()", & + & unitno=stderr, & + & file=__FILE__) +END PROCEDURE HDiv_Serendipity1 + +END SUBMODULE SerendipityMethods diff --git a/src/submodules/FEMatrix/src/STCM/STCM_1.inc b/src/submodules/FEMatrix/src/STCM/STCM_1.inc new file mode 100644 index 000000000..9b977f48c --- /dev/null +++ b/src/submodules/FEMatrix/src/STCM/STCM_1.inc @@ -0,0 +1,111 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_1a(ans, test, trial, term1, term2, c, projecton) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! Convective velocity, it can be + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_dx + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & test(ipt)%T, & + & p(:, :, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + !! + DEALLOCATE (IaJb, p, realval) +END SUBROUTINE STCM_1a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_1b(ans, test, trial, term1, term2, c, projecton) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! Convective velocity, it can be + INTEGER(I4B), INTENT(IN) :: term1 + !! del_dx + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: projecton + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & p(:, :, ips), & + & trial(ipt)%N(:, ips), & + & trial(ipt)%T) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + !! + DEALLOCATE (IaJb, p, realval) +END SUBROUTINE STCM_1b diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt new file mode 100644 index 000000000..ebcb11b22 --- /dev/null +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -0,0 +1,35 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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@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 +) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 new file mode 100644 index 000000000..6cecc69f9 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 @@ -0,0 +1,64 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 new file mode 100644 index 000000000..68d095928 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 @@ -0,0 +1,107 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) AdditionMethods + +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, & + Nodal, Quadrature +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE ReallocateUtility, ONLY: Reallocate + +#define _OP_ + + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Addition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_addition1 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) +INTEGER(I4B) :: jj, kk +SELECT CASE (obj1%rank) +CASE (scalar) + SELECT CASE (obj2%rank) + CASE (scalar) +#include "./include/ScalarOperatorScalar.F90" + CASE (vector) +#include "./include/ScalarOperatorVector.F90" + CASE (matrix) +#include "./include/ScalarOperatorMatrix.F90" + END SELECT +CASE (vector) + SELECT CASE (obj2%rank) + CASE (scalar) +#include "./include/VectorOperatorScalar.F90" + CASE (vector) +#include "./include/VectorOperatorVector.F90" + END SELECT +CASE (matrix) + SELECT CASE (obj2%rank) + CASE (scalar) +#include "./include/MatrixOperatorScalar.F90" + CASE (matrix) +#include "./include/MatrixOperatorMatrix.F90" + END SELECT +END SELECT +END PROCEDURE fevar_addition1 + +!---------------------------------------------------------------------------- +! Addition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_addition2 +SELECT CASE (obj1%rank) +CASE (scalar) +#include "./include/ScalarOperatorReal.F90" +CASE (vector) +#include "./include/VectorOperatorReal.F90" +CASE (matrix) +#include "./include/MatrixOperatorReal.F90" +END SELECT +END PROCEDURE fevar_addition2 + +!---------------------------------------------------------------------------- +! Addition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_addition3 +SELECT CASE (obj1%rank) +CASE (scalar) +#include "./include/RealOperatorScalar.F90" +CASE (vector) +#include "./include/RealOperatorVector.F90" +CASE (matrix) +#include "./include/RealOperatorMatrix.F90" +END SELECT +END PROCEDURE fevar_addition3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE AdditionMethods +#undef _OP_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 new file mode 100644 index 000000000..4cd019838 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 @@ -0,0 +1,467 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_Method) ConstructorMethods +USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & + Time, SpaceTime, Nodal, Quadrature + +USE ReallocateUtility, ONLY: Reallocate + +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 +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 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Constant +#define _DEFINEON_ Quadrature +#include "./include/scalar_constant.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Scalar_Constant + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Space +#define _DEFINEON_ Quadrature +#include "./include/scalar_space.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Scalar_Space + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Time +#define _DEFINEON_ Quadrature +#include "./include/scalar_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Scalar_Time + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_SpaceTime +#define _DEFINEON_ Quadrature +#include "./include/scalar_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Scalar_SpaceTime + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_SpaceTime2 +#define _DEFINEON_ Quadrature +#include "./include/scalar_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Scalar_SpaceTime2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Constant +#define _DEFINEON_ Quadrature +#include "./include/vector_constant.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_Constant + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Space +#define _DEFINEON_ Quadrature +#include "./include/vector_space.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_Space + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Space2 +#define _DEFINEON_ Quadrature +#include "./include/vector_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_Space2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Time +#define _DEFINEON_ Quadrature +#include "./include/vector_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_Time + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Time2 +#define _DEFINEON_ Quadrature +#include "./include/vector_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_Time2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_SpaceTime +#define _DEFINEON_ Quadrature +#include "./include/vector_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_SpaceTime + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_SpaceTime2 +#define _DEFINEON_ Quadrature +#include "./include/vector_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Vector_SpaceTime2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Constant +#define _DEFINEON_ Quadrature +#include "./include/matrix_constant.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Constant + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Constant2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_constant2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Constant2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Space +#define _DEFINEON_ Quadrature +#include "./include/matrix_space.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Space + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Space2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Space2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Time +#define _DEFINEON_ Quadrature +#include "./include/matrix_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Time + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Time2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_Time2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_SpaceTime +#define _DEFINEON_ Quadrature +#include "./include/matrix_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_SpaceTime + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_SpaceTime2 +#define _DEFINEON_ Quadrature +#include "./include/matrix_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Quadrature_Matrix_SpaceTime2 + +!---------------------------------------------------------------------------- +! Copy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Copy +obj1%s = obj2%s +obj1%defineOn = obj2%defineOn +obj1%rank = obj2%rank +obj1%varType = obj2%varType +obj1%len = obj2%len + +IF (obj1%capacity .GE. obj1%len) THEN + obj1%val(1:obj1%len) = obj2%val(1:obj1%len) + RETURN +END IF + +obj1%capacity = CAPACITY_EXPAND_FACTOR * obj1%len +CALL Reallocate(obj1%val, obj1%capacity) +obj1%val(1:obj1%len) = obj2%val(1:obj1%len) + +END PROCEDURE obj_Copy + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE ConstructorMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 new file mode 100644 index 000000000..3046f33bf --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 @@ -0,0 +1,129 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) DivisionMethods +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, & + Nodal, Quadrature +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE ReallocateUtility, ONLY: Reallocate + +#define _OP_ / + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! Division +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Division1 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) +INTEGER(I4B) :: jj, kk +SELECT CASE (obj1%rank) + +CASE (scalar) + + SELECT CASE (obj2%rank) + + CASE (scalar) + +#include "./include/ScalarOperatorScalar.F90" + CASE (vector) + +#include "./include/ScalarOperatorVector.F90" + CASE (matrix) + +#include "./include/ScalarOperatorMatrix.F90" + END SELECT +CASE (vector) + + SELECT CASE (obj2%rank) + + CASE (scalar) + +#include "./include/VectorOperatorScalar.F90" + CASE (vector) + +#include "./include/VectorOperatorVector.F90" + END SELECT +CASE (matrix) + + SELECT CASE (obj2%rank) + + CASE (scalar) + +#include "./include/MatrixOperatorScalar.F90" + CASE (matrix) + +#include "./include/MatrixOperatorMatrix.F90" + END SELECT +END SELECT +END PROCEDURE fevar_Division1 + +!---------------------------------------------------------------------------- +! Division +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Division2 +SELECT CASE (obj1%rank) + +CASE (scalar) + +#include "./include/ScalarOperatorReal.F90" +CASE (vector) + +#include "./include/VectorOperatorReal.F90" +CASE (matrix) + +#include "./include/MatrixOperatorReal.F90" +END SELECT +END PROCEDURE fevar_Division2 + +!---------------------------------------------------------------------------- +! Division +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Division3 +SELECT CASE (obj1%rank) + +CASE (scalar) + +#include "./include/RealOperatorScalar.F90" +CASE (vector) + +#include "./include/RealOperatorVector.F90" +CASE (matrix) + +#include "./include/RealOperatorMatrix.F90" +END SELECT +END PROCEDURE fevar_Division3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#undef _OP_ +END SUBMODULE DivisionMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 new file mode 100644 index 000000000..a1b1f1ab1 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 @@ -0,0 +1,282 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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@EqualMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 new file mode 100644 index 000000000..d7e92e320 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 @@ -0,0 +1,78 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) EqualMethods +USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! NORM2 +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! NORM2 +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE EqualMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 new file mode 100644 index 000000000..573b6700b --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.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(FEVariable_Method) GetMethods + +USE ReallocateUtility, ONLY: Reallocate + +USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & + Time, SpaceTime, Nodal, Quadrature +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! GetLambdaFromYoungsModulus +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_GetLambdaFromYoungsModulus +INTEGER(I4B) :: ii + +lambda = youngsModulus + +DO CONCURRENT(ii=1:lambda%len) + lambda%val(ii) = shearModulus%val(ii) * & + (youngsModulus%val(ii) - 2.0_DFP * shearModulus%val(ii)) / & + (3.0_DFP * shearModulus%val(ii) - youngsModulus%val(ii)) +END DO + +END PROCEDURE fevar_GetLambdaFromYoungsModulus + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Size +IF (PRESENT(dim)) THEN + ans = obj%s(dim) +ELSE + ans = obj%len +END IF +END PROCEDURE fevar_Size + +!---------------------------------------------------------------------------- +! Shape +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Shape +SELECT CASE (obj%rank) +CASE (Scalar) + SELECT CASE (obj%vartype) + CASE (Constant) + ans = [1] + CASE (Space, Time) + ans = obj%s(1:1) + CASE (SpaceTime) + ans = obj%s(1:2) + END SELECT +CASE (Vector) + SELECT CASE (obj%vartype) + CASE (Constant) + ans = obj%s(1:1) + CASE (Space, Time) + ans = obj%s(1:2) + CASE (SpaceTime) + ans = obj%s(1:3) + END SELECT +CASE (Matrix) + SELECT CASE (obj%vartype) + CASE (Constant) + ans = obj%s(1:2) + CASE (Space, Time) + ans = obj%s(1:3) + CASE (SpaceTime) + ans = obj%s(1:4) + END SELECT +END SELECT +END PROCEDURE fevar_Shape + +!---------------------------------------------------------------------------- +! rank +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_rank +ans = obj%rank +END PROCEDURE fevar_rank + +!---------------------------------------------------------------------------- +! vartype +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_vartype +ans = obj%vartype +END PROCEDURE fevar_vartype + +!---------------------------------------------------------------------------- +! defineon +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_defineon +ans = obj%defineon +END PROCEDURE fevar_defineon + +!---------------------------------------------------------------------------- +! isNodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_isNodalVariable +ans = obj%defineon .EQ. nodal +END PROCEDURE fevar_isNodalVariable + +!---------------------------------------------------------------------------- +! isNodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_isQuadratureVariable +ans = obj%defineon .NE. nodal +END PROCEDURE fevar_isQuadratureVariable + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_Constant +val = obj%val(1) +END PROCEDURE Scalar_Constant + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_Space +ALLOCATE (val(obj%len)) +val = obj%val(1:obj%len) +END PROCEDURE Scalar_Space + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_Time +ALLOCATE (val(obj%len)) +val = obj%val(1:obj%len) +END PROCEDURE Scalar_Time + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_SpaceTime +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + + END DO +END DO + +END PROCEDURE Scalar_SpaceTime + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_Constant +ALLOCATE (val(obj%len)) +val = obj%val(1:obj%len) +END PROCEDURE Vector_Constant + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_Space +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + END DO +END DO + +END PROCEDURE Vector_Space + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_Time +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + END DO +END DO +END PROCEDURE Vector_Time + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_SpaceTime +INTEGER(I4B) :: ii, jj, kk, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) + +cnt = 0 +DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk) = obj%val(cnt) + END DO + END DO +END DO +END PROCEDURE Vector_SpaceTime + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Matrix_Constant +INTEGER(I4B) :: ii, jj, cnt + +ALLOCATE (val(obj%s(1), obj%s(2))) + +cnt = 0 +DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + END DO +END DO +END PROCEDURE Matrix_Constant + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Matrix_Space +INTEGER(I4B) :: ii, jj, kk, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) + +cnt = 0 +DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk) = obj%val(cnt) + END DO + END DO +END DO +END PROCEDURE Matrix_Space + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Matrix_Time +INTEGER(I4B) :: ii, jj, kk, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) + +cnt = 0 +DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk) = obj%val(cnt) + END DO + END DO +END DO +END PROCEDURE Matrix_Time + +!---------------------------------------------------------------------------- +! getNodalvalues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Matrix_SpaceTime +INTEGER(I4B) :: ii, jj, kk, ll, cnt + +ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3), obj%s(4))) + +cnt = 0 +DO ll = 1, obj%s(4) + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + val(ii, jj, kk, ll) = obj%val(cnt) + END DO + END DO + END DO +END DO +END PROCEDURE Matrix_SpaceTime + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE GetMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 new file mode 100644 index 000000000..276dd37c0 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.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 +! + +SUBMODULE(FEVariable_Method) IOMethods +USE Display_Method, ONLY: Util_Display => Display, ToString + +USE GlobalData, ONLY: Scalar, Vector, Matrix, & + Constant, Space, Time, SpaceTime, & + Nodal, Quadrature + +USE BaseType, ONLY: TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime, & + TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix + +USE SafeSizeUtility, ONLY: SafeSize + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Display +CALL Util_Display(msg, unitno=unitno) + +SELECT CASE (obj%rank) + +CASE (Scalar) + + CALL Util_Display("RANK :: 0 (Scalar)", unitno=unitno) + + SELECT CASE (obj%varType) + CASE (Constant) + CALL Util_Display("VarType: Constant", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) + + CASE (Space) + CALL Util_Display("VarType: Space", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpace), & + 'VALUE: ', unitno=unitno) + CASE (Time) + CALL Util_Display("VarType: Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableTime), & + 'VALUE: ', unitno=unitno) + CASE (SpaceTime) + CALL Util_Display("VarType: Space & Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) + + CASE DEFAULT + CALL Util_Display("VarType: UNKNOWN", unitno=unitno) + END SELECT + +CASE (Vector) + + CALL Util_Display("RANK :: 1 (Vector)", unitno=unitno) + SELECT CASE (obj%varType) + CASE (Constant) + CALL Util_Display("VarType: Constant", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) + CASE (Space) + CALL Util_Display("VarType: Space", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpace), & + 'VALUE: ', unitno=unitno) + CASE (Time) + CALL Util_Display("VarType: Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableTime), & + 'VALUE: ', unitno=unitno) + CASE (SpaceTime) + CALL Util_Display("VarType: Space & Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) + + CASE DEFAULT + CALL Util_Display("VarType: UNKNOWN", unitno=unitno) + END SELECT + +CASE (Matrix) + + CALL Util_Display("RANK :: 2 (Matrix)", unitno=unitno) + SELECT CASE (obj%varType) + CASE (Constant) + CALL Util_Display("VarType: Constant", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) + CASE (Space) + CALL Util_Display("VarType: Space", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpace), & + 'VALUE: ', unitno=unitno) + CASE (Time) + CALL Util_Display("VarType: Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableTime), & + 'VALUE: ', unitno=unitno) + CASE (SpaceTime) + CALL Util_Display("VarType: Space & Time", unitno=unitno) + CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) + + CASE DEFAULT + CALL Util_Display("VarType: UNKNOWN", unitno=unitno) + END SELECT + +CASE DEFAULT + CALL Util_Display("RANK: UNKNOWN", unitno=unitno) + +END SELECT + +CALL Util_Display(obj%s, "s: ", unitno=unitno) +CALL Util_Display(obj%defineOn, "defineOn: ", unitno=unitno) +CALL Util_Display(obj%len, "len: ", unitno=unitno) +CALL Util_Display(obj%capacity, "capacity: ", unitno=unitno) +CALL Util_Display(SafeSize(obj%val), "Size of obj%val: ", unitno=unitno) + +END PROCEDURE fevar_Display + +END SUBMODULE IOMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 new file mode 100644 index 000000000..979dc3e8f --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 @@ -0,0 +1,176 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_Method) MeanMethods +USE IntegerUtility, ONLY: Get1DIndexFortran + +USE GlobalData, ONLY: Scalar, Vector, Matrix, & + Constant, Space, Time, & + SpaceTime, Nodal, Quadrature + +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Addition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Mean1 +REAL(DFP) :: val0 +SELECT CASE (obj%rank) +CASE (scalar) + IF (obj%defineOn .EQ. NODAL) THEN + ans = NodalVariable(MEAN(obj, TypeFEVariableScalar), TypeFEVariableScalar, & + TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(MEAN(obj, TypeFEVariableScalar), & + TypeFEVariableScalar, TypeFEVariableConstant) + END IF + +CASE (vector) + IF (obj%defineOn .EQ. NODAL) THEN + ans = NodalVariable(MEAN(obj, TypeFEVariableVector), & + TypeFEVariableVector, TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(MEAN(obj, TypeFEVariableVector), & + TypeFEVariableVector, TypeFEVariableConstant) + END IF + +CASE (matrix) + IF (obj%defineOn .EQ. NODAL) THEN + ans = NodalVariable(MEAN(obj, TypeFEVariableMatrix), & + TypeFEVariableMatrix, TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(MEAN(obj, TypeFEVariableMatrix), & + TypeFEVariableMatrix, TypeFEVariableConstant) + END IF +END SELECT +END PROCEDURE fevar_Mean1 + +!---------------------------------------------------------------------------- +! Addition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Mean2 +ans = SUM(obj%val(1:obj%len)) / obj%len +END PROCEDURE fevar_Mean2 + +!---------------------------------------------------------------------------- +! Addition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Mean3 +INTEGER(I4B) :: ii, tsize + +tsize = obj%s(1) +ALLOCATE (ans(tsize)) + +SELECT CASE (obj%varType) + +CASE (Constant) + + ans(1:tsize) = obj%val(1:tsize) + +CASE (Space, Time) + + ans = 0.0 + DO ii = 1, obj%s(2) + ans(1:tsize) = ans(1:tsize) + obj%val((ii - 1) * tsize + 1:ii * tsize) + END DO + + ans(1:tsize) = ans(1:tsize) / obj%s(2) + +CASE (SpaceTime) + + ans = 0.0 + DO ii = 1, obj%s(2) * obj%s(3) + ans(1:tsize) = ans(1:tsize) + obj%val((ii - 1) * tsize + 1:ii * tsize) + END DO + + ans(1:tsize) = ans(1:tsize) / (obj%s(2) * obj%s(3)) + +END SELECT + +END PROCEDURE fevar_Mean3 + +!---------------------------------------------------------------------------- +! Addition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Mean4 +INTEGER(I4B) :: ii, jj, kk, ll + +ALLOCATE (ans(obj%s(1), obj%s(2))) + +SELECT CASE (obj%varType) + +CASE (Constant) + + DO CONCURRENT(ii=1:obj%s(1), jj=1:obj%s(2)) + ans(ii, jj) = obj%val(Get1DIndexFortran(i=ii, j=jj, & + dim1=obj%s(1), dim2=obj%s(2))) + END DO + +CASE (Space, Time) + + DO CONCURRENT(kk=1:obj%s(3)) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + + ans(ii, jj) = ans(ii, jj) & + + obj%val(Get1DIndexFortran(i=ii, j=jj, k=kk, & + dim1=obj%s(1), dim2=obj%s(2), dim3=obj%s(3))) + + END DO + END DO + END DO + + ans = ans / obj%s(3) + +CASE (SpaceTime) + + DO CONCURRENT(kk=1:obj%s(3), ll=1:obj%s(4)) + + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + ans(ii, jj) = ans(ii, jj) + obj%val(Get1DIndexFortran( & + i=ii, j=jj, k=kk, l=ll, & + dim1=obj%s(1), dim2=obj%s(2), dim3=obj%s(3), dim4=obj%s(4))) + + END DO + END DO + END DO + + ans = ans / (obj%s(3) * obj%s(4)) + +END SELECT + +END PROCEDURE fevar_Mean4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE MeanMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 new file mode 100644 index 000000000..2c72ac268 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 @@ -0,0 +1,108 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) MultiplicationMethods + +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, Nodal, Quadrature + +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE ReallocateUtility, ONLY: Reallocate + +#define _OP_ * + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! Multiplication +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Multiplication1 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) +INTEGER(I4B) :: jj, kk +SELECT CASE (obj1%rank) +CASE (scalar) + SELECT CASE (obj2%rank) + CASE (scalar) +#include "./include/ScalarOperatorScalar.F90" + CASE (vector) +#include "./include/ScalarOperatorVector.F90" + CASE (matrix) +#include "./include/ScalarOperatorMatrix.F90" + END SELECT +CASE (vector) + SELECT CASE (obj2%rank) + CASE (scalar) +#include "./include/VectorOperatorScalar.F90" + CASE (vector) +#include "./include/VectorOperatorVector.F90" + END SELECT +CASE (matrix) + SELECT CASE (obj2%rank) + CASE (scalar) +#include "./include/MatrixOperatorScalar.F90" + CASE (matrix) +#include "./include/MatrixOperatorMatrix.F90" + END SELECT +END SELECT +END PROCEDURE fevar_Multiplication1 + +!---------------------------------------------------------------------------- +! Multiplication +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Multiplication2 +SELECT CASE (obj1%rank) +CASE (scalar) +#include "./include/ScalarOperatorReal.F90" +CASE (vector) +#include "./include/VectorOperatorReal.F90" +CASE (matrix) +#include "./include/MatrixOperatorReal.F90" +END SELECT +END PROCEDURE fevar_Multiplication2 + +!---------------------------------------------------------------------------- +! Multiplication +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Multiplication3 +SELECT CASE (obj1%rank) +CASE (scalar) +#include "./include/RealOperatorScalar.F90" +CASE (vector) +#include "./include/RealOperatorVector.F90" +CASE (matrix) +#include "./include/RealOperatorMatrix.F90" +END SELECT +END PROCEDURE fevar_Multiplication3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#undef _OP_ +END SUBMODULE MultiplicationMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 new file mode 100644 index 000000000..558a09ecd --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 @@ -0,0 +1,123 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_Method) Norm2Methods +USE IntegerUtility, ONLY: Get1DIndexFortran + +USE GlobalData, ONLY: Scalar, Vector, Matrix, & + Constant, Space, Time, & + SpaceTime, Nodal, Quadrature + +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE ReallocateUtility, ONLY: Reallocate + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! NORM2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_norm2 +REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:, :), r3(:, :, :), m3(:, :, :) + +INTEGER(I4B) :: jj, kk + +SELECT CASE (obj%vartype) + +CASE (constant) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(NORM2(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableConstant) + ELSE + ans = QuadratureVariable(NORM2(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableConstant) + END IF + +CASE (space) + + r2 = GET(obj, TypeFEVariableVector, TypeFEVariableSpace) + + CALL Reallocate(r1, SIZE(r2, 2)) + + DO jj = 1, SIZE(r1) + r1(jj) = NORM2(r2(:, jj)) + END DO + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(r1, & + typeFEVariableScalar, typeFEVariableSpace) + ELSE + ans = QuadratureVariable(r1, & + typeFEVariableScalar, typeFEVariableSpace) + END IF + +CASE (time) + + r2 = GET(obj, TypeFEVariableVector, TypeFEVariableTime) + + CALL Reallocate(r1, SIZE(r2, 2)) + + DO jj = 1, SIZE(r1) + r1(jj) = NORM2(r2(:, jj)) + END DO + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(r1, & + typeFEVariableScalar, typeFEVariableTime) + ELSE + ans = QuadratureVariable(r1, & + typeFEVariableScalar, typeFEVariableTime) + END IF + +CASE (spacetime) + + r3 = GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime) + + CALL Reallocate(r2, SIZE(r3, 2), SIZE(r3, 3)) + + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r2(jj, kk) = NORM2(r3(:, jj, kk)) + END DO + END DO + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableScalar, typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r2, & + typeFEVariableScalar, typeFEVariableSpaceTime) + END IF + +END SELECT +END PROCEDURE fevar_norm2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Norm2Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 new file mode 100644 index 000000000..800f72949 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.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 +! + +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 + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE PowerMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 new file mode 100644 index 000000000..6dbcbef79 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 @@ -0,0 +1,56 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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@SubtractionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 new file mode 100644 index 000000000..ab1f27b03 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 @@ -0,0 +1,142 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) SubtractionMethods + +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, & + Nodal, Quadrature +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE ReallocateUtility, ONLY: Reallocate + +#define _OP_ - + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Subtraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Subtraction1 +REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :) +INTEGER(I4B) :: jj, kk + +SELECT CASE (obj1%rank) + +CASE (scalar) + + SELECT CASE (obj2%rank) + + CASE (scalar) + +#include "./include/ScalarOperatorScalar.F90" + + CASE (vector) + +#include "./include/ScalarOperatorVector.F90" + + CASE (matrix) + +#include "./include/ScalarOperatorMatrix.F90" + END SELECT + +CASE (vector) + + SELECT CASE (obj2%rank) + + CASE (scalar) + +#include "./include/VectorOperatorScalar.F90" + + CASE (vector) + +#include "./include/VectorOperatorVector.F90" + END SELECT + +CASE (matrix) + + SELECT CASE (obj2%rank) + + CASE (scalar) + +#include "./include/MatrixOperatorScalar.F90" + + CASE (matrix) + +#include "./include/MatrixOperatorMatrix.F90" + END SELECT +END SELECT +END PROCEDURE fevar_Subtraction1 + +!---------------------------------------------------------------------------- +! Subtraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Subtraction2 + +SELECT CASE (obj1%rank) + +CASE (SCALAR) + +#include "./include/ScalarOperatorReal.F90" + +CASE (VECTOR) + +#include "./include/VectorOperatorReal.F90" + +CASE (MATRIX) + +#include "./include/MatrixOperatorReal.F90" +END SELECT +END PROCEDURE fevar_Subtraction2 + +!---------------------------------------------------------------------------- +! Subtraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Subtraction3 + +SELECT CASE (obj1%rank) + +CASE (SCALAR) + +#include "./include/RealOperatorScalar.F90" + +CASE (VECTOR) + +#include "./include/RealOperatorVector.F90" + +CASE (MATRIX) + +#include "./include/RealOperatorMatrix.F90" +END SELECT +END PROCEDURE fevar_Subtraction3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE SubtractionMethods +#undef _OP_ diff --git a/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 b/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 new file mode 100644 index 000000000..0f4640043 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 @@ -0,0 +1,50 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SELECT CASE (obj%vartype) +CASE (constant) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2)) + END IF +CASE (space) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3)) + END IF +CASE (time) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3)) + END IF +CASE (spacetime) + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4)) + ELSE + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4)) + END IF +END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 new file mode 100644 index 000000000..49ec28c4d --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 @@ -0,0 +1,129 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + SELECT CASE (obj2%vartype) + CASE (constant) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) + END IF + CASE (space) + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) + END DO + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) + ELSE + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) + END IF + DEALLOCATE (r2, r3) + CASE (time) + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj) + END DO + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) + END IF + DEALLOCATE (r2, r3) + CASE (spacetime) + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + r4 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r2(:, :) _OP_ r4(:, :, jj, kk) + END DO + END DO + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r4, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime) + END IF + DEALLOCATE (r2, r4) + END SELECT +CASE (space) + SELECT CASE (obj2%vartype) + CASE (constant) + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) + r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) + END DO + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableSpace) + ELSE + ans = QuadratureVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableSpace) + END IF + DEALLOCATE (r2, r3) + CASE (space) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) + END IF + END SELECT +CASE (time) + SELECT CASE (obj2%vartype) + CASE (constant) + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) + r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :) + END DO + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(r3, & + TypeFEVariableMatrix, TypeFEVariableTime) + END IF + DEALLOCATE (r2, r3) + CASE (time) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) + END IF + END SELECT +CASE (spacetime) + SELECT CASE (obj2%vartype) + CASE (constant) + r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant) + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(:, :) + END DO + END DO + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r4, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r4, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime) + END IF + DEALLOCATE (r2, r4) + CASE (spacetime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) + END IF + END SELECT +END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 new file mode 100644 index 000000000..74cb5c110 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 @@ -0,0 +1,34 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) + END IF +CASE (space) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) + END IF +CASE (time) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) + END IF +CASE (spacetime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) + END IF +END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 new file mode 100644 index 000000000..3b66f3643 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 @@ -0,0 +1,164 @@ +SELECT CASE (obj1%varType) + +CASE (constant) + + SELECT CASE (obj2%varType) + + CASE (constant) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2)) + END IF + + CASE (space) + + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1)) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2 _OP_ obj2%val(jj) + END DO + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) + ELSE + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) + END IF + + DEALLOCATE (r2, r3) + CASE (time) + + r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1)) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r2 _OP_ obj2%val(jj) + END DO + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) + END IF + + DEALLOCATE (r2, r3) + CASE (spacetime) + + r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime) + m2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant) + CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2)) + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = m2 _OP_ r2(jj, kk) + END DO + + END DO + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r4, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime) + END IF + + DEALLOCATE (r2, r4, m2) + END SELECT + +CASE (space) + + SELECT CASE (obj1%varType) + + CASE (constant) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3)) + END IF + + CASE (space) + + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) + ELSE + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace) + END IF + + DEALLOCATE (r3) + END SELECT + +CASE (time) + + SELECT CASE (obj1%varType) + + CASE (constant) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3)) + END IF + + CASE (time) + + r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime) + END IF + + DEALLOCATE (r3) + END SELECT + +CASE (spacetime) + + SELECT CASE (obj1%varType) + + CASE (constant) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4)) + END IF + + CASE (spacetime) + + r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime) + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(jj, kk) + END DO + + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r4, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime) + END IF + + DEALLOCATE (r2, r4) + END SELECT + +END SELECT diff --git a/src/submodules/FEVariable/src/include/MatrixPower.F90 b/src/submodules/FEVariable/src/include/MatrixPower.F90 new file mode 100644 index 000000000..1d6c8f911 --- /dev/null +++ b/src/submodules/FEVariable/src/include/MatrixPower.F90 @@ -0,0 +1,92 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! main +!! +SELECT CASE (obj%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:2)), & + & typeFEVariableMatrix, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj%val(:) ** n, obj%s(1:3)), & + & typeFEVariableMatrix, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF( obj%defineon .EQ. nodal ) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:) ** n, obj%s(1:4)), & + & typeFEVariableMatrix, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 new file mode 100644 index 000000000..9295afd5d --- /dev/null +++ b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 @@ -0,0 +1,34 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2)) + END IF +CASE (space) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3)) + END IF +CASE (time) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3)) + END IF +CASE (spacetime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4)) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4)) + END IF +END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 new file mode 100644 index 000000000..6e0fbc67c --- /dev/null +++ b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 @@ -0,0 +1,34 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) + END IF +CASE (space) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + END IF +CASE (time) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableTime) + END IF +CASE (spacetime) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + END IF +END SELECT diff --git a/src/submodules/FEVariable/src/include/RealOperatorVector.F90 b/src/submodules/FEVariable/src/include/RealOperatorVector.F90 new file mode 100644 index 000000000..69afa2912 --- /dev/null +++ b/src/submodules/FEVariable/src/include/RealOperatorVector.F90 @@ -0,0 +1,43 @@ +SELECT CASE (obj1%vartype) + +CASE (constant) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableVector, TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableVector, TypeFEVariableConstant) + END IF + +CASE (space) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), & + TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & + TypeFEVariableVector, TypeFEVariableSpace) + END IF + +CASE (time) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & + TypeFEVariableVector, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), & + TypeFEVariableVector, TypeFEVariableTime) + END IF + +CASE (spacetime) + + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), & + TypeFEVariableVector, TypeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), & + TypeFEVariableVector, TypeFEVariableSpaceTime) + END IF + +END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 b/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 new file mode 100644 index 000000000..47f10e592 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 @@ -0,0 +1,61 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +SELECT CASE (obj%vartype) +CASE (constant) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, & + typeFEVariableConstant) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, & + typeFEVariableConstant) +CASE (space) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpace) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpace) + +CASE (time) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableTime) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableTime) + +CASE (spacetime) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2)) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2)) +END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 new file mode 100644 index 000000000..3692e97ec --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 @@ -0,0 +1,186 @@ +SELECT CASE (obj1%vartype) + +CASE (constant) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2)) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2)) + + CASE (space) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3)) + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3)) + + CASE (time) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3)) + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3)) + + CASE (spacetime) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4)) + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4)) + + END SELECT + +CASE (space) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1)) + + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r2 + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r2, r3) + RETURN + END IF + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r2, r3) + + CASE (space) + + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace) + + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r3) + RETURN + END IF + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) + DEALLOCATE (r3) + + END SELECT + +CASE (time) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1)) + + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r2 + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r2, r3) + RETURN + END IF + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r2, r3) + + CASE (time) + + r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime) + DO jj = 1, SIZE(r3, 3) + r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r3) + RETURN + END IF + + ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime) + DEALLOCATE (r3) + + END SELECT + +CASE (spacetime) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + m2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant) + CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2)) + + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r2(jj, kk) _OP_ m2 + END DO + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, typeFEVariableMatrix, typeFEVariableSpaceTime) + DEALLOCATE (r2, m2, r4) + RETURN + END IF + + ans = QuadratureVariable(r4, typeFEVariableMatrix, & + typeFEVariableSpaceTime) + + DEALLOCATE (r2, m2, r4) + + CASE (spacetime) + + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + r4 = GET(obj2, typeFEVariableMatrix, typeFEVariableSpaceTime) + + DO kk = 1, SIZE(r4, 4) + DO jj = 1, SIZE(r4, 3) + r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:, :, jj, kk) + END DO + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r4, typeFEVariableMatrix, & + typeFEVariableSpaceTime) + DEALLOCATE (r2, r4) + RETURN + END IF + + ans = QuadratureVariable(r4, typeFEVariableMatrix, & + typeFEVariableSpaceTime) + DEALLOCATE (r2, r4) + + END SELECT + +END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 new file mode 100644 index 000000000..fa3e91c56 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 @@ -0,0 +1,34 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(obj1%val(1) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableConstant) + END IF +CASE (space) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpace) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpace) + END IF +CASE (time) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableTime) + END IF +CASE (spacetime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + END IF +END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 new file mode 100644 index 000000000..8e121f01d --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 @@ -0,0 +1,148 @@ +SELECT CASE (obj1%vartype) + +CASE (constant) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) + + RETURN + + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableConstant) + + CASE (space) + + IF (obj2%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + + CASE (time) + + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + + CASE (spacetime) + + IF (obj2%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2)) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2)) + + END SELECT + +CASE (space) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpace) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpace) + + CASE (space) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpace) + + END SELECT + +CASE (time) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + IF (obj1%defineon .EQ. Nodal) THEN + + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableTime) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableTime) + + CASE (time) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + RETURN + END IF + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableTime) + + END SELECT + +CASE (spacetime) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + RETURN + END IF + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + + CASE (spacetime) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + RETURN + END IF + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2)) + + END SELECT + +END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 new file mode 100644 index 000000000..594629b64 --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 @@ -0,0 +1,180 @@ +SELECT CASE (obj1%vartype) + +CASE (constant) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) + CASE (space) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2)) + + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2)) + CASE (time) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj2%s(1:2)) + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj2%s(1:2)) + + CASE (spacetime) + + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3)) + RETURN + END IF + + ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3)) + + END SELECT + +CASE (space) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + CALL Reallocate(r2, obj2%s(1), obj1%s(1)) + + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) + RETURN + END IF + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + + CASE (space) + + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) + + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) + RETURN + END IF + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + DEALLOCATE (r2) + + END SELECT + +CASE (time) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + CALL Reallocate(r2, obj2%s(1), obj1%s(1)) + + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + RETURN + END IF + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + + CASE (time) + + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) + + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj) + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + RETURN + END IF + + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) + DEALLOCATE (r2) + + END SELECT + +CASE (spacetime) + + SELECT CASE (obj2%vartype) + + CASE (constant) + + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + CALL Reallocate(r3, obj2%s(1), SIZE(r2, 1), SIZE(r2, 2)) + + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(1:obj2%len) + END DO + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) + + RETURN + END IF + + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) + + DEALLOCATE (r2, r3) + + CASE (spacetime) + r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime) + r3 = GET(obj2, typeFEVariableVector, typeFEVariableSpaceTime) + + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:, jj, kk) + END DO + END DO + + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) + DEALLOCATE (r2, r3) + RETURN + END IF + + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) + + DEALLOCATE (r2, r3) + + END SELECT + +END SELECT diff --git a/src/submodules/FEVariable/src/include/ScalarPower.F90 b/src/submodules/FEVariable/src/include/ScalarPower.F90 new file mode 100644 index 000000000..48f45c3dc --- /dev/null +++ b/src/submodules/FEVariable/src/include/ScalarPower.F90 @@ -0,0 +1,42 @@ +SELECT CASE (obj%vartype) + +CASE (constant) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1)**n, & + TypeFEVariableScalar, TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(obj%val(1)**n, & + TypeFEVariableScalar, TypeFEVariableConstant) + END IF + +CASE (space) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpace) + ELSE + ans = QuadratureVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpace) + END IF + +CASE (time) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableTime) + ELSE + ans = QuadratureVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableTime) + END IF + +CASE (spacetime) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2)) + ELSE + ans = QuadratureVariable(obj%val(1:obj%len)**n, & + TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2)) + END IF +END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorElemMethod.F90 b/src/submodules/FEVariable/src/include/VectorElemMethod.F90 new file mode 100644 index 000000000..8dbc238b0 --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorElemMethod.F90 @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +SELECT CASE (obj%vartype) +CASE (constant) + + IF (obj%defineon .EQ. nodal) THEN + + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableConstant) + + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableConstant) + +CASE (space) + + IF (obj%defineon .EQ. nodal) THEN + + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpace, obj%s(1:2)) + RETURN + + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpace, obj%s(1:2)) + +CASE (time) + + IF (obj%defineon .EQ. nodal) THEN + + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableTime, obj%s(1:2)) + + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableTime, obj%s(1:2)) + +CASE (spacetime) + + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3)) + RETURN + END IF + + ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), & + typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3)) + +END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 new file mode 100644 index 000000000..0aa58c55c --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 @@ -0,0 +1,34 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableConstant) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableConstant) + END IF +CASE (space) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2)) + END IF +CASE (time) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2)) + END IF +CASE (spacetime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, & + TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3)) + END IF +END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 new file mode 100644 index 000000000..74b2a8ad8 --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 @@ -0,0 +1,120 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + SELECT CASE (obj2%vartype) + CASE (constant) + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableConstant) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableConstant) + END IF + CASE (space) + CALL Reallocate(r2, obj1%s(1), obj2%s(1)) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj) + END DO + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) + ELSE + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + END IF + DEALLOCATE (r2) + CASE (time) + CALL Reallocate(r2, obj1%s(1), obj2%s(1)) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj) + END DO + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) + ELSE + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) + END IF + DEALLOCATE (r2) + CASE (spacetime) + r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) + CALL Reallocate(r3, obj1%s(1), SIZE(r2, 1), SIZE(r2, 2)) + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r2(jj, kk) + END DO + END DO + IF (obj2%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) + END IF + DEALLOCATE (r2, r3) + END SELECT +CASE (space) + SELECT CASE (obj1%vartype) + CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) + END IF + CASE (space) + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) + END DO + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace) + ELSE + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + END IF + DEALLOCATE (r2) + END SELECT +CASE (time) + SELECT CASE (obj1%vartype) + CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) + END IF + CASE (time) + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj) + END DO + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime) + ELSE + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime) + END IF + DEALLOCATE (r2) + END SELECT +CASE (spacetime) + SELECT CASE (obj1%vartype) + CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) + END IF + CASE (spacetime) + r3 = GET(obj1, typeFEVariableVector, typeFEVariableSpaceTime) + r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime) + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r3(:, jj, kk) _OP_ r2(jj, kk) + END DO + END DO + IF (obj1%defineon .EQ. Nodal) THEN + ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r3, typeFEVariableVector, & + typeFEVariableSpaceTime) + END IF + DEALLOCATE (r2, r3) + END SELECT +END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 new file mode 100644 index 000000000..32e88ebf9 --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 @@ -0,0 +1,130 @@ +SELECT CASE (obj1%vartype) +CASE (constant) + SELECT CASE (obj2%vartype) + CASE (constant) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableConstant) + END IF + CASE (space) + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj) + END DO + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) + ELSE + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) + END IF + DEALLOCATE (r2) + CASE (time) + r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj) + END DO + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableTime) + ELSE + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableTime) + END IF + DEALLOCATE (r2) + CASE (spacetime) + r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r3(:, jj, kk) + END DO + END DO + IF (obj2%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) + END IF + DEALLOCATE (r3) + + END SELECT +CASE (space) + SELECT CASE (obj2%vartype) + CASE (constant) + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len) + END DO + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) + ELSE + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableSpace) + END IF + DEALLOCATE (r2) + CASE (space) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2)) + END IF + END SELECT +CASE (time) + SELECT CASE (obj2%vartype) + CASE (constant) + r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) + DO jj = 1, SIZE(r2, 2) + r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len) + END DO + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r2, & + typeFEVariableVector, typeFEVariableTime) + ELSE + ans = QuadratureVariable(r2, & + typeFEVariableVector, typeFEVariableTime) + END IF + CASE (time) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableTime, obj1%s(1:2)) + END IF + END SELECT +CASE (spacetime) + SELECT CASE (obj2%vartype) + CASE (constant) + r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) + DO kk = 1, SIZE(r3, 3) + DO jj = 1, SIZE(r3, 2) + r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(1:obj2%len) + END DO + END DO + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(r3, & + typeFEVariableVector, typeFEVariableSpaceTime) + END IF + DEALLOCATE (r3) + + CASE (spacetime) + IF (obj1%defineon .EQ. nodal) THEN + ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) + ELSE + ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), & + typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3)) + END IF + END SELECT + +END SELECT diff --git a/src/submodules/FEVariable/src/include/VectorPower.F90 b/src/submodules/FEVariable/src/include/VectorPower.F90 new file mode 100644 index 000000000..83bc64b8d --- /dev/null +++ b/src/submodules/FEVariable/src/include/VectorPower.F90 @@ -0,0 +1,93 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! main +!! +SELECT CASE (obj%vartype) +!! +!! +!! +!! +CASE (constant) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable( & + & obj%val(:)**n, & + & typeFEVariableVector, & + & typeFEVariableConstant) + ELSE + ans = QuadratureVariable( & + & obj%val(:)**n, & + & typeFEVariableVector, & + & typeFEVariableConstant) + END IF +!! +!! +!! +!! +CASE (space) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableSpace) + END IF +!! +!! +!! +!! +CASE (time) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable( & + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + ELSE + ans = QuadratureVariable( & + & RESHAPE(obj%val(:)**n, obj%s(1:2)), & + & typeFEVariableVector, & + & typeFEVariableTime) + END IF +!! +!! +!! +!! +CASE (spacetime) + !! + IF (obj%defineon .EQ. nodal) THEN + ans = NodalVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + ELSE + ans = QuadratureVariable(& + & RESHAPE(obj%val(:)**n, obj%s(1:3)), & + & typeFEVariableVector, & + & typeFEVariableSpaceTime) + END IF +!! +!! +!! +!! +END SELECT diff --git a/src/submodules/FEVariable/src/include/matrix_constant.F90 b/src/submodules/FEVariable/src/include/matrix_constant.F90 new file mode 100644 index 000000000..bb2d804b9 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_constant.F90 @@ -0,0 +1,19 @@ +INTEGER(I4B) :: ii, jj, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/matrix_constant2.F90 b/src/submodules/FEVariable/src/include/matrix_constant2.F90 new file mode 100644 index 000000000..062b751b9 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_constant2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/matrix_space.F90 b/src/submodules/FEVariable/src/include/matrix_space.F90 new file mode 100644 index 000000000..0cd267920 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space.F90 @@ -0,0 +1,21 @@ +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO + +obj%s(1:3) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/matrix_space2.F90 b/src/submodules/FEVariable/src/include/matrix_space2.F90 new file mode 100644 index 000000000..d9cd89b84 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:3) = s(1:3) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/matrix_space_time.F90 b/src/submodules/FEVariable/src/include/matrix_space_time.F90 new file mode 100644 index 000000000..3a6463630 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space_time.F90 @@ -0,0 +1,23 @@ +INTEGER(I4B) :: ii, jj, kk, ll, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO ll = 1, SIZE(val, 4) + DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk, ll) + END DO + END DO + END DO +END DO + +obj%s(1:4) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 new file mode 100644 index 000000000..416f4d703 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:4) = s(1:4) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/matrix_time.F90 b/src/submodules/FEVariable/src/include/matrix_time.F90 new file mode 100644 index 000000000..a4b831d86 --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_time.F90 @@ -0,0 +1,21 @@ +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO + +obj%s(1:3) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Time diff --git a/src/submodules/FEVariable/src/include/matrix_time2.F90 b/src/submodules/FEVariable/src/include/matrix_time2.F90 new file mode 100644 index 000000000..aaa1007bb --- /dev/null +++ b/src/submodules/FEVariable/src/include/matrix_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:3) = s(1:3) +obj%defineOn = _DEFINEON_ +obj%rank = Matrix +obj%varType = Time diff --git a/src/submodules/FEVariable/src/include/scalar_constant.F90 b/src/submodules/FEVariable/src/include/scalar_constant.F90 new file mode 100644 index 000000000..628f7a7b6 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_constant.F90 @@ -0,0 +1,8 @@ +obj%len = 1 +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) +obj%val(1) = val +obj%s(1) = 1 +obj%defineOn = _DEFINEON_ +obj%rank = Scalar +obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/scalar_space.F90 b/src/submodules/FEVariable/src/include/scalar_space.F90 new file mode 100644 index 000000000..c43d15d52 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_space.F90 @@ -0,0 +1,8 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) +obj%val(1:obj%len) = val +obj%s(1) = SIZE(val) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/scalar_space_time.F90 b/src/submodules/FEVariable/src/include/scalar_space_time.F90 new file mode 100644 index 000000000..75ee2a726 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_space_time.F90 @@ -0,0 +1,18 @@ +INTEGER(I4B) :: ii, jj, kk + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +kk = 0 +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + kk = kk + 1 + obj%val(kk) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 new file mode 100644 index 000000000..e85818d99 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 @@ -0,0 +1,12 @@ +INTEGER(I4B) :: ii + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/scalar_time.F90 b/src/submodules/FEVariable/src/include/scalar_time.F90 new file mode 100644 index 000000000..1a7b0d3e3 --- /dev/null +++ b/src/submodules/FEVariable/src/include/scalar_time.F90 @@ -0,0 +1,8 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) +obj%val(1:obj%len) = val +obj%s(1) = SIZE(val) +obj%defineOn = _DEFINEON_ +obj%rank = SCALAR +obj%varType = Time diff --git a/src/submodules/FEVariable/src/include/vector_constant.F90 b/src/submodules/FEVariable/src/include/vector_constant.F90 new file mode 100644 index 000000000..42125ac15 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_constant.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len + +ALLOCATE (obj%val(obj%capacity)) +obj%val(1:obj%len) = val + +obj%s(1:1) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = Constant diff --git a/src/submodules/FEVariable/src/include/vector_space.F90 b/src/submodules/FEVariable/src/include/vector_space.F90 new file mode 100644 index 000000000..2d6a663ef --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space.F90 @@ -0,0 +1,18 @@ +INTEGER(I4B) :: ii, jj, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/vector_space2.F90 b/src/submodules/FEVariable/src/include/vector_space2.F90 new file mode 100644 index 000000000..a2e7c5cbf --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/vector_space_time.F90 b/src/submodules/FEVariable/src/include/vector_space_time.F90 new file mode 100644 index 000000000..e8ee7a797 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space_time.F90 @@ -0,0 +1,21 @@ +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 + +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO + +obj%s(1:3) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/vector_space_time2.F90 b/src/submodules/FEVariable/src/include/vector_space_time2.F90 new file mode 100644 index 000000000..a671d1408 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_space_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:3) = s(1:3) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = SpaceTime diff --git a/src/submodules/FEVariable/src/include/vector_time.F90 b/src/submodules/FEVariable/src/include/vector_time.F90 new file mode 100644 index 000000000..7cc4a4a7f --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_time.F90 @@ -0,0 +1,18 @@ +INTEGER(I4B) :: ii, jj, cnt + +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +cnt = 0 +DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO + +obj%s(1:2) = SHAPE(val) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = TIME diff --git a/src/submodules/FEVariable/src/include/vector_time2.F90 b/src/submodules/FEVariable/src/include/vector_time2.F90 new file mode 100644 index 000000000..b3e52b512 --- /dev/null +++ b/src/submodules/FEVariable/src/include/vector_time2.F90 @@ -0,0 +1,10 @@ +obj%len = SIZE(val) +obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +ALLOCATE (obj%val(obj%capacity)) + +obj%val(1:obj%len) = val(1:obj%len) + +obj%s(1:2) = s(1:2) +obj%defineOn = _DEFINEON_ +obj%rank = Vector +obj%varType = TIME diff --git a/src/submodules/FacetMatrix/CMakeLists.txt b/src/submodules/FacetMatrix/CMakeLists.txt new file mode 100644 index 000000000..4cb301a8c --- /dev/null +++ b/src/submodules/FacetMatrix/CMakeLists.txt @@ -0,0 +1,32 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/FacetMatrix_Method@FacetMatrix1Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix2Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix3Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix4Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix5Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix11Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix12Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix13Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix14Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix15Methods.F90 + ${src_path}/FacetMatrix_Method@FacetMatrix21Methods.F90 +) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 new file mode 100644 index 000000000..b9cf81703 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 @@ -0,0 +1,306 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix11Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix11_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C1( :, : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns = nns1 + nns2 + nsd = masterElemSD%refelem%nsd + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips) + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + ans = ans + & + & realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + !! + END DO + !! + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1 ) + !! +END PROCEDURE FacetMatrix11_1 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix11_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), slaveC1(:,:), & + & C1( :, : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + masterC1 = masterC1 * muMaster + slaveC1 = slaveC1 * muSlave + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips) + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + ans = ans & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + !! + END DO + !! + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1 ) + !! +END PROCEDURE FacetMatrix11_2 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix11_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), taubar( : ), C1( :, : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) + !! + masterC1 = masterC1 * muMaster + slaveC1 = slaveC1 * muSlave + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips) + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * & + & taubar + !! + DO ips = 1, nips + ans = ans & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + !! + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + !! + DEALLOCATE( realval, masterC1, slaveC1, taubar, C1 ) + !! +END PROCEDURE FacetMatrix11_3 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix11_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & muMasterBar( : ), muSlaveBar( : ), slaveC1( :, : ), C1( :, : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave ) + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips ) + slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips) + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + ans = ans & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + !! + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1, muMasterBar, muSlaveBar ) + !! +END PROCEDURE FacetMatrix11_4 + +!---------------------------------------------------------------------------- +! FacetMatrix11 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix11_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & muMasterBar( : ), muSlaveBar( : ), tauBar( : ), slaveC1( :, : ), & + & C1(:,:) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + ALLOCATE( C1( nns, nips ), ans( nns, nns ) ) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauBar, & + & val=tauvar ) + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips ) + slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips) + END DO + !! + realval = masterElemSD%js*masterElemSD%ws*masterElemSD%thickness*tauBar + !! + DO ips = 1, nips + ans = ans & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + !! + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + !! + DEALLOCATE( realval, masterC1, slaveC1, muMasterBar, & + & muSlaveBar, C1 ) + !! +END PROCEDURE FacetMatrix11_5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE FacetMatrix11Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 new file mode 100644 index 000000000..85cd9bb10 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 @@ -0,0 +1,157 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix12Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix12_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ) + INTEGER( I4B ) :: ips, nips, nns, nsd + !! + nns = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + CALL Reallocate(ans, nns, nns) + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=C1, & + & val=elemsd%normal ) + realval = elemsd%js * elemsd%ws * elemsd%thickness + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + DEALLOCATE( realval, C1 ) + !! +END PROCEDURE FacetMatrix12_1 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix12_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ) + INTEGER( I4B ) :: ips, nips, nns, nsd + !! + nns = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + CALL Reallocate(ans, nns, nns) + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=C1, & + & val=elemsd%normal ) + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + DEALLOCATE( realval, C1 ) + !! +END PROCEDURE FacetMatrix12_2 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix12_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), taubar( : ) + INTEGER( I4B ) :: ips, nips, nns, nsd + !! + nns = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + CALL Reallocate(ans, nns, nns) + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=C1, & + & val=elemsd%normal ) + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + DEALLOCATE( realval, C1, taubar ) + !! +END PROCEDURE FacetMatrix12_3 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix12_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), muBar( : ) + INTEGER( I4B ) :: ips, nips, nns, nsd + !! + nns = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + CALL Reallocate(ans, nns, nns) + CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal ) + CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) + realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + DEALLOCATE( realval, C1, muBar ) + !! +END PROCEDURE FacetMatrix12_4 + +!---------------------------------------------------------------------------- +! FacetMatrix12 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix12_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), & + & muBar( : ), tauBar( : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns, nsd + !! + nns = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + CALL Reallocate(ans, nns, nns) + CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal ) + CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) + CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar ) + realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + END DO + IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) + DEALLOCATE( realval, C1, muBar ) + !! +END PROCEDURE FacetMatrix12_5 + +END SUBMODULE FacetMatrix12Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 new file mode 100644 index 000000000..124c1dc20 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 @@ -0,0 +1,276 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix13Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix13_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nns2 = SIZE( elemsd%N, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & + & elemsd%N( :, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1 ) + !! +END PROCEDURE FacetMatrix13_1 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix13_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nns2 = SIZE( elemsd%N, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & + & elemsd%N( :, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1 ) + !! +END PROCEDURE FacetMatrix13_2 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix13_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nns2 = SIZE( elemsd%N, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & + & elemsd%N( :, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, taubar ) + !! +END PROCEDURE FacetMatrix13_3 + + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix13_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ), mubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nns2 = SIZE( elemsd%N, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & + & elemsd%N( :, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, mubar ) + !! +END PROCEDURE FacetMatrix13_4 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix13_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ), mubar( : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nns2 = SIZE( elemsd%N, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & + & elemsd%N( :, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, mubar, taubar ) + !! +END PROCEDURE FacetMatrix13_5 + +END SUBMODULE FacetMatrix13Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 new file mode 100644 index 000000000..805bf3938 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 @@ -0,0 +1,276 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix14Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix14_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1 ) + !! +END PROCEDURE FacetMatrix14_1 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix14_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1 ) + !! +END PROCEDURE FacetMatrix14_2 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix14_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + !! + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, taubar ) + !! +END PROCEDURE FacetMatrix14_3 + + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix14_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ), mubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar + !! + DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) + END DO + END DO + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, mubar ) + !! +END PROCEDURE FacetMatrix14_4 + +!---------------------------------------------------------------------------- +! FacetMatrix14 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix14_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & m4( :, :, :, : ), mubar( : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar + !! + DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, mubar, taubar ) + !! +END PROCEDURE FacetMatrix14_5 + +END SUBMODULE FacetMatrix14Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 new file mode 100644 index 000000000..45b5cddd3 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 @@ -0,0 +1,501 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix15Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix15_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + IF( opt .EQ. 1 ) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) + m4 = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) + !! + C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) + C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) + !! +END PROCEDURE FacetMatrix15_1 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix15_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + IF( opt .EQ. 1 ) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) + m4 = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + masterC1 = muMaster * masterC1 + slaveC1 = muSlave * slaveC1 + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) + !! + C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) + C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) + !! +END PROCEDURE FacetMatrix15_2 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix15_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + IF( opt .EQ. 1 ) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) + m4 = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + masterC1 = muMaster * masterC1 + slaveC1 = muSlave * slaveC1 + !! + DO ips = 1, nips + !! + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) + !! + C2(1:nns1, :, ips)=(0.5_DFP*tauMaster)*masterElemSD%dNdXt(:,:,ips) + C2(nns1+1:, :, ips)=(0.5_DFP*tauSlave)*slaveElemSD%dNdXt(:, :, slaveips) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) + !! +END PROCEDURE FacetMatrix15_3 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix15_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & muMasterBar( : ), muSlaveBar( : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + IF( opt .EQ. 1 ) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + !! + ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) + m4 = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave ) + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips ) + C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) + !! + C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) + C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, muMasterBar, & + & muSlaveBar ) + !! +END PROCEDURE FacetMatrix15_4 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix15_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & tauMasterBar( : ), tauSlaveBar( : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + IF( opt .EQ. 1 ) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) + m4 = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave ) + !! + masterC1 = muMaster * masterC1 + slaveC1 = muSlave * slaveC1 + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = masterC1(:, ips) + C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) + !! + C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) + C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) & + & *slaveElemSD%dNdXt(:, :, slaveips) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & + & tauSlaveBar ) + !! +END PROCEDURE FacetMatrix15_5 + +!---------------------------------------------------------------------------- +! FacetMatrix15 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix15_6 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & tauMasterBar( : ), tauSlaveBar( : ), muMasterBar( : ), & + & muSlaveBar( : ), C( : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + IF( opt .EQ. 1 ) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) + m4 = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave ) + !! + DO ips = 1, nips + slaveips = quadMap( ips ) + C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips ) + C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) + !! + C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) + C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) & + & *slaveElemSD%dNdXt(:, :, slaveips) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & + & tauSlaveBar, muMasterBar, muSlaveBar ) + !! +END PROCEDURE FacetMatrix15_6 + +END SUBMODULE FacetMatrix15Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 new file mode 100644 index 000000000..eb6aed951 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 @@ -0,0 +1,373 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix1Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix1_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal ) + !! + i3 = eye( nsd ) + !! + CALL Reallocate( G12, nns1+nns2, nsd, nsd ) + CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 ) + !! +END PROCEDURE FacetMatrix1_1 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix1_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal ) + !! + i3 = eye( nsd ) + !! + CALL Reallocate( G12, nns1+nns2, nsd, nsd ) + CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = muMaster*OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = muSlave*OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 ) + !! +END PROCEDURE FacetMatrix1_2 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix1_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & + & taubar( : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal ) + !! + CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) + !! + i3 = eye( nsd ) + !! + CALL Reallocate( G12, nns1+nns2, nsd, nsd ) + CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & + & * taubar + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = muMaster*OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = muSlave*OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, taubar ) + !! +END PROCEDURE FacetMatrix1_3 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix1_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & + & muMasterBar( : ), muSlaveBar( : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal ) + !! + CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, & + & val=muMaster ) + CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, & + & val=muSlave ) + !! + i3 = eye( nsd ) + !! + CALL Reallocate( G12, nns1+nns2, nsd, nsd ) + CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & + & muSlaveBar ) + !! +END PROCEDURE FacetMatrix1_4 + +!---------------------------------------------------------------------------- +! FacetMatrix1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix1_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & + & muMasterBar( : ), muSlaveBar( : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal ) + !! + CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, & + & val=muMaster ) + CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, & + & val=muSlave ) + CALL getInterpolation( obj=masterElemSD, interpol=taubar, val=tauvar ) + !! + i3 = eye( nsd ) + !! + CALL Reallocate( G12, nns1+nns2, nsd, nsd ) + CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & + & * taubar + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & + & muSlaveBar, taubar ) + !! +END PROCEDURE FacetMatrix1_5 + +END SUBMODULE FacetMatrix1Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 new file mode 100644 index 000000000..275164a2f --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 @@ -0,0 +1,127 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix21Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix21 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix21_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) + INTEGER( I4B ) :: ips, nips, nns2, nns1 + !! + nns1 = SIZE( elemsd%N, 1 ) + nns2 = SIZE( elemsd%dNdXt, 1 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + ALLOCATE( ans( nns1, nns2 ) ) + ans = 0.0_DFP + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness + !! + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips )) + END DO + !! + DEALLOCATE( realval, masterC1 ) + !! +END PROCEDURE FacetMatrix21_1 + +!---------------------------------------------------------------------------- +! FacetMatrix21 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix21_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) + INTEGER( I4B ) :: ips, nips, nns2, nns1 + !! + nns1 = SIZE( elemsd%N, 1 ) + nns2 = SIZE( elemsd%dNdXt, 1 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + ALLOCATE( ans( nns1, nns2 ) ) + ans = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar + !! + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips )) + END DO + !! + DEALLOCATE( realval, masterC1 ) + !! +END PROCEDURE FacetMatrix21_2 + +!---------------------------------------------------------------------------- +! FacetMatrix21 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix21_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%N, 1 ) + nns2 = SIZE( elemsd%dNdXt, 1 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + ALLOCATE( ans( nns1, nns2 ) ) + ans = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar + !! + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & masterC1( :, ips )) + END DO + !! + DEALLOCATE( realval, masterC1, taubar ) + !! +END PROCEDURE FacetMatrix21_3 + +END SUBMODULE FacetMatrix21Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 new file mode 100644 index 000000000..0f18edd6e --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 @@ -0,0 +1,127 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix22Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix22 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix22_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) + INTEGER( I4B ) :: ips, nips, nns2, nns1 + !! + nns1 = SIZE( elemsd%N, 1 ) + nns2 = SIZE( elemsd%dNdXt, 1 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + ALLOCATE( ans( nns2, nns1 ) ) + ans = 0.0_DFP + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness + !! + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ), & + & elemsd%N( :, ips )) + END DO + !! + DEALLOCATE( realval, masterC1 ) + !! +END PROCEDURE FacetMatrix22_1 + +!---------------------------------------------------------------------------- +! FacetMatrix22 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix22_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) + INTEGER( I4B ) :: ips, nips, nns2, nns1 + !! + nns1 = SIZE( elemsd%N, 1 ) + nns2 = SIZE( elemsd%dNdXt, 1 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + ALLOCATE( ans( nns2, nns1 ) ) + ans = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar + !! + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ), & + & elemsd%N( :, ips )) + END DO + !! + DEALLOCATE( realval, masterC1 ) + !! +END PROCEDURE FacetMatrix22_2 + +!---------------------------------------------------------------------------- +! FacetMatrix22 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix22_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%N, 1 ) + nns2 = SIZE( elemsd%dNdXt, 1 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + ALLOCATE( ans( nns2, nns ) ) + ans = 0.0_DFP + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar + !! + DO ips = 1, nips + ans( :, : ) = ans( :, : ) & + & + realval( ips ) * OUTERPROD( & + & masterC1( :, ips ), & + & elemsd%N( :, ips )) + END DO + !! + DEALLOCATE( realval, masterC1, taubar ) + !! +END PROCEDURE FacetMatrix22_3 + +END SUBMODULE FacetMatrix22Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 new file mode 100644 index 000000000..37485f0e5 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 @@ -0,0 +1,273 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix2Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix2_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns1, nsd, nsd) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, G12, m4 ) + !! +END PROCEDURE FacetMatrix2_1 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix2_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns1, nsd, nsd) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, G12, m4 ) + !! +END PROCEDURE FacetMatrix2_2 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix2_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), taubar( : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns1, nsd, nsd) + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, G12, taubar, m4 ) + !! +END PROCEDURE FacetMatrix2_3 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix2_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), muBar( : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal ) + CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns1, nsd, nsd) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, G12, muBar, m4 ) + !! +END PROCEDURE FacetMatrix2_4 + +!---------------------------------------------------------------------------- +! FacetMatrix2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix2_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), muBar( : ), & + & tauBar( : ) + INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + !! + CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal ) + CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) + CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns1, nsd, nsd) + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * MATMUL( G12( :, :, ii ), & + & TRANSPOSE( G12( :, :, jj ) ) ) + !! + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, G12, muBar, taubar, m4 ) + !! +END PROCEDURE FacetMatrix2_5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE FacetMatrix2Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 new file mode 100644 index 000000000..bc9995afb --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 @@ -0,0 +1,324 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix3Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix3_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + nns2 = SIZE( elemsd%N, 1 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & + & elemsd%N( :, ips ) ) + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, i3 ) + !! +END PROCEDURE FacetMatrix3_1 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix3_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + nns2 = SIZE( elemsd%N, 1 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & + & elemsd%N( :, ips ) ) + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12 ) + !! +END PROCEDURE FacetMatrix3_2 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix3_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + nns2 = SIZE( elemsd%N, 1 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & + & elemsd%N( :, ips ) ) + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 ) + !! +END PROCEDURE FacetMatrix3_3 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix3_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + nns2 = SIZE( elemsd%N, 1 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & + & elemsd%N( :, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 ) + !! +END PROCEDURE FacetMatrix3_4 + +!---------------------------------------------------------------------------- +! FacetMatrix3 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix3_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + nns2 = SIZE( elemsd%N, 1 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & + & elemsd%N( :, ips ) ) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar ) + !! +END PROCEDURE FacetMatrix3_5 + +END SUBMODULE FacetMatrix3Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 new file mode 100644 index 000000000..c685e4619 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 @@ -0,0 +1,334 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix4Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix4_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, i3 ) + !! +END PROCEDURE FacetMatrix4_1 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix4_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, i3 ) + !! +END PROCEDURE FacetMatrix4_2 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix4_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 ) + !! +END PROCEDURE FacetMatrix4_3 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix4_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : ) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 ) + !! +END PROCEDURE FacetMatrix4_4 + +!---------------------------------------------------------------------------- +! FacetMatrix4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix4_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3(:,:) + INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! + nns2 = SIZE( elemsd%N, 1 ) + nns1 = SIZE( elemsd%dNdXt, 1 ) + nsd = SIZE( elemsd%dNdXt, 2 ) + nips = SIZE( elemsd%dNdXt, 3 ) + i3 = Eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + CALL Reallocate(G12, nns1, nsd, nsd) + CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! + CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal ) + !! + CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! + realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar + !! + DO ips = 1, nips + !! + G12 = OUTERPROD( masterC1( :, ips ), i3 ) & + & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & + & elemsd%normal( 1:nsd, ips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval( ips ) * OUTERPROD( & + & elemsd%N( :, ips ), & + & MATMUL( & + & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar, i3 ) + !! +END PROCEDURE FacetMatrix4_5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE FacetMatrix4Methods \ No newline at end of file diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 new file mode 100644 index 000000000..ef1f352f7 --- /dev/null +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 @@ -0,0 +1,602 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(FacetMatrix_Method) FacetMatrix5Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix5_1 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & G12( :, :, : ), i3(:,:) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + i3 = eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( & + & G12( nns, nsd, nsd ), & + & C2( nsd, nns, nips ), & + & m4( nns, nns, nsd1, nsd2 )) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + DO ips = 1, nips + !! + slaveips = quadMap( ips ) + C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips)) + C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) + !! +END PROCEDURE FacetMatrix5_1 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix5_2 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & G12( :, :, : ), i3(:,:) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + i3 = eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( & + & G12( nns, nsd, nsd ), & + & C2( nsd, nns, nips ), & + & m4( nns, nns, nsd1, nsd2 )) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + masterC1 = muMaster * masterC1 + slaveC1 = muSlave * slaveC1 + !! + DO ips = 1, nips + !! + slaveips = quadMap( ips ) + C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips)) + C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) + !! +END PROCEDURE FacetMatrix5_2 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix5_3 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & G12( :, :, : ), i3(:,:) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + i3 = eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( & + & G12( nns, nsd, nsd ), & + & C2( nsd, nns, nips ), & + & m4( nns, nns, nsd1, nsd2 )) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + masterC1 = muMaster * masterC1 + slaveC1 = muSlave * slaveC1 + !! + DO ips = 1, nips + !! + slaveips = quadMap( ips ) + C2(:,1:nns1,ips)=(0.5_DFP*tauMaster)*TRANSPOSE( & + & masterElemSD%dNdXt(:,:,ips)) + C2(:,nns1+1:,ips)=(0.5_DFP*tauSlave)*TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) + !! +END PROCEDURE FacetMatrix5_3 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix5_4 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & G12( :, :, : ), i3(:,:), muMasterBar( : ), muSlaveBar( : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + i3 = eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( & + & G12( nns, nsd, nsd ), & + & C2( nsd, nns, nips ), & + & m4( nns, nns, nsd1, nsd2 )) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave ) + !! + DO ips = 1, nips + masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips ) + slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips ) + END DO + !! + DO ips = 1, nips + !! + slaveips = quadMap( ips ) + C2(:,1:nns1,ips)=(0.5_DFP)*TRANSPOSE( & + & masterElemSD%dNdXt(:,:,ips)) + C2(:,nns1+1:,ips)=(0.5_DFP)*TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & + & muMasterBar, muSlaveBar, G12 ) + !! +END PROCEDURE FacetMatrix5_4 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix5_5 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + i3 = eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( & + & G12( nns, nsd, nsd ), & + & C2( nsd, nns, nips ), & + & m4( nns, nns, nsd1, nsd2 )) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave ) + !! + masterC1 = muMaster * masterC1 + slaveC1 = muSlave * slaveC1 + !! + DO ips = 1, nips + !! + slaveips = quadMap( ips ) + !! + C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( & + & masterElemSD%dNdXt(:,:,ips)) + !! + C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & + & tauMasterBar, tauSlaveBar, G12 ) + !! +END PROCEDURE FacetMatrix5_5 + +!---------------------------------------------------------------------------- +! FacetMatrix5 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix5_6 + !! + REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & + & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & + & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : ), & + & muMasterBar( : ), muSlaveBar( : ) + INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! + nns1 = SIZE( masterElemSD%dNdXt, 1 ) + nsd = SIZE( masterElemSD%dNdXt, 2 ) + nips = SIZE( masterElemSD%dNdXt, 3 ) + nns2 = SIZE( slaveElemSD%dNdXt, 1 ) + nns = nns1 + nns2 + !! + i3 = eye( nsd ) + !! + IF( opt .EQ. 1 ) THEN + nsd1 = nsd + nsd2 = 1 + ELSE + nsd1 = 1 + nsd2 = nsd + END IF + !! + ALLOCATE( & + & G12( nns, nsd, nsd ), & + & C2( nsd, nns, nips ), & + & m4( nns, nns, nsd1, nsd2 )) + !! + CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal ) + !! + CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave ) + !! + CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster ) + !! + CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave ) + !! + DO ips = 1, nips + masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips ) + slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips ) + END DO + !! + DO ips = 1, nips + !! + slaveips = quadMap( ips ) + !! + C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( & + & masterElemSD%dNdXt(:,:,ips)) + !! + C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) + !! + END DO + !! + realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! + DO ips = 1, nips + !! + slaveips=quadMap(ips) + !! + G12( 1:nns1, :, : ) = OUTERPROD( & + & masterC1( :, ips ), i3 ) & + & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & + & masterElemSD%normal( 1:nsd, ips ) ) + !! + G12( nns1+1:, :, : ) = OUTERPROD( & + & slaveC1( :, slaveips ), i3 ) & + & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & + & slaveElemSD%normal( 1:nsd, slaveips ) ) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 + !! + m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & + & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + !! + END DO + END DO + !! + END DO + !! + CALL Convert( from=m4, to=ans ) + !! + DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & + & tauMasterBar, tauSlaveBar, muMasterBar, muSlaveBar, G12 ) + !! +END PROCEDURE FacetMatrix5_6 + +END SUBMODULE FacetMatrix5Methods \ No newline at end of file diff --git a/src/submodules/ForceVector/CMakeLists.txt b/src/submodules/ForceVector/CMakeLists.txt new file mode 100644 index 000000000..095ef0197 --- /dev/null +++ b/src/submodules/ForceVector/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/ForceVector_Method@Methods.F90 + ) diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 new file mode 100644 index 000000000..c090b621c --- /dev/null +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -0,0 +1,203 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ForceVector_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_1 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ips + +! main +realval = test%js * test%ws * test%thickness +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_1 + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_2 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ips + +! main +CALL GetInterpolation(obj=test, interpol=realval, val=c) +realval = test%js * test%ws * test%thickness * realval +CALL Reallocate(ans, SIZE(test%N, 1)) + +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) +END DO + +DEALLOCATE (realval) + +END PROCEDURE ForceVector_2b + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_3 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: cbar(:, :) +INTEGER(I4B) :: ips + +! main +CALL GetInterpolation(obj=test, interpol=cbar, val=c) +realval = test%js * test%ws * test%thickness +CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) + +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 ForceVector_4 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: cbar(:, :, :) +INTEGER(I4B) :: ips + +! main +CALL GetInterpolation(obj=test, interpol=cbar, val=c) +realval = test%js * test%ws * test%thickness +CALL Reallocate(ans, SIZE(cbar, 1), SIZE(cbar, 2), 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_4 + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_5 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c1bar(:) +REAL(DFP), ALLOCATABLE :: c2bar(:) +INTEGER(I4B) :: ips + +! main +CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) +CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) +realval = test%js * test%ws * test%thickness * c1bar * c2bar +CALL Reallocate(ans, SIZE(test%N, 1)) + +DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test%N(:, ips) +END DO + +DEALLOCATE (realval, c1bar, c2bar) +END PROCEDURE ForceVector_5 + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_6 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c1bar(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +INTEGER(I4B) :: ips + +! main +CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) +CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) +realval = test%js * test%ws * test%thickness * c1bar +CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test%N, 1)) + +DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * OUTERPROD(c2bar(:, ips), test%N(:, ips)) +END DO + +DEALLOCATE (realval, c1bar, c2bar) +END PROCEDURE ForceVector_6 + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_7 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c1bar(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) +INTEGER(I4B) :: ips + +! main +CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) +CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) +realval = test%js * test%ws * test%thickness * c1bar +CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test%N, 1)) + +DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * OUTERPROD(c2bar(:, :, ips), test%N(:, ips)) +END DO + +DEALLOCATE (realval, c1bar, c2bar) +END PROCEDURE ForceVector_7 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt new file mode 100644 index 000000000..74342d10f --- /dev/null +++ b/src/submodules/Geometry/CMakeLists.txt @@ -0,0 +1,39 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/ReferenceElement_Method@ConstructorMethods.F90 + ${src_path}/ReferenceElement_Method@IOMethods.F90 + ${src_path}/ReferenceElement_Method@FacetElementMethods.F90 + ${src_path}/ReferenceElement_Method@GeometryMethods.F90 + ${src_path}/ReferenceElement_Method@ElementNameMethods.F90 + ${src_path}/ReferenceElement_Method@LocalNodeCoordsMethods.F90 + ${src_path}/ReferenceElement_Method@EnquireMethods.F90 + ${src_path}/ReferenceElement_Method@VTKMethods.F90 + ${src_path}/ReferencePoint_Method@Methods.F90 + ${src_path}/ReferenceLine_Method@Methods.F90 + ${src_path}/Line_Method@Methods.F90 + ${src_path}/ReferenceTriangle_Method@Methods.F90 + ${src_path}/Triangle_Method@Methods.F90 + ${src_path}/Plane_Method@Methods.F90 + ${src_path}/ReferenceQuadrangle_Method@Methods.F90 + ${src_path}/ReferenceTetrahedron_Method@Methods.F90 + ${src_path}/ReferenceHexahedron_Method@Methods.F90 + ${src_path}/ReferencePrism_Method@Methods.F90 + ${src_path}/ReferencePyramid_Method@Methods.F90) diff --git a/src/submodules/Geometry/src/Line_Method@Methods.F90 b/src/submodules/Geometry/src/Line_Method@Methods.F90 new file mode 100644 index 000000000..93e5046f8 --- /dev/null +++ b/src/submodules/Geometry/src/Line_Method@Methods.F90 @@ -0,0 +1,339 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(Line_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE line_exp_is_degenerate_nd +ans = (all(p1(1:dim_num) == p2(1:dim_num))) +END PROCEDURE line_exp_is_degenerate_nd + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE line_exp2imp_2d +integer(i4b), parameter :: dim_num = 2 +real(dfp) norm +! +! Take care of degenerate cases. +! +if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + return +end if + +a = p2(2) - p1(2) +b = p1(1) - p2(1) +c = p2(1) * p1(2) - p1(1) * p2(2) + +norm = a * a + b * b + c * c + +if (0.0D+00 < norm) then + a = a / norm + b = b / norm + c = c / norm +end if + +if (a < 0.0D+00) then + a = -a + b = -b + c = -c +end if + +END PROCEDURE line_exp2imp_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure line_imp_is_degenerate_2d +ans = (a * a + b * b == 0.0D+00) +end procedure line_imp_is_degenerate_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure lines_imp_int_2d +integer(kind=4), parameter :: dim_num = 2 +real(kind=8) a(dim_num, dim_num + 1) +integer(kind=4) info +! +p(1:dim_num) = 0.0D+00 +! +! Refuse to handle degenerate lines. +! +if (line_imp_is_degenerate_2d(a1, b1, c1)) then + ival = -1 + return +end if +! +if (line_imp_is_degenerate_2d(a2, b2, c2)) then + ival = -2 + return +end if +! +! Set up and solve a linear system. +! +a(1, 1) = a1 +a(1, 2) = b1 +a(1, 3) = -c1 +a(2, 1) = a2 +a(2, 2) = b2 +a(2, 3) = -c2 +! +call r8mat_solve(2, 1, a, info) +! +! If the inverse exists, then the lines intersect at the solution point. +! +if (info == 0) then + + ival = 1 + p(1:dim_num) = a(1:dim_num, 3) +! +! If the inverse does not exist, then the lines are parallel +! or coincident. Check for parallelism by seeing if the +! C entries are in the same ratio as the A or B entries. +! +else + ival = 0 + if (a1 == 0.0D+00) then + if (b2 * c1 == c2 * b1) then + ival = 2 + end if + else + if (a2 * c1 == c2 * a1) then + ival = 2 + end if + end if +end if +! +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure line_exp_perp_2d +integer(kind=4), parameter :: dim_num = 2 +real(kind=8) bot +real(kind=8) t +! +flag = .false. +if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + flag = .true. + p4(1:2) = r8_huge() + return +end if +! +bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) +! +! (P3-P1) dot (P2-P1) = Norm(P3-P1) * Norm(P2-P1) * Cos(Theta). +! +! (P3-P1) dot (P2-P1) / Norm(P3-P1)^2 = normalized coordinate T +! of the projection of (P3-P1) onto (P2-P1). +! +t = sum((p1(1:dim_num) - p3(1:dim_num)) & + * (p1(1:dim_num) - p2(1:dim_num))) / bot +! +p4(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +! +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure lines_exp_int_2d +integer(kind=4), parameter :: dim_num = 2 +real(kind=8) a1 +real(kind=8) a2 +real(kind=8) b1 +real(kind=8) b2 +real(kind=8) c1 +real(kind=8) c2 +logical(kind=4) point_1 +logical(kind=4) point_2 +! +ival = 0 +p(1:dim_num) = 0.0D+00 +! +! Check whether either line is a point. +! +if (all(p1(1:dim_num) == p2(1:dim_num))) then + point_1 = .true. +else + point_1 = .false. +end if + +if (all(q1(1:dim_num) == q2(1:dim_num))) then + point_2 = .true. +else + point_2 = .false. +end if +! +! Convert the lines to ABC format. +! +if (.not. point_1) then + call line_exp2imp_2d(p1, p2, a1, b1, c1) +end if + +if (.not. point_2) then + call line_exp2imp_2d(q1, q2, a2, b2, c2) +end if +! +! Search for intersection of the lines. +! +if (point_1 .and. point_2) then + if (all(p1(1:dim_num) == q1(1:dim_num))) then + ival = 1 + p(1:dim_num) = p1(1:dim_num) + end if +else if (point_1) then + if (a2 * p1(1) + b2 * p1(2) == c2) then + ival = 1 + p(1:dim_num) = p1(1:dim_num) + end if +else if (point_2) then + if (a1 * q1(1) + b1 * q1(2) == c1) then + ival = 1 + p(1:dim_num) = q1(1:dim_num) + end if +else + call lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) +end if +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure segment_point_dist_2d +integer(kind=4), parameter :: dim_num = 2 +real(kind=8) bot +real(kind=8) pn(dim_num) +real(kind=8) t +! +! If the line segment is actually a point, then the answer is easy. +! +if (all(p1(1:dim_num) == p2(1:dim_num))) then + t = 0.0D+00 +else + bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) + t = sum((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) / bot + t = max(t, 0.0D+00) + t = min(t, 1.0D+00) +end if +! +pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure segment_point_dist_3d +integer(i4b), parameter :: dim_num = 3 +real(dfp) bot +real(dfp) pn(dim_num) +real(dfp) t +! +! If the line segment is actually a point, then the answer is easy. +! +if (all(p1(1:dim_num) == p2(1:dim_num))) then + t = 0.0D+00 +else + bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) + t = sum((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) / bot + t = max(t, 0.0D+00) + t = min(t, 1.0D+00) +end if + +pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure line_exp_point_dist_signed_2d +integer(kind=4), parameter :: dim_num = 2 +real(kind=8) a +real(kind=8) b +real(kind=8) c +! +! If the explicit line degenerates to a point, the computation is easy. +! +if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + dist_signed = sqrt(sum((p1(1:dim_num) - p(1:dim_num))**2)) +! +! Convert the explicit line to the implicit form A * P(1) + B * P(2) + C = 0. +! This makes the computation of the signed distance to (X,Y) easy. +! +else + a = p2(2) - p1(2) + b = p1(1) - p2(1) + c = p2(1) * p1(2) - p1(1) * p2(2) + dist_signed = (a * p(1) + b * p(2) + c) / sqrt(a * a + b * b) +end if +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure segment_point_near_2d +integer(kind=4), parameter :: dim_num = 2 +real(kind=8) bot +! +! If the line segment is actually a point, then the answer is easy. +! +if (all(p1(1:dim_num) == p2(1:dim_num))) then + t = 0.0D+00 +else + bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) + t = sum((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) / bot + t = max(t, 0.0D+00) + t = min(t, 1.0D+00) +end if +! +pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#include "./inc/aux.inc" + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/Plane_Method@Methods.F90 b/src/submodules/Geometry/src/Plane_Method@Methods.F90 new file mode 100644 index 000000000..cfd3f2228 --- /dev/null +++ b/src/submodules/Geometry/src/Plane_Method@Methods.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 +! + +SUBMODULE(Plane_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE plane_normal_line_exp_int_3d +integer(i4b), parameter :: dim_num = 3 +real(dfp) :: direction(dim_num) +real(dfp) :: temp +! +! Make sure the line is not degenerate. +! +if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then + return +end if +! +! Make sure the plane normal vector is a unit vector. +! +temp = sqrt(sum(normal(1:dim_num)**2)) +! +if (temp == 0.0D+00) then + return +end if +! +normal(1:dim_num) = normal(1:dim_num) / temp +! +! Determine the unit direction vector of the line. +! +direction(1:dim_num) = p2(1:dim_num) - p1(1:dim_num) +temp = sqrt(sum(direction(1:dim_num)**2)) +direction(1:dim_num) = direction(1:dim_num) / temp +! +! If the normal and direction vectors are orthogonal, then +! we have a special case to deal with. +! +if (dot_product(normal(1:dim_num), direction(1:dim_num)) == 0.0D+00) then + + temp = dot_product(normal(1:dim_num), p1(1:dim_num) - pp(1:dim_num)) + + if (temp == 0.0D+00) then + ival = 2 + pint(1:dim_num) = p1(1:dim_num) + else + ival = 0 + pint(1:dim_num) = huge(temp) + end if + + return +end if +! +! Determine the distance along the direction vector +! to the intersection point. +! +temp = dot_product(pp(1:dim_num) - p1(1:dim_num), normal(1:dim_num)) & + & / dot_product(direction(1:dim_num), normal(1:dim_num)) + +ival = 1 +pint(1:dim_num) = p1(1:dim_num) + temp * direction(1:dim_num) + +END PROCEDURE plane_normal_line_exp_int_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 new file mode 100644 index 000000000..9e4b6a457 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceElement_Method@ConstructorMethods.F90 @@ -0,0 +1,367 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ReferenceElement_Method) ConstructorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! RefTopoReallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefTopoReallocate +INTEGER(I4B) :: tsize, ii +LOGICAL(LGT) :: isok + +isok = ALLOCATED(obj) + +IF (isok) THEN + + tsize = SIZE(obj) + + DO ii = 1, tsize + CALL DEALLOCATE (obj(ii)) + END DO + + IF (tsize .NE. n) THEN + DEALLOCATE (obj) + ALLOCATE (obj(n)) + END IF + +ELSE + + ALLOCATE (obj(n)) + +END IF + +END PROCEDURE RefTopoReallocate + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefTopoDeallocate +LOGICAL(LGT) :: isok +INTEGER(I4B) :: ii, tsize + +isok = ALLOCATED(obj) + +IF (isok) THEN + tsize = SIZE(obj) + + DO ii = 1, tsize + CALL DEALLOCATE (obj(ii)) + END DO + + DEALLOCATE (obj) + +END IF + +END PROCEDURE RefTopoDeallocate + +!---------------------------------------------------------------------------- +! ReferenceTopology +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_ReferenceTopology +CALL Reallocate(obj%nptrs, SIZE(nptrs)) +obj%nptrs = nptrs +obj%name = name +obj%xiDimension = XiDimension(name) +END PROCEDURE refelem_ReferenceTopology + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_Deallocate1 +IF (ALLOCATED(obj%nptrs)) DEALLOCATE (obj%nptrs) +obj%name = 0_I4B +obj%XiDimension = 0_I4B +END PROCEDURE refelem_Deallocate1 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_Deallocate2 +INTEGER(I4B) :: ii +obj%domainName = "GENERAL" +obj%entityCounts = 0 +obj%xiDimension = 0 +obj%name = 0 +obj%order = 0 +obj%nsd = 0 +obj%interpolationPointType = Equidistance +IF (ALLOCATED(obj%topology)) THEN + DO ii = 1, SIZE(obj%topology) + CALL DEALLOCATE (obj%topology(ii)) + END DO + DEALLOCATE (obj%topology) +END IF +IF (ALLOCATED(obj%xiJ)) DEALLOCATE (obj%xiJ) +obj%highOrderElement => NULL() +END PROCEDURE refelem_Deallocate2 + +!---------------------------------------------------------------------------- +! NNE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_NNE1 +IF (ALLOCATED(obj%nptrs)) THEN + ans = SIZE(obj%nptrs) +ELSE + ans = 0 +END IF +END PROCEDURE refelem_NNE1 + +!---------------------------------------------------------------------------- +! NNE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_NNE2 +IF (ALLOCATED(obj%XiJ)) THEN + ans = SIZE(obj%XiJ, 2) +ELSE + ans = 0 +END IF +END PROCEDURE refelem_NNE2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_Initiate1 +obj%domainName = anotherobj%domainName +IF (ALLOCATED(anotherobj%xiJ)) obj%xiJ = anotherobj%xiJ +obj%entityCounts = anotherobj%entityCounts +obj%xiDimension = anotherobj%xiDimension +obj%nsd = anotherobj%nsd +obj%order = anotherobj%order +obj%name = anotherobj%name +obj%interpolationPointType = anotherobj%interpolationPointType +IF (ALLOCATED(anotherobj%topology)) THEN + obj%topology = anotherobj%topology +END IF +obj%highOrderElement => anotherobj%highOrderElement +END PROCEDURE refelem_Initiate1 + +!---------------------------------------------------------------------------- +! ReferenceElement_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_constructor_1 +CLASS(ReferenceElement_), POINTER :: refelem +INTEGER(I4B) :: elemOrder +refelem => NULL() +SELECT CASE (xidim) +CASE (0) + ans => ReferencePoint_Pointer(nsd=nsd) +CASE (1) + elemOrder = ElementOrder(elemType) + IF (elemOrder .NE. 1) THEN + refelem => ReferenceLine_Pointer(nsd=nsd) + ALLOCATE (ReferenceLine_ :: ans) + CALL refelem%highOrderElement( & + & order=elemOrder, & + & ipType=ipType, & + & highOrderObj=ans) + CALL DEALLOCATE (refelem) + DEALLOCATE (refelem) + refelem => NULL() + ELSE + ans => ReferenceLine_Pointer(nsd=nsd) + END IF +CASE (2) + elemOrder = ElementOrder(elemType) + IF (isTriangle(elemType)) THEN + IF (elemOrder .NE. 1) THEN + refelem => ReferenceTriangle_Pointer(nsd=nsd) + ALLOCATE (ReferenceTriangle_ :: ans) + CALL refelem%highOrderElement( & + & order=elemOrder, & + & highOrderObj=ans, & + & ipType=ipType) + CALL DEALLOCATE (refelem) + DEALLOCATE (refelem) + refelem => NULL() + ELSE + ans => ReferenceTriangle_Pointer(nsd=nsd) + END IF + ELSE IF (isQuadrangle(elemType)) THEN + IF (elemOrder .NE. 1) THEN + refelem => ReferenceQuadrangle_Pointer(nsd=nsd) + ALLOCATE (ReferenceQuadrangle_ :: ans) + CALL refelem%highOrderElement( & + & order=elemOrder, & + & highOrderObj=ans, & + & ipType=ipType) + CALL DEALLOCATE (refelem) + DEALLOCATE (refelem) + refelem => NULL() + ELSE + ans => ReferenceQuadrangle_Pointer(nsd=nsd) + END IF + END IF +CASE (3) + elemOrder = ElementOrder(elemType) + IF (isTetrahedron(elemType)) THEN + IF (elemOrder .NE. 1) THEN + refelem => ReferenceTetrahedron_Pointer(nsd=nsd) + ALLOCATE (ReferenceTetrahedron_ :: ans) + CALL refelem%highOrderElement( & + & order=elemOrder, & + & highOrderObj=ans, & + & ipType=ipType) + CALL DEALLOCATE (refelem) + DEALLOCATE (refelem) + refelem => NULL() + ELSE + ans => ReferenceTetrahedron_Pointer(nsd=nsd) + END IF + ELSE IF (isHexahedron(elemType)) THEN + IF (elemOrder .NE. 1) THEN + refelem => ReferenceHexahedron_Pointer(nsd=nsd) + ALLOCATE (ReferenceHexahedron_ :: ans) + CALL refelem%highOrderElement( & + & order=elemOrder, & + & highOrderObj=ans, & + & ipType=ipType) + CALL DEALLOCATE (refelem) + DEALLOCATE (refelem) + refelem => NULL() + ELSE + ans => ReferenceHexahedron_Pointer(nsd=nsd) + END IF + ELSE IF (isPrism(elemType)) THEN + IF (elemOrder .NE. 1) THEN + refelem => ReferencePrism_Pointer(nsd=nsd) + ALLOCATE (ReferencePrism_ :: ans) + CALL refelem%highOrderElement( & + & order=elemOrder, & + & highOrderObj=ans, & + & ipType=ipType) + CALL DEALLOCATE (refelem) + DEALLOCATE (refelem) + refelem => NULL() + ELSE + ans => ReferencePrism_Pointer(nsd=nsd) + END IF + ELSE IF (isPyramid(elemType)) THEN + IF (elemOrder .NE. 1) THEN + refelem => ReferencePyramid_Pointer(nsd=nsd) + ALLOCATE (ReferencePyramid_ :: ans) + CALL refelem%highOrderElement( & + & order=elemOrder, & + & highOrderObj=ans, & + & ipType=ipType) + CALL DEALLOCATE (refelem) + DEALLOCATE (refelem) + refelem => NULL() + ELSE + ans => ReferencePyramid_Pointer(nsd=nsd) + END IF + END IF +END SELECT +ans%interpolationPointType = ipType +END PROCEDURE refelem_constructor_1 + +!---------------------------------------------------------------------------- +! ReferenceElement_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_constructor_2 +SELECT TYPE (refelem) +TYPE IS (ReferenceLine_) + ALLOCATE (ReferenceLine_ :: ans) +TYPE IS (ReferenceTriangle_) + ALLOCATE (ReferenceTriangle_ :: ans) +TYPE IS (ReferenceQuadrangle_) + ALLOCATE (ReferenceQuadrangle_ :: ans) +TYPE IS (ReferenceTetrahedron_) + ALLOCATE (ReferenceTetrahedron_ :: ans) +TYPE IS (ReferenceHexahedron_) + ALLOCATE (ReferenceHexahedron_ :: ans) +TYPE IS (ReferencePrism_) + ALLOCATE (ReferencePrism_ :: ans) +TYPE IS (ReferencePyramid_) + ALLOCATE (ReferencePyramid_ :: ans) +CLASS DEFAULT + SELECT CASE (refelem%name) + CASE (Line) + ALLOCATE (ReferenceLine_ :: ans) + CASE (Triangle) + ALLOCATE (ReferenceTriangle_ :: ans) + CASE (Quadrangle) + ALLOCATE (ReferenceQuadrangle_ :: ans) + CASE (Tetrahedron) + ALLOCATE (ReferenceTetrahedron_ :: ans) + CASE (Hexahedron) + ALLOCATE (ReferenceHexahedron_ :: ans) + CASE (Prism) + ALLOCATE (ReferencePrism_ :: ans) + CASE (Pyramid) + ALLOCATE (ReferencePyramid_ :: ans) + END SELECT +END SELECT +ans = refelem +END PROCEDURE refelem_constructor_2 + +!---------------------------------------------------------------------------- +! getnptrs +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_getnptrs +INTEGER(I4B) :: ii, tsize +LOGICAL(LGT) :: isok + +#ifdef DEBUG_VER +isok = ALLOCATED(obj%topology) +IF (.NOT. isok) THEN + CALL Reallocate(ans, 0) + RETURN +END IF +#endif + +ii = SUM(obj%entityCounts) + +#ifdef DEBUG_VER +tsize = SIZE(obj%topology) +isok = ii .LE. tsize + +IF (.NOT. isok) THEN + CALL Reallocate(ans, 0) + RETURN +END IF + +isok = ALLOCATED(obj%topology(ii)%nptrs) + +IF (.NOT. isok) THEN + CALL Reallocate(ans, 0) + RETURN +END IF +#endif + +ans = obj%topology(ii)%nptrs +END PROCEDURE refelem_getnptrs + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE ConstructorMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 new file mode 100644 index 000000000..6f9165be3 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceElement_Method@EnquireMethods.F90 @@ -0,0 +1,296 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 1 March 2021 +! summary: This sumodule contains method for geometry + +SUBMODULE(ReferenceElement_Method) EnquireMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! isVolume +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isVolume1 +SELECT CASE (elemType) +CASE (Tetrahedron4, & + Hexahedron8, & + Prism6, & + Pyramid5, & + Tetrahedron10, & + Hexahedron27, & + Prism18, & + Pyramid14, & + Hexahedron20, & + Prism15, & + Pyramid13, & + Tetrahedron20, & + Tetrahedron35, & + Tetrahedron56, & + Hexahedron64, & + Hexahedron125) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isVolume1 + +!---------------------------------------------------------------------------- +! isVolume +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isVolume2 +ans = isVolume1(obj%name) +END PROCEDURE isVolume2 + +!---------------------------------------------------------------------------- +! isSurface +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isSurface1 +SELECT CASE (elemType) +CASE (Triangle3, & + Triangle6, & + Triangle9, & + Triangle10, & + Triangle12, & + Triangle15a, & + Triangle15b, & + Triangle21, & + Quadrangle4, & + Quadrangle8, & + Quadrangle9, & + Quadrangle16) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isSurface1 + +!---------------------------------------------------------------------------- +! isSurface +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isSurface2 +ans = isSurface1(obj%name) +END PROCEDURE isSurface2 + +!---------------------------------------------------------------------------- +! isLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isLine1 +SELECT CASE (elemType) +CASE (Line2, & + & Line3, & + & Line4, & + & Line5, & + & Line6) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isLine1 + +!---------------------------------------------------------------------------- +! isLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isLine2 +ans = isLine1(obj%name) +END PROCEDURE isLine2 + +!---------------------------------------------------------------------------- +! isPoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isPoint1 +SELECT CASE (elemType) +CASE (Point1) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isPoint1 + +!---------------------------------------------------------------------------- +! isPoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isPoint2 +ans = isPoint1(obj%name) +END PROCEDURE isPoint2 + +!---------------------------------------------------------------------------- +! isTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isTriangle1 +SELECT CASE (elemType) +CASE (Triangle3, Triangle6, & +& Triangle9, Triangle10, Triangle12, Triangle15a, & +& Triangle15b, Triangle21) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isTriangle1 + +!---------------------------------------------------------------------------- +! isTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isTriangle2 +ans = isTriangle1(obj%name) +END PROCEDURE isTriangle2 + +!---------------------------------------------------------------------------- +! isQuadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isQuadrangle1 +SELECT CASE (elemType) +CASE (Quadrangle4, Quadrangle8, Quadrangle9, Quadrangle16) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isQuadrangle1 + +!---------------------------------------------------------------------------- +! isQuadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isQuadrangle2 +ans = isQuadrangle1(obj%name) +END PROCEDURE isQuadrangle2 + +!---------------------------------------------------------------------------- +! isTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isTetrahedron1 +SELECT CASE (elemType) +CASE (Tetrahedron4, Tetrahedron10, Tetrahedron20, Tetrahedron35, & + & Tetrahedron56) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isTetrahedron1 + +!---------------------------------------------------------------------------- +! isTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isTetrahedron2 +ans = isTetrahedron1(obj%name) +END PROCEDURE isTetrahedron2 + +!---------------------------------------------------------------------------- +! isHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isHexahedron1 +SELECT CASE (elemType) +CASE (Hexahedron8, Hexahedron27, & + & Hexahedron20, Hexahedron64, Hexahedron125) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isHexahedron1 + +!---------------------------------------------------------------------------- +! isHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isHexahedron2 +ans = isHexahedron1(obj%name) +END PROCEDURE isHexahedron2 + +!---------------------------------------------------------------------------- +! isPrism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isPrism1 +SELECT CASE (elemType) +CASE (Prism6, Prism18, Prism15) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isPrism1 + +!---------------------------------------------------------------------------- +! isPrism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isPrism2 +ans = isPrism1(obj%name) +END PROCEDURE isPrism2 + +!---------------------------------------------------------------------------- +! isPyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isPyramid1 +SELECT CASE (elemType) +CASE (Pyramid5, Pyramid13, Pyramid14) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isPyramid1 + +!---------------------------------------------------------------------------- +! isPyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isPyramid2 +ans = isPyramid1(obj%name) +END PROCEDURE isPyramid2 + +!---------------------------------------------------------------------------- +! isSerendipityElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isSerendipityElement1 +SELECT CASE (elemType) +CASE (Triangle9, Triangle12, Triangle15b, Quadrangle8) + ans = .TRUE. +CASE DEFAULT + ans = .FALSE. +END SELECT +END PROCEDURE isSerendipityElement1 + +!---------------------------------------------------------------------------- +! isSerendipityElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isSerendipityElement2 +ans = isSerendipityElement1(obj%name) +END PROCEDURE isSerendipityElement2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE EnquireMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 new file mode 100644 index 000000000..9e4d46182 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceElement_Method@FacetElementMethods.F90 @@ -0,0 +1,223 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 1 March 2021 +! summary: This sumodule contains method for geometry + +SUBMODULE(ReferenceElement_Method) FacetElementMethods +USE ReferenceLine_Method, ONLY: DEFAULT_REF_LINE_COORD, & + & FacetElements_Line, & + & FacetTopology_Line + +USE ReferenceTriangle_Method, ONLY: GetEdgeConnectivity_Triangle, & + & FacetElements_Triangle, & + & FacetTopology_Triangle + +USE ReferenceQuadrangle_Method, ONLY: GetEdgeConnectivity_Quadrangle, & + & FacetElements_Quadrangle, & + & FacetTopology_Quadrangle + +USE ReferenceTetrahedron_Method, ONLY: FacetElements_Tetrahedron, & + & FacetTopology_Tetrahedron + +USE ReferenceTetrahedron_Method, ONLY: FacetElements_Tetrahedron, & + & FacetTopology_Tetrahedron + +USE ReferenceHexahedron_Method, ONLY: FacetElements_Hexahedron, & + & FacetTopology_Hexahedron + +USE ReferencePrism_Method, ONLY: FacetElements_Prism, & + & FacetTopology_Prism + +USE ReferencePyramid_Method, ONLY: FacetElements_Pyramid, & + & FacetTopology_Pyramid + +USE LineInterpolationUtility, ONLY: InterpolationPoint_Line +USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle +USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle +! USE TetrahedronInterpolationUtility +! USE HexahedronInterpolationUtility +! USE PrismInterpolationUtility +! USE PyramidInterpolationUtility + +USE ErrorHandling + +USE ReallocateUtility + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FacetMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Facet_Matrix_refelem +INTEGER(I4B) :: xicell, T(4), i, istart, iend, max_nns, nns, tFacet +T(1) = 0 +DO i = 2, 4 + T(i) = SUM(refelem%entityCounts(1:i - 1)) +END DO + +xicell = refelem%xiDimension + +SELECT CASE (xicell) +CASE (1) + tFacet = 2 + istart = 1 + iend = 2 + max_nns = 2 + ALLOCATE (FM(tFacet, max_nns + 3)) + FM = 0 + DO i = 0, tFacet - 1 + FM(i + 1, 1) = refelem%topology(istart + i)%name + FM(i + 1, 2) = refelem%topology(istart + i)%xiDimension + nns = SIZE(refelem%topology(istart + i)%nptrs) + FM(i + 1, 3) = nns + FM(i + 1, 4:(3 + nns)) = refelem%topology(istart + i)%nptrs + END DO + +CASE (2, 3) + tFacet = refelem%entityCounts(xicell) + istart = T(xicell) + 1 + iend = T(xicell) + tFacet + max_nns = 0 + DO i = istart, iend + nns = SIZE(refelem%topology(i)%nptrs) + IF (max_nns .LT. nns) max_nns = nns + END DO + ALLOCATE (FM(tFacet, max_nns + 3)) + FM = 0 + DO i = 0, tFacet - 1 + FM(i + 1, 1) = refelem%topology(istart + i)%name + FM(i + 1, 2) = refelem%topology(istart + i)%xiDimension + nns = SIZE(refelem%topology(istart + i)%nptrs) + FM(i + 1, 3) = nns + FM(i + 1, 4:(3 + nns)) = refelem%topology(istart + i)%nptrs + END DO +END SELECT + +END PROCEDURE Facet_Matrix_refelem + +!---------------------------------------------------------------------------- +! FacetElements +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_GetFacetElements1 +INTEGER(I4B) :: topo + +topo = ElementTopology(refelem) + +SELECT CASE (topo) +CASE (Line) + CALL FacetElements_Line(refelem=refelem, ans=ans) + +CASE (Triangle) + CALL FacetElements_Triangle(refelem=refelem, ans=ans) + +CASE (Quadrangle) + CALL FacetElements_Quadrangle(refelem=refelem, ans=ans) + +CASE (Tetrahedron) + CALL FacetElements_Tetrahedron(refelem=refelem, ans=ans) + +CASE (Hexahedron) + CALL FacetElements_Hexahedron(refelem=refelem, ans=ans) + +CASE (Prism) + CALL FacetElements_Prism(refelem=refelem, ans=ans) + +CASE (Pyramid) + CALL FacetElements_Pyramid(refelem=refelem, ans=ans) + +END SELECT + +END PROCEDURE refelem_GetFacetElements1 + +!---------------------------------------------------------------------------- +! FacetElements +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_GetFacetElements2 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Line) + CALL FacetElements_Line(elemType=elemType, nsd=nsd, ans=ans) + +CASE (Triangle) + CALL FacetElements_Triangle(elemType=elemType, nsd=nsd, ans=ans) + +CASE (Quadrangle) + CALL FacetElements_Quadrangle(elemType=elemType, nsd=nsd, ans=ans) + +CASE (Tetrahedron) + CALL FacetElements_Tetrahedron(elemType=elemType, nsd=nsd, ans=ans) + +CASE (Hexahedron) + CALL FacetElements_Hexahedron(elemType=elemType, nsd=nsd, ans=ans) + +CASE (Prism) + CALL FacetElements_Prism(elemType=elemType, nsd=nsd, ans=ans) + +CASE (Pyramid) + CALL FacetElements_Pyramid(elemType=elemType, nsd=nsd, ans=ans) + +END SELECT + +END PROCEDURE refelem_GetFacetElements2 + +!---------------------------------------------------------------------------- +! GetFacetTopology +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_GetFacettopology +INTEGER(I4B) :: topo +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Line) + CALL FacetTopology_Line(elemType=elemType, nptrs=nptrs, ans=ans) + +CASE (Triangle) + CALL FacetTopology_Triangle(elemType=elemType, nptrs=nptrs, ans=ans) + +CASE (Quadrangle) + CALL FacetTopology_Quadrangle(elemType=elemType, nptrs=nptrs, ans=ans) + +CASE (Tetrahedron) + CALL FacetTopology_Tetrahedron(elemType=elemType, nptrs=nptrs, ans=ans) + +CASE (Prism) + CALL FacetTopology_Prism(elemType=elemType, nptrs=nptrs, ans=ans) + +CASE (Pyramid) + CALL FacetTopology_Pyramid(elemType=elemType, nptrs=nptrs, ans=ans) + +CASE (Hexahedron) + CALL FacetTopology_Hexahedron(elemType=elemType, nptrs=nptrs, ans=ans) + +END SELECT +END PROCEDURE refelem_GetFacettopology + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE FacetElementMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 new file mode 100644 index 000000000..545047406 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 @@ -0,0 +1,560 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ReferenceElement_Method) GeometryMethods +USE ErrorHandling, ONLY: Errormsg +USE Display_Method + +USE ReferencePoint_Method, ONLY: Measure_Simplex_Point, Point_quality, & + TotalNodesInElement_Point + +USE ReferenceLine_Method, ONLY: Measure_Simplex_Line, & + Line_quality, & + TotalNodesInElement_Line, & + TotalEntities_Line, & + GetFaceElemType_Line, & + GetEdgeConnectivity_Line, & + GetFaceConnectivity_Line + +USE ReferenceTriangle_Method, ONLY: Measure_Simplex_Triangle, & + Triangle_quality, & + triangle_contains_point, & + GetEdgeConnectivity_Triangle, & + TotalNodesInElement_Triangle, & + TotalEntities_Triangle, & + GetFaceConnectivity_Triangle, & + GetFaceElemType_Triangle + +USE ReferenceQuadrangle_Method, ONLY: Measure_Simplex_Quadrangle, & + Quadrangle_quality, & + GetEdgeConnectivity_Quadrangle, & + TotalNodesInElement_Quadrangle, & + TotalEntities_Quadrangle, & + GetFaceConnectivity_Quadrangle, & + GetFaceElemType_Quadrangle + +USE ReferenceTetrahedron_Method, ONLY: Measure_Simplex_Tetrahedron, & + Tetrahedron_quality, & + GetEdgeConnectivity_Tetrahedron, & + GetFaceConnectivity_Tetrahedron, & + GetFaceElemType_Tetrahedron, & + TotalNodesInElement_Tetrahedron, & + TotalEntities_Tetrahedron + +USE ReferenceHexahedron_Method, ONLY: Measure_Simplex_Hexahedron, & + Hexahedron_quality, & + GetEdgeConnectivity_Hexahedron, & + GetFaceConnectivity_Hexahedron, & + GetFaceElemType_Hexahedron, & + TotalNodesInElement_Hexahedron, & + TotalEntities_Hexahedron + +USE ReferencePrism_Method, ONLY: Measure_Simplex_Prism, & + Prism_quality, & + GetEdgeConnectivity_Prism, & + GetFaceConnectivity_Prism, & + GetFaceElemType_Prism, & + TotalNodesInElement_Prism, & + TotalEntities_Prism + +USE ReferencePyramid_Method, ONLY: Measure_Simplex_Pyramid, & + Pyramid_quality, & + GetEdgeConnectivity_Pyramid, & + GetFaceConnectivity_Pyramid, & + GetFaceElemType_Pyramid, & + TotalNodesInElement_Pyramid, & + TotalEntities_Pyramid + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetElementIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetElementIndex +INTEGER(I4B) :: topo + +topo = refelem_ElementTopology1(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = 1 + +CASE (Line) + ans = 2 + +CASE (Triangle) + ans = 3 + +CASE (Quadrangle) + ans = 4 + +CASE (Tetrahedron) + ans = 5 + +CASE (Hexahedron) + ans = 6 + +CASE (Prism) + ans = 7 + +CASE (Pyramid) + ans = 8 + +END SELECT +END PROCEDURE GetElementIndex + +!---------------------------------------------------------------------------- +! RefElemGetGeoParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemGetGeoParam1 +INTEGER(I4B) :: topo + +topo = refelem_ElementTopology1(elemType) + +IF (PRESENT(tCells)) tCells = 1_I4B + +SELECT CASE (topo) + +CASE (Point, Line) + + IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Line(elemType) + IF (PRESENT(tEdges)) tEdges = 0_I4B + IF (PRESENT(tFaces)) tFaces = 2_I4B + + IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Line(con=edgeCon, & + opt=edgeOpt, order=order) + + IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Line(con=faceCon, & + opt=faceOpt, order=order) + + CALL GetFaceElemType_Line(faceElemType=faceElemType, & + tFaceNodes=tFaceNodes, elemType=elemType) + +CASE (Triangle) + + IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Triangle(elemType) + IF (PRESENT(tEdges)) tEdges = 3_I4B + IF (PRESENT(tFaces)) tFaces = 3_I4B + + IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Triangle(con=edgeCon, & + opt=edgeOpt, order=order) + + IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Triangle(con=faceCon, & + opt=faceOpt, order=order) + + CALL GetFaceElemType_Triangle(faceElemType=faceElemType, & + tFaceNodes=tFaceNodes, elemType=elemType) + +CASE (Quadrangle) + + IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Quadrangle(elemType) + IF (PRESENT(tEdges)) tEdges = 4_I4B + IF (PRESENT(tFaces)) tFaces = 4_I4B + + IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, & + opt=edgeOpt, order=order) + + IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Quadrangle(con=faceCon, & + opt=faceOpt, order=order) + + CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, & + tFaceNodes=tFaceNodes, elemType=elemType) + +CASE (Tetrahedron) + + IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Tetrahedron(elemType) + IF (PRESENT(tEdges)) tEdges = 6_I4B + IF (PRESENT(tFaces)) tFaces = 4_I4B + IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Tetrahedron(con=edgeCon, & + opt=edgeOpt, order=order) + IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Tetrahedron(con=faceCon, & + opt=faceOpt, order=order) + + CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & + tFaceNodes=tFaceNodes, elemType=elemType) + +CASE (Hexahedron) + + IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Hexahedron(elemType) + IF (PRESENT(tEdges)) tEdges = 12_I4B + IF (PRESENT(tFaces)) tFaces = 6_I4B + IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Hexahedron(con=edgeCon, & + opt=edgeOpt, order=order) + IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Hexahedron(con=faceCon, & + opt=faceOpt, order=order) + + CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, & + tFaceNodes=tFaceNodes, elemType=elemType) + +CASE (Prism) + + IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Prism(elemType) + IF (PRESENT(tEdges)) tEdges = 9_I4B + IF (PRESENT(tFaces)) tFaces = 5_I4B + IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Prism(con=edgeCon, & + opt=edgeOpt, order=order) + IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Prism(con=faceCon, & + opt=faceOpt, order=order) + + CALL GetFaceElemType_Prism(faceElemType=faceElemType, & + tFaceNodes=tFaceNodes, elemType=elemType) + +CASE (Pyramid) + + IF (PRESENT(tNodes)) tNodes = TotalNodesInElement_Pyramid(elemType) + IF (PRESENT(tEdges)) tEdges = 8_I4B + IF (PRESENT(tFaces)) tFaces = 5_I4B + IF (PRESENT(edgeCon)) CALL GetEdgeConnectivity_Pyramid(con=edgeCon, & + opt=edgeOpt, order=order) + IF (PRESENT(faceCon)) CALL GetFaceConnectivity_Pyramid(con=faceCon, & + opt=faceOpt, order=order) + + CALL GetFaceElemType_Pyramid(faceElemType=faceElemType, & + tFaceNodes=tFaceNodes, elemType=elemType) + +CASE DEFAULT + IF (PRESENT(tNodes)) tNodes = 0_I4B + IF (PRESENT(tEdges)) tEdges = 0_I4B + IF (PRESENT(tFaces)) tFaces = 0_I4B + IF (PRESENT(edgeCon)) edgeCon = 0_I4B + IF (PRESENT(faceCon)) faceCon = 0_I4B + IF (PRESENT(faceElemType)) faceElemType = 0_I4B + IF (PRESENT(tFaceNodes)) tFaceNodes = 0_I4B +END SELECT +END PROCEDURE RefElemGetGeoParam1 + +!---------------------------------------------------------------------------- +! GetTotalNodes +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalNodes1 +CALL RefElemGetGeoParam(tNodes=ans, elemType=elemType) +END PROCEDURE GetTotalNodes1 + +!---------------------------------------------------------------------------- +! GetTotalEdges +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalEdges1 +CALL RefElemGetGeoParam(tEdges=ans, elemType=elemType) +END PROCEDURE GetTotalEdges1 + +!---------------------------------------------------------------------------- +! GetTotalFaces +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalFaces1 +CALL RefElemGetGeoParam(tFaces=ans, elemType=elemType) +END PROCEDURE GetTotalFaces1 + +!---------------------------------------------------------------------------- +! GetTotalCells +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalCells1 +CALL RefElemGetGeoParam(tCells=ans, elemType=elemType) +END PROCEDURE GetTotalCells1 + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity1 +INTEGER(I4B) :: topo + +topo = refelem_ElementTopology1(elemType) + +SELECT CASE (topo) + +CASE (Line) + CALL GetEdgeConnectivity_Line(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Triangle) + + CALL GetEdgeConnectivity_Triangle(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Quadrangle) + + CALL GetEdgeConnectivity_Quadrangle(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Tetrahedron) + + CALL GetEdgeConnectivity_Tetrahedron(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Hexahedron) + + CALL GetEdgeConnectivity_Hexahedron(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Prism) + + CALL GetEdgeConnectivity_Prism(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Pyramid) + + CALL GetEdgeConnectivity_Pyramid(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +END SELECT +END PROCEDURE GetEdgeConnectivity1 + +!---------------------------------------------------------------------------- +! GetFaceConnectivity2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity1 +INTEGER(I4B) :: topo + +topo = refelem_ElementTopology1(elemType) + +SELECT CASE (topo) + +CASE (Line) + CALL GetFaceConnectivity_Line(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Triangle) + + CALL GetFaceConnectivity_Triangle(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Quadrangle) + + CALL GetFaceConnectivity_Quadrangle(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Tetrahedron) + + CALL GetFaceConnectivity_Tetrahedron(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Hexahedron) + + CALL GetFaceConnectivity_Hexahedron(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Prism) + + CALL GetFaceConnectivity_Prism(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +CASE (Pyramid) + + CALL GetFaceConnectivity_Pyramid(con=con, opt=opt, order=order, & + nrow=nrow, ncol=ncol) + +END SELECT +END PROCEDURE GetFaceConnectivity1 + +!---------------------------------------------------------------------------- +! GetFaceElemType +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType1 +INTEGER(I4B) :: topo + +topo = refelem_ElementTopology1(elemType) + +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 + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex +INTEGER(I4B) :: elemType +Ans = 0.0_DFP +SELECT TYPE (refelem) +TYPE IS (ReferencePoint_) + Ans = Measure_Simplex_Point(refelem, xij) +TYPE IS (ReferenceLine_) + Ans = Measure_Simplex_Line(refelem, xij) +TYPE IS (ReferenceTriangle_) + Ans = Measure_Simplex_Triangle(refelem, xij) +TYPE IS (ReferenceQuadrangle_) + Ans = Measure_Simplex_Quadrangle(refelem, xij) +TYPE IS (ReferenceTetrahedron_) + Ans = Measure_Simplex_Tetrahedron(refelem, xij) +TYPE IS (ReferenceHexahedron_) + Ans = Measure_Simplex_Hexahedron(refelem, xij) +TYPE IS (ReferencePrism_) + Ans = Measure_Simplex_Prism(refelem, xij) +TYPE IS (ReferencePyramid_) + Ans = Measure_Simplex_Pyramid(refelem, xij) +CLASS DEFAULT + elemType = refelem%name + IF (isPoint(elemType)) THEN + Ans = Measure_Simplex_Point(refelem, xij) + ELSEIF (isLine(elemType)) THEN + Ans = Measure_Simplex_Line(refelem, xij) + ELSEIF (isTriangle(elemType)) THEN + Ans = Measure_Simplex_Triangle(refelem, xij) + ELSEIF (isQuadrangle(elemType)) THEN + Ans = Measure_Simplex_Quadrangle(refelem, xij) + ELSEIF (isTetrahedron(elemType)) THEN + Ans = Measure_Simplex_Tetrahedron(refelem, xij) + ELSEIF (isHexahedron(elemType)) THEN + Ans = Measure_Simplex_Hexahedron(refelem, xij) + ELSEIF (isPrism(elemType)) THEN + Ans = Measure_Simplex_Prism(refelem, xij) + ELSEIF (isPyramid(elemType)) THEN + Ans = Measure_Simplex_Pyramid(refelem, xij) + END IF +END SELECT +END PROCEDURE Measure_Simplex + +!---------------------------------------------------------------------------- +! ElementQuality +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Element_Quality +SELECT TYPE (refelem) +CLASS IS (ReferencePoint_) + Ans = Point_quality(refelem, xij, measure) +CLASS IS (ReferenceLine_) + Ans = Line_quality(refelem, xij, measure) +CLASS IS (ReferenceTriangle_) + Ans = Triangle_quality(refelem, xij, measure) +CLASS IS (ReferenceQuadrangle_) + Ans = Quadrangle_quality(refelem, xij, measure) +CLASS IS (ReferenceTetrahedron_) + Ans = Tetrahedron_quality(refelem, xij, measure) +CLASS IS (ReferencePrism_) + Ans = Prism_quality(refelem, xij, measure) +CLASS IS (ReferenceHexahedron_) + Ans = Hexahedron_quality(refelem, xij, measure) +CLASS IS (ReferencePyramid_) + Ans = Pyramid_quality(refelem, xij, measure) +END SELECT +END PROCEDURE Element_Quality + +!---------------------------------------------------------------------------- +! ContainsPoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contains_point +SELECT TYPE (refelem) +CLASS IS (ReferenceLine_) + CALL Display("ERROR:: ReferenceElement_Method@Geometry.F90") + CALL Display(" Contains_point()") + CALL Display(" No case found for ReferenceLine_") + CALL Display(" Program stopped!!") + STOP +CLASS IS (ReferenceTriangle_) + Ans = triangle_contains_point(refelem, xij, x) +CLASS IS (ReferenceQuadrangle_) + CALL Display("ERROR:: ReferenceElement_Method@Geometry.F90") + CALL Display(" Contains_point()") + CALL Display(" No case found for Quadrangle_") + CALL Display(" Program stopped!!") + STOP +CLASS DEFAULT + CALL Display("ERROR:: ReferenceElement_Method@Geometry.F90") + CALL Display(" Contains_point()") + CALL Display(" No case found") + CALL Display(" Program stopped!!") + STOP +END SELECT +END PROCEDURE contains_point + +!---------------------------------------------------------------------------- +! TotalEntities +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_TotalEntities +INTEGER(I4B) :: topo + +topo = refelem_ElementTopology1(elemType) + +SELECT CASE (topo) +CASE (Point, Line) + + ans = TotalEntities_Line(elemType) + +CASE (Triangle) + + ans = TotalEntities_Triangle(elemType) + +CASE (Quadrangle) + ans = TotalEntities_Quadrangle(elemType) + +CASE (Tetrahedron) + ans = TotalEntities_Tetrahedron(elemType) + +CASE (Hexahedron) + ans = TotalEntities_Hexahedron(elemType) + +CASE (Prism) + ans = TotalEntities_Prism(elemType) + +CASE (Pyramid) + ans = TotalEntities_Pyramid(elemType) + +END SELECT +END PROCEDURE refelem_TotalEntities + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE GeometryMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 new file mode 100644 index 000000000..1ebb16046 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceElement_Method@IOMethods.F90 @@ -0,0 +1,283 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 1 March 2021 +! summary: This submodule contains IO methods for [[ReferenceElement_]] + +SUBMODULE(ReferenceElement_Method) IOMethods +USE BaseMethod +CONTAINS + +!---------------------------------------------------------------------------- +! MDEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE reftopo_MdEncode +TYPE(String), ALLOCATABLE :: astr(:, :) +INTEGER(I4B) :: n, ii, jj +TYPE(String) :: rh(3), ch(1) + +rh(1) = "Element type" +rh(2) = "Xidimension" +rh(3) = "Nptrs" +ch(1) = "" + +IF (ALLOCATED(obj%nptrs)) THEN + n = SIZE(obj%nptrs) + CALL reallocate(astr, 3, n) + astr(1, 1) = ElementName(obj%name) + DO ii = 2, n + astr(1, ii) = "" + END DO + + astr(2, 1) = tostring(obj%xidimension) + DO ii = 2, n + astr(2, ii) = "" + END DO + + DO ii = 1, n + astr(3, ii) = tostring(obj%nptrs(ii)) + END DO + +ELSE + + n = 1 + CALL reallocate(astr, 3, n) + astr(1, 1) = ElementName(obj%name) + astr(2, 1) = tostring(obj%xidimension) + astr(3, 1) = "NOT ALLOCATED" + +END IF + +ans = MdEncode(val=astr, rh=rh, ch=ch) + +IF (ALLOCATED(astr)) DEALLOCATE (astr) + +END PROCEDURE reftopo_MdEncode + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_MdEncode +!! Define internal variable +INTEGER(I4B) :: j, tsize, jj +LOGICAL(LGT) :: notFull0 +TYPE(String) :: astr(20) +CHARACTER(1), PARAMETER, DIMENSION(3) :: xyz = ["x", "y", "z"] +TYPE(String) :: rowTitle(20), colTitle(1) + +colTitle(1) = "" + +rowTitle(1) = "Element type"; astr(1) = ElementName(obj%name) +rowTitle(2) = "Xidimension"; astr(2) = tostring(obj%xiDimension) +rowTitle(3) = "NSD"; astr(3) = tostring(obj%nsd) +rowTitle(4) = "tPoints"; astr(4) = tostring(obj%entityCounts(1)) +rowTitle(5) = "tLines"; astr(5) = tostring(obj%entityCounts(2)) +rowTitle(6) = "tSurfaces"; astr(6) = tostring(obj%entityCounts(3)) +rowTitle(7) = "tVolumes"; astr(7) = tostring(obj%entityCounts(4)) + +tsize = SIZE(obj%xij, 1) +DO j = 1, tsize + rowTitle(7 + j) = xyz(j) +END DO + +ans = MdEncode(val=astr(1:7), rh=rowTitle(1:7), ch=colTitle)// & + & char_lf//"Nodal Coordinates:"//char_lf//char_lf// & + & MdEncode(obj%xij, rh=rowTitle(7 + 1:7 + tsize), ch=colTitle) + +! pointTopology +DO j = 1, obj%entityCounts(1) + ans = ans//"PointTopology( "//tostring(j)//" ) : "// & + & char_lf//char_lf//MdEncode(obj%topology(j)) +END DO + +!! edgeTopology +tsize = obj%entityCounts(1) +DO j = 1, obj%entityCounts(2) + ans = ans//"EdgeTopology( "//tostring(j)//" ) : "// & + & char_lf//char_lf//MdEncode(obj%topology(tsize + j)) +END DO + +!! faceTopology +tsize = tsize + obj%entityCounts(2) +DO j = 1, obj%entityCounts(3) + ans = ans//"FaceTopology( "//tostring(j)//" ) : "// & + & char_lf//char_lf//MdEncode(obj%topology(tsize + j)) +END DO + +!! cellTopology +tsize = tsize + obj%entityCounts(3) +DO j = 1, obj%entityCounts(4) + ans = ans//"CellTopology( "//tostring(j)//" ) : "// & + & char_lf//char_lf//MdEncode(obj%topology(tsize + j)) +END DO +END PROCEDURE refelem_MdEncode + +!---------------------------------------------------------------------------- +! refelem_ReactEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_ReactEncode +!! Define internal variable +INTEGER(I4B) :: j, tsize +LOGICAL(LGT) :: notFull0 +TYPE(String) :: rowTitle(20), colTitle(1) +TYPE(String) :: astr(20) +CHARACTER(1), PARAMETER, DIMENSION(3) :: xyz = ["x", "y", "z"] + +colTitle(1) = "" +rowTitle(1) = "Element type"; astr(1) = ElementName(obj%name) +rowTitle(2) = "Xidimension"; astr(2) = tostring(obj%xiDimension) +rowTitle(3) = "NSD"; astr(3) = tostring(obj%nsd) +rowTitle(4) = "tPoints"; astr(4) = tostring(obj%entityCounts(1)) +rowTitle(5) = "tLines"; astr(5) = tostring(obj%entityCounts(2)) +rowTitle(6) = "tSurfaces"; astr(6) = tostring(obj%entityCounts(3)) +rowTitle(7) = "tVolumes"; astr(7) = tostring(obj%entityCounts(4)) + +tsize = SIZE(obj%xij, 1) +DO j = 1, tsize + rowTitle(7 + j) = xyz(j) +END DO + +ans = MdEncode(val=astr(1:7), rh=rowTitle(1:7), ch=colTitle)// & + & char_lf//"Nodal Coordinates:"//char_lf//char_lf// & + & MdEncode(obj%xij, rh=rowTitle(8:7 + tsize), ch=colTitle) + +IF (obj%entityCounts(1) .GT. 0_I4B) THEN + ans = ans//React_StartTabs()//char_lf + + !! pointTopology + tsize = 0 + DO j = 1, obj%entityCounts(1) + ans = ans//React_StartTabItem( & + & VALUE=tostring(j), & + & label="PointTopology( "//tostring(j)//" ) : ")//char_lf// & + & MdEncode(obj%topology(tsize + j))//char_lf & + & //React_EndTabItem()//char_lf + END DO + + ans = ans//React_EndTabs()//char_lf +END IF + +IF (obj%entityCounts(2) .GT. 0_I4B) THEN + ans = ans//React_StartTabs()//char_lf + + !! edgeTopology + tsize = obj%entityCounts(1) + tsize + DO j = 1, obj%entityCounts(2) + ans = ans//React_StartTabItem( & + & VALUE=tostring(j), & + & label="EdgeTopology( "//tostring(j)//" ) : ")//char_lf// & + & MdEncode(obj%topology(tsize + j))//char_lf & + & //React_EndTabItem()//char_lf + END DO + + ans = ans//React_EndTabs()//char_lf +END IF + +IF (obj%entityCounts(3) .GT. 0_I4B) THEN + ans = ans//React_StartTabs()//char_lf + + !! edgeTopology + tsize = obj%entityCounts(2) + tsize + DO j = 1, obj%entityCounts(3) + ans = ans//React_StartTabItem( & + & VALUE=tostring(j), & + & label="FacetTopology( "//tostring(j)//" ) : ")//char_lf// & + & MdEncode(obj%topology(tsize + j))//char_lf & + & //React_EndTabItem()//char_lf + END DO + + ans = ans//React_EndTabs()//char_lf +END IF + +IF (obj%entityCounts(4) .GT. 0_I4B) THEN + ans = ans//React_StartTabs()//char_lf + + !! edgeTopology + tsize = obj%entityCounts(3) + tsize + DO j = 1, obj%entityCounts(4) + ans = ans//React_StartTabItem( & + & VALUE=tostring(j), & + & label="CellTopology( "//tostring(j)//" ) : ")//char_lf// & + & MdEncode(obj%topology(tsize + j))//char_lf & + & //React_EndTabItem()//char_lf + END DO + + ans = ans//React_EndTabs()//char_lf +END IF + +END PROCEDURE refelem_ReactEncode + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE reftopo_Display +CALL Display(msg, unitno=unitno) +CALL Display("ElemType: "//TRIM(ElementName(obj%Name)), unitno=unitno) +CALL Display("XiDim: "//TRIM(INT2STR(obj%XiDimension)), unitno=unitno) +CALL Display(obj%Nptrs, "Nptrs: ", unitno=unitno) +END PROCEDURE reftopo_Display + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refelem_Display +! Define internal variable +INTEGER(I4B) :: I, j +CALL Display(msg, unitno=unitno) +CALL Display("DomainName : "//TRIM(obj%domainName), & + & unitno=unitno) +CALL Display("ElemType : "//TRIM(ElementName(obj%Name)), & + & unitno=unitno) +CALL Display(obj%XiDimension, "XiDimension :: ", & + & unitno=unitno) +CALL Display(obj%NSD, "NSD : ", & + & unitno=unitno) +CALL Display(obj%Order, "Order : ", & + & unitno=unitno) +CALL Display(obj%EntityCounts(1), "EntityCounts(0) : ", & + & unitno=unitno) +CALL Display(obj%EntityCounts(2), "EntityCounts(1) : ", & + & unitno=unitno) +CALL Display(obj%EntityCounts(3), "EntityCounts(2) : ", & + & unitno=unitno) +CALL Display(obj%EntityCounts(4), "EntityCounts(3) : ", & + & unitno=unitno) + +CALL BlankLines(nol=1, unitNo=unitNo) +DO j = 1, SIZE(obj%XiJ, 2) + CALL EqualLine(unitNo=unitNo) + CALL Display(obj%XiJ(:, j), "Node( "//TRIM(str(j, .TRUE.))//" ) : ", & + & unitno=unitno) + CALL BlankLines(nol=1, unitNo=unitNo) +END DO + +DO j = 1, SIZE(obj%Topology) + CALL EqualLine(unitNo=unitNo) + CALL Display(obj%Topology(j), "Topology( "//TRIM(INT2STR(j))//" ) : ", & + & unitno=unitno) + CALL BlankLines(nol=1, unitNo=unitNo) +END DO + +END PROCEDURE refelem_Display + +END SUBMODULE IOMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 new file mode 100644 index 000000000..7475d8bf3 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceElement_Method@LocalNodeCoordsMethods.F90 @@ -0,0 +1,429 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 1 March 2021 +! summary: This sumodule contains method for geometry + +SUBMODULE(ReferenceElement_Method) LocalNodeCoordsMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Localnodecoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Local_nodecoord +IF (ALLOCATED(nodecoord)) DEALLOCATE (nodecoord) + +SELECT CASE (ElemType) +CASE (Point1) + ALLOCATE (nodecoord(3, 1)) + nodecoord = 0.0_DFP + +CASE (Line2) + ALLOCATE (nodecoord(3, 2)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [-1.0_DFP, 1.0_DFP] + +CASE (Line3) + ALLOCATE (nodecoord(3, 3)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [-1.0_DFP, 1.0_DFP, 0.0_DFP] + +CASE (Line4) + ALLOCATE (nodecoord(3, 4)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [ & + -1.0_DFP, 1.0_DFP, & + -0.333333333333333_DFP, & + 0.333333333333333_DFP] + +CASE (Line5) + ALLOCATE (nodecoord(3, 5)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [ & + -1.0_DFP, 1.0_DFP, & + -0.5_DFP, 0.0_DFP, & + 0.5_DFP] + +CASE (Line6) + ALLOCATE (nodecoord(3, 6)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [ & + -1.0_DFP, 1.0_DFP, & + -0.666666666666666_DFP, & + -0.333333333333333_DFP, & + 0.666666666666666_DFP, & + 0.333333333333333_DFP] + +CASE (Triangle3) + ALLOCATE (nodecoord(3, 3)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [0.0_DFP, 1.0_DFP, 0.0_DFP] + nodecoord(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP] + +CASE (Triangle6) + ALLOCATE (nodecoord(3, 6)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.5_DFP, 0.5_DFP, 0.0_DFP] + nodecoord(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP, & + & 0.0_DFP, 0.5_DFP, 0.5_DFP] + +CASE (Triangle9) + ALLOCATE (nodecoord(3, 9)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [ & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.33333333333333333333_DFP, & + 0.66666666666666666667_DFP, & + 0.66666666666666666667_DFP, & + 0.33333333333333333333_DFP, & + 0.0_DFP, & + 0.0_DFP] + + nodecoord(2, :) = [ & + 0.0_DFP, & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.33333333333333333333_DFP, & + 0.66666666666666666667_DFP, & + 0.66666666666666666667_DFP, & + 0.33333333333333333333_DFP] + +CASE (Triangle10) + ALLOCATE (nodecoord(3, 10)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [ & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.33333333333333333333_DFP, & + 0.66666666666666666667_DFP, & + 0.66666666666666666667_DFP, & + 0.33333333333333333333_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.33333333333333333333_DFP] + + nodecoord(2, :) = [ & + 0.0_DFP, & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.33333333333333333333_DFP, & + 0.66666666666666666667_DFP, & + 0.66666666666666666667_DFP, & + 0.33333333333333333333_DFP, & + 0.33333333333333333333_DFP] + +CASE (Triangle12) + ! incomplete triangle; all nodes on boundary + ALLOCATE (nodecoord(3, 12)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [ & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.25_DFP, & + 0.5_DFP, & + 0.75_DFP, & + 0.75_DFP, & + 0.5_DFP, & + 0.25_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP] + + nodecoord(2, :) = [ & + 0.0_DFP, & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.25_DFP, & + 0.5_DFP, & + 0.75_DFP, & + 0.75_DFP, & + 0.5_DFP, & + 0.25_DFP] + +CASE (Triangle15a) + ! complete triangle; 12 nodes on boundary and + ! 3 nodes are inside + ALLOCATE (nodecoord(3, 15)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [ & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.25_DFP, & + 0.5_DFP, & + 0.75_DFP, & + 0.75_DFP, & + 0.5_DFP, & + 0.25_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.25_DFP, & + 0.5_DFP, & + 0.25_DFP] + + nodecoord(2, :) = [ & + 0.0_DFP, & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.25_DFP, & + 0.5_DFP, & + 0.75_DFP, & + 0.75_DFP, & + 0.5_DFP, & + 0.25_DFP, & + 0.25_DFP, & + 0.25_DFP, & + 0.5_DFP] + +CASE (Triangle15b) + ! Incomplete triangle + ALLOCATE (nodecoord(3, 15)) + nodecoord = 0.0_DFP + + nodecoord(1, :) = [ & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.2_DFP, & + 0.4_DFP, & + 0.6_DFP, & + 0.8_DFP, & + 0.8_DFP, & + 0.6_DFP, & + 0.4_DFP, & + 0.2_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP] + + nodecoord(2, :) = [ & + 0.0_DFP, & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.2_DFP, & + 0.4_DFP, & + 0.6_DFP, & + 0.8_DFP, & + 0.8_DFP, & + 0.6_DFP, & + 0.4_DFP, & + 0.2_DFP] + +CASE (Triangle21) + ALLOCATE (nodecoord(3, 21)) + nodecoord = 0.0_DFP + + nodecoord(1, :) = [ & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.2_DFP, & + 0.4_DFP, & + 0.6_DFP, & + 0.8_DFP, & + 0.8_DFP, & + 0.6_DFP, & + 0.4_DFP, & + 0.2_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.2_DFP, & + 0.6_DFP, & + 0.2_DFP, & + 0.4_DFP, & + 0.4_DFP, & + 0.2_DFP] + + nodecoord(2, :) = [ & + 0.0_DFP, & + 0.0_DFP, & + 1.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.0_DFP, & + 0.2_DFP, & + 0.4_DFP, & + 0.6_DFP, & + 0.8_DFP, & + 0.8_DFP, & + 0.6_DFP, & + 0.4_DFP, & + 0.2_DFP, & + 0.2_DFP, & + 0.2_DFP, & + 0.6_DFP, & + 0.2_DFP, & + 0.4_DFP, & + 0.4_DFP] + +CASE (Quadrangle4) + ALLOCATE (nodecoord(3, 4)) + nodecoord = 0.0_DFP + nodecoord(1, :) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, 1.0_DFP] + nodecoord(2, :) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP] + +CASE (Quadrangle8) + nodecoord = RESHAPE([ & + -1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_DFP, 1.0_DFP, 0.0_DFP, & + 0.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, 0.0_DFP, 0.0_DFP, & + 0.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 8]) + +CASE (Quadrangle9) + nodecoord = RESHAPE([ & + -1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_DFP, 1.0_DFP, 0.0_DFP, & + 0.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, 0.0_DFP, 0.0_DFP, & + 0.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_DFP, 0.0_DFP, 0.0_DFP, & + 0.0_DFP, 0.0_DFP, 0.0_DFP], [3, 9]) + +CASE (Quadrangle16) + nodecoord = RESHAPE([ & + -1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_dfp/3.0_dfp, -1.0_DFP, 0.0_DFP, & + 1.0_dfp/3.0_dfp, -1.0_DFP, 0.0_DFP, & + 1.0_dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & + 1.0_dfp, 1.0_DFP/3.0_dfp, 0.0_DFP, & + 1.0_dfp/3.0_dfp, 1.0_DFP, 0.0_DFP, & + -1.0_dfp/3.0_dfp, 1.0_DFP, 0.0_DFP, & + -1.0_dfp, 1.0_DFP/3.0_dfp, 0.0_DFP, & + -1.0_dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & + -1.0_dfp/3.0_Dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & + 1.0_dfp/3.0_Dfp, -1.0_DFP/3.0_dfp, 0.0_DFP, & + 1.0_dfp/3.0_Dfp, 1.0_DFP/3.0_dfp, 0.0_DFP, & + -1.0_dfp/3.0_Dfp, 1.0_DFP/3.0_dfp, 0.0_DFP], & + [3, 16]) + +CASE (Hexahedron8) + nodecoord = RESHAPE([ & + -1.0_DFP, -1.0_DFP, -1.0_DFP, & + 1.0_DFP, -1.0_DFP, -1.0_DFP, & + 1.0_DFP, 1.0_DFP, -1.0_DFP, & + -1.0_DFP, 1.0_DFP, -1.0_DFP, & + -1.0_DFP, -1.0_DFP, 1.0_DFP, & + 1.0_DFP, -1.0_DFP, 1.0_DFP, & + 1.0_DFP, 1.0_DFP, 1.0_DFP, & + -1.0_DFP, 1.0_DFP, 1.0_DFP], [3, 8]) + +CASE (Hexahedron20) + nodecoord = RESHAPE([ & + -1.0_DFP, -1.0_DFP, -1.0_DFP, & + 1.0_DFP, -1.0_DFP, -1.0_DFP, & + 1.0_DFP, 1.0_DFP, -1.0_DFP, & + -1.0_DFP, 1.0_DFP, -1.0_DFP, & + -1.0_DFP, -1.0_DFP, 1.0_DFP, & + 1.0_DFP, -1.0_DFP, 1.0_DFP, & + 1.0_DFP, 1.0_DFP, 1.0_DFP, & + -1.0_DFP, 1.0_DFP, 1.0_DFP, & + 0.0_DFP, -1.0_DFP, -1.0_DFP, & + -1.0_DFP, 0.0_DFP, -1.0_DFP, & + -1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, 0.0_DFP, -1.0_DFP, & + 1.0_DFP, -1.0_DFP, 0.0_DFP, & + 0.0_DFP, 1.0_DFP, -1.0_DFP, & + 1.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_DFP, 1.0_DFP, 0.0_DFP, & + 0.0_DFP, -1.0_DFP, 1.0_DFP, & + -1.0_DFP, 0.0_DFP, 1.0_DFP, & + 1.0_DFP, 0.0_DFP, 1.0_DFP, & + 0.0_DFP, 1.0_DFP, 1.0_DFP], [3, 20]) + +CASE (Hexahedron27) + nodecoord = RESHAPE([ & + -1.0_DFP, -1.0_DFP, -1.0_DFP, & + 1.0_DFP, -1.0_DFP, -1.0_DFP, & + 1.0_DFP, 1.0_DFP, -1.0_DFP, & + -1.0_DFP, 1.0_DFP, -1.0_DFP, & + -1.0_DFP, -1.0_DFP, 1.0_DFP, & + 1.0_DFP, -1.0_DFP, 1.0_DFP, & + 1.0_DFP, 1.0_DFP, 1.0_DFP, & + -1.0_DFP, 1.0_DFP, 1.0_DFP, & + 0.0_DFP, -1.0_DFP, -1.0_DFP, & + -1.0_DFP, 0.0_DFP, -1.0_DFP, & + -1.0_DFP, -1.0_DFP, 0.0_DFP, & + 1.0_DFP, 0.0_DFP, -1.0_DFP, & + 1.0_DFP, -1.0_DFP, 0.0_DFP, & + 0.0_DFP, 1.0_DFP, -1.0_DFP, & + 1.0_DFP, 1.0_DFP, 0.0_DFP, & + -1.0_DFP, 1.0_DFP, 0.0_DFP, & + 0.0_DFP, -1.0_DFP, 1.0_DFP, & + -1.0_DFP, 0.0_DFP, 1.0_DFP, & + 1.0_DFP, 0.0_DFP, 1.0_DFP, & + 0.0_DFP, 1.0_DFP, 1.0_DFP, & + 0.0_DFP, 0.0_DFP, -1.0_DFP, & + 0.0_DFP, -1.0_DFP, 0.0_DFP, & + -1.0_DFP, 0.0_DFP, 0.0_DFP, & + 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, & + 0.0_DFP, 0.0_DFP, 0.0_DFP], [3, 27]) +END SELECT + +END PROCEDURE Local_nodecoord + +!----------------------------------------------------------------------------- +! FacetMatrix +!----------------------------------------------------------------------------- + +MODULE PROCEDURE Local_nodecoord_refelem +IF (ALLOCATED(refelem%xij)) THEN + nodecoord = refelem%xij +ELSE + ALLOCATE (nodecoord(0, 0)) +END IF +END PROCEDURE Local_nodecoord_refelem + +END SUBMODULE LocalNodeCoordsMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 new file mode 100644 index 000000000..17ecc9228 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 @@ -0,0 +1,154 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: VTK format element + +SUBMODULE(ReferenceElement_Method) VTKMethods +USE Utility, ONLY: arange +IMPLICIT NONE + +INTEGER(I4B), PARAMETER :: & + & vtk_point = 1, & + & vtk_line2 = 3, & + & vtk_triangle3 = 5, & + & vtk_quadrangle4 = 9, & + & vtk_tetrahedron4 = 10, & + & vtk_hexahedron8 = 12, & + & vtk_prism6 = 13, & + & vtk_pyramid5 = 14, & + & vtk_line3 = 21, & + & vtk_triangle6 = 22, & + & vtk_quadrangle8 = 23, & + & vtk_quadrangle9 = 28, & + & vtk_tetrahedron10 = 24, & + & vtk_hexahedron20 = 25, & + & vtk_hexahedron27 = 29, & + & vtk_prism15 = 26, & + & vtk_prism18 = 32, & + & vtk_line4 = 35, & + & vtk_pyramid13 = 27, & + & vtk_quadrangle16 = 70 +! VTK_LAGRANGE_QUADRILATERAL +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_vtk_elemType + +SELECT CASE (ElemType) +CASE (Point1) + vtk_type = vtk_point + nptrs = [1] + +CASE (Line2) + vtk_type = vtk_line2 + nptrs = [1, 2] + +CASE (Triangle3) + vtk_type = vtk_triangle3 + nptrs = [1, 2, 3] + +CASE (Quadrangle4) + vtk_type = vtk_quadrangle4 + nptrs = [1, 2, 3, 4] + +CASE (Tetrahedron4) + vtk_type = vtk_Tetrahedron4 + nptrs = [1, 2, 3, 4] + +CASE (Hexahedron8) + vtk_type = vtk_Hexahedron8 + nptrs = [1, 2, 3, 4, 5, 6, 7, 8] + +CASE (Prism6) + vtk_type = vtk_Prism6 + nptrs = [1, 2, 3, 4, 5, 6] + +CASE (Pyramid5) + vtk_type = vtk_Pyramid5 + nptrs = [1, 2, 3, 4, 5] + + !! Order=2 elements +CASE (Line3) + vtk_type = vtk_line3 + nptrs = [1, 2, 3] + +CASE (Triangle6) + vtk_type = vtk_Triangle6 + nptrs = [1, 2, 3, 4, 5, 6] + +CASE (Quadrangle9) + vtk_type = vtk_Quadrangle9 + nptrs = [1, 2, 3, 4, 5, 6, 7, 8, 9] + +CASE (Quadrangle8) + vtk_type = vtk_Quadrangle8 + nptrs = [1, 2, 3, 4, 5, 6, 7, 8] + +CASE (Tetrahedron10) + vtk_type = vtk_Tetrahedron10 + nptrs = 1 + [0, 1, 2, 3, 4, 5, 6, 7, 9, 8] + +CASE (Hexahedron20) + vtk_type = vtk_Hexahedron20 + nptrs = 1 + [0, 1, 2, 3, 4, 5, 6, 7, & + & 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14] + +CASE (Hexahedron27) + vtk_type = vtk_Hexahedron27 + nptrs = 1 + [0, 1, 2, 3, 4, 5, 6, 7, & + & 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14, & + & 24, 22, 20, 21, 23, 25, 26] + +CASE (Prism15) + vtk_type = vtk_Prism15 + nptrs = 1 + [0, 1, 2, 3, 4, 5, & + & 6, 8, 12, 7, 13, 14, 9, 11, 10] + +CASE (Prism18) + vtk_type = vtk_Prism18 + nptrs = 1 + [0, 1, 2, 3, 4, 5, & + & 6, 8, 12, 7, 13, 14, 9, 11, 10, & + & 15, 17, 16] + +CASE (Pyramid13) + vtk_type = vtk_Pyramid13 + nptrs = 1 + [0, 1, 2, 3, 4, 5, & + & 5, 8, 9, 6, 10, 7, 11, 12] + +CASE (Pyramid14) + vtk_type = vtk_Pyramid13 + nptrs = 1 + [0, 1, 2, 3, 4, 5, & + & 5, 8, 9, 6, 10, 7, 11, 12] + + !! order=3 element +CASE (Line4) + vtk_type = vtk_line4 + nptrs = [1, 2, 3, 4] + +CASE (Quadrangle16) + vtk_type = vtk_Quadrangle16 + nptrs = [1, 2, 3, 4, 5, 6, 7, 8, 10, 9, & + 12, 11, 13, 14, 16, 15] +END SELECT +END PROCEDURE get_vtk_elemType + +END SUBMODULE VTKMethods diff --git a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 new file mode 100644 index 000000000..82e3b9346 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 @@ -0,0 +1,629 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This module contains method for [[ReferenceHexahedron_]] + +SUBMODULE(ReferenceHexahedron_Method) Methods +USE ReferenceElement_Method +USE ApproxUtility +USE InvUtility +USE InputUtility +USE StringUtility +USE ArangeUtility +USE MiscUtility, ONLY: Int2STR + +USE ReferenceLine_Method, ONLY: ElementType_Line + +USE ReferenceQuadrangle_Method, ONLY: RefQuadrangleCoord, & + & ElementOrder_Quadrangle, & + & TotalEntities_Quadrangle, & + & FacetTopology_Quadrangle + +USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle + +USE HexahedronInterpolationUtility, ONLY: LagrangeDOF_Hexahedron, & + & InterpolationPoint_Hexahedron + +USE ReferencePrism_Method, ONLY: PolyhedronVolume3d +USE ReallocateUtility + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElementName_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementName_Hexahedron +SELECT CASE (elemType) +CASE (Hexahedron8) + ans = "Hexahedron8" + +CASE (Hexahedron27) + ans = "Hexahedron27" + +CASE (Hexahedron20) + ans = "Hexahedron20" + +CASE (Hexahedron64) + ans = "Hexahedron64" + +CASE (Hexahedron125) + ans = "Hexahedron125" + +CASE DEFAULT + ans = "NONE" +END SELECT + +END PROCEDURE ElementName_Hexahedron + +!---------------------------------------------------------------------------- +! FacetElements_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Hexahedron1 +INTEGER(I4B) :: ii, istart, tsize, jj +TYPE(ReferenceTopology_) :: topo + +istart = refelem%entityCounts(1) + refelem%entityCounts(2) +! tPoints + tEdges + +ii = 1 +ans(ii)%nsd = refelem%nsd +ans(ii)%interpolationPointType = refelem%interpolationPointType +ans(ii)%xij = InterpolationPoint_Quadrangle( & + & order=refelem%order, & + & ipType=refelem%interpolationPointType, & + & layout="VEFC") + +DO ii = 2, 4 + ans(ii)%nsd = ans(1)%nsd + ans(ii)%interpolationPointType = ans(1)%interpolationPointType + ans(ii)%xij = ans(1)%xij +END DO + +DO ii = 1, 4 + + topo = refelem%topology(istart + ii) + ans(ii)%xidimension = topo%xidimension + ans(ii)%name = topo%name + + ans(ii)%order = ElementOrder_Quadrangle(topo%name) + ans(ii)%entityCounts = TotalEntities_Quadrangle(topo%name) + + tsize = SUM(ans(ii)%entityCounts) + ! ALLOCATE (ans(ii)%topology(tsize)) + CALL RefTopoReallocate(ans(ii)%topology, tsize) + + ! points + DO jj = 1, ans(ii)%entityCounts(1) + ans(ii)%topology(jj) = ReferenceTopology(nptrs=topo%nptrs(jj:jj), & + & name=Point) + END DO + + ! lines + jj = ans(ii)%entityCounts(1) + CALL FacetTopology_Quadrangle(elemType=topo%name, & + & nptrs=topo%nptrs, ans=ans(ii)%topology(jj + 1:)) + + ! surface + tsize = jj + ans(ii)%entityCounts(2) + ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=topo%nptrs, & + & name=topo%name) + +END DO + +CALL DEALLOCATE (topo) + +END PROCEDURE FacetElements_Hexahedron1 + +!---------------------------------------------------------------------------- +! FacetElements_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Hexahedron2 +INTEGER(I4B), PARAMETER :: tface = 6 +INTEGER(I4B) :: ii, jj, order, entityCounts(4), tsize +INTEGER(I4B), ALLOCATABLE :: edgeCon(:, :), faceCon(:, :) +INTEGER(I4B) :: faceElemType(tface), tFaceNodes(tface) + +CALL GetFaceElemType_Hexahedron( & + & faceElemType=faceElemType, & + & tFaceNodes=tFaceNodes, & + & elemType=elemType) + +entityCounts = TotalEntities_Hexahedron(elemType) +order = ElementOrder_Hexahedron(elemType) + +CALL Reallocate(edgeCon, order + 1, entityCounts(2)) +CALL Reallocate(faceCon, tFaceNodes(1), tface) + +CALL GetEdgeConnectivity_Hexahedron(con=edgeCon, order=order) +CALL GetFaceConnectivity_Hexahedron(con=faceCon, order=order) + +DO ii = 1, tface + + ans(ii)%xiDimension = 2 + ans(ii)%order = order + ans(ii)%name = faceElemType(ii) + ans(ii)%interpolationPointType = Equidistance + + ans(ii)%xij = InterpolationPoint_Quadrangle( & + & order=ans(ii)%order, & + & ipType=ans(ii)%interpolationPointType, & + & layout="VEFC") + + ans(ii)%nsd = nsd + ans(ii)%entityCounts = TotalEntities_Quadrangle(ans(ii)%name) + + tsize = SUM(ans(ii)%entityCounts) + CALL RefTopoReallocate(ans(ii)%topology, tsize) + ! ALLOCATE (ans(ii)%topology(tsize)) + + ! points + DO jj = 1, ans(ii)%entityCounts(1) + ans(ii)%topology(jj) = Referencetopology(nptrs=faceCon(jj:jj, ii), & + & name=Point) + END DO + + ! lines + jj = ans(ii)%entityCounts(1) + CALL FacetTopology_Quadrangle(elemType=ans(ii)%name, & + & nptrs=faceCon(:, ii), ans=ans(ii)%topology(jj + 1:)) + + ! surface + tsize = jj + ans(ii)%entityCounts(2) + ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=faceCon(:, ii), & + & name=ans(ii)%name) + +END DO + +IF (ALLOCATED(edgeCon)) DEALLOCATE (edgeCon) +IF (ALLOCATED(faceCon)) DEALLOCATE (faceCon) +END PROCEDURE FacetElements_Hexahedron2 + +!---------------------------------------------------------------------------- +! FacetTopology_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetTopology_Hexahedron +INTEGER(I4B), PARAMETER :: tface = 6 +INTEGER(I4B) :: ii, faceElemType(tface), tFaceNodes(tface) +INTEGER(I4B), ALLOCATABLE :: con(:, :) + +CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, & + & elemType=elemType, tFaceNodes=tFaceNodes) + +CALL Reallocate(con, tFaceNodes(1), tface) + +ii = ElementOrder_Hexahedron(elemType=elemType) +CALL GetFaceConnectivity_Hexahedron(con=con, order=ii) + +DO ii = 1, tface + ans(ii)%nptrs = nptrs(con(1:tFaceNodes(ii), ii)) + ans(ii)%xiDimension = 2 + ans(ii)%name = faceElemType(ii) +END DO + +IF (ALLOCATED(con)) DEALLOCATE (con) +END PROCEDURE FacetTopology_Hexahedron + +!---------------------------------------------------------------------------- +! TotalEntities_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalEntities_Hexahedron +ans(2:4) = [12, 6, 1] +ans(1) = TotalNodesInElement_Hexahedron(elemType) +END PROCEDURE TotalEntities_Hexahedron + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Hexahedron +SELECT CASE (elemType) +CASE (Hexahedron8) + ans = 8 +CASE (Hexahedron20) + ans = 20 +CASE (Hexahedron27) + ans = 27 +CASE (Hexahedron64) + ans = 64 +CASE (Hexahedron125) + ans = 125 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Hexahedron + +!---------------------------------------------------------------------------- +! ElementType_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementType_Hexahedron +SELECT CASE (elemName) +CASE ("Hexahedron8", "Hexahedron") + ans = Hexahedron8 +CASE ("Hexahedron20") + ans = Hexahedron20 +CASE ("Hexahedron27") + ans = Hexahedron27 +CASE ("Hexahedron64") + ans = Hexahedron64 +CASE ("Hexahedron125") + ans = Hexahedron125 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementType_Hexahedron + +!---------------------------------------------------------------------------- +! ElementOrder_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementOrder_Hexahedron +SELECT CASE (ElemType) +CASE (Hexahedron) + ans = 1 +CASE (Hexahedron20) + ans = 2 +CASE (Hexahedron27) + ans = 2 +CASE (Hexahedron64) + ans = 3 +CASE (Hexahedron125) + ans = 4 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementOrder_Hexahedron + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_Ref_Hexahedron +INTEGER(I4B) :: ii, jj +INTEGER(I4B) :: p1p2(2, 12), lloop(4, 6), vol(8, 1) +REAL(DFP) :: unit_xij(3, 8), biunit_xij(3, 8) + +CALL DEALLOCATE (obj) +unit_xij = RefCoord_Hexahedron("UNIT") +biunit_xij = RefCoord_Hexahedron("BIUNIT") + +IF (PRESENT(xij)) THEN + obj%xij = xij(1:3, 1:8) + IF (ALL(obj%xij(1:3, 1:8) .approxeq.unit_xij)) THEN + obj%domainName = "UNIT" + ELSE IF (ALL(obj%xij(1:3, 1:8) .approxeq.biunit_xij)) THEN + obj%domainName = "BIUNIT" + ELSE + obj%domainName = "GENERAL" + END IF + +ELSE + + IF (PRESENT(domainName)) THEN + obj%domainName = UpperCase(domainName) + IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN + obj%xij = RefCoord_Hexahedron(obj%domainName) + END IF + ELSE + obj%domainName = "BIUNIT" + obj%xij = RefCoord_Hexahedron(obj%domainName) + END IF + +END IF + +CALL GetEdgeConnectivity_Hexahedron(con=p1p2, order=1_I4B) +CALL GetFaceConnectivity_Hexahedron(con=lloop, order=1_I4B) + +vol(:, 1) = arange(1_I4B, 8_I4B) + +obj%entityCounts = TotalEntities_Hexahedron(Hexahedron8) +obj%xidimension = 3 +obj%name = Hexahedron8 +obj%order = 1 +obj%nsd = nsd + +ii = SUM(obj%entityCounts) +CALL RefTopoReallocate(obj%topology, ii) + +! points +DO ii = 1, obj%entityCounts(1) + obj%topology(ii) = ReferenceTopology([ii], Point) +END DO + +! lines +jj = obj%entityCounts(1) +DO ii = 1, obj%entityCounts(2) + obj%topology(jj + ii) = ReferenceTopology(nptrs=p1p2(:, ii), & + & name=Line2) +END DO + +! faces +jj = jj + obj%entityCounts(2) +DO ii = 1, obj%entityCounts(3) + obj%topology(jj + ii) = ReferenceTopology(nptrs=lloop(:, ii), & + & name=Quadrangle4) +END DO + +! cell +jj = jj + obj%entityCounts(3) +obj%topology(jj + 1) = ReferenceTopology(vol(:, 1), Hexahedron8) + +obj%highorderElement => HighorderElement_Hexahedron +END PROCEDURE Initiate_Ref_Hexahedron + +!---------------------------------------------------------------------------- +! ReferenceHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Hexahedron +CALL Initiate_Ref_Hexahedron(obj=obj, nsd=NSD, xij=xij, & + & domainName=domainName) +END PROCEDURE Reference_Hexahedron + +!---------------------------------------------------------------------------- +! ReferenceHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Hexahedron_Pointer +ALLOCATE (obj) +CALL Initiate_Ref_Hexahedron(obj=obj, nsd=NSD, xij=xij, & + & domainName=domainName) +END PROCEDURE Reference_Hexahedron_Pointer + +!---------------------------------------------------------------------------- +! highOrderElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HighorderElement_Hexahedron +INTEGER(I4B) :: ii, tFaceNodes(8), faceElemType(8), jj, & + & edgetype +INTEGER(I4B), ALLOCATABLE :: edgecon(:, :), facecon(:, :) + +CALL DEALLOCATE (obj) + +obj%xij = InterpolationPoint_Hexahedron( & + & xij=refelem%xij(1:3, 1:8), & + & order=order, & + & ipType=ipType, & + & layout="VEFC") + +obj%domainName = refelem%domainName +obj%nsd = refelem%nsd +obj%highOrderElement => refelem%highOrderElement +obj%order = order +obj%xiDimension = refelem%xiDimension + +ii = LagrangeDOF_Hexahedron(order=order) +obj%name = ElementType_Hexahedron("Hexahedron"//INT2STR(ii)) +obj%entityCounts = TotalEntities_Hexahedron(obj%name) + +ii = SUM(obj%entityCounts) +CALL RefTopoReallocate(obj%topology, ii) + +! points +DO ii = 1, obj%entityCounts(1) + obj%topology(ii) = ReferenceTopology([ii], Point) +END DO + +CALL Reallocate(edgecon, order + 1, obj%entityCounts(2)) +CALL GetEdgeConnectivity_Hexahedron(con=edgecon, order=order) +edgetype = ElementType_Line("Line"//Int2STR(order + 1)) + +! lines +jj = obj%entityCounts(1) +DO ii = 1, obj%entityCounts(2) + obj%topology(jj + ii) = ReferenceTopology(nptrs=edgecon(:, ii), & + & name=edgetype) +END DO + +CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, & + & tFaceNodes=tFaceNodes, elemType=obj%name) +CALL Reallocate(facecon, tFaceNodes(1), obj%entityCounts(3)) +CALL GetFaceConnectivity_Hexahedron(con=facecon, order=order) + +! faces +jj = jj + obj%entityCounts(2) +DO ii = 1, obj%entityCounts(3) + obj%topology(jj + ii) = ReferenceTopology( & + & nptrs=facecon(1:tFaceNodes(ii), ii), & + & name=faceElemType(ii)) +END DO + +! cell +jj = jj + obj%entityCounts(3) +obj%topology(jj + 1) = ReferenceTopology( & + & arange(1_I4B, obj%entityCounts(1)), obj%name) + +IF (ALLOCATED(edgecon)) DEALLOCATE (edgecon) +IF (ALLOCATED(facecon)) DEALLOCATE (facecon) + +END PROCEDURE HighorderElement_Hexahedron + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Hexahedron +INTEGER(I4B) :: Order0(6), Node0(6, 4), FM(6, 7), iFace, b +Order0 = [4, 4, 4, 4, 4, 4] +FM = FacetMatrix(RefElem) +DO iFace = 1, 6 + b = FM(iFace, 3) + 3 + Node0(iFace, 1:Order0(iFace)) = FM(iFace, 4:b) +END DO +CALL PolyhedronVolume3d(coord=XiJ(1:3, 1:8), & + & order_max=4, face_num=6, node=node0, node_num=8, & + & order=order0, ans=ans) +END PROCEDURE Measure_Simplex_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Hexahedron_Quality +ans = 0.0_I4B +! TODO Implement Hexahedron_quality +END PROCEDURE Hexahedron_quality + +!---------------------------------------------------------------------------- +! HexahedronVolume3D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HexahedronVolume3D +TYPE(ReferenceHexahedron_) :: refelem +CALL Initiate_Ref_Hexahedron(obj=refelem, nsd=3_I4B) +ans = Measure_Simplex_Hexahedron(refelem=refelem, xij=xij) +CALL DEALLOCATE (refelem) +END PROCEDURE HexahedronVolume3D + +!---------------------------------------------------------------------------- +! RefHexahedronCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefHexahedronCoord +REAL(DFP) :: one, mone +CHARACTER(:), ALLOCATABLE :: astr + +astr = UpperCase(refHexahedron) + +SELECT CASE (astr) +CASE ("UNIT") + one = 1.0_DFP + mone = 0.0_DFP +CASE ("BIUNIT") + one = 1.0_DFP + mone = -1.0_DFP +END SELECT + +astr = "" + +ans(3, 1:4) = mone +ans(3, 5:8) = one +ans(1:2, 1:4) = RefQuadrangleCoord(refHexahedron) +ans(1:2, 5:8) = ans(1:2, 1:4) +END PROCEDURE RefHexahedronCoord + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity_Hexahedron +INTEGER(I4B) :: order0, ii, jj, iface +con(1:2, 1) = [1, 2] +con(1:2, 2) = [1, 4] +con(1:2, 3) = [1, 5] +con(1:2, 4) = [2, 3] +con(1:2, 5) = [2, 6] +con(1:2, 6) = [3, 4] +con(1:2, 7) = [3, 7] +con(1:2, 8) = [4, 8] +con(1:2, 9) = [5, 6] +con(1:2, 10) = [5, 8] +con(1:2, 11) = [6, 7] +con(1:2, 12) = [7, 8] + +order0 = Input(default=1_I4B, option=order) + +IF (PRESENT(ncol)) ncol = 12 +IF (PRESENT(nrow)) nrow = order0 + 1 + +jj = 8 +DO iface = 1, 12 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + END DO + jj = jj + order0 - 1 +END DO + +END PROCEDURE GetEdgeConnectivity_Hexahedron + +!---------------------------------------------------------------------------- +! GetFaceConnectivity_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity_Hexahedron +INTEGER(I4B) :: order0, ii +con(1:4, 1) = [1, 4, 3, 2] ! back +con(1:4, 2) = [5, 6, 7, 8] ! front +con(1:4, 3) = [1, 5, 8, 4] ! left +con(1:4, 4) = [2, 3, 7, 6] ! right +con(1:4, 5) = [1, 2, 6, 5] ! bottom +con(1:4, 6) = [3, 4, 8, 7] ! top + +order0 = Input(default=1_I4B, option=order) + +IF (PRESENT(ncol)) ncol = 6 + +ii = 5 + +SELECT CASE (order0) +CASE (2_I4B) + con(ii:8, 1) = [10, 14, 12, 9, 21] ! back + con(ii:8, 2) = [17, 19, 20, 18, 22] ! front + con(ii:8, 3) = [11, 18, 16, 10, 23] ! left + con(ii:8, 4) = [12, 15, 19, 13, 24] ! right + con(ii:8, 5) = [9, 13, 17, 11, 25] ! bottom + con(ii:8, 6) = [14, 16, 20, 15, 26] ! top + ii = 9 +END SELECT + +IF (PRESENT(nrow)) nrow = ii - 1 + +END PROCEDURE GetFaceConnectivity_Hexahedron + +!---------------------------------------------------------------------------- +! GetFaceElemType_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Hexahedron +INTEGER(I4B) :: elemType0 +elemType0 = Input(default=Hexahedron8, option=elemType) + +SELECT CASE (elemType0) +CASE (Hexahedron8) + + IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle4 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 4_I4B + +CASE (Hexahedron20) + IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle8 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 8_I4B + +CASE (Hexahedron27) + IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle9 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 9_I4B + +CASE (Hexahedron64) + IF (PRESENT(faceElemType)) faceElemType(1:6) = Quadrangle16 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 16_I4B + +END SELECT +END PROCEDURE GetFaceElemType_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 new file mode 100644 index 000000000..918998090 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 @@ -0,0 +1,376 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This submodule contains methods for [[ReferenceLine_]] + +SUBMODULE(ReferenceLine_Method) Methods +USE ReallocateUtility +USE ReferenceElement_Method +USE StringUtility +USE ApproxUtility +USE String_Class, ONLY: String +USE LineInterpolationUtility +USE Display_Method +USE InputUtility +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElementName_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementName_Line +SELECT CASE (elemType) +CASE (Point1) + ans = "Point1" +CASE (Line2) + ans = "Line2" +CASE (Line3) + ans = "Line3" +CASE (Line4) + ans = "Line4" +CASE (Line5) + ans = "Line5" +CASE (Line6) + ans = "Line6" +CASE DEFAULT + ans = "NONE" +END SELECT +END PROCEDURE ElementName_Line + +!---------------------------------------------------------------------------- +! FacetTopology_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetTopology_Line +ans(1)%nptrs = nptrs([1]) +ans(1)%xiDimension = 0 +ans(1)%name = Point + +ans(2)%nptrs = nptrs([2]) +ans(2)%xiDimension = 0 +ans(2)%name = Point +END PROCEDURE FacetTopology_Line + +!---------------------------------------------------------------------------- +! TotalEntities_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalEntities_Line +ans(1) = TotalNodesInElement_Line(elemType) +ans(2) = 1 +ans(3:4) = 0 +END PROCEDURE TotalEntities_Line + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Line +SELECT CASE (ElemType) +CASE (Line1) + ans = 1 +CASE (Line2) + ans = 2 +CASE (Line3) + ans = 3 +CASE (Line4) + ans = 4 +CASE (Line5) + ans = 5 +CASE (Line6) + ans = 6 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Line + +!---------------------------------------------------------------------------- +! ElementOrder_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementOrder_Line +SELECT CASE (elemType) +CASE (Line2) + ans = 1 +CASE (Line3) + ans = 2 +CASE (Line4) + ans = 3 +CASE (Line5) + ans = 4 +CASE (Line6) + ans = 5 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementOrder_Line + +!---------------------------------------------------------------------------- +! ElementType_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementType_Line +SELECT CASE (elemName) +CASE ("Line1", "Point", "Point1") + ans = Point +CASE ("Line2", "Line") + ans = Line2 +CASE ("Line3") + ans = Line3 +CASE ("Line4") + ans = Line4 +CASE ("Line5") + ans = Line5 +CASE ("Line6") + ans = Line6 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementType_Line + +!---------------------------------------------------------------------------- +! FacetElements_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Line1 +INTEGER(I4B) :: ii +INTEGER(I4B) :: nptrs(1) + +DO ii = 1, 2 + nptrs = refelem%topology(ii)%nptrs + CALL Reallocate(ans(ii)%xij, 3_I4B, 1) + ans(ii)%xij(1:3, 1) = DEFAULT_REF_LINE_COORD(1:3, ii) + ans(ii)%entityCounts = [1, 0, 0, 0] + ans(ii)%xiDimension = 0 + ans(ii)%name = Point + ans(ii)%interpolationPointType = refelem%interpolationPointType + ans(ii)%order = 0 + ans(ii)%nsd = refelem%nsd + ALLOCATE (ans(ii)%topology(1)) + ans(ii)%topology(1) = Referencetopology(nptrs=nptrs, name=Point) + ans(ii)%highOrderElement => NULL() +END DO +END PROCEDURE FacetElements_Line1 + +!---------------------------------------------------------------------------- +! FacetElements_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Line2 +INTEGER(I4B), PARAMETER :: nptrs(2) = [1, 2] +INTEGER(I4B) :: ii + +DO ii = 1, 2 + ans(ii)%xij = RESHAPE(DEFAULT_REF_LINE_COORD(1:3, ii), [3, 1]) + ans(ii)%entityCounts = [1, 0, 0, 0] + ans(ii)%xiDimension = 0 + ans(ii)%name = Point + ans(ii)%interpolationPointType = Equidistance + ans(ii)%order = 0 + ans(ii)%nsd = nsd + ALLOCATE (ans(ii)%topology(1)) + ans(ii)%topology(1) = Referencetopology(nptrs=nptrs(ii:ii), name=Point) + ans(ii)%highOrderElement => NULL() +END DO +END PROCEDURE FacetElements_Line2 + +!---------------------------------------------------------------------------- +! LineName +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LineName1 +SELECT CASE (order) +CASE (1) + ans = Line2 +CASE (2) + ans = Line3 +CASE (3) + ans = Line4 +CASE (4) + ans = Line5 +CASE (5) + ans = Line6 +CASE (6:) + ans = Line6 * 100 + order - 5 +END SELECT +END PROCEDURE LineName1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_ref_Line +REAL(DFP) :: unit_xij(1, 2), biunit_xij(1, 2) + +CALL DEALLOCATE (obj) + +unit_xij = RefCoord_Line("UNIT") +biunit_xij = RefCoord_Line("BIUNIT") + +IF (PRESENT(xij)) THEN + obj%xij = xij(1:1, 1:2) + IF (ALL(obj%xij(1:1, 1:2) .approxeq.unit_xij)) THEN + obj%domainName = "UNIT" + ELSE IF (ALL(obj%xij(1:1, 1:2) .approxeq.biunit_xij)) THEN + obj%domainName = "BIUNIT" + ELSE + obj%domainName = "GENERAL" + END IF +ELSE + IF (PRESENT(domainName)) THEN + obj%domainName = UpperCase(domainName) + IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN + obj%xij = RefCoord_Line(obj%domainName) + END IF + ELSE + obj%domainName = "BIUNIT" + obj%xij = RefCoord_Line(obj%domainName) + END IF +END IF + +obj%entityCounts = [2, 1, 0, 0] +obj%xiDimension = 1 +obj%order = 1 +obj%nsd = nsd +obj%name = Line2 +ALLOCATE (obj%topology(3)) +obj%topology(1) = ReferenceTopology([1], Point) +obj%topology(2) = ReferenceTopology([2], Point) +obj%topology(3) = ReferenceTopology([1, 2], Line2) +obj%highorderElement => highorderElement_Line +END PROCEDURE Initiate_ref_Line + +!---------------------------------------------------------------------------- +! ReferenceLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Line +CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) +END PROCEDURE Reference_Line + +!---------------------------------------------------------------------------- +! ReferenceLine_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Line_Pointer_1 +ALLOCATE (obj) +CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) +END PROCEDURE Reference_Line_Pointer_1 + +!---------------------------------------------------------------------------- +! LagrangeElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HighorderElement_Line +INTEGER(I4B) :: nns, i +obj%xij = InterpolationPoint_Line( & + & xij=refelem%xij, & + & order=order, & + & ipType=ipType, & + & layout="VEFC") +obj%domainName = refelem%domainName +obj%nsd = refelem%nsd +nns = SIZE(obj%xij, 2) +obj%entityCounts = [nns, 1, 0, 0] +obj%xiDimension = 1 +obj%order = order +obj%name = ElementType("Line"//ToString(nns)) +ALLOCATE (obj%topology(nns + 1)) +DO CONCURRENT(i=1:nns) + obj%topology(i) = ReferenceTopology([i], Point) +END DO +obj%topology(nns + 1) = ReferenceTopology([(i, i=1, nns)], obj%name) +END PROCEDURE HighorderElement_Line + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Line +SELECT CASE (SIZE(xij, 1)) +CASE (1) + Ans = ABS(xij(1, 1) - xij(1, 2)) +CASE (2) + Ans = SQRT((xij(1, 1) - xij(1, 2))**2 & + & + (xij(2, 1) - xij(2, 2))**2) +CASE default + Ans = SQRT((xij(1, 1) - xij(1, 2))**2 & + & + (xij(2, 1) - xij(2, 2))**2 & + & + (xij(3, 1) - xij(3, 2))**2) +END SELECT +END PROCEDURE Measure_Simplex_Line + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Line_quality +ans = 0.0_DFP +END PROCEDURE Line_quality + +!---------------------------------------------------------------------------- +! RefLineCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefLineCoord +TYPE(String) :: astr +astr = UpperCase(refLine) +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans(1, :) = [0.0_DFP, 1.0_DFP] +CASE ("BIUNIT") + ans(1, :) = [-1.0_DFP, 1.0_DFP] +END SELECT +END PROCEDURE RefLineCoord + +!---------------------------------------------------------------------------- +! GetEdgeElemType_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity_Line +IF (PRESENT(nrow)) nrow = 1 +IF (PRESENT(ncol)) ncol = 2 +con(1, 1) = 1 +con(1, 2) = 2 +END PROCEDURE GetEdgeConnectivity_Line + +!---------------------------------------------------------------------------- +! GetFaceElemType_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Line +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 + +!---------------------------------------------------------------------------- +! GetFaceConnectivity_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity_Line +IF (PRESENT(nrow)) nrow = 1 +IF (PRESENT(ncol)) ncol = 2 +con(1, 1) = 1 +con(1, 2) = 2 +END PROCEDURE GetFaceConnectivity_Line + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 new file mode 100644 index 000000000..23d1edaa3 --- /dev/null +++ b/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 @@ -0,0 +1,102 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This submodule contains methods for [[ReferencePoint_]] + +SUBMODULE(ReferencePoint_Method) Methods +USE ReallocateUtility +USE ReferenceElement_Method +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refPoint_Initiate +CALL Reallocate(obj%XiJ, 3, 1) +IF (PRESENT(XiJ)) THEN + obj%XiJ = XiJ +END IF +obj%EntityCounts = [1, 0, 0, 0] +obj%XiDimension = 0 +obj%Order = 0 +obj%NSD = NSD +obj%Name = Point1 +IF (ALLOCATED(obj%Topology)) DEALLOCATE (obj%Topology) +ALLOCATE (obj%Topology(1)) +obj%Topology(1) = ReferenceTopology([1], Point) +obj%highOrderElement => HighOrderElement_Point +END PROCEDURE refPoint_Initiate + +!---------------------------------------------------------------------------- +! ReferencePoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refPoint_Constructor1 +CALL refPoint_Initiate(obj, NSD, XiJ) +END PROCEDURE refPoint_Constructor1 + +!---------------------------------------------------------------------------- +! ReferencePoint_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE refPoint_Constructor_1 +ALLOCATE (obj) +CALL refpoint_Initiate(obj, NSD, XiJ) +END PROCEDURE refPoint_Constructor_1 + +!---------------------------------------------------------------------------- +! LagrangeElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HighOrderElement_Point +CALL Initiate(obj=obj, anotherobj=refelem) +END PROCEDURE HighOrderElement_Point + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Point +ans = 0.0_DFP +END PROCEDURE Measure_Simplex_Point + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Point_Quality +ans = 0.0_DFP +END PROCEDURE Point_Quality + +!---------------------------------------------------------------------------- +! TotalNodesInElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Point +SELECT CASE (elemType) +CASE (Point) + ans = 1 +CASE default + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Point + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 new file mode 100644 index 000000000..281bc250e --- /dev/null +++ b/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 @@ -0,0 +1,392 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This submodule defines methods for [[ReferencePrism_]] + +SUBMODULE(ReferencePrism_Method) Methods +USE ArangeUtility +USE ApproxUtility +USE StringUtility +USE ReferenceElement_Method + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElementName_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementName_Prism +SELECT CASE (elemType) +CASE (Prism6) + ans = "Prism6" + +CASE (Prism15) + ans = "Prism15" + +CASE (Prism18) + ans = "Prism18" + +CASE DEFAULT + ans = "NONE" + +END SELECT +END PROCEDURE ElementName_Prism + +!---------------------------------------------------------------------------- +! FaceTopology_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetTopology_Prism +! TODO: +! ! ALLOCATE (ans(5)) +! ans(1)%nptrs = nptrs([5, 4, 1, 2]) +! ans(2)%nptrs = nptrs([4, 6, 3, 1]) +! ans(3)%nptrs = nptrs([2, 3, 6, 5]) +! ans(4)%nptrs = nptrs([1, 3, 2]) +! ans(5)%nptrs = nptrs([4, 5, 6]) +! ans(:)%xiDimension = 2 +! ans(1:3)%name = Quadrangle4 +! ans(4:5)%name = Triangle3 + +! prism 15 +! ! ALLOCATE (ans(5)) +! ans(1)%nptrs = nptrs([5, 4, 1, 2, 13, 9, 7, 11]) +! ans(2)%nptrs = nptrs([4, 6, 3, 1, 14, 12, 8, 9]) +! ans(3)%nptrs = nptrs([2, 3, 6, 5, 10, 12, 15, 11]) +! ans(4)%nptrs = nptrs([1, 3, 2, 8, 10, 7]) +! ans(5)%nptrs = nptrs([4, 5, 6, 13, 15, 14]) +! ans(:)%xiDimension = 2 +! ans(1:3)%name = Quadrangle8 +! ans(4:5)%name = Triangle6 + +! prism 18 +! ! ALLOCATE (ans(5)) +! ans(1)%nptrs = nptrs([5, 4, 1, 2, 13, 9, 7, 11, 16]) +! ans(2)%nptrs = nptrs([4, 6, 3, 1, 14, 12, 8, 9, 17]) +! ans(3)%nptrs = nptrs([2, 3, 6, 5, 10, 12, 15, 11, 18]) +! ans(4)%nptrs = nptrs([1, 3, 2, 8, 10, 7]) +! ans(5)%nptrs = nptrs([4, 5, 6, 13, 15, 14]) +! ans(:)%xiDimension = 2 +! ans(1:3)%name = Quadrangle9 +! ans(4:5)%name = Triangle6 +END PROCEDURE FacetTopology_Prism + +!---------------------------------------------------------------------------- +! TotalEntities_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalEntities_Prism +ans(2:4) = [9, 5, 1] +ans(1) = TotalNodesInElement_Prism(elemType) +END PROCEDURE TotalEntities_Prism + +!---------------------------------------------------------------------------- +! TotalNodesInElements_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Prism +SELECT CASE (elemType) +CASE (Prism6) + ans = 6 +CASE (Prism15) + ans = 15 +CASE (Prism18) + ans = 18 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Prism + +!---------------------------------------------------------------------------- +! ElementType_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementType_Prism +SELECT CASE (elemName) +CASE ("Prism", "Prism6") + ans = Prism6 +CASE ("Prism15") + ans = Prism15 +CASE ("Prism18") + ans = Prism18 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementType_Prism + +!---------------------------------------------------------------------------- +! ElementOrder_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementOrder_Prism +SELECT CASE (elemType) +CASE (Prism6) + ans = 1 +CASE (Prism15) + ans = 2 +CASE (Prism18) + ans = 2 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementOrder_Prism + +!---------------------------------------------------------------------------- +! FacetElements_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Prism1 +! TODO: +END PROCEDURE FacetElements_Prism1 + +!---------------------------------------------------------------------------- +! FacetElements_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Prism2 +! TODO: +END PROCEDURE FacetElements_Prism2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_Ref_Prism +INTEGER(I4B) :: ii, jj +INTEGER(I4B), PARAMETER :: tNodes = 6, tFaces = 5, tEdges = 9, xidim = 3, & + & max_nodes_face = 4, name = Prism +INTEGER(I4B) :: p1p2(2, tEdges), lloop(max_nodes_face + 2, tFaces), & + & vol(tNodes, 1) +REAL(DFP) :: unit_xij(xidim, tNodes), biunit_xij(xidim, tNodes) + +CALL DEALLOCATE (obj) + +CALL GetEdgeConnectivity_Prism(con=p1p2, opt=1_I4B, order=1_I4B) +CALL GetFaceConnectivity_Prism(con=lloop, opt=1_I4B, order=1_I4B) + +vol(:, 1) = arange(1_I4B, tNodes) + +unit_xij = RefCoord_Prism("UNIT") +biunit_xij = RefCoord_Prism("BIUNIT") + +IF (PRESENT(xij)) THEN + obj%xij = xij(:xidim, :tNodes) + + IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.unit_xij)) THEN + obj%domainName = "UNIT" + ELSE IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.biunit_xij)) THEN + obj%domainName = "BIUNIT" + ELSE + obj%domainName = "GENERAL" + END IF + +ELSE + + IF (PRESENT(domainName)) THEN + obj%domainName = UpperCase(domainName) + IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN + obj%xij = RefCoord_Prism(obj%domainName) + END IF + ELSE + obj%domainName = "UNIT" + obj%xij = RefCoord_Prism(obj%domainName) + END IF + +END IF + +obj%entityCounts = [tNodes, tEdges, tFaces, 1_I4B] +obj%xidimension = xidim +obj%name = name +obj%order = 1_I4B +obj%nsd = nsd + +ALLOCATE (obj%topology(SUM(obj%entityCounts))) +DO ii = 1, obj%entityCounts(1) + obj%topology(ii) = ReferenceTopology([ii], Point) +END DO + +jj = obj%entityCounts(1) +DO ii = 1, obj%entityCounts(2) + obj%topology(jj + ii) = ReferenceTopology(p1p2(:, ii), Line2) +END DO + +jj = jj + obj%entityCounts(2) +DO ii = 1, obj%entityCounts(3) + obj%topology(jj + ii) = ReferenceTopology( & + & lloop(2 + 1:2 + lloop(1, ii), ii), lloop(2, ii)) +END DO + +jj = jj + obj%entityCounts(3) +DO ii = 1, obj%entityCounts(4) + obj%topology(jj + ii) = ReferenceTopology(vol(:, ii), name) +END DO + +obj%highorderElement => highorderElement_Prism +END PROCEDURE Initiate_Ref_Prism + +!---------------------------------------------------------------------------- +! ReferencePrism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Prism +CALL Initiate_Ref_Prism(obj=obj, nsd=NSD, xij=xij, domainName=domainName) +END PROCEDURE Reference_Prism + +!---------------------------------------------------------------------------- +! ReferencePrism_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Prism_Pointer +ALLOCATE (obj) +CALL Initiate_Ref_Prism(obj=obj, nsd=NSD, xij=xij, domainName=domainName) +END PROCEDURE Reference_Prism_Pointer + +!---------------------------------------------------------------------------- +! HighOrderElement_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HighOrderElement_Prism +! TODO: +! FIX: #250 Implement HighOrderElement_Prism +END PROCEDURE HighOrderElement_Prism + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Prism +INTEGER(I4B) :: fm(5, 7), node0(5, 4), order0(5), b, iface + +fm = FacetMatrix(refelem) +DO iface = 1, 5 + order0(iface) = fm(iface, 3) + b = order0(iface) + 3 + node0(iface, 1:order0(iface)) = fm(iface, 4:b) +END DO +CALL POLYHEDRONVOLUME3D(coord=XiJ(1:3, 1:6), & + & order_max=4, face_num=5, & + & node=node0, node_num=6, & + & order=order0, & + & ans=ans) +END PROCEDURE Measure_Simplex_Prism + +!---------------------------------------------------------------------------- +! Prism_Quality +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Prism_Quality +! TODO: +ans = 0.0_DFP +END PROCEDURE Prism_Quality + +!---------------------------------------------------------------------------- +! PolyhedronVolume3D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE PolyhedronVolume3D +INTEGER(I4B) :: iFace +INTEGER(I4B) :: n1 +INTEGER(I4B) :: n2 +INTEGER(I4B) :: n3 +INTEGER(I4B) :: v + +ans = 0.0_DFP +! Triangulate each iFace. +DO iface = 1, face_num + n3 = node(iface, order(iface)) + DO v = 1, order(iface) - 2 + n1 = node(iface, v) + n2 = node(iface, v + 1) + ans = ans & + + coord(1, n1) & + * (coord(2, n2) * coord(3, n3) - coord(2, n3) * coord(3, n2)) & + + coord(1, n2) & + * (coord(2, n3) * coord(3, n1) - coord(2, n1) * coord(3, n3)) & + + coord(1, n3) & + * (coord(2, n1) * coord(3, n2) - coord(2, n2) * coord(3, n1)) + END DO +END DO +ans = ans / 6.0_DFP +END PROCEDURE PolyhedronVolume3D + +!---------------------------------------------------------------------------- +! Refcoord_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefCoord_Prism +ans = 0.0_DFP +!TODO: +!FIX: Implement RefCoord_Prism +!ISSUE: #251 +END PROCEDURE RefCoord_Prism + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity_Prism +con(1:2, 1) = [1, 2] +con(1:2, 2) = [1, 3] +con(1:2, 3) = [1, 4] +con(1:2, 4) = [2, 3] +con(1:2, 5) = [2, 5] +con(1:2, 6) = [3, 6] +con(1:2, 7) = [4, 5] +con(1:2, 8) = [4, 6] +con(1:2, 9) = [5, 6] + +IF (PRESENT(ncol)) ncol = 9 +IF (PRESENT(nrow)) nrow = 2 + +END PROCEDURE GetEdgeConnectivity_Prism + +!---------------------------------------------------------------------------- +! GetFaceConnectivity_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity_Prism +con(1:4, 1) = [1, 3, 2, 0] +con(1:4, 2) = [2, 3, 6, 5] +con(1:4, 3) = [1, 2, 5, 4] +con(1:4, 4) = [1, 4, 6, 3] +con(1:4, 5) = [4, 5, 6, 0] + +IF (PRESENT(ncol)) ncol = 5 +IF (PRESENT(nrow)) nrow = 4 + +END PROCEDURE GetFaceConnectivity_Prism + +!---------------------------------------------------------------------------- +! GetFaceElemType_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Prism +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 SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 new file mode 100644 index 000000000..d2638525f --- /dev/null +++ b/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 @@ -0,0 +1,368 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This submodule contians methods for [[ReferencePyramid_]] + +SUBMODULE(ReferencePyramid_Method) Methods +USE ArangeUtility +USE ApproxUtility +USE StringUtility +USE ReferenceElement_Method +USE ReferencePrism_Method, ONLY: PolyhedronVolume3D + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElementName_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementName_Pyramid +SELECT CASE (elemType) +CASE (Pyramid5) + ans = "Pyramid5" + +CASE (Pyramid13) + ans = "Pyramid13" + +CASE (Pyramid14) + ans = "Pyramid14" + +CASE default + ans = "NONE" +END SELECT +END PROCEDURE ElementName_Pyramid + +!---------------------------------------------------------------------------- +! FaceTopology_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetTopology_Pyramid +! TODO: +! ALLOCATE (ans(5)) +! ans(1)%nptrs = nptrs([1, 2, 5]) +! ans(2)%nptrs = nptrs([2, 3, 5]) +! ans(3)%nptrs = nptrs([3, 4, 5]) +! ans(4)%nptrs = nptrs([1, 5, 4]) +! ans(5)%nptrs = nptrs([4, 3, 2, 1]) +! ans(:)%xiDimension = 2 +! ans(1:4)%name = Triangle3 +! ans(5)%name = Quadrangle4 +! Order=2 elements + +! CASE (Pyramid13) +! ! ALLOCATE (ans(5)) +! ans(1)%nptrs = nptrs([1, 2, 5, 6, 10, 8]) +! ans(2)%nptrs = nptrs([2, 3, 5, 9, 12, 10]) +! ans(3)%nptrs = nptrs([3, 4, 5, 11, 13, 12]) +! ans(4)%nptrs = nptrs([1, 5, 4, 8, 13, 7]) +! ans(5)%nptrs = nptrs([4, 3, 2, 1, 11, 9, 6, 7]) +! ans(:)%xiDimension = 2 +! ans(1:4)%name = Triangle6 +! ans(5)%name = Quadrangle8 +! +! CASE (Pyramid14) +! ! ALLOCATE (ans(5)) +! ans(1)%nptrs = nptrs([1, 2, 5, 6, 10, 8]) +! ans(2)%nptrs = nptrs([2, 3, 5, 9, 12, 10]) +! ans(3)%nptrs = nptrs([3, 4, 5, 11, 13, 12]) +! ans(4)%nptrs = nptrs([1, 5, 4, 8, 13, 7]) +! ans(5)%nptrs = nptrs([4, 3, 2, 1, 11, 9, 6, 7, 13]) +! ans(:)%xiDimension = 2 +! ans(1:4)%name = Triangle6 +! ans(5)%name = Quadrangle9 +END PROCEDURE FacetTopology_Pyramid + +!---------------------------------------------------------------------------- +! TotalEntities_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalEntities_Pyramid +ans(2:4) = [9, 5, 1] +ans(1) = TotalNodesInElement_Pyramid(elemType) +END PROCEDURE TotalEntities_Pyramid + +!---------------------------------------------------------------------------- +! TotalNodesInElements_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Pyramid +SELECT CASE (elemType) +CASE (Pyramid5) + ans = 5 + +CASE (Pyramid13) + ans = 13 + +CASE (Pyramid14) + ans = 14 + +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Pyramid + +!---------------------------------------------------------------------------- +! ElementType_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementType_Pyramid +SELECT CASE (elemName) +CASE ("Pyramid", "Pyramid5") + ans = Pyramid5 +CASE ("Pyramid13") + ans = Pyramid13 +CASE ("Pyramid14") + ans = Pyramid14 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementType_Pyramid + +!---------------------------------------------------------------------------- +! ElementOrder_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementOrder_Pyramid +SELECT CASE (elemType) +CASE (Pyramid5) + ans = 1 + +CASE (Pyramid13) + ans = 2 + +CASE (Pyramid14) + ans = 2 + +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementOrder_Pyramid + +!---------------------------------------------------------------------------- +! FacetElements_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Pyramid1 +! TODO: +END PROCEDURE FacetElements_Pyramid1 + +!---------------------------------------------------------------------------- +! FacetElements_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Pyramid2 +! TODO: +END PROCEDURE FacetElements_Pyramid2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_Ref_Pyramid +INTEGER(I4B) :: ii, jj +INTEGER(I4B), PARAMETER :: tNodes = 5, tFaces = 5, tEdges = 8, xidim = 3, & + & max_nodes_face = 4, name = Pyramid +INTEGER(I4B) :: p1p2(2, tEdges), lloop(max_nodes_face + 2, tFaces), & + & vol(tNodes, 1) +REAL(DFP) :: unit_xij(xidim, tNodes), biunit_xij(xidim, tNodes) + +CALL DEALLOCATE (obj) + +CALL GetEdgeConnectivity_Pyramid(con=p1p2, opt=1_I4B, order=1_I4B) +CALL GetFaceConnectivity_Pyramid(con=lloop, opt=1_I4B, order=1_I4B) + +vol(:, 1) = arange(1_I4B, tNodes) + +unit_xij = RefCoord_Pyramid("UNIT") +biunit_xij = RefCoord_Pyramid("BIUNIT") + +IF (PRESENT(xij)) THEN + + obj%xij = xij(:xidim, :tNodes) + + IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.unit_xij)) THEN + obj%domainName = "UNIT" + ELSE IF (ALL(obj%xij(:xidim, :tNodes) .approxeq.biunit_xij)) THEN + obj%domainName = "BIUNIT" + ELSE + obj%domainName = "GENERAL" + END IF + +ELSE + + IF (PRESENT(domainName)) THEN + obj%domainName = UpperCase(domainName) + IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN + obj%xij = RefCoord_Pyramid(obj%domainName) + END IF + ELSE + obj%domainName = "UNIT" + obj%xij = RefCoord_Pyramid(obj%domainName) + END IF + +END IF + +obj%entityCounts = [tNodes, tEdges, tFaces, 1_I4B] +obj%xidimension = xidim +obj%name = name +obj%order = 1_I4B +obj%nsd = nsd + +ALLOCATE (obj%topology(SUM(obj%entityCounts))) +DO ii = 1, obj%entityCounts(1) + obj%topology(ii) = ReferenceTopology([ii], Point) +END DO + +jj = obj%entityCounts(1) +DO ii = 1, obj%entityCounts(2) + obj%topology(jj + ii) = ReferenceTopology(p1p2(:, ii), Line2) +END DO + +jj = jj + obj%entityCounts(2) +DO ii = 1, obj%entityCounts(3) + obj%topology(jj + ii) = ReferenceTopology( & + & lloop(2 + 1:2 + lloop(1, ii), ii), lloop(2, ii)) +END DO + +jj = jj + obj%entityCounts(3) +DO ii = 1, obj%entityCounts(4) + obj%topology(jj + ii) = ReferenceTopology(vol(:, ii), name) +END DO + +obj%highorderElement => highorderElement_Pyramid +END PROCEDURE Initiate_Ref_Pyramid + +!---------------------------------------------------------------------------- +! ReferencePyramid +!---------------------------------------------------------------------------- +MODULE PROCEDURE Reference_Pyramid +CALL Initiate_Ref_Pyramid(obj=obj, nsd=NSD, xij=xij, domainName=domainName) +END PROCEDURE Reference_Pyramid + +!---------------------------------------------------------------------------- +! ReferencePyramid +!---------------------------------------------------------------------------- +MODULE PROCEDURE Reference_Pyramid_Pointer +ALLOCATE (obj) +CALL Initiate_Ref_Pyramid(obj=obj, nsd=NSD, xij=xij, domainName=domainName) +END PROCEDURE Reference_Pyramid_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HighOrderElement_Pyramid +! FIX: +!TODO: +END PROCEDURE HighOrderElement_Pyramid + +!----------------------------------------------------------------------------- +! MeasureSimplex +!----------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Pyramid +INTEGER(I4B) :: FM(5, 7), Node0(5, 4), Order0(5), iFace, b + +FM = FacetMatrix(RefElem) + +DO iFace = 1, 5 + Order0(iFace) = FM(iFace, 3) + b = Order0(iFace) + 3 + Node0(iFace, 1:Order0(iFace)) = FM(iFace, 4:b) +END DO + +CALL PolyhedronVolume3D(coord=XiJ(1:3, 1:5), & + & order_max=4, face_num=5, & + & node=Node0, node_num=5, & + & order=Order0, & + & ans=ans) + +END PROCEDURE Measure_Simplex_Pyramid + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Pyramid_Quality +ans = 0.0_DFP +!FIX: Implement Pyramid_Quality +!TODO: +END PROCEDURE Pyramid_Quality + +!---------------------------------------------------------------------------- +! Refcoord_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefCoord_Pyramid +!FIX: Implement RefCoord +ans = 0.0_DFP +!TODO: +END PROCEDURE RefCoord_Pyramid + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity_Pyramid +con(1:2, 1) = [1, 2] +con(1:2, 2) = [1, 4] +con(1:2, 3) = [1, 5] +con(1:2, 4) = [2, 3] +con(1:2, 5) = [2, 5] +con(1:2, 6) = [3, 4] +con(1:2, 7) = [3, 5] +con(1:2, 8) = [4, 5] + +IF (PRESENT(nrow)) nrow = 2 +IF (PRESENT(ncol)) ncol = 8 +END PROCEDURE GetEdgeConnectivity_Pyramid + +!---------------------------------------------------------------------------- +! GetFaceConnectivity_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity_Pyramid +con(1:4, 1) = [1, 4, 3, 2] +con(1:4, 2) = [2, 3, 5, 0] +con(1:4, 3) = [3, 4, 5, 0] +con(1:4, 4) = [1, 5, 4, 0] +con(1:4, 5) = [1, 2, 5, 0] +IF (PRESENT(nrow)) nrow = 4 +IF (PRESENT(ncol)) ncol = 5 +END PROCEDURE GetFaceConnectivity_Pyramid + +!---------------------------------------------------------------------------- +! GetFaceElemType_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Pyramid + +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 SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 new file mode 100644 index 000000000..c73f7bbf7 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 @@ -0,0 +1,660 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This submodule contains method for [[ReferenceQuadrangle_]] + +SUBMODULE(ReferenceQuadrangle_Method) Methods +USE ReferenceElement_Method +USE LineInterpolationUtility, ONLY: InterpolationPoint_Line +USE ReferenceLine_Method, ONLY: ElementOrder_Line, LineName + +USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle, & + LagrangeDOF_Quadrangle +USE ReferenceTriangle_Method, ONLY: TRIANGLEAREA2D +USE ReferenceLine_Method, ONLY: Linename, ElementType_Line + +USE ApproxUtility +USE AppendUtility +USE StringUtility +USE ArangeUtility +USE InputUtility +USE SortUtility +USE ReallocateUtility +USE Display_Method +USE MiscUtility, ONLY: Int2Str + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElementName_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementName_Quadrangle +SELECT CASE (elemType) +CASE (Quadrangle4) + ans = "Quadrangle4" +CASE (Quadrangle8) + ans = "Quadrangle8" +CASE (Quadrangle9) + ans = "Quadrangle9" +CASE (Quadrangle16) + ans = "Quadrangle16" +CASE default + ans = "" +END SELECT +END PROCEDURE ElementName_Quadrangle + +!---------------------------------------------------------------------------- +! FacetTopology_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetTopology_Quadrangle +INTEGER(I4B) :: order, ii, lineType +INTEGER(I4B), ALLOCATABLE :: con(:, :) + +order = ElementOrder_Quadrangle(elemType) +CALL Reallocate(con, order + 1, 4) +CALL GetEdgeConnectivity_Quadrangle(con=con, & + & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) +lineType = ElementType_Line("Line"//Int2Str(order + 1)) + +DO ii = 1, 4 + ans(ii)%nptrs = nptrs(con(:, ii)) + ans(ii)%xiDimension = 1 + ans(ii)%name = lineType +END DO + +IF (ALLOCATED(con)) DEALLOCATE (con) + +END PROCEDURE FacetTopology_Quadrangle + +!---------------------------------------------------------------------------- +! TotalEntities_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalEntities_Quadrangle +ans(2:4) = [4, 1, 0] +ans(1) = TotalNodesInElement_Quadrangle(elemType) +END PROCEDURE TotalEntities_Quadrangle + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Quadrangle +SELECT CASE (ElemType) +CASE (Quadrangle4) + ans = 4 +CASE (Quadrangle8) + ans = 8 +CASE (Quadrangle9) + ans = 9 +CASE (Quadrangle16) + ans = 16 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Quadrangle + +!---------------------------------------------------------------------------- +! ElementOrder_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementOrder_Quadrangle +SELECT CASE (ElemType) +CASE (Quadrangle4) + ans = 1 +CASE (Quadrangle8) + ans = 2 +CASE (Quadrangle9) + ans = 2 +CASE (Quadrangle16) + ans = 3 +END SELECT +END PROCEDURE ElementOrder_Quadrangle + +!---------------------------------------------------------------------------- +! ElementType_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementType_Quadrangle +SELECT CASE (elemName) +CASE ("Quadrangle4", "Quadrangle") + ans = Quadrangle4 +CASE ("Quadrangle8") + ans = Quadrangle8 +CASE ("Quadrangle9") + ans = Quadrangle9 +CASE ("Quadrangle16") + ans = Quadrangle16 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementType_Quadrangle + +!---------------------------------------------------------------------------- +! FacetElements_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Quadrangle1 +INTEGER(I4B) :: ii, istart, tsize, jj +TYPE(Referencetopology_) :: topo + +istart = refelem%entityCounts(1) + +ans(1)%xij = InterpolationPoint_Line( & + & order=refelem%order, & + & ipType=refelem%interpolationPointType, & + & layout="VEFC") + +ans(1)%interpolationPointType = refelem%interpolationPointType +ans(1)%nsd = refelem%nsd +DO ii = 2, 4 + ans(ii)%xij = ans(1)%xij + ans(ii)%interpolationPointType = ans(1)%interpolationPointType + ans(ii)%nsd = ans(1)%nsd +END DO + +DO ii = 1, 4 + topo = refelem%topology(istart + ii) + tsize = SIZE(topo%nptrs) + ans(ii)%xiDimension = topo%xiDimension + ans(ii)%name = topo%name + ans(ii)%order = ElementOrder_Line(elemType=topo%name) + ans(ii)%entityCounts = [tsize, 1, 0, 0] + + ALLOCATE (ans(ii)%topology(tsize + 1)) + + DO jj = 1, tsize + ans(ii)%topology(jj) = Referencetopology( & + & nptrs=topo%nptrs(jj:jj), name=Point) + END DO + + ans(ii)%topology(tsize + 1) = Referencetopology( & + & nptrs=topo%nptrs, name=topo%name) +END DO + +CALL DEALLOCATE (topo) + +END PROCEDURE FacetElements_Quadrangle1 + +!---------------------------------------------------------------------------- +! FacetElements_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Quadrangle2 +INTEGER(I4B) :: ii, jj, order +INTEGER(I4B), ALLOCATABLE :: edgeCon(:, :) + +order = ElementOrder_Quadrangle(elemType) +CALL Reallocate(edgeCon, order + 1, 4) +CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, & + & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) +!! The edges are accordign to gmsh +!! [1,2], [2,3], [3,4], [4,1] + +DO ii = 1, 4 + + 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)%nsd = nsd + ans(ii)%entityCounts = [order + 1, 1, 0, 0] + ALLOCATE (ans(ii)%topology(order + 2)) + + DO jj = 1, order + 1 + ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), & + & name=Point) + END DO + + ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), & + & name=ans(ii)%name) + +END DO + +IF (ALLOCATED(edgeCon)) DEALLOCATE (edgeCon) + +END PROCEDURE FacetElements_Quadrangle2 + +!---------------------------------------------------------------------------- +! Quadranglename1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadranglename1 +SELECT CASE (order) +CASE (1) + ans = Quadrangle4 +CASE (2) + ans = Quadrangle9 +CASE (3) + ans = Quadrangle16 +CASE (4:) + ans = Quadrangle16 + order - 3_I4B +END SELECT +END PROCEDURE Quadranglename1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_ref_Quadrangle +REAL(DFP) :: unit_xij(2, 4), biunit_xij(2, 4) +CALL DEALLOCATE (obj) + +unit_xij = RefCoord_Quadrangle("UNIT") +biunit_xij = RefCoord_Quadrangle("BIUNIT") + +IF (PRESENT(xij)) THEN + obj%xij = xij(1:2, 1:4) + IF (ALL(obj%xij(1:2, 1:4) .approxeq.unit_xij)) THEN + obj%domainName = "UNIT" + ELSE IF (ALL(obj%xij(1:2, 1:4) .approxeq.biunit_xij)) THEN + obj%domainName = "BIUNIT" + ELSE + obj%domainName = "GENERAL" + END IF + +ELSE + + IF (PRESENT(domainName)) THEN + obj%domainName = UpperCase(domainName) + IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN + obj%xij = RefCoord_Quadrangle(obj%domainName) + END IF + ELSE + obj%domainName = "BIUNIT" + obj%xij = RefCoord_Quadrangle(obj%domainName) + END IF + +END IF + +obj%entityCounts = [4, 4, 1, 0] +obj%xidimension = 2 +obj%name = Quadrangle4 +obj%order = 1 +obj%NSD = NSD +ALLOCATE (obj%topology(9)) +obj%topology(1) = ReferenceTopology([1], Point) +obj%topology(2) = ReferenceTopology([2], Point) +obj%topology(3) = ReferenceTopology([3], Point) +obj%topology(4) = ReferenceTopology([4], Point) +obj%topology(5) = ReferenceTopology([1, 2], Line2) +obj%topology(6) = ReferenceTopology([2, 3], Line2) +obj%topology(7) = ReferenceTopology([3, 4], Line2) +obj%topology(8) = ReferenceTopology([4, 1], Line2) +obj%topology(9) = ReferenceTopology([1, 2, 3, 4], Quadrangle4) +obj%highorderElement => highorderElement_Quadrangle +END PROCEDURE Initiate_ref_Quadrangle + +!---------------------------------------------------------------------------- +! ReferenceQuadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE reference_Quadrangle +CALL initiate_ref_quadrangle(obj=obj, nsd=NSD, xij=xij, domainName=domainName) +END PROCEDURE reference_Quadrangle + +!---------------------------------------------------------------------------- +! ReferenceQuadrangle_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE reference_Quadrangle_Pointer +ALLOCATE (obj) +CALL initiate_ref_quadrangle(obj=obj, nsd=NSD, xij=xij, domainName=domainName) +END PROCEDURE reference_Quadrangle_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE highorderElement_Quadrangle +INTEGER(I4B) :: NNS, I +INTEGER(I4B), ALLOCATABLE :: aintvec(:) + +CALL DEALLOCATE (obj) +SELECT CASE (order) +CASE (1) + CALL Initiate(obj=obj, Anotherobj=refelem) +CASE DEFAULT + obj%xij = InterpolationPoint_Quadrangle( & + & xij=refelem%xij, & + & order=order, & + & ipType=ipType, & + & layout="VEFC") + obj%domainName = refelem%domainName + NNS = LagrangeDOF_Quadrangle(order=order) + obj%entityCounts = [NNS, 4, 1, 0] + obj%xidimension = 2 + obj%name = QuadrangleName(order=order) + obj%order = order + obj%NSD = refelem%NSD + ALLOCATE (obj%topology(SUM(obj%entityCounts))) + DO I = 1, NNS + obj%topology(I) = ReferenceTopology([I], Point) + END DO + aintvec = [1, 2] .append.arange(5_I4B, 3_I4B + order) + obj%topology(NNS + 1) = ReferenceTopology(aintvec, Linename(order=order)) + + aintvec = [2, 3] .append.arange( & + & 3_I4B + order + 1, & + & 3_I4B + order + order - 1_I4B) + obj%topology(NNS + 2) = ReferenceTopology(aintvec, Linename(order=order)) + + aintvec = [3, 4] .append.arange(& + & 2_I4B + 2_I4B * order + 1, & + & 2_I4B + 2_I4B * order + order - 1_I4B) + obj%topology(NNS + 3) = ReferenceTopology(aintvec, Linename(order=order)) + + aintvec = [4, 1] .append.arange( & + & 1_I4B + 3_I4B * order + 1, & + & 1_I4B + 3_I4B * order + order - 1_I4B) + obj%topology(NNS + 4) = ReferenceTopology(aintvec, Linename(order=order)) + + obj%topology(NNS + 5) = ReferenceTopology( & + & arange(1_I4B, NNS, 1_I4B), obj%name) + obj%highOrderElement => refelem%highOrderElement +END SELECT +END PROCEDURE highorderElement_Quadrangle + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Quadrangle +IF (refelem%nsd .EQ. 2) THEN + CALL QuadArea2D(xij(1:2, 1:4), Ans) +ELSE + CALL QuadArea3D(xij(1:3, 1:4), Ans) +END IF +END PROCEDURE Measure_Simplex_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrangle_Quality +ans = 0.0_DFP +END PROCEDURE Quadrangle_Quality + +!---------------------------------------------------------------------------- +! QuadArea3D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadArea3D +REAL(DFP) :: p(3, 4) +! Define a parallelogram by averaging consecutive vertices. +p(1:3, 1:3) = (q(1:3, 1:3) + q(1:3, 2:4)) / 2.0_DFP +p(1:3, 4) = (q(1:3, 4) + q(1:3, 1)) / 2.0_DFP +! Compute the area. +CALL PARALLELOGRAMAREA3D(p, ans) +! The quadrilateral's area is twice that of the parallelogram. +ans = 2.0_DFP * ans +END PROCEDURE QuadArea3D + +!---------------------------------------------------------------------------- +! QuadArea2D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadArea2D +INTEGER(I4B), PARAMETER :: dim_num = 2 +REAL(DFP) :: area_triangle +REAL(DFP) :: t(dim_num, 3) +ans = 0.0_DFP +t(1:dim_num, 1:3) = RESHAPE( & + & [q(1:2, 1), q(1:2, 2), q(1:2, 3)], & + & [dim_num, 3] & + & ) +CALL TRIANGLEAREA2D(t, area_triangle) +ans = ans + area_triangle +t(1:dim_num, 1:3) = RESHAPE( & + & [q(1:2, 3), q(1:2, 4), q(1:2, 1)], & + & [dim_num, 3]) +CALL TRIANGLEAREA2D(t, area_triangle) +ans = ans + area_triangle +END PROCEDURE QuadArea2D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION R8MATDET4D(a) + REAL(DFP), INTENT(IN) :: a(4, 4) + REAL(DFP) :: R8MATDET4D + R8MATDET4D = & + a(1, 1) * ( & + a(2, 2) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & + - a(2, 3) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & + + a(2, 4) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2))) & + - a(1, 2) * ( & + a(2, 1) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & + - a(2, 3) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & + + a(2, 4) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1))) & + + a(1, 3) * ( & + a(2, 1) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & + - a(2, 2) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & + + a(2, 4) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) & + - a(1, 4) * ( & + a(2, 1) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2)) & + - a(2, 2) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1)) & + + a(2, 3) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) +END FUNCTION R8MATDET4D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-17 +! summary: Computes the area of a parallelogram in 3D +! +!# Introduction +! +! A parallelogram is a polygon having four sides, with the property +! that each pair of opposite sides is paralell. +! A parallelogram in 3D must have the property that it is "really" +! a 2D object, that is, that the four vertices that define it lie +! in some plane. +! Given the first three vertices of the parallelogram (in 2D or 3D), +! P1, P2, and P3, the fourth vertex must satisfy +! P4 = P1 + ( P3 - P2 ) +! This routine uses the fact that the norm of the cross product +! of two vectors is the area of the parallelogram they form: +! Area = ( P3 - P2 ) x ( P1 - P2 ). +! +! P4<-----P3 +! / / +! / / +! P1----->P2 +! + +PURE SUBROUTINE PARALLELOGRAMAREA3D(p, ans) + REAL(DFP), INTENT(IN) :: p(3, 4) + REAL(DFP), INTENT(OUT) :: ans + REAL(DFP) :: cross(3) + ! Compute the cross product vector. + cross(1) = (p(2, 2) - p(2, 1)) * (p(3, 3) - p(3, 1)) & + & - (p(3, 2) - p(3, 1)) * (p(2, 3) - p(2, 1)) + cross(2) = (p(3, 2) - p(3, 1)) * (p(1, 3) - p(1, 1)) & + & - (p(1, 2) - p(1, 1)) * (p(3, 3) - p(3, 1)) + cross(3) = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & + & - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) + ans = SQRT(SUM(cross(1:3)**2)) +END SUBROUTINE PARALLELOGRAMAREA3D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-17 +! summary: Computes the area of a parallelogram in 2D +! +!# Introduction +! +! A parallelogram is a polygon having four sides, with the property +! that each pair of opposite sides is paralell. +! Given the first three vertices of the parallelogram, +! P1, P2, and P3, the fourth vertex must satisfy +! +! P4 = P1 + ( P3 - P2 ) +! +! This routine uses the fact that the norm of the cross product +! of two vectors is the area of the parallelogram they form: +! +! Area = ( P3 - P2 ) x ( P1 - P2 ). +! +! P4<-----P3 +! / / +! / / +! P1----->P2 + +PURE SUBROUTINE PARALLELOGRAMAREA2D(p, ans) + REAL(DFP), INTENT(IN) :: p(2, 4) + REAL(DFP), INTENT(OUT) :: ans + ans = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & + & - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) +END SUBROUTINE PARALLELOGRAMAREA2D + +!---------------------------------------------------------------------------- +! RefQuadrangleCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefQuadrangleCoord +CHARACTER(:), ALLOCATABLE :: astr +astr = UpperCase(refQuadrangle) +SELECT CASE (astr) +CASE ("UNIT") + ans(1, :) = [0.0_DFP, 1.0_DFP, 1.0_DFP, 0.0_DFP] + ans(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP, 1.0_DFP] +CASE ("BIUNIT") + ans(1, :) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, -1.0_DFP] + ans(2, :) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP] +END SELECT +astr = "" +END PROCEDURE RefQuadrangleCoord + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity_Quadrangle +INTEGER(I4B) :: opt0, order0, ii, jj, iface + +opt0 = Input(default=1_I4B, option=opt) +order0 = Input(default=1_I4B, option=order) + +IF (PRESENT(ncol)) ncol = 4 +IF (PRESENT(nrow)) nrow = 1 + order0 + +SELECT CASE (opt0) +CASE (1_I4B) + con(1:2, 1) = [1, 2] + con(1:2, 2) = [4, 3] + con(1:2, 3) = [1, 4] + con(1:2, 4) = [2, 3] +CASE (2_I4B) + !! For Lagrangian polynomial + con(1:2, 1) = [1, 2] + con(1:2, 2) = [2, 3] + con(1:2, 3) = [3, 4] + con(1:2, 4) = [4, 1] +END SELECT + +jj = 4 +DO iface = 1, 4 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + END DO + jj = jj + order0 - 1 +END DO + +END PROCEDURE GetEdgeConnectivity_Quadrangle + +!---------------------------------------------------------------------------- +! GetFaceConnectivity_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity_Quadrangle +CALL GetEdgeConnectivity_Quadrangle(con=con, opt=2_I4B, order=order, & + nrow=nrow, ncol=ncol) +END PROCEDURE GetFaceConnectivity_Quadrangle + +!---------------------------------------------------------------------------- +! FaceShapeMetaData_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FaceShapeMetaData_Quadrangle +INTEGER(I4B) :: a(4), localFaces0(4) + +a(1) = MINLOC(face, 1) +a(2) = HelpFaceData_Quadrangle(1, a(1)) !b +a(3) = HelpFaceData_Quadrangle(2, a(1)) !c +a(4) = HelpFaceData_Quadrangle(3, a(1)) !d + +localFaces0(1:4) = face(a) +IF (PRESENT(localFaces)) THEN + localFaces(1:4) = localFaces0(1:4) +END IF + +sorted_face(1) = localFaces0(1) +sorted_face(3) = localFaces0(3) + +IF (localFaces0(2) .LT. localFaces0(4)) THEN + sorted_face(2) = localFaces0(2) + sorted_face(4) = localFaces0(4) + + IF (PRESENT(faceOrient)) THEN + faceOrient(3) = 1_INT8 + faceOrient(1) = SIGN(1, localFaces0(2) - localFaces0(1)) + faceOrient(2) = SIGN(1, localFaces0(4) - localFaces0(1)) + END IF + +ELSE + sorted_face(2) = localFaces0(4) + sorted_face(4) = localFaces0(2) + + IF (PRESENT(faceOrient)) THEN + faceOrient(3) = -1_INT8 + faceOrient(1) = SIGN(1, localFaces0(4) - localFaces0(1)) + faceOrient(2) = SIGN(1, localFaces0(2) - localFaces0(1)) + END IF + +END IF + +END PROCEDURE FaceShapeMetaData_Quadrangle + +!---------------------------------------------------------------------------- +! GetFaceElemType_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Quadrangle +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 SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 new file mode 100644 index 000000000..1e84e2ad5 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 @@ -0,0 +1,608 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This submodule contains methods for [[ReferenceTetrahedron_]] + +SUBMODULE(ReferenceTetrahedron_Method) Methods +USE ReferenceElement_Method +USE ApproxUtility +USE InvUtility +USE InputUtility +USE StringUtility +USE ArangeUtility +USE Display_Method +USE ReallocateUtility +USE MiscUtility, ONLY: Int2STR + +USE ReferenceLine_Method, ONLY: ElementType_Line + +USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle + +USE ReferenceTriangle_Method, ONLY: ElementOrder_Triangle, & + & TotalEntities_Triangle, FacetTopology_Triangle + +USE TetrahedronInterpolationUtility, ONLY: LagrangeDOF_Tetrahedron, & + & InterpolationPoint_Tetrahedron + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElementName_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementName_Tetrahedron + +SELECT CASE (elemType) +CASE (Tetrahedron4) + ans = "Tetrahedron4" + +CASE (Tetrahedron10) + ans = "Tetrahedron10" + +CASE (Tetrahedron20) + ans = "Tetrahedron20" + +CASE (Tetrahedron35) + ans = "Tetrahedron35" + +CASE (Tetrahedron56) + ans = "Tetrahedron56" + +CASE DEFAULT + ans = "NONE" + +END SELECT + +END PROCEDURE ElementName_Tetrahedron + +!---------------------------------------------------------------------------- +! FacetTopology_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetTopology_Tetrahedron +INTEGER(I4B) :: ii, faceElemType(4), tFaceNodes(4) +INTEGER(I4B), ALLOCATABLE :: con(:, :) + +CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & + & elemType=elemType, tFaceNodes=tFaceNodes) + +CALL Reallocate(con, tFaceNodes(1), 4) + +ii = ElementOrder_Tetrahedron(elemType=elemType) +CALL GetFaceConnectivity_Tetrahedron(con=con, order=ii) + +DO ii = 1, 4 + ans(ii)%nptrs = nptrs(con(:, ii)) + ans(ii)%xiDimension = 2 + ans(ii)%name = faceElemType(ii) +END DO + +IF (ALLOCATED(con)) DEALLOCATE (con) + +END PROCEDURE FacetTopology_Tetrahedron + +!---------------------------------------------------------------------------- +! TotalEntities_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalEntities_Tetrahedron +ans(2:4) = [6, 4, 1] +ans(1) = TotalNodesInElement_Tetrahedron(elemType) +END PROCEDURE TotalEntities_Tetrahedron + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Tetrahedron +SELECT CASE (elemType) +CASE (Tetrahedron4) + ans = 4 +CASE (Tetrahedron10) + ans = 10 +CASE (Tetrahedron20) + ans = 20 +CASE (Tetrahedron35) + ans = 35 +CASE (Tetrahedron56) + ans = 56 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Tetrahedron + +!---------------------------------------------------------------------------- +! ElementOrder_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementOrder_Tetrahedron +SELECT CASE (ElemType) +CASE (Tetrahedron4) + ans = 1 +CASE (Tetrahedron10) + ans = 2 +CASE (Tetrahedron20) + ans = 3 +CASE (Tetrahedron35) + ans = 4 +CASE (Tetrahedron56) + ans = 5 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementOrder_Tetrahedron + +!---------------------------------------------------------------------------- +! ElementType_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementType_Tetrahedron +SELECT CASE (elemName) +CASE ("Tetrahedron4", "Tetrahedron") + ans = Tetrahedron4 +CASE ("Tetrahedron10") + ans = Tetrahedron10 +CASE ("Tetrahedron20") + ans = Tetrahedron20 +CASE ("Tetrahedron35") + ans = Tetrahedron35 +CASE ("Tetrahedron56") + ans = Tetrahedron56 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementType_Tetrahedron + +!---------------------------------------------------------------------------- +! FacetElements_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Tetrahedron1 +INTEGER(I4B) :: ii, istart, tsize, jj +TYPE(ReferenceTopology_) :: topo + +istart = refelem%entityCounts(1) + refelem%entityCounts(2) +! tPoints + tEdges + +ii = 1 +ans(ii)%nsd = refelem%nsd +ans(ii)%interpolationPointType = refelem%interpolationPointType +ans(ii)%xij = InterpolationPoint_Triangle( & + & order=refelem%order, & + & ipType=refelem%interpolationPointType, & + & layout="VEFC") + +DO ii = 2, 4 + ans(ii)%nsd = ans(1)%nsd + ans(ii)%interpolationPointType = ans(1)%interpolationPointType + ans(ii)%xij = ans(1)%xij +END DO + +DO ii = 1, 4 + + topo = refelem%topology(istart + ii) + ans(ii)%xidimension = topo%xidimension + ans(ii)%name = topo%name + + ans(ii)%order = ElementOrder_Triangle(topo%name) + ans(ii)%entityCounts = TotalEntities_Triangle(topo%name) + + tsize = SUM(ans(ii)%entityCounts) + ! ALLOCATE (ans(ii)%topology(tsize)) + CALL RefTopoReallocate(ans(ii)%topology, tsize) + + ! points + DO jj = 1, ans(ii)%entityCounts(1) + ans(ii)%topology(jj) = ReferenceTopology(nptrs=topo%nptrs(jj:jj), & + & name=Point) + END DO + + ! lines + jj = ans(ii)%entityCounts(1) + CALL FacetTopology_Triangle(elemType=topo%name, & + & nptrs=topo%nptrs, ans=ans(ii)%topology(jj + 1:)) + + ! surface + tsize = jj + ans(ii)%entityCounts(2) + ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=topo%nptrs, & + & name=topo%name) + +END DO + +CALL DEALLOCATE (topo) + +END PROCEDURE FacetElements_Tetrahedron1 + +!---------------------------------------------------------------------------- +! FacetElements_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Tetrahedron2 +INTEGER(I4B) :: ii, jj, order, entityCounts(4), tsize +INTEGER(I4B), ALLOCATABLE :: edgeCon(:, :), faceCon(:, :) +INTEGER(I4B) :: faceElemType(4), tFaceNodes(4) + +CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & + & tFaceNodes=tFaceNodes, elemType=elemType) + +entityCounts = TotalEntities_Tetrahedron(elemType) +order = ElementOrder_Tetrahedron(elemType) + +CALL Reallocate(edgeCon, order + 1, entityCounts(2)) +CALL Reallocate(faceCon, tFaceNodes(1), entityCounts(3)) + +CALL GetEdgeConnectivity_Tetrahedron(con=edgeCon, order=order) +CALL GetFaceConnectivity_Tetrahedron(con=faceCon, order=order) + +DO ii = 1, entityCounts(3) + + ans(ii)%xiDimension = 2 + ans(ii)%order = order + ans(ii)%name = faceElemType(ii) + ans(ii)%interpolationPointType = Equidistance + + ans(ii)%xij = InterpolationPoint_Triangle( & + & order=ans(ii)%order, & + & ipType=ans(ii)%interpolationPointType, & + & layout="VEFC") + + ans(ii)%nsd = nsd + ans(ii)%entityCounts = TotalEntities_Triangle(ans(ii)%name) + + tsize = SUM(ans(ii)%entityCounts) + ! ALLOCATE (ans(ii)%topology(tsize)) + CALL RefTopoReallocate(ans(ii)%topology, tsize) + + ! points + DO jj = 1, ans(ii)%entityCounts(1) + ans(ii)%topology(jj) = Referencetopology(nptrs=faceCon(jj:jj, ii), & + & name=Point) + END DO + + ! lines + jj = ans(ii)%entityCounts(1) + CALL FacetTopology_Triangle(elemType=ans(ii)%name, & + & nptrs=faceCon(:, ii), ans=ans(ii)%topology(jj + 1:)) + + ! surface + tsize = jj + ans(ii)%entityCounts(2) + ans(ii)%topology(tsize + 1) = ReferenceTopology(nptrs=faceCon(:, ii), & + & name=ans(ii)%name) + +END DO + +IF (ALLOCATED(edgeCon)) DEALLOCATE (edgeCon) +IF (ALLOCATED(faceCon)) DEALLOCATE (faceCon) +END PROCEDURE FacetElements_Tetrahedron2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate_Ref_Tetrahedron +INTEGER(I4B), PARAMETER :: tNodes = 4, tFaces = 4, tEdges = 6 +INTEGER(I4B) :: ii, jj, p1p2(2, tEdges), lloop(3, tFaces) +REAL(DFP) :: unit_xij(nsd, tNodes), biunit_xij(nsd, tNodes) + +CALL DEALLOCATE (obj) + +unit_xij = RefCoord_Tetrahedron("UNIT") +biunit_xij = RefCoord_Tetrahedron("BIUNIT") + +IF (PRESENT(xij)) THEN + obj%xij = xij(1:3, 1:4) + + IF (ALL(obj%xij(1:3, 1:4) .approxeq.unit_xij)) THEN + obj%domainName = "UNIT" + ELSE IF (ALL(obj%xij(1:3, 1:4) .approxeq.biunit_xij)) THEN + obj%domainName = "BIUNIT" + ELSE + obj%domainName = "GENERAL" + END IF + +ELSE + + IF (PRESENT(domainName)) THEN + obj%domainName = UpperCase(domainName) + IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN + obj%xij = RefCoord_Tetrahedron(obj%domainName) + END IF + ELSE + obj%domainName = "UNIT" + obj%xij = RefCoord_Tetrahedron(obj%domainName) + END IF + +END IF + +CALL GetEdgeConnectivity_Tetrahedron(con=p1p2, order=1) +CALL GetFaceConnectivity_Tetrahedron(con=lloop, order=1) + +obj%entityCounts = [tNodes, tEdges, tFaces, 1_I4B] +obj%xidimension = nsd +obj%name = Tetrahedron4 +obj%order = 1_I4B +obj%nsd = nsd + +ii = SUM(obj%entityCounts) +CALL RefTopoReallocate(obj%topology, ii) + +! points +DO ii = 1, obj%entityCounts(1) + obj%topology(ii) = ReferenceTopology([ii], Point) +END DO + +! lines +jj = obj%entityCounts(1) +DO ii = 1, obj%entityCounts(2) + obj%topology(jj + ii) = ReferenceTopology(p1p2(:, ii), Line2) +END DO + +! faces +jj = jj + obj%entityCounts(2) +DO ii = 1, obj%entityCounts(3) + obj%topology(jj + ii) = ReferenceTopology(lloop(:, ii), Triangle3) +END DO + +! cell +jj = jj + obj%entityCounts(3) +obj%topology(jj + 1) = ReferenceTopology(arange(1_I4B, tNodes), Tetrahedron4) + +obj%highorderElement => highorderElement_Tetrahedron +END PROCEDURE Initiate_Ref_Tetrahedron + +!---------------------------------------------------------------------------- +! ReferenceTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Tetrahedron +CALL Initiate_Ref_tetrahedron(obj=obj, nsd=nsd, xij=xij, & + & domainName=domainName) +END PROCEDURE Reference_Tetrahedron + +!---------------------------------------------------------------------------- +! ReferenceTetrahedron_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reference_Tetrahedron_Pointer +ALLOCATE (obj) +CALL Initiate_Ref_tetrahedron(obj=obj, nsd=nsd, xij=xij, & + & domainName=domainName) +END PROCEDURE Reference_Tetrahedron_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HighOrderElement_Tetrahedron +INTEGER(I4B), PARAMETER :: tNodes = 4 +INTEGER(I4B) :: ii, tFaceNodes(4), faceElemType(4), jj, & + & edgetype +INTEGER(I4B), ALLOCATABLE :: edgecon(:, :), facecon(:, :) + +CALL DEALLOCATE (obj) + +obj%xij = InterpolationPoint_Tetrahedron( & + & xij=refelem%xij(1:3, 1:tNodes), & + & order=order, & + & ipType=ipType, & + & layout="VEFC") + +obj%domainName = refelem%domainName +obj%nsd = refelem%nsd +obj%highOrderElement => refelem%highOrderElement +obj%order = order +obj%xiDimension = refelem%xiDimension + +ii = LagrangeDOF_Tetrahedron(order=order) +obj%name = ElementType_Tetrahedron("Tetrahedron"//INT2STR(ii)) +obj%entityCounts = TotalEntities_Tetrahedron(obj%name) + +ii = SUM(obj%entityCounts) +CALL RefTopoReallocate(obj%topology, ii) + +! points +DO ii = 1, obj%entityCounts(1) + obj%topology(ii) = ReferenceTopology([ii], Point) +END DO + +CALL Reallocate(edgecon, order + 1, obj%entityCounts(2)) +CALL GetEdgeConnectivity_Tetrahedron(con=edgecon, order=order) +edgetype = ElementType_Line("Line"//Int2STR(order + 1)) + +! lines +jj = obj%entityCounts(1) +DO ii = 1, obj%entityCounts(2) + obj%topology(jj + ii) = ReferenceTopology(nptrs=edgecon(:, ii), & + & name=edgetype) +END DO + +CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, & + & tFaceNodes=tFaceNodes, elemType=obj%name) +CALL Reallocate(facecon, tFaceNodes(1), obj%entityCounts(3)) +CALL GetFaceConnectivity_Tetrahedron(con=facecon, order=order) + +! faces +jj = jj + obj%entityCounts(2) +DO ii = 1, obj%entityCounts(3) + obj%topology(jj + ii) = ReferenceTopology( & + & nptrs=facecon(1:tFaceNodes(ii), ii), & + & name=faceElemType(ii)) +END DO + +! cell +jj = jj + obj%entityCounts(3) +obj%topology(jj + 1) = ReferenceTopology( & + & arange(1_I4B, obj%entityCounts(1)), obj%name) + +IF (ALLOCATED(edgecon)) DEALLOCATE (edgecon) +IF (ALLOCATED(facecon)) DEALLOCATE (facecon) + +END PROCEDURE HighOrderElement_Tetrahedron + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Tetrahedron +CALL TetrahedronVolume3D(XiJ(1:3, 1:4), ans) +END PROCEDURE Measure_Simplex_Tetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Tetrahedron_Quality +ans = 0.0_DFP +! TODO Implement Tetrahedron_Quality +END PROCEDURE Tetrahedron_Quality + +!---------------------------------------------------------------------------- +! TetrahedronVolume3D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TetrahedronVolume3D +REAL(DFP) :: a(4, 4) +a(1:3, 1:4) = xij(1:3, 1:4) +a(4, 1:4) = 1.0_DFP +ans = ABS(Det(a)) / 6.0_DFP +END PROCEDURE TetrahedronVolume3D + +!---------------------------------------------------------------------------- +! RefCoord_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefCoord_Tetrahedron +CHARACTER(:), ALLOCATABLE :: layout +layout = UpperCase(refTetrahedron) +SELECT CASE (layout) +CASE ("BIUNIT") + ans(:, 1) = [-1.0_DFP, -1.0_DFP, -1.0_DFP] + ans(:, 2) = [1.0_DFP, -1.0_DFP, -1.0_DFP] + ans(:, 3) = [-1.0_DFP, 1.0_DFP, -1.0_DFP] + ans(:, 4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP] +CASE ("UNIT") + ans(:, 1) = [0.0_DFP, 0.0_DFP, 0.0_DFP] + ans(:, 2) = [1.0_DFP, 0.0_DFP, 0.0_DFP] + ans(:, 3) = [0.0_DFP, 1.0_DFP, 0.0_DFP] + ans(:, 4) = [0.0_DFP, 0.0_DFP, 1.0_DFP] +END SELECT +layout = "" +END PROCEDURE RefCoord_Tetrahedron + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity_Tetrahedron +INTEGER(I4B) :: order0, ii, jj, iface +con(1:2, 1) = [1, 2] +con(1:2, 2) = [1, 3] +con(1:2, 3) = [1, 4] +con(1:2, 4) = [2, 3] +con(1:2, 5) = [2, 4] +con(1:2, 6) = [3, 4] + +order0 = Input(default=1_I4B, option=order) + +IF (PRESENT(ncol)) ncol = 6 +IF (PRESENT(nrow)) nrow = order0 + 1 + +jj = 4 +DO iface = 1, 6 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + END DO + jj = jj + order0 - 1 +END DO + +END PROCEDURE GetEdgeConnectivity_Tetrahedron + +!---------------------------------------------------------------------------- +! GetFaceConnectivity_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity_Tetrahedron +INTEGER(I4B) :: order0, jj +con(1:3, 1) = [1, 3, 2] +con(1:3, 2) = [1, 2, 4] +con(1:3, 3) = [1, 4, 3] +con(1:3, 4) = [2, 3, 4] + +order0 = Input(default=1_I4B, option=order) +IF (PRESENT(ncol)) ncol = 4 + +jj = 4_I4B + +SELECT CASE (order0) +CASE (2_I4B) + con(jj:6, 1) = [6, 8, 5] + con(jj:6, 2) = [5, 9, 7] + con(jj:6, 3) = [7, 10, 6] + con(jj:6, 4) = [8, 10, 9] + jj = 7 +END SELECT + +IF (PRESENT(nrow)) nrow = jj - 1 + +END PROCEDURE GetFaceConnectivity_Tetrahedron + +!---------------------------------------------------------------------------- +! GetFaceElemType +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Tetrahedron +INTEGER(I4B) :: elemType0 +elemType0 = Input(default=Tetrahedron4, option=elemType) + +SELECT CASE (elemType0) +CASE (Tetrahedron4) + IF (PRESENT(faceElemType)) & + faceElemType(1:4) = Triangle3 + + IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 3_I4B + +CASE (Tetrahedron10) + IF (PRESENT(faceElemType)) & + faceElemType(1:4) = Triangle6 + + IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 6_I4B + +CASE (Tetrahedron20) + IF (PRESENT(faceElemType)) & + faceElemType(1:4) = Triangle10 + + IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 10_I4B + +CASE (Tetrahedron35) + IF (PRESENT(faceElemType)) & + faceElemType(1:4) = Triangle15 + + IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 15_I4B + +CASE (Tetrahedron56) + IF (PRESENT(faceElemType)) & + faceElemType(1:4) = Triangle21 + + IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 21_I4B + +END SELECT +END PROCEDURE GetFaceElemType_Tetrahedron + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 new file mode 100644 index 000000000..c1bfa8f99 --- /dev/null +++ b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 @@ -0,0 +1,849 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 2 March 2021 +! summary: This submodule contains methods for [[ReferenceTriangle_]] + +SUBMODULE(ReferenceTriangle_Method) Methods +USE BaseType, ONLY: QualityMeasure +USE ReferenceElement_Method +USE StringUtility +USE ApproxUtility +USE ArangeUtility +USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle, & + & LagrangeDOF_Triangle +USE Triangle_Method +USE InputUtility +USE ReferenceLine_Method, ONLY: ElementType_Line, & + & ElementOrder_Line +USE LineInterpolationUtility, ONLY: InterpolationPoint_Line +USE MiscUtility, ONLY: Int2Str +USE Display_Method +USE ReallocateUtility + +! USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ElementName_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementName_Triangle +SELECT CASE (elemType) +CASE (Triangle3) + ans = "Triangle3" +CASE (Triangle6) + ans = "Triangle6" +CASE (Triangle9) + ans = "Triangle9" +CASE (Triangle10) + ans = "Triangle10" +CASE (Triangle12) + ans = "Triangle12" +CASE (Triangle15a) + ans = "Triangle15a" +CASE (Triangle15b) + ans = "Triangle15b" +CASE (Triangle21) + ans = "Triangle21" +CASE DEFAULT + ans = "NONE" +END SELECT +END PROCEDURE ElementName_Triangle + +!---------------------------------------------------------------------------- +! FacetTopology_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetTopology_Triangle +INTEGER(I4B) :: order, ii, lineType +INTEGER(I4B), ALLOCATABLE :: con(:, :) + +order = ElementOrder_Triangle(elemType) +CALL Reallocate(con, order + 1, 3) +CALL GetFaceConnectivity_Triangle(con=con, & + & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, order=order) +lineType = ElementType_Line("Line"//Int2Str(order + 1)) + +DO ii = 1, 3 + ans(ii)%nptrs = nptrs(con(:, ii)) + ans(ii)%xiDimension = 1 + ans(ii)%name = lineType +END DO + +IF (ALLOCATED(con)) DEALLOCATE (con) + +END PROCEDURE FacetTopology_Triangle + +!---------------------------------------------------------------------------- +! TotalEntities_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalEntities_Triangle +ans(2:4) = [3, 1, 0] +ans(1) = TotalNodesInElement_Triangle(elemType) +END PROCEDURE TotalEntities_Triangle + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TotalNodesInElement_Triangle +SELECT CASE (ElemType) +CASE (Triangle3) + ans = 3 +CASE (Triangle6) + ans = 6 +CASE (Triangle9) + ans = 9 +CASE (Triangle10) + ans = 10 +CASE (Triangle12) + ans = 12 +CASE (Triangle15a) + ans = 15 +CASE (Triangle15b) + ans = 15 +CASE (Triangle21) + ans = 21 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE TotalNodesInElement_Triangle + +!---------------------------------------------------------------------------- +! ElementOrder_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementOrder_Triangle +SELECT CASE (ElemType) +CASE (Triangle3) + ans = 1 +CASE (Triangle6) + ans = 2 +CASE (Triangle9) + ans = 3 +CASE (Triangle10) + ans = 3 +CASE (Triangle12) + ans = 4 +CASE (Triangle15a) + ans = 4 +CASE (Triangle15b) + ans = 5 +CASE (Triangle21) + ans = 5 +END SELECT +END PROCEDURE ElementOrder_Triangle + +!---------------------------------------------------------------------------- +! ElementType_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElementType_Triangle +SELECT CASE (elemName) +CASE ("Triangle3", "Triangle") + ans = Triangle3 +CASE ("Triangle6") + ans = Triangle6 +CASE ("Triangle9") + ans = Triangle9 +CASE ("Triangle10") + ans = Triangle10 +CASE ("Triangle12") + ans = Triangle12 +CASE ("Triangle15a") + ans = Triangle15a +CASE ("Triangle15b") + ans = Triangle15b +CASE ("Triangle21") + ans = Triangle21 +CASE DEFAULT + ans = 0 +END SELECT +END PROCEDURE ElementType_Triangle + +!---------------------------------------------------------------------------- +! FacetElements_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Triangle1 +INTEGER(I4B) :: ii, istart, tsize, jj +TYPE(ReferenceTopology_) :: topo + +istart = refelem%entityCounts(1) + +ans(1)%xij = InterpolationPoint_Line( & + & order=refelem%order, & + & ipType=refelem%interpolationPointType, & + & layout="VEFC") + +ans(1)%interpolationPointType = refelem%interpolationPointType +ans(1)%nsd = refelem%nsd +DO ii = 2, 3 + ans(ii)%xij = ans(1)%xij + ans(ii)%interpolationPointType = ans(1)%interpolationPointType + ans(ii)%nsd = ans(1)%nsd +END DO + +DO ii = 1, 3 + topo = refelem%topology(istart + ii) + tsize = SIZE(topo%nptrs) + ans(ii)%xiDimension = topo%xiDimension + ans(ii)%name = topo%name + ans(ii)%order = ElementOrder_Line(elemType=topo%name) + ans(ii)%entityCounts = [tsize, 1, 0, 0] + + ALLOCATE (ans(ii)%topology(tsize + 1)) + DO jj = 1, tsize + ans(ii)%topology(jj) = Referencetopology( & + & nptrs=topo%nptrs(jj:jj), name=Point) + END DO + + ans(ii)%topology(tsize + 1) = Referencetopology( & + & nptrs=topo%nptrs, name=topo%name) +END DO + +CALL DEALLOCATE (topo) + +END PROCEDURE FacetElements_Triangle1 + +!---------------------------------------------------------------------------- +! FacetElements_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetElements_Triangle2 +INTEGER(I4B) :: ii, jj, order +INTEGER(I4B), ALLOCATABLE :: facecon(:, :) + +order = ElementOrder_Triangle(elemType) +CALL Reallocate(facecon, order + 1, 3) +CALL GetFaceConnectivity_Triangle(con=facecon, & + & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, order=order) +!! The edges are accordign to gmsh +!! [1,2], [2,3], [3,1] + +DO ii = 1, 3 + + 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=ans(ii)%order, & + & ipType=ans(ii)%interpolationPointType, & + & layout="VEFC") + + ans(ii)%nsd = nsd + ans(ii)%entityCounts = [order + 1, 1, 0, 0] + ALLOCATE (ans(ii)%topology(order + 2)) + + DO jj = 1, order + 1 + ans(ii)%topology(jj) = Referencetopology(nptrs=facecon(jj:jj, ii), & + & name=Point) + END DO + + ans(ii)%topology(order + 2) = Referencetopology(nptrs=facecon(1:2, ii), & + & name=ans(ii)%name) + +END DO + +IF (ALLOCATED(facecon)) DEALLOCATE (facecon) + +END PROCEDURE FacetElements_Triangle2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE initiate_ref_Triangle +REAL(DFP) :: unit_xij(2, 3), biunit_xij(2, 3) +INTEGER(I4B) :: facecon(2, 3), ii + +CALL DEALLOCATE (obj) + +unit_xij = RefCoord_Triangle("UNIT") +biunit_xij = RefCoord_Triangle("BIUNIT") + +IF (PRESENT(xij)) THEN + obj%xij = xij(1:2, 1:3) + IF (ALL(obj%xij(1:2, 1:3) .approxeq.unit_xij)) THEN + obj%domainName = "UNIT" + ELSE IF (ALL(obj%xij(1:2, 1:3) .approxeq.biunit_xij)) THEN + obj%domainName = "BIUNIT" + ELSE + obj%domainName = "GENERAL" + END IF + +ELSE + + IF (PRESENT(domainName)) THEN + obj%domainName = UpperCase(domainName) + IF (obj%domainName .EQ. "UNIT" .OR. obj%domainName .EQ. "BIUNIT") THEN + obj%xij = RefCoord_Triangle(obj%domainName) + END IF + ELSE + obj%domainName = "UNIT" + obj%xij = RefCoord_Triangle(obj%domainName) + END IF + +END IF + +obj%entityCounts = [3, 3, 1, 0] +obj%xiDimension = 2 +obj%name = Triangle3 +obj%order = 1 +obj%nsd = nsd + +ALLOCATE (obj%topology(7)) +obj%topology(1) = Referencetopology([1], Point) +obj%topology(2) = Referencetopology([2], Point) +obj%topology(3) = Referencetopology([3], Point) + +CALL GetFaceConnectivity_Triangle(con=facecon, & + & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, & + & order=1) + +DO ii = 1, 3 + obj%topology(3 + ii) = Referencetopology(facecon(1:2, ii), Line2) +END DO + +obj%topology(7) = Referencetopology([1, 2, 3], Triangle3) + +obj%highorderElement => highorderElement_Triangle +END PROCEDURE initiate_ref_Triangle + +!---------------------------------------------------------------------------- +! ReferenceTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE reference_Triangle +CALL initiate_ref_triangle(obj=obj, nsd=nsd, xij=xij, domainName=domainName) +END PROCEDURE reference_Triangle + +!---------------------------------------------------------------------------- +! ReferenceTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE reference_Triangle_Pointer +ALLOCATE (obj) +CALL initiate_ref_triangle(obj=obj, nsd=nsd, xij=xij, domainName=domainName) +END PROCEDURE reference_Triangle_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HighorderElement_Triangle +INTEGER(I4B) :: linetype, ii, nns +INTEGER(I4B), ALLOCATABLE :: facecon(:, :) + +CALL DEALLOCATE (obj) + +obj%xij = InterpolationPoint_Triangle( & + & xij=refelem%xij(:, 1:3), & + & order=order, & + & ipType=ipType, & + & layout="VEFC") + +obj%domainName = refelem%domainName +obj%nsd = refelem%nsd +obj%highOrderElement => refelem%highOrderElement +obj%order = order +obj%xidimension = refelem%xidimension +nns = LagrangeDOF_Triangle(order=order) +obj%name = ElementType_Triangle("Triangle"//Int2Str(nns)) +obj%entityCounts = TotalEntities_Triangle(obj%name) +ii = SUM(obj%entityCounts) +CALL RefTopoReallocate(obj%topology, ii) + +DO ii = 1, obj%entityCounts(1) + obj%topology(ii) = ReferenceTopology([ii], Point) +END DO + +CALL Reallocate(facecon, order + 1, obj%entityCounts(2)) +CALL GetFaceConnectivity_Triangle(con=facecon, & + & opt=DEFAULT_OPT_TRIANGLE_EDGE_CON, order=order) + +linetype = ElementType_Line("Line"//Int2Str(order + 1)) +ii = obj%entityCounts(1) +obj%topology(ii + 1) = ReferenceTopology(facecon(:, 1), linetype) +obj%topology(ii + 2) = ReferenceTopology(facecon(:, 2), linetype) +obj%topology(ii + 3) = ReferenceTopology(facecon(:, 3), linetype) +obj%topology(ii + 4) = ReferenceTopology(facecon(:, 4), linetype) + +ii = ii + obj%entityCounts(2) +obj%topology(ii + 1) = ReferenceTopology(arange(1_I4B, nns), obj%name) + +IF (ALLOCATED(facecon)) DEALLOCATE (facecon) +END PROCEDURE HighorderElement_Triangle + +!---------------------------------------------------------------------------- +! MeasureSimplex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Measure_Simplex_Triangle +ans = triangle_area(refelem, xij) +END PROCEDURE Measure_Simplex_Triangle + +!---------------------------------------------------------------------------- +! Triangle_Angles +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_angles +SELECT CASE (refelem%nsd) +CASE (2) + ans = triangle_angles_2d(xij(1:2, 1:3)) +CASE (3) + ans = triangle_angles_3d(xij(1:3, 1:3)) +END SELECT +END PROCEDURE triangle_angles + +!---------------------------------------------------------------------------- +! Triangle_Area +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_area +SELECT CASE (refelem%nsd) +CASE (2) + ans = triangle_area_2d(xij(1:2, 1:3)) +CASE (3) + ans = TRIANGLE_AREA_3D(xij(1:3, 1:3)) +END SELECT +END PROCEDURE triangle_area + +!---------------------------------------------------------------------------- +! Triangle_ArealVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_ArealVector +SELECT CASE (refelem%nsd) +CASE (2) + ans(1:2) = 0.0_DFP + ans(3) = triangle_area_2d(xij(1:2, 1:3)) +CASE (3) + ans = triangle_area_vector_3d(xij(1:3, 1:3)) +END SELECT +END PROCEDURE triangle_ArealVector + +!---------------------------------------------------------------------------- +! Triangle_Barycentric +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_barycentric +ans = triangle_barycentric_2d(xij(1:2, 1:3), x(1:2)) +END PROCEDURE triangle_barycentric + +!---------------------------------------------------------------------------- +! Triangle_Centroid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_centroid +IF (refelem%nsd .EQ. 2) THEN + Ans(3) = 0.0_DFP + ans(1:2) = triangle_centroid_2d(xij) +ELSE + ans = triangle_centroid_3d(xij) +END IF +END PROCEDURE triangle_centroid + +!---------------------------------------------------------------------------- +! triangle_circumcentre +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumcentre +IF (refelem%nsd .EQ. 2) THEN + Ans(3) = 0.0_DFP + ans(1:2) = triangle_circumcenter_2d(xij) +ELSE + ans = triangle_circumcenter(3_I4B, xij) +END IF +END PROCEDURE triangle_circumcentre + +!---------------------------------------------------------------------------- +! triangle_circumcircle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumcircle +Ans(4) = 0.0_DFP +CALL triangle_circumcircle_2d(xij, ans(1), ans(2:3)) +END PROCEDURE triangle_circumcircle + +!---------------------------------------------------------------------------- +! triangle_circumradius +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumradius +ans = triangle_circumradius_2d(xij) +END PROCEDURE triangle_circumradius + +!---------------------------------------------------------------------------- +! triangle_contains_line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_contains_line +IF (parametricLine) THEN + CALL triangle_contains_line_par_3d(xij, x1, x2, & + & inside, xint) +ELSE + CALL triangle_contains_line_exp_3d(xij, x1, x2, & + & inside, xint) +END IF +END PROCEDURE triangle_contains_line + +!---------------------------------------------------------------------------- +! triangle_contains_point +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_contains_point +ans = triangle_contains_point_2d_1(xij(1:2, 1:3), x(1:2)) +END PROCEDURE triangle_contains_point + +!---------------------------------------------------------------------------- +! triangle_diameter +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_diameter +ans = triangle_diameter_2d(xij(1:2, 1:3)) +END PROCEDURE triangle_diameter + +!---------------------------------------------------------------------------- +! triangle_edge_length +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_edge_length +ans = triangle_edge_length_2d(xij(1:2, 1:3)) +END PROCEDURE triangle_edge_length + +!---------------------------------------------------------------------------- +! triangle_incenter +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_incenter +Ans(3) = 0.0_DFP +ans(1:2) = triangle_incenter_2d(xij(1:2, 1:3)) +END PROCEDURE triangle_incenter + +!---------------------------------------------------------------------------- +! triangle_incircle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_incircle +Ans(4) = 0.0_DFP +CALL triangle_incircle_2d(xij(1:2, 1:3), Ans(1), Ans(2:3)) +END PROCEDURE triangle_incircle + +!---------------------------------------------------------------------------- +! triangle_inradius +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_inradius +ans = triangle_inradius_2d(xij(1:2, 1:3)) +END PROCEDURE triangle_inradius + +!---------------------------------------------------------------------------- +! triangle_orthocenter +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_orthocenter +Ans(3) = 0.0_DFP +ans(1:2) = triangle_orthocenter_2d(xij(1:2, 1:3)) +END PROCEDURE triangle_orthocenter + +!---------------------------------------------------------------------------- +! triangle_point_dist +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_point_dist +SELECT CASE (refelem%nsd) +CASE (2) + ans = triangle_point_dist_2d(xij(1:2, 1:3), x(1:2)) +CASE (3) + ans = triangle_point_dist_3d(xij(1:3, 1:3), x(1:3)) +END SELECT +END PROCEDURE triangle_point_dist + +!---------------------------------------------------------------------------- +! triangle_nearest_point +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_get_nearest_point +CALL triangle_point_near_2d(xij(1:2, 1:3), x(1:2), xn(1:2), dist) +END PROCEDURE triangle_get_nearest_point + +!---------------------------------------------------------------------------- +! triangle_random_point +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_random_point +Ans = 0.0_DFP +ans(1:2, 1:n) = triangle_sample(xij(1:2, 1:3), n, seed) +END PROCEDURE triangle_random_point + +!---------------------------------------------------------------------------- +! triangle_quality +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_quality +REAL(DFP) :: rvar(3) + +SELECT CASE (measure) + +CASE (QualityMeasure%area) + Ans = Area(refelem=refelem, xij=xij) + +CASE (QualityMeasure%maxangle) + Ans = MAXVAL(Angles(refelem=refelem, xij=xij)) + +CASE (QualityMeasure%minangle) + Ans = MINVAL(Angles(refelem=refelem, xij=xij)) + +CASE (QualityMeasure%angleratio) + Ans = 3.0_DFP * MINVAL(Angles(refelem=refelem, xij=xij)) / Pi + +CASE (QualityMeasure%radiusRatio) + Ans = 2.0_DFP * InRadius(refelem=refelem, xij=xij) & + & / CircumRadius(refelem=refelem, xij=xij) + +CASE (QualityMeasure%edgeRatio) + rvar = EdgeLength(refelem=refelem, xij=xij) + Ans = MINVAL(rvar) / MAXVAL(rvar) + +CASE (QualityMeasure%aspectRatio) + rvar = EdgeLength(refelem=refelem, xij=xij) + Ans = MAXVAL(rvar) * SUM(rvar) & + & / (4.0_DFP * SQRT(3.0_DFP) * area(refelem=refelem, xij=xij)) +END SELECT +END PROCEDURE triangle_quality + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriangleArea3D +INTEGER(I4B), PARAMETER :: dim_num = 3 +REAL(DFP) :: cross(dim_num) + +! Compute the cross product vector. +cross(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & + - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) +cross(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & + - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) +cross(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) +ans = 0.5_DFP * SQRT(SUM(cross(1:3)**2)) +END PROCEDURE TriangleArea3D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriangleArea2D +ans = 0.5_DFP * ( & + t(1, 1) * (t(2, 2) - t(2, 3)) & + + t(1, 2) * (t(2, 3) - t(2, 1)) & + + t(1, 3) * (t(2, 1) - t(2, 2))) +END PROCEDURE TriangleArea2D + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeConnectivity_Triangle +INTEGER(I4B) :: opt0, order0, ii, jj, iface + +opt0 = Input(default=1_I4B, option=opt) +order0 = Input(default=1_I4B, option=order) +jj = 3 + +IF (PRESENT(ncol)) ncol = 3 +IF (PRESENT(nrow)) nrow = 1 + order0 + +SELECT CASE (opt0) +CASE (1_I4B) + con(1:2, 1) = [1, 2] + con(1:2, 2) = [1, 3] + con(1:2, 3) = [2, 3] + + iface = 1 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + jj = jj + 1 + END DO + + iface = 3 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + jj = jj + 1 + END DO + + iface = 2 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + jj = jj + 1 + END DO + +CASE (2_I4B) + !! For Lagrangian polynomial + con(1:2, 1) = [1, 2] + con(1:2, 2) = [2, 3] + con(1:2, 3) = [3, 1] + + iface = 1 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + jj = jj + 1 + END DO + + iface = 2 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + jj = jj + 1 + END DO + + iface = 3 + DO ii = 1, order0 - 1 + con(2 + ii, iface) = jj + ii + jj = jj + 1 + END DO +END SELECT + +END PROCEDURE GetEdgeConnectivity_Triangle + +!---------------------------------------------------------------------------- +! GetFaceConnectivity_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceConnectivity_Triangle +CALL GetEdgeconnectivity_Triangle(con=con, opt=2_I4B, order=order, & + nrow=nrow, ncol=ncol) +END PROCEDURE GetFaceConnectivity_Triangle + +!---------------------------------------------------------------------------- +! RefTriangleCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefTriangleCoord +CHARACTER(:), ALLOCATABLE :: layout +layout = UpperCase(refTriangle) +SELECT CASE (layout) +CASE ("BIUNIT") + ans(:, 1) = [-1.0_DFP, -1.0_DFP] + ans(:, 2) = [1.0_DFP, -1.0_DFP] + ans(:, 3) = [-1.0_DFP, 1.0_DFP] +CASE ("UNIT") + ans(:, 1) = [0.0_DFP, 0.0_DFP] + ans(:, 2) = [1.0_DFP, 0.0_DFP] + ans(:, 3) = [0.0_DFP, 1.0_DFP] +END SELECT +layout = "" +END PROCEDURE RefTriangleCoord + +!---------------------------------------------------------------------------- +! FaceShapeMetaData_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FaceShapeMetaData_Triangle +INTEGER(I4B), PARAMETER :: HelpFaceData_Triangle(2, 3) = & + & RESHAPE([ & + & 2, 3, & + & 3, 1, & + & 1, 2 & + & ], [2, 3]) + +INTEGER(I4B) :: a(3), localFaces0(3) + +a(1) = MINLOC(face, 1) +a(2) = HelpFaceData_Triangle(1, a(1)) !b +a(3) = HelpFaceData_Triangle(2, a(1)) !c + +localFaces0 = face(a) +IF (PRESENT(localFaces)) THEN + localFaces(1:3) = localFaces0 +END IF + +sorted_face(1) = localFaces0(1) + +IF (localFaces0(2) .LT. localFaces0(3)) THEN + sorted_face(2) = localFaces0(2) + sorted_face(3) = localFaces0(3) + + IF (PRESENT(faceOrient)) THEN + faceOrient(1) = a(1) - 1_I4B + faceOrient(2) = 1_INT8 + END IF + +ELSE + sorted_face(2) = localFaces0(3) + sorted_face(3) = localFaces0(2) + + IF (PRESENT(faceOrient)) THEN + faceOrient(1) = a(1) - 1_I4B + faceOrient(2) = -1_INT8 + END IF + +END IF + +END PROCEDURE FaceShapeMetaData_Triangle + +!---------------------------------------------------------------------------- +! GetFaceElemType_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Triangle +INTEGER(I4B) :: elemType0 + +elemType0 = input(default=Triangle, option=elemType) + +SELECT CASE (elemType0) + +CASE (Triangle3) + + IF (PRESENT(faceElemType)) faceElemType(1:3) = Line2 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 2_I4B + +CASE (Triangle6) + IF (PRESENT(faceElemType)) faceElemType(1:3) = Line3 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 3_I4B + +CASE (Triangle9, Triangle10) + IF (PRESENT(faceElemType)) faceElemType(1:3) = Line4 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 4_I4B + +CASE (Triangle15) + IF (PRESENT(faceElemType)) faceElemType(1:3) = Line5 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 5_I4B + +CASE (Triangle21a, Triangle21b) + IF (PRESENT(faceElemType)) faceElemType(1:3) = Line6 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 6_I4B + +CASE (Triangle18) + IF (PRESENT(faceElemType)) faceElemType(1:3) = Line7 + IF (PRESENT(tFaceNodes)) tFaceNodes(1:3) = 7_I4B + +END SELECT + +END PROCEDURE GetFaceElemType_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/Triangle_Method@Methods.F90 b/src/submodules/Geometry/src/Triangle_Method@Methods.F90 new file mode 100644 index 000000000..70337ee7d --- /dev/null +++ b/src/submodules/Geometry/src/Triangle_Method@Methods.F90 @@ -0,0 +1,1435 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Triangle_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_angles_2d +INTEGER(I4B), PARAMETER :: dim_num = 2 +REAL(DFP), PARAMETER :: r8_pi = 3.141592653589793D+00 +REAL(DFP) :: a +REAL(DFP) :: b +REAL(DFP) :: c +! +! Compute the length of each side. +! +a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) +b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) +c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) +! +! Take care of ridiculous special cases. +! +IF (a == 0.0D+00 .AND. b == 0.0D+00 .AND. c == 0.0D+00) THEN + angle(1:3) = 2.0D+00 * r8_pi / 3.0D+00 + RETURN +END IF +! +IF (c == 0.0D+00 .OR. a == 0.0D+00) THEN + angle(1) = r8_pi +ELSE + angle(1) = safe_ACOS((c * c + a * a - b * b) / (2.0D+00 * c * a)) +END IF +! +IF (a == 0.0D+00 .OR. b == 0.0D+00) THEN + angle(2) = r8_pi +ELSE + angle(2) = safe_ACOS((a * a + b * b - c * c) / (2.0D+00 * a * b)) +END IF +! +IF (b == 0.0D+00 .OR. c == 0.0D+00) THEN + angle(3) = r8_pi +ELSE + angle(3) = safe_ACOS((b * b + c * c - a * a) / (2.0D+00 * b * c)) +END IF +END PROCEDURE triangle_angles_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_angles_3d +INTEGER(I4B), PARAMETER :: dim_num = 3 +REAL(DFP) :: a +REAL(DFP) :: b +REAL(DFP) :: c +REAL(DFP), PARAMETER :: r8_pi = 3.141592653589793D+00 +! +! Compute the length of each side. +! +a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) +b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) +c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) +! +! Take care of a ridiculous special case. +! +IF (a == 0.0_DFP .AND. b == 0.0_DFP .AND. c == 0.0_DFP) THEN + angle(1:3) = 2.0_DFP * r8_pi / 3.0_DFP + RETURN +END IF +! +IF (c == 0.0_DFP .OR. a == 0.0_DFP) THEN + angle(1) = r8_pi +ELSE + angle(1) = safe_acos((c * c + a * a - b * b) / (2.0_DFP * c * a)) +END IF +! +IF (a == 0.0_DFP .OR. b == 0.0_DFP) THEN + angle(2) = r8_pi +ELSE + angle(2) = safe_acos((a * a + b * b - c * c) / (2.0_DFP * a * b)) +END IF +! +IF (b == 0.0_DFP .OR. c == 0.0_DFP) THEN + angle(3) = r8_pi +ELSE + angle(3) = safe_acos((b * b + c * c - a * a) / (2.0_DFP * b * c)) +END IF +! +END PROCEDURE triangle_angles_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_area_2d +area = 0.5_DFP * ( & + t(1, 1) * (t(2, 2) - t(2, 3)) & + + t(1, 2) * (t(2, 3) - t(2, 1)) & + + t(1, 3) * (t(2, 1) - t(2, 2))) +END PROCEDURE triangle_area_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_area_3d +INTEGER(I4B), PARAMETER :: dim_num = 3_I4B +REAL(DFP) :: cross(dim_num) +! +! Compute the cross product vector. +! +cross(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & + - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) +! +cross(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & + - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) +! +cross(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) +! +area = 0.5D+00 * SQRT(SUM(cross(1:3)**2)) +END PROCEDURE triangle_area_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_area_3d_2 +INTEGER(I4B), PARAMETER :: dim_num = 3 +REAL(DFP) :: alpha +REAL(DFP) :: base +REAL(DFP) :: dot +REAL(DFP) :: height +! +! Find the projection of (P3-P1) onto (P2-P1). +! +dot = (t(1, 2) - t(1, 1)) * (t(1, 3) - t(1, 1)) & + + (t(2, 2) - t(2, 1)) * (t(2, 3) - t(2, 1)) & + + (t(3, 2) - t(3, 1)) * (t(3, 3) - t(3, 1)) +! +! Find the length of (P2-P1). +! +base = SQRT((t(1, 2) - t(1, 1))**2 & + & + (t(2, 2) - t(2, 1))**2 & + & + (t(3, 2) - t(3, 1))**2) +! +! The height of the triangle is the length of (P3-P1) after its +! projection onto (P2-P1) has been subtracted. +! +IF (base == 0.0_DFP) THEN + height = 0.0_DFP +ELSE + alpha = dot / (base * base) + height = SQRT( & + (t(1, 1) + alpha * (t(1, 2) - t(1, 1)) - t(1, 3))**2 & + + (t(2, 1) + alpha * (t(2, 2) - t(2, 1)) - t(2, 3))**2 & + + (t(3, 1) + alpha * (t(3, 2) - t(3, 1)) - t(3, 3))**2) +END IF +! +area = 0.5_DFP * base * height +! +END PROCEDURE triangle_area_3d_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_area_3d_3 +INTEGER(i4b), PARAMETER :: dim_num = 3 +INTEGER(i4b) :: i +INTEGER(i4b) :: j +INTEGER(i4b) :: jp1 +REAL(dfp) :: s(3) +!! +DO j = 1, 3 + jp1 = MOD(j, 3) + 1 + s(j) = 0.0D+00 + DO i = 1, dim_num + s(j) = s(j) + (t(i, j) - t(i, jp1))**2 + END DO + s(j) = SQRT(s(j)) +END DO +!! +area = (s(1) + s(2) + s(3)) & + * (-s(1) + s(2) + s(3)) & + * (s(1) - s(2) + s(3)) & + * (s(1) + s(2) - s(3)) +!! +IF (area < 0.0D+00) THEN + area = -1.0D+00 + RETURN +END IF +!! +area = 0.25D+00 * SQRT(area) +END PROCEDURE triangle_area_3d_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_area_heron +area = (s(1) + s(2) + s(3)) & + * (-s(1) + s(2) + s(3)) & + * (s(1) - s(2) + s(3)) & + * (s(1) + s(2) - s(3)) +IF (area < 0.0D+00) THEN + area = -1.0D+00 + RETURN +END IF +area = 0.25D+00 * SQRT(area) +END PROCEDURE triangle_area_heron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_area_vector_3d +INTEGER(i4b), PARAMETER :: dim_num = 3 + +area_vector(1) = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & + - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) + +area_vector(2) = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & + - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) + +area_vector(3) = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) +END PROCEDURE triangle_area_vector_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_barycentric_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b), PARAMETER :: rhs_num = 1 +REAL(dfp) :: a(dim_num, dim_num + rhs_num) +INTEGER(i4b) :: info +! +! Set up the linear system +! +! ( X2-X1 X3-X1 ) XSI(1) = X-X1 +! ( Y2-Y1 Y3-Y1 ) XSI(2) Y-Y1 +! +! which is satisfied by the barycentric coordinates of P. +! +a(1, 1) = t(1, 2) - t(1, 1) +a(1, 2) = t(1, 3) - t(1, 1) +a(1, 3) = p(1) - t(1, 1) +! +a(2, 1) = t(2, 2) - t(2, 1) +a(2, 2) = t(2, 3) - t(2, 1) +a(2, 3) = p(2) - t(2, 1) +! +! Solve the linear system. +! +CALL r8mat_solve(n=dim_num, rhs_num=rhs_num, a=a, info=info) +! +xsi(1) = a(1, 3) +xsi(2) = a(2, 3) +xsi(3) = 1.0D+00 - xsi(1) - xsi(2) +END PROCEDURE triangle_barycentric_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_centroid_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b) :: i +DO i = 1, dim_num + centroid(i) = SUM(t(i, 1:3)) / 3.0D+00 +END DO +END PROCEDURE triangle_centroid_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_centroid_3d +INTEGER(i4b), PARAMETER :: dim_num = 3 +INTEGER(i4b) :: i +DO i = 1, dim_num + centroid(i) = SUM(t(i, 1:3)) / 3.0D+00 +END DO +END PROCEDURE triangle_centroid_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumcenter_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: avar +REAL(dfp) :: f(2) +REAL(dfp) :: top(dim_num) + +f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 +f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 + +top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) +top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) + +avar = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) + +pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / avar +END PROCEDURE triangle_circumcenter_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumcenter_2d_2 +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b), PARAMETER :: rhs_num = 1 +REAL(dfp) :: a(dim_num, dim_num + rhs_num) +INTEGER(i4b) :: info +! +! Set up the linear system. +! +a(1, 1) = t(1, 2) - t(1, 1) +a(1, 2) = t(2, 2) - t(2, 1) +a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 +! +a(2, 1) = t(1, 3) - t(1, 1) +a(2, 2) = t(2, 3) - t(2, 1) +a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 +! +! Solve the linear system. +! +CALL r8mat_solve(dim_num, rhs_num, a, info) +! +! Compute the center +! +IF (info /= 0) THEN + pc(1:dim_num) = 0.0D+00 +ELSE + pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) +END IF +END PROCEDURE triangle_circumcenter_2d_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumcenter +REAL(dfp) :: a +REAL(dfp) :: abp +REAL(dfp) :: apc +REAL(dfp) :: b +REAL(dfp) :: c +REAL(dfp) :: pbc +!! +a = r8vec_normsq_affine(n, t(1:n, 2), t(1:n, 3)) +b = r8vec_normsq_affine(n, t(1:n, 3), t(1:n, 1)) +c = r8vec_normsq_affine(n, t(1:n, 1), t(1:n, 2)) +!! +pbc = a * (-a + b + c) +apc = b * (a - b + c) +abp = c * (a + b - c) +!! +p(1:n) = (pbc * t(1:n, 1) + apc * t(1:n, 2) + abp * t(1:n, 3)) & + & / (pbc + apc + abp) +END PROCEDURE triangle_circumcenter + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumcircle_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: a +REAL(dfp) :: b +REAL(dfp) :: bot +REAL(dfp) :: c +REAL(dfp) :: f(2) +REAL(dfp) :: top(dim_num) +REAL(dfp) :: avar +! +! Circumradius. +! +a = SQRT((t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2) +b = SQRT((t(1, 3) - t(1, 2))**2 + (t(2, 3) - t(2, 2))**2) +c = SQRT((t(1, 1) - t(1, 3))**2 + (t(2, 1) - t(2, 3))**2) +! +bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) +! +IF (bot <= 0.0D+00) THEN + r = -1.0D+00 + pc(1:2) = 0.0D+00 + RETURN +END IF +! +r = a * b * c / SQRT(bot) +! +! Circumcenter. +! +f(1) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 +f(2) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 +! +top(1) = (t(2, 3) - t(2, 1)) * f(1) - (t(2, 2) - t(2, 1)) * f(2) +top(2) = -(t(1, 3) - t(1, 1)) * f(1) + (t(1, 2) - t(1, 1)) * f(2) +! +avar = (t(2, 3) - t(2, 1)) * (t(1, 2) - t(1, 1)) & + & - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) +! +pc(1:2) = t(1:2, 1) + 0.5D+00 * top(1:2) / avar +! +END PROCEDURE triangle_circumcircle_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumcircle_2d_2 +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b), PARAMETER :: rhs_num = 1 +REAL(dfp) :: a(dim_num, dim_num + rhs_num) +INTEGER(i4b) :: info +! +! Set up the linear system. +! +a(1, 1) = t(1, 2) - t(1, 1) +a(1, 2) = t(2, 2) - t(2, 1) +a(1, 3) = (t(1, 2) - t(1, 1))**2 + (t(2, 2) - t(2, 1))**2 + +a(2, 1) = t(1, 3) - t(1, 1) +a(2, 2) = t(2, 3) - t(2, 1) +a(2, 3) = (t(1, 3) - t(1, 1))**2 + (t(2, 3) - t(2, 1))**2 +! +! Solve the linear system. +! +CALL r8mat_solve(dim_num, rhs_num, a, info) + +IF (info /= 0) THEN + r = -1.0D+00 + pc(1:dim_num) = 0.0D+00 +END IF + +r = 0.5D+00 * SQRT(a(1, dim_num + 1) * a(1, dim_num + 1) & + + a(2, dim_num + 1) * a(2, dim_num + 1)) +pc(1:dim_num) = t(1:dim_num, 1) + 0.5D+00 * a(1:dim_num, dim_num + 1) + +END PROCEDURE triangle_circumcircle_2d_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_circumradius_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: a +REAL(dfp) :: b +REAL(dfp) :: bot +REAL(dfp) :: c +! +! Compute the length of each side. +! +a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) +b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) +c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) +bot = (a + b + c) * (-a + b + c) * (a - b + c) * (a + b - c) +IF (bot <= 0.0D+00) THEN + r = -1.0D+00 + RETURN +END IF +r = a * b * c / SQRT(bot) +END PROCEDURE triangle_circumradius_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_contains_line_exp_3d +INTEGER(i4b), PARAMETER :: dim_num = 3 +INTEGER(i4b) :: ival +REAL(dfp) :: normal(dim_num) +REAL(dfp) :: normal2(dim_num) +REAL(dfp) :: temp +REAL(dfp) :: v1(dim_num) +REAL(dfp) :: v2(dim_num) +! +! Make sure the line is not degenerate. +! +IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) RETURN +! +! Make sure the triangle is not degenerate. +! +IF (triangle_is_degenerate_nd(dim_num, t)) RETURN +! +! Determine a unit normal vector associated with the plane of +! the triangle. +! +v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) +v2(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 1) +! +normal(1) = v1(2) * v2(3) - v1(3) * v2(2) +normal(2) = v1(3) * v2(1) - v1(1) * v2(3) +normal(3) = v1(1) * v2(2) - v1(2) * v2(1) +! +temp = SQRT(SUM(normal(1:dim_num)**2)) +normal(1:dim_num) = normal(1:dim_num) / temp +! +! 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) +! +IF (ival == 0) THEN + inside = .FALSE. + pint(1:dim_num) = HUGE(temp) + RETURN +ELSE IF (ival == 2) THEN + inside = .FALSE. + pint(1:dim_num) = p1(1:dim_num) + RETURN +END IF +! +! Now, check that all three triangles made by two vertices and +! the intersection point have the same "clock sense" as the +! triangle's normal vector. +! +v1(1:dim_num) = t(1:dim_num, 2) - t(1:dim_num, 1) +v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 1) +! +normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) +normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) +normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) + +IF (DOT_PRODUCT(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) THEN + inside = .FALSE. + RETURN +END IF + +v1(1:dim_num) = t(1:dim_num, 3) - t(1:dim_num, 2) +v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 2) + +normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) +normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) +normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) + +IF (DOT_PRODUCT(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) THEN + inside = .FALSE. + RETURN +END IF + +v1(1:dim_num) = t(1:dim_num, 1) - t(1:dim_num, 3) +v2(1:dim_num) = pint(1:dim_num) - t(1:dim_num, 3) + +normal2(1) = v1(2) * v2(3) - v1(3) * v2(2) +normal2(2) = v1(3) * v2(1) - v1(1) * v2(3) +normal2(3) = v1(1) * v2(2) - v1(2) * v2(1) + +IF (DOT_PRODUCT(normal(1:dim_num), normal2(1:dim_num)) < 0.0D+00) THEN + inside = .FALSE. + RETURN +END IF + +inside = .TRUE. + +END PROCEDURE triangle_contains_line_exp_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_contains_line_par_3d +INTEGER(i4b), PARAMETER :: dim_num = 3 +REAL(dfp) :: a +REAL(dfp) :: angle_sum +REAL(dfp) :: b +REAL(dfp) :: c +REAL(dfp) :: d +REAL(dfp) :: denom +LOGICAL(lgt) :: intersect +REAL(dfp) :: norm +REAL(dfp) :: norm1 +REAL(dfp) :: norm2 +REAL(dfp), PARAMETER :: r8_pi = 3.141592653589793D+00 +REAL(dfp) :: t_int +REAL(dfp), PARAMETER :: tol = 0.00001D+00 +REAL(dfp) :: v1(dim_num) +REAL(dfp) :: v2(dim_num) +REAL(dfp) :: v3(dim_num) +! +! Determine the implicit form (A,B,C,D) of the plane containing the +! triangle. +! +a = (t(2, 2) - t(2, 1)) * (t(3, 3) - t(3, 1)) & + - (t(3, 2) - t(3, 1)) * (t(2, 3) - t(2, 1)) + +b = (t(3, 2) - t(3, 1)) * (t(1, 3) - t(1, 1)) & + - (t(1, 2) - t(1, 1)) * (t(3, 3) - t(3, 1)) + +c = (t(1, 2) - t(1, 1)) * (t(2, 3) - t(2, 1)) & + - (t(2, 2) - t(2, 1)) * (t(1, 3) - t(1, 1)) + +d = -t(1, 2) * a - t(2, 2) * b - t(3, 2) * c +! +! Make sure the plane is well-defined. +! +norm1 = SQRT(a * a + b * b + c * c) + +IF (norm1 == 0.0D+00) THEN + inside = .FALSE. + p(1:dim_num) = 0.0D+00 + RETURN +END IF +! +! Make sure the implicit line is well defined. +! +norm2 = SQRT(SUM(pd(1:dim_num)**2)) + +IF (norm2 == 0.0D+00) THEN + inside = .FALSE. + p(1:dim_num) = 0.0D+00 + RETURN +END IF +! +! Determine the denominator of the parameter in the +! implicit line definition that determines the intersection +! point. +! +denom = a * pd(1) + b * pd(2) + c * pd(3) +! +! If DENOM is zero, or very small, the line and the plane may be +! parallel or almost so. +! +IF (ABS(denom) < tol * norm1 * norm2) THEN +! +! The line may actually lie in the plane. We're not going +! to try to address this possibility. +! + IF (a * p0(1) + b * p0(2) + c * p0(3) + d == 0.0D+00) THEN + + intersect = .TRUE. + inside = .FALSE. + p(1:dim_num) = p0(1:dim_num) +! +! The line and plane are parallel and disjoint. +! + ELSE + + intersect = .FALSE. + inside = .FALSE. + p(1:dim_num) = 0.0D+00 + + END IF +! +! The line and plane intersect at a single point P. +! +ELSE + + intersect = .TRUE. + t_int = -(a * p0(1) + b * p0(2) + c * p0(3) + d) / denom + p(1:dim_num) = p0(1:dim_num) + t_int * pd(1:dim_num) +! +! To see if P is included in the triangle, sum the angles +! formed by P and pairs of the vertices. If the point is in the +! triangle, we get a total 360 degree view. Otherwise, we +! get less than 180 degrees. +! + v1(1:dim_num) = t(1:dim_num, 1) - p(1:dim_num) + v2(1:dim_num) = t(1:dim_num, 2) - p(1:dim_num) + v3(1:dim_num) = t(1:dim_num, 3) - p(1:dim_num) + + norm = SQRT(SUM(v1(1:dim_num)**2)) + + IF (norm == 0.0D+00) THEN + inside = .TRUE. + RETURN + END IF + + v1(1:dim_num) = v1(1:dim_num) / norm + + norm = SQRT(SUM(v2(1:dim_num)**2)) + + IF (norm == 0.0D+00) THEN + inside = .TRUE. + RETURN + END IF + + v2(1:dim_num) = v2(1:dim_num) / norm + + norm = SQRT(SUM(v3(1:dim_num)**2)) + + IF (norm == 0.0D+00) THEN + inside = .TRUE. + RETURN + END IF + + v3(1:dim_num) = v3(1:dim_num) / norm + + angle_sum = safe_acos(DOT_PRODUCT(v1(1:3), v2(1:3))) & + + safe_acos(DOT_PRODUCT(v2(1:3), v3(1:3))) & + + safe_acos(DOT_PRODUCT(v3(1:3), v1(1:3))) + + IF (NINT(angle_sum / r8_pi) == 2) THEN + inside = .TRUE. + ELSE + inside = .FALSE. + END IF + +END IF + +RETURN +END PROCEDURE triangle_contains_line_par_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_contains_point_2d_1 +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: xsi(dim_num + 1) +xsi = triangle_barycentric_2d(t, p) +IF (ANY(xsi(1:3) < 0.0D+00)) THEN + inside = .FALSE. +ELSE + inside = .TRUE. +END IF +END PROCEDURE triangle_contains_point_2d_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_contains_point_2d_2 +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b) :: j +INTEGER(i4b) :: k +DO j = 1, 3 + k = MOD(j, 3) + 1 + IF (0.0D+00 < (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & + - (p(2) - t(2, j)) * (t(1, k) - t(1, j))) THEN + inside = .FALSE. + RETURN + END IF +END DO +inside = .TRUE. +END PROCEDURE triangle_contains_point_2d_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_contains_point_2d_3 +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: dir_new +REAL(dfp) :: dir_old +INTEGER(i4b) :: j +INTEGER(i4b) :: k + +dir_old = 0.0D+00 + +DO j = 1, 3 + k = MOD(j, 3) + 1 + dir_new = (p(1) - t(1, j)) * (t(2, k) - t(2, j)) & + - (p(2) - t(2, j)) * (t(1, k) - t(1, j)) + IF (dir_new * dir_old < 0.0D+00) THEN + inside = .FALSE. + RETURN + END IF + IF (dir_new /= 0.0D+00) THEN + dir_old = dir_new + END IF +END DO +inside = .TRUE. +END PROCEDURE triangle_contains_point_2d_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_diameter_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: a +REAL(dfp) :: asq +REAL(dfp) :: b +REAL(dfp) :: bsq +REAL(dfp) :: c +REAL(dfp) :: csq +! +! Compute the squared length of each side. +! +asq = SUM(t(1:dim_num, 1) - t(1:dim_num, 2))**2 +bsq = SUM(t(1:dim_num, 2) - t(1:dim_num, 3))**2 +csq = SUM(t(1:dim_num, 3) - t(1:dim_num, 1))**2 +! +! Take care of a zero side. +! +IF (asq == 0.0D+00) THEN + diameter = SQRT(bsq) + RETURN +ELSE IF (bsq == 0.0D+00) THEN + diameter = SQRT(csq) + RETURN +ELSE IF (csq == 0.0D+00) THEN + diameter = SQRT(asq) + RETURN +END IF +! +! Make ASQ the largest. +! +IF (asq < bsq) THEN + CALL swap(asq, bsq) +END IF + +IF (asq < csq) THEN + CALL swap(asq, csq) +END IF +! +! If ASQ is very large... +! +IF (bsq + csq < asq) THEN + diameter = SQRT(asq) +ELSE + a = SQRT(asq) + b = SQRT(bsq) + c = SQRT(csq) + diameter = 2.0D+00 * a * b * c / SQRT((a + b + c) * (-a + b + c) & + * (a - b + c) * (a + b - c)) +END IF +END PROCEDURE triangle_diameter_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_edge_length_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b) :: j1, j2 +DO j1 = 1, 3 + j2 = i4_wrap(j1 + 1, 1, 3) + edge_length(j1) = NORM2(t(1:dim_num, j2) - t(1:dim_num, j1)) +END DO +END PROCEDURE triangle_edge_length_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_gridpoints_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b) :: i +INTEGER(i4b) :: j +! +grid_num = 0 +! +! Special case, SUB_NUM = 0. +! +IF (sub_num == 0) THEN + IF (1 <= grid_max) THEN + grid_num = 1 + g(1, 1) = (t(1, 1) + t(1, 2) + t(1, 3)) / 3.0D+00 + g(2, 1) = (t(2, 1) + t(2, 2) + t(2, 3)) / 3.0D+00 + END IF + RETURN +END IF +! +DO i = 0, sub_num + DO j = 0, sub_num - i + IF (grid_num < grid_max) THEN + grid_num = grid_num + 1 + g(1, grid_num) = (REAL(i, kind=8) * t(1, 1) & + & + REAL(j, kind=8) * t(1, 2) & + & + REAL(sub_num - i - j, kind=8) * t(1, 3)) & + & / REAL(sub_num, kind=8) + ! + g(2, grid_num) = (REAL(i, kind=8) * t(2, 1) & + & + REAL(j, kind=8) * t(2, 2) & + & + REAL(sub_num - i - j, kind=8) * t(2, 3)) & + & / REAL(sub_num, kind=8) + END IF + END DO +END DO +! +END PROCEDURE triangle_gridpoints_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_incenter_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: a +REAL(dfp) :: b +REAL(dfp) :: c +REAL(dfp) :: perimeter +! +! Compute the length of each side. +! +a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) +b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) +c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + +perimeter = a + b + c + +IF (perimeter == 0.0D+00) THEN + pc(1:dim_num) = t(1:dim_num, 1) +ELSE + pc(1:dim_num) = (b * t(1:dim_num, 1) & + + c * t(1:dim_num, 2) & + + a * t(1:dim_num, 3)) / perimeter +END IF +END PROCEDURE triangle_incenter_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_incircle_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: a +REAL(dfp) :: b +REAL(dfp) :: c +REAL(dfp) :: perimeter +! +! Compute the length of each side. +! +a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) +b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) +c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + +perimeter = a + b + c + +IF (perimeter == 0.0D+00) THEN + pc(1:dim_num) = t(1:dim_num, 1) + r = 0.0D+00 + RETURN +END IF + +pc(1:dim_num) = ( & + b * t(1:dim_num, 1) & + + c * t(1:dim_num, 2) & + + a * t(1:dim_num, 3)) / perimeter + +r = 0.5D+00 * SQRT( & + (-a + b + c) & + * (+a - b + c) & + * (+a + b - c) / perimeter) +END PROCEDURE triangle_incircle_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_inradius_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) :: a +REAL(dfp) :: b +REAL(dfp) :: c +REAL(dfp) :: perimeter +! +! Compute the length of each side. +! +a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) +b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) +c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) + +perimeter = a + b + c + +IF (perimeter == 0.0D+00) THEN + r = 0.0D+00 + RETURN +END IF + +r = 0.5D+00 * SQRT( & + (-a + b + c) & + * (+a - b + c) & + * (+a + b - c) / perimeter) +END PROCEDURE triangle_inradius_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_is_degenerate_nd +ans = & + & (ALL(t(1:dim_num, 1) == t(1:dim_num, 2)) .OR. & + & ALL(t(1:dim_num, 2) == t(1:dim_num, 3)) .OR. & + & ALL(t(1:dim_num, 3) == t(1:dim_num, 1))) +END PROCEDURE triangle_is_degenerate_nd + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_lattice_layer_point_next +INTEGER(i4b) :: c1n +INTEGER(i4b), PARAMETER :: n = 2 +INTEGER(i4b) :: rhs1 +INTEGER(i4b) :: rhs2 +! +! Treat layer C(N+1) = 0 specially. +! +IF (c(n + 1) == 0) THEN + IF (.NOT. more) THEN + v(1:n) = 0 + more = .TRUE. + ELSE + more = .FALSE. + END IF + RETURN +END IF +! +! Compute first point. +! +IF (.NOT. more) THEN + v(1) = (c(n + 1) - 1) * c(1) + 1 + v(2) = 0 + more = .TRUE. +ELSE + c1n = i4vec_lcm(n, c) + rhs1 = c1n * (c(n + 1) - 1) + rhs2 = c1n * c(n + 1) + IF (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs2) THEN + v(1) = v(1) + 1 + ELSE + v(1) = (rhs1 - c(1) * (v(2) + 1)) / c(2) + v(1) = MAX(v(1), 0) + v(2) = v(2) + 1 + IF (c(2) * v(1) + c(1) * v(2) <= rhs1) THEN + v(1) = v(1) + 1 + END IF + IF (c(2) * v(1) + c(1) * v(2) <= rhs2) THEN + ELSE + v(1:n) = 0 + more = .FALSE. + END IF + END IF +END IF +END PROCEDURE triangle_lattice_layer_point_next + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_lattice_point_next +INTEGER(i4b) c1n +INTEGER(i4b), PARAMETER :: n = 2 +INTEGER(i4b) rhs + +IF (.NOT. more) THEN + + v(1:n) = 0 + more = .TRUE. + +ELSE + + c1n = i4vec_lcm(n, c) + + rhs = c1n * c(n + 1) + + IF (c(2) * (v(1) + 1) + c(1) * v(2) <= rhs) THEN + v(1) = v(1) + 1 + ELSE + v(1) = 0 + IF (c(2) * v(1) + c(1) * (v(2) + 1) <= rhs) THEN + v(2) = v(2) + 1 + ELSE + v(2) = 0 + more = .FALSE. + END IF + END IF +END IF +END PROCEDURE triangle_lattice_point_next + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_line_imp_int_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) a1 +REAL(dfp) b1 +REAL(dfp) c1 +INTEGER(i4b) i +INTEGER(i4b) ival +INTEGER(i4b) j +REAL(dfp) p(dim_num) +REAL(dfp) test1 +REAL(dfp) test2 + +int_num = 0 + +DO i = 1, 3 + j = i4_wrap(i + 1, 1, 3) + ! + ! Get the implicit form of the line through vertices I and I+1. + ! + CALL line_exp2imp_2d(t(1:2, i), t(1:2, j), a1, b1, c1) + ! + ! Seek an intersection with the original line. + ! + CALL lines_imp_int_2d(a, b, c, a1, b1, c1, ival, p) + ! + ! If there is an intersection, determine if it + ! lies between the two vertices. + ! + IF (ival == 1) THEN + test1 = SUM((p(1:dim_num) - t(1:dim_num, i)) & + * (t(1:dim_num, j) - t(1:dim_num, i))) + test2 = SUM((t(1:dim_num, j) - t(1:dim_num, i)) & + * (t(1:dim_num, j) - t(1:dim_num, i))) + ! + IF (0 <= test1 .AND. test1 <= test2) THEN + int_num = int_num + 1 + pint(1:dim_num, int_num) = p(1:dim_num) + END IF + END IF +END DO + +END PROCEDURE triangle_line_imp_int_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_orientation_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) avar + +IF (ALL(t(1:dim_num, 1) == t(1:dim_num, 2)) .OR. & + ALL(t(1:dim_num, 2) == t(1:dim_num, 3)) .OR. & + ALL(t(1:dim_num, 3) == t(1:dim_num, 1))) THEN + ans = 3 + RETURN +END IF + +avar = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & + & - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) + +IF (avar == 0.0D+00) THEN + ans = 2 +ELSE IF (avar < 0.0D+00) THEN + ans = 1 +ELSE IF (0.0D+00 < avar) THEN + ans = 0 +END IF + +END PROCEDURE triangle_orientation_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_orthocenter_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +LOGICAL(lgt) flag +INTEGER(i4b) ival +REAL(dfp) p23(dim_num) +REAL(dfp) p31(dim_num) +! +! Determine a point P23 common to the line (P2,P3) and +! its perpendicular through P1. +! +CALL line_exp_perp_2d(t(1:2, 2), t(1:2, 3), t(1:2, 1), p23, flag) + +IF (flag) THEN + pc(1:2) = r8_huge() + RETURN +END IF +! +! Determine a point P31 common to the line (P3,P1) and +! its perpendicular through P2. +! +CALL line_exp_perp_2d(t(1:2, 3), t(1:2, 1), t(1:2, 2), p31, flag) + +IF (flag) THEN + pc(1:2) = r8_huge() + RETURN +END IF +! +! Determine PC, the intersection of the lines (P1,P23) and (P2,P31). +! +CALL lines_exp_int_2d(t(1:2, 1), p23(1:2), t(1:2, 2), p31(1:2), ival, pc) + +IF (ival /= 1) THEN + pc(1:2) = r8_huge() + flag = .TRUE. + RETURN +END IF + +RETURN +END PROCEDURE triangle_orthocenter_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_point_dist_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b), PARAMETER :: side_num = 3 +REAL(dfp) dist2 +INTEGER(i4b) j +INTEGER(i4b) jp1 +! +! Find the distance to each of the line segments. +! +dist = HUGE(dist) +! +DO j = 1, side_num + jp1 = i4_wrap(j + 1, 1, side_num) + dist2 = segment_point_dist_2d(t(1:dim_num, j), t(1:dim_num, jp1), p) + IF (dist2 < dist) THEN + dist = dist2 + END IF +END DO +END PROCEDURE triangle_point_dist_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_point_dist_3d +INTEGER(i4b), PARAMETER :: dim_num = 3 +REAL(dfp) dist2 +! +! Compute the distances from the point to each of the sides. +! +dist2 = segment_point_dist_3d(t(1:dim_num, 1), t(1:dim_num, 2), p) +dist = dist2 +dist2 = segment_point_dist_3d(t(1:dim_num, 2), t(1:dim_num, 3), p) +dist = MIN(dist, dist2) +dist2 = segment_point_dist_3d(t(1:dim_num, 3), t(1:dim_num, 1), p) +dist = MIN(dist, dist2) +END PROCEDURE triangle_point_dist_3d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_point_dist_signed_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) dis12 +REAL(dfp) dis23 +REAL(dfp) dis31 +! +! Compute the signed line distances to the point. +! +dis12 = line_exp_point_dist_signed_2d(t(1:2, 1), t(1:2, 2), p) +dis23 = line_exp_point_dist_signed_2d(t(1:2, 2), t(1:2, 3), p) +dis31 = line_exp_point_dist_signed_2d(t(1:2, 3), t(1:2, 1), p) +! +! If the point is inside the triangle, all the line distances are negative. +! The largest (negative) line distance has the smallest magnitude, +! and is the signed triangle distance. +! +IF (dis12 <= 0.0D+00 .AND. dis23 <= 0.0D+00 .AND. dis31 <= 0.0D+00) THEN + dist_signed = MAX(dis12, dis23, dis31) +! +! If the point is outside the triangle, then we have to compute +! the (positive) line segment distances and take the minimum. +! +ELSE + dis12 = segment_point_dist_2d(t(1:2, 1), t(1:2, 2), p) + dis23 = segment_point_dist_2d(t(1:2, 2), t(1:2, 3), p) + dis31 = segment_point_dist_2d(t(1:2, 3), t(1:2, 1), p) + dist_signed = MIN(dis12, dis23, dis31) +END IF +! +END PROCEDURE triangle_point_dist_signed_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_point_near_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +INTEGER(i4b), PARAMETER :: side_num = 3 +INTEGER(i4b) j +INTEGER(i4b) jp1 +REAL(dfp) dist2 +REAL(dfp) pn2(dim_num) +REAL(dfp) tval +! +! Find the distance to each of the line segments that make up the edges +! of the triangle. +! +dist = HUGE(dist) +pn(1:dim_num) = 0.0D+00 +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) + IF (dist2 < dist) THEN + dist = dist2 + pn(1:dim_num) = pn2(1:dim_num) + END IF +END DO +END PROCEDURE triangle_point_near_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_quality_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) a +REAL(dfp) b +REAL(dfp) c +! +! Compute the length of each side. +! +a = SQRT(SUM((t(1:dim_num, 1) - t(1:dim_num, 2))**2)) +b = SQRT(SUM((t(1:dim_num, 2) - t(1:dim_num, 3))**2)) +c = SQRT(SUM((t(1:dim_num, 3) - t(1:dim_num, 1))**2)) +IF (a * b * c == 0.0D+00) THEN + quality = 0.0D+00 +ELSE + quality = (-a + b + c) * (a - b + c) * (a + b - c) & + / (a * b * c) +END IF +END PROCEDURE triangle_quality_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_right_lattice_point_num_2d +n = ((a + 1) * (b + 1) + i4_gcd(a, b) + 1) / 2 +END PROCEDURE triangle_right_lattice_point_num_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_sample +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) alpha(n) +INTEGER(i4b) dim +REAL(dfp) p12(dim_num, n) +REAL(dfp) p13(dim_num, n) +! +alpha = rvec_uniform_01(n, seed) +! +! Interpret R as a percentage of the triangle's area. +! +! Imagine a line L, parallel to side 1, so that the area between +! vertex 1 and line L is R percent of the full triangle's area. +! +! The line L will intersect sides 2 and 3 at a fraction +! ALPHA = SQRT ( R ) of the distance from vertex 1 to vertices 2 and 3. +! +alpha(1:n) = SQRT(alpha(1:n)) +! +! Determine the coordinates of the points on sides 2 and 3 intersected +! by line L. +! +DO dim = 1, dim_num + p12(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & + + alpha(1:n) * t(dim, 2) + + p13(dim, 1:n) = (1.0D+00 - alpha(1:n)) * t(dim, 1) & + + alpha(1:n) * t(dim, 3) +END DO +! +! Now choose, uniformly at random, a point on the line L. +! +alpha = rvec_uniform_01(n, seed) + +DO dim = 1, dim_num + p(dim, 1:n) = (1.0D+00 - alpha(1:n)) * p12(dim, 1:n) & + + alpha(1:n) * p13(dim, 1:n) +END DO + +END PROCEDURE triangle_sample + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle01_lattice_point_num_2d +n = ((s + 2) * (s + 1)) / 2 +END PROCEDURE triangle01_lattice_point_num_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_xsi_to_xy_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +p(1:dim_num) = MATMUL(t(1:dim_num, 1:3), xsi(1:dim_num + 1)) +END PROCEDURE triangle_xsi_to_xy_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE triangle_xy_to_xsi_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +REAL(kind=8) avar +avar = (t(1, 1) - t(1, 3)) * (t(2, 2) - t(2, 3)) & + - (t(1, 2) - t(1, 3)) * (t(2, 1) - t(2, 3)) +xsi(1) = ((t(2, 2) - t(2, 3)) * (p(1) - t(1, 3)) & + - (t(1, 2) - t(1, 3)) * (p(2) - t(2, 3))) / avar + +xsi(2) = (-(t(2, 1) - t(2, 3)) * (p(1) - t(1, 3)) & + + (t(1, 1) - t(1, 3)) * (p(2) - t(2, 3))) / avar + +xsi(3) = 1.0D+00 - xsi(1) - xsi(2) +END PROCEDURE triangle_xy_to_xsi_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#include "./inc/aux.inc" + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/inc/aux.inc b/src/submodules/Geometry/src/inc/aux.inc new file mode 100644 index 000000000..fe70e9a64 --- /dev/null +++ b/src/submodules/Geometry/src/inc/aux.inc @@ -0,0 +1,239 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 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/Geometry/src/modified_burkardt.inc b/src/submodules/Geometry/src/modified_burkardt.inc new file mode 100644 index 000000000..8ad0e2dc3 --- /dev/null +++ b/src/submodules/Geometry/src/modified_burkardt.inc @@ -0,0 +1,266 @@ + +!----------------------------------------------------------------------------- +! +!----------------------------------------------------------------------------- + +PURE FUNCTION R8MATDET4D(a) + !. . . . . . . . . . . . . . . . . . . + !! R8MATDET4D computes the determinant of a 4 by 4 matrix. + ! + ! Licensing: + ! This code is distributed under the GNU LGPL license. + ! Modified: + ! 16 April 1999 + ! Author: + ! John Burkardt + ! Parameters: + ! Input, real ( kind = 8 ) A(4,4), the matrix whose determinant is desired. + ! Output, real ( kind = 8 ) R8MATDET4D, the determinant of the matrix. + !. . . . . . . . . . . . . . . . . . . + + REAL(DFP), INTENT(IN) :: a(4, 4) + REAL(DFP) :: R8MATDET4D + + R8MATDET4D = & + a(1, 1) * ( & + a(2, 2) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & + - a(2, 3) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & + + a(2, 4) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2))) & + - a(1, 2) * ( & + a(2, 1) * (a(3, 3) * a(4, 4) - a(3, 4) * a(4, 3)) & + - a(2, 3) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & + + a(2, 4) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1))) & + + a(1, 3) * ( & + a(2, 1) * (a(3, 2) * a(4, 4) - a(3, 4) * a(4, 2)) & + - a(2, 2) * (a(3, 1) * a(4, 4) - a(3, 4) * a(4, 1)) & + + a(2, 4) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) & + - a(1, 4) * ( & + a(2, 1) * (a(3, 2) * a(4, 3) - a(3, 3) * a(4, 2)) & + - a(2, 2) * (a(3, 1) * a(4, 3) - a(3, 3) * a(4, 1)) & + + a(2, 3) * (a(3, 1) * a(4, 2) - a(3, 2) * a(4, 1))) + +END FUNCTION R8MATDET4D + +!----------------------------------------------------------------------------- +! +!----------------------------------------------------------------------------- + +PURE SUBROUTINE PARALLELOGRAMAREA3D(p, area) + + !. . . . . . . . . . . . . . . . . . . + !! PARALLELOGRAMAREA3D computes the area of a parallelogram in 3D. + ! + ! Discussion: + ! A parallelogram is a polygon having four sides, with the property + ! that each pair of opposite sides is paralell. + ! A parallelogram in 3D must have the property that it is "really" + ! a 2D object, that is, that the four vertices that define it lie + ! in some plane. + ! Given the first three vertices of the parallelogram (in 2D or 3D), + ! P1, P2, and P3, the fourth vertex must satisfy + ! P4 = P1 + ( P3 - P2 ) + ! This routine uses the fact that the norm of the cross product + ! of two vectors is the area of the parallelogram they form: + ! Area = ( P3 - P2 ) x ( P1 - P2 ). + ! + ! P4<-----P3 + ! / / + ! / / + ! P1----->P2 + ! + ! Licensing: + ! This code is distributed under the GNU LGPL license. + ! Modified: + ! 09 May 2010 + ! Author: + ! John Burkardt + ! Parameters: + ! Input, real ( kind = 8 ) P(3,4), the parallelogram vertices, + ! given in counterclockwise order. The fourth vertex is ignored. + ! Output, real ( kind = 8 ) AREA, the area + !. . . . . . . . . . . . . . . . . . . + + REAL(DFP), INTENT(IN) :: p(3, 4) + REAL(DFP), INTENT(OUT) :: area + REAL(DFP) :: cross(3) + + ! Compute the cross product vector. + + cross(1) = (p(2, 2) - p(2, 1)) * (p(3, 3) - p(3, 1)) & + - (p(3, 2) - p(3, 1)) * (p(2, 3) - p(2, 1)) + + cross(2) = (p(3, 2) - p(3, 1)) * (p(1, 3) - p(1, 1)) & + - (p(1, 2) - p(1, 1)) * (p(3, 3) - p(3, 1)) + + cross(3) = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & + - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) + + area = SQRT(SUM(cross(1:3)**2)) + +END SUBROUTINE PARALLELOGRAMAREA3D + +!----------------------------------------------------------------------------- +! +!----------------------------------------------------------------------------- + +PURE SUBROUTINE PARALLELOGRAMAREA2D(p, area) + + !. . . . . . . . . . . . . . . . . . . + ! + !! PARALLELOGRAMAREA2D computes the area of a parallelogram in 2D. + ! + ! Discussion: + ! A parallelogram is a polygon having four sides, with the property + ! that each pair of opposite sides is paralell. + ! Given the first three vertices of the parallelogram, + ! P1, P2, and P3, the fourth vertex must satisfy + ! + ! P4 = P1 + ( P3 - P2 ) + ! + ! This routine uses the fact that the norm of the cross product + ! of two vectors is the area of the parallelogram they form: + ! + ! Area = ( P3 - P2 ) x ( P1 - P2 ). + ! + ! P4<-----P3 + ! / / + ! / / + ! P1----->P2 + ! + ! Licensing: + ! This code is distributed under the GNU LGPL license. + ! Modified: + ! 09 May 2010 + ! Author: + ! John Burkardt + ! Parameters: + ! Input, real ( kind = 8 ) P(2,4), the parallelogram vertices, + ! given in counterclockwise order. The fourth vertex is ignored. + ! Output, real ( kind = 8 ) AREA, the (signed) area. + !. . . . . . . . . . . . . . . . . . . + + REAL(DFP), INTENT(IN) :: p(2, 4) + REAL(DFP), INTENT(OUT) :: area + + ! Compute the cross product vector, which only has a single + ! nonzero component. + + area = (p(1, 2) - p(1, 1)) * (p(2, 3) - p(2, 1)) & + - (p(2, 2) - p(2, 1)) * (p(1, 3) - p(1, 1)) + +END SUBROUTINE PARALLELOGRAMAREA2D + +!----------------------------------------------------------------------------- +! +!----------------------------------------------------------------------------- + +PURE SUBROUTINE TETRAHEDRONVOLUME3D(tetra, volume) + + !. . . . . . . . . . . . . . . . . . . + ! + !! TETRAHEDRONVOLUME3D computes the volume of a tetrahedron in 3D. + ! + ! Licensing: + ! This code is distributed under the GNU LGPL license. + ! Modified: + ! 30 December 2004 + ! Author: + ! John Burkardt + ! Parameters: + ! Input, real ( kind = 8 ) TETRA(3,4), the vertices of the tetrahedron. + ! Output, real ( kind = 8 ) VOLUME, the volume of the tetrahedron. + !. . . . . . . . . . . . . . . . . . . + + REAL(DFP), INTENT(IN) :: tetra(3, 4) + REAL(DFP), INTENT(OUT) :: volume + + INTEGER(I4B), PARAMETER :: dim_num = 3 + REAL(DFP) :: a(4, 4) + + a(1:dim_num, 1:4) = tetra(1:dim_num, 1:4) + a(4, 1:4) = 1.0_DFP + + volume = ABS(R8MATDET4D(a)) / 6.0_DFP + +END SUBROUTINE TETRAHEDRONVOLUME3D + +!----------------------------------------------------------------------------- +! +!----------------------------------------------------------------------------- + +PURE SUBROUTINE POLYHEDRONVOLUME3D(coord, order_max, face_num, node, & + & node_num, order, volume) + + !. . . . . . . . . . . . . . . . . . . + ! + !! POLYHEDRONVOLUME3D computes the volume of a polyhedron in 3D. + ! + ! Licensing: + ! This code is distributed under the GNU LGPL license. + ! Modified: + ! 19 August 2003 + ! Author: + ! John Burkardt + ! Parameters: + ! + ! Input, real ( kind = 8 ) COORD(3,NODE_NUM), the coordinates of + ! the vertices. The vertices may be listed in any order. + ! + ! Input, integer ( kind = 4 ) ORDER_MAX, the maximum number of vertices + ! that make up a face of the polyhedron. + ! + ! Input, integer ( kind = 4 ) FACE_NUM, the number of faces of the + ! polyhedron. + ! + ! Input, integer ( kind = 4 ) NODE(FACE_NUM,ORDER_MAX). Face I is + ! defined by + ! the vertices NODE(I,1) through NODE(I,ORDER(I)). These vertices + ! are listed in neighboring order. + ! + ! Input, integer ( kind = 4 ) NODE_NUM, the number of points stored in + ! COORD. + ! + ! Input, integer ( kind = 4 ) ORDER(FACE_NUM), the number of vertices + ! making + ! up each face. + ! + ! Output, real ( kind = 8 ) VOLUME, the volume of the polyhedron. + !. . . . . . . . . . . . . . . . . . . + + INTEGER(I4B), INTENT(IN) :: order_max + INTEGER(I4B), INTENT(IN) :: face_num + INTEGER(I4B), INTENT(IN) :: node(face_num, order_max) + INTEGER(I4B), INTENT(IN) :: node_num + REAL(DFP), INTENT(IN) :: coord(3, node_num) + INTEGER(I4B), INTENT(IN) :: order(face_num) + REAL(DFP), INTENT(OUT) :: volume + + INTEGER(I4B), PARAMETER :: dim_num = 3 + INTEGER(I4B) :: face + INTEGER(I4B) :: n1 + INTEGER(I4B) :: n2 + INTEGER(I4B) :: n3 + INTEGER(I4B) :: v + volume = 0.0_DFP + + ! Triangulate each face. + DO face = 1, face_num + + n3 = node(face, order(face)) + + DO v = 1, order(face) - 2 + n1 = node(face, v) + n2 = node(face, v + 1) + volume = volume & + + coord(1, n1) & + * (coord(2, n2) * coord(3, n3) - coord(2, n3) * coord(3, n2)) & + + coord(1, n2) & + * (coord(2, n3) * coord(3, n1) - coord(2, n1) * coord(3, n3)) & + + coord(1, n3) & + * (coord(2, n1) * coord(3, n2) - coord(2, n2) * coord(3, n1)) + END DO + END DO + + volume = volume / 6.0_DFP + +END SUBROUTINE POLYHEDRONVOLUME3D diff --git a/src/submodules/Hashing/CMakeLists.txt b/src/submodules/Hashing/CMakeLists.txt new file mode 100644 index 000000000..450d3aebb --- /dev/null +++ b/src/submodules/Hashing/CMakeLists.txt @@ -0,0 +1,24 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/Hashing32@fnvMethods.F90 + ${src_path}/Hashing32@nmMethods.F90 + ${src_path}/Hashing32@waterMethods.F90 +) diff --git a/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 b/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 new file mode 100644 index 000000000..ae673e061 --- /dev/null +++ b/src/submodules/Hashing/src/Hashing32@fnvMethods.F90 @@ -0,0 +1,121 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +! `FNV_1_HASH` and `FNV_1A_Hash` are translations to Fortran 2008 of the +! `FNV-1` and `FNV-1a` hash functions of Glenn Fowler, Landon Curt Noll, +! and Phong Vo, that has been released into the public domain. Permission +! has been granted, by Landon Curt Noll, for the use of these algorithms +! in the Fortran Standard Library. A description of these functions is +! available at https://en.wikipedia.org/wiki/Fowler–Noll–Vo_hash_function. + +SUBMODULE(Hashing32) fnvMethods +IMPLICIT NONE +INTEGER(INT_HASH), PARAMETER :: OFFSET_BASIS = INT(z'811C9DC5', INT_HASH) +INTEGER(INT_HASH), PARAMETER :: PRIME = INT(z'01000193', INT_HASH) +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int8_fnv_1 + INTEGER(Int64) :: ii + !! + ans = OFFSET_BASIS + !! + DO ii = 1_int64, SIZE(key, kind=int64) + ans = ans * prime + IF (little_endian) THEN + ans = IEOR(ans, & + TRANSFER([key(ii), 0_int8, 0_int8, 0_int8], & + & 0_int_hash)) + ELSE + ans = IEOR(ans, & + TRANSFER([0_int8, 0_int8, 0_int8, key(ii)], & + & 0_int_hash)) + END IF + END DO +END PROCEDURE Int8_fnv_1 + +MODULE PROCEDURE Int16_fnv_1 + ans = Int8_fnv_1(TRANSFER(key, 0_int8, & + & BYTES_INT16 * SIZE(key, kind=Int64))) +END PROCEDURE Int16_fnv_1 + +MODULE PROCEDURE Int32_fnv_1 + ans = Int8_fnv_1(TRANSFER(key, 0_int8, & + & BYTES_INT32 * SIZE(key, kind=Int64))) +END PROCEDURE Int32_fnv_1 + +MODULE PROCEDURE Int64_fnv_1 + ans = Int8_fnv_1(TRANSFER(key, 0_int8, & + & BYTES_INT64 * SIZE(key, kind=Int64))) +END PROCEDURE Int64_fnv_1 + +MODULE PROCEDURE Char_fnv_1 + ans = Int8_fnv_1(TRANSFER(key, 0_int8, & + & BYTES_CHAR * LEN(key, kind=Int64))) +END PROCEDURE Char_fnv_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int8_fnv_1a + INTEGER( Int64 ) :: ii + !! + ans = OFFSET_BASIS + !! + DO ii = 1_Int64, SIZE(key, kind=int64) + IF(little_endian) THEN + ans = IEOR(ans, TRANSFER([key(ii), 0_Int8, 0_Int8, 0_Int8], & + & 0_Int_hash)) + ELSE + ans = IEOR(ans, & + & TRANSFER([0_Int8, 0_Int8, 0_Int8, key(ii)], & + & 0_int_hash)) + END IF + ans = ans * prime + END DO + !! +END PROCEDURE Int8_fnv_1a + +MODULE PROCEDURE Int16_fnv_1a + ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & + & BYTES_INT16 * SIZE(key, kind=Int64))) +END PROCEDURE Int16_fnv_1a + +MODULE PROCEDURE Int32_fnv_1a + ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & + & BYTES_INT32 * SIZE(key, kind=Int64))) +END PROCEDURE Int32_fnv_1a + +MODULE PROCEDURE Int64_fnv_1a + ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & + & BYTES_INT64 * SIZE(key, kind=Int64))) +END PROCEDURE Int64_fnv_1a + +MODULE PROCEDURE Char_fnv_1a + ans = Int8_fnv_1a(TRANSFER(key, 0_Int8, & + & BYTES_CHAR * LEN(key, kind=Int64))) +END PROCEDURE Char_fnv_1a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE fnvMethods diff --git a/src/submodules/Hashing/src/Hashing32@nmMethods.F90 b/src/submodules/Hashing/src/Hashing32@nmMethods.F90 new file mode 100644 index 000000000..b38b41a70 --- /dev/null +++ b/src/submodules/Hashing/src/Hashing32@nmMethods.F90 @@ -0,0 +1,903 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 July 2021 +! summary: +! +!# Introduction +! +! Reference: https://github.com/fortran-lang/stdlib/tree/master/src +! +! `NM_HASH32` and `NM_HASH32X` are translations to Fortran 2008 and signed +! two's complement arithmetic of the `nmhash32` and `nmhash32x` scalar +! algorithms of James Z. M. Gao, copyright 2021. James Z. M. Gao's original +! C++ code, `nmhash.h`, is available at the URL: +! https://github.com/gzm55/hash-garage/blob/ +! a8913138bdb3b7539c202edee30a7f0794bbd835/nmhash.h +! +! under the BSD 2-Clause License: +! +! https://github.com/gzm55/hash-garage/blob/ +! a8913138bdb3b7539c202edee30a7f0794bbd835/LICENSE +! +! The algorithms come in multiple versions, depending on whether the +! vectorized instructions SSE2 or AVX2 are available. As neither instruction +! is available in portable Fortran 2008, the algorithms that do not use these +! instructions are used. +! +! The BSD 2-Clause license is as follows: +! +! BSD 2-Clause License +! +! Copyright (c) 2021, water hash algorithm. James Z.M. Gao +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. + +SUBMODULE(Hashing32) nmMethods +IMPLICIT NONE +! Primes from XXH +INTEGER(INT32), PARAMETER :: nmh_prime32_1 = INT(Z'9E3779B1', INT32) +INTEGER(INT32), PARAMETER :: nmh_prime32_2 = INT(Z'85EBCA77', INT32) +INTEGER(INT32), PARAMETER :: nmh_prime32_3 = INT(Z'C2B2AE3D', INT32) +INTEGER(INT32), PARAMETER :: nmh_prime32_4 = INT(Z'27D4EB2F', INT32) +INTEGER(INT32), PARAMETER :: nmh_m1 = INT(z'F0D9649B', INT32) +INTEGER(INT32), PARAMETER :: nmh_m2 = INT(z'29A7935D', INT32) +INTEGER(INT32), PARAMETER :: nmh_m3 = INT(z'55D35831', INT32) +INTEGER(INT32), PARAMETER :: nmh_m1_v(0:31) = nmh_m1 +INTEGER(INT32), PARAMETER :: nmh_m2_v(0:31) = nmh_m2 +INTEGER(INT32), PARAMETER :: nmh_m3_v(0:31) = nmh_m3 +LOGICAL(LGT), PARAMETER :: nmh_short32_without_seed2 = .FALSE. +LOGICAL(LGT), PARAMETER :: nmh_short32_with_seed2 = .TRUE. +INTEGER(INT32), PARAMETER :: init_size = 32 +! Pseudorandom secrets taken directly from FARSH. +INTEGER(INT32), PARAMETER :: nmh_acc_init(0:init_size - 1) = [ & + & INT(z'B8FE6C39', INT32), INT(z'23A44BBE', INT32), & + & INT(z'7C01812C', INT32), INT(z'F721AD1C', INT32), & + & INT(z'DED46DE9', INT32), INT(z'839097DB', INT32), & + & INT(z'7240A4A4', INT32), INT(z'B7B3671F', INT32), & + & INT(z'CB79E64E', INT32), INT(z'CCC0E578', INT32), & + & INT(z'825AD07D', INT32), INT(z'CCFF7221', INT32), & + & INT(z'B8084674', INT32), INT(z'F743248E', INT32), & + & INT(z'E03590E6', INT32), INT(z'813A264C', INT32), & + & INT(z'3C2852BB', INT32), INT(z'91C300CB', INT32), & + & INT(z'88D0658B', INT32), INT(z'1B532EA3', INT32), & + & INT(z'71644897', INT32), INT(z'A20DF94E', INT32), & + & INT(z'3819EF46', INT32), INT(z'A9DEACD8', INT32), & + & INT(z'A8FA763F', INT32), INT(z'E39C343F', INT32), & + & INT(z'F9DCBBC7', INT32), INT(z'C70B4F1D', INT32), & + & INT(z'8A51E04B', INT32), INT(z'CDB45931', INT32), & + & INT(z'C89F7EC9', INT32), INT(z'D9787364', INT32)] + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int8_nmhash32x +INTEGER(INT64) :: len +INTEGER(INT32) :: seed2 +INTEGER(INT32) :: u32 +INTEGER(INT16) :: u16(0:1) + +len = SIZE(key, kind=INT64) +IF (len <= 8) THEN + IF (len > 4) THEN + ans = nmhash32x_5to8(key, seed) + RETURN + ELSE ! 0 to 4 bytes + SELECT CASE (len) + CASE (0) + seed2 = seed + nmh_prime32_2 + u32 = 0 + CASE (1) + seed2 = seed + nmh_prime32_2 + ISHFT(1_INT32, 24) + & + ISHFT(1_INT32, 1) + IF (little_endian) THEN + u32 = TRANSFER([key(0), 0_INT8, 0_INT8, 0_INT8], & + & 0_INT32) + ELSE + u32 = TRANSFER([0_INT8, 0_INT8, 0_INT8, key(0)], & + & 0_INT32) + END IF + CASE (2) + seed2 = seed + nmh_prime32_2 + ISHFT(2_INT32, 24) + & + ISHFT(2_INT32, 1) + IF (little_endian) THEN + u32 = TRANSFER([nmh_readle16(key), 0_INT16], 0_INT32) + ELSE + u32 = TRANSFER([0_INT16, nmh_readle16(key)], 0_INT32) + END IF + CASE (3) + seed2 = seed + nmh_prime32_2 + ISHFT(3_INT32, 24) + & + ISHFT(3_INT32, 1) + IF (little_endian) THEN + u16(1) = TRANSFER([key(2), 0_INT8], 0_INT16) + u16(0) = nmh_readle16(key) + ELSE + u16(0) = TRANSFER([0_INT8, key(2)], 0_INT16) + u16(1) = nmh_readle16(key) + END IF + u32 = TRANSFER(u16, 0_INT32) + CASE (4) + seed2 = seed + nmh_prime32_1 + u32 = nmh_readle32(key) + CASE default + ans = 0 + RETURN + END SELECT + ans = nmhash32x_0to4(u32, seed2) + RETURN + END IF +END IF +IF (len < 256) THEN + ans = nmhash32x_9to255(key, seed) + RETURN +END IF +ans = nmhash32x_avalanche32(nmhash32_long(key, seed)) +END PROCEDURE Int8_nmhash32x + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int8_nmhash32 + !! NMHASH32 ans function for rank 1 array keys of kind INT8 +INTEGER(INT64) :: len +INTEGER(INT32) :: u32 +INTEGER(INT16) :: u16(0:1) +INTEGER(INT32) :: x, y +INTEGER(INT32) :: new_seed + !! +len = SIZE(key, kind=INT64) +IF (len <= 32) THEN + IF (len > 8) THEN + ans = nmhash32_9to32(key, seed) + RETURN + ELSE IF (len > 4) THEN + x = nmh_readle32(key) + y = IEOR(nmh_readle32(key(len - 4:)), nmh_prime32_4 + 2 + seed) + x = x + y + x = IEOR(x, ISHFT(x, len + 7)) + ans = nmhash32_0to8(x, ISHFTC(y, 5)) + RETURN + ELSE + SELECT CASE (len) + CASE (0) + new_seed = seed + nmh_prime32_2 + u32 = 0 + CASE (1) + new_seed = seed + nmh_prime32_2 + ISHFT(1_INT32, 24) + & + 2_INT32 + IF (little_endian) THEN + u32 = TRANSFER([key(0), 0_INT8, 0_INT8, 0_INT8], & + 0_INT32) + ELSE + u32 = TRANSFER([0_INT8, 0_INT8, 0_INT8, key(0)], & + 0_INT32) + END IF + CASE (2) + new_seed = seed + nmh_prime32_2 + ISHFT(2_INT32, 24) + & + 4_INT32 + IF (little_endian) THEN + u32 = TRANSFER([nmh_readle16(key), 0_INT16], 0_INT32) + ELSE + u32 = TRANSFER([0_INT16, nmh_readle16(key)], 0_INT32) + END IF + CASE (3) + new_seed = seed + nmh_prime32_2 + ISHFT(3_INT32, 24) + & + 6_INT32 + IF (little_endian) THEN + u16(1) = TRANSFER([key(2), 0_INT8], 0_INT16) + u16(0) = nmh_readle16(key) + ELSE + u16(0) = TRANSFER([0_INT8, key(2)], 0_INT16) + u16(1) = nmh_readle16(key) + END IF + u32 = TRANSFER(u16, 0_INT32) + CASE (4) + new_seed = seed + nmh_prime32_3 + u32 = nmh_readle32(key) + CASE default + ans = 0 + RETURN + END SELECT + ans = nmhash32_0to8(u32 + new_seed, ISHFTC(new_seed, 5)) + RETURN + END IF +ELSE IF (len < 256_INT64) THEN + ans = nmhash32_33to255(key, seed) + RETURN +ELSE + ans = nmhash32_avalanche32(nmhash32_long(key, seed)) + RETURN +END IF + !! +END PROCEDURE Int8_nmhash32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int16_nmhash32 +!! NMHASH32 hash function for rank 1 array keys of kind Int16 +ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & + & bytes_Int16 * SIZE(key, kind=INT64)), seed) +END PROCEDURE Int16_nmhash32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int32_nmhash32 +ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & + & bytes_Int32 * SIZE(key, kind=INT64)), seed) +END PROCEDURE Int32_nmhash32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int64_nmhash32 +ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & + & bytes_Int64 * SIZE(key, kind=INT64)), seed) +END PROCEDURE Int64_nmhash32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Char_nmhash32 +ans = Int8_nmhash32(TRANSFER(key, 0_INT8, & + & bytes_char * LEN(key, kind=INT64)), seed) +END PROCEDURE Char_nmhash32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int16_nmhash32x +ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & + & bytes_Int16 * SIZE(key, kind=INT64)), seed) +END PROCEDURE Int16_nmhash32x + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int32_nmhash32x +ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & + & bytes_Int32 * SIZE(key, kind=INT64)), seed) +END PROCEDURE Int32_nmhash32x + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int64_nmhash32x +ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & + & bytes_Int64 * SIZE(key, kind=INT64)), seed) +END PROCEDURE Int64_nmhash32x + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Char_nmhash32x +ans = Int8_nmhash32x(TRANSFER(key, 0_INT8, & + & bytes_char * LEN(key, kind=INT64)), seed) +END PROCEDURE Char_nmhash32x + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE new_nmhash32_seed +! Random SEED generator for NMHASH32 +INTEGER(INT32) :: old_seed +REAL(dp) :: sample +old_seed = seed +find_seed: DO + CALL RANDOM_NUMBER(sample) + seed = INT(FLOOR(sample * 2_INT64**32, INT64) - 2_INT64**31, & + INT32) + IF (seed /= old_seed) RETURN +END DO find_seed +END PROCEDURE new_nmhash32_seed + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE new_nmhash32x_seed +INTEGER(INT32) :: old_seed +REAL(dp) :: sample + +old_seed = seed +find_seed: DO + CALL RANDOM_NUMBER(sample) + seed = INT(FLOOR(sample * 2_INT64**32, INT64) - 2_INT64**31, & + INT32) + IF (seed /= old_seed) RETURN +END DO find_seed +END PROCEDURE new_nmhash32x_seed + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmh_readle32(p) RESULT(v) + INTEGER(INT32) :: v + INTEGER(INT8), INTENT(in) :: p(:) + + IF (little_endian) THEN + v = TRANSFER(p(1:4), 0_INT32) + ELSE + v = TRANSFER([p(4), p(3), p(2), p(1)], 0_INT32) + END IF + +END FUNCTION nmh_readle32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmh_readle16(p) RESULT(v) + INTEGER(INT16) :: v + INTEGER(INT8), INTENT(in) :: p(:) + + IF (little_endian) THEN + v = TRANSFER(p(1:2), 0_INT16) + ELSE + v = TRANSFER([p(2), p(1)], 0_INT16) + END IF + +END FUNCTION nmh_readle16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32_0to8(x, seed) RESULT(vx32) + INTEGER(INT32), INTENT(in) :: x + INTEGER(INT32), INTENT(in) :: seed + INTEGER(INT32) :: vx32 + ! base mixer: [-6 -12 776bf593 -19 11 3fb39c65 -15 -9 e9139917 -11 16] + ! = 0.027071104091278835 + INTEGER(INT32), PARAMETER :: m1 = INT(z'776BF593', INT32) + INTEGER(INT32), PARAMETER :: m2 = INT(z'3FB39C65', INT32) + INTEGER(INT32), PARAMETER :: m3 = INT(z'E9139917', INT32) + + INTEGER(INT16) :: vx16(2) + + vx32 = x + vx32 = IEOR(vx32, IEOR(ISHFT(vx32, -12), ISHFT(vx32, -6))) + vx16 = TRANSFER(vx32, 0_INT16, 2) + vx16 = vx16 * TRANSFER(m1, 0_INT16, 2) + vx32 = TRANSFER(vx16, 0_INT32) + vx32 = IEOR(vx32, IEOR(ISHFT(vx32, 11), ISHFT(vx32, -19))) + vx16 = TRANSFER(vx32, 0_INT16, 2) + vx16 = vx16 * TRANSFER(m2, 0_INT16, 2) + vx32 = TRANSFER(vx16, 0_INT32) + vx32 = IEOR(vx32, seed) + vx32 = IEOR(vx32, IEOR(ISHFT(vx32, -15), ISHFT(vx32, -9))) + vx16 = TRANSFER(vx32, 0_INT16, 2) + vx16 = vx16 * TRANSFER(m3, 0_INT16, 2) + vx32 = TRANSFER(vx16, 0_INT32) + vx32 = IEOR(vx32, IEOR(ISHFT(vx32, 16), ISHFT(vx32, -11))) + +END FUNCTION nmhash32_0to8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32_9to255(p, seed, full_avalanche) RESULT(RESULT) + INTEGER(INT8), INTENT(in) :: p(0:) + INTEGER(INT32), INTENT(in) :: seed + LOGICAL, INTENT(in) :: full_avalanche + INTEGER(INT32) :: RESULT + + INTEGER(INT32) :: xu32(0:3), yu32(0:3) + INTEGER(INT16) :: xu16(0:1) + ! Due to an issue with Intel OneAPI ifort 2021 (see + ! https://community.intel.com/t5/Intel-Fortran-Compiler/ + ! Intrinsic-transfer-with-a-provided-size-un-expected-behavior/m-p/ + ! 1343313#M158733 + ! ), it is not possible to define the following variables as a + ! PARAMETER. + ! INTEGER(int16), PARAMETER :: & + ! nmh_m1_16(0:1) = transfer( nmh_m1, 0_int16, 2 ), & + ! nmh_m2_16(0:1) = transfer( nmh_m2, 0_int16, 2 ), & + ! nmh_m3_16(0:1) = transfer( nmh_m3, 0_int16, 2 ) + INTEGER(INT16) :: nmh_m1_16(0:1), nmh_m2_16(0:1), nmh_m3_16(0:1) + INTEGER(INT32) :: s1 + INTEGER(INT64) :: length + INTEGER(INT32) :: length32(0:1) + INTEGER(INT64) :: i, j, r + + nmh_m1_16(0:1) = TRANSFER(nmh_m1, 0_INT16, 2) + nmh_m2_16(0:1) = TRANSFER(nmh_m2, 0_INT16, 2) + nmh_m3_16(0:1) = TRANSFER(nmh_m3, 0_INT16, 2) + + ! base mixer: [f0d9649b 5 -13 29a7935d -9 11 55d35831 -20 -10 ] = + ! 0.93495901789135362 + + RESULT = 0 + length = SIZE(p, kind=INT64) + length32 = TRANSFER(length, 0_INT32, 2) + IF (little_endian) THEN + s1 = seed + length32(0) + ELSE + s1 = seed + length32(1) + END IF + xu32(0) = nmh_prime32_1 + xu32(1) = nmh_prime32_2 + xu32(2) = nmh_prime32_3 + xu32(3) = nmh_prime32_4 + yu32(:) = s1 + + IF (full_avalanche) THEN + ! 33 to 255 bytes + r = (length - 1) / 32 + DO i = 0, r - 1 + DO j = 0, 3 + xu32(j) = IEOR(xu32(j), nmh_readle32(p(i * 32 + j * 4:))) + yu32(j) = IEOR(yu32(j), & + nmh_readle32(p(i * 32 + j * 4 + 16:))) + xu32(j) = xu32(j) + yu32(j) + xu16 = TRANSFER(xu32(j), 0_INT16, 2) + xu16 = xu16 * nmh_m1_16 + xu32(j) = TRANSFER(xu16, 0_INT32) + xu32(j) = IEOR(xu32(j), & + IEOR(ISHFT(xu32(j), 5), & + ISHFT(xu32(j), -13))) + xu16 = TRANSFER(xu32(j), 0_INT16, 2) + xu16 = xu16 * nmh_m2_16 + xu32(j) = TRANSFER(xu16, 0_INT32) + xu32(j) = IEOR(xu32(j), yu32(j)) + xu32(j) = IEOR(xu32(j), & + IEOR(ISHFT(xu32(j), 11), & + ISHFT(xu32(j), -9))) + xu16 = TRANSFER(xu32(j), 0_INT16, 2) + xu16 = xu16 * nmh_m3_16 + xu32(j) = TRANSFER(xu16, 0_INT32) + xu32(j) = IEOR(xu32(j), & + IEOR(ISHFT(xu32(j), -10), & + ISHFT(xu32(j), -20))) + END DO + END DO + DO j = 0, 3 + xu32(j) = IEOR(xu32(j), & + nmh_readle32(p(length - 32 + j * 4:))) + yu32(j) = IEOR(yu32(j), & + nmh_readle32(p(length - 16 + j * 4:))) + END DO + ELSE + ! 9 to 32 bytes + xu32(0) = IEOR(xu32(0), nmh_readle32(p(0:))) + xu32(1) = IEOR(xu32(1), nmh_readle32(p(ISHFT(ISHFT(length, -4), 3):))) + xu32(2) = IEOR(xu32(2), nmh_readle32(p(length - 8:))) + xu32(3) = IEOR(xu32(3), & + nmh_readle32(p(length - 8 - ISHFT(ISHFT(length, -4), 3):))) + yu32(0) = IEOR(yu32(0), nmh_readle32(p(4:))) + yu32(1) = IEOR(yu32(1), & + nmh_readle32(p(ISHFT(ISHFT(length, -4), 3) + 4:))) + yu32(2) = IEOR(yu32(2), nmh_readle32(p(length - 8 + 4:))) + yu32(3) = IEOR(yu32(3), & + nmh_readle32(p(length - 8 - & + ISHFT(ISHFT(length, -4), 3) + 4:))) + END IF + DO j = 0, 3 + xu32(j) = xu32(j) + yu32(j) + yu32(j) = IEOR(yu32(j), IEOR(ISHFT(yu32(j), 17), & + ISHFT(yu32(j), -6))) + xu16 = TRANSFER(xu32(j), 0_INT16, 2) + xu16 = xu16 * nmh_m1_16 + xu32(j) = TRANSFER(xu16, 0_INT32) + xu32(j) = IEOR(xu32(j), IEOR(ISHFT(xu32(j), 5), & + ISHFT(xu32(j), -13))) + xu16 = TRANSFER(xu32(j), 0_INT16, 2) + xu16 = xu16 * nmh_m2_16 + xu32(j) = TRANSFER(xu16, 0_INT32) + xu32(j) = IEOR(xu32(j), yu32(j)) + xu32(j) = IEOR(xu32(j), IEOR(ISHFT(xu32(j), 11), & + ISHFT(xu32(j), -9))) + xu16 = TRANSFER(xu32(j), 0_INT16, 2) + xu16 = xu16 * nmh_m3_16 + xu32(j) = TRANSFER(xu16, 0_INT32) + xu32(j) = IEOR(xu32(j), IEOR(ISHFT(xu32(j), -10), & + ISHFT(xu32(j), -20))) + END DO + xu32(0) = IEOR(xu32(0), nmh_prime32_1) + xu32(1) = IEOR(xu32(1), nmh_prime32_2) + xu32(2) = IEOR(xu32(2), nmh_prime32_3) + xu32(3) = IEOR(xu32(3), nmh_prime32_4) + DO j = 1, 3 + xu32(0) = xu32(0) + xu32(j) + END DO + xu32(0) = IEOR(xu32(0), s1 + ISHFT(s1, -5)) + xu16 = TRANSFER(xu32(0), 0_INT16, 2) + xu16 = xu16 * nmh_m3_16 + xu32(0) = TRANSFER(xu16, 0_INT32) + xu32(0) = IEOR(xu32(0), & + IEOR(ISHFT(xu32(0), -10), ISHFT(xu32(0), -20))) + RESULT = xu32(0) + +END FUNCTION nmhash32_9to255 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32_9to32(p, seed) RESULT(ans) + INTEGER(INT8), INTENT(in) :: p(0:) + INTEGER(INT32), INTENT(in) :: seed + INTEGER(INT32) :: ans + ans = nmhash32_9to255(p, seed, .FALSE.) +END FUNCTION nmhash32_9to32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32_33to255(p, seed) RESULT(ans) + INTEGER(INT8), INTENT(in) :: p(0:) + INTEGER(INT32), INTENT(in) :: seed + INTEGER(INT32) :: ans + ans = nmhash32_9to255(p, seed, .TRUE.) +END FUNCTION nmhash32_33to255 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE nmhash32_long_round(accx, accy, p) + INTEGER(INT32), INTENT(inout) :: accx(0:) + INTEGER(INT32), INTENT(inout) :: accy(0:) + INTEGER(INT8), INTENT(in) :: p(0:) + + INTEGER(INT64), PARAMETER :: nbgroups = init_size + INTEGER(INT64) :: i + INTEGER(INT16) :: dummy1(0:1) + INTEGER(INT16) :: dummy2(0:1) + + DO i = 0, nbgroups - 1 + accx(i) = IEOR(accx(i), nmh_readle32(p(i * 4:))) + accy(i) = IEOR(accy(i), nmh_readle32(p(i * 4 + nbgroups * 4:))) + accx(i) = accx(i) + accy(i) + accy(i) = IEOR(accy(i), ISHFT(accx(i), -1)) + dummy1 = TRANSFER(accx(i), 0_INT16, 2) + dummy2 = TRANSFER(nmh_m1_v(i), 0_INT16, 2) + dummy1 = dummy1 * dummy2 + accx(i) = TRANSFER(dummy1, 0_INT32) + accx(i) = IEOR(accx(i), IEOR(ISHFT(accx(i), 5), & + ISHFT(accx(i), -13))) + dummy1 = TRANSFER(accx(i), 0_INT16, 2) + dummy2 = TRANSFER(nmh_m2_v(i), 0_INT16, 2) + dummy1 = dummy1 * dummy2 + accx(i) = TRANSFER(dummy1, 0_INT32) + accx(i) = IEOR(accx(i), accy(i)) + accx(i) = IEOR(accx(i), IEOR(ISHFT(accx(i), 11), & + ISHFT(accx(i), -9))) + dummy1 = TRANSFER(accx(i), 0_INT16, 2) + dummy2 = TRANSFER(nmh_m3_v(i), 0_INT16, 2) + dummy1 = dummy1 * dummy2 + accx(i) = TRANSFER(dummy1, 0_INT32) + accx(i) = IEOR(accx(i), IEOR(ISHFT(accx(i), -10), & + ISHFT(accx(i), -20))) + END DO + +END SUBROUTINE nmhash32_long_round + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32_long(p, seed) RESULT(sum) + INTEGER(INT32) :: sum + INTEGER(INT8), INTENT(in) :: p(0:) + INTEGER(INT32), INTENT(in) :: seed + !! + INTEGER(INT32) :: accx(0:SIZE(nmh_acc_init) - 1) + INTEGER(INT32) :: accy(0:SIZE(nmh_acc_init) - 1) + INTEGER(INT64) :: nbrounds + INTEGER(INT64) :: len + INTEGER(INT32) :: len32(0:1) + INTEGER(INT64) :: i + !! + len = SIZE(p, kind=INT64) + nbrounds = (len - 1) / (4 * SIZE(accx, kind=INT64) * 2) + sum = 0 + !! + ! Init + DO i = 0_INT64, SIZE(nmh_acc_init, kind=INT64) - 1 + accx(i) = nmh_acc_init(i) + accy(i) = seed + END DO + !! + ! init + DO i = 0_INT64, nbrounds - 1 + CALL nmhash32_long_round(accx, accy, & + & p(i * 8 * SIZE(accx, kind=INT64):)) + END DO + CALL nmhash32_long_round(accx, accy, & + & p(len - 8 * SIZE(accx, kind=INT64):)) + !! + ! merge acc + DO i = 0, SIZE(accx, kind=INT64) - 1 + accx(i) = IEOR(accx(i), nmh_acc_init(i)) + sum = sum + accx(i) + END DO + !! + len32 = TRANSFER(len, 0_INT32, 2) + IF (little_endian) THEN + sum = sum + len32(1) + sum = IEOR(sum, len32(0)) + ELSE + sum = sum + len32(0) + sum = IEOR(sum, len32(1)) + END IF + !! +END FUNCTION nmhash32_long + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32_avalanche32(x) RESULT(u32) + INTEGER(INT32) :: u32 + INTEGER(INT32), INTENT(in) :: x + !! + INTEGER(INT16) :: u16(0:1) + INTEGER(INT32), PARAMETER :: m1 = INT(z'CCE5196D', INT32) + INTEGER(INT32), PARAMETER :: m2 = INT(z'464BE229', INT32) + ! Due to an issue with Intel OneAPI ifort 2021 (see + ! https://community.intel.com/t5/Intel-Fortran-Compiler/ + ! Intrinsic-transfer-with-a-provided-size-un-expected-behavior/m-p/ + ! 1343313#M158733 + ! ), it is not possible to define the following variables as a PARAMETER. + !INTEGER(int16), PARAMETER:: m1_16(0:1) = transfer(m1, 0_int16, 2) + !INTEGER(int16), PARAMETER:: m2_16(0:1) = transfer(m2, 0_int16, 2) + INTEGER(INT16) :: m1_16(0:1), m2_16(0:1) + ! [-21 -8 cce5196d 12 -7 464be229 -21 -8] = 3.2267098842182733 + !! + m1_16(0:1) = TRANSFER(m1, 0_INT16, 2) + m2_16(0:1) = TRANSFER(m2, 0_INT16, 2) + !! + u32 = x + u32 = IEOR(u32, IEOR(ISHFT(u32, -8), ISHFT(u32, -21))) + u16 = TRANSFER(u32, 0_INT16, 2) + u16(0) = u16(0) * m1_16(0) + u16(1) = u16(1) * m1_16(1) + u32 = TRANSFER(u16, 0_INT32) + u32 = IEOR(u32, IEOR(ISHFT(u32, 12), ISHFT(u32, -7))) + u16 = TRANSFER(u32, 0_INT16, 2) + u16(0) = u16(0) * m2_16(0) + u16(1) = u16(1) * m2_16(1) + u32 = TRANSFER(u16, 0_INT32) + u32 = IEOR(u32, IEOR(ISHFT(u32, -8), ISHFT(u32, -21))) + !! +END FUNCTION nmhash32_avalanche32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32x_0to4(x, seed) RESULT(hash) + INTEGER(INT32), INTENT(in) :: x + INTEGER(INT32), INTENT(in) :: seed + INTEGER(INT32) :: hash + !! + !! [bdab1ea9 18 a7896a1b 12 83796a2d 16] = 0.092922873297662509 + !! + hash = x + hash = IEOR(hash, seed) + hash = hash * INT(z'BDAB1EA9', INT32) + hash = hash + ISHFTC(seed, 31) + hash = IEOR(hash, ISHFT(hash, -18)) + hash = hash * INT(z'A7896A1B', INT32) + hash = IEOR(hash, ISHFT(hash, -12)) + hash = hash * INT(z'83796A2D', INT32) + hash = IEOR(hash, ISHFT(hash, -16)) + !! +END FUNCTION nmhash32x_0to4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32x_5to8(p, seed) RESULT(x) + INTEGER(INT8), INTENT(in) :: p(0:) + INTEGER(INT32), INTENT(in) :: seed + INTEGER(INT32) :: x + !! + !! internal variables + !! + INTEGER(INT64) :: len + INTEGER(INT32) :: y + ! + ! 5 to 9 bytes + ! mixer: [11049a7d 23 bcccdc7b 12 065e9dad 12] = 0.16577596555667246 + ! + len = SIZE(p, kind=INT64) + x = IEOR(nmh_readle32(p), nmh_prime32_3) + y = IEOR(nmh_readle32(p(len - 4:)), seed) + x = x + y + x = IEOR(x, ISHFT(x, -len)) + x = x * INT(z'11049A7D', INT32) + x = IEOR(x, ISHFT(x, -23)) + x = x * INT(z'BCCCDC7B', INT32) + x = IEOR(x, ISHFTC(y, 3)) + x = IEOR(x, ISHFT(x, -12)) + x = x * INT(z'065E9DAD', INT32) + x = IEOR(x, ISHFT(x, -12)) +END FUNCTION nmhash32x_5to8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32x_9to255(p, seed) RESULT(x) + INTEGER(INT8), INTENT(in) :: p(0:) + INTEGER(INT32), INTENT(in) :: seed + INTEGER(INT32) :: x + !! + !! internal variables + !! + INTEGER(INT64) :: len + INTEGER(INT32) :: len32(0:1), len_base + INTEGER(INT32) :: y + INTEGER(INT32) :: a, b + INTEGER(INT64) :: i, r + !! + ! - at least 9 bytes + ! - base mixer: [11049a7d 23 bcccdc7b 12 065e9dad 12] = 0.16577596555667246 + ! - tail mixer: [16 a52fb2cd 15 551e4d49 16] = 0.17162579707098322 + !! + len = SIZE(p, kind=INT64) + len32 = TRANSFER(len, 0_INT32, 2) + IF (little_endian) THEN + len_base = len32(0) + ELSE + len_base = len32(1) + END IF + x = nmh_prime32_3 + y = seed + a = nmh_prime32_4 + b = seed + r = (len - 1) / 16 + !! + DO i = 0, r - 1 + x = IEOR(x, nmh_readle32(p(i * 16 + 0:))) + y = IEOR(y, nmh_readle32(p(i * 16 + 4:))) + x = IEOR(x, y) + x = x * INT(z'11049A7D', INT32) + x = IEOR(x, ISHFT(x, -23)) + x = x * INT(z'BCCCDC7B', INT32) + y = ISHFTC(y, 4) + x = IEOR(x, y) + x = IEOR(x, ISHFT(x, -12)) + x = x * INT(z'065E9DAD', INT32) + x = IEOR(x, ISHFT(x, -12)) + + a = IEOR(a, nmh_readle32(p(i * 16 + 8:))) + b = IEOR(b, nmh_readle32(p(i * 16 + 12:))) + a = IEOR(a, b) + a = a * INT(z'11049A7D', INT32) + a = IEOR(a, ISHFT(a, -23)) + a = a * INT(z'BCCCDC7B', INT32) + b = ISHFTC(b, 3) + a = IEOR(a, b) + a = IEOR(a, ISHFT(a, -12)) + a = a * INT(z'065E9DAD', INT32) + a = IEOR(a, ISHFT(a, -12)) + END DO + !! + IF (IAND(len_base - 1_INT32, 8_INT32) /= 0) THEN + IF (IAND(len_base - 1_INT32, 4_INT32) /= 0) THEN + a = IEOR(a, nmh_readle32(p(r * 16 + 0:))) + b = IEOR(b, nmh_readle32(p(r * 16 + 4:))) + a = IEOR(a, b) + a = a * INT(z'11049A7D', INT32) + a = IEOR(a, ISHFT(a, -23)) + a = a * INT(z'BCCCDC7B', INT32) + a = IEOR(a, ISHFTC(b, 4)) + a = IEOR(a, ISHFT(a, -12)) + a = a * INT(z'065E9DAD', INT32) + ELSE + a = IEOR(a, nmh_readle32(p(r * 16:)) + b) + a = IEOR(a, ISHFT(a, -16)) + a = a * INT(z'A52FB2CD', INT32) + a = IEOR(a, ISHFT(a, -15)) + a = a * INT(z'551E4D49', INT32) + END IF + x = IEOR(x, nmh_readle32(p(len - 8:))) + y = IEOR(y, nmh_readle32(p(len - 4:))) + x = IEOR(x, y) + x = x * INT(z'11049A7D', INT32) + x = IEOR(x, ISHFT(x, -23)) + x = x * INT(z'BCCCDC7B', INT32); + x = IEOR(x, ISHFTC(y, 3)) + x = IEOR(x, ISHFT(x, -12)) + x = x * INT(z'065E9DAD', INT32) + ELSE + IF (IAND(len_base - 1_INT32, 4_INT32) /= 0) THEN + a = IEOR(a, nmh_readle32(p(r * 16:)) + b) + a = IEOR(a, ISHFT(a, -16)) + a = a * INT(z'A52FB2CD', INT32) + a = IEOR(a, ISHFT(a, -15)) + a = a * INT(z'551E4D49', INT32) + END IF + x = IEOR(x, nmh_readle32(p(len - 4:)) + y) + x = IEOR(x, ISHFT(x, -16)) + x = x * INT(z'A52FB2CD', INT32) + x = IEOR(x, ISHFT(x, -15)) + x = x * INT(z'551E4D49', INT32) + END IF + !! + x = IEOR(x, len_base) + x = IEOR(x, ISHFTC(a, 27)) ! rotate one lane to pass Diff test + x = IEOR(x, ISHFT(x, -14)) + x = x * INT(z'141CC535', INT32) + !! +END FUNCTION nmhash32x_9to255 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION nmhash32x_avalanche32(x) RESULT(hash) + INTEGER(INT32) :: hash + INTEGER(INT32), INTENT(in) :: x + ! Mixer with 2 mul from skeeto/hash-prospector: + ! [15 d168aaad 15 af723597 15] = 0.15983776156606694 + hash = x + hash = IEOR(hash, ISHFT(hash, -15)) + hash = hash * INT(z'D168AAAD', INT32) + hash = IEOR(hash, ISHFT(hash, -15)) + hash = hash * INT(z'AF723597', INT32) + hash = IEOR(hash, ISHFT(hash, -15)) +END FUNCTION nmhash32x_avalanche32 + +END SUBMODULE nmMethods diff --git a/src/submodules/Hashing/src/Hashing32@waterMethods.F90 b/src/submodules/Hashing/src/Hashing32@waterMethods.F90 new file mode 100644 index 000000000..d4a0e383d --- /dev/null +++ b/src/submodules/Hashing/src/Hashing32@waterMethods.F90 @@ -0,0 +1,313 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 July 2021 +! summary: +! +!# Introduction +! +! `WATER_HASH` is a translation to Fortran 2008 of the `waterhash` algorithm +! of Tommy Ettinger. Tommy Ettinger's original C++ code, `waterhash.h`, is +! available at the URL: https://github.com/tommyettinger/waterhash under the +! `unlicense`, https://github.com/tommyettinger/waterhash/blob/master/LICENSE. +! "`waterhash` is a variant on Wang Yi's `wyhash`, with 32 bit output, +! using at most 64 bit arithmetic. `wyhash` is available at the URL: +! `https://github.com/wangyi-fudan/wyhash` also under the unlicense: +! `https://github.com/wangyi-fudan/wyhash/blob/master/LICENSE`. +! Original Author: Wang Yi +! Waterhash Variant Author: Tommy Ettinger +! +! The `unlicense` reads as follows: +! This is free and unencumbered software released into the public domain. +! +! Anyone is free to copy, modify, publish, use, compile, sell, or +! distribute this software, either in source code form or as a compiled +! binary, for any purpose, commercial or non-commercial, and by any +! means. +! +! In jurisdictions that recognize copyright laws, the author or authors +! of this software dedicate any and all copyright interest in the +! software to the public domain. We make this dedication for the benefit +! of the public at large and to the detriment of our heirs and +! successors. We intend this dedication to be an overt act of +! relinquishment in perpetuity of all present and future rights to this +! software under copyright law. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +! IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +! OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +! ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +! OTHER DEALINGS IN THE SOFTWARE. +! +! For more information, please refer to +! +! `WATER_HASH` is distributed as part of the `stdlib_32_bit_hash_functions. +! f90` +! module and its `stdlib_hash_32bit_water.f90` submodule with the Fortran +! Standard Library at URL: https://github.com/fortran-lang/stdlib. +! The Fortran Standard Library, including this code, is distributed under the +! MIT License as described in the `LICENSE` file distributed with the library. +! `WATER_HASH` differs from `waterhash.h` not only in its use of Fortran, +! but also in its use of signed two's complement arithmetic in contrast to +! the unsigned arithmetic of Ettinger and Wang Yi, and in making some of the +! uses of `TRANSFER` endian dependent, in an attempt to make the quality of +! the hash endian independent. The use of signed arithmetic may change with +! the planned introduction of the unsigned BITS datatype in what is currently +! known as Fortran 202X. +! +! To be useful this code must be processed by a processor that implements two +! Fortran 2008 extensions to Fortran 2003: submodules, and 64 bit (`INT64`) +! integers. The processor must also use two's complement integers +! (all Fortran 95+ processors use two's complement arithmetic) with +! wrap around overflow at runtime and for BOZ constants. The latest releases +! of the following processors are known to implement the required Fortran +! 2008 extensions and default to runtime wrap around overflow: FLANG, +! gfortran, ifort, and NAG Fortran. Older versions of gfortran will require +! the compiler flag, `-fno-range-check`, to ensure wrap around semantics +! for BOZ constants, and only versions of the NAG compiler starting with +! version 17, have implemented submodules. The latest releases of Cray +! Fortran and IBM Fortran are known to implement the Fortran 2008 extensions, +! but whether they also implement wrap around overflow is unknown. +! +! This implementation has only been tested on little endian processors. It +! will generate different hashes on big endian processors, but they are +! believed to be of comparable quality to those generated for little endian +! processors. +! +! No version of this hash is suitable as a cryptographic hash. + +SUBMODULE(Hashing32) waterMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int8_water_hash + INTEGER(int32) :: dummy(2) + INTEGER(int64) :: h + INTEGER(int64) :: i + INTEGER(int64) :: len + INTEGER(int64), parameter :: & + !! + waterp0 = int(z'a0761d65', kind=int64), & + waterp1 = int(z'e7037ed1', kind=int64), & + waterp2 = int(z'8ebc6af1', kind=int64), & + waterp3 = int(z'589965cd', kind=int64), & + waterp4 = int(z'1d8e4e27', kind=int64), & + waterp5 = int(z'eb44accb', kind=int64) + + len = size(key, kind=int64) + h = seed + do i = 0_int64, len - 16, 16 + h = watermum(watermum(ieor(waterr32(key(i:)), waterp1), & + ieor(waterr32(key(i + 4:)), waterp2)) + h, & + watermum(ieor(waterr32(key(i + 8:)), waterp3), & + ieor(waterr32(key(i + 12:)), waterp4))) + end do + h = h + waterp5 + + select case (iand(len, 15_int64)) + case (1) + h = watermum(ieor(waterp2, h), & + ieor(waterr08(key(i:)), waterp1)) + case (2) + h = watermum(ieor(waterp3, h), & + ieor(waterr16(key(i:)), waterp4)) + case (3) + h = watermum(ieor(waterr16(key(i:)), h), & + ieor(waterr08(key(i + 2:)), waterp2)) + case (4) + h = watermum(ieor(waterr16(key(i:)), h), & + ieor(waterr16(key(i + 2:)), waterp3)) + case (5) + h = watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr08(key(i + 4:)), waterp1)) + case (6) + h = watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr16(key(i + 4:)), waterp1)) + case (7) + h = watermum(ieor(waterr32(key(i:)), h), & + ieor(ior(ishft(waterr16(key(i + 4:)), 8), & + waterr08(key(i + 6:))), waterp1)) + case (8) + h = watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp0)) + case (9) + h = ieor(watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp2)), & + watermum(ieor(h, waterp4), & + ieor(waterr08(key(i + 8:)), waterp3))) + case (10) + h = ieor(watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp2)), & + watermum(h, ieor(waterr16(key(i + 8:)), waterp3))) + case (11) + h = ieor(watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp2)), & + watermum(h, & + ieor(ior(ishft(waterr16(key(i + 8:)), 8), & + waterr08(key(i + 10:))), & + waterp3))) + case (12) + h = ieor(watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp2)), & + watermum(ieor(h, waterr32(key(i + 8:))), & + waterp4)) + case (13) + h = ieor(watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp2)), & + watermum(ieor(h, waterr32(key(i + 8:))), & + ieor(waterr08(key(i + 12:)), waterp4))) + case (14) + h = ieor(watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp2)), & + watermum(ieor(h, waterr32(key(i + 8:))), & + ieor(waterr16(key(i + 12:)), waterp4))) + case (15) + h = ieor(watermum(ieor(waterr32(key(i:)), h), & + ieor(waterr32(key(i + 4:)), waterp2)), & + watermum(ieor(h, waterr32(key(i + 8:))), & + ieor(ior(ishft(waterr16(key(i + 12:)), 8), & + waterr08(key(i + 14:))), & + waterp4))) + end select + + h = ieor(h, ishft(h, 16)) * ieor(len, waterp0) + h = h - ishft(h, -32) + dummy(1:2) = transfer(h, dummy, 2) + if (little_endian) then + ans = dummy(1) + else + ans = dummy(2) + end if + !! + contains + !! + pure function watermum(a, b) result(r) + INTEGER(int64) :: r + INTEGER(int64), intent(in) :: a, b + r = a * b + r = r - ishft(r, -32) + end function watermum + !! + pure function waterr08(p) result(v) + INTEGER(int64) :: v + INTEGER(int8), intent(in) :: p(:) + if (little_endian) then + v = transfer([p(1), 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8], v) + else + v = transfer([0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, p(1)], v) + end if + end function waterr08 + !! + pure function waterr16(p) result(v) + INTEGER(int64) :: v + INTEGER(int8), intent(in) :: p(:) + !! + if (little_endian) then + v = transfer([p(1), p(2), 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8], v) + else + v = transfer([0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, p(2), p(1)], v) + end if + !! + end function waterr16 + !! + pure function waterr32(p) result(v) + INTEGER(int64) :: v + INTEGER(int8), intent(in) :: p(:) + !! + if (little_endian) then + v = transfer([p(1), p(2), p(3), p(4), & + 0_int8, 0_int8, 0_int8, 0_int8], v) + else + v = transfer([0_int8, 0_int8, 0_int8, 0_int8, & + p(4), p(3), p(2), p(1)], v) + end if + !! + end function waterr32 + !! +END PROCEDURE Int8_water_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE int16_water_hash + ans = int8_water_hash(transfer(key, 0_int8, & + & bytes_int16 * size(key, kind=int64)), seed) +END PROCEDURE int16_water_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE int32_water_hash + ans = int8_water_hash(transfer(key, 0_int8, & + & bytes_int32 * size(key, kind=int64)), seed) +END PROCEDURE int32_water_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE int64_water_hash + ans = int8_water_hash(transfer(key, 0_int8, & + & bytes_int64 * size(key, kind=int64)), seed) +END PROCEDURE int64_water_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Char_water_hash + ans = int8_water_hash(transfer(key, 0_int8, & + & bytes_char * len(key, kind=int64)), seed) +END PROCEDURE Char_water_hash + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE new_water_hash_seed + !! + integer(int64) :: old_seed + real(dp) :: sample(2) + integer(int32) :: part(2) + old_seed = seed + find_seed:do + call random_number( sample ) + part = int( floor( sample * 2_int64**32, int64 ) & + & - 2_int64**31, int32 ) + seed = transfer( part, seed ) + if ( seed /= old_seed ) return + end do find_seed + !! +END PROCEDURE new_water_hash_seed + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE waterMethods diff --git a/src/submodules/Hashing/src/delme.F90 b/src/submodules/Hashing/src/delme.F90 new file mode 100644 index 000000000..e69de29bb diff --git a/src/submodules/IndexValue/CMakeLists.txt b/src/submodules/IndexValue/CMakeLists.txt new file mode 100644 index 000000000..506d7fdbc --- /dev/null +++ b/src/submodules/IndexValue/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/IndexValue_Method@Constructor.F90 +) \ No newline at end of file diff --git a/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 b/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 new file mode 100644 index 000000000..90caf6cd2 --- /dev/null +++ b/src/submodules/IndexValue/src/IndexValue_Method@Constructor.F90 @@ -0,0 +1,59 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(IndexValue_Method) Constructor +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! IndexValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor1 +obj%Indx = Indx + obj%Val = Val +END PROCEDURE Constructor1 + +!---------------------------------------------------------------------------- +! IndexValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor2 + INTEGER( I4B ) :: n, i + n = SIZE( Indx ) + ALLOCATE( obj( n ) ) + DO i = 1, n + obj( i )%Indx = Indx( i ) + obj( i )%Val = Val( i ) + END DO +END PROCEDURE Constructor2 + +!---------------------------------------------------------------------------- +! IndexValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor3 + INTEGER( I4B ) :: n, i + n = SIZE( Indx ) + ALLOCATE( obj( n ) ) + DO i = 1, n + obj( i )%Indx = Indx( i ) + obj( i )%Val = Val + END DO +END PROCEDURE Constructor3 + +END SUBMODULE Constructor \ No newline at end of file diff --git a/src/submodules/IntVector/CMakeLists.txt b/src/submodules/IntVector/CMakeLists.txt new file mode 100644 index 000000000..3309c013a --- /dev/null +++ b/src/submodules/IntVector/CMakeLists.txt @@ -0,0 +1,27 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General 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}/IntVector_ConstructorMethod@Methods.F90 + ${src_path}/IntVector_IOMethod@Methods.F90 + ${src_path}/IntVector_SetMethod@Methods.F90 + ${src_path}/IntVector_AppendMethod@Methods.F90 + ${src_path}/IntVector_GetMethod@Methods.F90 + ${src_path}/IntVector_EnquireMethod@Methods.F90 +) diff --git a/src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 new file mode 100644 index 000000000..e62cd6115 --- /dev/null +++ b/src/submodules/IntVector/src/IntVector_AppendMethod@Methods.F90 @@ -0,0 +1,102 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This submodule implements set methods of [[IntVector_]] + +SUBMODULE(IntVector_AppendMethod) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Append_1 +CALL Append(obj%Val, VALUE) +END PROCEDURE IntVec_Append_1 + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Append_2 +CALL Append(obj%Val, VALUE) +END PROCEDURE IntVec_Append_2 + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Append_3 +CALL Append(obj%Val, Anotherobj%Val) +END PROCEDURE IntVec_Append_3 + +!---------------------------------------------------------------------------- +! H_CONCAT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_H_CONCAT_1 +INTEGER(I4B) :: s1, s2 +s1 = SIZE(vec1) +s2 = SIZE(vec2) +ans(1:s1) = vec1(:) +ans(s1 + 1:) = vec2(:) +END PROCEDURE IntVec_H_CONCAT_1 + +!---------------------------------------------------------------------------- +! H_CONCAT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_H_CONCAT_2 +INTEGER(I4B) :: s1, s2 +s1 = SIZE(obj1) +s2 = SIZE(obj2) +CALL Initiate(ans, s1 + s2) +ans%val(1:s1) = obj1%val(:) +ans%val(s1 + 1:) = obj2%val(:) +END PROCEDURE IntVec_H_CONCAT_2 + +!---------------------------------------------------------------------------- +! H_CONCAT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_H_CONCAT_3 +INTEGER(I4B) :: s1, s2 +s1 = SIZE(vec1) +s2 = SIZE(obj2) +CALL Initiate(ans, s1 + s2) +ans%val(1:s1) = vec1(:) +ans%val(s1 + 1:) = obj2%val(:) +END PROCEDURE IntVec_H_CONCAT_3 + +!---------------------------------------------------------------------------- +! H_CONCAT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_H_CONCAT_4 +INTEGER(I4B) :: s1, s2 +s1 = SIZE(obj1) +s2 = SIZE(vec2) +CALL Initiate(ans, s1 + s2) +ans%val(1:s1) = obj1%val(:) +ans%val(s1 + 1:) = vec2(:) +END PROCEDURE IntVec_H_CONCAT_4 + +END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 new file mode 100644 index 000000000..bcbeb6ae0 --- /dev/null +++ b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 @@ -0,0 +1,244 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This submodule contains the contructor methods for [[IntVector_]] + +SUBMODULE(IntVector_ConstructorMethod) Methods +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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 intVec_Size +IF (ALLOCATED(obj%Val)) THEN + Ans = SIZE(obj%Val) +ELSE + Ans = 0 +END IF +END PROCEDURE intVec_Size + +!---------------------------------------------------------------------------- +! getTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_getTotalDimension +ans = obj%tDimension +END PROCEDURE IntVec_getTotalDimension + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_AllocateData +CALL Reallocate(obj%Val, Dims) +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE intVec_AllocateData + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_Reallocate +IF (ALLOCATED(obj)) THEN + IF (SIZE(obj) .NE. row) THEN + DEALLOCATE (obj) + ALLOCATE (obj(row)) + END IF +ELSE + ALLOCATE (obj(row)) +END IF +END PROCEDURE intVec_Reallocate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_Deallocate +IF (ALLOCATED(obj%Val)) DEALLOCATE (obj%Val) +END PROCEDURE intVec_Deallocate + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_initiate1 +CALL ALLOCATE (obj, tSize) +END PROCEDURE intVec_initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_initiate2 +INTEGER(I4B) :: n, i +n = SIZE(tSize) +IF (ALLOCATED(obj)) THEN + IF (SIZE(obj) .NE. n) THEN + DEALLOCATE (obj) + ALLOCATE (obj(n)) + END IF +ELSE + ALLOCATE (obj(n)) +END IF +DO i = 1, n + CALL ALLOCATE (obj(i), tSize(i)) +END DO +END PROCEDURE intVec_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 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_initiate4a +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE intVec_initiate4a + +MODULE PROCEDURE intVec_initiate4b +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE intVec_initiate4b + +MODULE PROCEDURE intVec_initiate4c +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE intVec_initiate4c + +MODULE PROCEDURE intVec_initiate4d +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE intVec_initiate4d + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_initiate5a +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE intVec_initiate5a + +MODULE PROCEDURE intVec_initiate5b +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE intVec_initiate5b + +!---------------------------------------------------------------------------- +! Vector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Constructor1 +CALL ALLOCATE (obj, tSize) +END PROCEDURE IntVec_Constructor1 + +!---------------------------------------------------------------------------- +! Vector_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Constructor2 +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE IntVec_Constructor2 + +!---------------------------------------------------------------------------- +! Vector_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Constructor3 +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE IntVec_Constructor3 + +!---------------------------------------------------------------------------- +! Vector_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Constructor_1 +ALLOCATE (obj) +CALL ALLOCATE (obj, tSize) +END PROCEDURE IntVec_Constructor_1 + +!---------------------------------------------------------------------------- +! Vector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Constructor_2 +ALLOCATE (obj) +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE IntVec_Constructor_2 + +!---------------------------------------------------------------------------- +! Vector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Constructor_3 +ALLOCATE (obj) +obj%Val = Val +CALL setTotalDimension(obj, 1_I4B) +END PROCEDURE IntVec_Constructor_3 + +!---------------------------------------------------------------------------- +! Assignment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_assign_a +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val +END IF +END PROCEDURE IntVec_assign_a + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_convert_int +IF (ALLOCATED(From%Val)) THEN + To = From%Val +END IF +END PROCEDURE obj_convert_int + +END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 new file mode 100644 index 000000000..552e6ec2f --- /dev/null +++ b/src/submodules/IntVector/src/IntVector_EnquireMethod@Methods.F90 @@ -0,0 +1,119 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(IntVector_EnquireMethod) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! intVec_isAllocated +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_isAllocated +IF (ALLOCATED(obj%Val)) THEN + ans = .TRUE. +ELSE + ans = .FALSE. +END IF +END PROCEDURE intVec_isAllocated + +!---------------------------------------------------------------------------- +! IN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_in1 +ans = obj1%val.in.obj2%val +END PROCEDURE intVec_in1 + +!---------------------------------------------------------------------------- +! IN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_in2a +ans = ANY(a .EQ. obj%val) +END PROCEDURE intVec_in2a + +!---------------------------------------------------------------------------- +! IN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_in2b +ans = ANY(a .EQ. obj%val) +END PROCEDURE intVec_in2b + +!---------------------------------------------------------------------------- +! IN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_in2c +ans = ANY(a .EQ. obj%val) +END PROCEDURE intVec_in2c + +!---------------------------------------------------------------------------- +! IN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_in2d +ans = ANY(a .EQ. obj%val) +END PROCEDURE intVec_in2d + +!---------------------------------------------------------------------------- +! isPresent +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_isPresent1 +INTEGER(I4B) :: i +Ans = .FALSE. +DO i = 1, SIZE(obj%Val) + IF (obj%Val(i) .EQ. VALUE) THEN + Ans = .TRUE. + EXIT + END IF +END DO +END PROCEDURE intVec_isPresent1 + +!---------------------------------------------------------------------------- +! isPresent +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_isPresent2 +INTEGER(I4B) :: i, m, j +LOGICAL(LGT), ALLOCATABLE :: Search(:) +m = SIZE(VALUE) +ALLOCATE (Ans(m), Search(m)) +Search = .TRUE. +Ans = .FALSE. + !! +DO i = 1, SIZE(obj%Val) + DO j = 1, m + IF (Search(j)) THEN + IF (VALUE(j) .EQ. obj%Val(i)) THEN + Search(j) = .FALSE. + Ans(j) = .TRUE. + END IF + END IF + END DO +END DO + !! +END PROCEDURE intVec_isPresent2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 new file mode 100644 index 000000000..48e791fee --- /dev/null +++ b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 @@ -0,0 +1,284 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! + +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 25 Feb 2021 +! summary: This submodule implements get methods of [[IntVector_]] + +SUBMODULE(IntVector_GetMethod) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_1 +IF (ALLOCATED(obj%Val)) THEN + Val = IntVector(obj%Val) +END IF +END PROCEDURE intVec_get_1 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_2 +IF (ALLOCATED(obj%Val)) THEN + Val = IntVector(obj%Val(Indx)) +END IF +END PROCEDURE intVec_get_2 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_3 +IF (ALLOCATED(obj%Val)) THEN + Val = IntVector(obj%Val( & + & istart:& + & Input(default=SIZE(obj), option=iend):& + & Input(option=stride, default=1))) +END IF +END PROCEDURE intVec_get_3 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_4 +Val = IntVector(get(obj, TypeInt)) +END PROCEDURE intVec_get_4 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_5 +Val = IntVector(get(obj, Indx, TypeInt)) +END PROCEDURE intVec_get_5 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_6 +Val = IntVector(get(obj, iStart, iEnd, Stride, & + & TypeInt)) +END PROCEDURE intVec_get_6 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_7a +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val +END IF +END PROCEDURE intVec_get_7a +MODULE PROCEDURE intVec_get_7b +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val +END IF +END PROCEDURE intVec_get_7b +MODULE PROCEDURE intVec_get_7c +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val +END IF +END PROCEDURE intVec_get_7c +MODULE PROCEDURE intVec_get_7d +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val +END IF +END PROCEDURE intVec_get_7d + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_8a +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(Indx) +END IF +END PROCEDURE intVec_get_8a + +MODULE PROCEDURE intVec_get_8b +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(Indx) +END IF +END PROCEDURE intVec_get_8b + +MODULE PROCEDURE intVec_get_8c +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(Indx) +END IF +END PROCEDURE intVec_get_8c + +MODULE PROCEDURE intVec_get_8d +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(Indx) +END IF +END PROCEDURE intVec_get_8d + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_9a +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(iStart:iEnd:Stride) +END IF +END PROCEDURE intVec_get_9a + +MODULE PROCEDURE intVec_get_9b +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(iStart:iEnd:Stride) +END IF +END PROCEDURE intVec_get_9b + +MODULE PROCEDURE intVec_get_9c +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(iStart:iEnd:Stride) +END IF +END PROCEDURE intVec_get_9c + +MODULE PROCEDURE intVec_get_9d +IF (ALLOCATED(obj%Val)) THEN + Val = obj%Val(iStart:iEnd:Stride) +END IF +END PROCEDURE intVec_get_9d + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_10a +#include "./include/intvec_get_10.inc" +END PROCEDURE intVec_get_10a +MODULE PROCEDURE intVec_get_10b +#include "./include/intvec_get_10.inc" +END PROCEDURE intVec_get_10b +MODULE PROCEDURE intVec_get_10c +#include "./include/intvec_get_10.inc" +END PROCEDURE intVec_get_10c +MODULE PROCEDURE intVec_get_10d +#include "./include/intvec_get_10.inc" +END PROCEDURE intVec_get_10d + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_11a +#include "./include/intvec_get_11.inc" +END PROCEDURE intVec_get_11a +MODULE PROCEDURE intVec_get_11b +#include "./include/intvec_get_11.inc" +END PROCEDURE intVec_get_11b +MODULE PROCEDURE intVec_get_11c +#include "./include/intvec_get_11.inc" +END PROCEDURE intVec_get_11c +MODULE PROCEDURE intVec_get_11d +#include "./include/intvec_get_11.inc" +END PROCEDURE intVec_get_11d + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_12a +#include "./include/intvec_get_12.inc" +END PROCEDURE intVec_get_12a +MODULE PROCEDURE intVec_get_12b +#include "./include/intvec_get_12.inc" +END PROCEDURE intVec_get_12b +MODULE PROCEDURE intVec_get_12c +#include "./include/intvec_get_12.inc" +END PROCEDURE intVec_get_12c +MODULE PROCEDURE intVec_get_12d +#include "./include/intvec_get_12.inc" +END PROCEDURE intVec_get_12d + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_get_13a +#include "./include/intvec_get_13.inc" +END PROCEDURE intVec_get_13a +MODULE PROCEDURE intVec_get_13b +#include "./include/intvec_get_13.inc" +END PROCEDURE intVec_get_13b +MODULE PROCEDURE intVec_get_13c +#include "./include/intvec_get_13.inc" +END PROCEDURE intVec_get_13c +MODULE PROCEDURE intVec_get_13d +#include "./include/intvec_get_13.inc" +END PROCEDURE intVec_get_13d + +!---------------------------------------------------------------------------- +! getPointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_getPointer_1 +Val => obj +END PROCEDURE intVec_getPointer_1 + +!---------------------------------------------------------------------------- +! getPointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_getPointer_2 +Val => obj%Val +END PROCEDURE intVec_getPointer_2 + +!---------------------------------------------------------------------------- +! IndexOf +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_getIndex1 +Ans = MINLOC(ABS(obj%Val - val), 1) +END PROCEDURE intVec_getIndex1 + +!---------------------------------------------------------------------------- +! IndexOf +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_getIndex2 +INTEGER(I4B) :: i, j, m +LOGICAL(LGT), ALLOCATABLE :: Search(:) +! +m = SIZE(val) +ALLOCATE (Search(m), Ans(m)) +Search = .TRUE. +Ans = 0 + +DO i = 1, SIZE(obj%Val) + DO j = 1, m + IF (Search(j)) THEN + IF (val(j) .EQ. obj%Val(i)) THEN + Search(j) = .FALSE. + Ans(j) = i + END IF + END IF + END DO +END DO +END PROCEDURE intVec_getIndex2 + +END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_IOMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_IOMethod@Methods.F90 new file mode 100644 index 000000000..f0c43a5e9 --- /dev/null +++ b/src/submodules/IntVector/src/IntVector_IOMethod@Methods.F90 @@ -0,0 +1,55 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 28 Feb 2021 +! summary: This contains Input/Output methods for [[IntVector_]] + +SUBMODULE(IntVector_IOMethod) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_Display1 +INTEGER(I4B) :: j +CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) +CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) +DO j = 1, SIZE(obj) + CALL Display(obj(j), & + & msg="# "//TRIM(msg)//"( " & + & //TOSTRING(j)//" ) ", & + & unitNo=UnitNo, orient=orient) +END DO +END PROCEDURE intVec_Display1 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_Display2 +IF (isAllocated(obj)) THEN + CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) + CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) + CALL Display(Val=obj%Val, msg='', unitNo=unitNo, orient=orient) +END IF +END PROCEDURE intVec_Display2 + +END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 new file mode 100644 index 000000000..859f575d4 --- /dev/null +++ b/src/submodules/IntVector/src/IntVector_SetMethod@Methods.F90 @@ -0,0 +1,102 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This submodule implements set methods of [[IntVector_]] + +SUBMODULE(IntVector_SetMethod) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_setTotalDimension +obj%tDimension = tDimension +END PROCEDURE IntVec_setTotalDimension + +!---------------------------------------------------------------------------- +! setMethod +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_set1 +IF (ALLOCATED(obj%val)) THEN + IF (SIZE(VALUE) .EQ. 1) THEN + obj%val(Indx) = VALUE(1) + ELSE + obj%val(Indx) = VALUE + END IF +END IF +END PROCEDURE intVec_set1 + +!---------------------------------------------------------------------------- +! setMethod +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intVec_set2 +IF (ALLOCATED(obj%val)) THEN + obj%val(Indx) = VALUE +END IF +END PROCEDURE intVec_set2 + +!---------------------------------------------------------------------------- +! RemoveDuplicate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_RemoveDuplicates_1 +! Define internal variables +INTEGER(I4B) :: i, k, j, N +INTEGER(I4B), ALLOCATABLE :: Res(:) +LOGICAL(LGT) :: isok + +isok = ALLOCATED(obj%val) +IF (.NOT. isok) RETURN + +N = SIZE(obj%val) +isok = N .GT. 0 +IF (.NOT. isok) RETURN + +ALLOCATE (Res(N)) +Res = 0 +Res(1) = obj%val(1) +k = 1 +DO i = 2, N + IF (.NOT. ANY(Res .EQ. obj%val(i))) THEN + k = k + 1 + Res(k) = obj%val(i) + END IF +END DO +obj%val = Res(1:k) +DEALLOCATE (Res) +END PROCEDURE IntVec_RemoveDuplicates_1 + +!---------------------------------------------------------------------------- +! Repeat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IntVec_Repeat_1 +Ans = REPEAT(obj%val, rtimes) +END PROCEDURE IntVec_Repeat_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/IntVector/src/include/intvec_get_10.inc b/src/submodules/IntVector/src/include/intvec_get_10.inc new file mode 100644 index 000000000..e2b591ab4 --- /dev/null +++ b/src/submodules/IntVector/src/include/intvec_get_10.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +INTEGER(I4B) :: N, i, tNodes, r1, r2 +N = SIZE(obj) +tNodes = 0 +DO i = 1, N + tNodes = tNodes + SIZE(obj(i)%Val) +END DO +!! +ALLOCATE (Val(tNodes)) +!! +tNodes = 0; r1 = 0; r2 = 0 +DO i = 1, N + r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%Val) + Val(r1:r2) = obj(i)%Val +END DO +!! \ No newline at end of file diff --git a/src/submodules/IntVector/src/include/intvec_get_11.inc b/src/submodules/IntVector/src/include/intvec_get_11.inc new file mode 100644 index 000000000..fc400ccb9 --- /dev/null +++ b/src/submodules/IntVector/src/include/intvec_get_11.inc @@ -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 +! + +INTEGER(I4B) :: N, i, M +!! +N = SIZE(obj) +M = SIZE(Indx) +!! +ALLOCATE (Val(N * M)) +!! +DO i = 1, N + Val((i - 1) * M + 1:i * M) = obj(i)%Val(Indx) +END DO +!! \ No newline at end of file diff --git a/src/submodules/IntVector/src/include/intvec_get_12.inc b/src/submodules/IntVector/src/include/intvec_get_12.inc new file mode 100644 index 000000000..7e76c48fe --- /dev/null +++ b/src/submodules/IntVector/src/include/intvec_get_12.inc @@ -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 +! + +INTEGER(I4B) :: N, i, M +!! +N = SIZE(obj) +M = 1 + (iEnd - iStart) / Stride +!! +ALLOCATE (Val(M * N)) +!! +DO i = 1, N + Val((i - 1) * M + 1:i * M) = obj(i)%Val(iStart:iEnd:Stride) +END DO +!! \ No newline at end of file diff --git a/src/submodules/IntVector/src/include/intvec_get_13.inc b/src/submodules/IntVector/src/include/intvec_get_13.inc new file mode 100644 index 000000000..e2c817f0d --- /dev/null +++ b/src/submodules/IntVector/src/include/intvec_get_13.inc @@ -0,0 +1,18 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +val = obj%val(indx) \ No newline at end of file diff --git a/src/submodules/IterationData/CMakeLists.txt b/src/submodules/IterationData/CMakeLists.txt new file mode 100644 index 000000000..99076a595 --- /dev/null +++ b/src/submodules/IterationData/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}/IterationData_Method@ConstructorMethods.F90 + ${src_path}/IterationData_Method@IOMethods.F90 +) \ No newline at end of file diff --git a/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 b/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 new file mode 100644 index 000000000..4317fb565 --- /dev/null +++ b/src/submodules/IterationData/src/IterationData_Method@ConstructorMethods.F90 @@ -0,0 +1,179 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(IterationData_Method) ConstructorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE iterdata_Initiate + IF( PRESENT( MaxIter ) ) obj%MaxIter = MaxIter + IF( PRESENT( IterationNumber ) ) obj%IterationNumber = IterationNumber + IF( PRESENT( ResidualError0 ) ) obj%ResidualError0 = ResidualError0 + IF( PRESENT( ResidualError ) ) obj%ResidualError = ResidualError + IF( PRESENT( ResidualTolerance ) ) obj%ResidualTolerance = ResidualTolerance + IF( PRESENT( SolutionError0 ) ) obj%SolutionError0 = SolutionError0 + IF( PRESENT( SolutionError ) ) obj%SolutionError = SolutionError + IF( PRESENT( SolutionTolerance ) ) obj%SolutionTolerance = SolutionTolerance + IF( PRESENT( ConvergenceType ) ) obj%ConvergenceType = ConvergenceType + IF( PRESENT( ConvergenceIn ) ) obj%ConvergenceIn = ConvergenceIn + IF( PRESENT( NormType ) ) obj%NormType = NormType + IF( PRESENT( Converged ) ) obj%Converged = Converged + IF( PRESENT( TimeAtStart ) ) obj%TimeAtStart = TimeAtStart + IF( PRESENT( TimeAtEnd ) ) obj%TimeAtEnd = TimeAtEnd +END PROCEDURE iterdata_Initiate + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE iterdata_Deallocate + obj%MaxIter = 0 + obj%IterationNumber = 0 + obj%ResidualError = 0.0 + obj%ResidualError0 = 0.0 + obj%ResidualTolerance = 0.0 + obj%SolutionError = 0.0 + obj%SolutionError0 = 0.0 + obj%SolutionTolerance = 0.0 + obj%ConvergenceType = 0 + obj%ConvergenceIn = 0 + obj%NormType = 0 + obj%Converged = .FALSE. + obj%TimeAtStart = 0.0 + obj%TimeAtEnd = 0.0 + IF( allocated( obj%convergenceData ) ) DEALLOCATE( obj%convergenceData ) + IF( allocated( obj%header ) ) DEALLOCATE( obj%header ) +END PROCEDURE iterdata_Deallocate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE iterdata_isConverged + LOGICAL( LGT ) :: l1, l2 + !! + SELECT CASE( obj%convergenceIn ) + !! + !! Convergence in residual + !! + CASE( ConvergenceInRes ) + ! !! + IF( obj%convergenceType .EQ. RelativeConvergence ) THEN + !! + ans = checkConvergence( & + & errorAtStart=obj%residualError0, & + & errorAtEnd=obj%residualError, & + & tolerance=obj%residualTolerance ) + !! + ELSE + !! + ans = checkConvergence( & + & errorAtStart=1.0_DFP, & + & errorAtEnd=obj%residualError, & + & tolerance=obj%residualTolerance ) + !! + END IF + !! + !! Convergence in sol + !! + CASE( ConvergenceInSol ) + !! + IF( obj%convergenceType .EQ. RelativeConvergence ) THEN + !! + ans = checkConvergence( & + & errorAtStart=obj%solutionError0, & + & errorAtEnd=obj%solutionError, & + & tolerance=obj%solutionTolerance ) + !! + ELSE + !! + ans = checkConvergence( & + & errorAtStart=1.0_DFP, & + & errorAtEnd=obj%solutionError, & + & tolerance=obj%solutionTolerance ) + !! + END IF + !! + !! Convergence in both solution and residual + !! + CASE( ConvergenceInResSol ) + !! + IF( obj%convergenceType .EQ. RelativeConvergence ) THEN + !! + ans = checkConvergence( & + & errorAtStart=obj%residualError0, & + & errorAtEnd=obj%residualError, & + & tolerance=obj%residualTolerance ) & + & .AND. & + & checkConvergence( & + & errorAtStart=obj%solutionError0, & + & errorAtEnd=obj%solutionError, & + & tolerance=obj%solutionTolerance ) + !! + ELSE + !! + ans = checkConvergence( & + & errorAtStart=1.0_DFP, & + & errorAtEnd=obj%residualError, & + & tolerance=obj%residualTolerance ) & + & .AND. & + & checkConvergence( & + & errorAtStart=1.0_DFP, & + & errorAtEnd=obj%solutionError, & + & tolerance=obj%solutionTolerance ) + !! + END IF + !! + !! + !! + END SELECT + !! + !! + !! +END PROCEDURE iterdata_isConverged + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION checkConvergence( errorAtStart, errorAtEnd, tolerance ) & + & RESULT( ans ) + !! + REAL( DFP ), INTENT( IN ) :: errorAtStart + REAL( DFP ), INTENT( IN ) :: errorAtEnd + REAL( DFP ), INTENT( IN ) :: tolerance + LOGICAL( LGT ) :: ans + !! + !! + IF( errorAtEnd .LE. tolerance * errorAtStart ) THEN + Ans = .TRUE. + ELSE + Ans = .FALSE. + END IF + !! +END FUNCTION checkConvergence + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE ConstructorMethods \ No newline at end of file diff --git a/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 b/src/submodules/IterationData/src/IterationData_Method@IOMethods.F90 new file mode 100644 index 000000000..d316aa439 --- /dev/null +++ b/src/submodules/IterationData/src/IterationData_Method@IOMethods.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(IterationData_Method) IOMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE iterdata_Display +CALL Display(TRIM(msg), unitno) +CALL Display(obj%maxIter, 'maxIter: ', unitno) +CALL Display(obj%iterationNumber, 'iterationNumber: ', unitno) +CALL Display(obj%residualError0, 'residualError0: ', unitno) +CALL Display(obj%residualError, 'residualError: ', unitno) +CALL Display(obj%residualTolerance, 'residualTolerance: ', unitno) +CALL Display(obj%solutionError0, 'solutionError0: ', unitno) +CALL Display(obj%solutionError, 'solutionError: ', unitno) +CALL Display(obj%solutionTolerance, 'solutionTolerance: ', unitno) +CALL Display(obj%convergenceType, 'convergenceType: ', unitno) +CALL Display(obj%convergenceIn, 'convergenceIn: ', unitno) +CALL Display(obj%normType, 'normType: ', unitno) +CALL Display(obj%converged, 'converged: ', unitno) +CALL Display(obj%timeAtStart, 'timeAtStart: ', unitno) +CALL Display(obj%timeAtEnd, 'timeAtEnd: ', unitno) +END PROCEDURE iterdata_Display + +END SUBMODULE IOMethods diff --git a/src/submodules/KeyValue/CMakeLists.txt b/src/submodules/KeyValue/CMakeLists.txt new file mode 100644 index 000000000..f5e7b9296 --- /dev/null +++ b/src/submodules/KeyValue/CMakeLists.txt @@ -0,0 +1,15 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/KeyValue_Method@Constructor.F90 + ${src_path}/KeyValue_Method@getMethod.F90 + ${src_path}/KeyValue_Method@setMethod.F90 +) \ No newline at end of file diff --git a/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 b/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 new file mode 100644 index 000000000..183bd13ea --- /dev/null +++ b/src/submodules/KeyValue/src/KeyValue_Method@Constructor.F90 @@ -0,0 +1,505 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This submodule contains implementation of construction methods [[keyvalue_]] + +SUBMODULE(KeyValue_Method) Constructor +USE BaseMethod +IMPLICIT NONE + +CONTAINS +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate1 + obj%DataType = Real_Rank_0 + obj%Key = Key + obj%Value = RESHAPE( [Value], [1,1] ) +END PROCEDURE Initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate2 + obj%DataType = Real_Rank_0 + obj%Key = Key + obj%Value = RESHAPE( [Value], [1,1] ) +END PROCEDURE Initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate3 + obj%DataType = Real_Rank_1 + obj%Key = Key + obj%Value = RESHAPE( Value, [SIZE( Value ), 1] ) +END PROCEDURE Initiate3 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate4 + obj%DataType = Real_Rank_1 + obj%Key = Key + obj%Value = RESHAPE( Value, [SIZE( Value ), 1] ) +END PROCEDURE Initiate4 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate5 + obj%DataType = Real_Rank_2 + obj%Key = Key + obj%Value = Value +END PROCEDURE Initiate5 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate6 + obj%DataType = Real_Rank_2 + obj%Key = Key + obj%Value = Value +END PROCEDURE Initiate6 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate7 + obj%DataType = Int_Rank_0 + obj%Key = Key + obj%Value = RESHAPE( [Value], [1,1] ) +END PROCEDURE Initiate7 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate8 + obj%DataType = Int_Rank_0 + obj%Key = Key + obj%Value = REAL( RESHAPE( [Value], [1,1] ), DFP ) +END PROCEDURE Initiate8 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate9 + obj%DataType = Int_Rank_1 + obj%Key = Key + obj%Value = REAL( RESHAPE( Value, [SIZE( Value ), 1 ] ), DFP ) +END PROCEDURE Initiate9 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate10 + obj%DataType = Int_Rank_1 + obj%Key = Key + obj%Value = REAL( RESHAPE( Value, [SIZE( Value ), 1 ] ), DFP ) +END PROCEDURE Initiate10 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate11 + obj%DataType = Int_Rank_2 + obj%Key = Key + obj%Value = REAL( Value, DFP ) +END PROCEDURE Initiate11 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate12 + obj%DataType = Int_Rank_2 + obj%Key = Key + obj%Value = REAL( Value, DFP ) +END PROCEDURE Initiate12 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Initiate13 + obj%DataType = obj2%DataType + obj%Key = obj2%Key + IF( ALLOCATED( obj2%Value ) ) THEN + obj%Value = obj2%Value + END IF +END PROCEDURE Initiate13 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor1 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor1 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor2 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor2 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor3 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor3 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor4 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor4 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor5 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor5 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor6 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor6 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor7 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor7 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor8 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor8 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor9 + CALL Initiate( Ans, Key, Value ) +END PROCEDURE Constructor9 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor10 + CALL Initiate(Ans, Key, Value ) +END PROCEDURE Constructor10 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor11 + CALL Initiate(Ans, Key, Value ) +END PROCEDURE Constructor11 + +!---------------------------------------------------------------------------- +! KeyValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor12 + CALL Initiate(Ans, Key, Value ) +END PROCEDURE Constructor12 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE keyvalue_display + INTEGER( I4B ) :: I + CHARACTER( LEN = 6 ) :: s + + I = stdout + + IF( PRESENT( UnitNo ) ) I = UnitNo + SELECT CASE( obj%DataType ) + CASE( REAL_RANK_0 ) + s = "Rank0" + CASE( REAL_RANK_1 ) + s = "Rank1" + CASE( REAL_RANK_2 ) + s = "Rank2" + CASE( INT_RANK_0 ) + s = "Rank0" + CASE( INT_RANK_1 ) + s = "Rank1" + CASE( INT_RANK_2 ) + s = "Rank2" + END SELECT + + IF( LEN_TRIM( msg ) .NE. 0 ) CALL Display( msg, I ) + IF( ALLOCATED( obj%Value ) ) THEN + CALL Display( obj%Value, & + & s // " :: " // TRIM( obj%Key%Raw ) // " :: ", UnitNo = I ) + ELSE + CALL Display( s // " :: " // TRIM( obj%Key%Raw ) // " :: ", UnitNo = I ) + END IF +END PROCEDURE keyvalue_display + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mp_display + INTEGER( I4B ) :: n, i, j + + I = stdout + IF( PRESENT( UnitNo ) ) I = UnitNo + n = SIZE( obj ) + CALL BlankLines( UnitNo = I ) + DO j = 1, n + CALL display( obj( j ), msg, UnitNo = I ) + CALL BlankLines( UnitNo = I ) + END DO + +END PROCEDURE mp_display + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Equal1 + Ans = obj%Key .EQ. String( Key ) +END PROCEDURE Equal1 + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Equal2 + Ans = obj%Key .EQ. String( Key ) +END PROCEDURE Equal2 + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Equal3 + Ans = obj%Key .EQ. Key +END PROCEDURE Equal3 + +!---------------------------------------------------------------------------- +! Equal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Equal4 + Ans = obj%Key .EQ. Key +END PROCEDURE Equal4 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE keyvalue_deallocate + IF( ALLOCATED( obj%Value ) ) DEALLOCATE( obj%Value ) +END PROCEDURE keyvalue_deallocate + +END SUBMODULE Constructor + +! CONTAINS + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_1( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! CHARACTER( LEN = * ), INTENT( IN ) :: Key +! REAL( DFP ), INTENT( IN ) :: Value + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_1 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_2( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! TYPE( String ), INTENT( IN ) :: Key +! REAL( DFP ), INTENT( IN ) :: Value + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_2 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_3( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! CHARACTER( LEN = * ), INTENT( IN ) :: Key +! REAL( DFP ), INTENT( IN ) :: Value( : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_3 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_4( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! TYPE( String ), INTENT( IN ) :: Key +! REAL( DFP ), INTENT( IN ) :: Value( : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_4 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_5( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! CHARACTER( LEN = * ), INTENT( IN ) :: Key +! REAL( DFP ), INTENT( IN ) :: Value( :, : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_5 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_6( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! TYPE( String ), INTENT( IN ) :: Key +! REAL( DFP ), INTENT( IN ) :: Value( :, : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_6 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_7( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! CHARACTER( LEN = * ), INTENT( IN ) :: Key +! INTEGER( I4B ), INTENT( IN ) :: Value + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_7 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_8( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! TYPE( String ), INTENT( IN ) :: Key +! INTEGER( I4B ), INTENT( IN ) :: Value + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_8 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_9( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! CHARACTER( LEN = * ), INTENT( IN ) :: Key +! INTEGER( I4B ), INTENT( IN ) :: Value( : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_9 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_10( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! TYPE( String ), INTENT( IN ) :: Key +! INTEGER( I4B ), INTENT( IN ) :: Value( : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_10 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_11( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! CHARACTER( LEN = * ), INTENT( IN ) :: Key +! INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_11 + +! !---------------------------------------------------------------------------- +! ! KeyValue_Pointer +! !---------------------------------------------------------------------------- + +! FUNCTION Constructor_12( Key, Value ) RESULT( Ans ) +! CLASS( keyValue_ ), POINTER :: Ans +! TYPE( String ), INTENT( IN ) :: Key +! INTEGER( I4B ), INTENT( IN ) :: Value( :, : ) + +! ALLOCATE( Ans ) +! CALL Initiate( Ans, Key, Value ) +! END FUNCTION Constructor_12 \ No newline at end of file diff --git a/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 b/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 new file mode 100644 index 000000000..ceaf46ca5 --- /dev/null +++ b/src/submodules/KeyValue/src/KeyValue_Method@getMethod.F90 @@ -0,0 +1,186 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(KeyValue_Method) getMethod + !! This submodule includes implementation of method to set values in + !! [[keyvalue_]] +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! getKey +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getKey1 + Key = TRIM( obj%Key%Raw ) +END PROCEDURE getKey1 + +!---------------------------------------------------------------------------- +! getKey +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getKey2 + Key = obj%Key +END PROCEDURE getKey2 + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getValue1 + Value = obj%Value( 1, 1 ) +END PROCEDURE getValue1 + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getValue2 + Value = obj%Value( :, 1 ) +END PROCEDURE getValue2 + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getValue3 + Value = obj%Value +END PROCEDURE getValue3 + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getValue4 + Value = INT( obj%Value( 1, 1 ) ) +END PROCEDURE getValue4 + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getValue5 + Value = INT( obj%Value( :, 1 ) ) +END PROCEDURE getValue5 + +!---------------------------------------------------------------------------- +! getValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getValue6 + Value = INT( obj%Value ) +END PROCEDURE getValue6 + +!---------------------------------------------------------------------------- +! INDEX +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Index1 + INTEGER( I4B ) :: I + Ans = 0 + DO I = 1, SIZE( obj ) + IF( obj( I ) .EQ. Key ) THEN + Ans = I + EXIT + END IF + END DO +END PROCEDURE Index1 + +!---------------------------------------------------------------------------- +! INDEX +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Index2 + INTEGER( I4B ) :: I + Ans = 0 + DO I = 1, SIZE( obj ) + IF( obj( I ) .EQ. Key ) THEN + Ans = I + EXIT + END IF + END DO +END PROCEDURE Index2 + +!---------------------------------------------------------------------------- +! Present +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Present1 + INTEGER( I4B ) :: I + Ans = .FALSE. + DO I = 1, SIZE( obj ) + IF( obj( I ) .EQ. Key ) THEN + Ans = .TRUE. + EXIT + END IF + END DO +END PROCEDURE Present1 + +!---------------------------------------------------------------------------- +! Present +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Present2 + INTEGER( I4B ) :: I + Ans = .FALSE. + DO I = 1, SIZE( obj ) + IF( obj( I ) .EQ. Key ) THEN + Ans = .TRUE. + EXIT + END IF + END DO +END PROCEDURE Present2 + +!---------------------------------------------------------------------------- +! Contains +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Contains1 + INTEGER( I4B ) :: I + + Ans = .FALSE. + DO I = 1, SIZE( obj ) + IF( obj( I ) .EQ. Key ) THEN + Ans = .TRUE. + EXIT + END IF + END DO + +END PROCEDURE Contains1 + +!---------------------------------------------------------------------------- +! Contains +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Contains2 + INTEGER( I4B ) :: I + Ans = .FALSE. + DO I = 1, SIZE( obj ) + IF( obj( I ) .EQ. Key ) THEN + Ans = .TRUE. + EXIT + END IF + END DO +END PROCEDURE Contains2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE getMethod diff --git a/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 b/src/submodules/KeyValue/src/KeyValue_Method@setMethod.F90 new file mode 100644 index 000000000..6c0da142e --- /dev/null +++ b/src/submodules/KeyValue/src/KeyValue_Method@setMethod.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 + +SUBMODULE(KeyValue_Method) setMethod + !! This submodule includes implementation of method to set values in + !! [[keyvalue_]] +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setKey1 + obj%Key = Key +END PROCEDURE setKey1 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE setKey2 + obj%Key = Key +END PROCEDURE setKey2 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetValue1 + CALL Initiate( obj, obj%Key, Value ) +END PROCEDURE SetValue1 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetValue2 + CALL Initiate( obj, obj%Key, Value ) +END PROCEDURE SetValue2 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetValue3 + CALL Initiate( obj, obj%Key, Value ) +END PROCEDURE SetValue3 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetValue4 + CALL Initiate( obj, obj%Key, Value ) +END PROCEDURE SetValue4 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetValue5 + CALL Initiate( obj, obj%Key, Value ) +END PROCEDURE SetValue5 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetValue6 + CALL Initiate( obj, obj%Key, Value ) +END PROCEDURE SetValue6 + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE keyvalue_append + INTEGER( I4B ) :: I, Indx, tSize + LOGICAL( LGT ) :: isPresent + + IF( .NOT. ALLOCATED( obj ) ) THEN + ALLOCATE( obj( 1 ) ) + obj( 1 ) = KeyValobj + ELSE + tSize = SIZE( obj ) + DO I = 1, tSize + isPresent = obj( I ) .EQ. KeyValobj%Key + IF( isPresent ) THEN + Indx = I + EXIT + END IF + END DO + + IF( isPresent ) THEN + + obj( Indx ) = KeyValobj + + ELSE + + BLOCK + TYPE( keyvalue_ ) :: Dummyobj( tSize ) + + DO I = 1, tSize + Dummyobj( I ) = obj( I ) + END DO + + DEALLOCATE( obj ) + ALLOCATE( obj( tSize + 1 ) ) + + DO I = 1, tSize + obj( I ) = Dummyobj( I ) + END DO + + obj( tSize + 1 ) = KeyValobj + + END BLOCK + END IF + END IF + +END PROCEDURE keyvalue_append + +END SUBMODULE setMethod \ No newline at end of file diff --git a/src/submodules/Lapack/CMakeLists.txt b/src/submodules/Lapack/CMakeLists.txt new file mode 100644 index 000000000..2ae05b6c4 --- /dev/null +++ b/src/submodules/Lapack/CMakeLists.txt @@ -0,0 +1,41 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +IF( USE_LAPACK95 ) + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/GE_CompRoutineMethods@Methods.F90 + ${src_path}/GE_EigenValueMethods@Methods.F90 + ${src_path}/GE_LUMethods@Methods.F90 + ${src_path}/GE_LinearSolveMethods@Methods.F90 + ${src_path}/GE_SingularValueMethods@Methods.F90 + ) +ENDIF( ) + +IF( USE_LAPACK95 ) + SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/Sym_CompRoutineMethods@Methods.F90 + ${src_path}/Sym_EigenValueMethods@Methods.F90 + ${src_path}/Sym_LUMethods@Methods.F90 + ${src_path}/Sym_LinearSolveMethods@Methods.F90 + ${src_path}/Sym_SingularValueMethods@Methods.F90 + ) +ENDIF( ) + diff --git a/src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 b/src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 new file mode 100644 index 000000000..f7001e886 --- /dev/null +++ b/src/submodules/Lapack/src/GE_CompRoutineMethods@Methods.F90 @@ -0,0 +1,74 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(GE_CompRoutineMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ConditionNo +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_ConditionNo_1 +REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: tempA +tempA = A +CALL getLU(A=tempA, RCOND=ans, NORM=NORM) +ans = 1.0_DFP / ans +END PROCEDURE ge_ConditionNo_1 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat1 +INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) +invA = A +CALL getLU(A=invA, IPIV=ipiv, info=info) +CALL GETRI(A=invA, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat1 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat2 +INTEGER(I4B) :: info +invA = A +CALL GETRI(A=invA, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat2 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat3 +INTEGER(I4B) :: info +CALL GETRI(A=A, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat3 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat4 +INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) +CALL getLU(A=A, IPIV=ipiv, info=info) +CALL GETRI(A=A, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat4 + +END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 b/src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 new file mode 100644 index 000000000..66e2098e7 --- /dev/null +++ b/src/submodules/Lapack/src/GE_EigenValueMethods@Methods.F90 @@ -0,0 +1,203 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +! the implementation of deig, zeig, deigvals, and zeigvals are copied from +! linalg.f90 available in https://github.com/certik/fortran-utils +! and are modified to suit the needs of EASIFEM library + +SUBMODULE(GE_EigenValueMethods) Methods +USE BaseMethod, ONLY: ErrorMsg, GEEV, stderr, stdout, tostring, & + Display, Input +USE AssertUtility +IMPLICIT NONE +COMPLEX(DFPC), PARAMETER :: i_ = (0.0_DFP, 1.0_DFP) +CONTAINS + +!---------------------------------------------------------------------------- +! getEig +!---------------------------------------------------------------------------- + +MODULE PROCEDURE deig +! LAPACK variables for DGEEV: +REAL(DFP), ALLOCATABLE :: At(:, :), vr(:, :), wi(:), wr(:) +INTEGER(I4B) :: info, lda, ldvr, n, i +LOGICAL(LGT) :: destroy0 + +CHARACTER(*), PARAMETER :: myName = "deig" + +destroy0 = Input(default=.TRUE., option=destroy) +lda = SIZE(A, 1) +n = SIZE(A, 2) +ldvr = n +! CALL Assert(Mat=A, s=[n, n], msg="[ARG ERROR] :: A should be square", & +! file=__FILE__, line=__LINE__, routine=myName) +! CALL Assert(n1=SIZE(lam), n2=n, msg="[ARG ERROR] :: size of lam should be "// & +! "equal to "//tostring(n), file=__FILE__, line=__LINE__, & +! routine=myName) +! CALL Assert(mat=c, s=[n, n], msg="[ARG ERROR] :: shape of c should be"// & +! "the same as one of A", file=__FILE__, line=__LINE__, & +! routine=myName) + +ALLOCATE (wr(n), wi(n), vr(ldvr, n)) +IF (.NOT. destroy0) THEN + ALLOCATE (At(lda, n)) + At = A + CALL GEEV(A=At, WR=wr, WI=wi, VR=vr, INFO=info) +ELSE + CALL GEEV(A=A, WR=wr, WI=wi, VR=vr, INFO=info) +END IF + +IF (info .NE. 0) CALL GeevErrorMsg(info, n) + +lam = wr + i_ * wi +! as DGEEV has a rather complicated way of returning the eigenvectors, +! it is necessary to build the complex array of eigenvectors from +! two real arrays: +DO i = 1, n + IF (wi(i) > 0.0) THEN ! first of two conjugate eigenvalues + c(:, i) = vr(:, i) + i_ * vr(:, i + 1) + ELSEIF (wi(i) < 0.0_DFP) THEN ! second of two conjugate eigenvalues + c(:, i) = vr(:, i - 1) - i_ * vr(:, i) + ELSE + c(:, i) = vr(:, i) + END IF +END DO + +END PROCEDURE deig + +!---------------------------------------------------------------------------- +! getEig +!---------------------------------------------------------------------------- + +MODULE PROCEDURE zeig +! LAPACK variables: +INTEGER(I4B) :: info, ldvr, n +REAL(DFP), ALLOCATABLE :: rwork(:) +COMPLEX(DFPC), ALLOCATABLE :: vr(:, :) +LOGICAL(LGT) :: destroy0 + +CHARACTER(*), PARAMETER :: myName = "zeig" + +destroy0 = Input(default=.TRUE., option=destroy) +n = SIZE(A, 2) +ldvr = n +! CALL Assert(Mat=A, s=[n, n], msg="[ARG ERROR] :: A should be square", & +! file=__FILE__, line=__LINE__, routine=myName) +! CALL Assert(n1=SIZE(lam), n2=n, msg="[ARG ERROR] :: size of lam should be "// & +! "equal to "//tostring(n), file=__FILE__, line=__LINE__, & +! routine=myName) +! CALL Assert(mat=c, s=[n, n], msg="[ARG ERROR] :: shape of c should be"// & +! "the same as one of A", file=__FILE__, line=__LINE__, & +! routine=myName) +ALLOCATE (vr(ldvr, n)) +IF (.NOT. destroy0) THEN + c = A + CALL GEEV(A=c, W=lam, VR=vr, INFO=info) + c = vr +ELSE + CALL GEEV(A=A, W=lam, VR=c, INFO=info) +END IF + +IF (info .NE. 0) CALL GeevErrorMsg(info, n) + +END PROCEDURE zeig + +!---------------------------------------------------------------------------- +! getEigVals +!---------------------------------------------------------------------------- + +MODULE PROCEDURE deigvals +! LAPACK variables for DGEEV: +REAL(DFP), ALLOCATABLE :: At(:, :), wi(:), wr(:) +INTEGER(I4B) :: info, lda, ldvr, n, i +LOGICAL(LGT) :: destroy0 + +CHARACTER(*), PARAMETER :: myName = "deigvals" + +destroy0 = Input(default=.TRUE., option=destroy) +lda = SIZE(A, 1) +n = SIZE(A, 2) +ldvr = n + +ALLOCATE (wr(n), wi(n)) +IF (.NOT. destroy0) THEN + ALLOCATE (At(lda, n)) + At = A + CALL GEEV(A=At, WR=wr, WI=wi, INFO=info) +ELSE + CALL GEEV(A=A, WR=wr, WI=wi, INFO=info) +END IF + +IF (info .NE. 0) CALL GeevErrorMsg(info, n) + +lam = wr + i_ * wi +END PROCEDURE deigvals + +!---------------------------------------------------------------------------- +! getEigVals_2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE zeigvals +! LAPACK variables: +INTEGER(I4B) :: info, lda, n +COMPLEX(DFPC), ALLOCATABLE :: At(:, :) +LOGICAL(LGT) :: destroy0 + +CHARACTER(*), PARAMETER :: myName = "zeigvals" +destroy0 = Input(default=.TRUE., option=destroy) + +lda = SIZE(A, 1) +n = SIZE(A, 2) +IF (.NOT. destroy0) THEN + ALLOCATE (At(lda, n)) + At = A + CALL GEEV(A=At, W=lam, INFO=info) +ELSE + CALL GEEV(A=A, W=lam, INFO=info) +END IF +IF (info .NE. 0) CALL GeevErrorMsg(info, n) + +END PROCEDURE zeigvals + +!---------------------------------------------------------------------------- +! geevErrorMsg +!---------------------------------------------------------------------------- + +SUBROUTINE GeevErrorMsg(info, n) + INTEGER(I4B), INTENT(IN) :: info, n + + CALL Display(info, "LA_GEEV returned info = ", unitno=stdout) + IF (info .LT. 0) THEN + CALL Display("The "//tostring(-info)//"-th argument "// & + "had an illegal value.", unitno=stderr) + ELSE + CALL Display("The QR algorithm failed to compute all the", unitno=stderr) + CALL Display("eigenvalues, and no eigenvectors have been computed;", & + unitno=stderr) + CALL Display("elements "//tostring(info + 1)//":"//tostring(n)// & + " of WR and WI contain eigenvalues which converged.", & + unitno=stderr) + END IF + CALL ErrorMsg( & + & msg="ERROR IN LA_GEEV", & + & file=__FILE__, & + & line=__LINE__, & + & routine="zeigvals", & + & unitno=stderr) + STOP +END SUBROUTINE GeevErrorMsg + +END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_LUMethods@Methods.F90 b/src/submodules/Lapack/src/GE_LUMethods@Methods.F90 new file mode 100644 index 000000000..a529f9de1 --- /dev/null +++ b/src/submodules/Lapack/src/GE_LUMethods@Methods.F90 @@ -0,0 +1,144 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(GE_LUMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getLU_1 +LU = A +CALL GETRF(A=LU, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) +END PROCEDURE getLU_1 + +!---------------------------------------------------------------------------- +! getLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getLU_2 +CALL GETRF(A=A, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) +END PROCEDURE getLU_2 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_1 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_1 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_2 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_2 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_3 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +X = B +!! +CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_3 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_4 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +X = B +CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_4 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Inv_1 +invA = A +CALL GETRI(A=invA, IPIV=IPIV, info=info) +END PROCEDURE Inv_1 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Inv_2 +CALL GETRI(A=A, IPIV=IPIV, info=info) +END PROCEDURE Inv_2 + +END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 new file mode 100644 index 000000000..9ef6ff814 --- /dev/null +++ b/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 @@ -0,0 +1,74 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(GE_Lapack_Method) CompRoutineMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ConditionNo +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_ConditionNo_1 +REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: tempA +tempA = A +CALL getLU(A=tempA, RCOND=ans, NORM=NORM) +ans = 1.0_DFP / ans +END PROCEDURE ge_ConditionNo_1 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat1 +INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) +invA = A +CALL getLU(A=invA, IPIV=ipiv, info=info) +CALL GETRI(A=invA, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat1 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat2 +INTEGER(I4B) :: info +invA = A +CALL GETRI(A=invA, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat2 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat3 +INTEGER(I4B) :: info +CALL GETRI(A=A, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat3 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat4 +INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) +CALL getLU(A=A, IPIV=ipiv, info=info) +CALL GETRI(A=A, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat4 + +END SUBMODULE CompRoutineMethods diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 new file mode 100644 index 000000000..4888c962f --- /dev/null +++ b/src/submodules/Lapack/src/GE_Lapack_Method@EigenvalueMethods.F90 @@ -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 +! + +SUBMODULE(GE_Lapack_Method) EigenValueMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! DGEES +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dgees_1 +END PROCEDURE dgees_1 +END SUBMODULE EigenValueMethods \ No newline at end of file diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 new file mode 100644 index 000000000..ef6c8a86a --- /dev/null +++ b/src/submodules/Lapack/src/GE_Lapack_Method@LUMethods.F90 @@ -0,0 +1,144 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(GE_Lapack_Method) LUMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getLU_1 +LU = A +CALL GETRF(A=LU, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) +END PROCEDURE getLU_1 + +!---------------------------------------------------------------------------- +! getLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getLU_2 +CALL GETRF(A=A, IPIV=IPIV, RCOND=RCOND, NORM=NORM, info=info) +END PROCEDURE getLU_2 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_1 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_1 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_2 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +CALL GETRS(A=A, IPIV=IPIV, B=B, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_2 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_3 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +X = B +!! +CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_3 + +!---------------------------------------------------------------------------- +! LUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LUSolve_4 +CHARACTER(1) :: TRANS +!! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF +!! +X = B +CALL GETRS(A=A, IPIV=IPIV, B=X, TRANS=TRANS, info=info) +!! +END PROCEDURE LUSolve_4 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Inv_1 +invA = A +CALL GETRI(A=invA, IPIV=IPIV, info=info) +END PROCEDURE Inv_1 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Inv_2 +CALL GETRI(A=A, IPIV=IPIV, info=info) +END PROCEDURE Inv_2 + +END SUBMODULE LUMethods diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 new file mode 100644 index 000000000..27d562670 --- /dev/null +++ b/src/submodules/Lapack/src/GE_Lapack_Method@LinearSolveMethods.F90 @@ -0,0 +1,278 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(GE_Lapack_Method) LinearSolveMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_solve_1 +REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At +CHARACTER(LEN=1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +At = A +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=At, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_solve_1 + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_solve_2 +REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At +CHARACTER(LEN=1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +At = A +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=At, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_solve_2 + +!---------------------------------------------------------------------------- +! LinSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_1 +CHARACTER(LEN=1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_1 + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_2 +CHARACTER(LEN=1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_2 + +!---------------------------------------------------------------------------- +! LinSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_3 +CHARACTER(LEN=1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=B, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_3 + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_4 +CHARACTER(LEN=1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=B, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE LinearSolveMethods diff --git a/src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 b/src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 new file mode 100644 index 000000000..a015d5746 --- /dev/null +++ b/src/submodules/Lapack/src/GE_LinearSolveMethods@Methods.F90 @@ -0,0 +1,278 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(GE_LinearSolveMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_solve_1 +REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At +CHARACTER(1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +At = A +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=At, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_solve_1 + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_solve_2 +REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: At +CHARACTER(1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +At = A +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=At, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=At, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=At, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_solve_2 + +!---------------------------------------------------------------------------- +! LinSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_1 +CHARACTER(1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_1 + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_2 +CHARACTER(1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +X = B + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=X, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=X, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=X, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_2 + +!---------------------------------------------------------------------------- +! LinSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_3 +CHARACTER(1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=B, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_3 + +!---------------------------------------------------------------------------- +! Solve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_linsolve_4 +CHARACTER(1) :: TRANS + !! +IF (PRESENT(isTranspose)) THEN + IF (isTranspose) THEN + TRANS = "T" + ELSE + TRANS = "N" + END IF +ELSE + TRANS = "N" +END IF + !! +IF (SIZE(A, 1) .EQ. SIZE(A, 2)) THEN + CALL GESV(A=A, B=B, IPIV=IPIV, info=info) +ELSE + IF (PRESENT(SolverName)) THEN + SELECT CASE (TRIM(SolverName)) + !! + CASE ("GELS") + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + !! + CASE ("GELSD") + CALL GELSD(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + CASE ("GELSS") + CALL GELSS(A=A, B=B, RANK=RANK, RCOND=RCOND, S=S, info=info) + !! + END SELECT + ELSE + CALL GELS(A=A, B=B, TRANS=TRANS, info=info) + END IF +END IF + !! +END PROCEDURE ge_linsolve_4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 b/src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 new file mode 100644 index 000000000..f7c7f1938 --- /dev/null +++ b/src/submodules/Lapack/src/GE_SingularValueMethods@Methods.F90 @@ -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 +! + +! SUBMODULE(GE_SingularValueMethods) Methods +! USE BaseMethod +! IMPLICIT NONE +! CONTAINS +! +! !---------------------------------------------------------------------------- +! ! DGEES +! !---------------------------------------------------------------------------- +! +! ! MODULE PROCEDURE dgees_1 +! ! END PROCEDURE dgees_1 +! END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 new file mode 100644 index 000000000..63b7886bf --- /dev/null +++ b/src/submodules/Lapack/src/Sym_CompRoutineMethods@Methods.F90 @@ -0,0 +1,16 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! diff --git a/src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 new file mode 100644 index 000000000..63b7886bf --- /dev/null +++ b/src/submodules/Lapack/src/Sym_EigenValueMethods@Methods.F90 @@ -0,0 +1,16 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! diff --git a/src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 new file mode 100644 index 000000000..10b45b9d8 --- /dev/null +++ b/src/submodules/Lapack/src/Sym_LUMethods@Methods.F90 @@ -0,0 +1,507 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Sym_LUMethods) Methods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseMethod, ONLY: Display, Input, Arange, Zeros, GetTril, & +& GetTriu, ArgSort, tostring +USE F95_LAPACK, ONLY: SYTRF, LACPY, LAPMR, POTRF, SYTRS, SYTRI +USE F77_LAPACK, ONLY: SYCONV => LA_SYCONV +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLU_1 +CALL LACPY(A=A, B=LU, UPLO=UPLO) +CALL SYTRF(A=LU, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +END PROCEDURE SymGetLU_1 + +!---------------------------------------------------------------------------- +! GetLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLU_2 +CALL SYTRF(A=A, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +END PROCEDURE SymGetLU_2 + +!---------------------------------------------------------------------------- +! GetLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLDL_1 +CHARACTER(1) :: luplo +INTEGER(I4B) :: linfo, n +INTEGER(I4B), ALLOCATABLE :: work(:, :) +! +! work(1:n, 1) = ipiv(:) from sytrf +! work(1:n, 2) = swap_(:) block diagonal information +! work(1:n, 3) = pivots(:) cleaned version of ipiv +! work(1:n, 4) = perm cleaned version of ipiv +! +n = SIZE(A, 1) +ALLOCATE (work(n, 4)) +luplo = INPUT(option=UPLO, default="U") +LU = 0.0_DFP +! +! Copy data in LU from A +! +CALL LACPY(A=A, B=LU, UPLO=luplo) +! +! Call SYTRF +! +CALL SYTRF(A=LU, UPLO=luplo, IPIV=work(:, 1), INFO=linfo) +! +! Clean the ipiv0 returned by SYTRF +! +CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & + & swap_=work(:, 2), pivots=work(:, 3), info=linfo) +! +CALL LDL_GET_D_and_L(D=D, E=E, ldu=lu, & + & pivs=work(:, 3), uplo=luplo) +! +CALL LDL_CONSTRUCT_TRI_FACTOR(lu=lu, swap_=work(:, 2), & + & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) +! +IF (PRESENT(info)) info = linfo +IF (PRESENT(IPIV)) IPIV = work(:, 4) +DEALLOCATE (work) +END PROCEDURE SymGetLDL_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: +! +!# Introduction +! +! This helper function takes the rather strangely encoded permutation array +! returned by the LAPACK routines ?(HE/SY)TRF and converts it into +! regularized permutation and diagonal pivot size format. +! Since FORTRAN uses 1-indexing and LAPACK uses different start points for +! upper and lower formats there are certain offsets in the indices used +! below. +! Let's assume a result where the matrix is 6x6 and there are two 2x2 +! and two 1x1 blocks reported by the routine. To ease the coding efforts, +! we still populate a 6-sized array and fill zeros as the following :: +! pivots = [2, 0, 2, 0, 1, 1] +! This denotes a diagonal matrix of the form :: +! [x x ] +! [x x ] +! [ x x ] +! [ x x ] +! [ x ] +! [ x] +! In other words, we write 2 when the 2x2 block is first encountered and +! automatically write 0 to the next entry and skip the next spin of the +! loop. Thus, a separate counter or array appends to keep track of block +! sizes are avoided. If needed, zeros can be filtered out later without +! losing the block structure. +! Parameters +! ---------- +! a : ndarray +! The permutation array ipiv returned by LAPACK +! lower : bool, optional +! The switch to select whether upper or lower triangle is chosen in +! the LAPACK call. +! Returns +! ------- +! swap_ : ndarray +! The array that defines the row/column swap operations. For example, +! if row two is swapped with row four, the result is [0, 3, 2, 3]. +! pivots : ndarray +! The array that defines the block diagonal structure as given above. + +SUBROUTINE LDL_SENITIZE_IPIV(ipiv0, uplo, swap_, pivots, info) + INTEGER(I4B), INTENT(IN) :: ipiv0(:) + CHARACTER(1), INTENT(IN) :: uplo + INTEGER(I4B), INTENT(INOUT) :: swap_(:) + INTEGER(I4B), INTENT(INOUT) :: pivots(:) + INTEGER(I4B), INTENT(OUT) :: info + ! + ! internal variables + ! + INTEGER(I4B) :: n, ind, x, y, rs, re, ri, cur_val + LOGICAL(LGT) :: skip2x2 + ! + info = 0 + n = SIZE(ipiv0) + ! + IF (uplo .EQ. "L") THEN + x = 1 + y = 0 + rs = 1 + re = n + ri = 1 + ELSE + x = -1 + y = -1 + rs = n + re = 1 + ri = -1 + END IF + ! + skip2x2 = .FALSE. + swap_ = arange(1_I4B, n) + pivots = zeros(n, 1_I4B) + ! + DO ind = rs, re, ri + IF (skip2x2) skip2x2 = .FALSE. + cur_val = ipiv0(ind) + ! + IF (cur_val .GT. 0) THEN + IF (cur_val .NE. ind) THEN + swap_(ind) = swap_(cur_val) + END IF + pivots(ind) = 1 + ! + ELSEIF (cur_val < 0 .AND. cur_val == ipiv0(ind + x)) THEN + ! + IF (-cur_val .NE. ind + 1) THEN + swap_(ind + x) = swap_(-cur_val) + END IF + ! + pivots(ind + y) = 2 + skip2x2 = .TRUE. + ! + END IF + END DO + +END SUBROUTINE LDL_SENITIZE_IPIV + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: +! +!# Introduction +! +! Helper function to extract the diagonal and triangular matrices for +! LDL.T factorization. +! +!## Parameters +! +! ldu : ndarray +! The compact output returned by the LAPACK routing +! +! pivs : ndarray +! The sanitized array of {0, 1, 2} denoting the sizes of the pivots. For +! every 2 there is a succeeding 0. +! +! lower : bool, optional +! If set to False, upper triangular part is considered. +! +! hermitian : bool, optional +! If set to False a symmetric complex array is assumed. +! +!## Returns +! +! d : ndarray +! The block diagonal matrix. +! +! lu : ndarray +! The upper/lower triangular matrix + +SUBROUTINE LDL_GET_D_and_L(D, E, ldu, pivs, uplo) + REAL(DFP), INTENT(INOUT) :: D(:) + REAL(DFP), INTENT(INOUT) :: E(:) + REAL(DFP), INTENT(INOUT) :: ldu(:, :) + INTEGER(I4B), INTENT(IN) :: pivs(:) + CHARACTER(1), INTENT(IN) :: uplo + ! + ! internal variables + ! + INTEGER(I4B) :: x, y, ii, n, blk_i, inc + ! + ! extract D from LDU + ! + n = SIZE(ldu, 1) + ! + DO CONCURRENT(ii=1:n) + D(ii) = ldu(ii, ii) + E(ii) = 0.0_DFP + ldu(ii, ii) = 1.0_DFP + END DO + ! + blk_i = 1 + ! + IF (uplo .EQ. "L") THEN + x = 1 + y = 0 + !! + DO ii = 1, n + IF (pivs(ii) .EQ. 0) CYCLE + ! increment the block index and check for 2s + ! if 2 then copy the off diagonals depending on uplo + inc = blk_i + pivs(ii) + ! + IF (pivs(ii) .EQ. 2) THEN + E(blk_i) = ldu(blk_i + x, blk_i + y) + ldu(blk_i + x, blk_i + y) = 0.0 + END IF + ! + blk_i = inc + ! + END DO + !! + ELSE + y = 1 + x = 0 + !! + DO ii = 1, n + IF (pivs(ii) .EQ. 0) CYCLE + ! increment the block index and check for 2s + ! if 2 then copy the off diagonals depending on uplo + inc = blk_i + pivs(ii) + ! + IF (pivs(ii) .EQ. 2) THEN + E(blk_i) = ldu(blk_i + x, blk_i + y) + ldu(blk_i + x, blk_i + y) = 0.0 + END IF + ! + blk_i = inc + ! + END DO + END IF + ! +END SUBROUTINE LDL_GET_D_and_L + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-22 +! summary: Helper +! +!# Introduction +! +! Helper function to construct explicit outer factors of LDL factorization. +! If lower is True the permuted factors are multiplied as L(1)*L(2)*...*L(k). +! Otherwise, the permuted factors are multiplied as L(k)*...*L(2)*L(1). See +! LAPACK documentation for more details. +! +!### Parameters +! lu : ndarray +! The triangular array that is extracted from LAPACK routine call with +! ones on the diagonals. +! swap_ : ndarray +! The array that defines the row swapping indices. If the kth entry is m +! then rows k,m are swapped. Notice that the mth entry is not necessarily +! k to avoid undoing the swapping. +! pivots : ndarray +! The array that defines the block diagonal structure returned by +! _ldl_sanitize_ipiv(). +! lower : bool, optional +! The boolean to switch between lower and upper triangular structure. +! +!### Returns +!lu : ndarray +!The square outer factor which satisfies the L * D * L.T = A +!perm : ndarray +!The permutation vector that brings the lu to the triangular form +! +!@note +!Note that the original argument "lu" is overwritten. +!@endnote + +SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR(lu, swap_, pivots, perm, permTemp, uplo) + REAL(DFP), INTENT(INOUT) :: lu(:, :) + INTEGER(I4B), INTENT(IN) :: swap_(:) + INTEGER(I4B), INTENT(IN) :: pivots(:) + INTEGER(I4B), INTENT(INOUT) :: perm(:) + INTEGER(I4B), INTENT(INOUT) :: permTemp(:) + CHARACTER(1), INTENT(IN) :: uplo + ! + ! internal variables + ! + INTEGER(I4B) :: n, rs, re, ri, ind, s_ind, col_s, col_e, zero_or_two, & + & incr_col_s, incr_col_e + LOGICAL(LGT) :: islower + ! + ! main program + ! + n = SIZE(lu, 1) + permTemp = arange(1_I4B, n, 1_I4B) + ! + IF (uplo .EQ. "L") THEN + rs = n + re = 1 + ri = -1 + islower = .TRUE. + zero_or_two = 0 + incr_col_s = -1 + incr_col_e = 0 + ELSE + rs = 1 + re = n + ri = 1 + islower = .FALSE. + zero_or_two = 2 + incr_col_s = 0 + incr_col_e = 1 + END IF + ! + DO ind = rs, re, ri + s_ind = swap_(ind) + ! + IF (s_ind .NE. ind) THEN + ! Column start and end positions + IF (islower) THEN + col_s = ind + col_e = n + ELSE + col_s = 1 + col_e = ind + END IF + ! + ! If we stumble upon a 2x2 block include both cols in the permTemp. + ! + IF (pivots(ind) .EQ. zero_or_two) THEN + col_s = col_s + incr_col_s + col_e = col_e + incr_col_e + END IF + ! + lu([s_ind, ind], col_s:col_e) = lu([ind, s_ind], col_s:col_e) + permTemp([s_ind, ind]) = permTemp([ind, s_ind]) + ! + END IF + END DO + !! + perm = ArgSort(permTemp) + !! +END SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR + +!---------------------------------------------------------------------------- +! getLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLDL_2 +CHARACTER(1) :: luplo +INTEGER(I4B) :: linfo, n +INTEGER(I4B), ALLOCATABLE :: work(:, :) +! +! work(1:n, 1) = ipiv(:) from sytrf +! work(1:n, 2) = swap_(:) block diagonal information +! work(1:n, 3) = pivots(:) cleaned version of ipiv +! work(1:n, 4) = perm cleaned version of ipiv +! +n = SIZE(A, 1) +ALLOCATE (work(n, 4)) +luplo = INPUT(option=UPLO, default="U") +! +! Call SYTRF +! +CALL SYTRF(A=A, UPLO=luplo, IPIV=work(:, 1), INFO=info) +! +! Clean the ipiv0 returned by SYTRF +! +CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & + & swap_=work(:, 2), pivots=work(:, 3), info=linfo) +! +CALL LDL_GET_D_and_L(D=D, E=E, ldu=A, & + & pivs=work(:, 3), uplo=luplo) +! +CALL LDL_CONSTRUCT_TRI_FACTOR(lu=A, swap_=work(:, 2), & + & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) +! +IF (PRESENT(info)) info = linfo +IF (PRESENT(IPIV)) IPIV = work(:, 4) +DEALLOCATE (work) +END PROCEDURE SymGetLDL_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetCholesky_1 +! +! Make a copy of LU +! +CALL LACPY(A=A, B=LU, UPLO=uplo) +CALL POTRF(A=LU, uplo=uplo, info=info) +! +END PROCEDURE SymGetCholesky_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetCholesky_2 +CALL POTRF(A=A, uplo=uplo, info=info) +END PROCEDURE SymGetCholesky_2 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_1 +CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_1 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_2 +CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_2 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_3 +X = B +CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_3 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_4 +X = B +CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_4 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetInv_1 +CALL LACPY(A=A, B=invA, UPLO=UPLO) +CALL SYTRI(A=invA, IPIV=IPIV, UPLO=UPLO, info=INFO) +END PROCEDURE SymGetInv_1 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetInv_2 +CALL SYTRI(A=A, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymGetInv_2 + +END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 b/src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 new file mode 100644 index 000000000..d8fd80be9 --- /dev/null +++ b/src/submodules/Lapack/src/Sym_Lapack_Method@LUMethods.F90 @@ -0,0 +1,506 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Sym_Lapack_Method) LUMethods +USE BaseMethod, ONLY: Display, Input, Arange, Zeros, GetTril, & +& GetTriu, ArgSort, tostring +USE F95_LAPACK, ONLY: SYTRF, LACPY, LAPMR, POTRF, SYTRS, SYTRI +USE F77_LAPACK, ONLY: SYCONV => LA_SYCONV +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLU_1 +CALL LACPY(A=A, B=LU, UPLO=UPLO) +CALL SYTRF(A=LU, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +END PROCEDURE SymGetLU_1 + +!---------------------------------------------------------------------------- +! GetLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLU_2 +CALL SYTRF(A=A, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +END PROCEDURE SymGetLU_2 + +!---------------------------------------------------------------------------- +! GetLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLDL_1 +CHARACTER(LEN=1) :: luplo +INTEGER(I4B) :: linfo, n +INTEGER(I4B), ALLOCATABLE :: work(:, :) +! +! work(1:n, 1) = ipiv(:) from sytrf +! work(1:n, 2) = swap_(:) block diagonal information +! work(1:n, 3) = pivots(:) cleaned version of ipiv +! work(1:n, 4) = perm cleaned version of ipiv +! +n = SIZE(A, 1) +ALLOCATE (work(n, 4)) +luplo = INPUT(option=UPLO, default="U") +LU = 0.0_DFP +! +! Copy data in LU from A +! +CALL LACPY(A=A, B=LU, UPLO=luplo) +! +! Call SYTRF +! +CALL SYTRF(A=LU, UPLO=luplo, IPIV=work(:, 1), INFO=linfo) +! +! Clean the ipiv0 returned by SYTRF +! +CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & + & swap_=work(:, 2), pivots=work(:, 3), info=linfo) +! +CALL LDL_GET_D_and_L(D=D, E=E, ldu=lu, & + & pivs=work(:, 3), uplo=luplo) +! +CALL LDL_CONSTRUCT_TRI_FACTOR(lu=lu, swap_=work(:, 2), & + & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) +! +IF (PRESENT(info)) info = linfo +IF (PRESENT(IPIV)) IPIV = work(:, 4) +DEALLOCATE (work) +END PROCEDURE SymGetLDL_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: +! +!# Introduction +! +! This helper function takes the rather strangely encoded permutation array +! returned by the LAPACK routines ?(HE/SY)TRF and converts it into +! regularized permutation and diagonal pivot size format. +! Since FORTRAN uses 1-indexing and LAPACK uses different start points for +! upper and lower formats there are certain offsets in the indices used +! below. +! Let's assume a result where the matrix is 6x6 and there are two 2x2 +! and two 1x1 blocks reported by the routine. To ease the coding efforts, +! we still populate a 6-sized array and fill zeros as the following :: +! pivots = [2, 0, 2, 0, 1, 1] +! This denotes a diagonal matrix of the form :: +! [x x ] +! [x x ] +! [ x x ] +! [ x x ] +! [ x ] +! [ x] +! In other words, we write 2 when the 2x2 block is first encountered and +! automatically write 0 to the next entry and skip the next spin of the +! loop. Thus, a separate counter or array appends to keep track of block +! sizes are avoided. If needed, zeros can be filtered out later without +! losing the block structure. +! Parameters +! ---------- +! a : ndarray +! The permutation array ipiv returned by LAPACK +! lower : bool, optional +! The switch to select whether upper or lower triangle is chosen in +! the LAPACK call. +! Returns +! ------- +! swap_ : ndarray +! The array that defines the row/column swap operations. For example, +! if row two is swapped with row four, the result is [0, 3, 2, 3]. +! pivots : ndarray +! The array that defines the block diagonal structure as given above. + +SUBROUTINE LDL_SENITIZE_IPIV(ipiv0, uplo, swap_, pivots, info) + INTEGER(I4B), INTENT(IN) :: ipiv0(:) + CHARACTER(LEN=1), INTENT(IN) :: uplo + INTEGER(I4B), INTENT(INOUT) :: swap_(:) + INTEGER(I4B), INTENT(INOUT) :: pivots(:) + INTEGER(I4B), INTENT(OUT) :: info + ! + ! internal variables + ! + INTEGER(I4B) :: n, ind, x, y, rs, re, ri, cur_val + LOGICAL(LGT) :: skip2x2 + ! + info = 0 + n = SIZE(ipiv0) + ! + IF (uplo .EQ. "L") THEN + x = 1 + y = 0 + rs = 1 + re = n + ri = 1 + ELSE + x = -1 + y = -1 + rs = n + re = 1 + ri = -1 + END IF + ! + skip2x2 = .FALSE. + swap_ = arange(1_I4B, n) + pivots = zeros(n, 1_I4B) + ! + DO ind = rs, re, ri + IF (skip2x2) skip2x2 = .FALSE. + cur_val = ipiv0(ind) + ! + IF (cur_val .GT. 0) THEN + IF (cur_val .NE. ind) THEN + swap_(ind) = swap_(cur_val) + END IF + pivots(ind) = 1 + ! + ELSEIF (cur_val < 0 .AND. cur_val == ipiv0(ind + x)) THEN + ! + IF (-cur_val .NE. ind + 1) THEN + swap_(ind + x) = swap_(-cur_val) + END IF + ! + pivots(ind + y) = 2 + skip2x2 = .TRUE. + ! + END IF + END DO + +END SUBROUTINE LDL_SENITIZE_IPIV + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-21 +! summary: +! +!# Introduction +! +! Helper function to extract the diagonal and triangular matrices for +! LDL.T factorization. +! +!## Parameters +! +! ldu : ndarray +! The compact output returned by the LAPACK routing +! +! pivs : ndarray +! The sanitized array of {0, 1, 2} denoting the sizes of the pivots. For +! every 2 there is a succeeding 0. +! +! lower : bool, optional +! If set to False, upper triangular part is considered. +! +! hermitian : bool, optional +! If set to False a symmetric complex array is assumed. +! +!## Returns +! +! d : ndarray +! The block diagonal matrix. +! +! lu : ndarray +! The upper/lower triangular matrix + +SUBROUTINE LDL_GET_D_and_L(D, E, ldu, pivs, uplo) + REAL(DFP), INTENT(INOUT) :: D(:) + REAL(DFP), INTENT(INOUT) :: E(:) + REAL(DFP), INTENT(INOUT) :: ldu(:, :) + INTEGER(I4B), INTENT(IN) :: pivs(:) + CHARACTER(LEN=1), INTENT(IN) :: uplo + ! + ! internal variables + ! + INTEGER(I4B) :: x, y, ii, n, blk_i, inc + ! + ! extract D from LDU + ! + n = SIZE(ldu, 1) + ! + DO CONCURRENT(ii=1:n) + D(ii) = ldu(ii, ii) + E(ii) = 0.0_DFP + ldu(ii, ii) = 1.0_DFP + END DO + ! + blk_i = 1 + ! + IF (uplo .EQ. "L") THEN + x = 1 + y = 0 + !! + DO ii = 1, n + IF (pivs(ii) .EQ. 0) CYCLE + ! increment the block index and check for 2s + ! if 2 then copy the off diagonals depending on uplo + inc = blk_i + pivs(ii) + ! + IF (pivs(ii) .EQ. 2) THEN + E(blk_i) = ldu(blk_i + x, blk_i + y) + ldu(blk_i + x, blk_i + y) = 0.0 + END IF + ! + blk_i = inc + ! + END DO + !! + ELSE + y = 1 + x = 0 + !! + DO ii = 1, n + IF (pivs(ii) .EQ. 0) CYCLE + ! increment the block index and check for 2s + ! if 2 then copy the off diagonals depending on uplo + inc = blk_i + pivs(ii) + ! + IF (pivs(ii) .EQ. 2) THEN + E(blk_i) = ldu(blk_i + x, blk_i + y) + ldu(blk_i + x, blk_i + y) = 0.0 + END IF + ! + blk_i = inc + ! + END DO + END IF + ! +END SUBROUTINE LDL_GET_D_and_L + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-22 +! summary: Helper +! +!# Introduction +! +! Helper function to construct explicit outer factors of LDL factorization. +! If lower is True the permuted factors are multiplied as L(1)*L(2)*...*L(k). +! Otherwise, the permuted factors are multiplied as L(k)*...*L(2)*L(1). See +! LAPACK documentation for more details. +! +!### Parameters +! lu : ndarray +! The triangular array that is extracted from LAPACK routine call with +! ones on the diagonals. +! swap_ : ndarray +! The array that defines the row swapping indices. If the kth entry is m +! then rows k,m are swapped. Notice that the mth entry is not necessarily +! k to avoid undoing the swapping. +! pivots : ndarray +! The array that defines the block diagonal structure returned by +! _ldl_sanitize_ipiv(). +! lower : bool, optional +! The boolean to switch between lower and upper triangular structure. +! +!### Returns +!lu : ndarray +!The square outer factor which satisfies the L * D * L.T = A +!perm : ndarray +!The permutation vector that brings the lu to the triangular form +! +!@note +!Note that the original argument "lu" is overwritten. +!@endnote + +SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR(lu, swap_, pivots, perm, permTemp, uplo) + REAL(DFP), INTENT(INOUT) :: lu(:, :) + INTEGER(I4B), INTENT(IN) :: swap_(:) + INTEGER(I4B), INTENT(IN) :: pivots(:) + INTEGER(I4B), INTENT(INOUT) :: perm(:) + INTEGER(I4B), INTENT(INOUT) :: permTemp(:) + CHARACTER(LEN=1), INTENT(IN) :: uplo + ! + ! internal variables + ! + INTEGER(I4B) :: n, rs, re, ri, ind, s_ind, col_s, col_e, zero_or_two, & + & incr_col_s, incr_col_e + LOGICAL(LGT) :: islower + ! + ! main program + ! + n = SIZE(lu, 1) + permTemp = arange(1_I4B, n, 1_I4B) + ! + IF (uplo .EQ. "L") THEN + rs = n + re = 1 + ri = -1 + islower = .TRUE. + zero_or_two = 0 + incr_col_s = -1 + incr_col_e = 0 + ELSE + rs = 1 + re = n + ri = 1 + islower = .FALSE. + zero_or_two = 2 + incr_col_s = 0 + incr_col_e = 1 + END IF + ! + DO ind = rs, re, ri + s_ind = swap_(ind) + ! + IF (s_ind .NE. ind) THEN + ! Column start and end positions + IF (islower) THEN + col_s = ind + col_e = n + ELSE + col_s = 1 + col_e = ind + END IF + ! + ! If we stumble upon a 2x2 block include both cols in the permTemp. + ! + IF (pivots(ind) .EQ. zero_or_two) THEN + col_s = col_s + incr_col_s + col_e = col_e + incr_col_e + END IF + ! + lu([s_ind, ind], col_s:col_e) = lu([ind, s_ind], col_s:col_e) + permTemp([s_ind, ind]) = permTemp([ind, s_ind]) + ! + END IF + END DO + !! + perm = ArgSort(permTemp) + !! +END SUBROUTINE LDL_CONSTRUCT_TRI_FACTOR + +!---------------------------------------------------------------------------- +! getLU +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetLDL_2 +CHARACTER(LEN=1) :: luplo +INTEGER(I4B) :: linfo, n +INTEGER(I4B), ALLOCATABLE :: work(:, :) +! +! work(1:n, 1) = ipiv(:) from sytrf +! work(1:n, 2) = swap_(:) block diagonal information +! work(1:n, 3) = pivots(:) cleaned version of ipiv +! work(1:n, 4) = perm cleaned version of ipiv +! +n = SIZE(A, 1) +ALLOCATE (work(n, 4)) +luplo = INPUT(option=UPLO, default="U") +! +! Call SYTRF +! +CALL SYTRF(A=A, UPLO=luplo, IPIV=work(:, 1), INFO=info) +! +! Clean the ipiv0 returned by SYTRF +! +CALL LDL_SENITIZE_IPIV(ipiv0=work(:, 1), uplo=luplo, & + & swap_=work(:, 2), pivots=work(:, 3), info=linfo) +! +CALL LDL_GET_D_and_L(D=D, E=E, ldu=A, & + & pivs=work(:, 3), uplo=luplo) +! +CALL LDL_CONSTRUCT_TRI_FACTOR(lu=A, swap_=work(:, 2), & + & pivots=work(:, 3), perm=work(:, 4), permTemp=work(:, 1), uplo=luplo) +! +IF (PRESENT(info)) info = linfo +IF (PRESENT(IPIV)) IPIV = work(:, 4) +DEALLOCATE (work) +END PROCEDURE SymGetLDL_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetCholesky_1 +! +! Make a copy of LU +! +CALL LACPY(A=A, B=LU, UPLO=uplo) +CALL POTRF(A=LU, uplo=uplo, info=info) +! +END PROCEDURE SymGetCholesky_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetCholesky_2 +CALL POTRF(A=A, uplo=uplo, info=info) +END PROCEDURE SymGetCholesky_2 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_1 +CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_1 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_2 +CALL SYTRS(A=A, B=B, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_2 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_3 +X = B +CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_3 + +!---------------------------------------------------------------------------- +! SymLUSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLUSolve_4 +X = B +CALL SYTRS(A=A, B=X, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymLUSolve_4 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetInv_1 +CALL LACPY(A=A, B=invA, UPLO=UPLO) +CALL SYTRI(A=invA, IPIV=IPIV, UPLO=UPLO, info=INFO) +END PROCEDURE SymGetInv_1 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymGetInv_2 +CALL SYTRI(A=A, IPIV=IPIV, UPLO=UPLO, INFO=INFO) +END PROCEDURE SymGetInv_2 + +END SUBMODULE LUMethods diff --git a/src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 b/src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 new file mode 100644 index 000000000..a3ccd81b1 --- /dev/null +++ b/src/submodules/Lapack/src/Sym_Lapack_Method@LinearSolveMethods.F90 @@ -0,0 +1,215 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Sym_Lapack_Method) LinearSolveMethods +USE String_Class +USE BaseMethod, ONLY: UpperCase, ErrorMsg +USE F95_LAPACK, ONLY: LACPY, SYSV +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_1 +REAL(DFP), ALLOCATABLE :: LocalA(:, :) +INTEGER(I4B) :: n +TYPE(String) :: LSolveName +!! +n = SIZE(A, 1) +ALLOCATE (LocalA(n, n)) +!! +CALL LACPY(A=A, B=LocalA, UPLO=UPLO) +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_1", & + & unitno=stderr) + DEALLOCATE (LocalA) + STOP +END SELECT +DEALLOCATE (LocalA) +END PROCEDURE SymLinSolve_1 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_2 +REAL(DFP), ALLOCATABLE :: LocalA(:, :) +INTEGER(I4B) :: n +TYPE(String) :: LSolveName +!! +n = SIZE(A, 1) +ALLOCATE (LocalA(n, n)) +!! +CALL LACPY(A=A, B=LocalA, UPLO=UPLO) +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_2", & + & unitno=stderr) + DEALLOCATE (LocalA) + STOP +END SELECT + +DEALLOCATE (LocalA) +END PROCEDURE SymLinSolve_2 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_3 +TYPE(String) :: LSolveName +!! +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_3", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_3 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_4 +TYPE(String) :: LSolveName +!! +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_4", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_4 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_5 +TYPE(String) :: LSolveName +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_5", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_5 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_6 +TYPE(String) :: LSolveName +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_6", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE LinearSolveMethods diff --git a/src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 new file mode 100644 index 000000000..e983557d0 --- /dev/null +++ b/src/submodules/Lapack/src/Sym_LinearSolveMethods@Methods.F90 @@ -0,0 +1,216 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Sym_LinearSolveMethods) Methods +USE GlobalData, ONLY: DFP, I4B, LGT, stdout, stderr +USE String_Class +USE BaseMethod, ONLY: UpperCase, ErrorMsg +USE F95_LAPACK, ONLY: LACPY, SYSV +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_1 +REAL(DFP), ALLOCATABLE :: LocalA(:, :) +INTEGER(I4B) :: n +TYPE(String) :: LSolveName +!! +n = SIZE(A, 1) +ALLOCATE (LocalA(n, n)) +!! +CALL LACPY(A=A, B=LocalA, UPLO=UPLO) +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_1", & + & unitno=stderr) + DEALLOCATE (LocalA) + STOP +END SELECT +DEALLOCATE (LocalA) +END PROCEDURE SymLinSolve_1 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_2 +REAL(DFP), ALLOCATABLE :: LocalA(:, :) +INTEGER(I4B) :: n +TYPE(String) :: LSolveName +!! +n = SIZE(A, 1) +ALLOCATE (LocalA(n, n)) +!! +CALL LACPY(A=A, B=LocalA, UPLO=UPLO) +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=LocalA, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_2", & + & unitno=stderr) + DEALLOCATE (LocalA) + STOP +END SELECT + +DEALLOCATE (LocalA) +END PROCEDURE SymLinSolve_2 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_3 +TYPE(String) :: LSolveName +!! +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_3", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_3 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_4 +TYPE(String) :: LSolveName +!! +X = B +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=X, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_4", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_4 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_5 +TYPE(String) :: LSolveName +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_5", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_5 + +!---------------------------------------------------------------------------- +! SymSolve +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymLinSolve_6 +TYPE(String) :: LSolveName +!! +IF (PRESENT(SolverName)) THEN + LSolveName = UpperCase(SolverName) +ELSE + LSolveName = "SYSV" +END IF +!! +SELECT CASE (LSolveName%chars()) +CASE ("SYSV") + CALL SYSV(A=A, B=B, UPLO=UPLO, IPIV=IPIV, INFO=INFO) +CASE DEFAULT + CALL ErrorMsg( & + & msg="NO CASE FOUND FOR "//LSolveName%chars(), & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymLinSolve_6", & + & unitno=stderr) + STOP +END SELECT +END PROCEDURE SymLinSolve_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 b/src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 new file mode 100644 index 000000000..63b7886bf --- /dev/null +++ b/src/submodules/Lapack/src/Sym_SingularValueMethods@Methods.F90 @@ -0,0 +1,16 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! diff --git a/src/submodules/MassMatrix/CMakeLists.txt b/src/submodules/MassMatrix/CMakeLists.txt new file mode 100644 index 000000000..70e3b6181 --- /dev/null +++ b/src/submodules/MassMatrix/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}/MassMatrix_Method@Methods.F90 + ) diff --git a/src/submodules/MassMatrix/src/MM_1.inc b/src/submodules/MassMatrix/src/MM_1.inc new file mode 100644 index 000000000..aee971caa --- /dev/null +++ b/src/submodules/MassMatrix/src/MM_1.inc @@ -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 +! + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_1(ans, test, trial, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ips + !! + !! main + !! + CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + CALL getInterpolation(obj=trial, interpol=realval, val=rho) + realval = trial%js * trial%ws * trial%thickness * realval + !! + DO ips = 1, size(realval) + ans = ans + realval(ips) * & + & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + END DO + !! + if( present( opt ) ) CALL MakeDiagonalCopies(ans, opt) + !! + DEALLOCATE (realval) +END SUBROUTINE MM_1 diff --git a/src/submodules/MassMatrix/src/MM_2a.inc b/src/submodules/MassMatrix/src/MM_2a.inc new file mode 100644 index 000000000..0c31616c7 --- /dev/null +++ b/src/submodules/MassMatrix/src/MM_2a.inc @@ -0,0 +1,58 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_2a(ans, test, trial, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector variable + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1 + !! Define internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ii, ips + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1) + !! + realval = trial%js * trial%ws * trial%thickness + !! + DO ips = 1, SIZE(realval) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, ii, 1) = m4(:, :, ii, 1) & + & + realval(ips) * vbar(ii, ips) * m2 + END DO + END DO + !! + CALL Convert(From=m4, To=ans) + !! + DEALLOCATE (realval, m2, vbar, m4) + !! +END SUBROUTINE MM_2a diff --git a/src/submodules/MassMatrix/src/MM_2b.inc b/src/submodules/MassMatrix/src/MM_2b.inc new file mode 100644 index 000000000..3cbcb268e --- /dev/null +++ b/src/submodules/MassMatrix/src/MM_2b.inc @@ -0,0 +1,61 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_2b(ans, test, trial, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector variable + INTEGER( I4B ), INTENT( IN ) :: opt + !! 2 + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ii, ips + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + DO ips = 1, SIZE(realval) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, 1, ii) = m4(:, :, 1, ii) & + & + realval(ips) * vbar(ii, ips) * m2 + END DO + END DO + !! + CALL Convert(From=m4, To=ans) + !! + DEALLOCATE (realval, m2, vbar, m4) + !! +END SUBROUTINE MM_2b diff --git a/src/submodules/MassMatrix/src/MM_2c.inc b/src/submodules/MassMatrix/src/MM_2c.inc new file mode 100644 index 000000000..edc9450fa --- /dev/null +++ b/src/submodules/MassMatrix/src/MM_2c.inc @@ -0,0 +1,59 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_2c(ans, test, trial, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector variable + INTEGER( I4B ), INTENT( IN ) :: opt + !! 3 + !! Define internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ips, ii + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & + & SIZE(vbar, 1), SIZE(vbar, 1)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + DO ips = 1, SIZE(vbar, 2) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, ii, ii) = m4(:, :, ii, ii) & + & + realval(ips) * vbar(ii, ips) * m2 + END DO + END DO + !! + CALL Convert(from=m4, to=ans) + !! + DEALLOCATE (realval, m2, vbar, m4) + !! +END SUBROUTINE MM_2c diff --git a/src/submodules/MassMatrix/src/MM_2d.inc b/src/submodules/MassMatrix/src/MM_2d.inc new file mode 100644 index 000000000..00474ec01 --- /dev/null +++ b/src/submodules/MassMatrix/src/MM_2d.inc @@ -0,0 +1,61 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_2d(ans, test, trial, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector variable + !! Define internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ips, ii, jj + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & + & SIZE(vbar, 1), SIZE(vbar, 1)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + DO ips = 1, SIZE(vbar, 2) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO jj = 1, SIZE(vbar, 1) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * vbar(ii, ips) & + & * vbar(jj, ips) * m2 + END DO + END DO + END DO + !! + CALL Convert(from=m4, to=ans) + !! + DEALLOCATE (realval, m2, vbar, m4) + !! +END SUBROUTINE MM_2d diff --git a/src/submodules/MassMatrix/src/MM_3.inc b/src/submodules/MassMatrix/src/MM_3.inc new file mode 100644 index 000000000..b72f07d7f --- /dev/null +++ b/src/submodules/MassMatrix/src/MM_3.inc @@ -0,0 +1,62 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_3(ans, test, trial, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + !! matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! 4 + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ii, jj, ips + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2)) + !! + realval = trial%js * trial%ws * trial%thickness + !! + DO ips = 1, SIZE(realval) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO jj = 1, SIZE(kbar, 2) + DO ii = 1, SIZE(kbar, 1) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * kbar(ii, jj, ips) * m2 + END DO + END DO + END DO + !! + CALL Convert(From=m4, To=ans) + !! + DEALLOCATE (realval, m2, kbar, m4) +END SUBROUTINE MM_3 diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 new file mode 100644 index 000000000..880619fef --- /dev/null +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -0,0 +1,326 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(MassMatrix_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_2a(ans, test, trial, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + ! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + ! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + ! vector variable + ! Define internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ii, ips + + ! main + CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1) + realval = trial%js * trial%ws * trial%thickness + + DO ips = 1, SIZE(realval) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, ii, 1) = m4(:, :, ii, 1) & + & + realval(ips) * vbar(ii, ips) * m2 + END DO + END DO + + CALL Convert(From=m4, To=ans) + DEALLOCATE (realval, m2, vbar, m4) +END SUBROUTINE MM_2a + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_2b(ans, test, trial, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + ! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + ! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + ! vector variable + + ! Define internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ii, ips + + ! main + CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1)) + realval = trial%js * trial%ws * trial%thickness + + DO ips = 1, SIZE(realval) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, 1, ii) = m4(:, :, 1, ii) & + & + realval(ips) * vbar(ii, ips) * m2 + END DO + END DO + + 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, interpol=vbar, val=rho) + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & + & SIZE(vbar, 1), SIZE(vbar, 1)) + + realval = trial%js * trial%ws * trial%thickness + + DO ips = 1, SIZE(vbar, 2) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, ii, ii) = m4(:, :, ii, ii) & + & + realval(ips) * vbar(ii, ips) * m2 + END DO + END DO + + CALL Convert(from=m4, to=ans) + + DEALLOCATE (realval, m2, vbar, m4) +END SUBROUTINE MM_2c + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MM_2d(ans, test, trial, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + ! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + ! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: rho + ! vector variable + ! Define internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :) + REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) + INTEGER(I4B) :: ips, ii, jj + + ! main + CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & + & SIZE(vbar, 1), SIZE(vbar, 1)) + + realval = trial%js * trial%ws * trial%thickness + + DO ips = 1, SIZE(vbar, 2) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO jj = 1, SIZE(vbar, 1) + DO ii = 1, SIZE(vbar, 1) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * vbar(ii, ips) & + & * vbar(jj, ips) * m2 + END DO + END DO + END DO + + CALL Convert(from=m4, to=ans) + + DEALLOCATE (realval, m2, vbar, m4) +END SUBROUTINE MM_2d + +!---------------------------------------------------------------------------- +! 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) +END PROCEDURE MassMatrix_1 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +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, interpol=realval, val=rho) +realval = trial%js * trial%ws * trial%thickness * realval + +DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * & + & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) +END DO + +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +DEALLOCATE (realval) +END PROCEDURE MassMatrix_2 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix_3 +SELECT CASE (opt) +CASE (1) + CALL MM_2a(ans=ans, test=test, trial=trial, rho=rho) +CASE (2) + CALL MM_2b(ans=ans, test=test, trial=trial, rho=rho) +CASE (3) + CALL MM_2c(ans=ans, test=test, trial=trial, rho=rho) +CASE (4) + CALL MM_2d(ans=ans, test=test, trial=trial, rho=rho) +END SELECT +END PROCEDURE MassMatrix_3 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix_4 +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: m2(:, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :) +REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +INTEGER(I4B) :: ii, jj, ips + +! main +CALL GetInterpolation(obj=trial, interpol=kbar, val=rho) +CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2)) + +realval = trial%js * trial%ws * trial%thickness + +DO ips = 1, SIZE(realval) + m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) + DO jj = 1, SIZE(kbar, 2) + DO ii = 1, SIZE(kbar, 1) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * kbar(ii, jj, ips) * m2 + END DO + END DO +END DO + +CALL Convert(From=m4, To=ans) +DEALLOCATE (realval, m2, kbar, m4) +END PROCEDURE MassMatrix_4 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix_5 +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 + +! 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) + +ALLOCATE (acoeff(SIZE(lambdaBar, 1)), bcoeff(SIZE(lambdaBar, 1))) + +bcoeff = SQRT(rhoBar * muBar) +acoeff = SQRT(rhoBar * (lambdaBar + 2.0_DFP * muBar)) - bcoeff + +nsd = trial%refelem%nsd +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 MassMatrix_5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/MdEncode/CMakeLists.txt b/src/submodules/MdEncode/CMakeLists.txt new file mode 100644 index 000000000..97f3c2040 --- /dev/null +++ b/src/submodules/MdEncode/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}/MdEncode_Method@Methods.F90 +) diff --git a/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 b/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 new file mode 100644 index 000000000..ce52c7ad1 --- /dev/null +++ b/src/submodules/MdEncode/src/MdEncode_Method@Methods.F90 @@ -0,0 +1,403 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(MdEncode_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! MdEncode_Method@Methods +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MdEncode_Int8 +ans = Tostring(val) +END PROCEDURE MdEncode_Int8 + +MODULE PROCEDURE MdEncode_Int16 +ans = Tostring(val) +END PROCEDURE MdEncode_Int16 + +MODULE PROCEDURE MdEncode_Int32 +ans = Tostring(val) +END PROCEDURE MdEncode_Int32 + +MODULE PROCEDURE MdEncode_Int64 +ans = Tostring(val) +END PROCEDURE MdEncode_Int64 + +MODULE PROCEDURE MdEncode_Real32 +ans = Tostring(val) +END PROCEDURE MdEncode_Real32 + +MODULE PROCEDURE MdEncode_Real64 +ans = Tostring(val) +END PROCEDURE MdEncode_Real64 + +MODULE PROCEDURE MdEncode_Char +ans = TRIM(val) +END PROCEDURE MdEncode_Char + +MODULE PROCEDURE MdEncode_String +ans = val%chars() +END PROCEDURE MdEncode_String + +!---------------------------------------------------------------------------- +! MdEncode_Method@Methods +!---------------------------------------------------------------------------- + +! MODULE PROCEDURE MdEncode_2 +! INTEGER(I4B) :: ii, n +! +! n = SIZE(val) +! ans = "| " +! DO ii = 1, n +! ans = ans//" | " +! END DO +! ans = ans//CHAR_LF +! +! ans = ans//"| " +! DO ii = 1, n +! ans = ans//" --- | " +! END DO +! ans = ans//CHAR_LF +! +! SELECT TYPE (val) +! TYPE IS (REAL(REAL32)) +! #include "./inc/MdEncode_2.inc" +! TYPE IS (REAL(REAL64)) +! #include "./inc/MdEncode_2.inc" +! TYPE IS (INTEGER(INT8)) +! #include "./inc/MdEncode_2.inc" +! TYPE IS (INTEGER(INT16)) +! #include "./inc/MdEncode_2.inc" +! TYPE IS (INTEGER(INT32)) +! #include "./inc/MdEncode_2.inc" +! TYPE IS (INTEGER(INT64)) +! #include "./inc/MdEncode_2.inc" +! TYPE IS (CHARACTER(LEN=*)) +! ans = ans//"| " +! DO ii = 1, n +! ans = ans//TRIM(val(ii))//" | " +! END DO +! ans = ans//CHAR_LF +! TYPE IS (String) +! ans = ans//"| " +! DO ii = 1, n +! ans = ans//TRIM(val(ii))//" | " +! END DO +! ans = ans//CHAR_LF +! END SELECT +! +! END PROCEDURE MdEncode_2 + +!---------------------------------------------------------------------------- +! MdEncode_Method@Methods +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MdEncode2_Int8 +#include "./inc/MdEncode_2.inc" +END PROCEDURE MdEncode2_Int8 + +MODULE PROCEDURE MdEncode2_Int16 +#include "./inc/MdEncode_2.inc" +END PROCEDURE MdEncode2_Int16 + +MODULE PROCEDURE MdEncode2_Int32 +#include "./inc/MdEncode_2.inc" +END PROCEDURE MdEncode2_Int32 + +MODULE PROCEDURE MdEncode2_Int64 +#include "./inc/MdEncode_2.inc" +END PROCEDURE MdEncode2_Int64 + +MODULE PROCEDURE MdEncode2_Real32 +#include "./inc/MdEncode_2.inc" +END PROCEDURE MdEncode2_Real32 + +MODULE PROCEDURE MdEncode2_Real64 +#include "./inc/MdEncode_2.inc" +END PROCEDURE MdEncode2_Real64 + +MODULE PROCEDURE MdEncode2_String +#include "./inc/MdEncode_2.inc" +END PROCEDURE MdEncode2_String + +!---------------------------------------------------------------------------- +! MdEncode_Method@Methods +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MdEncode3_Int8 +#include "./inc/MdEncode_3.inc" +END PROCEDURE MdEncode3_Int8 + +MODULE PROCEDURE MdEncode3_Int16 +#include "./inc/MdEncode_3.inc" +END PROCEDURE MdEncode3_Int16 + +MODULE PROCEDURE MdEncode3_Int32 +#include "./inc/MdEncode_3.inc" +END PROCEDURE MdEncode3_Int32 + +MODULE PROCEDURE MdEncode3_Int64 +#include "./inc/MdEncode_3.inc" +END PROCEDURE MdEncode3_Int64 + +MODULE PROCEDURE MdEncode3_Real32 +#include "./inc/MdEncode_3.inc" +END PROCEDURE MdEncode3_Real32 + +MODULE PROCEDURE MdEncode3_Real64 +#include "./inc/MdEncode_3.inc" +END PROCEDURE MdEncode3_Real64 + +MODULE PROCEDURE MdEncode3_String +#include "./inc/MdEncode_3.inc" +END PROCEDURE MdEncode3_String + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MdEncode4_Int8 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & + & //MdEncode(val(:, :, ii)) +END DO +END PROCEDURE MdEncode4_Int8 + +MODULE PROCEDURE MdEncode4_Int16 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & + & //MdEncode(val(:, :, ii)) +END DO +END PROCEDURE MdEncode4_Int16 + +MODULE PROCEDURE MdEncode4_Int32 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & + & //MdEncode(val(:, :, ii)) +END DO +END PROCEDURE MdEncode4_Int32 + +MODULE PROCEDURE MdEncode4_Int64 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & + & //MdEncode(val(:, :, ii)) +END DO +END PROCEDURE MdEncode4_Int64 + +MODULE PROCEDURE MdEncode4_Real32 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & + & //MdEncode(val(:, :, ii)) +END DO +END PROCEDURE MdEncode4_Real32 + +MODULE PROCEDURE MdEncode4_Real64 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & + & //MdEncode(val(:, :, ii)) +END DO +END PROCEDURE MdEncode4_Real64 + +MODULE PROCEDURE MdEncode4_String +INTEGER(I4B) :: ii +DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//" ) = "//CHAR_LF2 & + & //MdEncode(val(:, :, ii)) +END DO +END PROCEDURE MdEncode4_String + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MdEncode5_Int8 +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(val, 4) + DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & + & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) + END DO +END DO +END PROCEDURE MdEncode5_Int8 + +MODULE PROCEDURE MdEncode5_Int16 +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(val, 4) + DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & + & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) + END DO +END DO +END PROCEDURE MdEncode5_Int16 + +MODULE PROCEDURE MdEncode5_Int32 +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(val, 4) + DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & + & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) + END DO +END DO +END PROCEDURE MdEncode5_Int32 + +MODULE PROCEDURE MdEncode5_Int64 +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(val, 4) + DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & + & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) + END DO +END DO +END PROCEDURE MdEncode5_Int64 + +MODULE PROCEDURE MdEncode5_Real32 +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(val, 4) + DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & + & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) + END DO +END DO +END PROCEDURE MdEncode5_Real32 + +MODULE PROCEDURE MdEncode5_Real64 +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(val, 4) + DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & + & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) + END DO +END DO +END PROCEDURE MdEncode5_Real64 + +MODULE PROCEDURE MdEncode5_String +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(val, 4) + DO ii = 1, SIZE(val, 3) + ans = ans//"( :, :, "//tostring(ii)//", "//tostring(jj)//" ) = " & + & //CHAR_LF//CHAR_LF//MdEncode(val(:, :, ii, jj)) + END DO +END DO +END PROCEDURE MdEncode5_String + +!---------------------------------------------------------------------------- +! Mdencode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MdEncode6_Int8 +#include "./inc/MdEncode_6.inc" +END PROCEDURE MdEncode6_Int8 + +MODULE PROCEDURE MdEncode6_Int16 +#include "./inc/MdEncode_6.inc" +END PROCEDURE MdEncode6_Int16 + +MODULE PROCEDURE MdEncode6_Int32 +#include "./inc/MdEncode_6.inc" +END PROCEDURE MdEncode6_Int32 + +MODULE PROCEDURE MdEncode6_Int64 +#include "./inc/MdEncode_6.inc" +END PROCEDURE MdEncode6_Int64 + +MODULE PROCEDURE MdEncode6_Real32 +#include "./inc/MdEncode_6.inc" +END PROCEDURE MdEncode6_Real32 + +MODULE PROCEDURE MdEncode6_Real64 +#include "./inc/MdEncode_6.inc" +END PROCEDURE MdEncode6_Real64 + +MODULE PROCEDURE MdEncode6_String +#include "./inc/MdEncode_6.inc" +END PROCEDURE MdEncode6_String + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MdEncode7_Int8 +#include "./inc/MdEncode_7.inc" +END PROCEDURE MdEncode7_Int8 + +MODULE PROCEDURE MdEncode7_Int16 +#include "./inc/MdEncode_7.inc" +END PROCEDURE MdEncode7_Int16 + +MODULE PROCEDURE MdEncode7_Int32 +#include "./inc/MdEncode_7.inc" +END PROCEDURE MdEncode7_Int32 + +MODULE PROCEDURE MdEncode7_Int64 +#include "./inc/MdEncode_7.inc" +END PROCEDURE MdEncode7_Int64 + +MODULE PROCEDURE MdEncode7_Real32 +#include "./inc/MdEncode_7.inc" +END PROCEDURE MdEncode7_Real32 + +MODULE PROCEDURE MdEncode7_Real64 +#include "./inc/MdEncode_7.inc" +END PROCEDURE MdEncode7_Real64 + +MODULE PROCEDURE MdEncode7_String +#include "./inc/MdEncode_7.inc" +END PROCEDURE MdEncode7_String + +!---------------------------------------------------------------------------- +! StartTab +!---------------------------------------------------------------------------- + +MODULE PROCEDURE React_StartTabs +ans = ""//char_lf +END PROCEDURE React_StartTabs + +!---------------------------------------------------------------------------- +! EndTabs +!---------------------------------------------------------------------------- + +MODULE PROCEDURE React_EndTabs +ans = ""//char_lf +END PROCEDURE React_EndTabs + +!---------------------------------------------------------------------------- +! StartTabItem +!---------------------------------------------------------------------------- + +MODULE PROCEDURE React_StartTabItem +ans = "'//char_lf +END PROCEDURE React_StartTabItem + +!---------------------------------------------------------------------------- +! StartTabItem +!---------------------------------------------------------------------------- + +MODULE PROCEDURE React_EndTabItem +ans = ""//char_lf +END PROCEDURE React_EndTabItem + +END SUBMODULE Methods diff --git a/src/submodules/MdEncode/src/inc/MdEncode_2.inc b/src/submodules/MdEncode/src/inc/MdEncode_2.inc new file mode 100644 index 000000000..6b51c65b5 --- /dev/null +++ b/src/submodules/MdEncode/src/inc/MdEncode_2.inc @@ -0,0 +1,35 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: ii, n +n = SIZE(val) +ans = "| " +DO ii = 1, n + ans = ans//" | " +END DO +ans = ans//CHAR_LF +ans = ans//"| " +DO ii = 1, n + ans = ans//" --- | " +END DO +ans = ans//CHAR_LF + +ans = ans//"| " +DO ii = 1, n + ans = ans//MdEncode(val(ii))//" | " +END DO +ans = ans//CHAR_LF diff --git a/src/submodules/MdEncode/src/inc/MdEncode_3.inc b/src/submodules/MdEncode/src/inc/MdEncode_3.inc new file mode 100644 index 000000000..8e91a8894 --- /dev/null +++ b/src/submodules/MdEncode/src/inc/MdEncode_3.inc @@ -0,0 +1,39 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: ii, jj, m, n +m = SIZE(val, 1) +n = SIZE(val, 2) +ans = "| " +DO ii = 1, n + ans = ans//" | " +END DO +ans = ans//CHAR_LF + +ans = ans//"| " +DO ii = 1, n + ans = ans//" --- | " +END DO +ans = ans//CHAR_LF + +DO ii = 1, m + ans = ans // "| " + DO jj = 1, n + ans = ans // MdEncode( val( ii, jj ) ) // " | " + END DO + ans = ans // CHAR_LF +END DO diff --git a/src/submodules/MdEncode/src/inc/MdEncode_3b.inc b/src/submodules/MdEncode/src/inc/MdEncode_3b.inc new file mode 100644 index 000000000..2cafdbb74 --- /dev/null +++ b/src/submodules/MdEncode/src/inc/MdEncode_3b.inc @@ -0,0 +1,25 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + + +DO ii = 1, m + ans = ans // " | " + DO jj = 1, n + ans = ans // TRIM( val( ii, jj ) ) // " | " + END DO + ans = ans // CHAR_LF +END DO \ No newline at end of file diff --git a/src/submodules/MdEncode/src/inc/MdEncode_6.inc b/src/submodules/MdEncode/src/inc/MdEncode_6.inc new file mode 100644 index 000000000..efc061d54 --- /dev/null +++ b/src/submodules/MdEncode/src/inc/MdEncode_6.inc @@ -0,0 +1,109 @@ + +INTEGER(I4B) :: nc, nr, n, ii +nc = SIZE(ch) +nr = SIZE(rh) +n = SIZE(val) + +SELECT CASE (nc) +CASE (1) + + IF (nr .EQ. n) THEN + + ans = ivert//avert//ch(1)%chars()//evert//abr + ans = ans// & + & ivert//adash//avert//adash//evert//abr + + DO ii = 1, n + ans = ans// & + & ivert//rh(ii)%chars()//avert//mdencode(val(ii))//evert//abr + END DO + ans = ans//abr + + ELSE + + IF (ch(1)%LEN_TRIM() .EQ. 0_I4B) THEN + + ans = ivert//avert + + DO ii = 1, n + ans = ans//ablank//evert + END DO + ans = ans//abr + + ans = ans//ivert//adash//evert + DO ii = 1, n + ans = ans//adash//evert + END DO + ans = ans//abr + + ans = ans//ivert//rh(1)%chars()//evert + + DO ii = 1, n + ans = ans//mdencode(val(ii))//evert + END DO + ans = ans//abr + ELSE + + ans = ivert//ch(1)%chars()//evert//abr + ans = ans// & + & ivert//adash//evert//abr + + DO ii = 1, n + ans = ans// & + & ivert//mdencode(val(ii))//evert//abr + END DO + ans = ans//abr + END IF + + END IF + +CASE default + + IF (nc .EQ. n) THEN + + ans = ivert//avert + + DO ii = 1, n + ans = ans//ch(ii)%chars()//evert + END DO + ans = ans//abr + + ans = ans//ivert//adash//evert + DO ii = 1, n + ans = ans//adash//evert + END DO + ans = ans//abr + + ans = ans//ivert//rh(1)%chars()//evert + + DO ii = 1, n + ans = ans//mdencode(val(ii))//evert + END DO + ans = ans//abr + + ELSE + + ans = ivert//avert + + DO ii = 1, n + ans = ans//ablank//evert + END DO + ans = ans//abr + + ans = ans//ivert//adash//evert + DO ii = 1, n + ans = ans//adash//evert + END DO + ans = ans//abr + + ans = ans//ivert//rh(1)%chars()//evert + + DO ii = 1, n + ans = ans//mdencode(val(ii))//evert + END DO + ans = ans//abr + + END IF + +END SELECT + diff --git a/src/submodules/MdEncode/src/inc/MdEncode_7.inc b/src/submodules/MdEncode/src/inc/MdEncode_7.inc new file mode 100644 index 000000000..e02cd8349 --- /dev/null +++ b/src/submodules/MdEncode/src/inc/MdEncode_7.inc @@ -0,0 +1,121 @@ +INTEGER(I4B) :: nc, nr, n, ii, m, jj +LOGICAL(LGT) :: norow, nocol +nc = SIZE(ch) +nr = SIZE(rh) +m = SIZE(val, 1) +n = SIZE(val, 2) + +IF (m .EQ. 1) THEN + ans = MdEncode(val=val(1, :), rh=rh, ch=ch) + RETURN +END IF + +IF (n .EQ. 1) THEN + ans = MdEncode(val=val(:, 1), rh=rh, ch=ch) + RETURN +END IF + +IF (nc .LT. n) THEN + nocol = .TRUE. +ELSE + nocol = .FALSE. +END IF + +IF (nr .LT. m) THEN + norow = .TRUE. +ELSE + norow = .FALSE. +END IF + +IF (nocol .AND. norow) THEN + ans = MdEncode(val) + RETURN +END IF + +IF (norow .AND. (.NOT. nocol)) THEN + ! | col-1 | col-2 | col-3 | + ! | ---- | ----- | ----- | + ! | 1 | 2 | 3 | + + ans = ivert + + DO ii = 1, n + ans = ans//ch(ii)%chars()//avert + END DO + ans = ans//abr + + ans = ans//ivert + DO ii = 1, n + ans = ans//adash//avert + END DO + ans = ans//abr + + ans = ans//ivert + + DO ii = 1, m + DO jj = 1, n + ans = ans//mdencode(val(ii, jj))//avert + END DO + ans = ans//abr + END DO + ans = ans//abr + RETURN +END IF + +IF (nocol .AND. (.NOT. norow)) THEN + ! | | | | | + ! | ----- | ---- | ----- | ----- | + ! | row-1 | 1 | 2 | 3 | + ! | row-2 | 1 | 2 | 3 | + ! | row-3 | 1 | 2 | 3 | + + ans = ivert//avert + DO ii = 1, n + ans = ans//ablank//avert + END DO + ans = ans//abr + + ans = ans//ivert//adash//avert + DO ii = 1, n + ans = ans//adash//avert + END DO + ans = ans//abr + + DO ii = 1, m + ans = ans//ivert//rh(ii)%chars()//avert + DO jj = 1, n + ans = ans//mdencode(val(ii, jj))//avert + END DO + ans = ans//abr + END DO + ans = ans//abr + RETURN +END IF + +! | | col-1 | col-2 | col-3 | +! | ----- | ---- | ----- | ----- | +! | row-1 | 1 | 2 | 3 | +! | row-2 | 1 | 2 | 3 | +! | row-3 | 1 | 2 | 3 | + +ans = ivert//avert +DO ii = 1, n + ans = ans//ch(ii)%chars()//avert +END DO +ans = ans//abr + +ans = ans//ivert//adash//avert +DO ii = 1, n + ans = ans//adash//avert +END DO +ans = ans//abr + +DO ii = 1, m + ans = ans//ivert//rh(ii)%chars()//avert + DO jj = 1, n + ans = ans//mdencode(val(ii, jj))//avert + END DO + ans = ans//abr +END DO +ans = ans//abr + diff --git a/src/submodules/MultiIndices/CMakeLists.txt b/src/submodules/MultiIndices/CMakeLists.txt new file mode 100644 index 000000000..76b424d30 --- /dev/null +++ b/src/submodules/MultiIndices/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/MultiIndices_Method@Methods.F90 +) diff --git a/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 b/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 new file mode 100644 index 000000000..fff8eab4d --- /dev/null +++ b/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 @@ -0,0 +1,96 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(MultiIndices_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate1 +obj%n = n +obj%d = d +END PROCEDURE obj_Initiate1 + +!---------------------------------------------------------------------------- +! MultiIndices +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_MultiIndices +ans%n = n +ans%d = d +END PROCEDURE obj_MultiIndices + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Deallocate +obj%n = 0 +obj%d = 0 +END PROCEDURE obj_Deallocate + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Display +CALL Display(msg, unitno=unitno) +CALL Display(obj%n, "n = ", unitno=unitno) +CALL Display(obj%d, "d = ", unitno=unitno) +END PROCEDURE obj_Display + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size1 +ans = INT(Binom(obj%n + obj%d, obj%d, 1.0_DFP), KIND=I4B) +END PROCEDURE obj_Size1 + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size2 +INTEGER(I4B) :: ii +ans = 0_I4B +DO ii = 0, obj%n + ans = ans + Size(n=ii, d=obj%d) +END DO +END PROCEDURE obj_Size2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices1 +ans = GetMultiIndices(n=obj%n, d=obj%d) +END PROCEDURE obj_GetMultiIndices1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices2 +ans = GetMultiIndices(n=obj%n, d=obj%d, upto=.true.) +END PROCEDURE obj_GetMultiIndices2 + +END SUBMODULE Methods diff --git a/src/submodules/OpenMP/CMakeLists.txt b/src/submodules/OpenMP/CMakeLists.txt new file mode 100644 index 000000000..162383e14 --- /dev/null +++ b/src/submodules/OpenMP/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 9/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/OpenMP_Method@Constructor.F90 +) diff --git a/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 b/src/submodules/OpenMP/src/OpenMP_Method@Constructor.F90 new file mode 100644 index 000000000..393120f01 --- /dev/null +++ b/src/submodules/OpenMP/src/OpenMP_Method@Constructor.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 +! + +SUBMODULE(OpenMP_Method) Constructor +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate + OMP%State = OMP_THREADS_FORKED + OMP%IS_INIT = .TRUE. + OMP%DID_I_INIT = .TRUE. + !$ OMP%MAX_THREADS = omp_get_max_threads() + !$ OMP%NUM_THREADS = omp_get_num_threads() + !$ OMP%Rank = omp_get_thread_num() +END PROCEDURE obj_initiate + +!---------------------------------------------------------------------------- +! Finalize +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_finalize + OMP%State = OMP_THREADS_JOINED + OMP%IS_INIT = .FALSE. + OMP%DID_I_INIT = .FALSE. + OMP%MAX_THREADS = 1 + OMP%NUM_THREADS = 1 + OMP%Rank = 0 +END PROCEDURE obj_finalize + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_partition_vec + INTEGER( I4B ) :: chunck + chunck = INT( N/OMP_NUM_THREADS, KIND=I4B ) + + IF( chunck .NE. 0 ) THEN + IF( OMP%RANK .EQ. OMP_NUM_THREADS-1 ) THEN + Ans = [(chunck*OMP%RANK) + 1, N, 1, N-chunck*OMP%RANK] + ELSE + Ans = [(chunck*OMP%RANK) + 1, chunck*(OMP%RANK + 1), 1, chunck] + END IF + ELSE + IF( OMP%RANK .EQ. 0 ) THEN + Ans = [1, N, 1, N] + ELSE + Ans = [0,0,1,0] + END IF + END IF +END PROCEDURE obj_partition_vec + +END SUBMODULE Constructor \ No newline at end of file diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt new file mode 100644 index 000000000..90b4a65e5 --- /dev/null +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -0,0 +1,43 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/LineInterpolationUtility@Methods.F90 + ${src_path}/QuadraturePoint_Triangle_Solin.F90 + ${src_path}/QuadraturePoint_Tetrahedron_Solin.F90 + ${src_path}/TriangleInterpolationUtility@Methods.F90 + ${src_path}/TriangleInterpolationUtility@QuadratureMethods.F90 + ${src_path}/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 + ${src_path}/TriangleInterpolationUtility@LagrangeBasisMethods.F90 + ${src_path}/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 + ${src_path}/QuadrangleInterpolationUtility@Methods.F90 + ${src_path}/TetrahedronInterpolationUtility@Methods.F90 + ${src_path}/HexahedronInterpolationUtility@Methods.F90 + ${src_path}/PrismInterpolationUtility@Methods.F90 + ${src_path}/PyramidInterpolationUtility@Methods.F90 + ${src_path}/InterpolationUtility@Methods.F90 + ${src_path}/LagrangePolynomialUtility@Methods.F90 + ${src_path}/JacobiPolynomialUtility@Methods.F90 + ${src_path}/UltrasphericalPolynomialUtility@Methods.F90 + ${src_path}/LegendrePolynomialUtility@Methods.F90 + ${src_path}/LobattoPolynomialUtility@Methods.F90 + ${src_path}/UnscaledLobattoPolynomialUtility@Methods.F90 + ${src_path}/Chebyshev1PolynomialUtility@Methods.F90 + ${src_path}/OrthogonalPolynomialUtility@Methods.F90 + ${src_path}/RecursiveNodesUtility@Methods.F90) diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 new file mode 100644 index 000000000..8c905ad17 --- /dev/null +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -0,0 +1,1150 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Chebyshev1PolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Chebyshev1Alpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Alpha +ans = 0.0_DFP +END PROCEDURE Chebyshev1Alpha + +!---------------------------------------------------------------------------- +! Chebyshev1Beta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Beta +SELECT CASE (n) +CASE (0_I4B) + ans = pi +CASE (1_I4B) + ans = 0.5_DFP +CASE DEFAULT + ans = 0.25_DFP +END SELECT +END PROCEDURE Chebyshev1Beta + +!---------------------------------------------------------------------------- +! GetChebyshev1RecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetChebyshev1RecurrenceCoeff +IF (n .LE. 0) RETURN +alphaCoeff = 0.0_DFP +betaCoeff(0) = pi +IF (n .EQ. 1) RETURN +betaCoeff(1) = 0.5_DFP +IF (n .EQ. 2) RETURN +betaCoeff(2:) = 0.25_DFP +END PROCEDURE GetChebyshev1RecurrenceCoeff + +!---------------------------------------------------------------------------- +! GetChebyshev1RecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetChebyshev1RecurrenceCoeff2 +IF (n .LE. 0) RETURN +A = 2.0_DFP +B = 0.0_DFP +C = 1.0_DFP +END PROCEDURE GetChebyshev1RecurrenceCoeff2 + +!---------------------------------------------------------------------------- +! Chebyshev1LeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1LeadingCoeff +IF (n .EQ. 0_I4B) THEN + ans = 1.0_DFP +ELSE + ans = 2.0_DFP**(n - 1_I4B) +END IF +END PROCEDURE Chebyshev1LeadingCoeff + +!---------------------------------------------------------------------------- +! Chebyshev1LeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1LeadingCoeffRatio +IF (n .EQ. 0_I4B) THEN + ans = 1.0_DFP +ELSE + ans = 2.0_DFP +END IF +END PROCEDURE Chebyshev1LeadingCoeffRatio + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQR +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1NormSQR +IF (n .EQ. 0_I4B) THEN + ans = pi +ELSE + ans = pi / 2.0_DFP +END IF +END PROCEDURE Chebyshev1NormSQR + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQR2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1NormSQR2 +ans(0) = pi +IF (n .EQ. 0) RETURN +ans(1:) = 0.5_DFP * pi +END PROCEDURE Chebyshev1NormSQR2 + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQRRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1NormSQRRatio +ans = 1.0_DFP +END PROCEDURE Chebyshev1NormSQRRatio + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1JacobiMatrix +CALL JacobiJacobiMatrix(n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE Chebyshev1JacobiMatrix + +!---------------------------------------------------------------------------- +! Chebyshev1GaussQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GaussQuadrature +pt = Chebyshev1Zeros(n=n) +IF (PRESENT(wt)) wt = pi / n +END PROCEDURE Chebyshev1GaussQuadrature + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiRadauMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1JacobiRadauMatrix +CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE Chebyshev1JacobiRadauMatrix + +!---------------------------------------------------------------------------- +! Chebyshev1GaussRadauQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GaussRadauQuadrature +INTEGER(I4B) :: ii, c +REAL(DFP) :: avar, avar2 +!! +IF (a .LT. 0.0_DFP) THEN + c = 0_I4B +ELSE + c = 1_I4B +END IF +!! +avar = pi / (2.0_DFP * n + 1.0_DFP) +!! +avar2 = pi / (2.0_DFP * n + 1.0_DFP) +!! +IF (PRESENT(wt)) THEN + DO ii = 0, n + pt(ii + 1) = -COS(avar * (2 * ii + c)) + wt(ii + 1) = avar2 + END DO +!! + wt(1) = wt(1) / 2.0_DFP +ELSE + DO ii = 0, n + pt(ii + 1) = -COS(avar * (2 * ii + c)) + END DO +END IF +!! +END PROCEDURE Chebyshev1GaussRadauQuadrature + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiLobattoMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1JacobiLobattoMatrix +CALL JacobiJacobiLobattoMatrix(n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE Chebyshev1JacobiLobattoMatrix + +!---------------------------------------------------------------------------- +! Chebyshev1GaussLobattoQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GaussLobattoQuadrature +INTEGER(I4B) :: ii +REAL(DFP) :: avar +!! +avar = pi / (n + 1.0_DFP) +!! +IF (PRESENT(wt)) THEN + wt = avar + wt(1) = wt(1) / 2.0_DFP + wt(n + 2) = wt(n + 2) / 2.0_DFP +END IF +!! +DO ii = 0, n + 1 + pt(ii + 1) = -COS(avar * ii) +END DO +!! +END PROCEDURE Chebyshev1GaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! Chebyshev1Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Zeros +INTEGER(I4B) :: ii +REAL(DFP) :: aval +aval = pi * 0.5_DFP / REAL(n, KIND=DFP) +DO ii = 1, n + ans(ii) = -COS((2.0_DFP * ii - 1.0_DFP) * aval) +END DO +END PROCEDURE Chebyshev1Zeros + +!---------------------------------------------------------------------------- +! Chebyshev1Quadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Quadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP +REAL(DFP), ALLOCATABLE :: p(:), w(:) +LOGICAL(LGT) :: inside +!! +IF (PRESENT(onlyInside)) THEN + inside = onlyInside +ELSE + inside = .FALSE. +END IF +!! +SELECT CASE (QuadType) +CASE (Gauss) + !! + order = n + CALL Chebyshev1GaussQuadrature(n=order, pt=pt, wt=wt) + !! +CASE (GaussRadau, GaussRadauLeft) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=p, wt=w) + pt = p(2:); wt = w(2:) + DEALLOCATE (p, w) + ELSE + order = n - 1 + CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussRadauRight) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=p, wt=w) + pt = p(1:n); wt = w(1:n) + ELSE + order = n - 1 + CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussLobatto) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 2), w(n + 2)) + CALL Chebyshev1GaussLobattoQuadrature(n=order, pt=p, wt=w) + pt = p(2:n + 1); wt = w(2:n + 1) + ELSE + order = n - 2 + CALL Chebyshev1GaussLobattoQuadrature(n=order, pt=pt, wt=wt) + END IF +END SELECT + !! +END PROCEDURE Chebyshev1Quadrature + +!---------------------------------------------------------------------------- +! Chebyshev1Eval1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Eval1 +INTEGER(I4B) :: i +REAL(DFP) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + ans_1 = ans + ans = (2.0_DFP * x) * ans - ans_2 + ans_2 = ans_1 + !! +END DO +END PROCEDURE Chebyshev1Eval1 + +!---------------------------------------------------------------------------- +! Chebyshev1Eval2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Eval2 +INTEGER(I4B) :: i +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + ans_1 = ans + ans = (2.0_DFP * x) * ans - ans_2 + ans_2 = ans_1 + !! +END DO +END PROCEDURE Chebyshev1Eval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalAll1 +INTEGER(I4B) :: i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2) = x +!! +DO i = 2, n + ans(i + 1) = (2.0_DFP * x) * ans(i) - ans(i - 1) +END DO +!! +END PROCEDURE Chebyshev1EvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalAll2 +INTEGER(I4B) :: i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(:, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(:, 2) = x +!! +DO i = 2, n + ans(:, i + 1) = (2.0_DFP * x) * ans(:, i) - ans(:, i - 1) +END DO +!! +END PROCEDURE Chebyshev1EvalAll2 + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansionAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1MonomialExpansionAll +INTEGER(I4B), PARAMETER :: rk = 1.0_DFP +INTEGER(I4B) :: ii +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 0.0_DFP +ans(1, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2, 2) = 1.0_DFP +!! +DO ii = 2, n + !! + ! ans(ii + 1, 1) = -ans(ii - 1, 1) + ans(1, ii + 1) = -ans(1, ii - 1) + !! + ! ans(ii + 1, 2:ii - 1) = 2.0_DFP*ans(ii, 1:ii - 2) - ans(ii - 1, 2:ii - 1) + ans(2:ii - 1, ii + 1) = 2.0_DFP * ans(1:ii - 2, ii) - ans(2:ii - 1, ii - 1) + !! + ! ans(ii + 1, ii) = 2.0_DFP * ans(ii, ii - 1) + ans(ii, ii + 1) = 2.0_DFP * ans(ii - 1, ii) + !! + ! ans(ii + 1, ii + 1) = 2.0_DFP * ans(ii, ii) + ans(ii + 1, ii + 1) = 2.0_DFP * ans(ii, ii) + !! +END DO +!! +END PROCEDURE Chebyshev1MonomialExpansionAll + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansion +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1MonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = Chebyshev1MonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE Chebyshev1MonomialExpansion + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalAll1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalAll1 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: p(1:n + 1), r_ii +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(1) = 1.0_DFP +ans(1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p(2) = x +ans(2) = 1.0_DFP +!! +IF (n .EQ. 1_I4B) RETURN +!! +p(3) = 2.0_DFP * x**2 - 1.0_DFP +ans(3) = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p(ii + 1) = (2.0_DFP * x) * p(ii) - p(ii - 1) + ans(ii + 1) = 2.0_DFP * r_ii * p(ii) & + & + r_ii * ans(ii - 1) / (r_ii - 2.0_DFP) + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEvalAll1 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalAll2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalAll2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: p(1:SIZE(x), 1:n + 1), r_ii +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(:, 1) = 1.0_DFP +ans(:, 1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p(:, 2) = x +ans(:, 2) = 1.0_DFP +!! +IF (n .EQ. 1_I4B) RETURN +!! +p(:, 3) = 2.0_DFP * x**2 - 1.0_DFP +ans(:, 3) = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p(:, ii + 1) = (2.0_DFP * x) * p(:, ii) - p(:, ii - 1) + ans(:, ii + 1) = 2.0_DFP * r_ii * p(:, ii) & + & + r_ii * ans(:, ii - 1) / (r_ii - 2.0_DFP) + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEvalAll2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEval1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEval1 +! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii, p, p_1, p_2, ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p = x +ans = 1.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n .EQ. 1_I4B) RETURN +!! +p = 2.0_DFP * x**2 - 1.0_DFP +ans = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p_1 = p + p = (2.0_DFP * x) * p - p_2 + p_2 = p_1 + !! + ans_1 = ans + ans = 2.0_DFP * r_ii * p_1 & + & + r_ii * ans_2 / (r_ii - 2.0_DFP) + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEval1 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEval2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2, ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p = x +ans = 1.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n .EQ. 1_I4B) RETURN +!! +p = 2.0_DFP * x**2 - 1.0_DFP +ans = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p_1 = p + p = (2.0_DFP * x) * p - p_2 + p_2 = p_1 + !! + ans_1 = ans + ans = 2.0_DFP * r_ii * p_1 & + & + r_ii * ans_2 / (r_ii - 2.0_DFP) + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEval2 + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalSum1 +REAL(DFP) :: xx, t, b1, b2 +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n, 1, -1 + t = xx * b1 - b2 + coeff(i) + b2 = b1 + b1 = t +END DO +ans = x * b1 - b2 + coeff(0) +END PROCEDURE Chebyshev1EvalSum1 + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: xx, t, b1, b2 +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n, 1, -1 + t = xx * b1 - b2 + coeff(i) + b2 = b1 + b1 = t +END DO +ans = x * b1 - b2 + coeff(0) +END PROCEDURE Chebyshev1EvalSum2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalSum1 +REAL(DFP) :: xx, t, b1, b2 +INTEGER(I4B) :: i +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n - 1, 0, -1 + t = xx * b1 - b2 + (i + 1) * coeff(i + 1); + b2 = b1; + b1 = t; +END DO +!! +ans = b1 +END PROCEDURE Chebyshev1GradientEvalSum1 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: xx, t, b1, b2 +INTEGER(I4B) :: i +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n - 1, 0, -1 + t = xx * b1 - b2 + (i + 1) * coeff(i + 1); + b2 = b1; + b1 = t; +END DO +!! +ans = b1 +END PROCEDURE Chebyshev1GradientEvalSum2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalSum3 +REAL(DFP) :: s, t, b1, b2 +INTEGER(I4B) :: i +REAL(DFP) :: j +!! +IF (n .LT. 0) RETURN +!! +IF (k .EQ. 0) THEN + !! + ans = Chebyshev1EvalSum(coeff=coeff, n=n, x=x) + !! +ELSE + !! + b1 = 0.0_DFP + b2 = 0.0_DFP + s = 1.0_DFP + !! + DO i = k - 1, 1, -1 + s = 2.0_DFP * s * i + END DO + !! + DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & + & / (j + 2) * b2 + (j + k) * coeff(i + k); + b2 = b1; + b1 = t; + END DO + !! + ans = s * b1 +END IF +END PROCEDURE Chebyshev1GradientEvalSum3 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalSum4 +REAL(DFP) :: s +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: i +REAL(DFP) :: j +!! +IF (n .LT. 0) RETURN +!! +IF (k .EQ. 0) THEN + !! + ans = Chebyshev1EvalSum(coeff=coeff, n=n, x=x) + !! +ELSE + !! + b1 = 0.0_DFP + b2 = 0.0_DFP + s = 1.0_DFP + !! + DO i = k - 1, 1, -1 + s = 2.0_DFP * s * i + END DO + !! + DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & + & / (j + 2) * b2 + (j + k) * coeff(i + k); + b2 = b1; + b1 = t; + END DO + !! + ans = s * b1 +END IF + +END PROCEDURE Chebyshev1GradientEvalSum4 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform1 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +REAL(DFP) :: rn +!! +nrmsqr = Chebyshev1NormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = pi +END IF +!! +PP = Chebyshev1EvalAll(n=n, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / nrmsqr(jj) +END DO +!! +END PROCEDURE Chebyshev1Transform1 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform2 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +REAL(DFP) :: rn +!! +nrmsqr = Chebyshev1NormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = pi +END IF +!! +PP = Chebyshev1EvalAll(n=n, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / nrmsqr(jj) + END DO +END DO +!! +END PROCEDURE Chebyshev1Transform2 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii +!! +CALL Chebyshev1Quadrature(n=n + 1, pt=pt, wt=wt,& + & quadType=quadType) +!! +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO +!! +ans = Chebyshev1Transform(n=n, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) +!! +END PROCEDURE Chebyshev1Transform3 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform4 +INTEGER(I4B) :: ii, jj +REAL(DFP) :: avar +!! +ans = 0.0_DFP +!! +IF (quadType .EQ. GaussLobatto) THEN + !! + DO jj = 0, n + !! + ans(jj) = coeff(0) * 0.5_DFP + coeff(n) * 0.5_DFP * (-1.0)**jj + !! + DO ii = 1, n - 1 + ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi * ii / n) + END DO + !! + ans(jj) = ans(jj) * 2.0_DFP / n + !! + END DO + !! + ans(0) = ans(0) * 0.5_DFP + ans(n) = ans(n) * 0.5_DFP + !! +ELSE + !! + DO jj = 0, n + !! + avar = jj * pi * 0.5_DFP / (n + 1.0_DFP) + !! + DO ii = 0, n + ans(jj) = ans(jj) + coeff(ii) * COS((2.0 * ii + 1.0) * avar) + END DO + !! + ans(jj) = ans(jj) * 2.0_DFP / (n + 1.0) + !! + END DO + !! + ans(0) = ans(0) * 0.5_DFP + !! +END IF +!! +END PROCEDURE Chebyshev1Transform4 + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1InvTransform1 +ans = Chebyshev1EvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE Chebyshev1InvTransform1 + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1InvTransform2 +ans = Chebyshev1EvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE Chebyshev1InvTransform2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientCoeff1 +REAL(DFP) :: a, b, c +INTEGER(I4B) :: ii +REAL(DFP) :: jj +!! +ans(n) = 0.0_DFP +IF (n .EQ. 0) RETURN +!! +IF (n .EQ. 1) THEN + c = 2.0_DFP +ELSE + c = 1.0_DFP +END IF +!! +ans(n - 1) = 2.0_DFP * n * coeff(n) / c +!! +DO ii = n - 1, 1, -1 + jj = REAL(ii, KIND=DFP) + ans(ii - 1) = 2.0_DFP * jj * coeff(ii) + ans(ii + 1) +END DO +!! +ans(0) = 0.5_DFP * ans(0) +!! +END PROCEDURE Chebyshev1GradientCoeff1 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1DMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL Chebyshev1DMatrixGL2(n=n, x=x, D=ans) +CASE (Gauss) + CALL Chebyshev1DMatrixG2(n=n, x=x, D=ans) +END SELECT +END PROCEDURE Chebyshev1DMatrix1 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Chebyshev1DMatrixGL2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: rn, j1, j2 + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = int(n / 2) + rn = REAL(n, KIND=DFP) + !! + D = 0.0_DFP + !! + DO jj = 0, n + DO ii = 0, nb2 + j1 = SIN(0.5 * (ii + jj) * pi / rn) + j2 = SIN(0.5 * (ii - jj) * pi / rn) + IF (ii .NE. jj) & + & D(ii, jj) = 0.5 * (-1)**(ii + jj) / j1 / j2 + END DO + END DO + !! + D(0, :) = D(0, :) * 2.0_DFP + D(:, 0) = D(:, 0) * 0.5_DFP + D(:, n) = D(:, n) * 0.5_DFP + !! + !! correct diagonal entries + !! + D(0, 0) = -(2.0_DFP * rn**2 + 1.0_DFP) / 6.0_DFP + !! + DO ii = 1, nb2 + D(ii, ii) = -x(ii) * 0.5_DFP / (SIN(pi * ii / rn))**2 + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE Chebyshev1DMatrixGL2 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Chebyshev1DMatrixG(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! internal variables + !! + REAL(DFP) :: rn, j3, j4 + INTEGER(I4B) :: ii, jj, nb2 + !! + !! main + !! + rn = REAL(n, KIND=DFP) + nb2 = int(n / 2) + D = 0.0_DFP + !! + DO jj = 0, n + j4 = (rn + 1.0) * SIN((2.0 * jj + 1) * 0.5 * pi) & + & / SIN((2.0 * jj + 1) * 0.5 * pi / (rn + 1.0)) + DO ii = 0, nb2 + j3 = (rn + 1.0) * SIN((2.0 * ii + 1) * 0.5 * pi) & + & / SIN((2.0 * ii + 1) * 0.5 * pi / (rn + 1.0)) + IF (ii .NE. jj) & + & D(ii, jj) = j3 / j4 / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = x(ii) * 0.5_DFP / (1.0_DFP - x(ii)**2) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE Chebyshev1DMatrixG + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Chebyshev1DMatrixG2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! internal variables + !! + REAL(DFP) :: rn + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj, nb2 + !! + !! main + !! + rn = REAL(n, KIND=DFP) + nb2 = int(n / 2) + D = 0.0_DFP + !! + J = Chebyshev1GradientEval(n=n + 1, x=x) + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = x(ii) * 0.5_DFP / (1.0_DFP - x(ii)**2) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE Chebyshev1DMatrixG2 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatEvenOdd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1DMatEvenOdd1 +CALL UltrasphericalDMatEvenOdd(n=n, D=D, o=o, e=e) +END PROCEDURE Chebyshev1DMatEvenOdd1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc b/src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc new file mode 100644 index 000000000..c14367e25 --- /dev/null +++ b/src/submodules/Polynomial/src/EquidistanceLIP_Tetrahedron.inc @@ -0,0 +1,267 @@ + +!---------------------------------------------------------------------------- +! EquidistanceLIP_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceLIP_Tetrahedron + !! +SELECT CASE (order) +CASE (1) + !! + !! tetra4 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0], [3, 4]) + !! +CASE (2) + !! + !! tetra10 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.5, 0.0, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.0, 0.5, & + & 0.0, 0.5, 0.5, & + & 0.5, 0.0, 0.5], [3, 10]) + !! +CASE (3) + !! + !! tetra20 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.0, 0.66666666666666666667, & + & 0.0, 0.0, 0.33333333333333333333, & + & 0.0, 0.33333333333333333333, 0.66666666666666666667, & + & 0.0, 0.66666666666666666667, 0.33333333333333333333, & + & 0.33333333333333333333, 0.0, 0.66666666666666666667, & + & 0.66666666666666666667, 0.0, 0.33333333333333333333, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.0, 0.33333333333333333333, & + & 0.0, 0.33333333333333333333, 0.33333333333333333333, & + & 0.33333333333333333333, 0.33333333333333333333, & + & 0.33333333333333333333], [3, 20]) + !! +CASE (4) + !! + !! tetra35 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.25, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.75, 0.0, 0.0, & + & 0.75, 0.25, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.25, 0.75, 0.0, & + & 0.0, 0.75, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.25, 0.0, & + & 0.0, 0.0, 0.75, & + & 0.0, 0.0, 0.5, & + & 0.0, 0.0, 0.25, & + & 0.0, 0.25, 0.75, & + & 0.0, 0.5, 0.5, & + & 0.0, 0.75, 0.25, & + & 0.25, 0.0, 0.75, & + & 0.5, 0.0, 0.5, & + & 0.75, 0.0, 0.25, & + & 0.25, 0.25, 0.0, & + & 0.25, 0.5, 0.0, & + & 0.5, 0.25, 0.0, & + & 0.25, 0.0, 0.25, & + & 0.5, 0.0, 0.25, & + & 0.25, 0.0, 0.5, & + & 0.0, 0.25, 0.25, & + & 0.0, 0.25, 0.5, & + & 0.0, 0.5, 0.25, & + & 0.25, 0.25, 0.5, & + & 0.5, 0.25, 0.25, & + & 0.25, 0.5, 0.25, & + & 0.25, 0.25, 0.25], [3, 35]) + !! +CASE (5) + !! + !! tetra56 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.2, 0.0, 0.0, & + & 0.4, 0.0, 0.0, & + & 0.6, 0.0, 0.0, & + & 0.8, 0.0, 0.0, & + & 0.8, 0.2, 0.0, & + & 0.6, 0.4, 0.0, & + & 0.4, 0.6, 0.0, & + & 0.2, 0.8, 0.0, & + & 0.0, 0.8, 0.0, & + & 0.0, 0.6, 0.0, & + & 0.0, 0.4, 0.0, & + & 0.0, 0.2, 0.0, & + & 0.0, 0.0, 0.8, & + & 0.0, 0.0, 0.6, & + & 0.0, 0.0, 0.4, & + & 0.0, 0.0, 0.2, & + & 0.0, 0.2, 0.8, & + & 0.0, 0.4, 0.6, & + & 0.0, 0.6, 0.4, & + & 0.0, 0.8, 0.2, & + & 0.2, 0.0, 0.8, & + & 0.4, 0.0, 0.6, & + & 0.6, 0.0, 0.4, & + & 0.8, 0.0, 0.2, & + & 0.2, 0.2, 0.0, & + & 0.2, 0.6, 0.0, & + & 0.6, 0.2, 0.0, & + & 0.2, 0.4, 0.0, & + & 0.4, 0.4, 0.0, & + & 0.4, 0.2, 0.0, & + & 0.2, 0.0, 0.2, & + & 0.6, 0.0, 0.2, & + & 0.2, 0.0, 0.6, & + & 0.4, 0.0, 0.2, & + & 0.4, 0.0, 0.4, & + & 0.2, 0.0, 0.4, & + & 0.0, 0.2, 0.2, & + & 0.0, 0.2, 0.6, & + & 0.0, 0.6, 0.2, & + & 0.0, 0.2, 0.4, & + & 0.0, 0.4, 0.4, & + & 0.0, 0.4, 0.2, & + & 0.2, 0.2, 0.6, & + & 0.6, 0.2, 0.2, & + & 0.2, 0.6, 0.2, & + & 0.4, 0.2, 0.4, & + & 0.4, 0.4, 0.2, & + & 0.2, 0.4, 0.4, & + & 0.2, 0.2, 0.2, & + & 0.4, 0.2, 0.2, & + & 0.2, 0.4, 0.2, & + & 0.2, 0.2, 0.4], [3, 56]) + !! +CASE (6) + !! + !! + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.16666666666666666667, 0.0, 0.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.83333333333333333333, 0.0, 0.0, & + & 0.83333333333333333333, 0.16666666666666666667, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.16666666666666666667, 0.83333333333333333333, 0.0, & + & 0.0, 0.83333333333333333333, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.16666666666666666667, 0.0, & + & 0.0, 0.0, 0.83333333333333333333, & + & 0.0, 0.0, 0.66666666666666666667, & + & 0.0, 0.0, 0.5, & + & 0.0, 0.0, 0.33333333333333333333, & + & 0.0, 0.0, 0.16666666666666666667, & + & 0.0, 0.16666666666666666667, 0.83333333333333333333, & + & 0.0, 0.33333333333333333333, 0.66666666666666666667, & + & 0.0, 0.5, 0.5, & + & 0.0, 0.66666666666666666667, 0.33333333333333333333, & + & 0.0, 0.83333333333333333333, 0.16666666666666666667, & + & 0.16666666666666666667, 0.0, 0.83333333333333333333, & + & 0.33333333333333333333, 0.0, 0.66666666666666666667, & + & 0.5, 0.0, 0.5, & + & 0.66666666666666666667, 0.0, 0.33333333333333333333, & + & 0.83333333333333333333, 0.0, 0.16666666666666666667, & + & 0.16666666666666666667, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.66666666666666666667, 0.0, & + & 0.66666666666666666667, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.33333333333333333333, 0.0, & + & 0.16666666666666666667, 0.5, 0.0, & + & 0.33333333333333333333, 0.5, 0.0, & + & 0.5, 0.33333333333333333333, 0.0, & + & 0.5, 0.16666666666666666667, 0.0, & + & 0.33333333333333333333, 0.16666666666666666667, 0.0, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0, & + & 0.16666666666666666667, 0.0, 0.16666666666666666667, & + & 0.66666666666666666667, 0.0, 0.16666666666666666667, & + & 0.16666666666666666667, 0.0, 0.66666666666666666667, & + & 0.33333333333333333333, 0.0, 0.16666666666666666667, & + & 0.5, 0.0, 0.16666666666666666667, & + & 0.5, 0.0, 0.33333333333333333333, & + & 0.33333333333333333333, 0.0, 0.5, & + & 0.16666666666666666667, 0.0, 0.5, & + & 0.16666666666666666667, 0.0, 0.33333333333333333333, & + & 0.33333333333333333333, 0.0, 0.33333333333333333333, & + & 0.0, 0.16666666666666666667, 0.16666666666666666667, & + & 0.0, 0.16666666666666666667, 0.66666666666666666667, & + & 0.0, 0.66666666666666666667, 0.16666666666666666667, & + & 0.0, 0.16666666666666666667, 0.33333333333333333333, & + & 0.0, 0.16666666666666666667, 0.5, & + & 0.0, 0.33333333333333333333, 0.5, & + & 0.0, 0.5, 0.33333333333333333333, & + & 0.0, 0.5, 0.16666666666666666667, & + & 0.0, 0.33333333333333333333, 0.16666666666666666667, & + & 0.0, 0.33333333333333333333, 0.33333333333333333333, & + & 0.16666666666666666667, 0.16666666666666666667, & + & 0.66666666666666666667, & + & 0.66666666666666666667, 0.16666666666666666667, & + & 0.16666666666666666667, & + & 0.16666666666666666667, 0.66666666666666666667, & + & 0.16666666666666666667, & + & 0.33333333333333333333, 0.16666666666666666667, 0.5, & + & 0.5, 0.16666666666666666667, 0.33333333333333333333, & + & 0.5, 0.33333333333333333333, 0.16666666666666666667, & + & 0.33333333333333333333, 0.5, 0.16666666666666666667, & + & 0.16666666666666666667, 0.5, 0.33333333333333333333, & + & 0.16666666666666666667, 0.33333333333333333333, 0.5, & + & 0.33333333333333333333, 0.33333333333333333333, & + & 0.33333333333333333333, & + & 0.16666666666666666667, 0.16666666666666666667, & + & 0.16666666666666666667, & + & 0.5, 0.16666666666666666667, 0.16666666666666666667, & + & 0.16666666666666666667, 0.5, 0.16666666666666666667, & + & 0.16666666666666666667, 0.16666666666666666667, 0.5, & + & 0.33333333333333333333, 0.16666666666666666667, & + & 0.16666666666666666667, & + & 0.33333333333333333333, 0.33333333333333333333, & + & 0.16666666666666666667, & + & 0.16666666666666666667, 0.33333333333333333333, & + & 0.16666666666666666667, & + & 0.16666666666666666667, 0.16666666666666666667, & + & 0.33333333333333333333, & + & 0.16666666666666666667, 0.33333333333333333333, & + & 0.33333333333333333333, & + & 0.33333333333333333333, 0.16666666666666666667, & + & 0.33333333333333333333], [3, 84]) +END SELECT + !! +END PROCEDURE EquidistanceLIP_Tetrahedron diff --git a/src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc b/src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc new file mode 100644 index 000000000..8b5bb1a8d --- /dev/null +++ b/src/submodules/Polynomial/src/EquidistanceLIP_Triangle.inc @@ -0,0 +1,403 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 PROCEDURE EquidistanceLIP_Triangle + !! + !! Define internal variables + !! + INTEGER( I4B ) :: i + REAL( DFP ) :: x( 3 ), y( 3 ) + REAL( DFP ), ALLOCATABLE :: xi( : ), eta( : ) + !! + !! + !! + SELECT CASE( Order ) + !! + CASE( 1 ) + !! + !! order 1; Triangle3 + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP], [3, 3] ) + !! + CASE( 2 ) + !! + !! order 2, Triangle6 + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.5_DFP, 0.0_DFP, 0.0_DFP, & + & 0.5_DFP, 0.5_DFP, 0.0_DFP, & + & 0.0_DFP, 0.5_DFP, 0.0_DFP ], & + & [3, 6]) + !! + CASE( 3 ) + !! + !! order 3, Triangle10 + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.33333333333333333333_DFP, 0.0_DFP, 0.0_DFP, & + & 0.66666666666666666667_DFP, 0.0_DFP, 0.0_DFP, & + & 0.66666666666666666667_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & + & 0.33333333333333333333_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & + & 0.0_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & + & 0.0_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & + & 0.33333333333333333333_DFP, 0.33333333333333333333_DFP, 0.0_DFP], & + & [3, 10]) + !! + CASE( 4 ) + !! + !! order 4 Includes bubble nodes also + !! Trianagle15a + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.25_DFP, 0.0_DFP, 0.0_DFP, & + & 0.5_DFP, 0.0_DFP, 0.0_DFP, & + & 0.75_DFP, 0.0_DFP, 0.0_DFP, & + & 0.75_DFP, 0.25_DFP, 0.0_DFP, & + & 0.5_DFP, 0.5_DFP, 0.0_DFP, & + & 0.25_DFP, 0.75_DFP, 0.0_DFP, & + & 0.0_DFP, 0.75_DFP, 0.0_DFP, & + & 0.0_DFP, 0.5_DFP, 0.0_DFP, & + & 0.0_DFP, 0.25_DFP, 0.0_DFP, & + & 0.25_DFP, 0.25_DFP, 0.0_DFP, & + & 0.5_DFP, 0.25_DFP, 0.0_DFP, & + & 0.25_DFP, 0.5_DFP, 0.0_DFP], & + & [3, 15]) + !! + CASE( 5 ) + !! + !! This is fifth order triangle + !! 3 nodes on vertex, 12 nodes on edge, and 6 on the face + !! Triangle21 + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.2, 0.0, 0.0, & + & 0.4, 0.0, 0.0, & + & 0.6, 0.0, 0.0, & + & 0.8, 0.0, 0.0, & + & 0.8, 0.2, 0.0, & + & 0.6, 0.4, 0.0, & + & 0.4, 0.6, 0.0, & + & 0.2, 0.8, 0.0, & + & 0.0, 0.8, 0.0, & + & 0.0, 0.6, 0.0, & + & 0.0, 0.4, 0.0, & + & 0.0, 0.2, 0.0, & + & 0.2, 0.2, 0.0, & + & 0.6, 0.2, 0.0, & + & 0.2, 0.6, 0.0, & + & 0.4, 0.2, 0.0, & + & 0.4, 0.4, 0.0, & + & 0.2, 0.4, 0.0], [3, 21]) + !! + CASE( 6 ) + !! + !! Triangle28 + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.16666666666666666667, 0.0, 0.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.83333333333333333333, 0.0, 0.0, & + & 0.83333333333333333333, 0.16666666666666666667, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.16666666666666666667, 0.83333333333333333333, 0.0, & + & 0.0, 0.83333333333333333333, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.16666666666666666667, 0.0, & + & 0.66666666666666666667, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.66666666666666666667, 0.0, & + & 0.33333333333333333333, 0.16666666666666666667, 0.0, & + & 0.5, 0.16666666666666666667, 0.0, & + & 0.5, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.5, 0.0, & + & 0.16666666666666666667, 0.5, 0.0, & + & 0.16666666666666666667, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0], [3, 28] ) + !! + CASE( 7 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.14285714285714285714, 0.0, 0.0, & + & 0.28571428571428571429, 0.0, 0.0, & + & 0.42857142857142857143, 0.0, 0.0, & + & 0.57142857142857142857, 0.0, 0.0, & + & 0.71428571428571428571, 0.0, 0.0, & + & 0.85714285714285714286, 0.0, 0.0, & + & 0.85714285714285714286, 0.14285714285714285714, 0.0, & + & 0.71428571428571428571, 0.28571428571428571429, 0.0, & + & 0.57142857142857142857, 0.42857142857142857143, 0.0, & + & 0.42857142857142857143, 0.57142857142857142857, 0.0, & + & 0.28571428571428571429, 0.71428571428571428571, 0.0, & + & 0.14285714285714285714, 0.85714285714285714286, 0.0, & + & 0.0, 0.85714285714285714286, 0.0, & + & 0.0, 0.71428571428571428571, 0.0, & + & 0.0, 0.57142857142857142857, 0.0, & + & 0.0, 0.42857142857142857143, 0.0, & + & 0.0, 0.28571428571428571429, 0.0, & + & 0.0, 0.14285714285714285714, 0.0, & + & 0.14285714285714285714, 0.14285714285714285714, 0.0, & + & 0.71428571428571428571, 0.14285714285714285714, 0.0, & + & 0.14285714285714285714, 0.71428571428571428571, 0.0, & + & 0.28571428571428571429, 0.14285714285714285714, 0.0, & + & 0.42857142857142857143, 0.14285714285714285714, 0.0, & + & 0.57142857142857142857, 0.14285714285714285714, 0.0, & + & 0.57142857142857142857, 0.28571428571428571429, 0.0, & + & 0.42857142857142857143, 0.42857142857142857143, 0.0, & + & 0.28571428571428571429, 0.57142857142857142857, 0.0, & + & 0.14285714285714285714, 0.57142857142857142857, 0.0, & + & 0.14285714285714285714, 0.42857142857142857143, 0.0, & + & 0.14285714285714285714, 0.28571428571428571429, 0.0, & + & 0.28571428571428571429, 0.28571428571428571429, 0.0, & + & 0.42857142857142857143, 0.28571428571428571429, 0.0, & + & 0.28571428571428571429, 0.42857142857142857143, 0.0 ], [3,36]) + !! + CASE( 8 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.125, 0.0, 0.0, & + & 0.25, 0.0, 0.0, & + & 0.375, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.625, 0.0, 0.0, & + & 0.75, 0.0, 0.0, & + & 0.875, 0.0, 0.0, & + & 0.875, 0.125, 0.0, & + & 0.75, 0.25, 0.0, & + & 0.625, 0.375, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.375, 0.625, 0.0, & + & 0.25, 0.75, 0.0, & + & 0.125, 0.875, 0.0, & + & 0.0, 0.875, 0.0, & + & 0.0, 0.75, 0.0, & + & 0.0, 0.625, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.375, 0.0, & + & 0.0, 0.25, 0.0, & + & 0.0, 0.125, 0.0, & + & 0.125, 0.125, 0.0, & + & 0.75, 0.125, 0.0, & + & 0.125, 0.75, 0.0, & + & 0.25, 0.125, 0.0, & + & 0.375, 0.125, 0.0, & + & 0.5, 0.125, 0.0, & + & 0.625, 0.125, 0.0, & + & 0.625, 0.25, 0.0, & + & 0.5, 0.375, 0.0, & + & 0.375, 0.5, 0.0, & + & 0.25, 0.625, 0.0, & + & 0.125, 0.625, 0.0, & + & 0.125, 0.5, 0.0, & + & 0.125, 0.375, 0.0, & + & 0.125, 0.25, 0.0, & + & 0.25, 0.25, 0.0, & + & 0.5, 0.25, 0.0, & + & 0.25, 0.5, 0.0, & + & 0.375, 0.25, 0.0, & + & 0.375, 0.375, 0.0, & + & 0.25, 0.375, 0.0 ], [3, 45]) + !! + CASE( 9 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.11111111111111111111, 0.0, 0.0, & + & 0.22222222222222222222, 0.0, 0.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.44444444444444444444, 0.0, 0.0, & + & 0.55555555555555555556, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.77777777777777777778, 0.0, 0.0, & + & 0.88888888888888888889, 0.0, 0.0, & + & 0.88888888888888888889, 0.11111111111111111111, 0.0, & + & 0.77777777777777777778, 0.22222222222222222222, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.55555555555555555556, 0.44444444444444444444, 0.0, & + & 0.44444444444444444444, 0.55555555555555555556, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.22222222222222222222, 0.77777777777777777778, 0.0, & + & 0.11111111111111111111, 0.88888888888888888889, 0.0, & + & 0.0, 0.88888888888888888889, 0.0, & + & 0.0, 0.77777777777777777778, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.55555555555555555556, 0.0, & + & 0.0, 0.44444444444444444444, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.22222222222222222222, 0.0, & + & 0.0, 0.11111111111111111111, 0.0, & + & 0.11111111111111111111, 0.11111111111111111111, 0.0, & + & 0.77777777777777777778, 0.11111111111111111111, 0.0, & + & 0.11111111111111111111, 0.77777777777777777778, 0.0, & + & 0.22222222222222222222, 0.11111111111111111111, 0.0, & + & 0.33333333333333333333, 0.11111111111111111111, 0.0, & + & 0.44444444444444444444, 0.11111111111111111111, 0.0, & + & 0.55555555555555555556, 0.11111111111111111111, 0.0, & + & 0.66666666666666666667, 0.11111111111111111111, 0.0, & + & 0.66666666666666666667, 0.22222222222222222222, 0.0, & + & 0.55555555555555555556, 0.33333333333333333333, 0.0, & + & 0.44444444444444444444, 0.44444444444444444444, 0.0, & + & 0.33333333333333333333, 0.55555555555555555556, 0.0, & + & 0.22222222222222222222, 0.66666666666666666667, 0.0, & + & 0.11111111111111111111, 0.66666666666666666667, 0.0, & + & 0.11111111111111111111, 0.55555555555555555556, 0.0, & + & 0.11111111111111111111, 0.44444444444444444444, 0.0, & + & 0.11111111111111111111, 0.33333333333333333333, 0.0, & + & 0.11111111111111111111, 0.22222222222222222222, 0.0, & + & 0.22222222222222222222, 0.22222222222222222222, 0.0, & + & 0.55555555555555555556, 0.22222222222222222222, 0.0, & + & 0.22222222222222222222, 0.55555555555555555556, 0.0, & + & 0.33333333333333333333, 0.22222222222222222222, 0.0, & + & 0.44444444444444444444, 0.22222222222222222222, 0.0, & + & 0.44444444444444444444, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.44444444444444444444, 0.0, & + & 0.22222222222222222222, 0.44444444444444444444, 0.0, & + & 0.22222222222222222222, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0 ], [3,55] ) + !! + CASE( 10 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.1, 0.0, 0.0, & + & 0.2, 0.0, 0.0, & + & 0.3, 0.0, 0.0, & + & 0.4, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.6, 0.0, 0.0, & + & 0.7, 0.0, 0.0, & + & 0.8, 0.0, 0.0, & + & 0.9, 0.0, 0.0, & + & 0.9, 0.1, 0.0, & + & 0.8, 0.2, 0.0, & + & 0.7, 0.3, 0.0, & + & 0.6, 0.4, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.4, 0.6, 0.0, & + & 0.3, 0.7, 0.0, & + & 0.2, 0.8, 0.0, & + & 0.1, 0.9, 0.0, & + & 0.0, 0.9, 0.0, & + & 0.0, 0.8, 0.0, & + & 0.0, 0.7, 0.0, & + & 0.0, 0.6, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.4, 0.0, & + & 0.0, 0.3, 0.0, & + & 0.0, 0.2, 0.0, & + & 0.0, 0.1, 0.0, & + & 0.1, 0.1, 0.0, & + & 0.8, 0.1, 0.0, & + & 0.1, 0.8, 0.0, & + & 0.2, 0.1, 0.0, & + & 0.3, 0.1, 0.0, & + & 0.4, 0.1, 0.0, & + & 0.5, 0.1, 0.0, & + & 0.6, 0.1, 0.0, & + & 0.7, 0.1, 0.0, & + & 0.7, 0.2, 0.0, & + & 0.6, 0.3, 0.0, & + & 0.5, 0.4, 0.0, & + & 0.4, 0.5, 0.0, & + & 0.3, 0.6, 0.0, & + & 0.2, 0.7, 0.0, & + & 0.1, 0.7, 0.0, & + & 0.1, 0.6, 0.0, & + & 0.1, 0.5, 0.0, & + & 0.1, 0.4, 0.0, & + & 0.1, 0.3, 0.0, & + & 0.1, 0.2, 0.0, & + & 0.2, 0.2, 0.0, & + & 0.6, 0.2, 0.0, & + & 0.2, 0.6, 0.0, & + & 0.3, 0.2, 0.0, & + & 0.4, 0.2, 0.0, & + & 0.5, 0.2, 0.0, & + & 0.5, 0.3, 0.0, & + & 0.4, 0.4, 0.0, & + & 0.3, 0.5, 0.0, & + & 0.2, 0.5, 0.0, & + & 0.2, 0.4, 0.0, & + & 0.2, 0.3, 0.0, & + & 0.3, 0.3, 0.0, & + & 0.4, 0.3, 0.0, & + & 0.3, 0.4, 0.0 ], [3,66] ) + END SELECT + !! + !! + !! + IF( PRESENT( xij ) ) THEN + !! + ALLOCATE( xi( SIZE( nodecoord, 2 ) ), eta( SIZE( nodecoord, 2 ) ) ) + xi( : ) = nodecoord( 1, : ) + eta( : ) = nodecoord( 2, : ) + !! + x = xij( 1, 1:3 ) + y = xij( 2, 1:3 ) + !! + nodecoord( 1, : ) = x( 1 ) + ( x( 2 ) - x( 1 ) ) * xi & + & + ( x( 3 ) - x( 1 ) ) * eta + !! + nodecoord( 2, : ) = y( 1 ) + ( y( 2 ) - y( 1 ) ) * xi & + & + ( y( 3 ) - y( 1 ) ) * eta + !! + DEALLOCATE( xi, eta ) + !! + END IF + !! +END PROCEDURE EquidistanceLIP_Triangle \ No newline at end of file diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..4e1eb13d0 --- /dev/null +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -0,0 +1,2950 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(HexahedronInterpolationUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! RefElemDomain_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Hexahedron +ans = "BIUNIT" +END PROCEDURE RefElemDomain_Hexahedron + +!---------------------------------------------------------------------------- +! GetVertexDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetVertexDOF_Hexahedron +ans = 8_I4B +END PROCEDURE GetVertexDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeDOF_Hexahedron1 +ans = MAX(pe1 + pe2 + pe3 + pe4 - 4_I4B, 0_I4B) +END PROCEDURE GetEdgeDOF_Hexahedron1 + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeDOF_Hexahedron2 +ans = GetEdgeDOF_Hexahedron(p, p, p, p) & + & + GetEdgeDOF_Hexahedron(q, q, q, q) & + & + GetEdgeDOF_Hexahedron(r, r, r, r) +END PROCEDURE GetEdgeDOF_Hexahedron2 + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeDOF_Hexahedron3 +ans = GetEdgeDOF_Hexahedron(p, p, p) +END PROCEDURE GetEdgeDOF_Hexahedron3 + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeDOF_Hexahedron4 +ans = GetEdgeDOF_Hexahedron(px1, px2, px3, px4) & + & + GetEdgeDOF_Hexahedron(py1, py2, py3, py4) & + & + GetEdgeDOF_Hexahedron(pz1, pz2, pz3, pz4) +END PROCEDURE GetEdgeDOF_Hexahedron4 + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFacetDOF_Hexahedron1 +ans = GetFacetDOF_Hexahedron(pxy1, pxy2) & + & + GetFacetDOF_Hexahedron(pxz1, pxz2) & + & + GetFacetDOF_Hexahedron(pyz1, pyz2) +ans = 2_I4B * ans +END PROCEDURE GetFacetDOF_Hexahedron1 + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFacetDOF_Hexahedron2 +ans = GetFacetDOF_Hexahedron(p, q) & + & + GetFacetDOF_Hexahedron(p, r) & + & + GetFacetDOF_Hexahedron(q, r) +ans = ans * 2_I4B +END PROCEDURE GetFacetDOF_Hexahedron2 + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFacetDOF_Hexahedron3 +ans = (p - 1) * (q - 1) +END PROCEDURE GetFacetDOF_Hexahedron3 + +!---------------------------------------------------------------------------- +! GetFacetDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFacetDOF_Hexahedron4 +ans = GetFacetDOF_Hexahedron(p, p) * 6_I4B +END PROCEDURE GetFacetDOF_Hexahedron4 + +!---------------------------------------------------------------------------- +! GetCellDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetCellDOF_Hexahedron1 +ans = (p - 1) * (q - 1) * (r - 1) +END PROCEDURE GetCellDOF_Hexahedron1 + +!---------------------------------------------------------------------------- +! GetCellDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetCellDOF_Hexahedron2 +ans = GetCellDOF_Hexahedron(p, p, p) +END PROCEDURE GetCellDOF_Hexahedron2 + +!---------------------------------------------------------------------------- +! QuadratureNumber_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Hexahedron +ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1) +ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2) +ans(3) = QuadratureNumber_Line(order=r, quadType=quadType3) +END PROCEDURE QuadratureNumber_Hexahedron + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeConnectivity_Hexahedron +CALL GetEdgeConnectivity_Hexahedron(con=ans) +END PROCEDURE EdgeConnectivity_Hexahedron + +!---------------------------------------------------------------------------- +! FacetConnectivity_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetConnectivity_Hexahedron +TYPE(String) :: baseInterpol0 +TYPE(String) :: baseContinuity0 + +baseInterpol0 = UpperCase(baseInterpol) +baseContinuity0 = UpperCase(baseContinuity) + +SELECT CASE (baseInterpol0%chars()) +CASE ( & + & "HIERARCHYPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHYPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION", & + & "ORTHOGONALPOLYNOMIAL", & + & "ORTHOGONAL", & + & "ORTHOGONALINTERPOLATION") + ans(:, 1) = [1, 2, 3, 4] ! back + ans(:, 2) = [5, 6, 7, 8] ! front + ans(:, 3) = [1, 4, 8, 5] ! left + ans(:, 4) = [2, 3, 7, 6] ! right + ans(:, 5) = [1, 2, 6, 5] ! bottom + ans(:, 6) = [4, 3, 7, 8] ! top +CASE DEFAULT + ans(:, 1) = [1, 4, 3, 2] ! back + ans(:, 2) = [5, 6, 7, 8] ! front + ans(:, 3) = [1, 5, 8, 4] ! left + ans(:, 4) = [2, 3, 7, 6] ! right + ans(:, 5) = [1, 2, 6, 5] ! bottom + ans(:, 6) = [3, 4, 8, 7] ! top +END SELECT + +END PROCEDURE FacetConnectivity_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeDegree_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Hexahedron1 +INTEGER(I4B) :: n, ii, jj, kk, indx +n = LagrangeDOF_Hexahedron(order=order) +ALLOCATE (ans(n, 3)) +indx = 0 +DO kk = 0, order + DO jj = 0, order + DO ii = 0, order + indx = indx + 1 + ans(indx, 1) = ii + ans(indx, 2) = jj + ans(indx, 3) = kk + END DO + END DO +END DO +END PROCEDURE LagrangeDegree_Hexahedron1 + +!---------------------------------------------------------------------------- +! LagrangeDegree_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Hexahedron2 +INTEGER(I4B) :: n, ii, jj, kk, indx +n = LagrangeDOF_Hexahedron(p=p, q=q, r=r) +ALLOCATE (ans(n, 3)) +indx = 0 +DO kk = 0, r + DO jj = 0, q + DO ii = 0, p + indx = indx + 1 + ans(indx, 1) = ii + ans(indx, 2) = jj + ans(indx, 3) = kk + END DO + END DO +END DO +END PROCEDURE LagrangeDegree_Hexahedron2 + +!---------------------------------------------------------------------------- +! GetTotalDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Hexahedron +ans = (order + 1)**3 +END PROCEDURE GetTotalDOF_Hexahedron + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Hexahedron +ans = (order - 1)**3 +END PROCEDURE GetTotalInDOF_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Hexahedron1 +ans = (order + 1)**3 +END PROCEDURE LagrangeDOF_Hexahedron1 + +!---------------------------------------------------------------------------- +! LagrangeDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Hexahedron2 +ans = (p + 1) * (q + 1) * (r + 1) +END PROCEDURE LagrangeDOF_Hexahedron2 + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Hexahedron1 +ans = (order - 1)**3 +END PROCEDURE LagrangeInDOF_Hexahedron1 + +!---------------------------------------------------------------------------- +! LagrangeDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Hexahedron2 +ans = (p - 1) * (q - 1) * (r - 1) +END PROCEDURE LagrangeInDOF_Hexahedron2 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Hexahedron1 +ans = EquidistancePoint_Hexahedron2(p=order, q=order, r=order, xij=xij) +END PROCEDURE EquidistancePoint_Hexahedron1 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Hexahedron2 +! internal variables +REAL(DFP) :: x(p + 1), y(q + 1), z(r + 1), temp0 +REAL(DFP), DIMENSION(p + 1, q + 1, r + 1) :: xi, eta, zeta +REAL(DFP) :: temp(3, (p + 1) * (q + 1) * (r + 1)) +INTEGER(I4B) :: ii, jj, kk, nsd + +x = EquidistancePoint_Line(order=p, xij=[-1.0_DFP, 1.0_DFP]) +y = EquidistancePoint_Line(order=q, xij=[-1.0_DFP, 1.0_DFP]) +z = EquidistancePoint_Line(order=r, xij=[-1.0_DFP, 1.0_DFP]) +IF (p .GT. 0_I4B) THEN + temp0 = x(2) +END IF +DO ii = 2, p + x(ii) = x(ii + 1) +END DO +x(p + 1) = temp0 + +IF (q .GT. 0_I4B) THEN + temp0 = y(2) +END IF +DO ii = 2, q + y(ii) = y(ii + 1) +END DO +y(q + 1) = temp0 + +IF (r .GT. 0_I4B) THEN + temp0 = z(2) +END IF +DO ii = 2, r + z(ii) = z(ii + 1) +END DO +z(r + 1) = temp0 + +nsd = 3 +CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1)) + +DO ii = 1, p + 1 + DO jj = 1, q + 1 + DO kk = 1, r + 1 + xi(ii, jj, kk) = x(ii) + eta(ii, jj, kk) = y(jj) + zeta(ii, jj, kk) = z(kk) + END DO + END DO +END DO + +CALL IJK2VEFC_Hexahedron( & + & xi=xi, & + & eta=eta, & + & zeta=zeta, & + & temp=temp, & + & p=p, & + & q=q, & + & r=r) + +IF (PRESENT(xij)) THEN + ans = FromBiUnitHexahedron2Hexahedron( & + & xin=temp, & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4), & + & x5=xij(:, 5), & + & x6=xij(:, 6), & + & x7=xij(:, 7), & + & x8=xij(:, 8) & + & ) +ELSE + ans = temp +END IF + +END PROCEDURE EquidistancePoint_Hexahedron2 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Hexahedron1 +ans = EquidistanceInPoint_Hexahedron2(p=order, q=order, r=order, xij=xij) +END PROCEDURE EquidistanceInPoint_Hexahedron1 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Hexahedron2 +INTEGER(I4B) :: i1, i2, ii +REAL(DFP), ALLOCATABLE :: ans0(:, :) + +ans0 = EquidistancePoint_Hexahedron(p=p, q=q, r=r, xij=xij) +i1 = LagrangeDOF_Hexahedron(p=p, q=q, r=r) +i2 = LagrangeInDOF_Hexahedron(p=p, q=q, r=r) +CALL reallocate(ans, 3, i2) +ii = i1 - i2 +IF (ii + 1 .LE. SIZE(ans0, 2)) ans = ans0(:, ii + 1:) +IF (ALLOCATED(ans0)) DEALLOCATE (ans0) +END PROCEDURE EquidistanceInPoint_Hexahedron2 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Hexahedron1 +ans = InterpolationPoint_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & layout=layout, & + & ipType1=ipType, & + & ipType2=ipType, & + & ipType3=ipType, & + & alpha1=alpha, & + & alpha2=alpha, & + & alpha3=alpha, & + & beta1=beta, & + & beta2=beta, & + & beta3=beta, & + & lambda1=lambda, & + & lambda2=lambda, & + & lambda3=lambda, & + & xij=xij) +END PROCEDURE InterpolationPoint_Hexahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Hexahedron2 +! internal variables +REAL(DFP) :: x(p + 1), y(q + 1), z(r + 1) +REAL(DFP), DIMENSION(p + 1, q + 1, r + 1) :: xi, eta, zeta +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: ii, jj, kk, nsd, cnt +TYPE(String) :: astr + +astr = TRIM(UpperCase(layout)) + +x = InterpolationPoint_Line(order=p, ipType=ipType1, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha1, beta=beta1, lambda=lambda1 & + & ) + +y = InterpolationPoint_Line(order=q, ipType=ipType2, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha2, beta=beta2, lambda=lambda2 & + & ) + +z = InterpolationPoint_Line(order=r, ipType=ipType3, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha3, beta=beta3, lambda=lambda3 & + & ) + +nsd = 3 + +CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1)) +CALL Reallocate(temp, nsd, (p + 1) * (q + 1) * (r + 1)) + +xi = 0.0_DFP +eta = 0.0_DFP +zeta = 0.0_DFP + +DO ii = 1, p + 1 + DO jj = 1, q + 1 + DO kk = 1, r + 1 + xi(ii, jj, kk) = x(ii) + eta(ii, jj, kk) = y(jj) + zeta(ii, jj, kk) = z(kk) + END DO + END DO +END DO + +IF (astr%chars() .EQ. "VEFC") THEN + CALL IJK2VEFC_Hexahedron( & + & xi=xi, & + & eta=eta, & + & zeta=zeta, & + & temp=temp, & + & p=p, & + & q=q, & + & r=r) +ELSE + cnt = 0 + DO ii = 1, p + 1 + DO jj = 1, q + 1 + DO kk = 1, r + 1 + cnt = cnt + 1 + temp(1, cnt) = x(ii) + temp(2, cnt) = y(ii) + temp(3, cnt) = z(ii) + END DO + END DO + END DO +END IF + +IF (PRESENT(xij)) THEN + ans = FromBiUnitHexahedron2Hexahedron( & + & xin=temp, & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4), & + & x5=xij(:, 5), & + & x6=xij(:, 6), & + & x7=xij(:, 7), & + & x8=xij(:, 8) & + & ) +ELSE + ans = temp +END IF +END PROCEDURE InterpolationPoint_Hexahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJK2VEFC_Hexahedron +! internal variables +INTEGER(I4B) :: cnt, ii, jj, kk, ll, N, & + & ii1, ii2, jj1, jj2, kk1, kk2, ijk(3, 8), & + & iedge, iface, p1, p2, dii, djj, dkk, startNode +INTEGER(I4B), PARAMETER :: tPoints = 8, tEdges = 12, tFacets = 6 +INTEGER(I4B) :: edgeConnectivity(2, tEdges) +INTEGER(I4B) :: facetConnectivity(4, tFacets) +REAL(DFP), ALLOCATABLE :: temp2d(:, :), temp_in(:, :) +REAL(DFP), ALLOCATABLE :: xi_in(:, :, :), eta_in(:, :, :), zeta_in(:, :, :) + +! vertices +IF (ALL([p, q, r] .EQ. 0_I4B)) THEN + temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + RETURN +END IF + +N = (p + 1) * (q + 1) * (r + 1) +cnt = 0 + +ijk(:, 1) = [1, 1, 1] +ijk(:, 2) = [p + 1, 1, 1] +ijk(:, 3) = [p + 1, q + 1, 1] +ijk(:, 4) = [1, q + 1, 1] +ijk(:, 5) = [1, 1, r + 1] +ijk(:, 6) = [p + 1, 1, r + 1] +ijk(:, 7) = [p + 1, q + 1, r + 1] +ijk(:, 8) = [1, q + 1, r + 1] + +edgeConnectivity = EdgeConnectivity_Hexahedron( & + & baseInterpol="Lagrange", & + & baseContinuity="H1") + +facetConnectivity = FacetConnectivity_Hexahedron( & + & baseInterpol="Lagrange", & + & baseContinuity="H1") + +IF (ALL([p, q, r] .GE. 1_I4B)) THEN + DO ii = 1, 8 + cnt = cnt + 1 + temp(:, ii) = [& + & xi(ijk(1, ii), ijk(2, ii), ijk(3, ii)), & + & eta(ijk(1, ii), ijk(2, ii), ijk(3, ii)), & + & zeta(ijk(1, ii), ijk(2, ii), ijk(3, ii))] + END DO + + IF (ALL([p, q, r] .EQ. 1_I4B)) RETURN + +ELSE + + DO ii = 1, p + 1 + DO jj = 1, q + 1 + DO kk = 1, r + 1 + cnt = cnt + 1 + temp(:, cnt) = & + & [ & + & xi(ii, jj, kk), & + & eta(ii, jj, kk), & + & zeta(ii, jj, kk) & + & ] + END DO + END DO + END DO + +END IF + +IF (ALL([p, q, r] .GE. 1_I4B)) THEN + DO iedge = 1, tEdges + p1 = edgeConnectivity(1, iedge) + p2 = edgeConnectivity(2, iedge) + + IF (ijk(1, p1) .EQ. ijk(1, p2)) THEN + ii1 = ijk(1, p1) + ii2 = ii1 + dii = 1 + ELSE IF (ijk(1, p1) .LT. ijk(1, p2)) THEN + ii1 = ijk(1, p1) + 1 + ii2 = ijk(1, p2) - 1 + dii = 1 + ELSE IF (ijk(1, p1) .GT. ijk(1, p2)) THEN + ii1 = ijk(1, p1) - 1 + ii2 = ijk(1, p2) + 1 + dii = -1 + END IF + + IF (ijk(2, p1) .EQ. ijk(2, p2)) THEN + jj1 = ijk(2, p1) + jj2 = jj1 + djj = 1 + ELSE IF (ijk(2, p1) .LT. ijk(2, p2)) THEN + jj1 = ijk(2, p1) + 1 + jj2 = ijk(2, p2) - 1 + djj = 1 + ELSE IF (ijk(2, p1) .GT. ijk(2, p2)) THEN + jj1 = ijk(2, p1) - 1 + jj2 = ijk(2, p2) + 1 + djj = -1 + END IF + + IF (ijk(3, p1) .EQ. ijk(3, p2)) THEN + kk1 = ijk(3, p1) + kk2 = kk1 + dkk = 1 + ELSE IF (ijk(3, p1) .LT. ijk(3, p2)) THEN + kk1 = ijk(3, p1) + 1 + kk2 = ijk(3, p2) - 1 + dkk = 1 + ELSE IF (ijk(3, p1) .GT. ijk(3, p2)) THEN + kk1 = ijk(3, p1) - 1 + kk2 = ijk(3, p2) + 1 + dkk = -1 + END IF + + DO ii = ii1, ii2, dii + DO jj = jj1, jj2, djj + DO kk = kk1, kk2, dkk + cnt = cnt + 1 + temp(:, cnt) = [ & + & xi(ii, jj, kk), & + & eta(ii, jj, kk), & + & zeta(ii, jj, kk)] + END DO + END DO + END DO + END DO + + ! face 1, x-y, clockwise, startNode + kk = 1 + startNode = 1 + CALL Reallocate(temp2d, 2, (p + 1) * (q + 1)) + CALL IJ2VEFC_Quadrangle_Clockwise( & + & xi=xi(:, :, kk), & + & eta=eta(:, :, kk), & + & temp=temp2d, & + & p=p, & + & q=q, & + & startNode=startNode) + + IF ((p + 1) * (q + 1) .GE. 2 * (p + q) + 1) THEN + ii1 = cnt + 1 + ii2 = cnt + (p - 1) * (q - 1) + cnt = ii2 + temp(1:2, ii1:ii2) = temp2d(1:2, 2 * (p + q) + 1:) + temp(3, ii1:ii2) = zeta(1, 1, kk) !!-1.0_DFP ! TODO + END IF + + ! face 2, x-y, anticlockwise + kk = r + 1 + startNode = 1 + CALL IJ2VEFC_Quadrangle_AntiClockwise( & + & xi=xi(:, :, kk), & + & eta=eta(:, :, kk), & + & temp=temp2d, & + & p=p, & + & q=q, & + & startNode=startNode) + + IF ((p + 1) * (q + 1) .GE. 2 * (p + q) + 1) THEN + ii1 = cnt + 1 + ii2 = cnt + (p - 1) * (q - 1) + cnt = ii2 + temp(1:2, ii1:ii2) = temp2d(1:2, 2 * (p + q) + 1:) + temp(3, ii1:ii2) = zeta(1, 1, kk) !! 1.0_DFP ! TODO + END IF + + ! face-3 + ! z-y + ! clockwise + ii = 1 + startNode = 1 + CALL Reallocate(temp2d, 2, (r + 1) * (q + 1)) + CALL IJ2VEFC_Quadrangle_AntiClockwise( & + & xi=TRANSPOSE(zeta(ii, :, :)), & + & eta=TRANSPOSE(eta(ii, :, :)), & + & temp=temp2d, & + & p=r, & + & q=q, & + & startNode=startNode) + + IF ((r + 1) * (q + 1) .GE. 2 * (r + q) + 1) THEN + ii1 = cnt + 1 + ii2 = cnt + (r - 1) * (q - 1) + cnt = ii2 + temp(1, ii1:ii2) = xi(ii, 1, 1) !!-1.0_DFP + temp(2, ii1:ii2) = temp2d(2, 2 * (r + q) + 1:) + temp(3, ii1:ii2) = temp2d(1, 2 * (r + q) + 1:) + END IF + + ! face 4 + ! z-y + ! anticlockwise + ii = p + 1 + startNode = 1 + CALL IJ2VEFC_Quadrangle_Clockwise( & + & xi=TRANSPOSE(zeta(ii, :, :)), & + & eta=TRANSPOSE(eta(ii, :, :)), & + & temp=temp2d, & + & p=r, & + & q=q, & + & startNode=startNode) + + IF ((r + 1) * (q + 1) .GE. 2 * (r + q) + 1) THEN + ii1 = cnt + 1 + ii2 = cnt + (r - 1) * (q - 1) + cnt = ii2 + temp(1, ii1:ii2) = xi(ii, 1, 1) !!1.0_DFP ! TODO + temp(2, ii1:ii2) = temp2d(2, 2 * (r + q) + 1:) + temp(3, ii1:ii2) = temp2d(1, 2 * (r + q) + 1:) + END IF + + ! face 5 + ! z-x + ! anticlockwise + jj = q + 1 + startNode = 4 + CALL Reallocate(temp2d, 2, (r + 1) * (p + 1)) + CALL IJ2VEFC_Quadrangle_AntiClockwise( & + & xi=TRANSPOSE(zeta(:, jj, :)), & + & eta=TRANSPOSE(xi(:, jj, :)), & + & temp=temp2d, & + & p=r, & + & q=p, & + & startNode=startNode) + + IF ((r + 1) * (p + 1) .GE. 2 * (r + p) + 1) THEN + ii1 = cnt + 1 + ii2 = cnt + (r - 1) * (p - 1) + cnt = ii2 + temp(1, ii1:ii2) = temp2d(2, 2 * (r + p) + 1:) + temp(2, ii1:ii2) = eta(1, jj, 1) + temp(3, ii1:ii2) = temp2d(1, 2 * (r + p) + 1:) + END IF + + ! face 6 + ! z-x + ! clockwise + jj = 1 + startNode = 1 + CALL IJ2VEFC_Quadrangle_Clockwise( & + & xi=TRANSPOSE(zeta(:, jj, :)), & + & eta=TRANSPOSE(xi(:, jj, :)), & + & temp=temp2d, & + & p=r, & + & q=p, & + & startNode=startNode) + + IF ((r + 1) * (p + 1) .GE. 2 * (r + p) + 1) THEN + ii1 = cnt + 1 + ii2 = cnt + (r - 1) * (p - 1) + cnt = ii2 + temp(1, ii1:ii2) = temp2d(2, 2 * (r + p) + 1:) + temp(2, ii1:ii2) = eta(1, jj, 1) + temp(3, ii1:ii2) = temp2d(1, 2 * (r + p) + 1:) + END IF + + ! internal nodes + IF (ALL([p, q, r] .GE. 2_I4B)) THEN + + CALL Reallocate( & + & xi_in, & + & MAX(p - 1, 1_I4B), & + & MAX(q - 1_I4B, 1_I4B), & + & MAX(r - 1_I4B, 1_I4B)) + CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2), SIZE(xi_in, 3)) + CALL Reallocate(zeta_in, SIZE(xi_in, 1), SIZE(xi_in, 2), SIZE(xi_in, 3)) + CALL Reallocate(temp_in, 3, 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 + + IF (r .LE. 1_I4B) THEN + kk1 = 1 + kk2 = 1 + ELSE + kk1 = 2 + kk2 = r + END IF + + xi_in = xi(ii1:p, jj1:q, kk1:r) + eta_in = eta(ii1:p, jj1:q, kk1:r) + zeta_in = zeta(ii1:p, jj1:q, kk1:r) + + CALL IJK2VEFC_Hexahedron( & + & xi=xi_in, & + & eta=eta_in, & + & zeta=zeta_in, & + & temp=temp_in, & + & p=MAX(p - 2, 0_I4B), & + & q=MAX(q - 2, 0_I4B), & + & r=MAX(r - 2, 0_I4B)) + + ii1 = cnt + 1 + ii2 = ii1 + SIZE(temp_in, 2) - 1 + temp(1:3, ii1:ii2) = temp_in + END IF + +END IF + +END PROCEDURE IJK2VEFC_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info + +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) + +END PROCEDURE LagrangeCoeff_Hexahedron1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron2 +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Hexahedron2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Hexahedron3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron4 +INTEGER(I4B) :: basisType0, ii, jj, kk, indx +REAL(DFP) :: ans1(SIZE(xij, 2), 0:order) +REAL(DFP) :: ans2(SIZE(xij, 2), 0:order) +REAL(DFP) :: ans3(SIZE(xij, 2), 0:order) + +basisType0 = Input(default=Monomial, option=basisType) + +SELECT CASE (basisType0) +CASE (Monomial) + ans = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) + +CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) + + IF (basisType0 .EQ. Jacobi) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL Errormsg(& + & msg="alpha and beta should be present for basisType=Jacobi", & + & file=__FILE__, & + & routine="LagrangeCoeff_Hexahedron4", & + & line=__LINE__, & + & unitno=stderr) + STOP + END IF + END IF + + IF (basisType0 .EQ. Ultraspherical) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL Errormsg(& + & msg="lambda should be present for basisType=Ultraspherical", & + & file=__FILE__, & + & routine="LagrangeCoeff_Hexahedron4", & + & line=__LINE__, & + & unitno=stderr) + STOP + END IF + END IF + + ans1 = EvalAllOrthopol( & + & n=order, & + & x=xij(1, :), & + & orthopol=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + + ans2 = EvalAllOrthopol( & + & n=order, & + & x=xij(2, :), & + & orthopol=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + + ans3 = EvalAllOrthopol( & + & n=order, & + & x=xij(3, :), & + & orthopol=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + + indx = 0 + DO kk = 0, order + DO jj = 0, order + DO ii = 0, order + indx = indx + 1 + ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk) + END DO + END DO + END DO + +CASE DEFAULT + CALL Errormsg(& + & msg="No case found for basisType = "//tostring(basisType0), & + & file=__FILE__, & + & routine="LagrangeCoeff_Hexahedron4()", & + & line=__LINE__, & + & unitno=stderr) + STOP +END SELECT +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Hexahedron4 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron5 +INTEGER(I4B) :: basisType0, ii, jj, kk, indx, basisType(3) +REAL(DFP) :: ans1(SIZE(xij, 2), 0:p) +REAL(DFP) :: ans2(SIZE(xij, 2), 0:q) +REAL(DFP) :: ans3(SIZE(xij, 2), 0:r) + +basisType(1) = input(default=Monomial, option=basisType1) +basisType(2) = input(default=Monomial, option=basisType2) +basisType(3) = input(default=Monomial, option=basisType3) + +basisType0 = basisType(1) +SELECT CASE (basisType0) +CASE (Monomial) + ans1 = LagrangeVandermonde(order=p, xij=xij(1:1, :), elemType=Line) + +CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) + + ans1 = EvalAllOrthopol( & + & n=p, & + & x=xij(1, :), & + & orthopol=basisType0, & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +CASE DEFAULT + CALL Errormsg(& + & msg="No case found for basisType1", & + & file=__FILE__, & + & routine="LagrangeCoeff_Hexahedron5", & + & line=__LINE__, & + & unitno=stderr) +END SELECT + +basisType0 = basisType(2) +SELECT CASE (basisType0) +CASE (Monomial) + ans2 = LagrangeVandermonde(order=q, xij=xij(2:2, :), elemType=Line) + +CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) + + ans2 = EvalAllOrthopol( & + & n=q, & + & x=xij(2, :), & + & orthopol=basisType0, & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +CASE DEFAULT + CALL Errormsg(& + & msg="No case found for basisType2", & + & file=__FILE__, & + & routine="LagrangeCoeff_Hexahedron5", & + & line=__LINE__, & + & unitno=stderr) +END SELECT + +basisType0 = basisType(3) +SELECT CASE (basisType0) +CASE (Monomial) + ans3 = LagrangeVandermonde(order=r, xij=xij(3:3, :), elemType=Line) + +CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) + + ans3 = EvalAllOrthopol( & + & n=r, & + & x=xij(3, :), & + & orthopol=basisType0, & + & alpha=alpha3, & + & beta=beta3, & + & lambda=lambda3) + +CASE DEFAULT + CALL Errormsg(& + & msg="No case found for basisType3", & + & file=__FILE__, & + & routine="LagrangeCoeff_Hexahedron5", & + & line=__LINE__, & + & unitno=stderr) +END SELECT + +indx = 0 +DO kk = 0, r + DO jj = 0, q + DO ii = 0, p + indx = indx + 1 + ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk) + END DO + END DO +END DO + +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Hexahedron5 + +!---------------------------------------------------------------------------- +! TensorProdBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Hexahedron1 +REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), p + 1) +REAL(DFP) :: Q1(SIZE(xij, 2), q + 1) +REAL(DFP) :: R1(SIZE(xij, 2), r + 1) +INTEGER(I4B) :: ii, k1, k2, k3, cnt + +x = xij(1, :) +y = xij(2, :) +z = xij(3, :) + +P1 = BasisEvalAll_Line( & + & order=p, & + & x=x, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +Q1 = BasisEvalAll_Line( & + & order=q, & + & x=y, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +R1 = BasisEvalAll_Line( & + & order=r, & + & x=z, & + & refLine="BIUNIT", & + & basisType=basisType3, & + & alpha=alpha3, & + & beta=beta3, & + & lambda=lambda3) + +cnt = 0 + +DO k3 = 1, r + 1 + DO k2 = 1, q + 1 + DO k1 = 1, p + 1 + cnt = cnt + 1 + ans(:, cnt) = P1(:, k1) * Q1(:, k2) * R1(:, k3) + END DO + END DO +END DO + +END PROCEDURE TensorProdBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! TensorProdBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Hexahedron2 +REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z)) +INTEGER(I4B) :: ii, jj, cnt, kk + +xij = 0.0_DFP +cnt = 0 +DO ii = 1, SIZE(x) + DO jj = 1, SIZE(y) + DO kk = 1, SIZE(z) + cnt = cnt + 1 + xij(1, cnt) = x(ii) + xij(2, cnt) = y(jj) + xij(3, cnt) = z(kk) + END DO + END DO +END DO + +ans = TensorProdBasis_Hexahedron1( & + & p=p, & + & q=q, & + & r=r, & + & xij=xij, & + & basisType1=basisType1, & + & basisType2=basisType2, & + & basisType3=basisType3, & + & alpha1=alpha1, & + & alpha2=alpha2, & + & alpha3=alpha3, & + & beta1=beta1, & + & beta2=beta2, & + & beta3=beta3, & + & lambda1=lambda1, & + & lambda2=lambda2, & + & lambda3=lambda3) + +END PROCEDURE TensorProdBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! VertexBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Hexahedron1 +ans(:, 1) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP - y) * (1.0_DFP - z) +ans(:, 2) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP - y) * (1.0_DFP - z) +ans(:, 3) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP + y) * (1.0_DFP - z) +ans(:, 4) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP + y) * (1.0_DFP - z) +ans(:, 5) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP - y) * (1.0_DFP + z) +ans(:, 6) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP - y) * (1.0_DFP + z) +ans(:, 7) = 0.125_DFP * (1.0_DFP + x) * (1.0_DFP + y) * (1.0_DFP + z) +ans(:, 8) = 0.125_DFP * (1.0_DFP - x) * (1.0_DFP + y) * (1.0_DFP + z) +END PROCEDURE VertexBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! VertexBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Hexahedron2 +ans(:, 1) = L1(:, 0) * L2(:, 0) * L3(:, 0) +ans(:, 2) = L1(:, 1) * L2(:, 0) * L3(:, 0) +ans(:, 3) = L1(:, 1) * L2(:, 1) * L3(:, 0) +ans(:, 4) = L1(:, 0) * L2(:, 1) * L3(:, 0) +ans(:, 5) = L1(:, 0) * L2(:, 0) * L3(:, 1) +ans(:, 6) = L1(:, 1) * L2(:, 0) * L3(:, 1) +ans(:, 7) = L1(:, 1) * L2(:, 1) * L3(:, 1) +ans(:, 8) = L1(:, 0) * L2(:, 1) * L3(:, 1) +END PROCEDURE VertexBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! VertexBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Hexahedron3 +ans = VertexBasis_Hexahedron1( & + & x=xij(1, :), & + & y=xij(2, :), & + & z=xij(3, :) & + & ) +END PROCEDURE VertexBasis_Hexahedron3 + +!---------------------------------------------------------------------------- +! VertexBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasisGradient_Hexahedron2 +ans(:, 1, 1) = dL1(:, 0) * L2(:, 0) * L3(:, 0) +ans(:, 2, 1) = dL1(:, 1) * L2(:, 0) * L3(:, 0) +ans(:, 3, 1) = dL1(:, 1) * L2(:, 1) * L3(:, 0) +ans(:, 4, 1) = dL1(:, 0) * L2(:, 1) * L3(:, 0) +ans(:, 5, 1) = dL1(:, 0) * L2(:, 0) * L3(:, 1) +ans(:, 6, 1) = dL1(:, 1) * L2(:, 0) * L3(:, 1) +ans(:, 7, 1) = dL1(:, 1) * L2(:, 1) * L3(:, 1) +ans(:, 8, 1) = dL1(:, 0) * L2(:, 1) * L3(:, 1) + +ans(:, 1, 2) = L1(:, 0) * dL2(:, 0) * L3(:, 0) +ans(:, 2, 2) = L1(:, 1) * dL2(:, 0) * L3(:, 0) +ans(:, 3, 2) = L1(:, 1) * dL2(:, 1) * L3(:, 0) +ans(:, 4, 2) = L1(:, 0) * dL2(:, 1) * L3(:, 0) +ans(:, 5, 2) = L1(:, 0) * dL2(:, 0) * L3(:, 1) +ans(:, 6, 2) = L1(:, 1) * dL2(:, 0) * L3(:, 1) +ans(:, 7, 2) = L1(:, 1) * dL2(:, 1) * L3(:, 1) +ans(:, 8, 2) = L1(:, 0) * dL2(:, 1) * L3(:, 1) + +ans(:, 1, 3) = L1(:, 0) * L2(:, 0) * dL3(:, 0) +ans(:, 2, 3) = L1(:, 1) * L2(:, 0) * dL3(:, 0) +ans(:, 3, 3) = L1(:, 1) * L2(:, 1) * dL3(:, 0) +ans(:, 4, 3) = L1(:, 0) * L2(:, 1) * dL3(:, 0) +ans(:, 5, 3) = L1(:, 0) * L2(:, 0) * dL3(:, 1) +ans(:, 6, 3) = L1(:, 1) * L2(:, 0) * dL3(:, 1) +ans(:, 7, 3) = L1(:, 1) * L2(:, 1) * dL3(:, 1) +ans(:, 8, 3) = L1(:, 0) * L2(:, 1) * dL3(:, 1) +END PROCEDURE VertexBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! xEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xEdgeBasis_Hexahedron1 +REAL(DFP) :: L1(1:SIZE(x), 0:MAXVAL([pe1, pe2, pe3, pe4])) +INTEGER(I4B) :: maxP, k1, cnt + +maxP = SIZE(L1, 2) - 1_I4B +L1 = LobattoEvalAll(n=maxP, x=x) + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP - y) * (1.0_DFP - z) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP + y) * (1.0_DFP - z) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP - y) * (1.0_DFP + z) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L1(:, k1) * (1.0_DFP + y) * (1.0_DFP + z) +END DO + +END PROCEDURE xEdgeBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! xEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xEdgeBasis_Hexahedron2 +INTEGER(I4B) :: cnt, k1 + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 0) * L3(:, 0) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 1) * L3(:, 0) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 0) * L3(:, 1) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 1) * L3(:, 1) +END DO +END PROCEDURE xEdgeBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! xEdgeBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xEdgeBasisGradient_Hexahedron2 +INTEGER(I4B) :: cnt, k1 + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) * L3(:, 0) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) * L3(:, 0) + ans(:, cnt, 3) = L1(:, k1) * L2(:, 0) * dL3(:, 0) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) * L3(:, 0) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) * L3(:, 0) + ans(:, cnt, 3) = L1(:, k1) * L2(:, 1) * dL3(:, 0) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) * L3(:, 1) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) * L3(:, 1) + ans(:, cnt, 3) = L1(:, k1) * L2(:, 0) * dL3(:, 1) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) * L3(:, 1) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) * L3(:, 1) + ans(:, cnt, 3) = L1(:, k1) * L2(:, 1) * dL3(:, 1) +END DO +END PROCEDURE xEdgeBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! yEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE yEdgeBasis_Hexahedron1 +REAL(DFP) :: L2(1:SIZE(y), 0:MAXVAL([pe1, pe2, pe3, pe4])) +INTEGER(I4B) :: maxP, k1, cnt + +maxP = SIZE(L2, 2) - 1_I4B +L2 = LobattoEvalAll(n=maxP, x=y) + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP - x) * (1.0_DFP - z) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP + x) * (1.0_DFP - z) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP - x) * (1.0_DFP + z) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L2(:, k1) * (1.0_DFP + x) * (1.0_DFP + z) +END DO + +END PROCEDURE yEdgeBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! yEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE yEdgeBasis_Hexahedron2 +INTEGER(I4B) :: cnt, k1 + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L1(:, 0) * L3(:, 0) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L1(:, 1) * L3(:, 0) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L1(:, 0) * L3(:, 1) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L1(:, 1) * L3(:, 1) +END DO +END PROCEDURE yEdgeBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! yEdgeBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE yEdgeBasisGradient_Hexahedron2 +INTEGER(I4B) :: cnt, k1 + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 0) * L2(:, k1) * L3(:, 0) + ans(:, cnt, 2) = L1(:, 0) * dL2(:, k1) * L3(:, 0) + ans(:, cnt, 3) = L1(:, 0) * L2(:, k1) * dL3(:, 0) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 1) * L2(:, k1) * L3(:, 0) + ans(:, cnt, 2) = L1(:, 1) * dL2(:, k1) * L3(:, 0) + ans(:, cnt, 3) = L1(:, 1) * L2(:, k1) * dL3(:, 0) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 0) * L2(:, k1) * L3(:, 1) + ans(:, cnt, 2) = L1(:, 0) * dL2(:, k1) * L3(:, 1) + ans(:, cnt, 3) = L1(:, 0) * L2(:, k1) * dL3(:, 1) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 1) * L2(:, k1) * L3(:, 1) + ans(:, cnt, 2) = L1(:, 1) * dL2(:, k1) * L3(:, 1) + ans(:, cnt, 3) = L1(:, 1) * L2(:, k1) * dL3(:, 1) +END DO +END PROCEDURE yEdgeBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! zEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE zEdgeBasis_Hexahedron1 +REAL(DFP) :: L3(1:SIZE(y), 0:MAXVAL([pe1, pe2, pe3, pe4])) +INTEGER(I4B) :: maxP, k1, cnt + +maxP = SIZE(L3, 2) - 1_I4B +L3 = LobattoEvalAll(n=maxP, x=z) + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP - x) * (1.0_DFP - y) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP + x) * (1.0_DFP - y) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP - x) * (1.0_DFP + y) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * L3(:, k1) * (1.0_DFP + x) * (1.0_DFP + y) +END DO +END PROCEDURE zEdgeBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! zEdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE zEdgeBasis_Hexahedron2 +INTEGER(I4B) :: cnt, k1 + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt) = L3(:, k1) * L1(:, 0) * L2(:, 0) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt) = L3(:, k1) * L1(:, 1) * L2(:, 0) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = L3(:, k1) * L1(:, 0) * L2(:, 1) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = L3(:, k1) * L1(:, 1) * L2(:, 1) +END DO +END PROCEDURE zEdgeBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! zEdgeBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE zEdgeBasisGradient_Hexahedron2 +INTEGER(I4B) :: cnt, k1 + +cnt = 0 +DO k1 = 2, pe1 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 0) * L2(:, 0) * L3(:, k1) + ans(:, cnt, 2) = L1(:, 0) * dL2(:, 0) * L3(:, k1) + ans(:, cnt, 3) = L1(:, 0) * L2(:, 0) * dL3(:, k1) +END DO + +DO k1 = 2, pe2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 1) * L2(:, 0) * L3(:, k1) + ans(:, cnt, 2) = L1(:, 1) * dL2(:, 0) * L3(:, k1) + ans(:, cnt, 3) = L1(:, 1) * L2(:, 0) * dL3(:, k1) +END DO + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 0) * L2(:, 1) * L3(:, k1) + ans(:, cnt, 2) = L1(:, 0) * dL2(:, 1) * L3(:, k1) + ans(:, cnt, 3) = L1(:, 0) * L2(:, 1) * dL3(:, k1) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 1) * L2(:, 1) * L3(:, k1) + ans(:, cnt, 2) = L1(:, 1) * dL2(:, 1) * L3(:, k1) + ans(:, cnt, 3) = L1(:, 1) * L2(:, 1) * dL3(:, k1) +END DO +END PROCEDURE zEdgeBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! EdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasis_Hexahedron1 +SELECT CASE (dim) +CASE (1_I4B) + ans = xEdgeBasis_Hexahedron1(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + & x=x, y=y, z=z) +CASE (2_I4B) + ans = yEdgeBasis_Hexahedron1(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + & x=x, y=y, z=z) +CASE (3_I4B) + ans = zEdgeBasis_Hexahedron1(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + & x=x, y=y, z=z) +END SELECT +END PROCEDURE EdgeBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! EdgeBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasis_Hexahedron2 +SELECT CASE (dim) +CASE (1_I4B) + ans = xEdgeBasis_Hexahedron2(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + & L1=L1, L2=L2, L3=L3) +CASE (2_I4B) + ans = yEdgeBasis_Hexahedron2(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + & L1=L1, L2=L2, L3=L3) +CASE (3_I4B) + ans = zEdgeBasis_Hexahedron2(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + & L1=L1, L2=L2, L3=L3) +END SELECT +END PROCEDURE EdgeBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! EdgeBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasisGradient_Hexahedron2 +SELECT CASE (dim) +CASE (1_I4B) + ans = xEdgeBasisGradient_Hexahedron2( & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +CASE (2_I4B) + ans = yEdgeBasisGradient_Hexahedron2( & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +CASE (3_I4B) + ans = zEdgeBasisGradient_Hexahedron2( & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END SELECT +END PROCEDURE EdgeBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! xyFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xyFacetBasis_Hexahedron1 +REAL(DFP) :: L1(1:SIZE(x), 0:n1) +REAL(DFP) :: L2(1:SIZE(y), 0:n2) +INTEGER(I4B) :: k1, cnt, k2 + +L1 = LobattoEvalAll(n=n1, x=x) +L2 = LobattoEvalAll(n=n2, x=y) + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) * 0.5_DFP * (1.0_DFP - z) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) * 0.5_DFP * (1.0_DFP + z) + END DO +END DO +END PROCEDURE xyFacetBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! xyFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xyFacetBasis_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2 + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, 0) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, 1) + END DO +END DO +END PROCEDURE xyFacetBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! xyFacetBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xyFacetBasisGradient_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2 + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) * L3(:, 0) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) * L3(:, 0) + ans(:, cnt, 3) = L1(:, k1) * L2(:, k2) * dL3(:, 0) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) * L3(:, 1) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) * L3(:, 1) + ans(:, cnt, 3) = L1(:, k1) * L2(:, k2) * dL3(:, 1) + END DO +END DO +END PROCEDURE xyFacetBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! yzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE yzFacetBasis_Hexahedron1 +REAL(DFP) :: L2(1:SIZE(y), 0:n1) +REAL(DFP) :: L3(1:SIZE(z), 0:n2) +INTEGER(I4B) :: k1, cnt, k2 + +L2 = LobattoEvalAll(n=n1, x=y) +L3 = LobattoEvalAll(n=n2, x=z) + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP - x) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP + x) + END DO +END DO +END PROCEDURE yzFacetBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! yzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE yzFacetBasis_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2 + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L3(:, k2) * L1(:, 0) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L2(:, k1) * L3(:, k2) * L1(:, 1) + END DO +END DO +END PROCEDURE yzFacetBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! yzFacetBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE yzFacetBasisGradient_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2 + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 0) * L2(:, k1) * L3(:, k2) + ans(:, cnt, 2) = L1(:, 0) * dL2(:, k1) * L3(:, k2) + ans(:, cnt, 3) = L1(:, 0) * L2(:, k1) * dL3(:, k2) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 1) * L2(:, k1) * L3(:, k2) + ans(:, cnt, 2) = L1(:, 1) * dL2(:, k1) * L3(:, k2) + ans(:, cnt, 3) = L1(:, 1) * L2(:, k1) * dL3(:, k2) + END DO +END DO +END PROCEDURE yzFacetBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! xzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xzFacetBasis_Hexahedron1 +REAL(DFP) :: L1(1:SIZE(x), 0:n1) +REAL(DFP) :: L3(1:SIZE(z), 0:n2) +INTEGER(I4B) :: k1, cnt, k2 + +L1 = LobattoEvalAll(n=n1, x=x) +L3 = LobattoEvalAll(n=n2, x=z) + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP - y) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L3(:, k2) * 0.5_DFP * (1.0_DFP + y) + END DO +END DO +END PROCEDURE xzFacetBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! xzFacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xzFacetBasis_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2 + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L3(:, k2) * L2(:, 0) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L3(:, k2) * L2(:, 1) + END DO +END DO +END PROCEDURE xzFacetBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! xzFacetBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE xzFacetBasisGradient_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2 + +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) * L3(:, k2) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) * L3(:, k2) + ans(:, cnt, 3) = L1(:, k1) * L2(:, 0) * dL3(:, k2) + END DO +END DO + +DO k1 = 2, n1 + DO k2 = 2, n2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) * L3(:, k2) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) * L3(:, k2) + ans(:, cnt, 3) = L1(:, k1) * L2(:, 1) * dL3(:, k2) + END DO +END DO +END PROCEDURE xzFacetBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! FacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetBasis_Hexahedron1 + +SELECT CASE (dim1) +CASE (1_I4B) + SELECT CASE (dim2) + CASE (2_I4B) + ans = xyFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) + CASE (3_I4B) + ans = xzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) + END SELECT +CASE (2_I4B) + SELECT CASE (dim2) + CASE (1_I4B) + ans = xyFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) + CASE (3_I4B) + ans = yzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) + END SELECT +CASE (3_I4B) + SELECT CASE (dim2) + CASE (1_I4B) + ans = xzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) + CASE (2_I4B) + ans = yzFacetBasis_Hexahedron1(n1=n1, n2=n2, x=x, y=y, z=z) + END SELECT +END SELECT + +END PROCEDURE FacetBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! FacetBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetBasis_Hexahedron2 + +SELECT CASE (dim1) +CASE (1_I4B) + SELECT CASE (dim2) + CASE (2_I4B) + ans = xyFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) + CASE (3_I4B) + ans = xzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) + END SELECT +CASE (2_I4B) + SELECT CASE (dim2) + CASE (1_I4B) + ans = xyFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) + CASE (3_I4B) + ans = yzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) + END SELECT +CASE (3_I4B) + SELECT CASE (dim2) + CASE (1_I4B) + ans = xzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) + CASE (2_I4B) + ans = yzFacetBasis_Hexahedron2(n1=n1, n2=n2, L1=L1, L2=L2, L3=L3) + END SELECT +END SELECT +END PROCEDURE FacetBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! FacetBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetBasisGradient_Hexahedron2 + +SELECT CASE (dim1) +CASE (1_I4B) + SELECT CASE (dim2) + CASE (2_I4B) + ans = xyFacetBasisGradient_Hexahedron2( & + & n1=n1, & + & n2=n2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) + CASE (3_I4B) + ans = xzFacetBasisGradient_Hexahedron2( & + & n1=n1, & + & n2=n2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) + END SELECT +CASE (2_I4B) + SELECT CASE (dim2) + CASE (1_I4B) + ans = xyFacetBasisGradient_Hexahedron2( & + & n1=n1, & + & n2=n2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) + CASE (3_I4B) + ans = yzFacetBasisGradient_Hexahedron2( & + & n1=n1, & + & n2=n2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) + END SELECT +CASE (3_I4B) + SELECT CASE (dim2) + CASE (1_I4B) + ans = xzFacetBasisGradient_Hexahedron2( & + & n1=n1, & + & n2=n2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) + CASE (2_I4B) + ans = yzFacetBasisGradient_Hexahedron2( & + & n1=n1, & + & n2=n2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) + END SELECT +END SELECT +END PROCEDURE FacetBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! CellBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Hexahedron1 +REAL(DFP) :: L1(1:SIZE(x), 0:n1) +REAL(DFP) :: L2(1:SIZE(y), 0:n2) +REAL(DFP) :: L3(1:SIZE(z), 0:n3) +INTEGER(I4B) :: k1, cnt, k2, k3 +L1 = LobattoEvalAll(n=n1, x=x) +L2 = LobattoEvalAll(n=n2, x=y) +L3 = LobattoEvalAll(n=n3, x=z) +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + DO k3 = 2, n3 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, k3) + END DO + END DO +END DO +END PROCEDURE CellBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! CellBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2, k3 +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + DO k3 = 2, n3 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) * L3(:, k3) + END DO + END DO +END DO +END PROCEDURE CellBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! CellBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasisGradient_Hexahedron2 +INTEGER(I4B) :: k1, cnt, k2, k3 +cnt = 0 +DO k1 = 2, n1 + DO k2 = 2, n2 + DO k3 = 2, n3 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) * L3(:, k3) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) * L3(:, k3) + ans(:, cnt, 3) = L1(:, k1) * L2(:, k2) * dL3(:, k3) + END DO + END DO +END DO +END PROCEDURE CellBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Hexahedron1 + +#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1]) +#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1]) +#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2]) + +INTEGER(I4B) :: a, b, maxP, maxQ, maxR +REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_) +REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_) +REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_) + +#undef _maxP_ +#undef _maxQ_ +#undef _maxR_ + +maxP = SIZE(L1, 2) - 1 +maxQ = SIZE(L2, 2) - 1 +maxR = SIZE(L3, 2) - 1 + +L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) +L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) +L3 = LobattoEvalAll(n=maxR, x=xij(3, :)) + +! Vertex basis function + +ans(:, 1:8) = VertexBasis_Hexahedron2(L1=L1, L2=L2, L3=L3) + +! Edge basis function + +b = 8 + +IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + px1 + px2 + px3 + px4 - 4 + ans(:, a:b) = xEdgeBasis_Hexahedron2( & + & pe1=px1, pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3) +END IF + +IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + py1 + py2 + py3 + py4 - 4 + ans(:, a:b) = yEdgeBasis_Hexahedron2( & + & pe1=py1, pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3) +END IF + +IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4 + ans(:, a:b) = zEdgeBasis_Hexahedron2( & + & pe1=pz1, pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3) +END IF + +! Facet basis function + +IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1) + ans(:, a:b) = xyFacetBasis_Hexahedron2( & + & n1=pxy1, n2=pxy2, L1=L1, L2=L2, L3=L3) +END IF + +IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1) + ans(:, a:b) = xzFacetBasis_Hexahedron2( & + & n1=pxz1, n2=pxz2, L1=L1, L2=L2, L3=L3) +END IF + +IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1) + ans(:, a:b) = yzFacetBasis_Hexahedron2( & + & n1=pyz1, n2=pyz2, L1=L1, L2=L2, L3=L3) +END IF + +IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1) + ans(:, a:b) = cellBasis_Hexahedron2( & + & n1=pb1, n2=pb2, n3=pb3, L1=L1, L2=L2, L3=L3) +END IF +END PROCEDURE HeirarchicalBasis_Hexahedron1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Hexahedron2 +ans = HeirarchicalBasis_Hexahedron1(& + & pb1=p, pb2=q, pb3=r, & + & pxy1=p, pxy2=q, & + & pxz1=p, pxz2=r, & + & pyz1=q, pyz2=r, & + & px1=p, px2=p, px3=p, px4=p, & + & py1=q, py2=q, py3=q, py4=q, & + & pz1=r, pz2=r, pz3=r, pz4=r, & + & xij=xij) +END PROCEDURE HeirarchicalBasis_Hexahedron2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Hexahedron1 +ans = QuadraturePoint_Hexahedron2( & + & p=order, & + & q=order, & + & r=order, & + & quadType1=quadType, & + & quadType2=quadType, & + & quadType3=quadType, & + & refHexahedron=refHexahedron, & + & xij=xij, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda, & + & alpha3=alpha, & + & beta3=beta, & + & lambda3=lambda & + & ) +END PROCEDURE QuadraturePoint_Hexahedron1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Hexahedron2 +! internal variables +REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), z(:, :), temp(:, :) +INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt +TYPE(String) :: astr + +astr = UpperCase(refHexahedron) + +x = QuadraturePoint_Line( & + & order=p, & + & quadType=quadType1, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) +np = SIZE(x, 2) + +y = QuadraturePoint_Line( & + & order=q, & + & quadType=quadType2, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) +nq = SIZE(y, 2) + +z = QuadraturePoint_Line( & + & order=r, & + & quadType=quadType2, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha3, & + & beta=beta3, & + & lambda=lambda3) +nr = SIZE(z, 2) + +nsd = 3 +CALL Reallocate(ans, 4_I4B, np * nq * nr) +CALL Reallocate(temp, 4_I4B, np * nq * nr) + +cnt = 0 +DO ii = 1, np + DO jj = 1, nq + DO kk = 1, nr + cnt = cnt + 1 + temp(1, cnt) = x(1, ii) + temp(2, cnt) = y(1, jj) + temp(3, cnt) = z(1, kk) + temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk) + END DO + END DO +END DO + +IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( & + & xin=temp(1:3, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4), & + & x5=xij(:, 5), & + & x6=xij(:, 6), & + & x7=xij(:, 7), & + & x8=xij(:, 8) & + & ) + ans(4, :) = temp(4, :) * JacobianHexahedron( & + & from="BIUNIT", to="HEXAHEDRON", xij=xij) + +ELSE + IF (astr%chars() .EQ. "UNIT") THEN + ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( & + & xin=temp(1:3, :)) + ans(4, :) = temp(4, :) * JacobianHexahedron( & + & from="BIUNIT", to="UNIT", xij=xij) + ELSE + ans = temp + END IF +END IF + +IF (ALLOCATED(temp)) DEALLOCATE (temp) +IF (ALLOCATED(x)) DEALLOCATE (x) +IF (ALLOCATED(y)) DEALLOCATE (y) +IF (ALLOCATED(z)) DEALLOCATE (z) + +END PROCEDURE QuadraturePoint_Hexahedron2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Hexahedron3 +ans = QuadraturePoint_Hexahedron4( & + & nipsx=nips, & + & nipsy=nips, & + & nipsz=nips, & + & quadType1=quadType, & + & quadType2=quadType, & + & quadType3=quadType, & + & refHexahedron=refHexahedron, & + & xij=xij, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda, & + & alpha3=alpha, & + & beta3=beta, & + & lambda3=lambda & + & ) +END PROCEDURE QuadraturePoint_Hexahedron3 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Hexahedron4 +! internal variables +REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), z(2, nipsz(1)), & +& temp(4, nipsy(1) * nipsx(1) * nipsz(1)) +INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt +TYPE(String) :: astr + +astr = UpperCase(refHexahedron) + +x = QuadraturePoint_Line( & + & nips=nipsx, & + & quadType=quadType1, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) +np = SIZE(x, 2) + +y = QuadraturePoint_Line( & + & nips=nipsy, & + & quadType=quadType2, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) +nq = SIZE(y, 2) + +z = QuadraturePoint_Line( & + & nips=nipsz, & + & quadType=quadType3, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha3, & + & beta=beta3, & + & lambda=lambda3) +nr = SIZE(z, 2) + +nsd = 3 +CALL Reallocate(ans, 4_I4B, np * nq * nr) + +cnt = 0 +DO ii = 1, np + DO jj = 1, nq + DO kk = 1, nr + cnt = cnt + 1 + temp(1, cnt) = x(1, ii) + temp(2, cnt) = y(1, jj) + temp(3, cnt) = z(1, kk) + temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk) + END DO + END DO +END DO + +IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( & + & xin=temp(1:3, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4), & + & x5=xij(:, 5), & + & x6=xij(:, 6), & + & x7=xij(:, 7), & + & x8=xij(:, 8) & + & ) + ans(4, :) = temp(4, :) * JacobianHexahedron( & + & from="BIUNIT", to="HEXAHEDRON", xij=xij) + +ELSE + IF (astr%chars() .EQ. "UNIT") THEN + ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( & + & xin=temp(1:3, :)) + ans(4, :) = temp(4, :) * JacobianHexahedron( & + & from="BIUNIT", to="UNIT", xij=xij) + ELSE + ans = temp + END IF +END IF + +END PROCEDURE QuadraturePoint_Hexahedron4 + +!---------------------------------------------------------------------------- +! LagrangeEvallAll_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Hexahedron1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: degree(SIZE(xij, 2), 3) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Hexahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) + coeff0 = TRANSPOSE(coeff) + ELSE + coeff0 = TRANSPOSE(coeff) + END IF +ELSE + coeff0 = TRANSPOSE( & + & LagrangeCoeff_Hexahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & )) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Hexahedron(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Hexahedron1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + + DO ii = 1, tdof + xx(1, ii) = x(1)**degree(ii, 1) & + & * x(2)**degree(ii, 2) & + & * x(3)**degree(ii, 3) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasis_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=RESHAPE(x, [3, 1])) + +CASE DEFAULT + + xx = TensorProdBasis_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=RESHAPE(x, [3, 1]), & + & basisType1=basisType0, & + & basisType2=basisType0, & + & basisType3=basisType0, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda, & + & alpha3=alpha, & + & beta3=beta, & + & lambda3=lambda & + & ) + +END SELECT + +ans = MATMUL(coeff0, xx(1, :)) + +END PROCEDURE LagrangeEvalAll_Hexahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Hexahedron2 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: degree(SIZE(xij, 2), 3) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) +REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Hexahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) + coeff0 = coeff + ELSE + coeff0 = coeff + END IF +ELSE + coeff0 = LagrangeCoeff_Hexahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Hexahedron(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Hexahedron1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + + DO ii = 1, tdof + xx(:, ii) = x(1, :)**degree(ii, 1) & + & * x(2, :)**degree(ii, 2) & + & * x(3, :)**degree(ii, 3) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasis_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=x) + +CASE DEFAULT + + xx = TensorProdBasis_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=x, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & basisType3=basisType0, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda, & + & alpha3=alpha, & + & beta3=beta, & + & lambda3=lambda) + +END SELECT + +ans = MATMUL(xx, coeff0) + +END PROCEDURE LagrangeEvalAll_Hexahedron2 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Hexahedron1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci +INTEGER(I4B) :: degree(SIZE(xij, 2), 3), d1, d2, d3 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & + & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Hexahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) + END IF + coeff0 = coeff +ELSE + coeff0 = LagrangeCoeff_Hexahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + degree = LagrangeDegree_Hexahedron(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Hexahedron1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + + DO ii = 1, tdof + d1 = degree(ii, 1) + d2 = degree(ii, 2) + d3 = degree(ii, 3) + + ai = MAX(d1 - 1_I4B, 0_I4B) + bi = MAX(d2 - 1_I4B, 0_I4B) + ci = MAX(d3 - 1_I4B, 0_I4B) + + ar = REAL(d1, DFP) + br = REAL(d2, DFP) + cr = REAL(d3, DFP) + + xx(:, ii, 1) = (ar * x(1, :)**ai) * & + & x(2, :)**d2 * & + & x(3, :)**d3 + + xx(:, ii, 2) = x(1, :)**d1 * & + & (br * x(2, :)**bi) * & + & x(3, :)**d3 + + xx(:, ii, 3) = x(1, :)**d1 * & + & x(2, :)**d2 * & + & (cr * x(3, :)**ci) + + END DO + +CASE (Heirarchical) + xx = HeirarchicalBasisGradient_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=x) + +CASE DEFAULT + xx = OrthogonalBasisGradient_Hexahedron( & + & p=order, & + & q=order, & + & r=order, & + & xij=x, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & basisType3=basisType0, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda, & + & alpha3=alpha, & + & beta3=beta, & + & lambda3=lambda) + +END SELECT + +DO ii = 1, 3 + ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) + ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) +END DO + +END PROCEDURE LagrangeGradientEvalAll_Hexahedron1 + +!---------------------------------------------------------------------------- +! TensorProdBasisGradient_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1 +REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), p + 1) +REAL(DFP) :: Q1(SIZE(xij, 2), q + 1) +REAL(DFP) :: R1(SIZE(xij, 2), r + 1) +REAL(DFP) :: dP1(SIZE(xij, 2), p + 1) +REAL(DFP) :: dQ1(SIZE(xij, 2), q + 1) +REAL(DFP) :: dR1(SIZE(xij, 2), r + 1) + +INTEGER(I4B) :: ii, k1, k2, k3, cnt + +x = xij(1, :) +y = xij(2, :) +z = xij(3, :) + +P1 = BasisEvalAll_Line( & + & order=p, & + & x=x, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +Q1 = BasisEvalAll_Line( & + & order=q, & + & x=y, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +R1 = BasisEvalAll_Line( & + & order=r, & + & x=z, & + & refLine="BIUNIT", & + & basisType=basisType3, & + & alpha=alpha3, & + & beta=beta3, & + & lambda=lambda3) + +dP1 = BasisGradientEvalAll_Line( & + & order=p, & + & x=x, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +dQ1 = BasisGradientEvalAll_Line( & + & order=q, & + & x=y, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +dR1 = BasisGradientEvalAll_Line( & + & order=r, & + & x=z, & + & refLine="BIUNIT", & + & basisType=basisType3, & + & alpha=alpha3, & + & beta=beta3, & + & lambda=lambda3) + +cnt = 0 + +DO k3 = 1, r + 1 + DO k2 = 1, q + 1 + DO k1 = 1, p + 1 + cnt = cnt + 1 + ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2) * R1(:, k3) + ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2) * R1(:, k3) + ans(:, cnt, 3) = P1(:, k1) * Q1(:, k2) * dR1(:, k3) + END DO + END DO +END DO +END PROCEDURE TensorProdBasisGradient_Hexahedron1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Hexahedron1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron1 +#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1]) +#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1]) +#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2]) + +INTEGER(I4B) :: a, b, maxP, maxQ, maxR +REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_) +REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_) +REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_) +REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:_maxP_) +REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:_maxQ_) +REAL(DFP) :: dL3(1:SIZE(xij, 2), 0:_maxR_) + +#undef _maxP_ +#undef _maxQ_ +#undef _maxR_ + +maxP = SIZE(L1, 2) - 1 +maxQ = SIZE(L2, 2) - 1 +maxR = SIZE(L3, 2) - 1 + +L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) +L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) +L3 = LobattoEvalAll(n=maxR, x=xij(3, :)) + +dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :)) +dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :)) +dL3 = LobattoGradientEvalAll(n=maxR, x=xij(3, :)) + +! Vertex basis function +ans(:, 1:8, :) = VertexBasisGradient_Hexahedron2( & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) + +! Edge basis function +b = 8 + +IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + px1 + px2 + px3 + px4 - 4 + ans(:, a:b, :) = xEdgeBasisGradient_Hexahedron2( & + & pe1=px1, & + & pe2=px2, & + & pe3=px3, & + & pe4=px4, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END IF + +IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + py1 + py2 + py3 + py4 - 4 + ans(:, a:b, :) = yEdgeBasisGradient_Hexahedron2( & + & pe1=py1, & + & pe2=py2, & + & pe3=py3, & + & pe4=py4, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END IF + +IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4 + ans(:, a:b, :) = zEdgeBasisGradient_Hexahedron2( & + & pe1=pz1, & + & pe2=pz2, & + & pe3=pz3, & + & pe4=pz4, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END IF + +! Facet basis function + +IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1) + ans(:, a:b, :) = xyFacetBasisGradient_Hexahedron2( & + & n1=pxy1, & + & n2=pxy2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END IF + +IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1) + ans(:, a:b, :) = xzFacetBasisGradient_Hexahedron2( & + & n1=pxz1, & + & n2=pxz2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END IF + +IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1) + ans(:, a:b, :) = yzFacetBasisGradient_Hexahedron2( & + & n1=pyz1, & + & n2=pyz2, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END IF + +IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1) + ans(:, a:b, :) = cellBasisGradient_Hexahedron2( & + & n1=pb1, & + & n2=pb2, & + & n3=pb3, & + & L1=L1, & + & L2=L2, & + & L3=L3, & + & dL1=dL1, & + & dL2=dL2, & + & dL3=dL3 & + & ) +END IF +END PROCEDURE HeirarchicalBasisGradient_Hexahedron1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Hexahedron2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron2 +ans = HeirarchicalBasisGradient_Hexahedron1(& + & pb1=p, pb2=q, pb3=r, & + & pxy1=p, pxy2=q, & + & pxz1=p, pxz2=r, & + & pyz1=q, pyz2=r, & + & px1=p, px2=p, px3=p, px4=p, & + & py1=q, py2=q, py3=q, py4=q, & + & pz1=r, pz2=r, pz3=r, pz4=r, & + & xij=xij) +END PROCEDURE HeirarchicalBasisGradient_Hexahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 new file mode 100644 index 000000000..93e179fd5 --- /dev/null +++ b/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 @@ -0,0 +1,149 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(InterpolationUtility) Methods +USE GlobalData, ONLY: Point, Line, Triangle, Quadrangle, & + Tetrahedron, Hexahedron, Prism, Pyramid + +USE ReferenceElement_Method, ONLY: ElementTopology +USE LineInterpolationUtility, ONLY: GetTotalDOF_Line, & + GetTotalInDOF_Line +USE TriangleInterpolationUtility, ONLY: GetTotalDOF_Triangle, & + GetTotalInDOF_Triangle +USE QuadrangleInterpolationUtility, ONLY: GetTotalDOF_Quadrangle, & + GetTotalInDOF_Quadrangle +USE TetrahedronInterpolationUtility, ONLY: GetTotalDOF_Tetrahedron, & + GetTotalInDOF_Tetrahedron +USE HexahedronInterpolationUtility, ONLY: GetTotalDOF_Hexahedron, & + GetTotalInDOF_Hexahedron +USE PrismInterpolationUtility, ONLY: GetTotalDOF_Prism, & + GetTotalInDOF_Prism +USE PyramidInterpolationUtility, ONLY: GetTotalDOF_Pyramid, & + GetTotalInDOF_Pyramid + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! VandermondeMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VandermondeMatrix_Real32 +INTEGER(I4B) :: ii +ans(:, 1) = 1.0_REAL32 +DO ii = 2, order + 1 + ans(:, ii) = x**(ii - 1) +END DO +END PROCEDURE VandermondeMatrix_Real32 + +!---------------------------------------------------------------------------- +! VandermondeMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VandermondeMatrix_Real64 +INTEGER(I4B) :: ii +ans(:, 1) = 1.0_REAL64 +DO ii = 2, order + 1 + ans(:, ii) = x**(ii - 1) +END DO +END PROCEDURE VandermondeMatrix_Real64 + +!---------------------------------------------------------------------------- +! VandermondeMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF1 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = 0 +CASE (Line) + ans = GetTotalDOF_Line(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Triangle) + ans = GetTotalDOF_Triangle(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Quadrangle) + ans = GetTotalDOF_Quadrangle(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Tetrahedron) + ans = GetTotalDOF_Tetrahedron(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) +CASE (Hexahedron) + ans = GetTotalDOF_Hexahedron(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Prism) + ans = GetTotalDOF_Prism(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Pyramid) + ans = GetTotalDOF_Pyramid(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) +END SELECT + +END PROCEDURE GetTotalDOF1 + +!---------------------------------------------------------------------------- +! VandermondeMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF1 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = 0 +CASE (Line) + ans = GetTotalInDOF_Line(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Triangle) + ans = GetTotalInDOF_Triangle(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Quadrangle) + ans = GetTotalInDOF_Quadrangle(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Tetrahedron) + ans = GetTotalInDOF_Tetrahedron(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) +CASE (Hexahedron) + ans = GetTotalInDOF_Hexahedron(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Prism) + ans = GetTotalInDOF_Prism(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) + +CASE (Pyramid) + ans = GetTotalInDOF_Pyramid(order=order, baseContinuity=baseContinuity, & + baseInterpolation=baseInterpolation) +END SELECT + +END PROCEDURE GetTotalInDOF1 + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..676683b43 --- /dev/null +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -0,0 +1,1415 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(JacobiPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! JacobiAlpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiAlpha +IF (n .EQ. 0) THEN + ans = (beta - alpha) / (alpha + beta + 2.0_DFP) +ELSE + ans = (beta**2 - alpha**2) / (alpha + beta + 2.0_DFP * n) & + & / (alpha + beta + 2.0_DFP + 2.0_DFP * n) +END IF +END PROCEDURE JacobiAlpha + +!---------------------------------------------------------------------------- +! JacobiBeta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiBeta +IF (n .EQ. 0) THEN + ans = 2.0_DFP**(alpha + beta + 1.0_DFP) * GAMMA(alpha + 1.0_DFP) & + & * GAMMA(beta + 1.0_DFP) & + & / GAMMA(alpha + beta + 2.0_DFP) +ELSEIF (n .EQ. 1) THEN + ans = 4.0_DFP * (1.0_DFP + alpha) * (1.0_DFP + beta) / & + & (alpha + beta + 2.0_DFP)**2 / (alpha + beta + 3.0_DFP) +ELSE + ans = 4.0_DFP * n * (n + alpha) * (n + beta) * (n + alpha + beta) & + & / (alpha + beta + 2.0_DFP * n)**2 / (alpha + beta + 1.0_DFP + 2.0 * n) & + & / (alpha + beta - 1.0_DFP + 2.0 * n) +END IF +END PROCEDURE JacobiBeta + +!---------------------------------------------------------------------------- +! GetJacobiRecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetJacobiRecurrenceCoeff +REAL(DFP), PARAMETER :: two = 2.0_DFP, four = 4.0_DFP +REAL(DFP) :: ab1, ab, ab2, abm1, bma, ab3, b2ma2, ab4 +INTEGER(I4B) :: ii + !! +IF (n .LE. 0) RETURN + !! +ab = alpha + beta +ab1 = ab + 1.0_DFP +abm1 = ab - 1.0_DFP +bma = beta - alpha +ab2 = ab1 + 1.0_DFP +ab3 = ab2 + 1.0_DFP +ab4 = ab3 + 1.0_DFP +b2ma2 = beta * beta - alpha * alpha + !! + !! beta 0 + !! +betaCoeff(0) = two**(ab1) * GAMMA(alpha + 1.0_DFP) & + & * GAMMA(beta + 1.0_DFP) & + & / GAMMA(ab1 + 1.0_DFP) + !! + !! alpha 0 + !! +alphaCoeff(0) = bma / ab2 + !! + !! RETURN IF n = 1 + !! +IF (n .EQ. 1) RETURN + !! +betaCoeff(1) = four * (1.0_DFP + alpha) * (1.0_DFP + beta) / (ab2 * ab2 * ab3) +alphaCoeff(1) = b2ma2 / (ab2 * ab4) + !! + !! Now it safe to compute other coefficients + !! +DO ii = 2, n - 1 + !! + betaCoeff(ii) = four * ii * (ii + alpha) * (ii + beta) * (ii + ab) & + & / (ab + 2.0 * ii)**2 / (ab1 + 2.0 * ii) / (abm1 + 2.0 * ii) + !! + alphaCoeff(ii) = b2ma2 / (ab + 2.0 * ii) / (ab2 + 2.0 * ii) + !! +END DO + !! +END PROCEDURE GetJacobiRecurrenceCoeff + +!---------------------------------------------------------------------------- +! GetJacobiRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetJacobiRecurrenceCoeff2 +REAL(DFP) :: j +INTEGER(I4B) :: ii +!! +IF (n .LT. 1) RETURN +A(0) = 0.5_DFP * (alpha + beta + 2.0_DFP) +B(0) = -A(0) * JacobiAlpha(n=0_I4B, alpha=alpha, beta=beta) +j = JacobiBeta(n=0_I4B, alpha=alpha, beta=beta) +C(0) = SQRT(j) * A(0) +!! +IF (n .EQ. 1) RETURN +!! +DO ii = 2, n + j = REAL(ii, KIND=DFP) + A(ii-1) = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + B(ii - 1) = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + C(ii - 1) = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); +END DO +!! +END PROCEDURE GetJacobiRecurrenceCoeff2 + +!---------------------------------------------------------------------------- +! JacobiLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiLeadingCoeff +ans = GAMMA(2.0_DFP * n + alpha + beta + 1.0_DFP) / GAMMA(n + 1.0_DFP) / & + & GAMMA(n + alpha + beta + 1.0_DFP) / 2.0_DFP**n +END PROCEDURE JacobiLeadingCoeff + +!---------------------------------------------------------------------------- +! JacobiLeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiLeadingCoeffRatio +REAL(DFP) :: a1, a2, rn +IF (n .EQ. 0) THEN + ans = 0.5_DFP * (alpha + beta + 2.0_DFP) +ELSE + rn = REAL(n, KIND=DFP) + a1 = 2.0_DFP * rn + alpha + beta + 1.0_DFP + ans = 0.5_DFP * a1 * (a1 + 1.0_DFP) / (rn + 1.0_DFP) / (a1 - rn) +END IF +END PROCEDURE JacobiLeadingCoeffRatio + +!---------------------------------------------------------------------------- +! JacobiNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiNormSqr +REAL(DFP) :: a1, a2, a3, b1, b2, b3 +a1 = 2.0**(alpha + beta + 1.0_DFP) +a2 = GAMMA(n + alpha + 1.0_DFP) +a3 = GAMMA(n + beta + 1.0_DFP) +b1 = 2.0_DFP * n + alpha + beta + 1.0_DFP +b2 = Factorial(n) +b3 = GAMMA(n + alpha + beta + 1.0_DFP) +ans = a1 * a2 * a3 / b1 / b2 / b3 +END PROCEDURE JacobiNormSqr + +!---------------------------------------------------------------------------- +! JacobiNormSqr2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiNormSqr2 +REAL(DFP) :: rn, s +INTEGER(I4B) :: ii +!! +ans(0) = JacobiNormSQR(n=0_I4B, alpha=alpha, beta=beta) +!! +IF (n .EQ. 0) RETURN +!! +s = JacobiNormSQRRatio(n=0_I4B, alpha=alpha, beta=beta) +ans(1) = ans(0) * s +!! +DO ii = 1, n - 1 + rn = REAL(ii, KIND=DFP) + s = (rn + alpha + 1.0_DFP) * (rn + beta + 1.0_DFP) * & + & (2.0_DFP * rn + alpha + beta + 1.0_DFP) / (rn + 1.0_DFP) & + & / (2.0_DFP * rn + alpha + beta + 3.0_DFP) & + & / (rn + alpha + beta + 1.0_DFP) + ans(ii + 1) = s * ans(ii) +END DO +END PROCEDURE JacobiNormSqr2 + +!---------------------------------------------------------------------------- +! JacobiNormSqrRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiNormSqrRatio +REAL(DFP) :: rn +IF (n .EQ. 0) THEN + ans = (1.0_DFP + alpha) * (1.0_DFP + beta) / (3.0_DFP + alpha + beta) +ELSE + rn = REAL(n, KIND=DFP) + ans = (rn + alpha + 1.0_DFP) * (rn + beta + 1.0_DFP) * & + & (2.0_DFP * rn + alpha + beta + 1.0_DFP) / (rn + 1.0_DFP) & + & / (2.0_DFP * rn + alpha + beta + 3.0_DFP) & + & / (rn + alpha + beta + 1.0_DFP) +END IF +END PROCEDURE JacobiNormSqrRatio + +!---------------------------------------------------------------------------- +! JacobiJacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiJacobiMatrix +REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0 + !! +IF (n .LT. 1) RETURN + !! +CALL GetJacobiRecurrenceCoeff(n=n, alpha=alpha, beta=beta, & + & alphaCoeff=alphaCoeff0, betaCoeff=betaCoeff0) +IF (PRESENT(alphaCoeff)) alphaCoeff(0:n - 1) = alphaCoeff0 +IF (PRESENT(betaCoeff)) betaCoeff(0:n - 1) = betaCoeff0 +CALL JacobiMatrix(alphaCoeff=alphaCoeff0, & + & betaCoeff=betaCoeff0, D=D, E=E) + !! +END PROCEDURE JacobiJacobiMatrix + +!---------------------------------------------------------------------------- +! JacobiGaussQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGaussQuadrature +REAL(DFP) :: beta0, Z(n, n), betaCoeff(0:n - 1), pn(n) +INTEGER(I4B) :: ii + !! +CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=beta, D=pt, & + & E=pn, betaCoeff=betaCoeff) + !! +#ifdef USE_LAPACK95 +IF (PRESENT(wt)) THEN + wt = pn + CALL STEV(D=pt, E=wt, Z=Z) + DO ii = 1, n + wt(ii) = betaCoeff(0) * Z(1, ii)**2 + END DO +ELSE + CALL STEV(D=pt, E=pn) +END IF + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiGaussQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE JacobiGaussQuadrature + +!---------------------------------------------------------------------------- +! JacobiJacobiRadauMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiJacobiRadauMatrix +REAL(DFP) :: avar, r1, r2, r3, ab, ab2 + !! +IF (n .LT. 1) RETURN + !! +CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=beta, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) + !! +r1 = (1.0 - a) * n * (n + alpha) - (1.0 + a) * n * (n + beta) +r2 = 2.0 * n + alpha + beta +r3 = r2 + 1.0 +avar = a + r1 / r2 / r3 +D(n + 1) = avar + !! +ab = alpha + beta +ab2 = ab + 2.0_DFP +IF (n .EQ. 1) THEN + avar = 4.0_DFP * (1.0_DFP+alpha) * (1.0_DFP+beta) / (ab2*ab2*(ab2+1.0)) +ELSE + avar = 4.0_DFP * n * (n + alpha) * (n + beta) * (n + ab) & + & / (ab + 2.0 * n)**2 / (ab + 1.0 + 2.0 * n) / (ab - 1.0 + 2.0 * n) +END IF + !! +E(n) = SQRT(avar) + !! +END PROCEDURE JacobiJacobiRadauMatrix + +!---------------------------------------------------------------------------- +! JacobiGaussRadauQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGaussRadauQuadrature + !! +REAL(DFP) :: beta0, Z(n + 1, n + 1), betaCoeff(0:n), pn(n + 1) +INTEGER(I4B) :: ii + !! +CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=alpha, beta=beta, D=pt, & + & E=pn, betaCoeff=betaCoeff) + !! +#ifdef USE_LAPACK95 + !! +IF (PRESENT(wt)) THEN + wt = pn + CALL STEV(D=pt, E=wt, Z=Z) + DO ii = 1, n + 1 + wt(ii) = betaCoeff(0) * Z(1, ii)**2 + END DO +ELSE + CALL STEV(D=pt, E=pn) +END IF + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiGaussRadauQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE JacobiGaussRadauQuadrature + +!---------------------------------------------------------------------------- +! JacobiJacobiLobattoMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiJacobiLobattoMatrix + !! +REAL(DFP) :: avar, r1, r2, r3, ab + !! +IF (n .LT. 0) RETURN + !! +CALL JacobiJacobiMatrix( & + & n=n + 1, & + & alpha=alpha, & + & beta=beta, & + & D=D, & + & E=E, & + & alphaCoeff=alphaCoeff, & + & betaCoeff=betaCoeff) + !! +r1 = alpha - beta +r2 = 2.0 * n + alpha + beta + 2.0_DFP +r3 = 1.0 +avar = r1 / r2 / r3 +D(n + 2) = avar + !! +ab = alpha + beta +r1 = 4.0_DFP * (n + alpha + 1.0) * (n + beta + 1.0) * (n + ab + 1.0) +r2 = 2.0 * n + ab + 1.0 +r3 = (r2 + 1.0)**2 + !! +E(n + 1) = SQRT(r1 / r2 / r3) + !! +END PROCEDURE JacobiJacobiLobattoMatrix + +!---------------------------------------------------------------------------- +! JacobiGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGaussLobattoQuadrature + !! +REAL(DFP) :: beta0, Z(n + 2, n + 2), betaCoeff(0:n + 1), pn(n + 2) +INTEGER(I4B) :: ii + !! +CALL JacobiJacobiLobattoMatrix(n=n, alpha=alpha, beta=beta, D=pt, & + & E=pn, betaCoeff=betaCoeff) +!! +#ifdef USE_LAPACK95 +IF (PRESENT(wt)) THEN + wt = pn + CALL STEV(D=pt, E=wt, Z=Z) + DO ii = 1, n + 2 + wt(ii) = betaCoeff(0) * Z(1, ii)**2 + END DO +ELSE + CALL STEV(D=pt, E=pn) +END IF + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiGaussLobattoQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE JacobiGaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! JacobiZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiZeros + !! +REAL(DFP) :: E(n) + !! +CALL JacobiJacobiMatrix( & + & n=n, & + & alpha=alpha, & + & beta=beta, & + & D=ans, & + & E=E) + !! +#ifdef USE_LAPACK95 + !! +CALL STEV(D=ans, E=E) + !! +#else + !! +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiZeros", & + & line=__LINE__, & + & unitno=stdout) + !! +#endif + !! +END PROCEDURE JacobiZeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiQuadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP + !! +SELECT CASE (quadType) +CASE (Gauss) + order = n + CALL JacobiGaussQuadrature(n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +CASE (GaussRadau, GaussRadauLeft) + order = n - 1 + CALL JacobiGaussRadauQuadrature(a=left, n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +CASE (GaussRadauRight) + order = n - 1 + CALL JacobiGaussRadauQuadrature(a=right, n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +CASE (GaussLobatto) + order = n - 2 + CALL JacobiGaussLobattoQuadrature(n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +END SELECT +END PROCEDURE JacobiQuadrature + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalAll1 +INTEGER(I4B) :: i +REAL(DFP) :: c1 +REAL(DFP) :: c2 +REAL(DFP) :: c3 +REAL(DFP) :: c4 +REAL(DFP) :: r_i +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans(i + 1) = ((c3 + c2 * x) * ans(i) + c4 * ans(i - 1)) / c1 + !! +END DO + +END PROCEDURE JacobiEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalAll2 +INTEGER(I4B) :: i +REAL(DFP) :: c1 +REAL(DFP) :: c2 +REAL(DFP) :: c3 +REAL(DFP) :: c4 +REAL(DFP) :: r_i +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(:, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(:, 2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans(:, i + 1) = ((c3 + c2 * x(:)) & + & * ans(:, i) + c4 * ans(:, i - 1)) / c1 + !! +END DO + !! +END PROCEDURE JacobiEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEval1 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, c4, r_i, ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans_1 = ans + ans = ((c3 + c2 * x) * ans + c4 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE JacobiEval1 + +!---------------------------------------------------------------------------- +! JacobiEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEval2 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, c4, r_i +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans_1 = ans + ans = ((c3 + c2 * x) * ans + c4 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE JacobiEval2 + +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +CALL GetJacobiRecurrenceCoeff2(n=n + 2, alpha=alpha, beta=beta, A=A, B=B, C=C) +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 0, -1 + t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO +!! +ans = b1 +!! +END PROCEDURE JacobiEvalSum1 + +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +CALL GetJacobiRecurrenceCoeff2(n=n + 2, alpha=alpha, beta=beta, A=A, B=B, C=C) +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 0, -1 + t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO +!! +ans = b1 +!! +END PROCEDURE JacobiEvalSum2 + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEval1 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP) :: p, p_1, p_2 +REAL(DFP) :: ans_1, ans_2 +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +!! +ab = alpha + beta +amb = alpha - beta +p = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p = (a1 * x + a2) * p - a3 * p_2 + !! + p_2 = p_1 + !! + ans_1 = ans + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans = (p_1 - b1 * ans_2 - b2 * ans_1) / b3 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE JacobiGradientEval1 + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2, ans_1, ans_2 +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +!! +ab = alpha + beta +amb = alpha - beta +p = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p = (a1 * x + a2) * p - a3 * p_2 + !! + p_2 = p_1 + !! + ans_1 = ans + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans = (p_1 - b1 * ans_2 - b2 * ans_1) / b3 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE JacobiGradientEval2 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalAll1 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP), DIMENSION(n + 1) :: p +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(1) = 1.0_DFP +ans(1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +!! +ab = alpha + beta +amb = alpha - beta +p(2) = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans(2) = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p(ii + 1) = (a1 * x + a2) * p(ii) - a3 * p(ii - 1) + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans(ii + 1) = (p(ii) - b1 * ans(ii - 1) - b2 * ans(ii)) / b3 + !! +END DO +!! +END PROCEDURE JacobiGradientEvalAll1 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalAll2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP), DIMENSION(SIZE(x), n + 1) :: p +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(:, 1) = 1.0_DFP +ans(:, 1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +ab = alpha + beta +amb = alpha - beta +p(:, 2) = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans(:, 2) = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p(:, ii + 1) = (a1 * x + a2) * p(:, ii) - a3 * p(:, ii - 1) + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans(:, ii + 1) = (p(:, ii) - b1 * ans(:, ii - 1) - b2 * ans(:, ii)) / b3 + !! +END DO +!! +END PROCEDURE JacobiGradientEvalAll2 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum1 +REAL(DFP) :: t, b1, b2, Ac, A1, A2, a10, a11, a12, a20, a21, j +REAL(DFP), PARAMETER :: c = 0.5_DFP +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + !! + !! Recurrence coeff + !! + Ac = j + 2 + alpha + beta; + a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); + a11 = (2 * j + 4 + alpha + beta) * x; + a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); + A1 = a10 * (a11 + a12); + a20 = -(j + 2 + alpha) * (j + 2 + beta) & + & / ((j + 2) * (alpha + beta + j + 4)); + a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 + +END PROCEDURE JacobiGradientEvalSum1 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum2 +REAL(DFP) :: Ac, A2, a10, a12, a20, a21, j +REAL(DFP), DIMENSION(SIZE(x)) :: a11, A1, t, b1, b2 +REAL(DFP), PARAMETER :: c = 0.5_DFP +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + !! + !! Recurrence coeff + !! + Ac = j + 2 + alpha + beta; + a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); + a11 = (2 * j + 4 + alpha + beta) * x; + a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); + A1 = a10 * (a11 + a12); + a20 = -(j + 2 + alpha) * (j + 2 + beta) & + & / ((j + 2) * (alpha + beta + j + 4)); + a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 +END PROCEDURE JacobiGradientEvalSum2 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum3 +REAL(DFP) :: t, b1, b2, Ac, A1, A2, a10, a11, a12, a20, a21, c, s +INTEGER(I4B) :: i, j +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +c = 1.0_DFP +!! +DO i = k, 1, -1 + c = c / 2.0_DFP +END DO +!! +DO i = n - k, 0, -1 + !! + s = 1.0_DFP + !! + DO j = 1, k + s = s * (alpha + beta + i + k + j) + END DO + !! + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1 = a10 * (a11 + a12); + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a21 = (alpha + beta + 2 * i + 4 + 2 * k) & + & / (alpha + beta + 2 * i + 2 + 2 * k); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + s * coeff(i + k); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 + +END PROCEDURE JacobiGradientEvalSum3 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum4 +REAL(DFP) :: Ac, A2, a10, a12, a20, a21, c, s +REAL(DFP), DIMENSION(SIZE(x)) :: a11, A1, t, b1, b2 +INTEGER(I4B) :: i, j +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +c = 1.0_DFP +!! +DO i = k, 1, -1 + c = c / 2.0_DFP +END DO +!! +DO i = n - k, 0, -1 + !! + s = 1.0_DFP + !! + DO j = 1, k + s = s * (alpha + beta + i + k + j) + END DO + !! + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1 = a10 * (a11 + a12); + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a21 = (alpha + beta + 2 * i + 4 + 2 * k) & + & / (alpha + beta + 2 * i + 2 + 2 * k); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + s * coeff(i + k); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 + +END PROCEDURE JacobiGradientEvalSum4 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform1 +REAL(DFP), DIMENSION(0:n) :: Gamma, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +!! +Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) +!! +!! Correct Gamma(n) +!! +IF (quadType .EQ. GaussLobatto) THEN + Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & + & * Gamma(n) +END IF +!! +PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / Gamma(jj) +END DO +!! +END PROCEDURE JacobiTransform1 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform2 +REAL(DFP), DIMENSION(0:n) :: Gamma, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +!! +Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) +!! +!! Correct Gamma(n) +!! +IF (quadType .EQ. GaussLobatto) THEN + Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & + & * Gamma(n) +END IF +!! +PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / Gamma(jj) + END DO +END DO +!! +END PROCEDURE JacobiTransform2 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii +!! +CALL JacobiQuadrature(n=n + 1, alpha=alpha, beta=beta, pt=pt, wt=wt,& + & quadType=quadType) +!! +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO +!! +ans = JacobiTransform(n=n, alpha=alpha, beta=beta, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) +END PROCEDURE JacobiTransform3 + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiInvTransform1 +ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & + & x=x) +END PROCEDURE JacobiInvTransform1 + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiInvTransform2 +ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & + & x=x) +END PROCEDURE JacobiInvTransform2 + +!---------------------------------------------------------------------------- +! JacobiGradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientCoeff1 +REAL(DFP) :: a, b, c, ab, amb, tnab, nab +INTEGER(I4B) :: ii +REAL(DFP) :: jj + +ans(n) = 0.0_DFP +IF (n .EQ. 0) RETURN +!! +!! c(n-1) +!! +ab = alpha + beta +amb = alpha - beta +tnab = 2.0 * n + ab +nab = n + ab +!! +IF (n .EQ. 1) THEN + c = 2.0_DFP / (ab + 2.0_DFP) +ELSE + c = 2.0 * (n + ab) / (tnab - 1.0) / tnab +END IF +!! +ans(n - 1) = coeff(n) / c +!! +DO ii = n - 1, 1, -1 + jj = REAL(ii, KIND=DFP) + tnab = 2.0 * jj + ab + nab = jj + ab + c = 2.0 * (jj + ab) / (tnab - 1.0) / tnab + b = 2.0 * amb / tnab / (tnab + 2.0) + a = -2.0 * (jj+alpha+1.0)*(jj+beta+1.0) / (nab+1.0) / (tnab+2.0)/(tnab+3.0) + ans(ii - 1) = (coeff(ii) - b * ans(ii) - a * ans(ii + 1)) / c +END DO +!! +END PROCEDURE JacobiGradientCoeff1 + +!---------------------------------------------------------------------------- +! JacobiDMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiDMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL JacobiDMatrixGL(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType,& + & D=ans) +CASE (Gauss) + CALL JacobiDMatrixG(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType, & + & D=ans) +END SELECT +END PROCEDURE JacobiDMatrix1 + +!---------------------------------------------------------------------------- +! JacobiDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE JacobiDMatrixGL(n, alpha, beta, x, quadType, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: ab, rn + INTEGER(I4B) :: ii, jj + REAL(DFP) :: gb2, gna1, gnb1, ga2, sgn, gn, ga1, temp + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = JacobiGradientEval(n=n - 1, alpha=alpha + 1.0_DFP, & + & beta=beta + 1.0_DFP, x=x) + !! + !! zeroth column + !! + ab = alpha + beta + rn = REAL(n, KIND=DFP) + !! + D(0, 0) = 0.5 * (alpha - rn * (rn + ab + 1.0)) / (beta + 2.0) + !! + !! + gb2 = GAMMA(beta + 2.0_DFP) + gna1 = GAMMA(rn + alpha + 1.0_DFP) + gnb1 = GAMMA(rn + beta + 1.0_DFP) + ga1 = GAMMA(alpha + 1.0_DFP) + ga2 = ga1 * (alpha + 1.0_DFP) + gn = GAMMA(rn) + sgn = (-1.0)**n + !! + D(n, 0) = sgn * 0.5 * gb2 * gna1 / gnb1 / ga2 + !! + sgn = (-1.0)**(n - 1) + !! + DO ii = 1, n - 1 + D(ii, 0) = sgn * 0.5 * gn * gb2 * (1.0 - x(ii)) * J(ii) / gnb1 + END DO + !! + !! last column + !! + sgn = (-1.0)**(n + 1) + !! + D(0, n) = sgn * 0.5 * ga2 * gnb1 / gna1 / gb2 + !! + D(n, n) = 0.5 * (-beta + rn * (rn + ab + 1.0)) / (alpha + 2.0) + !! + D(1:n - 1, n) = (gn * ga2 * 0.5 / gna1) * (1.0_DFP + x(1:n - 1)) & + & * J(1:n - 1) + !! + !! internal columns + !! + sgn = (-1.0)**(n) + DO ii = 1, n - 1 + temp = J(ii) * (1.0 - x(ii)) * (1.0 + x(ii))**2 + D(0, ii) = 2.0 * sgn * gnb1 / gn / gb2 / temp + !! + temp = J(ii) * (1.0 + x(ii)) * (1.0 - x(ii))**2 + D(n, ii) = -2.0 * gna1 / gn / ga2 / temp + END DO + !! + DO jj = 1, n - 1 + DO ii = 1, n - 1 + IF (ii .EQ. jj) THEN + D(ii, ii) = (alpha - beta + ab * x(ii)) / 2.0 / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = (1.0 - x(ii)**2) * J(ii) / (1.0 - x(jj)**2) / J(jj) & + & / (x(ii) - x(jj)) + END IF + END DO + END DO +END SUBROUTINE JacobiDMatrixGL + +!---------------------------------------------------------------------------- +! JacobiDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE JacobiDMatrixG(n, alpha, beta, x, quadType, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: ab, amb + INTEGER(I4B) :: ii, jj + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = JacobiGradientEval(n=n + 1, alpha=alpha, beta=beta, x=x) + !! + !! zeroth column + !! + ab = alpha + beta + ab = alpha - beta + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = (amb + (ab + 2.0) * x(ii)) / 2.0 / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO +!! +END SUBROUTINE JacobiDMatrixG + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 new file mode 100644 index 000000000..d08340e69 --- /dev/null +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -0,0 +1,927 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(LagrangePolynomialUtility) Methods +USE GlobalData, ONLY: stdout, stderr, Point, Line, Triangle, Quadrangle, & + Tetrahedron, Hexahedron, Prism, Pyramid + +USE ErrorHandling, ONLY: Errormsg + +USE ReferenceElement_Method, ONLY: ElementTopology + +USE ReferenceLine_Method, ONLY: RefCoord_Line +USE ReferenceTriangle_Method, ONLY: RefCoord_Triangle +USE ReferenceQuadrangle_Method, ONLY: RefCoord_Quadrangle +USE ReferenceTetrahedron_Method, ONLY: RefCoord_Tetrahedron +USE ReferenceHexahedron_Method, ONLY: RefCoord_Hexahedron +USE ReferencePrism_Method, ONLY: RefCoord_Prism +USE ReferencePyramid_Method, ONLY: RefCoord_Pyramid + +USE LineInterpolationUtility, ONLY: RefElemDomain_Line, & + LagrangeDOF_Line, & + LagrangeInDOF_Line, & + LagrangeDegree_Line, & + EquidistancePoint_Line, & + InterpolationPoint_Line, & + LagrangeCoeff_Line, & + LagrangeEvalAll_Line, & + LagrangeGradientEvalAll_Line + +USE TriangleInterpolationUtility, ONLY: RefElemDomain_Triangle, & + LagrangeDOF_Triangle, & + LagrangeInDOF_Triangle, & + LagrangeDegree_Triangle, & + EquidistancePoint_Triangle, & + InterpolationPoint_Triangle, & + LagrangeCoeff_Triangle, & + LagrangeEvalAll_Triangle, & + LagrangeGradientEvalAll_Triangle + +USE QuadrangleInterpolationUtility, ONLY: RefElemDomain_Quadrangle, & + LagrangeDOF_Quadrangle, & + LagrangeInDOF_Quadrangle, & + LagrangeDegree_Quadrangle, & + EquidistancePoint_Quadrangle, & + InterpolationPoint_Quadrangle, & + LagrangeCoeff_Quadrangle, & + LagrangeEvalAll_Quadrangle, & + LagrangeGradientEvalAll_Quadrangle + +USE TetrahedronInterpolationUtility, ONLY: RefElemDomain_Tetrahedron, & + LagrangeDOF_Tetrahedron, & + LagrangeInDOF_Tetrahedron, & + LagrangeDegree_Tetrahedron, & + EquidistancePoint_Tetrahedron, & + InterpolationPoint_Tetrahedron, & + LagrangeCoeff_Tetrahedron, & + LagrangeEvalAll_Tetrahedron, & + LagrangeGradientEvalAll_Tetrahedron + +USE HexahedronInterpolationUtility, ONLY: RefElemDomain_Hexahedron, & + LagrangeDOF_Hexahedron, & + LagrangeInDOF_Hexahedron, & + LagrangeDegree_Hexahedron, & + EquidistancePoint_Hexahedron, & + InterpolationPoint_Hexahedron, & + LagrangeCoeff_Hexahedron, & + LagrangeEvalAll_Hexahedron, & + LagrangeGradientEvalAll_Hexahedron + +USE PrismInterpolationUtility, ONLY: RefElemDomain_Prism, & + LagrangeDOF_Prism, & + LagrangeInDOF_Prism, & + LagrangeDegree_Prism, & + EquidistancePoint_Prism, & + InterpolationPoint_Prism, & + LagrangeCoeff_Prism, & + LagrangeEvalAll_Prism, & + LagrangeGradientEvalAll_Prism + +USE PyramidInterpolationUtility, ONLY: RefElemDomain_Pyramid, & + LagrangeDOF_Pyramid, & + LagrangeInDOF_Pyramid, & + LagrangeDegree_Pyramid, & + EquidistancePoint_Pyramid, & + InterpolationPoint_Pyramid, & + LagrangeCoeff_Pyramid, & + LagrangeEvalAll_Pyramid, & + LagrangeGradientEvalAll_Pyramid + +USE ReallocateUtility, ONLY: Reallocate + +USE Display_Method, ONLY: ToString + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! RefElemDomain +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = "" + +CASE (Line) + ans = RefElemDomain_Line(baseContinuity, baseInterpol) + +CASE (Triangle) + ans = RefElemDomain_Triangle(baseContinuity, baseInterpol) + +CASE (Quadrangle) + ans = RefElemDomain_Quadrangle(baseContinuity, baseInterpol) + +CASE (Tetrahedron) + ans = RefElemDomain_Tetrahedron(baseContinuity, baseInterpol) + +CASE (Hexahedron) + ans = RefElemDomain_Hexahedron(baseContinuity, baseInterpol) + +CASE (Prism) + ans = RefElemDomain_Prism(baseContinuity, baseInterpol) + +CASE (Pyramid) + ans = RefElemDomain_Pyramid(baseContinuity, baseInterpol) +END SELECT + +END PROCEDURE RefElemDomain + +!---------------------------------------------------------------------------- +! RefCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefCoord +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) + CALL Reallocate(ans, 3_I4B, 1_I4B) + +CASE (Line) + ans = RefCoord_Line(refElem) + +CASE (Triangle) + ans = RefCoord_Triangle(refElem) + +CASE (Quadrangle) + ans = RefCoord_Quadrangle(refElem) + +CASE (Tetrahedron) + ans = RefCoord_Tetrahedron(refElem) + +CASE (Hexahedron) + ans = RefCoord_Hexahedron(refElem) + +CASE (Prism) + ans = RefCoord_Prism(refElem) + +CASE (Pyramid) + ans = RefCoord_Pyramid(refElem) + +END SELECT +END PROCEDURE RefCoord + +!---------------------------------------------------------------------------- +! LagrangeDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = 1 +CASE (Line) + ans = LagrangeDOF_Line(order=order) +CASE (Triangle) + ans = LagrangeDOF_Triangle(order=order) +CASE (Quadrangle) + ans = LagrangeDOF_Quadrangle(order=order) +CASE (Tetrahedron) + ans = LagrangeDOF_Tetrahedron(order=order) +CASE (Hexahedron) + ans = LagrangeDOF_Hexahedron(order=order) +CASE (Prism) + ans = LagrangeDOF_Prism(order=order) +CASE (Pyramid) + ans = LagrangeDOF_Pyramid(order=order) +END SELECT +END PROCEDURE LagrangeDOF + +!---------------------------------------------------------------------------- +! LagrangeInDOF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = 0 +CASE (Line) + ans = LagrangeInDOF_Line(order=order) +CASE (Triangle) + ans = LagrangeInDOF_Triangle(order=order) +CASE (Quadrangle) + ans = LagrangeInDOF_Quadrangle(order=order) +CASE (Tetrahedron) + ans = LagrangeInDOF_Tetrahedron(order=order) +CASE (Hexahedron) + ans = LagrangeInDOF_Hexahedron(order=order) +CASE (Prism) + ans = LagrangeInDOF_Prism(order=order) +CASE (Pyramid) + ans = LagrangeInDOF_Pyramid(order=order) +END SELECT + +END PROCEDURE LagrangeInDOF + +!---------------------------------------------------------------------------- +! LagrangeDegree +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree +INTEGER(I4B) :: topo +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ALLOCATE (ans(0, 0)) +CASE (Line) + ans = LagrangeDegree_Line(order=order) +CASE (Triangle) + ans = LagrangeDegree_Triangle(order=order) +CASE (Quadrangle) + ans = LagrangeDegree_Quadrangle(order=order) +CASE (Tetrahedron) + ans = LagrangeDegree_Tetrahedron(order=order) +CASE (Hexahedron) + ans = LagrangeDegree_Hexahedron(order=order) +CASE (Prism) + ans = LagrangeDegree_Prism(order=order) +CASE (Pyramid) + ans = LagrangeDegree_Pyramid(order=order) +END SELECT +END PROCEDURE LagrangeDegree + +!---------------------------------------------------------------------------- +! LagrangeVandermonde +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeVandermonde +INTEGER(I4B) :: nrow, ncol +nrow = SIZE(xij, 2) +ncol = LagrangeDOF(order=order, elemType=elemType) +CALL Reallocate(ans, nrow, ncol) +CALL LagrangeVandermonde_(xij=xij, order=order, elemType=elemType, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeVandermonde + +!---------------------------------------------------------------------------- +! LagrangeVandermonde_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeVandermonde_ +INTEGER(I4B), ALLOCATABLE :: degree(:, :) +INTEGER(I4B) :: jj, nsd, ii + +degree = LagrangeDegree(order=order, elemType=elemType) +nrow = SIZE(xij, 2) +nsd = SIZE(degree, 2) +ncol = SIZE(degree, 1) + +SELECT CASE (nsd) +CASE (1) + + DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = xij(1, ii)**degree(jj, 1) + END DO + +CASE (2) + + 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 + +CASE (3) + + DO CONCURRENT(jj=1:ncol, ii=1:nrow) + ans(ii, jj) = (xij(1, ii)**degree(jj, 1)) * (xij(2, ii)**degree(jj, 2)) & + & * (xij(3, ii)**degree(jj, 3)) + END DO + +END SELECT + +IF (ALLOCATED(degree)) DEALLOCATE (degree) +END PROCEDURE LagrangeVandermonde_ + +!---------------------------------------------------------------------------- +! EquidistancePoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) + IF (PRESENT(xij)) THEN + ans = xij + ELSE + ALLOCATE (ans(0, 0)) + END IF + +CASE (Line) + ans = EquidistancePoint_Line(order=order, xij=xij) + +CASE (Triangle) + ans = EquidistancePoint_Triangle(order=order, xij=xij) + +CASE (Quadrangle) + ans = EquidistancePoint_Quadrangle(order=order, xij=xij) + +CASE (Tetrahedron) + ans = EquidistancePoint_Tetrahedron(order=order, xij=xij) + +CASE (Hexahedron) + ans = EquidistancePoint_Hexahedron(order=order, xij=xij) + +CASE (Prism) + ans = EquidistancePoint_Prism(order=order, xij=xij) + +CASE (Pyramid) + ans = EquidistancePoint_Pyramid(order=order, xij=xij) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="EquidistancePoint()", & + & file=__FILE__) +END SELECT +END PROCEDURE EquidistancePoint + +!---------------------------------------------------------------------------- +! InterpolationPoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) + IF (PRESENT(xij)) THEN + ans = xij + ELSE + ALLOCATE (ans(0, 0)) + END IF + +CASE (Line) + ans = InterpolationPoint_Line(& + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout=layout, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE (Triangle) + ans = InterpolationPoint_Triangle( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout=layout, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE (Quadrangle) + ans = InterpolationPoint_Quadrangle( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout=layout, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE (Tetrahedron) + ans = InterpolationPoint_Tetrahedron( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout=layout, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE (Hexahedron) + ans = InterpolationPoint_Hexahedron( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout=layout, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE (Prism) + ans = InterpolationPoint_Prism( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout=layout, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE (Pyramid) + ans = InterpolationPoint_Pyramid( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout=layout, & + & alpha=alpha, beta=beta, lambda=lambda) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="InterpolationPoint()", & + & file=__FILE__) + RETURN +END SELECT + +END PROCEDURE InterpolationPoint + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff1 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) +CASE (Line) + ans = LagrangeCoeff_Line(order=order, xij=xij, i=i) + +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, xij=xij, i=i) + +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, xij=xij, i=i) + +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij, i=i) + +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, xij=xij, i=i) + +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, xij=xij, i=i) + +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, xij=xij, i=i) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="LagrangeCoeff1()", & + & file=__FILE__) +END SELECT + +END PROCEDURE LagrangeCoeff1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff2 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + ans = LagrangeCoeff_Line(order=order, xij=xij) + +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, xij=xij) + +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, xij=xij) + +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij) + +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, xij=xij) + +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, xij=xij) + +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, xij=xij) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="LagrangeCoeff2()", & + & file=__FILE__) +END SELECT +END PROCEDURE LagrangeCoeff2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff3 +INTEGER(I4B) :: topo +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + ans = LagrangeCoeff_Line(order=order, i=i, v=v, isVandermonde=.TRUE.) + +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, isVandermonde=.TRUE.) + +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, isVandermonde=.TRUE.) + +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) + +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) + +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, i=i, v=v, isVandermonde=.TRUE.) + +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, isVandermonde=.TRUE.) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="LagrangeCoeff2()", & + & file=__FILE__) +END SELECT +END PROCEDURE LagrangeCoeff3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff4 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + ans = LagrangeCoeff_Line(order=order, i=i, v=v, ipiv=ipiv) + +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, ipiv=ipiv) + +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, ipiv=ipiv) + +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, ipiv=ipiv) + +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, ipiv=ipiv) + +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, i=i, v=v, ipiv=ipiv) + +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, ipiv=ipiv) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="LagrangeCoeff2()", & + & file=__FILE__) +END SELECT +END PROCEDURE LagrangeCoeff4 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll1 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + ans = LagrangeEvalAll_Line( & + & order=order, & + & xij=xij, & + & x=x, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Triangle) + ans = LagrangeEvalAll_Triangle( & + & order=order, & + & x=x, & + & xij=xij, & + & refTriangle=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Quadrangle) + ans = LagrangeEvalAll_Quadrangle( & + & order=order, & + & x=x, & + & xij=xij, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Tetrahedron) + ans = LagrangeEvalAll_Tetrahedron( & + & order=order, & + & x=x, & + & xij=xij, & + & refTetrahedron=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Hexahedron) + ans = LagrangeEvalAll_Hexahedron( & + & order=order, & + & x=x, & + & xij=xij, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Prism) + ans = LagrangeEvalAll_Prism( & + & order=order, & + & x=x, & + & xij=xij, & + & refPrism=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Pyramid) + ans = LagrangeEvalAll_Pyramid( & + & order=order, & + & x=x, & + & xij=xij, & + & refPyramid=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="LagrangeEvalAll2()", & + & file=__FILE__) +END SELECT +END PROCEDURE LagrangeEvalAll1 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll1 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + IF (SIZE(x, 1) .NE. 1 .OR. SIZE(xij, 1) .NE. 1) THEN + CALL Errormsg( & + & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 1", & + & unitno=stderr, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1", & + & file=__FILE__) + RETURN + END IF + + ans(:, :, 1:1) = LagrangeGradientEvalAll_Line( & + & order=order, & + & x=x, & + & xij=xij, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Triangle) + + IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN + CALL Errormsg( & + & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & + & unitno=stderr, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1", & + & file=__FILE__) + RETURN + END IF + + ans(:, :, 1:2) = LagrangeGradientEvalAll_Triangle( & + & order=order, & + & x=x, & + & xij=xij, & + & refTriangle=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Quadrangle) + + IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN + CALL Errormsg( & + & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & + & unitno=stderr, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1", & + & file=__FILE__) + RETURN + END IF + ans(:, :, 1:2) = LagrangeGradientEvalAll_Quadrangle( & + & order=order, & + & x=x, & + & xij=xij, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Tetrahedron) + + IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN + CALL Errormsg( & + & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + & unitno=stderr, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1", & + & file=__FILE__) + RETURN + END IF + ans(:, :, 1:3) = LagrangeGradientEvalAll_Tetrahedron( & + & order=order, & + & x=x, & + & xij=xij, & + & refTetrahedron=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Hexahedron) + + IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN + CALL Errormsg( & + & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + & unitno=stderr, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1", & + & file=__FILE__) + RETURN + END IF + ans(:, :, 1:3) = LagrangeGradientEvalAll_Hexahedron( & + & order=order, & + & x=x, & + & xij=xij, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Prism) + + IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN + CALL Errormsg( & + & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + & unitno=stderr, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1", & + & file=__FILE__) + RETURN + END IF + ans(:, :, 1:3) = LagrangeGradientEvalAll_Prism( & + & order=order, & + & x=x, & + & xij=xij, & + & refPrism=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE (Pyramid) + + IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN + CALL Errormsg( & + & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + & unitno=stderr, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1", & + & file=__FILE__) + RETURN + END IF + ans(:, :, 1:3) = LagrangeGradientEvalAll_Pyramid( & + & order=order, & + & x=x, & + & xij=xij, & + & refPyramid=domainName, & + & coeff=coeff, & + & firstCall=firstCall, & + & basisType=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE DEFAULT + CALL Errormsg(& + & msg="No CASE FOUND: elemType="//ToString(elemType), & + & unitno=stdout, & + & line=__LINE__, & + & routine="LagrangeGradientEvalAll1()", & + & file=__FILE__) + RETURN +END SELECT +END PROCEDURE LagrangeGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 new file mode 100644 index 000000000..f91273474 --- /dev/null +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -0,0 +1,1182 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(LegendrePolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! LegendreAlpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreAlpha +ans = 0.0_DFP +END PROCEDURE LegendreAlpha + +!---------------------------------------------------------------------------- +! LegendreBeta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreBeta +REAL(DFP) :: avar +!! +IF (n .EQ. 0_I4B) THEN + ans = 2.0_DFP +ELSE + avar = REAL(n**2, KIND=DFP) + ans = avar / (4.0_DFP * avar - 1.0_DFP) +END IF +END PROCEDURE LegendreBeta + +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetLegendreRecurrenceCoeff +REAL(DFP), PARAMETER :: one = 1.0_DFP, two = 2.0_DFP, four = 4.0_DFP +REAL(DFP) :: avar +INTEGER(I4B) :: ii +!! +IF (n .LE. 0) RETURN +!! +alphaCoeff = 0.0_DFP +betaCoeff(0) = two +IF (n .EQ. 1) RETURN +!! +DO ii = 1, n - 1 + avar = REAL(ii**2, KIND=DFP) + betaCoeff(ii) = avar / (four * avar - one) +END DO +!! +END PROCEDURE GetLegendreRecurrenceCoeff + +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetLegendreRecurrenceCoeff2 +REAL(DFP) :: j +INTEGER(I4B) :: ii +!! +IF (n .LT. 1) RETURN +B = 0.0_DFP +!! +DO ii = 1, n + j = REAL(ii, KIND=DFP) + A(ii - 1) = (2.0_DFP * j - 1.0_DFP) / j; + C(ii - 1) = (j - 1.0_DFP) / j; +END DO +!! +END PROCEDURE GetLegendreRecurrenceCoeff2 + +!---------------------------------------------------------------------------- +! LegendreLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreLeadingCoeff +REAL(DFP) :: a1, a2, a3 +a1 = REAL(Factorial(2 * n), KIND=DFP) +a2 = REAL(Factorial(n)**2, KIND=DFP) +a3 = REAL(2**n, KIND=DFP) +ans = a1 / a2 / a3 +END PROCEDURE LegendreLeadingCoeff + +!---------------------------------------------------------------------------- +! LegendreLeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreLeadingCoeffRatio +ans = (2.0 * n + 1) / (n + 1.0_DFP) +END PROCEDURE LegendreLeadingCoeffRatio + +!---------------------------------------------------------------------------- +! LegendreNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreNormSqr +ans = 2.0_DFP / (2.0_DFP * n + 1.0_DFP) +END PROCEDURE LegendreNormSqr + +!---------------------------------------------------------------------------- +! LegendreNormSqrRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreNormSqrRatio +ans = (2.0_DFP * n + 1.0_DFP) / (2.0_DFP * n + 3.0_DFP) +END PROCEDURE LegendreNormSqrRatio + +!---------------------------------------------------------------------------- +! LegendreNormSqr2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreNormSqr2 +INTEGER(I4B) :: ii +DO ii = 0, n + ans(ii) = 2.0_DFP / (2.0_DFP * ii + 1.0_DFP) +END DO +END PROCEDURE LegendreNormSqr2 + +!---------------------------------------------------------------------------- +! LegendreJacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreJacobiMatrix +REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0 +!! +IF (n .LT. 1) RETURN +!! +CALL GetLegendreRecurrenceCoeff(n=n, alphaCoeff=alphaCoeff0, & + & betaCoeff=betaCoeff0) +IF (PRESENT(alphaCoeff)) alphaCoeff(0:n - 1) = alphaCoeff0 +IF (PRESENT(betaCoeff)) betaCoeff(0:n - 1) = betaCoeff0 +!! +CALL JacobiMatrix(alphaCoeff=alphaCoeff0, & + & betaCoeff=betaCoeff0, D=D, E=E) +!! +END PROCEDURE LegendreJacobiMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGaussQuadrature +REAL(DFP) :: pn(n), fixvar +INTEGER(I4B) :: ii +!! +CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) +!! +#ifdef USE_LAPACK95 +CALL STEV(D=pt, E=pn) +!! +IF (PRESENT(wt)) THEN + wt = pn + pn = LegendreEval(n=n - 1, x=pt) + fixvar = 2.0_DFP / REAL(n**2, KIND=DFP) + DO ii = 1, n + wt(ii) = fixvar * (1.0_DFP - pt(ii)**2) / (pn(ii)**2) + END DO +END IF + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="LegendreGaussQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE LegendreGaussQuadrature + +!---------------------------------------------------------------------------- +! LegendreJacobiRadauMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreJacobiRadauMatrix +REAL(DFP) :: avar, r1, r2 +!! +IF (n .LT. 1) RETURN +!! +CALL LegendreJacobiMatrix(n=n, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +!! +r1 = a * REAL(n + 1, KIND=DFP) +r2 = REAL(2 * n + 1, KIND=DFP) +D(n + 1) = r1 / r2 +!! +r1 = REAL(n**2, KIND=DFP) +r2 = 4.0_DFP * r1 - 1.0_DFP +!! +E(n) = SQRT(r1 / r2) +!! +END PROCEDURE LegendreJacobiRadauMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussRadauQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGaussRadauQuadrature +REAL(DFP) :: pn(n + 1), fixvar +INTEGER(I4B) :: ii + !! +CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=pn) +!! +#ifdef USE_LAPACK95 +!! +CALL STEV(D=pt, E=pn) +!! +IF (PRESENT(wt)) THEN + wt = pn + pn = LegendreEval(n=n, x=pt) + fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) + !! + DO ii = 1, n + 1 + wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) + END DO +END IF + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="LegendreGaussRadauQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE LegendreGaussRadauQuadrature + +!---------------------------------------------------------------------------- +! LegendreJacobiLobattoMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreJacobiLobattoMatrix + !! +REAL(DFP) :: r1, r2 + !! +IF (n .LT. 0) RETURN + !! +CALL LegendreJacobiMatrix( & + & n=n + 1, & + & D=D, & + & E=E, & + & alphaCoeff=alphaCoeff, & + & betaCoeff=betaCoeff) + !! +D(n + 2) = 0.0_DFP +r1 = REAL(n + 1, KIND=DFP) +r2 = REAL(2 * n + 1, KIND=DFP) + !! +E(n + 1) = SQRT(r1 / r2) + !! +END PROCEDURE LegendreJacobiLobattoMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGaussLobattoQuadrature +REAL(DFP) :: pn(n + 2), fixvar +INTEGER(I4B) :: ii +!! +CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=pn) +!! +#ifdef USE_LAPACK95 +!! +CALL STEV(D=pt, E=pn) +!! +IF (PRESENT(wt)) THEN + wt = pn + pn = LegendreEval(n=n + 1, x=pt) + fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) + !! + DO ii = 1, n + 2 + wt(ii) = fixvar / (pn(ii)**2) + END DO +END IF + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="LegendreGaussLobattoQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE LegendreGaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! LegendreZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreZeros +ans = JacobiZeros(alpha=0.0_DFP, beta=0.0_DFP, n=n) +END PROCEDURE LegendreZeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreQuadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP +REAL(DFP), ALLOCATABLE :: p(:), w(:) +LOGICAL(LGT) :: inside +!! +IF (PRESENT(onlyInside)) THEN + inside = onlyInside +ELSE + inside = .FALSE. +END IF +!! +SELECT CASE (QuadType) +CASE (Gauss) + !! + order = n + CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt) + !! +CASE (GaussRadau, GaussRadauLeft) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=p, wt=w) + pt = p(2:); wt = w(2:) + DEALLOCATE (p, w) + ELSE + order = n - 1 + CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussRadauRight) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=p, wt=w) + pt = p(1:n); wt = w(1:n) + ELSE + order = n - 1 + CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussLobatto) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 2), w(n + 2)) + CALL LegendreGaussLobattoQuadrature(n=order, pt=p, wt=w) + pt = p(2:n + 1); wt = w(2:n + 1) + ELSE + order = n - 2 + CALL LegendreGaussLobattoQuadrature(n=order, pt=pt, wt=wt) + END IF +END SELECT +END PROCEDURE LegendreQuadrature + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEval1 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i, ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + r_i = REAL(i, kind=DFP) + c1 = r_i + 1.0_DFP + c2 = 2.0_DFP * r_i + 1.0_DFP + c3 = -r_i + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE LegendreEval1 + +!---------------------------------------------------------------------------- +! LegendreEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEval2 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + r_i = REAL(i, kind=DFP) + c1 = r_i + 1.0_DFP + c2 = 2.0_DFP * r_i + 1.0_DFP + c3 = -r_i + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE LegendreEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalAll1 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2) = x +!! +DO i = 2, n + !! + r_i = REAL(i, kind=DFP) + c1 = r_i + c2 = 2.0_DFP * r_i - 1.0_DFP + c3 = -r_i + 1.0_DFP + !! + ans(i + 1) = ((c2 * x) * ans(i) + c3 * ans(i - 1)) / c1 + !! +END DO + +END PROCEDURE LegendreEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalAll2 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(:, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(:, 2) = x +!! +DO i = 2, n + !! + r_i = REAL(i, kind=DFP) + c1 = r_i + c2 = 2.0_DFP * r_i - 1.0_DFP + c3 = -r_i + 1.0_DFP + !! + ans(:, i + 1) = ((c2 * x) * ans(:, i) + c3 * ans(:, i - 1)) / c1 + !! +END DO + +END PROCEDURE LegendreEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreMonomialExpansionAll +REAL(DFP) :: r_i +INTEGER(I4B) :: ii + !! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 0.0_DFP +ans(1, 1) = 1.0_DFP + !! +IF (n .EQ. 0) THEN + RETURN +END IF + !! +ans(2, 2) = 1.0_DFP + !! +DO ii = 2, n + !! + r_i = REAL(ii, KIND=DFP) + !! + ans(1:ii - 1, ii + 1) = & + & (-r_i + 1.0) * ans(1:ii - 1, ii - 1) / r_i + !! + ans(2:ii + 1, ii + 1) = ans(2:ii + 1, ii + 1) & + & + (2.0 * r_i - 1.0) * ans(1:ii, ii) / r_i + !! +END DO +END PROCEDURE LegendreMonomialExpansionAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreMonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = LegendreMonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE LegendreMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalAll1 + !! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:n + 1) + !! +IF (n < 0) THEN + RETURN +END IF +!! +p(1) = 1.0_DFP +ans(1) = 0.0_DFP + !! +IF (n < 1) THEN + RETURN +END IF +!! +p(2) = x +ans(2) = 1.0_DFP + !! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p(ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(ii) & + & - (r_ii - 1.0_DFP) * p(ii - 1)) & + & / r_ii + !! + ans(ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(ii) + ans(ii - 1) + !! +END DO +!! +END PROCEDURE LegendreGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalAll2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:SIZE(x), 1:n + 1) +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(:, 1) = 1.0_DFP +ans(:, 1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +p(:, 2) = x +ans(:, 2) = 1.0_DFP +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p(:, ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(:, ii) & + & - (r_ii - 1.0_DFP) * p(:, ii - 1)) & + & / r_ii + !! + ans(:, ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(:, ii) + ans(:, ii - 1) + !! +END DO +!! +END PROCEDURE LegendreGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEval1 + !! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p, p_1, p_2 +REAL(DFP) :: ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +p = x +ans = 1.0_DFP +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + p = ((2.0_DFP * r_ii - 1) * x * p & + & - (r_ii - 1.0_DFP) * p_2) & + & / r_ii + !! + p_2 = p_1 + !! + ans_1 = ans + ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE LegendreGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +p = x +ans = 1.0_DFP +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + p = ((2.0_DFP * r_ii - 1) * x * p & + & - (r_ii - 1.0_DFP) * p_2) & + & / r_ii + !! + p_2 = p_1 + !! + ans_1 = ans + ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE LegendreGradientEval2 + +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 1, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) + b2 = b1 + b1 = t +END DO +!! +ans = x * b1 - b2 / 2.0_DFP + coeff(0) +!! +END PROCEDURE LegendreEvalSum1 + +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 1, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) + b2 = b1 + b1 = t +END DO +!! +ans = x * b1 - b2 / 2.0_DFP + coeff(0) +!! +END PROCEDURE LegendreEvalSum2 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO j = n - 1, 0, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); + b2 = b1; + b1 = t; +END DO +ans = b1 +END PROCEDURE LegendreGradientEvalSum1 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO j = n - 1, 0, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); + b2 = b1; + b1 = t; +END DO +ans = b1 +END PROCEDURE LegendreGradientEvalSum2 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum3 +REAL(DFP) :: t, b1, b2 +REAL(DFP) :: s, A1, A2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +s = 1.0_DFP +!! +DO j = 2 * k - 1, 1, -2 + s = j * s +END DO +!! +DO j = n - k, 0, -1 + i = REAL(j, KIND=DFP) + A1 = (2 * i + 2 * k + 1) / (i + 1) * x; + A2 = -(i + 2 * k + 1) / (i + 2); + t = A1 * b1 + A2 * b2 + coeff(j + k); + b2 = b1; + b1 = t; +END DO +ans = s * b1 +END PROCEDURE LegendreGradientEvalSum3 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum4 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2, A1 +REAL(DFP) :: s, A2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +s = 1.0_DFP +!! +DO j = 2 * k - 1, 1, -2 + s = j * s +END DO +!! +DO j = n - k, 0, -1 + i = REAL(j, KIND=DFP) + A1 = (2 * i + 2 * k + 1) / (i + 1) * x; + A2 = -(i + 2 * k + 1) / (i + 2); + t = A1 * b1 + A2 * b2 + coeff(j + k); + b2 = b1; + b1 = t; +END DO +!! +ans = s * b1 +END PROCEDURE LegendreGradientEvalSum4 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform1 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +REAL(DFP) :: rn +!! +nrmsqr = LegendreNormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP / rn +END IF +!! +PP = LegendreEvalAll(n=n, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / nrmsqr(jj) +END DO +!! +END PROCEDURE LegendreTransform1 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform2 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +REAL(DFP) :: rn +!! +nrmsqr = LegendreNormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP / rn +END IF +!! +PP = LegendreEvalAll(n=n, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / nrmsqr(jj) + END DO +END DO +!! +END PROCEDURE LegendreTransform2 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii +!! +CALL LegendreQuadrature(n=n + 1, pt=pt, wt=wt,& + & quadType=quadType) +!! +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO +!! +ans = LegendreTransform(n=n, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) +!! +END PROCEDURE LegendreTransform3 + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreInvTransform1 +ans = LegendreEvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE LegendreInvTransform1 + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreInvTransform2 +ans = LegendreEvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE LegendreInvTransform2 + +!---------------------------------------------------------------------------- +! LegendreGradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientCoeff1 +ans = UltrasphericalGradientCoeff(n=n, lambda=0.5_DFP, coeff=coeff) +END PROCEDURE LegendreGradientCoeff1 + +!---------------------------------------------------------------------------- +! LegendreDMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreDMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL LegendreDMatrixGL2(n=n, x=x, D=ans) +CASE (Gauss) + CALL LegendreDMatrixG2(n=n, x=x, D=ans) +END SELECT +END PROCEDURE LegendreDMatrix1 + +!---------------------------------------------------------------------------- +! LegendreDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixGL(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj + !! + rn = REAL(n, KIND=DFP) + !! + J = LegendreEval(n=n, x=x) + !! + D = 0.0_DFP + D(0, 0) = 0.125_DFP * rn * (rn + 1.0_DFP) + D(n, n) = -D(0, 0) + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! +END SUBROUTINE LegendreDMatrixGL + +!---------------------------------------------------------------------------- +! LegendreDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixGL2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = INT(n / 2) + rn = REAL(n, KIND=DFP) + !! + J = LegendreEval(n=n, x=x) + D = 0.0_DFP + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE LegendreDMatrixGL2 + +!---------------------------------------------------------------------------- +! LegendreDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixG(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = LegendreGradientEval(n=n + 1, x=x) + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = x(ii) / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO +!! +END SUBROUTINE LegendreDMatrixG + +!---------------------------------------------------------------------------- +! LegendreDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixG2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! internal variables + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj, nb2 + !! + !! main + !! + nb2 = INT(n / 2) + D = 0.0_DFP + !! + J = LegendreGradientEval(n=n + 1, x=x) + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE LegendreDMatrixG2 + +!---------------------------------------------------------------------------- +! LegendreDMatEvenOdd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreDMatEvenOdd1 +CALL UltrasphericalDMatEvenOdd(n=n, D=D, o=o, e=e) +END PROCEDURE LegendreDMatEvenOdd1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..ba2d7102b --- /dev/null +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -0,0 +1,1404 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(LineInterpolationUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! RefElemDomain_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Line +ans = "BIUNIT" +END PROCEDURE RefElemDomain_Line + +!---------------------------------------------------------------------------- +! QuadratureNumber_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Line +SELECT CASE (quadType) +CASE (GaussLegendre, GaussChebyshev, GaussJacobi, GaussUltraspherical) + ans = 1_I4B + INT(order / 2, kind=I4B) +CASE DEFAULT + ans = 2_I4B + INT(order / 2, kind=I4B) +END SELECT +END PROCEDURE QuadratureNumber_Line + +!---------------------------------------------------------------------------- +! ToVEFC_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ToVEFC_Line +REAL(DFP) :: t1 +INTEGER(I4B) :: np +np = SIZE(pt) +t1 = pt(np) +IF (np .GT. 2) THEN + pt(3:np) = pt(2:np - 1) + pt(2) = t1 +END IF +END PROCEDURE ToVEFC_Line + +!---------------------------------------------------------------------------- +! LagrangeDegree_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Line +INTEGER(I4B) :: ii, n +n = LagrangeDOF_Line(order=order) +ALLOCATE (ans(n, 1)) +DO ii = 1, n + ans(ii, 1) = ii - 1 +END DO +END PROCEDURE LagrangeDegree_Line + +!---------------------------------------------------------------------------- +! LagrangeDOF_Point +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Point +ans = 1_I4B +END PROCEDURE LagrangeDOF_Point + +!---------------------------------------------------------------------------- +! LagrangeDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Line +ans = order + 1 +END PROCEDURE LagrangeDOF_Line + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Line +ans = order - 1_I4B +END PROCEDURE LagrangeInDOF_Line + +!---------------------------------------------------------------------------- +! GetTotalDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Line +ans = order + 1 +END PROCEDURE GetTotalDOF_Line + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Line +ans = order - 1_I4B +END PROCEDURE GetTotalInDOF_Line + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line1 +INTEGER(I4B) :: n, ii +REAL(DFP) :: avar +IF (order .LE. 1_I4B) THEN + ALLOCATE (ans(0)) + RETURN +END IF +n = LagrangeInDOF_Line(order=order) +ALLOCATE (ans(n)) +avar = (xij(2) - xij(1)) / order +DO ii = 1, n + ans(ii) = xij(1) + ii * avar +END DO +END PROCEDURE EquidistanceInPoint_Line1 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line2 +INTEGER(I4B) :: n, ii, nsd +REAL(DFP) :: x0(3, 2) +REAL(DFP) :: avar(3) +IF (order .LE. 1_I4B) THEN + ALLOCATE (ans(0, 0)) + RETURN +END IF +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + x0(1:nsd, 1) = xij(1:nsd, 1) + x0(1:nsd, 2) = xij(1:nsd, 2) +ELSE + nsd = 1_I4B + x0(1:nsd, 1) = [-1.0] + x0(1:nsd, 2) = [1.0] +END IF +n = LagrangeInDOF_Line(order=order) +ALLOCATE (ans(nsd, n)) +avar(1:nsd) = (x0(1:nsd, 2) - x0(1:nsd, 1)) / order +DO ii = 1, n + ans(1:nsd, ii) = x0(1:nsd, 1) + ii * avar(1:nsd) +END DO +END PROCEDURE EquidistanceInPoint_Line2 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line1 +CALL Reallocate(ans, order + 1) +IF (order .EQ. 0_I4B) THEN + ans(1) = 0.5_DFP * (xij(1) + xij(2)) + RETURN +END IF +ans(1) = xij(1) +ans(2) = xij(2) +IF (order .GE. 2) THEN + ans(3:) = EquidistanceInPoint_Line(order=order, xij=xij) +END IF +END PROCEDURE EquidistancePoint_Line1 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line2 +INTEGER(I4B) :: nsd + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + CALL Reallocate(ans, nsd, order + 1) + IF (order .EQ. 0_I4B) THEN + ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) + RETURN + END IF + ans(1:nsd, 1) = xij(1:nsd, 1) + ans(1:nsd, 2) = xij(1:nsd, 2) +ELSE + nsd = 1_I4B + CALL Reallocate(ans, nsd, order + 1) + IF (order .EQ. 0_I4B) THEN + ans(1:nsd, 1) = 0.0_DFP + RETURN + END IF + ans(1:nsd, 1) = [-1.0] + ans(1:nsd, 2) = [1.0] +END IF +IF (order .GE. 2) THEN + ans(1:nsd, 3:) = EquidistanceInPoint_Line(order=order, xij=xij) +END IF +END PROCEDURE EquidistancePoint_Line2 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line1 +CHARACTER(20) :: astr +INTEGER(I4B) :: nsd, ii +REAL(DFP) :: temp(order + 1), t1 + +IF (order .EQ. 0_I4B) THEN + IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + CALL Reallocate(ans, nsd, 1) + ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) + ELSE + CALL Reallocate(ans, 1, 1) + ans = 0.0_DFP + END IF + RETURN +END IF + +astr = TRIM(UpperCase(layout)) + +SELECT CASE (ipType) + +CASE (Equidistance) + ans = EquidistancePoint_Line(xij=xij, order=order) + IF (astr .EQ. "INCREASING") THEN + DO ii = 1, SIZE(ans, 1) + ans(ii, :) = SORT(ans(ii, :)) + END DO + END IF + RETURN +CASE (GaussLegendre) + CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=Gauss) +CASE (GaussLegendreLobatto) + CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=GaussLobatto) + IF (layout .EQ. "VEFC") THEN + t1 = temp(order + 1) + IF (order .GE. 2) THEN + temp(3:) = temp(2:order) + END IF + temp(2) = t1 + END IF + +CASE (GaussChebyshev) + CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=Gauss) + +CASE (GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=GaussLobatto) + IF (layout .EQ. "VEFC") THEN + t1 = temp(order + 1) + IF (order .GE. 2) THEN + temp(3:) = temp(2:order) + END IF + temp(2) = t1 + END IF + +CASE (GaussJacobi) + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL ErrorMsg(& + & msg="alpha and beta should be present for ipType=GaussJacobi", & + & file=__FILE__, & + & routine="InterpolationPoint_Line1", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL JacobiQuadrature( & + & n=order + 1, & + & pt=temp, & + & quadType=Gauss, & + & alpha=alpha, & + & beta=beta) + +CASE (GaussJacobiLobatto) + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL ErrorMsg(& + & msg="alpha and beta should be present for ipType=GaussJacobi", & + & file=__FILE__, & + & routine="InterpolationPoint_Line1", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL JacobiQuadrature( & + & n=order + 1, & + & pt=temp, & + & quadType=GaussLobatto, & + & alpha=alpha, & + & beta=beta) + + IF (layout .EQ. "VEFC") THEN + t1 = temp(order + 1) + IF (order .GE. 2) THEN + temp(3:) = temp(2:order) + END IF + temp(2) = t1 + END IF + +CASE (GaussUltraspherical) + IF (.NOT. PRESENT(lambda)) THEN + CALL ErrorMsg(& + & msg="lambda should be present for ipType=GaussUltraspherical", & + & file=__FILE__, & + & routine="InterpolationPoint_Line1", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL UltrasphericalQuadrature( & + & n=order + 1, & + & pt=temp, & + & quadType=Gauss, & + & lambda=lambda) + +CASE (GaussUltrasphericalLobatto) + IF (.NOT. PRESENT(lambda)) THEN + CALL ErrorMsg(& + & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", & + & file=__FILE__, & + & routine="InterpolationPoint_Line1", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL UltrasphericalQuadrature( & + & n=order + 1, & + & pt=temp, & + & quadType=GaussLobatto, & + & lambda=lambda) + + IF (layout .EQ. "VEFC") THEN + t1 = temp(order + 1) + IF (order .GE. 2) THEN + temp(3:) = temp(2:order) + END IF + temp(2) = t1 + END IF + +CASE DEFAULT + CALL ErrorMsg(& + & msg="Unknown iptype", & + & file=__FILE__, & + & routine="InterpolationPoint_Line1", & + & line=__LINE__, & + & unitno=stderr) +END SELECT + +IF (ipType .NE. Equidistance) THEN + IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + CALL Reallocate(ans, nsd, order + 1) + ans = FromBiunitLine2Segment(xin=temp, x1=xij(:, 1), & + & x2=xij(:, 2)) + ELSE + CALL Reallocate(ans, 1, order + 1) + ans(1, :) = temp + END IF +END IF +END PROCEDURE InterpolationPoint_Line1 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line2 +CHARACTER(20) :: astr +REAL(DFP) :: t1 + +IF (order .EQ. 0_I4B) THEN + ans = [0.5_DFP * (xij(1) + xij(2))] + RETURN +END IF + +CALL Reallocate(ans, order + 1) +astr = TRIM(UpperCase(layout)) + +SELECT CASE (ipType) +CASE (Equidistance) + ans = EquidistancePoint_Line(xij=xij, order=order) + IF (astr .EQ. "INCREASING") ans = SORT(ans) + RETURN + +CASE (GaussLegendre) + CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=Gauss) + +CASE (GaussLegendreLobatto) + CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=GaussLobatto) + IF (layout .EQ. "VEFC") THEN + t1 = ans(order + 1) + IF (order .GE. 2) THEN + ans(3:) = ans(2:order) + END IF + ans(2) = t1 + END IF + +CASE (GaussChebyshev) + CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=Gauss) + +CASE (GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=GaussLobatto) + IF (layout .EQ. "VEFC") THEN + t1 = ans(order + 1) + IF (order .GE. 2) THEN + ans(3:) = ans(2:order) + END IF + ans(2) = t1 + END IF + +CASE (GaussJacobi) + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL ErrorMsg(& + & msg="alpha and beta should be present for ipType=GaussJacobi", & + & file=__FILE__, & + & routine="InterpolationPoint_Line2", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL JacobiQuadrature( & + & n=order + 1, & + & pt=ans, & + & quadType=Gauss, & + & alpha=alpha, & + & beta=beta) + +CASE (GaussJacobiLobatto) + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL ErrorMsg(& + & msg="alpha and beta should be present for ipType=GaussJacobiLobatto", & + & file=__FILE__, & + & routine="InterpolationPoint_Line2", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL JacobiQuadrature( & + & n=order + 1, & + & pt=ans, & + & quadType=GaussLobatto, & + & alpha=alpha, & + & beta=beta) + + IF (layout .EQ. "VEFC") THEN + t1 = ans(order + 1) + IF (order .GE. 2) THEN + ans(3:) = ans(2:order) + END IF + ans(2) = t1 + END IF + +CASE (GaussUltraspherical) + IF (.NOT. PRESENT(lambda)) THEN + CALL ErrorMsg(& + & msg="lambda should be present for ipType=GaussUltraspherical", & + & file=__FILE__, & + & routine="InterpolationPoint_Line2", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL UltrasphericalQuadrature( & + & n=order + 1, & + & pt=ans, & + & quadType=Gauss, & + & lambda=lambda) + +CASE (GaussUltrasphericalLobatto) + IF (.NOT. PRESENT(lambda)) THEN + CALL ErrorMsg(& + & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", & + & file=__FILE__, & + & routine="InterpolationPoint_Line2", & + & line=__LINE__, & + & unitno=stderr) + END IF + + CALL UltrasphericalQuadrature( & + & n=order + 1, & + & pt=ans, & + & quadType=GaussLobatto, & + & lambda=lambda) + + IF (layout .EQ. "VEFC") THEN + t1 = ans(order + 1) + IF (order .GE. 2) THEN + ans(3:) = ans(2:order) + END IF + ans(2) = t1 + END IF + +CASE DEFAULT + CALL ErrorMsg(& + & msg="Unknown iptype", & + & file=__FILE__, & + & routine="InterpolationPoint_Line2", & + & line=__LINE__, & + & unitno=stderr) +END SELECT + +IF (ipType .NE. Equidistance) THEN + ans = FromBiunitLine2Segment(xin=ans, x1=xij(1), x2=xij(2)) +END IF +END PROCEDURE InterpolationPoint_Line2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line1 +REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +v = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) +CALL getLU(A=v, IPIV=ipiv, info=info) +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Line1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line2 +REAL(DFP) :: vtemp(SIZE(v, 1), SIZE(v, 2)) +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +vtemp = v; ipiv = 0 +CALL getLU(A=vtemp, IPIV=ipiv, info=info) +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Line2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Line3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Line4 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line5 +SELECT CASE (basisType) +CASE (Monomial) + ans = LagrangeCoeff_Line(order=order, xij=xij) +CASE DEFAULT + ans = EvalAllOrthopol(& + & n=order, & + & x=xij(1, :), & + & orthopol=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + CALL GetInvMat(ans) +END SELECT +END PROCEDURE LagrangeCoeff_Line5 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line1 +LOGICAL(LGT) :: firstCall0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) +INTEGER(I4B) :: ii, orthopol0 + +IF (SIZE(xij, 2) .NE. order + 1) THEN + CALL Errormsg(& + & msg="Size(xij, 1) .NE. order+1 ", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +orthopol0 = input(default=Monomial, option=basisType) +firstCall0 = input(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Line(& + & order=order, & + & xij=xij, & + & basisType=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + END IF + coeff0 = TRANSPOSE(coeff) +ELSE + coeff0 = TRANSPOSE(LagrangeCoeff_Line(& + & order=order, & + & xij=xij, & + & basisType=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & )) +END IF + +SELECT CASE (orthopol0) +CASE (Monomial) + xx(1, 1) = 1.0_DFP + DO ii = 1, order + xx(1, ii + 1) = xx(1, ii) * x + END DO +CASE DEFAULT + xx = EvalAllOrthopol(& + & n=order, & + & x=[x], & + & orthopol=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END SELECT + +ans = MATMUL(coeff0, xx(1, :)) + +END PROCEDURE LagrangeEvalAll_Line1 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line2 +LOGICAL(LGT) :: firstCall0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) +INTEGER(I4B) :: ii, orthopol0 + +IF (SIZE(xij, 2) .NE. order + 1) THEN + CALL Errormsg(& + & msg="Size(xij, 1) .NE. order+1 ", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +orthopol0 = Input(default=Monomial, option=basisType) +firstCall0 = Input(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Line(& + & order=order, & + & xij=xij, & + & basisType=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + END IF + coeff0 = coeff +ELSE + coeff0 = LagrangeCoeff_Line(& + & order=order, & + & xij=xij, & + & basisType=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) +END IF + +SELECT CASE (orthopol0) +CASE (Monomial) + xx(:, 1) = 1.0_DFP + DO ii = 1, order + xx(:, ii + 1) = xx(:, ii) * x(1, :) + END DO +CASE DEFAULT + xx = EvalAllOrthopol(& + & n=order, & + & x=x(1, :), & + & orthopol=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END SELECT + +ans = MATMUL(xx, coeff0) + +END PROCEDURE LagrangeEvalAll_Line2 + +!---------------------------------------------------------------------------- +! EvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisEvalAll_Line1 +INTEGER(I4B) :: ii, basisType0 +TYPE(String) :: astr +astr = UpperCase(refLine) + +IF (astr%chars() .EQ. "UNIT") THEN + CALL Errormsg(& + & msg="refLine should be BIUNIT", & + & file=__FILE__, & + & routine="BasisEvalAll_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +basisType0 = input(default=Monomial, option=basisType) +SELECT CASE (basisType0) +CASE (Monomial) + ans(1) = 1.0_DFP + DO ii = 1, order + ans(ii + 1) = ans(ii) * x + END DO +CASE DEFAULT + + IF (basisType0 .EQ. Jacobi) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL Errormsg(& + & msg="alpha and beta should be present for basisType=Jacobi", & + & file=__FILE__, & + & routine="BasisEvalAll_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + IF (basisType0 .EQ. Ultraspherical) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL Errormsg(& + & msg="lambda should be present for basisType=Ultraspherical", & + & file=__FILE__, & + & routine="BasisEvalAll_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + ans = RESHAPE(EvalAllOrthopol(& + & n=order, & + & x=[x], & + & orthopol=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda), [order + 1]) +END SELECT + +END PROCEDURE BasisEvalAll_Line1 + +!---------------------------------------------------------------------------- +! BasisGradientEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisGradientEvalAll_Line1 +INTEGER(I4B) :: ii, basisType0 +TYPE(String) :: astr +astr = UpperCase(refLine) + +IF (astr%chars() .EQ. "UNIT") THEN + CALL Errormsg(& + & msg="refLine should be BIUNIT", & + & file=__FILE__, & + & routine="BasisGradientEvalAll_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +basisType0 = input(default=Monomial, option=basisType) +SELECT CASE (basisType0) +CASE (Monomial) + ans(1) = 0.0_DFP + DO ii = 1, order + ans(ii + 1) = REAL(ii, dfp) * x**(ii - 1) + END DO +CASE DEFAULT + + IF (basisType0 .EQ. Jacobi) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL Errormsg(& + & msg="alpha and beta should be present for basisType=Jacobi", & + & file=__FILE__, & + & routine="BasisGradientEvalAll_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + IF (basisType0 .EQ. Ultraspherical) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL Errormsg(& + & msg="lambda should be present for basisType=Ultraspherical", & + & file=__FILE__, & + & routine="BasisGradientEvalAll_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + ans = RESHAPE(GradientEvalAllOrthopol(& + & n=order, & + & x=[x], & + & orthopol=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda), [order + 1]) +END SELECT + +END PROCEDURE BasisGradientEvalAll_Line1 + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisEvalAll_Line2 +INTEGER(I4B) :: ii, basisType0 +TYPE(String) :: astr +astr = UpperCase(refLine) + +IF (astr%chars() .EQ. "UNIT") THEN + CALL Errormsg(& + & msg="refLine should be BIUNIT", & + & file=__FILE__, & + & routine="BasisEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +basisType0 = input(default=Monomial, option=basisType) +SELECT CASE (basisType0) +CASE (Monomial) + ans(:, 1) = 1.0_DFP + DO ii = 1, order + ans(:, ii + 1) = ans(:, ii) * x + END DO +CASE DEFAULT + + IF (basisType0 .EQ. Jacobi) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL Errormsg(& + & msg="alpha and beta should be present for basisType=Jacobi", & + & file=__FILE__, & + & routine="BasisEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + IF (basisType0 .EQ. Ultraspherical) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL Errormsg(& + & msg="lambda should be present for basisType=Ultraspherical", & + & file=__FILE__, & + & routine="BasisEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + ans = EvalAllOrthopol(& + & n=order, & + & x=x, & + & orthopol=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END SELECT + +END PROCEDURE BasisEvalAll_Line2 + +!---------------------------------------------------------------------------- +! BasisGradientEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisGradientEvalAll_Line2 +INTEGER(I4B) :: ii, basisType0 +TYPE(String) :: astr +astr = UpperCase(refLine) + +IF (astr%chars() .EQ. "UNIT") THEN + CALL Errormsg(& + & msg="refLine should be BIUNIT", & + & file=__FILE__, & + & routine="BasisGradientEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +basisType0 = input(default=Monomial, option=basisType) +SELECT CASE (basisType0) +CASE (Monomial) + ans(:, 1) = 0.0_DFP + DO ii = 1, order + ans(:, ii + 1) = REAL(ii, dfp) * x**(ii - 1) + END DO +CASE DEFAULT + + IF (basisType0 .EQ. Jacobi) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL Errormsg(& + & msg="alpha and beta should be present for basisType=Jacobi", & + & file=__FILE__, & + & routine="BasisGradientEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + IF (basisType0 .EQ. Ultraspherical) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL Errormsg(& + & msg="lambda should be present for basisType=Ultraspherical", & + & file=__FILE__, & + & routine="BasisGradientEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + END IF + + ans = GradientEvalAllOrthopol(& + & n=order, & + & x=x, & + & orthopol=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END SELECT + +END PROCEDURE BasisGradientEvalAll_Line2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line1 +INTEGER(I4B) :: nips(1) +nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) +ans = QuadraturePoint_Line3(nips=nips, quadType=quadType, & +& layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE QuadraturePoint_Line1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line2 +ans = QuadraturePoint_Line1(& + & order=order, & + & quadType=quadType, & + & layout=layout, & + & xij=RESHAPE(xij, [1, 2]), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END PROCEDURE QuadraturePoint_Line2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line4 +ans = QuadraturePoint_Line3(& + & nips=nips, & + & quadType=quadType, & + & layout=layout, & + & xij=RESHAPE(xij, [1, 2]), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END PROCEDURE QuadraturePoint_Line4 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line3 +CHARACTER(20) :: astr +INTEGER(I4B) :: np, nsd, ii +REAL(DFP) :: pt(nips(1)), wt(nips(1)) +REAL(DFP) :: t1 +LOGICAL(LGT) :: changeLayout + +IF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL ErrorMsg(& + & msg="alpha and beta should be present for quadType=GaussJacobi", & + & file=__FILE__, & + & routine="QuadraturePoint_Line3", & + & line=__LINE__, & + & unitno=stderr) + END IF + RETURN +ELSEIF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL ErrorMsg(& + & msg="lambda should be present for quadType=GaussUltraspherical", & + & file=__FILE__, & + & routine="QuadraturePoint_Line3", & + & line=__LINE__, & + & unitno=stderr) + END IF + RETURN +END IF + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 1 +END IF + +astr = TRIM(UpperCase(layout)) +np = nips(1) +CALL Reallocate(ans, nsd + 1_I4B, np) +changeLayout = .FALSE. + +SELECT CASE (quadType) + +CASE (GaussLegendre) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss) + +CASE (GaussLegendreRadauLeft) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) + +CASE (GaussLegendreRadauRight) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) + +CASE (GaussLegendreLobatto) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +CASE (GaussChebyshev) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=Gauss) + +CASE (GaussChebyshevRadauLeft) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) + +CASE (GaussChebyshevRadauRight) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) + +CASE (GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +CASE (GaussJacobi) + CALL JacobiQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=Gauss, & + & alpha=alpha, & + & beta=beta) + +CASE (GaussJacobiRadauLeft) + CALL JacobiQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=GaussRadauLeft, & + & alpha=alpha, & + & beta=beta) + +CASE (GaussJacobiRadauRight) + CALL JacobiQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=GaussRadauRight, & + & alpha=alpha, & + & beta=beta) + +CASE (GaussJacobiLobatto) + CALL JacobiQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=GaussLobatto, & + & alpha=alpha, & + & beta=beta) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +CASE (GaussUltraspherical) + CALL UltrasphericalQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=Gauss, & + & lambda=lambda) + +CASE (GaussUltrasphericalRadauLeft) + CALL UltrasphericalQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=GaussRadauLeft, & + & lambda=lambda) + +CASE (GaussUltrasphericalRadauRight) + CALL UltrasphericalQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=GaussRadauRight, & + & lambda=lambda) + +CASE (GaussUltrasphericalLobatto) + CALL UltrasphericalQuadrature( & + & n=np, & + & pt=pt, & + & wt=wt, & + & quadType=GaussLobatto, & + & lambda=lambda) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +CASE DEFAULT + CALL ErrorMsg(& + & msg="Unknown iptype", & + & file=__FILE__, & + & routine="QuadraturePoint_Line3", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +IF (changeLayout) THEN + CALL ToVEFC_Line(pt) + CALL ToVEFC_Line(wt) +END IF + +IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromBiunitLine2Segment( & + & xin=pt, & + & x1=xij(:, 1), & + & x2=xij(:, 2)) + ans(nsd + 1, :) = wt * NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP +ELSE + ans(1, :) = pt + ans(nsd + 1, :) = wt +END IF +END PROCEDURE QuadraturePoint_Line3 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Line1 +LOGICAL(LGT) :: firstCall0 +REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1) +INTEGER(I4B) :: ii, orthopol0 + +orthopol0 = input(default=Monomial, option=basisType) +firstCall0 = input(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Line(& + & order=order, & + & xij=xij, & + & basisType=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + END IF + coeff0 = coeff +ELSE + coeff0 = LagrangeCoeff_Line(& + & order=order, & + & xij=xij, & + & basisType=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) +END IF + +SELECT CASE (orthopol0) +CASE (Monomial) + + IF (SIZE(xij, 2) .NE. order + 1) THEN + CALL Errormsg(& + & msg="size(xij, 2) is not same as order+1", & + & file=__FILE__, & + & routine="LagrangeGradientEvalAll_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + + DO ii = 0, order + xx(:, ii + 1) = REAL(ii, kind=DFP) * x(1, :)**(MAX(ii - 1_I4B, 0_I4B)) + END DO + +CASE DEFAULT + xx = GradientEvalAllOrthopol(& + & n=order, & + & x=x(1, :), & + & orthopol=orthopol0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END SELECT + +ans(:, :, 1) = MATMUL(xx, coeff0) + +END PROCEDURE LagrangeGradientEvalAll_Line1 + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Line1 +TYPE(String) :: astr +astr = UpperCase(refLine) + +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans = EvalAllOrthopol( & + & n=order, & + & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & + & orthopol=Lobatto) +CASE ("BIUNIT") + ans = EvalAllOrthopol( & + & n=order, & + & x=xij(1, :), & + & orthopol=Lobatto) +CASE DEFAULT + ans = 0.0_DFP + CALL Errormsg(& + & msg="No case found for refline.", & + & file=__FILE__, & + & routine="HeirarchicalBasis_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +END PROCEDURE HeirarchicalBasis_Line1 + +!---------------------------------------------------------------------------- +! HeirarchicalGradientBasis_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalGradientBasis_Line1 +TYPE(String) :: astr +astr = UpperCase(refLine) + +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans(:, :, 1) = GradientEvalAllOrthopol( & + & n=order, & + & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & + & orthopol=Lobatto) + ans = ans * 2.0_DFP +CASE ("BIUNIT") + ans(:, :, 1) = GradientEvalAllOrthopol( & + & n=order, & + & x=xij(1, :), & + & orthopol=Lobatto) +CASE DEFAULT + ans = 0.0_DFP + CALL Errormsg(& + & msg="No case found for refline.", & + & file=__FILE__, & + & routine="HeirarchicalGradientBasis_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +END PROCEDURE HeirarchicalGradientBasis_Line1 + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Line1 +INTEGER(I4B) :: ii +TYPE(String) :: astr + +ans = 0.0_DFP +astr = UpperCase(refLine) + +IF (basisType .EQ. Jacobi) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL Errormsg(& + & msg="alpha and beta should be present for basisType=Jacobi", & + & file=__FILE__, & + & routine="BasisEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF +END IF + +IF (basisType .EQ. Ultraspherical) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL Errormsg(& + & msg="lambda should be present for basisType=Ultraspherical", & + & file=__FILE__, & + & routine="BasisEvalAll_Line2", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF +END IF + +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans = EvalAllOrthopol(& + & n=order, & + & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & + & orthopol=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE ("BIUNIT") + ans = EvalAllOrthopol(& + & n=order, & + & x=xij(1, :), & + & orthopol=basisType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +CASE DEFAULT + ans = 0.0_DFP + CALL Errormsg(& + & msg="No case found for refLine.", & + & file=__FILE__, & + & routine="OrthogonalBasis_Line1()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +END PROCEDURE OrthogonalBasis_Line1 + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Line1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Line1 +TYPE(String) :: astr +astr = UpperCase(refLine) + +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans(:, :, 1) = GradientEvalAllOrthopol( & + & n=order, & + & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & + & orthopol=basisType) + ans = ans * 2.0_DFP +CASE ("BIUNIT") + ans(:, :, 1) = GradientEvalAllOrthopol( & + & n=order, & + & x=xij(1, :), & + & orthopol=basisType) +CASE DEFAULT + ans = 0.0_DFP + CALL Errormsg(& + & msg="No case found for refline.", & + & file=__FILE__, & + & routine=" OrthogonalBasisGradient_Line1", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT +END PROCEDURE OrthogonalBasisGradient_Line1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..2278c25d1 --- /dev/null +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -0,0 +1,453 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(LobattoPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! LobattoLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoLeadingCoeff +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP +CASE (1) + ans = -0.5_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + m = LegendreLeadingCoeff(n=n) + ans = m * avar +END SELECT +END PROCEDURE LobattoLeadingCoeff + +!---------------------------------------------------------------------------- +! LobattoNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoNormSqr +REAL(DFP) :: m, a1, a2 +SELECT CASE (n) +CASE (0, 1) + ans = 2.0_DFP / 3.0_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + a1 = (2.0_DFP * m + 1) + a2 = (2.0_DFP * m + 5) + ans = 2.0_DFP / a1 / a2 +END SELECT +END PROCEDURE LobattoNormSqr + +!---------------------------------------------------------------------------- +! LobattoZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoZeros +SELECT CASE (n) +CASE (1) + ans(1) = 1.0_DFP +CASE (2) + ans(1) = -1.0_DFP + ans(2) = 1.0_DFP +CASE DEFAULT + ans(1) = -1.0_DFP + ans(n) = 1.0_DFP + ans(2:n - 1) = JacobiZeros(alpha=1.0_DFP, beta=1.0_DFP, n=n - 2_I4B) +END SELECT +END PROCEDURE LobattoZeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEval1 +REAL(DFP) :: avar, m +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE LobattoEval1 + +!---------------------------------------------------------------------------- +! LobattoEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEval2 +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE LobattoEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEvalAll1 +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans(2 + ii) = avar * (p(ii + 2) - p(ii)) + END DO +END SELECT +END PROCEDURE LobattoEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEvalAll2 +REAL(DFP) :: avar, m +REAL(DFP) :: p(SIZE(x), n + 1) +INTEGER(I4B) :: ii +SELECT CASE (n) +CASE (0) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) + END DO +END SELECT +END PROCEDURE LobattoEvalAll2 + +!---------------------------------------------------------------------------- +! LobattoKernelEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoKernelEvalAll1 +INTEGER(I4B) :: nrow, ncol +CALL LobattoKernelEvalAll1_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LobattoKernelEvalAll1 + +!---------------------------------------------------------------------------- +! LobattoKernelEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoKernelEvalAll1_ +REAL(DFP) :: m, avar +INTEGER(I4B) :: ii + +CALL UltrasphericalEvalAll_(n=n, x=x, lambda=1.5_DFP, ans=ans, nrow=nrow, & + ncol=ncol) + +DO ii = 0, n + m = REAL(ii, KIND=DFP) + avar = -SQRT(8.0_DFP*(2.0_DFP*m+3.0_DFP))/(m+1.0_DFP)/(m+2.0_DFP) + ans(1:nrow, ii) = avar * ans(1:nrow, ii) +END DO +END PROCEDURE LobattoKernelEvalAll1_ + +!---------------------------------------------------------------------------- +! LobattoKernelGradientEvalAll1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoKernelGradientEvalAll1 +REAL(DFP) :: m, avar +INTEGER(I4B) :: ii + +ans = UltrasphericalGradientEvalAll(n=n, x=x, lambda=1.5_DFP) +DO ii = 0, n + m = REAL(ii, KIND=DFP) + avar = -SQRT(8.0_DFP*(2.0_DFP*m+3.0_DFP))/(m+1.0_DFP)/(m+2.0_DFP) + ans(:, ii) = avar * ans(:, ii) +END DO +END PROCEDURE LobattoKernelGradientEvalAll1 + +!---------------------------------------------------------------------------- +! LobattoKernelGradientEvalAll1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoKernelGradientEvalAll1_ +REAL(DFP) :: m, avar +INTEGER(I4B) :: ii + +CALL UltrasphericalGradientEvalAll_(n=n, x=x, lambda=1.5_DFP, nrow=nrow, & + ncol=ncol, ans=ans) +DO CONCURRENT(ii=0:n) + m = REAL(ii, KIND=DFP) + avar = -SQRT(8.0_DFP*(2.0_DFP*m+3.0_DFP))/(m+1.0_DFP)/(m+2.0_DFP) + ans(1:nrow, ii) = avar * ans(1:nrow, ii) +END DO +END PROCEDURE LobattoKernelGradientEvalAll1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoMonomialExpansionAll +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1, n + 1) +INTEGER(I4B) :: ii +!! +ans = 0.0_DFP +!! +SELECT CASE (n) +CASE (0) + ans(1, 1) = 0.5_DFP +CASE (1) + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP +CASE DEFAULT + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP + !! + p = LegendreMonomialExpansionAll(n=n) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans(:, ii + 2) = avar * (p(:, ii + 2) - p(:, ii)) + END DO + !! +END SELECT +END PROCEDURE LobattoMonomialExpansionAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoMonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = LobattoMonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE LobattoMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEvalAll1 +REAL(DFP) :: p(n), avar, m +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = -0.5_DFP +CASE (1) + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP +CASE DEFAULT + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans(ii + 2) = avar * p(ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE LobattoGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEvalAll2 +REAL(DFP) :: p(SIZE(x), n), avar, m +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(:, 1) = -0.5_DFP +CASE (1) + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP +CASE DEFAULT + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans(:, ii + 2) = avar * p(:, ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE LobattoGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEval1 +REAL(DFP) :: p, avar, m + !! +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + !! + p = LegendreEval(n=n - 1_I4B, x=x) + m = REAL(n - 2, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans = avar * p +END SELECT +END PROCEDURE LobattoGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEval2 +REAL(DFP) :: p(SIZE(x)), avar, m + !! +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + !! + p = LegendreEval(n=n - 1_I4B, x=x) + m = REAL(n - 2, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans = avar * p +END SELECT +END PROCEDURE LobattoGradientEval2 + +!---------------------------------------------------------------------------- +! LobattoMassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoMassMatrix +INTEGER(I4B) :: ii +REAL(DFP) :: m +!! +ans = 0.0_DFP +!! +DO ii = 1, n + 1 + ans(ii, ii) = LobattoNormSQR(n=ii - 1_I4B) +END DO +!! +IF (n .EQ. 0_I4B) RETURN +!! +ans(1, 2) = 1.0_DFP / 3.0_DFP +ans(2, 1) = ans(1, 2) +!! +IF (n .EQ. 1_I4B) RETURN +!! +ans(1, 3) = -1.0_DFP / SQRT(6.0_DFP) +ans(3, 1) = ans(1, 3) +ans(2, 3) = ans(1, 3) +ans(3, 2) = ans(2, 3) +!! +IF (n .EQ. 2_I4B) RETURN +!! +ans(1, 4) = 1.0_DFP / SQRT(90.0_DFP) +ans(4, 1) = ans(1, 4) +ans(2, 4) = -ans(1, 4) +ans(4, 2) = ans(2, 4) +!! +IF (n .EQ. 3_I4B) RETURN +!! +DO ii = 3, n + 1 + !! + m = REAL(ii - 3, DFP) + !! + IF (ii + 2 .LE. n + 1) THEN + ans(ii, ii + 2) = -1.0_DFP / (2.0_DFP * m + 5.0_DFP) / & + & SQRT((2.0_DFP * m + 7.0_DFP) * (2.0_DFP * m + 3.0_DFP)) + !! + ans(ii + 2, ii) = ans(ii, ii + 2) + END IF + !! +END DO +!! +END PROCEDURE LobattoMassMatrix + +!---------------------------------------------------------------------------- +! LobattoStiffnessMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoStiffnessMatrix +INTEGER(I4B) :: ii + +ans = 0.0_DFP + +DO ii = 1, n + 1 + ans(ii, ii) = 1.0_DFP +END DO + +ans(1, 1) = 0.5_DFP + +IF (n .EQ. 0_I4B) RETURN + +ans(2, 2) = 0.5_DFP +ans(1, 2) = -0.5_DFP +ans(2, 1) = ans(1, 2) + +END PROCEDURE LobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..207d2760c --- /dev/null +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -0,0 +1,159 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(OrthogonalPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Clenshaw_1 +REAL(DFP), DIMENSION(0:SIZE(c)) :: u +INTEGER(I4B) :: ii, n +REAL(DFP) :: y00, ym10 + +y00 = INPUT(default=1.0_DFP, option=y0) +ym10 = INPUT(default=0.0_DFP, option=ym1) + +!! The size of c, alpha, beta should be same n+1: 0 to n +!! The size of u is n+2, 0 to n+1 +n = SIZE(c) - 1 +u(n) = c(n) +u(n + 1) = 0.0_DFP +DO ii = n - 1, 0, -1 + u(ii) = (x - alpha(ii)) * u(ii + 1) - beta(ii + 1) * u(ii + 2) + c(ii) +END DO +ans = u(0) * y00 - beta(0) * u(1) * ym10 +END PROCEDURE Clenshaw_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Clenshaw_2 +REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c)) :: u +INTEGER(I4B) :: ii, n +REAL(DFP) :: y00, ym10 +y00 = INPUT(default=1.0_DFP, option=y0) +ym10 = INPUT(default=0.0_DFP, option=ym1) +!! The size of c, alpha, beta should be same n+1: 0 to n +!! The size of u is n+2, 0 to n+1 +n = SIZE(c) - 1 +u(:, n) = c(n) +u(:, n + 1) = 0.0_DFP +DO ii = n - 1, 0, -1 + u(:, ii) = (x - alpha(ii)) * u(:, ii + 1) & + & - beta(ii + 1) * u(:, ii + 2) + c(ii) +END DO +ans = u(:, 0) * y00 - beta(0) * u(:, 1) * ym10 +END PROCEDURE Clenshaw_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ChebClenshaw_1 +REAL(DFP), DIMENSION(0:SIZE(c) + 2) :: u +INTEGER(I4B) :: ii, n +!! The size of c is n+1: 0 to n +!! The size of u is n+3, 0 to n+2 +n = SIZE(c) - 1 +u(n) = c(n) +u(n + 1) = 0.0_DFP +u(n + 2) = 0.0_DFP +DO ii = n - 1, 0, -1 + u(ii) = 2.0_DFP * x * u(ii + 1) - u(ii + 2) + c(ii) +END DO +ans = 0.5_DFP * (u(0) - u(2)) +END PROCEDURE ChebClenshaw_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ChebClenshaw_2 +REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c) + 2) :: u +INTEGER(I4B) :: ii, n +!! The size of c is n+1: 0 to n +!! The size of u is n+3, 0 to n+2 +n = SIZE(c) - 1 +u(:, n) = c(n) +u(:, n + 1) = 0.0_DFP +u(:, n + 2) = 0.0_DFP +DO ii = n - 1, 0, -1 + u(:, ii) = 2.0_DFP * x * u(:, ii + 1) - u(:, ii + 2) + c(ii) +END DO +ans = 0.5_DFP * (u(:, 0) - u(:, 2)) +END PROCEDURE ChebClenshaw_2 + +!---------------------------------------------------------------------------- +! JacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiMatrix_1 +INTEGER(I4B) :: n +n = SIZE(alphaCoeff) +D(1:n) = alphaCoeff(0:n - 1) +E(1:n - 1) = SQRT(betaCoeff(1:n - 1)) +END PROCEDURE JacobiMatrix_1 + +!---------------------------------------------------------------------------- +! EvalAllOrthopol +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EvalAllOrthopol +SELECT CASE (orthopol) +CASE (Jacobi) + ans = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +CASE (Ultraspherical) + ans = UltraSphericalEvalAll(n=n, lambda=lambda, x=x) +CASE (Legendre) + ans = LegendreEvalAll(n=n, x=x) +CASE (Chebyshev) + ans = Chebyshev1EvalAll(n=n, x=x) +CASE (Lobatto) + ans = LobattoEvalAll(n=n, x=x) +CASE (UnscaledLobatto) + ans = UnscaledLobattoEvalAll(n=n, x=x) +END SELECT +END PROCEDURE EvalAllOrthopol + +!---------------------------------------------------------------------------- +! GradientEvalAllOrthopol +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GradientEvalAllOrthopol +SELECT CASE (orthopol) +CASE (Jacobi) + ans = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) +CASE (Ultraspherical) + ans = UltraSphericalGradientEvalAll(n=n, lambda=lambda, x=x) +CASE (Legendre) + ans = LegendreGradientEvalAll(n=n, x=x) +CASE (Chebyshev) + ans = Chebyshev1GradientEvalAll(n=n, x=x) +CASE (Lobatto) + ans = LobattoGradientEvalAll(n=n, x=x) +CASE (UnscaledLobatto) + ans = UnscaledLobattoGradientEvalAll(n=n, x=x) +END SELECT +END PROCEDURE GradientEvalAllOrthopol + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..89c49dfe6 --- /dev/null +++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 @@ -0,0 +1,285 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(PrismInterpolationUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeConnectivity_Prism +CALL GetEdgeConnectivity_Prism(con=ans) +END PROCEDURE EdgeConnectivity_Prism + +!---------------------------------------------------------------------------- +! FacetConnectivity_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetConnectivity_Prism +!! ans +ans(:, 1) = [3, Triangle3, 1, 3, 2, 0] +ans(:, 2) = [4, Quadrangle4, 2, 3, 6, 5] +ans(:, 3) = [4, Quadrangle4, 1, 2, 5, 4] +ans(:, 4) = [4, Quadrangle4, 1, 4, 6, 3] +ans(:, 5) = [3, Triangle3, 4, 5, 6, 0] +END PROCEDURE FacetConnectivity_Prism + +!---------------------------------------------------------------------------- +! RefElemDomain_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Prism +!FIX: Implement RefElemDomain_Prism +CALL Errormsg(& + & msg="[WORK IN PROGRESS] We are working on it", & + & file=__FILE__, & + & line=__LINE__,& + & routine="RefElemDomain_Prism()", & + & unitno=stderr) +END PROCEDURE RefElemDomain_Prism + +!---------------------------------------------------------------------------- +! LagrangeDegree_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Prism + +!ISSUE: #164 Implement LagrangeDegree_Prism + +END PROCEDURE LagrangeDegree_Prism + +!---------------------------------------------------------------------------- +! LagrangeDOF_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Prism +ans = (order + 1)**2 * (order + 2) / 2_I4B +END PROCEDURE LagrangeDOF_Prism + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Prism +ans = (order - 1)**2 * (order - 2) / 2_I4B +END PROCEDURE LagrangeInDOF_Prism + +!---------------------------------------------------------------------------- +! GetTotalDOF_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Prism +ans = (order + 1)**2 * (order + 2) / 2_I4B +END PROCEDURE GetTotalDOF_Prism + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Prism +ans = (order - 1)**2 * (order - 2) / 2_I4B +END PROCEDURE GetTotalInDOF_Prism + +!---------------------------------------------------------------------------- +! EquidistancePoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Prism +! nodecoord( :, 1 ) = [0,0,-1] +! nodecoord( :, 2 ) = [1,0,-1] +! nodecoord( :, 3 ) = [0,1,-1] +! nodecoord( :, 4 ) = [0,0,1] +! nodecoord( :, 5 ) = [1,0,1] +! nodecoord( :, 6 ) = [0,1,1] +!ISSUE: #160 Implement EquidistancePoint_Prism routine +END PROCEDURE EquidistancePoint_Prism + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Prism +!FIX: Implement EquidistanceInPoint_Prism routine +END PROCEDURE EquidistanceInPoint_Prism + +!---------------------------------------------------------------------------- +! InterpolationPoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Prism +SELECT CASE (ipType) +CASE (Equidistance) + nodecoord = EquidistancePoint_Prism(xij=xij, order=order) +CASE (GaussLegendre) +CASE (GaussLegendreLobatto) +CASE (GaussChebyshev) +CASE (GaussChebyshevLobatto) +END SELECT +END PROCEDURE InterpolationPoint_Prism + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism2 +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Prism4 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Prism1 +! FIX: Implement QuadraturePoint_Prism1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="QuadraturePoint_Prism1()", & +& file=__FILE__) +END PROCEDURE QuadraturePoint_Prism1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Prism2 +! FIX: Implement QuadraturePoint_Prism2 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="QuadraturePoint_Prism2()", & +& file=__FILE__) +END PROCEDURE QuadraturePoint_Prism2 + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Prism1 +!FIX: Implement TensorQuadraturePoint_Prism1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="TensorQuadraturePoint_Prism1()", & +& file=__FILE__) +END PROCEDURE TensorQuadraturePoint_Prism1 + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Prism2 +!FIX: Implement TensorQuadraturePoint_Prism2 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="TensorQuadraturePoint_Prism2()", & +& file=__FILE__) +END PROCEDURE TensorQuadraturePoint_Prism2 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Prism1 +! FIX: Implement LagrangeEvalAll_Prism1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="LagrangeEvalAll_Prism1()", & +& file=__FILE__) +END PROCEDURE LagrangeEvalAll_Prism1 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Prism2 +! FIX: Implement LagrangeEvalAll_Prism2 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="LagrangeEvalAll_Prism2()", & +& file=__FILE__) +END PROCEDURE LagrangeEvalAll_Prism2 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Prism1 +!FIX: Implement LagrangeGradientEvalAll_Prism1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="LagrangeGradientEvalAll_Prism1()", & +& file=__FILE__) +END PROCEDURE LagrangeGradientEvalAll_Prism1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..ccbdb15b7 --- /dev/null +++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 @@ -0,0 +1,288 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This programris free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(PyramidInterpolationUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeConnectivity_Pyramid +ans(:, 1) = [1, 2] +ans(:, 2) = [1, 4] +ans(:, 3) = [1, 5] +ans(:, 4) = [2, 3] +ans(:, 5) = [2, 5] +ans(:, 6) = [3, 4] +ans(:, 7) = [3, 5] +ans(:, 8) = [4, 5] +END PROCEDURE EdgeConnectivity_Pyramid + +!---------------------------------------------------------------------------- +! FacetConnectivity_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetConnectivity_Pyramid +ans(:, 1) = [4, Quadrangle4, 1, 4, 3, 2] +ans(:, 2) = [3, Triangle3, 2, 3, 5, 0] +ans(:, 3) = [3, Triangle3, 3, 4, 5, 0] +ans(:, 4) = [3, Triangle3, 1, 5, 4, 0] +ans(:, 5) = [3, Triangle3, 1, 2, 5, 0] +END PROCEDURE FacetConnectivity_Pyramid + +!---------------------------------------------------------------------------- +! RefElemDomain_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Pyramid +!FIX: Implement RefElemDomain +CALL Errormsg(& + & msg="[WORK IN PROGRESS] We are working on it", & + & file=__FILE__, & + & line=__LINE__,& + & routine="RefElemDomain_Pyramid()", & + & unitno=stderr) +END PROCEDURE RefElemDomain_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeDegree_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Pyramid +! ISSUE: #165 Implement LagrangeDegree_Pyramid +END PROCEDURE LagrangeDegree_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeDOF_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Pyramid +ans = (order + 1) * (order + 2) * (2 * order + 3) / 6 +END PROCEDURE LagrangeDOF_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Pyramid +ans = (order - 1) * (order - 2) * (2 * order - 3) / 6 +END PROCEDURE LagrangeInDOF_Pyramid + +!---------------------------------------------------------------------------- +! GetTotalDOF_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Pyramid +ans = (order + 1) * (order + 2) * (2 * order + 3) / 6 +END PROCEDURE GetTotalDOF_Pyramid + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Pyramid +ans = (order - 1) * (order - 2) * (2 * order - 3) / 6 +END PROCEDURE GetTotalInDOF_Pyramid + +!---------------------------------------------------------------------------- +! EquidistancePoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Pyramid +!FIX: Implement EquidistancePoint_Pyramid +!ISSUE: #161 Implement EquidistancePoint_Pyramid routine +! nodecoord(:, 1) = [-1, -1, 0] +! nodecoord(:, 2) = [1, -1, 0] +! nodecoord(:, 3) = [1, 1, 0] +! nodecoord(:, 4) = [-1, 1, 0] +! nodecoord(:, 5) = [0, 0, 1] +END PROCEDURE EquidistancePoint_Pyramid + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Pyramid +! FIX: Implement EquidistanceInPoint_Pyramid +! ISSUE: #161 Implement EquidistanceInPoint_Pyramid routine + +END PROCEDURE EquidistanceInPoint_Pyramid + +!---------------------------------------------------------------------------- +! InterpolationPoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Pyramid +! FIX: Implement EquidistancePoint_Pyramid +SELECT CASE (ipType) +CASE (Equidistance) + nodecoord = EquidistancePoint_Pyramid(xij=xij, order=order) +CASE (GaussLegendre) +CASE (GaussLegendreLobatto) +CASE (GaussChebyshev) +CASE (GaussChebyshevLobatto) +END SELECT +END PROCEDURE InterpolationPoint_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid2 +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Pyramid4 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Pyramid1 +!FIX: QuadraturePoint_Pyramid1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="QuadraturePoint_Pyramid1()", & +& file=__FILE__) +END PROCEDURE QuadraturePoint_Pyramid1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Pyramid2 +!FIX: QuadraturePoint_Pyramid2 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="QuadraturePoint_Pyramid2()", & +& file=__FILE__) +END PROCEDURE QuadraturePoint_Pyramid2 + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Pyramid1 +!FIX: TensorQuadraturePoint_Pyramid1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="TensorQuadraturePoint_Pyramid1()", & +& file=__FILE__) +END PROCEDURE TensorQuadraturePoint_Pyramid1 + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Pyramid2 +!FIX: TensorQuadraturePoint_Pyramid2 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="TensorQuadraturePoint_Pyramid2()", & +& file=__FILE__) +END PROCEDURE TensorQuadraturePoint_Pyramid2 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Pyramid1 +!FIX: LagrangeEvalAll_Pyramid1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="LagrangeEvalAll_Pyramid1()", & +& file=__FILE__) +END PROCEDURE LagrangeEvalAll_Pyramid1 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Pyramid2 +!FIX: LagrangeEvalAll_Pyramid2 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="LagrangeEvalAll_Pyramid2()", & +& file=__FILE__) +END PROCEDURE LagrangeEvalAll_Pyramid2 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Pyramid1 +!FIX: LagrangeGradientEvalAll_Pyramid1 +CALL ErrorMsg(& +& msg="Work in progress", & +& unitno=stdout, & +& line=__LINE__, & +& routine="LagrangeGradientEvalAll_Pyramid1()", & +& file=__FILE__) +END PROCEDURE LagrangeGradientEvalAll_Pyramid1 + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..31abd7661 --- /dev/null +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -0,0 +1,2023 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(QuadrangleInterpolationUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! RefElemDomain_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Quadrangle +ans = "BIUNIT" +END PROCEDURE RefElemDomain_Quadrangle + +!---------------------------------------------------------------------------- +! FacetConnectivity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetConnectivity_Quadrangle +CHARACTER(:), ALLOCATABLE :: baseInterpol0 +! TYPE(String) :: baseContinuity0 + +baseInterpol0 = UpperCase(baseInterpol) +! baseContinuity0 = UpperCase(baseContinuity) + +SELECT CASE (baseInterpol0) +CASE ( & + & "HIERARCHYPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHYPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION", & + & "ORTHOGONALPOLYNOMIAL", & + & "ORTHOGONAL", & + & "ORTHOGONALINTERPOLATION") + ans(:, 1) = [1, 2] + ans(:, 2) = [4, 3] + ans(:, 3) = [1, 4] + ans(:, 4) = [2, 3] +CASE DEFAULT + ans(:, 1) = [1, 2] + ans(:, 2) = [2, 3] + ans(:, 3) = [3, 4] + ans(:, 4) = [4, 1] +END SELECT +END PROCEDURE FacetConnectivity_Quadrangle + +!---------------------------------------------------------------------------- +! QuadratureNumber_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Quadrangle +ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1) +ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2) +END PROCEDURE QuadratureNumber_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Quadrangle1 +INTEGER(I4B) :: n, ii, jj, kk +n = LagrangeDOF_Quadrangle(order=order) +ALLOCATE (ans(n, 2)) +kk = 0 +DO jj = 0, order + DO ii = 0, order + kk = kk + 1 + ans(kk, 1) = ii + ans(kk, 2) = jj + END DO +END DO +END PROCEDURE LagrangeDegree_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Quadrangle2 +INTEGER(I4B) :: n, ii, jj, kk +n = LagrangeDOF_Quadrangle(p=p, q=q) +ALLOCATE (ans(n, 2)) +kk = 0 +DO jj = 0, q + DO ii = 0, p + kk = kk + 1 + ans(kk, 1) = ii + ans(kk, 2) = jj + END DO +END DO +END PROCEDURE LagrangeDegree_Quadrangle2 + +!---------------------------------------------------------------------------- +! GetTotalDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Quadrangle +ans = (order + 1)**2 +END PROCEDURE GetTotalDOF_Quadrangle + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Quadrangle +ans = (order - 1)**2 +END PROCEDURE GetTotalInDOF_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Quadrangle1 +ans = (order + 1)**2 +END PROCEDURE LagrangeDOF_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Quadrangle2 +ans = (p + 1) * (q + 1) +END PROCEDURE LagrangeDOF_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Quadrangle1 +ans = (order - 1)**2 +END PROCEDURE LagrangeInDOF_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Quadrangle2 +ans = (p - 1) * (q - 1) +END PROCEDURE LagrangeInDOF_Quadrangle2 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Quadrangle1 +INTEGER(I4B) :: nsd, n, ne, i1, i2 +REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu + +x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + x(1:nsd, 1:4) = xij(1:nsd, 1:4) +ELSE + nsd = 2_I4B + x = 0.0_DFP + x(1:2, :) = RefQuadrangleCoord("BIUNIT") +END IF + +n = LagrangeDOF_Quadrangle(order=order) +ALLOCATE (ans(nsd, n)) +ans = 0.0_DFP + +! points on vertex +ans(1:nsd, 1:4) = x(1:nsd, 1:4) + +! points on edge +ne = LagrangeInDOF_Line(order=order) + +i2 = 4 +IF (order .GT. 1_I4B) THEN + i1 = i2 + 1; i2 = i1 + ne - 1 + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, [1, 2])) + + i1 = i2 + 1; i2 = i1 + ne - 1 + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, [2, 3])) + + i1 = i2 + 1; i2 = i1 + ne - 1 + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, [3, 4])) + + i1 = i2 + 1; i2 = i1 + ne - 1 + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, [4, 1])) + +END IF + +! points on face +IF (order .GT. 1_I4B) THEN + + IF (order .EQ. 2_I4B) THEN + i1 = i2 + 1 + ans(1:nsd, i1) = SUM(x(1:nsd, :), dim=2_I4B) / 4.0_DFP + ELSE + + e1 = x(:, 2) - x(:, 1) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 4) - x(:, 1) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) + + e1 = x(:, 3) - x(:, 2) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 1) - x(:, 2) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) + + e1 = x(:, 2) - x(:, 3) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 4) - x(:, 3) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) + + e1 = x(:, 3) - x(:, 4) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 1) - x(:, 4) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd) + + i1 = i2 + 1 + ans(1:nsd, i1:) = EquidistancePoint_Quadrangle( & + & order=order - 2, & + & xij=xin(1:nsd, 1:4)) + + END IF +END IF +END PROCEDURE EquidistancePoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Quadrangle2 +ans = InterpolationPoint_Quadrangle2( & + & p=p, & + & q=q, & + & xij=xij, & + & ipType1=Equidistance, & + & ipType2=Equidistance, & + & layout="VEFC") +END PROCEDURE EquidistancePoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Quadrangle1 +INTEGER(I4B) :: nsd, n, ne, i1, i2 +REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu + +IF (order .LT. 2_I4B) THEN + ALLOCATE (ans(0, 0)) + RETURN +END IF + +x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + x(1:nsd, 1:4) = xij(1:nsd, 1:4) +ELSE + nsd = 2_I4B + x(1:nsd, 1) = [-1.0, -1.0] + x(1:nsd, 2) = [1.0, -1.0] + x(1:nsd, 3) = [1.0, 1.0] + x(1:nsd, 4) = [-1.0, 1.0] +END IF + +n = LagrangeInDOF_Quadrangle(order=order) +ALLOCATE (ans(nsd, n)) +ans = 0.0_DFP + +! points on face +IF (order .EQ. 2_I4B) THEN + ans(1:nsd, 1) = SUM(x, dim=2_I4B) / 4.0_DFP +ELSE + e1 = x(:, 2) - x(:, 1) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 4) - x(:, 1) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) + + e1 = x(:, 3) - x(:, 2) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 1) - x(:, 2) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) + + e1 = x(:, 2) - x(:, 3) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 4) - x(:, 3) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) + + e1 = x(:, 3) - x(:, 4) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 1) - x(:, 4) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd) + + ans(1:nsd, 1:) = EquidistancePoint_Quadrangle1( & + & order=order - 2, & + & xij=xin(1:nsd, 1:4)) + +END IF +END PROCEDURE EquidistanceInPoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Quadrangle2 +END PROCEDURE EquidistanceInPoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJ2VEFC_Quadrangle +CALL IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, temp, p, q, 1_I4B) +END PROCEDURE IJ2VEFC_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise +! internal variables +INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2 +INTEGER(I4B), PARAMETER :: tEdges = 4 +INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & +& pointsOrder(4) +REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & + & temp_in(:, :) + +! vertices +N = (p + 1) * (q + 1) +cnt = 0 +ll = -1 + +SELECT CASE (startNode) +CASE (1) + edgeConnectivity(:, 1) = [1, 4] + edgeConnectivity(:, 2) = [4, 3] + edgeConnectivity(:, 3) = [3, 2] + edgeConnectivity(:, 4) = [2, 1] + pointsOrder = [1, 4, 3, 2] +CASE (2) + edgeConnectivity(:, 1) = [2, 1] + edgeConnectivity(:, 2) = [1, 4] + edgeConnectivity(:, 3) = [4, 3] + edgeConnectivity(:, 4) = [3, 2] + pointsOrder = [2, 1, 4, 3] +CASE (3) + edgeConnectivity(:, 1) = [3, 2] + edgeConnectivity(:, 2) = [2, 1] + edgeConnectivity(:, 3) = [1, 4] + edgeConnectivity(:, 4) = [4, 3] + pointsOrder = [3, 2, 1, 4] +CASE (4) + edgeConnectivity(:, 1) = [4, 3] + edgeConnectivity(:, 2) = [3, 2] + edgeConnectivity(:, 3) = [2, 1] + edgeConnectivity(:, 4) = [1, 4] + pointsOrder = [4, 3, 2, 1] +END SELECT + +IF (ALL([p, q] .EQ. 0_I4B)) THEN + temp(:, 1) = [xi(1, 1), eta(1, 1)] + RETURN +END IF + +ij(:, 1) = [1, 1] +ij(:, 2) = [p + 1, 1] +ij(:, 3) = [p + 1, q + 1] +ij(:, 4) = [1, q + 1] + +IF (ALL([p, q] .GE. 1_I4B)) THEN + DO ii = 1, 4 + cnt = cnt + 1 + jj = pointsOrder(ii) + temp(1:2, ii) = [ & + & xi(ij(1, jj), ij(2, jj)), & + & eta(ij(1, jj), ij(2, jj)) & + & ] + END DO + IF (ALL([p, q] .EQ. 1_I4B)) RETURN + +ELSE + IF (p .EQ. 0_I4B) THEN + DO jj = 1, q + 1 + cnt = cnt + 1 + temp(1:2, jj) = [xi(1, jj), eta(1, jj)] + END DO + END IF + + IF (q .EQ. 0_I4B) THEN + DO ii = 1, p + 1 + cnt = cnt + 1 + temp(1:2, ii) = [xi(ii, 1), eta(ii, 1)] + END DO + END IF + +END IF + +IF (ALL([p, q] .GE. 1_I4B)) THEN + DO iedge = 1, tEdges + p1 = edgeConnectivity(1, iedge) + p2 = edgeConnectivity(2, iedge) + + IF (ij(1, p1) .EQ. ij(1, p2)) THEN + ii1 = ij(1, p1) + ii2 = ii1 + dii = 1 + ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN + ii1 = ij(1, p1) + 1 + ii2 = ij(1, p2) - 1 + dii = 1 + ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN + ii1 = ij(1, p1) - 1 + ii2 = ij(1, p2) + 1 + dii = -1 + END IF + + IF (ij(2, p1) .EQ. ij(2, p2)) THEN + jj1 = ij(2, p1) + jj2 = jj1 + djj = 1 + ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN + jj1 = ij(2, p1) + 1 + jj2 = ij(2, p2) - 1 + djj = 1 + ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN + jj1 = ij(2, p1) - 1 + jj2 = ij(2, p2) + 1 + djj = -1 + END IF + + DO ii = ii1, ii2, dii + DO jj = jj1, jj2, djj + cnt = cnt + 1 + temp(:, cnt) = [xi(ii, jj), eta(ii, jj)] + END DO + END DO + END DO + + ! internal nodes + IF (ALL([p, q] .GE. 2_I4B)) THEN + + CALL Reallocate( & + & xi_in, & + & MAX(p - 1, 1_I4B), & + & MAX(q - 1_I4B, 1_I4B)) + CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) + CALL Reallocate(temp_in, 2, SIZE(xi_in)) + + IF (p .LE. 1_I4B) THEN + ii1 = 1 + ii2 = 1 + ELSE + ii1 = 2 + ii2 = p + END IF + + IF (q .LE. 1_I4B) THEN + jj1 = 1 + jj2 = 1 + ELSE + jj1 = 2 + jj2 = q + END IF + + xi_in = xi(ii1:ii2, jj1:jj2) + eta_in = eta(ii1:ii2, jj1:jj2) + + CALL IJ2VEFC_Quadrangle_Clockwise( & + & xi=xi_in, & + & eta=eta_in, & + & temp=temp_in, & + & p=MAX(p - 2, 0_I4B), & + & q=MAX(q - 2, 0_I4B), & + & startNode=startNode) + + ii1 = cnt + 1 + ii2 = ii1 + SIZE(temp_in, 2) - 1 + temp(1:2, ii1:ii2) = temp_in + END IF + +END IF + +IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) +IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) +IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) + +END PROCEDURE IJ2VEFC_Quadrangle_Clockwise + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise +! internal variables +INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2 +INTEGER(I4B), PARAMETER :: tEdges = 4 +INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & +& pointsOrder(4) +REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & + & temp_in(:, :) + +! vertices +N = (p + 1) * (q + 1) +cnt = 0 +ll = -1 + +SELECT CASE (startNode) +CASE (1) + edgeConnectivity(:, 1) = [1, 2] + edgeConnectivity(:, 2) = [2, 3] + edgeConnectivity(:, 3) = [3, 4] + edgeConnectivity(:, 4) = [4, 1] + pointsOrder = [1, 2, 3, 4] +CASE (2) + edgeConnectivity(:, 1) = [2, 3] + edgeConnectivity(:, 2) = [3, 4] + edgeConnectivity(:, 3) = [4, 1] + edgeConnectivity(:, 4) = [1, 2] + pointsOrder = [2, 3, 4, 1] +CASE (3) + edgeConnectivity(:, 1) = [3, 4] + edgeConnectivity(:, 2) = [4, 1] + edgeConnectivity(:, 3) = [1, 2] + edgeConnectivity(:, 4) = [2, 3] + pointsOrder = [3, 4, 1, 2] +CASE (4) + edgeConnectivity(:, 1) = [4, 1] + edgeConnectivity(:, 2) = [1, 2] + edgeConnectivity(:, 3) = [2, 3] + edgeConnectivity(:, 4) = [3, 4] + pointsOrder = [4, 1, 2, 3] +END SELECT + +IF (ALL([p, q] .EQ. 0_I4B)) THEN + temp(:, 1) = [xi(1, 1), eta(1, 1)] + RETURN +END IF + +ij(:, 1) = [1, 1] +ij(:, 2) = [p + 1, 1] +ij(:, 3) = [p + 1, q + 1] +ij(:, 4) = [1, q + 1] + +IF (ALL([p, q] .GE. 1_I4B)) THEN + DO ii = 1, 4 + cnt = cnt + 1 + jj = pointsOrder(ii) + temp(1:2, ii) = [& + & xi(ij(1, jj), ij(2, jj)), & + & eta(ij(1, jj), ij(2, jj)) & + & ] + END DO + IF (ALL([p, q] .EQ. 1_I4B)) RETURN + +ELSE + DO ii = 1, MIN(p, 1) + 1 + DO jj = 1, MIN(q, 1) + 1 + cnt = cnt + 1 + temp(1:2, cnt) = [& + & xi(ij(1, cnt), ij(2, cnt)), & + & eta(ij(1, cnt), ij(2, cnt))] + END DO + END DO +END IF + +IF (ALL([p, q] .GE. 1_I4B)) THEN + DO iedge = 1, tEdges + p1 = edgeConnectivity(1, iedge) + p2 = edgeConnectivity(2, iedge) + + IF (ij(1, p1) .EQ. ij(1, p2)) THEN + ii1 = ij(1, p1) + ii2 = ii1 + dii = 1 + ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN + ii1 = ij(1, p1) + 1 + ii2 = ij(1, p2) - 1 + dii = 1 + ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN + ii1 = ij(1, p1) - 1 + ii2 = ij(1, p2) + 1 + dii = -1 + END IF + + IF (ij(2, p1) .EQ. ij(2, p2)) THEN + jj1 = ij(2, p1) + jj2 = jj1 + djj = 1 + ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN + jj1 = ij(2, p1) + 1 + jj2 = ij(2, p2) - 1 + djj = 1 + ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN + jj1 = ij(2, p1) - 1 + jj2 = ij(2, p2) + 1 + djj = -1 + END IF + + DO ii = ii1, ii2, dii + DO jj = jj1, jj2, djj + cnt = cnt + 1 + temp(:, cnt) = [xi(ii, jj), eta(ii, jj)] + END DO + END DO + END DO + + ! internal nodes + IF (ALL([p, q] .GE. 2_I4B)) THEN + + CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B)) + CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) + CALL Reallocate(temp_in, 2, SIZE(xi_in)) + + IF (p .LE. 1_I4B) THEN + ii1 = 1 + ii2 = 1 + ELSE + ii1 = 2 + ii2 = p + END IF + + IF (q .LE. 1_I4B) THEN + jj1 = 1 + jj2 = 1 + ELSE + jj1 = 2 + jj2 = q + END IF + + xi_in = xi(ii1:ii2, jj1:jj2) + eta_in = eta(ii1:ii2, jj1:jj2) + + CALL IJ2VEFC_Quadrangle_AntiClockwise( & + & xi=xi_in, & + & eta=eta_in, & + & temp=temp_in, & + & p=MAX(p - 2, 0_I4B), & + & q=MAX(q - 2, 0_I4B), & + & startNode=startNode) + + ii1 = cnt + 1 + ii2 = ii1 + SIZE(temp_in, 2) - 1 + temp(1:2, ii1:ii2) = temp_in + END IF + +END IF + +IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) +IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) +IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) + +END PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle1 +ans = InterpolationPoint_Quadrangle2( & + & p=order, & + & q=order, & + & ipType1=ipType, & + & ipType2=ipType, & + & xij=xij, & + & layout=layout, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda & + & ) +END PROCEDURE InterpolationPoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle2 +! internal variables +REAL(DFP) :: x(p + 1), y(q + 1), & + & xi(p + 1, q + 1), eta(p + 1, q + 1) +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: ii, jj, kk, nsd + +x = InterpolationPoint_Line( & + & order=p, & + & ipType=ipType1, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +y = InterpolationPoint_Line( & + & order=q, & + & ipType=ipType2, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2 +END IF + +CALL Reallocate(ans, nsd, (p + 1) * (q + 1)) +CALL Reallocate(temp, 2, (p + 1) * (q + 1)) + +xi = 0.0_DFP +eta = 0.0_DFP + +DO ii = 1, p + 1 + DO jj = 1, q + 1 + xi(ii, jj) = x(ii) + eta(ii, jj) = y(jj) + END DO +END DO + +IF (layout .EQ. "VEFC") THEN + CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=temp, p=p, q=q) +ELSE + kk = 0 + DO ii = 1, p + 1 + DO jj = 1, q + 1 + kk = kk + 1 + temp(1, kk) = xi(ii, jj) + temp(2, kk) = eta(ii, jj) + END DO + END DO +END IF + +IF (PRESENT(xij)) THEN + ans = FromBiUnitQuadrangle2Quadrangle(xin=temp, x1=xij(:, 1), & + & x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4)) +ELSE + ans = temp +END IF +END PROCEDURE InterpolationPoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle2 + +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle4 +INTEGER(I4B) :: basisType0, ii, jj, indx +REAL(DFP) :: ans1(SIZE(xij, 2), 0:order) +REAL(DFP) :: ans2(SIZE(xij, 2), 0:order) + +basisType0 = input(default=Monomial, option=basisType) + +IF (basisType0 .EQ. Heirarchical) THEN + ans = HeirarchicalBasis_Quadrangle2(p=order, q=order, xij=xij) +ELSE + ans = TensorProdBasis_Quadrangle1( & + & p=order, & + & q=order, & + & xij=xij, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda) +END IF + +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Quadrangle4 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle5 +INTEGER(I4B) :: ii, jj, kk, indx, basisType(2) +REAL(DFP) :: ans1(SIZE(xij, 2), 0:p) +REAL(DFP) :: ans2(SIZE(xij, 2), 0:q) + +basisType(1) = input(default=Monomial, option=basisType1) +basisType(2) = input(default=Monomial, option=basisType2) + +IF (ALL(basisType .EQ. Heirarchical)) THEN + ans = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij) +ELSE + ans = TensorProdBasis_Quadrangle1( & + & p=p, & + & q=q, & + & xij=xij, & + & basisType1=basisType(1), & + & basisType2=basisType(2), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2) +END IF + +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Quadrangle5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +CALL Dubiner_Quadrangle1_(xij=xij, order=order, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE Dubiner_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle1_ +REAL(DFP) :: P1(SIZE(xij, 2), order + 1), P2(SIZE(xij, 2), order + 1) +REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) +REAL(DFP) :: avec(SIZE(xij, 2)), alpha, beta +INTEGER(I4B) :: k1, k2, max_k2, cnt + +x = xij(1, :) +y = xij(2, :) +nrow = SIZE(xij, 2) +ncol = (order + 1) * (order + 2) / 2 + +P1 = LegendreEvalAll(n=order, x=x) + +! we do not need x now, so let store (1-y)/2 in x +x = 0.5_DFP * (1.0_DFP - y) +alpha = 0.0_DFP +beta = 0.0_DFP +cnt = 0 + +DO k1 = 0, order + + avec = (x)**k1 ! note here x = 0.5_DFP*(1-y) + alpha = 2.0_DFP * k1 + 1.0_DFP + + max_k2 = order - k1 + + P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta) + + DO k2 = 0, max_k2 + cnt = cnt + 1 + ans(:, cnt) = P1(:, k1 + 1) * avec * P2(:, k2 + 1) + END DO + +END DO + +END PROCEDURE Dubiner_Quadrangle1_ + +!---------------------------------------------------------------------------- +! DubinerGradient_Quadrangle1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DubinerGradient_Quadrangle1 +INTEGER(I4B) :: s(3) +CALL DubinerGradient_Quadrangle1_(xij=xij, order=order, ans=ans, & + tsize1=s(1), tsize2=s(2), tsize3=s(3)) +END PROCEDURE DubinerGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! DubinerGradient_Quadrangle1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DubinerGradient_Quadrangle1_ +REAL(DFP), DIMENSION(SIZE(xij, 2), order + 1) :: P1, P2, dP1, dP2 +REAL(DFP), DIMENSION(SIZE(xij, 2)) :: avec, bvec, x, y +REAL(DFP) :: alpha, beta +INTEGER(I4B) :: k1, k2, max_k2, cnt + +tsize1 = SIZE(xij, 2) +tsize2 = (order + 1) * (order + 2) / 2 +tsize3 = 2 + +x = xij(1, :) +y = xij(2, :) +P1 = LegendreEvalAll(n=order, x=x) +dP1 = LegendreGradientEvalAll(n=order, x=x) + +! we do not need x now, so let store (1-y)/2 in x +x = 0.5_DFP * (1.0_DFP - y) +alpha = 1.0_DFP +beta = 0.0_DFP +cnt = 0 + +DO k1 = 0, order + bvec = x**(MAX(k1 - 1_I4B, 0_I4B)) + avec = x * bvec + alpha = 2.0_DFP * k1 + 1.0_DFP + + max_k2 = order - k1 + + P2(:, 1:max_k2 + 1) = JacobiEvalAll( & + & n=max_k2, & + & x=y, & + & alpha=alpha, & + & beta=beta) + + dP2(:, 1:max_k2 + 1) = JacobiGradientEvalAll( & + & n=max_k2, & + & x=y, & + & alpha=alpha, & + & beta=beta) + + DO k2 = 0, max_k2 + cnt = cnt + 1 + ans(:, cnt, 1) = dP1(:, k1 + 1) * avec * P2(:, k2 + 1) + ans(:, cnt, 2) = P1(:, k1 + 1) * bvec * & + & (x * dP2(:, k2 + 1) - 0.5_DFP * REAL(k1, DFP) * P2(:, k2 + 1)) + END DO +END DO +END PROCEDURE DubinerGradient_Quadrangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL Dubiner_Quadrangle2_(x=x, y=y, order=order, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE Dubiner_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle2_ +REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) +INTEGER(I4B) :: ii, jj, cnt + +xij = 0.0_DFP +cnt = 0 +DO ii = 1, SIZE(x) + DO jj = 1, SIZE(y) + cnt = cnt + 1 + xij(1, cnt) = x(ii) + xij(2, cnt) = y(jj) + END DO +END DO +CALL Dubiner_Quadrangle1_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE Dubiner_Quadrangle2_ + +!---------------------------------------------------------------------------- +! TensorProdOrthoPol_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle1 +REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) +INTEGER(I4B) :: ii, k1, k2, cnt + +x = xij(1, :) +y = xij(2, :) + +P1 = BasisEvalAll_Line( & + & order=p, & + & x=x, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +Q1 = BasisEvalAll_Line( & + & order=q, & + & x=y, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +cnt = 0 + +DO k2 = 1, q + 1 + DO k1 = 1, p + 1 + cnt = cnt + 1 + ans(:, cnt) = P1(:, k1) * Q1(:, k2) + END DO +END DO + +END PROCEDURE TensorProdBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle2 +REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) +INTEGER(I4B) :: ii, jj, cnt + +xij = 0.0_DFP +cnt = 0 +DO ii = 1, SIZE(x) + DO jj = 1, SIZE(y) + cnt = cnt + 1 + xij(1, cnt) = x(ii) + xij(2, cnt) = y(jj) + END DO +END DO + +ans = TensorProdBasis_Quadrangle1( & + & p=p, & + & q=q, & + & xij=xij, & + & basisType1=basisType1, & + & basisType2=basisType2, & + & alpha1=alpha1, & + & alpha2=alpha2, & + & beta1=beta1, & + & beta2=beta2, & + & lambda1=lambda1, & + & lambda2=lambda2) + +END PROCEDURE TensorProdBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle1 +ans(:, 1) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP - y) +ans(:, 2) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP - y) +ans(:, 3) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP + y) +ans(:, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y) +END PROCEDURE VertexBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle2 +ans(:, 1) = L1(:, 0) * L2(:, 0) +ans(:, 2) = L1(:, 1) * L2(:, 0) +ans(:, 3) = L1(:, 1) * L2(:, 1) +ans(:, 4) = L1(:, 0) * L2(:, 1) +END PROCEDURE VertexBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! VertexBasisGradient_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasisGradient_Quadrangle2 +ans(:, 1, 1) = dL1(:, 0) * L2(:, 0) +ans(:, 2, 1) = dL1(:, 1) * L2(:, 0) +ans(:, 3, 1) = dL1(:, 1) * L2(:, 1) +ans(:, 4, 1) = dL1(:, 0) * L2(:, 1) +ans(:, 1, 2) = L1(:, 0) * dL2(:, 0) +ans(:, 2, 2) = L1(:, 1) * dL2(:, 0) +ans(:, 3, 2) = L1(:, 1) * dL2(:, 1) +ans(:, 4, 2) = L1(:, 0) * dL2(:, 1) +END PROCEDURE VertexBasisGradient_Quadrangle2 + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle3 +ans = VertexBasis_Quadrangle1( & + & x=xij(1, :), & + & y=xij(2, :)) +END PROCEDURE VertexBasis_Quadrangle3 + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle +REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) +INTEGER(I4B) :: maxQ, k2, cnt + +maxQ = MAX(qe1, qe2) + +L2 = LobattoEvalAll(n=maxQ, x=y) + +cnt = 0 + +DO k2 = 2, qe1 + cnt = cnt + 1 + ans(:, cnt) = 0.5_DFP * (1.0_DFP - x) * L2(:, k2) +END DO + +DO k2 = 2, qe2 + cnt = cnt + 1 + ans(:, cnt) = 0.5_DFP * (1.0_DFP + x) * L2(:, k2) +END DO + +END PROCEDURE VerticalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2 +INTEGER(I4B) :: k2, cnt + +cnt = 0 +DO k2 = 2, qe1 + cnt = cnt + 1 + ans(:, cnt) = L1(:, 0) * L2(:, k2) +END DO +DO k2 = 2, qe2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, 1) * L2(:, k2) +END DO + +END PROCEDURE VerticalEdgeBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! VerticalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasisGradient_Quadrangle2 +INTEGER(I4B) :: k2, cnt +cnt = 0 +DO k2 = 2, qe1 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 0) * L2(:, k2) + ans(:, cnt, 2) = L1(:, 0) * dL2(:, k2) +END DO +DO k2 = 2, qe2 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, 1) * L2(:, k2) + ans(:, cnt, 2) = L1(:, 1) * dL2(:, k2) +END DO +END PROCEDURE VerticalEdgeBasisGradient_Quadrangle2 + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle +REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4)) +INTEGER(I4B) :: maxP, k1, cnt + +maxP = MAX(pe3, pe4) + +L1 = LobattoEvalAll(n=maxP, x=x) + +cnt = 0 + +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = 0.5_DFP * (1.0_DFP - y) * L1(:, k1) +END DO + +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = 0.5_DFP * (1.0_DFP + y) * L1(:, k1) +END DO + +END PROCEDURE HorizontalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2 +INTEGER(I4B) :: k1, cnt +cnt = 0 +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 0) +END DO +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 1) +END DO +END PROCEDURE HorizontalEdgeBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2 +INTEGER(I4B) :: k1, cnt +cnt = 0 +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) +END DO +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) +END DO +END PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2 + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle +REAL(DFP) :: L1(1:SIZE(x), 0:pb) +REAL(DFP) :: L2(1:SIZE(y), 0:qb) +INTEGER(I4B) :: k1, k2, cnt + +L1 = LobattoEvalAll(n=pb, x=x) +L2 = LobattoEvalAll(n=qb, x=y) + +cnt = 0 + +DO k1 = 2, pb + DO k2 = 2, qb + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) + END DO +END DO + +END PROCEDURE CellBasis_Quadrangle + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle2 +INTEGER(I4B) :: k1, k2, cnt +cnt = 0 +DO k1 = 2, pb + DO k2 = 2, qb + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) + END DO +END DO +END PROCEDURE CellBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! CellBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasisGradient_Quadrangle2 +INTEGER(I4B) :: k1, k2, cnt +cnt = 0 +DO k1 = 2, pb + DO k2 = 2, qb + cnt = cnt + 1 + ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) + ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) + END DO +END DO +END PROCEDURE CellBasisGradient_Quadrangle2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 +INTEGER(I4B) :: a, b, maxP, maxQ +REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) +REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) + +maxP = MAX(pe3, pe4, pb) +maxQ = MAX(qe1, qe2, qb) + +L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) +L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) + +! Vertex basis function + +ans(:, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) + +! Edge basis function + +b = 4 +! +IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 + ans(:, a:b) = VerticalEdgeBasis_Quadrangle2( & + & qe1=qe1, qe2=qe2, L1=L1, L2=L2) +END IF + +! Edge basis function + +IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 + ans(:, a:b) = HorizontalEdgeBasis_Quadrangle2( & + & pe3=pe3, pe4=pe4, L1=L1, L2=L2) +END IF + +! Cell basis function + +IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + (pb - 1) * (qb - 1) + ans(:, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) +END IF +END PROCEDURE HeirarchicalBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 +ans = HeirarchicalBasis_Quadrangle1(pb=p, pe3=p, pe4=p, & + & qb=q, qe1=q, qe2=q, xij=xij) +END PROCEDURE HeirarchicalBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeEvallAll_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Quadrangle(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) + coeff0 = TRANSPOSE(coeff) + ELSE + coeff0 = TRANSPOSE(coeff) + END IF +ELSE + coeff0 = TRANSPOSE(LagrangeCoeff_Quadrangle(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & )) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Quadrangle(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Quadrangle1", & + & line=__LINE__, & + & unitno=stderr) + END IF + + DO ii = 1, tdof + xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasis_Quadrangle( & + & p=order, & + & q=order, & + & xij=RESHAPE(x, [2, 1])) + +CASE DEFAULT + + xx = TensorProdBasis_Quadrangle( & + & p=order, & + & q=order, & + & xij=RESHAPE(x, [2, 1]), & + & basisType1=basisType0, & + & basisType2=basisType0, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda) + +END SELECT + +ans = MATMUL(coeff0, xx(1, :)) + +END PROCEDURE LagrangeEvalAll_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle2 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) +REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Quadrangle(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) + coeff0 = coeff + ELSE + coeff0 = coeff + END IF +ELSE + coeff0 = LagrangeCoeff_Quadrangle(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Quadrangle(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Quadrangle1", & + & line=__LINE__, & + & unitno=stderr) + END IF + + DO ii = 1, tdof + xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasis_Quadrangle( & + & p=order, & + & q=order, & + & xij=x) + +CASE DEFAULT + + xx = TensorProdBasis_Quadrangle( & + & p=order, & + & q=order, & + & xij=x, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda) + +END SELECT + +ans = MATMUL(xx, coeff0) + +END PROCEDURE LagrangeEvalAll_Quadrangle2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle1 +ans = QuadraturePoint_Quadrangle2( & + & p=order, & + & q=order, & + & quadType1=quadType, & + & quadType2=quadType, & + & xij=xij, & + & refQuadrangle=refQuadrangle, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda & + & ) +END PROCEDURE QuadraturePoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle2 +! internal variables +REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), temp(:, :) +INTEGER(I4B) :: ii, jj, kk, nsd, np, nq +TYPE(String) :: astr + +astr = TRIM(UpperCase(refQuadrangle)) + +x = QuadraturePoint_Line( & + & order=p, & + & quadType=quadType1, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +np = SIZE(x, 2) + +y = QuadraturePoint_Line( & + & order=q, & + & quadType=quadType2, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +nq = SIZE(y, 2) + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2 +END IF + +CALL Reallocate(ans, nsd + 1_I4B, np * nq) +CALL Reallocate(temp, 3_I4B, np * nq) + +kk = 0 +DO ii = 1, np + DO jj = 1, nq + kk = kk + 1 + temp(1, kk) = x(1, ii) + temp(2, kk) = y(1, jj) + temp(3, kk) = x(2, ii) * y(2, jj) + END DO +END DO + +IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( & + & xin=temp(1:2, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4)) + ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & + & from="BIUNIT", to="QUADRANGLE", xij=xij) +ELSE + IF (astr%chars() .EQ. "UNIT") THEN + ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( & + & xin=temp(1:2, :)) + ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & + & from="BIUNIT", to="UNIT", xij=xij) + ELSE + ans = temp + END IF +END IF + +IF (ALLOCATED(temp)) DEALLOCATE (temp) +IF (ALLOCATED(x)) DEALLOCATE (x) +IF (ALLOCATED(y)) DEALLOCATE (y) + +END PROCEDURE QuadraturePoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle3 +ans = QuadraturePoint_Quadrangle4( & + & nipsx=nips, & + & nipsy=nips, & + & quadType1=quadType, & + & quadType2=quadType, & + & refQuadrangle=refQuadrangle, & + & xij=xij, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda & + & ) +END PROCEDURE QuadraturePoint_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle4 +! internal variables +REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), temp(3, nipsy(1) * nipsx(1)) +INTEGER(I4B) :: ii, jj, kk, nsd, np, nq +TYPE(String) :: astr + +astr = TRIM(UpperCase(refQuadrangle)) + +x = QuadraturePoint_Line( & + & nips=nipsx, & + & quadType=quadType1, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +np = SIZE(x, 2) + +y = QuadraturePoint_Line( & + & nips=nipsy, & + & quadType=quadType2, & + & xij=[-1.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +nq = SIZE(y, 2) + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2 +END IF + +CALL Reallocate(ans, nsd + 1_I4B, np * nq) + +kk = 0 +DO ii = 1, np + DO jj = 1, nq + kk = kk + 1 + temp(1, kk) = x(1, ii) + temp(2, kk) = y(1, jj) + temp(3, kk) = x(2, ii) * y(2, jj) + END DO +END DO + +IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( & + & xin=temp(1:2, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4)) + ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & + & from="BIUNIT", to="QUADRANGLE", xij=xij) +ELSE + IF (astr%chars() .EQ. "UNIT") THEN + ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( & + & xin=temp(1:2, :)) + ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & + & from="BIUNIT", to="UNIT", xij=xij) + ELSE + ans = temp + END IF +END IF + +END PROCEDURE QuadraturePoint_Quadrangle4 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof, ai, bi +INTEGER(I4B) :: degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & + & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Quadrangle(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) + coeff0 = coeff + ELSE + coeff0 = coeff + END IF +ELSE + coeff0 = LagrangeCoeff_Quadrangle(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda & + & ) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Quadrangle(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Quadrangle1", & + & line=__LINE__, & + & unitno=stderr) + END IF + + DO ii = 1, tdof + ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) + bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) + ar = REAL(degree(ii, 1_I4B), DFP) + br = REAL(degree(ii, 2_I4B), DFP) + xx(:, ii, 1) = (ar * x(1, :)**ai) * x(2, :)**degree(ii, 2) + xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasisGradient_Quadrangle( & + & p=order, & + & q=order, & + & xij=x) + +CASE DEFAULT + + xx = OrthogonalBasisGradient_Quadrangle( & + & p=order, & + & q=order, & + & xij=x, & + & basisType1=basisType0, & + & basisType2=basisType0, & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda) + +END SELECT + +DO ii = 1, 2 + ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) + ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) +END DO + +END PROCEDURE LagrangeGradientEvalAll_Quadrangle1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1 +INTEGER(I4B) :: a, b, maxP, maxQ +REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) +REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) +REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) +REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) + +maxP = MAX(pe3, pe4, pb) +maxQ = MAX(qe1, qe2, qb) + +L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) +L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) +dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :)) +dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :)) + +! Vertex basis function +ans(:, 1:4, 1:2) = VertexBasisGradient_Quadrangle2( & +& L1=L1, & +& L2=L2, & +& dL1=dL1, & +& dL2=dL2 & +& ) + +! Edge basis function +b = 4 +IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 + ans(:, a:b, 1:2) = VerticalEdgeBasisGradient_Quadrangle2( & + & qe1=qe1, & + & qe2=qe2, & + & L1=L1, & + & L2=L2, & + & dL1=dL1, & + & dL2=dL2 & + & ) +END IF + +! Edge basis function +IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 + ans(:, a:b, 1:2) = HorizontalEdgeBasisGradient_Quadrangle2( & + & pe3=pe3, & + & pe4=pe4, & + & L1=L1, & + & L2=L2, & + & dL1=dL1, & + & dL2=dL2 & + & ) +END IF + +! Cell basis function +IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + (pb - 1) * (qb - 1) + ans(:, a:b, 1:2) = CellBasisGradient_Quadrangle2( & + & pb=pb, & + & qb=qb, & + & L1=L1, & + & L2=L2, & + & dL1=dL1, & + & dL2=dL2 & + & ) +END IF +END PROCEDURE HeirarchicalBasisGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2 +ans = HeirarchicalBasisGradient_Quadrangle1( & + & pb=p, & + & pe3=p, & + & pe4=p, & + & qb=q, & + & qe1=q, & + & qe2=q, & + & xij=xij) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle2 + +!---------------------------------------------------------------------------- +! TensorProdBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 +REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) +REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1) +INTEGER(I4B) :: ii, k1, k2, cnt + +x = xij(1, :) +y = xij(2, :) + +P1 = BasisEvalAll_Line( & + & order=p, & + & x=x, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +Q1 = BasisEvalAll_Line( & + & order=q, & + & x=y, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +dP1 = BasisGradientEvalAll_Line( & + & order=p, & + & x=x, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) + +dQ1 = BasisGradientEvalAll_Line( & + & order=q, & + & x=y, & + & refLine="BIUNIT", & + & basisType=basisType1, & + & alpha=alpha2, & + & beta=beta2, & + & lambda=lambda2) + +cnt = 0 + +DO k2 = 1, q + 1 + DO k1 = 1, p + 1 + cnt = cnt + 1 + ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2) + ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2) + END DO +END DO + +END PROCEDURE TensorProdBasisGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle3 +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 new file mode 100644 index 000000000..810e3c6cb --- /dev/null +++ b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 @@ -0,0 +1,3449 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE QuadraturePoint_Tetrahedron_Solin +USE GlobalData, ONLY: DFP, I4B, LGT +IMPLICIT NONE +PRIVATE +PUBLIC :: QuadraturePointTetrahedronSolin +PUBLIC :: QuadratureOrderTetrahedronSolin +PUBLIC :: QuadratureNumberTetrahedronSolin +INTEGER( I4B ), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN=21 + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips + INTEGER(I4B) :: ans + ans = -1 + SELECT CASE (nips) + CASE (1) + ans = 1 + CASE (4) + ans = 2 + CASE (5) + ans = 3 + CASE (11) + ans = 4 + CASE (14) + ans = 5 + CASE (24) + ans = 6 + CASE (31) + ans = 7 + CASE (43) + ans = 8 + CASE (53) + ans = 9 + CASE (126) + ans = 11 + CASE (210) + ans = 13 + CASE (330) + ans = 15 + CASE (495) + ans = 17 + CASE (715) + ans = 19 + CASE (1001) + ans = 21 + END SELECT +END FUNCTION QuadratureOrderTetrahedronSolin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + ans = -1 + SELECT CASE (order) + CASE (0, 1) + ans = 1 + CASE (2) + ans = 4 + CASE (3) + ans = 5 + CASE (4) + ans = 11 + CASE (5) + ans = 14 + CASE (6) + ans = 24 + CASE (7) + ans = 31 + CASE (8) + ans = 43 + CASE (9) + ans = 53 + CASE (10) + ans = 126 + CASE (11) + ans = 126 + CASE (12) + ans = 210 + CASE (13) + ans = 210 + CASE (14) + ans = 330 + CASE (15) + ans = 330 + CASE (16) + ans = 495 + CASE (17) + ans = 495 + CASE (18) + ans = 715 + CASE (19) + ans = 715 + CASE (20) + ans = 1001 + CASE (21) + ans = 1001 + END SELECT +END FUNCTION QuadratureNumberTetrahedronSolin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QuadraturePointTetrahedronSolin(order) RESULT(ans) + REAL(DFP), ALLOCATABLE :: ans(:, :) + INTEGER(I4B), INTENT(IN) :: order + SELECT CASE (order) + CASE (0, 1) + ans = QP_Tetrahedron_Order1() + CASE (2) + ans = QP_Tetrahedron_Order2() + CASE (3) + ans = QP_Tetrahedron_Order3() + CASE (4) + ans = QP_Tetrahedron_Order4() + CASE (5) + ans = QP_Tetrahedron_Order5() + CASE (6) + ans = QP_Tetrahedron_Order6() + CASE (7) + ans = QP_Tetrahedron_Order7() + CASE (8) + ans = QP_Tetrahedron_Order8() + CASE (9) + ans = QP_Tetrahedron_Order9() + CASE (10) + ans = QP_Tetrahedron_Order10() + CASE (11) + ans = QP_Tetrahedron_Order11() + CASE (12) + ans = QP_Tetrahedron_Order12() + CASE (13) + ans = QP_Tetrahedron_Order13() + CASE (14) + ans = QP_Tetrahedron_Order14() + CASE (15) + ans = QP_Tetrahedron_Order15() + CASE (16) + ans = QP_Tetrahedron_Order16() + CASE (17) + ans = QP_Tetrahedron_Order17() + CASE (18) + ans = QP_Tetrahedron_Order18() + CASE (19) + ans = QP_Tetrahedron_Order19() + CASE (20) + ans = QP_Tetrahedron_Order20() + CASE (21) + ans = QP_Tetrahedron_Order21() + END SELECT +END FUNCTION QuadraturePointTetrahedronSolin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order1() RESULT(ans) + REAL(DFP) :: ans(4, 1) + ans = RESHAPE([ & + & 0.250000000000000, 0.250000000000000, 0.250000000000000, 0.166666666666667 & + & ], [4, 1]) +END FUNCTION QP_Tetrahedron_Order1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order2() RESULT(ans) + REAL(DFP) :: ans(4, 4) + ans = RESHAPE([ & + & 0.585410196624969, 0.138196601125011, 0.138196601125011, 0.041666666666667, & + & 0.138196601125011, 0.138196601125011, 0.138196601125011, 0.041666666666667, & + & 0.138196601125011, 0.138196601125011, 0.585410196624969, 0.041666666666667, & + & 0.138196601125011, 0.585410196624969, 0.138196601125011, 0.041666666666667 & + & ], [4, 4]) +END FUNCTION QP_Tetrahedron_Order2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order3() RESULT(ans) + REAL(DFP) :: ans(4, 5) + ans = RESHAPE([ & + & 0.250000000000000, 0.250000000000000, 0.250000000000000, -0.133333333333333, & + & 0.500000000000000, 0.166666666666667, 0.166666666666667, 0.075000000000000, & + & 0.166666666666667, 0.166666666666667, 0.166666666666667, 0.075000000000000, & + & 0.166666666666667, 0.166666666666667, 0.500000000000000, 0.075000000000000, & + & 0.166666666666667, 0.500000000000000, 0.166666666666667, 0.075000000000000 & + & ], [4, 5]) +END FUNCTION QP_Tetrahedron_Order3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order4() RESULT(ans) + REAL(DFP) :: ans(4, 11) + ans = RESHAPE([ & + & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222, & + & 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888, & + & 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888, & + & 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888, & + & 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888, & + & 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888, & + & 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 & + & ], [4, 11]) +END FUNCTION QP_Tetrahedron_Order4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order5() RESULT(ans) + REAL(DFP) :: ans(4, 14) + ans = RESHAPE([ & + & 0.0927352503109, 0.0927352503109, 0.0927352503109 , 0.01224884051940, & + & 0.7217942490670, 0.0927352503109, 0.0927352503109 , 0.01224884051940, & + & 0.0927352503109, 0.7217942490670, 0.0927352503109 , 0.01224884051940, & + & 0.0927352503109, 0.0927352503109, 0.7217942490670 , 0.01224884051940, & + & 0.3108859192630, 0.3108859192630, 0.3108859192630 , 0.01878132095300, & + & 0.0673422422101, 0.3108859192630, 0.3108859192630 , 0.01878132095300, & + & 0.3108859192630, 0.0673422422101, 0.3108859192630 , 0.01878132095300, & + & 0.3108859192630, 0.3108859192630, 0.0673422422101 , 0.01878132095300, & + & 0.4544962958740, 0.4544962958740, 0.0455037041256 , 0.00709100346285, & + & 0.4544962958740, 0.0455037041256, 0.4544962958740 , 0.00709100346285, & + & 0.0455037041256, 0.4544962958740, 0.4544962958740 , 0.00709100346285, & + & 0.4544962958740, 0.0455037041256, 0.0455037041256 , 0.00709100346285, & + & 0.0455037041256, 0.4544962958740, 0.0455037041256 , 0.00709100346285, & + & 0.0455037041256, 0.0455037041256, 0.4544962958740 , 0.00709100346285 & + & ], [4, 14]) +END FUNCTION QP_Tetrahedron_Order5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order6() RESULT(ans) + REAL(DFP) :: ans(4, 24) + ans = RESHAPE([ & + & 0.2146028712590, 0.2146028712590, 0.2146028712590 , 0.006653791709700, & + & 0.3561913862230, 0.2146028712590, 0.2146028712590 , 0.006653791709700, & + & 0.2146028712590, 0.3561913862230, 0.2146028712590 , 0.006653791709700, & + & 0.2146028712590, 0.2146028712590, 0.3561913862230 , 0.006653791709700, & + & 0.0406739585346, 0.0406739585346, 0.0406739585346 , 0.001679535175883, & + & 0.8779781243960, 0.0406739585346, 0.0406739585346 , 0.001679535175883, & + & 0.0406739585346, 0.8779781243960, 0.0406739585346 , 0.001679535175883, & + & 0.0406739585346, 0.0406739585346, 0.8779781243960 , 0.001679535175883, & + & 0.3223378901420, 0.3223378901420, 0.3223378901420 , 0.009226196923950, & + & 0.0329863295732, 0.3223378901420, 0.3223378901420 , 0.009226196923950, & + & 0.3223378901420, 0.0329863295732, 0.3223378901420 , 0.009226196923950, & + & 0.3223378901420, 0.3223378901420, 0.0329863295732 , 0.009226196923950, & + & 0.0636610018750, 0.0636610018750, 0.2696723314580 , 0.008035714285717, & + & 0.0636610018750, 0.2696723314580, 0.0636610018750 , 0.008035714285717, & + & 0.0636610018750, 0.0636610018750, 0.6030056647920 , 0.008035714285717, & + & 0.0636610018750, 0.6030056647920, 0.0636610018750 , 0.008035714285717, & + & 0.0636610018750, 0.2696723314580, 0.6030056647920 , 0.008035714285717, & + & 0.0636610018750, 0.6030056647920, 0.2696723314580 , 0.008035714285717, & + & 0.2696723314580, 0.0636610018750, 0.0636610018750 , 0.008035714285717, & + & 0.2696723314580, 0.0636610018750, 0.6030056647920 , 0.008035714285717, & + & 0.2696723314580, 0.6030056647920, 0.0636610018750 , 0.008035714285717, & + & 0.6030056647920, 0.0636610018750, 0.2696723314580 , 0.008035714285717, & + & 0.6030056647920, 0.0636610018750, 0.0636610018750 , 0.008035714285717, & + & 0.6030056647920, 0.2696723314580, 0.0636610018750 , 0.008035714285717 & + & ], [4, 24]) +END FUNCTION QP_Tetrahedron_Order6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order7() RESULT(ans) + REAL(DFP) :: ans(4, 31) + ans = RESHAPE([ & + & 0.50000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, & + & 0.50000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, & + & 0.00000000000000, 0.50000000000000, 0.50000000000000 , +0.000970017636685, & + & 0.00000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, & + & 0.00000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, & + & 0.50000000000000, 0.00000000000000, 0.00000000000000 , +0.000970017636685, & + & 0.25000000000000, 0.25000000000000, 0.25000000000000 , +0.018264223466167, & + & 0.07821319233030, 0.07821319233030, 0.07821319233030 , +0.010599941524417, & + & 0.07821319233030, 0.07821319233030, 0.76536042300900 , +0.010599941524417, & + & 0.07821319233030, 0.76536042300900, 0.07821319233030 , +0.010599941524417, & + & 0.76536042300900, 0.07821319233030, 0.07821319233030 , +0.010599941524417, & + & 0.12184321666400, 0.12184321666400, 0.12184321666400 , -0.062517740114333, & + & 0.12184321666400, 0.12184321666400, 0.63447035000800 , -0.062517740114333, & + & 0.12184321666400, 0.63447035000800, 0.12184321666400 , -0.062517740114333, & + & 0.63447035000800, 0.12184321666400, 0.12184321666400 , -0.062517740114333, & + & 0.33253916444600, 0.33253916444600, 0.33253916444600 , +0.004891425263067, & + & 0.33253916444600, 0.33253916444600, 0.00238250666074 , +0.004891425263067, & + & 0.33253916444600, 0.00238250666074, 0.33253916444600 , +0.004891425263067, & + & 0.00238250666074, 0.33253916444600, 0.33253916444600 , +0.004891425263067, & + & 0.10000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, & + & 0.10000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000, & + & 0.10000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, & + & 0.10000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, & + & 0.10000000000000, 0.20000000000000, 0.60000000000000 , +0.027557319224000, & + & 0.10000000000000, 0.60000000000000, 0.20000000000000 , +0.027557319224000, & + & 0.20000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, & + & 0.20000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, & + & 0.20000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, & + & 0.60000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, & + & 0.60000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, & + & 0.60000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000 & + & ], [4, 31]) +END FUNCTION QP_Tetrahedron_Order7 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order8() RESULT(ans) + REAL(DFP) :: ans(4, 43) + ans = RESHAPE([ & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.020500188658667, & + & 0.2068299316110, 0.2068299316110, 0.2068299316110 , +0.014250305822867, & + & 0.2068299316110, 0.2068299316110, 0.3795102051680 , +0.014250305822867, & + & 0.2068299316110, 0.3795102051680, 0.2068299316110 , +0.014250305822867, & + & 0.3795102051680, 0.2068299316110, 0.2068299316110 , +0.014250305822867, & + & 0.0821035883105, 0.0821035883105, 0.0821035883105 , +0.001967033313133, & + & 0.0821035883105, 0.0821035883105, 0.7536892350680 , +0.001967033313133, & + & 0.0821035883105, 0.7536892350680, 0.0821035883105 , +0.001967033313133, & + & 0.7536892350680, 0.0821035883105, 0.0821035883105 , +0.001967033313133, & + & 0.0057819505052, 0.0057819505052, 0.0057819505052 , +0.000169834109093, & + & 0.0057819505052, 0.0057819505052, 0.9826541484840 , +0.000169834109093, & + & 0.0057819505052, 0.9826541484840, 0.0057819505052 , +0.000169834109093, & + & 0.9826541484840, 0.0057819505052, 0.0057819505052 , +0.000169834109093, & + & 0.0505327400189, 0.0505327400189, 0.4494672599810 , +0.004579683824467, & + & 0.0505327400189, 0.4494672599810, 0.0505327400189 , +0.004579683824467, & + & 0.4494672599810, 0.0505327400189, 0.0505327400189 , +0.004579683824467, & + & 0.0505327400189, 0.4494672599810, 0.4494672599810 , +0.004579683824467, & + & 0.4494672599810, 0.0505327400189, 0.4494672599810 , +0.004579683824467, & + & 0.4494672599810, 0.4494672599810, 0.0505327400189 , +0.004579683824467, & + & 0.2290665361170, 0.2290665361170, 0.0356395827885 , +0.005704485808683, & + & 0.2290665361170, 0.0356395827885, 0.2290665361170 , +0.005704485808683, & + & 0.2290665361170, 0.2290665361170, 0.5062273449780 , +0.005704485808683, & + & 0.2290665361170, 0.5062273449780, 0.2290665361170 , +0.005704485808683, & + & 0.2290665361170, 0.0356395827885, 0.5062273449780 , +0.005704485808683, & + & 0.2290665361170, 0.5062273449780, 0.0356395827885 , +0.005704485808683, & + & 0.0356395827885, 0.2290665361170, 0.2290665361170 , +0.005704485808683, & + & 0.0356395827885, 0.2290665361170, 0.5062273449780 , +0.005704485808683, & + & 0.0356395827885, 0.5062273449780, 0.2290665361170 , +0.005704485808683, & + & 0.5062273449780, 0.2290665361170, 0.0356395827885 , +0.005704485808683, & + & 0.5062273449780, 0.2290665361170, 0.2290665361170 , +0.005704485808683, & + & 0.5062273449780, 0.0356395827885, 0.2290665361170 , +0.005704485808683, & + & 0.0366077495532, 0.0366077495532, 0.1904860419350 , +0.002140519141167, & + & 0.0366077495532, 0.1904860419350, 0.0366077495532 , +0.002140519141167, & + & 0.0366077495532, 0.0366077495532, 0.7362984589590 , +0.002140519141167, & + & 0.0366077495532, 0.7362984589590, 0.0366077495532 , +0.002140519141167, & + & 0.0366077495532, 0.1904860419350, 0.7362984589590 , +0.002140519141167, & + & 0.0366077495532, 0.7362984589590, 0.1904860419350 , +0.002140519141167, & + & 0.1904860419350, 0.0366077495532, 0.0366077495532 , +0.002140519141167, & + & 0.1904860419350, 0.0366077495532, 0.7362984589590 , +0.002140519141167, & + & 0.1904860419350, 0.7362984589590, 0.0366077495532 , +0.002140519141167, & + & 0.7362984589590, 0.0366077495532, 0.1904860419350 , +0.002140519141167, & + & 0.7362984589590, 0.0366077495532, 0.0366077495532 , +0.002140519141167, & + & 0.7362984589590, 0.1904860419350, 0.0366077495532 , +0.002140519141167 & + & ], [4, 43]) +END FUNCTION QP_Tetrahedron_Order8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order9() RESULT(ans) + REAL(DFP) :: ans(4, 53) + ans = RESHAPE([ & + & +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167, & + & +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & + & +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083, & + & +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083, & + & +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & + & +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & + & +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500, & + & +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500, & + & +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & + & +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & + & +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167, & + & +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167, & + & +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & + & +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & + & +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500, & + & +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500, & + & +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & + & +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & + & +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & + & +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & + & +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & + & +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500, & + & +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500, & + & +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & + & +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & + & +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & + & +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & + & +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & + & +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & + & +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & + & +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & + & +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & + & +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & + & +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667, & + & +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667, & + & +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & + & +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & + & +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & + & +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & + & +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & + & +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & + & -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & + & -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557, & + & -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & + & -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & + & -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557, & + & -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557, & + & +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & + & +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & + & +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & + & +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & + & +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & + & +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 & + & ], [4, 53]) +END FUNCTION QP_Tetrahedron_Order9 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order10() RESULT(ans) + REAL(DFP) :: ans(4, 126) + ans = QP_Tetrahedron_Order11() +END FUNCTION QP_Tetrahedron_Order10 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order11() RESULT(ans) + REAL(DFP) :: ans(4, 126) + ans = RESHAPE([ & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.4062316284e-05 & + & ], [4, 126]) +END FUNCTION QP_Tetrahedron_Order11 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order12() RESULT(ans) + REAL(DFP) :: ans(4, 210) + ans = QP_Tetrahedron_Order13() +END FUNCTION QP_Tetrahedron_Order12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order13() RESULT(ans) + REAL(DFP) :: ans(4, 210) + ans = RESHAPE([ & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 & + & ], [4, 210]) +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order14() RESULT(ans) + REAL(DFP) :: ans(4, 330) + ans = QP_Tetrahedron_Order15() +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order15() RESULT(ans) + REAL(DFP) :: ans(4, 330) + ans = RESHAPE([ & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 & + & ], [4, 330]) +END FUNCTION QP_Tetrahedron_Order15 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order16() RESULT(ans) + REAL(DFP) :: ans(4, 495) + ans = QP_Tetrahedron_Order17() +END FUNCTION QP_Tetrahedron_Order16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order17() RESULT(ans) + REAL(DFP) :: ans(4, 495) + ans = RESHAPE([ & + & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3573205875e-08 & + & ], [4, 495]) +END FUNCTION QP_Tetrahedron_Order17 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order18() RESULT(ans) + REAL(DFP) :: ans(4, 715) + ans = QP_Tetrahedron_Order19() +END FUNCTION QP_Tetrahedron_Order18 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order19() RESULT(ans) + REAL(DFP) :: ans(4, 715) + ans = RESHAPE([ & + & 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 & + & ], [4, 715]) +END FUNCTION QP_Tetrahedron_Order19 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order20() RESULT(ans) + REAL(DFP) :: ans(4, 1001) + ans = QP_Tetrahedron_Order21() +END FUNCTION QP_Tetrahedron_Order20 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION QP_Tetrahedron_Order21() RESULT(ans) + REAL(DFP) :: ans(4, 1001) + ans = RESHAPE([ & + & 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 & + & ], [4, 1001]) +END FUNCTION QP_Tetrahedron_Order21 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE QuadraturePoint_Tetrahedron_Solin diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 new file mode 100644 index 000000000..58f5d1310 --- /dev/null +++ b/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 @@ -0,0 +1,477 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +! reference +! http://people.sc.fsu.edu/~jburkardt/datasets/quadrature_rules_tri/quadrature_rules_tri.html +! +! Jarle Berntsen, Terje Espelid, +! Algorithm 706, +! DCUTRI: an algorithm for adaptive cubature over a collection of triangles, +! ACM Transactions on Mathematical Software, +! Volume 18, Number 3, September 1992, pages 329-342. +! +! +! Elise deDoncker, Ian Robinson, +! Algorithm 612: Integration over a Triangle Using Nonlinear Extrapolation, +! ACM Transactions on Mathematical Software, +! Volume 10, Number 1, March 1984, pages 17-22. +! +! +! Dirk Laurie, +! Algorithm 584, CUBTRI, Automatic Cubature Over a Triangle, +! ACM Transactions on Mathematical Software, +! Volume 8, Number 2, 1982, pages 210-218. +! +! +! James Lyness, Dennis Jespersen, +! Moderate Degree Symmetric Quadrature Rules for the Triangle, +! Journal of the Institute of Mathematics and its Applications, +! Volume 15, Number 1, February 1975, pages 19-32. +! +! +! Hans Rudolf Schwarz, +! Finite Element Methods, +! Academic Press, 1988, +! ISBN: 0126330107, +! LC: TA347.F5.S3313. +! +! +! Gilbert Strang, George Fix, +! An Analysis of the Finite Element Method, +! Cambridge, 1973, +! ISBN: 096140888X, +! LC: TA335.S77. +! +! +! Arthur Stroud, +! Approximate Calculation of Multiple Integrals, +! Prentice Hall, 1971, +! ISBN: 0130438936, +! LC: QA311.S85. +! +! +! Olgierd Zienkiewicz, +! The Finite Element Method, +! Sixth Edition, +! Butterworth-Heinemann, 2005, +! ISBN: 0750663200, +! LC: TA640.2.Z54 + +module QuadraturePoint_Triangle_InternalUseOnly +USE GlobalData, only: DFP +implicit none +private + +REAL(DFP), DIMENSION(3, 1), PUBLIC, PARAMETER :: TPW1 = & + & TRANSPOSE(RESHAPE([ & + & 0.3333333333333333_DFP, 0.3333333333333333_DFP, 0.5_DFP], & + & [1, 3])) +!! TPW1 has accuracy 1 + +REAL(DFP), DIMENSION(3, 3), PUBLIC, PARAMETER :: TPW3 = & + & TRANSPOSE(RESHAPE([ & + & 0.66666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP, & + & 0.16666666666666666_DFP, 0.66666666666666666_DFP, 0.16666666666666666_DFP, & + & 0.16666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP],& + & [3, 3])) +!! TPW3 has accuracy 2, Strang1 + +REAL(DFP), DIMENSION(3, 4), PUBLIC, PARAMETER :: TPW4 = & + & TRANSPOSE(RESHAPE([ & + & 0.3333333333333333_DFP, 0.2_DFP, 0.2_DFP, & + & 0.6_DFP, 0.3333333333333333_DFP, 0.2_DFP, & + & 0.6_DFP, 0.2_DFP, -0.28125_DFP, & + & 0.2604166666666667_DFP, 0.2604166666666667_DFP, 0.2604166666666667_DFP], [4, 3])) +!! TPW4 has accuracy 3, Strang3 + +REAL(DFP), DIMENSION(3, 6), PUBLIC, PARAMETER :: TPW6 = & + & TRANSPOSE(RESHAPE([0.091576213509771_DFP, & + & 0.816847572980458_DFP, 0.091576213509771_DFP, & + & 0.445948490915965_DFP, 0.445948490915965_DFP, & + & 0.10810301816807_DFP, 0.091576213509771_DFP, & + & 0.091576213509771_DFP, 0.816847572980458_DFP, & + & 0.10810301816807_DFP, 0.445948490915965_DFP, & + & 0.445948490915965_DFP, 0.0549758718227661_DFP, & + & 0.0549758718227661_DFP, 0.0549758718227661_DFP, & + & 0.11169079483905_DFP, 0.11169079483905_DFP, & + & 0.11169079483905_DFP], [6, 3])) +!! TPW6 has accuracy 4, Strang5 + +REAL(DFP), DIMENSION(3, 7), PUBLIC, PARAMETER :: TPW7 = & + & TRANSPOSE(RESHAPE([ & + & 0.3333333333333333_DFP, & + & 0.470142064105115_DFP, 0.05971587178977_DFP, & + & 0.470142064105115_DFP, 0.101286507323456_DFP, & + & 0.797426985353088_DFP, 0.101286507323456_DFP, & + & 0.3333333333333333_DFP, 0.470142064105115_DFP, & + & 0.470142064105115_DFP, 0.05971587178977_DFP, & + & 0.101286507323456_DFP, 0.101286507323456_DFP, & + & 0.797426985353088_DFP, 0.1125_DFP, & + & 0.066197076394253_DFP, 0.066197076394253_DFP, & + & 0.066197076394253_DFP, 0.062969590272413_DFP, & + & 0.062969590272413_DFP, 0.062969590272413_DFP], & + & [7, 3])) +!! TPW7 has accuracy 5, Strang7 + +REAL(DFP), DIMENSION(3, 9), PUBLIC, PARAMETER :: TPW9 = & +& transpose(reshape( [ & + 0.124949503233232_DFP ,& + 0.437525248383384_DFP ,& + 0.437525248383384_DFP ,& + 0.797112651860071_DFP ,& + 0.797112651860071_DFP ,& + 0.165409927389841_DFP ,& + 0.165409927389841_DFP ,& + 0.037477420750088_DFP ,& + 0.037477420750088_DFP ,& + 0.437525248383384_DFP ,& + 0.124949503233232_DFP ,& + 0.437525248383384_DFP ,& + 0.165409927389841_DFP ,& + 0.037477420750088_DFP ,& + 0.797112651860071_DFP ,& + 0.037477420750088_DFP ,& + 0.797112651860071_DFP ,& + 0.165409927389841_DFP ,& + 0.205950504760887_DFP/2.0_DFP ,& + 0.205950504760887_DFP/2.0_DFP ,& + 0.205950504760887_DFP/2.0_DFP ,& + 0.063691414286223_DFP/2.0_DFP ,& + 0.063691414286223_DFP/2.0_DFP ,& + 0.063691414286223_DFP/2.0_DFP ,& + 0.063691414286223_DFP/2.0_DFP ,& + 0.063691414286223_DFP/2.0_DFP ,& + 0.063691414286223_DFP/2.0_DFP], & +& [9,3])) + +!! TPw9 has accuracy 6, Strang8 +!! Do not use this rule + +REAL(DFP), DIMENSION(3, 12), PUBLIC, PARAMETER :: TPW12 = & + & TRANSPOSE(RESHAPE([ & + & 0.063089014491502_DFP, & + & 0.873821971016996_DFP, 0.063089014491502_DFP, & + & 0.24928674517091_DFP, 0.50142650965818_DFP, & + & 0.24928674517091_DFP, 0.310352451033785_DFP, & + & 0.053145049844816_DFP, 0.636502499121399_DFP, & + & 0.636502499121399_DFP, 0.310352451033785_DFP, & + & 0.053145049844816_DFP, 0.063089014491502_DFP, & + & 0.063089014491502_DFP, 0.873821971016996_DFP, & + & 0.24928674517091_DFP, 0.24928674517091_DFP, & + & 0.50142650965818_DFP, 0.053145049844816_DFP, & + & 0.310352451033785_DFP, 0.310352451033785_DFP, & + & 0.053145049844816_DFP, 0.636502499121399_DFP, & + & 0.636502499121399_DFP, 0.025422453185103_DFP, & + & 0.025422453185103_DFP, 0.025422453185103_DFP, & + & 0.058393137863189_DFP, 0.058393137863189_DFP, & + & 0.058393137863189_DFP, 0.041425537809187_DFP, & + & 0.041425537809187_DFP, 0.041425537809187_DFP, & + & 0.041425537809187_DFP, 0.041425537809187_DFP, & + & 0.041425537809187_DFP], [12, 3])) +!! STRANG9, order 12, degree of precision 6. + +REAL(DFP), DIMENSION(3, 13), PUBLIC, PARAMETER :: TPW13 = & +& TRANSPOSE(RESHAPE([ & +0.333333333333333_DFP, & +0.260345966079040_DFP, & +0.260345966079040_DFP, & +0.479308067841920_DFP, & +0.065130102902216_DFP, & +0.065130102902216_DFP, & +0.869739794195568_DFP, & +0.312865496004874_DFP, & +0.638444188569810_DFP, & +0.048690315425316_DFP, & +0.312865496004874_DFP, & +0.638444188569810_DFP, & +0.048690315425316_DFP, & +0.333333333333333_DFP, & +0.260345966079040_DFP, & +0.479308067841920_DFP, & +0.260345966079040_DFP, & +0.065130102902216_DFP, & +0.869739794195568_DFP, & +0.065130102902216_DFP, & +0.638444188569810_DFP, & +0.048690315425316_DFP, & +0.312865496004874_DFP, & +0.048690315425316_DFP, & +0.312865496004874_DFP, & +0.638444188569810_DFP, & +-0.074785022233841_DFP, & +0.087807628716604_DFP, & +0.087807628716604_DFP, & +0.087807628716604_DFP, & +0.026673617804419_DFP, & +0.026673617804419_DFP, & +0.026673617804419_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP & +& ], & +& [13, 3])) +!! STRANG10, order 13, degree of precision 7. + +REAL(DFP), DIMENSION(3, 19), PUBLIC, PARAMETER :: TPW19b = & + & TRANSPOSE(RESHAPE( & +& [0.3333333333333333_DFP, 0.7974269853530872_DFP, & +& 0.1012865073234563_DFP, 0.1012865073234563_DFP, & +& 0.0597158717897698_DFP, 0.4701420641051151_DFP, & +& 0.4701420641051151_DFP, 0.5357953464498992_DFP, & +& 0.2321023267750504_DFP, 0.2321023267750504_DFP, & +& 0.9410382782311209_DFP, 0.0294808608844396_DFP, & +& 0.0294808608844396_DFP, 0.7384168123405100_DFP, & +& 0.7384168123405100_DFP, 0.2321023267750504_DFP, & +& 0.2321023267750504_DFP, 0.0294808608844396_DFP, & +& 0.0294808608844396_DFP, & +& 0.3333333333333333_DFP, 0.1012865073234563_DFP, & +& 0.7974269853530872_DFP, 0.1012865073234563_DFP, & +& 0.4701420641051151_DFP, 0.0597158717897698_DFP, & +& 0.4701420641051151_DFP, 0.2321023267750504_DFP, & +& 0.5357953464498992_DFP, 0.2321023267750504_DFP, & +& 0.0294808608844396_DFP, 0.9410382782311209_DFP, & +& 0.0294808608844396_DFP, 0.2321023267750504_DFP, & +& 0.0294808608844396_DFP, 0.7384168123405100_DFP, & +& 0.0294808608844396_DFP, 0.7384168123405100_DFP, & +& 0.2321023267750504_DFP, & +& 0.5_DFP * 0.0378610912003147_DFP, 0.5_DFP * 0.0376204254131829_DFP, & +& 0.5_DFP * 0.0376204254131829_DFP, & +& 0.5_DFP * 0.0376204254131829_DFP, 0.5_DFP * 0.0783573522441174_DFP, & +& 0.5_DFP * 0.0783573522441174_DFP, & +& 0.5_DFP * 0.0783573522441174_DFP, 0.5_DFP * 0.1162714796569659_DFP, & +& 0.5_DFP * 0.1162714796569659_DFP, & +& 0.5_DFP * 0.1162714796569659_DFP, 0.5_DFP * 0.0134442673751655_DFP, & +& 0.5_DFP * 0.0134442673751655_DFP, & +& 0.5_DFP * 0.0134442673751655_DFP, 0.5_DFP * 0.0375097224552317_DFP, & +& 0.5_DFP * 0.0375097224552317_DFP, & +& 0.5_DFP * 0.0375097224552317_DFP, 0.5_DFP * 0.0375097224552317_DFP, & +& 0.5_DFP * 0.0375097224552317_DFP, & +& 0.5_DFP * 0.0375097224552317_DFP & +& ], & +& [19, 3])) + +!! TOMS584_19, order 19, degree of precision 8, a rule from ACM TOMS algorithm 584. + + +REAL(DFP), DIMENSION(3, 19), PUBLIC, PARAMETER :: TPW19 = & + & TRANSPOSE(RESHAPE( & +& [0.33333333333333331, 2.06349616025259287E-002, 0.48968251919873701, & +& 0.48968251919873701, 0.12582081701412900, 0.43708959149293553, & +& 0.43708959149293553, 0.62359292876193562, 0.18820353561903219, & +& 0.18820353561903219, 0.91054097321109406, 4.47295133944529688E-002, & +& 4.47295133944529688E-002, 0.74119859878449801, 0.74119859878449801, & +& 3.68384120547362581E-002, 3.68384120547362581E-002, 0.22196298916076573, & +& 0.22196298916076573, & +& 0.33333333333333331, 0.48968251919873701, & +& 2.06349616025259287E-002, 0.48968251919873701, & +& 0.43708959149293553, 0.12582081701412900, & +& 0.43708959149293553, 0.18820353561903219, & +& 0.62359292876193562, 0.18820353561903219, & +& 4.47295133944529688E-002, 0.91054097321109406, & +& 4.47295133944529688E-002, 3.68384120547362581E-002, & +& 0.22196298916076573, 0.74119859878449801, 0.22196298916076573, & +& 0.74119859878449801, 3.68384120547362581E-002, & +& 0.5 * 9.71357962827961025E-002, 0.5 * 3.13347002271398278E-002, & +& 0.5 * 3.13347002271398278E-002, 0.5 * 3.13347002271398278E-002, & +& 0.5 * 7.78275410047754301E-002, 0.5 * 7.78275410047754301E-002, & +& 0.5 * 7.78275410047754301E-002, 0.5 * 7.96477389272090969E-002, & +& 0.5 * 7.96477389272090969E-002, 0.5 * 7.96477389272090969E-002, & +& 0.5 * 2.55776756586981006E-002, 0.5 * 2.55776756586981006E-002, & +& 0.5 * 2.55776756586981006E-002, 0.5 * 4.32835393772893970E-002, & +& 0.5 * 4.32835393772893970E-002, 0.5 * 4.32835393772893970E-002, & +& 0.5 * 4.32835393772893970E-002, 0.5 * 4.32835393772893970E-002, & +& 0.5 * 4.32835393772893970E-002], & +& [19, 3])) + +!! TOMS612_19, order 19, degree of precision 9, a rule from ACM TOMS algorithm 612 + +REAL(DFP), DIMENSION(3, 28), PUBLIC, PARAMETER :: TPW28 = & + & TRANSPOSE(RESHAPE( & +&[0.33333333333333333_DFP, 0.9480217181434233_DFP, & +& 0.02598914092828833_DFP, 0.02598914092828833_DFP, & +& 0.8114249947041546_DFP, 0.09428750264792270_DFP, & +& 0.09428750264792270_DFP, 0.01072644996557060_DFP, & +& 0.4946367750172147_DFP, 0.4946367750172147_DFP, & +& 0.5853132347709715_DFP, 0.2073433826145142_DFP, & +& 0.2073433826145142_DFP, 0.1221843885990187_DFP, & +& 0.4389078057004907_DFP, 0.4389078057004907_DFP, & +& 0.6779376548825902_DFP, 0.6779376548825902_DFP, & +& 0.04484167758913055_DFP, 0.04484167758913055_DFP, & +& 0.27722066752827925_DFP, 0.27722066752827925_DFP, & +& 0.8588702812826364_DFP, 0.8588702812826364_DFP, & +& 0.0000000000000000_DFP, 0.0000000000000000_DFP, & +& 0.1411297187173636_DFP, 0.1411297187173636_DFP, & +& 0.333333333333333333_DFP, 0.02598914092828833_DFP, & +& 0.9480217181434233_DFP, 0.02598914092828833_DFP, & +& 0.09428750264792270_DFP, 0.8114249947041546_DFP, & +& 0.09428750264792270_DFP, 0.4946367750172147_DFP, & +& 0.01072644996557060_DFP, 0.4946367750172147_DFP, & +& 0.2073433826145142_DFP, 0.5853132347709715_DFP, & +& 0.2073433826145142_DFP, 0.4389078057004907_DFP, & +& 0.1221843885990187_DFP, 0.4389078057004907_DFP, & +& 0.04484167758913055_DFP, 0.27722066752827925_DFP, & +& 0.6779376548825902_DFP, 0.27722066752827925_DFP, & +& 0.6779376548825902_DFP, 0.04484167758913055_DFP, & +& 0.00000000000000000_DFP, 0.1411297187173636_DFP, & +& 0.8588702812826364_DFP, 0.1411297187173636_DFP, & +& 0.8588702812826364_DFP, 0.0000000000000000_DFP, & +& 0.5_DFP * 0.08797730116222190_DFP, 0.5_DFP * 0.008744311553736190_DFP, & +& 0.5_DFP * 0.008744311553736190_DFP, & +& 0.5_DFP * 0.008744311553736190_DFP, 0.5_DFP * 0.03808157199393533_DFP, & +& 0.5_DFP * 0.03808157199393533_DFP, & +& 0.5_DFP * 0.03808157199393533_DFP, 0.5_DFP * 0.01885544805613125_DFP, & +& 0.5_DFP * 0.01885544805613125_DFP, & +& 0.5_DFP * 0.01885544805613125_DFP, 0.5_DFP * 0.07215969754474100_DFP, & +& 0.5_DFP * 0.07215969754474100_DFP, & +& 0.5_DFP * 0.07215969754474100_DFP, 0.5_DFP * 0.06932913870553720_DFP, & +& 0.5_DFP * 0.06932913870553720_DFP, & +& 0.5_DFP * 0.06932913870553720_DFP, 0.5_DFP * 0.04105631542928860_DFP, & +& 0.5_DFP * 0.04105631542928860_DFP, & +& 0.5_DFP * 0.04105631542928860_DFP, 0.5_DFP * 0.04105631542928860_DFP, & +& 0.5_DFP * 0.04105631542928860_DFP, & +& 0.5_DFP * 0.04105631542928860_DFP, 0.5_DFP * 0.007362383783300573_DFP, & +& 0.5_DFP * 0.007362383783300573_DFP, & +& 0.5_DFP * 0.007362383783300573_DFP, 0.5_DFP * 0.007362383783300573_DFP, & +& 0.5_DFP * 0.007362383783300573_DFP, & +& 0.5_DFP * 0.007362383783300573_DFP], & +& [28, 3])) + +!! TOMS612_28, order 28, degree of precision 11, a rule from ACM TOMS algorithm 612. + +REAL(DFP), DIMENSION(3, 37), PUBLIC, PARAMETER :: TPW37 = & + & TRANSPOSE(RESHAPE([ & +0.333333333333333333333333333333_DFP, & +0.950275662924105565450352089520_DFP, & +0.024862168537947217274823955239_DFP, & +0.024862168537947217274823955239_DFP, & +0.171614914923835347556304795551_DFP, & +0.414192542538082326221847602214_DFP, & +0.414192542538082326221847602214_DFP, & +0.539412243677190440263092985511_DFP, & +0.230293878161404779868453507244_DFP, & +0.230293878161404779868453507244_DFP, & +0.772160036676532561750285570113_DFP, & +0.113919981661733719124857214943_DFP, & +0.113919981661733719124857214943_DFP, & +0.009085399949835353883572964740_DFP, & +0.495457300025082323058213517632_DFP, & +0.495457300025082323058213517632_DFP, & +0.062277290305886993497083640527_DFP, & +0.468861354847056503251458179727_DFP, & +0.468861354847056503251458179727_DFP, & +0.022076289653624405142446876931_DFP, & +0.022076289653624405142446876931_DFP, & +0.851306504174348550389457672223_DFP, & +0.851306504174348550389457672223_DFP, & +0.126617206172027096933163647918_DFP, & +0.126617206172027096933163647918_DFP, & +0.018620522802520968955913511549_DFP, & +0.018620522802520968955913511549_DFP, & +0.689441970728591295496647976487_DFP, & +0.689441970728591295496647976487_DFP, & +0.291937506468887771754472382212_DFP, & +0.291937506468887771754472382212_DFP, & +0.096506481292159228736516560903_DFP, & +0.096506481292159228736516560903_DFP, & +0.635867859433872768286976979827_DFP, & +0.635867859433872768286976979827_DFP, & +0.267625659273967961282458816185_DFP, & +0.267625659273967961282458816185_DFP, & +0.333333333333333333333333333333_DFP, & +0.024862168537947217274823955239_DFP, & +0.950275662924105565450352089520_DFP, & +0.024862168537947217274823955239_DFP, & +0.414192542538082326221847602214_DFP, & +0.171614914923835347556304795551_DFP, & +0.414192542538082326221847602214_DFP, & +0.230293878161404779868453507244_DFP, & +0.539412243677190440263092985511_DFP, & +0.230293878161404779868453507244_DFP, & +0.113919981661733719124857214943_DFP, & +0.772160036676532561750285570113_DFP, & +0.113919981661733719124857214943_DFP, & +0.495457300025082323058213517632_DFP, & +0.009085399949835353883572964740_DFP, & +0.495457300025082323058213517632_DFP, & +0.468861354847056503251458179727_DFP, & +0.062277290305886993497083640527_DFP, & +0.468861354847056503251458179727_DFP, & +0.851306504174348550389457672223_DFP, & +0.126617206172027096933163647918_DFP, & +0.022076289653624405142446876931_DFP, & +0.126617206172027096933163647918_DFP, & +0.022076289653624405142446876931_DFP, & +0.851306504174348550389457672223_DFP, & +0.689441970728591295496647976487_DFP, & +0.291937506468887771754472382212_DFP, & +0.018620522802520968955913511549_DFP, & +0.291937506468887771754472382212_DFP, & +0.018620522802520968955913511549_DFP, & +0.689441970728591295496647976487_DFP, & +0.635867859433872768286976979827_DFP, & +0.267625659273967961282458816185_DFP, & +0.096506481292159228736516560903_DFP, & +0.267625659273967961282458816185_DFP, & +0.096506481292159228736516560903_DFP, & +0.635867859433872768286976979827_DFP, & +0.5_DFP * 0.051739766065744133555179145422_DFP, & +0.5_DFP * 0.008007799555564801597804123460_DFP, & +0.5_DFP * 0.008007799555564801597804123460_DFP, & +0.5_DFP * 0.008007799555564801597804123460_DFP, & +0.5_DFP * 0.046868898981821644823226732071_DFP, & +0.5_DFP * 0.046868898981821644823226732071_DFP, & +0.5_DFP * 0.046868898981821644823226732071_DFP, & +0.5_DFP * 0.046590940183976487960361770070_DFP, & +0.5_DFP * 0.046590940183976487960361770070_DFP, & +0.5_DFP * 0.046590940183976487960361770070_DFP, & +0.5_DFP * 0.031016943313796381407646220131_DFP, & +0.5_DFP * 0.031016943313796381407646220131_DFP, & +0.5_DFP * 0.031016943313796381407646220131_DFP, & +0.5_DFP * 0.010791612736631273623178240136_DFP, & +0.5_DFP * 0.010791612736631273623178240136_DFP, & +0.5_DFP * 0.010791612736631273623178240136_DFP, & +0.5_DFP * 0.032195534242431618819414482205_DFP, & +0.5_DFP * 0.032195534242431618819414482205_DFP, & +0.5_DFP * 0.032195534242431618819414482205_DFP, & +0.5_DFP * 0.015445834210701583817692900053_DFP, & +0.5_DFP * 0.015445834210701583817692900053_DFP, & +0.5_DFP * 0.015445834210701583817692900053_DFP, & +0.5_DFP * 0.015445834210701583817692900053_DFP, & +0.5_DFP * 0.015445834210701583817692900053_DFP, & +0.5_DFP * 0.015445834210701583817692900053_DFP, & +0.5_DFP * 0.017822989923178661888748319485_DFP, & +0.5_DFP * 0.017822989923178661888748319485_DFP, & +0.5_DFP * 0.017822989923178661888748319485_DFP, & +0.5_DFP * 0.017822989923178661888748319485_DFP, & +0.5_DFP * 0.017822989923178661888748319485_DFP, & +0.5_DFP * 0.017822989923178661888748319485_DFP, & +0.5_DFP * 0.037038683681384627918546472190_DFP, & +0.5_DFP * 0.037038683681384627918546472190_DFP, & +0.5_DFP * 0.037038683681384627918546472190_DFP, & +0.5_DFP * 0.037038683681384627918546472190_DFP, & +0.5_DFP * 0.037038683681384627918546472190_DFP, & +0.5_DFP * 0.037038683681384627918546472190_DFP], & +[37, 3])) + +!!TOMS706_37, order 37, degree of precision 13, a rule from ACM TOMS algorithm 706. + + + +end module QuadraturePoint_Triangle_InternalUseOnly diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 new file mode 100644 index 000000000..9e154630b --- /dev/null +++ b/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 @@ -0,0 +1,2170 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +! reference +! 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 +USE GlobalData, only: DFP, I4B +implicit none +private +public :: QuadratureNumberTriangleSolin +public :: QuadraturePointTriangleSolin +public :: QuadraturePointTriangleSolin_ + +REAL(DFP), DIMENSION(3, 1), PUBLIC, PARAMETER :: triSolin1 = & + & TRANSPOSE(RESHAPE([ & + & 0.3333333333333333_DFP, 0.3333333333333333_DFP, 0.5_DFP], & + & [1, 3])) +!! triSolin1 has accuracy 1 + +REAL(DFP), DIMENSION(3, 3), PUBLIC, PARAMETER :: triSolin3 = & + & TRANSPOSE(RESHAPE([ & + & 0.66666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP, & + & 0.16666666666666666_DFP, 0.66666666666666666_DFP, 0.16666666666666666_DFP, & + & 0.16666666666666666_DFP, 0.16666666666666666_DFP, 0.16666666666666666_DFP],& + & [3, 3])) +!! triSolin3 has accuracy 2, Strang1 + +REAL(DFP), DIMENSION(3, 4), PUBLIC, PARAMETER :: triSolin4 = & + & TRANSPOSE(RESHAPE([ & + & 0.3333333333333333_DFP, 0.2_DFP, 0.2_DFP, & + & 0.6_DFP, 0.3333333333333333_DFP, 0.2_DFP, & + & 0.6_DFP, 0.2_DFP, -0.28125_DFP, & + & 0.2604166666666667_DFP, 0.2604166666666667_DFP, 0.2604166666666667_DFP], [4, 3])) +!! triSolin4 has accuracy 3, Strang3 +!! 1 negative weight, 0 points outside of the triangle, total sum of the +!! weights is 0.5 + +REAL(DFP), DIMENSION(3, 6), PUBLIC, PARAMETER :: triSolin6 = & + & TRANSPOSE(RESHAPE([0.091576213509771_DFP, & + & 0.816847572980458_DFP, 0.091576213509771_DFP, & + & 0.445948490915965_DFP, 0.445948490915965_DFP, & + & 0.10810301816807_DFP, 0.091576213509771_DFP, & + & 0.091576213509771_DFP, 0.816847572980458_DFP, & + & 0.10810301816807_DFP, 0.445948490915965_DFP, & + & 0.445948490915965_DFP, 0.0549758718227661_DFP, & + & 0.0549758718227661_DFP, 0.0549758718227661_DFP, & + & 0.11169079483905_DFP, 0.11169079483905_DFP, & + & 0.11169079483905_DFP], [6, 3])) +!! triSolin6 has accuracy 4, Strang5 +!! 0 negative weights, 0 points outside of the triangle, total sum of the +!! weights is 0.5 + +REAL(DFP), DIMENSION(3, 7), PUBLIC, PARAMETER :: triSolin7 = & + & TRANSPOSE(RESHAPE([ & + & 0.3333333333333333_DFP, & + & 0.470142064105115_DFP, 0.05971587178977_DFP, & + & 0.470142064105115_DFP, 0.101286507323456_DFP, & + & 0.797426985353088_DFP, 0.101286507323456_DFP, & + & 0.3333333333333333_DFP, 0.470142064105115_DFP, & + & 0.470142064105115_DFP, 0.05971587178977_DFP, & + & 0.101286507323456_DFP, 0.101286507323456_DFP, & + & 0.797426985353088_DFP, 0.1125_DFP, & + & 0.066197076394253_DFP, 0.066197076394253_DFP, & + & 0.066197076394253_DFP, 0.062969590272413_DFP, & + & 0.062969590272413_DFP, 0.062969590272413_DFP], & + & [7, 3])) +!! triSolin7 has accuracy 5, Strang7 +!! 0 negative weights, 0 points outside of the triangle, total sum of the +!! weights is 0.5 + +REAL(DFP), DIMENSION(3, 12), PUBLIC, PARAMETER :: triSolin12 = & +& transpose(reshape( [ & +0.249286745170910_DFP, & +0.249286745170910_DFP, & +0.501426509658179_DFP, & +0.063089014491502_DFP, & +0.063089014491502_DFP, & +0.873821971016996_DFP, & +0.310352451033785_DFP, & +0.636502499121399_DFP, & +0.053145049844816_DFP, & +0.310352451033785_DFP, & +0.636502499121399_DFP, & +0.053145049844816_DFP, & +0.249286745170910_DFP, & +0.501426509658179_DFP, & +0.249286745170910_DFP, & +0.063089014491502_DFP, & +0.873821971016996_DFP, & +0.063089014491502_DFP, & +0.636502499121399_DFP, & +0.053145049844816_DFP, & +0.310352451033785_DFP, & +0.053145049844816_DFP, & +0.310352451033785_DFP, & +0.636502499121399_DFP, & +0.058393137863189_DFP, & +0.058393137863189_DFP, & +0.058393137863189_DFP, & +0.025422453185104_DFP, & +0.025422453185104_DFP, & +0.025422453185104_DFP, & +0.041425537809187_DFP, & +0.041425537809187_DFP, & +0.041425537809187_DFP, & +0.041425537809187_DFP, & +0.041425537809187_DFP, & +0.041425537809187_DFP & +& ], & +& [12,3])) + +!! accuracy = 6 +!! 0 negative weights, 0 points outside of the triangle, total sum of the +!! weights is 0.5 + +REAL(DFP), DIMENSION(3, 13), PUBLIC, PARAMETER :: triSolin13 = & +& TRANSPOSE(RESHAPE([ & +0.333333333333333_DFP, & +0.260345966079040_DFP, & +0.260345966079040_DFP, & +0.479308067841920_DFP, & +0.065130102902216_DFP, & +0.065130102902216_DFP, & +0.869739794195568_DFP, & +0.312865496004874_DFP, & +0.638444188569810_DFP, & +0.048690315425316_DFP, & +0.312865496004874_DFP, & +0.638444188569810_DFP, & +0.048690315425316_DFP, & +0.333333333333333_DFP, & +0.260345966079040_DFP, & +0.479308067841920_DFP, & +0.260345966079040_DFP, & +0.065130102902216_DFP, & +0.869739794195568_DFP, & +0.065130102902216_DFP, & +0.638444188569810_DFP, & +0.048690315425316_DFP, & +0.312865496004874_DFP, & +0.048690315425316_DFP, & +0.312865496004874_DFP, & +0.638444188569810_DFP, & +-0.074785022233841_DFP, & +0.087807628716604_DFP, & +0.087807628716604_DFP, & +0.087807628716604_DFP, & +0.026673617804419_DFP, & +0.026673617804419_DFP, & +0.026673617804419_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP, & +0.038556880445128_DFP & +& ], & +& [13, 3])) +!! STRANG10, order 13, degree of precision 7. +!! 1 negative weight, 0 points outside of the triangle, total sum of the +!! weights is 0.5 + +REAL(DFP), DIMENSION(3, 16), PUBLIC, PARAMETER :: triSolin16 = & +& TRANSPOSE(RESHAPE([ & +0.333333333333333_DFP, & +0.459292588292723_DFP, & +0.459292588292723_DFP, & +0.081414823414554_DFP, & +0.170569307751760_DFP, & +0.170569307751760_DFP, & +0.658861384496480_DFP, & +0.050547228317031_DFP, & +0.050547228317031_DFP, & +0.898905543365938_DFP, & +0.263112829634638_DFP, & +0.728492392955404_DFP, & +0.008394777409958_DFP, & +0.263112829634638_DFP, & +0.728492392955404_DFP, & +0.008394777409958_DFP, & +0.333333333333333_DFP, & +0.459292588292723_DFP, & +0.081414823414554_DFP, & +0.459292588292723_DFP, & +0.170569307751760_DFP, & +0.658861384496480_DFP, & +0.170569307751760_DFP, & +0.050547228317031_DFP, & +0.898905543365938_DFP, & +0.050547228317031_DFP, & +0.728492392955404_DFP, & +0.008394777409958_DFP, & +0.263112829634638_DFP, & +0.008394777409958_DFP, & +0.263112829634638_DFP, & +0.728492392955404_DFP, & +0.072157803838894_DFP, & +0.047545817133643_DFP, & +0.047545817133643_DFP, & +0.047545817133643_DFP, & +0.051608685267359_DFP, & +0.051608685267359_DFP, & +0.051608685267359_DFP, & +0.016229248811599_DFP, & +0.016229248811599_DFP, & +0.016229248811599_DFP, & +0.013615157087217_DFP, & +0.013615157087217_DFP, & +0.013615157087217_DFP, & +0.013615157087217_DFP, & +0.013615157087217_DFP, & +0.013615157087217_DFP & +& ], & +& [16, 3])) +!! degree of precision 16. +!! 0 negative weights, 0 points outside of the triangle, total sum of the +!! weights is 0.5 + +REAL(DFP), DIMENSION(3, 19), PUBLIC, PARAMETER :: triSolin19 = & +& TRANSPOSE(RESHAPE([ & +0.3333333333330_DFP, & +0.4896825191990_DFP, & +0.4896825191990_DFP, & +0.0206349616025_DFP, & +0.4370895914930_DFP, & +0.4370895914930_DFP, & +0.1258208170140_DFP, & +0.1882035356190_DFP, & +0.1882035356190_DFP, & +0.6235929287620_DFP, & +0.0447295133945_DFP, & +0.0447295133945_DFP, & +0.9105409732110_DFP, & +0.2219629891610_DFP, & +0.7411985987840_DFP, & +0.0368384120547_DFP, & +0.2219629891610_DFP, & +0.7411985987840_DFP, & +0.0368384120547_DFP, & +0.3333333333333_DFP, & +0.4896825191990_DFP, & +0.0206349616025_DFP, & +0.4896825191990_DFP, & +0.4370895914930_DFP, & +0.1258208170140_DFP, & +0.4370895914930_DFP, & +0.1882035356190_DFP, & +0.6235929287620_DFP, & +0.1882035356190_DFP, & +0.0447295133945_DFP, & +0.9105409732110_DFP, & +0.0447295133945_DFP, & +0.7411985987840_DFP, & +0.0368384120547_DFP, & +0.2219629891610_DFP, & +0.0368384120547_DFP, & +0.2219629891610_DFP, & +0.7411985987840_DFP, & +0.04856789814140_DFP, & +0.01566735011355_DFP, & +0.01566735011355_DFP, & +0.01566735011355_DFP, & +0.03891377050240_DFP, & +0.03891377050240_DFP, & +0.03891377050240_DFP, & +0.03982386946360_DFP, & +0.03982386946360_DFP, & +0.03982386946360_DFP, & +0.01278883782935_DFP, & +0.01278883782935_DFP, & +0.01278883782935_DFP, & +0.02164176968865_DFP, & +0.02164176968865_DFP, & +0.02164176968865_DFP, & +0.02164176968865_DFP, & +0.02164176968865_DFP, & +0.02164176968865_DFP & +], [19, 3])) + +!! TOMS612_19, order 19, degree of precision 9, a rule from ACM TOMS algorithm 612 + + +REAL(DFP), DIMENSION(3, 25), PUBLIC, PARAMETER :: triSolin25 = & +& TRANSPOSE(RESHAPE([ & +0.3333333333330_DFP, & +0.4855776333840_DFP, & +0.4855776333840_DFP, & +0.0288447332327_DFP, & +0.1094815754850_DFP, & +0.1094815754850_DFP, & +0.7810368490300_DFP, & +0.3079398387640_DFP, & +0.5503529418210_DFP, & +0.1417072194150_DFP, & +0.3079398387640_DFP, & +0.5503529418210_DFP, & +0.1417072194150_DFP, & +0.2466725606400_DFP, & +0.7283239045970_DFP, & +0.0250035347627_DFP, & +0.2466725606400_DFP, & +0.7283239045970_DFP, & +0.0250035347627_DFP, & +0.0668032510122_DFP, & +0.9236559335870_DFP, & +0.0095408154003_DFP, & +0.0668032510122_DFP, & +0.9236559335870_DFP, & +0.0095408154003_DFP, & +0.3333333333330_DFP, & +0.4855776333840_DFP, & +0.0288447332327_DFP, & +0.4855776333840_DFP, & +0.1094815754850_DFP, & +0.7810368490300_DFP, & +0.1094815754850_DFP, & +0.5503529418210_DFP, & +0.1417072194150_DFP, & +0.3079398387640_DFP, & +0.1417072194150_DFP, & +0.3079398387640_DFP, & +0.5503529418210_DFP, & +0.7283239045970_DFP, & +0.0250035347627_DFP, & +0.2466725606400_DFP, & +0.0250035347627_DFP, & +0.2466725606400_DFP, & +0.7283239045970_DFP, & +0.9236559335870_DFP, & +0.0095408154003_DFP, & +0.0668032510122_DFP, & +0.0095408154003_DFP, & +0.0668032510122_DFP, & +0.9236559335870_DFP, & +0.04540899519140_DFP, & +0.01836297887825_DFP, & +0.01836297887825_DFP, & +0.01836297887825_DFP, & +0.02266052971775_DFP, & +0.02266052971775_DFP, & +0.02266052971775_DFP, & +0.03637895842270_DFP, & +0.03637895842270_DFP, & +0.03637895842270_DFP, & +0.03637895842270_DFP, & +0.03637895842270_DFP, & +0.03637895842270_DFP, & +0.01416362126555_DFP, & +0.01416362126555_DFP, & +0.01416362126555_DFP, & +0.01416362126555_DFP, & +0.01416362126555_DFP, & +0.01416362126555_DFP, & +0.00471083348185_DFP, & +0.00471083348185_DFP, & +0.00471083348185_DFP, & +0.00471083348185_DFP, & +0.00471083348185_DFP, & +0.00471083348185_DFP & +], [25, 3])) + +REAL(DFP), DIMENSION(3, 27), PUBLIC, PARAMETER :: triSolin27 = & +& TRANSPOSE(RESHAPE([ & ++0.5346110482710_DFP, & +-0.0692220965415_DFP, & ++0.5346110482710_DFP, & ++0.3989693029660_DFP, & ++0.2020613940680_DFP, & ++0.3989693029660_DFP, & ++0.2033099004310_DFP, & ++0.5933801991370_DFP, & ++0.2033099004310_DFP, & ++0.1193509122830_DFP, & ++0.7612981754350_DFP, & ++0.1193509122830_DFP, & ++0.0323649481113_DFP, & ++0.9352701037770_DFP, & ++0.0323649481113_DFP, & ++0.5932012134280_DFP, & ++0.0501781383105_DFP, & ++0.3566206482610_DFP, & ++0.0501781383105_DFP, & ++0.3566206482610_DFP, & ++0.5932012134280_DFP, & ++0.8074890031600_DFP, & ++0.0210220165362_DFP, & ++0.1714889803040_DFP, & ++0.0210220165362_DFP, & ++0.1714889803040_DFP, & ++0.8074890031600_DFP, & ++0.5346110482710_DFP, & ++0.5346110482710_DFP, & +-0.0692220965415_DFP, & ++0.3989693029660_DFP, & ++0.3989693029660_DFP, & ++0.2020613940680_DFP, & ++0.2033099004310_DFP, & ++0.2033099004310_DFP, & ++0.5933801991370_DFP, & ++0.1193509122830_DFP, & ++0.1193509122830_DFP, & ++0.7612981754350_DFP, & ++0.0323649481113_DFP, & ++0.0323649481113_DFP, & ++0.9352701037770_DFP, & ++0.3566206482610_DFP, & ++0.5932012134280_DFP, & ++0.0501781383105_DFP, & ++0.3566206482610_DFP, & ++0.5932012134280_DFP, & ++0.0501781383105_DFP, & ++0.1714889803040_DFP, & ++0.8074890031600_DFP, & ++0.0210220165362_DFP, & ++0.1714889803040_DFP, & ++0.8074890031600_DFP, & ++0.0210220165362_DFP, & +0.00046350316448_DFP, & +0.00046350316448_DFP, & +0.00046350316448_DFP, & +0.03857476745740_DFP, & +0.03857476745740_DFP, & +0.03857476745740_DFP, & +0.02966148869040_DFP, & +0.02966148869040_DFP, & +0.02966148869040_DFP, & +0.01809227025170_DFP, & +0.01809227025170_DFP, & +0.01809227025170_DFP, & +0.00682986550135_DFP, & +0.00682986550135_DFP, & +0.00682986550135_DFP, & +0.02616855598110_DFP, & +0.02616855598110_DFP, & +0.02616855598110_DFP, & +0.02616855598110_DFP, & +0.02616855598110_DFP, & +0.02616855598110_DFP, & +0.01035382981955_DFP, & +0.01035382981955_DFP, & +0.01035382981955_DFP, & +0.01035382981955_DFP, & +0.01035382981955_DFP, & +0.01035382981955_DFP & +], [27, 3])) + +REAL(DFP), DIMENSION(3, 33), PUBLIC, PARAMETER :: triSolin33 = & +& TRANSPOSE(RESHAPE([ & +0.4882173897740_DFP, & +0.4882173897740_DFP, & +0.0235652204524_DFP, & +0.4397243922940_DFP, & +0.4397243922940_DFP, & +0.1205512154110_DFP, & +0.2712103850120_DFP, & +0.2712103850120_DFP, & +0.4575792299760_DFP, & +0.1275761455420_DFP, & +0.1275761455420_DFP, & +0.7448477089170_DFP, & +0.0213173504532_DFP, & +0.0213173504532_DFP, & +0.9573652990940_DFP, & +0.2757132696860_DFP, & +0.6089432357800_DFP, & +0.1153434945350_DFP, & +0.2757132696860_DFP, & +0.6089432357800_DFP, & +0.1153434945350_DFP, & +0.2813255809900_DFP, & +0.6958360867880_DFP, & +0.0228383322223_DFP, & +0.2813255809900_DFP, & +0.6958360867880_DFP, & +0.0228383322223_DFP, & +0.1162519159080_DFP, & +0.8580140335440_DFP, & +0.0257340505483_DFP, & +0.1162519159080_DFP, & +0.8580140335440_DFP, & +0.0257340505483_DFP, & +0.4882173897740_DFP, & +0.0235652204524_DFP, & +0.4882173897740_DFP, & +0.4397243922940_DFP, & +0.1205512154110_DFP, & +0.4397243922940_DFP, & +0.2712103850120_DFP, & +0.4575792299760_DFP, & +0.2712103850120_DFP, & +0.1275761455420_DFP, & +0.7448477089170_DFP, & +0.1275761455420_DFP, & +0.0213173504532_DFP, & +0.9573652990940_DFP, & +0.0213173504532_DFP, & +0.6089432357800_DFP, & +0.1153434945350_DFP, & +0.2757132696860_DFP, & +0.1153434945350_DFP, & +0.2757132696860_DFP, & +0.6089432357800_DFP, & +0.6958360867880_DFP, & +0.0228383322223_DFP, & +0.2813255809900_DFP, & +0.0228383322223_DFP, & +0.2813255809900_DFP, & +0.6958360867880_DFP, & +0.8580140335440_DFP, & +0.0257340505483_DFP, & +0.1162519159080_DFP, & +0.0257340505483_DFP, & +0.1162519159080_DFP, & +0.8580140335440_DFP, & +0.01286553322025_DFP, & +0.01286553322025_DFP, & +0.01286553322025_DFP, & +0.02184627226900_DFP, & +0.02184627226900_DFP, & +0.02184627226900_DFP, & +0.03142911210895_DFP, & +0.03142911210895_DFP, & +0.03142911210895_DFP, & +0.01739805646535_DFP, & +0.01739805646535_DFP, & +0.01739805646535_DFP, & +0.00308313052578_DFP, & +0.00308313052578_DFP, & +0.00308313052578_DFP, & +0.02018577888320_DFP, & +0.02018577888320_DFP, & +0.02018577888320_DFP, & +0.02018577888320_DFP, & +0.02018577888320_DFP, & +0.02018577888320_DFP, & +0.01117838660115_DFP, & +0.01117838660115_DFP, & +0.01117838660115_DFP, & +0.01117838660115_DFP, & +0.01117838660115_DFP, & +0.01117838660115_DFP, & +0.00865811555435_DFP, & +0.00865811555435_DFP, & +0.00865811555435_DFP, & +0.00865811555435_DFP, & +0.00865811555435_DFP, & +0.00865811555435_DFP & +], [33, 3])) + + +REAL(DFP), DIMENSION(3, 37), PUBLIC, PARAMETER :: triSolin37 = & +& TRANSPOSE(RESHAPE([ & +0.33333333333330_DFP, & +0.49504818494000_DFP, & +0.00990363012059_DFP, & +0.49504818494000_DFP, & +0.46871663511000_DFP, & +0.06256672978090_DFP, & +0.46871663511000_DFP, & +0.41452133680100_DFP, & +0.17095732639700_DFP, & +0.41452133680100_DFP, & +0.22939957204300_DFP, & +0.54120085591400_DFP, & +0.22939957204300_DFP, & +0.11442449519600_DFP, & +0.77115100960700_DFP, & +0.11442449519600_DFP, & +0.02481139136350_DFP, & +0.95037721727300_DFP, & +0.02481139136350_DFP, & +0.63635117456200_DFP, & +0.09485382837960_DFP, & +0.26879499705900_DFP, & +0.09485382837960_DFP, & +0.26879499705900_DFP, & +0.63635117456200_DFP, & +0.69016915998700_DFP, & +0.01810077327880_DFP, & +0.29173006673400_DFP, & +0.01810077327880_DFP, & +0.29173006673400_DFP, & +0.69016915998700_DFP, & +0.85140953783400_DFP, & +0.02223307667410_DFP, & +0.12635738549200_DFP, & +0.02223307667410_DFP, & +0.12635738549200_DFP, & +0.85140953783400_DFP, & +0.33333333333330_DFP, & +0.49504818494000_DFP, & +0.49504818494000_DFP, & +0.00990363012059_DFP, & +0.46871663511000_DFP, & +0.46871663511000_DFP, & +0.06256672978090_DFP, & +0.41452133680100_DFP, & +0.41452133680100_DFP, & +0.17095732639700_DFP, & +0.22939957204300_DFP, & +0.22939957204300_DFP, & +0.54120085591400_DFP, & +0.11442449519600_DFP, & +0.11442449519600_DFP, & +0.77115100960700_DFP, & +0.02481139136350_DFP, & +0.02481139136350_DFP, & +0.95037721727300_DFP, & +0.26879499705900_DFP, & +0.63635117456200_DFP, & +0.09485382837960_DFP, & +0.26879499705900_DFP, & +0.63635117456200_DFP, & +0.09485382837960_DFP, & +0.29173006673400_DFP, & +0.69016915998700_DFP, & +0.01810077327880_DFP, & +0.29173006673400_DFP, & +0.69016915998700_DFP, & +0.01810077327880_DFP, & +0.12635738549200_DFP, & +0.85140953783400_DFP, & +0.02223307667410_DFP, & +0.12635738549200_DFP, & +0.85140953783400_DFP, & +0.02223307667410_DFP, & +0.026260461700400_DFP, & +0.005640072604650_DFP, & +0.005640072604650_DFP, & +0.005640072604650_DFP, & +0.015711759181250_DFP, & +0.015711759181250_DFP, & +0.015711759181250_DFP, & +0.023536251252100_DFP, & +0.023536251252100_DFP, & +0.023536251252100_DFP, & +0.023681793268200_DFP, & +0.023681793268200_DFP, & +0.023681793268200_DFP, & +0.015583764522900_DFP, & +0.015583764522900_DFP, & +0.015583764522900_DFP, & +0.003987885732535_DFP, & +0.003987885732535_DFP, & +0.003987885732535_DFP, & +0.018424201364350_DFP, & +0.018424201364350_DFP, & +0.018424201364350_DFP, & +0.018424201364350_DFP, & +0.018424201364350_DFP, & +0.018424201364350_DFP, & +0.008700731651900_DFP, & +0.008700731651900_DFP, & +0.008700731651900_DFP, & +0.008700731651900_DFP, & +0.008700731651900_DFP, & +0.008700731651900_DFP, & +0.007760893419500_DFP, & +0.007760893419500_DFP, & +0.007760893419500_DFP, & +0.007760893419500_DFP, & +0.007760893419500_DFP, & +0.007760893419500_DFP & +], [37, 3])) + + +REAL(DFP), DIMENSION(3, 42), PUBLIC, PARAMETER :: triSolin42 = & +& TRANSPOSE(RESHAPE([ & +0.48896391036200_DFP, & +0.02207217927560_DFP, & +0.48896391036200_DFP, & +0.41764471934000_DFP, & +0.16471056131900_DFP, & +0.41764471934000_DFP, & +0.27347752830900_DFP, & +0.45304494338200_DFP, & +0.27347752830900_DFP, & +0.17720553241300_DFP, & +0.64558893517500_DFP, & +0.17720553241300_DFP, & +0.06179988309090_DFP, & +0.87640023381800_DFP, & +0.06179988309090_DFP, & +0.01939096124870_DFP, & +0.96121807750300_DFP, & +0.01939096124870_DFP, & +0.77060855477500_DFP, & +0.05712475740360_DFP, & +0.17226668782100_DFP, & +0.05712475740360_DFP, & +0.17226668782100_DFP, & +0.77060855477500_DFP, & +0.57022229084700_DFP, & +0.09291624935700_DFP, & +0.33686145979600_DFP, & +0.09291624935700_DFP, & +0.33686145979600_DFP, & +0.57022229084700_DFP, & +0.68698016780800_DFP, & +0.01464695005570_DFP, & +0.29837288213600_DFP, & +0.01464695005570_DFP, & +0.29837288213600_DFP, & +0.68698016780800_DFP, & +0.87975717137000_DFP, & +0.00126833093287_DFP, & +0.11897449769700_DFP, & +0.00126833093287_DFP, & +0.11897449769700_DFP, & +0.87975717137000_DFP, & +0.48896391036200_DFP, & +0.48896391036200_DFP, & +0.02207217927560_DFP, & +0.41764471934000_DFP, & +0.41764471934000_DFP, & +0.16471056131900_DFP, & +0.27347752830900_DFP, & +0.27347752830900_DFP, & +0.45304494338200_DFP, & +0.17720553241300_DFP, & +0.17720553241300_DFP, & +0.64558893517500_DFP, & +0.06179988309090_DFP, & +0.06179988309090_DFP, & +0.87640023381800_DFP, & +0.01939096124870_DFP, & +0.01939096124870_DFP, & +0.96121807750300_DFP, & +0.17226668782100_DFP, & +0.77060855477500_DFP, & +0.05712475740360_DFP, & +0.17226668782100_DFP, & +0.77060855477500_DFP, & +0.05712475740360_DFP, & +0.33686145979600_DFP, & +0.57022229084700_DFP, & +0.09291624935700_DFP, & +0.33686145979600_DFP, & +0.57022229084700_DFP, & +0.09291624935700_DFP, & +0.29837288213600_DFP, & +0.68698016780800_DFP, & +0.01464695005570_DFP, & +0.29837288213600_DFP, & +0.68698016780800_DFP, & +0.01464695005570_DFP, & +0.11897449769700_DFP, & +0.87975717137000_DFP, & +0.00126833093287_DFP, & +0.11897449769700_DFP, & +0.87975717137000_DFP, & +0.00126833093287_DFP, & +0.01094179068470_DFP, & +0.01094179068470_DFP, & +0.01094179068470_DFP, & +0.01639417677205_DFP, & +0.01639417677205_DFP, & +0.01639417677205_DFP, & +0.02588705225365_DFP, & +0.02588705225365_DFP, & +0.02588705225365_DFP, & +0.02108129436850_DFP, & +0.02108129436850_DFP, & +0.02108129436850_DFP, & +0.00721684983490_DFP, & +0.00721684983490_DFP, & +0.00721684983490_DFP, & +0.00246170180120_DFP, & +0.00246170180120_DFP, & +0.00246170180120_DFP, & +0.01233287660630_DFP, & +0.01233287660630_DFP, & +0.01233287660630_DFP, & +0.01233287660630_DFP, & +0.01233287660630_DFP, & +0.01233287660630_DFP, & +0.01928575539355_DFP, & +0.01928575539355_DFP, & +0.01928575539355_DFP, & +0.01928575539355_DFP, & +0.01928575539355_DFP, & +0.01928575539355_DFP, & +0.00721815405675_DFP, & +0.00721815405675_DFP, & +0.00721815405675_DFP, & +0.00721815405675_DFP, & +0.00721815405675_DFP, & +0.00721815405675_DFP, & +0.00250511441925_DFP, & +0.00250511441925_DFP, & +0.00250511441925_DFP, & +0.00250511441925_DFP, & +0.00250511441925_DFP, & +0.00250511441925_DFP & +], [42, 3])) + + +REAL(DFP), DIMENSION(3, 48), PUBLIC, PARAMETER :: triSolin48 = & +& TRANSPOSE(RESHAPE([ & ++0.5069729168580_DFP, & +-0.0139458337165_DFP, & ++0.5069729168580_DFP, & ++0.4314063542830_DFP, & ++0.1371872914340_DFP, & ++0.4314063542830_DFP, & ++0.2776936448470_DFP, & ++0.4446127103060_DFP, & ++0.2776936448470_DFP, & ++0.1264648910410_DFP, & ++0.7470702179170_DFP, & ++0.1264648910410_DFP, & ++0.0708083859747_DFP, & ++0.8583832280510_DFP, & ++0.0708083859747_DFP, & ++0.0189651702411_DFP, & ++0.9620696595180_DFP, & ++0.0189651702411_DFP, & ++0.6049544668930_DFP, & ++0.1337341619670_DFP, & ++0.2613113711400_DFP, & ++0.1337341619670_DFP, & ++0.2613113711400_DFP, & ++0.6049544668930_DFP, & ++0.5755865555130_DFP, & ++0.0363666773969_DFP, & ++0.3880467670900_DFP, & ++0.0363666773969_DFP, & ++0.3880467670900_DFP, & ++0.5755865555130_DFP, & ++0.7244626630770_DFP, & +-0.0101748831266_DFP, & ++0.2857122200500_DFP, & +-0.0101748831266_DFP, & ++0.2857122200500_DFP, & ++0.7244626630770_DFP, & ++0.7475564660520_DFP, & ++0.0368438698759_DFP, & ++0.2155996640720_DFP, & ++0.0368438698759_DFP, & ++0.2155996640720_DFP, & ++0.7475564660520_DFP, & ++0.8839645740920_DFP, & ++0.0124598093312_DFP, & ++0.1035756165760_DFP, & ++0.0124598093312_DFP, & ++0.1035756165760_DFP, & ++0.8839645740920_DFP, & ++0.5069729168580_DFP, & ++0.5069729168580_DFP, & +-0.0139458337165_DFP, & ++0.4314063542830_DFP, & ++0.4314063542830_DFP, & ++0.1371872914340_DFP, & ++0.2776936448470_DFP, & ++0.2776936448470_DFP, & ++0.4446127103060_DFP, & ++0.1264648910410_DFP, & ++0.1264648910410_DFP, & ++0.7470702179170_DFP, & ++0.0708083859747_DFP, & ++0.0708083859747_DFP, & ++0.8583832280510_DFP, & ++0.0189651702411_DFP, & ++0.0189651702411_DFP, & ++0.9620696595180_DFP, & ++0.2613113711400_DFP, & ++0.6049544668930_DFP, & ++0.1337341619670_DFP, & ++0.2613113711400_DFP, & ++0.6049544668930_DFP, & ++0.1337341619670_DFP, & ++0.3880467670900_DFP, & ++0.5755865555130_DFP, & ++0.0363666773969_DFP, & ++0.3880467670900_DFP, & ++0.5755865555130_DFP, & ++0.0363666773969_DFP, & ++0.2857122200500_DFP, & ++0.7244626630770_DFP, & +-0.0101748831266_DFP, & ++0.2857122200500_DFP, & ++0.7244626630770_DFP, & +-0.0101748831266_DFP, & ++0.2155996640720_DFP, & ++0.7475564660520_DFP, & ++0.0368438698759_DFP, & ++0.2155996640720_DFP, & ++0.7475564660520_DFP, & ++0.0368438698759_DFP, & ++0.1035756165760_DFP, & ++0.8839645740920_DFP, & ++0.0124598093312_DFP, & ++0.1035756165760_DFP, & ++0.8839645740920_DFP, & ++0.0124598093312_DFP, & +0.000958437821425_DFP, & +0.000958437821425_DFP, & +0.000958437821425_DFP, & +0.022124513635550_DFP, & +0.022124513635550_DFP, & +0.022124513635550_DFP, & +0.025593274359450_DFP, & +0.025593274359450_DFP, & +0.025593274359450_DFP, & +0.011843867935350_DFP, & +0.011843867935350_DFP, & +0.011843867935350_DFP, & +0.006644887845000_DFP, & +0.006644887845000_DFP, & +0.006644887845000_DFP, & +0.002374458304095_DFP, & +0.002374458304095_DFP, & +0.002374458304095_DFP, & +0.019275036299800_DFP, & +0.019275036299800_DFP, & +0.019275036299800_DFP, & +0.019275036299800_DFP, & +0.019275036299800_DFP, & +0.019275036299800_DFP, & +0.013607907160300_DFP, & +0.013607907160300_DFP, & +0.013607907160300_DFP, & +0.013607907160300_DFP, & +0.013607907160300_DFP, & +0.013607907160300_DFP, & +0.001091038683400_DFP, & +0.001091038683400_DFP, & +0.001091038683400_DFP, & +0.001091038683400_DFP, & +0.001091038683400_DFP, & +0.001091038683400_DFP, & +0.010752659923850_DFP, & +0.010752659923850_DFP, & +0.010752659923850_DFP, & +0.010752659923850_DFP, & +0.010752659923850_DFP, & +0.010752659923850_DFP, & +0.003836971315525_DFP, & +0.003836971315525_DFP, & +0.003836971315525_DFP, & +0.003836971315525_DFP, & +0.003836971315525_DFP, & +0.003836971315525_DFP & +], [48, 3])) + +REAL(DFP), DIMENSION(3, 52), PUBLIC, PARAMETER :: triSolin52 = & +& TRANSPOSE(RESHAPE([ & ++0.33333333333330_DFP, & ++0.49738054194800_DFP, & ++0.00523891610312_DFP, & ++0.49738054194800_DFP, & ++0.41346943854900_DFP, & ++0.17306112290100_DFP, & ++0.41346943854900_DFP, & ++0.47045859906700_DFP, & ++0.05908280186600_DFP, & ++0.47045859906700_DFP, & ++0.24055374997000_DFP, & ++0.51889250006100_DFP, & ++0.24055374997000_DFP, & ++0.14796579422300_DFP, & ++0.70406841155500_DFP, & ++0.14796579422300_DFP, & ++0.07546518765750_DFP, & ++0.84906962468500_DFP, & ++0.07546518765750_DFP, & ++0.01659640262300_DFP, & ++0.96680719475400_DFP, & ++0.01659640262300_DFP, & ++0.59986871117500_DFP, & ++0.10357569224500_DFP, & ++0.29655559658000_DFP, & ++0.10357569224500_DFP, & ++0.29655559658000_DFP, & ++0.59986871117500_DFP, & ++0.64219352494200_DFP, & ++0.02008341165540_DFP, & ++0.33772306340300_DFP, & ++0.02008341165540_DFP, & ++0.33772306340300_DFP, & ++0.64219352494200_DFP, & ++0.79959272097100_DFP, & +-0.00434100261414_DFP, & ++0.20474828164300_DFP, & +-0.00434100261414_DFP, & ++0.20474828164300_DFP, & ++0.79959272097100_DFP, & ++0.76869972140100_DFP, & ++0.04194178646800_DFP, & ++0.18935849213100_DFP, & ++0.04194178646800_DFP, & ++0.18935849213100_DFP, & ++0.76869972140100_DFP, & ++0.90039906408700_DFP, & ++0.01431732023070_DFP, & ++0.08528361568270_DFP, & ++0.01431732023070_DFP, & ++0.08528361568270_DFP, & ++0.90039906408700_DFP, & ++0.33333333333330_DFP, & ++0.49738054194800_DFP, & ++0.49738054194800_DFP, & ++0.00523891610312_DFP, & ++0.41346943854900_DFP, & ++0.41346943854900_DFP, & ++0.17306112290100_DFP, & ++0.47045859906700_DFP, & ++0.47045859906700_DFP, & ++0.05908280186600_DFP, & ++0.24055374997000_DFP, & ++0.24055374997000_DFP, & ++0.51889250006100_DFP, & ++0.14796579422300_DFP, & ++0.14796579422300_DFP, & ++0.70406841155500_DFP, & ++0.07546518765750_DFP, & ++0.07546518765750_DFP, & ++0.84906962468500_DFP, & ++0.01659640262300_DFP, & ++0.01659640262300_DFP, & ++0.96680719475400_DFP, & ++0.29655559658000_DFP, & ++0.59986871117500_DFP, & ++0.10357569224500_DFP, & ++0.29655559658000_DFP, & ++0.59986871117500_DFP, & ++0.10357569224500_DFP, & ++0.33772306340300_DFP, & ++0.64219352494200_DFP, & ++0.02008341165540_DFP, & ++0.33772306340300_DFP, & ++0.64219352494200_DFP, & ++0.02008341165540_DFP, & ++0.20474828164300_DFP, & ++0.79959272097100_DFP, & +-0.00434100261414_DFP, & ++0.20474828164300_DFP, & ++0.79959272097100_DFP, & +-0.00434100261414_DFP, & ++0.18935849213100_DFP, & ++0.76869972140100_DFP, & ++0.04194178646800_DFP, & ++0.18935849213100_DFP, & ++0.76869972140100_DFP, & ++0.04194178646800_DFP, & ++0.08528361568270_DFP, & ++0.90039906408700_DFP, & ++0.01431732023070_DFP, & ++0.08528361568270_DFP, & ++0.90039906408700_DFP, & ++0.01431732023070_DFP, & +0.023437848713800_DFP, & +0.003202939289290_DFP, & +0.003202939289290_DFP, & +0.003202939289290_DFP, & +0.020855148369700_DFP, & +0.020855148369700_DFP, & +0.020855148369700_DFP, & +0.013445742125050_DFP, & +0.013445742125050_DFP, & +0.013445742125050_DFP, & +0.021066261380800_DFP, & +0.021066261380800_DFP, & +0.021066261380800_DFP, & +0.015000133421400_DFP, & +0.015000133421400_DFP, & +0.015000133421400_DFP, & +0.007100049462500_DFP, & +0.007100049462500_DFP, & +0.007100049462500_DFP, & +0.001791231175635_DFP, & +0.001791231175635_DFP, & +0.001791231175635_DFP, & +0.016386573730300_DFP, & +0.016386573730300_DFP, & +0.016386573730300_DFP, & +0.016386573730300_DFP, & +0.016386573730300_DFP, & +0.016386573730300_DFP, & +0.007649153124200_DFP, & +0.007649153124200_DFP, & +0.007649153124200_DFP, & +0.007649153124200_DFP, & +0.007649153124200_DFP, & +0.007649153124200_DFP, & +0.001193122096420_DFP, & +0.001193122096420_DFP, & +0.001193122096420_DFP, & +0.001193122096420_DFP, & +0.001193122096420_DFP, & +0.001193122096420_DFP, & +0.009542396377950_DFP, & +0.009542396377950_DFP, & +0.009542396377950_DFP, & +0.009542396377950_DFP, & +0.009542396377950_DFP, & +0.009542396377950_DFP, & +0.003425027273270_DFP, & +0.003425027273270_DFP, & +0.003425027273270_DFP, & +0.003425027273270_DFP, & +0.003425027273270_DFP, & +0.003425027273270_DFP & +], [52, 3])) + +REAL(DFP), DIMENSION(3, 61), PUBLIC, PARAMETER :: triSolin61 = & +& TRANSPOSE(RESHAPE([ & +0.33333333333330_DFP, & +0.49717054055700_DFP, & +0.00565891888645_DFP, & +0.49717054055700_DFP, & +0.48217632262500_DFP, & +0.03564735475080_DFP, & +0.48217632262500_DFP, & +0.45023996902100_DFP, & +0.09952006195840_DFP, & +0.45023996902100_DFP, & +0.40026623937700_DFP, & +0.19946752124500_DFP, & +0.40026623937700_DFP, & +0.25214126797100_DFP, & +0.49571746405800_DFP, & +0.25214126797100_DFP, & +0.16204700465800_DFP, & +0.67590599068300_DFP, & +0.16204700465800_DFP, & +0.07587588226070_DFP, & +0.84824823547900_DFP, & +0.07587588226070_DFP, & +0.01565472696780_DFP, & +0.96869054606400_DFP, & +0.01565472696780_DFP, & +0.65549320380900_DFP, & +0.01018692882690_DFP, & +0.33431986736400_DFP, & +0.01018692882690_DFP, & +0.33431986736400_DFP, & +0.65549320380900_DFP, & +0.57233759053200_DFP, & +0.13544087167100_DFP, & +0.29222153779700_DFP, & +0.13544087167100_DFP, & +0.29222153779700_DFP, & +0.57233759053200_DFP, & +0.62600119028600_DFP, & +0.05442392429060_DFP, & +0.31957488542300_DFP, & +0.05442392429060_DFP, & +0.31957488542300_DFP, & +0.62600119028600_DFP, & +0.79642721497400_DFP, & +0.01286856083360_DFP, & +0.19070422419200_DFP, & +0.01286856083360_DFP, & +0.19070422419200_DFP, & +0.79642721497400_DFP, & +0.75235100593800_DFP, & +0.06716578241350_DFP, & +0.18048321164900_DFP, & +0.06716578241350_DFP, & +0.18048321164900_DFP, & +0.75235100593800_DFP, & +0.90462550409600_DFP, & +0.01466318222480_DFP, & +0.08071131367960_DFP, & +0.01466318222480_DFP, & +0.08071131367960_DFP, & +0.90462550409600_DFP, & +0.33333333333330_DFP, & +0.49717054055700_DFP, & +0.49717054055700_DFP, & +0.00565891888645_DFP, & +0.48217632262500_DFP, & +0.48217632262500_DFP, & +0.03564735475080_DFP, & +0.45023996902100_DFP, & +0.45023996902100_DFP, & +0.09952006195840_DFP, & +0.40026623937700_DFP, & +0.40026623937700_DFP, & +0.19946752124500_DFP, & +0.25214126797100_DFP, & +0.25214126797100_DFP, & +0.49571746405800_DFP, & +0.16204700465800_DFP, & +0.16204700465800_DFP, & +0.67590599068300_DFP, & +0.07587588226070_DFP, & +0.07587588226070_DFP, & +0.84824823547900_DFP, & +0.01565472696780_DFP, & +0.01565472696780_DFP, & +0.96869054606400_DFP, & +0.33431986736400_DFP, & +0.65549320380900_DFP, & +0.01018692882690_DFP, & +0.33431986736400_DFP, & +0.65549320380900_DFP, & +0.01018692882690_DFP, & +0.29222153779700_DFP, & +0.57233759053200_DFP, & +0.13544087167100_DFP, & +0.29222153779700_DFP, & +0.57233759053200_DFP, & +0.13544087167100_DFP, & +0.31957488542300_DFP, & +0.62600119028600_DFP, & +0.05442392429060_DFP, & +0.31957488542300_DFP, & +0.62600119028600_DFP, & +0.05442392429060_DFP, & +0.19070422419200_DFP, & +0.79642721497400_DFP, & +0.01286856083360_DFP, & +0.19070422419200_DFP, & +0.79642721497400_DFP, & +0.01286856083360_DFP, & +0.18048321164900_DFP, & +0.75235100593800_DFP, & +0.06716578241350_DFP, & +0.18048321164900_DFP, & +0.75235100593800_DFP, & +0.06716578241350_DFP, & +0.08071131367960_DFP, & +0.90462550409600_DFP, & +0.01466318222480_DFP, & +0.08071131367960_DFP, & +0.90462550409600_DFP, & +0.01466318222480_DFP, & +0.016718599645400_DFP, & +0.002546707720255_DFP, & +0.002546707720255_DFP, & +0.002546707720255_DFP, & +0.007335432263800_DFP, & +0.007335432263800_DFP, & +0.007335432263800_DFP, & +0.012175439176850_DFP, & +0.012175439176850_DFP, & +0.012175439176850_DFP, & +0.015553775434500_DFP, & +0.015553775434500_DFP, & +0.015553775434500_DFP, & +0.015628555609300_DFP, & +0.015628555609300_DFP, & +0.015628555609300_DFP, & +0.012407827169850_DFP, & +0.012407827169850_DFP, & +0.012407827169850_DFP, & +0.007028036535300_DFP, & +0.007028036535300_DFP, & +0.007028036535300_DFP, & +0.001597338086890_DFP, & +0.001597338086890_DFP, & +0.001597338086890_DFP, & +0.004059827659495_DFP, & +0.004059827659495_DFP, & +0.004059827659495_DFP, & +0.004059827659495_DFP, & +0.004059827659495_DFP, & +0.004059827659495_DFP, & +0.013402871141600_DFP, & +0.013402871141600_DFP, & +0.013402871141600_DFP, & +0.013402871141600_DFP, & +0.013402871141600_DFP, & +0.013402871141600_DFP, & +0.009229996605400_DFP, & +0.009229996605400_DFP, & +0.009229996605400_DFP, & +0.009229996605400_DFP, & +0.009229996605400_DFP, & +0.009229996605400_DFP, & +0.004238434267165_DFP, & +0.004238434267165_DFP, & +0.004238434267165_DFP, & +0.004238434267165_DFP, & +0.004238434267165_DFP, & +0.004238434267165_DFP, & +0.009146398385000_DFP, & +0.009146398385000_DFP, & +0.009146398385000_DFP, & +0.009146398385000_DFP, & +0.009146398385000_DFP, & +0.009146398385000_DFP, & +0.003332816002085_DFP, & +0.003332816002085_DFP, & +0.003332816002085_DFP, & +0.003332816002085_DFP, & +0.003332816002085_DFP, & +0.003332816002085_DFP & +], [61, 3])) + + +REAL(DFP), DIMENSION(3, 70), PUBLIC, PARAMETER :: triSolin70 = & +& TRANSPOSE(RESHAPE([ & ++0.33333333333330_DFP, & ++0.49334480863100_DFP, & ++0.01331038273820_DFP, & ++0.49334480863100_DFP, & ++0.46921059424200_DFP, & ++0.06157881151610_DFP, & ++0.46921059424200_DFP, & ++0.43628139588700_DFP, & ++0.12743720822600_DFP, & ++0.43628139588700_DFP, & ++0.39484617067300_DFP, & ++0.21030765865300_DFP, & ++0.39484617067300_DFP, & ++0.24979456880300_DFP, & ++0.50041086239400_DFP, & ++0.24979456880300_DFP, & ++0.16143219374400_DFP, & ++0.67713561251200_DFP, & ++0.16143219374400_DFP, & ++0.07659822748540_DFP, & ++0.84680354502900_DFP, & ++0.07659822748540_DFP, & ++0.02425243935350_DFP, & ++0.95149512129300_DFP, & ++0.02425243935350_DFP, & ++0.04314636721700_DFP, & ++0.91370726556600_DFP, & ++0.04314636721700_DFP, & ++0.63265796885700_DFP, & ++0.00843053620242_DFP, & ++0.35891149494100_DFP, & ++0.00843053620242_DFP, & ++0.35891149494100_DFP, & ++0.63265796885700_DFP, & ++0.57441097151100_DFP, & ++0.13118655173700_DFP, & ++0.29440247675200_DFP, & ++0.13118655173700_DFP, & ++0.29440247675200_DFP, & ++0.57441097151100_DFP, & ++0.62477904679300_DFP, & ++0.05020315156570_DFP, & ++0.32501780164200_DFP, & ++0.05020315156570_DFP, & ++0.32501780164200_DFP, & ++0.62477904679300_DFP, & ++0.74893317652300_DFP, & ++0.06632926381090_DFP, & ++0.18473755966600_DFP, & ++0.06632926381090_DFP, & ++0.18473755966600_DFP, & ++0.74893317652300_DFP, & ++0.76920700542000_DFP, & ++0.01199619456620_DFP, & ++0.21879680001300_DFP, & ++0.01199619456620_DFP, & ++0.21879680001300_DFP, & ++0.76920700542000_DFP, & ++0.88396230227300_DFP, & ++0.01485810059010_DFP, & ++0.10117959713600_DFP, & ++0.01485810059010_DFP, & ++0.10117959713600_DFP, & ++0.88396230227300_DFP, & ++1.01434726001000_DFP, & +-0.03522201528790_DFP, & ++0.02087475528260_DFP, & +-0.03522201528790_DFP, & ++0.02087475528260_DFP, & ++1.01434726001000_DFP, & ++0.33333333333330_DFP, & ++0.49334480863100_DFP, & ++0.49334480863100_DFP, & ++0.01331038273820_DFP, & ++0.46921059424200_DFP, & ++0.46921059424200_DFP, & ++0.06157881151610_DFP, & ++0.43628139588700_DFP, & ++0.43628139588700_DFP, & ++0.12743720822600_DFP, & ++0.39484617067300_DFP, & ++0.39484617067300_DFP, & ++0.21030765865300_DFP, & ++0.24979456880300_DFP, & ++0.24979456880300_DFP, & ++0.50041086239400_DFP, & ++0.16143219374400_DFP, & ++0.16143219374400_DFP, & ++0.67713561251200_DFP, & ++0.07659822748540_DFP, & ++0.07659822748540_DFP, & ++0.84680354502900_DFP, & ++0.02425243935350_DFP, & ++0.02425243935350_DFP, & ++0.95149512129300_DFP, & ++0.04314636721700_DFP, & ++0.04314636721700_DFP, & ++0.91370726556600_DFP, & ++0.35891149494100_DFP, & ++0.63265796885700_DFP, & ++0.00843053620242_DFP, & ++0.35891149494100_DFP, & ++0.63265796885700_DFP, & ++0.00843053620242_DFP, & ++0.29440247675200_DFP, & ++0.57441097151100_DFP, & ++0.13118655173700_DFP, & ++0.29440247675200_DFP, & ++0.57441097151100_DFP, & ++0.13118655173700_DFP, & ++0.32501780164200_DFP, & ++0.62477904679300_DFP, & ++0.05020315156570_DFP, & ++0.32501780164200_DFP, & ++0.62477904679300_DFP, & ++0.05020315156570_DFP, & ++0.18473755966600_DFP, & ++0.74893317652300_DFP, & ++0.06632926381090_DFP, & ++0.18473755966600_DFP, & ++0.74893317652300_DFP, & ++0.06632926381090_DFP, & ++0.21879680001300_DFP, & ++0.76920700542000_DFP, & ++0.01199619456620_DFP, & ++0.21879680001300_DFP, & ++0.76920700542000_DFP, & ++0.01199619456620_DFP, & ++0.10117959713600_DFP, & ++0.88396230227300_DFP, & ++0.01485810059010_DFP, & ++0.10117959713600_DFP, & ++0.88396230227300_DFP, & ++0.01485810059010_DFP, & ++0.02087475528260_DFP, & ++1.01434726001000_DFP, & +-0.03522201528790_DFP, & ++0.02087475528260_DFP, & ++1.01434726001000_DFP, & +-0.03522201528790_DFP, & ++0.015404969968800_DFP, & ++0.004536218339700_DFP, & ++0.004536218339700_DFP, & ++0.004536218339700_DFP, & ++0.009380658469800_DFP, & ++0.009380658469800_DFP, & ++0.009380658469800_DFP, & ++0.009720548992750_DFP, & ++0.009720548992750_DFP, & ++0.009720548992750_DFP, & ++0.013876974305400_DFP, & ++0.013876974305400_DFP, & ++0.013876974305400_DFP, & ++0.016128112675750_DFP, & ++0.016128112675750_DFP, & ++0.016128112675750_DFP, & ++0.012537016308450_DFP, & ++0.012537016308450_DFP, & ++0.012537016308450_DFP, & ++0.007635963985900_DFP, & ++0.007635963985900_DFP, & ++0.007635963985900_DFP, & ++0.003396961011480_DFP, & ++0.003396961011480_DFP, & ++0.003396961011480_DFP, & +-0.001111549364960_DFP, & +-0.001111549364960_DFP, & +-0.001111549364960_DFP, & ++0.003165957038205_DFP, & ++0.003165957038205_DFP, & ++0.003165957038205_DFP, & ++0.003165957038205_DFP, & ++0.003165957038205_DFP, & ++0.003165957038205_DFP, & ++0.013628769024550_DFP, & ++0.013628769024550_DFP, & ++0.013628769024550_DFP, & ++0.013628769024550_DFP, & ++0.013628769024550_DFP, & ++0.013628769024550_DFP, & ++0.008838392824750_DFP, & ++0.008838392824750_DFP, & ++0.008838392824750_DFP, & ++0.008838392824750_DFP, & ++0.008838392824750_DFP, & ++0.008838392824750_DFP, & ++0.009189742319050_DFP, & ++0.009189742319050_DFP, & ++0.009189742319050_DFP, & ++0.009189742319050_DFP, & ++0.009189742319050_DFP, & ++0.009189742319050_DFP, & ++0.004052366404095_DFP, & ++0.004052366404095_DFP, & ++0.004052366404095_DFP, & ++0.004052366404095_DFP, & ++0.004052366404095_DFP, & ++0.004052366404095_DFP, & ++0.003817064535365_DFP, & ++0.003817064535365_DFP, & ++0.003817064535365_DFP, & ++0.003817064535365_DFP, & ++0.003817064535365_DFP, & ++0.003817064535365_DFP, & +real(+2.3093830397e-05, kind=DFP), & +real(+2.3093830397e-05, kind=DFP), & +real(+2.3093830397e-05, kind=DFP), & +real(+2.3093830397e-05, kind=DFP), & +real(+2.3093830397e-05, kind=DFP), & +real(+2.3093830397e-05, kind=DFP) & +], [70, 3])) + + +REAL(DFP), DIMENSION(3, 73), PUBLIC, PARAMETER :: triSolin73 = & +& TRANSPOSE(RESHAPE([ & +0.33333333333330_DFP, & +0.48960998707300_DFP, & +0.02078002585400_DFP, & +0.48960998707300_DFP, & +0.45453689269800_DFP, & +0.09092621460420_DFP, & +0.45453689269800_DFP, & +0.40141668064900_DFP, & +0.19716663870100_DFP, & +0.40141668064900_DFP, & +0.25555165440300_DFP, & +0.48889669119400_DFP, & +0.25555165440300_DFP, & +0.17707794215200_DFP, & +0.64584411569600_DFP, & +0.17707794215200_DFP, & +0.11006105322800_DFP, & +0.77987789354400_DFP, & +0.11006105322800_DFP, & +0.05552862425180_DFP, & +0.88894275149600_DFP, & +0.05552862425180_DFP, & +0.01262186377720_DFP, & +0.97475627244600_DFP, & +0.01262186377720_DFP, & +0.60063379479500_DFP, & +0.00361141784841_DFP, & +0.39575478735700_DFP, & +0.00361141784841_DFP, & +0.39575478735700_DFP, & +0.60063379479500_DFP, & +0.55760326158900_DFP, & +0.13446675453100_DFP, & +0.30792998388000_DFP, & +0.13446675453100_DFP, & +0.30792998388000_DFP, & +0.55760326158900_DFP, & +0.72098702581700_DFP, & +0.01444602577610_DFP, & +0.26456694840700_DFP, & +0.01444602577610_DFP, & +0.26456694840700_DFP, & +0.72098702581700_DFP, & +0.59452706895600_DFP, & +0.04693357883820_DFP, & +0.35853935220600_DFP, & +0.04693357883820_DFP, & +0.35853935220600_DFP, & +0.59452706895600_DFP, & +0.83933147368100_DFP, & +0.00286112035057_DFP, & +0.15780740596900_DFP, & +0.00286112035057_DFP, & +0.15780740596900_DFP, & +0.83933147368100_DFP, & +0.70108797892600_DFP, & +0.22386142409800_DFP, & +0.07505059697590_DFP, & +0.22386142409800_DFP, & +0.07505059697590_DFP, & +0.70108797892600_DFP, & +0.82293132407000_DFP, & +0.03464707481680_DFP, & +0.14242160111300_DFP, & +0.03464707481680_DFP, & +0.14242160111300_DFP, & +0.82293132407000_DFP, & +0.92434425262100_DFP, & +0.01016111929630_DFP, & +0.06549462808290_DFP, & +0.01016111929630_DFP, & +0.06549462808290_DFP, & +0.92434425262100_DFP, & +0.33333333333330_DFP, & +0.48960998707300_DFP, & +0.48960998707300_DFP, & +0.02078002585400_DFP, & +0.45453689269800_DFP, & +0.45453689269800_DFP, & +0.09092621460420_DFP, & +0.40141668064900_DFP, & +0.40141668064900_DFP, & +0.19716663870100_DFP, & +0.25555165440300_DFP, & +0.25555165440300_DFP, & +0.48889669119400_DFP, & +0.17707794215200_DFP, & +0.17707794215200_DFP, & +0.64584411569600_DFP, & +0.11006105322800_DFP, & +0.11006105322800_DFP, & +0.77987789354400_DFP, & +0.05552862425180_DFP, & +0.05552862425180_DFP, & +0.88894275149600_DFP, & +0.01262186377720_DFP, & +0.01262186377720_DFP, & +0.97475627244600_DFP, & +0.39575478735700_DFP, & +0.60063379479500_DFP, & +0.00361141784841_DFP, & +0.39575478735700_DFP, & +0.60063379479500_DFP, & +0.00361141784841_DFP, & +0.30792998388000_DFP, & +0.55760326158900_DFP, & +0.13446675453100_DFP, & +0.30792998388000_DFP, & +0.55760326158900_DFP, & +0.13446675453100_DFP, & +0.26456694840700_DFP, & +0.72098702581700_DFP, & +0.01444602577610_DFP, & +0.26456694840700_DFP, & +0.72098702581700_DFP, & +0.01444602577610_DFP, & +0.35853935220600_DFP, & +0.59452706895600_DFP, & +0.04693357883820_DFP, & +0.35853935220600_DFP, & +0.59452706895600_DFP, & +0.04693357883820_DFP, & +0.15780740596900_DFP, & +0.83933147368100_DFP, & +0.00286112035057_DFP, & +0.15780740596900_DFP, & +0.83933147368100_DFP, & +0.00286112035057_DFP, & +0.07505059697590_DFP, & +0.70108797892600_DFP, & +0.22386142409800_DFP, & +0.07505059697590_DFP, & +0.70108797892600_DFP, & +0.22386142409800_DFP, & +0.14242160111300_DFP, & +0.82293132407000_DFP, & +0.03464707481680_DFP, & +0.14242160111300_DFP, & +0.82293132407000_DFP, & +0.03464707481680_DFP, & +0.06549462808290_DFP, & +0.92434425262100_DFP, & +0.01016111929630_DFP, & +0.06549462808290_DFP, & +0.92434425262100_DFP, & +0.01016111929630_DFP, & +0.016453165694450_DFP, & +0.005165365945650_DFP, & +0.005165365945650_DFP, & +0.005165365945650_DFP, & +0.011193623631500_DFP, & +0.011193623631500_DFP, & +0.011193623631500_DFP, & +0.015133062934750_DFP, & +0.015133062934750_DFP, & +0.015133062934750_DFP, & +0.015245483901100_DFP, & +0.015245483901100_DFP, & +0.015245483901100_DFP, & +0.012079606370800_DFP, & +0.012079606370800_DFP, & +0.012079606370800_DFP, & +0.008025401793400_DFP, & +0.008025401793400_DFP, & +0.008025401793400_DFP, & +0.004042290130890_DFP, & +0.004042290130890_DFP, & +0.004042290130890_DFP, & +0.001039681013740_DFP, & +0.001039681013740_DFP, & +0.001039681013740_DFP, & +0.001942438452490_DFP, & +0.001942438452490_DFP, & +0.001942438452490_DFP, & +0.001942438452490_DFP, & +0.001942438452490_DFP, & +0.001942438452490_DFP, & +0.012787080306000_DFP, & +0.012787080306000_DFP, & +0.012787080306000_DFP, & +0.012787080306000_DFP, & +0.012787080306000_DFP, & +0.012787080306000_DFP, & +0.004440451786670_DFP, & +0.004440451786670_DFP, & +0.004440451786670_DFP, & +0.004440451786670_DFP, & +0.004440451786670_DFP, & +0.004440451786670_DFP, & +0.008062273380850_DFP, & +0.008062273380850_DFP, & +0.008062273380850_DFP, & +0.008062273380850_DFP, & +0.008062273380850_DFP, & +0.008062273380850_DFP, & +0.001245970908745_DFP, & +0.001245970908745_DFP, & +0.001245970908745_DFP, & +0.001245970908745_DFP, & +0.001245970908745_DFP, & +0.001245970908745_DFP, & +0.009121420059500_DFP, & +0.009121420059500_DFP, & +0.009121420059500_DFP, & +0.009121420059500_DFP, & +0.009121420059500_DFP, & +0.009121420059500_DFP, & +0.005129281868100_DFP, & +0.005129281868100_DFP, & +0.005129281868100_DFP, & +0.005129281868100_DFP, & +0.005129281868100_DFP, & +0.005129281868100_DFP, & +0.001899964427650_DFP, & +0.001899964427650_DFP, & +0.001899964427650_DFP, & +0.001899964427650_DFP, & +0.001899964427650_DFP, & +0.001899964427650_DFP & +], [73, 3])) + + +REAL(DFP), DIMENSION(3, 79), PUBLIC, PARAMETER :: triSolin79 = & +& TRANSPOSE(RESHAPE([ & ++0.3333333333333_DFP, & ++0.5009504643520_DFP, & +-0.0019009287044_DFP, & ++0.5009504643520_DFP, & ++0.4882129579350_DFP, & ++0.0235740841305_DFP, & ++0.4882129579350_DFP, & ++0.4551366869500_DFP, & ++0.0897266360994_DFP, & ++0.4551366869500_DFP, & ++0.4019962593180_DFP, & ++0.1960074813630_DFP, & ++0.4019962593180_DFP, & ++0.2558929097590_DFP, & ++0.4882141804810_DFP, & ++0.2558929097590_DFP, & ++0.1764882559950_DFP, & ++0.6470234880100_DFP, & ++0.1764882559950_DFP, & ++0.1041708553370_DFP, & ++0.7916582893260_DFP, & ++0.1041708553370_DFP, & ++0.0530689638409_DFP, & ++0.8938620723180_DFP, & ++0.0530689638409_DFP, & ++0.0416187151960_DFP, & ++0.9167625696080_DFP, & ++0.0416187151960_DFP, & ++0.0115819214068_DFP, & ++0.9768361571860_DFP, & ++0.0115819214068_DFP, & ++0.6064026461060_DFP, & ++0.0487415836648_DFP, & ++0.3448557702290_DFP, & ++0.0487415836648_DFP, & ++0.3448557702290_DFP, & ++0.6064026461060_DFP, & ++0.6158426144570_DFP, & ++0.0063141159486_DFP, & ++0.3778432695950_DFP, & ++0.0063141159486_DFP, & ++0.3778432695950_DFP, & ++0.6158426144570_DFP, & ++0.5590480003900_DFP, & ++0.1343165205470_DFP, & ++0.3066354790620_DFP, & ++0.1343165205470_DFP, & ++0.3066354790620_DFP, & ++0.5590480003900_DFP, & ++0.7366067432630_DFP, & ++0.0139738939624_DFP, & ++0.2494193627750_DFP, & ++0.0139738939624_DFP, & ++0.2494193627750_DFP, & ++0.7366067432630_DFP, & ++0.7116751422870_DFP, & ++0.0755491329098_DFP, & ++0.2127757248030_DFP, & ++0.0755491329098_DFP, & ++0.2127757248030_DFP, & ++0.7116751422870_DFP, & ++0.8614027171550_DFP, & +-0.0083681532082_DFP, & ++0.1469654360530_DFP, & +-0.0083681532082_DFP, & ++0.1469654360530_DFP, & ++0.8614027171550_DFP, & ++0.8355869579120_DFP, & ++0.0266860632587_DFP, & ++0.1377269788290_DFP, & ++0.0266860632587_DFP, & ++0.1377269788290_DFP, & ++0.8355869579120_DFP, & ++0.9297561715570_DFP, & ++0.0105477192941_DFP, & ++0.0596961091490_DFP, & ++0.0105477192941_DFP, & ++0.0596961091490_DFP, & ++0.9297561715570_DFP, & ++0.3333333333333_DFP, & ++0.5009504643520_DFP, & ++0.5009504643520_DFP, & +-0.0019009287044_DFP, & ++0.4882129579350_DFP, & ++0.4882129579350_DFP, & ++0.0235740841305_DFP, & ++0.4551366869500_DFP, & ++0.4551366869500_DFP, & ++0.0897266360994_DFP, & ++0.4019962593180_DFP, & ++0.4019962593180_DFP, & ++0.1960074813630_DFP, & ++0.2558929097590_DFP, & ++0.2558929097590_DFP, & ++0.4882141804810_DFP, & ++0.1764882559950_DFP, & ++0.1764882559950_DFP, & ++0.6470234880100_DFP, & ++0.1041708553370_DFP, & ++0.1041708553370_DFP, & ++0.7916582893260_DFP, & ++0.0530689638409_DFP, & ++0.0530689638409_DFP, & ++0.8938620723180_DFP, & ++0.0416187151960_DFP, & ++0.0416187151960_DFP, & ++0.9167625696080_DFP, & ++0.0115819214068_DFP, & ++0.0115819214068_DFP, & ++0.9768361571860_DFP, & ++0.3448557702290_DFP, & ++0.6064026461060_DFP, & ++0.0487415836648_DFP, & ++0.3448557702290_DFP, & ++0.6064026461060_DFP, & ++0.0487415836648_DFP, & ++0.3778432695950_DFP, & ++0.6158426144570_DFP, & ++0.0063141159486_DFP, & ++0.3778432695950_DFP, & ++0.6158426144570_DFP, & ++0.0063141159486_DFP, & ++0.3066354790620_DFP, & ++0.5590480003900_DFP, & ++0.1343165205470_DFP, & ++0.3066354790620_DFP, & ++0.5590480003900_DFP, & ++0.1343165205470_DFP, & ++0.2494193627750_DFP, & ++0.7366067432630_DFP, & ++0.0139738939624_DFP, & ++0.2494193627750_DFP, & ++0.7366067432630_DFP, & ++0.0139738939624_DFP, & ++0.2127757248030_DFP, & ++0.7116751422870_DFP, & ++0.0755491329098_DFP, & ++0.2127757248030_DFP, & ++0.7116751422870_DFP, & ++0.0755491329098_DFP, & ++0.1469654360530_DFP, & ++0.8614027171550_DFP, & +-0.0083681532082_DFP, & ++0.1469654360530_DFP, & ++0.8614027171550_DFP, & +-0.0083681532082_DFP, & ++0.1377269788290_DFP, & ++0.8355869579120_DFP, & ++0.0266860632587_DFP, & ++0.1377269788290_DFP, & ++0.8355869579120_DFP, & ++0.0266860632587_DFP, & ++0.0596961091490_DFP, & ++0.9297561715570_DFP, & ++0.0105477192941_DFP, & ++0.0596961091490_DFP, & ++0.9297561715570_DFP, & ++0.0105477192941_DFP, & ++0.016528527770800_DFP, & ++0.000433509592831_DFP, & ++0.000433509592831_DFP, & ++0.000433509592831_DFP, & ++0.005830026358200_DFP, & ++0.005830026358200_DFP, & ++0.005830026358200_DFP, & ++0.011438468178200_DFP, & ++0.011438468178200_DFP, & ++0.011438468178200_DFP, & ++0.015224491336950_DFP, & ++0.015224491336950_DFP, & ++0.015224491336950_DFP, & ++0.015312445862700_DFP, & ++0.015312445862700_DFP, & ++0.015312445862700_DFP, & ++0.012184028838400_DFP, & ++0.012184028838400_DFP, & ++0.012184028838400_DFP, & ++0.007998716016000_DFP, & ++0.007998716016000_DFP, & ++0.007998716016000_DFP, & ++0.003849150907800_DFP, & ++0.003849150907800_DFP, & ++0.003849150907800_DFP, & +-0.000316030248744_DFP, & +-0.000316030248744_DFP, & +-0.000316030248744_DFP, & ++0.000875567150595_DFP, & ++0.000875567150595_DFP, & ++0.000875567150595_DFP, & ++0.008232919594800_DFP, & ++0.008232919594800_DFP, & ++0.008232919594800_DFP, & ++0.008232919594800_DFP, & ++0.008232919594800_DFP, & ++0.008232919594800_DFP, & ++0.002419516770245_DFP, & ++0.002419516770245_DFP, & ++0.002419516770245_DFP, & ++0.002419516770245_DFP, & ++0.002419516770245_DFP, & ++0.002419516770245_DFP, & ++0.012902453267350_DFP, & ++0.012902453267350_DFP, & ++0.012902453267350_DFP, & ++0.012902453267350_DFP, & ++0.012902453267350_DFP, & ++0.012902453267350_DFP, & ++0.004235545527220_DFP, & ++0.004235545527220_DFP, & ++0.004235545527220_DFP, & ++0.004235545527220_DFP, & ++0.004235545527220_DFP, & ++0.004235545527220_DFP, & ++0.009177457053150_DFP, & ++0.009177457053150_DFP, & ++0.009177457053150_DFP, & ++0.009177457053150_DFP, & ++0.009177457053150_DFP, & ++0.009177457053150_DFP, & ++0.000352202338954_DFP, & ++0.000352202338954_DFP, & ++0.000352202338954_DFP, & ++0.000352202338954_DFP, & ++0.000352202338954_DFP, & ++0.000352202338954_DFP, & ++0.005056342463750_DFP, & ++0.005056342463750_DFP, & ++0.005056342463750_DFP, & ++0.005056342463750_DFP, & ++0.005056342463750_DFP, & ++0.005056342463750_DFP, & ++0.001786954692975_DFP, & ++0.001786954692975_DFP, & ++0.001786954692975_DFP, & ++0.001786954692975_DFP, & ++0.001786954692975_DFP, & ++0.001786954692975_DFP & +], [79, 3])) + +contains + +pure function QuadratureNumberTriangleSolin(order) result(ans) +INTEGER( I4B ), INTENT( IN ) :: order +INTEGER( I4B ) :: ans +select case(order) +case(1) +ans = 1 +case(2) +ans = 3 +case(3) +ans = 4 +case(4) +ans = 6 +case(5) +ans = 7 +case(6) +ans = 12 +case(7) +ans = 13 +case(8) +ans = 16 +case(9) +ans = 19 +case(10) +ans = 25 +case(11) +ans = 27 +case(12) +ans = 33 +case(13) +ans = 37 +case(14) +ans = 42 +case(15) +ans = 48 +case(16) +ans = 52 +case(17) +ans = 61 +case(18) +ans = 70 +case(19) +ans = 73 +case(20) +ans = 79 +case default +ans = -1 +end select +end function QuadratureNumberTriangleSolin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +pure function QuadraturePointTriangleSolin1(order) result(ans) + INTEGER( I4B ), INTENT( IN ) :: order + REAL( DFP ), ALLOCATABLE :: ans(:, :) + INTEGER(I4B) :: nips(1) + nips(1) = QuadratureNumberTriangleSolin(order=order) + if( nips(1) .gt. 0_I4B ) then + ans = QuadraturePointTriangleSolin(nips=nips) + end if +end function QuadraturePointTriangleSolin1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +pure subroutine QuadraturePointTriangleSolin1_(order, ans, nrow, ncol) + INTEGER( I4B ), INTENT( IN ) :: order + REAL( DFP ), INTENT(INOUT) :: ans(:, :) + INTEGER( I4B ), INTENT(OUT) :: nrow, ncol + + INTEGER(I4B) :: nips(1) + + nips(1) = QuadratureNumberTriangleSolin(order=order) + nrow = 0 + ncol = 0 + + if( nips(1) .gt. 0_I4B ) & + CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=nrow, & + ncol=ncol) + +end subroutine QuadraturePointTriangleSolin1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +pure function QuadraturePointTriangleSolin(nips) result(ans) + INTEGER( I4B ), INTENT( IN ) :: nips(1) + REAL( DFP ), ALLOCATABLE :: ans(:, :) + + INTEGER(I4B) :: nrow, ncol + + nrow = 3 + ncol = nips(1) + + ALLOCATE(ans(nrow, ncol)) + CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=nrow, ncol=ncol) + +end function QuadraturePointTriangleSolin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +pure subroutine QuadraturePointTriangleSolin_(nips, ans, nrow, ncol) + INTEGER( I4B ), INTENT( IN ) :: nips(1) + REAL( DFP ), INTENT(INOUT) :: ans(:, :) + INTEGER( I4B ), INTENT(OUT) :: nrow, ncol + + nrow = 3 + ncol = nips(1) + + select case(nips(1)) + case(1) + ans(1:nrow, 1:ncol) = triSolin1 + + case(3) + ans(1:nrow, 1:ncol) = triSolin3 + + case(4) + ans(1:nrow, 1:ncol) = triSolin4 + + case(6) + ans(1:nrow, 1:ncol) = triSolin6 + + case(7) + ans(1:nrow, 1:ncol) = triSolin7 + + case(12) + ans(1:nrow, 1:ncol) = triSolin12 + + case(13) + ans(1:nrow, 1:ncol) = triSolin13 + + case(16) + ans(1:nrow, 1:ncol) = triSolin16 + + case(19) + ans(1:nrow, 1:ncol) = triSolin19 + + case(25) + ans(1:nrow, 1:ncol) = triSolin25 + + case(27) + ans(1:nrow, 1:ncol) = triSolin27 + + case(33) + ans(1:nrow, 1:ncol) = triSolin33 + + case(37) + ans(1:nrow, 1:ncol) = triSolin37 + + case(42) + ans(1:nrow, 1:ncol) = triSolin42 + + case(48) + ans(1:nrow, 1:ncol) = triSolin48 + + case(52) + ans(1:nrow, 1:ncol) = triSolin52 + + case(61) + ans(1:nrow, 1:ncol) = triSolin61 + + case(70) + ans(1:nrow, 1:ncol) = triSolin70 + + case(73) + ans(1:nrow, 1:ncol) = triSolin73 + + case(79) + ans(1:nrow, 1:ncol) = triSolin79 + + end select +end subroutine QuadraturePointTriangleSolin_ + +END MODULE QuadraturePoint_Triangle_Solin diff --git a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 new file mode 100644 index 000000000..cb6c67770 --- /dev/null +++ b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 @@ -0,0 +1,346 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(RecursiveNodesUtility) Methods +USE BaseMethod +CONTAINS + +!---------------------------------------------------------------------------- +! RecursiveNode1D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode1D +INTEGER(I4B) :: n, jj +INTEGER(I4B), PARAMETER :: d = 1_I4B +INTEGER(I4B) :: aindx(d + 1) +REAL(DFP) :: avar +REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] +INTEGER(I4B), ALLOCATABLE :: indices(:, :) +REAL(DFP), ALLOCATABLE :: x(:) + +n = order +x = InterpolationPoint_Line( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout="INCREASING", & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +indices = GetMultiIndices(n=n, d=d) +CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) + +DO jj = 1, SIZE(ans, 2) + aindx = indices(:, jj) + 1 + avar = x(aindx(1)) + x(aindx(2)) + ans(1, jj) = x(aindx(1)) / avar + ans(2, jj) = x(aindx(2)) / avar +END DO + +IF (PRESENT(domain)) THEN + ans = Coord_Map(x=ans, from="BaryCentric", to=domain) +END IF + +IF (ALLOCATED(indices)) DEALLOCATE (indices) +IF (ALLOCATED(x)) DEALLOCATE (x) +END PROCEDURE RecursiveNode1D + +!---------------------------------------------------------------------------- +! RecursiveNode2D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode2D +INTEGER(I4B) :: n, jj, ii +INTEGER(I4B), PARAMETER :: d = 2_I4B +INTEGER(I4B) :: aindx(d + 1), indx(d) +REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) +REAL(DFP) :: BX(2, order + 1, order + 1) +INTEGER(I4B), ALLOCATABLE :: indices(:, :) + +n = order +CALL BarycentericNodeFamily1D( & + & order=order, & + & ipType=ipType, & + & ans=BX, & + & Xn=Xn, & + & alpha=alpha, beta=beta, lambda=lambda) + +indices = GetMultiIndices(n=n, d=d) +CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) + +DO jj = 1, SIZE(ans, 2) + aindx = indices(:, jj) + xt = 0.0_DFP + + DO ii = 1, d + 1 + indx = Pop(aindx, ii) + bs = BX(:, indx(1) + 1, indx(2) + 1) + b = Push(vec=bs, VALUE=0.0_DFP, pos=ii) + xi = Xn(SUM(indx) + 1) + xt = xt + xi + ans(1:d + 1, jj) = ans(1:d + 1, jj) + xi * b + END DO + ans(:, jj) = ans(:, jj) / xt +END DO + +IF (PRESENT(domain)) THEN + ans = Coord_Map(x=ans, from="BaryCentric", to=domain) +END IF + +IF (ALLOCATED(indices)) DEALLOCATE (indices) +END PROCEDURE RecursiveNode2D + +!---------------------------------------------------------------------------- +! RecursiveNode3D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode3D +INTEGER(I4B) :: n, jj, ii +INTEGER(I4B), PARAMETER :: d = 3_I4B +INTEGER(I4B) :: aindx(d + 1), indx(d) +REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) +REAL(DFP) :: BX(3, order + 1, order + 1, order + 1) +INTEGER(I4B), ALLOCATABLE :: indices(:, :) + +n = order +CALL BarycentericNodeFamily2D(order=order, ipType=ipType, ans=BX, Xn=Xn, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +indices = GetMultiIndices(n=n, d=d) +CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) +ans = 0.0_DFP + +DO jj = 1, SIZE(ans, 2) + + aindx = indices(:, jj) + xt = 0.0_DFP + + DO ii = 1, d + 1 + + indx = Pop(aindx, ii) + bs = BX(:, indx(1) + 1, indx(2) + 1, indx(3) + 1) + b = Push(vec=bs, VALUE=0.0_DFP, pos=ii) + xi = Xn(SUM(indx) + 1) + xt = xt + xi + ans(:, jj) = ans(:, jj) + xi * b + + END DO + + ans(:, jj) = ans(:, jj) / xt + +END DO + +IF (PRESENT(domain)) THEN + ans = Coord_Map(x=ans, from="BaryCentric", to=domain) +END IF + +IF (ALLOCATED(indices)) DEALLOCATE (indices) + +END PROCEDURE RecursiveNode3D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn, alpha, & + & beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: ipType + REAL(DFP), INTENT(OUT) :: ans(2, order + 1, order + 1) + REAL(DFP), INTENT(OUT) :: Xn(order + 1) + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + ! + INTEGER(I4B) :: ii, jj, n + INTEGER(I4B), PARAMETER :: d = 1_I4B + REAL(DFP), ALLOCATABLE :: BXn(:, :) + INTEGER(I4B), ALLOCATABLE :: indices(:, :) + !! + DO ii = 0, order + n = ii + indices = GetMultiIndices(n=n, d=d) + BXn = RecursiveNode1D(order=n, ipType=ipType, & + & alpha=alpha, beta=beta, lambda=lambda) + !! + DO jj = 1, n + 1 + ans(1:d + 1, indices(1, jj) + 1, indices(2, jj) + 1) = BXn(1:d + 1, jj) + END DO + !! + END DO + !! + Xn = BXn(1, :) + !! + IF (ALLOCATED(BXn)) DEALLOCATE (BXn) + IF (ALLOCATED(indices)) DEALLOCATE (indices) + !! +END SUBROUTINE BarycentericNodeFamily1D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: ipType + REAL(DFP), INTENT(OUT) :: ans(3, order + 1, order + 1, order + 1) + REAL(DFP), INTENT(OUT) :: Xn(order + 1) + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + !! + INTEGER(I4B) :: ii, jj, n + INTEGER(I4B), PARAMETER :: d = 2_I4B + REAL(DFP), ALLOCATABLE :: BXn(:, :) + INTEGER(I4B), ALLOCATABLE :: indices(:, :) + REAL(DFP) :: avar + REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] + !! + DO ii = 0, order + n = ii + indices = GetMultiIndices(n=n, d=d) + BXn = RecursiveNode2D(order=n, ipType=ipType, alpha=alpha, beta=beta, lambda=lambda ) + !! + DO jj = 1, SIZE(BXn, 2) + ans(1:3, & + & indices(1, jj) + 1, & + & indices(2, jj) + 1, & + & indices(3, jj) + 1) = BXn(1:3, jj) + END DO + !! + END DO + !! + Xn = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij, & + & layout="INCREASING", alpha=alpha, beta=beta, lambda=lambda) + !! + ! IF (order .GT. 1) THEN + ! avar = Xn(2) + ! Xn(2:order) = Xn(3:) + ! Xn(order + 1) = avar + ! END IF + !! + IF (ALLOCATED(BXn)) DEALLOCATE (BXn) + IF (ALLOCATED(indices)) DEALLOCATE (indices) + !! +END SUBROUTINE BarycentericNodeFamily2D + +!---------------------------------------------------------------------------- +! Unit2Equilateral +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Unit2Equilateral +INTEGER(I4B) :: ii +!! +IF (d .GT. 1_I4B) THEN + ! Move the top vertex over the centroid + DO ii = 1, d - 1 + x(ii, :) = x(ii, :) + x(d, :) / d + END DO + ! Make the projection onto the lesser dimensions equilateral + CALL Unit2Equilateral(d - 1, x(1:d - 1, :)) + ! scale the vertical dimension + x(d, :) = x(d, :) * SQRT((d + 1.0_DFP) / (2.0_DFP * d)) +END IF +END PROCEDURE Unit2Equilateral + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Equilateral2Unit +INTEGER(I4B) :: ii +!! +IF (d .GT. 1_I4B) THEN + x(d, :) = x(d, :) / SQRT((d + 1.0_DFP) / (2.0_DFP * d)) + CALL Equilateral2Unit(d=d - 1, x=x(1:d - 1, :)) + DO ii = 1, d - 1 + x(ii, :) = x(ii, :) - x(d, :) / d + END DO +END IF +END PROCEDURE Equilateral2Unit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ToUnit +TYPE(String) :: astr +INTEGER(I4B) :: d +astr = UpperCase(TRIM(domain)) +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans = x +CASE ("BIUNIT") + ans = 0.5_DFP * (x + 1.0_DFP) +CASE ("BARYCENTRIC") + d = SIZE(x, 1) + ans = x(1:d - 1, :) +CASE ("EQUILATERAL") + d = SIZE(x, 1) + ans = x + ans = ans / 2.0_DFP + CALL Equilateral2Unit(d=d, x=ans) + ans = ans + 1.0_DFP / (d + 1.0_DFP) +END SELECT +END PROCEDURE ToUnit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnit +TYPE(String) :: astr +INTEGER(I4B) :: d +astr = UpperCase(TRIM(domain)) +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans = x +CASE ("BIUNIT") + ans = 2.0_DFP * x - 1 +CASE ("BARYCENTRIC") + ans = x.ROWCONCAT. (1.0_DFP - SUM(x, dim=1)) +CASE ("EQUILATERAL") + d = SIZE(x, 1) + ans = x + ans = ans - 1.0_DFP / (d + 1.0_DFP) + CALL Unit2Equilateral(d=d, x=ans) + ans = ans * 2.0_DFP +END SELECT +END PROCEDURE FromUnit + +!---------------------------------------------------------------------------- +! Coord_Map +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Coord_Map +ans = FromUnit(x=(ToUnit(x=x, domain=from)), domain=to) +END PROCEDURE Coord_Map + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..0c0fcc3b2 --- /dev/null +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -0,0 +1,2587 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(TetrahedronInterpolationUtility) Methods +USE BaseMethod +USE QuadraturePoint_Tetrahedron_Solin, ONLY: & +& QuadratureNumberTetrahedronSolin, & +& QuadratureOrderTetrahedronSolin, & +& QuadraturePointTetrahedronSolin, & +& MAX_ORDER_TETRAHEDRON_SOLIN +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! RefElemDomain_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Tetrahedron +SELECT CASE (UpperCase(baseContinuity)) +CASE ("H1") + SELECT CASE (UpperCase(baseInterpol)) + CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") + ans = "UNIT" + CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") + ans = "UNIT" + CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") + ans = "UNIT" + CASE ( & + & "HIERARCHICALPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHICALPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION") + ans = "BIUNIT" + CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") + ans = "BIUNIT" + CASE DEFAULT + CALL Errormsg(& + & msg="No case found for given baseInterpol="//TRIM(baseInterpol), & + & file=__FILE__, & + & line=__LINE__,& + & routine="RefElemDomain_Tetrahedron()", & + & unitno=stderr) + END SELECT +CASE DEFAULT + CALL Errormsg(& + & msg="No case found for given baseContinuity="//TRIM(baseContinuity), & + & file=__FILE__, & + & line=__LINE__,& + & routine="RefElemDomain_Tetrahedron()", & + & unitno=stderr) +END SELECT +END PROCEDURE RefElemDomain_Tetrahedron + +!---------------------------------------------------------------------------- +! GetVertexDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetVertexDOF_Tetrahedron +ans = 4 +END PROCEDURE GetVertexDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeDOF_Tetrahedron1 +ans = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6_I4B +END PROCEDURE GetEdgeDOF_Tetrahedron1 + +!---------------------------------------------------------------------------- +! GetEdgeDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetEdgeDOF_Tetrahedron2 +ans = GetEdgeDOF_Tetrahedron1(p, p, p, p, p, p) +END PROCEDURE GetEdgeDOF_Tetrahedron2 + +!---------------------------------------------------------------------------- +! GetFacetDOF_Tetrahedron1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFacetDOF_Tetrahedron1 +ans = (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2 +END PROCEDURE GetFacetDOF_Tetrahedron1 + +!---------------------------------------------------------------------------- +! GetFacetDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFacetDOF_Tetrahedron2 +ans = GetFacetDOF_Tetrahedron1(p, p, p, p) +END PROCEDURE GetFacetDOF_Tetrahedron2 + +!---------------------------------------------------------------------------- +! GetCellDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetCellDOF_Tetrahedron1 +ans = (p - 1) * (p - 2) * (p - 3) / 6_I4B +END PROCEDURE GetCellDOF_Tetrahedron1 + +!---------------------------------------------------------------------------- +! EdgeConnectivity_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeConnectivity_Tetrahedron +ans(:, 1) = [1, 2] +ans(:, 2) = [1, 3] +ans(:, 3) = [1, 4] +ans(:, 4) = [2, 3] +ans(:, 5) = [2, 4] +ans(:, 6) = [3, 4] +END PROCEDURE EdgeConnectivity_Tetrahedron + +!---------------------------------------------------------------------------- +! FacetConnectivity_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetConnectivity_Tetrahedron +TYPE(String) :: baseInterpol0 +TYPE(String) :: baseContinuity0 + +baseInterpol0 = UpperCase(baseInterpol) +baseContinuity0 = UpperCase(baseContinuity) + +SELECT CASE (baseInterpol0%chars()) +CASE ( & + & "HIERARCHYPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHYPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION", & + & "ORTHOGONALPOLYNOMIAL", & + & "ORTHOGONAL", & + & "ORTHOGONALINTERPOLATION") + ans(:, 1) = [1, 2, 3] + ans(:, 2) = [1, 2, 4] + ans(:, 3) = [1, 3, 4] + ans(:, 4) = [2, 3, 4] +CASE DEFAULT + ans(:, 1) = [1, 3, 2] + ans(:, 2) = [1, 2, 4] + ans(:, 3) = [1, 4, 3] + ans(:, 4) = [2, 3, 4] +END SELECT + +END PROCEDURE FacetConnectivity_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeDegree_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Tetrahedron +INTEGER(I4B) :: n, ii, jj, kk, ll +n = LagrangeDOF_Tetrahedron(order=order) +ALLOCATE (ans(n, 3)) +ll = 0 +DO kk = 0, order + DO jj = 0, order + DO ii = 0, order + IF (ii + jj + kk .LE. order) THEN + ll = ll + 1 + ans(ll, 1) = ii + ans(ll, 2) = jj + ans(ll, 3) = kk + END IF + END DO + END DO +END DO +END PROCEDURE LagrangeDegree_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Tetrahedron +ans = (order + 1) * (order + 2) * (order + 3) / 6_I4B +END PROCEDURE LagrangeDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetTotalDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Tetrahedron +ans = (order + 1) * (order + 2) * (order + 3) / 6_I4B +END PROCEDURE GetTotalDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Tetrahedron +ans = (order - 1) * (order - 2) * (order - 3) / 6_I4B +END PROCEDURE GetTotalInDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Tetrahedron +ans = (order - 1) * (order - 2) * (order - 3) / 6_I4B +END PROCEDURE LagrangeInDOF_Tetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Tetrahedron_old +INTEGER(I4B), PARAMETER :: nv = 4_I4B +INTEGER(I4B) :: nsd, n, ne, nf, nc, i1, i2, ii +REAL(DFP) :: x(3, nv), xin(3, nv), e1(3), e2(3), e3(3), lam, & + & avar, mu, delta +INTEGER(I4B), PARAMETER :: edges(6, 2) = RESHAPE( & + & [1, 1, 1, 2, 2, 3, 2, 3, 4, 3, 4, 4], [6, 2]) +INTEGER(I4B), PARAMETER :: faces(4, 3) = RESHAPE( & + & [1, 1, 1, 2, 3, 2, 4, 3, 2, 4, 3, 4], [4, 3]) + +x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + x(1:nsd, 1:nv) = xij(1:nsd, 1:nv) +ELSE + nsd = 3_I4B + x(1:nsd, 1) = [0.0, 0.0, 0.0] + x(1:nsd, 2) = [1.0, 0.0, 0.0] + x(1:nsd, 3) = [0.0, 1.0, 0.0] + x(1:nsd, 4) = [0.0, 0.0, 1.0] +END IF + +n = LagrangeDOF_Tetrahedron(order=order) +ALLOCATE (ans(nsd, n)) +ans = 0.0_DFP + +! points on vertex +ans(1:nsd, 1:nv) = x(1:nsd, 1:nv) + +! points on edge +ne = LagrangeInDOF_Line(order=order) +nf = LagrangeInDOF_Triangle(order=order) +nc = LagrangeInDOF_Tetrahedron(order=order) + +i2 = nv +IF (order .GT. 1_I4B) THEN + DO ii = 1, SIZE(edges, 1) + i1 = i2 + 1; i2 = i2 + ne + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, edges(ii, 1:2))) + END DO +END IF + +! points on face +IF (order .GT. 2_I4B) THEN + DO ii = 1, SIZE(faces, 1) + i1 = i2 + 1; i2 = i2 + nf + ans(1:nsd, i1:i2) = EquidistanceInPoint_Triangle( & + & order=order, & + & xij=x(1:nsd, faces(ii, 1:3))) + END DO +END IF + +! points on cell +IF (order .GT. 3_I4B) THEN + IF (order .EQ. 4_I4B) THEN + ans(1:nsd, i2 + 1) = SUM(x(1:nsd, :), dim=2_I4B) / nv + ELSE + e1 = x(:, 2) - x(:, 1); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 3) - x(:, 1); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 4) - x(:, 1); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 1) = x(1:nsd, 1) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + + e1 = x(:, 1) - x(:, 2); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 3) - x(:, 2); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 4) - x(:, 2); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 2) = x(1:nsd, 2) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + + e1 = x(:, 1) - x(:, 3); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 2) - x(:, 3); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 4) - x(:, 3); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 3) = x(1:nsd, 3) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + + e1 = x(:, 1) - x(:, 4); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 2) - x(:, 4); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 3) - x(:, 4); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 4) = x(1:nsd, 4) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + + i1 = i2 + 1 + ans(1:nsd, i1:) = EquidistancePoint_Tetrahedron( & + & order=order - 4, & + & xij=xin(1:nsd, 1:4)) + END IF +END IF +END PROCEDURE EquidistancePoint_Tetrahedron_old + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Tetrahedron_old +INTEGER(I4B), PARAMETER :: nv = 4_I4B +INTEGER(I4B) :: nsd, n, ne, nf, nc, i1, i2, ii +REAL(DFP) :: x(3, nv), xin(3, nv), e1(3), e2(3), e3(3), lam, & + & avar, mu, delta +INTEGER(I4B), PARAMETER :: edges(6, 2) = RESHAPE( & + & [1, 1, 1, 2, 2, 3, 2, 3, 4, 3, 4, 4], [6, 2]) +INTEGER(I4B), PARAMETER :: faces(4, 3) = RESHAPE( & + & [1, 1, 1, 2, 3, 2, 4, 3, 2, 4, 3, 4], [4, 3]) + +x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + x(1:nsd, 1:nv) = xij(1:nsd, 1:nv) +ELSE + nsd = 3_I4B + x(1:nsd, 1) = [0.0, 0.0, 0.0] + x(1:nsd, 2) = [1.0, 0.0, 0.0] + x(1:nsd, 3) = [0.0, 1.0, 0.0] + x(1:nsd, 4) = [0.0, 0.0, 1.0] +END IF +! +n = LagrangeInDOF_Tetrahedron(order=order) +! +! points on cell +! +IF (order .GT. 3_I4B) THEN + ALLOCATE (ans(nsd, n)) + ans = 0.0_DFP + IF (order .EQ. 4_I4B) THEN + ans(1:nsd, i2 + 1) = SUM(x(1:nsd, :), dim=2_I4B) / nv + ELSE + ! + e1 = x(:, 2) - x(:, 1); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 3) - x(:, 1); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 4) - x(:, 1); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 1) = x(1:nsd, 1) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + ! + e1 = x(:, 1) - x(:, 2); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 3) - x(:, 2); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 4) - x(:, 2); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 2) = x(1:nsd, 2) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + ! + e1 = x(:, 1) - x(:, 3); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 2) - x(:, 3); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 4) - x(:, 3); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 3) = x(1:nsd, 3) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + ! + e1 = x(:, 1) - x(:, 4); avar = NORM2(e1); e1 = e1 / avar + lam = avar / order + e2 = x(:, 2) - x(:, 4); avar = NORM2(e2); e2 = e2 / avar + mu = avar / order + e3 = x(:, 3) - x(:, 4); avar = NORM2(e3); e3 = e3 / avar + delta = avar / order + xin(1:nsd, 4) = x(1:nsd, 4) & + & + lam * e1(1:nsd) & + & + mu * e2(1:nsd) & + & + delta * e3(1:nsd) + ! + i1 = i2 + 1 + ans(1:nsd, i1:) = EquidistancePoint_Tetrahedron( & + & order=order - 4, & + & xij=xin(1:nsd, 1:4)) + ! + END IF +ELSE + ALLOCATE (ans(0, 0)) +END IF +END PROCEDURE EquidistanceInPoint_Tetrahedron_old + +!---------------------------------------------------------------------------- +! EquidistancePoint_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Tetrahedron +ans = InterpolationPoint_Tetrahedron( & + & order=order, & + & ipType=Equidistance, & + & layout="VEFC", & + & xij=xij & + &) +END PROCEDURE EquidistancePoint_Tetrahedron + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Tetrahedron +INTEGER(I4B) :: ii, jj +REAL(DFP), ALLOCATABLE :: ans0(:, :) +ans0 = EquidistancePoint_Tetrahedron(order=order, xij=xij) +ii = LagrangeDOF_Tetrahedron(order) +jj = LagrangeInDOF_Tetrahedron(order) +CALL Reallocate(ans, 3, jj) +ans = ans0(1:3, ii - jj + 1:) +IF (ALLOCATED(ans0)) DEALLOCATE (ans0) +END PROCEDURE EquidistanceInPoint_Tetrahedron + +!---------------------------------------------------------------------------- +! InterpolationPoint_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Tetrahedron +ans = Isaac_Tetrahedron( & + & order=order, & + & ipType=ipType, & + & layout=layout, & + & xij=xij, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END PROCEDURE InterpolationPoint_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron2 +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron4 +INTEGER(I4B) :: basisType0 +basisType0 = input(default=Monomial, option=basisType) + +SELECT CASE (basisType0) +CASE (Monomial) + ans = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron) +CASE (Heirarchical) + IF (PRESENT(refTetrahedron)) THEN + ans = HeirarchicalBasis_Tetrahedron(& + & order=order, & + & xij=xij, & + & refTetrahedron=refTetrahedron & + & ) + ELSE + ans = HeirarchicalBasis_Tetrahedron(& + & order=order, & + & xij=xij, & + & refTetrahedron="UNIT" & + & ) + END IF +CASE DEFAULT + IF (PRESENT(refTetrahedron)) THEN + ans = OrthogonalBasis_Tetrahedron(& + & order=order, & + & xij=xij, & + & refTetrahedron=refTetrahedron & + & ) + ELSE + ans = OrthogonalBasis_Tetrahedron(& + & order=order, & + & xij=xij, & + & refTetrahedron="UNIT" & + & ) + END IF +END SELECT +CALL GetInvMat(ans) + +END PROCEDURE LagrangeCoeff_Tetrahedron4 + +!---------------------------------------------------------------------------- +! Isaac_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Isaac_Tetrahedron +REAL(DFP), DIMENSION(order + 1, order + 1, order + 1) :: xi, eta, zeta +REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) +INTEGER(I4B) :: nsd, N, cnt, ii, jj, kk +CHARACTER(*), PARAMETER :: myName = "Isaac_Tetrahedron" + +rPoints = RecursiveNode3D( & + & order=order, & + & ipType=ipType, & + & domain="UNIT", & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) + +N = SIZE(rPoints, 2) + +nsd = 3 +CALL Reallocate(ans, nsd, N) +CALL Reallocate(temp, nsd, N) + +!! convert from rPoints to xi and eta +cnt = 0 +xi = 0.0_DFP +eta = 0.0_DFP +zeta = 0.0_DFP + +DO ii = 0, order + DO jj = 0, order + DO kk = 0, order + IF (ii + jj + kk .LE. order) THEN + cnt = cnt + 1 + xi(ii + 1, jj + 1, kk + 1) = rPoints(1, cnt) + eta(ii + 1, jj + 1, kk + 1) = rPoints(2, cnt) + zeta(ii + 1, jj + 1, kk + 1) = rPoints(3, cnt) + END IF + END DO + END DO +END DO + +IF (layout .EQ. "VEFC") THEN + CALL IJK2VEFC_Tetrahedron( & + & xi=xi, & + & eta=eta, & + & zeta=zeta, & + & temp=temp, & + & order=order, & + & N=N) +ELSE + temp = rPoints +END IF + +IF (PRESENT(xij)) THEN + ans = FromUnitTetrahedron2Tetrahedron( & + & xin=temp, & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4)) +ELSE + ans = temp +END IF + +IF (ALLOCATED(temp)) DEALLOCATE (temp) +IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints) +END PROCEDURE Isaac_Tetrahedron + +!---------------------------------------------------------------------------- +! BlythPozrikidis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BlythPozrikidis_Tetrahedron +CALL ErrorMsg( & + & msg="This method is under development, please use Isaac_Tetrahedron()", & + & file=__FILE__, & + & routine="BlythPozrikidis_Tetrahedron()", & + & line=__LINE__, & + & unitno=stderr) +RETURN +END PROCEDURE BlythPozrikidis_Tetrahedron + +!---------------------------------------------------------------------------- +! IJK2VEFC_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJK2VEFC_Tetrahedron +INTEGER(I4B) :: indof, ii, cnt, jj, kk, ll +REAL(DFP), DIMENSION(3, (order + 1)*(order + 2)/2) :: temp_face_in +REAL(DFP), DIMENSION(order + 1, order + 1) :: xi2, eta2, zeta2 + +SELECT CASE (order) +CASE (0) + temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] +CASE (1) + ! | 0 | 0 | 0 | + ! | 0 | 0 | 1 | + ! | 0 | 1 | 0 | + ! | 1 | 0 | 0 | + temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] + temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] + temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] +CASE (2) + ! | 0 | 0 | 0 | + ! | 0 | 0 | 0.5 | + ! | 0 | 0 | 1 | + ! | 0 | 0.5 | 0 | + ! | 0 | 0.5 | 0.5 | + ! | 0 | 1 | 0 | + ! | 0.5 | 0 | 0 | + ! | 0.5 | 0 | 0.5 | + ! | 0.5 | 0.5 | 0 | + ! | 1 | 0 | 0 | + + ! four vertex + temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] + temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] + temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] + + ! edge1 x + temp(:, 5) = [xi(2, 1, 1), eta(2, 1, 1), zeta(2, 1, 1)] + ! edge2 y + temp(:, 6) = [xi(1, 2, 1), eta(1, 2, 1), zeta(1, 2, 1)] + ! edge3 z + temp(:, 7) = [xi(1, 1, 2), eta(1, 1, 2), zeta(1, 1, 2)] + ! edge4 xy + temp(:, 8) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] + ! edge5, xz + temp(:, 9) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] + ! edge6, yz + temp(:, 10) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] + +CASE (3) + ! | 0 | 0 | 0 | + ! | 0 | 0 | 0.33333 | + ! | 0 | 0 | 0.66667 | + ! | 0 | 0 | 1 | + ! | 0 | 0.33333 | 0 | + ! | 0 | 0.33333 | 0.33333 | + ! | 0 | 0.33333 | 0.66667 | + ! | 0 | 0.66667 | 0 | + ! | 0 | 0.66667 | 0.33333 | + ! | 0 | 1 | 0 | + ! | 0.33333 | 0 | 0 | + ! | 0.33333 | 0 | 0.33333 | + ! | 0.33333 | 0 | 0.66667 | + ! | 0.33333 | 0.33333 | 0 | + ! | 0.33333 | 0.33333 | 0.33333 | + ! | 0.33333 | 0.66667 | 0 | + ! | 0.66667 | 0 | 0 | + ! | 0.66667 | 0 | 0.33333 | + ! | 0.66667 | 0.33333 | 0 | + ! | 1 | 0 | 0 | + + ! four vertex + temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] + temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] + temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] + + cnt = 4 + ! edge1 x + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] + END DO + ! edge2 y + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] + END DO + ! edge3 z + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] + END DO + ! edge4 xy + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(4-ii, 1+ii, 1), eta(4-ii, 1+ii, 1), zeta(4-ii, 1+ii, 1)] + END DO + ! edge5, xz + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(4-ii, 1, ii+1), eta(4-ii, 1, ii+1), zeta(4-ii, 1, ii+1)] + END DO + ! edge6, yz + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(1, 4-ii, ii+1), eta(1, 4-ii, ii+1), zeta(1, 4-ii, ii+1)] + END DO + + ! facet xy + cnt = cnt + 1 + temp(:, cnt) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] + + ! facet xz + cnt = cnt + 1 + temp(:, cnt) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] + + ! facet yz + cnt = cnt + 1 + temp(:, cnt) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] + + ! facet 4 + cnt = cnt + 1 + temp(:, cnt) = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)] + +CASE DEFAULT + + ! four vertex + temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] + temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] + temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] + + cnt = 4 + ! edge1 x + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] + END DO + ! edge2 y + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] + END DO + ! edge3 z + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] + END DO + ! edge4 xy + jj = order + 1 + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [ & + & xi(jj - ii, 1 + ii, 1), & + & eta(jj - ii, 1 + ii, 1), & + & zeta(jj - ii, 1 + ii, 1)] + END DO + ! edge5, xz + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [ & + & xi(jj - ii, 1, ii + 1), & + & eta(jj - ii, 1, ii + 1), & + & zeta(jj - ii, 1, ii + 1)] + END DO + ! edge6, yz + DO ii = 1, order - 1 + cnt = cnt + 1 + temp(:, cnt) = [ & + & xi(1, jj - ii, ii + 1), & + & eta(1, jj - ii, ii + 1), & + & zeta(1, jj - ii, ii + 1)] + END DO + + ! facet xy + jj = LagrangeDOF_Triangle(order) + CALL IJ2VEFC_Triangle( & + & xi=xi(:, :, 1), & + & eta=eta(:, :, 1), & + & temp=temp_face_in, & + & order=order, & + & N=jj) + kk = LagrangeInDOF_Triangle(order) + DO ii = jj - kk + 1, jj + cnt = cnt + 1 + temp(:, cnt) = [temp_face_in(1, ii), temp_face_in(2, ii), zeta(1, 1, 1)] + END DO + + ! facet xz + ! jj = LagrangeDOF_Triangle(order) + CALL IJ2VEFC_Triangle( & + & xi=xi(:, 1, :), & + & eta=zeta(:, 1, :), & + & temp=temp_face_in, & + & order=order, & + & N=jj) + ! kk = LagrangeInDOF_Triangle(order) + DO ii = jj - kk + 1, jj + cnt = cnt + 1 + temp(:, cnt) = [temp_face_in(1, ii), eta(1, 1, 1), temp_face_in(2, ii)] + END DO + + ! facet yz + ! jj = LagrangeDOF_Triangle(order) + CALL IJ2VEFC_Triangle( & + & xi=eta(1, :, :), & + & eta=zeta(1, :, :), & + & temp=temp_face_in, & + & order=order, & + & N=jj) + ! kk = LagrangeInDOF_Triangle(order) + DO ii = jj - kk + 1, jj + cnt = cnt + 1 + temp(:, cnt) = [xi(1, 1, 1), temp_face_in(1, ii), temp_face_in(2, ii)] + END DO + + ! ! facet 4 + ! cnt = cnt + 1 + ! temp(:, cnt) = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)] + xi2 = 0.0_DFP + eta2 = 0.0_DFP + zeta2 = 0.0_DFP + DO ii = 0, order + ll = 0 + DO jj = 0, order + DO kk = 0, order + IF (ii + jj + kk .EQ. order) THEN + ll = ll + 1 + xi2(ii + 1, ll) = xi(ii + 1, jj + 1, kk + 1) + eta2(ii + 1, ll) = eta(ii + 1, jj + 1, kk + 1) + zeta2(ii + 1, ll) = zeta(ii + 1, jj + 1, kk + 1) + END IF + END DO + END DO + END DO + + temp_face_in = 0.0_DFP + CALL IJK2VEFC_Triangle( & + & xi=xi2, & + & eta=eta2, & + & zeta=zeta2, & + & temp=temp_face_in, & + & order=order, & + & N=SIZE(temp_face_in, 2)) + + ! facet 4 + jj = LagrangeDOF_Triangle(order) + CALL IJK2VEFC_Triangle( & + & xi=xi2, & + & eta=eta2, & + & zeta=zeta2, & + & temp=temp_face_in, & + & order=order, & + & N=jj) + kk = LagrangeInDOF_Triangle(order) + DO ii = jj - kk + 1, jj + cnt = cnt + 1 + temp(:, cnt) = temp_face_in(1:3, ii) + END DO + + jj = LagrangeDOF_Tetrahedron(order) + kk = LagrangeInDOF_Tetrahedron(order=order) + CALL IJK2VEFC_Tetrahedron( & + & xi(2:order - 2, 2:order - 2, 2:order - 2), & + & eta(2:order - 2, 2:order - 2, 2:order - 2), & + & zeta(2:order - 2, 2:order - 2, 2:order - 2), & + & temp(:, cnt + 1:), & + & order - 4, kk) +END SELECT + +END PROCEDURE IJK2VEFC_Tetrahedron + +!---------------------------------------------------------------------------- +! IJ2VEFC_Triangle +!---------------------------------------------------------------------------- + +SUBROUTINE IJK2VEFC_Triangle( & + & xi, & + & eta, & + & zeta, & + & temp, & + & order, & + & N) + REAL(DFP), INTENT(IN) :: xi(:, :) + REAL(DFP), INTENT(IN) :: eta(:, :) + REAL(DFP), INTENT(IN) :: zeta(:, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: N + + INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, llt, llr + + cnt = 0 + m = order + llt = INT((m - 1) / 3) + llr = MOD(m - 1, 3) + DO ll = 0, llt + ! v1 + cnt = cnt + 1 + ii = 1 + ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + temp(3, cnt) = zeta(ii, jj) + ! v2 + cnt = cnt + 1 + ii = m + 1 - 2 * ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + temp(3, cnt) = zeta(ii, jj) + ! v3 + cnt = cnt + 1 + ii = 1 + ll; jj = m + 1 - 2 * ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + temp(3, cnt) = zeta(ii, jj) + ! nodes on edge 12 + jj = ll + 1 + DO ii = 2 + ll, m - 2 * ll + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + temp(3, cnt) = zeta(ii, jj) + END DO + ! nodes on edge 23 + DO jj = 2 + ll, m - 2 * ll + cnt = cnt + 1 + ii = m - ll + 2 - jj + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + temp(3, cnt) = zeta(ii, jj) + END DO + ! nodes on edge 31 + ii = ll + 1 + DO jj = m - 2 * ll, 2 + ll, -1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + temp(3, cnt) = zeta(ii, jj) + END DO + ! internal nodes + END DO + + IF (llr .EQ. 2_I4B) THEN + ! a internal point + cnt = cnt + 1 + ll = llt + 1 + ii = 1 + ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + temp(3, cnt) = zeta(ii, jj) + END IF + + IF (cnt .NE. N) THEN + CALL ErrorMsg( & + & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" & + & //tostring(N), & + & file=__FILE__, & + & routine="IJ2VEFC_Triangle()", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF +END SUBROUTINE IJK2VEFC_Triangle + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Tetrahedron1 +CHARACTER(20) :: layout +REAL(DFP) :: x(1:3, 1:SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), 0:order) +REAL(DFP) :: Q1(SIZE(xij, 2), 0:order) +REAL(DFP) :: R1(SIZE(xij, 2), 0:order) +REAL(DFP) :: x2(SIZE(xij, 2), 0:order) +REAL(DFP) :: x3(SIZE(xij, 2), 0:order) +INTEGER(I4B) :: cnt +INTEGER(I4B) :: p, q, r + +layout = TRIM(UpperCase(refTetrahedron)) +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x = FromBiUnitTetrahedron2BiUnitHexahedron(xin=xij) +CASE ("UNIT") + x = FromUnitTetrahedron2BiUnitHexahedron(xin=xij) +END SELECT + +DO p = 0, order + x2(:, p) = 0.5_DFP * (1.0_DFP - x(2, :)) + x3(:, p) = 0.5_DFP * (1.0_DFP - x(3, :)) +END DO + +P1 = LegendreEvalAll(n=order, x=x(1, :)) + +cnt = 0 + +DO p = 0, order + + Q1 = (x2**p) * JacobiEvalAll( & + & n=order, & + & x=x(2, :), & + & alpha=REAL(2 * p + 1, DFP), & + & beta=0.0_DFP) + + DO q = 0, order - p + + R1 = (x3**(p + q)) * JacobiEvalAll( & + & n=order, & + & x=x(3, :), & + & alpha=REAL(2 * p + 2 * q + 2, DFP), & + & beta=0.0_DFP) + + DO r = 0, order - p - q + cnt = cnt + 1 + ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r) + END DO + END DO +END DO + +END PROCEDURE OrthogonalBasis_Tetrahedron1 + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Tetrahedron2 +CHARACTER(20) :: layout +REAL(DFP) :: x0(SIZE(x)), y0(SIZE(y)), z0(SIZE(z)) +REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z)) +INTEGER(I4B) :: ii, jj, cnt, kk +REAL(DFP) :: P1(1:3, 0:order) +REAL(DFP) :: Q1(1:3, 0:order) +REAL(DFP) :: R1(1:3, 0:order) +REAL(DFP) :: x2(SIZE(xij, 2), 0:order) +REAL(DFP) :: x3(SIZE(xij, 2), 0:order) +INTEGER(I4B) :: p, q, r + +layout = TRIM(UpperCase(refTetrahedron)) + +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x0 = x + y0 = y + z0 = z +CASE ("UNIT") + x0 = FromUnitLine2BiUnitLine(xin=x) + y0 = FromUnitLine2BiUnitLine(xin=y) + z0 = FromUnitLine2BiUnitLine(xin=z) +END SELECT + +xij = 0.0_DFP +cnt = 0 +DO ii = 1, SIZE(x0) + DO jj = 1, SIZE(y0) + DO kk = 1, SIZE(z0) + cnt = cnt + 1 + xij(1, cnt) = x0(ii) + xij(2, cnt) = y0(jj) + xij(3, cnt) = z0(kk) + END DO + END DO +END DO + +DO p = 0, order + x2(:, p) = 0.5_DFP * (1.0_DFP - xij(2, :)) + x3(:, p) = 0.5_DFP * (1.0_DFP - xij(3, :)) +END DO + +P1 = LegendreEvalAll(n=order, x=xij(1, :)) + +cnt = 0 + +DO p = 0, order + + Q1 = (x2**p) * JacobiEvalAll( & + & n=order, & + & x=xij(2, :), & + & alpha=REAL(2 * p + 1, DFP), & + & beta=0.0_DFP) + + DO q = 0, order - p + + R1 = (x3**(p + q)) * JacobiEvalAll( & + & n=order, & + & x=xij(3, :), & + & alpha=REAL(2 * p + 2 * q + 2, DFP), & + & beta=0.0_DFP) + + DO r = 0, order - p - q + cnt = cnt + 1 + ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r) + END DO + END DO +END DO + +END PROCEDURE OrthogonalBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! BarycentricVertexBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricVertexBasis_Tetrahedron +ans = TRANSPOSE(lambda(1:4, :)) +END PROCEDURE BarycentricVertexBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricVertexBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricVertexBasisGradient_Tetrahedron +INTEGER(I4B) :: ii +REAL(DFP) :: eye4_(4, 4) +eye4_ = eye(4_I4B, 1.0_DFP) +DO CONCURRENT(ii=1:SIZE(ans, 1)) + ans(ii, :, :) = eye4_ +END DO +END PROCEDURE BarycentricVertexBasisGradient_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron +REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) +REAL(DFP) :: phi( & + & 1:6 * SIZE(lambda, 2), & + & 0:MAX( & + & pe1 - 2, & + & pe2 - 2, & + & pe3 - 2, & + & pe4 - 2, & + & pe5 - 2, & + & pe6 - 2)) +INTEGER(I4B) :: maxP, tPoints, i1, i2 + +tPoints = SIZE(lambda, 2) +maxP = SIZE(phi, 2) - 1 + +i1 = 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) + +phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) + +ans = BarycentricEdgeBasis_Tetrahedron2( & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & pe5=pe5, & + & pe6=pe6, & + & lambda=lambda, & + & phi=phi & + & ) + +END PROCEDURE BarycentricEdgeBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Tetrahedron2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron2 +INTEGER(I4B) :: tPoints, a, ii, i1, i2 +REAL(DFP) :: temp(SIZE(lambda, 2)) + +ans = 0.0_DFP +tPoints = SIZE(temp) + +!! edge(1) = (v1, v2) +a = 0 +temp = lambda(1, :) * lambda(2, :) +i1 = 1 +i2 = i1 + tPoints - 1 +DO ii = 1, pe1 - 1 + a = a + 1 + ans(:, a) = temp * phi(i1:i2, ii - 1) +END DO + +!! edge(2) = (v1, v3) +temp = lambda(1, :) * lambda(3, :) +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +DO ii = 1, pe2 - 1 + a = a + 1 + ans(:, a) = temp * phi(i1:i2, ii - 1) +END DO + +!! edge(3) = (v1, v4) +temp = lambda(1, :) * lambda(4, :) +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +DO ii = 1, pe3 - 1 + a = a + 1 + ans(:, a) = temp * phi(i1:i2, ii - 1) +END DO + +!! edge(4) = (v2, v3) +temp = lambda(2, :) * lambda(3, :) +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +DO ii = 1, pe4 - 1 + a = a + 1 + ans(:, a) = temp * phi(i1:i2, ii - 1) +END DO + +!! edge(5) = (v2, v4) +temp = lambda(2, :) * lambda(4, :) +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +DO ii = 1, pe5 - 1 + a = a + 1 + ans(:, a) = temp * phi(i1:i2, ii - 1) +END DO + +!! edge(5) = (v3, v4) +temp = lambda(3, :) * lambda(4, :) +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +DO ii = 1, pe6 - 1 + a = a + 1 + ans(:, a) = temp * phi(i1:i2, ii - 1) +END DO + +END PROCEDURE BarycentricEdgeBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasisGradient_Tetrahedron2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasisGradient_Tetrahedron2 +INTEGER(I4B) :: a, ii, i1, i2, edges(2, 6), orders(6), iedge, v1, v2, & + & tPoints +REAL(DFP) :: temp(SIZE(lambda, 2), 6) + +tPoints = SIZE(lambda, 2) +ans = 0.0_DFP +a = 0 +i2 = 0 +temp(:, 1) = lambda(1, :) +temp(:, 2) = lambda(2, :) +temp(:, 3) = lambda(3, :) +temp(:, 4) = lambda(4, :) + +edges = EdgeConnectivity_Tetrahedron( & + & baseinterpol="Lagrange", & + & basecontinuity="H1") +orders = [pe1, pe2, pe3, pe4, pe5, pe6] + +DO iedge = 1, SIZE(edges, 2) + v1 = edges(1, iedge); v2 = edges(2, iedge) + temp(:, 5) = temp(:, v1) * temp(:, v2) + i1 = i2 + 1; i2 = i1 + tPoints - 1 + DO ii = 1, orders(iedge) - 1 + a = a + 1 + temp(:, 6) = temp(:, 5) * dphi(i1:i2, ii - 1) + ans(:, a, v1) = temp(:, v2) * phi(i1:i2, ii - 1) - temp(:, 6) + ans(:, a, v2) = temp(:, v1) * phi(i1:i2, ii - 1) + temp(:, 6) + END DO +END DO +END PROCEDURE BarycentricEdgeBasisGradient_Tetrahedron2 + +!---------------------------------------------------------------------------- +! BarycentricFacetBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron +REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) +REAL(DFP) :: phi( & + & 1:6 * SIZE(lambda, 2), & + & 0:MAX( & + & ps1 - 1, & + & ps2 - 1, & + & ps3 - 1, & + & ps4 - 1)) +INTEGER(I4B) :: maxP, tPoints, i1, i2 + +tPoints = SIZE(lambda, 2) +maxP = SIZE(phi, 2) - 1 + +i1 = 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) + +phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +ans = BarycentricFacetBasis_Tetrahedron2( & + & ps1=ps1, & + & ps2=ps2, & + & ps3=ps3, & + & ps4=ps4, & + & lambda=lambda, & + & phi=phi) + +END PROCEDURE BarycentricFacetBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricFacetBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron2 +REAL(DFP) :: temp(SIZE(lambda, 2)) +INTEGER(I4B) :: tPoints, i1, i2, ii, a +INTEGER(I4B) :: i21(2), i31(2), i41(2), i32(2), i42(2), i43(2) +INTEGER(I4B) :: facetConn(3, 4), fid, n1, n2, cnt, indx1(2, 4), indx2(2, 4) + +tPoints = SIZE(temp) + +i21 = [1, tPoints] +i31 = i21 + tPoints +i41 = i31 + tPoints +i32 = i41 + tPoints +i42 = i32 + tPoints +i43 = i42 + tPoints +facetConn = FacetConnectivity_Tetrahedron( & + & baseInterpol="HIERARCHY", & + & baseContinuity="H1") +indx1 = ((i21.rowconcat.i21) .rowconcat.i31) .rowconcat.i32 +indx2 = ((i31.rowconcat.i41) .rowconcat.i41) .rowconcat.i42 + +ans = 0.0_DFP +i2 = 0 +cnt = 0 + +!! Face1 +DO fid = 1, SIZE(facetConn, 2) + temp = lambda(facetConn(1, fid), :) & + & * lambda(facetConn(2, fid), :) & + & * lambda(facetConn(3, fid), :) + DO n1 = 1, ps1 - 1 + DO n2 = 1, ps1 - 1 - n1 + cnt = cnt + 1 + ans(:, cnt) = temp & + & * phi(indx1(1, fid):indx1(2, fid), n1 - 1) & + & * phi(indx2(1, fid):indx2(2, fid), n2 - 1) + END DO + END DO +END DO + +END PROCEDURE BarycentricFacetBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! BarycentricFacetBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricFacetBasisGradient_Tetrahedron2 +REAL(DFP) :: temp(SIZE(lambda, 2), 8) +INTEGER(I4B) :: tPoints, i1, i2, ii, a, v1, v2, v3 +INTEGER(I4B) :: i21(2), i31(2), i41(2), i32(2), i42(2), i43(2) +INTEGER(I4B) :: facetConn(3, 4), fid, n1, n2, cnt, indx1(2, 4), indx2(2, 4) + +tPoints = SIZE(lambda, 2) +i21 = [1, tPoints] +i31 = i21 + tPoints +i41 = i31 + tPoints +i32 = i41 + tPoints +i42 = i32 + tPoints +i43 = i42 + tPoints +facetConn = FacetConnectivity_Tetrahedron( & + & baseInterpol="HIERARCHY", & + & baseContinuity="H1") +indx1 = ((i21.rowconcat.i21) .rowconcat.i31) .rowconcat.i32 +indx2 = ((i31.rowconcat.i41) .rowconcat.i41) .rowconcat.i42 + +ans = 0.0_DFP +cnt = 0 +temp(:, 1) = lambda(1, :) +temp(:, 2) = lambda(2, :) +temp(:, 3) = lambda(3, :) +temp(:, 4) = lambda(4, :) + +DO fid = 1, SIZE(facetConn, 2) + v1 = facetConn(1, fid) + v2 = facetConn(2, fid) + v3 = facetConn(3, fid) + i1 = indx1(1, fid) + i2 = indx1(1, fid) + temp(:, 5) = temp(:, v1) * temp(:, v2) * temp(:, v3) + + DO n1 = 1, ps1 - 1 + DO n2 = 1, ps1 - 1 - n1 + cnt = cnt + 1 + temp(:, 6) = phi(i1:i2, n1 - 1) * phi(i1:i2, n2 - 1) + temp(:, 7) = temp(:, 5) * dphi(i1:i2, n1 - 1) * phi(i1:i2, n2 - 1) + temp(:, 8) = temp(:, 5) * phi(i1:i2, n1 - 1) * dphi(i1:i2, n2 - 1) + + ans(:, cnt, v1) = temp(:, v2) * temp(:, v3) * temp(:, 6) & + & - temp(:, 7) - temp(:, 8) + + ans(:, cnt, v2) = temp(:, v1) * temp(:, v3) * temp(:, 6) & + & + temp(:, 7) + + ans(:, cnt, v3) = temp(:, v1) * temp(:, v2) * temp(:, 6) & + & + temp(:, 8) + END DO + END DO +END DO +END PROCEDURE BarycentricFacetBasisGradient_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasis_Tetrahedron +REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) +REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:pb) +INTEGER(I4B) :: maxP, tPoints, i1, i2 + +tPoints = SIZE(lambda, 2) +maxP = SIZE(phi, 2) - 1 + +i1 = 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) + +phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +ans = BarycentricCellBasis_Tetrahedron2( & + & pb=pb, & + & lambda=lambda, & + & phi=phi) + +END PROCEDURE BarycentricCellBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricCellBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasis_Tetrahedron2 +REAL(DFP) :: temp(SIZE(lambda, 2)) +INTEGER(I4B) :: tPoints +INTEGER(I4B) :: i21(2), i31(2), i41(2) +INTEGER(I4B) :: n1, n2, n3, cnt + +tPoints = SIZE(temp) + +i21 = [1, tPoints] +i31 = i21 + tPoints +i41 = i31 + tPoints + +ans = 0.0_DFP +cnt = 0 + +temp = lambda(1, :) & + & * lambda(2, :) & + & * lambda(3, :) & + & * lambda(4, :) + +DO n1 = 1, pb - 1 + DO n2 = 1, pb - 1 - n1 + DO n3 = 1, pb - 1 - n1 - n2 + cnt = cnt + 1 + ans(:, cnt) = temp & + & * phi(i21(1):i21(2), n1 - 1) & + & * phi(i31(1):i31(2), n2 - 1) & + & * phi(i41(1):i41(2), n3 - 1) + END DO + END DO +END DO + +END PROCEDURE BarycentricCellBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! BarycentricCellBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasisGradient_Tetrahedron2 +REAL(DFP) :: temp(SIZE(lambda, 2), 13) +INTEGER(I4B) :: tPoints +INTEGER(I4B) :: i21(2), i31(2), i41(2) +INTEGER(I4B) :: n1, n2, n3, cnt + +tPoints = SIZE(lambda, 2) +i21 = [1, tPoints] +i31 = i21 + tPoints +i41 = i31 + tPoints +ans = 0.0_DFP +cnt = 0 + +temp(:, 1) = lambda(1, :) +temp(:, 2) = lambda(2, :) +temp(:, 3) = lambda(3, :) +temp(:, 4) = lambda(4, :) +temp(:, 5) = PRODUCT(temp(:, 1:4), dim=2) +temp(:, 6) = PRODUCT(temp(:, [2, 3, 4]), dim=2) +temp(:, 7) = PRODUCT(temp(:, [1, 3, 4]), dim=2) +temp(:, 8) = PRODUCT(temp(:, [1, 2, 4]), dim=2) +temp(:, 9) = PRODUCT(temp(:, [1, 2, 3]), dim=2) + +DO n1 = 1, pb - 1 + DO n2 = 1, pb - 1 - n1 + DO n3 = 1, pb - 1 - n1 - n2 + cnt = cnt + 1 + temp(:, 10) = phi(i21(1):i21(2), n1 - 1) & + & * phi(i31(1):i31(2), n2 - 1) & + & * phi(i41(1):i41(2), n3 - 1) + + temp(:, 11) = temp(:, 5) * dphi(i21(1):i21(2), n1 - 1) & + & * phi(i31(1):i31(2), n2 - 1) & + & * phi(i41(1):i41(2), n3 - 1) + + temp(:, 12) = temp(:, 5) * phi(i21(1):i21(2), n1 - 1) & + & * dphi(i31(1):i31(2), n2 - 1) & + & * phi(i41(1):i41(2), n3 - 1) + + temp(:, 13) = temp(:, 5) * phi(i21(1):i21(2), n1 - 1) & + & * phi(i31(1):i31(2), n2 - 1) & + & * dphi(i41(1):i41(2), n3 - 1) + + ans(:, cnt, 1) = temp(:, 6) * temp(:, 10) & + &- temp(:, 11) - temp(:, 12) - temp(:, 13) + + ans(:, cnt, 2) = temp(:, 7) * temp(:, 10) + temp(:, 11) + ans(:, cnt, 3) = temp(:, 8) * temp(:, 10) + temp(:, 12) + ans(:, cnt, 4) = temp(:, 9) * temp(:, 10) + temp(:, 13) + END DO + END DO +END DO + +END PROCEDURE BarycentricCellBasisGradient_Tetrahedron2 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1 +REAL(DFP) :: phi( & + & 1:6 * SIZE(lambda, 2), & + & 0:MAX( & + & pe1 - 2, & + & pe2 - 2, & + & pe3 - 2, & + & pe4 - 2, & + & pe5 - 2, & + & pe6 - 2, & + & ps1 - 1, & + & ps2 - 1, & + & ps3 - 1, & + & ps4 - 1, & + & order & + & )) +REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) +INTEGER(I4B) :: a, b, maxP, tPoints, i1, i2 + +tPoints = SIZE(lambda, 2) +maxP = SIZE(phi, 2) - 1_I4B + +i1 = 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) + +phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) + +!! Vertex basis function +ans = 0.0_DFP +ans(:, 1:4) = BarycentricVertexBasis_Tetrahedron(lambda=lambda) +b = 4 + +!! Edge basis function +IF (ANY([pe1, pe2, pe3, pe4, pe5, pe6] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 + ans(:, a:b) = BarycentricEdgeBasis_Tetrahedron2( & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & pe5=pe5, & + & pe6=pe6, & + & lambda=lambda, & + & phi=phi & + & ) +END IF + +!! Facet basis function +IF (ANY([ps1, ps2, ps3, ps4] .GE. 3_I4B)) THEN + a = b + 1 + b = a - 1 & + & + (ps1 - 1_I4B) * (ps1 - 2_I4B) / 2_I4B & + & + (ps2 - 1_I4B) * (ps2 - 2_I4B) / 2_I4B & + & + (ps3 - 1_I4B) * (ps3 - 2_I4B) / 2_I4B & + & + (ps4 - 1_I4B) * (ps4 - 2_I4B) / 2_I4B + + ans(:, a:b) = BarycentricFacetBasis_Tetrahedron2( & + & ps1=ps1, & + & ps2=ps2, & + & ps3=ps3, & + & ps4=ps4, & + & lambda=lambda, & + & phi=phi & + & ) +END IF + +!! Cell basis function +IF (order .GE. 4_I4B) THEN + a = b + 1 + b = a - 1 & + & + (order - 1_I4B) * (order - 2_I4B) * (order - 3_I4B) / 6_I4B + + ans(:, a:b) = BarycentricCellBasis_Tetrahedron2( & + & pb=order, & + & lambda=lambda, & + & phi=phi) +END IF +END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2 +ans = BarycentricHeirarchicalBasis_Tetrahedron( & + & order=order, & + & pe1=order, & + & pe2=order, & + & pe3=order, & + & pe4=order, & + & pe5=order, & + & pe6=order, & + & ps1=order, & + & ps2=order, & + & ps3=order, & + & ps4=order, & + & lambda=lambda & + & ) +END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron1 +REAL(DFP) :: phi( & + & 1:6 * SIZE(lambda, 2), & + & 0:MAX( & + & pe1 - 2, & + & pe2 - 2, & + & pe3 - 2, & + & pe4 - 2, & + & pe5 - 2, & + & pe6 - 2, & + & ps1 - 1, & + & ps2 - 1, & + & ps3 - 1, & + & ps4 - 1, & + & order & + & )) +REAL(DFP) :: dphi( & + & 1:6 * SIZE(lambda, 2), & + & 0:MAX( & + & pe1 - 2, & + & pe2 - 2, & + & pe3 - 2, & + & pe4 - 2, & + & pe5 - 2, & + & pe6 - 2, & + & ps1 - 1, & + & ps2 - 1, & + & ps3 - 1, & + & ps4 - 1, & + & order & + & )) +REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) +INTEGER(I4B) :: a, b, maxP, tPoints, i1, i2 + +tPoints = SIZE(lambda, 2) +maxP = SIZE(phi, 2) - 1_I4B + +i1 = 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) + +i1 = i2 + 1 +i2 = i1 + tPoints - 1 +d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) + +phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +dphi = LobattoKernelGradientEvalAll(n=maxP, x=d_lambda) + +!! Vertex basis function +ans = 0.0_DFP +ans(:, 1:4, :) = BarycentricVertexBasisGradient_Tetrahedron(lambda=lambda) +b = 4 + +!! Edge basis function +IF (ANY([pe1, pe2, pe3, pe4, pe5, pe6] .GE. 2_I4B)) THEN + a = b + 1 + b = a - 1 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 + ans(:, a:b, :) = BarycentricEdgeBasisGradient_Tetrahedron2( & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & pe5=pe5, & + & pe6=pe6, & + & lambda=lambda, & + & phi=phi, & + & dphi=dphi & + & ) +END IF + +!! Facet basis function +IF (ANY([ps1, ps2, ps3, ps4] .GE. 3_I4B)) THEN + a = b + 1 + b = a - 1 & + & + (ps1 - 1_I4B) * (ps1 - 2_I4B) / 2_I4B & + & + (ps2 - 1_I4B) * (ps2 - 2_I4B) / 2_I4B & + & + (ps3 - 1_I4B) * (ps3 - 2_I4B) / 2_I4B & + & + (ps4 - 1_I4B) * (ps4 - 2_I4B) / 2_I4B + + ans(:, a:b, :) = BarycentricFacetBasisGradient_Tetrahedron2( & + & ps1=ps1, & + & ps2=ps2, & + & ps3=ps3, & + & ps4=ps4, & + & lambda=lambda, & + & phi=phi, & + & dphi=dphi & + & ) +END IF + +!! Cell basis function +IF (order .GE. 4_I4B) THEN + a = b + 1 + b = a - 1 & + & + (order - 1_I4B) * (order - 2_I4B) * (order - 3_I4B) / 6_I4B + + ans(:, a:b, :) = BarycentricCellBasisGradient_Tetrahedron2( & + & pb=order, & + & lambda=lambda, & + & phi=phi, dphi=dphi) +END IF +END PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron1 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron2 +ans = BarycentricHeirarchicalBasisGradient_Tetrahedron( & + & order=order, & + & pe1=order, & + & pe2=order, & + & pe3=order, & + & pe4=order, & + & pe5=order, & + & pe6=order, & + & ps1=order, & + & ps2=order, & + & ps3=order, & + & ps4=order, & + & lambda=lambda & + & ) +END PROCEDURE BarycentricHeirarchicalBasisGradient_Tetrahedron2 + +!---------------------------------------------------------------------------- +! VertexBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Tetrahedron +ans = BarycentricVertexBasis_Tetrahedron(& + & lambda=BarycentricCoordTetrahedron( & + & xin=xij, & + & refTetrahedron=refTetrahedron)) +END PROCEDURE VertexBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! EdgeBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasis_Tetrahedron +ans = BarycentricEdgeBasis_Tetrahedron(& + & lambda=BarycentricCoordTetrahedron( & + & xin=xij, & + & refTetrahedron=refTetrahedron), & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & pe5=pe5, & + & pe6=pe6) +END PROCEDURE EdgeBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! FacetBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetBasis_Tetrahedron +ans = BarycentricFacetBasis_Tetrahedron(& + & lambda=BarycentricCoordTetrahedron( & + & xin=xij, & + & refTetrahedron=refTetrahedron), & + & ps1=ps1, & + & ps2=ps2, & + & ps3=ps3, & + & ps4=ps4) +END PROCEDURE FacetBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! CellBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Tetrahedron +ans = BarycentricCellBasis_Tetrahedron(& + & lambda=BarycentricCoordTetrahedron( & + & xin=xij, & + & refTetrahedron=refTetrahedron), & + & pb=pb) +END PROCEDURE CellBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Tetrahedron1 +ans = BarycentricHeirarchicalBasis_Tetrahedron(& + & lambda=BarycentricCoordTetrahedron( & + & xin=xij, & + & refTetrahedron=refTetrahedron), & + & order=order, & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & pe5=pe5, & + & pe6=pe6, & + & ps1=ps1, & + & ps2=ps2, & + & ps3=ps3, & + & ps4=ps4) +END PROCEDURE HeirarchicalBasis_Tetrahedron1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Tetrahedron2 +ans = BarycentricHeirarchicalBasis_Tetrahedron(& + & lambda=BarycentricCoordTetrahedron( & + & xin=xij, & + & refTetrahedron=refTetrahedron), & + & order=order) +END PROCEDURE HeirarchicalBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! LagrangeEvallAll_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Tetrahedron1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: degree(SIZE(xij, 2), 3) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) +TYPE(String) :: ref0 + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) +ref0 = INPUT(default="UNIT", option=refTetrahedron) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Tetrahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & refTetrahedron=ref0%chars() & + & ) + coeff0 = TRANSPOSE(coeff) + ELSE + coeff0 = TRANSPOSE(coeff) + END IF +ELSE + coeff0 = TRANSPOSE( & + & LagrangeCoeff_Tetrahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & refTetrahedron=ref0%chars() & + & )) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Tetrahedron(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Tetrahedron1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + + DO ii = 1, tdof + xx(1, ii) = x(1)**degree(ii, 1) & + & * x(2)**degree(ii, 2) & + & * x(3)**degree(ii, 3) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasis_Tetrahedron( & + & order=order, & + & xij=RESHAPE(x, [3, 1]), & + & refTetrahedron=ref0%chars()) + +CASE DEFAULT + xx = OrthogonalBasis_Tetrahedron( & + & order=order, & + & xij=RESHAPE(x, [3, 1]), & + & refTetrahedron=ref0%chars() & + & ) + +END SELECT + +ans = MATMUL(coeff0, xx(1, :)) + +END PROCEDURE LagrangeEvalAll_Tetrahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Tetrahedron2 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: degree(SIZE(xij, 2), 3) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) +REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) +TYPE(String) :: ref0 + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) +ref0 = INPUT(default="UNIT", option=refTetrahedron) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Tetrahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & refTetrahedron=ref0%chars() & + & ) + END IF + coeff0 = coeff +ELSE + coeff0 = LagrangeCoeff_Tetrahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & refTetrahedron=ref0%chars() & + & ) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Tetrahedron(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Tetrahedron1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + + DO ii = 1, tdof + xx(:, ii) = x(1, :)**degree(ii, 1) & + & * x(2, :)**degree(ii, 2) & + & * x(3, :)**degree(ii, 3) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasis_Tetrahedron( & + & order=order, & + & xij=x, & + & refTetrahedron=ref0%chars()) + +CASE DEFAULT + + xx = OrthogonalBasis_Tetrahedron( & + & order=order, & + & xij=x, & + & refTetrahedron=ref0%chars() & + & ) + +END SELECT + +ans = MATMUL(xx, coeff0) + +END PROCEDURE LagrangeEvalAll_Tetrahedron2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Tetrahedron1 +REAL(DFP), ALLOCATABLE :: temp_t(:, :) +TYPE(string) :: astr + +IF (order .LE. MAX_ORDER_TETRAHEDRON_SOLIN) THEN + astr = TRIM(UpperCase(refTetrahedron)) + temp_t = QuadraturePointTetrahedronSolin(order=order) + CALL Reallocate(ans, 4_I4B, SIZE(temp_t, 2, kind=I4B)) + + IF (PRESENT(xij)) THEN + ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & + & xin=temp_t(1:3, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4) & + & ) + + ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & + & from="UNIT", & + & to="TETRAHEDRON", & + & xij=xij) + + ELSE + + IF (astr%chars() .EQ. "BIUNIT") THEN + ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :)) + ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & + & from="UNIT", & + & to="BIUNIT") + + ELSE + ans = temp_t + END IF + END IF + + IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) +ELSE + ans = TensorQuadraturepoint_Tetrahedron( & + & order=order, & + & quadtype=quadtype, & + & refTetrahedron=refTetrahedron, & + & xij=xij) +END IF +END PROCEDURE QuadraturePoint_Tetrahedron1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Tetrahedron2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Tetrahedron2 +INTEGER(I4B) :: order +order = QuadratureOrderTetrahedronSolin(nips(1)) +IF (order .LT. 0) THEN + ans = Quadraturepoint_Tetrahedron1( & + & order=order, & + & quadtype=quadType, & + & refTetrahedron=refTetrahedron, & + & xij=xij) +ELSE + CALL Errormsg(& + & msg="This routine is available for nips = [ & + & 1, 4, 5, 11, 14, 24, 31, 43, 53, 126, 210, 330, 495, 715, 1001] & + & TRY CALLING TensorQuadraturePoint_Tetrahedron() instead.", & + & file=__FILE__, & + & routine="QuadraturePoint_Tetrahedron2()", & + & line=__LINE__, & + & unitno=stderr) +END IF +END PROCEDURE QuadraturePoint_Tetrahedron2 + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron1 +INTEGER(I4B) :: n(4) +n = 1_I4B + INT(order / 2, kind=I4B) +n(2) = n(2) + 1 +ans = TensorQuadraturePoint_Tetrahedron2( & + & nipsx=n(1), & + & nipsy=n(2), & + & nipsz=n(3), & + & quadType=quadType, & + & refTetrahedron=refTetrahedron, & + & xij=xij) +END PROCEDURE TensorQuadraturePoint_Tetrahedron1 + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron2 +INTEGER(I4B) :: n(3), nsd +REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :) +TYPE(String) :: astr + +astr = TRIM(UpperCase(refTetrahedron)) +n(1) = nipsx(1) +n(2) = nipsy(1) +n(3) = nipsz(1) + +temp_q = QuadraturePoint_Hexahedron(& + & nipsx=n(1:1), & + & nipsy=n(2:2), & + & nipsz=n(3:3), & + & quadType1=GaussLegendreLobatto, & + & quadType2=GaussJacobiRadauLeft, & + & quadType3=GaussJacobiRadauLeft, & + & refHexahedron="BIUNIT", & + & alpha2=1.0_DFP, & + & beta2=0.0_DFP, & + & alpha3=2.0_DFP, & + & beta3=0.0_DFP) + +CALL Reallocate(temp_t, SIZE(temp_q, 1, KIND=I4B), SIZE(temp_q, 2, KIND=I4B)) +temp_t(1:3, :) = FromBiUnitHexahedron2UnitTetrahedron(xin=temp_q(1:3, :)) +temp_t(4, :) = temp_q(4, :) / 8.0_DFP +nsd = 3_I4B +CALL Reallocate(ans, 4_I4B, SIZE(temp_q, 2, KIND=I4B)) + +IF (PRESENT(xij)) THEN + ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & + & xin=temp_t(1:3, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4) & + & ) + ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & + & from="UNIT", & + & to="TETRAHEDRON", & + & xij=xij) +ELSE + IF (astr%chars() .EQ. "BIUNIT") THEN + ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :)) + ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & + & from="UNIT", & + & to="BIUNIT") + ELSE + ans = temp_t + END IF +END IF + +IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q) +IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) +END PROCEDURE TensorQuadraturePoint_Tetrahedron2 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Tetrahedron1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci +INTEGER(I4B) :: degree(SIZE(xij, 2), 3) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & + & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr +TYPE(String) :: ref0 + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) +ref0 = INPUT(default="UNIT", option=refTetrahedron) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + coeff = LagrangeCoeff_Tetrahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & refTetrahedron=ref0%chars() & + & ) + END IF + coeff0 = coeff +ELSE + coeff0 = LagrangeCoeff_Tetrahedron(& + & order=order, & + & xij=xij, & + & basisType=basisType0, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda, & + & refTetrahedron=ref0%chars() & + & ) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Tetrahedron(order=order) + tdof = SIZE(xij, 2) + + IF (tdof .NE. SIZE(degree, 1)) THEN + CALL Errormsg(& + & msg="tdof is not same as size(degree,1)", & + & file=__FILE__, & + & routine="LagrangeEvalAll_Tetrahedron1", & + & line=__LINE__, & + & unitno=stderr) + RETURN + END IF + + DO ii = 1, tdof + ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) + bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) + ci = MAX(degree(ii, 3_I4B) - 1_I4B, 0_I4B) + + ar = REAL(degree(ii, 1_I4B), DFP) + br = REAL(degree(ii, 2_I4B), DFP) + cr = REAL(degree(ii, 3_I4B), DFP) + + xx(:, ii, 1) = (ar * x(1, :)**ai) * & + & x(2, :)**degree(ii, 2) * & + & x(3, :)**degree(ii, 3) + + xx(:, ii, 2) = x(1, :)**degree(ii, 1) * & + & (br * x(2, :)**bi) * & + & x(3, :)**degree(ii, 3) + + xx(:, ii, 3) = x(1, :)**degree(ii, 1) * & + & x(2, :)**degree(ii, 2) * & + & (cr * x(2, :)**ci) + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasisGradient_Tetrahedron( & + & order=order, & + & xij=x, & + & refTetrahedron=ref0%chars()) + +CASE DEFAULT + + xx = OrthogonalBasisGradient_Tetrahedron( & + & order=order, & + & xij=x, & + & refTetrahedron=ref0%chars() & + & ) + +END SELECT + +DO ii = 1, 3 + ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) + ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) +END DO + +END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1 + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Tetrahedron1 +CHARACTER(20) :: layout +REAL(DFP) :: x(1:3, 1:SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), 0:order) +REAL(DFP) :: Q1(SIZE(xij, 2), 0:order) +REAL(DFP) :: R1(SIZE(xij, 2), 0:order) +REAL(DFP) :: dP1(SIZE(xij, 2), 0:order) +REAL(DFP) :: dQ1(SIZE(xij, 2), 0:order) +REAL(DFP) :: dR1(SIZE(xij, 2), 0:order) +REAL(DFP) :: temp(SIZE(xij, 2), 10), areal, breal +INTEGER(I4B) :: cnt +INTEGER(I4B) :: p, q, r +LOGICAL(LGT) :: isBiunit +REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), SIZE(ans, 3)) + +ans0 = 0.0_DFP +layout = TRIM(UpperCase(refTetrahedron)) +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x = FromBiUnitTetrahedron2BiUnitHexahedron(xin=xij) + isBiunit = .TRUE. +CASE ("UNIT") + x = FromUnitTetrahedron2BiUnitHexahedron(xin=xij) + isBiunit = .FALSE. +END SELECT + +temp(:, 1) = 0.5_DFP * (1.0_DFP - x(2, :)) +temp(:, 2) = 0.5_DFP * (1.0_DFP - x(3, :)) + +P1 = LegendreEvalAll(n=order, x=x(1, :)) +dP1 = LegendreGradientEvalAll(n=order, x=x(1, :)) +cnt = 0 + +DO p = 0, order + areal = -0.5_DFP * REAL(p, DFP) + + Q1 = JacobiEvalAll( & + & n=order, & + & x=x(2, :), & + & alpha=REAL(2 * p + 1, DFP), & + & beta=0.0_DFP & + & ) + + dQ1 = JacobiGradientEvalAll( & + & n=order, & + & x=x(2, :), & + & alpha=REAL(2 * p + 1, DFP), & + & beta=0.0_DFP & + & ) + + temp(:, 3) = temp(:, 1)**MAX(p - 1_I4B, 0_I4B) + temp(:, 4) = temp(:, 3) * temp(:, 1) + + DO q = 0, order - p + + breal = -0.5_DFP * REAL(p + q, DFP) + + R1 = JacobiEvalAll( & + & n=order, & + & x=x(3, :), & + & alpha=REAL(2 * p + 2 * q + 2, DFP), & + & beta=0.0_DFP & + & ) + + dR1 = JacobiGradientEvalAll( & + & n=order, & + & x=x(3, :), & + & alpha=REAL(2 * p + 2 * q + 2, DFP), & + & beta=0.0_DFP & + & ) + + temp(:, 5) = P1(:, p) * Q1(:, q) + temp(:, 6) = P1(:, p) * dQ1(:, q) + temp(:, 7) = dP1(:, p) * Q1(:, q) + temp(:, 9) = temp(:, 2)**MAX(p + q - 1_I4B, 0_I4B) + temp(:, 10) = temp(:, 9) * temp(:, 2) + + DO r = 0, order - p - q + temp(:, 8) = temp(:, 5) * R1(:, r) + cnt = cnt + 1 + ans0(:, cnt, 1) = temp(:, 7) * R1(:, r) * temp(:, 4) * temp(:, 10) + ans0(:, cnt, 2) = temp(:, 8) * areal * temp(:, 3) * temp(:, 10) & + & + temp(:, 6) * R1(:, r) * temp(:, 4) * temp(:, 10) + ans0(:, cnt, 2) = temp(:, 8) * breal * temp(:, 4) * temp(:, 9) & + & + temp(:, 5) * dR1(:, r) * temp(:, 4) * temp(:, 10) + END DO + END DO +END DO + +IF (isBiunit) THEN + temp(:, 1) = x(1, :) + temp(:, 2) = x(2, :) + temp(:, 3) = x(3, :) + + temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3)) + temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3)) + temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3)) + temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2 + + DO CONCURRENT(p=1:SIZE(ans, 2)) + ans(:, p, 1) = -temp(:, 4) * ans0(:, p, 1) + ans(:, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2) + ans(:, p, 3) = temp(:, 5) * ans0(:, p, 1) & + & + temp(:, 7) * ans0(:, p, 2) & + & + ans0(:, p, 3) + END DO + +ELSE + + temp(:, 1:3) = FromUnitTetrahedron2BiUnitTetrahedron(x) + + temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3)) + temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3)) + temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3)) + temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2 + + DO CONCURRENT(p=1:SIZE(ans, 2)) + ans(:, p, 1) = -temp(:, 4) * ans0(:, p, 1) + ans(:, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2) + ans(:, p, 3) = temp(:, 5) * ans0(:, p, 1) & + & + temp(:, 7) * ans0(:, p, 2) & + & + ans0(:, p, 3) + END DO + + ans = 2.0_DFP * ans + +END IF + +END PROCEDURE OrthogonalBasisGradient_Tetrahedron1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron1 +TYPE(String) :: name +REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), 4) +ans0 = BarycentricHeirarchicalBasisGradient_Tetrahedron(& + & lambda=BarycentricCoordTetrahedron( & + & xin=xij, & + & refTetrahedron=refTetrahedron), & + & order=order, & + & pe1=pe1, & + & pe2=pe2, & + & pe3=pe3, & + & pe4=pe4, & + & pe5=pe5, & + & pe6=pe6, & + & ps1=ps1, & + & ps2=ps2, & + & ps3=ps3, & + & ps4=ps4) + +ans(:, :, 1) = ans0(:, :, 2) - ans0(:, :, 1) +ans(:, :, 2) = ans0(:, :, 3) - ans0(:, :, 1) +ans(:, :, 3) = ans0(:, :, 4) - ans0(:, :, 1) + +name = UpperCase(refTetrahedron) +IF (name == "BIUNIT") THEN + ans = 0.5_DFP * ans +END IF +END PROCEDURE HeirarchicalBasisGradient_Tetrahedron1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron2 +ans = HeirarchicalBasisGradient_Tetrahedron1( & + & order=order, & + & pe1=order, & + & pe2=order, & + & pe3=order, & + & pe4=order, & + & pe5=order, & + & pe6=order, & + & ps1=order, & + & ps2=order, & + & ps3=order, & + & ps4=order, & + & xij=xij, & + & refTetrahedron=refTetrahedron) +END PROCEDURE HeirarchicalBasisGradient_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +! +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 new file mode 100644 index 000000000..df48713f1 --- /dev/null +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 @@ -0,0 +1,666 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(TriangleInterpolationUtility) HeirarchicalBasisMethods +USE LobattoPolynomialUtility, ONLY: LobattoKernelEvalAll_, & + LobattoKernelGradientEvalAll_ +USE MappingUtility, ONLY: BarycentricCoordTriangle_ + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! BarycentricVertexBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricVertexBasis_Triangle +INTEGER(I4B) :: a(2) +a = SHAPE(lambda) +ans(1:a(2), 1:a(1)) = TRANSPOSE(lambda) +END PROCEDURE BarycentricVertexBasis_Triangle + +!---------------------------------------------------------------------------- +! VertexBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Triangle +REAL(DFP) :: lambda(3, SIZE(xij, 2)) +CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) +CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans) +END PROCEDURE VertexBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasis_Triangle +REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) +REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) +INTEGER(I4B) :: maxP, tPoints, ii, jj + +tPoints = SIZE(lambda, 2) +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) + +DO CONCURRENT(ii=1:tpoints) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) +END DO + +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=ii, ncol=jj) + +CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & + lambda=lambda, phi=phi, ans=ans) + +END PROCEDURE BarycentricEdgeBasis_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 30 Oct 2022 +! summary: Evaluate the edge basis on triangle using barycentric coordinate +! (internal only) + +MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & + lambda, phi, ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge (e1) + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge (e2) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge (e3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP), INTENT(INOUT) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) + + INTEGER(I4B) :: tPoints, a, ii + REAL(DFP) :: temp(SIZE(lambda, 2)) + !FIXME: Remove this temp, I want no allocation in this routine + + ans = 0.0_DFP + tPoints = SIZE(lambda, 2) + a = 0 + + !FIXME: Make these loop parallel + + ! edge(1) = 1 -> 2 + temp = lambda(1, :) * lambda(2, :) + DO ii = 1, pe1 - 1 + ans(:, a + ii) = temp * phi(1:tPoints, ii - 1) + END DO + + ! edge(2) = 2 -> 3 + a = pe1 - 1 + temp = lambda(2, :) * lambda(3, :) + DO ii = 1, pe2 - 1 + ans(:, a + ii) = temp & + * phi(1 + tPoints:2 * tPoints, ii - 1) + END DO + + ! edge(3) = 3 -> 1 + a = pe1 - 1 + pe2 - 1 + temp = lambda(3, :) * lambda(1, :) + DO ii = 1, pe3 - 1 + ans(:, a + ii) = temp & + * phi(1 + 2 * tPoints:3 * tPoints, ii - 1) + END DO +END SUBROUTINE BarycentricEdgeBasis_Triangle2 + +!---------------------------------------------------------------------------- +! EdgeBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasis_Triangle +REAL(DFP) :: lambda(3, SIZE(xij, 2)) +CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) +CALL BarycentricEdgeBasis_Triangle(lambda=lambda, ans=ans, pe1=pe1, & + pe2=pe2, pe3=pe3) +END PROCEDURE EdgeBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasis_Triangle +REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) +REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:order - 2) +INTEGER(I4B) :: maxP, tPoints, ii, nrow, ncol + +tPoints = SIZE(lambda, 2) +maxP = order - 2 + +DO CONCURRENT(ii=1:tpoints) + ! Cell 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! Cell 2 -> 3 + d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) + ! Cell 3 -> 1 + d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) +END DO + +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=ans, nrow=nrow, ncol=ncol) + +CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & + ans=ans) + +END PROCEDURE BarycentricCellBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricCellBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis in the cell of reference triangle (internal only) + +PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barcentric coordinates + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points + !! (lambda2-lambda1), + !! (lambda3-lambda2), + !! (lambda1-lambda3) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) + + INTEGER(I4B) :: tp, k1, k2, cnt + REAL(DFP) :: temp(SIZE(lambda, 2)) + !! FIXME: Remove this temp from there, no allocation is our goal + + tp = SIZE(lambda, 2) + temp = lambda(1, :) * lambda(2, :) * lambda(3, :) + cnt = 0 + + ! FIXME: Make this loop parallel + + DO k1 = 1, order - 2 + DO k2 = 1, order - 1 - k1 + cnt = cnt + 1 + ans(:, cnt) = temp * phi(1:tp, k1 - 1) * & + & phi(1 + 2 * tp:3 * tp, k2 - 1) + END DO + END DO + +END SUBROUTINE BarycentricCellBasis_Triangle2 + +!---------------------------------------------------------------------------- +! CellBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Triangle +REAL(DFP) :: lambda(3, SIZE(xij, 2)) +CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) +CALL BarycentricCellBasis_Triangle(lambda=lambda, ans=ans, order=order) +END PROCEDURE CellBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle1 +INTEGER(I4B) :: a, b, ii +INTEGER(I4B) :: maxP +REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), & + 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)) +REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) +LOGICAL(LGT) :: isok + +nrow = SIZE(lambda, 2) +ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) + +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) + +DO CONCURRENT(ii=1:nrow) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii) +END DO + +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + +! Vertex basis function +ans = 0.0_DFP +CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3)) + +! Edge basis function +b = 3 + +isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) +IF (isok) THEN + a = b + 1 + b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 + CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & + lambda=lambda, phi=phi, ans=ans(:, a:b)) +END IF + +! Cell basis function +IF (order .GT. 2_I4B) THEN + a = b + 1 + b = a - 1 + INT((order - 1) * (order - 2) / 2) + CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & + ans=ans(:, a:b)) +END IF + +END PROCEDURE BarycentricHeirarchicalBasis_Triangle1 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2 +CALL BarycentricHeirarchicalBasis_Triangle1(order=order, pe1=order, & + pe2=order, pe3=order, lambda=lambda, & + refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricHeirarchicalBasis_Triangle2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Triangle1 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Triangle1_(order=order, pe1=pe1, pe2=pe2, pe3=pe3, & + xij=xij, refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Triangle1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Triangle1_ +REAL(DFP) :: lambda(3, SIZE(xij, 2)) +CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) +CALL BarycentricHeirarchicalBasis_Triangle(order=order, pe1=pe1, pe2=pe2, & + pe3=pe3, lambda=lambda, refTriangle=refTriangle, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE HeirarchicalBasis_Triangle1_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Triangle2 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Triangle2_(order=order, xij=xij, & + refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Triangle2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Triangle2_ +REAL(DFP) :: lambda(3, SIZE(xij, 2)) +CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) +CALL BarycentricHeirarchicalBasis_Triangle(order=order, lambda=lambda, & + refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Triangle2_ + +!---------------------------------------------------------------------------- +! BarycentricVertexBasisGradient_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricVertexBasisGradient_Triangle +INTEGER(I4B) :: ii, tp + +tp = SIZE(lambda, 2) +ans(1:tp, 1:3, 1:3) = 0.0_DFP +DO CONCURRENT(ii=1:3) + ans(1:tp, ii, ii) = 1.0_DFP +END DO + +END PROCEDURE BarycentricVertexBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasisGradient_Triangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasisGradient_Triangle +REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) +REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) +REAL(DFP) :: gradientPhi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) +INTEGER(I4B) :: maxP, tPoints, ii, a, b + +tPoints = SIZE(lambda, 2) +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) + +DO CONCURRENT(ii=1:tpoints) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) +END DO + +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + +CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & + nrow=a, ncol=b) + +CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & + lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans) + +END PROCEDURE BarycentricEdgeBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu and Vikas Sharma, Ph. D. +! date: 2024-04-21 +! summary: Evaluate the gradient of the edge basis on triangle +! using barycentric coordinate + +PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle2(pe1, pe2, pe3, & + lambda, phi, gradientPhi, ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge (e1) + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge (e2) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge (e3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:) + !! gradients of lobatto kernel functions + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) + + INTEGER(I4B) :: tp, a, ii + REAL(DFP) :: temp(SIZE(lambda, 2)) + ! FIXME: Remove this temp + + tp = SIZE(lambda, 2) + + !FIXME: Make these loop parallel + + a = 0 + ! edge(1) = 1 -> 2 + temp = lambda(1, :) * lambda(2, :) + DO ii = 1, pe1 - 1 + ans(1:tp, a + ii, 1) = lambda(2, :) * phi(1:tp, ii - 1) - & + temp * gradientPhi(1:tp, ii - 1) + ans(1:tp, a + ii, 2) = lambda(1, :) * phi(1:tp, ii - 1) + & + temp * gradientPhi(1:tp, ii - 1) + ans(1:tp, a + ii, 3) = 0.0_DFP + END DO + + ! edge(2) = 2 -> 3 + a = pe1 - 1 + temp = lambda(2, :) * lambda(3, :) + DO ii = 1, pe2 - 1 + ans(1:tp, a + ii, 1) = 0.0_DFP + + ans(1:tp, a + ii, 2) = lambda(3, :) * & + phi(1 + tp:2 * tp, ii - 1) - & + temp * gradientPhi(1 + tp:2 * tp, ii - 1) + + ans(1:tp, a + ii, 3) = lambda(2, :) * & + phi(1 + tp:2 * tp, ii - 1) + & + temp * gradientPhi(1 + tp:2 * tp, ii - 1) + END DO + + ! edge(3) = 3 -> 1 + a = pe1 - 1 + pe2 - 1 + temp = lambda(3, :) * lambda(1, :) + DO ii = 1, pe3 - 1 + ans(1:tp, a + ii, 1) = lambda(3, :) * & + phi(1 + 2 * tp:3 * tp, ii - 1) + & + temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1) + + ans(1:tp, a + ii, 2) = 0.0_DFP + + ans(1:tp, a + ii, 3) = lambda(1, :) * & + phi(1 + 2 * tp:3 * tp, ii - 1) - & + temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1) + END DO +END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2 + +!---------------------------------------------------------------------------- +! BarycentricVertexBasisGradient_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasisGradient_Triangle +INTEGER(I4B) :: a, b, ii, maxP, tp +REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) + +tp = SIZE(lambda, 2) +maxP = order - 2 + +a = 3 * tp; b = maxP +ALLOCATE (phi(a, b), gradientPhi(a, b), d_lambda(a)) + +DO CONCURRENT(ii=1:tp) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii) +END DO + +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + +CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & + nrow=a, ncol=b) + +CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & + phi=phi, gradientPhi=gradientPhi, ans=ans) +END PROCEDURE BarycentricCellBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! BarycentricCellBasisGradient_Triangle +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-04-21 +! summary: Evaluate the gradient of the cell basis on triangle + +PURE SUBROUTINE BarycentricCellBasisGradient_Triangle2(order, lambda, phi, & + gradientPhi, ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:) + !! gradients of lobatto kernel functions + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2), 3) + + ! internal variables + INTEGER(I4B) :: tPoints, k1, k2, cnt + REAL(DFP) :: temp1(SIZE(lambda, 2)), temp2(SIZE(lambda, 2)) + REAL(DFP) :: temp3(SIZE(lambda, 2)), temp4(SIZE(lambda, 2)) + + ! FIXME: Remove these temps + + tPoints = SIZE(lambda, 2) + temp1 = lambda(1, :) * lambda(2, :) * lambda(3, :) + temp2 = lambda(2, :) * lambda(3, :) + temp3 = lambda(1, :) * lambda(3, :) + temp4 = lambda(1, :) * lambda(2, :) + cnt = 0 + + ! FIXME: make these loop parallel + + DO k1 = 1, order - 2 + DO k2 = 1, order - 1 - k1 + cnt = cnt + 1 + ans(:, cnt, 1) = temp2 * phi(1:tPoints, k1 - 1) * & + phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & + temp1 * (gradientPhi(1:tPoints, k1 - 1) * & + phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & + phi(1:tPoints, k1 - 1) * & + gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1)) + ans(:, cnt, 2) = (temp3 * phi(1:tPoints, k1 - 1) + & + temp1 * gradientPhi(1:tPoints, k1 - 1)) * & + phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) + ans(:, cnt, 3) = (temp4 * phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & + temp1 * gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1)) * & + phi(1:tPoints, k1 - 1) + END DO + END DO +END SUBROUTINE BarycentricCellBasisGradient_Triangle2 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1 +INTEGER(I4B) :: a, b, ii, maxP, tp +REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) +LOGICAL(LGT) :: isok + +tp = SIZE(lambda, 2) +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) + +a = 3 * tp; b = maxP +ALLOCATE (phi(a, 0:b), gradientPhi(a, 0:b), d_lambda(a)) + +DO CONCURRENT(ii=1:tp) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii) +END DO + +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + +CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & + nrow=a, ncol=b) + +! gradient of vertex basis +ans(1:tp, 1:3, 1:3) = 0.0_DFP +DO CONCURRENT(ii=1:3) + ans(1:tp, ii, ii) = 1.0_DFP +END DO + +! gradient of Edge basis function +b = 3 +isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) +IF (isok) THEN + a = b + 1 + b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 + CALL BarycentricEdgeBasisGradient_Triangle2( & + pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, & + phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :)) +END IF + +! gradient of Cell basis function +IF (order .GT. 2_I4B) THEN + a = b + 1 + b = a - 1 + INT((order - 1) * (order - 2) / 2) + CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & + phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :)) +END IF + +DEALLOCATE (phi, gradientPhi, d_lambda) +END PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1 +INTEGER(I4B) :: s(3) +CALL HeirarchicalBasisGradient_Triangle1_(order=order, pe1=pe1, & + pe2=pe2, pe3=pe3, xij=xij, refTriangle=refTriangle, ans=ans, tsize1=s(1), & + tsize2=s(2), tsize3=s(3)) +END PROCEDURE HeirarchicalBasisGradient_Triangle1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1_ +REAL(DFP) :: jac(3, 2) +REAL(DFP), ALLOCATABLE :: lambda(:, :), dPhi(:, :, :) +INTEGER(I4B) :: ii, jj, kk + +ii = SIZE(xij, 2) +jj = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) +ALLOCATE (lambda(3, ii), dPhi(ii, jj, 3)) +tsize1 = SIZE(xij, 2) +tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) +tsize3 = 2 + +CALL BarycentricCoordTriangle_(xin=xij, refTriangle=refTriangle, ans=lambda) +CALL BarycentricHeirarchicalBasisGradient_Triangle( & + order=order, pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, & + refTriangle=refTriangle, ans=dPhi) + +SELECT CASE (refTriangle(1:1)) +CASE ("B", "b") + jac(1, :) = [-0.50_DFP, -0.50_DFP] + jac(2, :) = [0.50_DFP, 0.0_DFP] + jac(3, :) = [0.0_DFP, 0.50_DFP] +CASE ("U", "u") + jac(1, :) = [-1.0_DFP, -1.0_DFP] + jac(2, :) = [1.0_DFP, 0.0_DFP] + jac(3, :) = [0.0_DFP, 1.0_DFP] +END SELECT + +DO CONCURRENT(ii=1:tsize1, jj=1:tsize2, kk=1:tsize3) + ans(ii, jj, kk) = dPhi(ii, jj, 1) * jac(1, kk) & + + dPhi(ii, jj, 2) * jac(2, kk) & + + dPhi(ii, jj, 3) * jac(3, kk) +END DO + +DEALLOCATE (lambda, dPhi) + +END PROCEDURE HeirarchicalBasisGradient_Triangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE HeirarchicalBasisMethods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 new file mode 100644 index 000000000..50fd1448c --- /dev/null +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -0,0 +1,346 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(TriangleInterpolationUtility) LagrangeBasisMethods +USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_ +USE ErrorHandling, ONLY: Errormsg +USE InputUtility, ONLY: Input +USE GE_CompRoutineMethods, ONLY: GetInvMat +USE GE_LUMethods, ONLY: LUSolve, GetLU + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! LagrangeDegree_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Triangle +INTEGER(I4B) :: nrow, ncol +nrow = (order + 1) * (order + 2) / 2_I4B +ncol = 2 +ALLOCATE (ans(nrow, ncol)) +CALL LagrangeDegree_Triangle_(order=order, ans=ans, ncol=ncol, nrow=nrow) +END PROCEDURE LagrangeDegree_Triangle + +!---------------------------------------------------------------------------- +! LagrangeDegree_Triangle_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Triangle_ +INTEGER(I4B) :: ii, jj, kk + +nrow = (order + 1) * (order + 2) / 2_I4B +ncol = 2 + +kk = 0 +DO jj = 0, order + DO ii = 0, order - jj + kk = kk + 1 + ans(kk, 1) = ii + ans(kk, 2) = jj + END DO +END DO + +END PROCEDURE LagrangeDegree_Triangle_ + +!---------------------------------------------------------------------------- +! LagrangeDOF_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Triangle +ans = (order + 1) * (order + 2) / 2_I4B +END PROCEDURE LagrangeDOF_Triangle + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Triangle +ans = (order - 1) * (order - 2) / 2_I4B +END PROCEDURE LagrangeInDOF_Triangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info, nrow, ncol + +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, ans=V, & + nrow=nrow, ncol=ncol) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle2 +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info + +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle4 +INTEGER(I4B) :: basisType0, nrow, ncol +CHARACTER(:), ALLOCATABLE :: ref0 + +basisType0 = Input(default=Monomial, option=basisType) +ref0 = Input(default="UNIT", option=refTriangle) +CALL LagrangeCoeff_Triangle4_(order=order, xij=xij, basisType=basisType0, & + refTriangle=ref0, ans=ans, nrow=nrow, ncol=ncol) +ref0 = "" +END PROCEDURE LagrangeCoeff_Triangle4 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle4_ + +SELECT CASE (basisType) + +CASE (Monomial) + CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) + + CALL Dubiner_Triangle_(order=order, xij=xij, refTriangle=refTriangle, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (Heirarchical) + + CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & + pe3=order, xij=xij, refTriangle=refTriangle, & + ans=ans, nrow=nrow, ncol=ncol) +END SELECT + +CALL GetInvMat(ans(1:nrow, 1:ncol)) + +END PROCEDURE LagrangeCoeff_Triangle4_ + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Triangle1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow +INTEGER(I4B) :: degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) + +basisType0 = Input(default=Monomial, option=basisType) +firstCall0 = Input(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + + IF (firstCall0) THEN + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, & + basisType=basisType0, refTriangle=refTriangle, & + ans=coeff, nrow=nrow, ncol=ncol) + coeff0 = TRANSPOSE(coeff) + ELSE + coeff0 = TRANSPOSE(coeff) + END IF + +ELSE + + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, & + basisType=basisType0, refTriangle=refTriangle, & + ans=coeff0, nrow=nrow, ncol=ncol) + coeff0 = TRANSPOSE(coeff0) + +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) + + tdof = SIZE(xij, 2) + + DO ii = 1, tdof + xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) + END DO + +CASE (Heirarchical) + + CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, & + pe2=order, pe3=order, xij=RESHAPE(x, [2, 1]), & + refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) + +CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) + + CALL Dubiner_Triangle_(order=order, xij=RESHAPE(x, [2, 1]), & + refTriangle=refTriangle, ans=xx, nrow=nrow, ncol=ncol) + +END SELECT + +ans = MATMUL(coeff0, xx(1, :)) +END PROCEDURE LagrangeEvalAll_Triangle1 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Triangle2 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow +INTEGER(I4B) :: degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) + +basisType0 = Input(default=Monomial, option=basisType) +firstCall0 = Input(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & + refTriangle=refTriangle, ans=coeff, nrow=nrow, ncol=ncol) + coeff0 = coeff + + ELSE + + coeff0 = coeff + + END IF +ELSE + + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & + refTriangle=refTriangle, ans=coeff0, nrow=nrow, ncol=ncol) + +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) + tdof = SIZE(xij, 2) + + DO ii = 1, tdof + xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2) + END DO + +CASE (Heirarchical) + + CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & + pe3=order, xij=x, refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) + +CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) + + CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, & + ans=xx, nrow=nrow, ncol=ncol) + +END SELECT + +ans = MATMUL(xx, coeff0) +END PROCEDURE LagrangeEvalAll_Triangle2 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Triangle1 +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, s(3) +INTEGER(I4B) :: degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & + & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br + +basisType0 = Input(default=Monomial, option=basisType) +firstCall0 = Input(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & + refTriangle=refTriangle, ans=coeff, nrow=s(1), ncol=s(2)) + END IF + + coeff0 = coeff +ELSE + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & + refTriangle=refTriangle, ans=coeff0, nrow=s(1), ncol=s(2)) +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=s(1), ncol=s(2)) + + tdof = SIZE(xij, 2) + + DO ii = 1, tdof + ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) + bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) + ar = REAL(degree(ii, 1_I4B), DFP) + br = REAL(degree(ii, 2_I4B), DFP) + xx(:, ii, 1) = (ar * x(1, :)**ai) * x(2, :)**degree(ii, 2) + xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi) + END DO + +CASE (Heirarchical) + + CALL HeirarchicalBasisGradient_Triangle_(order=order, pe1=order, pe2=order, & + pe3=order, xij=x, refTriangle=refTriangle, ans=xx, tsize1=s(1), & + tsize2=s(2), tsize3=s(3)) + +CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) + + CALL OrthogonalBasisGradient_Triangle_(order=order, xij=x, & + refTriangle=refTriangle, ans=xx, tsize1=s(1), tsize2=s(2), tsize3=s(3)) + +END SELECT + +DO ii = 1, 2 + ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) + ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) +END DO + +END PROCEDURE LagrangeGradientEvalAll_Triangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE LagrangeBasisMethods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..9e50e8c6a --- /dev/null +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.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 + +SUBMODULE(TriangleInterpolationUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetTotalDOF_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Triangle +ans = (order + 1) * (order + 2) / 2_I4B +END PROCEDURE GetTotalDOF_Triangle + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Triangle +ans = (order - 1) * (order - 2) / 2_I4B +END PROCEDURE GetTotalInDOF_Triangle + +!---------------------------------------------------------------------------- +! RefElemDomain_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Triangle +SELECT CASE (UpperCase(baseContinuity)) +CASE ("H1") + SELECT CASE (UpperCase(baseInterpol)) + CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") + ans = "UNIT" + CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") + ans = "UNIT" + CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") + ans = "UNIT" + CASE ( & + & "HIERARCHICALPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHICALPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION") + ans = "BIUNIT" + CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") + ans = "BIUNIT" + CASE DEFAULT + CALL Errormsg(& + & msg="No case found for given baseInterpol="//TRIM(baseInterpol), & + & file=__FILE__, & + & line=__LINE__,& + & routine="RefElemDomain_Triangle()", & + & unitno=stderr) + END SELECT +CASE DEFAULT + CALL Errormsg(& + & msg="No case found for given baseContinuity="//TRIM(baseContinuity), & + & file=__FILE__, & + & line=__LINE__,& + & routine="RefElemDomain_Triangle()", & + & unitno=stderr) +END SELECT +END PROCEDURE RefElemDomain_Triangle + +!---------------------------------------------------------------------------- +! FacetConnectivity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetConnectivity_Triangle +TYPE(String) :: baseInterpol0 +TYPE(String) :: baseContinuity0 + +baseInterpol0 = UpperCase(baseInterpol) +baseContinuity0 = UpperCase(baseContinuity) + +SELECT CASE (baseInterpol0%chars()) +CASE ( & + & "HIERARCHYPOLYNOMIAL", & + & "HIERARCHY", & + & "HEIRARCHYPOLYNOMIAL", & + & "HEIRARCHY", & + & "HIERARCHYINTERPOLATION", & + & "HEIRARCHYINTERPOLATION", & + & "ORTHOGONALPOLYNOMIAL", & + & "ORTHOGONAL", & + & "ORTHOGONALINTERPOLATION") + ans(:, 1) = [1, 2] + ans(:, 2) = [1, 3] + ans(:, 3) = [2, 3] +CASE DEFAULT + ans(:, 1) = [1, 2] + ans(:, 2) = [2, 3] + ans(:, 3) = [3, 1] +END SELECT +END PROCEDURE FacetConnectivity_Triangle + +!---------------------------------------------------------------------------- +! EquidistancePoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Triangle +INTEGER(I4B) :: nsd, n, ne, i1, i2 +REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu + +x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + x(1:nsd, 1:3) = xij(1:nsd, 1:3) +ELSE + nsd = 2_I4B + x(1:nsd, 1) = [0.0, 0.0] + x(1:nsd, 2) = [1.0, 0.0] + x(1:nsd, 3) = [0.0, 1.0] +END IF + +n = LagrangeDOF_Triangle(order=order) +ALLOCATE (ans(nsd, n)) +ans = 0.0_DFP + +!! points on vertex +ans(1:nsd, 1:3) = x(1:nsd, 1:3) + +!! points on edge +ne = LagrangeInDOF_Line(order=order) +i2 = 3 +IF (order .GT. 1_I4B) THEN + i1 = i2 + 1; i2 = i1 + ne - 1 + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, [1, 2])) + !! + i1 = i2 + 1; i2 = i1 + ne - 1 + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, [2, 3])) + !! + i1 = i2 + 1; i2 = i1 + ne - 1 + ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & + & order=order, & + & xij=x(1:nsd, [3, 1])) + !! +END IF + +!! points on face +IF (order .GT. 2_I4B) THEN + !! + IF (order .EQ. 3_I4B) THEN + i1 = i2 + 1 + ans(1:nsd, i1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP + ELSE + !! + e1 = x(:, 2) - x(:, 1) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 3) - x(:, 1) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) + !! + e1 = x(:, 3) - x(:, 2) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 1) - x(:, 2) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) + !! + e1 = x(:, 1) - x(:, 3) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 2) - x(:, 3) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) + !! + i1 = i2 + 1 + ans(1:nsd, i1:) = EquidistancePoint_Triangle( & + & order=order - 3, & + & xij=xin(1:nsd, 1:3)) + !! + END IF +END IF + +END PROCEDURE EquidistancePoint_Triangle + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Triangle +INTEGER(I4B) :: nsd, n +REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu + +IF (order .LT. 3_I4B) THEN + ALLOCATE (ans(0, 0)) + RETURN +END IF + +x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + x(1:nsd, 1:3) = xij(1:nsd, 1:3) +ELSE + nsd = 2_I4B + x(1:nsd, 1) = [0.0, 0.0] + x(1:nsd, 2) = [1.0, 0.0] + x(1:nsd, 3) = [0.0, 1.0] +END IF + +n = LagrangeInDOF_Triangle(order=order) +ALLOCATE (ans(nsd, n)) +ans = 0.0_DFP + +!! points on face +IF (order .EQ. 3_I4B) THEN + ans(1:nsd, 1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP +ELSE + !! + e1 = x(:, 2) - x(:, 1) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 3) - x(:, 1) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) + !! + e1 = x(:, 3) - x(:, 2) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 1) - x(:, 2) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) + !! + e1 = x(:, 1) - x(:, 3) + avar = NORM2(e1) + e1 = e1 / avar + lam = avar / order + e2 = x(:, 2) - x(:, 3) + avar = NORM2(e2) + e2 = e2 / avar + mu = avar / order + xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) + !! + ans(1:nsd, 1:) = EquidistancePoint_Triangle( & + & order=order - 3, & + & xij=xin(1:nsd, 1:3)) + !! +END IF + +END PROCEDURE EquidistanceInPoint_Triangle + +!---------------------------------------------------------------------------- +! BlythPozrikidis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BlythPozrikidis_Triangle +REAL(DFP) :: v(order + 1), xi(order + 1, order + 1), eta(order + 1, order + 1) +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: nsd, N, ii, jj, kk +CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle" + +v = InterpolationPoint_Line( & + & order=order, & + & ipType=ipType, & + & xij=[0.0_DFP, 1.0_DFP], & + & layout="INCREASING", & + & lambda=lambda, & + & beta=beta, & + & alpha=alpha) + +N = LagrangeDOF_Triangle(order=order) + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2 +END IF + +CALL Reallocate(ans, nsd, N) +CALL Reallocate(temp, 2, N) + +xi = 0.0_DFP +eta = 0.0_DFP + +DO ii = 1, order + 1 + DO jj = 1, order + 2 - ii + kk = order + 3 - ii - jj + xi(ii, jj) = (1.0 + 2.0 * v(ii) - v(jj) - v(kk)) / 3.0_DFP + eta(ii, jj) = (1.0 + 2.0 * v(jj) - v(ii) - v(kk)) / 3.0_DFP + END DO +END DO + +IF (layout .EQ. "VEFC") THEN + + CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N) + + IF (PRESENT(xij)) THEN + ans = FromUnitTriangle2Triangle(xin=temp, & + & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) + ELSE + ans = temp + END IF + +ELSE + CALL ErrorMsg( & + & msg="Only layout=VEFC is allowed, given layout is " & + & //TRIM(layout), & + & file=__FILE__, & + & routine=myname, & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +IF (ALLOCATED(temp)) DEALLOCATE (temp) + +END PROCEDURE BlythPozrikidis_Triangle + +!---------------------------------------------------------------------------- +! Isaac_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Isaac_Triangle +REAL(DFP) :: xi(order + 1, order + 1), eta(order + 1, order + 1) +REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) +INTEGER(I4B) :: nsd, N, cnt, ii, jj +CHARACTER(*), PARAMETER :: myName = "Isaac_Triangle" + +rPoints = RecursiveNode2D(order=order, ipType=ipType, domain="UNIT", & + & alpha=alpha, beta=beta, lambda=lambda) + +N = SIZE(rPoints, 2) + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2 +END IF + +CALL Reallocate(ans, nsd, N) + +!! convert from rPoints to xi and eta +cnt = 0 +xi = 0.0_DFP +eta = 0.0_DFP + +DO ii = 1, order + 1 + DO jj = 1, order + 2 - ii + cnt = cnt + 1 + xi(ii, jj) = rPoints(1, cnt) + eta(ii, jj) = rPoints(2, cnt) + END DO +END DO + +IF (layout .EQ. "VEFC") THEN + CALL Reallocate(temp, 2, N) + CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N) + IF (PRESENT(xij)) THEN + ans = FromUnitTriangle2Triangle(xin=temp, & + & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) + ELSE + ans = temp + END IF +ELSE + CALL ErrorMsg( & + & msg="Only layout=VEFC is allowed, given layout is " & + & //TRIM(layout), & + & file=__FILE__, & + & routine=myname, & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF + +IF (ALLOCATED(temp)) DEALLOCATE (temp) +IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints) +END PROCEDURE Isaac_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJ2VEFC_Triangle +INTEGER(I4B) :: cnt, m, ii, jj, ll, llt, llr + +cnt = 0 +m = order +llt = INT((m - 1) / 3) +llr = MOD(m - 1, 3) +DO ll = 0, llt + !! v1 + cnt = cnt + 1 + ii = 1 + ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + !! v2 + cnt = cnt + 1 + ii = m + 1 - 2 * ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + !! v3 + cnt = cnt + 1 + ii = 1 + ll; jj = m + 1 - 2 * ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + !! nodes on edge 12 + jj = ll + 1 + DO ii = 2 + ll, m - 2 * ll + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + !! nodes on edge 23 + DO jj = 2 + ll, m - 2 * ll + cnt = cnt + 1 + ii = m - ll + 2 - jj + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + !! nodes on edge 31 + ii = ll + 1 + DO jj = m - 2 * ll, 2 + ll, -1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + !! internal nodes +END DO + +IF (llr .EQ. 2_I4B) THEN + !! a internal point + cnt = cnt + 1 + ll = llt + 1 + ii = 1 + ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) +END IF + +IF (cnt .NE. N) THEN + CALL ErrorMsg( & + & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" & + & //tostring(N), & + & file=__FILE__, & + & routine="IJ2VEFC_Triangle()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END IF +END PROCEDURE IJ2VEFC_Triangle + +!---------------------------------------------------------------------------- +! InterpolationPoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Triangle +CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle" + +SELECT CASE (ipType) +CASE (Equidistance) + ans = EquidistancePoint_Triangle(xij=xij, order=order) +CASE (Feket, Hesthaven, ChenBabuska) + CALL ErrorMsg( & + & msg="Feket, Hesthaven, ChenBabuska nodes not available", & + & file=__FILE__, & + & routine=myname, & + & line=__LINE__, & + & unitno=stderr) + RETURN +CASE (BlythPozLegendre) + ans = BlythPozrikidis_Triangle( & + & order=order, & + & ipType=GaussLegendreLobatto, & + & layout="VEFC", & + & xij=xij, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +CASE (BlythPozChebyshev) + ans = BlythPozrikidis_Triangle( & + & order=order, & + & ipType=GaussChebyshevLobatto, & + & layout="VEFC", & + & xij=xij, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +CASE (IsaacLegendre, GaussLegendreLobatto) + ans = Isaac_Triangle( & + & order=order, & + & ipType=GaussLegendreLobatto, & + & layout="VEFC", & + & xij=xij, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +CASE (IsaacChebyshev, GaussChebyshevLobatto) + ans = Isaac_Triangle( & + & order=order, & + & ipType=GaussChebyshevLobatto, & + & layout="VEFC", & + & xij=xij, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +CASE DEFAULT + ans = Isaac_Triangle( & + & order=order, & + & ipType=ipType, & + & layout="VEFC", & + & xij=xij, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END SELECT +END PROCEDURE InterpolationPoint_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 new file mode 100644 index 000000000..edc3b5850 --- /dev/null +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 @@ -0,0 +1,116 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(TriangleInterpolationUtility) OrthogonalBasisMethods +USE MappingUtility, ONLY: FromTriangle2Square_, & + FromLine2Line_ + +USE QuadrangleInterpolationUtility, ONLY: Dubiner_Quadrangle_, & + DubinerGradient_Quadrangle_ +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Dubiner_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Triangle1 +INTEGER(I4B) :: nrow, ncol +CALL Dubiner_Triangle1_(order=order, xij=xij, reftriangle=reftriangle, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE Dubiner_Triangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Triangle1_ +REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) +CALL FromTriangle2Square_(xin=xij, ans=x, from=reftriangle, to="B") +CALL Dubiner_Quadrangle_(order=order, xij=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE Dubiner_Triangle1_ + +!---------------------------------------------------------------------------- +! Dubiner_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Triangle2 +INTEGER(I4B) :: nrow, ncol +CALL Dubiner_Triangle2_(order=order, x=x, y=y, reftriangle=reftriangle, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE Dubiner_Triangle2 + +!---------------------------------------------------------------------------- +! Dubiner_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Triangle2_ +REAL(DFP), ALLOCATABLE :: x0(:), y0(:) +INTEGER(I4B) :: ii, jj + +ii = SIZE(x) +jj = SIZE(y) +ALLOCATE (x0(ii), y0(jj)) + +CALL FromLine2Line_(xin=x, ans=x0, from=refTriangle, to="B") +CALL FromLine2Line_(xin=y, ans=y0, from=refTriangle, to="B") + +CALL Dubiner_Quadrangle_(order=order, x=x0, y=y0, ans=ans, nrow=nrow, & + ncol=ncol) +DEALLOCATE (x0, y0) +END PROCEDURE Dubiner_Triangle2_ + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Triangle1 +INTEGER(I4B) :: s(3) +CALL OrthogonalBasisGradient_Triangle1_(order=order, xij=xij, & + reftriangle=reftriangle, ans=ans, tsize1=s(1), tsize2=s(2), tsize3=s(3)) +END PROCEDURE OrthogonalBasisGradient_Triangle1 + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Triangle1_ +INTEGER(I4B) :: ii, s(2), jj +REAL(DFP), ALLOCATABLE :: x(:, :) + +s = SHAPE(xij) +ALLOCATE (x(s(1), s(2))) + +CALL FromTriangle2Square_(xin=xij, ans=x, from=reftriangle, to="B") +CALL DubinerGradient_Quadrangle_(order=order, xij=x, ans=ans, tsize1=tsize1, & + tsize2=tsize2, tsize3=tsize3) + +DO CONCURRENT(ii=1:tsize2, jj=1:tsize1) + + ans(jj, ii, 1) = ans(jj, ii, 1) * 4.0_DFP / (1.0_DFP - x(2, jj)) + ans(jj, ii, 2) = ans(jj, ii, 1) * (1.0_DFP + x(1, jj)) * 0.5_DFP & + + 2.0_DFP * ans(jj, ii, 2) +END DO + +DEALLOCATE (x) + +END PROCEDURE OrthogonalBasisGradient_Triangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE OrthogonalBasisMethods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 new file mode 100644 index 000000000..26a49cb99 --- /dev/null +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -0,0 +1,219 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(TriangleInterpolationUtility) QuadratureMethods +USE BaseMethod +USE QuadraturePoint_Triangle_Solin, ONLY: QuadraturePointTriangleSolin, & + QuadraturePointTriangleSolin_, & + QuadratureNumberTriangleSolin +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Triangle1 +INTEGER(I4B) :: np(1), nq(1), n +n = 1_I4B + INT(order / 2, kind=I4B) +np(1) = n + 1 +nq(1) = n +ans = TensorQuadraturePoint_Triangle2( & + & nipsx=np, & + & nipsy=nq, & + & quadType=quadType, & + & refTriangle=refTriangle, & + & xij=xij) +END PROCEDURE TensorQuadraturePoint_Triangle1 + +!---------------------------------------------------------------------------- +! TensorQuadraturePoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Triangle2 +INTEGER(I4B) :: np(1), nq(1), nsd +REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :) +TYPE(String) :: astr + +astr = TRIM(UpperCase(refTriangle)) +np(1) = nipsx(1) +nq(1) = nipsy(1) + +temp_q = QuadraturePoint_Quadrangle(& + & nipsx=np, & + & nipsy=nq, & + & quadType1=GaussLegendreLobatto, & + & quadType2=GaussJacobiRadauLeft, & + & refQuadrangle="BIUNIT", & + & alpha2=1.0_DFP, & + & beta2=0.0_DFP) + +CALL Reallocate(temp_t, SIZE(temp_q, 1, kind=I4B), SIZE(temp_q, 2, kind=I4B)) +temp_t(1:2, :) = FromBiUnitSqr2UnitTriangle(xin=temp_q(1:2, :)) +temp_t(3, :) = temp_q(3, :) / 8.0_DFP + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2_I4B +END IF + +CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_q, 2, kind=I4B)) + +IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromUnitTriangle2Triangle( & + & xin=temp_t(1:2, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3)) + ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & + & from="UNIT", & + & to="TRIANGLE", & + & xij=xij) +ELSE + IF (astr%chars() .EQ. "BIUNIT") THEN + ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) + + ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & + & from="UNIT", & + & to="BIUNIT") + + ELSE + ans = temp_t + END IF +END IF + +IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q) +IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) + +END PROCEDURE TensorQuadraturePoint_Triangle2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Triangle1 +INTEGER(I4B) :: nips(1), nsd, ii, jj +REAL(DFP), ALLOCATABLE :: temp_t(:, :) +LOGICAL(LGT) :: abool + +nips(1) = QuadratureNumberTriangleSolin(order=order) + +IF (nips(1) .LE. 0) THEN + ans = TensorQuadraturepoint_Triangle(order=order, quadtype=quadtype, & + reftriangle=reftriangle, xij=xij) + RETURN +END IF + +ALLOCATE (temp_t(3, nips(1))) +CALL QuadraturePointTriangleSolin_(nips=nips, ans=temp_t, nrow=ii, & + ncol=jj) + +nsd = 2_I4B +abool = PRESENT(xij) +IF (abool) nsd = SIZE(xij, 1) + +ii = nsd + 1 +ALLOCATE (ans(ii, jj)) + +IF (abool) THEN + + CALL FromTriangle2Triangle_(xin=temp_t(1:2, :), x1=xij(1:nsd, 1), & + x2=xij(1:nsd, 2), x3=xij(1:nsd, 3), ans=ans(1:nsd, :), & + from="U", to="T") + + ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", & + to="TRIANGLE", xij=xij) + + RETURN + +END IF + +abool = reftriangle(1:1) == "B" .OR. reftriangle(1:1) == "b" + +IF (abool) THEN + ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) + ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", to="BIUNIT") + RETURN +END IF + +ans = temp_t + +IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) + +END PROCEDURE QuadraturePoint_Triangle1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Triangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Triangle2 +INTEGER(I4B) :: nsd +REAL(DFP), ALLOCATABLE :: temp_t(:, :) +TYPE(string) :: astr + +IF (nips(1) .LE. QuadratureNumberTriangleSolin(order=20_I4B)) THEN + astr = TRIM(UpperCase(refTriangle)) + temp_t = QuadraturePointTriangleSolin(nips=nips) + + IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + ELSE + nsd = 2_I4B + END IF + + CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_t, 2, kind=I4B)) + + IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromUnitTriangle2Triangle( & + & xin=temp_t(1:2, :), & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3)) + ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & + & from="UNIT", & + & to="TRIANGLE", & + & xij=xij) + ELSE + IF (astr%chars() .EQ. "BIUNIT") THEN + ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) + ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & + & from="UNIT", & + & to="BIUNIT") + + ELSE + ans = temp_t + END IF + END IF + + IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) +ELSE + CALL Errormsg( & + & msg="This routine should be called for economical"// & + & " quadrature points only, otherwise call QuadraturePoint_Triangle1()", & + & file=__FILE__, & + & line=__LINE__, & + & routine="QuadraturePoint_Triangle2()", & + & unitNo=stdout) + RETURN +END IF +END PROCEDURE QuadraturePoint_Triangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE QuadratureMethods diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..2c5e7e9d8 --- /dev/null +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -0,0 +1,1221 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(UltrasphericalPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! UltrasphericalAlpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalAlpha +ans = 0.0_DFP +END PROCEDURE UltrasphericalAlpha + +!---------------------------------------------------------------------------- +! UltrasphericalBeta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalBeta +REAL(DFP) :: avar, bvar +!! +SELECT CASE (n) +CASE (0_I4B) + avar = pi * GAMMA(2.0_DFP * lambda) + bvar = (GAMMA(lambda))**2 * lambda * 2.0_DFP**(2.0_DFP * lambda - 1.0_DFP) + ans = avar / bvar +CASE (1_I4B) + ans = 0.5_DFP / (1.0_DFP + lambda) +CASE DEFAULT + avar = n * (2.0_DFP * lambda + n - 1.0_DFP) + bvar = 4.0_DFP * (n + lambda) * (n + lambda - 1.0_DFP) + ans = avar / bvar +END SELECT +END PROCEDURE UltrasphericalBeta + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetUltrasphericalRecurrenceCoeff +REAL(DFP) :: avar, bvar +INTEGER(I4B) :: ii +!! +IF (n .LE. 0) RETURN +!! +alphaCoeff = 0.0_DFP +!! +avar = pi * GAMMA(2.0_DFP * lambda) +bvar = (GAMMA(lambda))**2 * lambda * 2.0_DFP**(2.0_DFP * lambda - 1.0_DFP) +betaCoeff(0) = avar / bvar +!! +IF (n .EQ. 1) RETURN +!! +betaCoeff(1) = 0.5_DFP / (1.0_DFP + lambda) +!! +IF (n .EQ. 2) RETURN +!! +DO ii = 2, n - 1 + avar = ii * (2.0_DFP * lambda + ii - 1.0_DFP) + bvar = 4.0_DFP * (ii + lambda) * (ii + lambda - 1.0_DFP) + betaCoeff(ii) = avar / bvar +END DO +!! +END PROCEDURE GetUltrasphericalRecurrenceCoeff + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetUltrasphericalRecurrenceCoeff2 +REAL(DFP) :: j +INTEGER(I4B) :: ii +!! +IF (n .LT. 1) RETURN +B = 0.0_DFP +!! +DO ii = 1, n + j = REAL(ii, KIND=DFP) + A(ii - 1) = 2 * (j + lambda - 1) / j; + C(ii - 1) = (j + 2 * lambda - 2) / j; +END DO +!! +END PROCEDURE GetUltrasphericalRecurrenceCoeff2 + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalLeadingCoeff +REAL(DFP) :: a1, a2 +a1 = (2.0_DFP**n) * GAMMA(n + lambda) +a2 = Factorial(n) * GAMMA(lambda) +ans = a1 / a2 +END PROCEDURE UltrasphericalLeadingCoeff + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalLeadingCoeffRatio +ans = 2.0_DFP * (n + lambda) / (n + 1.0_DFP) +END PROCEDURE UltrasphericalLeadingCoeffRatio + +!---------------------------------------------------------------------------- +! UltrasphericalNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalNormSqr +REAL(DFP) :: a1, a2 +a1 = 2.0_DFP**(1.0_DFP - 2.0_DFP * lambda) * pi * GAMMA(n + 2.0_DFP * lambda) +a2 = GAMMA(lambda)**2 * (n + lambda) * Factorial(n) +ans = a1 / a2 +END PROCEDURE UltrasphericalNormSqr + +!---------------------------------------------------------------------------- +! UltrasphericalNormSqrRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalNormSqrRatio +REAL(DFP) :: a1, a2 +a1 = (n + lambda) * (n + 2.0_DFP * lambda) +a2 = (n + 1.0_DFP) * (n + lambda + 1.0_DFP) +ans = a1 / a2 +END PROCEDURE UltrasphericalNormSqrRatio + +!---------------------------------------------------------------------------- +! UltrasphericalNormSqr2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalNormSqr2 +REAL(DFP) :: rn, s +INTEGER(I4B) :: ii +!! +ans(0) = UltrasphericalNormSQR(n=0_I4B, lambda=lambda) +!! +IF (n .EQ. 0) RETURN +!! +s = UltrasphericalNormSQRRatio(n=0_I4B, lambda=lambda) +ans(1) = ans(0) * s +!! +DO ii = 1, n - 1 + rn = REAL(ii, KIND=DFP) + s = (rn + lambda) * (rn + 2.0_DFP * lambda) / (rn + 1.0_DFP) & + & / (rn + lambda + 1.0_DFP) + ans(ii + 1) = s * ans(ii) +END DO +END PROCEDURE UltrasphericalNormSqr2 + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalJacobiMatrix +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=alpha, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE UltrasphericalJacobiMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGaussQuadrature +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiGaussQuadrature(n=n, alpha=alpha, beta=alpha, pt=pt, wt=wt) +END PROCEDURE UltrasphericalGaussQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiRadauMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalJacobiRadauMatrix +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=alpha, beta=alpha, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE UltrasphericalJacobiRadauMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussRadauQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGaussRadauQuadrature +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiGaussRadauQuadrature(a=a, n=n, alpha=alpha, beta=alpha, & + & pt=pt, wt=wt) +END PROCEDURE UltrasphericalGaussRadauQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiLobattoMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalJacobiLobattoMatrix +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiJacobiLobattoMatrix(n=n, alpha=alpha, beta=alpha, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE UltrasphericalJacobiLobattoMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGaussLobattoQuadrature +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiGaussLobattoQuadrature(n=n, alpha=alpha, beta=alpha, & + & pt=pt, wt=wt) +END PROCEDURE UltrasphericalGaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalZeros +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +ans = JacobiZeros(alpha=alpha, beta=alpha, n=n) +END PROCEDURE UltrasphericalZeros + +!---------------------------------------------------------------------------- +! UltrasphericalQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalQuadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP +REAL(DFP), ALLOCATABLE :: p(:), w(:) +LOGICAL(LGT) :: inside +!! +IF (PRESENT(onlyInside)) THEN + inside = onlyInside +ELSE + inside = .FALSE. +END IF +!! +SELECT CASE (QuadType) +CASE (Gauss) + !! + order = n + CALL UltrasphericalGaussQuadrature(n=order, lambda=lambda, pt=pt, wt=wt) + !! +CASE (GaussRadau, GaussRadauLeft) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL UltrasphericalGaussRadauQuadrature(a=left, lambda=lambda, & + & n=order, pt=p, wt=w) + pt = p(2:); wt = w(2:) + DEALLOCATE (p, w) + ELSE + order = n - 1 + CALL UltrasphericalGaussRadauQuadrature(a=left, lambda=lambda, & + & n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussRadauRight) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL UltrasphericalGaussRadauQuadrature(a=right, lambda=lambda, & + & n=order, pt=p, wt=w) + pt = p(1:n); wt = w(1:n) + ELSE + order = n - 1 + CALL UltrasphericalGaussRadauQuadrature(a=right, lambda=lambda, & + & n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussLobatto) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 2), w(n + 2)) + CALL UltrasphericalGaussLobattoQuadrature(n=order, lambda=lambda, & + & pt=p, wt=w) + pt = p(2:n + 1); wt = w(2:n + 1) + ELSE + order = n - 2 + CALL UltrasphericalGaussLobattoQuadrature(n=order, lambda=lambda, & + & pt=pt, wt=wt) + END IF +END SELECT +END PROCEDURE UltrasphericalQuadrature + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEval1 +INTEGER(I4B) :: ii +REAL(DFP) :: c1, c2, c3, r_ii, ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = 2.0_DFP * lambda * x +IF (n .EQ. 1) RETURN +!! +DO ii = 1, n - 1 + !! + r_ii = REAL(ii, kind=DFP) + c1 = r_ii + 1.0_DFP + c2 = 2.0_DFP * (r_ii + lambda) + c3 = -(2.0_DFP * lambda + r_ii - 1.0_DFP) + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE UltrasphericalEval1 + +!---------------------------------------------------------------------------- +! UltrasphericalEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEval2 +INTEGER(I4B) :: ii +REAL(DFP) :: c1, c2, c3, r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) RETURN +!! +ans = 2.0_DFP * lambda * x +!! +IF (n .EQ. 1) RETURN +!! +DO ii = 1, n - 1 + !! + r_ii = REAL(ii, kind=DFP) + c1 = r_ii + 1.0_DFP + c2 = 2.0_DFP * (r_ii + lambda) + c3 = -(2.0_DFP * lambda + r_ii - 1.0_DFP) + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE UltrasphericalEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalAll1 +INTEGER(I4B) :: a +CALL UltrasphericalEvalAll1_(n=n, lambda=lambda, x=x, ans=ans, tsize=a) +END PROCEDURE UltrasphericalEvalAll1 + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalAll1_ +INTEGER(I4B) :: ii +REAL(DFP) :: c1, c2, c3, r_ii + +tsize = 0 +IF (n < 0) RETURN + +tsize = 1 +ans(1) = 1.0_DFP +IF (n .EQ. 0) RETURN + +tsize = n + 1 +ans(2) = 2.0_DFP * lambda * x + +DO ii = 2, n + r_ii = REAL(ii, kind=DFP) + c1 = 1.0_DFP / r_ii + c2 = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * c1 * x + c3 = -(2.0_DFP * lambda + r_ii - 2.0_DFP) * c1 + ans(ii + 1) = c2 * ans(ii) + c3 * ans(ii - 1) +END DO + +END PROCEDURE UltrasphericalEvalAll1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalAll2 +INTEGER(I4B) :: a, b +CALL UltrasphericalEvalAll2_(n=n, lambda=lambda, x=x, ans=ans, nrow=a, ncol=b) +END PROCEDURE UltrasphericalEvalAll2 + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalAll2_ +INTEGER(I4B) :: ii, jj +REAL(DFP) :: c1, c2, c3, r_ii + +nrow = 0; ncol = 0 +IF (n < 0) RETURN + +! FIXME: What is this? +ans = 0.0_DFP + +nrow = SIZE(x) +ncol = n + 1 +ans(1:nrow, 1) = 1.0_DFP + +IF (n .EQ. 0) RETURN + +DO CONCURRENT(jj=1:nrow) + + ans(jj, 2) = 2.0_DFP * lambda * x(jj) + + DO ii = 2, n + + r_ii = REAL(ii, kind=DFP) + c1 = 1.0_DFP / r_ii + c2 = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * c1 * x(jj) + c3 = -(2.0_DFP * lambda + r_ii - 2.0_DFP) * c1 + + ans(1:jj, ii + 1) = c2 * ans(1:jj, ii) + c3 * ans(1:jj, ii - 1) + + END DO +END DO + +END PROCEDURE UltrasphericalEvalAll2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalAll1 +INTEGER(I4B) :: tsize +CALL UltrasphericalGradientEvalAll1_(n=n, lambda=lambda, x=x, ans=ans, & + tsize=tsize) +END PROCEDURE UltrasphericalGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL UltrasphericalGradientEvalAll2_(n=n, lambda=lambda, x=x, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE UltrasphericalGradientEvalAll2 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalAll1_ +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:n + 1) + +tsize = 0 +IF (n < 0) RETURN + +tsize = n + 1 +p(1) = 1.0_DFP +ans(1) = 0.0_DFP + +IF (n < 1) RETURN + +p(2) = 2.0_DFP * lambda * x +ans(2) = 2.0_DFP * lambda + +DO ii = 2, n + + r_ii = REAL(ii, KIND=DFP) + + p(ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(ii) & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(ii - 1)) & + & / r_ii + + ans(ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(ii) + ans(ii - 1) + +END DO + +END PROCEDURE UltrasphericalGradientEvalAll1_ + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalAll2_ +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:SIZE(x), 1:n + 1) + +nrow = 0; ncol = 0 +IF (n < 0) RETURN + +nrow = SIZE(x) +ncol = n + 1 + +p(1:nrow, 1) = 1.0_DFP +ans(1:nrow, 1) = 0.0_DFP + +IF (n < 1) RETURN + +p(1:nrow, 2) = 2.0_DFP * lambda * x +ans(1:nrow, 2) = 2.0_DFP * lambda + +DO ii = 2, n + + r_ii = REAL(ii, KIND=DFP) + +p(1:nrow, ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(1:nrow, ii) & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(1:nrow, ii - 1)) & + & / r_ii + + ans(1:nrow, ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(1:nrow, ii) & + & + ans(1:nrow, ii - 1) + +END DO + +END PROCEDURE UltrasphericalGradientEvalAll2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEval1 + +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p, p_1, p_2 +REAL(DFP) :: ans_1, ans_2 + +ans = 0.0_DFP + +IF (n < 0) THEN + RETURN +END IF + +p = 1.0_DFP +p_2 = p +ans_2 = ans + +IF (n < 1) THEN + RETURN +END IF + +p = 2.0_DFP * lambda * x +ans = 2.0_DFP * lambda + +DO ii = 2, n + + r_ii = REAL(ii, KIND=DFP) + + p_1 = p + + p = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p_2) & + & / r_ii + + p_2 = p_1 + + ans_1 = ans + ans = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + +END DO + +END PROCEDURE UltrasphericalGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +p = 2.0_DFP * lambda * x +ans = 2.0_DFP * lambda +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + p = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p_2) & + & / r_ii + !! + p_2 = p_1 + !! + ans_1 = ans + ans = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE UltrasphericalGradientEval2 + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C + +! IF (n .LT. 0) RETURN +! IF (lambda .LE. -0.5_DFP) RETURN +! IF (lambda .EQ. 0.0_DFP) RETURN + +CALL GetUltrasphericalRecurrenceCoeff2(n=n + 2, lambda=lambda, A=A, B=B, C=C) + +b1 = 0.0_DFP +b2 = 0.0_DFP + +DO j = n, 0, -1 + t = (A(j) * x) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO + +ans = b1 + +END PROCEDURE UltrasphericalEvalSum1 + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C + +! IF (n .LT. 0) RETURN +! IF (lambda .LE. -0.5_DFP) RETURN +! IF (lambda .EQ. 0.0_DFP) RETURN + +CALL GetUltrasphericalRecurrenceCoeff2(n=n + 2, lambda=lambda, A=A, B=B, C=C) + +b1 = 0.0_DFP +b2 = 0.0_DFP + +DO j = n, 0, -1 + t = (A(j) * x) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO + +ans = b1 + +END PROCEDURE UltrasphericalEvalSum2 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum1 +REAL(DFP) :: t, b1, b2 +REAL(DFP) :: A1, A2 +INTEGER(I4B) :: i +REAL(DFP) :: j +REAL(DFP) :: c + +! IF (n .LT. 0) RETURN +! IF (lambda .LE. -0.5_DFP) RETURN +! IF (lambda .EQ. 0.0_DFP) RETURN + +c = 2 * lambda; +b1 = 0 +b2 = 0 + +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + 1 + lambda) * x / (j + 1) + A2 = -(j + 2 * lambda + 2) / (j + 2) + t = A1 * b1 + A2 * b2 + coeff(i + 1) + b2 = b1 + b1 = t +END DO +ans = C * b1 +END PROCEDURE UltrasphericalGradientEvalSum1 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum2 +REAL(DFP) :: A2 +REAL(DFP), DIMENSION(SIZE(x)) :: A1, t, b1, b2 +INTEGER(I4B) :: i +REAL(DFP) :: j +REAL(DFP) :: c + +! IF (n .LT. 0) RETURN +! IF (lambda .LE. -0.5_DFP) RETURN +! IF (lambda .EQ. 0.0_DFP) RETURN + +c = 2 * lambda; +b1 = 0 +b2 = 0 + +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + 1 + lambda) * x / (j + 1) + A2 = -(j + 2 * lambda + 2) / (j + 2) + t = A1 * b1 + A2 * b2 + coeff(i + 1) + b2 = b1 + b1 = t +END DO +ans = C * b1 +END PROCEDURE UltrasphericalGradientEvalSum2 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum3 +REAL(DFP) :: t, b1, b2, s +REAL(DFP) :: A1, A2 +INTEGER(I4B) :: i +REAL(DFP) :: j + +! IF (n .LT. 0) RETURN +! IF (lambda .LE. -0.5_DFP) RETURN +! IF (lambda .EQ. 0.0_DFP) RETURN + +s = 1.0_DFP +DO i = 1, k + s = 2 * s * (lambda + i - 1); +END DO + +b1 = 0 +b2 = 0 + +DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + k + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2 * k) / (j + 2); + t = A1 * b1 + A2 * b2 + coeff(i + k); + b2 = b1; + b1 = t; +END DO +ans = s * b1 +END PROCEDURE UltrasphericalGradientEvalSum3 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum4 +REAL(DFP) :: A2, s +REAL(DFP), DIMENSION(SIZE(x)) :: A1, b1, b2, t +INTEGER(I4B) :: i +REAL(DFP) :: j + +! IF (n .LT. 0) RETURN +! IF (lambda .LE. -0.5_DFP) RETURN +! IF (lambda .EQ. 0.0_DFP) RETURN + +s = 1.0_DFP +DO i = 1, k + s = 2 * s * (lambda + i - 1); +END DO + +b1 = 0 +b2 = 0 + +DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + k + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2 * k) / (j + 2); + t = A1 * b1 + A2 * b2 + coeff(i + k); + b2 = b1; + b1 = t; +END DO +ans = s * b1 +END PROCEDURE UltrasphericalGradientEvalSum4 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform1 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +REAL(DFP) :: rn +!! +nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) +END IF +!! +PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / nrmsqr(jj) +END DO +!! +END PROCEDURE UltrasphericalTransform1 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform2 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +REAL(DFP) :: rn +!! +nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) +END IF +!! +PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / nrmsqr(jj) + END DO +END DO +!! +END PROCEDURE UltrasphericalTransform2 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii + +CALL UltrasphericalQuadrature(n=n + 1, lambda=lambda, pt=pt, wt=wt,& + & quadType=quadType) + +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO + +ans = UltrasphericalTransform(n=n, lambda=lambda, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) + +END PROCEDURE UltrasphericalTransform3 + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalInvTransform1 +ans = UltrasphericalEvalSum(n=n, lambda=lambda, coeff=coeff, & + & x=x) +END PROCEDURE UltrasphericalInvTransform1 + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalInvTransform2 +ans = UltrasphericalEvalSum(n=n, lambda=lambda, coeff=coeff, & + & x=x) +END PROCEDURE UltrasphericalInvTransform2 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientCoeff1 +REAL(DFP) :: a, b, c +INTEGER(I4B) :: ii +REAL(DFP) :: jj +!! +ans(n) = 0.0_DFP +IF (n .EQ. 0) RETURN +!! +ans(n - 1) = 2.0 * (n + lambda - 1.0_DFP) * coeff(n) +!! +DO ii = n - 1, 1, -1 + jj = REAL(ii, KIND=DFP) + a = jj + lambda - 1.0_DFP + b = jj + lambda + 1.0_DFP + c = a / b + ans(ii - 1) = 2.0_DFP * a * coeff(ii) + c * ans(ii + 1) +END DO +!! +END PROCEDURE UltrasphericalGradientCoeff1 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalDMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL UltrasphericalDMatrixGL2(n=n, lambda=lambda, x=x,& + & D=ans) +CASE (Gauss) + CALL UltrasphericalDMatrixG2(n=n, lambda=lambda, x=x, & + & D=ans) +END SELECT +END PROCEDURE UltrasphericalDMatrix1 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixGL(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = INT(n / 2) + rn = REAL(n, KIND=DFP) + !! + J = UltrasphericalEval(n=n, lambda=lambda, x=x) + !! + !! first col + !! + D(0, 0) = (lambda - 0.5_DFP - rn * (rn + 2.0 * lambda)) / & + & (2.0 * lambda + 3.0) + DO ii = 1, n + D(ii, 0) = (lambda + 0.5) * J(ii) / (x(ii) + 1.0) / J(0) + END DO + !! + !! last col + !! + DO ii = 0, n - 1 + D(ii, n) = (lambda + 0.5) * J(ii) / (x(ii) - 1.0) / J(n) + END DO + D(n, n) = -D(0, 0) + !! + !! internal column + !! + DO jj = 1, n - 1 + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = (lambda - 0.5) * x(ii) / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO + !! +END SUBROUTINE UltrasphericalDMatrixGL + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixGL2(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = INT(n / 2) + rn = REAL(n, KIND=DFP) + !! + J = UltrasphericalEval(n=n, lambda=lambda, x=x) + D = 0.0_DFP + !! + !! first col + !! + !D(0, 0) = (lambda - 0.5_DFP - rn * (rn + 2.0 * lambda)) / & + ! & (2.0 * lambda + 3.0) + DO ii = 1, nb2 + D(ii, 0) = (lambda + 0.5) * J(ii) / (x(ii) + 1.0) / J(0) + END DO + !! + !! last col + !! + DO ii = 0, nb2 + D(ii, n) = (lambda + 0.5) * J(ii) / (x(ii) - 1.0) / J(n) + END DO + !! + !! internal column + !! + DO jj = 1, n - 1 + DO ii = 0, nb2 + IF (ii .NE. jj) & !THEN + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + ! ELSE + ! D(ii, ii) = (lambda - 0.5) * x(ii) / (1.0 - x(ii)**2) + !END IF + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE UltrasphericalDMatrixGL2 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixG(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = UltrasphericalGradientEval(n=n + 1, lambda=lambda, x=x) + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = (lambda + 0.5_DFP) * x(ii) / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO +!! +END SUBROUTINE UltrasphericalDMatrixG + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixG2(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj, nb2 + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + nb2 = INT(n / 2) + !! + J = UltrasphericalGradientEval(n=n + 1, lambda=lambda, x=x) + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE UltrasphericalDMatrixG2 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatEvenOdd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalDMatEvenOdd1 +INTEGER(I4B) :: ii, jj, n1, n2 + !! +IF (MOD(N, 2) .EQ. 0) THEN + !! even + !! + n1 = INT(n / 2) - 1 + !! + DO jj = 0, n1 + DO ii = 0, n1 + e(ii, jj) = D(ii, jj) + D(ii, n - jj) + o(ii, jj) = D(ii, jj) - D(ii, n - jj) + END DO + END DO + !! + n2 = n1 + 1 + e(1:n1, n2) = D(1:n1, n2) + o(n2, 1:n1) = D(n2, 1:n1) - D(n2, 1:n1) + !! +ELSE + !! odd + n2 = (n - 1) / 2 + n1 = n2 + !! + DO jj = 0, n2 + DO ii = 0, n1 + e(ii, jj) = D(ii, jj) + D(ii, n - jj) + o(ii, jj) = D(ii, jj) - D(ii, n - jj) + END DO + END DO + !! +END IF +END PROCEDURE UltrasphericalDMatEvenOdd1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..9092e9e12 --- /dev/null +++ b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 @@ -0,0 +1,381 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(UnscaledLobattoPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! UnscaledLobattoLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoLeadingCoeff +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP +CASE (1) + ans = -0.5_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + m = LegendreLeadingCoeff(n=n) + ans = m * avar +END SELECT +END PROCEDURE UnscaledLobattoLeadingCoeff + +!---------------------------------------------------------------------------- +! UnscaledLobattoNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoNormSqr +REAL(DFP) :: m, a1, a2, a3 +SELECT CASE (n) +CASE (0, 1) + ans = 2.0_DFP / 3.0_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + a1 = (2.0_DFP * m + 1) + a2 = (2.0_DFP * m + 3) + a3 = (2.0_DFP * m + 5) + ans = 4.0_DFP / a1 / a2 / a3 +END SELECT +END PROCEDURE UnscaledLobattoNormSqr + +!---------------------------------------------------------------------------- +! UnscaledLobattoZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoZeros +SELECT CASE (n) +CASE (1) + ans(1) = 1.0_DFP +CASE (2) + ans(1) = -1.0_DFP + ans(2) = 1.0_DFP +CASE DEFAULT + ans(1) = -1.0_DFP + ans(n) = 1.0_DFP + ans(2:n - 1) = JacobiZeros(alpha=1.0_DFP, beta=1.0_DFP, n=n - 2_I4B) +END SELECT +END PROCEDURE UnscaledLobattoZeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEval1 +REAL(DFP) :: avar, m +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE UnscaledLobattoEval1 + +!---------------------------------------------------------------------------- +! UnscaledLobattoEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEval2 +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE UnscaledLobattoEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEvalAll1 +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans(2 + ii) = avar * (p(ii + 2) - p(ii)) + END DO +END SELECT +END PROCEDURE UnscaledLobattoEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEvalAll2 +REAL(DFP) :: avar, m +REAL(DFP) :: p(SIZE(x), n + 1) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) + END DO +END SELECT +END PROCEDURE UnscaledLobattoEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoMonomialExpansionAll +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1, n + 1) +INTEGER(I4B) :: ii +!! +ans = 0.0_DFP +!! +SELECT CASE (n) +CASE (0) + ans(1, 1) = 0.5_DFP +CASE (1) + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP +CASE DEFAULT + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP + !! + p = LegendreMonomialExpansionAll(n=n) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans(:, ii + 2) = avar * (p(:, ii + 2) - p(:, ii)) + END DO + !! +END SELECT +END PROCEDURE UnscaledLobattoMonomialExpansionAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoMonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = UnscaledLobattoMonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE UnscaledLobattoMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 +REAL(DFP) :: p(n) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = -0.5_DFP +CASE (1) + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP +CASE DEFAULT + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + ans(ii + 2) = p(ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE UnscaledLobattoGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 +REAL(DFP) :: p(SIZE(x), n) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(:, 1) = -0.5_DFP +CASE (1) + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP +CASE DEFAULT + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + ans(:, ii + 2) = p(:, ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE UnscaledLobattoGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEval1 + !! +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + ans = LegendreEval(n=n - 1_I4B, x=x) +END SELECT +END PROCEDURE UnscaledLobattoGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEval2 +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + ans = LegendreEval(n=n - 1_I4B, x=x) +END SELECT +END PROCEDURE UnscaledLobattoGradientEval2 + +!---------------------------------------------------------------------------- +! UnscaledLobattoMassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoMassMatrix +INTEGER(I4B) :: ii +REAL(DFP) :: m +!! +ans = 0.0_DFP +!! +DO ii = 1, n + 1 + ans(ii, ii) = UnscaledLobattoNormSQR(n=ii - 1_I4B) +END DO +!! +IF (n .EQ. 0_I4B) RETURN +!! +ans(1, 2) = 1.0_DFP / 3.0_DFP +ans(2, 1) = ans(1, 2) +!! +IF (n .EQ. 1_I4B) RETURN +!! +ans(1, 3) = -1.0_DFP / 3.0_DFP +ans(3, 1) = ans(1, 3) +ans(2, 3) = ans(1, 3) +ans(3, 2) = ans(2, 3) +!! +IF (n .EQ. 2_I4B) RETURN +!! +ans(1, 4) = 1.0_DFP / 15.0_DFP +ans(4, 1) = ans(1, 4) +ans(2, 4) = -ans(1, 4) +ans(4, 2) = ans(2, 4) +!! +IF (n .EQ. 3_I4B) RETURN +!! +DO ii = 3, n + 1 + !! + m = REAL(ii - 3, DFP) + !! + IF (ii + 2 .LE. n + 1) THEN + ans(ii, ii + 2) = -2.0_DFP / (2.0_DFP * m + 3.0_DFP) / & + & (2.0_DFP * m + 5.0_DFP) / (2.0_DFP * m + 7.0_DFP) + !! + ans(ii + 2, ii) = ans(ii, ii + 2) + END IF + !! +END DO +!! +END PROCEDURE UnscaledLobattoMassMatrix + +!---------------------------------------------------------------------------- +! UnscaledLobattoStiffnessMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoStiffnessMatrix +INTEGER(I4B) :: ii +REAL(DFP) :: m +!! +ans = 0.0_DFP +!! +ans(1, 1) = 0.5_DFP +!! +IF (n .EQ. 0_I4B) RETURN +!! +ans(2, 2) = 0.5_DFP +ans(1, 2) = -0.5_DFP +ans(2, 1) = ans(1, 2) +!! +DO ii = 3, n + 1 + m = REAL(ii - 3, DFP) + ans(ii, ii) = 2.0_DFP / (2.0_DFP * m + 3.0_DFP) +END DO +END PROCEDURE UnscaledLobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..353cf8485 --- /dev/null +++ b/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 @@ -0,0 +1,376 @@ + +! 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/Polynomial/src/include/Quadrangle/edge_12.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_12.inc new file mode 100644 index 000000000..e3f826e6b --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_12.inc @@ -0,0 +1,10 @@ + + ! nodes on edge 12 + jj = ll + 1 + IF (cnt .LT. N) THEN + DO ii = 2 + ll, p - ll + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc new file mode 100644 index 000000000..9f83df9f4 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_14.inc @@ -0,0 +1,9 @@ + + ii = ll + 1 + IF (cnt .LT. N) THEN + DO jj = 2 + ll, q - ll, 1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc new file mode 100644 index 000000000..254a740be --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_21.inc @@ -0,0 +1,9 @@ + ! nodes on edge 21 + jj = ll + 1 + IF (cnt .LT. N) THEN + DO ii = p - ll, 2 + ll, -1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc new file mode 100644 index 000000000..8c06958ac --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_23.inc @@ -0,0 +1,10 @@ + + ! nodes on edge 23 + ii = p + 1 - ll + IF (cnt .LT. N) THEN + DO jj = 2 + ll, q - ll + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc new file mode 100644 index 000000000..eecb89c4d --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_32.inc @@ -0,0 +1,10 @@ + + ! nodes on edge 32 + ii = p + 1 - ll + IF (cnt .LT. N) THEN + DO jj = q - ll, 2 + ll, -1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc new file mode 100644 index 000000000..b926206d8 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_34.inc @@ -0,0 +1,10 @@ + + ! nodes on edge 34 + jj = q + 1 - ll + IF (cnt .LT. N) THEN + DO ii = p - ll, 2 + ll, -1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc new file mode 100644 index 000000000..e30df2070 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_41.inc @@ -0,0 +1,10 @@ + + ! nodes on edge 41 + ii = ll + 1 + IF (cnt .LT. N) THEN + DO jj = q - ll, 2 + ll, -1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc b/src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc new file mode 100644 index 000000000..89adc3ea4 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/edge_43.inc @@ -0,0 +1,10 @@ + + ! nodes on edge 43 + jj = q + 1 - ll + IF (cnt .LT. N) THEN + DO ii = 2 + ll, p - ll, +1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc new file mode 100644 index 000000000..227ecf65f --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/vertex_1.inc @@ -0,0 +1,8 @@ + ! v1 + ii = 1 + ll + jj = 1 + ll + IF (cnt .LT. N) THEN + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc new file mode 100644 index 000000000..28160d0c3 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/vertex_2.inc @@ -0,0 +1,8 @@ + ! v2 + ii = p + 1 - ll + jj = 1 + ll + IF (cnt .LT. N) THEN + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc new file mode 100644 index 000000000..7fcbe3930 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/vertex_3.inc @@ -0,0 +1,8 @@ + ! v3 + ii = p + 1 - ll + jj = q + 1 - ll + IF (cnt .LT. N) THEN + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END IF diff --git a/src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc b/src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc new file mode 100644 index 000000000..89b7e95ce --- /dev/null +++ b/src/submodules/Polynomial/src/include/Quadrangle/vertex_4.inc @@ -0,0 +1,8 @@ + ! v4 + ii = 1 + ll + jj = q + 1 - ll + IF (cnt .LT. N) THEN + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END IF diff --git a/src/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt new file mode 100644 index 000000000..69ce7a34f --- /dev/null +++ b/src/submodules/QuadraturePoint/CMakeLists.txt @@ -0,0 +1,25 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/QuadraturePoint_Method@IOMethods.F90 + ${src_path}/QuadraturePoint_Method@GetMethods.F90 + ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90 +) + diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 new file mode 100755 index 000000000..9387b1aab --- /dev/null +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -0,0 +1,964 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: Constructor methods for [[QuadraturePoint_]] + +SUBMODULE(QuadraturePoint_Method) ConstructorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! QuadraturePointIDToName +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePointIDToName +ans = BaseInterpolation_ToString(name) +END PROCEDURE QuadraturePointIDToName + +!---------------------------------------------------------------------------- +! QuadraturePointNameToID +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePointNameToID +ans = BaseInterpolation_ToInteger(name) +END PROCEDURE QuadraturePointNameToID + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate1 +obj%points = points +obj%tXi = SIZE(points, 1) - 1 +! No of row minus one +END PROCEDURE quad_initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate2 +obj%tXi = tXi +CALL Reallocate(obj%points, tXi + 1, tpoints) +END PROCEDURE quad_initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate3 +INTEGER(I4B) :: quadType +quadType = QuadraturePointNameToId(quadratureType) +CALL Initiate( & + & obj=obj, & + & refElem=refElem, & + & order=order, & + & quadratureType=quadType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END PROCEDURE quad_initiate3 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate4 +INTEGER(I4B) :: quadType +quadType = QuadraturePointNameToId(quadratureType) +CALL Initiate( & + & obj=obj, & + & refElem=refElem, & + & nips=nips, & + & quadratureType=quadType, & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) +END PROCEDURE quad_initiate4 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate5 + +SELECT TYPE (refelem) +TYPE IS (ReferenceLine_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & order=order, & + & quadType=quadratureType, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + +TYPE IS (ReferenceTriangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & order=order, & + & quadType=quadratureType, & + & refTriangle=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceQuadrangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & order=order, & + & quadType=quadratureType, & + & refQuadrangle=refelem%domainName, & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + +TYPE IS (ReferenceTetrahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & order=order, & + & quadType=quadratureType, & + & refTetrahedron=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceHexahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & order=order, & + & quadType=quadratureType, & + & refHexahedron=refelem%domainName, & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + +TYPE IS (ReferencePrism_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & order=order, & + & quadType=quadratureType, & + & refPrism=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferencePyramid_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & order=order, & + & quadType=quadratureType, & + & refPyramid=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceElement_) + + IF (isLine(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & order=order, & + & quadType=quadratureType, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + RETURN + END IF + + IF (isTriangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & order=order, & + & quadType=quadratureType, & + & refTriangle=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isQuadrangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & order=order, & + & quadType=quadratureType, & + & refQuadrangle=refelem%domainName, & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + RETURN + END IF + + IF (isTetrahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & order=order, & + & quadType=quadratureType, & + & refTetrahedron=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isHexahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & order=order, & + & quadType=quadratureType, & + & refHexahedron=refelem%domainName, & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + RETURN + END IF + + IF (isPrism(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & order=order, & + & quadType=quadratureType, & + & refPrism=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isPyramid(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & order=order, & + & quadType=quadratureType, & + & refPyramid=refelem%domainName, & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + +CLASS DEFAULT + CALL ErrorMsg(& + & msg="[NO CASE FOUND] for the type of refelem", & + & file=__FILE__, & + & routine="quad_initiate5()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +END PROCEDURE quad_initiate5 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate6 + +SELECT TYPE (refelem) +TYPE IS (ReferenceLine_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & nips=nips, & + & quadType=quadratureType, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + +TYPE IS (ReferenceTriangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & nips=nips, & + & quadType=quadratureType, & + & refTriangle="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceQuadrangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & nips=nips, & + & quadType=quadratureType, & + & refQuadrangle="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + +TYPE IS (ReferenceTetrahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & nips=nips, & + & quadType=quadratureType, & + & refTetrahedron="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceHexahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & nips=nips, & + & quadType=quadratureType, & + & refHexahedron="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + +TYPE IS (ReferencePrism_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & nips=nips, & + & quadType=quadratureType, & + & refPrism="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferencePyramid_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & nips=nips, & + & quadType=quadratureType, & + & refPyramid="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceElement_) + + IF (isLine(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & nips=nips, & + & quadType=quadratureType, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + RETURN + END IF + + IF (isTriangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & nips=nips, & + & quadType=quadratureType, & + & refTriangle="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isQuadrangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & nips=nips, & + & quadType=quadratureType, & + & refQuadrangle="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + RETURN + END IF + + IF (isTetrahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & nips=nips, & + & quadType=quadratureType, & + & refTetrahedron="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isHexahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & nips=nips, & + & quadType=quadratureType, & + & refHexahedron="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha, & + & beta=beta, & + & lambda=lambda) & + & ) + RETURN + END IF + + IF (isPrism(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & nips=nips, & + & quadType=quadratureType, & + & refPrism="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isPyramid(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & nips=nips, & + & quadType=quadratureType, & + & refPyramid="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + +CLASS DEFAULT + CALL ErrorMsg(& + & msg="No case found", & + & file=__FILE__, & + & routine="quad_initiate6()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +END PROCEDURE quad_initiate6 + +!---------------------------------------------------------------------------- +! QuadraturePoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate7 + +SELECT TYPE (refelem) +TYPE IS (ReferenceLine_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & order=p, & + & quadType=quadratureType1, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) & + & ) + +TYPE IS (ReferenceTriangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & order=p, & + & quadType=quadratureType1, & + & refTriangle="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceQuadrangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & p=p, & + & q=q, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & refQuadrangle="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2 & + & )) + +TYPE IS (ReferenceTetrahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & order=p, & + & quadType=quadratureType1, & + & refTetrahedron="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceHexahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & p=p, & + & q=q, & + & r=r, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & quadType3=quadratureType3, & + & refHexahedron="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2, & + & alpha3=alpha3, & + & beta3=beta3, & + & lambda3=lambda3 & + & )) + +TYPE IS (ReferencePrism_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & order=p, & + & quadType=quadratureType1, & + & refPrism="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferencePyramid_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & order=p, & + & quadType=quadratureType1, & + & refPyramid="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceElement_) + + IF (isLine(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & order=p, & + & quadType=quadratureType1, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) & + & ) + RETURN + END IF + + IF (isTriangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & order=p, & + & quadType=quadratureType1, & + & refTriangle="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isQuadrangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & p=p, & + & q=q, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & refQuadrangle="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2 & + & )) + RETURN + END IF + + IF (isTetrahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & order=p, & + & quadType=quadratureType1, & + & refTetrahedron="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isHexahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & p=p, & + & q=q, & + & r=r, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & quadType3=quadratureType3, & + & refHexahedron="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2, & + & alpha3=alpha3, & + & beta3=beta3, & + & lambda3=lambda3 & + & )) + RETURN + END IF + + IF (isPrism(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & order=p, & + & quadType=quadratureType1, & + & refPrism="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isPyramid(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & order=p, & + & quadType=quadratureType1, & + & refPyramid="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + +CLASS DEFAULT + CALL ErrorMsg(& + & msg="No case found", & + & file=__FILE__, & + & routine="quad_initiate7()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +END PROCEDURE quad_initiate7 + +!---------------------------------------------------------------------------- +! QuadraturePoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_initiate8 + +SELECT TYPE (refelem) +TYPE IS (ReferenceLine_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & nips=nipsx, & + & quadType=quadratureType1, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) & + & ) + +TYPE IS (ReferenceTriangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refTriangle="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceQuadrangle_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & nipsx=nipsx, & + & nipsy=nipsy, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & refQuadrangle="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2 & + & )) + +TYPE IS (ReferenceTetrahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refTetrahedron="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceHexahedron_) + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & nipsx=nipsx, & + & nipsy=nipsy, & + & nipsz=nipsz, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & quadType3=quadratureType3, & + & refHexahedron="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2, & + & alpha3=alpha3, & + & beta3=beta3, & + & lambda3=lambda3 & + & )) + +TYPE IS (ReferencePrism_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refPrism="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferencePyramid_) + + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refPyramid="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + +TYPE IS (ReferenceElement_) + + IF (isLine(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Line( & + & nips=nipsx, & + & quadType=quadratureType1, & + & layout="INCREASING", & + & xij=LocalNodeCoord(refElem), & + & alpha=alpha1, & + & beta=beta1, & + & lambda=lambda1) & + & ) + RETURN + END IF + + IF (isTriangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Triangle( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refTriangle="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isQuadrangle(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Quadrangle( & + & nipsx=nipsx, & + & nipsy=nipsy, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & refQuadrangle="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2 & + & )) + RETURN + END IF + + IF (isTetrahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Tetrahedron( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refTetrahedron="UNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isHexahedron(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Hexahedron( & + & nipsx=nipsx, & + & nipsy=nipsy, & + & nipsz=nipsz, & + & quadType1=quadratureType1, & + & quadType2=quadratureType2, & + & quadType3=quadratureType3, & + & refHexahedron="BIUNIT", & + & xij=LocalNodeCoord(refElem), & + & alpha1=alpha1, & + & beta1=beta1, & + & lambda1=lambda1, & + & alpha2=alpha2, & + & beta2=beta2, & + & lambda2=lambda2, & + & alpha3=alpha3, & + & beta3=beta3, & + & lambda3=lambda3 & + & )) + RETURN + END IF + + IF (isPrism(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Prism( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refPrism="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + + IF (isPyramid(refelem%name)) THEN + CALL Initiate( & + & obj=obj, & + & points=QuadraturePoint_Pyramid( & + & nips=nipsx, & + & quadType=quadratureType1, & + & refPyramid="BIUNIT", & + & xij=LocalNodeCoord(refElem)) & + & ) + RETURN + END IF + +CLASS DEFAULT + CALL ErrorMsg(& + & msg="No case found", & + & file=__FILE__, & + & routine="quad_initiate7()", & + & line=__LINE__, & + & unitno=stderr) + RETURN +END SELECT + +END PROCEDURE quad_initiate8 + +!---------------------------------------------------------------------------- +! QuadraturePoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Constructor1 +obj%points = points +obj%tXi = SIZE(points, 1) - 1 +END PROCEDURE quad_Constructor1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Constructor_1 +ALLOCATE (obj) +obj%points = points +obj%tXi = SIZE(points, 1) - 1 +END PROCEDURE quad_Constructor_1 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Deallocate +IF (ALLOCATED(obj%points)) DEALLOCATE (obj%points) +obj%tXi = -1 +END PROCEDURE quad_Deallocate + +END SUBMODULE ConstructorMethods diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 new file mode 100755 index 000000000..126af77a7 --- /dev/null +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.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 +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: Constructor methods for [[Quadraturepoints_]] + +SUBMODULE(QuadraturePoint_Method) GetMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SIZE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Size +ans = SIZE(obj%points, dims) +END PROCEDURE quad_Size + +!---------------------------------------------------------------------------- +! getTotalQuadraturepoints +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_getTotalQuadraturepoints +ans = SIZE(obj, 2) +END PROCEDURE quad_getTotalQuadraturepoints + +!---------------------------------------------------------------------------- +! getQuadraturepoints +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_GetQuadraturePoints1 +points = 0.0_DFP +points(1:obj%tXi) = obj%points(1:obj%tXi, Num) +weights = obj%points(obj%tXi + 1, Num) +END PROCEDURE quad_GetQuadraturePoints1 + +!---------------------------------------------------------------------------- +! getQuadraturepoints +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_GetQuadraturePoints2 +INTEGER(I4B) :: n +n = SIZE(obj%points, 2) !#column +CALL Reallocate(points, 3, n) +points(1:obj%tXi, 1:n) = obj%points(1:obj%tXi, 1:n) +weights = obj%points(obj%tXi + 1, 1:n) +END PROCEDURE quad_GetQuadraturePoints2 + +!---------------------------------------------------------------------------- +! Outerprod +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Outerprod +REAL(DFP), ALLOCATABLE :: points(:, :) +INTEGER(I4B) :: n1, n2, n +INTEGER(I4B) :: ii, a, b + +n1 = SIZE(obj1, 2) +n2 = SIZE(obj2, 2) +n = n1 * n2 + +CALL Reallocate(points, 3, n) +DO ii = 1, n1 + a = (ii - 1) * n2 + 1 + b = ii * n2 + points(1, a:b) = obj1%points(1, ii) + points(2, a:b) = obj2%points(1, :) + points(3, a:b) = obj1%points(2, ii) * obj2%points(2, :) +END DO + +CALL Initiate(obj=ans, points=points) +IF (ALLOCATED(points)) DEALLOCATE (points) +END PROCEDURE quad_Outerprod + +END SUBMODULE GetMethods diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 new file mode 100644 index 000000000..698838d8d --- /dev/null +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 @@ -0,0 +1,70 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This submodule contains the IO method for [[QuadraturePoint_]] + +SUBMODULE(QuadraturePoint_Method) IOMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Display +CALL Display(msg, unitno=unitno) +IF (.NOT. ALLOCATED(obj%points)) THEN + RETURN +END IF +CALL Display(obj%points, msg="# points :", unitno=unitno) +CALL Display(obj%txi, msg="# txi :", unitno=unitno) +END PROCEDURE quad_Display + +!---------------------------------------------------------------------------- +! MdEncode +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_MdEncode +INTEGER(I4B) :: ii, n, jj +TYPE(String), ALLOCATABLE :: rh(:), ch(:) + +IF (.NOT. ALLOCATED(obj%points)) THEN + ans = "" + RETURN +END IF + +n = SIZE(obj%points, 2) +CALL Reallocate(rh, SIZE(obj, 1)) +CALL Reallocate(ch, SIZE(obj, 2)) + +DO ii = 1, SIZE(rh) - 1 + rh(ii) = "`x"//tostring(ii)//"`" +END DO +rh(obj%txi + 1) = "w" + +DO ii = 1, SIZE(ch) + ch(ii) = "`p"//tostring(ii)//"`" +END DO + +ans = MdEncode(obj%points, rh=rh, ch=ch) + +END PROCEDURE QuadraturePoint_MdEncode + +END SUBMODULE IOMethods diff --git a/src/submodules/Random/CMakeLists.txt b/src/submodules/Random/CMakeLists.txt new file mode 100644 index 000000000..627e36426 --- /dev/null +++ b/src/submodules/Random/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}/Random_Method@Methods.F90 +) diff --git a/src/submodules/Random/src/Random_Method@Methods.F90 b/src/submodules/Random/src/Random_Method@Methods.F90 new file mode 100644 index 000000000..a0b369b08 --- /dev/null +++ b/src/submodules/Random/src/Random_Method@Methods.F90 @@ -0,0 +1,382 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Random_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE initRandom +INTEGER(I4B) :: SeedSize + +CALL RANDOM_SEED(size=SeedSize) +IF (.NOT. ALLOCATED(obj%random_int_seed)) THEN + ALLOCATE (obj%random_int_seed(SeedSize)) +END IF +call RANDOM_SEED(get=obj%random_int_seed) +END PROCEDURE initRandom + +!---------------------------------------------------------------------------- +! getRandom +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getRandom +REAL(DFP) :: val, y +INTEGER(I4B) :: i + +IF (PRESENT(distribution)) THEN + SELECT CASE (TRIM(distribution)) + CASE ("Binomial", "binomial") + val = 0.0d0 + DO i = 1, 20 + CALL RANDOM_NUMBER(y) + val = val + y + END DO + Ans = val - 10.0_DFP + CASE DEFAULT + CALL RANDOM_NUMBER(Ans) + END SELECT +ELSE + CALL RANDOM_NUMBER(Ans) +END IF + +END PROCEDURE getRandom + +!---------------------------------------------------------------------------- +! SaveRandom +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SaveRandom +CALL RANDOM_SEED(put=obj%Random_INT_SEED) +END PROCEDURE SaveRandom + +!---------------------------------------------------------------------------- +! UniformRandom +!---------------------------------------------------------------------------- + +MODULE PROCEDURE uniformRandom +REAL(DFP) :: a, diff, val(2) + +val(1) = From +val(2) = To +diff = abs(From - To) +CALL RANDOM_NUMBER(a) +Ans = a * diff + minval(val) +END PROCEDURE uniformRandom + +!---------------------------------------------------------------------------- +! getRandomInteger +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getRandomInteger +REAL(DFP) :: xr, a, diff, val(2) + +val(1) = From +val(2) = To +diff = abs(dble(from) - dble(to)) + +call random_number(a) +xr = a * diff + minval(val) +Ans = nint(xr) +if (Ans == From - 1) then + Ans = From +end if +if (Ans == To + 1) then + Ans = To +end if +END PROCEDURE getRandomInteger + +!---------------------------------------------------------------------------- +! RandomValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE select_random_int_from_vec +INTEGER(I4B) :: posi +posi = getRandomInteger(obj, From=1, To=size(Val)) +Ans = Val(posi) +END PROCEDURE select_random_int_from_vec + +!---------------------------------------------------------------------------- +! RandomValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE select_random_int_from_array +INTEGER(I4B) :: i1, i2 +i1 = getRandomInteger(obj, From=1, To=SIZE(Val, 1)) +i2 = getRandomInteger(obj, From=1, To=SIZE(Val, 2)) +Ans = Val(i1, i2) +END PROCEDURE select_random_int_from_array + +!---------------------------------------------------------------------------- +! RandomValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE select_random_real_from_vec +INTEGER(I4B) :: posi +posi = getRandomInteger(obj, From=1, To=size(Val)) +Ans = Val(posi) +END PROCEDURE select_random_real_from_vec + +!---------------------------------------------------------------------------- +! RandomValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE select_random_real_from_array +INTEGER(I4B) :: i1, i2 +i1 = getRandomInteger(obj, From=1, To=SIZE(Val, 1)) +i2 = getRandomInteger(obj, From=1, To=SIZE(Val, 2)) +Ans = Val(i1, i2) +END PROCEDURE select_random_real_from_array + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure rvec_uniform_01 +integer(i4b) i +integer(i4b) k +integer(i4b) seed0 +! +seed0 = INPUT(option=seed, default=1_I4B) +! +if (seed0 == 0) then + r = 0.0 + return +end if +! +do i = 1, n + k = seed0 / 127773 + seed0 = 16807 * (seed0 - k * 127773) - k * 2836 + if (seed0 < 0) then + seed0 = seed0 + 2147483647 + end if + r(i) = real(seed0, kind=8) * 4.656612875D-10 +end do +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE rvec_uniform_ab +integer(i4b) i +integer(i4b) k +integer(i4b) seed0 +! +seed0 = INPUT(option=seed, default=1_I4B) +! +if (seed0 == 0) then + r = 0.0 + return +end if +! +do i = 1, n + k = seed0 / 127773 + seed0 = 16807 * (seed0 - k * 127773) - k * 2836 + if (seed0 < 0) then + seed0 = seed0 + 2147483647 + end if + r(i) = a + (b - a) * real(seed0, kind=8) * 4.656612875D-10 +end do +! +END PROCEDURE rvec_uniform_ab + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE rvec_uniform_unit +real(kind=8) norm +! +! Get M values from a standard normal distribution. +! +w = rvec_normal_01(m, seed) +! +! Compute the length of the vector. +! +norm = sqrt(sum(w(1:m)**2)) +! +! Normalize the vector. +! +w(1:m) = w(1:m) / norm + +return +END PROCEDURE rvec_uniform_unit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure rvec_normal_01 +integer(i4b) m +real(dfp) r(n + 1) +real(dfp), parameter :: r8_pi = 3.141592653589793D+00 +integer(i4b) x_hi_index +integer(i4b) x_lo_index +! integer(i4b), save :: made = 0 +! real(dfp), save :: y = 0.0D+00 +! integer(i4b), save :: saved = 0 +integer(i4b) :: saved +integer(i4b) :: made +real(dfp) :: y +! +made = 0 +y = 0.0_DFP +saved = 0 +! +! I'd like to allow the user to reset the internal data. +! But this won't work properly if we have a saved value Y. +! I'm making a crock option that allows the user to signal +! explicitly that any internal memory should be flushed, +! by passing in a negative value for N. +! +if (n < 0) then + ! n = made + made = 0 + saved = 0 + y = 0.0D+00 + return +else if (n == 0) then + return +end if +! +! Record the range of X we need to fill in. +! +x_lo_index = 1 +x_hi_index = n +! +! Use up the old value, if we have it. +! +if (saved == 1) then + x(1) = y + saved = 0 + x_lo_index = 2 +end if +! +! Maybe we don't need any more values. +! +if (x_hi_index - x_lo_index + 1 == 0) then +! +! If we need just one new value, do that here to avoid null arrays. +! +else if (x_hi_index - x_lo_index + 1 == 1) then + + r(1) = r8_uniform_01(seed) + + if (r(1) == 0.0D+00) then + ! write (*, '(a)') ' ' + ! write (*, '(a)') 'rvec_NORMAL_01 - Fatal error!' + ! write (*, '(a)') ' R8_UNIFORM_01 returned a value of 0.' + ! stop 1 + return + end if + + r(2) = r8_uniform_01(seed) + + x(x_hi_index) = & + sqrt(-2.0D+00 * log(r(1))) * cos(2.0D+00 * r8_pi * r(2)) + y = sqrt(-2.0D+00 * log(r(1))) * sin(2.0D+00 * r8_pi * r(2)) + + saved = 1 + + made = made + 2 +! +! If we require an even number of values, that's easy. +! +else if (mod(x_hi_index - x_lo_index + 1, 2) == 0) then + + m = (x_hi_index - x_lo_index + 1) / 2 + + r = rvec_uniform_01(2 * m, seed) + + x(x_lo_index:x_hi_index - 1:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & + * cos(2.0D+00 * r8_pi * r(2:2 * m:2)) + + x(x_lo_index + 1:x_hi_index:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 1:2))) & + * sin(2.0D+00 * r8_pi * r(2:2 * m:2)) + + made = made + x_hi_index - x_lo_index + 1 +! +! If we require an odd number of values, we generate an even number, +! and handle the last pair specially, storing one in X(N), and +! saving the other for later. +! +else + + x_hi_index = x_hi_index - 1 + + m = (x_hi_index - x_lo_index + 1) / 2 + 1 + + r = rvec_uniform_01(2 * m, seed) + + x(x_lo_index:x_hi_index - 1:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & + * cos(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) + + x(x_lo_index + 1:x_hi_index:2) = & + sqrt(-2.0D+00 * log(r(1:2 * m - 3:2))) & + * sin(2.0D+00 * r8_pi * r(2:2 * m - 2:2)) + + x(n) = sqrt(-2.0E+00 * log(r(2 * m - 1))) & + * cos(2.0D+00 * r8_pi * r(2 * m)) + + y = sqrt(-2.0D+00 * log(r(2 * m - 1))) & + * sin(2.0D+00 * r8_pi * r(2 * m)) + + saved = 1 + + made = made + x_hi_index - x_lo_index + 2 + +end if +end procedure + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +module procedure r8_uniform_01 +integer(i4b) seed0 +integer(i4b) k +! +seed0 = INPUT(option=seed, default=1_I4B) +! +if (seed0 == 0) then + ans = 0.0 + return +end if +! +k = seed0 / 127773 + +seed0 = 16807 * (seed0 - k * 127773) - k * 2836 + +if (seed0 < 0) then + seed0 = seed0 + 2147483647 +end if +! +! Although SEED can be represented exactly as a 32 bit integer, +! it generally cannot be represented exactly as a 32 bit real number! +! +ans = real(seed0, kind=8) * 4.656612875D-10 +end procedure + +END SUBMODULE Methods diff --git a/src/submodules/Rank2Tensor/CMakeLists.txt b/src/submodules/Rank2Tensor/CMakeLists.txt new file mode 100644 index 000000000..fa0079d1e --- /dev/null +++ b/src/submodules/Rank2Tensor/CMakeLists.txt @@ -0,0 +1,19 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 4/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/Rank2Tensor_Method@ConstructorMethods.F90 + ${src_path}/Rank2Tensor_Method@IOMethods.F90 + ${src_path}/Rank2Tensor_Method@ContractionMethods.F90 + ${src_path}/Rank2Tensor_Method@InvarMethods.F90 + ${src_path}/Rank2Tensor_Method@OperatorMethods.F90 + ${src_path}/Rank2Tensor_Method@PullbackMethods.F90 + ${src_path}/Rank2Tensor_Method@PushForwardMethods.F90 +) diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 new file mode 100644 index 000000000..417034404 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ConstructorMethods.F90 @@ -0,0 +1,275 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Rank2Tensor_Method) ConstructorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE init_by_rank2 + obj%T = obj2%T + obj%isSym = obj2%isSym +END PROCEDURE init_by_rank2 +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE init_by_mat + obj%T = Mat + IF( PRESENT( isSym ) ) THEN + obj%isSym = isSym + ELSE + obj%isSym = .FALSE. + END IF +END PROCEDURE init_by_mat + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE init_by_voigt + obj%T = V + obj%isSym = .TRUE. +END PROCEDURE init_by_voigt + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE init_voigt_from_r2tensor + CALL Initiate( obj, T=T%T, VoigtType=VoigtType) +END PROCEDURE init_voigt_from_r2tensor + +!---------------------------------------------------------------------------- +! Rank2Tensor +!---------------------------------------------------------------------------- + +MODULE PROCEDURE r2t_by_mat + CALL Initiate( obj=Ans, Mat=Mat, isSym=isSym ) +END PROCEDURE r2t_by_mat + +!---------------------------------------------------------------------------- +! Rank2Tensor +!---------------------------------------------------------------------------- + +MODULE PROCEDURE r2t_by_voigt + CALL Initiate( obj=Ans, V=V ) +END PROCEDURE r2t_by_voigt + +!---------------------------------------------------------------------------- +! Rank2Tensor_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ptr_r2t_by_mat + ALLOCATE( Ans ) + CALL Initiate( obj=Ans, Mat=Mat, isSym=isSym ) +END PROCEDURE ptr_r2t_by_mat + +!---------------------------------------------------------------------------- +! Rank2Tensor_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ptr_r2t_by_voigt + ALLOCATE( Ans ) + CALL Initiate( obj=Ans, V=V ) +END PROCEDURE ptr_r2t_by_voigt + +!---------------------------------------------------------------------------- +! Assignment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE r2tensor_eq_mat + CALL Initiate( obj=obj, Mat=Mat ) +END PROCEDURE r2tensor_eq_mat + +!---------------------------------------------------------------------------- +! Assignment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat_eq_r2tensor + Mat = obj%T +END PROCEDURE mat_eq_r2tensor + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE voigt_eq_r2tensor + CALL Initiate( obj=V, T=obj%T, VoigtType=StressTypeVoigt) +END PROCEDURE voigt_eq_r2tensor + +!---------------------------------------------------------------------------- +! Identity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE identity_rank2 + CALL Initiate( obj=obj, Mat=Eye3, isSym=.TRUE. ) +END PROCEDURE identity_rank2 + +!---------------------------------------------------------------------------- +! ones +!---------------------------------------------------------------------------- + +MODULE PROCEDURE rank2_getOnes + REAL( DFP ) :: T( 3, 3 ) + T = 1.0_DFP + CALL Initiate( obj=obj, Mat=T, isSym=.TRUE. ) +END PROCEDURE rank2_getOnes + +!---------------------------------------------------------------------------- +! zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE rank2_getZeros + REAL( DFP ) :: T( 3, 3 ) + T = 0.0_DFP + CALL Initiate( obj=obj, Mat=T, isSym=.TRUE. ) +END PROCEDURE rank2_getZeros + +!---------------------------------------------------------------------------- +! IsotropicTensor +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isotropic_rank2 + CALL Initiate( obj=obj, Mat=Lambda*Eye3, isSym=.TRUE. ) +END PROCEDURE isotropic_rank2 + +!---------------------------------------------------------------------------- +! Sym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE sym_r2t + IF( obj%isSym ) THEN + CALL Initiate( obj=Ans, Mat=obj%T, isSym = .TRUE. ) + ELSE + CALL Initiate( obj=Ans, Mat=SYM( obj%T ), isSym = .TRUE. ) + END IF +END PROCEDURE sym_r2t + +!---------------------------------------------------------------------------- +! SkewSym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE skewsym_r2t + CALL Initiate( obj=Ans, Mat=SkewSym(obj%T), isSym=.FALSE. ) +END PROCEDURE skewsym_r2t + +!---------------------------------------------------------------------------- +! Transpose +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_transpose + CALL Initiate( Ans, Mat = TRANSPOSE(obj%T), isSym=obj%isSym ) +END PROCEDURE obj_transpose + +!---------------------------------------------------------------------------- +! isSym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isSym_rank2 + Ans = obj%isSym +END PROCEDURE isSym_rank2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isDeviatoric_rank2 + Ans = ABS( obj%T(1,1)+obj%T(2,2)+obj%T(3,3) ) .LE. 1.0E-12 +END PROCEDURE isDeviatoric_rank2 + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE inv_rank2 + CALL INV( A=obj%T, InvA=Invobj%T ) + Invobj%isSym = obj%isSym +END PROCEDURE inv_rank2 + +!---------------------------------------------------------------------------- +! DeformationGradient +!---------------------------------------------------------------------------- + +MODULE PROCEDURE F_constructor1 + IF( PRESENT( obj ) ) THEN + CALL initiate( Ans, obj ) + END IF +END PROCEDURE F_constructor1 + +!---------------------------------------------------------------------------- +! DeformationGradient_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE F_constructor_1 + ALLOCATE( Ans ) + Ans = DeformationGradient( obj ) +END PROCEDURE F_constructor_1 + +!---------------------------------------------------------------------------- +! LeftCauchyGreen +!---------------------------------------------------------------------------- + +MODULE PROCEDURE b_constructor1 + IF( PRESENT( F ) ) THEN + Ans = MATMUL( F, TRANSPOSE( F ) ) + ELSE IF( PRESENT( V ) ) THEN + Ans = MATMUL( V, V ) + END IF + Ans%isSym = .TRUE. +END PROCEDURE b_constructor1 + +!---------------------------------------------------------------------------- +! LeftCauchyGreen_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE b_constructor_1 + ALLOCATE( Ans ) + Ans = LeftCauchyGreen( F=F, V=V ) +END PROCEDURE b_constructor_1 + +!---------------------------------------------------------------------------- +! RightCauchyGreen +!---------------------------------------------------------------------------- + +MODULE PROCEDURE C_constructor1 + IF( PRESENT( F ) ) THEN + Ans = MATMUL( TRANSPOSE( F ), F ) + ELSE IF( PRESENT( U ) ) THEN + Ans = MATMUL( U, U ) + END IF + Ans%isSym = .TRUE. +END PROCEDURE C_constructor1 + +!---------------------------------------------------------------------------- +! RightCauchyGreen_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE C_constructor_1 + ALLOCATE( Ans ) + Ans = RightCauchyGreen( F=F, U=U ) +END PROCEDURE C_constructor_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE ConstructorMethods diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 new file mode 100644 index 000000000..b9e7c549c --- /dev/null +++ b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@ContractionMethods.F90 @@ -0,0 +1,89 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 17 March 2021 +! summary: Submodules for computing the contraction + +#define T_11 T( 1, 1 ) +#define T_12 T( 1, 2 ) +#define T_13 T( 1, 3 ) +#define T_21 T( 2, 1 ) +#define T_22 T( 2, 2 ) +#define T_23 T( 2, 3 ) +#define T_31 T( 3, 1 ) +#define T_32 T( 3, 2 ) +#define T_33 T( 3, 3 ) + +SUBMODULE(Rank2Tensor_Method) ContractionMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE r2_contract_r2 + Ans = SUM( obj1%T * obj2%T ) +END PROCEDURE r2_contract_r2 + +!---------------------------------------------------------------------------- +! Contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE r2_contract_voigt_r2 + ASSOCIATE( T => obj1%T, V => obj2%V, Scale => obj2%Scale ) + Ans = T_11 * V( 1 ) & + & + T_22 * V( 2 ) & + & + T_33 * V( 3 ) & + & + (T_12 + T_21) * V( 4 ) * Scale & + & + (T_23 + T_32) * V( 5 ) * Scale & + & + (T_13 + T_31) * V( 6 ) * Scale + END ASSOCIATE +END PROCEDURE r2_contract_voigt_r2 + +!---------------------------------------------------------------------------- +! Contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE voigt_r2_contract_r2 + Ans = r2_contract_voigt_r2( obj1=obj2, obj2=obj1 ) +END PROCEDURE voigt_r2_contract_r2 + +!---------------------------------------------------------------------------- +! Contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE voigt_r2_contract_voigt_r2 + ASSOCIATE( A => obj1%V, B => obj2%V, S1 => obj1%Scale, S2 => obj2%Scale ) + Ans = A( 1 ) * B( 1 ) + A( 2 ) * B( 2 ) + A( 3 ) * B( 3 ) & + & + 2.0 * S1 * S2 * ( A( 4 ) * B( 4 ) & + & + A( 5 ) * B( 5 ) + A( 6 ) * B( 6 ) ) + END ASSOCIATE +END PROCEDURE voigt_r2_contract_voigt_r2 + +#undef T_11 +#undef T_12 +#undef T_13 +#undef T_21 +#undef T_22 +#undef T_23 +#undef T_31 +#undef T_32 +#undef T_33 +END SUBMODULE ContractionMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 new file mode 100644 index 000000000..a0c8439af --- /dev/null +++ b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@IOMethods.F90 @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library, +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D, +! +! This program is free software: you can redistribute it and/or modify, +! it under the terms of the GNU General Public License as published by, +! the Free Software Foundation, either version 3 of the License, or, +! (at your option) any later version., +! +! This program is distributed in the hope that it will be useful,, +! but WITHOUT ANY WARRANTY; without even the implied warranty of, +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the, +! GNU General Public License for more details., +! +! You should have received a copy of the GNU General Public License, +! along with this program. If not, see . +! + +SUBMODULE(Rank2Tensor_Method) IOMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display@constructor +!---------------------------------------------------------------------------- + +MODULE PROCEDURE display_obj + CALL Display( obj%T, MSG=MSG, & + & UnitNo=INPUT( default = stdout, option=UnitNo ) ) +END PROCEDURE display_obj + +END SUBMODULE IOMethods diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 new file mode 100644 index 000000000..3c3a6847e --- /dev/null +++ b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@InvarMethods.F90 @@ -0,0 +1,335 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(Rank2Tensor_Method) InvarMethods +USE BaseMethod +#define T_11 T( 1, 1 ) +#define T_12 T( 1, 2 ) +#define T_13 T( 1, 3 ) +#define T_21 T( 2, 1 ) +#define T_22 T( 2, 2 ) +#define T_23 T( 2, 3 ) +#define T_31 T( 3, 1 ) +#define T_32 T( 3, 2 ) +#define T_33 T( 3, 3 ) +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE trace_obj +ASSOCIATE (T => obj%T) + IF (PRESENT(Power)) THEN + SELECT CASE (Power) + CASE (1) + Ans = T_11 + T_22 + T_33 + CASE (2) + Ans = SUM(T * TRANSPOSE(T)) + CASE (3) + Ans = SUM(MATMUL(T, T) * TRANSPOSE(T)) + END SELECT + ELSE + Ans = T_11 + T_22 + T_33 + END IF +END ASSOCIATE +END PROCEDURE trace_obj + +!---------------------------------------------------------------------------- +! J2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE j2_obj +LOGICAL(LGT) :: isDev +isDev = INPUT(default=.FALSE., option=isDeviatoric) +IF (isDev) THEN + Ans = 0.5_DFP * Trace(obj=obj, Power=2) +ELSE + ASSOCIATE (T => obj%T) + Ans = (T_11 - T_22)**2 & + & + (T_22 - T_33)**2 & + & + (T_33 - T_11)**2 & + & + 6.0_DFP * (T_12 * T_21 + T_23 * T_32 + T_13 * T_31) + Ans = Ans / 6.0_DFP + END ASSOCIATE +END IF +END PROCEDURE j2_obj + +!---------------------------------------------------------------------------- +! J3 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE j3_obj +LOGICAL(LGT) :: isDev +isDev = INPUT(default=.FALSE., option=isDeviatoric) +IF (isDev) THEN + Ans = det(obj) +ELSE + Ans = det(Deviatoric(obj)) +END IF +END PROCEDURE j3_obj + +!---------------------------------------------------------------------------- +! Det +!---------------------------------------------------------------------------- + +MODULE PROCEDURE det_obj +ASSOCIATE (T => obj%T) + Ans = T(1, 1) * (T(2, 2) * T(3, 3) - T(2, 3) * T(3, 2)) & + & - T(1, 2) * (T(2, 1) * T(3, 3) - T(2, 3) * T(3, 1)) & + & + T(1, 3) * (T(2, 1) * T(3, 2) - T(3, 1) * T(2, 2)) +END ASSOCIATE +END PROCEDURE det_obj + +!---------------------------------------------------------------------------- +! LodeAngle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE theta_obj_j2j3 +REAL(DFP) :: J_2, J_3, Dummy +J_2 = J2; J_3 = J3 +IF (J_2 .EQ. 0.0_DFP) THEN + Ans = 0.0_DFP +ELSE + Dummy = 1.5_DFP * SQRT(3.0_DFP) * J_3 / (J_2 * SQRT(J_2)) + IF (Dummy .GE. 1.0_DFP) Dummy = 1.0_DFP + IF (Dummy .LE. -1.0_DFP) Dummy = -1.0_DFP + IF (LodeType .EQ. SineLode) Ans = ASIN(-Dummy) / 3.0_DFP + IF (LodeType .EQ. CosineLode) Ans = ACOS(Dummy) / 3.0_DFP +END IF +END PROCEDURE theta_obj_j2j3 + +!---------------------------------------------------------------------------- +! LodeAngle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE theta_obj +Ans = LodeAngle(LodeType=LodeType, & + & J2=J2(obj, isDeviatoric), & + & J3=J3(obj, isDeviatoric)) +END PROCEDURE theta_obj + +!---------------------------------------------------------------------------- +! Isotropic +!---------------------------------------------------------------------------- + +MODULE PROCEDURE iso_part_obj +CALL IsotropicTensor(obj=Ans, Lambda=Trace(obj) / 3.0_DFP) +END PROCEDURE iso_part_obj + +!---------------------------------------------------------------------------- +! Deviatoric +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dev_part_obj +REAL(DFP) :: a +ASSOCIATE (T => Ans%T) + a = Trace(obj) / 3.0_DFP + T = 0.0_DFP + T_11 = a + T_22 = a + T_33 = a + T = -T + obj%T +END ASSOCIATE +END PROCEDURE dev_part_obj + +!---------------------------------------------------------------------------- +! Invariants +!---------------------------------------------------------------------------- + +MODULE PROCEDURE invariants_rank2 +LOGICAL(LGT) :: isDev + +isDev = INPUT(default=.FALSE., option=isDeviatoric) +IF (isDev) THEN + Ans(1) = 0.0 + Ans(2) = 0.5_DFP * Contraction(obj, TRANSPOSE(obj)) + Ans(3) = Det(obj) +ELSE + Ans(1) = Trace(obj) + Ans(2) = 0.5_DFP * (Ans(1)**2 - Trace(obj, Power=2)) + Ans(3) = Det(obj) +END IF +END PROCEDURE invariants_rank2 + +!---------------------------------------------------------------------------- +! Spectral +!---------------------------------------------------------------------------- + +MODULE PROCEDURE eigen_r2t +REAL(DFP) :: Mat(3, 3) +Mat = obj%T +IF (obj%isSym) THEN + CALL GetSymEigenJacobi(Mat=Mat, EigenValues=WR, EigenVectors=QR, MaxIter=100) +ELSE + CALL spectral_r2t(obj%T, QR=QR, WR=WR, QI=QI, WI=WI) +END IF +END PROCEDURE eigen_r2t + +!---------------------------------------------------------------------------- +! Spectral +!---------------------------------------------------------------------------- + +SUBROUTINE spectral_r2t(T, QR, WR, QI, WI) + REAL(DFP), INTENT(IN) :: T(3, 3) + REAL(DFP), INTENT(INOUT) :: QR(3, 3), QI(3, 3) + REAL(DFP), INTENT(OUT) :: WR(3), WI(3) + + ! Define internal varuables + REAL(DFP) :: EigenVec(3, 3) + REAL(DFP) :: Mat(3, 3) + + Mat = T + CALL GEEV(A=Mat, WR=WR, WI=WI, VR=EigenVec) + + ! First two eigen value is complex + IF (ABS(WI(1)) .GT. Zero) THEN + QR(:, 1) = EigenVec(:, 1) + QI(:, 1) = EigenVec(:, 2) + QR(:, 2) = EigenVec(:, 1) + QI(:, 2) = -EigenVec(:, 2) + QR(:, 3) = EigenVec(:, 3) + QI(:, 3) = 0.0_DFP + ! Last two eigen value is complex + ELSE IF (ABS(WI(2)) .GT. Zero) THEN + QR(:, 1) = EigenVec(:, 1) + QI(:, 1) = 0.0_DFP + QR(:, 2) = EigenVec(:, 2) + QI(:, 2) = EigenVec(:, 3) + QR(:, 3) = EigenVec(:, 2) + QI(:, 3) = -EigenVec(:, 3) + ! no complex eigen value + ELSE + QI = 0.0_DFP + QR(:, 1) = EigenVec(:, 1) + QR(:, 2) = EigenVec(:, 2) + QR(:, 3) = EigenVec(:, 3) + END IF +END SUBROUTINE spectral_r2t + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pd_r2t +CALL PD(Mat=obj%T, R=R%T, U=U%T, V=V%T) +U%isSym = .TRUE. +V%isSym = .TRUE. +END PROCEDURE pd_r2t + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: Polar decomposition +! +!# Introduction +! This subroutine calculates the polar decomposition +! * Ref: Higham and Noferini, 2015 Algorithm 3.1 for NSD = 3 +! * PDType = 1 for F = RU; and 2 for F = VR +! * Mat = RU = VR, Therefore H denotes either U or V + +SUBROUTINE PD(Mat, R, U, V) + ! Define intent of dummy variables + REAL(DFP), INTENT(IN) :: Mat(3, 3) + REAL(DFP), INTENT(INOUT) :: R(3, 3) + REAL(DFP), INTENT(INOUT) :: U(3, 3) + REAL(DFP), INTENT(INOUT) :: V(3, 3) + + ! Define internal variables + REAL(DFP) :: RT(3, 3) + REAL(DFP) :: B(4, 4) + REAL(DFP) :: EigenVecs(4, 4) + REAL(DFP) :: EigenVals(4) + REAL(DFP) :: Vmax(4) + INTEGER(I4B) :: MAX_LOC(1) + + B(1, 1) = Mat(1, 1) + Mat(2, 2) + Mat(3, 3) + B(1, 2) = Mat(2, 3) - Mat(3, 2) + B(1, 3) = Mat(3, 1) - Mat(1, 3) + B(1, 4) = Mat(1, 2) - Mat(2, 1) + B(2, 1) = Mat(1, 2) + B(2, 2) = Mat(1, 1) - Mat(2, 2) - Mat(3, 3) + B(2, 3) = Mat(1, 2) + Mat(2, 1) + B(2, 4) = Mat(1, 3) + Mat(3, 1) + B(3, 1) = B(1, 3) + B(3, 2) = B(2, 3) + B(3, 3) = -Mat(1, 1) + Mat(2, 2) - Mat(3, 3) + B(3, 4) = Mat(2, 3) + Mat(3, 2) + B(4, 1) = B(1, 4) + B(4, 2) = B(2, 4) + B(4, 3) = B(3, 4) + B(4, 4) = -Mat(1, 1) - Mat(2, 2) + Mat(3, 3) + + CALL GetSymEigenJacobi( & + & Mat=B, EigenValues=EigenVals, & + & EigenVectors=EigenVecs, MaxIter=100) + + ! Get Dominating eigen value and corresponding eigen vectors + MAX_LOC = MAXLOC(ABS(EigenVals)) + Vmax = EigenVecs(:, MAX_LOC(1)) + + ! Compute R matrix from Vmax Vector + R(1, 1) = 1.0_DFP - 2.0_DFP * (Vmax(3) * Vmax(3) + Vmax(4) * Vmax(4)) + RT(1, 1) = R(1, 1) + + R(1, 2) = 2.0_DFP * (Vmax(2) * Vmax(3) + Vmax(1) * Vmax(4)) + RT(2, 1) = R(1, 2) + + R(1, 3) = 2.0_DFP * (Vmax(2) * Vmax(4) - Vmax(1) * Vmax(3)) + RT(3, 1) = R(1, 3) + + R(2, 1) = 2.0_DFP * (Vmax(2) * Vmax(3) - Vmax(1) * Vmax(4)) + RT(1, 2) = R(2, 1) + + R(2, 2) = 1.0_DFP - 2.0_DFP * (Vmax(2) * Vmax(2) + Vmax(4) * Vmax(4)) + RT(2, 2) = R(2, 2) + + R(2, 3) = 2.0_DFP * (Vmax(3) * Vmax(4) + Vmax(1) * Vmax(2)) + RT(3, 2) = R(2, 3) + + R(3, 1) = 2.0_DFP * (Vmax(2) * Vmax(4) + Vmax(1) * Vmax(3)) + RT(1, 3) = R(3, 1) + + R(3, 2) = 2.0_DFP * (Vmax(3) * Vmax(4) - Vmax(1) * Vmax(2)) + RT(2, 3) = R(3, 2) + + R(3, 3) = 1.0_DFP - 2.0_DFP * (Vmax(3) * Vmax(3) + Vmax(2) * Vmax(2)) + RT(3, 3) = R(3, 3) + + U = MATMUL(RT, Mat) + V = MATMUL(Mat, RT) +END SUBROUTINE PD + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#undef T_11 +#undef T_12 +#undef T_13 +#undef T_21 +#undef T_22 +#undef T_23 +#undef T_31 +#undef T_32 +#undef T_33 + +END SUBMODULE InvarMethods diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.F90 new file mode 100644 index 000000000..1ab8f27ff --- /dev/null +++ b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@OperatorMethods.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 +! + +!> author: Vikas Sharma, Ph. D. +! date: 17 March 2021 +! summary: This subroutine contains algebraic operator + +SUBMODULE(Rank2Tensor_Method) OperatorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_add_obj + Ans%T = obj1%T + obj2%T + IF( obj1%isSym .AND. obj2%isSym ) Ans%isSym = .TRUE. +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_add_Scalar + Ans%T = obj1%T + obj2 + Ans%isSym = obj1%isSym +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_add_obj + Ans%T = obj1 + obj2%T + Ans%isSym = obj2%isSym +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_minus_obj + Ans%T = obj1%T - obj2%T + IF( obj1%isSym .AND. obj2%isSym ) Ans%isSym = .TRUE. + +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_minus_Scalar + Ans%T = obj1%T - obj2 + Ans%isSym = obj1%isSym +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_minus_obj + Ans%T = obj1 - obj2%T + Ans%isSym = obj2%isSym +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_times_obj + Ans%T = obj1%T * obj2%T +END PROCEDURE obj_times_obj + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_times_scalar + Ans%T = obj1%T * obj2 + Ans%isSym = obj1%isSym +END PROCEDURE obj_times_scalar + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalar_times_obj + Ans%T = obj1 * obj2%T + Ans%isSym = obj2%isSym +END PROCEDURE scalar_times_obj + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_div_obj + Ans%T = obj1%T / obj2%T +END PROCEDURE obj_div_obj + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_div_scalar + Ans%T = obj1%T / obj2 + Ans%isSym = obj1%isSym +END PROCEDURE obj_div_scalar + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalar_div_obj + Ans%T = obj1 / obj2%T + Ans%isSym = obj2%isSym +END PROCEDURE scalar_div_obj + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_matmul_obj + Ans%T = MATMUL( obj1%T, obj2%T ) +END PROCEDURE obj_matmul_obj + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_matmul_vec + Ans = MATMUL( obj1%T, obj2 ) +END PROCEDURE obj_matmul_vec + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vec_matmul_obj + Ans = MATMUL( obj1, obj2%T ) +END PROCEDURE vec_matmul_obj + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE OperatorMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 new file mode 100644 index 000000000..15fd67e8c --- /dev/null +++ b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PullbackMethods.F90 @@ -0,0 +1,90 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 17 March 2021 +! summary: Methods for pull back of rank2 tensor + +SUBMODULE(Rank2Tensor_Method) PullBackMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pullback_rank2 + TYPE( Rank2Tensor_ ) :: InvF + + SELECT CASE ( TRIM( indx1 ) ) + CASE( "NA" ) + SELECT CASE( TRIM( indx2 ) ) + CASE( "CONTRAVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL ( T, TRANSPOSE(InvF) ) + CASE( "COVAR" ) + Ans = MATMUL ( T, F ) + CASE( "NA" ) + Ans = T + END SELECT + + CASE( "CONTRAVAR" ) + SELECT CASE( TRIM( indx2 ) ) + CASE( "CONTRAVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( InvF, MATMUL (T, TRANSPOSE(InvF)) ) + CASE( "COVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( InvF, MATMUL ( T, F ) ) + CASE( "NA" ) + CALL INV( F, InvF ) + Ans = MATMUL( InvF, T ) + END SELECT + + CASE( "COVAR" ) + SELECT CASE( TRIM( indx2 ) ) + CASE( "CONTRAVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( TRANSPOSE(F), MATMUL(T, TRANSPOSE(InvF)) ) + CASE( "COVAR" ) + Ans = MATMUL( TRANSPOSE(F), MATMUL(T, F) ) + CASE( "NA" ) + Ans = MATMUL( TRANSPOSE(F), T ) + END SELECT + END SELECT + +END PROCEDURE pullback_rank2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pullback_vec + TYPE( Rank2Tensor_ ) :: InvF + SELECT CASE ( TRIM( indx1 ) ) + CASE( "NA" ) + Ans = Vec + CASE( "CONTRAVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( InvF, Vec ) + CASE( "COVAR" ) + Ans = MATMUL( TRANSPOSE(F), Vec ) + END SELECT +END PROCEDURE pullback_vec + +END SUBMODULE PullBackMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 new file mode 100644 index 000000000..2f3daf517 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/Rank2Tensor_Method@PushForwardMethods.F90 @@ -0,0 +1,90 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 17 March 2021 +! summary: Methods for pull back of rank2 tensor + +SUBMODULE(Rank2Tensor_Method) PushForwardMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE PushForward_rank2 + TYPE( Rank2Tensor_ ) :: InvF + + SELECT CASE ( TRIM( indx1 ) ) + CASE( "NA" ) + SELECT CASE( TRIM( indx2 ) ) + CASE( "CONTRAVAR" ) + Ans = MATMUL( T, TRANSPOSE(F) ) + CASE( "COVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( T, InvF ) + CASE( "NA" ) + Ans = T + END SELECT + + CASE( "CONTRAVAR" ) + SELECT CASE( TRIM( indx2 ) ) + CASE( "CONTRAVAR" ) + Ans = MATMUL( F, MATMUL(T, TRANSPOSE(F)) ) + CASE( "COVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( F, MATMUL ( T, InvF ) ) + CASE( "NA" ) + Ans = MATMUL( F, T ) + END SELECT + + CASE( "COVAR" ) + SELECT CASE( TRIM( indx2 ) ) + CASE( "CONTRAVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( TRANSPOSE(InvF), MATMUL(T, TRANSPOSE(F)) ) + CASE( "COVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( TRANSPOSE(InvF), MATMUL(T, InvF) ) + CASE( "NA" ) + CALL INV( F, InvF ) + Ans = MATMUL( TRANSPOSE( InvF ), T ) + END SELECT + END SELECT + +END PROCEDURE PushForward_rank2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE PushForward_vec + TYPE( Rank2Tensor_ ) :: InvF + SELECT CASE ( TRIM( indx1 ) ) + CASE( "NA" ) + Ans = Vec + CASE( "CONTRAVAR" ) + Ans = MATMUL( F, Vec ) + CASE( "COVAR" ) + CALL INV( F, InvF ) + Ans = MATMUL( TRANSPOSE(InvF), Vec ) + END SELECT +END PROCEDURE PushForward_vec + +END SUBMODULE PushForwardMethods \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/matrix_exponential.F90 b/src/submodules/Rank2Tensor/src/matrix_exponential.F90 new file mode 100644 index 000000000..765b9b9d4 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/matrix_exponential.F90 @@ -0,0 +1,502 @@ +subroutine c8mat_expm1 ( n, a, e ) + +!*****************************************************************************80 +! +!! C8MAT_EXPM1 is essentially MATLAB's built-in matrix exponential algorithm. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 March 2013 +! +! Author: +! +! FORTRAN90 version by John Burkardt +! +! Reference: +! +! Cleve Moler, Charles VanLoan, +! Nineteen Dubious Ways to Compute the Exponential of a Matrix, +! Twenty-Five Years Later, +! SIAM Review, +! Volume 45, Number 1, March 2003, pages 3-49. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the matrix. +! +! Input, complex ( kind = 8 ) A(N,N), the matrix. +! +! Output, complex ( kind = 8 ) E(N,N), the estimate for exp(A). +! + implicit none + + integer ( kind = 4 ) n + + complex ( kind = 8 ) a(n,n) + complex ( kind = 8 ) a2(n,n) + real ( kind = 8 ) a_norm + real ( kind = 8 ) c + real ( kind = 8 ) c8mat_norm_li + complex ( kind = 8 ) d(n,n) + complex ( kind = 8 ) e(n,n) + integer ( kind = 4 ) ee + integer ( kind = 4 ) k + logical p + integer ( kind = 4 ) , parameter :: q = 6 + real ( kind = 8 ) r8_log_2 + integer ( kind = 4 ) s + complex ( kind = 8 ) x(n,n) +! +! Make a copy of the matrix. +! + a2(1:n,1:n) = a(1:n,1:n) +! +! Compute the L-infinity norm. +! + a_norm = c8mat_norm_li ( n, n, a2 ) +! +! Determine a scaling factor for the matrix. +! + ee = int ( r8_log_2 ( a_norm ) ) + 1 + + s = max ( 0, ee + 1 ) + + a2(1:n,1:n) = a2(1:n,1:n) / 2.0D+00 ** s + + x(1:n,1:n) = a2(1:n,1:n) + + c = 0.5D+00 + + call c8mat_identity ( n, e ) + e(1:n,1:n) = e(1:n,1:n) + c * a2(1:n,1:n) + + call c8mat_identity ( n, d ) + d(1:n,1:n) = d(1:n,1:n) - c * a2(1:n,1:n) + + p = .true. + + do k = 2, q + + c = c * real ( q - k + 1, kind = 8 ) & + / real ( k * ( 2 * q - k + 1 ), kind = 8 ) + + x(1:n,1:n) = matmul ( a2(1:n,1:n), x(1:n,1:n) ) + + e(1:n,1:n) = e(1:n,1:n) + c * x(1:n,1:n) + + if ( p ) then + d(1:n,1:n) = d(1:n,1:n) + c * x(1:n,1:n) + else + d(1:n,1:n) = d(1:n,1:n) - c * x(1:n,1:n) + end if + + p = .not. p + + end do +! +! E -> inverse(D) * E +! + call c8mat_minvm ( n, n, d, e, e ) +! +! E -> E^(2*S) +! + do k = 1, s + e(1:n,1:n) = matmul ( e(1:n,1:n), e(1:n,1:n) ) + end do + + return +end + +subroutine r8mat_expm1 ( n, a, e ) + +!*****************************************************************************80 +! +!! R8MAT_EXPM1 is essentially MATLAB's built-in matrix exponential algorithm. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 November 2011 +! +! Author: +! +! Cleve Moler, Charles Van Loan +! +! Reference: +! +! Cleve Moler, Charles VanLoan, +! Nineteen Dubious Ways to Compute the Exponential of a Matrix, +! Twenty-Five Years Later, +! SIAM Review, +! Volume 45, Number 1, March 2003, pages 3-49. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the matrix. +! +! Input, real ( kind = 8 ) A(N,N), the matrix. +! +! Output, real ( kind = 8 ) E(N,N), the estimate for exp(A). +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a(n,n) + real ( kind = 8 ) a2(n,n) + real ( kind = 8 ) a_norm + real ( kind = 8 ) c + real ( kind = 8 ) d(n,n) + real ( kind = 8 ) e(n,n) + integer ( kind = 4 ) ee + integer ( kind = 4 ) k + logical p + integer ( kind = 4 ) , parameter :: q = 6 + real ( kind = 8 ) r8_log_2 + real ( kind = 8 ) r8mat_norm_li + integer ( kind = 4 ) s + real ( kind = 8 ) x(n,n) + + a2(1:n,1:n) = a(1:n,1:n) + + a_norm = r8mat_norm_li ( n, n, a2 ) + + ee = int ( r8_log_2 ( a_norm ) ) + 1 + + s = max ( 0, ee + 1 ) + + a2(1:n,1:n) = a2(1:n,1:n) / 2.0D+00**s + + x(1:n,1:n) = a2(1:n,1:n) + + c = 0.5D+00 + + call r8mat_identity ( n, e ) + e(1:n,1:n) = e(1:n,1:n) + c * a2(1:n,1:n) + + call r8mat_identity ( n, d ) + d(1:n,1:n) = d(1:n,1:n) - c * a2(1:n,1:n) + + p = .true. + + do k = 2, q + + c = c * real ( q - k + 1, kind = 8 ) & + / real ( k * ( 2 * q - k + 1 ), kind = 8 ) + + x(1:n,1:n) = matmul ( a2(1:n,1:n), x(1:n,1:n) ) + + e(1:n,1:n) = e(1:n,1:n) + c * x(1:n,1:n) + + if ( p ) then + d(1:n,1:n) = d(1:n,1:n) + c * x(1:n,1:n) + else + d(1:n,1:n) = d(1:n,1:n) - c * x(1:n,1:n) + end if + + p = .not. p + + end do +! +! E -> inverse(D) * E +! + call r8mat_minvm ( n, n, d, e, e ) +! +! E -> E^(2*S) +! + do k = 1, s + e(1:n,1:n) = matmul ( e(1:n,1:n), e(1:n,1:n) ) + end do + + return +end + +subroutine r8mat_expm2 ( n, a, e ) + +!*****************************************************************************80 +! +!! R8MAT_EXPM2 uses the Taylor series for the matrix exponential. +! +! Discussion: +! +! Formally, +! +! exp ( A ) = I + A + 1/2 A^2 + 1/3! A^3 + ... +! +! This function sums the series until a tolerance is satisfied. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 November 2011 +! +! Author: +! +! Cleve Moler, Charles Van Loan +! +! Reference: +! +! Cleve Moler, Charles VanLoan, +! Nineteen Dubious Ways to Compute the Exponential of a Matrix, +! Twenty-Five Years Later, +! SIAM Review, +! Volume 45, Number 1, March 2003, pages 3-49. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the matrix. +! +! Input, real ( kind = 8 ) A(N,N), the matrix. +! +! Output, real ( kind = 8 ) E(N,N), the estimate for exp(A). +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a(n,n) + real ( kind = 8 ) e(n,n) + real ( kind = 8 ) f(n,n) + real ( kind = 8 ) g(n,n) + integer ( kind = 4 ) k + logical r8mat_insignificant + + e(1:n,1:n) = 0.0D+00 + + call r8mat_identity ( n, f ) + + k = 1 + + do + + if ( r8mat_insignificant ( n, n, e, f ) ) then + exit + end if + + e(1:n,1:n) = e(1:n,1:n) + f(1:n,1:n) + + f(1:n,1:n) = matmul ( a(1:n,1:n), f(1:n,1:n) ) / real ( k, kind = 8 ) + k = k + 1 + + end do + + return +end + +subroutine r8mat_expm3 ( n, a, e ) + +!*****************************************************************************80 +! +!! R8MAT_EXPM3 approximates the matrix exponential using an eigenvalue approach. +! +! Discussion: +! +! exp(A) = V * D * V +! +! where V is the matrix of eigenvectors of A, and D is the diagonal matrix +! whose i-th diagonal entry is exp(lambda(i)), for lambda(i) an eigenvalue +! of A. +! +! This function is accurate for matrices which are symmetric, orthogonal, +! or normal. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 November 2011 +! +! Author: +! +! Cleve Moler, Charles Van Loan +! +! Reference: +! +! Cleve Moler, Charles VanLoan, +! Nineteen Dubious Ways to Compute the Exponential of a Matrix, +! Twenty-Five Years Later, +! SIAM Review, +! Volume 45, Number 1, March 2003, pages 3-49. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the matrix. +! +! Input, real ( kind = 8 ) A(N,N), the matrix. +! +! Output, real ( kind = 8 ) E(N,N), the estimate for exp(A). +! +! [ V, D ] = eig ( A ); +! E = V * diag ( exp ( diag ( D ) ) ) / V; + + return +end + + +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: TensorFunctions.part +! Last Update : Dec-16-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of module +! +! DESCRIPTION :: +! - This part contains subroutines for computing various +! Tensor valued Tensor functions +! +! HOSTING FILE +! - Rank2Tensor_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! TensorPower +!------------------------------------------------------------------------------ + +! RECURSIVE FUNCTION TensorPower( N, T, TSquare, I1, I2, I3 ) RESULT( TP ) + +! ! Description +! !. . . . . . . . . . . . . . . . . . . . +! ! 1. - T^n is computed using Cayley-Hamilton theorem +! !. . . . . . . . . . . . . . . . . . . . + +! USE Utility, ONLY : Eye + +! ! Define Intent of dummy variables +! REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: T, TSquare +! REAL( DFP ), DIMENSION( SIZE( T, 1 ), SIZE( T, 2 ) ) :: TP +! REAL( DFP ), INTENT( IN ) :: I1, I2, I3 +! INTEGER( I4B ), INTENT( IN ) :: N + +! ! Define internal variables +! INTEGER( I4B ) :: I +! Error_Flag = .FALSE. + +! SELECT CASE( N ) + +! CASE( 0 ) +! TP = Eye( SIZE( T, 1 ) ) +! CASE( 1 ) +! TP = T +! CASE( 2 ) +! TP = TSquare +! CASE DEFAULT +! TP = I1 * TensorPower( N-1, T, TSquare, I1, I2, I3 ) & +! - I2 * TensorPower( N-2, T, TSquare, I1, I2, I3 ) & +! + I3 * TensorPower( N-3, T, TSquare, I1, I2, I3 ) +! END SELECT +! ! +! END FUNCTION TensorPower + +!------------------------------------------------------------------------------ +! f_TensorEXP_1 +!------------------------------------------------------------------------------ + + FUNCTION f_TensorEXP_1( Mat, t, m ) + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. - compute exp( T ) using time-series +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY: Factorial, Eye, INT2STR + + ! Define Intent of dummy variables + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: f_TensorEXP_1 + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: m + REAL( DFP ), INTENT( IN ) :: t + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Dummy( :, : ) + INTEGER( I4B ) :: N = 20, I + + IF( PRESENT( m ) ) N = m + + IF( N .GE. 40 ) THEN + + CALL Err_Msg( "Rank2Tensor_Class.F90>>TensorFunctions.part", & + "Tensor_Exp()", & + "m is too large to compute the factorial; Program Stopped!") + STOP + + END IF + + Dummy = Eye( SIZE( Mat, 1 ) ) + f_TensorEXP_1 = Dummy + + DO I = 1, N + + + Dummy = MATMUL( Mat, Dummy ) + f_TensorEXP_1 = f_TensorEXP_1 + ( t**I ) * Dummy / REAL( Factorial( I ), KIND = DFP ) + + END DO + + + DEALLOCATE( Dummy ) + + END FUNCTION f_TensorEXP_1 + +!------------------------------------------------------------------------------ +! m_TensorEXP_1 +!------------------------------------------------------------------------------ + + FUNCTION m_TensorEXP_1( obj, t, m ) + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. - compute exp( T ) using time-series +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY: Factorial, Eye + + ! Define Intent of dummy variables + + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_TensorEXP_1 + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: m + REAL( DFP ), INTENT( IN ) :: t + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Mat( :, : ) + + Mat = obj + + IF( PRESENT( m ) ) THEN + + m_TensorEXP_1 = f_TensorEXP_1( Mat, t, m ) + + ELSE + + m_TensorEXP_1 = f_TensorEXP_1( Mat, t ) + + END IF + + DEALLOCATE( Mat ) + + END FUNCTION m_TensorEXP_1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 b/src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 new file mode 100755 index 000000000..f14867496 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/ContinuumSpin/ContinuumSpin_Class.F90 @@ -0,0 +1,137 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ContinuumSpin_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define ContinuumSpin Class +!============================================================================== + + MODULE ContinuumSpin_Class + USE GlobalData + USE IO + USE Rank2Tensor_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: ContinuumSpin_, ContinuumSpin, ContinuumSpin_Pointer + +!------------------------------------------------------------------------------ +! ContinuumSpin_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Rank2Tensor_ ) :: ContinuumSpin_ + + END TYPE ContinuumSpin_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE ContinuumSpin + MODULE PROCEDURE Constructor1, Constructor2 + END INTERFACE + + INTERFACE ContinuumSpin_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy varialbes + CLASS( ContinuumSpin_ ), POINTER :: Constructor_1 + + ALLOCATE( Constructor_1 ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( L ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + USE VelocityGradient_Class + + ! Define intent of dummy varialbes + CLASS( ContinuumSpin_ ), POINTER :: Constructor_2 + TYPE( VelocityGradient_ ), INTENT( IN ) :: L + + ALLOCATE( Constructor_2 ) + Constructor_2 = .Anti. L + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( ContinuumSpin_ ) :: Constructor1 + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( L ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + USE VelocityGradient_Class + + ! Define intent of dummy varialbes + TYPE( ContinuumSpin_ ) :: Constructor2 + TYPE( VelocityGradient_ ), INTENT( IN ) :: L + + Constructor2 = .Anti. L + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + + END MODULE ContinuumSpin_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 new file mode 100755 index 000000000..3ec397469 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationGradient_Class.F90 @@ -0,0 +1,218 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DeformationGradient_Class.F90 +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to deformation gradient +!============================================================================== + + MODULE DeformationGradient_Class + USE GlobalData + USE IO + USE Rank2Tensor_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: DeformationGradient_, DeformationGradient_Pointer, & + DeformationGradient + +!------------------------------------------------------------------------------ +! DeformationGradient_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Rank2Tensor_ ) :: DeformationGradient_ + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. - DeformationGradient +!. . . . . . . . . . . . . . . . . . . . + + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: R + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: U + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: V + REAL( DFP ), ALLOCATABLE, DIMENSION( : ) :: EigenVal + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_U + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_V + + CONTAINS + + ! Constructor.part + + PROCEDURE, PUBLIC, PASS :: Initiate2, Initiate5 + PROCEDURE, PUBLIC, PASS :: Deallocate + + ! Component.part + + PROCEDURE, PUBLIC, PASS :: m_RightStretch + PROCEDURE, PUBLIC, PASS :: m_Rotation + PROCEDURE, PUBLIC, PASS :: m_LeftStretch + PROCEDURE, PUBLIC, PASS :: m_EigenValues + PROCEDURE, PUBLIC, PASS :: m_EigenVectors_U + PROCEDURE, PUBLIC, PASS :: m_EigenVectors_V + PROCEDURE, PUBLIC, PASS :: m_Jacobian + + GENERIC, PUBLIC :: OPERATOR( .R. ) => m_Rotation + GENERIC, PUBLIC :: OPERATOR( .U. ) => m_RightStretch + GENERIC, PUBLIC :: OPERATOR( .V. ) => m_LeftStretch + GENERIC, PUBLIC :: OPERATOR( .EigenValues. ) => m_EigenValues + GENERIC, PUBLIC :: OPERATOR( .EigenVectorsU. ) => m_EigenVectors_U + GENERIC, PUBLIC :: OPERATOR( .EigenVectorsV. ) => m_EigenVectors_V + GENERIC, PUBLIC :: OPERATOR( .J. ) => m_Jacobian + + ! DeformationTensor.part + + PROCEDURE, PUBLIC, PASS :: m_RightCauchyGreen + GENERIC, PUBLIC :: RightCauchyGreen => m_RightCauchyGreen + GENERIC, PUBLIC :: OPERATOR( .C. ) => m_RightCauchyGreen + + PROCEDURE, PUBLIC, PASS :: m_LeftCauchyGreen + GENERIC, PUBLIC :: LeftCauchyGreen => m_LeftCauchyGreen + GENERIC, PUBLIC :: OPERATOR( .B. ) => m_LeftCauchyGreen + + ! StrainTensor.part + + PROCEDURE, PUBLIC, PASS :: m_GreenStrain + GENERIC, PUBLIC :: OPERATOR( .GreenStrain. ) => m_GreenStrain + GENERIC, PUBLIC :: GreenStrain => m_GreenStrain + + + PROCEDURE, PUBLIC, PASS :: m_AlmansiStrain + GENERIC, PUBLIC :: OPERATOR( .AlmansiStrain. ) => m_AlmansiStrain + GENERIC, PUBLIC :: AlmansiStrain => m_AlmansiStrain + + ! Display.part + + PROCEDURE, PUBLIC, PASS :: Display + + END TYPE DeformationGradient_ + + +!. . . . . . . . . . . . . . . . . . . . +! DeformationGradient_Pointer +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE DeformationGradient_Pointer + MODULE PROCEDURE Constructor1, Constructor2, Constructor3 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! DeformationGradient +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE DeformationGradient + MODULE PROCEDURE Constructor4, Constructor5, Constructor6 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! OPERATOR( .C. ) +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE OPERATOR( .C. ) + MODULE PROCEDURE m_RightCauchyGreen, f_RightCauchyGreen + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! RightCauchyGreen +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE RightCauchyGreen + MODULE PROCEDURE m_RightCauchyGreen, f_RightCauchyGreen + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! OPERATOR( .B. ) +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE OPERATOR( .B. ) + MODULE PROCEDURE m_LeftCauchyGreen, f_LeftCauchyGreen + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! LeftCauchyGreen +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE LeftCauchyGreen + MODULE PROCEDURE m_LeftCauchyGreen, f_LeftCauchyGreen + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! GreenTensor +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE GreenTensor + MODULE PROCEDURE m_GreenStrain, f_GreenStrain + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! GreenTensor +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE OPERATOR( .GreenTensor. ) + + MODULE PROCEDURE m_GreenStrain, f_GreenStrain + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! AlmansiTensor +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE AlmansiTensor + + MODULE PROCEDURE m_AlmansiStrain, f_AlmansiStrain + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! AlmansiTensor +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE OPERATOR( .AlmansiTensor. ) + + MODULE PROCEDURE m_AlmansiStrain, f_AlmansiStrain + + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + + CONTAINS + +#include "./Constructor.part" +#include "./Display.part" +#include "./Components.part" +#include "./StrainTensor.part" +#include "./DeformationTensor.part" + + END MODULE DeformationGradient_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part new file mode 100755 index 000000000..c51686371 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/DeformationTensor.part @@ -0,0 +1,100 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DeformationTensor.part +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Deformation Gradient class is defined +! HOSTING FILE +! - DeformationGradient_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! m_RightCauchyGreen +!------------------------------------------------------------------------------ + + FUNCTION m_RightCauchyGreen( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. m_RightCauchyGreen = F^T F +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( DeformationGradient_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_RightCauchyGreen + + ! Define internal variables + + m_RightCauchyGreen = ( .transpose. obj ) .matmul. obj + + END FUNCTION m_RightCauchyGreen + +!------------------------------------------------------------------------------ +! f_RightCauchyGreen +!------------------------------------------------------------------------------ + + FUNCTION f_RightCauchyGreen( Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. f_RightCauchyGreen = F^T F +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), DIMENSION( 3, 3 ) :: f_RightCauchyGreen + + ! Define internal variables + + f_RightCauchyGreen = ( .transpose. Mat ) .matmul. Mat + + END FUNCTION f_RightCauchyGreen + +!------------------------------------------------------------------------------ +! m_LeftCauchyGreen +!------------------------------------------------------------------------------ + + FUNCTION m_LeftCauchyGreen( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. m_LeftCauchyGreen = FF^T +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( DeformationGradient_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_LeftCauchyGreen + + ! Define internal variables + + m_LeftCauchyGreen = obj .matmul. ( .transpose. obj ) + + END FUNCTION m_LeftCauchyGreen + +!------------------------------------------------------------------------------ +! f_LeftCauchyGreen +!------------------------------------------------------------------------------ + + FUNCTION f_LeftCauchyGreen( Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. f_LeftCauchyGreen = FF^T +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), DIMENSION( 3, 3 ) :: f_LeftCauchyGreen + + ! Define internal variables + + f_LeftCauchyGreen = MATMUL( Mat, TRANSPOSE( Mat ) ) + + END FUNCTION f_LeftCauchyGreen \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part new file mode 100755 index 000000000..c9bc327ab --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/Display.part @@ -0,0 +1,120 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Display.part +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Display DeformationGradinet object +! HOSTING FILE +! - DeformationGradient_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Display +!------------------------------------------------------------------------------ + + SUBROUTINE Display( obj, UnitNo ) + + USE Utility, ONLY: Display_Array + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. - Display the content +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( DeformationGradient_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo + + ! Define internal variables + INTEGER( I4B ) :: I, j + + IF( PRESENT( UnitNo ) ) THEN + I = UnitNo + ELSE + I = 6 + END IF + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL BlankLines( UnitNo = I ) + WRITE( I, "(A)" ) "DeformationGradient_ object is not initiated " + WRITE( I, "(A)" ) "Nothing to show " + CALL BlankLines( UnitNo = I ) + RETURN + + END IF + + CALL BlankLines( UnitNo = I ) + CALL EqualLine( UnitNo = I ) + WRITE( I, "(5X, A)" ) "|||| Deformation Gradient obj Data ||||" + CALL EqualLine( UnitNo = I ) + CALL BlankLines( UnitNo = I ) + + + + CALL BlankLines( UnitNo = I ) + WRITE( I, "(A)" ) "F = " + CALL BlankLines( UnitNo = I ) + + DO j = 1, 3 + + WRITE( I, "(4x, 3G17.7)" ) obj%T( j, : ) + + END DO + CALL BlankLines( UnitNo = I ) + + WRITE( I, "(A, I2 )" ) "NSD = ", obj%NSD + CALL BlankLines( UnitNo = I ) + + IF( ALLOCATED( obj%R ) ) THEN + + CALL Display_Array( obj%R, " R ", I ) + + END IF + + IF( ALLOCATED( obj%U ) ) THEN + + CALL Display_Array( obj%U, " U ", I ) + + END IF + + IF( ALLOCATED( obj%V ) ) THEN + + CALL Display_Array( obj%V, " V ", I ) + + END IF + + IF( ALLOCATED( obj%EigenVal ) ) THEN + + CALL Display_Array( obj%EigenVal, " EigenValues ", I ) + + END IF + + IF( ALLOCATED( obj%EigenVec_U ) ) THEN + + CALL Display_Array( obj%EigenVec_U, " Eigen Vectors of U ", I ) + + END IF + + IF( ALLOCATED( obj%EigenVec_V ) ) THEN + + CALL Display_Array( obj%EigenVec_V, " Eigen Vectors of V ", I ) + + END IF + + CALL DashLine( UnitNo = I ) + CALL BlankLines( UnitNo = I ) + + END SUBROUTINE Display +! \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md new file mode 100755 index 000000000..2280d6841 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/MdFiles/DeformationGradient_Class.md @@ -0,0 +1,128 @@ +# Deformation Gradient Class + +## Structure + +```fortran + TYPE, PUBLIC, EXTENDS( Rank2Tensor_ ) :: DeformationGradient_ + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: R + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: U + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: V + REAL( DFP ), ALLOCATABLE, DIMENSION( : ) :: EigenVal + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_U + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: EigenVec_V +``` + +## Description + +## Getting Started + +### Constructing the object + +The subroutine `Initiate()` can be used to create the `DeformationGradient_` class. + +```fortran +CALL obj%Initiate( ) +CALL obj%Initiate( Mat2( :, : ) ) +CALL obj%Initiate( Scalar ) +CALL obj%Initiate( VoigtVec, VoigtType ) +CALL obj%Initiate( obj2 ) +``` + +In addition we can use the function `DeformationGradient()` which returns the `DeformationGradient_` type. + +```fortran +obj = DeformationGradient( ) +obj = DeformationGradient( Mat2, FULL ) +obj = DeformationGradient( Mat2 ) +``` + +We have also defined function `DeformationGradient_Pointer()` that returns the pointer to the `DeformationGradient_` pointer. + +```fortran +obj = DeformationGradient_Pointer( ) +obj = DeformationGradient_Pointer( Mat2, FULL ) +obj = DeformationGradient_Pointer( Mat2 ) +``` + +Here `Full` can be `True` or `False`. If `True` then `R, U, V, EigenVal, EigenVec_U, EigenVec_V` all will be computed. + +We can also use `Assignment Operator( = )` + +```fortran +obj = Mat2( :, : ) +``` + +### Deallocating the object + +We can call `obj%Deallocate()` + +### Getting the Rotation part + +```fortran +R = .R. obj +``` + +### Getting the Right Stretch Tensor + +```fortran +U = .U. obj +``` + +### Getting the Left Stretch Tensor + +```fortran +V = .V. obj +``` + +### Getting the EigenValues of F, U, V + +Not that U and V are similar tensor, therefore, F, U, V all have same eigenvalues. + +```fortran +Val = .EigenValues. obj +``` + +### Getting the EigenVectors of U and V + +```fortran +P( :, : ) = .EigenVectorsU. obj +P( :, : ) = .EigenVectorsV. obj +``` + +### Getting the Jacobian + +```fortran +J = .J. obj +``` + +### Getting Right and Left Cauchy Green Deformation Tensor + +```fortran +C = RightCauchyGreen( obj ) +C = RightCauchyGreen( Mat ) +C = .C. obj +C = .C. Mat +``` + +```fortran +B = LeftCauchyGreen( obj ) +B = LeftCauchyGreen( Mat ) +B = .B. obj +B = .B. Mat +``` + +### Getting the Strain + +```fortran +E = GreenStrain( obj ) +E = GreenStrain( Mat ) +E = .GreenStrain. obj +E = .GreenStrain. Mat +``` + +```fortran +e = AlmansiStrain( obj ) +e = AlmansiStrain( Mat ) +e = .AlmansiStrain. obj +e = .AlmansiStrain. Mat +``` \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part new file mode 100755 index 000000000..612e80c54 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/DeformationGradient/StrainTensor.part @@ -0,0 +1,112 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DeformationTensor.part +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Deformation Gradient class is defined +! HOSTING FILE +! - DeformationGradient_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! m_GreenStrain +!------------------------------------------------------------------------------ + + FUNCTION m_GreenStrain( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. m_GreenStrain = 0.5 * ( F^T F - I ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( DeformationGradient_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_GreenStrain + + ! Define internal variables + + m_GreenStrain = 0.5_DFP * ( (( .transpose. obj ) .matmul. obj) - Eye3 ) + + END FUNCTION m_GreenStrain + +!------------------------------------------------------------------------------ +! f_GreenStrain +!------------------------------------------------------------------------------ + + FUNCTION f_GreenStrain( Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. f_GreenStrain = 0.5 * ( F^T F - I ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), DIMENSION( 3, 3 ) :: f_GreenStrain + + ! Define internal variables + + f_GreenStrain = 0.5_DFP * ( (( .transpose. Mat ) .matmul. Mat) - Eye3 ) + + END FUNCTION f_GreenStrain + +!------------------------------------------------------------------------------ +! m_AlmansiStrain +!------------------------------------------------------------------------------ + + FUNCTION m_AlmansiStrain( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. m_AlmansiStrain +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( DeformationGradient_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_AlmansiStrain + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: B( :, : ), InvB( :, : ) + + B = .B. obj + InvB = .Inv. B + + m_AlmansiStrain = 0.5_DFP * ( Eye3 - InvB ) + + DEALLOCATE( B, InvB ) + + END FUNCTION m_AlmansiStrain + +!------------------------------------------------------------------------------ +! f_AlmansiStrain +!------------------------------------------------------------------------------ + + FUNCTION f_AlmansiStrain( Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. f_AlmansiStrain +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), DIMENSION( 3, 3 ) :: f_AlmansiStrain + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: B( :, : ), InvB( :, :) + + B = .B. Mat + InvB = .Inv. B + + f_AlmansiStrain = 0.5_DFP * ( Eye3 - InvB ) + + DEALLOCATE( B, InvB ) + + END FUNCTION f_AlmansiStrain diff --git a/src/submodules/Rank2Tensor/src/old data/Interface.part b/src/submodules/Rank2Tensor/src/old data/Interface.part new file mode 100755 index 000000000..a0dc41a75 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Interface.part @@ -0,0 +1,314 @@ + + INTERFACE Rank2Tensor_Pointer + + MODULE PROCEDURE :: Constructor1, Constructor2, Constructor3, & + Constructor4, Constructor10 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Rank2Tensor + + MODULE PROCEDURE :: Constructor5, Constructor6, Constructor7, & + Constructor8, Constructor9 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE VectorProduct + + MODULE PROCEDURE VectorProduct2, VectorProduct3 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Box + + MODULE PROCEDURE BoxProduct + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE getParallelComponent + + MODULE PROCEDURE getProjection + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Trace + + MODULE PROCEDURE Trace_2, Trace_1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE isSymmetric + + MODULE PROCEDURE isSymmetric_1, isSymmetric_2 + + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE isDeviatoric + + MODULE PROCEDURE isDeviatoric_1, isDeviatoric_2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE DoubleDot_Product + + MODULE PROCEDURE DoubleDot_Product1, DoubleDot_Product2, & + DoubleDot_Product3, DoubleDot_Product4,& + DoubleDot_Product5, DoubleDot_Product6 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Invariant_I1 + + MODULE PROCEDURE f_Invariant_I1, m_Invariant_I1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Invariant_I2 + + MODULE PROCEDURE f_Invariant_I2, m_Invariant_I2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Invariant_I3 + + MODULE PROCEDURE f_Invariant_I3, m_Invariant_I3 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Invariant_J2 + + MODULE PROCEDURE f_Invariant_J2, m_Invariant_J2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Invariant_J3 + + MODULE PROCEDURE f_Invariant_J3, m_Invariant_J3 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE LodeAngle + + MODULE PROCEDURE f_LodeAngle_1, f_LodeAngle_2, m_LodeAngle + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE SymmetricPart + + MODULE PROCEDURE f_SymmetricPart, m_SymmetricPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE AntiSymmetricPart + + MODULE PROCEDURE f_AntiSymmetricPart, m_AntiSymmetricPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE HydrostaticPart + + MODULE PROCEDURE f_HydrostaticPart, m_HydrostaticPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE SphericalPart + + MODULE PROCEDURE f_HydrostaticPart, m_HydrostaticPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE DeviatoricPart + + MODULE PROCEDURE f_DeviatoricPart, m_DeviatoricPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Pullback + + MODULE PROCEDURE m_Rank2PullBack_1, m_Rank2PullBack_2, & + f_Rank2PullBack_1, f_Rank2PullBack_2, & + f_VecPullBack_1, f_VecPullBack_2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE PushForward + + MODULE PROCEDURE m_Rank2PushForward_1, m_Rank2PushForward_2, & + f_Rank2PushForward_1, f_Rank2PushForward_2, & + f_VecPushForward_1, f_VecPushForward_2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Tensor_Eigens + + MODULE PROCEDURE m_Eigens_1, m_Eigens_2, f_Eigens_1, f_Eigens_2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Tensor_PrincipalValue + + MODULE PROCEDURE m_PrincipalValue_1, f_PrincipalValue_1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Tensor_SpectralRadius + + MODULE PROCEDURE m_SpectralRadius_1, f_SpectralRadius_1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE PolarDecomposition + + MODULE PROCEDURE m_getPolarDecomp_1, f_getPolarDecomp_1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE RotationPart + + MODULE PROCEDURE f_getRotationPart, m_getRotationPart + + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Tensor_Exp + + MODULE PROCEDURE m_TensorEXP_1, f_TensorEXP_1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 b/src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 new file mode 100755 index 000000000..b6a95242c --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/LeftCauchyGreen/LeftCauchyGreen_Class.F90 @@ -0,0 +1,100 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: LeftCauchyGreen_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Left Cauchy green tensor +!============================================================================== + + MODULE LeftCauchyGreen_Class + USE GlobalData + USE IO + USE Rank2Tensor_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: LeftCauchyGreen_, LeftCauchyGreen, LeftCauchyGreen_Pointer + +!------------------------------------------------------------------------------ +! LeftCauchyGreen_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Rank2Tensor_ ) :: LeftCauchyGreen_ + + END TYPE LeftCauchyGreen_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE LeftCauchyGreen + MODULE PROCEDURE Constructor1 + END INTERFACE + + INTERFACE LeftCauchyGreen_Pointer + MODULE PROCEDURE Constructor_1 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy varialbes + CLASS( LeftCauchyGreen_ ), POINTER :: Constructor_1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + ALLOCATE( Constructor_1 ) + Constructor_1 = F .matmul. (.transpose. F) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy variables + TYPE( LeftCauchyGreen_ ) :: Constructor1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + Constructor1 = F .matmul. (.transpose. F) + + END FUNCTION Constructor1 + + END MODULE LeftCauchyGreen_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part new file mode 100755 index 000000000..b46b380cf --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Display.part @@ -0,0 +1,71 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Display.part +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Material Jacobian class is defined +! HOSTING FILE +! - MaterialJacobian_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Display +!------------------------------------------------------------------------------ + + SUBROUTINE Display( obj, UnitNo ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Display the content +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo + + ! Define internal variables + INTEGER( I4B ) :: I, j + + IF( PRESENT( UnitNo ) ) THEN + I = UnitNo + ELSE + I = 6 + END IF + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL BlankLines( UnitNo = I ) + WRITE( I, "(A)" ) "MaterialJacobian_ object is Empty" + CALL BlankLines( UnitNo = I ) + RETURN + + END IF + + CALL BlankLines( UnitNo = I ) + CALL EqualLine( UnitNo = I ) + WRITE( I, "(12X, A)" ) "|||| Material Jacobian Data ||||" + CALL EqualLine( UnitNo = I ) + CALL BlankLines( UnitNo = I ) + + CALL Display_Array( obj%C, "C" ) + + WRITE( I, "(A)" ) "Stress Type" + CALL obj%StressType%Display( I ) + + WRITE( I, "(A)" ) "Strain Type" + CALL obj%StrainType%Display( I ) + + WRITE( I, "(A)" ) "Rate Type" + CALL obj%RateType%Display( ) + + END SUBROUTINE Display diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part new file mode 100755 index 000000000..33dc00bff --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Initiate.part @@ -0,0 +1,257 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Initiate.part +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - MaterialJacobian class is defined +! HOSTING FILE +! - MaterialJacobian_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getSize +!------------------------------------------------------------------------------ + + INTEGER( I4B ) FUNCTION getSize( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the size of obj%C +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Initiate.part", & + "getSize(), .Size. obj", & + "obj%C is not allocated, Program Stopped!!!"& + ) + + STOP + + END IF + + getSize = SIZE( obj%C, 1 ) + + END FUNCTION getSize + +!------------------------------------------------------------------------------ +! Deallocate +!------------------------------------------------------------------------------ + + SUBROUTINE Deallocate( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Deallocate Data +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + + END SUBROUTINE Deallocate + +!------------------------------------------------------------------------------ +! Initiate1 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate1( obj, N ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the obj%C( N, N ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: N + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + ALLOCATE( obj%C( N, N ) ) + obj%C = 0.0_DFP + + END SUBROUTINE Initiate1 + +!------------------------------------------------------------------------------ +! Initiate2 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate2( obj, N, Fill ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the obj%C( N, N ) with all entries fill +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), INTENT( IN ) :: Fill + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + ALLOCATE( obj%C( N, N ) ) + obj%C = Fill + + END SUBROUTINE Initiate2 + +!------------------------------------------------------------------------------ +! Initiate3 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate3( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the obj%C( :, : ) = Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + obj%C = Mat + + END SUBROUTINE Initiate3 + +!------------------------------------------------------------------------------ +! Initiate4 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate4( obj, N, StressType, StrainType, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of obj%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: N + TYPE( String_ ), INTENT( IN ) :: StressType, StrainType, RateType + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + ALLOCATE( obj%C( N, N ) ) + obj%C = 0.0_DFP + + obj%StressType = StressType + obj%StrainType = StrainType + obj%RateType = RateType + + END SUBROUTINE Initiate4 + +!------------------------------------------------------------------------------ +! Initiate5 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate5( obj, N, StressType, StrainType, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of obj%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: N + CHARACTER( LEN = * ), INTENT( IN ) :: StressType, StrainType, RateType + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + ALLOCATE( obj%C( N, N ) ) + obj%C = 0.0_DFP + + obj%StressType = StressType + obj%StrainType = StrainType + obj%RateType = RateType + + END SUBROUTINE Initiate5 + +!------------------------------------------------------------------------------ +! Initiate6 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate6( obj, N, Names ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of obj%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: N + TYPE( String_ ), INTENT( IN ) :: Names( 3 ) + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + ALLOCATE( obj%C( N, N ) ) + obj%C = 0.0_DFP + + obj%StressType = Names( 1 ) + obj%StrainType = Names( 2 ) + obj%RateType = Names( 3 ) + + END SUBROUTINE Initiate6 + +!------------------------------------------------------------------------------ +! Initiate7 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate7( obj, N, Names ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the obj%C( N, N ) with all entries fill +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: N + CHARACTER( LEN = * ), INTENT( IN ) :: Names( 3 ) + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + ALLOCATE( obj%C( N, N ) ) + obj%C = 0.0_DFP + + obj%StressType = Names( 1 ) + obj%StrainType = Names( 2 ) + obj%RateType = Names( 3 ) + + END SUBROUTINE Initiate7 + +!------------------------------------------------------------------------------ +! Initiate8 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate8( obj, obj2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Copy obj2 into obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj2 + + IF( ALLOCATED( obj%C ) ) DEALLOCATE( obj%C ) + + IF( ALLOCATED( obj2%C ) ) THEN + + obj%C = obj2%C + + END IF + + obj%StressType = obj2%StressType + obj%StrainType = obj2%StrainType + obj%RateType = obj2%RateType + + END SUBROUTINE Initiate8 + + + diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part new file mode 100755 index 000000000..51452ba5c --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian.part @@ -0,0 +1,153 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MaterialJacobian_Pointer.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - MaterialJacobian class is defined +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( N ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor1%C( N, N ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( MaterialJacobian_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: N + + CALL Constructor1%Initiate( N ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( N, Fill ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor2%C( N, N ) with all entries fill +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( MaterialJacobian_ ) :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), INTENT( IN ) :: Fill + + CALL Constructor2%Initiate( N, Fill ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor3%C( :, : ) = Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( MaterialJacobian_ ) :: Constructor3 + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + + CALL Constructor3%Initiate( Mat ) + + END FUNCTION Constructor3 + +!------------------------------------------------------------------------------ +! Constructor4 +!------------------------------------------------------------------------------ + + FUNCTION Constructor4( N, StressType, StrainType, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of Constructor4%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( MaterialJacobian_ ) :: Constructor4 + INTEGER( I4B ), INTENT( IN ) :: N + TYPE( String_ ), INTENT( IN ) :: StressType, StrainType, RateType + + CALL Constructor4%Initiate( N, StressType, StrainType, RateType ) + + END FUNCTION Constructor4 + +!------------------------------------------------------------------------------ +! Constructor5 +!------------------------------------------------------------------------------ + + FUNCTION Constructor5( N, StressType, StrainType, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of Constructor5%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( MaterialJacobian_ ) :: Constructor5 + INTEGER( I4B ), INTENT( IN ) :: N + CHARACTER( LEN = * ), INTENT( IN ) :: StressType, StrainType, RateType + + CALL Constructor5%Initiate( N, StressType, StrainType, RateType ) + + END FUNCTION Constructor5 + +!------------------------------------------------------------------------------ +! Constructor6 +!------------------------------------------------------------------------------ + + FUNCTION Constructor6( N, Names ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of Constructor6%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( MaterialJacobian_ ) :: Constructor6 + INTEGER( I4B ), INTENT( IN ) :: N + TYPE( String_ ), INTENT( IN ) :: Names( 3 ) + + CALL Constructor6%Initiate( N, Names ) + + END FUNCTION Constructor6 + +!------------------------------------------------------------------------------ +! Constructor7 +!------------------------------------------------------------------------------ + + FUNCTION Constructor7( N, Names ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor7%C( N, N ) with all entries fill +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( MaterialJacobian_ ) :: Constructor7 + INTEGER( I4B ), INTENT( IN ) :: N + CHARACTER( LEN = * ), INTENT( IN ) :: Names( 3 ) + + CALL Constructor7%Initiate( N, Names ) + + END FUNCTION Constructor7 + + + diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 new file mode 100755 index 000000000..b8b2ded20 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Class.F90 @@ -0,0 +1,177 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MaterialJacobian_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define MaterialJacobian Class +!============================================================================== + + MODULE MaterialJacobian_Class + USE GlobalData + USE IO + USE String_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: MaterialJacobian_, MaterialJacobian, MaterialJacobian_Pointer + +!------------------------------------------------------------------------------ +! MaterialJacobian_ +!------------------------------------------------------------------------------ + + TYPE :: MaterialJacobian_ +!. . . . . . . . . . . . . . . . . . . . +! Material Jacobian Class +!. . . . . . . . . . . . . . . . . . . . + + REAL( DFP ), ALLOCATABLE :: C( :, : ) + TYPE( String_ ) :: StressType, StrainType, RateType + + CONTAINS + + ! Constructor.part + + PROCEDURE, PUBLIC, PASS( obj ) :: Initiate1, Initiate2, & + Initiate3, Initiate4, Initiate5, Initiate6, & + Initiate7, getSize, Deallocate, Initiate8 + + GENERIC, PUBLIC :: Initiate => Initiate1, Initiate2, & + Initiate3, Initiate4, Initiate5, Initiate6, & + Initiate7, Initiate8 + + GENERIC, PUBLIC :: ASSIGNMENT( = ) => Initiate3, Initiate8 + GENERIC, PUBLIC :: OPERATOR( .SIZE. ) => getSize + + ! Names.part + + PROCEDURE, PUBLIC, PASS( obj ) :: setStressType1, setStressType2,& + setStrainType1, setStrainType2, setRateType1, setRateType2, & + getStressType, getStrainType, getRateType + + GENERIC, PUBLIC :: setStressType => setStressType1, setStressType2 + GENERIC, PUBLIC :: setStrainType => setStrainType1, setStrainType2 + GENERIC, PUBLIC :: setRateType => setRateType1, setRateType2 + + GENERIC, PUBLIC :: OPERATOR( .StressType. ) => getStressType + GENERIC, PUBLIC :: OPERATOR( .StrainType. ) => getStrainType + GENERIC, PUBLIC :: OPERATOR( .RateType. ) => getRateType + + + ! getCijkl.part + + PROCEDURE, PUBLIC, PASS( obj ) :: getCijkl, obj2Mat, & + getCijkl_Pointer, Cijkl_Pointer + + GENERIC, PUBLIC :: ASSIGNMENT( = ) => obj2Mat + + + ! OperatorOverloading/ .Cijkl. + + PROCEDURE, PUBLIC, PASS( obj ) :: Cijkl_1, Cijkl_2, & + Cijkl_4, Cijkl, Cijkl_5 + + GENERIC, PUBLIC :: OPERATOR( .Cijkl. ) => Cijkl_1, Cijkl, & + Cijkl_5 + + GENERIC, PUBLIC :: OPERATOR( .Shape. ) => Cijkl_5 + + ! OperatorOverloading/Contraction + + PROCEDURE, PUBLIC, PASS( obj ) :: Contraction_1, Contraction_2, & + Contraction_3, Contraction_4 + + GENERIC, PUBLIC :: OPERATOR( .Contraction. ) => & + Contraction_1, Contraction_2, Contraction_3, Contraction_4 + + ! OperatorOverloading/Asterics + + PROCEDURE, PUBLIC, PASS( obj ) :: obj_Times_Scalar, Scalar_Times_obj + + GENERIC, PUBLIC :: OPERATOR( * ) => obj_Times_Scalar, & + Scalar_Times_obj + + + ! OperatorOverloading/Matmul + + PROCEDURE, PUBLIC, PASS( obj ) :: obj_Matmul_Vec, Vec_Matmul_obj + + GENERIC, PUBLIC :: OPERATOR( .matmul. ) => obj_Matmul_Vec, & + Vec_Matmul_obj + + + ! OperatorOverloading/Addition + + PROCEDURE, PUBLIC, PASS( obj ) :: obj_Add_obj, obj_Add_Mat, & + Mat_Add_obj, obj_Add_Scalar, Scalar_Add_obj + + GENERIC, PUBLIC :: OPERATOR( + ) => obj_Add_obj, obj_Add_Mat, & + Mat_Add_obj, obj_Add_Scalar, Scalar_Add_obj + + + ! OperatorOverloading/Subtraction + + PROCEDURE, PUBLIC, PASS( obj ) :: obj_Minus_obj, obj_Minus_Mat, & + Mat_Minus_obj, obj_Minus_Scalar, Scalar_Minus_obj + + GENERIC, PUBLIC :: OPERATOR( - ) => obj_Minus_obj, obj_Minus_Mat, & + Mat_Minus_obj, obj_Minus_Scalar, Scalar_Minus_obj + + + ! Display.part + + PROCEDURE, PUBLIC, PASS :: Display + + END TYPE MaterialJacobian_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE MaterialJacobian + MODULE PROCEDURE Constructor1, Constructor2, Constructor3, & + Constructor4, Constructor5, Constructor6, Constructor7 + END INTERFACE + + INTERFACE MaterialJacobian_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3, & + Constructor_4, Constructor_5, Constructor_6, Constructor_7 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + + INCLUDE "./Initiate.part" + INCLUDE "./MaterialJacobian_Pointer.part" + INCLUDE "./MaterialJacobian.part" + INCLUDE "./getCijkl.part" + INCLUDE "./Names.part" + + INCLUDE "./OperatorOverloading/Cijkl.part" + INCLUDE "./OperatorOverloading/Contraction.part" + INCLUDE "./OperatorOverloading/Asterics.part" + INCLUDE "./OperatorOverloading/Matmul.part" + INCLUDE "./OperatorOverloading/Addition.part" + INCLUDE "./OperatorOverloading/Subtraction.part" + + INCLUDE "./Display.part" + + + END MODULE MaterialJacobian_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part new file mode 100755 index 000000000..5febb23e7 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MaterialJacobian_Pointer.part @@ -0,0 +1,160 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MaterialJacobian_Pointer.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - MaterialJacobian class is defined +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( N ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor_1%C( N, N ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: N + + ALLOCATE( Constructor_1 ) + CALL Constructor_1%Initiate( N ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( N, Fill ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor_2%C( N, N ) with all entries fill +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), POINTER :: Constructor_2 + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), INTENT( IN ) :: Fill + + ALLOCATE( Constructor_2 ) + CALL Constructor_2%Initiate( N, Fill ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor_3%C( :, : ) = Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), POINTER :: Constructor_3 + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + + ALLOCATE( Constructor_3 ) + CALL Constructor_3%Initiate( Mat ) + + END FUNCTION Constructor_3 + +!------------------------------------------------------------------------------ +! Constructor_4 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_4( N, StressType, StrainType, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of Constructor_4%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), POINTER :: Constructor_4 + INTEGER( I4B ), INTENT( IN ) :: N + TYPE( String_ ), INTENT( IN ) :: StressType, StrainType, RateType + + ALLOCATE( Constructor_4 ) + CALL Constructor_4%Initiate( N, StressType, StrainType, RateType ) + + END FUNCTION Constructor_4 + +!------------------------------------------------------------------------------ +! Constructor_5 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_5( N, StressType, StrainType, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of Constructor_5%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), POINTER :: Constructor_5 + INTEGER( I4B ), INTENT( IN ) :: N + CHARACTER( LEN = * ), INTENT( IN ) :: StressType, StrainType, RateType + + ALLOCATE( Constructor_5 ) + CALL Constructor_5%Initiate( N, StressType, StrainType, RateType ) + + END FUNCTION Constructor_5 + +!------------------------------------------------------------------------------ +! Constructor_6 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_6( N, Names ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Size of Constructor_6%C is N, with other details +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), POINTER :: Constructor_6 + INTEGER( I4B ), INTENT( IN ) :: N + TYPE( String_ ), INTENT( IN ) :: Names( 3 ) + + ALLOCATE( Constructor_6 ) + CALL Constructor_6%Initiate( N, Names ) + + END FUNCTION Constructor_6 + +!------------------------------------------------------------------------------ +! Constructor_7 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_7( N, Names ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate the Constructor_7%C( N, N ) with all entries fill +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), POINTER :: Constructor_7 + INTEGER( I4B ), INTENT( IN ) :: N + CHARACTER( LEN = * ), INTENT( IN ) :: Names( 3 ) + + ALLOCATE( Constructor_7 ) + CALL Constructor_7%Initiate( N, Names ) + + END FUNCTION Constructor_7 + + + diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md new file mode 100755 index 000000000..274c67a3f --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/MdFiles/MaterialJacobian_Class.md @@ -0,0 +1,230 @@ +# Material Jacobian + +## Structure + +```fortran +TYPE, PUBLIC :: MaterialJacobian_ + REAL( DFP ), ALLOCATABLE :: C( :, : ) + TYPE( String_ ) :: StressType, StrainType, RateType +END TYPE MaterialJacobian_ +``` + +## Description + +`MaterialJacobian_` class is defined as constitutive data. Material jacobian relates the change in flux with the changes in gradient of some field. If the field is scalar then the flux is vector. If the field is vector then the flux is rank-2 tensor. When the material tangent is Rank-4 tensor then we assume that it has atleast minor-symmetery, therefore, we can use Voigt notation for Rank-4 tensor. + +## Getting Started + +### Initiating the `MaterialJacobian_` object + +We can construct the object using the routine called `Initiate()`. + +```fortran +CALL obj%Initiate( N ) +CALL obj%Initiate( N, Fill ) +CALL obj%Initiate( Mat ) +CALL obj%Initiate( N, StressType, StrainType, RateType ) +CALL obj%Initiate( N, [StressType, StrainType, RateType] ) +``` + +We can also initiate the `MaterialJacobian_` using the function called `MaterialJacobian()` or `MaterialJacobian_Pointer()` + +```fortran +obj = MaterialJacobian( N ) +obj = MaterialJacobian( N, Fill ) +obj = MaterialJacobian( Mat ) +obj = MaterialJacobian( N, StressType, StrainType, RateType ) +obj = MaterialJacobian( N, [StressType, StrainType, RateType] ) +``` + +```fortran +obj => MaterialJacobian_Pointer( N ) +obj => MaterialJacobian_Pointer( N, Fill ) +obj => MaterialJacobian_Pointer( Mat ) +obj => MaterialJacobian_Pointer( N, StressType, StrainType, RateType ) +obj => MaterialJacobian_Pointer( N, [StressType, StrainType, RateType] ) +``` + +```fortran +CALL obj%Initiate( N ) +obj = MaterialJacobian( N ) +obj => MaterialJacobian_Pointer( N ) +``` + +The above call allocate `obj%C( N, N )` with all zero entries. + +```fortran +CALL obj%Initiate( N, Fill ) +obj = MaterialJacobian( N, Fill ) +obj => MaterialJacobian_Pointer( N, Fill ) +``` + +The above call allocates `obj%C(N,N)` with all entries equal to `Fill`. + +```fortran +CALL obj%Initiate( Mat ) +obj = MaterialJacobian( Mat ) +obj => MaterialJacobian_Pointer( Mat ) +``` + +The above call allocates `obj%C` with `Mat`. + +```fortran +CALL obj%Initiate( N, StressType, StrainType, RateType ) +obj = MaterialJacobian( N, StressType, StrainType, RateType ) +obj => MaterialJacobian_Pointer( N, StressType, StrainType, RateType ) +``` + +The above call allocates `obj%C` with size `N`. `StressType`, `StrainType`, and `RateType` can be `String_` object or character object. + +```fortran +CALL obj%Initiate( N, [StressType, StrainType, RateType] ) +obj = MaterialJacobian( N, [StressType, StrainType, RateType] ) +obj => MaterialJacobian_Pointer( N, [StressType, StrainType, RateType] ) +``` + +The above call allocates `obj%C` with size `N`. The size-3 rank-1 array can be can be `String_` object or character object. + +### Setting the value of Names + +We can set the values of `obj%StressType` `obj%StrainType`, and `obj%RateType` using the subroutine. + +```Fortran +CALL obj%setStressType( StressType ) +CALL obj%setStrainType( StrainType ) +CALL obj%setRateType( RateType ) +``` + +>The argument can be `Character` type or `String_` type. + +### Getting the values of Names + +```fortran +StressType = .StressType. obj +StrainType = .StrainType. obj +RateType = .RateType. obj +``` + +### Geting the values of `obj%C` + +We can get the size of `obj%C` using the operator called `.SIZE.` and we can deallocate the data using the routine called `obj%Deallocate()`. + +We can access the values using both subroutines and functions. + +Subroutines to access the hardcopy and pointer to `obj%C` are given below. + +```fortran +CALL obj%getCijkl( Mat ) +CALL obj%getCijkl_Pointer( Mat ) +``` + +Functions to access the hardcopy and pointer to `obj%C` are given below. + +```fortran +Mat => obj%Cijkl_Pointer( ) +Mat = obj +``` + +The Operator `.Cijkl.` and `.At.` can also be used to access the hardcopies of Cijkl. + +```fortran +Mat = .Cijkl. obj +Mat = obj .Cijkl. [Indx1, Indx2] +Mat = obj .Cijkl. [i,j,k,l] +``` + +```fortran +CALL obj%getCijkl( Mat ) +Mat = obj +``` + +The above call reallocates `Mat` with the `obj%C`. + +```fortran +CALL obj%getCijkl_Pointer( Mat ) +Mat => obj%Cijkl_Pointer( ) +``` + +The above call returns the Pointer to the `obj%C`. + +```fortran +Mat = .Cijkl. obj +``` + +The above call will return the `obj%C` hardcopy. + +```fortran +Mat = obj .Cijkl. [Indx1, Indx2] +``` + +The above call will return the `obj%C( i,j)` + +```fortran +Mat = obj .Cijkl. [i,j,k,l] +``` + +The above call will return the `C(i,j,k,l)`. In this case `[i,j,k,l]` are convered into voigt index then value of `obj%C` correspoding to those voigt-indices are returned. + +There is another interesting way to use `.Cijkl.`. Suppose you want to obtain 6 by 6 jacobian matrix then we can call `obj .Cijkl. 6`. In this case, even if `obj%C` is not 6 by 6 we will get 6 by 6 form. + +```fortran +C = obj .Cijkl. 6 +C = obj .Cijkl. 4 +C = obj .Cijkl. 3 +C = obj .Cijkl. 2 +C = obj .Cijkl. 1 +``` + +Alternatively you can also use `obj .Shape. 6` or `obj .Shape. M` for getting the M by M matrix. + +### Assignment Operator (=) + +```fortran +obj = Mat +Mat = obj +obj = obj2 +``` + +### Contraction Operator + +Contraction of Material Jacobian with the Tensor and matrix is defined. It will return a 3 by 3 matrix. If you want to convert it into voigt vector then use `VoigtVec()` function from the `Voigt` module. + +```fortran +Mat = obj .Contraction. Rank2Tensorobj +Mat = Rank2Tensorobj .Contraction. obj +Mat = obj .Contraction. Mat +Mat = Mat .Contraction. obj +``` + +### Matmul Operator + +Matmul operator is defined so that we can operate `MaterialJacobian_` object directly with the `VoigtVec`. Using `matmul` operator we can do matrix multiplication of obj with voigt vector. + +```fortran +Vec = obj .matmul. Vec +Vec = Vec .matmul. obj +``` + +### Addition Operator + +We have defined the addition operator for material jacobian class. We can add `obj + obj` `obj + Mat` `obj +Scalar`. Note that in first two cases the shape should be compatible. Suppose if the shapes are not identical then we can use `obj .Cijkl. N + obj .Cijkl. N`. A Rank-2 fortran array is returned. + +```fortran +Mat = obj + obj +Mat = obj + Mat +Mat = Mat + obj +Mat = obj + Scalar +Mat = Scalar + obj +``` + +### Subtraction Operator + +```fortran +Mat = obj - obj +Mat = obj - Mat +Mat = Mat - obj +Mat = obj - Scalar +Mat = Scalar - obj +``` + +### Asterics Operator \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part new file mode 100755 index 000000000..6eb636600 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/Names.part @@ -0,0 +1,174 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Names.part +! Last Update : Jan-01-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Methods to access the obj%stressType obj%StrainType +! obj%RateType +! HOSTING FILE +! - MaterialJacobian_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! setStressType1 +!------------------------------------------------------------------------------ + + SUBROUTINE setStressType1( obj, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. set the obj%StressType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + obj%StressType = StressType + + END SUBROUTINE setStressType1 + +!------------------------------------------------------------------------------ +! setStressType2 +!------------------------------------------------------------------------------ + + SUBROUTINE setStressType2( obj, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. set the obj%StressType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + TYPE( String_ ), INTENT( IN ) :: StressType + + obj%StressType = StressType + + END SUBROUTINE setStressType2 + +!------------------------------------------------------------------------------ +! setStrainType1 +!------------------------------------------------------------------------------ + + SUBROUTINE setStrainType1( obj, StrainType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. set the obj%StrainType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: StrainType + + obj%StrainType = StrainType + + END SUBROUTINE setStrainType1 + +!------------------------------------------------------------------------------ +! setStrainType2 +!------------------------------------------------------------------------------ + + SUBROUTINE setStrainType2( obj, StrainType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. set the obj%StrainType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + TYPE( String_ ), INTENT( IN ) :: StrainType + + obj%StrainType = StrainType + + END SUBROUTINE setStrainType2 + +!------------------------------------------------------------------------------ +! setRateType1 +!------------------------------------------------------------------------------ + + SUBROUTINE setRateType1( obj, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. set the obj%RateType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: RateType + + obj%RateType = RateType + + END SUBROUTINE setRateType1 + +!------------------------------------------------------------------------------ +! setRateType2 +!------------------------------------------------------------------------------ + + SUBROUTINE setRateType2( obj, RateType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. set the obj%RateType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( INOUT ) :: obj + TYPE( String_ ), INTENT( IN ) :: RateType + + obj%RateType = RateType + + END SUBROUTINE setRateType2 + +!------------------------------------------------------------------------------ +! getStressType +!------------------------------------------------------------------------------ + + FUNCTION getStressType( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. get the obj%StressType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + TYPE( String_ ) :: getStressType + + getStressType = obj%StressType + + END FUNCTION getStressType + +!------------------------------------------------------------------------------ +! getStrainType +!------------------------------------------------------------------------------ + + FUNCTION getStrainType( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. get the obj%StrainType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + TYPE( String_ ) :: getStrainType + + getStrainType = obj%StrainType + + END FUNCTION getStrainType + +!------------------------------------------------------------------------------ +! getRateType +!------------------------------------------------------------------------------ + + FUNCTION getRateType( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. get the obj%RateType +!. . . . . . . . . . . . . . . . . . . . + + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + TYPE( String_ ) :: getRateType + + getRateType = obj%RateType + + END FUNCTION getRateType \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part new file mode 100755 index 000000000..f8d1d1606 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Addition.part @@ -0,0 +1,193 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Addition.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Addition Operator is defined +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_obj( obj, obj2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj2 + REAL( DFP ), ALLOCATABLE :: obj_Add_obj( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: N1, N2 + + IF( .NOT. ALLOCATED( obj%C ) & + .OR. .NOT. ALLOCATED( obj2%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Addition.part", & + "obj + obj2", & + "obj or obj2 is/are not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N1 = .SIZE. obj + N2 = .SIZE. obj2 + + IF( N1 .NE. N2 ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Addition.part", & + "obj + obj2", & + "The Shape of obj%C and obj2%C are not Compatible, & + Program Stopped!!!"& + ) + STOP + + END IF + + ALLOCATE( obj_Add_obj( N1, N1 ) ) + + obj_Add_obj = obj%C + obj2%C + + END FUNCTION obj_Add_obj + +!------------------------------------------------------------------------------ +! obj_Add_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_Mat( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), ALLOCATABLE :: obj_Add_Mat( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: N1, N2 + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Addition.part", & + "obj + Mat", & + "obj is not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N1 = .SIZE. obj + N2 = SIZE( Mat, 1 ) + + IF( N1 .NE. N2 ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Addition.part", & + "obj + Mat", & + "The Shape of obj%C and Mat are not Compatible, & + Program Stopped!!!"& + ) + STOP + + END IF + + ALLOCATE( obj_Add_Mat( N1, N1 ) ) + + obj_Add_Mat = obj%C + Mat + + END FUNCTION obj_Add_Mat + +!------------------------------------------------------------------------------ +! Mat_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_Add_obj( Mat, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat + obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), ALLOCATABLE :: Mat_Add_obj( :, : ) + + Mat_Add_obj = obj_Add_Mat( obj, Mat ) + + END FUNCTION Mat_Add_obj + +!------------------------------------------------------------------------------ +! obj_Add_Scalar +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_Scalar( obj, Scalar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Scalar +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), ALLOCATABLE :: obj_Add_Scalar( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Addition.part", & + "obj + Mat", & + "obj is not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N = .SIZE. obj + ALLOCATE( obj_Add_Scalar( N, N ) ) + obj_Add_Scalar = obj%C + Scalar + + END FUNCTION obj_Add_Scalar + +!------------------------------------------------------------------------------ +! Scalar_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION Scalar_Add_obj( Scalar, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Scalar + obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), ALLOCATABLE :: Scalar_Add_obj( :, : ) + + Scalar_Add_obj = obj_Add_Scalar( obj, Scalar ) + + END FUNCTION Scalar_Add_obj \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part new file mode 100755 index 000000000..25b191038 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Asterics.part @@ -0,0 +1,75 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Asterics.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Asterics Operator is defined for Material Jacobian and +! tensor +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_Times_Scalar +!------------------------------------------------------------------------------ + + FUNCTION obj_Times_Scalar( obj, Scalar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Contraction. Tensor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), ALLOCATABLE :: obj_Times_Scalar( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Asterics.part", & + "obj * Scalar", & + "obj is not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N = .SIZE. obj + ALLOCATE( obj_Times_Scalar( N, N ) ) + obj_Times_Scalar = obj%C * Scalar + + END FUNCTION obj_Times_Scalar + +!------------------------------------------------------------------------------ +! Scalar_Times_obj +!------------------------------------------------------------------------------ + + FUNCTION Scalar_Times_obj( Scalar, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Contraction. Tensor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), ALLOCATABLE :: Scalar_Times_obj( :, : ) + + Scalar_Times_obj = obj_Times_Scalar( obj, Scalar ) + + END FUNCTION Scalar_Times_obj + diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part new file mode 100755 index 000000000..5ddfabde6 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Cijkl.part @@ -0,0 +1,424 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Cijkl.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Operators to access the obj%C are defined +! - .Cijkl. +! - .AT. +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! Cijkl_1 +!------------------------------------------------------------------------------ + + FUNCTION Cijkl_1( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Operator .Cijkl. , Mat = .Cijkl. obj returns obj%C +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE :: Cijkl_1( :, : ) + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " .Cijkl. obj", & + "obj%C is not allocated, Program Stopped!!!"& + ) + + STOP + + END IF + + IF( ALLOCATED( Cijkl_1 ) ) DEALLOCATE( Cijkl_1 ) + Cijkl_1 = obj%C + + END FUNCTION Cijkl_1 + +!------------------------------------------------------------------------------ +! Cijkl_2 +!------------------------------------------------------------------------------ + + FUNCTION Cijkl_2( obj, Indx ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Indx( 2 ) + REAL( DFP ) :: Cijkl_2 + + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " obj .Cijkl. Index", & + "obj%C is not allocated, Program Stopped!!!"& + ) + + STOP + + END IF + + N = .SIZE. obj + + IF( ANY( Indx .GT. N ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " obj .Cijkl. Index", & + "Indx is out of bound, Program Stopped!!!"& + ) + + STOP + + END IF + + Cijkl_2 = obj%C( Indx( 1 ), Indx( 2 ) ) + + END FUNCTION Cijkl_2 + +!------------------------------------------------------------------------------ +! Cijkl_4 +!------------------------------------------------------------------------------ + + FUNCTION Cijkl_4( obj, Indx ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) +!. . . . . . . . . . . . . . . . . . . . + + USE Voigt + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Indx( 4 ) + REAL( DFP ) :: Cijkl_4 + + INTEGER( I4B ) :: NSD, N, i, j, k, l + INTEGER( I4B ), ALLOCATABLE :: IndxMat( :, : ) + REAL( DFP ), ALLOCATABLE :: C( :, : ) + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " obj .Cijkl. Index", & + "obj%C is not allocated, Program Stopped!!!"& + ) + + STOP + + END IF + + N = .SIZE. obj + + NSD = 3 + + IF( ANY( Indx .GT. NSD ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " obj .Cijkl. Index", & + "Indx should be less than NSD = 3, Program Stopped!!!"& + ) + + STOP + + END IF + + ALLOCATE( IndxMat( NSD, NSD ) ) + + IndxMat( 1, 1 ) = 1 + IndxMat( 2, 2 ) = 2 + IndxMat( 3, 3 ) = 3 + IndxMat( 1, 2 ) = 4 + IndxMat( 2, 1 ) = 4 + IndxMat( 2, 3 ) = 5 + IndxMat( 3, 2 ) = 5 + IndxMat( 1, 3 ) = 6 + IndxMat( 3, 1 ) = 6 + + i = Indx( 1 ) + j = Indx( 2 ) + k = Indx( 3 ) + l = Indx( 4 ) + + SELECT CASE( N ) + + CASE( 6 ) + + Cijkl_4 = obj%C( IndxMat( i, j ), IndxMat( k, l ) ) + + CASE( 4 ) + + C = Mat6_From_Mat4( obj%C ) + Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) + + CASE( 3 ) + + C = Mat6_From_Mat3( obj%C ) + Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) + + CASE( 2 ) + + C = Mat6_From_Mat2( obj%C ) + Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) + + + CASE( 1 ) + C = Mat6_From_Mat1( obj%C ) + Cijkl_4 = C( IndxMat( i, j ), IndxMat( k, l ) ) + + CASE DEFAULT + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " obj .Cijkl. Index", & + "No Case Found for shape of Stored obj%C, Program Stopped!!!"& + ) + STOP + + END SELECT + + + IF( ALLOCATED( C ) ) DEALLOCATE( C ) + IF( ALLOCATED( IndxMat ) ) DEALLOCATE( IndxMat ) + + END FUNCTION Cijkl_4 + +!------------------------------------------------------------------------------ +! Cijkl +!------------------------------------------------------------------------------ + + FUNCTION Cijkl( obj, Indx ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Indx( : ) + REAL( DFP ) :: Cijkl + + SELECT CASE( SIZE( Indx ) ) + + CASE( 2 ) + + Cijkl = Cijkl_2( obj, Indx ) + + CASE( 4 ) + + Cijkl = Cijkl_4( obj, Indx ) + + CASE DEFAULT + + Cijkl = 0.0_DFP + + END SELECT + + END FUNCTION Cijkl + +!------------------------------------------------------------------------------ +! Cijkl_5 +!------------------------------------------------------------------------------ + + FUNCTION Cijkl_5( obj, M ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Cijkl. Indx, Returns obj%C( Indx( 1 ), obj%C( Indx( 2 )) ) +!. . . . . . . . . . . . . . . . . . . . + + USE Voigt + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: M + REAL( DFP ) :: Cijkl_5( M , M ) + + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " obj .Cijkl. Index", & + "obj%C is not allocated, Program Stopped!!!"& + ) + + STOP + + END IF + + N = .SIZE. obj + + SELECT CASE( N ) + + CASE( 6 ) + + SELECT CASE( M ) + + CASE( 6 ) + + Cijkl_5 = obj%C + + CASE( 4 ) + + Cijkl_5 = Mat4_From_Mat6( obj%C ) + + CASE( 3 ) + + Cijkl_5 = Mat3_From_Mat6( obj%C ) + + CASE( 2 ) + + Cijkl_5 = Mat2_From_Mat6( obj%C ) + + CASE( 1 ) + + Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) + + + END SELECT + + CASE( 4 ) + + SELECT CASE( M ) + + CASE( 6 ) + + Cijkl_5 = Mat6_From_Mat4( obj%C ) + + CASE( 4 ) + + Cijkl_5 = obj%C + + CASE( 3 ) + + Cijkl_5 = Mat3_From_Mat4( obj%C ) + + CASE( 2 ) + + Cijkl_5 = Mat2_From_Mat4( obj%C ) + + CASE( 1 ) + + Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) + + + END SELECT + + CASE( 3 ) + + SELECT CASE( M ) + + CASE( 6 ) + + Cijkl_5 = Mat6_From_Mat3( obj%C ) + + CASE( 4 ) + + Cijkl_5 = Mat4_From_Mat3( obj%C ) + + CASE( 3 ) + + Cijkl_5 = obj%C + + CASE( 2 ) + + Cijkl_5 = Mat2_From_Mat3( obj%C ) + + CASE( 1 ) + + Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) + + + END SELECT + + CASE( 2 ) + + SELECT CASE( M ) + + CASE( 6 ) + + Cijkl_5 = Mat6_From_Mat2( obj%C ) + + CASE( 4 ) + + Cijkl_5 = Mat4_From_Mat2( obj%C ) + + CASE( 3 ) + + Cijkl_5 = Mat3_From_Mat2( obj%C ) + + CASE( 2 ) + + Cijkl_5 = obj%C + + CASE( 1 ) + + Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) + + + END SELECT + + CASE( 1 ) + + SELECT CASE( M ) + + CASE( 6 ) + + Cijkl_5 = Mat6_From_Mat1( obj%C ) + + CASE( 4 ) + + Cijkl_5 = Mat4_From_Mat1( obj%C ) + + CASE( 3 ) + + Cijkl_5 = Mat3_From_Mat1( obj%C ) + + CASE( 2 ) + + Cijkl_5 = Mat2_From_Mat1( obj%C ) + + CASE( 1 ) + + Cijkl_5( 1, 1 ) = obj%C( 1, 1 ) + + + END SELECT + + CASE DEFAULT + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>OperatorOverloading/Cijkl.part", & + " obj .Cijkl. Index", & + "No Case Found for shape of Stored obj%C, Program Stopped!!!"& + ) + STOP + + END SELECT + + END FUNCTION Cijkl_5 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part new file mode 100755 index 000000000..5583aff19 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Contraction.part @@ -0,0 +1,130 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Contraction.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Contraction Operator is defined for Material Jacobian and +! tensor +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! Contraction_1 +!------------------------------------------------------------------------------ + + FUNCTION Contraction_1( obj, Tensorobj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Contraction. Tensor +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE Voigt + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ) :: Contraction_1( 3, 3 ) + + ! Define intent of dummy variables + REAL( DFP ), ALLOCATABLE :: Vec( : ) + + CALL Tensorobj%getTensor( Vec, "Strain" ) + Vec = MATMUL( obj .Cijkl. SIZE(Vec), Vec ) + Contraction_1 = MatFromVoigtVec( Vec, "Stress" ) + DEALLOCATE( Vec ) + + END FUNCTION Contraction_1 + +!------------------------------------------------------------------------------ +! Contraction_2 +!------------------------------------------------------------------------------ + + FUNCTION Contraction_2( Tensorobj, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Tensor .Contraction. obj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE Voigt + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ) :: Contraction_2( 3, 3 ) + + ! Define intent of dummy variables + REAL( DFP ), ALLOCATABLE :: Vec( : ) + + CALL Tensorobj%getTensor( Vec, "Strain" ) + Vec = MATMUL( TRANSPOSE( obj .Cijkl. SIZE( Vec ) ), Vec ) + Contraction_2 = MatFromVoigtVec( Vec, "Stress" ) + DEALLOCATE( Vec ) + + END FUNCTION Contraction_2 + +!------------------------------------------------------------------------------ +! Contraction_3 +!------------------------------------------------------------------------------ + + FUNCTION Contraction_3( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Contraction. Mat +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE Voigt + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ) :: Contraction_3( 3, 3 ) + + ! Define intent of dummy variables + TYPE( Rank2Tensor_ ) :: Tensorobj + + Tensorobj = Mat + Contraction_3 = Contraction_1( obj, Tensorobj ) + CALL Tensorobj%Deallocate( ) + + END FUNCTION Contraction_3 + +!------------------------------------------------------------------------------ +! Contraction_4 +!------------------------------------------------------------------------------ + + FUNCTION Contraction_4( Mat, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat .Contraction. obj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE Voigt + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ) :: Contraction_4( 3, 3 ) + + ! Define intent of dummy variables + TYPE( Rank2Tensor_ ) :: Tensorobj + + Tensorobj = Mat + Contraction_4 = Contraction_2( Tensorobj, obj ) + CALL Tensorobj%Deallocate( ) + + END FUNCTION Contraction_4 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part new file mode 100755 index 000000000..fe56704b4 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Matmul.part @@ -0,0 +1,91 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Matmul.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - matmul Operator is defined for defining matrix multiplication +! of Material Jacobian and voigt vector. +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_matmul_Vec +!------------------------------------------------------------------------------ + + FUNCTION obj_matmul_Vec( obj, Vec ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .matmul. Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Vec( : ) + REAL( DFP ), ALLOCATABLE :: obj_matmul_Vec( : ) + + ! Define internal variables + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>matmul.part", & + "obj .matmul. Vec", & + "obj is not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N = SIZE( Vec ) + ALLOCATE( obj_matmul_Vec( N ) ) + obj_matmul_Vec = MATMUL( obj .Cijkl. N, Vec ) + + END FUNCTION obj_matmul_Vec + +!------------------------------------------------------------------------------ +! Vec_matmul_obj +!------------------------------------------------------------------------------ + + FUNCTION Vec_matmul_obj( Vec, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Vec .matmul. obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Vec( : ) + REAL( DFP ), ALLOCATABLE :: Vec_matmul_obj( : ) + + ! Define internal variables + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>matmul.part", & + "obj .matmul. Vec", & + "obj is not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N = SIZE( Vec ) + ALLOCATE( Vec_matmul_obj( N ) ) + + Vec_matmul_obj = MATMUL( TRANSPOSE( obj .Cijkl. N ), Vec ) + + END FUNCTION Vec_matmul_obj diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part new file mode 100755 index 000000000..a27579299 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/OperatorOverloading/Subtraction.part @@ -0,0 +1,193 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Subtraction.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Subtraction Operator is defined +! HOSTING FILE +! - MaterialJacobian_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_obj( obj, obj2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj - obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj2 + REAL( DFP ), ALLOCATABLE :: obj_Minus_obj( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: N1, N2 + + IF( .NOT. ALLOCATED( obj%C ) & + .OR. .NOT. ALLOCATED( obj2%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Subtraction.part", & + "obj - obj2", & + "obj or obj2 is/are not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N1 = .SIZE. obj + N2 = .SIZE. obj2 + + IF( N1 .NE. N2 ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Subtraction.part", & + "obj - obj2", & + "The Shape of obj%C and obj2%C are not Compatible, & + Program Stopped!!!"& + ) + STOP + + END IF + + ALLOCATE( obj_Minus_obj( N1, N1 ) ) + + obj_Minus_obj = obj%C - obj2%C + + END FUNCTION obj_Minus_obj + +!------------------------------------------------------------------------------ +! obj_Minus_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_Mat( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj - Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), ALLOCATABLE :: obj_Minus_Mat( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: N1, N2 + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Subtraction.part", & + "obj - Mat", & + "obj is not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N1 = .SIZE. obj + N2 = SIZE( Mat, 1 ) + + IF( N1 .NE. N2 ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Subtraction.part", & + "obj - Mat", & + "The Shape of obj%C and Mat are not Compatible, & + Program Stopped!!!"& + ) + STOP + + END IF + + ALLOCATE( obj_Minus_Mat( N1, N1 ) ) + + obj_Minus_Mat = obj%C - Mat + + END FUNCTION obj_Minus_Mat + +!------------------------------------------------------------------------------ +! Mat_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_Minus_obj( Mat, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat - obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + REAL( DFP ), ALLOCATABLE :: Mat_Minus_obj( :, : ) + + Mat_Minus_obj = -obj_Minus_Mat( obj, Mat ) + + END FUNCTION Mat_Minus_obj + +!------------------------------------------------------------------------------ +! obj_Minus_Scalar +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_Scalar( obj, Scalar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj - Scalar +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), ALLOCATABLE :: obj_Minus_Scalar( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>Subtraction.part", & + "obj - Mat", & + "obj is not initiated, Program Stopped!!!"& + ) + STOP + + END IF + + N = .SIZE. obj + ALLOCATE( obj_Minus_Scalar( N, N ) ) + obj_Minus_Scalar = obj%C - Scalar + + END FUNCTION obj_Minus_Scalar + +!------------------------------------------------------------------------------ +! Scalar_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION Scalar_Minus_obj( Scalar, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Scalar - obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), ALLOCATABLE :: Scalar_Minus_obj( :, : ) + + Scalar_Minus_obj = -obj_Minus_Scalar( obj, Scalar ) + + END FUNCTION Scalar_Minus_obj \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part new file mode 100755 index 000000000..cd42bafe1 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MaterialJacobian/getCijkl.part @@ -0,0 +1,146 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: getCijkl.part +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Methods to access the obj%C +! HOSTING FILE +! - MaterialJacobian_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getCijkl +!------------------------------------------------------------------------------ + + SUBROUTINE getCijkl( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Reallcoate Mat with obj%C +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: Mat( :, : ) + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>getCijkl.part", & + "getCijkl(obj, Mat)", & + "obj%C is not allocated."& + ) + + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED( Mat ) ) DEALLOCATE( Mat ) + Mat = obj%C + + END SUBROUTINE getCijkl + +!------------------------------------------------------------------------------ +! getCijkl_Pointer +!------------------------------------------------------------------------------ + + SUBROUTINE getCijkl_Pointer( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat => obj%C, Returns pointer to obj%C +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ), TARGET :: obj + REAL( DFP ), POINTER, INTENT( OUT ) :: Mat( :, : ) + + Error_Flag = .FALSE. + + IF( ASSOCIATED( Mat ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>getCijkl_Pointer.part", & + "getCijkl_Pointer(obj, Mat)", & + "Mat is already associated, Nullify first."& + ) + + Error_Flag = .TRUE. + RETURN + + END IF + + IF( .NOT. ALLOCATED( obj%C ) ) THEN + + CALL Err_Msg( & + "MaterialJacobian_Class.F90>>getCijkl_Pointer.part", & + "getCijkl_Pointer(obj, Mat)", & + "obj%C is not allocated."& + ) + + Error_Flag = .TRUE. + RETURN + + END IF + + Mat => obj%C + + END SUBROUTINE getCijkl_Pointer + +!------------------------------------------------------------------------------ +! Cijkl_Pointer +!------------------------------------------------------------------------------ + + FUNCTION Cijkl_Pointer( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Cijkl_Pointer => obj%C, Function Returns pointer to obj%C +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ), TARGET :: obj + REAL( DFP ), POINTER :: Cijkl_Pointer( :, : ) + + Cijkl_Pointer => NULL( ) + + CALL obj%getCijkl_Pointer( Cijkl_Pointer ) + CALL Check_Error( & + "MaterialJacobian_Class.F90>>getCijkl.part>> Mat => obj%Cijkl_Pointer()", & + "Traceback ---> CALL obj%getCijkl_Pointer( Cijkl_Pointer )"& + ) + + END FUNCTION Cijkl_Pointer + +!------------------------------------------------------------------------------ +! obj2Mat +!------------------------------------------------------------------------------ + + SUBROUTINE obj2Mat( Mat, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat = obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( MaterialJacobian_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: Mat( :, : ) + + CALL obj%getCijkl( Mat ) + CALL Check_Error( & + "MaterialJacobian_Class.F90>>getCijkl.part>> Mat = obj", & + "Traceback ---> CALL obj%getCijkl( Mat )"& + ) + + END SUBROUTINE obj2Mat \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md b/src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md new file mode 100755 index 000000000..1f6e6f7f6 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/MdFiles/Tensor_Class.md @@ -0,0 +1,2288 @@ +# Rank2Tensor Class is defined + +## Notice + +On 13-July-2018, when I tried to compile this module using ifort then there was an error related to .matmul. I think it is due to the fact that this operator was defined as an method as well as the module generic operator. So I have removed it as a method, and i have kept it only as module generic operator. + + +## ToDO + +-Extend to `VelocityGradient_` +-Extend to `RightCauchyGreen_` +-Extend to `LeftCauchyGreen_` +-Extend to `StrainRate_` +-Extend to `SpinTensor_` +-Extend to `ContinuumSpin_` +-Extend to `MaterialJacobian_` a Rank-4 tensor but in Voigt form +-Add methods for getting derivative of invariants and Tensor. +-Add methods for Convective Rates +-Add methods so that T = Mat2 +-Add EigenProjection methods. +-Add robust tensor-exponentatial function. +-Add method for getting the isochoric and volumetric part + +## Structure + +```fortran + TYPE, PUBLIC :: Tensor_ + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: T + INTEGER( I4B ) :: NSD +``` + +## Description + +`NSD` stands for number of spatial dimension. Rank2Tensor `T` is always (3,3), but NSD helps us to identify which components are meaningful. + +## Getting Started + +### Initiating the `Tensor_` object + +The subroutine `Initiate()` can be used to create the `Tensor_` class. + +```fortran +CALL obj%Initiate( ) +CALL obj%Initiate( Mat2( :, : ) ) +CALL obj%Initiate( Scalar ) +CALL obj%Initiate( VoigtVec, VoigtType ) +CALL obj%Initiate( obj2 ) +``` + +In addition we can use the function `Rank2Tensor()` which returns the `Rank2Tensor_` type. + +```fortran +obj = Rank2Tensor( ) +obj = Rank2Tensor( Mat2 ) +obj = Rank2Tensor( Scalar ) +obj = Rank2Tensor( VoigtVec, VoigtType ) +obj = Rank2Tensor( obj2 ) +``` + +We have also defined function `Rank2Tensor_Pointer()` that returns the pointer to the `Rank2Tensor_` pointer. + +```fortran +obj => Rank2Tensor_Pointer( ) +obj => Rank2Tensor_Pointer( Mat2 ) +obj => Rank2Tensor_Pointer( Scalar ) +obj => Rank2Tensor_Pointer( VoigtVec, VoigtType ) +obj => Rank2Tensor_Pointer( obj2 ) +``` + +We can also use `Assignment Operator( = )` + +```fortran +obj = Mat2( :, : ) +``` + +```fortran +CALL obj%Initiate( ) +obj = Rank2Tensor( ) +obj => Rank2Tensor_Pointer( ) +``` + +The above call will create the `Tensor_` object with all zero entries and NSD = 3. + +```fortran +CALL obj%Initiate( Mat2 ) +obj = Rank2Tensor( Mat2 ) +obj => Rank2Tensor_Pointer( Mat2 ) +``` + +The above call will create the `Tensor_` object. Depending upon the size of `Mat2(:,:)` NSD is decided. + +```fortran +CALL obj%Initiate( Scalar ) +obj = Rank2Tensor( Scalar ) +obj => Rank2Tensor_Pointer( Scalar ) +``` + +The above call will fill all entries with the scalar, and `NSD` will be set to 3. + +```fortran +CALL obj%Initiate( VoigtVec, VoigtType ) +obj = Rank2Tensor( VoigtVec, VoigtType ) +obj => Rank2Tensor_Pointer( VoigtVec, VoigtType ) +``` + +The above call will make tensor object from the voigt vector. `VoigtType` can be `Stress` or `Strain`. + +```fortran +CALL obj%Initiate( obj2 ) +obj = Rank2Tensor( obj2 ) +obj => Rank2Tensor_Pointer( obj2 ) +``` + +The above call will make tensor object from other tensor object. + +### Checking the status and deallocating the data + +```fortran +CALL obj%isInitiated( ) +CALL obj%Deallocate( ) +``` + +### Setting and getting the NSD + +```fortran +NSD = obj%getNSD( ) +NSD = .NSD. obj +CALL obj%setNSD( NSD ) +``` + +### Getting the tensor + +We can get the Tensor in a matrix as well as voigt vector. To get tensor in voigt vector we need to call `getTensor()` + +```fortran +CALL obj%getTensor( Mat ) +CALL obj%getTensor( VoigtVec, VoigtType ) +``` + +Both `Mat` and `VoigtVec` must be allocatable as they are reallocated by the method. + +We can use assignment operator. + +```fortran +Mat = obj +``` + +### Logical Functions for Tensor + +We have defined the function `isSymmetric()` and `isDeviatoric()` + +```fortran +L = isSymmetric( obj ) +L = isSymmetric( Mat2 ) +L = isDeviatoric( obj ) +L = isDeviatoric( Mat2 ) +``` + +### Invariants + +**Trace Of Tensor or Matrix** + +```fortran +t = Trace( obj ) +t = Trace( Mat ) +t = .Trace. obj +t = .Trace. Mat +``` + +**Contraction of Tensors** + +```fortran +s = DoubleDot_Product( obj, obj2 ) +s = DoubleDot_Product( obj, Mat ) +s = DoubleDot_Product( obj, VoigtVec, VoigtType ) +s = DoubleDot_Product( A, B ) +s = DoubleDot_Product( A, VoigtType_A, B, VoigtType_B ) +s = DoubleDot_Product( Mat, VoigtVec, VoigtType ) +``` + +We also defined the `DoubleDot` operator. This operator works only on matrices and Rank2Tensor_ objects. + +```fortran +s = obj .doubledot. obj +s = obj .doubledot. mat +s = mat .doubledot. obj +s = mat .doubledot. mat +``` + +**Invariant_I1** + +$$I_1 = Trace( T ) $$ + +```fortran +I1 = Invarinant_I1( obj ) +I1 = Invarinant_I1( Mat ) +``` + +**Invariant_I2** + +`I2 = 0.5( ( Tr( T )**2 - Tr( T*T ) ) )` + +```fortran +I2 = Invarinant_I2( obj ) +I2 = Invarinant_I2( Mat ) +``` + +**Invariant_I3** + +`I3 = det( Tensor )` + +```fortran +I3 = Invarinant_I3( obj ) +I3 = Invarinant_I3( Mat ) +``` + +**Invariant_J2** + +`I2 = 0.5 * Dev( T ): Dev( T )` + +```fortran +J2 = Invarinant_J2( obj ) +J2 = Invarinant_J2( Mat ) +``` + +**Invariant_J3** + +`J3 = det( Dev( T ) )` + +```fortran +J3 = Invarinant_J3( obj ) +J3 = Invarinant_J3( Mat ) +``` + +**LodeAngle** + + +```fortran +theta = LodeAngle( J2, J3, LodeAngleType ) +theta = LodeAngle( obj, LodeAngleType ) +theta = LodeAngle( Mat, LodeAngleType ) +``` + +`LodeAngleType` can be `Sine` or `Cosine`. + + +### Tensor Decomposition + +**Getting Symmetric and Skew Symmetric Part** + +```fortran +Dummy = SymmetricPart( obj ) +Dummy = SymmetricPart( Mat ) +Dummy = AntiSymmetricPart( obj ) +Dummy = AntiSymmetricPart( Mat ) +``` + +We can also use the operator `.Sym.` and `.Anti.` + +```fortran +Dummy = .Sym. obj +Dummy = .Sym. Mat +Dummy = .Anti. obj +Dummy = .Anti. Mat +``` + +**getting the Hydrostatic Part** + +`Trace( T ) / 3` + +```fortran +Dummy = HydrostaticPart( obj ) +Dummy = HydrostaticPart( Mat ) +Dummy = SphericalPart( obj ) +Dummy = Spherical( Mat ) +``` + +We can also use `.Hydro.` operator. + +```fortran +Dummy = .Hydro. obj +Dummy = .Hydro. Mat +``` + +**Getting the Deviatoric Part** + +```fortran +Dummy = DeviatoricPart( obj ) +Dummy = DeviatoricPart( Mat ) +Dummy = .Dev.( obj ) +Dummy = .Dev.( Mat ) +``` + +### Pull-Back operation + +```fortran +Dummy = Pullback( T, F, indx1, indx2 ) +``` + +`T` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. `F` can be a `Rank2Tensor_` or Matrix of (3,3) shape. Indx1, and Indx2 should be `Contra`, `CoVar`. + +We can also use `Pullback` of vector using the same functions. + +```fortran +Dummy = Pullback( Vec, F, indx1 ) +``` + +`F` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. + +### Push-Forward operation + +```fortran +Dummy = PushForward( T, F, indx1, indx2 ) +``` + +`T` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. `F` can be a `Rank2Tensor_` or Matrix of (3,3) shape. Indx1, and Indx2 should be `Contra`, `CoVar`. + +We can also use `Pullback` of vector using the same functions. + +```fortran +Dummy = PushForward( Vec, F, indx1 ) +``` + +`F` can be a `Rank2Tensor_` object or Matrix of (3,3) shape. + +## Spectral Decomposition of tensor + +**Getting the EigenValues and EigenVectors** + +We have defined the routine called `Tensor_Eigens` for getting the eigen values and eigen-vectors. + +```fortran +CALL Tensor_Eigens( Mat, EigenValues, EigenVectors ) +``` + +EigenValues can be Rank-2 or Rank-1 fortran array. If Rank-1 then only real parts of eigen-values will be returned. + +**Getting the PrincipalValue** + +Principal values is defined by the maximum eigen value. + +```fortran +dummy = Tensor_PrincipalValue( obj ) +dummy = Tensor_PrincipalValue( Mat ) +``` + +**Getting the SpectralRadius** + +```fortran +dummy = Tensor_SpectralRadius( obj ) +dummy = Tensor_SpectralRadius( Mat ) +``` + +### Polar Decomposition + +```fortran +CALL PolarDecomposition( Mat, R, H, PDType ) +CALL PolarDecomposition( obj, R, H, PDType ) +``` + +```fortran +R = RotationPart( Mat ) +R = RotationPart( obj ) +``` + +### Vector Operations + +**VectorProduct** + +We have defined `VectorProduct()` function for computing the cross product( also known as vector product ), It returns a length 3 vector. `VectorProduct(u,v)` is $u \times v$. `VectorProduct(u,v,w)` is equivalent to $u \times ( v \times w )$ + +```fortran +Vec = VectorProduct( u, v ) +Vec = u .X. v +Vec = VectorProduct( u, v, w ) +``` + +**BoxProduct** + +The `BoxProduct(u,v,w)` is equivalent to $[u,v,w] = u \cdot ( v \times w )$ + +```fortran +Dummy = BoxProduct( u, v, w) +``` + +**getAngle** + +Returns the angle (in radians) betrween two vectors + +```fortran +theta = getAngle( u, v ) +theta = u .Angle. v +``` + +**getProjection** + +`getProjection(u,v)` project vector u on v and returns the projection vector in the direction of v. + +```fortran +P = u .ProjectOn. v +``` + +**UnitVector** + +Returns the unit vector + +```fortran +uhat = UnitVector( u ) +uhat = .UnitVector. u +``` + +**Dot Product** + +```fortran +s = DOT_PRODUCT( u, v ) +s = u .dot. v +``` + +**Normal and Parallel components** + +We have defined two operators to decompose a vector in the direction along and perpendicular to some vector. + +```fortran +p = u .ComponentParallelTo. v +n = u .ComponentNormalTo. v +``` + +**Vector2D** + +`Vector2D` converts any vector in two 2D vector format. + +**Vector3D** + +`vector3D` converts any vector in 3D vector format. + +**Vector1D** + +`vector1D` converts any vector in 1D vector format. + + +### Operator Overloading + +**Contraction** + +```fortran +obj .Contraction. MaterialJacobianobj +MaterialJaconbianobj .Contraction. obj +``` + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +## Construction Methods + +```fortran +CALL obj%initiate( ) +CALL obj%Initiate( Mat ) +CALL obj%Initiate( Scalar ) +CALL obj%Initiate( VoigtVec, VoigtType ) +CALL obj%Initiate( obj2 ) +``` + +```fortran +obj => Tensor_Pointer( ) +obj => Tensor_Pointer( Mat ) +obj => Tensor_Pointer( Scalar ) +obj => Tensor_Pointer( VoigtVec, VoigtType ) +obj => Tensor_Pointer( obj2 ) +``` + +```fortran +obj = Rank2Tensor( ) +obj = Rank2Tensor( Mat ) +obj = Rank2Tensor( Scalar ) +obj = Rank2Tensor( VoigtVec, VoigtType ) +obj = Rank2Tensor( obj2 ) +``` + +### Initiate() + +Type-1 + +Interface + +```fortran + SUBROUTINE Initiate1( obj ) + CLASS( Tensor_ ), INTENT( INOUT ) :: obj + IF( ALLOCATED( obj%T ) ) DEALLOCATE( obj%T ) + ALLOCATE( obj%T( 3, 3 ) ) + obj%NSD = 3 + obj%T = 0.0_DFP + END SUBROUTINE Initiate1 +``` + +Description + +See the above code. + +Type-2 + +Interface + +```fortran + SUBROUTINE Initiate2( obj, A ) + CLASS( Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A +``` + +Description + +Here `A` should be a square matrix of the size in the list {1,2,3}. + +Type-3 + +Interface + +```fortran + SUBROUTINE Initiate3( obj, A ) + CLASS( Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: A + + IF( ALLOCATED( obj%T ) ) DEALLOCATE( obj%T ) + ALLOCATE( obj%T( 3, 3 ) ) + obj%T = A + END SUBROUTINE Initiate3 +``` + +Description + +See the code above + +Type-4 + +Interface + +```fortran + SUBROUTINE Initiate4( obj, A, VoigtType ) + USE Voigt + CLASS( Tensor_ ), INTENT( INOUT ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType +``` + +Description + +Coverts a Voigt vector into a tensor. + +Type-5 + +Interface + +```fortran + SUBROUTINE Initiate5( obj, obj2 ) + CLASS( Tensor_ ), INTENT( INOUT ) :: obj + CLASS( Tensor_ ), INTENT( IN ) :: obj2 +``` + +Description + +Coverts a Voigt vector into a tensor. + +### Tensor_Pointer( ) + +Type-1 + +Interface + +```fortran + FUNCTION Constructor1( ) + CLASS( Tensor_ ), POINTER :: Constructor1 + + ALLOCATE( Tensor_ :: Constructor1 ) + CALL Constructor1%Initiate( ) + END FUNCTION Constructor1 +``` + +Description + +Type-2 + +Interface + +```fortran + FUNCTION Constructor2( A ) + CLASS( Tensor_ ), POINTER :: Constructor2 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A + Error_Flag = .FALSE. + ALLOCATE( Tensor_ :: Constructor2 ) + CALL Constructor2%Initiate( A ) + END FUNCTION Constructor2 +``` + +Description + +Type-3 + +Interface + +```fortran + FUNCTION Constructor3( A ) + CLASS( Tensor_ ), POINTER :: Constructor3 + REAL( DFP ), INTENT( IN ) :: A + + Error_Flag = .FALSE. + + ALLOCATE( Tensor_ :: Constructor3 ) + CALL Constructor3%Initiate( A ) + END FUNCTION Constructor3 +``` + +Description + +Type-4 + +Interface + +```fortran + FUNCTION Constructor4( A, VoigtType ) + USE Voigt + CLASS( Tensor_ ), POINTER :: Constructor4 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType + + Error_Flag = .FALSE. + ALLOCATE( Tensor_ :: Constructor4 ) + CALL Constructor4%Initiate( A, VoigtType ) + END FUNCTION Constructor4 +``` + +Description + +Type-5 + +Interface + +```fortran + FUNCTION Constructor10( obj ) + CLASS( Tensor_ ), POINTER :: Constructor10 + CLASS( Tensor_ ), INTENT( IN ) :: obj + + ALLOCATE( Constructor10 ) + CALL Constructor10%Initiate( obj ) + END FUNCTION Constructor10 +``` + +Description + +### Rank2Tensor( ) + +Type-1 + +Interface + +```fortran + FUNCTION Constructor5( ) + TYPE( Tensor_ ) :: Constructor5 + + CALL Constructor5%Initiate( ) + END FUNCTION Constructor5 +``` + +Description + +Type-2 + +Interface + +```fortran + FUNCTION Constructor6( A ) + TYPE( Tensor_ ) :: Constructor6 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A + + Error_Flag = .FALSE. + CALL Constructor6%Initiate( A ) + END FUNCTION Constructor6 +``` + +Description + +Type-3 + +Interface + +```fortran + FUNCTION Constructor7( A ) + TYPE( Tensor_ ) :: Constructor7 + REAL( DFP ), INTENT( IN ) :: A + + Error_Flag = .FALSE. + + CALL Constructor7%Initiate( A ) + END FUNCTION Constructor7 +``` + +Description + +Type-4 + +Interface + +```fortran + FUNCTION Constructor8( A, VoigtType ) + USE Voigt + TYPE( Tensor_ ) :: Constructor8 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType + + + Error_Flag = .FALSE. + CALL Constructor8%Initiate( A, VoigtType ) + + CALL Check_Error( & + "Tensor_Class.F90>>Constructor.part>>Constructor8()", & + "TraceBack ---> CALL Constructor8%Initiate( A, VoigtType )" & + ) + END FUNCTION Constructor8 +``` + +Description + +Type-5 + +Interface + +```fortran + FUNCTION Constructor9( obj ) + TYPE( Tensor_ ) :: Constructor9 + CLASS( Tensor_ ), INTENT( IN ) :: obj + + CALL Constructor9%Initiate( obj ) + END FUNCTION Constructor9 +``` + +Description + +### getNSD( ) + +Interface + +```fortran + INTEGER( I4B ) FUNCTION getNSD( obj ) + CLASS( Tensor_ ), INTENT( IN ) :: obj + getNSD = obj%NSD + END FUNCTION getNSD +``` + +### getTensor + +Type-1 + +```fortran + SUBROUTINE getTensor_1( obj, T ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( INOUT ) :: T + + Error_Flag = .FALSE. + + IF( .NOT. obj%isInitiated( ) ) THEN + CALL Err_Msg( & + "Tensor_Class.F90>>getTensor_1.part", & + "getTensor_1()", & + "Tensor obj is Not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED( T ) ) DEALLOCATE( T ) + T = obj%T + +END SUBROUTINE getTensor_1 +``` + +Type-2 + +```fortran + SUBROUTINE getTensor_2( obj, Vec, VoigtType ) + USE Voigt + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, DIMENSION( : ), INTENT( INOUT ) :: Vec + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType +``` + +Description + +If `obj%NSD` is 2 then `Vec` has length 4. Note that `Vec` is reallocated by the routine. + +Type-3 + +```fortran + SUBROUTINE getTensor_3( T, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: T +``` + +> This subroutine is used for overloading the assignment operator. Now we can obtain the value using `Mat = obj`. + +## Operator Overloading ( * ) + +Type-1 + +```fortran + FUNCTION TensorTimesScalar_1( obj, Scalar ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_1 +``` + +`obj * 2.0_DFP` returns a (3,3) matrix. + +Type-2 + +```fortran + FUNCTION TensorTimesScalar_2( Scalar, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_2 +``` + +`2.0_DFP * obj` returns a (3,3) matrix. + +Type-3 + +```fortran + FUNCTION TensorTimesScalar_3( obj, Scalar ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_3 +``` + +`obj * 2` returns a (3,3) matrix. + +Type-4 + +```fortran + FUNCTION TensorTimesScalar_4( Scalar, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_4 +``` + +`2 * obj` returns a (3,3) matrix. + +Type-5 + +```fortran + FUNCTION TensorTimesTensor( obj, obj2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesTensor +``` + +`obj1 * obj2` perfoms element wise multiplication + +Type-6 + +```fortran + FUNCTION TensorTimesVector( obj, Vec ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: TensorTimesVector +``` + +`obj * Vec` returns array of length-3 after performing matrix vector multiplication. Symbolically, $w = T \cdot v$ + +Example + +```fortran +TENSOR = + + 1.000000 1.000000 1.000000 + 1.000000 1.000000 1.000000 + 1.000000 1.000000 1.000000 + +NSD = 3 + +Vec2 = T * Vec1 + 6.0000 6.0000 6.0000 + +Vec2 = T * [1.d0, 2.d0, 3.d0] + 6.0000 6.0000 6.0000 + +Vec1 = T * Vec1 + 6.0000 6.0000 6.0000 + +Vec2 = T * [1.d0, 2.d0] + 3.0000 3.0000 0.0000 + +Vec2 = T * [1.d0] + 1.0000 0.0000 0.0000 +``` + +Type-7 + +```fortran + FUNCTION VectorTimesTensor( Vec, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: VectorTimesTensor +``` + +`Vec * obj` returns array of length-3 after performing matrix vector multiplication. Symbolically $w = v \cdot T$ + +Example + +```fortran +TENSOR = + + 1.000000 2.000000 3.000000 + 1.000000 2.000000 3.000000 + 1.000000 2.000000 3.000000 + +NSD = 3 + +Vec2 = Vec1 * T + 6.0000 12.000 18.000 + +Vec2 = [1.d0, 2.d0, 3.d0] * T + 6.0000 12.000 18.000 + +Vec1 = Vec1 * T + 6.0000 12.000 18.000 + +Vec2 = [1.d0, 2.d0] * T + 3.0000 6.0000 0.0000 + +Vec2 = [1.d0] * T + 1.0000 0.0000 0.0000 +``` + +Type-8 + +```fortran + FUNCTION TensorTimesMat( obj, Mat ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesMat +``` + +Type-9 + +```fortran + FUNCTION MatTimesTensor( Mat, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: MatTimesTensor +``` + +### MatMul + +Type-1 + +```fortran + FUNCTION MatMul_1( obj, obj2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_1 +``` + +Type-2 + +```fortran + FUNCTION MatMul_2( obj, Mat2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_2 + +``` + +Type-3 + +```fortran + FUNCTION MatMul_3( Mat2, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_3 +``` + +Type-4 + +```fortran + FUNCTION VectorTimesTensor( Vec, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: VectorTimesTensor +``` + +Type-5 + +```fortran + FUNCTION TensorTimesVector( obj, Vec ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: TensorTimesVector +``` + +### Dyadic Product/Otimes + +Type-1 + +```fortran + FUNCTION Tensor_Dyadic_Tensor( obj, obj2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Tensor +``` + +Type-2 + +```fortran + FUNCTION Tensor_Dyadic_Mat( obj, Mat ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Mat +``` + +Type-3 + +```fortran + FUNCTION Mat_Dyadic_Tensor( Mat, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Dyadic_Tensor +``` + +> Note that .Otimes. always return a (6,6) matrix. If you want to use (4,4) or (3,3) matrix then use `Mat4_From_Mat6`, and `Mat3_From_Mat6` function. +> For Voigt represent of rank-2 tensor dyadic product both tensor must be symmetric. + +Examples + +```fortran + CALL T%FreeThePointer( T ) + + T => Rank2Tensor_Pointer( RESHAPE( [ & + 1.d0, 1.d0, 1.d0, & + 1.d0, 2.d0, 3.d0, & + 1.d0, 3.d0, 3.d0 & + ], & + [3,3] & + ) & + ) + + CALL T%Display( ) + + DummyMat = T .Otimes. T + + CALL Display_Array( DummyMat, "T .Otimes. T" ) + + DummyMat = T + CALL Display_Array( ( T .Otimes. DummyMat ), "T .Otimes. DummyMat " ) + + DummyMat = T .Otimes. DummyMat + CALL Display_Array( DummyMat, "DummyMat = T .Otimes. DummyMat " ) + + DummyMat = T + CALL Display_Array( ( DummyMat .Otimes. T ), "DummyMat .Otimes. T " ) +``` + +Resutls + +```fortran +TENSOR = + + 1.000000 1.000000 1.000000 + 1.000000 2.000000 3.000000 + 1.000000 3.000000 3.000000 + +NSD = 3 + + +T .Otimes. T= + + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + + +T .Otimes. DummyMat= + + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + + +DummyMat = T .Otimes. DummyMat= + + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + +DummyMat .Otimes. T= + + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 2.000000 4.000000 6.000000 2.000000 6.000000 2.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 + 3.000000 6.000000 9.000000 3.000000 9.000000 3.000000 + 1.000000 2.000000 3.000000 1.000000 3.000000 1.000000 +``` + +Example of getting (4,4) array from (6,6) array + +```fortran + DummyMat = Mat4_From_Mat6( DummyMat .Otimes. T ) + CALL Display_Array( DummyMat, "DummyMat = Mat4_From_Mat6( DummyMat .Otimes. T ) ") +``` + +Result + +```fortran +DummyMat = Mat4_From_Mat6( DummyMat .Otimes. T )= + + 1.000000 2.000000 1.000000 3.000000 + 2.000000 4.000000 2.000000 6.000000 + 1.000000 2.000000 1.000000 3.000000 + 3.000000 6.000000 3.000000 9.000000 +``` + +### Transpose + +```fortran + FUNCTION Transpose_1( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: Transpose_1 +``` + +> Returns a (3,3) matrix. + +### Addition + +Type-1 + +```fortran + FUNCTION obj_Add_obj( obj, obj2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_obj + obj_Add_obj = obj%T + obj2%T + END FUNCTION obj_Add_obj +``` + +Example : `obj + obj2` + +Type-2 + +```fortran + FUNCTION obj_Add_Mat( obj, Mat ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Mat + obj_Add_Mat = obj%T + Mat + END FUNCTION obj_Add_Mat +``` + +Example: `obj + Mat` + +Type-3 + +```fortran + FUNCTION Mat_Add_obj( Mat, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Add_obj + Mat_Add_obj = obj%T + Mat + END FUNCTION Mat_Add_obj +``` + +Example: `Mat + obj` + +### Subtraction + +Type-1 + +```fortran + FUNCTION obj_Minus_obj( obj, obj2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_obj + obj_Minus_obj = obj%T - obj2%T + END FUNCTION obj_Minus_obj +``` + +Example : `obj - obj2` + +Type-2 + +```fortran + FUNCTION obj_Minus_Mat( obj, Mat ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Mat + obj_Minus_Mat = obj%T - Mat + END FUNCTION obj_Minus_Mat +``` + +Example: `obj - Mat` + +Type-3 + +```fortran + FUNCTION Mat_Minus_obj( Mat, obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Minus_obj + Mat_Minus_obj = obj%T - Mat + END FUNCTION Mat_Minus_obj +``` + +Example: `Mat - obj` + +## Vector Methods + +### VectorProduct + +Type-1 + +```fortran + FUNCTION VectorProduct2( u, v ) + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v + REAL( DFP ), DIMENSION( 3 ) :: VectorProduct2 +``` + +Description + +Computes $u \times v$ + +Type-2 + +```fortran + FUNCTION VectorProduct3( u, v, w ) + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w + REAL( DFP ), DIMENSION( 3 ) :: VectorProduct3 +``` + +Description + +Computes $u \times ( v \times w )$ + +### BoxProduct + +```fortran + REAL( DFP ) FUNCTION BoxProduct( u, v, w ) + USE Utility, ONLY: Det + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w +``` + +Description + +Computes $[u,v,w] = u \cdot (v \times w)$ + +Example + +```fortran + Vec1 = [1.d0, 2.d0, 0.d0] + Vec2 = [1.d0, 1.d0, 0.d0] + Vec3 = Vec1 .X. Vec2 + CALL Display_Array( Vec3, "Vec3 = Vec1 .X. Vec2 ") + CALL Display_Array( & + VectorProduct( Vec1, Vec2, Vec3 ), & + "VectorProduct( Vec1, Vec2, Vec3 )" & + ) + + CALL Display_Array( & + -Vec2 .x. Vec3 .x. Vec1, & + "-Vec2 .x. Vec3 .x. Vec1" & + ) + CALL Display_Array( [Box(Vec1, Vec2, Vec3)], "Box[V1, V2, V3] ") +``` + +### getAngle + +```Fortran + REAL( DFP ) FUNCTION getAngle( u, v ) + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v +``` + +Returns angle between two vectors + +Example + +```fortran + Vec1 = [1.d0, 0.d0, 0.d0] + Vec2 = [1.d0, 1.d0, 0.d0] + + CALL Display_Array( [Vec1.Angle.Vec2], "Vec1.Angle.Vec2") +``` + +### getProjection + +```fortran + FUNCTION getProjection( u, v ) + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v + REAL( DFP ), DIMENSION( 3 ) :: getProjection +``` + +Project u on v. New Operator is defined `u .ProjectOn. v`. + +Example + +```fortran + Vec1 = [1.d0, 0.d0, 0.d0] + Vec2 = [-1.d0, 1.d0, 0.d0] + + CALL T%FreeThePointer( T ) + T => Rank2Tensor_Pointer( RESHAPE( [ & + 1.d0, 1.d0, 1.d0, & + 2.d0, 2.d0, 2.d0, & + 3.d0, 3.d0, 3.d0 & + ], & + [3,3] & + ) & + ) + + CALL Display_Array( T*Vec2 .ProjectOn. Vec1, "T*Vec2 .ProjectOn. Vec1") +``` + +### UnitVector + +```fortran + FUNCTION UnitVector( u ) + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( 3 ) :: UnitVector +``` + +Returns the unit vector. + +### DotProduct + +```fortran + FUNCTION DotProduct( u, v ) + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v + REAL( DFP ) :: DotProduct + DotProduct = DOT_PRODUCT( u, v ) + END FUNCTION DotProduct +``` + +Returns the dot product, used for defining the operator `u .dot. v` + +Example + +```fortran + Vec1 = [1.d0, -1.d0, 0.d0] + Vec2 = [-1.d0, 1.d0, 0.d0] + dp = Vec1 .dot. Vec2 +``` + +### getNormalComponent + +```fortran + FUNCTION getNormalComponent( u, v ) + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v + REAL( DFP ), DIMENSION( 3 ) :: getNormalComponent + getNormalComponent = u - ( u .ProjectOn. v ) + END FUNCTION getNormalComponent +``` + +Returns component of `u` that is normal to `v`. New operator is defined `u .ComponentNormalTo. v` + +### getParallelComponent + +Alias of `getProjection` method. it is used to define a new operator `u .ComponentParallelTo. v`. + + +Example + +```fortran + Vec1 = [1.d0, 1.d0, 1.d0] + CALL Display_Array( Vec1, "Vec1 ") + + Vec2 = [1.d0, 0.d0, 0.d0] + CALL Display_Array( Vec2, "Vec2 ") + + Vec3 = Vec1 .ComponentParallelTo. Vec2 + CALL Display_Array( Vec3, "Vec3 = Vec1 .ComponentParallelTo. Vec2 ") + + Vec3 = Vec1 .ComponentNormalTo. Vec2 + CALL Display_Array( Vec3, "Vec3 = Vec1 .ComponentNormalTo. Vec2 ") + + Vec3 = (Vec1 .ComponentNormalTo. Vec2) + (Vec1 .ComponentParallelTo. Vec2) + CALL Display_Array( Vec3, & + " Vec3 = Vec1 .ComponentNormalTo. Vec2 + Vec1 .ComponentParallelTo. Vec2 ") +``` + +### Vector3D + +```fortran + FUNCTION Vector3D( u ) + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( 3 ) :: Vector3D + + Vector3D = 0.0_DFP + SELECT CASE( SIZE( u ) ) + CASE( 1 ) + Vector3D( 1 ) = u( 1 ) + CASE( 2 ) + Vector3D( 1 : 2 ) = u( 1 : 2 ) + CASE DEFAULT + Vector3D( 1: 3 ) = u( 1 : 3 ) + END SELECT + END FUNCTION Vector3D +``` + +### Vector2D + +```fortran + FUNCTION Vector2D( u ) + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( 2 ) :: Vector2D + Vector2D = 0.0_DFP + SELECT CASE( SIZE( U ) ) + CASE( 1 ) + Vector2D( 1 ) = U( 1 ) + CASE DEFAULT + Vector2D( 1: 2 ) = U( 1: 2 ) + END SELECT + END FUNCTION Vector2D +``` + +### Vector1D + +```fortran + FUNCTION Vector1D( u ) + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( 1 ) :: Vector1D + Vector1D( 1 ) = u( 1 ) + END FUNCTION Vector1D +``` + +> We have made BoxProduct, VectorProduct, Box, getAngle, getProjection, UnitVector, getParallelComponent, getNormalComponent, Vector2D, Vector3D, Vector1D public. These functions can be used as vector functions. +> In addition we have defined the OPERATOR( .X. ), OPERATOR( .Angle. ), OPERATOR( .ProjectOn. ), OPERATOR( .dot. ), OPERATOR( .ComponentParallelTo. ), OPERATOR( .ComponentNormalTo. ). + +## Tensor Decomposition + +### Symmetric Part + +Method + +```fortran + +``` + +Function + +```fortran + +``` + +### Symmetric Part + +Method + +```fortran + FUNCTION m_SymmetricPart( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_SymmetricPart + m_SymmetricPart = 0.5_DFP * ( obj%T + TRANSPOSE( obj%T ) ) + END FUNCTION m_SymmetricPart +``` + +Function + +```fortran + FUNCTION f_SymmetricPart( Mat ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: f_SymmetricPart + f_SymmetricPart = 0.5_DFP * ( Mat + TRANSPOSE( Mat ) ) + END FUNCTION f_SymmetricPart +``` + +### AntiSymmetric Part + +Method + +```fortran + FUNCTION m_AntiSymmetricPart( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_AntiSymmetricPart + m_AntiSymmetricPart = 0.5_DFP * ( obj%T - TRANSPOSE( obj%T ) ) + END FUNCTION m_AntiSymmetricPart +``` + +Function + +```fortran + FUNCTION f_AntiSymmetricPart( Mat ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: & + f_AntiSymmetricPart + f_AntiSymmetricPart = 0.5_DFP * ( Mat - TRANSPOSE( Mat ) ) + END FUNCTION f_AntiSymmetricPart +``` + +### Hydrostatic Part + +Method + +```fortran + FUNCTION m_HydrostaticPart( obj ) + USE Utility, ONLY : Eye + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_HydrostaticPart + m_HydrostaticPart = Trace( obj ) * Eye( 3 ) / 3 + END FUNCTION m_HydrostaticPart +``` + +Function + +```fortran + FUNCTION f_HydrostaticPart( Mat ) + USE Utility, ONLY : Eye + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: f_HydrostaticPart + f_HydrostaticPart = Trace( Mat ) * Eye( 3 ) / 3 + END FUNCTION f_HydrostaticPart +``` + +### Deviatoric Part + +Method + +```fortran + FUNCTION m_DeviatoricPart( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_DeviatoricPart + + m_DeviatoricPart = obj%T - HydrostaticPart( obj ) +``` + +Function + +```fortran + FUNCTION f_DeviatoricPart( Mat ) + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: f_DeviatoricPart + f_DeviatoricPart = Mat - HydrostaticPart( Mat ) + END FUNCTION f_DeviatoricPart +``` + +## Invariants + +### Trace + +Method + +```fortran +I = obj%Trace( ) +``` + +Returns the trace of Tensor object. + +Module Function + +```fortran +I = Trace( T ) +``` + +Returns the trace of fortran array `T`. + +### Double_DotProduct + +There is a generic method _Double\_DotProduct_ and module-function called _Double\_DotProduct_. Therefore you can use this function e.g. `real_val = obj%Double_DotProduct( ... )` as a method as well as a module-function `real_val = Double_DotProduct()`. + +Type-1 + +```fortran + REAL( DFP ) FUNCTION DoubleDot_Product1( obj, obj2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + DoubleDot_Product1 = SUM( obj * obj2 ) + END FUNCTION DoubleDot_Product1 +``` + +Type-2 + +```fortran + REAL( DFP ) FUNCTION DoubleDot_Product2( obj, A ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A + DoubleDot_Product2 = SUM( obj * A ) + END FUNCTION DoubleDot_Product2 +``` + +Type-3 + +```fortran + REAL( DFP ) FUNCTION DoubleDot_Product3( A, B ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, B + DoubleDot_Product3 = SUM( A * B ) + END FUNCTION DoubleDot_Product3 +``` + +Type-4 + +```fortran + REAL( DFP ) FUNCTION DoubleDot_Product4( obj, A, VoigtType ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType + + TYPE( Rank2Tensor_ ) :: T + T = Rank2Tensor( A, VoigtType ) + DoubleDot_Product4 = SUM( T*obj ) + + CALL T%Deallocate( ) + + END FUNCTION DoubleDot_Product4 +``` + +Type-5 + +```fortran + REAL( DFP ) FUNCTION DoubleDot_Product5( A, B, VoigtType ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: B + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType + + TYPE( Rank2Tensor_ ) :: T + T = Rank2Tensor( B, VoigtType ) + DoubleDot_Product5 = SUM( T * A ) + CALL T%Deallocate( ) + END FUNCTION DoubleDot_Product5 +``` + +Type-6 + +```fortran + REAL( DFP ) FUNCTION DoubleDot_Product6( A, VoigtType_A, B, VoigtType_B ) + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: A, B + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType_A, VoigtType_B + TYPE( Rank2Tensor_ ) :: T1, T2 + T1 = Rank2Tensor( A, VoigtType_A ) + T2 = Rank2Tensor( B, VoigtType_B ) + DoubleDot_Product6 = SUM( T1 * T2 ) + CALL T1%Deallocate( ) + CALL T2%Deallocate( ) + END FUNCTION DoubleDot_Product6 +``` + +We have also defined two operators called `.DoubleDot.` and `.Contraction.` + +Use of `.DoubleDot.` operator. + +- `obj .DoubleDot. obj` returns scalar +- `obj .DoubleDot. Mat` returns scalar +- `Mat .DoubleDot. obj` returns scalar +- `Mat .DoubleDot. Mat` returns scalar + +Use of `.Contraction.` operator. + +- `obj .Contraction. obj` returns scalar +- `obj .Contraction. Mat` returns scalar +- `Mat .Contraction. obj` returns scalar +- `Mat .Contraction. Mat` returns scalar +- `Mat .Contraction. Mat` returns scalar +- `Mat .Contraction. Vec` returns vector +- `Mat .Contraction. Vec` returns vector $T \cdot v$ +- `Vec .Contraction. Mat` returns vector $T^T \cdot v$ + +### Invariant I1 + +$$I_1 = Trace( T )$$ + +There are methods as well as module-function for this. + +Method + +```fortran +obj%Invariant_I1( ) +``` + +Module-function + +```fortran +Invariant_I1( obj ) +Invariant_I1( Mat ) +``` + +### Invariant I2 + +$$I_2 = \frac{1}{2} \Big [ Trace^2( T ) - Trace( T^2 ) \Big ]$$ + +There are methods as well as module-function for this. + +Method + +```fortran +obj%Invariant_I2( ) +``` + +Module-function + +```fortran +Invariant_I2( obj ) +Invariant_I2( Mat ) +``` + +### Invariant I3 + +$$I_3 = \det{T}$$ + +There are methods as well as module-function for this. + +Method + +```fortran +obj%Invaria3t_I2( ) +``` + +Module-function + +```fortran +Invariant_I3( obj ) +Invariant_I3( Mat ) +``` + +### Invariant J2 + +$$J_2 = \frac{1}{2} dev(T):dev(T)$$ + +Method + +```fortran + REAL( DFP ) FUNCTION m_Invariant_J2( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE :: S( :, : ) + IF( isDeviatoric( obj ) ) THEN + m_Invariant_J2 = 0.5_DFP * ( obj .Contraction. obj ) + ELSE + S = DeviatoricPart( obj ) + m_Invariant_J2 = 0.5_DFP * ( S .Contraction. S ) + END IF + IF( ALLOCATED( S ) ) DEALLOCATE( S ) + END FUNCTION m_Invariant_J2 +``` + +Module Function + +```fortran + REAL( DFP ) FUNCTION f_Invariant_J2( Mat ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), ALLOCATABLE :: S( :, : ) + IF( isDeviatoric( Mat ) ) THEN + f_Invariant_J2 = 0.5_DFP * ( Mat .Contraction. Mat ) + ELSE + S = DeviatoricPart( Mat ) + f_Invariant_J2 = 0.5_DFP * ( S .Contraction. S ) + END IF + IF( ALLOCATED( S ) ) DEALLOCATE( S ) + END FUNCTION f_Invariant_J2 +``` + +### Invariant J3 + +$$J_3 = \det( dev( T ) )$$ + +Method + +```fortran + REAL( DFP ) FUNCTION m_Invariant_J3( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE :: S( :, : ) + IF( isDeviatoric( obj ) ) THEN + m_Invariant_J3 = Invariant_I3( obj ) + ELSE + S = DeviatoricPart( obj ) + m_Invariant_J3 = Invariant_I3( S ) + END IF + IF( ALLOCATED( S ) ) DEALLOCATE( S ) + END FUNCTION m_Invariant_J3 +``` + +Module Function + +```fortran + REAL( DFP ) FUNCTION f_Invariant_J3( Mat ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), ALLOCATABLE :: S( :, : ) + IF( isDeviatoric( Mat ) ) THEN + f_Invariant_J3 = Invariant_I3( Mat ) + ELSE + S = DeviatoricPart( Mat ) + f_Invariant_J3 = Invariant_I3( S ) + END IF + IF( ALLOCATED( S ) ) DEALLOCATE( S ) + END FUNCTION f_Invariant_J3 +``` + +### LodeAngle + +Type-1 + +```fortran + REAL( DFP ) f_LodeAngle_1( J2, J3, LodeAngleType ) + REAL( DFP ), INTENT( IN ) :: J2, J3 + CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType + REAL( DFP ) :: Dummy + + IF( J2 .EQ. 0.0_DFP ) THEN + f_LodeAngle_1 = 0.0_DFP + RETURN + END IF + + Dummy = 1.5_DFP * SQRT( 3.0_DFP ) * J3 / J2 / SQRT( J2 ) + + IF( Dummy .GE. 1.0_DFP ) Dummy = 1.0_DFP + IF( Dummy .LE. -1.0_DFP ) Dummy = -1.0_DFP + + SELECT CASE( TRIM( LodeAngleType ) ) + CASE( "SIN", "SINE", "Sin", "Sine", "sine", "sin" ) + f_LodeAngle_1 = ASIN( -Dummy ) / 3.0_DFP + CASE DEFAULT + f_LodeAngle_1 = ACOS( Dummy ) / 3.0_DFP + END SELECT + END FUNCTION f_LodeAngle_1 + +``` + +Type-2 + +```fortran + REAL( DFP ) m_LodeAngle( obj, LodeAngleType ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType + + REAL( DFP ) :: J2, J3 + J2 = Invariant_J2( obj ) + J3 = Invariant_J3( obj ) + m_LodeAngle = f_LodeAngle_1( J2, J3, LodeAngleType ) + END FUNCTION m_LodeAngle +``` + +Type-3 + +```fortran + REAL( DFP ) f_LodeAngle_2( Mat, LodeAngleType ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType + + REAL( DFP ) :: J2, J3 + J2 = Invariant_J2( Mat ) + J3 = Invariant_J3( Mat ) + f_LodeAngle_2 = f_LodeAngle_1( J2, J3, LodeAngleType ) + END FUNCTION f_LodeAngle_2 +``` + +## PullBack + +Type-1 + +```fortran + FUNCTION f_Rank2PullBack_1( T, F, indx1, indx2 ) + USE Utility, ONLY: det, INV + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: T, F + REAL( DFP ), DIMENSION( SIZE( T, 1 ), SIZE( T, 2 ) ) :: f_Rank2PullBack_1 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 +``` + +Description + +To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. + +Type-2 + +```fortran + FUNCTION f_Rank2PullBack_2( T, obj, indx1, indx2 ) + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: T + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: f_Rank2PullBack_2 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + + REAL( DFP ), ALLOCATABLE :: F( :, :) + + F = obj + + f_Rank2PullBack_2 = f_Rank2PullBack_1( T, F, indx1, indx2 ) + + DEALLOCATE( F ) + + END FUNCTION f_Rank2PullBack_2 +``` + +Type-3 + +```fortran + FUNCTION m_Rank2PullBack_1( obj, F, indx1, indx2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: F + REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PullBack_1 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + + REAL( DFP ), ALLOCATABLE :: T( :, : ) + T = obj + m_Rank2PullBack_1 = f_Rank2PullBack_1( T, F, indx1, indx2 ) + END FUNCTION m_Rank2PullBack_1 +``` + +Description + +To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. + +Type-4 + +```fortran + FUNCTION m_Rank2PullBack_2( obj, obj2, indx1, indx2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PullBack_2 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + + REAL( DFP ), ALLOCATABLE :: T( :, : ), F + T = obj + F = obj2 + m_Rank2PullBack_2 = f_Rank2PullBack_1( T, F, indx1, indx2 ) + END FUNCTION m_Rank2PullBack_2 +``` + +Description + +To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. + +Type-5 + +```fortran + FUNCTION f_VecPullBack_1( Vec, F, indx1 ) + USE Utility, ONLY: det, INV + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F + REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: f_VecPullBack_1 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1 +``` + +Type-6 + +```fortran + FUNCTION f_VecPullBack_2( Vec, obj, indx1 ) + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: Vec + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3 ) :: f_VecPullBack_2 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1 + + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: F + + F = obj + f_VecPullBack_2 = f_VecPullBack_1( Vec, F, indx1 ) + DEALLOCATE( F ) + + END FUNCTION f_VecPullBack_2 +``` + +## PushForward + +Type-1 + +```fortran + FUNCTION f_Rank2PushForward_1( T, F, indx1, indx2 ) + USE Utility, ONLY: det, INV + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: T, F + REAL( DFP ), DIMENSION( SIZE( T, 1 ), SIZE( T, 2 ) ) :: f_Rank2PushForward_1 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 +``` + +Description + +To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. + +Type-2 + +```fortran + FUNCTION f_Rank2PushForward_2( T, obj, indx1, indx2 ) + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: T + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: f_Rank2PushForward_2 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + + REAL( DFP ), ALLOCATABLE :: F( :, :) + + F = obj + + f_Rank2PushForward_2 = f_Rank2PushForward_1( T, F, indx1, indx2 ) + + DEALLOCATE( F ) + + END FUNCTION f_Rank2PushForward_2 +``` + +Type-3 + +```fortran + FUNCTION m_Rank2PushForward_1( obj, F, indx1, indx2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: F + REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PushForward_1 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + + REAL( DFP ), ALLOCATABLE :: T( :, : ) + T = obj + m_Rank2PushForward_1 = f_Rank2PushForward_1( T, F, indx1, indx2 ) + END FUNCTION m_Rank2PushForward_1 +``` + +Description + +To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. + +Type-4 + +```fortran + FUNCTION m_Rank2PushForward_2( obj, obj2, indx1, indx2 ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: m_Rank2PushForward_2 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1, indx2 + + REAL( DFP ), ALLOCATABLE :: T( :, : ), F + T = obj + F = obj2 + m_Rank2PushForward_2 = f_Rank2PushForward_1( T, F, indx1, indx2 ) + END FUNCTION m_Rank2PushForward_2 +``` + +Description + +To be added later. See page-123 of Hashiguchi and Yamakawa, 2014. + +Type-5 + +```fortran + FUNCTION f_VecPushForward_1( Vec, F, indx1 ) + USE Utility, ONLY: det, INV + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F + REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: f_VecPushForward_1 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1 +``` + +Type-6 + +```fortran + FUNCTION f_VecPushForward_2( Vec, obj, indx1 ) + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: Vec + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3 ) :: f_VecPushForward_2 + CHARACTER( LEN = * ), INTENT( IN ) :: indx1 + + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: F + + F = obj + f_VecPushForward_2 = f_VecPushForward_1( Vec, F, indx1 ) + DEALLOCATE( F ) + + END FUNCTION f_VecPushForward_2 +``` + +## Spectral Decomposition + +### Eigens + +Type-1 + +```fortran + SUBROUTINE f_Eigens( Mat, EigenVectors, EigenValues ) +!. . . . . . . . . . . . . . . . . . . . +! 1. Eigen values are computed using DGEEV( ) subroutine of +! lapack libarary. +! 2. EigenValues( :, 2 ) has two columns, the first column denotes +! the real value of eigen value and second column denotes the +! imaginary/complex value of eigenvalue. The conjugate values +! are put next to each other. With positive imaginary value +! put first. +! 3. If j-th eigen value is imaginary then j-th and j+1 th Eigenvectors +! are given by +! v(j) = EigenVectors( :, j ) + i * EigenVectors( :, j +1 ) +! v(j+1) = EigenVectors( :, j ) - i * EigenVectors( :, j +1 ) +! +! 4. DGEEV function from lapack library has been used. +!. . . . . . . . . . . . . . . . . . . . + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: EigenValues( :, : ), & + EigenVectors( :, : ) +``` + +Type-2 + +```fortran + SUBROUTINE m_Eigens( obj, EigenVectors, EigenValues ) +!. . . . . . . . . . . . . . . . . . . . +! 1. Eigen values are computed using DGEEV( ) subroutine of +! lapack libarary. +! 2. EigenValues( :, 2 ) has two columns, the first column denotes +! the real value of eigen value and second column denotes the +! imaginary/complex value of eigenvalue. The conjugate values +! are put next to each other. With positive imaginary value +! put first. +! 3. If j-th eigen value is imaginary then j-th and j+1 th Eigenvectors +! are given by +! v(j) = EigenVectors( :, j ) + i * EigenVectors( :, j +1 ) +! v(j+1) = EigenVectors( :, j ) - i * EigenVectors( :, j +1 ) +!. . . . . . . . . . . . . . . . . . . . + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: EigenValues( :, : ), & + EigenVectors( :, : ) +``` + +Example + +```fortran +CALL Tensor_Eigens( Mat, EigenVectors, EigenValues ) +CALL Tensor_Eigens( obj, EigenVectors, EigenValues ) +CALL obj%Eigens( EigenVectors, EigenValues ) +``` + +### Principal Value + +Type-1 + +```fortran +REAL( DFP ) FUNCTION f_PrincipalValue_1( Mat ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), ALLOCATABLE :: EigenVectors( :, : ), EigenValues( :, : ) + CALL f_Eigens( Mat, EigenVectors, EigenValues ) + f_PrincipalValue_1 = MAXVAL( EigenValues( :, 1 ) ) + DEALLOCATE( EigenValues, EigenVectors ) +END FUNCTION f_PrincipalValue_1 +``` + +Description + +Returns the max( Real( eigenvalue ) ) + +Type-2 + +```fortran +REAL( DFP ) FUNCTION m_PrincipalValue_1( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE :: EigenVectors( :, : ), EigenValues( :, : ) + CALL m_Eigens( obj, EigenVectors, EigenValues ) + m_PrincipalValue_1 = MAXVAL( Eigenvalues( :, 1 ) ) + DEALLOCATE( EigenValues, EigenVectors ) +END FUNCTION m_PrincipalValue_1 +``` + +Exam + +### Spectral Radius + +Type-1 + +```fortran +REAL( DFP ) FUNCTION f_SpectralRadius_1( Mat ) + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + + REAL( DFP ), ALLOCATABLE :: EigenVectors( :, : ), EigenValues( :, : ) + COMPLEX( DFP ), ALLOCATABLE :: Lambda( :, : ) + INTEGER( I4B ) :: N + + CALL f_Eigens( Mat, EigenVectors, EigenValues ) + f_SpectralRadius_1 = MAXVAL( EigenValues( :, 1 ) ) + N = SIZE( Eigenvalues, 1 ) + ALLOCATE( Lambda( N ) ) + Lambda( 1 : N ) = CMPLX( EigenValues( 1 : N, 1 ), EigenValues( 1 : N, 2 ) ) + EigenValues = MAXVAL( ABS( Lambda ) ) + DEALLOCATE( EigenValues, EigenVectors, Lambda ) + +END FUNCTION f_SpectralRadius_1 +``` + +Description + +Returns the max( Real( eigenvalue ) ) + +Type-2 + +```fortran +REAL( DFP ) FUNCTION m_SpectralRadius_1( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + + REAL( DFP ), ALLOCATABLE :: Mat( :, : ) + Mat = obj + m_SpectralRadius_1 = f_SpectralRadius_1( Mat ) + DEALLOCATE( Mat ) +END FUNCTION m_SpectralRadius_1 +``` + +Description + +Returns the max( Real( eigenvalue ) ) + +## Polar Decomposition + +Type-1 + +```fortran + SUBROUTINE f_getPolarDecomp_1( Mat, R, H, PDType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Ref: Higham and Noferini, 2015 Algorithm 3.1 for NSD = 3 +! 2. PDType = "Right", "U", "Left", "V", "RU", "VR" +! 3. Mat = RU = VR, Therefore H denotes either U or V +! 4. RU is called "Right" polar decomposition and VR is called left +! polar decomposition +!. . . . . . . . . . . . . . . . . . . . + + USE LinearAlgebra, ONLY: GetSymEigenJacobiacobi + USE Utility, ONLY: IMAXLOC, INV + + ! Define intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: R + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: H + CHARACTER( LEN = * ), INTENT( IN ) :: PDType +``` + +Type-2 + +```fortran + SUBROUTINE m_getPolarDecomp_1( obj, R, H, PDType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Ref: Higham and Noferini, 2015 Algorithm 3.1 for NSD = 3 +! 2. PDType = "Right", "U", "Left", "V", "RU", "VR" +! 3. Mat = RU = VR, Therefore H denotes either U or V +! 4. RU is called "Right" polar decomposition and VR is called left +! polar decomposition +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: R + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( OUT ) :: H + CHARACTER( LEN = * ), INTENT( IN ) :: PDType +``` + +### Rotation Part + +Type-1 + +```fortran + FUNCTION f_getRotationPart( Mat ) + USE LinearAlgebra, ONLY: GetSymEigenJacobi + USE Utility, ONLY: IMAXLOC, INV + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: f_getRotationPart +``` + +Type-2 + +```fortran + FUNCTION m_getRotationPart( obj ) + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_getRotationPart + REAL( DFP ), ALLOCATABLE :: Mat( :, : ) + Mat = obj + m_getRotationPart = f_getRotationPart( Mat ) + DEALLOCATE( Mat ) + END FUNCTION m_getRotationPart +``` + diff --git a/src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part b/src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part new file mode 100755 index 000000000..608afbb28 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Old_Rank4Tensors.part @@ -0,0 +1,518 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Rank4Tensors.part +! Last Update : September-10-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of module +! +! Info:: - This part contains isotropic tensors of Rank-1, Rank-2, Rank-3 +! and Rank-4 +! +! Hosting File - Tensor.F90 +! +!============================================================================== +! +! List of items +! +!------------------------------------------------------------------------------ +! DiracDelta +!------------------------------------------------------------------------------ +! + INTEGER(I4B) FUNCTION DiracDelta( i, j ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-2 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j +! + Error_Flag = .FALSE. + + IF( i .EQ. j ) THEN + DiracDelta = 1 + ELSE + DiracDelta = 0 + END IF +! + END FUNCTION DiracDelta +! +!------------------------------------------------------------------------------ +! LeviCivita +!------------------------------------------------------------------------------ +! + INTEGER(I4B) FUNCTION LeviCivita( i, j, k ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-3 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j, k +! + Error_Flag = .FALSE. + + LeviCivita = ( i - j ) * ( j - k ) * ( k - i ) / 2 +! + END FUNCTION LeviCivita +! +!------------------------------------------------------------------------------ +! ISO4 +!------------------------------------------------------------------------------ +! + REAL(DFP) FUNCTION ISO4( lambda, mu, i, j, k, l ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-4 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j, k, l + REAL( DFP ), INTENT( IN ) :: lambda, mu +! + Error_Flag = .FALSE. + + ISO4 = lambda * DiracDelta( i, j ) * DiracDelta( k, l ) & + + mu * ( DiracDelta( i, k ) * DiracDelta( j, l ) & + + DiracDelta( i, l ) * DiracDelta( j, k ) ) +! + END FUNCTION ISO4 +! +!------------------------------------------------------------------------------ +! TraceISO4 +!------------------------------------------------------------------------------ +! + REAL(DFP) FUNCTION TraceISO4( i, j, k, l ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-3 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j, k, l +! + Error_Flag = .FALSE. + TraceISO4 = DiracDelta( i, j ) * DiracDelta( k, l ) +! + END FUNCTION TraceISO4 +! +!------------------------------------------------------------------------------ +! IdentityISO4 +!------------------------------------------------------------------------------ +! + REAL(DFP) FUNCTION IdentityISO4( i, j, k, l ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-3 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j, k, l +! + Error_Flag = .FALSE. + IdentityISO4 = DiracDelta( i, k ) * DiracDelta( j, l ) +! + END FUNCTION IdentityISO4 +! +!------------------------------------------------------------------------------ +! TransposeISO4 +!------------------------------------------------------------------------------ +! + REAL(DFP) FUNCTION TransposeISO4( i, j, k, l ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-3 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j, k, l +! + Error_Flag = .FALSE. + TransposeISO4 = DiracDelta( i, l ) * DiracDelta( j, k ) +! + END FUNCTION TransposeISO4 +! +!------------------------------------------------------------------------------ +! SymISO4 +!------------------------------------------------------------------------------ +! + REAL(DFP) FUNCTION SymISO4( i, j, k, l ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-3 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j, k, l +! + Error_Flag = .FALSE. + SymISO4 = 0.5_DFP * ( IdentityISO4( i, j, k, l ) + TransposeISO4( i,j,k,l )) +! + END FUNCTION SymISO4 +! +!------------------------------------------------------------------------------ +! AntiSymISO4 +!------------------------------------------------------------------------------ +! + REAL(DFP) FUNCTION AntiSymISO4( i, j, k, l ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - IsotropicTensors Rank-3 +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: i, j, k, l +! + Error_Flag = .FALSE. + AntiSymISO4 = 0.5_DFP * ( IdentityISO4( i, j, k, l ) & + - TransposeISO4( i, j, k, l ) ) +! + END FUNCTION AntiSymISO4 +! +!------------------------------------------------------------------------------ +! VoigtMatTraceISO4 +!------------------------------------------------------------------------------ +! + FUNCTION VoigtMatTraceISO4( N ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), DIMENSION( N, N ) :: VoigtMatTraceISO4 +! + Error_Flag = .FALSE. + VoigtMatTraceISO4 = 0.0_DFP + SELECT CASE( N ) + CASE( 6 ) + VoigtMatTraceISO4( 1 : 3, 1 : 3 ) = 1.0_DFP + CASE( 4 ) + VoigtMatTraceISO4( 1 : 2, 1 : 2 ) = 1.0_DFP + VoigtMatTraceISO4( 4, 4 ) = 1.0_DFP + VoigtMatTraceISO4( 1, 4 ) = 1.0_DFP + VoigtMatTraceISO4( 4, 1 ) = 1.0_DFP + VoigtMatTraceISO4( 4, 2 ) = 1.0_DFP + CASE( 3 ) + VoigtMatTraceISO4( 1 : 2, 1 : 2 ) = 1.0_DFP + CASE( 1 ) + VoigtMatTraceISO4( 1, 1 ) =1.0_DFP + CASE DEFAULT + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "VoigtMatTraceISO4(), Flag-1", "Unknown N" ) + Error_Flag = .TRUE. + RETURN + END SELECT +! + END FUNCTION VoigtMatTraceISO4 +! +!------------------------------------------------------------------------------ +! VoigtMatIdentityISO4 +!------------------------------------------------------------------------------ +! + FUNCTION VoigtMatIdentityISO4( N ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), DIMENSION( N, N ) :: VoigtMatIdentityISO4 +! + VoigtMatIdentityISO4 = 0.0_DFP + Error_Flag = .FALSE. + SELECT CASE( N ) + CASE( 6 ) + VoigtMatIdentityISO4( 1, 1 ) = 1.0_DFP + VoigtMatIdentityISO4( 2, 2 ) = 1.0_DFP + VoigtMatIdentityISO4( 3, 3 ) = 1.0_DFP + VoigtMatIdentityISO4( 4, 4 ) = 1.0_DFP + VoigtMatIdentityISO4( 5, 5 ) = 1.0_DFP + VoigtMatIdentityISO4( 6, 6 ) = 1.0_DFP + CASE( 4 ) + VoigtMatIdentityISO4( 1, 1 ) = 1.0_DFP + VoigtMatIdentityISO4( 2, 2 ) = 1.0_DFP + VoigtMatIdentityISO4( 3, 3 ) = 1.0_DFP + VoigtMatIdentityISO4( 4, 4 ) = 1.0_DFP + CASE( 3 ) + VoigtMatIdentityISO4( 1, 1 ) = 1.0_DFP + VoigtMatIdentityISO4( 2, 2 ) = 1.0_DFP + VoigtMatIdentityISO4( 3, 3 ) = 1.0_DFP + CASE( 1 ) + VoigtMatIdentityISO4( 1, 1 ) =1.0_DFP + CASE DEFAULT + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "VoigtMatIdentityISO4(), Flag-1", "Unknown N" ) + Error_Flag = .TRUE. + RETURN + END SELECT +! + END FUNCTION VoigtMatIdentityISO4 +! +!------------------------------------------------------------------------------ +! VoigtMatTransposeISO4 +!------------------------------------------------------------------------------ +! + FUNCTION VoigtMatTransposeISO4( N ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), DIMENSION( N, N ) :: VoigtMatTransposeISO4 +! + VoigtMatTransposeISO4 = 0.0_DFP + Error_Flag = .FALSE. + SELECT CASE( N ) + CASE( 6 ) + VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP + VoigtMatTransposeISO4( 2, 2 ) = 1.0_DFP + VoigtMatTransposeISO4( 3, 3 ) = 1.0_DFP + CASE( 4 ) + VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP + VoigtMatTransposeISO4( 2, 2 ) = 1.0_DFP + VoigtMatTransposeISO4( 4, 4 ) = 1.0_DFP + CASE( 3 ) + VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP + VoigtMatTransposeISO4( 2, 2 ) = 1.0_DFP + CASE( 1 ) + VoigtMatTransposeISO4( 1, 1 ) = 1.0_DFP + CASE DEFAULT + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "VoigtMatTransposeISO4(), Flag-1", "Unknown N" ) + Error_Flag = .TRUE. + RETURN + END SELECT +! + END FUNCTION VoigtMatTransposeISO4 +! +!------------------------------------------------------------------------------ +! VoigtMatSymISO4 +!------------------------------------------------------------------------------ +! + FUNCTION VoigtMatSymISO4( N ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), DIMENSION( N, N ) :: VoigtMatSymISO4 +! + VoigtMatSymISO4 = 0.0_DFP + Error_Flag = .FALSE. + SELECT CASE( N ) + CASE( 6 ) + VoigtMatSymISO4( 1, 1 ) = 1.0_DFP + VoigtMatSymISO4( 2, 2 ) = 1.0_DFP + VoigtMatSymISO4( 3, 3 ) = 1.0_DFP + VoigtMatSymISO4( 4, 4 ) = 0.5_DFP + VoigtMatSymISO4( 5, 5 ) = 0.5_DFP + VoigtMatSymISO4( 6, 6 ) = 0.5_DFP + CASE( 4 ) + VoigtMatSymISO4( 1, 1 ) = 1.0_DFP + VoigtMatSymISO4( 2, 2 ) = 1.0_DFP + VoigtMatSymISO4( 4, 4 ) = 1.0_DFP + VoigtMatSymISO4( 3, 3 ) = 0.5_DFP + CASE( 3 ) + VoigtMatSymISO4( 1, 1 ) = 1.0_DFP + VoigtMatSymISO4( 2, 2 ) = 1.0_DFP + VoigtMatSymISO4( 3, 3 ) = 0.5_DFP + CASE( 1 ) + VoigtMatSymISO4( 1, 1 ) = 1.0_DFP + CASE DEFAULT + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "VoigtMatSymISO4(), Flag-1", "Unknown N" ) + Error_Flag = .TRUE. + RETURN + END SELECT +! + END FUNCTION VoigtMatSymISO4 +! +!------------------------------------------------------------------------------ +! VoigtMatAntiSymISO4 +!------------------------------------------------------------------------------ +! + FUNCTION VoigtMatAntiSymISO4( N ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - +! +!------------------------------------------------------------------------------ +! +! Define Intent of dummy variables + INTEGER( I4B ), INTENT( IN ) :: N + REAL( DFP ), DIMENSION( N, N ) :: VoigtMatAntiSymISO4 +! + VoigtMatAntiSymISO4 = 0.0_DFP + Error_Flag = .FALSE. +! + SELECT CASE( N ) + CASE( 6 ) + VoigtMatAntiSymISO4( 4, 4 ) = 0.5_DFP + VoigtMatAntiSymISO4( 5, 5 ) = 0.5_DFP + VoigtMatAntiSymISO4( 6, 6 ) = 0.5_DFP + CASE( 4 ) + VoigtMatAntiSymISO4( 3, 3 ) = 0.5_DFP + CASE( 3 ) + + CASE( 1 ) + + CASE DEFAULT + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "VoigtMatAntiSymISO4(), Flag-1", "Unknown N" ) + Error_Flag = .TRUE. + RETURN + END SELECT +! + END FUNCTION VoigtMatAntiSymISO4 +! +!------------------------------------------------------------------------------ +! MatTriadMat +!------------------------------------------------------------------------------ +! +SUBROUTINE MatTriadMat( C, A, B, TriadType ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - C = A Triad B +! - TriadType = "NA", "UPBar", "DownBar", "UpTilde", "DownTilde" +! +!------------------------------------------------------------------------------ +! + USE Utility, ONLY : Assert_Eq +! Define Intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, B + REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: TriadType +! +! Define internal variables + INTEGER( I4B ) :: N, II, JJ, i, j, k, l + INTEGER( I4B ), ALLOCATABLE, DIMENSION( :, : ) :: Indx + Error_Flag = .FALSE. + N = Assert_Eq( (/SIZE( A, 1 ), SIZE( A, 2 ), SIZE( B, 1 ), SIZE( B, 2 )/), & + "Tensor.F90>>Rank4Tensors.part>>MatTriadMat()") +! + SELECT CASE( N ) + CASE( 3 ) +! + ALLOCATE( Indx( 6, 2 ) ) + IndX( 1, 1 ) = 1; IndX( 1, 2 ) = 1 + IndX( 2, 1 ) = 2; IndX( 2, 2 ) = 2 + IndX( 3, 1 ) = 3; IndX( 3, 2 ) = 3 + IndX( 4, 1 ) = 1; IndX( 4, 2 ) = 2 + IndX( 5, 1 ) = 2; IndX( 5, 2 ) = 3 + IndX( 6, 1 ) = 1; IndX( 6, 2 ) = 3 +! + DO II = 1, 6 + i = Indx( II, 1 ); j = Indx( II, 2 ) + DO JJ = 1, 6 + k = Indx( JJ, 1 ); l = Indx( JJ, 2 ) + SELECT CASE( TRIM( TriadType ) ) + CASE( "NA", "Na", "na", "Default", "DEFAULT", " " ) + C( II, JJ ) = A( i, j ) * B( k, l ) + CASE( "BarUp", "UpBar", "BARUP", "UPBAR", "Bar_Up", "Up_Bar" ) + C( II, JJ ) = A( i, k ) * B( j, l ) + CASE( "BarDown", "DownBar", "BARDOWN", "DOWNBAR", "Bar_Down", & + "Down_Bar") + C( II, JJ ) = A( i, l ) * B( j, k ) + CASE DEFAULT +! Flag-1 + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "MatTriadMat( ), Flag-2", "Unknown TriadType" ) + Error_Flag = .TRUE. + RETURN + END SELECT + END DO + END DO + DEALLOCATE( Indx ) +! + CASE( 2 ) +! + ALLOCATE( Indx( 4, 2 ) ) + IndX( 1, 1 ) = 1; IndX( 1, 2 ) = 1 + IndX( 2, 1 ) = 2; IndX( 2, 2 ) = 2 + IndX( 3, 1 ) = 1; IndX( 3, 2 ) = 2 + IndX( 4, 1 ) = 3; IndX( 4, 2 ) = 3 +! + DO II = 1, 4 + i = Indx( II, 1 ); j = Indx( II, 2 ) + DO JJ = 1, 4 + k = Indx( JJ, 1 ); l = Indx( JJ, 2 ) + SELECT CASE( TRIM( TriadType ) ) + CASE( "NA", "Na", "na", "Default", "DEFAULT", " " ) + C( II, JJ ) = A( i, j ) * B( k, l ) + CASE( "BarUp", "UpBar", "BARUP", "UPBAR", "Bar_Up", "Up_Bar" ) + C( II, JJ ) = A( i, k ) * B( j, l ) + CASE( "BarDown", "DownBar", "BARDOWN", "DOWNBAR", "Bar_Down", & + "Down_Bar") + C( II, JJ ) = A( i, l ) * B( j, k ) + CASE( "TildeDown", "DownTilde", "TILDEDOWN", "DOWNTILDE", & + "Tilde_Down", "Down_Tilde") + C( II, JJ ) = A( i, l ) * B( k, j ) + CASE( "TildeUp", "UpTilde", "TILDEUP", "UPTILDE", & + "Tilde_Up", "Up_Tilde") + C( II, JJ ) = A( i, k ) * B( l, j ) + CASE DEFAULT +! Flag-2 + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "MatTriadMat( ), Flag-2", "Unknown TriadType" ) + Error_Flag = .TRUE. + RETURN + END SELECT + END DO + END DO + DEALLOCATE( Indx ) +! + CASE DEFAULT +! Flag-3 + CALL Err_Msg( "Tensor.F90>>Rank4Tensors.part", & + "MatTriadMat( ), Flag-1", "Unknown N" ) + Error_Flag = .TRUE. + RETURN + END SELECT +! +END SUBROUTINE MatTriadMat +! +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part b/src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part new file mode 100755 index 000000000..985b4fbc3 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Old_StrainMeasures.part @@ -0,0 +1,349 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StrainMeasures.part +! Last Update : September-03-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Module +! +! Info:: - This module includes subroutine for computing various strain +! Measures +! +!============================================================================== +! +! List of items +! +! To Do:: Add subroutine for Seth-Hill General Strain Measures +! +! +!------------------------------------------------------------------------------ +! +! +!------------------------------------------------------------------------------ +! DeformationTensor +!------------------------------------------------------------------------------ +! + FUNCTION DeformationTensor( F, DefTensorType ) + ! + ! Description + !------------------------------------------------------------------------------ + ! 1. - This subroutine computes deformation tensor + ! - Right Cauchy Green Deformation Tensor C = F^T F + ! - Left Cauchy Green Deformation Tensro b = F F^T + ! + !------------------------------------------------------------------------------ + ! + USE Utility, ONLY: Inv + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F + REAL( DFP ), DIMENSION( SIZE( F, 1 ), SIZE( F, 2 ) ) :: DeformationTensor + CHARACTER( LEN = * ), INTENT( IN ) :: DefTensorType +! +! Define internal variables + REAL( DFP ), DIMENSION( SIZE( F, 1 ), SIZE( F, 2 ) ) :: DummyMat + Error_Flag = .FALSE. +! + SELECT CASE( TRIM( DefTensorType ) ) + CASE( "Right", "C", "right", "c" ) + DeformationTensor = MATMUL( TRANSPOSE( F ), F ) + CASE( "Left", "left", "b", "B" ) + DeformationTensor = MATMUL( F, TRANSPOSE( F ) ) + CASE( "BInv", "bInv", "binv", "Binv" ) + DummyMat = MATMUL( F, TRANSPOSE( F ) ) + CALL Inv( A = DummyMat, InvA = DeformationTensor ) +! Flag-1 + CASE DEFAULT + CALL Err_Msg( "Tensor.F90>>StrainMeasures.part", & + "DeformationTensor(), Flag-1", "Unknown Deformation Tensor Type" ) + Error_Flag = .TRUE. + RETURN + END SELECT +! + END FUNCTION DeformationTensor +! +!------------------------------------------------------------------------------ +! GreenStrainTensor +!------------------------------------------------------------------------------ +! + SUBROUTINE GreenStrainTensor( E, F, C, U ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - This subroutine computes deformation tensor +! - Right Cauchy Green Deformation Tensor C = F^T F +! - Left Cauchy Green Deformation Tensro b = F F^T +! +!------------------------------------------------------------------------------ +! + USE Utility, ONLY: Assert_Eq, Eye +! Define Intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F, C, U + REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: E + ! + ! Internal varible + INTEGER( I4B ) :: N + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: I + + Error_Flag = .FALSE. + + N = Assert_Eq( SIZE( E, 1 ), SIZE( E, 2 ), & + "Tensor.F90>>StrainMeasures.part" ) + + ALLOCATE( I( N, N ) ) + I = Eye( N ) + + IF( PRESENT( F ) ) THEN + E = 0.5_DFP * ( DeformationTensor( F, "C" ) - I ) + DEALLOCATE( I ) + RETURN + ELSE IF( PRESENT( C ) ) THEN + E = 0.5_DFP * ( C - I ) + DEALLOCATE( I ) + RETURN + ELSE IF( PRESENT( U ) ) THEN + E = 0.5*( MATMUL( U, U ) - I ) + DEALLOCATE( I ) + RETURN + ELSE +! Flag-1 + CALL Err_Msg( " Tensor.F90 >> StrainMeasures.part", & + "GreenStrainTensor(), Flag-1" , " Both C and F cannot be present") + Error_Flag = .TRUE. + DEALLOCATE( I ) + RETURN + END IF +! + END SUBROUTINE GreenStrainTensor +! +!------------------------------------------------------------------------------ +! AlmansiStrainTensor +!------------------------------------------------------------------------------ +! + SUBROUTINE AlmansiStrainTensor( e, F, B, bInv, V ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - This subroutine computes deformation tensor +! - Right Cauchy Green Deformation Tensor C = F^T F +! - Left Cauchy Green Deformation Tensro b = F F^T +! +!------------------------------------------------------------------------------ +! +USE Utility, ONLY: Assert_Eq, Eye, Inv +! Define Intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F, B, bInv, V + REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: e +! +! Internal varible + INTEGER( I4B ) :: N + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ) :: I + + Error_Flag = .FALSE. + + N = Assert_Eq( SIZE( e, 1 ), SIZE( e, 2 ), & + "Tensor.F90>>StrainMeasures.part" ) + + ALLOCATE( I( N, N ) ) + + IF( PRESENT( F ) ) THEN + e = 0.5_DFP * ( I - DeformationTensor( F, "bInv" ) ) + DEALLOCATE( I ) + RETURN + ELSE IF ( PRESENT( B ) ) THEN + CALL INV ( A = B, INVA = I ) + e = -0.5_DFP * I + I = Eye( N ) + e = e + 0.5_DFP * I + DEALLOCATE( I ) + RETURN + ELSE IF ( PRESENT( bInv ) ) THEN + I = Eye( N ) + e = 0.5_DFP * ( I - bInv ) + DEALLOCATE( I ) + RETURN + ELSE IF( PRESENT( V ) ) THEN + CALL INV( A = V, INVA = I ) + e = -0.5_DFP*MATMUL( I, I ) + I = Eye( N ) + e = e + 0.5_DFP * I + DEALLOCATE( I ) + RETURN + ELSE +! Flag-1 + CALL Err_Msg( " Tensor.F90 >> StrainMeasures.part", & + "AlmansiStrainTensor(), Flag-1" , " Both B and F cannot be present") + Error_Flag = .TRUE. + DEALLOCATE( I ) + RETURN + END IF +! +END SUBROUTINE AlmansiStrainTensor +! +!------------------------------------------------------------------------------ +! StretchTensor +!------------------------------------------------------------------------------ +! + SUBROUTINE StretchTensor( C, B, F, U, V ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - This subroutine computes deformation tensor +! - Right Cauchy Green Deformation Tensor C = F^T F +! - Left Cauchy Green Deformation Tensro b = F F^T +! +!------------------------------------------------------------------------------ +! +USE LinearAlgebra, ONLY: GetSymEigenJacobi +USE Utility, ONLY: Put_Diag +! Define Intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( INOUT ), OPTIONAL :: F, B, C + REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ), OPTIONAL :: U, V +! +! Internal varible + REAL( DFP ), ALLOCATABLE :: EigenVals( : ), EigenVecs( :, : ), DummyMat(:,:) + + Error_Flag = .FALSE. +! + IF( PRESENT( U ) ) THEN +! + IF( PRESENT( F ) ) THEN + ALLOCATE( DummyMat( SIZE( F, 1 ), SIZE( F, 2 ) ) ) + DummyMat = 0.0_DFP + CALL getPolarDecomp( T = F, R = DummyMat, H = U, PDType = "U" ) + DEALLOCATE( DummyMat ) +! + ELSE IF( PRESENT( C ) ) THEN + ALLOCATE( DummyMat( SIZE( C, 1 ), SIZE( C, 2 ) ) ) + ALLOCATE( EigenVals( SIZE( C, 1 ) ) ) + ALLOCATE( EigenVecs( SIZE( C, 1 ), SIZE( C, 2 ) ) ) + DummyMat = 0.0_DFP +! Flag-1 + CALL GetSymEigenJacobi( Mat = C, EigenVals = EigenVals, & + EigenVecs = EigenVecs, MaxIter = 20 ) + CALL Check_Error( "Tensor.F90>>StrainMeasures.part", & + "StretchTensor(), Flag-1" ) +! + EigenVals( : ) = SQRT( EigenVals ( : ) ) +! + CALL Put_Diag( EigenVals, DummyMat ) +! + U = MATMUL( EigenVecs, & + MATMUL( DummyMat, TRANSPOSE( EigenVecs) ) ) + + DEALLOCATE( DummyMat, EigenVals, EigenVecs ) +! + ELSE + CALL Err_Msg( "Tensor.F90>>StrainMeasures.part", & + "StretchTensor(), Flag-2", & + "To Find U either F or C should be present") + END IF + END IF +! + IF( PRESENT( V ) ) THEN + IF( PRESENT( F ) ) THEN + ALLOCATE( DummyMat( SIZE( F, 1 ), SIZE( F, 2 ) ) ) + DummyMat = 0.0_DFP + CALL getPolarDecomp( T = F, R = DummyMat, H = V, PDType = "V" ) + DEALLOCATE( DummyMat ) +! + ELSE IF( PRESENT( B ) ) THEN + ALLOCATE( DummyMat( SIZE( B, 1 ), SIZE( B, 2 ) ) ) + ALLOCATE( EigenVals( SIZE( B, 1 ) ) ) + ALLOCATE( EigenVecs( SIZE( B, 1 ), SIZE( B, 2 ) ) ) + DummyMat = 0.0_DFP +! Flag-2 + CALL GetSymEigenJacobi( Mat = B, EigenVals = EigenVals, & + EigenVecs = EigenVecs, MaxIter = 20 ) + CALL Check_Error( " Tensor.F90>>StrainMeasures.part", & + "StretchTensor(), Flag-2" ) +! + EigenVals( : ) = SQRT( EigenVals ( : ) ) +! + CALL Put_Diag( EigenVals, DummyMat ) +! + V = MATMUL( EigenVecs, & + MATMUL( DummyMat, TRANSPOSE( EigenVecs) ) ) +! + DEALLOCATE( DummyMat, EigenVals, EigenVecs ) +!Flag-3 + ELSE + CALL Err_Msg( "Tensor.F90>>StrainMeasures.part", & + "StretchTensor(), Flag-3", & + "To Find V either F or B should be present") + END IF +! + END IF +! + END SUBROUTINE StretchTensor +! +!------------------------------------------------------------------------------ +! F_Distortional +!------------------------------------------------------------------------------ +! + FUNCTION F_Distortional( F, J ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - This subroutine computes Distortional part of Deformation +! gradient tensor +! +!------------------------------------------------------------------------------ +! +USE Utility, ONLY: det +! Define Intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: F + REAL( DFP ), DIMENSION( SIZE( F, 1 ), SIZE( F, 2 ) ) :: F_Distortional + REAL( DFP ), INTENT( IN ), OPTIONAL :: J +! Define internal variables + REAL( DFP ) :: DetF + + Error_Flag = .FALSE. + + IF( PRESENT( J ) ) THEN + DetF = J + ELSE + DetF = det( F ) + END IF +! + F_Distortional = ( DetF ** ( -1.0_DFP / 3.0_DFP ) ) * F +! +END FUNCTION F_Distortional +! +!------------------------------------------------------------------------------ +! StretchTensor +!------------------------------------------------------------------------------ +! + FUNCTION C_Distortional( C, J ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - This subroutine computes Distortional part of the Right +! Cauchy deformation tensor +! +!------------------------------------------------------------------------------ +! + USE Utility, ONLY: det +! Define Intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( SIZE( C, 1 ), SIZE( C, 2 ) ) :: C_Distortional + REAL( DFP ), INTENT( IN ), OPTIONAL :: J +! Define internal variables + REAL( DFP ) :: DetC + + Error_Flag = .FALSE. + + IF( PRESENT( J ) ) THEN + DetC = J*J + ELSE + DetC = det( C ) + END IF + + C_Distortional = ( DetC ** ( -1.0_DFP / 3.0_DFP ) ) * C +! + END FUNCTION C_Distortional diff --git a/src/submodules/Rank2Tensor/src/old data/Old_getCDash.part b/src/submodules/Rank2Tensor/src/old data/Old_getCDash.part new file mode 100755 index 000000000..768e40479 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Old_getCDash.part @@ -0,0 +1,151 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: getCDash.part +! Last Update : August-27-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Module +! +! Info:: - This part includes subroutine for getting C-Dash Matrix +! C-Dash is a matrix for 4th order tensor which has both major +! and Minor symmetry. C-dash is only the funciton of Cauchy Stress +! C_dash : d = Sigma . d + d . Sigma +! +! +!============================================================================== +! +! List of items +! +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! getCSigmaTruesdell +!------------------------------------------------------------------------------ +! + SUBROUTINE getCDash( C, Stress, StressType, F, J ) +! +! Description +!------------------------------------------------------------------------------ +! 1. This Function computes "CDash" which is frequently appeared +! in computing CsigmaTruesdell. +! StressType is for Stress Tensor +! 2. C has INTENT(OUT) +! 3. F and J are Optional arguments which are needed incase StressType +! is not Cauchy Stress. It will be used for conversion +! +!------------------------------------------------------------------------------ +! Define arguments of dummy argument + REAL( DFP ), DIMENSION( :, : ), INTENT( OUT ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Stress + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F + REAL( DFP ), INTENT( IN ), OPTIONAL :: J + CHARACTER( LEN = * ), INTENT( IN ) :: StressType +! +! Define internal variables + REAL( DFP ), DIMENSION( :, : ), ALLOCATABLE :: Sigma + REAL( DFP ) :: d2 = 2.0_DFP, pt5 = 0.5_DFP +! + Error_Flag = .FALSE. +! +! get Cauchy Stress + ALLOCATE( Sigma( SIZE( Stress, 1 ), SIZE( Stress, 2 ) ) ) +! Flag-1 + CALL getCauchyStress( Sigma = Sigma, Stress = Stress, & + StressType = StressType ) + CALL Check_Error( "Utility>>Tensor.F90>>getCDash.part", & + "getCDash() >> Flag-1" ) +! + C = 0.0_DFP +! +SELECT CASE( SIZE( C, 1 ) ) + CASE( 6 ) + C ( 1, 1 ) = d2 * Sigma( 1, 1 ) + !C ( 1, 2 ) = C ( 1, 2 ) - 0.0_DFP + !C ( 1, 3 ) = C ( 1, 3 ) - 0.0_DFP + C ( 1, 4 ) = Sigma( 1, 2 ) + !C ( 1, 5 ) = C ( 1, 5 ) - 0.0_DFP + C ( 1, 6 ) = Sigma( 1, 3 ) + + !C ( 2, 1 ) = C ( 2, 1 ) - 0.0_DFP + C ( 2, 2 ) = d2 * Sigma( 2, 2 ) + !C ( 2, 3 ) = C ( 2, 3 ) - 0.0_DFP + C ( 2, 4 ) = Sigma( 2, 1 ) + C ( 2, 5 ) = Sigma( 2, 3 ) + !C ( 2, 6 ) = C ( 2, 6 ) - 0.0_DFP + + !C ( 3, 1 ) = C ( 3, 1 ) - 0.0_DFP + !C ( 3, 2 ) = C ( 3, 2 ) - 0.0_DFP + C ( 3, 3 ) = d2 * Sigma( 3, 3 ) + !C ( 3, 4 ) = C ( 3, 4 ) - 0.0_DFP + C ( 3, 5 ) = Sigma( 2, 3 ) + C ( 3, 6 ) = Sigma( 1, 3 ) + + C ( 4, 1 ) = Sigma( 1, 2 ) + C ( 4, 2 ) = Sigma( 1, 2 ) + !C ( 4, 3 ) = C ( 4, 3 ) - 0.0_DFP + C ( 4, 4 ) = pt5 * Sigma( 1, 1 ) + pt5 * Sigma( 2, 2 ) + C ( 4, 5 ) = pt5 * Sigma( 1, 3 ) + C ( 4, 6 ) = pt5 * Sigma( 2, 3 ) + + !C ( 5, 1 ) = C ( 5, 1 ) - 0.0_DFP + C ( 5, 2 ) = Sigma( 2, 3 ) + C ( 5, 3 ) = Sigma( 2, 3 ) + C ( 5, 4 ) = pt5 * Sigma( 1, 3 ) + C ( 5, 5 ) = pt5 * Sigma( 2, 2 ) + pt5 * Sigma( 3, 3 ) + C ( 5, 6 ) = pt5 * Sigma( 2, 1 ) + + + C ( 6, 1 ) = Sigma( 1, 3 ) + !C ( 6, 2 ) = C ( 6, 2 ) - 0.0_DFP + C ( 6, 3 ) = Sigma( 1, 3 ) + C ( 6, 4 ) = pt5 * Sigma( 2, 3 ) + C ( 6, 5 ) = pt5 * Sigma( 2, 1 ) + C ( 6, 6 ) = pt5 * Sigma( 1, 1 ) + pt5 * Sigma( 3, 3 ) + + CASE( 4 ) + + C ( 1, 1 ) = d2 * Sigma( 1, 1 ) + !C ( 1, 2 ) = C ( 1, 2 ) - 0.0_DFP + C ( 1, 3 ) = Sigma( 1, 2 ) + !C ( 1, 4 ) = C ( 1, 4 ) - 0.0_DFP + + !C ( 2, 1 ) = C ( 2, 1 ) - 0.0_DFP + C ( 2, 2 ) = d2 * Sigma( 2, 2 ) + C ( 2, 3 ) = Sigma( 1, 2 ) + !C ( 2, 4 ) = C ( 2, 4 ) - 0.0_DFP + + C ( 3, 1 ) = Sigma( 1, 2 ) + C ( 3, 2 ) = Sigma( 1, 2 ) + C ( 3, 3 ) = pt5 * Sigma( 1, 1 ) + pt5 * Sigma( 2, 2 ) + !C ( 3, 4 ) = C ( 3, 4 ) - 0.0_DFP + + !C ( 4, 1 ) = C ( 4, 1 ) - 0.0_DFP + !C ( 4, 2 ) = C ( 4, 2 ) - 0.0_DFP + !C ( 4, 3 ) = C ( 4, 3 ) - 0.0_DFP + IF ( SIZE( Sigma, 1 ) .EQ. 3 ) THEN + C ( 4, 4 ) = d2 * Sigma( 3, 3 ) + END IF + + CASE ( 1 ) + C ( 1, 1 ) = d2 * Sigma( 1, 1 ) +! Flag-2 + CASE DEFAULT + CALL Err_Msg( "Utility>>Tensor.F90>>getCDash.part", & + "getCDash(), Flag-2", " Unknown Shape of C matrix " ) + END SELECT +! + DEALLOCATE( Sigma ) +! + END SUBROUTINE getCDash +! +!------------------------------------------------------------------------------ +! getCSigmaTruesdell +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part b/src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part new file mode 100755 index 000000000..12c794e0a --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Old_getCSigmaTruesdell.part @@ -0,0 +1,237 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: getCSigmaTruesdell.part +! Last Update : August-27-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Module +! +! Info:: - This module includes subroutine for tensor operations +! +! Hosting File :- Tensor.F90 +! +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getCSigmaTruesdell +!------------------------------------------------------------------------------ +! + SUBROUTINE getCSigmaTruesdell( C, Stress, StressType, StressRateType, F, J ) + USE Utility, ONLY : OUTERPROD + USE Voigt +! +! Description +!------------------------------------------------------------------------------ +! 1. This Function computes "CsigmaTruesdell" which is used in +! Linearization of virtual work. +! StressType is for Stress Tensor +! 2. C has INTENT(INOUT ) +! 3. Stress Rate Type provides information to the program about the +! type of C matrix. Sigma( StressRateType ) = C:d +! 4. Note Changes will appear in C +! 5. F and J are Optional arguments which are needed incase StressType +! is not Cauchy Stress. +! It will be used for conversion +! +!------------------------------------------------------------------------------ +! Define arguments of dummy argument + REAL( DFP ), DIMENSION( :, : ), INTENT( INOUT ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: Stress + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ), OPTIONAL :: F + REAL( DFP ), INTENT( IN ), OPTIONAL :: J + CHARACTER( LEN = * ), INTENT( IN ), OPTIONAL :: StressType + CHARACTER( LEN = * ), INTENT( IN ) :: StressRateType +! Define internal variables + REAL( DFP ), DIMENSION( :, : ), ALLOCATABLE :: Sigma, DummyMat, B + INTEGER( I4B ), DIMENSION( :, : ), ALLOCATABLE :: Indx + REAL( DFP ) :: d2 = 2.0_DFP, pt5 = 0.5_DFP + INTEGER( I4B ) :: ii, jj, M +! +! get Cauchy Stress + IF( PRESENT( Stress ) ) THEN + ALLOCATE( Sigma( SIZE( Stress, 1 ), SIZE( Stress, 2 ) ) ) +! Flag-1 + CALL getCauchyStress( Sigma = Sigma, Stress = Stress, & + StressType = StressType ) + CALL Check_Error( "Utility>>Tensor.F90>>getCSigmaTruesdell.part", & + "getCSigmaTruesdell() >> Flag-1" ) + END IF +! +! Build case based on Stress Rate Type + SELECT CASE( TRIM( StressRateType ) ) +! +!------------------------------------------------------------------------------- +! Jaumann Stress Rate +!------------------------------------------------------------------------------- +! + CASE( "Jaumann", "JaumannZaremba", "JZ" ) + SELECT CASE( SIZE( C, 1 ) ) + CASE( 6 ) + C ( 1, 1 ) = C ( 1, 1 ) - Sigma( 1, 1 ) + C ( 1, 2 ) = C ( 1, 2 ) + Sigma( 1, 1 ) + C ( 1, 3 ) = C ( 1, 3 ) + Sigma( 1, 1 ) + C ( 1, 4 ) = C ( 1, 4 ) - Sigma( 1, 2 ) + !C ( 1, 5 ) = C ( 1, 5 ) - 0.0_DFP + C ( 1, 6 ) = C ( 1, 6 ) - Sigma( 1, 3 ) + + C ( 2, 1 ) = C ( 2, 1 ) + Sigma( 2, 2 ) + C ( 2, 2 ) = C ( 2, 2 ) - Sigma( 2, 2 ) + C ( 2, 3 ) = C ( 2, 3 ) + Sigma( 2, 2 ) + C ( 2, 4 ) = C ( 2, 4 ) - Sigma( 2, 1 ) + C ( 2, 5 ) = C ( 2, 5 ) - Sigma( 2, 3 ) + !C ( 2, 6 ) = C ( 2, 6 ) - 0.0_DFP + + C ( 3, 1 ) = C ( 3, 1 ) + Sigma( 3, 3 ) + C ( 3, 2 ) = C ( 3, 2 ) + Sigma( 3, 3 ) + C ( 3, 3 ) = C ( 3, 3 ) - Sigma( 3, 3 ) + !C ( 3, 4 ) = C ( 3, 4 ) - 0.0_DFP + C ( 3, 5 ) = C ( 3, 5 ) - Sigma( 2, 3 ) + C ( 3, 6 ) = C ( 3, 6 ) - Sigma( 1, 3 ) + + !C ( 4, 1 ) = C ( 4, 1 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) + !C ( 4, 2 ) = C ( 4, 2 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) + C ( 4, 3 ) = C ( 4, 3 ) + Sigma( 1, 2 ) + C ( 4, 4 ) = C ( 4, 4 ) - pt5 * Sigma( 1, 1 ) - pt5 * Sigma( 2, 2 ) + C ( 4, 5 ) = C ( 4, 5 ) - pt5 * Sigma( 1, 3 ) + C ( 4, 6 ) = C ( 4, 6 ) - pt5 * Sigma( 2, 3 ) + + C ( 5, 1 ) = C ( 5, 1 ) + Sigma( 2, 3 ) + !C ( 5, 2 ) = C ( 5, 2 ) - Sigma( 2, 3 ) + Sigma( 2, 3 ) + !C ( 5, 3 ) = C ( 5, 3 ) - Sigma( 2, 3 ) + Sigma( 2, 3 ) + C ( 5, 4 ) = C ( 5, 4 ) - pt5 * Sigma( 1, 3 ) + C ( 5, 5 ) = C ( 5, 5 ) - pt5 * Sigma( 2, 2 ) - pt5 * Sigma( 3, 3 ) + C ( 5, 6 ) = C ( 5, 6 ) - pt5 * Sigma( 2, 1 ) + + + !C ( 6, 1 ) = C ( 6, 1 ) - Sigma( 1, 3 ) + Sigma( 1, 3 ) + C ( 6, 2 ) = C ( 6, 2 ) + Sigma( 1, 3 ) + !C ( 6, 3 ) = C ( 6, 3 ) - Sigma( 1, 3 ) + Sigma( 1, 3 ) + C ( 6, 4 ) = C ( 6, 4 ) - pt5 * Sigma( 2, 3 ) + C ( 6, 5 ) = C ( 6, 5 ) - pt5 * Sigma( 2, 1 ) + C ( 6, 6 ) = C ( 6, 6 ) - pt5 * Sigma( 1, 1 ) - pt5 * Sigma( 3, 3 ) + + CASE( 4 ) + + C ( 1, 1 ) = C ( 1, 1 ) - Sigma( 1, 1 ) + C ( 1, 2 ) = C ( 1, 2 ) + Sigma( 1, 1 ) + C ( 1, 3 ) = C ( 1, 3 ) - Sigma( 1, 2 ) + C ( 1, 4 ) = C ( 1, 4 ) + Sigma( 1, 1 ) + + C ( 2, 1 ) = C ( 2, 1 ) + Sigma( 2, 2 ) + C ( 2, 2 ) = C ( 2, 2 ) - Sigma( 2, 2 ) + C ( 2, 3 ) = C ( 2, 3 ) - Sigma( 1, 2 ) + C ( 2, 4 ) = C ( 2, 4 ) + Sigma( 2, 2 ) + + !C ( 3, 1 ) = C ( 3, 1 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) + !C ( 3, 2 ) = C ( 3, 2 ) - Sigma( 1, 2 ) + Sigma( 1, 2 ) + C ( 3, 3 ) = C ( 3, 3 ) - pt5 * Sigma( 1, 1 ) - pt5 * Sigma( 2, 2 ) + C ( 3, 4 ) = C ( 3, 4 ) + Sigma( 1, 2 ) + + IF ( SIZE ( Sigma, 1 ) .EQ. 3 ) THEN + C ( 4, 1 ) = C ( 4, 1 ) + Sigma( 3, 3 ) + C ( 4, 2 ) = C ( 4, 2 ) + Sigma( 3, 3 ) + !C ( 4, 3 ) = C ( 4, 3 ) - 0.0_DFP + C ( 4, 4 ) = C ( 4, 4 ) - Sigma( 3, 3 ) + END IF + + CASE ( 1 ) + C ( 1, 1 ) = C ( 1 , 1 ) - Sigma( 1, 1 ) + END SELECT +! +!------------------------------------------------------------------------------- +! Jaumann Stress Rate +!------------------------------------------------------------------------------- +! + CASE( "Truesdell", "truesdell" ) + RETURN ! Do nothing and return +! +!------------------------------------------------------------------------------- +! SE +!------------------------------------------------------------------------------- +! + CASE( "SE", "se", "NA" ) +! Flag-2 + IF( .NOT. PRESENT( F ) .OR. .NOT. PRESENT( J ) ) THEN + CALL Err_Msg( "Utility>>Tensor.part>>getCSigmaTruesdell.part", & + " getCSigmaTruesdell(), Flag-2 ", & + " F and J are missing in arguments ") + Error_Flag = .TRUE. + RETURN + END IF +! + ALLOCATE( B( SIZE( C, 1 ), SIZE( C, 2 ) ) ) + ALLOCATE( DummyMat( SIZE( F, 2 ), SIZE( F, 2 ) ) ) + ALLOCATE( Indx( SIZE( C, 1 ), 2 ) ) + + SELECT CASE( SIZE( Indx, 1 ) ) + CASE( 6 ) + Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 + Indx( 2, 1 ) = 2; Indx( 2, 2 ) = 2 + Indx( 3, 1 ) = 3; Indx( 3, 2 ) = 3 + Indx( 4, 1 ) = 1; Indx( 4, 2 ) = 2 + Indx( 5, 1 ) = 2; Indx( 5, 2 ) = 3 + Indx( 6, 1 ) = 1; Indx( 6, 2 ) = 3 + CASE(4) + Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 + Indx( 2, 1 ) = 2; Indx( 2, 2 ) = 2 + Indx( 3, 1 ) = 1; Indx( 3, 2 ) = 2 + Indx( 4, 1 ) = 3; Indx( 4, 2 ) = 3 + CASE(3) + Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 + Indx( 2, 1 ) = 2; Indx( 2, 2 ) = 2 + Indx( 3, 1 ) = 1; Indx( 3, 2 ) = 2 + CASE(1) + Indx( 1, 1 ) = 1; Indx( 1, 2 ) = 1 +! Flag-3 + CASE DEFAULT + CALL Err_Msg( "Utility>>Tensor.part", & + " getCSigmaTruesdell(), Flag-3 ", & + "No case found for given Size of C") + Error_Flag = .TRUE. + RETURN + END SELECT + + DO M = 1, SIZE( Indx, 1 ) + ii = Indx( M, 1); jj = Indx( M, 2 ) + DummyMat = 0.0_DFP + DummyMat = OUTERPROD( a = F( ii, : ), b = F( jj, : ) ) +! Flag-4 + CALL Matrix2Voigt( Mat = DummyMat, VoigtVec = B( :, M ), & + VoigtType = "Strain" ) + CALL Check_Error( "Utility>>Tensor.F90>>getCSigmaTruesdell.part", & + "getCSigmaTruesdell() >> Flag-4" ) + END DO + + IF( ALLOCATED( DummyMat ) ) DEALLOCATE( DummyMat ) + ALLOCATE( DummyMat( SIZE( C, 1), SIZE( C, 2 ) ) ) + DummyMat = MATMUL( TRANSPOSE( B ), MATMUL( C, B ) ) + C = DummyMat / J +! Flag-5 + CASE DEFAULT + CALL Err_Msg( "Utility>>Tensor.part", & + " getCSigmaTruesdell(), Flag-5 ", & + "Unknown Stress Rate Type") + Error_Flag = .TRUE. + RETURN +! + END SELECT +! + IF( ALLOCATED( Sigma ) ) DEALLOCATE( Sigma ) + IF( ALLOCATED( B ) ) DEALLOCATE( B ) + IF( ALLOCATED( DummyMat ) ) DEALLOCATE( DummyMat ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) +! + END SUBROUTINE getCSigmaTruesdell + ! + ! + !------------------------------------------------------------------------------ + ! getCSigmaTruesdell + !------------------------------------------------------------------------------ + ! diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorInterface.part b/src/submodules/Rank2Tensor/src/old data/OperatorInterface.part new file mode 100755 index 000000000..25a3dce88 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorInterface.part @@ -0,0 +1,217 @@ + + INTERFACE OPERATOR( .X. ) + + MODULE PROCEDURE VectorProduct2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Angle. ) + + MODULE PROCEDURE getAngle + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .ProjectOn. ) + + MODULE PROCEDURE getProjection + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .UnitVector. ) + + MODULE PROCEDURE UnitVector + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .dot. ) + + MODULE PROCEDURE DotProduct + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .ComponentNormalTo. ) + + MODULE PROCEDURE getNormalComponent + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .ComponentParallelTo. ) + + MODULE PROCEDURE getProjection + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Trace. ) + + MODULE PROCEDURE Trace_1, Trace_2 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .DoubleDot. ) + + MODULE PROCEDURE DoubleDot_Product1, DoubleDot_Product2, & + DoubleDot_Product3, DoubleDot_Product7 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Sym. ) + + MODULE PROCEDURE f_SymmetricPart, m_SymmetricPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Anti. ) + + MODULE PROCEDURE f_AntiSymmetricPart, m_AntiSymmetricPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Hydro. ) + + MODULE PROCEDURE f_HydrostaticPart, m_HydrostaticPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Dev. ) + + MODULE PROCEDURE f_DeviatoricPart, m_DeviatoricPart + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Contraction. ) + + MODULE PROCEDURE DoubleDot_Product1, DoubleDot_Product2, & + DoubleDot_Product3, DoubleDot_Product7, TensorTimesVector, & + VectorTimesTensor, MatVec, VecMat, VecVec + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .matmul. ) + + MODULE PROCEDURE MatVec, VecMat, MatMat, MatMul_1, MatMul_2, & + MatMul_3, TensorTimesVector, VectorTimesTensor + + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .det. ) + + MODULE PROCEDURE f_Det_1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .Otimes. ) + + MODULE PROCEDURE Mat_Dyadic_Mat + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .inverse. ) + + MODULE PROCEDURE f_inverse_1 + + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .inv. ) + + MODULE PROCEDURE f_inverse_1, m_inverse_1 + + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE OPERATOR( .transpose. ) + + MODULE PROCEDURE Transpose_2, Transpose_1 + + END INTERFACE diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part new file mode 100755 index 000000000..a33d44be1 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Addition.part @@ -0,0 +1,220 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Addition.part +! Last Update : Dec-13-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Tensor class is defined +! HOSTING FILE +! - Rank2Tensor_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_obj( obj, obj2 ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_obj + + obj_Add_obj = obj%T + obj2%T + + END FUNCTION obj_Add_obj + +!------------------------------------------------------------------------------ +! obj_Add_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_Mat( obj, Mat ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Mat + + obj_Add_Mat = obj%T + Mat + + END FUNCTION obj_Add_Mat + +!------------------------------------------------------------------------------ +! Mat_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_Add_obj( Mat, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Add_obj + + Mat_Add_obj = obj%T + Mat + + END FUNCTION Mat_Add_obj + + +!------------------------------------------------------------------------------ +! obj_Add_Scalar +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_Scalar( obj, S ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Scalar + + obj_Add_Scalar = obj%T + S + + END FUNCTION obj_Add_Scalar + +!------------------------------------------------------------------------------ +! obj_Add_Scalar +!------------------------------------------------------------------------------ + + FUNCTION Scalar_Add_obj( S, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Add_obj + + Scalar_Add_obj = obj_Add_Scalar( obj, S ) + + END FUNCTION Scalar_Add_obj + +!------------------------------------------------------------------------------ +! obj_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_obj( obj, obj2 ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_obj + + obj_Minus_obj = obj%T - obj2%T + + END FUNCTION obj_Minus_obj + +!------------------------------------------------------------------------------ +! obj_Minus_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_Mat( obj, Mat ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Mat + + obj_Minus_Mat = obj%T - Mat + + END FUNCTION obj_Minus_Mat + +!------------------------------------------------------------------------------ +! Mat_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_Minus_obj( Mat, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Minus_obj + + Mat_Minus_obj = Mat - obj%T + + END FUNCTION Mat_Minus_obj + +!------------------------------------------------------------------------------ +! obj_Minus_Scalar +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_Scalar( obj, S ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Scalar + + obj_Minus_Scalar = obj%T - S + + END FUNCTION obj_Minus_Scalar + +!------------------------------------------------------------------------------ +! Scalar_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION Scalar_Minus_obj( S, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Minus_obj + + Scalar_Minus_obj = -obj_Minus_Scalar( obj, S ) + + END FUNCTION Scalar_Minus_obj + + diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part new file mode 100755 index 000000000..e07111d7b --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Asterics.part @@ -0,0 +1,373 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Asterics.part +! Last Update : Dec-13-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Tensor class is defined +! HOSTING FILE +! - Rank2Tensor_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! TensorTimesScalar_1 +!------------------------------------------------------------------------------ +! + FUNCTION TensorTimesScalar_1( obj, Scalar ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_1 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "TensorTimesScalar_1()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + TensorTimesScalar_1 = obj%T * Scalar + + END FUNCTION TensorTimesScalar_1 +! +!------------------------------------------------------------------------------ +! TensorTimesScalar_2 +!------------------------------------------------------------------------------ +! + FUNCTION TensorTimesScalar_2( Scalar, obj ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_2 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "TensorTimesScalar_2()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + TensorTimesScalar_2 = obj%T * Scalar + + END FUNCTION TensorTimesScalar_2 +! +!------------------------------------------------------------------------------ +! TensorTimesScalar_3 +!------------------------------------------------------------------------------ +! + FUNCTION TensorTimesScalar_3( obj, Scalar ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_3 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "TensorTimesScalar_3()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + TensorTimesScalar_3 = obj%T * Scalar + + END FUNCTION TensorTimesScalar_3 +! +!------------------------------------------------------------------------------ +! TensorTimesScalar_4 +!------------------------------------------------------------------------------ +! + FUNCTION TensorTimesScalar_4( Scalar, obj ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesScalar_4 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "TensorTimesScalar_4()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + TensorTimesScalar_4 = obj%T * Scalar + + END FUNCTION TensorTimesScalar_4 +! +!------------------------------------------------------------------------------ +! TensorTimesTensor +!------------------------------------------------------------------------------ +! + FUNCTION TensorTimesTensor( obj, obj2 ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesTensor + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) & + .OR. .NOT. ALLOCATED( obj2%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "TensorTimesTensor()", & + "Tensor_ obj is/are not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + TensorTimesTensor = obj%T * obj2%T + + END FUNCTION TensorTimesTensor +! +!------------------------------------------------------------------------------ +! TensorTimesVector +!------------------------------------------------------------------------------ +! + FUNCTION TensorTimesVector( obj, Vec ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. Vec = [T] * {v} +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: TensorTimesVector + +! Define internal variables + + Error_Flag = .FALSE. + + TensorTimesVector = 0.0_DFP + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "TensorTimesVector()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + SELECT CASE( SIZE( Vec ) ) + + CASE( 1 ) + + TensorTimesVector( 1 ) = obj%T( 1, 1 ) * Vec( 1 ) + + CASE( 2 ) + + TensorTimesVector( 1 : 2 ) = MATMUL( obj%T( 1:2, 1:2 ), Vec( 1:2 ) ) + + CASE( 3 ) + + TensorTimesVector = MATMUL( obj%T, Vec ) + + END SELECT + + + END FUNCTION TensorTimesVector +! +!------------------------------------------------------------------------------ +! VectorTimesTensor +!------------------------------------------------------------------------------ +! + FUNCTION VectorTimesTensor( Vec, obj ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. Vec = {v}*[T] = [T]^T {v} +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: VectorTimesTensor + +! Define internal variables + + Error_Flag = .FALSE. + + VectorTimesTensor = 0.0_DFP + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "VectorTimesTensor()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + SELECT CASE( SIZE( Vec ) ) + + CASE( 1 ) + + VectorTimesTensor( 1 ) = obj%T( 1, 1 ) * Vec( 1 ) + + CASE( 2 ) + + VectorTimesTensor( 1 : 2 ) = MATMUL( TRANSPOSE( obj%T( 1:2, 1:2 ) ), Vec( 1:2 ) ) + + CASE( 3 ) + + VectorTimesTensor = MATMUL( TRANSPOSE( obj%T ), Vec ) + + END SELECT + + END FUNCTION VectorTimesTensor +! +!------------------------------------------------------------------------------ +! TensorTimesMat +!------------------------------------------------------------------------------ +! + FUNCTION TensorTimesMat( obj, Mat ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesMat + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "TensorTimesMat()", & + "Tensor_ obj not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + TensorTimesMat = obj%T * Mat + + END FUNCTION TensorTimesMat +! +!------------------------------------------------------------------------------ +! MatTimesTensor +!------------------------------------------------------------------------------ +! + FUNCTION MatTimesTensor( Mat, obj ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: MatTimesTensor + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Asterics.part", & + "MatTimesTensor()", & + "Tensor_ obj not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + MatTimesTensor = obj%T * Mat + + END FUNCTION MatTimesTensor +! \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part new file mode 100755 index 000000000..1c82bc891 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Determinant.part @@ -0,0 +1,60 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Determinant.part +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Tensor class is defined +! HOSTING FILE +! - Rank2Tensor_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! f_Det_1 +!------------------------------------------------------------------------------ + + FUNCTION f_Det_1( Mat ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . +! 1. - determinent +!. . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : Det + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ) :: f_Det_1 + + f_Det_1 = Det( Mat ) + + END FUNCTION f_Det_1 + +!------------------------------------------------------------------------------ +! m_Det_1 +!------------------------------------------------------------------------------ + + FUNCTION m_Det_1( obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . +! 1. - determinent +!. . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : Det + + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ) :: m_Det_1 + + m_Det_1 = Det( obj%T ) + + END FUNCTION m_Det_1 + diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part new file mode 100755 index 000000000..e6a63ccc8 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Inverse.part @@ -0,0 +1,65 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Inverse.part +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Tensor class is defined +! HOSTING FILE +! - Rank2Tensor_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! f_inverse_1 +!------------------------------------------------------------------------------ + +FUNCTION f_inverse_1( Mat ) + + USE Utility, ONLY : INV + + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( SIZE( Mat,1 ), SIZE( Mat, 2 ) ) :: f_inverse_1 + + + Error_Flag = .FALSE. + + CALL INV( A = Mat, INVA = f_inverse_1 ) + + CALL Check_Error( & + "Rank2Tensor_Class.F90>>Inverse.part>>f_inverse_1()", & + "Traceback ---> CALL INV( A = Mat, INVA = Mat )" & + ) + +END FUNCTION f_inverse_1 + +!------------------------------------------------------------------------------ +! m_inverse_1 +!------------------------------------------------------------------------------ + +FUNCTION m_inverse_1( obj ) + + USE Utility, ONLY : INV + + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_inverse_1 + + + Error_Flag = .FALSE. + + CALL INV( A = obj%T, INVA = m_inverse_1 ) + + CALL Check_Error( & + "Rank2Tensor_Class.F90>>Inverse.part>>m_inverse_1()", & + "Traceback ---> CALL INV( A = Mat, INVA = Mat )" & + ) + +END FUNCTION m_inverse_1 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part new file mode 100755 index 000000000..386b715f3 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/MatMul.part @@ -0,0 +1,257 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MatMul.part +! Last Update : Dec-13-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Tensor class is defined +! HOSTING FILE +! - Rank2Tensor_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! MatMul_1 +!------------------------------------------------------------------------------ +! + FUNCTION MatMul_1( obj, obj2 ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Tensor Class +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_1 + + Error_Flag = .FALSE. + +#ifdef DEBUG_VER + IF( .NOT. ALLOCATED( obj%T ) & + .OR. .NOT. ALLOCATED( obj2%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>OperatorOverloading.part", & + "MatMul_1()", & + "Tensor_ obj is/are not allocated. Program Stopped"& + ) + Error_Flag = .TRUE. + + STOP + + END IF +#endif + MatMul_1 = MATMUL( obj%T, obj2%T ) + + END FUNCTION MatMul_1 +! +!------------------------------------------------------------------------------ +! MatMul_2 +!------------------------------------------------------------------------------ +! + FUNCTION MatMul_2( obj, Mat2 ) +! +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. - obj .matmul. Mat +!. . . . . . . . . . . . . . . . . . . . +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_2 + + ! Define internal variables + INTEGER( I4B ) :: N + Error_Flag = .FALSE. + +#ifdef DEBUG_VER + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>OperatorOverloading.part", & + "MatMul_2()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF +#endif + + N = SIZE( Mat2, 1 ) + MatMul_2 = 0.0_DFP + + SELECT CASE( N ) + + CASE( 1 ) + + MatMul_2( 1, 1 ) = obj%T( 1, 1 ) * Mat2( 1, 1 ) + + CASE( 2 ) + + MatMul_2( 1:2, 1:2 ) = MATMUL(obj%T( 1:2, 1:2 ), Mat2( 1:2, 1:2 )) + + CASE DEFAULT + + MatMul_2( 1:3, 1:3 ) = MATMUL(obj%T( 1:3, 1:3 ), Mat2( 1:3, 1:3 )) + + END SELECT + + END FUNCTION MatMul_2 +! +!------------------------------------------------------------------------------ +! MatMul_3 +!------------------------------------------------------------------------------ +! + FUNCTION MatMul_3( Mat2, obj ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Mat .matmul. obj +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( 3, 3 ) :: MatMul_3 + + ! Define internal variables + INTEGER( I4B ) :: N + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>OperatorOverloading.part", & + "MatMul_3()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + N = SIZE( Mat2, 1 ) + MatMul_3 = 0.0_DFP + + SELECT CASE( N ) + + CASE( 1 ) + + MatMul_3( 1, 1 ) = obj%T( 1, 1 ) * Mat2( 1, 1 ) + + CASE( 2 ) + + MatMul_3( 1:2, 1:2 ) = MATMUL( Mat2( 1:2, 1:2 ), obj%T( 1:2, 1:2 ) ) + + CASE DEFAULT + + MatMul_3( 1:3, 1:3 ) = MATMUL( Mat2( 1:3, 1:3 ), obj%T( 1:3, 1:3 ) ) + + END SELECT + + END FUNCTION MatMul_3 + +!------------------------------------------------------------------------------ +! MatVec +!------------------------------------------------------------------------------ + + FUNCTION MatVec( Mat2, Vec ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . +! 1. - Used for defining the contraction operator +!. . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: MatVec + + MatVec = MATMUL( Mat2, Vec ) + + END FUNCTION MatVec + +!------------------------------------------------------------------------------ +! VecMat +!------------------------------------------------------------------------------ + + FUNCTION VecMat( Vec, Mat2 ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . +! 1. - used for defining the contraction operator +!. . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( SIZE( Vec ) ) :: VecMat + + VecMat = MATMUL( TRANSPOSE( Mat2 ), Vec ) + + END FUNCTION VecMat + +!------------------------------------------------------------------------------ +! VecVec +!------------------------------------------------------------------------------ + + FUNCTION VecVec( Vec, Vec2 ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . +! 1. - used for defining the contraction operator +!. . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ) :: VecVec + + VecVec = DOT_PRODUCT( Vec, Vec2 ) + + END FUNCTION VecVec + +!------------------------------------------------------------------------------ +! MatMat +!------------------------------------------------------------------------------ + + FUNCTION MatMat( Mat1, Mat2 ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . +! 1. - used for defining the contraction operator +!. . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat1 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( SIZE( Mat1, 1 ), SIZE( Mat2, 2) ) :: MatMat + + IF( SIZE( Mat1, 2 ) .NE. SIZE( Mat2, 1 ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>MatMul.part>", & + "Mat .matmul. Mat", & + "Matrix multiplication is not compatible, Program Stopped!!!" & + ) + STOP + END IF + + MatMat = MATMUL( Mat1, Mat2 ) + + END FUNCTION MatMat diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part new file mode 100755 index 000000000..c966472e8 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Otimes.part @@ -0,0 +1,292 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Otimes.part +! Last Update : Dec-13-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPsTION +! - Otimes operator is defined +! HOSTING FILE +! - Rank2Tensor_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Tensor_Dyadic_Tensor +!------------------------------------------------------------------------------ + + FUNCTION Tensor_Dyadic_Tensor( obj, obj2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Tensor + + ! Define internal variables + + INTEGER( I4B ) :: Index( 6, 2 ), I, J + + Error_Flag = .FALSE. + + Tensor_Dyadic_Tensor = 0.0_DFP + + IF( .NOT. ALLOCATED( obj%T ) .OR. .NOT. ALLOCATED( obj2%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Otimes.part", & + ".Otimes.()", & + "Tensor_ obj is/are not allocated. Program Stopped"& + ) + Error_Flag = .TRUE. + + STOP + + END IF + + IF( .NOT. obj%isSymmetric( ) .OR. .NOT. obj2%isSymmetric( ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Otimes.part", & + ".Otimes.()", & + "Tensor_ obj is/are not symmmetric.Program Stopped"& + ) + Error_Flag = .TRUE. + + STOP + + END IF + + Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 + Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 + Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 + Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 + Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 + Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 + + + DO I = 1, SIZE( Index, 1 ) + + DO J = 1, SIZE( Index, 1 ) + + Tensor_Dyadic_Tensor( I, J ) = & + obj%T( Index( I, 1 ), Index( I, 2 ) ) & + * obj2%T( Index( J, 1 ), Index( J, 2 ) ) + + END DO + + END DO + + END FUNCTION Tensor_Dyadic_Tensor + +!------------------------------------------------------------------------------ +! Tensor_Dyadic_Mat +!------------------------------------------------------------------------------ + + FUNCTION Tensor_Dyadic_Mat( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Dyadic_Mat + + ! Define internal variables + + INTEGER( I4B ) :: Index( 6, 2 ), I, J + + Error_Flag = .FALSE. + + Tensor_Dyadic_Mat = 0.0_DFP + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Otimes.part", & + ".Otimes.()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + IF( .NOT. obj%isSymmetric( ) .OR. .NOT. isSymmetric( Mat ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Otimes.part", & + ".Otimes.()", & + "Tensor_ obj is/are not symmmetric.Program Stopped"& + ) + Error_Flag = .TRUE. + + STOP + + END IF + + Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 + Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 + Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 + Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 + Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 + Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 + + + DO I = 1, SIZE( Index, 1 ) + + DO J = 1, SIZE( Index, 1 ) + + Tensor_Dyadic_Mat( I, J ) = & + obj%T( Index( I, 1 ), Index( I, 2 ) ) & + * Mat( Index( J, 1 ), Index( J, 2 ) ) + + END DO + + END DO + + END FUNCTION Tensor_Dyadic_Mat +! +!------------------------------------------------------------------------------ +! Mat_Dyadic_Tensor +!------------------------------------------------------------------------------ +! + FUNCTION Mat_Dyadic_Tensor( Mat, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat .otimes. obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Dyadic_Tensor + + ! Define internal variables + + INTEGER( I4B ) :: Index( 6, 2 ), I, J + + Error_Flag = .FALSE. + + Mat_Dyadic_Tensor = 0.0_DFP + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Otimes.part", & + ".Otimes.", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + IF( .NOT. obj%isSymmetric( ) .OR. .NOT. isSymmetric( Mat ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Otimes.part", & + ".Otimes.", & + "Tensor_ obj is/are not symmmetric.Program Stopped"& + ) + Error_Flag = .TRUE. + + STOP + + END IF + + Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 + Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 + Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 + Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 + Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 + Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 + + + DO I = 1, SIZE( Index, 1 ) + + DO J = 1, SIZE( Index, 1 ) + + Mat_Dyadic_Tensor( I, J ) = & + Mat( Index( I, 1 ), Index( I, 2 ) ) & + * obj%T( Index( J, 1 ), Index( J, 2 ) ) + + END DO + + END DO + + END FUNCTION Mat_Dyadic_Tensor + +!------------------------------------------------------------------------------ +! Mat_Dyadic_Mat +!------------------------------------------------------------------------------ + + FUNCTION Mat_Dyadic_Mat( Mat, Mat2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat .otimes. obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( IN ) :: Mat, Mat2 + REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Dyadic_Mat + + ! Define internal variables + + INTEGER( I4B ) :: Index( 6, 2 ), I, J + + Error_Flag = .FALSE. + + Mat_Dyadic_Mat = 0.0_DFP + + IF( .NOT. isSymmetric( Mat2 ) .OR. .NOT. isSymmetric( Mat ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>Otimes.part", & + ".Otimes.", & + "Matrix is/are not symmmetric.Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + Index( 1, 1 ) = 1; Index( 1, 2 ) = 1 + Index( 2, 1 ) = 2; Index( 2, 2 ) = 2 + Index( 3, 1 ) = 3; Index( 3, 2 ) = 3 + Index( 4, 1 ) = 1; Index( 4, 2 ) = 2 + Index( 5, 1 ) = 2; Index( 5, 2 ) = 3 + Index( 6, 1 ) = 1; Index( 6, 2 ) = 3 + + + DO I = 1, SIZE( Index, 1 ) + + DO J = 1, SIZE( Index, 1 ) + + Mat_Dyadic_Mat( I, J ) = & + Mat( Index( I, 1 ), Index( I, 2 ) ) & + * Mat2( Index( J, 1 ), Index( J, 2 ) ) + + END DO + + END DO + + END FUNCTION Mat_Dyadic_Mat diff --git a/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part new file mode 100755 index 000000000..6bceb1624 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/OperatorOverloading/Transpose.part @@ -0,0 +1,72 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Transpose.part +! Last Update : Dec-13-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Tensor class is defined +! HOSTING FILE +! - Rank2Tensor_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! Transpose_1 +!------------------------------------------------------------------------------ + + FUNCTION Transpose_1( obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. transpose of obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Rank2Tensor_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: Transpose_1 + + IF( .NOT. ALLOCATED( obj%T ) ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>OperatorOverloading.part", & + ".Transpose.()", & + "Tensor_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + + Transpose_1 = TRANSPOSE( obj%T ) + + END FUNCTION Transpose_1 + +!------------------------------------------------------------------------------ +! Transpose_2 +!------------------------------------------------------------------------------ + + FUNCTION Transpose_2( Mat ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. transpose +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( SIZE( Mat, 1 ), SIZE( Mat, 2 ) ) :: Transpose_2 + + Transpose_2 = TRANSPOSE( Mat ) + + END FUNCTION Transpose_2 +! diff --git a/src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 b/src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 new file mode 100755 index 000000000..7858f0ea9 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/RightCauchyGreen/RightCauchyGreen_Class.F90 @@ -0,0 +1,100 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: RightCauchyGreen_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Left Cauchy green tensor +!============================================================================== + + MODULE RightCauchyGreen_Class + USE GlobalData + USE IO + USE Rank2Tensor_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: RightCauchyGreen_, RightCauchyGreen, RightCauchyGreen_Pointer + +!------------------------------------------------------------------------------ +! RightCauchyGreen_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Rank2Tensor_ ) :: RightCauchyGreen_ + + END TYPE RightCauchyGreen_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE RightCauchyGreen + MODULE PROCEDURE Constructor1 + END INTERFACE + + INTERFACE RightCauchyGreen_Pointer + MODULE PROCEDURE Constructor_1 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy varialbes + CLASS( RightCauchyGreen_ ), POINTER :: Constructor_1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + ALLOCATE( Constructor_1 ) + Constructor_1 = ( .transpose. F ) .matmul. F + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy variables + TYPE( RightCauchyGreen_ ) :: Constructor1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + Constructor1 = ( .transpose. F ) .matmul. F + + END FUNCTION Constructor1 + + END MODULE RightCauchyGreen_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 new file mode 100755 index 000000000..94ec4aa5e --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Strain/AlmansiStrain_Class.F90 @@ -0,0 +1,145 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: AlmansiStrain_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define AlmansiStrain Class +!============================================================================== + + MODULE AlmansiStrain_Class + USE GlobalData + USE IO + USE Strain_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: AlmansiStrain_, AlmansiStrain, AlmansiStrain_Pointer + +!------------------------------------------------------------------------------ +! AlmansiStrain_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Strain_ ) :: AlmansiStrain_ + + END TYPE AlmansiStrain_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE AlmansiStrain + MODULE PROCEDURE Constructor1, Constructor2 + END INTERFACE + + INTERFACE AlmansiStrain_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy varialbes + CLASS( AlmansiStrain_ ), POINTER :: Constructor_1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + ALLOCATE( Constructor_1 ) + Constructor_1 = .AlmansiStrain. F + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( B ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using Right Cauchy Green tensor +!. . . . . . . . . . . . . . . . . . . . + + USE LeftCauchyGreen_Class + + ! Define intent of dummy varialbes + CLASS( AlmansiStrain_ ), POINTER :: Constructor_2 + TYPE( LeftCauchyGreen_ ), INTENT( IN ) :: B + + ALLOCATE( Constructor_2 ) + Constructor_2 = 0.5_DFP*( Eye3 - ( .inv. B ) ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy variables + TYPE( AlmansiStrain_ ) :: Constructor1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + Constructor1 = .AlmansiStrain. F + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( B ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using Right Cauchy Green tensor +!. . . . . . . . . . . . . . . . . . . . + + USE LeftCauchyGreen_Class + + ! Define intent of dummy varialbes + TYPE( AlmansiStrain_ ) :: Constructor2 + TYPE( LeftCauchyGreen_ ), INTENT( IN ) :: B + + Constructor2 = 0.5_DFP*( Eye3 - ( .inv. B ) ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + + END MODULE AlmansiStrain_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 new file mode 100755 index 000000000..c6cd51c99 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Strain/GreenStrain_Class.F90 @@ -0,0 +1,142 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: GreenStrain_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define GreenStrain Class +!============================================================================== + + MODULE GreenStrain_Class + USE GlobalData + USE IO + USE Strain_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: GreenStrain_, GreenStrain, GreenStrain_Pointer + +!------------------------------------------------------------------------------ +! GreenStrain_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Strain_ ) :: GreenStrain_ + + END TYPE GreenStrain_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE GreenStrain + MODULE PROCEDURE Constructor1, Constructor2 + END INTERFACE + + INTERFACE GreenStrain_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy varialbes + CLASS( GreenStrain_ ), POINTER :: Constructor_1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + ALLOCATE( Constructor_1 ) + Constructor_1 = .GreenStrain. F + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( C ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using Right Cauchy Green tensor +!. . . . . . . . . . . . . . . . . . . . + + USE RightCauchyGreen_Class + + ! Define intent of dummy varialbes + CLASS( GreenStrain_ ), POINTER :: Constructor_2 + TYPE( RightCauchyGreen_ ), INTENT( IN ) :: C + + ALLOCATE( Constructor_2 ) + Constructor_2 = 0.5_DFP*( C - Eye3 ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using deformation gradient tensor +!. . . . . . . . . . . . . . . . . . . . + + USE DeformationGradient_Class + + ! Define intent of dummy variables + TYPE( GreenStrain_ ) :: Constructor1 + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + + Constructor1 = .GreenStrain. F + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( C ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Constructing using Right Cauchy Green tensor +!. . . . . . . . . . . . . . . . . . . . + + USE RightCauchyGreen_Class + + ! Define intent of dummy varialbes + TYPE( GreenStrain_ ) :: Constructor2 + TYPE( RightCauchyGreen_ ), INTENT( IN ) :: C + + + Constructor2 = 0.5_DFP*( C - Eye3 ) + + END FUNCTION Constructor2 + + END MODULE GreenStrain_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 new file mode 100755 index 000000000..256be7fbd --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Strain/SmallStrain_Class.F90 @@ -0,0 +1,88 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SmallStrain_Class.F90 +! Last Update : Dec-30-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define SmallStrain Class +!============================================================================== + + MODULE SmallStrain_Class + USE GlobalData + USE IO + USE Strain_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: SmallStrain_, SmallStrain, SmallStrain_Pointer + +!------------------------------------------------------------------------------ +! SmallStrain_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Strain_ ) :: SmallStrain_ + + END TYPE SmallStrain_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE SmallStrain + MODULE PROCEDURE Constructor1 + END INTERFACE + + INTERFACE SmallStrain_Pointer + MODULE PROCEDURE Constructor_1 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Construction +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy varialbes + CLASS( SmallStrain_ ), POINTER :: Constructor_1 + ALLOCATE( Constructor_1 ) + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Construction +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( SmallStrain_ ) :: Constructor1 + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + + END MODULE SmallStrain_Class + diff --git a/src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 new file mode 100755 index 000000000..1da7b4374 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Strain/Strain_Class.F90 @@ -0,0 +1,96 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Strain_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define Strain Class +!============================================================================== + + MODULE Strain_Class + USE GlobalData + USE IO + USE Rank2Tensor_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: Strain_, Strain, Strain_Pointer + +!------------------------------------------------------------------------------ +! Strain_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Rank2Tensor_ ) :: Strain_ + + END TYPE Strain_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE Strain + MODULE PROCEDURE Constructor1 + END INTERFACE + + INTERFACE Strain_Pointer + MODULE PROCEDURE Constructor_1 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty strain constructor +!. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy varialbes + CLASS( Strain_ ), POINTER :: Constructor_1 + + ALLOCATE( Constructor_1 ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty strain constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( Strain_ ) :: Constructor1 + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + + END MODULE Strain_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 b/src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 new file mode 100755 index 000000000..bd237c8da --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/StrainRate/StrainRate_Class.F90 @@ -0,0 +1,137 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StrainRate_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define StrainRate Class +!============================================================================== + + MODULE StrainRate_Class + USE GlobalData + USE IO + USE Rank2Tensor_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: StrainRate_, StrainRate, StrainRate_Pointer + +!------------------------------------------------------------------------------ +! StrainRate_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Rank2Tensor_ ) :: StrainRate_ + + END TYPE StrainRate_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE StrainRate + MODULE PROCEDURE Constructor1, Constructor2 + END INTERFACE + + INTERFACE StrainRate_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy varialbes + CLASS( StrainRate_ ), POINTER :: Constructor_1 + + ALLOCATE( Constructor_1 ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( L ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + USE VelocityGradient_Class + + ! Define intent of dummy varialbes + CLASS( StrainRate_ ), POINTER :: Constructor_2 + TYPE( VelocityGradient_ ), INTENT( IN ) :: L + + ALLOCATE( Constructor_2 ) + Constructor_2 = .Sym. L + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( StrainRate_ ) :: Constructor1 + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( L ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + USE VelocityGradient_Class + + ! Define intent of dummy varialbes + TYPE( StrainRate_ ) :: Constructor2 + TYPE( VelocityGradient_ ), INTENT( IN ) :: L + + Constructor2 = .Sym. L + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + + END MODULE StrainRate_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part new file mode 100755 index 000000000..de1fbbd70 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/CauchyStress.part @@ -0,0 +1,109 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: CauchyStress.part +! Last Update : Dec-28-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of Module +! +! Description :: +! - This part includes subroutine for getting Cauchy Stress from +! any other Stress Measures +! Hosting File :: +! - Stress_Class +!============================================================================== + +!------------------------------------------------------------------------------ +! getCauchyStress +!------------------------------------------------------------------------------ + + FUNCTION getCauchyStress( obj, F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. This subroutine computes the Cauchy stress from given stress type +! 2. Fobj is Deformation Gradient object. +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE DeformationGradient_Class + + ! Define arguments of dummy argument + CLASS( Stress_ ), INTENT( IN ) :: obj + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + REAL( DFP ), ALLOCATABLE :: getCauchyStress( :, : ) + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + REAL( DFP ) :: J + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>CauchyStress.part", & + "getCauchyStress()", & + "Stress_ object is not initiated. & + Program Stopped !!!" & + ) + STOP + + END IF + + T = obj + + SELECT CASE( TRIM( obj%StressType ) ) + + CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) + + getCauchyStress = T + + CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) + + J = .det. F + + getCauchyStress = T * ( 1.0_DFP / J ) + + CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) + + J = .det. F + getCauchyStress = ( F .matmul. T ) .matmul. ( .transpose. F ) + getCauchyStress = getCauchyStress * ( 1.0_DFP / J ) + + CASE( "PK1", "Pk1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) + + J = .det. F + getCauchyStress = T .matmul. ( .transpose. F ) + getCauchyStress = getCauchyStress * ( 1.0_DFP / J ) + + CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) + + J = .det. F + getCauchyStress = ( ( .transpose. ( .inv. F ) ) .matmul. T ) .matmul. ( .transpose. F ) + getCauchyStress = getCauchyStress * ( 1.0_DFP / J ) + + + CASE DEFAULT + + CALL Err_Msg( & + "Stress_Class.F90>>CauchyStress.part", & + "getCauchyStress( obj, F )", & + "No case found for obj%StressType. & + Program Stopped!!!" & + ) + STOP + + END SELECT + + CALL T%Deallocate( ) + + END FUNCTION getCauchyStress + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part b/src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part new file mode 100755 index 000000000..afb503a15 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/Constructor.part @@ -0,0 +1,563 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Deformation Gradient class is defined +! HOSTING FILE +! - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Deallocate +!------------------------------------------------------------------------------ + + SUBROUTINE Deallocate( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Deallocate the data +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + IF( ALLOCATED( obj%V ) ) DEALLOCATE( obj%V ) + + END SUBROUTINE Deallocate + +!------------------------------------------------------------------------------ +! isInitiated +!------------------------------------------------------------------------------ + + LOGICAL( LGT ) FUNCTION isInitiated( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Tensor Class +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + isInitiated = .FALSE. + + IF( ALLOCATED( obj%V ) ) THEN + isInitiated = .TRUE. + END IF + + END FUNCTION isInitiated + +!------------------------------------------------------------------------------ +! getNSD +!------------------------------------------------------------------------------ + + INTEGER( I4B ) FUNCTION getNSD( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Tensor Class +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + getNSD = obj%NSD + + END FUNCTION getNSD + +!------------------------------------------------------------------------------ +! getVoigtLen +!------------------------------------------------------------------------------ + + INTEGER( I4B ) FUNCTION getVoigtLen( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Tensor Class +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + IF( ALLOCATED( obj%V ) ) THEN + + getVoigtLen = SIZE( obj%V ) + + ELSE + + CALL Err_Msg( & + "Stress_Class.F90>>Constructor.part", & + ".Size. obj", & + "obj%V is not allocated, Program Stopped!!!"& + ) + + STOP + + END IF + + END FUNCTION getVoigtLen + +!------------------------------------------------------------------------------ +! getNSD +!------------------------------------------------------------------------------ + + SUBROUTINE setNSD( obj, NSD ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Tensor Class +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + INTEGER( I4B ), INTENT( IN ) :: NSD + + obj%NSD = NSD + + END SUBROUTINE setNSD + +!------------------------------------------------------------------------------ +! Initiate1 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate1( obj, Vec, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + ! Define internal variables + INTEGER( I4B ) :: N + + N = SIZE( Vec ) + IF( ALLOCATED( obj%V ) ) DEALLOCATE( obj%V ) + ALLOCATE( obj%V( N ) ) + + obj%V = Vec + + obj%StressType = TRIM( StressType ) + + SELECT CASE( N ) + + CASE( 1 ) + obj%NSD = 1 + CASE( 3 ) + obj%NSD = 2 + CASE( 4 ) + obj%NSD = 2 + CASE( 6 ) + obj%NSD = 3 + + END SELECT + + END SUBROUTINE Initiate1 + +!------------------------------------------------------------------------------ +! Initiate2 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate2( obj, Mat, VoigtLen, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + INTEGER( I4B ), INTENT( IN ) :: VoigtLen + + ! Define internal variable + REAL( DFP ), ALLOCATABLE :: Vec( : ) + + Vec = VoigtVec( Mat, VoigtLen, "Stress") + + CALL Check_Error( & + "Stress_Class.F90>>Constructor.F90>>Initiate()", & + "Traceback ---> obj%V = VoigtVec( Mat, VoigtLen,'Stress') " ) + + CALL obj%Initiate1( Vec = Vec, StressType = StressType ) + + DEALLOCATE( Vec ) + + END SUBROUTINE Initiate2 + +!------------------------------------------------------------------------------ +! Initiate3 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate3( obj, obj2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj Stress obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + CLASS( Stress_ ), INTENT( IN ) :: obj2 + + + IF( ALLOCATED( obj%V ) ) DEALLOCATE( obj%V ) + + IF( ALLOCATED( obj2%V ) ) THEN + + obj%V = obj2%V + + END IF + + obj%StressType = TRIM( obj2%StressType ) + obj%NSD = obj2%NSD + + END SUBROUTINE Initiate3 + +!------------------------------------------------------------------------------ +! Initiate4 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate4( obj, Tensorobj, VoigtLen, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Rank2Tensor object +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + INTEGER( I4B ), INTENT( IN ) :: VoigtLen + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + REAL( DFP ), ALLOCATABLE :: Mat( :, : ) + + Mat = Tensorobj + + CALL obj%Initiate2( Mat = Mat, VoigtLen = VoigtLen, & + StressType = StressType ) + + DEALLOCATE( Mat ) + + END SUBROUTINE Initiate4 + +!------------------------------------------------------------------------------ +! Initiate5 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate5( obj, Mat, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + CALL obj%Initiate2( & + Mat = Mat, & + VoigtLen = 6, & + StressType = StressType & + ) + + END SUBROUTINE Initiate5 + +!------------------------------------------------------------------------------ +! Initiate6 +!------------------------------------------------------------------------------ + + SUBROUTINE Initiate6( obj, Tensorobj, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Rank2Tensor object +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + CALL obj%Initiate4( & + Tensorobj = Tensorobj, & + VoigtLen = 6, & + StressType = StressType & + ) + + END SUBROUTINE Initiate6 + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Vec, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), POINTER :: Constructor_1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + ALLOCATE( Stress_ :: Constructor_1 ) + + CALL Constructor_1%Initiate( Vec = Vec, StressType = StressType ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( Mat, VoigtLen, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), POINTER :: Constructor_2 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + INTEGER( I4B ), INTENT( IN ) :: VoigtLen + + ALLOCATE( Stress_ :: Constructor_2 ) + + CALL Constructor_2%Initiate( Mat = Mat, & + VoigtLen = VoigtLen, StressType = StressType ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), POINTER :: Constructor_3 + CLASS( Stress_ ), INTENT( IN ) :: obj + + ALLOCATE( Stress_ :: Constructor_3 ) + + CALL Constructor_3%Initiate( obj ) + + END FUNCTION Constructor_3 + +!------------------------------------------------------------------------------ +! Constructor_4 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_4( Tensorobj, VoigtLen, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), POINTER :: Constructor_4 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + INTEGER( I4B ), INTENT( IN ) :: VoigtLen + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + ALLOCATE( Stress_ :: Constructor_4 ) + + CALL Constructor_4%Initiate( Tensorobj = Tensorobj, & + VoigtLen = VoigtLen, StressType = StressType ) + + END FUNCTION Constructor_4 + +!------------------------------------------------------------------------------ +! Constructor_5 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_5( Mat, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), POINTER :: Constructor_5 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + ALLOCATE( Stress_ :: Constructor_5 ) + + CALL Constructor_5%Initiate( Mat = Mat, StressType = StressType ) + + END FUNCTION Constructor_5 + +!------------------------------------------------------------------------------ +! Constructor_6 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_6( Tensorobj, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), POINTER :: Constructor_6 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + ALLOCATE( Stress_ :: Constructor_6 ) + + CALL Constructor_6%Initiate( & + Tensorobj = Tensorobj, & + StressType = StressType & + ) + + END FUNCTION Constructor_6 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Vec, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( Stress_ ) :: Constructor1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + CALL Constructor1%Initiate( Vec = Vec, StressType = StressType ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( Mat, VoigtLen, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( Stress_ ) :: Constructor2 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + INTEGER( I4B ), INTENT( IN ) :: VoigtLen + + CALL Constructor2%Initiate( Mat = Mat, & + VoigtLen = VoigtLen, StressType = StressType ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( Stress_ ) :: Constructor3 + CLASS( Stress_ ), INTENT( IN ) :: obj + + CALL Constructor3%Initiate( obj ) + + END FUNCTION Constructor3 + +!------------------------------------------------------------------------------ +! Constructor4 +!------------------------------------------------------------------------------ + + FUNCTION Constructor4( Tensorobj, VoigtLen, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + TYPE( Stress_ ) :: Constructor4 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + INTEGER( I4B ), INTENT( IN ) :: VoigtLen + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + CALL Constructor4%Initiate( Tensorobj = Tensorobj, & + VoigtLen = VoigtLen, StressType = StressType ) + + END FUNCTION Constructor4 + +!------------------------------------------------------------------------------ +! Constructor5 +!------------------------------------------------------------------------------ + + FUNCTION Constructor5( Mat, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( Stress_ ) :: Constructor5 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + CALL Constructor5%Initiate( & + Mat = Mat, & + StressType = StressType & + ) + + END FUNCTION Constructor5 + +!------------------------------------------------------------------------------ +! Constructor6 +!------------------------------------------------------------------------------ + + FUNCTION Constructor6( Tensorobj, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate obj using Voigt vector +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + TYPE( Stress_ ) :: Constructor6 + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + CALL Constructor6%Initiate( & + Tensorobj = Tensorobj, & + StressType = StressType & + ) + + END FUNCTION Constructor6 diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Display.part b/src/submodules/Rank2Tensor/src/old data/Stress/Display.part new file mode 100755 index 000000000..566926b7c --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/Display.part @@ -0,0 +1,71 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Display.part +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Display Stress Tensor +! HOSTING FILE +! - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Display +!------------------------------------------------------------------------------ + + SUBROUTINE Display( obj, UnitNo ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Display Stress Tensor +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : Display_Array + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ), OPTIONAL :: UnitNo + + ! Define internal variables + INTEGER( I4B ) :: I, j + + IF( PRESENT( UnitNo ) ) THEN + I = UnitNo + ELSE + I = 6 + END IF + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL BlankLines( UnitNo = I ) + WRITE( I, "(A)" ) "Stress_ object is not initiated " + WRITE( I, "(A)" ) "Nothing to show " + CALL BlankLines( UnitNo = I ) + RETURN + + END IF + + CALL BlankLines( UnitNo = I ) + CALL EqualLine( UnitNo = I ) + WRITE( I, "(12X, A)" ) "|||| Stress obj Data ||||" + CALL EqualLine( UnitNo = I ) + CALL BlankLines( UnitNo = I ) + + WRITE( I, "(A, I2)" ) "NSD = ", obj%NSD + CALL BlankLines( UnitNo = I ) + WRITE( I, "(A, A)" ) "Stress Type = ", TRIM( obj%StressType ) + + CALL Display_Array( MatFromVoigtVec( obj%V, "Stress" ), "Stress " ) + + CALL DashLine( UnitNo = I ) + + END SUBROUTINE Display \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part new file mode 100755 index 000000000..ebbbbfbd0 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/EshelbyStress.part @@ -0,0 +1,106 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: EshelbyStress.part +! Last Update : Dec-28-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of Module +! +! Description :: +! - This part includes subroutine for getting Eshelby Stress from +! any other Stress Measures +! Hosting File :: +! - Stress_Class +!============================================================================== + +!------------------------------------------------------------------------------ +! getEshelbyStress +!------------------------------------------------------------------------------ + + FUNCTION getEshelbyStress( obj, F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. This subroutine computes the Cauchy stress from given stress type +! 2. Fobj is Deformation Gradient object. +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE DeformationGradient_Class + + ! Define arguments of dummy argument + CLASS( Stress_ ), INTENT( IN ) :: obj + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + REAL( DFP ), ALLOCATABLE :: getEshelbyStress( :, : ) + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + REAL( DFP ), ALLOCATABLE :: InvF( :, : ) + REAL( DFP ) :: J + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>EshelbyStress.part", & + "getEshelbyStress()", & + "Stress_ object is not initiated. & + Program Stopped !!!" & + ) + STOP + + END IF + + T = obj + + SELECT CASE( TRIM( obj%StressType ) ) + + CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) + + J = .det. F + InvF = .Inv. F + getEshelbyStress = (.transpose. F ) .matmul. ( T .matmul. TRANSPOSE( InvF ) ) + getEshelbyStress = J * getEshelbyStress + + CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) + + InvF = .Inv. F + getEshelbyStress = (.transpose. F ) .matmul. ( T .matmul. TRANSPOSE( InvF ) ) + + CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) + + getEshelbyStress = ( (.transpose. F ) .matmul. F ) .matmul. T + + CASE( "PK1", "Pk1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) + + getEshelbyStress = ( .transpose. F ) .matmul. T + + CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) + + getEshelbyStress = T + + CASE DEFAULT + + CALL Err_Msg( & + "Stress_Class.F90>>EshelbyStress.part", & + "getEshelbyStress( obj, F )", & + "No case found for obj%StressType. & + Program Stopped!!!" & + ) + STOP + + END SELECT + + CALL T%Deallocate( ) + IF( ALLOCATED( InvF ) ) DEALLOCATE( InvF ) + + END FUNCTION getEshelbyStress + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Interface.part b/src/submodules/Rank2Tensor/src/old data/Stress/Interface.part new file mode 100755 index 000000000..e69de29bb diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part new file mode 100755 index 000000000..f6b566b8f --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/KirchhoffStress.part @@ -0,0 +1,101 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: KirchhoffStress.part +! Last Update : Dec-28-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of Module +! +! Description :: +! - This part includes subroutine for getting Kirchhoff Stress from +! any other Stress Measures +! Hosting File :: +! - Stress_Class +!============================================================================== + +!------------------------------------------------------------------------------ +! getKirchhoffStress +!------------------------------------------------------------------------------ + + FUNCTION getKirchhoffStress( obj, F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. This subroutine computes the Cauchy stress from given stress type +! 2. Fobj is Deformation Gradient object. +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE DeformationGradient_Class + + ! Define arguments of dummy argument + CLASS( Stress_ ), INTENT( IN ) :: obj + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + REAL( DFP ), ALLOCATABLE :: getKirchhoffStress( :, : ) + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + REAL( DFP ) :: J + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>KirchhoffStress.part", & + "getKirchhoffStress()", & + "Stress_ object is not initiated. & + Program Stopped !!!" & + ) + STOP + + END IF + + T = obj + + SELECT CASE( TRIM( obj%StressType ) ) + + CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) + + J = .det. F + getKirchhoffStress = T * J + + CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) + + getKirchhoffStress = T + + CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) + + getKirchhoffStress = ( F .matmul. T ) .matmul. ( .transpose. F ) + + CASE( "PK1", "Pk1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) + + getKirchhoffStress = T .matmul. ( .transpose. F ) + + CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) + + getKirchhoffStress = ( ( .transpose. ( .inv. F ) ) .matmul. T ) .matmul. ( .transpose. F ) + + CASE DEFAULT + + CALL Err_Msg( & + "Stress_Class.F90>>KirchhoffStress.part", & + "getKirchhoffStress( obj, F )", & + "No case found for obj%StressType. & + Program Stopped!!!" & + ) + STOP + + END SELECT + + CALL T%Deallocate( ) + + END FUNCTION getKirchhoffStress + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md b/src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md new file mode 100755 index 000000000..79e2678af --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/MdFiles/Stress_Class.md @@ -0,0 +1,128 @@ +# Stress Class + +## ToDo + +* Extend Assignment operator for `obj = Mat`. This should not change the stress type +* Extend Assignment operator for `obj = Vec`. This should not change the stress type + +## Structure + +```fortran + TYPE, PUBLIC :: Stress_ + REAL( DFP ), ALLOCATABLE :: V( : ) + INTEGER( I4B ) :: NSD + CHARACTER( LEN = 50 ) :: StressType = "" +``` + +## Description + +## Getting Started + +### Constructing the object + +**Initiate** subroutine + +```fortran +CALL obj%Initiate( Vec, StresType ) +CALL obj%Initiate( Mat, VoigtLen, StressType ) +CALL obj%Initiate( Mat, StressType ) +CALL obj%Initiate( obj2 ) +CALL obj%Initiate( Tensorobj, VoigtLen, StressType ) +CALL obj%Initiate( Tensorobj, StressType ) +``` + +**Stress** function + +```fortran +obj = Stress( Vec, StresType ) +obj = Stress( Mat, VoigtLen, StressType ) +obj = Stress( Mat, StressType ) +obj = Stress( obj2 ) +obj = Stress( Tensorobj, VoigtLen, StressType ) +obj = Stress( Tensorobj, StressType ) +``` + +**Stress_Pointer** function + +```fortran +obj => Stress_Pointer( Vec, StresType ) +obj => Stress_Pointer( Mat, VoigtLen, StressType ) +obj => Stress_Pointer( Mat, StressType ) +obj => Stress_Pointer( obj2 ) +obj => Stress_Pointer( Tensorobj, VoigtLen, StressType ) +obj => Stress_Pointer( Tensorobj, StressType ) +``` + +### Getting the length of `obj%V` + +```fortran +tSize = .SIZE. obj +``` + +The program stops if the `obj%V` is not allocated. + +### Getting the Stress Tensor in Voigt Form + +Many times we need to get the stress tensor in voigt vector form with appropriate length. When we use `obj = Mat` then the voigt vector length will be 6 even if the Mat retpresent the 2D, Rank-2 tensor. Therefore, it is very important to get voigt vector of correct length. For this we have designed the operator called `.Shape.`. `obj .Shape. M` will return voigt vector of length M. + +```fortran +Vec = obj .Shape. M +``` + +Note that M should belong to the list {1,2,3,4,6}. + + +### Assignment Operator + +```fortran +obj = obj2 +Tensorobj = obj +Mat = obj +Vec = obj +obj = Mat +obj = Tensorobj +obj = Vec +``` + +```fortran +obj = obj2 +``` + +The above call we copy `obj2` into `obj` + + +```fortran +Tensorobj = obj +``` + +The above call copies the content of `obj` into Rank2Tensor_ class object `Tensorobj` + +```fortran +Mat = obj +``` + +The above call copies the content of `obj` into the 3 by 3 array. + +```fortran +Vec = obj +``` + +The above call copies the content of the `obj` into the vector. The length of the returned vector is same as the length of `obj%V` + +```fortran +obj = Mat +``` + +The above call copies the content of `Mat` into the stress object `obj`. The `StressType` remains unchanged. + +```fortran +obj = Vec +``` + +The above call copies the content of the `Vec` into the stress object `obj`. The `StressType` remains unchanged. + +```fortran +obj = Tensorobj +``` + +The above call copies the content of the `Rank2Tensor_` object into the stress object `obj`. The `StressType` remains unchanged. \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part new file mode 100755 index 000000000..9d90a8a89 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Addition.part @@ -0,0 +1,372 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Addition.part +! Last Update : Dec-18-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Addition of Stress tensor, returns (3,3) array +! HOSTING FILE +! - Rank2Tensor_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_obj( obj, obj2 ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_obj + + obj_Add_obj = MatFromVoigtVec(obj%V + obj2%V, "Stress") + + END FUNCTION obj_Add_obj + +!------------------------------------------------------------------------------ +! obj_Add_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_Mat( obj, Mat ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Mat + + ! Define internal variables + INTEGER( I4B ) :: N + + N = SIZE( Mat, 1 ) + + obj_Add_Mat = MatFromVoigtVec( obj%V, "Stress" ) + + SELECT CASE( N ) + + CASE( 1 ) + + obj_Add_Mat( 1, 1 ) = obj_Add_Mat( 1, 1 ) + Mat( 1, 1 ) + + CASE( 2 ) + + obj_Add_Mat( 1:2, 1:2 ) = obj_Add_Mat( 1:2, 1:2 ) & + + Mat( 1:2, 1:2 ) + + CASE DEFAULT + + obj_Add_Mat( 1:3, 1:3 ) = obj_Add_Mat( 1:3, 1:3 ) & + + Mat( 1:3, 1:3 ) + + END SELECT + + END FUNCTION obj_Add_Mat + +!------------------------------------------------------------------------------ +! Mat_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_Add_obj( Mat, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat + obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Add_obj + + Mat_Add_obj = obj_Add_Mat( obj, Mat ) + + END FUNCTION Mat_Add_obj + +!------------------------------------------------------------------------------ +! obj_Add_Vec +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_Vec( obj, Vec ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Vec + + ! Define internal variables + INTEGER( I4B ) :: N + REAL( DFP ), ALLOCATABLE :: DummyVec( : ) + + + DummyVec = obj%V + + N = MINVAL( [SIZE( Vec ), SIZE( DummyVec ) ]) + + DummyVec( 1:N ) = DummyVec( 1:N ) + Vec( 1:N ) + + obj_Add_Vec = MatFromVoigtVec( DummyVec, "Stress" ) + + DEALLOCATE( DummyVec ) + + END FUNCTION obj_Add_Vec + +!------------------------------------------------------------------------------ +! obj_Add_Scalar +!------------------------------------------------------------------------------ + + FUNCTION obj_Add_Scalar( obj, S ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Add_Scalar + + obj_Add_Scalar = MatFromVoigtVec( obj%V + S, "Stress" ) + + END FUNCTION obj_Add_Scalar + +!------------------------------------------------------------------------------ +! obj_Add_Scalar +!------------------------------------------------------------------------------ + + FUNCTION Scalar_Add_obj( S, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Add_obj + + Scalar_Add_obj = obj_Add_Scalar( obj, S ) + + END FUNCTION Scalar_Add_obj + +!------------------------------------------------------------------------------ +! Vec_Add_obj +!------------------------------------------------------------------------------ + + FUNCTION Vec_Add_obj( Vec, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3, 3 ) :: Vec_Add_obj + + Vec_Add_obj = obj_Add_Vec( obj, Vec ) + + END FUNCTION Vec_Add_obj + + +!------------------------------------------------------------------------------ +! obj_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_obj( obj, obj2 ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_obj + + obj_Minus_obj = MatFromVoigtVec( obj%V - obj2%V, "Stress" ) + + END FUNCTION obj_Minus_obj + +!------------------------------------------------------------------------------ +! obj_Minus_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_Mat( obj, Mat ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Mat + + ! Define internal variables + INTEGER( I4B ) :: N + + N = SIZE( Mat, 1 ) + + obj_Minus_Mat = MatFromVoigtVec( obj%V, "Stress" ) + + SELECT CASE( N ) + + CASE( 1 ) + + obj_Minus_Mat( 1, 1 ) = obj_Minus_Mat( 1, 1 ) - Mat( 1, 1 ) + + CASE( 2 ) + + obj_Minus_Mat( 1:2, 1:2 ) = obj_Minus_Mat( 1:2, 1:2 ) & + - Mat( 1:2, 1:2 ) + + CASE DEFAULT + + obj_Minus_Mat( 1:3, 1:3 ) = obj_Minus_Mat( 1:3, 1:3 ) & + - Mat( 1:3, 1:3 ) + + END SELECT + + END FUNCTION obj_Minus_Mat + +!------------------------------------------------------------------------------ +! Mat_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_Minus_obj( Mat, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat + obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_Minus_obj + + Mat_Minus_obj = -obj_Minus_Mat( obj, Mat ) + + END FUNCTION Mat_Minus_obj + +!------------------------------------------------------------------------------ +! obj_Minus_Vec +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_Vec( obj, Vec ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Vec + + ! Define internal variables + INTEGER( I4B ) :: N + REAL( DFP ), ALLOCATABLE :: DummyVec( : ) + + DummyVec = obj%V + + N = MINVAL( [SIZE( Vec ), SIZE( DummyVec ) ]) + + DummyVec( 1:N ) = DummyVec( 1:N ) - Vec( 1:N ) + + obj_Minus_Vec = MatFromVoigtVec( DummyVec, "Stress" ) + + DEALLOCATE( DummyVec ) + + END FUNCTION obj_Minus_Vec + +!------------------------------------------------------------------------------ +! Vec_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION Vec_Minus_obj( Vec, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3, 3 ) :: Vec_Minus_obj + + Vec_Minus_obj = -obj_Minus_Vec( obj, Vec ) + + END FUNCTION Vec_Minus_obj + +!------------------------------------------------------------------------------ +! obj_Minus_Scalar +!------------------------------------------------------------------------------ + + FUNCTION obj_Minus_Scalar( obj, S ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_Minus_Scalar + + obj_Minus_Scalar = MatFromVoigtVec( obj%V - S, "Stress" ) + + END FUNCTION obj_Minus_Scalar + +!------------------------------------------------------------------------------ +! Scalar_Minus_obj +!------------------------------------------------------------------------------ + + FUNCTION Scalar_Minus_obj( S, obj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj + Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: S + REAL( DFP ), DIMENSION( 3, 3 ) :: Scalar_Minus_obj + + Scalar_Minus_obj = -obj_Minus_Scalar( obj, S ) + + END FUNCTION Scalar_Minus_obj + + + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part new file mode 100755 index 000000000..7480473a5 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Assignment.part @@ -0,0 +1,94 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Assignment.part +! Last Update : Jan-1-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - Assignment operator is overloaded +! HOSTING FILE +! - Stress_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_From_Tensor +!------------------------------------------------------------------------------ + + SUBROUTINE obj_From_Tensor( obj, Tensorobj ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj = Tensorobj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + + ! Define internal variables + CHARACTER( LEN = 50 ) :: Str + + Str = .StressType. obj + + CALL obj%Initiate( Tensorobj, Str ) + + END SUBROUTINE obj_From_Tensor + +!------------------------------------------------------------------------------ +! obj_From_Mat +!------------------------------------------------------------------------------ + + SUBROUTINE obj_From_Mat( obj, Mat ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj = Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Mat( :, : ) + + ! Define internal variables + CHARACTER( LEN = 50 ) :: Str + + Str = .StressType. obj + + CALL obj%Initiate( Mat, Str ) + + END SUBROUTINE obj_From_Mat + +!------------------------------------------------------------------------------ +! obj_From_Vec +!------------------------------------------------------------------------------ + + SUBROUTINE obj_From_Vec( obj, Vec ) + +! DESCRIPTION +!. . . . . . . . . . . . . . . . . . . . +! 1. obj = Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + REAL( DFP ), INTENT( IN ) :: Vec( : ) + + ! Define internal variables + CHARACTER( LEN = 50 ) :: Str + + Str = .StressType. obj + + CALL obj%Initiate( Vec, Str ) + + END SUBROUTINE obj_From_Vec + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part new file mode 100755 index 000000000..e793a83f1 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Asterics.part @@ -0,0 +1,445 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Asterics.part +! Last Update : Dec-13-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION :: +! - Tensor class is defined +! HOSTING FILE +! - Stress_Class.F90 +!============================================================================== + +!------------------------------------------------------------------------------ +! objTimesScalar_1 +!------------------------------------------------------------------------------ + + FUNCTION objTimesScalar_1( obj, Scalar ) + +!. . . . . . . . . . . . . . . . . . . . +! obj * Scalar +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesScalar_1 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * Real", & + "Stress_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + objTimesScalar_1 = MatFromVoigtVec(obj%V * Scalar, "Stress") + + CALL Check_Error( & + "Stress_Class.F90>>Asterics.part>>obj*Scalar", & + "Traceback ---> & + objTimesScalar_1 = MatFromVoigtVec(obj%V * Scalar,") + + END FUNCTION objTimesScalar_1 + +!------------------------------------------------------------------------------ +! ScalarTimesobj_1 +!------------------------------------------------------------------------------ + + FUNCTION ScalarTimesobj_1( Scalar, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! Scalar*obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: ScalarTimesobj_1 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "Real * obj",& + "Stress_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + ScalarTimesobj_1 = MatFromVoigtVec(obj%V * Scalar, "Stress") + + CALL Check_Error( & + "Stress_Class.F90>>Asterics.part>>obj*Scalar", & + "Traceback ---> & + ScalarTimesobj_1 = MatFromVoigtVec(obj%V * Scalar,") + + END FUNCTION ScalarTimesobj_1 +! +!------------------------------------------------------------------------------ +! objTimesScalar_2 +!------------------------------------------------------------------------------ +! + FUNCTION objTimesScalar_2( obj, Scalar ) +! +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . +! + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesScalar_2 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * Integer", & + "Stress_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + objTimesScalar_2 = MatFromVoigtVec(obj%V * Scalar, "Stress") + + CALL Check_Error( & + "Stress_Class.F90>>Asterics.part>>obj*Scalar", & + "Traceback ---> & + objTimesScalar_2 = MatFromVoigtVec(obj%V * Scalar,") + + END FUNCTION objTimesScalar_2 + +!------------------------------------------------------------------------------ +! ScalarTimesobj_2 +!------------------------------------------------------------------------------ + + FUNCTION ScalarTimesobj_2( Scalar, obj ) +! +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . +! + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: Scalar + REAL( DFP ), DIMENSION( 3, 3 ) :: ScalarTimesobj_2 + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "Integer * obj", & + "Stress_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + ScalarTimesobj_2 = MatFromVoigtVec(obj%V * Scalar, "Stress") + + CALL Check_Error( & + "Stress_Class.F90>>Asterics.part>>obj*Scalar", & + "Traceback ---> & + ScalarTimesobj_2 = MatFromVoigtVec(obj%V * Scalar,") + + END FUNCTION ScalarTimesobj_2 + +!------------------------------------------------------------------------------ +! objTimesobj +!------------------------------------------------------------------------------ + + FUNCTION objTimesobj( obj, obj2 ) + +!. . . . . . . . . . . . . . . . . . . . +! obj%V * obj%V +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesobj + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) & + .OR. .NOT. ALLOCATED( obj2%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * obj", & + "Stress_ obj is/are not allocated. & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + IF( SIZE( obj%V ) .NE. SIZE( obj2%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * obj2 ", & + "The size of obj%V and obj2%V must be the same. & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + objTimesobj = MatFromVoigtVec( obj%V * obj2%V, "Stress" ) + + CALL Check_Error( & + "Stress_Class.F90>>Asterics.part>>obj*Scalar", & + "Traceback ---> & + objTimesobj = MatFromVoigtVec( obj%V * obj2%V,") + + END FUNCTION objTimesobj + +!------------------------------------------------------------------------------ +! objTimesMat +!------------------------------------------------------------------------------ + + FUNCTION objTimesMat( obj, Mat ) + +!. . . . . . . . . . . . . . . . . . . . +! obj * Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesMat + + ! Define internal variables + INTEGER( I4B ) :: m, n + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * Mat", & + "Stress_ obj not allocated. & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + m = SIZE( Mat, 1 ) + + IF( SIZE( Mat, 2 ) .NE. m .OR. m .GT. 3 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * Mat", & + "Mat should be a square matrix of shape & + (3,3), (2,2), (1,1). & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + objTimesMat = MatFromVoigtVec( obj%V, "Stress" ) + + CALL Check_Error( & + "Stress_Class.F90>>Asterics.part>>obj*Scalar", & + "Traceback ---> & + objTimesMat = MatFromVoigtVec( obj%V,") + + n = MIN( m, 3 ) + + objTimesMat( 1:n, 1:n ) = objTimesMat( 1:n, 1:n ) * Mat( 1:n, 1:n ) + + END FUNCTION objTimesMat + +!------------------------------------------------------------------------------ +! MatTimesobj +!------------------------------------------------------------------------------ + + FUNCTION MatTimesobj( Mat, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! Mat * obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 3, 3 ) :: MatTimesobj + + MatTimesobj = objTimesMat( obj, Mat ) + + END FUNCTION MatTimesobj + +!------------------------------------------------------------------------------ +! objTimesTensor +!------------------------------------------------------------------------------ + + FUNCTION objTimesTensor( obj, Tensorobj ) + +!. . . . . . . . . . . . . . . . . . . . +! obj * Tensorobj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesTensor + + REAL( DFP ), ALLOCATABLE :: Mat( :, : ) + + Mat = Tensorobj + + objTimesTensor = objTimesMat( obj, Mat ) + + DEALLOCATE( Mat ) + + END FUNCTION objTimesTensor + +!------------------------------------------------------------------------------ +! TensorTimesobj +!------------------------------------------------------------------------------ + + FUNCTION TensorTimesobj( Tensorobj, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! obj * Tensorobj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ), DIMENSION( 3, 3 ) :: TensorTimesobj + + REAL( DFP ), ALLOCATABLE :: Mat( :, : ) + + Mat = Tensorobj + + TensorTimesobj = objTimesMat( obj, Mat ) + + DEALLOCATE( Mat ) + + END FUNCTION TensorTimesobj + +!------------------------------------------------------------------------------ +! objTimesVector +!------------------------------------------------------------------------------ + + FUNCTION objTimesVector( obj, Vec ) + +!. . . . . . . . . . . . . . . . . . . . +! obj * VoigtVec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3, 3 ) :: objTimesVector + + ! Define internal variables + INTEGER( I4B ) :: m + REAL( DFP ) :: DummyVec( 6 ) + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * Vector", & + "Stress_ obj is not allocated. & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + m = SIZE( Vec ) + + IF( m .GT. 6 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Asterics.part", & + "obj * Vector", & + "The Length of Vec should be less than or equal to 6. & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + DummyVec = 1.0_DFP + DummyVec( 1 : m ) = Vec( 1 : m ) + + objTimesVector = objTimesMat( obj, MatFromVoigtVec( DummyVec, "Stress" ) ) + + END FUNCTION objTimesVector + +!------------------------------------------------------------------------------ +! VectorTimesobj +!------------------------------------------------------------------------------ + + FUNCTION VectorTimesobj( Vec, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! VoigtVec * obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3, 3 ) :: VectorTimesobj + + ! Define internal variables + + VectorTimesobj = objTimesVector( obj, Vec ) + + END FUNCTION VectorTimesobj diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part new file mode 100755 index 000000000..573d02353 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Invariant.part @@ -0,0 +1,346 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Invariants.part +! Last Update : Dec-18-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of module +! +! Info:: - This part contains the subroutines related to +! the tensor invariants. + +! Hosting File - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Invar_I1 +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_I1( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. - Returns the trace of a tensor +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + TYPE( Rank2Tensor_ ) :: T + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Invariant.part", & + "Invar_I1()", & + "Stress_ object is not allocated. & + Program Stopped !!!") + + STOP + + END IF + + T = obj + Invar_I1 = Trace( T ) + CALL T%Deallocate( ) + + END FUNCTION Invar_I1 + +!------------------------------------------------------------------------------ +! Invar_I2 +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_I2( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. - Returns I2 invariant +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Invariant.part", & + "Invar_I2()", & + "Stress_ object is not allocated. & + Program Stopped !!!") + + STOP + + END IF + + T = obj + Invar_I2 = Invariant_I2( T ) + CALL T%Deallocate( ) + + END FUNCTION Invar_I2 + +!------------------------------------------------------------------------------ +! Invar_I3 +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_I3( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns I3 invariant +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Invariant.part", & + "Invar_I3()", & + "Stress_ object is not allocated. & + Program Stopped !!!") + + STOP + + END IF + + T = obj + Invar_I3 = Invariant_I3( T ) + CALL T%Deallocate( ) + + END FUNCTION Invar_I3 + +!------------------------------------------------------------------------------ +! Invar_J2 +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_J2( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns J2 = 0.5*Dev( Sigma ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Invariant.part", & + "Invar_J2()", & + "Stress_ object is not allocated. & + Program Stopped !!!") + + STOP + + END IF + + T = obj + Invar_J2 = Invariant_J2( T ) + CALL T%Deallocate( ) + + END FUNCTION Invar_J2 + +!------------------------------------------------------------------------------ +! Invar_J3 +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_J3( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns Det( Dev( Sigma )) +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Invariant.part", & + "Invar_J3()", & + "Stress_ object is not allocated. & + Program Stopped !!!") + + STOP + + END IF + + T = obj + Invar_J3 = Invariant_J3( T ) + CALL T%Deallocate( ) + + END FUNCTION Invar_J3 + +!------------------------------------------------------------------------------ +! Sigma_m +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Sigma_m( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns Det( Dev( Sigma )) +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + + Sigma_m = Invar_I1( obj ) / 3.0_DFP + + END FUNCTION Sigma_m + +!------------------------------------------------------------------------------ +! Sigma_Bar +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Sigma_Bar( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. Sigma_Bar = SQRT( 3 * J2 ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + + Sigma_Bar = SQRT( Invar_J2( obj ) * 3.0_DFP ) + + END FUNCTION Sigma_Bar + +!------------------------------------------------------------------------------ +! Invar_Z +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_Z( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. Invar_Z = Sigma_m / SQRT( 3 ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + + Invar_Z = Sigma_m( obj ) / SQRT( 3.0_DFP ) + + END FUNCTION Invar_Z + +!------------------------------------------------------------------------------ +! Invar_r +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_r( obj ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. Invar_r = SQRT( 2 * J2 ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variabless + + Invar_r = SQRT( 2.0_DFP * Invar_J2( obj ) ) + + END FUNCTION Invar_r + +!------------------------------------------------------------------------------ +! m_Invar_LodeAngle +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION m_Invar_LodeAngle( obj, LodeAngleType ) + + USE Rank2Tensor_Class + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. LodeAngleType "Sine", "Cosine" +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: LodeAngleType + + TYPE( Rank2Tensor_ ) :: T + +! Check the existence of obj + T = obj + m_Invar_LodeAngle = LodeAngle( T, LodeAngleType ) + + CALL T%Deallocate( ) + + END FUNCTION m_Invar_LodeAngle + +!------------------------------------------------------------------------------ +! Invar_LodeAngle +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION Invar_LodeAngle( obj ) + +! Description +!. . . . . . . . . . . . . . . . . . . . +! 1. In this case Lode angle is "Sine" type. +! This method will be used for defining the operator +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + + Invar_LodeAngle = m_Invar_LodeAngle( obj, "Sine" ) + + END FUNCTION Invar_LodeAngle + + + + + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part new file mode 100755 index 000000000..a3860a8f4 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Matmul.part @@ -0,0 +1,334 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MatMul.part +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESsCRIPTION +! - Matrix multiplication operator +! HOSTING FILE +! - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_matmul_obj +!------------------------------------------------------------------------------ +! + FUNCTION obj_matmul_obj( obj, obj2 ) + +!. . . . . . . . . . . . . . . . . . . . +! obj .matmul. obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_matmul_obj + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Mat1( :, : ), Mat2( :, : ) + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) & + .OR. .NOT. ALLOCATED( obj2%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "obj_matmul_obj()", & + "Stress_ obj is/are not allocated. Program Stopped"& + ) + Error_Flag = .TRUE. + + STOP + + END IF + + CALL obj%getStress( Mat1 ) + CALL obj%getStress( Mat2 ) + + CALL Display_Array( Mat1, "Debug:: obj_matmul_obj :: Mat1 =") + + obj_matmul_obj = MATMUL( Mat1, Mat2 ) + + DEALLOCATE( Mat1, Mat2 ) + + END FUNCTION obj_matmul_obj + +!------------------------------------------------------------------------------ +! obj_matmul_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_matmul_Mat( obj, Mat2 ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. - obj .matmul. Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_matmul_Mat + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "obj_matmul_Mat()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + T = obj + + obj_matmul_Mat = T .matmul. Mat2 + + CALL T%Deallocate( ) + + END FUNCTION obj_matmul_Mat + +!------------------------------------------------------------------------------ +! obj_matmul_Vec +!------------------------------------------------------------------------------ + + FUNCTION obj_matmul_Vec( obj, Vec ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. - obj .matmul. Vec +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: obj_matmul_Vec + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "obj_matmul_Vec()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + + IF( SIZE( Vec ) .GT. 3 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "obj_matmul_Vec()", & + "The size of Vec should be less than or equal to 3. & + Program Stopped" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + T = obj + + obj_matmul_Vec = T .matmul. Vec + + CALL T%Deallocate( ) + + END FUNCTION obj_matmul_Vec + +!------------------------------------------------------------------------------ +! Vec_matmul_obj +!------------------------------------------------------------------------------ + + FUNCTION Vec_matmul_obj( Vec, obj ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Vec .matmul. obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 3 ) :: Vec_matmul_obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "Vec_matmul_obj()", & + "Stress_ obj is not allocated. & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + IF( SIZE( Vec ) .GT. 3 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "Vec_matmul_obj()", & + "The size of Vec should be less than or equal to 3. & + Program Stopped !!!" & + ) + Error_Flag = .TRUE. + + STOP + + END IF + + T = obj + + Vec_matmul_obj = Vec .matmul. T + + CALL T%Deallocate( ) + + END FUNCTION Vec_matmul_obj + +!------------------------------------------------------------------------------ +! Mat_matmul_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_matmul_obj( Mat2, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat .matmul. obj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat2 + REAL( DFP ), DIMENSION( 3, 3 ) :: Mat_matmul_obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "Mat_matmul_obj()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + + END IF + + T = obj + Mat_matmul_obj = Mat2 .matmul. T + CALL T%Deallocate( ) + + END FUNCTION Mat_matmul_obj + +!------------------------------------------------------------------------------ +! obj_matmul_Tensor +!------------------------------------------------------------------------------ + + FUNCTION obj_matmul_Tensor( obj, Tensorobj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .matmul. Tensorobj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ), DIMENSION( 3, 3 ) :: obj_matmul_Tensor + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "obj_matmul_Tensor()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + + END IF + + T = obj + obj_matmul_Tensor = T .matmul. Tensorobj + CALL T%Deallocate( ) + + END FUNCTION obj_matmul_Tensor + +!------------------------------------------------------------------------------ +! Tensor_matmul_obj +!------------------------------------------------------------------------------ + + FUNCTION Tensor_matmul_obj( Tensorobj, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Tensor .matmul. obj +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ), DIMENSION( 3, 3 ) :: Tensor_matmul_obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Matmul.part", & + "Tensor_matmul_obj()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + + END IF + + T = obj + Tensor_matmul_obj = Tensorobj .matmul. T + CALL T%Deallocate( ) + + END FUNCTION Tensor_matmul_obj diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part new file mode 100755 index 000000000..a7fd38983 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Otimes.part @@ -0,0 +1,422 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Otimes.part +! Last Update : Dec-18-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION :: +! - Dyadic product for stress class is defined +! HOSTING FILE +! - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! obj_Otimes_obj +!------------------------------------------------------------------------------ + + FUNCTION obj_Otimes_obj( obj, obj2 ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. obj2 +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + + CLASS( Stress_ ), INTENT( IN ) :: obj, obj2 + REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T1, T2 + + IF( .NOT. ALLOCATED( obj%V ) & + .OR. .NOT. ALLOCATED( obj2%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "obj_Otimes_obj()", & + "Stress_ obj is/are not allocated. Program Stopped"& + ) + Error_Flag = .TRUE. + + STOP + + END IF + + T1 = obj + T2 = obj2 + + obj_Otimes_obj = T1 .otimes. T2 + + CALL T1%Deallocate( ) + CALL T2%Deallocate( ) + + END FUNCTION obj_Otimes_obj + +!------------------------------------------------------------------------------ +! obj_Otimes_Mat +!------------------------------------------------------------------------------ + + FUNCTION obj_Otimes_Mat( obj, Mat ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. Mat +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_Mat + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + INTEGER( I4B ) :: N + REAL ( DFP ) :: DummyMat( 3, 3 ) + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "obj_Otimes_Mat()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + END IF + + N = SIZE( Mat, 1 ) + + IF( SIZE( Mat, 2 ) .NE. N .OR. N .GT. 3 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "obj_Otimes_Mat()", & + "Mat should be square matrix, & + and Size should be less than equal to 3, & + Program Stopped!!!" & + ) + STOP + + END IF + + DummyMat = 0.0_DFP + DummyMat( 1:N, 1:N ) = Mat( 1:N, 1:N ) + + T = obj + + obj_Otimes_Mat = T .Otimes. DummyMat + + CALL T%Deallocate( ) + + END FUNCTION obj_Otimes_Mat + +!------------------------------------------------------------------------------ +! Mat_Otimes_obj +!------------------------------------------------------------------------------ + + FUNCTION Mat_Otimes_obj( Mat, obj ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. Mat .otimes. obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Mat + REAL( DFP ), DIMENSION( 6, 6 ) :: Mat_Otimes_obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + INTEGER( I4B ) :: N + REAL ( DFP ) :: DummyMat( 3, 3 ) + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "Mat_Otimes_obj()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + END IF + + N = SIZE( Mat, 1 ) + + IF( SIZE( Mat, 2 ) .NE. N .OR. N .GT. 3 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "Mat_Otimes_obj()", & + "Mat should be square matrix, & + and Size should be less than equal to 3, & + Program Stopped!!!" & + ) + STOP + + END IF + + DummyMat = 0.0_DFP + DummyMat( 1:N, 1:N ) = Mat( 1:N, 1:N ) + + T = obj + + Mat_Otimes_obj = DummyMat .Otimes. T + + CALL T%Deallocate( ) + + END FUNCTION Mat_Otimes_obj + +!------------------------------------------------------------------------------ +! obj_Otimes_Tensor +!------------------------------------------------------------------------------ + + FUNCTION obj_Otimes_Tensor( obj, Tensorobj ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. Tensor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_Tensor + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "obj_Otimes_Tensor()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + END IF + + T = obj + + obj_Otimes_Tensor = T .Otimes. Tensorobj + + CALL T%Deallocate( ) + + END FUNCTION obj_Otimes_Tensor + +!------------------------------------------------------------------------------ +! Tensor_Otimes_obj +!------------------------------------------------------------------------------ + + FUNCTION Tensor_Otimes_obj( Tensorobj, obj ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. Tensor .otimes. obj +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( IN ) :: Tensorobj + REAL( DFP ), DIMENSION( 6, 6 ) :: Tensor_Otimes_obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "Tensor_Otimes_obj()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + END IF + + T = obj + + Tensor_Otimes_obj = Tensorobj .Otimes. T + + CALL T%Deallocate( ) + + END FUNCTION Tensor_Otimes_obj + +!------------------------------------------------------------------------------ +! obj_Otimes_Vec +!------------------------------------------------------------------------------ + + FUNCTION obj_Otimes_Vec( obj, Vec ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. Vec +! 2. Vec is voigt vector of type stress +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 6, 6 ) :: obj_Otimes_Vec + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T1, T2 + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "obj_Otimes_Vec()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + + END IF + + IF( SIZE( Vec ) .GT. 6 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "obj_Otimes_Vec()", & + "The length of Vec must be less than or equal to 6. & + Program Stopped !!! " & + ) + STOP + + END IF + + T1 = obj + T2 = Rank2Tensor( Vec, "Stress") + + obj_Otimes_Vec = T1 .Otimes. T2 + + CALL T1%Deallocate( ) + CALL T2%Deallocate( ) + + END FUNCTION obj_Otimes_Vec + +!------------------------------------------------------------------------------ +! Vec_Otimes_obj +!------------------------------------------------------------------------------ + + FUNCTION Vec_Otimes_obj( Vec, obj ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. Vec .otimes. obj +! 2. Vec is voigt vector of type stress +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + REAL( DFP ), DIMENSION( 6, 6 ) :: Vec_Otimes_obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T1, T2 + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "Vec_Otimes_obj()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + + END IF + + IF( SIZE( Vec ) .GT. 6 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "Vec_Otimes_obj()", & + "The length of Vec must be less than or equal to 6. & + Program Stopped !!! " & + ) + STOP + + END IF + + T1 = obj + T2 = Rank2Tensor( Vec, "Stress") + + Vec_Otimes_obj = T2 .Otimes. T1 + + CALL T1%Deallocate( ) + CALL T2%Deallocate( ) + + END FUNCTION Vec_Otimes_obj + +!------------------------------------------------------------------------------ +! m_obj_Otimes_Vec +!------------------------------------------------------------------------------ + + FUNCTION m_obj_Otimes_Vec( obj, Vec, VoigtType ) + + USE Rank2Tensor_Class + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .otimes. Vec +! 2. Vec is voigt vector of type stress +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Vec + CHARACTER( LEN = * ), INTENT( IN ) :: VoigtType + REAL( DFP ), DIMENSION( 6, 6 ) :: m_obj_Otimes_Vec + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T1, T2 + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "m_obj_Otimes_Vec()", & + "Stress_ obj is not allocated. Program Stopped" & + ) + STOP + + END IF + + IF( SIZE( Vec ) .GT. 6 ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Otimes.part", & + "m_obj_Otimes_Vec()", & + "The length of Vec must be less than or equal to 6. & + Program Stopped !!! " & + ) + STOP + + END IF + + T1 = obj + T2 = Rank2Tensor( Vec, VoigtType ) + + m_obj_Otimes_Vec = T1 .Otimes. T2 + + CALL T1%Deallocate( ) + CALL T2%Deallocate( ) + + END FUNCTION m_obj_Otimes_Vec \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part new file mode 100755 index 000000000..f9d924258 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/OperatorOverloading/Shape.part @@ -0,0 +1,205 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Shape.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION :: +! - .Shape. operator is defined, That returns the VoigtVector +! +! HOSTING FILE +! - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! VoigtVector_1 +!------------------------------------------------------------------------------ + + FUNCTION VoigtVector_1( obj, M ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. obj .Shape. M, Returns obj%S in Voigt vector +! form of length M +!. . . . . . . . . . . . . . . . . . . . + + USE Voigt + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + INTEGER( I4B ), INTENT( IN ) :: M + REAL( DFP ) :: VoigtVector_1( M ) + + INTEGER( I4B ) :: N + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>OperatorOverloading/Shape.part", & + " obj .Shape. M", & + "obj%V is not allocated, Program Stopped!!!"& + ) + + STOP + + END IF + + N = .SIZE. obj + + SELECT CASE( N ) + + CASE( 6 ) + + SELECT CASE( M ) + + CASE( 6 ) + + VoigtVector_1 = obj%V + + CASE( 4 ) + + VoigtVector_1 = Vec4_From_Vec6( obj%V ) + + CASE( 3 ) + + VoigtVector_1 = Vec3_From_Vec6( obj%V ) + + CASE( 2 ) + + VoigtVector_1 = Vec2_From_Vec6( obj%V ) + + CASE( 1 ) + + VoigtVector_1( 1 ) = obj%V( 1 ) + + + END SELECT + + CASE( 4 ) + + SELECT CASE( M ) + + CASE( 6 ) + + VoigtVector_1 = Vec6_From_Vec4( obj%V ) + + CASE( 4 ) + + VoigtVector_1 = obj%V + + CASE( 3 ) + + VoigtVector_1 = Vec3_From_Vec4( obj%V ) + + CASE( 2 ) + + VoigtVector_1 = Vec2_From_Vec4( obj%V ) + + CASE( 1 ) + + VoigtVector_1( 1 ) = obj%V( 1 ) + + + END SELECT + + CASE( 3 ) + + SELECT CASE( M ) + + CASE( 6 ) + + VoigtVector_1 = Vec6_From_Vec3( obj%V ) + + CASE( 4 ) + + VoigtVector_1 = Vec4_From_Vec3( obj%V ) + + CASE( 3 ) + + VoigtVector_1 = obj%V + + CASE( 2 ) + + VoigtVector_1 = Vec2_From_Vec3( obj%V ) + + CASE( 1 ) + + VoigtVector_1( 1 ) = obj%V( 1 ) + + + END SELECT + + CASE( 2 ) + + SELECT CASE( M ) + + CASE( 6 ) + + VoigtVector_1 = Vec6_From_Vec2( obj%V ) + + CASE( 4 ) + + VoigtVector_1 = Vec4_From_Vec2( obj%V ) + + CASE( 3 ) + + VoigtVector_1 = Vec3_From_Vec2( obj%V ) + + CASE( 2 ) + + VoigtVector_1 = obj%V + + CASE( 1 ) + + VoigtVector_1( 1 ) = obj%V( 1 ) + + + END SELECT + + CASE( 1 ) + + SELECT CASE( M ) + + CASE( 6 ) + + VoigtVector_1 = Vec6_From_Vec1( obj%V ) + + CASE( 4 ) + + VoigtVector_1 = Vec4_From_Vec1( obj%V ) + + CASE( 3 ) + + VoigtVector_1 = Vec3_From_Vec1( obj%V ) + + CASE( 2 ) + + VoigtVector_1 = Vec2_From_Vec1( obj%V ) + + CASE( 1 ) + + VoigtVector_1( 1 ) = obj%V( 1 ) + + + END SELECT + + CASE DEFAULT + + CALL Err_Msg( & + "Stress_Class.F90>>OperatorOverloading/Shape.part", & + " obj .Shape. M", & + "No Case Found for shape of obj%V, Program Stopped!!!"& + ) + STOP + + END SELECT + + END FUNCTION VoigtVector_1 \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part b/src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part new file mode 100755 index 000000000..d69bc8cb0 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/Pk1Stress.part @@ -0,0 +1,108 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Pk1Stress.part +! Last Update : Dec-28-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of Module +! +! Description :: +! - This part includes subroutine for getting Pk1 Stress from +! any other Stress Measures +! Hosting File :: +! - Stress_Class +!============================================================================== + +!------------------------------------------------------------------------------ +! getPk1Stress +!------------------------------------------------------------------------------ + + FUNCTION getPk1Stress( obj, F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. This subroutine computes the Pk1 stress ( PI )from given stress type +! 2. Fobj is Deformation Gradient object. +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE DeformationGradient_Class + + ! Define arguments of dummy argument + CLASS( Stress_ ), INTENT( IN ) :: obj + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + REAL( DFP ), ALLOCATABLE :: getPk1Stress( :, : ) + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + REAL( DFP ) :: J + REAL( DFP ), ALLOCATABLE :: InvF( :, : ) + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Pk1Stress.part", & + "getPk1Stress(), obj .pkOne. F, obj .PI. F", & + "Stress_ object is not initiated. & + Program Stopped !!!" & + ) + STOP + + END IF + + T = obj + + SELECT CASE( TRIM( obj%StressType ) ) + + CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) + + J = .det. F + InvF = .INV. F + getPk1Stress = T .matmul. TRANSPOSE( InvF ) + getPk1Stress = J * getPk1Stress + + CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) + + InvF = .INV. F + getPk1Stress = T .matmul. TRANSPOSE( InvF ) + + CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) + + getPk1Stress = F .matmul. T + + CASE( "PK1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) + + getPk1Stress = T + + CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) + + InvF = .INV. F + getPk1Stress = TRANSPOSE( InvF ) .matmul. T + + + CASE DEFAULT + + CALL Err_Msg( & + "Stress_Class.F90>>Pk1Stress.part", & + "getPk1Stress( obj, F ), obj .pkOne. F, obj .PI. F", & + "No case found for obj%StressType. & + Program Stopped!!!" & + ) + STOP + + END SELECT + + CALL T%Deallocate( ) + IF( ALLOCATED( InvF ) ) DEALLOCATE( InvF ) + + END FUNCTION getPk1Stress + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part b/src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part new file mode 100755 index 000000000..8c7947c11 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/Pk2Stress.part @@ -0,0 +1,109 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: PK2Stress.part +! Last Update : Dec-28-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of Module +! +! Description :: +! - This part includes subroutine for getting PK2 Stress from +! any other Stress Measures +! Hosting File :: +! - Stress_Class +!============================================================================== + +!------------------------------------------------------------------------------ +! getPK2Stress +!------------------------------------------------------------------------------ + + FUNCTION getPK2Stress( obj, F ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. This subroutine computes the Cauchy stress from given stress type +! 2. Fobj is Deformation Gradient object. +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + USE DeformationGradient_Class + + ! Define arguments of dummy argument + CLASS( Stress_ ), INTENT( IN ) :: obj + TYPE( DeformationGradient_ ), INTENT( IN ) :: F + REAL( DFP ), ALLOCATABLE :: getPK2Stress( :, : ) + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + REAL( DFP ) :: J + REAL( DFP ), ALLOCATABLE :: InvF( :, : ) + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>Pk2Stress.part", & + "getPK2Stress(), obj.pkTwo.F, obj.S.F", & + "Stress_ object is not initiated. & + Program Stopped !!!" & + ) + STOP + + END IF + + T = obj + + SELECT CASE( TRIM( obj%StressType ) ) + + CASE( "Cauchy", "cauchy", "Sigma", "sigma" ) + + J = .det. F + InvF = .INV. F + getPK2Stress = ( InvF .matmul. T ) .matmul. TRANSPOSE( InvF ) + getPK2Stress = J * getPK2Stress + + CASE( "Kirchhoff", "kirchhoff", "Tau", "kirchoff", "Kirchoff", "tau" ) + + InvF = .INV. F + getPK2Stress = ( InvF .matmul. T ) .matmul. TRANSPOSE( InvF ) + + CASE( "PK2", "Pk2", "pk2", "PK-2", "pk-2", "S", "s" ) + + getPK2Stress = T + + CASE( "PK1", "pk1", "PK-1", "pk-1", "Pi", "PI", "pi" ) + + InvF = .INV. F + getPK2Stress = InvF .matmul. T + + CASE( "Eshelby-Like", "Eshelby", "EshelbyLike", "M", "m" ) + + InvF = .INV. F + getPK2Stress = InvF .matmul. ( TRANSPOSE( InvF ) .matmul. T ) + + + CASE DEFAULT + + CALL Err_Msg( & + "Stress_Class.F90>>Pk2Stress.part", & + "getPK2Stress( obj, F ), obj .pkTwo. F, obj .S. F", & + "No case found for obj%StressType. & + Program Stopped!!!" & + ) + STOP + + END SELECT + + CALL T%Deallocate( ) + IF( ALLOCATED( InvF ) ) DEALLOCATE( InvF ) + + END FUNCTION getPK2Stress + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part b/src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part new file mode 100755 index 000000000..fbc0512bf --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/SpectralDecomposition.part @@ -0,0 +1,193 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SpectralDecomposition.part +! Last Update : Dec-16-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of module +! +! Info:: - This is part of the code. +! - Contains subroutines related to the spectral decomposition of +! a tensor. +! Hosting File - +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Eigens +!------------------------------------------------------------------------------ + + SUBROUTINE Eigens( obj, EigenValues, EigenVectors ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the eigen values and Eigen Vectors +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, INTENT( OUT ) :: EigenValues( : ), & + EigenVectors( :, : ) + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>SpectralDecomposition.part", & + "Eigens()", & + "Stress_ object is not allocated. & + Program Stopped !!!") + + STOP + + END IF + + T = obj + + CALL T%Eigens( EigenValues = Eigenvalues, EigenVectors = EigenVectors ) + + CALL Check_Error( & + "Stress_Class.F90>>SpectralDecomposition.part>>m_Eigen_1()", & + "Traceback ---> & + CALL T%Eigens( EigenValues = Eigenvalues, EigenVectors = EigenVectors )"& + ) + + CALL T%Deallocate( ) + + END SUBROUTINE Eigens + +!------------------------------------------------------------------------------ +! PrincipalValue +!------------------------------------------------------------------------------ + +REAL( DFP ) FUNCTION PrincipalValue( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! - Returns the max( Real( eigenvalue ) ) +! - m_Eigens_1 is used in this routine +!. . . . . . . . . . . . . . . . . . . . + + + USE Rank2Tensor_Class + + ! Define intent of dummy arguments + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>SpectralDecomposition.part", & + "PrincipalValue()", & + "Stress_ object is not allocated. & + Program Stopped !!!") + + STOP + + END IF + + T = obj + + PrincipalValue = Tensor_PrincipalValue( T ) + + CALL T%Deallocate( ) + +END FUNCTION PrincipalValue + +!------------------------------------------------------------------------------ +! SpectralRadius +!------------------------------------------------------------------------------ + +REAL( DFP ) FUNCTION SpectralRadius( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! - Returns the max( Real( eigenvalue ) ) +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy arguments + CLASS( Stress_ ), INTENT( IN ) :: obj + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + + T = obj + + SpectralRadius = Tensor_SpectralRadius( T ) + + CALL T%Deallocate( ) + +END FUNCTION SpectralRadius + +!------------------------------------------------------------------------------ +! EigenValues +!------------------------------------------------------------------------------ + + FUNCTION EigenValues( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! - Returns EigenValues +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy arguments + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3 ) :: EigenValues + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: EigVals( : ), EigVecs( :, : ) + + CALL Eigens( obj, EigVals, EigVecs ) + CALL Check_Error( & + "Stress_Class.F90>>SpectralDecomposition.part>>EigenValues()", & + "Traceback ---> CALL Eigens( obj, EigVals, EigVecs ) "& + ) + + EigenValues( 1 : 3 ) = EigVals( 1 : 3 ) + + DEALLOCATE( EigVals, EigVecs ) + + +END FUNCTION EigenValues + +!------------------------------------------------------------------------------ +! EigenVectors +!------------------------------------------------------------------------------ + + FUNCTION EigenVectors( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! - Returns EigenVectors +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy arguments + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: EigenVectors + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: EigVals( : ), EigVecs( :, : ) + + CALL Eigens( obj, EigVals, EigVecs ) + CALL Check_Error( & + "Stress_Class.F90>>SpectralDecomposition.part>>EigenVectors()", & + "Traceback ---> CALL Eigens( obj, EigVals, EigVecs ) "& + ) + + EigenVectors( :, : ) = EigVecs( :, : ) + + DEALLOCATE( EigVals, EigVecs ) + +END FUNCTION EigenVectors + diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/StressType.part b/src/submodules/Rank2Tensor/src/old data/Stress/StressType.part new file mode 100755 index 000000000..2a2539c77 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/StressType.part @@ -0,0 +1,57 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StressType.part +! Last Update : Dec-28-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DESCRIPTION +! - method to access obj%stress field +! HOSTING FILE +! - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStressType +!------------------------------------------------------------------------------ + + FUNCTION getStressType( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the obj%StressType +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CHARACTER( LEN = 50 ) :: getStressType + + + getStressType = TRIM( obj%StressType ) + + END FUNCTION getStressType + +!------------------------------------------------------------------------------ +! setStressType +!------------------------------------------------------------------------------ + + SUBROUTINE setStressType( obj, StressType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the obj%StressType +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( INOUT ) :: obj + CHARACTER( LEN = * ), INTENT( IN ) :: StressType + + obj%StressType = TRIM( StressType ) + + END SUBROUTINE setStressType \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 new file mode 100755 index 000000000..d093d5ee6 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/Stress_Class.F90 @@ -0,0 +1,355 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Stress_Class.F90 +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Stress_ Class is defined +!============================================================================== + + MODULE Stress_Class + USE GlobalData + USE IO + USE Voigt + IMPLICIT NONE + + PRIVATE + + PUBLIC :: Stress_, Stress, Stress_Pointer + + +!------------------------------------------------------------------------------ +! Stress_ +!------------------------------------------------------------------------------ + + TYPE :: Stress_ + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Stress class is defined +!. . . . . . . . . . . . . . . . . . . . + + REAL( DFP ), ALLOCATABLE :: V( : ) + INTEGER( I4B ) :: NSD + CHARACTER( LEN = 50 ) :: StressType = "" + + CONTAINS + + + ! Constructor.part + + PROCEDURE, PUBLIC, PASS :: Initiate1, Initiate2, Initiate3, & + Initiate4, Initiate5, Initiate6 + + GENERIC, PUBLIC :: Initiate => Initiate1, Initiate2, Initiate3, & + Initiate4, Initiate5, Initiate6 + + GENERIC, PUBLIC :: ASSIGNMENT( = ) => Initiate3 + + PROCEDURE, PUBLIC, PASS :: isInitiated + PROCEDURE, PUBLIC, PASS :: Deallocate + PROCEDURE, PUBLIC, PASS :: getVoigtLen + GENERIC, PUBLIC :: OPERATOR( .SIZE. ) => getVoigtLen + PROCEDURE, PUBLIC, PASS :: getNSD, setNSD + + + ! StressType.part + + PROCEDURE, PUBLIC, PASS( obj ) :: getStressType, setStressType + GENERIC, PUBLIC :: OPERATOR( .StressType. ) => getStressType + GENERIC, PUBLIC :: ASSIGNMENT( = ) => setStressType + + + ! getStress.part + + PROCEDURE, PUBLIC, PASS :: s_getStress_1 + PROCEDURE, PUBLIC, PASS :: s_getStress_2 + PROCEDURE, PUBLIC, PASS :: s_getStress_5 + GENERIC, PUBLIC :: getStress => s_getStress_1, s_getStress_2, & + s_getStress_5 + + PROCEDURE, PUBLIC, PASS( obj ) :: s_getStress_3, s_getStress_4, & + s_getStress_6 + GENERIC, PUBLIC :: ASSIGNMENT( = ) => s_getStress_3, s_getStress_4, & + s_getStress_6 + + ! OperatorOverloading/Addition.part + + PROCEDURE, PUBLIC, PASS :: obj_Add_obj + PROCEDURE, PUBLIC, PASS :: obj_Add_Mat + PROCEDURE, PUBLIC, PASS :: obj_Add_Vec + PROCEDURE, PUBLIC, PASS :: obj_Add_Scalar + PROCEDURE, PUBLIC, PASS( obj ) :: Mat_Add_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Vec_Add_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Scalar_Add_obj + + GENERIC, PUBLIC :: OPERATOR( + ) => obj_Add_Mat, obj_Add_obj, & + Mat_Add_obj, obj_Add_Vec, Vec_Add_obj, Scalar_Add_obj, & + obj_Add_Scalar + + PROCEDURE, PUBLIC, PASS :: obj_Minus_obj + PROCEDURE, PUBLIC, PASS :: obj_Minus_Mat + PROCEDURE, PUBLIC, PASS :: obj_Minus_Vec + PROCEDURE, PUBLIC, PASS :: obj_Minus_Scalar + PROCEDURE, PUBLIC, PASS( obj ) :: Mat_Minus_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Vec_Minus_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Scalar_Minus_obj + + GENERIC, PUBLIC :: OPERATOR( - ) => obj_Minus_Mat, obj_Minus_obj, & + Mat_Minus_obj, obj_Minus_Vec, Vec_Minus_obj, Scalar_Minus_obj, & + obj_Minus_Scalar + + + ! OperatorOverloading/Assignment.part + + PROCEDURE, PUBLIC, PASS( obj ) :: obj_From_Tensor, & + obj_From_Mat, obj_From_Vec + + GENERIC, PUBLIC :: ASSIGNMENT( = ) => obj_From_Tensor, & + obj_From_Mat, obj_From_Vec + + + ! OperatorOverLoading/Asterics.part + + PROCEDURE, PUBLIC, PASS :: objTimesScalar_1 + PROCEDURE, PUBLIC, PASS :: objTimesScalar_2 + PROCEDURE, PUBLIC, PASS :: objTimesobj + PROCEDURE, PUBLIC, PASS :: objTimesMat + PROCEDURE, PUBLIC, PASS :: objTimesVector + PROCEDURE, PUBLIC, PASS :: objTimesTensor + PROCEDURE, PUBLIC, PASS( obj ) :: ScalarTimesobj_1 + PROCEDURE, PUBLIC, PASS( obj ) :: ScalarTimesobj_2 + PROCEDURE, PUBLIC, PASS( obj ) :: MatTimesobj + PROCEDURE, PUBLIC, PASS( obj ) :: VectorTimesobj + PROCEDURE, PUBLIC, PASS( obj ) :: TensorTimesobj + + GENERIC, PUBLIC :: OPERATOR( * ) => objTimesScalar_1, & + objTimesScalar_2, objTimesobj, objTimesMat, ScalarTimesobj_1, & + ScalarTimesobj_2, MatTimesobj, objTimesVector, VectorTimesobj, & + TensorTimesobj, objTimesTensor + + + ! OperatorOverLoading/Matmul.part + + PROCEDURE, PUBLIC, PASS :: obj_matmul_obj + PROCEDURE, PUBLIC, PASS :: obj_matmul_Mat + PROCEDURE, PUBLIC, PASS :: obj_matmul_Tensor + PROCEDURE, PUBLIC, PASS :: obj_matmul_Vec + PROCEDURE, PUBLIC, PASS( obj ) :: Mat_matmul_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Tensor_matmul_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Vec_matmul_obj + + GENERIC, PUBLIC :: OPERATOR( .matmul. ) => obj_matmul_obj , & + obj_matmul_Mat, obj_matmul_Tensor, Mat_matmul_obj, & + Tensor_matmul_obj, obj_matmul_Vec, Vec_matmul_obj + + + ! OperatorOverLoading/Otimes.part + + PROCEDURE, PUBLIC, PASS :: obj_Otimes_obj + PROCEDURE, PUBLIC, PASS :: obj_Otimes_Mat + PROCEDURE, PUBLIC, PASS :: obj_Otimes_Tensor + PROCEDURE, PUBLIC, PASS :: obj_Otimes_Vec + PROCEDURE, PUBLIC, PASS :: m_obj_Otimes_Vec + PROCEDURE, PUBLIC, PASS( obj ) :: Mat_Otimes_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Tensor_Otimes_obj + PROCEDURE, PUBLIC, PASS( obj ) :: Vec_Otimes_obj + + GENERIC, PUBLIC :: OPERATOR( .Otimes. ) => obj_Otimes_obj, & + obj_Otimes_Mat, obj_Otimes_Tensor, Mat_Otimes_obj, & + Tensor_Otimes_obj, Vec_Otimes_obj, obj_Otimes_Vec + + GENERIC, PUBLIC :: Otimes => obj_Otimes_obj, & + obj_Otimes_Mat, obj_Otimes_Tensor, obj_Otimes_Vec, & + m_obj_Otimes_Vec + + + ! OperatorOverLoading/Invariant.part + + PROCEDURE, PUBLIC, PASS :: Invar_I1 + GENERIC, PUBLIC :: Invariant_I1 => Invar_I1 + GENERIC, PUBLIC :: OPERATOR( .Ione. ) => Invar_I1 + + PROCEDURE, PUBLIC, PASS :: Invar_I2 + GENERIC, PUBLIC :: Invariant_I2 => Invar_I2 + GENERIC, PUBLIC :: OPERATOR( .Itwo. ) => Invar_I2 + + PROCEDURE, PUBLIC, PASS :: Invar_I3 + GENERIC, PUBLIC :: Invariant_I3 => Invar_I3 + GENERIC, PUBLIC :: OPERATOR( .Ithree. ) => Invar_I3 + + PROCEDURE, PUBLIC, PASS :: Invar_J2 + GENERIC, PUBLIC :: Invariant_J2 => Invar_J2 + GENERIC, PUBLIC :: OPERATOR( .Jtwo. ) => Invar_J2 + + PROCEDURE, PUBLIC, PASS :: Invar_J3 + GENERIC, PUBLIC :: Invariant_J3 => Invar_J3 + GENERIC, PUBLIC :: OPERATOR( .Jthree. ) => Invar_J3 + + PROCEDURE, PUBLIC, PASS :: Sigma_m + GENERIC, PUBLIC :: OPERATOR( .sigmaM. ) => Sigma_m + + PROCEDURE, PUBLIC, PASS :: Sigma_Bar + GENERIC, PUBLIC :: OPERATOR( .sigmaBAR. ) => Sigma_Bar + + PROCEDURE, PUBLIC, PASS :: Invar_Z + GENERIC, PUBLIC :: Invariant_Z => Invar_Z + GENERIC, PUBLIC :: OPERATOR( .z. ) => Invar_Z + + PROCEDURE, PUBLIC, PASS :: Invar_r + GENERIC, PUBLIC :: OPERATOR( .r. ) => Invar_r + + PROCEDURE, PUBLIC, PASS :: m_Invar_LodeAngle + GENERIC, PUBLIC :: LodeAngle => m_Invar_LodeAngle + + PROCEDURE, PUBLIC, PASS :: Invar_LodeAngle + GENERIC, PUBLIC :: OPERATOR( .LodeAngle. ) => Invar_LodeAngle + GENERIC, PUBLIC :: OPERATOR( .theta. ) => Invar_LodeAngle + + + ! OperatorOverLoading/Shape.part + + PROCEDURE, PUBLIC, PASS( obj ) :: VoigtVector_1 + GENERIC, PUBLIC :: OPERATOR( .Shape. ) => VoigtVector_1 + + + ! SpectralDecomposition.part + PROCEDURE, PUBLIC, PASS :: Eigens + + PROCEDURE, PUBLIC, PASS :: EigenVectors + GENERIC, PUBLIC :: OPERATOR( .EigenVectors. ) => EigenVectors + + PROCEDURE, PUBLIC, PASS :: EigenValues + GENERIC, PUBLIC :: OPERATOR( .EigenValues. ) => EigenValues + + PROCEDURE, PUBLIC, PASS :: PrincipalValue + GENERIC, PUBLIC :: OPERATOR( .PrincipalValue. ) => PrincipalValue + + PROCEDURE, PUBLIC, PASS :: SpectralRadius + GENERIC, PUBLIC :: OPERATOR( .SpectralRadius. ) => SpectralRadius + + + ! TensorDecomposition.part + + PROCEDURE, PUBLIC, PASS :: m_SymmetricPart + GENERIC, PUBLIC :: SymmetricPart => m_SymmetricPart + + GENERIC, PUBLIC :: OPERATOR( .sym. ) => m_SymmetricPart + GENERIC, PUBLIC :: OPERATOR( .SymmetricPart. ) => m_SymmetricPart + + PROCEDURE, PUBLIC, PASS :: m_AntiSymmetricPart + GENERIC, PUBLIC :: AntiSymmetricPart => m_AntiSymmetricPart + + GENERIC, PUBLIC :: OPERATOR( .AntiSym. ) => m_AntiSymmetricPart + GENERIC, PUBLIC :: OPERATOR( .AntiSymmetricPart. ) => m_AntiSymmetricPart + + PROCEDURE, PUBLIC, PASS :: m_HydrostaticPart + GENERIC, PUBLIC :: HydrostaticPart => m_HydrostaticPart + + GENERIC, PUBLIC :: OPERATOR( .HydrostaticPart. ) => m_HydrostaticPart + GENERIC, PUBLIC :: OPERATOR( .Hydro. ) => m_HydrostaticPart + + GENERIC, PUBLIC :: SphericalPart => m_HydrostaticPart + + + PROCEDURE, PUBLIC, PASS :: m_DeviatoricPart + GENERIC, PUBLIC :: DeviatoricPart => m_DeviatoricPart + + GENERIC, PUBLIC :: OPERATOR( .Dev. ) => m_DeviatoricPart + GENERIC, PUBLIC :: OPERATOR( .DeviatoricPart. ) => m_DeviatoricPart + + + ! CauchyStress.part + + PROCEDURE, PUBLIC, PASS( obj ) :: getCauchyStress + GENERIC, PUBLIC :: OPERATOR( .Cauchy.) => getCauchyStress + GENERIC, PUBLIC :: OPERATOR( .Sigma.) => getCauchyStress + + ! Pk2Stress.part + + PROCEDURE, PUBLIC, PASS( obj ) :: getPK2Stress + GENERIC, PUBLIC :: OPERATOR( .pkTWO. ) => getPK2Stress + GENERIC, PUBLIC :: OPERATOR( .S. ) => getPK2Stress + + ! Pk1Stress.part + + PROCEDURE, PUBLIC, PASS( obj ) :: getPK1Stress + GENERIC, PUBLIC :: OPERATOR( .pkONE. ) => getPK1Stress + GENERIC, PUBLIC :: OPERATOR( .PI. ) => getPK1Stress + + ! KirchhoffStress.part + + PROCEDURE, PUBLIC, PASS( obj ) :: getKirchhoffStress + GENERIC, PUBLIC :: OPERATOR( .Kirchhoff. ) => getKirchhoffStress + GENERIC, PUBLIC :: OPERATOR( .Tau. ) => getKirchhoffStress + + ! EshelbyStress.part + + PROCEDURE, PUBLIC, PASS( obj ) :: getEshelbyStress + GENERIC, PUBLIC :: OPERATOR( .Eshelby. ) => getEshelbyStress + GENERIC, PUBLIC :: OPERATOR( .M. ) => getEshelbyStress + + ! Display.part + + PROCEDURE, PUBLIC, PASS :: Display + + END TYPE Stress_ + + +!. . . . . . . . . . . . . . . . . . . . +! Interfaces +!. . . . . . . . . . . . . . . . . . . . + + + INTERFACE Stress_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3, & + Constructor_4, Constructor_5, Constructor_6 + END INTERFACE + + INTERFACE Stress + MODULE PROCEDURE Constructor1, Constructor2, Constructor3, & + Constructor4, Constructor5, Constructor6 + END INTERFACE + + +!. . . . . . . . . . . . . . . . . . . . +! Contains +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +#include "./Constructor.part" +#include "./StressType.part" +#include "./Display.part" +#include "./getStress.part" + +#include "./OperatorOverloading/Assignment.part" +#include "./OperatorOverloading/Addition.part" +#include "./OperatorOverloading/Asterics.part" +#include "./OperatorOverloading/Matmul.part" +#include "./OperatorOverloading/Otimes.part" +#include "./OperatorOverloading/Invariant.part" +#include "./OperatorOverloading/Shape.part" + +#include "./SpectralDecomposition.part" +#include "./TensorDecomposition.part" + +#include "./CauchyStress.part" +#include "./Pk2Stress.part" +#include "./Pk1Stress.part" +#include "./KirchhoffStress.part" +#include "./EshelbyStress.part" + + END MODULE Stress_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part b/src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part new file mode 100755 index 000000000..d33877549 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/TensorDecomposition.part @@ -0,0 +1,126 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Invariants.part +! Last Update : Dec-14-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of module +! +! Info:: - This part contains the subroutines related to +! the stress decomposition. + +! Hosting File - Rank2Tensor_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! m_SymmetricPart +!------------------------------------------------------------------------------ +! + FUNCTION m_SymmetricPart( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Symmetric part of Tensor, method +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_SymmetricPart + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + T = obj + m_SymmetricPart = SymmetricPart( T ) + + CALL T%Deallocate( ) + + END FUNCTION m_SymmetricPart + +!------------------------------------------------------------------------------ +! m_AntiSymmetricPart +!------------------------------------------------------------------------------ +! + FUNCTION m_AntiSymmetricPart( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - AntiSymmetric part of Tensor, method +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_AntiSymmetricPart + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + T = obj + m_AntiSymmetricPart = AntiSymmetricPart( T ) + + CALL T%Deallocate( ) + + END FUNCTION m_AntiSymmetricPart + +!------------------------------------------------------------------------------ +! m_HydrostaticPart +!------------------------------------------------------------------------------ + + FUNCTION m_HydrostaticPart( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Hydrostatic part of Tensor :: Trace( T ) / 3 +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_HydrostaticPart + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + T = obj + + m_HydrostaticPart = HydrostaticPart( T ) + + CALL T%Deallocate( ) + + END FUNCTION m_HydrostaticPart + +!------------------------------------------------------------------------------ +! m_DeviatoricPart +!------------------------------------------------------------------------------ + + FUNCTION m_DeviatoricPart( obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Deviatoric part of stress +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define Intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ) :: m_DeviatoricPart + + ! Define internal variables + TYPE( Rank2Tensor_ ) :: T + T = obj + + m_DeviatoricPart = DeviatoricPart( T ) + + CALL T%Deallocate( ) + + END FUNCTION m_DeviatoricPart + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/Rank2Tensor/src/old data/Stress/getStress.part b/src/submodules/Rank2Tensor/src/old data/Stress/getStress.part new file mode 100755 index 000000000..ec38e7198 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress/getStress.part @@ -0,0 +1,228 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: getStress.part +! Last Update : Dec-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the program +! +! DEsSCRIPTION +! - Returns the values stored in the tensor +! HOSTING FILE +! - Stress_Class.F90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! s_getStress_1 +!------------------------------------------------------------------------------ + + SUBROUTINE s_getStress_1( obj, T ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. T = obj%T +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, DIMENSION( :, : ), INTENT( INOUT ) :: T + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>getStress.part",& + "s_getStress_1()",& + "Stress obj is Not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED( T ) ) DEALLOCATE( T ) + T = MatFromVoigtVec( obj%V, "Stress" ) + +END SUBROUTINE s_getStress_1 + +!------------------------------------------------------------------------------ +! s_getStress_2 +!------------------------------------------------------------------------------ + + SUBROUTINE s_getStress_2( obj, Vec ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Vec = obj%V +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, DIMENSION( : ), INTENT( INOUT ) :: Vec + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>getStress.part",& + "s_getStress_2()",& + "Stress obj is Not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED( Vec ) ) DEALLOCATE( Vec ) + + Vec = obj%V + + END SUBROUTINE s_getStress_2 + +!------------------------------------------------------------------------------ +! s_getStress_3 +!------------------------------------------------------------------------------ + + SUBROUTINE s_getStress_3( T, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - For overloading the Assignment operator +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), DIMENSION( 3, 3 ), INTENT( OUT ) :: T + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>getStress.part",& + "Assignement Operator( = )",& + "Stress obj is Not Initiated, & + Program Stopped !!!" & + ) + STOP + + END IF + + T = MatFromVoigtVec( obj%V, "Stress" ) + + CALL Check_Error( & + "Stress_Class.F90>>getStress.part>>Assignemnt Operator", & + "Traceback ---> T = MatFromVoigtVec( obj%V " & + ) + + END SUBROUTINE s_getStress_3 + +!------------------------------------------------------------------------------ +! s_getStress_4 +!------------------------------------------------------------------------------ + + SUBROUTINE s_getStress_4( Vec, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - For overloading the Assignment operator +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + REAL( DFP ), ALLOCATABLE, DIMENSION( : ), INTENT( OUT ) :: Vec + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>getStress.part",& + "Assignement Operator( = )",& + "Stress obj is Not Initiated, & + Program Stopped !!!" & + ) + STOP + + END IF + + IF( ALLOCATED( Vec ) ) DEALLOCATE( Vec ) + + Vec = obj%V + + END SUBROUTINE s_getStress_4 + +!------------------------------------------------------------------------------ +! s_getStress_5 +!------------------------------------------------------------------------------ + + SUBROUTINE s_getStress_5( obj, Tensorobj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Returns the tensor object +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( INOUT ) :: Tensorobj + + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>getStress.part",& + "s_getStress_5",& + "Stress obj is Not Initiated, & + Program Stopped !!!" & + ) + STOP + + END IF + + CALL Tensorobj%Initiate( obj%V, "Stress" ) + + END SUBROUTINE s_getStress_5 + +!------------------------------------------------------------------------------ +! s_getStress_6 +!------------------------------------------------------------------------------ + + SUBROUTINE s_getStress_6( Tensorobj, obj ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Returns the tensor object +!. . . . . . . . . . . . . . . . . . . . + + USE Rank2Tensor_Class + + ! Define intent of dummy variables + CLASS( Stress_ ), INTENT( IN ) :: obj + CLASS( Rank2Tensor_ ), INTENT( OUT ) :: Tensorobj + + Error_Flag = .FALSE. + + IF( .NOT. ALLOCATED( obj%V ) ) THEN + + CALL Err_Msg( & + "Stress_Class.F90>>getStress.part",& + "Assignment Operator( = )",& + "Stress obj is Not Initiated, & + Program Stopped !!!" & + ) + STOP + + END IF + + CALL Tensorobj%Initiate( obj%V, "Stress" ) + + END SUBROUTINE s_getStress_6 diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part new file mode 100755 index 000000000..dacd9c5a3 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Initiate.part @@ -0,0 +1,48 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Initiate.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; Initiate the Sigma object +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! + SUBROUTINE Initiate( Stress, n ) +! +! Description +!------------------------------------------------------------------------------ +! 1. - Initiate the Sigma object +! +!------------------------------------------------------------------------------ +! Define arguments of dummy argument + CLASS(Stress_) :: Stress + INTEGER(I4B), INTENT(IN) :: n + + IF( ALLOCATED( Stress%Sigma ) ) DEALLOCATE( Stress%Sigma ) + + ALLOCATE( Stress%Sigma( n ) ) + + Stress%Sigma( : ) = 0.0_DFP + + END SUBROUTINE Initiate +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part new file mode 100755 index 000000000..ffd5a3114 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Invariants.part @@ -0,0 +1,252 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Invariants.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; Initiate the Sigma object +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSigma_m +!------------------------------------------------------------------------------ +! + FUNCTION getSigma_m(Stress) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! Sigma_m = tr(sigma)/3 +! trSigma = +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP) :: getSigma_m +! + INTEGER(I4B) :: n + n = Stress%getLength() +! + SELECT CASE(n) + CASE(4) + getSigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) & + + Stress%Sigma(4) ) / 3.0_DFP + + CASE(6) + getSigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) & + + Stress%Sigma(3) ) / 3.0_DFP + END SELECT +! + END FUNCTION getSigma_m +! +!------------------------------------------------------------------------------ +! getSigma_bar +!------------------------------------------------------------------------------ +! + FUNCTION getSigma_bar(Stress) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! Sigma_bar = tr(sigma)/3 +! trSigma = +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP) :: getSigma_bar +! + INTEGER(I4B) :: n + n = Stress%getLength() +! + SELECT CASE(n) + CASE(4) + getSigma_bar = SQRT(( (Stress%Sigma(1)-Stress%Sigma(2))**2 & + +(Stress%Sigma(2)-Stress%Sigma(4))**2 & + +(Stress%Sigma(4)-Stress%Sigma(1))**2 & + + 6.0_DFP*Stress%Sigma(3)*Stress%Sigma(3)) / 2.0_DFP) + + CASE(6) + getSigma_bar = SQRT( ( ( Stress%Sigma(1) - Stress%Sigma(2) )**2 & + +( Stress%Sigma(2) - Stress%Sigma(3) )**2 & + +( Stress%Sigma(3) - Stress%Sigma(1) )**2 & + + 6.0_DFP * ( Stress%Sigma(4) * Stress%Sigma(4) & + + Stress%Sigma(5) * Stress%Sigma(5) & + + Stress%Sigma(6) * Stress%Sigma(6) ) & + ) / 2.0_DFP ) + END SELECT +! + END FUNCTION getSigma_bar +! +!------------------------------------------------------------------------------ +! getJ2 +!------------------------------------------------------------------------------ +! + FUNCTION getJ2(Stress) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! Sigma_bar = +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP) :: getJ2 +! + getJ2 = Stress%getSigma_bar()**2 / 3.0_DFP +! + END FUNCTION getJ2 +! +!------------------------------------------------------------------------------ +! getLodeAngle +!------------------------------------------------------------------------------ +! + FUNCTION getLodeAngle(Stress) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! Sigma_bar = +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP) :: getLodeAngle +! + REAL(DFP) :: s1,s2,s3, J3,small=1.0E-10_DFP, sine, Sigma_m, Sigma_bar + INTEGER(I4B):: n + + n = Stress%getLength() + + SELECT CASE(n) + CASE(4) + Sigma_m = Stress%getSigma_m() + Sigma_bar = Stress%getSigma_bar() + + IF(sigma_bar .LT. small) THEN + getLodeAngle = 0.0_DFP + ELSE + s1 = Stress%Sigma(1) - Sigma_m + s2 = Stress%Sigma(2) - Sigma_m + s3 = Stress%Sigma(4) - Sigma_m + J3 = s1*s2*s3 - s3*(Stress%Sigma(3)*Stress%Sigma(3)) + + sine = -13.5_DFP * J3 / Sigma_bar**3 + + IF( sine .GE. 1.0_DFP ) THEN + sine = 1.0_DFP + END IF + IF(sine .LT. -1.0_DFP)THEN + sine = -1.0_DFP + END IF + getLodeAngle = ASIN(sine)/3.0_DFP + END IF + + CASE(6) + Sigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) + Stress%Sigma(3) ) / 3.0_DFP + Sigma_bar = Stress%getSigma_bar() + + s1 = Stress%Sigma(1) - Sigma_m + s2 = Stress%Sigma(2) - Sigma_m + s3 = Stress%Sigma(3) - Sigma_m + + J3 = s1*( s2 * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & + - Stress%Sigma(4) * ( Stress%Sigma(4) * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & + + Stress%Sigma(6) * ( Stress%Sigma(4) * Stress%Sigma(5) - s2 * Stress%Sigma(6) ) + + sine = -13.5_DFP * J3 / Sigma_bar**3 + + IF( sine .GE. 1.0_DFP ) THEN + sine = 1.0_DFP + END IF + IF(sine .LT. -1.0_DFP)THEN + sine = -1.0_DFP + END IF + getLodeAngle = ASIN(sine)/3.0_DFP + + END SELECT +! + END FUNCTION getLodeAngle +! +!------------------------------------------------------------------------------ +! getJ3 +!------------------------------------------------------------------------------ +! + FUNCTION getJ3(Stress) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP) :: getJ3 +! + REAL(DFP) :: s1,s2,s3,small=1.0E-10_DFP, Sigma_m + INTEGER(I4B):: n + + n = Stress%getLength() + + SELECT CASE(n) + CASE(4) + Sigma_m = Stress%getSigma_m() + s1 = Stress%Sigma(1) - Sigma_m + s2 = Stress%Sigma(2) - Sigma_m + s3 = Stress%Sigma(4) - Sigma_m + getJ3 = s1*s2*s3 - s3*(Stress%Sigma(3)*Stress%Sigma(3)) + CASE(6) + Sigma_m = Stress%getSigma_m() + s1 = Stress%Sigma(1) - Sigma_m + s2 = Stress%Sigma(2) - Sigma_m + s3 = Stress%Sigma(3) - Sigma_m + getJ3 = s1*( s2 * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & + - Stress%Sigma(4) * ( Stress%Sigma(4) * s3 - Stress%Sigma(6) * Stress%Sigma(5) ) & + + Stress%Sigma(6) * ( Stress%Sigma(4) * Stress%Sigma(5) - s2 * Stress%Sigma(6) ) + END SELECT +! + END FUNCTION getJ3 +! +!------------------------------------------------------------------------------ +! getStressInvariants +!------------------------------------------------------------------------------ +! + SUBROUTINE getStressInvariants(Stress, Sigma_m, Sigma_bar, theta) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! Sigma_m = tr(sigma)/3 +! Sigma_bar = sqrt(3/2)||S|| +! theta = Lode angle +! Sigma = (sigma11, sigma22, sigma12, sigma33) +! +! 2 - Input is Sigma which is a vector using Voigt +! notation for plane strain +! +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP), INTENT(OUT) :: Sigma_m, Sigma_bar, theta + + Sigma_m = Stress%getSigma_m() + Sigma_bar = Stress%getSigma_bar() + theta = Stress%getLodeAngle() +! + END SUBROUTINE getStressInvariants +! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part new file mode 100755 index 000000000..61d2eaa33 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDecomposition.part @@ -0,0 +1,66 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StressDecomposition.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSigma_m +!------------------------------------------------------------------------------ +! + SUBROUTINE getDeviatoricPart(Stress, S) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! Sigma_m = tr(sigma)/3 +! trSigma = +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(OUT) :: S +! + INTEGER(I4B) :: n + REAL(DFP) :: Sigma_m + Error_flag = .FALSE. + + n = Stress%getLength() +! + SELECT CASE(n) + CASE(4) + Sigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) + Stress%Sigma(4) ) / 3.0_DFP + S(1) = Stress%Sigma(1) - Sigma_m + S(2) = Stress%Sigma(2) - Sigma_m + S(4) = Stress%Sigma(4) - Sigma_m + S(3) = Stress%Sigma(3) + + CASE(6) + Sigma_m = ( Stress%Sigma(1) + Stress%Sigma(2) + Stress%Sigma(3) ) / 3.0_DFP + S(:) = Stress%Sigma(:) + S(1) = Stress%Sigma(1) - Sigma_m + S(2) = Stress%Sigma(2) - Sigma_m + S(3) = Stress%Sigma(3) - Sigma_m + END SELECT +! + END SUBROUTINE getDeviatoricPart +! +!------------------------------------------------------------------------------ +! getSigma_bar +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part new file mode 100755 index 000000000..b1a985cf4 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/StressDerivatives.part @@ -0,0 +1,201 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StressDerivatives.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getDsigma_mDsigma +!------------------------------------------------------------------------------ +! + SUBROUTINE getDsigma_mDsigma(Stress, Dsigma_m) +! +! Description +!------------------------------------------------------------------------------ +! 1 - This subroutine Makes Stress Invariants +! Sigma_m = tr(sigma)/3 +! trSigma = +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(OUT) :: Dsigma_m +! + INTEGER(I4B) :: n + REAL(DFP) :: one3 , zro = 0.0_DFP + Error_flag = .FALSE. + n = Stress%getLength() + one3 = 1.0_DFP / 3.0_DFP +! + SELECT CASE(n) + CASE(4) + Dsigma_m(:) = one3 + Dsigma_m(3) = zro + + CASE(6) + Dsigma_m (1:3) = one3 + Dsigma_m (4:6) = zro + END SELECT +! + END SUBROUTINE getDsigma_mDsigma +! +!------------------------------------------------------------------------------ +! getDJ2Dsigma +!------------------------------------------------------------------------------ +! +! + SUBROUTINE getDJ2Dsigma(Stress, DJ2, Voigt) +! Description +!------------------------------------------------------------------------------ +! 1 - If voigt is true then Kinematic-Voigt notatio is followed +! If Voigt is true then +! DJ2 = [s11, s22, s33, 2*s12, 2*s23, 2*s13] +! +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(OUT) :: DJ2 + LOGICAL(LGT), INTENT(IN), OPTIONAL :: Voigt +! Define internal variables + LOGICAL(LGT) :: isVoigt = .TRUE. + INTEGER(I4B) :: n +! + n = Stress%getLength() +! + IF( PRESENT( Voigt ) ) isVoigt = Voigt +! + CALL Stress%getDeviatoricPart( S = DJ2 ) + + IF( isVoigt ) THEN + SELECT CASE(n) + CASE(4) + DJ2( 3 ) = 2.0_DFP * DJ2( 3 ) + CASE(6) + DJ2( 4 : 6 ) = 2.0_DFP * DJ2( 4 : 6 ) + END SELECT + END IF +! + END SUBROUTINE getDJ2Dsigma +! +! +!------------------------------------------------------------------------------ +! getDsigma_barDJ2 +!------------------------------------------------------------------------------ +! + FUNCTION getDsigma_barDJ2(Stress) +! +! Description +!------------------------------------------------------------------------------ +! 1 - +! +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP) :: getDsigma_barDJ2 +! Define internal variables + REAL(DFP) :: Sigma_bar +! + Sigma_bar = Stress%getSigma_bar() + + getDsigma_barDJ2 = 3.0_DFP / Sigma_bar / 2.0_DFP +! + END FUNCTION getDsigma_barDJ2 +! +!------------------------------------------------------------------------------ +! getDsigma_barDsigma +!------------------------------------------------------------------------------ +! + SUBROUTINE getDsigma_barDsigma(Stress, Dsigma_bar, Voigt) +! +! Description +!------------------------------------------------------------------------------ +! 1 - If voigt is true then Kinematic-Voigt notation is followed +! +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(OUT) :: Dsigma_bar + LOGICAL(LGT), INTENT(IN), OPTIONAL :: Voigt +! Define internal variables + REAL( DFP ), ALLOCATABLE :: DJ2(:) + REAL(DFP) :: a + INTEGER(I4B) :: n +! + n = Stress%getLength() + + ALLOCATE(DJ2(n)) + + IF( PRESENT( Voigt ) ) THEN + CALL Stress%getDJ2Dsigma( DJ2 = DJ2, Voigt = Voigt) + ELSE + CALL Stress%getDJ2Dsigma( DJ2 = DJ2 ) + END IF + + a = Stress%getDsigma_barDJ2() + + Dsigma_bar (:) = a * DJ2 (:) + + DEALLOCATE(DJ2) +! + END SUBROUTINE getDsigma_barDsigma +! +!------------------------------------------------------------------------------ +! getDJ3Dsigma +!------------------------------------------------------------------------------ +! + SUBROUTINE getDJ3Dsigma(Stress, DJ3, Voigt) +! +! Description +!------------------------------------------------------------------------------ +! 1 - +! +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(OUT) :: DJ3 + LOGICAL(LGT), INTENT(IN), OPTIONAL :: Voigt +! Define internal variables + LOGICAL(LGT) :: isVoigt = .TRUE. + INTEGER(I4B) :: n +! + n = Stress%getLength() + + IF(PRESENT(Voigt)) isVoigt = Voigt + + + CALL Stress%getHillTensor(H = DJ3) + + IF(isVoigt) THEN + SELECT CASE(n) + CASE(4) + DJ3( 3 ) = 2.0_DFP * DJ3 (3) + CASE(6) + DJ3( 4 : 6 ) = 2.0_DFP * DJ3( 4 : 6 ) + END SELECT + END IF +! + END SUBROUTINE getDJ3Dsigma +! +!------------------------------------------------------------------------------ +! getDJ3Dsigma +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 new file mode 100755 index 000000000..c7e69be61 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/Stress_Class.F90 @@ -0,0 +1,126 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Stress_Class.F90 +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Module +! +! Info:: - Defines a Stress Class +! +! +!============================================================================== +! +! List of items +! +! +!------------------------------------------------------------------------------ +! +! ----------------------- +! USE ASSOCIATION +! ----------------------- +! + MODULE Stress_Class + USE GlobalData + USE IO +! + IMPLICIT NONE +! +!------------------------------------------------------------------------------ +! IterativeLinearSolver +!------------------------------------------------------------------------------ +! + TYPE :: Stress_ +! +! Description +!------------------------------------------------------------------------------ +! 1. - Stress Class is defined +! +!------------------------------------------------------------------------------ +! Instance variable + REAL(DFP), ALLOCATABLE, DIMENSION(:) :: Sigma +! +! Type bound procedures + CONTAINS +! ------- + PROCEDURE, PUBLIC, PASS :: Initiate + PROCEDURE, PUBLIC, PASS :: setSigma + PROCEDURE, PUBLIC, PASS :: getSigma + PROCEDURE, PUBLIC, PASS :: getLength + PROCEDURE, PUBLIC, PASS :: getSigma_m + PROCEDURE, PUBLIC, PASS :: getSigma_bar + PROCEDURE, PUBLIC, PASS :: getJ2, getJ3 + PROCEDURE, PUBLIC, PASS :: getLodeAngle + PROCEDURE, PUBLIC, PASS :: getDeviatoricPart + PROCEDURE, PUBLIC, PASS :: getHillTensor + PROCEDURE, PUBLIC, PASS :: getDsigma_mDsigma + PROCEDURE, PUBLIC, PASS :: getDJ2Dsigma + PROCEDURE, PUBLIC, PASS :: getDsigma_barDJ2 + PROCEDURE, PUBLIC, PASS :: getDsigma_barDsigma + PROCEDURE, PUBLIC, PASS :: getDJ3Dsigma + PROCEDURE, PUBLIC, PASS :: getStressInvariants +! + END TYPE Stress_ +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! +! --------------- +! PUBLIC/PRIVATE +! --------------- + PRIVATE :: Initiate + PRIVATE :: setSigma + PRIVATE :: getSigma + PRIVATE :: getLength + PRIVATE :: getSigma_m + PRIVATE :: getSigma_bar + PRIVATE :: getJ2, getJ3 + PRIVATE :: getLodeAngle + PRIVATE :: getDeviatoricPart + PRIVATE :: getHillTensor + PRIVATE :: getDsigma_mDsigma + PRIVATE :: getDJ2Dsigma + PRIVATE :: getDsigma_barDJ2 + PRIVATE :: getDsigma_barDsigma + PRIVATE :: getDJ3Dsigma + PRIVATE :: getStressInvariants + + +! ----------- +! CONTAINS +! ----------- + CONTAINS +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! + INCLUDE "./Initiate.part" + + INCLUDE "./setSigma.part" + + INCLUDE "./getSigma.part" + + INCLUDE "./getLength.part" + + INCLUDE "./Invariants.part" + + INCLUDE "./StressDecomposition.part" + + INCLUDE "./getHillTensor.part" + + INCLUDE "./StressDerivatives.part" + +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! +END MODULE Stress_Class diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part new file mode 100755 index 000000000..f72bfb90b --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getHillTensor.part @@ -0,0 +1,88 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: getHillTensor.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! + SUBROUTINE getHillTensor(Stress, H) +! +! Description +!------------------------------------------------------------------------------ +! 1 - Hill tensor is dev(S**2) +!------------------------------------------------------------------------------ +! Define intent of dummy variables +! + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(OUT) :: H +! + REAL(DFP), ALLOCATABLE :: S(:, :), Smat(: , :) + REAL(DFP) :: trS + INTEGER(I4B):: n + + n = Stress%getLength() + + ALLOCATE(S(n,1), Smat(3,3)) + Smat = 0.0_DFP + + CALL Stress%getDeviatoricPart(S = S(:,1)) + + SELECT CASE(n) + CASE(4) + Smat(1, 1) = S(1,1) + Smat(1, 2) = S(3,1) + Smat(2, 1) = S(3,1) + Smat(2, 2) = S(2,1) + Smat(3, 3) = S(4,1) + CASE(6) + Smat = RESHAPE ((/ S(1,1), S(4,1), S(6,1), & + S(4,1), S(2,1), S(5,1), & + S(6,1), S(5,1), S(3,1) & + /), (/ 3, 3/) ) + END SELECT + + DEALLOCATE(S) + ALLOCATE(S(3,3)) + S = MATMUL(Smat, Smat) + trS = S(1,1) + S(2,2) + S(3,3) + S(1,1) = S(1,1) - trS / 3.0_DFP + S(2,2) = S(2,2) - trS / 3.0_DFP + S(3,3) = S(3,3) - trS / 3.0_DFP + + SELECT CASE(n) + CASE(4) + H(1) = S(1,1) + H(2) = S(2,2) + H(3) = S(1,2) + H(4) = S(3,3) + CASE(6) + H(1) = S(1,1) + H(2) = S(2,2) + H(3) = S(3,3) + H(4) = S(1,2) + H(5) = S(2,3) + H(6) = S(1,3) + END SELECT + + DEALLOCATE(S, Smat) +! + END SUBROUTINE getHillTensor +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part new file mode 100755 index 000000000..d1c98c3ca --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getLength.part @@ -0,0 +1,44 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: getLength.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! +! + INTEGER(I4B) FUNCTION getLength(Stress) +! +! Description +!------------------------------------------------------------------------------ +! 1. - get the Sigma object +! +!------------------------------------------------------------------------------ +! Define arguments of dummy argument + CLASS(Stress_) :: Stress +! + getLength = SIZE(Stress%Sigma) + + END FUNCTION getLength +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part new file mode 100755 index 000000000..aa974428c --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/getSigma.part @@ -0,0 +1,60 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: getSigma.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; Initiate the Sigma object +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! +! + SUBROUTINE getSigma(Stress, Sigma) +! +! Description +!------------------------------------------------------------------------------ +! 1. - get the Sigma object +! +!------------------------------------------------------------------------------ +! Define arguments of dummy argument + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(OUT) :: Sigma +! + IF(.NOT. ALLOCATED(Stress%Sigma)) THEN + CALL Err_msg("Stress_Class.F90", "getSigma", & + "Stress%Sigma is not allocated first use initiate") + + Error_Flag = .TRUE. + RETURN + END IF + + IF(SIZE(Stress%Sigma) .NE. SIZE(Sigma)) THEN + CALL Err_msg("Stress_Class.F90", "getSigma", & + "The size of Stress%Sigma is not same as Sigma") + Error_Flag = .TRUE. + STOP + END IF +! + Sigma(:) = Stress%Sigma(:) +! + END SUBROUTINE getSigma +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part b/src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part new file mode 100755 index 000000000..d4cbd0b4b --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Stress_Old/setSigma.part @@ -0,0 +1,50 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: setSigma.part +! Last Update : March-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type :: Part of the Code +! +! Info :: - Part of the code; Initiate the Sigma object +! +! Hosting File +! :: - Stress_Class.F90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! +! + SUBROUTINE setSigma(Stress, Sigma) +! +! Description +!------------------------------------------------------------------------------ +! 1. - set the Sigma object +! +!------------------------------------------------------------------------------ +! Define arguments of dummy argument + CLASS(Stress_) :: Stress + REAL(DFP), DIMENSION(:), INTENT(IN):: Sigma +! + INTEGER(I4B) :: n +! + n = SIZE(Sigma, 1) + CALL Stress%Initiate(n) +! + Stress%Sigma(:) = Sigma(:) + + END SUBROUTINE setSigma +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/Rank2Tensor/src/old data/Tensor.F90 b/src/submodules/Rank2Tensor/src/old data/Tensor.F90 new file mode 100755 index 000000000..a82a060d2 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/Tensor.F90 @@ -0,0 +1,33 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Tensor.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Module +! +! Info:: - This module includes all the tensor related classes +!============================================================================== + +MODULE Tensor + USE Rank2Tensor_Class + USE DeformationGradient_Class + USE Stress_Class + USE LeftCauchyGreen_Class + USE RightCauchyGreen_Class + USE Strain_Class + USE SmallStrain_Class + USE GreenStrain_Class + USE AlmansiStrain_Class + USE VelocityGradient_Class + USE StrainRate_Class + USE ContinuumSpin_Class + USE MaterialJacobian_Class + USE ConstitutiveData_Class +END MODULE Tensor \ No newline at end of file diff --git a/src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 b/src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 new file mode 100755 index 000000000..3dd4c9ef1 --- /dev/null +++ b/src/submodules/Rank2Tensor/src/old data/VelocityGradient/VelocityGradient_Class.F90 @@ -0,0 +1,96 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: VelocityGradient_Class.F90 +! Last Update : Dec-29-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Rank2Tensor class is extended to Define VelocityGradient Class +!============================================================================== + + MODULE VelocityGradient_Class + USE GlobalData + USE IO + USE Rank2Tensor_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: VelocityGradient_, VelocityGradient, VelocityGradient_Pointer + +!------------------------------------------------------------------------------ +! VelocityGradient_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( Rank2Tensor_ ) :: VelocityGradient_ + + END TYPE VelocityGradient_ + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + INTERFACE VelocityGradient + MODULE PROCEDURE Constructor1 + END INTERFACE + + INTERFACE VelocityGradient_Pointer + MODULE PROCEDURE Constructor_1 + END INTERFACE + +!. . . . . . . . . . . . . . . . . . . . +! +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy varialbes + CLASS( VelocityGradient_ ), POINTER :: Constructor_1 + + ALLOCATE( Constructor_1 ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Velocity Gradient constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( VelocityGradient_ ) :: Constructor1 + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + + END MODULE VelocityGradient_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/RealMatrix/CMakeLists.txt b/src/submodules/RealMatrix/CMakeLists.txt new file mode 100644 index 000000000..569d8a922 --- /dev/null +++ b/src/submodules/RealMatrix/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}/RealMatrix_Method@IOMethods.F90 + ${src_path}/RealMatrix_Method@ConstructorMethods.F90 + ${src_path}/RealMatrix_Method@GetValuesMethods.F90 + ${src_path}/RealMatrix_Method@SetValuesMethods.F90 + ${src_path}/RealMatrix_Method@MatmulMethods.F90 + ${src_path}/RealMatrix_Method@LAPACKMethods.F90 + ${src_path}/RealMatrix_Method@IterativeSolverMethods.F90 +) diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 new file mode 100644 index 000000000..57d84d14a --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@BLASMethods.F90 @@ -0,0 +1,17 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 new file mode 100644 index 000000000..32bae5ad0 --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 @@ -0,0 +1,295 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 (RealMatrix_Method) ConstructorMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Shape +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_shape + IF( ALLOCATED( obj%val ) ) THEN + Ans = SHAPE( obj%val ) + ELSE + Ans = 0 + END IF +END PROCEDURE get_shape + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_size + !Define internal variables + INTEGER( I4B ) :: S( 2 ) + IF( ALLOCATED( obj%val ) ) THEN + S = SHAPE( obj%val ) + IF( PRESENT( Dims ) ) THEN + Ans = S( Dims ) + ELSE + Ans = S( 1 ) * S( 2 ) + END IF + ELSE + Ans = 0 + END IF +END PROCEDURE get_size + +!---------------------------------------------------------------------------- +! getTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_tdimension + ans = obj%tDimension +END PROCEDURE get_tdimension + +!---------------------------------------------------------------------------- +! setTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE set_tdimension + obj%tDimension = tDimension +END PROCEDURE set_tdimension + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE allocate_data + CALL Reallocate( obj%val, Dims(1), Dims(2) ) + CALL setTotalDimension( obj, 2_I4B ) +END PROCEDURE allocate_data + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Deallocate_Data + IF( ALLOCATED( obj%val ) ) DEALLOCATE( obj%val ) + CALL setTotalDimension( obj, 0 ) +END PROCEDURE Deallocate_Data + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_initiate1 + CALL Allocate( obj, Dims ) +END PROCEDURE realmat_initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_initiate2 + CALL Allocate( obj, [nrow, ncol] ) +END PROCEDURE realmat_initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_initiate3 + INTEGER( I4B ) :: j + DO j = 1, SIZE( obj ) + CALL Allocate( obj( j ), Dims ) + END DO +END PROCEDURE realmat_initiate3 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_initiate4 + INTEGER( I4B ) :: j + DO j = 1, SIZE( obj ) + CALL Allocate( obj( j ), Dims( j, : ) ) + END DO +END PROCEDURE realmat_initiate4 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_initiate5 + obj%val = val + CALL setTotalDimension( obj, 2_I4B ) +END PROCEDURE realmat_initiate5 + +!---------------------------------------------------------------------------- +! Matrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor1 + CALL Initiate( obj, Dims ) +END PROCEDURE Constructor1 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realMat_eye1 + INTEGER( I4B ) :: i + CALL Initiate( Ans, [m,m] ) + DO i = 1, m + Ans%val ( i, i ) = 1.0 + END DO +END PROCEDURE realMat_eye1 + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_convert_1 + CALL Convert( From=From%val, To=To%val, Conversion=Conversion, nns=nns, & + & tdof=tdof ) +END PROCEDURE realmat_convert_1 + +!---------------------------------------------------------------------------- +! Sym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE sym_array + Ans = 0.5_DFP * ( obj + TRANSPOSE( obj ) ) +END PROCEDURE sym_array + +!---------------------------------------------------------------------------- +! Sym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE sym_obj + Ans%val = 0.5_DFP * ( obj%val + TRANSPOSE( obj%val ) ) +END PROCEDURE sym_obj + +!---------------------------------------------------------------------------- +! SkewSym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SkewSym_array + Ans = 0.5_DFP * ( obj - TRANSPOSE( obj ) ) +END PROCEDURE SkewSym_array + +!---------------------------------------------------------------------------- +! SkewSym +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SkewSym_obj + Ans%val = 0.5_DFP * ( obj%val - TRANSPOSE( obj%val ) ) +END PROCEDURE SkewSym_obj + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_make_diag_copy1 + INTEGER( I4B ) :: I, s( 2 ) + REAL( DFP ), ALLOCATABLE :: DummyMat2( :, : ) + + IF( ALLOCATED( mat ) ) THEN + s = SHAPE( mat ) + DummyMat2 = mat + CALL Reallocate( mat, s( 1 )*nCopy, s( 2 )*nCopy ) + DO I = 1, nCopy + mat( ( I - 1 ) * s( 1 ) + 1 : I * s( 1 ), & + & ( I - 1 ) * s( 2 ) + 1 : I * s( 2 ) ) & + & = DummyMat2( :, : ) + END DO + DEALLOCATE( DummyMat2 ) + END IF +END PROCEDURE realmat_make_diag_copy1 + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_make_diag_copy2 + INTEGER( I4B ) :: I, S( 2 ) + S = SHAPE( From ) + CALL Reallocate( To, S( 1 )*nCopy, S( 2 )*nCopy ) + To = 0.0_DFP + DO I = 1, nCopy + To( ( I - 1 ) * S( 1 ) + 1 : I * S( 1 ), & + & ( I - 1 ) * S( 2 ) + 1 : I * S( 2 ) ) & + & = From( :, : ) + END DO +END PROCEDURE realmat_make_diag_copy2 + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_make_diag_copy3 + CALL realmat_make_diag_copy1( Mat = Mat%val, nCopy = nCopy ) +END PROCEDURE realmat_make_diag_copy3 + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_make_diag_copy4 + CALL realmat_make_diag_copy2( From = From%val, To = To%val, & + & nCopy = nCopy ) +END PROCEDURE realmat_make_diag_copy4 + +!---------------------------------------------------------------------------- +! Random_Number +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_random_number + IF( PRESENT( m ) .AND. PRESENT( n ) ) THEN + CALL Reallocate( obj%val, m, n ) + CALL RANDOM_NUMBER( obj%val ) + RETURN + END IF + + IF( PRESENT( m ) ) THEN + CALL Reallocate( obj%val, m, m ) + CALL RANDOM_NUMBER( obj%val ) + RETURN + END IF + + IF( PRESENT( n ) ) THEN + CALL Reallocate( obj%val, n, n ) + CALL RANDOM_NUMBER( obj%val ) + RETURN + END IF + + CALL RANDOM_NUMBER( obj%val ) + +END PROCEDURE realmat_random_number + +!---------------------------------------------------------------------------- +! testMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TestMatrix + SELECT CASE( matNo ) + CASE( 1 ) + ALLOCATE( Ans( 4, 4 ) ) + Ans( :, 1 ) = [3.0, -3.0, 6.0, -9.0] + Ans( :, 2 ) = [-7.0, 5.0, -4.0, 5.0] + Ans( :, 3 ) = [-2.0, 1.0, 0.0, -5.0] + Ans( :, 4 ) = [2.0, 0.0, -5.0, 12.0] + END SELECT +END PROCEDURE TestMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +END SUBMODULE ConstructorMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 new file mode 100644 index 000000000..028a1c84d --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@GetValuesMethods.F90 @@ -0,0 +1,174 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealMatrix_Method) GetvaluesMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get1 +IF (ALLOCATED(obj%val)) THEN + CALL reallocate(ans, SIZE(obj, 1), SIZE(obj, 2)) + ans = obj%val +ELSE + CALL reallocate(ans, 0, 0) +END IF +END PROCEDURE realmat_Get1 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get1b +ans = realmat_get1(obj=obj, datatype=1.0_DFP) +END PROCEDURE realmat_Get1b + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get2 +ans = obj%val(RIndx, CIndx) +END PROCEDURE realmat_Get2 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get3 +#define Indx iStart:iEnd:Stride +ans = obj%val(Indx, Indx) +#undef Indx +END PROCEDURE realmat_Get3 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get4 +ans%val = obj%val +CALL SetTotalDimension(ans, 2_I4B) +END PROCEDURE realmat_Get4 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get5 +ans%val = obj%val(RIndx, CIndx) +CALL SetTotalDimension(ans, 2_I4B) +END PROCEDURE realmat_Get5 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get6 +#define Indx iStart:iEnd:Stride +ans%val = obj%val(Indx, Indx) +#undef Indx +CALL SetTotalDimension(ans, 2_I4B) +END PROCEDURE realmat_Get6 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get7 +INTEGER(I4B) :: s(2), i, j, r1, r2, c1, c2 +INTEGER(I4B), ALLOCATABLE :: rc(:, :) + !! + !! main + !! +s = SHAPE(obj) +ALLOCATE (rc(0:2, 0:(s(1) * s(2)))) +rc = 0 + !! +DO j = 1, s(2) + DO i = 1, s(1) + rc(1:2, i + (j - 1) * s(1)) = SHAPE(obj(i, j)) + END DO +END DO + !! +i = MAXVAL(SUM(RESHAPE(rc(1, 1:), SHAPE(obj)), 1)) +j = MAXVAL(SUM(RESHAPE(rc(2, 1:), SHAPE(obj)), 2)) + !! +ALLOCATE (ans(i, j)); ans = 0.0_DFP + !! +c1 = 0; c2 = 0 + !! +DO j = 1, s(2) + c1 = 1 + c2 + c2 = c1 + rc(2, j) - 1 + r1 = 0; r2 = 0 + DO i = 1, s(1) + r1 = 1 + r2 + r2 = r1 + rc(1, i) - 1 + ans(r1:r2, c1:c2) = obj(i, j)%val + END DO +END DO + !! +END PROCEDURE realmat_Get7 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Get8 +ans%val = Get(obj, TypeDFP) +CALL SetTotalDimension(ans, 2_I4B) +END PROCEDURE realmat_Get8 + +!---------------------------------------------------------------------------- +! Copy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Copy1 +To = from%val +END PROCEDURE realmat_Copy1 + +!---------------------------------------------------------------------------- +! Copy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Copy2 +to%val = from%val +CALL SetTotalDimension(To, 2_I4B) +END PROCEDURE realmat_Copy2 + +!---------------------------------------------------------------------------- +! Copy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Copy3 +to%val = from +CALL SetTotalDimension(To, 2_I4B) +END PROCEDURE realmat_Copy3 + +!---------------------------------------------------------------------------- +! ArrayPointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_GetPointer +ans => obj%val +END PROCEDURE realmat_GetPointer + +END SUBMODULE GetvaluesMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 new file mode 100644 index 000000000..61f17d819 --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@IOMethods.F90 @@ -0,0 +1,55 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 7 March 2021 +! summary: This module contains IO methods for [[RealMatrix_]] + +SUBMODULE(RealMatrix_Method) IOMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Display1 + CALL Display( obj%Val, msg, UnitNo=UnitNo ) +END PROCEDURE realmat_Display1 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_Display2 + INTEGER( I4B ) :: j + !! + DO j = 1, SIZE( obj ) + !! + CALL Display( & + & obj( j )%Val, & + & trim(msg)// ' (' // tostring(j) // '): ', & + & UnitNo=UnitNo ) + !! + CALL Blanklines( UnitNo = UnitNo, NOL = 2 ) + !! + END DO + !! +END PROCEDURE realmat_Display2 + +END SUBMODULE IOMethods \ No newline at end of file diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 new file mode 100644 index 000000000..654426487 --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@IterativeSolverMethods.F90 @@ -0,0 +1,151 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealMatrix_Method) IterativeSolverMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! CG +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_CG_1 +REAL(DFP) :: alpha, beta, tol, pap, error0, error, rr1, rr2 +REAL(DFP) :: w(SIZE(rhs), 3) +REAL(DFP), PARAMETER :: default_atol = 0.0_DFP +REAL(DFP), PARAMETER :: default_rtol = 1.0E-6 +INTEGER(I4B), PARAMETER :: default_maxiter = 10 +! 1=r 2=p 3=Ap +INTEGER(I4B) :: maxiter0 +INTEGER(I4B) :: ii +INTEGER(I4B) :: convIn +LOGICAL(LGT) :: recomputeRes + +! temp storage of Ax0 +w(:, 2) = MATMUL(mat, sol) ! BLAS + +! r0=b-Ax0 +w(:, 1) = rhs - w(:, 2) ! BLAS + +! p0=r0 +w(:, 2) = w(:, 1) ! BLAS + +convIn = INPUT(option=convergenceIn, default=convergenceInRes) + +! tol +IF (INPUT(option=relativeToRHS, default=.FALSE.)) THEN + + ! rto*||b||+atol + tol = NORM2(rhs) ! BLAS + +ELSE + IF (convIn .EQ. convergenceInRes) THEN + + ! rtol*r0+atol + tol = NORM2(w(:, 1)) ! BLAS + error0 = tol + + ELSE + + ! rtol*dx0+atol + rr1 = DOT_PRODUCT(w(:, 1), w(:, 1)) ! BLAS + w(:, 3) = MATMUL(mat, w(:, 1)) ! BLAS + pap = DOT_PRODUCT(w(:, 1), w(:, 3)) ! BLAS + alpha = rr1 / pap + ! dx0=alpha||p0|| + error0 = SQRT(rr1) + tol = ABS(alpha) * error0 + END IF +END IF + +tol = INPUT(default=default_rtol, option=rtol) * tol & + & + INPUT(default=default_atol, option=atol) + +! Check convergence +IF (convIn .EQ. convergenceInRes) THEN + IF (error0 .LE. tol) THEN + RETURN + END IF +END IF + +! maxiter0 +IF (PRESENT(maxiter)) THEN + + IF (maxiter .LT. 0) THEN + maxiter0 = maxI4B + ELSE + maxiter0 = maxiter + END IF + +ELSE + maxiter0 = MIN(SIZE(rhs), default_maxiter) +END IF + +! recomputeRes +IF (PRESENT(restartAfter)) THEN + recomputeRes = .TRUE. +ELSE + recomputeRes = .FALSE. +END IF + +ii = 0 + +! Start iteration +DO + rr1 = DOT_PRODUCT(w(:, 1), w(:, 1)) ! BLAS + w(:, 3) = MATMUL(mat, w(:, 2)) ! BLAS + pap = DOT_PRODUCT(w(:, 2), w(:, 3)) ! BLAS + alpha = rr1 / pap + + ! increse the iteration + ii = ii + 1 + + ! update solution + sol = sol + alpha * w(:, 2) ! BLAS + + IF (recomputeRes) THEN + IF (MOD(ii, restartAfter) .EQ. 0) THEN + ! temp storage of Ax + w(:, 3) = MATMUL(mat, sol) ! BLAS + w(:, 1) = rhs - w(:, 3) ! BLAS + END IF + ELSE + w(:, 1) = w(:, 1) - alpha * w(:, 3) ! BLAS + END IF + + rr2 = DOT_PRODUCT(w(:, 1), w(:, 1)) ! BLAS + + ! check convergence + IF (convIn .EQ. convergenceInRes) THEN + error = SQRT(rr2) + IF ((error .LE. tol) .OR. (ii .GT. maxiter0)) EXIT + ELSE + error = alpha * NORM2(w(:, 2)) + ! BLAS + IF ((error .LE. tol) .OR. (ii .GT. maxiter0)) EXIT + END IF + + ! beta + beta = rr2 / rr1 + + ! update p + w(:, 2) = w(:, 1) + beta * w(:, 2) ! BLAS +END DO + +END PROCEDURE realmat_CG_1 + +END SUBMODULE IterativeSolverMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 new file mode 100644 index 000000000..3126b5ce2 --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@LAPACKMethods.F90 @@ -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 +! + +SUBMODULE(RealMatrix_Method) LAPACKMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS +END SUBMODULE LAPACKMethods diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.F90 new file mode 100644 index 000000000..58675e338 --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@MatmulMethods.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(RealMatrix_Method) MatmulMethods +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_MatMul1 + Ans%Val = MATMUL( obj1%Val, obj2%Val ) + CALL SetTotalDimension( Ans, 2_I4B ) +END PROCEDURE realmat_MatMul1 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_MatMul2 + Ans = MATMUL( obj%Val, Vec ) +END PROCEDURE realmat_MatMul2 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_MatMul3 + Ans = RealVector( MATMUL( obj%Val, Vec%Val ) ) +END PROCEDURE realmat_MatMul3 + +END SUBMODULE MatmulMethods \ No newline at end of file diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 new file mode 100644 index 000000000..5323683ac --- /dev/null +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@SetValuesMethods.F90 @@ -0,0 +1,427 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealMatrix_Method) SetValuesMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! setValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_set_1 + obj%Val = Val +END PROCEDURE realmat_set_1 + +!---------------------------------------------------------------------------- +! setValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_set_2 + obj%Val( Row, Col ) = Val +END PROCEDURE realmat_set_2 + +!---------------------------------------------------------------------------- +! setValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_set_3 + obj%Val( Row, Col ) = Val +END PROCEDURE realmat_set_3 + +!---------------------------------------------------------------------------- +! setValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_set_4 + INTEGER( I4B ) :: i + ! + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + IF( Indx .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx + obj%Val( i-Indx, i ) = Val( i ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx + obj%Val( i, i+Indx ) = Val( i ) + END DO + END IF + CASE( MATRIX_ROW ) + ! row + IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN + obj%Val( Indx, 1:SIZE( Val ) ) = Val + END IF + CASE( MATRIX_COLUMN ) + IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN + obj%Val( 1:SIZE( Val ), Indx ) = Val + END IF + END SELECT +END PROCEDURE realmat_set_4 + +!---------------------------------------------------------------------------- +! setValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_set_5 + INTEGER( I4B ) :: i, j + ! + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + DO j = 1, SIZE( Indx ) + IF( Indx( j ) .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) + obj%Val( i-Indx( j ), i ) = Val( i, j ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) + obj%Val( i, i+Indx( j ) ) = Val( i, j ) + END DO + END IF + END DO + CASE( MATRIX_ROW ) + ! row + DO j = 1, SIZE( Indx ) + obj%Val( Indx( j ), : ) = Val( j, : ) + END DO + CASE( MATRIX_COLUMN ) + ! col + DO j = 1, SIZE( Indx ) + obj%Val( :, Indx( j ) ) = Val( :, j ) + END DO + END SELECT +END PROCEDURE realmat_set_5 + +!---------------------------------------------------------------------------- +! setValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_set_6 + obj%Val=1.0_DFP +END PROCEDURE realmat_set_6 + +!---------------------------------------------------------------------------- +! addContribution +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_add_1 + SELECT CASE( IACHAR( Op ) ) + CASE( 43 ) + ! + + obj%Val = obj%Val + Scale * Val + CASE( 45 ) + ! - + obj%Val = obj%Val - Scale * Val + CASE( 42 ) + ! * + obj%Val = Scale * (obj%Val * Val) + CASE( 47 ) + ! / + obj%Val = ( obj%Val / Val ) / Scale + END SELECT +END PROCEDURE realmat_add_1 + +!---------------------------------------------------------------------------- +! addContribution +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_add_2 + SELECT CASE( IACHAR( Op ) ) + CASE( 43 ) + ! + + obj%Val( Row, Col ) = obj%Val( Row, Col ) + Scale * Val + CASE( 45 ) + ! - + obj%Val( Row, Col ) = obj%Val( Row, Col ) - Scale * Val + CASE( 42 ) + ! * + obj%Val( Row, Col ) = Scale * obj%Val( Row, Col ) * Val + CASE( 47 ) + ! / + obj%Val( Row, Col ) = obj%Val( Row, Col ) / Val / Scale + END SELECT +END PROCEDURE realmat_add_2 + +!---------------------------------------------------------------------------- +! realmat_add_3 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_add_3 + SELECT CASE( IACHAR( Op ) ) + CASE( 43 ) + ! + + obj%Val( Row, Col ) = obj%Val( Row, Col ) + Scale * Val + CASE( 45 ) + ! - + obj%Val( Row, Col ) = obj%Val( Row, Col ) - Scale * Val + CASE( 42 ) + ! * + obj%Val( Row, Col ) = Scale * obj%Val( Row, Col ) * Val + CASE( 47 ) + ! / + obj%Val( Row, Col ) = obj%Val( Row, Col ) / Val / Scale + END SELECT +END PROCEDURE realmat_add_3 + +!---------------------------------------------------------------------------- +! realmat_add_4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_add_4 + INTEGER( I4B ) :: i + SELECT CASE( IACHAR( Op ) ) + CASE( 43 ) + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + IF( Indx .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx + obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) + Scale * Val( i ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx + obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) + Scale * Val( i ) + END DO + END IF + CASE( MATRIX_ROW ) + ! row + IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN + obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & + & + Scale * Val + END IF + CASE( MATRIX_COLUMN ) + IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN + obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & + & + Scale * Val + END IF + END SELECT + CASE( 45 ) + SELECT CASE( ExtraOption ) + CASE( 0 ) + ! diagonal + IF( Indx .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx + obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) - Scale * Val( i ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx + obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) - Scale * Val( i ) + END DO + END IF + CASE( 1 ) + ! row + IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN + obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & + & - Scale * Val + END IF + CASE( 2 ) + IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN + obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & + & - Scale * Val + END IF + END SELECT + CASE( 42 ) + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + IF( Indx .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx + obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) * Scale * Val( i ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx + obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) * Scale * Val( i ) + END DO + END IF + CASE( MATRIX_ROW ) + ! row + IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN + obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & + & * Scale * Val + END IF + CASE( MATRIX_COLUMN ) + IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN + obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & + & * Scale * Val + END IF + END SELECT + CASE( 47 ) + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + IF( Indx .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx + obj%Val( i-Indx, i ) = obj%Val( i-Indx, i ) / Scale / Val( i ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx + obj%Val( i, i+Indx ) = obj%Val( i, i+Indx ) / Scale / Val( i ) + END DO + END IF + CASE( MATRIX_ROW ) + ! row + IF( Indx .LE. SIZE( obj%Val, 1 ) ) THEN + obj%Val( Indx, 1:SIZE( Val ) ) = obj%Val( Indx, 1:SIZE( Val ) ) & + & / Scale / Val + END IF + CASE( MATRIX_COLUMN ) + IF( Indx .LE. SIZE( obj%Val, 2 ) ) THEN + obj%Val( 1:SIZE( Val ), Indx ) = obj%Val( 1:SIZE( Val ), Indx ) & + & / Scale / Val + END IF + END SELECT + END SELECT +END PROCEDURE realmat_add_4 + +!---------------------------------------------------------------------------- +! addContribution +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_add_5 + INTEGER( I4B ) :: i, j + ! + SELECT CASE( IACHAR( Op ) ) + CASE( 43 ) + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + DO j = 1, SIZE( Indx ) + IF( Indx( j ) .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) + obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) & + & + Scale * Val( i, j ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) + obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) + & + & Scale * Val( i, j ) + END DO + END IF + END DO + CASE( MATRIX_ROW ) + ! row + DO j = 1, SIZE( Indx ) + obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) + & + & Scale * Val( j, : ) + END DO + CASE( MATRIX_COLUMN ) + ! col + DO j = 1, SIZE( Indx ) + obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) + & + & Scale * Val( :, j ) + END DO + END SELECT + CASE( 45 ) + ! - + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + DO j = 1, SIZE( Indx ) + IF( Indx( j ) .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) + obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) & + & - Scale * Val( i, j ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) + obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) - & + & Scale * Val( i, j ) + END DO + END IF + END DO + CASE( MATRIX_ROW ) + ! row + DO j = 1, SIZE( Indx ) + obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) - & + & Scale * Val( j, : ) + END DO + CASE( MATRIX_COLUMN ) + ! col + DO j = 1, SIZE( Indx ) + obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) - & + & Scale * Val( :, j ) + END DO + END SELECT + CASE( 42 ) + ! * + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + DO j = 1, SIZE( Indx ) + IF( Indx( j ) .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) + obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) * & + & Scale * Val( i, j ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) + obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) * & + & Scale * Val( i, j ) + END DO + END IF + END DO + CASE( MATRIX_ROW ) + ! row + DO j = 1, SIZE( Indx ) + obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) * & + & Scale * Val( j, : ) + END DO + CASE( MATRIX_COLUMN ) + ! col + DO j = 1, SIZE( Indx ) + obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) * & + & Scale * Val( :, j ) + END DO + END SELECT + CASE( 47 ) + ! / + SELECT CASE( ExtraOption ) + CASE( MATRIX_DIAGONAL ) + ! diagonal + DO j = 1, SIZE( Indx ) + IF( Indx( j ) .LT. 0 ) THEN + DO i = 1, SIZE( obj%Val, 2 ) + Indx( j ) + obj%Val( i-Indx( j ), i ) = obj%Val( i-Indx( j ), i ) / & + & Scale / Val( i, j ) + END DO + ELSE + DO i = 1, SIZE( obj%Val, 1 ) - Indx( j ) + obj%Val( i, i+Indx( j ) ) = obj%Val( i, i+Indx( j ) ) / & + & Scale / Val( i, j ) + END DO + END IF + END DO + CASE( MATRIX_ROW ) + ! row + DO j = 1, SIZE( Indx ) + obj%Val( Indx( j ), : ) = obj%Val( Indx( j ), : ) / & + & Scale / Val( j, : ) + END DO + CASE( MATRIX_COLUMN ) + ! col + DO j = 1, SIZE( Indx ) + obj%Val( :, Indx( j ) ) = obj%Val( :, Indx( j ) ) / & + & Scale / Val( :, j ) + END DO + END SELECT + END SELECT +END PROCEDURE realmat_add_5 + +END SUBMODULE SetValuesMethods \ No newline at end of file diff --git a/src/submodules/RealVector/CMakeLists.txt b/src/submodules/RealVector/CMakeLists.txt new file mode 100644 index 000000000..67b6dee0f --- /dev/null +++ b/src/submodules/RealVector/CMakeLists.txt @@ -0,0 +1,34 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/RealVector_AddMethods@Methods.F90 + ${src_path}/RealVector_AppendMethods@Methods.F90 + ${src_path}/RealVector_AssignMethods@Methods.F90 + ${src_path}/RealVector_Blas1Methods@Methods.F90 + ${src_path}/RealVector_ComparisonMethods@Methods.F90 + ${src_path}/RealVector_ConstructorMethods@Methods.F90 + ${src_path}/RealVector_GetMethods@Methods.F90 + ${src_path}/RealVector_GetValueMethods@Methods.F90 + ${src_path}/RealVector_IOMethods@Methods.F90 + ${src_path}/RealVector_Norm2ErrorMethods@Methods.F90 + ${src_path}/RealVector_Norm2Methods@Methods.F90 + ${src_path}/RealVector_SetMethods@Methods.F90 + ${src_path}/RealVector_ShallowCopyMethods@Methods.F90 +) diff --git a/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 new file mode 100644 index 000000000..21482901d --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90 @@ -0,0 +1,370 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealVector_AddMethods) Methods +USE GlobalData, ONLY: DOF_FMT, NODES_FMT + +USE DOF_Method, ONLY: DOF_Add => Add, & + OPERATOR(.tdof.), & + GetNodeLoc + +USE F77_BLAS, ONLY: F77_AXPY + +USE F95_BLAS, ONLY: F95_AXPY => AXPY + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add1 +! obj%val = obj%val + scale * VALUE +REAL(DFP) :: aval(1) +INTEGER(I4B) :: N +aval(1) = VALUE +N = SIZE(obj%val) +CALL F77_AXPY(N=N, A=scale, X=aval, INCX=0_I4B, Y=obj%val, INCY=1_I4B) +END PROCEDURE obj_Add1 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add2 +! obj%val = obj%val + scale * VALUE +CALL F95_AXPY(A=scale, X=VALUE, Y=obj%val) +END PROCEDURE obj_Add2 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add3 +obj%val(nodenum) = obj%val(nodenum) + scale * VALUE +END PROCEDURE obj_Add3 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add4 +obj%val(nodenum) = obj%val(nodenum) + scale * VALUE +END PROCEDURE obj_Add4 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add5 +IF (SIZE(VALUE) .EQ. 1) THEN + obj%val(nodenum) = obj%val(nodenum) + scale * VALUE(1) + RETURN +END IF + +obj%val(nodenum) = obj%val(nodenum) + scale * VALUE +END PROCEDURE obj_Add5 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add6 +! obj%val(istart:iend:stride) = obj%val(istart:iend:stride) + scale * VALUE +REAL(DFP) :: aval(1) +INTEGER(I4B) :: N +aval(1) = VALUE +N = INT((iend - istart + stride) / stride) +CALL F77_AXPY(N=N, A=scale, X=aval, INCX=0_I4B, Y=obj%val(istart:), & + INCY=stride) +END PROCEDURE obj_Add6 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add7 +! obj%val(istart:iend:stride) = obj%val(istart:iend:stride) + scale * VALUE +INTEGER(I4B) :: N + +N = SIZE(VALUE) +CALL F77_AXPY(N=N, A=scale, X=VALUE, INCX=1_I4B, Y=obj%val(istart:), & + INCY=stride) +END PROCEDURE obj_Add7 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add8 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, conversion=conversion) +END PROCEDURE obj_Add8 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add9 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add9 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add10 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, idof=idof) +END PROCEDURE obj_Add10 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add11 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + scale=scale, idof=idof) +END PROCEDURE obj_Add11 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add12 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, idof=idof, ivar=ivar) +END PROCEDURE obj_Add12 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add13 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + scale=scale, idof=idof, ivar=ivar) +END PROCEDURE obj_Add13 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add14 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add14 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add15 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add15 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add16 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add16 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add17 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add17 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add18 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add18 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add19 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add19 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add20 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add20 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add21 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, idof=idof) +END PROCEDURE obj_Add21 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add22 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, ivar=ivar, idof=idof) +END PROCEDURE obj_Add22 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add23 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add23 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add24 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add24 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add25 +CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Add25 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add26 +! obj%val = obj%val + scale * VALUE%val +CALL F95_AXPY(A=scale, X=VALUE%val, Y=obj%val) +END PROCEDURE obj_Add26 + +!---------------------------------------------------------------------------- +! add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add27 +INTEGER(I4B) :: tdof, s(3), idof + +tdof = .tdof.dofobj + +DO idof = 1, tdof + s = GetNodeLoc(obj=dofobj, idof=idof) + CALL obj_Add7(obj=obj, istart=s(1), iend=s(2), stride=s(3), scale=scale, & + VALUE=VALUE(:, idof)) +END DO + +END PROCEDURE obj_Add27 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add28 +INTEGER(I4B) :: s(3) +s = GetNodeLoc(obj=dofobj, idof=idof) +CALL obj_Add7(obj=obj, istart=s(1), iend=s(2), stride=s(3), scale=scale, & + VALUE=VALUE) +END PROCEDURE obj_Add28 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add29 +INTEGER(I4B) :: s1(3), s2(3) +INTEGER(I4B) :: N + +s1 = GetNodeLoc(obj=dofobj1, idof=idof1) +s2 = GetNodeLoc(obj=dofobj2, idof=idof2) + +N = (s1(2) - s1(1) + s1(3)) / s1(3) + +CALL F77_AXPY(N=N, A=scale, X=obj2%val(s2(1):), INCX=s2(3), & + Y=obj1%val(s1(1):), INCY=s1(3)) +END PROCEDURE obj_Add29 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add30 +INTEGER(I4B) :: ii, jj +DO ii = istart, iend, stride + jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) + obj%val(jj) = obj%val(jj) + scale * VALUE +END DO +END PROCEDURE obj_Add30 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add31 +INTEGER(I4B) :: ii, jj +DO ii = istart, iend, stride + jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) + obj%val(jj) = obj%val(jj) + scale * VALUE((ii - istart + stride) / stride) +END DO +END PROCEDURE obj_Add31 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add32 +INTEGER(I4B) :: tsize +tsize = (iend - istart + stride) / stride +CALL F77_AXPY(N=tsize, A=scale, X=VALUE(istart_value:), INCX=stride_value, & + Y=obj%val(istart:), INCY=stride) +! !$OMP PARALLEL DO PRIVATE(ii) +! DO ii = 1, tsize +! obj%val(istart+(stride-1)*ii) = value(istart_value+(stride_value-1)*ii) +! END DO +! !$OMP END PARALLEL DO +END PROCEDURE obj_Add32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 new file mode 100644 index 000000000..73f42c297 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_AppendMethods@Methods.F90 @@ -0,0 +1,55 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This submodule contains set methods of [[RealVector_]] + +SUBMODULE(RealVector_AppendMethods) Methods +USE AppendUtility, ONLY: Util_Append => Append +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Append1 +CALL Util_Append(obj%val, VALUE) +END PROCEDURE obj_Append1 + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Append2 +CALL Util_Append(obj%val, VALUE) +END PROCEDURE obj_Append2 + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Append3 +CALL Util_Append(obj%val, Anotherobj%val) +END PROCEDURE obj_Append3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 new file mode 100644 index 000000000..c7830bacb --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_AssignMethods@Methods.F90 @@ -0,0 +1,160 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealVector_AssignMethods) Methods +USE RealVector_ShallowCopyMethods, ONLY: ShallowCopy +USE F95_BLAS, ONLY: COPY +USE RealVector_ConstructorMethods, ONLY: SetTotalDimension, & + Size + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign1 +CALL ShallowCopy(Y=lhs, X=rhs) +CALL SetTotalDimension(lhs, 1_I4B) +CALL COPY(Y=lhs%val, X=rhs%val) +END PROCEDURE obj_assign1 + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign2 +INTEGER(I4B) :: m, ii, aa +CALL ShallowCopy(Y=lhs, X=rhs) +CALL SetTotalDimension(lhs, 1_I4B) +m = 0 +DO ii = 1, SIZE(rhs) + aa = m + 1 + m = m + SIZE(rhs(ii)) + CALL COPY(Y=lhs%val(aa:m), X=rhs(ii)%val) +END DO +END PROCEDURE obj_assign2 + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign3a +CALL ShallowCopy(Y=lhs, X=rhs) +CALL SetTotalDimension(lhs, 1_I4B) +lhs%val = rhs +END PROCEDURE obj_assign3a + +MODULE PROCEDURE obj_assign3b +CALL ShallowCopy(Y=lhs, X=rhs) +CALL SetTotalDimension(lhs, 1_I4B) +lhs%val = rhs +END PROCEDURE obj_assign3b + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign4a +#ifdef USE_Real64 +lhs = rhs%val +#else +CALL ShallowCopy(Y=lhs, X=rhs) +CALL COPY(Y=lhs, X=rhs%val) +#endif +END PROCEDURE obj_assign4a +MODULE PROCEDURE obj_assign4b +CALL ShallowCopy(Y=lhs, X=rhs) +#ifdef USE_Real64 +CALL COPY(Y=lhs, X=rhs%val) +#else +lhs = rhs%val +#endif +END PROCEDURE obj_assign4b + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign5a +INTEGER(I4B) :: m, ii, aa +CALL ShallowCopy(Y=lhs, X=rhs) +m = 0 +DO ii = 1, SIZE(rhs) + aa = m + 1 + m = m + SIZE(rhs(ii)) +#ifndef USE_Real64 + CALL COPY(Y=lhs(aa:m), X=rhs(ii)%val) +#else + lhs(aa:m) = rhs(ii)%val(:) +#endif +END DO +END PROCEDURE obj_assign5a + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign5b +INTEGER(I4B) :: m, ii, aa + !! +CALL ShallowCopy(Y=lhs, X=rhs) +m = 0 +DO ii = 1, SIZE(rhs) + aa = m + 1 + m = m + SIZE(rhs(ii)) +#ifdef USE_Real64 + CALL COPY(Y=lhs(aa:m), X=rhs(ii)%val) +#else + lhs(aa:m) = rhs(ii)%val(:) +#endif +END DO +END PROCEDURE obj_assign5b + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign6 +lhs = REAL(rhs, DFP) +END PROCEDURE obj_assign6 + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign7 +REAL(DFP), ALLOCATABLE :: dummy(:) +dummy = rhs +lhs = INT(dummy, I4B) +IF (ALLOCATED(dummy)) DEALLOCATE (dummy) +END PROCEDURE obj_assign7 + +!---------------------------------------------------------------------------- +! Assign +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_assign8 +REAL(DFP), ALLOCATABLE :: dummy(:) +dummy = rhs +lhs = INT(dummy, I4B) +IF (ALLOCATED(dummy)) DEALLOCATE (dummy) +END PROCEDURE obj_assign8 + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 b/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.F90 new file mode 100644 index 000000000..eb9ad5131 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_Blas1Methods@Methods.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 +! + +SUBMODULE(RealVector_Blas1Methods) Methods + +USE F95_BLAS, ONLY: BLAS_AXPY => AXPY, & + BLAS_COPY => COPY, & + BLAS_DOT => DOT, & + BLAS_NRM2 => NRM2, & + BLAS_SCAL => SCAL, & + BLAS_SWAP => SWAP, & + BLAS_ASUM => ASUM + +USE RealVector_ShallowCopyMethods, ONLY: ShallowCopy +USE RealVector_ConstructorMethods, ONLY: SetTotalDimension, Size +USE InputUtility, ONLY: Input + +USE ReallocateUtility, ONLY: Reallocate + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ASUM +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ASUMscalar +ans = BLAS_ASUM(obj%Val) +END PROCEDURE ASUMscalar + +!---------------------------------------------------------------------------- +! ASUM +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ASUMvector +INTEGER(I4B) :: i +DO i = 1, SIZE(obj) + ans = ans + BLAS_ASUM(obj(i)%Val) +END DO +END PROCEDURE ASUMvector + +!---------------------------------------------------------------------------- +! AXPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarAXPYscalar +CALL BLAS_AXPY(X=X%Val, Y=Y%Val, A=A) +END PROCEDURE scalarAXPYscalar + +!---------------------------------------------------------------------------- +! AXPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarAXPYintrinsic +CALL BLAS_AXPY(X=X, Y=Y%Val, A=A) +END PROCEDURE scalarAXPYintrinsic + +!---------------------------------------------------------------------------- +! AXPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vectorAXPYvector +INTEGER(I4B) :: i +DO i = 1, SIZE(X) + CALL BLAS_AXPY(Y=Y(i)%Val, A=A(i), X=X(i)%Val) +END DO +END PROCEDURE vectorAXPYvector + +!---------------------------------------------------------------------------- +! COPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarCOPYscalar +CALL SHALLOWCOPY(Y=Y%Val, X=X%Val) +CALL SetTotalDimension(Y, 1_I4B) +CALL BLAS_COPY(Y=Y%Val, X=X%Val) +END PROCEDURE scalarCOPYscalar + +!---------------------------------------------------------------------------- +! COPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarCOPYintrinsic_1a +CALL SHALLOWCOPY(Y=Y%Val, X=X) +CALL SetTotalDimension(Y, 1_I4B) +Y%Val = X +END PROCEDURE scalarCOPYintrinsic_1a + +!---------------------------------------------------------------------------- +! COPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarCOPYintrinsic_1b +CALL SHALLOWCOPY(Y=Y%Val, X=X) +CALL SetTotalDimension(Y, 1_I4B) +CALL BLAS_COPY(Y=Y%Val, X=X) +! Y%Val = X +END PROCEDURE scalarCOPYintrinsic_1b + +!---------------------------------------------------------------------------- +! COPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intrinsicCOPYscalar_1a +CALL SHALLOWCOPY(Y=Y, X=X%Val) +Y = X%Val +! CALL COPY(Y=Y, X=X%Val) +END PROCEDURE intrinsicCOPYscalar_1a + +!---------------------------------------------------------------------------- +! COPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE intrinsicCOPYscalar_1b +CALL SHALLOWCOPY(Y=Y, X=X%Val) +! Y = X%Val +CALL BLAS_COPY(Y=Y, X=X%Val) +END PROCEDURE intrinsicCOPYscalar_1b + +!---------------------------------------------------------------------------- +! COPY +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vectorCOPYvector +INTEGER(I4B) :: i +CALL SHALLOWCOPY(Y=Y, X=X) +DO i = 1, SIZE(X) + CALL BLAS_COPY(Y=Y(i)%Val, X=X(i)%Val) + CALL SetTotalDimension(Y(i), 1_I4B) +END DO +END PROCEDURE vectorCOPYvector + +!---------------------------------------------------------------------------- +! COPY +!---------------------------------------------------------------------------- + +!Y=X(:)%Val +MODULE PROCEDURE scalarCOPYvector +INTEGER(I4B) :: i, r1, r2 +CALL SHALLOWCOPY(Y=Y, X=X) +CALL SetTotalDimension(Y, 1_I4B) +r1 = 0; r2 = 0 +DO i = 1, SIZE(X) + r1 = r2 + 1 + r2 = r2 + SIZE(X(i)%Val) + Y%Val(r1:r2) = X(i)%Val +END DO +END PROCEDURE scalarCOPYvector + +!---------------------------------------------------------------------------- +! Compact +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Compact_real_1 +INTEGER(I4B) :: m +REAL(DFP), ALLOCATABLE :: Temp_Val(:) +m = SIZE(Val) +IF (m .GT. row) THEN + CALL Reallocate(Temp_Val, m) + CALL BLAS_COPY(Y=Temp_Val, X=Val) + CALL Reallocate(Val, row) + CALL BLAS_COPY(Y=Val, X=Temp_Val(1:row)) + DEALLOCATE (Temp_Val) +END IF +END PROCEDURE Compact_real_1 + +!---------------------------------------------------------------------------- +! Compact +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Compact_Int_1 +INTEGER(I4B) :: m +INTEGER(I4B), ALLOCATABLE :: Temp_Val(:) +m = SIZE(Val) +IF (m .GT. row) THEN + Temp_Val = Val + CALL Reallocate(Val, row) + Val = Temp_Val(1:row) + DEALLOCATE (Temp_Val) +END IF +END PROCEDURE Compact_Int_1 + +!---------------------------------------------------------------------------- +! DOT +!---------------------------------------------------------------------------- + +PURE FUNCTION inner_dot(obj1, obj2) RESULT(ans) + REAL(DFP), INTENT(IN) :: obj1(:) + REAL(DFP), INTENT(IN) :: obj2(:) + REAL(DFP) :: ans + ans = BLAS_DOT(obj1, obj2) +END FUNCTION inner_dot + +!---------------------------------------------------------------------------- +! DOT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarDOTscalar +ans = inner_dot(obj1%Val, obj2%Val) +END PROCEDURE scalarDOTscalar + +!---------------------------------------------------------------------------- +! DOT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarDOTintrinsic +ans = inner_dot(obj%val, val) +END PROCEDURE scalarDOTintrinsic + +!---------------------------------------------------------------------------- +! DOT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vectorDOTvector +INTEGER(I4B) :: i +ans = 0.0 +DO i = 1, SIZE(obj1) + ans = ans + DOT_PRODUCT(obj1(i), obj2(i)) +END DO +END PROCEDURE vectorDOTvector + +!---------------------------------------------------------------------------- +! DOT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vectorDOTscalar +INTEGER(I4B) :: i +ans = 0.0 +DO i = 1, SIZE(obj1) + ans = ans + DOT_PRODUCT(obj1(i)%Val, obj2%Val) +END DO +END PROCEDURE vectorDOTscalar + +!---------------------------------------------------------------------------- +! DOT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarDOTvector +INTEGER(I4B) :: i +ans = 0.0 +DO i = 1, SIZE(obj2) + ans = ans + DOT_PRODUCT(obj1%Val, obj2(i)%Val) +END DO +END PROCEDURE scalarDOTvector + +!---------------------------------------------------------------------------- +! NRM2 +!---------------------------------------------------------------------------- + +PURE FUNCTION inner_nrm2(X) RESULT(ans) + REAL(DFP), INTENT(IN) :: X(:) + REAL(DFP) :: ans + ans = BLAS_NRM2(X) ! blas +END FUNCTION inner_nrm2 + +!---------------------------------------------------------------------------- +! NORM2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE NRM2scalar +ans = inner_nrm2(obj%Val) +END PROCEDURE NRM2scalar + +!---------------------------------------------------------------------------- +! NORM2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE NRM2vector +ans = SQRT(DOT_PRODUCT(obj, obj)) +END PROCEDURE NRM2vector + +!---------------------------------------------------------------------------- +! NORM2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Norm1 +ans = ASUM(obj) +END PROCEDURE obj_Norm1 + +!---------------------------------------------------------------------------- +! NORM2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Normi +ans = MAXVAL(ABS(obj%val)) +END PROCEDURE obj_Normi + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarSWAPscalar +CALL BLAS_SWAP(X=X%Val, Y=Y%Val) +END PROCEDURE scalarSWAPscalar + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vectorSWAPvector +INTEGER(I4B) :: i +DO i = 1, SIZE(X) + CALL BLAS_SWAP(X=X(i)%Val, Y=Y(i)%Val) +END DO +END PROCEDURE vectorSWAPvector + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalarSWAPintrinsic +CALL BLAS_SWAP(X=X%Val, Y=Y) +END PROCEDURE scalarSWAPintrinsic + +!---------------------------------------------------------------------------- +! SCAL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SCALscalar +CALL BLAS_SCAL(A=A, X=X%Val) +END PROCEDURE SCALscalar + +!---------------------------------------------------------------------------- +! SCAL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SCALvector +INTEGER(I4B) :: i +DO i = 1, SIZE(X) + CALL BLAS_SCAL(A=A, X=X(i)%Val) +END DO +END PROCEDURE SCALvector + +!---------------------------------------------------------------------------- +! PMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_PMUL1 +INTEGER(I4B) :: ii, tsize + +tsize = SIZE(obj) +ASSOCIATE (z => obj%val, x => obj1%val, y => obj2%val) + DO CONCURRENT(ii=1:tsize) + z(ii) = x(ii) * y(ii) + END DO +END ASSOCIATE + +END PROCEDURE obj_PMUL1 + +!---------------------------------------------------------------------------- +! PDIV +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_PDIV1 +INTEGER(I4B) :: ii, tsize +LOGICAL(LGT) :: check0 + +check0 = Input(default=.FALSE., option=check_divide_by_zero) +tsize = SIZE(obj) + +ASSOCIATE (z => obj%val, x => obj1%val, y => obj2%val) + + IF (check0) THEN + + DO CONCURRENT(ii=1:tsize, y(ii) .NE. 0.0_DFP) + z(ii) = x(ii) / y(ii) + END DO + + ELSE + + DO CONCURRENT(ii=1:tsize) + z(ii) = x(ii) / y(ii) + END DO + + END IF + +END ASSOCIATE + +END PROCEDURE obj_PDIV1 + +!---------------------------------------------------------------------------- +! Reciprocal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Reciprocal1 +INTEGER(I4B) :: ii, tsize +LOGICAL(LGT) :: check0 + +check0 = Input(default=.FALSE., option=check_divide_by_zero) +tsize = SIZE(obj1) + +ASSOCIATE (x => obj1%val, y => obj2%val) + + IF (check0) THEN + + DO CONCURRENT(ii=1:tsize, y(ii) .NE. 0.0_DFP) + x(ii) = 1.0_DFP / y(ii) + END DO + + ELSE + + DO CONCURRENT(ii=1:tsize) + x(ii) = 1.0_DFP / y(ii) + END DO + + END IF + +END ASSOCIATE + +END PROCEDURE obj_Reciprocal1 + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.F90 new file mode 100644 index 000000000..f6b833baa --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_ComparisonMethods@Methods.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 +! + +SUBMODULE(RealVector_ComparisonMethods) Methods +USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! isEqual +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isEqual +IF (.NOT. ALLOCATED(obj%val)) THEN + ans = .FALSE. + RETURN +END IF + +IF (.NOT. ALLOCATED(obj2%val)) THEN + ans = .FALSE. + RETURN +END IF + +IF (SIZE(obj%val) .NE. SIZE(obj2%val)) THEN + ans = .FALSE. + RETURN +END IF + +IF (ALL(obj%val.APPROXEQ.obj2%val)) THEN + ans = .TRUE. +ELSE + ans = .FALSE. +END IF +END PROCEDURE obj_isEqual + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 new file mode 100644 index 000000000..748e25b04 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_ConstructorMethods@Methods.F90 @@ -0,0 +1,265 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This module contains constructor methods of [[RealVector_]] + +SUBMODULE(RealVector_ConstructorMethods) Methods +USE SafeSizeUtility, ONLY: SafeSize + +USE F95_BLAS, ONLY: COPY + +USE DOF_Method, ONLY: OPERATOR(.tnodes.), & + OPERATOR(.tDOF.) + +USE ReallocateUtility, ONLY: Util_Reallocate => Reallocate + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! isAllocated +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isAllocated +ans = ALLOCATED(obj%val) +END PROCEDURE obj_isAllocated + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Shape +ans(1) = SafeSize(obj%val) +END PROCEDURE obj_Shape + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size +ans = SafeSize(obj%val) +END PROCEDURE obj_Size + +!---------------------------------------------------------------------------- +! getTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RealVec_getTotalDimension +ans = obj%tDimension +END PROCEDURE RealVec_getTotalDimension + +!---------------------------------------------------------------------------- +! setTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RealVec_setTotalDimension +obj%tDimension = tDimension +END PROCEDURE RealVec_setTotalDimension + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Allocate +CALL Util_Reallocate(obj%val, Dims) +CALL SetTotalDimension(obj, 1_I4B) +END PROCEDURE obj_Allocate + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Reallocate +LOGICAL(LGT) :: isok + +isok = ALLOCATED(obj) + +IF (.NOT. isok) THEN + ALLOCATE (obj(row)) + RETURN +END IF + +isok = SIZE(obj) .NE. row +IF (isok) THEN + DEALLOCATE (obj) + ALLOCATE (obj(row)) +END IF + +END PROCEDURE obj_Reallocate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Deallocate +IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) +END PROCEDURE obj_Deallocate + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate1 +CALL ALLOCATE (obj, tSize) +END PROCEDURE obj_Initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate2 +INTEGER(I4B) :: n, i +n = SIZE(tSize) + +IF (ALLOCATED(obj)) THEN + IF (SIZE(obj) .NE. n) THEN + DEALLOCATE (obj) + ALLOCATE (obj(n)) + END IF +ELSE + ALLOCATE (obj(n)) +END IF + +DO i = 1, n + CALL ALLOCATE (obj(i), tSize(i)) +END DO +END PROCEDURE obj_Initiate2 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate3 +IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) +ALLOCATE (obj%val(a:b)) +obj%val = 0.0_DFP +CALL SetTotalDimension(obj, 1_I4B) +END PROCEDURE obj_Initiate3 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate4 +CALL Initiate(obj=obj, tSize=(.tNodes.dofobj)) +END PROCEDURE obj_Initiate4 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate5 +INTEGER(I4B) :: ii +INTEGER(I4B), ALLOCATABLE :: tsize(:) +ASSOCIATE (Map => dofobj%Map) + ALLOCATE (tsize(.tDOF.dofobj)) + DO ii = 1, SIZE(Map, 1) - 1 + tsize(Map(ii, 5):Map(ii + 1, 5) - 1) = Map(ii, 6) + END DO + CALL Initiate(obj=obj, tsize=tsize) + DEALLOCATE (tsize) +END ASSOCIATE +END PROCEDURE obj_Initiate5 + +!---------------------------------------------------------------------------- +! Random_Number +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Random_Number1 +CALL Initiate(obj=obj, tSize=tSize) +CALL RANDOM_NUMBER(obj%val) +END PROCEDURE obj_Random_Number1 + +!---------------------------------------------------------------------------- +! Random_Number +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Random_Number2 +INTEGER(I4B) :: ii, n +n = SIZE(tSize) +IF (ALLOCATED(obj)) THEN + IF (SIZE(obj) .NE. n) THEN + DEALLOCATE (obj) + ALLOCATE (obj(n)) + END IF +ELSE + ALLOCATE (obj(n)) +END IF +DO ii = 1, n + CALL Initiate(obj=obj(ii), tSize=tSize(ii)) + CALL RANDOM_NUMBER(obj(ii)%val) +END DO +END PROCEDURE obj_Random_Number2 + +!---------------------------------------------------------------------------- +! Vector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor1 +CALL ALLOCATE (obj, tSize) +END PROCEDURE obj_Constructor1 + +!---------------------------------------------------------------------------- +! Vector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor2 +CALL ALLOCATE (obj, SIZE(val)) +CALL COPY(Y=obj%val, X=REAL(val, DFP)) +END PROCEDURE obj_Constructor2 + +!---------------------------------------------------------------------------- +! Vector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor3 +CALL ALLOCATE (obj, SIZE(val)) +CALL COPY(Y=obj%val, X=val) +END PROCEDURE obj_Constructor3 + +!---------------------------------------------------------------------------- +! Vector_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor_1 +ALLOCATE (obj) +CALL ALLOCATE (obj, tSize) +END PROCEDURE obj_Constructor_1 + +!---------------------------------------------------------------------------- +! Vector_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor_2 +ALLOCATE (obj) +CALL ALLOCATE (obj, SIZE(val)) +CALL COPY(Y=obj%val, X=REAL(val, DFP)) +END PROCEDURE obj_Constructor_2 + +!---------------------------------------------------------------------------- +! Vector_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Constructor_3 +ALLOCATE (obj) +CALL ALLOCATE (obj, SIZE(val)) +CALL COPY(Y=obj%val, X=REAL(val, DFP)) +END PROCEDURE obj_Constructor_3 + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 new file mode 100644 index 000000000..071dd5fe3 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 @@ -0,0 +1,598 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This submodule contains Get methods of [[RealVector_]] + +SUBMODULE(RealVector_GetMethods) Methods +USE DOF_Method, ONLY: GetNodeLoc, DOF_GetIndex => GetIndex + +USE InputUtility, ONLY: INPUT + +USE ReallocateUtility, ONLY: Reallocate + +USE F95_BLAS, ONLY: COPY + +USE RealVector_AssignMethods, ONLY: ASSIGNMENT(=) + +USE RealVector_ConstructorMethods, ONLY: RealVector_Size => Size + +USE SafeSizeUtility, ONLY: SafeSize + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! GetPointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetPointer1 +val => obj%val +END PROCEDURE obj_GetPointer1 + +!---------------------------------------------------------------------------- +! GetPointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetPointer2 +INTEGER(I4B) :: s(3) +s = GetNodeLoc(obj=dofobj, idof=idof) +val => obj%val(s(1):s(2):s(3)) +END PROCEDURE obj_GetPointer2 + +!---------------------------------------------------------------------------- +! IndexOf +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex1 +Ans = MINLOC(ABS(obj%val - VALUE), 1) +END PROCEDURE obj_GetIndex1 + +!---------------------------------------------------------------------------- +! IndexOf +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetIndex2 +! Ans = MINLOC( ABS( obj%val - Value ), 1 ) +INTEGER(I4B) :: i, j, m +LOGICAL(LGT), ALLOCATABLE :: Search(:) +REAL(DFP) :: tol0 + +tol0 = INPUT(default=REAL(1.0E-10, DFP), option=tol) +m = SIZE(VALUE) +ALLOCATE (Search(m), Ans(m)) +Search = .TRUE. +Ans = 0 +DO i = 1, SIZE(obj%val) + DO j = 1, m + IF (Search(j)) THEN + IF (ABS(VALUE(j) - obj%val(i)) .LE. tol0) THEN + Search(j) = .FALSE. + Ans(j) = i + END IF + END IF + END DO +END DO +END PROCEDURE obj_GetIndex2 + +!---------------------------------------------------------------------------- +! isPresent +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isPresent1 +INTEGER(I4B) :: i +REAL(DFP) :: tol0 +Ans = .FALSE. +tol0 = INPUT(default=REAL(1.0E-10, DFP), option=tol) +DO i = 1, SIZE(obj%val) + IF (ABS(obj%val(i) - VALUE) .LE. tol0) THEN + Ans = .TRUE. + EXIT + END IF +END DO +END PROCEDURE obj_isPresent1 + +!---------------------------------------------------------------------------- +! isPresent +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_isPresent2 +INTEGER(I4B) :: i, m, j +REAL(DFP) :: tol0 +LOGICAL(LGT), ALLOCATABLE :: Search(:) + +tol0 = INPUT(default=REAL(1.0E-10, DFP), option=tol) +m = SIZE(VALUE) +ALLOCATE (Ans(m), Search(m)) +Search = .TRUE. +Ans = .FALSE. +DO i = 1, SIZE(obj%val) + DO j = 1, m + IF (Search(j)) THEN + IF (ABS(VALUE(j) - obj%val(i)) .LE. tol0) THEN + Search(j) = .FALSE. + Ans(j) = .TRUE. + END IF + END IF + END DO +END DO +END PROCEDURE obj_isPresent2 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get1 +INTEGER(I4B) :: tsize, ii +tsize = SafeSize(obj%val) +ALLOCATE (ans(tsize)) + +DO CONCURRENT(ii=1:tsize) + ans(ii) = INT(obj%val(ii), kind=I4B) +END DO +END PROCEDURE obj_Get1 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get2 +INTEGER(I4B) :: tsize, ii + +tsize = SIZE(nodenum) +ALLOCATE (ans(tsize)) + +DO CONCURRENT(ii=1:tsize) + ans(ii) = INT(obj%val(nodenum(ii)), kind=I4B) +END DO +END PROCEDURE obj_Get2 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get3 +INTEGER(I4B) :: tsize, ii, jj + +tsize = 1_I4B + (iend - istart) / stride +ALLOCATE (ans(tsize)) + +jj = 0 + +DO ii = istart, iend, stride + jj = jj + 1 + ans(jj) = INT(obj%val(ii), kind=I4B) +END DO +END PROCEDURE obj_Get3 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get4a +INTEGER(I4B) :: tsize, ii +tsize = SafeSize(obj%val) +ALLOCATE (ans(tsize)) + +DO CONCURRENT(ii=1:tsize) + ans(ii) = REAL(obj%val(ii), kind=REAL32) +END DO + +END PROCEDURE obj_Get4a + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get4b +INTEGER(I4B) :: tsize, ii +tsize = SafeSize(obj%val) +ALLOCATE (ans(tsize)) + +DO CONCURRENT(ii=1:tsize) + ans(ii) = REAL(obj%val(ii), kind=REAL64) +END DO +END PROCEDURE obj_Get4b + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get5a +INTEGER(I4B) :: tsize, ii + +tsize = SIZE(nodenum) +ALLOCATE (ans(tsize)) + +DO ii = 1, tsize + ans(ii) = REAL(obj%val(nodenum(ii)), kind=REAL32) +END DO + +END PROCEDURE obj_Get5a + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get5b +INTEGER(I4B) :: tsize, ii + +tsize = SIZE(nodenum) +ALLOCATE (ans(tsize)) + +DO ii = 1, tsize + ans(ii) = REAL(obj%val(nodenum(ii)), kind=REAL64) +END DO +END PROCEDURE obj_Get5b + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get6 +INTEGER(I4B) :: tsize, ii, jj + +tsize = 1_I4B + (iend - istart) / stride +ALLOCATE (ans(tsize)) + +jj = 0 + +DO ii = istart, iend, stride + jj = jj + 1 + ans(jj) = obj%val(ii) +END DO + +END PROCEDURE obj_Get6 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get7 +INTEGER(I4B) :: N, i, tNodes, r1, r2 + +N = SIZE(obj) +tNodes = 0 +DO i = 1, N + tNodes = tNodes + RealVector_SIZE(obj(i)) +END DO + +ALLOCATE (val(tNodes)) +tNodes = 0 +r1 = 0 +r2 = 0 + +DO i = 1, N + r1 = r2 + 1 + r2 = r2 + RealVector_SIZE(obj(i)) + val(r1:r2) = obj(i)%val +END DO + +END PROCEDURE obj_Get7 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get8 +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = SIZE(nodenum) +ALLOCATE (val(N * M)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) +END DO +END PROCEDURE obj_Get8 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get9 +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = 1 + (iend - istart) / stride +ALLOCATE (val(M * N)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) +END DO +END PROCEDURE obj_Get9 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get10a +INTEGER(I4B) :: N, i, tNodes, r1, r2 +N = SIZE(obj) +tNodes = 0 +DO i = 1, N + tNodes = tNodes + SIZE(obj(i)%val) +END DO +ALLOCATE (val(tNodes)) +tNodes = 0; r1 = 0; r2 = 0 +DO i = 1, N + r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val) + val(r1:r2) = obj(i)%val +END DO +END PROCEDURE obj_Get10a + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get10b +INTEGER(I4B) :: N, i, tNodes, r1, r2 +N = SIZE(obj) +tNodes = 0 +DO i = 1, N + tNodes = tNodes + SIZE(obj(i)%val) +END DO +ALLOCATE (val(tNodes)) +tNodes = 0; r1 = 0; r2 = 0 +DO i = 1, N + r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val) + val(r1:r2) = obj(i)%val +END DO +END PROCEDURE obj_Get10b + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get11a +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = SIZE(nodenum) +ALLOCATE (val(M * N)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) +END DO +END PROCEDURE obj_Get11a + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get11b +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = SIZE(nodenum) +ALLOCATE (val(M * N)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) +END DO +END PROCEDURE obj_Get11b + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get12a +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = 1 + (iend - istart) / stride +ALLOCATE (val(M * N)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) +END DO +END PROCEDURE obj_Get12a + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get12b +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = 1 + (iend - istart) / stride +ALLOCATE (val(M * N)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) +END DO +END PROCEDURE obj_Get12b + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get13 +val = Get(obj=obj, dataType=1.0_DFP) +END PROCEDURE obj_Get13 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get14 +val = Get(obj=obj, nodenum=nodenum, dataType=1.0_DFP) +END PROCEDURE obj_Get14 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get15 +val = Get(obj=obj, istart=istart, iend=iend, stride=stride, & + & dataType=1.0_DFP) +END PROCEDURE obj_Get15 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get16 +val = Get(obj=obj, nodenum=nodenum, dataType=1.0_DFP) +END PROCEDURE obj_Get16 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get17 +val = Get(obj=obj, istart=istart, iend=iend, stride=stride, & + & dataType=1.0_DFP) +END PROCEDURE obj_Get17 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get18a +val = obj%val(nodenum) +END PROCEDURE obj_Get18a + +MODULE PROCEDURE obj_Get18b +val = obj%val(nodenum) +END PROCEDURE obj_Get18b + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get19 +IF (ALLOCATED(obj%val)) THEN + ans = obj +ELSE + ALLOCATE (ans(0)) +END IF +END PROCEDURE obj_Get19 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get20 +IF (ALLOCATED(obj%val)) THEN + CALL Reallocate(ans, SIZE(nodenum)) + CALL COPY(Y=ans, X=obj%val(nodenum)) +ELSE + ALLOCATE (ans(0)) +END IF +END PROCEDURE obj_Get20 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get21 +IF (ALLOCATED(obj%val)) THEN + ans = obj%val(istart:iend:stride) +ELSE + ALLOCATE (ans(0)) +END IF +END PROCEDURE obj_Get21 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get22 +INTEGER(I4B) :: N, i, tNodes, r1, r2 +N = SIZE(obj) +tNodes = 0 +DO i = 1, N + tNodes = tNodes + SIZE(obj(i)%val) +END DO +ALLOCATE (val(tNodes)) +tNodes = 0; r1 = 0; r2 = 0 +DO i = 1, N + r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val) + val(r1:r2) = obj(i)%val +END DO +END PROCEDURE obj_Get22 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get23 +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = SIZE(nodenum) +ALLOCATE (val(M * N)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum) +END DO +END PROCEDURE obj_Get23 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get24 +INTEGER(I4B) :: N, i, M +N = SIZE(obj) +M = 1 + (iend - istart) / stride +ALLOCATE (val(M * N)) +DO i = 1, N + val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride) +END DO +END PROCEDURE obj_Get24 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get25 +ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, & + ivar=ivar, idof=idof)) +END PROCEDURE obj_Get25 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get26 +ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, & + ivar=ivar, idof=idof)) +END PROCEDURE obj_Get26 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get27 +ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar)) +END PROCEDURE obj_Get27 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get28 +ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, & + spacecompo=spacecompo, timecompo=timecompo)) +END PROCEDURE obj_Get28 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get29 +INTEGER(I4B) :: s(3) +s = GetNodeLoc(obj=dofobj, idof=idof) +ans = Get(obj=obj, istart=s(1), iend=s(2), stride=s(3), dataType=1.0_DFP) +END PROCEDURE obj_Get29 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 new file mode 100644 index 000000000..9ca4e0181 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 @@ -0,0 +1,526 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealVector_GetValueMethods) Methods +USE GlobalData, ONLY: DOF_FMT, NODES_FMT + +USE DOF_Method, ONLY: GetIDOF, & + GetNodeLoc, & + GetIndex, & + OPERATOR(.tdof.), & + OPERATOR(.tnodes.), & + DOF_GetValue => GetValue, & + DOF_GetValue_ => GetValue_ + +USE ReallocateUtility, ONLY: Reallocate + +USE F95_BLAS, ONLY: COPY + +USE F77_BLAS, ONLY: F77_Copy + +USE RealVector_SetMethods, ONLY: Set + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue1 +CALL Set(obj=VALUE, VALUE=obj%val, istart=istart, iend=iend, stride=stride) +END PROCEDURE obj_GetValue1 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue2 +INTEGER(I4B) :: s(3) +s = GetNodeLoc(obj=dofobj, idof=idof) +CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3)) +END PROCEDURE obj_GetValue2 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue3 +INTEGER(I4B) :: s(3) +s = GetNodeLoc(obj=dofobj, & + idof=GetIDOF(obj=dofobj, ivar=ivar, idof=idof)) +CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3)) +END PROCEDURE obj_GetValue3 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue4 +INTEGER(I4B) :: s(3) + +s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, & + ivar=ivar, & + spaceCompo=spaceCompo, & + timeCompo=timeCompo)) + +CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3)) +END PROCEDURE obj_GetValue4 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue5 +CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=idofvalue, & + obj2=obj, dofobj2=dofobj, idof2=idofobj) +END PROCEDURE obj_GetValue5 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue6 +INTEGER(I4B) :: ii + +DO ii = 1, SIZE(idofobj) + CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=idofvalue(ii), & + obj2=obj, dofobj2=dofobj, idof2=idofobj(ii)) +END DO + +END PROCEDURE obj_GetValue6 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue7 +INTEGER(I4B) :: global_idofobj, global_idofvalue +global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, idof=idofobj) +global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, idof=idofvalue) +CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & + obj2=obj, dofobj2=dofobj, idof2=global_idofobj) +END PROCEDURE obj_GetValue7 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue8 +INTEGER(I4B) :: global_idofobj, global_idofvalue, ii + +DO ii = 1, SIZE(idofobj) + global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, idof=idofobj(ii)) + global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, idof=idofvalue(ii)) + CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & + obj2=obj, dofobj2=dofobj, idof2=global_idofobj) +END DO + +END PROCEDURE obj_GetValue8 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue9 +INTEGER(I4B) :: global_idofobj, global_idofvalue + +global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, spaceCompo=spaceCompoObj, & + timeCompo=timeCompoObj) + +global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, & + spaceCompo=spaceCompoValue, timeCompo=timeCompoValue) + +CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & + obj2=obj, dofobj2=dofobj, idof2=global_idofobj) + +END PROCEDURE obj_GetValue9 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue10 +INTEGER(I4B) :: global_idofobj, global_idofvalue, ii + +DO ii = 1, SIZE(timeCompoObj) + global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, & + spaceCompo=spaceCompoObj, timeCompo=timeCompoObj(ii)) + + global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, & + spaceCompo=spaceCompoValue, timeCompo=timeCompoValue(ii)) + + CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & + obj2=obj, dofobj2=dofobj, idof2=global_idofobj) +END DO + +END PROCEDURE obj_GetValue10 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue11 +INTEGER(I4B) :: global_idofobj, global_idofvalue, ii + +DO ii = 1, SIZE(spaceCompoObj) + + global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, & + spaceCompo=spaceCompoObj(ii), timeCompo=timeCompoObj) + + global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, & + spaceCompo=spaceCompoValue(ii), timeCompo=timeCompoValue) + + CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, & + obj2=obj, dofobj2=dofobj, idof2=global_idofobj) + +END DO + +END PROCEDURE obj_GetValue11 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue12 +CALL DOF_GetValue(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & + storageFMT=storageFMT, nodenum=nodenum) +END PROCEDURE obj_GetValue12 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_12 +CALL DOF_GetValue_(v=VALUE, tsize=tsize, val=obj%val, obj=dofobj, idof=idof, & + storageFMT=storageFMT, nodenum=nodenum) +END PROCEDURE obj_GetValue_12 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue13 +CALL DOF_GetValue(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & + storageFMT=storageFMT) +END PROCEDURE obj_GetValue13 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_13 +CALL DOF_GetValue_(v=VALUE, tsize=tsize, val=obj%val, obj=dofobj, idof=idof, & + storageFMT=storageFMT) +END PROCEDURE obj_GetValue_13 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue14 +CALL DOF_GetValue(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & + force3D=force3D) +END PROCEDURE obj_GetValue14 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_14 +CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & + force3D=force3D, nrow=nrow, ncol=ncol) +END PROCEDURE obj_GetValue_14 + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue15 +VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, & + idof=idof)) +END PROCEDURE obj_GetValue15 + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue16 +VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, idof=idof)) +END PROCEDURE obj_GetValue16 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_16 +INTEGER(I4B) :: global_idof +global_idof = GetIDOF(obj=dofobj, ivar=ivar, idof=idof) +CALL DOF_GetValue_(obj=dofobj, nodenum=nodenum, idof=global_idof, & + v=VALUE, tsize=tsize, val=obj%val) +END PROCEDURE obj_GetValue_16 + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue17 +VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar)) +END PROCEDURE obj_GetValue17 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_17 +INTEGER(I4B), ALLOCATABLE :: idof(:) +idof = GetIDOF(obj=dofobj, ivar=ivar) +CALL GetValue_(obj=obj, dofobj=dofobj, nodenum=nodenum, idof=idof, & + VALUE=VALUE, tsize=tsize, & + storageFMT=dofobj%storageFMT) +END PROCEDURE obj_GetValue_17 + +!---------------------------------------------------------------------------- +! get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue18 +VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, & + spaceCompo=spaceCompo, timeCompo=timeCompo)) +END PROCEDURE obj_GetValue18 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_18 +INTEGER(I4B) :: idof +idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, & + timeCompo=timeCompo) +CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & + nodenum=nodenum, tsize=tsize) +END PROCEDURE obj_GetValue_18 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue19 +INTEGER(I4B) :: s(3), tsize + +tsize = dofobj.tNodes.idof +CALL Reallocate(VALUE, tsize) +CALL obj_GetValue_19(obj=obj, dofobj=dofobj, VALUE=VALUE, tsize=tsize, & + idof=idof) + +END PROCEDURE obj_GetValue19 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_19 +CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & + tsize=tsize, isidof=.TRUE.) +END PROCEDURE obj_GetValue_19 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue20 +INTEGER(I4B) :: global_idof +global_idof = GetIDOF(obj=dofobj, ivar=ivar, idof=idof) +CALL GetValue(obj=obj, dofobj=dofobj, idof=global_idof, & + VALUE=VALUE) +END PROCEDURE obj_GetValue20 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_20 +INTEGER(I4B) :: global_idof +global_idof = GetIDOF(obj=dofobj, ivar=ivar, idof=idof) +CALL GetValue_(obj=obj, dofobj=dofobj, idof=global_idof, & + VALUE=VALUE, tsize=tsize) +END PROCEDURE obj_GetValue_20 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue21 +INTEGER(I4B) :: global_idof +global_idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, & + timeCompo=timeCompo) +CALL GetValue(obj=obj, dofobj=dofobj, idof=global_idof, & + VALUE=VALUE) +END PROCEDURE obj_GetValue21 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_21 +INTEGER(I4B) :: global_idof +global_idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, & + timeCompo=timeCompo) +CALL GetValue_(obj=obj, dofobj=dofobj, idof=global_idof, & + VALUE=VALUE, tsize=tsize) +END PROCEDURE obj_GetValue_21 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue22 +INTEGER(I4B) :: tsize +tsize = SIZE(idof) * SIZE(nodenum) +CALL Reallocate(VALUE, tsize) +CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, VALUE=VALUE, tsize=tsize, & + nodenum=nodenum) +END PROCEDURE obj_GetValue22 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_22 +CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, & + tsize=tsize, nodenum=nodenum, storageFMT=dofobj%storageFMT) +END PROCEDURE obj_GetValue_22 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue23 +INTEGER(I4B) :: tsize +tsize = dofobj.tNodes.idof +CALL Reallocate(VALUE, tsize) +CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, VALUE=VALUE, tsize=tsize) +END PROCEDURE obj_GetValue23 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_23 +CALL DOF_GetValue_(obj=dofobj, val=obj%val, v=VALUE, idof=idof, tsize=tsize, & + storageFMT=dofobj%StorageFMT) +END PROCEDURE obj_GetValue_23 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_24 +INTEGER(I4B) :: jj + +SELECT CASE (storageFMT) + +CASE (DOF_FMT) + ncol = SIZE(idof) + + DO jj = 1, ncol + CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof(jj:jj), nodenum=nodenum, & + VALUE=VALUE(:, jj), tsize=nrow, storageFMT=dofobj%storageFMT) + END DO + +CASE (NODES_FMT) + ncol = SIZE(nodenum) + + DO jj = 1, ncol + CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, nodenum=nodenum(jj:jj), & + VALUE=VALUE(:, jj), tsize=nrow, storageFMT=dofobj%storageFMT) + END DO + +END SELECT + +END PROCEDURE obj_GetValue_24 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue24 +CALL COPY(Y=VALUE%val, X=obj%val) +END PROCEDURE obj_GetValue24 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_25 +INTEGER(I4B) :: jj + +SELECT CASE (storageFMT) + +CASE (DOF_FMT) + ncol = SIZE(idof) + + DO jj = 1, ncol + CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof(jj), & + VALUE=VALUE(:, jj), tsize=nrow) + END DO + +CASE (NODES_FMT) + CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, VALUE=VALUE, & + nrow=nrow, ncol=ncol) + +END SELECT + +END PROCEDURE obj_GetValue_25 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_26 +INTEGER(I4B) :: ii +tsize = SIZE(nodenum) +DO ii = 1, tsize + VALUE(ii) = obj%val(nodenum(ii)) +END DO +END PROCEDURE obj_GetValue_26 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_27 +tsize = (iend - istart + stride) / stride +CALL F77_Copy(N=tsize, X=obj%val(istart:), INCX=stride, & + Y=VALUE, INCY=1_I4B) +END PROCEDURE obj_GetValue_27 + +!---------------------------------------------------------------------------- +! GetValue_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetValue_28 +tsize = (iend - istart + stride) / stride +CALL F77_Copy(N=tsize, X=obj%val(istart:), INCX=stride, & + Y=VALUE(istart_value:), INCY=stride_value) +END PROCEDURE obj_GetValue_28 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 new file mode 100644 index 000000000..dd6b6b51c --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_IOMethods@Methods.F90 @@ -0,0 +1,65 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This submodule implements IO methods of [[RealVector_]] + +SUBMODULE(RealVector_IOMethods) Methods +USE Display_Method, ONLY: Util_Display => Display, & + tostring + +USE RealVector_ConstructorMethods, ONLY: size + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_display1 +INTEGER(I4B) :: tsize +CALL Util_Display(msg=msg, unitno=unitno) +tsize = SIZE(obj) +CALL Util_Display(msg="size: "//tostring(tsize), unitno=unitno) +CALL Util_Display(val=obj%val, msg='', unitno=unitno, orient='col', & + full=.TRUE.) +END PROCEDURE obj_display1 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_display2 +INTEGER(I4B) :: j, tsize + +tsize = SIZE(obj) +CALL Util_Display(msg=msg, unitno=unitno) +CALL Util_Display(msg="size : "//tostring(tsize), unitno=unitno) + +DO j = 1, tsize + CALL Display(obj(j), msg="("//tostring(j)//"): ", unitno=unitno) +END DO + +END PROCEDURE obj_display2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 new file mode 100644 index 000000000..135b0d65a --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_Norm2ErrorMethods@Methods.F90 @@ -0,0 +1,183 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealVector_Norm2ErrorMethods) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2error_1 +INTEGER(I4B) :: p(3), s(3), ii, jj +s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & + idof=idofobj)) + +p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & + idof=idofobj2)) + +jj = 0; ans = 0.0_DFP + +DO ii = s(1), s(2), s(3) + jj = jj + 1 + ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 +END DO + +ans = SQRT(ans) +END PROCEDURE obj_norm2error_1 + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2error_2 +INTEGER(I4B) :: p(3), s(3), ii, jj, kk +ans = 0.0_DFP +DO kk = 1, SIZE(idofobj) + s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & + idof=idofobj(kk))) + + p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & + idof=idofobj2(kk))) + + jj = 0 + + DO ii = s(1), s(2), s(3) + jj = jj + 1 + ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 + END DO + +END DO + +ans = SQRT(ans) + +END PROCEDURE obj_norm2error_2 + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2error_3 +INTEGER(I4B) :: p(3), s(3), ii, jj + +s = GetNodeLoc(obj=dofobj, idof=idofobj) +p = GetNodeLoc(obj=dofobj2, idof=idofobj2) + +jj = 0; ans = 0.0_DFP + +DO ii = s(1), s(2), s(3) + jj = jj + 1 + ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 +END DO + +ans = SQRT(ans) + +END PROCEDURE obj_norm2error_3 + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2error_4 +INTEGER(I4B) :: p(3), s(3), ii, jj, kk + +ans = 0.0_DFP + +DO kk = 1, SIZE(idofobj) + + s = GetNodeLoc(obj=dofobj, idof=idofobj(kk)) + p = GetNodeLoc(obj=dofobj2, idof=idofobj2(kk)) + + jj = 0 + + DO ii = s(1), s(2), s(3) + jj = jj + 1 + ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 + END DO + +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2error_4 + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2error_5 +INTEGER(I4B) :: p(3), s(3), ii, jj +s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & + spaceCompo=spaceCompoObj, timeCompo=timeCompoObj)) + +p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & + spaceCompo=spaceCompoobj2, timeCompo=timeCompoobj2)) + +jj = 0; ans = 0.0_DFP +DO ii = s(1), s(2), s(3) + jj = jj + 1 + ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2error_5 + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2error_6 +INTEGER(I4B) :: p(3), s(3), ii, jj, kk +ans = 0.0_DFP +DO kk = 1, SIZE(timeCompoObj) + s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & + spaceCompo=spaceCompoObj, timeCompo=timeCompoObj(kk))) + + p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, ivar=ivarobj2, & + spaceCompo=spaceCompoobj2, timeCompo=timeCompoobj2(kk))) + + jj = 0 + DO ii = s(1), s(2), s(3) + jj = jj + 1 + ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 + END DO +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2error_6 + +!---------------------------------------------------------------------------- +! Norm2Error +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2error_7 +INTEGER(I4B) :: p(3), s(3), ii, jj, kk +ans = 0.0_DFP +DO kk = 1, SIZE(spaceCompoObj) + s = GetNodeLoc(obj=dofobj, idof=getIDOF(obj=dofobj, ivar=ivarobj, & + spaceCompo=spaceCompoObj(kk), timeCompo=timeCompoObj)) + p = GetNodeLoc(obj=dofobj2, idof=getIDOF(obj=dofobj2, & + ivar=ivarobj2, spaceCompo=spaceCompoobj2(kk), timeCompo=timeCompoobj2)) + + jj = 0 + DO ii = s(1), s(2), s(3) + jj = jj + 1 + ans = ans + (obj2%val(p(1) + (jj - 1) * p(3)) - obj%val(ii))**2 + END DO +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2error_7 + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 b/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 new file mode 100644 index 000000000..4e6eb55d5 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_Norm2Methods@Methods.F90 @@ -0,0 +1,139 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealVector_Norm2Methods) Methods +USE DOF_Method, ONLY: GetNodeLoc, GetIDOF + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2_1 +INTEGER(I4B) :: s(3), ii + +ii = GetIDOF(obj=dof, ivar=ivar, idof=idof) +s = GetNodeLoc(obj=dof, idof=ii) +ans = 0.0_DFP +DO ii = s(1), s(2), s(3) + ans = ans + obj%val(ii)**2 +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2_1 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2_2 +INTEGER(I4B) :: s(3), ii, kk +ans = 0.0_DFP +DO kk = 1, SIZE(idof) + ii = GetIDOF(obj=dof, ivar=ivar, idof=idof(kk)) + s = GetNodeLoc(obj=dof, idof=ii) + DO ii = s(1), s(2), s(3) + ans = ans + obj%val(ii)**2 + END DO +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2_2 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2_3 +INTEGER(I4B) :: s(3), ii +s = GetNodeLoc(obj=dof, idof=idof) +ans = 0.0_DFP +DO ii = s(1), s(2), s(3) + ans = ans + obj%val(ii)**2 +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2_3 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2_4 +INTEGER(I4B) :: s(3), ii, kk +ans = 0.0_DFP +DO kk = 1, SIZE(idof) + s = GetNodeLoc(obj=dof, idof=idof(kk)) + DO ii = s(1), s(2), s(3) + ans = ans + obj%val(ii)**2 + END DO +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2_4 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2_5 +INTEGER(I4B) :: s(3), ii + +ii = GetIDOF(obj=dof, ivar=ivar, spaceCompo=spaceCompo, timeCompo=timeCompo) +s = GetNodeLoc(obj=dof, idof=ii) +ans = 0.0_DFP +DO ii = s(1), s(2), s(3) + ans = ans + obj%val(ii)**2 +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2_5 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2_6 +INTEGER(I4B) :: s(3), ii, kk +ans = 0.0_DFP +DO kk = 1, SIZE(timeCompo) + ii = GetIDOF(obj=dof, ivar=ivar, spaceCompo=spaceCompo, & + timeCompo=timeCompo(kk)) + s = GetNodeLoc(obj=dof, idof=ii) + DO ii = s(1), s(2), s(3) + ans = ans + obj%val(ii)**2 + END DO +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2_6 + +!---------------------------------------------------------------------------- +! norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_norm2_7 +INTEGER(I4B) :: s(3), ii, kk +ans = 0.0_DFP +DO kk = 1, SIZE(spaceCompo) + ii = GetIDOF(obj=dof, ivar=ivar, spaceCompo=spaceCompo(kk), & + timeCompo=timeCompo) + s = GetNodeLoc(obj=dof, idof=ii) + DO ii = s(1), s(2), s(3) + ans = ans + obj%val(ii)**2 + END DO +END DO +ans = SQRT(ans) +END PROCEDURE obj_norm2_7 + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 new file mode 100644 index 000000000..1e8678589 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 @@ -0,0 +1,362 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(RealVector_SetMethods) Methods +USE DOF_Method, ONLY: DOF_Set => Set, & + OPERATOR(.tdof.), & + GetNodeLoc +USE F77_Blas, ONLY: F77_Copy +USE F95_Blas, ONLY: F95_Copy => Copy +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set1 +REAL(DFP) :: aval(1) +INTEGER(I4B) :: N +aval(1) = VALUE +N = SIZE(obj%val) +CALL F77_Copy(N=N, X=aval, INCX=0_I4B, Y=obj%val, INCY=1_I4B) +END PROCEDURE obj_Set1 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set2 +CALL F95_Copy(X=VALUE, Y=obj%val) +END PROCEDURE obj_Set2 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set3 +obj%val(nodenum) = VALUE +END PROCEDURE obj_Set3 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set4 +obj%val(nodenum) = VALUE +END PROCEDURE obj_Set4 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set5 +IF (SIZE(VALUE) .EQ. 1) THEN + obj%val(nodenum) = VALUE(1) + RETURN +END IF + +obj%val(nodenum) = VALUE +END PROCEDURE obj_Set5 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set6 +REAL(DFP) :: aval(1) +INTEGER(I4B) :: N +aval(1) = VALUE +N = INT((iend - istart + stride) / stride) +CALL F77_Copy(N=N, X=aval, INCX=0_I4B, Y=obj%val(istart:), & + INCY=stride) +END PROCEDURE obj_Set6 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set7 +INTEGER(I4B) :: N + +N = SIZE(VALUE) +CALL F77_Copy(N=N, X=VALUE, INCX=1_I4B, Y=obj%val(istart:), & + INCY=stride) +END PROCEDURE obj_Set7 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set8 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + conversion=conversion) +END PROCEDURE obj_Set8 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set9 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE) +END PROCEDURE obj_Set9 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set10 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + idof=idof) +END PROCEDURE obj_Set10 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set11 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + idof=idof) +END PROCEDURE obj_Set11 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set12 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + idof=idof, ivar=ivar) +END PROCEDURE obj_Set12 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set13 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + idof=idof, ivar=ivar) +END PROCEDURE obj_Set13 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set14 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set14 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set15 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set15 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set16 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set16 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set17 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set17 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set18 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set18 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set19 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set19 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set20 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE) +END PROCEDURE obj_Set20 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set21 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + idof=idof) +END PROCEDURE obj_Set21 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set22 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + ivar=ivar, idof=idof) +END PROCEDURE obj_Set22 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set23 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set23 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set24 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set24 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set25 +CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, & + ivar=ivar, spacecompo=spacecompo, timecompo=timecompo) +END PROCEDURE obj_Set25 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set26 +! obj%val = VALUE%val +CALL F95_Copy(X=VALUE%val, Y=obj%val) +END PROCEDURE obj_Set26 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set27 +INTEGER(I4B) :: tdof, s(3), idof + +tdof = .tdof.dofobj + +DO idof = 1, tdof + s = GetNodeLoc(obj=dofobj, idof=idof) + CALL obj_Set7(obj=obj, istart=s(1), iend=s(2), stride=s(3), & + VALUE=VALUE(:, idof)) +END DO + +END PROCEDURE obj_Set27 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set28 +INTEGER(I4B) :: s(3) +s = GetNodeLoc(obj=dofobj, idof=idof) +CALL obj_Set7(obj=obj, istart=s(1), iend=s(2), stride=s(3), VALUE=VALUE) +END PROCEDURE obj_Set28 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set29 +INTEGER(I4B) :: s1(3), s2(3) +INTEGER(I4B) :: N + +s1 = GetNodeLoc(obj=dofobj1, idof=idof1) +s2 = GetNodeLoc(obj=dofobj2, idof=idof2) + +N = (s1(2) - s1(1) + s1(3)) / s1(3) + +CALL F77_Copy(N=N, X=obj2%val(s2(1):), INCX=s2(3), Y=obj1%val(s1(1):), & + INCY=s1(3)) +END PROCEDURE obj_Set29 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set30 +INTEGER(I4B) :: ii, jj +!$OMP PARALLEL DO PRIVATE(ii, jj) +DO ii = istart, iend, stride + jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) + obj%val(jj) = VALUE +END DO +!$OMP END PARALLEL DO +END PROCEDURE obj_Set30 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set31 +INTEGER(I4B) :: ii, jj +!$OMP PARALLEL DO PRIVATE(ii, jj) +DO ii = istart, iend, stride + jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii) + obj%val(jj) = VALUE((ii - istart + stride) / stride) +END DO +!$OMP END PARALLEL DO +END PROCEDURE obj_Set31 + +!---------------------------------------------------------------------------- +! set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set32 +INTEGER(I4B) :: tsize +tsize = (iend - istart + stride) / stride +CALL F77_Copy(N=tsize, X=VALUE(istart_value:), INCX=stride_value, & + Y=obj%val(istart:), INCY=stride) +! !$OMP PARALLEL DO PRIVATE(ii) +! DO ii = 1, tsize +! obj%val(istart+(stride-1)*ii) = value(istart_value+(stride_value-1)*ii) +! END DO +! !$OMP END PARALLEL DO +END PROCEDURE obj_Set32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.F90 new file mode 100644 index 000000000..cefda8f30 --- /dev/null +++ b/src/submodules/RealVector/src/RealVector_ShallowCopyMethods@Methods.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(RealVector_ShallowCopyMethods) Methods +USE ReallocateUtility, ONLY: Reallocate +USE RealVector_ConstructorMethods, ONLY: Size + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy1a +CALL Reallocate(Y, SIZE(X)) +END PROCEDURE obj_ShallowCopy1a + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy1b +CALL Reallocate(Y, SIZE(X)) +END PROCEDURE obj_ShallowCopy1b + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy1c +CALL Reallocate(Y, SIZE(X)) +END PROCEDURE obj_ShallowCopy1c + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy1d +CALL Reallocate(Y, SIZE(X)) +END PROCEDURE obj_ShallowCopy1d + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy2 +CALL ShallowCopy(Y=Y%Val, X=X%Val) +END PROCEDURE obj_ShallowCopy2 + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy3 +INTEGER(I4B) :: i +IF (ALLOCATED(Y)) THEN + IF (SIZE(Y) .NE. SIZE(X)) THEN + DEALLOCATE (Y) + ALLOCATE (Y(SIZE(X))) + END IF +ELSE + ALLOCATE (Y(SIZE(X))) +END IF +DO i = 1, SIZE(Y) + CALL ShallowCopy(Y=Y(i)%Val, X=X(i)%Val) +END DO +END PROCEDURE obj_ShallowCopy3 + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy4 +INTEGER(I4B) :: i, tNodes +tNodes = 0 +DO i = 1, SIZE(X) + tNodes = tNodes + SIZE(X(i)%Val) +END DO +CALL Reallocate(Y%Val, tNodes) +END PROCEDURE obj_ShallowCopy4 + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy5a +CALL ShallowCopy(Y=Y%Val, X=X) +END PROCEDURE obj_ShallowCopy5a + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy5b +CALL ShallowCopy(Y=Y%Val, X=X) +END PROCEDURE obj_ShallowCopy5b + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy6a +CALL ShallowCopy(Y=Y, X=X%Val) +END PROCEDURE obj_ShallowCopy6a + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy6b +CALL ShallowCopy(Y=Y, X=X%Val) +END PROCEDURE obj_ShallowCopy6b + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy7a +INTEGER(I4B) :: ii, m +m = 0 +DO ii = 1, SIZE(X) + m = m + SIZE(X(ii)) +END DO +CALL Reallocate(Y, m) +END PROCEDURE obj_ShallowCopy7a + +!---------------------------------------------------------------------------- +! ShallowCopy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ShallowCopy7b +INTEGER(I4B) :: ii, m +m = 0 +DO ii = 1, SIZE(X) + m = m + SIZE(X(ii)) +END DO +CALL Reallocate(Y, m) +END PROCEDURE obj_ShallowCopy7b + +END SUBMODULE Methods diff --git a/src/submodules/RealVector/src/Save_hdf5.F90 b/src/submodules/RealVector/src/Save_hdf5.F90 new file mode 100644 index 000000000..c8f6427da --- /dev/null +++ b/src/submodules/RealVector/src/Save_hdf5.F90 @@ -0,0 +1,151 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 25 Feb 2021 +! summary: This submodule implements IO methods of [[RealVector_]] + +SUBMODULE(RealVector_Method) IO +USE BaseMethod +USE h5fortran +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RealVectorDisplay + INTEGER( I4B ) :: i, max_size + type(hdf5_file) :: h5f + type(File_) :: aFile + INTEGER( I4B ) :: sizes(SIZE(obj)) + REAL( DFP ) :: val( SIZE( obj ) ) + + DO i = 1, SIZE( obj ) + sizes(i) = SIZE(obj(i)) + END DO + + max_size = MAXVAL( sizes ) + + IF( PRESENT( UnitNo ) ) THEN + CALL Write_data( UnitNo ) + RETURN + END IF + + IF( PRESENT( filename ) ) THEN + SELECT CASE( TRIM( extension ) ) + CASE( '.hdf5' ) + call ExecuteCommand( 'mkdir -p '//trim(path), & + & __FILE__ // "Line num :: " // TRIM(INT2STR(__LINE__)) & + & // " RealVectorDisplay()" ) + + call h5f%initialize( & + & filename= trim(path)//trim(filename)//trim(extension), & + & status='new', action='w', comp_lvl=1) + + DO i = 1, SIZE(obj) + call h5f%write( '/' // TRIM(msg) // '/comp[' & + & // TRIM(INT2STR(i)) // ']', obj(i)%Val ) + END DO + call h5f%finalize() + + CASE( '.txt' ) + CALL OpenFileToWrite(obj=afile, filename=filename, path=path, & + & extension='.txt') + CALL Write_data( afile%UnitNo ) + CALL CloseFile(afile) + + CASE( '.md' ) + CALL Display( __FILE__, 'ERROR in File :: ' ) + CALL Display( __LINE__, ' in LINE :: ' ) + CALL Display( ' Message :: Cannot write to .txt file') + STOP + END SELECT + + RETURN + + END IF + + CALL Write_data( stdout ) + + CONTAINS + SUBROUTINE Write_data( unitno ) + INTEGER( I4B ), INTENT( IN ) :: unitno + INTEGER( I4B ) :: i, j + + DO i = 1, max_size + val = 0.0_DFP + DO j = 1, SIZE( obj ) + IF( i .LE. sizes( j ) ) val( j ) = obj(j)%Val(i) + END DO + + WRITE( UnitNo, * ) val + + END DO + END SUBROUTINE + +END PROCEDURE RealVectorDisplay + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RealscalarDisplay + IF( PRESENT( UnitNo ) ) THEN + CALL Display( obj%Val, UnitNo = UnitNo, msg=msg ) + RETURN + END IF + + IF( PRESENT( filename ) ) THEN + CALL Display( obj%Val, msg=msg, filename=filename, & + & extension=extension, path=path ) + RETURN + END IF + + CALL Display( obj%Val, msg=msg, unitNo = stdout) + +END PROCEDURE RealscalarDisplay + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Display_Vector_Real + INTEGER( I4B ) :: i + type(hdf5_file) :: h5f + + SELECT CASE( TRIM( extension ) ) + CASE( '.hdf5' ) + call ExecuteCommand( 'mkdir -p ' // trim(path), & + & __FILE__ // "Line num :: " // TRIM(INT2STR(__LINE__)) & + & // " Display_Vector_Real()" ) + call h5f%initialize( & + & filename= trim(path)//trim(filename)//trim(extension), & + & status='new', action='w', comp_lvl=1) + call h5f%write( '/' // TRIM(msg), Vec ) + call h5f%finalize() + CASE DEFAULT + CALL Display( Val=__FILE__, msg="Error: In file :: ", unitNo = stdout ) + CALL Display( Val=__LINE__, msg="In line number :: ", UnitNo = stdout ) + CALL Display( Msg= "No match found for given extension", UnitNo=stdout ) + STOP + END SELECT + +END PROCEDURE Display_Vector_Real + +END SUBMODULE IO \ No newline at end of file diff --git a/src/submodules/STConvectiveMatrix/CMakeLists.txt b/src/submodules/STConvectiveMatrix/CMakeLists.txt new file mode 100644 index 000000000..7db91df8e --- /dev/null +++ b/src/submodules/STConvectiveMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/STConvectiveMatrix_Method@Methods.F90 + ) diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part new file mode 100755 index 000000000..291a5a8e8 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/Constructor.part @@ -0,0 +1,139 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate Convective Matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STConvectiveMatrix_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor_1 ) + ALLOCATE( Constructor_1 % Mat2( row, col ) ) + Constructor_1 % Mat2 = 0.0_DFP + CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate the Space Time Convective Matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STConvectiveMatrix_ ), POINTER :: Constructor_2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor_2 ) + ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) + Constructor_2 % Mat4 = 0.0_DFP + CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Returns mass matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STConvectiveMatrix_ ), POINTER :: Constructor_3 + ALLOCATE( Constructor_3 ) + + END FUNCTION Constructor_3 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate Convective Matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STConvectiveMatrix_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor1 % Mat2( row, col ) ) + Constructor1 % Mat2 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Initiate the Space Time Convective Matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STConvectiveMatrix_ ) :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) + Constructor2 % Mat4 = 0.0_DFP + CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Returns mass matrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STConvectiveMatrix_ ) :: Constructor3 + + END FUNCTION Constructor3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part new file mode 100755 index 000000000..4f685eeaf --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_10.part @@ -0,0 +1,52 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_10.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_10 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_10( Obj, Term1, Term2, Xtype, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. getting the Convective matrix +! 2. Term1, Term2 0, 1 +! 3. XType X, Y, Z +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: XType + + CALL Obj % getConvectiveMatrix( Term1 = Term1, Term2 = Term2, XType = XType ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getConvectiveMatrix_10 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part new file mode 100755 index 000000000..96fcba280 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_11.part @@ -0,0 +1,199 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_11.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getConvectiveMatrix_11 +!------------------------------------------------------------------------------ +! + SUBROUTINE getConvectiveMatrix_11( Obj, C, Term1, Term2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( :, :, : ) +! 2. Term1 and Term2 `dx` `dt` +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & + DummyVec2( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + + ! Flag-1 +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL(Term1) ) ) + + CASE( "dt", "DT", "Dt", "dT" ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dt, dx ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( STNodalValues = C, & + cdNTdXt = cdNTdXt) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()" & + ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & + b = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "Unknown value of Term2; It should be dx or dy or dz" & + ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + +#ifdef DEBUG_VER + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) +#else + CASE DEFAULT +#endif + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dx, dt ) + CASE( "dt", "DT", "Dt", "dT" ) +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( STNodalValues = C, & + cdNTdXt = cdNTdXt ) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()" & + ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & + a = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "Unknown value of Term2; It should be 'dt' " & + ) + Error_Flag = .TRUE. + RETURN + END SELECT + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_11()", & + "Unknown value of Term1; It should be 'dt' or 'dx'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat4FromMat2( NNT, NNT ) + NULLIFY( SD ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + + END SUBROUTINE getConvectiveMatrix_11 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part new file mode 100755 index 000000000..b67dc189b --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_12.part @@ -0,0 +1,200 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_12.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix12 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_12( Obj, C, Term1, Term2 ) + +!. . . . . . . . . . . . . . . . . . . . +! `1. C( :, : ) +! 2. Term1 and Term2 "dx", "dt" +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & + DummyVec2( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + + ! Flag-1 +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL(Term1) ) ) + + CASE( "dt", "DT", "Dt", "dT" ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dt, dx ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( SpaceNodalValues = C, & + cdNTdXt = cdNTdXt) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()" & + ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & + b = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "Unknown value of Term2; It should be dx or dy or dz" & + ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + +#ifdef DEBUG_VER + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) +#else + CASE DEFAULT +#endif + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dx, dt ) + CASE( "dt", "DT", "Dt", "dT" ) +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( SpaceNodalValues = C, & + cdNTdXt = cdNTdXt ) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()" & + ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & + a = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "Unknown value of Term2; It should be 'dt' " & + ) + Error_Flag = .TRUE. + RETURN + END SELECT + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_12()", & + "Unknown value of Term1; It should be 'dt' or 'dx'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat4FromMat2( NNT, NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + + END SUBROUTINE getConvectiveMatrix_12 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part new file mode 100755 index 000000000..5338a8aac --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_13.part @@ -0,0 +1,239 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_13.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_13 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_13( Obj, C, Term1, Term2, CType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( :, : ) +! 2. Term1, Term2 dt and dx +! 3. CType `NodalValues` `QuadPoints` +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & + DummyVec2( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( "Nodal", "Nodal Values", "NodalValues", & + "SpaceNodalValues", "Space Nodal Values" ) + + CALL Obj % getConvectiveMatrix_12( Term1 = Term1, & + Term2 = Term2, C = C ) + +#ifdef DEBUG_VER + IF( Error_Flag ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()", & + "TraceBack >> & + & CALL Obj % getConvectiveMatrix_12( Term1 = Term1, & + & Term2 = Term2, C = C ) " ) + + END IF + CASE( "Integration", "Integration Points", & + "IntegrationPoints", "Quad", "Quad Points", "QuadPoints" ) +#else + CASE DEFAULT +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL(Term1) ) ) + + CASE( "dt", "DT", "Dt", "dT" ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dt, dx ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS ), & + cdNTdXt = cdNTdXt) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()" & + ) +#endif + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & + b = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()", & + "Unknown value of Term2; & + & It should be dx or dy or dz" ) + Error_Flag = .TRUE. + RETURN + END SELECT + + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dx, dt ) + CASE( "dt", "DT", "Dt", "dT" ) +#else + CASE DEFAULT +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS ), & + cdNTdXt = cdNTdXt ) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()" ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & + a = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()", & + "Unknown value of Term2; It should be 'dt' " & + ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()", & + "Unknown value of Term1; It should be 'dt' or 'dx'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_13()", & + "No case found for given CType; It should be & + & 'Nodal', 'NodalValues', 'Nodal Values', 'SpaceNodalValues', & + & 'Space Nodal Values', 'Integation Points', 'Integration', & + & 'IntegrationPoints', 'Quad', 'Quad Points', 'QuadPoints'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat4FromMat2( NNT, NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + + END SUBROUTINE getConvectiveMatrix_13 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part new file mode 100755 index 000000000..7cd462542 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_14.part @@ -0,0 +1,238 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_14.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_14 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_14( Obj, C, Term1, Term2, CType ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C(:,:,:) +! 2. Term1, Term2 "dx", "dt" +! 3. Ctype "NodalValues", "QuadPoints" +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & + DummyVec2( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()", & + "STMassMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( "Nodal", "Nodal Values", "NodalValues", & + "STNodalValues", "ST Nodal Values" ) + + CALL Obj % getConvectiveMatrix_11( Term1 = Term1, & + Term2 = Term2, C = C ) + +#ifdef DEBUG_VER + IF( Error_Flag ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()", & + "TraceBack >> & + & CALL Obj % getConvectiveMatrix_11( Term1 = Term1, & + & Term2 = Term2, C = C ) " & + ) + + END IF +#endif + + CASE( "Integration", "Integration Points", & + "IntegrationPoints", "Quad", "Quad Points", "QuadPoints" ) + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL(Term1) ) ) + + CASE( "dt", "DT", "Dt", "dT" ) + + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dt, dx ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS, IPT ), & + cdNTdXt = cdNTdXt ) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()" & + ) +#endif + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & + b = DummyVec2( :, 1 ) ) + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()", & + "Unknown value of Term2; It should be dx or dy or dz" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) + + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dx, dt ) + CASE( "dt", "DT", "Dt", "dT" ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( VectorValues = C( :, IPS, IPT ), & + cdNTdXt = cdNTdXt ) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()" & + ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & + a = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()", & + "Unknown value of Term2; It should be 'dt'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()", & + "Unknown value of Term1; It should be 'dt' or 'dx'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_14()", & + "No case found for given CType; It should be & + & 'Nodal', 'NodalValues', 'Nodal Values', 'STNodalValues', & + & 'ST Nodal Values', 'Integation Points', 'Integration', & + & 'IntegrationPoints', 'Quad', 'Quad Points', 'QuadPoints'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat4FromMat2( NNT, NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + + END SUBROUTINE getConvectiveMatrix_14 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part new file mode 100755 index 000000000..fe1487a7d --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_15.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_15.part +! Last Update : Nov-18-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_15 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_15( Obj, C, Term1, Term2, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( :, :, : ) +! 2. Term1, Term2 "dx", "dt" +! 3. nCopy +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getConvectiveMatrix_15 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part new file mode 100755 index 000000000..f7175bbd4 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_16.part @@ -0,0 +1,51 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_16.part +! Last Update : Nov-18-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_16 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_16( Obj, C, Term1, Term2, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( :, : ) +! 2. Term1, Term2 { dx, dt } +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getConvectiveMatrix_16 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part new file mode 100755 index 000000000..095bcc92a --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_17.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_17.part +! Last Update : Nov-18-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_17 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_17( Obj, C, Term1, Term2, CType, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( :, : ) +! 2. Term1, Term2 {dx, dt} +! 3. CType "NodalValues", "QuadPoints" +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getConvectiveMatrix_17 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part new file mode 100755 index 000000000..ae658547f --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_18.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_18.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_18 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_18( Obj, C, Term1, Term2, CType, nCopy) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( :, :, : ) +! 2. Term1, Term2 "dx", "dt" +! 3. CType "NodalValues", "QuadPoints" +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getConvectiveMatrix_18 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part new file mode 100755 index 000000000..b69749b79 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_19.part @@ -0,0 +1,347 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_19.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getConvectiveMatrix_19 +!------------------------------------------------------------------------------ +! + SUBROUTINE getConvectiveMatrix_19( Obj, A, Term1, Term2, Xtype, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A( :, :, :, : ) +! 2. Term1, Term2 1, or 0 +! 3. Xtype x, y, z +! 4. MultiVar is just to create another interface +!. . . . . . . . . . . . . . . . . . . . + + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, :, : ), Mat4( :, :, :, : ) + REAL( DFP ) :: RealVal, RealVal1, Aij + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( A, 3 ) .NE. NIPS .OR. SIZE( A, 4 ) .NE. NIPT ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19()", & + "The Shape of A matrix must be ( *, *, NIPS, NIPT)" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19()", & + "XType is X therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19(), Flag-1", & + "XType is Y therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19(), Flag-1", & + "XType is Z therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Mat3( NNS, NNS, NNT ) ) + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + Mat2 = A( :, :, IPS, IPT ) + + DO aa = 1, NNT + + Mat3( :, :, aa ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), b = SD % N ) + + END DO + + DO b = 1, NNT + + RealVal = SD % T( b ) * RealVal1 + + Mat4( :, :, :, b ) = Mat3 * RealVal + + END DO + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( j, i ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + + !( 0, 1 ) + CASE( 1 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + Mat2 = A( :, :, IPS, IPT ) + + DO b = 1, NNT + + Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) + + END DO + + DO aa = 1, NNT + + RealVal = SD % T( aa ) * RealVal1 + + Mat4( :, :, aa, : ) = Mat3 * RealVal + + END DO + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( i, j ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_19()", & + "Unknown value of Term1; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + + END SUBROUTINE getConvectiveMatrix_19 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part new file mode 100755 index 000000000..d69b69094 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_20.part @@ -0,0 +1,345 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_20.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_20 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_20( Obj, A, Term1, Term2, Xtype, MultiVar ) + +!------------------------------------------------------------------------------ +! 1. - Returns mass matrix; A is 3D array; Spatial-integration points +!------------------------------------------------------------------------------ + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, :, : ), & + & Mat4( :, :, :, : ) + REAL( DFP ) :: RealVal, RealVal1, Aij + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( A, 3 ) .NE. NIPS ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20()", & + "The Shape of A matrix must be ( *, *, NIPS)" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20()", & + "XType is X therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20(), Flag-1", & + "XType is Y therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20(), Flag-1", & + "XType is Z therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + ! CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + ! XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + +! + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Mat3( NNS, NNS, NNT ) ) + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + Mat2 = A( :, :, IPS ) + + DO aa = 1, NNT + + Mat3( :, :, aa ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), b = SD % N ) + + END DO + + DO b = 1, NNT + + RealVal = SD % T( b ) * RealVal1 + + Mat4( :, :, :, b ) = Mat3 * RealVal + + END DO + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( j, i ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + + !( 0, 1 ) + CASE( 1 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + Mat2 = A( :, :, IPS ) + + DO b = 1, NNT + + Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) + + END DO + + DO aa = 1, NNT + + RealVal = SD % T( aa ) * RealVal1 + + Mat4( :, :, aa, : ) = Mat3 * RealVal + + END DO + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( i, j ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_20()", & + "Unknown value of Term1; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + + END SUBROUTINE getConvectiveMatrix_20 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part new file mode 100755 index 000000000..316ddf82a --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_21.part @@ -0,0 +1,316 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_21.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_21 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_21( Obj, A, Term1, Term2, Xtype, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A( :, : ) +! 2. Term1, Term2 "dx" "dt" +! 3. XType "x, y, z" +! 4. Multivar is for +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ), ALLOCATABLE :: Mat3( :, :, : ), Mat4( :, :, :, : ) + REAL( DFP ) :: RealVal, RealVal1, Aij + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER +! Flag-3 + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21()", & + "XType is X therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + END IF + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21(), Flag-1", & + "XType is Y therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21(), Flag-1", & + "XType is Z therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + END IF + END SELECT +#endif + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Mat3( NNS, NNS, NNT ) ) + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DO aa = 1, NNT + + Mat3( :, :, aa ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), b = SD % N ) + + END DO + + DO b = 1, NNT + + RealVal = SD % T( b ) * RealVal1 + + Mat4( :, :, :, b ) = Mat3 * RealVal + + END DO + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = A( j, i ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + + !( 0, 1 ) + CASE( 1 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DO b = 1, NNT + + Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) + + END DO + + DO aa = 1, NNT + + RealVal = SD % T( aa ) * RealVal1 + + Mat4( :, :, aa, : ) = Mat3 * RealVal + + END DO + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = A( i, j ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_21()", & + "Unknown value of Term1; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + + END SUBROUTINE getConvectiveMatrix_21 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ \ No newline at end of file diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part new file mode 100755 index 000000000..0457b3a55 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_22.part @@ -0,0 +1,258 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_22.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_22 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_22( Obj, Term1, Term2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Term1 and Term2 = {dt, dx, dy, dz} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + +! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ) :: RealVal + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + REAL( DFP ), ALLOCATABLE :: DummyVec1( :, : ), DummyVec2( :, : ) + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_22()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_22()", & + "Term1 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_22()", & + "Term1 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_22()", & + "Term1 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_22()", & + "Term2 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_22()", & + "Term2 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_22()", & + "Term2 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL(Term1) ) ) + + CASE( "dt", "DT", "Dt", "dT" ) + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RealVal * RESHAPE( SD % dNTdXt( :, XIndex, : ), (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + & + OUTERPROD( a = DummyVec1( :, 1 ), b = DummyVec2( :, 1 ) ) + + END DO + + END DO + + CASE DEFAULT + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RealVal * RESHAPE( SD % dNTdXt( :, XIndex, : ), (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + & + OUTERPROD( b = DummyVec1( :, 1 ), a = DummyVec2( :, 1 ) ) + + END DO + + END DO + + END SELECT + + CALL Obj % Mat4FromMat2( NNT, NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + + + END SUBROUTINE getConvectiveMatrix_22 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part new file mode 100755 index 000000000..029e075f0 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_23.part @@ -0,0 +1,50 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_23.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_23 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_23( Obj, Term1, Term2, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Term1 and Term2 = { dt, dx, dy, dz } +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getConvectiveMatrix( Term1 = Term1, Term2 = Term2 ) + CALL Obj % MakeDiagonalCopies(nCopy) + + END SUBROUTINE getConvectiveMatrix_23 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part new file mode 100755 index 000000000..e542b57e4 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_24.part @@ -0,0 +1,351 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_24.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_24 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_24( Obj, A, Term1, Term2, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A( :, :, :, : ) +! 2. Term1, Term2 {dt, dx, dy, dx} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) + REAL( DFP ) :: RealVal, Aij + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + +NIPT = SIZE( Obj % SD, 2 ) +NNS = SIZE( Obj % SD( 1,1 ) % N ) +NNT = SIZE( Obj % SD( 1,1 ) % T ) +NIPS = SIZE( Obj % SD, 1 ) +NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( A, 3 ) .NE. NIPS .OR. SIZE( A, 4 ) .NE. NIPT ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "The Shape of A matrix must be ( *, *, NIPS, NIPT)" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "Term1 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "Term1 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "Term1 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg("STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "Term2 is dx therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "Term2 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_24()", & + "Term2 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dt", "DT", "dT", "t" ) + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + ! XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + Mat2 = A( :, :, IPS, IPT ) + + DO b = 1, NNT + + DO aa = 1, NNT + + Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdt( :, aa ), & + b = SD % dNTdXt( :, XIndex, b ) ) + + END DO + + END DO + + Mat4 = Mat4 * RealVal + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( i, j ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + + CASE DEFAULT + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + ! XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + Mat2 = A( :, :, IPS, IPT ) + + DO b = 1, NNT + + DO aa = 1, NNT + + Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), & + b = SD % dNTdt( :, b ) ) + + END DO + + END DO + + Mat4 = Mat4 * RealVal + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( j, i ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + + END SUBROUTINE getConvectiveMatrix_24 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part new file mode 100755 index 000000000..9872cc2d8 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_25.part @@ -0,0 +1,347 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_25.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_25 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_25( Obj, A, Term1, Term2, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A(:,:,:) +! 2. Term1, Term2 {dt, dx, dy, dz} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) + REAL( DFP ) :: RealVal, Aij + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + +NIPT = SIZE( Obj % SD, 2 ) +NNS = SIZE( Obj % SD( 1,1 ) % N ) +NNT = SIZE( Obj % SD( 1,1 ) % T ) +NIPS = SIZE( Obj % SD, 1 ) +NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( A, 3 ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "The Shape of A matrix must be ( *, *, NIPS)" & + ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "Term1 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "Term1 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "Term1 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg("STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "Term2 is dx therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "Term2 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_25()", & + "Term2 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dt", "DT", "dT", "t" ) + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + ! XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + Mat2 = A( :, :, IPS ) + + DO b = 1, NNT + + DO aa = 1, NNT + + Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdt( :, aa ), & + b = SD % dNTdXt( :, XIndex, b ) ) + + END DO + + END DO + + Mat4 = Mat4 * RealVal + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( i, j ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + + CASE DEFAULT + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + ! XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + Mat2 = A( :, :, IPS ) + + DO b = 1, NNT + + DO aa = 1, NNT + + Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), & + b = SD % dNTdt( :, b ) ) + + END DO + + END DO + + Mat4 = Mat4 * RealVal + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = Mat2( j, i ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + + END SUBROUTINE getConvectiveMatrix_25 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part new file mode 100755 index 000000000..093ce3ded --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_26.part @@ -0,0 +1,338 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_25.part +! Last Update : Nov-19-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_26 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_26( Obj, A, Term1, Term2, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A( :, : ) +! 2. Term1 and Term2 {dt,dx,dy,dz} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ), ALLOCATABLE :: Mat4( :, :, :, : ) + REAL( DFP ) :: RealVal, Aij + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + +NIPT = SIZE( Obj % SD, 2 ) +NNS = SIZE( Obj % SD( 1,1 ) % N ) +NNT = SIZE( Obj % SD( 1,1 ) % T ) +NIPS = SIZE( Obj % SD, 1 ) +NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + M = SIZE( A, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "Term1 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "Term1 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "Term1 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg("STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "Term2 is dx therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "Term2 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_26()", & + "Term2 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dt", "DT", "dT", "t" ) + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + ! XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + ! Mat2 = A( :, :, IPS, IPT ) + + DO b = 1, NNT + + DO aa = 1, NNT + + Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdt( :, aa ), & + b = SD % dNTdXt( :, XIndex, b ) ) + + END DO + + END DO + + Mat4 = Mat4 * RealVal + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = A( i, j ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + + CASE DEFAULT + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + ! CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + ! XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + ! Mat2 = A( :, :, IPS, IPT ) + + DO b = 1, NNT + + DO aa = 1, NNT + + Mat4( :, :, aa, b ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, aa ), & + b = SD % dNTdt( :, b ) ) + + END DO + + END DO + + Mat4 = Mat4 * RealVal + + DO j = 1, M + + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + + DO i = 1, M + + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + + Aij = A( j, i ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4( :, :, :, : ) * Aij + + END DO + + END DO + + END DO + + END DO + + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + + END SUBROUTINE getConvectiveMatrix_26 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part new file mode 100755 index 000000000..26e5b2361 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_27.part @@ -0,0 +1,200 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_27.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix12 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_27( Obj, C, Term1, Term2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( : ) +! 2. Term1, Term2 {dt, dx, dy, dz} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), DummyVec1( :, : ), & + DummyVec2( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + + ! Flag-1 +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_27()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL(Term1) ) ) + + CASE( "dt", "DT", "Dt", "dT" ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dt, dx ) + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( VectorValues = C, & + cdNTdXt = cdNTdXt) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_27()" & + ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( a = DummyVec1( :, 1 ), & + b = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_27()", & + "Unknown value of Term2; It should be dx or dy or dz" & + ) + Error_Flag = .TRUE. + RETURN + END SELECT +#endif + +#ifdef DEBUG_VER + CASE( "dx", "dX", "dx1", "dX1", "x", "X", "x1", "X1", & + "dy", "dY", "dx2", "dX2", "y", "Y", "x2", "X2", & + "dz", "dZ", "dx3", "dX3", "z", "Z", "x3", "X3" ) +#else + CASE DEFAULT +#endif + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL(Term2) ) ) + + !( dx, dt ) + CASE( "dt", "DT", "Dt", "dT" ) +#endif + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( VectorValues = C, & + cdNTdXt = cdNTdXt ) +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_27()" & + ) +#endif + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DummyVec1 = RealVal * RESHAPE( SD % dNTdt, (/NNS*NNT, 1/) ) + DummyVec2 = RESHAPE( cdNTdXt, (/NNS*NNT, 1/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) + OUTERPROD( b = DummyVec1( :, 1 ), & + a = DummyVec2( :, 1 ) ) + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_27()", & + "Unknown value of Term2; It should be 'dt' " & + ) + Error_Flag = .TRUE. + RETURN + END SELECT + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_27()", & + "Unknown value of Term1; It should be 'dt' or 'dx'" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat4FromMat2( NNT, NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + + END SUBROUTINE getConvectiveMatrix_27 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part new file mode 100755 index 000000000..8979b227a --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_28.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_28.part +! Last Update : Nov-18-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_28 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_28( Obj, C, Term1, Term2, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( : ) +! 2. Term1, Term2 {dt, dx, dy, dz} +!. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + CALL Obj % getConvectiveMatrix( C = C, Term1 = Term1, Term2 = Term2 ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getConvectiveMatrix_28 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part new file mode 100755 index 000000000..f59eef7a6 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_29.part @@ -0,0 +1,208 @@ + +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_29.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_29 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_29( Obj, C, Term1, Term2 ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. C( : ) +! 2. Term1, Term2 = {0,1} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, b + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Mat3( :, :, : ) + REAL( DFP ) :: RealVal1, RealVal + CLASS( STShapeData_ ), POINTER :: SD + + ! Flag-1 +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_1()", & + "Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Mat3( NNS, NNS, NNT ) ) + +SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + CALL SD % getProjectionOfdNTdXt( VectorValues = C, cdNTdXt = cdNTdXt ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DO a = 1, NNT + + Mat3( :, :, a ) = OUTERPROD( a = cdNTdXt( :, a ), b = SD % N ) + + END DO + + DO b = 1, NNT + + RealVal = SD % T( b ) * RealVal1 + + Obj % Mat4( :, :, :, b ) = Obj % Mat4( :, :, :, b ) + & + Mat3 * RealVal + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_1()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + + !( 0, 1 ) + CASE( 1 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + CALL SD % getProjectionOfdNTdXt( VectorValues = C, & + cdNTdXt = cdNTdXt ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + +#ifdef DEBUG_VER + CALL Check_Error( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_1()" ) +#endif + + DO b = 1, NNT + + Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = cdNTdXt( :, b ) ) + + END DO + + + DO a = 1, NNT + + RealVal = SD % T( a ) * RealVal1 + + Obj % Mat4( :, :, a, : ) = Obj % Mat4( :, :, a, : ) + & + Mat3 * RealVal + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_1()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_1()", & + "Unknown value of Term1; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + + END SUBROUTINE getConvectiveMatrix_29 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part new file mode 100755 index 000000000..bdc4bc5aa --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_30.part @@ -0,0 +1,231 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_30.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_30 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_30( Obj, A, A0, Term1, Term2, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A, A0 ( :, :, :, : ) +! 2. Term1, Term2 {dt, dx, dy, dz} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: A, A0 + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables +#ifdef DEBUG_VER + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, NSD +#endif + INTEGER( I4B ) :: IPS, IPT + REAL( DFP ), ALLOCATABLE :: Mat4( :, :, :, : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + IF( SIZE( A, 3 ) .NE. NIPS .OR. SIZE( A, 4 ) .NE. NIPT ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "The Shape of A matrix must be ( *, *, NIPS, NIPT)" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A0, 3 ) .NE. NIPS .OR. SIZE( A0, 4 ) .NE. NIPT ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "The Shape of A0 matrix must be ( *, *, NIPS, NIPT)" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "The size of first and second dimension of A0 must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "Term1 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "Term1 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "Term1 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "Term2 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "Term2 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_30()", & + "Term2 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + +#endif + + ALLOCATE( Mat4( SIZE( A, 1 ), SIZE( A, 2 ), SIZE( A, 3 ), SIZE( A, 4 ) ) ) + + DO IPT = 1, SIZE( A, 4 ) + DO IPS = 1, SIZE( A, 3 ) + Mat4( :, :, IPS, IPT ) = MATMUL( TRANSPOSE( A0( :,:,IPS, IPT ) ), A( :, :, IPS, IPT ) ) + END DO + END DO + + CALL Obj % getConvectiveMatrix( A = Mat4, Term1 = Term1, Term2 = Term2, MultiVar = MultiVar ) + DEALLOCATE( Mat4 ) + + END SUBROUTINE getConvectiveMatrix_30 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part new file mode 100755 index 000000000..837ff34f4 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_31.part @@ -0,0 +1,229 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_31.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_31 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_31( Obj, A, A0, Term1, Term2, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A, A0 ( :, :, : ) +! 2. Term1, Term2 {dt, dx, dy, dz} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: A, A0 + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables +#ifdef DEBUG_VER + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, NSD +#endif + INTEGER( I4B ) :: IPS + REAL( DFP ), ALLOCATABLE :: Mat3( :, :, : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + IF( SIZE( A, 3 ) .NE. NIPS ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "The Shape of A matrix must be ( *, *, NIPS)" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A0, 3 ) .NE. NIPS ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "The Shape of A0 matrix must be ( *, *, NIPS )" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "The size of first and second dimension of A0 must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "Term1 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "Term1 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "Term1 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "Term2 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "Term2 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_31()", & + "Term2 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + ALLOCATE( Mat3( SIZE( A, 1 ), SIZE( A, 2 ), SIZE( A, 3 ) ) ) + + DO IPS = 1, SIZE( A, 3 ) + Mat3( :, :, IPS ) = MATMUL( TRANSPOSE( A0( :,:,IPS ) ), A( :, :, IPS ) ) + END DO + + CALL Obj % getConvectiveMatrix( A = Mat3, Term1 = Term1, Term2 = Term2, MultiVar = MultiVar ) + + DEALLOCATE( Mat3 ) + + END SUBROUTINE getConvectiveMatrix_31 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part new file mode 100755 index 000000000..e9f637d6c --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_32.part @@ -0,0 +1,198 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_32.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_32 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_32( Obj, A, A0, Term1, Term2, MultiVar ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. A, A0 ( :, : ) +! 2. Term1, Term2 {dt, dx, dy, dz} +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: A, A0 + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar + + ! Define internal variables +#ifdef DEBUG_VER + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, NSD +#endif + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + IF( SIZE( A, 1 ) .NE. SIZE( A, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "The size of first and second dimension of A must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( SIZE( A0, 1 ) .NE. SIZE( A0, 2 ) ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "The size of first and second dimension of A0 must be same" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "Term1 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "Term1 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "Term1 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "dX", "dx", "dx1", "dX1", "X", "x", "x1", "X1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "Term2 is dx therefore NSD should be & + & greater than or equal to 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "Term2 is dy therefore NSD should be greater than 1" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_32()", & + "Term2 is dz therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + Mat2 = MATMUL( TRANSPOSE( A0 ), A ) + CALL Obj % getConvectiveMatrix( A = Mat2, Term1 = Term1, Term2 = Term2, MultiVar = MultiVar ) + DEALLOCATE( Mat2 ) + + END SUBROUTINE getConvectiveMatrix_32 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part new file mode 100755 index 000000000..4d14c9a87 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_33.part @@ -0,0 +1,238 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_33.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_33 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns Space time convective matrix +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, :, : ) + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & + Mat3( :, : ), dUdt( : ) + REAL( DFP ) :: RealVal, RealVal1, RealVal2 + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + LOGICAL( LGT ) :: dCdU_Nodal + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + ! Flag-1 + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_33(), Flag-1", & + "STConvectiveMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + a = SIZE( dCdU, 3 ) + b = SIZE( dCdU, 4 ) + +#ifdef DEBUG_VER + IF( a .NE. NNS .AND. a .NE. NIPS ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of third index of dCdU must be equal to the NNS or NIPS" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( b .NE. NNT .AND. b .NE. NIPT ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of fourth index of dCdU must be equal to the NNT or NIPT" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( tSize .NE. NSD ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + ! Check the type of dCdU + + SELECT CASE( TRIM( dCdU_Type ) ) + + CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & + "Space Nodal Values" ) + + dCdU_Nodal = .TRUE. + + CASE( "Integration", "Integration Points", & + "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) + + dCdU_Nodal = .FALSE. + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_33( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "dCdU_Type should be either NodalValues or QuadPoints" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + + Obj % Mat4 = 0.0_DFP; + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + IF( dCdU_Nodal ) THEN + + CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ ) +#ifdef DEBUG_VER + CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_33()", & + "CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ )" ) +#endif + + ELSE + + dCdU_ = dCdU( :, :, IPS, IPT ) + + END IF + + ! Compute dUdt + dUdt = SD .dVdt. U + + DO a = 1, NNT + + Mat3 = MATMUL( SD % dNTdXt( :, :, a ), dCdU_ ) + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) + + DO b = 1, NNT + + RealVal2 = RealVal1 * SD % T( b ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + RealVal = RealVal2 * dUdt( p ) + + Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & + Obj % Mat4( r1 : r2, c1 : c2, a, b ) & + + RealVal * Mat2 + + END DO + + END DO + + END DO + + + END DO + + + END DO + + END DO + + CALL Obj % Mat2FromMat4( ) + + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) + + END SUBROUTINE getConvectiveMatrix_33 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part new file mode 100755 index 000000000..b72196cc7 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_34.part @@ -0,0 +1,222 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_34.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_34 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns Space time convective matrix +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, : ) + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & + Mat3( :, : ), dUdt( : ) + REAL( DFP ) :: RealVal, RealVal1, RealVal2 + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + LOGICAL( LGT ) :: dCdU_Nodal + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_34(), Flag-1", & + "STConvectiveMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + a = SIZE( dCdU, 3 ) + +#ifdef DEBUG_VER + IF( a .NE. NNS .AND. a .NE. NIPS ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of third index of dCdU must be equal to the NNS or NIPS" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( tSize .NE. NSD ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + ! Check the type of dCdU + + SELECT CASE( TRIM( dCdU_Type ) ) + + CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & + "Space Nodal Values" ) + + dCdU_Nodal = .TRUE. + + CASE( "Integration", "Integration Points", & + "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) + + dCdU_Nodal = .FALSE. + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_34( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "dCdU_Type should be either NodalValues or QuadPoints" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + + Obj % Mat4 = 0.0_DFP; + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + IF( dCdU_Nodal ) THEN + + CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) +#ifdef DEBUG_VER + CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_34()", & + "CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ )" ) +#endif + ELSE + + dCdU_ = dCdU( :, :, IPS ) + + END IF + + ! Compute dUdt + dUdt = SD .dVdt. U + + DO a = 1, NNT + + Mat3 = MATMUL( SD % dNTdXt( :, :, a ), dCdU_ ) + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) + + DO b = 1, NNT + + RealVal2 = RealVal1 * SD % T( b ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + RealVal = RealVal2 * dUdt( p ) + + Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & + Obj % Mat4( r1 : r2, c1 : c2, a, b ) & + + RealVal * Mat2 + + END DO + + END DO + + END DO + + + END DO + + + END DO + + END DO + + CALL Obj % Mat2FromMat4( ) + + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) + + END SUBROUTINE getConvectiveMatrix_34 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part new file mode 100755 index 000000000..fe13f5936 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_35.part @@ -0,0 +1,163 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_35.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_35 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_35( Obj, U, dCdU, dCdU_Type ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, : ) + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, : ), dUdt( : ) + REAL( DFP ) :: RealVal, RealVal1, RealVal2 + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_35(), Flag-1", & + "STConvectiveMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + +#ifdef DEBUG_VER + IF( tSize .NE. NSD ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_35( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + + Obj % Mat4 = 0.0_DFP; + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + ! Compute dUdt + dUdt = SD .dVdt. U + + DO a = 1, NNT + + Mat3 = MATMUL( SD % dNTdXt( :, :, a ), dCdU ) + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) + + DO b = 1, NNT + + RealVal2 = RealVal1 * SD % T( b ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + RealVal = RealVal2 * dUdt( p ) + + Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & + Obj % Mat4( r1 : r2, c1 : c2, a, b ) & + + RealVal * Mat2 + + END DO + + END DO + + END DO + + + END DO + + + END DO + + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) + + END SUBROUTINE getConvectiveMatrix_35 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part new file mode 100755 index 000000000..1daff9d9b --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_36.part @@ -0,0 +1,148 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_36.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_36 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_36( Obj, U ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: U( :, :, : ) + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat3( :, : ), dUdt( : ) + REAL( DFP ) :: RealVal, RealVal1, RealVal2 + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_36(), Flag-1", & + "STConvectiveMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + ! Make Indx + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + + Obj % Mat4 = 0.0_DFP; + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + ! Compute dUdt + dUdt = SD .dVdt. U + + DO a = 1, NNT + + Mat3 = SD % dNTdXt( :, :, a ) + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + Mat2 = OUTERPROD( a = Mat3( :, q ), b = SD % N ) + + DO b = 1, NNT + + RealVal2 = RealVal1 * SD % T( b ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + RealVal = RealVal2 * dUdt( p ) + + Obj % Mat4( r1 : r2, c1 : c2, a, b ) = & + Obj % Mat4( r1 : r2, c1 : c2, a, b ) & + + RealVal * Mat2 + + END DO + + END DO + + END DO + + + END DO + + + END DO + + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( dUdt ) ) DEALLOCATE( dUdt ) + + END SUBROUTINE getConvectiveMatrix_36 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part new file mode 100755 index 000000000..bc337a38e --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_37.part @@ -0,0 +1,248 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_37.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_37 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_37( Obj, U, C, dCdU, dCdU_Type ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix +! 2. C is function of U +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, :, : ), C( :,:,:) + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & + Mat3( :, : ), Mat4(:,:), dUdX( :, : ), & + CBar( : ), dUdU( :, : ), cdUdX( : ) + REAL( DFP ) :: RealVal, RealVal1 + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + LOGICAL( LGT ) :: dCdU_Nodal + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_37(), Flag-1", & + "STConvectiveMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + a = SIZE( dCdU, 3 ) + b = SIZE( dCdU, 4 ) + +#ifdef DEBUG_VER + IF( a .NE. NNS .AND. a .NE. NIPS ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of third index of dCdU must be equal to the NNS or NIPS" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( b .NE. NNT .AND. b .NE. NIPT ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of fourth index of dCdU must be equal to the NNT or NIPT" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( tSize .NE. NSD ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + ! Check the type of dCdU + + SELECT CASE( TRIM( dCdU_Type ) ) + + CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & + "Space Nodal Values" ) + + dCdU_Nodal = .TRUE. + + CASE( "Integration", "Integration Points", & + "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) + + dCdU_Nodal = .FALSE. + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_37( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "dCdU_Type should be either NodalValues or QuadPoints" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + ALLOCATE( CBar( NSD ) ) + Obj % Mat4 = 0.0_DFP; + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + IF( dCdU_Nodal ) THEN + + CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ ) + +#ifdef DEBUG_VER + CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_37()", & + "CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, Val = dCdU_ )" ) +#endif + + ELSE + + dCdU_ = dCdU( :, :, IPS, IPT ) + + END IF + + CALL SD % getInterpolationOfVector( CBar, C ) +#ifdef DEBUG_VER + CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_37()", & + "CALL SD % getInterpolationOfVector( CBar, C )" ) +#endif + ! Compute dUdt + dUdX = SD .dVdXt. U + dUdU = MATMUL( dUdX, dCdU_ ) + + cdUdX = MATMUL( dUdX, CBar ) + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + Mat4 = OUTERPROD( a = dCdU_( :, q ), b = cdUdX ) & + + OUTERPROD( a = CBar, b = dUdU( :, q ) ) + + DO a = 1, NNT + + Mat3 = MATMUL( SD % dNTdXt( :, :, a ), Mat4 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Mat2 = OUTERPROD( a = Mat3( :, p ), b = SD % N ) + + DO b = 1, NNT + + RealVal = RealVal1 * SD % T( b ) + Obj % Mat4( r1:r2, c1:c2, a, b ) = Obj % Mat4( r1:r2, c1:c2, a, b ) & + + RealVal * Mat2 + + END DO + + END DO + + END DO + + END DO + + END DO + + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) + IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) + IF( ALLOCATED( cdUdX ) ) DEALLOCATE( cdUdX ) + IF( ALLOCATED( CBar ) ) DEALLOCATE( CBar ) + + END SUBROUTINE getConvectiveMatrix_37 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part new file mode 100755 index 000000000..5155f2bf6 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_38.part @@ -0,0 +1,231 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_38.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_38 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_38( Obj, U, C, dCdU, dCdU_Type ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix +! 2. C is function of U +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, : ), C( :,:,:) + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), & + Mat3( :, : ), Mat4(:,:), dUdX( :, : ), & + CBar( : ), dUdU( :, : ), cdUdX( : ) + REAL( DFP ) :: RealVal, RealVal1 + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + LOGICAL( LGT ) :: dCdU_Nodal + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_38(), Flag-1", & + "STConvectiveMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + a = SIZE( dCdU, 3 ) + +#ifdef DEBUG_VER + IF( a .NE. NNS .AND. a .NE. NIPS ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_38( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of third index of dCdU must be equal to the NNS or NIPS" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( tSize .NE. NSD ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_38( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + ! Check the type of dCdU + + SELECT CASE( TRIM( dCdU_Type ) ) + + CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & + "Space Nodal Values" ) + + dCdU_Nodal = .TRUE. + + CASE( "Integration", "Integration Points", & + "IntegrationPoints", "Quad Points", "QuadPoints", "Quad" ) + + dCdU_Nodal = .FALSE. +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_38( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "dCdU_Type should be either NodalValues or QuadPoints" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + ALLOCATE( CBar( NSD ) ) + Obj % Mat4 = 0.0_DFP; + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + IF( dCdU_Nodal ) THEN + + CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) +#ifdef DEBUG_VER + CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_38()", & + "CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ )" ) +#endif + ELSE + + dCdU_ = dCdU( :, :, IPS ) + + END IF + + CALL SD % getInterpolationOfVector( CBar, C ) +#ifdef DEBUG_VER + CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_38()", & + "CALL SD % getInterpolationOfVector( CBar, C )" ) +#endif + ! Compute dUdt + dUdX = SD .dVdXt. U + dUdU = MATMUL( dUdX, dCdU_ ) + + cdUdX = MATMUL( dUdX, CBar ) + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + Mat4 = OUTERPROD( a = dCdU_( :, q ), b = cdUdX ) & + + OUTERPROD( a = CBar, b = dUdU( :, q ) ) + + DO a = 1, NNT + + Mat3 = MATMUL( SD % dNTdXt( :, :, a ), Mat4 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Mat2 = OUTERPROD( a = Mat3( :, p ), b = SD % N ) + + DO b = 1, NNT + + RealVal = RealVal1 * SD % T( b ) + Obj % Mat4( r1:r2, c1:c2, a, b ) = Obj % Mat4( r1:r2, c1:c2, a, b ) & + + RealVal * Mat2 + + END DO + + END DO + + END DO + + END DO + + END DO + + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) + IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) + IF( ALLOCATED( cdUdX ) ) DEALLOCATE( cdUdX ) + IF( ALLOCATED( CBar ) ) DEALLOCATE( CBar ) + + END SUBROUTINE getConvectiveMatrix_38 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part new file mode 100755 index 000000000..eb0feadaf --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_39.part @@ -0,0 +1,177 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_39.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_39 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_39( Obj, U, C, dCdU, dCdU_Type ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix +! 2. C is function of U +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, : ), C( :,:,:) + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), & + Mat3( :, : ), Mat4(:,:), dUdX( :, : ), & + CBar( : ), dUdU( :, : ), cdUdX( : ) + REAL( DFP ) :: RealVal, RealVal1 + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_39(), Flag-1", & + "STConvectiveMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + +#ifdef DEBUG_VER + IF( tSize .NE. NSD ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_39( Obj, U, dCdU, dCdU_Type, MatrixName ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + ALLOCATE( CBar( NSD ) ) + Obj % Mat4 = 0.0_DFP; + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + CALL SD % getInterpolationOfVector( CBar, C ) + +#ifdef DEBUG_VER + CALL Check_Error( "STConvectiveMatrix_Class.f90>>getConvectiveMatrix_39()", & + "CALL SD % getInterpolationOfVector( CBar, C )" ) +#endif + ! Compute dUdt + dUdX = SD .dVdXt. U + dUdU = MATMUL( dUdX, dCdU ) + + cdUdX = MATMUL( dUdX, CBar ) + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + Mat4 = OUTERPROD( a = dCdU( :, q ), b = cdUdX ) & + + OUTERPROD( a = CBar, b = dUdU( :, q ) ) + + DO a = 1, NNT + + Mat3 = MATMUL( SD % dNTdXt( :, :, a ), Mat4 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Mat2 = OUTERPROD( a = Mat3( :, p ), b = SD % N ) + + DO b = 1, NNT + + RealVal = RealVal1 * SD % T( b ) + Obj % Mat4( r1:r2, c1:c2, a, b ) = Obj % Mat4( r1:r2, c1:c2, a, b ) & + + RealVal * Mat2 + + END DO + + END DO + + END DO + + END DO + + END DO + + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) + IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) + IF( ALLOCATED( cdUdX ) ) DEALLOCATE( cdUdX ) + IF( ALLOCATED( CBar ) ) DEALLOCATE( CBar ) + + END SUBROUTINE getConvectiveMatrix_39 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part new file mode 100755 index 000000000..6cb9840f7 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/ConvectiveMatrix_9.part @@ -0,0 +1,253 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ConvectiveMatrix_9.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STConvectiveMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getConvectiveMatrix_9 +!------------------------------------------------------------------------------ + + SUBROUTINE getConvectiveMatrix_9( Obj, Term1, Term2, Xtype ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - Returns mass matrix; C is a 2D array of STNodal Values +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, b, NSD + REAL( DFP ), ALLOCATABLE :: Mat3( :, :, : ) + REAL( DFP ) :: RealVal, RealVal1 + INTEGER( I4B ) :: XIndex + CLASS( STShapeData_ ), POINTER :: SD + + XIndex = 1 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9(), Flag-1", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPT = SIZE( Obj % SD, 2 ) + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + IF( NSD .LT. 1 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9(), Flag-1", & + "XType is 'dX' therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + IF( NSD .LT. 2 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "XType is 'dY' therefore NSD should be greater than 1" ) + Error_Flag = .TRUE. + RETURN + + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + IF( NSD .LT. 3 ) THEN + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "XType is Z therefore NSD should be greater than 2" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + END SELECT +#endif + + SELECT CASE( TRIM( ADJUSTL( XType ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + + XIndex = 1 + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + + XIndex = 2 + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + + XIndex = 3 + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + ALLOCATE( Mat3( NNS, NNS, NNT ) ) + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DO a = 1, NNT + + Mat3( :, :, a ) = OUTERPROD( a = SD % dNTdXt( :, XIndex, a ), b = SD % N ) + + END DO + + DO b = 1, NNT + + RealVal = RealVal1 * SD % T( b ) + Obj % Mat4( :, :, :, b ) = Obj % Mat4( :, :, :, b ) + & + Mat3 * RealVal + + END DO + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + + SELECT CASE( Term2 ) + + !( 0, 1 ) + CASE( 1 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + DO b = 1, NNT + + Mat3( :, :, b ) = OUTERPROD( a = SD % N, b = SD % dNTdXt( :, XIndex, b ) ) + + END DO + + DO a = 1, NNT + + RealVal = RealVal1 * SD % T( a ) + Obj % Mat4( :, :, a, : ) = Obj % Mat4( :, :, a, : ) + & + Mat3 * RealVal + + END DO + + END DO + + END DO +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getConvectiveMatrix_9()", & + "Unknown value of Term1; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + + END SUBROUTINE getConvectiveMatrix_9 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md new file mode 100755 index 000000000..44d3ddc23 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MdFiles/STConvectiveMatrix_Class.md @@ -0,0 +1,4393 @@ +# Space-Time Convective Matrix + +## ToDO + +## Stucture + +```fortran + TYPE, PUBLIC, EXTENDS( STElemShapeData_ ) :: STConvectiveMatrix_ + END TYPE +``` + +## Getting Started + +### Making the object + +```fortran +Obj = STConvectiveMatrix( Row, Col, NIPS, NIPT ) +Obj = STConvectiveMatrix( I1, I2, I3, I4, NIPS, NIPT ) +Obj = STConvectiveMatrix( ) +``` + +```fortran +Obj => STConvectiveMatrix_Pointer( Row, Col, NIPS, NIPT ) +Obj => STConvectiveMatrix_Pointer( I1, I2, I3, I4, NIPS, NIPT ) +Obj => STConvectiveMatrix_Pointer( ) +``` + +### Getting Convective Matrix + +- Currently, there are 39 interfaces for space-time convective matrix. + +- The generic subroutine for getting the convective matrix is `getConvectiveMatrix()`. A summary of different interfaces are given below. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2 ) +CALL Obj % getConvectiveMatrix( C, Term1, Term2, nCopy ) +CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType ) +CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType, nCopy ) +CALL Obj % getConvectiveMatrix( U, dCdU, dCdU_Type ) +CALL Obj % getConvectiveMatrix( U ) +CALL Obj % getConvectiveMatrix( U, C, dCdU, dCdU_Type ) +``` + +The description of each interface is provided below. + +#### Type-1 + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } +$$ + +The above two matrix can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2 ) +``` + +- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. + - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. + - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. + - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. + +#### Type-2 + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } {\delta _{pq}} +$$ + +The above two matrix can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2, nCopy ) +``` + +- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. + - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. + - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. + - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. + +#### Type-3 + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } +$$ + +In the above case if `C` is defined at integration points then we can use the following interface. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType ) +``` + +- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. +- `CType` can be `NodalValues` or `QuadPoints`. + +#### Type-4 + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}} \cdot {N^J}{T_b}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +M\left( {I,J,a,b} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } {\delta _{pq}} +$$ + +In the above case if `C` is defined at integration points then we can use the following interface. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType, nCopy ) +``` + +- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. +- `CType` can be `NodalValues` or `QuadPoints`. + +#### Type-5 + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +The above two matrices can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2 ) +``` + +- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. + - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. + - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. + - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. + +#### Type-6 + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +The above two matrices can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2, nCopy ) +``` + +- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. + - If `C` is rank-1, `C(:)`, then it denotes the convective velocity constant in both space and time. + - If `C` is rank-2, `C(:,:)`, then it denotes the space-nodal values of convective velocity. In this case velocity is constant in time domain. + - If `C` is rank-3, `C(:,:,:)`, then it denotes the space-time nodal values of convective velocity. In this case velocity changes with both space and time. + +#### Type-7 + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +In the above two matrices if `C` matrix is defined at integration points then we can use the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType ) +``` + +- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. + +#### Type-8 + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}} \cdot {c_j}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{c_j}\frac{{\partial {N^I}{T_a}}}{{\partial {x_j}}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +In the above two matrices if `C` matrix is defined at integration points then we can use the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( C, Term1, Term2, CType, nCopy ) +``` + +- In the above call `Term1` and `Term2` are characters. They can be `dt`, `dx, dy, dz`. +- `C` denotes the convective velocity. It can be Rank-1, Rank-2, Rank-3 array. +- `CType` can be `NodalValues` or `QuadPoints`. + +--- + +In case of the following terms in partial differntial equation + +$$ +\frac{{\partial {\bf{U}}}}{{\partial t}} + \frac{{\partial {\bf{f}}({\bf{U}})}}{{\partial x}} + \frac{{\partial {\bf{g}}({\bf{U}})}}{{\partial y}} + \frac{{\partial {\bf{h}}({\bf{U}})}}{{\partial z}} + \cdots +$$ + +following matrices may appear.The next few interfaces deals with these terms. + +#### Type-9 + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}} \cdot {N^J}{T_b}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}} \cdot {N^J}{T_b}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}} \cdot {N^J}{T_b}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] +$$ + +$$ +M\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] +$$ + +The above six matrices can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( Term1, Term2, XType ) +``` + +- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1 at the same time. +- `XType` can be `dx`, `dy`, and `dz`. + +#### Type-10 + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}} \cdot {N^J}{T_b}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}} \cdot {N^J}{T_b}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}} \cdot {N^J}{T_b}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +$$ +{M^{pq}}\left( {I,J,a,b} \right) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^J}{T_b}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] {\delta_{pq}} +$$ + +The above six matrices can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( Term1, Term2, XType, nCopy ) +``` + +- In the above call `Term1` and `Term2` can be 0 or 1. If it is 1 then it denotes the spatial gradient. Both `Term1` and `Term2` cannot be 0 or 1 at the same time. +- `XType` can be `dx`, `dy`, and `dz`. + +#### Type-11 + +$$ +M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] +$$ + +$$ +M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] +$$ + +$$ +M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] +$$ + +$$ +M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +$$ +M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +$$ +M(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +The above six matrices can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( Term1, Term2 ) +``` + +#### Type-12 + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial x}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial y}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial z}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right]{\delta _{pq}} +$$ + +The above six matrices can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( Term1, Term2, nCopy ) +``` + +--- + +Now we want to compute the space-time convective finite element matrix for following PDE. + +$$ +\frac{\partial \textbf{U}}{\partial t} + \mathbf{A_1} \frac{\partial \textbf{U}}{\partial x} + \mathbf{A_2} \frac{\partial \textbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial \textbf{U}}{\partial z} + \cdots +$$ + +#### Type-13 + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}{{[{{\bf{A}}_{\bf{1}}}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial x}}{N^J}{T_b}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial y}}{N^J}{T_b}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial z}}{N^J}{T_b}d\Omega dt} } } \right] +$$ + +The above matrices can be computed using the following subroutine. + +```fortran +CALL Obj % getConvectiveMatrix( A, Term1, Term2, Xtype, MultiVar ) +``` + +- In the above call `A` can be Rank-4 `A(:,:,:,:)`, Rank-3 `A(:,:,:)` or Rank-2 `A(:,:)` fortran array. +- `Term-1` and `Term-2` are integers which can be 1 or 0. +- `XType` is character and it can be `dx, dy, dz`. +- `MultiVar` has no effect it is just for interface uniqness. + +#### Type-14 + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}{{[{{\bf{A}}_{\bf{1}}}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial x}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial x}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial y}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial y}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}{{[{{\bf{A}}_2}]}_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial z}}d\Omega dt} } } \right] +$$ + +$$ +{M^{pq}}(I,J,a,b) = \left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{[{{\bf{A}}_{\bf{1}}}]}_{qp}}\frac{{\partial {N^I}{T_a}}}{{\partial z}}\frac{{\partial {N^J}{T_b}}}{{\partial t}}d\Omega dt} } } \right] +$$ + +The above matrices can be computed using the following subrouine. + +```fortran +CALL Obj % getConvectiveMatrix( A, Term1, Term2, MultiVar ) +``` + +- In above case `A` can be rank-4 `A(:,:,:,:)`, rank-3 `A( :, :, : )` or rank-2 `A(:,:)`. +- In the above case `Term1` and `Term2` are characters, and it can be `dt, dx, dy, dz`. + +--- + +```fortran +CALL Obj % getConvectiveMatrix( A, A0, Term1, Term2, MultiVar ) +``` + +In the above case `A` and `A0` can be Rank-4, Rank-3, Rank-2. Term1 and Term2 are `dt, dx, dy, dz`. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +## Code used for testing the methods + +```fortran +PROGRAM MAIN +USE GlobalData +USE IO +USE ElementData_Class +USE STElement_Class +USE STSlab_Classx +USE STElemShapeData_Class +USE STConvectiveMatrix_Class + +CLASS( STElement_ ), POINTER :: Elem +CLASS( ElementData_ ), POINTER :: Data +CLASS( STSlab_ ), POINTER :: STSlabs +CLASS( STElemShapeData_ ), POINTER :: STElemSD +INTEGER( I4B ) :: Int1, NIPS, NIPT, IPS, IPT, I, a, b, J, & + NNS, NSD, NNT, XiDimension + +INTEGER( I4B ), ALLOCATABLE :: Nptrs( : ), Mat4Shape( : ) + +REAL ( DFP ), ALLOCATABLE :: DummyMat2(:,:), TimeVec( : ), & +DummyVec( : ), DummyMat3( :, :, : ), DummyMat4( :, :, :, :) + +! MAKING SPACE-TIME ELEMENT + +NSD = 2; XiDimension = 2; NNS = 4; NNT = 2 +WRITE( *, * ) "Making Space-Time Element" +CALL BlankLines( ) + +Data => ElementData( ) +CALL Data % setNSD( NSD ) +CALL Data % setNNE( NNS ) +CALL Data % setNNS( NNS ) +CALL Data % setNNT( NNT ) +CALL Data % setMatType( 1 ) +CALL Data % setElemTopology( "Quad4") +CALL Data % setSpaceElemTopology( "Quad4" ) +CALL Data % setTimeElemTopology( "Line2" ) +CALL Data % setElemType( "SpaceTimeContinuum" ) +CALL Data % setXiDimension( 2 ) + +Nptrs = (/1,2,3,4/) + +Elem => STElement( Nptrs, Data ) +CALL BlankLines( ) +CALL Elem % Display( ) + + +! MAKING SPACE-TIME SLAB + +STSlabs => STSLAB( tSTSlabs = 2, tNodes = (/4,4/)) + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( 2, 4 ) ) + +DummyMat2 = ReSHAPE( [-1.0, -1.0, 1.0, & + -1.0, 1.0, 1.0, -1.0, 1.0],[2,4]) + +CALL STSlabs % addNodes( Val = DummyMat2, STSlabNum = 1, & +NodeNum =(/1,2,3,4/) ) + +CALL STSlabs % addNodes( Val = DummyMat2, STSlabNum = 2, & +NodeNum = [1,2,3,4] ) + +! MAKING ST-CONVECTIVE-MATRIX + +ALLOCATE( TimeVec( 2 ) ) +TimeVec = [-1.0, 1.0] + +ALLOCATE( STConvectiveMatrix_ :: STElemSD ) + +! Ask for NIPS and NIPT + +WRITE( *, "(A)" ) "TESTING SPACE-TIME CONVECTIVE MATRIX :: " +CALL BlankLines( ) + +WRITE( *, "(A)") "ENTER NIPS :: " +READ( *, * ) NIPS + +WRITE( *, "(A)") "ENTER NIPT :: " +READ( *, * ) NIPT + +!NIPS = 4; NIPT = 2 + +CALL Elem % getSTElemShapeData( STElemSD_Obj = STElemSD,& +TimeVec = TimeVec, NIPS = NIPS, NIPT = NIPT, STSlab_Obj = STSlabs ) +``` + +## Structure + +## Theory + +Now we want to compute the space-time convective finite element matrix for following PDE. + +$$\frac{\partial u_i}{\partial t} + c_k \frac{\partial u_i}{\partial x_k} + \cdots $$ + +We would like to compute the following matrices. + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +> These tasks are performed by following methods; `getConvectiveMatrix_1`, `getConvectiveMatrix_2`, `getConvectiveMatrix_3`, `getConvectiveMatrix_4`, `getConvectiveMatrix_5`, `getConvectiveMatrix_6`, `getConvectiveMatrix_7`, `getConvectiveMatrix_8`, and `getConvectiveMatrix_28`. + +Now we want to compute the space-time convective finite element matrix for following PDE. + +$$\frac{\partial \textbf{U}}{\partial t} + \frac{\partial \textbf{f(U)}}{\partial x} + \frac{\partial \textbf{g(U)}}{\partial y} + \frac{\partial \textbf{h(U)}}{\partial z} + \cdots $$ + +where $\textbf{U}, \textbf{f}, \textbf{g}, \textbf{h} \in R^m$. In this case we wish to compute the following matrices. + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}g_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}g_{iJ}$$ + + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}h_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}h_{iJ}$$ + +> These tasks are performed by following methods; `getConvectiveMatrix_9`, `getConvectiveMatrix_10`. + +Now we want to compute the space-time convective finite element matrix for following PDE. + +$$\frac{\partial u_i}{\partial t} + c_k \frac{\partial u_i}{\partial x_k} + \cdots $$ + +We would like to compute the following matrices. + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +> These tasks are performed by methods `getConvectiveMatrix_11()`, `getConvectiveMatrix_12()`, `getConvectiveMatrix_13()`, `getConvectiveMatrix_14()`, `getConvectiveMatrix_15()`, `getConvectiveMatrix_16()`, `getConvectiveMatrix_17()`, `getConvectiveMatrix_18()`, `getConvectiveMatrix_27()`, and `getConvectiveMatrix_28()`. + +Now we want to compute the space-time convective finite element matrix for following PDE. + +$$\frac{\partial \textbf{U}}{\partial t} + \frac{\partial \textbf{f(U)}}{\partial x} + \frac{\partial \textbf{g(U)}}{\partial y} + \frac{\partial \textbf{h(U)}}{\partial z} + \cdots $$ + +where $\textbf{U}, \textbf{f}, \textbf{g}, \textbf{h} \in R^m$. In this case we wish to compute the following matrices. + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{iJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{iJ}$$ + +> These tasks are performed by `getConvectiveMatrix_22()` and `getConvectiveMatrix_23()` + +Now we want to compute the space-time convective finite element matrix for following PDE. + +$$\frac{\partial \textbf{U}}{\partial t} + \mathbf{A_1} \frac{\partial \textbf{U}}{\partial x} + \mathbf{A_2} \frac{\partial \textbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial \textbf{U}}{\partial z} + \cdots$$ + +where $\textbf{U} \in R^m$, $\mathbf{A_i} \in R^{m \times m}$. In this case we wish to compute the following matrices. + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ + +The shape of each ${}^{4}M(:,:,a,b)$ is $(N_{NS} \times m, N_{NS} \times m)$. In this case there will be coupling between different components of $\mathbf{U}$. This coupling is due to $\mathbf{A_i}$. The structure of any of the above ${}^{4}\mathbf{M}$ is given as + +$${}^{4}\mathbf{M}(:,:,a,b) = +\begin{bmatrix} +\mathbf{M_{11}} & \cdots & \mathbf{M_{1m}} \\ +\vdots & \ddots & \vdots \\ +\mathbf{M_{m1}} & \cdots & \mathbf{M_{mm}} \\ +\end{bmatrix}$$ + +Each $\mathbf{M_{ij}}$ has shape $(N_{ns} \times N_{ns})$. + +> These tasks are performed by methods `getConvectiveMatrix_19` to `getConvectiveMatrix_21` + +Now we want to compute the space-time convective finite element matrix for following PDE. + +$$\frac{\partial \textbf{U}}{\partial t} + \mathbf{A_1} \frac{\partial \textbf{U}}{\partial x} + \mathbf{A_2} \frac{\partial \textbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial \textbf{U}}{\partial z} + \cdots $$ + +where $\textbf{U} \in R^m$, $\mathbf{A_i} \in R^{m \times m}$. In this case we wish to compute the following matrices. + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + +The shape of each ${}^{4}M(:,:,a,b)$ is $(N_{NS} \times m, N_{NS} \times m)$. In this case there will be coupling between different components of $\mathbf{U}$. This coupling is due to $\mathbf{A_i}$. The structure of any of the above ${}^{4}\mathbf{M}$ is given as + +$${}^{4}\mathbf{M}(:,:,a,b) = +\begin{bmatrix} +\mathbf{M_{11}} & \cdots & \mathbf{M_{1m}} \\ +\vdots & \ddots & \vdots \\ +\mathbf{M_{m1}} & \cdots & \mathbf{M_{mm}} \\ +\end{bmatrix}$$ + +Each $\mathbf{M_{ij}}$ has shape $(N_{ns} \times N_{ns})$. + +> These tasks are performed by methods `getConvectiveMatrix_24()`, `getConvectiveMatrix_25()`, `getConvectiveMatrix_26()`. + +Now consider the following terms in a pde. + +$$\mathbf{A_0} \frac{\partial U}{\partial t} + \mathbf{A_1} \frac{\partial U}{\partial x} + \mathbf{A_2} \frac{\partial \mathbf{U}}{\partial y} + \mathbf{A_3} \frac{\partial U}{\partial t} + \cdots$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + + + +## Methods + +### getConvectiveMatrix_1() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_1( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- `C(:,:,:)` is a three dimension array. It represents the space-time nodal values of convective velocity $c(x,t)$. The shape of `C` is `(NSD, NNS, NNT)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-node. The third index of `C` denotes the temporal node. In this case `C` varies with both space-time. + +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat3, Term1 = 0, Term2 = 1 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_1( C, Term1 = 0, Term2 = 1 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_1( C, Term1 = 0, Term2 = 1 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 +``` + +> As expected `NIPS = 4, NIPT = 1` is not sufficient for integration as the integrand is quadratic in time. Therefore we need atleast `NIPT = 2`. Note that this may be different incase mesh is moving, then additional time dependent terms may appear in the integrand. + +### getConvectiveMatrix_2() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_2( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- `C(:,:)` is a two dimension array. It represents the spatial nodal values of convective velocity $c(x,t)$. The shape of `C` is `(NSD, NNS)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-node. In this case, `C` varies in space but remains constant in time. + +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_1( C = DummyMat2, Term1 = 0, Term2 = 1 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 +``` + +### getConvectiveMatrix_29() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_29( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- `C(:)` is a vector array. It represents the spatial components of the convective velocity $c(x,t)$. The shape of `C` is `(NSD)`. The first index of `C` denotes the spatial coordinate. In this case, `C` remains constant in both space and time domain. + +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) + +DummyVec = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyVec, Term1 = 0, Term2 = 1 ) + +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_28( C = DummyMat2, Term1 = 0, Term2 = 1 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + ``` + +### getConvectiveMatrix_3() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_3( Obj, C, Term1, Term2, Ctype ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +- `C(:,:)` is a two dimension array. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the spatial nodal values, and the shape of `C` will be `(NSD, NNS)`. In this case first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. + - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at spatial-integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. + - In this method, `C` varies only in spatial dimension and remains constant in the temporal domain. +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = "Quad" ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 +``` + +### getConvectiveMatrix_4() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_4( Obj, C, Term1, Term2, Ctype ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +- `C(:,:)` is a two dimension array. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the space-time nodal values, and the shape of `C` will be `(NSD, NNS, NNT)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. The third index denotes the temporal-node. + - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at space-time integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS, NIPT)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. The third index of `C` denotes the temporal-integration point. + - In this method, `C` varies both in spatial and temporal dimension. +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, CType = "Quad" ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_3( C = DummyMat2, Term1 = 0, Term2 = 1, Ctype = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.3333333 0.000000 0.3333333 0.000000 +``` + +### getConvectiveMatrix_5() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_5( Obj, C, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy +``` + +DESCRIPTION + +- `C(:,:,:)` is a three dimension array. `C` denotes the space-time nodal values of _convective velocity_, and the shape of `C` will be `(NSD, NNS, NNT)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. The third index denotes the temporal nodes. In this method, `C` varies in both spatial and temporal dimension. +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. +- `nCopy` is the number of copies that should be placed on diagonals. + +> For more details see the notes. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) + +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_5( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 +``` + +### getConvectiveMatrix_6() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_6( Obj, C, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy +``` + +DESCRIPTION + +- `C(:,:,:)` is a two dimension array. `C` denotes the space-time nodal values of _convective velocity_, and the shape of `C` will be `(NSD, NNS)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. In this method, `C` varies in only in spatial dimension, and remains constant in temporal dimension. +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. +- `nCopy` is the number of copies that should be placed on diagonals. + +> For more details see the notes. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_6( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 +``` + +### getConvectiveMatrix_7() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_7( Obj, C, Term1, Term2, CType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +- `C(:,:)` is a two dimension array. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the spatial nodal values, and the shape of `C` will be `(NSD, NNS)`. In this case first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. + - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at spatial-integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. + - In this method, `C` varies only in spatial dimension and remains constant in the temporal domain. +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. +- `nCopy` is the number of copies that should be placed on diagonals. + +> For more details see the notes. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_7( C = DummyMat2, Term1 = 0, Term2 = 1, nCopy = 2, CType = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 +``` + +### getConvectiveMatrix_8() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_8( Obj, C, Term1, Term2, CType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +- `C(:,:)` is a two dimension array. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaceNodalValues]` then `C` denotes the space-time nodal values, and the shape of `C` will be `(NSD, NNS, NNT)`. In this case, first index of `C` denotes the spatial-coordinate. The second index denotes the spatial-node. The third index denotes the temporal-node. + - If `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of _convective velocity_ at space-time integration points(quadrature points). In this case, the shape of `C` is `(NSD, NIPS, NIPT)`. The first index of `C` denotes the spatial coordinate. The second index of `C` denotes the spatial-integration point. The third index of `C` denotes the temporal-integration point. + - In this method, `C` varies both in spatial and temporal dimension. +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. +- `nCopy` is the number of copies that should be placed on diagonals. + +> For more details see the notes. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} N^I T_a c_k \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \quad \int_{Q_n} c_k \frac{\partial N^I T_a}{\partial x_k} N^J T_b {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) + +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2, CType = "Quad" ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_8( C = DummyMat3, Term1 = 0, Term2 = 1, nCopy = 2, CType = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.000000 0.1666667 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.5555556E-01 0.1111111 0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.000000 0.1666667 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.4444444 0.1111111 0.2222222 0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.3333333 0.000000 0.3333333 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.4444444 0.1111111 0.2222222 0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.000000 0.3333333 0.000000 +``` + +### getConvectiveMatrix_9() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_9( Obj, Term1, Term2, Xtype ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType +``` + +DESCRIPTION + +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. +- `XType` is a string which denotes the spatial gradient type. + - If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it denotes the spatial gradient with respect to `x` coordinate. + - If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it denotes the spatial gradient with respect to `y` coordinate. + - If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it denotes the spatial gradient with respect to `z` coordinate. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}g_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}g_{iJ}$$ + + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}h_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}h_{iJ}$$ + + +TESTING + +```fortran +CALL STElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = "dx" ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_9( Term1 = 0, Term2 = 1, XType = 'dx' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 + +Mat4( :, :, 1, 2 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 1 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 2 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 +``` + +### getConvectiveMatrix_10() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_10( Obj, Term1, Term2, Xtype, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: XType +``` + +DESCRIPTION + +- `Term1` and `Term2` are integers that can take values 0 and 1. They represents the spatial derivative. If it is zero then this means no spatial derivative. If it is 1 then it means first order spatial derivative. +- `XType` is a string which denotes the spatial gradient type. + - If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it denotes the spatial gradient with respect to `x` coordinate. + - If `Xtype` is in the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it denotes the spatial gradient with respect to `y` coordinate. + - If `Xtype` is in the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it denotes the spatial gradient with respect to `z` coordinate. +- `nCopy` is the number of copies that should be placed on diagonals. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}g_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}g_{iJ}$$ + + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} N^I T_a \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}h_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a} U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}h_{iJ}$$ + +TESTING + +```fortran +CALL STElemSD % getConvectiveMatrix( Term1 = 0, Term2 = 1, XType = "X", nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_10( Term1 = 0, Term2 = 1, XType = 'X', nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 + +Mat4( :, :, 1, 2 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 1 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 2 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.2222222 0.2222222 0.1111111 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.1111111 0.2222222 -0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 0.2222222 0.1111111 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.1111111 0.2222222 -0.2222222 +``` + +### getConvectiveMatrix_11() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_11( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- Here `C(:,:,:)` is the 3D array which denotes the **space-time** nodal values of *convection velocity* $c(x,t)$. The shape of `C` must be `C(NSD, NNS, NNT)`. Where `NSD` is number of spatial dimentsion. `NNS` number of nodes in spatial-element. `NNT` is number of nodes in time-element. +- `Term1` and `Term2` are `string`, and should not be identical. They can take following values `[dx, dy, dz, dx1, dx2, dx3, x1, x2, x3, x, y, z] [dt]`. Thesevalues represent the time derivative or spatial derivatives. +- The first set denotes the gradient. `dt` denotes the time derivative. Symbolically following matrix is computed. + + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + + +TESTING + +For all the tests `C(:,:,:) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) + +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat3 ) + +CALL STElemSD % getConvectiveMatrix( Term1 = "dx", Term2 = "dt", C = DummyMat3 ) +``` + +**`NIPS = 1`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +```fortran +CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dx', Term2 = 'dt', C = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.2500000 0.2500000 0.2500000 0.2500000 + 0.000000 0.000000 0.000000 0.000000 + -0.2500000 -0.2500000 -0.2500000 -0.2500000 + 0.000000 0.000000 0.000000 0.000000 + +Mat4( :, :, 1, 2 ) + + -0.2500000 -0.2500000 -0.2500000 -0.2500000 + 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.2500000 0.2500000 0.2500000 + 0.000000 0.000000 0.000000 0.000000 + +Mat4( :, :, 2, 1 ) + + 0.2500000 0.2500000 0.2500000 0.2500000 + 0.000000 0.000000 0.000000 0.000000 + -0.2500000 -0.2500000 -0.2500000 -0.2500000 + 0.000000 0.000000 0.000000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.2500000 -0.2500000 -0.2500000 -0.2500000 + 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.2500000 0.2500000 0.2500000 + 0.000000 0.000000 0.000000 0.000000 + +``` + +> As expected the matrices are transpose of each other, i.e. ${}^{4}M(I,J,a,b) = {}^{4}M(J,I,b,a)$. Therefore, we will consider only the first one. + +**`NIPS = 1`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +> The matrix is rank deficient, and there is no effect of increasing the `NIPT`. Therefore, we must increase the `NIPS` + +**`NIPS = 4, NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +**`NIPS = 4, NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +> `NIPS = 4, NIPT = 1` results same as `NIPS = 4, NIPT = 2`, because in the present case mesh is not moving so the integrand is linear in time therefore we need only one integration point for exact integration. Note that this may vary when mesh is also moving. + +**`NIPS = 9, NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_11( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 9 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.8673617E-18 -0.2500000 0.8673617E-18 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 -0.8673617E-18 0.2500000 -0.8673617E-18 +``` + +Once again the results are the same. Therefore, lets stop here and move to next method. + +### getConvectiveMatrix_12() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_12( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- This subroutine perform the same task as `getConvectiveMatrix_11()` +- In this case, `C(:,:)` is a two-dimensional array. `C` denotes the spatial-nodal values of *convective velocity*. This case means that `convective velocity` does not change with time, however it changes with spatial coordiantes. The shape of `C` should be `(NSD, NNS)`. The first index denotes the spatial coordinate, and the second index denotes the spatial-node. + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx") +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt") +``` +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:,:) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat2 ) + +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_12( Term1 = 'dt', Term2 = 'dx', C = DummyMat2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + + _4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_27() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_27( Obj, C, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- This subroutine perform the same task as `getConvectiveMatrix_11()`. +- In this case `C(:)` is a one-dimensional array. `C` denotes the components of *convective velocity*. This case means that `convective velocity` is constant inside the element and does not change in space-time domain. The shape of `C` should be `(NSD)` + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx") +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt") +``` +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) + +DummyVec = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyVec ) + +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_27( Term1 = 'dt', Term2 = 'dx', C = DummyVec ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_13() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_13( Obj, C, Term1, Term2, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +- This subroutine perform the same task as `getConvectiveMatrix_11()`. +- In this case, `C(:, :)` is a 2-dimensional array. +- `Ctype` variable is an important parameter. If the value of `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, Space Nodal Values, SpaeNodalValues]` then this subroutine calls the `getConvectiveMatrix_12()`. +- If the value of `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of *convective velocity* at spatial-integration (quadrature) points. +- This case means that `convective velocity` is constant in time domain but varying in the space domain. The shape of `C` should be `(NSD, NIPS)` + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", CType = "Quad") +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", Ctype = "Quad") +``` +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:, :) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat2, CType = "Quad" ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_13( Term1 = 'dt', Term2 = 'dx', C = DummyMat2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_14() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_14( Obj, C, Term1, Term2, CType) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION + +This subroutien performs the same task as `getConvectiveMatrix_11()`, but in this case `C(:, :, :)` is a 3-dimensional array. `Ctype` variable is an important parameter. If the value of `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then this subroutine calls the `getConvectiveMatrix_11()`. If the value of `Ctype` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C` denotes the value of *convective velocity* at space-time integration (quadrature) points. This case means that `convective velocity` is changes in both space and time domain. The shape of `C` should be `(NSD, NIPS, NIPT)` + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", CType = "Quad") +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", Ctype = "Quad") +``` + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:, :, :) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) + +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat3, CType = "Quad" ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_14( Term1 = 'dt', Term2 = 'dx', C = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_15() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_15( Obj, C, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +Symbolically, this subroutine does the following, + +**`Term1 = dt, Term2 = dx`** + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k}{dQ} ({}^{b}u_{iJ})$$ + +**`Term1 = dx, Term2 = dt`** + +$${}^{4}M(I,J,a,b) = {}^{a}\delta u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} ({}^{b}u_{iJ})$$ + +Here `C(:, :, :)` is a 3-dimensional array that represents the space-time nodal values of *convective velocity* $c(x,t)$. The shape of `C` array should be `(NSD, NNS, NNT)`. `Term1` and `Term2` has same meaning as defined in above methods. `nCopy` here defines the number of unknowns i.e. $u_i, i=1 \cdots nCopy$. In this case, the shape of ${}^{4}M(:,:,:,:)$ will be $(nCopy \times NNS, nCopy \times NNS, NNT, NNT)$. The structure of ${}^{4}M(:,:,a,b)$ is shown below. + +$$ +{}^{4}M(:,:,a,b)=\begin{bmatrix} + \textbf{M} & \textbf{0} & \cdots & \textbf{0} \\ + \textbf{0} & \textbf{M} & \cdots & \textbf{0} \\ + \vdots & \vdots & \ddots & \vdots \\ + \textbf{0} & \textbf{0} & \cdots & \textbf{M} \\ +\end{bmatrix}$$ + +> Here all $\textbf{M}$ are identical, and has shape `(NNS, NNS)`. For more details see the notes. + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2 ) +``` + +TESTING + +For all the tests `C(:, :, :) = 1.0`. The following code is used for testing. + +```fortran + +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) + +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat3, nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_15( Term1 = 'dt', Term2 = 'dx', C = DummyMat3, nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_16() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_16( Obj, C, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +The subroutine performs the same task as `getConvectiveMatrix_15()`. However here `C(:,:)` is a two dimensional array, and represents the spatial-nodal values. In this case the *convective velocity* $c(x,t)$ does not chage with time, and change only in space domain. For details see the notes or `getConvectiveMatrix_15()`. The shape of `C(:,:)` should be `(NSD, NNS)` + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:, :) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyMat2, nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_16( Term1 = 'dt', Term2 = 'dx', C = DummyMat2, nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_28() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_28( Obj, C, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + INTEGER( I4B ), INTENT( IN ) :: nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +The subroutine performs the same task as `getConvectiveMatrix_15()`. However here `C(:)` is a vector in this case, and represents the component of convective velocity. In this case the *convective velocity* $c(x,t)$ does not chage in space and time domain. For details see the notes or `getConvectiveMatrix_15()`. The shape of `C(:,:)` should be `(NSD, NNS)` + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2 ) +``` +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:, :) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) + +DummyVec = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", C = DummyVec, nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_28( Term1 = 'dt', Term2 = 'dx', C = DummyVec, nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_17() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_17( Obj, C, Term1, Term2, CType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +DESCRIPTION + +The subroutine performs the same task as `getConvectiveMatrix_15()`. However, in this case, `C(:, :)` is a 2D array. If `Ctype` is `Nodal` then `C` denotes the spatial-nodal values and shape of `C` must be `(NSD, NNS)`. If `Ctype` is defined as `Quad` then `C(:,:)` represents the convective velocities at *spatial-integration* points. In this method, the *convective velocity* $c(x,t)$ does not chage in time, but varies only in space domain. The shape of `C` array should be `(NSD, NIPS)`. the second index of `C` denotes the spatial-integration points. For details see the notes or `getConvectiveMatrix_15()`. + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2, Ctype = 'Quad' ) +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2, Ctype = 'Quad' ) +``` +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:, :) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) + +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", & +C = DummyMat2, CType = "Quad", nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_17( Term1 = 'dt', Term2 = 'dx', C = DummyMat2, Ctype = 'Quad', nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_18() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_18( Obj, C, Term1, Term2, CType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2, CType + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +DESCRIPTION + +The subroutine performs the same task as `getConvectiveMatrix_15()`. However, in this case, `C(:, :, :)` is a 3D array. If `Ctype` is `Nodal` then `C` denotes the space-time nodal values and shape of `C` must be `(NSD, NNS, NNT)`. If `Ctype` is defined as `Quad` then `C(:,:,:)` represents the convective velocities at *space-time integration* points. In this method, the *convective velocity* $c(x,t)$ chages in both space and time domain. The shape of `C` array should be `(NSD, NIPS, NIPT)`. the second index of `C` denotes the spatial-integration points, and third index denotes the temporal integration points. For details see the notes or `getConvectiveMatrix_15()`. + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dt", Term2 = "dx", nCopy = 2, Ctype = 'Quad' ) +CALL Obj % getConvectiveMatrix( C = C, Term1 = "dx", Term2 = "dt", nCopy = 2, Ctype = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} \frac{ \partial N^I T_a}{\partial t} c_{k}^{h} \frac{\partial N^J T_b}{\partial x_k} {dQ} \quad {}^{b}u_{iJ}$$ + +$${}^{4}M(I,J,a,b) = \delta {}^{a}u_{iI} \int_{Q_n} c_{k}^{h} \frac{\partial N^I T_a}{\partial x_k} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}u_{iJ}$$ + +TESTING + +For all the tests `C(:, :, :) = 1.0`. The following code is used for testing. + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) + +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", & +C = DummyMat3, CType = "Quad", nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_18( Term1 = 'dt', Term2 = 'dx', C = DummyMat3, Ctype = 'Quad', nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 1, 2 ) + + 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.2500000 0.000000 -0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.3333333 -0.8333333E-01 -0.1666667 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 0.8333333E-01 -0.3333333 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.2500000 0.000000 -0.2500000 0.000000 + +Mat4( :, :, 2, 1 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + +Mat4( :, :, 2, 2 ) + + -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.2500000 0.000000 0.2500000 0.000000 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.3333333 0.8333333E-01 0.1666667 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 -0.8333333E-01 0.3333333 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.2500000 0.000000 0.2500000 0.000000 +``` + +### getConvectiveMatrix_22() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_22( Obj, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +- `Term1` and `Term2` are strings. They represent the time derivative and/or space-derivative. +- If `Term1` or `Term2` is in the set`[dt, Dt, dT, DT]` then it means the time derivative. +- If `Term1` or `Term2` is in the set `[dx, dx1, dX, x, X, x1, X1]` then it means deriavative with respect to `x` coordinate. +- If `Term1` or `Term2` is in the set `[dy, dx2, dY, y, Y, x2, X2]` then it means deriavative with respect to `y` coordinate. +- If `Term1` or `Term2` is in the set `[dz, dx3, dZ, z, Z, x3, X3]` then it means deriavative with respect to `z` coordinate. + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dx") +CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dy") +CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dz") +CALL Obj % getConvectiveMatrix( Term1 = "dx", Term2 = "dt") +CALL Obj % getConvectiveMatrix( Term1 = "dy", Term2 = "dt") +CALL Obj % getConvectiveMatrix( Term1 = "dz", Term2 = "dt") +``` + +> `Term1` and `Term2` should not be the same. Why?, because it does not make sense in case of convective terms. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{iJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{iJ}$$ + + +TESTING + +```fortran +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx") +CALL STElemSD % DISPLAYMATRIX4( ) + +CALL STElemSD % getConvectiveMatrix( Term1 = "dx", Term2 = "dt") +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 1`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + +Mat4( :, :, 1, 2 ) + + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + +Mat4( :, :, 2, 1 ) + + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + +Mat4( :, :, 2, 2 ) + + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 +``` + +```fortran +CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dx', Term2 = 'dt') + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1250000 0.1250000 0.1250000 0.1250000 + -0.1250000 -0.1250000 -0.1250000 -0.1250000 + -0.1250000 -0.1250000 -0.1250000 -0.1250000 + 0.1250000 0.1250000 0.1250000 0.1250000 + +Mat4( :, :, 1, 2 ) + + -0.1250000 -0.1250000 -0.1250000 -0.1250000 + 0.1250000 0.1250000 0.1250000 0.1250000 + 0.1250000 0.1250000 0.1250000 0.1250000 + -0.1250000 -0.1250000 -0.1250000 -0.1250000 + +Mat4( :, :, 2, 1 ) + + 0.1250000 0.1250000 0.1250000 0.1250000 + -0.1250000 -0.1250000 -0.1250000 -0.1250000 + -0.1250000 -0.1250000 -0.1250000 -0.1250000 + 0.1250000 0.1250000 0.1250000 0.1250000 + +Mat4( :, :, 2, 2 ) + + -0.1250000 -0.1250000 -0.1250000 -0.1250000 + 0.1250000 0.1250000 0.1250000 0.1250000 + 0.1250000 0.1250000 0.1250000 0.1250000 + -0.1250000 -0.1250000 -0.1250000 -0.1250000 +``` + +> As expected the matrices are transpose of each other, i.e. ${}^{4}M(I,J,a,b) = {}^{4}M(J,I,b,a)$. Therefore, we will consider only the first one. + +**`NIPS = 1`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + +Mat4( :, :, 1, 2 ) + + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + 0.1250000 -0.1250000 -0.1250000 0.1250000 + +Mat4( :, :, 2, 1 ) + + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + +Mat4( :, :, 2, 2 ) + + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 + -0.1250000 0.1250000 0.1250000 -0.1250000 +``` + +> The matrix is rank deficient, and there is no effect of increasing the `NIPT`. Therefore, we must increase the `NIPS` + +**`NIPS = 4, NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +**`NIPS = 4, NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +> `NIPS = 4, NIPT = 1` results same as `NIPS = 4, NIPT = 2`, because in the present case mesh is not moving so the integrand is linear in time therefore we need only one integration point for exact integration. Note that this may vary when mesh is also moving. + +**`NIPS = 9, NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_22( Term1 = 'dt', Term2 = 'dx') + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 9 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +Once again the results are the same. Therefore, lets stop here and move to next method. + +### getConvectiveMatrix_23() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_23( Obj, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +DESCRIPTION + +- This method will create the `nCopy` of the convective matrix defined in the previous routine. + +The following code snippet can be used to perform this task. + +```fortran +CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dy", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( Term1 = "dt", Term2 = "dz", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( Term1 = "dx", Term2 = "dt", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( Term1 = "dy", Term2 = "dt", nCopy = 2 ) +CALL Obj % getConvectiveMatrix( Term1 = "dz", Term2 = "dt", nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{iJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{iJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{iJ}$$ + + +TESTING + +```fortran +CALL STElemSD % getConvectiveMatrix( Term1 = "dt", Term2 = "dx", nCopy = 2 ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 1`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_23( Term1 = 'dt', Term2 = 'dx', nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.000000 0.000000 0.000000 0.000000 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 0.000000 0.000000 0.000000 0.000000 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + 0.000000 0.000000 0.000000 0.000000 -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +### getConvectiveMatrix_19() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_19( Obj, A, Term1, Term2, Xtype, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, :, : ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:,:,:)` is a four dimensional array. The shape of `A` is `(M,M,NIPS, NIPT)`. The thrid index denotes the spatial-integation point. The fourth index represent the temporal integration point. In this case, `A` changes with both space and time. +- `Term1` and `Term2` are integers, and can take values 0 or 1. If They are 1 then it means first order spatial derivative. If they are 0 then it means no spatial-derivative. +- `Xtype` is a string, which stands for the type of spatial gradient. If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) +ALLOCATE( DummyMat4( 1, 1, NIPS, NIPT ) ) +DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP; !DummyMat4( 2, 2, :, : ) = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( A = DummyMat4, Term1 = 0, Term2 = 1, XType = "dx", MultiVar = .TRUE. ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_19( A = DummyMat4, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 1, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_19( A = DummyMat4, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 + +Mat4( :, :, 1, 2 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 1 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 2 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 +``` + +**`NIPS = 9`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_19( A = DummyMat4, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 9 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 + +Mat4( :, :, 1, 2 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 1 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 2 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 + ``` + + > `NIPS = 4, NIPT = 1` is not sufficient, because the integrand is quadratic in time therefore, we need atleast `2` integration points in time domain. `NIPS = 4, NIPT = 2` will compute the integration accurately. Note that this case may change when mesh is moving. Because then additional time dependent terms may appear in the integrand. + +### getConvectiveMatrix_20() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_20( Obj, A, Term1, Term2, Xtype, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:,:)` is a three dimensional array. The shape of `A` is `(M,M,NIPS)`. The thrid index denotes the spatial-integation point. In this case, `A` changes with space, but it is constant in time. +- `Term1` and `Term2` are integers, and can take values 0 or 1. If They are 1 then it means first order spatial derivative. If they are 0 then it means no spatial-derivative. +- `Xtype` is a string, which stands for the type of spatial gradient. If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( 1, 1, NIPS ) ) +DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( A = DummyMat3, Term1 = 0, Term2 = 1, XType = "dx", MultiVar = .TRUE. ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_20( A = DummyMat3, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 + +Mat4( :, :, 1, 2 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 1 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 2 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 + ``` + +### getConvectiveMatrix_21() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_21( Obj, A, Term1, Term2, Xtype, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ) :: A + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: XType + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:)` is a two dimensional array. The shape of `A` is `(M,M)`. In this case, `A` does not change in space and time domain. +- `Term1` and `Term2` are integers, and can take values 0 or 1. If they are 1 then it means first order spatial derivative. If they are 0 then it means no spatial-derivative. +- `Xtype` is a string, which stands for the type of spatial gradient. If `Xtype` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} N^J T_b {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} N^J T_b {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} N^I T_a [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} N^J T_b {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( 1, 1 ) ) +DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( A = DummyMat2, Term1 = 0, Term2 = 1, XType = "dx", MultiVar = .TRUE. ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran +CALL STElemSD % getConvectiveMatrix_21( A = DummyMat2, Term1 = 0, Term2 = 1, Xtype = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 + +Mat4( :, :, 1, 2 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 1 ) + + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.1111111 0.1111111 0.5555556E-01 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + -0.5555556E-01 0.5555556E-01 0.1111111 -0.1111111 + +Mat4( :, :, 2, 2 ) + + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.2222222 0.2222222 0.1111111 -0.1111111 + -0.1111111 0.1111111 0.2222222 -0.2222222 + -0.1111111 0.1111111 0.2222222 -0.2222222 +``` + +### getConvectiveMatrix_24() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_24( Obj, A, Term1, Term2, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, :, : ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:, :, :)` is a four-dimensional array. The shape of `A` is `(M,M, NIPS, NIPT)`. The third index of `A` denotes the spatial-integration point. The fourth index of A denotes the temporal integration point. In this case, `A` changes in both space and time domain. +- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. + - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. + - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. + - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. + - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) +ALLOCATE( DummyMat4( 1, 1, NIPS, NIPT ) ) +DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( A = DummyMat4, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix_24( A = DummyMat4, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +**`NIPS = 4`, `NIPT = 2`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_24( A = DummyMat4, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + + > As expected `NIPS = 4, NIPT = 1` is enough for the present case, as the integrand is linear in time. However, this situation may change when the mesh is moving and new time dependent terms may appear. + +### getConvectiveMatrix_25() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_25( Obj, A, Term1, Term2, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:, :)` is a three-dimensional array. The shape of `A` is `(M,M, NIPS)`. The third index of `A` denotes the spatial-integration point. In this case, `A` changes in spatial domain but does not change with time. +- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. + - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. + - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. + - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. + - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( 1, 1, NIPS ) ) +DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( A = DummyMat3, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_25( A = DummyMat3, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +### getConvectiveMatrix_26() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_26( Obj, A, Term1, Term2, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ) :: A + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:)` is a two-dimensional array. The shape of `A` is `(M,M)`. In this case, `A` does not changes in space-time domain. +- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. + - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. + - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. + - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. + - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). + +SYMBOLIC CALCULATION + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{ij} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ji} \frac{\partial N^I T_a}{\partial x} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{ij} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ji} \frac{\partial N^I T_a}{\partial y} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} \frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{ij} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ji} \frac{\partial N^I T_a}{\partial z} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( 1, 1 ) ) +DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( A = DummyMat2, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) +CALL STElemSD % DISPLAYMATRIX4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran + +CALL STElemSD % getConvectiveMatrix_25( A = DummyMat2, Term1 = 'dt', Term2 = 'dx', MultiVar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +### getConvectiveMatrix_30() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_30( Obj, A, A0, Term1, Term2, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, :, : ) :: A, A0 + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:,:,:)` and `A0(:,:,:,:)` is a four-dimensional array. The shape of `A` and `A0` is `(M, M, NIPS, NIPT)`. The third index denotes the spatial-integration point and the fourth index denotes the temporal integration point. In this case, `A` and `A0` changes in space-time domain. +- `Term1` and `Term2` are strings, and denotes the either the temporal derivative or spatial derivative. + - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. + - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. + - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. + - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). + +SYMBOLIC CALCULATION + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat4 )) DEALLOCATE( DummyMat4 ) +ALLOCATE( DummyMat4( 1, 1, NIPS, NIPT ) ) +DummyMat4 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat4, & +A0 = DummyMat4, Multivar = .TRUE. ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat4, & +A0 = DummyMat4, Multivar = .TRUE. )" + +CALL STElemSD % DisplayMatrix4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat4, A0 = DummyMat4, Multivar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +### getConvectiveMatrix_31() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_31( Obj, A, A0, Term1, Term2, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ) :: A, A0 + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:,:)` and `A0(:,:,:)` is a three-dimensional array. The shape of `A` and `A0` is `(M, M, NIPS)`. The third index denotes the spatial-integration point. In this case, `A` and `A0` changes in spatial dimension but remain constant in time domain. +- `Term1` and `Term2` are strings, and denote either the temporal derivative or spatial derivative. + - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. + - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. + - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. + - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). + +SYMBOLIC CALCULATION + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 )) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( 1, 1, NIPS) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat3, & +A0 = DummyMat3, Multivar = .TRUE. ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat3, & +A0 = DummyMat3, Multivar = .TRUE. )" + +CALL STElemSD % DisplayMatrix4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat3, A0 = DummyMat3, Multivar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` + +### getConvectiveMatrix_32() + +INTERFACE + +```fortran + SUBROUTINE getConvectiveMatrix_31( Obj, A, A0, Term1, Term2, MultiVar ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STConvectiveMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ) :: A, A0 + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + LOGICAL( LGT ), INTENT( IN ) :: MultiVar +``` + +DESCRIPTION + +- `A(:,:)` and `A0(:,:)` is a two-dimensional array. The shape of `A` and `A0` is `(M, M)`. In this case, `A` and `A0` does not change in spatial and temporal domain. +- `Term1` and `Term2` are strings, and denote either the temporal derivative or spatial derivative. + - If `Term1` or `Term2` is in the set `[dx, dX, dx1, dX1, x, X, x1, X1]` then it means the spatial derivative is with respect to the `x`. + - If it belongs to the set `[dy, dY, dx2, dX2, y, Y, x2, X2]` then it means the spatial derivative is with respect to the `y`. + - If it belongs to the set `[dz, dZ, dx3, dX3, z, Z, x3, X3]` then it means the spatial derivative is with respect to the `z`. + - If it belongs to the set `[dt, Dt, DT, dT]` then it means temporal derivative. +- `MultiVar` is a logical parameter, which has no effect on the functionality of this method. However, this dummy argument is required to tell the compiler that this routine is different then other routine which involves _convection velocity_. + +> One of the `Term1` and `Term2` must be `dt`, Why? because it is convective matrix ;). + +SYMBOLIC CALCULATION + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki} \frac{\partial N^I T_a}{\partial t} [ \mathbf{A_1} ]_{kj} \frac{\partial N^J T_b}{\partial x} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_1} ]_{ki} \frac{\partial N^I T_a}{\partial x} [\mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}f_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_2}]_{kj} \frac{\partial N^J T_b}{\partial y} {dQ} \quad {}^{b}g_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_2}]_{ki} \frac{\partial N^I T_a}{\partial y} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}g_{jJ}$$ + + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [ \mathbf{A_0}]_{ki}\frac{\partial N^I T_a}{\partial t} [\mathbf{A_3}]_{kj} \frac{\partial N^J T_b}{\partial z} {dQ} \quad {}^{b}h_{jJ}$$ + +$${}^{4}M(I,J,a,b) = {}^{a}\delta U_{iI} \quad \int_{Q_n} [\mathbf{A_3}]_{ki} \frac{\partial N^I T_a}{\partial z} [ \mathbf{A_0}]_{kj} \frac{\partial N^J T_b}{\partial t} {dQ} \quad {}^{b}h_{jJ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 )) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( 1, 1) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat2, & +A0 = DummyMat2, Multivar = .TRUE. ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat2, & +A0 = DummyMat2, Multivar = .TRUE. )" + +CALL STElemSD % DisplayMatrix4( ) +``` + +**`NIPS = 4`, `NIPT = 1`** + +```fortran +CALL STElemSD % getConvectiveMatrix( term1 = 'dt', term2 = 'dx', A = DummyMat2, A0 = DummyMat2, Multivar = .TRUE. ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 1 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 1, 2 ) + + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.1666667 -0.1666667 -0.8333333E-01 0.8333333E-01 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + 0.8333333E-01 -0.8333333E-01 -0.1666667 0.1666667 + +Mat4( :, :, 2, 1 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + +Mat4( :, :, 2, 2 ) + + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.1666667 0.1666667 0.8333333E-01 -0.8333333E-01 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 + -0.8333333E-01 0.8333333E-01 0.1666667 -0.1666667 +``` diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part new file mode 100644 index 000000000..784a97c99 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/MethodNames.part @@ -0,0 +1,39 @@ +getConvectiveMatrix_1, & +getConvectiveMatrix_2, & +getConvectiveMatrix_3, & +getConvectiveMatrix_4, & +getConvectiveMatrix_5, & +getConvectiveMatrix_6, & +getConvectiveMatrix_7, & +getConvectiveMatrix_8, & +getConvectiveMatrix_9, & +getConvectiveMatrix_10, & +getConvectiveMatrix_11, & +getConvectiveMatrix_12, & +getConvectiveMatrix_13, & +getConvectiveMatrix_14, & +getConvectiveMatrix_15, & +getConvectiveMatrix_16, & +getConvectiveMatrix_17, & +getConvectiveMatrix_18, & +getConvectiveMatrix_19, & +getConvectiveMatrix_20, & +getConvectiveMatrix_21, & +getConvectiveMatrix_22, & +getConvectiveMatrix_23, & +getConvectiveMatrix_24, & +getConvectiveMatrix_25, & +getConvectiveMatrix_26, & +getConvectiveMatrix_27, & +getConvectiveMatrix_28, & +getConvectiveMatrix_29, & +getConvectiveMatrix_30, & +getConvectiveMatrix_31, & +getConvectiveMatrix_32, & +getConvectiveMatrix_33, & +getConvectiveMatrix_34, & +getConvectiveMatrix_35, & +getConvectiveMatrix_36, & +getConvectiveMatrix_37, & +getConvectiveMatrix_38, & +getConvectiveMatrix_39 diff --git a/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 new file mode 100755 index 000000000..702abc13c --- /dev/null +++ b/src/submodules/STConvectiveMatrix/STConvectiveMatrix-old/STConvectiveMatrix_Class.f90 @@ -0,0 +1,112 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: STConvectiveMatrix_Class.f90 +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - STElemShapeData_ Class is extended for computing the Convection or +! Advection matrix. +! +!============================================================================== + +!------------------------------------------------------------------------------ +! USE ASSOCIATION +!------------------------------------------------------------------------------ + + MODULE STConvectiveMatrix_Class + USE IO + USE GlobalData + USE ShapeData_Class + USE STShapeData_Class + USE STElemShapeData_Class + + PRIVATE + PUBLIC :: STConvectiveMatrix_, STConvectiveMatrix_Pointer, & + STConvectiveMatrix + +!------------------------------------------------------------------------------ +! STConvectiveMatrix_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( STElemShapeData_ ) :: STConvectiveMatrix_ + +!. . . . . . . . . . . . . . . . . . . . +! 1. - This class for computation of mass matrix +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + PROCEDURE, PUBLIC, PASS :: & +#include "./MethodNames.part" + + END TYPE STConvectiveMatrix_ + +!------------------------------------------------------------------------------ +! INTERFACES +!------------------------------------------------------------------------------ + + INTERFACE STConvectiveMatrix_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 + END INTERFACE + + INTERFACE STConvectiveMatrix + MODULE PROCEDURE Constructor1, Constructor2, Constructor3 + END INTERFACE + +!------------------------------------------------------------------------------ +! CONTAINS +!------------------------------------------------------------------------------ + + CONTAINS + +#include "./Constructor.part" +#include "./ConvectiveMatrix_1.part" +#include "./ConvectiveMatrix_2.part" +#include "./ConvectiveMatrix_3.part" +#include "./ConvectiveMatrix_4.part" +#include "./ConvectiveMatrix_5.part" +#include "./ConvectiveMatrix_6.part" +#include "./ConvectiveMatrix_7.part" +#include "./ConvectiveMatrix_8.part" +#include "./ConvectiveMatrix_9.part" +#include "./ConvectiveMatrix_10.part" +#include "./ConvectiveMatrix_11.part" +#include "./ConvectiveMatrix_12.part" +#include "./ConvectiveMatrix_13.part" +#include "./ConvectiveMatrix_14.part" +#include "./ConvectiveMatrix_15.part" +#include "./ConvectiveMatrix_16.part" +#include "./ConvectiveMatrix_17.part" +#include "./ConvectiveMatrix_18.part" +#include "./ConvectiveMatrix_19.part" +#include "./ConvectiveMatrix_20.part" +#include "./ConvectiveMatrix_21.part" +#include "./ConvectiveMatrix_22.part" +#include "./ConvectiveMatrix_23.part" +#include "./ConvectiveMatrix_24.part" +#include "./ConvectiveMatrix_25.part" +#include "./ConvectiveMatrix_26.part" +#include "./ConvectiveMatrix_27.part" +#include "./ConvectiveMatrix_28.part" +#include "./ConvectiveMatrix_29.part" +#include "./ConvectiveMatrix_30.part" +#include "./ConvectiveMatrix_31.part" +#include "./ConvectiveMatrix_32.part" +#include "./ConvectiveMatrix_33.part" +#include "./ConvectiveMatrix_34.part" +#include "./ConvectiveMatrix_35.part" +#include "./ConvectiveMatrix_36.part" +#include "./ConvectiveMatrix_37.part" +#include "./ConvectiveMatrix_38.part" +#include "./ConvectiveMatrix_39.part" + + END MODULE STConvectiveMatrix_Class + diff --git a/src/submodules/STConvectiveMatrix/src/STCM_1.inc b/src/submodules/STConvectiveMatrix/src/STCM_1.inc new file mode 100644 index 000000000..83bace805 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_1.inc @@ -0,0 +1,115 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_1a(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! Convective velocity, it can be + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_dx + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & test(ipt)%T, & + & p(:, :, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + !! + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, realval) +END SUBROUTINE STCM_1a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_1b(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + !! Convective velocity, it can be + INTEGER(I4B), INTENT(IN) :: term1 + !! del_dx + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & p(:, :, ips), & + & trial(ipt)%N(:, ips), & + & trial(ipt)%T) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + !! + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, realval) +END SUBROUTINE STCM_1b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_10.inc b/src/submodules/STConvectiveMatrix/src/STCM_10.inc new file mode 100644 index 000000000..7f4492b77 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_10.inc @@ -0,0 +1,125 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_10a(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! dx, dy, dz + INTEGER(I4B), INTENT(IN) :: term2 + !! dx, dy, dz + TYPE(FEVariable_), INTENT(IN) :: c + !! vector variable + TYPE(FEVariable_), INTENT(IN) :: rho + !! Scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! projecton-->trial + !! + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + !! + !! 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, val=rho, interpol=rhobar) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, :, term1, ips), & + & p(:, :, ips)) + END DO + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, p, rhobar) + !! +END SUBROUTINE STCM_10a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_10b(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! dx, dy, dz + INTEGER(I4B), INTENT(IN) :: term2 + !! dx, dy, dz + TYPE(FEVariable_), INTENT(IN) :: c + !! vector variable + TYPE(FEVariable_), INTENT(IN) :: rho + !! Scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! projecton --> "test" + !! + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + !! + !! 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, val=rho, interpol=rhobar) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & p(:, :, ips), & + & trial(ipt)%dNTdXt(:, :, term2, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, p, rhobar) +END SUBROUTINE STCM_10b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc new file mode 100644 index 000000000..afe947737 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_11.inc @@ -0,0 +1,215 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, or (del_x, del_y, del_z) + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar varible + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1, 2 + !! + !! projecton --> trial + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, nsd + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + !! + if( opt .eq. 1 ) then + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) & + & * outerprod(& + & test(ipt)%dNTdXt(:, a, ii, ips), & + & p(:,b,ips)) + END DO + END DO + END DO + END DO + !! + END DO + else + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) & + & * outerprod(& + & test(ipt)%dNTdXt(:, a, ii, ips), & + & p(:,b,ips)) + END DO + END DO + END DO + END DO + !! + END DO + end if + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, p, rhobar) + !! +END SUBROUTINE STCM_11a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, or (del_x, del_y, del_z) + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar varible + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1, 2 + !! + !! projecton-->test + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, nsd + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + !! + if( opt .eq. 1 ) then + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) & + & * outerprod( & + & p(:,a,ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + else + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) & + & * outerprod( & + & p(:,a,ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + end if + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, p, rhobar) + !! +END SUBROUTINE STCM_11b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_12.inc b/src/submodules/STConvectiveMatrix/src/STCM_12.inc new file mode 100644 index 000000000..ffb27a1d8 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_12.inc @@ -0,0 +1,122 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_12a(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! not used + INTEGER(I4B), INTENT(IN) :: term2 + !! not used + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar fe variable + TYPE(FEVariable_), INTENT(IN) :: c + !! vector fe variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! projecton --> trial + !! + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:,:) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! 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, val=rho, interpol=rhobar) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( test(ipt)%dNTdt(:,:,ips), p(:, :, ips)) + END DO + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, rhobar, realval) + !! +END SUBROUTINE STCM_12a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_12b(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! not used + INTEGER(I4B), INTENT(IN) :: term2 + !! not used + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar fe variable + TYPE(FEVariable_), INTENT(IN) :: c + !! vector fe variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! projecton --> test + !! + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:,:) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! 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, val=rho, interpol=rhobar) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( p(:, :, ips), trial(ipt)%dNTdt(:, :,ips)) + END DO + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if( present(opt) ) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, rhobar, realval) + !! +END SUBROUTINE STCM_12b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_13.inc b/src/submodules/STConvectiveMatrix/src/STCM_13.inc new file mode 100644 index 000000000..6e5dfa2e7 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_13.inc @@ -0,0 +1,272 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! STCM_13a +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_13a(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * test(ipt)%T(a) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar) + !! +END SUBROUTINE STCM_13a + +!---------------------------------------------------------------------------- +! STCM_13b +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_13b(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 2 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * test(ipt)%T(a) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar) + !! +END SUBROUTINE STCM_13b + +!---------------------------------------------------------------------------- +! STCM_13c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_13c(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * trial(ipt)%T(b) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%N(:, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar) + !! +END SUBROUTINE STCM_13c + +!---------------------------------------------------------------------------- +! STCM_13c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * trial(ipt)%T(b) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%N(:, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + 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 new file mode 100644 index 000000000..20a7621fe --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_14.inc @@ -0,0 +1,272 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! STCM_14a +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_14a(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar) + !! +END SUBROUTINE STCM_14a + +!---------------------------------------------------------------------------- +! STCM_14b +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_14b(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 2 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar) + !! +END SUBROUTINE STCM_14b + +!---------------------------------------------------------------------------- +! STCM_14c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_14c(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%dNTdt(:, b, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar) + !! +END SUBROUTINE STCM_14c + +!---------------------------------------------------------------------------- +! STCM_14c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdt(:, b, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + 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 new file mode 100644 index 000000000..6b86dda81 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_15.inc @@ -0,0 +1,292 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! STCM_15a +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_15a(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * test(ipt)%T(a) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar) + !! +END SUBROUTINE STCM_15a + +!---------------------------------------------------------------------------- +! STCM_15b +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_15b(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 2 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * test(ipt)%T(a) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar) + !! +END SUBROUTINE STCM_15b + +!---------------------------------------------------------------------------- +! STCM_15c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_15c(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * trial(ipt)%T(b) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%N(:, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar) + !! +END SUBROUTINE STCM_15c + +!---------------------------------------------------------------------------- +! STCM_15c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * trial(ipt)%T(b) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%N(:, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + 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 new file mode 100644 index 000000000..06ac2870a --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_16.inc @@ -0,0 +1,292 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! STCM_16a +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_16a(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar) + !! +END SUBROUTINE STCM_16a + +!---------------------------------------------------------------------------- +! STCM_16b +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_16b(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: rho + !! + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 2 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar) + !! +END SUBROUTINE STCM_16b + +!---------------------------------------------------------------------------- +! STCM_16c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_16c(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), INTENT(IN) :: rho + !! + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%dNTdt(:, b, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar) + !! +END SUBROUTINE STCM_16c + +!---------------------------------------------------------------------------- +! STCM_16c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), INTENT(IN) :: rho + !! + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdt(:, b, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + 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 new file mode 100644 index 000000000..3f52946a9 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_17.inc @@ -0,0 +1,311 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! STCM_17a +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! projecton test + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(ii, ips, ipt) & + & * outerprod( & + & p(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar, p) + !! +END SUBROUTINE STCM_17a + +!---------------------------------------------------------------------------- +! STCM_17b +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: rho + !! + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 2 + !! projecton test + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(jj, ips, ipt) & + & * outerprod( & + & p(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar, p) + !! +END SUBROUTINE STCM_17b + +!---------------------------------------------------------------------------- +! STCM_17c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), INTENT(IN) :: rho + !! + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 1 + !! projecton trial + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + !! + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(ii, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & p(:, b, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, vbar, rhobar, p) + !! +END SUBROUTINE STCM_17c + +!---------------------------------------------------------------------------- +! STCM_17c +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, & + & opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all, del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), INTENT(IN) :: rho + !! + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER(I4B), INTENT(IN) :: opt + !! opt = 2 + !! projecton trial + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii, jj + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, SIZE(m6, 4) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * vbar(jj, ips, ipt) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & p(:, b, ips)) + END DO + END DO + END DO + END DO + END DO + !! + END DO + !! + CALL Convert(from=m6, to=ans) + !! + 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 new file mode 100644 index 000000000..cb5ec15db --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_2.inc @@ -0,0 +1,134 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_2a(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + !! + !! main + !! + !! make c bar at ips and ipt + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + !! term1 .eq. del_none + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), test(ipt)%T, & + & trial(ipt)%dNTdXt(:, :, term2, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, cbar) + !! +END SUBROUTINE STCM_2a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_2b(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + !! + !! main + !! + !! make c bar at ips and ipt + !! + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + !! term2 .eq. del_none + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, :, term1, ips), & + & trial(ipt)%N(:, ips), trial(ipt)%T) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, cbar) + !! +END SUBROUTINE STCM_2b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_3.inc b/src/submodules/STConvectiveMatrix/src/STCM_3.inc new file mode 100644 index 000000000..7ff2ee6e7 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_3.inc @@ -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 + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_3a(ans, test, trial, term1, & + & term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar varible + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1 Mi1 + !! 2 M1i + !! + INTEGER(I4B) :: ips, ipt, a, b, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + !! make c bar at ips and ipt + !! + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + IF( opt .EQ. 1 ) THEN + !! + !! Mi1(:,:,:,:) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) * test(ipt)%T(a) & + & * outerprod( & + & test(ipt)%N(:,ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + !! + !! + !! + !! + ELSE + !! + !! M1i(:,:,:,:) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) * test(ipt)%T(a) & + & * outerprod( & + & test(ipt)%N(:,ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + END IF + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, cbar) + !! +END SUBROUTINE STCM_3a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_3b(ans, test, trial, term1, & + & term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all + INTEGER(I4B), INTENT(IN) :: term2 + !! none + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar varible + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1 --> Mi1 + !! 2 --> M1i + !! + INTEGER(I4B) :: ips, ipt, a, b, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + !! make c bar at ips and ipt + !! + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + !! + !! + IF( opt .EQ. 1 ) THEN + !! + !! Mi1 + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) * trial(ipt)%T(b) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%N(:,ips)) + END DO + END DO + END DO + END DO + !! + END DO + ELSE + !! + !! M1i + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) * trial(ipt)%T(b) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%N(:,ips)) + END DO + END DO + END DO + END DO + !! + END DO + END IF + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, cbar) + !! +END SUBROUTINE STCM_3b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_4.inc b/src/submodules/STConvectiveMatrix/src/STCM_4.inc new file mode 100644 index 000000000..24aeacc50 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_4.inc @@ -0,0 +1,128 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_4a(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x, del_y, del_z + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + !! + !! main + !! + !! make c bar at ips and ipt + !! + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:,:,ips), & + & trial(ipt)%dNTdXt(:, :, term2, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, cbar) + !! +END SUBROUTINE STCM_4a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_4b(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + !! + !! main + !! + !! make c bar at ips and ipt + !! + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, :, term1, ips), & + & trial(ipt)%dNTdt(:,:,ips) & + & ) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, cbar) + !! +END SUBROUTINE STCM_4b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_5.inc b/src/submodules/STConvectiveMatrix/src/STCM_5.inc new file mode 100644 index 000000000..6eb81e2d8 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_5.inc @@ -0,0 +1,217 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar varible + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1 + !! 2 + !! + !! Define internal variables + !! + !! + INTEGER(I4B) :: ips, ipt, a, b, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + !! make c bar at ips and ipt + !! + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + IF( opt .EQ. 1 ) THEN + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdT(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + !! + ELSE + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdT(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + !! + END IF + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, cbar) + !! +END SUBROUTINE STCM_5a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + TYPE(FEVariable_), OPTIONAL, INTENT(IN) :: c + !! Scalar variable + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1 + !! 2 + !! Define internal variables + INTEGER(I4B) :: ips, ipt, a, b, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + !! make c bar at ips and ipt + !! + IF (PRESENT(c)) THEN + CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + ELSE + CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) + cbar = 1.0_DFP + END IF + !! + IF( opt .EQ. 1 ) THEN + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdt(:, b, ips)) + END DO + END DO + END DO + END DO + !! + END DO + ELSE + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdt(:, b, ips)) + END DO + END DO + END DO + END DO + !! + END DO + END IF + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, cbar) + !! +END SUBROUTINE STCM_5b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_6.inc b/src/submodules/STConvectiveMatrix/src/STCM_6.inc new file mode 100644 index 000000000..700f7db54 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_6.inc @@ -0,0 +1,119 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_6a(ans, test, trial, term1, term2, c, projecton, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! dx, dy, dz + INTEGER(I4B), INTENT(IN) :: term2 + !! dx, dy, dz + TYPE(FEVariable_), INTENT(IN) :: c + !! vector variable + CHARACTER(LEN=*), INTENT(IN) :: projecton + !! trial + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, :, term1, ips), & + & p(:, :, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, p) + !! +END SUBROUTINE STCM_6a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_6b(ans, test, trial, term1, term2, c, projecton, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! dx, dy, dz + INTEGER(I4B), INTENT(IN) :: term2 + !! dx, dy, dz + TYPE(FEVariable_), INTENT(IN) :: c + !! vector variable + CHARACTER(LEN=*), INTENT(IN) :: projecton + !! test + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Define internal variables + INTEGER(I4B) :: ipt, ips + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & p(:, :, ips), & + & trial(ipt)%dNTdXt(:, :, term2, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! cleanup + DEALLOCATE (IaJb, realval, p) + !! +END SUBROUTINE STCM_6b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_7.inc b/src/submodules/STConvectiveMatrix/src/STCM_7.inc new file mode 100644 index 000000000..ac7faec21 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_7.inc @@ -0,0 +1,201 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! STCM_7a +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x_all + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all, del_x, del_y, del_z + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER( I4B ), INTENT( IN ) :: opt + !! 1 + !! 2 + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + if( opt .eq. 1 ) then + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & p(:, b, ips)) + END DO + END DO + END DO + END DO + !! + END DO + else + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & p(:, b, ips)) + END DO + END DO + END DO + END DO + !! + END DO + end if + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, p) +END SUBROUTINE STCM_7a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_x, del_y, del_z + INTEGER(I4B), INTENT(IN) :: term2 + !! del_x_all + TYPE(FEVariable_), INTENT(IN) :: c + !! vector varible + INTEGER( I4B ), INTENT( IN ) :: opt + !! + !! Define internal variables + !! + INTEGER(I4B) :: ips, ipt, a, b, ii + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + !! + !! main + !! + if( opt .eq. 1 ) then + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 3) + m6(:, :, ii, 1, a, b) = m6(:, :, ii, 1, a, b) & + & + realval(ips) & + & * outerprod( & + & p(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + else + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO ii = 1, SIZE(m6, 4) + m6(:, :, 1, ii, a, b) = m6(:, :, 1, ii, a, b) & + & + realval(ips) & + & * outerprod( & + & p(:, a, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + END DO + END DO + END DO + END DO + !! + END DO + end if + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, realval, p) +END SUBROUTINE STCM_7b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_8.inc b/src/submodules/STConvectiveMatrix/src/STCM_8.inc new file mode 100644 index 000000000..5aac726a1 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_8.inc @@ -0,0 +1,112 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_8a(ans, test, trial, c, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER( I4B ), INTENT( IN ) :: term1 + INTEGER( I4B ), INTENT( IN ) :: term2 + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! vector fe variable + !! term1 = del_t + !! term2 = del_x, del_y, del_z + !! projecton = trial + !! + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( test(ipt)%dNTdt(:,:,ips), p(:, :, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, realval) +END SUBROUTINE STCM_8a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_8b(ans, test, trial, c, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER( I4B ), INTENT( IN ) :: term1 + INTEGER( I4B ), INTENT( IN ) :: term2 + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! vector fe variable + !! term1 = del_x, del_y, del_z + !! term2 = del_t + !! projecton = test + !! + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + 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) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( p(:, :, ips), trial(ipt)%dNTdt(:, :,ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF( PRESENT(opt) ) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, realval) + !! +END SUBROUTINE STCM_8b \ No newline at end of file diff --git a/src/submodules/STConvectiveMatrix/src/STCM_9.inc b/src/submodules/STConvectiveMatrix/src/STCM_9.inc new file mode 100644 index 000000000..301ffc2e9 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STCM_9.inc @@ -0,0 +1,122 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_9a(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar variable + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_dx + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! ncopy + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: rhobar(:,:) + !! 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, val=rho, interpol=rhobar) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), test(ipt)%T, & + & p(:, :, ips)) + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, realval, rhobar) + !! +END SUBROUTINE STCM_9a + +!---------------------------------------------------------------------------- +! ConvectiveMatrix +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STCM_9b(ans, test, trial, term1, term2, rho, c, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + TYPE(FEVariable_), INTENT(IN) :: rho + !! scalar variable + TYPE(FEVariable_), INTENT(IN) :: c + !! convective velocity + INTEGER(I4B), INTENT(IN) :: term1 + !! del_dx + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + ! Define internal variables + INTEGER(I4B) :: ips, ipt + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: rhobar(:,:) + !! 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, val=rho, interpol=rhobar) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + !! + DO ips = 1, SIZE(realval) + !! + IaJb = IaJb + realval(ips) & + & * outerprod( & + & p(:, :, ips), & + & trial(ipt)%N(:, ips), trial(ipt)%T) + !! + END DO + !! + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (IaJb, p, realval, rhobar) + !! +END SUBROUTINE STCM_9b diff --git a/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 b/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 new file mode 100644 index 000000000..8d8a13284 --- /dev/null +++ b/src/submodules/STConvectiveMatrix/src/STConvectiveMatrix_Method@Methods.F90 @@ -0,0 +1,805 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(STConvectiveMatrix_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +#include "./STCM_1.inc" +#include "./STCM_2.inc" +#include "./STCM_3.inc" +#include "./STCM_4.inc" +#include "./STCM_5.inc" +#include "./STCM_6.inc" +#include "./STCM_7.inc" +#include "./STCM_8.inc" +#include "./STCM_9.inc" +#include "./STCM_10.inc" +#include "./STCM_11.inc" +#include "./STCM_12.inc" +#include "./STCM_13.inc" +#include "./STCM_14.inc" +#include "./STCM_15.inc" +#include "./STCM_16.inc" +#include "./STCM_17.inc" + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MakeDiagonalCopiesIJab(ans, ncopy) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: ncopy + !! + REAL(DFP), ALLOCATABLE :: m2(:, :), m4(:, :, :, :) + INTEGER(I4B) :: a, b + !! + m4 = ans + !! + CALL Reallocate(ans, & + & ncopy * SIZE(m4, 1), & + & ncopy * SIZE(m4, 2), & + & SIZE(m4, 3), & + & SIZE(m4, 4)) + !! + DO b = 1, SIZE(m4, 4) + DO a = 1, SIZE(m4, 3) + CALL MakeDiagonalCopies(from=m4(:, :, a, b), to=m2, ncopy=ncopy) + ans(:, :, a, b) = m2 + END DO + END DO + !! + DEALLOCATE (m2, m4) +END SUBROUTINE MakeDiagonalCopiesIJab + +!---------------------------------------------------------------------------- +! STConvectiveMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Mat4_STConvectiveMatrix_1 +!! +SELECT CASE (term1) +!! +!! +!! +!! +CASE (DEL_NONE) + !! + SELECT CASE( term2 ) + CASE( DEL_X_ALL ) + !! + !! term1 = none + !! term2 = del_x_all + !! + CALL STCM_3a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = none + !! term2 = dx/dy/dz + !! + CALL STCM_2a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + END SELECT +!! +!! +!! +!! +CASE (DEL_X, DEL_Y, DEL_Z) + !! + SELECT CASE( term2 ) + CASE( DEL_NONE ) + !! + !! term1 = dx/dy/dz + !! term2 = none + !! + CALL STCM_2b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = dx/dy/dz + !! term2 = DEL_X, DEL_Y, DEL_Z + !! TODO + !! + CASE( DEL_X_ALL ) + !! + !! term1 = dx/dy/dz + !! term2 = DEL_X_ALL + !! TODO + !! + CASE( DEL_T ) + !! + !! term1 = dx/dy/dz + !! term2 = dt + !! + CALL STCM_4b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + END SELECT +!! +!! +!! +!! +CASE (DEL_X_ALL) + !! + SELECT CASE( term2 ) + CASE( DEL_NONE ) + !! + !! term1 = del_x_all + !! term2 = del_none + !! + CALL STCM_3b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = del_x_all + !! term2 = del_x, del_y, del_z + !! TODO + !! + CASE( DEL_X_ALL ) + !! + !! term1 = del_x_all + !! term2 = del_x_all + !! TODO + !! + CASE( DEL_T ) + !! + !! term1 = del_x_all + !! term2 = del_t + !! + CALL STCM_5b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + END SELECT +!! +!! +!! +!! +CASE (DEL_T) + !! + SELECT CASE( term2 ) + !!case( DEL_NONE ) + !! + !! term1 = del_t + !! term2 = del_none + !! NOT POSSIBLE + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = del_t + !! term2 = del_x, del_y, del_z + CALL STCM_4a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + CASE( DEL_X_ALL ) + !! + !! term1 = del_t + !! term2 = del_x_all + !! + CALL STCM_5a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + !! case( DEL_T ) + !! + !! term1 = del_t + !! term2 = del_t + !! NOT POSSIBLE + !! + END SELECT +!! +END SELECT +!! +!! +!! +!! +END PROCEDURE Mat4_STConvectiveMatrix_1 + +!---------------------------------------------------------------------------- +! STConvectiveMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Mat4_STConvectiveMatrix_2 +!! +SELECT CASE (term1) +!! +!! +!! +!! +CASE (DEL_NONE) + !! + SELECT CASE( term2 ) + CASE( DEL_X_ALL ) + !! + !! term1 = none + !! term2 = del_x_all + !! + CALL STCM_3a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = none + !! term2 = dx/dy/dz + !! + CALL STCM_2a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + END SELECT +!! +!! +!! +!! +CASE (DEL_X, DEL_Y, DEL_Z) + !! + SELECT CASE( term2 ) + CASE( DEL_NONE ) + !! + !! term1 = dx/dy/dz + !! term2 = none + !! + CALL STCM_2b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = dx/dy/dz + !! term2 = DEL_X, DEL_Y, DEL_Z + !! TODO + !! + CASE( DEL_X_ALL ) + !! + !! term1 = dx/dy/dz + !! term2 = DEL_X_ALL + !! TODO + !! + CASE( DEL_T ) + !! + !! term1 = dx/dy/dz + !! term2 = dt + !! + CALL STCM_4b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + END SELECT +!! +!! +!! +!! +CASE (DEL_X_ALL) + !! + SELECT CASE( term2 ) + CASE( DEL_NONE ) + !! + !! term1 = del_x_all + !! term2 = del_none + !! + CALL STCM_3b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = del_x_all + !! term2 = del_x, del_y, del_z + !! TODO + !! + CASE( DEL_X_ALL ) + !! + !! term1 = del_x_all + !! term2 = del_x_all + !! TODO + !! + CASE( DEL_T ) + !! + !! term1 = del_x_all + !! term2 = del_t + !! + CALL STCM_5b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + END SELECT +!! +!! +!! +!! +CASE (DEL_T) + !! + SELECT CASE( term2 ) + !!case( DEL_NONE ) + !! + !! term1 = del_t + !! term2 = del_none + !! NOT POSSIBLE + !! + CASE( DEL_X, DEL_Y, DEL_Z ) + !! + !! term1 = del_t + !! term2 = del_x, del_y, del_z + !! + CALL STCM_4a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + CASE( DEL_X_ALL ) + !! + !! term1 = del_t + !! term2 = del_x_all + !! + CALL STCM_5a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + !! case( DEL_T ) + !! + !! term1 = del_t + !! term2 = del_t + !! NOT POSSIBLE + !! + END SELECT +!! +END SELECT +!! +!! +!! +!! +END PROCEDURE Mat4_STConvectiveMatrix_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Mat4_STConvectiveMatrix_3 + !! +SELECT CASE (term1) +CASE (DEL_NONE) + !! + !! term1 = none + !! term2 = del_x, del_y, del_z, del_x_all + !! projecton = trial (not needed) + !! + CALL STCM_1a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + !! + !! + !! +CASE (DEL_X, DEL_Y, DEL_Z) + !! + SELECT CASE (term2) + !! + CASE (DEL_NONE) + !! + !! term1 = dx/dy/dz + !! term2 = none + !! c = vector + !! + CALL STCM_1b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + CASE (DEL_t) + !! + !! term1 = dx/dy/dz + !! term2 = dt + !! c = vector + !! + CALL STCM_8b(ans=ans, test=test, trial=trial, c=c, term1=term1, & + & term2=term2, opt=opt) + !! + CASE (DEL_x, DEL_y, DEL_z) + !! + !! term1 = dx/dy/dz + !! term2 = dx/dy/dz + !! c = vector + !! + IF (TRIM(projecton) .EQ. "trial") THEN + CALL STCM_6a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, & + & projecton=projecton, opt=opt) + ELSE + CALL STCM_6b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, & + & projecton=projecton, opt=opt) + END IF + !! + CASE (DEL_x_all) + !! + !! term1 = dx/dy/dz + !! term2 = del_x_all + !! + CALL STCM_7b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=opt) + !! + END SELECT + !! + !! + !! + !! +CASE (DEL_X_ALL) + !! + SELECT CASE (term2) + CASE (DEL_NONE) + !! + !! term1 = del_x_all + !! term2 = del_none + !! + CALL STCM_1b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + CASE (DEL_T) + !! + !! term1 = del_x_all + !! term2 = del_t + !! + CALL STCM_8b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, c=c, opt=opt) + !! + CASE (DEL_X, DEL_Y, DEL_Z) + !! + !! term1 = del_x_all + !! term2 = del_x, del_y, del_z + !! + CALL STCM_7a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=opt) + !! + END SELECT + !! + !! + !! + !! +CASE (DEL_t) + !! + CALL STCM_8a(ans=ans, test=test, trial=trial, c=c, term1=term1, & + & term2=term2, opt=opt) + !! +END SELECT + !! + !! + !! + !! +END PROCEDURE Mat4_STConvectiveMatrix_3 + +!---------------------------------------------------------------------------- +! STConvectiveMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Mat4_STConvectiveMatrix_4 + !! +SELECT CASE (term1) +!! +!! +!! +!! +CASE (DEL_NONE) + !! + !! term1 = del_none + !! term2 = del_x/del_y/del_z + !! term2 = del_x_all + !! + CALL STCM_9a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) +!! +!! +!! +!! +CASE (DEL_X, DEL_Y, DEL_Z) + !! + SELECT CASE (term2) + !! + CASE (DEL_NONE) + !! + !! term1 = del_x, del_y, del_z + !! term2 = del_none + !! + CALL STCM_9b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) + !! + CASE (DEL_t) + !! + !! term1 = del_x, del_y, del_z + !! term2 = del_t + !! + CALL STCM_12b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) + !! + CASE (DEL_x, DEL_y, DEL_z) + !! + !! term1 = del_x, del_y, del_z + !! term2 = del_x, del_y, del_z + !! + IF (TRIM(projecton) .EQ. "trial") THEN + CALL STCM_10a(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, rho=c1, c=c2, opt=opt) + ELSE + CALL STCM_10b(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, rho=c1, c=c2, opt=opt) + END IF + !! + CASE (DEL_x_all) + !! + !! term1 = del_x, del_y, del_z + !! term2 = del_x_all + !! + CALL STCM_11b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) + !! + END SELECT + !! + !! + !! + !! +CASE (DEL_X_ALL) + !! + SELECT CASE (term2) + CASE (DEL_NONE) + !! + !! term1 = del_x_all + !! term2 = del_none + !! + CALL STCM_9b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) + !! + CASE (DEL_t) + !! + !! term1 = del_x_all + !! term2 = del_t + !! + CALL STCM_12b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) + !! + CASE (DEL_x, DEL_y, DEL_z) + !! + !! term1 = del_x_all + !! term2 = del_x, del_y, del_z + !! + CALL STCM_11a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) + !! + CASE (DEL_x_all) + !! + !! term1 = del_x_all + !! term2 = del_x_all + !! + IF (TRIM(projecton) .EQ. "trial") THEN + CALL STCM_11a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=del_x, rho=c1, c=c2, opt=opt) + ELSE + CALL STCM_11b(ans=ans, test=test, trial=trial, & + & term1=del_x, term2=term2, rho=c1, c=c2, opt=opt) + END IF + !! + END SELECT + !! + !! + !! + !! +CASE (DEL_t) + !! + !! term1 = del_t + !! term2 = del_x, del_y, del_z + !! term2 = del_x_all + !! + CALL STCM_12a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=opt) + !! +END SELECT + !! +END PROCEDURE Mat4_STConvectiveMatrix_4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Mat4_STConvectiveMatrix_5 +SELECT CASE (term1) +CASE (del_none) + !! + !! term1 = del_none + !! term2 = del_x,y,z,x_all + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_13a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=1) + ELSE + CALL STCM_13b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=2) + END IF + !! +CASE (del_t) + !! + !! term1 = del_t + !! term2 = del_x,y,z,x_all + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_14a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=1) + ELSE + CALL STCM_14b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=2) + END IF + !! +CASE DEFAULT + !! + SELECT CASE (term2) + CASE (del_none) + !! + !! term2 = del_x,y,z,x_all + !! term1 = del_none + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_13c(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=1) + ELSE + CALL STCM_13d(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=2) + END IF + !! + CASE (del_t) + !! + !! term2 = del_x,y,z,x_all + !! term1 = del_t + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_14c(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=1) + ELSE + CALL STCM_14d(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, c=c, opt=2) + END IF + !! + END SELECT +END SELECT +!! +END PROCEDURE Mat4_STConvectiveMatrix_5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Mat4_STConvectiveMatrix_6 + !! + SELECT CASE (term1) + !! + !! + !! + !! + CASE (del_none) + !! + SELECT CASE( term2 ) + !! + CASE( del_none ) + !! + !! not possible + !! + CASE( del_t ) + !! + !! not possible + !! + CASE( del_x, del_y, del_z ) + !! + !! term1 = del_none + !! term2 = del_x, del_y, del_z, del_x_all + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_15a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=1) + ELSE + CALL STCM_15b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=2) + END IF + !! + END SELECT + !! + !! + !! + !! + CASE (del_t) + !! + SELECT CASE( term2 ) + !! + CASE( del_none ) + !! + !! not possible + !! + CASE( del_t ) + !! + !! not possible + !! + CASE( del_x, del_y, del_z ) + !! + !! term1 = del_t + !! term2 = del_x, del_y, del_z + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_16a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=1) + ELSE + CALL STCM_16b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=2) + END IF + !! + END SELECT + !! + !! + !! + !! + CASE (del_x, del_y, del_z) + !! + SELECT CASE ( term2 ) + !! + CASE( del_none ) + !! + !! term1 = del_x, del_y, del_z + !! term2 = del_none + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_15c(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=1) + ELSE + CALL STCM_15d(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=2) + END IF + !! + CASE( del_t ) + !! + !! term1 = del_x, del_y, del_z, del_x_all + !! term2 = del_t + !! + IF (opt(1) .EQ. 1) THEN + CALL STCM_16c(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=1) + ELSE + CALL STCM_16d(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=2) + END IF + !! + !! + CASE( del_x, del_y, del_z ) + !! + !! term1 = del_x, del_y, del_z, del_x_all + !! term2 = del_x, del_y, del_z, del_x_all + !! + IF( TRIM(projecton) .EQ. 'test' ) THEN + IF (opt(1) .EQ. 1) THEN + CALL STCM_17a(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=1) + ELSE + CALL STCM_17b(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=2) + END IF + ELSE + IF (opt(1) .EQ. 1) THEN + CALL STCM_17c(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=1) + ELSE + CALL STCM_17d(ans=ans, test=test, trial=trial, & + & term1=term1, term2=term2, rho=c1, c=c2, opt=2) + END IF + END IF + !! + END SELECT + !! + END SELECT + !! +END PROCEDURE Mat4_STConvectiveMatrix_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/STDiffusionMatrix/CMakeLists.txt b/src/submodules/STDiffusionMatrix/CMakeLists.txt new file mode 100644 index 000000000..cd489b9cd --- /dev/null +++ b/src/submodules/STDiffusionMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/STDiffusionMatrix_Method@Methods.F90 + ) diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part new file mode 100755 index 000000000..47a48a34e --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/Constructor.part @@ -0,0 +1,138 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( Row, Col ), Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STDiffusionMatrix_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor_1 ) + ALLOCATE( Constructor_1 % Mat2( row, col ) ) + Constructor_1 % Mat2 = 0.0_DFP + CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat4( I1, I2, I3, I4 ), Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STDiffusionMatrix_ ), POINTER :: Constructor_2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor_2 ) + ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) + Constructor_2 % Mat4 = 0.0_DFP + CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty contructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STDiffusionMatrix_ ), POINTER :: Constructor_3 + ALLOCATE( Constructor_3 ) + + END FUNCTION Constructor_3 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( Row, Col ), Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STDiffusionMatrix_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor1 % Mat2( row, col ) ) + Constructor1 % Mat2 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat4( I1, I2, I3, I4 ), Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STDiffusionMatrix_ ) :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) + Constructor2 % Mat4 = 0.0_DFP + CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty contructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STDiffusionMatrix_ ) :: Constructor3 + + END FUNCTION Constructor3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part new file mode 100755 index 000000000..70c205a44 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_1.part @@ -0,0 +1,93 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_1.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! Ver-2 => 3Loops +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_1 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_1( Obj ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. SpaceTime Diffusion matrix + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, & + NSD, i + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + REAL( DFP ), ALLOCATABLE :: DummyVec1( : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_1(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS * NNT ) ) + Obj % Mat2 = 0.0_DFP + + ALLOCATE( DummyVec1( NNS*NNT ) ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + DO i = 1, NSD + DummyVec1 = RESHAPE( SD % dNTdXt( :, i, : ), (/NNS*NNT/) ) + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & + & + OUTERPROD( a = DummyVec1*RealVal, b = DummyVec1 ) + END DO + END DO + END DO + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + NULLIFY( SD ) + DEALLOCATE( DummyVec1 ) + +END SUBROUTINE getDiffusionMatrix_1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part new file mode 100755 index 000000000..d0e29605f --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_10.part @@ -0,0 +1,175 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_10.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_10 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_10( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns diffusion matrix + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + + LOGICAL( LGT ) :: isC1Nodal, isC2Nodal + + isC1Nodal = .TRUE. + isC2Nodal = .TRUE. + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_10(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_10()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_10()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_10()", & + "The SIZE(C1, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_10()", & + "The SIZE(C2, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC1Nodal = .FALSE. + END SELECT + + SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC2Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD ( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + ! Make c1dNTdXt based on the CType + IF( isC1Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + SpaceNodalValues = C1 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + VectorValues = C1( :, IPS ) ) + END IF + + IF( isC2Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + SpaceNodalValues = C2 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + VectorValues = C2( :, IPS ) ) + END IF + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_10 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part new file mode 100755 index 000000000..e78c2f728 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_11.part @@ -0,0 +1,126 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_11.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_11 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_11( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1, c2 ( : ) + ! 2. c1Type, c2Type "NodalValues" "QuapPoints" + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_11(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_11()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_11()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD ( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + ! Make c1dNTdXt based on the CType + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1 ) + + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2 ) + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_11 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part new file mode 100755 index 000000000..7c6714f6c --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_12.part @@ -0,0 +1,187 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_12.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_12 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1( :, :, : ) + ! 2. c2( :, : ) + ! 3. c1Type, c2Type "NodalValues", "QuadPoints" + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isC1Nodal, isC2Nodal + + isC1Nodal = .TRUE. + isC2Nodal = .TRUE. + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_12(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_12()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_12()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_12()", & + "The SIZE(C1, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 3 ) .NE. NIPT .AND. SIZE( C1, 3 ) .NE. NNT ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_12()", & + "The SIZE(C1, 3) should be equal to either NIPT, & + & or NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_12()", & + "The SIZE(C2, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC1Nodal = .FALSE. + END SELECT + + SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC2Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + IF( isC1Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & STNodalValues = C1 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1( :, IPS, IPT ) ) + END IF + + IF( isC2Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & SpaceNodalValues = C2 ) + ELSE + CALL Obj % SD( IPS, IPT ) % & + & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2( :, IPS ) ) + END IF + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_12 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part new file mode 100755 index 000000000..a3bea5229 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_13.part @@ -0,0 +1,183 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_13.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_13 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_13( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1( :, : ), c2( :, :, : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isC1Nodal, isC2Nodal + + isC1Nodal = .TRUE. + isC2Nodal = .TRUE. + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_13(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_13()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_13()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_13()", & + "The SIZE(C1, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_13()", & + "The SIZE(C2, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 3 ) .NE. NIPT .AND. SIZE( C2, 3 ) .NE. NNT ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_13()", & + "The SIZE(C2, 3) should be equal to either NIPT, & + & or NNT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC1Nodal = .FALSE. + END SELECT + + SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC2Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + IF( isC1Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & SpaceNodalValues = C1 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1( :, IPS ) ) + END IF + + IF( isC2Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & STNodalValues = C2 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2( :, IPS, IPT ) ) + END IF + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_13 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part new file mode 100755 index 000000000..20716262b --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_14.part @@ -0,0 +1,161 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_14.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_14 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_14( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1( :, :, : ), c2( : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isC1Nodal + + isC1Nodal = .TRUE. + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_14(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_14()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_14()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_14()", & + "The SIZE(C1, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 3 ) .NE. NIPT .AND. SIZE( C1, 3 ) .NE. NNT ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_14()", & + "The SIZE(C1, 3) should be equal to either NIPT, & + & or NNT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + & "Integration", "Integration Points", & + & "IntegrationPoints" ) + isC1Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + IF( isC1Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & STNodalValues = C1 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1( :, IPS, IPT ) ) + END IF + + CALL Obj % SD( IPS, IPT ) % & + & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2 ) + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_14 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part new file mode 100755 index 000000000..3ee53dd5b --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_15.part @@ -0,0 +1,160 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_15.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_15 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_15( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1( : ), c2( :, :, : ) + !. . . . . . . . . . . . . . . . . . . .-- + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isC2Nodal + + isC2Nodal = .TRUE. + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_15(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_15()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_15()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_15()", & + "The SIZE(C2, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 3 ) .NE. NIPT .AND. SIZE( C2, 3 ) .NE. NNT ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_15()", & + "The SIZE(C2, 3) should be equal to either NIPT, & + & or NNT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC2Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1 ) + + IF( isC2Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & STNodalValues = C2 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2( :, IPS, IPT ) ) + END IF + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_15 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part new file mode 100755 index 000000000..3a734cb40 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_16.part @@ -0,0 +1,152 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_16.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_16 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_16( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1( :, : ), c2( : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isC1Nodal + + isC1Nodal = .TRUE. + +#ifdef DEBUG_VER + ! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_16(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_16()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_16()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_16()", & + "The SIZE(C1, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC1Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + IF( isC1Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & SpaceNodalValues = C1 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1( :, IPS ) ) + END IF + + CALL Obj % SD( IPS, IPT ) % & + & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2 ) + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_16 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part new file mode 100755 index 000000000..a3dc066e9 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_17.part @@ -0,0 +1,150 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_17.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_17 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_17( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1( : ), c2( :, : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isC2Nodal + + isC2Nodal = .TRUE. + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_17(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_17()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_17()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STConvectiveMatrix_Class.f90", & + "getDiffusionMatrix_17()", & + "The SIZE(C2, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC2Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1 ) + + IF( isC2Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & SpaceNodalValues = C2 ) + ELSE + CALL Obj % SD( IPS, IPT ) % & + & getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2( :, IPS ) ) + END IF + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) +END SUBROUTINE getDiffusionMatrix_17 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part new file mode 100755 index 000000000..16a02d0c4 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_18.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_18.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_18 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_18( Obj, c1, c2, c1Type, c2Type, nCopy ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1( :, :, : ), c2( :, :, : ) + ! 2. c1Type, c2Type "NodalValues", "QuadPoints" + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + +END SUBROUTINE getDiffusionMatrix_18 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part new file mode 100755 index 000000000..0a707d1b8 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_19.part @@ -0,0 +1,52 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_19.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_19 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_19( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c1( :, : ), c2( :, : ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_19 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part new file mode 100755 index 000000000..9234e6212 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_2.part @@ -0,0 +1,50 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_2.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_2 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_2( Obj, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns mass matrix; C is a 2D array of STNodal Values +!. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part new file mode 100755 index 000000000..f69aa9d5e --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_20.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_20.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_20 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_20( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c1( : ), c2( : ) +!. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_20 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part new file mode 100755 index 000000000..b03a273e6 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_21.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_21.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_21 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_21( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c1( :, :, : ), c2( :, : ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_21 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part new file mode 100755 index 000000000..7f0b08b6d --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_22.part @@ -0,0 +1,53 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_22.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_22 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_22( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c2( :, :, : ), c1( :, : ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_22 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part new file mode 100755 index 000000000..5640683c6 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_23.part @@ -0,0 +1,54 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_23.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_23 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_23( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c1( :, :, : ) +! 2. c2( : ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_23 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part new file mode 100755 index 000000000..5f7940012 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_24.part @@ -0,0 +1,55 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_24.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_24 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_24( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c1( : ) +! 2. c2( :, :, : ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_24 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part new file mode 100755 index 000000000..619d340e4 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_25.part @@ -0,0 +1,54 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_25.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_25 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_25( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c1( :, : ) +! 2. c2( : ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_25 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part new file mode 100755 index 000000000..79e86275e --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_26.part @@ -0,0 +1,54 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_26.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_26 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_26( Obj, c1, c2, c1Type, c2Type, nCopy ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. c1( : ) +! 2. c2( :, : ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( c1 = c1, c2 = c2, & + & c1Type = c1Type, c2Type = c2Type ) + CALL Obj % MakeDiagonalCopies( nCopy ) + + END SUBROUTINE getDiffusionMatrix_26 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part new file mode 100755 index 000000000..b5043456f --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_27.part @@ -0,0 +1,234 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_27.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_27 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_27( Obj, K, Term1, Term2 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, :, : ) + ! 2. Term1, Term2 {dx, dy, dz} + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ) :: RealVal1, RealVal + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + INTEGER( I4B ) :: XIndx1, XIndx2 + + CLASS( STShapeData_ ), POINTER :: SD + + XIndx1 = 1 + XIndx2 = 1 + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( K, 3 ) .NE. NIPS .OR. SIZE( K, 4 ) .NE. NIPT ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27(), Flag-2", & + "The SIZE( K, 3 ) should be NIPS, & + & SIZE( K, 4 ) should be NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27(), Flag-3", & + "The size of first and second dimension of K must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( K, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27()", & + "Term1 is 'x' or 'dx' therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27()", & + "Term1 is 'dy' or 'y', & + & therefore NSD should be greater than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27()", & + "Term1 is 'dz' or 'z', therefore, & + & NSD should be greater than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27()", & + "Term2 is 'x' or 'dx' therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27()", & + "Term2 is 'dy' or 'y', & + & therefore NSD should be greater than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_27()", & + "Term2 is 'dz' or 'z', therefore, & + & NSD should be greater than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + END SELECT +#endif + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + XIndx1 = 1 + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + XIndx1 = 2 + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + XIndx1 = 3 + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + XIndx2 = 1 + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + XIndx2 = 2 + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + XIndx2 = 3 + END SELECT + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + DO b = 1, NNT + DO aa = 1, NNT + Mat4( :, :, aa, b ) = & + & OUTERPROD( a = SD % dNTdXt( :, XIndx1, aa ), & + & b = SD % dNTdXt( :, XIndx2, b ) ) + END DO + END DO + + Mat2 = K( :, :, IPS, IPT ) + + DO j = 1, M + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + DO i = 1, M + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + RealVal = Mat2( i, j ) * RealVal1 + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) + Mat4*RealVal + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + +END SUBROUTINE getDiffusionMatrix_27 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part new file mode 100755 index 000000000..01a7c7dd6 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_28.part @@ -0,0 +1,234 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_28.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_28 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_28( Obj, K, Term1, Term2 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, :, : ) + ! 2. Term1, Term2 {dx, dy, dz} + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ) :: RealVal1, RealVal + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), Mat4( :, :, :, : ) + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + INTEGER( I4B ) :: XIndx1, XIndx2 + + CLASS( STShapeData_ ), POINTER :: SD + + XIndx1 = 1 + XIndx2 = 1 + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( K, 3 ) .NE. NIPS ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28(), Flag-2", & + "The SIZE( K, 3 ) should be NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28(), Flag-3", & + "The size of first and second dimension of K must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( K, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term1 is 'x' or 'dx' therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term1 is 'dy' or 'y', & + & therefore NSD should be greater than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term1 is 'dz' or 'z', therefore, & + & NSD should be greater than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term2 is 'x' or 'dx' therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term2 is 'dy' or 'y', & + & therefore NSD should be greater than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term2 is 'dz' or 'z', therefore, & + & NSD should be greater than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + + END SELECT +#endif + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + XIndx1 = 1 + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + XIndx1 = 2 + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + XIndx1 = 3 + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + XIndx2 = 1 + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + XIndx2 = 2 + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + XIndx2 = 3 + END SELECT + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + DO b = 1, NNT + DO aa = 1, NNT + Mat4( :, :, aa, b ) = & + & OUTERPROD( a = SD % dNTdXt( :, XIndx1, aa ), & + & b = SD % dNTdXt( :, XIndx2, b ) ) + END DO + END DO + + Mat2 = K( :, :, IPS ) + + DO j = 1, M + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + DO i = 1, M + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + RealVal = Mat2( i, j ) * RealVal1 + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) + Mat4*RealVal + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + +END SUBROUTINE getDiffusionMatrix_28 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part new file mode 100755 index 000000000..1de30542c --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_29.part @@ -0,0 +1,222 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_29.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_29 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_29( Obj, K, Term1, Term2 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M + REAL( DFP ) :: RealVal1, RealVal + REAL( DFP ), ALLOCATABLE :: Mat4( :, :, :, : ) + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + INTEGER( I4B ) :: XIndx1, XIndx2 + + CLASS( STShapeData_ ), POINTER :: SD + + XIndx1 = 1 + XIndx2 = 1 + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28(), Flag-3", & + "The size of first and second dimension of K must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( K, 1 ) + +#ifdef DEBUG_VER + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term1 is 'x' or 'dx' therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term1 is 'dy' or 'y', & + & therefore NSD should be greater than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term1 is 'dz' or 'z', therefore, & + & NSD should be greater than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + IF( NSD .LT. 1 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term2 is 'x' or 'dx' therefore NSD should be & + & greater than or equal to 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + IF( NSD .LT. 2 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term2 is 'dy' or 'y', & + & therefore NSD should be greater than 1" ) + Error_Flag = .TRUE. + RETURN + END IF + + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + IF( NSD .LT. 3 ) THEN + CALL Err_Msg("STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_28()", & + "Term2 is 'dz' or 'z', therefore, & + & NSD should be greater than 2" ) + Error_Flag = .TRUE. + RETURN + END IF + + END SELECT +#endif + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*M, NNS*M, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + ALLOCATE( Indx( M, 2 ) ) + Indx = 0 + DO i = 1, M + Indx( i, 1 ) = (i-1)*NNS + 1 + Indx( i, 2 ) = i*NNS + END DO + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + XIndx1 = 1 + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + XIndx1 = 2 + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + XIndx1 = 3 + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term2 ) ) ) + + CASE( "X", "x", "x1", "X1", "dX", "dx", "dx1", "dX1" ) + XIndx2 = 1 + CASE( "Y", "y", "x2", "X2", "dY", "dy", "dx2", "dX2" ) + XIndx2 = 2 + CASE( "Z", "z", "x3", "X3", "dZ", "dz", "dx3", "dX3" ) + XIndx2 = 3 + END SELECT + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + DO b = 1, NNT + DO aa = 1, NNT + Mat4( :, :, aa, b ) = & + & OUTERPROD( a = SD % dNTdXt( :, XIndx1, aa ), & + & b = SD % dNTdXt( :, XIndx2, b ) ) + END DO + END DO + DO j = 1, M + c1 = Indx( j, 1 ) + c2 = Indx( j, 2 ) + DO i = 1, M + r1 = Indx( i, 1 ) + r2 = Indx( i, 2 ) + RealVal = K( i, j ) * RealVal1 + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + & Obj % Mat4( r1:r2, c1:c2, :, : ) + Mat4*RealVal + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + +END SUBROUTINE getDiffusionMatrix_29 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part new file mode 100755 index 000000000..2e84b8673 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_3.part @@ -0,0 +1,136 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_3.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_3 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_3( Obj, K ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, :, :, : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, & + NSD, j + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), DummyMat3( :,:,: ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + & "STDiffusionMatrix_Class.f90", & + & "getDiffusionMatrix_3(), Flag-1", & + & "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN + CALL Err_Msg( & + & "STDiffusionMatrix_Class.f90", & + & "getDiffusionMatrix_3()", & + & "The SIZE(K, 1) should be equal to SIZE(K, 2)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( K, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + & "STDiffusionMatrix_Class.f90", & + & "getDiffusionMatrix_3()", & + & "The SIZE(K, 1) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( K, 3 ) .NE. NIPS .OR. SIZE( K, 4 ) .NE. NIPT ) THEN + CALL Err_Msg( & + & "STDiffusionMatrix_Class.f90", & + & "getDiffusionMatrix_3()", & + & "The SIZE(K, 3) should be equal to NIPS, & + & and SIZE(K,4) should be equal to NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + ALLOCATE( DummyMat3( NNS, NSD, NNT ) ) + ALLOCATE( DummyVec1( NNT*NNS ), DummyVec2( NNT*NNS ) ) + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + Mat2 = K( :, :, IPS, IPT ) + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + DO a = 1, NNT + DummyMat3( :, :, a ) = MATMUL( SD % dNTdXt( :, :, a ), Mat2 ) + END DO + + DO j = 1, NSD + DummyVec1 = RESHAPE( SD % dNTdXt( :, j, : ), (/NNS*NNT/) ) + DummyVec2 = RealVal*RESHAPE( DummyMat3( :, j, : ), (/NNS*NNT/) ) + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & + + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + NULLIFY( SD ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2) ) DEALLOCATE( DummyVec2) + IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) + +END SUBROUTINE getDiffusionMatrix_3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part new file mode 100755 index 000000000..17f5985f7 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_30.part @@ -0,0 +1,180 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_30.part +! Last Update : March-05-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_30 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_30( Obj, TimeVector, IntegrationSide ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns Diffusion matrix for acoustic wave equation +! 2. Time Integration is character "Right", "Left", "Both" +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, M, p, q + REAL( DFP ), ALLOCATABLE :: dNTdXt( :, :, : ), T( : ), dNTdXt2( :, :, : ) + REAL( DFP ) :: Ws, Js, thick, RealVal, Jt, Wt, Kij, t1, t2, Theta + TYPE( STElemShapeData_ ), TARGET :: STElemSD + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_30()", & + "STDiffusionMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + M = NSD + + t1 = TimeVector( 1 ) + t2 = TimeVector( 2 ) + + ! Make copy of Obj + CALL STElemSD % Initiate( Obj ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => STElemSD .SDPointer. [IPS, IPT] + Theta = .Theta. SD + T = SD .TimeIntegration. [t1, t2, Theta] + + CALL SD % setT( T ) + CALL Check_Error( & + "STDiffusionMatrix_Class.f90>>DiffusionMatrix_30.part", & + "Traceback ---> CALL SD % setT( T )"& + ) + + CALL SD % setdNTdXt( ) + CALL Check_Error( & + "STDiffusionMatrix_Class.f90>>DiffusionMatrix_30.part", & + "Traceback ---> CALL SD % setdNTdXT( )"& + ) + SD => NULL( ) + + END DO + + END DO + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + CALL STElemSD % SD( IPS, IPT ) % getdNTdXt( dNTdXt2 ) + + RealVal = Ws * Wt * Js * Jt * thick + + DO aa = 1, NNT + + DO b = 1, NNT + + DO p = 1, NSD + + SELECT CASE( TRIM( IntegrationSide ) ) + + CASE( "Right", "RIGHT", "right" ) + Obj % Mat4( :, :, aa, b ) = & + Obj % Mat4( :, :, aa, b ) + & + OUTERPROD( a = dNTdXt( :, p, aa ), & + b = dNTdXt2( :, p, b ) ) * RealVal + + CASE( "Left", "LEFT", "left" ) + Obj % Mat4( :, :, aa, b ) = & + Obj % Mat4( :, :, aa, b ) + & + OUTERPROD( a = dNTdXt2( :, p, aa ), & + b = dNTdXt( :, p, b ) ) * RealVal + + CASE( "Both", "BOTH", "both" ) + Obj % Mat4( :, :, aa, b ) = & + Obj % Mat4( :, :, aa, b ) + & + OUTERPROD( a = dNTdXt2( :, p, aa ), & + b = dNTdXt2( :, p, b ) ) * RealVal + + CASE DEFAULT + Obj % Mat4( :, :, aa, b ) = & + Obj % Mat4( :, :, aa, b ) + & + OUTERPROD( a = dNTdXt( :, p, aa ), & + b = dNTdXt( :, p, b ) ) * RealVal + + END SELECT + + END DO + + END DO + + END DO + + END DO + + END DO + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( dNTdXt ) ) DEALLOCATE( dNTdXt ) + IF( ALLOCATED( dNTdXt2 ) ) DEALLOCATE( dNTdXt2 ) + IF( ALLOCATED( T ) ) DEALLOCATE( T ) + CALL STElemSD % DeallocateData( ) + SD => NULL( ) + + END SUBROUTINE getDiffusionMatrix_30 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part new file mode 100755 index 000000000..aa56524ac --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_31.part @@ -0,0 +1,211 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_31.part +! Last Update : March-27-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Diffusion matrix for pressure wave equation for +! alpha-beta-v-STFEM +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_31 +!------------------------------------------------------------------------------ + + SUBROUTINE getDiffusionMatrix_31( Obj, TimeVector, IntegrationSide, Beta_STFEM ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns Diffusion matrix for acoustic wave equation +! 2. Time Integration is character "Right", "Left", "Both" +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ), Beta_STFEM + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, M, p, q + + REAL( DFP ), ALLOCATABLE :: dNTdXt( :, :, : ), T( : ), dNTdXt2( :, :, : ), & + dNTdXt3( :, :, : ) + REAL( DFP ) :: Beta, Ws, Js, thick, RealVal, Jt, Wt, Kij, t1, t2, Theta + TYPE( STElemShapeData_ ), TARGET :: STElemSD, STElemSD2 + CLASS( STShapeData_ ), POINTER :: SD => NULL( ), SD2 => NULL( ) + + Error_Flag = .FALSE. + + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_31()", & + "STDiffusionMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + M = NSD + + t1 = TimeVector( 1 ) + t2 = TimeVector( 2 ) + + Beta = Beta_STFEM * ( t2 - t1 ) + + ! Make copy of Obj + CALL STElemSD % Initiate( Obj ) + CALL STElemSD2 % Initiate( Obj ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => STElemSD .SDPointer. [IPS, IPT] + Theta = .Theta. SD + T = SD .TimeIntegration. [t1, t2, Theta] + + CALL SD % setT( T ) + CALL Check_Error( & + "STDiffusionMatrix_Class.f90>>DiffusionMatrix_31.part", & + "Traceback ---> CALL SD % setT( T )"& + ) + + CALL SD % setdNTdXt( ) + CALL Check_Error( & + "STDiffusionMatrix_Class.f90>>DiffusionMatrix_31.part", & + "Traceback ---> CALL SD % setdNTdXT( )"& + ) + + SD2 => STElemSD2 % SD( IPS, IPT ) + T = SD2 % dTdTheta / SD2 % Jt + + CALL SD2 % setT( T ) + CALL Check_Error( & + "STStiffnessMatrix_Class.f90>>StiffnessMatrix_13.part", & + "Traceback ---> CALL SD2 % setT( T )"& + ) + + CALL SD2 % setdNTdXt( ) + CALL Check_Error( & + "STStiffnessMatrix_Class.f90>>StiffnessMatrix_13.part", & + "Traceback ---> CALL SD2 % setdNTdXT( )"& + ) + + END DO + + END DO + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + CALL STElemSD % SD( IPS, IPT ) % getdNTdXt( dNTdXt2 ) + CALL STElemSD2 % SD( IPS, IPT ) % getdNTdXt( dNTdXt3 ) + + RealVal = Ws * Wt * Js * Jt * thick * Beta + + DO aa = 1, NNT + + DO b = 1, NNT + + DO p = 1, NSD + + SELECT CASE( TRIM( IntegrationSide ) ) + + CASE( "Right", "RIGHT", "right" ) + Obj % Mat4( :, :, aa, b ) = & + Obj % Mat4( :, :, aa, b ) + & + OUTERPROD( a = dNTdXt3( :, p, aa ), & + b = dNTdXt2( :, p, b ) ) * RealVal + + CASE( "Left", "LEFT", "left" ) + Obj % Mat4( :, :, aa, b ) = & + Obj % Mat4( :, :, aa, b ) + & + OUTERPROD( a = dNTdXt2( :, p, aa ), & + b = dNTdXt3( :, p, b ) ) * RealVal + + CASE( "None", "NONE", "none" ) + Obj % Mat4( :, :, aa, b ) = & + Obj % Mat4( :, :, aa, b ) + & + OUTERPROD( a = dNTdXt3( :, p, aa ), & + b = dNTdXt( :, p, b ) ) * RealVal + + CASE DEFAULT + + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getStiffnessMatrix_31()", & + "No case found for given integration side" & + ) + Error_Flag = .TRUE. + RETURN + + END SELECT + + END DO + + END DO + + END DO + + END DO + + END DO + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( dNTdXt ) ) DEALLOCATE( dNTdXt ) + IF( ALLOCATED( dNTdXt2 ) ) DEALLOCATE( dNTdXt2 ) + IF( ALLOCATED( dNTdXt3 ) ) DEALLOCATE( dNTdXt3 ) + IF( ALLOCATED( T ) ) DEALLOCATE( T ) + CALL STElemSD % DeallocateData( ) + CALL STElemSD2 % DeallocateData( ) + SD => NULL( ) + SD2 => NULL( ) + + END SUBROUTINE getDiffusionMatrix_31 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part new file mode 100755 index 000000000..aacf1b0ea --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_4.part @@ -0,0 +1,137 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_4.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_4 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_4( Obj, K ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, :, : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, & + NSD, j + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), DummyMat3( :,:,: ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + & "STDiffusionMatrix_Class.f90", & + & "getDiffusionMatrix_4(), Flag-1", & + & "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_4()", & + "The SIZE(K, 1) should be equal to SIZE(K, 2)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( K, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_4()", & + "The SIZE(K, 1) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( K, 3 ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_4()", & + "The SIZE(K, 3) should be equal to NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + ALLOCATE( DummyMat3( NNS, NSD, NNT ) ) + ALLOCATE( DummyVec1( NNT*NNS ), DummyVec2( NNT*NNS ) ) + + DO IPS = 1, NIPS + Mat2 = K( :, :, IPS ) + DO IPT = 1, NIPT + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + DO a = 1, NNT + DummyMat3( :, :, a ) = MATMUL( SD % dNTdXt( :, :, a ), Mat2 ) + END DO + DO j = 1, NSD + DummyVec1 = RESHAPE( SD % dNTdXt( :, j, : ), (/NNS*NNT/) ) + DummyVec2 = RealVal*RESHAPE( DummyMat3(:,j,:), (/NNS*NNT/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & + + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2) ) DEALLOCATE( DummyVec2) + IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) + +END SUBROUTINE getDiffusionMatrix_4 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part new file mode 100755 index 000000000..cf3bd5a8a --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_5.part @@ -0,0 +1,128 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_5.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_5 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_5( Obj, K ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, : ) + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, & + NSD, j + REAL( DFP ), ALLOCATABLE :: DummyMat3( :,:,: ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_4(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( K, 1 ) .NE. SIZE( K, 2 ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_4()", & + "The SIZE(K, 1) should be equal to SIZE(K, 2)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( K, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_4()", & + "The SIZE(K, 1) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + ALLOCATE( DummyMat3( NNS, NSD, NNT ) ) + ALLOCATE( DummyVec1( NNT*NNS ), DummyVec2( NNT*NNS ) ) + + DO IPS = 1, NIPS + DO IPT = 1, NIPT + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + DO a = 1, NNT + DummyMat3( :, :, a ) = MATMUL( SD % dNTdXt( :, :, a ), K ) + END DO + + DO j = 1, NSD + DummyVec1 = RESHAPE( SD % dNTdXt( :, j, : ), (/NNS*NNT/) ) + DummyVec2 = RealVal*RESHAPE( DummyMat3( :, j, : ), (/NNS*NNT/) ) + + Obj % Mat2( :, : ) = Obj % Mat2( :, : ) & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + + NULLIFY( SD ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2) ) DEALLOCATE( DummyVec2) + IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) + +END SUBROUTINE getDiffusionMatrix_5 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part new file mode 100755 index 000000000..785089aa3 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_6.part @@ -0,0 +1,50 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_6.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_6 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_6( Obj, K, nCopy ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns mass matrix; C is a 2D array of STNodal Values + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( K = K ) + CALL Obj % MakeDiagonalCopies( nCopy ) + +END SUBROUTINE getDiffusionMatrix_6 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part new file mode 100755 index 000000000..9893d4867 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_7.part @@ -0,0 +1,51 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_7.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_7 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_7( Obj, K, nCopy ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, :, : ) + !. . . . . . . . . . . . . . . . . . . . + + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( K = K ) + CALL Obj % MakeDiagonalCopies( nCopy ) + +END SUBROUTINE getDiffusionMatrix_7 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part new file mode 100755 index 000000000..92357d92a --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_8.part @@ -0,0 +1,50 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_8.part +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_8 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_8( Obj, K, nCopy ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. K( :, : ) + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K + INTEGER( I4B ), INTENT( IN ) :: nCopy + + CALL Obj % getDiffusionMatrix( K = K ) + CALL Obj % MakeDiagonalCopies( nCopy ) + +END SUBROUTINE getDiffusionMatrix_8 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part new file mode 100755 index 000000000..ff390d6b8 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/DiffusionMatrix_9.part @@ -0,0 +1,194 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: DiffusionMatrix_9.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STDiffusionMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getDiffusionMatrix_9 +!------------------------------------------------------------------------------ + +SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. c1, c2 ( :, :, : ) + ! 2. c1Type, c2Type NodalValues, QuadPoints + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD + REAL( DFP ), ALLOCATABLE :: c1dNTdXt( :, : ), c2dNTdXt( :, : ), & + DummyVec1( : ), DummyVec2( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isC1Nodal, isC2Nodal + + isC1Nodal = .TRUE. + isC2Nodal = .TRUE. + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_9(), Flag-1", & + "STDiffusionMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + +#ifdef DEBUG_VER + IF( SIZE( C1, 1 ) .NE. SIZE( C2, 1 ) ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_9()", & + "The SIZE(C1, 1) should be equal to SIZE(C2, 1)" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 1 ) .NE. NSD ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_9()", & + "The SIZE(C1, 1), SIZE( C2, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 2 ) .NE. NIPS .AND. SIZE( C1, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_9()", & + "The SIZE(C1, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C1, 3 ) .NE. NIPT .AND. SIZE( C1, 3 ) .NE. NNT ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_9()", & + "The SIZE(C1, 3) should be equal to either NIPT, & + & or NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 2 ) .NE. NIPS .AND. SIZE( C2, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_9()", & + "The SIZE(C2, 2) should be equal to either NIPS, & + & or NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( C2, 3 ) .NE. NIPT .AND. SIZE( C2, 3 ) .NE. NNT ) THEN + CALL Err_Msg( & + "STDiffusionMatrix_Class.f90", & + "getDiffusionMatrix_9()", & + "The SIZE(C2, 3) should be equal to either NIPT, & + & or NNT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( TRIM( ADJUSTL( c1Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC1Nodal = .FALSE. + END SELECT + + SELECT CASE( TRIM( ADJUSTL( c2Type ) ) ) + CASE( "Quad", "QuadPoints", "Quad Points", & + "Integration", "Integration Points", & + "IntegrationPoints" ) + isC2Nodal = .FALSE. + END SELECT + + IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NNS*NNT, NNS*NNT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isC1Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & STNodalValues = C1 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c1dNTdXt, & + & VectorValues = C1( :, IPS, IPT ) ) + END IF + + IF( isC2Nodal ) THEN + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & STNodalValues = C2 ) + ELSE + CALL SD % getProjectionOfdNTdXt( cdNTdXt = c2dNTdXt, & + & VectorValues = C2( :, IPS, IPT ) ) + END IF + + DummyVec1 = RESHAPE( c1dNTdXt, (/NNS*NNT/) ) + DummyVec2 = RealVal * RESHAPE( c2dNTdXt, (/NNS*NNT/) ) + + Obj % Mat2 = Obj % Mat2 & + & + OUTERPROD( a = DummyVec1, b = DummyVec2 ) + END DO + END DO + + CALL Obj % Mat4FromMat2( I3 = NNT, I4 = NNT ) + NULLIFY( SD ) + IF( ALLOCATED( c1dNTdXt ) ) DEALLOCATE( c1dNTdXt ) + IF( ALLOCATED( c2dNTdXt ) ) DEALLOCATE( c2dNTdXt ) + IF( ALLOCATED( DummyVec1 ) ) DEALLOCATE( DummyVec1 ) + IF( ALLOCATED( DummyVec2 ) ) DEALLOCATE( DummyVec2 ) + +END SUBROUTINE getDiffusionMatrix_9 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part new file mode 100644 index 000000000..9f920588f --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/MethodNames.part @@ -0,0 +1,31 @@ +getDiffusionMatrix_1, & +getDiffusionMatrix_2 , & +getDiffusionMatrix_3 , & +getDiffusionMatrix_4 , & +getDiffusionMatrix_5 , & +getDiffusionMatrix_6 , & +getDiffusionMatrix_7 , & +getDiffusionMatrix_8 , & +getDiffusionMatrix_9 , & +getDiffusionMatrix_10 , & +getDiffusionMatrix_11 , & +getDiffusionMatrix_12 , & +getDiffusionMatrix_13 , & +getDiffusionMatrix_14 , & +getDiffusionMatrix_15 , & +getDiffusionMatrix_16 , & +getDiffusionMatrix_17 , & +getDiffusionMatrix_18 , & +getDiffusionMatrix_19 , & +getDiffusionMatrix_20 , & +getDiffusionMatrix_21 , & +getDiffusionMatrix_22 , & +getDiffusionMatrix_23 , & +getDiffusionMatrix_24 , & +getDiffusionMatrix_25 , & +getDiffusionMatrix_26 , & +getDiffusionMatrix_27 , & +getDiffusionMatrix_28 , & +getDiffusionMatrix_29 , & +getDiffusionMatrix_30 , & +getDiffusionMatrix_31 \ No newline at end of file diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 new file mode 100755 index 000000000..75fa6cf23 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.f90 @@ -0,0 +1,100 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: STDiffusionMatrix_Class.f90 +! Last Update : Nov-20-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Diffusion matrices for space-time elements +! +!============================================================================== + + MODULE STDiffusionMatrix_Class + USE GlobalData + USE IO + USE STElemShapeData_Class + USE STShapeData_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: STDiffusionMatrix_, STDiffusionMatrix, & + STDiffusionMatrix_Pointer + +!------------------------------------------------------------------------------ +! STElemShapeData_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( STElemShapeData_ ) :: STDiffusionMatrix_ + +!. . . . . . . . . . . . . . . . . . . . +! 1. Diffusion matrices for the space-time element. +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + + PROCEDURE, PUBLIC, PASS( Obj ) :: & +#include "./MethodNames.part" + + END TYPE STDiffusionMatrix_ + +!------------------------------------------------------------------------------ +! INTERFACES +!------------------------------------------------------------------------------ + + INTERFACE STDiffusionMatrix_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 + END INTERFACE + + INTERFACE STDiffusionMatrix + MODULE PROCEDURE Constructor1, Constructor2, Constructor3 + END INTERFACE + +!------------------------------------------------------------------------------ +! CONTAINS +!------------------------------------------------------------------------------ + + CONTAINS + +#include "./Constructor.part" +#include "./DiffusionMatrix_1.part" +#include "./DiffusionMatrix_2.part" +#include "./DiffusionMatrix_3.part" +#include "./DiffusionMatrix_4.part" +#include "./DiffusionMatrix_5.part" +#include "./DiffusionMatrix_6.part" +#include "./DiffusionMatrix_7.part" +#include "./DiffusionMatrix_8.part" +#include "./DiffusionMatrix_9.part" +#include "./DiffusionMatrix_10.part" +#include "./DiffusionMatrix_11.part" +#include "./DiffusionMatrix_12.part" +#include "./DiffusionMatrix_13.part" +#include "./DiffusionMatrix_14.part" +#include "./DiffusionMatrix_15.part" +#include "./DiffusionMatrix_16.part" +#include "./DiffusionMatrix_17.part" +#include "./DiffusionMatrix_18.part" +#include "./DiffusionMatrix_19.part" +#include "./DiffusionMatrix_20.part" +#include "./DiffusionMatrix_21.part" +#include "./DiffusionMatrix_22.part" +#include "./DiffusionMatrix_23.part" +#include "./DiffusionMatrix_24.part" +#include "./DiffusionMatrix_25.part" +#include "./DiffusionMatrix_26.part" +#include "./DiffusionMatrix_27.part" +#include "./DiffusionMatrix_28.part" +#include "./DiffusionMatrix_29.part" +#include "./DiffusionMatrix_30.part" +#include "./DiffusionMatrix_31.part" + + END MODULE STDiffusionMatrix_Class + diff --git a/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md new file mode 100755 index 000000000..6fe667b09 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/STDiffusionMatrix-old/STDiffusionMatrix_Class.md @@ -0,0 +1,1971 @@ +# Space Time Diffusion Matrix Class + +## ToDo + +## Structure + +## Description + +`STDiffusionMatrix_` object is child of `STElemShapeData_` class. It can be initiated using following commands. + +## Getting Started + +### Making The Object + +We can make the object using the `Initiate` method. + +```fortran +CALL Obj % Initiate( NIPS = NIPS, NIPT = NIPT) +CALL Obj % InitiateMatrix( row= row, col = col) +CALL Obj % InitiateMatrix( I1 = I1, I2 = I2, I3 = I3, I4= I4) +``` + +We can also use the `STDiffusionMatrix()` function + +```fortran +STElemSD = STDiffusionMatrix( ) +STElemSD = STDiffusionMatrix( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) +STElemSD = STDiffusionMatrix( I1, I2, I3, I4, I5, NIPS, NIPT) +``` + +We can also use the `STDiffusionMatrix_Pointer()` function + +```fortran +STElemSD => STDiffusionMatrix_Pointer( ) +STElemSD => STDiffusionMatrix_Pointer( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) +STElemSD => STDiffusionMatrix_Pointer( I1, I2, I3, I4, I5, NIPS, NIPT) +``` + +### Getting The Diffusion Matrix + +To compute the following matrix + +$$\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta u\,}}{{\partial {\bf{x}}}} \cdot \frac{{\partial u}}{{\partial {\bf{x}}}}d\Omega dt} } = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_i}}}\,\frac{{\partial {N^J}{T_b}}}{{\partial {x_i}}}d\Omega dt} } } \right]\,{}^b{u_J}$$ + +we can use the following command + +```fortran +CALL Obj % getDiffusionMatrix( ) +``` + +To compute the following matrix + +$$ +\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta {u_i}\,}}{{\partial {\bf{x}}}} \cdot \frac{{\partial {u_i}}}{{\partial {\bf{x}}}}d\Omega dt} } = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_p}}}\,\frac{{\partial {N^J}{T_b}}}{{\partial {x_p}}}d\Omega dt} } } \right]\,{}^b{u_{iJ}} +$$ + +we can call following fortran command. + + +```fortran +CALL Obj % getDiffusionMatrix( nCopy ) +``` + +To compute the following matrix + +$$ +\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta u\,}}{{\partial {x_i}}}{K_{ij}}\frac{{\partial u}}{{\partial {x_j}}}d\Omega dt} } = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_i}}}\,{K_{ij}}\frac{{\partial {N^J}{T_b}}}{{\partial {x_j}}}d\Omega dt} } } \right]\,{}^b{u_J} +$$ + +We can call following command. + +```fortran +CALL Obj % getDiffusionMatrix( K ) +``` + +To compute the following matrix + +$$ +\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial \delta {u_i}\,}}{{\partial {x_p}}}{K_{pq}}\frac{{\partial {u_i}}}{{\partial {x_q}}}d\Omega dt} } = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial {x_p}}}\,{K_{pq}}\frac{{\partial {N^J}{T_b}}}{{\partial {x_q}}}d\Omega dt} } } \right]\,{}^b{u_{iJ}} +$$ + +we can call following fortran command. + +```fortran +CALL Obj % getDiffusionMatrix( K, nCopy ) +``` + +In the above two calls `K` can be rank-4 `K(:,:,:,:)`, rank-3 `K(:,:,:)`, rank-2 `K(:,:)`. If `K` is varying in both space and time then it is given by space-time matrix. If `K` is changing only with the space then it is given by the Rank-3, and if `K` is constant in both space and time then it is given by the Rank-2 matrix. `K` is defined at the integration points. + +To compute the following matrix + +$$ +\[\int_{{I_n}}^{} {\int_\Omega ^{} {{{\bf{c}}_1} \cdot \frac{{\partial \delta u}}{{\partial {\bf{x}}}}{{\bf{c}}_2} \cdot \frac{{\partial u}}{{\partial {\bf{x}}}}d\Omega dt} } = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{{\bf{c}}_1} \cdot \frac{{\partial {N^I}{T_a}}}{{\partial {\bf{x}}}}{{\bf{c}}_2} \cdot \frac{{\partial {N^J}{T_b}}}{{\partial {\bf{x}}}}d\Omega dt} } } \right]{}^b{u_J}\] +$$ + +```fortran +CALL Obj % getDiffusionMatrix( c1, c2, c1Type, c2Type ) +CALL Obj % getDiffusionMatrix( c1, c2, c1Type, c2Type, nCopy ) +``` + +In the above call `c1, c2` can be rank-3 `(:,:,:)`, rank-2 `(:,:)`, rank-1 `(:)`. `c1Type, c2Type` can be `NodalValues` or `QuadPoints`. `c1, c2` denotes the convective velocity. + +- If convective velocity is changing in space and time then it must be given by Rank-3 matrix. +- If convective velocity is changing in only space then it must be given by Rank-2 matrix. +- If convective velocity is constant in both space and time then it must be given by Rank-1 matrix. + + + +```fortran +CALL Obj % getDiffusionMatrix( K, Term1, Term2 ) +``` + +In the above call `K` can be rank-4 `K(:,:,:,:)`, rank-3 `K(:,:,:)`, rank-2 `K(:,:)`. `Term1` and `Term2` can be `dx, dy, dz`. + + + + + + + + + + + + + + + + + + + + + + + + + + + + +## Theory + +Consider the following _scalar_ term present in the pde + +$${\nabla}^2 u + \cdots $$ + +then we may need to compute the following matrices. + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +Note here, $u \in R$. + +> These tasks are performed by following methods; `getDiffusionMatrix_1()`, `getDiffusionMatrix_2()` + +Now consider the following terms in a pde. + +$${\nabla} \cdot \Big( -{}^{2}\mathbf{K}{\nabla}u \Big) + \cdots $$ +or +$$\frac{\partial}{\partial x_i} \cdot \Big( -{}^{2}K_{ij} \frac{\partial u}{\partial x_j} \Big) + \cdots $$ + +> These tasks are performed by following methods; `getDiffusionMatrix_3()`, `getDiffusionMatrix_4()`, `getDiffusionMatrix_5()`, `getDiffusionMatrix_6()`, `getDiffusionMatrix_7()`, and `getDiffusionMatrix_8()` + + + +## Methods + +### getDiffusionMatrix_1() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_1( Obj ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. This is the simplest form possible. No arguments are required. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +CALL STElemSD % getDiffusionMatrix( ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_1( )" +CALL STElemSD % DisplayMatrix4 +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_1( ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` +> Note that in this case integrad is quadratic in time, therefore we need atleast 2 integration points in the time. This condition may change when the mesh is moving. Note that the row sum and column sum is zero as expected. + +### getDiffusionMatrix_2() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_2( Obj, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. This is the simplest form possible. No arguments are required. +- `nCopy` is an integer, which decides how many copies need to be placed on the diagonal. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +CALL STElemSD % getDiffusionMatrix( nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_2( nCopy = 2 )" +CALL STElemSD % DisplayMatrix4 +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_2( nCopy = 2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111 -0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111 -0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getDiffusionMatrix_3() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_3( Obj, K ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `K(:,:,:,:)` is a four dimensional array. The shape of `K` should be `(NSD, NSD, NIPS, NIPT)`. The third index denotes the spatial-integration points. The fourth index denotes the temporal integration points. In this case, `K` matrix varies in both space and time. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( K = DummyMat4 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) +ALLOCATE( DummyMat4( NSD, NSD, NIPS, NIPT ) ) +DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP +DummyMat4( 2, 2, :, : ) = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( K = DummyMat4 ) +cALL Check_Error( " " , " " ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_3( K = DummyMat4 )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_3( K = DummyMat4 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getDiffusionMatrix_4() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_4( Obj, K ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `K(:,:,:)` is a three dimensional array. The shape of `K` should be `(NSD, NSD, NIPS)`. The third index denotes the spatial-integration points. In this case, `K` matrix varies in only in space and remains constant in time. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( K = DummyMat3 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NSD, NIPS ) ) +DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP +DummyMat3( 2, 2, : ) = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( K = DummyMat3 ) +cALL Check_Error( " " , " " ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_4( K = DummyMat3 )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_4( K = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getDiffusionMatrix_5() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_5( Obj, K ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `K(:,:)` is a two dimensional array. The shape of `K` should be `(NSD, NSD)`. In this case, `K` matrix remains constant in both space and time. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( K = DummyMat2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NSD ) ) +DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP +DummyMat2( 2, 2 ) = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( K = DummyMat2 ) +cALL Check_Error( " " , " " ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.2222222 -0.1111111 0.4444444 -0.1111111 + -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getDiffusionMatrix_6() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_6( Obj, K, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `K(:,:,:,:)` is a four dimensional array. The shape of `K` should be `(NSD, NSD, NIPS, NIPT)`. The third index denotes the spatial-integration points. The fourth index denotes the temporal integration points. In this case, `K` matrix varies in both space and time. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( K = DummyMat4, nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) +ALLOCATE( DummyMat4( NSD, NSD, NIPS, NIPT ) ) +DummyMat4 = 0.0_DFP; DummyMat4( 1, 1, :, : ) = 1.0_DFP +DummyMat4( 2, 2, :, : ) = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( K = DummyMat4, nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_6( K = DummyMat4 )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_6( K = DummyMat4 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getDiffusionMatrix_7() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_7( Obj, K, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `K(:,:,:)` is a three dimensional array. The shape of `K` should be `(NSD, NSD, NIPS)`. The third index denotes the spatial-integration points. In this case, `K` matrix varies in only in space and remains constant in time. +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( K = DummyMat3, nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NSD, NIPS ) ) +DummyMat3 = 0.0_DFP; DummyMat3( 1, 1, : ) = 1.0_DFP +DummyMat3( 2, 2, : ) = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( K = DummyMat3, nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_7( K = DummyMat3 )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_7( K = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getDiffusionMatrix_8() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_8( Obj, K, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `K(:,:)` is a two dimensional array. The shape of `K` should be `(NSD, NSD)`. In this case, `K` matrix remains constant in both space and time. + +```fortran +CALL STElemSD % getDiffusionMatrix( K = DummyMat2, nCopy = 2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_I \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_i} \frac{\partial N^J T_b}{ \partial x_i} {dQ} \quad {}^{b}u_J$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NSD ) ) +DummyMat2 = 0.0_DFP; DummyMat2( 1, 1 ) = 1.0_DFP +DummyMat2( 2, 2 ) = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( K = DummyMat2, nCopy = 2 ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_5( K = DummyMat2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 0.000000 0.000000 0.000000 0.000000 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.2222222 -0.5555556E-01 -0.1111111-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 0.2222222 -0.5555556E-01-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.5555556E-01 0.2222222-0.5555556E-01 + 0.000000 0.000000 0.000000 0.000000 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.000000 0.000000 0.000000 0.000000 + -0.2222222 -0.1111111 0.4444444 -0.1111111 0.000000 0.000000 0.000000 0.000000 + -0.1111111 -0.2222222 -0.1111111 0.4444444 0.000000 0.000000 0.000000 0.000000 + 0.000000 0.000000 0.000000 0.000000 0.4444444 -0.1111111 -0.2222222-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 0.4444444 -0.1111111-0.2222222 + 0.000000 0.000000 0.000000 0.000000 -0.2222222 -0.1111111 0.4444444-0.1111111 + 0.000000 0.000000 0.000000 0.000000 -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getDiffusionMatrix_9() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c1(:,:,:)` and `c2(:,:,:)` are three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` or `C2Type` are in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` and/or `c2` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `C1Type` or `C2Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` and/or `c2` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Nodal' ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat3,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_9( c1 = & +DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_9( c1 = DummyMat3, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_10() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c1(:,:)` and `c2(:,:)` are two dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` or `C2Type` are in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` and/or `c2` denotes the spatial nodal values. In this case, their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. +- `C1Type` or `C2Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` and/or `c2` denotes the values at spatial integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat2,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_10( c1 = & +DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_10( c1 = DummyMat2, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_11() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_9( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c1(:)` and `c2(:)` are vectors. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` or `C2Type` are string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyVec,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_11( c1 = & +DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_11( c1 = DummyVec, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_12() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c1(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `C1Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `c2(:,:)` are two dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c2` denotes the spatial nodal values. In this case, their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. +- `C2Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at spatial integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. + + + + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyMat2,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_12( c1 = & +DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_12( c1 = DummyMat3, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_13() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c2(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `C2Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `c1(:,:)` are two dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the spatial nodal values. In this case, their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. +- `C1Type` are in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at spatial integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. + + + + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyMat3,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_12( c1 = & +DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_13( c1 = DummyMat2, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_14() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c1(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `C1Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `c2(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C2Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. + + + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat3, c2 = DummyVec,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_14( c1 = & +DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_14( c1 = DummyMat3, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_15() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c2(:,:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c2` denotes the space-time nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `C2Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at space-time integration(quadrature) points. In this case, their shape should be `(NSD, NIPS, NIPT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `c1(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. + + + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat3,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_15( c1 = & +DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_15( c1 = DummyVec, c2 = DummyMat3, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_16() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c1(:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c1` denotes the space nodal values. In this case their shape should be `(NSD, NNS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. +- `C1Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c1` denotes the values at space integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. +- `c2(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C2Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. + + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) +DummyMat2 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyMat2, c2 = DummyVec,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_16( c1 = & +DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_16( c1 = DummyMat2, c2 = DummyVec, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_17() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_12( Obj, c1, c2, c1Type, c2Type ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type +``` + +DESCRIPTION + +- This methods computes the diffusion matrix for a scalar variable. +- `c2(:,:)` is three dimensional arrays. They denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C2Type` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `c2` denotes the space nodal values. In this case their shape should be `(NSD, NNS, NNT)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. +- `C2Type` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Qaud Points]` then `c2` denotes the values at space integration(quadrature) points. In this case, their shape should be `(NSD, NIPS)`. The first index denotes the spatial-coordinate. The second index denotes the spatial-node. Third index denotes the temporal nodes. +- `c1(:)` is a vector. It denotes the vector over which projection of $\frac{\partial N^I T_a}{\partial x_k}$ will be taken. +- `C1Type` is string type and has no effect on the functionality of the method. they are inlcuded here to maintain the subroutine. + + + +CODE SNIPPET + +```fortran +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Nodal' ) +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Nodal', C2Type = 'Quad' ) +``` + +SYMBOLIC CALCULATION + +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) +DummyMat2 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getDiffusionMatrix( c1 = DummyVec, c2 = DummyMat2,& +C1Type = 'Quad', C2Type = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") "CALL STElemSD % getDiffusionMatrix_17( c1 = & +DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' )" +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getDiffusionMatrix_17( c1 = DummyVec, c2 = DummyMat2, C1Type = 'Quad', C2Type = 'Quad' ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + +Mat4( :, :, 1, 2 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 1 ) + + 0.3888889 -0.5555556E-01 -0.2777778 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + -0.2777778 -0.5555556E-01 0.3888889 -0.5555556E-01 + -0.5555556E-01 0.5555556E-01 -0.5555556E-01 0.5555556E-01 + +Mat4( :, :, 2, 2 ) + + 0.7777778 -0.1111111 -0.5555556 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 + -0.5555556 -0.1111111 0.7777778 -0.1111111 + -0.1111111 0.1111111 -0.1111111 0.1111111 +``` + +### getDiffusionMatrix_18() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_18( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_19() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_19( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_20() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_20( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1, c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_21() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_21( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_22() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_22( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_23() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_23( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_24() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_24( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_25() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_25( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c1 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c2 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_26() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_26( Obj, c1, c2, c1Type, c2Type, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: c2 + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: c1 + CHARACTER( LEN = * ), INTENT( IN ) :: c1Type, c2Type + INTEGER( I4B ), INTENT( IN ) :: nCopy +``` + +### getDiffusionMatrix_27() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_27( Obj, K, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: K + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +### getDiffusionMatrix_28() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_28( Obj, K, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: K + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + +### getDiffusionMatrix_29() + +INTERFACE + +```fortran + SUBROUTINE getDiffusionMatrix_29( Obj, K, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STDiffusionMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: K + CHARACTER( LEN = * ), INTENT( IN ) :: Term1, Term2 +``` + + diff --git a/src/submodules/STDiffusionMatrix/src/STDM_1.inc b/src/submodules/STDiffusionMatrix/src/STDM_1.inc new file mode 100644 index 000000000..62ab2a90f --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_1.inc @@ -0,0 +1,64 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +PURE SUBROUTINE STDM_1(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! a scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=k) + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) & + & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& + & trial(ipt)%dNTdXt(:, :, ii, ips)) + !! + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, kbar) +END SUBROUTINE STDM_1 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_11.inc b/src/submodules/STDiffusionMatrix/src/STDM_11.inc new file mode 100644 index 000000000..45d6b94cf --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_11.inc @@ -0,0 +1,147 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: kbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=k) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, kbar) + !! +END SUBROUTINE STDM_11a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! 2 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: kbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=k) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, kbar) + !! +END SUBROUTINE STDM_11b diff --git a/src/submodules/STDiffusionMatrix/src/STDM_12.inc b/src/submodules/STDiffusionMatrix/src/STDM_12.inc new file mode 100644 index 000000000..8c8e1ee34 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_12.inc @@ -0,0 +1,181 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + INTEGER(I4B) :: ips, ipt, ii, nsd + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=k) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), & + & 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 3) + m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + END DO + !! + CALL Convert( from=m6, to=ans) + !! + DEALLOCATE (realval, IJab, vbar, m6) + !! +END SUBROUTINE STDM_12a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! opt=2 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + INTEGER(I4B) :: ips, ipt, ii, nsd + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=k) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, & + & SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 4) + m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m6, to=ans) + !! + 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 new file mode 100644 index 000000000..07e8c1420 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_13.inc @@ -0,0 +1,155 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, c1bar, c2bar) + !! +END SUBROUTINE STDM_13a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! 2 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:,ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, c1bar, c2bar) + !! +END SUBROUTINE STDM_13b diff --git a/src/submodules/STDiffusionMatrix/src/STDM_14.inc b/src/submodules/STDiffusionMatrix/src/STDM_14.inc new file mode 100644 index 000000000..b4415905a --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_14.inc @@ -0,0 +1,188 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=cbar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), & + & 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 3) + m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + END DO + !! + CALL Convert( from=m6, to=ans) + !! + DEALLOCATE (realval, IJab, vbar, m6, cbar) + !! +END SUBROUTINE STDM_14a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector variable + INTEGER(I4B), INTENT(IN) :: opt + !! opt=2 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=cbar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, & + & SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * cbar(:,ipt) + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 4) + m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m6, to=ans) + !! + DEALLOCATE (realval, IJab, vbar, m6) + !! +END SUBROUTINE STDM_14b diff --git a/src/submodules/STDiffusionMatrix/src/STDM_2.inc b/src/submodules/STDiffusionMatrix/src/STDM_2.inc new file mode 100644 index 000000000..6131ed31d --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_2.inc @@ -0,0 +1,60 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PURE SUBROUTINE STDM_2(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Vector variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p1(:, :, :) + REAL(DFP), ALLOCATABLE :: p2(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=k) + !! + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k) + !! + DO ips = 1, SIZE(realval) + !! + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + !! + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, p1, p2) +END SUBROUTINE STDM_2 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_3.inc b/src/submodules/STDiffusionMatrix/src/STDM_3.inc new file mode 100644 index 000000000..e753853ac --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_3.inc @@ -0,0 +1,66 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +PURE SUBROUTINE STDM_3(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd + !! + !! main + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=k) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) + !! + END DO + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, KBar, IaJb) +END SUBROUTINE STDM_3 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_4.inc b/src/submodules/STDiffusionMatrix/src/STDM_4.inc new file mode 100644 index 000000000..c45591f3a --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_4.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! vector +!! vector +!! +PURE SUBROUTINE STDM_4(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Vector variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p1(:, :, :) + REAL(DFP), ALLOCATABLE :: p2(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + !! + DO ips = 1, SIZE(realval) + !! + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + !! + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, p1, p2) +END SUBROUTINE STDM_4 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_5.inc b/src/submodules/STDiffusionMatrix/src/STDM_5.inc new file mode 100644 index 000000000..392dec893 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_5.inc @@ -0,0 +1,79 @@ + +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- +! +! scalar +! matrix +! +PURE SUBROUTINE STDM_5(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! sclar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd + !! + !! 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=rhobar, val=c1) + CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) + !! + END DO + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, rhobar, kbar) +END SUBROUTINE STDM_5 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_6.inc b/src/submodules/STDiffusionMatrix/src/STDM_6.inc new file mode 100644 index 000000000..abb4efdb8 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_6.inc @@ -0,0 +1,71 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! scalar +! scalar +! +PURE SUBROUTINE STDM_6(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! a scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! a scalar variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & + & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) & + & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& + & trial(ipt)%dNTdXt(:, :, ii, ips)) + !! + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, c1bar, c2bar) +END SUBROUTINE STDM_6 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_7.inc b/src/submodules/STDiffusionMatrix/src/STDM_7.inc new file mode 100644 index 000000000..60a248dc0 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_7.inc @@ -0,0 +1,64 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +! +! Scalar +! Vector +! +PURE SUBROUTINE STDM_7(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:,:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p1(:, :, :) + REAL(DFP), ALLOCATABLE :: p2(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! 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) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + !! + DO ips = 1, SIZE(realval) + !! + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + !! + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, c1bar, iajb, p1, p2) +END SUBROUTINE STDM_7 diff --git a/src/submodules/STDiffusionMatrix/src/STDM_8.inc b/src/submodules/STDiffusionMatrix/src/STDM_8.inc new file mode 100644 index 000000000..3e4c46518 --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDM_8.inc @@ -0,0 +1,73 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! matrix +! matrix +! +PURE SUBROUTINE STDM_8(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Matrix variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Matrix variable + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd + !! + !! main + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt)) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) * m2(ii, jj) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) + !! + END DO + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, m2, iajb, k1bar, k2bar) +END SUBROUTINE STDM_8 diff --git a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 new file mode 100644 index 000000000..03386ddca --- /dev/null +++ b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 @@ -0,0 +1,1180 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(STDiffusionMatrix_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: kbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=k) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, kbar) + !! +END SUBROUTINE STDM_11a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! 2 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: kbar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=k) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, kbar) + !! +END SUBROUTINE STDM_11b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + INTEGER(I4B) :: ips, ipt, ii, nsd, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=k) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), & + & 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 3) + m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + END DO + !! + CALL Convert( from=m6, to=ans) + !! + DEALLOCATE (realval, IJab, vbar, m6) + !! +END SUBROUTINE STDM_12a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: k + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! opt=2 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + INTEGER(I4B) :: ips, ipt, ii, nsd, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=k) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, & + & SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 4) + m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m6, to=ans) + !! + DEALLOCATE (realval, IJab, vbar, m6) + !! +END SUBROUTINE STDM_12b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, jj, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, c1bar, c2bar) + !! +END SUBROUTINE STDM_13a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar variable + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Scalar variable + INTEGER(I4B), INTENT(IN) :: opt + !! 2 + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd, a, b + !! + !! main + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & trial(1)%refelem%nsd, & + & trial(1)%refelem%nsd, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:,ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + DO jj = 1, nsd + DO ii = 1, nsd + !! + m6(:, :, ii, jj, a, b) = m6(:, :, ii, jj, a, b) & + & + realval(ips) * & + & OUTERPROD( & + & test(ipt)%dNTdXt(:, a, jj, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (realval, m6, c1bar, c2bar) + !! +END SUBROUTINE STDM_13b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector + INTEGER(I4B), INTENT(IN) :: opt + !! opt=1 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=cbar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(vbar, 1), & + & 1, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 3) + m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + END DO + !! + CALL Convert( from=m6, to=ans) + !! + DEALLOCATE (realval, IJab, vbar, m6, cbar) + !! +END SUBROUTINE STDM_14a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + !! test function + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + !! trial function + CLASS(FEVariable_), INTENT(IN) :: c1 + !! Scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! Vector variable + INTEGER(I4B), INTENT(IN) :: opt + !! opt=2 + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IJab(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=cbar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + !! + CALL Reallocate( & + & IJab, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + CALL Reallocate( & + & m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & 1, & + & SIZE(vbar, 1), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * cbar(:,ipt) + !! + DO ips = 1, SIZE(realval) + !! + IJab = 0.0_DFP + !! + DO ii = 1, nsd + DO b = 1, SIZE(IJab, 4) + DO a = 1, SIZE(IJab, 3) + !! + IJab(:,:,a,b) = IJab(:,:,a,b) & + & + OUTERPROD( & + & test(ipt)%dNTdXt(:, a, ii, ips), & + & trial(ipt)%dNTdXt(:, b, ii, ips)) + !! + END DO + END DO + END DO + !! + DO ii = 1, SIZE(m6, 4) + m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & + & + realval( ips ) * vbar(ii, ips, ipt) & + & * IJab + END DO + !! + END DO + !! + END DO + !! + CALL Convert( from=m6, to=ans) + !! + DEALLOCATE (realval, IJab, vbar, m6) + !! +END SUBROUTINE STDM_14b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MakeDiagonalCopiesIJab(ans, ncopy) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: ncopy + !! + REAL(DFP), ALLOCATABLE :: m2(:, :), m4(:, :, :, :) + INTEGER(I4B) :: a, b + !! + m4 = ans + !! + CALL Reallocate(ans, & + & ncopy * SIZE(m4, 1), & + & ncopy * SIZE(m4, 2), & + & SIZE(m4, 3), & + & SIZE(m4, 4)) + !! + DO b = 1, SIZE(m4, 4) + DO a = 1, SIZE(m4, 3) + CALL MakeDiagonalCopies(from=m4(:, :, a, b), to=m2, ncopy=ncopy) + ans(:, :, a, b) = m2 + END DO + END DO + !! + DEALLOCATE (m2, m4) +END SUBROUTINE MakeDiagonalCopiesIJab + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_1 +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +INTEGER(I4B) :: ips, ipt, ii, nsd +!! +!! main +!! +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +nsd = trial(1)%refelem%nsd +!! +DO ipt = 1, SIZE(trial) + realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & + & * trial(ipt)%Wt * trial(ipt)%Jt + DO ips = 1, SIZE(trial(1)%N, 2) + DO ii = 1, nsd + iajb = iajb + realval(ips) & + & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& + & trial(ipt)%dNTdXt(:, :, ii, ips)) + END DO + END DO +END DO +!! +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +!! +if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +!! +DEALLOCATE (realval, iajb) +END PROCEDURE mat4_STDiffusionMatrix_1 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_2 + ! CALL STDM_1(ans=ans, test=test, trial=trial, k=k, opt=opt) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=k) + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) & + & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& + & trial(ipt)%dNTdXt(:, :, ii, ips)) + !! + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, kbar) +END PROCEDURE mat4_STDiffusionMatrix_2 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_3 + ! CALL STDM_2(ans=ans, test=test, trial=trial, k=k, opt=opt) + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p1(:, :, :) + REAL(DFP), ALLOCATABLE :: p2(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + !! + DO ipt = 1, SIZE(trial) + !! + 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=trial(ipt), cdNTdXt=p2, val=k) + !! + DO ips = 1, SIZE(realval) + !! + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + !! + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, p1, p2) +END PROCEDURE mat4_STDiffusionMatrix_3 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_4 + ! CALL STDM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd + !! + !! 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=kbar, val=k) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) + !! + END DO + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, KBar, IaJb) +END PROCEDURE mat4_STDiffusionMatrix_4 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_5 + !! + !! scalar + !! scalar + !! + ! CALL STDM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + INTEGER(I4B) :: ips, ipt, ii, nsd + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & + & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) & + & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& + & trial(ipt)%dNTdXt(:, :, ii, ips)) + !! + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, c1bar, c2bar) +END PROCEDURE mat4_STDiffusionMatrix_5 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_6 + !! + !! scalar + !! vector + !! + ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:,:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p1(:, :, :) + REAL(DFP), ALLOCATABLE :: p2(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! 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) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + !! + DO ips = 1, SIZE(realval) + !! + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + !! + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, c1bar, iajb, p1, p2) + !! +END PROCEDURE mat4_STDiffusionMatrix_6 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_7 + !! + !! scalar + !! matrix + !! + ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd + !! + !! 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=rhobar, val=c1) + CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + !! + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) + !! + END DO + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, rhobar, kbar) +END PROCEDURE mat4_STDiffusionMatrix_7 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_8 + !! + !! vector + !! scalar + !! + ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) + !! + ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & + & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableVector, opt=opt ) +END PROCEDURE mat4_STDiffusionMatrix_8 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_9 + !! + !! vector + !! vector + !! + ! CALL STDM_4(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: p1(:, :, :) + REAL(DFP), ALLOCATABLE :: p2(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + !! + DO ips = 1, SIZE(realval) + !! + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + !! + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, iajb, p1, p2) +END PROCEDURE mat4_STDiffusionMatrix_9 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_10 + !! + !! vector + !! matrix + !! + !! CALL STDM_10(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! +END PROCEDURE mat4_STDiffusionMatrix_10 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_11 + !! + !! matrix + !! scalar + !! + ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) + !! + ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & + & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableMatrix, opt=opt) + !! +END PROCEDURE mat4_STDiffusionMatrix_11 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_12 + !! + !! matrix + !! vector + !! + !!CALL STDM_9(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! +END PROCEDURE mat4_STDiffusionMatrix_12 + +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_13 + !! + !! matrix + !! matrix + !! + ! CALL STDM_8(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :) + INTEGER(I4B) :: ips, ipt, ii, jj, nsd + !! + !! main + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) + nsd = trial(1)%refelem%nsd + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt)) + !! + DO jj = 1, nsd + !! + DO ii = 1, nsd + !! + iajb = iajb + realval(ips) * m2(ii, jj) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) + !! + END DO + END DO + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (realval, m2, iajb, k1bar, k2bar) + !! +END PROCEDURE mat4_STDiffusionMatrix_13 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_14 +IF (opt(1) .EQ. 1) THEN + CALL STDM_11a(ans=ans, test=test, trial=trial, k=k, opt=1) +ELSE + CALL STDM_11b(ans=ans, test=test, trial=trial, k=k, opt=2) +END IF +END PROCEDURE mat4_STDiffusionMatrix_14 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_15 +IF (opt(1) .EQ. 1) THEN + CALL STDM_12a(ans=ans, test=test, trial=trial, k=k, opt=1) +ELSE + CALL STDM_12b(ans=ans, test=test, trial=trial, k=k, opt=2) +END IF +END PROCEDURE mat4_STDiffusionMatrix_15 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_16 +IF (opt(1) .EQ. 1) THEN + CALL STDM_13a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=1) +ELSE + CALL STDM_13b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=2) +END IF +END PROCEDURE mat4_STDiffusionMatrix_16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STDiffusionMatrix_17 +IF (opt(1) .EQ. 1) THEN + CALL STDM_14a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=1) +ELSE + CALL STDM_14b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=2) +END IF +END PROCEDURE mat4_STDiffusionMatrix_17 + +END SUBMODULE Methods diff --git a/src/submodules/STFextVector/Constructor.part b/src/submodules/STFextVector/Constructor.part new file mode 100755 index 000000000..10c3d85be --- /dev/null +++ b/src/submodules/STFextVector/Constructor.part @@ -0,0 +1,152 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Nov-24-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Row, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFextVector_ pointer +! Allocates the Obj % Vec1( row ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STFextVector_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT + + ALLOCATE( Constructor_1 ) + ALLOCATE( Constructor_1 % Vec1( row ) ) + Constructor_1 % Vec1 = 0.0_DFP + CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( I1, I2, I3, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFextVector_ pointer +! Allocates the Obj % Vec3( I1, I2, I3 ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STFextVector_ ), POINTER :: Constructor_2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT + + ALLOCATE( Constructor_2 ) + ALLOCATE( Constructor_2 % Vec3( I1, I2, I3 ) ) + Constructor_2 % Vec3 = 0.0_DFP + CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFextVector_ pointer +! Empty constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STFextVector_ ), POINTER :: Constructor_3 + + ALLOCATE( Constructor_3 ) + + END FUNCTION Constructor_3 + + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Row, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFextVector_ object +! Allocates the Obj % Vec1( row ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STFextVector_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT + + ALLOCATE( Constructor1 % Vec1( row ) ) + Constructor1 % Vec1 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( I1, I2, I3, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFextVector_ object +! Allocates the Obj % Vec3( I1, I2, I3 ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STFextVector_ ) :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT + + ALLOCATE( Constructor2 % Vec3( I1, I2, I3 ) ) + Constructor2 % Vec3 = 0.0_DFP + CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFextVector_ object +! Empty constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STFextVector_ ) :: Constructor3 + + END FUNCTION Constructor3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_1.part b/src/submodules/STFextVector/FextVector_1.part new file mode 100755 index 000000000..f1abbb7c2 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_1.part @@ -0,0 +1,111 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_1.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_1 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_1( Obj, Fext ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes the space-time nodal values + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY:OUTERPROD + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, I, M + REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat(:,:) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + & "STFextVector_Class.f90", & + & "getFextVector_1(Obj, Fext)", & + & "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .OR. SIZE( Fext, 3 ) .NE. NNT ) THEN + CALL Err_Msg( & + & "STFextVector_Class.f90", & + & "getFextVector_1(Obj, Fext)", & + & "The SIZE( Fext, 2 ) should be equal to NNS, & + & The SIZE( Fext, 3 ) should be equal to NNT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + DummyMat = OUTERPROD( Fbar, SD % N ) + + DO a = 1, NNT + Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & + & DummyMat * RealVal * SD % T( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, DummyMat ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_10.part b/src/submodules/STFextVector/FextVector_10.part new file mode 100755 index 000000000..652853944 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_10.part @@ -0,0 +1,141 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_10.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_10 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_10( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes space-time nodal value, C denotes constant value + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isFNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_10(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + & "getFextVector_10(), Flag-2", & + & "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + & "getFextVector_10(), Flag-3", & + & "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + & "getFextVector_10(), Flag-4", & + & "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C, cdNTdXt = cdNTdXt ) + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS, IPT ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_10 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_11.part b/src/submodules/STFextVector/FextVector_11.part new file mode 100755 index 000000000..c6e7561bd --- /dev/null +++ b/src/submodules/STFextVector/FextVector_11.part @@ -0,0 +1,161 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_11.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_11 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_11( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Spacetime nodal values C; Fext Space nodal values + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isCNodal, isFNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_11(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_11(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_11(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_11(), Flag-4", & + "The SIZE( C, 3 ) should be equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_11(), Flag-5", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + isCNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isCNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isCNodal ) THEN + CALL SD % getProjectionOfdNTdXt( & + & STNodalValues = C, cdNTdXt = cdNTdXt ) + ELSE + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C(:,IPS,IPT), cdNTdXt = cdNTdXt ) + END IF + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_11 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_12.part b/src/submodules/STFextVector/FextVector_12.part new file mode 100755 index 000000000..49f81b10d --- /dev/null +++ b/src/submodules/STFextVector/FextVector_12.part @@ -0,0 +1,138 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_12.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_12 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_12( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. C :: SpaceTime Nodal values; Fext:: Constant in space and time + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isCNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_12(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_12(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_12(), Flag-4", & + "The SIZE( C, 3 ) should be equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_12(), Flag-5", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isCNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isCNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isCNodal ) THEN + CALL SD % getProjectionOfdNTdXt( & + & STNodalValues = C, cdNTdXt = cdNTdXt ) + ELSE + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C(:,IPS,IPT), cdNTdXt = cdNTdXt ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fext( a ) + END DO + END DO + END DO + + DEALLOCATE( cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_12 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_13.part b/src/submodules/STFextVector/FextVector_13.part new file mode 100755 index 000000000..7c69d4072 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_13.part @@ -0,0 +1,133 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_13.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_13 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_13( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext :: SpaceNodal Values; C :: Constant values + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isFNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_13(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_13(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_13(), Flag-3", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C, cdNTdXt = cdNTdXt ) + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_13 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_14.part b/src/submodules/STFextVector/FextVector_14.part new file mode 100755 index 000000000..b37dfc730 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_14.part @@ -0,0 +1,131 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_12.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_14 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_14( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext :: Constant in space and time, C :: space nodal values + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isCNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_14(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_14(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_14(), Flag-4", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isCNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isCNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isCNodal ) THEN + CALL SD % getProjectionOfdNTdXt( & + & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) + ELSE + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C(:,IPS), cdNTdXt = cdNTdXt ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fext( a ) + END DO + END DO + END DO + + DEALLOCATE( cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_14 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/STFextVector/FextVector_15.part b/src/submodules/STFextVector/FextVector_15.part new file mode 100755 index 000000000..8dd91f205 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_15.part @@ -0,0 +1,136 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_15.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_15 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_15( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext and C are space-time nodal values + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_15(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_15(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Fext, 3 ) .NE. NNT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_15(), Flag-3", & + "The SIZE( Fext, 3 ) should be equal to NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_15(), Flag-4", & + "The SIZE( C, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 3 ) .NE. NNT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_15(), Flag-5", & + "The SIZE( C, 3 ) should be equal to NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_15(), Flag-6", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & STNodalValues = C, cdNTdXt = cdNTdXt ) + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_15 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_16.part b/src/submodules/STFextVector/FextVector_16.part new file mode 100755 index 000000000..de6cd022a --- /dev/null +++ b/src/submodules/STFextVector/FextVector_16.part @@ -0,0 +1,122 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_16.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_16 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_16( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext and C denotes the space nodal values + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_16(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_16(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_16(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_16(), Flag-4", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_16 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_17.part b/src/submodules/STFextVector/FextVector_17.part new file mode 100755 index 000000000..a0684e21a --- /dev/null +++ b/src/submodules/STFextVector/FextVector_17.part @@ -0,0 +1,104 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_17.part +! Last Update : Nov-24-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_17 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_17( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Both Fext and C are constant in space and time + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_17(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_17(), Flag-2", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C, cdNTdXt = cdNTdXt ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fext( a ) + END DO + + END DO + END DO + + DEALLOCATE( cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_17 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_18.part b/src/submodules/STFextVector/FextVector_18.part new file mode 100755 index 000000000..7aa6d7e95 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_18.part @@ -0,0 +1,131 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_18.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_18 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_18( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes the space time nodal values; C denotes the space nodal + ! values. + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_18(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_18(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Fext, 3 ) .NE. NNT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_18(), Flag-3", & + "The SIZE( Fext, 3 ) should be equal to NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_18(), Flag-4", & + "The SIZE( C, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_18(), Flag-5", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_18 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/STFextVector/FextVector_19.part b/src/submodules/STFextVector/FextVector_19.part new file mode 100755 index 000000000..f3e41d84f --- /dev/null +++ b/src/submodules/STFextVector/FextVector_19.part @@ -0,0 +1,124 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_19.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_19 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_19( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes space time nodal values; C is constant in space and + ! time domain + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_19(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_19(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Fext, 3 ) .NE. NNT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_19(), Flag-3", & + "The SIZE( Fext, 3 ) should be equal to NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_19(), Flag-4", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C, cdNTdXt = cdNTdXt ) + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_19 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_2.part b/src/submodules/STFextVector/FextVector_2.part new file mode 100755 index 000000000..be55cfb7d --- /dev/null +++ b/src/submodules/STFextVector/FextVector_2.part @@ -0,0 +1,112 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_2.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_2 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_2( Obj, Fext ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Space Nodal Values of Fext + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, I, M + REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat(:,:) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + & "STFextVector_Class.f90", & + & "getFextVector_1(Obj, Fext)", & + & "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS ) THEN + CALL Err_Msg( & + & "STFextVector_Class.f90", & + & "getFextVector_1(Obj, Fext)", & + & "The SIZE( Fext, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNT = Obj % SD( 1,1 ) % getNNT( ) + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + DummyMat = OUTERPROD( Fbar, SD % N ) + + DO a = 1, NNT + Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & + & DummyMat * RealVal * SD % T( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, DummyMat ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_20.part b/src/submodules/STFextVector/FextVector_20.part new file mode 100755 index 000000000..715e9c276 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_20.part @@ -0,0 +1,131 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_20.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_20 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_20( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes Space nodal values, C denotes space time nodal values + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_20(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_20(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_20(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 3 ) .NE. NNT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_20(), Flag-4", & + "The SIZE( C, 3 ) should be equal to NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_20(), Flag-5", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & STNodalValues = C, cdNTdXt = cdNTdXt ) + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_20 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_21.part b/src/submodules/STFextVector/FextVector_21.part new file mode 100755 index 000000000..cdc1956ae --- /dev/null +++ b/src/submodules/STFextVector/FextVector_21.part @@ -0,0 +1,121 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_21.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_21 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_21( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext is constant in space and time; C is space-time nodal values + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_21(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + ! Flag-3 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_21(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 3 ) .NE. NNT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_21(), Flag-4", & + "The SIZE( C, 3 ) should be equal to NNT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_21(), Flag-5", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & STNodalValues = C, cdNTdXt = cdNTdXt ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fext( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_21 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_22.part b/src/submodules/STFextVector/FextVector_22.part new file mode 100755 index 000000000..f524de13b --- /dev/null +++ b/src/submodules/STFextVector/FextVector_22.part @@ -0,0 +1,116 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_22.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_22 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_22( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext :: denotes the space nodal values; C is constant in space and time + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_22(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_22(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_22(), Flag-3", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C, cdNTdXt = cdNTdXt ) + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_22 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_23.part b/src/submodules/STFextVector/FextVector_23.part new file mode 100755 index 000000000..1ff56d55a --- /dev/null +++ b/src/submodules/STFextVector/FextVector_23.part @@ -0,0 +1,113 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_23.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_23 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_23( Obj, Fext, C ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext constant in space and time and C is space nodal values + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_23(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( C, 2 ) .NE. NNS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_23(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_23(), Flag-4", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + CALL SD % getProjectionOfdNTdXt( & + & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fext( a ) + END DO + + END DO + END DO + + DEALLOCATE( cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_23 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_24.part b/src/submodules/STFextVector/FextVector_24.part new file mode 100755 index 000000000..29137c63f --- /dev/null +++ b/src/submodules/STFextVector/FextVector_24.part @@ -0,0 +1,149 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_24.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_24 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_24( Obj, Fext, FextType, Term1 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes the space time nodal values + ! 2. FextType can be Nodal or Quad, and Term1 can be dx, dy, dz, dt + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, Indx, M + REAL( DFP ), ALLOCATABLE :: Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isFNodal + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + ! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_24(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_24(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_24(), Flag-3", & + "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) + Indx = 1_I4B + + CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) + Indx = 2_I4B + + CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) + Indx = 3_I4B + + CASE DEFAULT + Indx = 0_I4B + + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt & + & * SD % Thickness + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS, IPT ) + END IF + + IF( Indx .EQ. 0 ) THEN + DO a = 1, M + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * Fbar( a ) * SD % dNTdt + END DO + ELSE + DO a = 1, M + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * Fbar( a ) * SD % dNTdXt( :, Indx, : ) + END DO + END IF + + END DO + END DO + + DEALLOCATE( Fbar ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_24 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_25.part b/src/submodules/STFextVector/FextVector_25.part new file mode 100755 index 000000000..00fb4f85e --- /dev/null +++ b/src/submodules/STFextVector/FextVector_25.part @@ -0,0 +1,142 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_25.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_25 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_25( Obj, Fext, FextType, Term1 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext Space nodal values + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, Indx, M + REAL( DFP ), ALLOCATABLE :: Fbar( : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + LOGICAL( LGT ) :: isFNodal + + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_25(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_25(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) + Indx = 1_I4B + + CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) + Indx = 2_I4B + + CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) + Indx = 3_I4B + + CASE DEFAULT + Indx = 0_I4B + + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt & + & * SD % Thickness + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS ) + END IF + + IF( Indx .EQ. 0 ) THEN + DO a = 1, M + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * Fbar( a ) * SD % dNTdt + END DO + ELSE + DO a = 1, M + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * Fbar( a ) * SD % dNTdXt( :, Indx, : ) + END DO + END IF + + END DO + END DO + + DEALLOCATE( Fbar ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_25 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/STFextVector/FextVector_26.part b/src/submodules/STFextVector/FextVector_26.part new file mode 100755 index 000000000..1aa8206c4 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_26.part @@ -0,0 +1,113 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_26.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_26 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_26( Obj, Fext, FextType, Term1 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns element Fext; + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, Indx, M + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_26(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) + Indx = 1_I4B + + CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) + Indx = 2_I4B + + CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) + Indx = 3_I4B + + CASE DEFAULT + Indx = 0_I4B + + END SELECT + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt & + & * SD % Thickness + + IF( Indx .EQ. 0 ) THEN + DO a = 1, M + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * Fext( a ) * SD % dNTdt + END DO + ELSE + DO a = 1, M + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * Fext( a ) * SD % dNTdXt( :, Indx, : ) + END DO + END IF + + END DO + END DO + + NULLIFY( SD ) + +END SUBROUTINE getFextVector_26 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_3.part b/src/submodules/STFextVector/FextVector_3.part new file mode 100755 index 000000000..1c1a8c5b4 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_3.part @@ -0,0 +1,97 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_3.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== +! +! +!------------------------------------------------------------------------------ +! getFextVector_3 +!------------------------------------------------------------------------------ +! +SUBROUTINE getFextVector_3( Obj, Fext ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext is constant in both space and time domain + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M + REAL( DFP ), ALLOCATABLE :: DummyMat(:,:) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + & "STFextVector_Class.f90", & + & "getFextVector_1(Obj, Fext)", & + & "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + DummyMat = OUTERPROD( Fext, SD % N ) + + DO a = 1, NNT + Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & + & DummyMat * RealVal * SD % T( a ) + END DO + END DO + END DO + + DEALLOCATE( DummyMat ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_4.part b/src/submodules/STFextVector/FextVector_4.part new file mode 100755 index 000000000..67e70f3f3 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_4.part @@ -0,0 +1,135 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_4.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_4 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_4( Obj, Fext, FextType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. FextType can be Nodal or Quad + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M + REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat( :, : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + ! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_4(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NIPS = Obj % getNIPS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + & "getFextVector_4(), Flag-2", & + & "The SIZE( Fext, 2 ) should be & + & equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + & "getFextVector_4(), Flag-3", & + & "The SIZE( Fext, 3 ) should be & + & equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints') + isNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isNodal ) THEN + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS, IPT ) + END IF + + DummyMat = OUTERPROD( Fbar, SD % N ) + + DO a = 1, NNT + Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & + & DummyMat * RealVal * SD % T( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, DummyMat ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_4 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_5.part b/src/submodules/STFextVector/FextVector_5.part new file mode 100755 index 000000000..76ffaabf9 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_5.part @@ -0,0 +1,127 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_5.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_5 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_5( Obj, Fext, FextType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext is space nodal values and FextType can be nodal or quad + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M + REAL( DFP ), ALLOCATABLE :: Fbar( : ), DummyMat( :, : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + ! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_5(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NIPS = Obj % getNIPS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + & "getFextVector_5(), Flag-2", & + & "The SIZE( Fext, 2 ) should be & + & equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints') + isNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isNodal ) THEN + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS ) + END IF + + DummyMat = OUTERPROD( Fbar, SD % N ) + + DO a = 1, NNT + Obj % Vec3( :, :, a ) = Obj % Vec3( :, :, a ) + & + & DummyMat * RealVal * SD % T( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, DummyMat ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_5 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_6.part b/src/submodules/STFextVector/FextVector_6.part new file mode 100755 index 000000000..79917bf73 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_6.part @@ -0,0 +1,169 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_6.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_6 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_6( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes the space and time nodal values and C also denotes the + ! space-time nodal values + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isCNodal, isFNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + & "getFextVector_6(), Flag-1", & + & "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_6(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_6(), Flag-3", & + "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_6(), Flag-4", & + "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_6(), Flag-5", & + "The SIZE( C, 3 ) should be equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_6(), Flag-6", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + isCNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isCNodal = .FALSE. + END SELECT + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD=>Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isCNodal ) THEN + CALL SD % getProjectionOfdNTdXt( & + & STNodalValues = C, cdNTdXt = cdNTdXt ) + ELSE + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C(:,IPS,IPT), cdNTdXt = cdNTdXt ) + END IF + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS, IPT ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_6 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/FextVector_7.part b/src/submodules/STFextVector/FextVector_7.part new file mode 100755 index 000000000..e5d99f6b2 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_7.part @@ -0,0 +1,154 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_7.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_7 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_7( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext and C denotes the space nodal values + ! 2. FextType and CType can be Nodal and Quad + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isCNodal, isFNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_7(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_7(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_7(), Flag-3", & + "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_7(), Flag-4", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + isCNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isCNodal = .FALSE. + END SELECT + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD=>Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isCNodal ) THEN + CALL SD % getProjectionOfdNTdXt( & + & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) + ELSE + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C(:,IPS), cdNTdXt = cdNTdXt ) + END IF + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & SpaceNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_7 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/STFextVector/FextVector_8.part b/src/submodules/STFextVector/FextVector_8.part new file mode 100755 index 000000000..e9e9c680d --- /dev/null +++ b/src/submodules/STFextVector/FextVector_8.part @@ -0,0 +1,109 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_8.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_8 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_8( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns element Fext; + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_8(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + +#ifdef DEBUG_VER + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_8(), Flag-2", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + M = SIZE( Fext, 1 ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD=>Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C, cdNTdXt = cdNTdXt ) + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fext( a ) + END DO + + END DO + END DO + + DEALLOCATE( cdNTdXt ) + NULLIFY( SD ) + +END SUBROUTINE getFextVector_8 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/FextVector_9.part b/src/submodules/STFextVector/FextVector_9.part new file mode 100755 index 000000000..50b98d8b7 --- /dev/null +++ b/src/submodules/STFextVector/FextVector_9.part @@ -0,0 +1,161 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FextVector_9.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STFextVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFextVector_9 +!------------------------------------------------------------------------------ + +SUBROUTINE getFextVector_9( Obj, Fext, C, FextType, CType ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Fext denotes space and time nodal values; C denotes the space + ! nodal values; FextType and Ctype are Quad or NodalValues + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFextVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, M, NSD + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), Fbar( : ) + REAL( DFP ) :: RealVal + LOGICAL( LGT ) :: isCNodal, isFNodal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_9(), Flag-1", & + "STFextVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Fext, 2 ) .NE. NNS .AND. SIZE( Fext, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_9(), Flag-2", & + "The SIZE( Fext, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Fext, 3 ) .NE. NNT .AND. SIZE( Fext, 3 ) .NE. NIPT ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_9(), Flag-3", & + "The SIZE( Fext, 3 ) should be equal to NNT, or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_9(), Flag-4", & + "The SIZE( C, 2 ) should be equal to NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( C, 1 ) .NE. NSD ) THEN + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_9(), Flag-5", & + "The SIZE( C, 1 ) should be equal to NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + isFNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isFNodal = .FALSE. + END SELECT + + isCNodal = .TRUE. + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + CASE( 'Quad', 'QuadPoints', 'Quad Points', & + & 'Integration', 'Integration Points', & + & 'IntegrationPoints' ) + isCNodal = .FALSE. + END SELECT + + M = SIZE( Fext, 1 ) + ALLOCATE( Fbar( M ) ) + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( M, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => Obj%SD(IPS,IPT) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + IF( isCNodal ) THEN + CALL SD % getProjectionOfdNTdXt( & + & SpaceNodalValues = C, cdNTdXt = cdNTdXt ) + ELSE + CALL SD % getProjectionOfdNTdXt( & + & VectorValues = C(:,IPS), cdNTdXt = cdNTdXt ) + END IF + + IF( isFNodal ) THEN + CALL SD % getInterpolationOfVector( & + & STNodalValues = Fext, Val = Fbar ) + ELSE + Fbar = Fext( :, IPS, IPT ) + END IF + + DO a = 1, NSD + Obj % Vec3( a, :, : ) = Obj % Vec3( a, :, : ) + & + & RealVal * cdNTdXt * Fbar( a ) + END DO + END DO + END DO + + DEALLOCATE( Fbar, cdNTdXt ) + NULLIFY( SD ) +END SUBROUTINE getFextVector_9 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFextVector/MdFiles/STFextVector_Class.md b/src/submodules/STFextVector/MdFiles/STFextVector_Class.md new file mode 100755 index 000000000..260c8973d --- /dev/null +++ b/src/submodules/STFextVector/MdFiles/STFextVector_Class.md @@ -0,0 +1,1845 @@ +# Space Time Fext Vector Class + +## ToDo + +- External force due to function +- External force due to line load or point load +- External force due to impact load, dirac delta function + +[toc] + +## Getting Started + +### Making the object + +`STFextVector_` class is subclass of `STElemShapeData_` class. The object of this class can be initiated using following commands. + +- Calling the inherited method `initiate` + +```fortran +CALL STElemSD % Initiate( NIPS = NIPS, NIPT = NIPT) +``` + +- We can use the `STFextVector()` function + +```fortran +CLASS( STELemShapeData_ ), POINTER :: STElemSD +STElemSD => STFextVector( ) +STElemSD => STFextVector( row = row, NIPS = NIPS, NIPT = NIPT ) +STElemSD => STFextVector( I1, I2, I3, NIPS, NIPT) +``` + +### Getting the Space time Fext Vector + +$$ +J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}\mathop {{f_i}}\limits_{ext} d\Omega dt} } +$$ + +We can compute the above integral using the following fortran command + +```fortran +CALL Obj % getFextVector( Fext ) +``` + +In the above call the argument `Fext` can be a Rank-1, Rank-2, or Rank-3 matrix. + +- If Fext is changing with both space and time then it must be described by the Rank-3 matrix. +- If Fext is changing only in space then it must be described by the Rank-2 matrix. +- If Fext is not changing with space and time then it must be described by the Rnak-1 array. + +In case `Fext` is defined at the quadrature points then we can use the following fortran command. + +```fortran +CALL Obj % getFextVector(Fext, FextType) +``` + +Here `FextType` can be `NodalValues` or `QuadPoints`. Once again `Fext` can be a rank-1, rank-2, or rank-3 array. + +To compute the following integral + +$$ +J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {{\bf{c}} \cdot \frac{{\partial {N^I}{T_a}}}{{d{\bf{x}}}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } +$$ + +we can use the following fortran command + +```fortran +CALL Obj % getFextVector(Fext, C, FextType, CType) +``` + +> In the above call `C` denotes the convective matrix, `Fext` denotes external force vector. `FextType` and `CType` can be `NodalValues` and/or `QuadPoints`. Moreover, `C` and `Fext` can be rank-1, rank-2, rank-3 fortran arrays. + +IF both `Fext` and `C` can be given by nodal-values instead of quadrature point values then we can use the following fortran command. + +```fortran +CALL Obj % getFextVector( Fext, C ) +``` + +> Note that in above call Fext and C can be rank-1, rank-2, and/or rank-3 fortran array. + +To compute the following integral + +$$ +J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dt}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } +$$ + +we can call the following fortran command + +```fortran +CALL Obj % getFextVector( Fext, FextType, "dt") +``` + +To compute the following integral + +$$ +J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dx}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } +$$ + +we can call the following fortran command + +```fortran +CALL Obj % getFextVector( Fext, FextType, "dx") +``` + +To compute the following integral + +$$ +J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dy}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } +$$ + +we can call the following fortran command + +```fortran +CALL Obj % getFextVector( Fext, FextType, "dy") +``` + +To compute the following integral + +$$ +J\left( {i,I,a} \right) = \int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{dz}}\mathop {{f_i}}\limits_{ext} d\Omega dt} } +$$ + +we can call the following fortran command + +```fortran +CALL Obj % getFextVector( Fext, FextType, "dz") +``` + + + +## Theory + +Very often we need to compute the following matrices. + +$${}^{3}Vec(i, I, a) = {}^{a}\delta u_{iI} \int_{Q_n} N^I T_a f_i {dQ}$$ + +> These tasks are performed by following methods; `getFextVector_1()`, `getFextVector_2()`, `getFextVector_3()`, `getFextVector_4()`, and `getFextVector_5()` + +Now consider the following space-time finite element matrices. + +$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +> These tasks are performed by following methods; `getFextVector_6()`, `getFextVector_7()`, `getFextVector_8()`, `getFextVector_9()`, `getFextVector_10()`, `getFextVector_10()`, `getFextVector_11()`, `getFextVector_12()`, `getFextVector_13()`, `getFextVector_14()`, `getFextVector_15()`, `getFextVector_16()`, `getFextVector_17()`, `getFextVector_18()`, `getFextVector_19()`, `getFextVector_20()`, `getFextVector_21()`, `getFextVector_22()`, and `getFextVector_23()`. + +Now consider the following space-time finite element matrices. + +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ + +> These tasks are performed by following methods; `getFextVector_24()`, `getFextVector_25()`, `getFextVector_26()`. + +## Methods + +### getFextVector_1() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_1( Obj, Fext ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat3 ) +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat3 ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_1( Fext = DummyMat3 )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_1( Fext = DummyMat3 ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +### getFextVector_2() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_2( Obj, Fext ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the space nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case, `Fext` varies only in space and remains constant in time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat2 ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_2( Fext = DummyMat2 )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_2( Fext = DummyMat2 ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +### getFextVector_3() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_3( Obj, Fext ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- `Fext(:)` is a vector of shape `(M)`. It denotes the spatial components of external force. The first index denotes the componenets of a vector. In this case, `Fext` does not change in both space and time. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyVec ) +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyVec ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_3( Fext = DummyVec )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_3( Fext = DummyVec ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +### getFextVector_4() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_4( Obj, Fext, FextType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- `FextType` is a string. + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_4( Fext = DummyMat3, & +& FextType = "Quad" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_4( Fext = DummyMat3, FextType = "Quad" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +### getFextVector_5() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_5( Obj, Fext, FextType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- `FextType` is a string. + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies only in space, and remains constant in time domain. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at spatial integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in spatial domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = {}^{a}\delta u_iI \int_{Q_n} N^I T_a f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = 'Quad' ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_5( Fext = DummyMat2, & +& FextType = "Quad" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_5( Fext = DummyMat2, FextType = "Quad" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +### getFextVector_6() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_6( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- `FextType` is a string. + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. +- `Ctype` is a string. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. + - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat3, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", & +C = DummyMat3, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_6( Fext = DummyMat3, FextType = "Quad", & +C = DummyMat3, CType = "Quad" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_6( Fext = DummyMat3, FextType = "Quad", C = DummyMat3, CType = "Quad" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_7() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_7( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- `FextType` is a string. + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies in space-domain, but remains constant in time. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in space, but remains constant in time domain. +- `Ctype` is a string. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the space-nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `C` varies in space-time domain. + - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:)` is a three dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `C` varies in space-domain, but remains constant in time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat2, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NIPS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", & +C = DummyMat2, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_7( Fext = DummyMat2, FextType = "Quad", & +C = DummyMat2, CType = "Quad" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_7( Fext = DummyMat2, FextType = "Quad", C = DummyMat2, CType = "Quad" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_8() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_8( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- This methods computes the space-time element vector for external force. +- There is no effect of `Ctype` or `FextType`. +- Both `Fext` and `C` are constant in space and time. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyVec, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", & +C = DummyVec, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_7( Fext = DummyVec, FextType = "Quad", & +C = DummyVec, CType = "Quad" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_8( Fext = DummyVec, FextType = "Quad", C =DummyVec, CType = "Quad" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_9() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_9( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- `FextType` is a string. + + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. +- `Ctype` is a string. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the space-nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `C` varies in space-time domain. + - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:)` is a three dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `C` varies in space-domain, but remains constant in time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_25( Fext = DummyMat3, & +C = DummyMat2, FextType = "Nodal", CType = "Nodal" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_25( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_10() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_10( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- `FextType` is a string. + + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `Fext` varies in space-time domain. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `Fext` varies in space-time domain. +- There is no effect of `Ctype`, `C` is constant in space and time. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_10( Fext = DummyMat3, & +C = DummyVec, FextType = "Nodal", CType = "Nodal" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_10( Fext = DummyMat3, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_11() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_11( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- `FextType` is a string. + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies in space-domain, but remains constant in time. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in space, but remains constant in time domain. + +- `Ctype` is a string. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. + - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyMat3, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEAL[LOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_11( Fext = DummyMat3, & +C = DummyMat2, FextType = "Nodal", CType = "Nodal" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_11( Fext = DummyMat3, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_12() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_12( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- There is no effect of `FextType`, and `Fext` is constant in space and time. + +- `Ctype` is a string. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. + - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat3, FextType = "Nodal", CType = "Nodal" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_12( Fext = DummyVec, & +C = DummyMat3, FextType = "Nodal", CType = "Nodal" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_12( Fext = DummyVec, C = DummyMat3, FextType = "Nodal", CType = "Nodal" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_13() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_13( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- There is no effect of `CType`, and `C` is constant in space and time. + +- `FextType` is a string. + - If `FextType` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `Fext(:,:)` is a two dimensional array of shape `(M, NNS)`. It denotes the spatial nodal values of external force. The first index denotes the componenets of a vector. The second index denotes the spatial-node. In this case `Fext` varies in space-domain, but remains constant in time. + - If `FextType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `Fext(:,:)` is a two dimensional array of shape `(M, NIPS)`. It denotes the values of external force at space-integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point. In this case `Fext` varies only in space, but remains constant in time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat2, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_12( Fext = DummyMat2, & +C = DummyVec, FextType = "Nodal", CType = "Nodal" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_12( Fext = DummyMat2, C = DummyVec, FextType = "Nodal", CType = "Nodal" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_14() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_14( Obj, Fext, C, FextType, CType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, CType +``` + +DESCRIPTION + +- There is no effect of `FextType`, and `Fext` is constant in space and time. + +- `Ctype` is a string. + - If `Ctype` is in the set `[Nodal, NodalValues, Nodal Values, STNodalValues, ST Nodal Values]` then `C(:,:,:)` is a three dimensional array of shape `(M, NNS, NNT)`. It denotes the space-time nodal values of _convective velocity_. The first index denotes the componenets of a vector. The second index denotes the spatial-node, the third index denotes the temporal-node. In this case `C` varies in space-time domain. + - If `CType` is in the set `[Integration, IntegrationPoints, Integration Points, Quad, QuadPoints, Quad Points]` then `C(:,:,:)` is a three dimensional array of shape `(M, NIPS, NIPT)`. It denotes the values of external force at space-time integation points. The first index denotes the componenets of a vector. The second index denotes spatial integration point, the third index denotes the temporal-integration point. In this case `C` varies in space-time domain. + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Nodal', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Quad', Ctype = 'Quad') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Quad', Ctype = 'Nodal') +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = 'Nodal', Ctype = 'Quad') +``` + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyVec, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_14( Fext = DummyVec, & +C = DummyMat2, FextType = "Nodal", CType = "Nodal" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 1, NIPT = 1__ + +```fortran +CALL STElemSD % getFextVector_14( Fext = DummyVec, C = DummyMat2, FextType = "Nodal", CType = "Nodal" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 1 NIPT :: 1 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 + +Vec3( :, :, 2 ) + + -2.000000 -2.000000 + 0.000000 0.000000 + 2.000000 2.000000 + 0.000000 0.000000 +``` + +### getFextVector_15() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_15( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext, C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_16() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_16( Obj, Fext, C ) + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext, C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_17() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_17( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext, C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_18() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_18( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C +``` + +### getFextVector_19() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_19( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_20() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_20( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_21() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_21( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_22() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_22( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_23() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_23( Obj, Fext, C ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C +``` + +DESCRIPTION + +SYNTAX + +SYMBOLIC CALCULATION + +$${}^{3}Vec(i, I, a) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{\partial x_k} c_k f_i {dQ}$$ + +### getFextVector_24() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_24( Obj, Fext, FextType, Term1 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 +``` + +DESCRIPTION + +SYMBOLIC CALCULATION + +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dx" ) +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dy" ) +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dz" ) +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Nodal", Term1 = "dt" ) +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dx" ) +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dy" ) +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dz" ) +CALL STElemSD % getFextVector( Fext = DummyMat3, FextType = "Quad", Term1 = "dt" ) +``` + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat3, & +FextType = "Nodal", Term1 = "dx" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_24( Fext = DummyMat3, & +FextType = "Nodal", Term1 = "dx" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 4, NIPS = 2__ + +```fortran +CALL STElemSD % getFextVector_24( Fext = DummyMat3, FextType = "Nodal", Term1 = "dx" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 + +Vec3( :, :, 2 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 +``` + +```fortran +CALL STElemSD % getFextVector_24( Fext = DummyMat3, FextType = "Nodal", Term1 = "dy" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + +Vec3( :, :, 2 ) + + -1.000000 -1.000000 + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +```fortran +CALL STElemSD % getFextVector_24( Fext = DummyMat3, FextType = "Nodal", Term1 = "dt" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + -1.000000 -1.000000 + -1.000000 -1.000000 + -1.000000 -1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + + +### getFextVector_25() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_25( Obj, Fext, FextType, Term1 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 +``` + +DESCRIPTION + +SYMBOLIC CALCULATION + +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dx" ) +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dy" ) +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dz" ) +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Nodal", Term1 = "dt" ) +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dx" ) +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dy" ) +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dz" ) +CALL STElemSD % getFextVector( Fext = DummyMat2, FextType = "Quad", Term1 = "dt" ) +``` + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyMat2, & + FextType = "Nodal", Term1 = "dx" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_25( Fext = DummyMat2, & +FextType = "Nodal", Term1 = "dx" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 4, NIPT =2__ + +```fortran +CALL STElemSD % getFextVector_25( Fext = DummyMat2, FextType = "Nodal", Term1 = "dx" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 + +Vec3( :, :, 2 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 +``` + +```fortran +CALL STElemSD % getFextVector_25( Fext = DummyMat2, FextType = "Nodal", Term1 = "dx" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 + +Vec3( :, :, 2 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 +``` + +```fortran +CALL STElemSD % getFextVector_25( Fext = DummyMat2, FextType = "Nodal", Term1 = "dt" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + -1.000000 -1.000000 + -1.000000 -1.000000 + -1.000000 -1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +### getFextVector_26() + +INTERFACE + +```fortran + SUBROUTINE getFextVector_26( Obj, Fext, FextType, Term1 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STFextVector_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Fext + CHARACTER( LEN = * ), INTENT( IN ) :: FextType, Term1 +``` + +DESCRIPTION + +SYMBOLIC CALCULATION + +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial t} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial x} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial y} f_i dQ$$ +$${}^{3}V( i, I, a ) = {}^{a}\delta u_{iI} \int_{Q_n} \frac{\partial N^I T_a}{\partial z} f_i dQ$$ + +SYNTAX + +```fortran +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dx" ) +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dy" ) +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dz" ) +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Nodal", Term1 = "dt" ) +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dx" ) +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dy" ) +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dz" ) +CALL STElemSD % getFextVector( Fext = DummyVec, FextType = "Quad", Term1 = "dt" ) +``` + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getFextVector( Fext = DummyVec, & + FextType = "Nodal", Term1 = "dx" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getFextVector_25( Fext = DummyVec, & +FextType = "Nodal", Term1 = "dx" )' + +CALL STElemSD % DisplayVector3( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getFextVector_25( Fext = DummyVec, FextType = "Nodal", Term1 = "dx" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 + +Vec3( :, :, 2 ) + + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + -1.000000 -1.000000 +``` + +```fortran +CALL STElemSD % getFextVector_25( Fext = DummyVec, FextType = "Nodal", Term1 = "dy" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + +Vec3( :, :, 2 ) + + -1.000000 -1.000000 + -1.000000 -1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` + +```fortran +CALL STElemSD % getFextVector_25( Fext = DummyVec, FextType = "Nodal", Term1 = "dt" ) + +VECTOR STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 +------------------------------------------------- + +Vec3(:,:,:) :: + +Vec3( :, :, 1 ) + + -1.000000 -1.000000 + -1.000000 -1.000000 + -1.000000 -1.000000 + -1.000000 -1.000000 + +Vec3( :, :, 2 ) + + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 + 1.000000 1.000000 +``` \ No newline at end of file diff --git a/src/submodules/STFextVector/MethodNames.part b/src/submodules/STFextVector/MethodNames.part new file mode 100644 index 000000000..370ddaa3d --- /dev/null +++ b/src/submodules/STFextVector/MethodNames.part @@ -0,0 +1,26 @@ +getFextVector_1, & +getFextVector_2, & +getFextVector_3, & +getFextVector_4, & +getFextVector_5, & +getFextVector_6, & +getFextVector_7, & +getFextVector_8, & +getFextVector_9, & +getFextVector_10, & +getFextVector_11, & +getFextVector_12, & +getFextVector_13, & +getFextVector_14, & +getFextVector_15, & +getFextVector_16, & +getFextVector_17, & +getFextVector_18, & +getFextVector_19, & +getFextVector_20, & +getFextVector_21, & +getFextVector_22, & +getFextVector_23, & +getFextVector_24, & +getFextVector_25, & +getFextVector_26 diff --git a/src/submodules/STFextVector/STFextVector_Class.f90 b/src/submodules/STFextVector/STFextVector_Class.f90 new file mode 100755 index 000000000..604cbe68a --- /dev/null +++ b/src/submodules/STFextVector/STFextVector_Class.f90 @@ -0,0 +1,102 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: STFextVector_Class.f90 +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - STElemShapeData_ Class is extended for computing the STFextVector. +! Updates +! - Nov-23-2017 +! - Jan-04-2018 Added STFextVector_Pointer +!============================================================================== + + MODULE STFextVector_Class + USE IO + USE GlobalData + USE STElemShapeData_Class + USE STShapeData_Class + USE ShapeData_Class + + IMPLICIT NONE + + PRIVATE + PUBLIC :: STFextVector, STFextVector_, STFextVector_Pointer + +!------------------------------------------------------------------------------ +! STFextVector_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( STElemShapeData_ ) :: STFextVector_ + +!. . . . . . . . . . . . . . . . . . . . +! 1. This class computes the Space-Time External Force vector +! for space-time element. +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + + PROCEDURE, PUBLIC, PASS :: & +#include "./MethodNames.part" + + END TYPE STFextVector_ + +!------------------------------------------------------------------------------ +! INTERFACES +!------------------------------------------------------------------------------ + + INTERFACE STFextVector + MODULE PROCEDURE Constructor1, Constructor2, Constructor3 + END INTERFACE + + INTERFACE STFextVector_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 + END INTERFACE + +!------------------------------------------------------------------------------ +! CONTAINS +!------------------------------------------------------------------------------ + + CONTAINS + +#include "./Constructor.part" +#include "./FextVector_1.part" +#include "./FextVector_2.part" +#include "./FextVector_3.part" +#include "./FextVector_4.part" +#include "./FextVector_5.part" +#include "./FextVector_6.part" +#include "./FextVector_7.part" +#include "./FextVector_8.part" +#include "./FextVector_9.part" +#include "./FextVector_10.part" +#include "./FextVector_11.part" +#include "./FextVector_12.part" +#include "./FextVector_13.part" +#include "./FextVector_14.part" +#include "./FextVector_15.part" +#include "./FextVector_16.part" +#include "./FextVector_17.part" +#include "./FextVector_18.part" +#include "./FextVector_19.part" +#include "./FextVector_20.part" +#include "./FextVector_21.part" +#include "./FextVector_22.part" +#include "./FextVector_23.part" +#include "./FextVector_24.part" +#include "./FextVector_25.part" +#include "./FextVector_26.part" + + END MODULE STFextVector_Class + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STFextVector/delme.f90 b/src/submodules/STFextVector/delme.f90 new file mode 100644 index 000000000..a7971671a --- /dev/null +++ b/src/submodules/STFextVector/delme.f90 @@ -0,0 +1,338 @@ + + SELECT CASE( TRIM( ADJUSTL( FextType ) ) ) + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'STNodalValues', 'ST Nodal Values' ) + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & + STNodalValues = Fext, Val = Fbar ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 1, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & + STNodalValues = Fext, Val = Fbar ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 2, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & + STNodalValues = Fext, Val = Fbar ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 3, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE( 'dt', 'dT', 'Dt', 't' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + CALL Obj % SD( IPS, IPT ) % getInterpolationOfVector( & + STNodalValues = Fext, Val = Fbar ) + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdt( I, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( 'STFextVector_Class.f90>>FextVector_24.part', & + & 'getFextVector_24()', & + & 'No case found for Term1, It should be, & + & [dx, dx1, dX, dX1, x, X, x1, X1], & + & [dy, dx2, dY, dX2, y, Y, x2, X2], & + & [dz, dx3, dZ, dX3, z, Z, x3, X3], & + & [dt, dT, t, Dt]' ) + Error_Flag = .TRUE. + RETURN + + END SELECT + + + + CASE( 'Integration', 'Integration Points', 'IntegrationPoints', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + SELECT CASE( TRIM( ADJUSTL( Term1 ) ) ) + + CASE( 'dx', 'dx1', 'dX', 'dX1', 'x', 'X', 'x1', 'X1' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + Fbar = Fext( :, IPS, IPT ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 1, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE( 'dy', 'dx2', 'dY', 'dX2', 'y', 'Y', 'x2', 'X2' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + Fbar = Fext( :, IPS, IPT ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 2, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE( 'dz', 'dx3', 'dZ', 'dX3', 'z', 'Z', 'x3', 'X3' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + Fbar = Fext( :, IPS, IPT ) + + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdXt( I, 3, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE( 'dt', 'dT', 'Dt', 't' ) + + DO a = 1, NNT + + DO I = 1, NNS + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + + thick = Obj % SD( IPS, IPT ) % getThickness( ) + + Fbar = Fext( :, IPS, IPT ) + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + RealVal = Ws * Wt * Js * Jt * thick * dNTdt( I, a ) + + Obj % Vec3( :, I, a ) = Obj % Vec3( :, I, a ) + & + Fbar * RealVal + + END DO + + END DO + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( 'STFextVector_Class.f90>>FextVector_24.part', & + & 'getFextVector_24()', & + & 'No case found for Term1, It should be, & + & [dx, dx1, dX, dX1, x, X, x1, X1], & + & [dy, dx2, dY, dX2, y, Y, x2, X2], & + & [dz, dx3, dZ, dX3, z, Z, x3, X3], & + & [dt, dT, t, Dt]' ) + Error_Flag = .TRUE. + RETURN + + END SELECT + + CASE DEFAULT + + CALL Err_Msg("STFextVector_Class.f90", & + "getFextVector_24(), Flag-1", & + "No case found for FextType, It should be & + 'Nodal', 'Nodal Values', 'NodalValues', 'STNodalValues', 'ST Nodal Values', & + & 'Integration', 'Integration Points', 'IntegrationPoints', 'Quad', 'QuadPoints', & + & 'Quad Points'" ) + Error_Flag = .TRUE. + RETURN + + END SELECT \ No newline at end of file diff --git a/src/submodules/STFintVector/Constructor.part b/src/submodules/STFintVector/Constructor.part new file mode 100755 index 000000000..79975bb1f --- /dev/null +++ b/src/submodules/STFintVector/Constructor.part @@ -0,0 +1,152 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Construction method for STFintVector_ Object +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Row, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFintVector_ pointer +! Allocates the Obj % Vec1( row ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STFintVector_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT + + ALLOCATE( Constructor_1 ) + ALLOCATE( Constructor_1 % Vec1( row ) ) + Constructor_1 % Vec1 = 0.0_DFP + CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( I1, I2, I3, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFintVector_ pointer +! Allocates the Obj % Vec3( I1, I2, I3 ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STFintVector_ ), POINTER :: Constructor_2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT + + ALLOCATE( Constructor_2 ) + ALLOCATE( Constructor_2 % Vec3( I1, I2, I3 ) ) + Constructor_2 % Vec3 = 0.0_DFP + CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFintVector_ pointer +! Empty constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STFintVector_ ), POINTER :: Constructor_3 + + ALLOCATE( Constructor_3 ) + + END FUNCTION Constructor_3 + + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Row, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFintVector_ object +! Allocates the Obj % Vec1( row ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STFintVector_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, NIPS, NIPT + + ALLOCATE( Constructor1 % Vec1( row ) ) + Constructor1 % Vec1 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( I1, I2, I3, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFintVector_ object +! Allocates the Obj % Vec3( I1, I2, I3 ) +! Allocates the Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STFintVector_ ) :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, NIPS, NIPT + + ALLOCATE( Constructor2 % Vec3( I1, I2, I3 ) ) + Constructor2 % Vec3 = 0.0_DFP + CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the STFintVector_ object +! Empty constructor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STFintVector_ ) :: Constructor3 + + END FUNCTION Constructor3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_1.part b/src/submodules/STFintVector/FintVector_1.part new file mode 100755 index 000000000..40e223494 --- /dev/null +++ b/src/submodules/STFintVector/FintVector_1.part @@ -0,0 +1,113 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_1.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_1 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_1( Obj, Sigma ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Fint; + ! 2. Sigma( :, :, : ) depends upon space and time + ! 3. First index of Sigma is related to the voigt components + ! 4. Second index denotes the spatial-integration point and + ! 5. Third index denotes the temporal integration point + !. . . . . . . . . . . . . . . . . . . . + + USE Voigt, ONLY : MatFromVoigtVec + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Sigma + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J + REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_1(Obj, Sigma)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Sigma, 2 ) .NE. NIPS .OR. SIZE( Sigma, 3 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_1(Obj, Sigma)", & + "The SIZE( Sigma, 2 ) should be equal to NIPS, & + & The SIZE( Sigma, 3 ) should be equal to NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD%Thickness + S = MatFromVoigtVec( Sigma( :, IPS, IPT ), "Stress" ) + DO i = 1, NSD + Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) + DO j = 2, NSD + Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) + END DO + Obj % Vec3( i, :, : ) = Obj % Vec3( i, :, : ) + RealVal * Mat + END DO + END DO + END DO + + DEALLOCATE( S, Mat ) + NULLIFY( SD ) + +END SUBROUTINE getFintVector_1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_2.part b/src/submodules/STFintVector/FintVector_2.part new file mode 100755 index 000000000..ad71d4df1 --- /dev/null +++ b/src/submodules/STFintVector/FintVector_2.part @@ -0,0 +1,112 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_2.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_2 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_2( Obj, Sigma ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Fint; + ! 2. Sigma( :, : ) does not change with time + ! 3. First index of Sigma is related to the voigt components + ! 4. Second index denotes the spatial-integration point + !. . . . . . . . . . . . . . . . . . . . + + USE Voigt, ONLY : MatFromVoigtVec + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Sigma + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J + REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_2(Obj, Sigma)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + +#ifdef DEBUG_VER + IF( SIZE( Sigma, 2 ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_2(Obj, Sigma)", & + "The SIZE( Sigma, 2 ) should be equal to NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPT = Obj % getNIPT( ) + + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + DO IPS = 1, NIPS + S = MatFromVoigtVec( Sigma( :, IPS ), "Stress" ) + DO IPT = 1, NIPT + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD%Thickness + DO i = 1, NSD + Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) + DO j = 2, NSD + Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) + END DO + Obj % Vec3( i, :, : ) = Obj % Vec3( i, :, : ) + RealVal * Mat + END DO + END DO + END DO + + DEALLOCATE( S, Mat ) + NULLIFY( SD ) + +END SUBROUTINE getFintVector_2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_3.part b/src/submodules/STFintVector/FintVector_3.part new file mode 100755 index 000000000..0c33a819d --- /dev/null +++ b/src/submodules/STFintVector/FintVector_3.part @@ -0,0 +1,100 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_3.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_3 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_3( Obj, Sigma ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Fint; + ! 2. Sigma( : ) does not change with space and time. + ! 3. First index of Sigma is related to the voigt components + !. . . . . . . . . . . . . . . . . . . . + + USE Voigt, ONLY : MatFromVoigtVec + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Sigma + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J + REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ) + REAL( DFP ) :: RealVal + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_3(Obj, Sigma)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + ! Make Stress Tensor ( 3 by 3 ) + S = MatFromVoigtVec( Sigma, "Stress" ) + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD%Thickness + DO i = 1, NSD + Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) + DO j = 2, NSD + Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) + END DO + Obj % Vec3( i, :, : ) = Obj % Vec3( i, :, : ) + RealVal * Mat + END DO + END DO + END DO + + DEALLOCATE( S, Mat ) + NULLIFY( SD ) + +END SUBROUTINE getFintVector_3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_4.part b/src/submodules/STFintVector/FintVector_4.part new file mode 100755 index 000000000..50e1e22dd --- /dev/null +++ b/src/submodules/STFintVector/FintVector_4.part @@ -0,0 +1,100 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_4.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_4 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_4( Obj, CData ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Sigma; + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE Stress_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) + + ! Define internal variables + INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, N, NSD + REAL( DFP ), ALLOCATABLE :: Sigma( :, :, : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_4(Obj, CData)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_4(Obj, CData)", & + "The Shape of CData is not compatible" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ALLOCATE( Sigma( N, NIPS, NIPT ) ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + Sigma( :, IPS, IPT ) = CData( IPS, IPT ) % S .Shape. N + END DO + END DO + CALL Obj % getFintVector( Sigma ) + DEALLOCATE( Sigma ) + +END SUBROUTINE getFintVector_4 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_5.part b/src/submodules/STFintVector/FintVector_5.part new file mode 100755 index 000000000..1af81e412 --- /dev/null +++ b/src/submodules/STFintVector/FintVector_5.part @@ -0,0 +1,96 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_5.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_5 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_5( Obj, CData ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Fint vector for space time element; + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE Stress_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( : ) + + ! Define internal variables + INTEGER( I4B ) :: NIPS, IPS, N, NSD + REAL( DFP ), ALLOCATABLE :: Sigma( :, : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_5(Obj, CData)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + +#ifdef DEBUG_VER + IF( SIZE( CData ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_5(Obj, CData)", & + "The Shape of CData is not compatible" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + ALLOCATE( Sigma( N, NIPS ) ) + DO IPS = 1, NIPS + Sigma( :, IPS ) = CData( IPS ) % S .Shape. N + END DO + CALL Obj % getFintVector( Sigma ) + DEALLOCATE( Sigma ) + +END SUBROUTINE getFintVector_5 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_6.part b/src/submodules/STFintVector/FintVector_6.part new file mode 100755 index 000000000..adf3cc488 --- /dev/null +++ b/src/submodules/STFintVector/FintVector_6.part @@ -0,0 +1,81 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_6.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_6 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_6( Obj, CData ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Fint vector for space time element; + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE Stress_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData + + ! Define internal variables + INTEGER( I4B ) :: N, NSD + REAL( DFP ), ALLOCATABLE :: Sigma( : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_6(Obj, CData)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1,1 ) % getNSD( ) + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + ALLOCATE( Sigma( N ) ) + Sigma( : ) = CData % S .Shape. N + CALL Obj % getFintVector_3( Sigma ) + DEALLOCATE( Sigma ) + +END SUBROUTINE getFintVector_6 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_7.part b/src/submodules/STFintVector/FintVector_7.part new file mode 100755 index 000000000..533e87f98 --- /dev/null +++ b/src/submodules/STFintVector/FintVector_7.part @@ -0,0 +1,138 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_1.part +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! - Internal force vector for alpha-beta v-STFEM +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_7 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_7( Obj, Sigma, TimeVector, beta_STFEM ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Sigma; + !. . . . . . . . . . . . . . . . . . . . + + USE Voigt, ONLY : MatFromVoigtVec + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Sigma + REAL( DFP ), INTENT( IN ) :: beta_STFEM, TimeVector( 2 ) + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, I, NSD, J + + REAL( DFP ), ALLOCATABLE :: S( :, : ), Mat( :, : ), T( : ) + REAL( DFP ) :: RealVal, beta, t1, t2 + TYPE( STElemShapeData_ ), TARGET :: STElemSD2 + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_7(Obj, Sigma)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Sigma, 2 ) .NE. NIPS .OR. SIZE( Sigma, 3 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_7(Obj, Sigma)", & + "The SIZE( Sigma, 2 ) should be equal to NIPS, & + & The SIZE( Sigma, 3 ) should be equal to NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + IF( ALLOCATED( Obj % Vec3 ) ) DEALLOCATE( Obj % Vec3 ) + ALLOCATE( Obj % Vec3( NSD, NNS, NNT ) ) + Obj % Vec3 = 0.0_DFP + + t1 = TimeVector( 1 ) + t2 = TimeVector( 2 ) + beta = beta_STFEM * ( t2 - t1 ) + + CALL STElemSD2 % Initiate( Obj ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => STElemSD2 % SD( IPS, IPT ) + T = SD % dTdTheta / SD % Jt + CALL SD % setT( T ) + CALL SD % setdNTdXt( ) + END DO + END DO + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SD => STElemSD2 % SD( IPS, IPT ) + + RealVal = Obj % SD( IPS, IPT ) % Ws & + & * Obj % SD( IPS, IPT ) % Wt & + & * Obj % SD( IPS, IPT ) % Js_Xi2Xt & + & * Obj % SD( IPS, IPT ) % Jt & + & * Obj % SD( IPS, IPT ) % Thickness & + & * beta + + S = MatFromVoigtVec( Sigma( :, IPS, IPT ), "Stress" ) + + DO i = 1, NSD + Mat = S( i, 1 ) * SD % dNTdXt( :, 1, : ) + DO j = 2, NSD + Mat = Mat + S( i, j ) * SD % dNTdXt( :, j, : ) + END DO + Obj % Vec3(i, :, : ) = Obj % Vec3( i, :, : ) & + & + Mat * RealVal + END DO + + END DO + + END DO + + NULLIFY( SD ) + DEALLOCATE( Mat, T, S, STElemSD2 % SD ) + +END SUBROUTINE getFintVector_7 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/FintVector_8.part b/src/submodules/STFintVector/FintVector_8.part new file mode 100755 index 000000000..169a854a6 --- /dev/null +++ b/src/submodules/STFintVector/FintVector_8.part @@ -0,0 +1,103 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: FintVector_8.part +! Last Update : March-25-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Method for computing the Spacetime Fint vector +! - Internal force vector for alpha-beta v-STFEM +! +! HOSTING FILE +! - STFintVector_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getFintVector_8 +!------------------------------------------------------------------------------ + +SUBROUTINE getFintVector_8( Obj, CData, TimeVector, beta_STFEM ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns element Sigma; + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE Stress_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STFintVector_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) + REAL( DFP ), INTENT( IN ) :: beta_STFEM, TimeVector( 2 ) + + ! Define internal variables + INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, N, NSD + REAL( DFP ), ALLOCATABLE :: Sigma( :, :, : ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_8(Obj, CData)", & + "STFintVector_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1,1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STFintVector_Class.f90", & + "getFintVector_8(Obj, CData)", & + "The Shape of CData is not compatible" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ALLOCATE( Sigma( N, NIPS, NIPT ) ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + Sigma( :, IPS, IPT ) = CData( IPS, IPT ) % S .Shape. N + END DO + END DO + + CALL Obj % getFintVector( Sigma, TimeVector, beta_STFEM ) + DEALLOCATE( Sigma ) + +END SUBROUTINE getFintVector_8 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STFintVector/MdFiles/STFintVector_Class.md b/src/submodules/STFintVector/MdFiles/STFintVector_Class.md new file mode 100755 index 000000000..781dac88e --- /dev/null +++ b/src/submodules/STFintVector/MdFiles/STFintVector_Class.md @@ -0,0 +1,61 @@ +# Space Time Internal Force Vector + +## ToDo + +- Make construction method like `STFintVector(S1, S2)` where the S1 and S2 are Integer vectors. The size of S2 is two. and it contains `NIPS` and `NIPT`. The size of S1 should be either 1 or 3. If One allocates `Obj % Vec1(S1(1))`, If 3 then allocate `Obj % Vec3()`. + +## Description + +The class `STFintVector_Class` is the subclass of `STElemShapeData_` class. It is designed to compute the internal force vector for `SolidMechanics` applications. + +## Getting Started + +### Making the Object + +We have defined the function called `STFintVector_Pointer` that will return the pointer to the object. We have also defined the function `STFintVector()` that will return the object of `STFintVector_` type. + +```fortran +Obj => STFintVector_Pointer( ) +Obj => STFintVector_Pointer( Row, NIPS, NIPT ) +Obj => STFintVector_Pointer( I1, I2, I3, NIPS, NIPT ) +``` + +- The first call, above, is empty contructor. +- The second call, above, allocates `Obj % Vec1(row)` and `Obj%SD(NIPS, NIPT)` +- The third call, above, allocates `Obj%Vec3(I1, I2, I3)` and `Obj%SD(NIPS, NIPT)` + +```fortran +Obj = STFintVector( ) +Obj = STFintVector( Row, NIPS, NIPT ) +Obj = STFintVector( I1, I2, I3, NIPS, NIPT ) +``` + +- The first call, above, is empty contructor. +- The second call, above, allocates `Obj % Vec1(row)` and `Obj%SD(NIPS, NIPT)` +- The third call, above, allocates `Obj%Vec3(I1, I2, I3)` and `Obj%SD(NIPS, NIPT)` + +### Getting the Fint vector + +```fortran +CALL Obj % getFintVector( Sigma( :, :, : ) ) +``` + +```fortran +CALL Obj % getFintVector( Sigma( :, : ) ) +``` + +```fortran +CALL Obj % getFintVector( Sigma( : ) ) +``` + +```fortran +CALL Obj % getFintVector( CData( :, : ) ) +``` + +```fortran +CALL Obj % getFintVector( CData( : ) ) +``` + +```fortran +CALL Obj % getFintVector( CData ) +``` \ No newline at end of file diff --git a/src/submodules/STFintVector/MethodNames.part b/src/submodules/STFintVector/MethodNames.part new file mode 100644 index 000000000..0d90034a4 --- /dev/null +++ b/src/submodules/STFintVector/MethodNames.part @@ -0,0 +1,8 @@ +getFintVector_1, & +getFintVector_2, & +getFintVector_3, & +getFintVector_4, & +getFintVector_5, & +getFintVector_6, & +getFintVector_7, & +getFintVector_8 \ No newline at end of file diff --git a/src/submodules/STFintVector/STFintVector_Class.f90 b/src/submodules/STFintVector/STFintVector_Class.f90 new file mode 100755 index 000000000..08e3a0524 --- /dev/null +++ b/src/submodules/STFintVector/STFintVector_Class.f90 @@ -0,0 +1,80 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: STFintVector_Class.f90 +! Last Update : Jan-04-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - STElemShapeData_ Class is extended for computing the STFintVector. +!============================================================================== + +MODULE STFintVector_Class + USE IO + USE GlobalData + USE STElemShapeData_Class + USE STShapeData_Class + USE ShapeData_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: STFintVector, STFintVector_, STFintVector_Pointer + + !------------------------------------------------------------------------------ + ! STFintVector_ + !------------------------------------------------------------------------------ + + TYPE, EXTENDS( STElemShapeData_ ) :: STFintVector_ + + !. . . . . . . . . . . . . . . . . . . . + ! 1. This class computes the Space-Time Internal Force vector + ! for space-time element. + !. . . . . . . . . . . . . . . . . . . . + + CONTAINS + + PROCEDURE, PUBLIC, PASS :: & +#include "./MethodNames.part" + + END TYPE STFintVector_ + + !------------------------------------------------------------------------------ + ! INTERFACES + !------------------------------------------------------------------------------ + + INTERFACE STFintVector + MODULE PROCEDURE Constructor1, Constructor2, Constructor3 + END INTERFACE STFintVector + + INTERFACE STFintVector_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 + END INTERFACE STFintVector_Pointer + + !------------------------------------------------------------------------------ + ! CONTAINS + !------------------------------------------------------------------------------ + + CONTAINS + +#include "./Constructor.part" +#include "./FintVector_1.part" +#include "./FintVector_2.part" +#include "./FintVector_3.part" +#include "./FintVector_4.part" +#include "./FintVector_5.part" +#include "./FintVector_6.part" +#include "./FintVector_7.part" +#include "./FintVector_8.part" + + END MODULE STFintVector_Class + + !------------------------------------------------------------------------------ + ! + !------------------------------------------------------------------------------ diff --git a/src/submodules/STForceVector/CMakeLists.txt b/src/submodules/STForceVector/CMakeLists.txt new file mode 100644 index 000000000..d3b0f733a --- /dev/null +++ b/src/submodules/STForceVector/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/STForceVector_Method@Methods.F90 + ) diff --git a/src/submodules/STForceVector/src/STFV_1.inc b/src/submodules/STForceVector/src/STFV_1.inc new file mode 100644 index 000000000..545c440c8 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_1.inc @@ -0,0 +1,55 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_1(ans, test, term1) + !! intent of dummy variable + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_NONE + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * OUTERPROD( & + & a=test(ipt)%N(:, ips), & + & b=test(ipt)%T) + END DO + !! + END DO + !! + DEALLOCATE (realval) + !! +END SUBROUTINE STFV_1 diff --git a/src/submodules/STForceVector/src/STFV_10.inc b/src/submodules/STForceVector/src/STFV_10.inc new file mode 100644 index 000000000..4d1d43572 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_10.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_10(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & cbar(:, ips, ipt), & + & test(ipt)%dNTdt(:, :, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_10 diff --git a/src/submodules/STForceVector/src/STFV_11.inc b/src/submodules/STForceVector/src/STFV_11.inc new file mode 100644 index 000000000..a8dd461fd --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_11.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_11(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(cbar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & cbar(:, :, ips, ipt), & + & test(ipt)%dNTdt(:, :, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_11 diff --git a/src/submodules/STForceVector/src/STFV_12.inc b/src/submodules/STForceVector/src/STFV_12.inc new file mode 100644 index 000000000..30f70caa6 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_12.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_12(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_12 diff --git a/src/submodules/STForceVector/src/STFV_13.inc b/src/submodules/STForceVector/src/STFV_13.inc new file mode 100644 index 000000000..46c60fca7 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_13.inc @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_13(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & c2bar(:, ips, ipt), & + & test(ipt)%dNTdt(:, :, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_13 diff --git a/src/submodules/STForceVector/src/STFV_14.inc b/src/submodules/STForceVector/src/STFV_14.inc new file mode 100644 index 000000000..2a15e9e59 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_14.inc @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_14(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(c2bar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & c2bar(:, :, ips, ipt), & + & test(ipt)%dNTdt(:, :, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_14 diff --git a/src/submodules/STForceVector/src/STFV_15.inc b/src/submodules/STForceVector/src/STFV_15.inc new file mode 100644 index 000000000..a38e8e233 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_15.inc @@ -0,0 +1,53 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_15(ans, test, term1) + !! intent of dummy variable + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_x, DEL_y, DEL_z + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips) + END DO + !! + END DO + !! + DEALLOCATE (realval) + !! +END SUBROUTINE STFV_15 diff --git a/src/submodules/STForceVector/src/STFV_16.inc b/src/submodules/STForceVector/src/STFV_16.inc new file mode 100644 index 000000000..1e7d142a4 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_16.inc @@ -0,0 +1,58 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_16(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_x, DEL_y, DEL_z + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_16 diff --git a/src/submodules/STForceVector/src/STFV_17.inc b/src/submodules/STForceVector/src/STFV_17.inc new file mode 100644 index 000000000..4bca8d65d --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_17.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_17(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & cbar(:, ips, ipt), & + & test(ipt)%dNTdXt(:, :, term1, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_17 diff --git a/src/submodules/STForceVector/src/STFV_18.inc b/src/submodules/STForceVector/src/STFV_18.inc new file mode 100644 index 000000000..1e6718d30 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_18.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_18(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_X, DEL_Y, DEL_Z + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(cbar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & cbar(:, :, ips, ipt), & + & test(ipt)%dNTdXt(:, :, term1, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_18 diff --git a/src/submodules/STForceVector/src/STFV_19.inc b/src/submodules/STForceVector/src/STFV_19.inc new file mode 100644 index 000000000..a25da34d2 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_19.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_19(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_X, DEL_Y, DEL_Z + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_19 diff --git a/src/submodules/STForceVector/src/STFV_2.inc b/src/submodules/STForceVector/src/STFV_2.inc new file mode 100644 index 000000000..324e24d1b --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_2.inc @@ -0,0 +1,60 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_2(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_NONE + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * OUTERPROD( & + & a=test(ipt)%N(:, ips), & + & b=test(ipt)%T) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_2 diff --git a/src/submodules/STForceVector/src/STFV_20.inc b/src/submodules/STForceVector/src/STFV_20.inc new file mode 100644 index 000000000..9808f017c --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_20.inc @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_20(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_X, DEL_Y, DEL_Z + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & c2bar(:, ips, ipt), & + & test(ipt)%dNTdXt(:, :, term1, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_20 diff --git a/src/submodules/STForceVector/src/STFV_21.inc b/src/submodules/STForceVector/src/STFV_21.inc new file mode 100644 index 000000000..23b796789 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_21.inc @@ -0,0 +1,68 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_21(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(c2bar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & c2bar(:, :, ips, ipt), & + & test(ipt)%dNTdXt(:, :, term1, ips)) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_21 diff --git a/src/submodules/STForceVector/src/STFV_3.inc b/src/submodules/STForceVector/src/STFV_3.inc new file mode 100644 index 000000000..76603c036 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_3.inc @@ -0,0 +1,64 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_3(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_NONE + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & cbar(:, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_3 diff --git a/src/submodules/STForceVector/src/STFV_4.inc b/src/submodules/STForceVector/src/STFV_4.inc new file mode 100644 index 000000000..9035f097f --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_4.inc @@ -0,0 +1,64 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_4(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_NONE + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(cbar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & cbar(:, :, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_4 diff --git a/src/submodules/STForceVector/src/STFV_5.inc b/src/submodules/STForceVector/src/STFV_5.inc new file mode 100644 index 000000000..297e0089e --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_5.inc @@ -0,0 +1,66 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_5(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_NONE + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & a=test(ipt)%N(:, ips), & + & b=test(ipt)%T) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_5 diff --git a/src/submodules/STForceVector/src/STFV_6.inc b/src/submodules/STForceVector/src/STFV_6.inc new file mode 100644 index 000000000..9d1f365b2 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_6.inc @@ -0,0 +1,69 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_6(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_NONE + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & c2bar(:, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_6 diff --git a/src/submodules/STForceVector/src/STFV_7.inc b/src/submodules/STForceVector/src/STFV_7.inc new file mode 100644 index 000000000..ed62cd905 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_7.inc @@ -0,0 +1,69 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_7(ans, test, term1, c1, c1rank, c2, c2rank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_NONE + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=c1bar, val=c1) + CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! + CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(c2bar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & c2bar(:, :, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! + END DO + !! + DEALLOCATE (realval, c1bar, c2bar) + !! +END SUBROUTINE STFV_7 diff --git a/src/submodules/STForceVector/src/STFV_8.inc b/src/submodules/STForceVector/src/STFV_8.inc new file mode 100644 index 000000000..dfe340b3f --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_8.inc @@ -0,0 +1,53 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_8(ans, test, term1) + !! intent of dummy variable + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips) + END DO + !! + END DO + !! + DEALLOCATE (realval) + !! +END SUBROUTINE STFV_8 diff --git a/src/submodules/STForceVector/src/STFV_9.inc b/src/submodules/STForceVector/src/STFV_9.inc new file mode 100644 index 000000000..2ec1de665 --- /dev/null +++ b/src/submodules/STForceVector/src/STFV_9.inc @@ -0,0 +1,58 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_9(ans, test, term1, c, crank) + !! intent of dummy variable + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_t + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + !! + !! Define internal variable + !! + REAL(DFP), ALLOCATABLE :: realval(:) + REAL(DFP), ALLOCATABLE :: cbar(:, :) + INTEGER(I4B) :: ips, ipt + !! + !! main + !! + CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! + CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! + DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips) + END DO + !! + END DO + !! + DEALLOCATE (realval, cbar) + !! +END SUBROUTINE STFV_9 diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 new file mode 100644 index 000000000..aced7d296 --- /dev/null +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -0,0 +1,865 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(STForceVector_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +#include "./STFV_1.inc" +#include "./STFV_2.inc" +#include "./STFV_3.inc" +#include "./STFV_4.inc" +#include "./STFV_5.inc" +#include "./STFV_6.inc" +#include "./STFV_7.inc" + +#include "./STFV_8.inc" +#include "./STFV_9.inc" +#include "./STFV_10.inc" +#include "./STFV_11.inc" +#include "./STFV_12.inc" +#include "./STFV_13.inc" +#include "./STFV_14.inc" + +#include "./STFV_15.inc" +#include "./STFV_16.inc" +#include "./STFV_17.inc" +#include "./STFV_18.inc" +#include "./STFV_19.inc" +#include "./STFV_20.inc" +#include "./STFV_21.inc" + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_1 + !! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * & + & test(ipt)%Jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * OUTERPROD( & + & a=test(ipt)%N(:, ips), & + & b=test(ipt)%T) + END DO + !! +END DO + !! +DEALLOCATE (realval) + !! +END PROCEDURE STForceVector_1 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_2 + !! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: cbar(:, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! +CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * cbar(:, ipt) * test(ipt)%Jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * OUTERPROD( & + & a=test(ipt)%N(:, ips), & + & b=test(ipt)%T) + END DO + !! +END DO + !! +DEALLOCATE (realval, cbar) + !! +END PROCEDURE STForceVector_2 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_3 + !! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: cbar(:, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! +CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & cbar(:, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! +END DO + !! +DEALLOCATE (realval, cbar) + !! +END PROCEDURE STForceVector_3 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_4 + !! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL getInterpolation(obj=test, interpol=cbar, val=c) + !! +CALL reallocate( & + & ans, & + & SIZE(cbar, 1), & + & SIZE(cbar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & cbar(:, :, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! +END DO + !! +DEALLOCATE (realval, cbar) + !! +END PROCEDURE STForceVector_4 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_5 + !! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL getInterpolation(obj=test, interpol=c1bar, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! +CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%Jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & a=test(ipt)%N(:, ips), & + & b=test(ipt)%T) + END DO + !! +END DO + !! +DEALLOCATE (realval, c1bar, c2bar) + !! +END PROCEDURE STForceVector_5 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_6 + !! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL getInterpolation(obj=test, interpol=c1bar, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! +CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%Jt + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & c2bar(:, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! +END DO + !! +DEALLOCATE (realval, c1bar, c2bar) + !! +END PROCEDURE STForceVector_6 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_7 + !! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL getInterpolation(obj=test, interpol=c1bar, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! +CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(c2bar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c1bar(:, ipt) * test(ipt)%jt + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD( & + & c2bar(:, :, ips, ipt), & + & test(ipt)%N(:, ips), & + & test(ipt)%T) + END DO + !! +END DO + !! +DEALLOCATE (realval, c1bar, c2bar) + !! +END PROCEDURE STForceVector_7 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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 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 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 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 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 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 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 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_15 + !! + !! Define internal variable + !! +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c) + !! +CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * p1(:, :, ips, ipt) + END DO + !! +END DO + !! +DEALLOCATE (realval, p1) + !! +END PROCEDURE STForceVector_15 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_16 + !! + !! Define internal variable + !! +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! +CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * c2bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * p1(:, :, ips, ipt) + END DO + !! +END DO + !! +DEALLOCATE (realval, p1, c2bar) + !! + +END PROCEDURE STForceVector_16 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_17 + !! +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! +CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD( & + & c2bar(:, ips, ipt), & + & p1(:, :, ips, ipt)) + END DO + !! +END DO + !! +DEALLOCATE (realval, p1, c2bar) + !! +END PROCEDURE STForceVector_17 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_18 + !! + !! Define internal variable + !! +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + !! +CALL reallocate( & + & ans, & + & SIZE(c2bar, 1), & + & SIZE(c2bar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) & + & * OUTERPROD(c2bar(:, :, ips, ipt), p1(:, :, ips, ipt)) + END DO + !! +END DO + !! +DEALLOCATE (realval, p1, c2bar) + !! +END PROCEDURE STForceVector_18 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_19 + !! + !! Define internal variable + !! +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +REAL(DFP), ALLOCATABLE :: c3bar(:, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, interpol=c3bar, val=c3) + !! +CALL reallocate( & + & ans, & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js & + & * test(ipt)%ws & + & * test(ipt)%thickness & + & * c2bar(:, ipt) & + & * c3bar(:, ipt) + !! + !! + DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * p1(:, :, ips, ipt) + END DO + !! +END DO + !! +DEALLOCATE (realval, p1, c2bar, c3bar) + !! +END PROCEDURE STForceVector_19 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_20 + !! +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +REAL(DFP), ALLOCATABLE :: c3bar(:, :, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, interpol=c3bar, val=c3) + !! +CALL reallocate( & + & ans, & + & SIZE(c3bar, 1), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & + & * c2bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + ans = ans & + & + realval(ips) & + & * OUTERPROD(c3bar(:, ips, ipt), p1(:, :, ips, ipt)) + END DO + !! +END DO + !! +DEALLOCATE (realval, p1, c2bar, c3bar) + !! +END PROCEDURE STForceVector_20 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STForceVector_21 + !! + !! Define internal variable + !! +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +REAL(DFP), ALLOCATABLE :: c3bar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt + !! + !! main + !! +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, interpol=c3bar, val=c3) + !! +CALL reallocate( & + & ans, & + & SIZE(c3bar, 1), & + & SIZE(c3bar, 2), & + & SIZE(test(1)%N, 1), & + & SIZE(test(1)%T)) + !! +DO ipt = 1, SIZE(test) + !! + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * & + & c2bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + ans = ans + realval(ips) * OUTERPROD( & + & c3bar(:, :, ips, ipt), & + & p1(:, :, ips, ipt)) + !! + END DO +END DO + !! +DEALLOCATE (realval, p1, c2bar, c3bar) + !! +END PROCEDURE STForceVector_21 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/STMassMatrix/CMakeLists.txt b/src/submodules/STMassMatrix/CMakeLists.txt new file mode 100644 index 000000000..b4bb52f6d --- /dev/null +++ b/src/submodules/STMassMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/STMassMatrix_Method@Methods.F90 + ) diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part b/src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part new file mode 100755 index 000000000..8d7c9598e --- /dev/null +++ b/src/submodules/STMassMatrix/STMassMatrix-old/Constructor.part @@ -0,0 +1,144 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Nov-05-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - STMassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( Row, Col ) +! 2. Allocate Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STMassMatrix_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor_1 ) + ALLOCATE( Constructor_1 % Mat2( row, col ) ) + Constructor_1 % Mat2 = 0.0_DFP + CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( I1, I2, I3, I4 ) +! 2. Allocate Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STMassMatrix_ ), POINTER :: Constructor_2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor_2 ) + ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) + Constructor_2 % Mat4 = 0.0_DFP + CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Contractor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STMassMatrix_ ), POINTER :: Constructor_3 + + ALLOCATE( Constructor_3 ) + + END FUNCTION Constructor_3 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( Row, Col ) +! 2. Allocate Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STMassMatrix_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor1 % Mat2( row, col ) ) + Constructor1 % Mat2 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Allocate Obj % Mat2( I1, I2, I3, I4 ) +! 2. Allocate Obj % SD( NIPS, NIPT ) +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STMassMatrix_ ) :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) + Constructor2 % Mat4 = 0.0_DFP + CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Empty Contractor +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STMassMatrix_ ) :: Constructor3 + + END FUNCTION Constructor3 +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part new file mode 100755 index 000000000..46e4c0364 --- /dev/null +++ b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_15.part @@ -0,0 +1,284 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MassMatrix_15.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space time mass matrix due to linearization of convective term +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getMassMatrix_15 +!------------------------------------------------------------------------------ + +SUBROUTINE getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns mass matrix + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, :, : ) + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), dUdX( :, : ), & + dUdU( :, : ), Mat4( :, :, :, : ), Mat3( :, :, : ) + REAL( DFP ) :: RealVal + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + LOGICAL( LGT ) :: dCdU_Nodal + CLASS( STShapeData_ ), POINTER :: SD + + dCdU_Nodal = .TRUE. + + ! Flag-1 +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_15(), Flag-1", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + a = SIZE( dCdU, 3 ) + b = SIZE( dCdU, 4 ) + +#ifdef DEBUG_VER + IF( a .NE. NNS .AND. a .NE. NIPS ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + & "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & + & "The size of third index of dCdU must be equal to & + & the NNS or NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( b .NE. NNT .AND. b .NE. NIPT ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + & "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & + & "The size of fourth index of dCdU must be equal & + & to the NNT or NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + + IF( tSize .NE. NSD ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & + & "The size of first two indices of dCdU must be & + & equal to the NSD" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + ! Check the type of dCdU + + SELECT CASE( TRIM( dCdU_Type ) ) + +#ifdef DEBUG_VER + CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & + & "Space Nodal Values" ) + dCdU_Nodal = .TRUE. +#endif + CASE( "QuadPoints", "Quad", "Integration", "Integration Points", & + & "IntegrationPoints", "Quad Points") + dCdU_Nodal = .FALSE. + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_15( Obj, U, dCdU, Term1, Term2, dCdU_Type )", & + & "dCdU_Type should be either NodalValues or QuadPoints" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP; + + SELECT CASE( Term1 ) + CASE( 1 ) + SELECT CASE( Term2 ) + !( 1, 0 ) + CASE( 0 ) + ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) + DO IPT= 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + IF( dCdU_Nodal ) THEN + CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, & + & Val = dCdU_ ) + ELSE + dCdU_ = dCdU( :, :, IPS, IPT ) + END IF + + ! Compute dUdx + dUdx = SD .dVdXt. U + ! Compute dUdU + dUdU = MATMUL( dUdx, dCdU_ ) + DO a = 1, NNT + Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) + END DO + + DO b = 1, NNT + Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) + END DO + + DO q = 1, NSD + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + DO p = 1, NSD + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) & + & + Mat4 * dUdU( p, q ) + END DO + END DO + END DO + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + & "STMassMatrix_Class.f90", & + & "getMassMatrix_15(), Flag-1", & + & "Unknown value of Term2; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + SELECT CASE( Term2 ) + !( 0, 0 ) + CASE( 0 ) + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + DO IPT= 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + IF( dCdU_Nodal ) THEN + CALL SD % getInterpolationOfMatrix( STNodalValues = dCdU, & + & Val = dCdU_ ) + ELSE + dCdU_ = dCdU( :, :, IPS, IPT ) + END IF + + ! Compute dUdx + dUdx = SD .dVdXt. U + ! Compute dUdU + dUdU = MATMUL( dUdx, dCdU_ ) + + Mat2 = OUTERPROD( SD % N, SD % N ) + DO b = 1, NNT + DO a = 1, NNT + Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & + & * SD % T(b) * RealVal ) + END DO + END DO + + DO q = 1, NSD + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + DO p = 1, NSD + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + & Obj % Mat4( r1:r2, c1:c2, :, : ) & + & + Mat4 * dUdU( p, q ) + END DO + END DO + END DO + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + & "STMassMatrix_Class.f90", & + & "getMassMatrix_15(), Flag-1", & + & "Unknown value of Term2; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_15(), Flag-1", & + "Unknown value of Term1; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) + IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) + IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) + +END SUBROUTINE getMassMatrix_15 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part new file mode 100755 index 000000000..fa6f51bc7 --- /dev/null +++ b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_16.part @@ -0,0 +1,343 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MassMatrix_16.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getMassMatrix_16 +!------------------------------------------------------------------------------ + +SUBROUTINE getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns mass matrix + ! 2. dCdU( :, :, : ) changes only in space + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, :, : ) + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dCdU_( :, : ), dUdX( :, : ), & + dUdU( :, : ), Mat4( :, :, :, : ), Mat3( :, :, : ) + REAL( DFP ) :: RealVal + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + LOGICAL( LGT ) :: dCdU_Nodal + + CLASS( STShapeData_ ), POINTER :: SD + + dCdU_Nodal = .TRUE. + + ! Flag-1 +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + a = SIZE( dCdU, 3 ) + +#ifdef DEBUG_VER + IF( a .NE. NNS .AND. a .NE. NIPS ) THEN + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & + "The size of third index of dCdU must be equal to the NNS or NIPS" & + ) + Error_Flag = .TRUE. + RETURN + + END IF + + IF( tSize .NE. NSD ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + ! Check the type of dCdU + + SELECT CASE( TRIM( dCdU_Type ) ) + +#ifdef DEBUG_VER + CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & + "Space Nodal Values" ) + dCdU_Nodal = .TRUE. +#endif + + CASE( "QuadPoints", "Quad", "Integration", "Integration Points", & + "IntegrationPoints", "Quad Points") + dCdU_Nodal = .FALSE. + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & + "dCdU_Type should be either NodalValues or QuadPoints" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP; + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + IF( dCdU_Nodal ) THEN + + CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) +#ifdef DEBUG_VER + CALL Check_Error( "STMassMatrix_Class.f90>>getMassMatrix_16()", & + "CALL SD % getInterpolationOfScalar( SpaceNodalValues = dCdU, Val = dCdU_ )" ) +#endif + ELSE + + dCdU_ = dCdU( :, :, IPS ) + + END IF + + ! Compute dUdx + dUdx = SD .dVdXt. U + + ! Compute dUdU + dUdU = MATMUL( dUdx, dCdU_ ) + + + DO a = 1, NNT + + Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) + + END DO + + DO b = 1, NNT + + Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) + + END DO + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4 * dUdU( p, q ) + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + + !( 0, 0 ) + CASE( 0 ) + + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + IF( dCdU_Nodal ) THEN + + CALL SD % getInterpolationOfMatrix( SpaceNodalValues = dCdU, Val = dCdU_ ) +#ifdef DEBUG_VER + CALL Check_Error( "STMassMatrix_Class.f90>>getMassMatrix_16()", & + "CALL SD % getInterpolationOfScalar( SpaceNodalValues = dCdU, Val = dCdU_ )" ) +#endif + ELSE + + dCdU_ = dCdU( :, :, IPS ) + + END IF + + ! Compute dUdx + dUdx = SD .dVdXt. U; + + ! Compute dUdU + dUdU = MATMUL( dUdx, dCdU_ ) + + Mat2 = OUTERPROD( SD % N, SD % N ) + + DO b = 1, NNT + DO a = 1, NNT + + Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & + * SD % T(b) * RealVal ) + + END DO + + END DO + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4 * dUdU( p, q ) + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "Unknown value of Term1; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( dCdU_ ) ) DEALLOCATE( dCdU_ ) + IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) + IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) + + +END SUBROUTINE getMassMatrix_16 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part new file mode 100755 index 000000000..5df87703b --- /dev/null +++ b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_17.part @@ -0,0 +1,305 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MassMatrix_17.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getMassMatrix_17 +!------------------------------------------------------------------------------ + +SUBROUTINE getMassMatrix_17( Obj, U, dCdU, Term1, Term2, dCdU_Type ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns mass matrix + ! 2. dCdU( :, : ) does not changes in space and time + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), INTENT( IN ) :: U( :, :, : ), dCdU( :, : ) + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: dCdU_Type + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q, tSize + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dUdX( :, : ), & + dUdU( :, : ), Mat4( :, :, :, : ), & + Mat3( :, :, : ) + REAL( DFP ) :: RealVal + + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + LOGICAL( LGT ) :: dCdU_Nodal + + CLASS( STShapeData_ ), POINTER :: SD + + dCdU_Nodal = .TRUE. + + ! Flag-1 +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + ! Make Indx + tSize = SIZE( dCdU, 1 ) + +#ifdef DEBUG_VER + IF( tSize .NE. NSD ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & + "The size of first two indices of dCdU must be equal to the NSD" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + ALLOCATE( Indx( NSD, 2 ) ) + ! + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + ! Check the type of dCdU + + SELECT CASE( TRIM( dCdU_Type ) ) + +#ifdef DEBUG_VER + CASE( "Nodal", "NodalValues", "Nodal Values", "SpaceNodalValues", & + "Space Nodal Values" ) + + dCdU_Nodal = .TRUE. +#endif + + CASE( "QuadPoints", "Quad", "Integration", "Integration Points", & + "IntegrationPoints", "Quad Points") + + dCdU_Nodal = .FALSE. + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16( Obj, U, dCdU, Term1, Term2, dCdU_Type ), Flag-2", & + "dCdU_Type should be either NodalValues or QuadPoints" & + ) + Error_Flag = .TRUE. + RETURN +#endif + + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP; + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + ! Compute dUdx + dUdx = SD .dVdXt. U + + ! Compute dUdU + dUdU = MATMUL( dUdx, dCdU ) + + + DO a = 1, NNT + + Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) + + END DO + + DO b = 1, NNT + + Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) + + END DO + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4 * dUdU( p, q ) + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + + !( 0, 0 ) + CASE( 0 ) + + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + ! Compute dUdx + dUdx = SD .dVdXt. U; + + ! Compute dUdU + dUdU = MATMUL( dUdx, dCdU ) + + Mat2 = OUTERPROD( SD % N, SD % N ) + + DO b = 1, NNT + DO a = 1, NNT + + Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & + * SD % T(b) * RealVal ) + + END DO + + END DO + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4 * dUdU( p, q ) + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_16(), Flag-1", & + "Unknown value of Term1; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( dUdU ) ) DEALLOCATE( dUdU ) + IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) + +END SUBROUTINE getMassMatrix_17 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part new file mode 100755 index 000000000..7335bf1be --- /dev/null +++ b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_18.part @@ -0,0 +1,241 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MassMatrix_18.part +! Last Update : Feb-09-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space Interpolation of scalar and vector +! +! HOSTING FILE +! - MassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getMassMatrix_18 +!------------------------------------------------------------------------------ + +SUBROUTINE getMassMatrix_18( Obj, U, Term1, Term2 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns mass matrix + ! 2. dCdU( :, : ) does not changes in space and time + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), INTENT( IN ) :: U( :, :, : ) + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, NSD, & + a, b, r1, r2, c1, c2, p, q + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ), dUdX( :, : ), & + Mat4( :, :, :, : ), Mat3( :, :, : ) + REAL( DFP ) :: RealVal + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_18(), Flag-1", & + "STMassMatrix_ Object is not Initiated" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + ALLOCATE( Indx( NSD, 2 ) ) + + DO p = 1, NSD + Indx( p, 1 ) = ( p - 1 ) * NNS + 1 + Indx( p, 2 ) = p * NNS + END DO + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP; + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 0 ) + CASE( 0 ) + + ALLOCATE( Mat3( NNS, NNS, NNT ), Mat4( NNS, NNS, NNT, NNT ) ) + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + ! Compute dUdx + dUdx = SD .dVdXt. U + + DO a = 1, NNT + + Mat3( :, :, a ) = OUTERPROD( SD % dNTdt( :, a ), SD % N ) + + END DO + + DO b = 1, NNT + + Mat4( :, :, :, b ) = Mat3 * ( RealVal * SD % T( b ) ) + + END DO + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4 * dUdX( p, q ) + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_18(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" & + ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + + !( 0, 0 ) + CASE( 0 ) + + ALLOCATE( Mat4( NNS, NNS, NNT, NNT ) ) + + DO IPT= 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness + + ! Compute dUdx + dUdx = SD .dVdXt. U; + + Mat2 = OUTERPROD( SD % N, SD % N ) + + DO b = 1, NNT + DO a = 1, NNT + + Mat4( :,:,a,b) = Mat2 *( SD % T( a ) & + * SD % T(b) * RealVal ) + + END DO + + END DO + + DO q = 1, NSD + + c1 = Indx( q, 1 ); c2 = Indx( q, 2 ) + + DO p = 1, NSD + + r1 = Indx( p, 1 ); r2 = Indx( p, 2 ) + + Obj % Mat4( r1:r2, c1:c2, :, : ) = & + Obj % Mat4( r1:r2, c1:c2, :, : ) & + + Mat4 * dUdX( p, q ) + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + + CASE DEFAULT + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_18(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_18(), Flag-1", & + "Unknown value of Term1; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + IF( ALLOCATED( Mat3 ) ) DEALLOCATE( Mat3 ) + IF( ALLOCATED( Mat4 ) ) DEALLOCATE( Mat4 ) + IF( ALLOCATED( dUdX ) ) DEALLOCATE( dUdX ) + +END SUBROUTINE getMassMatrix_18 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part new file mode 100755 index 000000000..2dc5e87f5 --- /dev/null +++ b/src/submodules/STMassMatrix/STMassMatrix-old/MassMatrix_3.part @@ -0,0 +1,236 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: MassMatrix_3.part +! Last Update : Nov-16-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STMassMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getMassMatrix_3 +!------------------------------------------------------------------------------ + +SUBROUTINE getMassMatrix_3( Obj, rho, Term1, Term2 ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns mass matrix; rho is a vector + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STMassMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), INTENT( IN ) :: rho( : ) + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, a, b + REAL( DFP ) :: RealVal1, RealVal, RhoBar + REAL( DFP ), ALLOCATABLE :: Mat2( :, : ) + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg("STMassMatrix_Class.f90", & + "getMassMatrix_3(), Flag-1", & + "STMassMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = SIZE( Obj % SD( 1,1 ) % N ) + NNT = SIZE( Obj % SD( 1,1 ) % T ) + NIPS = SIZE( Obj % SD, 1 ) + NIPT = SIZE( Obj % SD, 2 ) + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS, NNS, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + SELECT CASE( Term1 ) + + CASE( 1 ) + + SELECT CASE( Term2 ) + + !( 1, 1 ) + CASE( 1 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + CALL SD % getInterpolationOfScalar( RhoBar, rho ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar + + DO b = 1, NNT + + DO a = 1, NNT + + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) + & + OUTERPROD( a = SD % dNTdt( :, a ), b = SD % dNTdt( :, b ) ) * RealVal + + END DO + + END DO + + END DO + + END DO + + !( 1, 0 ) + CASE( 0 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + CALL SD % getInterpolationOfScalar( RhoBar, rho ) +#ifdef DEBUG_VER + CALL Check_Error("STMassMatrix_Class.f90 >> getMassMatrix_3()", & + "CALL SD % getInterpolationOfScalar( RhoBar, rho )" ) +#endif + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar + + DO a = 1, NNT + + Mat2 = OUTERPROD( a = SD % dNTdt( :, a ), b = SD % N ) + + DO b = 1, NNT + + RealVal = SD % T( b ) * RealVal1 + + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & + + Mat2 * RealVal + + END DO + + END DO + + END DO + + END DO + +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_3(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CASE( 0 ) + + SELECT CASE( Term2 ) + !( 0, 1 ) + CASE( 1 ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + CALL SD % getInterpolationOfScalar( RhoBar, rho ) +#ifdef DEBUG_VER + CALL Check_Error("STMassMatrix_Class.f90 >> getMassMatrix_3()", & + "CALL SD % getInterpolationOfScalar( RhoBar, rho )" ) +#endif + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar + + DO b = 1, NNT + + Mat2 = OUTERPROD( a = SD % N, b = SD % dNTdt( :, b ) ) + + DO a = 1, NNT + + RealVal = SD % T( a ) * RealVal1 + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & + + Mat2 * RealVal + + END DO + + END DO + + END DO + + END DO + + !( 0, 0 ) + CASE( 0 ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + CALL SD % getInterpolationOfScalar( RhoBar, rho ) +#ifdef DEBUG_VER + CALL Check_Error("STMassMatrix_Class.f90 >> getMassMatrix_3()", & + "CALL SD % getInterpolationOfScalar( RhoBar, rho )" ) +#endif + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * RhoBar + Mat2 = OUTERPROD( a = SD % N, b = SD % N ) + + DO b = 1, NNT + DO a = 1, NNT + RealVal = SD % T( a ) * SD % T( b ) * RealVal1 + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & + + Mat2 * RealVal + END DO + END DO + END DO + END DO +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_3(), Flag-1", & + "Unknown value of Term2; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT +#ifdef DEBUG_VER + CASE DEFAULT + CALL Err_Msg( & + "STMassMatrix_Class.f90", & + "getMassMatrix_3(), Flag-1", & + "Unknown value of Term1; It should be 1 or 0" ) + Error_Flag = .TRUE. + RETURN +#endif + END SELECT + + CALL Obj % Mat2FromMat4( ) + NULLIFY( SD ) + ! IF( ALLOCATED( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + IF( ALLOCATED( Mat2 ) ) DEALLOCATE( Mat2 ) + +END SUBROUTINE getMassMatrix_3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md b/src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md new file mode 100755 index 000000000..27b84843b --- /dev/null +++ b/src/submodules/STMassMatrix/STMassMatrix-old/STMassMatrix_Class.md @@ -0,0 +1,596 @@ +# Space Time Mass Matrix + +## ToDo + +## Description + +The mass matrix in case of space-time finite element involves time derivative. The following four forms are possible. + +## Structure + +1. Term1 = 0, and Term2 = 0 implies following form + +$$\int_{Q_n}{N^I T_a N^J T_b}\ d\Omega dt$$ + +2. Term1 = 1, and Term2 = 0 implies following form + +$$\int_{Q_n} \frac{\partial N^I T_a}{\partial t} {N^J T_b}\ d\Omega dt$$ + +3. Term1 = 0, and Term2 = 1 implies following form + +$$\int_{Q_n} {N^I T_a} \frac{\partial N^J T_b}{\partial t} \ d\Omega dt$$ + +4. Term1 = 1, and Term2 = 1 implies following form + +$$\int_{Q_n} \frac{\partial N^I T_a}{\partial t} \frac{\partial N^J T_b}{\partial t} \ d\Omega dt$$ + +## Getting Started + +### Making the object + +Using the `STMassMatrix()` + +```fortran +Obj = STMassMatrix( ) +Obj = STMassMatrix( Row, Col, NIPS, NIPT ) +Obj = STMassMatrix( I1, I2, I3, I4, NIPS, NIPT ) +``` + +Using the `STMassMatrix_Pointer()` + +```fortran +Obj => STMassMatrix_Pointer( ) +Obj => STMassMatrix_Pointer( Row, Col, NIPS, NIPT ) +Obj => STMassMatrix_Pointer( I1, I2, I3, I4, NIPS, NIPT ) +``` + +### Getting the mass matrix + +We can compute the following matrices + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right): = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} +$$ + +using the following fortran command + +```fortran +CALL Obj % getMassMatrix( Term1, Term2 ) +``` + +The following loop has been implemented to compute these matrices + +- For **(1,1)** following loop have been implemented + +```fortran +DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho + + DO b = 1, NNT + + DO a = 1, NNT + + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) + & + OUTERPROD( a = SD % dNTdt( :, a ), b = SD % dNTdt( :, b ) ) * RealVal + + END DO + + END DO + + END DO + +END DO +``` + +- For **(1,0)** following loop have been implemented + +```fortran +DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho + + DO a = 1, NNT + + Mat2 = OUTERPROD( a = SD % dNTdt( :, a ), b = SD % N ) + + DO b = 1, NNT + + RealVal = SD % T( b ) * RealVal1 + + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & + + Mat2 * RealVal + + END DO + + END DO + + END DO + +END DO +``` + +- For **(0,1)** following loop have been implemented + +```fortran +DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho + + DO b = 1, NNT + + Mat2 = OUTERPROD( a = SD % N, b = SD % dNTdt( :, b ) ) + + DO a = 1, NNT + + RealVal = SD % T( a ) * RealVal1 + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & + + Mat2 * RealVal + + END DO + + END DO + + END DO + +END DO +``` + +- For **(0,0)** following loop have been implmented + +```fortran +DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + RealVal1 = SD % Ws * SD % Wt * SD % Js_Xi2Xt * SD % Jt * SD % Thickness * rho + Mat2 = OUTERPROD( a = SD % N, b = SD % N ) + + DO b = 1, NNT + + DO a = 1, NNT + + RealVal = SD % T( a ) * SD % T( b ) * RealVal1 + Obj % Mat4( :, :, a, b ) = Obj % Mat4( :, :, a, b ) & + + Mat2 * RealVal + + END DO + + END DO + + END DO + +END DO +``` + +--- + +The space-time mass matrices + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right): = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST} ^{ii} \left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST}^{ii} \left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +can be computed using the following fortran command. + +```fortran +CALL Obj % getMassMatrix( Term1, Term2, nCopy ) +``` + +We can compute the following space-time mass matrices + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right): = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho(\mathbf{x},t) {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho(\mathbf{x},t) {N^J}{T_b}} d\Omega dt} \right]{}^b{u_J} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho(\mathbf{x},t) \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} +$$ + +$$ +\mathop {\bf{M}}\limits_{ST} \left( {I,J,a,b} \right) = {}^a\delta {u_I}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho(\mathbf{x},t) \frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_J} +$$ + + +```fortran +CALL Obj % getMassMatrix( rho, Term1, Term2 ) +``` + +In above case `rho` can be Rank-0, Rank-1, Rank-2. + +- `rho`, Rank-0, denotes the constant value of $\rho$ in both space and time +- `rho(:)`, Rank-1, denotes the space nodal values; $\rho := \rho(\mathbf{x})$ changes only in space +- `rho(:,:)`, Rank-2, denotes the space-time nodal values; $\rho := \rho(\mathbf{x}, t)$ changes in both space and time. + +If the $\rho$ is defined on the integration points then we can use the following command. + +```fortran +CALL Obj % getMassMatrix( rho, Term1, Term2, rhoType ) +``` + +In the above case, `rhoType` can be `"NodalValues"` or `"QuadPoints"`. In this case, we `rho` can be Rank-0, Rank-1, Rank-2. + +We can compute the following matrices + +$$ +\mathop {{{\bf{M}}^{ii}}}\limits_{ST} \left( {I,J,a,b} \right): = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho ({\bf{x}},t){N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho ({\bf{x}},t){N^J}{T_b}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} \rho ({\bf{x}},t)\frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{ii}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} \rho ({\bf{x}},t)\frac{{\partial {N^J}{T_b}}}{{\partial t}}} d\Omega dt} \right]{}^b{u_{iJ}} +$$ + +the above intergrals can be computed using the following fortran command. + +```fortran +CALL Obj % getMassMatrix( rho, Term1, Term2, nCopy ) +``` + +If $\rho$ is defined on integral points then we can use following fortran command. + +In the above case, `rho` can be Rank-0, Rank-1, Rank-2. + +```fortran +CALL Obj % getMassMatrix( rho, Term1, Term2, RhoType, nCopy ) +``` + +In the above case, `rho` can be Rank-0, Rank-1, Rank-2. + +We can compute the following matrices + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{pq}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_r}}}\frac{{\partial {c_r}}}{{\partial {u_q}}}} d\Omega dt} \right]\Delta {}^b{u_{qJ}} +$$ + +using the foloowing fortran command + +```fortran +CALL Obj % getMassMatrix( U, dCdU, 0, 0, dCdU_Type) +``` + +- In the above call `dCdU` denotes the jacobian matrix for the mapping from $u \rightarrow c$ and it can be given by Rank-2, Rank-3, Rank-4. +- `dCdU_Type` can be `NodalValues` or `QuadPoints`. +- If $\frac{\partial c}{\partial u}$ changes in space and time then we must represent it using Rank-4 array. +- If $\frac{\partial c}{\partial u}$ changes only in space, and remains contant in time then we must represent it using Rank-3 array. +- If $\frac{\partial c}{\partial u}$ does not change in space and time then we must represent it using Rank-2 array. +- `U` is a space-time nodal values of velocity, and it is represented by Rank-3 array. + +We can compute the following matrices + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{pq}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_r}}}\frac{{\partial {c_r}}}{{\partial {u_q}}}} d\Omega dt} \right]\Delta {}^b{u_{qJ}} +$$ + +using the foloowing fortran command + +```fortran +CALL Obj % getMassMatrix( U, dCdU, 1, 0, dCdU_Type) +``` + +- In the above call `dCdU` denotes the jacobian matrix for the mapping from $u \rightarrow c$ and it can be given by Rank-2, Rank-3, Rank-4. +- `dCdU_Type` can be `NodalValues` or `QuadPoints`. +- If $\frac{\partial c}{\partial u}$ changes in space and time then we must represent it using Rank-4 array. +- If $\frac{\partial c}{\partial u}$ changes only in space, and remains contant in time then we must represent it using Rank-3 array. +- If $\frac{\partial c}{\partial u}$ does not change in space and time then we must represent it using Rank-2 array. +- `U` is a space-time nodal values of velocity, and it is represented by Rank-3 array. + +In case of _Naviar-Stokes_ equation or _Burgers_ Equation the jacobian $\frac{\partial c_p}{\partial u_q}$ is identity (i.e. $c(\mathbf{x},t) = u(\mathbf{x},t)$) in such case we get following matrices + +$$ +{\mathop {\bf{M}}\limits_{ST} ^{pq}}\left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {{N^I}{T_a}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_q}}}} d\Omega dt} \right]\Delta {}^b{u_{qJ}} +$$ + +the above matrix can be computed using following fortran command. + +```fortran +CALL Obj % getMassMatrix( U, 0, 0 ) +``` + +In case of _Naviar-Stokes_ equation or _Burgers_ Equation the jacobian $\frac{\partial c_p}{\partial u_q}$ is identity (i.e. $c(\mathbf{x},t) = u(\mathbf{x},t)$) in such case we get following matrices + +$$ +\mathop {\bf{M}}\limits_{ST}^{pq} \left( {I,J,a,b} \right) = {}^a\delta {u_{iI}}\left[ {\int_{{I_n}}^{} {\int_\Omega ^{} {\frac{{\partial {N^I}{T_a}}}{{\partial t}}} {N^J}{T_b}\frac{{\partial {u_p}}}{{\partial {x_q}}}} d\Omega dt} \right]{\Delta ^b}{u_{qJ}} +$$ + +The above matrix can be computed using following fortran command. + +```fortran +CALL Obj % getMassMatrix( U, 1, 0 ) +``` + +## Methods + +### _Constructor1()_ + +INTERFACE + +```fortran + FUNCTION Constructor1( Row, Col, NIPS, NIPT ) + + CLASS( STMassMatrix_ ), POINTER :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + ALLOCATE( Constructor1 ) + ALLOCATE( Constructor1 % Mat2( row, col ) ) + Constructor1 % Mat2 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) +END FUNCTION Constructor1 +``` + +DESCRIPTION + This function allocated `Obj % Mat2`, and also allocated `Obj % SD`. + +### _Constructor2()_ + +INTERFACE + +```fortran + FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) + + CLASS( STMassMatrix_ ), POINTER :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + ALLOCATE( Constructor2 ) + ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) + Constructor2 % Mat4 = 0.0_DFP + CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + END FUNCTION Constructor2 +``` + +DESCRIPTION + This function allocated `Obj % Mat4`, and also allocated `Obj % SD`. + + +### _getMassMatrix\_1()_ + +INTERFACE + +```fortran +SUBROUTINE getMassMatrix_1( Obj, rho, Term1, Term2 ) + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +This subroutine computes the mass matrix. `rho` is constant in this case which can be used as a scale. + +### _getMassMatrix\_2()_ + +INTERFACE + +```fortran + SUBROUTINE getMassMatrix_2( Obj, Term1, Term2 ) + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +In this case `rho` $\rho$ is absent. + +### _getMAssMatrix\_3()_ + +INTERFACE + +```fortran + SUBROUTINE getMassMatrix_3( Obj, rho, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +In this case `rho` $\rho$ is a vector, i.e. it is the spatial nodal values of scalar variable `rho`. In this case, `rho` $rho$ does not change with time, but only varies in space. + +### _getMAssMatrix\_4()_ + +INTERFACE + +```fortran +SUBROUTINE getMassMatrix_4( Obj, rho, Term1, Term2 ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 +``` + +DESCRIPTION + +In this case `rho` $\rho$ is a two dimensional array, i.e. it is the space-time nodal values of scalar variable `rho`. The first index of `rho` denotes the spatial node, and second index of `rho` denotes the temporal node. In this case, `rho` $rho$ changes in both space and time domain. + +### _getMAssMatrix\_5()_ + +INTERFACE + +```fortran + SUBROUTINE getMassMatrix_5( Obj, rho, Term1, Term2, rhoType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: RhoType +``` + +DESCRIPTION + +In this case `rho` $\rho$ is a two dimensional array. If `rhotype` is `[Integration Points, IntegrationPoints, Quad Points, QuadPoints, Quad]` then it is defined at space-time integation points. In this case the number of rows in `rho` must be equal to `NIPS` and number of columns in `rho` must be equal to the `NIPT`. The first index of `rho` denotes the spatial integation point, and second index of `rho` denotes the temporal integration points. In this case, `rho` $rho$ changes in both space and time domain. This method will be useful in forming the *stabilized* matrices. If `rhotype` is `[Nodal, Nodal Values, NodalValues, STNodalValues]` then `rho` is defined at space-time nodal values and the methods call the `getMassMatrix_4()` for computation. + +### _getMassMatrix\_6()_ + +INTERFACE + +```fortran + SUBROUTINE getMassMatrix_6( Obj, rho, Term1, Term2, rhoType ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2 + CHARACTER( LEN = * ), INTENT( IN ) :: RhoType +``` + +DESCRIPTION + +In this case `rho` $\rho$ is a one dimensional array. If `rhotype` is `[Integration Points, IntegrationPoints, Quad Points, QuadPoints, Quad]` then it is defined at space integation points. In this case the size of `rho` must be equal to `NIPS`. The elements of `rho` denotes the spatial integation pointIn this case, `rho` $rho$ changes in only in space, and not in time domain. This method will be useful in forming the *stabilized* matrices. If `rhotype` is `[Nodal, Nodal Values, NodalValues, STNodalValues]` then `rho` is defined at space nodal values and the methods call the `getMassMatrix_3()` for computation. + +### _getMassMatrix\_7()_ + +INTERFACE + +```fortran + SUBROUTINE getMassMatrix_7( Obj, rho, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: nCopy, Term1, Term2 +``` + +DESCRIPTION + +In this case `rho` $\rho$ is a real scalar. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** + +### _getMassMatrix\_8()_ + +INTERFACE + +```fortran + SUBROUTINE getMassMatrix_8( Obj, Term1, Term2, nCopy ) + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + INTEGER( I4B ), INTENT( IN ) :: nCopy, Term1, Term2 +``` + +DESCRIPTION + +In this case `rho` is absent. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** + +### _getMassMatrix\_9()_ + +INTERFACE + +```fortran + SUBROUTINE getMassMatrix_9( Obj, rho, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy +``` + +DESCRIPTION + +In this case `rho` is a vector, and represent the spatial nodal values. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** + +### _getMassMatrix\_10()_ + +INTERFACE + +```fortran +SUBROUTINE getMassMatrix_10( Obj, rho, Term1, Term2, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy +``` + +DESCRIPTION + +In this case `rho` is a 2D array, and represent the space-time nodal values. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** + +### _getMassMatrix\_11()_ + +INTERFACE + +```fortran +SUBROUTINE getMassMatrix_11( Obj, rho, Term1, Term2, rhoType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: RhoType +``` + +DESCRIPTION + +In this case `rho` is a 2D array, and can represent the space-time nodal values, or space-time integation point values. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** + +### _getMassMatrix\_12()_ + +INTERFACE + +```fortran +SUBROUTINE getMassMatrix_12( Obj, rho, Term1, Term2, rhoType, nCopy ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STMassMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: rho + INTEGER( I4B ), INTENT( IN ) :: Term1, Term2, nCopy + CHARACTER( LEN = * ), INTENT( IN ) :: RhoType +``` + +DESCRIPTION + +In this case `rho` is a vector, and can represent the space-nodal values or space-integration value. This subroutine computes the `nCopy` of the mass matrix. **This Need More Explaination** diff --git a/src/submodules/STMassMatrix/src/STMM_1.inc b/src/submodules/STMassMatrix/src/STMM_1.inc new file mode 100644 index 000000000..78b3c1818 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_1.inc @@ -0,0 +1,57 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) + +PURE SUBROUTINE STMM_1(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER( I4B ) :: ips, ipt + !! + !! main + !! + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + !! + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE(IaJb, realval) + !! +END SUBROUTINE STMM_1 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_10.inc b/src/submodules/STMassMatrix/src/STMM_10.inc new file mode 100644 index 000000000..5fcce6471 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_10.inc @@ -0,0 +1,80 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) +REAL(DFP), ALLOCATABLE :: vbar(:, :, :) +REAL(DFP), ALLOCATABLE :: Jij(:, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6,3), SIZE(m6,4), & + & SIZE(test(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD( trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +!! +DEALLOCATE (m6, IJija, vbar, Jij, realval) +!! +!END SUBROUTINE STMM_10a diff --git a/src/submodules/STMassMatrix/src/STMM_10a.inc b/src/submodules/STMassMatrix/src/STMM_10a.inc new file mode 100644 index 000000000..0979a4ad1 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_10a.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) +#include "./STMM_10.inc" +END SUBROUTINE STMM_10a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_10b.inc b/src/submodules/STMassMatrix/src/STMM_10b.inc new file mode 100644 index 000000000..f11b6859a --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_10b.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_10b(ans, test, trial, term1, term2, rho) +#include "./STMM_10.inc" +END SUBROUTINE STMM_10b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_10c.inc b/src/submodules/STMassMatrix/src/STMM_10c.inc new file mode 100644 index 000000000..8ae76e2d0 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_10c.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_10c(ans, test, trial, term1, term2, rho) +#include "./STMM_10.inc" +END SUBROUTINE STMM_10c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_10d.inc b/src/submodules/STMassMatrix/src/STMM_10d.inc new file mode 100644 index 000000000..48a4c4925 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_10d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_10d(ans, test, trial, term1, term2, rho) +#include "./STMM_10.inc" +END SUBROUTINE STMM_10d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11.inc b/src/submodules/STMassMatrix/src/STMM_11.inc new file mode 100644 index 000000000..dd37d0b9d --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_11.inc @@ -0,0 +1,79 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +! 11a, 11b, 11c +! ij = outerprod(vbar(:,ips, ipt), [1.0_DFP]) +! ij = diag(vbar(:,ips, ipt)) +! ij = outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, ij, vbar, realval) + !! +!END SUBROUTINE STMM_11a diff --git a/src/submodules/STMassMatrix/src/STMM_11a.inc b/src/submodules/STMassMatrix/src/STMM_11a.inc new file mode 100644 index 000000000..378e06b24 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_11a.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho) +#include "./STMM_11.inc" +END SUBROUTINE STMM_11a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11b.inc b/src/submodules/STMassMatrix/src/STMM_11b.inc new file mode 100644 index 000000000..3f5a41f50 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_11b.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_11b(ans, test, trial, term1, term2, rho) +#include "./STMM_11.inc" +END SUBROUTINE STMM_11b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11c.inc b/src/submodules/STMassMatrix/src/STMM_11c.inc new file mode 100644 index 000000000..828532a8e --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_11c.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_11c(ans, test, trial, term1, term2, rho) +#include "./STMM_11.inc" +END SUBROUTINE STMM_11c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_11d.inc b/src/submodules/STMassMatrix/src/STMM_11d.inc new file mode 100644 index 000000000..f2324013d --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_11d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_11d(ans, test, trial, term1, term2, rho) +#include "./STMM_11.inc" +END SUBROUTINE STMM_11d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12.inc b/src/submodules/STMassMatrix/src/STMM_12.inc new file mode 100644 index 000000000..fae4e434d --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_12.inc @@ -0,0 +1,77 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_t +CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: vbar(:, :, :) +REAL(DFP), ALLOCATABLE :: ij(:, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:,a, ips), & + & trial(ipt)%dNTdt(:,b, ips), & + & ij ) + END DO + END DO + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, ij, vbar, realval) +!! +!END SUBROUTINE STMM_12c diff --git a/src/submodules/STMassMatrix/src/STMM_12a.inc b/src/submodules/STMassMatrix/src/STMM_12a.inc new file mode 100644 index 000000000..81e82b880 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_12a.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_12a(ans, test, trial, term1, term2, rho) +#include "./STMM_12.inc" +END SUBROUTINE STMM_12a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12b.inc b/src/submodules/STMassMatrix/src/STMM_12b.inc new file mode 100644 index 000000000..8257c7e17 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_12b.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_12b(ans, test, trial, term1, term2, rho) +#include "./STMM_12.inc" +END SUBROUTINE STMM_12b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12c.inc b/src/submodules/STMassMatrix/src/STMM_12c.inc new file mode 100644 index 000000000..c525ec0fc --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_12c.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho) +#include "./STMM_12.inc" +END SUBROUTINE STMM_12c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_12d.inc b/src/submodules/STMassMatrix/src/STMM_12d.inc new file mode 100644 index 000000000..e09ea6718 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_12d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_12d(ans, test, trial, term1, term2, rho) +#include "./STMM_12.inc" +END SUBROUTINE STMM_12d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_13.inc b/src/submodules/STMassMatrix/src/STMM_13.inc new file mode 100644 index 000000000..f5b9512b2 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_13.inc @@ -0,0 +1,69 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_13(ans, test, trial, term1, term2, rho) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_none +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: rho +!! matrix +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=kbar, val=rho) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), SIZE(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval( ips ) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & kbar(:,:,ips, ipt) , & + & test(ipt)%T, & + & trial(ipt)%T) + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, kbar, realval) +!! +END SUBROUTINE STMM_13 diff --git a/src/submodules/STMassMatrix/src/STMM_14.inc b/src/submodules/STMassMatrix/src/STMM_14.inc new file mode 100644 index 000000000..93e435df6 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_14.inc @@ -0,0 +1,79 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +PURE SUBROUTINE STMM_14(ans, test, trial, term1, term2, rho) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: rho +!! matrix +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: Jij(:, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=kbar, val=rho) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), SIZE(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6,3), SIZE(m6,4), & + & SIZE(test(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD( trial(ipt)%N(:, ips), kbar(:,:,ips,ipt) ) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +!! +DEALLOCATE (m6, IJija, kbar, Jij, realval) + !! +END SUBROUTINE STMM_14 diff --git a/src/submodules/STMassMatrix/src/STMM_15.inc b/src/submodules/STMassMatrix/src/STMM_15.inc new file mode 100644 index 000000000..a3cca6c48 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_15.inc @@ -0,0 +1,71 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), SIZE(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6,6) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:,ips), & + & trial(ipt)%dNTdt(:,b,ips), & + & kbar(:,:,ips, ipt), test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, kbar, realval) + !! +END SUBROUTINE STMM_15 diff --git a/src/submodules/STMassMatrix/src/STMM_16.inc b/src/submodules/STMassMatrix/src/STMM_16.inc new file mode 100644 index 000000000..f2f7934f4 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_16.inc @@ -0,0 +1,74 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_16(ans, test, trial, term1, term2, rho) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_t +CLASS(FEVariable_), INTENT(IN) :: rho +!! matrix +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), size(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:,a, ips), & + & trial(ipt)%dNTdt(:,b, ips), & + & kbar(:,:,ips, ipt) ) + END DO + END DO + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, kbar, realval) + !! +END SUBROUTINE STMM_16 diff --git a/src/submodules/STMassMatrix/src/STMM_17.inc b/src/submodules/STMassMatrix/src/STMM_17.inc new file mode 100644 index 000000000..4afc80018 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_17.inc @@ -0,0 +1,24 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) +PURE SUBROUTINE STMM_17(ans, test, trial, term1, term2, c1, c2, opt) +#include "./STMM_17_20.inc" +END SUBROUTINE STMM_17 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_17_20.inc b/src/submodules/STMassMatrix/src/STMM_17_20.inc new file mode 100644 index 000000000..79fa78f10 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_17_20.inc @@ -0,0 +1,65 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_none +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! scalar +INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: m2(:, :) +REAL(DFP), ALLOCATABLE :: m2b(:, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips +!! +!! 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=m2, val=c1) +CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * & + & trial(ipt)%thickness * trial(ipt)%wt * & + & trial(ipt)%jt * m2(:, ipt) * m2b(:,ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) * OUTERPROD( _NT1_, _NT2_ ) + END DO + !! +END DO +!! +CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) +!! +IF(PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) +!! +DEALLOCATE (IaJb, m2, m2b, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_18.inc b/src/submodules/STMassMatrix/src/STMM_18.inc new file mode 100644 index 000000000..1407d84b2 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_18.inc @@ -0,0 +1,24 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) +PURE SUBROUTINE STMM_18(ans, test, trial, term1, term2, c1, c2, opt) +#include "./STMM_17_20.inc" +END SUBROUTINE STMM_18 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_19.inc b/src/submodules/STMassMatrix/src/STMM_19.inc new file mode 100644 index 000000000..9296ef514 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_19.inc @@ -0,0 +1,24 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) +PURE SUBROUTINE STMM_19(ans, test, trial, term1, term2, c1, c2, opt) +#include "./STMM_17_20.inc" +END SUBROUTINE STMM_19 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_2.inc b/src/submodules/STMassMatrix/src/STMM_2.inc new file mode 100644 index 000000000..d84cddf82 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_2.inc @@ -0,0 +1,58 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) + +PURE SUBROUTINE STMM_2(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + !! + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER( I4B ) :: ips, ipt + !! + !! main + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE(iajb, realval) + !! +END SUBROUTINE STMM_2 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_20.inc b/src/submodules/STMassMatrix/src/STMM_20.inc new file mode 100644 index 000000000..0ec551b6e --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_20.inc @@ -0,0 +1,24 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) +PURE SUBROUTINE STMM_20(ans, test, trial, term1, term2, c1, c2, opt) +#include "./STMM_17_20.inc" +END SUBROUTINE STMM_20 +#undef _NT1_ +#undef _NT2_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21.inc b/src/submodules/STMassMatrix/src/STMM_21.inc new file mode 100644 index 000000000..7d80f5c6f --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_21.inc @@ -0,0 +1,70 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_none +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: vbar(:, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval( ips ) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, vbar, c1bar, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_21a.inc b/src/submodules/STMassMatrix/src/STMM_21a.inc new file mode 100644 index 000000000..68df5ffea --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_21a.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_21a(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_21.inc" +END SUBROUTINE STMM_21a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21b.inc b/src/submodules/STMassMatrix/src/STMM_21b.inc new file mode 100644 index 000000000..54d57e74c --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_21b.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_21b(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_21.inc" +END SUBROUTINE STMM_21b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21c.inc b/src/submodules/STMassMatrix/src/STMM_21c.inc new file mode 100644 index 000000000..68f1b8758 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_21c.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_21c(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_21.inc" +END SUBROUTINE STMM_21c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_21d.inc b/src/submodules/STMassMatrix/src/STMM_21d.inc new file mode 100644 index 000000000..e0f1d53c9 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_21d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_21d(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_21.inc" +END SUBROUTINE STMM_21d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22.inc b/src/submodules/STMassMatrix/src/STMM_22.inc new file mode 100644 index 000000000..8b90d56fd --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_22.inc @@ -0,0 +1,81 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: vbar(:, :, :) +REAL(DFP), ALLOCATABLE :: Jij(:, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6,3), SIZE(m6,4), & + & SIZE(test(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD( trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +!! +DEALLOCATE (m6, IJija, vbar, Jij, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_22a.inc b/src/submodules/STMassMatrix/src/STMM_22a.inc new file mode 100644 index 000000000..4d6212951 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_22a.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_22a(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_22.inc" +END SUBROUTINE STMM_22a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22b.inc b/src/submodules/STMassMatrix/src/STMM_22b.inc new file mode 100644 index 000000000..09dc7ccb2 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_22b.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_22b(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_22.inc" +END SUBROUTINE STMM_22b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22c.inc b/src/submodules/STMassMatrix/src/STMM_22c.inc new file mode 100644 index 000000000..d552c33f2 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_22c.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_22c(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_22.inc" +END SUBROUTINE STMM_22c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_22d.inc b/src/submodules/STMassMatrix/src/STMM_22d.inc new file mode 100644 index 000000000..af54f9ece --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_22d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_22d(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_22.inc" +END SUBROUTINE STMM_22d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23.inc b/src/submodules/STMassMatrix/src/STMM_23.inc new file mode 100644 index 000000000..392086dc1 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_23.inc @@ -0,0 +1,80 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +! 11a, 11b, 11c +! ij = outerprod(vbar(:,ips, ipt), [1.0_DFP]) +! ij = diag(vbar(:,ips, ipt)) +! ij = outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_none +INTEGER(I4B), INTENT(IN) :: term2 +!! del_t +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: vbar(:, :, :) +REAL(DFP), ALLOCATABLE :: ij(:, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +!! +DEALLOCATE (m6, ij, c1bar, vbar, realval) \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23a.inc b/src/submodules/STMassMatrix/src/STMM_23a.inc new file mode 100644 index 000000000..fc06e9bb3 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_23a.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_23a(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_23.inc" +END SUBROUTINE STMM_23a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23b.inc b/src/submodules/STMassMatrix/src/STMM_23b.inc new file mode 100644 index 000000000..95334e747 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_23b.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_23b(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_23.inc" +END SUBROUTINE STMM_23b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23c.inc b/src/submodules/STMassMatrix/src/STMM_23c.inc new file mode 100644 index 000000000..1a82dcb1a --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_23c.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_23c(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_23.inc" +END SUBROUTINE STMM_23c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_23d.inc b/src/submodules/STMassMatrix/src/STMM_23d.inc new file mode 100644 index 000000000..36f29346e --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_23d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_23d(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_23.inc" +END SUBROUTINE STMM_23d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24.inc b/src/submodules/STMassMatrix/src/STMM_24.inc new file mode 100644 index 000000000..864486652 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_24.inc @@ -0,0 +1,77 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_t +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: vbar(:, :, :) +REAL(DFP), ALLOCATABLE :: ij(:, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar( :, ipt ) + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:,a, ips), & + & trial(ipt)%dNTdt(:,b, ips), & + & ij ) + END DO + END DO + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, ij, vbar, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_24a.inc b/src/submodules/STMassMatrix/src/STMM_24a.inc new file mode 100644 index 000000000..a558659e5 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_24a.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_24a(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24b.inc b/src/submodules/STMassMatrix/src/STMM_24b.inc new file mode 100644 index 000000000..4bd8e0aac --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_24b.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_24b(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24c.inc b/src/submodules/STMassMatrix/src/STMM_24c.inc new file mode 100644 index 000000000..9bf563a93 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_24c.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_24c(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_24d.inc b/src/submodules/STMassMatrix/src/STMM_24d.inc new file mode 100644 index 000000000..edce1b039 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_24d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_24d(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_25.inc b/src/submodules/STMassMatrix/src/STMM_25.inc new file mode 100644 index 000000000..5c3c7a257 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_25.inc @@ -0,0 +1,73 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_25(ans, test, trial, term1, term2, c1, c2) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_none +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! matrix +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), SIZE(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar( :, ipt ) + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval( ips ) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & kbar(:,:,ips, ipt) , & + & test(ipt)%T, & + & trial(ipt)%T) + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, kbar, c1bar, realval) +!! +END SUBROUTINE STMM_25 diff --git a/src/submodules/STMassMatrix/src/STMM_26.inc b/src/submodules/STMassMatrix/src/STMM_26.inc new file mode 100644 index 000000000..cfff28b2b --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_26.inc @@ -0,0 +1,84 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_26(ans, test, trial, term1, term2, c1, c2) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! matrix +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: Jij(:, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), SIZE(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6,3), SIZE(m6,4), & + & SIZE(test(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD( trial(ipt)%N(:, ips), kbar(:,:,ips,ipt) ) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +!! +DEALLOCATE (m6, IJija, kbar, Jij, realval) + !! +END SUBROUTINE STMM_26 diff --git a/src/submodules/STMassMatrix/src/STMM_27.inc b/src/submodules/STMassMatrix/src/STMM_27.inc new file mode 100644 index 000000000..5e54e6983 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_27.inc @@ -0,0 +1,75 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: c1 + !! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), SIZE(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6,6) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:,ips), & + & trial(ipt)%dNTdt(:,b,ips), & + & kbar(:,:,ips, ipt), test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, kbar, c1bar, realval) + !! +END SUBROUTINE STMM_27 diff --git a/src/submodules/STMassMatrix/src/STMM_28.inc b/src/submodules/STMassMatrix/src/STMM_28.inc new file mode 100644 index 000000000..6bd0c9393 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_28.inc @@ -0,0 +1,77 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_28(ans, test, trial, term1, term2, c1, c2) +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_t +INTEGER(I4B), INTENT(IN) :: term2 +!! del_t +CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar +CLASS(FEVariable_), INTENT(IN) :: c2 +!! matrix +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar,1), size(kbar,2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:,a, ips), & + & trial(ipt)%dNTdt(:,b, ips), & + & kbar(:,:,ips, ipt) ) + END DO + END DO + !! + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, kbar, c1bar, realval) + !! +END SUBROUTINE STMM_28 diff --git a/src/submodules/STMassMatrix/src/STMM_3.inc b/src/submodules/STMassMatrix/src/STMM_3.inc new file mode 100644 index 000000000..ad25c2b4e --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_3.inc @@ -0,0 +1,57 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) + +PURE SUBROUTINE STMM_3(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER( I4B ) :: ips, ipt + !! + !! main + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE(iajb, realval) + !! +END SUBROUTINE STMM_3 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_4.inc b/src/submodules/STMassMatrix/src/STMM_4.inc new file mode 100644 index 000000000..9d24d98f2 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_4.inc @@ -0,0 +1,57 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) + +PURE SUBROUTINE STMM_4(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! main + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE(iajb, realval) + !! +END SUBROUTINE STMM_4 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_5.inc b/src/submodules/STMassMatrix/src/STMM_5.inc new file mode 100644 index 000000000..b536a0c53 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_5.inc @@ -0,0 +1,61 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) + +PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, rhobar, realval) + !! +END SUBROUTINE STMM_5 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_6.inc b/src/submodules/STMassMatrix/src/STMM_6.inc new file mode 100644 index 000000000..9424215c7 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_6.inc @@ -0,0 +1,61 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) + +PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, realval) + !! +END SUBROUTINE STMM_6 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_7.inc b/src/submodules/STMassMatrix/src/STMM_7.inc new file mode 100644 index 000000000..8474fde1e --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_7.inc @@ -0,0 +1,66 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) + +PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + IF(present(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, rhobar, realval) + !! +END SUBROUTINE STMM_7 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_8.inc b/src/submodules/STMassMatrix/src/STMM_8.inc new file mode 100644 index 000000000..326e32b62 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_8.inc @@ -0,0 +1,61 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) + +PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, rhobar, realval) + !! +END SUBROUTINE STMM_8 +#undef _NT1_ +#undef _NT2_ diff --git a/src/submodules/STMassMatrix/src/STMM_9.inc b/src/submodules/STMassMatrix/src/STMM_9.inc new file mode 100644 index 000000000..9d6980288 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_9.inc @@ -0,0 +1,67 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) +CLASS(STElemshapeData_), INTENT(IN) :: test(:) +CLASS(STElemshapeData_), INTENT(IN) :: trial(:) +INTEGER(I4B), INTENT(IN) :: term1 +!! del_none +INTEGER(I4B), INTENT(IN) :: term2 +!! del_none +CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable +REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) +REAL(DFP), ALLOCATABLE :: vbar(:, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! +CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! +CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! +DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval( ips ) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO +END DO +!! +CALL Convert(from=m6, to=ans) +DEALLOCATE (m6, vbar, realval) +!! diff --git a/src/submodules/STMassMatrix/src/STMM_9a.inc b/src/submodules/STMassMatrix/src/STMM_9a.inc new file mode 100644 index 000000000..73c430e5f --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_9a.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_9a(ans, test, trial, term1, term2, rho) +#include "./STMM_9.inc" +END SUBROUTINE STMM_9a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ diff --git a/src/submodules/STMassMatrix/src/STMM_9b.inc b/src/submodules/STMassMatrix/src/STMM_9b.inc new file mode 100644 index 000000000..f33bfbf85 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_9b.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_9b(ans, test, trial, term1, term2, rho) +#include "./STMM_9.inc" +END SUBROUTINE STMM_9b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMM_9c.inc b/src/submodules/STMassMatrix/src/STMM_9c.inc new file mode 100644 index 000000000..591c35093 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_9c.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_9c(ans, test, trial, term1, term2, rho) +#include "./STMM_9.inc" +END SUBROUTINE STMM_9c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ diff --git a/src/submodules/STMassMatrix/src/STMM_9d.inc b/src/submodules/STMassMatrix/src/STMM_9d.inc new file mode 100644 index 000000000..e29329c72 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMM_9d.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_9d(ans, test, trial, term1, term2, rho) +#include "./STMM_9.inc" +END SUBROUTINE STMM_9d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ \ No newline at end of file diff --git a/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 b/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 new file mode 100644 index 000000000..78aa30ae6 --- /dev/null +++ b/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 @@ -0,0 +1,3653 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(STMassMatrix_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_1(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + + !! Internal variable + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ips, ipt + + CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) * OUTERPROD( & + & OUTERPROD(test(ipt)%N(:, ips), test(ipt)%T), & + & OUTERPROD(trial(ipt)%N(:, ips), trial(ipt)%T)) + END DO + END DO + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + DEALLOCATE (IaJb, realval) + +END SUBROUTINE STMM_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_2(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ips, ipt + + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD( & + & test(ipt)%dNTdt(:, :, ips), & + & OUTERPROD(trial(ipt)%N(:, ips), trial(ipt)%T)) + END DO + END DO + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + DEALLOCATE (iajb, realval) + +END SUBROUTINE STMM_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_3(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ips, ipt + + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD( & + & OUTERPROD(test(ipt)%N(:, ips), test(ipt)%T), & + & trial(ipt)%dNTdt(:, :, ips)) + END DO + END DO + + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + + DEALLOCATE (iajb, realval) + +END SUBROUTINE STMM_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) + +PURE SUBROUTINE STMM_4(ans, test, trial, term1, term2, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_t + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! main + !! + CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, realval) + !! +END SUBROUTINE STMM_4 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) + +PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, rhobar, realval) + !! +END SUBROUTINE STMM_5 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) + +PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, realval) + !! +END SUBROUTINE STMM_6 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) + +PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, rhobar, realval) + !! +END SUBROUTINE STMM_7 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) + +PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_none + CLASS(FEVariable_), INTENT(IN) :: rho + !! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: rhobar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips + !! + !! 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=rhobar, val=rho) + !! + DO ipt = 1, SIZE(trial) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + DO ips = 1, SIZE(realval) + iajb = iajb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + END DO + !! + CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) + !! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) + !! + DEALLOCATE (iajb, rhobar, realval) + !! +END SUBROUTINE STMM_8 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_9a(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, realval) +!! +END SUBROUTINE STMM_9a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_9b(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, realval) +!! +END SUBROUTINE STMM_9b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_9c(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, realval) +!! +END SUBROUTINE STMM_9c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_9d(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, realval) +!! +END SUBROUTINE STMM_9d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +!! +!END SUBROUTINE STMM_10a +END SUBROUTINE STMM_10a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_10b(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +!! +!END SUBROUTINE STMM_10a +END SUBROUTINE STMM_10b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_10c(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +!! +!END SUBROUTINE STMM_10a +END SUBROUTINE STMM_10c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_10d(ans, test, trial, term1, term2, rho) +!PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +!! +!END SUBROUTINE STMM_10a +END SUBROUTINE STMM_10d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, ij, vbar, realval) + !! +END SUBROUTINE STMM_11a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_11b(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, ij, vbar, realval) +END SUBROUTINE STMM_11b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_11c(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, ij, vbar, realval) + !! +!END SUBROUTINE STMM_11a +END SUBROUTINE STMM_11c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_11d(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, ij, vbar, realval) + !! +END SUBROUTINE STMM_11d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_12a(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij) + END DO + END DO + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, ij, vbar, realval) +END SUBROUTINE STMM_12a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_12b(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij) + END DO + END DO + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, ij, vbar, realval) +END SUBROUTINE STMM_12b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij) + END DO + END DO + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, ij, vbar, realval) +END SUBROUTINE STMM_12c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_12d(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: rho +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij) + END DO + END DO + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, ij, vbar, realval) +END SUBROUTINE STMM_12d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_13(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! matrix +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=kbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & kbar(:, :, ips, ipt), & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, kbar, realval) +!! +END SUBROUTINE STMM_13 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +PURE SUBROUTINE STMM_14(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: rho +!! matrix +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=kbar, val=rho) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), kbar(:, :, ips, ipt)) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, kbar, Jij, realval) + !! +END SUBROUTINE STMM_14 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: rho + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & kbar(:, :, ips, ipt), test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, kbar, realval) + !! +END SUBROUTINE STMM_15 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_16(ans, test, trial, term1, term2, rho) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: rho +!! matrix +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & kbar(:, :, ips, ipt)) + END DO + END DO + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, kbar, realval) + !! +END SUBROUTINE STMM_16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) +PURE SUBROUTINE STMM_17(ans, test, trial, term1, term2, c1, c2, opt) + + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: m2b(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips +!! +!! 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=m2, val=c1) + CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * & + & trial(ipt)%thickness * trial(ipt)%wt * & + & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + !! + END DO +!! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) +!! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) +!! + DEALLOCATE (IaJb, m2, m2b, realval) +END SUBROUTINE STMM_17 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ OUTERPROD(trial(ipt)%N(:,ips), trial(ipt)%T) +PURE SUBROUTINE STMM_18(ans, test, trial, term1, term2, c1, c2, opt) + + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: m2b(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips +!! +!! 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=m2, val=c1) + CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * & + & trial(ipt)%thickness * trial(ipt)%wt * & + & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + !! + END DO +!! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) +!! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) +!! + DEALLOCATE (IaJb, m2, m2b, realval) +END SUBROUTINE STMM_18 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ OUTERPROD(test(ipt)%N(:,ips), test(ipt)%T) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) +PURE SUBROUTINE STMM_19(ans, test, trial, term1, term2, c1, c2, opt) + + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: m2b(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips +!! +!! 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=m2, val=c1) + CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * & + & trial(ipt)%thickness * trial(ipt)%wt * & + & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + !! + END DO +!! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) +!! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) +!! + DEALLOCATE (IaJb, m2, m2b, realval) +END SUBROUTINE STMM_19 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _NT1_ test(ipt)%dNTdt(:,:,ips) +#define _NT2_ trial(ipt)%dNTdt(:,:,ips) +PURE SUBROUTINE STMM_20(ans, test, trial, term1, term2, c1, c2, opt) + + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! scalar + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) + REAL(DFP), ALLOCATABLE :: m2(:, :) + REAL(DFP), ALLOCATABLE :: m2b(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips +!! +!! 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=m2, val=c1) + CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * & + & trial(ipt)%thickness * trial(ipt)%wt * & + & trial(ipt)%jt * m2(:, ipt) * m2b(:, ipt) + !! + DO ips = 1, SIZE(realval) + IaJb = IaJb + realval(ips) * OUTERPROD(_NT1_, _NT2_) + END DO + !! + END DO +!! + CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) +!! + IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) +!! + DEALLOCATE (IaJb, m2, m2b, realval) +END SUBROUTINE STMM_20 +#undef _NT1_ +#undef _NT2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_21a(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, c1bar, realval) +END SUBROUTINE STMM_21a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_21b(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, c1bar, realval) +END SUBROUTINE STMM_21b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_21c(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, c1bar, realval) +END SUBROUTINE STMM_21c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_21d(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & _KIJ_, & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, vbar, c1bar, realval) +END SUBROUTINE STMM_21d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_22a(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +END SUBROUTINE STMM_22a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_22b(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +END SUBROUTINE STMM_22b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_22c(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +END SUBROUTINE STMM_22c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_22d(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), _KIJ_) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, vbar, Jij, realval) +END SUBROUTINE STMM_22d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_23a(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, ij, c1bar, vbar, realval) +END SUBROUTINE STMM_23a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_23b(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, ij, c1bar, vbar, realval) +END SUBROUTINE STMM_23b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_23c(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, ij, c1bar, vbar, realval) +END SUBROUTINE STMM_23c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_23d(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! vector +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: vbar(:, :, :) + REAL(DFP), ALLOCATABLE :: ij(:, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & _DIM1_, _DIM2_, & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + ij = _KIJ_ + !! + DO b = 1, SIZE(trial(1)%T) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & ij, test(ipt)%T) + END DO + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, ij, c1bar, vbar, realval) +END SUBROUTINE STMM_23d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), [1.0_DFP]) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ 1 + +PURE SUBROUTINE STMM_24a(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24a + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod([1.0_DFP], vbar(:,ips, ipt)) +#define _DIM1_ 1 +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_24b(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24b + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ diag(vbar(:,ips, ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_24c(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24c + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#define _KIJ_ outerprod(vbar(:,ips, ipt), vbar(:,ips,ipt)) +#define _DIM1_ SIZE(vbar, 1) +#define _DIM2_ SIZE(vbar, 1) + +PURE SUBROUTINE STMM_24d(ans, test, trial, term1, term2, c1, c2) +#include "./STMM_24.inc" +END SUBROUTINE STMM_24d + +#undef _DIM1_ +#undef _DIM2_ +#undef _KIJ_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_25(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_none + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! matrix +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + m6 = m6 + realval(ips) * outerprod( & + & outerprod(test(ipt)%N(:, ips), & + & trial(ipt)%N(:, ips)), & + & kbar(:, :, ips, ipt), & + & test(ipt)%T, & + & trial(ipt)%T) + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, kbar, c1bar, realval) +!! +END SUBROUTINE STMM_25 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_26(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_none + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! matrix +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: IJija(:, :, :, :, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: Jij(:, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + CALL Reallocate(IJija, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(m6, 3), SIZE(m6, 4), & + & SIZE(test(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + Jij = OUTERPROD(trial(ipt)%N(:, ips), kbar(:, :, ips, ipt)) + !! + DO a = 1, SIZE(m6, 5) + IJija(:, :, :, :, a) = outerprod(test(ipt)%dNTdt(:, a, ips), Jij) + END DO + !! + m6 = m6 + realval(ips) * outerprod(IJija, trial(ipt)%T) + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) +!! + DEALLOCATE (m6, IJija, kbar, Jij, realval) + !! +END SUBROUTINE STMM_26 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! del_none + INTEGER(I4B), INTENT(IN) :: term2 + !! del_t + CLASS(FEVariable_), INTENT(IN) :: c1 + !! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 + !! vector + !! + !! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b + !! + !! main + !! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + !! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) + !! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + m6(:, :, :, :, :, b) = m6(:, :, :, :, :, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%N(:, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & kbar(:, :, ips, ipt), test(ipt)%T) + END DO + END DO + END DO + !! + CALL Convert(from=m6, to=ans) + !! + DEALLOCATE (m6, kbar, c1bar, realval) + !! +END SUBROUTINE STMM_27 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STMM_28(ans, test, trial, term1, term2, c1, c2) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CLASS(STElemshapeData_), INTENT(IN) :: trial(:) + INTEGER(I4B), INTENT(IN) :: term1 +!! del_t + INTEGER(I4B), INTENT(IN) :: term2 +!! del_t + CLASS(FEVariable_), INTENT(IN) :: c1 +!! scalar + CLASS(FEVariable_), INTENT(IN) :: c2 +!! matrix +!! +!! Internal variable + REAL(DFP), ALLOCATABLE :: m6(:, :, :, :, :, :) + REAL(DFP), ALLOCATABLE :: c1bar(:, :) + REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) + REAL(DFP), ALLOCATABLE :: realval(:) + INTEGER(I4B) :: ipt, ips, a, b +!! +!! main +!! + CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +!! + CALL Reallocate(m6, & + & SIZE(test(1)%N, 1), & + & SIZE(trial(1)%N, 1), & + & SIZE(kbar, 1), SIZE(kbar, 2), & + & SIZE(test(1)%T), & + & SIZE(trial(1)%T)) +!! + DO ipt = 1, SIZE(trial) + !! + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & + & trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + !! + DO ips = 1, SIZE(realval) + !! + DO b = 1, SIZE(m6, 6) + DO a = 1, SIZE(m6, 5) + m6(:, :, :, :, a, b) = m6(:, :, :, :, a, b) & + & + realval(ips) & + & * outerprod( & + & test(ipt)%dNTdt(:, a, ips), & + & trial(ipt)%dNTdt(:, b, ips), & + & kbar(:, :, ips, ipt)) + END DO + END DO + !! + END DO + END DO +!! + CALL Convert(from=m6, to=ans) + DEALLOCATE (m6, kbar, c1bar, realval) + !! +END SUBROUTINE STMM_28 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MakeDiagonalCopiesIJab(ans, ncopy) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(IN) :: ncopy + !! + REAL(DFP), ALLOCATABLE :: m2(:, :), m4(:, :, :, :) + INTEGER(I4B) :: a, b + !! + m4 = ans + !! + CALL Reallocate(ans, & + & ncopy * SIZE(m4, 1), & + & ncopy * SIZE(m4, 2), & + & SIZE(m4, 3), & + & SIZE(m4, 4)) + !! + DO b = 1, SIZE(m4, 4) + DO a = 1, SIZE(m4, 3) + CALL MakeDiagonalCopies(from=m4(:, :, a, b), to=m2, ncopy=ncopy) + ans(:, :, a, b) = m2 + END DO + END DO + !! + DEALLOCATE (m2, m4) +END SUBROUTINE MakeDiagonalCopiesIJab + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STMassMatrix_1 +SELECT CASE (term1) + !! + !! + !! + !! +CASE (del_t) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! del_t + !! del_t + CALL STMM_4(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + CASE (del_none) + !! del_t + !! del_none + CALL STMM_2(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + END SELECT + !! + !! + !! + !! +CASE (del_none) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! del_none + !! del_t + CALL STMM_3(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + CASE (del_none) + !! del_none + !! del_none + CALL STMM_1(ans=ans, test=test, trial=trial, term1=term1, & + & term2=term2, opt=opt) + !! + END SELECT +END SELECT + !! +END PROCEDURE mat4_STMassMatrix_1 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STMassMatrix_2 + !! +SELECT CASE (term1) + !! + !! + !! + !! +CASE (del_t) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! del_t + !! del_t + !! + CALL STMM_8(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2, opt=opt) + !! + CASE (del_none) + !! + !! del_t + !! del_none + !! + CALL STMM_6(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2, opt=opt) + !! + END SELECT + !! + !! + !! + !! +CASE (del_none) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! del_none + !! del_t + !! + CALL STMM_7(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2, opt=opt) + !! + CASE (del_none) + !! + !! del_none + !! del_none + !! + CALL STMM_5(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2, opt=opt) + !! + END SELECT +END SELECT + !! +END PROCEDURE mat4_STMassMatrix_2 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STMassMatrix_3 + !! + !! main + !! +SELECT CASE (term1) + !! + !! + !! + !! +CASE (del_t) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! del_t + !! del_t + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_12a(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_12b(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_12c(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_12d(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + END SELECT + !! + CASE (del_none) + !! + !! del_t + !! del_none + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_10a(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_10b(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_10c(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_10d(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + END SELECT + !! + END SELECT + !! + !! + !! + !! +CASE (del_none) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! del_none + !! del_t + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_11a(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_11b(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_11c(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_11d(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + END SELECT + !! + CASE (del_none) + !! + !! del_none + !! del_none + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_9a(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_9b(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_9c(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_9d(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + END SELECT + !! + END SELECT +END SELECT + !! +END PROCEDURE mat4_STMassMatrix_3 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STMassMatrix_4 + !! + !! main + !! +SELECT CASE (term1) + !! + !! + !! + !! +CASE (del_t) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! del_t + !! del_t + !! + CALL STMM_16(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + !! + CASE (del_none) + !! + !! del_t, + !! del_none + !! + CALL STMM_14(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + !! + END SELECT + !! + !! + !! + !! +CASE (del_none) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! del_none, + !! del_t + !! + CALL STMM_15(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + !! + CASE (del_none) + !! + !! del_none, + !! del_none, + !! + CALL STMM_13(ans=ans, test=test, trial=trial, rho=rho, & + & term1=term1, term2=term2) + !! + END SELECT +END SELECT +END PROCEDURE mat4_STMassMatrix_4 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STMassMatrix_5 +SELECT CASE (term1) + !! + !! + !! + !! +CASE (del_t) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! scalar + !! scalar + !! del_t + !! del_t + !! + CALL STMM_20(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2, opt=opt) + !! + CASE (del_none) + !! + !! scalar + !! scalar + !! del_t + !! del_none + !! + CALL STMM_18(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2, opt=opt) + !! + END SELECT + !! +CASE (del_none) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! scalar + !! scalar + !! del_none + !! del_t + !! + CALL STMM_19(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2, opt=opt) + !! + CASE (del_none) + !! + !! scalar + !! scalar + !! del_none + !! del_none + !! + CALL STMM_17(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2, opt=opt) + !! + END SELECT +END SELECT + !! +END PROCEDURE mat4_STMassMatrix_5 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STMassMatrix_6 + !! +SELECT CASE (term1) + !! + !! + !! + !! +CASE (del_t) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! scalar + !! vector + !! del_t + !! del_t + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_24a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_24b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_24c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_24d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + END SELECT + !! + CASE (del_none) + !! + !! scalar + !! vector + !! del_t + !! del_none + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_22a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_22b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_22c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_22d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + END SELECT + !! + END SELECT + !! + !! + !! + !! +CASE (del_none) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! scalar + !! vector + !! del_none + !! del_t + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_23a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_23b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_23c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_23d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + END SELECT + !! + CASE (del_none) + !! + !! scalar + !! vector + !! del_none + !! del_none + !! + SELECT CASE (opt) + CASE (1) + CALL STMM_21a(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (2) + CALL STMM_21b(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (3) + CALL STMM_21c(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + CASE (4) + CALL STMM_21d(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + END SELECT + !! + END SELECT +END SELECT + !! +END PROCEDURE mat4_STMassMatrix_6 + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat4_STMassMatrix_7 +SELECT CASE (term1) + !! + !! + !! + !! +CASE (del_t) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! scalar + !! matrix + !! del_t + !! del_t + !! + CALL STMM_28(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + !! + CASE (del_none) + !! + !! scalar + !! matrix + !! del_t + !! del_none + !! + CALL STMM_26(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + !! + END SELECT + !! +CASE (del_none) + !! + SELECT CASE (term2) + !! + CASE (del_t) + !! + !! scalar + !! matrix + !! del_none + !! del_t + !! + CALL STMM_27(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + !! + CASE (del_none) + !! + !! scalar + !! matrix + !! del_none + !! del_none + !! + CALL STMM_25(ans=ans, test=test, trial=trial, c1=c1, c2=c2, & + & term1=term1, term2=term2) + !! + END SELECT +END SELECT +END PROCEDURE mat4_STMassMatrix_7 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/STStiffnessMatrix/Constructor.part b/src/submodules/STStiffnessMatrix/Constructor.part new file mode 100755 index 000000000..088f03b8e --- /dev/null +++ b/src/submodules/STStiffnessMatrix/Constructor.part @@ -0,0 +1,142 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construct the STStiffnessMatrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STStiffnessMatrix_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor_1 ) + + ALLOCATE( Constructor_1 % Mat2( row, col ) ) + + Constructor_1 % Mat2 = 0.0_DFP + + CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construct the STStiffnessMatrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STStiffnessMatrix_ ), POINTER :: Constructor_2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor_2 ) + + ALLOCATE( Constructor_2 % Mat4( I1, I2, I3, I4 ) ) + + Constructor_2 % Mat4 = 0.0_DFP + + CALL Constructor_2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor_3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construct the STStiffnessMatrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( STStiffnessMatrix_ ), POINTER :: Constructor_3 + ALLOCATE( Constructor_3 ) + END FUNCTION Constructor_3 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor1( Row, Col, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construct the STStiffnessMatrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STStiffnessMatrix_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: row, col, NIPS, NIPT + + ALLOCATE( Constructor1 % Mat2( row, col ) ) + Constructor1 % Mat2 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( I1, I2, I3, I4, NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construct the STStiffnessMatrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STStiffnessMatrix_ ) :: Constructor2 + INTEGER( I4B ), INTENT( IN ) :: I1, I2, I3, I4, NIPS, NIPT + + ALLOCATE( Constructor2 % Mat4( I1, I2, I3, I4 ) ) + Constructor2 % Mat4 = 0.0_DFP + CALL Constructor2 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! Constructor3 +!------------------------------------------------------------------------------ + + FUNCTION Constructor3( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construct the STStiffnessMatrix +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( STStiffnessMatrix_ ) :: Constructor3 + + END FUNCTION Constructor3 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md b/src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md new file mode 100755 index 000000000..777b05c6c --- /dev/null +++ b/src/submodules/STStiffnessMatrix/MdFiles/STStiffnessMatrix_Class.md @@ -0,0 +1,421 @@ +# Space Time Stiffness Matrix Class + +## Description + +## Getting Started + +### Making the Object + +`STStiffnessMatrix_` object is child of `STElemShapeData_` class. This class is designed for _solid mechanics_ applications. The object of this class can be initiated using following commands. + +Calling the inherited method `initiate` + +```fortran +CALL STElemSD % Initiate( NIPS = NIPS, NIPT = NIPT) +CALL STElemSD % InitiateMatrix( row= row, col = col) +CALL STElemSD % InitiateMatrix( I1 = I1, I2 = I2, I3 = I3, I4= I4) +``` + +We can use the `STStiffnessMatrix_Pointer()` function, which returns the pointer to the object + +```fortran +CLASS( STELemShapeData_ ), POINTER :: STElemSD + +STElemSD => STStiffnessMatrix_Pointer( ) +STElemSD => STStiffnessMatrix_Pointer( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) +STElemSD => STStiffnessMatrix_Pointer( I1, I2, I3, I4, I5, NIPS, NIPT) +``` + +We can also use the function `STStiffnessMatrix()` function, which returns the object + +```fortran +STElemSD = STStiffnessMatrix( ) +STElemSD = STStiffnessMatrix( row = row, col = col, NIPS = NIPS, NIPT = NIPT ) +STElemSD = STStiffnessMatrix( I1, I2, I3, I4, I5, NIPS, NIPT) +``` + +### Getting the Stiffness Matrix + +We have devided the Stiffness matrix into three basic categories. See the next section Theory for the explanation. + +```fortran +CALL Obj % getStiffnessMatrix( Cijkl ) +``` + +In above case Cijkl is a fortran array. It can be Rank-4, Rank-3, Rank-2. + +```fortran +CALL Obj % getStiffnessMatrix( CData ) +``` + +In above case `CData` is `ConstitutiveData_` object. It can be Rank-2, Rank-1 or Rank-0. + +```fortran +CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) +``` + +In above case Cijkl is a fortran array. It can be Rank-4, Rank-3, Rank-2. Inaddition, TimeVec is a length-2 rank-0 fortran array. It contains the starting and ending time i.e. t1, and t2. `IntegrationSide` is the character. It can be `Left`, `Right`, `Both`, or `NA`. See the Next section for more details + +```fortran +CALL Obj % getStiffnessMatrix( CData, TimeVector, IntegrationSide ) +``` + +In above case `CData` is `ConstitutiveData_` object. It can be Rank-2, Rank-1 or Rank-0. Inaddition, TimeVec is a length-2 rank-0 fortran array. It contains the starting and ending time i.e. t1, and t2. `IntegrationSide` is the character. It can be `Left`, `Right`, `Both`, or `NA`. See the Next section for more details. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +## Theory + +Very often we need to compute the following matrices in solid-mechanics applications. + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ + +Note here, $u \in R^{nsd}$. Generally, `Cijkl` has minor symmetry. + +$$C_{ijkl} = C_{jikl}$$ +$$C_{ijkl} = C_{ijlk}$$ + +The shape of ${}^{4}Mat(:, :, a, b)$ will be `(NSD*NNS, NSD*NNS)`. It will be a block matrix, and shape of each block will be `(NNS, NNS)`. For more details see the notes (_page 55_) + + +> These tasks are performed by following methods; `getStiffnessMatrix_1()`, `getStiffnessMatrix_2()`, and `getStiffnessMatrix_3()` + + +## Methods + +### getStiffnessMatrix_1() + +INTERFACE + +```fortran + SUBROUTINE getStiffnessMatrix_1( Obj, Cijkl ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl +``` + +DESCRIPTION + +- This methods computes the Stiffness matrix. +- `Cijkl(:,:,:,:)` is a four dimensional array of shape `(M,M,NIPS, NIPT)`. In two dimensional case it `M` should be either 3 or 4. In case of three dimensional it should be 6. See _page 55_ in the notes for maore details. In this case Cijkl may change in space and time domain. The third index denotes the spatial integration point and fourth index denotes the temporal integration points. + +CODE SNIPPET + +```fortran +CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat4 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat4 ) ) DEALLOCATE( DummyMat4 ) +ALLOCATE( DummyMat4( 3, 3, NIPS, NIPT ) ) +DummyMat4 = 0.0_DFP; DummyMat4( 1,1, :, : ) = 1.0_DFP; +DummyMat4( 2,2, :, : ) = 1.0_DFP; DummyMat4( 3,3, :, : ) = 1.0_DFP + +CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat4 ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getStiffnessMatrix_1( Cijkl = DummyMat4 )' +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getStiffnessMatrix_1( Cijkl = DummyMat4 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 + -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 + 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 + -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 + 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` +> Note that in this case integrad is quadratic in time, therefore we need atleast 2 integration points in the time. This condition may change when the mesh is moving. Note that the row sum and column sum is zero as expected. + +### getStiffnessMatrix_2() + +INTERFACE + +```fortran + SUBROUTINE getStiffnessMatrix_2( Obj, Cijkl ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Cijkl +``` + +DESCRIPTION + +- This methods computes the Stiffness matrix. +- `Cijkl(:,:,:)` is a three dimensional array of shape `(M,M,NIPS)`. In two dimensional case it `M` should be either 3 or 4. In case of three dimensional it should be 6. See _page 55_ in the notes for more details. In this case, Cijkl changes only in space, and remains constant in time domain. The third index, denotes the spatial integration point. + +CODE SNIPPET + +```fortran +CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat3 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( 3, 3, NIPS ) ) +DummyMat3 = 0.0_DFP; DummyMat3( 1,1, : ) = 1.0_DFP; +DummyMat3( 2,2, : ) = 1.0_DFP; DummyMat3( 3,3, : ) = 1.0_DFP + +CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat3 ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getStiffnessMatrix_2( Cijkl = DummyMat3 )' +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getStiffnessMatrix_2( Cijkl = DummyMat3 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 + -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 + 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 + -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 + 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` + +### getStiffnessMatrix_3() + +INTERFACE + +```fortran + SUBROUTINE getStiffnessMatrix_3( Obj, Cijkl ) + + USE Utility, ONLY : OUTERPROD + + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Cijkl +``` + +DESCRIPTION + +- This methods computes the Stiffness matrix. +- `Cijkl(:,:)` is a three dimensional array of shape `(M,M)`. In two dimensional case it `M` should be either 3 or 4. In case of three dimensional it should be 6. See _page 55_ in the notes for more details. In this case, Cijkl does not change in both space and time. + +CODE SNIPPET + +```fortran +CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat2 ) +``` + +SYMBOLIC CALCULATION + +$${}^{4}Mat(I, J, a, b) = \delta {}^{a} u_iI \int_{Q_n} \frac{\partial N^I T_a}{ \partial x_j} C_{ijkl} \frac{\partial N^J T_b}{ \partial x_l} {dQ} \quad {}^{b}u_kJ$$ + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( 3, 3 ) ) +DummyMat2 = 0.0_DFP; DummyMat2( 1,1 ) = 1.0_DFP; +DummyMat2( 2,2 ) = 1.0_DFP; DummyMat2( 3,3 ) = 1.0_DFP + +CALL STElemSD % getStiffnessMatrix( Cijkl = DummyMat2 ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getStiffnessMatrix_3( Cijkl = DummyMat2 )' +CALL STElemSD % DisplayMatrix4( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getStiffnessMatrix_3( Cijkl = DummyMat2 ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +4D MATRIX, MAT4(:,:,:,:) :: + +Mat4( :, :, 1, 1 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 + -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 + 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 + +Mat4( :, :, 1, 2 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 1 ) + + 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.8333333E-01 + -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.8333333E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 0.2222222 -0.5555556E-01 -0.1111111 -0.5555556E-01 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.5555556E-01 0.2222222 -0.5555556E-01 -0.1111111 + -0.8333333E-01 -0.8333333E-01 0.8333333E-01 0.8333333E-01 -0.1111111 -0.5555556E-01 0.2222222 -0.5555556E-01 + 0.8333333E-01 0.8333333E-01 -0.8333333E-01 -0.8333333E-01 -0.5555556E-01 -0.1111111 -0.5555556E-01 0.2222222 + +Mat4( :, :, 2, 2 ) + + 0.4444444 -0.1111111 -0.2222222 -0.1111111 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.1111111 0.4444444 -0.1111111 -0.2222222 0.1666667 -0.1666667 -0.1666667 0.1666667 + -0.2222222 -0.1111111 0.4444444 -0.1111111 -0.1666667 0.1666667 0.1666667 -0.1666667 + -0.1111111 -0.2222222 -0.1111111 0.4444444 -0.1666667 0.1666667 0.1666667 -0.1666667 + 0.1666667 0.1666667 -0.1666667 -0.1666667 0.4444444 -0.1111111 -0.2222222 -0.1111111 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.1111111 0.4444444 -0.1111111 -0.2222222 + -0.1666667 -0.1666667 0.1666667 0.1666667 -0.2222222 -0.1111111 0.4444444 -0.1111111 + 0.1666667 0.1666667 -0.1666667 -0.1666667 -0.1111111 -0.2222222 -0.1111111 0.4444444 +``` \ No newline at end of file diff --git a/src/submodules/STStiffnessMatrix/MethodNames.part b/src/submodules/STStiffnessMatrix/MethodNames.part new file mode 100644 index 000000000..5f0902822 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/MethodNames.part @@ -0,0 +1,14 @@ +getStiffnessMatrix_1, & +getStiffnessMatrix_2, & +getStiffnessMatrix_3, & +getStiffnessMatrix_4, & +getStiffnessMatrix_5, & +getStiffnessMatrix_6, & +getStiffnessMatrix_7, & +getStiffnessMatrix_8, & +getStiffnessMatrix_9, & +getStiffnessMatrix_10, & +getStiffnessMatrix_11, & +getStiffnessMatrix_12, & +getStiffnessMatrix_13, & +getStiffnessMatrix_14 diff --git a/src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 b/src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 new file mode 100755 index 000000000..15bf11953 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/STStiffnessMatrix_Class.f90 @@ -0,0 +1,85 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: STStiffnessMatrix_Class.f90 +! Last Update : Nov-21-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - Stiffness matrices for space-time elements +! +!============================================================================== + + MODULE STStiffnessMatrix_Class + USE GlobalData + USE IO + USE STElemShapeData_Class + USE STShapeData_Class + USE ShapeData_Class + IMPLICIT NONE + + PRIVATE + PUBLIC :: STStiffnessMatrix_, STStiffnessMatrix_POINTER, STStiffnessMatrix + +!------------------------------------------------------------------------------ +! STElemShapeData_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( STElemShapeData_ ) :: STStiffnessMatrix_ + +!. . . . . . . . . . . . . . . . . . . . +! 1. Stiffness matrices for the space-time element for & +! solid mechanics application +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + + PROCEDURE, PUBLIC, PASS :: & +#include "./MethodNames.part" + + END TYPE STStiffnessMatrix_ + +!------------------------------------------------------------------------------ +! INTERFACES +!------------------------------------------------------------------------------ + + + INTERFACE STStiffnessMatrix_POINTER + MODULE PROCEDURE Constructor_1, Constructor_2, Constructor_3 + END INTERFACE + + INTERFACE STStiffnessMatrix + MODULE PROCEDURE Constructor1, Constructor2, Constructor3 + END INTERFACE + +!------------------------------------------------------------------------------ +! CONTAINS +!------------------------------------------------------------------------------ + + CONTAINS + +#include "./Constructor.part" +#include "./StiffnessMatrix_1.part" +#include "./StiffnessMatrix_2.part" +#include "./StiffnessMatrix_3.part" +#include "./StiffnessMatrix_4.part" +#include "./StiffnessMatrix_5.part" +#include "./StiffnessMatrix_6.part" +#include "./StiffnessMatrix_7.part" +#include "./StiffnessMatrix_8.part" +#include "./StiffnessMatrix_9.part" +#include "./StiffnessMatrix_10.part" +#include "./StiffnessMatrix_11.part" +#include "./StiffnessMatrix_12.part" +#include "./StiffnessMatrix_13.part" +#include "./StiffnessMatrix_14.part" + + END MODULE STStiffnessMatrix_Class + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part new file mode 100755 index 000000000..c75a6ab4c --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_1.part @@ -0,0 +1,176 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_1.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_1 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_1( Obj, Cijkl ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns Stiffness matrix + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + & i, j, sizeOFC + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + REAL( DFP ) :: RealVal + REAL( DFP ), ALLOCATABLE :: Ce( :, : ), BMat( :, : ), BTMat( :, : ) + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + Error_Flag = .FALSE. + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_1()", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Cijkl, 3 ) .NE. NIPS .OR. SIZE( Cijkl, 4 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_1()", & + "The SIZE( Cijkl, 3 ) should be NIPS, & + & SIZE( Cijkl, 4 ) should be NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_1()", & + "The size of first and second dimension of Cijkl must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SizeOfC = SIZE( Cijkl, 1 ) + +#ifdef DEBUG_VER + IF( NSD .EQ. 2 ) THEN + IF( SizeOfC .NE. 4 & + .AND. SizeOfC .NE. 3 ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_1()", & + "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & + & either 3, 4" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF + IF( NSD .EQ. 3 ) THEN + IF( SizeOfC .NE. 6 ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_1(), Flag-5", & + "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & + & equal to 6" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF +#endif + + ! Make Indx + SELECT CASE( NSD ) + CASE( 1 ) + ALLOCATE( Indx( 1, 1 ) ) + Indx = 1 + CASE( 2 ) + Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) + CASE( 3 ) + Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) + END SELECT + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) + ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) + BMat = 0.0_DFP + BTMat = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + DO j = 1, NSD + DO i = 1, NSD + Ce( (i-1) * NSD + 1 : i * NSD, (j-1) * NSD + 1 : j * NSD ) & + & = Cijkl( Indx( :, i ), Indx( :, j ), IPS, IPT ) + END DO + END DO + + DO b = 1, NNT + DO i = 1, NSD + BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & + & TRANSPOSE( SD % dNTdXt( :, :, b ) ) + END DO + DO aa = 1, NNT + DO i = 1, NSD + BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & + & SD % dNTdXt( :, :, aa ) + END DO + Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & + & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + DEALLOCATE( Ce, Indx, BMat, BTMat ) + +END SUBROUTINE getStiffnessMatrix_1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part new file mode 100755 index 000000000..4d5f05e3f --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_10.part @@ -0,0 +1,106 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_10.part +! Last Update : Jan-06-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_10 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_10( Obj, CData, TimeVector, IntegrationSide ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns Stiffness matrix + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE MaterialJacobian_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + TYPE( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, :, : ) + INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, NSD, N + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix(Obj, CData)", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix(Obj, CData)", & + "The Shape Of CData is not compatible" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ! Make Cijkl + ALLOCATE( Cijkl( N, N, NIPS, NIPT ) ) + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + Cijkl( :, :, IPS, IPT ) = CData( IPS, IPT ) % C .Cijkl. N + END DO + END DO + + CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) + + DEALLOCATE( Cijkl ) + +END SUBROUTINE getStiffnessMatrix_10 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part new file mode 100755 index 000000000..6a6a76002 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_11.part @@ -0,0 +1,104 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_11.part +! Last Update : Jan-06-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_11 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_11( Obj, CData, TimeVector, IntegrationSide ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. CData is the one dimensional array + ! 3. In this case material tangent doesnot vary with the time. + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE MaterialJacobian_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + TYPE( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( : ) + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, : ) + INTEGER( I4B ) :: NIPS, IPS, NSD, N + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_11(Obj, CData)", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + +#ifdef DEBUG_VER + IF( SIZE( CData ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_11(Obj, CData)", & + "The Shape Of CData is not compatible" & + ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ALLOCATE( Cijkl( N, N, NIPS ) ) + + DO IPS = 1, NIPS + Cijkl( :, :, IPS ) = CData( IPS ) % C .Cijkl. N + END DO + + CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) + + DEALLOCATE( Cijkl ) + +END SUBROUTINE getStiffnessMatrix_11 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part new file mode 100755 index 000000000..aab4cd54c --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_12.part @@ -0,0 +1,85 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_12.part +! Last Update : Jan-06-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_12 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_12( Obj, CData, TimeVector, IntegrationSide ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. CData is constant + ! 3. In this case material tangent doesnot vary with the space-time. + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE MaterialJacobian_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Cijkl( :, : ) + INTEGER( I4B ) :: NSD, N + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_12(Obj, CData)", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ! Make Cijkl + ALLOCATE( Cijkl( N, N ) ) + Cijkl( :, : ) = CData % C .Cijkl. N + CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide ) + DEALLOCATE( Cijkl ) + +END SUBROUTINE getStiffnessMatrix_12 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part new file mode 100755 index 000000000..1d201a323 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_13.part @@ -0,0 +1,240 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_13.part +! Last Update : March-15-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space time stiffness matrix for alpha-beta v-ST/FEM +! - beta_STFEM is beta => +! - Effective coefficient will be beta_STFEM * dt +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_13 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_13( Obj, Cijkl, TimeVector, IntegrationSide, & + & beta_STFEM ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. Time Integration is character it should be "left", "right" + !. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY : OUTERPROD + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + REAL( DFP ), INTENT( IN ) :: beta_STFEM + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, r1, r2, c1, c2, M, sizeOFC, p, q + REAL( DFP ), ALLOCATABLE :: dNTdXt( :, :, : ), T( : ), dNTdXt2( :, :, : ), & + dNTdXt3( :, :, : ) + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + REAL( DFP ) :: Ws, Js, thick, RealVal, Jt, Wt, Kij, t1, t2, Theta, beta + TYPE( STElemShapeData_ ), TARGET :: STElemSD, STElemSD2 + CLASS( STShapeData_ ), POINTER :: SD => NULL( ), SD2 => NULL( ) + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_13()", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Cijkl, 3 ) .NE. NIPS .OR. SIZE( Cijkl, 4 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_13()", & + "The SIZE( Cijkl, 3 ) should be NIPS, & + & SIZE( Cijkl, 4 ) should be NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_13()", & + "The size of first and second dimension of Cijkl must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SizeOfC = SIZE( Cijkl, 1 ) + +#ifdef DEBUG_VER + IF( NSD .EQ. 2 ) THEN + IF( SizeOfC .NE. 4 & + & .AND. SizeOfC .NE. 3 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_13()", & + & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & + & either 3, 4" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF + IF( NSD .EQ. 3 ) THEN + IF( SizeOfC .NE. 6 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_13(), Flag-5", & + & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & + & equal to 6" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF +#endif + + ! Make Indx + SELECT CASE( NSD ) + CASE( 1 ) + ALLOCATE( Indx( 1, 1 ) ) + Indx = 1 + CASE( 2 ) + Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) + CASE( 3 ) + Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) + END SELECT + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + t1 = TimeVector( 1 ) + t2 = TimeVector( 2 ) + + beta = beta_STFEM * ( t2 - t1 ) + + ! Make copy of Obj + CALL STElemSD % Initiate( Obj ) + CALL STElemSD2 % Initiate( Obj ) + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => STElemSD % SD( IPS, IPT ) + Theta = SD % Theta + T = SD .TimeIntegration. [t1, t2, Theta] + + CALL SD % setT( T ) + CALL SD % setdNTdXt( ) + SD2 => STElemSD2 % SD( IPS, IPT ) + T = SD2 % dTdTheta / SD2 % Jt + CALL SD2 % setT( T ) + CALL SD2 % setdNTdXt( ) + END DO + END DO + + SD => NULL( ) + + DO p = 1, NSD + DO q = 1, NSD + DO aa = 1, NNT + DO b = 1, NNT + DO i = 1, M + DO j = 1, M + r1 = ( i - 1_I4B ) * NNS + 1_I4B + r2 = i*NNS + c1 = ( j - 1_I4B ) * NNS + 1_I4B + c2 = j*NNS + DO IPT = 1, NIPT + DO IPS = 1, NIPS + Kij = Cijkl( Indx( p, i ), Indx( q, j ), IPS, IPT ) + Ws = Obj % SD( IPS, IPT ) % getWs( ) + Wt = Obj % SD( IPS, IPT ) % getWt( ) + Js = Obj % SD( IPS, IPT ) % getJs_Xi2Xt( ) + Jt = Obj % SD( IPS, IPT ) % getJt( ) + thick = Obj % SD( IPS, IPT ) % getThickness( ) + CALL Obj % SD( IPS, IPT ) % getdNTdXt( dNTdXt ) + CALL STElemSD % SD( IPS, IPT ) % getdNTdXt( dNTdXt2 ) + CALL STElemSD2 % SD( IPS, IPT ) % getdNTdXt( dNTdXt3 ) + RealVal = Ws * Wt * Js * Jt * thick * Kij*beta + + SELECT CASE( TRIM( IntegrationSide ) ) + CASE( "Right", "RIGHT", "right" ) + Obj % Mat4( r1:r2, c1:c2, aa, b ) = & + Obj % Mat4( r1:r2, c1:c2, aa, b ) + & + OUTERPROD( a = dNTdXt3( :, p, aa ), b = dNTdXt2( :, q, b ) ) * RealVal + + CASE( "Left", "LEFT", "left" ) + Obj % Mat4( r1:r2, c1:c2, aa, b ) = & + Obj % Mat4( r1:r2, c1:c2, aa, b ) + & + OUTERPROD( a = dNTdXt2( :, p, aa ), b = dNTdXt3( :, q, b ) ) * RealVal + + CASE( "None", "NONE", "none" ) + Obj % Mat4( r1:r2, c1:c2, aa, b ) = & + Obj % Mat4( r1:r2, c1:c2, aa, b ) + & + OUTERPROD( a = dNTdXt3( :, p, aa ), b = dNTdXt( :, q, b ) ) * RealVal + + CASE DEFAULT + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_13()", & + "No case found for given integration side" & + ) + Error_Flag = .TRUE. + RETURN + END SELECT + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + IF( ALLOCATED( dNTdXt ) ) DEALLOCATE( dNTdXt ) + IF( ALLOCATED( dNTdXt2 ) ) DEALLOCATE( dNTdXt2 ) + IF( ALLOCATED( dNTdXt3 ) ) DEALLOCATE( dNTdXt3 ) + IF( ALLOCATED( Indx ) ) DEALLOCATE( Indx ) + IF( ALLOCATED( T ) ) DEALLOCATE( T ) + CALL STElemSD % DeallocateData( ) + CALL STElemSD2 % DeallocateData( ) + SD => NULL( ) + SD2 => NULL( ) + +END SUBROUTINE getStiffnessMatrix_13 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part new file mode 100755 index 000000000..e4f887eec --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_14.part @@ -0,0 +1,106 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_14.part +! Last Update : Jan-06-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! - Space time stiffness matrix for alpha-beta v-ST/FEM +! - beta_STFEM is beta => +! - Effective coefficient will be beta_STFEM * dt +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_14 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_14( Obj, CData, TimeVector, IntegrationSide, & + & beta_STFEM ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns Stiffness matrix + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE MaterialJacobian_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + TYPE( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ), beta_STFEM + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, :, : ) + INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, NSD, N + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix(Obj, CData)", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = .NIPS. Obj + NIPT = .NIPT. Obj + +#ifdef DEBUG_VER + IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix(Obj, CData)", & + "The Shape Of CData is not compatible" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ! Make Cijkl + ALLOCATE( Cijkl( N, N, NIPS, NIPT ) ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + Cijkl( :, :, IPS, IPT ) = CData( IPS, IPT ) % C .Cijkl. N + END DO + END DO + CALL Obj % getStiffnessMatrix( Cijkl, TimeVector, IntegrationSide, beta_STFEM ) + DEALLOCATE( Cijkl ) + +END SUBROUTINE getStiffnessMatrix_14 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part new file mode 100755 index 000000000..e4cf95e13 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_2.part @@ -0,0 +1,176 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_2.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_2 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_2( Obj, Cijkl ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness Matrix + ! 2. Cijkl is constant in time + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Cijkl + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, sizeOFC + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + REAL( DFP ) :: RealVal + REAL( DFP ), ALLOCATABLE :: Ce( :, : ), BMat( :, : ), BTMat( :, : ) + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + Error_Flag = .FALSE. + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2()", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Cijkl, 3 ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2()", & + "The SIZE( Cijkl, 3 ) should be NIPS" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2()", & + "The size of first and second dimension of Cijkl must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SizeOfC = SIZE( Cijkl, 1 ) + +#ifdef DEBUG_VER + IF( NSD .EQ. 2 ) THEN + IF( SizeOfC .NE. 4 & + .AND. SizeOfC .NE. 3 ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2()", & + "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & + & either 3, 4" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF + IF( NSD .EQ. 3 ) THEN + IF( SizeOfC .NE. 6 ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2(), Flag-5", & + "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & + & equal to 6" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF +#endif + + ! Make Indx + SELECT CASE( NSD ) + CASE( 1 ) + ALLOCATE( Indx( 1, 1 ) ) + Indx = 1 + CASE( 2 ) + Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) + CASE( 3 ) + Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) + END SELECT + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) + ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) + BMat = 0.0_DFP + BTMat = 0.0_DFP + + DO IPS = 1, NIPS + + DO j = 1, NSD + DO i = 1, NSD + Ce( (i-1) * NSD + 1 : i * NSD, (j-1) * NSD + 1 : j * NSD ) & + & = Cijkl( Indx( :, i ), Indx( :, j ), IPS ) + END DO + END DO + + DO IPT = 1, NIPT + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + DO b = 1, NNT + DO i = 1, NSD + BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & + & TRANSPOSE( SD % dNTdXt( :, :, b ) ) + END DO + DO aa = 1, NNT + DO i = 1, NSD + BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & + & SD % dNTdXt( :, :, aa ) + END DO + Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & + & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + DEALLOCATE( Ce, Indx, BMat, BTMat ) + +END SUBROUTINE getStiffnessMatrix_2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part new file mode 100755 index 000000000..4e53feba0 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_3.part @@ -0,0 +1,171 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_3.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_3 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_3( Obj, Cijkl ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Cijkl + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, sizeOFC + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + REAL( DFP ) :: RealVal + REAL( DFP ), ALLOCATABLE :: Ce( :, : ), BMat( :, : ), BTMat( :, : ) + + CLASS( STShapeData_ ), POINTER :: SD + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + Error_Flag = .FALSE. + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2()", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2()", & + "The size of first and second dimension of Cijkl must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SizeOfC = SIZE( Cijkl, 1 ) + +#ifdef DEBUG_VER + IF( NSD .EQ. 2 ) THEN + IF( SizeOfC .NE. 4 & + .AND. SizeOfC .NE. 3 ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2()", & + "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & + & either 3, 4" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF + IF( NSD .EQ. 3 ) THEN + IF( SizeOfC .NE. 6 ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_2(), Flag-5", & + "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & + & equal to 6" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF +#endif + + ! Make Indx + SELECT CASE( NSD ) + CASE( 1 ) + ALLOCATE( Indx( 1, 1 ) ) + Indx = 1 + CASE( 2 ) + Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) + CASE( 3 ) + Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) + END SELECT + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) + ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) + BMat = 0.0_DFP + BTMat = 0.0_DFP + + DO j = 1, NSD + DO i = 1, NSD + Ce( (i-1) * NSD + 1 : i * NSD, (j-1) * NSD + 1 : j * NSD ) & + & = Cijkl( Indx( :, i ), Indx( :, j ) ) + END DO + END DO + + DO IPS = 1, NIPS + DO IPT = 1, NIPT + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + DO b = 1, NNT + + DO i = 1, NSD + BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & + & TRANSPOSE( SD % dNTdXt( :, :, b ) ) + END DO + + DO aa = 1, NNT + + DO i = 1, NSD + BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & + & SD % dNTdXt( :, :, aa ) + END DO + + Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & + & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + DEALLOCATE( Ce, Indx, BMat, BTMat ) + +END SUBROUTINE getStiffnessMatrix_3 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part new file mode 100755 index 000000000..31847cef2 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_4.part @@ -0,0 +1,98 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_4.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_4 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_4( Obj, CData ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. - Returns Stiffness matrix + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE MaterialJacobian_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( :, : ) + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, :, : ) + INTEGER( I4B ) :: NIPS, NIPT, IPS, IPT, NSD, N + +#ifdef DEBUG_VER + IF( .NOT. Obj % isInitiated( ) ) THEN + Error_Flag = .FALSE. + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix(Obj, CData)", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( CData, 1 ) .NE. NIPS .OR. SIZE( CData, 2 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix(Obj, CData)", & + "The Shape Of CData is not compatible" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ! Make Cijkl + ALLOCATE( Cijkl( N, N, NIPS, NIPT ) ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + Cijkl( :, :, IPS, IPT ) = CData( IPS, IPT ) % C .Cijkl. N + END DO + END DO + CALL Obj % getStiffnessMatrix( Cijkl ) + DEALLOCATE( Cijkl ) + +END SUBROUTINE getStiffnessMatrix_4 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part new file mode 100755 index 000000000..42f34d8d7 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_5.part @@ -0,0 +1,98 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_5.part +! Last Update : Nov-23-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_5 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_5( Obj, CData ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. CData is the one dimensional array + ! 3. In this case material tangent doesnot vary with the time. + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE MaterialJacobian_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData( : ) + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Cijkl( :, :, : ) + INTEGER( I4B ) :: NIPS, IPS, NSD, N + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_5(Obj, CData)", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NIPS = Obj % getNIPS( ) + +#ifdef DEBUG_VER + IF( SIZE( CData ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_5(Obj, CData)", & + "The Shape Of CData is not compatible" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + ! Make Cijkl + ALLOCATE( Cijkl( N, N, NIPS ) ) + DO IPS = 1, NIPS + Cijkl( :, :, IPS ) = CData( IPS ) % C .Cijkl. N + END DO + CALL Obj % getStiffnessMatrix( Cijkl ) + DEALLOCATE( Cijkl ) + +END SUBROUTINE getStiffnessMatrix_5 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part new file mode 100755 index 000000000..0b8069e1c --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_6.part @@ -0,0 +1,82 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_6.part +! Last Update : Jan-03-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_6 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_6( Obj, CData ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. CData is constant + ! 3. In this case material tangent doesnot vary with the space-time. + !. . . . . . . . . . . . . . . . . . . . + + USE ConstitutiveData_Class + USE MaterialJacobian_Class + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + CLASS( ConstitutiveData_ ), INTENT( IN ), TARGET :: CData + + ! Define internal variables + REAL( DFP ), ALLOCATABLE :: Cijkl( :, : ) + INTEGER( I4B ) :: NSD, N + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_6(Obj, CData)", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + + SELECT CASE( NSD ) + CASE( 3 ) + N = 6 + CASE( 2 ) + N = 4 + CASE( 1 ) + N = 1 + END SELECT + + Cijkl = CData % C .Cijkl. N + CALL Obj % getStiffnessMatrix( Cijkl ) + DEALLOCATE( Cijkl ) + +END SUBROUTINE getStiffnessMatrix_6 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part new file mode 100755 index 000000000..3601ed278 --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_7.part @@ -0,0 +1,229 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_7.part +! Last Update : Jan-06-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_7 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_7( Obj, Cijkl, TimeVector, IntegrationSide ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. Time Integration is character "Right", "Left", "Both" + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, :, : ), INTENT( IN ) :: Cijkl + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, sizeOFC + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + REAL( DFP ) :: RealVal, t1, t2, Theta + REAL( DFP ), ALLOCATABLE :: T( : ), Ce( :, : ), BMat( :, : ), BTMat( :, : ) + + TYPE( STElemShapeData_ ), TARGET :: STElemSD + CLASS( STShapeData_ ), POINTER :: SD, SD2 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_7()", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Cijkl, 3 ) .NE. NIPS .OR. SIZE( Cijkl, 4 ) .NE. NIPT ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_7()", & + "The SIZE( Cijkl, 3 ) should be NIPS, & + & SIZE( Cijkl, 4 ) should be NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_7()", & + "The size of first and second dimension of Cijkl must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SizeOfC = SIZE( Cijkl, 1 ) + +#ifdef DEBUG_VER + IF( NSD .EQ. 2 ) THEN + IF( SizeOfC .NE. 4 & + & .AND. SizeOfC .NE. 3 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_7()", & + & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & + & either 3, 4" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF + IF( NSD .EQ. 3 ) THEN + IF( SizeOfC .NE. 6 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_7(), Flag-5", & + & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & + & equal to 6" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF +#endif + + ! Make Indx + SELECT CASE( NSD ) + CASE( 1 ) + ALLOCATE( Indx( 1, 1 ) ) + Indx = 1 + CASE( 2 ) + Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) + CASE( 3 ) + Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) + END SELECT + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + + t1 = TimeVector( 1 ) + t2 = TimeVector( 2 ) + + ! Make copy of Obj + CALL STElemSD % Initiate( Obj ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => STElemSD % SD( IPS, IPT ) + Theta = SD % Theta + T = SD .TimeIntegration. [t1, t2, Theta] + CALL SD % setT( T ) + CALL SD % setdNTdXt( ) + END DO + END DO + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) + ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) + BMat = 0.0_DFP + BTMat = 0.0_DFP + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SELECT CASE( TRIM( IntegrationSide ) ) + + CASE( "Right", "RIGHT", "right" ) + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + SD2 => STElemSD % SD( IPS, IPT ) + + CASE( "Left", "LEFT", "left" ) + + SD => STElemSD % SD( IPS, IPT ) + SD2 => Obj % SD( IPS, IPT ) + RealVal = SD2 % Ws * SD2 % Wt * SD2 % Js_Xi2Xt & + & * SD2 % Jt * SD2 % Thickness + + CASE( "Both", "BOTH", "both" ) + + SD => STElemSD % SD( IPS, IPT ) + SD2 => STElemSD % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CASE DEFAULT + + SD => Obj % SD( IPS, IPT ) + SD2 => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + END SELECT + + DO j = 1, NSD + DO i = 1, NSD + Ce( (i-1)*NSD + 1:i*NSD, (j-1)*NSD + 1:j*NSD ) & + & = Cijkl( Indx( :, i ), Indx( :, j ), IPS, IPT ) + END DO + END DO + + DO b = 1, NNT + DO i = 1, NSD + BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & + & TRANSPOSE( SD2 % dNTdXt( :, :, b ) ) + END DO + + DO aa = 1, NNT + DO i = 1, NSD + BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & + & SD % dNTdXt( :, :, aa ) + END DO + + Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & + & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) + + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + DEALLOCATE( Indx, T, Ce, BMat, BTMat ) + CALL STElemSD % DeallocateData( ) + SD => NULL( ) + SD2 => NULL( ) + +END SUBROUTINE getStiffnessMatrix_7 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part new file mode 100755 index 000000000..0be3f38bc --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_8.part @@ -0,0 +1,230 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_8.part +! Last Update : Jan-06-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_8 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_8( Obj, Cijkl, TimeVector, IntegrationSide ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. Time Integration is character "Right", "Left", "Both" + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: Cijkl + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, sizeOFC + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + REAL( DFP ) :: RealVal, t1, t2, Theta + REAL( DFP ), ALLOCATABLE :: T( : ), Ce( :, : ), BMat( :, : ), BTMat( :, : ) + + TYPE( STElemShapeData_ ), TARGET :: STElemSD + CLASS( STShapeData_ ), POINTER :: SD, SD2 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_7()", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Cijkl, 3 ) .NE. NIPS ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_7()", & + "The SIZE( Cijkl, 3 ) should be NIPS, & + & SIZE( Cijkl, 4 ) should be NIPT" ) + Error_Flag = .TRUE. + RETURN + END IF + IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_7()", & + "The size of first and second dimension of Cijkl must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SizeOfC = SIZE( Cijkl, 1 ) + +#ifdef DEBUG_VER + IF( NSD .EQ. 2 ) THEN + IF( SizeOfC .NE. 4 & + & .AND. SizeOfC .NE. 3 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_7()", & + & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & + & either 3, 4" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF + IF( NSD .EQ. 3 ) THEN + IF( SizeOfC .NE. 6 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_7(), Flag-5", & + & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & + & equal to 6" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF +#endif + + ! Make Indx + SELECT CASE( NSD ) + CASE( 1 ) + ALLOCATE( Indx( 1, 1 ) ) + Indx = 1 + CASE( 2 ) + Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) + CASE( 3 ) + Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) + END SELECT + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + + t1 = TimeVector( 1 ) + t2 = TimeVector( 2 ) + + ! Make copy of Obj + CALL STElemSD % Initiate( Obj ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => STElemSD % SD( IPS, IPT ) + Theta = SD % Theta + T = SD .TimeIntegration. [t1, t2, Theta] + CALL SD % setT( T ) + CALL SD % setdNTdXt( ) + END DO + END DO + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) + ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) + BMat = 0.0_DFP + BTMat = 0.0_DFP + + DO IPS = 1, NIPS + + DO j = 1, NSD + DO i = 1, NSD + Ce( (i-1)*NSD + 1:i*NSD, (j-1)*NSD + 1:j*NSD ) & + & = Cijkl( Indx( :, i ), Indx( :, j ), IPS ) + END DO + END DO + + DO IPT = 1, NIPT + + SELECT CASE( TRIM( IntegrationSide ) ) + + CASE( "Right", "RIGHT", "right" ) + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + SD2 => STElemSD % SD( IPS, IPT ) + + CASE( "Left", "LEFT", "left" ) + + SD => STElemSD % SD( IPS, IPT ) + SD2 => Obj % SD( IPS, IPT ) + RealVal = SD2 % Ws * SD2 % Wt * SD2 % Js_Xi2Xt & + & * SD2 % Jt * SD2 % Thickness + + CASE( "Both", "BOTH", "both" ) + + SD => STElemSD % SD( IPS, IPT ) + SD2 => STElemSD % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CASE DEFAULT + + SD => Obj % SD( IPS, IPT ) + SD2 => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + END SELECT + + DO b = 1, NNT + DO i = 1, NSD + BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & + & TRANSPOSE( SD2 % dNTdXt( :, :, b ) ) + END DO + + DO aa = 1, NNT + DO i = 1, NSD + BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & + & SD % dNTdXt( :, :, aa ) + END DO + + Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & + & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) + + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + DEALLOCATE( Indx, T, Ce, BMat, BTMat ) + CALL STElemSD % DeallocateData( ) + SD => NULL( ) + SD2 => NULL( ) + +END SUBROUTINE getStiffnessMatrix_8 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part b/src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part new file mode 100755 index 000000000..553ce2c8f --- /dev/null +++ b/src/submodules/STStiffnessMatrix/StiffnessMatrix_9.part @@ -0,0 +1,221 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: StiffnessMatrix_9.part +! Last Update : Jan-06-2018 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - STStiffnessMatrix_Class.f90 +!============================================================================== + +!------------------------------------------------------------------------------ +! getStiffnessMatrix_9 +!------------------------------------------------------------------------------ + +SUBROUTINE getStiffnessMatrix_9( Obj, Cijkl, TimeVector, IntegrationSide ) + + !. . . . . . . . . . . . . . . . . . . . + ! 1. Returns Stiffness matrix + ! 2. Time Integration is character "Right", "Left", "Both" + !. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( STStiffnessMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Cijkl + REAL( DFP ), INTENT( IN ) :: TimeVector( 2 ) + CHARACTER( LEN = * ), INTENT( IN ) :: IntegrationSide + + + ! Define internal variables + INTEGER( I4B ) :: NNS, NNT, NIPS, NIPT, IPS, IPT, aa, b, NSD, & + i, j, sizeOFC + INTEGER( I4B ), ALLOCATABLE :: Indx( :, : ) + + REAL( DFP ) :: RealVal, t1, t2, Theta + REAL( DFP ), ALLOCATABLE :: T( : ), Ce( :, : ), BMat( :, : ), BTMat( :, : ) + + TYPE( STElemShapeData_ ), TARGET :: STElemSD + CLASS( STShapeData_ ), POINTER :: SD, SD2 + +#ifdef DEBUG_VER + Error_Flag = .FALSE. + IF( .NOT. Obj % isInitiated( ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_9()", & + "STStiffnessMatrix_ Object is not Initiated" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + IF( SIZE( Cijkl, 1 ) .NE. SIZE( Cijkl, 2 ) ) THEN + CALL Err_Msg( & + "STStiffnessMatrix_Class.f90", & + "getStiffnessMatrix_9()", & + "The size of first and second dimension of Cijkl must be same" ) + Error_Flag = .TRUE. + RETURN + END IF +#endif + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + SizeOfC = SIZE( Cijkl, 1 ) + +#ifdef DEBUG_VER + IF( NSD .EQ. 2 ) THEN + IF( SizeOfC .NE. 4 & + & .AND. SizeOfC .NE. 3 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_9()", & + & "In case of NSD = 2, SIZE( Cijkl, 1 ) should be & + & either 3, 4" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF + IF( NSD .EQ. 3 ) THEN + IF( SizeOfC .NE. 6 ) THEN + CALL Err_Msg( & + & "STStiffnessMatrix_Class.f90", & + & "getStiffnessMatrix_9(), Flag-5", & + & "In case of NSD = 3, SIZE( Cijkl, 1 ) should be & + & equal to 6" ) + Error_Flag = .TRUE. + RETURN + END IF + END IF +#endif + + ! Make Indx + SELECT CASE( NSD ) + CASE( 1 ) + ALLOCATE( Indx( 1, 1 ) ) + Indx = 1 + CASE( 2 ) + Indx = RESHAPE( (/1,3,3,2/), (/2,2/) ) + CASE( 3 ) + Indx = RESHAPE( (/1,4,6,4,2,5,6,5,3/), (/3,3/) ) + END SELECT + + NNS = Obj % SD( 1,1 ) % getNNS( ) + NNT = Obj % SD( 1,1 ) % getNNT( ) + + t1 = TimeVector( 1 ) + t2 = TimeVector( 2 ) + + ! Make copy of Obj + CALL STElemSD % Initiate( Obj ) + DO IPT = 1, NIPT + DO IPS = 1, NIPS + SD => STElemSD % SD( IPS, IPT ) + Theta = SD % Theta + T = SD .TimeIntegration. [t1, t2, Theta] + CALL SD % setT( T ) + CALL SD % setdNTdXt( ) + END DO + END DO + + IF( ALLOCATED( Obj % Mat4 ) ) DEALLOCATE( Obj % Mat4 ) + ALLOCATE( Obj % Mat4( NNS*NSD, NNS*NSD, NNT, NNT ) ) + Obj % Mat4 = 0.0_DFP + + ALLOCATE( Ce( NSD * NSD, NSD * NSD ) ) + ALLOCATE( BMat( NSD*NNS, NSD*NSD ), BTMat( NSD*NSD, NSD*NNS ) ) + BMat = 0.0_DFP + BTMat = 0.0_DFP + + DO j = 1, NSD + DO i = 1, NSD + Ce( (i-1)*NSD + 1:i*NSD, (j-1)*NSD + 1:j*NSD ) & + & = Cijkl( Indx( :, i ), Indx( :, j ) ) + END DO + END DO + + DO IPT = 1, NIPT + DO IPS = 1, NIPS + + SELECT CASE( TRIM( IntegrationSide ) ) + + CASE( "Right", "RIGHT", "right" ) + + SD => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + SD2 => STElemSD % SD( IPS, IPT ) + + CASE( "Left", "LEFT", "left" ) + + SD => STElemSD % SD( IPS, IPT ) + SD2 => Obj % SD( IPS, IPT ) + RealVal = SD2 % Ws * SD2 % Wt * SD2 % Js_Xi2Xt & + & * SD2 % Jt * SD2 % Thickness + + CASE( "Both", "BOTH", "both" ) + + SD => STElemSD % SD( IPS, IPT ) + SD2 => STElemSD % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + CASE DEFAULT + + SD => Obj % SD( IPS, IPT ) + SD2 => Obj % SD( IPS, IPT ) + RealVal = SD % Ws * SD % Wt * SD % Js_Xi2Xt & + & * SD % Jt * SD % Thickness + + END SELECT + + DO b = 1, NNT + DO i = 1, NSD + BTMat( (i-1) * NSD + 1 : i * NSD, (i-1) * NNS + 1 : i * NNS ) = & + & TRANSPOSE( SD2 % dNTdXt( :, :, b ) ) + END DO + + DO aa = 1, NNT + DO i = 1, NSD + BMat( (i-1) * NNS + 1 : i * NNS, (i-1) * NSD + 1 : i * NSD ) = & + & SD % dNTdXt( :, :, aa ) + END DO + + Obj % Mat4( :, :, aa, b ) = Obj % Mat4( :, :, aa, b ) + & + & RealVal * MATMUL( MATMUL( BMat, Ce ), BTMat ) + + END DO + END DO + END DO + END DO + + CALL Obj % Mat2FromMat4( ) + DEALLOCATE( Indx, T, Ce, BMat, BTMat ) + CALL STElemSD % DeallocateData( ) + SD => NULL( ) + SD2 => NULL( ) + +END SUBROUTINE getStiffnessMatrix_9 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ST_Tau_SUPG_RGN/Constructor.part b/src/submodules/ST_Tau_SUPG_RGN/Constructor.part new file mode 100755 index 000000000..39dd6a339 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/Constructor.part @@ -0,0 +1,101 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: Constructor.part +! Last Update : Nov-17-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! Constructor_1 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_1( NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construtor function +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( ST_Tau_SUPG_RGN_ ), POINTER :: Constructor_1 + INTEGER( I4B ), INTENT( IN ) :: NIPS, NIPT + + ALLOCATE( Constructor_1 ) + + ALLOCATE( Constructor_1 % Mat2( NIPS, NIPT ) ) + + Constructor_1 % Mat2 = 0.0_DFP + + CALL Constructor_1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor_1 + +!------------------------------------------------------------------------------ +! Constructor_2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor_2( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construtor function +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + CLASS( ST_Tau_SUPG_RGN_ ), POINTER :: Constructor_2 + ALLOCATE( Constructor_2 ) + + END FUNCTION Constructor_2 + +!------------------------------------------------------------------------------ +! Constructor1 +!------------------------------------------------------------------------------ +! + FUNCTION Constructor1( NIPS, NIPT ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construtor function +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( ST_Tau_SUPG_RGN_ ) :: Constructor1 + INTEGER( I4B ), INTENT( IN ) :: NIPS, NIPT + + ALLOCATE( Constructor1 % Mat2( NIPS, NIPT ) ) + Constructor1 % Mat2 = 0.0_DFP + CALL Constructor1 % Initiate( NIPS = NIPS, NIPT = NIPT ) + + END FUNCTION Constructor1 + +!------------------------------------------------------------------------------ +! Constructor2 +!------------------------------------------------------------------------------ + + FUNCTION Constructor2( ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Construtor function +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables + TYPE( ST_Tau_SUPG_RGN_ ) :: Constructor2 + + END FUNCTION Constructor2 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ST_Tau_SUPG_RGN/MdFiles/._ST_TAU_SUPG_RGN_Class.md b/src/submodules/ST_Tau_SUPG_RGN/MdFiles/._ST_TAU_SUPG_RGN_Class.md new file mode 100644 index 0000000000000000000000000000000000000000..18e5cd827d6324657aca6added3aa781df6fb72e GIT binary patch literal 299 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@lPNI@)@;(G!eitBqRu;46I`hke!dF z4P-hFR`SgC^M ST_Tau_SUPG_RGN( ) +STElemSD => ST_Tau_SUPG_RGN( NIPS, NIPT ) +``` + + + +## Theory + +We are intended to compute the following. + +## Methods + +### getSUPG\_For\_Scalar\_1( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_1( Obj, Phi, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NNS, NNT ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_1( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_1( C = DummyMat3, Phi = DummyMat2, Mu= 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_2( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_2( Obj, Phi, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NNS, NNT ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3( :, :, 1), Phi = DummyMat2, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_2( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_2( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_3( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_3( Obj, Phi, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NSD ) ) +DummyVec = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NNS, NNT ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_3( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_3(C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_4( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_4( Obj, Phi, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NNS ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_4( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_4(C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_5( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_5( Obj, Phi, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NNS ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_5( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_4(C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_6( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_6( Obj, Phi, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NSD, NNS ) ) +DummyMat2 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NNS ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat2(:,1), Phi = DummyVec, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_6( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_6( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP ) +MATRIX STORED IN ST-ELEMENT-SHAPEDATA +NIPS :: 4 NIPT :: 2 +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_7( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_7( Obj, Phi, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NNS, NNT ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_7( C = DummyMat3,& + Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_7( C = DummyMat3,Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) +MATRIX STORED IN ST-ELEMENT-SHAPEDATA +NIPS :: 4 NIPT :: 2 +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_8( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_8( Obj, Phi, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NNS, NNT ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3( :, :, 1), Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_8( C = DummyMat2,& + Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_8( C = DummyMat2,Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) +MATRIX STORED IN ST-ELEMENT-SHAPEDATA +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_9( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_9( Obj, Phi, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyMat2 ) ) DEALLOCATE( DummyMat2 ) +ALLOCATE( DummyMat2( NNS, NNT ) ) +DummyMat2 = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3( :, 1, 1), Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_9( C = DummyVec,& +Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_9( C = DummyVec,Phi = DummyMat2, Mu = 1.0_DFP, CType = "Quad" ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_10( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_10( Obj, Phi, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NNS ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_10( C = DummyMat3,& +Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_10( C = DummyMat3,Phi = DummyVec, Mu =1.0_DFP, CType = "Quad" ) +MATRIX STORED IN ST-ELEMENT-SHAPEDATA +NIPS :: 4 NIPT :: 2 +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_11( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_11( Obj, Phi, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyMat2, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NNS ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3(:,:,1), Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_11( C = DummyMat2,& + Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_11( C = DummyMat2,Phi = DummyVec, Mu =1.0_DFP, CType = "Quad" ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Scalar\_12( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Scalar_12( Obj, Phi, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForScalar( C = DummyVec, Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NIPS, NIPT ) ) +DummyMat3 = 1.0_DFP + +IF( ALLOCATED( DummyVec ) ) DEALLOCATE( DummyVec ) +ALLOCATE( DummyVec( NNS ) ) +DummyVec = 1.0_DFP + +CALL STElemSD % getSUPGForScalar( C = DummyMat3(:,1,1), Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Scalar_12( C = DummyVec,& +Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Scalar_11( C = DummyVec,Phi = DummyVec, Mu = 1.0_DFP, CType = "Quad" ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Vector\_1( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_1( Obj, U, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_1( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Vector_1( C = DummyMat3, U = DummyMat3, Mu = 1.0_DFP ) +MATRIX STORED IN ST-ELEMENT-SHAPEDATA +NIPS :: 4 NIPT :: 2 +------------------------------------------------- +2D MATRIX, Mat2(:, :) :: + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Vector\_2( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_2( Obj, U, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForVector( C = DummyMat2, U = DummyMat3, Mu = 1.0_DFP ) + +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getSUPGForVector( C = DummyMat3(:,:,1), U = DummyMat3, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_2( C = DummyMat2, U = DummyMat3, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Vector_2( C = DummyMat2, U = DummyMat3, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Vector\_3( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_3( Obj, U, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForVector( C = DummyVec, U = DummyMat3, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getSUPGForVector( C = DummyMat3(:,1,1), U = DummyMat3, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_3( C = DummyVec, U = DummyMat3, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran + +CALL STElemSD % getSUPG_For_Vector_3( C = DummyVec, U = DummyMat3, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Vector\_4( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_4( Obj, U, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat2, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getSUPGForVector( C = DummyMat3, U = DummyMat3(:,:,1), Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_4( C = DummyMat3, U = DummyMat2, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Vector_4( C = DummyMat3, U = DummyMat2, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Vector\_5( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_5( Obj, U, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +CALL STElemSD % getSUPGForVector( C = DummyMat2, U = DummyMat2, Mu = 1.0_DFP ) +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getSUPGForVector( C = DummyMat3( :, :, 1 ), U = DummyMat3(:,:,1), Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_5( C = DummyMat2, U = DummyMat2, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Vector_5( C = DummyMat2, U = DummyMat2, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Vector\_6( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_6( Obj, U, C, Mu ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +? +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +IF( ALLOCATED( DummyMat3 ) ) DEALLOCATE( DummyMat3 ) +ALLOCATE( DummyMat3( NSD, NNS, NNT ) ) +DummyMat3 = 1.0_DFP + +CALL STElemSD % getSUPGForVector( C = DummyVec, U = DummyMat2, Mu = 1.0_DFP ) + +CALL BlankLines( ) +WRITE( *, "(A)") 'CALL STElemSD % getSUPG_For_Vector_6( C = DummyVec, U = DummyMat2, Mu = 1.0_DFP )' + +CALL STElemSD % DisplayMatrix2( ) +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +CALL STElemSD % getSUPG_For_Vector_6( C = DummyVec, U = DummyMat2, Mu = 1.0_DFP ) + +MATRIX STORED IN ST-ELEMENT-SHAPEDATA + +NIPS :: 4 NIPT :: 2 + +------------------------------------------------- + +2D MATRIX, Mat2(:, :) :: + + 0.5358984 0.6000000 + 0.6000000 0.6000000 + 0.6000000 0.5358984 + 0.6000000 0.6000000 +``` + +### getSUPG\_For\_Vector\_7( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_7( Obj, U, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +? +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +? +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +? +``` + +### getSUPG\_For\_Vector\_8( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_7( Obj, U, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +? +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +? +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +? +``` + +### getSUPG\_For\_Vector\_9( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_9( Obj, U, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +? +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +? +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +? +``` + +### getSUPG\_For\_Vector\_10( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_10( Obj, U, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +? +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +? +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +? +``` + +### getSUPG\_For\_Vector\_11( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_11( Obj, U, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +? +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +? +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +? +``` + +### getSUPG\_For\_Vector\_12( ) + +INTERFACE + +```fortran + SUBROUTINE getSUPG_For_Vector_12( Obj, U, C, Mu, CType ) + + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ) :: Obj + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +``` + +DESCRIPTION +? + +SYNTAX + +```fortran +? +``` + +SYMBOLIC CALCULATION +? + +TESTING + +```fortran +? +``` + +__NIPS = 4, NIPT = 2__ + +```fortran +? +``` \ No newline at end of file diff --git a/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part b/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part new file mode 100644 index 000000000..72e8fa5b8 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForScalar.part @@ -0,0 +1,12 @@ +getSUPG_For_Scalar_1, & +getSUPG_For_Scalar_2, & +getSUPG_For_Scalar_3, & +getSUPG_For_Scalar_4, & +getSUPG_For_Scalar_5, & +getSUPG_For_Scalar_6, & +getSUPG_For_Scalar_7, & +getSUPG_For_Scalar_8, & +getSUPG_For_Scalar_9, & +getSUPG_For_Scalar_10, & +getSUPG_For_Scalar_11, & +getSUPG_For_Scalar_12 diff --git a/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part b/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part new file mode 100644 index 000000000..cb81f8860 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/MethodNamesForVector.part @@ -0,0 +1,12 @@ +getSUPG_For_Vector_1, & +getSUPG_For_Vector_2, & +getSUPG_For_Vector_3, & +getSUPG_For_Vector_4, & +getSUPG_For_Vector_5, & +getSUPG_For_Vector_6, & +getSUPG_For_Vector_7, & +getSUPG_For_Vector_8, & +getSUPG_For_Vector_9, & +getSUPG_For_Vector_10, & +getSUPG_For_Vector_11, & +getSUPG_For_Vector_12 \ No newline at end of file diff --git a/src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 b/src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 new file mode 100755 index 000000000..2a3fb046e --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/ST_Tau_SUPG_RGN_Class.f90 @@ -0,0 +1,100 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: ST_Tau_SUPG_RGN_Class.f90 +! Last Update : Nov-15-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Module +! +! DESCRIPTION +! - STElemShapeData_ Class is extended to define the supg stabilization +! parameter. +! +!============================================================================== + + MODULE ST_Tau_SUPG_RGN_Class + USE GlobalData + USE IO + USE STElemShapeData_Class + USE STShapeData_Class + + IMPLICIT NONE + + PRIVATE + PUBLIC :: ST_Tau_SUPG_RGN_, ST_Tau_SUPG_RGN, ST_Tau_SUPG_RGN_Pointer + +!------------------------------------------------------------------------------ +! ST_Tau_SUPG_RGN_WTSA_ +!------------------------------------------------------------------------------ + + TYPE, EXTENDS( STElemShapeData_ ) :: ST_Tau_SUPG_RGN_ + +!. . . . . . . . . . . . . . . . . . . . +! 1. This class for computation of mass matrix +!. . . . . . . . . . . . . . . . . . . . + + CONTAINS + + PROCEDURE, PUBLIC, PASS( Obj ) :: & +#include "./MethodNamesForScalar.part" + PROCEDURE, PUBLIC, PASS( Obj ) :: & +#include "./MethodNamesForVector.part" + + END TYPE ST_Tau_SUPG_RGN_ + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + + ! INTERFACES + INTERFACE ST_Tau_SUPG_RGN_Pointer + MODULE PROCEDURE Constructor_1, Constructor_2 + END INTERFACE + + INTERFACE ST_Tau_SUPG_RGN + MODULE PROCEDURE Constructor1, Constructor2 + END INTERFACE + +!------------------------------------------------------------------------------ +! CONTAINS +!------------------------------------------------------------------------------ + + CONTAINS + +#undef STMat + +#include "./Constructor.part" +#include "./SUPG_Scalar_1.part" +#include "./SUPG_Scalar_2.part" +#include "./SUPG_Scalar_3.part" +#include "./SUPG_Scalar_4.part" +#include "./SUPG_Scalar_5.part" +#include "./SUPG_Scalar_6.part" +#include "./SUPG_Scalar_7.part" +#include "./SUPG_Scalar_8.part" +#include "./SUPG_Scalar_9.part" +#include "./SUPG_Scalar_10.part" +#include "./SUPG_Scalar_11.part" +#include "./SUPG_Scalar_12.part" + +#include "./SUPG_Vector_1.part" +#include "./SUPG_Vector_2.part" +#include "./SUPG_Vector_3.part" +#include "./SUPG_Vector_4.part" +#include "./SUPG_Vector_5.part" +#include "./SUPG_Vector_6.part" +#include "./SUPG_Vector_7.part" +#include "./SUPG_Vector_8.part" +#include "./SUPG_Vector_9.part" +#include "./SUPG_Vector_10.part" +#include "./SUPG_Vector_11.part" +#include "./SUPG_Vector_12.part" + + END MODULE ST_Tau_SUPG_RGN_Class + diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part new file mode 100755 index 000000000..5a88e0ce9 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_1.part @@ -0,0 +1,211 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_1 +!------------------------------------------------------------------------------ + + SUBROUTINE getSUPG_For_Scalar_1( Obj, Phi, C, Mu ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!. . . . . . . . . . . . . . . . . . . . + + ! Define intent of dummy variables +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + + ! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT +#ifdef DEBUG_VER + INTEGER( I4B ) :: NSD, NNS, NNT +#endif + + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + CLASS( STShapeData_ ), POINTER :: SD => NULL( ) + Error_Flag = .FALSE. + +#ifdef DEBUG_VER +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & + "getSUPG_For_Scalar_1()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + + ! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & + "getSUPG_For_Scalar_1()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + + ! Flag-3 + IF( SIZE( Phi, 2 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & + "getSUPG_For_Scalar_1()", & + "SIZE( Phi, 2 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + + ! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & + "getSUPG_For_Scalar_1()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + + ! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & + "getSUPG_For_Scalar_1()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + + ! Flag-6 + IF( SIZE( C, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_1.part", & + "getSUPG_For_Scalar_1()", & + "SIZE( C, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, STNodalValues = C ) + + CALL SD % getUnitNormalOfScalar( & + STNodalValues = Phi, R = R ) + + CALL SD % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( SD % dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + + Tau12 = 0.0_DFP + + ELSE + + Tau12 = d1 / DummyReal + + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + NULLIFY( SD ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) + + END SUBROUTINE getSUPG_For_Scalar_1 + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part new file mode 100755 index 000000000..6c2f461fb --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_10.part @@ -0,0 +1,223 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_10.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_10 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_10( Obj, Phi, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & + "getSUPG_For_Scalar_10()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & + "getSUPG_For_Scalar_10()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & + "getSUPG_For_Scalar_10()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & + "getSUPG_For_Scalar_10()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & + "getSUPG_For_Scalar_10()", & + "SIZE( C, 3 ) should be equal to the NNT or NIPT") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'STNodalValues', 'ST Nodal Values') + + CALL Obj % getSUPG_For_Scalar_4( Phi = Phi, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & + "getSUPG_For_Scalar_10()", & + "Traceback ---> CALL Obj % getSUPG_For_Scalar_4( Phi = Phi, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + SpaceNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_10.part", & + "getSUPG_For_Scalar_10()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'STNodalValues', 'ST Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_10 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part new file mode 100755 index 000000000..0a3477a80 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_11.part @@ -0,0 +1,212 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_11.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_11 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_11( Obj, Phi, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & + "getSUPG_For_Scalar_11()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & + "getSUPG_For_Scalar_11()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & + "getSUPG_For_Scalar_11()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & + "getSUPG_For_Scalar_11()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'SpaceNodalValues', 'Space Nodal Values') + + CALL Obj % getSUPG_For_Scalar_5( Phi = Phi, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & + "getSUPG_For_Scalar_11()", & + "Traceback ---> CALL Obj % getSUPG_For_Scalar_5( Phi = Phi, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + SpaceNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_11.part", & + "getSUPG_For_Scalar_11()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'SpaceNodalValues', 'Space Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_11 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part new file mode 100755 index 000000000..40d632aaf --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_12.part @@ -0,0 +1,64 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_12.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_12 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_12( Obj, Phi, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + + Error_Flag = .FALSE. + + CALL Obj % getSUPG_For_Scalar_6( Phi = Phi, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_12.part", & + "getSUPG_For_Scalar_12()", & + "Traceback ---> CALL Obj % getSUPG_For_Scalar_6( Phi = Phi, C = C )") + + END IF +! +END SUBROUTINE getSUPG_For_Scalar_12 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk new file mode 100755 index 000000000..38becdf74 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.bk @@ -0,0 +1,190 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_2.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_2 +!------------------------------------------------------------------------------ + + SUBROUTINE getSUPG_For_Scalar_2( Obj, Phi, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C is space-nodal values, and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( Phi, 2 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( Phi, 2 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPS = 1, NIPS + + DO IPT = 1, NIPT + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, SpaceNodalValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + STNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_2 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part new file mode 100755 index 000000000..c663ea3a0 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_2.part @@ -0,0 +1,204 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_2.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== + +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_2 +!------------------------------------------------------------------------------ + + SUBROUTINE getSUPG_For_Scalar_2( Obj, Phi, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C is space-nodal values, and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + + ! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT +#ifdef DEBUG_VER + INTEGER( I4B ) :: NSD, NNS, NNT +#endif + + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + CLASS( STShapeData_ ), POINTER :: SD => NULL( ) + + + Error_Flag = .FALSE. + +#ifdef DEBUG_VER + ! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + +#ifdef DEBUG_VER + ! Flag-2 + + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + + ! Flag-3 + IF( SIZE( Phi, 2 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( Phi, 2 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + + ! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + + ! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_2.part", & + "getSUPG_For_Scalar_2()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF +#endif + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + SD => Obj % SD( IPS, IPT ) + + CALL SD % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, SpaceNodalValues = C ) + + CALL SD % getUnitNormalOfScalar( & + STNodalValues = Phi, R = R ) + + CALL SD % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( SD % dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + + Tau12 = 0.0_DFP + + ELSE + + Tau12 = d1 / DummyReal + + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + NULLIFY( SD ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_2 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part new file mode 100755 index 000000000..6390b1b9f --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_3.part @@ -0,0 +1,178 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_3.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_3 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_3( Obj, Phi, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C is constant, and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & + "getSUPG_For_Scalar_3()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & + "getSUPG_For_Scalar_3()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( Phi, 2 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & + "getSUPG_For_Scalar_3()", & + "SIZE( Phi, 2 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_3.part", & + "getSUPG_For_Scalar_3()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPS = 1, NIPS + + DO IPT = 1, NIPT + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + STNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_3 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part new file mode 100755 index 000000000..150ec9ff3 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_4.part @@ -0,0 +1,189 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_4.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_4 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_4( Obj, Phi, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C is space-time nodal values, Phi is space-nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & + "getSUPG_For_Scalar_4()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & + "getSUPG_For_Scalar_4()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & + "getSUPG_For_Scalar_4()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & + "getSUPG_For_Scalar_4()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_4.part", & + "getSUPG_For_Scalar_4()", & + "SIZE( C, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPS = 1, NIPS + + DO IPT = 1, NIPT + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, STNodalValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + SpaceNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_4 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part new file mode 100755 index 000000000..8668e6382 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_5.part @@ -0,0 +1,178 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_5.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_5 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_5( Obj, Phi, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C is space-nodal values, and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & + "getSUPG_For_Scalar_5()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & + "getSUPG_For_Scalar_5()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & + "getSUPG_For_Scalar_5()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_5.part", & + "getSUPG_For_Scalar_5()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPS = 1, NIPS + + DO IPT = 1, NIPT + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, SpaceNodalValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + SpaceNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_5 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part new file mode 100755 index 000000000..d1de8bc07 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_6.part @@ -0,0 +1,166 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_6.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_6 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_6( Obj, Phi, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C is constant, and Phi is space-nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_6.part", & + "getSUPG_For_Scalar_6()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_6.part", & + "getSUPG_For_Scalar_6()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_6.part", & + "getSUPG_For_Scalar_6()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPS = 1, NIPS + + DO IPT = 1, NIPT + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + SpaceNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_6 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part new file mode 100755 index 000000000..7bae30eb1 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_7.part @@ -0,0 +1,234 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_7.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_7 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_7( Obj, Phi, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( Phi, 2 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "SIZE( Phi, 2 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "SIZE( C, 3 ) should be equal to the NNT or NIPT") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'STNodalValues', 'ST Nodal Values') + + CALL Obj % getSUPG_For_Scalar_1( Phi = Phi, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "Traceback ---> CALL Obj % getSUPG_For_Scalar_1( Phi = Phi, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + STNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_7.part", & + "getSUPG_For_Scalar_7()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'STNodalValues', 'ST Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_7 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part new file mode 100755 index 000000000..5106188a3 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_8.part @@ -0,0 +1,222 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_8.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_8 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_8( Obj, Phi, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & + "getSUPG_For_Scalar_8()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( Phi, 1 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & + "getSUPG_For_Scalar_8()", & + "SIZE( Phi, 1 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( Phi, 2 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & + "getSUPG_For_Scalar_8()", & + "SIZE( Phi, 2 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & + "getSUPG_For_Scalar_8()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & + "getSUPG_For_Scalar_8()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'SpaceNodalValues', 'Space Nodal Values') + + CALL Obj % getSUPG_For_Scalar_2( Phi = Phi, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & + "getSUPG_For_Scalar_8()", & + "Traceback ---> CALL Obj % getSUPG_For_Scalar_2( Phi = Phi, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfScalar( & + STNodalValues = Phi, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_8.part", & + "getSUPG_For_Scalar_8()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'SpaceNodalValues', 'Space Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Scalar_8 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part new file mode 100755 index 000000000..cd4b4c30f --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Scalar_9.part @@ -0,0 +1,64 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Scalar_9.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Scalar_9 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Scalar_9( Obj, Phi, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: Phi + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + + Error_Flag = .FALSE. + + CALL Obj % getSUPG_For_Scalar_3( Phi = Phi, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Scalar_9.part", & + "getSUPG_For_Scalar_9()", & + "Traceback ---> CALL Obj % getSUPG_For_Scalar_3( Phi = Phi, C = C )") + + END IF +! +END SUBROUTINE getSUPG_For_Scalar_9 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part new file mode 100755 index 000000000..bfe2c1ba5 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_1.part @@ -0,0 +1,211 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_1.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_1 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_1( Obj, U, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & + "getSUPG_For_Vector_1()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & + "getSUPG_For_Vector_1()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & + "getSUPG_For_Vector_1()", & + "SIZE( U, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( U, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & + "getSUPG_For_Vector_1()", & + "SIZE( U, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & + "getSUPG_For_Vector_1()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & + "getSUPG_For_Vector_1()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-7 + IF( SIZE( C, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_1.part", & + "getSUPG_For_Vector_1()", & + "SIZE( C, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, STNodalValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + STNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_1 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part new file mode 100755 index 000000000..7e7e030e9 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_10.part @@ -0,0 +1,234 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_10.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_10 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_10( Obj, U, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "SIZE( U, 2 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "SIZE( C, 3 ) should be equal to the NNT or NIPT") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'STNodalValues', 'ST Nodal Values') + + CALL Obj % getSUPG_For_Vector_4( U = U, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "Traceback ---> CALL Obj % getSUPG_For_Vector_4( U = U, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + SpaceNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_10.part", & + "getSUPG_For_Vector_10()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'STNodalValues', 'ST Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_10 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part new file mode 100755 index 000000000..19b473bfa --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_11.part @@ -0,0 +1,222 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_11.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_11 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_11( Obj, U, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & + "getSUPG_For_Vector_11()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & + "getSUPG_For_Vector_11()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & + "getSUPG_For_Vector_11()", & + "SIZE( U, 2 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & + "getSUPG_For_Vector_11()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & + "getSUPG_For_Vector_11()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'SpaceNodalValues', 'Space Nodal Values') + + CALL Obj % getSUPG_For_Vector_5( U = U, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & + "getSUPG_For_Vector_11()", & + "Traceback ---> CALL Obj % getSUPG_For_Vector_5( U = U, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + SpaceNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_11.part", & + "getSUPG_For_Vector_11()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'SpaceNodalValues', 'Space Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_11 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part new file mode 100755 index 000000000..d4459e20e --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_12.part @@ -0,0 +1,62 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_12.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_12 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_12( Obj, U, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType +! + CALL Obj % getSUPG_For_Vector_6( U = U, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_12.part", & + "getSUPG_For_Vector_12()", & + "Traceback ---> CALL Obj % getSUPG_For_Vector_6( U = U, C = C )") + + END IF +! +END SUBROUTINE getSUPG_For_Vector_12 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part new file mode 100755 index 000000000..d096d2910 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_2.part @@ -0,0 +1,199 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_2.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_2 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_2( Obj, U, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & + "getSUPG_For_Vector_2()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & + "getSUPG_For_Vector_2()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & + "getSUPG_For_Vector_2()", & + "SIZE( U, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( U, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & + "getSUPG_For_Vector_2()", & + "SIZE( U, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & + "getSUPG_For_Vector_2()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_2.part", & + "getSUPG_For_Vector_2()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, SpaceNodalValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + STNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_2 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part new file mode 100755 index 000000000..7f9769305 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_3.part @@ -0,0 +1,188 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_3.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_3 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_3( Obj, U, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & + "getSUPG_For_Vector_3()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & + "getSUPG_For_Vector_3()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & + "getSUPG_For_Vector_3()", & + "SIZE( U, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( U, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & + "getSUPG_For_Vector_3()", & + "SIZE( U, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_3.part", & + "getSUPG_For_Vector_3()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + STNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_3 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part new file mode 100755 index 000000000..08b17fbfe --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_4.part @@ -0,0 +1,200 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_4.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_4 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_4( Obj, U, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & + "getSUPG_For_Vector_4()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & + "getSUPG_For_Vector_4()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & + "getSUPG_For_Vector_4()", & + "SIZE( U, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & + "getSUPG_For_Vector_4()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & + "getSUPG_For_Vector_4()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_4.part", & + "getSUPG_For_Vector_4()", & + "SIZE( C, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, STNodalValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + SpaceNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_4 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part new file mode 100755 index 000000000..85b2e8f98 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_5.part @@ -0,0 +1,189 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_5.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_5 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_5( Obj, U, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & + "getSUPG_For_Vector_5()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & + "getSUPG_For_Vector_5()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & + "getSUPG_For_Vector_5()", & + "SIZE( U, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & + "getSUPG_For_Vector_5()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_5.part", & + "getSUPG_For_Vector_5()", & + "SIZE( C, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, SpaceNodalValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + SpaceNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_5 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part new file mode 100755 index 000000000..23798386c --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_6.part @@ -0,0 +1,177 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_6.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_6 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_6( Obj, U, C, Mu ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & + "getSUPG_For_Vector_6()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & + "getSUPG_For_Vector_6()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & + "getSUPG_For_Vector_6()", & + "SIZE( U, 2 ) should be equal to the NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_6.part", & + "getSUPG_For_Vector_6()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + SpaceNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_6 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part new file mode 100755 index 000000000..385c17f23 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_7.part @@ -0,0 +1,245 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_7.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_7 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_7( Obj, U, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "SIZE( U, 2 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "SIZE( U, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-6 + IF( SIZE( C, 3 ) .NE. NNT .AND. SIZE( C, 3 ) .NE. NIPT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "SIZE( C, 3 ) should be equal to the NNT or NIPT") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'STNodalValues', 'ST Nodal Values') + + CALL Obj % getSUPG_For_Vector_1( U = U, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "Traceback ---> CALL Obj % getSUPG_For_Vector_1( U = U, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS, IPT ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + STNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_7.part", & + "getSUPG_For_Vector_7()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'STNodalValues', 'ST Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_7 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part new file mode 100755 index 000000000..bd8dab7f7 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_8.part @@ -0,0 +1,234 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_8.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_8 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_8( Obj, U, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( :, : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! Define internal variables + INTEGER( I4B ) :: IPS, IPT, NIPS, NIPT, NSD, NNS, NNT + REAL( DFP ), ALLOCATABLE :: cdNTdXt( :, : ), R( : ), rdNTdXt( :, : ), & + dNTdt( :, : ) + REAL( DFP ) :: DummyReal, h, Tau12, Tau3, d1 = 1.0_DFP, d2 = 2.0_DFP, & + pt5 = 0.5_DFP, TauSUPG, mpt5 = -0.5_DFP, d4 = 4.0_DFP + + + Error_Flag = .FALSE. + +! Flag-1 + IF( .NOT. Obj % isInitiated( ) ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "ST_Tau_SUPG_RGN_ Object is not initiated") + Error_Flag = .TRUE. + RETURN + + END IF + + NIPS = Obj % getNIPS( ) + NIPT = Obj % getNIPT( ) + NSD = Obj % SD( 1, 1 ) % getNSD( ) + NNS = Obj % SD( 1, 1 ) % getNNS( ) + NNT = Obj % SD( 1, 1 ) % getNNT( ) + +! Flag-2 + IF( SIZE( U, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "SIZE( U, 1 ) Should be equal to NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 2 ) .NE. NNS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "SIZE( U, 2 ) Should be equal to NNS") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-3 + IF( SIZE( U, 3 ) .NE. NNT ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "SIZE( U, 3 ) should be equal to the NNT") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-4 + IF( SIZE( C, 1 ) .NE. NSD ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "SIZE( C, 1 ) should be equal to the NSD") + Error_Flag = .TRUE. + RETURN + + END IF + +! Flag-5 + IF( SIZE( C, 2 ) .NE. NNS .AND. SIZE( C, 2 ) .NE. NIPS ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "SIZE( C, 2 ) should be equal to the NNS or NIPS") + Error_Flag = .TRUE. + RETURN + + END IF + + + IF( ALLOCATED ( Obj % Mat2 ) ) DEALLOCATE( Obj % Mat2 ) + ALLOCATE( Obj % Mat2( NIPS, NIPT ) ) + Obj % Mat2 = 0.0_DFP + + SELECT CASE( TRIM( ADJUSTL( CType ) ) ) + + CASE( 'Nodal', 'Nodal Values', 'NodalValues', & + 'SpaceNodalValues', 'Space Nodal Values') + + CALL Obj % getSUPG_For_Vector_2( U = U, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "Traceback ---> CALL Obj % getSUPG_For_Vector_2( U = U, C = C )") + + END IF + + CASE( 'Integration', 'IntegrationPoints', 'Integration Points', & + 'Quad', 'QuadPoints', 'Quad Points' ) + + DO IPT = 1, NIPT + + DO IPS = 1, NIPS + + CALL Obj % SD( IPS, IPT ) % getdNTdt( dNTdt ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = cdNTdXt, VectorValues = C( :, IPS ) ) + + CALL Obj % SD( IPS, IPT ) % getUnitNormalOfVector( & + STNodalValues = U, R = R ) + + CALL Obj % SD( IPS, IPT ) % getProjectionOfdNTdXt( & + cdNTdXt = rdNTdXt, VectorValues = R ) + + ! Make Tau3 + + DummyReal = SUM( ABS( rdNTdXt ) ) + IF( DummyReal .LE. zero ) THEN + h = 0.0_DFP + ELSE + h = d2 / DummyReal + END IF + + Tau3 = h * h / d4 / mu + + ! Make Tau12 + + DummyReal = SUM( ABS( dNTdt + cdNTdXt ) ) + + IF( DummyReal .LE. zero ) THEN + Tau12 = 0.0_DFP + ELSE + Tau12 = d1 / DummyReal + END IF + + ! Make Tau SUPG + + TauSUPG = 0.0_DFP + + IF( Tau12 .NE. 0.0_DFP .AND. Tau3 .NE. 0.0_DFP ) THEN + + TauSUPG = ( d1 / Tau12 / Tau12 + d1 / Tau3 / Tau3 )**(mpt5) + + ELSE + + TauSUPG = MAXVAL( (/Tau12, Tau3/) ) + + END IF + + ! Set the value in Mat2 + Obj % Mat2( IPS, IPT ) = TauSUPG + + END DO + + END DO + + CASE DEFAULT + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_8.part", & + "getSUPG_For_Vector_8()", & + "No case found for given CType it should be & + & 'Nodal', 'Nodal Values', 'NodalValues', & + & 'SpaceNodalValues', 'Space Nodal Values', & + & 'Integration', 'IntegrationPoints', 'Integration Points', & + & 'Quad', 'QuadPoints', 'Quad Points' ") + Error_Flag = .TRUE. + RETURN + + + END SELECT + + IF( ALLOCATED( dNTdt ) ) DEALLOCATE( dNTdt ) + IF( ALLOCATED( cdNTdXt ) ) DEALLOCATE( cdNTdXt ) + IF( ALLOCATED( rdNTdXt ) ) DEALLOCATE( rdNTdXt ) + IF( ALLOCATED( R ) ) DEALLOCATE( R ) +! +END SUBROUTINE getSUPG_For_Vector_8 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part new file mode 100755 index 000000000..deeb5d367 --- /dev/null +++ b/src/submodules/ST_Tau_SUPG_RGN/SUPG_Vector_9.part @@ -0,0 +1,63 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: SUPG_Vector_9.part +! Last Update : Nov-25-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! TYPE :: Part of the Code +! +! DESCRIPTION +! - This code is part of the code +! +! HOSTING FILE +! - ST_Tau_SUPG_RGN_Class.f90 +! +!============================================================================== +! +!------------------------------------------------------------------------------ +! getSUPG_For_Vector_9 +!------------------------------------------------------------------------------ +! + SUBROUTINE getSUPG_For_Vector_9( Obj, U, C, Mu, CType ) +! +! DESCRIPTION +!------------------------------------------------------------------------------ +! 1. - Returns Tau SUPG for scalar unknown; & +! C and Phi are space-time nodal values +!------------------------------------------------------------------------------ +! +! Define intent of dummy variables + +#ifdef STMat + CLASS( SpaceTimeMatrix_ ), INTENT( INOUT ), TARGET :: Obj +#else + CLASS( ST_Tau_SUPG_RGN_ ), INTENT( INOUT ), TARGET :: Obj +#endif + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: C + REAL( DFP ), DIMENSION( :, :, : ), INTENT( IN ) :: U + REAL( DFP ), INTENT( IN ) :: Mu + CHARACTER( LEN = * ), INTENT( IN ) :: CType + +! + CALL Obj % getSUPG_For_Vector_3( U = U, C = C, Mu = Mu ) + + IF( Error_Flag ) THEN + + CALL Err_Msg( "ST_Tau_SUPG_RGN_Class.f90>>SUPG_Vector_9.part", & + "getSUPG_For_Vector_9()", & + "Traceback ---> CALL Obj % getSUPG_For_Vector_3( U = U, C = C )") + + END IF +! +END SUBROUTINE getSUPG_For_Vector_9 +! +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +! diff --git a/src/submodules/StiffnessMatrix/CMakeLists.txt b/src/submodules/StiffnessMatrix/CMakeLists.txt new file mode 100644 index 000000000..931cf6240 --- /dev/null +++ b/src/submodules/StiffnessMatrix/CMakeLists.txt @@ -0,0 +1,13 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 1/03/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/StiffnessMatrix_Method@Methods.F90 + ) diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 new file mode 100644 index 000000000..11e983a30 --- /dev/null +++ b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 @@ -0,0 +1,338 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(StiffnessMatrix_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! StiffnessMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix1 +REAL(DFP), ALLOCATABLE :: realval(:), CBar(:, :, :), & + & Ce(:, :), BMat1(:, :), BMat2(:, :) +INTEGER(I4B) :: nips, nns1, nns2, i, j, ips, nsd +INTEGER(I4B), ALLOCATABLE :: indx(:, :) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = SIZE(trial%dNdXt, 2) + +CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) +CALL GetInterpolation(obj=test, interpol=CBar, val=Cijkl) + +SELECT CASE (nsd) +CASE (1) + ALLOCATE (indx(1, 1)) + indx = 1 +CASE (2) + ALLOCATE (indx(2, 2)) + indx = RESHAPE([1, 3, 3, 2], [2, 2]) +CASE (3) + ALLOCATE (indx(3, 3)) + indx = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3]) +END SELECT + +ALLOCATE (Ce(nsd * nsd, nsd * nsd), BMat1(nsd * nns1, nsd * nsd), & + & BMat2(nsd * nns2, nsd * nsd)) + +BMat1 = 0.0_DFP +BMat2 = 0.0_DFP + +CALL Reallocate(realval, nips) +realval = trial%ws * trial%js * trial%thickness + +DO ips = 1, nips + + DO j = 1, nsd + DO i = 1, nsd + Ce((i - 1) * nsd + 1:i * nsd, (j - 1) * nsd + 1:j * nsd) & + & = CBar(indx(:, i), indx(:, j), ips) + END DO + END DO + + DO i = 1, nsd + BMat1((i - 1) * nns1 + 1:i * nns1, (i - 1) * nsd + 1:i * nsd) = & + & test%dNdXt(:, :, ips) + BMat2((i - 1) * nns2 + 1:i * nns2, (i - 1) * nsd + 1:i * nsd) = & + & trial%dNdXt(:, :, ips) + END DO + + ans = ans + realval(ips) * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2)) + +END DO + +DEALLOCATE (BMat1, BMat2, indx, Ce, CBar, realval) + +END PROCEDURE obj_StiffnessMatrix1 + +!---------------------------------------------------------------------------- +! StiffnessMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix2 +! Define internal variable +REAL(DFP), ALLOCATABLE :: lambdaBar(:), muBar(:), & + & realval(:), Ke11(:, :) +REAL(DFP) :: real1, real2, real3 +INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, i, j, r1, r2, ips +LOGICAL(LGT) :: case1 +TYPE(FEVariable_) :: lambda0 + +IF (PRESENT(isLambdaYoungsModulus)) THEN + case1 = isLambdaYoungsModulus +ELSE + case1 = .FALSE. +END IF + +IF (case1) THEN + CALL GetLambdaFromYoungsModulus(lambda=lambda0, & + & youngsModulus=lambda, shearModulus=mu) +ELSE + lambda0 = lambda +END IF + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = SIZE(trial%dNdXt, 2) + +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 Reallocate(realval, nips) +realval = trial%ws * trial%js * trial%thickness + +DO ips = 1, nips + real1 = muBar(ips) * realval(ips) + real2 = (lambdaBar(ips) + muBar(ips)) * realval(ips) + real3 = lambdaBar(ips) * realval(ips) + c1 = 0 + c2 = 0 + DO j = 1, nsd + c1 = c2 + 1 + c2 = j * nns2 + r1 = 0 + r2 = 0 + DO i = 1, nsd + r1 = r2 + 1 + r2 = i * nns1 + IF (i .EQ. j) THEN + Ke11 = real1 * MATMUL( & + & test%dNdXt(:, :, ips), & + & TRANSPOSE(trial%dNdXt(:, :, ips))) & + & + real2 * OUTERPROD( & + & test%dNdXt(:, i, ips), & + & trial%dNdXt(:, i, ips)) + ELSE + Ke11 = real3 * OUTERPROD( & + & test%dNdXt(:, i, ips), & + & trial%dNdXt(:, j, ips)) & + + real1 * & + & OUTERPROD( & + & test%dNdXt(:, j, ips), & + & trial%dNdXt(:, i, ips)) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11 + END DO + END DO +END DO + +DEALLOCATE (realval, Ke11, lambdaBar, muBar) +CALL DEALLOCATE (lambda0) + +END PROCEDURE obj_StiffnessMatrix2 + +!---------------------------------------------------------------------------- +! Stiffnessmatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix3 +INTEGER(I4B) :: nns1, nns2, nips, ips, nsd, c1, c2, r1, r2, i, j +REAL(DFP), ALLOCATABLE :: realval(:), Ke11(:, :) +REAL(DFP) :: real1, real2, real3 +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = SIZE(trial%dNdXt, 2) + +CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) +CALL Reallocate(realval, nips) +realval = trial%ws * trial%thickness * trial%js + +DO ips = 1, nips + real1 = mu * realval(ips) + real2 = (lambda + mu) * realval(ips) + real3 = lambda * realval(ips) + c1 = 0; c2 = 0; + DO j = 1, nsd + c1 = c2 + 1; c2 = j * nns2; r1 = 0; r2 = 0 + DO i = 1, nsd + r1 = r2 + 1; r2 = i * nns1 + IF (i .EQ. j) THEN + Ke11 = real1 * MATMUL(test%dNdXt(:, :, ips), & + & TRANSPOSE(trial%dNdXt(:, :, ips))) & + & + real2 * OUTERPROD(test%dNdXt(:, i, ips), & + & trial%dNdXt(:, i, ips)) + ELSE + Ke11 = real3 * OUTERPROD(test%dNdXt(:, i, ips), & + & trial%dNdXt(:, j, ips)) & + + real1 * & + & OUTERPROD(test%dNdXt(:, j, ips), & + & trial%dNdXt(:, i, ips)) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11 + END DO + END DO +END DO + +DEALLOCATE (realval, Ke11) +END PROCEDURE obj_StiffnessMatrix3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix4 +REAL(DFP), ALLOCATABLE :: realval(:), Ce(:, :), BMat1(:, :), BMat2(:, :) +INTEGER(I4B) :: nips, nns1, nns2, i, j, ips, nsd +INTEGER(I4B), ALLOCATABLE :: indx(:, :) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = SIZE(trial%dNdXt, 2) + +CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) + +SELECT CASE (nsd) +CASE (1) + ALLOCATE (indx(1, 1)) + indx = 1 +CASE (2) + ALLOCATE (indx(2, 2)) + indx = RESHAPE([1, 3, 3, 2], [2, 2]) +CASE (3) + ALLOCATE (indx(3, 3)) + indx = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3]) +END SELECT + +ALLOCATE (Ce(nsd * nsd, nsd * nsd), & + & BMat1(nsd * nns1, nsd * nsd), & + & BMat2(nsd * nns2, nsd * nsd)) + +BMat1 = 0.0_DFP +BMat2 = 0.0_DFP + +CALL Reallocate(realval, nips) +realval = trial%ws * trial%js * trial%thickness + +DO ips = 1, nips + + DO j = 1, nsd + DO i = 1, nsd + Ce((i - 1) * nsd + 1:i * nsd, (j - 1) * nsd + 1:j * nsd) & + & = Cijkl(indx(:, i), indx(:, j)) + END DO + END DO + + DO i = 1, nsd + BMat1((i - 1) * nns1 + 1:i * nns1, (i - 1) * nsd + 1:i * nsd) = & + & test%dNdXt(:, :, ips) + BMat2((i - 1) * nns2 + 1:i * nns2, (i - 1) * nsd + 1:i * nsd) = & + & trial%dNdXt(:, :, ips) + END DO + + ans = ans + realval(ips) * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2)) + +END DO + +DEALLOCATE (BMat1, BMat2, indx, Ce, realval) + +END PROCEDURE obj_StiffnessMatrix4 + +!---------------------------------------------------------------------------- +! StiffnessMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix5 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:), Ke11(:, :) +REAL(DFP) :: real1, real2, real3 +INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, i, j, r1, r2, ips + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = SIZE(trial%dNdXt, 2) + +CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) +ans = 0.0_DFP + +CALL Reallocate(realval, nips) +realval = trial%ws * trial%js * trial%thickness + +DO ips = 1, nips + real1 = mu(ips) * realval(ips) + real2 = (lambda(ips) + mu(ips)) * realval(ips) + real3 = lambda(ips) * realval(ips) + c1 = 0 + c2 = 0 + DO j = 1, nsd + c1 = c2 + 1 + c2 = j * nns2 + r1 = 0 + r2 = 0 + DO i = 1, nsd + r1 = r2 + 1 + r2 = i * nns1 + IF (i .EQ. j) THEN + Ke11 = real1 * MATMUL( & + & test%dNdXt(:, :, ips), & + & TRANSPOSE(trial%dNdXt(:, :, ips))) & + & + real2 * OUTERPROD( & + & test%dNdXt(:, i, ips), & + & trial%dNdXt(:, i, ips)) + ELSE + Ke11 = real3 * OUTERPROD( & + & test%dNdXt(:, i, ips), & + & trial%dNdXt(:, j, ips)) & + + real1 * & + & OUTERPROD( & + & test%dNdXt(:, j, ips), & + & trial%dNdXt(:, i, ips)) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11 + END DO + END DO +END DO + +DEALLOCATE (realval, Ke11) + +END PROCEDURE obj_StiffnessMatrix5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/TriangleInterface/CMakeLists.txt b/src/submodules/TriangleInterface/CMakeLists.txt new file mode 100644 index 000000000..d8f4bc2fd --- /dev/null +++ b/src/submodules/TriangleInterface/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}/TriangleInterface@Methods.F90) diff --git a/src/submodules/TriangleInterface/src/TriangleInterface@Methods.F90 b/src/submodules/TriangleInterface/src/TriangleInterface@Methods.F90 new file mode 100644 index 000000000..4e4f44939 --- /dev/null +++ b/src/submodules/TriangleInterface/src/TriangleInterface@Methods.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 +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(TriangleInterface) Methods +USE ISO_C_BINDING, ONLY: C_LOC, C_F_POINTER, C_ASSOCIATED +USE Display_Method, ONLY: MyDisplay => Display +IMPLICIT NONE + +#include "./definemacro.h" + +CONTAINS + +!---------------------------------------------------------------------------- +! TriangleReport +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriangleDeallocate +CALL TriangleFree(obj) +CALL TriangleNullify(obj) +END PROCEDURE TriangleDeallocate + +!---------------------------------------------------------------------------- +! TriangleSetParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriangleSetParam +IF (PRESENT(pointlist)) obj%pointlist = C_LOC(pointlist) +IF (PRESENT(pointattributelist)) obj%pointattributelist = & + C_LOC(pointattributelist) +IF (PRESENT(pointmarkerlist)) obj%pointmarkerlist = C_LOC(pointmarkerlist) +IF (PRESENT(numberofpoints)) obj%numberofpoints = numberofpoints +IF (PRESENT(numberofpointattributes)) obj%numberofpointattributes = & + numberofpointattributes +IF (PRESENT(trianglelist)) obj%trianglelist = C_LOC(trianglelist) +IF (PRESENT(triangleattributelist)) obj%triangleattributelist = & + C_LOC(triangleattributelist) +IF (PRESENT(trianglearealist)) obj%trianglearealist = C_LOC(trianglearealist) +IF (PRESENT(neighborlist)) obj%neighborlist = C_LOC(neighborlist) +IF (PRESENT(numberoftriangles)) obj%numberoftriangles = numberoftriangles +IF (PRESENT(numberofcorners)) obj%numberofcorners = numberofcorners +IF (PRESENT(numberoftriangleattributes)) obj%numberoftriangleattributes = & + numberoftriangleattributes +IF (PRESENT(segmentlist)) obj%segmentlist = C_LOC(segmentlist) +IF (PRESENT(segmentmarkerlist)) obj%segmentmarkerlist = & + C_LOC(segmentmarkerlist) +IF (PRESENT(numberofsegments)) obj%numberofsegments = numberofsegments +IF (PRESENT(holelist)) obj%holelist = C_LOC(holelist) +IF (PRESENT(numberofholes)) obj%numberofholes = numberofholes +IF (PRESENT(regionlist)) obj%regionlist = C_LOC(regionlist) +IF (PRESENT(numberofregions)) obj%numberofregions = numberofregions +IF (PRESENT(edgelist)) obj%edgelist = C_LOC(edgelist) +IF (PRESENT(edgemarkerlist)) obj%edgemarkerlist = C_LOC(edgemarkerlist) +IF (PRESENT(numberofedges)) obj%numberofedges = numberofedges +IF (PRESENT(normlist)) obj%normlist = C_LOC(normlist) +END PROCEDURE TriangleSetParam + +!---------------------------------------------------------------------------- +! TriangleGetParam +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriangleGetParam +C2F(pointlist, obj%numberofpoints) +C2F(pointattributelist, obj%numberofpointattributes * obj%numberofpoints) +C2F(pointmarkerlist, obj%numberofpoints) +SimpleSet(numberofpoints) +SimpleSet(numberofpointattributes) +C2F(trianglelist, obj%numberofcorners * obj%numberoftriangles) +C2F(triangleattributelist, obj%numberoftriangleattributes * obj%numberoftriangles) +C2F(trianglearealist, obj%numberoftriangles) +C2F(neighborlist, 3 * obj%numberoftriangles) +SimpleSet(numberoftriangles) +SimpleSet(numberofcorners) +SimpleSet(numberoftriangleattributes) +C2F(segmentlist, 2 * obj%numberofsegments) +C2F(segmentmarkerlist, obj%numberofsegments) +SimpleSet(numberofsegments) +C2F(holelist, 2 * obj%numberofholes) +SimpleSet(numberofholes) +C2F(regionlist, 4 * obj%numberofregions) +SimpleSet(numberofregions) +C2F(edgelist, 2 * obj%numberofedges) +C2F(edgemarkerlist, obj%numberofedges) +C2F(normlist, 2 * obj%numberofedges) +SimpleSet(numberofedges) +END PROCEDURE TriangleGetParam + +!---------------------------------------------------------------------------- +! TriangleNullify +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriangleNullify +MyNullify(pointlist) +MyNullify(pointattributelist) +MyNullify(pointmarkerlist) +MyNullify(trianglelist) +MyNullify(triangleattributelist) +MyNullify(trianglearealist) +MyNullify(neighborlist) +MyNullify(segmentlist) +MyNullify(segmentmarkerlist) +MyNullify(holelist) +MyNullify(regionlist) +MyNullify(edgelist) +MyNullify(edgemarkerlist) +MyNullify(normlist) +SimpleNull(numberofpoints) +SimpleNull(numberofpointattributes) +SimpleNull(numberoftriangles) +SimpleNull(numberofcorners) +SimpleNull(numberoftriangleattributes) +SimpleNull(numberofsegments) +SimpleNull(numberofholes) +SimpleNull(numberofregions) +SimpleNull(numberofedges) +END PROCEDURE TriangleNullify + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriangleDisplay + +CALL DisplayPtr("pointlist", obj%pointlist) +CALL DisplayPtr("pointattributelist", obj%pointattributelist) +CALL DisplayPtr("pointmarkerlist", obj%pointmarkerlist) +CALL DisplayPtr("trianglelist", obj%trianglelist) +CALL DisplayPtr("triangleattributelist", obj%triangleattributelist) +CALL DisplayPtr("trianglearealist", obj%trianglearealist) +CALL DisplayPtr("neighborlist", obj%neighborlist) +CALL DisplayPtr("segmentlist", obj%segmentlist) +CALL DisplayPtr("segmentmarkerlist", obj%segmentmarkerlist) +CALL DisplayPtr("holelist", obj%holelist) +CALL DisplayPtr("regionlist", obj%regionlist) +CALL DisplayPtr("edgelist", obj%edgelist) +CALL DisplayPtr("edgemarkerlist", obj%edgemarkerlist) +CALL DisplayPtr("normlist", obj%normlist) + +CALL MyDisplay(obj%numberofpoints, "numberofpoints: ", unitno=unitno) +CALL MyDisplay(obj%numberofpointattributes,"numberofpointattributes: ",unitno=unitno) +CALL MyDisplay(obj%numberoftriangles, "numberoftriangles: ", unitno=unitno) +CALL MyDisplay(obj%numberofcorners, "numberofcorners: ", unitno=unitno) +CALL MyDisplay(obj%numberoftriangleattributes,"numberoftriangleattributes: ",unitno=unitno) +CALL MyDisplay(obj%numberofsegments, "numberofsegments: ", unitno=unitno) +CALL MyDisplay(obj%numberofholes, "numberofholes: ", unitno=unitno) +CALL MyDisplay(obj%numberofregions, "numberofregions: ", unitno=unitno) +CALL MyDisplay(obj%numberofedges, "numberofedges: ", unitno=unitno) + +CONTAINS + +SUBROUTINE DisplayPtr(myname, cptr) + CHARACTER(*), INTENT(in) :: myname + TYPE(C_PTR), INTENT(in) :: cptr + + LOGICAL(LGT) :: abool + abool = C_ASSOCIATED(cptr) + CALL MyDisplay(abool, myname//" ASSOCIATED: ", unitno=unitno) +END SUBROUTINE DisplayPtr + +END PROCEDURE TriangleDisplay + +#include "./undefinemacro.h" + +END SUBMODULE Methods diff --git a/src/submodules/TriangleInterface/src/definemacro.h b/src/submodules/TriangleInterface/src/definemacro.h new file mode 100644 index 000000000..95f27126b --- /dev/null +++ b/src/submodules/TriangleInterface/src/definemacro.h @@ -0,0 +1,4 @@ +#define C2F(a, c) IF(PRESENT(a)) CALL C_F_POINTER(obj % a, a, [c]) +#define MyNullify(a) obj % a = C_NULL_PTR +#define SimpleSet(a) IF(PRESENT(a)) a = obj % a +#define SimpleNull(a) obj % a = 0 diff --git a/src/submodules/TriangleInterface/src/undefinemacro.h b/src/submodules/TriangleInterface/src/undefinemacro.h new file mode 100644 index 000000000..d7c0433ae --- /dev/null +++ b/src/submodules/TriangleInterface/src/undefinemacro.h @@ -0,0 +1,4 @@ +#undef C2F +#undef SimpleSet +#undef SimpleNull +#undef MyNullify diff --git a/src/submodules/Utility/CMakeLists.txt b/src/submodules/Utility/CMakeLists.txt new file mode 100644 index 000000000..c67eb1a0d --- /dev/null +++ b/src/submodules/Utility/CMakeLists.txt @@ -0,0 +1,55 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General 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}/MappingUtility@Methods.F90 + ${src_path}/BinomUtility@Methods.F90 + ${src_path}/MedianUtility@Methods.F90 + ${src_path}/PartitionUtility@Methods.F90 + ${src_path}/SortUtility@Methods.F90 + ${src_path}/SwapUtility@Methods.F90 + ${src_path}/ConvertUtility@Methods.F90 + ${src_path}/ReallocateUtility@Methods.F90 + ${src_path}/ProductUtility@Methods.F90 + ${src_path}/ArangeUtility@Methods.F90 + ${src_path}/GridPointUtility@Methods.F90 + ${src_path}/HeadUtility@Methods.F90 + ${src_path}/TailUtility@Methods.F90 + ${src_path}/SplitUtility@Methods.F90 + ${src_path}/OnesUtility@Methods.F90 + ${src_path}/ZerosUtility@Methods.F90 + ${src_path}/EyeUtility@Methods.F90 + ${src_path}/DiagUtility@Methods.F90 + ${src_path}/AppendUtility@Methods.F90 + ${src_path}/InputUtility@Methods.F90 + ${src_path}/InvUtility@Methods.F90 + ${src_path}/MatmulUtility@Methods.F90 + ${src_path}/ContractionUtility@Methods.F90 + ${src_path}/AssertUtility@Methods.F90 + ${src_path}/ApproxUtility@Methods.F90 + ${src_path}/HashingUtility@Methods.F90 + ${src_path}/MiscUtility@Methods.F90 + ${src_path}/StringUtility@Methods.F90 + ${src_path}/IntegerUtility@Methods.F90 + ${src_path}/PushPopUtility@Methods.F90 + ${src_path}/EigenUtility@Methods.F90 + ${src_path}/SymUtility@Methods.F90 + ${src_path}/TriagUtility@Methods.F90 + ${src_path}/LinearAlgebraUtility@Methods.F90 + ${src_path}/SafeSizeUtility@Methods.F90) diff --git a/src/submodules/Utility/src/Append/Append_1.inc b/src/submodules/Utility/src/Append/Append_1.inc new file mode 100644 index 000000000..4b1b512c0 --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_1.inc @@ -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 + +IF (.NOT. ALLOCATED(A)) THEN + A = [Entry] +ELSE + n = SIZE(A); ALLOCATE (Dummy(n + 1)) + Dummy(1:n) = A; Dummy(1 + n) = Entry + CALL MOVE_ALLOC(From=Dummy, TO=A) +END IF diff --git a/src/submodules/Utility/src/Append/Append_1cd.inc b/src/submodules/Utility/src/Append/Append_1cd.inc new file mode 100644 index 000000000..a49942938 --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_1cd.inc @@ -0,0 +1,27 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +INTEGER(I4B) :: n +!! +n = SIZE(A) +!! +IF( n .NE. 0 ) THEN + CALL Reallocate( C, n+1 ) + C(1:n) = A; C(1 + n) = B +ELSE + C = [B] +END IF +!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Append/Append_2.inc b/src/submodules/Utility/src/Append/Append_2.inc new file mode 100644 index 000000000..c293643fb --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_2.inc @@ -0,0 +1,40 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + + +IF (.NOT. ALLOCATED(A)) THEN + IF (SIZE(ENTRY) .NE. 0) THEN + A = ENTRY + ELSE + ALLOCATE (A(0)) + END IF +ELSE + IF( SIZE( A ) .NE. 0 ) THEN + IF (SIZE(ENTRY) .NE. 0) THEN + m = SIZE(ENTRY); n = SIZE(A) + ALLOCATE (Dummy(n + m)); Dummy(1:n) = A; Dummy(n + 1:) = ENTRY + CALL MOVE_ALLOC(From=Dummy, To=A) + END IF + ELSE + IF (SIZE(ENTRY) .NE. 0) THEN + m = SIZE(ENTRY) + ALLOCATE (Dummy(m)) + Dummy(1:) = ENTRY + CALL MOVE_ALLOC(From=Dummy, To=A) + END IF + END IF +END IF diff --git a/src/submodules/Utility/src/Append/Append_2abcd.inc b/src/submodules/Utility/src/Append/Append_2abcd.inc new file mode 100644 index 000000000..79093c57f --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_2abcd.inc @@ -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 +! + +INTEGER(I4B) :: na, nb, nc + +na = SIZE( A ) +nb = SIZE( B ) +nc = SIZE( C ) + +CALL Reallocate( D, na+nb+nc ) +IF(na .gt. 0) D(1:na) = A +IF(nb .gt. 0) D(na + 1: na+nb) = B +IF(nc .gt. 0) D(na + nb + 1:) = C + + diff --git a/src/submodules/Utility/src/Append/Append_2cd.inc b/src/submodules/Utility/src/Append/Append_2cd.inc new file mode 100644 index 000000000..041e9b253 --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_2cd.inc @@ -0,0 +1,53 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: na, nb +!! +nb = SIZE( B ) +na = SIZE( A ) +!! +IF( na .NE. 0 ) THEN + !! + !! na not zero + !! + IF ( nb .NE. 0) THEN + !! + !! nb not zero + !! + CALL Reallocate( C, na+nb ) + C(1:na) = A + C(na + 1:) = B + !! + ELSE + C = A + END IF + !! +ELSE + !! + !! na is zero + !! + IF (nb .NE. 0) THEN + !! + !! nb is zero + !! + C = B + ELSE + CALL Reallocate( C, 0 ) + END IF + !! +END IF +!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Append/Append_3.inc b/src/submodules/Utility/src/Append/Append_3.inc new file mode 100644 index 000000000..18fe71c13 --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_3.inc @@ -0,0 +1,27 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +IF( mask ) THEN + IF (.NOT. ALLOCATED(A)) THEN + A = [Entry] + ELSE + n = SIZE(A); ALLOCATE (Dummy(n + 1)) + Dummy(1:n) = A; Dummy(1 + n) = Entry + CALL MOVE_ALLOC(From=Dummy, TO=A) + END IF +ELSE + IF (.NOT. ALLOCATED(A)) ALLOCATE( A( 0 ) ) +END IF diff --git a/src/submodules/Utility/src/Append/Append_3cd.inc b/src/submodules/Utility/src/Append/Append_3cd.inc new file mode 100644 index 000000000..90dc7ad51 --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_3cd.inc @@ -0,0 +1,38 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) :: n +!! +n = SIZE(A) +!! +IF( n .NE. 0 ) THEN + !! + IF( mask ) THEN + CALL Reallocate( C, n+1 ) + C(1:n) = A; C(1 + n) = B + ELSE + CALL Reallocate( C, n ) + C = A + END IF +ELSE + IF( mask ) THEN + C = [B] + ELSE + CALL Reallocate( C, 0 ) + END IF +END IF +!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Append/Append_4.inc b/src/submodules/Utility/src/Append/Append_4.inc new file mode 100644 index 000000000..a7c68b784 --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_4.inc @@ -0,0 +1,45 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +IF (.NOT. ALLOCATED(A)) THEN + !! + IF (SIZE(ENTRY) .NE. 0) THEN + m = COUNT( mask ) + IF( m .NE. 0 ) THEN + A = PACK( ENTRY, mask ) + ELSE + ALLOCATE( A(0) ) + END IF + ELSE + ALLOCATE (A(0)) + END IF + !! +ELSE + !! + IF (SIZE(ENTRY) .NE. 0) THEN + m = COUNT( mask ) + IF( m .NE. 0 ) THEN + n = SIZE(A) + ALLOCATE (Dummy(n + m)) + Dummy(1:n) = A + Dummy(n + 1:) = PACK( ENTRY, mask ) + CALL MOVE_ALLOC(From=Dummy, To=A) + END IF + END IF +END IF +!! + diff --git a/src/submodules/Utility/src/Append/Append_4cd.inc b/src/submodules/Utility/src/Append/Append_4cd.inc new file mode 100644 index 000000000..7c84a635b --- /dev/null +++ b/src/submodules/Utility/src/Append/Append_4cd.inc @@ -0,0 +1,63 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) :: n, m, na, nb, nm +!! +na = SIZE( A ) +nb = SIZE( B ) +!! +IF( na .EQ. 0 ) THEN + !! + !! na zero + !! + IF ( nb .EQ. 0 ) THEN + !! + !! nb is zero + !! + CALL REALLOCATE( C, 0 ) + !! + ELSE + !! + !! nb is not zero + !! + nm = COUNT(mask) + !! + IF( nm .EQ. 0 ) THEN + CALL REALLOCATE( C, 0 ) + ELSE + C = PACK( B, mask ) + END IF + END IF + !! +ELSE + !! + !! na is not zero + !! + IF ( nb .EQ. 0 ) THEN + C = A + ELSE + nm = COUNT(mask) + IF( nm .EQ. 0 ) THEN + C = A + ELSE + CALL Reallocate( C, na + nm ) + C(1:na) = A + C(na + 1:) = PACK( B, mask ) + END IF + END IF +END IF +!! \ No newline at end of file diff --git a/src/submodules/Utility/src/AppendUtility@Methods.F90 b/src/submodules/Utility/src/AppendUtility@Methods.F90 new file mode 100644 index 000000000..6a8c90211 --- /dev/null +++ b/src/submodules/Utility/src/AppendUtility@Methods.F90 @@ -0,0 +1,485 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(AppendUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE expand_int8 +INTEGER(INT8), ALLOCATABLE :: tmp(:) +#include "./Expand/Expand.inc" +END PROCEDURE expand_int8 + +MODULE PROCEDURE expand_int16 +INTEGER(INT16), ALLOCATABLE :: tmp(:) +#include "./Expand/Expand.inc" +END PROCEDURE expand_int16 + +MODULE PROCEDURE expand_int32 +INTEGER(INT32), ALLOCATABLE :: tmp(:) +#include "./Expand/Expand.inc" +END PROCEDURE expand_int32 + +MODULE PROCEDURE expand_int64 +INTEGER(INT64), ALLOCATABLE :: tmp(:) +#include "./Expand/Expand.inc" +END PROCEDURE expand_int64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE expand_real32 +REAL(REAL32), ALLOCATABLE :: tmp(:) +#include "./Expand/Expand.inc" +END PROCEDURE expand_real32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE expand_real64 +REAL(REAL64), ALLOCATABLE :: tmp(:) +#include "./Expand/Expand.inc" +END PROCEDURE expand_real64 + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_1a +INTEGER(I4B), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n +#include "./Append/Append_1.inc" +END PROCEDURE Append_1a + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_1b +REAL(DFP), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n +#include "./Append/Append_1.inc" +END PROCEDURE Append_1b + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_1c +#include "./Append/Append_1cd.inc" +END PROCEDURE Append_1c + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_1d +#include "./Append/Append_1cd.inc" +END PROCEDURE Append_1d + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_2a +INTEGER(I4B), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n, m +#include "./Append/Append_2.inc" +END PROCEDURE Append_2a + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_2b +REAL(DFP), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n, m +#include "./Append/Append_2.inc" +END PROCEDURE Append_2b + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_2c +#include "./Append/Append_2cd.inc" +END PROCEDURE Append_2c + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_2d +#include "./Append/Append_2cd.inc" +END PROCEDURE Append_2d + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_2e +#include "./Append/Append_2abcd.inc" +END PROCEDURE Append_2e + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_2f +#include "./Append/Append_2abcd.inc" +END PROCEDURE Append_2f + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_3a +INTEGER(I4B), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n +#include "./Append/Append_3.inc" +END PROCEDURE Append_3a + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_3b +REAL(DFP), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n +#include "./Append/Append_3.inc" +END PROCEDURE Append_3b + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_3c +#include "./Append/Append_3cd.inc" +END PROCEDURE Append_3c + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_3d +#include "./Append/Append_3cd.inc" +END PROCEDURE Append_3d + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_4a +INTEGER(I4B), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n, m +#include "./Append/Append_4.inc" +END PROCEDURE Append_4a + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_4b +REAL(DFP), ALLOCATABLE :: Dummy(:) +INTEGER(I4B) :: n, m +#include "./Append/Append_4.inc" +END PROCEDURE Append_4b + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_4c +#include "./Append/Append_4cd.inc" +END PROCEDURE Append_4c + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Append_4d +#include "./Append/Append_4cd.inc" +END PROCEDURE Append_4d + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE func_Append_1a +CALL Append(ans, A, ENTRY) +END PROCEDURE func_Append_1a + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE func_Append_1b +CALL Append(ans, A, ENTRY) +END PROCEDURE func_Append_1b + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE func_Append_2a +CALL Append(ans, A, ENTRY) +END PROCEDURE func_Append_2a + +!---------------------------------------------------------------------------- +! Append +!---------------------------------------------------------------------------- + +MODULE PROCEDURE func_Append_2b +CALL Append(ans, A, ENTRY) +END PROCEDURE func_Append_2b + +!---------------------------------------------------------------------------- +! colConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE colconcat_1a +#include "./ColConcat/ColConcat_1.inc" +END PROCEDURE colconcat_1a + +MODULE PROCEDURE colconcat_1b +#include "./ColConcat/ColConcat_1.inc" +END PROCEDURE colconcat_1b + +MODULE PROCEDURE colconcat_1c +#include "./ColConcat/ColConcat_1.inc" +END PROCEDURE colconcat_1c + +MODULE PROCEDURE colconcat_1d +#include "./ColConcat/ColConcat_1.inc" +END PROCEDURE colconcat_1d + +MODULE PROCEDURE colconcat_1e +#include "./ColConcat/ColConcat_1.inc" +END PROCEDURE colconcat_1e + +MODULE PROCEDURE colconcat_1f +#include "./ColConcat/ColConcat_1.inc" +END PROCEDURE colconcat_1f + +!---------------------------------------------------------------------------- +! colConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE colconcat_2a +#include "./ColConcat/ColConcat_2.inc" +END PROCEDURE colconcat_2a + +MODULE PROCEDURE colconcat_2b +#include "./ColConcat/ColConcat_2.inc" +END PROCEDURE colconcat_2b + +MODULE PROCEDURE colconcat_2c +#include "./ColConcat/ColConcat_2.inc" +END PROCEDURE colconcat_2c + +MODULE PROCEDURE colconcat_2d +#include "./ColConcat/ColConcat_2.inc" +END PROCEDURE colconcat_2d + +MODULE PROCEDURE colconcat_2e +#include "./ColConcat/ColConcat_2.inc" +END PROCEDURE colconcat_2e + +MODULE PROCEDURE colconcat_2f +#include "./ColConcat/ColConcat_2.inc" +END PROCEDURE colconcat_2f + +!---------------------------------------------------------------------------- +! colConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE colconcat_3a +#include "./ColConcat/ColConcat_3.inc" +END PROCEDURE colconcat_3a + +MODULE PROCEDURE colconcat_3b +#include "./ColConcat/ColConcat_3.inc" +END PROCEDURE colconcat_3b + +MODULE PROCEDURE colconcat_3c +#include "./ColConcat/ColConcat_3.inc" +END PROCEDURE colconcat_3c + +MODULE PROCEDURE colconcat_3d +#include "./ColConcat/ColConcat_3.inc" +END PROCEDURE colconcat_3d + +MODULE PROCEDURE colconcat_3e +#include "./ColConcat/ColConcat_3.inc" +END PROCEDURE colconcat_3e + +MODULE PROCEDURE colconcat_3f +#include "./ColConcat/ColConcat_3.inc" +END PROCEDURE colconcat_3f + +!---------------------------------------------------------------------------- +! colConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE colconcat_4a +#include "./ColConcat/ColConcat_4.inc" +END PROCEDURE colconcat_4a + +MODULE PROCEDURE colconcat_4b +#include "./ColConcat/ColConcat_4.inc" +END PROCEDURE colconcat_4b + +MODULE PROCEDURE colconcat_4c +#include "./ColConcat/ColConcat_4.inc" +END PROCEDURE colconcat_4c + +MODULE PROCEDURE colconcat_4d +#include "./ColConcat/ColConcat_4.inc" +END PROCEDURE colconcat_4d + +MODULE PROCEDURE colconcat_4e +#include "./ColConcat/ColConcat_4.inc" +END PROCEDURE colconcat_4e + +MODULE PROCEDURE colconcat_4f +#include "./ColConcat/ColConcat_4.inc" +END PROCEDURE colconcat_4f + +!---------------------------------------------------------------------------- +! colConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Rowconcat_1a +#include "./RowConcat/RowConcat_1.inc" +END PROCEDURE Rowconcat_1a + +MODULE PROCEDURE Rowconcat_1b +#include "./RowConcat/RowConcat_1.inc" +END PROCEDURE Rowconcat_1b + +MODULE PROCEDURE Rowconcat_1c +#include "./RowConcat/RowConcat_1.inc" +END PROCEDURE Rowconcat_1c + +MODULE PROCEDURE Rowconcat_1d +#include "./RowConcat/RowConcat_1.inc" +END PROCEDURE Rowconcat_1d + +MODULE PROCEDURE Rowconcat_1e +#include "./RowConcat/RowConcat_1.inc" +END PROCEDURE Rowconcat_1e + +MODULE PROCEDURE Rowconcat_1f +#include "./RowConcat/RowConcat_1.inc" +END PROCEDURE Rowconcat_1f + +!---------------------------------------------------------------------------- +! RowConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Rowconcat_2a +#include "./RowConcat/RowConcat_2.inc" +END PROCEDURE Rowconcat_2a + +MODULE PROCEDURE Rowconcat_2b +#include "./RowConcat/RowConcat_2.inc" +END PROCEDURE Rowconcat_2b + +MODULE PROCEDURE Rowconcat_2c +#include "./RowConcat/RowConcat_2.inc" +END PROCEDURE Rowconcat_2c + +MODULE PROCEDURE Rowconcat_2d +#include "./RowConcat/RowConcat_2.inc" +END PROCEDURE Rowconcat_2d + +MODULE PROCEDURE Rowconcat_2e +#include "./RowConcat/RowConcat_2.inc" +END PROCEDURE Rowconcat_2e + +MODULE PROCEDURE Rowconcat_2f +#include "./RowConcat/RowConcat_2.inc" +END PROCEDURE Rowconcat_2f + +!---------------------------------------------------------------------------- +! RowConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Rowconcat_3a +#include "./RowConcat/RowConcat_3.inc" +END PROCEDURE Rowconcat_3a + +MODULE PROCEDURE Rowconcat_3b +#include "./RowConcat/RowConcat_3.inc" +END PROCEDURE Rowconcat_3b + +MODULE PROCEDURE Rowconcat_3c +#include "./RowConcat/RowConcat_3.inc" +END PROCEDURE Rowconcat_3c + +MODULE PROCEDURE Rowconcat_3d +#include "./RowConcat/RowConcat_3.inc" +END PROCEDURE Rowconcat_3d + +MODULE PROCEDURE Rowconcat_3e +#include "./RowConcat/RowConcat_3.inc" +END PROCEDURE Rowconcat_3e + +MODULE PROCEDURE Rowconcat_3f +#include "./RowConcat/RowConcat_3.inc" +END PROCEDURE Rowconcat_3f + +!---------------------------------------------------------------------------- +! RowConcat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Rowconcat_4a +#include "./RowConcat/RowConcat_4.inc" +END PROCEDURE Rowconcat_4a + +MODULE PROCEDURE Rowconcat_4b +#include "./RowConcat/RowConcat_4.inc" +END PROCEDURE Rowconcat_4b + +MODULE PROCEDURE Rowconcat_4c +#include "./RowConcat/RowConcat_4.inc" +END PROCEDURE Rowconcat_4c + +MODULE PROCEDURE Rowconcat_4d +#include "./RowConcat/RowConcat_4.inc" +END PROCEDURE Rowconcat_4d + +MODULE PROCEDURE Rowconcat_4e +#include "./RowConcat/RowConcat_4.inc" +END PROCEDURE Rowconcat_4e + +MODULE PROCEDURE Rowconcat_4f +#include "./RowConcat/RowConcat_4.inc" +END PROCEDURE Rowconcat_4f + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ApproxUtility@Methods.F90 b/src/submodules/Utility/src/ApproxUtility@Methods.F90 new file mode 100644 index 000000000..07d58718f --- /dev/null +++ b/src/submodules/Utility/src/ApproxUtility@Methods.F90 @@ -0,0 +1,323 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ApproxUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! APPROX +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxeq_1 +REAL(REAL64), PARAMETER :: my_zero = 1.0E-10 +ans = (ABS(a - b) .LE. my_zero) +END PROCEDURE approxeq_1 + +!---------------------------------------------------------------------------- +! APPROX +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxeq_2 +REAL(REAL64), PARAMETER :: my_zero = 1.0E-10 +ans = (ABS(a - b) .LE. my_zero) +END PROCEDURE approxeq_2 + +!---------------------------------------------------------------------------- +! APPROXR +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxeqr_1 +REAL(REAL32) :: eps +REAL(REAL32), PARAMETER :: my_zero = REAL(Zero, REAL32) +eps = my_zero + MAX(ABS(a), ABS(b)) * my_zero +ans = (ABS(a - b) .LE. eps) +END PROCEDURE approxeqr_1 + +!---------------------------------------------------------------------------- +! APPROXR +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxeqr_2 +REAL(REAL64) :: eps +REAL(REAL64), PARAMETER :: my_zero = REAL(Zero, REAL64) +eps = my_zero + MAX(ABS(a), ABS(b)) * my_zero +ans = (ABS(a - b) .LE. eps) +END PROCEDURE approxeqr_2 + +!---------------------------------------------------------------------------- +! APPROXEQF +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxeq_ulp_real +LOGICAL(LGT) :: isok + +isok = (a > 0._DFP .AND. b < 0._DFP) .OR. (a < 0._DFP .AND. b > 0._DFP) + +IF (isok) THEN + ans = approxeq_1(a, b) +ELSE + ans = (ABS(TRANSFER(a, 1_I4B) - TRANSFER(b, 1_I4B)) <= 10_I4B) +END IF +END PROCEDURE approxeq_ulp_real + +!---------------------------------------------------------------------------- +! APPROXLE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxle_1 +REAL(DFP), PARAMETER :: my_zero = 1.0E-10 +ans = (r1 - r2 .LE. my_zero) +END PROCEDURE approxle_1 + +!---------------------------------------------------------------------------- +! APPROXLE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxle_2 +REAL(DFP), PARAMETER :: my_zero = 1.0E-10 +ans = (r1 - r2 .LE. my_zero) +END PROCEDURE approxle_2 + +!---------------------------------------------------------------------------- +! APPROXGE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxge_1 +REAL(DFP), PARAMETER :: my_zero = 1.0E-10 +ans = (my_zero .GE. r2 - r1) +END PROCEDURE approxge_1 + +!---------------------------------------------------------------------------- +! APPROXGE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE approxge_2 +REAL(DFP), PARAMETER :: my_zero = 1.0E-10 +ans = (my_zero .GE. r2 - r1) +END PROCEDURE approxge_2 + +!---------------------------------------------------------------------------- +! SOFTEQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softeq_1 +ans = (ABS(r1 - r2) .LE. tol) +END PROCEDURE softeq_1 + +!---------------------------------------------------------------------------- +! SOFTEQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softeq_2 +ans = (ABS(r1 - r2) .LE. tol) +END PROCEDURE softeq_2 + +!---------------------------------------------------------------------------- +! SOFTEQR +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softeqr_1 +REAL(REAL32) :: eps +eps = REAL(Zero, REAL32) + MAX(ABS(r1), ABS(r2)) * tol +ans = (ABS(r1 - r2) .LE. eps) +END PROCEDURE softeqr_1 + +!---------------------------------------------------------------------------- +! SOFTEQR +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softeqr_2 +REAL(REAL64) :: eps +eps = REAL(Zero, REAL64) + MAX(ABS(r1), ABS(r2)) * tol +ans = (ABS(r1 - r2) .LE. eps) +END PROCEDURE softeqr_2 + +!---------------------------------------------------------------------------- +! SOFTLE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softle_1 +ans = (r1 .LE. r2 + tol) +END PROCEDURE softle_1 + +!---------------------------------------------------------------------------- +! SOFTLE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softle_2 +ans = (r1 .LE. r2 + tol) +END PROCEDURE softle_2 + +!---------------------------------------------------------------------------- +! SOFTLT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softlt_1 +ans = (r1 < r2 - tol) +END PROCEDURE softlt_1 + +!---------------------------------------------------------------------------- +! SOFTLT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softlt_2 +ans = (r1 < r2 - tol) +END PROCEDURE softlt_2 + +!---------------------------------------------------------------------------- +! SOFTGE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softge_1 +ans = (r1 + tol .GE. r2) +END PROCEDURE softge_1 + +!---------------------------------------------------------------------------- +! SOFTGE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softge_2 +ans = (r1 + tol .GE. r2) +END PROCEDURE softge_2 + +!---------------------------------------------------------------------------- +! SOFTGT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softgt_1 +ans = (r1 > r2 + tol) +END PROCEDURE softgt_1 + +!---------------------------------------------------------------------------- +! SOFTGT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE softgt_2 +ans = (r1 > r2 + tol) +END PROCEDURE softgt_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE equalto_logical +ans = (l1 .EQV. l2) +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE notequalto_logical +ans = (l1 .NEQV. l2) +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assign_char_to_Int8 +INTEGER(I4B) :: tmpInt +CHARACTER(4) :: fmt +tmpInt = LEN(c) +WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) +READ (c, '(I'//TRIM(fmt)//')') i +END PROCEDURE assign_char_to_Int8 + +MODULE PROCEDURE assign_char_to_Int16 +INTEGER(I4B) :: tmpInt +CHARACTER(4) :: fmt +tmpInt = LEN(c) +WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) +READ (c, '(I'//TRIM(fmt)//')') i +END PROCEDURE assign_char_to_Int16 + +MODULE PROCEDURE assign_char_to_Int32 +INTEGER(I4B) :: tmpInt +CHARACTER(4) :: fmt +tmpInt = LEN(c) +WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) +READ (c, '(I'//TRIM(fmt)//')') i +END PROCEDURE assign_char_to_Int32 + +MODULE PROCEDURE assign_char_to_Int64 +INTEGER(I4B) :: tmpInt +CHARACTER(4) :: fmt +tmpInt = LEN(c) +WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) +READ (c, '(I'//TRIM(fmt)//')') i +END PROCEDURE assign_char_to_Int64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assign_char_to_bool +IF (c == 'true') THEN + b = .TRUE. +ELSE + b = .FALSE. +END IF +END PROCEDURE assign_char_to_bool + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assign_char_to_real32 +INTEGER(I4B) :: tmpInt +CHARACTER(4) :: fmt +tmpInt = LEN(c) +WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) +READ (c, '(f'//TRIM(fmt)//'.0)') s +END PROCEDURE assign_char_to_real32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assign_char_to_real64 +INTEGER(I4B) :: tmpInt +CHARACTER(4) :: fmt +tmpInt = LEN(c) +WRITE (fmt, '(i4)') tmpInt; fmt = ADJUSTL(fmt) +READ (c, '(f'//TRIM(fmt)//'.0)') s +END PROCEDURE assign_char_to_real64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isNumeric +INTEGER(I4B) :: i, val +bool = .FALSE. +IF (LEN(char_str) < 1) THEN + RETURN +ELSE + DO i = 1, LEN(char_str) + ! 0-9 are represented by ASCII codes 48-57 + val = IACHAR(char_str(i:i)) + IF (.NOT. (val > 47 .AND. val < 58)) THEN + ! If any character isn't between those codes, it isn't an integer + RETURN + END IF + END DO +END IF +bool = .TRUE. +END PROCEDURE + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ArangeUtility@Methods.F90 b/src/submodules/Utility/src/ArangeUtility@Methods.F90 new file mode 100644 index 000000000..89c4e4b05 --- /dev/null +++ b/src/submodules/Utility/src/ArangeUtility@Methods.F90 @@ -0,0 +1,128 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(ArangeUtility) Methods +USE BaseMethod, ONLY: INPUT +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! arange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arange_Int8 +! Internal var +INTEGER(INT8) :: incr +INTEGER(INT8) :: i +INTEGER(INT8) :: n +incr = INPUT(default=1_Int8, option=increment) +n = (iend - istart) / incr + 1 +ALLOCATE (Ans(n)) +DO CONCURRENT(i=1:n) + Ans(i) = istart + (i - 1) * incr +END DO +END PROCEDURE arange_Int8 + +!---------------------------------------------------------------------------- +! arange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arange_Int16 +! Internal var +INTEGER(INT16) :: incr +INTEGER(INT16) :: i +INTEGER(INT16) :: n +incr = INPUT(default=1_Int16, option=increment) +n = (iend - istart) / incr + 1 +ALLOCATE (Ans(n)) +DO CONCURRENT(i=1:n) + Ans(i) = istart + (i - 1) * incr +END DO +END PROCEDURE arange_Int16 + +!---------------------------------------------------------------------------- +! arange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arange_Int32 +! Internal var +INTEGER(INT32) :: incr +INTEGER(INT32) :: i +INTEGER(INT32) :: n +incr = INPUT(default=1_Int32, option=increment) +n = (iend - istart) / incr + 1 +ALLOCATE (Ans(n)) +DO CONCURRENT(i=1:n) + Ans(i) = istart + (i - 1) * incr +END DO +END PROCEDURE arange_Int32 +!---------------------------------------------------------------------------- +! arange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arange_Int64 +! Internal var +INTEGER(INT64) :: incr +INTEGER(INT64) :: i +INTEGER(INT64) :: n +incr = INPUT(default=1_Int64, option=increment) +n = (iend - istart) / incr + 1 +ALLOCATE (Ans(n)) +DO CONCURRENT(i=1:n) + Ans(i) = istart + (i - 1) * incr +END DO +END PROCEDURE arange_Int64 + +!---------------------------------------------------------------------------- +! arange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arange_real64 +! internal var +REAL(REAL64) :: incr +INTEGER(I4B) :: i +INTEGER(I4B) :: n + !! +incr = INPUT(Default=1.0_REAL64, Option=increment) + !! +n = (iend - istart + 0.5_REAL64 * incr) / incr + 1 +ALLOCATE (Ans(n)) +DO CONCURRENT(i=1:n) + Ans(i) = istart + (i - 1) * incr +END DO +END PROCEDURE arange_real64 + +!---------------------------------------------------------------------------- +! arange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arange_real32 +! internal var +REAL(REAL32) :: incr +INTEGER(I4B) :: i +INTEGER(I4B) :: n + !! +incr = INPUT(Default=1.0_REAL32, Option=increment) + !! +n = (iend - istart + 0.5_REAL32 * incr) / incr + 1 +ALLOCATE (Ans(n)) +DO CONCURRENT(i=1:n) + Ans(i) = istart + (i - 1) * incr +END DO +END PROCEDURE arange_real32 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/AssertUtility@Methods.F90 b/src/submodules/Utility/src/AssertUtility@Methods.F90 new file mode 100644 index 000000000..aad9ad691 --- /dev/null +++ b/src/submodules/Utility/src/AssertUtility@Methods.F90 @@ -0,0 +1,214 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Assert functions + +SUBMODULE(AssertUtility) Methods +USE BaseMethod, ONLY: ErrorMsg +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Assert_EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_eq2 +IF (n1 .EQ. n2) THEN + assert_eq2 = n1 +ELSE + CALL ErrorMsg( & + & File=__FILE__, & + & Routine="Assert_Eq()", & + & Line=__LINE__, & + & MSG=" Sizes of Matrices are not the same; Program Stopped ") + STOP +END IF +END PROCEDURE assert_eq2 + +!---------------------------------------------------------------------------- +! Assert_EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_eq3 +IF (n1 == n2 .AND. n2 == n3) THEN + assert_eq3 = n1 +ELSE + CALL ErrorMsg( & + & File=__FILE__, & + & Routine="Assert_Eq()", & + & Line=__LINE__, & + & MSG=" Sizes of Matrices are not the same; Program Stopped ") + STOP +END IF +END PROCEDURE assert_eq3 + +!---------------------------------------------------------------------------- +! Assert_EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_eq4 +IF (n1 == n2 .AND. n2 == n3 .AND. n3 == n4) THEN + assert_eq4 = n1 +ELSE + CALL ErrorMsg( & + & File=__FILE__, & + & Routine="Assert_Eq()", & + & Line=__LINE__, & + & MSG=" Sizes of Matrices are not the same; Program Stopped ") + STOP +END IF +END PROCEDURE assert_eq4 + +!---------------------------------------------------------------------------- +! Assert_EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_eqn +IF (ALL(nn(2:) == nn(1))) THEN + assert_eqn = nn(1) +ELSE + CALL ErrorMsg( & + & File=__FILE__, & + & Routine="Assert_Eq()", & + & Line=__LINE__, & + & MSG=" Sizes of Matrices are not the same; Program Stopped ") + STOP +END IF +END PROCEDURE assert_eqn + +!---------------------------------------------------------------------------- +! ASSERT_SHAPE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_shape_2 +INTEGER(I4B) :: shape_mat(2) +shape_mat = SHAPE(Mat) +IF (ALL(shape_mat == s)) THEN + RETURN +ELSE + CALL ErrorMsg( & + & File=file, & + & Routine=routine, & + & Line=line, & + & MSG=msg) + STOP +END IF +END PROCEDURE assert_shape_2 + +!---------------------------------------------------------------------------- +! ASSERT_SHAPE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_shape_3 +INTEGER(I4B) :: shape_mat(3) +shape_mat = SHAPE(Mat) +IF (ALL(shape_mat == s)) THEN + RETURN +ELSE + CALL ErrorMsg(File=file, Routine=routine, Line=line, & + & MSG=msg) + STOP +END IF +END PROCEDURE assert_shape_3 + +!---------------------------------------------------------------------------- +! ASSERT_SHAPE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_shape_4 +INTEGER(I4B) :: shape_mat(4) +shape_mat = SHAPE(Mat) +IF (ALL(shape_mat == s)) THEN + RETURN +ELSE + CALL ErrorMsg(File=file, Routine=routine, Line=line, & + & MSG=msg) + STOP +END IF +END PROCEDURE assert_shape_4 + +!---------------------------------------------------------------------------- +! Assert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_2 +IF (n1 .EQ. n2) THEN + RETURN +ELSE + CALL ErrorMsg( & + & File=file, & + & Routine=routine, & + & Line=line, & + & MSG=msg) + STOP +END IF +END PROCEDURE assert_2 + +!---------------------------------------------------------------------------- +! Assert_EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_3 +IF (n1 == n2 .AND. n2 == n3) THEN + RETURN +ELSE + CALL ErrorMsg( & + & File=file, & + & Routine=routine, & + & Line=line, & + & MSG=msg) + STOP +END IF +END PROCEDURE assert_3 + +!---------------------------------------------------------------------------- +! Assert_EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_4 +IF (n1 == n2 .AND. n2 == n3 .AND. n3 == n4) THEN + RETURN +ELSE + CALL ErrorMsg( & + & File=file, & + & Routine=routine, & + & Line=line, & + & MSG=msg) + STOP +END IF +END PROCEDURE assert_4 + +!---------------------------------------------------------------------------- +! Assert_EQ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE assert_n +IF (ALL(nn(2:) == nn(1))) THEN + RETURN +ELSE + CALL ErrorMsg( & + & File=file, & + & Routine=routine, & + & Line=line, & + & MSG=msg) + STOP +END IF +END PROCEDURE assert_n + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/BinomUtility@Methods.F90 b/src/submodules/Utility/src/BinomUtility@Methods.F90 new file mode 100644 index 000000000..77fc27774 --- /dev/null +++ b/src/submodules/Utility/src/BinomUtility@Methods.F90 @@ -0,0 +1,142 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(BinomUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real32_Binom_Int8 + !! + IF( k .EQ. 0_Int8 ) THEN + ans = 1.0_Real32 + ELSE + ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & + & Real32_Binom_Int8( n=n, k=k-1_Int8, kind=kind ) + END IF + !! +END PROCEDURE Real32_Binom_Int8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real32_Binom_Int16 + !! + IF( k .EQ. 0_Int16 ) THEN + ans = 1.0_Real32 + ELSE + ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & + & Real32_Binom_Int16( n=n, k=k-1_Int16, kind=kind ) + END IF + !! +END PROCEDURE Real32_Binom_Int16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real32_Binom_Int32 + !! + IF( k .EQ. 0_Int32 ) THEN + ans = 1.0_Real32 + ELSE + ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & + & Real32_Binom_Int32( n=n, k=k-1_Int32, kind=kind ) + END IF + !! +END PROCEDURE Real32_Binom_Int32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real32_Binom_Int64 + !! + IF( k .EQ. 0_Int64 ) THEN + ans = 1.0_Real32 + ELSE + ans = REAL(n - k + 1, KIND=Real32) / REAL(k, KIND=Real32) * & + & Real32_Binom_Int64( n=n, k=k-1_Int64, kind=kind ) + END IF + !! +END PROCEDURE Real32_Binom_Int64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real64_Binom_Int8 + !! + IF( k .EQ. 0_Int8 ) THEN + ans = 1.0_Real64 + ELSE + ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & + & Real64_Binom_Int8( n=n, k=k-1_Int8, kind=kind ) + END IF + !! +END PROCEDURE Real64_Binom_Int8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real64_Binom_Int16 + !! + IF( k .EQ. 0_Int16 ) THEN + ans = 1.0_Real64 + ELSE + ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & + & Real64_Binom_Int16( n=n, k=k-1_Int16, kind=kind ) + END IF + !! +END PROCEDURE Real64_Binom_Int16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real64_Binom_Int32 + !! + IF( k .EQ. 0_Int32 ) THEN + ans = 1.0_Real64 + ELSE + ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & + & Real64_Binom_Int32( n=n, k=k-1_Int32, kind=kind ) + END IF + !! +END PROCEDURE Real64_Binom_Int32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Real64_Binom_Int64 + !! + IF( k .EQ. 0_Int64 ) THEN + ans = 1.0_Real64 + ELSE + ans = REAL(n - k + 1, KIND=Real64) / REAL(k, KIND=Real64) * & + & Real64_Binom_Int64( n=n, k=k-1_Int64, kind=kind ) + END IF + !! +END PROCEDURE Real64_Binom_Int64 + +END SUBMODULE Methods \ No newline at end of file diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_1.inc b/src/submodules/Utility/src/ColConcat/ColConcat_1.inc new file mode 100644 index 000000000..e0ebbf859 --- /dev/null +++ b/src/submodules/Utility/src/ColConcat/ColConcat_1.inc @@ -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 +! + +INTEGER(I4B) :: n +n = MAX(SIZE(a), SIZE(b)) +CALL reallocate(ans, n, 2) +ans(1:SIZE(a), 1) = a +ans(1:SIZE(b), 2) = b diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_2.inc b/src/submodules/Utility/src/ColConcat/ColConcat_2.inc new file mode 100644 index 000000000..4c0407718 --- /dev/null +++ b/src/submodules/Utility/src/ColConcat/ColConcat_2.inc @@ -0,0 +1,24 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + + INTEGER(I4B) :: nrow, ncol + + nrow = MAX(SIZE(a,1), SIZE(b)) + ncol = SIZE(a,2) + 1 + CALL reallocate(ans, nrow, ncol) + ans(1:SIZE(a,1), 1:size(a,2) ) = a + ans(1:SIZE(b), ncol) = b diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_3.inc b/src/submodules/Utility/src/ColConcat/ColConcat_3.inc new file mode 100644 index 000000000..2854c5473 --- /dev/null +++ b/src/submodules/Utility/src/ColConcat/ColConcat_3.inc @@ -0,0 +1,24 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + + INTEGER(I4B) :: nrow, ncol + + nrow = MAX(SIZE(b,1), SIZE(a)) + ncol = SIZE(b,2) + 1 + CALL reallocate(ans, nrow, ncol) + ans(1:SIZE(a), 1) = a + ans(1:SIZE(b,1), 2:) = b diff --git a/src/submodules/Utility/src/ColConcat/ColConcat_4.inc b/src/submodules/Utility/src/ColConcat/ColConcat_4.inc new file mode 100644 index 000000000..c3d463251 --- /dev/null +++ b/src/submodules/Utility/src/ColConcat/ColConcat_4.inc @@ -0,0 +1,27 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: nrow, ncol + + nrow = MAX(SIZE(a, 1), SIZE(b, 1)) + ncol = SIZE(a, 2) + SIZE(b, 2) + + CALL reallocate(ans, nrow, ncol) + + ans(1:SIZE(a, 1), 1:SIZE(a, 2)) = a + + ans(1:SIZE(b, 1), SIZE(a, 2) + 1:) = b diff --git a/src/submodules/Utility/src/ContractionUtility@Methods.F90 b/src/submodules/Utility/src/ContractionUtility@Methods.F90 new file mode 100644 index 000000000..6fbe200b9 --- /dev/null +++ b/src/submodules/Utility/src/ContractionUtility@Methods.F90 @@ -0,0 +1,183 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Methods for matrix multiplication + +SUBMODULE(ContractionUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r4_r1 +ans = MATMUL(a1, a2) +END PROCEDURE contraction_r4_r1 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r4_r2 +INTEGER(I4B) :: ii +!! +ans = 0.0_DFP +DO ii = 1, SIZE(a2, 2) + ans = ans + MATMUL(a1(:, :, :, ii), a2(:, ii)) +END DO +END PROCEDURE contraction_r4_r2 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r4_r3 +INTEGER(I4B) :: ii, jj +!! +ans = 0.0_DFP +DO jj = 1, SIZE(a2, 3) + DO ii = 1, SIZE(a2, 2) + ans = ans + MATMUL(a1(:, :, ii, jj), a2(:, ii, jj)) + END DO +END DO +END PROCEDURE contraction_r4_r3 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r4_r4 +ans = SUM(a1 * a2) +END PROCEDURE contraction_r4_r4 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r3_r1 +ans = MATMUL(a1, a2) +END PROCEDURE contraction_r3_r1 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r3_r2 +INTEGER(I4B) :: ii +!! +ans = 0.0_DFP +DO ii = 1, SIZE(a2, 2) + ans = ans + MATMUL(a1(:, :, ii), a2(:, ii)) +END DO +END PROCEDURE contraction_r3_r2 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r3_r3 +ans = SUM(a1 * a2) +END PROCEDURE contraction_r3_r3 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r3_r4 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(a2, 4) + ans(ii) = Contraction(a1, a2(:, :, :, ii)) +END DO +END PROCEDURE contraction_r3_r4 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r2_r1 + ans = matmul(a1, a2) +END PROCEDURE contraction_r2_r1 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r2_r2 + ans = sum(a1*a2) +END PROCEDURE contraction_r2_r2 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r2_r3 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(a2, 3) + ans(ii) = Contraction(a1, a2(:, :, ii)) +END DO +END PROCEDURE contraction_r2_r3 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r2_r4 +INTEGER(I4B) :: ii, jj +DO jj = 1, SIZE(a2, 4) + DO ii = 1, SIZE(a2, 3) + ans(ii, jj) = Contraction(a1, a2(:, :, ii, jj)) + END DO +END DO +END PROCEDURE contraction_r2_r4 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r1_r1 +ans = DOT_PRODUCT(a1, a2) +END PROCEDURE contraction_r1_r1 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r1_r2 +ans = MATMUL(a1, a2) +END PROCEDURE contraction_r1_r2 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r1_r3 +ans = matmul(a1, a2) +END PROCEDURE contraction_r1_r3 + +!---------------------------------------------------------------------------- +! contraction +!---------------------------------------------------------------------------- + +MODULE PROCEDURE contraction_r1_r4 +ans = matmul(a1,a2) +END PROCEDURE contraction_r1_r4 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90 new file mode 100644 index 000000000..658b358e7 --- /dev/null +++ b/src/submodules/Utility/src/ConvertUtility@Methods.F90 @@ -0,0 +1,123 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: This submodule contains method for swaping + +SUBMODULE(ConvertUtility) Methods +USE ReallocateUtility +USE EyeUtility +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE 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 + +!---------------------------------------------------------------------------- +! ConvertSafe +!---------------------------------------------------------------------------- + +MODULE PROCEDURE convert_1_safe +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) +CASE (DofToNodes) + + DO inode = 1, nns + DO idof = 1, tdof + j = (inode - 1) * tdof + idof + T(j, j) = 0 + i = (idof - 1) * nns + inode + T(i, j) = 1 + END DO + END DO + +CASE (NodesToDOF) + + DO idof = 1, tdof + DO inode = 1, nns + j = (idof - 1) * nns + inode + T(j, j) = 0 + i = (inode - 1) * tdof + idof + T(i, j) = 1 + END DO + END DO + +END SELECT + +to = MATMUL(TRANSPOSE(T), MATMUL(from, T)) +END PROCEDURE convert_1_safe + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE convert_2 +! Define internal variables +INTEGER(I4B) :: a, b, I(4), r1, r2, c1, c2 +I = SHAPE(From) +CALL Reallocate(To, I(1) * I(3), I(2) * I(4)) +c1 = 0; c2 = 0 +DO b = 1, I(4) + c1 = c2 + 1 + c2 = b * I(2) + r1 = 0; r2 = 0 + DO a = 1, I(3) + r1 = r2 + 1; + r2 = a * I(1) + To(r1:r2, c1:c2) = From(:, :, a, b) + END DO +END DO +END PROCEDURE convert_2 + +!---------------------------------------------------------------------------- +! Convert +!---------------------------------------------------------------------------- + +MODULE PROCEDURE convert_3 +INTEGER(I4B) :: a, b, s(6) +REAL(DFP), ALLOCATABLE :: m2(:, :) + !! +s = SHAPE(from) +CALL Reallocate(to, s(1) * s(3), s(2) * s(4), s(5), s(6)) + !! +DO b = 1, s(6) + DO a = 1, s(5) + CALL Convert(from=from(:, :, :, :, a, b), to=m2) + to(:, :, a, b) = m2 + END DO +END DO +DEALLOCATE (m2) +END PROCEDURE convert_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Diag/SetDiag.inc b/src/submodules/Utility/src/Diag/SetDiag.inc new file mode 100644 index 000000000..1495021f0 --- /dev/null +++ b/src/submodules/Utility/src/Diag/SetDiag.inc @@ -0,0 +1,62 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: m, n, ii +!! +n = SIZE(mat, 1) +!! +IF (diagNo .EQ. 0) THEN + !! + IF (SIZE(d) .EQ. 1) THEN + DO CONCURRENT(ii=1:n) + mat(ii, ii) = REAL(d(1), kind=DFP) + END DO + ELSE + DO CONCURRENT(ii=1:n) + mat(ii, ii) = REAL(d(ii), kind=DFP) + END DO + END IF + !! +ELSEIF (diagNo .GT. 0) THEN + !! + m = n - diagNo + !! + IF (SIZE(d) .EQ. 1) THEN + DO CONCURRENT(ii=1:m) + mat(ii, ii + diagNo) = REAL(d(1), kind=DFP) + END DO + ELSE + DO CONCURRENT(ii=1:m) + mat(ii, ii + diagNo) = REAL(d(ii), kind=DFP) + END DO + END IF + !! +ELSE + !! + m = n + diagNo + !! + IF (SIZE(d) .EQ. 1) THEN + DO CONCURRENT(ii=1:m) + mat(ii - diagNo, ii) = REAL(d(1), kind=DFP) + END DO + ELSE + DO CONCURRENT(ii=1:m) + mat(ii - diagNo, ii) = REAL(d(ii), kind=DFP) + END DO + END IF + !! +END IF diff --git a/src/submodules/Utility/src/Diag/SetTriDiag.inc b/src/submodules/Utility/src/Diag/SetTriDiag.inc new file mode 100644 index 000000000..dc658326e --- /dev/null +++ b/src/submodules/Utility/src/Diag/SetTriDiag.inc @@ -0,0 +1,55 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: m, n, ii +!! +n = SIZE(mat, 1) +!! +IF (SIZE(d) .EQ. 1) THEN + DO CONCURRENT(ii=1:n) + mat(ii, ii) = REAL(d(1), kind=DFP) + END DO +ELSE + DO CONCURRENT(ii=1:n) + mat(ii, ii) = REAL(d(ii), kind=DFP) + END DO +END IF +!! +m = n - 1 +!! +IF (SIZE(da) .EQ. 1) THEN + DO CONCURRENT(ii=1:m) + mat(ii, ii + 1) = REAL(da(1), kind=DFP) + END DO +ELSE + DO CONCURRENT(ii=1:m) + mat(ii, ii + 1) = REAL(da(ii), kind=DFP) + END DO +END IF +!! +m = n - 1 +!! +IF (SIZE(db) .EQ. 1) THEN + DO CONCURRENT(ii=1:m) + mat(ii + 1, ii) = REAL(db(1), kind=DFP) + END DO +ELSE + DO CONCURRENT(ii=1:m) + mat(ii + 1, ii) = REAL(db(ii), kind=DFP) + END DO +END IF +!! \ No newline at end of file diff --git a/src/submodules/Utility/src/Diag/Tridiag.inc b/src/submodules/Utility/src/Diag/Tridiag.inc new file mode 100644 index 000000000..12eeb9dee --- /dev/null +++ b/src/submodules/Utility/src/Diag/Tridiag.inc @@ -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 +! + +INTEGER(I4B) :: da_No, db_No +ans = Diag(d) +da_No = ABS(INPUT(option=diagNo, default=1)) +db_No = -da_No +CALL SetDiag(mat=ans, d=da, diagNo=da_No) +CALL SetDiag(mat=ans, d=db, diagNo=db_No) diff --git a/src/submodules/Utility/src/DiagUtility@Methods.F90 b/src/submodules/Utility/src/DiagUtility@Methods.F90 new file mode 100644 index 000000000..0e921b2b5 --- /dev/null +++ b/src/submodules/Utility/src/DiagUtility@Methods.F90 @@ -0,0 +1,273 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(DiagUtility) Methods +USE BaseMethod, ONLY: Reallocate, Input +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Diag_1 +INTEGER(I4B) :: ii +ans = 0.0_DFP +DO ii = 1, SIZE(a) + ans(ii, ii) = REAL(a(ii), kind=DFP) +END DO +END PROCEDURE Diag_1 + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Diag_2 +INTEGER(I4B) :: ii +ans = 0.0_DFP +DO ii = 1, SIZE(a) + ans(ii, ii) = REAL(a(ii), kind=DFP) +END DO +END PROCEDURE Diag_2 + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Diag_3 +INTEGER(I4B) :: ii +ans = 0.0_DFP +DO ii = 1, SIZE(a) + ans(ii, ii) = REAL(a(ii), kind=DFP) +END DO +END PROCEDURE Diag_3 + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Diag_4 +INTEGER(I4B) :: ii +ans = 0.0_DFP +DO ii = 1, SIZE(a) + ans(ii, ii) = REAL(a(ii), kind=DFP) +END DO +END PROCEDURE Diag_4 + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Diag_5 +INTEGER(I4B) :: ii +ans = 0.0_DFP +DO ii = 1, SIZE(a) + ans(ii, ii) = REAL(a(ii), kind=DFP) +END DO +END PROCEDURE Diag_5 + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Diag_6 +INTEGER(I4B) :: ii +ans = 0.0_DFP +DO ii = 1, SIZE(a) + ans(ii, ii) = REAL(a(ii), kind=DFP) +END DO +END PROCEDURE Diag_6 + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE Diag_7 +INTEGER(I4B) :: ii +ans = 0.0_DFP +DO ii = 1, SIZE(a) + ans(ii, ii) = REAL(a(ii), kind=DFP) +END DO +END PROCEDURE Diag_7 +#endif + +!---------------------------------------------------------------------------- +! Diag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Diag_8 +INTEGER(I4B) :: n, m, ii +n = SIZE(mat, 1) +IF (diagNo .EQ. 0) THEN + !! + CALL Reallocate(ans, n) + DO CONCURRENT(ii=1:n) + ans(ii) = mat(ii, ii) + END DO + !! +ELSEIF (diagNo .GT. 0) THEN + !! + m = n - diagNo + CALL Reallocate(ans, m) + DO CONCURRENT(ii=1:m) + ans(ii) = mat(ii, ii + diagNo) + END DO + !! +ELSE + !! + m = n + diagNo + CALL Reallocate(ans, m) + DO CONCURRENT(ii=1:m) + ans(ii) = mat(ii - diagNo, ii) + END DO + !! +END IF + !! +END PROCEDURE Diag_8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetDiag1 +#include "./Diag/SetDiag.inc" +END PROCEDURE SetDiag1 + +MODULE PROCEDURE SetDiag2 +#include "./Diag/SetDiag.inc" +END PROCEDURE SetDiag2 + +MODULE PROCEDURE SetDiag3 +#include "./Diag/SetDiag.inc" +END PROCEDURE SetDiag3 + +MODULE PROCEDURE SetDiag4 +#include "./Diag/SetDiag.inc" +END PROCEDURE SetDiag4 + +MODULE PROCEDURE SetDiag5 +#include "./Diag/SetDiag.inc" +END PROCEDURE SetDiag5 + +MODULE PROCEDURE SetDiag6 +#include "./Diag/SetDiag.inc" +END PROCEDURE SetDiag6 + +!---------------------------------------------------------------------------- +! SetTriDiag +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetTriDiag1 +#include "./Diag/SetTriDiag.inc" +END PROCEDURE SetTriDiag1 + +MODULE PROCEDURE SetTriDiag2 +#include "./Diag/SetTriDiag.inc" +END PROCEDURE SetTriDiag2 + +MODULE PROCEDURE SetTriDiag3 +#include "./Diag/SetTriDiag.inc" +END PROCEDURE SetTriDiag3 + +MODULE PROCEDURE SetTriDiag4 +#include "./Diag/SetTriDiag.inc" +END PROCEDURE SetTriDiag4 + +MODULE PROCEDURE SetTriDiag5 +#include "./Diag/SetTriDiag.inc" +END PROCEDURE SetTriDiag5 + +MODULE PROCEDURE SetTriDiag6 +#include "./Diag/SetTriDiag.inc" +END PROCEDURE SetTriDiag6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiagSize1 +ans = DiagSize(m=n, n=n, diagNo=diagNo) +END PROCEDURE DiagSize1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiagSize2 +IF (diagNo .GE. 0 .AND. diagNo .LE. n) THEN + ans = MIN(m, n - diagNo) +ELSE IF (diagNo .LT. 0 .AND. -diagNo .LE. m) THEN + ans = MIN(n, m + diagNo) +ELSE + ans = 0 +END IF +END PROCEDURE DiagSize2 + +!---------------------------------------------------------------------------- +! DiagIndx +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiagIndx +INTEGER(I4B) :: tsize, ii +! +tsize = DiagSize(m, n, diagNo) +! +ALLOCATE (ans(tsize, 2)) +! +IF (diagNo .GE. 0 .AND. diagNo .LE. n) THEN + DO CONCURRENT(ii=1:tsize) + ans(ii, 1) = ii + ans(ii, 2) = ii + diagNo + END DO +ELSE IF (diagNo .LT. 0 .AND. -diagNo .LE. m) THEN + DO CONCURRENT(ii=1:tsize) + ans(ii, 2) = ii + ans(ii, 1) = ii - diagNo + END DO +END IF +END PROCEDURE DiagIndx + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Tridiag_1 +#include "./Diag/Tridiag.inc" +END PROCEDURE Tridiag_1 + +MODULE PROCEDURE Tridiag_2 +#include "./Diag/Tridiag.inc" +END PROCEDURE Tridiag_2 + +MODULE PROCEDURE Tridiag_3 +#include "./Diag/Tridiag.inc" +END PROCEDURE Tridiag_3 + +MODULE PROCEDURE Tridiag_4 +#include "./Diag/Tridiag.inc" +END PROCEDURE Tridiag_4 + +MODULE PROCEDURE Tridiag_5 +#include "./Diag/Tridiag.inc" +END PROCEDURE Tridiag_5 + +MODULE PROCEDURE Tridiag_6 +#include "./Diag/Tridiag.inc" +END PROCEDURE Tridiag_6 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/EigenUtility@Methods.F90 b/src/submodules/Utility/src/EigenUtility@Methods.F90 new file mode 100644 index 000000000..075472fce --- /dev/null +++ b/src/submodules/Utility/src/EigenUtility@Methods.F90 @@ -0,0 +1,335 @@ +! This program is mat part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR mat PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received mat copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(EigenUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymEigenValues2by2 +REAL(DFP) :: i1, i2, a, b +i1 = mat(1, 1) + mat(2, 2) +i2 = (mat(1, 1) - mat(2, 2))**2 + 4.0_DFP * (mat(1, 2)**2) +a = 0.5_DFP * i1 +! b = SQRT(a**2 - i2) +b = 0.5_DFP * SQRT(i2) +ans(1) = a - b +ans(2) = a + b +END PROCEDURE SymEigenValues2by2 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymEigenValues3by3 +REAL(DFP) :: q, p, r +REAL(DFP), PARAMETER :: twothirdpi = 2.0_DFP * pi / 3.0_DFP +!! +r = mat(1, 2) * mat(1, 2) + mat(1, 3) * mat(1, 3) + mat(2, 3) * mat(2, 3) +q = (mat(1, 1) + mat(2, 2) + mat(3, 3)) / 3.0_DFP +!! +ans(1) = mat(1, 1) - q +ans(2) = mat(2, 2) - q +ans(3) = mat(3, 3) - q +!! +p = SQRT((ans(1) * ans(1) + ans(2) * ans(2) + ans(3) * ans(3) + 2 * r) & + & / 6.0_DFP) +!! +r = (ans(1) * (ans(2) * ans(3) - mat(2, 3) * mat(2, 3)) & + & - mat(1, 2) * (mat(1, 2) * ans(3) - mat(2, 3) * mat(1, 3)) & + & + mat(1, 3) * (mat(1, 2) * mat(2, 3) - ans(2) * mat(1, 3))) & + & / (p * p * p) * 0.5_DFP +!! +IF (r <= -1.0_DFP) THEN + r = 0.5_DFP * twothirdpi +ELSE IF (r >= 1.0_DFP) THEN + r = 0.0_DFP +ELSE + r = acos(r) / 3.0_DFP +END IF +!! +ans(3) = q + 2 * p * cos(r) +ans(1) = q + 2 * p * cos(r + twothirdpi) +ans(2) = 3 * q - ans(1) - ans(3) +!! +END PROCEDURE SymEigenValues3by3 + +!---------------------------------------------------------------------------- +! SymEigenValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymEigenValuesUpto3 +!! +SELECT CASE (SIZE(mat, 1)) +CASE (1) + ans(1) = mat(1, 1) +CASE (2) + ans = SymEigenValues2by2(mat=mat) +CASE (3) + ans = SymEigenValues3by3(mat=mat) +END SELECT +END PROCEDURE SymEigenValuesUpto3 + +!---------------------------------------------------------------------------- +! SymEigenValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SymEigenValues +INTEGER(I4B) :: n +REAL(DFP), DIMENSION(SIZE(mat, 1), SIZE(mat, 2)) :: temp +!! +n = SIZE(mat, 1) +!! +SELECT CASE (n) +CASE (1) + ans(1) = mat(1, 1) +CASE (2) + ans = SymEigenValues2by2(mat=mat) +CASE (3) + ans = SymEigenValues3by3(mat=mat) +CASE DEFAULT +#ifdef USE_LAPACK95 + temp = mat + CALL SYEV(A=temp, W=ans, JOBZ="N") +#else + CALL ErrorMsg( & + & msg="This routine requires Lapack95 interface", & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymEigenValues()", & + & unitno=stderr) +#endif + !! +END SELECT +END PROCEDURE SymEigenValues + +!---------------------------------------------------------------------------- +! SymEigenValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetSymEigenValues_ +INTEGER(I4B) :: n +!! +n = SIZE(mat, 1) +!! +SELECT CASE (n) +CASE (1) + eigenValues(1) = mat(1, 1) +CASE (2) + eigenValues = SymEigenValues2by2(mat=mat) +CASE (3) + eigenValues = SymEigenValues3by3(mat=mat) +CASE DEFAULT +#ifdef USE_LAPACK95 + CALL SYEV(A=mat, W=eigenValues, JOBZ="N") +#else + CALL ErrorMsg( & + & msg="This routine requires Lapack95 interface", & + & file=__FILE__, & + & line=__LINE__, & + & routine="SymEigenValues_()", & + & unitno=stderr) +#endif + !! +END SELECT +END PROCEDURE GetSymEigenValues_ + +!---------------------------------------------------------------------------- +! SymEigenValues +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetSymEigenValues +REAL(DFP), DIMENSION(SIZE(mat, 1), SIZE(mat, 2)) :: temp +temp = mat +CALL GetSymEigenValues_(mat=temp, eigenValues=eigenValues) +END PROCEDURE GetSymEigenValues + +!---------------------------------------------------------------------------- +! GetSymEigenJacobi +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetSymEigenJacobi +INTEGER(I4B) :: i, ip, iq, n, ii, jj, tRot +REAL(DFP) :: c, g, h, s, sm, t, tau, theta, tresh +REAL(DFP), DIMENSION(SIZE(EigenValues)) :: b, z +REAL(DFP), DIMENSION(SIZE(mat, 1), SIZE(mat, 2)) :: tempMat +REAL(DFP), PARAMETER :: tol = 1.0E-10 + +tempMat = mat + +n = SIZE(mat, 1) + +!---- Initialize v to the identity matrix. +CALL unit_matrix(EigenVectors(:, :)) + +!---- Initialize b and d to the diagonal of A +!---- This vector will accumulate terms of the +!---- form tapq as in eq. (11.1.14). +b(:) = get_diag(tempMat(:, :)) +EigenValues(:) = b(:) +z(:) = 0.0_DFP +tRot = 0 + +DO i = 1, MaxIter + + !---- SUM off-diagonal elements. + sm = SUM(ABS(tempMat), mask=upper_triangle(n, n)) + IF (SOFTEQ(sm, 0.0_DFP, tol)) THEN + + !---- Restore the upper diagonal part + DO jj = 1, n + DO ii = 1, jj - 1 + tempMat(ii, jj) = tempMat(jj, ii) + END DO + END DO + + !---- Sort the Eigen vector and Eigen values in decreasing order + CALL SortEigenValues(EigenValues=EigenValues, & + & EigenVectors=EigenVectors) + RETURN + + END IF + + !---- The normal return, which relies on quadratic convergence + !---- to machine underflow. + tresh = MERGE(0.2_DFP * sm / n**2, 0.0_DFP, i < 4) + + !---- On the first three sweeps, we will rotate only IF tresh exceeded. + DO ip = 1, n - 1 + DO iq = ip + 1, n + g = 100.0_DFP * ABS(tempMat(ip, iq)) + !---- After four sweeps, skip the rotation IF the off-diagonal + !---- element is small. + IF ((i > 4) .AND. (ABS(EigenValues(ip)) + g .EQ. & + & ABS(EigenValues(ip))) .AND. (ABS(EigenValues(iq)) & + & + g .EQ. ABS(EigenValues(iq)))) THEN + + tempMat(ip, iq) = 0.0_DFP + + ELSE IF (ABS(tempMat(ip, iq)) .GT. tresh) THEN + + h = EigenValues(iq) - EigenValues(ip) + + IF (ABS(h) + g .EQ. ABS(h)) THEN + t = tempMat(ip, iq) / h + ELSE + theta = 0.5_DFP * h / tempMat(ip, iq) + t = 1.0_DFP / (ABS(theta) + SQRT(1.0_DFP + theta**2)) + IF (theta .LT. 0.0_DFP) t = -t + END IF + + c = 1.0_DFP / SQRT(1 + t**2) + s = t * c + tau = s / (1.0_DFP + c) + h = t * tempMat(ip, iq) + z(ip) = z(ip) - h + z(iq) = z(iq) + h + EigenValues(ip) = EigenValues(ip) - h + EigenValues(iq) = EigenValues(iq) + h + tempMat(ip, iq) = 0.0_DFP + + CALL jrotate(tempMat(1:ip - 1, ip), tempMat(1:ip - 1, iq)) + ! Case of rotations 1 ≤ j < p. + CALL jrotate(tempMat(ip, ip + 1:iq - 1), tempMat(ip + 1:iq - 1, iq)) + ! Case of rotations p < j < q. + CALL jrotate(tempMat(ip, iq + 1:n), tempMat(iq, iq + 1:n)) + ! Case of rotations q < j ≤ n. + CALL jrotate(EigenVectors(:, ip), EigenVectors(:, iq)) + tRot = tRot + 1 + END IF + END DO + END DO + + b(:) = b(:) + z(:) + ! Update d with the SUM of tapq, and reinitialize z. + EigenValues(:) = b(:) + z(:) = 0.0_DFP +END DO + +CONTAINS + +PURE SUBROUTINE jrotate(a1, a2) + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: a1, a2 + REAL(DFP), DIMENSION(SIZE(a1)) :: wk1 + wk1(:) = a1(:) + a1(:) = a1(:) - s * (a2(:) + a1(:) * tau) + a2(:) = a2(:) + s * (wk1(:) - a2(:) * tau) +END SUBROUTINE jrotate + +PURE FUNCTION get_diag(mat) + REAL(DFP), DIMENSION(:, :), INTENT(IN) :: mat + REAL(DFP), DIMENSION(SIZE(mat, 1)) :: get_diag + INTEGER(I4B) :: j + j = size(mat, 1) + DO j = 1, size(mat, 1) + get_diag(j) = mat(j, j) + END DO +END FUNCTION get_diag + +PURE SUBROUTINE unit_matrix(mat) + REAL(DFP), DIMENSION(:, :), INTENT(OUT) :: mat + INTEGER(I4B) :: i, n + n = min(size(mat, 1), size(mat, 2)) + mat(:, :) = 0.0_sp + DO i = 1, n + mat(i, i) = 1.0_sp + END DO +END SUBROUTINE unit_matrix + +PURE SUBROUTINE SortEigenValues(EigenValues, EigenVectors) + REAL(DFP), DIMENSION(:), INTENT(INOUT) :: EigenValues + REAL(DFP), DIMENSION(:, :), INTENT(INOUT) :: EigenVectors + INTEGER(I4B) :: i, j, n + + n = SIZE(EigenValues) + + DO i = 1, n - 1 + j = ImaxLoc(EigenValues(i:n)) + j = j + i - 1 + IF (j .NE. i) THEN + CALL SWAP(EigenValues(i), EigenValues(j)) + CALL SWAP(EigenVectors(:, i), EigenVectors(:, j)) + END IF + END DO +END SUBROUTINE SortEigenValues + +PURE FUNCTION upper_triangle(j, k, extra) + INTEGER(I4B), INTENT(IN) :: j, k + INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra + LOGICAL(LGT), DIMENSION(j, k) :: upper_triangle + INTEGER(I4B) :: n + n = 0 + IF (PRESENT(extra)) n = extra + upper_triangle = (outerDiff(arth(1, 1, j), arth(1, 1, k)) < n) +END FUNCTION upper_triangle + +! PURE FUNCTION lower_triangle(j,k,extra) +! INTEGER(I4B), INTENT(IN) :: j,k +! INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra +! LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle +! INTEGER(I4B) :: n +! n=0 +! IF (PRESENT(extra)) n=extra +! lower_triangle=(outerdIFf(arth_i(1,1,j),arth_i(1,1,k)) > -n) +! END FUNCTION lower_triangle +END PROCEDURE GetSymEigenJacobi + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Expand/Expand.inc b/src/submodules/Utility/src/Expand/Expand.inc new file mode 100644 index 000000000..520cd21bb --- /dev/null +++ b/src/submodules/Utility/src/Expand/Expand.inc @@ -0,0 +1,47 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! temporary array +!! +IF( PRESENT(val) ) THEN + IF( ALLOCATED(vec) ) THEN + IF( n .EQ. SIZE(vec)) THEN + ! have to add another chunk: + ALLOCATE(tmp(SIZE(vec)+chunk_size)) + tmp(1:SIZE(vec)) = vec + CALL MOVE_ALLOC(tmp,vec) + END IF + n = n + 1 + ELSE + ! the first element: + ALLOCATE(vec(chunk_size)) + n = 1 + END IF + vec(n) = val +END IF +!! +!! +!! +IF (PRESENT(finished)) THEN + IF (finished) THEN + ! set vec to actual size (n): + IF (ALLOCATED(tmp)) DEALLOCATE(tmp) + ALLOCATE(tmp(n)) + tmp = vec(1:n) + CALL MOVE_ALLOC(tmp,vec) + END IF +END IF \ No newline at end of file diff --git a/src/submodules/Utility/src/Expand/ExpandMatrix.inc b/src/submodules/Utility/src/Expand/ExpandMatrix.inc new file mode 100644 index 000000000..511cf0f09 --- /dev/null +++ b/src/submodules/Utility/src/Expand/ExpandMatrix.inc @@ -0,0 +1,55 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +!! +!! temporary array +!! + +INTEGER( I4B ) :: dimSize1, dimSize2, otherdim + + +IF (PRESENT(val)) THEN + IF (dim .EQ. 1) THEN + ELSE + END IF + + IF (ALLOCATED(mat)) THEN + IF (n .EQ. SIZE(mat, dim)) THEN + ! have to add another chunk: + ALLOCATE (tmp(SIZE(mat, dim) + chunk_size, SIZE(mat, otherdim))) + tmp(1:SIZE(mat, 1), 1:SIZE(mat, 2) ) = mat + CALL MOVE_ALLOC(tmp, mat) + END IF + n = n + 1 + ELSE + ! the first element: + ALLOCATE (mat(chunk_size)) + n = 1 + END IF + mat(n) = val +END IF +!! +!! +!! +IF (PRESENT(finished)) THEN + IF (finished) THEN + ! set mat to actual size (n): + IF (ALLOCATED(tmp)) DEALLOCATE (tmp) + ALLOCATE (tmp(n)) + tmp = mat(1:n) + CALL MOVE_ALLOC(tmp, mat) + END IF +END IF diff --git a/src/submodules/Utility/src/EyeUtility@Methods.F90 b/src/submodules/Utility/src/EyeUtility@Methods.F90 new file mode 100644 index 000000000..9337cd5e8 --- /dev/null +++ b/src/submodules/Utility/src/EyeUtility@Methods.F90 @@ -0,0 +1,120 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(EyeUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE int_eye_1 +INTEGER(I4B) :: i +Ans = 0_INT8 +DO i = 1, m + Ans(i, i) = 1 +END DO +END PROCEDURE int_eye_1 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE int_eye_2 +INTEGER(I4B) :: i +Ans = 0_INT16 +DO i = 1, m + Ans(i, i) = 1 +END DO +END PROCEDURE int_eye_2 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE int_eye_3 +INTEGER(I4B) :: i +Ans = 0_INT32 +DO i = 1, m + Ans(i, i) = 1 +END DO +END PROCEDURE int_eye_3 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE int_eye_4 +INTEGER(I4B) :: i +Ans = 0_INT64 +DO i = 1, m + Ans(i, i) = 1 +END DO +END PROCEDURE int_eye_4 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE int_eye_5 +INTEGER(I4B) :: i +Ans = 0_INT128 +DO i = 1, m + Ans(i, i) = 1 +END DO +END PROCEDURE int_eye_5 +#endif + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE real_eye_1 +INTEGER(I4B) :: i +Ans = 0.0 +DO i = 1, m + Ans(i, i) = 1.0 +END DO +END PROCEDURE real_eye_1 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE real_eye_2 +INTEGER(I4B) :: i +Ans = 0.0 +DO i = 1, m + Ans(i, i) = 1.0 +END DO +END PROCEDURE real_eye_2 + +!---------------------------------------------------------------------------- +! Eye +!---------------------------------------------------------------------------- + +MODULE PROCEDURE real_eye_3 +INTEGER(I4B) :: i +Ans = 0.0 +DO i = 1, m + Ans(i, i) = 1.0 +END DO +END PROCEDURE real_eye_3 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/GridPointUtility@Methods.F90 b/src/submodules/Utility/src/GridPointUtility@Methods.F90 new file mode 100644 index 000000000..a01b11291 --- /dev/null +++ b/src/submodules/Utility/src/GridPointUtility@Methods.F90 @@ -0,0 +1,239 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(GridPointUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ExpMesh +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ExpMesh_Real64 +INTEGER(I4B) :: i +REAL(DFP) :: alpha, beta + !! +IF (ABS(a - 1) .LT. TINY(1.0_DFP)) THEN + alpha = (rmax - rmin) / N + DO i = 1, N + 1 + ans(i) = alpha * (i - 1.0_DFP) + rmin + END DO +ELSE + IF (N .GT. 1) THEN + beta = LOG(a) / (N - 1) + alpha = (rmax - rmin) / (EXP(beta * N) - 1) + DO i = 1, N + 1 + ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin + END DO + ELSE IF (N .EQ. 1) THEN + ans(1) = rmin + ans(2) = rmax + END IF +END IF + !! +END PROCEDURE ExpMesh_Real64 + +!---------------------------------------------------------------------------- +! ExpMesh +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ExpMesh_Real32 +INTEGER(I4B) :: i +REAL(Real32) :: alpha, beta + !! +IF (ABS(a - 1) .LT. TINY(1.0_DFP)) THEN + alpha = (rmax - rmin) / N + DO i = 1, N + 1 + ans(i) = alpha * (i - 1.0_Real32) + rmin + END DO +ELSE + IF (N .GT. 1) THEN + beta = LOG(a) / (N - 1) + alpha = (rmax - rmin) / (EXP(beta * N) - 1) + DO i = 1, N + 1 + ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin + END DO + ELSE IF (N .EQ. 1) THEN + ans(1) = rmin + ans(2) = rmax + END IF +END IF + !! +END PROCEDURE ExpMesh_Real32 + +!---------------------------------------------------------------------------- +! Linspace +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LinSpace_Real32 +! Local vars +REAL(Real32) :: dx +INTEGER(I4B) :: i +INTEGER(I4B) :: nn + !! main +nn = INPUT(option=n, default=100) +IF (nn .EQ. 1) THEN + ans = [a] +ELSE + ALLOCATE (ans(nn)) + dx = (b - a) / REAL((nn - 1), Real32) + ans = [(i * dx + a, i=0, nn - 1)] +END IF +END PROCEDURE LinSpace_Real32 + +!---------------------------------------------------------------------------- +! LinSpace +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LinSpace_Real64 +! Local vars +REAL(Real64) :: dx +INTEGER(I4B) :: i +INTEGER(I4B) :: nn +!> main +nn = INPUT(option=n, default=100) +IF (nn .EQ. 1) THEN + ans = [a] +ELSE + ALLOCATE (ans(nn)) + dx = (b - a) / REAL((nn - 1), Real64) + ans = [(i * dx + a, i=0, nn - 1)] +END IF +END PROCEDURE LinSpace_Real64 + +!---------------------------------------------------------------------------- +! Linspace +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LogSpace_Real32 +INTEGER(I4B) :: base0, n0 +LOGICAL(LGT) :: endpoint0 +REAL(Real32), ALLOCATABLE :: ans0(:) + !! +endpoint0 = INPUT(option=endPoint, default=.TRUE.) +base0 = INPUT(option=base, default=10) +n0 = INPUT(option=n, default=100_I4B) + !! +IF (endpoint0) THEN + ans0 = Linspace(a=a, b=b, n=n0) + ans = base0**(ans0) +ELSE + ans0 = Linspace(a=a, b=b, n=n0 + 1) + ans = base0**(ans0(1:n0)) +END IF + !! +IF (ALLOCATED(ans0)) DEALLOCATE (ans0) +END PROCEDURE LogSpace_Real32 + +!---------------------------------------------------------------------------- +! Linspace +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LogSpace_Real64 +INTEGER(I4B) :: base0, n0 +LOGICAL(LGT) :: endpoint0 +REAL(Real64), ALLOCATABLE :: ans0(:) + !! +endpoint0 = INPUT(option=endPoint, default=.TRUE.) +base0 = INPUT(option=base, default=10) +n0 = INPUT(option=n, default=100_I4B) + !! +IF (endpoint0) THEN + ans0 = Linspace(a=a, b=b, n=n0) + ans = base0**(ans0) +ELSE + ans0 = Linspace(a=a, b=b, n=n0 + 1) + ans = base0**(ans0(1:n0)) +END IF + !! +IF (ALLOCATED(ans0)) DEALLOCATE (ans0) +END PROCEDURE LogSpace_Real64 + +!---------------------------------------------------------------------------- +! MeshGrid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MeshGrid2D_Real64 +! Local variables +INTEGER(I4B) :: nx +INTEGER(I4B) :: ny +! Initial setting +nx = SIZE(xgv, dim=1) +ny = SIZE(ygv, dim=1) +CALL Reallocate(x, ny, nx) +CALL Reallocate(y, ny, nx) +x(:, :) = SPREAD(xgv, dim=2, ncopies=ny) +y(:, :) = SPREAD(ygv, dim=1, ncopies=nx) +END PROCEDURE MeshGrid2D_Real64 + +!---------------------------------------------------------------------------- +! MeshGrid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MeshGrid2D_Real32 +! Local variables +INTEGER(I4B) :: nx +INTEGER(I4B) :: ny +! Initial setting +nx = SIZE(xgv, dim=1) +ny = SIZE(ygv, dim=1) +CALL Reallocate(x, ny, nx) +CALL Reallocate(y, ny, nx) +x(:, :) = SPREAD(xgv, dim=2, ncopies=ny) +y(:, :) = SPREAD(ygv, dim=1, ncopies=nx) +END PROCEDURE MeshGrid2D_Real32 + +!---------------------------------------------------------------------------- +! MeshGrid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MeshGrid3D_Real64 +integer :: nx, ny, nz, i +nx = size(xgv); ny = size(ygv); nz = size(zgv) +CALL Reallocate(x, nx, ny, nz) +CALL Reallocate(y, nx, ny, nz) +CALL Reallocate(z, nx, ny, nz) +DO i = 1, nz + x(:, :, i) = SPREAD(xgv, dim=2, ncopies=ny) + y(:, :, i) = SPREAD(ygv, dim=1, ncopies=nx) +END DO +DO i = 1, nx + z(i, :, :) = SPREAD(zgv, dim=1, ncopies=ny) +END DO +END PROCEDURE MeshGrid3D_Real64 + +!---------------------------------------------------------------------------- +! MeshGrid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MeshGrid3D_Real32 +integer :: nx, ny, nz, i +nx = size(xgv); ny = size(ygv); nz = size(zgv) +CALL Reallocate(x, ny, nx, nz) +CALL Reallocate(y, ny, nx, nz) +CALL Reallocate(z, ny, nx, nz) +DO i = 1, nz + x(:, :, i) = SPREAD(xgv, dim=2, ncopies=ny) + y(:, :, i) = SPREAD(ygv, dim=1, ncopies=nx) +END DO +DO i = 1, nx + z(i, :, :) = SPREAD(zgv, dim=1, ncopies=ny) +END DO +END PROCEDURE MeshGrid3D_Real32 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/HashingUtility@Methods.F90 b/src/submodules/Utility/src/HashingUtility@Methods.F90 new file mode 100644 index 000000000..3a814257a --- /dev/null +++ b/src/submodules/Utility/src/HashingUtility@Methods.F90 @@ -0,0 +1,54 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(HashingUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! C code from the refer to +! https://cp-algorithms.com/string/string-hashing.html +! long long compute_hash(string const& s) { +! const int p = 31; +! const int m = 1e9 + 9; +! long long hash_value = 0; +! long long p_pow = 1; +! for (char c : s) { +! hash_value = (hash_value + (c - 'a' + 1) * p_pow) % m; +! p_pow = (p_pow * p) % m; +! } +! return hash_value; +! } + +MODULE PROCEDURE StringToUID_PolyRoll + INTEGER( I4B ), PARAMETER :: p = 53 + INTEGER( I4B ), PARAMETER :: m = 1e6 + 9 + INTEGER( I4B ) :: p_pow, ii + !! + p_pow = 1 + ans = 0 + !! + DO ii = 1, LEN_TRIM( charVar ) + ans = MOD( (ans + (ICHAR(charVar(ii:ii)) - ICHAR('A') + 1) * p_pow ), m ) + p_pow = MOD( (p_pow * p), m ) + END DO +END PROCEDURE StringToUID_PolyRoll + +END SUBMODULE Methods \ No newline at end of file diff --git a/src/submodules/Utility/src/HeadUtility@Methods.F90 b/src/submodules/Utility/src/HeadUtility@Methods.F90 new file mode 100644 index 000000000..488b773f5 --- /dev/null +++ b/src/submodules/Utility/src/HeadUtility@Methods.F90 @@ -0,0 +1,67 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(HeadUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Head +!---------------------------------------------------------------------------- + +MODULE PROCEDURE head_Int8 +ans = x(1) +END PROCEDURE head_Int8 + +MODULE PROCEDURE head_Int16 +ans = x(1) +END PROCEDURE head_Int16 + +MODULE PROCEDURE head_Int32 +ans = x(1) +END PROCEDURE head_Int32 + +MODULE PROCEDURE head_Int64 +ans = x(1) +END PROCEDURE head_Int64 + +!---------------------------------------------------------------------------- +! Head +!---------------------------------------------------------------------------- + +MODULE PROCEDURE head_Real32 +ans = x(1) +END PROCEDURE head_Real32 + +MODULE PROCEDURE head_Real64 +ans = x(1) +END PROCEDURE head_Real64 + +!---------------------------------------------------------------------------- +! Head +!---------------------------------------------------------------------------- + +MODULE PROCEDURE head_char +ans(1:1) = x(1:1) +END PROCEDURE head_char + +!---------------------------------------------------------------------------- +! Tail +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/HeapSort/ArgHeapSort.inc b/src/submodules/Utility/src/HeapSort/ArgHeapSort.inc new file mode 100644 index 000000000..761097bae --- /dev/null +++ b/src/submodules/Utility/src/HeapSort/ArgHeapSort.inc @@ -0,0 +1,76 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with array program. If not, see +! + +INTEGER(I4B) :: start, bottom +INTEGER(I4B) :: N + +N = SIZE(arg) +arg = arange(1_I4B, n, 1_I4B) + +DO start = ((n - 2) / 2), 0, -1 + CALL argSiftdown(arg, start, n); +END DO + +DO bottom = n - 1, 1, -1 + CALL Swap(arg(0), arg(bottom)) + CALL argSiftdown(arg, 0, bottom) +END DO + +CONTAINS + +PURE SUBROUTINE argSiftdown(arg, start, bottom) + INTEGER(I4B), INTENT(INOUT) :: arg(0:) + INTEGER(I4B), INTENT(IN) :: start + INTEGER(I4B), INTENT(IN) :: bottom + ! + INTEGER(I4B) :: i, j + i = start + DO WHILE ((i * 2) + 1 < bottom) + j = (i * 2) + 1 + IF (j + 1 < bottom) THEN + IF (array(arg(j)) < array(arg(j + 1))) j = j + 1 + END IF + IF (array(arg(i)) < array(arg(j))) THEN + CALL Swap(arg(i), arg(j)) + i = j + ELSE + EXIT + END IF + END DO + +END SUBROUTINE + +! subroutine argSiftdown(array, arg, start, bottom) +! real(Real32) :: array(:) +! INTEGER(Int32) :: arg(0:) +! INTEGER(Int32) :: start +! INTEGER(Int32) :: bottom +! INTEGER(Int32) :: i, j +! i = start +! DO WHILE ((i * 2) + 1 < bottom) +! j = (i * 2) + 1 +! IF (j + 1 < bottom) THEN +! IF (array(arg(j)) < array(arg(j + 1))) j = j + 1 +! END IF +! IF (array(arg(i)) < array(arg(j))) THEN +! CALL swap(arg(i), arg(j)) +! i = j +! ELSE +! RETURN +! END IF +! END DO +! END subroutine diff --git a/src/submodules/Utility/src/HeapSort/HeapSort.inc b/src/submodules/Utility/src/HeapSort/HeapSort.inc new file mode 100644 index 000000000..5516423ef --- /dev/null +++ b/src/submodules/Utility/src/HeapSort/HeapSort.inc @@ -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 +! + +INTEGER(I4B) :: n, i, k, j, l + +n = SIZE(array) +IF (n .LE. 1) RETURN +l = n / 2 + 1 +k = n +DO WHILE (k .NE. 1) + IF (l .GT. 1) THEN + l = l - 1 + t = array(L) + ELSE + t = array(k) + array(k) = array(1) + k = k - 1 + IF (k .EQ. 1) THEN + array(1) = t + EXIT + END IF + END IF + i = l + j = l + l + DO WHILE (j .LE. k) + IF (j .LT. k) THEN + IF (array(j) .LT. array(j + 1)) j = j + 1 + END IF + IF (t .LT. array(j)) THEN + array(i) = array(j) + i = j + j = j + j + ELSE + j = k + 1 + END IF + END DO + array(i) = t +END DO diff --git a/src/submodules/Utility/src/In/In_1.inc b/src/submodules/Utility/src/In/In_1.inc new file mode 100644 index 000000000..1bbf7c7cf --- /dev/null +++ b/src/submodules/Utility/src/In/In_1.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + + +INTEGER(I4B) :: ii + +ans = .TRUE. +IF (SIZE(a) .GT. SIZE(b)) THEN + ans = .FALSE. + RETURN +END IF + +DO ii = 1, SIZE(a) + IF (.NOT. ANY(a(ii) .EQ. b)) THEN + ans = .FALSE. + EXIT + END IF +END DO diff --git a/src/submodules/Utility/src/In/IsIn_1.inc b/src/submodules/Utility/src/In/IsIn_1.inc new file mode 100644 index 000000000..125ac6262 --- /dev/null +++ b/src/submodules/Utility/src/In/IsIn_1.inc @@ -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 +! + +!! +INTEGER(I4B) :: ii +!! +DO ii = 1, SIZE(a) + ans( ii ) = ANY(a(ii) .EQ. b) +END DO \ No newline at end of file diff --git a/src/submodules/Utility/src/Input/Input1.inc b/src/submodules/Utility/src/Input/Input1.inc new file mode 100644 index 000000000..233d59e61 --- /dev/null +++ b/src/submodules/Utility/src/Input/Input1.inc @@ -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 +! + +IF(PRESENT(option) )THEN + ans=option +ELSE + ans=default +ENDIF \ No newline at end of file diff --git a/src/submodules/Utility/src/InputUtility@Methods.F90 b/src/submodules/Utility/src/InputUtility@Methods.F90 new file mode 100644 index 000000000..dea94390b --- /dev/null +++ b/src/submodules/Utility/src/InputUtility@Methods.F90 @@ -0,0 +1,150 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: This method contains the input method + +SUBMODULE(InputUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_Int8 +#include "./Input/Input1.inc" +END PROCEDURE input_Int8 +MODULE PROCEDURE input_Int16 +#include "./Input/Input1.inc" +END PROCEDURE input_Int16 +MODULE PROCEDURE input_Int32 +#include "./Input/Input1.inc" +END PROCEDURE input_Int32 +MODULE PROCEDURE input_Int64 +#include "./Input/Input1.inc" +END PROCEDURE input_Int64 + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_Real32 +#include "./Input/Input1.inc" +END PROCEDURE input_Real32 +MODULE PROCEDURE input_Real64 +#include "./Input/Input1.inc" +END PROCEDURE input_Real64 + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_Int8Vec +#include "./Input/Input1.inc" +END PROCEDURE input_Int8Vec +MODULE PROCEDURE input_Int16Vec +#include "./Input/Input1.inc" +END PROCEDURE input_Int16Vec +MODULE PROCEDURE input_Int32Vec +#include "./Input/Input1.inc" +END PROCEDURE input_Int32Vec +MODULE PROCEDURE input_Int64Vec +#include "./Input/Input1.inc" +END PROCEDURE input_Int64Vec + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_Real32vec +#include "./Input/Input1.inc" +END PROCEDURE input_Real32vec +MODULE PROCEDURE input_Real64vec +#include "./Input/Input1.inc" +END PROCEDURE input_Real64vec + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_Int8Array +#include "./Input/Input1.inc" +END PROCEDURE input_Int8Array +MODULE PROCEDURE input_Int16Array +#include "./Input/Input1.inc" +END PROCEDURE input_Int16Array +MODULE PROCEDURE input_Int32Array +#include "./Input/Input1.inc" +END PROCEDURE input_Int32Array +MODULE PROCEDURE input_Int64Array +#include "./Input/Input1.inc" +END PROCEDURE input_Int64Array + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_Real32Array +#include "./Input/Input1.inc" +END PROCEDURE input_Real32Array +MODULE PROCEDURE input_Real64Array +#include "./Input/Input1.inc" +END PROCEDURE input_Real64Array + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_String +#include "./Input/Input1.inc" +END PROCEDURE input_String + +! MODULE PROCEDURE input_StringVec +! #include "./Input/Input1.inc" +! END PROCEDURE input_StringVec + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_logical +#include "./Input/Input1.inc" +END PROCEDURE input_logical + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_logicalvec +#include "./Input/Input1.inc" +END PROCEDURE input_logicalvec + +!---------------------------------------------------------------------------- +! Input +!---------------------------------------------------------------------------- + +MODULE PROCEDURE input_logicalArray +#include "./Input/Input1.inc" +END PROCEDURE input_logicalArray + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc b/src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc new file mode 100644 index 000000000..78ed3fe96 --- /dev/null +++ b/src/submodules/Utility/src/InsertionSort/ArgInsertionSort.inc @@ -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 +! + +INTEGER(I4B) :: ii, jj + +DO ii = low, high + DO jj = ii, low + 1, -1 + IF (array(arg(jj)) < array(arg(jj - 1))) THEN + CALL SWAP(arg(jj), arg(jj - 1)) + ELSE + EXIT + END IF + END DO +END DO diff --git a/src/submodules/Utility/src/InsertionSort/InsertionSort.inc b/src/submodules/Utility/src/InsertionSort/InsertionSort.inc new file mode 100644 index 000000000..76778c5c8 --- /dev/null +++ b/src/submodules/Utility/src/InsertionSort/InsertionSort.inc @@ -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 +! + +INTEGER(I4B) :: ii, jj + +DO ii = low, high + DO jj = ii, low + 1, -1 + IF (array(jj) < array(jj - 1)) THEN + CALL SWAP(array(jj), array(jj - 1)) + ELSE + EXIT + END IF + END DO +END DO diff --git a/src/submodules/Utility/src/IntegerUtility@Methods.F90 b/src/submodules/Utility/src/IntegerUtility@Methods.F90 new file mode 100644 index 000000000..68e4d625c --- /dev/null +++ b/src/submodules/Utility/src/IntegerUtility@Methods.F90 @@ -0,0 +1,386 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(IntegerUtility) Methods +USE AppendUtility, ONLY: OPERATOR(.ROWCONCAT.), & + OPERATOR(.COLCONCAT.), & + Expand +USE SortUtility, ONLY: QuickSort +USE BinomUtility, ONLY: Binom +USE OnesUtility, ONLY: ones + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size1 +ans = INT(Binom(n + d, d, 1.0_DFP), KIND=I4B) +END PROCEDURE obj_Size1 + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size2 +INTEGER(I4B) :: ii +ans = 0_I4B +DO ii = 0, n + ans = ans + SIZE(n=ii, d=d) +END DO +END PROCEDURE obj_Size2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices1 +INTEGER(I4B) :: ii, m +INTEGER(I4B), ALLOCATABLE :: indx(:, :), acol(:), indx2(:, :) + +SELECT CASE (d) +CASE (1_I4B) + + ALLOCATE (ans(2, n + 1)) + DO ii = 0, n + ans(1:2, ii + 1) = [ii, n - ii] + END DO + +CASE DEFAULT + + ALLOCATE (ans(d + 1, 1)) + ans = 0; ans(1, 1) = n + + DO ii = n - 1, 0_I4B, -1_I4B + + indx = GetMultiIndices(n=n - ii, d=d - 1) + m = SIZE(indx, 2) + acol = ii * ones(m, 1_I4B) + indx2 = acol.ROWCONCAT.indx + ans = indx2.COLCONCAT.ans + + END DO + +END SELECT + +IF (ALLOCATED(indx)) DEALLOCATE (indx) +IF (ALLOCATED(acol)) DEALLOCATE (acol) +IF (ALLOCATED(indx2)) DEALLOCATE (indx2) + +END PROCEDURE obj_GetMultiIndices1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices2 +INTEGER(I4B) :: ii, m, r1, r2 + +m = SIZE(n, d, .TRUE.) +ALLOCATE (ans(d + 1, m)) + +r1 = 0; r2 = 0 +DO ii = 0, n + m = SIZE(n=ii, d=d) + r1 = r2 + 1_I4B + r2 = r1 + m - 1 + ans(:, r1:r2) = GetMultiIndices(n=ii, d=d) +END DO + +END PROCEDURE obj_GetMultiIndices2 + +!---------------------------------------------------------------------------- +! IN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE in_1a +#include "./In/In_1.inc" +END PROCEDURE in_1a + +MODULE PROCEDURE in_1b +#include "./In/In_1.inc" +END PROCEDURE in_1b + +MODULE PROCEDURE in_1c +#include "./In/In_1.inc" +END PROCEDURE in_1c + +MODULE PROCEDURE in_1d +#include "./In/In_1.inc" +END PROCEDURE in_1d + +!---------------------------------------------------------------------------- +! isIN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IsIn_1a +#include "./In/IsIn_1.inc" +END PROCEDURE IsIn_1a + +MODULE PROCEDURE IsIn_1b +#include "./In/IsIn_1.inc" +END PROCEDURE IsIn_1b + +MODULE PROCEDURE IsIn_1c +#include "./In/IsIn_1.inc" +END PROCEDURE IsIn_1c + +MODULE PROCEDURE IsIn_1d +#include "./In/IsIn_1.inc" +END PROCEDURE IsIn_1d + +!---------------------------------------------------------------------------- +! IN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE in_2a +ans = ANY(a .EQ. b) +END PROCEDURE in_2a + +MODULE PROCEDURE in_2b +ans = ANY(a .EQ. b) +END PROCEDURE in_2b + +MODULE PROCEDURE in_2c +ans = ANY(a .EQ. b) +END PROCEDURE in_2c + +MODULE PROCEDURE in_2d +ans = ANY(a .EQ. b) +END PROCEDURE in_2d + +!---------------------------------------------------------------------------- +! RemoveDuplicate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RemoveDuplicates_1a +INTEGER(INT8) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_1.inc" +END PROCEDURE RemoveDuplicates_1a + +MODULE PROCEDURE RemoveDuplicates_1b +INTEGER(INT16) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_1.inc" +END PROCEDURE RemoveDuplicates_1b + +MODULE PROCEDURE RemoveDuplicates_1c +INTEGER(INT32) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_1.inc" +END PROCEDURE RemoveDuplicates_1c + +MODULE PROCEDURE RemoveDuplicates_1d +INTEGER(INT64) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_1.inc" +END PROCEDURE RemoveDuplicates_1d + +!---------------------------------------------------------------------------- +! RemoveDuplicate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RemoveDuplicates_1a_ +INTEGER(INT8) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_2.inc" +END PROCEDURE RemoveDuplicates_1a_ + +MODULE PROCEDURE RemoveDuplicates_1b_ +INTEGER(INT16) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_2.inc" +END PROCEDURE RemoveDuplicates_1b_ + +MODULE PROCEDURE RemoveDuplicates_1c_ +INTEGER(INT32) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_2.inc" +END PROCEDURE RemoveDuplicates_1c_ + +MODULE PROCEDURE RemoveDuplicates_1d_ +INTEGER(INT64) :: temp(SIZE(obj)) +#include "./RemoveDuplicates/RemoveDuplicates_2.inc" +END PROCEDURE RemoveDuplicates_1d_ + +!---------------------------------------------------------------------------- +! Repeat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Repeat_1a +#include "./Repeat/Repeat_1.inc" +END PROCEDURE Repeat_1a + +MODULE PROCEDURE Repeat_1b +#include "./Repeat/Repeat_1.inc" +END PROCEDURE Repeat_1b + +MODULE PROCEDURE Repeat_1c +#include "./Repeat/Repeat_1.inc" +END PROCEDURE Repeat_1c + +MODULE PROCEDURE Repeat_1d +#include "./Repeat/Repeat_1.inc" +END PROCEDURE Repeat_1d + +MODULE PROCEDURE Repeat_1e +#include "./Repeat/Repeat_1.inc" +END PROCEDURE Repeat_1e + +MODULE PROCEDURE Repeat_1f +#include "./Repeat/Repeat_1.inc" +END PROCEDURE Repeat_1f + +!---------------------------------------------------------------------------- +! IndexOf +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetIndex1 +Ans = MINLOC(ABS(obj - val), 1) +END PROCEDURE GetIndex1 + +!---------------------------------------------------------------------------- +! IndexOf +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetIndex2 +INTEGER(I4B) :: i, j, m +LOGICAL(LGT), ALLOCATABLE :: Search(:) + +m = SIZE(val) +ALLOCATE (Search(m), Ans(m)) +Search = .TRUE. +Ans = 0 + +DO i = 1, SIZE(obj) + DO j = 1, m + IF (Search(j)) THEN + IF (val(j) .EQ. obj(i)) THEN + Search(j) = .FALSE. + Ans(j) = i + END IF + END IF + END DO +END DO +END PROCEDURE GetIndex2 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Get1_Int8 +ans = 0 +IF (indx .LE. SIZE(val)) ans = val(indx) +END PROCEDURE Get1_Int8 + +MODULE PROCEDURE Get1_Int16 +ans = 0 +IF (indx .LE. SIZE(val)) ans = val(indx) +END PROCEDURE Get1_Int16 + +MODULE PROCEDURE Get1_Int32 +ans = 0 +IF (indx .LE. SIZE(val)) ans = val(indx) +END PROCEDURE Get1_Int32 + +MODULE PROCEDURE Get1_Int64 +ans = 0 +IF (indx .LE. SIZE(val)) ans = val(indx) +END PROCEDURE Get1_Int64 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Get2_Int8 +ans = val(indx) +END PROCEDURE Get2_Int8 + +MODULE PROCEDURE Get2_Int16 +ans = val(indx) +END PROCEDURE Get2_Int16 + +MODULE PROCEDURE Get2_Int32 +ans = val(indx) +END PROCEDURE Get2_Int32 + +MODULE PROCEDURE Get2_Int64 +ans = val(indx) +END PROCEDURE Get2_Int64 + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Get3_Int8 +ans = val(istart:iend:stride) +END PROCEDURE Get3_Int8 + +MODULE PROCEDURE Get3_Int16 +ans = val(istart:iend:stride) +END PROCEDURE Get3_Int16 + +MODULE PROCEDURE Get3_Int32 +ans = val(istart:iend:stride) +END PROCEDURE Get3_Int32 + +MODULE PROCEDURE Get3_Int64 +ans = val(istart:iend:stride) +END PROCEDURE Get3_Int64 + +!---------------------------------------------------------------------------- +! GetIntersection +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetIntersection1 +#include "./Intersection/Intersection.inc" +END PROCEDURE GetIntersection1 + +MODULE PROCEDURE GetIntersection2 +#include "./Intersection/Intersection.inc" +END PROCEDURE GetIntersection2 + +MODULE PROCEDURE GetIntersection3 +#include "./Intersection/Intersection.inc" +END PROCEDURE GetIntersection3 + +MODULE PROCEDURE GetIntersection4 +#include "./Intersection/Intersection.inc" +END PROCEDURE GetIntersection4 + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DFortranIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Get1DIndexFrom2DFortranIndex +ans = (j - 1) * dim1 + i +END PROCEDURE Get1DIndexFrom2DFortranIndex + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DFortranIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Get1DIndexFrom3DFortranIndex +ans = (k - 1) * dim1 * dim2 + (j - 1) * dim1 + i +END PROCEDURE Get1DIndexFrom3DFortranIndex + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DFortranIndex +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Get1DIndexFrom4DFortranIndex +ans = (l - 1) * dim1 * dim2 * dim3 + (k - 1) * dim1 * dim2 & + + (j - 1) * dim1 + i +END PROCEDURE Get1DIndexFrom4DFortranIndex + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Intersection/Intersection.inc b/src/submodules/Utility/src/Intersection/Intersection.inc new file mode 100644 index 000000000..926c381d5 --- /dev/null +++ b/src/submodules/Utility/src/Intersection/Intersection.inc @@ -0,0 +1,22 @@ +INTEGER(I4B) :: tsize1, tsize2, ii + +tsize1 = SIZE(a) +tsize2 = SIZE(b) +tsize = 0 + +IF (tsize1 .LE. tsize2) THEN + DO ii = 1, tsize1 + IF (ANY(a(ii) .EQ. b)) THEN + tsize = tsize + 1 + c(tsize) = a(ii) + END IF + END DO + RETURN +END IF + +DO ii = 1, tsize2 + IF (ANY(b(ii) .EQ. a)) THEN + tsize = tsize + 1 + c(tsize) = b(ii) + END IF +END DO diff --git a/src/submodules/Utility/src/IntroSort/ArgIntroSort.inc b/src/submodules/Utility/src/IntroSort/ArgIntroSort.inc new file mode 100644 index 000000000..63b7886bf --- /dev/null +++ b/src/submodules/Utility/src/IntroSort/ArgIntroSort.inc @@ -0,0 +1,16 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! diff --git a/src/submodules/Utility/src/IntroSort/IntroSort.inc b/src/submodules/Utility/src/IntroSort/IntroSort.inc new file mode 100644 index 000000000..63b7886bf --- /dev/null +++ b/src/submodules/Utility/src/IntroSort/IntroSort.inc @@ -0,0 +1,16 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! diff --git a/src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc b/src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc new file mode 100644 index 000000000..980800478 --- /dev/null +++ b/src/submodules/Utility/src/IntroSort/Recursive_ArgIntroSort.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +N = right - left + 1 +IF (N < minimumLengthForInsertion) THEN + CALL argInsertionSort(this, idx, left, right) + RETURN +END IF +IF (maxDepth == 0) THEN + CALL argHeapsort(this, idx(left:right)) + RETURN +END IF +imid = left + N / 2 +CALL argMedian(this, idx, left, imid, right) +CALL argPartition(this, idx, left, right, iPivot) +CALL _Recursive_ArgIntroSort_(this, idx, left, iPivot - 1, maxDepth - 1) +CALL _Recursive_ArgIntroSort_(this, idx, iPivot + 1, right, maxDepth - 1) diff --git a/src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc b/src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc new file mode 100644 index 000000000..d2ab39821 --- /dev/null +++ b/src/submodules/Utility/src/IntroSort/Recursive_IntroSort.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +N = right - left + 1 +IF (N < minimumLengthForInsertion) THEN + CALL InsertionSort(this, left, right) + RETURN +END IF +IF (maxDepth .EQ. 0) THEN + CALL Heapsort(this(left:right)) + RETURN +END IF +imid = left + N / 2 +CALL Median(this, left, imid, right) +CALL swap(this(left), this(imid)) +CALL partition(this, left, right, iPivot) +CALL _Recursive_IntroSort_(this, left, iPivot - 1, maxDepth - 1) +CALL _Recursive_IntroSort_(this, iPivot + 1, right, maxDepth - 1) diff --git a/src/submodules/Utility/src/InvUtility@Methods.F90 b/src/submodules/Utility/src/InvUtility@Methods.F90 new file mode 100644 index 000000000..6a89a8ccc --- /dev/null +++ b/src/submodules/Utility/src/InvUtility@Methods.F90 @@ -0,0 +1,225 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Methods for determining determinent and inverse of small matrix + +SUBMODULE(InvUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS +!---------------------------------------------------------------------------- +! DET +!---------------------------------------------------------------------------- + +MODULE PROCEDURE det_2D +SELECT CASE (SIZE(A, 1)) +CASE (1) + Ans = A(1, 1) +CASE (2) + Ans = A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1) +CASE (3) + Ans = A(1, 1) * (A(2, 2) * A(3, 3) - A(2, 3) * A(3, 2)) & + & - A(1, 2) * (A(2, 1) * A(3, 3) - A(2, 3) * A(3, 1)) & + & + A(1, 3) * (A(2, 1) * A(3, 2) - A(3, 1) * A(2, 2)) +CASE (4) + Ans = A(1, 1) * (A(2, 2) * (A(3, 3) * A(4, 4) - A(3, 4) * A(4, 3))& + & + A(2, 3) * (A(3, 4) * A(4, 2) - A(3, 2) * A(4, 4)) & + & + A(2, 4) * (A(3, 2) * A(4, 3) & + & - A(3, 3) * A(4, 2))) - A(1, 2) * (A(2, 1) * (A(3, 3) * A(4, 4) & +& - A(3, 4) * A(4, 3)) + A(2, 3) * (A(3, 4) * A(4, 1) - A(3, 1) * A(4, 4)) & + & + A(2, 4) * (A(3, 1) * A(4, 3) - A(3, 3) * A(4, 1))) & + & + A(1, 3) * (A(2, 1) * (A(3, 2) * A(4, 4) - A(3, 4) * A(4, 2)) & + & + A(2, 2) * (A(3, 4) * A(4, 1) & +& - A(3, 1) * A(4, 4)) + A(2, 4) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1))) & + & - A(1, 4) * (A(2, 1) * (A(3, 2) * A(4, 3) - A(3, 3) * A(4, 2)) & + & + A(2, 2) * (A(3, 3) * A(4, 1) - A(3, 1) * A(4, 3)) & + & + A(2, 3) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1))) +CASE (5) + Ans = det_2d_5(a) +END SELECT +END PROCEDURE det_2D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION det_2d_5(a) RESULT(ans) + REAL(DFP), INTENT(IN) :: a(5, 5) + REAL(DFP) :: ans + !! + REAL(DFP) :: b(4, 4) + INTEGER(I4B) :: i + INTEGER(I4B) :: inc + INTEGER(I4B) :: j + INTEGER(I4B) :: k + ! + ! Expand the determinant into the sum of the determinants of the + ! five 4 by 4 matrices created by dropping row 1, and column k. + ! + ans = 0.0D+00 + ! + DO k = 1, 5 + DO i = 1, 4 + DO j = 1, 4 + IF (j < k) THEN + inc = 0 + ELSE + inc = 1 + END IF + b(i, j) = a(i + 1, j + inc) + END DO + END DO + !! + ans = ans + (-1)**(k + 1) * a(1, k) * det_2D(b) + !! + END DO +END FUNCTION det_2d_5 + +!---------------------------------------------------------------------------- +! DET +!---------------------------------------------------------------------------- + +MODULE PROCEDURE det_3D +INTEGER(I4B) :: i, n +n = SIZE(A, 3) +ALLOCATE (Ans(n)) +DO i = 1, n + Ans(i) = Det(A(:, :, i)) +END DO +END PROCEDURE det_3D + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Inv_2D +!Define internal variables +REAL(DFP) :: d, co(4, 4) + +SELECT CASE (SIZE(A, 1)) +CASE (1) + d = det(A) + IF (ABS(d) .LT. ZERO) THEN + invA = 0.0_DFP + ELSE + invA = 1.0 / d + END IF + +CASE (2) + d = det(A) + IF (ABS(d) .LT. ZERO) THEN + invA = 0.0_DFP + ELSE + invA(1, 1) = A(2, 2) / d + invA(1, 2) = -A(1, 2) / d + invA(2, 1) = -A(2, 1) / d + invA(2, 2) = A(1, 1) / d + END IF +CASE (3) + d = det(A) + IF (ABS(d) .LT. ZERO) THEN + invA = 0.0_DFP + ELSE + co(1, 1) = (A(2, 2) * A(3, 3) - A(2, 3) * A(3, 2)) + co(1, 2) = -(A(2, 1) * A(3, 3) - A(2, 3) * A(3, 1)) + co(1, 3) = +(A(2, 1) * A(3, 2) - A(2, 2) * A(3, 1)) + co(2, 1) = -(A(1, 2) * A(3, 3) - A(1, 3) * A(3, 2)) + co(2, 2) = +(A(1, 1) * A(3, 3) - A(1, 3) * A(3, 1)) + co(2, 3) = -(A(1, 1) * A(3, 2) - A(1, 2) * A(3, 1)) + co(3, 1) = +(A(1, 2) * A(2, 3) - A(1, 3) * A(2, 2)) + co(3, 2) = -(A(1, 1) * A(2, 3) - A(1, 3) * A(2, 1)) + co(3, 3) = +(A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1)) + invA = TRANSPOSE(co(1:3, 1:3)) / d + END IF + +CASE (4) + + d = det(A) + IF (ABS(d) .LT. ZERO) THEN + invA = 0.0_DFP + ELSE + co(1, 1) = A(2, 2) * (A(3, 3) * A(4, 4) - A(3, 4) * A(4, 3)) + & + A(2, 3) * (A(3, 4) * A(4, 2) - A(3, 2) * A(4, 4)) + & + A(2, 4) * (A(3, 2) * A(4, 3) - A(3, 3) * A(4, 2)) + co(1, 2) = A(2, 1) * (A(3, 4) * A(4, 3) - A(3, 3) * A(4, 4)) + & + A(2, 3) * (A(3, 1) * A(4, 4) - A(3, 4) * A(4, 1)) + & + A(2, 4) * (A(3, 3) * A(4, 1) - A(3, 1) * A(4, 3)) + co(1, 3) = A(2, 1) * (A(3, 2) * A(4, 4) - A(3, 4) * A(4, 2)) + & + A(2, 2) * (A(3, 4) * A(4, 1) - A(3, 1) * A(4, 4)) + & + A(2, 4) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1)) + co(1, 4) = A(2, 1) * (A(3, 3) * A(4, 2) - A(3, 2) * A(4, 3)) + & + A(2, 2) * (A(3, 1) * A(4, 3) - A(3, 3) * A(4, 1)) + & + A(2, 3) * (A(3, 2) * A(4, 1) - A(3, 1) * A(4, 2)) + co(2, 1) = A(1, 2) * (A(3, 4) * A(4, 3) - A(3, 3) * A(4, 4)) + & + A(1, 3) * (A(3, 2) * A(4, 4) - A(3, 4) * A(4, 2)) + & + A(1, 4) * (A(3, 3) * A(4, 2) - A(3, 2) * A(4, 3)) + co(2, 2) = A(1, 1) * (A(3, 3) * A(4, 4) - A(3, 4) * A(4, 3)) + & + A(1, 3) * (A(3, 4) * A(4, 1) - A(3, 1) * A(4, 4)) + & + A(1, 4) * (A(3, 1) * A(4, 3) - A(3, 3) * A(4, 1)) + co(2, 3) = A(1, 1) * (A(3, 4) * A(4, 2) - A(3, 2) * A(4, 4)) + & + A(1, 2) * (A(3, 1) * A(4, 4) - A(3, 4) * A(4, 1)) + & + A(1, 4) * (A(3, 2) * A(4, 1) - A(3, 1) * A(4, 2)) + co(2, 4) = A(1, 1) * (A(3, 2) * A(4, 3) - A(3, 3) * A(4, 2)) + & + A(1, 2) * (A(3, 3) * A(4, 1) - A(3, 1) * A(4, 3)) + & + A(1, 3) * (A(3, 1) * A(4, 2) - A(3, 2) * A(4, 1)) + co(3, 1) = A(1, 2) * (A(2, 3) * A(4, 4) - A(2, 4) * A(4, 3)) + & + A(1, 3) * (A(2, 4) * A(4, 2) - A(2, 2) * A(4, 4)) + & + A(1, 4) * (A(2, 2) * A(4, 3) - A(2, 3) * A(4, 2)) + co(3, 2) = A(1, 1) * (A(2, 4) * A(4, 3) - A(2, 3) * A(4, 4)) + & + A(1, 3) * (A(2, 1) * A(4, 4) - A(2, 4) * A(4, 1)) + & + A(1, 4) * (A(2, 3) * A(4, 1) - A(2, 1) * A(4, 3)) + co(3, 3) = A(1, 1) * (A(2, 2) * A(4, 4) - A(2, 4) * A(4, 2)) + & + A(1, 2) * (A(2, 4) * A(4, 1) - A(2, 1) * A(4, 4)) + & + A(1, 4) * (A(2, 1) * A(4, 2) - A(2, 2) * A(4, 1)) + co(3, 4) = A(1, 1) * (A(2, 3) * A(4, 2) - A(2, 2) * A(4, 3)) + & + A(1, 2) * (A(2, 1) * A(4, 3) - A(2, 3) * A(4, 1)) + & + A(1, 3) * (A(2, 2) * A(4, 1) - A(2, 1) * A(4, 2)) + co(4, 1) = A(1, 2) * (A(2, 4) * A(3, 3) - A(2, 3) * A(3, 4)) + & + A(1, 3) * (A(2, 2) * A(3, 4) - A(2, 4) * A(3, 2)) + & + A(1, 4) * (A(2, 3) * A(3, 2) - A(2, 2) * A(3, 3)) + co(4, 2) = A(1, 1) * (A(2, 3) * A(3, 4) - A(2, 4) * A(3, 3)) + & + A(1, 3) * (A(2, 4) * A(3, 1) - A(2, 1) * A(3, 4)) + & + A(1, 4) * (A(2, 1) * A(3, 3) - A(2, 3) * A(3, 1)) + co(4, 3) = A(1, 1) * (A(2, 4) * A(3, 2) - A(2, 2) * A(3, 4)) + & + A(1, 2) * (A(2, 1) * A(3, 4) - A(2, 4) * A(3, 1)) + & + A(1, 4) * (A(2, 2) * A(3, 1) - A(2, 1) * A(3, 2)) + co(4, 4) = A(1, 1) * (A(2, 2) * A(3, 3) - A(2, 3) * A(3, 2)) + & + A(1, 2) * (A(2, 3) * A(3, 1) - A(2, 1) * A(3, 3)) + & + A(1, 3) * (A(2, 1) * A(3, 2) - A(2, 2) * A(3, 1)) + invA = TRANSPOSE(co) / d + END IF + +END SELECT + +END PROCEDURE Inv_2D + +!---------------------------------------------------------------------------- +! Inv +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Inv_3D +! define internal variables +INTEGER(I4B) :: i, n +n = SIZE(A, 3) +DO i = 1, n + CALL Inv(invA=invA(:, :, i), A=A(:, :, i)) +END DO +END PROCEDURE Inv_3D + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 b/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 new file mode 100644 index 000000000..8d9d1e4ee --- /dev/null +++ b/src/submodules/Utility/src/LinearAlgebraUtility@Methods.F90 @@ -0,0 +1,65 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(LinearAlgebraUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! IntHilbertMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InvHilbertMatrix +REAL(DFP) :: p +REAL(DFP) :: r +INTEGER(I4B) :: i +INTEGER(I4B) :: j +INTEGER(I4B) :: ip1 + +p = REAL(n, kind=DFP) + +DO i = 1, n +IF (i .NE. 1) p = (REAL(n - i + 1, DFP) * p * REAL(n + i - 1, DFP)) / REAL(i - 1, DFP)**2 + r = p * p + ans(i, i) = r / REAL(2 * i - 1, DFP) + IF (i .EQ. n) CYCLE + ip1 = i + 1 + DO j = ip1, n + r = (-1) * (REAL(n - j + 1, DFP) * r * (n + j - 1)) / REAL(j - 1, DFP)**2 + ans(i, j) = r / REAL(i + j - 1, DFP) + ans(j, i) = ans(i, j) + END DO +END DO +END PROCEDURE InvHilbertMatrix + +!---------------------------------------------------------------------------- +! HilbertMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HilbertMatrix +INTEGER(I4B) :: ii, jj +REAL(DFP) :: avar + +DO jj = 1, n + DO ii = 1, n + avar = REAL(ii + jj - 1, KIND=DFP) + ans(ii, jj) = 1.0_DFP / avar + END DO +END DO +END PROCEDURE HilbertMatrix + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 new file mode 100644 index 000000000..c5dbf2273 --- /dev/null +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -0,0 +1,826 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(MappingUtility) Methods +USE BaseMethod, ONLY: UpperCase, & + & SOFTLE, & + & RefCoord_Tetrahedron, & + & RefCoord_Hexahedron, & + & TriangleArea2D, & + & TriangleArea3D, & + & QuadrangleArea2D, & + & QuadrangleArea3D, & + & TetrahedronVolume3D, & + & HexahedronVolume3D +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiunitLine2Segment1 +ans = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin +END PROCEDURE FromBiunitLine2Segment1 + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiunitLine2Segment2 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(xin) + ans(:, ii) = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin(ii) +END DO +END PROCEDURE FromBiunitLine2Segment2 + +!---------------------------------------------------------------------------- +! FromBiUnitLine2UnitLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitLine2UnitLine +ans = 0.5_DFP * (1.0_DFP + xin) +END PROCEDURE FromBiUnitLine2UnitLine + +!---------------------------------------------------------------------------- +! FromUnitLine2BiUnitLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitLine2BiUnitLine +ans = 2.0_DFP * xin - 1.0_DFP +END PROCEDURE FromUnitLine2BiUnitLine + +!---------------------------------------------------------------------------- +! FromLine2Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromLine2Line_ +CHARACTER(2) :: acase +INTEGER(I4B) :: ii, n + +acase = from(1:1)//to(1:1) +n = SIZE(xin) + +SELECT CASE (acase) + +CASE ("BU", "bu", "bU", "Bu") + + DO CONCURRENT(ii=1:n) + ans(ii) = 0.5_DFP * (1.0_DFP + xin(ii)) + END DO + +CASE ("BB", "UU", "bb", "uu") + + DO CONCURRENT(ii=1:n) + ans(ii) = xin(ii) + END DO + +CASE ("UB", "ub", "uB", "Ub") + + DO CONCURRENT(ii=1:n) + ans(ii) = 2.0_DFP * xin(ii) - 1.0_DFP + END DO + +END SELECT +END PROCEDURE FromLine2Line_ + +!---------------------------------------------------------------------------- +! FromUnitTriangle2Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTriangle2Triangle1 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(ans, 2) + ans(:, ii) = x1 + (x2 - x1) * xin(1, ii) + (x3 - x1) * xin(2, ii) +END DO +END PROCEDURE FromUnitTriangle2Triangle1 + +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2UnitQuadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1 +ans = FromBiUnitQuadrangle2Quadrangle(& + & xin=xin, & + & x1=[0.0_DFP, 0.0_DFP], & + & x2=[1.0_DFP, 0.0_DFP], & + & x3=[1.0_DFP, 1.0_DFP], & + & x4=[0.0_DFP, 1.0_DFP]) +END PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1 + +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2UnitQuadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitQuadrangle2BiUnitQuadrangle1 +INTEGER(I4B) :: ii +REAL(DFP) :: xi, eta, p1, p2, p3, p4 + +DO ii = 1, SIZE(ans, 2) + xi = xin(1, ii) + eta = xin(2, ii) + p1 = (1.0 - xi) * (1.0 - eta) + p2 = xi * (1.0 - eta) + p3 = xi * eta + p4 = (1.0 - xi) * eta + ans(1:2, ii) = & + & [-1.0_DFP, -1.0_DFP] * p1 & + & + [1.0_DFP, -1.0_DFP] * p2 & + & + [1.0_DFP, 1.0_DFP] * p3 & + & + [-1.0_DFP, 1.0_DFP] * p4 +END DO +END PROCEDURE FromUnitQuadrangle2BiUnitQuadrangle1 + +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitQuadrangle2Quadrangle1 +INTEGER(I4B) :: ii +REAL(DFP) :: xi, eta, p1, p2, p3, p4 +!! +DO ii = 1, SIZE(ans, 2) + xi = xin(1, ii) + eta = xin(2, ii) + p1 = 0.25 * (1.0 - xi) * (1.0 - eta) + p2 = 0.25 * (1.0 + xi) * (1.0 - eta) + p3 = 0.25 * (1.0 + xi) * (1.0 + eta) + p4 = 0.25 * (1.0 - xi) * (1.0 + eta) + ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 +END DO +END PROCEDURE FromBiUnitQuadrangle2Quadrangle1 + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitHexahedron2Hexahedron1 +INTEGER(I4B) :: ii +REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta +REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP + +DO ii = 1, SIZE(ans, 2) + xi = xin(1, ii) + eta = xin(2, ii) + zeta = xin(3, ii) + p1 = p125 * (one - xi) * (one - eta) * (one - zeta) + p2 = p125 * (one + xi) * (one - eta) * (one - zeta) + p3 = p125 * (one + xi) * (one + eta) * (one - zeta) + p4 = p125 * (one - xi) * (one + eta) * (one - zeta) + p5 = p125 * (one - xi) * (one - eta) * (one + zeta) + p6 = p125 * (one + xi) * (one - eta) * (one + zeta) + p7 = p125 * (one + xi) * (one + eta) * (one + zeta) + p8 = p125 * (one - xi) * (one + eta) * (one + zeta) + ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 + & + & x5 * p5 + x6 * p6 + x7 * p7 + x8 * p8 +END DO +END PROCEDURE FromBiUnitHexahedron2Hexahedron1 + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2UnitHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitHexahedron2UnitHexahedron1 +REAL(DFP) :: xij(3, 8) +xij = RefCoord_Hexahedron(refHexahedron="UNIT") +ans = FromBiUnitHexahedron2Hexahedron(& + & xin=xin, & + & x1=xij(:, 1), & + & x2=xij(:, 2), & + & x3=xij(:, 3), & + & x4=xij(:, 4), & + & x5=xij(:, 5), & + & x6=xij(:, 6), & + & x7=xij(:, 7), & + & x8=xij(:, 8)) +END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1 + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitHexahedron2BiUnitHexahedron1 +INTEGER(I4B) :: ii +REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta +REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP +REAL(DFP) :: x(3, 8) + +x = RefCoord_Hexahedron(refHexahedron="BIUNIT") + +DO ii = 1, SIZE(ans, 2) + xi = xin(1, ii) + eta = xin(2, ii) + zeta = xin(3, ii) + p1 = (one - xi) * (one - eta) * (one - zeta) + p2 = (xi) * (one - eta) * (one - zeta) + p3 = (xi) * (eta) * (one - zeta) + p4 = (one - xi) * (eta) * (one - zeta) + p5 = (one - xi) * (one - eta) * (zeta) + p6 = (xi) * (one - eta) * (zeta) + p7 = (xi) * (eta) * (zeta) + p8 = (one - xi) * (eta) * (zeta) + ans(:, ii) = x(:, 1) * p1 + x(:, 2) * p2 + x(:, 3) * p3 + x(:, 4) * p4 + & + & x(:, 5) * p5 + x(:, 6) * p6 + x(:, 7) * p7 + x(:, 8) * p8 +END DO +END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1 + +!---------------------------------------------------------------------------- +! FromTriangle2Square_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromTriangle2Square_ +CHARACTER(2) :: acase +acase = from(1:1)//to(1:1) + +SELECT CASE (acase) + +CASE ("BB", "bb") + + ans(1, :) = (1.0_DFP + zero + 2.0_DFP * xin(1, :) + xin(2, :)) & + / (1.0_DFP + zero - xin(2, :)) + ans(2, :) = xin(2, :) + +CASE ("UB", "ub") + + ans(1, :) = (2.0_DFP * xin(1, :) + xin(2, :) - 1.0_DFP + zero) & + / (1.0_DFP + zero - xin(2, :)) + ans(2, :) = 2.0_DFP * xin(2, :) - 1.0_DFP + +END SELECT +END PROCEDURE FromTriangle2Square_ + +!---------------------------------------------------------------------------- +! FromBiUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitTriangle2BiUnitSqr +CALL FromTriangle2Square_(xin=xin, ans=ans, from="B", to="B") +END PROCEDURE FromBiUnitTriangle2BiUnitSqr + +!---------------------------------------------------------------------------- +! FromUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTriangle2BiUnitSqr +CALL FromTriangle2Square_(xin=xin, ans=ans, from="U", to="B") +END PROCEDURE FromUnitTriangle2BiUnitSqr + +!---------------------------------------------------------------------------- +! FromSquare2Triangle_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromSquare2Triangle_ +CHARACTER(2) :: acase +acase = from(1:1)//to(1:1) + +SELECT CASE (acase) + +CASE ("BB", "bb", "Bb", "bB") + + ans(1, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) & + - 1.0_DFP + ans(2, :) = xin(2, :) + +CASE ("BU", "bu", "Bu", "bU") + + ans(1, :) = 0.25_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) + ans(2, :) = 0.5_DFP * (xin(2, :) + 1.0_DFP) + +END SELECT +END PROCEDURE FromSquare2Triangle_ + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2BiUnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitSqr2BiUnitTriangle +CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="B") +END PROCEDURE FromBiUnitSqr2BiUnitTriangle + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2UnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitSqr2UnitTriangle +CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="U") +END PROCEDURE FromBiUnitSqr2UnitTriangle + +!---------------------------------------------------------------------------- +! BarycentricCoordUnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordUnitTriangle +CALL BaryCentricCoordTriangle_(xin, "U", ans) +END PROCEDURE BarycentricCoordUnitTriangle + +!---------------------------------------------------------------------------- +! BarycentricCoordBiUnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordBiUnitTriangle +CALL BaryCentricCoordTriangle_(xin, "B", ans) +END PROCEDURE BarycentricCoordBiUnitTriangle + +!---------------------------------------------------------------------------- +! BarycentricCoordTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordTriangle +CALL BaryCentricCoordTriangle_(xin, refTriangle, ans) +END PROCEDURE BarycentricCoordTriangle + +!---------------------------------------------------------------------------- +! BarycentricCoordTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordTriangle_ +SELECT CASE (refTriangle(1:1)) +CASE ("B", "b") + ans(1, :) = -0.5_DFP * (xin(1, :) + xin(2, :)) + ans(2, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) + ans(3, :) = 0.5_DFP * (1.0_DFP + xin(2, :)) + +CASE ("U", "u") + ans(1, :) = 1.0_DFP - xin(1, :) - xin(2, :) + ans(2, :) = xin(1, :) + ans(3, :) = xin(2, :) +END SELECT +END PROCEDURE BarycentricCoordTriangle_ + +!---------------------------------------------------------------------------- +! FromTriangle2Triangle_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromTriangle2Triangle_ +CHARACTER(2) :: acase +INTEGER(I4B) :: ii, n + +acase = from(1:1)//to(1:1) + +SELECT CASE (acase) + +CASE ("BU", "bu", "bU", "Bu") + + ans = 0.5_DFP * (1.0_DFP + xin) + +CASE ("UB", "ub", "Ub", "uB") + + ans = -1.0_DFP + 2.0_DFP * xin + +CASE ("UT", "ut", "Ut", "uT") + + n = SIZE(xin, 2) + DO CONCURRENT(ii=1:n) + ans(:, ii) = x1 + (x2 - x1) * xin(1, ii) + (x3 - x1) * xin(2, ii) + END DO + +END SELECT +END PROCEDURE FromTriangle2Triangle_ + +!---------------------------------------------------------------------------- +! FromBiUnitTriangle2UnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitTriangle2UnitTriangle +CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="B", to="U") +END PROCEDURE FromBiUnitTriangle2UnitTriangle + +!---------------------------------------------------------------------------- +! FromBiUnitTriangle2UnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTriangle2BiUnitTriangle +CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="U", to="B") +END PROCEDURE FromUnitTriangle2BiUnitTriangle + +!---------------------------------------------------------------------------- +! FromBiUnitTetrahedron2UnitTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron +ans = 0.5_DFP * (1.0_DFP + xin) +END PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron + +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2BiUnitTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron +ans = -1.0_DFP + 2.0_DFP * xin +END PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron + +!---------------------------------------------------------------------------- +! FromBiUnitTetrahedron2Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitTetrahedron2Tetrahedron +INTEGER(I4B) :: ii +DO ii = 1, SIZE(xin, 2) + ans(:, ii) = & + -0.5_DFP * (1.0_DFP + xin(1, ii) + xin(2, ii) + xin(3, ii)) * x1(:) & + + 0.5_DFP * (1.0_DFP + xin(1, ii)) * x2(:) & + + 0.5_DFP * (1.0_DFP + xin(2, ii)) * x3(:) & + + 0.5_DFP * (1.0_DFP + xin(3, ii)) * x4(:) +END DO +END PROCEDURE FromBiUnitTetrahedron2Tetrahedron + +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTetrahedron2Tetrahedron +INTEGER(I4B) :: ii +DO ii = 1, SIZE(xin, 2) + ans(:, ii) = & + (1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii)) * x1(:) & + + xin(1, ii) * x2(:) & + + xin(2, ii) * x3(:) & + + xin(3, ii) * x4(:) +END DO +END PROCEDURE FromUnitTetrahedron2Tetrahedron + +!---------------------------------------------------------------------------- +! BarycentricCoordUnitTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordUnitTetrahedron +ans(1, :) = 1.0_DFP - xin(1, :) - xin(2, :) - xin(3, :) +ans(2, :) = xin(1, :) +ans(3, :) = xin(2, :) +ans(4, :) = xin(3, :) +END PROCEDURE BarycentricCoordUnitTetrahedron + +!---------------------------------------------------------------------------- +! BarycentricCoordBiUnitTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordBiUnitTetrahedron +ans(1, :) = -0.5_DFP * (1.0_DFP + xin(1, :) + xin(2, :) + xin(3, :)) +ans(2, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) +ans(3, :) = 0.5_DFP * (1.0_DFP + xin(2, :)) +ans(4, :) = 0.5_DFP * (1.0_DFP + xin(3, :)) +END PROCEDURE BarycentricCoordBiUnitTetrahedron + +!---------------------------------------------------------------------------- +! BarycentricCoordTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordTetrahedron +SELECT CASE (refTetrahedron(1:1)) +CASE ("B", "b") + ans = BarycentricCoordBiUnitTetrahedron(xin) +CASE ("U", "u") + ans = BarycentricCoordUnitTetrahedron(xin) +END SELECT +END PROCEDURE BarycentricCoordTetrahedron + +!---------------------------------------------------------------------------- +! FromBiUnitTetrahedron2BiUnitHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitTetrahedron2BiUnitHexahedron +INTEGER(I4B) :: ii +REAL(DFP) :: tol, alpha, beta + +tol = 1.0E-12 + +DO ii = 1, SIZE(xin, 2) + alpha = xin(2, ii) + xin(3, ii) + beta = 1.0_DFP - xin(3, ii) + + IF (SOFTLE(ABS(alpha), zero, tol)) THEN + ans(1, ii) = -1.0_DFP + ELSE + ans(1, ii) = -(2.0_DFP + 2.0_DFP * xin(1, ii) + alpha) / alpha + END IF + + IF (SOFTLE(ABS(beta), zero, tol)) THEN + ans(2, ii) = -1.0_DFP + ELSE + ans(2, ii) = (1.0_DFP + 2.0_DFP * xin(2, ii) + xin(3, ii)) / beta + END IF + + ans(3, ii) = xin(3, ii) +END DO + +END PROCEDURE FromBiUnitTetrahedron2BiUnitHexahedron + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2BiUnitTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron +ans(1, :) = 0.25_DFP & + & * (1.0_DFP + xin(1, :)) & + & * (1.0_DFP - xin(2, :)) & + & * (1.0_DFP - xin(3, :)) - 1.0_DFP + +ans(2, :) = 0.5_DFP & + & * (1.0_DFP + xin(2, :)) & + & * (1.0_DFP - xin(3, :)) - 1.0_DFP + +ans(3, :) = xin(3, :) +END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron + +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2BiUnitHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTetrahedron2BiUnitHexahedron +ans = FromBiUnitTetrahedron2BiUnitHexahedron(& + & FromUnitTetrahedron2BiUnitTetrahedron(xin)) +END PROCEDURE FromUnitTetrahedron2BiUnitHexahedron + +!---------------------------------------------------------------------------- +! FromBiUnitHexahedron2UnitTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitHexahedron2UnitTetrahedron +ans = FromBiUnitTetrahedron2UnitTetrahedron( & + & FromBiUnitHexahedron2BiUnitTetrahedron(xin)) +END PROCEDURE FromBiUnitHexahedron2UnitTetrahedron + +!---------------------------------------------------------------------------- +! JacobianLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobianLine +SELECT CASE (TRIM(from)) +CASE ("BIUNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 1.0_DFP + CASE ("UNIT") + ans = 0.5_DFP + CASE ("LINE") + ans = NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP + END SELECT +CASE ("UNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 2.0_DFP + CASE ("UNIT") + ans = 1.0_DFP + CASE ("LINE") + ans = NORM2(xij(:, 2) - xij(:, 1)) + END SELECT +CASE ("LINE") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 2.0_DFP / NORM2(xij(:, 2) - xij(:, 1)) + CASE ("UNIT") + ans = 1.0_DFP / NORM2(xij(:, 2) - xij(:, 1)) + CASE ("LINE") + ans = 1.0_DFP + END SELECT +END SELECT +END PROCEDURE JacobianLine + +!---------------------------------------------------------------------------- +! JacobianTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobianTriangle +ans = 1.0_DFP +SELECT CASE (TRIM(from)) +CASE ("BIUNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 1.0_DFP + CASE ("UNIT") + ans = 0.25_DFP + CASE ("TRIANGLE") + IF (PRESENT(xij)) THEN + + IF (SIZE(xij, 1) .EQ. 2_I4B) THEN + CALL TriangleArea2D(xij(1:2, 1:3), ans) + ELSE + CALL TriangleArea3D(xij(1:3, 1:3), ans) + END IF + + ans = ans / 2.0_DFP + + END IF + END SELECT +CASE ("UNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 4.0_DFP + CASE ("UNIT") + ans = 1.0_DFP + + CASE ("TRIANGLE") + IF (PRESENT(xij)) THEN + IF (SIZE(xij, 1) .EQ. 2_I4B) THEN + CALL TriangleArea2D(xij(1:2, 1:3), ans) + ELSE + CALL TriangleArea3D(xij(1:3, 1:3), ans) + END IF + ans = ans / 0.5_DFP + END IF + END SELECT + +CASE ("TRIANGLE") + + IF (PRESENT(xij)) THEN + IF (SIZE(xij, 1) .EQ. 2_I4B) THEN + CALL TriangleArea2D(xij(1:2, 1:3), ans) + ELSE IF (SIZE(xij, 1) .EQ. 3_I4B) THEN + CALL TriangleArea3D(xij(1:3, 1:3), ans) + END IF + ELSE + RETURN + END IF + + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 2.0_DFP / ans + CASE ("UNIT") + ans = 0.5_DFP / ans + END SELECT + +END SELECT +END PROCEDURE JacobianTriangle + +!---------------------------------------------------------------------------- +! JacobianQuadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobianQuadrangle +ans = 1.0_DFP +SELECT CASE (TRIM(from)) +CASE ("BIUNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 1.0_DFP + CASE ("UNIT") + ans = 0.25_DFP + + CASE ("QUADRANGLE") + IF (PRESENT(xij)) THEN + IF (SIZE(xij, 1) .EQ. 2_I4B) THEN + CALL QuadrangleArea2D(xij(1:2, 1:4), ans) + ELSE + CALL QuadrangleArea3D(xij(1:3, 1:4), ans) + END IF + ans = ans / 4.0_DFP + END IF + END SELECT + +CASE ("UNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 4.0_DFP + CASE ("UNIT") + ans = 1.0_DFP + + CASE ("QUADRANGLE") + IF (PRESENT(xij)) THEN + IF (SIZE(xij, 1) .EQ. 2_I4B) THEN + CALL QuadrangleArea2D(xij(1:2, 1:4), ans) + ELSE + CALL QuadrangleArea3D(xij(1:3, 1:4), ans) + END IF + END IF + END SELECT + +CASE ("QUADRANGLE") + + IF (PRESENT(xij)) THEN + IF (SIZE(xij, 1) .EQ. 2_I4B) THEN + CALL QuadrangleArea2D(xij(1:2, 1:4), ans) + ELSE + CALL QuadrangleArea3D(xij(1:3, 1:4), ans) + END IF + ELSE + RETURN + END IF + + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 4.0_DFP / ans + CASE ("UNIT") + ans = 1.0_DFP / ans + END SELECT + +END SELECT +END PROCEDURE JacobianQuadrangle + +!---------------------------------------------------------------------------- +! JacobianHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobianHexahedron +REAL(DFP) :: ans0 +ans = 1.0_DFP +SELECT CASE (TRIM(from)) +CASE ("BIUNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 1.0_DFP + CASE ("UNIT") + ans = 0.125_DFP + CASE ("HEXAHEDRON") + IF (PRESENT(xij)) THEN + CALL HexahedronVolume3D(xij(1:3, 1:8), ans) + CALL HexahedronVolume3D(RefCoord_Hexahedron(from), ans0) + ans = ans / ans0 + END IF + END SELECT + +CASE ("UNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 8.0_DFP + CASE ("UNIT") + ans = 1.0_DFP + CASE ("HEXAHEDRON") + IF (PRESENT(xij)) THEN + CALL HexahedronVolume3D(xij(1:3, 1:8), ans) + CALL HexahedronVolume3D(RefCoord_Hexahedron(from), ans0) + ans = ans / ans0 + END IF + END SELECT + +CASE ("HEXAHEDRON") + IF (PRESENT(xij)) THEN + CALL HexahedronVolume3D(xij(1:3, 1:8), ans0) + ELSE + RETURN + END IF + + SELECT CASE (TRIM(to)) + CASE ("BIUNIT", "UNIT") + CALL HexahedronVolume3D(RefCoord_Hexahedron(to), ans) + ans = ans / ans0 + END SELECT + +END SELECT +END PROCEDURE JacobianHexahedron + +!---------------------------------------------------------------------------- +! JacobianHexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobianTetrahedron +REAL(DFP) :: ans0 +ans = 1.0_DFP +SELECT CASE (TRIM(from)) +CASE ("BIUNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 1.0_DFP + CASE ("UNIT") + ans = 0.125_DFP + CASE ("TETRAHEDRON") + IF (PRESENT(xij)) THEN + CALL TetrahedronVolume3D(xij(1:3, 1:4), ans) + CALL TetrahedronVolume3D(RefCoord_Tetrahedron(from), ans0) + ans = ans / ans0 + END IF + END SELECT + +CASE ("UNIT") + SELECT CASE (TRIM(to)) + CASE ("BIUNIT") + ans = 8.0_DFP + CASE ("UNIT") + ans = 1.0_DFP + CASE ("TETRAHEDRON") + IF (PRESENT(xij)) THEN + CALL TetrahedronVolume3D(xij(1:3, 1:4), ans) + CALL TetrahedronVolume3D(RefCoord_Tetrahedron(from), ans0) + ans = ans / ans0 + END IF + END SELECT + +CASE ("TETRAHEDRON") + IF (PRESENT(xij)) THEN + CALL TetrahedronVolume3D(xij(1:3, 1:4), ans0) + ELSE + RETURN + END IF + + SELECT CASE (TRIM(to)) + CASE ("BIUNIT", "UNIT") + CALL TetrahedronVolume3D(RefCoord_Tetrahedron(to), ans) + ans = ans / ans0 + END SELECT + +END SELECT +END PROCEDURE JacobianTetrahedron + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/MatmulUtility@Methods.F90 b/src/submodules/Utility/src/MatmulUtility@Methods.F90 new file mode 100644 index 000000000..1cc31c999 --- /dev/null +++ b/src/submodules/Utility/src/MatmulUtility@Methods.F90 @@ -0,0 +1,173 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: Methods for matrix multiplication + +SUBMODULE(MatmulUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +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 +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)) +END DO +END PROCEDURE matmul_r4_r2 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r4_r3 +INTEGER(I4B) :: ii +!! +DO ii = 1, SIZE(a2, 3) + ans(:,:,:,:,ii) = matmul(a1, a2(:,:,ii)) +END DO +END PROCEDURE matmul_r4_r3 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r4_r4 +INTEGER(I4B) :: ii +!! +DO ii = 1, SIZE(a2, 4) + ans(:,:,:,:,:,ii) = matmul(a1, a2(:,:,:,ii)) +END DO +END PROCEDURE matmul_r4_r4 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r1 +INTEGER(I4B) :: ii +ans = a2(1) * a1(:, :, 1) +DO ii = 2, SIZE(a2) + ans = ans + a2(ii) * a1(:, :, ii) +END DO +END PROCEDURE matmul_r3_r1 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r2 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(a2, 2) + ans(:, :, ii) = MATMUL(a1, a2(:, ii)) +END DO +END PROCEDURE matmul_r3_r2 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r3 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(a2, 3) + ans(:,:,:,ii) = matmul(a1, a2(:, :, ii)) +END DO +END PROCEDURE matmul_r3_r3 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r4 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(a2, 4) + ans(:,:,:,:,ii) = matmul(a1, a2(:, :, :,ii)) +END DO +END PROCEDURE matmul_r3_r4 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r2_r3 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(a2, 3) + ans(:, :, ii) = MATMUL(a1, a2(:, :, ii)) +END DO +END PROCEDURE matmul_r2_r3 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r2_r4 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(a2, 4) + ans(:, :, :, ii) = MATMUL(a1, a2(:, :, :, ii)) +END DO +END PROCEDURE matmul_r2_r4 + +!---------------------------------------------------------------------------- +! 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 +END PROCEDURE matmul_r1_r3 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r1_r4 +INTEGER(I4B) :: ii +ans = a1(1) * a2(1, :, :, :) +DO ii = 2, SIZE(a1) + ans = ans + a1(ii) * a2(ii, :, :, :) +END DO +END PROCEDURE matmul_r1_r4 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Median/ArgMedian.inc b/src/submodules/Utility/src/Median/ArgMedian.inc new file mode 100644 index 000000000..ddc929849 --- /dev/null +++ b/src/submodules/Utility/src/Median/ArgMedian.inc @@ -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 +! + +IF (this(indx(right)) < this(indx(left))) CALL swap(indx(left), indx(right)) +IF (this(indx(mid)) < this(indx(left))) CALL swap(indx(mid), indx(left)) +IF (this(indx(right)) < this(indx(mid))) CALL swap(indx(right), indx(mid)) diff --git a/src/submodules/Utility/src/Median/Median.inc b/src/submodules/Utility/src/Median/Median.inc new file mode 100644 index 000000000..0ff1cd794 --- /dev/null +++ b/src/submodules/Utility/src/Median/Median.inc @@ -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 +! + +if (this(right) < this(left)) call swap(this(left), this(right)) +if (this(mid) < this(left)) call swap(this(mid), this(left)) +if (this(right) < this(mid)) call swap(this(right), this(mid)) diff --git a/src/submodules/Utility/src/MedianUtility@Methods.F90 b/src/submodules/Utility/src/MedianUtility@Methods.F90 new file mode 100644 index 000000000..f4d4a922e --- /dev/null +++ b/src/submodules/Utility/src/MedianUtility@Methods.F90 @@ -0,0 +1,119 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(MedianUtility) Methods +USE BaseMethod, ONLY: SWAP +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Median +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Median_Real32 +#include "./Median/Median.inc" +END PROCEDURE Median_Real32 + +!---------------------------------------------------------------------------- +! Median +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Median_Real64 +#include "./Median/Median.inc" +END PROCEDURE Median_Real64 + +!---------------------------------------------------------------------------- +! Median +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Median_Int8 +#include "./Median/Median.inc" +END PROCEDURE Median_Int8 + +!---------------------------------------------------------------------------- +! Median +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Median_Int16 +#include "./Median/Median.inc" +END PROCEDURE Median_Int16 + +!---------------------------------------------------------------------------- +! Median +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Median_Int32 +#include "./Median/Median.inc" +END PROCEDURE Median_Int32 + +!---------------------------------------------------------------------------- +! Median +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Median_Int64 +#include "./Median/Median.inc" +END PROCEDURE Median_Int64 + +!---------------------------------------------------------------------------- +! ArgMedian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgMedian_Real32 +#include "./Median/ArgMedian.inc" +END PROCEDURE ArgMedian_Real32 + +!---------------------------------------------------------------------------- +! ArgMedian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgMedian_Real64 +#include "./Median/ArgMedian.inc" +END PROCEDURE ArgMedian_Real64 + +!---------------------------------------------------------------------------- +! ArgMedian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgMedian_Int8 +#include "./Median/ArgMedian.inc" +END PROCEDURE ArgMedian_Int8 + +!---------------------------------------------------------------------------- +! ArgMedian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgMedian_Int16 +#include "./Median/ArgMedian.inc" +END PROCEDURE ArgMedian_Int16 + +!---------------------------------------------------------------------------- +! ArgMedian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgMedian_Int32 +#include "./Median/ArgMedian.inc" +END PROCEDURE ArgMedian_Int32 + +!---------------------------------------------------------------------------- +! ArgMedian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgMedian_Int64 +#include "./Median/ArgMedian.inc" +END PROCEDURE ArgMedian_Int64 + +END SUBMODULE diff --git a/src/submodules/Utility/src/MiscUtility@Methods.F90 b/src/submodules/Utility/src/MiscUtility@Methods.F90 new file mode 100644 index 000000000..705af9600 --- /dev/null +++ b/src/submodules/Utility/src/MiscUtility@Methods.F90 @@ -0,0 +1,366 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(MiscUtility) Methods +USE BaseMethod +IMPLICIT NONE +INTEGER(I4B), PARAMETER :: NPAR_ARTH = 16, NPAR2_ARTH = 8 +INTEGER(I4B), PARAMETER :: NPAR_GEOP = 4, NPAR2_GEOP = 2 +INTEGER(I4B), PARAMETER :: NPAR_CUMSUM = 16 +INTEGER(I4B), PARAMETER :: NPAR_CUMPROD = 8 +INTEGER(I4B), PARAMETER :: NPAR_POLY = 8 +INTEGER(I4B), PARAMETER :: NPAR_POLYTERM = 8 +CONTAINS + +!---------------------------------------------------------------------------- +! Radian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE radian_dfp +Ans = deg / 180.0_DFP * 3.1415926535_DFP +END PROCEDURE + +!---------------------------------------------------------------------------- +! Radian +!---------------------------------------------------------------------------- + +MODULE PROCEDURE radian_int +Ans = REAL(deg, KIND=DFP) / 180.0_DFP * 3.1415926535_DFP +END PROCEDURE + +!---------------------------------------------------------------------------- +! Degrees +!---------------------------------------------------------------------------- + +MODULE PROCEDURE degrees_dfp +Ans = rad / 3.1415926535_DFP * 180.0_DFP +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Loc_Nearest_Point +! Define internal variables +REAL(DFP) :: xr(3) +INTEGER(I4B) :: i, n, m, norm, tr_norm + +n = SIZE(Array, 1) +m = SIZE(Array, 2) +IF (n .NE. SIZE(x)) THEN + CALL ErrorMSG(& + & Msg="SearchNearestCoord >> size(Array,1) should be =size(x)", & + & File=__FILE__, & + & Line=__LINE__, & + & Routine="Loc_Nearest_Point(Array, x)") + STOP +END IF +! +DO i = 1, m + xr(1:n) = Array(1:n, i) + tr_norm = NORM2(xr(1:n) - x(1:n)) + IF (i .EQ. 1) THEN + norm = tr_norm + id = i + ELSE + IF (norm .GT. tr_norm) THEN + norm = tr_norm + id = i + ELSE + CYCLE + END IF + END IF +END DO +END PROCEDURE + +!---------------------------------------------------------------------------- +! ExecuteCommand +!---------------------------------------------------------------------------- + +MODULE PROCEDURE exe_cmd +! Define internal variables +INTEGER(I4B) :: CMDSTAT, EXITSTAT +LOGICAL(LGT) :: WAIT = .TRUE. +CHARACTER(LEN=300) :: CMDMSG = "" + +CALL EXECUTE_COMMAND_LINE(TRIM(CMD), CMDSTAT=CMDSTAT, & + & EXITSTAT=EXITSTAT, WAIT=WAIT, CMDMSG=CMDMSG) + +IF (CMDSTAT .NE. 0) THEN + IF (CMDSTAT .EQ. -1) THEN + CALL ErrorMsg( & + & File=__FILE__, & + & Routine="exe_cmd()", & + & Line=__LINE__, & + & MSG="following command failed "//TRIM(CMDMSG)) + END IF + + CALL ErrorMsg( & + & File=__FILE__, & + & Routine="exe_cmd()", & + & Line=__LINE__, & + & MSG="following command failed "//TRIM(CMDMSG)) + STOP +END IF +END PROCEDURE + +!---------------------------------------------------------------------------- +! getUnitNo +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getUnitNo_1 +! Define internal variables +LOGICAL(LGT) :: isOpen, isExist +INTEGER(I4B) :: Imin, Imax, I + +Imin = 10 +Imax = 1000 + +DO I = Imin, Imax, 1 + INQUIRE (UNIT=I, OPENED=isOpen, EXIST=isExist) + IF (isExist .AND. .NOT. isOpen) EXIT +END DO +IF (isOpen .OR. .NOT. isExist) THEN + CALL ErrorMsg( & + & File=__FILE__, & + & Routine="getUnitNo_1()", & + & Line=__LINE__, & + & MSG=" cannot find a valid unit number; Program Stopped") + STOP +END IF +ans = I +END PROCEDURE getUnitNo_1 + +!---------------------------------------------------------------------------- +! Factorial +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Factorial +IF (N .EQ. 0) THEN + Ans = 1 +ELSE + Ans = N * Factorial(N - 1) +END IF +END PROCEDURE + +!---------------------------------------------------------------------------- +! Int2Str +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Int2Str +CHARACTER(LEN=15) :: Str +WRITE (Str, "(I15)") I +Int2Str = TRIM(ADJUSTL(Str)) +END PROCEDURE + +!---------------------------------------------------------------------------- +! Real2Str +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SP2Str +CHARACTER(LEN=20) :: Str +WRITE (Str, "(G17.7)") I +SP2Str = TRIM(ADJUSTL(Str)) +END PROCEDURE + +!---------------------------------------------------------------------------- +! Real2Str +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DP2Str +CHARACTER(LEN=20) :: Str +WRITE (Str, "(G17.7)") I +DP2Str = TRIM(ADJUSTL(Str)) +END PROCEDURE + +!---------------------------------------------------------------------------- +! ARTH +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arth_r +INTEGER(I4B) :: k, k2 +REAL(SP) :: temp +IF (n > 0) arth_r(1) = first +IF (n <= NPAR_ARTH) THEN + DO k = 2, n + arth_r(k) = arth_r(k - 1) + increment + END DO +ELSE + DO k = 2, NPAR2_ARTH + arth_r(k) = arth_r(k - 1) + increment + END DO + temp = increment * NPAR2_ARTH + k = NPAR2_ARTH + DO + IF (k >= n) exit + k2 = k + k + arth_r(k + 1:min(k2, n)) = temp + arth_r(1:min(k, n - k)) + temp = temp + temp + k = k2 + END DO +END IF +END PROCEDURE arth_r + +!---------------------------------------------------------------------------- +! ARTH +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arth_d +INTEGER(I4B) :: k, k2 +REAL(DP) :: temp +IF (n > 0) arth_d(1) = first +IF (n <= NPAR_ARTH) THEN + DO k = 2, n + arth_d(k) = arth_d(k - 1) + increment + END DO +ELSE + DO k = 2, NPAR2_ARTH + arth_d(k) = arth_d(k - 1) + increment + END DO + temp = increment * NPAR2_ARTH + k = NPAR2_ARTH + DO + IF (k >= n) exit + k2 = k + k + arth_d(k + 1:min(k2, n)) = temp + arth_d(1:min(k, n - k)) + temp = temp + temp + k = k2 + END DO +END IF +END PROCEDURE arth_d + +!---------------------------------------------------------------------------- +! ARTH +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arth_i +INTEGER(I4B) :: k, k2, temp +IF (n > 0) arth_i(1) = first +IF (n <= NPAR_ARTH) THEN + DO k = 2, n + arth_i(k) = arth_i(k - 1) + increment + END DO +ELSE + DO k = 2, NPAR2_ARTH + arth_i(k) = arth_i(k - 1) + increment + END DO + temp = increment * NPAR2_ARTH + k = NPAR2_ARTH + DO + IF (k >= n) exit + k2 = k + k + arth_i(k + 1:min(k2, n)) = temp + arth_i(1:min(k, n - k)) + temp = temp + temp + k = k2 + END DO +END IF +END PROCEDURE arth_i + +!---------------------------------------------------------------------------- +! OuterDiff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerdIFf_r +outerdIFf_r = SPREAD(a, dim=2, ncopies=size(b)) - & + SPREAD(b, dim=1, ncopies=size(a)) +END PROCEDURE outerdIFf_r + +MODULE PROCEDURE outerdIFf_d +outerdIFf_d = SPREAD(a, dim=2, ncopies=size(b)) - & + SPREAD(b, dim=1, ncopies=size(a)) +END PROCEDURE outerdIFf_d + +MODULE PROCEDURE outerdIFf_i +outerdIFf_i = SPREAD(a, dim=2, ncopies=size(b)) - & + SPREAD(b, dim=1, ncopies=size(a)) +END PROCEDURE outerdIFf_i + +!---------------------------------------------------------------------------- +! IMAXLOC +!---------------------------------------------------------------------------- + +MODULE PROCEDURE imaxloc_r +INTEGER(I4B), DIMENSION(1) :: imax +imax = MAXLOC(arr(:)) +imaxloc_r = imax(1) +END PROCEDURE imaxloc_r + +!---------------------------------------------------------------------------- +! IMAXLOC +!---------------------------------------------------------------------------- + +MODULE PROCEDURE imaxloc_i +INTEGER(I4B), DIMENSION(1) :: imax +imax = MAXLOC(iarr(:)) +imaxloc_i = imax(1) +END PROCEDURE imaxloc_i + +!---------------------------------------------------------------------------- +! IMINLOC +!---------------------------------------------------------------------------- + +MODULE PROCEDURE iminloc_r +INTEGER(I4B), DIMENSION(1) :: imin +imin = MINLOC(arr(:)) +iminloc_r = imin(1) +END PROCEDURE iminloc_r + +!---------------------------------------------------------------------------- +! IMG +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IMG_1 +COMPLEX(Real32), PARAMETER :: i = (0.0_Real32, 1.0_Real32) +ans = REAL(x * i, KIND=Real32) +END PROCEDURE IMG_1 + +!---------------------------------------------------------------------------- +! IMG +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IMG_2 +COMPLEX(Real64), PARAMETER :: i = (0.0_Real64, 1.0_Real64) +ans = REAL(x * i, KIND=Real64) +END PROCEDURE IMG_2 + +!---------------------------------------------------------------------------- +! Safe_ACOS +!---------------------------------------------------------------------------- + +MODULE PROCEDURE safe_ACOS +REAL(DFP) :: c2 +!! +c2 = c +c2 = MAX(c2, -1.0_DFP) +c2 = MIN(c2, +1.0_DFP) +!! +ans = acos(c2) +END PROCEDURE safe_ACOS + +!---------------------------------------------------------------------------- +! Safe_ASIN +!---------------------------------------------------------------------------- + +MODULE PROCEDURE safe_ASIN +REAL(DFP) :: s2 +s2 = s +s2 = MAX(s2, -1.0D+00) +s2 = MIN(s2, +1.0D+00) +ans = asin(s2) +END PROCEDURE safe_ASIN + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/OnesUtility@Methods.F90 b/src/submodules/Utility/src/OnesUtility@Methods.F90 new file mode 100644 index 000000000..285e84680 --- /dev/null +++ b/src/submodules/Utility/src/OnesUtility@Methods.F90 @@ -0,0 +1,253 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +submodule(OnesUtility) Methods +implicit none +contains + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_1 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_2 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_3 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_4 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- +#ifdef USE_Int128 +module procedure ones_5 + ans = 1 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_6 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_7 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_8 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_9 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_10 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_11 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +module procedure ones_12 + ans = 1 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_13 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_14 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_15 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_16 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_17 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_18 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +module procedure ones_19 + ans = 1 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_20 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_21 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_22 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_23 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_24 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_25 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +module procedure ones_26 + ans = 1 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_27 + ans = 1 +end procedure + +!---------------------------------------------------------------------------- +! Ones +!---------------------------------------------------------------------------- + +module procedure ones_28 + ans = 1 +end procedure + +end submodule Methods diff --git a/src/submodules/Utility/src/Partition/ArgPartition.inc b/src/submodules/Utility/src/Partition/ArgPartition.inc new file mode 100644 index 000000000..09bde4203 --- /dev/null +++ b/src/submodules/Utility/src/Partition/ArgPartition.inc @@ -0,0 +1,34 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + + +pivot = this(idx(left)) +lo = left + 1; hi = right +DO WHILE (lo <= hi) + DO WHILE (this(idx(hi)) > pivot) + hi = hi - 1 + END DO + DO WHILE (lo <= hi .AND. this(idx(lo)) <= pivot) + lo = lo + 1 + END DO + IF (lo <= hi) THEN + CALL swap(idx(lo), idx(hi)) + lo = lo + 1; hi = hi - 1 + END IF +END DO +CALL swap(idx(left), idx(hi)) +i = hi diff --git a/src/submodules/Utility/src/Partition/Partition.inc b/src/submodules/Utility/src/Partition/Partition.inc new file mode 100644 index 000000000..9a78557fb --- /dev/null +++ b/src/submodules/Utility/src/Partition/Partition.inc @@ -0,0 +1,35 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + + +pivot = this(left) +lo = left; hi = right +DO WHILE (lo <= hi) + DO WHILE (this(hi) > pivot) + hi = hi - 1 + END DO + + DO WHILE (lo <= hi .AND. this(lo) <= pivot) + lo = lo + 1 + END DO + IF (lo <= hi) THEN + CALL swap(this(lo), this(hi)) + lo = lo + 1; hi = hi - 1 + END IF +END DO +CALL swap(this(left), this(hi)) +iPivot = hi diff --git a/src/submodules/Utility/src/PartitionUtility@Methods.F90 b/src/submodules/Utility/src/PartitionUtility@Methods.F90 new file mode 100644 index 000000000..c9597bbdd --- /dev/null +++ b/src/submodules/Utility/src/PartitionUtility@Methods.F90 @@ -0,0 +1,143 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(PartitionUtility) Methods +USE BaseMethod, ONLY: SWAP +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE partition_Real32 +INTEGER(I4B) :: lo, hi +REAL(REAL32) :: pivot +#include "./Partition/Partition.inc" +END PROCEDURE partition_Real32 + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE partition_Real64 +INTEGER(I4B) :: lo, hi +REAL(REAL64) :: pivot +#include "./Partition/Partition.inc" +END PROCEDURE partition_Real64 + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE partition_Int8 +INTEGER(I4B) :: lo, hi +INTEGER(INT8) :: pivot +#include "./Partition/Partition.inc" +END PROCEDURE partition_Int8 + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE partition_Int16 +INTEGER(I4B) :: lo, hi +INTEGER(INT16) :: pivot +#include "./Partition/Partition.inc" +END PROCEDURE partition_Int16 + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE partition_Int32 +INTEGER(I4B) :: lo, hi +INTEGER(INT32) :: pivot +#include "./Partition/Partition.inc" +END PROCEDURE partition_Int32 + +!---------------------------------------------------------------------------- +! Partition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE partition_Int64 +INTEGER(I4B) :: lo, hi +INTEGER(INT64) :: pivot +#include "./Partition/Partition.inc" +END PROCEDURE partition_Int64 + +!---------------------------------------------------------------------------- +! ArgPartition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE argPartition_Int8 +INTEGER(I4B) :: lo, hi +INTEGER(INT8) :: pivot +#include "./Partition/ArgPartition.inc" +END PROCEDURE argPartition_Int8 + +!---------------------------------------------------------------------------- +! ArgPartition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE argPartition_Int16 +INTEGER(I4B) :: lo, hi +INTEGER(INT16) :: pivot +#include "./Partition/ArgPartition.inc" +END PROCEDURE argPartition_Int16 + +!---------------------------------------------------------------------------- +! ArgPartition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE argPartition_Int32 +INTEGER(I4B) :: lo, hi +INTEGER(INT32) :: pivot +#include "./Partition/ArgPartition.inc" +END PROCEDURE argPartition_Int32 + +!---------------------------------------------------------------------------- +! ArgPartition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE argPartition_Int64 +INTEGER(I4B) :: lo, hi +INTEGER(INT64) :: pivot +#include "./Partition/ArgPartition.inc" +END PROCEDURE argPartition_Int64 + +!---------------------------------------------------------------------------- +! ArgPartition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE argPartition_Real32 +INTEGER(I4B) :: lo, hi +REAL(REAL32) :: pivot +#include "./Partition/ArgPartition.inc" +END PROCEDURE argPartition_Real32 + +!---------------------------------------------------------------------------- +! ArgPartition +!---------------------------------------------------------------------------- + +MODULE PROCEDURE argPartition_Real64 +INTEGER(I4B) :: lo, hi +REAL(REAL64) :: pivot +#include "./Partition/ArgPartition.inc" +END PROCEDURE argPartition_Real64 + +END SUBMODULE diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 new file mode 100644 index 000000000..e68c7588c --- /dev/null +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -0,0 +1,500 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: This submodule contains outerprod + +SUBMODULE(ProductUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! VectorProd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vectorProduct_1 +c(1) = a(2) * b(3) - a(3) * b(2) +c(2) = a(3) * b(1) - a(1) * b(3) +c(3) = a(1) * b(2) - a(2) * b(1) +END PROCEDURE vectorProduct_1 + +!---------------------------------------------------------------------------- +! VectorProd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vectorProduct_2 +c(1) = a(2) * b(3) - a(3) * b(2) +c(2) = a(3) * b(1) - a(1) * b(3) +c(3) = a(1) * b(2) - a(2) * b(1) +END PROCEDURE vectorProduct_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1 +ans = 0.0_DFP +ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * & + & SPREAD(b, dim=1, ncopies=SIZE(a)) +END PROCEDURE outerprod_r1r1 + +!-------------------------------------------------------------------- +! +!-------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1s +ans = 0.0_DFP +IF (Sym) THEN + ans = SPREAD(0.5_DFP * a, dim=2, ncopies=SIZE(b)) & + & * SPREAD(b, dim=1, ncopies=SIZE(a)) & + & + SPREAD(0.5_DFP * b, dim=2, ncopies=SIZE(a)) & + & * SPREAD(a, dim=1, ncopies=SIZE(b)) +ELSE + ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * & + & SPREAD(b, dim=1, ncopies=SIZE(a)) +END IF +END PROCEDURE outerprod_r1r1s + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r2 +INTEGER(I4B) :: ii +do ii = 1, size(b, 2) + ans(:, :, ii) = outerprod(a, b(:, ii)) +end do +END PROCEDURE outerprod_r1r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r3 +INTEGER(I4B) :: ii +do ii = 1, size(b, 3) + ans(:, :, :, ii) = outerprod(a, b(:, :, ii)) +end do +END PROCEDURE outerprod_r1r3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r4 +INTEGER(I4B) :: ii +do ii = 1, size(b, 4) + ans(:, :, :, :, ii) = outerprod(a, b(:, :, :, ii)) +end do +END PROCEDURE outerprod_r1r4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r5 +INTEGER(I4B) :: ii +do ii = 1, size(b, 5) + ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, :, ii)) +end do +END PROCEDURE outerprod_r1r5 + +!-------------------------------------------------------------------- +! +!-------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r1 +INTEGER(I4B) :: ii +do ii = 1, size(b, 1) + ans(:, :, ii) = a * b(ii) +end do +END PROCEDURE outerprod_r2r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r2 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 2) + ans(:, :, :, ii) = outerprod(a, b(:, ii)) +END DO +END PROCEDURE outerprod_r2r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r3 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 3) + ans(:, :, :, :, ii) = outerprod(a, b(:, :, ii)) +END DO +END PROCEDURE outerprod_r2r3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r4 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 4) + ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, ii)) +END DO +END PROCEDURE outerprod_r2r4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r3r1 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 1) + ans(:, :, :, ii) = a(:, :, :) * b(ii) +END DO +END PROCEDURE outerprod_r3r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r3r2 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 2) + ans(:, :, :, :, ii) = outerprod(a, b(:, ii)) +END DO +END PROCEDURE outerprod_r3r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r3r3 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 3) + ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, ii)) +END DO +END PROCEDURE outerprod_r3r3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r4r1 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 1) + ans(:, :, :, :, ii) = a * b(ii) +END DO +END PROCEDURE outerprod_r4r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r4r2 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b, 2) + ans(:, :, :, :, :, ii) = outerprod(a, b(:, ii)) +END DO +END PROCEDURE outerprod_r4r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r5r1 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(b) + ans(:, :, :, :, :, ii) = a * b(ii) +END DO +END PROCEDURE outerprod_r5r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r2 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r1r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r3 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r1r3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r4 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r1r4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r2r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r2r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r2r2 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r2r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r2r3 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r2r3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r3r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r3r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r3r2 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r3r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r4r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r1r4r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r1r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r2r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r1r2 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r2r1r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r1r3 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r2r1r3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r2r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r2r2r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r2r2 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r2r2r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r3r1r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r3r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r3r1r2 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r3r1r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r3r2r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r3r2r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r4r1r1 +ans = outerprod(outerprod(a, b), c) +END PROCEDURE outerprod_r4r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r1r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r1r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r1r2 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r1r1r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r1r3 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r1r1r3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r2r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r1r2r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r2r2 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r1r2r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r1r3r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r1r3r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r2r1r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r2r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r2r1r2 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r2r1r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r2r2r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r2r2r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r1r3r1r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r1r3r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r1r1r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r2r1r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r1r1r2 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r2r1r1r2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r1r2r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r2r1r2r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r2r2r1r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r2r2r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE outerprod_r3r1r1r1 +ans = outerprod(outerprod(a, outerprod(b, c)), d) +END PROCEDURE outerprod_r3r1r1r1 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/PushPop/Pop_Scalar.inc b/src/submodules/Utility/src/PushPop/Pop_Scalar.inc new file mode 100644 index 000000000..3e54cf768 --- /dev/null +++ b/src/submodules/Utility/src/PushPop/Pop_Scalar.inc @@ -0,0 +1,40 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) :: n, ii + !! +n = SIZE(vec) +!! +IF (n .EQ. 1) RETURN +!! +IF (pos .GT. n) THEN + ans = vec(1:n - 1) + RETURN +END IF +!! +IF (pos .LT. 1_I4B) THEN + ans = vec(2:n) + RETURN +END IF +!! +DO ii = 1, pos - 1 + ans(ii) = vec(ii) +END DO + +DO ii = pos, n - 1 + ans(ii) = vec(ii + 1) +END DO diff --git a/src/submodules/Utility/src/PushPop/Push_Scalar.inc b/src/submodules/Utility/src/PushPop/Push_Scalar.inc new file mode 100644 index 000000000..7cfd66cec --- /dev/null +++ b/src/submodules/Utility/src/PushPop/Push_Scalar.inc @@ -0,0 +1,41 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) :: n, ii + !! +n = SIZE(vec) + !! +IF (pos .GT. n) THEN + ans(1:n) = vec + ans(n + 1) = value + RETURN +END IF + !! +IF (pos .LT. 1_I4B) THEN + ans(1) = value + ans(2:n + 1) = vec + RETURN +END IF + !! +ans(pos) = value +DO ii = 1, pos - 1 + ans(ii) = vec(ii) +END DO + +DO ii = pos, n + ans(ii + 1) = vec(ii) +END DO diff --git a/src/submodules/Utility/src/PushPopUtility@Methods.F90 b/src/submodules/Utility/src/PushPopUtility@Methods.F90 new file mode 100644 index 000000000..0f820b5ef --- /dev/null +++ b/src/submodules/Utility/src/PushPopUtility@Methods.F90 @@ -0,0 +1,118 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(PushPopUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int8 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int16 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int32 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int64 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_real32 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_real32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_real64 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_real64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int8 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int16 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int32 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int64 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_real32 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_real32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_real64 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_real64 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc new file mode 100644 index 000000000..42e8eec30 --- /dev/null +++ b/src/submodules/Utility/src/QuickSort/QuickSort1Vec.inc @@ -0,0 +1,34 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) i, iPivot + +iPivot = high +i = low +DO WHILE (iPivot > i) + IF (vect1(i) > vect1(iPivot)) THEN + CALL Swap(vect1(i), vect1(iPivot - 1)) + CALL Swap(vect1(iPivot - 1), vect1(iPivot)) + iPivot = iPivot - 1 + ELSE + i = i + 1 + END IF +END DO +IF (low < high) THEN + CALL QuickSort(vect1, low, iPivot - 1) + CALL QuickSort(vect1, iPivot + 1, high) +END IF diff --git a/src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc new file mode 100644 index 000000000..4bc273972 --- /dev/null +++ b/src/submodules/Utility/src/QuickSort/QuickSort2Vec.inc @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) i, iPivot + +iPivot = high +i = low +DO WHILE (iPivot > i) + IF (vect1(i) > vect1(iPivot)) THEN + CALL Swap(vect1(i), vect1(iPivot - 1)) + CALL Swap(vect2(i), vect2(iPivot - 1)) + CALL Swap(vect1(iPivot - 1), vect1(iPivot)) + CALL Swap(vect2(iPivot - 1), vect2(iPivot)) + iPivot = iPivot - 1 + ELSE + i = i + 1 + END IF +END DO +IF (low < high) THEN + CALL QuickSort(vect1, vect2, low, iPivot - 1) + CALL QuickSort(vect1, vect2, iPivot + 1, high) +END IF diff --git a/src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc new file mode 100644 index 000000000..36df532c1 --- /dev/null +++ b/src/submodules/Utility/src/QuickSort/QuickSort3Vec.inc @@ -0,0 +1,38 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) i, iPivot + +iPivot = high +i = low +DO WHILE (iPivot > i) + IF (vect1(i) > vect1(iPivot)) THEN + CALL Swap(vect1(i), vect1(iPivot - 1)) + CALL Swap(vect2(i), vect2(iPivot - 1)) + CALL Swap(vect3(i), vect3(iPivot - 1)) + CALL Swap(vect1(iPivot - 1), vect1(iPivot)) + CALL Swap(vect2(iPivot - 1), vect2(iPivot)) + CALL Swap(vect3(iPivot - 1), vect3(iPivot)) + iPivot = iPivot - 1 + ELSE + i = i + 1 + END IF +END DO +IF (low < high) THEN + CALL QuickSort(vect1, vect2, vect3, low, iPivot - 1) + CALL QuickSort(vect1, vect2, vect3, iPivot + 1, high) +END IF diff --git a/src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc b/src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc new file mode 100644 index 000000000..85b7eec3c --- /dev/null +++ b/src/submodules/Utility/src/QuickSort/QuickSort4Vec.inc @@ -0,0 +1,40 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) i, iPivot + +iPivot = high +i = low +DO WHILE (iPivot > i) + IF (vect1(i) > vect1(iPivot)) THEN + CALL Swap(vect1(i), vect1(iPivot - 1)) + CALL Swap(vect2(i), vect2(iPivot - 1)) + CALL Swap(vect3(i), vect3(iPivot - 1)) + CALL Swap(vect4(i), vect4(iPivot - 1)) + CALL Swap(vect1(iPivot - 1), vect1(iPivot)) + CALL Swap(vect2(iPivot - 1), vect2(iPivot)) + CALL Swap(vect3(iPivot - 1), vect3(iPivot)) + CALL Swap(vect4(iPivot - 1), vect4(iPivot)) + iPivot = iPivot - 1 + ELSE + i = i + 1 + END IF +END DO +IF (low < high) THEN + CALL QuickSort(vect1, vect2, vect3, vect4, low, iPivot - 1) + CALL QuickSort(vect1, vect2, vect3, vect4, iPivot + 1, high) +END IF diff --git a/src/submodules/Utility/src/ReallocateUtility@Methods.F90 b/src/submodules/Utility/src/ReallocateUtility@Methods.F90 new file mode 100644 index 000000000..a468f09db --- /dev/null +++ b/src/submodules/Utility/src/ReallocateUtility@Methods.F90 @@ -0,0 +1,1186 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: Methods for reallocating arrays + +SUBMODULE(ReallocateUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Reallocate2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_logical +IF (ALLOCATED(Mat)) THEN + IF (SIZE(Mat) .NE. row) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row)) + END IF +ELSE + ALLOCATE (Mat(row)) +END IF +Mat = .FALSE. +END PROCEDURE Reallocate_logical + +!---------------------------------------------------------------------------- +! Reallocate2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R1 +IF (ALLOCATED(Mat)) THEN + IF (SIZE(Mat) .NE. row) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row)) + END IF +ELSE + ALLOCATE (Mat(row)) +END IF +Mat = 0.0_DFP +END PROCEDURE Reallocate_Real64_R1 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R1b +CALL Reallocate_Real64_R1(mat, s(1)) +END PROCEDURE Reallocate_Real64_R1b + +!---------------------------------------------------------------------------- +! Reallocate2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R1 +IF (ALLOCATED(Mat)) THEN + IF (SIZE(Mat) .NE. row) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row)) + END IF +ELSE + ALLOCATE (Mat(row)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real32_R1 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R1b +CALL Reallocate_Real32_R1(mat, s(1)) +END PROCEDURE Reallocate_Real32_R1b + +!---------------------------------------------------------------------------- +! Reallocate1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R2 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row, col)) + END IF +ELSE + ALLOCATE (Mat(row, col)) +END IF +Mat = 0.0_DFP +END PROCEDURE Reallocate_Real64_R2 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R2b +CALL Reallocate_Real64_R2(mat, s(1), s(2)) +END PROCEDURE Reallocate_Real64_R2b + +!---------------------------------------------------------------------------- +! Reallocate1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R2 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row, col)) + END IF +ELSE + ALLOCATE (Mat(row, col)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real32_R2 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R2b +CALL Reallocate_Real32_R2(mat, s(1), s(2)) +END PROCEDURE Reallocate_Real32_R2b + +!--------------------------------------------------------------------------- +! Reallocate +!--------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R3 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3)) +END IF +Mat = 0.0_DFP +END PROCEDURE Reallocate_Real64_R3 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R3b +CALL Reallocate_Real64_R3(mat, s(1), s(2), s(3)) +END PROCEDURE Reallocate_Real64_R3b + +!--------------------------------------------------------------------------- +! Reallocate +!--------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R3 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real32_R3 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R3b +CALL Reallocate_Real32_R3(mat, s(1), s(2), s(3)) +END PROCEDURE Reallocate_Real32_R3b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R4 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3) & + & .OR. (SIZE(Mat, 4) .NE. i4) & + & ) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real64_R4 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R4b +CALL Reallocate_Real64_R4(mat, s(1), s(2), s(3), s(4)) +END PROCEDURE Reallocate_Real64_R4b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R4 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3) & + & .OR. (SIZE(Mat, 4) .NE. i4) & + & ) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real32_R4 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R4b +CALL Reallocate_Real32_R4(mat, s(1), s(2), s(3), s(4)) +END PROCEDURE Reallocate_Real32_R4b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R5 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real64_R5 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R5b +CALL Reallocate_Real64_R5(mat, s(1), s(2), s(3), s(4), s(5)) +END PROCEDURE Reallocate_Real64_R5b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R5 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real32_R5 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R5b +CALL Reallocate_Real32_R5(mat, s(1), s(2), s(3), s(4), s(5)) +END PROCEDURE Reallocate_Real32_R5b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R6 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real64_R6 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R6b +CALL Reallocate_Real64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +END PROCEDURE Reallocate_Real64_R6b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R6 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real32_R6 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R6b +CALL Reallocate_Real32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +END PROCEDURE Reallocate_Real32_R6b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R7 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real64_R7 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R7b +CALL Reallocate_Real64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +END PROCEDURE Reallocate_Real64_R7b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R7 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) +END IF +Mat = 0.0 +END PROCEDURE Reallocate_Real32_R7 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R7b +CALL Reallocate_Real32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +END PROCEDURE Reallocate_Real32_R7b + +!---------------------------------------------------------------------------- +! Reallocate2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R1 +IF (ALLOCATED(Mat)) THEN + IF (SIZE(Mat) .NE. row) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row)) + END IF +ELSE + ALLOCATE (Mat(row)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int64_R1 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R1b +CALL Reallocate_Int64_R1(mat, s(1)) +END PROCEDURE Reallocate_Int64_R1b + +!---------------------------------------------------------------------------- +! Reallocate2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R1 +IF (ALLOCATED(Mat)) THEN + IF (SIZE(Mat) .NE. row) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row)) + END IF +ELSE + ALLOCATE (Mat(row)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int32_R1 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R1b +CALL Reallocate_Int32_R1(mat, s(1)) +END PROCEDURE Reallocate_Int32_R1b + +!---------------------------------------------------------------------------- +! Reallocate2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int16_R1 +IF (ALLOCATED(Mat)) THEN + IF (SIZE(Mat) .NE. row) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row)) + END IF +ELSE + ALLOCATE (Mat(row)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int16_R1 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int16_R1b +CALL Reallocate_Int16_R1(mat, s(1)) +END PROCEDURE Reallocate_Int16_R1b + +!---------------------------------------------------------------------------- +! Reallocate2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int8_R1 +IF (ALLOCATED(Mat)) THEN + IF (SIZE(Mat) .NE. row) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row)) + END IF +ELSE + ALLOCATE (Mat(row)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int8_R1 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int8_R1b +CALL Reallocate_Int8_R1(mat, s(1)) +END PROCEDURE Reallocate_Int8_R1b + +!---------------------------------------------------------------------------- +! Reallocate1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R2 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row, col)) + END IF +ELSE + ALLOCATE (Mat(row, col)) +END IF +Mat = 0_DFP +END PROCEDURE Reallocate_Int64_R2 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R2b +CALL Reallocate_Int64_R2(mat, s(1), s(2)) +END PROCEDURE Reallocate_Int64_R2b + +!---------------------------------------------------------------------------- +! Reallocate1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R2 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row, col)) + END IF +ELSE + ALLOCATE (Mat(row, col)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int32_R2 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R2b +CALL Reallocate_Int32_R2(mat, s(1), s(2)) +END PROCEDURE Reallocate_Int32_R2b + +!---------------------------------------------------------------------------- +! Reallocate1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int16_R2 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row, col)) + END IF +ELSE + ALLOCATE (Mat(row, col)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int16_R2 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int16_R2b +CALL Reallocate_Int16_R2(mat, s(1), s(2)) +END PROCEDURE Reallocate_Int16_R2b + +!---------------------------------------------------------------------------- +! Reallocate1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int8_R2 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(row, col)) + END IF +ELSE + ALLOCATE (Mat(row, col)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int8_R2 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int8_R2b +CALL Reallocate_Int8_R2(mat, s(1), s(2)) +END PROCEDURE Reallocate_Int8_R2b + +!--------------------------------------------------------------------------- +! Reallocate +!--------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R3 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3)) +END IF +Mat = 0_DFP +END PROCEDURE Reallocate_Int64_R3 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R3b +CALL Reallocate_Int64_R3(mat, s(1), s(2), s(3)) +END PROCEDURE Reallocate_Int64_R3b + +!--------------------------------------------------------------------------- +! Reallocate +!--------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R3 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3)) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int32_R3 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R3b +CALL Reallocate_Int32_R3(mat, s(1), s(2), s(3)) +END PROCEDURE Reallocate_Int32_R3b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R4 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3) & + & .OR. (SIZE(Mat, 4) .NE. i4) & + & ) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int64_R4 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R4b +CALL Reallocate_Int64_R4(mat, s(1), s(2), s(3), s(4)) +END PROCEDURE Reallocate_Int64_R4b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R4 +IF (ALLOCATED(Mat)) THEN + IF ((SIZE(Mat, 1) .NE. i1) & + & .OR. (SIZE(Mat, 2) .NE. i2) & + & .OR. (SIZE(Mat, 3) .NE. i3) & + & .OR. (SIZE(Mat, 4) .NE. i4) & + & ) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int32_R4 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R4b +CALL Reallocate_Int32_R4(mat, s(1), s(2), s(3), s(4)) +END PROCEDURE Reallocate_Int32_R4b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R5 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int64_R5 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R5b +CALL Reallocate_Int64_R5(mat, s(1), s(2), s(3), s(4), s(5)) +END PROCEDURE Reallocate_Int64_R5b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R5 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int32_R5 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R5b +CALL Reallocate_Int32_R5(mat, s(1), s(2), s(3), s(4), s(5)) +END PROCEDURE Reallocate_Int32_R5b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R6 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int64_R6 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R6b +CALL Reallocate_Int64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +END PROCEDURE Reallocate_Int64_R6b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R6 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int32_R6 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R6b +CALL Reallocate_Int32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +END PROCEDURE Reallocate_Int32_R6b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R7 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int64_R7 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int64_R7b +CALL Reallocate_Int64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +END PROCEDURE Reallocate_Int64_R7b + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R7 +IF (ALLOCATED(Mat)) THEN + IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN + DEALLOCATE (Mat) + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) + END IF +ELSE + ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) +END IF +Mat = 0 +END PROCEDURE Reallocate_Int32_R7 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R7b +CALL Reallocate_Int32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +END PROCEDURE Reallocate_Int32_R7b + +!---------------------------------------------------------------------------- +! Reallocate6 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Int32_R1_6 +IF (ALLOCATED(Vec1)) THEN + IF (SIZE(Vec1) .NE. n1) THEN + DEALLOCATE (Vec1) + ALLOCATE (Vec1(n1)) + END IF +ELSE + ALLOCATE (Vec1(n1)) +END IF +Vec1 = 0 + +IF (ALLOCATED(Vec2)) THEN + IF (SIZE(Vec2) .NE. n2) THEN + DEALLOCATE (Vec2) + ALLOCATE (Vec2(n2)) + END IF +ELSE + ALLOCATE (Vec2(n2)) +END IF +Vec2 = 0 + +IF (PRESENT(Vec3)) THEN + IF (ALLOCATED(Vec3)) THEN + IF (SIZE(Vec3) .NE. n3) THEN + DEALLOCATE (Vec3) + ALLOCATE (Vec3(n3)) + END IF + ELSE + ALLOCATE (Vec3(n3)) + END IF + Vec3 = 0 +END IF + +IF (PRESENT(Vec4)) THEN + IF (ALLOCATED(Vec4)) THEN + IF (SIZE(Vec4) .NE. n4) THEN + DEALLOCATE (Vec4) + ALLOCATE (Vec4(n4)) + END IF + ELSE + ALLOCATE (Vec4(n4)) + END IF + Vec4 = 0 +END IF + +IF (PRESENT(Vec5)) THEN + IF (ALLOCATED(Vec5)) THEN + IF (SIZE(Vec5) .NE. n5) THEN + DEALLOCATE (Vec5) + ALLOCATE (Vec5(n5)) + END IF + ELSE + ALLOCATE (Vec5(n5)) + END IF + Vec5 = 0 +END IF + +IF (PRESENT(Vec6)) THEN + IF (ALLOCATED(Vec6)) THEN + IF (SIZE(Vec6) .NE. n6) THEN + DEALLOCATE (Vec6) + ALLOCATE (Vec6(n6)) + END IF + ELSE + ALLOCATE (Vec6(n6)) + END IF + Vec6 = 0 +END IF + +END PROCEDURE Reallocate_Int32_R1_6 + +!---------------------------------------------------------------------------- +! Reallocate7 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_R1_6 +IF (ALLOCATED(Vec1)) THEN + IF (SIZE(Vec1) .NE. n1) THEN + DEALLOCATE (Vec1) + ALLOCATE (Vec1(n1)) + END IF +ELSE + ALLOCATE (Vec1(n1)) +END IF +Vec1 = 0.0 + +IF (ALLOCATED(Vec2)) THEN + IF (SIZE(Vec2) .NE. n2) THEN + DEALLOCATE (Vec2) + ALLOCATE (Vec2(n2)) + END IF +ELSE + ALLOCATE (Vec2(n2)) +END IF +Vec2 = 0.0 + +IF (PRESENT(Vec3)) THEN + IF (ALLOCATED(Vec3)) THEN + IF (SIZE(Vec3) .NE. n3) THEN + DEALLOCATE (Vec3) + ALLOCATE (Vec3(n3)) + END IF + ELSE + ALLOCATE (Vec3(n3)) + END IF + Vec3 = 0.0 +END IF + +IF (PRESENT(Vec4)) THEN + IF (ALLOCATED(Vec4)) THEN + IF (SIZE(Vec4) .NE. n4) THEN + DEALLOCATE (Vec4) + ALLOCATE (Vec4(n4)) + END IF + ELSE + ALLOCATE (Vec4(n4)) + END IF + Vec4 = 0.0 +END IF + +IF (PRESENT(Vec5)) THEN + IF (ALLOCATED(Vec5)) THEN + IF (SIZE(Vec5) .NE. n5) THEN + DEALLOCATE (Vec5) + ALLOCATE (Vec5(n5)) + END IF + ELSE + ALLOCATE (Vec5(n5)) + END IF + Vec5 = 0.0 +END IF + +IF (PRESENT(Vec6)) THEN + IF (ALLOCATED(Vec6)) THEN + IF (SIZE(Vec6) .NE. n6) THEN + DEALLOCATE (Vec6) + ALLOCATE (Vec6(n6)) + END IF + ELSE + ALLOCATE (Vec6(n6)) + END IF + Vec6 = 0.0 +END IF +END PROCEDURE Reallocate_Real64_R1_6 + +!---------------------------------------------------------------------------- +! Reallocate7 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_R1_6 +IF (ALLOCATED(Vec1)) THEN + IF (SIZE(Vec1) .NE. n1) THEN + DEALLOCATE (Vec1) + ALLOCATE (Vec1(n1)) + END IF +ELSE + ALLOCATE (Vec1(n1)) +END IF +Vec1 = 0.0 + +IF (ALLOCATED(Vec2)) THEN + IF (SIZE(Vec2) .NE. n2) THEN + DEALLOCATE (Vec2) + ALLOCATE (Vec2(n2)) + END IF +ELSE + ALLOCATE (Vec2(n2)) +END IF +Vec2 = 0.0 + +IF (PRESENT(Vec3)) THEN + IF (ALLOCATED(Vec3)) THEN + IF (SIZE(Vec3) .NE. n3) THEN + DEALLOCATE (Vec3) + ALLOCATE (Vec3(n3)) + END IF + ELSE + ALLOCATE (Vec3(n3)) + END IF + Vec3 = 0.0 +END IF + +IF (PRESENT(Vec4)) THEN + IF (ALLOCATED(Vec4)) THEN + IF (SIZE(Vec4) .NE. n4) THEN + DEALLOCATE (Vec4) + ALLOCATE (Vec4(n4)) + END IF + ELSE + ALLOCATE (Vec4(n4)) + END IF + Vec4 = 0.0 +END IF + +IF (PRESENT(Vec5)) THEN + IF (ALLOCATED(Vec5)) THEN + IF (SIZE(Vec5) .NE. n5) THEN + DEALLOCATE (Vec5) + ALLOCATE (Vec5(n5)) + END IF + ELSE + ALLOCATE (Vec5(n5)) + END IF + Vec5 = 0.0 +END IF + +IF (PRESENT(Vec6)) THEN + IF (ALLOCATED(Vec6)) THEN + IF (SIZE(Vec6) .NE. n6) THEN + DEALLOCATE (Vec6) + ALLOCATE (Vec6(n6)) + END IF + ELSE + ALLOCATE (Vec6(n6)) + END IF + Vec6 = 0.0 +END IF +END PROCEDURE Reallocate_Real32_R1_6 + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_AIJ +IF (ALLOCATED(A)) THEN + IF (SIZE(A) .NE. nA) THEN + DEALLOCATE (A) + ALLOCATE (A(nA)) + END IF +ELSE + ALLOCATE (A(nA)) +END IF +A = 0.0 + +IF (ALLOCATED(IA)) THEN + IF (SIZE(IA) .NE. nIA) THEN + DEALLOCATE (IA) + ALLOCATE (IA(nIA)) + END IF +ELSE + ALLOCATE (IA(nIA)) +END IF +IA = 0 + +IF (ALLOCATED(JA)) THEN + IF (SIZE(JA) .NE. nJA) THEN + DEALLOCATE (JA) + ALLOCATE (JA(nJA)) + END IF +ELSE + ALLOCATE (JA(nJA)) +END IF +JA = 0 +END PROCEDURE Reallocate_Real64_AIJ + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_AIJ +IF (ALLOCATED(A)) THEN + IF (SIZE(A) .NE. nA) THEN + DEALLOCATE (A) + ALLOCATE (A(nA)) + END IF +ELSE + ALLOCATE (A(nA)) +END IF +A = 0.0 + +IF (ALLOCATED(IA)) THEN + IF (SIZE(IA) .NE. nIA) THEN + DEALLOCATE (IA) + ALLOCATE (IA(nIA)) + END IF +ELSE + ALLOCATE (IA(nIA)) +END IF +IA = 0 + +IF (ALLOCATED(JA)) THEN + IF (SIZE(JA) .NE. nJA) THEN + DEALLOCATE (JA) + ALLOCATE (JA(nJA)) + END IF +ELSE + ALLOCATE (JA(nJA)) +END IF +JA = 0 +END PROCEDURE Reallocate_Real32_AIJ + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real64_AI +IF (ALLOCATED(A)) THEN + IF (SIZE(A) .NE. nA) THEN + DEALLOCATE (A) + ALLOCATE (A(nA)) + END IF +ELSE + ALLOCATE (A(nA)) +END IF +A = 0.0 + +IF (ALLOCATED(IA)) THEN + IF (SIZE(IA) .NE. nIA) THEN + DEALLOCATE (IA) + ALLOCATE (IA(nIA)) + END IF +ELSE + ALLOCATE (IA(nIA)) +END IF +IA = 0 +END PROCEDURE Reallocate_Real64_AI + +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reallocate_Real32_AI +IF (ALLOCATED(A)) THEN + IF (SIZE(A) .NE. nA) THEN + DEALLOCATE (A) + ALLOCATE (A(nA)) + END IF +ELSE + ALLOCATE (A(nA)) +END IF +A = 0.0 + +IF (ALLOCATED(IA)) THEN + IF (SIZE(IA) .NE. nIA) THEN + DEALLOCATE (IA) + ALLOCATE (IA(nIA)) + END IF +ELSE + ALLOCATE (IA(nIA)) +END IF +IA = 0 +END PROCEDURE Reallocate_Real32_AI + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc b/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc new file mode 100644 index 000000000..046a6bd6b --- /dev/null +++ b/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_1.inc @@ -0,0 +1,46 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 internal variables +INTEGER(I4B) :: ii, n, tsize + +IF (.NOT. ALLOCATED(obj)) THEN + RETURN +END IF + +tsize = SIZE(obj) + +if(tsize .LE. 1) RETURN + + +CALL QUICKSORT(obj, 1_I4B, tsize) + +temp = obj +DEALLOCATE (obj) + +n = 1 +obj = [temp(1)] + +DO ii = 2, tsize + IF (temp(ii) .NE. temp(ii - 1)) THEN + CALL Expand(vec=obj, n=n, chunk_size=tsize, & + & val=temp(ii)) + END IF +END DO + +CALL Expand(vec=obj, n=n, chunk_size=tsize, finished=.TRUE.) + diff --git a/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc b/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc new file mode 100644 index 000000000..6c0d03e1f --- /dev/null +++ b/src/submodules/Utility/src/RemoveDuplicates/RemoveDuplicates_2.inc @@ -0,0 +1,24 @@ +! Define internal variables +INTEGER(I4B) :: ii, n + +tsize = SIZE(obj) +IF (tsize .LE. 1) RETURN + +IF (.NOT. isSorted) CALL QUICKSORT(obj, 1_I4B, tsize) + +DO CONCURRENT(ii=1:tsize) + temp(ii) = obj(ii) + obj(ii) = 0 +END DO + +obj(1) = temp(1) + +n = 1 +DO ii = 2, tsize + IF (temp(ii) .NE. temp(ii - 1)) THEN + n = n + 1 + obj(n) = temp(ii) + END IF +END DO + +tsize = n diff --git a/src/submodules/Utility/src/Repeat/Repeat_1.inc b/src/submodules/Utility/src/Repeat/Repeat_1.inc new file mode 100644 index 000000000..968e97111 --- /dev/null +++ b/src/submodules/Utility/src/Repeat/Repeat_1.inc @@ -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 +! + +INTEGER(I4B) :: n, i +n = SIZE(Val) +Ans(1:n) = Val +DO i = 1, rtimes - 1 + Ans(i * n + 1:(i + 1) * n) = Val +END DO diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_1.inc b/src/submodules/Utility/src/RowConcat/RowConcat_1.inc new file mode 100644 index 000000000..9e32ef339 --- /dev/null +++ b/src/submodules/Utility/src/RowConcat/RowConcat_1.inc @@ -0,0 +1,27 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: ncol, nrow + +nrow = 2 +ncol = MAX(SIZE(a), SIZE(b)) + +CALL reallocate(ans, nrow, ncol) + +ans(1, 1:SIZE(a)) = a + +ans(2, 1:SIZE(b)) = b diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_2.inc b/src/submodules/Utility/src/RowConcat/RowConcat_2.inc new file mode 100644 index 000000000..fe528ff1b --- /dev/null +++ b/src/submodules/Utility/src/RowConcat/RowConcat_2.inc @@ -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 +! + + INTEGER(I4B) :: nrow, ncol + + nrow = SIZE(a,1) + 1 + + ncol = MAX(SIZE(a,2), SIZE(b)) + + CALL reallocate(ans, nrow, ncol) + + ans(1:SIZE(a,1), 1:size(a,2) ) = a + + ans(nrow, 1:SIZE(b) ) = b diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_3.inc b/src/submodules/Utility/src/RowConcat/RowConcat_3.inc new file mode 100644 index 000000000..42461a24b --- /dev/null +++ b/src/submodules/Utility/src/RowConcat/RowConcat_3.inc @@ -0,0 +1,27 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: nrow, ncol + + nrow = SIZE(b,1) + 1 + ncol = MAX(SIZE(b,2), SIZE(a)) + + CALL reallocate(ans, nrow, ncol) + + ans(1, 1:SIZE(a)) = a + + ans(2:, 1:SIZE(b,2)) = b diff --git a/src/submodules/Utility/src/RowConcat/RowConcat_4.inc b/src/submodules/Utility/src/RowConcat/RowConcat_4.inc new file mode 100644 index 000000000..ac6f77a52 --- /dev/null +++ b/src/submodules/Utility/src/RowConcat/RowConcat_4.inc @@ -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 +! + + INTEGER(I4B) :: nrow, ncol + + ncol = MAX(SIZE(a, 2), SIZE(b, 2)) + + nrow = SIZE(a, 1) + SIZE(b, 1) + + CALL reallocate(ans, nrow, ncol) + + ans(1:SIZE(a, 1), 1:SIZE(a, 2)) = a + + ans(SIZE(a, 1) + 1:, 1:SIZE(b, 2)) = b diff --git a/src/submodules/Utility/src/SafeSizeUtility@Methods.F90 b/src/submodules/Utility/src/SafeSizeUtility@Methods.F90 new file mode 100644 index 000000000..287b6589f --- /dev/null +++ b/src/submodules/Utility/src/SafeSizeUtility@Methods.F90 @@ -0,0 +1,64 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(SafeSizeUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SafeSize +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SafeSize1 +ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) +END PROCEDURE SafeSize1 + +!---------------------------------------------------------------------------- +! SafeSize +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SafeSize2 +ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) +END PROCEDURE SafeSize2 + +!---------------------------------------------------------------------------- +! SafeSize +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SafeSize3 +ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) +END PROCEDURE SafeSize3 + +!---------------------------------------------------------------------------- +! SafeSize +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SafeSize4 +ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) +END PROCEDURE SafeSize4 + +!---------------------------------------------------------------------------- +! SafeSize +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SafeSize5 +ans = 0; IF (ALLOCATED(VALUE)) ans = SIZE(VALUE) +END PROCEDURE SafeSize5 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Sort/ArgSort.inc b/src/submodules/Utility/src/Sort/ArgSort.inc new file mode 100644 index 000000000..a9763bcde --- /dev/null +++ b/src/submodules/Utility/src/Sort/ArgSort.inc @@ -0,0 +1,35 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +CHARACTER(LEN=120) :: name0 + +IF (PRESENT(name)) THEN + name0 = UpperCase(name) +ELSE + name0 = "INTROSORT" +END IF + +ans = arange(1_I4B, SIZE(x, kind=I4B), 1_I4B) + +SELECT CASE (TRIM(name0)) +CASE ("HEAPSORT") + CALL ArgHeapSort(array=x, arg=ans) +CASE ("INTROSORT", "QUICKSORT") + CALL ArgIntroSort(array=x, arg=ans) +CASE ("INSERTION") + CALL ArgInsertionSort(array=x, arg=ans, low=1_I4B, high=SIZE(x, kind=I4B)) +END SELECT diff --git a/src/submodules/Utility/src/Sort/Sort.inc b/src/submodules/Utility/src/Sort/Sort.inc new file mode 100644 index 000000000..ef78bbfbd --- /dev/null +++ b/src/submodules/Utility/src/Sort/Sort.inc @@ -0,0 +1,37 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +CHARACTER(LEN=120) :: name0 + +IF (PRESENT(name)) THEN + name0 = UpperCase(name) +ELSE + name0 = "INTROSORT" +END IF + +ans = x + +SELECT CASE (TRIM(name0)) +CASE ("QUICKSORT") + CALL QuickSort(vect1=ans, low=1_I4B, high=SIZE(ans, kind=I4B)) +CASE ("HEAPSORT") + CALL HeapSort(array=ans) +CASE ("INTROSORT") + CALL IntroSort(array=ans) +CASE ("INSERTIONSORT") + CALL InsertionSort(array=ans, low=1_I4B, high=SIZE(ans, kind=I4B)) +END SELECT diff --git a/src/submodules/Utility/src/SortUtility@Methods.F90 b/src/submodules/Utility/src/SortUtility@Methods.F90 new file mode 100644 index 000000000..e4e198cf1 --- /dev/null +++ b/src/submodules/Utility/src/SortUtility@Methods.F90 @@ -0,0 +1,615 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: This submodule contains the sorting routine + +SUBMODULE(SortUtility) Methods +USE BaseMethod, ONLY: Swap, UpperCase, arange, Median, Partition, & +& ArgPartition, ArgMedian +IMPLICIT NONE + +INTEGER(I4B), PARAMETER :: minimumLengthForInsertion = 16 + +CONTAINS + +!---------------------------------------------------------------------------- +! IntroSort_Int8 +!---------------------------------------------------------------------------- + +#define _Recursive_IntroSort_ Recursive_IntroSort_Int8 +MODULE PROCEDURE IntroSort_Int8 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_IntroSort_(array, low, high, maxDepth) +END PROCEDURE IntroSort_Int8 +RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) + INTEGER(INT8), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_IntroSort.inc" +END SUBROUTINE _Recursive_IntroSort_ +#undef _Recursive_IntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Int16 +!---------------------------------------------------------------------------- + +#define _Recursive_IntroSort_ Recursive_IntroSort_Int16 +MODULE PROCEDURE IntroSort_Int16 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_IntroSort_(array, low, high, maxDepth) +END PROCEDURE IntroSort_Int16 +RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) + INTEGER(INT16), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_IntroSort.inc" +END SUBROUTINE _Recursive_IntroSort_ +#undef _Recursive_IntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Int32 +!---------------------------------------------------------------------------- + +#define _Recursive_IntroSort_ Recursive_IntroSort_Int32 +MODULE PROCEDURE IntroSort_Int32 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_IntroSort_(array, low, high, maxDepth) +END PROCEDURE IntroSort_Int32 +RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) + INTEGER(INT32), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_IntroSort.inc" +END SUBROUTINE _Recursive_IntroSort_ +#undef _Recursive_IntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Int8 +!---------------------------------------------------------------------------- + +#define _Recursive_IntroSort_ Recursive_IntroSort_Int64 +MODULE PROCEDURE IntroSort_Int64 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_IntroSort_(array, low, high, maxDepth) +END PROCEDURE IntroSort_Int64 +RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) + INTEGER(INT64), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_IntroSort.inc" +END SUBROUTINE _Recursive_IntroSort_ +#undef _Recursive_IntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Real32 +!---------------------------------------------------------------------------- + +#define _Recursive_IntroSort_ Recursive_IntroSort_Real32 +MODULE PROCEDURE IntroSort_Real32 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_IntroSort_(array, low, high, maxDepth) +END PROCEDURE IntroSort_Real32 +RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) + REAL(REAL32), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_IntroSort.inc" +END SUBROUTINE _Recursive_IntroSort_ +#undef _Recursive_IntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Real64 +!---------------------------------------------------------------------------- + +#define _Recursive_IntroSort_ Recursive_IntroSort_Real64 +MODULE PROCEDURE IntroSort_Real64 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_IntroSort_(array, low, high, maxDepth) +END PROCEDURE IntroSort_Real64 +RECURSIVE PURE SUBROUTINE _Recursive_IntroSort_(this, left, right, maxDepth) + REAL(REAL64), INTENT(INOUT) :: this(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_IntroSort.inc" +END SUBROUTINE _Recursive_IntroSort_ +#undef _Recursive_IntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Int8 +!---------------------------------------------------------------------------- + +#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int8 +MODULE PROCEDURE ArgIntroSort_Int8 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) +END PROCEDURE ArgIntroSort_Int8 +RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & + & left, right, maxDepth) + INTEGER(INT8), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: idx(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_ArgIntroSort.inc" +END SUBROUTINE _Recursive_ArgIntroSort_ +#undef _Recursive_ArgIntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Int16 +!---------------------------------------------------------------------------- + +#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int16 +MODULE PROCEDURE ArgIntroSort_Int16 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) +END PROCEDURE ArgIntroSort_Int16 +RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & + & left, right, maxDepth) + INTEGER(INT16), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: idx(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_ArgIntroSort.inc" +END SUBROUTINE _Recursive_ArgIntroSort_ +#undef _Recursive_ArgIntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Int32 +!---------------------------------------------------------------------------- + +#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int32 +MODULE PROCEDURE ArgIntroSort_Int32 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) +END PROCEDURE ArgIntroSort_Int32 +RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & + & left, right, maxDepth) + INTEGER(INT32), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: idx(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_ArgIntroSort.inc" +END SUBROUTINE _Recursive_ArgIntroSort_ +#undef _Recursive_ArgIntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Int64 +!---------------------------------------------------------------------------- + +#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Int64 +MODULE PROCEDURE ArgIntroSort_Int64 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) +END PROCEDURE ArgIntroSort_Int64 +RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & + & left, right, maxDepth) + INTEGER(INT64), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: idx(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_ArgIntroSort.inc" +END SUBROUTINE _Recursive_ArgIntroSort_ +#undef _Recursive_ArgIntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Real32 +!---------------------------------------------------------------------------- + +#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Real32 +MODULE PROCEDURE ArgIntroSort_Real32 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) +END PROCEDURE ArgIntroSort_Real32 +RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & + & left, right, maxDepth) + REAL(REAL32), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: idx(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_ArgIntroSort.inc" +END SUBROUTINE _Recursive_ArgIntroSort_ +#undef _Recursive_ArgIntroSort_ + +!---------------------------------------------------------------------------- +! IntroSort_Real32 +!---------------------------------------------------------------------------- + +#define _Recursive_ArgIntroSort_ Recursive_ArgIntroSort_Real64 +MODULE PROCEDURE ArgIntroSort_Real64 +INTEGER(I4B) :: low, high +INTEGER(I4B) :: maxDepth +low = 1 +high = SIZE(array) +maxDepth = 2 * idnint(LOG(DBLE(high))) +CALL _Recursive_ArgIntroSort_(array, arg, low, high, maxDepth) +END PROCEDURE ArgIntroSort_Real64 +RECURSIVE PURE SUBROUTINE _Recursive_ArgIntroSort_(this, idx, & + & left, right, maxDepth) + REAL(REAL64), INTENT(IN) :: this(:) + INTEGER(I4B), INTENT(INOUT) :: idx(:) + INTEGER(I4B), INTENT(IN) :: left, right, maxDepth + INTEGER(I4B) :: imid, iPivot, N +#include "./IntroSort/Recursive_ArgIntroSort.inc" +END SUBROUTINE _Recursive_ArgIntroSort_ +#undef _Recursive_ArgIntroSort_ + +!---------------------------------------------------------------------------- +! InsertionSort +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InsertionSort_Int8 +#include "./InsertionSort/InsertionSort.inc" +END PROCEDURE InsertionSort_Int8 + +MODULE PROCEDURE InsertionSort_Int16 +#include "./InsertionSort/InsertionSort.inc" +END PROCEDURE InsertionSort_Int16 + +MODULE PROCEDURE InsertionSort_Int32 +#include "./InsertionSort/InsertionSort.inc" +END PROCEDURE InsertionSort_Int32 + +MODULE PROCEDURE InsertionSort_Int64 +#include "./InsertionSort/InsertionSort.inc" +END PROCEDURE InsertionSort_Int64 + +MODULE PROCEDURE InsertionSort_Real32 +#include "./InsertionSort/InsertionSort.inc" +END PROCEDURE InsertionSort_Real32 + +MODULE PROCEDURE InsertionSort_Real64 +#include "./InsertionSort/InsertionSort.inc" +END PROCEDURE InsertionSort_Real64 + +!---------------------------------------------------------------------------- +! ArgInsertionSort +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgInsertionSort_Int8 +#include "./InsertionSort/ArgInsertionSort.inc" +END PROCEDURE ArgInsertionSort_Int8 + +MODULE PROCEDURE ArgInsertionSort_Int16 +#include "./InsertionSort/ArgInsertionSort.inc" +END PROCEDURE ArgInsertionSort_Int16 + +MODULE PROCEDURE ArgInsertionSort_Int32 +#include "./InsertionSort/ArgInsertionSort.inc" +END PROCEDURE ArgInsertionSort_Int32 + +MODULE PROCEDURE ArgInsertionSort_Int64 +#include "./InsertionSort/ArgInsertionSort.inc" +END PROCEDURE ArgInsertionSort_Int64 + +MODULE PROCEDURE ArgInsertionSort_Real32 +#include "./InsertionSort/ArgInsertionSort.inc" +END PROCEDURE ArgInsertionSort_Real32 + +MODULE PROCEDURE ArgInsertionSort_Real64 +#include "./InsertionSort/ArgInsertionSort.inc" +END PROCEDURE ArgInsertionSort_Real64 + +!---------------------------------------------------------------------------- +! HeapSort +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeapSort_Int8 +INTEGER(INT8) :: t +#include "./HeapSort/HeapSort.inc" +END PROCEDURE HeapSort_Int8 + +MODULE PROCEDURE HeapSort_Int16 +INTEGER(INT16) :: t +#include "./HeapSort/HeapSort.inc" +END PROCEDURE HeapSort_Int16 + +MODULE PROCEDURE HeapSort_Int32 +INTEGER(INT32) :: t +#include "./HeapSort/HeapSort.inc" +END PROCEDURE HeapSort_Int32 + +MODULE PROCEDURE HeapSort_Int64 +INTEGER(INT64) :: t +#include "./HeapSort/HeapSort.inc" +END PROCEDURE HeapSort_Int64 + +MODULE PROCEDURE HeapSort_Real32 +REAL(REAL32) :: t +#include "./HeapSort/HeapSort.inc" +END PROCEDURE HeapSort_Real32 + +MODULE PROCEDURE HeapSort_Real64 +REAL(REAL64) :: t +#include "./HeapSort/HeapSort.inc" +END PROCEDURE HeapSort_Real64 + +!---------------------------------------------------------------------------- +! ArgHeapSort +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgHeapSort_Int8 +#include "./HeapSort/ArgHeapSort.inc" +END PROCEDURE ArgHeapSort_Int8 + +MODULE PROCEDURE ArgHeapSort_Int16 +#include "./HeapSort/ArgHeapSort.inc" +END PROCEDURE ArgHeapSort_Int16 + +MODULE PROCEDURE ArgHeapSort_Int32 +#include "./HeapSort/ArgHeapSort.inc" +END PROCEDURE ArgHeapSort_Int32 + +MODULE PROCEDURE ArgHeapSort_Int64 +#include "./HeapSort/ArgHeapSort.inc" +END PROCEDURE ArgHeapSort_Int64 + +MODULE PROCEDURE ArgHeapSort_Real32 +#include "./HeapSort/ArgHeapSort.inc" +END PROCEDURE ArgHeapSort_Real32 + +MODULE PROCEDURE ArgHeapSort_Real64 +#include "./HeapSort/ArgHeapSort.inc" +END PROCEDURE ArgHeapSort_Real64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuickSort1vectReal32 +#include "./QuickSort/QuickSort1Vec.inc" +END PROCEDURE QuickSort1vectReal32 + +MODULE PROCEDURE QuickSort1vectReal64 +#include "./QuickSort/QuickSort1Vec.inc" +END PROCEDURE QuickSort1vectReal64 + +MODULE PROCEDURE QuickSort1vectInt8 +#include "./QuickSort/QuickSort1Vec.inc" +END PROCEDURE QuickSort1vectInt8 + +MODULE PROCEDURE QuickSort1vectInt16 +#include "./QuickSort/QuickSort1Vec.inc" +END PROCEDURE QuickSort1vectInt16 + +MODULE PROCEDURE QuickSort1vectInt32 +#include "./QuickSort/QuickSort1Vec.inc" +END PROCEDURE QuickSort1vectInt32 + +MODULE PROCEDURE QuickSort1vectInt64 +#include "./QuickSort/QuickSort1Vec.inc" +END PROCEDURE QuickSort1vectInt64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuickSort2vectIR +#include "./QuickSort/QuickSort2Vec.inc" +END PROCEDURE QuickSort2vectIR + +MODULE PROCEDURE QuickSort2vectII +#include "./QuickSort/QuickSort2Vec.inc" +END PROCEDURE QuickSort2vectII + +MODULE PROCEDURE QuickSort2vectRI +#include "./QuickSort/QuickSort2Vec.inc" +END PROCEDURE QuickSort2vectRI + +MODULE PROCEDURE QuickSort2vectRR +#include "./QuickSort/QuickSort2Vec.inc" +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuickSort3vectIII +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE QuickSort3vectIII + +MODULE PROCEDURE QuickSort3vectIIR +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort3vectIRR +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort3vectIRI +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort3vectRRR +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort3vectRRI +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort3vectRIR +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort3vectRII +#include "./QuickSort/QuickSort3Vec.inc" +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuickSort4vectIIII +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectIIIR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectIIRI +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectIIRR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectIRRR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectIRRI +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectIRIR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectIRII +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRRRR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRRRI +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRRIR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRRII +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRIRR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRIRI +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRIIR +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +MODULE PROCEDURE QuickSort4vectRIII +#include "./QuickSort/QuickSort4Vec.inc" +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Sort_Int8 +#include "./Sort/Sort.inc" +END PROCEDURE Sort_Int8 +MODULE PROCEDURE Sort_Int16 +#include "./Sort/Sort.inc" +END PROCEDURE Sort_Int16 +MODULE PROCEDURE Sort_Int32 +#include "./Sort/Sort.inc" +END PROCEDURE Sort_Int32 +MODULE PROCEDURE Sort_Int64 +#include "./Sort/Sort.inc" +END PROCEDURE Sort_Int64 +MODULE PROCEDURE Sort_Real32 +#include "./Sort/Sort.inc" +END PROCEDURE Sort_Real32 +MODULE PROCEDURE Sort_Real64 +#include "./Sort/Sort.inc" +END PROCEDURE Sort_Real64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ArgSort_Int8 +#include "./Sort/ArgSort.inc" +END PROCEDURE ArgSort_Int8 +MODULE PROCEDURE ArgSort_Int16 +#include "./Sort/ArgSort.inc" +END PROCEDURE ArgSort_Int16 +MODULE PROCEDURE ArgSort_Int32 +#include "./Sort/ArgSort.inc" +END PROCEDURE ArgSort_Int32 +MODULE PROCEDURE ArgSort_Int64 +#include "./Sort/ArgSort.inc" +END PROCEDURE ArgSort_Int64 +MODULE PROCEDURE ArgSort_Real32 +#include "./Sort/ArgSort.inc" +END PROCEDURE ArgSort_Real32 +MODULE PROCEDURE ArgSort_Real64 +#include "./Sort/ArgSort.inc" +END PROCEDURE ArgSort_Real64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/SplitUtility@Methods.F90 b/src/submodules/Utility/src/SplitUtility@Methods.F90 new file mode 100644 index 000000000..bab5645f5 --- /dev/null +++ b/src/submodules/Utility/src/SplitUtility@Methods.F90 @@ -0,0 +1,93 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(SplitUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SPLIT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE split_Int8 +IF (section == 1) THEN + Ans = x(1:SIZE(x) / 2) +ELSEIF (section == 2) THEN + Ans = x(SIZE(x) / 2 + 1:) +END IF +END PROCEDURE split_Int8 + +MODULE PROCEDURE split_Int16 +IF (section == 1) THEN + Ans = x(1:SIZE(x) / 2) +ELSEIF (section == 2) THEN + Ans = x(SIZE(x) / 2 + 1:) +END IF +END PROCEDURE split_Int16 + +MODULE PROCEDURE split_Int32 +IF (section == 1) THEN + Ans = x(1:SIZE(x) / 2) +ELSEIF (section == 2) THEN + Ans = x(SIZE(x) / 2 + 1:) +END IF +END PROCEDURE split_Int32 + +MODULE PROCEDURE split_Int64 +IF (section == 1) THEN + Ans = x(1:SIZE(x) / 2) +ELSEIF (section == 2) THEN + Ans = x(SIZE(x) / 2 + 1:) +END IF +END PROCEDURE split_Int64 + +!---------------------------------------------------------------------------- +! SPLIT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE split_Real32 +IF (section == 1) THEN + Ans = x(1:SIZE(x) / 2) +ELSEIF (section == 2) THEN + Ans = x(SIZE(x) / 2 + 1:) +END IF +END PROCEDURE split_Real32 + +MODULE PROCEDURE split_Real64 +IF (section == 1) THEN + Ans = x(1:SIZE(x) / 2) +ELSEIF (section == 2) THEN + Ans = x(SIZE(x) / 2 + 1:) +END IF +END PROCEDURE split_Real64 + +!---------------------------------------------------------------------------- +! SPLIT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE split_char +IF (section == 1) THEN + Ans = x(1:LEN(x) / 2) +ELSE IF (section == 2) THEN + Ans = x(LEN(x) / 2 + 1:) +ELSE + Ans = '' +END IF +END PROCEDURE split_char + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/StringUtility@Methods.F90 b/src/submodules/Utility/src/StringUtility@Methods.F90 new file mode 100644 index 000000000..4906fb4fe --- /dev/null +++ b/src/submodules/Utility/src/StringUtility@Methods.F90 @@ -0,0 +1,547 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(StringUtility) Methods +USE GlobalData, ONLY: CHAR_BSLASH, CHAR_DOT, CHAR_FSLASH, CHAR_SLASH + +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_END + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! PathDir +!---------------------------------------------------------------------------- + +MODULE PROCEDURE PathDir +INTEGER(I4B) :: tsize, last +INTEGER(I4B), ALLOCATABLE :: indices(:) + +ans = TRIM(path) +tsize = LEN(ans) +IF (tsize .EQ. 0) THEN + ans = "." + RETURN +END IF + +IF ((tsize .EQ. 1)) THEN + IF (ans(1:1) .NE. CHAR_SLASH) THEN + ans = "." + END IF + RETURN +END IF + +last = tsize +DO + IF (ans(last:last) .EQ. CHAR_SLASH) THEN + last = last - 1 + ans = ans(1:last) + ELSE + EXIT + END IF + + IF (last .EQ. 1) EXIT +END DO + +IF (last .EQ. 1) RETURN + +tsize = LEN(ans) + +CALL StrFind(chars=ans, pattern=CHAR_SLASH, indices=indices) + +! It means no / found in the path +IF (SIZE(indices) .EQ. 0) THEN + ans = "." + DEALLOCATE (indices) + RETURN +END IF + +last = indices(SIZE(indices)) - 1 + +! /abc type pattern +IF (last .EQ. 0) THEN + ans = "/" + DEALLOCATE (indices) + RETURN +END IF + +ans = ans(1:last) +DEALLOCATE (indices) + +DO + IF (last .EQ. 1) EXIT + IF (ans(last:last) .EQ. CHAR_SLASH) THEN + last = last - 1 + ans = ans(1:last) + ELSE + EXIT + END IF + +END DO + +END PROCEDURE PathDir + +!---------------------------------------------------------------------------- +! PathBase +!---------------------------------------------------------------------------- + +MODULE PROCEDURE PathBase +INTEGER(I4B) :: tsize, last +INTEGER(I4B), ALLOCATABLE :: indices(:) + +ans = TRIM(path) + +tsize = LEN(ans) + +IF (tsize .EQ. 0) THEN + ans = "." + RETURN +END IF + +IF ((tsize .EQ. 1)) RETURN + +last = tsize +DO + IF (ans(last:last) .EQ. CHAR_SLASH) THEN + last = last - 1 + ans = ans(1:last) + ELSE + EXIT + END IF + + IF (last .EQ. 1) EXIT +END DO + +IF (last .EQ. 1) RETURN + +tsize = LEN(ans) + +CALL StrFind(chars=ans, pattern=CHAR_SLASH, indices=indices) +IF (SIZE(indices) .EQ. 0) THEN + last = 1 +ELSE + last = indices(SIZE(indices)) + 1 +END IF + +ans = ans(last:tsize) +IF (ALLOCATED(indices)) DEALLOCATE (indices) +END PROCEDURE PathBase + +!---------------------------------------------------------------------------- +! PathJoin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE PathJoin1 +ans = TRIM(path1)//CHAR_SLASH//TRIM(path2) +END PROCEDURE PathJoin1 + +!---------------------------------------------------------------------------- +! PathJoin +!---------------------------------------------------------------------------- + +MODULE PROCEDURE PathJoin2 +INTEGER(I4B) :: tsize, ii + +tsize = SIZE(paths) +ans = "" + +DO ii = 1, tsize + ans = ans//CHAR_SLASH//paths(ii)%chars() +END DO + +END PROCEDURE PathJoin2 + +!---------------------------------------------------------------------------- +! UpperCase +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UpperCase_Char +ans = chars +CALL ToUpperCase_Char(ans) +END PROCEDURE UpperCase_Char + +!---------------------------------------------------------------------------- +! ToUpperCase +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ToUpperCase_Char +INTEGER(I4B) :: i, diff +CHARACTER(1) :: c + +diff = ICHAR('A') - ICHAR('a') +DO i = 1, LEN(chars) + c = chars(i:i) + IF (ICHAR(c) .GE. ICHAR('a') .AND. ICHAR(c) <= ICHAR('z')) THEN + chars(i:i) = CHAR(ICHAR(c) + diff) + END IF +END DO +END PROCEDURE ToUpperCase_Char + +!---------------------------------------------------------------------------- +! LowerCase +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LowerCase_Char +ans = chars +CALL ToLowerCase_Char(ans) +END PROCEDURE LowerCase_Char + +!---------------------------------------------------------------------------- +! ToLowerCase +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ToLowerCase_Char +INTEGER(I4B) :: i, diff +CHARACTER(1) :: c +!> +diff = ICHAR('A') - ICHAR('a') +DO i = 1, LEN(chars) + c = chars(i:i) + IF (ICHAR(c) .GE. ICHAR('A') .AND. ICHAR(c) .LE. ICHAR('Z')) THEN + chars(i:i) = CHAR(ICHAR(c) - diff) + END IF +END DO +END PROCEDURE ToLowerCase_Char + +!---------------------------------------------------------------------------- +! isWhiteChar +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isWhiteChar_char +INTEGER(I4B) :: ia +ia = IACHAR(char) +IF (ia .EQ. 32 .OR. ia .EQ. 9) THEN + ans = .TRUE. +ELSE + ans = .FALSE. +END IF +END PROCEDURE isWhiteChar_char + +!---------------------------------------------------------------------------- +! isBlank +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isBlank_chars +INTEGER(I4B) :: i, j +j = 0 +ans = .TRUE. +DO i = 1, LEN(chars) + IF (.NOT. isWhiteChar(chars(i:i))) THEN + ans = .FALSE. + EXIT + END IF +END DO +END PROCEDURE isBlank_chars + +!---------------------------------------------------------------------------- +! numMatchStr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE numMatchStr_chars +INTEGER(I4B) :: i +ans = 0 +DO i = 1, LEN(chars) + IF (i + LEN(pattern) - 1 > LEN(chars)) EXIT + IF (chars(i:i + LEN(pattern) - 1) == pattern) ans = ans + 1 +END DO +END PROCEDURE numMatchStr_chars + +!---------------------------------------------------------------------------- +! numStrings +!---------------------------------------------------------------------------- + +MODULE PROCEDURE numStrings_chars +INTEGER(I4B) :: i, multidcol, n, ncol, nmult, ioerr +LOGICAL(LGT) :: nonblankd, nonblank, multidata, inQuotes + +!Check for single-quoted strings, if the number of single quotes is odd +!then return with a value of -1 to signal an error +IF (MOD(numMatchStr(TRIM(chars), "'"), 2) /= 0) THEN + ans = -1 + RETURN +END IF + +!Check for double-quoted strings, if the number of double quotes is odd +!then return with a value of -2 to signal an error +IF (MOD(numMatchStr(TRIM(chars), '"'), 2) /= 0) THEN + ans = -2 + RETURN +END IF + +nonblankd = .FALSE. +multidata = .FALSE. +inQuotes = .FALSE. +ncol = LEN_TRIM(chars) +IF (ncol > 2) THEN + ans = 1 +ELSE + ans = 0 +END IF + +n = 0 +DO i = ncol, 1, -1 + IF (chars(i:i) == "'" .OR. chars(i:i) == '"') THEN + IF (inQuotes) THEN + inQuotes = .FALSE. + n = n + 2 + CYCLE + ELSE + inQuotes = .TRUE. + END IF + END IF + !Process the spaces and multiplier characters if not in a quoted string + IF (.NOT. inQuotes) THEN + IF (chars(i:i) == ' ' .OR. ICHAR(chars(i:i)) == 9) THEN !ichar(tab)=9 + nonblank = .FALSE. + ELSE + IF (chars(i:i) == '*') THEN + multidata = .TRUE. + multidcol = i + END IF + nonblank = .TRUE. + END IF + IF ((.NOT. nonblankd .AND. nonblank) .OR. & + (nonblankd .AND. .NOT. nonblank)) THEN + n = n + 1 + END IF + IF (multidata .AND. (nonblankd .AND. .NOT. nonblank)) THEN + !ioerr will be non-zero if the sub-string is not an integer + READ (chars(i + 1:multidcol - 1), *, IOSTAT=ioerr) nmult + IF (ioerr /= 0) nmult = 1 + n = n + (nmult - 1) * 2 + + !If we are multiplying a quoted string need to subtract 1. + IF (multidcol < ncol) THEN + IF (chars(multidcol + 1:multidcol + 1) == '"' .OR. & + chars(multidcol + 1:multidcol + 1) == "'") & + n = n - 1 + END IF + + multidata = .FALSE. + END IF + nonblankd = nonblank + END IF +END DO +IF (MOD(n, 2) /= 0) THEN + ans = n / 2 + 1 +ELSE + ans = n / 2 +END IF +END PROCEDURE numStrings_chars + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE isPresent_chars +ans = MERGE(INDEX(chars, pattern) > 0, .FALSE., & + & (LEN(pattern) > 0 .AND. LEN(chars) > 0)) +END PROCEDURE isPresent_chars + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE strFind_chars +INTEGER(I4B) :: i, n +n = 0 +ALLOCATE (indices(numMatchStr(chars, pattern))) +DO i = 1, LEN(chars) + IF (i + LEN(pattern) - 1 > LEN(chars)) EXIT + IF (chars(i:i + LEN(pattern) - 1) == pattern) THEN + n = n + 1 + indices(n) = i + END IF +END DO +END PROCEDURE strFind_chars + +!---------------------------------------------------------------------------- +! FindReplace +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FindReplace_chars +CHARACTER(LEN(chars)) :: string2 +INTEGER(I4B), ALLOCATABLE :: indices(:) +INTEGER(I4B) :: i, n, stt, stp, dlen, slen, rlen, flen, tlen +!> +slen = LEN(chars) +tlen = LEN_TRIM(chars) +rlen = LEN(repp) +flen = LEN(findp) +dlen = rlen - flen +string2 = chars +n = numMatchStr(chars, findp) +CALL strfind(chars, findp, indices) +IF (slen >= tlen + n * dlen) THEN + DO i = 1, n + stt = indices(i) + stp = stt + rlen - 1 + chars(stt:stp) = repp + chars(stp + 1:slen) = string2(stt + flen - (i - 1) * dlen:slen) + IF (i < n) indices(i + 1) = indices(i + 1) + dlen * i + END DO +END IF +DEALLOCATE (indices) +END PROCEDURE FindReplace_chars + +!---------------------------------------------------------------------------- +! getField +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getField_chars +INTEGER(I4B) :: j, ioerr, nf +CHARACTER(LEN(chars)) :: temp, temp2 + +temp = chars +temp2 = '' +nf = numStrings(temp) +IF (0 < i .AND. i <= nf) THEN + !The fortran READ(*,*) parses at the '/' character + !we don't want this to occur. We only want it to parse for '*' + !and ' ' characters. So if slashes are present we treat things + !differently. + IF (isPresent(temp, CHAR_FSLASH)) THEN + !Temporarily change the CHAR_FSLASH character to a BSLASH character + !to get correct parsing behavior + CALL FindReplace(temp, CHAR_FSLASH, CHAR_BSLASH) + READ (temp, *, IOSTAT=ioerr) (temp2, j=1, i) + CALL FindReplace(temp, CHAR_BSLASH, CHAR_FSLASH) + CALL FindReplace(temp2, CHAR_BSLASH, CHAR_FSLASH) + ELSE + READ (temp, *, IOSTAT=ioerr) (temp2, j=1, i) + END IF + field = TRIM(temp2) + IF (PRESENT(ierr)) ierr = ioerr +ELSE + IF (PRESENT(ierr)) ierr = IOSTAT_END +END IF +END PROCEDURE getField_chars + +!---------------------------------------------------------------------------- +! SlashRep +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SlashRep_chars +INTEGER(I4B) :: i +DO i = 1, LEN_TRIM(chars) +#ifdef WIN32 + IF (chars(i:i) == CHAR_FSLASH) chars(i:i) = CHAR_SLASH +#else + IF (chars(i:i) == CHAR_BSLASH) chars(i:i) = CHAR_SLASH +#endif +END DO +END PROCEDURE SlashRep_chars + +!---------------------------------------------------------------------------- +! getFileParts +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getFileParts_chars +INTEGER(I4B) :: i +CALL getPath_chars(chars, path) +CALL getFileName_chars(chars, fname) +DO i = LEN_TRIM(fname), 1, -1 + IF (fname(i:i) .EQ. CHAR_DOT) THEN + fname = fname(1:i - 1) + EXIT + END IF +END DO +CALL getFileNameExt_chars(chars, ext) +END PROCEDURE getFileParts_chars + +!---------------------------------------------------------------------------- +! getPath +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getPath_chars +CHARACTER(LEN(chars)) :: chars2 +INTEGER(I4B) :: i +!> +chars2 = chars +CALL SlashRep(chars2) +path = '' +DO i = LEN_TRIM(chars2), 1, -1 + IF (chars2(i:i) .EQ. CHAR_SLASH) THEN + path = chars2(1:i) + EXIT + END IF +END DO +END PROCEDURE getPath_chars + +!---------------------------------------------------------------------------- +! getExtension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getExtension_chars +! Define internal variables +INTEGER(I4B) :: n, m +n = 0 +n = INDEX(char, ".", back=.TRUE.) +IF (n .EQ. 0) THEN + ext = "" +ELSE + m = LEN(char) + ext = CHAR(n + 1:m) +END IF +END PROCEDURE getExtension_chars + +!---------------------------------------------------------------------------- +! getFileName +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getFileName_chars +CHARACTER(LEN(chars)) :: chars2 +INTEGER(I4B) :: i +chars2 = chars +CALL SlashRep(chars2) +fname = chars +DO i = LEN_TRIM(chars2), 1, -1 + IF (chars2(i:i) .EQ. CHAR_SLASH) THEN + fname = chars2(i + 1:LEN_TRIM(chars2)) + EXIT + END IF +END DO +END PROCEDURE getFileName_chars + +!---------------------------------------------------------------------------- +! getFileNameExt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getFileNameExt_chars +CHARACTER(:), ALLOCATABLE :: chars2 +INTEGER(I4B) :: i, SLASHloc + +chars2 = TRIM(chars) +CALL SlashRep(chars2) +ext = '' +SLASHloc = 1 +DO i = LEN_TRIM(chars2), 1, -1 + IF (chars2(i:i) == CHAR_SLASH) THEN + SLASHloc = i + EXIT + END IF +END DO +DO i = LEN_TRIM(chars2), SLASHloc, -1 + IF (chars2(i:i) == CHAR_DOT) THEN + ext = chars2(i:LEN_TRIM(chars2)) + EXIT + END IF +END DO +END PROCEDURE getFileNameExt_chars + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/SwapUtility@Methods.F90 b/src/submodules/Utility/src/SwapUtility@Methods.F90 new file mode 100644 index 000000000..c891eb817 --- /dev/null +++ b/src/submodules/Utility/src/SwapUtility@Methods.F90 @@ -0,0 +1,817 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 22 March 2021 +! summary: This submodule contains method for swaping + +SUBMODULE(SwapUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int8 +INTEGER(INT8) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int8 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int16 +INTEGER(INT16) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int16 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int32 +INTEGER(INT32) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int32 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int64 +INTEGER(INT64) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int64 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_r32 +REAL(REAL32) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_r32 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_r64 +REAL(REAL64) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_r64 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +#ifndef USE_BLAS95 +MODULE PROCEDURE swap_r32v +REAL(REAL32), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_r32v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_r64v +REAL(REAL64), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_r64v +#endif + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int8v +INTEGER(INT8), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int8v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int16v +INTEGER(INT16), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int16v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int32v +INTEGER(INT32), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int32v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int64v +INTEGER(INT64), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int64v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE swap_Int128v +INTEGER(Int128), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int128v +#endif + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_c +COMPLEX(DFPC) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_c + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +#ifndef USE_BLAS95 +MODULE PROCEDURE swap_cv +COMPLEX(DFPC), DIMENSION(SIZE(a)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_cv +#endif + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_cm +COMPLEX(DFPC), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_cm + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_r32m +REAL(REAL32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_r32m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_r64m +REAL(REAL64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_r64m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int8m +INTEGER(INT8), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int8m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int16m +INTEGER(INT16), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int16m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int32m +INTEGER(INT32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int32m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_Int64m +INTEGER(INT64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int64m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE swap_Int128m +INTEGER(Int128), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum +dum = a +a = b +b = dum +END PROCEDURE swap_Int128m +#endif + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_r32s +REAL(REAL32) :: swp +IF (mask) THEN + swp = a + a = b + b = swp +END IF +END PROCEDURE masked_swap_r32s + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_r64s +REAL(REAL64) :: swp +IF (mask) THEN + swp = a + a = b + b = swp +END IF +END PROCEDURE masked_swap_r64s + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int8s +INTEGER(INT8) :: swp +IF (mask) THEN + swp = a + a = b + b = swp +END IF +END PROCEDURE masked_swap_Int8s + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int16s +INTEGER(INT16) :: swp +IF (mask) THEN + swp = a + a = b + b = swp +END IF +END PROCEDURE masked_swap_Int16s + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int32s +INTEGER(INT32) :: swp +IF (mask) THEN + swp = a + a = b + b = swp +END IF +END PROCEDURE masked_swap_Int32s + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int64s +INTEGER(INT64) :: swp +IF (mask) THEN + swp = a + a = b + b = swp +END IF +END PROCEDURE masked_swap_Int64s + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE masked_swap_Int128s +INTEGER(Int128) :: swp +IF (mask) THEN + swp = a + a = b + b = swp +END IF +END PROCEDURE masked_swap_Int128s +#endif + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_r32v +REAL(REAL32), DIMENSION(SIZE(a)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_r32v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_r64v +REAL(REAL64), DIMENSION(SIZE(a)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_r64v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int8v +INTEGER(INT8), DIMENSION(SIZE(a)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int8v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int16v +INTEGER(INT16), DIMENSION(SIZE(a)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int16v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int32v +INTEGER(INT32), DIMENSION(SIZE(a)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int32v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int64v +INTEGER(INT64), DIMENSION(SIZE(a)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int64v + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE masked_swap_Int128v +INTEGER(Int128), DIMENSION(SIZE(a)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int128v +#endif + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_r32m +REAL(REAL32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_r32m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_r64m +REAL(REAL64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_r64m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int8m +INTEGER(INT8), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int8m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int16m +INTEGER(INT16), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int16m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int32m +INTEGER(INT32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int32m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE masked_swap_Int64m +INTEGER(INT64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int64m + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE masked_swap_Int128m +INTEGER(Int128), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: swp +WHERE (mask) + swp = a + a = b + b = swp +END WHERE +END PROCEDURE masked_swap_Int128m +#endif + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index1 +INTEGER(I4B) :: IJ(2), s(2), i, j +!! main +IF (ANY([i1, i2] .GT. 2) .OR. ANY([i1, i2] .LE. 0) .OR. i1 .EQ. i2) THEN + s = SHAPE(b) + CALL Reallocate(a, s(1), s(2)) + a = b +ELSE + s = SHAPE(b) + CALL Reallocate(a, s(i1), s(i2)) + DO j = 1, s(2) + DO i = 1, s(1) + ij = [i, j] + a(ij(i1), ij(i2)) = b(i, j) + END DO + END DO +END IF +END PROCEDURE swap_index1 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index_1 +INTEGER(I4B) :: ij(2), s(2), i, j +!! main +s = SHAPE(b) +DO j = 1, s(2) + DO i = 1, s(1) + ij(1) = i; ij(2) = j + a(ij(i1), ij(i2)) = b(i, j) + END DO +END DO +END PROCEDURE swap_index_1 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index_2 +INTEGER(I4B) :: ij(2), s(2), i, j +!! main +s = SHAPE(b) +DO j = 1, s(2) + DO i = 1, s(1) + ij(1) = i; ij(2) = j + a(ij(i1), ij(i2)) = b(i, j) + END DO +END DO +END PROCEDURE swap_index_2 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index2 +INTEGER(I4B) :: IJ(2), s(2), i, j +!! main +IF (ANY([i1, i2] .GT. 2) .OR. ANY([i1, i2] .LE. 0) .OR. i1 .EQ. i2) THEN + s = SHAPE(b) + CALL Reallocate(a, s(1), s(2)) + a = b +ELSE + s = SHAPE(b) + CALL Reallocate(a, s(i1), s(i2)) + DO j = 1, s(2) + DO i = 1, s(1) + ij = [i, j] + a(ij(i1), ij(i2)) = b(i, j) + END DO + END DO +END IF +END PROCEDURE swap_index2 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index3 +INTEGER(I4B) :: ijk(3), s(3), i, j, k +!! main +IF (ANY([i1, i2, i3] .GT. 3) .OR. ANY([i1, i2, i3] .LE. 0)) THEN + s = SHAPE(b) + CALL Reallocate(a, s(1), s(2), s(3)) + a = b +ELSE + s = SHAPE(b) + CALL Reallocate(a, s(i1), s(i2), s(i3)) + DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + ijk = [i, j, k] + a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) + END DO + END DO + END DO +END IF +END PROCEDURE swap_index3 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index4 +INTEGER(I4B) :: ijk(3), s(3), i, j, k +!! main +IF (ANY([i1, i2, i3] .GT. 3) .OR. ANY([i1, i2, i3] .LE. 0)) THEN + s = SHAPE(b) + CALL Reallocate(a, s(1), s(2), s(3)) + a = b +ELSE + s = SHAPE(b) + CALL Reallocate(a, s(i1), s(i2), s(i3)) + DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + ijk = [i, j, k] + a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) + END DO + END DO + END DO +END IF +END PROCEDURE swap_index4 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index_3 +INTEGER(I4B) :: ijk(3), s(3), i, j, k +!! main +s = SHAPE(b) +DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + ijk = [i, j, k] + a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) + END DO + END DO +END DO +END PROCEDURE swap_index_3 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index_4 +INTEGER(I4B) :: ijk(3), s(3), i, j, k +!! main +s = SHAPE(b) +DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + ijk = [i, j, k] + a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k) + END DO + END DO +END DO +END PROCEDURE swap_index_4 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index5 +INTEGER(I4B) :: indx(4), s(4), i, j, k, l +!! main +s = SHAPE(b) +CALL Reallocate(a, s(i1), s(i2), s(i3), s(i4)) +DO l = 1, s(4) + DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + indx = [i, j, k, l] + a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) + END DO + END DO + END DO +END DO +END PROCEDURE swap_index5 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index6 +INTEGER(I4B) :: indx(4), s(4), i, j, k, l +!! main +s = SHAPE(b) +CALL Reallocate(a, s(i1), s(i2), s(i3), s(i4)) +DO l = 1, s(4) + DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + indx = [i, j, k, l] + a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) + END DO + END DO + END DO +END DO +END PROCEDURE swap_index6 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index_5 +INTEGER(I4B) :: indx(4), s(4), i, j, k, l +!! main +s = SHAPE(b) +DO l = 1, s(4) + DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + indx = [i, j, k, l] + a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) + END DO + END DO + END DO +END DO +END PROCEDURE swap_index_5 + +!---------------------------------------------------------------------------- +! SWAP +!---------------------------------------------------------------------------- + +MODULE PROCEDURE swap_index_6 +INTEGER(I4B) :: indx(4), s(4), i, j, k, l +!! main +s = SHAPE(b) +DO l = 1, s(4) + DO k = 1, s(3) + DO j = 1, s(2) + DO i = 1, s(1) + indx = [i, j, k, l] + a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l) + END DO + END DO + END DO +END DO +END PROCEDURE swap_index_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Sym/GetSym.inc b/src/submodules/Utility/src/Sym/GetSym.inc new file mode 100644 index 000000000..9dd641a01 --- /dev/null +++ b/src/submodules/Utility/src/Sym/GetSym.inc @@ -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 +! + +INTEGER(I4B) :: ii, jj +SELECT CASE (from) +CASE ("L", "l") + DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) + IF (ii .GE. jj) mat(jj, ii) = mat(ii, jj) + END DO +CASE ("u", "U") + DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) + IF (ii .GE. jj) mat(ii, jj) = mat(jj, ii) + END DO +END SELECT diff --git a/src/submodules/Utility/src/Sym/Sym.inc b/src/submodules/Utility/src/Sym/Sym.inc new file mode 100644 index 000000000..5404c877b --- /dev/null +++ b/src/submodules/Utility/src/Sym/Sym.inc @@ -0,0 +1,36 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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) :: ii, jj +SELECT CASE (from) +CASE ("L", "l") + DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) + IF (ii .GE. jj) THEN + ans(jj, ii) = mat(ii, jj) + ELSE + ans(jj, ii) = mat(jj, ii) + END IF + END DO +CASE ("u", "U") + DO CONCURRENT(ii=1:SIZE(mat, 1), jj=1:SIZE(mat, 2)) + IF (ii .GE. jj) THEN + ans(ii, jj) = mat(jj, ii) + ELSE + ans(ii, jj) = mat(ii, jj) + END IF + END DO +END SELECT diff --git a/src/submodules/Utility/src/SymUtility@Methods.F90 b/src/submodules/Utility/src/SymUtility@Methods.F90 new file mode 100644 index 000000000..ba817fb04 --- /dev/null +++ b/src/submodules/Utility/src/SymUtility@Methods.F90 @@ -0,0 +1,78 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(SymUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Sym_Int8 +#include "./Sym/Sym.inc" +END PROCEDURE Sym_Int8 + +MODULE PROCEDURE Sym_Int16 +#include "./Sym/Sym.inc" +END PROCEDURE Sym_Int16 + +MODULE PROCEDURE Sym_Int32 +#include "./Sym/Sym.inc" +END PROCEDURE Sym_Int32 + +MODULE PROCEDURE Sym_Int64 +#include "./Sym/Sym.inc" +END PROCEDURE Sym_Int64 + +MODULE PROCEDURE Sym_Real32 +#include "./Sym/Sym.inc" +END PROCEDURE Sym_Real32 + +MODULE PROCEDURE Sym_Real64 +#include "./Sym/Sym.inc" +END PROCEDURE Sym_Real64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetSym_Int8 +#include "./Sym/GetSym.inc" +END PROCEDURE GetSym_Int8 + +MODULE PROCEDURE GetSym_Int16 +#include "./Sym/GetSym.inc" +END PROCEDURE GetSym_Int16 + +MODULE PROCEDURE GetSym_Int32 +#include "./Sym/GetSym.inc" +END PROCEDURE GetSym_Int32 + +MODULE PROCEDURE GetSym_Int64 +#include "./Sym/GetSym.inc" +END PROCEDURE GetSym_Int64 + +MODULE PROCEDURE GetSym_Real32 +#include "./Sym/GetSym.inc" +END PROCEDURE GetSym_Real32 + +MODULE PROCEDURE GetSym_Real64 +#include "./Sym/GetSym.inc" +END PROCEDURE GetSym_Real64 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/TailUtility@Methods.F90 b/src/submodules/Utility/src/TailUtility@Methods.F90 new file mode 100644 index 000000000..8ef119bf4 --- /dev/null +++ b/src/submodules/Utility/src/TailUtility@Methods.F90 @@ -0,0 +1,103 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(TailUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Tail +!---------------------------------------------------------------------------- + +MODULE PROCEDURE tail_Int8 +ans = x(2:) +END PROCEDURE tail_Int8 + +MODULE PROCEDURE tail_Int16 +ans = x(2:) +END PROCEDURE tail_Int16 + +MODULE PROCEDURE tail_Int32 +ans = x(2:) +END PROCEDURE tail_Int32 + +MODULE PROCEDURE tail_Int64 +ans = x(2:) +END PROCEDURE tail_Int64 + +!---------------------------------------------------------------------------- +! Tail +!---------------------------------------------------------------------------- + +MODULE PROCEDURE tail_Real32 +ans = x(2:) +END PROCEDURE tail_Real32 + +MODULE PROCEDURE tail_Real64 +ans = x(2:) +END PROCEDURE tail_Real64 + +!---------------------------------------------------------------------------- +! Tail +!---------------------------------------------------------------------------- + +MODULE PROCEDURE tail_char +ans = x(2:) +END PROCEDURE tail_char + +!---------------------------------------------------------------------------- +! last +!---------------------------------------------------------------------------- + +MODULE PROCEDURE last_Int8 +ans = x(SIZE(x)) +END PROCEDURE last_Int8 + +MODULE PROCEDURE last_Int16 +ans = x(SIZE(x)) +END PROCEDURE last_Int16 + +MODULE PROCEDURE last_Int32 +ans = x(SIZE(x)) +END PROCEDURE last_Int32 + +MODULE PROCEDURE last_Int64 +ans = x(SIZE(x)) +END PROCEDURE last_Int64 + +!---------------------------------------------------------------------------- +! last +!---------------------------------------------------------------------------- + +MODULE PROCEDURE last_Real32 +ans = x(SIZE(x)) +END PROCEDURE last_Real32 + +MODULE PROCEDURE last_Real64 +ans = x(SIZE(x)) +END PROCEDURE last_Real64 + +!---------------------------------------------------------------------------- +! last +!---------------------------------------------------------------------------- + +MODULE PROCEDURE last_char +ans = x(LEN(x):LEN(x)) +END PROCEDURE last_char + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/Triag/GetTril1.inc b/src/submodules/Utility/src/Triag/GetTril1.inc new file mode 100644 index 000000000..31006c131 --- /dev/null +++ b/src/submodules/Utility/src/Triag/GetTril1.inc @@ -0,0 +1,26 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +lu = 0.0_DFP +indx = TrilIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + lu(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) +END DO +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/GetTril2.inc b/src/submodules/Utility/src/Triag/GetTril2.inc new file mode 100644 index 000000000..fb7100513 --- /dev/null +++ b/src/submodules/Utility/src/Triag/GetTril2.inc @@ -0,0 +1,34 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: tsize, ii, jj +! +indx = TrilIndx(A, diagNo) +tsize = SIZE(indx, 1) +! +CALL Reallocate(lu, tsize) +! +jj = 0 +! +DO ii = 1, tsize + jj = jj + 1 + lu(jj) = A(indx(ii, 1), indx(ii, 2)) +END DO +! +DEALLOCATE (indx) + diff --git a/src/submodules/Utility/src/Triag/GetTriu1.inc b/src/submodules/Utility/src/Triag/GetTriu1.inc new file mode 100644 index 000000000..a064c5da6 --- /dev/null +++ b/src/submodules/Utility/src/Triag/GetTriu1.inc @@ -0,0 +1,26 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +lu = 0.0_DFP +indx = TriuIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + lu(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) +END DO +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/GetTriu2.inc b/src/submodules/Utility/src/Triag/GetTriu2.inc new file mode 100644 index 000000000..c9a18bc77 --- /dev/null +++ b/src/submodules/Utility/src/Triag/GetTriu2.inc @@ -0,0 +1,33 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: tsize, ii, jj +! +indx = TriuIndx(A, diagNo) +tsize = SIZE(indx, 1) +! +CALL REALLOCATE(lu, tsize) +! +jj = 0 +! +DO ii = 1, tsize + jj = jj + 1 + lu(jj) = A(indx(ii, 1), indx(ii, 2)) +END DO +! +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTril1.inc b/src/submodules/Utility/src/Triag/SetTril1.inc new file mode 100644 index 000000000..22a7c93b5 --- /dev/null +++ b/src/submodules/Utility/src/Triag/SetTril1.inc @@ -0,0 +1,25 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +indx = TrilIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + A(indx(ii, 1), indx(ii, 2)) = lu(indx(ii, 1), indx(ii, 2)) +END DO +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTril2.inc b/src/submodules/Utility/src/Triag/SetTril2.inc new file mode 100644 index 000000000..c072b35a5 --- /dev/null +++ b/src/submodules/Utility/src/Triag/SetTril2.inc @@ -0,0 +1,32 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: tsize, ii, jj +! +indx = TrilIndx(A, diagNo) +tsize = SIZE(indx, 1) +! +jj = 0 +! +DO ii = 1, tsize + jj = jj + 1 + A(indx(ii, 1), indx(ii, 2)) = lu(jj) +END DO +! +DEALLOCATE (indx) + diff --git a/src/submodules/Utility/src/Triag/SetTril3.inc b/src/submodules/Utility/src/Triag/SetTril3.inc new file mode 100644 index 000000000..3cd3ee755 --- /dev/null +++ b/src/submodules/Utility/src/Triag/SetTril3.inc @@ -0,0 +1,25 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +indx = TrilIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + A(indx(ii, 1), indx(ii, 2)) = val +END DO +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTriu1.inc b/src/submodules/Utility/src/Triag/SetTriu1.inc new file mode 100644 index 000000000..d963b1318 --- /dev/null +++ b/src/submodules/Utility/src/Triag/SetTriu1.inc @@ -0,0 +1,25 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +indx = TriuIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + A(indx(ii, 1), indx(ii, 2)) = lu(indx(ii, 1), indx(ii, 2)) +END DO +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTriu2.inc b/src/submodules/Utility/src/Triag/SetTriu2.inc new file mode 100644 index 000000000..02aeb9eb9 --- /dev/null +++ b/src/submodules/Utility/src/Triag/SetTriu2.inc @@ -0,0 +1,31 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: tsize, ii, jj +! +indx = TriuIndx(A, diagNo) +tsize = SIZE(indx, 1) +! +jj = 0 +! +DO ii = 1, tsize + jj = jj + 1 + A(indx(ii, 1), indx(ii, 2)) = lu(jj) +END DO +! +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/SetTriu3.inc b/src/submodules/Utility/src/Triag/SetTriu3.inc new file mode 100644 index 000000000..c000b6540 --- /dev/null +++ b/src/submodules/Utility/src/Triag/SetTriu3.inc @@ -0,0 +1,25 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +indx = TriuIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + A(indx(ii, 1), indx(ii, 2)) = val +END DO +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/Triag/Tril1.inc b/src/submodules/Utility/src/Triag/Tril1.inc new file mode 100644 index 000000000..8671972b9 --- /dev/null +++ b/src/submodules/Utility/src/Triag/Tril1.inc @@ -0,0 +1,26 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +ans = 0.0_DFP +indx = TrilIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + ans(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) +END DO +DEALLOCATE (indx) \ No newline at end of file diff --git a/src/submodules/Utility/src/Triag/Tril2.inc b/src/submodules/Utility/src/Triag/Tril2.inc new file mode 100644 index 000000000..b0020c1f7 --- /dev/null +++ b/src/submodules/Utility/src/Triag/Tril2.inc @@ -0,0 +1,34 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: tsize, ii, jj +! +indx = TrilIndx(A, diagNo) +tsize = SIZE(indx, 1) +! +ALLOCATE (ans(tsize)) +! +jj = 0 +! +DO ii = 1, tsize + jj = jj + 1 + ans(jj) = A(indx(ii, 1), indx(ii, 2)) +END DO +! +DEALLOCATE (indx) + diff --git a/src/submodules/Utility/src/Triag/Triu1.inc b/src/submodules/Utility/src/Triag/Triu1.inc new file mode 100644 index 000000000..e9b9694eb --- /dev/null +++ b/src/submodules/Utility/src/Triag/Triu1.inc @@ -0,0 +1,26 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: ii +! +ans = 0.0_DFP +indx = TriuIndx(A, diagNo) +DO CONCURRENT(ii=1:SIZE(indx, 1)) + ans(indx(ii, 1), indx(ii, 2)) = A(indx(ii, 1), indx(ii, 2)) +END DO +DEALLOCATE (indx) \ No newline at end of file diff --git a/src/submodules/Utility/src/Triag/Triu2.inc b/src/submodules/Utility/src/Triag/Triu2.inc new file mode 100644 index 000000000..27d4e574d --- /dev/null +++ b/src/submodules/Utility/src/Triag/Triu2.inc @@ -0,0 +1,33 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: tsize, ii, jj +! +indx = TriuIndx(A, diagNo) +tsize = SIZE(indx, 1) +! +ALLOCATE (ans(tsize)) +! +jj = 0 +! +DO ii = 1, tsize + jj = jj + 1 + ans(jj) = A(indx(ii, 1), indx(ii, 2)) +END DO +! +DEALLOCATE (indx) diff --git a/src/submodules/Utility/src/TriagUtility@Methods.F90 b/src/submodules/Utility/src/TriagUtility@Methods.F90 new file mode 100644 index 000000000..0a8df9988 --- /dev/null +++ b/src/submodules/Utility/src/TriagUtility@Methods.F90 @@ -0,0 +1,434 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(TriagUtility) Methods +USE BaseMethod, ONLY: Input, DiagIndx, Append, Reallocate, DiagSize +CONTAINS + +!---------------------------------------------------------------------------- +! TriuIndx +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriuIndx_1 +INTEGER(I4B) :: m0, n0, diagNo0, tsize, tdiag, idiag, i1, i2 +! +m0 = m +n0 = INPUT(default=m, option=n) +diagNo0 = INPUT(default=0_I4B, option=diagNo) +! +tsize = 0 +tdiag = 0 +idiag = diagNo0 +! +DO + IF (idiag .GT. n0) EXIT + tsize = tsize + DiagSize(m0, n0, idiag) + idiag = idiag + 1 +END DO +! +ALLOCATE (ans(tsize, 2)) +! +idiag = diagNo0 +! +i1 = 0 +i2 = 0 +! +DO + IF (idiag .GT. n0) EXIT + i1 = i2 + 1 + i2 = i2 + DiagSize(m0, n0, idiag) + ans(i1:i2, 1:2) = DiagIndx(m0, n0, idiag) + idiag = idiag + 1 +END DO +! +END PROCEDURE TriuIndx_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TriuIndx_2 +ans = TriuIndx(SIZE(A, 1), SIZE(A, 2), diagNo) +END PROCEDURE TriuIndx_2 + +!---------------------------------------------------------------------------- +! TrilIndx +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TrilIndx_1 +INTEGER(I4B) :: m0, n0, diagNo0, tsize, idiag, i1, i2 +! +m0 = m +n0 = INPUT(default=m, option=n) +diagNo0 = INPUT(default=0_I4B, option=diagNo) +! +tsize = 0 +idiag = diagNo0 +! +DO + IF (-idiag .GT. m0) EXIT + tsize = tsize + DiagSize(m0, n0, idiag) + idiag = idiag - 1 +END DO +! +ALLOCATE (ans(tsize, 2)) +! +i1 = 0 +i2 = 0 +idiag = diagNo0 +! +DO + IF (-idiag .GT. m0) EXIT + i1 = i2 + 1 + i2 = i2 + DiagSize(m0, n0, idiag) + ans(i1:i2, 1:2) = DiagIndx(m0, n0, idiag) + idiag = idiag - 1 +END DO +! +END PROCEDURE TrilIndx_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TrilIndx_2 +ans = TrilIndx(SIZE(A, 1), SIZE(A, 2), diagNo) +END PROCEDURE TrilIndx_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Tril_1 +#include "./Triag/Tril1.inc" +END PROCEDURE Tril_1 +MODULE PROCEDURE Tril_2 +#include "./Triag/Tril1.inc" +END PROCEDURE Tril_2 +MODULE PROCEDURE Tril_3 +#include "./Triag/Tril1.inc" +END PROCEDURE Tril_3 +MODULE PROCEDURE Tril_4 +#include "./Triag/Tril1.inc" +END PROCEDURE Tril_4 +MODULE PROCEDURE Tril_5 +#include "./Triag/Tril1.inc" +END PROCEDURE Tril_5 +MODULE PROCEDURE Tril_6 +#include "./Triag/Tril1.inc" +END PROCEDURE Tril_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Tril_7 +#include "./Triag/Tril2.inc" +END PROCEDURE Tril_7 +MODULE PROCEDURE Tril_8 +#include "./Triag/Tril2.inc" +END PROCEDURE Tril_8 +MODULE PROCEDURE Tril_9 +#include "./Triag/Tril2.inc" +END PROCEDURE Tril_9 +MODULE PROCEDURE Tril_10 +#include "./Triag/Tril2.inc" +END PROCEDURE Tril_10 +MODULE PROCEDURE Tril_11 +#include "./Triag/Tril2.inc" +END PROCEDURE Tril_11 +MODULE PROCEDURE Tril_12 +#include "./Triag/Tril2.inc" +END PROCEDURE Tril_12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Triu_1 +#include "./Triag/Triu1.inc" +END PROCEDURE Triu_1 +MODULE PROCEDURE Triu_2 +#include "./Triag/Triu1.inc" +END PROCEDURE Triu_2 +MODULE PROCEDURE Triu_3 +#include "./Triag/Triu1.inc" +END PROCEDURE Triu_3 +MODULE PROCEDURE Triu_4 +#include "./Triag/Triu1.inc" +END PROCEDURE Triu_4 +MODULE PROCEDURE Triu_5 +#include "./Triag/Triu1.inc" +END PROCEDURE Triu_5 +MODULE PROCEDURE Triu_6 +#include "./Triag/Triu1.inc" +END PROCEDURE Triu_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Triu_7 +#include "./Triag/Triu2.inc" +END PROCEDURE Triu_7 +MODULE PROCEDURE Triu_8 +#include "./Triag/Triu2.inc" +END PROCEDURE Triu_8 +MODULE PROCEDURE Triu_9 +#include "./Triag/Triu2.inc" +END PROCEDURE Triu_9 +MODULE PROCEDURE Triu_10 +#include "./Triag/Triu2.inc" +END PROCEDURE Triu_10 +MODULE PROCEDURE Triu_11 +#include "./Triag/Triu2.inc" +END PROCEDURE Triu_11 +MODULE PROCEDURE Triu_12 +#include "./Triag/Triu2.inc" +END PROCEDURE Triu_12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTril_1 +#include "./Triag/GetTril1.inc" +END PROCEDURE GetTril_1 +MODULE PROCEDURE GetTril_2 +#include "./Triag/GetTril1.inc" +END PROCEDURE GetTril_2 +MODULE PROCEDURE GetTril_3 +#include "./Triag/GetTril1.inc" +END PROCEDURE GetTril_3 +MODULE PROCEDURE GetTril_4 +#include "./Triag/GetTril1.inc" +END PROCEDURE GetTril_4 +MODULE PROCEDURE GetTril_5 +#include "./Triag/GetTril1.inc" +END PROCEDURE GetTril_5 +MODULE PROCEDURE GetTril_6 +#include "./Triag/GetTril1.inc" +END PROCEDURE GetTril_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTril_7 +#include "./Triag/GetTril2.inc" +END PROCEDURE GetTril_7 +MODULE PROCEDURE GetTril_8 +#include "./Triag/GetTril2.inc" +END PROCEDURE GetTril_8 +MODULE PROCEDURE GetTril_9 +#include "./Triag/GetTril2.inc" +END PROCEDURE GetTril_9 +MODULE PROCEDURE GetTril_10 +#include "./Triag/GetTril2.inc" +END PROCEDURE GetTril_10 +MODULE PROCEDURE GetTril_11 +#include "./Triag/GetTril2.inc" +END PROCEDURE GetTril_11 +MODULE PROCEDURE GetTril_12 +#include "./Triag/GetTril2.inc" +END PROCEDURE GetTril_12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTriu_1 +#include "./Triag/GetTriu1.inc" +END PROCEDURE GetTriu_1 +MODULE PROCEDURE GetTriu_2 +#include "./Triag/GetTriu1.inc" +END PROCEDURE GetTriu_2 +MODULE PROCEDURE GetTriu_3 +#include "./Triag/GetTriu1.inc" +END PROCEDURE GetTriu_3 +MODULE PROCEDURE GetTriu_4 +#include "./Triag/GetTriu1.inc" +END PROCEDURE GetTriu_4 +MODULE PROCEDURE GetTriu_5 +#include "./Triag/GetTriu1.inc" +END PROCEDURE GetTriu_5 +MODULE PROCEDURE GetTriu_6 +#include "./Triag/GetTriu1.inc" +END PROCEDURE GetTriu_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTriu_7 +#include "./Triag/GetTriu2.inc" +END PROCEDURE GetTriu_7 +MODULE PROCEDURE GetTriu_8 +#include "./Triag/GetTriu2.inc" +END PROCEDURE GetTriu_8 +MODULE PROCEDURE GetTriu_9 +#include "./Triag/GetTriu2.inc" +END PROCEDURE GetTriu_9 +MODULE PROCEDURE GetTriu_10 +#include "./Triag/GetTriu2.inc" +END PROCEDURE GetTriu_10 +MODULE PROCEDURE GetTriu_11 +#include "./Triag/GetTriu2.inc" +END PROCEDURE GetTriu_11 +MODULE PROCEDURE GetTriu_12 +#include "./Triag/GetTriu2.inc" +END PROCEDURE GetTriu_12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetTriu_1 +#include "./Triag/SetTriu1.inc" +END PROCEDURE SetTriu_1 +MODULE PROCEDURE SetTriu_2 +#include "./Triag/SetTriu1.inc" +END PROCEDURE SetTriu_2 +MODULE PROCEDURE SetTriu_3 +#include "./Triag/SetTriu1.inc" +END PROCEDURE SetTriu_3 +MODULE PROCEDURE SetTriu_4 +#include "./Triag/SetTriu1.inc" +END PROCEDURE SetTriu_4 +MODULE PROCEDURE SetTriu_5 +#include "./Triag/SetTriu1.inc" +END PROCEDURE SetTriu_5 +MODULE PROCEDURE SetTriu_6 +#include "./Triag/SetTriu1.inc" +END PROCEDURE SetTriu_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetTriu_7 +#include "./Triag/SetTriu2.inc" +END PROCEDURE SetTriu_7 +MODULE PROCEDURE SetTriu_8 +#include "./Triag/SetTriu2.inc" +END PROCEDURE SetTriu_8 +MODULE PROCEDURE SetTriu_9 +#include "./Triag/SetTriu2.inc" +END PROCEDURE SetTriu_9 +MODULE PROCEDURE SetTriu_10 +#include "./Triag/SetTriu2.inc" +END PROCEDURE SetTriu_10 +MODULE PROCEDURE SetTriu_11 +#include "./Triag/SetTriu2.inc" +END PROCEDURE SetTriu_11 +MODULE PROCEDURE SetTriu_12 +#include "./Triag/SetTriu2.inc" +END PROCEDURE SetTriu_12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetTriu_13 +#include "./Triag/SetTriu3.inc" +END PROCEDURE SetTriu_13 +MODULE PROCEDURE SetTriu_14 +#include "./Triag/SetTriu3.inc" +END PROCEDURE SetTriu_14 +MODULE PROCEDURE SetTriu_15 +#include "./Triag/SetTriu3.inc" +END PROCEDURE SetTriu_15 +MODULE PROCEDURE SetTriu_16 +#include "./Triag/SetTriu3.inc" +END PROCEDURE SetTriu_16 +MODULE PROCEDURE SetTriu_17 +#include "./Triag/SetTriu3.inc" +END PROCEDURE SetTriu_17 +MODULE PROCEDURE SetTriu_18 +#include "./Triag/SetTriu3.inc" +END PROCEDURE SetTriu_18 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetTril_1 +#include "./Triag/SetTril1.inc" +END PROCEDURE SetTril_1 +MODULE PROCEDURE SetTril_2 +#include "./Triag/SetTril1.inc" +END PROCEDURE SetTril_2 +MODULE PROCEDURE SetTril_3 +#include "./Triag/SetTril1.inc" +END PROCEDURE SetTril_3 +MODULE PROCEDURE SetTril_4 +#include "./Triag/SetTril1.inc" +END PROCEDURE SetTril_4 +MODULE PROCEDURE SetTril_5 +#include "./Triag/SetTril1.inc" +END PROCEDURE SetTril_5 +MODULE PROCEDURE SetTril_6 +#include "./Triag/SetTril1.inc" +END PROCEDURE SetTril_6 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetTril_7 +#include "./Triag/SetTril2.inc" +END PROCEDURE SetTril_7 +MODULE PROCEDURE SetTril_8 +#include "./Triag/SetTril2.inc" +END PROCEDURE SetTril_8 +MODULE PROCEDURE SetTril_9 +#include "./Triag/SetTril2.inc" +END PROCEDURE SetTril_9 +MODULE PROCEDURE SetTril_10 +#include "./Triag/SetTril2.inc" +END PROCEDURE SetTril_10 +MODULE PROCEDURE SetTril_11 +#include "./Triag/SetTril2.inc" +END PROCEDURE SetTril_11 +MODULE PROCEDURE SetTril_12 +#include "./Triag/SetTril2.inc" +END PROCEDURE SetTril_12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE SetTril_13 +#include "./Triag/SetTril3.inc" +END PROCEDURE SetTril_13 +MODULE PROCEDURE SetTril_14 +#include "./Triag/SetTril3.inc" +END PROCEDURE SetTril_14 +MODULE PROCEDURE SetTril_15 +#include "./Triag/SetTril3.inc" +END PROCEDURE SetTril_15 +MODULE PROCEDURE SetTril_16 +#include "./Triag/SetTril3.inc" +END PROCEDURE SetTril_16 +MODULE PROCEDURE SetTril_17 +#include "./Triag/SetTril3.inc" +END PROCEDURE SetTril_17 +MODULE PROCEDURE SetTril_18 +#include "./Triag/SetTril3.inc" +END PROCEDURE SetTril_18 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ZerosUtility@Methods.F90 b/src/submodules/Utility/src/ZerosUtility@Methods.F90 new file mode 100644 index 000000000..7b9e1724b --- /dev/null +++ b/src/submodules/Utility/src/ZerosUtility@Methods.F90 @@ -0,0 +1,281 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ZerosUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_1 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_2 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_3 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_4 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- +#ifdef USE_Int128 +MODULE PROCEDURE Zeros_5 +ans = 0 +END PROCEDURE +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_6 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_7 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_8 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_9 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_10 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_11 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE Zeros_12 +ans = 0 +END PROCEDURE +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_13 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_14 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_15 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_16 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_17 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_18 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE Zeros_19 +ans = 0 +END PROCEDURE +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_20 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_21 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_22 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_23 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_24 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_25 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +MODULE PROCEDURE Zeros_26 +ans = 0 +END PROCEDURE +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_27 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_28 +ans = 0 +END PROCEDURE + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Zeros_29_Int8 +ans = 0_INT8 +END PROCEDURE Zeros_29_Int8 + +MODULE PROCEDURE Zeros_29_Int16 +ans = 0_INT16 +END PROCEDURE Zeros_29_Int16 + +MODULE PROCEDURE Zeros_29_Int32 +ans = 0_INT32 +END PROCEDURE Zeros_29_Int32 + +MODULE PROCEDURE Zeros_29_Int64 +ans = 0_INT64 +END PROCEDURE Zeros_29_Int64 + +MODULE PROCEDURE Zeros_29_Real32 +ans = 0.0_REAL32 +END PROCEDURE Zeros_29_Real32 + +MODULE PROCEDURE Zeros_29_Real64 +ans = 0.0_REAL64 +END PROCEDURE Zeros_29_Real64 + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc b/src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc new file mode 100644 index 000000000..c14367e25 --- /dev/null +++ b/src/submodules/Utility/src/inc/EquidistanceLIP_Tetrahedron.inc @@ -0,0 +1,267 @@ + +!---------------------------------------------------------------------------- +! EquidistanceLIP_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceLIP_Tetrahedron + !! +SELECT CASE (order) +CASE (1) + !! + !! tetra4 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0], [3, 4]) + !! +CASE (2) + !! + !! tetra10 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.5, 0.0, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.0, 0.5, & + & 0.0, 0.5, 0.5, & + & 0.5, 0.0, 0.5], [3, 10]) + !! +CASE (3) + !! + !! tetra20 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.0, 0.66666666666666666667, & + & 0.0, 0.0, 0.33333333333333333333, & + & 0.0, 0.33333333333333333333, 0.66666666666666666667, & + & 0.0, 0.66666666666666666667, 0.33333333333333333333, & + & 0.33333333333333333333, 0.0, 0.66666666666666666667, & + & 0.66666666666666666667, 0.0, 0.33333333333333333333, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.0, 0.33333333333333333333, & + & 0.0, 0.33333333333333333333, 0.33333333333333333333, & + & 0.33333333333333333333, 0.33333333333333333333, & + & 0.33333333333333333333], [3, 20]) + !! +CASE (4) + !! + !! tetra35 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.25, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.75, 0.0, 0.0, & + & 0.75, 0.25, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.25, 0.75, 0.0, & + & 0.0, 0.75, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.25, 0.0, & + & 0.0, 0.0, 0.75, & + & 0.0, 0.0, 0.5, & + & 0.0, 0.0, 0.25, & + & 0.0, 0.25, 0.75, & + & 0.0, 0.5, 0.5, & + & 0.0, 0.75, 0.25, & + & 0.25, 0.0, 0.75, & + & 0.5, 0.0, 0.5, & + & 0.75, 0.0, 0.25, & + & 0.25, 0.25, 0.0, & + & 0.25, 0.5, 0.0, & + & 0.5, 0.25, 0.0, & + & 0.25, 0.0, 0.25, & + & 0.5, 0.0, 0.25, & + & 0.25, 0.0, 0.5, & + & 0.0, 0.25, 0.25, & + & 0.0, 0.25, 0.5, & + & 0.0, 0.5, 0.25, & + & 0.25, 0.25, 0.5, & + & 0.5, 0.25, 0.25, & + & 0.25, 0.5, 0.25, & + & 0.25, 0.25, 0.25], [3, 35]) + !! +CASE (5) + !! + !! tetra56 + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.2, 0.0, 0.0, & + & 0.4, 0.0, 0.0, & + & 0.6, 0.0, 0.0, & + & 0.8, 0.0, 0.0, & + & 0.8, 0.2, 0.0, & + & 0.6, 0.4, 0.0, & + & 0.4, 0.6, 0.0, & + & 0.2, 0.8, 0.0, & + & 0.0, 0.8, 0.0, & + & 0.0, 0.6, 0.0, & + & 0.0, 0.4, 0.0, & + & 0.0, 0.2, 0.0, & + & 0.0, 0.0, 0.8, & + & 0.0, 0.0, 0.6, & + & 0.0, 0.0, 0.4, & + & 0.0, 0.0, 0.2, & + & 0.0, 0.2, 0.8, & + & 0.0, 0.4, 0.6, & + & 0.0, 0.6, 0.4, & + & 0.0, 0.8, 0.2, & + & 0.2, 0.0, 0.8, & + & 0.4, 0.0, 0.6, & + & 0.6, 0.0, 0.4, & + & 0.8, 0.0, 0.2, & + & 0.2, 0.2, 0.0, & + & 0.2, 0.6, 0.0, & + & 0.6, 0.2, 0.0, & + & 0.2, 0.4, 0.0, & + & 0.4, 0.4, 0.0, & + & 0.4, 0.2, 0.0, & + & 0.2, 0.0, 0.2, & + & 0.6, 0.0, 0.2, & + & 0.2, 0.0, 0.6, & + & 0.4, 0.0, 0.2, & + & 0.4, 0.0, 0.4, & + & 0.2, 0.0, 0.4, & + & 0.0, 0.2, 0.2, & + & 0.0, 0.2, 0.6, & + & 0.0, 0.6, 0.2, & + & 0.0, 0.2, 0.4, & + & 0.0, 0.4, 0.4, & + & 0.0, 0.4, 0.2, & + & 0.2, 0.2, 0.6, & + & 0.6, 0.2, 0.2, & + & 0.2, 0.6, 0.2, & + & 0.4, 0.2, 0.4, & + & 0.4, 0.4, 0.2, & + & 0.2, 0.4, 0.4, & + & 0.2, 0.2, 0.2, & + & 0.4, 0.2, 0.2, & + & 0.2, 0.4, 0.2, & + & 0.2, 0.2, 0.4], [3, 56]) + !! +CASE (6) + !! + !! + !! + nodecoord = reshape([ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.0, 0.0, 1.0, & + & 0.16666666666666666667, 0.0, 0.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.83333333333333333333, 0.0, 0.0, & + & 0.83333333333333333333, 0.16666666666666666667, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.16666666666666666667, 0.83333333333333333333, 0.0, & + & 0.0, 0.83333333333333333333, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.16666666666666666667, 0.0, & + & 0.0, 0.0, 0.83333333333333333333, & + & 0.0, 0.0, 0.66666666666666666667, & + & 0.0, 0.0, 0.5, & + & 0.0, 0.0, 0.33333333333333333333, & + & 0.0, 0.0, 0.16666666666666666667, & + & 0.0, 0.16666666666666666667, 0.83333333333333333333, & + & 0.0, 0.33333333333333333333, 0.66666666666666666667, & + & 0.0, 0.5, 0.5, & + & 0.0, 0.66666666666666666667, 0.33333333333333333333, & + & 0.0, 0.83333333333333333333, 0.16666666666666666667, & + & 0.16666666666666666667, 0.0, 0.83333333333333333333, & + & 0.33333333333333333333, 0.0, 0.66666666666666666667, & + & 0.5, 0.0, 0.5, & + & 0.66666666666666666667, 0.0, 0.33333333333333333333, & + & 0.83333333333333333333, 0.0, 0.16666666666666666667, & + & 0.16666666666666666667, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.66666666666666666667, 0.0, & + & 0.66666666666666666667, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.33333333333333333333, 0.0, & + & 0.16666666666666666667, 0.5, 0.0, & + & 0.33333333333333333333, 0.5, 0.0, & + & 0.5, 0.33333333333333333333, 0.0, & + & 0.5, 0.16666666666666666667, 0.0, & + & 0.33333333333333333333, 0.16666666666666666667, 0.0, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0, & + & 0.16666666666666666667, 0.0, 0.16666666666666666667, & + & 0.66666666666666666667, 0.0, 0.16666666666666666667, & + & 0.16666666666666666667, 0.0, 0.66666666666666666667, & + & 0.33333333333333333333, 0.0, 0.16666666666666666667, & + & 0.5, 0.0, 0.16666666666666666667, & + & 0.5, 0.0, 0.33333333333333333333, & + & 0.33333333333333333333, 0.0, 0.5, & + & 0.16666666666666666667, 0.0, 0.5, & + & 0.16666666666666666667, 0.0, 0.33333333333333333333, & + & 0.33333333333333333333, 0.0, 0.33333333333333333333, & + & 0.0, 0.16666666666666666667, 0.16666666666666666667, & + & 0.0, 0.16666666666666666667, 0.66666666666666666667, & + & 0.0, 0.66666666666666666667, 0.16666666666666666667, & + & 0.0, 0.16666666666666666667, 0.33333333333333333333, & + & 0.0, 0.16666666666666666667, 0.5, & + & 0.0, 0.33333333333333333333, 0.5, & + & 0.0, 0.5, 0.33333333333333333333, & + & 0.0, 0.5, 0.16666666666666666667, & + & 0.0, 0.33333333333333333333, 0.16666666666666666667, & + & 0.0, 0.33333333333333333333, 0.33333333333333333333, & + & 0.16666666666666666667, 0.16666666666666666667, & + & 0.66666666666666666667, & + & 0.66666666666666666667, 0.16666666666666666667, & + & 0.16666666666666666667, & + & 0.16666666666666666667, 0.66666666666666666667, & + & 0.16666666666666666667, & + & 0.33333333333333333333, 0.16666666666666666667, 0.5, & + & 0.5, 0.16666666666666666667, 0.33333333333333333333, & + & 0.5, 0.33333333333333333333, 0.16666666666666666667, & + & 0.33333333333333333333, 0.5, 0.16666666666666666667, & + & 0.16666666666666666667, 0.5, 0.33333333333333333333, & + & 0.16666666666666666667, 0.33333333333333333333, 0.5, & + & 0.33333333333333333333, 0.33333333333333333333, & + & 0.33333333333333333333, & + & 0.16666666666666666667, 0.16666666666666666667, & + & 0.16666666666666666667, & + & 0.5, 0.16666666666666666667, 0.16666666666666666667, & + & 0.16666666666666666667, 0.5, 0.16666666666666666667, & + & 0.16666666666666666667, 0.16666666666666666667, 0.5, & + & 0.33333333333333333333, 0.16666666666666666667, & + & 0.16666666666666666667, & + & 0.33333333333333333333, 0.33333333333333333333, & + & 0.16666666666666666667, & + & 0.16666666666666666667, 0.33333333333333333333, & + & 0.16666666666666666667, & + & 0.16666666666666666667, 0.16666666666666666667, & + & 0.33333333333333333333, & + & 0.16666666666666666667, 0.33333333333333333333, & + & 0.33333333333333333333, & + & 0.33333333333333333333, 0.16666666666666666667, & + & 0.33333333333333333333], [3, 84]) +END SELECT + !! +END PROCEDURE EquidistanceLIP_Tetrahedron diff --git a/src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc b/src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc new file mode 100644 index 000000000..8b5bb1a8d --- /dev/null +++ b/src/submodules/Utility/src/inc/EquidistanceLIP_Triangle.inc @@ -0,0 +1,403 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 PROCEDURE EquidistanceLIP_Triangle + !! + !! Define internal variables + !! + INTEGER( I4B ) :: i + REAL( DFP ) :: x( 3 ), y( 3 ) + REAL( DFP ), ALLOCATABLE :: xi( : ), eta( : ) + !! + !! + !! + SELECT CASE( Order ) + !! + CASE( 1 ) + !! + !! order 1; Triangle3 + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP], [3, 3] ) + !! + CASE( 2 ) + !! + !! order 2, Triangle6 + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.5_DFP, 0.0_DFP, 0.0_DFP, & + & 0.5_DFP, 0.5_DFP, 0.0_DFP, & + & 0.0_DFP, 0.5_DFP, 0.0_DFP ], & + & [3, 6]) + !! + CASE( 3 ) + !! + !! order 3, Triangle10 + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.33333333333333333333_DFP, 0.0_DFP, 0.0_DFP, & + & 0.66666666666666666667_DFP, 0.0_DFP, 0.0_DFP, & + & 0.66666666666666666667_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & + & 0.33333333333333333333_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & + & 0.0_DFP, 0.66666666666666666667_DFP, 0.0_DFP, & + & 0.0_DFP, 0.33333333333333333333_DFP, 0.0_DFP, & + & 0.33333333333333333333_DFP, 0.33333333333333333333_DFP, 0.0_DFP], & + & [3, 10]) + !! + CASE( 4 ) + !! + !! order 4 Includes bubble nodes also + !! Trianagle15a + !! + nodecoord = RESHAPE( [ & + & 0.0_DFP, 0.0_DFP, 0.0_DFP, & + & 1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.25_DFP, 0.0_DFP, 0.0_DFP, & + & 0.5_DFP, 0.0_DFP, 0.0_DFP, & + & 0.75_DFP, 0.0_DFP, 0.0_DFP, & + & 0.75_DFP, 0.25_DFP, 0.0_DFP, & + & 0.5_DFP, 0.5_DFP, 0.0_DFP, & + & 0.25_DFP, 0.75_DFP, 0.0_DFP, & + & 0.0_DFP, 0.75_DFP, 0.0_DFP, & + & 0.0_DFP, 0.5_DFP, 0.0_DFP, & + & 0.0_DFP, 0.25_DFP, 0.0_DFP, & + & 0.25_DFP, 0.25_DFP, 0.0_DFP, & + & 0.5_DFP, 0.25_DFP, 0.0_DFP, & + & 0.25_DFP, 0.5_DFP, 0.0_DFP], & + & [3, 15]) + !! + CASE( 5 ) + !! + !! This is fifth order triangle + !! 3 nodes on vertex, 12 nodes on edge, and 6 on the face + !! Triangle21 + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.2, 0.0, 0.0, & + & 0.4, 0.0, 0.0, & + & 0.6, 0.0, 0.0, & + & 0.8, 0.0, 0.0, & + & 0.8, 0.2, 0.0, & + & 0.6, 0.4, 0.0, & + & 0.4, 0.6, 0.0, & + & 0.2, 0.8, 0.0, & + & 0.0, 0.8, 0.0, & + & 0.0, 0.6, 0.0, & + & 0.0, 0.4, 0.0, & + & 0.0, 0.2, 0.0, & + & 0.2, 0.2, 0.0, & + & 0.6, 0.2, 0.0, & + & 0.2, 0.6, 0.0, & + & 0.4, 0.2, 0.0, & + & 0.4, 0.4, 0.0, & + & 0.2, 0.4, 0.0], [3, 21]) + !! + CASE( 6 ) + !! + !! Triangle28 + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.16666666666666666667, 0.0, 0.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.83333333333333333333, 0.0, 0.0, & + & 0.83333333333333333333, 0.16666666666666666667, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.16666666666666666667, 0.83333333333333333333, 0.0, & + & 0.0, 0.83333333333333333333, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.16666666666666666667, 0.0, & + & 0.66666666666666666667, 0.16666666666666666667, 0.0, & + & 0.16666666666666666667, 0.66666666666666666667, 0.0, & + & 0.33333333333333333333, 0.16666666666666666667, 0.0, & + & 0.5, 0.16666666666666666667, 0.0, & + & 0.5, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.5, 0.0, & + & 0.16666666666666666667, 0.5, 0.0, & + & 0.16666666666666666667, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0], [3, 28] ) + !! + CASE( 7 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.14285714285714285714, 0.0, 0.0, & + & 0.28571428571428571429, 0.0, 0.0, & + & 0.42857142857142857143, 0.0, 0.0, & + & 0.57142857142857142857, 0.0, 0.0, & + & 0.71428571428571428571, 0.0, 0.0, & + & 0.85714285714285714286, 0.0, 0.0, & + & 0.85714285714285714286, 0.14285714285714285714, 0.0, & + & 0.71428571428571428571, 0.28571428571428571429, 0.0, & + & 0.57142857142857142857, 0.42857142857142857143, 0.0, & + & 0.42857142857142857143, 0.57142857142857142857, 0.0, & + & 0.28571428571428571429, 0.71428571428571428571, 0.0, & + & 0.14285714285714285714, 0.85714285714285714286, 0.0, & + & 0.0, 0.85714285714285714286, 0.0, & + & 0.0, 0.71428571428571428571, 0.0, & + & 0.0, 0.57142857142857142857, 0.0, & + & 0.0, 0.42857142857142857143, 0.0, & + & 0.0, 0.28571428571428571429, 0.0, & + & 0.0, 0.14285714285714285714, 0.0, & + & 0.14285714285714285714, 0.14285714285714285714, 0.0, & + & 0.71428571428571428571, 0.14285714285714285714, 0.0, & + & 0.14285714285714285714, 0.71428571428571428571, 0.0, & + & 0.28571428571428571429, 0.14285714285714285714, 0.0, & + & 0.42857142857142857143, 0.14285714285714285714, 0.0, & + & 0.57142857142857142857, 0.14285714285714285714, 0.0, & + & 0.57142857142857142857, 0.28571428571428571429, 0.0, & + & 0.42857142857142857143, 0.42857142857142857143, 0.0, & + & 0.28571428571428571429, 0.57142857142857142857, 0.0, & + & 0.14285714285714285714, 0.57142857142857142857, 0.0, & + & 0.14285714285714285714, 0.42857142857142857143, 0.0, & + & 0.14285714285714285714, 0.28571428571428571429, 0.0, & + & 0.28571428571428571429, 0.28571428571428571429, 0.0, & + & 0.42857142857142857143, 0.28571428571428571429, 0.0, & + & 0.28571428571428571429, 0.42857142857142857143, 0.0 ], [3,36]) + !! + CASE( 8 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.125, 0.0, 0.0, & + & 0.25, 0.0, 0.0, & + & 0.375, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.625, 0.0, 0.0, & + & 0.75, 0.0, 0.0, & + & 0.875, 0.0, 0.0, & + & 0.875, 0.125, 0.0, & + & 0.75, 0.25, 0.0, & + & 0.625, 0.375, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.375, 0.625, 0.0, & + & 0.25, 0.75, 0.0, & + & 0.125, 0.875, 0.0, & + & 0.0, 0.875, 0.0, & + & 0.0, 0.75, 0.0, & + & 0.0, 0.625, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.375, 0.0, & + & 0.0, 0.25, 0.0, & + & 0.0, 0.125, 0.0, & + & 0.125, 0.125, 0.0, & + & 0.75, 0.125, 0.0, & + & 0.125, 0.75, 0.0, & + & 0.25, 0.125, 0.0, & + & 0.375, 0.125, 0.0, & + & 0.5, 0.125, 0.0, & + & 0.625, 0.125, 0.0, & + & 0.625, 0.25, 0.0, & + & 0.5, 0.375, 0.0, & + & 0.375, 0.5, 0.0, & + & 0.25, 0.625, 0.0, & + & 0.125, 0.625, 0.0, & + & 0.125, 0.5, 0.0, & + & 0.125, 0.375, 0.0, & + & 0.125, 0.25, 0.0, & + & 0.25, 0.25, 0.0, & + & 0.5, 0.25, 0.0, & + & 0.25, 0.5, 0.0, & + & 0.375, 0.25, 0.0, & + & 0.375, 0.375, 0.0, & + & 0.25, 0.375, 0.0 ], [3, 45]) + !! + CASE( 9 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.11111111111111111111, 0.0, 0.0, & + & 0.22222222222222222222, 0.0, 0.0, & + & 0.33333333333333333333, 0.0, 0.0, & + & 0.44444444444444444444, 0.0, 0.0, & + & 0.55555555555555555556, 0.0, 0.0, & + & 0.66666666666666666667, 0.0, 0.0, & + & 0.77777777777777777778, 0.0, 0.0, & + & 0.88888888888888888889, 0.0, 0.0, & + & 0.88888888888888888889, 0.11111111111111111111, 0.0, & + & 0.77777777777777777778, 0.22222222222222222222, 0.0, & + & 0.66666666666666666667, 0.33333333333333333333, 0.0, & + & 0.55555555555555555556, 0.44444444444444444444, 0.0, & + & 0.44444444444444444444, 0.55555555555555555556, 0.0, & + & 0.33333333333333333333, 0.66666666666666666667, 0.0, & + & 0.22222222222222222222, 0.77777777777777777778, 0.0, & + & 0.11111111111111111111, 0.88888888888888888889, 0.0, & + & 0.0, 0.88888888888888888889, 0.0, & + & 0.0, 0.77777777777777777778, 0.0, & + & 0.0, 0.66666666666666666667, 0.0, & + & 0.0, 0.55555555555555555556, 0.0, & + & 0.0, 0.44444444444444444444, 0.0, & + & 0.0, 0.33333333333333333333, 0.0, & + & 0.0, 0.22222222222222222222, 0.0, & + & 0.0, 0.11111111111111111111, 0.0, & + & 0.11111111111111111111, 0.11111111111111111111, 0.0, & + & 0.77777777777777777778, 0.11111111111111111111, 0.0, & + & 0.11111111111111111111, 0.77777777777777777778, 0.0, & + & 0.22222222222222222222, 0.11111111111111111111, 0.0, & + & 0.33333333333333333333, 0.11111111111111111111, 0.0, & + & 0.44444444444444444444, 0.11111111111111111111, 0.0, & + & 0.55555555555555555556, 0.11111111111111111111, 0.0, & + & 0.66666666666666666667, 0.11111111111111111111, 0.0, & + & 0.66666666666666666667, 0.22222222222222222222, 0.0, & + & 0.55555555555555555556, 0.33333333333333333333, 0.0, & + & 0.44444444444444444444, 0.44444444444444444444, 0.0, & + & 0.33333333333333333333, 0.55555555555555555556, 0.0, & + & 0.22222222222222222222, 0.66666666666666666667, 0.0, & + & 0.11111111111111111111, 0.66666666666666666667, 0.0, & + & 0.11111111111111111111, 0.55555555555555555556, 0.0, & + & 0.11111111111111111111, 0.44444444444444444444, 0.0, & + & 0.11111111111111111111, 0.33333333333333333333, 0.0, & + & 0.11111111111111111111, 0.22222222222222222222, 0.0, & + & 0.22222222222222222222, 0.22222222222222222222, 0.0, & + & 0.55555555555555555556, 0.22222222222222222222, 0.0, & + & 0.22222222222222222222, 0.55555555555555555556, 0.0, & + & 0.33333333333333333333, 0.22222222222222222222, 0.0, & + & 0.44444444444444444444, 0.22222222222222222222, 0.0, & + & 0.44444444444444444444, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.44444444444444444444, 0.0, & + & 0.22222222222222222222, 0.44444444444444444444, 0.0, & + & 0.22222222222222222222, 0.33333333333333333333, 0.0, & + & 0.33333333333333333333, 0.33333333333333333333, 0.0 ], [3,55] ) + !! + CASE( 10 ) + !! + !! + !! + nodecoord = RESHAPE( [ & + & 0.0, 0.0, 0.0, & + & 1.0, 0.0, 0.0, & + & 0.0, 1.0, 0.0, & + & 0.1, 0.0, 0.0, & + & 0.2, 0.0, 0.0, & + & 0.3, 0.0, 0.0, & + & 0.4, 0.0, 0.0, & + & 0.5, 0.0, 0.0, & + & 0.6, 0.0, 0.0, & + & 0.7, 0.0, 0.0, & + & 0.8, 0.0, 0.0, & + & 0.9, 0.0, 0.0, & + & 0.9, 0.1, 0.0, & + & 0.8, 0.2, 0.0, & + & 0.7, 0.3, 0.0, & + & 0.6, 0.4, 0.0, & + & 0.5, 0.5, 0.0, & + & 0.4, 0.6, 0.0, & + & 0.3, 0.7, 0.0, & + & 0.2, 0.8, 0.0, & + & 0.1, 0.9, 0.0, & + & 0.0, 0.9, 0.0, & + & 0.0, 0.8, 0.0, & + & 0.0, 0.7, 0.0, & + & 0.0, 0.6, 0.0, & + & 0.0, 0.5, 0.0, & + & 0.0, 0.4, 0.0, & + & 0.0, 0.3, 0.0, & + & 0.0, 0.2, 0.0, & + & 0.0, 0.1, 0.0, & + & 0.1, 0.1, 0.0, & + & 0.8, 0.1, 0.0, & + & 0.1, 0.8, 0.0, & + & 0.2, 0.1, 0.0, & + & 0.3, 0.1, 0.0, & + & 0.4, 0.1, 0.0, & + & 0.5, 0.1, 0.0, & + & 0.6, 0.1, 0.0, & + & 0.7, 0.1, 0.0, & + & 0.7, 0.2, 0.0, & + & 0.6, 0.3, 0.0, & + & 0.5, 0.4, 0.0, & + & 0.4, 0.5, 0.0, & + & 0.3, 0.6, 0.0, & + & 0.2, 0.7, 0.0, & + & 0.1, 0.7, 0.0, & + & 0.1, 0.6, 0.0, & + & 0.1, 0.5, 0.0, & + & 0.1, 0.4, 0.0, & + & 0.1, 0.3, 0.0, & + & 0.1, 0.2, 0.0, & + & 0.2, 0.2, 0.0, & + & 0.6, 0.2, 0.0, & + & 0.2, 0.6, 0.0, & + & 0.3, 0.2, 0.0, & + & 0.4, 0.2, 0.0, & + & 0.5, 0.2, 0.0, & + & 0.5, 0.3, 0.0, & + & 0.4, 0.4, 0.0, & + & 0.3, 0.5, 0.0, & + & 0.2, 0.5, 0.0, & + & 0.2, 0.4, 0.0, & + & 0.2, 0.3, 0.0, & + & 0.3, 0.3, 0.0, & + & 0.4, 0.3, 0.0, & + & 0.3, 0.4, 0.0 ], [3,66] ) + END SELECT + !! + !! + !! + IF( PRESENT( xij ) ) THEN + !! + ALLOCATE( xi( SIZE( nodecoord, 2 ) ), eta( SIZE( nodecoord, 2 ) ) ) + xi( : ) = nodecoord( 1, : ) + eta( : ) = nodecoord( 2, : ) + !! + x = xij( 1, 1:3 ) + y = xij( 2, 1:3 ) + !! + nodecoord( 1, : ) = x( 1 ) + ( x( 2 ) - x( 1 ) ) * xi & + & + ( x( 3 ) - x( 1 ) ) * eta + !! + nodecoord( 2, : ) = y( 1 ) + ( y( 2 ) - y( 1 ) ) * xi & + & + ( y( 3 ) - y( 1 ) ) * eta + !! + DEALLOCATE( xi, eta ) + !! + END IF + !! +END PROCEDURE EquidistanceLIP_Triangle \ No newline at end of file diff --git a/src/submodules/Vector/ToDo/VectorOperations.part b/src/submodules/Vector/ToDo/VectorOperations.part new file mode 100755 index 000000000..85b1036af --- /dev/null +++ b/src/submodules/Vector/ToDo/VectorOperations.part @@ -0,0 +1,366 @@ +! +!------------------------------------------------------------------------------ +! Author : Vikas sharma +! Position : Doctral Student +! Institute : Kyoto Univeristy, Japan +! Program name: VectorOperations.part +! Last Update : September-06-2017 +! +!------------------------------------------------------------------------------ +! Details of Program +!============================================================================== +! +! Type:: Part of module +! +! Info:: - This contains some vector operations + +! Hosting File - +! +!============================================================================== + +!------------------------------------------------------------------------------ +! VectorProduct2 +!------------------------------------------------------------------------------ + + FUNCTION VectorProduct2( u, v ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Vector product; u x v +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v + REAL( DFP ), DIMENSION( 3 ) :: VectorProduct2 + + ! Define internal variables + INTEGER( I4B ) :: N + + + Error_Flag = .FALSE. + + IF( SIZE( u ) .NE. SIZE( v ) ) THEN + + CALL Err_Msg( & + "Tensor_Class.F90>>VectorOperations.part", & + "VectorProduct( u, v )", & + "The size of u and v must be same; & + & it should be either 2 or 3; PROGRAM STOPPED!!") + Error_Flag = .TRUE. + STOP + + END IF + + N = SIZE( u ) + + SELECT CASE( N ) + + CASE( 3 ) + + VectorProduct2( 1 ) = U( 2 ) * V( 3 ) - U( 3 ) * V( 2 ) + VectorProduct2( 2 ) = U( 3 ) * V( 1 ) - U( 1 ) * V( 3 ) + VectorProduct2( 3 ) = U( 1 ) * V( 2 ) - U( 2 ) * V( 1 ) + + CASE( 2 ) + + VectorProduct2( 1 ) = 0.0_DFP + VectorProduct2( 2 ) = 0.0_DFP + VectorProduct2( 3 ) = U( 1 ) * V( 2 ) - U( 2 ) * V( 1 ) + + CASE DEFAULT + + CALL Err_Msg( & + "Tensor_Class.F90>>VectorOperations.part", & + "VectorProduct()", & + "No case found for the size of u and v; & + & it should be either 2 or 3; PROGRAM STOPPED!!") + Error_Flag = .TRUE. + STOP + + END SELECT + + END FUNCTION VectorProduct2 + +!------------------------------------------------------------------------------ +! VectorProduct3 +!------------------------------------------------------------------------------ + + FUNCTION VectorProduct3( u, v, w ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Triple Vector product u x ( v x w ) +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY: Assert_Eq + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w + REAL( DFP ), DIMENSION( 3 ) :: VectorProduct3 + + ! Define internal variables + INTEGER( I4B ) :: N + + + Error_Flag = .FALSE. + + VectorProduct3 = DOT_PRODUCT( u, w ) * v - DOT_PRODUCT( u, v ) * w + + END FUNCTION VectorProduct3 + +!------------------------------------------------------------------------------ +! BoxProduct +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION BoxProduct( u, v, w ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Triple Scalar product u.( v x w ) = [u,v,w] = [v,w,u] = [w,u,v] +! +!. . . . . . . . . . . . . . . . . . . . + + USE Utility, ONLY: Det + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( 3 ), INTENT( IN ) :: u, v, w + + ! Define internal variables + REAL( DFP ), DIMENSION( 3, 3 ) :: DummyMat + Error_Flag = .FALSE. + + DummyMat = RESHAPE((/u(1), v(1), w(1),& + u(2), v(2), w(2),& + u(3), v(3), w(3)/),(/3,3/)) + + BoxProduct = Det( DummyMat ) + + END FUNCTION BoxProduct + +!------------------------------------------------------------------------------ +! getAngle +!------------------------------------------------------------------------------ + + REAL( DFP ) FUNCTION getAngle( u, v ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. Returns the angle between two vectors +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v + + ! Define internal variables + REAL( DFP ) :: Norm_u, Norm_v, CosTheta + + Norm_u = SQRT( DOT_PRODUCT( u, u ) ) + Norm_v = SQRT( DOT_PRODUCT( v, v ) ) + + IF( Norm_u .EQ. 0.0_DFP .OR. Norm_v .EQ. 0.0_DFP ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>VectorOperations.part", & + "getAngle()", & + "Either u or v is/are zero, Angle Not Defined, Program Stopped!") + STOP + + END IF + + CosTheta = DOT_PRODUCT( u, v ) / Norm_u / Norm_v + + getAngle = ACOS( CosTheta ) + + END FUNCTION getAngle + +!------------------------------------------------------------------------------ +! getProjection +!------------------------------------------------------------------------------ + + FUNCTION getProjection( u, v ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. project u on v and return the projection vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v + REAL( DFP ), DIMENSION( SIZE( u ) ) :: getProjection + + ! Define internal variables + REAL( DFP ) :: Norm_u, Norm_v, CosTheta + + Norm_u = SQRT( DOT_PRODUCT( u, u ) ) + Norm_v = SQRT( DOT_PRODUCT( v, v ) ) + + IF( Norm_u .EQ. 0.0_DFP .OR. Norm_v .EQ. 0.0_DFP ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>VectorOperations.part", & + "getProjection()", & + "Either u or v is/are zero, projection is not defined, & + Program Stopped!") + STOP + + END IF + + CosTheta = DOT_PRODUCT( u, v ) / Norm_u / Norm_v + + getProjection = ( Norm_u * CosTheta / Norm_v ) * v + + END FUNCTION getProjection + +!------------------------------------------------------------------------------ +! UnitVector +!------------------------------------------------------------------------------ + + FUNCTION UnitVector( u ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. - returns unit vector +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( SIZE( u ) ) :: UnitVector + + ! Define internal variables + REAL( DFP ) :: Norm_u + + Norm_u = SQRT( DOT_PRODUCT( u, u ) ) + + IF( Norm_u .EQ. 0.0_DFP ) THEN + + CALL Err_Msg( & + "Rank2Tensor_Class.F90>>VectorOperations.part", & + "UnitVector()", & + "U vector is zero, projection is not defined, & + Program Stopped!") + STOP + + END IF + + UnitVector = ( 1.0_DFP / Norm_u ) * u + + END FUNCTION UnitVector + +!------------------------------------------------------------------------------ +! DotProduct +!------------------------------------------------------------------------------ + + FUNCTION DotProduct( u, v ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. returns u.v +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v + REAL( DFP ) :: DotProduct + + DotProduct = DOT_PRODUCT( u, v) + + END FUNCTION DotProduct + +!------------------------------------------------------------------------------ +! getNormalComponent +!------------------------------------------------------------------------------ + + FUNCTION getNormalComponent( u, v ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. returns component of u that is normal to v +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u, v + REAL( DFP ), DIMENSION( SIZE( u ) ) :: getNormalComponent + + getNormalComponent = u - ( u .ProjectOn. v ) + + END FUNCTION getNormalComponent + +!------------------------------------------------------------------------------ +! Vector2D +!------------------------------------------------------------------------------ + + FUNCTION Vector2D( u ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. converts any vector in 2D vector format. +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( 2 ) :: Vector2D + + + Vector2D = 0.0_DFP + SELECT CASE( SIZE( U ) ) + + CASE( 1 ) + + Vector2D( 1 ) = U( 1 ) + + CASE DEFAULT + + Vector2D( 1: 2 ) = U( 1: 2 ) + + END SELECT + + END FUNCTION Vector2D + +!------------------------------------------------------------------------------ +! Vector3D +!------------------------------------------------------------------------------ + + FUNCTION Vector3D( u ) + +!. . . . . . . . . . . . . . . . . . . . +! 1. converts any vector in 3D vector format. +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( 3 ) :: Vector3D + + + Vector3D = 0.0_DFP + + SELECT CASE( SIZE( u ) ) + + CASE( 1 ) + + Vector3D( 1 ) = u( 1 ) + + CASE( 2 ) + + Vector3D( 1 : 2 ) = u( 1 : 2 ) + + CASE DEFAULT + + Vector3D( 1: 3 ) = u( 1 : 3 ) + + END SELECT + + END FUNCTION Vector3D + +!------------------------------------------------------------------------------ +! Vector1D +!------------------------------------------------------------------------------ + + FUNCTION Vector1D( u ) + + +!. . . . . . . . . . . . . . . . . . . . +! 1. converts any vector in 1D vector format. +!. . . . . . . . . . . . . . . . . . . . + + ! Define Intent of dummy variables + REAL( DFP ), DIMENSION( : ), INTENT( IN ) :: u + REAL( DFP ), DIMENSION( 1 ) :: Vector1D + + Vector1D( 1 ) = u( 1 ) + + END FUNCTION Vector1D + +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ + diff --git a/src/submodules/Vector3D/CMakeLists.txt b/src/submodules/Vector3D/CMakeLists.txt new file mode 100644 index 000000000..41e532c3d --- /dev/null +++ b/src/submodules/Vector3D/CMakeLists.txt @@ -0,0 +1,14 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 23/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/Vector3D_Method@Constructor.F90 + ${src_path}/Vector3D_Method@Misc.F90 +) \ No newline at end of file diff --git a/src/submodules/Vector3D/Vector3D_Method@Misc.F90 b/src/submodules/Vector3D/Vector3D_Method@Misc.F90 new file mode 100644 index 000000000..e69de29bb diff --git a/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 b/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 new file mode 100644 index 000000000..9333de0b8 --- /dev/null +++ b/src/submodules/Vector3D/src/Vector3D_Method@Constructor.F90 @@ -0,0 +1,143 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 24 Feb 2021 +! summary: This submodule contains the implementation of construction relted methods defined inside [[Vector3D_Method]] module. +! + +SUBMODULE(Vector3D_Method) Constructor +USE BaseMethod +IMPLICIT NONE +CONTAINS + + +!---------------------------------------------------------------------------- +! SHAPE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_shape + Ans = 3_I4B +END PROCEDURE get_shape + +!---------------------------------------------------------------------------- +! SIZE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_size + Ans = 3_I4B +END PROCEDURE get_size + +!---------------------------------------------------------------------------- +! getTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vec3D_getTotalDimension + ans = obj%tDimension +END PROCEDURE Vec3D_getTotalDimension + +!---------------------------------------------------------------------------- +! setTotalDimension +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vec3D_setTotalDimension + obj%tDimension = tDimension +END PROCEDURE Vec3D_setTotalDimension + +!---------------------------------------------------------------------------- +! ALLOCATE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE allocate_data + obj%Val=0.0_DFP + CALL setTotalDimension( obj, 1_I4B ) +END PROCEDURE allocate_data + +!---------------------------------------------------------------------------- +! DEALLOCATE +!---------------------------------------------------------------------------- + +MODULE PROCEDURE deallocate_data + obj%Val=0.0_DFP + CALL setTotalDimension( obj, 1_I4B ) +END PROCEDURE deallocate_data + + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE initiate_obj_from_val + SELECT CASE( SIZE( Val ) ) + CASE( 1 ) + obj%Val(1) = Val(1) + obj%Val(2) = 0.0_DFP + obj%Val(3) = 0.0_DFP + CASE( 2 ) + obj%Val(1) = Val(1) + obj%Val(2) = Val(2) + obj%Val(3) = 0.0_DFP + CASE DEFAULT + obj%Val = Val( 1:3 ) + END SELECT +END PROCEDURE initiate_obj_from_val + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE initiate_obj_from_obj + obj%Val = Anotherobj%Val +END PROCEDURE initiate_obj_from_obj + +!---------------------------------------------------------------------------- +! Vector3D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor1 + Ans = Val +END PROCEDURE Constructor1 + +!---------------------------------------------------------------------------- +! Vector3D_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor_1 + ALLOCATE( Ans ) + CALL Initiate(obj=Ans, Val=Val) +END PROCEDURE Constructor_1 + +!---------------------------------------------------------------------------- +! Vector3D_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Constructor_2 + ALLOCATE( Ans ) + CALL Initiate( obj=Ans, Anotherobj=obj ) +END PROCEDURE Constructor_2 + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Display_obj + INTEGER( I4B ) :: i + i = Input(default=stdout, option=unitNo) + CALL Display( Val=obj%Val, msg=msg, UnitNo = i) +END PROCEDURE Display_obj + +END SUBMODULE Constructor diff --git a/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 b/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 new file mode 100644 index 000000000..5bfa06525 --- /dev/null +++ b/src/submodules/Vector3D/src/Vector3D_Method@Misc.F90 @@ -0,0 +1,152 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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: 24 Feb 2021 +! summary: This submodule implements the methods of [[Vector3D_]] which are defined in [[Vector3D_Method]] module. + +SUBMODULE(Vector3D_Method) Misc +USE BaseMethod +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! DOT_PRODUCT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dot_product_1 + Ans = DOT_PRODUCT( obj1%Val, obj2%Val ) +END PROCEDURE dot_product_1 + +!---------------------------------------------------------------------------- +! DOT_PRODUCT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dot_product_2 + IF( SIZE( Val ) .LT. 3 ) THEN + Ans = DOT_PRODUCT( obj, Vector3D( Val ) ) + ELSE + Ans = DOT_PRODUCT( obj%Val, Val(1:3) ) + END IF +END PROCEDURE dot_product_2 + +!---------------------------------------------------------------------------- +! DOT_PRODUCT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dot_product_3 + Ans = DOT_PRODUCT(obj=obj, Val=Val) +END PROCEDURE dot_product_3 + +!---------------------------------------------------------------------------- +! DOT_PRODUCT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE dot_product_4 + Ans = DOT_PRODUCT(VECTOR_PRODUCT(v, w), u) +END PROCEDURE dot_product_4 + +!---------------------------------------------------------------------------- +! Vector_Product +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_product_1 + Ans = Vector_Product(obj1%val, obj2%val) +END PROCEDURE vector_product_1 + +!---------------------------------------------------------------------------- +! Vector_Product +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_product_2 + IF( SIZE( Val ) .LT. 3 ) THEN + Ans = VECTOR_PRODUCT( obj, Vector3D( Val ) ) + ELSE + Ans = VECTOR_PRODUCT( obj%Val, Val(1:3) ) + END IF +END PROCEDURE vector_product_2 + +!---------------------------------------------------------------------------- +! Vector_Product +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_product_3 + Ans = VECTOR_PRODUCT(obj=obj, Val=Val) +END PROCEDURE vector_product_3 + +!---------------------------------------------------------------------------- +! Vector_Product +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_product_4 + Ans = DOT_PRODUCT( u%val, w%val ) * v%val- DOT_PRODUCT( u%val, v%val ) * w%val +END PROCEDURE vector_product_4 + +!---------------------------------------------------------------------------- +! Norm2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Norm2_obj + Ans = SQRT( DOT_PRODUCT( obj%Val, obj%Val ) ) +END PROCEDURE Norm2_obj + +!---------------------------------------------------------------------------- +! UnitVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_UnitVector + Ans = obj%Val / NORM2( obj%Val ) +END PROCEDURE get_UnitVector + +!---------------------------------------------------------------------------- +! Angle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_angle + Ans = ACOS( DOT_PRODUCT( u, v ) / NORM2(u) / NORM2(v) ) +END PROCEDURE get_angle + +!---------------------------------------------------------------------------- +! ProjectionVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_projection_vector_obj + Ans = (DOT_PRODUCT( u, v ) / DOT_PRODUCT( v, v )) * v%val +END PROCEDURE get_projection_vector_obj + +!---------------------------------------------------------------------------- +! Normal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getNormal_Vector + Ans = u%val - (DOT_PRODUCT( u, v ) / DOT_PRODUCT( v, v )) * v%val +END PROCEDURE getNormal_Vector + +!---------------------------------------------------------------------------- +! Projection +!---------------------------------------------------------------------------- + +MODULE PROCEDURE get_projection_obj + Ans = DOT_PRODUCT( u, v ) / NORM2( v ) +END PROCEDURE get_projection_obj + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Misc \ No newline at end of file diff --git a/src/submodules/VoigtRank2Tensor/CMakeLists.txt b/src/submodules/VoigtRank2Tensor/CMakeLists.txt new file mode 100644 index 000000000..7353ba725 --- /dev/null +++ b/src/submodules/VoigtRank2Tensor/CMakeLists.txt @@ -0,0 +1,14 @@ +# This file is a part of easifem-base +# (c) 2021, Vikas Sharma, Ph.D. +# All right reserved +# +# log +# 23/02/2021 this file was created +#----------------------------------------------------------------------- + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/VoigtRank2Tensor_Method@Constructor.F90 + ${src_path}/VoigtRank2Tensor_Method@IO.F90 +) diff --git a/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 b/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 new file mode 100644 index 000000000..f715326d6 --- /dev/null +++ b/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@Constructor.F90 @@ -0,0 +1,125 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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(VoigtRank2Tensor_Method) Constructor +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE init_from_vec +ASSOCIATE( V => obj%V, Scale => obj%Scale ) + V = 0.0_DFP + obj%VoigtType = VoigtType + V( 1:6 ) = Vec( 1:6 ) + SELECT CASE( VoigtType ) + CASE( StrainTypeVoigt ) + Scale = 0.5_DFP + CASE( StressTypeVoigt ) + Scale = 1.0_DFP + END SELECT +END ASSOCIATE +END PROCEDURE init_from_vec + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE init_from_mat +ASSOCIATE( V => obj%V, Scale => obj%Scale ) + obj%VoigtType = VoigtType + V( 1 ) = T( 1, 1 ) + V( 2 ) = T( 2, 2 ) + V( 3 ) = T( 3, 3 ) + V( 4 ) = T( 1, 2 ) + T( 2, 1 ) + V( 5 ) = T( 2, 3 ) + T( 3, 2 ) + V( 6 ) = T( 1, 3 ) + T( 3, 1 ) + SELECT CASE( VoigtType ) + CASE( StressTypeVoigt ) + Scale = 1.0_DFP + V( 4 : 6 ) = 0.5_DFP * V( 4 : 6 ) + CASE( StrainTypeVoigt ) + Scale = 0.5_DFP + END SELECT +END ASSOCIATE +END PROCEDURE init_from_mat + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor +!---------------------------------------------------------------------------- + +MODULE PROCEDURE constructor1 + CALL Initiate( Ans, Vec, VoigtType ) +END PROCEDURE constructor1 + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor +!---------------------------------------------------------------------------- + +MODULE PROCEDURE constructor2 + CALL Initiate( obj=Ans, T=T, VoigtType=VoigtType ) +END PROCEDURE constructor2 + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE constructor_1 + ALLOCATE( Ans ) + CALL Initiate( obj=Ans, Vec=Vec, VoigtType = VoigtType ) +END PROCEDURE constructor_1 + +!---------------------------------------------------------------------------- +! VoigtRank2Tensor_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE constructor_2 + ALLOCATE( Ans ) + CALL Initiate( obj=Ans, T=T, VoigtType=VoigtType ) +END PROCEDURE constructor_2 + +!---------------------------------------------------------------------------- +! Assignment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE mat_eq_obj + ASSOCIATE( V => obj%V, Scale => obj%Scale ) + T = 0.0_DFP + T( 1, 1 ) = V( 1 ) + T( 2, 2 ) = V( 2 ) + T( 3, 3 ) = V( 3 ) + T( 1, 2 ) = Scale * V( 4 ) + T( 2, 1 ) = T( 1, 2 ) + T( 2, 3 ) = Scale * V( 5 ) + T( 3, 2 ) = T( 2, 3 ) + T( 1, 3 ) = Scale * V( 6 ) + T( 3, 1 ) = T( 1, 3 ) + END ASSOCIATE +END PROCEDURE mat_eq_obj + +!---------------------------------------------------------------------------- +! Assignment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vec_eq_obj + vec = obj%V +END PROCEDURE vec_eq_obj + +END SUBMODULE Constructor diff --git a/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 b/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 new file mode 100644 index 000000000..39c2df052 --- /dev/null +++ b/src/submodules/VoigtRank2Tensor/src/VoigtRank2Tensor_Method@IO.F90 @@ -0,0 +1,42 @@ +! This program is a part of EASIFEM library, +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D, +! +! This program is free software: you can redistribute it and/or modify, +! it under the terms of the GNU General Public License as published by, +! the Free Software Foundation, either version 3 of the License, or, +! (at your option) any later version., +! +! This program is distributed in the hope that it will be useful,, +! but WITHOUT ANY WARRANTY; without even the implied warranty of, +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the, +! GNU General 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(VoigtRank2Tensor_Method) IO +Use BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE display_obj + INTEGER( I4B ) :: I, j + ASSOCIATE( V => obj%V ) + I = INPUT( option=UnitNo, Default=StdOut ) + WRITE( I, "(A)" ) "# " // TRIM( Msg ) + SELECT CASE( obj%VoigtType ) + CASE( StressTypeVoigt ) + WRITE( I, "(A)" ) "Stress Like Voigt Type" + CASE( StrainTypeVoigt ) + WRITE( I, "(A)" ) "Strain Like Voigt Type" + END SELECT + CALL Display( Val = V, UnitNo=I, Msg="", orient = "row") + END ASSOCIATE +END PROCEDURE display_obj + +END SUBMODULE IO From d9483112a85235ac793fbd5e8651e9e5a14f3b7d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 09:12:19 +0900 Subject: [PATCH 050/359] updates in ReferenceLine_Methods --- .../Geometry/src/ReferenceLine_Method.F90 | 21 +++--- .../src/ReferenceLine_Method@Methods.F90 | 64 ++++++++++++------- 2 files changed, 53 insertions(+), 32 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Geometry/src/ReferenceLine_Method.F90 index 4a9e9b0e9..a609e48b0 100644 --- a/src/modules/Geometry/src/ReferenceLine_Method.F90 +++ b/src/modules/Geometry/src/ReferenceLine_Method.F90 @@ -20,10 +20,16 @@ ! summary: This submodule contains method for [[ReferenceLine_]] MODULE ReferenceLine_Method -USE BaseType -USE GlobalData +USE BaseType, ONLY: ReferenceTopology_, & + ReferenceElement_, & + ReferenceLine_ + +USE GlobalData, ONLY: I4B, DFP, LGT + IMPLICIT NONE + PRIVATE + PUBLIC :: Initiate PUBLIC :: ReferenceLine PUBLIC :: ReferenceLine_Pointer @@ -54,11 +60,11 @@ MODULE ReferenceLine_Method #endif #ifdef REF_LINE_IS_UNIT -REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = & - & RESHAPE([0, 0, 0, 1, 0, 0], [3, 2]) +REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = & + RESHAPE([0, 0, 0, 1, 0, 0], [3, 2]) #else -REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = & - & RESHAPE([-1, 0, 0, 1, 0, 0], [3, 2]) +REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = & + RESHAPE([-1, 0, 0, 1, 0, 0], [3, 2]) #endif !---------------------------------------------------------------------------- @@ -351,8 +357,7 @@ END FUNCTION Reference_Line_Pointer_1 !``` INTERFACE - MODULE SUBROUTINE HighOrderElement_Line(refelem, order, obj, & - & ipType) + MODULE SUBROUTINE HighOrderElement_Line(refelem, order, obj, ipType) CLASS(ReferenceElement_), INTENT(IN) :: refelem !! Linear line element INTEGER(I4B), INTENT(IN) :: order diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 index 918998090..2c2b10e85 100644 --- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 @@ -20,15 +20,29 @@ ! summary: This submodule contains methods for [[ReferenceLine_]] SUBMODULE(ReferenceLine_Method) Methods -USE ReallocateUtility -USE ReferenceElement_Method -USE StringUtility -USE ApproxUtility + +USE GlobalData, ONLY: Line, Line1, Line2, Line3, Line4, Line5, & + Line6, Point1, Equidistance + +USE ReallocateUtility, ONLY: Reallocate + +USE ReferenceElement_Method, ONLY: ReferenceTopology, & + ElementType, DEALLOCATE + +USE StringUtility, ONLY: UpperCase + +USE ApproxUtility, ONLY: OPERATOR(.approxeq.) + USE String_Class, ONLY: String -USE LineInterpolationUtility -USE Display_Method -USE InputUtility + +USE LineInterpolationUtility, ONLY: InterpolationPoint_Line + +USE Display_Method, ONLY: ToString + +USE InputUtility, ONLY: Input + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -61,11 +75,11 @@ MODULE PROCEDURE FacetTopology_Line ans(1)%nptrs = nptrs([1]) ans(1)%xiDimension = 0 -ans(1)%name = Point +ans(1)%name = Point1 ans(2)%nptrs = nptrs([2]) ans(2)%xiDimension = 0 -ans(2)%name = Point +ans(2)%name = Point1 END PROCEDURE FacetTopology_Line !---------------------------------------------------------------------------- @@ -83,7 +97,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE TotalNodesInElement_Line -SELECT CASE (ElemType) +SELECT CASE (elemType) CASE (Line1) ans = 1 CASE (Line2) @@ -129,7 +143,7 @@ MODULE PROCEDURE ElementType_Line SELECT CASE (elemName) CASE ("Line1", "Point", "Point1") - ans = Point + ans = Point1 CASE ("Line2", "Line") ans = Line2 CASE ("Line3") @@ -159,12 +173,12 @@ ans(ii)%xij(1:3, 1) = DEFAULT_REF_LINE_COORD(1:3, ii) ans(ii)%entityCounts = [1, 0, 0, 0] ans(ii)%xiDimension = 0 - ans(ii)%name = Point + ans(ii)%name = Point1 ans(ii)%interpolationPointType = refelem%interpolationPointType ans(ii)%order = 0 ans(ii)%nsd = refelem%nsd ALLOCATE (ans(ii)%topology(1)) - ans(ii)%topology(1) = Referencetopology(nptrs=nptrs, name=Point) + ans(ii)%topology(1) = Referencetopology(nptrs=nptrs, name=Point1) ans(ii)%highOrderElement => NULL() END DO END PROCEDURE FacetElements_Line1 @@ -181,12 +195,12 @@ ans(ii)%xij = RESHAPE(DEFAULT_REF_LINE_COORD(1:3, ii), [3, 1]) ans(ii)%entityCounts = [1, 0, 0, 0] ans(ii)%xiDimension = 0 - ans(ii)%name = Point + ans(ii)%name = Point1 ans(ii)%interpolationPointType = Equidistance ans(ii)%order = 0 ans(ii)%nsd = nsd ALLOCATE (ans(ii)%topology(1)) - ans(ii)%topology(1) = Referencetopology(nptrs=nptrs(ii:ii), name=Point) + ans(ii)%topology(1) = Referencetopology(nptrs=nptrs(ii:ii), name=Point1) ans(ii)%highOrderElement => NULL() END DO END PROCEDURE FacetElements_Line2 @@ -251,8 +265,8 @@ obj%nsd = nsd obj%name = Line2 ALLOCATE (obj%topology(3)) -obj%topology(1) = ReferenceTopology([1], Point) -obj%topology(2) = ReferenceTopology([2], Point) +obj%topology(1) = ReferenceTopology([1], Point1) +obj%topology(2) = ReferenceTopology([2], Point1) obj%topology(3) = ReferenceTopology([1, 2], Line2) obj%highorderElement => highorderElement_Line END PROCEDURE Initiate_ref_Line @@ -262,7 +276,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reference_Line -CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) +CALL Initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) END PROCEDURE Reference_Line !---------------------------------------------------------------------------- @@ -271,7 +285,7 @@ MODULE PROCEDURE Reference_Line_Pointer_1 ALLOCATE (obj) -CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) +CALL Initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName) END PROCEDURE Reference_Line_Pointer_1 !---------------------------------------------------------------------------- @@ -280,11 +294,13 @@ MODULE PROCEDURE HighorderElement_Line INTEGER(I4B) :: nns, i + obj%xij = InterpolationPoint_Line( & - & xij=refelem%xij, & - & order=order, & - & ipType=ipType, & - & layout="VEFC") + xij=refelem%xij, & + order=order, & + ipType=ipType, & + layout="VEFC") + obj%domainName = refelem%domainName obj%nsd = refelem%nsd nns = SIZE(obj%xij, 2) @@ -294,7 +310,7 @@ obj%name = ElementType("Line"//ToString(nns)) ALLOCATE (obj%topology(nns + 1)) DO CONCURRENT(i=1:nns) - obj%topology(i) = ReferenceTopology([i], Point) + obj%topology(i) = ReferenceTopology([i], Point1) END DO obj%topology(nns + 1) = ReferenceTopology([(i, i=1, nns)], obj%name) END PROCEDURE HighorderElement_Line From 6a8eb884c7dcc2a3a06ab61199ab0ffa5be48507 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 18 Jun 2024 15:02:35 +0900 Subject: [PATCH 051/359] updates in ReferenceQuadrangle --- .../src/ReferenceQuadrangle_Method.F90 | 20 +++-- .../ReferenceQuadrangle_Method@Methods.F90 | 76 +++++++++++-------- 2 files changed, 56 insertions(+), 40 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 index 09f3e2cd3..4756e86b4 100644 --- a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 +++ b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 @@ -20,11 +20,15 @@ ! summary: This module contains methods for [[ReferenceQuadrangle_]] MODULE ReferenceQuadrangle_Method -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT + USE BaseType, ONLY: ReferenceQuadrangle_, ReferenceElement_, & ReferenceTopology_ + IMPLICIT NONE + PRIVATE + PUBLIC :: Initiate PUBLIC :: ReferenceQuadrangle PUBLIC :: ReferenceQuadrangle_Pointer @@ -254,8 +258,8 @@ END FUNCTION reference_Quadrangle ! summary: Returns linear Quadrangle element INTERFACE ReferenceQuadrangle_Pointer - MODULE FUNCTION reference_Quadrangle_Pointer(NSD, xij, domainName) & - & RESULT(obj) + MODULE FUNCTION reference_Quadrangle_Pointer(NSD, xij, domainName) & + RESULT(obj) INTEGER(I4B), INTENT(IN) :: NSD REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName @@ -287,7 +291,7 @@ END FUNCTION reference_Quadrangle_Pointer INTERFACE MODULE SUBROUTINE HighorderElement_Quadrangle(refelem, order, obj, & - & ipType) + ipType) CLASS(ReferenceElement_), INTENT(IN) :: refelem INTEGER(I4B), INTENT(IN) :: order CLASS(ReferenceElement_), INTENT(INOUT) :: obj @@ -448,8 +452,8 @@ END FUNCTION RefQuadrangleCoord ! summary: Returns meta data for global orientation of face INTERFACE - MODULE SUBROUTINE FaceShapeMetaData_Quadrangle(face, sorted_face, & - & faceOrient, localFaces) + MODULE SUBROUTINE FaceShapeMetaData_Quadrangle(face, sorted_face, & + faceOrient, localFaces) INTEGER(I4B), INTENT(INOUT) :: face(:) INTEGER(I4B), INTENT(INOUT) :: sorted_face(:) INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceOrient(:) @@ -466,8 +470,8 @@ END SUBROUTINE FaceShapeMetaData_Quadrangle ! summary: Returns the element type of each face INTERFACE -MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, opt, & - tFaceNodes) + MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, & + opt, tFaceNodes) INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType !! name of element INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 index c73f7bbf7..c4cf08816 100644 --- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 @@ -20,23 +20,40 @@ ! summary: This submodule contains method for [[ReferenceQuadrangle_]] SUBMODULE(ReferenceQuadrangle_Method) Methods -USE ReferenceElement_Method + +USE GlobalData, ONLY: Quadrangle, Quadrangle4, Quadrangle8, Quadrangle9, & + Quadrangle16, Point, Line2, Equidistance, INT8 + +USE ReferenceElement_Method, ONLY: ReferenceTopology, DEALLOCATE, & + ReferenceElement_Initiate => Initiate + USE LineInterpolationUtility, ONLY: InterpolationPoint_Line + USE ReferenceLine_Method, ONLY: ElementOrder_Line, LineName USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle, & LagrangeDOF_Quadrangle + USE ReferenceTriangle_Method, ONLY: TRIANGLEAREA2D + USE ReferenceLine_Method, ONLY: Linename, ElementType_Line -USE ApproxUtility +USE ApproxUtility, ONLY: OPERATOR(.approxeq.) + USE AppendUtility -USE StringUtility -USE ArangeUtility -USE InputUtility -USE SortUtility -USE ReallocateUtility -USE Display_Method + +USE StringUtility, ONLY: UpperCase + +USE ArangeUtility, ONLY: Arange + +USE InputUtility, ONLY: Input + +USE SortUtility, ONLY: Sort + +USE ReallocateUtility, ONLY: Reallocate + +USE Display_Method, ONLY: ToString + USE MiscUtility, ONLY: Int2Str IMPLICIT NONE @@ -71,8 +88,8 @@ order = ElementOrder_Quadrangle(elemType) CALL Reallocate(con, order + 1, 4) -CALL GetEdgeConnectivity_Quadrangle(con=con, & - & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) +CALL GetEdgeConnectivity_Quadrangle(con=con, & + opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) lineType = ElementType_Line("Line"//Int2Str(order + 1)) DO ii = 1, 4 @@ -99,7 +116,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE TotalNodesInElement_Quadrangle -SELECT CASE (ElemType) +SELECT CASE (elemType) CASE (Quadrangle4) ans = 4 CASE (Quadrangle8) @@ -118,7 +135,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ElementOrder_Quadrangle -SELECT CASE (ElemType) +SELECT CASE (elemType) CASE (Quadrangle4) ans = 1 CASE (Quadrangle8) @@ -159,10 +176,10 @@ istart = refelem%entityCounts(1) -ans(1)%xij = InterpolationPoint_Line( & - & order=refelem%order, & - & ipType=refelem%interpolationPointType, & - & layout="VEFC") +ans(1)%xij = InterpolationPoint_Line( & + order=refelem%order, & + ipType=refelem%interpolationPointType, & + layout="VEFC") ans(1)%interpolationPointType = refelem%interpolationPointType ans(1)%nsd = refelem%nsd @@ -205,8 +222,8 @@ order = ElementOrder_Quadrangle(elemType) CALL Reallocate(edgeCon, order + 1, 4) -CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, & - & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) +CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, & + opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order) !! The edges are accordign to gmsh !! [1,2], [2,3], [3,4], [4,1] @@ -216,22 +233,20 @@ ans(ii)%order = order ans(ii)%name = ElementType_Line("Line"//tostring(order + 1)) ans(ii)%interpolationPointType = Equidistance - ans(ii)%xij = InterpolationPoint_Line( & - & order=order, & - & ipType=Equidistance, & - & layout="VEFC") + ans(ii)%xij = InterpolationPoint_Line(order=order, ipType=Equidistance, & + layout="VEFC") ans(ii)%nsd = nsd ans(ii)%entityCounts = [order + 1, 1, 0, 0] ALLOCATE (ans(ii)%topology(order + 2)) DO jj = 1, order + 1 - ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), & - & name=Point) + ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), & + name=Point) END DO - ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), & - & name=ans(ii)%name) + ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), & + name=ans(ii)%name) END DO @@ -337,13 +352,10 @@ CALL DEALLOCATE (obj) SELECT CASE (order) CASE (1) - CALL Initiate(obj=obj, Anotherobj=refelem) + CALL ReferenceElement_Initiate(obj=obj, Anotherobj=refelem) CASE DEFAULT - obj%xij = InterpolationPoint_Quadrangle( & - & xij=refelem%xij, & - & order=order, & - & ipType=ipType, & - & layout="VEFC") + obj%xij = InterpolationPoint_Quadrangle(xij=refelem%xij, order=order, & + ipType=ipType, layout="VEFC") obj%domainName = refelem%domainName NNS = LagrangeDOF_Quadrangle(order=order) obj%entityCounts = [NNS, 4, 1, 0] From 90430f7b13a3543562cafc7b9dd3ac351bdb292a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Jun 2024 13:25:30 +0900 Subject: [PATCH 052/359] Minor updates in LagrangePolynomialUtility --- .../src/LagrangePolynomialUtility.F90 | 50 ++++--------------- 1 file changed, 11 insertions(+), 39 deletions(-) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index a5c151d8c..c8f71d0a8 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -49,7 +49,7 @@ MODULE LagrangePolynomialUtility INTERFACE MODULE FUNCTION RefElemDomain(elemType, baseContinuity, baseInterpol) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: elemType !! Element type CHARACTER(*), INTENT(IN) :: baseContinuity @@ -144,7 +144,7 @@ END FUNCTION LagrangeDegree INTERFACE MODULE PURE FUNCTION LagrangeVandermonde(xij, order, elemType) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: xij(:, :) !! points in $x_{iJ}$ format INTEGER(I4B), INTENT(IN) :: order @@ -192,11 +192,7 @@ END SUBROUTINE LagrangeVandermonde_ ! summary: Equidistance points on 1D/2D/3D elements INTERFACE - MODULE FUNCTION EquidistancePoint( & - & order, & - & elemType, & - & xij) & - & RESULT(ans) + MODULE FUNCTION EquidistancePoint(order, elemType, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of element INTEGER(I4B), INTENT(IN) :: elemType @@ -228,15 +224,8 @@ END FUNCTION EquidistancePoint ! summary: Get the interpolation point INTERFACE - MODULE FUNCTION InterpolationPoint( & - & order, & - & elemType, & - & ipType, & - & xij, & - & layout, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION InterpolationPoint(order, elemType, ipType, xij, layout, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of interpolation INTEGER(I4B), INTENT(IN) :: elemType @@ -319,7 +308,7 @@ END FUNCTION LagrangeCoeff2 INTERFACE LagrangeCoeff MODULE FUNCTION LagrangeCoeff3(order, elemType, i, v, & - & isVandermonde) RESULT(ans) + isVandermonde) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial, it should be SIZE(v,2)-1 INTEGER(I4B), INTENT(IN) :: elemType @@ -340,8 +329,7 @@ END FUNCTION LagrangeCoeff3 !---------------------------------------------------------------------------- INTERFACE LagrangeCoeff - MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) & - & RESULT(ans) + MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial, it should be SIZE(x,2)-1 INTEGER(I4B), INTENT(IN) :: elemType @@ -362,16 +350,8 @@ END FUNCTION LagrangeCoeff4 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll - MODULE FUNCTION LagrangeEvalAll1( & - & order, & - & elemType, & - & x, & - & xij, & - & domainName, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll1(order, elemType, x, xij, domainName, & + coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials INTEGER(I4B), INTENT(IN) :: elemType @@ -408,16 +388,8 @@ END FUNCTION LagrangeEvalAll1 !---------------------------------------------------------------------------- INTERFACE LagrangeGradientEvalAll - MODULE FUNCTION LagrangeGradientEvalAll1( & - & order, & - & elemType, & - & x, & - & xij, & - & domainName, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeGradientEvalAll1(order, elemType, x, xij, & + domainName, coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials INTEGER(I4B), INTENT(IN) :: elemType From ef7aa4d922e4896aeb72bde7a4baa450a82c9cc7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Jun 2024 13:26:05 +0900 Subject: [PATCH 053/359] Updates in BaseType --- src/modules/BaseType/src/BaseType.F90 | 93 ++++++++++++++++++++++++++- 1 file changed, 92 insertions(+), 1 deletion(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 5385572b3..adb0d44e4 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -189,6 +189,9 @@ MODULE BaseType PUBLIC :: iface_MatrixFunction PUBLIC :: Range_ PUBLIC :: Interval1D_ +PUBLIC :: TypePrecondOpt +PUBLIC :: TypeConvergenceOpt +PUBLIC :: TypeSolverNameOpt INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 @@ -1594,7 +1597,7 @@ END SUBROUTINE highorder_refelem !> author: Vikas Sharma, Ph. D. ! date: 4 Sept 2022 -! summary: Multi-indices object is defined +! summary: Multi-indices object is definedstringclass TYPE :: MultiIndices_ INTEGER(I4B) :: d @@ -1745,4 +1748,92 @@ PURE FUNCTION iface_MatrixFunction(x) RESULT(ans) END FUNCTION iface_MatrixFunction END INTERFACE +!---------------------------------------------------------------------------- +! TypePreconOpt +!---------------------------------------------------------------------------- + +TYPE :: PrecondOpt_ + INTEGER(I4B) :: NONE = NO_PRECONDITION + INTEGER(I4B) :: left = LEFT_PRECONDITION + INTEGER(I4B) :: right = RIGHT_PRECONDITION + INTEGER(I4B) :: both = LEFT_RIGHT_PRECONDITION + INTEGER(I4B) :: jacobi = PRECOND_JACOBI + INTEGER(I4B) :: ilu = PRECOND_ILU + INTEGER(I4B) :: ssor = PRECOND_SSOR + INTEGER(I4B) :: hybrid = PRECOND_HYBRID + INTEGER(I4B) :: is = PRECOND_IS + INTEGER(I4B) :: sainv = PRECOND_SAINV + INTEGER(I4B) :: saamg = PRECOND_SAAMG + INTEGER(I4B) :: iluc = PRECOND_ILUC + INTEGER(I4B) :: adds = PRECOND_ADDS + INTEGER(I4B) :: ilutp = PRECOND_ILUTP + INTEGER(I4B) :: ilud = PRECOND_ILUD + INTEGER(I4B) :: iludp = PRECOND_ILUDP + INTEGER(I4B) :: ilu0 = PRECOND_ILU0 + INTEGER(I4B) :: iluk = PRECOND_ILUK + INTEGER(I4B) :: ilut = PRECOND_ILUT +END TYPE PrecondOpt_ + +TYPE(PrecondOpt_), PARAMETER :: TypePrecondOpt = PrecondOpt_() + +!---------------------------------------------------------------------------- +! TypePreconOpt +!---------------------------------------------------------------------------- + +TYPE :: ConvergenceOpt_ + INTEGER(I4B) :: res = convergenceInRes + INTEGER(I4B) :: sol = convergenceInSol + INTEGER(I4B) :: both = convergenceInResSol + INTEGER(I4B) :: relative = relativeConvergence + INTEGER(I4B) :: absolute = absoluteConvergence +END TYPE ConvergenceOpt_ + +TYPE(ConvergenceOpt_), PARAMETER :: TypeConvergenceOpt = ConvergenceOpt_() + +!---------------------------------------------------------------------------- +! SolverNameOpt_ +!---------------------------------------------------------------------------- + +TYPE SolverNameOpt_ + INTEGER(I4B) :: cg = LIS_CG + INTEGER(I4B) :: bcg = LIS_BCG + INTEGER(I4B) :: bicg = LIS_BICG + INTEGER(I4B) :: cgs = LIS_CGS + INTEGER(I4B) :: bcgstab = LIS_BCGSTAB + INTEGER(I4B) :: bicgstab = LIS_BICGSTAB + INTEGER(I4B) :: bicgstabl = LIS_BICGSTABL + INTEGER(I4B) :: gpbicg = LIS_GPBICG + INTEGER(I4B) :: tfqmr = LIS_TFQMR + INTEGER(I4B) :: omn = LIS_OMN + INTEGER(I4B) :: fom = LIS_FOM + INTEGER(I4B) :: orthomin = LIS_ORTHOMIN + INTEGER(I4B) :: gmres = LIS_GMRES + INTEGER(I4B) :: gmr = LIS_GMR + INTEGER(I4B) :: jacobi = LIS_JACOBI + INTEGER(I4B) :: gs = LIS_GS + INTEGER(I4B) :: sor = LIS_SOR + INTEGER(I4B) :: bicgsafe = LIS_BICGSAFE + INTEGER(I4B) :: cr = LIS_CR + INTEGER(I4B) :: bicr = LIS_BICR + INTEGER(I4B) :: crs = LIS_CRS + INTEGER(I4B) :: bicrstab = LIS_BICRSTAB + INTEGER(I4B) :: gpbicr = LIS_GPBICR + INTEGER(I4B) :: bicrsafe = LIS_BICRSAFE + INTEGER(I4B) :: fgmres = LIS_FGMRES + INTEGER(I4B) :: idrs = LIS_IDRS + INTEGER(I4B) :: idr1 = LIS_IDR1 + INTEGER(I4B) :: minres = LIS_MINRES + INTEGER(I4B) :: cocg = LIS_COCG + INTEGER(I4B) :: cocr = LIS_COCR + INTEGER(I4B) :: cgnr = LIS_CGNR + INTEGER(I4B) :: cgn = LIS_CGN + INTEGER(I4B) :: dbcg = LIS_DBCG + INTEGER(I4B) :: dbicg = LIS_DBICG + INTEGER(I4B) :: dqgmres = LIS_DQGMRES + INTEGER(I4B) :: superlu = LIS_SUPERLU +END TYPE SolverNameOpt_ + +TYPE(SolverNameOpt_), PARAMETER :: TypeSolverNameOpt = & + SolverNameOpt_() + END MODULE BaseType From 6f0f6abbdc4e575fa46ad858e2a271c1a10facf7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Jun 2024 13:26:31 +0900 Subject: [PATCH 054/359] Removing some bugs in CSRMatrix_GetMethods@Methods --- .../src/CSRMatrix_GetMethods@Methods.F90 | 36 +++++++++++++------ 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 index d87d4cf31..f41ca5305 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 @@ -160,21 +160,37 @@ MODULE PROCEDURE obj_Get0 ! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) +INTEGER(I4B), ALLOCATABLE :: indx(:) INTEGER(I4B) :: ii, jj -row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum) -col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum) -VALUE = 0.0_DFP -DO ii = 1, SIZE(row) - DO jj = 1, SIZE(col) - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), & - & icolumn=col(jj)) +nrow = .tdof. (obj%csr%idof) +nrow = nrow * SIZE(nodenum) + +ncol = .tdof. (obj%csr%jdof) +ncol = ncol * SIZE(nodenum) + +ALLOCATE (indx(nrow + ncol)) + +CALL GetIndex_(obj=obj%csr%idof, nodeNum=nodenum, & + ans=indx(1:), tsize=ii) + +CALL GetIndex_(obj=obj%csr%jdof, nodeNum=nodenum, & + ans=indx(nrow + 1:), tsize=ii) + +! row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum) +! col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum) + +VALUE(1:nrow, 1:ncol) = 0.0_DFP + +DO ii = 1, nrow + DO jj = 1, ncol + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=indx(ii), & + icolumn=indx(nrow + jj)) END DO END DO -IF (ALLOCATED(row)) DEALLOCATE (row) -IF (ALLOCATED(col)) DEALLOCATE (col) +DEALLOCATE (indx) + END PROCEDURE obj_Get0 !---------------------------------------------------------------------------- From 873540ba3a7904e80f653831be3804b05542ad91 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Jun 2024 13:49:56 +0900 Subject: [PATCH 055/359] Minor updates in ReferenceElement_Method --- .../Geometry/src/ReferenceElement_Method.F90 | 24 +++++++- ...eferenceElement_Method@GeometryMethods.F90 | 60 ++++++++++++++++--- 2 files changed, 75 insertions(+), 9 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index 58a0500c0..4a410b019 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -75,6 +75,7 @@ MODULE ReferenceElement_Method PUBLIC :: GetElementIndex PUBLIC :: Reallocate PUBLIC :: RefTopoReallocate +PUBLIC :: RefCoord INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_FACES = 6 INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_EDGES = 12 @@ -129,8 +130,27 @@ MODULE ReferenceElement_Method !! number of nodes in each face of tetrahedron END TYPE ReferenceElementInfo_ -TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = & - & ReferenceElementInfo_() +TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = & + ReferenceElementInfo_() + +!---------------------------------------------------------------------------- +! RefCoord +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE PURE FUNCTION RefCoord(elemType, refElem) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type + CHARACTER(*), INTENT(IN) :: refElem + !! "UNIT" + !! "BIUNIT" + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION RefCoord +END INTERFACE !---------------------------------------------------------------------------- ! GetElementIndex@GeometryMethods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 index 545047406..fa416a8ee 100644 --- a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 +++ b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 @@ -28,7 +28,8 @@ TotalEntities_Line, & GetFaceElemType_Line, & GetEdgeConnectivity_Line, & - GetFaceConnectivity_Line + GetFaceConnectivity_Line, & + RefCoord_Line USE ReferenceTriangle_Method, ONLY: Measure_Simplex_Triangle, & Triangle_quality, & @@ -37,7 +38,8 @@ TotalNodesInElement_Triangle, & TotalEntities_Triangle, & GetFaceConnectivity_Triangle, & - GetFaceElemType_Triangle + GetFaceElemType_Triangle, & + RefCoord_Triangle USE ReferenceQuadrangle_Method, ONLY: Measure_Simplex_Quadrangle, & Quadrangle_quality, & @@ -45,7 +47,8 @@ TotalNodesInElement_Quadrangle, & TotalEntities_Quadrangle, & GetFaceConnectivity_Quadrangle, & - GetFaceElemType_Quadrangle + GetFaceElemType_Quadrangle, & + RefCoord_Quadrangle USE ReferenceTetrahedron_Method, ONLY: Measure_Simplex_Tetrahedron, & Tetrahedron_quality, & @@ -53,7 +56,8 @@ GetFaceConnectivity_Tetrahedron, & GetFaceElemType_Tetrahedron, & TotalNodesInElement_Tetrahedron, & - TotalEntities_Tetrahedron + TotalEntities_Tetrahedron, & + RefCoord_Tetrahedron USE ReferenceHexahedron_Method, ONLY: Measure_Simplex_Hexahedron, & Hexahedron_quality, & @@ -61,7 +65,8 @@ GetFaceConnectivity_Hexahedron, & GetFaceElemType_Hexahedron, & TotalNodesInElement_Hexahedron, & - TotalEntities_Hexahedron + TotalEntities_Hexahedron, & + RefCoord_Hexahedron USE ReferencePrism_Method, ONLY: Measure_Simplex_Prism, & Prism_quality, & @@ -69,7 +74,8 @@ GetFaceConnectivity_Prism, & GetFaceElemType_Prism, & TotalNodesInElement_Prism, & - TotalEntities_Prism + TotalEntities_Prism, & + RefCoord_Prism USE ReferencePyramid_Method, ONLY: Measure_Simplex_Pyramid, & Pyramid_quality, & @@ -77,11 +83,51 @@ GetFaceConnectivity_Pyramid, & GetFaceElemType_Pyramid, & TotalNodesInElement_Pyramid, & - TotalEntities_Pyramid + TotalEntities_Pyramid, & + RefCoord_Pyramid IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! RefCoord +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefCoord +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) + ALLOCATE (ans(3, 1)) + ans = 0.0_DFP + +CASE (Line) + ans = RefCoord_Line(refElem) + +CASE (Triangle) + ans = RefCoord_Triangle(refElem) + +CASE (Quadrangle) + ans = RefCoord_Quadrangle(refElem) + +CASE (Tetrahedron) + ans = RefCoord_Tetrahedron(refElem) + +CASE (Hexahedron) + ans = RefCoord_Hexahedron(refElem) + +CASE (Prism) + ans = RefCoord_Prism(refElem) + +CASE (Pyramid) + ans = RefCoord_Pyramid(refElem) + +END SELECT +END PROCEDURE RefCoord + !---------------------------------------------------------------------------- ! GetElementIndex !---------------------------------------------------------------------------- From 9f49b4c7e9d22d1254f3ff5b1fcb8c9a9e868817 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Jun 2024 13:50:13 +0900 Subject: [PATCH 056/359] Minor updates in InterpolationUtility --- .../Polynomial/src/InterpolationUtility.F90 | 26 ++++++++ .../src/InterpolationUtility@Methods.F90 | 65 +++++++++++++++++-- 2 files changed, 84 insertions(+), 7 deletions(-) diff --git a/src/modules/Polynomial/src/InterpolationUtility.F90 b/src/modules/Polynomial/src/InterpolationUtility.F90 index fc76c2f07..d2e860faa 100644 --- a/src/modules/Polynomial/src/InterpolationUtility.F90 +++ b/src/modules/Polynomial/src/InterpolationUtility.F90 @@ -17,11 +17,14 @@ MODULE InterpolationUtility USE GlobalData, ONLY: I4B, DFP, REAL32, REAL64 +USE String_Class, ONLY: String + IMPLICIT NONE PRIVATE PUBLIC :: VandermondeMatrix PUBLIC :: GetTotalInDOF PUBLIC :: GetTotalDOF +PUBLIC :: RefElemDomain !---------------------------------------------------------------------------- ! @@ -93,4 +96,27 @@ MODULE PURE FUNCTION GetTotalInDOF1(elemType, order, baseContinuity, & END FUNCTION GetTotalInDOF1 END INTERFACE GetTotalInDOF +!---------------------------------------------------------------------------- +! RefElemDomain +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain(elemType, baseContinuity, baseInterpol) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type + CHARACTER(*), INTENT(IN) :: baseContinuity + !! Cointinuity (conformity) of basis functions + !! "H1", "HDiv", "HCurl", "DG" + CHARACTER(*), INTENT(IN) :: baseInterpol + !! Basis function family for Interpolation + !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal + TYPE(String) :: ans + END FUNCTION RefElemDomain +END INTERFACE + END MODULE InterpolationUtility diff --git a/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 index 93e179fd5..53351e70a 100644 --- a/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 @@ -20,20 +20,34 @@ Tetrahedron, Hexahedron, Prism, Pyramid USE ReferenceElement_Method, ONLY: ElementTopology + USE LineInterpolationUtility, ONLY: GetTotalDOF_Line, & - GetTotalInDOF_Line + GetTotalInDOF_Line, & + RefElemDomain_Line + USE TriangleInterpolationUtility, ONLY: GetTotalDOF_Triangle, & - GetTotalInDOF_Triangle + GetTotalInDOF_Triangle, & + RefElemDomain_Triangle + USE QuadrangleInterpolationUtility, ONLY: GetTotalDOF_Quadrangle, & - GetTotalInDOF_Quadrangle + GetTotalInDOF_Quadrangle, & + RefElemDomain_Quadrangle + USE TetrahedronInterpolationUtility, ONLY: GetTotalDOF_Tetrahedron, & - GetTotalInDOF_Tetrahedron + GetTotalInDOF_Tetrahedron, & + RefElemDomain_Tetrahedron + USE HexahedronInterpolationUtility, ONLY: GetTotalDOF_Hexahedron, & - GetTotalInDOF_Hexahedron + GetTotalInDOF_Hexahedron, & + RefElemDomain_Hexahedron + USE PrismInterpolationUtility, ONLY: GetTotalDOF_Prism, & - GetTotalInDOF_Prism + GetTotalInDOF_Prism, & + RefElemDomain_Prism + USE PyramidInterpolationUtility, ONLY: GetTotalDOF_Pyramid, & - GetTotalInDOF_Pyramid + GetTotalInDOF_Pyramid, & + RefElemDomain_Pyramid IMPLICIT NONE CONTAINS @@ -146,4 +160,41 @@ END PROCEDURE GetTotalInDOF1 +!---------------------------------------------------------------------------- +! RefElemDomain +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = "" + +CASE (Line) + ans = RefElemDomain_Line(baseContinuity, baseInterpol) + +CASE (Triangle) + ans = RefElemDomain_Triangle(baseContinuity, baseInterpol) + +CASE (Quadrangle) + ans = RefElemDomain_Quadrangle(baseContinuity, baseInterpol) + +CASE (Tetrahedron) + ans = RefElemDomain_Tetrahedron(baseContinuity, baseInterpol) + +CASE (Hexahedron) + ans = RefElemDomain_Hexahedron(baseContinuity, baseInterpol) + +CASE (Prism) + ans = RefElemDomain_Prism(baseContinuity, baseInterpol) + +CASE (Pyramid) + ans = RefElemDomain_Pyramid(baseContinuity, baseInterpol) +END SELECT + +END PROCEDURE RefElemDomain + END SUBMODULE Methods From 4e6c366c229736de3237b18d600abb7d6d4f355c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Jun 2024 13:50:25 +0900 Subject: [PATCH 057/359] Minor Updates in LagrangePolynomialUtility --- .../src/LagrangePolynomialUtility.F90 | 44 -------- .../src/LagrangePolynomialUtility@Methods.F90 | 104 ++---------------- 2 files changed, 7 insertions(+), 141 deletions(-) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index c8f71d0a8..fc224af91 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -34,53 +34,9 @@ MODULE LagrangePolynomialUtility PUBLIC :: EquidistancePoint PUBLIC :: InterpolationPoint PUBLIC :: LagrangeCoeff -PUBLIC :: RefCoord -PUBLIC :: RefElemDomain PUBLIC :: LagrangeEvalAll PUBLIC :: LagrangeGradientEvalAll -!---------------------------------------------------------------------------- -! RefElemDomain -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain(elemType, baseContinuity, baseInterpol) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - !! Element type - CHARACTER(*), INTENT(IN) :: baseContinuity - !! Cointinuity (conformity) of basis functions - !! "H1", "HDiv", "HCurl", "DG" - CHARACTER(*), INTENT(IN) :: baseInterpol - !! Basis function family for Interpolation - !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal - TYPE(String) :: ans - END FUNCTION RefElemDomain -END INTERFACE - -!---------------------------------------------------------------------------- -! RefCoord -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE PURE FUNCTION RefCoord(elemType, refElem) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - !! Element type - CHARACTER(*), INTENT(IN) :: refElem - !! "UNIT" - !! "BIUNIT" - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION RefCoord -END INTERFACE - !---------------------------------------------------------------------------- ! LagrangeDOF@BasisMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index d08340e69..a047cba63 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -23,16 +23,7 @@ USE ReferenceElement_Method, ONLY: ElementTopology -USE ReferenceLine_Method, ONLY: RefCoord_Line -USE ReferenceTriangle_Method, ONLY: RefCoord_Triangle -USE ReferenceQuadrangle_Method, ONLY: RefCoord_Quadrangle -USE ReferenceTetrahedron_Method, ONLY: RefCoord_Tetrahedron -USE ReferenceHexahedron_Method, ONLY: RefCoord_Hexahedron -USE ReferencePrism_Method, ONLY: RefCoord_Prism -USE ReferencePyramid_Method, ONLY: RefCoord_Pyramid - -USE LineInterpolationUtility, ONLY: RefElemDomain_Line, & - LagrangeDOF_Line, & +USE LineInterpolationUtility, ONLY: LagrangeDOF_Line, & LagrangeInDOF_Line, & LagrangeDegree_Line, & EquidistancePoint_Line, & @@ -41,8 +32,7 @@ LagrangeEvalAll_Line, & LagrangeGradientEvalAll_Line -USE TriangleInterpolationUtility, ONLY: RefElemDomain_Triangle, & - LagrangeDOF_Triangle, & +USE TriangleInterpolationUtility, ONLY: LagrangeDOF_Triangle, & LagrangeInDOF_Triangle, & LagrangeDegree_Triangle, & EquidistancePoint_Triangle, & @@ -51,8 +41,7 @@ LagrangeEvalAll_Triangle, & LagrangeGradientEvalAll_Triangle -USE QuadrangleInterpolationUtility, ONLY: RefElemDomain_Quadrangle, & - LagrangeDOF_Quadrangle, & +USE QuadrangleInterpolationUtility, ONLY: LagrangeDOF_Quadrangle, & LagrangeInDOF_Quadrangle, & LagrangeDegree_Quadrangle, & EquidistancePoint_Quadrangle, & @@ -61,8 +50,7 @@ LagrangeEvalAll_Quadrangle, & LagrangeGradientEvalAll_Quadrangle -USE TetrahedronInterpolationUtility, ONLY: RefElemDomain_Tetrahedron, & - LagrangeDOF_Tetrahedron, & +USE TetrahedronInterpolationUtility, ONLY: LagrangeDOF_Tetrahedron, & LagrangeInDOF_Tetrahedron, & LagrangeDegree_Tetrahedron, & EquidistancePoint_Tetrahedron, & @@ -71,8 +59,7 @@ LagrangeEvalAll_Tetrahedron, & LagrangeGradientEvalAll_Tetrahedron -USE HexahedronInterpolationUtility, ONLY: RefElemDomain_Hexahedron, & - LagrangeDOF_Hexahedron, & +USE HexahedronInterpolationUtility, ONLY: LagrangeDOF_Hexahedron, & LagrangeInDOF_Hexahedron, & LagrangeDegree_Hexahedron, & EquidistancePoint_Hexahedron, & @@ -81,8 +68,7 @@ LagrangeEvalAll_Hexahedron, & LagrangeGradientEvalAll_Hexahedron -USE PrismInterpolationUtility, ONLY: RefElemDomain_Prism, & - LagrangeDOF_Prism, & +USE PrismInterpolationUtility, ONLY: LagrangeDOF_Prism, & LagrangeInDOF_Prism, & LagrangeDegree_Prism, & EquidistancePoint_Prism, & @@ -91,8 +77,7 @@ LagrangeEvalAll_Prism, & LagrangeGradientEvalAll_Prism -USE PyramidInterpolationUtility, ONLY: RefElemDomain_Pyramid, & - LagrangeDOF_Pyramid, & +USE PyramidInterpolationUtility, ONLY: LagrangeDOF_Pyramid, & LagrangeInDOF_Pyramid, & LagrangeDegree_Pyramid, & EquidistancePoint_Pyramid, & @@ -108,81 +93,6 @@ IMPLICIT NONE CONTAINS -!---------------------------------------------------------------------------- -! RefElemDomain -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - ans = "" - -CASE (Line) - ans = RefElemDomain_Line(baseContinuity, baseInterpol) - -CASE (Triangle) - ans = RefElemDomain_Triangle(baseContinuity, baseInterpol) - -CASE (Quadrangle) - ans = RefElemDomain_Quadrangle(baseContinuity, baseInterpol) - -CASE (Tetrahedron) - ans = RefElemDomain_Tetrahedron(baseContinuity, baseInterpol) - -CASE (Hexahedron) - ans = RefElemDomain_Hexahedron(baseContinuity, baseInterpol) - -CASE (Prism) - ans = RefElemDomain_Prism(baseContinuity, baseInterpol) - -CASE (Pyramid) - ans = RefElemDomain_Pyramid(baseContinuity, baseInterpol) -END SELECT - -END PROCEDURE RefElemDomain - -!---------------------------------------------------------------------------- -! RefCoord -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefCoord -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) - -CASE (Point) - CALL Reallocate(ans, 3_I4B, 1_I4B) - -CASE (Line) - ans = RefCoord_Line(refElem) - -CASE (Triangle) - ans = RefCoord_Triangle(refElem) - -CASE (Quadrangle) - ans = RefCoord_Quadrangle(refElem) - -CASE (Tetrahedron) - ans = RefCoord_Tetrahedron(refElem) - -CASE (Hexahedron) - ans = RefCoord_Hexahedron(refElem) - -CASE (Prism) - ans = RefCoord_Prism(refElem) - -CASE (Pyramid) - ans = RefCoord_Pyramid(refElem) - -END SELECT -END PROCEDURE RefCoord - !---------------------------------------------------------------------------- ! LagrangeDOF !---------------------------------------------------------------------------- From acb1c6bff0b0aa931ca6797d3e993d07872015a7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 26 Jun 2024 13:34:14 +0900 Subject: [PATCH 058/359] Updates in SortUtility --- src/modules/Utility/src/SortUtility.F90 | 258 +++++++++--------------- 1 file changed, 90 insertions(+), 168 deletions(-) diff --git a/src/modules/Utility/src/SortUtility.F90 b/src/modules/Utility/src/SortUtility.F90 index 392e60538..d7e6ce42d 100644 --- a/src/modules/Utility/src/SortUtility.F90 +++ b/src/modules/Utility/src/SortUtility.F90 @@ -16,7 +16,8 @@ ! MODULE SortUtility -USE GlobalData +USE GlobalData, ONLY: INT8, INT16, INT32, INT64, REAL32, REAL64, & + I4B, DFP IMPLICIT NONE PRIVATE @@ -38,7 +39,7 @@ MODULE SortUtility ! date: 2023-06-27 ! summary: Sorting by insertion algorithm -INTERFACE +INTERFACE IntroSort MODULE PURE SUBROUTINE IntroSort_Int8(array) INTEGER(INT8), INTENT(INOUT) :: array(:) END SUBROUTINE IntroSort_Int8 @@ -57,16 +58,6 @@ END SUBROUTINE IntroSort_Real32 MODULE PURE SUBROUTINE IntroSort_Real64(array) REAL(REAL64), INTENT(INOUT) :: array(:) END SUBROUTINE IntroSort_Real64 -END INTERFACE - -INTERFACE IntroSort - MODULE PROCEDURE & - & IntroSort_Int8, & - & IntroSort_Int16, & - & IntroSort_Int32, & - & IntroSort_Int64, & - & IntroSort_Real32, & - & IntroSort_Real64 END INTERFACE IntroSort !---------------------------------------------------------------------------- @@ -77,7 +68,7 @@ END SUBROUTINE IntroSort_Real64 ! date: 2023-06-27 ! summary: Indirect sorting by insertion sort -INTERFACE +INTERFACE ArgIntroSort MODULE PURE SUBROUTINE ArgIntroSort_Int8(array, arg) INTEGER(INT8), INTENT(IN) :: array(:) INTEGER(I4B), INTENT(INOUT) :: arg(:) @@ -107,16 +98,6 @@ MODULE PURE SUBROUTINE ArgIntroSort_Real64(array, arg) REAL(REAL64), INTENT(IN) :: array(:) INTEGER(I4B), INTENT(INOUT) :: arg(:) END SUBROUTINE ArgIntroSort_Real64 -END INTERFACE - -INTERFACE ArgIntroSort - MODULE PROCEDURE & - & ArgIntroSort_Int8, & - & ArgIntroSort_Int16, & - & ArgIntroSort_Int32, & - & ArgIntroSort_Int64, & - & ArgIntroSort_Real32, & - & ArgIntroSort_Real64 END INTERFACE ArgIntroSort !---------------------------------------------------------------------------- @@ -127,7 +108,7 @@ END SUBROUTINE ArgIntroSort_Real64 ! date: 2023-06-27 ! summary: Sorting by insertion algorithm -INTERFACE +INTERFACE InsertionSort MODULE PURE SUBROUTINE InsertionSort_Int8(array, low, high) INTEGER(INT8), INTENT(INOUT) :: array(:) INTEGER(I4B), INTENT(IN) :: low @@ -158,16 +139,6 @@ MODULE PURE SUBROUTINE InsertionSort_Real64(array, low, high) INTEGER(I4B), INTENT(IN) :: low INTEGER(I4B), INTENT(IN) :: high END SUBROUTINE InsertionSort_Real64 -END INTERFACE - -INTERFACE InsertionSort - MODULE PROCEDURE & - & InsertionSort_Int8, & - & InsertionSort_Int16, & - & InsertionSort_Int32, & - & InsertionSort_Int64, & - & InsertionSort_Real32, & - & InsertionSort_Real64 END INTERFACE InsertionSort !---------------------------------------------------------------------------- @@ -178,7 +149,7 @@ END SUBROUTINE InsertionSort_Real64 ! date: 2023-06-27 ! summary: Indirect sorting by insertion sort -INTERFACE +INTERFACE ArgInsertionSort MODULE PURE SUBROUTINE ArgInsertionSort_Int8(array, arg, low, high) INTEGER(INT8), INTENT(IN) :: array(:) INTEGER(I4B), INTENT(INOUT) :: arg(:) @@ -220,16 +191,6 @@ MODULE PURE SUBROUTINE ArgInsertionSort_Real64(array, arg, low, high) INTEGER(I4B), INTENT(IN) :: low INTEGER(I4B), INTENT(IN) :: high END SUBROUTINE ArgInsertionSort_Real64 -END INTERFACE - -INTERFACE ArgInsertionSort - MODULE PROCEDURE & - & ArgInsertionSort_Int8, & - & ArgInsertionSort_Int16, & - & ArgInsertionSort_Int32, & - & ArgInsertionSort_Int64, & - & ArgInsertionSort_Real32, & - & ArgInsertionSort_Real64 END INTERFACE ArgInsertionSort !---------------------------------------------------------------------------- @@ -240,7 +201,7 @@ END SUBROUTINE ArgInsertionSort_Real64 ! date: 22 March 2021 ! summary: Heap Sort -INTERFACE +INTERFACE HeapSort MODULE PURE SUBROUTINE HeapSort_Int8(array) INTEGER(INT8), INTENT(INOUT) :: array(:) END SUBROUTINE HeapSort_Int8 @@ -259,11 +220,6 @@ END SUBROUTINE HeapSort_Real32 MODULE PURE SUBROUTINE HeapSort_Real64(array) REAL(REAL64), INTENT(INOUT) :: array(:) END SUBROUTINE HeapSort_Real64 -END INTERFACE - -INTERFACE HeapSort - MODULE PROCEDURE HeapSort_Int8, HeapSort_Int16, HeapSort_Int32, & - & HeapSort_Int64, HeapSort_Real32, HeapSort_Real64 END INTERFACE HeapSort !---------------------------------------------------------------------------- @@ -274,7 +230,7 @@ END SUBROUTINE HeapSort_Real64 ! date: 22 March 2021 ! summary: Heap Sort -INTERFACE +INTERFACE ArgHeapSort MODULE PURE SUBROUTINE ArgHeapSort_Int8(array, arg) INTEGER(INT8), INTENT(IN) :: array(:) INTEGER(I4B), INTENT(OUT) :: arg(0:) @@ -304,18 +260,13 @@ MODULE PURE SUBROUTINE ArgHeapSort_Real64(array, arg) REAL(REAL64), INTENT(IN) :: array(:) INTEGER(I4B), INTENT(OUT) :: arg(0:) END SUBROUTINE ArgHeapSort_Real64 -END INTERFACE - -INTERFACE ArgHeapSort - MODULE PROCEDURE ArgHeapSort_Int8, ArgHeapSort_Int16, ArgHeapSort_Int32, & - & ArgHeapSort_Int64, ArgHeapSort_Real32, ArgHeapSort_Real64 END INTERFACE ArgHeapSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt8(vect1, low, high) INTEGER(INT8), INTENT(INOUT) :: vect1(:) INTEGER(I4B), INTENT(IN) :: low, high @@ -340,388 +291,369 @@ MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectReal64(vect1, low, high) REAL(REAL64), INTENT(INOUT) :: vect1(:) INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE QuickSort1vectReal64 -END INTERFACE - -INTERFACE QuickSort - MODULE PROCEDURE QuickSort1vectInt8, QuickSort1vectInt16, & - & QuickSort1vectInt32, QuickSort1vectInt64 - MODULE PROCEDURE QuickSort1vectReal32, QuickSort1vectReal64 END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE RECURSIVE PURE SUBROUTINE QuickSort2vectIR(vect1, vect2, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectII(vect1, vect2, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRI(vect1, vect2, low, high) REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRR(vect1, vect2, low, high) REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIII(vect1, vect2, vect3, & - & low, high) + low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIIR(vect1, vect2, vect3, & - & low, high) + low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRR(vect1, vect2, vect3, & - & low, high) + low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRI(vect1, vect2, vect3, & - & low, high) + low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRR(vect1, vect2, vect3, & - & low, high) + low, high) REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRI(vect1, vect2, vect3, & - & low, high) + low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRIR(vect1, vect2, vect3, & - & low, high) + low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRII(vect1, vect2, vect3, & - & low, high) + low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIII(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIIR(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRI(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRR(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRR(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRI(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect4 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRIR(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRII(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRR(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRI(vect1, vect2, & - & vect3, vect4, low, high) + vect3, vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect4 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRIR(vect1, vect2, & - & vect3, vect4, low, high) + vect3, vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRII(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3, vect4 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRR(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRI(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect4 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIIR(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect4 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE +END INTERFACE QuickSort !---------------------------------------------------------------------------- ! QuickSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE QuickSort MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIII(vect1, vect2, vect3, & - & vect4, low, high) + vect4, low, high) INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4 REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1 INTEGER(I4B), INTENT(IN) :: low, high END SUBROUTINE -END INTERFACE - -INTERFACE QuickSort - MODULE PROCEDURE QuickSort2vectII, & - & QuickSort2vectIR, QuickSort2vectRR, QuickSort2vectRI, & - & QuickSort3vectIII, QuickSort3vectIIR, QuickSort3vectIRI, & - & QuickSort3vectIRR, QuickSort3vectRRR, QuickSort3vectRRI, & - & QuickSort3vectRIR, QuickSort3vectRII, QuickSort4vectIIII, & - & QuickSort4vectIIIR, QuickSort4vectIIRI, QuickSort4vectIIRR, & - & QuickSort4vectIRII, QuickSort4vectIRIR, QuickSort4vectIRRI, & - & QuickSort4vectIRRR, QuickSort4vectRIII, QuickSort4vectRIIR, & - & QuickSort4vectRIRI, QuickSort4vectRIRR, QuickSort4vectRRII, & - & QuickSort4vectRRIR, QuickSort4vectRRRI, QuickSort4vectRRRR END INTERFACE QuickSort !---------------------------------------------------------------------------- ! Sort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE Sort MODULE PURE FUNCTION Sort_Int8(x, name) RESULT(ans) INTEGER(INT8), INTENT(IN) :: x(:) CHARACTER(*), OPTIONAL, INTENT(IN) :: name @@ -752,18 +684,13 @@ MODULE PURE FUNCTION Sort_Real64(x, name) RESULT(ans) CHARACTER(*), OPTIONAL, INTENT(IN) :: name REAL(REAL64) :: ans(SIZE(x)) END FUNCTION Sort_Real64 -END INTERFACE - -INTERFACE Sort - MODULE PROCEDURE Sort_Int8, Sort_Int16, Sort_Int32, Sort_Int64 - MODULE PROCEDURE Sort_Real32, Sort_Real64 END INTERFACE Sort !---------------------------------------------------------------------------- ! ArgSort !---------------------------------------------------------------------------- -INTERFACE +INTERFACE ArgSort MODULE PURE FUNCTION ArgSort_Int8(x, name) RESULT(ans) INTEGER(INT8), INTENT(IN) :: x(:) CHARACTER(*), OPTIONAL, INTENT(IN) :: name @@ -794,11 +721,6 @@ MODULE PURE FUNCTION ArgSort_Real64(x, name) RESULT(ans) CHARACTER(*), OPTIONAL, INTENT(IN) :: name INTEGER(I4B) :: ans(SIZE(x)) END FUNCTION ArgSort_Real64 -END INTERFACE - -INTERFACE ArgSort - MODULE PROCEDURE ArgSort_Int8, ArgSort_Int16, ArgSort_Int32, ArgSort_Int64 - MODULE PROCEDURE ArgSort_Real32, ArgSort_Real64 END INTERFACE ArgSort !---------------------------------------------------------------------------- From b588fdc49466ebea526a17670a19316fa3c8a870 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 26 Jun 2024 13:36:09 +0900 Subject: [PATCH 059/359] Updates in SortUtility --- src/submodules/Utility/src/SortUtility@Methods.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/submodules/Utility/src/SortUtility@Methods.F90 b/src/submodules/Utility/src/SortUtility@Methods.F90 index e4e198cf1..8561b6c01 100644 --- a/src/submodules/Utility/src/SortUtility@Methods.F90 +++ b/src/submodules/Utility/src/SortUtility@Methods.F90 @@ -20,8 +20,16 @@ ! summary: This submodule contains the sorting routine SUBMODULE(SortUtility) Methods -USE BaseMethod, ONLY: Swap, UpperCase, arange, Median, Partition, & -& ArgPartition, ArgMedian +USE SwapUtility, ONLY: Swap + +USE StringUtility, ONLY: UpperCase + +USE ArangeUtility, ONLY: Arange + +USE MedianUtility, ONLY: Median, ArgMedian + +USE PartitionUtility, ONLY: Partition, ArgPartition + IMPLICIT NONE INTEGER(I4B), PARAMETER :: minimumLengthForInsertion = 16 From 2bcdcfa1d136d84782355df0bdb672da502cce67 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 26 Jun 2024 14:17:04 +0900 Subject: [PATCH 060/359] Updates in MappingUtility --- src/modules/Utility/src/MappingUtility.F90 | 55 +++++++++++++++---- .../Utility/src/MappingUtility@Methods.F90 | 22 ++++++++ 2 files changed, 67 insertions(+), 10 deletions(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 9ad5c7125..e212c1453 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -27,6 +27,7 @@ MODULE MappingUtility PRIVATE PUBLIC :: FromBiunitLine2Segment +PUBLIC :: FromBiunitLine2Segment_ PUBLIC :: FromBiUnitLine2UnitLine PUBLIC :: FromUnitLine2BiUnitLine PUBLIC :: FromLine2Line_ @@ -97,7 +98,7 @@ MODULE MappingUtility ! date: 19 Oct 2022 ! summary: Map from unit line to physical space -INTERFACE +INTERFACE FromBiunitLine2Segment MODULE PURE FUNCTION FromBiunitLine2Segment1(xin, x1, x2) RESULT(ans) REAL(DFP), INTENT(IN) :: xin(:) !! coordinates in [-1,1] @@ -108,12 +109,26 @@ MODULE PURE FUNCTION FromBiunitLine2Segment1(xin, x1, x2) RESULT(ans) REAL(DFP) :: ans(SIZE(xin)) !! mapped coordinates of xin in physical domain END FUNCTION FromBiunitLine2Segment1 -END INTERFACE - -INTERFACE FromBiunitLine2Segment - MODULE PROCEDURE FromBiunitLine2Segment1 END INTERFACE FromBiunitLine2Segment +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment_ +!---------------------------------------------------------------------------- + +INTERFACE FromBiunitLine2Segment_ + MODULE PURE SUBROUTINE FromBiunitLine2Segment1_(xin, x1, x2, ans, tsize) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in [-1,1] + REAL(DFP), INTENT(IN) :: x1 + !! x1 of physical domain + REAL(DFP), INTENT(IN) :: x2 + !! x2 of physical domain + REAL(DFP), INTENT(INOUT) :: ans(:) + !! mapped coordinates of xin in physical domain + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE FromBiunitLine2Segment1_ +END INTERFACE FromBiunitLine2Segment_ + !---------------------------------------------------------------------------- ! FromBiunitLine2Segment !---------------------------------------------------------------------------- @@ -122,7 +137,7 @@ END FUNCTION FromBiunitLine2Segment1 ! date: 19 Oct 2022 ! summary: Map from unit line to physical space -INTERFACE +INTERFACE FromBiunitLine2Segment MODULE PURE FUNCTION FromBiunitLine2Segment2(xin, x1, x2) RESULT(ans) REAL(DFP), INTENT(IN) :: xin(:) !! coordinates in [-1,1], SIZE(xin) = n @@ -134,12 +149,32 @@ MODULE PURE FUNCTION FromBiunitLine2Segment2(xin, x1, x2) RESULT(ans) !! returned coordinates in physical space !! ans is in xij format END FUNCTION FromBiunitLine2Segment2 -END INTERFACE - -INTERFACE FromBiunitLine2Segment - MODULE PROCEDURE FromBiunitLine2Segment2 END INTERFACE FromBiunitLine2Segment +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: from bi unit line to segment wo allocation + +INTERFACE FromBiunitLine2Segment_ + MODULE PURE SUBROUTINE FromBiunitLine2Segment2_(xin, x1, x2, ans, nrow, & + ncol) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in [-1,1], SIZE(xin) = n + REAL(DFP), INTENT(IN) :: x1(:) + !! x1 of physical domain, SIZE(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! x2 of physical domain, SIZE(x2) = nsd + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates in physical space + !! ans is in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE FromBiunitLine2Segment2_ +END INTERFACE FromBiunitLine2Segment_ + !---------------------------------------------------------------------------- ! FromUnitTriangle2Triangle !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index c5dbf2273..a41438ba3 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -40,6 +40,15 @@ ! FromBiunitLine2Segment !---------------------------------------------------------------------------- +MODULE PROCEDURE FromBiunitLine2Segment1_ +tsize = SIZE(xin) +ans(1:tsize) = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin +END PROCEDURE FromBiunitLine2Segment1_ + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + MODULE PROCEDURE FromBiunitLine2Segment2 INTEGER(I4B) :: ii DO ii = 1, SIZE(xin) @@ -47,6 +56,19 @@ END DO END PROCEDURE FromBiunitLine2Segment2 +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiunitLine2Segment2_ +INTEGER(I4B) :: ii +nrow = SIZE(x1) +ncol = SIZE(xin) +DO ii = 1, ncol + ans(1:nrow, ii) = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin(ii) +END DO +END PROCEDURE FromBiunitLine2Segment2_ + !---------------------------------------------------------------------------- ! FromBiUnitLine2UnitLine !---------------------------------------------------------------------------- From a29e1562c37d9fbc93cfb4fd1bd062bacafac2d2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 26 Jun 2024 15:54:57 +0900 Subject: [PATCH 061/359] updates in line LineInterpolationUtility --- .../src/LineInterpolationUtility.F90 | 276 +++++--- .../src/LineInterpolationUtility@Methods.F90 | 670 ++++++++++-------- 2 files changed, 564 insertions(+), 382 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index dda86c81d..8e1bac4bd 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -30,6 +30,7 @@ MODULE LineInterpolationUtility PUBLIC :: EquidistanceInPoint_Line PUBLIC :: EquidistancePoint_Line PUBLIC :: InterpolationPoint_Line +PUBLIC :: InterpolationPoint_Line_ PUBLIC :: LagrangeCoeff_Line PUBLIC :: LagrangeEvalAll_Line PUBLIC :: LagrangeGradientEvalAll_Line @@ -232,6 +233,21 @@ MODULE PURE FUNCTION EquidistanceInPoint_Line1(order, xij) RESULT(ans) END FUNCTION EquidistanceInPoint_Line1 END INTERFACE EquidistanceInPoint_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EquidistanceInPoint_Line_ + MODULE PURE SUBROUTINE EquidistanceInPoint_Line1_(order, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(IN) :: xij(2) + !! coordinates of point 1 and point 2 + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE EquidistanceInPoint_Line1_ +END INTERFACE EquidistanceInPoint_Line_ + !---------------------------------------------------------------------------- ! EquidistanceInPoint_Line !---------------------------------------------------------------------------- @@ -264,6 +280,27 @@ MODULE PURE FUNCTION EquidistanceInPoint_Line2(order, xij) RESULT(ans) END FUNCTION EquidistanceInPoint_Line2 END INTERFACE EquidistanceInPoint_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EquidistanceInPoint_Line_ + MODULE PURE SUBROUTINE EquidistanceInPoint_Line2_(order, xij, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 2 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Equidistnace points in $x_{iJ}$ format + !! The number of rows is equal to the number of rows in xij + !! (if xij present), otherwise, it is 1. + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE EquidistanceInPoint_Line2_ +END INTERFACE EquidistanceInPoint_Line_ + !---------------------------------------------------------------------------- ! EquidistancePoint_Line !---------------------------------------------------------------------------- @@ -289,6 +326,22 @@ MODULE PURE FUNCTION EquidistancePoint_Line1(order, xij) & END FUNCTION EquidistancePoint_Line1 END INTERFACE EquidistancePoint_Line +!---------------------------------------------------------------------------- +! EquidistancePoint_Line_ +!---------------------------------------------------------------------------- + +INTERFACE EquidistancePoint_Line_ + MODULE PURE SUBROUTINE EquidistancePoint_Line1_(order, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(IN) :: xij(2) + !! coorindates of point 1 and point 2 + REAL(DFP), INTENT(INOUT) :: ans(:) + !! equidistance points + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE EquidistancePoint_Line1_ +END INTERFACE EquidistancePoint_Line_ + !---------------------------------------------------------------------------- ! EquidistancePoint_Line !---------------------------------------------------------------------------- @@ -319,6 +372,27 @@ MODULE PURE FUNCTION EquidistancePoint_Line2(order, xij) & END FUNCTION EquidistancePoint_Line2 END INTERFACE EquidistancePoint_Line +!---------------------------------------------------------------------------- +! EquidistancePoint_Line_ +!---------------------------------------------------------------------------- + +INTERFACE EquidistancePoint_Line_ + MODULE PURE SUBROUTINE EquidistancePoint_Line2_(order, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 2 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! equidistance points in $x_{iJ}$ format + !! If xij is not present, then number of rows in ans + !! is 1. If `xij` is present then the number of rows in + !! ans is same as xij. + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE EquidistancePoint_Line2_ +END INTERFACE EquidistancePoint_Line_ + !---------------------------------------------------------------------------- ! InterpolationPoint_Line !---------------------------------------------------------------------------- @@ -355,7 +429,7 @@ END FUNCTION EquidistancePoint_Line2 INTERFACE InterpolationPoint_Line MODULE FUNCTION InterpolationPoint_Line1(order, ipType, & - & layout, xij, alpha, beta, lambda) RESULT(ans) + layout, xij, alpha, beta, lambda) RESULT(ans) !! INTEGER(I4B), INTENT(IN) :: order !! Order of interpolation @@ -381,6 +455,43 @@ MODULE FUNCTION InterpolationPoint_Line1(order, ipType, & END FUNCTION InterpolationPoint_Line1 END INTERFACE InterpolationPoint_Line +!---------------------------------------------------------------------------- +! InterpolationPoint_Line_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-25 +! summary: Interpolation without allocation + +INTERFACE InterpolationPoint_Line_ + MODULE SUBROUTINE InterpolationPoint_Line1_(order, ipType, ans, nrow, ncol, & + layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of interpolation + INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation point type + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in xij format + !! size(ans,1) = 1 + !! size(ans,2) = order+1 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! domain of interpolation + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Line1_ +END INTERFACE InterpolationPoint_Line_ + !---------------------------------------------------------------------------- ! InterpolationPoint_Line !---------------------------------------------------------------------------- @@ -391,7 +502,7 @@ END FUNCTION InterpolationPoint_Line1 INTERFACE InterpolationPoint_Line MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, & - & layout, alpha, beta, lambda) RESULT(ans) + layout, alpha, beta, lambda) RESULT(ans) !! INTEGER(I4B), INTENT(IN) :: order !! order of interpolation @@ -421,6 +532,38 @@ MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, & END FUNCTION InterpolationPoint_Line2 END INTERFACE InterpolationPoint_Line +!---------------------------------------------------------------------------- +! InterpolationPoint_Line_ +!---------------------------------------------------------------------------- + +INTERFACE InterpolationPoint_Line_ + MODULE SUBROUTINE InterpolationPoint_Line2_(order, ipType, ans, tsize, & + xij, layout, alpha, beta, lambda) + !! + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation point type + !! See TypeInterpolationOpt + REAL(DFP), INTENT(INOUT) :: ans(:) + !! one dimensional interpolation point + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + REAL(DFP), INTENT(IN) :: xij(2) + !! end points + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + !! "DECREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Line2_ +END INTERFACE InterpolationPoint_Line_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Line !---------------------------------------------------------------------------- @@ -499,7 +642,7 @@ END FUNCTION LagrangeCoeff_Line4 INTERFACE LagrangeCoeff_Line MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, & - & beta, lambda) RESULT(ans) + beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial, it should be SIZE(xij,2)-1 REAL(DFP), INTENT(IN) :: xij(:, :) @@ -534,8 +677,7 @@ END FUNCTION LagrangeCoeff_Line5 INTERFACE LagrangeEvalAll_Line MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, & - & basisType, alpha, beta, lambda) & - & RESULT(ans) + basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x @@ -575,10 +717,8 @@ END FUNCTION LagrangeEvalAll_Line1 ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeEvalAll_Line - MODULE FUNCTION LagrangeEvalAll_Line2( & - & order, x, xij, coeff, firstCall, & - & basisType, alpha, beta, lambda) & - & RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Line2(order, x, xij, coeff, firstCall, & + basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -625,14 +765,8 @@ END FUNCTION LagrangeEvalAll_Line2 ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeGradientEvalAll_Line - MODULE FUNCTION LagrangeGradientEvalAll_Line1( & - & order, & - & x, & - & xij, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeGradientEvalAll_Line1(order, x, xij, coeff, & + firstCall, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -679,14 +813,8 @@ END FUNCTION LagrangeGradientEvalAll_Line1 ! summary: Evaluate basis functions of order upto n INTERFACE BasisEvalAll_Line - MODULE FUNCTION BasisEvalAll_Line1( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION BasisEvalAll_Line1(order, x, refLine, basisType, alpha, & + beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x @@ -721,14 +849,8 @@ END FUNCTION BasisEvalAll_Line1 ! summary: Evaluate basis functions of order upto n INTERFACE BasisEvalAll_Line - MODULE FUNCTION BasisEvalAll_Line2( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION BasisEvalAll_Line2(order, x, refLine, basisType, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x(:) @@ -766,14 +888,8 @@ END FUNCTION BasisEvalAll_Line2 ! summary: Evaluate basis functions of order upto n INTERFACE OrthogonalBasis_Line - MODULE FUNCTION OrthogonalBasis_Line1( & - & order, & - & xij, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION OrthogonalBasis_Line1(order, xij, refLine, basisType, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: xij(:, :) @@ -811,14 +927,8 @@ END FUNCTION OrthogonalBasis_Line1 ! summary: Evaluate basis functions of order upto n INTERFACE OrthogonalBasisGradient_Line - MODULE FUNCTION OrthogonalBasisGradient_Line1( & - & order, & - & xij, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, & + basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: xij(:, :) @@ -880,10 +990,8 @@ END FUNCTION HeirarchicalBasis_Line1 ! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line INTERFACE HeirarchicalGradientBasis_Line - MODULE FUNCTION HeirarchicalGradientBasis_Line1( & - & order, & - & xij, & - & refLine) RESULT(ans) + MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation REAL(DFP), INTENT(IN) :: xij(:, :) @@ -908,14 +1016,8 @@ END FUNCTION HeirarchicalGradientBasis_Line1 ! summary: Evaluate the gradient of basis functions of order upto n INTERFACE BasisGradientEvalAll_Line - MODULE FUNCTION BasisGradientEvalAll_Line1( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION BasisGradientEvalAll_Line1(order, x, refLine, basisType, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x @@ -950,14 +1052,8 @@ END FUNCTION BasisGradientEvalAll_Line1 ! summary: Evaluate gradient of basis functions of order upto n INTERFACE BasisGradientEvalAll_Line - MODULE FUNCTION BasisGradientEvalAll_Line2( & - & order, & - & x, & - & refLine, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION BasisGradientEvalAll_Line2(order, x, refLine, basisType, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x(:) @@ -995,15 +1091,8 @@ END FUNCTION BasisGradientEvalAll_Line2 ! summary: Returns quadrature points INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line1( & - & order, & - & quadType, & - & layout, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - !! + MODULE FUNCTION QuadraturePoint_Line1(order, quadType, layout, xij, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of interpolation INTEGER(I4B), INTENT(IN) :: quadType @@ -1046,14 +1135,8 @@ END FUNCTION QuadraturePoint_Line1 ! summary: Returns the interpolation point INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line2( & - & order, & - & quadType, & - & xij, & - & layout, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Line2(order, quadType, xij, layout, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of interpolation INTEGER(I4B), INTENT(IN) :: quadType @@ -1090,15 +1173,8 @@ END FUNCTION QuadraturePoint_Line2 ! summary: Returns quadrature points INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line3( & - & nips, & - & quadType, & - & layout, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) - !! + MODULE FUNCTION QuadraturePoint_Line3(nips, quadType, layout, xij, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: nips(1) !! Order of interpolation INTEGER(I4B), INTENT(IN) :: quadType @@ -1141,14 +1217,8 @@ END FUNCTION QuadraturePoint_Line3 ! summary: Returns the interpolation point INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line4( & - & nips, & - & quadType, & - & xij, & - & layout, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Line4(nips, quadType, xij, layout, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: nips(1) !! order of interpolation INTEGER(I4B), INTENT(IN) :: quadType diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index ba2d7102b..489967b7b 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -114,230 +114,321 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistanceInPoint_Line1 -INTEGER(I4B) :: n, ii -REAL(DFP) :: avar +INTEGER(I4B) :: tsize + IF (order .LE. 1_I4B) THEN ALLOCATE (ans(0)) RETURN END IF -n = LagrangeInDOF_Line(order=order) -ALLOCATE (ans(n)) + +tsize = LagrangeInDOF_Line(order=order) +ALLOCATE (ans(tsize)) +CALL EquidistanceInPoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize) + +END PROCEDURE EquidistanceInPoint_Line1 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line1_ +INTEGER(I4B) :: ii +REAL(DFP) :: avar + +tsize = 0 +IF (order .LE. 1_I4B) RETURN + +tsize = LagrangeInDOF_Line(order=order) + avar = (xij(2) - xij(1)) / order -DO ii = 1, n - ans(ii) = xij(1) + ii * avar + +DO ii = 1, tsize + ans(ii) = xij(1) + REAL(ii, kind=dfp) * avar END DO -END PROCEDURE EquidistanceInPoint_Line1 + +END PROCEDURE EquidistanceInPoint_Line1_ !---------------------------------------------------------------------------- ! EquidistanceInPoint_Line !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistanceInPoint_Line2 -INTEGER(I4B) :: n, ii, nsd -REAL(DFP) :: x0(3, 2) -REAL(DFP) :: avar(3) +INTEGER(I4B) :: nrow, ncol + IF (order .LE. 1_I4B) THEN ALLOCATE (ans(0, 0)) RETURN END IF + IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x0(1:nsd, 1) = xij(1:nsd, 1) - x0(1:nsd, 2) = xij(1:nsd, 2) + nrow = SIZE(xij, 1) ELSE - nsd = 1_I4B - x0(1:nsd, 1) = [-1.0] - x0(1:nsd, 2) = [1.0] + nrow = 1_I4B END IF -n = LagrangeInDOF_Line(order=order) -ALLOCATE (ans(nsd, n)) -avar(1:nsd) = (x0(1:nsd, 2) - x0(1:nsd, 1)) / order -DO ii = 1, n - ans(1:nsd, ii) = x0(1:nsd, 1) + ii * avar(1:nsd) -END DO + +ncol = LagrangeInDOF_Line(order=order) + +ALLOCATE (ans(nrow, ncol)) + +CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) + END PROCEDURE EquidistanceInPoint_Line2 +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line2_ +INTEGER(I4B) :: ii +REAL(DFP) :: x0(3, 3) + +nrow = 0; ncol = 0 +IF (order .LE. 1_I4B) RETURN + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + x0(1:nrow, 1) = xij(1:nrow, 1) + x0(1:nrow, 2) = xij(1:nrow, 2) +ELSE + nrow = 1_I4B + x0(1, 1) = -1.0 + x0(1, 2) = 1.0 +END IF + +ncol = LagrangeInDOF_Line(order=order) + +x0(1:nrow, 3) = (x0(1:nrow, 2) - x0(1:nrow, 1)) / order + +DO ii = 1, ncol + ans(1:nrow, ii) = x0(1:nrow, 1) + ii * x0(1:nrow, 3) +END DO +END PROCEDURE EquidistanceInPoint_Line2_ + !---------------------------------------------------------------------------- ! EquidistancePoint_Line !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Line1 -CALL Reallocate(ans, order + 1) -IF (order .EQ. 0_I4B) THEN - ans(1) = 0.5_DFP * (xij(1) + xij(2)) - RETURN -END IF -ans(1) = xij(1) -ans(2) = xij(2) -IF (order .GE. 2) THEN - ans(3:) = EquidistanceInPoint_Line(order=order, xij=xij) -END IF +INTEGER(I4B) :: tsize + +tsize = order + 1 +ALLOCATE (ans(tsize)) +CALL EquidistancePoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize) END PROCEDURE EquidistancePoint_Line1 +!---------------------------------------------------------------------------- +! EquidistancePoint_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line1_ +INTEGER(I4B) :: tempint + +tsize = order + 1 + +SELECT CASE (order) +CASE (0) + ans(1) = 0.5_DFP * (xij(1) + xij(2)) + +CASE (1) + ans(1) = xij(1) + ans(2) = xij(2) + +CASE DEFAULT + ans(1) = xij(1) + ans(2) = xij(2) + CALL EquidistanceInPoint_Line_(order=order, xij=xij, ans=ans(3:), & + tsize=tempint) +END SELECT + +END PROCEDURE EquidistancePoint_Line1_ + !---------------------------------------------------------------------------- ! EquidistancePoint_Line !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Line2 -INTEGER(I4B) :: nsd +INTEGER(I4B) :: nrow, ncol IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - CALL Reallocate(ans, nsd, order + 1) - IF (order .EQ. 0_I4B) THEN - ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) + nrow = SIZE(xij, 1) +ELSE + nrow = 1_I4B +END IF + +ncol = order + 1 +ALLOCATE (ans(nrow, ncol)) + +CALL EquidistancePoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE EquidistancePoint_Line2 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line2_ +INTEGER(I4B) :: tempint + +ncol = order + 1 + +SELECT CASE (order) + +CASE (0) + + IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + ans(1:nrow, 1) = 0.5_DFP * (xij(1:nrow, 1) + xij(1:nrow, 2)) RETURN END IF - ans(1:nsd, 1) = xij(1:nsd, 1) - ans(1:nsd, 2) = xij(1:nsd, 2) -ELSE - nsd = 1_I4B - CALL Reallocate(ans, nsd, order + 1) - IF (order .EQ. 0_I4B) THEN - ans(1:nsd, 1) = 0.0_DFP + + nrow = 1_I4B + ans(1, 1) = 0.0_DFP + +CASE (1) + + IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + ans(1:nrow, 1:2) = xij(1:nrow, 1:2) RETURN END IF - ans(1:nsd, 1) = [-1.0] - ans(1:nsd, 2) = [1.0] -END IF -IF (order .GE. 2) THEN - ans(1:nsd, 3:) = EquidistanceInPoint_Line(order=order, xij=xij) -END IF -END PROCEDURE EquidistancePoint_Line2 + + nrow = 1 + ans(1, 1) = -1.0_DFP + ans(1, 2) = 1.0_DFP + +CASE DEFAULT + + IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + ans(1:nrow, 1:2) = xij(1:nrow, 1:2) + ELSE + nrow = 1 + ans(1, 1) = -1.0_DFP + ans(1, 2) = 1.0_DFP + END IF + + CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans(:, 3:), & + nrow=nrow, ncol=tempint) + +END SELECT + +END PROCEDURE EquidistancePoint_Line2_ !---------------------------------------------------------------------------- ! InterpolationPoint_Line !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Line1 -CHARACTER(20) :: astr -INTEGER(I4B) :: nsd, ii -REAL(DFP) :: temp(order + 1), t1 +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 1 +END IF + +ncol = order + 1 + +ALLOCATE (ans(nrow, ncol)) + +CALL InterpolationPoint_Line1(order=order, ipType=ipType, ans=ans, & + nrow=nrow, ncol=ncol, layout=layout, xij=xij, alpha=alpha, & + beta=beta, lambda=lambda) + +END PROCEDURE InterpolationPoint_Line1 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line2 +INTEGER(I4B) :: tsize +tsize = order + 1 +ALLOCATE (ans(tsize)) +CALL InterpolationPoint_Line2_(order=order, ipType=ipType, & + xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, tsize=tsize) +END PROCEDURE InterpolationPoint_Line2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line1_ +REAL(DFP) :: temp(64) IF (order .EQ. 0_I4B) THEN - IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - CALL Reallocate(ans, nsd, 1) - ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) - ELSE - CALL Reallocate(ans, 1, 1) - ans = 0.0_DFP - END IF + CALL EquidistancePoint_Line_(xij=xij, order=order, ans=ans, nrow=nrow, & + ncol=ncol) RETURN END IF -astr = TRIM(UpperCase(layout)) +CALL handle_error +!! handle_error is defined in this routine, see below + +ncol = order + 1 SELECT CASE (ipType) CASE (Equidistance) - ans = EquidistancePoint_Line(xij=xij, order=order) - IF (astr .EQ. "INCREASING") THEN - DO ii = 1, SIZE(ans, 1) - ans(ii, :) = SORT(ans(ii, :)) - END DO - END IF - RETURN + CALL EquidistancePoint_Line_(xij=xij, order=order, nrow=nrow, ncol=ncol, & + ans=ans) + CALL handle_increasing + CASE (GaussLegendre) - CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=Gauss) -CASE (GaussLegendreLobatto) - CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:) = temp(2:order) - END IF - temp(2) = t1 - END IF + CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss) + CALL handle_non_equidistance CASE (GaussChebyshev) - CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=Gauss) + CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss) + CALL handle_non_equidistance + +CASE (GaussLegendreLobatto) + CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance CASE (GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:) = temp(2:order) - END IF - temp(2) = t1 - END IF + CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance CASE (GaussJacobi) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobi", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF - - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=Gauss, & - & alpha=alpha, & - & beta=beta) + CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss, & + alpha=alpha, beta=beta) + CALL handle_non_equidistance CASE (GaussJacobiLobatto) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobi", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF + CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto, & + alpha=alpha, beta=beta) + CALL handle_vefc + CALL handle_non_equidistance - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=GaussLobatto, & - & alpha=alpha, & - & beta=beta) +CASE (GaussUltraspherical) + CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss, & + lambda=lambda) + CALL handle_non_equidistance - IF (layout .EQ. "VEFC") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:) = temp(2:order) - END IF - temp(2) = t1 - END IF +CASE (GaussUltrasphericalLobatto) + CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto, & + lambda=lambda) -CASE (GaussUltraspherical) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltraspherical", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF + CALL handle_vefc + CALL handle_non_equidistance - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=Gauss, & - & lambda=lambda) +CASE DEFAULT + CALL ErrorMsg(msg="Unknown iptype", routine="InterpolationPoint_Line1_()", & + file=__FILE__, line=__LINE__, unitno=stderr) +END SELECT -CASE (GaussUltrasphericalLobatto) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) - END IF +CONTAINS - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=temp, & - & quadType=GaussLobatto, & - & lambda=lambda) +SUBROUTINE handle_vefc + INTEGER(I4B) :: jj + REAL(DFP) :: t1 - IF (layout .EQ. "VEFC") THEN + IF (layout(1:2) .EQ. "VE") THEN t1 = temp(order + 1) IF (order .GE. 2) THEN temp(3:) = temp(2:order) @@ -345,111 +436,137 @@ temp(2) = t1 END IF -CASE DEFAULT - CALL ErrorMsg(& - & msg="Unknown iptype", & - & file=__FILE__, & - & routine="InterpolationPoint_Line1", & - & line=__LINE__, & - & unitno=stderr) -END SELECT +END SUBROUTINE handle_vefc + +SUBROUTINE handle_increasing + INTEGER(I4B) :: ii + + IF (layout(1:2) .EQ. "IN") THEN + DO ii = 1, nrow + CALL HeapSort(ans(ii, :)) + END DO + END IF +END SUBROUTINE -IF (ipType .NE. Equidistance) THEN +SUBROUTINE handle_non_equidistance IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - CALL Reallocate(ans, nsd, order + 1) - ans = FromBiunitLine2Segment(xin=temp, x1=xij(:, 1), & - & x2=xij(:, 2)) + CALL FromBiunitLine2Segment_(xin=temp(1:ncol), x1=xij(:, 1), x2=xij(:, 2), & + ans=ans, nrow=nrow, ncol=ncol) ELSE - CALL Reallocate(ans, 1, order + 1) - ans(1, :) = temp + nrow = 1 + ans(1, 1:ncol) = temp(1:ncol) END IF -END IF -END PROCEDURE InterpolationPoint_Line1 + +END SUBROUTINE handle_non_equidistance + +SUBROUTINE handle_error + +#ifdef DEBUG_VER + LOGICAL(LGT) :: isok + CHARACTER(:), ALLOCATABLE :: msg + + SELECT CASE (ipType) + CASE (GaussJacobi, 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 (GaussUltraSpherical, GaussUltraSphericalLobatto) + isok = PRESENT(lambda) + IF (.NOT. isok) THEN + msg = "lambda should be present for ipType=GaussUltraSpherical" + CALL ErrorMsg(msg=msg, file=__FILE__, & + routine="InterpolationPoint_Line1_()", & + line=__LINE__, unitno=stderr) + END IF + END SELECT + +#endif + +END SUBROUTINE handle_error + +END PROCEDURE InterpolationPoint_Line1_ !---------------------------------------------------------------------------- -! InterpolationPoint_Line +! InterpolationPoint_Line2_ !---------------------------------------------------------------------------- -MODULE PROCEDURE InterpolationPoint_Line2 -CHARACTER(20) :: astr -REAL(DFP) :: t1 - +MODULE PROCEDURE InterpolationPoint_Line2_ +tsize = order + 1 IF (order .EQ. 0_I4B) THEN - ans = [0.5_DFP * (xij(1) + xij(2))] + ans(1) = 0.5_DFP * (xij(1) + xij(2)) RETURN END IF -CALL Reallocate(ans, order + 1) -astr = TRIM(UpperCase(layout)) +CALL handle_error SELECT CASE (ipType) + CASE (Equidistance) - ans = EquidistancePoint_Line(xij=xij, order=order) - IF (astr .EQ. "INCREASING") ans = SORT(ans) - RETURN + CALL EquidistancePoint_Line_(xij=xij, order=order, tsize=tsize, ans=ans) + IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans) CASE (GaussLegendre) - CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=Gauss) - -CASE (GaussLegendreLobatto) - CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) - END IF - ans(2) = t1 - END IF + CALL LegendreQuadrature(n=tsize, pt=ans, quadType=Gauss) + CALL handle_non_equidistance CASE (GaussChebyshev) - CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=Gauss) - -CASE (GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=GaussLobatto) - IF (layout .EQ. "VEFC") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) - END IF - ans(2) = t1 - END IF + CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=Gauss) + CALL handle_non_equidistance CASE (GaussJacobi) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobi", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF + CALL JacobiQuadrature(n=tsize, pt=ans, quadType=Gauss, alpha=alpha, & + beta=beta) + CALL handle_non_equidistance - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=Gauss, & - & alpha=alpha, & - & beta=beta) +CASE (GaussUltraspherical) + CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=Gauss, & + lambda=lambda) + CALL handle_non_equidistance + +CASE (GaussLegendreLobatto) + CALL LegendreQuadrature(n=tsize, pt=ans, quadType=GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance + +CASE (GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance CASE (GaussJacobiLobatto) - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for ipType=GaussJacobiLobatto", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF + CALL JacobiQuadrature(n=tsize, pt=ans, quadType=GaussLobatto, alpha=alpha, & + beta=beta) + CALL handle_vefc + CALL handle_non_equidistance - CALL JacobiQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=GaussLobatto, & - & alpha=alpha, & - & beta=beta) +CASE (GaussUltrasphericalLobatto) + CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=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 + INTEGER(I4B) :: jj + REAL(DFP) :: t1 - IF (layout .EQ. "VEFC") THEN + IF (layout(1:2) .EQ. "VE") THEN t1 = ans(order + 1) IF (order .GE. 2) THEN ans(3:) = ans(2:order) @@ -457,59 +574,54 @@ ans(2) = t1 END IF -CASE (GaussUltraspherical) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltraspherical", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF +END SUBROUTINE handle_vefc - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=Gauss, & - & lambda=lambda) +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -CASE (GaussUltrasphericalLobatto) - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) - END IF +SUBROUTINE handle_non_equidistance + CALL FromBiunitLine2Segment_(xin=ans, x1=xij(1), x2=xij(2), & + ans=ans, tsize=tsize) - CALL UltrasphericalQuadrature( & - & n=order + 1, & - & pt=ans, & - & quadType=GaussLobatto, & - & lambda=lambda) +END SUBROUTINE handle_non_equidistance - IF (layout .EQ. "VEFC") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE handle_error + +#ifdef DEBUG_VER + LOGICAL(LGT) :: isok + CHARACTER(:), ALLOCATABLE :: msg + + SELECT CASE (ipType) + CASE (GaussJacobi, 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 - ans(2) = t1 - END IF -CASE DEFAULT - CALL ErrorMsg(& - & msg="Unknown iptype", & - & file=__FILE__, & - & routine="InterpolationPoint_Line2", & - & line=__LINE__, & - & unitno=stderr) -END SELECT + CASE (GaussUltraSpherical, 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 -IF (ipType .NE. Equidistance) THEN - ans = FromBiunitLine2Segment(xin=ans, x1=xij(1), x2=xij(2)) -END IF -END PROCEDURE InterpolationPoint_Line2 +#endif + +END SUBROUTINE handle_error + +END PROCEDURE InterpolationPoint_Line2_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Line From b17f6d1ae0521b742a67d0c85229bbe5def68d86 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 26 Jun 2024 16:50:33 +0900 Subject: [PATCH 062/359] Updates in LineInterpolationUtility --- .../src/LineInterpolationUtility.F90 | 2 +- .../src/LineInterpolationUtility@Methods.F90 | 194 ++++++++---------- 2 files changed, 81 insertions(+), 115 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 8e1bac4bd..46ba135e8 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -16,7 +16,7 @@ ! MODULE LineInterpolationUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT USE String_Class, ONLY: String IMPLICIT NONE PRIVATE diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 489967b7b..221f37885 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -16,7 +16,12 @@ ! SUBMODULE(LineInterpolationUtility) Methods -USE BaseMethod +USE BaseType, ONLY: ipopt => TypeInterpolationOpt, & + qpopt => TypeQuadratureOpt, & + polyopt => TypePolynomialOpt + +USE GlobalData, ONLY: stderr + IMPLICIT NONE CONTAINS @@ -34,7 +39,8 @@ MODULE PROCEDURE QuadratureNumber_Line SELECT CASE (quadType) -CASE (GaussLegendre, GaussChebyshev, GaussJacobi, GaussUltraspherical) +CASE (qpopt%GaussLegendre, qpopt%GaussChebyshev, & + qpopt%GaussJacobi, qpopt%GaussUltraspherical) ans = 1_I4B + INT(order / 2, kind=I4B) CASE DEFAULT ans = 2_I4B + INT(order / 2, kind=I4B) @@ -332,9 +338,9 @@ ALLOCATE (ans(nrow, ncol)) -CALL InterpolationPoint_Line1(order=order, ipType=ipType, ans=ans, & +CALL InterpolationPoint_Line1_(order=order, ipType=ipType, ans=ans, & nrow=nrow, ncol=ncol, layout=layout, xij=xij, alpha=alpha, & - beta=beta, lambda=lambda) + beta=beta, lambda=lambda) END PROCEDURE InterpolationPoint_Line1 @@ -371,46 +377,46 @@ SELECT CASE (ipType) -CASE (Equidistance) +CASE (ipopt%Equidistance) CALL EquidistancePoint_Line_(xij=xij, order=order, nrow=nrow, ncol=ncol, & ans=ans) CALL handle_increasing -CASE (GaussLegendre) +CASE (ipopt%GaussLegendre) CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss) CALL handle_non_equidistance -CASE (GaussChebyshev) +CASE (ipopt%GaussChebyshev) CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss) CALL handle_non_equidistance -CASE (GaussLegendreLobatto) +CASE (ipopt%GaussLegendreLobatto) CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto) CALL handle_vefc CALL handle_non_equidistance -CASE (GaussChebyshevLobatto) +CASE (ipopt%GaussChebyshevLobatto) CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto) CALL handle_vefc CALL handle_non_equidistance -CASE (GaussJacobi) +CASE (ipopt%GaussJacobi) CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss, & alpha=alpha, beta=beta) CALL handle_non_equidistance -CASE (GaussJacobiLobatto) +CASE (ipopt%GaussJacobiLobatto) CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto, & alpha=alpha, beta=beta) CALL handle_vefc CALL handle_non_equidistance -CASE (GaussUltraspherical) +CASE (ipopt%GaussUltraspherical) CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss, & lambda=lambda) CALL handle_non_equidistance -CASE (GaussUltrasphericalLobatto) +CASE (ipopt%GaussUltrasphericalLobatto) CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=GaussLobatto, & lambda=lambda) @@ -466,7 +472,7 @@ SUBROUTINE handle_error CHARACTER(:), ALLOCATABLE :: msg SELECT CASE (ipType) - CASE (GaussJacobi, GaussJacobiLobatto) + 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" @@ -476,7 +482,7 @@ SUBROUTINE handle_error line=__LINE__, unitno=stderr) END IF - CASE (GaussUltraSpherical, GaussUltraSphericalLobatto) + CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) isok = PRESENT(lambda) IF (.NOT. isok) THEN msg = "lambda should be present for ipType=GaussUltraSpherical" @@ -507,45 +513,45 @@ END SUBROUTINE handle_error SELECT CASE (ipType) -CASE (Equidistance) +CASE (ipopt%Equidistance) CALL EquidistancePoint_Line_(xij=xij, order=order, tsize=tsize, ans=ans) IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans) -CASE (GaussLegendre) +CASE (ipopt%GaussLegendre) CALL LegendreQuadrature(n=tsize, pt=ans, quadType=Gauss) CALL handle_non_equidistance -CASE (GaussChebyshev) +CASE (ipopt%GaussChebyshev) CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=Gauss) CALL handle_non_equidistance -CASE (GaussJacobi) +CASE (ipopt%GaussJacobi) CALL JacobiQuadrature(n=tsize, pt=ans, quadType=Gauss, alpha=alpha, & beta=beta) CALL handle_non_equidistance -CASE (GaussUltraspherical) +CASE (ipopt%GaussUltraspherical) CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=Gauss, & lambda=lambda) CALL handle_non_equidistance -CASE (GaussLegendreLobatto) +CASE (ipopt%GaussLegendreLobatto) CALL LegendreQuadrature(n=tsize, pt=ans, quadType=GaussLobatto) CALL handle_vefc CALL handle_non_equidistance -CASE (GaussChebyshevLobatto) +CASE (ipopt%GaussChebyshevLobatto) CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=GaussLobatto) CALL handle_vefc CALL handle_non_equidistance -CASE (GaussJacobiLobatto) +CASE (ipopt%GaussJacobiLobatto) CALL JacobiQuadrature(n=tsize, pt=ans, quadType=GaussLobatto, alpha=alpha, & beta=beta) CALL handle_vefc CALL handle_non_equidistance -CASE (GaussUltrasphericalLobatto) +CASE (ipopt%GaussUltrasphericalLobatto) CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=GaussLobatto, & lambda=lambda) CALL handle_vefc @@ -597,7 +603,7 @@ SUBROUTINE handle_error CHARACTER(:), ALLOCATABLE :: msg SELECT CASE (ipType) - CASE (GaussJacobi, GaussJacobiLobatto) + 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" @@ -607,7 +613,7 @@ SUBROUTINE handle_error line=__LINE__, unitno=stderr) END IF - CASE (GaussUltraSpherical, GaussUltraSphericalLobatto) + CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) isok = PRESENT(lambda) IF (.NOT. isok) THEN msg = "lambda should be present for ipType=GaussUltraSpherical" @@ -676,7 +682,7 @@ END SUBROUTINE handle_error MODULE PROCEDURE LagrangeCoeff_Line5 SELECT CASE (basisType) -CASE (Monomial) +CASE (polyopt%Monomial) ans = LagrangeCoeff_Line(order=order, xij=xij) CASE DEFAULT ans = EvalAllOrthopol(& @@ -709,7 +715,7 @@ END SUBROUTINE handle_error RETURN END IF -orthopol0 = input(default=Monomial, option=basisType) +orthopol0 = input(default=polyopt%Monomial, option=basisType) firstCall0 = input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN @@ -735,7 +741,7 @@ END SUBROUTINE handle_error END IF SELECT CASE (orthopol0) -CASE (Monomial) +CASE (polyopt%Monomial) xx(1, 1) = 1.0_DFP DO ii = 1, order xx(1, ii + 1) = xx(1, ii) * x @@ -773,7 +779,7 @@ END SUBROUTINE handle_error RETURN END IF -orthopol0 = Input(default=Monomial, option=basisType) +orthopol0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN @@ -799,7 +805,7 @@ END SUBROUTINE handle_error END IF SELECT CASE (orthopol0) -CASE (Monomial) +CASE (polyopt%Monomial) xx(:, 1) = 1.0_DFP DO ii = 1, order xx(:, ii + 1) = xx(:, ii) * x(1, :) @@ -839,7 +845,7 @@ END SUBROUTINE handle_error basisType0 = input(default=Monomial, option=basisType) SELECT CASE (basisType0) -CASE (Monomial) +CASE (polyopt%Monomial) ans(1) = 1.0_DFP DO ii = 1, order ans(ii + 1) = ans(ii) * x @@ -902,7 +908,7 @@ END SUBROUTINE handle_error basisType0 = input(default=Monomial, option=basisType) SELECT CASE (basisType0) -CASE (Monomial) +CASE (polyopt%Monomial) ans(1) = 0.0_DFP DO ii = 1, order ans(ii + 1) = REAL(ii, dfp) * x**(ii - 1) @@ -965,7 +971,7 @@ END SUBROUTINE handle_error basisType0 = input(default=Monomial, option=basisType) SELECT CASE (basisType0) -CASE (Monomial) +CASE (polyopt%Monomial) ans(:, 1) = 1.0_DFP DO ii = 1, order ans(:, ii + 1) = ans(:, ii) * x @@ -1028,7 +1034,7 @@ END SUBROUTINE handle_error basisType0 = input(default=Monomial, option=basisType) SELECT CASE (basisType0) -CASE (Monomial) +CASE (polyopt%Monomial) ans(:, 1) = 0.0_DFP DO ii = 1, order ans(:, ii + 1) = REAL(ii, dfp) * x**(ii - 1) @@ -1157,109 +1163,69 @@ END SUBROUTINE handle_error SELECT CASE (quadType) -CASE (GaussLegendre) +CASE (ipopt%GaussLegendre) CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss) -CASE (GaussLegendreRadauLeft) +CASE (ipopt%GaussLegendreRadauLeft) CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) -CASE (GaussLegendreRadauRight) +CASE (ipopt%GaussLegendreRadauRight) CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) -CASE (GaussLegendreLobatto) +CASE (ipopt%GaussLegendreLobatto) CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) IF (layout .EQ. "VEFC") changeLayout = .TRUE. -CASE (GaussChebyshev) +CASE (ipopt%GaussChebyshev) CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=Gauss) -CASE (GaussChebyshevRadauLeft) +CASE (ipopt%GaussChebyshevRadauLeft) CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) -CASE (GaussChebyshevRadauRight) +CASE (ipopt%GaussChebyshevRadauRight) CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) -CASE (GaussChebyshevLobatto) +CASE (ipopt%GaussChebyshevLobatto) CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) IF (layout .EQ. "VEFC") changeLayout = .TRUE. -CASE (GaussJacobi) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=Gauss, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiRadauLeft) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauLeft, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiRadauRight) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauRight, & - & alpha=alpha, & - & beta=beta) - -CASE (GaussJacobiLobatto) - CALL JacobiQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussLobatto, & - & alpha=alpha, & - & beta=beta) +CASE (ipopt%GaussJacobi) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss, & + alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiRadauLeft) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft, & + alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiRadauRight) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight, & + alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiLobatto) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto, & + alpha=alpha, beta=beta) IF (layout .EQ. "VEFC") changeLayout = .TRUE. -CASE (GaussUltraspherical) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=Gauss, & - & lambda=lambda) +CASE (ipopt%GaussUltraspherical) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss, & + lambda=lambda) -CASE (GaussUltrasphericalRadauLeft) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauLeft, & - & lambda=lambda) +CASE (ipopt%GaussUltrasphericalRadauLeft) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & + quadType=GaussRadauLeft, lambda=lambda) -CASE (GaussUltrasphericalRadauRight) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussRadauRight, & - & lambda=lambda) +CASE (ipopt%GaussUltrasphericalRadauRight) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & + quadType=GaussRadauRight, lambda=lambda) -CASE (GaussUltrasphericalLobatto) - CALL UltrasphericalQuadrature( & - & n=np, & - & pt=pt, & - & wt=wt, & - & quadType=GaussLobatto, & - & lambda=lambda) +CASE (ipopt%GaussUltrasphericalLobatto) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & + quadType=GaussLobatto, lambda=lambda) IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE DEFAULT - CALL ErrorMsg(& - & msg="Unknown iptype", & - & file=__FILE__, & - & routine="QuadraturePoint_Line3", & - & line=__LINE__, & - & unitno=stderr) + CALL ErrorMsg(msg="Unknown iptype", routine="QuadraturePoint_Line3", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END SELECT @@ -1289,7 +1255,7 @@ END SUBROUTINE handle_error REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1) INTEGER(I4B) :: ii, orthopol0 -orthopol0 = input(default=Monomial, option=basisType) +orthopol0 = input(default=polyopt%Monomial, option=basisType) firstCall0 = input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN @@ -1315,7 +1281,7 @@ END SUBROUTINE handle_error END IF SELECT CASE (orthopol0) -CASE (Monomial) +CASE (polyopt%Monomial) IF (SIZE(xij, 2) .NE. order + 1) THEN CALL Errormsg(& From d010896633b0403feed0ed77374be8f174c93b6a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 26 Jun 2024 20:46:29 +0900 Subject: [PATCH 063/359] updates in MappingUtility --- src/modules/Utility/src/MappingUtility.F90 | 32 ++++++++++++++++++- .../Utility/src/MappingUtility@Methods.F90 | 16 ++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index e212c1453..4fdfb737c 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -55,6 +55,7 @@ MODULE MappingUtility PUBLIC :: FromTriangle2Square_ PUBLIC :: FromUnitTriangle2Triangle +PUBLIC :: FromUnitTriangle2Triangle_ PUBLIC :: BarycentricCoordUnitTriangle !! This is function @@ -201,6 +202,35 @@ MODULE PURE FUNCTION FromUnitTriangle2Triangle1(xin, x1, x2, x3) RESULT(ans) END FUNCTION FromUnitTriangle2Triangle1 END INTERFACE FromUnitTriangle2Triangle +!---------------------------------------------------------------------------- +! FromUnitTriangle2Triangle_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-26 +! summary: from unit triangle to triangle without allocation + +INTERFACE FromUnitTriangle2Triangle_ + MODULE PURE SUBROUTINE FromUnitTriangle2Triangle1_(xin, x1, x2, x3, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of unit triangle + !! (0,0), (1,0), (0,1) + !! shape(xin) = (2,N) + REAL(DFP), INTENT(IN) :: x1(:) + !! x1 of physical domain, size(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! x2 of physical domain, size(x2) = nsd + REAL(DFP), INTENT(IN) :: x3(:) + !! x3 of physical domain, size(x3) = nsd + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE FromUnitTriangle2Triangle1_ +END INTERFACE FromUnitTriangle2Triangle_ + !---------------------------------------------------------------------------- ! FromBiUnitQuadrangle2Quadrangle !---------------------------------------------------------------------------- @@ -251,7 +281,7 @@ END FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1 INTERFACE FromBiUnitQuadrangle2Quadrangle MODULE PURE FUNCTION FromBiUnitQuadrangle2Quadrangle1(xin, x1, x2, x3, x4) & - & RESULT(ans) + & RESULT(ans) REAL(DFP), INTENT(IN) :: xin(:, :) !! vertex coordinate of biunit Quadrangle in xij format !! SIZE(xin,1) = 2 diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index a41438ba3..e63d36f08 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -130,6 +130,22 @@ END DO END PROCEDURE FromUnitTriangle2Triangle1 +!---------------------------------------------------------------------------- +! FromUnitTriangle2Triangle_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTriangle2Triangle1_ +INTEGER(I4B) :: ii, jj + +nrow = SIZE(x1) +ncol = SIZE(xin, 2) + +DO CONCURRENT(jj=1:ncol, ii=1:nrow) + ans(ii, jj) = x1(ii) + (x2(ii) - x1(ii)) * xin(1, jj) & + + (x3(ii) - x1(ii)) * xin(2, jj) +END DO +END PROCEDURE FromUnitTriangle2Triangle1_ + !---------------------------------------------------------------------------- ! FromBiUnitQuadrangle2UnitQuadrangle !---------------------------------------------------------------------------- From 7a25bf69fc923885118515ae6955e1bd02488f18 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 09:15:49 +0900 Subject: [PATCH 064/359] Updates in IntegerUtility --- src/modules/Utility/src/IntegerUtility.F90 | 40 ++++++++- .../Utility/src/IntegerUtility@Methods.F90 | 87 ++++++++++++------- 2 files changed, 92 insertions(+), 35 deletions(-) diff --git a/src/modules/Utility/src/IntegerUtility.F90 b/src/modules/Utility/src/IntegerUtility.F90 index b52c57a50..561ce774e 100644 --- a/src/modules/Utility/src/IntegerUtility.F90 +++ b/src/modules/Utility/src/IntegerUtility.F90 @@ -28,6 +28,7 @@ MODULE IntegerUtility PUBLIC :: Repeat PUBLIC :: SIZE PUBLIC :: GetMultiIndices +PUBLIC :: GetMultiIndices_ PUBLIC :: GetIndex PUBLIC :: Get PUBLIC :: GetIntersection @@ -70,7 +71,7 @@ END FUNCTION obj_Size2 !> author: Vikas Sharma, Ph. D. ! date: 4 Sept 2022 -! summary: Get Indices +! summary: Get Indices INTERFACE GetMultiIndices MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices1(n, d) RESULT(ans) @@ -85,7 +86,24 @@ END FUNCTION obj_GetMultiIndices1 !> author: Vikas Sharma, Ph. D. ! date: 4 Sept 2022 -! summary: Get Indices upto order n +! summary: Get Indices + +INTERFACE GetMultiIndices_ + MODULE RECURSIVE PURE SUBROUTINE obj_GetMultiIndices1_(n, d, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n, d + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_GetMultiIndices1_ +END INTERFACE GetMultiIndices_ + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices upto order n INTERFACE GetMultiIndices MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans) @@ -95,6 +113,24 @@ MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans) END FUNCTION obj_GetMultiIndices2 END INTERFACE GetMultiIndices +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices upto order n + +INTERFACE GetMultiIndices_ + MODULE RECURSIVE PURE SUBROUTINE obj_GetMultiIndices2_(n, d, upto, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n, d + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_GetMultiIndices2_ +END INTERFACE GetMultiIndices_ + !---------------------------------------------------------------------------- ! Operator(.in.)@IntegerMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/IntegerUtility@Methods.F90 b/src/submodules/Utility/src/IntegerUtility@Methods.F90 index 68e4d625c..df2ecb24c 100644 --- a/src/submodules/Utility/src/IntegerUtility@Methods.F90 +++ b/src/submodules/Utility/src/IntegerUtility@Methods.F90 @@ -51,58 +51,79 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetMultiIndices1 -INTEGER(I4B) :: ii, m -INTEGER(I4B), ALLOCATABLE :: indx(:, :), acol(:), indx2(:, :) +INTEGER(I4B) :: nrow, ncol +nrow = d + 1 +ncol = SIZE(n=n, d=d) +ALLOCATE (ans(nrow, ncol)) +CALL GetMultiIndices_(n=n, d=d, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE obj_GetMultiIndices1 -SELECT CASE (d) -CASE (1_I4B) +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- - ALLOCATE (ans(2, n + 1)) - DO ii = 0, n - ans(1:2, ii + 1) = [ii, n - ii] - END DO +MODULE PROCEDURE obj_GetMultiIndices1_ +INTEGER(I4B) :: ii, aint, bint, tsize -CASE DEFAULT +IF (d .EQ. 1) THEN - ALLOCATE (ans(d + 1, 1)) - ans = 0; ans(1, 1) = n + nrow = 2 + ncol = n + 1 - DO ii = n - 1, 0_I4B, -1_I4B + DO ii = 0, n + ans(1, ii + 1) = ii + ans(2, ii + 1) = n - ii + END DO - indx = GetMultiIndices(n=n - ii, d=d - 1) - m = SIZE(indx, 2) - acol = ii * ones(m, 1_I4B) - indx2 = acol.ROWCONCAT.indx - ans = indx2.COLCONCAT.ans + RETURN +END IF - END DO +nrow = d + 1 +ncol = SIZE(n=n, d=d) -END SELECT +ans(1:nrow, 1:ncol) = 0 +ans(1, ncol) = n -IF (ALLOCATED(indx)) DEALLOCATE (indx) -IF (ALLOCATED(acol)) DEALLOCATE (acol) -IF (ALLOCATED(indx2)) DEALLOCATE (indx2) +bint = ncol -END PROCEDURE obj_GetMultiIndices1 +DO ii = n - 1, 0_I4B, -1_I4B + tsize = SIZE(n=n - ii, d=d - 1) + bint = bint - tsize + ans(1, bint:bint + tsize - 1) = ii + CALL GetMultiIndices_(n=n - ii, d=d - 1, ans=ans(2:, bint:), nrow=aint, & + ncol=tsize) +END DO + +END PROCEDURE obj_GetMultiIndices1_ !---------------------------------------------------------------------------- -! +! GetMultiIndices_ !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_GetMultiIndices2 -INTEGER(I4B) :: ii, m, r1, r2 +MODULE PROCEDURE obj_GetMultiIndices2_ +INTEGER(I4B) :: ii, aint, bint, indx -m = SIZE(n, d, .TRUE.) -ALLOCATE (ans(d + 1, m)) +nrow = d + 1 +ncol = SIZE(n, d, .TRUE.) -r1 = 0; r2 = 0 +indx = 1 DO ii = 0, n - m = SIZE(n=ii, d=d) - r1 = r2 + 1_I4B - r2 = r1 + m - 1 - ans(:, r1:r2) = GetMultiIndices(n=ii, d=d) + CALL GetMultiIndices_(n=ii, d=d, ans=ans(:, indx:), nrow=aint, ncol=bint) + indx = indx + bint END DO +END PROCEDURE obj_GetMultiIndices2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices2 +INTEGER(I4B) :: nrow, ncol +nrow = d + 1 +ncol = SIZE(n=n, d=d, upto=upto) +ALLOCATE (ans(nrow, ncol)) +CALL GetMultiIndices_(n=n, d=d, ans=ans, nrow=nrow, ncol=ncol, upto=upto) END PROCEDURE obj_GetMultiIndices2 !---------------------------------------------------------------------------- From 7258f960d289fb1e8e20c6ce304728be036fe984 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 16:57:37 +0900 Subject: [PATCH 065/359] Updates in RecursiveNodesUtility --- .../Polynomial/src/RecursiveNodesUtility.F90 | 187 ++++++- .../src/RecursiveNodesUtility@Methods.F90 | 470 ++++++++++++------ 2 files changed, 497 insertions(+), 160 deletions(-) diff --git a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 index e45d75fde..6d86cd660 100644 --- a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 +++ b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 @@ -17,12 +17,19 @@ MODULE RecursiveNodesUtility USE GlobalData + IMPLICIT NONE + PRIVATE + PUBLIC :: RecursiveNode1D PUBLIC :: RecursiveNode2D PUBLIC :: RecursiveNode3D +PUBLIC :: RecursiveNode1D_ +PUBLIC :: RecursiveNode2D_ +PUBLIC :: RecursiveNode3D_ + !---------------------------------------------------------------------------- ! RecursiveNode1D !---------------------------------------------------------------------------- @@ -32,8 +39,8 @@ MODULE RecursiveNodesUtility ! summary: RecursiveNodes in 1D INTERFACE - MODULE FUNCTION RecursiveNode1D(order, ipType, & - & domain, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION RecursiveNode1D(order, ipType, domain, alpha, beta, & + lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order >= 0 INTEGER(I4B), INTENT(IN) :: ipType @@ -62,6 +69,43 @@ MODULE FUNCTION RecursiveNode1D(order, ipType, & END FUNCTION RecursiveNode1D END INTERFACE +!---------------------------------------------------------------------------- +! RecursiveNode1D_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE RecursiveNode1D_(order, ipType, domain, alpha, beta, & + lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 2 corresponding to b0 and b1 + !! size(ans,2) total number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns of ans + CHARACTER(*), OPTIONAL, INTENT(IN) :: domain + !! unit (0,1) + !! biunit (-1, 1) + !! equilateral + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END SUBROUTINE RecursiveNode1D_ +END INTERFACE + !---------------------------------------------------------------------------- ! RecursiveNode2D !---------------------------------------------------------------------------- @@ -71,15 +115,8 @@ END FUNCTION RecursiveNode1D ! summary: RecursiveNodes in 2D INTERFACE - MODULE FUNCTION RecursiveNode2D( & - & order, & - & ipType, & - & domain, & - & alpha, & - & beta, & - & lambda & - & ) & - & RESULT(ans) + MODULE FUNCTION RecursiveNode2D(order, ipType, domain, alpha, beta, & + lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order >= 0 INTEGER(I4B), INTENT(IN) :: ipType @@ -108,6 +145,43 @@ MODULE FUNCTION RecursiveNode2D( & END FUNCTION RecursiveNode2D END INTERFACE +!---------------------------------------------------------------------------- +! RecursiveNode2D_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE RecursiveNode2D_(order, ipType, ans, nrow, ncol, & + domain, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 3 corresponding to b0, b1, b2 + !! size(ans,2) total number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns of ans + CHARACTER(*), OPTIONAL, INTENT(IN) :: domain + !! unit + !! Biunit + !! Equilateral + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END SUBROUTINE RecursiveNode2D_ +END INTERFACE + !---------------------------------------------------------------------------- ! RecursiveNode3D !---------------------------------------------------------------------------- @@ -117,14 +191,8 @@ END FUNCTION RecursiveNode2D ! summary: Recursive nodes in 3D INTERFACE - MODULE FUNCTION RecursiveNode3D( & - & order, & - & ipType, & - & domain, & - & alpha, & - & beta, & - & lambda & - & ) RESULT(ans) + MODULE FUNCTION RecursiveNode3D(order, ipType, domain, alpha, beta, & + lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order >= 0 INTEGER(I4B), INTENT(IN) :: ipType @@ -153,6 +221,47 @@ MODULE FUNCTION RecursiveNode3D( & END FUNCTION RecursiveNode3D END INTERFACE +!---------------------------------------------------------------------------- +! RecursiveNode3D_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-26 +! summary: Recursive node 3D without allocation + +INTERFACE + MODULE SUBROUTINE RecursiveNode3D_(order, ipType, ans, nrow, ncol, & + domain, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 4 corresponding to b0, b1, b2, b3 + !! size(ans,2) total number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns of ans + CHARACTER(*), OPTIONAL, INTENT(IN) :: domain + !! unit + !! Biunit + !! Equilateral + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END SUBROUTINE RecursiveNode3D_ +END INTERFACE + !---------------------------------------------------------------------------- ! ToUnit !---------------------------------------------------------------------------- @@ -165,6 +274,19 @@ MODULE PURE FUNCTION ToUnit(x, domain) RESULT(ans) END FUNCTION ToUnit END INTERFACE +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE ToUnit_(x, domain, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(*), INTENT(IN) :: domain + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE ToUnit_ +END INTERFACE + !---------------------------------------------------------------------------- ! ToUnit !---------------------------------------------------------------------------- @@ -181,6 +303,19 @@ END FUNCTION FromUnit ! ToUnit !---------------------------------------------------------------------------- +INTERFACE + MODULE PURE SUBROUTINE FromUnit_(x, domain, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(*), INTENT(IN) :: domain + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE FromUnit_ +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + INTERFACE MODULE RECURSIVE PURE SUBROUTINE Unit2Equilateral(d, x) INTEGER(I4B), INTENT(IN) :: d @@ -212,4 +347,18 @@ MODULE PURE FUNCTION Coord_Map(x, from, to) RESULT(ans) END FUNCTION Coord_Map END INTERFACE +!---------------------------------------------------------------------------- +! Coord_Map +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE Coord_Map_(x, from, to, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(*), INTENT(IN) :: from + CHARACTER(*), INTENT(IN) :: to + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Coord_Map_ +END INTERFACE + END MODULE RecursiveNodesUtility diff --git a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 index cb6c67770..b9914c143 100644 --- a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 @@ -19,73 +19,163 @@ USE BaseMethod CONTAINS +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION NumberofRows(d, domain) RESULT(nrow) + INTEGER(I4B), INTENT(IN) :: d + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: domain + INTEGER(I4B) :: nrow + + LOGICAL(LGT) :: isdomain + CHARACTER(2) :: mydomain + + isdomain = PRESENT(domain) + mydomain = "BA" + IF (isdomain) mydomain = UpperCase(domain(1:2)) + + IF (mydomain .EQ. "BA") THEN + nrow = d + 1 + ELSE + nrow = d + END IF +END FUNCTION NumberofRows + !---------------------------------------------------------------------------- ! RecursiveNode1D !---------------------------------------------------------------------------- MODULE PROCEDURE RecursiveNode1D -INTEGER(I4B) :: n, jj -INTEGER(I4B), PARAMETER :: d = 1_I4B -INTEGER(I4B) :: aindx(d + 1) -REAL(DFP) :: avar -REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] -INTEGER(I4B), ALLOCATABLE :: indices(:, :) -REAL(DFP), ALLOCATABLE :: x(:) - -n = order -x = InterpolationPoint_Line( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout="INCREASING", & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - -indices = GetMultiIndices(n=n, d=d) -CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) - -DO jj = 1, SIZE(ans, 2) - aindx = indices(:, jj) + 1 - avar = x(aindx(1)) + x(aindx(2)) - ans(1, jj) = x(aindx(1)) / avar - ans(2, jj) = x(aindx(2)) / avar -END DO +INTEGER(I4B) :: nrow, ncol -IF (PRESENT(domain)) THEN - ans = Coord_Map(x=ans, from="BaryCentric", to=domain) -END IF +nrow = NumberofRows(d=1_I4B, domain=domain) +ncol = SIZE(n=order, d=1_I4B) + +ALLOCATE (ans(nrow, ncol)) + +CALL RecursiveNode1D_(order=order, ipType=ipType, ans=ans, nrow=nrow, & + ncol=ncol, alpha=alpha, beta=beta, lambda=lambda, domain=domain) -IF (ALLOCATED(indices)) DEALLOCATE (indices) -IF (ALLOCATED(x)) DEALLOCATE (x) END PROCEDURE RecursiveNode1D +!---------------------------------------------------------------------------- +! RecursiveNode1D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode1D_ +INTEGER(I4B), PARAMETER :: d = 1_I4B, max_order = 99_I4B +INTEGER(I4B) :: jj, tsize, i1, i2, aint, bint +REAL(DFP) :: avar, x(max_order + 1), xij(2, 1) +LOGICAL(LGT) :: isdomain +CHARACTER(2) :: mydomain + +INTEGER(I4B), ALLOCATABLE :: indices(:, :) + +isdomain = PRESENT(domain) +mydomain = "BA" +IF (isdomain) mydomain = domain(1:2) + +xij(1, 1) = 0.0_DFP +xij(2, 1) = 1.0_DFP + +CALL InterpolationPoint_Line_(order=order, ipType=ipType, xij=xij(:, 1), & + ans=x, layout="INCREASING", alpha=alpha, beta=beta, lambda=lambda, & + tsize=tsize) + +nrow = d + 1 +ncol = SIZE(n=order, d=d) + +ALLOCATE (indices(nrow, ncol)) + +CALL GetMultiIndices_(n=order, d=d, ans=indices, nrow=nrow, ncol=ncol) + +SELECT CASE (mydomain) +CASE ("BA", "Ba", "ba") + DO jj = 1, ncol + i1 = indices(1, jj) + 1 + i2 = indices(2, jj) + 1 + + avar = x(i1) + x(i2) + + ans(1, jj) = x(i1) / avar + ans(2, jj) = x(i2) / avar + END DO + +CASE default + nrow = nrow - 1 + + DO jj = 1, ncol + i1 = indices(1, jj) + 1 + i2 = indices(2, jj) + 1 + + avar = x(i1) + x(i2) + + xij(1, 1) = x(i1) / avar + xij(2, 1) = x(i2) / avar + + CALL Coord_Map_(x=xij, from="BARYCENTRIC", to=mydomain, & + ans=ans(:, jj:), nrow=aint, ncol=bint) + END DO + +END SELECT + +DEALLOCATE (indices) + +END PROCEDURE RecursiveNode1D_ + !---------------------------------------------------------------------------- ! RecursiveNode2D !---------------------------------------------------------------------------- MODULE PROCEDURE RecursiveNode2D -INTEGER(I4B) :: n, jj, ii -INTEGER(I4B), PARAMETER :: d = 2_I4B -INTEGER(I4B) :: aindx(d + 1), indx(d) -REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) -REAL(DFP) :: BX(2, order + 1, order + 1) +INTEGER(I4B) :: nrow, ncol +nrow = NumberofRows(d=2_I4B, domain=domain) +ncol = SIZE(n=order, d=2_I4B) +ALLOCATE (ans(nrow, ncol)) +CALL RecursiveNode2D_(order=order, iptype=iptype, ans=ans, nrow=nrow, & + ncol=ncol, domain=domain, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE RecursiveNode2D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode2D_ +INTEGER(I4B), PARAMETER :: d = 2_I4B, dp1 = 3_I4B +INTEGER(I4B), PARAMETER :: max_order = 100 !! max_order + 1 + +INTEGER(I4B) :: aindx(dp1), indx(d), aint, bint, jj, ii + +REAL(DFP) :: xi, xt, b(dp1), bs(d), Xn(max_order), & + BX(d, max_order, max_order), xij(dp1, 1), & + bxn(d, max_order) + INTEGER(I4B), ALLOCATABLE :: indices(:, :) -n = order -CALL BarycentericNodeFamily1D( & - & order=order, & - & ipType=ipType, & - & ans=BX, & - & Xn=Xn, & - & alpha=alpha, beta=beta, lambda=lambda) +CHARACTER(2) :: mydomain +LOGICAL(LGT) :: isdomain + +isdomain = PRESENT(domain) +mydomain = "BA"; IF (isdomain) mydomain = UpperCase(domain(1:2)) -indices = GetMultiIndices(n=n, d=d) -CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) +nrow = d + 1 +ncol = SIZE(n=order, d=d) +ALLOCATE (indices(nrow, ncol)) -DO jj = 1, SIZE(ans, 2) +CALL BarycentericNodeFamily1D(order=order, ipType=ipType, ans=BX, & + Xn=Xn, alpha=alpha, beta=beta, lambda=lambda, & + indices=indices, bxn=bxn) + +CALL GetMultiIndices_(n=order, d=d, ans=indices, nrow=nrow, ncol=ncol) + +IF (mydomain .NE. "BA") nrow = d + +DO jj = 1, ncol aindx = indices(:, jj) + xt = 0.0_DFP + xij = 0.0_DFP DO ii = 1, d + 1 indx = Pop(aindx, ii) @@ -93,158 +183,183 @@ b = Push(vec=bs, VALUE=0.0_DFP, pos=ii) xi = Xn(SUM(indx) + 1) xt = xt + xi - ans(1:d + 1, jj) = ans(1:d + 1, jj) + xi * b + xij(:, 1) = xij(:, 1) + xi * b END DO - ans(:, jj) = ans(:, jj) / xt -END DO -IF (PRESENT(domain)) THEN - ans = Coord_Map(x=ans, from="BaryCentric", to=domain) -END IF + xij = xij / xt + + CALL Coord_Map_(x=xij, from="BARYCENTRIC", to=mydomain, & + ans=ans(:, jj:), nrow=aint, ncol=bint) + +END DO IF (ALLOCATED(indices)) DEALLOCATE (indices) -END PROCEDURE RecursiveNode2D +END PROCEDURE RecursiveNode2D_ !---------------------------------------------------------------------------- ! RecursiveNode3D !---------------------------------------------------------------------------- MODULE PROCEDURE RecursiveNode3D -INTEGER(I4B) :: n, jj, ii -INTEGER(I4B), PARAMETER :: d = 3_I4B -INTEGER(I4B) :: aindx(d + 1), indx(d) -REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) -REAL(DFP) :: BX(3, order + 1, order + 1, order + 1) +INTEGER(I4B) :: nrow, ncol +nrow = NumberofRows(d=3_I4B, domain=domain) +ncol = SIZE(n=order, d=3_I4B) +ALLOCATE (ans(nrow, ncol)) +CALL RecursiveNode3D_(order=order, iptype=iptype, ans=ans, nrow=nrow, & + ncol=ncol, domain=domain, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE RecursiveNode3D + +!---------------------------------------------------------------------------- +! RecursiveNode3D_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode3D_ +INTEGER(I4B), PARAMETER :: d = 3_I4B, dp1 = 4_I4B, max_order = 26 + +INTEGER(I4B) :: jj, ii, aint, bint, aindx(dp1), indx(d) + +REAL(DFP) :: xi, xt, b(dp1), bs(d), xn(max_order), & + bx(d, max_order, max_order, max_order), xij(dp1, 1) + INTEGER(I4B), ALLOCATABLE :: indices(:, :) +REAL(DFP), ALLOCATABLE :: bxn(:, :) + +CHARACTER(2) :: mydomain +LOGICAL(LGT) :: isdomain + +isdomain = PRESENT(domain) +mydomain = "BA"; IF (isdomain) mydomain = UpperCase(domain(1:2)) + +nrow = d + 1 +ncol = SIZE(n=order, d=d) +ALLOCATE (indices(nrow, ncol), bxn(d, ncol)) -n = order -CALL BarycentericNodeFamily2D(order=order, ipType=ipType, ans=BX, Xn=Xn, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +CALL BarycentericNodeFamily2D(order=order, ipType=ipType, ans=bx, Xn=Xn, & + alpha=alpha, beta=beta, lambda=lambda, indices=indices, bxn=bxn) -indices = GetMultiIndices(n=n, d=d) -CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) -ans = 0.0_DFP +CALL GetMultiIndices_(n=order, d=d, ans=indices, nrow=nrow, ncol=ncol) -DO jj = 1, SIZE(ans, 2) +IF (mydomain .NE. "BA") nrow = d + +DO jj = 1, ncol aindx = indices(:, jj) xt = 0.0_DFP + xij = 0.0_DFP - DO ii = 1, d + 1 + DO ii = 1, dp1 indx = Pop(aindx, ii) - bs = BX(:, indx(1) + 1, indx(2) + 1, indx(3) + 1) + bs = bx(:, indx(1) + 1, indx(2) + 1, indx(3) + 1) b = Push(vec=bs, VALUE=0.0_DFP, pos=ii) - xi = Xn(SUM(indx) + 1) + xi = xn(SUM(indx) + 1) xt = xt + xi - ans(:, jj) = ans(:, jj) + xi * b + xij(:, 1) = xij(:, 1) + xi * b END DO - ans(:, jj) = ans(:, jj) / xt + xij = xij / xt -END DO + CALL Coord_Map_(x=xij, from="BARYCENTRIC", to=mydomain, & + ans=ans(:, jj:), nrow=aint, ncol=bint) -IF (PRESENT(domain)) THEN - ans = Coord_Map(x=ans, from="BaryCentric", to=domain) -END IF +END DO IF (ALLOCATED(indices)) DEALLOCATE (indices) +IF (ALLOCATED(bxn)) DEALLOCATE (bxn) -END PROCEDURE RecursiveNode3D +END PROCEDURE RecursiveNode3D_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn, alpha, & - & beta, lambda) +SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn, indices, bxn, & + alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), INTENT(IN) :: ipType - REAL(DFP), INTENT(OUT) :: ans(2, order + 1, order + 1) - REAL(DFP), INTENT(OUT) :: Xn(order + 1) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! ans(2, order + 1, order + 1) + REAL(DFP), INTENT(INOUT) :: Xn(:) + !! Xn(order + 1) + INTEGER(I4B), INTENT(INOUT) :: indices(:, :) + !! + REAL(DFP), INTENT(INOUT) :: bxn(:, :) + !! REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - ! - INTEGER(I4B) :: ii, jj, n - INTEGER(I4B), PARAMETER :: d = 1_I4B - REAL(DFP), ALLOCATABLE :: BXn(:, :) - INTEGER(I4B), ALLOCATABLE :: indices(:, :) - !! + !! Ultraspherical polynomial parameter + + INTEGER(I4B), PARAMETER :: d = 1_I4B, dp1 = 2_I4B + INTEGER(I4B) :: ii, jj, nrow, ncol + DO ii = 0, order - n = ii - indices = GetMultiIndices(n=n, d=d) - BXn = RecursiveNode1D(order=n, ipType=ipType, & - & alpha=alpha, beta=beta, lambda=lambda) - !! - DO jj = 1, n + 1 - ans(1:d + 1, indices(1, jj) + 1, indices(2, jj) + 1) = BXn(1:d + 1, jj) + ! indices = GetMultiIndices(n=ii, d=d) + CALL GetMultiIndices_(n=ii, d=d, ans=indices, nrow=nrow, ncol=ncol) + + CALL RecursiveNode1D_(order=ii, ipType=ipType, ans=bxn, nrow=nrow, & + ncol=ncol, alpha=alpha, beta=beta, lambda=lambda) + + DO jj = 1, ii + 1 + ans(1:dp1, indices(1, jj) + 1, indices(2, jj) + 1) = bxn(1:dp1, jj) END DO - !! + END DO - !! - Xn = BXn(1, :) - !! - IF (ALLOCATED(BXn)) DEALLOCATE (BXn) - IF (ALLOCATED(indices)) DEALLOCATE (indices) - !! + + Xn(1:order + 1) = bxn(1, 1:order + 1) + END SUBROUTINE BarycentericNodeFamily1D !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn, alpha, beta, lambda) +SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn, alpha, beta, & + lambda, indices, bxn) + INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), INTENT(IN) :: ipType - REAL(DFP), INTENT(OUT) :: ans(3, order + 1, order + 1, order + 1) - REAL(DFP), INTENT(OUT) :: Xn(order + 1) + REAL(DFP), INTENT(inout) :: ans(:, :, :, :) + !! ans(3, order + 1, order + 1, order + 1) + REAL(DFP), INTENT(OUT) :: xn(:) + !! Xn(order + 1) + INTEGER(I4B), INTENT(INOUT) :: indices(:, :) + !! + REAL(DFP), INTENT(INOUT) :: bxn(:, :) + !! REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter - !! - INTEGER(I4B) :: ii, jj, n - INTEGER(I4B), PARAMETER :: d = 2_I4B - REAL(DFP), ALLOCATABLE :: BXn(:, :) - INTEGER(I4B), ALLOCATABLE :: indices(:, :) - REAL(DFP) :: avar + !! Ultraspherical polynomial parameter + + !! Internal varible + REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] - !! + INTEGER(I4B), PARAMETER :: d = 2_I4B + INTEGER(I4B) :: ii, jj, nrow, ncol + DO ii = 0, order - n = ii - indices = GetMultiIndices(n=n, d=d) - BXn = RecursiveNode2D(order=n, ipType=ipType, alpha=alpha, beta=beta, lambda=lambda ) - !! - DO jj = 1, SIZE(BXn, 2) - ans(1:3, & - & indices(1, jj) + 1, & - & indices(2, jj) + 1, & - & indices(3, jj) + 1) = BXn(1:3, jj) + CALL GetMultiIndices_(n=ii, d=d, ans=indices, nrow=nrow, ncol=ncol) + + CALL RecursiveNode2D_(order=ii, ipType=ipType, alpha=alpha, & + beta=beta, lambda=lambda, ans=bxn, nrow=nrow, ncol=ncol) + + DO jj = 1, ncol + ans(1:3, indices(1, jj) + 1, indices(2, jj) + 1, indices(3, jj) + 1) = & + bxn(1:3, jj) END DO - !! + END DO - !! - Xn = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij, & - & layout="INCREASING", alpha=alpha, beta=beta, lambda=lambda) - !! - ! IF (order .GT. 1) THEN - ! avar = Xn(2) - ! Xn(2:order) = Xn(3:) - ! Xn(order + 1) = avar - ! END IF - !! - IF (ALLOCATED(BXn)) DEALLOCATE (BXn) - IF (ALLOCATED(indices)) DEALLOCATE (indices) - !! + + CALL InterpolationPoint_Line_(ans=xn, tsize=nrow, order=order, & + ipType=ipType, xij=xij, layout="INCREASING", alpha=alpha, & + beta=beta, lambda=lambda) + END SUBROUTINE BarycentericNodeFamily2D !---------------------------------------------------------------------------- @@ -311,6 +426,38 @@ END SUBROUTINE BarycentericNodeFamily2D ! !---------------------------------------------------------------------------- +MODULE PROCEDURE ToUnit_ +nrow = SIZE(x, 1) +ncol = SIZE(x, 2) + +SELECT CASE (domain(1:2)) +CASE ("UN", "un", "Un") + ans(1:nrow, 1:ncol) = x + +CASE ("BI", "bi", "Bi") + ans(1:nrow, 1:ncol) = 0.5_DFP * (x + 1.0_DFP) + +CASE ("BA", "ba", "Ba") + nrow = nrow - 1 + ans(1:nrow, 1:ncol) = x(1:nrow, :) + +CASE ("EQ", "eq", "Eq") + ans(1:nrow, 1:ncol) = x + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) * 0.5_DFP + + CALL Equilateral2Unit(d=nrow, x=ans) + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + 1.0_DFP / & + (REAL(nrow, kind=dfp) + 1.0_DFP) + +END SELECT +END PROCEDURE ToUnit_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE FromUnit TYPE(String) :: astr INTEGER(I4B) :: d @@ -331,6 +478,36 @@ END SUBROUTINE BarycentericNodeFamily2D END SELECT END PROCEDURE FromUnit +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnit_ +nrow = SIZE(x, 1) +ncol = SIZE(x, 2) + +SELECT CASE (domain(1:2)) +CASE ("UN", "Un", "un") + ans(1:nrow, 1:ncol) = x + +CASE ("BI", "Bi", "bi") + ans(1:nrow, 1:ncol) = 2.0_DFP * x - 1.0_DFP + +CASE ("BA", "Ba", "ba") + ans(1:nrow, 1:ncol) = x + nrow = nrow + 1 + ans(nrow, 1:ncol) = (1.0_DFP - SUM(x, dim=1)) + +CASE ("EQ", "Eq", "eq") + ans(1:nrow, 1:ncol) = x - 1.0_DFP / (REAL(nrow, kind=DFP) + 1.0_DFP) + + CALL Unit2Equilateral(d=nrow, x=ans) + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) * 2.0_DFP + +END SELECT +END PROCEDURE FromUnit_ + !---------------------------------------------------------------------------- ! Coord_Map !---------------------------------------------------------------------------- @@ -339,6 +516,17 @@ END SUBROUTINE BarycentericNodeFamily2D ans = FromUnit(x=(ToUnit(x=x, domain=from)), domain=to) END PROCEDURE Coord_Map +!---------------------------------------------------------------------------- +! Coord_Map +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Coord_Map_ +INTEGER(I4B) :: aint, bint +CALL ToUnit_(x=x, domain=from, ans=ans, nrow=aint, ncol=bint) +CALL FromUnit_(x=ans(1:aint, 1:bint), domain=to, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE Coord_Map_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 7d18d476f845bc3b111af0cb8b0bee8be2a94dbe Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 17:10:46 +0900 Subject: [PATCH 066/359] Updates in RecursiveNodesUtility --- .../Polynomial/src/RecursiveNodesUtility.F90 | 110 +++++++++--------- .../src/RecursiveNodesUtility@Methods.F90 | 63 ++++------ 2 files changed, 80 insertions(+), 93 deletions(-) diff --git a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 index 6d86cd660..f4a96f155 100644 --- a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 +++ b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 @@ -16,7 +16,7 @@ ! MODULE RecursiveNodesUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT IMPLICIT NONE @@ -42,30 +42,30 @@ MODULE RecursiveNodesUtility MODULE FUNCTION RecursiveNode1D(order, ipType, domain, alpha, beta, & lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order >= 0 + !! order >= 0 INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! LobattoGaussJacobi - !! LobattoGaussChebyshev - !! LobattoGaussGegenbauer - !! GaussJacobi - !! GaussChebyshev - !! GaussGegenbauer + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer REAL(DFP), ALLOCATABLE :: ans(:, :) - !! barycentric coordinates, in xiJ format - !! size(ans,1) = 2 corresponding to b0 and b1 - !! size(ans,2) total number of points + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 2 corresponding to b0 and b1 + !! size(ans,2) total number of points CHARACTER(*), OPTIONAL, INTENT(IN) :: domain - !! unit (0,1) - !! biunit (-1, 1) - !! equilateral + !! unit (0,1) + !! biunit (-1, 1) + !! equilateral REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter + !! Ultraspherical polynomial parameter END FUNCTION RecursiveNode1D END INTERFACE @@ -118,30 +118,30 @@ END SUBROUTINE RecursiveNode1D_ MODULE FUNCTION RecursiveNode2D(order, ipType, domain, alpha, beta, & lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order >= 0 + !! order >= 0 INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! LobattoGaussJacobi - !! LobattoGaussChebyshev - !! LobattoGaussGegenbauer - !! GaussJacobi - !! GaussChebyshev - !! GaussGegenbauer + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer REAL(DFP), ALLOCATABLE :: ans(:, :) - !! barycentric coordinates, in xiJ format - !! size(ans,1) = 3 corresponding to b0, b1, b2 - !! size(ans,2) total number of points + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 3 corresponding to b0, b1, b2 + !! size(ans,2) total number of points CHARACTER(*), OPTIONAL, INTENT(IN) :: domain - !! unit - !! Biunit - !! Equilateral + !! unit + !! Biunit + !! Equilateral REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter + !! Ultraspherical polynomial parameter END FUNCTION RecursiveNode2D END INTERFACE @@ -194,30 +194,30 @@ END SUBROUTINE RecursiveNode2D_ MODULE FUNCTION RecursiveNode3D(order, ipType, domain, alpha, beta, & lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order >= 0 + !! order >= 0 INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! LobattoGaussJacobi - !! LobattoGaussChebyshev - !! LobattoGaussGegenbauer - !! GaussJacobi - !! GaussChebyshev - !! GaussGegenbauer + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer REAL(DFP), ALLOCATABLE :: ans(:, :) - !! barycentric coordinates, in xiJ format - !! size(ans,1) = 4 corresponding to b0, b1, b2, b3 - !! size(ans,2) total number of points + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 4 corresponding to b0, b1, b2, b3 + !! size(ans,2) total number of points CHARACTER(*), OPTIONAL, INTENT(IN) :: domain - !! unit - !! Biunit - !! Equilateral + !! unit + !! Biunit + !! Equilateral REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical polynomial parameter + !! Ultraspherical polynomial parameter END FUNCTION RecursiveNode3D END INTERFACE diff --git a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 index b9914c143..c27db2507 100644 --- a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 @@ -16,7 +16,14 @@ ! SUBMODULE(RecursiveNodesUtility) Methods -USE BaseMethod +USE StringUtility, ONLY: UpperCase + +USE IntegerUtility, ONLY: GetMultiIndices_, Size + +USE PushPopUtility, ONLY: Pop, Push + +USE LineInterpolationUtility, ONLY: InterpolationPoint_Line_ + CONTAINS !---------------------------------------------------------------------------- @@ -368,7 +375,7 @@ END SUBROUTINE BarycentericNodeFamily2D MODULE PROCEDURE Unit2Equilateral INTEGER(I4B) :: ii -!! + IF (d .GT. 1_I4B) THEN ! Move the top vertex over the centroid DO ii = 1, d - 1 @@ -387,7 +394,7 @@ END SUBROUTINE BarycentericNodeFamily2D MODULE PROCEDURE Equilateral2Unit INTEGER(I4B) :: ii -!! + IF (d .GT. 1_I4B) THEN x(d, :) = x(d, :) / SQRT((d + 1.0_DFP) / (2.0_DFP * d)) CALL Equilateral2Unit(d=d - 1, x=x(1:d - 1, :)) @@ -402,24 +409,14 @@ END SUBROUTINE BarycentericNodeFamily2D !---------------------------------------------------------------------------- MODULE PROCEDURE ToUnit -TYPE(String) :: astr -INTEGER(I4B) :: d -astr = UpperCase(TRIM(domain)) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = x -CASE ("BIUNIT") - ans = 0.5_DFP * (x + 1.0_DFP) -CASE ("BARYCENTRIC") - d = SIZE(x, 1) - ans = x(1:d - 1, :) -CASE ("EQUILATERAL") - d = SIZE(x, 1) - ans = x - ans = ans / 2.0_DFP - CALL Equilateral2Unit(d=d, x=ans) - ans = ans + 1.0_DFP / (d + 1.0_DFP) -END SELECT +INTEGER(I4B) :: nrow, ncol +CHARACTER(2) :: mydomain +mydomain = UpperCase(domain(1:2)) +nrow = SIZE(x, 1) +ncol = SIZE(x, 2) +IF (mydomain .EQ. "BA") nrow = nrow - 1 +ALLOCATE (ans(nrow, ncol)) +CALL ToUnit_(x=x, domain=mydomain, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE ToUnit !---------------------------------------------------------------------------- @@ -459,23 +456,13 @@ END SUBROUTINE BarycentericNodeFamily2D !---------------------------------------------------------------------------- MODULE PROCEDURE FromUnit -TYPE(String) :: astr -INTEGER(I4B) :: d -astr = UpperCase(TRIM(domain)) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = x -CASE ("BIUNIT") - ans = 2.0_DFP * x - 1 -CASE ("BARYCENTRIC") - ans = x.ROWCONCAT. (1.0_DFP - SUM(x, dim=1)) -CASE ("EQUILATERAL") - d = SIZE(x, 1) - ans = x - ans = ans - 1.0_DFP / (d + 1.0_DFP) - CALL Unit2Equilateral(d=d, x=ans) - ans = ans * 2.0_DFP -END SELECT +INTEGER(I4B) :: nrow, ncol +CHARACTER(2) :: mydomain +mydomain = UpperCase(domain(1:2)) +nrow = SIZE(x, 1) +ncol = SIZE(x, 2) +IF (mydomain .EQ. "BA") nrow = nrow + 1 +CALL FromUnit_(x=x, domain=mydomain, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE FromUnit !---------------------------------------------------------------------------- From 803fc41214eda5b5c23060a9004ecbb76600a9b7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 19:09:02 +0900 Subject: [PATCH 067/359] Updates in TriangleInterpolationUtility --- .../src/TriangleInterpolationUtility.F90 | 155 +++- .../TriangleInterpolationUtility@Methods.F90 | 709 ++++++++++-------- 2 files changed, 547 insertions(+), 317 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 463931d91..c944ba760 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -16,7 +16,7 @@ ! MODULE TriangleInterpolationUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT USE String_Class, ONLY: String IMPLICIT NONE PRIVATE @@ -26,6 +26,7 @@ MODULE TriangleInterpolationUtility PUBLIC :: EquidistanceInPoint_Triangle PUBLIC :: EquidistancePoint_Triangle PUBLIC :: InterpolationPoint_Triangle +PUBLIC :: InterpolationPoint_Triangle_ PUBLIC :: LagrangeCoeff_Triangle PUBLIC :: Dubiner_Triangle @@ -54,7 +55,7 @@ MODULE TriangleInterpolationUtility ! PUBLIC :: BarycentricHeirarchicalBasisGradient_Triangle !---------------------------------------------------------------------------- -! GetTotalDOF_Triangle +! GetTotalDOF_Triangle !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -147,7 +148,7 @@ END FUNCTION FacetConnectivity_Triangle MODULE SUBROUTINE IJ2VEFC_Triangle(xi, eta, temp, order, N) REAL(DFP), INTENT(IN) :: xi(:, :) REAL(DFP), INTENT(IN) :: eta(:, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) + REAL(DFP), INTENT(INOUT) :: temp(:, :) INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), INTENT(IN) :: N END SUBROUTINE IJ2VEFC_Triangle @@ -254,6 +255,36 @@ MODULE PURE FUNCTION EquidistanceInPoint_Triangle(order, xij) RESULT(ans) END FUNCTION EquidistanceInPoint_Triangle END INTERFACE +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Aug 2022 +! summary: Returns equidistance points in triangle +! +!# Introduction +! +!- This function returns the equidistance points in triangle +!- All points are inside the triangle + +INTERFACE + MODULE PURE SUBROUTINE EquidistanceInPoint_Triangle_(order, ans, nrow, & + ncol, xij) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + !! If xij is present then number of rows in ans is same as xij + !! If xij is not present then number of rows in ans is 2. + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + END SUBROUTINE EquidistanceInPoint_Triangle_ +END INTERFACE + !---------------------------------------------------------------------------- ! EquidistancePoint_Triangle !---------------------------------------------------------------------------- @@ -284,6 +315,22 @@ MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Triangle(order, xij) RESULT(ans END FUNCTION EquidistancePoint_Triangle END INTERFACE +INTERFACE + MODULE RECURSIVE PURE SUBROUTINE EquidistancePoint_Triangle_(order, ans, & + nrow, ncol, xij) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and cols + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + END SUBROUTINE EquidistancePoint_Triangle_ +END INTERFACE + !---------------------------------------------------------------------------- ! BlythPozrikidis_Triangle !---------------------------------------------------------------------------- @@ -301,9 +348,8 @@ END FUNCTION EquidistancePoint_Triangle ! doi:10.1093/imamat/hxh077. INTERFACE - MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, & - & alpha, beta, lambda) & - & RESULT(ans) + MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType @@ -325,6 +371,37 @@ MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, & END FUNCTION BlythPozrikidis_Triangle END INTERFACE +!---------------------------------------------------------------------------- +! BlythPozrikidis_Triangle_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE BlythPozrikidis_Triangle_(order, ipType, ans, nrow, ncol, & + layout, xij, alpha, beta, lambda) + + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! xij coordinates + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END SUBROUTINE BlythPozrikidis_Triangle_ +END INTERFACE + !---------------------------------------------------------------------------- ! Isaac_Triangle !---------------------------------------------------------------------------- @@ -334,8 +411,8 @@ END FUNCTION BlythPozrikidis_Triangle ! summary: Isaac points on triangle INTERFACE - MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, & - & alpha, beta, lambda) & + MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, & + alpha, beta, lambda) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order @@ -358,6 +435,36 @@ MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, & END FUNCTION Isaac_Triangle END INTERFACE +!---------------------------------------------------------------------------- +! Isaac_Triangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE Isaac_Triangle_(order, ipType, ans, nrow, ncol, & + layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! xij coordinates + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END SUBROUTINE Isaac_Triangle_ +END INTERFACE + !---------------------------------------------------------------------------- ! InterpolationPoint_Triangle !---------------------------------------------------------------------------- @@ -391,7 +498,7 @@ END FUNCTION Isaac_Triangle INTERFACE MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, & - & layout, xij, alpha, beta, lambda) RESULT(ans) + layout, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType @@ -411,6 +518,34 @@ MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, & END FUNCTION InterpolationPoint_Triangle END INTERFACE +!---------------------------------------------------------------------------- +! InterpolationPoint_Triangle_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE InterpolationPoint_Triangle_(order, ipType, ans, nrow, & + ncol, layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! xij coordinates + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Coord of domain in xij format + CHARACTER(*), INTENT(IN) :: layout + !! local node numbering layout, always VEFC + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END SUBROUTINE InterpolationPoint_Triangle_ +END INTERFACE + !---------------------------------------------------------------------------- ! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- @@ -1484,7 +1619,7 @@ END FUNCTION HeirarchicalBasisGradient_Triangle1 INTERFACE HeirarchicalBasisGradient_Triangle_ MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_(order, pe1, pe2, pe3,& - & xij, refTriangle, ans, tsize1, tsize2, tsize3) + & 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 diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 index 9e50e8c6a..1589a40e1 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 @@ -15,7 +15,27 @@ ! along with this program. If not, see SUBMODULE(TriangleInterpolationUtility) Methods -USE BaseMethod +USE BaseType, ONLY: ipopt => TypeInterpolationOpt + +USE StringUtility, ONLY: UpperCase + +USE LineInterpolationUtility, ONLY: EquidistanceInPoint_Line, & + EquidistanceInPoint_Line_, & + LagrangeInDOF_Line, & + InterpolationPoint_Line_ + +USE MappingUtility, ONLY: FromUnitTriangle2Triangle_ + +USE ErrorHandling, ONLY: Errormsg + +USE RecursiveNodesUtility, ONLY: RecursiveNode2D_ + +USE IntegerUtility, ONLY: Size + +USE Display_Method, ONLY: ToString + +USE GlobalData, ONLY: stderr + IMPLICIT NONE CONTAINS @@ -40,41 +60,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE RefElemDomain_Triangle -SELECT CASE (UpperCase(baseContinuity)) +CHARACTER(2) :: bc +CHARACTER(3) :: bi + +bc = UpperCase(baseContinuity(1:2)) +bi = UpperCase(baseInterpol(1:3)) + +SELECT CASE (bc) + CASE ("H1") - SELECT CASE (UpperCase(baseInterpol)) - CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") - ans = "UNIT" - CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") - ans = "UNIT" - CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") + + SELECT CASE (bi) + + !! Lagrange + CASE ("LAG", "SER", "HER") ans = "UNIT" - CASE ( & - & "HIERARCHICALPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHICALPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION") + + CASE ("HIE", "HEI") ans = "BIUNIT" - CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") + + CASE ("ORT") ans = "BIUNIT" + CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given baseInterpol="//TRIM(baseInterpol), & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Triangle()", & - & unitno=stderr) + + CALL Errormsg( & + msg="No case found for given baseInterpol="//TRIM(baseInterpol), & + routine="RefElemDomain_Triangle()", file=__FILE__, line=__LINE__, & + unitno=stderr) + END SELECT + CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given baseContinuity="//TRIM(baseContinuity), & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Triangle()", & - & unitno=stderr) + + CALL Errormsg( & + msg="No case found for given baseContinuity="//TRIM(baseContinuity), & + file=__FILE__, line=__LINE__, routine="RefElemDomain_Triangle()", & + unitno=stderr) + END SELECT + END PROCEDURE RefElemDomain_Triangle !---------------------------------------------------------------------------- @@ -82,30 +107,21 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FacetConnectivity_Triangle -TYPE(String) :: baseInterpol0 -TYPE(String) :: baseContinuity0 - -baseInterpol0 = UpperCase(baseInterpol) -baseContinuity0 = UpperCase(baseContinuity) - -SELECT CASE (baseInterpol0%chars()) -CASE ( & - & "HIERARCHYPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHYPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION", & - & "ORTHOGONALPOLYNOMIAL", & - & "ORTHOGONAL", & - & "ORTHOGONALINTERPOLATION") +CHARACTER(3) :: bi + +bi = UpperCase(baseInterpol(1:3)) + +SELECT CASE (bi) +CASE ("HIE", "HEI", "ORT") ans(:, 1) = [1, 2] ans(:, 2) = [1, 3] ans(:, 3) = [2, 3] + CASE DEFAULT ans(:, 1) = [1, 2] ans(:, 2) = [2, 3] ans(:, 3) = [3, 1] + END SELECT END PROCEDURE FacetConnectivity_Triangle @@ -114,201 +130,261 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Triangle -INTEGER(I4B) :: nsd, n, ne, i1, i2 +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 2_I4B +END IF + +ncol = LagrangeDOF_Triangle(order=order) +ALLOCATE (ans(nrow, ncol)) + +CALL EquidistancePoint_Triangle_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) + +END PROCEDURE EquidistancePoint_Triangle + +!---------------------------------------------------------------------------- +! EquidistancePoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Triangle_ +INTEGER(I4B) :: i1, i2, aint, bint REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:3) = xij(1:nsd, 1:3) + nrow = SIZE(xij, 1) + x(1:nrow, 1:3) = xij(1:nrow, 1:3) ELSE - nsd = 2_I4B - x(1:nsd, 1) = [0.0, 0.0] - x(1:nsd, 2) = [1.0, 0.0] - x(1:nsd, 3) = [0.0, 1.0] + nrow = 2_I4B + x(1:nrow, 1) = [0.0, 0.0] + x(1:nrow, 2) = [1.0, 0.0] + x(1:nrow, 3) = [0.0, 1.0] END IF -n = LagrangeDOF_Triangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP +ncol = LagrangeDOF_Triangle(order=order) +! ALLOCATE (ans(nrow, n)) +! ans = 0.0_DFP !! points on vertex -ans(1:nsd, 1:3) = x(1:nsd, 1:3) +ans(1:nrow, 1:3) = x(1:nrow, 1:3) !! points on edge -ne = LagrangeInDOF_Line(order=order) +! ne = LagrangeInDOF_Line(order=order) i2 = 3 IF (order .GT. 1_I4B) THEN - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [1, 2])) - !! - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [2, 3])) - !! - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [3, 1])) - !! + i1 = i2 + 1 + ! i1 = i2 + 1; i2 = i1 + ne - 1 + ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & + ! order=order, & + ! xij=x(1:nrow, [1, 2])) + CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [1, 2]), & + ans=ans(:, i1:), nrow=aint, ncol=bint) + + i1 = i1 + bint + ! i1 = i2 + 1; i2 = i1 + ne - 1 + ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & + ! order=order, & + ! xij=x(1:nrow, [2, 3])) + CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [2, 3]), & + ans=ans(:, i1:), nrow=aint, ncol=bint) + + i1 = i1 + bint + ! i1 = i2 + 1; i2 = i1 + ne - 1 + ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & + ! order=order, & + ! xij=x(1:nrow, [3, 1])) + CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [3, 1]), & + ans=ans(:, i1:), nrow=aint, ncol=bint) + i2 = i1 + bint - 1 + END IF +IF (order .LE. 2_I4B) RETURN + !! points on face -IF (order .GT. 2_I4B) THEN - !! - IF (order .EQ. 3_I4B) THEN - i1 = i2 + 1 - ans(1:nsd, i1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP - ELSE - !! - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 1) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - i1 = i2 + 1 - ans(1:nsd, i1:) = EquidistancePoint_Triangle( & - & order=order - 3, & - & xij=xin(1:nsd, 1:3)) - !! - END IF +IF (order .EQ. 3_I4B) THEN + i1 = i2 + 1 + ans(1:nrow, i1) = (x(1:nrow, 1) + x(1:nrow, 2) + x(1:nrow, 3)) / 3.0_DFP + RETURN END IF -END PROCEDURE EquidistancePoint_Triangle +e1 = x(:, 2) - x(:, 1) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 3) - x(:, 1) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 1) = x(1:nrow, 1) + lam * e1(1:nrow) + mu * e2(1:nrow) + +e1 = x(:, 3) - x(:, 2) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 1) - x(:, 2) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 2) = x(1:nrow, 2) + lam * e1(1:nrow) + mu * e2(1:nrow) + +e1 = x(:, 1) - x(:, 3) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 2) - x(:, 3) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow) + +i1 = i2 + 1 +! ans(1:nrow, i1:) = EquidistancePoint_Triangle(order=order - 3, & +! xij=xin(1:nrow, 1:3)) +CALL EquidistancePoint_Triangle_(order=order - 3, xij=xin(1:nrow, 1:3), & + ans=ans(1:nrow, i1:), nrow=aint, ncol=bint) + +END PROCEDURE EquidistancePoint_Triangle_ !---------------------------------------------------------------------------- ! EquidistanceInPoint_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistanceInPoint_Triangle -INTEGER(I4B) :: nsd, n -REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu +INTEGER(I4B) :: nrow, ncol IF (order .LT. 3_I4B) THEN ALLOCATE (ans(0, 0)) RETURN END IF +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 2_I4B +END IF + +ncol = LagrangeInDOF_Triangle(order=order) + +CALL EquidistanceInPoint_Triangle_(order=order, ans=ans, nrow=nrow, & + ncol=ncol) + +END PROCEDURE EquidistanceInPoint_Triangle + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Triangle_ +REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu +INTEGER(I4B) :: aint, bint + +nrow = 0; ncol = 0 +IF (order .LT. 3_I4B) RETURN + x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:3) = xij(1:nsd, 1:3) + nrow = SIZE(xij, 1) + x(1:nrow, 1:3) = xij(1:nrow, 1:3) ELSE - nsd = 2_I4B - x(1:nsd, 1) = [0.0, 0.0] - x(1:nsd, 2) = [1.0, 0.0] - x(1:nsd, 3) = [0.0, 1.0] + nrow = 2_I4B + x(1:nrow, 1) = [0.0, 0.0] + x(1:nrow, 2) = [1.0, 0.0] + x(1:nrow, 3) = [0.0, 1.0] END IF -n = LagrangeInDOF_Triangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP +ncol = LagrangeInDOF_Triangle(order=order) +! ALLOCATE (ans(nrow, n)) +! ans = 0.0_DFP !! points on face IF (order .EQ. 3_I4B) THEN - ans(1:nsd, 1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP -ELSE - !! - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 3) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - e1 = x(:, 1) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 2) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - !! - ans(1:nsd, 1:) = EquidistancePoint_Triangle( & - & order=order - 3, & - & xij=xin(1:nsd, 1:3)) - !! + ans(1:nrow, 1) = (x(1:nrow, 1) + x(1:nrow, 2) + x(1:nrow, 3)) / 3.0_DFP + RETURN END IF -END PROCEDURE EquidistanceInPoint_Triangle +e1 = x(:, 2) - x(:, 1) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 3) - x(:, 1) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 1) = x(1:nrow, 1) + lam * e1(1:nrow) + mu * e2(1:nrow) + +e1 = x(:, 3) - x(:, 2) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 1) - x(:, 2) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 2) = x(1:nrow, 2) + lam * e1(1:nrow) + mu * e2(1:nrow) + +e1 = x(:, 1) - x(:, 3) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 2) - x(:, 3) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow) + +CALL EquidistancePoint_Triangle_(order=order - 3, xij=xin(1:nrow, 1:3), & + ans=ans, nrow=aint, ncol=bint) + +END PROCEDURE EquidistanceInPoint_Triangle_ !---------------------------------------------------------------------------- ! BlythPozrikidis_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE BlythPozrikidis_Triangle -REAL(DFP) :: v(order + 1), xi(order + 1, order + 1), eta(order + 1, order + 1) -REAL(DFP), ALLOCATABLE :: temp(:, :) -INTEGER(I4B) :: nsd, N, ii, jj, kk -CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle" - -v = InterpolationPoint_Line( & - & order=order, & - & ipType=ipType, & - & xij=[0.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & lambda=lambda, & - & beta=beta, & - & alpha=alpha) - -N = LagrangeDOF_Triangle(order=order) +INTEGER(I4B) :: nrow, ncol +ncol = LagrangeDOF_Triangle(order=order) +nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) +ALLOCATE (ans(nrow, ncol)) +CALL BlythPozrikidis_Triangle_(order=order, ipType=ipType, ans=ans,nrow=nrow,& + ncol=ncol, layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE BlythPozrikidis_Triangle -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2 -END IF +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BlythPozrikidis_Triangle_ +INTEGER(I4B), PARAMETER :: max_order = 30 +CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle()" +REAL(DFP), PARAMETER :: x(2) = [0.0_DFP, 1.0_DFP] + +REAL(DFP) :: v(max_order + 1), xi(max_order + 1, max_order + 1), & + eta(max_order + 1, max_order + 1), temp(2, 512) -CALL Reallocate(ans, nsd, N) -CALL Reallocate(temp, 2, N) +INTEGER(I4B) :: ii, jj, kk, tsize -xi = 0.0_DFP -eta = 0.0_DFP +LOGICAL(LGT) :: isx + +CALL InterpolationPoint_Line_(order=order, ipType=ipType, xij=x, & + layout="INCREASING", lambda=lambda, & + beta=beta, alpha=alpha, ans=v, tsize=tsize) + +ncol = LagrangeDOF_Triangle(order=order) +nrow = 2 + +isx = .FALSE.; IF (PRESENT(xij)) isx = .TRUE. +IF (isx) nrow = SIZE(xij, 1) + +xi(1:order + 1, 1:order + 1) = 0.0_DFP +eta(1:order + 1, 1:order + 1) = 0.0_DFP DO ii = 1, order + 1 DO jj = 1, order + 2 - ii @@ -318,91 +394,101 @@ END DO END DO -IF (layout .EQ. "VEFC") THEN +SELECT CASE (layout) - CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N) +CASE ("VEFC") - IF (PRESENT(xij)) THEN - ans = FromUnitTriangle2Triangle(xin=temp, & - & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) - ELSE - ans = temp + CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=ncol) + + IF (isx) THEN + CALL FromUnitTriangle2Triangle_(xin=temp(1:2, 1:ncol), x1=xij(:, 1), & + x2=xij(:, 2), x3=xij(:, 3), ans=ans, nrow=nrow, ncol=ncol) + RETURN END IF -ELSE - CALL ErrorMsg( & - & msg="Only layout=VEFC is allowed, given layout is " & - & //TRIM(layout), & - & file=__FILE__, & - & routine=myname, & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF + ans(1:2, 1:ncol) = temp(1:2, 1:ncol) -IF (ALLOCATED(temp)) DEALLOCATE (temp) +CASE DEFAULT -END PROCEDURE BlythPozrikidis_Triangle + CALL ErrorMsg(msg="layout=VEFC is allowed, found layout is "//TRIM(layout), & + file=__FILE__, routine=myname, line=__LINE__, unitno=stderr) + +END SELECT + +END PROCEDURE BlythPozrikidis_Triangle_ !---------------------------------------------------------------------------- ! Isaac_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE Isaac_Triangle -REAL(DFP) :: xi(order + 1, order + 1), eta(order + 1, order + 1) -REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) -INTEGER(I4B) :: nsd, N, cnt, ii, jj -CHARACTER(*), PARAMETER :: myName = "Isaac_Triangle" +INTEGER(I4B) :: nrow, ncol -rPoints = RecursiveNode2D(order=order, ipType=ipType, domain="UNIT", & - & alpha=alpha, beta=beta, lambda=lambda) +ncol = SIZE(n=order, d=2) +nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) -N = SIZE(rPoints, 2) +ALLOCATE (ans(nrow, ncol)) -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 2 -END IF +CALL Isaac_Triangle_(order=order, ipType=ipType, ans=ans, nrow=nrow, & + ncol=ncol, layout=layout, xij=xij, alpha=alpha, & + beta=beta, lambda=lambda) + +END PROCEDURE Isaac_Triangle + +!---------------------------------------------------------------------------- +! Isaac_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Isaac_Triangle_ +CHARACTER(*), PARAMETER :: myName = "Isaac_Triangle()" +INTEGER(I4B), PARAMETER :: max_order = 30 +REAL(DFP) :: xi(max_order + 1, max_order + 1), & + eta(max_order + 1, max_order + 1), & + temp(2, 512) -CALL Reallocate(ans, nsd, N) +! REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) +INTEGER(I4B) :: cnt, ii, jj +INTEGER(I4B) :: nn + +nn = 1 + order + +CALL RecursiveNode2D_(order=order, ipType=ipType, domain="UNIT", & + alpha=alpha, beta=beta, lambda=lambda, ans=temp, & + nrow=nrow, ncol=ncol) + +IF (PRESENT(xij)) nrow = SIZE(xij, 1) !! convert from rPoints to xi and eta cnt = 0 -xi = 0.0_DFP -eta = 0.0_DFP +xi(1:nn, 1:nn) = 0.0_DFP +eta(1:nn, 1:nn) = 0.0_DFP -DO ii = 1, order + 1 - DO jj = 1, order + 2 - ii +DO ii = 1, nn + DO jj = 1, nn + 1 - ii cnt = cnt + 1 - xi(ii, jj) = rPoints(1, cnt) - eta(ii, jj) = rPoints(2, cnt) + xi(ii, jj) = temp(1, cnt) + eta(ii, jj) = temp(2, cnt) END DO END DO IF (layout .EQ. "VEFC") THEN - CALL Reallocate(temp, 2, N) - CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N) + ! CALL Reallocate(temp, 2, N) + CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=ncol) + IF (PRESENT(xij)) THEN - ans = FromUnitTriangle2Triangle(xin=temp, & - & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) - ELSE - ans = temp + CALL FromUnitTriangle2Triangle_(xin=temp(:, 1:ncol), ans=ans, & + nrow=nrow, ncol=ncol, x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) + RETURN END IF -ELSE - CALL ErrorMsg( & - & msg="Only layout=VEFC is allowed, given layout is " & - & //TRIM(layout), & - & file=__FILE__, & - & routine=myname, & - & line=__LINE__, & - & unitno=stderr) + + ans(1:nrow, 1:ncol) = temp(1:nrow, 1:ncol) RETURN END IF -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints) -END PROCEDURE Isaac_Triangle +CALL ErrorMsg(file=__FILE__, routine=myname, line=__LINE__, unitno=stderr, & + msg="Only layout=VEFC is allowed, found layout is "//layout) + +END PROCEDURE Isaac_Triangle_ !---------------------------------------------------------------------------- ! @@ -465,15 +551,13 @@ END IF IF (cnt .NE. N) THEN - CALL ErrorMsg( & - & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" & - & //tostring(N), & - & file=__FILE__, & - & routine="IJ2VEFC_Triangle()", & - & line=__LINE__, & - & unitno=stderr) + CALL ErrorMsg(file=__FILE__, routine="IJ2VEFC_Triangle()", & + line=__LINE__, unitno=stderr, & + msg="cnt="//ToString(cnt)//" not equal to total DOF, N=" & + //ToString(N)) RETURN END IF + END PROCEDURE IJ2VEFC_Triangle !---------------------------------------------------------------------------- @@ -481,67 +565,78 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Triangle -CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle" +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 2 +END IF SELECT CASE (ipType) -CASE (Equidistance) - ans = EquidistancePoint_Triangle(xij=xij, order=order) -CASE (Feket, Hesthaven, ChenBabuska) - CALL ErrorMsg( & - & msg="Feket, Hesthaven, ChenBabuska nodes not available", & - & file=__FILE__, & - & routine=myname, & - & line=__LINE__, & - & unitno=stderr) - RETURN -CASE (BlythPozLegendre) - ans = BlythPozrikidis_Triangle( & - & order=order, & - & ipType=GaussLegendreLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE (BlythPozChebyshev) - ans = BlythPozrikidis_Triangle( & - & order=order, & - & ipType=GaussChebyshevLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE (IsaacLegendre, GaussLegendreLobatto) - ans = Isaac_Triangle( & - & order=order, & - & ipType=GaussLegendreLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE (IsaacChebyshev, GaussChebyshevLobatto) - ans = Isaac_Triangle( & - & order=order, & - & ipType=GaussChebyshevLobatto, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -CASE DEFAULT - ans = Isaac_Triangle( & - & order=order, & - & ipType=ipType, & - & layout="VEFC", & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +CASE (ipopt%Equidistance, ipopt%BlythPozChebyshev, ipopt%BlythPozLegendre) + ncol = LagrangeDOF_Triangle(order=order) + +CASE (ipopt%IsaacLegendre, ipopt%IsaacChebyshev, & + ipopt%GaussLegendreLobatto, ipopt%GaussChebyshevLobatto) + ncol = SIZE(n=order, d=2) + END SELECT + +ALLOCATE (ans(nrow, ncol)) + +CALL InterpolationPoint_Triangle_(order=order, ipType=ipType, ans=ans, & + nrow=nrow, ncol=ncol, xij=xij, alpha=alpha, & + beta=beta, lambda=lambda, layout=layout) + END PROCEDURE InterpolationPoint_Triangle +!---------------------------------------------------------------------------- +! InterpolationPoint_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Triangle_ +CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle_()" + +SELECT CASE (ipType) +CASE (ipopt%Equidistance) + CALL EquidistancePoint_Triangle_(xij=xij, order=order, ans=ans, & + nrow=nrow, ncol=ncol) + +CASE (ipopt%BlythPozLegendre) + CALL BlythPozrikidis_Triangle_(order=order, ans=ans, nrow=nrow, ncol=ncol, & + ipType=ipopt%GaussLegendreLobatto, layout="VEFC", xij=xij, & + alpha=alpha, beta=beta, lambda=lambda) + +CASE (ipopt%BlythPozChebyshev) + CALL BlythPozrikidis_Triangle_(order=order, & + ipType=ipopt%GaussChebyshevLobatto, & + layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (ipopt%IsaacLegendre, ipopt%GaussLegendreLobatto) + CALL Isaac_Triangle_(order=order, & + ipType=ipopt%GaussLegendreLobatto, & + layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (ipopt%IsaacChebyshev, ipopt%GaussChebyshevLobatto) + CALL Isaac_Triangle_(order=order, ipType=ipopt%GaussChebyshevLobatto, & + layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (ipopt%Feket, ipopt%Hesthaven, ipopt%ChenBabuska) + CALL ErrorMsg(msg="Feket, Hesthaven, ChenBabuska nodes not available", & + file=__FILE__, routine=myname, line=__LINE__, unitno=stderr) + +CASE DEFAULT + CALL Isaac_Triangle_(order=order, ipType=ipType, layout="VEFC", & + xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) +END SELECT + +END PROCEDURE InterpolationPoint_Triangle_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From b620a06409a86342a85424261875fa93b399ae69 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 19:09:32 +0900 Subject: [PATCH 068/359] updates in base type --- src/modules/BaseType/src/BaseType.F90 | 82 +++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index adb0d44e4..7701f44b3 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -192,6 +192,10 @@ MODULE BaseType PUBLIC :: TypePrecondOpt PUBLIC :: TypeConvergenceOpt PUBLIC :: TypeSolverNameOpt +PUBLIC :: TypeElemNameOpt +PUBLIC :: TypePolynomialOpt +PUBLIC :: TypeQuadratureOpt +PUBLIC :: TypeInterpolationOpt INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 @@ -1836,4 +1840,82 @@ END FUNCTION iface_MatrixFunction TYPE(SolverNameOpt_), PARAMETER :: TypeSolverNameOpt = & SolverNameOpt_() +!---------------------------------------------------------------------------- +! TypeElemNameOpt +!---------------------------------------------------------------------------- + +TYPE :: ElemNameOpt_ + INTEGER(I4B) :: point = Point + INTEGER(I4B) :: line = Line + INTEGER(I4B) :: triangle = Triangle + INTEGER(I4B) :: quadrangle = Quadrangle + INTEGER(I4B) :: tetrahedron = Tetrahedron + INTEGER(I4B) :: hexahedron = Hexahedron + INTEGER(I4B) :: prism = Prism + INTEGER(I4B) :: pyramid = Pyramid +END TYPE ElemNameOpt_ + +TYPE(ElemNameOpt_), PARAMETER :: TypeElemNameOpt = ElemNameOpt_() + +!---------------------------------------------------------------------------- +! TypePolynomialOpt +!---------------------------------------------------------------------------- + +TYPE :: PolynomialOpt_ + INTEGER(I4B) :: monomial = Monomial + INTEGER(I4B) :: lagrange = LagrangePolynomial + INTEGER(I4B) :: serendipity = SerendipityPolynomial + INTEGER(I4B) :: hierarchical = HierarchicalPolynomial + INTEGER(I4B) :: orthogonal = OrthogonalPolynomial + INTEGER(I4B) :: jacobi = JacobiPolynomial + INTEGER(I4B) :: legendre = LegendrePolynomial + INTEGER(I4B) :: chebyshev = ChebyshevPolynomial + INTEGER(I4B) :: lobatto = LobattoPolynomial + INTEGER(I4B) :: unscaledLobatto = UnscaledLobattoPolynomial + INTEGER(I4B) :: hermit = HermitPolynomial + INTEGER(I4B) :: ultraspherical = UltrasphericalPolynomial +END TYPE PolynomialOpt_ + +TYPE(PolynomialOpt_), PARAMETER :: TypePolynomialOpt = PolynomialOpt_() + +!---------------------------------------------------------------------------- +! TypeQuadratureOpt +!---------------------------------------------------------------------------- + +TYPE :: QuadratureOpt_ + INTEGER(I4B) :: equidistance = EquidistanceQP + INTEGER(I4B) :: Gauss = GaussQP + INTEGER(I4B) :: GaussLegendre = GaussLegendreQP + INTEGER(I4B) :: GaussLegendreLobatto = GaussLegendreLobattoQP + INTEGER(I4B) :: GaussLegendreRadauLeft = GaussLegendreRadauLeft + INTEGER(I4B) :: GaussLegendreRadauRight = GaussLegendreRadauRight + INTEGER(I4B) :: GaussRadau = GaussRadauQP + INTEGER(I4B) :: GaussRadauLeft = GaussRadauLeftQP + INTEGER(I4B) :: GaussRadauRight = GaussRadauRightQP + INTEGER(I4B) :: GaussLobatto = GaussLobattoQP + INTEGER(I4B) :: GaussChebyshev = GaussChebyshevQP + INTEGER(I4B) :: GaussChebyshevLobatto = GaussChebyshevLobattoQP + INTEGER(I4B) :: GaussChebyshevRadauLeft = GaussChebyshevRadauLeft + INTEGER(I4B) :: GaussChebyshevRadauRight = GaussChebyshevRadauRight + INTEGER(I4B) :: GaussJacobi = GaussJacobiQP + INTEGER(I4B) :: GaussJacobiLobatto = GaussJacobiLobattoQP + INTEGER(I4B) :: GaussJacobiRadauLeft = GaussJacobiRadauLeft + INTEGER(I4B) :: GaussJacobiRadauRight = GaussJacobiRadauRight + INTEGER(I4B) :: GaussUltraSpherical = GaussUltraSphericalQP + INTEGER(I4B) :: GaussUltraSphericalLobatto = GaussUltraSphericalLobattoQP + INTEGER(I4B) :: GaussUltraSphericalRadauLeft = GaussUltraSphericalRadauLeft + INTEGER(I4B) :: GaussUltraSphericalRadauRight = & + GaussUltraSphericalRadauRight + INTEGER(I4B) :: ChenBabuska = ChenBabuskaQP + INTEGER(I4B) :: Hesthaven = HesthavenQP + INTEGER(I4B) :: Feket = FeketQP + INTEGER(I4B) :: BlythPozLegendre = BlythPozLegendreQP + INTEGER(I4B) :: BlythPozChebyshev = BlythPozChebyshevQP + INTEGER(I4B) :: IsaacLegendre = IsaacLegendreQP + INTEGER(I4B) :: IsaacChebyshev = IsaacChebyshevQP +END TYPE QuadratureOpt_ + +TYPE(QuadratureOpt_), PARAMETER :: TypeQuadratureOpt = QuadratureOpt_() +TYPE(QuadratureOpt_), PARAMETER :: TypeInterpolationOpt = QuadratureOpt_() + END MODULE BaseType From b16462c58ea667d2dfe50a3261d53d12d4b7a970 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 19:09:44 +0900 Subject: [PATCH 069/359] updates in global data --- src/modules/GlobalData/src/GlobalData.F90 | 24 ++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 index caf86f440..1f40bac1f 100755 --- a/src/modules/GlobalData/src/GlobalData.F90 +++ b/src/modules/GlobalData/src/GlobalData.F90 @@ -288,13 +288,19 @@ MODULE GlobalData INTEGER(I4B), PARAMETER :: HierarchyPolynomial = 3 INTEGER(I4B), PARAMETER :: Hierarchy = HierarchyPolynomial INTEGER(I4B), PARAMETER :: Jacobi = 4 +INTEGER(I4B), PARAMETER :: JacobiPolynomial = Jacobi INTEGER(I4B), PARAMETER :: Ultraspherical = 5 +INTEGER(I4B), PARAMETER :: UltrasphericalPolynomial = Ultraspherical INTEGER(I4B), PARAMETER :: Legendre = 6 +INTEGER(I4B), PARAMETER :: LegendrePolynomial = 6 INTEGER(I4B), PARAMETER :: Chebyshev = 7 +INTEGER(I4B), PARAMETER :: ChebyshevPolynomial = 7 INTEGER(I4B), PARAMETER :: Lobatto = 8 +INTEGER(I4B), PARAMETER :: LobattoPolynomial = 8 INTEGER(I4B), PARAMETER :: Orthogonal = 9 INTEGER(I4B), PARAMETER :: OrthogonalPolynomial = Orthogonal INTEGER(I4B), PARAMETER :: UnscaledLobatto = 10 +INTEGER(I4B), PARAMETER :: UnscaledLobattoPolynomial = 10 INTEGER(I4B), PARAMETER :: HermitPolynomial = 11 !! !! Quadrature types @@ -332,23 +338,35 @@ MODULE GlobalData !! !! Type of quadrature points !! +INTEGER(I4B), PARAMETER :: EquidistanceQP = Equidistance INTEGER(I4B), PARAMETER :: GaussQP = Gauss INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre +INTEGER(I4B), PARAMETER :: GaussLegendreLobattoQP = GaussLegendreLobatto INTEGER(I4B), PARAMETER :: GaussRadauQP = GaussRadau INTEGER(I4B), PARAMETER :: GaussRadauLeftQP = GaussRadauLeft INTEGER(I4B), PARAMETER :: GaussRadauRightQP = GaussRadauRight INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto INTEGER(I4B), PARAMETER :: GaussChebyshevQP = GaussChebyshev -!! +INTEGER(I4B), PARAMETER :: GaussChebyshevLobattoQP = GaussChebyshevLobatto +INTEGER(I4B), PARAMETER :: GaussJacobiQP = GaussJacobi +INTEGER(I4B), PARAMETER :: GaussJacobiLobattoQP = GaussJacobiLobatto +INTEGER(I4B), PARAMETER :: GaussUltrasphericalQP = GaussUltraspherical +INTEGER(I4B), PARAMETER :: GaussUltrasphericalLobattoQP = & + GaussUltrasphericalLobatto INTEGER(I4B), PARAMETER :: ChenBabuska = 22 !! for triangle nodes +INTEGER(I4B), PARAMETER :: ChenBabuskaQP = 22 !! for triangle nodes INTEGER(I4B), PARAMETER :: Hesthaven = 23 !! for triangle nodes +INTEGER(I4B), PARAMETER :: HesthavenQP = 23 !! for triangle nodes INTEGER(I4B), PARAMETER :: Feket = 24 !! for triangle nodes -!! +INTEGER(I4B), PARAMETER :: FeketQP = 24 !! for triangle nodes INTEGER(I4B), PARAMETER :: BlythPozLegendre = 25 !! for triangle +INTEGER(I4B), PARAMETER :: BlythPozLegendreQP = 25 !! for triangle INTEGER(I4B), PARAMETER :: BlythPozChebyshev = 26 !! for triangle -!! +INTEGER(I4B), PARAMETER :: BlythPozChebyshevQP = 26 !! for triangle INTEGER(I4B), PARAMETER :: IsaacLegendre = 27 !! for triangle +INTEGER(I4B), PARAMETER :: IsaacLegendreQP = 27 !! for triangle INTEGER(I4B), PARAMETER :: IsaacChebyshev = 28 !! for triangle +INTEGER(I4B), PARAMETER :: IsaacChebyshevQP = 28 !! for triangle !! !! Type of Lagrange Interpolation Points !! From a8f76e0eb35d13f813d0071db95219e9f29ba3dd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 19:10:40 +0900 Subject: [PATCH 070/359] updates in quadrature point methods --- .../src/QuadraturePoint_Method.F90 | 46 ++++--------------- 1 file changed, 10 insertions(+), 36 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index 8ba04ee10..341110e9e 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -181,12 +181,8 @@ END SUBROUTINE quad_initiate4 ! summary: This routine constructs the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate5( & - & obj, & - & refElem, & - & order, & - & quadratureType, & - & alpha, beta, lambda) + MODULE SUBROUTINE quad_initiate5(obj, refElem, order, quadratureType, & + alpha, beta, lambda) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -223,14 +219,8 @@ END SUBROUTINE quad_initiate5 ! summary: This routine initiates the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate6( & - & obj, & - & refElem, & - & nips, & - & quadratureType, & - & alpha, & - & beta, & - & lambda) + MODULE SUBROUTINE quad_initiate6(obj, refElem, nips, quadratureType, & + alpha, beta, lambda) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -267,16 +257,9 @@ END SUBROUTINE quad_initiate6 ! summary: This routine initiates the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate7( & - & obj, & - & refElem, & - & p, q, r, & - & quadratureType1, & - & quadratureType2, & - & quadratureType3, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3) + MODULE SUBROUTINE quad_initiate7(obj, refElem, p, q, r, quadratureType1, & + quadratureType2, quadratureType3, alpha1, beta1, lambda1, alpha2, & + beta2, lambda2, alpha3, beta3, lambda3) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -321,18 +304,9 @@ END SUBROUTINE quad_initiate7 ! summary: This routine initiates the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate8( & - & obj, & - & refElem, & - & nipsx, & - & nipsy, & - & nipsz, & - & quadratureType1, & - & quadratureType2, & - & quadratureType3, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3) + MODULE SUBROUTINE quad_initiate8(obj, refElem, nipsx, nipsy, nipsz, & + quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & + lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem From 1d95957d5a9edf9c7fecdbaca2fe1dcce193d6e8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Jun 2024 19:11:05 +0900 Subject: [PATCH 071/359] updates in line interpolation util --- .../src/LineInterpolationUtility.F90 | 2 + .../src/LineInterpolationUtility@Methods.F90 | 153 +++++++++++------- 2 files changed, 94 insertions(+), 61 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 46ba135e8..ba4bca095 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -28,7 +28,9 @@ MODULE LineInterpolationUtility PUBLIC :: GetTotalDOF_Line PUBLIC :: GetTotalInDOF_Line PUBLIC :: EquidistanceInPoint_Line +PUBLIC :: EquidistanceInPoint_Line_ PUBLIC :: EquidistancePoint_Line +PUBLIC :: EquidistancePoint_Line_ PUBLIC :: InterpolationPoint_Line PUBLIC :: InterpolationPoint_Line_ PUBLIC :: LagrangeCoeff_Line diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 221f37885..ec2f69f8e 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -18,10 +18,39 @@ SUBMODULE(LineInterpolationUtility) Methods USE BaseType, ONLY: ipopt => TypeInterpolationOpt, & qpopt => TypeQuadratureOpt, & - polyopt => TypePolynomialOpt + polyopt => TypePolynomialOpt, & + elmopt => TypeElemNameOpt USE GlobalData, ONLY: stderr +USE StringUtility, ONLY: UpperCase + +USE MappingUtility, ONLY: FromBiunitLine2Segment_, & + FromBiunitLine2Segment, & + FromUnitLine2BiUnitLine + +USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol, & + EvalAllOrthopol + +USE InputUtility, ONLY: Input + +USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde, & + LagrangeCoeff + +USE ErrorHandling, ONLY: ErrorMsg + +USE LegendrePolynomialUtility, ONLY: LegendreQuadrature + +USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature + +USE JacobiPolynomialUtility, ONLY: JacobiQuadrature + +USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature + +USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat + +USE SortUtility, ONLY: HeapSort + IMPLICIT NONE CONTAINS @@ -383,41 +412,41 @@ CALL handle_increasing CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=Gauss) + 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=Gauss) + 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=GaussLobatto) + 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=GaussLobatto) + 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=Gauss, & + 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=GaussLobatto, & + 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=Gauss, & +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=GaussLobatto, & + CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto, & lambda=lambda) CALL handle_vefc @@ -515,44 +544,45 @@ END SUBROUTINE handle_error CASE (ipopt%Equidistance) CALL EquidistancePoint_Line_(xij=xij, order=order, tsize=tsize, ans=ans) - IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans) + + IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans(1:tsize)) CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=tsize, pt=ans, quadType=Gauss) + CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss) CALL handle_non_equidistance CASE (ipopt%GaussChebyshev) - CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=Gauss) + CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%Gauss) CALL handle_non_equidistance CASE (ipopt%GaussJacobi) - CALL JacobiQuadrature(n=tsize, pt=ans, quadType=Gauss, alpha=alpha, & + 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=Gauss, & + 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=GaussLobatto) + 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=GaussLobatto) + 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=GaussLobatto, alpha=alpha, & + 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=GaussLobatto, & + CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, & lambda=lambda) CALL handle_vefc CALL handle_non_equidistance @@ -637,8 +667,8 @@ END SUBROUTINE handle_error REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv INTEGER(I4B) :: info -v = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) -CALL getLU(A=v, IPIV=ipiv, info=info) +v = LagrangeVandermonde(order=order, xij=xij, elemType=elmopt%Line) +CALL GetLU(A=v, IPIV=ipiv, info=info) ans = 0.0_DFP; ans(i) = 1.0_DFP CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) END PROCEDURE LagrangeCoeff_Line1 @@ -652,7 +682,7 @@ END SUBROUTINE handle_error INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv INTEGER(I4B) :: info vtemp = v; ipiv = 0 -CALL getLU(A=vtemp, IPIV=ipiv, info=info) +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) ans = 0.0_DFP; ans(i) = 1.0_DFP CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) END PROCEDURE LagrangeCoeff_Line2 @@ -672,7 +702,7 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Line4 -ans = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) +ans = LagrangeVandermonde(order=order, xij=xij, elemType=elmopt%Line) CALL GetInvMat(ans) END PROCEDURE LagrangeCoeff_Line4 @@ -843,7 +873,7 @@ END SUBROUTINE handle_error RETURN END IF -basisType0 = input(default=Monomial, option=basisType) +basisType0 = input(default=polyopt%Monomial, option=basisType) SELECT CASE (basisType0) CASE (polyopt%Monomial) ans(1) = 1.0_DFP @@ -852,7 +882,7 @@ END SUBROUTINE handle_error END DO CASE DEFAULT - IF (basisType0 .EQ. Jacobi) THEN + 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", & @@ -864,7 +894,7 @@ END SUBROUTINE handle_error END IF END IF - IF (basisType0 .EQ. Ultraspherical) THEN + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN IF (.NOT. PRESENT(lambda)) THEN CALL Errormsg(& & msg="lambda should be present for basisType=Ultraspherical", & @@ -906,7 +936,7 @@ END SUBROUTINE handle_error RETURN END IF -basisType0 = input(default=Monomial, option=basisType) +basisType0 = input(default=polyopt%Monomial, option=basisType) SELECT CASE (basisType0) CASE (polyopt%Monomial) ans(1) = 0.0_DFP @@ -915,7 +945,7 @@ END SUBROUTINE handle_error END DO CASE DEFAULT - IF (basisType0 .EQ. Jacobi) THEN + 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", & @@ -927,7 +957,7 @@ END SUBROUTINE handle_error END IF END IF - IF (basisType0 .EQ. Ultraspherical) THEN + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN IF (.NOT. PRESENT(lambda)) THEN CALL Errormsg(& & msg="lambda should be present for basisType=Ultraspherical", & @@ -969,7 +999,7 @@ END SUBROUTINE handle_error RETURN END IF -basisType0 = input(default=Monomial, option=basisType) +basisType0 = input(default=polyopt%Monomial, option=basisType) SELECT CASE (basisType0) CASE (polyopt%Monomial) ans(:, 1) = 1.0_DFP @@ -978,7 +1008,7 @@ END SUBROUTINE handle_error END DO CASE DEFAULT - IF (basisType0 .EQ. Jacobi) THEN + 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", & @@ -990,7 +1020,7 @@ END SUBROUTINE handle_error END IF END IF - IF (basisType0 .EQ. Ultraspherical) THEN + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN IF (.NOT. PRESENT(lambda)) THEN CALL Errormsg(& & msg="lambda should be present for basisType=Ultraspherical", & @@ -1032,7 +1062,7 @@ END SUBROUTINE handle_error RETURN END IF -basisType0 = input(default=Monomial, option=basisType) +basisType0 = input(default=polyopt%Monomial, option=basisType) SELECT CASE (basisType0) CASE (polyopt%Monomial) ans(:, 1) = 0.0_DFP @@ -1041,7 +1071,7 @@ END SUBROUTINE handle_error END DO CASE DEFAULT - IF (basisType0 .EQ. Jacobi) THEN + 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", & @@ -1053,7 +1083,7 @@ END SUBROUTINE handle_error END IF END IF - IF (basisType0 .EQ. Ultraspherical) THEN + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN IF (.NOT. PRESENT(lambda)) THEN CALL Errormsg(& & msg="lambda should be present for basisType=Ultraspherical", & @@ -1128,20 +1158,20 @@ END SUBROUTINE handle_error REAL(DFP) :: t1 LOGICAL(LGT) :: changeLayout -IF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN +IF (ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType)) THEN IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN CALL ErrorMsg(& - & msg="alpha and beta should be present for quadType=GaussJacobi", & + & msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & & file=__FILE__, & & routine="QuadraturePoint_Line3", & & line=__LINE__, & & unitno=stderr) END IF RETURN -ELSEIF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN +ELSEIF (ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType)) THEN IF (.NOT. PRESENT(lambda)) THEN CALL ErrorMsg(& - & msg="lambda should be present for quadType=GaussUltraspherical", & + & msg="lambda should be present for quadType=ipopt%GaussUltraspherical", & & file=__FILE__, & & routine="QuadraturePoint_Line3", & & line=__LINE__, & @@ -1158,69 +1188,70 @@ END SUBROUTINE handle_error astr = TRIM(UpperCase(layout)) np = nips(1) -CALL Reallocate(ans, nsd + 1_I4B, np) +! CALL Reallocate(ans, nsd + 1_I4B, np) +ALLOCATE (ans(nsd + 1_I4B, np)) changeLayout = .FALSE. SELECT CASE (quadType) CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) CASE (ipopt%GaussLegendreRadauLeft) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft) CASE (ipopt%GaussLegendreRadauRight) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight) CASE (ipopt%GaussLegendreLobatto) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE (ipopt%GaussChebyshev) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=Gauss) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) CASE (ipopt%GaussChebyshevRadauLeft) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft) CASE (ipopt%GaussChebyshevRadauRight) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight) CASE (ipopt%GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE (ipopt%GaussJacobi) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss, & + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & alpha=alpha, beta=beta) CASE (ipopt%GaussJacobiRadauLeft) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft, & + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft, & alpha=alpha, beta=beta) CASE (ipopt%GaussJacobiRadauRight) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight, & + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight, & alpha=alpha, beta=beta) CASE (ipopt%GaussJacobiLobatto) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto, & + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto, & alpha=alpha, beta=beta) IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE (ipopt%GaussUltraspherical) - CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss, & + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & lambda=lambda) CASE (ipopt%GaussUltrasphericalRadauLeft) CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & - quadType=GaussRadauLeft, lambda=lambda) + quadType=ipopt%GaussRadauLeft, lambda=lambda) CASE (ipopt%GaussUltrasphericalRadauRight) CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & - quadType=GaussRadauRight, lambda=lambda) + quadType=ipopt%GaussRadauRight, lambda=lambda) CASE (ipopt%GaussUltrasphericalLobatto) CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & - quadType=GaussLobatto, lambda=lambda) + quadType=ipopt%GaussLobatto, lambda=lambda) IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE DEFAULT @@ -1324,12 +1355,12 @@ END SUBROUTINE handle_error ans = EvalAllOrthopol( & & n=order, & & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=Lobatto) + & orthopol=polyopt%Lobatto) CASE ("BIUNIT") ans = EvalAllOrthopol( & & n=order, & & x=xij(1, :), & - & orthopol=Lobatto) + & orthopol=polyopt%Lobatto) CASE DEFAULT ans = 0.0_DFP CALL Errormsg(& @@ -1356,13 +1387,13 @@ END SUBROUTINE handle_error ans(:, :, 1) = GradientEvalAllOrthopol( & & n=order, & & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=Lobatto) + & orthopol=polyopt%Lobatto) ans = ans * 2.0_DFP CASE ("BIUNIT") ans(:, :, 1) = GradientEvalAllOrthopol( & & n=order, & & x=xij(1, :), & - & orthopol=Lobatto) + & orthopol=polyopt%Lobatto) CASE DEFAULT ans = 0.0_DFP CALL Errormsg(& @@ -1387,7 +1418,7 @@ END SUBROUTINE handle_error ans = 0.0_DFP astr = UpperCase(refLine) -IF (basisType .EQ. Jacobi) THEN +IF (basisType .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", & @@ -1399,7 +1430,7 @@ END SUBROUTINE handle_error END IF END IF -IF (basisType .EQ. Ultraspherical) THEN +IF (basisType .EQ. polyopt%Ultraspherical) THEN IF (.NOT. PRESENT(lambda)) THEN CALL Errormsg(& & msg="lambda should be present for basisType=Ultraspherical", & From d3708b8a972db960942bcf102bc7c6586f9ee300 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 10:09:39 +0900 Subject: [PATCH 072/359] Updates in QuadrangleInterpolationUtility --- .../src/QuadrangleInterpolationUtility.F90 | 131 ++++++++-------- ...QuadrangleInterpolationUtility@Methods.F90 | 142 +++++++++--------- 2 files changed, 139 insertions(+), 134 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 20109601e..d129e380e 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -25,6 +25,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: EquidistancePoint_Quadrangle PUBLIC :: EquidistanceInPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle +PUBLIC :: InterpolationPoint_Quadrangle_ PUBLIC :: LagrangeCoeff_Quadrangle PUBLIC :: Dubiner_Quadrangle PUBLIC :: Dubiner_Quadrangle_ @@ -418,33 +419,12 @@ END FUNCTION EquidistanceInPoint_Quadrangle2 ! also follow the same convention. Please read Gmsh manual on this topic. INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle1( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION InterpolationPoint_Quadrangle1(order, ipType, layout, & + xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of element INTEGER(I4B), INTENT(IN) :: ipType !! 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(:, :) @@ -460,6 +440,33 @@ MODULE FUNCTION InterpolationPoint_Quadrangle1( & END FUNCTION InterpolationPoint_Quadrangle1 END INTERFACE InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle_ +!---------------------------------------------------------------------------- + +INTERFACE InterpolationPoint_Quadrangle_ + MODULE SUBROUTINE InterpolationPoint_Quadrangle1_(order, ipType, ans, & + nrow, ncol, layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + CHARACTER(*), INTENT(IN) :: layout + !! VEFC, INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Quadrangle1_ +END INTERFACE InterpolationPoint_Quadrangle_ + !---------------------------------------------------------------------------- ! InterpolationPoint_Quadrangle !---------------------------------------------------------------------------- @@ -490,51 +497,16 @@ END FUNCTION InterpolationPoint_Quadrangle1 ! also follow the same convention. Please read Gmsh manual on this topic. INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle2( & - & p, q, ipType1, ipType2, layout, xij, alpha1, beta1, & - & lambda1, alpha2, beta2, lambda2) RESULT(ans) + MODULE FUNCTION InterpolationPoint_Quadrangle2(p, q, ipType1, ipType2, & + layout, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order of element in x direction INTEGER(I4B), INTENT(IN) :: q !! order of element in y direction INTEGER(I4B), INTENT(IN) :: ipType1 !! interpolation point type in x direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight INTEGER(I4B), INTENT(IN) :: ipType2 !! interpolation point type in y direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: layout !! VEFC, INCREASING REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) @@ -556,6 +528,45 @@ MODULE FUNCTION InterpolationPoint_Quadrangle2( & END FUNCTION InterpolationPoint_Quadrangle2 END INTERFACE InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle_ +!---------------------------------------------------------------------------- + +INTERFACE InterpolationPoint_Quadrangle_ + MODULE SUBROUTINE InterpolationPoint_Quadrangle2_(p, q, ipType1, ipType2, & + ans, nrow, ncol, layout, xij, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2) + INTEGER(I4B), INTENT(IN) :: p + !! order of element in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of element in y direction + INTEGER(I4B), INTENT(IN) :: ipType1 + !! interpolation point type in x direction + INTEGER(I4B), INTENT(IN) :: ipType2 + !! interpolation point type in y direction + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! + CHARACTER(*), INTENT(IN) :: layout + !! VEFC, INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Quadrangle2_ +END INTERFACE InterpolationPoint_Quadrangle_ + !---------------------------------------------------------------------------- ! IJ2VEFC !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 31abd7661..e5930bae1 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -32,23 +32,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FacetConnectivity_Quadrangle -CHARACTER(:), ALLOCATABLE :: baseInterpol0 -! TYPE(String) :: baseContinuity0 - -baseInterpol0 = UpperCase(baseInterpol) -! baseContinuity0 = UpperCase(baseContinuity) - -SELECT CASE (baseInterpol0) -CASE ( & - & "HIERARCHYPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHYPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION", & - & "ORTHOGONALPOLYNOMIAL", & - & "ORTHOGONAL", & - & "ORTHOGONALINTERPOLATION") +CHARACTER(3) :: bi + +bi = UpperCase(baseInterpol(1:3)) + +SELECT CASE (bi) +CASE ("HIE", "HEI", "ORT") ans(:, 1) = [1, 2] ans(:, 2) = [4, 3] ans(:, 3) = [1, 4] @@ -717,90 +706,95 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Quadrangle1 -ans = InterpolationPoint_Quadrangle2( & - & p=order, & - & q=order, & - & ipType1=ipType, & - & ipType2=ipType, & - & xij=xij, & - & layout=layout, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda & - & ) +ans = InterpolationPoint_Quadrangle2(p=order, q=order, ipType1=ipType, & + ipType2=ipType, xij=xij, layout=layout, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda) END PROCEDURE InterpolationPoint_Quadrangle1 +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle1_ +CALL InterpolationPoint_Quadrangle2_(p=order, q=order, ipType1=ipType, & + ipType2=ipType, xij=xij, layout=layout, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE InterpolationPoint_Quadrangle1_ + !---------------------------------------------------------------------------- ! InterpolationPoint_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Quadrangle2 -! internal variables -REAL(DFP) :: x(p + 1), y(q + 1), & - & xi(p + 1, q + 1), eta(p + 1, q + 1) -REAL(DFP), ALLOCATABLE :: temp(:, :) -INTEGER(I4B) :: ii, jj, kk, nsd +INTEGER(I4B) :: nrow, ncol -x = InterpolationPoint_Line( & - & order=p, & - & ipType=ipType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) +nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) +ncol = (p + 1) * (q + 1) +ALLOCATE (ans(nrow, ncol)) -y = InterpolationPoint_Line( & - & order=q, & - & ipType=ipType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle2_ +REAL(DFP), PARAMETER :: biunit_xij(2) = [-1.0_DFP, 1.0_DFP] + +REAL(DFP) :: x(p + 1), y(q + 1), xi(p + 1, q + 1), eta(p + 1, q + 1) +INTEGER(I4B) :: ii, jj, kk, tsize IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) + nrow = SIZE(xij, 1) ELSE - nsd = 2 + nrow = 2 END IF -CALL Reallocate(ans, nsd, (p + 1) * (q + 1)) -CALL Reallocate(temp, 2, (p + 1) * (q + 1)) +ncol = (p + 1) * (q + 1) + +CALL InterpolationPoint_Line_(order=p, ipType=ipType1, xij=biunit_xij, & + layout="INCREASING", alpha=alpha1, beta=beta1, lambda=lambda1, & + ans=x, tsize=tsize) -xi = 0.0_DFP -eta = 0.0_DFP +CALL InterpolationPoint_Line_(order=q, ipType=ipType2, xij=biunit_xij, & + layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, & + ans=y, tsize=tsize) +! CALL Reallocate(ans, nsd, (p + 1) * (q + 1)) +! CALL Reallocate(temp, 2, (p + 1) * (q + 1)) +! xi = 0.0_DFP +! eta = 0.0_DFP + +kk = 0 DO ii = 1, p + 1 DO jj = 1, q + 1 + kk = kk + 1 xi(ii, jj) = x(ii) + ans(1, kk) = x(ii) + eta(ii, jj) = y(jj) + ans(2, kk) = y(jj) END DO END DO -IF (layout .EQ. "VEFC") THEN - CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=temp, p=p, q=q) -ELSE - kk = 0 - DO ii = 1, p + 1 - DO jj = 1, q + 1 - kk = kk + 1 - temp(1, kk) = xi(ii, jj) - temp(2, kk) = eta(ii, jj) - END DO - END DO +IF (layout(1:4) .EQ. "VEFC") THEN + CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=ans(1:2, 1:ncol), p=p, q=q) END IF IF (PRESENT(xij)) THEN - ans = FromBiUnitQuadrangle2Quadrangle(xin=temp, x1=xij(:, 1), & - & x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4)) -ELSE - ans = temp + CALL FromBiUnitQuadrangle2Quadrangle_(xin=ans(1:2, 1:ncol), & + x1=xij(:, 1), x2=xij(:, 2), & + x3=xij(:, 3), x4=xij(:, 4), & + ans=ans, nrow=ii, ncol=jj) END IF -END PROCEDURE InterpolationPoint_Quadrangle2 + +END PROCEDURE InterpolationPoint_Quadrangle2_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle From a679e4935bbef296873460b60212dbd2683a9039 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 10:09:57 +0900 Subject: [PATCH 073/359] Updates in MappingUtility --- src/modules/Utility/src/MappingUtility.F90 | 42 ++++++++++++++++--- .../Utility/src/MappingUtility@Methods.F90 | 42 +++++++++++++------ 2 files changed, 66 insertions(+), 18 deletions(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 4fdfb737c..0cc3cfebf 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -33,6 +33,8 @@ MODULE MappingUtility PUBLIC :: FromLine2Line_ PUBLIC :: FromBiUnitQuadrangle2Quadrangle +PUBLIC :: FromBiUnitQuadrangle2Quadrangle_ + PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle PUBLIC :: FromUnitQuadrangle2BiUnitQuadrangle @@ -232,7 +234,7 @@ END SUBROUTINE FromUnitTriangle2Triangle1_ END INTERFACE FromUnitTriangle2Triangle_ !---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2Quadrangle +! FromBiUnitQuadrangle2UnitQuadrangle !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -241,7 +243,7 @@ END SUBROUTINE FromUnitTriangle2Triangle1_ INTERFACE FromBiUnitQuadrangle2UnitQuadrangle MODULE PURE FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1(xin) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: xin(:, :) !! vertex coordinate of biunit Quadrangle in xij format !! SIZE(xin,1) = 2 @@ -252,7 +254,7 @@ END FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1 END INTERFACE FromBiUnitQuadrangle2UnitQuadrangle !---------------------------------------------------------------------------- -! FromBiUnitQuadrangle2Quadrangle +! FromUnitQuadrangle2BiUnitQuadrangle !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -261,7 +263,7 @@ END FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1 INTERFACE FromUnitQuadrangle2BiUnitQuadrangle MODULE PURE FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1(xin) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: xin(:, :) !! vertex coordinate of biunit Quadrangle in xij format !! SIZE(xin,1) = 2 @@ -281,7 +283,7 @@ END FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1 INTERFACE FromBiUnitQuadrangle2Quadrangle MODULE PURE FUNCTION FromBiUnitQuadrangle2Quadrangle1(xin, x1, x2, x3, x4) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: xin(:, :) !! vertex coordinate of biunit Quadrangle in xij format !! SIZE(xin,1) = 2 @@ -299,6 +301,36 @@ MODULE PURE FUNCTION FromBiUnitQuadrangle2Quadrangle1(xin, x1, x2, x3, x4) & END FUNCTION FromBiUnitQuadrangle2Quadrangle1 END INTERFACE FromBiUnitQuadrangle2Quadrangle +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2Quadrangle_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE FromBiUnitQuadrangle2Quadrangle_ + MODULE PURE SUBROUTINE FromBiUnitQuadrangle2Quadrangle1_(xin, x1, x2, x3, & + x4, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Quadrangle in xij format + !! SIZE(xin,1) = 2 + REAL(DFP), INTENT(IN) :: x1(:) + !! vertex x1 of physical domain, size(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! vertex x2 of physical domain, size(x2) = nsd + REAL(DFP), INTENT(IN) :: x3(:) + !! vertex x3 of physical domain, size(x3) = nsd + REAL(DFP), INTENT(IN) :: x4(:) + !! vertex x4 of physical domain, size(x4) = nsd + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(x1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE FromBiUnitQuadrangle2Quadrangle1_ +END INTERFACE FromBiUnitQuadrangle2Quadrangle_ + !---------------------------------------------------------------------------- ! FromBiUnitHexahedron2Hexahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index e63d36f08..f740686bd 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -16,16 +16,18 @@ SUBMODULE(MappingUtility) Methods USE BaseMethod, ONLY: UpperCase, & - & SOFTLE, & - & RefCoord_Tetrahedron, & - & RefCoord_Hexahedron, & - & TriangleArea2D, & - & TriangleArea3D, & - & QuadrangleArea2D, & - & QuadrangleArea3D, & - & TetrahedronVolume3D, & - & HexahedronVolume3D + SOFTLE, & + RefCoord_Tetrahedron, & + RefCoord_Hexahedron, & + TriangleArea2D, & + TriangleArea3D, & + QuadrangleArea2D, & + QuadrangleArea3D, & + TetrahedronVolume3D, & + HexahedronVolume3D + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -187,19 +189,33 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitQuadrangle2Quadrangle1 +INTEGER(I4B) :: nrow, ncol +CALL FromBiUnitQuadrangle2Quadrangle1_(xin=xin, ans=ans, x1=x1, x2=x2, & + x3=x3, x4=x4, nrow=nrow, ncol=ncol) +END PROCEDURE FromBiUnitQuadrangle2Quadrangle1 + +!---------------------------------------------------------------------------- +! FromBiUnitQuadrangle2Quadrangle_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitQuadrangle2Quadrangle1_ INTEGER(I4B) :: ii REAL(DFP) :: xi, eta, p1, p2, p3, p4 -!! -DO ii = 1, SIZE(ans, 2) + +! ans(SIZE(x1), SIZE(xin, 2)) +nrow = SIZE(x1) +ncol = SIZE(xin, 2) + +DO ii = 1, ncol xi = xin(1, ii) eta = xin(2, ii) p1 = 0.25 * (1.0 - xi) * (1.0 - eta) p2 = 0.25 * (1.0 + xi) * (1.0 - eta) p3 = 0.25 * (1.0 + xi) * (1.0 + eta) p4 = 0.25 * (1.0 - xi) * (1.0 + eta) - ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 + ans(1:nrow, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 END DO -END PROCEDURE FromBiUnitQuadrangle2Quadrangle1 +END PROCEDURE FromBiUnitQuadrangle2Quadrangle1_ !---------------------------------------------------------------------------- ! FromBiUnitHexahedron2Hexahedron From 751cce3b704e7fbcbeca7345c3bc44b35ca3e29a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 11:32:01 +0900 Subject: [PATCH 074/359] Updates in TetrahedronInterpolationUtility --- .../src/TetrahedronInterpolationUtility.F90 | 71 ++-- ...etrahedronInterpolationUtility@Methods.F90 | 316 ++++++++++-------- 2 files changed, 218 insertions(+), 169 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index 1fba7da35..f34b1f69e 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -27,9 +27,10 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: EquidistanceInPoint_Tetrahedron PUBLIC :: EquidistancePoint_Tetrahedron PUBLIC :: LagrangeCoeff_Tetrahedron -PUBLIC :: Isaac_Tetrahedron -PUBLIC :: BlythPozrikidis_Tetrahedron +! PUBLIC :: Isaac_Tetrahedron +! PUBLIC :: BlythPozrikidis_Tetrahedron PUBLIC :: InterpolationPoint_Tetrahedron +PUBLIC :: InterpolationPoint_Tetrahedron_ PUBLIC :: OrthogonalBasis_Tetrahedron PUBLIC :: BarycentricVertexBasis_Tetrahedron PUBLIC :: BarycentricEdgeBasis_Tetrahedron @@ -443,14 +444,8 @@ END FUNCTION EquidistancePoint_Tetrahedron_old ! summary: Interpolation point INTERFACE - MODULE FUNCTION InterpolationPoint_Tetrahedron( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION InterpolationPoint_Tetrahedron(order, ipType, layout, & + xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of element INTEGER(I4B), INTENT(IN) :: ipType @@ -477,6 +472,38 @@ MODULE FUNCTION InterpolationPoint_Tetrahedron( & END FUNCTION InterpolationPoint_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! InterpolationPoint_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point + +INTERFACE + MODULE SUBROUTINE InterpolationPoint_Tetrahedron_(order, ipType, ans, & + nrow, ncol, layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation type + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC", "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(3, 4) + !! coordinates of vertices in $x_{iJ}$ format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + END SUBROUTINE InterpolationPoint_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- @@ -580,9 +607,8 @@ END FUNCTION LagrangeCoeff_Tetrahedron4 ! https://tisaac.gitlab.io/recursivenodes/ INTERFACE - MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, & - & alpha, beta, lambda) & - & RESULT(ans) + MODULE SUBROUTINE Isaac_Tetrahedron(order, ipType, ans, nrow, ncol, & + layout, xij, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType @@ -593,6 +619,10 @@ MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, & !! GaussChebyshevLobatto !! GaussJacobi !! GaussJacobiLobatto + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! xij coordinates + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! nodal coordinates of Tetrahedron CHARACTER(*), INTENT(IN) :: layout @@ -604,9 +634,7 @@ MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, & !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical polynomial parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! xij coordinates - END FUNCTION Isaac_Tetrahedron + END SUBROUTINE Isaac_Tetrahedron END INTERFACE !---------------------------------------------------------------------------- @@ -658,17 +686,12 @@ END FUNCTION BlythPozrikidis_Tetrahedron !---------------------------------------------------------------------------- INTERFACE - MODULE RECURSIVE SUBROUTINE IJK2VEFC_Tetrahedron( & - & xi, & - & eta, & - & zeta, & - & temp, & - & order, & - & N) + MODULE RECURSIVE SUBROUTINE IJK2VEFC_Tetrahedron(xi, eta, zeta, temp, & + order, N) REAL(DFP), INTENT(IN) :: xi(:, :, :) REAL(DFP), INTENT(IN) :: eta(:, :, :) REAL(DFP), INTENT(IN) :: zeta(:, :, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) + REAL(DFP), INTENT(INOUT) :: temp(:, :) INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), INTENT(IN) :: N END SUBROUTINE IJK2VEFC_Tetrahedron diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index 0c0fcc3b2..360914196 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -16,12 +16,14 @@ SUBMODULE(TetrahedronInterpolationUtility) Methods USE BaseMethod -USE QuadraturePoint_Tetrahedron_Solin, ONLY: & -& QuadratureNumberTetrahedronSolin, & -& QuadratureOrderTetrahedronSolin, & -& QuadraturePointTetrahedronSolin, & -& MAX_ORDER_TETRAHEDRON_SOLIN +USE QuadraturePoint_Tetrahedron_Solin, ONLY: & + QuadratureNumberTetrahedronSolin, & + QuadratureOrderTetrahedronSolin, & + QuadraturePointTetrahedronSolin, & + MAX_ORDER_TETRAHEDRON_SOLIN + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -461,14 +463,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Tetrahedron -ans = Isaac_Tetrahedron( & - & order=order, & - & ipType=ipType, & - & layout=layout, & - & xij=xij, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +INTEGER(I4B) :: nrow, ncol + +ncol = SIZE(n=order, d=3) +ALLOCATE (ans(3, ncol)) +CALL Isaac_Tetrahedron(order=order, ipType=ipType, layout=layout, xij=xij, & + alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE InterpolationPoint_Tetrahedron !---------------------------------------------------------------------------- @@ -557,24 +557,20 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Isaac_Tetrahedron +! CHARACTER(*), PARAMETER :: myName = "Isaac_Tetrahedron" + REAL(DFP), DIMENSION(order + 1, order + 1, order + 1) :: xi, eta, zeta -REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) -INTEGER(I4B) :: nsd, N, cnt, ii, jj, kk -CHARACTER(*), PARAMETER :: myName = "Isaac_Tetrahedron" -rPoints = RecursiveNode3D( & - & order=order, & - & ipType=ipType, & - & domain="UNIT", & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +INTEGER(I4B) :: cnt, ii, jj, kk -N = SIZE(rPoints, 2) +ncol = SIZE(n=order, d=3) +nrow = 3 -nsd = 3 -CALL Reallocate(ans, nsd, N) -CALL Reallocate(temp, nsd, N) +CALL RecursiveNode3D_(order=order, ipType=ipType, domain="UNIT", & + alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) + +! CALL Reallocate(ans, nsd, N) +! CALL Reallocate(temp, nrow, ncol) !! convert from rPoints to xi and eta cnt = 0 @@ -587,39 +583,26 @@ DO kk = 0, order IF (ii + jj + kk .LE. order) THEN cnt = cnt + 1 - xi(ii + 1, jj + 1, kk + 1) = rPoints(1, cnt) - eta(ii + 1, jj + 1, kk + 1) = rPoints(2, cnt) - zeta(ii + 1, jj + 1, kk + 1) = rPoints(3, cnt) + xi(ii + 1, jj + 1, kk + 1) = ans(1, cnt) + eta(ii + 1, jj + 1, kk + 1) = ans(2, cnt) + zeta(ii + 1, jj + 1, kk + 1) = ans(3, cnt) END IF END DO END DO END DO IF (layout .EQ. "VEFC") THEN - CALL IJK2VEFC_Tetrahedron( & - & xi=xi, & - & eta=eta, & - & zeta=zeta, & - & temp=temp, & - & order=order, & - & N=N) -ELSE - temp = rPoints + CALL IJK2VEFC_Tetrahedron(xi=xi, eta=eta, zeta=zeta, temp=ans, & + order=order, N=ncol) END IF IF (PRESENT(xij)) THEN - ans = FromUnitTetrahedron2Tetrahedron( & - & xin=temp, & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4)) -ELSE - ans = temp + ! convert temp to ans using xij + CALL FromUnitTetrahedron2Tetrahedron_(xin=ans(1:nrow, 1:ncol), & + x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, & + nrow=nrow, ncol=ncol) END IF -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints) END PROCEDURE Isaac_Tetrahedron !---------------------------------------------------------------------------- @@ -642,21 +625,33 @@ MODULE PROCEDURE IJK2VEFC_Tetrahedron INTEGER(I4B) :: indof, ii, cnt, jj, kk, ll +REAL(DFP) :: x(3) +INTEGER(I4B), PARAMETER :: nrow = 3 + REAL(DFP), DIMENSION(3, (order + 1)*(order + 2)/2) :: temp_face_in REAL(DFP), DIMENSION(order + 1, order + 1) :: xi2, eta2, zeta2 SELECT CASE (order) CASE (0) - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(1:nrow, 1) = x CASE (1) ! | 0 | 0 | 0 | ! | 0 | 0 | 1 | ! | 0 | 1 | 0 | ! | 1 | 0 | 0 | - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] + x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(1:nrow, 1) = x + + x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)] + temp(1:nrow, 2) = x + + x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)] + temp(1:nrow, 3) = x + + x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)] + temp(1:nrow, 4) = x + CASE (2) ! | 0 | 0 | 0 | ! | 0 | 0 | 0.5 | @@ -670,23 +665,41 @@ ! | 1 | 0 | 0 | ! four vertex - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] + x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(1:nrow, 1) = x + + x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)] + temp(1:nrow, 2) = x + + x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)] + temp(1:nrow, 3) = x + + x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)] + temp(1:nrow, 4) = x ! edge1 x - temp(:, 5) = [xi(2, 1, 1), eta(2, 1, 1), zeta(2, 1, 1)] + x = [xi(2, 1, 1), eta(2, 1, 1), zeta(2, 1, 1)] + temp(1:nrow, 5) = x + ! edge2 y - temp(:, 6) = [xi(1, 2, 1), eta(1, 2, 1), zeta(1, 2, 1)] + x = [xi(1, 2, 1), eta(1, 2, 1), zeta(1, 2, 1)] + temp(1:nrow, 6) = x + ! edge3 z - temp(:, 7) = [xi(1, 1, 2), eta(1, 1, 2), zeta(1, 1, 2)] + x = [xi(1, 1, 2), eta(1, 1, 2), zeta(1, 1, 2)] + temp(1:nrow, 7) = x + ! edge4 xy - temp(:, 8) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] + x = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] + temp(1:nrow, 8) = x + ! edge5, xz - temp(:, 9) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] + x = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] + temp(1:nrow, 9) = x + ! edge6, yz - temp(:, 10) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] + x = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] + temp(1:nrow, 10) = x CASE (3) ! | 0 | 0 | 0 | @@ -711,149 +724,179 @@ ! | 1 | 0 | 0 | ! four vertex - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] + x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(1:nrow, 1) = x + + x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)] + temp(1:nrow, 2) = x + + x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)] + temp(1:nrow, 3) = x + + x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)] + temp(1:nrow, 4) = x cnt = 4 ! edge1 x DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] + x = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] + temp(1:nrow, cnt) = x END DO + ! edge2 y DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] + x = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] + temp(1:nrow, cnt) = x END DO + ! edge3 z DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] + x = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] + temp(1:nrow, cnt) = x END DO + ! edge4 xy DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(4-ii, 1+ii, 1), eta(4-ii, 1+ii, 1), zeta(4-ii, 1+ii, 1)] + x = [xi(4 - ii, 1 + ii, 1), eta(4 - ii, 1 + ii, 1), & + zeta(4 - ii, 1 + ii, 1)] + temp(1:nrow, cnt) = x END DO + ! edge5, xz DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(4-ii, 1, ii+1), eta(4-ii, 1, ii+1), zeta(4-ii, 1, ii+1)] + x = [xi(4 - ii, 1, ii + 1), eta(4 - ii, 1, ii + 1), & + zeta(4 - ii, 1, ii + 1)] + temp(1:nrow, cnt) = x END DO ! edge6, yz DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(1, 4-ii, ii+1), eta(1, 4-ii, ii+1), zeta(1, 4-ii, ii+1)] + x = [xi(1, 4 - ii, ii + 1), eta(1, 4 - ii, ii + 1), & + zeta(1, 4 - ii, ii + 1)] + temp(1:nrow, cnt) = x + END DO ! facet xy cnt = cnt + 1 - temp(:, cnt) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] + x = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)] + temp(1:nrow, cnt) = x ! facet xz cnt = cnt + 1 - temp(:, cnt) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] + x = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)] + temp(1:nrow, cnt) = x ! facet yz cnt = cnt + 1 - temp(:, cnt) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] + x = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)] + temp(1:nrow, cnt) = x ! facet 4 cnt = cnt + 1 - temp(:, cnt) = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)] + x = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)] + temp(1:nrow, cnt) = x CASE DEFAULT ! four vertex - temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] - temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)] - temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)] - temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)] + x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)] + temp(1:nrow, 1) = x + + x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)] + temp(1:nrow, 2) = x + + x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)] + temp(1:nrow, 3) = x + + x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)] + temp(1:nrow, 4) = x cnt = 4 ! edge1 x DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] + x = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)] + temp(1:nrow, cnt) = x + END DO ! edge2 y DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] + x = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)] + temp(1:nrow, cnt) = x + END DO ! edge3 z DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] + x = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)] + temp(1:nrow, cnt) = x + END DO ! edge4 xy jj = order + 1 DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [ & - & xi(jj - ii, 1 + ii, 1), & - & eta(jj - ii, 1 + ii, 1), & - & zeta(jj - ii, 1 + ii, 1)] + x = [xi(jj - ii, 1 + ii, 1), eta(jj - ii, 1 + ii, 1), & + zeta(jj - ii, 1 + ii, 1)] + temp(1:nrow, cnt) = x END DO + ! edge5, xz DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [ & - & xi(jj - ii, 1, ii + 1), & - & eta(jj - ii, 1, ii + 1), & - & zeta(jj - ii, 1, ii + 1)] + x = [xi(jj - ii, 1, ii + 1), eta(jj - ii, 1, ii + 1), & + zeta(jj - ii, 1, ii + 1)] + temp(1:nrow, cnt) = x END DO + ! edge6, yz DO ii = 1, order - 1 cnt = cnt + 1 - temp(:, cnt) = [ & - & xi(1, jj - ii, ii + 1), & - & eta(1, jj - ii, ii + 1), & - & zeta(1, jj - ii, ii + 1)] + x = [xi(1, jj - ii, ii + 1), eta(1, jj - ii, ii + 1), & + zeta(1, jj - ii, ii + 1)] + temp(1:nrow, cnt) = x END DO ! facet xy jj = LagrangeDOF_Triangle(order) - CALL IJ2VEFC_Triangle( & - & xi=xi(:, :, 1), & - & eta=eta(:, :, 1), & - & temp=temp_face_in, & - & order=order, & - & N=jj) + CALL IJ2VEFC_Triangle(xi=xi(:, :, 1), eta=eta(:, :, 1), & + temp=temp_face_in, order=order, N=jj) + kk = LagrangeInDOF_Triangle(order) DO ii = jj - kk + 1, jj cnt = cnt + 1 - temp(:, cnt) = [temp_face_in(1, ii), temp_face_in(2, ii), zeta(1, 1, 1)] + x = [temp_face_in(1, ii), temp_face_in(2, ii), zeta(1, 1, 1)] + temp(1:nrow, cnt) = x END DO ! facet xz ! jj = LagrangeDOF_Triangle(order) - CALL IJ2VEFC_Triangle( & - & xi=xi(:, 1, :), & - & eta=zeta(:, 1, :), & - & temp=temp_face_in, & - & order=order, & - & N=jj) + CALL IJ2VEFC_Triangle(xi=xi(:, 1, :), eta=zeta(:, 1, :), & + temp=temp_face_in, order=order, N=jj) + ! kk = LagrangeInDOF_Triangle(order) DO ii = jj - kk + 1, jj cnt = cnt + 1 - temp(:, cnt) = [temp_face_in(1, ii), eta(1, 1, 1), temp_face_in(2, ii)] + x = [temp_face_in(1, ii), eta(1, 1, 1), temp_face_in(2, ii)] + temp(1:nrow, cnt) = x END DO ! facet yz ! jj = LagrangeDOF_Triangle(order) - CALL IJ2VEFC_Triangle( & - & xi=eta(1, :, :), & - & eta=zeta(1, :, :), & - & temp=temp_face_in, & - & order=order, & - & N=jj) + CALL IJ2VEFC_Triangle(xi=eta(1, :, :), eta=zeta(1, :, :), & + temp=temp_face_in, order=order, N=jj) ! kk = LagrangeInDOF_Triangle(order) DO ii = jj - kk + 1, jj cnt = cnt + 1 - temp(:, cnt) = [xi(1, 1, 1), temp_face_in(1, ii), temp_face_in(2, ii)] + x = [xi(1, 1, 1), temp_face_in(1, ii), temp_face_in(2, ii)] + temp(1:nrow, cnt) = x END DO ! ! facet 4 @@ -877,23 +920,13 @@ END DO temp_face_in = 0.0_DFP - CALL IJK2VEFC_Triangle( & - & xi=xi2, & - & eta=eta2, & - & zeta=zeta2, & - & temp=temp_face_in, & - & order=order, & - & N=SIZE(temp_face_in, 2)) + CALL IJK2VEFC_Triangle(xi=xi2, eta=eta2, zeta=zeta2, temp=temp_face_in, & + order=order, N=SIZE(temp_face_in, 2)) ! facet 4 jj = LagrangeDOF_Triangle(order) - CALL IJK2VEFC_Triangle( & - & xi=xi2, & - & eta=eta2, & - & zeta=zeta2, & - & temp=temp_face_in, & - & order=order, & - & N=jj) + CALL IJK2VEFC_Triangle(xi=xi2, eta=eta2, zeta=zeta2, temp=temp_face_in, & + order=order, N=jj) kk = LagrangeInDOF_Triangle(order) DO ii = jj - kk + 1, jj cnt = cnt + 1 @@ -902,12 +935,10 @@ jj = LagrangeDOF_Tetrahedron(order) kk = LagrangeInDOF_Tetrahedron(order=order) - CALL IJK2VEFC_Tetrahedron( & - & xi(2:order - 2, 2:order - 2, 2:order - 2), & - & eta(2:order - 2, 2:order - 2, 2:order - 2), & - & zeta(2:order - 2, 2:order - 2, 2:order - 2), & - & temp(:, cnt + 1:), & - & order - 4, kk) + CALL IJK2VEFC_Tetrahedron(xi(2:order - 2, 2:order - 2, 2:order - 2), & + eta(2:order - 2, 2:order - 2, 2:order - 2), & + zeta(2:order - 2, 2:order - 2, 2:order - 2), temp(:, cnt + 1:), & + order - 4, kk) END SELECT END PROCEDURE IJK2VEFC_Tetrahedron @@ -916,13 +947,7 @@ ! IJ2VEFC_Triangle !---------------------------------------------------------------------------- -SUBROUTINE IJK2VEFC_Triangle( & - & xi, & - & eta, & - & zeta, & - & temp, & - & order, & - & N) +SUBROUTINE IJK2VEFC_Triangle(xi, eta, zeta, temp, order, N) REAL(DFP), INTENT(IN) :: xi(:, :) REAL(DFP), INTENT(IN) :: eta(:, :) REAL(DFP), INTENT(IN) :: zeta(:, :) @@ -1002,6 +1027,7 @@ SUBROUTINE IJK2VEFC_Triangle( & & unitno=stderr) RETURN END IF + END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- From 4bb88b853c9c6ba6799203db7a10c0aacda1ac8a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 11:32:13 +0900 Subject: [PATCH 075/359] updates in MappingUtility --- src/modules/Utility/src/MappingUtility.F90 | 35 +++++++++++++++---- .../Utility/src/MappingUtility@Methods.F90 | 28 +++++++++++---- 2 files changed, 50 insertions(+), 13 deletions(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 0cc3cfebf..25bba0e8f 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -76,6 +76,7 @@ MODULE MappingUtility PUBLIC :: FromUnitTetrahedron2BiUnitTetrahedron PUBLIC :: FromBiUnitTetrahedron2UnitTetrahedron PUBLIC :: FromUnitTetrahedron2Tetrahedron +PUBLIC :: FromUnitTetrahedron2Tetrahedron_ PUBLIC :: FromBiUnitTetrahedron2Tetrahedron PUBLIC :: BarycentricCoordUnitTetrahedron PUBLIC :: BarycentricCoordBiUnitTetrahedron @@ -785,12 +786,8 @@ END FUNCTION FromBiUnitTetrahedron2Tetrahedron ! summary: Unit Tetrahedron to tetrahedron INTERFACE - MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron( & - & xin, & - & x1, & - & x2, & - & x3, & - & x4) RESULT(ans) + MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron(xin, x1, x2, x3, x4) & + RESULT(ans) REAL(DFP), INTENT(IN) :: xin(:, :) REAL(DFP), INTENT(IN) :: x1(3) !! Coordinate of tetrahedron node 1 @@ -804,6 +801,32 @@ MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron( & END FUNCTION FromUnitTetrahedron2Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2Tetrahedron_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-28 +! summary: No allocation + +INTERFACE +MODULE PURE SUBROUTINE FromUnitTetrahedron2Tetrahedron_(xin, x1, x2, x3, x4, & + ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(IN) :: x1(3) + !! Coordinate of tetrahedron node 1 + REAL(DFP), INTENT(IN) :: x2(3) + !! Coordinate of tetrahedron node 2 + REAL(DFP), INTENT(IN) :: x3(3) + !! Coordinate of tetrahedron node 3 + REAL(DFP), INTENT(IN) :: x4(3) + !! Coordinate of tetrahedron node 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(3, SIZE(xin, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE FromUnitTetrahedron2Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricCoordUnitTetrahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index f740686bd..1a0ac6a36 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -496,15 +496,29 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromUnitTetrahedron2Tetrahedron +INTEGER(I4B) :: nrow, ncol +CALL FromUnitTetrahedron2Tetrahedron_(xin=xin, ans=ans, x1=x1, x2=x2, & + x3=x3, x4=x4, nrow=nrow, ncol=ncol) +END PROCEDURE FromUnitTetrahedron2Tetrahedron + +!---------------------------------------------------------------------------- +! FromUnitTetrahedron2Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTetrahedron2Tetrahedron_ INTEGER(I4B) :: ii -DO ii = 1, SIZE(xin, 2) - ans(:, ii) = & - (1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii)) * x1(:) & - + xin(1, ii) * x2(:) & - + xin(2, ii) * x3(:) & - + xin(3, ii) * x4(:) + +nrow = 3 +ncol = SIZE(xin, 2) + +DO ii = 1, ncol + ans(1:3, ii) = & + (1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii)) * x1(1:3) & + + xin(1, ii) * x2(1:3) & + + xin(2, ii) * x3(1:3) & + + xin(3, ii) * x4(1:3) END DO -END PROCEDURE FromUnitTetrahedron2Tetrahedron +END PROCEDURE FromUnitTetrahedron2Tetrahedron_ !---------------------------------------------------------------------------- ! BarycentricCoordUnitTetrahedron From ea2f02f2d90643fc6806db144498ed2b53a2e691 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 11:34:18 +0900 Subject: [PATCH 076/359] Updates in TetrahedronInterpolationUtility --- .../src/TetrahedronInterpolationUtility@Methods.F90 | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index 360914196..7c0725313 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -464,12 +464,21 @@ MODULE PROCEDURE InterpolationPoint_Tetrahedron INTEGER(I4B) :: nrow, ncol - ncol = SIZE(n=order, d=3) ALLOCATE (ans(3, ncol)) +CALL InterpolationPoint_Tetrahedron_(order=order, ipType=ipType, & + layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE InterpolationPoint_Tetrahedron + +!---------------------------------------------------------------------------- +! InterpolationPoint_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Tetrahedron_ CALL Isaac_Tetrahedron(order=order, ipType=ipType, layout=layout, xij=xij, & alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE InterpolationPoint_Tetrahedron +END PROCEDURE InterpolationPoint_Tetrahedron_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron From 6458a03d2953295ca74c60dfd02b93fbc5882605 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 11:37:36 +0900 Subject: [PATCH 077/359] Updates in HexahedronInterpolationUtility --- .../src/HexahedronInterpolationUtility.F90 | 169 +++++++++++------- ...HexahedronInterpolationUtility@Methods.F90 | 28 +++ 2 files changed, 136 insertions(+), 61 deletions(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index fef9276e3..ac4086a52 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -26,6 +26,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: EquidistancePoint_Hexahedron PUBLIC :: EquidistanceInPoint_Hexahedron PUBLIC :: InterpolationPoint_Hexahedron +PUBLIC :: InterpolationPoint_Hexahedron_ PUBLIC :: LagrangeCoeff_Hexahedron PUBLIC :: EdgeConnectivity_Hexahedron PUBLIC :: FacetConnectivity_Hexahedron @@ -607,7 +608,7 @@ END FUNCTION EquidistancePoint_Hexahedron2 INTERFACE InterpolationPoint_Hexahedron MODULE FUNCTION InterpolationPoint_Hexahedron1(order, ipType, & - & layout, xij, alpha, beta, lambda) RESULT(ans) + layout, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in x, y and z direction INTEGER(I4B), INTENT(IN) :: ipType @@ -636,23 +637,49 @@ END FUNCTION InterpolationPoint_Hexahedron1 !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-07-10 -! summary: Interpolation points +! date: 2024-06-26 +! summary: Interpolation points without allocation + +INTERFACE InterpolationPoint_Hexahedron_ + MODULE SUBROUTINE InterpolationPoint_Hexahedron1_(order, ipType, ans, & + nrow, ncol, layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order in x, y and z direction + INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation type in x, y, and z direction + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in xij format + !! rows of ans denotes x, y, z components + !! cols of ans denotes x, y, z components + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and cols + CHARACTER(*), INTENT(IN) :: layout + !! layout can be VEFC or INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordiantes of reference hexahedron + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Hexahedron1_ +END INTERFACE InterpolationPoint_Hexahedron_ + +!---------------------------------------------------------------------------- +! InterpolationPoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-26 +! summary: Interpolation points hexahedron INTERFACE InterpolationPoint_Hexahedron - MODULE FUNCTION InterpolationPoint_Hexahedron2( & - & p, & - & q, & - & r, & - & ipType1, & - & ipType2, & - & ipType3, & - & layout, & - & xij, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3 & - & ) RESULT(ans) + MODULE FUNCTION InterpolationPoint_Hexahedron2(p, q, r, ipType1, & + ipType2, ipType3, layout, xij, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order in x direction INTEGER(I4B), INTENT(IN) :: q @@ -694,6 +721,61 @@ MODULE FUNCTION InterpolationPoint_Hexahedron2( & END FUNCTION InterpolationPoint_Hexahedron2 END INTERFACE InterpolationPoint_Hexahedron +!---------------------------------------------------------------------------- +! InterpolationPoint_Hexahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-10 +! summary: Interpolation points + +INTERFACE InterpolationPoint_Hexahedron_ + MODULE SUBROUTINE InterpolationPoint_Hexahedron2_(p, q, r, ipType1, & + ipType2, ipType3, ans, nrow, ncol, layout, xij, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, alpha3, beta3, lambda3) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order in z direction + INTEGER(I4B), INTENT(IN) :: ipType1 + !! interpolation type in x direction + INTEGER(I4B), INTENT(IN) :: ipType2 + !! interpolation type in y direction + INTEGER(I4B), INTENT(IN) :: ipType3 + !! interpolation type in z direction + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolation points in xij format + !! rows of ans denotes x, y, z components + !! cols of ans denotes x, y, z components + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and cols written in ans + CHARACTER(*), INTENT(IN) :: layout + !! layout can be VEFC or INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinate of reference Hexahedron + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Hexahedron2_ +END INTERFACE InterpolationPoint_Hexahedron_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -703,12 +785,8 @@ END FUNCTION InterpolationPoint_Hexahedron2 ! summary: Convert IJK to VEFC format INTERFACE - MODULE RECURSIVE PURE SUBROUTINE IJK2VEFC_Hexahedron( & - & xi, & - & eta, & - & zeta, & - & temp, & - & p, q, r) + MODULE RECURSIVE PURE SUBROUTINE IJK2VEFC_Hexahedron(xi, eta, zeta, & + temp, p, q, r) REAL(DFP), INTENT(IN) :: xi(:, :, :) REAL(DFP), INTENT(IN) :: eta(:, :, :) REAL(DFP), INTENT(IN) :: zeta(:, :, :) @@ -752,7 +830,7 @@ END FUNCTION LagrangeCoeff_Hexahedron1 INTERFACE LagrangeCoeff_Hexahedron MODULE FUNCTION LagrangeCoeff_Hexahedron2(order, i, v, isVandermonde) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial, it should be SIZE(v,2)-1 INTEGER(I4B), INTENT(IN) :: i @@ -799,7 +877,7 @@ END FUNCTION LagrangeCoeff_Hexahedron3 INTERFACE LagrangeCoeff_Hexahedron MODULE FUNCTION LagrangeCoeff_Hexahedron4(order, xij, basisType, & - & refHexahedron, alpha, beta, lambda) RESULT(ans) + refHexahedron, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial REAL(DFP), INTENT(IN) :: xij(:, :) @@ -834,25 +912,9 @@ END FUNCTION LagrangeCoeff_Hexahedron4 ! summary: Returns the coefficients of monomials for all lagrange polynomial INTERFACE LagrangeCoeff_Hexahedron - MODULE FUNCTION LagrangeCoeff_Hexahedron5(& - & p, & - & q, & - & r, & - & xij, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3, & - & refHexahedron & - & ) RESULT(ans) + MODULE FUNCTION LagrangeCoeff_Hexahedron5(p, q, r, xij, basisType1, & + basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, alpha3, beta3, lambda3, refHexahedron) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order of polynomial in x direction INTEGER(I4B), INTENT(IN) :: q @@ -920,24 +982,9 @@ END FUNCTION LagrangeCoeff_Hexahedron5 ! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron INTERFACE TensorProdBasis_Hexahedron - MODULE FUNCTION TensorProdBasis_Hexahedron1( & - & p, & - & q, & - & r, & - & xij, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3) & - & RESULT(ans) + MODULE FUNCTION TensorProdBasis_Hexahedron1(p, q, r, xij, basisType1, & + basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, alpha3, beta3, lambda3) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index 4e1eb13d0..233dfd731 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2947,4 +2947,32 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE InterpolationPoint_Hexahedron1_ +CALL ErrorMsg(& + & msg="InterpolationPoint_Hexahedron1_ is not implemented", & + & file=__FILE__, & + & routine="InterpolationPoint_Hexahedron1_", & + & line=__LINE__, & + & unitno=stderr) +! STOP +END PROCEDURE InterpolationPoint_Hexahedron1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Hexahedron2_ +CALL ErrorMsg(& + & msg="InterpolationPoint_Hexahedron2_ is not implemented", & + & file=__FILE__, & + & routine="InterpolationPoint_Hexahedron2_", & + & line=__LINE__, & + & unitno=stderr) +STOP +END PROCEDURE InterpolationPoint_Hexahedron2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE Methods From 9ba03a4535e4a42fbdc835afe23cef60bc87b6e9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 11:40:57 +0900 Subject: [PATCH 078/359] Updates in PrismInterpolationUtility --- .../src/PrismInterpolationUtility.F90 | 37 +++++++++++++++---- .../src/PrismInterpolationUtility@Methods.F90 | 13 +++++++ 2 files changed, 43 insertions(+), 7 deletions(-) diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index 40ced9a38..dea4f0d9d 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -26,6 +26,7 @@ MODULE PrismInterpolationUtility PUBLIC :: EquidistanceInPoint_Prism PUBLIC :: EquidistancePoint_Prism PUBLIC :: InterpolationPoint_Prism +PUBLIC :: InterpolationPoint_Prism_ PUBLIC :: LagrangeCoeff_Prism PUBLIC :: QuadraturePoint_Prism PUBLIC :: TensorQuadraturePoint_Prism @@ -267,13 +268,8 @@ END FUNCTION EquidistancePoint_Prism ! summary: Interpolation point on Prism INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Prism( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, beta, lambda) & - & RESULT(nodecoord) + MODULE FUNCTION InterpolationPoint_Prism(order, ipType, layout, & + xij, alpha, beta, lambda) RESULT(nodecoord) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType @@ -289,6 +285,33 @@ MODULE PURE FUNCTION InterpolationPoint_Prism( & END FUNCTION InterpolationPoint_Prism END INTERFACE +!---------------------------------------------------------------------------- +! InterpolationPoint_Prism +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point on Prism + +INTERFACE + MODULE SUBROUTINE InterpolationPoint_Prism_(order, ipType, ans, & + nrow, ncol, layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation point type + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolation points in $x_{iJ}$ format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + CHARACTER(*), INTENT(IN) :: layout + !! + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coords of vertices in $x_{iJ}$ format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Jacobi and Ultraspherical parameters + END SUBROUTINE InterpolationPoint_Prism_ +END INTERFACE + !---------------------------------------------------------------------------- ! LagrangeCoeff_Prism !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 index 89c49dfe6..df5efb89e 100644 --- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 @@ -134,6 +134,19 @@ END SELECT END PROCEDURE InterpolationPoint_Prism +!---------------------------------------------------------------------------- +! InterpolationPoint_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Prism_ +CALL ErrorMsg(& + & msg="InterpolationPoint_Prism_ is not implemented", & + & file=__FILE__, & + & routine="InterpolationPoint_Prism_", & + & line=__LINE__, & + & unitno=stderr) +END PROCEDURE InterpolationPoint_Prism_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Prism !---------------------------------------------------------------------------- From 1c7654b0a0c1437db1a4f9b3ac1d53b9b73ce85b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 14:31:57 +0900 Subject: [PATCH 079/359] updates in eleme shape data --- src/modules/ElemshapeData/CMakeLists.txt | 74 ++++++++--------- .../src/ElemshapeData_H1Methods.F90 | 82 +++++-------------- .../src/ElemshapeData_Lagrange.F90 | 75 +++++++++++++++++ .../src/PyramidInterpolationUtility.F90 | 37 +++++++-- .../PyramidInterpolationUtility@Methods.F90 | 13 +++ 5 files changed, 177 insertions(+), 104 deletions(-) create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt index 39fa1ba47..f8e09790a 100644 --- a/src/modules/ElemshapeData/CMakeLists.txt +++ b/src/modules/ElemshapeData/CMakeLists.txt @@ -1,43 +1,41 @@ -# This program is a part of EASIFEM library -# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D # -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. # -# You should have received a copy of the GNU General Public License -# along with this program. If not, see +# You should have received a copy of the GNU General Public License along with +# this program. If not, see # -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ElemshapeData_Method.F90 - ${src_path}/ElemshapeData_ConstructorMethods.F90 - ${src_path}/ElemshapeData_DivergenceMethods.F90 - ${src_path}/ElemshapeData_GradientMethods.F90 - ${src_path}/ElemshapeData_GetMethods.F90 - - ${src_path}/ElemshapeData_H1Methods.F90 - ${src_path}/ElemshapeData_DGMethods.F90 - ${src_path}/ElemshapeData_HDivMethods.F90 - ${src_path}/ElemshapeData_HCurlMethods.F90 - - ${src_path}/ElemshapeData_HminHmaxMethods.F90 - ${src_path}/ElemshapeData_HRGNParamMethods.F90 - ${src_path}/ElemshapeData_HRQIParamMethods.F90 - ${src_path}/ElemshapeData_InterpolMethods.F90 - ${src_path}/ElemshapeData_IOMethods.F90 - ${src_path}/ElemshapeData_LocalDivergenceMethods.F90 - ${src_path}/ElemshapeData_LocalGradientMethods.F90 - ${src_path}/ElemshapeData_ProjectionMethods.F90 - ${src_path}/ElemshapeData_SetMethods.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods.F90 - ${src_path}/ElemshapeData_UnitNormalMethods.F90 -) +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ElemshapeData_Method.F90 + ${src_path}/ElemshapeData_ConstructorMethods.F90 + ${src_path}/ElemshapeData_DivergenceMethods.F90 + ${src_path}/ElemshapeData_GradientMethods.F90 + ${src_path}/ElemshapeData_GetMethods.F90 + ${src_path}/ElemshapeData_H1Methods.F90 + ${src_path}/ElemshapeData_DGMethods.F90 + ${src_path}/ElemshapeData_HDivMethods.F90 + ${src_path}/ElemshapeData_HCurlMethods.F90 + ${src_path}/ElemshapeData_Lagrange.F90 + ${src_path}/ElemshapeData_HminHmaxMethods.F90 + ${src_path}/ElemshapeData_HRGNParamMethods.F90 + ${src_path}/ElemshapeData_HRQIParamMethods.F90 + ${src_path}/ElemshapeData_InterpolMethods.F90 + ${src_path}/ElemshapeData_IOMethods.F90 + ${src_path}/ElemshapeData_LocalDivergenceMethods.F90 + ${src_path}/ElemshapeData_LocalGradientMethods.F90 + ${src_path}/ElemshapeData_ProjectionMethods.F90 + ${src_path}/ElemshapeData_SetMethods.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods.F90 + ${src_path}/ElemshapeData_UnitNormalMethods.F90) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 index 2af6c22b6..6e42b9047 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 @@ -15,8 +15,17 @@ ! along with this program. If not, see MODULE ElemshapeData_H1Methods -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemshapeData_, & + QuadraturePoint_, & + ReferenceElement_, & + H1_, & + LagrangeInterpolation_, & + HierarchyInterpolation_, & + OrthogonalInterpolation_, & + HermitInterpolation_, & + SerendipityInterpolation_ + +USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE PRIVATE PUBLIC :: Initiate @@ -30,20 +39,9 @@ MODULE ElemshapeData_H1Methods ! summary: This routine initiate the shape data INTERFACE Initiate - MODULE SUBROUTINE H1_Lagrange1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & coeff, & - & firstCall, & - & alpha, & - & beta, & - & lambda) + MODULE SUBROUTINE H1_Lagrange1(obj, quad, refelem, baseContinuity, & + baseInterpolation, order, ipType, basisType, coeff, firstCall, & + alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj CLASS(QuadraturePoint_), INTENT(IN) :: quad CLASS(ReferenceElement_), INTENT(IN) :: refelem @@ -79,17 +77,8 @@ END SUBROUTINE H1_Lagrange1 ! This routine initiates the shape function related data inside the element. INTERFACE Initiate - MODULE SUBROUTINE H1_Hierarchy1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) + MODULE SUBROUTINE H1_Hierarchy1(obj, quad, refelem, baseContinuity, & + baseInterpolation, order, ipType, basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -128,17 +117,8 @@ END SUBROUTINE H1_Hierarchy1 ! This routine initiates the shape function related data inside the element. INTERFACE Initiate - MODULE SUBROUTINE H1_Orthogonal1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) + MODULE SUBROUTINE H1_Orthogonal1(obj, quad, refelem, baseContinuity, & + baseInterpolation, order, ipType, basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -174,17 +154,8 @@ END SUBROUTINE H1_Orthogonal1 ! This routine initiates the shape function related data inside the element. INTERFACE Initiate - MODULE SUBROUTINE H1_Hermit1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) + MODULE SUBROUTINE H1_Hermit1(obj, quad, refelem, baseContinuity, & + baseInterpolation, order, ipType, basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -216,17 +187,8 @@ END SUBROUTINE H1_Hermit1 ! summary: This routine initiate the shape data INTERFACE Initiate - MODULE SUBROUTINE H1_Serendipity1( & - & obj, & - & quad, & - & refelem, & - & baseContinuity, & - & baseInterpolation, & - & order, & - & ipType, & - & basisType, & - & alpha, beta, lambda & - &) + MODULE SUBROUTINE H1_Serendipity1(obj, quad, refelem, baseContinuity, & + baseInterpolation, order, ipType, basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 new file mode 100644 index 000000000..1a9ac69a8 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 @@ -0,0 +1,75 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_Lagrange +USE BaseType, ONLY: ElemshapeData_, & + QuadraturePoint_, & + ReferenceElement_, & + H1_, & + LagrangeInterpolation_, & + HierarchyInterpolation_, & + OrthogonalInterpolation_, & + HermitInterpolation_, & + SerendipityInterpolation_ + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: ElemshapeData_InitiateLagrange + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE ElemshapeData_InitiateLagrange + MODULE SUBROUTINE ElemshapeData_InitiateLagrange1(obj, quad, nsd, xidim, & + elemType, refelemCoord, refelemDomain, baseContinuity, & + baseInterpolation, order, ipType, basisType, & + coeff, firstCall, alpha, beta, lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + TYPE(QuadraturePoint_), INTENT(IN) :: quad + INTEGER(I4B), INTENT(IN) :: nsd + INTEGER(I4B), INTENT(IN) :: xidim + INTEGER(I4B), INTENT(IN) :: elemType + REAL(DFP), INTENT(IN) :: refelemCoord(:, :) + CHARACTER(*), INTENT(IN) :: refelemDomain + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation point type + !! Default value is Equidistance + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function types + !! Default value is Monomial + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE ElemshapeData_InitiateLagrange1 +END INTERFACE ElemshapeData_InitiateLagrange + +END MODULE ElemshapeData_Lagrange diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 index 12147960d..ecb6ef1e3 100644 --- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 @@ -26,6 +26,7 @@ MODULE PyramidInterpolationUtility PUBLIC :: EquidistanceInPoint_Pyramid PUBLIC :: EquidistancePoint_Pyramid PUBLIC :: InterpolationPoint_Pyramid +PUBLIC :: InterpolationPoint_Pyramid_ PUBLIC :: LagrangeCoeff_Pyramid PUBLIC :: QuadraturePoint_Pyramid PUBLIC :: TensorQuadraturePoint_Pyramid @@ -267,12 +268,8 @@ END FUNCTION EquidistancePoint_Pyramid ! summary: Interpolation point on Pyramid INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Pyramid( & - & order, & - & ipType, & - & layout, & - & xij, & - & alpha, beta, lambda) RESULT(nodecoord) + MODULE FUNCTION InterpolationPoint_Pyramid(order, ipType, layout, & + xij, alpha, beta, lambda) RESULT(nodecoord) INTEGER(I4B), INTENT(IN) :: order !! order of element INTEGER(I4B), INTENT(IN) :: ipType @@ -288,6 +285,34 @@ MODULE PURE FUNCTION InterpolationPoint_Pyramid( & END FUNCTION InterpolationPoint_Pyramid END INTERFACE +!---------------------------------------------------------------------------- +! InterpolationPoint_Pyramid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Interpolation point on Pyramid + +INTERFACE + MODULE SUBROUTINE InterpolationPoint_Pyramid_(order, ipType, ans, & + nrow, ncol, layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in $x_{iJ}$ format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns in ans + CHARACTER(*), INTENT(IN) :: layout + !! layout + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coords of vertices in $x_{iJ}$ format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Alpha, beta, and lambda + END SUBROUTINE InterpolationPoint_Pyramid_ +END INTERFACE + !---------------------------------------------------------------------------- ! LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 index ccbdb15b7..db94a6c84 100644 --- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 @@ -141,6 +141,19 @@ END SELECT END PROCEDURE InterpolationPoint_Pyramid +!---------------------------------------------------------------------------- +! InterpolationPoint_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Pyramid_ +CALL ErrorMsg(& + & msg="InterpolationPoint_Pyramid_ is not implemented", & + & file=__FILE__, & + & routine="InterpolationPoint_Pyramid_", & + & line=__LINE__, & + & unitno=stderr) +END PROCEDURE InterpolationPoint_Pyramid_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- From dfa568f999af248c125b4d68cc4944e3ea331e92 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 14:32:04 +0900 Subject: [PATCH 080/359] updates in lagrange poly --- .../src/LagrangePolynomialUtility.F90 | 46 +++++++++++++++++++ .../src/QuadrangleInterpolationUtility.F90 | 17 +++++++ 2 files changed, 63 insertions(+) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index fc224af91..9f16642f7 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -33,6 +33,7 @@ MODULE LagrangePolynomialUtility PUBLIC :: LagrangeVandermonde_ PUBLIC :: EquidistancePoint PUBLIC :: InterpolationPoint +PUBLIC :: InterpolationPoint_ PUBLIC :: LagrangeCoeff PUBLIC :: LagrangeEvalAll PUBLIC :: LagrangeGradientEvalAll @@ -214,6 +215,51 @@ MODULE FUNCTION InterpolationPoint(order, elemType, ipType, xij, layout, & END FUNCTION InterpolationPoint END INTERFACE +!---------------------------------------------------------------------------- +! InterpolationPoint +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Get the interpolation point + +INTERFACE + MODULE SUBROUTINE InterpolationPoint_(order, elemType, ipType, xij, layout, & + alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: elemType + !! element type, following values are allowed. + !! Point, Line, Triangle, Quadrangle, Tetrahedron + !! Hexahedron, Prism, Pyramid + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto, + !! GaussUltraspherical, GaussUltrasphericalLobatto + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! the number of rows and cols written in ans + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" Vertex, Edge, Face, Cell + !! "INCREASING" incresing order + !! "DECREASING" decreasing order + !! "XYZ" First X, then Y, then Z + !! "YXZ" First Y, then X, then Z + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of linear elements. + !! Domain of interpolation, default values are given by: + !! Biunit line + !! Unit triangle + !! Biunit Quadrangle + !! Unit Tetrahedron + !! Biunit Hexahedron + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Jacobi and Ultraspherical parameters + END SUBROUTINE InterpolationPoint_ +END INTERFACE + !---------------------------------------------------------------------------- ! LagrangeCoeff !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index d129e380e..87e76a502 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -425,6 +425,23 @@ MODULE FUNCTION InterpolationPoint_Quadrangle1(order, ipType, layout, & !! 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(:, :) From 1226920d64b615cb05c9a9ce161ed6ad28ea51a8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 14:32:13 +0900 Subject: [PATCH 081/359] updates in integer utility --- ...s sharma's conflicted copy 2024-06-26).F90 | 537 ++++++++++++++++++ 1 file changed, 537 insertions(+) create mode 100644 src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 diff --git a/src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 b/src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 new file mode 100644 index 000000000..1f1067657 --- /dev/null +++ b/src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 @@ -0,0 +1,537 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General 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 IntegerUtility +USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, & + REAL32, REAL64 +IMPLICIT NONE +PRIVATE + +PUBLIC :: OPERATOR(.in.) +PUBLIC :: OPERATOR(.isin.) +PUBLIC :: RemoveDuplicates +PUBLIC :: RemoveDuplicates_ +PUBLIC :: Repeat +PUBLIC :: SIZE +PUBLIC :: GetMultiIndices +PUBLIC :: GetIndex +PUBLIC :: Get +PUBLIC :: GetIntersection +PUBLIC :: Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE Size + MODULE PURE FUNCTION obj_Size1(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + INTEGER(I4B) :: ans + END FUNCTION obj_Size1 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE Size + MODULE PURE FUNCTION obj_Size2(n, d, upto) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B) :: ans + END FUNCTION obj_Size2 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices + +INTERFACE GetMultiIndices + MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices1(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices1 +END INTERFACE GetMultiIndices + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices upto order n + +INTERFACE GetMultiIndices + MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices2 +END INTERFACE GetMultiIndices + +!---------------------------------------------------------------------------- +! Operator(.in.)@IntegerMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another + +INTERFACE OPERATOR(.in.) + MODULE PURE FUNCTION in_1a(a, b) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1a + + MODULE PURE FUNCTION in_1b(a, b) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1b + + MODULE PURE FUNCTION in_1c(a, b) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1c + + MODULE PURE FUNCTION in_1d(a, b) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_1d + +END INTERFACE OPERATOR(.in.) + +!---------------------------------------------------------------------------- +! Operator(.in.)@IntegerMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another +! +!# Introduction +! +! This function returns a vector of booleans +! if a(i) is inside the b, then ans(i) is true, otherwise false. + +INTERFACE OPERATOR(.isin.) + MODULE PURE FUNCTION isin_1a(a, b) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a(:) + INTEGER(INT8), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1a + + MODULE PURE FUNCTION isin_1b(a, b) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a(:) + INTEGER(INT16), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1b + + MODULE PURE FUNCTION isin_1c(a, b) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a(:) + INTEGER(INT32), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1c + + MODULE PURE FUNCTION isin_1d(a, b) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a(:) + INTEGER(INT64), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans(SIZE(a)) + END FUNCTION isin_1d +END INTERFACE OPERATOR(.isin.) + +!---------------------------------------------------------------------------- +! Operator(.in.)@IntegerMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-11 +! update: 2021-11-11 +! summary: Returns true if a integer set is inside another + +INTERFACE OPERATOR(.in.) + + MODULE PURE FUNCTION in_2a(a, b) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: a + INTEGER(INT8), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2a + + MODULE PURE FUNCTION in_2b(a, b) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: a + INTEGER(INT16), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2b + + MODULE PURE FUNCTION in_2c(a, b) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: a + INTEGER(INT32), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2c + + MODULE PURE FUNCTION in_2d(a, b) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: a + INTEGER(INT64), INTENT(IN) :: b(:) + LOGICAL(LGT) :: ans + END FUNCTION in_2d + +END INTERFACE OPERATOR(.in.) + +INTERFACE OPERATOR(.isin.) + MODULE PROCEDURE in_2a, in_2b, in_2c, in_2d +END INTERFACE OPERATOR(.isin.) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-12 +! summary: Remove duplicates entries + +INTERFACE RemoveDuplicates + MODULE PURE SUBROUTINE RemoveDuplicates_1a(obj) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1a + MODULE PURE SUBROUTINE RemoveDuplicates_1b(obj) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1b + MODULE PURE SUBROUTINE RemoveDuplicates_1c(obj) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1c + MODULE PURE SUBROUTINE RemoveDuplicates_1d(obj) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: obj(:) + END SUBROUTINE RemoveDuplicates_1d +END INTERFACE RemoveDuplicates + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-12 +! summary: Remove duplicates with no allocation + +INTERFACE RemoveDuplicates_ + MODULE PURE SUBROUTINE RemoveDuplicates_1a_(obj, tsize, isSorted) + INTEGER(INT8), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1a_ + + MODULE PURE SUBROUTINE RemoveDuplicates_1b_(obj, tsize, isSorted) + INTEGER(INT16), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1b_ + + MODULE PURE SUBROUTINE RemoveDuplicates_1c_(obj, tsize, isSorted) + INTEGER(INT32), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1c_ + + MODULE PURE SUBROUTINE RemoveDuplicates_1d_(obj, tsize, isSorted) + INTEGER(INT64), INTENT(INOUT) :: obj(:) + !! obj(1:tsize) will have unique entries + LOGICAL(LGT), INTENT(IN) :: isSorted + !! if obj is sorted then set isSorted to true + INTEGER(I4B), INTENT(OUT) :: tsize + !! number of unique entries found + END SUBROUTINE RemoveDuplicates_1d_ + +END INTERFACE RemoveDuplicates_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Repeat + MODULE PURE FUNCTION Repeat_1a(Val, rtimes) RESULT(Ans) + INTEGER(INT8), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT8) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1a + MODULE PURE FUNCTION Repeat_1b(Val, rtimes) RESULT(Ans) + INTEGER(INT16), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT16) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1b + MODULE PURE FUNCTION Repeat_1c(Val, rtimes) RESULT(Ans) + INTEGER(INT32), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT32) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1c + MODULE PURE FUNCTION Repeat_1d(Val, rtimes) RESULT(Ans) + INTEGER(INT64), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + INTEGER(INT64) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1d + MODULE PURE FUNCTION Repeat_1e(Val, rtimes) RESULT(Ans) + REAL(REAL32), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + REAL(REAL32) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1e + MODULE PURE FUNCTION Repeat_1f(Val, rtimes) RESULT(Ans) + REAL(REAL64), INTENT(IN) :: Val(:) + INTEGER(I4B), INTENT(IN) :: rtimes + REAL(REAL64) :: Ans(SIZE(Val) * rtimes) + END FUNCTION Repeat_1f +END INTERFACE Repeat + +!---------------------------------------------------------------------------- +! getIndex@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PURE FUNCTION GetIndex1(obj, val) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: val + INTEGER(I4B) :: ans + END FUNCTION GetIndex1 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! getIndex@getMethod +!---------------------------------------------------------------------------- + +INTERFACE GetIndex + MODULE PURE FUNCTION GetIndex2(obj, Val) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: obj(:) + INTEGER(I4B), INTENT(IN) :: Val(:) + INTEGER(I4B), ALLOCATABLE :: Ans(:) + END FUNCTION GetIndex2 +END INTERFACE GetIndex + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION Get1_Int8(val, indx) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT8) :: ans + END FUNCTION Get1_Int8 + + MODULE PURE FUNCTION Get1_Int16(val, indx) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT16) :: ans + END FUNCTION Get1_Int16 + + MODULE PURE FUNCTION Get1_Int32(val, indx) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT32) :: ans + END FUNCTION Get1_Int32 + + MODULE PURE FUNCTION Get1_Int64(val, indx) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx + INTEGER(INT64) :: ans + END FUNCTION Get1_Int64 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION Get2_Int8(val, indx) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT8) :: ans(SIZE(indx)) + END FUNCTION Get2_Int8 + + MODULE PURE FUNCTION Get2_Int16(val, indx) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT16) :: ans(SIZE(indx)) + END FUNCTION Get2_Int16 + + MODULE PURE FUNCTION Get2_Int32(val, indx) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT32) :: ans(SIZE(indx)) + END FUNCTION Get2_Int32 + + MODULE PURE FUNCTION Get2_Int64(val, indx) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: indx(:) + INTEGER(INT64) :: ans(SIZE(indx)) + END FUNCTION Get2_Int64 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get +!---------------------------------------------------------------------------- + +INTERFACE Get + MODULE PURE FUNCTION Get3_Int8(val, istart, iend, stride) RESULT(ans) + INTEGER(INT8), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT8) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int8 + + MODULE PURE FUNCTION Get3_Int16(val, istart, iend, stride) RESULT(ans) + INTEGER(INT16), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT16) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int16 + + MODULE PURE FUNCTION Get3_Int32(val, istart, iend, stride) RESULT(ans) + INTEGER(INT32), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT32) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int32 + + MODULE PURE FUNCTION Get3_Int64(val, istart, iend, stride) RESULT(ans) + INTEGER(INT64), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: istart, iend, stride + INTEGER(INT64) :: ans(INT((iend - istart) / stride) + 1) + END FUNCTION Get3_Int64 +END INTERFACE Get + +!---------------------------------------------------------------------------- +! GetIntersection +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-05-22 +! summary: Get the intersection fo two integer vectors + +INTERFACE GetIntersection + MODULE PURE SUBROUTINE GetIntersection1(a, b, c, tsize) + INTEGER(INT8), INTENT(IN) :: a(:), b(:) + INTEGER(INT8), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection1 + + MODULE PURE SUBROUTINE GetIntersection2(a, b, c, tsize) + INTEGER(INT16), INTENT(IN) :: a(:), b(:) + INTEGER(INT16), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection2 + + MODULE PURE SUBROUTINE GetIntersection3(a, b, c, tsize) + INTEGER(INT32), INTENT(IN) :: a(:), b(:) + INTEGER(INT32), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection3 + + MODULE PURE SUBROUTINE GetIntersection4(a, b, c, tsize) + INTEGER(INT64), INTENT(IN) :: a(:), b(:) + INTEGER(INT64), INTENT(INOUT) :: c(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetIntersection4 +END INTERFACE GetIntersection + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j) to ans from Fortran2D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom2DFortranIndex(i, j, dim1, dim2) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom2DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Get1DIndexFrom2DIndex +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j,k) to ans from Fortran3D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom3DFortranIndex(i, j, k, dim1, dim2, & + dim3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: k + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom3DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! Get1DIndexFortran +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-14 +! summary: Convert (i,j,k,l) to ans from Fortran4D array to 1D array + +INTERFACE Get1DIndexFortran + MODULE PURE FUNCTION Get1DIndexFrom4DFortranIndex(i, j, k, l, dim1, dim2, & + dim3, dim4) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: i + INTEGER(I4B), INTENT(IN) :: j + INTEGER(I4B), INTENT(IN) :: k + INTEGER(I4B), INTENT(IN) :: l + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(I4B) :: ans + END FUNCTION Get1DIndexFrom4DFortranIndex +END INTERFACE Get1DIndexFortran + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE IntegerUtility From cffa9dc32e388388251cbd4a7aaaa541b25d8de2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 14:32:20 +0900 Subject: [PATCH 082/359] updates in elemshape data --- src/submodules/ElemshapeData/CMakeLists.txt | 111 +++++++------- ...lemshapeData_H1Methods@LagrangeMethods.F90 | 137 ++++++++---------- .../ElemshapeData_Lagrange@Methods.F90 | 121 ++++++++++++++++ 3 files changed, 232 insertions(+), 137 deletions(-) create mode 100644 src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt index ca148d457..8937f2d22 100644 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -1,63 +1,58 @@ -# This program is a part of EASIFEM library -# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D # -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. # -# You should have received a copy of the GNU General Public License -# along with this program. If not, see +# You should have received a copy of the GNU General Public License along with +# this program. If not, see # -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ElemshapeData_ConstructorMethods@Methods.F90 - ${src_path}/ElemshapeData_DivergenceMethods@Methods.F90 - ${src_path}/ElemshapeData_GetMethods@Methods.F90 - ${src_path}/ElemshapeData_GradientMethods@Methods.F90 - - ${src_path}/H1/ElemshapeData_H1Methods@HermitMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 - - ${src_path}/DG/ElemshapeData_DGMethods@HermitMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 - - ${src_path}/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 - - ${src_path}/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 - - ${src_path}/ElemshapeData_HminHmaxMethods@Methods.F90 - ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90 - ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90 - ${src_path}/ElemshapeData_InterpolMethods@Methods.F90 - ${src_path}/ElemshapeData_IOMethods@Methods.F90 - ${src_path}/ElemshapeData_LocalDivergenceMethods@Methods.F90 - ${src_path}/ElemshapeData_LocalGradientMethods@Methods.F90 - ${src_path}/ElemshapeData_ProjectionMethods@Methods.F90 - ${src_path}/ElemshapeData_SetMethods@Methods.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods@SUGN3.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90 - ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 - ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90 -) +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ElemshapeData_ConstructorMethods@Methods.F90 + ${src_path}/ElemshapeData_DivergenceMethods@Methods.F90 + ${src_path}/ElemshapeData_GetMethods@Methods.F90 + ${src_path}/ElemshapeData_GradientMethods@Methods.F90 + ${src_path}/Lagrange/ElemshapeData_Lagrange@Methods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@HermitMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 + ${src_path}/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@HermitMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 + ${src_path}/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 + ${src_path}/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 + ${src_path}/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 + ${src_path}/ElemshapeData_HminHmaxMethods@Methods.F90 + ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90 + ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90 + ${src_path}/ElemshapeData_InterpolMethods@Methods.F90 + ${src_path}/ElemshapeData_IOMethods@Methods.F90 + ${src_path}/ElemshapeData_LocalDivergenceMethods@Methods.F90 + ${src_path}/ElemshapeData_LocalGradientMethods@Methods.F90 + ${src_path}/ElemshapeData_ProjectionMethods@Methods.F90 + ${src_path}/ElemshapeData_SetMethods@Methods.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods@SUGN3.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90 + ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 + ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90) diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 index 39cc8ade3..7b0f7a94b 100644 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 +++ b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 @@ -16,7 +16,25 @@ ! SUBMODULE(ElemShapeData_H1Methods) LagrangeMethods -USE BaseMethod +USE InputUtility, ONLY: Input + +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate + +USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE + +USE LagrangePolynomialUtility, ONLY: LagrangeDOF, & + InterpolationPoint, & + LagrangeEvalAll, & + LagrangeGradientEvalAll + +USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & + QuadraturePoint_Size => Size + +USE BaseType, ONLY: TypeQuadratureOpt, & + TypePolynomialOpt + +USE SwapUtility, ONLY: SWAP + IMPLICIT NONE CONTAINS @@ -27,99 +45,60 @@ MODULE PROCEDURE H1_Lagrange1 REAL(DFP), ALLOCATABLE :: pt(:, :), xij(:, :), dNdXi(:, :, :), coeff0(:, :) -INTEGER(I4B) :: nsd, xidim, ipType0, basisType0 +INTEGER(I4B) :: nsd, xidim, ipType0, basisType0, tsize, nns -ipType0 = Input(default=Equidistance, option=ipType) -basisType0 = Input(default=Monomial, option=basisType) +ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType) +basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType) ! CALL DEALLOCATE (obj) -CALL Initiate(obj%refelem, refelem) +CALL Refelem_Initiate(obj%refelem, refelem) + nsd = refelem%nsd + xidim = refelem%xiDimension + CALL GetQuadraturePoints(obj=quad, points=pt, weights=obj%ws) + obj%quad = quad -CALL ALLOCATE ( & - & obj=obj, & - & nsd=nsd, & - & xidim=xidim, & - & nns=LagrangeDOF(order=order, elemType=refelem%name), & - & nips=SIZE(quad, 2)) +tsize = QuadraturePoint_Size(quad, 2) -xij = InterpolationPoint( & - & order=order, & - & elemType=refelem%name, & - & ipType=ipType0, & - & layout="VEFC", & - & xij=refelem%xij(1:xidim, :), & - & alpha=alpha, beta=beta, lambda=lambda) +nns = LagrangeDOF(order=order, elemType=refelem%name) +CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=tsize) -CALL Reallocate(coeff0, SIZE(xij, 2), SIZE(xij, 2)) +xij = InterpolationPoint(order=order, elemType=refelem%name, ipType=ipType0, & + layout="VEFC", xij=refelem%xij(1:xidim, :), alpha=alpha, beta=beta, & + lambda=lambda) + +ALLOCATE (coeff0(SIZE(xij, 2), SIZE(xij, 2))) IF (PRESENT(coeff)) THEN - obj%N = TRANSPOSE(LagrangeEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff, & - & firstCall=firstCall)) - - dNdXi = LagrangeGradientEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff, & - & firstCall=.FALSE.) - - CALL SWAP( & - & a=obj%dNdXi, & - & b=dNdXi, & - & i1=2, i2=3, i3=1) + + obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=refelem%name, & + x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff, firstCall=firstCall)) + + dNdXi = LagrangeGradientEvalAll(order=order, elemType=refelem%name, & + x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff, firstCall=.FALSE.) + + CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) ELSE - obj%N = TRANSPOSE(LagrangeEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff0, & - & firstCall=.TRUE.)) - - dNdXi = LagrangeGradientEvalAll( & - & order=order, & - & elemType=refelem%name, & - & x=pt(1:xidim, :), & - & xij=xij, & - & domainName=refelem%domainName, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & coeff=coeff0, & - & firstCall=.FALSE.) - - CALL SWAP( & - & a=obj%dNdXi, & - & b=dNdXi, & - & i1=2, i2=3, i3=1) + obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=refelem%name, & + x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff0, firstCall=.TRUE.)) + + dNdXi = LagrangeGradientEvalAll(order=order, elemType=refelem%name, & + x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & + basisType=basisType0, alpha=alpha, beta=beta, & + lambda=lambda, coeff=coeff0, firstCall=.FALSE.) + + CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) END IF diff --git a/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 new file mode 100644 index 000000000..8e7929c45 --- /dev/null +++ b/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 @@ -0,0 +1,121 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_Lagrange) Methods +USE InputUtility, ONLY: Input + +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate + +USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE + +USE LagrangePolynomialUtility, ONLY: LagrangeDOF, & + InterpolationPoint_, & + LagrangeEvalAll, & + LagrangeGradientEvalAll + +USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & + QuadraturePoint_Size => Size + +USE BaseType, ONLY: TypeQuadratureOpt, & + TypePolynomialOpt + +USE SwapUtility, ONLY: SWAP + +USE Display_Method, ONLY: Display + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! ElemshapeData_InitiateLagrange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ElemshapeData_InitiateLagrange1 +REAL(DFP), ALLOCATABLE :: xij(:, :), dNdXi(:, :, :), coeff0(:, :) +INTEGER(I4B) :: ipType0, basisType0, tsize, nns, nrow, ncol + +ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType) +basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType) + +! CALL DEALLOCATE (obj) + +tsize = SIZE(quad%points, 2) +! pt = quad%points(1:obj%txi, 1:tsize) +! wt = quad%points(obj%txi + 1, 1:tsize) + +nns = LagrangeDOF(order=order, elemType=elemType) + +CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=tsize) + +obj%ws = quad%points(quad%txi + 1, 1:tsize) + +ncol = LagrangeDOF(order=order, elemType=elemType) +ALLOCATE (xij(3, ncol)) + +CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType0, & + layout="VEFC", xij=refelemCoord(1:xidim, :), alpha=alpha, beta=beta, & + lambda=lambda, ans=xij, nrow=nrow, ncol=ncol) + +IF (PRESENT(coeff)) THEN + + obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:tsize), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff, firstCall=firstCall)) + + dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:tsize), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff, firstCall=.FALSE.) + +ELSE + + ALLOCATE (coeff0(SIZE(xij, 2), SIZE(xij, 2))) + + obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:tsize), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff0, firstCall=.TRUE.)) + + dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:tsize), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff0, firstCall=.FALSE.) +END IF + +CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) + +IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) +IF (ALLOCATED(xij)) DEALLOCATE (xij) +IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0) + +END PROCEDURE ElemshapeData_InitiateLagrange1 + +END SUBMODULE Methods From 96852f38c08181c5b5f3918d934c0dc9ff47b719 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 14:32:26 +0900 Subject: [PATCH 083/359] updates in polynomial util --- .../src/LagrangePolynomialUtility@Methods.F90 | 139 ++++++++++++------ .../src/LineInterpolationUtility@Methods.F90 | 4 +- ...erpolationUtility@LagrangeBasisMethods.F90 | 44 +++--- 3 files changed, 118 insertions(+), 69 deletions(-) diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index a047cba63..c9b0361ef 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -28,6 +28,7 @@ LagrangeDegree_Line, & EquidistancePoint_Line, & InterpolationPoint_Line, & + InterpolationPoint_Line_, & LagrangeCoeff_Line, & LagrangeEvalAll_Line, & LagrangeGradientEvalAll_Line @@ -37,6 +38,7 @@ LagrangeDegree_Triangle, & EquidistancePoint_Triangle, & InterpolationPoint_Triangle, & + InterpolationPoint_Triangle_, & LagrangeCoeff_Triangle, & LagrangeEvalAll_Triangle, & LagrangeGradientEvalAll_Triangle @@ -46,6 +48,7 @@ LagrangeDegree_Quadrangle, & EquidistancePoint_Quadrangle, & InterpolationPoint_Quadrangle, & + InterpolationPoint_Quadrangle_, & LagrangeCoeff_Quadrangle, & LagrangeEvalAll_Quadrangle, & LagrangeGradientEvalAll_Quadrangle @@ -55,6 +58,7 @@ LagrangeDegree_Tetrahedron, & EquidistancePoint_Tetrahedron, & InterpolationPoint_Tetrahedron, & + InterpolationPoint_Tetrahedron_, & LagrangeCoeff_Tetrahedron, & LagrangeEvalAll_Tetrahedron, & LagrangeGradientEvalAll_Tetrahedron @@ -64,6 +68,7 @@ LagrangeDegree_Hexahedron, & EquidistancePoint_Hexahedron, & InterpolationPoint_Hexahedron, & + InterpolationPoint_Hexahedron_, & LagrangeCoeff_Hexahedron, & LagrangeEvalAll_Hexahedron, & LagrangeGradientEvalAll_Hexahedron @@ -73,6 +78,7 @@ LagrangeDegree_Prism, & EquidistancePoint_Prism, & InterpolationPoint_Prism, & + InterpolationPoint_Prism_, & LagrangeCoeff_Prism, & LagrangeEvalAll_Prism, & LagrangeGradientEvalAll_Prism @@ -82,6 +88,7 @@ LagrangeDegree_Pyramid, & EquidistancePoint_Pyramid, & InterpolationPoint_Pyramid, & + InterpolationPoint_Pyramid_, & LagrangeCoeff_Pyramid, & LagrangeEvalAll_Pyramid, & LagrangeGradientEvalAll_Pyramid @@ -299,73 +306,109 @@ END IF CASE (Line) - ans = InterpolationPoint_Line(& - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) + ans = InterpolationPoint_Line(order=order, ipType=ipType, & + xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) CASE (Triangle) - ans = InterpolationPoint_Triangle( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) + ans = InterpolationPoint_Triangle(order=order, ipType=ipType, & + xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) CASE (Quadrangle) - ans = InterpolationPoint_Quadrangle( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) + ans = InterpolationPoint_Quadrangle(order=order, ipType=ipType, & + xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) CASE (Tetrahedron) - ans = InterpolationPoint_Tetrahedron( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) + ans = InterpolationPoint_Tetrahedron(order=order, ipType=ipType, & + xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) CASE (Hexahedron) - ans = InterpolationPoint_Hexahedron( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) + ans = InterpolationPoint_Hexahedron(order=order, ipType=ipType, xij=xij, & + layout=layout, alpha=alpha, beta=beta, lambda=lambda) CASE (Prism) - ans = InterpolationPoint_Prism( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) + ans = InterpolationPoint_Prism(order=order, ipType=ipType, xij=xij, & + layout=layout, alpha=alpha, beta=beta, lambda=lambda) CASE (Pyramid) - ans = InterpolationPoint_Pyramid( & - & order=order, & - & ipType=ipType, & - & xij=xij, & - & layout=layout, & - & alpha=alpha, beta=beta, lambda=lambda) + ans = InterpolationPoint_Pyramid(order=order, ipType=ipType, xij=xij, & + layout=layout, alpha=alpha, beta=beta, lambda=lambda) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="InterpolationPoint()", & - & file=__FILE__) + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + unitno=stdout, line=__LINE__, routine="InterpolationPoint()", & + file=__FILE__) RETURN END SELECT END PROCEDURE InterpolationPoint +!---------------------------------------------------------------------------- +! InterpolationPoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_ +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) + + IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + ncol = SIZE(xij, 2) + ans(1:nrow, 1:ncol) = xij(1:nrow, 1:ncol) + RETURN + END IF + + nrow = 0 + ncol = 0 + +CASE (Line) + CALL InterpolationPoint_Line_(order=order, ipType=ipType, ans=ans, & + nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, beta=beta, & + lambda=lambda) + +CASE (Triangle) + CALL InterpolationPoint_Triangle_(order=order, ipType=ipType, ans=ans, & + nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, beta=beta, & + lambda=lambda) + +CASE (Quadrangle) + CALL InterpolationPoint_Quadrangle_(order=order, ipType=ipType, ans=ans, & + nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, & + beta=beta, lambda=lambda) + +CASE (Tetrahedron) + CALL InterpolationPoint_Tetrahedron_(order=order, ipType=ipType, ans=ans, & + nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, & + beta=beta, lambda=lambda) + +CASE (Hexahedron) + CALL InterpolationPoint_Hexahedron_(order=order, ipType=ipType, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol, layout=layout, & + alpha=alpha, beta=beta, lambda=lambda) + +CASE (Prism) + CALL InterpolationPoint_Prism_(order=order, ipType=ipType, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol, layout=layout, & + alpha=alpha, beta=beta, lambda=lambda) + +CASE (Pyramid) + CALL InterpolationPoint_Pyramid_(order=order, ipType=ipType, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol, layout=layout, alpha=alpha, beta=beta, & + lambda=lambda) + +CASE DEFAULT + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + unitno=stdout, line=__LINE__, routine="InterpolationPoint()", & + file=__FILE__) + RETURN +END SELECT + +END PROCEDURE InterpolationPoint_ + !---------------------------------------------------------------------------- ! LagrangeCoeff !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index ec2f69f8e..e6fef517a 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -745,8 +745,8 @@ END SUBROUTINE handle_error RETURN END IF -orthopol0 = input(default=polyopt%Monomial, option=basisType) -firstCall0 = input(default=.TRUE., option=firstCall) +orthopol0 = Input(default=polyopt%Monomial, option=basisType) +firstCall0 = Input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN IF (firstCall0) THEN diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index 50fd1448c..d71b20c3e 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -21,7 +21,10 @@ USE GE_CompRoutineMethods, ONLY: GetInvMat USE GE_LUMethods, ONLY: LUSolve, GetLU +USE BaseType, ONLY: polyopt => TypePolynomialOpt, elemopt => TypeElemNameOpt + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -84,8 +87,8 @@ ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, ans=V, & - nrow=nrow, ncol=ncol) +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elemopt%Triangle, & + ans=V, nrow=nrow, ncol=ncol) CALL GetLU(A=V, IPIV=ipiv, info=info) CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) END PROCEDURE LagrangeCoeff_Triangle1 @@ -122,7 +125,7 @@ INTEGER(I4B) :: basisType0, nrow, ncol CHARACTER(:), ALLOCATABLE :: ref0 -basisType0 = Input(default=Monomial, option=basisType) +basisType0 = Input(default=polyopt%Monomial, option=basisType) ref0 = Input(default="UNIT", option=refTriangle) CALL LagrangeCoeff_Triangle4_(order=order, xij=xij, basisType=basisType0, & refTriangle=ref0, ans=ans, nrow=nrow, ncol=ncol) @@ -137,16 +140,17 @@ SELECT CASE (basisType) -CASE (Monomial) - CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, & +CASE (polyopt%Monomial) + CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elemopt%Triangle, & ans=ans, nrow=nrow, ncol=ncol) -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) +CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, & + polyopt%Lobatto, polyopt%Ultraspherical) CALL Dubiner_Triangle_(order=order, xij=xij, refTriangle=refTriangle, & ans=ans, nrow=nrow, ncol=ncol) -CASE (Heirarchical) +CASE (polyopt%Hierarchical) CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & pe3=order, xij=xij, refTriangle=refTriangle, & @@ -167,7 +171,7 @@ INTEGER(I4B) :: degree(SIZE(xij, 2), 2) REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) -basisType0 = Input(default=Monomial, option=basisType) +basisType0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN @@ -192,7 +196,7 @@ SELECT CASE (basisType0) -CASE (Monomial) +CASE (polyopt%Monomial) CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) @@ -202,13 +206,14 @@ xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) END DO -CASE (Heirarchical) +CASE (polyopt%Hierarchical) CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, & pe2=order, pe3=order, xij=RESHAPE(x, [2, 1]), & refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) +CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, & + polyopt%Ultraspherical) CALL Dubiner_Triangle_(order=order, xij=RESHAPE(x, [2, 1]), & refTriangle=refTriangle, ans=xx, nrow=nrow, ncol=ncol) @@ -228,7 +233,7 @@ INTEGER(I4B) :: degree(SIZE(xij, 2), 2) REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) -basisType0 = Input(default=Monomial, option=basisType) +basisType0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN @@ -252,7 +257,7 @@ SELECT CASE (basisType0) -CASE (Monomial) +CASE (polyopt%Monomial) CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) tdof = SIZE(xij, 2) @@ -261,12 +266,12 @@ xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2) END DO -CASE (Heirarchical) +CASE (polyopt%Hierarchical) CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & pe3=order, xij=x, refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) +CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, polyopt%Ultraspherical) CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, & ans=xx, nrow=nrow, ncol=ncol) @@ -287,7 +292,7 @@ REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br -basisType0 = Input(default=Monomial, option=basisType) +basisType0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN @@ -304,7 +309,7 @@ SELECT CASE (basisType0) -CASE (Monomial) +CASE (polyopt%Monomial) CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=s(1), ncol=s(2)) @@ -319,13 +324,14 @@ xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi) END DO -CASE (Heirarchical) +CASE (polyopt%Hierarchical) CALL HeirarchicalBasisGradient_Triangle_(order=order, pe1=order, pe2=order, & pe3=order, xij=x, refTriangle=refTriangle, ans=xx, tsize1=s(1), & tsize2=s(2), tsize3=s(3)) -CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical) +CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, & + polyopt%Ultraspherical) CALL OrthogonalBasisGradient_Triangle_(order=order, xij=x, & refTriangle=refTriangle, ans=xx, tsize1=s(1), tsize2=s(2), tsize3=s(3)) From 76da2edff59cb01d1e5054ac2dbc7bac7272e9a3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 16:27:58 +0900 Subject: [PATCH 084/359] Updates in LagrangePolynomialUtility --- .../src/LagrangePolynomialUtility.F90 | 95 +++++++++++++++++++ .../src/LagrangePolynomialUtility@Methods.F90 | 59 +++++++++--- 2 files changed, 141 insertions(+), 13 deletions(-) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index 9f16642f7..6716999f2 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -283,6 +283,31 @@ MODULE FUNCTION LagrangeCoeff1(order, elemType, i, xij) RESULT(ans) END FUNCTION LagrangeCoeff1 END INTERFACE LagrangeCoeff +!---------------------------------------------------------------------------- +! LagrangeCoeff_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Returns the coefficient of ith lagrange poly + +INTERFACE LagrangeCoeff_ + MODULE SUBROUTINE LagrangeCoeff1_(order, elemType, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff1_ +END INTERFACE LagrangeCoeff_ + !---------------------------------------------------------------------------- ! LagrangeCoeff !---------------------------------------------------------------------------- @@ -304,6 +329,29 @@ MODULE FUNCTION LagrangeCoeff2(order, elemType, xij) RESULT(ans) END FUNCTION LagrangeCoeff2 END INTERFACE LagrangeCoeff +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Returns the coefficient of all lagrange poly + +INTERFACE LagrangeCoeff_ + MODULE SUBROUTINE LagrangeCoeff2_(order, elemType, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff2_ +END INTERFACE LagrangeCoeff_ + !---------------------------------------------------------------------------- ! LagrangeCoeff !---------------------------------------------------------------------------- @@ -326,6 +374,30 @@ MODULE FUNCTION LagrangeCoeff3(order, elemType, i, v, & END FUNCTION LagrangeCoeff3 END INTERFACE LagrangeCoeff +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_ + MODULE SUBROUTINE LagrangeCoeff3_(order, elemType, i, v, & + isVandermonde, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff3_ +END INTERFACE LagrangeCoeff_ + !---------------------------------------------------------------------------- ! LagrangeCoeff !---------------------------------------------------------------------------- @@ -347,6 +419,29 @@ MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) RESULT(ans) END FUNCTION LagrangeCoeff4 END INTERFACE LagrangeCoeff +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_ + MODULE SUBROUTINE LagrangeCoeff4_(order, elemType, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff4_ +END INTERFACE LagrangeCoeff_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index c9b0361ef..a0097127a 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -409,6 +409,42 @@ END PROCEDURE InterpolationPoint_ +!---------------------------------------------------------------------------- +! LagrangeCoeff_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff1_ +CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & + routine="LagrangeCoeff1_", file=__FILE__) +END PROCEDURE LagrangeCoeff1_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff2_ +CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & + routine="LagrangeCoeff2_", file=__FILE__) +END PROCEDURE LagrangeCoeff2_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff3_ +CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & + routine="LagrangeCoeff3_", file=__FILE__) +END PROCEDURE LagrangeCoeff3_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff4_ +CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & + routine="LagrangeCoeff4_", file=__FILE__) +END PROCEDURE LagrangeCoeff4_ + !---------------------------------------------------------------------------- ! LagrangeCoeff !---------------------------------------------------------------------------- @@ -443,12 +479,12 @@ ans = LagrangeCoeff_Pyramid(order=order, xij=xij, i=i) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff1()", & - & file=__FILE__) + CALL Errormsg( & + msg="No CASE FOUND: elemType="//ToString(elemType), & + unitno=stdout, & + line=__LINE__, & + routine="LagrangeCoeff1()", & + file=__FILE__) END SELECT END PROCEDURE LagrangeCoeff1 @@ -487,12 +523,9 @@ ans = LagrangeCoeff_Pyramid(order=order, xij=xij) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff2()", & - & file=__FILE__) + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + unitno=stdout, line=__LINE__, routine="LagrangeCoeff2()", & + file=__FILE__) END SELECT END PROCEDURE LagrangeCoeff2 @@ -533,7 +566,7 @@ & msg="No CASE FOUND: elemType="//ToString(elemType), & & unitno=stdout, & & line=__LINE__, & - & routine="LagrangeCoeff2()", & + & routine="LagrangeCoeff3()", & & file=__FILE__) END SELECT END PROCEDURE LagrangeCoeff3 From 1adf4f7452d0b6dfa0f19776f26200ed3b924449 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 16:28:08 +0900 Subject: [PATCH 085/359] Updates in LineInterpolationUtility --- .../src/LineInterpolationUtility.F90 | 116 +++++++++++++++- .../src/LineInterpolationUtility@Methods.F90 | 124 ++++++++++++++---- 2 files changed, 206 insertions(+), 34 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index ba4bca095..e3cae4f02 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -587,6 +587,25 @@ END FUNCTION LagrangeCoeff_Line1 ! LagrangeCoeff_Line !---------------------------------------------------------------------------- +INTERFACE LagrangeCoeff_Line_ + MODULE SUBROUTINE LagrangeCoeff_Line1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(order + 1) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Line1_ +END INTERFACE LagrangeCoeff_Line_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + INTERFACE LagrangeCoeff_Line MODULE FUNCTION LagrangeCoeff_Line2(order, i, v, isVandermonde) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -606,6 +625,28 @@ END FUNCTION LagrangeCoeff_Line2 ! LagrangeCoeff_Line !---------------------------------------------------------------------------- +INTERFACE LagrangeCoeff_Line_ + MODULE SUBROUTINE LagrangeCoeff_Line2_(order, i, v, isVandermonde, ans, & + tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(order + 1) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Line2_ +END INTERFACE LagrangeCoeff_Line_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + INTERFACE LagrangeCoeff_Line MODULE FUNCTION LagrangeCoeff_Line3(order, i, v, ipiv) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -625,6 +666,27 @@ END FUNCTION LagrangeCoeff_Line3 ! LagrangeCoeff_Line !---------------------------------------------------------------------------- +INTERFACE LagrangeCoeff_Line_ + MODULE SUBROUTINE LagrangeCoeff_Line3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(order + 1) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Line3_ +END INTERFACE LagrangeCoeff_Line_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + INTERFACE LagrangeCoeff_Line MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -638,6 +700,25 @@ MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans) END FUNCTION LagrangeCoeff_Line4 END INTERFACE LagrangeCoeff_Line +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Line_ + MODULE SUBROUTINE LagrangeCoeff_Line4_(order, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(order + 1, order + 1) + !! coefficients + !! jth column of ans corresponds to the coeff of lagrange polynomial + !! at the jth point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Line4_ +END INTERFACE LagrangeCoeff_Line_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Line !---------------------------------------------------------------------------- @@ -650,12 +731,7 @@ MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, & REAL(DFP), INTENT(IN) :: xij(:, :) !! points in xij format, size(xij,2) = order+1 INTEGER(I4B), INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! Monomial, Jacobi, Legendre, Chebyshev, Lobatto, UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -669,6 +745,34 @@ MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, & END FUNCTION LagrangeCoeff_Line5 END INTERFACE LagrangeCoeff_Line +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Line_ + MODULE SUBROUTINE LagrangeCoeff_Line5_(order, xij, basisType, alpha, & + beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + INTEGER(I4B), INTENT(IN) :: basisType + !! Monomial, Jacobi, Legendre, Chebyshev, Lobatto, UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + !! jth column of ans corresponds to the coeff of lagrange polynomial + !! at the jth point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Line5_ +END INTERFACE LagrangeCoeff_Line_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Line !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index e6fef517a..d77884a6d 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -35,7 +35,8 @@ USE InputUtility, ONLY: Input USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde, & - LagrangeCoeff + LagrangeCoeff, & + LagrangeVandermonde_ USE ErrorHandling, ONLY: ErrorMsg @@ -664,68 +665,135 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Line1 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Line1_(order=order, i=i, xij=xij, ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Line1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line1_ REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -v = LagrangeVandermonde(order=order, xij=xij, elemType=elmopt%Line) +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 = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Line1 + +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) + +END PROCEDURE LagrangeCoeff_Line1_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Line !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Line2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Line2_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Line2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line2_ REAL(DFP) :: vtemp(SIZE(v, 1), SIZE(v, 2)) INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv INTEGER(I4B) :: info -vtemp = v; ipiv = 0 + +tsize = order + 1 + +vtemp = v +! ipiv = 0 + CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Line2 + +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) + +END PROCEDURE LagrangeCoeff_Line2_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Line !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Line3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Line3_(order=order, i=i, v=v, ipiv=ipiv, ans=ans, & + tsize=tsize) END PROCEDURE LagrangeCoeff_Line3 !---------------------------------------------------------------------------- ! LagrangeCoeff_Line !---------------------------------------------------------------------------- +MODULE PROCEDURE LagrangeCoeff_Line3_ +INTEGER(I4B) :: info +tsize = 1 + order +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Line3_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + MODULE PROCEDURE LagrangeCoeff_Line4 -ans = LagrangeVandermonde(order=order, xij=xij, elemType=elmopt%Line) -CALL GetInvMat(ans) +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Line4_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) END PROCEDURE LagrangeCoeff_Line4 +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line4_ +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elmopt%Line, & + ans=ans, nrow=nrow, ncol=ncol) +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Line4_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Line !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Line5 -SELECT CASE (basisType) -CASE (polyopt%Monomial) - ans = LagrangeCoeff_Line(order=order, xij=xij) -CASE DEFAULT - ans = EvalAllOrthopol(& - & n=order, & - & x=xij(1, :), & - & orthopol=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - CALL GetInvMat(ans) -END SELECT +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Line5_(order=order, xij=xij, basisType=basisType, & + alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE LagrangeCoeff_Line5 +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line5_ +IF (basisType .EQ. polyopt%Monomial) THEN + CALL LagrangeCoeff_Line_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) + RETURN +END IF + +nrow = SIZE(xij, 2) +ncol = nrow + +ans(1:nrow, 1:ncol) = EvalAllOrthopol(n=order, x=xij(1, :), & + orthopol=basisType, & + alpha=alpha, beta=beta, lambda=lambda) + +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Line5_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Line !---------------------------------------------------------------------------- From 72af307db37859dae560d33d48ed29634780b254 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 16:52:02 +0900 Subject: [PATCH 086/359] updates in JacobiPolynomialUtility --- .../src/JacobiPolynomialUtility.F90 | 36 ++ .../src/JacobiPolynomialUtility@Methods.F90 | 327 +++++++++--------- 2 files changed, 200 insertions(+), 163 deletions(-) diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index c8357a7e4..b5475ce82 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -534,6 +534,24 @@ MODULE PURE FUNCTION JacobiEvalAll1(n, alpha, beta, x) RESULT(ans) END FUNCTION JacobiEvalAll1 END INTERFACE JacobiEvalAll +!---------------------------------------------------------------------------- +! JacobiEvalAll +!---------------------------------------------------------------------------- + +INTERFACE JacobiEvalAll_ + MODULE PURE SUBROUTINE JacobiEvalAll1_(n, alpha, beta, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(n + 1) + !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE JacobiEvalAll1_ +END INTERFACE JacobiEvalAll_ + !---------------------------------------------------------------------------- ! JacobiEvalUpto !---------------------------------------------------------------------------- @@ -565,6 +583,24 @@ MODULE PURE FUNCTION JacobiEvalAll2(n, alpha, beta, x) RESULT(ans) END FUNCTION JacobiEvalAll2 END INTERFACE JacobiEvalAll +!---------------------------------------------------------------------------- +! JacobiEvalAll +!---------------------------------------------------------------------------- + +INTERFACE JacobiEvalAll_ + MODULE PURE SUBROUTINE JacobiEvalAll2_(n, alpha, beta, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), n + 1) + !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE JacobiEvalAll2_ +END INTERFACE JacobiEvalAll_ + !---------------------------------------------------------------------------- ! JacobiEval !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index 676683b43..4a5463178 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -120,11 +120,11 @@ !! DO ii = 2, n j = REAL(ii, KIND=DFP) - A(ii-1) = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + A(ii-1) = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); B(ii - 1) = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); C(ii - 1) = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); END DO !! END PROCEDURE GetJacobiRecurrenceCoeff2 @@ -460,117 +460,118 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiEvalAll1 +INTEGER(I4B) :: tsize +CALL JacobiEvalAll1_(n=n, x=x, alpha=alpha, beta=beta, ans=ans, tsize=tsize) +END PROCEDURE JacobiEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalAll1_ INTEGER(I4B) :: i -REAL(DFP) :: c1 -REAL(DFP) :: c2 -REAL(DFP) :: c3 -REAL(DFP) :: c4 -REAL(DFP) :: r_i -!! -ans = 0.0_DFP -!! -IF (alpha <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (beta <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (n < 0) THEN - RETURN -END IF -!! +REAL(DFP) :: c1, c2, c3, c4, r_i, apb, amb, r2, apb_minus_2, apb_minus_1, & + alpha_minus_1, beta_minus_1 + +tsize = 0 + +IF (alpha <= -1.0_DFP) RETURN +IF (beta <= -1.0_DFP) RETURN + +IF (n < 0) RETURN + +tsize = 1 + n ans(1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & - & + 0.5_DFP * (alpha - beta) -!! + +IF (n .EQ. 0) RETURN + +apb = alpha + beta +apb_minus_2 = apb - 2.0_DFP +apb_minus_1 = apb - 1.0_DFP +alpha_minus_1 = alpha - 1.0_DFP +beta_minus_1 = beta - 1.0_DFP +amb = alpha - beta + +ans(2) = (1.0_DFP + 0.5_DFP * apb) * x + 0.5_DFP * amb + DO i = 2, n - !! - r_i = real(i, kind=DFP) - !! - c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (2.0_DFP * r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (alpha + beta) * (alpha - beta) - !! - c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & - & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) - !! + + r_i = REAL(i, kind=DFP) + r2 = 2.0_DFP * r_i + + c1 = r2 * (r_i + apb) * (r2 + apb_minus_2) + + c2 = (r2 + apb_minus_1) * (r2 + apb) * (r2 + apb_minus_2) + + c3 = (r2 + apb_minus_1) * apb * amb + + c4 = -2.0_DFP * (r_i + alpha_minus_1) * (r_i + beta_minus_1) * (r2 + apb) + ans(i + 1) = ((c3 + c2 * x) * ans(i) + c4 * ans(i - 1)) / c1 - !! + END DO -END PROCEDURE JacobiEvalAll1 +END PROCEDURE JacobiEvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL JacobiEvalAll2_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE JacobiEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalAll2_ INTEGER(I4B) :: i -REAL(DFP) :: c1 -REAL(DFP) :: c2 -REAL(DFP) :: c3 -REAL(DFP) :: c4 -REAL(DFP) :: r_i -!! -ans = 0.0_DFP -!! -IF (alpha <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (beta <= -1.0_DFP) THEN - RETURN -END IF -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(:, 1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(:, 2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & - & + 0.5_DFP * (alpha - beta) -!! +REAL(DFP) :: c1, c2, c3, c4, r_i, apb, amb, r2, apb_minus_2, apb_minus_1, & + alpha_minus_1, beta_minus_1 + +nrow = 0 +ncol = 0 +IF (alpha <= -1.0_DFP) RETURN +IF (beta <= -1.0_DFP) RETURN +IF (n < 0) RETURN + +nrow = SIZE(x) +ncol = 1 + n + +ans(1:nrow, 1) = 1.0_DFP + +IF (n .EQ. 0) RETURN + +apb = alpha + beta +apb_minus_2 = apb - 2.0_DFP +apb_minus_1 = apb - 1.0_DFP +alpha_minus_1 = alpha - 1.0_DFP +beta_minus_1 = beta - 1.0_DFP + +ans(1:nrow, 2) = (1.0_DFP + 0.5_DFP * apb) * x + 0.5_DFP * amb + DO i = 2, n - !! - r_i = real(i, kind=DFP) - !! - c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (2.0_DFP * r_i + alpha + beta) & - & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) - !! - c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & - & * (alpha + beta) * (alpha - beta) - !! - c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & - & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) - !! - ans(:, i + 1) = ((c3 + c2 * x(:)) & - & * ans(:, i) + c4 * ans(:, i - 1)) / c1 - !! + + r_i = REAL(i, kind=DFP) + r2 = 2.0_DFP * r_i + + c1 = r2 * (r_i + apb) * (r2 + apb_minus_2) + + c2 = (r2 + apb_minus_1) * (r2 + apb) * (r2 + apb_minus_2) + + c3 = (r2 + apb_minus_1) * apb * amb + + c4 = -2.0_DFP * (r_i + alpha_minus_1) * (r_i + beta_minus_1) * (r2 + apb) + + ans(1:nrow, i + 1) = ((c3 + c2 * x) * ans(1:nrow, i) & + + c4 * ans(1:nrow, i - 1)) / c1 + END DO - !! -END PROCEDURE JacobiEvalAll2 + +END PROCEDURE JacobiEvalAll2_ !---------------------------------------------------------------------------- ! @@ -606,7 +607,7 @@ !! DO i = 2, n !! - r_i = real(i, kind=DFP) + r_i = REAL(i, kind=DFP) !! c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) @@ -663,7 +664,7 @@ !! DO i = 2, n !! - r_i = real(i, kind=DFP) + r_i = REAL(i, kind=DFP) !! c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) @@ -704,7 +705,7 @@ b2 = 0.0_DFP !! DO j = n, 0, -1 - t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); + t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); b2 = b1 b1 = t END DO @@ -732,7 +733,7 @@ b2 = 0.0_DFP !! DO j = n, 0, -1 - t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); + t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); b2 = b1 b1 = t END DO @@ -778,11 +779,11 @@ !! p_1 = p !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); !! p = (a1 * x + a2) * p - a3 * p_2 !! @@ -838,11 +839,11 @@ !! p_1 = p !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); !! p = (a1 * x + a2) * p - a3 * p_2 !! @@ -894,11 +895,11 @@ !! j = REAL(ii, KIND=DFP) !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); !! p(ii + 1) = (a1 * x + a2) * p(ii) - a3 * p(ii - 1) !! @@ -944,11 +945,11 @@ !! j = REAL(ii, KIND=DFP) !! - a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); !! p(:, ii + 1) = (a1 * x + a2) * p(:, ii) - a3 * p(:, ii - 1) !! @@ -984,18 +985,18 @@ !! !! Recurrence coeff !! - Ac = j + 2 + alpha + beta; - a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); - a11 = (2 * j + 4 + alpha + beta) * x; - a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); - A1 = a10 * (a11 + a12); + Ac = j + 2 + alpha + beta; + a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); + a11 = (2 * j + 4 + alpha + beta) * x; + a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); + A1 = a10 * (a11 + a12); a20 = -(j + 2 + alpha) * (j + 2 + beta) & - & / ((j + 2) * (alpha + beta + j + 4)); - a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); - b2 = b1; - b1 = t; + & / ((j + 2) * (alpha + beta + j + 4)); + a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); + b2 = b1; + b1 = t; END DO ans = c * b1 @@ -1024,18 +1025,18 @@ !! !! Recurrence coeff !! - Ac = j + 2 + alpha + beta; - a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); - a11 = (2 * j + 4 + alpha + beta) * x; - a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); - A1 = a10 * (a11 + a12); + Ac = j + 2 + alpha + beta; + a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); + a11 = (2 * j + 4 + alpha + beta) * x; + a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); + A1 = a10 * (a11 + a12); a20 = -(j + 2 + alpha) * (j + 2 + beta) & - & / ((j + 2) * (alpha + beta + j + 4)); - a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); - b2 = b1; - b1 = t; + & / ((j + 2) * (alpha + beta + j + 4)); + a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); + b2 = b1; + b1 = t; END DO ans = c * b1 @@ -1069,17 +1070,17 @@ s = s * (alpha + beta + i + k + j) END DO !! - a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); - a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; - a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); - A1 = a10 * (a11 + a12); - a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1 = a10 * (a11 + a12); + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); a21 = (alpha + beta + 2 * i + 4 + 2 * k) & - & / (alpha + beta + 2 * i + 2 + 2 * k); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + s * coeff(i + k); - b2 = b1; - b1 = t; + & / (alpha + beta + 2 * i + 2 + 2 * k); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + s * coeff(i + k); + b2 = b1; + b1 = t; END DO ans = c * b1 @@ -1115,17 +1116,17 @@ s = s * (alpha + beta + i + k + j) END DO !! - a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); - a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; - a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); - A1 = a10 * (a11 + a12); - a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1 = a10 * (a11 + a12); + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); a21 = (alpha + beta + 2 * i + 4 + 2 * k) & - & / (alpha + beta + 2 * i + 2 + 2 * k); - A2 = a20 * a21; - t = A1 * b1 + A2 * b2 + s * coeff(i + k); - b2 = b1; - b1 = t; + & / (alpha + beta + 2 * i + 2 + 2 * k); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + s * coeff(i + k); + b2 = b1; + b1 = t; END DO ans = c * b1 @@ -1146,15 +1147,15 @@ !! Correct Gamma(n) !! IF (quadType .EQ. GaussLobatto) THEN - Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & - & * Gamma(n) + GAMMA(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & + & * GAMMA(n) END IF !! PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) !! DO jj = 0, n temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / Gamma(jj) + ans(jj) = SUM(temp) / GAMMA(jj) END DO !! END PROCEDURE JacobiTransform1 @@ -1173,8 +1174,8 @@ !! Correct Gamma(n) !! IF (quadType .EQ. GaussLobatto) THEN - Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & - & * Gamma(n) + GAMMA(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & + & * GAMMA(n) END IF !! PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) @@ -1182,7 +1183,7 @@ DO kk = 1, SIZE(coeff, 2) DO jj = 0, n temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / Gamma(jj) + ans(jj, kk) = SUM(temp) / GAMMA(jj) END DO END DO !! From 76a95b6523f504c99b9a496db7353b48a3d8877e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 16:56:02 +0900 Subject: [PATCH 087/359] Updates in JacobiPolynomialUtility --- .../src/JacobiPolynomialUtility@Methods.F90 | 13 ++++++++++--- .../src/UltrasphericalPolynomialUtility@Methods.F90 | 2 +- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index 4a5463178..5dd7e4f6d 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -502,12 +502,16 @@ c1 = r2 * (r_i + apb) * (r2 + apb_minus_2) c2 = (r2 + apb_minus_1) * (r2 + apb) * (r2 + apb_minus_2) + c2 = c2 / c1 c3 = (r2 + apb_minus_1) * apb * amb + c3 = c3 / c1 c4 = -2.0_DFP * (r_i + alpha_minus_1) * (r_i + beta_minus_1) * (r2 + apb) - ans(i + 1) = ((c3 + c2 * x) * ans(i) + c4 * ans(i - 1)) / c1 + c4 = c4 / c1 + + ans(i + 1) = (c3 + c2 * x) * ans(i) + c4 * ans(i - 1) END DO @@ -561,13 +565,16 @@ c1 = r2 * (r_i + apb) * (r2 + apb_minus_2) c2 = (r2 + apb_minus_1) * (r2 + apb) * (r2 + apb_minus_2) + c2 = c2 / c1 c3 = (r2 + apb_minus_1) * apb * amb + c3 = c3 / c1 c4 = -2.0_DFP * (r_i + alpha_minus_1) * (r_i + beta_minus_1) * (r2 + apb) + c4 = c4 / c1 - ans(1:nrow, i + 1) = ((c3 + c2 * x) * ans(1:nrow, i) & - + c4 * ans(1:nrow, i - 1)) / c1 + ans(1:nrow, i + 1) = (c3 + c2 * x) * ans(1:nrow, i) & + + c4 * ans(1:nrow, i - 1) END DO diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 index 2c5e7e9d8..441b6b7fa 100644 --- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -548,7 +548,7 @@ p(1:nrow, ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(1:nrow, ii) & & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(1:nrow, ii - 1)) & - & / r_ii + & / r_ii ans(1:nrow, ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(1:nrow, ii) & & + ans(1:nrow, ii - 1) From 57280ea7fa772886bf2217b9836f3f698a9e0336 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 17:21:10 +0900 Subject: [PATCH 088/359] Updates in LegendrePolynomialUtility --- .../src/LegendrePolynomialUtility.F90 | 49 ++++++++-- .../src/LegendrePolynomialUtility@Methods.F90 | 93 +++++++++++-------- 2 files changed, 94 insertions(+), 48 deletions(-) diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index 9c7ff28b6..e34131a32 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -546,7 +546,7 @@ END FUNCTION LegendreEval2 ! !- x: the point at which the polynomials are to be evaluated. -INTERFACE +INTERFACE LegendreEvalAll MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! Highest order of polynomial. @@ -557,12 +557,27 @@ MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans) !! Evaluate Legendre polynomial of order = 0 to n (total n+1) !! at point x END FUNCTION LegendreEvalAll1 -END INTERFACE - -INTERFACE LegendreEvalAll - MODULE PROCEDURE LegendreEvalAll1 END INTERFACE LegendreEvalAll +!---------------------------------------------------------------------------- +! LegendreEvalAll_ +!---------------------------------------------------------------------------- + +INTERFACE LegendreEvalAll_ + MODULE PURE SUBROUTINE LegendreEvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! Highest order of polynomial. + !! Polynomials from 0 to n will be computed. + REAL(DFP), INTENT(IN) :: x + !! Point of evaluation, $x \in [-1, 1]$ + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(n + 1) + !! Evaluate Legendre polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LegendreEvalAll1_ +END INTERFACE LegendreEvalAll_ + !---------------------------------------------------------------------------- ! LegendreEvalAll !---------------------------------------------------------------------------- @@ -587,7 +602,7 @@ END FUNCTION LegendreEvalAll1 ! points, N+1 number of polynomials. So ans(j, :) denotes value of all ! polynomials at jth point, and ans(:, n) denotes value of Pn at all nodes -INTERFACE +INTERFACE LegendreEvalAll MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! Highest order of polynomial. @@ -597,12 +612,26 @@ MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans) REAL(DFP) :: ans(SIZE(x), n + 1) !! shape (M,N+1) END FUNCTION LegendreEvalAll2 -END INTERFACE - -INTERFACE LegendreEvalAll - MODULE PROCEDURE LegendreEvalAll2 END INTERFACE LegendreEvalAll +!---------------------------------------------------------------------------- +! LegendreEvalAll_ +!---------------------------------------------------------------------------- + +INTERFACE LegendreEvalAll_ + MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! Highest order of polynomial. + !! Polynomials from 0 to n will be computed. + REAL(DFP), INTENT(IN) :: x(:) + !! number of points, SIZE(x)=M + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), n + 1) + !! shape (M,N+1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LegendreEvalAll2_ +END INTERFACE LegendreEvalAll_ + !---------------------------------------------------------------------------- ! LegendreMonomialExpansionAll !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index f91273474..baba400bf 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -450,70 +450,87 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreEvalAll1 +INTEGER(I4B) :: tsize +CALL LegendreEvalAll1_(n=n, x=x, ans=ans, tsize=tsize) +END PROCEDURE LegendreEvalAll1 + +!---------------------------------------------------------------------------- +! LegendreEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalAll1_ INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! + +tsize = 0 +IF (n < 0) RETURN + +tsize = n + 1 ans(1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! + +IF (n .EQ. 0) RETURN + ans(2) = x -!! + DO i = 2, n - !! + r_i = REAL(i, kind=DFP) + c1 = r_i + c2 = 2.0_DFP * r_i - 1.0_DFP + c2 = c2 / c1 + c3 = -r_i + 1.0_DFP - !! - ans(i + 1) = ((c2 * x) * ans(i) + c3 * ans(i - 1)) / c1 - !! + c3 = c3 / c1 + + ans(i + 1) = (c2 * x) * ans(i) + c3 * ans(i - 1) END DO -END PROCEDURE LegendreEvalAll1 +END PROCEDURE LegendreEvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL LegendreEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LegendreEvalAll2 + +!---------------------------------------------------------------------------- +! LegendreEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalAll2_ INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(:, 1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(:, 2) = x -!! + +nrow = 0; ncol = 0 +IF (n < 0) RETURN + +nrow = SIZE(x) +ncol = n + 1 + +ans(1:nrow, 1) = 1.0_DFP + +IF (n .EQ. 0) RETURN + +ans(1:nrow, 2) = x + DO i = 2, n - !! r_i = REAL(i, kind=DFP) c1 = r_i c2 = 2.0_DFP * r_i - 1.0_DFP + c2 = c2 / c1 + c3 = -r_i + 1.0_DFP - !! - ans(:, i + 1) = ((c2 * x) * ans(:, i) + c3 * ans(:, i - 1)) / c1 - !! + c3 = c3 / c1 + + ans(1:nrow, i + 1) = (c2 * x) * ans(1:nrow, i) + c3 * ans(1:nrow, i - 1) END DO -END PROCEDURE LegendreEvalAll2 +END PROCEDURE LegendreEvalAll2_ !---------------------------------------------------------------------------- ! From 05c0a1b18757fe25a147644a9dd7544b18d1c591 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 17:33:26 +0900 Subject: [PATCH 089/359] Updates in Chebyshev1PolynomialUtility --- .../src/Chebyshev1PolynomialUtility.F90 | 48 ++++++-- .../Chebyshev1PolynomialUtility@Methods.F90 | 110 ++++++++++-------- 2 files changed, 100 insertions(+), 58 deletions(-) diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index 10bfc0a0c..5866376d7 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -463,7 +463,7 @@ END FUNCTION Chebyshev1Eval2 !- ans(1:N+1), the values of the first N+1 Chebyshev1 polynomials at the ! point -INTERFACE +INTERFACE Chebyshev1EvalAll MODULE PURE FUNCTION Chebyshev1EvalAll1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -473,12 +473,26 @@ MODULE PURE FUNCTION Chebyshev1EvalAll1(n, x) RESULT(ans) !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) !! at point x END FUNCTION Chebyshev1EvalAll1 -END INTERFACE - -INTERFACE Chebyshev1EvalAll - MODULE PROCEDURE Chebyshev1EvalAll1 END INTERFACE Chebyshev1EvalAll +!---------------------------------------------------------------------------- +! Chebyshev1EvalAll +!---------------------------------------------------------------------------- + +INTERFACE Chebyshev1EvalAll_ + MODULE PURE SUBROUTINE Chebyshev1EvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:) + ! ans(n + 1) + !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE Chebyshev1EvalAll1_ +END INTERFACE Chebyshev1EvalAll_ + !---------------------------------------------------------------------------- ! Chebyshev1EvalAll !---------------------------------------------------------------------------- @@ -498,7 +512,7 @@ END FUNCTION Chebyshev1EvalAll1 !- ans(M,1:N+1), the values of the first N+1 Chebyshev1 polynomials at the ! points x(1:m) -INTERFACE +INTERFACE Chebyshev1EvalAll MODULE PURE FUNCTION Chebyshev1EvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -508,12 +522,26 @@ MODULE PURE FUNCTION Chebyshev1EvalAll2(n, x) RESULT(ans) !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) !! at points x END FUNCTION Chebyshev1EvalAll2 -END INTERFACE - -INTERFACE Chebyshev1EvalAll - MODULE PROCEDURE Chebyshev1EvalAll2 END INTERFACE Chebyshev1EvalAll +!---------------------------------------------------------------------------- +! ChebyshevEvalAll2_ +!---------------------------------------------------------------------------- + +INTERFACE Chebyshev1EvalAll_ + MODULE PURE SUBROUTINE Chebyshev1EvalAll2_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! several points of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), n + 1) + !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) + !! at points x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Chebyshev1EvalAll2_ +END INTERFACE Chebyshev1EvalAll_ + !---------------------------------------------------------------------------- ! Chebyshev1MonomialExpansionAll !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index 8c905ad17..22cb2e167 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -357,54 +357,68 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1EvalAll1 +INTEGER(I4B) :: tsize +CALL Chebyshev1EvalAll1_(tsize=tsize, ans=ans, n=n, x=x) +END PROCEDURE Chebyshev1EvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalAll1_ INTEGER(I4B) :: i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! + +tsize = 0 + +IF (n < 0) RETURN + +tsize = n + 1 ans(1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! + +IF (n .EQ. 0) RETURN + ans(2) = x -!! + DO i = 2, n ans(i + 1) = (2.0_DFP * x) * ans(i) - ans(i - 1) END DO -!! -END PROCEDURE Chebyshev1EvalAll1 +END PROCEDURE Chebyshev1EvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1EvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL Chebyshev1EvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE Chebyshev1EvalAll2 + +!---------------------------------------------------------------------------- +! Chebyshev1EvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalAll2_ INTEGER(I4B) :: i -!! -ans = 0.0_DFP -!! -IF (n < 0) THEN - RETURN -END IF -!! -ans(:, 1) = 1.0_DFP -!! -IF (n .EQ. 0) THEN - RETURN -END IF -!! -ans(:, 2) = x -!! + +nrow = 0 +ncol = 0 + +IF (n < 0) RETURN + +nrow = SIZE(x) +ncol = n + 1 + +ans(1:nrow, 1) = 1.0_DFP + +IF (n .EQ. 0) RETURN + +ans(1:nrow, 2) = x + DO i = 2, n - ans(:, i + 1) = (2.0_DFP * x) * ans(:, i) - ans(:, i - 1) + ans(1:nrow, i + 1) = (2.0_DFP * x) * ans(1:nrow, i) - ans(1:nrow, i - 1) END DO -!! -END PROCEDURE Chebyshev1EvalAll2 + +END PROCEDURE Chebyshev1EvalAll2_ !---------------------------------------------------------------------------- ! Chebyshev1MonomialExpansionAll @@ -693,9 +707,9 @@ xx = 2.0_DFP * x !! DO i = n - 1, 0, -1 - t = xx * b1 - b2 + (i + 1) * coeff(i + 1); - b2 = b1; - b1 = t; + t = xx * b1 - b2 + (i + 1) * coeff(i + 1); + b2 = b1; + b1 = t; END DO !! ans = b1 @@ -714,9 +728,9 @@ xx = 2.0_DFP * x !! DO i = n - 1, 0, -1 - t = xx * b1 - b2 + (i + 1) * coeff(i + 1); - b2 = b1; - b1 = t; + t = xx * b1 - b2 + (i + 1) * coeff(i + 1); + b2 = b1; + b1 = t; END DO !! ans = b1 @@ -750,9 +764,9 @@ DO i = n - k, 0, -1 j = REAL(i, KIND=DFP) t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & - & / (j + 2) * b2 + (j + k) * coeff(i + k); - b2 = b1; - b1 = t; + & / (j + 2) * b2 + (j + k) * coeff(i + k); + b2 = b1; + b1 = t; END DO !! ans = s * b1 @@ -788,9 +802,9 @@ DO i = n - k, 0, -1 j = REAL(i, KIND=DFP) t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & - & / (j + 2) * b2 + (j + k) * coeff(i + k); - b2 = b1; - b1 = t; + & / (j + 2) * b2 + (j + k) * coeff(i + k); + b2 = b1; + b1 = t; END DO !! ans = s * b1 @@ -1000,7 +1014,7 @@ PURE SUBROUTINE Chebyshev1DMatrixGL2(n, x, D) REAL(DFP) :: rn, j1, j2 INTEGER(I4B) :: ii, jj, nb2 !! - nb2 = int(n / 2) + nb2 = INT(n / 2) rn = REAL(n, KIND=DFP) !! D = 0.0_DFP @@ -1056,7 +1070,7 @@ PURE SUBROUTINE Chebyshev1DMatrixG(n, x, D) !! main !! rn = REAL(n, KIND=DFP) - nb2 = int(n / 2) + nb2 = INT(n / 2) D = 0.0_DFP !! DO jj = 0, n @@ -1107,7 +1121,7 @@ PURE SUBROUTINE Chebyshev1DMatrixG2(n, x, D) !! main !! rn = REAL(n, KIND=DFP) - nb2 = int(n / 2) + nb2 = INT(n / 2) D = 0.0_DFP !! J = Chebyshev1GradientEval(n=n + 1, x=x) From 298ccd7a7bbf87355035c0202743a595fd28483f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 17:45:49 +0900 Subject: [PATCH 090/359] Updates in LobattoPolynomialUtility --- .../src/LegendrePolynomialUtility.F90 | 1 + .../src/LobattoPolynomialUtility.F90 | 44 ++++++++++---- .../src/LobattoPolynomialUtility@Methods.F90 | 59 +++++++++++++++---- 3 files changed, 81 insertions(+), 23 deletions(-) diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index e34131a32..b540a4d00 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -45,6 +45,7 @@ MODULE LegendrePolynomialUtility PUBLIC :: LegendreQuadrature PUBLIC :: LegendreEval PUBLIC :: LegendreEvalAll +PUBLIC :: LegendreEvalAll_ PUBLIC :: LegendreMonomialExpansionAll PUBLIC :: LegendreMonomialExpansion PUBLIC :: LegendreGradientEvalAll diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index 9d7e15c4e..0b7274878 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -173,7 +173,7 @@ END FUNCTION LobattoEval2 !- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point ! X. -INTERFACE +INTERFACE LobattoEvalAll MODULE PURE FUNCTION LobattoEvalAll1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x @@ -181,12 +181,24 @@ MODULE PURE FUNCTION LobattoEvalAll1(n, x) RESULT(ans) !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) !! at point x END FUNCTION LobattoEvalAll1 -END INTERFACE - -INTERFACE LobattoEvalAll - MODULE PROCEDURE LobattoEvalAll1 END INTERFACE LobattoEvalAll +!---------------------------------------------------------------------------- +! LobattoEvalAll_ +!---------------------------------------------------------------------------- + +INTERFACE LobattoEvalAll_ + MODULE PURE SUBROUTINE LobattoEvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(n + 1) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LobattoEvalAll1_ +END INTERFACE LobattoEvalAll_ + !---------------------------------------------------------------------------- ! LobattoEvalAll !---------------------------------------------------------------------------- @@ -206,7 +218,7 @@ END FUNCTION LobattoEvalAll1 !- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point ! X. -INTERFACE +INTERFACE LobattoEvalAll MODULE PURE FUNCTION LobattoEvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) @@ -214,12 +226,24 @@ MODULE PURE FUNCTION LobattoEvalAll2(n, x) RESULT(ans) !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) !! at point x END FUNCTION LobattoEvalAll2 -END INTERFACE - -INTERFACE LobattoEvalAll - MODULE PROCEDURE LobattoEvalAll2 END INTERFACE LobattoEvalAll +!---------------------------------------------------------------------------- +! LobattoEvalAll_ +!---------------------------------------------------------------------------- + +INTERFACE LobattoEvalAll_ + MODULE PURE SUBROUTINE LobattoEvalAll2_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(x), n + 1) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LobattoEvalAll2_ +END INTERFACE LobattoEvalAll_ + !---------------------------------------------------------------------------- ! LobattoKernelEvalAll !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 index 2278c25d1..59c22d3ea 100644 --- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -117,53 +117,86 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LobattoEvalAll1 +INTEGER(I4B) :: tsize +CALL LobattoEvalAll1_(n=n, x=x, ans=ans, tsize=tsize) +END PROCEDURE LobattoEvalAll1 + +!---------------------------------------------------------------------------- +! LobattoEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEvalAll1_ REAL(DFP) :: avar, m REAL(DFP) :: p(n + 1) INTEGER(I4B) :: ii - !! + +tsize = n + 1 + SELECT CASE (n) CASE (0) ans(1) = 0.5_DFP * (1.0_DFP - x) + CASE (1) ans(1) = 0.5_DFP * (1.0_DFP - x) ans(2) = 0.5_DFP * (1.0_DFP + x) + CASE DEFAULT ans(1) = 0.5_DFP * (1.0_DFP - x) ans(2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) + + CALL LegendreEvalAll_(n=n, x=x, ans=p, tsize=ii) + DO ii = 1, n - 1 m = REAL(ii - 1, KIND=DFP) avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - ans(2 + ii) = avar * (p(ii + 2) - p(ii)) + ans(ii + 2) = avar * (p(ii + 2) - p(ii)) END DO + END SELECT -END PROCEDURE LobattoEvalAll1 +END PROCEDURE LobattoEvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE LobattoEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL LobattoEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LobattoEvalAll2 + +!---------------------------------------------------------------------------- +! LobattoEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEvalAll2_ REAL(DFP) :: avar, m REAL(DFP) :: p(SIZE(x), n + 1) -INTEGER(I4B) :: ii +INTEGER(I4B) :: ii, aint, bint + +nrow = SIZE(x) +ncol = 1 + n + SELECT CASE (n) CASE (0) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x) + CASE (1) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) + ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x) + ans(1:nrow, 2) = 0.5_DFP * (1.0_DFP + x) + CASE DEFAULT - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) + ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x) + ans(1:nrow, 2) = 0.5_DFP * (1.0_DFP + x) + CALL LegendreEvalAll_(n=n, x=x, ans=p, nrow=aint, ncol=bint) + DO ii = 1, n - 1 m = REAL(ii - 1, KIND=DFP) avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) - ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) + ans(1:nrow, 2 + ii) = avar * (p(1:nrow, ii + 2) - p(1:nrow, ii)) END DO + END SELECT -END PROCEDURE LobattoEvalAll2 +END PROCEDURE LobattoEvalAll2_ !---------------------------------------------------------------------------- ! LobattoKernelEvalAll From a49c4fda7e17406d6820dcc2b5085f90811eb536 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 18:35:23 +0900 Subject: [PATCH 091/359] Updates in UnscaledLobattoPolynomialUtility --- .../src/UnscaledLobattoPolynomialUtility.F90 | 46 +++++++++++---- ...scaledLobattoPolynomialUtility@Methods.F90 | 59 +++++++++++++++---- 2 files changed, 82 insertions(+), 23 deletions(-) diff --git a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 index d766d0344..1afcd3653 100644 --- a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 @@ -171,7 +171,7 @@ END FUNCTION UnscaledLobattoEval2 !- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at ! the point X. -INTERFACE +INTERFACE UnscaledLobattoEvalAll MODULE PURE FUNCTION UnscaledLobattoEvalAll1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x @@ -179,12 +179,24 @@ MODULE PURE FUNCTION UnscaledLobattoEvalAll1(n, x) RESULT(ans) !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) !! at point x END FUNCTION UnscaledLobattoEvalAll1 -END INTERFACE - -INTERFACE UnscaledLobattoEvalAll - MODULE PROCEDURE UnscaledLobattoEvalAll1 END INTERFACE UnscaledLobattoEvalAll +!---------------------------------------------------------------------------- +! UnscaledLobattoEvalAll_ +!---------------------------------------------------------------------------- + +INTERFACE UnscaledLobattoEvalAll_ + MODULE PURE SUBROUTINE UnscaledLobattoEvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(n + 1) + !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE UnscaledLobattoEvalAll1_ +END INTERFACE UnscaledLobattoEvalAll_ + !---------------------------------------------------------------------------- ! UnscaledLobattoEvalAll !---------------------------------------------------------------------------- @@ -205,7 +217,8 @@ END FUNCTION UnscaledLobattoEvalAll1 !- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at ! the point X. -INTERFACE +INTERFACE UnscaledLobattoEvalAll + MODULE PURE FUNCTION UnscaledLobattoEvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) @@ -213,12 +226,25 @@ MODULE PURE FUNCTION UnscaledLobattoEvalAll2(n, x) RESULT(ans) !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) !! at point x END FUNCTION UnscaledLobattoEvalAll2 -END INTERFACE - -INTERFACE UnscaledLobattoEvalAll - MODULE PROCEDURE UnscaledLobattoEvalAll2 END INTERFACE UnscaledLobattoEvalAll +!---------------------------------------------------------------------------- +! UnscaledLobattoEvalAll_ +!---------------------------------------------------------------------------- + +INTERFACE UnscaledLobattoEvalAll_ + + MODULE PURE SUBROUTINE UnscaledLobattoEvalAll2_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), n + 1) + !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) + !! at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE UnscaledLobattoEvalAll2_ +END INTERFACE UnscaledLobattoEvalAll_ + !---------------------------------------------------------------------------- ! UnscaledLobattoMonomialExpansionAll !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 index 9092e9e12..1b4ef8182 100644 --- a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 @@ -118,54 +118,87 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE UnscaledLobattoEvalAll1 +INTEGER(I4B) :: tsize +CALL UnscaledLobattoEvalAll1_(n=n, x=x, ans=ans, tsize=tsize) +END PROCEDURE UnscaledLobattoEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEvalAll1_ REAL(DFP) :: avar, m REAL(DFP) :: p(n + 1) INTEGER(I4B) :: ii - !! + +tsize = n + 1 + SELECT CASE (n) CASE (0) ans(1) = 0.5_DFP * (1.0_DFP - x) + CASE (1) ans(1) = 0.5_DFP * (1.0_DFP - x) ans(2) = 0.5_DFP * (1.0_DFP + x) + CASE DEFAULT ans(1) = 0.5_DFP * (1.0_DFP - x) ans(2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) + + CALL LegendreEvalAll_(n=n, x=x, ans=p, tsize=ii) + DO ii = 1, n - 1 m = REAL(ii - 1, KIND=DFP) avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) ans(2 + ii) = avar * (p(ii + 2) - p(ii)) END DO + END SELECT -END PROCEDURE UnscaledLobattoEvalAll1 +END PROCEDURE UnscaledLobattoEvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE UnscaledLobattoEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL UnscaledLobattoEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE UnscaledLobattoEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEvalAll2_ REAL(DFP) :: avar, m REAL(DFP) :: p(SIZE(x), n + 1) -INTEGER(I4B) :: ii - !! +INTEGER(I4B) :: ii, aint, bint + +nrow = SIZE(x) +ncol = n + 1 + SELECT CASE (n) CASE (0) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x) + CASE (1) - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) + ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x) + ans(1:nrow, 2) = 0.5_DFP * (1.0_DFP + x) + CASE DEFAULT - ans(:, 1) = 0.5_DFP * (1.0_DFP - x) - ans(:, 2) = 0.5_DFP * (1.0_DFP + x) - p = LegendreEvalAll(n=n, x=x) + ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x) + ans(1:nrow, 2) = 0.5_DFP * (1.0_DFP + x) + + CALL LegendreEvalAll_(n=n, x=x, ans=p, nrow=aint, ncol=bint) + DO ii = 1, n - 1 m = REAL(ii - 1, KIND=DFP) avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) - ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) + ans(1:nrow, 2 + ii) = avar * (p(1:nrow, ii + 2) - p(1:nrow, ii)) END DO + END SELECT -END PROCEDURE UnscaledLobattoEvalAll2 +END PROCEDURE UnscaledLobattoEvalAll2_ !---------------------------------------------------------------------------- ! From 36870bc97a0cd33875515073912a92952a83a276 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 18:46:54 +0900 Subject: [PATCH 092/359] Updates in Polynomials --- .../src/JacobiPolynomialUtility.F90 | 1 + .../src/LobattoPolynomialUtility.F90 | 1 + .../src/OrthogonalPolynomialUtility.F90 | 45 ++++++++++++++++--- .../src/UnscaledLobattoPolynomialUtility.F90 | 1 + .../OrthogonalPolynomialUtility@Methods.F90 | 23 ++++++++++ 5 files changed, 65 insertions(+), 6 deletions(-) diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index b5475ce82..c0d12a71d 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -44,6 +44,7 @@ MODULE JacobiPolynomialUtility PUBLIC :: JacobiZeros PUBLIC :: JacobiQuadrature PUBLIC :: JacobiEvalAll +PUBLIC :: JacobiEvalAll_ PUBLIC :: JacobiEval PUBLIC :: JacobiEvalSum PUBLIC :: JacobiGradientEval diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index 0b7274878..02bd6c6d7 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -29,6 +29,7 @@ MODULE LobattoPolynomialUtility PUBLIC :: LobattoZeros PUBLIC :: LobattoEval PUBLIC :: LobattoEvalAll +PUBLIC :: LobattoEvalAll_ PUBLIC :: LobattoKernelEvalAll PUBLIC :: LobattoKernelEvalAll_ PUBLIC :: LobattoKernelGradientEvalAll diff --git a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 index 5e4783126..f5b8fd8b9 100644 --- a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 @@ -23,6 +23,7 @@ MODULE OrthogonalPolynomialUtility PUBLIC :: ChebClenshaw PUBLIC :: JacobiMatrix PUBLIC :: EvalAllOrthopol +PUBLIC :: EvalAllOrthopol_ PUBLIC :: GradientEvalAllOrthopol !---------------------------------------------------------------------------- @@ -160,7 +161,7 @@ END SUBROUTINE JacobiMatrix_1 INTERFACE MODULE PURE FUNCTION EvalAllOrthopol(n, x, orthopol, alpha, beta, & - & lambda) RESULT(ans) + lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: x(:) @@ -192,11 +193,8 @@ END FUNCTION EvalAllOrthopol !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION GradientEvalAllOrthopol( & - & n, & - & x, & - & orthopol, & - & alpha, beta, lambda) RESULT(ans) + MODULE PURE FUNCTION GradientEvalAllOrthopol(n, x, orthopol, alpha, & + beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: x(:) @@ -223,4 +221,39 @@ MODULE PURE FUNCTION GradientEvalAllOrthopol( & END FUNCTION GradientEvalAllOrthopol END INTERFACE +!---------------------------------------------------------------------------- +! EvalAllOrthopol_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE EvalAllOrthopol_(n, x, orthopol, alpha, beta, & + lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! points of evaluation + INTEGER(I4B), INTENT(IN) :: orthopol + !! orthogonal polynomial family + !! Legendre + !! Jacobi + !! Lobatto + !! Chebyshev + !! Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha1 needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta1 is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda1 is needed when orthopol1 is "Ultraspherical" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(x), n + 1) + !! The number of rows in ans is equal to the number of points. + !! The number of columns are equal to the orthogonal + !! polynomials from order = 0 to n + !! Therefore, jth column is denotes the value of jth polynomial + !! at all the points. + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE EvalAllOrthopol_ +END INTERFACE + END MODULE OrthogonalPolynomialUtility diff --git a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 index 1afcd3653..95fec7495 100644 --- a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 @@ -29,6 +29,7 @@ MODULE UnscaledLobattoPolynomialUtility PUBLIC :: UnscaledLobattoZeros PUBLIC :: UnscaledLobattoEval PUBLIC :: UnscaledLobattoEvalAll +PUBLIC :: UnscaledLobattoEvalAll_ PUBLIC :: UnscaledLobattoMonomialExpansionAll PUBLIC :: UnscaledLobattoMonomialExpansion PUBLIC :: UnscaledLobattoGradientEvalAll diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index 207d2760c..0604f96bb 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -135,6 +135,29 @@ END SELECT END PROCEDURE EvalAllOrthopol +!---------------------------------------------------------------------------- +! EvalAllOrthopol +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EvalAllOrthopol_ +SELECT CASE (orthopol) +CASE (Jacobi) + CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, nrow=nrow, & + ncol=ncol) +CASE (Ultraspherical) + CALL UltraSphericalEvalAll_(n=n, lambda=lambda, x=x, ans=ans, nrow=nrow, & + ncol=ncol) +CASE (Legendre) + CALL LegendreEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +CASE (Chebyshev) + CALL Chebyshev1EvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +CASE (Lobatto) + CALL LobattoEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +CASE (UnscaledLobatto) + CALL UnscaledLobattoEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END SELECT +END PROCEDURE EvalAllOrthopol_ + !---------------------------------------------------------------------------- ! GradientEvalAllOrthopol !---------------------------------------------------------------------------- From b92d7ea2b6ad5fec43bb7e53b691f83407323306 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 18:50:38 +0900 Subject: [PATCH 093/359] Update in LineInterpolationUtility --- .../src/LineInterpolationUtility@Methods.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index d77884a6d..5bd0dddf5 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -30,7 +30,8 @@ FromUnitLine2BiUnitLine USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol, & - EvalAllOrthopol + EvalAllOrthopol, & + EvalAllOrthopol_ USE InputUtility, ONLY: Input @@ -784,12 +785,10 @@ END SUBROUTINE handle_error RETURN END IF -nrow = SIZE(xij, 2) -ncol = nrow - -ans(1:nrow, 1:ncol) = EvalAllOrthopol(n=order, x=xij(1, :), & - orthopol=basisType, & - alpha=alpha, beta=beta, lambda=lambda) +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_ From 017253cf1a9408349f254e120c8bd9c54baec869 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 19:40:45 +0900 Subject: [PATCH 094/359] Updates in QuadrangleInterpolationUtility --- .../src/QuadrangleInterpolationUtility.F90 | 165 ++++++++++++++++-- .../src/TriangleInterpolationUtility.F90 | 86 +++++++-- ...QuadrangleInterpolationUtility@Methods.F90 | 146 +++++++++++----- ...erpolationUtility@LagrangeBasisMethods.F90 | 52 +++++- 4 files changed, 356 insertions(+), 93 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 87e76a502..dde12a00e 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -27,6 +27,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: InterpolationPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle_ PUBLIC :: LagrangeCoeff_Quadrangle +PUBLIC :: LagrangeCoeff_Quadrangle_ PUBLIC :: Dubiner_Quadrangle PUBLIC :: Dubiner_Quadrangle_ PUBLIC :: TensorProdBasis_Quadrangle @@ -659,6 +660,25 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans) END FUNCTION LagrangeCoeff_Quadrangle1 END INTERFACE LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle_ +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Quadrangle1_ +END INTERFACE LagrangeCoeff_Quadrangle_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- @@ -679,6 +699,27 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & END FUNCTION LagrangeCoeff_Quadrangle2 END INTERFACE LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle_ +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Quadrangle2_ +END INTERFACE LagrangeCoeff_Quadrangle_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- @@ -698,18 +739,34 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle3(order, i, v, ipiv) RESULT(ans) END FUNCTION LagrangeCoeff_Quadrangle3 END INTERFACE LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Quadrangle3_ +END INTERFACE LagrangeCoeff_Quadrangle_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle4( & - & order, & - & xij, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION LagrangeCoeff_Quadrangle4(order, xij, basisType, alpha, & + beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial REAL(DFP), INTENT(IN) :: xij(:, :) @@ -732,23 +789,44 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle4( & END FUNCTION LagrangeCoeff_Quadrangle4 END INTERFACE LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle4_(order, xij, basisType, & + alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Quadrangle4_ +END INTERFACE LagrangeCoeff_Quadrangle_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle5( & - & p, & - & q, & - & xij, & - & basisType1, & - & basisType2, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2) RESULT(ans) + MODULE FUNCTION LagrangeCoeff_Quadrangle5(p, q, xij, basisType1, & + basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order of polynomial in x direction INTEGER(I4B), INTENT(IN) :: q @@ -788,6 +866,55 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle5( & END FUNCTION LagrangeCoeff_Quadrangle5 END INTERFACE LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle5_(p, q, xij, basisType1, & + basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p + !! order of polynomial in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of polynomial in y direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basisType in x direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basisType in y direction + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Quadrangle5_ +END INTERFACE LagrangeCoeff_Quadrangle_ + !---------------------------------------------------------------------------- ! DubinerPolynomial !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index c944ba760..43a0322db 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -28,6 +28,7 @@ MODULE TriangleInterpolationUtility PUBLIC :: InterpolationPoint_Triangle PUBLIC :: InterpolationPoint_Triangle_ PUBLIC :: LagrangeCoeff_Triangle +PUBLIC :: LagrangeCoeff_Triangle_ PUBLIC :: Dubiner_Triangle PUBLIC :: OrthogonalBasis_Triangle @@ -40,6 +41,7 @@ MODULE TriangleInterpolationUtility PUBLIC :: HeirarchicalBasisGradient_Triangle PUBLIC :: LagrangeEvalAll_Triangle + PUBLIC :: LagrangeGradientEvalAll_Triangle PUBLIC :: QuadraturePoint_Triangle PUBLIC :: IJ2VEFC_Triangle @@ -567,6 +569,25 @@ MODULE FUNCTION LagrangeCoeff_Triangle1(order, i, xij) RESULT(ans) END FUNCTION LagrangeCoeff_Triangle1 END INTERFACE LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle_ +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Triangle_ + MODULE SUBROUTINE LagrangeCoeff_Triangle1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Triangle1_ +END INTERFACE LagrangeCoeff_Triangle_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- @@ -592,6 +613,29 @@ MODULE FUNCTION LagrangeCoeff_Triangle2(order, i, v, isVandermonde) & END FUNCTION LagrangeCoeff_Triangle2 END INTERFACE LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle_ +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Triangle_ + MODULE SUBROUTINE LagrangeCoeff_Triangle2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue, the value of isVandermonde + !! is not used in thesubroutine _ + REAL(DFP), INTENT(INOUT) :: ans(:) + ! ans(SIZE(v, 1)) + !! coefficients of ith Lagrange polynomial + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Triangle2_ +END INTERFACE LagrangeCoeff_Triangle_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- @@ -615,6 +659,27 @@ MODULE FUNCTION LagrangeCoeff_Triangle3(order, i, v, ipiv) RESULT(ans) END FUNCTION LagrangeCoeff_Triangle3 END INTERFACE LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Triangle_ + MODULE SUBROUTINE LagrangeCoeff_Triangle3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Triangle3_ +END INTERFACE LagrangeCoeff_Triangle_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- @@ -1313,14 +1378,8 @@ END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1 ! summary: Evaluate all Lagrange polynomial of order n at single points INTERFACE LagrangeEvalAll_Triangle - MODULE FUNCTION LagrangeEvalAll_Triangle1( & - & order, & - & x, & - & xij, & - & refTriangle, & - & coeff, & - & firstCall, & - & basisType) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Triangle1(order, x, xij, refTriangle, & + coeff, firstCall, basisType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(2) @@ -1355,15 +1414,8 @@ END FUNCTION LagrangeEvalAll_Triangle1 ! summary: Evaluate all Lagrange polynomials of order n at several points INTERFACE LagrangeEvalAll_Triangle - MODULE FUNCTION LagrangeEvalAll_Triangle2( & - & order, & - & x, & - & xij, & - & refTriangle, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Triangle2(order, x, xij, refTriangle, & + coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index e5930bae1..fb136973f 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -801,101 +801,151 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Quadrangle1 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Quadrangle1_(order=order, i=i, xij=xij, ans=ans, & + tsize=tsize) +END PROCEDURE LagrangeCoeff_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle1_ REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP + +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 GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle1 +CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle1_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Quadrangle2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Quadrangle2_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +MODULE PROCEDURE LagrangeCoeff_Quadrangle2_ REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B + +tsize = SIZE(v, 1) + +vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle2 +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle2_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Quadrangle3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Quadrangle3_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff_Quadrangle3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle3_ +INTEGER(I4B) :: info +tsize = SIZE(v, 1) +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle3_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Quadrangle4 +INTEGER(I4B) :: 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, ii, jj, indx -REAL(DFP) :: ans1(SIZE(xij, 2), 0:order) -REAL(DFP) :: ans2(SIZE(xij, 2), 0:order) -basisType0 = input(default=Monomial, option=basisType) +nrow = SIZE(xij, 2) +ncol = nrow + +basisType0 = Input(default=Monomial, option=basisType) IF (basisType0 .EQ. Heirarchical) THEN - ans = HeirarchicalBasis_Quadrangle2(p=order, q=order, xij=xij) -ELSE - ans = TensorProdBasis_Quadrangle1( & - & p=order, & - & q=order, & - & xij=xij, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) + ans(1:nrow, 1:ncol) = HeirarchicalBasis_Quadrangle2(p=order, q=order, & + xij=xij) + CALL GetInvMat(ans(1:nrow, 1:ncol)) + RETURN END IF -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Quadrangle4 +ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=order, q=order, & + xij=xij, basisType1=basisType0, basisType2=basisType0, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & + beta2=beta, lambda2=lambda) + +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) :: ii, jj, kk, indx, basisType(2) -REAL(DFP) :: ans1(SIZE(xij, 2), 0:p) -REAL(DFP) :: ans2(SIZE(xij, 2), 0:q) -basisType(1) = input(default=Monomial, option=basisType1) -basisType(2) = input(default=Monomial, option=basisType2) +nrow = SIZE(xij, 2) +ncol = nrow + +basisType(1) = Input(default=Monomial, option=basisType1) +basisType(2) = Input(default=Monomial, option=basisType2) IF (ALL(basisType .EQ. Heirarchical)) THEN - ans = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij) -ELSE - ans = TensorProdBasis_Quadrangle1( & - & p=p, & - & q=q, & - & xij=xij, & - & basisType1=basisType(1), & - & basisType2=basisType(2), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2) + ans(1:nrow, 1:ncol) = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij) + CALL GetInvMat(ans(1:nrow, 1:ncol)) + RETURN END IF -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Quadrangle5 +ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=p, q=q, xij=xij, & + basisType1=basisType(1), alpha1=alpha1, beta1=beta1, lambda1=lambda1, & + basisType2=basisType(2), alpha2=alpha2, beta2=beta2, lambda2=lambda2) + +CALL GetInvMat(ans(1:nrow, 1:ncol)) + +END PROCEDURE LagrangeCoeff_Quadrangle5_ !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index d71b20c3e..1a2d6fb66 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -81,42 +81,76 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Triangle1 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Triangle1_(order=order, i=i, xij=xij, ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Triangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle1_ REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv INTEGER(I4B) :: info, nrow, ncol -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +tsize = SIZE(xij, 2) + +ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elemopt%Triangle, & ans=V, nrow=nrow, ncol=ncol) CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Triangle1 +CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle1_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Triangle2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Triangle2_(order=order, i=i, v=v, & + isVandermonde=isVandermonde, ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Triangle2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle2_ REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +tsize = SIZE(v, 1) +vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Triangle2 +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle2_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Triangle3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Triangle3_(order=order, i=i, v=v, ipiv=ipiv, ans=ans, & + tsize=tsize) END PROCEDURE LagrangeCoeff_Triangle3 +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle3_ +INTEGER(I4B) :: info + +tsize = SIZE(v, 1) +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle3_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- From 9ab82d85504c9718ec020ecdb92d7090f751bb4d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 20:01:48 +0900 Subject: [PATCH 095/359] Updates in TetrahedronInterpolationUtility --- .../src/TetrahedronInterpolationUtility.F90 | 93 +++++++++++++ ...etrahedronInterpolationUtility@Methods.F90 | 122 ++++++++++++------ 2 files changed, 177 insertions(+), 38 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index f34b1f69e..8e933e7ae 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -521,6 +521,25 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron1(order, i, xij) RESULT(ans) END FUNCTION LagrangeCoeff_Tetrahedron1 END INTERFACE LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron_ + MODULE SUBROUTINE LagrangeCoeff_Tetrahedron1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Tetrahedron1_ +END INTERFACE LagrangeCoeff_Tetrahedron_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- @@ -541,6 +560,28 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron2(order, i, v, isVandermonde) & END FUNCTION LagrangeCoeff_Tetrahedron2 END INTERFACE LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron_ + MODULE SUBROUTINE LagrangeCoeff_Tetrahedron2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP), INTENT(INOUT) :: ans(:) + ! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Tetrahedron2_ +END INTERFACE LagrangeCoeff_Tetrahedron_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- @@ -560,6 +601,27 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron3(order, i, v, ipiv) RESULT(ans) END FUNCTION LagrangeCoeff_Tetrahedron3 END INTERFACE LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron_ + MODULE SUBROUTINE LagrangeCoeff_Tetrahedron3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Tetrahedron3_ +END INTERFACE LagrangeCoeff_Tetrahedron_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- @@ -594,6 +656,37 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron4( & END FUNCTION LagrangeCoeff_Tetrahedron4 END INTERFACE LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron_ + MODULE SUBROUTINE LagrangeCoeff_Tetrahedron4_(order, xij, basisType, & + refTetrahedron, alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi (Dubiner) + !! Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT * default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Tetrahedron4_ +END INTERFACE LagrangeCoeff_Tetrahedron_ + !---------------------------------------------------------------------------- ! Isaac_Tetrahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index 7c0725313..e2bb7a132 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -485,81 +485,127 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Tetrahedron1 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Tetrahedron1_(order=order, i=i, xij=xij, ans=ans, & + tsize=tsize) +END PROCEDURE LagrangeCoeff_Tetrahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron1_ REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP + +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=Tetrahedron) CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Tetrahedron1 +CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron1_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Tetrahedron2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Tetrahedron2_(order=order, i=i, v=v, & + isVandermonde=.TRUE., ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron2_ REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B + +tsize = SIZE(v, 1) + +vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Tetrahedron2 +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron2_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Tetrahedron3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Tetrahedron3_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff_Tetrahedron3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron3_ +INTEGER(I4B) :: info + +tsize = SIZE(v, 1) + +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron3_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Tetrahedron4 +INTEGER(I4B) :: nrow, ncol + +CALL LagrangeCoeff_Tetrahedron4_(order=order, xij=xij, basisType=basisType, & + refTetrahedron=refTetrahedron, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE LagrangeCoeff_Tetrahedron4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron4_ INTEGER(I4B) :: basisType0 +CHARACTER(:), ALLOCATABLE :: aname + basisType0 = input(default=Monomial, option=basisType) +nrow = SIZE(xij, 2) +ncol = nrow SELECT CASE (basisType0) CASE (Monomial) - ans = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron) + ans(1:nrow, 1:ncol) = LagrangeVandermonde(order=order, xij=xij, & + elemType=Tetrahedron) + + CALL LagrangeVandermonde_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol, elemType=Tetrahedron) + CASE (Heirarchical) - IF (PRESENT(refTetrahedron)) THEN - ans = HeirarchicalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron=refTetrahedron & - & ) - ELSE - ans = HeirarchicalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron="UNIT" & - & ) - END IF + aname = Input(default="UNIT", option=refTetrahedron) + + ans(1:nrow, 1:ncol) = HeirarchicalBasis_Tetrahedron(order=order, xij=xij, & + refTetrahedron=aname) + CASE DEFAULT - IF (PRESENT(refTetrahedron)) THEN - ans = OrthogonalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron=refTetrahedron & - & ) - ELSE - ans = OrthogonalBasis_Tetrahedron(& - & order=order, & - & xij=xij, & - & refTetrahedron="UNIT" & - & ) - END IF + aname = Input(default="UNIT", option=refTetrahedron) + + ans(1:nrow, 1:ncol) = OrthogonalBasis_Tetrahedron(order=order, & + xij=xij, refTetrahedron=refTetrahedron) + END SELECT -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Tetrahedron4 +CALL GetInvMat(ans(1:nrow, 1:ncol)) + +END PROCEDURE LagrangeCoeff_Tetrahedron4_ !---------------------------------------------------------------------------- ! Isaac_Tetrahedron From d7f3f8e7f545c6d9d749f380aca7c26f902bedba Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Jun 2024 23:53:17 +0900 Subject: [PATCH 096/359] Updates in HexahedronInterpolationUtility --- .../src/HexahedronInterpolationUtility.F90 | 149 +++++++++- ...HexahedronInterpolationUtility@Methods.F90 | 260 ++++++++---------- 2 files changed, 265 insertions(+), 144 deletions(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index ac4086a52..a780400f0 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -820,6 +820,27 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron1(order, i, xij) RESULT(ans) END FUNCTION LagrangeCoeff_Hexahedron1 END INTERFACE LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Hexahedron_ + MODULE SUBROUTINE LagrangeCoeff_Hexahedron1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! interpolation points in xij format + !! number of rows in xij is 3 + !! number of columns should be equal to the number degree of freedom + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Hexahedron1_ +END INTERFACE LagrangeCoeff_Hexahedron_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Hexahedron !---------------------------------------------------------------------------- @@ -844,6 +865,28 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron2(order, i, v, isVandermonde) & END FUNCTION LagrangeCoeff_Hexahedron2 END INTERFACE LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Hexahedron_ + MODULE SUBROUTINE LagrangeCoeff_Hexahedron2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Hexahedron2_ +END INTERFACE LagrangeCoeff_Hexahedron_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Hexahedron !---------------------------------------------------------------------------- @@ -867,6 +910,27 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron3(order, i, v, ipiv) RESULT(ans) END FUNCTION LagrangeCoeff_Hexahedron3 END INTERFACE LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Hexahedron_ + MODULE SUBROUTINE LagrangeCoeff_Hexahedron3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + ! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Hexahedron3_ +END INTERFACE LagrangeCoeff_Hexahedron_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Hexahedron !---------------------------------------------------------------------------- @@ -903,6 +967,35 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron4(order, xij, basisType, & END FUNCTION LagrangeCoeff_Hexahedron4 END INTERFACE LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Hexahedron_ + MODULE SUBROUTINE LagrangeCoeff_Hexahedron4_(order, xij, basisType, & + refHexahedron, alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials, Jacobi, Legendre, Chebyshev, Ultraspherical, Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Hexahedron4_ +END INTERFACE LagrangeCoeff_Hexahedron_ + !---------------------------------------------------------------------------- ! LagrangeCoeff_Hexahedron !---------------------------------------------------------------------------- @@ -925,6 +1018,54 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron5(p, q, r, xij, basisType1, & !! These are interpolation points in xij format, size(xij,2) INTEGER(I4B), INTENT(IN) :: basisType1 !! basis type in x direction + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basis type in y direction + INTEGER(I4B), INTENT(IN) :: basisType3 + !! basis type in z direction + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! This parameter is needed when basisType1 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! This parameter is needed when basisType1 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! This parameter is needed when basisType1 is Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! This parameter is needed when basisType2 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! This parameter is needed when basisType2 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! This parameter is needed when basisType2 is Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! This parameter is needed when basisType3 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! This parameter is needed when basisType3 is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! This parameter is needed when basisType3 is Ultraspherical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron + !! UNIT + !! BIUNIT + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron5 +END INTERFACE LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Hexahedron_ + MODULE SUBROUTINE LagrangeCoeff_Hexahedron5_(p, q, r, xij, basisType1, & + basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, alpha3, beta3, lambda3, refHexahedron, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p + !! order of polynomial in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of polynomial in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order of polynomial in z direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! These are interpolation points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basis type in x direction !! Monomials !! Jacobi !! Legendre @@ -968,10 +1109,12 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron5(p, q, r, xij, basisType1, & CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron !! UNIT !! BIUNIT - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(xij, 2), SIZE(xij, 2)) !! coefficients - END FUNCTION LagrangeCoeff_Hexahedron5 -END INTERFACE LagrangeCoeff_Hexahedron + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Hexahedron5_ +END INTERFACE LagrangeCoeff_Hexahedron_ !---------------------------------------------------------------------------- ! TensorProdBasis_Hexahedron diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index 233dfd731..d72e51d1d 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -821,212 +821,189 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Hexahedron1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Hexahedron1_(order=order, i=i, xij=xij, ans=ans, & + tsize=tsize) +END PROCEDURE LagrangeCoeff_Hexahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron1_ +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: v INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info +INTEGER(I4B) :: info, nrow, ncol -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +tsize = SIZE(xij, 2) -END PROCEDURE LagrangeCoeff_Hexahedron1 +ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Hexahedron, & + ans=v, nrow=nrow, ncol=ncol) +CALL GetLU(A=v, IPIV=ipiv, info=info) +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) + +END PROCEDURE LagrangeCoeff_Hexahedron1_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Hexahedron !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Hexahedron2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Hexahedron2_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Hexahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron2_ REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B + +tsize = SIZE(v, 1) + +vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Hexahedron2 +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Hexahedron2_ !---------------------------------------------------------------------------- ! LagrangeCoeff_Hexahedron !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Hexahedron3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Hexahedron3_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff_Hexahedron3 !---------------------------------------------------------------------------- -! LagrangeCoeff_Hexahedron +! !---------------------------------------------------------------------------- -MODULE PROCEDURE LagrangeCoeff_Hexahedron4 -INTEGER(I4B) :: basisType0, ii, jj, kk, indx -REAL(DFP) :: ans1(SIZE(xij, 2), 0:order) -REAL(DFP) :: ans2(SIZE(xij, 2), 0:order) -REAL(DFP) :: ans3(SIZE(xij, 2), 0:order) +MODULE PROCEDURE LagrangeCoeff_Hexahedron3_ +INTEGER(I4B) :: info -basisType0 = Input(default=Monomial, option=basisType) +tsize = SIZE(v, 1) +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Hexahedron3_ -SELECT CASE (basisType0) -CASE (Monomial) - ans = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- -CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) +MODULE PROCEDURE LagrangeCoeff_Hexahedron4 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Hexahedron5_(p=order, q=order, r=order, xij=xij, & + basisType1=basisType, basisType2=basisType, basisType3=basisType, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, & + refHexahedron=refHexahedron, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeCoeff_Hexahedron4 - IF (basisType0 .EQ. Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron4", & - & line=__LINE__, & - & unitno=stderr) - STOP - END IF - END IF +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- - IF (basisType0 .EQ. Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron4", & - & line=__LINE__, & - & unitno=stderr) - STOP - END IF - END IF +MODULE PROCEDURE LagrangeCoeff_Hexahedron4_ +CALL LagrangeCoeff_Hexahedron5_(p=order, q=order, r=order, xij=xij, & + basisType1=basisType, basisType2=basisType, basisType3=basisType, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, & + refHexahedron=refHexahedron, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeCoeff_Hexahedron4_ - ans1 = EvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - - ans2 = EvalAllOrthopol( & - & n=order, & - & x=xij(2, :), & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - - ans3 = EvalAllOrthopol( & - & n=order, & - & x=xij(3, :), & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - - indx = 0 - DO kk = 0, order - DO jj = 0, order - DO ii = 0, order - indx = indx + 1 - ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk) - END DO - END DO - END DO +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType = "//tostring(basisType0), & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron4()", & - & line=__LINE__, & - & unitno=stderr) - STOP -END SELECT -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Hexahedron4 +MODULE PROCEDURE LagrangeCoeff_Hexahedron5 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Hexahedron5_(p=p, q=q, r=r, xij=xij, & + basisType1=basisType1, basisType2=basisType2, basisType3=basisType3, & + alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, beta2=beta2, & + lambda2=lambda2, alpha3=alpha3, beta3=beta3, lambda3=lambda3, & + refHexahedron=refHexahedron, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeCoeff_Hexahedron5 !---------------------------------------------------------------------------- ! LagrangeCoeff_Hexahedron !---------------------------------------------------------------------------- -MODULE PROCEDURE LagrangeCoeff_Hexahedron5 +MODULE PROCEDURE LagrangeCoeff_Hexahedron5_ INTEGER(I4B) :: basisType0, ii, jj, kk, indx, basisType(3) REAL(DFP) :: ans1(SIZE(xij, 2), 0:p) REAL(DFP) :: ans2(SIZE(xij, 2), 0:q) REAL(DFP) :: ans3(SIZE(xij, 2), 0:r) -basisType(1) = input(default=Monomial, option=basisType1) -basisType(2) = input(default=Monomial, option=basisType2) -basisType(3) = input(default=Monomial, option=basisType3) +basisType(1) = Input(default=Monomial, option=basisType1) +basisType(2) = Input(default=Monomial, option=basisType2) +basisType(3) = Input(default=Monomial, option=basisType3) + +nrow = SIZE(xij, 2) +ncol = nrow basisType0 = basisType(1) SELECT CASE (basisType0) CASE (Monomial) - ans1 = LagrangeVandermonde(order=p, xij=xij(1:1, :), elemType=Line) + CALL LagrangeVandermonde_(order=p, xij=xij(1:1, :), elemType=Line, & + ans=ans1, nrow=ii, ncol=jj) CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) - - ans1 = EvalAllOrthopol( & - & n=p, & - & x=xij(1, :), & - & orthopol=basisType0, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) + CALL EvalAllOrthopol_(n=p, x=xij(1, :), orthopol=basisType0, & + alpha=alpha1, beta=beta1, lambda=lambda1, & + ans=ans1, nrow=ii, ncol=jj) CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType1", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron5", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg(msg="No case found for basisType1", & + routine="LagrangeCoeff_Hexahedron5", & + file=__FILE__, line=__LINE__, unitno=stderr) + + RETURN END SELECT basisType0 = basisType(2) SELECT CASE (basisType0) CASE (Monomial) - ans2 = LagrangeVandermonde(order=q, xij=xij(2:2, :), elemType=Line) + CALL LagrangeVandermonde_(order=q, xij=xij(2:2, :), elemType=Line, & + ans=ans2, nrow=ii, ncol=jj) CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) - ans2 = EvalAllOrthopol( & - & n=q, & - & x=xij(2, :), & - & orthopol=basisType0, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) + CALL EvalAllOrthopol_(n=q, x=xij(2, :), orthopol=basisType0, & + alpha=alpha2, beta=beta2, lambda=lambda2, & + ans=ans2, nrow=ii, ncol=jj) CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType2", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron5", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg(msg="No case found for basisType2", & + routine="LagrangeCoeff_Hexahedron5", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN END SELECT basisType0 = basisType(3) SELECT CASE (basisType0) CASE (Monomial) - ans3 = LagrangeVandermonde(order=r, xij=xij(3:3, :), elemType=Line) + CALL LagrangeVandermonde_(order=r, xij=xij(3:3, :), elemType=Line, & + ans=ans3, nrow=ii, ncol=jj) CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical) - - ans3 = EvalAllOrthopol( & - & n=r, & - & x=xij(3, :), & - & orthopol=basisType0, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) + CALL EvalAllOrthopol_(n=r, x=xij(3, :), orthopol=basisType0, & + alpha=alpha3, beta=beta3, lambda=lambda3, & + ans=ans3, nrow=ii, ncol=jj) CASE DEFAULT - CALL Errormsg(& - & msg="No case found for basisType3", & - & file=__FILE__, & - & routine="LagrangeCoeff_Hexahedron5", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg(msg="No case found for basisType3", & + routine="LagrangeCoeff_Hexahedron5", & + file=__FILE__, line=__LINE__, unitno=stderr) + + RETURN END SELECT indx = 0 @@ -1034,13 +1011,14 @@ DO jj = 0, q DO ii = 0, p indx = indx + 1 - ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk) + ans(1:nrow, indx) = & + ans1(1:nrow, ii) * ans2(1:nrow, jj) * ans3(1:nrow, kk) END DO END DO END DO -CALL GetInvMat(ans) -END PROCEDURE LagrangeCoeff_Hexahedron5 +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Hexahedron5_ !---------------------------------------------------------------------------- ! TensorProdBasis_Hexahedron From 44fa287c5fc7340a25168d0404302fb111185f9a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 00:45:31 +0900 Subject: [PATCH 097/359] Updates in PrismInterpolationUtility --- .../src/PrismInterpolationUtility.F90 | 109 +++++++++++++++++- .../src/PrismInterpolationUtility@Methods.F90 | 93 ++++++++++++--- 2 files changed, 183 insertions(+), 19 deletions(-) diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index dea4f0d9d..3c2422e9f 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -373,16 +373,123 @@ END FUNCTION LagrangeCoeff_Prism3 !---------------------------------------------------------------------------- INTERFACE LagrangeCoeff_Prism - MODULE FUNCTION LagrangeCoeff_Prism4(order, xij) RESULT(ans) + MODULE FUNCTION LagrangeCoeff_Prism4(order, xij, basisType, & + refPrism, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial REAL(DFP), INTENT(IN) :: xij(:, :) !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi (Dubiner) + !! Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT * default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) !! coefficients END FUNCTION LagrangeCoeff_Prism4 END INTERFACE LagrangeCoeff_Prism +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism_ + MODULE SUBROUTINE LagrangeCoeff_Prism1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Prism1_ +END INTERFACE LagrangeCoeff_Prism_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism_ + MODULE SUBROUTINE LagrangeCoeff_Prism2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP), INTENT(INOUT) :: ans(:) + ! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Prism2_ +END INTERFACE LagrangeCoeff_Prism_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism_ + MODULE SUBROUTINE LagrangeCoeff_Prism3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Prism3_ +END INTERFACE LagrangeCoeff_Prism_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Prism_ + MODULE SUBROUTINE LagrangeCoeff_Prism4_(order, xij, basisType, & + refPrism, alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi (Dubiner) + !! Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT * default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Prism4_ +END INTERFACE LagrangeCoeff_Prism_ + !---------------------------------------------------------------------------- ! QuadraturePoints_Prism !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 index df5efb89e..a0daa9a53 100644 --- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 @@ -152,13 +152,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Prism1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Prism1_(order=order, i=i, xij=xij, ans=ans, & + tsize=tsize) END PROCEDURE LagrangeCoeff_Prism1 !---------------------------------------------------------------------------- @@ -166,12 +162,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Prism2 -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Prism2_(order=order, i=i, v=v, & + isVandermonde=.TRUE., ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff_Prism2 !---------------------------------------------------------------------------- @@ -179,9 +172,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Prism3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Prism3_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff_Prism3 !---------------------------------------------------------------------------- @@ -189,10 +182,74 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Prism4 -ans = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) -CALL GetInvMat(ans) +INTEGER(I4B) :: nrow, ncol + +CALL LagrangeCoeff_Prism4_(order=order, xij=xij, basisType=basisType, & + refPrism=refPrism, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + END PROCEDURE LagrangeCoeff_Prism4 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism1_ +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info, nrow, ncol + +tsize = SIZE(xij, 2) + +ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Prism, & + ans=V, nrow=nrow, ncol=ncol) + +CALL GetLU(A=V, IPIV=ipiv, info=info) + +CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism2_ +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info + +tsize = SIZE(v, 1) + +vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism3_ +INTEGER(I4B) :: info + +tsize = SIZE(v, 1) + +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism4_ +CALL LagrangeVandermonde_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol, elemType=Prism) +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Prism4_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Prism !---------------------------------------------------------------------------- From 8e4005fb36520609a91ee68f814b4b7f7747d1df Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 00:45:40 +0900 Subject: [PATCH 098/359] Updates in TetrahedronInterpolationUtility --- .../src/TetrahedronInterpolationUtility.F90 | 124 +++++++++--------- ...etrahedronInterpolationUtility@Methods.F90 | 77 +++++------ 2 files changed, 101 insertions(+), 100 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index 8e933e7ae..a18706c06 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -521,25 +521,6 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron1(order, i, xij) RESULT(ans) END FUNCTION LagrangeCoeff_Tetrahedron1 END INTERFACE LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Tetrahedron_ - MODULE SUBROUTINE LagrangeCoeff_Tetrahedron1_(order, i, xij, ans, tsize) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP), INTENT(INOUT) :: ans(:) - !! ans(SIZE(xij, 2)) - !! coefficients - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE LagrangeCoeff_Tetrahedron1_ -END INTERFACE LagrangeCoeff_Tetrahedron_ - !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- @@ -560,28 +541,6 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron2(order, i, v, isVandermonde) & END FUNCTION LagrangeCoeff_Tetrahedron2 END INTERFACE LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Tetrahedron_ - MODULE SUBROUTINE LagrangeCoeff_Tetrahedron2_(order, i, v, isVandermonde, & - ans, tsize) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP), INTENT(INOUT) :: ans(:) - ! ans(SIZE(v, 1)) - !! coefficients - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE LagrangeCoeff_Tetrahedron2_ -END INTERFACE LagrangeCoeff_Tetrahedron_ - !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- @@ -601,27 +560,6 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron3(order, i, v, ipiv) RESULT(ans) END FUNCTION LagrangeCoeff_Tetrahedron3 END INTERFACE LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE LagrangeCoeff_Tetrahedron_ - MODULE SUBROUTINE LagrangeCoeff_Tetrahedron3_(order, i, v, ipiv, ans, tsize) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP), INTENT(INOUT) :: ans(:) - !! ans(SIZE(v, 1)) - !! coefficients - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE LagrangeCoeff_Tetrahedron3_ -END INTERFACE LagrangeCoeff_Tetrahedron_ - !---------------------------------------------------------------------------- ! LagrangeCoeff_Tetrahedron !---------------------------------------------------------------------------- @@ -660,6 +598,68 @@ END FUNCTION LagrangeCoeff_Tetrahedron4 ! !---------------------------------------------------------------------------- +INTERFACE LagrangeCoeff_Tetrahedron_ + MODULE SUBROUTINE LagrangeCoeff_Tetrahedron1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Tetrahedron1_ +END INTERFACE LagrangeCoeff_Tetrahedron_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron_ + MODULE SUBROUTINE LagrangeCoeff_Tetrahedron2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP), INTENT(INOUT) :: ans(:) + ! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Tetrahedron2_ +END INTERFACE LagrangeCoeff_Tetrahedron_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Tetrahedron_ + MODULE SUBROUTINE LagrangeCoeff_Tetrahedron3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Tetrahedron3_ +END INTERFACE LagrangeCoeff_Tetrahedron_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE LagrangeCoeff_Tetrahedron_ MODULE SUBROUTINE LagrangeCoeff_Tetrahedron4_(order, xij, basisType, & refTetrahedron, alpha, beta, lambda, ans, nrow, ncol) diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index e2bb7a132..f3bf50d4d 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -490,6 +490,39 @@ tsize=tsize) END PROCEDURE LagrangeCoeff_Tetrahedron1 +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Tetrahedron2_(order=order, i=i, v=v, & + isVandermonde=.TRUE., ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Tetrahedron2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron3 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Tetrahedron3_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Tetrahedron3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron4 +INTEGER(I4B) :: nrow, ncol + +CALL LagrangeCoeff_Tetrahedron4_(order=order, xij=xij, basisType=basisType, & + refTetrahedron=refTetrahedron, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE LagrangeCoeff_Tetrahedron4 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -497,26 +530,20 @@ MODULE PROCEDURE LagrangeCoeff_Tetrahedron1_ REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info +INTEGER(I4B) :: info, nrow, ncol 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=Tetrahedron) + +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Tetrahedron, & + ans=V, nrow=nrow, ncol=ncol) + CALL GetLU(A=V, IPIV=ipiv, info=info) + CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) END PROCEDURE LagrangeCoeff_Tetrahedron1_ -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Tetrahedron2 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Tetrahedron2_(order=order, i=i, v=v, & - isVandermonde=.TRUE., ans=ans, tsize=tsize) -END PROCEDURE LagrangeCoeff_Tetrahedron2 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -533,16 +560,6 @@ CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) END PROCEDURE LagrangeCoeff_Tetrahedron2_ -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Tetrahedron3 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Tetrahedron3_(order=order, i=i, v=v, ipiv=ipiv, & - ans=ans, tsize=tsize) -END PROCEDURE LagrangeCoeff_Tetrahedron3 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -556,19 +573,6 @@ CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) END PROCEDURE LagrangeCoeff_Tetrahedron3_ -!---------------------------------------------------------------------------- -! LagrangeCoeff_Tetrahedron -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Tetrahedron4 -INTEGER(I4B) :: nrow, ncol - -CALL LagrangeCoeff_Tetrahedron4_(order=order, xij=xij, basisType=basisType, & - refTetrahedron=refTetrahedron, alpha=alpha, beta=beta, lambda=lambda, & - ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE LagrangeCoeff_Tetrahedron4 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -583,9 +587,6 @@ SELECT CASE (basisType0) CASE (Monomial) - ans(1:nrow, 1:ncol) = LagrangeVandermonde(order=order, xij=xij, & - elemType=Tetrahedron) - CALL LagrangeVandermonde_(order=order, xij=xij, ans=ans, nrow=nrow, & ncol=ncol, elemType=Tetrahedron) From c24af01e7eefff82fb691af131e83fde8d0101ed Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 13:34:52 +0900 Subject: [PATCH 099/359] Updates in LineInterpolationUtility --- .../src/LineInterpolationUtility.F90 | 86 +++++++- .../src/LineInterpolationUtility@Methods.F90 | 184 ++++++++++-------- 2 files changed, 186 insertions(+), 84 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index e3cae4f02..6abb888aa 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -34,6 +34,7 @@ MODULE LineInterpolationUtility PUBLIC :: InterpolationPoint_Line PUBLIC :: InterpolationPoint_Line_ PUBLIC :: LagrangeCoeff_Line +PUBLIC :: LagrangeCoeff_Line_ PUBLIC :: LagrangeEvalAll_Line PUBLIC :: LagrangeGradientEvalAll_Line PUBLIC :: BasisEvalAll_Line @@ -797,12 +798,7 @@ MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, & !! If firstCall is False, then coeff will be used !! Default value of firstCall is True INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! Monomial Jacobi Legendre Chebyshev Lobatto UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -814,6 +810,41 @@ MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, & END FUNCTION LagrangeEvalAll_Line1 END INTERFACE LagrangeEvalAll_Line +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line_ +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Line_ + MODULE SUBROUTINE LagrangeEvalAll_Line1_(order, x, xij, coeff, firstCall, & + basisType, alpha, beta, lambda, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial Jacobi Legendre Chebyshev Lobatto UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeEvalAll_Line1_ +END INTERFACE LagrangeEvalAll_Line_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Line !---------------------------------------------------------------------------- @@ -862,6 +893,49 @@ MODULE FUNCTION LagrangeEvalAll_Line2(order, x, xij, coeff, firstCall, & END FUNCTION LagrangeEvalAll_Line2 END INTERFACE LagrangeEvalAll_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Line_ + MODULE SUBROUTINE LagrangeEvalAll_Line2_(order, x, xij, ans, nrow, ncol, & + coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + !! size(xij, 1) = nsd + !! size(xij, 2) = number of points + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nubmer of rows and cols writte in ans + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial, Jacobi, Legendre, Chebyshev, Lobatto, UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Line2_ +END INTERFACE LagrangeEvalAll_Line_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Line !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 5bd0dddf5..ca17b7ddf 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -53,6 +53,8 @@ USE SortUtility, ONLY: HeapSort +USE F95_BLAS, ONLY: GEMM + IMPLICIT NONE CONTAINS @@ -798,128 +800,154 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Line1 +INTEGER(I4B) :: tsize +CALL LagrangeEvalAll_Line1_(order=order, x=x, xij=xij, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, tsize=tsize) +END PROCEDURE LagrangeEvalAll_Line1 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line1_ LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) -INTEGER(I4B) :: ii, orthopol0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), x1(1) +INTEGER(I4B) :: ii, orthopol0, nrow, ncol -IF (SIZE(xij, 2) .NE. order + 1) THEN - CALL Errormsg(& - & msg="Size(xij, 1) .NE. order+1 ", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) +tsize = SIZE(xij, 2) + +#ifdef DEBUG_VER + +IF (tsize .NE. order + 1) THEN + CALL Errormsg(msg="Size(xij, 1) .NE. order+1 ", & + routine="LagrangeEvalAll_Line2", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF +#endif + orthopol0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) +! make coeff0 + IF (PRESENT(coeff)) THEN IF (firstCall0) THEN - coeff = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + CALL LagrangeCoeff_Line_(order=order, xij=xij, & + basisType=orthopol0, alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff, nrow=nrow, ncol=ncol) END IF - coeff0 = TRANSPOSE(coeff) + + ! coeff0(1:nrow, 1:ncol) = TRANSPOSE(coeff(1:nrow, 1:ncol)) + coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) + ELSE - coeff0 = TRANSPOSE(LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & )) + + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff0, nrow=nrow, ncol=ncol) + + ! coeff0(1:nrow, 1:ncol) = TRANSPOSE(coeff0(1:nrow, 1:ncol)) END IF -SELECT CASE (orthopol0) -CASE (polyopt%Monomial) +IF (orthopol0 .EQ. polyopt%monomial) THEN + xx(1, 1) = 1.0_DFP DO ii = 1, order xx(1, ii + 1) = xx(1, ii) * x END DO -CASE DEFAULT - xx = EvalAllOrthopol(& - & n=order, & - & x=[x], & - & orthopol=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT -ans = MATMUL(coeff0, xx(1, :)) +ELSE -END PROCEDURE LagrangeEvalAll_Line1 + x1(1) = x + CALL EvalAllOrthopol_(n=order, x=x1, orthopol=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=xx, nrow=nrow, ncol=ncol) + +END IF + +DO CONCURRENT(ii=1:tsize) + ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) +END DO + +END PROCEDURE LagrangeEvalAll_Line1_ !---------------------------------------------------------------------------- ! LagrangeEvalAll_Line !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Line2 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Line2_(order=order, x=x, xij=xij, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeEvalAll_Line2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line2_ LOGICAL(LGT) :: firstCall0 REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) -INTEGER(I4B) :: ii, orthopol0 +INTEGER(I4B) :: ii, orthopol0, aint, bint -IF (SIZE(xij, 2) .NE. order + 1) THEN - CALL Errormsg(& - & msg="Size(xij, 1) .NE. order+1 ", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) +nrow = SIZE(x, 2) +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 +#endif + orthopol0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN - coeff = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + ! coeff = LagrangeCoeff_Line(& + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, ans=coeff, nrow=aint, ncol=bint) END IF - coeff0 = coeff + + coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) + ELSE - coeff0 = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) + + ! coeff0 = LagrangeCoeff_Line(& + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=aint, ncol=bint) + END IF -SELECT CASE (orthopol0) -CASE (polyopt%Monomial) +IF (orthopol0 .EQ. polyopt%monomial) THEN + xx(:, 1) = 1.0_DFP DO ii = 1, order xx(:, ii + 1) = xx(:, ii) * x(1, :) END DO -CASE DEFAULT - xx = EvalAllOrthopol(& - & n=order, & - & x=x(1, :), & - & orthopol=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT -ans = MATMUL(xx, coeff0) +ELSE -END PROCEDURE LagrangeEvalAll_Line2 + ! xx = EvalAllOrthopol( + CALL EvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, alpha=alpha, & + beta=beta, lambda=lambda, ans=xx, nrow=aint, ncol=bint) + +END IF + +! ans = MATMUL(xx, coeff0) +CALL GEMM(C=ans, alpha=1.0_DFP, A=xx, B=coeff0) + +END PROCEDURE LagrangeEvalAll_Line2_ !---------------------------------------------------------------------------- ! EvalAll_Line @@ -1229,12 +1257,11 @@ END SUBROUTINE handle_error IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN CALL ErrorMsg(& & msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & - & file=__FILE__, & & routine="QuadraturePoint_Line3", & - & line=__LINE__, & - & unitno=stderr) + & file=__FILE__, line=__LINE__, unitno=stderr) END IF RETURN + ELSEIF (ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType)) THEN IF (.NOT. PRESENT(lambda)) THEN CALL ErrorMsg(& @@ -1245,6 +1272,7 @@ END SUBROUTINE handle_error & unitno=stderr) END IF RETURN + END IF IF (PRESENT(xij)) THEN From 769bc1bbc8a7ea35f2729c14045a80cf2e8dd4aa Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 13:41:08 +0900 Subject: [PATCH 100/359] Updates in LineInterpolationUtility --- src/modules/Polynomial/src/LineInterpolationUtility.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 6abb888aa..4217688dd 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -36,6 +36,7 @@ MODULE LineInterpolationUtility PUBLIC :: LagrangeCoeff_Line PUBLIC :: LagrangeCoeff_Line_ PUBLIC :: LagrangeEvalAll_Line +PUBLIC :: LagrangeEvalAll_Line_ PUBLIC :: LagrangeGradientEvalAll_Line PUBLIC :: BasisEvalAll_Line PUBLIC :: BasisGradientEvalAll_Line From d113f7a96c7e5929f52e12a89820d1d6bc6a06c5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 15:46:00 +0900 Subject: [PATCH 101/359] Updates in TriangleInterpolationUtility --- .../src/TriangleInterpolationUtility.F90 | 76 +++++++++++++++++++ ...erpolationUtility@LagrangeBasisMethods.F90 | 74 +++++++++++++----- 2 files changed, 131 insertions(+), 19 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 43a0322db..e58e4ffd9 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -41,6 +41,7 @@ MODULE TriangleInterpolationUtility PUBLIC :: HeirarchicalBasisGradient_Triangle PUBLIC :: LagrangeEvalAll_Triangle +PUBLIC :: LagrangeEvalAll_Triangle_ PUBLIC :: LagrangeGradientEvalAll_Triangle PUBLIC :: QuadraturePoint_Triangle @@ -1405,6 +1406,42 @@ MODULE FUNCTION LagrangeEvalAll_Triangle1(order, x, xij, refTriangle, & END FUNCTION LagrangeEvalAll_Triangle1 END INTERFACE LagrangeEvalAll_Triangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Triangle_ + MODULE SUBROUTINE LagrangeEvalAll_Triangle1_(order, x, xij, ans, tsize, & + refTriangle, coeff, firstCall, basisType) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(2) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! + CHARACTER(*), INTENT(IN) :: refTriangle + !! interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: tsize + !! Total size written in ans + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + END SUBROUTINE LagrangeEvalAll_Triangle1_ +END INTERFACE LagrangeEvalAll_Triangle_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Triangle !---------------------------------------------------------------------------- @@ -1444,6 +1481,45 @@ MODULE FUNCTION LagrangeEvalAll_Triangle2(order, x, xij, refTriangle, & END FUNCTION LagrangeEvalAll_Triangle2 END INTERFACE LagrangeEvalAll_Triangle +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Triangle_@LagrnageBasisMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Triangle_ + MODULE SUBROUTINE LagrangeEvalAll_Triangle2_(order, x, xij, ans, nrow, & + ncol, refTriangle, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of rows and columns written to ans + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE LagrangeEvalAll_Triangle2_ +END INTERFACE LagrangeEvalAll_Triangle_ + !---------------------------------------------------------------------------- ! QuadraturePoints_Triangle !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index 1a2d6fb66..42f9c4b26 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -21,6 +21,8 @@ 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 @@ -200,11 +202,25 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Triangle1 +INTEGER(I4B) :: tsize + +CALL LagrangeEvalAll_Triangle1_(order=order, x=x, xij=xij, ans=ans, & + tsize=tsize, refTriangle=refTriangle, coeff=coeff, & + firstCall=firstCall, basisType=basisType) +END PROCEDURE LagrangeEvalAll_Triangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Triangle1_ LOGICAL(LGT) :: firstCall0 INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow INTEGER(I4B) :: degree(SIZE(xij, 2), 2) REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) +tsize = SIZE(xij, 2) + basisType0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) @@ -214,17 +230,17 @@ CALL LagrangeCoeff_Triangle_(order=order, xij=xij, & basisType=basisType0, refTriangle=refTriangle, & ans=coeff, nrow=nrow, ncol=ncol) - coeff0 = TRANSPOSE(coeff) - ELSE - coeff0 = TRANSPOSE(coeff) END IF + ! coeff0 = TRANSPOSE(coeff) + coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) + ELSE CALL LagrangeCoeff_Triangle_(order=order, xij=xij, & basisType=basisType0, refTriangle=refTriangle, & ans=coeff0, nrow=nrow, ncol=ncol) - coeff0 = TRANSPOSE(coeff0) + ! coeff0 = TRANSPOSE(coeff0) END IF @@ -254,19 +270,40 @@ END SELECT -ans = MATMUL(coeff0, xx(1, :)) -END PROCEDURE LagrangeEvalAll_Triangle1 +DO CONCURRENT(ii=1:tsize) + ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) +END DO + +! ans = MATMUL(coeff0, xx(1, :)) +END PROCEDURE LagrangeEvalAll_Triangle1_ !---------------------------------------------------------------------------- ! LagrangeEvalAll_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Triangle2 + +INTEGER(I4B) :: nrow, ncol + +CALL LagrangeEvalAll_Triangle2_(order=order, x=x, xij=xij, & + reftriangle=reftriangle, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda, nrow=nrow, ncol=ncol, ans=ans) +END PROCEDURE LagrangeEvalAll_Triangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Triangle2_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow +INTEGER(I4B) :: ii, basisType0, tdof, aint, bint INTEGER(I4B) :: degree(SIZE(xij, 2), 2) REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) + basisType0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) @@ -274,18 +311,16 @@ IF (firstCall0) THEN CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff, nrow=nrow, ncol=ncol) - coeff0 = coeff + refTriangle=refTriangle, ans=coeff, nrow=aint, ncol=bint) - ELSE + END IF - coeff0 = coeff + coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) - END IF ELSE CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff0, nrow=nrow, ncol=ncol) + refTriangle=refTriangle, ans=coeff0, nrow=aint, ncol=bint) END IF @@ -293,7 +328,7 @@ CASE (polyopt%Monomial) - CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) + CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=aint, ncol=bint) tdof = SIZE(xij, 2) DO ii = 1, tdof @@ -303,17 +338,18 @@ CASE (polyopt%Hierarchical) CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=x, refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) + pe3=order, xij=x, refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint) -CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, polyopt%Ultraspherical) +CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, & + polyopt%Ultraspherical) CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, & - ans=xx, nrow=nrow, ncol=ncol) + ans=xx, nrow=aint, ncol=bint) END SELECT -ans = MATMUL(xx, coeff0) -END PROCEDURE LagrangeEvalAll_Triangle2 +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0) +END PROCEDURE LagrangeEvalAll_Triangle2_ !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Triangle From 9a2b99aa47501b25058c9bf9c4966a3df8cfe209 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 15:46:11 +0900 Subject: [PATCH 102/359] Updates in F95_BLAS --- src/modules/BLAS95/src/F95_BLAS.F90 | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/modules/BLAS95/src/F95_BLAS.F90 b/src/modules/BLAS95/src/F95_BLAS.F90 index 9f5b8bb01..419ac54f6 100644 --- a/src/modules/BLAS95/src/F95_BLAS.F90 +++ b/src/modules/BLAS95/src/F95_BLAS.F90 @@ -40,6 +40,7 @@ MODULE F95_BLAS PUBLIC :: AXPY PUBLIC :: ASUM PUBLIC :: GEMV +PUBLIC :: GEMM #ifndef USE_NativeBLAS PUBLIC :: IAMIN @@ -204,6 +205,24 @@ MODULE F95_BLAS END INTERFACE GEMV #endif +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE GEMM + MODULE PROCEDURE SGEMM_F95, DGEMM_F95, CGEMM_F95, ZGEMM_F95 +END INTERFACE GEMM + +! #ifdef USE_INTEL_MKL +! INTERFACE GEMV +! MODULE PROCEDURE SCGEMV_F95, DZGEMV_F95 +! END INTERFACE GEMV +! #endif + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + CONTAINS #ifndef USE_APPLE_NativeBLAS From 342eceba4246d134a71559b96cadbdd01f55d002 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 17:21:14 +0900 Subject: [PATCH 103/359] Updates in LineInterpolationUtility --- .../src/LineInterpolationUtility.F90 | 73 ++++++++ .../src/LineInterpolationUtility@Methods.F90 | 173 +++++++++++------- 2 files changed, 183 insertions(+), 63 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 4217688dd..2e87c6a7f 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -39,6 +39,7 @@ MODULE LineInterpolationUtility PUBLIC :: LagrangeEvalAll_Line_ PUBLIC :: LagrangeGradientEvalAll_Line PUBLIC :: BasisEvalAll_Line +PUBLIC :: BasisEvalAll_Line_ PUBLIC :: BasisGradientEvalAll_Line PUBLIC :: QuadraturePoint_Line PUBLIC :: ToVEFC_Line @@ -1021,6 +1022,40 @@ MODULE FUNCTION BasisEvalAll_Line1(order, x, refLine, basisType, alpha, & END FUNCTION BasisEvalAll_Line1 END INTERFACE BasisEvalAll_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE BasisEvalAll_Line_ + MODULE SUBROUTINE BasisEvalAll_Line1_(order, x, ans, tsize, refLine, & + basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(order + 1) + !! Value of n+1 polynomials at point x + INTEGER(I4B), INTENT(OUT) :: tsize + CHARACTER(*), INTENT(IN) :: refLine + !! Refline should be BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE BasisEvalAll_Line1_ +END INTERFACE BasisEvalAll_Line_ + !---------------------------------------------------------------------------- ! BasisEvalAll_Line !---------------------------------------------------------------------------- @@ -1060,6 +1095,44 @@ MODULE FUNCTION BasisEvalAll_Line2(order, x, refLine, basisType, & END FUNCTION BasisEvalAll_Line2 END INTERFACE BasisEvalAll_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE BasisEvalAll_Line_ + MODULE SUBROUTINE BasisEvalAll_Line2_(order, x, ans, nrow, ncol, & + refLine, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x(:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), order + 1) + !! Value of n+1 polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT + !! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE BasisEvalAll_Line2_ +END INTERFACE BasisEvalAll_Line_ + !---------------------------------------------------------------------------- ! BasisEvalAll_Line !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index ca17b7ddf..dc36c40f9 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -954,63 +954,91 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE BasisEvalAll_Line1 -INTEGER(I4B) :: ii, basisType0 -TYPE(String) :: astr -astr = UpperCase(refLine) +INTEGER(I4B) :: tsize +CALL BasisEvalAll_Line1_(order=order, x=x, ans=ans, tsize=tsize, & + refline=refline, basistype=basistype, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE BasisEvalAll_Line1 -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisEvalAll_Line1_ +#ifdef DEBUG_VER +CHARACTER(1) :: astr +#endif + +INTEGER(I4B) :: ii, basisType0, nrow, ncol +REAL(DFP) :: temp(1, 100), x1(1) + +tsize = order + 1 + +#ifdef DEBUG_VER + +astr = UpperCase(refLine(1:1)) +IF (astr .EQ. "U") THEN + CALL Errormsg(msg="refLine should be BIUNIT", & + routine="BasisEvalAll_Line1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF -basisType0 = input(default=polyopt%Monomial, option=basisType) +#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", & - & file=__FILE__, & - & routine="BasisEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg( & + msg="alpha and beta should be present for basisType=Jacobi", & + routine="BasisEvalAll_Line1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF END IF IF (basisType0 .EQ. polyopt%Ultraspherical) THEN IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg( & + msg="lambda should be present for basisType=Ultraspherical", & + routine="BasisEvalAll_Line1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF END IF - ans = RESHAPE(EvalAllOrthopol(& - & n=order, & - & x=[x], & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda), [order + 1]) + IF (order + 1 .GT. SIZE(temp, 2)) THEN + CALL Errormsg( & + msg="order+1 is greater than number of col in temp", & + routine="BasisEvalAll_Line1_", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN + END IF + +#endif + + x1(1) = x + CALL EvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, alpha=alpha, & + beta=beta, lambda=lambda, ans=temp, nrow=nrow, ncol=ncol) + + ans(1:tsize) = temp(1, 1:tsize) + END SELECT -END PROCEDURE BasisEvalAll_Line1 +END PROCEDURE BasisEvalAll_Line1_ !---------------------------------------------------------------------------- ! BasisGradientEvalAll_Line @@ -1080,63 +1108,82 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- 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 -TYPE(String) :: astr -astr = UpperCase(refLine) -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) +nrow = SIZE(x) +ncol = order + 1 + +#ifdef DEBUG_VER + +astr = UpperCase(refline(1:1)) + +IF (astr .EQ. "U") THEN + CALL Errormsg(msg="refLine should be BIUNIT", & + routine="BasisEvalAll_Line2", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF -basisType0 = input(default=polyopt%Monomial, option=basisType) +#endif + +basisType0 = Input(default=polyopt%Monomial, option=basisType) + SELECT CASE (basisType0) + CASE (polyopt%Monomial) - ans(:, 1) = 1.0_DFP + ans(1:nrow, 1) = 1.0_DFP DO ii = 1, order - ans(:, ii + 1) = ans(:, ii) * x + 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", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg( & + msg="alpha and beta should be present for basisType=Jacobi", & + routine="BasisEvalAll_Line2", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF END IF IF (basisType0 .EQ. polyopt%Ultraspherical) THEN IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg( & + msg="lambda should be present for basisType=Ultraspherical", & + routine="BasisEvalAll_Line2", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF END IF - ans = EvalAllOrthopol(& - & n=order, & - & x=x, & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +#endif + + 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 +END PROCEDURE BasisEvalAll_Line2_ !---------------------------------------------------------------------------- ! BasisGradientEvalAll_Line From feeae9f83e7c8c9ff6a535fc62046d7093a97b86 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 19:45:13 +0900 Subject: [PATCH 104/359] Updates in QuadrangleInterpolationUtility --- .../src/QuadrangleInterpolationUtility.F90 | 446 ++++++++++++++++- ...QuadrangleInterpolationUtility@Methods.F90 | 463 +++++++++++++----- 2 files changed, 760 insertions(+), 149 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index dde12a00e..a6797878a 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -40,6 +40,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: IJ2VEFC_Quadrangle_Clockwise PUBLIC :: IJ2VEFC_Quadrangle_AntiClockwise PUBLIC :: LagrangeEvalAll_Quadrangle +PUBLIC :: LagrangeEvalAll_Quadrangle_ PUBLIC :: QuadraturePoint_Quadrangle PUBLIC :: QuadratureNumber_Quadrangle PUBLIC :: FacetConnectivity_Quadrangle @@ -177,6 +178,22 @@ END FUNCTION LagrangeDegree_Quadrangle1 ! date: 18 Aug 2022 ! summary: Returns the degree of monomials for Lagrange polynomials +INTERFACE LagrangeDegree_Quadrangle_ + MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle1_(order, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeDegree_Quadrangle1_ +END INTERFACE LagrangeDegree_Quadrangle_ + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + INTERFACE LagrangeDegree_Quadrangle MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p @@ -185,6 +202,19 @@ MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans) END FUNCTION LagrangeDegree_Quadrangle2 END INTERFACE LagrangeDegree_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeDegree_Quadrangle_ + MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle2_(p, q, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p + INTEGER(I4B), INTENT(IN) :: q + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeDegree_Quadrangle2_ +END INTERFACE LagrangeDegree_Quadrangle_ + !---------------------------------------------------------------------------- ! LagrangeDOF_Quadrangle !---------------------------------------------------------------------------- @@ -1261,6 +1291,48 @@ END FUNCTION TensorProdBasis_Quadrangle1 MODULE PROCEDURE TensorProdBasis_Quadrangle1 END INTERFACE OrthogonalBasis_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE TensorProdBasis_Quadrangle_ + MODULE SUBROUTINE TensorProdBasis_Quadrangle1_(p, q, xij, ans, nrow, & + ncol, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, & + beta2, lambda2) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2) + !! ncol = (p + 1) * (q + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basis type in x1 direction + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basis type in x2 direction + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + END SUBROUTINE TensorProdBasis_Quadrangle1_ +END INTERFACE TensorProdBasis_Quadrangle_ + +INTERFACE OrthogonalBasis_Quadrangle_ + MODULE PROCEDURE TensorProdBasis_Quadrangle1_ +END INTERFACE OrthogonalBasis_Quadrangle_ + !---------------------------------------------------------------------------- ! TensorProdBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1335,6 +1407,47 @@ END FUNCTION TensorProdBasis_Quadrangle2 MODULE PROCEDURE TensorProdBasis_Quadrangle2 END INTERFACE OrthogonalBasis_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE TensorProdBasis_Quadrangle_ + MODULE SUBROUTINE TensorProdBasis_Quadrangle2_(p, q, x, y, ans, nrow, & + ncol, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1)) + !! nrow = SIZE(x) * SIZE(y) + !! ncol = (p + 1) * (q + 1) + !! Tensor basis + !! The number of rows corresponds to the + !! total number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + INTEGER(I4B), INTENT(IN) :: basisType1 + !! Orthogonal polynomial family in x1 direction + INTEGER(I4B), INTENT(IN) :: basisType2 + !! Orthogonal poly family in x2 direction + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + END SUBROUTINE TensorProdBasis_Quadrangle2_ +END INTERFACE TensorProdBasis_Quadrangle_ + !---------------------------------------------------------------------------- ! VertexBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1354,22 +1467,19 @@ END FUNCTION VertexBasis_Quadrangle1 END INTERFACE VertexBasis_Quadrangle !---------------------------------------------------------------------------- -! VertexBasis_Quadrangle +! !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE VertexBasis_Quadrangle - MODULE PURE FUNCTION VertexBasis_Quadrangle3(xij) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: xij(:, :) +INTERFACE VertexBasis_Quadrangle_ + MODULE PURE SUBROUTINE VertexBasis_Quadrangle1_(x, y, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: x(:), y(:) !! point of evaluation - REAL(DFP) :: ans(SIZE(xij, 2), 4) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), 4) !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Quadrangle3 -END INTERFACE VertexBasis_Quadrangle + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE VertexBasis_Quadrangle1_ +END INTERFACE VertexBasis_Quadrangle_ !---------------------------------------------------------------------------- ! VertexBasis_Quadrangle2 @@ -1389,6 +1499,54 @@ MODULE PURE FUNCTION VertexBasis_Quadrangle2(L1, L2) RESULT(ans) END FUNCTION VertexBasis_Quadrangle2 END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE VertexBasis_Quadrangle2_(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 + END SUBROUTINE VertexBasis_Quadrangle2_ +END INTERFACE + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE VertexBasis_Quadrangle + MODULE PURE FUNCTION VertexBasis_Quadrangle3(xij) RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + REAL(DFP) :: ans(SIZE(xij, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Quadrangle3 +END INTERFACE VertexBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE VertexBasis_Quadrangle_ + MODULE PURE SUBROUTINE VertexBasis_Quadrangle3_(xij, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE VertexBasis_Quadrangle3_ +END INTERFACE VertexBasis_Quadrangle_ + !---------------------------------------------------------------------------- ! VertexBasis_Quadrangle2 !---------------------------------------------------------------------------- @@ -1452,6 +1610,28 @@ END FUNCTION VerticalEdgeBasis_Quadrangle ! !---------------------------------------------------------------------------- +INTERFACE + MODULE PURE SUBROUTINE VerticalEdgeBasis_Quadrangle_(qe1, qe2, x, y, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1), it should be greater than 1 + !! It should be greater than 2 + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2), it should be greater than 1 + !! It should be greater than 2 + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + !! these points should be between [-1, 1]. + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(x), qe1 + qe2 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE VerticalEdgeBasis_Quadrangle_ +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle2(qe1, qe2, L1, L2) & & RESULT(ans) @@ -1469,6 +1649,25 @@ END FUNCTION VerticalEdgeBasis_Quadrangle2 ! !---------------------------------------------------------------------------- +INTERFACE + MODULE PURE SUBROUTINE VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, & + ans, nrow, ncol) + 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 + END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE MODULE PURE FUNCTION VerticalEdgeBasisGradient_Quadrangle2( & & qe1, & @@ -1521,6 +1720,25 @@ END FUNCTION HorizontalEdgeBasis_Quadrangle ! !---------------------------------------------------------------------------- +INTERFACE + MODULE PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle_(pe3, pe4, x, y, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), pe3 + pe4 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HorizontalEdgeBasis_Quadrangle_ +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle2(pe3, pe4, L1, L2) & & RESULT(ans) @@ -1539,14 +1757,27 @@ END FUNCTION HorizontalEdgeBasis_Quadrangle2 !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasisGradient_Quadrangle2( & - &pe3, & - & pe4, & - & L1, & - & L2, & - & dL1, & - & dL2) & - & RESULT(ans) + MODULE PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle2_(pe3, pe4, L1, L2, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), pe3 + pe4 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION HorizontalEdgeBasisGradient_Quadrangle2(pe3, pe4, & + L1, L2, dL1, dL2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe3 !! order on bottom vertical edge (e3), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: pe4 @@ -1581,6 +1812,25 @@ MODULE PURE FUNCTION CellBasis_Quadrangle(pb, qb, x, y) RESULT(ans) END FUNCTION CellBasis_Quadrangle END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE CellBasis_Quadrangle_(pb, qb, x, y, ans, nrow, & + ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), (pb - 1) * (qb - 1)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE CellBasis_Quadrangle_ +END INTERFACE + !---------------------------------------------------------------------------- ! CellBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1597,6 +1847,25 @@ MODULE PURE FUNCTION CellBasis_Quadrangle2(pb, qb, L1, L2) RESULT(ans) END FUNCTION CellBasis_Quadrangle2 END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE CellBasis_Quadrangle2_ +END INTERFACE + !---------------------------------------------------------------------------- ! CellBasisGradient_Quadrangle !---------------------------------------------------------------------------- @@ -1662,6 +1931,34 @@ MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle1(pb, qb, pe3, pe4, & END FUNCTION HeirarchicalBasis_Quadrangle1 END INTERFACE HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Quadrangle_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle1_(pb, qb, pe3, pe4, & + qe1, qe2, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2), & + !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Quadrangle1_ +END INTERFACE HeirarchicalBasis_Quadrangle_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1688,6 +1985,26 @@ MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle2(p, q, xij) RESULT(ans) END FUNCTION HeirarchicalBasis_Quadrangle2 END INTERFACE HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Quadrangle_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle2_(p, q, xij, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! order of interpolation inside the quadrangle in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2) + !! ncol = (p + 1) * (q + 1)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Quadrangle2_ +END INTERFACE HeirarchicalBasis_Quadrangle_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Quadrangle !---------------------------------------------------------------------------- @@ -1745,6 +2062,55 @@ MODULE FUNCTION LagrangeEvalAll_Quadrangle1( & 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 !---------------------------------------------------------------------------- @@ -1794,6 +2160,46 @@ MODULE FUNCTION LagrangeEvalAll_Quadrangle2( & END FUNCTION LagrangeEvalAll_Quadrangle2 END INTERFACE LagrangeEvalAll_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Quadrangle_ + MODULE SUBROUTINE LagrangeEvalAll_Quadrangle2_(order, x, xij, ans, & + nrow, ncol, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Quadrangle2_ +END INTERFACE LagrangeEvalAll_Quadrangle_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Quadrangle !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index fb136973f..f676a1e5a 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -64,9 +64,22 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeDegree_Quadrangle1 -INTEGER(I4B) :: n, ii, jj, kk -n = LagrangeDOF_Quadrangle(order=order) -ALLOCATE (ans(n, 2)) +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_ +INTEGER(I4B) :: ii, jj, kk + +nrow = LagrangeDOF_Quadrangle(order=order) +ncol = 2 + kk = 0 DO jj = 0, order DO ii = 0, order @@ -75,16 +88,31 @@ ans(kk, 2) = jj END DO END DO -END PROCEDURE LagrangeDegree_Quadrangle1 + +END PROCEDURE LagrangeDegree_Quadrangle1_ !---------------------------------------------------------------------------- ! LagrangeDegree_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeDegree_Quadrangle2 -INTEGER(I4B) :: n, ii, jj, kk -n = LagrangeDOF_Quadrangle(p=p, q=q) -ALLOCATE (ans(n, 2)) +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, kk +nrow = LagrangeDOF_Quadrangle(p=p, q=q) +ncol = 2 + kk = 0 DO jj = 0, q DO ii = 0, p @@ -93,7 +121,7 @@ ans(kk, 2) = jj END DO END DO -END PROCEDURE LagrangeDegree_Quadrangle2 +END PROCEDURE LagrangeDegree_Quadrangle2_ !---------------------------------------------------------------------------- ! GetTotalDOF_Quadrangle @@ -1097,52 +1125,68 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE TensorProdBasis_Quadrangle1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) +INTEGER(I4B) :: nrow, ncol +CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol, basisType1=basisType1, basisType2=basisType2, & + alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & + beta2=beta2, lambda2=lambda2) +END PROCEDURE TensorProdBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! TensorProdBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle1_ REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: ii, k1, k2, cnt +INTEGER(I4B) :: ii, k1, k2, cnt, aint, bint -x = xij(1, :) -y = xij(2, :) +nrow = SIZE(xij, 2) +ncol = (p + 1) * (q + 1) -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) +! P1 = BasisEvalAll_Line( & +CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & + basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, ans=P1, & + nrow=aint, ncol=bint) -Q1 = BasisEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) +! Q1 = BasisEvalAll_Line( & +CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & + basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, & + nrow=aint, ncol=bint) cnt = 0 DO k2 = 1, q + 1 DO k1 = 1, p + 1 cnt = cnt + 1 - ans(:, cnt) = P1(:, k1) * Q1(:, k2) + ans(1:nrow, cnt) = P1(1:nrow, k1) * Q1(1:nrow, k2) END DO END DO -END PROCEDURE TensorProdBasis_Quadrangle1 +END PROCEDURE TensorProdBasis_Quadrangle1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE TensorProdBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL TensorProdBasis_Quadrangle2_(p=p, q=q, x=x, y=y, ans=ans, nrow=nrow, & + ncol=ncol, basisType1=basisType1, basisType2=basisType2, & + alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & + beta2=beta2, lambda2=lambda2) +END PROCEDURE TensorProdBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle2_ REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) INTEGER(I4B) :: ii, jj, cnt xij = 0.0_DFP cnt = 0 + DO ii = 1, SIZE(x) DO jj = 1, SIZE(y) cnt = cnt + 1 @@ -1151,43 +1195,82 @@ END DO END DO -ans = TensorProdBasis_Quadrangle1( & - & p=p, & - & q=q, & - & xij=xij, & - & basisType1=basisType1, & - & basisType2=basisType2, & - & alpha1=alpha1, & - & alpha2=alpha2, & - & beta1=beta1, & - & beta2=beta2, & - & lambda1=lambda1, & - & lambda2=lambda2) +! ans = TensorProdBasis_Quadrangle1( & +CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, basisType1=basisType1, & + basisType2=basisType2, alpha1=alpha1, alpha2=alpha2, beta1=beta1, & + beta2=beta2, lambda1=lambda1, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE TensorProdBasis_Quadrangle2 +END PROCEDURE TensorProdBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! VertexBasis_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE VertexBasis_Quadrangle1 -ans(:, 1) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP - y) -ans(:, 2) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP - y) -ans(:, 3) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP + y) -ans(:, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y) +INTEGER(I4B) :: nrow, ncol +CALL VertexBasis_Quadrangle1_(x=x, y=y, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE VertexBasis_Quadrangle1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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_Quadrangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE VertexBasis_Quadrangle2 -ans(:, 1) = L1(:, 0) * L2(:, 0) -ans(:, 2) = L1(:, 1) * L2(:, 0) -ans(:, 3) = L1(:, 1) * L2(:, 1) -ans(:, 4) = L1(:, 0) * L2(:, 1) +INTEGER(I4B) :: nrow, ncol +CALL VertexBasis_Quadrangle2_(L1, L2, ans, nrow, ncol) END PROCEDURE VertexBasis_Quadrangle2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle2_ +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 PROCEDURE VertexBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle3 +INTEGER(I4B) :: nrow, ncol +CALL VertexBasis_Quadrangle3_(xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE VertexBasis_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle3_ +! ans = VertexBasis_Quadrangle1( & +CALL VertexBasis_Quadrangle1_(x=xij(1, :), y=xij(2, :), ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE VertexBasis_Quadrangle3_ + !---------------------------------------------------------------------------- ! VertexBasisGradient_Quadrangle2 !---------------------------------------------------------------------------- @@ -1204,59 +1287,80 @@ END PROCEDURE VertexBasisGradient_Quadrangle2 !---------------------------------------------------------------------------- -! VertexBasis_Quadrangle +! VerticalEdgeBasis_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE VertexBasis_Quadrangle3 -ans = VertexBasis_Quadrangle1( & - & x=xij(1, :), & - & y=xij(2, :)) -END PROCEDURE VertexBasis_Quadrangle3 +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle +INTEGER(I4B) :: nrow, ncol +CALL VerticalEdgeBasis_Quadrangle_(qe1, qe2, x, y, ans, nrow, ncol) +END PROCEDURE VerticalEdgeBasis_Quadrangle !---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle +! !---------------------------------------------------------------------------- -MODULE PROCEDURE VerticalEdgeBasis_Quadrangle -REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) -INTEGER(I4B) :: maxQ, k2, cnt +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle_ +! REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) +INTEGER(I4B) :: maxQ, k2, cnt, aint, bint +REAL(DFP), ALLOCATABLE :: L2(:, :) + +nrow = SIZE(x) +ncol = qe1 + qe2 - 2 maxQ = MAX(qe1, qe2) -L2 = LobattoEvalAll(n=maxQ, x=y) +ALLOCATE (L2(1:SIZE(y), 0:maxQ)) + +! L2 = LobattoEvalAll(n=maxQ, x=y) +CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) cnt = 0 DO k2 = 2, qe1 cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP - x) * L2(:, k2) + ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP - x(1:nrow)) * L2(1:nrow, k2) END DO DO k2 = 2, qe2 cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP + x) * L2(:, k2) + ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP + x(1:nrow)) * L2(1:nrow, k2) END DO -END PROCEDURE VerticalEdgeBasis_Quadrangle +DEALLOCATE (L2) + +END PROCEDURE VerticalEdgeBasis_Quadrangle_ !---------------------------------------------------------------------------- ! VerticalEdgeBasis_Quadrangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, ans, nrow, ncol) +END PROCEDURE VerticalEdgeBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2_ INTEGER(I4B) :: k2, cnt +nrow = SIZE(L1, 1) +ncol = qe1 + qe2 - 2 + cnt = 0 DO k2 = 2, qe1 cnt = cnt + 1 - ans(:, cnt) = L1(:, 0) * L2(:, k2) + ans(1:nrow, cnt) = L1(1:nrow, 0) * L2(1:nrow, k2) END DO + DO k2 = 2, qe2 cnt = cnt + 1 - ans(:, cnt) = L1(:, 1) * L2(:, k2) + ans(1:nrow, cnt) = L1(1:nrow, 1) * L2(1:nrow, k2) END DO -END PROCEDURE VerticalEdgeBasis_Quadrangle2 +END PROCEDURE VerticalEdgeBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! VerticalEdgeBasisGradient_Quadrangle @@ -1282,43 +1386,77 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle -REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4)) -INTEGER(I4B) :: maxP, k1, cnt +INTEGER(I4B) :: nrow, ncol +CALL HorizontalEdgeBasis_Quadrangle_(pe3, pe4, x, y, ans, nrow, ncol) +END PROCEDURE HorizontalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle_ +! REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4)) +INTEGER(I4B) :: maxP, k1, cnt, aint, bint +REAL(DFP), ALLOCATABLE :: L1(:, :) + +nrow = SIZE(x) +ncol = pe3 + pe4 - 2 maxP = MAX(pe3, pe4) -L1 = LobattoEvalAll(n=maxP, x=x) +ALLOCATE (L1(1:nrow, 0:maxP)) + +! L1 = LobattoEvalAll(n=maxP, x=x) +CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) cnt = 0 DO k1 = 2, pe3 cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP - y) * L1(:, k1) + ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP - y(1:nrow)) * L1(1:nrow, k1) END DO DO k1 = 2, pe4 cnt = cnt + 1 - ans(:, cnt) = 0.5_DFP * (1.0_DFP + y) * L1(:, k1) + ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP + y(1:nrow)) * L1(1:nrow, k1) END DO -END PROCEDURE HorizontalEdgeBasis_Quadrangle +DEALLOCATE (L1) + +END PROCEDURE HorizontalEdgeBasis_Quadrangle_ !---------------------------------------------------------------------------- ! HorizontalEdgeBasis_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HorizontalEdgeBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2_ INTEGER(I4B) :: k1, cnt + +nrow = SIZE(L1, 1) +ncol = pe3 + pe4 - 2 + cnt = 0 DO k1 = 2, pe3 cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 0) + ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, 0) END DO + DO k1 = 2, pe4 cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, 1) + ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, 1) END DO -END PROCEDURE HorizontalEdgeBasis_Quadrangle2 + +END PROCEDURE HorizontalEdgeBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! HorizontalEdgeBasisGradient_Quadrangle @@ -1344,38 +1482,69 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE CellBasis_Quadrangle +INTEGER(I4B) :: nrow, ncol +CALL CellBasis_Quadrangle_(pb=pb, qb=qb, x=x, y=y, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE CellBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle_ REAL(DFP) :: L1(1:SIZE(x), 0:pb) REAL(DFP) :: L2(1:SIZE(y), 0:qb) -INTEGER(I4B) :: k1, k2, cnt +INTEGER(I4B) :: k1, k2, cnt, aint, bint + +nrow = SIZE(x) +ncol = (pb - 1) * (qb - 1) + +! L1 = LobattoEvalAll(n=pb, x=x) +! L2 = LobattoEvalAll(n=qb, x=y) -L1 = LobattoEvalAll(n=pb, x=x) -L2 = LobattoEvalAll(n=qb, x=y) +CALL LobattoEvalAll_(n=pb, x=x, ans=L1, nrow=aint, ncol=bint) +CALL LobattoEvalAll_(n=qb, x=y, ans=L2, nrow=aint, ncol=bint) cnt = 0 DO k1 = 2, pb DO k2 = 2, qb cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) + ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, k2) END DO END DO -END PROCEDURE CellBasis_Quadrangle +END PROCEDURE CellBasis_Quadrangle_ !---------------------------------------------------------------------------- ! CellBasis_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE CellBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE CellBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle2_ INTEGER(I4B) :: k1, k2, cnt + +nrow = SIZE(L1, 1) +ncol = (pb - 1) * (qb - 1) + cnt = 0 + DO k1 = 2, pb DO k2 = 2, qb cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * L2(:, k2) + ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, k2) END DO END DO -END PROCEDURE CellBasis_Quadrangle2 +END PROCEDURE CellBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! CellBasisGradient_Quadrangle @@ -1398,10 +1567,23 @@ !---------------------------------------------------------------------------- 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) :: a, b, maxP, maxQ REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) +nrow = SIZE(xij, 2) +ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 + maxP = MAX(pe3, pe4, pb) maxQ = MAX(qe1, qe2, qb) @@ -1410,17 +1592,16 @@ ! Vertex basis function -ans(:, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) +ans(1:nrow, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) ! Edge basis function b = 4 -! IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN a = b + 1 b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 - ans(:, a:b) = VerticalEdgeBasis_Quadrangle2( & - & qe1=qe1, qe2=qe2, L1=L1, L2=L2) + ans(1:nrow, a:b) = VerticalEdgeBasis_Quadrangle2( & + qe1=qe1, qe2=qe2, L1=L1, L2=L2) END IF ! Edge basis function @@ -1428,8 +1609,8 @@ IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN a = b + 1 b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 - ans(:, a:b) = HorizontalEdgeBasis_Quadrangle2( & - & pe3=pe3, pe4=pe4, L1=L1, L2=L2) + ans(1:nrow, a:b) = HorizontalEdgeBasis_Quadrangle2( & + pe3=pe3, pe4=pe4, L1=L1, L2=L2) END IF ! Cell basis function @@ -1437,55 +1618,76 @@ IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN a = b + 1 b = a - 1 + (pb - 1) * (qb - 1) - ans(:, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) + ans(1:nrow, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) END IF -END PROCEDURE HeirarchicalBasis_Quadrangle1 + +END PROCEDURE HeirarchicalBasis_Quadrangle1_ !---------------------------------------------------------------------------- ! HeirarchicalBasis_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 -ans = HeirarchicalBasis_Quadrangle1(pb=p, pe3=p, pe4=p, & - & qb=q, qe1=q, qe2=q, xij=xij) +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_ + !---------------------------------------------------------------------------- ! LagrangeEvallAll_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Quadrangle1 +INTEGER(I4B) :: tsize +CALL LagrangeEvalAll_Quadrangle1_(order=order, x=x, xij=xij, & + ans=ans, tsize=tsize, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE LagrangeEvalAll_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle1_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: ii, basisType0, nrow, ncol INTEGER(I4B) :: degree(SIZE(xij, 2), 2) REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) +tsize = SIZE(xij, 2) + basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN - coeff = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = TRANSPOSE(coeff) - ELSE - coeff0 = TRANSPOSE(coeff) + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, & + beta=beta, lambda=lambda, & + ans=coeff, nrow=nrow, ncol=ncol) END IF + + ! coeff0 = TRANSPOSE(coeff) + coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) + ELSE - coeff0 = TRANSPOSE(LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & )) + + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff0, nrow=nrow, ncol=ncol) + ! coeff0 = TRANSPOSE(coeff0) + END IF SELECT CASE (basisType0) @@ -1493,27 +1695,28 @@ CASE (Monomial) degree = LagrangeDegree_Quadrangle(order=order) - tdof = SIZE(xij, 2) +! CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Quadrangle1", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + + IF (tsize .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Quadrangle1", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN END IF - DO ii = 1, tdof +#endif + + DO ii = 1, tsize xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) END DO CASE (Heirarchical) - xx = HeirarchicalBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=RESHAPE(x, [2, 1])) + ! xx = HeirarchicalBasis_Quadrangle( & + ! CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, & + ! xij=RESHAPE(x, [2, 1]), ans=xx, nrow=nrow, ncol=ncol) CASE DEFAULT @@ -1532,9 +1735,11 @@ END SELECT -ans = MATMUL(coeff0, xx(1, :)) +DO CONCURRENT(ii=1:tsize) + ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) +END DO -END PROCEDURE LagrangeEvalAll_Quadrangle1 +END PROCEDURE LagrangeEvalAll_Quadrangle1_ !---------------------------------------------------------------------------- ! LagrangeEvalAll_Quadrangle2 From 74327dd682d72f189f84b7cdca2ca0d9d98d6cce Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Jun 2024 20:02:15 +0900 Subject: [PATCH 105/359] Updates in QuadrangleInterpolationUtility --- ...QuadrangleInterpolationUtility@Methods.F90 | 70 ++++++++++++------- 1 file changed, 45 insertions(+), 25 deletions(-) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index f676a1e5a..5b045f769 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -841,12 +841,14 @@ MODULE PROCEDURE LagrangeCoeff_Quadrangle1_ REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info +INTEGER(I4B) :: info, nrow, ncol 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) +! 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_ @@ -916,22 +918,20 @@ MODULE PROCEDURE LagrangeCoeff_Quadrangle4_ INTEGER(I4B) :: basisType0, ii, jj, indx -nrow = SIZE(xij, 2) -ncol = nrow - basisType0 = Input(default=Monomial, option=basisType) IF (basisType0 .EQ. Heirarchical) THEN - ans(1:nrow, 1:ncol) = HeirarchicalBasis_Quadrangle2(p=order, q=order, & - xij=xij) + 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, & +! 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) + beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) CALL GetInvMat(ans(1:nrow, 1:ncol)) @@ -955,21 +955,23 @@ MODULE PROCEDURE LagrangeCoeff_Quadrangle5_ INTEGER(I4B) :: ii, jj, kk, indx, basisType(2) -nrow = SIZE(xij, 2) -ncol = nrow - 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) + ! 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, & +! 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) + basisType2=basisType(2), alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + ans=ans, nrow=nrow, ncol=ncol) CALL GetInvMat(ans(1:nrow, 1:ncol)) @@ -1578,8 +1580,10 @@ MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_ INTEGER(I4B) :: a, b, maxP, maxQ -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) +! REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) +! REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) + +REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) nrow = SIZE(xij, 2) ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 @@ -1587,12 +1591,18 @@ maxP = MAX(pe3, pe4, pb) maxQ = MAX(qe1, qe2, qb) -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) +ALLOCATE (L1(1:nrow, 0:maxP), L2(1:nrow, 0:maxQ)) + +! L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) +! L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) + +CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=a, ncol=b) +CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=a, ncol=b) ! Vertex basis function -ans(1:nrow, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) +! ans(1:nrow, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) +CALL VertexBasis_Quadrangle2_(L1=L1, L2=L2, ans=ans, nrow=maxP, ncol=maxQ) ! Edge basis function @@ -1600,8 +1610,11 @@ IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN a = b + 1 b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 - ans(1:nrow, a:b) = VerticalEdgeBasis_Quadrangle2( & - qe1=qe1, qe2=qe2, L1=L1, L2=L2) + ! ans(1:nrow, a:b) = VerticalEdgeBasis_Quadrangle2( & + ! qe1=qe1, qe2=qe2, L1=L1, L2=L2) + + CALL VerticalEdgeBasis_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, L2=L2, & + ans=ans(:, a:), nrow=maxP, ncol=maxQ) END IF ! Edge basis function @@ -1609,8 +1622,11 @@ IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN a = b + 1 b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 - ans(1:nrow, a:b) = HorizontalEdgeBasis_Quadrangle2( & - pe3=pe3, pe4=pe4, L1=L1, L2=L2) + ! ans(1:nrow, a:b) = HorizontalEdgeBasis_Quadrangle2( & + ! pe3=pe3, pe4=pe4, L1=L1, L2=L2) + + CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & + ans=ans(:, a:), nrow=maxP, ncol=maxQ) END IF ! Cell basis function @@ -1618,9 +1634,13 @@ IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN a = b + 1 b = a - 1 + (pb - 1) * (qb - 1) - ans(1:nrow, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) + ! ans(1:nrow, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) + CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, & + ans=ans(:, a:), nrow=maxP, ncol=maxQ) END IF +DEALLOCATE (L1, L2) + END PROCEDURE HeirarchicalBasis_Quadrangle1_ !---------------------------------------------------------------------------- From a6ac44895676d4d89aa6f60bd0a7aa2bf4c8ea19 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 01:17:33 +0900 Subject: [PATCH 106/359] Updates in MappingUtility --- src/modules/Utility/src/MappingUtility.F90 | 47 +++++++++++++ .../Utility/src/MappingUtility@Methods.F90 | 68 ++++++++++++++++--- 2 files changed, 104 insertions(+), 11 deletions(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 25bba0e8f..d961eae5c 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -79,8 +79,11 @@ MODULE MappingUtility PUBLIC :: FromUnitTetrahedron2Tetrahedron_ PUBLIC :: FromBiUnitTetrahedron2Tetrahedron PUBLIC :: BarycentricCoordUnitTetrahedron +PUBLIC :: BarycentricCoordUnitTetrahedron_ PUBLIC :: BarycentricCoordBiUnitTetrahedron +PUBLIC :: BarycentricCoordBiUnitTetrahedron_ PUBLIC :: BarycentricCoordTetrahedron +PUBLIC :: BarycentricCoordTetrahedron_ PUBLIC :: FromBiUnitTetrahedron2BiUnitHexahedron PUBLIC :: FromBiUnitHexahedron2BiUnitTetrahedron PUBLIC :: FromUnitTetrahedron2BiUnitHexahedron @@ -842,6 +845,20 @@ MODULE PURE FUNCTION BarycentricCoordUnitTetrahedron(xin) RESULT(ans) END FUNCTION BarycentricCoordUnitTetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCoordUnitTetrahedron_(xin, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(4, SIZE(xin, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricCoordUnitTetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricCoordBiUnitTetrahedron !---------------------------------------------------------------------------- @@ -857,6 +874,20 @@ MODULE PURE FUNCTION BarycentricCoordBiUnitTetrahedron(xin) RESULT(ans) END FUNCTION BarycentricCoordBiUnitTetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCoordBiUnitTetrahedron_(xin, & + ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(4, SIZE(xin, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricCoordBiUnitTetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricCoordTetrahedron !---------------------------------------------------------------------------- @@ -871,6 +902,22 @@ MODULE PURE FUNCTION BarycentricCoordTetrahedron(xin, refTetrahedron) RESULT(ans END FUNCTION BarycentricCoordTetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCoordTetrahedron_(xin, refTetrahedron, & + ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" "BIUNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(4, SIZE(xin, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricCoordTetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! FromBiUnitTetrahedron2BiUnitHexahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index 1a0ac6a36..7a478de7a 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -525,35 +525,81 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricCoordUnitTetrahedron -ans(1, :) = 1.0_DFP - xin(1, :) - xin(2, :) - xin(3, :) -ans(2, :) = xin(1, :) -ans(3, :) = xin(2, :) -ans(4, :) = xin(3, :) +INTEGER(I4B) :: nrow, ncol +CALL BarycentricCoordUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE BarycentricCoordUnitTetrahedron +!---------------------------------------------------------------------------- +! BarycentricCoordUnitTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordUnitTetrahedron_ +INTEGER(I4B) :: ii + +nrow = 4 +ncol = SIZE(xin, 2) + +DO CONCURRENT(ii=1:ncol) + ans(1, ii) = 1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii) + ans(2, ii) = xin(1, ii) + ans(3, ii) = xin(2, ii) + ans(4, ii) = xin(3, ii) +END DO +END PROCEDURE BarycentricCoordUnitTetrahedron_ + !---------------------------------------------------------------------------- ! BarycentricCoordBiUnitTetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricCoordBiUnitTetrahedron -ans(1, :) = -0.5_DFP * (1.0_DFP + xin(1, :) + xin(2, :) + xin(3, :)) -ans(2, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) -ans(3, :) = 0.5_DFP * (1.0_DFP + xin(2, :)) -ans(4, :) = 0.5_DFP * (1.0_DFP + xin(3, :)) +INTEGER(I4B) :: nrow, ncol +CALL BarycentricCoordBiUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, & + ncol=ncol) END PROCEDURE BarycentricCoordBiUnitTetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordBiUnitTetrahedron_ +INTEGER(I4B) :: ii + +nrow = 4 +ncol = SIZE(xin, 2) + +DO CONCURRENT(ii=1:ncol) + ans(1, ii) = -0.5_DFP * (1.0_DFP + xin(1, ii) + xin(2, ii) + xin(3, ii)) + ans(2, ii) = 0.5_DFP * (1.0_DFP + xin(1, ii)) + ans(3, ii) = 0.5_DFP * (1.0_DFP + xin(2, ii)) + ans(4, ii) = 0.5_DFP * (1.0_DFP + xin(3, ii)) +END DO + +END PROCEDURE BarycentricCoordBiUnitTetrahedron_ + !---------------------------------------------------------------------------- ! BarycentricCoordTetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricCoordTetrahedron +INTEGER(I4B) :: nrow, ncol +CALL BarycentricCoordTetrahedron_(xin=xin, refTetrahedron=refTetrahedron, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricCoordTetrahedron + +!---------------------------------------------------------------------------- +! BarycentricCoordTetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordTetrahedron_ SELECT CASE (refTetrahedron(1:1)) CASE ("B", "b") - ans = BarycentricCoordBiUnitTetrahedron(xin) + CALL BarycentricCoordBiUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, & + ncol=ncol) CASE ("U", "u") - ans = BarycentricCoordUnitTetrahedron(xin) + CALL BarycentricCoordUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, & + ncol=ncol) END SELECT -END PROCEDURE BarycentricCoordTetrahedron +END PROCEDURE BarycentricCoordTetrahedron_ !---------------------------------------------------------------------------- ! FromBiUnitTetrahedron2BiUnitHexahedron From ecfc97bbe3f0022768ff7867ced0c7a16423a7f1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 15:08:52 +0900 Subject: [PATCH 107/359] updates in TetrahedronInterpolationUtility --- .../src/TetrahedronInterpolationUtility.F90 | 717 +++++++++++-- ...etrahedronInterpolationUtility@Methods.F90 | 998 +++++++++++------- 2 files changed, 1203 insertions(+), 512 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index a18706c06..fa1554ece 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -27,8 +27,7 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: EquidistanceInPoint_Tetrahedron PUBLIC :: EquidistancePoint_Tetrahedron PUBLIC :: LagrangeCoeff_Tetrahedron -! PUBLIC :: Isaac_Tetrahedron -! PUBLIC :: BlythPozrikidis_Tetrahedron +PUBLIC :: LagrangeCoeff_Tetrahedron_ PUBLIC :: InterpolationPoint_Tetrahedron PUBLIC :: InterpolationPoint_Tetrahedron_ PUBLIC :: OrthogonalBasis_Tetrahedron @@ -49,6 +48,7 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: GetFacetDOF_Tetrahedron PUBLIC :: GetCellDOF_Tetrahedron PUBLIC :: LagrangeEvalAll_Tetrahedron +PUBLIC :: LagrangeEvalAll_Tetrahedron_ PUBLIC :: QuadraturePoint_Tetrahedron PUBLIC :: RefElemDomain_Tetrahedron PUBLIC :: LagrangeGradientEvalAll_Tetrahedron @@ -281,6 +281,18 @@ MODULE PURE FUNCTION LagrangeDegree_Tetrahedron(order) RESULT(ans) END FUNCTION LagrangeDegree_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE LagrangeDegree_Tetrahedron_(order, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeDegree_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! LagrangeDOF_Tetrahedron !---------------------------------------------------------------------------- @@ -822,6 +834,34 @@ MODULE FUNCTION OrthogonalBasis_Tetrahedron1( & END FUNCTION OrthogonalBasis_Tetrahedron1 END INTERFACE OrthogonalBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE OrthogonalBasis_Tetrahedron_ + MODULE SUBROUTINE OrthogonalBasis_Tetrahedron1_(order, xij, & + refTetrahedron, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in reference Tetrahedron. + !! The shape functions will be evaluated + !! at these points. + !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" + !! "BIUNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns + !! nrow = SIZE(xij, 2) + !! ncol = (order + 1) * (order + 2) * (order + 3) / 6 + END SUBROUTINE OrthogonalBasis_Tetrahedron1_ +END INTERFACE OrthogonalBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! OrthogonalBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -854,6 +894,34 @@ MODULE FUNCTION OrthogonalBasis_Tetrahedron2( & END FUNCTION OrthogonalBasis_Tetrahedron2 END INTERFACE OrthogonalBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE OrthogonalBasis_Tetrahedron_ + MODULE SUBROUTINE OrthogonalBasis_Tetrahedron2_(order, x, y, z, & + refTetrahedron, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:) + !! x coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) + REAL(DFP), INTENT(IN) :: y(:) + !! y coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) + REAL(DFP), INTENT(IN) :: z(:) + !! z coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z) + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" + !! "BIUNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x) * SIZE(y) * SIZE(z) + !! ncol = (order + 1) * (order + 2) * (order + 3) / 6 + END SUBROUTINE OrthogonalBasis_Tetrahedron2_ +END INTERFACE OrthogonalBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! BarycentricVertexBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -874,6 +942,24 @@ MODULE PURE FUNCTION BarycentricVertexBasis_Tetrahedron(lambda) & END FUNCTION BarycentricVertexBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricVertexBasis_Tetrahedron_(lambda, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + !! number of rows = 4 + !! number of columns = number of points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(lambda, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricVertexBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricVertexBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -884,7 +970,7 @@ END FUNCTION BarycentricVertexBasis_Tetrahedron INTERFACE MODULE PURE FUNCTION BarycentricVertexBasisGradient_Tetrahedron(lambda) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: lambda(:, :) !! point of evaluation in terms of barycentrix coords !! number of rows = 4 @@ -911,15 +997,8 @@ END FUNCTION BarycentricVertexBasisGradient_Tetrahedron ! pe1, pe2, pe3 should be greater than or equal to 2 INTERFACE - MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & lambda & - & ) RESULT(ans) + MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron(pe1, pe2, pe3, pe4, & + pe5, pe6, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe1 !! order on edge parallel to x INTEGER(I4B), INTENT(IN) :: pe2 @@ -941,6 +1020,35 @@ MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron( & END FUNCTION BarycentricEdgeBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricEdgeBasis_Tetrahedron_(pe1, pe2, pe3, & + pe4, pe5, pe6, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order on edge parallel to yz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(lambda, 2) + !! ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricEdgeBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricEdgeBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -950,15 +1058,8 @@ END FUNCTION BarycentricEdgeBasis_Tetrahedron ! summary: Evaluate the edge basis on Tetrahedron in terms of barycentric INTERFACE - MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2( & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & lambda, & - & phi) RESULT(ans) + MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2(pe1, pe2, pe3, & + pe4, pe5, pe6, lambda, phi) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe1 !! order on edge parallel to x INTEGER(I4B), INTENT(IN) :: pe2 @@ -986,6 +1087,41 @@ MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2( & END FUNCTION BarycentricEdgeBasis_Tetrahedron2 END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricEdgeBasis_Tetrahedron2_(pe1, pe2, pe3, & + pe4, pe5, pe6, lambda, phi, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order on edge parallel to yz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 4 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(lambda, 2) + !! ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricEdgeBasis_Tetrahedron2_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricEdgeBasisGradient_Tetrahedron !---------------------------------------------------------------------------- @@ -1084,6 +1220,32 @@ MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron( & END FUNCTION BarycentricFacetBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricFacetBasis_Tetrahedron_(ps1, ps2, ps3, & + ps4, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: ps1 + !! order on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order on facet parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(lambda, 2) + !! ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 & + !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2 + END SUBROUTINE BarycentricFacetBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricFacetBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -1126,6 +1288,37 @@ MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron2( & END FUNCTION BarycentricFacetBasis_Tetrahedron2 END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricFacetBasis_Tetrahedron2_(ps1, ps2, ps3, & + ps4, lambda, phi, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: ps1 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order on edge parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(lambda, 2) + !! ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 & + !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricFacetBasis_Tetrahedron2_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricFacetBasisGradient_Tetrahedron !---------------------------------------------------------------------------- @@ -1209,6 +1402,25 @@ MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron( & END FUNCTION BarycentricCellBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCellBasis_Tetrahedron_(pb, lambda, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order on facet parallel to xy + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(lambda, 2) + !! ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B + END SUBROUTINE BarycentricCellBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricCellBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -1240,6 +1452,34 @@ MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron2( & END FUNCTION BarycentricCellBasis_Tetrahedron2 END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE BarycentricCellBasis_Tetrahedron2_(pb, lambda, phi, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order on facet parallel to xy + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to 4 + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! Value of lobatto kernel values + !! size(phi1, 1) = 6*number of points + !! - (lambda2-lambda1) + !! - (lambda3-lambda1) + !! - (lambda4-lambda1) + !! - (lambda3-lambda2) + !! - (lambda4-lambda2) + !! - (lambda4-lambda3) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(lambda, 2) + !! ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B + END SUBROUTINE BarycentricCellBasis_Tetrahedron2_ +END INTERFACE + !---------------------------------------------------------------------------- ! BarycentricCellBasisGradient_Tetrahedron !---------------------------------------------------------------------------- @@ -1293,20 +1533,8 @@ END FUNCTION BarycentricCellBasisGradient_Tetrahedron2 ! summary: Evaluate all modal basis (heirarchical polynomial) on Tetrahedron INTERFACE BarycentricHeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & lambda & - & ) RESULT(ans) + MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1(order, & + pe1, pe2, pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 INTEGER(I4B), INTENT(IN) :: pe1 @@ -1346,28 +1574,12 @@ END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1 END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron !---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasisGradient_Tetrahedron +! !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Gradient of heirarchical basis in terms of barycentric coord - -INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron - MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & lambda & - & ) RESULT(ans) +INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_ + MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron1_(order, & + pe1, pe2, pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, lambda, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 INTEGER(I4B), INTENT(IN) :: pe1 @@ -1394,17 +1606,15 @@ MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( & !! Barycenteric coordinates !! number of rows = 4 !! number of cols = number of points - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & 4 & - & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & - & + (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2 & - & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 4_I4B) - END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1 -END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(lambda, 2) + !! ncol = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + !! + (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 & + !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2 & + !! + (order - 1) * (order - 2) * (order - 3) / 6_I4B + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron1_ +END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_ !---------------------------------------------------------------------------- ! @@ -1415,20 +1625,88 @@ END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1 ! summary: Evaluate heirarchical basis in terms of barycentric coord INTERFACE BarycentricHeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2( & - & order, lambda) RESULT(ans) + MODULE PURE FUNCTION & + BarycentricHeirarchicalBasis_Tetrahedron2(order, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 REAL(DFP), INTENT(IN) :: lambda(:, :) !! Barycenteric coordinates !! number of rows = 4 !! number of cols = number of points - REAL(DFP) :: ans( & - & SIZE(lambda, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6_I4B) + REAL(DFP) :: ans(SIZE(lambda, 2), & + (order + 1) * (order + 2) * (order + 3) / 6_I4B) END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2 END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_ + MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron2_( & + order, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 4 + !! number of cols = number of points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(lambda, 2) + !! ncol = (order + 1) * (order + 2) * (order + 3) / 6_I4B + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron2_ +END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_ + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Gradient of heirarchical basis in terms of barycentric coord + +INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron + MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( & + order, pe1, pe2, pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order of interpolation on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order of interpolation on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps1 + !! order of interpolation on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order of interpolation on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order of interpolation on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order of interpolation on facet parallel to xyz + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 4 + !! number of cols = number of points + REAL(DFP) :: ans( & + & SIZE(lambda, 2), & + & 4 & + & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + & + (ps1 - 1) * (ps1 - 2) / 2 & + & + (ps2 - 1) * (ps2 - 2) / 2 & + & + (ps3 - 1) * (ps3 - 2) / 2 & + & + (ps4 - 1) * (ps4 - 2) / 2 & + & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 4_I4B) + END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1 +END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron + !---------------------------------------------------------------------------- ! BarycentricHeirarchicalBasisGradient_Tetrahedron !---------------------------------------------------------------------------- @@ -1473,6 +1751,24 @@ MODULE PURE FUNCTION VertexBasis_Tetrahedron(xij, refTetrahedron) & END FUNCTION VertexBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE VertexBasis_Tetrahedron_(xij, refTetrahedron, & + ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Unit or biunit + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! ans(SIZE(xij, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END SUBROUTINE VertexBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! EdgeBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -1514,6 +1810,37 @@ MODULE PURE FUNCTION EdgeBasis_Tetrahedron( & END FUNCTION EdgeBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE EdgeBasis_Tetrahedron_(pe1, pe2, pe3, pe4, pe5, & + pe6, xij, refTetrahedron, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order on edge parallel to yz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xij, 2) + !! ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 + END SUBROUTINE EdgeBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! FacetBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -1552,6 +1879,34 @@ MODULE PURE FUNCTION FacetBasis_Tetrahedron( & END FUNCTION FacetBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE FacetBasis_Tetrahedron_(ps1, ps2, ps3, ps4, xij, & + refTetrahedron, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: ps1 + !! order on facet to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order on facet to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order on facet to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order on facet to xyz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xij, 2) + !! ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 & + !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2 + END SUBROUTINE FacetBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! CellBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -1578,6 +1933,28 @@ MODULE PURE FUNCTION CellBasis_Tetrahedron( & END FUNCTION CellBasis_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE CellBasis_Tetrahedron_(pb, xij, refTetrahedron, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order in cell + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + !! nrow = SIZE(xij, 2) + !! ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B + END SUBROUTINE CellBasis_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -1640,6 +2017,49 @@ MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1( & END FUNCTION HeirarchicalBasis_Tetrahedron1 END INTERFACE HeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Tetrahedron_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Tetrahedron1_(order, pe1, pe2, & + pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order of interpolation on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order of interpolation on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps1 + !! order of interpolation on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order of interpolation on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order of interpolation on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order of interpolation on facet parallel to xyz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2), + !! ncol = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 + (ps1 - 1) * (ps1 - 2) / 2 + !! + (ps2 - 1) * (ps2 - 2) / 2 + (ps3 - 1) * (ps3 - 2) / 2 & + !! + (ps4 - 1) * (ps4 - 2) / 2 + (order - 1) * (order - 2) * (order - 3) / 6_I4B) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Tetrahedron1_ +END INTERFACE HeirarchicalBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Tetrahedron !---------------------------------------------------------------------------- @@ -1666,6 +2086,26 @@ MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2( & END FUNCTION HeirarchicalBasis_Tetrahedron2 END INTERFACE HeirarchicalBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Tetrahedron_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Tetrahedron2_(order, xij, & + refTetrahedron, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2) + !! ncol = (order + 1) * (order + 2) * (order + 3) / 6_I4B) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Tetrahedron2_ +END INTERFACE HeirarchicalBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Tetrahedron !---------------------------------------------------------------------------- @@ -1675,17 +2115,9 @@ END FUNCTION HeirarchicalBasis_Tetrahedron2 ! summary: Evaluate all Lagrange polynomials at several points INTERFACE LagrangeEvalAll_Tetrahedron - MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( & - & order, & - & x, & - & xij, & - & refTetrahedron, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Tetrahedron1(order, x, xij, & + refTetrahedron, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(3) @@ -1711,13 +2143,6 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( & !! Default value of firstCall is True INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - !! Orthogonal REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1729,6 +2154,54 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( & END FUNCTION LagrangeEvalAll_Tetrahedron1 END INTERFACE LagrangeEvalAll_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Tetrahedron_ + MODULE SUBROUTINE LagrangeEvalAll_Tetrahedron1_(order, x, xij, ans, & + tsize, refTetrahedron, coeff, firstCall, basisType, alpha, beta, & + lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Value of n+1 Lagrange polynomials at point x + !! size(xij, 2) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total data written in ans + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be computed and returned + !! by this routine. + !! If firstCall is False, then coeff should be given, which will be + !! used. + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Tetrahedron1_ +END INTERFACE LagrangeEvalAll_Tetrahedron_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Tetrahedron !---------------------------------------------------------------------------- @@ -1738,18 +2211,9 @@ END FUNCTION LagrangeEvalAll_Tetrahedron1 ! summary: Evaluate all Lagrange polynomials at several points INTERFACE LagrangeEvalAll_Tetrahedron - MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( & - & order, & - & x, & - & xij, & - & refTetrahedron, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, & - & beta, & - & lambda & - & ) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Tetrahedron2(order, x, xij, & + refTetrahedron, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1770,6 +2234,51 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( & !! Default value of firstCall is True INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType !! Monomials *Default + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Tetrahedron2 +END INTERFACE LagrangeEvalAll_Tetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Tetrahedron_ + MODULE SUBROUTINE LagrangeEvalAll_Tetrahedron2_(order, x, xij, ans, & + nrow, ncol, refTetrahedron, coeff, firstCall, basisType, alpha, beta, & + lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns writen in ans + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + ! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default !! Legendre !! Lobatto !! Chebyshev @@ -1783,10 +2292,8 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( & !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Tetrahedron2 -END INTERFACE LagrangeEvalAll_Tetrahedron + END SUBROUTINE LagrangeEvalAll_Tetrahedron2_ +END INTERFACE LagrangeEvalAll_Tetrahedron_ !---------------------------------------------------------------------------- ! QuadraturePoints_Tetrahedron diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index f3bf50d4d..d01863753 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -172,9 +172,23 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeDegree_Tetrahedron -INTEGER(I4B) :: n, ii, jj, kk, ll -n = LagrangeDOF_Tetrahedron(order=order) -ALLOCATE (ans(n, 3)) +INTEGER(I4B) :: nrow, ncol +nrow = LagrangeDOF_Tetrahedron(order=order) +ncol = 3 +ALLOCATE (ans(nrow, ncol)) +CALL LagrangeDegree_Tetrahedron_(order=order, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeDegree_Tetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Tetrahedron_ +INTEGER(I4B) :: ii, jj, kk, ll + +nrow = LagrangeDOF_Tetrahedron(order=order) +ncol = 3 + ll = 0 DO kk = 0, order DO jj = 0, order @@ -188,7 +202,8 @@ END DO END DO END DO -END PROCEDURE LagrangeDegree_Tetrahedron + +END PROCEDURE LagrangeDegree_Tetrahedron_ !---------------------------------------------------------------------------- ! LagrangeDOF_Tetrahedron @@ -1091,6 +1106,16 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE OrthogonalBasis_Tetrahedron1 +INTEGER(I4B) :: nrow, ncol +CALL OrthogonalBasis_Tetrahedron1_(order=order, xij=xij, & + refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE OrthogonalBasis_Tetrahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Tetrahedron1_ CHARACTER(20) :: layout REAL(DFP) :: x(1:3, 1:SIZE(xij, 2)) REAL(DFP) :: P1(SIZE(xij, 2), 0:order) @@ -1099,7 +1124,10 @@ END SUBROUTINE IJK2VEFC_Triangle REAL(DFP) :: x2(SIZE(xij, 2), 0:order) REAL(DFP) :: x3(SIZE(xij, 2), 0:order) INTEGER(I4B) :: cnt -INTEGER(I4B) :: p, q, r +INTEGER(I4B) :: p, q, r, indx(7) + +nrow = SIZE(xij, 2) +ncol = (order + 1) * (order + 2) * (order + 3) / 6 layout = TRIM(UpperCase(refTetrahedron)) SELECT CASE (TRIM(layout)) @@ -1114,40 +1142,52 @@ END SUBROUTINE IJK2VEFC_Triangle x3(:, p) = 0.5_DFP * (1.0_DFP - x(3, :)) END DO -P1 = LegendreEvalAll(n=order, x=x(1, :)) +! P1 = LegendreEvalAll(n=order, x=x(1, :)) +CALL LegendreEvalAll_(n=order, x=x(1, :), ans=P1, nrow=indx(1), ncol=indx(2)) cnt = 0 DO p = 0, order Q1 = (x2**p) * JacobiEvalAll( & - & n=order, & - & x=x(2, :), & - & alpha=REAL(2 * p + 1, DFP), & - & beta=0.0_DFP) + n=order, & + x=x(2, :), & + alpha=REAL(2 * p + 1, DFP), & + beta=0.0_DFP) DO q = 0, order - p R1 = (x3**(p + q)) * JacobiEvalAll( & - & n=order, & - & x=x(3, :), & - & alpha=REAL(2 * p + 2 * q + 2, DFP), & - & beta=0.0_DFP) + n=order, & + x=x(3, :), & + alpha=REAL(2 * p + 2 * q + 2, DFP), & + beta=0.0_DFP) DO r = 0, order - p - q cnt = cnt + 1 - ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r) + ans(1:nrow, cnt) = P1(1:nrow, p) * Q1(1:nrow, q) * R1(1:nrow, r) END DO END DO + END DO -END PROCEDURE OrthogonalBasis_Tetrahedron1 +END PROCEDURE OrthogonalBasis_Tetrahedron1_ !---------------------------------------------------------------------------- ! OrthogonalBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE OrthogonalBasis_Tetrahedron2 +INTEGER(I4B) :: nrow, ncol +CALL OrthogonalBasis_Tetrahedron2_(order=order, x=x, y=y, z=z, & + refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE OrthogonalBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Tetrahedron2_ CHARACTER(20) :: layout REAL(DFP) :: x0(SIZE(x)), y0(SIZE(y)), z0(SIZE(z)) REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z)) @@ -1159,6 +1199,9 @@ END SUBROUTINE IJK2VEFC_Triangle REAL(DFP) :: x3(SIZE(xij, 2), 0:order) INTEGER(I4B) :: p, q, r +nrow = SIZE(x) * SIZE(y) * SIZE(z) +ncol = (order + 1) * (order + 2) * (order + 3) / 6 + layout = TRIM(UpperCase(refTetrahedron)) SELECT CASE (TRIM(layout)) @@ -1212,21 +1255,37 @@ END SUBROUTINE IJK2VEFC_Triangle DO r = 0, order - p - q cnt = cnt + 1 - ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r) + ans(1:nrow, cnt) = P1(:, p) * Q1(:, q) * R1(:, r) END DO END DO END DO -END PROCEDURE OrthogonalBasis_Tetrahedron2 +END PROCEDURE OrthogonalBasis_Tetrahedron2_ !---------------------------------------------------------------------------- ! BarycentricVertexBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricVertexBasis_Tetrahedron -ans = TRANSPOSE(lambda(1:4, :)) +INTEGER(I4B) :: nrow, ncol +CALL BarycentricVertexBasis_Tetrahedron_(lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE BarycentricVertexBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricVertexBasis_Tetrahedron_ +INTEGER(I4B) :: ii, jj +nrow = SIZE(lambda, 2) +ncol = 4 + +DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = lambda(jj, ii) +END DO +END PROCEDURE BarycentricVertexBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! BarycentricVertexBasisGradient_Tetrahedron !---------------------------------------------------------------------------- @@ -1245,127 +1304,125 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron -REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) -REAL(DFP) :: phi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & pe1 - 2, & - & pe2 - 2, & - & pe3 - 2, & - & pe4 - 2, & - & pe5 - 2, & - & pe6 - 2)) -INTEGER(I4B) :: maxP, tPoints, i1, i2 +INTEGER(I4B) :: nrow, ncol +CALL BarycentricEdgeBasis_Tetrahedron_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + pe5=pe5, pe6=pe6, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricEdgeBasis_Tetrahedron -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) +MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron_ +REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) +REAL(DFP), ALLOCATABLE :: phi(:, :) +INTEGER(I4B) :: maxP, indx(7) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) +nrow = SIZE(lambda, 2) +ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, pe4 - 2, pe5 - 2, pe6 - 2) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) +indx(1) = 6 * nrow +ALLOCATE (phi(1:indx(1), 0:maxP)) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) +indx = [0, 1, 2, 3, 4, 5, 6] * nrow -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) +d_lambda(indx(1) + 1:indx(2)) = lambda(2, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(2) + 1:indx(3)) = lambda(3, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(3) + 1:indx(4)) = lambda(4, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(4) + 1:indx(5)) = lambda(3, 1:nrow) - lambda(2, 1:nrow) +d_lambda(indx(5) + 1:indx(6)) = lambda(4, 1:nrow) - lambda(2, 1:nrow) +d_lambda(indx(6) + 1:indx(7)) = lambda(4, 1:nrow) - lambda(3, 1:nrow) -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol) -ans = BarycentricEdgeBasis_Tetrahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & lambda=lambda, & - & phi=phi & - & ) +! ans = BarycentricEdgeBasis_Tetrahedron2 +CALL BarycentricEdgeBasis_Tetrahedron2_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + pe5=pe5, pe6=pe6, lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE BarycentricEdgeBasis_Tetrahedron +DEALLOCATE (phi) + +END PROCEDURE BarycentricEdgeBasis_Tetrahedron_ !---------------------------------------------------------------------------- ! BarycentricEdgeBasis_Tetrahedron2 !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron2 -INTEGER(I4B) :: tPoints, a, ii, i1, i2 +INTEGER(I4B) :: nrow, ncol +CALL BarycentricEdgeBasis_Tetrahedron2_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, & + pe5=pe5, pe6=pe6, lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricEdgeBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron2_ +INTEGER(I4B) :: a, ii, i1, i2 REAL(DFP) :: temp(SIZE(lambda, 2)) -ans = 0.0_DFP -tPoints = SIZE(temp) +nrow = SIZE(lambda, 2) +ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 !! edge(1) = (v1, v2) a = 0 -temp = lambda(1, :) * lambda(2, :) +temp = lambda(1, 1:nrow) * lambda(2, 1:nrow) i1 = 1 -i2 = i1 + tPoints - 1 +i2 = i1 + nrow - 1 DO ii = 1, pe1 - 1 a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) + ans(1:nrow, a) = temp * phi(i1:i2, ii - 1) END DO !! edge(2) = (v1, v3) -temp = lambda(1, :) * lambda(3, :) +temp = lambda(1, 1:nrow) * lambda(3, 1:nrow) i1 = i2 + 1 -i2 = i1 + tPoints - 1 +i2 = i1 + nrow - 1 DO ii = 1, pe2 - 1 a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) + ans(1:nrow, a) = temp * phi(i1:i2, ii - 1) END DO !! edge(3) = (v1, v4) -temp = lambda(1, :) * lambda(4, :) +temp = lambda(1, 1:nrow) * lambda(4, 1:nrow) i1 = i2 + 1 -i2 = i1 + tPoints - 1 +i2 = i1 + nrow - 1 DO ii = 1, pe3 - 1 a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) + ans(1:nrow, a) = temp * phi(i1:i2, ii - 1) END DO !! edge(4) = (v2, v3) -temp = lambda(2, :) * lambda(3, :) +temp = lambda(2, 1:nrow) * lambda(3, 1:nrow) i1 = i2 + 1 -i2 = i1 + tPoints - 1 +i2 = i1 + nrow - 1 DO ii = 1, pe4 - 1 a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) + ans(1:nrow, a) = temp * phi(i1:i2, ii - 1) END DO !! edge(5) = (v2, v4) -temp = lambda(2, :) * lambda(4, :) +temp = lambda(2, 1:nrow) * lambda(4, 1:nrow) i1 = i2 + 1 -i2 = i1 + tPoints - 1 +i2 = i1 + nrow - 1 DO ii = 1, pe5 - 1 a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) + ans(1:nrow, a) = temp * phi(i1:i2, ii - 1) END DO !! edge(5) = (v3, v4) -temp = lambda(3, :) * lambda(4, :) +temp = lambda(3, 1:nrow) * lambda(4, 1:nrow) i1 = i2 + 1 -i2 = i1 + tPoints - 1 +i2 = i1 + nrow - 1 DO ii = 1, pe6 - 1 a = a + 1 - ans(:, a) = temp * phi(i1:i2, ii - 1) + ans(1:nrow, a) = temp * phi(i1:i2, ii - 1) END DO -END PROCEDURE BarycentricEdgeBasis_Tetrahedron2 +END PROCEDURE BarycentricEdgeBasis_Tetrahedron2_ !---------------------------------------------------------------------------- ! BarycentricEdgeBasisGradient_Tetrahedron2 @@ -1373,7 +1430,7 @@ END SUBROUTINE IJK2VEFC_Triangle MODULE PROCEDURE BarycentricEdgeBasisGradient_Tetrahedron2 INTEGER(I4B) :: a, ii, i1, i2, edges(2, 6), orders(6), iedge, v1, v2, & - & tPoints + tPoints REAL(DFP) :: temp(SIZE(lambda, 2), 6) tPoints = SIZE(lambda, 2) @@ -1408,98 +1465,114 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron +INTEGER(I4B) :: nrow, ncol +CALL BarycentricFacetBasis_Tetrahedron_(ps1=ps1, ps2=ps2, ps3=ps3, & + ps4=ps4, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricFacetBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron_ REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) -REAL(DFP) :: phi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & ps1 - 1, & - & ps2 - 1, & - & ps3 - 1, & - & ps4 - 1)) -INTEGER(I4B) :: maxP, tPoints, i1, i2 +REAL(DFP), ALLOCATABLE :: phi(:, :) -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1 +INTEGER(I4B) :: maxP, indx(7) -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) +nrow = SIZE(lambda, 2) +ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 & + + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2 -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) +indx(1) = 6 * nrow +maxP = MAX(ps1 - 1, ps2 - 1, ps3 - 1, ps4 - 1) +ALLOCATE (phi(1:indx(1), 0:maxP)) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) +indx = [0, 1, 2, 3, 4, 5, 6] * nrow -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) +d_lambda(indx(1) + 1:indx(2)) = lambda(2, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(2) + 1:indx(3)) = lambda(3, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(3) + 1:indx(4)) = lambda(4, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(4) + 1:indx(5)) = lambda(3, 1:nrow) - lambda(2, 1:nrow) +d_lambda(indx(5) + 1:indx(6)) = lambda(4, 1:nrow) - lambda(2, 1:nrow) +d_lambda(indx(6) + 1:indx(7)) = lambda(4, 1:nrow) - lambda(3, 1:nrow) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) +! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) +! ans = BarycentricFacetBasis_Tetrahedron2( & +CALL BarycentricFacetBasis_Tetrahedron2_(ps1=ps1, ps2=ps2, ps3=ps3, & + ps4=ps4, lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol) -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) -ans = BarycentricFacetBasis_Tetrahedron2( & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4, & - & lambda=lambda, & - & phi=phi) +DEALLOCATE (phi) -END PROCEDURE BarycentricFacetBasis_Tetrahedron +END PROCEDURE BarycentricFacetBasis_Tetrahedron_ !---------------------------------------------------------------------------- ! BarycentricFacetBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron2 +INTEGER(I4B) :: nrow, ncol +CALL BarycentricFacetBasis_Tetrahedron2_(ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4, & + lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricFacetBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron2_ REAL(DFP) :: temp(SIZE(lambda, 2)) -INTEGER(I4B) :: tPoints, i1, i2, ii, a +INTEGER(I4B) :: i1, i2 INTEGER(I4B) :: i21(2), i31(2), i41(2), i32(2), i42(2), i43(2) INTEGER(I4B) :: facetConn(3, 4), fid, n1, n2, cnt, indx1(2, 4), indx2(2, 4) -tPoints = SIZE(temp) +nrow = SIZE(lambda, 2) +ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 & + + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2 -i21 = [1, tPoints] -i31 = i21 + tPoints -i41 = i31 + tPoints -i32 = i41 + tPoints -i42 = i32 + tPoints -i43 = i42 + tPoints -facetConn = FacetConnectivity_Tetrahedron( & - & baseInterpol="HIERARCHY", & - & baseContinuity="H1") -indx1 = ((i21.rowconcat.i21) .rowconcat.i31) .rowconcat.i32 -indx2 = ((i31.rowconcat.i41) .rowconcat.i41) .rowconcat.i42 +i21(1) = 1; i21(2) = nrow +i31 = i21 + nrow +i41 = i31 + nrow +i32 = i41 + nrow +i42 = i32 + nrow +i43 = i42 + nrow -ans = 0.0_DFP +facetConn(1:3, 1:4) = & + FacetConnectivity_Tetrahedron(baseInterpol="HIERARCHY", baseContinuity="H1") + +indx1(1:2, 1) = i21 +indx1(1:2, 2) = i21 +indx1(1:2, 3) = i31 +indx1(1:2, 4) = i32 + +indx2(1:2, 1) = i31 +indx2(1:2, 2) = i41 +indx2(1:2, 3) = i41 +indx2(1:2, 4) = i42 + +! ans = 0.0_DFP i2 = 0 cnt = 0 !! Face1 DO fid = 1, SIZE(facetConn, 2) - temp = lambda(facetConn(1, fid), :) & - & * lambda(facetConn(2, fid), :) & - & * lambda(facetConn(3, fid), :) + temp(1:nrow) = lambda(facetConn(1, fid), 1:nrow) & + * lambda(facetConn(2, fid), 1:nrow) & + * lambda(facetConn(3, fid), 1:nrow) + DO n1 = 1, ps1 - 1 DO n2 = 1, ps1 - 1 - n1 cnt = cnt + 1 - ans(:, cnt) = temp & - & * phi(indx1(1, fid):indx1(2, fid), n1 - 1) & - & * phi(indx2(1, fid):indx2(2, fid), n2 - 1) + ans(1:nrow, cnt) = temp & + * phi(indx1(1, fid):indx1(2, fid), n1 - 1) & + * phi(indx2(1, fid):indx2(2, fid), n2 - 1) END DO END DO END DO -END PROCEDURE BarycentricFacetBasis_Tetrahedron2 +END PROCEDURE BarycentricFacetBasis_Tetrahedron2_ !---------------------------------------------------------------------------- ! BarycentricFacetBasisGradient_Tetrahedron @@ -1564,70 +1637,91 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricCellBasis_Tetrahedron +INTEGER(I4B) :: nrow, ncol +CALL BarycentricCellBasis_Tetrahedron_(pb=pb, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricCellBasis_Tetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasis_Tetrahedron_ REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:pb) INTEGER(I4B) :: maxP, tPoints, i1, i2 -tPoints = SIZE(lambda, 2) +nrow = SIZE(lambda, 2) +ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B + maxP = SIZE(phi, 2) - 1 i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) +i2 = i1 + nrow - 1 +d_lambda(i1:i2) = lambda(2, 1:nrow) - lambda(1, 1:nrow) i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) +i2 = i1 + nrow - 1 +d_lambda(i1:i2) = lambda(3, 1:nrow) - lambda(1, 1:nrow) i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) +i2 = i1 + nrow - 1 +d_lambda(i1:i2) = lambda(4, 1:nrow) - lambda(1, 1:nrow) -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) -ans = BarycentricCellBasis_Tetrahedron2( & - & pb=pb, & - & lambda=lambda, & - & phi=phi) +! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol) -END PROCEDURE BarycentricCellBasis_Tetrahedron +! ans = BarycentricCellBasis_Tetrahedron2( & +CALL BarycentricCellBasis_Tetrahedron2_(pb=pb, lambda=lambda, phi=phi, & + ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE BarycentricCellBasis_Tetrahedron_ !---------------------------------------------------------------------------- ! BarycentricCellBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricCellBasis_Tetrahedron2 +INTEGER(I4B) :: nrow, ncol +CALL BarycentricCellBasis_Tetrahedron2_(pb=pb, lambda=lambda, phi=phi, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricCellBasis_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasis_Tetrahedron2_ REAL(DFP) :: temp(SIZE(lambda, 2)) -INTEGER(I4B) :: tPoints INTEGER(I4B) :: i21(2), i31(2), i41(2) INTEGER(I4B) :: n1, n2, n3, cnt -tPoints = SIZE(temp) +nrow = SIZE(lambda, 2) +ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B -i21 = [1, tPoints] -i31 = i21 + tPoints -i41 = i31 + tPoints +i21(1) = 1; i21(2) = nrow +i31 = i21 + nrow +i41 = i31 + nrow ans = 0.0_DFP cnt = 0 -temp = lambda(1, :) & - & * lambda(2, :) & - & * lambda(3, :) & - & * lambda(4, :) +temp(1:nrow) = lambda(1, 1:nrow) * lambda(2, 1:nrow) & + * lambda(3, 1:nrow) * lambda(4, 1:nrow) DO n1 = 1, pb - 1 DO n2 = 1, pb - 1 - n1 DO n3 = 1, pb - 1 - n1 - n2 cnt = cnt + 1 - ans(:, cnt) = temp & - & * phi(i21(1):i21(2), n1 - 1) & - & * phi(i31(1):i31(2), n2 - 1) & - & * phi(i41(1):i41(2), n3 - 1) + ans(1:nrow, cnt) = temp & + * phi(i21(1):i21(2), n1 - 1) & + * phi(i31(1):i31(2), n2 - 1) & + * phi(i41(1):i41(2), n3 - 1) END DO END DO END DO -END PROCEDURE BarycentricCellBasis_Tetrahedron2 +END PROCEDURE BarycentricCellBasis_Tetrahedron2_ !---------------------------------------------------------------------------- ! BarycentricCellBasisGradient_Tetrahedron @@ -1693,127 +1787,106 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1 -REAL(DFP) :: phi( & - & 1:6 * SIZE(lambda, 2), & - & 0:MAX( & - & pe1 - 2, & - & pe2 - 2, & - & pe3 - 2, & - & pe4 - 2, & - & pe5 - 2, & - & pe6 - 2, & - & ps1 - 1, & - & ps2 - 1, & - & ps3 - 1, & - & ps4 - 1, & - & order & - & )) -REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) -INTEGER(I4B) :: a, b, maxP, tPoints, i1, i2 +INTEGER(I4B) :: nrow, ncol +CALL BarycentricHeirarchicalBasis_Tetrahedron1_(order=order, & + pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ps1=ps1, & + ps2=ps2, ps3=ps3, ps4=ps4, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1 -tPoints = SIZE(lambda, 2) -maxP = SIZE(phi, 2) - 1_I4B +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -i1 = 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(2, :) - lambda(1, :) +MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1_ +REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2)) +INTEGER(I4B) :: maxP, bint, indx(7) +REAL(DFP), ALLOCATABLE :: phi(:, :) +LOGICAL(LGT) :: isok -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(1, :) +nrow = SIZE(lambda, 2) +ncol = 0 -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(1, :) +indx(1) = 6 * nrow +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, pe4 - 2, pe5 - 2, pe6 - 2, & + ps1 - 1, ps2 - 1, ps3 - 1, ps4 - 1, order) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(3, :) - lambda(2, :) +ALLOCATE (phi(1:indx(1), 0:maxP)) -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(2, :) +indx = [0, 1, 2, 3, 4, 5, 6] * nrow -i1 = i2 + 1 -i2 = i1 + tPoints - 1 -d_lambda(i1:i2) = lambda(4, :) - lambda(3, :) +d_lambda(indx(1) + 1:indx(2)) = lambda(2, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(2) + 1:indx(3)) = lambda(3, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(3) + 1:indx(4)) = lambda(4, 1:nrow) - lambda(1, 1:nrow) +d_lambda(indx(4) + 1:indx(5)) = lambda(3, 1:nrow) - lambda(2, 1:nrow) +d_lambda(indx(5) + 1:indx(6)) = lambda(4, 1:nrow) - lambda(2, 1:nrow) +d_lambda(indx(6) + 1:indx(7)) = lambda(4, 1:nrow) - lambda(3, 1:nrow) -phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=indx(1), ncol=indx(2)) !! Vertex basis function -ans = 0.0_DFP -ans(:, 1:4) = BarycentricVertexBasis_Tetrahedron(lambda=lambda) -b = 4 +CALL BarycentricVertexBasis_Tetrahedron_(lambda=lambda, ans=ans, nrow=indx(1), & + ncol=bint) + +ncol = ncol + bint !! Edge basis function -IF (ANY([pe1, pe2, pe3, pe4, pe5, pe6] .GE. 2_I4B)) THEN - a = b + 1 - b = a - 1 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 - ans(:, a:b) = BarycentricEdgeBasis_Tetrahedron2( & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & lambda=lambda, & - & phi=phi & - & ) +indx(1:6) = [pe1, pe2, pe3, pe4, pe5, pe6] +isok = ANY(indx(1:6) .GE. 2_I4B) + +IF (isok) THEN + CALL BarycentricEdgeBasis_Tetrahedron2_(pe1=pe1, pe2=pe2, pe3=pe3, & + pe4=pe4, pe5=pe5, pe6=pe6, lambda=lambda, phi=phi, ans=ans(:, ncol + 1:), & + nrow=nrow, ncol=bint) + + ncol = ncol + bint END IF !! Facet basis function -IF (ANY([ps1, ps2, ps3, ps4] .GE. 3_I4B)) THEN - a = b + 1 - b = a - 1 & - & + (ps1 - 1_I4B) * (ps1 - 2_I4B) / 2_I4B & - & + (ps2 - 1_I4B) * (ps2 - 2_I4B) / 2_I4B & - & + (ps3 - 1_I4B) * (ps3 - 2_I4B) / 2_I4B & - & + (ps4 - 1_I4B) * (ps4 - 2_I4B) / 2_I4B - - ans(:, a:b) = BarycentricFacetBasis_Tetrahedron2( & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4, & - & lambda=lambda, & - & phi=phi & - & ) +indx(1:4) = [ps1, ps2, ps3, ps4] +isok = ANY(indx(1:4) .GE. 3_I4B) +IF (isok) THEN + CALL BarycentricFacetBasis_Tetrahedron2_(ps1=ps1, ps2=ps2, ps3=ps3, & + ps4=ps4, lambda=lambda, phi=phi, ans=ans(:, ncol + 1:), nrow=nrow, & + ncol=bint) + + ncol = ncol + bint END IF !! Cell basis function -IF (order .GE. 4_I4B) THEN - a = b + 1 - b = a - 1 & - & + (order - 1_I4B) * (order - 2_I4B) * (order - 3_I4B) / 6_I4B +isok = order .GE. 4_I4B +IF (isok) THEN + CALL BarycentricCellBasis_Tetrahedron2_(pb=order, lambda=lambda, phi=phi, & + ans=ans(:, ncol + 1:), nrow=nrow, ncol=bint) - ans(:, a:b) = BarycentricCellBasis_Tetrahedron2( & - & pb=order, & - & lambda=lambda, & - & phi=phi) + ncol = ncol + bint END IF -END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1 + +DEALLOCATE (phi) + +END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1_ !---------------------------------------------------------------------------- ! BarycentricHeirarchicalBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2 -ans = BarycentricHeirarchicalBasis_Tetrahedron( & - & order=order, & - & pe1=order, & - & pe2=order, & - & pe3=order, & - & pe4=order, & - & pe5=order, & - & pe6=order, & - & ps1=order, & - & ps2=order, & - & ps3=order, & - & ps4=order, & - & lambda=lambda & - & ) +INTEGER(I4B) :: nrow, ncol +CALL BarycentricHeirarchicalBasis_Tetrahedron2_(order=order, & + lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2_ +CALL BarycentricHeirarchicalBasis_Tetrahedron1_(order=order, pe1=order, & + pe2=order, pe3=order, pe4=order, pe5=order, pe6=order, ps1=order, & + ps2=order, ps3=order, ps4=order, lambda=lambda, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2_ + !---------------------------------------------------------------------------- ! BarycentricHeirarchicalBasisGradient_Tetrahedron !---------------------------------------------------------------------------- @@ -1963,260 +2036,371 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE VertexBasis_Tetrahedron -ans = BarycentricVertexBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron)) +INTEGER(I4B) :: nrow, ncol +CALL VertexBasis_Tetrahedron_(xij=xij, refTetrahedron=refTetrahedron, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE VertexBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Tetrahedron_ +REAL(DFP), ALLOCATABLE :: lambda(:, :) + +nrow = SIZE(xij, 2) +ALLOCATE (lambda(4, nrow)) + +CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, & + ans=lambda, nrow=nrow, ncol=ncol) + +CALL BarycentricVertexBasis_Tetrahedron_(lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) + +DEALLOCATE (lambda) +END PROCEDURE VertexBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! EdgeBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE EdgeBasis_Tetrahedron -ans = BarycentricEdgeBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6) +INTEGER(I4B) :: nrow, ncol +CALL EdgeBasis_Tetrahedron_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, & + pe6=pe6, xij=xij, refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, & + ncol=ncol) END PROCEDURE EdgeBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasis_Tetrahedron_ +REAL(DFP), ALLOCATABLE :: lambda(:, :) + +nrow = SIZE(xij, 2) +ALLOCATE (lambda(4, nrow)) + +CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, & + ans=lambda, nrow=nrow, ncol=ncol) + +CALL BarycentricEdgeBasis_Tetrahedron_(lambda=lambda, pe1=pe1, pe2=pe2, & + pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ans=ans, nrow=nrow, ncol=ncol) + +DEALLOCATE (lambda) +END PROCEDURE EdgeBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! FacetBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE FacetBasis_Tetrahedron -ans = BarycentricFacetBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4) +INTEGER(I4B) :: nrow, ncol +CALL FacetBasis_Tetrahedron_(ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4, xij=xij, & + refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE FacetBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetBasis_Tetrahedron_ +REAL(DFP), ALLOCATABLE :: lambda(:, :) + +nrow = SIZE(xij, 2) +ALLOCATE (lambda(4, nrow)) + +CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, & + ans=lambda, nrow=nrow, ncol=ncol) + +CALL BarycentricFacetBasis_Tetrahedron_(lambda=lambda, ps1=ps1, ps2=ps2, & + ps3=ps3, ps4=ps4, ans=ans, nrow=nrow, ncol=ncol) + +DEALLOCATE (lambda) +END PROCEDURE FacetBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! CellBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE CellBasis_Tetrahedron -ans = BarycentricCellBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & pb=pb) +INTEGER(I4B) :: nrow, ncol +CALL CellBasis_Tetrahedron_(pb=pb, xij=xij, refTetrahedron=refTetrahedron, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE CellBasis_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Tetrahedron_ +REAL(DFP), ALLOCATABLE :: lambda(:, :) + +nrow = SIZE(xij, 2) +ALLOCATE (lambda(4, nrow)) + +CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, & + ans=lambda, nrow=nrow, ncol=ncol) + +CALL BarycentricCellBasis_Tetrahedron_(lambda=lambda, pb=pb, ans=ans, & + nrow=nrow, ncol=ncol) + +DEALLOCATE (lambda) +END PROCEDURE CellBasis_Tetrahedron_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Tetrahedron1 -ans = BarycentricHeirarchicalBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & order=order, & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4) +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Tetrahedron1_(order, pe1, pe2, pe3, pe4, pe5, pe6, & + ps1, ps2, ps3, ps4, xij, refTetrahedron, ans, nrow, ncol) END PROCEDURE HeirarchicalBasis_Tetrahedron1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Tetrahedron1_ +REAL(DFP), ALLOCATABLE :: lambda(:, :) + +nrow = SIZE(xij, 2) + +ALLOCATE (lambda(4, nrow)) + +CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, & + ans=lambda, nrow=nrow, ncol=ncol) + +! ans(1:nrow, 1:ncol) = BarycentricHeirarchicalBasis_Tetrahedron( & +CALL BarycentricHeirarchicalBasis_Tetrahedron_(lambda=lambda, order=order, & + pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ps1=ps1, ps2= & + ps2, ps3=ps3, ps4=ps4, ans=ans, nrow=nrow, ncol=ncol) + +DEALLOCATE (lambda) +END PROCEDURE HeirarchicalBasis_Tetrahedron1_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Tetrahedron2 -ans = BarycentricHeirarchicalBasis_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & order=order) +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Tetrahedron2_(order, xij, refTetrahedron, ans, nrow, & + ncol) END PROCEDURE HeirarchicalBasis_Tetrahedron2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Tetrahedron2_ +REAL(DFP), ALLOCATABLE :: lambda(:, :) + +nrow = SIZE(xij, 2) +ALLOCATE (lambda(4, nrow)) +CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, & + ans=lambda, nrow=nrow, ncol=ncol) + +CALL BarycentricHeirarchicalBasis_Tetrahedron_(lambda=lambda, order=order, & + ans=ans, nrow=nrow, ncol=ncol) + +DEALLOCATE (lambda) +END PROCEDURE HeirarchicalBasis_Tetrahedron2_ + !---------------------------------------------------------------------------- ! LagrangeEvallAll_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Tetrahedron1 +INTEGER(I4B) :: tsize +CALL LagrangeEvalAll_Tetrahedron1_(order=order, x=x, xij=xij, ans=ans, & + tsize=tsize, refTetrahedron=refTetrahedron, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) + +END PROCEDURE LagrangeEvalAll_Tetrahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Tetrahedron1_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: ii, basisType0, nrow, ncol INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) -TYPE(String) :: ref0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), & + x31(3, 1) +CHARACTER(:), ALLOCATABLE :: ref0 + +tsize = SIZE(xij, 2) basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) + ref0 = INPUT(default="UNIT", option=refTetrahedron) IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN - coeff = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) - coeff0 = TRANSPOSE(coeff) - ELSE - coeff0 = TRANSPOSE(coeff) + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + refTetrahedron=ref0, ans=coeff, nrow=nrow, ncol=ncol) END IF + + coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) + ELSE - coeff0 = TRANSPOSE( & - & LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & )) + ! coeff0 = TRANSPOSE( & + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + refTetrahedron=ref0, ans=coeff0, nrow=nrow, ncol=ncol) END IF SELECT CASE (basisType0) CASE (Monomial) - degree = LagrangeDegree_Tetrahedron(order=order) - tdof = SIZE(xij, 2) + ! degree = LagrangeDegree_Tetrahedron(order=order) + CALL LagrangeDegree_Tetrahedron_(order=order, ans=degree, nrow=nrow, & + ncol=ncol) - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Tetrahedron1", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + + IF (tsize .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Tetrahedron1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF - DO ii = 1, tdof - xx(1, ii) = x(1)**degree(ii, 1) & - & * x(2)**degree(ii, 2) & - & * x(3)**degree(ii, 3) +#endif + + DO ii = 1, tsize + xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) * x(3)**degree(ii, 3) END DO CASE (Heirarchical) - xx = HeirarchicalBasis_Tetrahedron( & - & order=order, & - & xij=RESHAPE(x, [3, 1]), & - & refTetrahedron=ref0%chars()) + ! FIXME: + x31(1:3, 1) = x(1:3) + ! xx = HeirarchicalBasis_Tetrahedron(order=order, xij=x31, refTetrahedron=ref0) + call HeirarchicalBasis_Tetrahedron_(order=order, xij=x31, refTetrahedron=ref0, & + ans=xx, nrow=nrow, ncol=ncol) CASE DEFAULT - xx = OrthogonalBasis_Tetrahedron( & - & order=order, & - & xij=RESHAPE(x, [3, 1]), & - & refTetrahedron=ref0%chars() & - & ) + + !FIXME: + x31(1:3, 1) = x(1:3) + CALL OrthogonalBasis_Tetrahedron(order=order, xij=x31, refTetrahedron=ref0, & + ans=xx, nrow=nrow, ncol=ncol) END SELECT -ans = MATMUL(coeff0, xx(1, :)) +DO CONCURRENT(ii=1:tsize) + ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) +END DO -END PROCEDURE LagrangeEvalAll_Tetrahedron1 +END PROCEDURE LagrangeEvalAll_Tetrahedron1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Tetrahedron2 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Tetrahedron2_(order=order, x=x, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol, refTetrahedron=refTetrahedron, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE LagrangeEvalAll_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Tetrahedron2_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) -REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) -TYPE(String) :: ref0 + +INTEGER(I4B) :: ii, jj, basisType0, indx(7), degree(SIZE(xij, 2), 3) + +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & + xx(SIZE(x, 2), SIZE(xij, 2)), areal + +CHARACTER(:), ALLOCATABLE :: ref0 + +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) ref0 = INPUT(default="UNIT", option=refTetrahedron) IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN - coeff = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) + + ! coeff = LagrangeCoeff_Tetrahedron(& + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + refTetrahedron=ref0, ans=coeff, nrow=indx(1), ncol=indx(2)) + END IF - coeff0 = coeff + + coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) + ELSE - coeff0 = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) + + ! coeff0 = LagrangeCoeff_Tetrahedron(& + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + refTetrahedron=ref0, ans=coeff0, nrow=indx(1), ncol=indx(2)) END IF SELECT CASE (basisType0) CASE (Monomial) - degree = LagrangeDegree_Tetrahedron(order=order) - tdof = SIZE(xij, 2) + ! degree = LagrangeDegree_Tetrahedron(order=order) + CALL LagrangeDegree_Tetrahedron_(order=order, ans=degree, nrow=indx(1), & + ncol=indx(2)) - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Tetrahedron1", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + IF (ncol .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Tetrahedron1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF +#endif + + DO ii = 1, ncol + indx(1:3) = degree(ii, 1:3) + + DO jj = 1, nrow + areal = x(1, jj)**indx(1) * x(2, jj)**indx(2) * x(3, jj)**indx(3) + xx(jj, ii) = areal + END DO - DO ii = 1, tdof - xx(:, ii) = x(1, :)**degree(ii, 1) & - & * x(2, :)**degree(ii, 2) & - & * x(3, :)**degree(ii, 3) END DO CASE (Heirarchical) - xx = HeirarchicalBasis_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars()) + CALL HeirarchicalBasis_Tetrahedron_(order=order, xij=x, & + refTetrahedron=ref0, ans=xx, nrow=indx(1), ncol=indx(2)) CASE DEFAULT - xx = OrthogonalBasis_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars() & - & ) + CALL OrthogonalBasis_Tetrahedron_(order=order, xij=x, refTetrahedron=ref0, & + ans=xx, nrows=indx(1), ncols=indx(2)) END SELECT -ans = MATMUL(xx, coeff0) +! ans = MATMUL(xx, coeff0) -END PROCEDURE LagrangeEvalAll_Tetrahedron2 +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0) + +END PROCEDURE LagrangeEvalAll_Tetrahedron2_ !---------------------------------------------------------------------------- ! QuadraturePoint_Tetrahedron From f8caf5d4a03558c968068dd13fc32c50ff46a962 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 15:09:19 +0900 Subject: [PATCH 108/359] Updates in TriangleInterpolationUtility --- ...TriangleInterpolationUtility@LagrangeBasisMethods.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index 42f9c4b26..3d6159048 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -217,7 +217,8 @@ LOGICAL(LGT) :: firstCall0 INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), & + x21(2, 1) tsize = SIZE(xij, 2) @@ -258,14 +259,16 @@ CASE (polyopt%Hierarchical) + x21(1:2, 1) = x(1:2) CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, & - pe2=order, pe3=order, xij=RESHAPE(x, [2, 1]), & + pe2=order, pe3=order, xij=x21, & refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow) CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, & polyopt%Ultraspherical) - CALL Dubiner_Triangle_(order=order, xij=RESHAPE(x, [2, 1]), & + x21(1:2, 1) = x(1:2) + CALL Dubiner_Triangle_(order=order, xij=x21, & refTriangle=refTriangle, ans=xx, nrow=nrow, ncol=ncol) END SELECT From 0d5d8a77ad2a92ecfcaf8c0f3ee0bcefbc929e7d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 15:10:06 +0900 Subject: [PATCH 109/359] Updates in HexahedronInterpolationUtility --- src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index a780400f0..d58da7a93 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -28,6 +28,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: InterpolationPoint_Hexahedron PUBLIC :: InterpolationPoint_Hexahedron_ PUBLIC :: LagrangeCoeff_Hexahedron +PUBLIC :: LagrangeCoeff_Hexahedron_ PUBLIC :: EdgeConnectivity_Hexahedron PUBLIC :: FacetConnectivity_Hexahedron PUBLIC :: QuadratureNumber_Hexahedron From 3a1bc523f658cf8e0473878df95ba2dbb4ded0ec Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 15:10:17 +0900 Subject: [PATCH 110/359] Updates in PrismInterpolationUtility --- src/modules/Polynomial/src/PrismInterpolationUtility.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index 3c2422e9f..290bbfdd9 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -28,6 +28,7 @@ MODULE PrismInterpolationUtility PUBLIC :: InterpolationPoint_Prism PUBLIC :: InterpolationPoint_Prism_ PUBLIC :: LagrangeCoeff_Prism +PUBLIC :: LagrangeCoeff_Prism_ PUBLIC :: QuadraturePoint_Prism PUBLIC :: TensorQuadraturePoint_Prism PUBLIC :: RefElemDomain_Prism From 9a0e3339f98322b1a032a959a644bd66ba474c1b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 15:10:29 +0900 Subject: [PATCH 111/359] Updates in PyramidInterpolationUtility --- .../src/PyramidInterpolationUtility.F90 | 134 +++++++++++++++--- 1 file changed, 113 insertions(+), 21 deletions(-) diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 index ecb6ef1e3..6d0b43211 100644 --- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 @@ -28,6 +28,7 @@ MODULE PyramidInterpolationUtility PUBLIC :: InterpolationPoint_Pyramid PUBLIC :: InterpolationPoint_Pyramid_ PUBLIC :: LagrangeCoeff_Pyramid +PUBLIC :: LagrangeCoeff_Pyramid_ PUBLIC :: QuadraturePoint_Pyramid PUBLIC :: TensorQuadraturePoint_Pyramid PUBLIC :: RefElemDomain_Pyramid @@ -317,7 +318,7 @@ END SUBROUTINE InterpolationPoint_Pyramid_ ! LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- -INTERFACE +INTERFACE LagrangeCoeff_Pyramid MODULE FUNCTION LagrangeCoeff_Pyramid1(order, i, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial @@ -328,17 +329,13 @@ MODULE FUNCTION LagrangeCoeff_Pyramid1(order, i, xij) RESULT(ans) REAL(DFP) :: ans(SIZE(xij, 2)) !! coefficients END FUNCTION LagrangeCoeff_Pyramid1 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid1 END INTERFACE LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- ! LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- -INTERFACE +INTERFACE LagrangeCoeff_Pyramid MODULE FUNCTION LagrangeCoeff_Pyramid2(order, i, v, isVandermonde) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -352,17 +349,13 @@ MODULE FUNCTION LagrangeCoeff_Pyramid2(order, i, v, isVandermonde) & REAL(DFP) :: ans(SIZE(v, 1)) !! coefficients END FUNCTION LagrangeCoeff_Pyramid2 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid2 END INTERFACE LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- ! LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- -INTERFACE +INTERFACE LagrangeCoeff_Pyramid MODULE FUNCTION LagrangeCoeff_Pyramid3(order, i, v, ipiv) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial, it should be SIZE(x,2)-1 @@ -375,31 +368,130 @@ MODULE FUNCTION LagrangeCoeff_Pyramid3(order, i, v, ipiv) RESULT(ans) REAL(DFP) :: ans(SIZE(v, 1)) !! coefficients END FUNCTION LagrangeCoeff_Pyramid3 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid3 END INTERFACE LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- ! LagrangeCoeff_Pyramid !---------------------------------------------------------------------------- -INTERFACE - MODULE FUNCTION LagrangeCoeff_Pyramid4(order, xij) RESULT(ans) +INTERFACE LagrangeCoeff_Pyramid + MODULE FUNCTION LagrangeCoeff_Pyramid4(order, xij, basisType, & + refPyramid, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial REAL(DFP), INTENT(IN) :: xij(:, :) !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi (Dubiner) + !! Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT * default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) !! coefficients END FUNCTION LagrangeCoeff_Pyramid4 -END INTERFACE - -INTERFACE LagrangeCoeff_Pyramid - MODULE PROCEDURE LagrangeCoeff_Pyramid4 END INTERFACE LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Pyramid_ + MODULE SUBROUTINE LagrangeCoeff_Pyramid1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Pyramid1_ +END INTERFACE LagrangeCoeff_Pyramid_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Pyramid_ + MODULE SUBROUTINE LagrangeCoeff_Pyramid2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP), INTENT(INOUT) :: ans(:) + ! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Pyramid2_ +END INTERFACE LagrangeCoeff_Pyramid_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Pyramid_ + MODULE SUBROUTINE LagrangeCoeff_Pyramid3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Pyramid3_ +END INTERFACE LagrangeCoeff_Pyramid_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Pyramid_ + MODULE SUBROUTINE LagrangeCoeff_Pyramid4_(order, xij, basisType, & + refPyramid, alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi (Dubiner) + !! Heirarchical + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT * default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical polynomial parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Pyramid4_ +END INTERFACE LagrangeCoeff_Pyramid_ + !---------------------------------------------------------------------------- ! QuadraturePoints_Pyramid !---------------------------------------------------------------------------- From e396d37425a2273cc6fec9425aa7adb0e37b28e6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 15:11:06 +0900 Subject: [PATCH 112/359] Updates in LagrangePolynomialUtility --- .../src/LagrangePolynomialUtility@Methods.F90 | 234 +++++++++++++++--- .../PyramidInterpolationUtility@Methods.F90 | 93 +++++-- 2 files changed, 274 insertions(+), 53 deletions(-) diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index a0097127a..fddcb5741 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -17,7 +17,7 @@ SUBMODULE(LagrangePolynomialUtility) Methods USE GlobalData, ONLY: stdout, stderr, Point, Line, Triangle, Quadrangle, & - Tetrahedron, Hexahedron, Prism, Pyramid + Tetrahedron, Hexahedron, Prism, Pyramid, Monomial USE ErrorHandling, ONLY: Errormsg @@ -30,6 +30,7 @@ InterpolationPoint_Line, & InterpolationPoint_Line_, & LagrangeCoeff_Line, & + LagrangeCoeff_Line_, & LagrangeEvalAll_Line, & LagrangeGradientEvalAll_Line @@ -40,6 +41,7 @@ InterpolationPoint_Triangle, & InterpolationPoint_Triangle_, & LagrangeCoeff_Triangle, & + LagrangeCoeff_Triangle_, & LagrangeEvalAll_Triangle, & LagrangeGradientEvalAll_Triangle @@ -50,6 +52,7 @@ InterpolationPoint_Quadrangle, & InterpolationPoint_Quadrangle_, & LagrangeCoeff_Quadrangle, & + LagrangeCoeff_Quadrangle_, & LagrangeEvalAll_Quadrangle, & LagrangeGradientEvalAll_Quadrangle @@ -60,6 +63,7 @@ InterpolationPoint_Tetrahedron, & InterpolationPoint_Tetrahedron_, & LagrangeCoeff_Tetrahedron, & + LagrangeCoeff_Tetrahedron_, & LagrangeEvalAll_Tetrahedron, & LagrangeGradientEvalAll_Tetrahedron @@ -70,6 +74,7 @@ InterpolationPoint_Hexahedron, & InterpolationPoint_Hexahedron_, & LagrangeCoeff_Hexahedron, & + LagrangeCoeff_Hexahedron_, & LagrangeEvalAll_Hexahedron, & LagrangeGradientEvalAll_Hexahedron @@ -80,6 +85,7 @@ InterpolationPoint_Prism, & InterpolationPoint_Prism_, & LagrangeCoeff_Prism, & + LagrangeCoeff_Prism_, & LagrangeEvalAll_Prism, & LagrangeGradientEvalAll_Prism @@ -90,6 +96,7 @@ InterpolationPoint_Pyramid, & InterpolationPoint_Pyramid_, & LagrangeCoeff_Pyramid, & + LagrangeCoeff_Pyramid_, & LagrangeEvalAll_Pyramid, & LagrangeGradientEvalAll_Pyramid @@ -410,39 +417,198 @@ END PROCEDURE InterpolationPoint_ !---------------------------------------------------------------------------- -! LagrangeCoeff_ +! LagrangeCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff1_ -CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & - routine="LagrangeCoeff1_", file=__FILE__) +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) + +CASE (Line) + CALL LagrangeCoeff_Line_(order=order, xij=xij, i=i, & + ans=ans, tsize=tsize) + +CASE (Triangle) + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, i=i, & + ans=ans, tsize=tsize) + +CASE (Quadrangle) + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, i=i, & + ans=ans, tsize=tsize) + +CASE (Tetrahedron) + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, i=i, & + ans=ans, tsize=tsize) + +CASE (Hexahedron) + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, i=i, & + ans=ans, tsize=tsize) + +CASE (Prism) + CALL LagrangeCoeff_Prism_(order=order, xij=xij, i=i, & + ans=ans, tsize=tsize) + +CASE (Pyramid) + CALL LagrangeCoeff_Pyramid_(order=order, xij=xij, i=i, & + ans=ans, tsize=tsize) + +CASE DEFAULT + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="LagrangeCoeff1_()", & + unitno=stdout, line=__LINE__, file=__FILE__) + RETURN +END SELECT + END PROCEDURE LagrangeCoeff1_ !---------------------------------------------------------------------------- -! LagrangeCoeff_ +! LagrangeCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff2_ -CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & - routine="LagrangeCoeff2_", file=__FILE__) +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + CALL LagrangeCoeff_Line_(order=order, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) + +CASE (Triangle) + CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=Monomial, & + refTriangle="UNIT", ans=ans, nrow=nrow, ncol=ncol) + +CASE (Quadrangle) + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (Tetrahedron) + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (Hexahedron) + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (Prism) + CALL LagrangeCoeff_Prism_(order=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (Pyramid) + CALL LagrangeCoeff_Pyramid_(order=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE DEFAULT + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + unitno=stdout, line=__LINE__, routine="LagrangeCoeff2_()", & + file=__FILE__) +END SELECT END PROCEDURE LagrangeCoeff2_ !---------------------------------------------------------------------------- -! LagrangeCoeff_ +! LagrangeCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff3_ -CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & - routine="LagrangeCoeff3_", file=__FILE__) +INTEGER(I4B) :: topo +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + CALL LagrangeCoeff_Line_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) + +CASE (Triangle) + CALL LagrangeCoeff_Triangle_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) + +CASE (Quadrangle) + CALL LagrangeCoeff_Quadrangle_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) + +CASE (Tetrahedron) +CALL LagrangeCoeff_Tetrahedron_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) + +CASE (Hexahedron) + CALL LagrangeCoeff_Hexahedron_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) + +CASE (Prism) + CALL LagrangeCoeff_Prism_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) + +CASE (Pyramid) + CALL LagrangeCoeff_Pyramid_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) + +CASE DEFAULT + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="LagrangeCoeff3_()", unitno=stdout, line=__LINE__, & + file=__FILE__) + RETURN +END SELECT + END PROCEDURE LagrangeCoeff3_ !---------------------------------------------------------------------------- -! LagrangeCoeff_ +! LagrangeCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff4_ -CALL Errormsg(msg="Not Implemented", unitno=stdout, line=__LINE__, & - routine="LagrangeCoeff4_", file=__FILE__) +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + +CASE (Line) + CALL LagrangeCoeff_Line_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) + +CASE (Triangle) + CALL LagrangeCoeff_Triangle_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) + +CASE (Quadrangle) + CALL LagrangeCoeff_Quadrangle_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) + +CASE (Tetrahedron) + CALL LagrangeCoeff_Tetrahedron_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) + +CASE (Hexahedron) + CALL LagrangeCoeff_Hexahedron_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) + +CASE (Prism) + CALL LagrangeCoeff_Prism_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) + +CASE (Pyramid) + CALL LagrangeCoeff_Pyramid_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) + +CASE DEFAULT + CALL Errormsg( & + msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="LagrangeCoeff4_()", & + unitno=stdout, line=__LINE__, file=__FILE__) + RETURN +END SELECT + END PROCEDURE LagrangeCoeff4_ !---------------------------------------------------------------------------- @@ -481,10 +647,8 @@ CASE DEFAULT CALL Errormsg( & msg="No CASE FOUND: elemType="//ToString(elemType), & - unitno=stdout, & - line=__LINE__, & - routine="LagrangeCoeff1()", & - file=__FILE__) + routine="LagrangeCoeff1()", unitno=stdout, line=__LINE__, file=__FILE__) + RETURN END SELECT END PROCEDURE LagrangeCoeff1 @@ -526,6 +690,7 @@ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & unitno=stdout, line=__LINE__, routine="LagrangeCoeff2()", & file=__FILE__) + RETURN END SELECT END PROCEDURE LagrangeCoeff2 @@ -562,13 +727,13 @@ ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, isVandermonde=.TRUE.) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff3()", & - & file=__FILE__) + CALL Errormsg( & + msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="LagrangeCoeff3()", & + unitno=stdout, line=__LINE__, file=__FILE__) + RETURN END SELECT + END PROCEDURE LagrangeCoeff3 !---------------------------------------------------------------------------- @@ -605,13 +770,13 @@ ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, ipiv=ipiv) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeCoeff2()", & - & file=__FILE__) + CALL Errormsg( & + msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="LagrangeCoeff2()", & + unitno=stdout, line=__LINE__, file=__FILE__) + RETURN END SELECT + END PROCEDURE LagrangeCoeff4 !---------------------------------------------------------------------------- @@ -715,13 +880,12 @@ & lambda=lambda) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeEvalAll2()", & - & file=__FILE__) + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="LagrangeEvalAll2()", & + unitno=stdout, line=__LINE__, file=__FILE__) + RETURN END SELECT + END PROCEDURE LagrangeEvalAll1 !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 index db94a6c84..dc3a3ed1d 100644 --- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 @@ -159,13 +159,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Pyramid1 -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info -ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP -V = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Pyramid1_(order=order, i=i, xij=xij, ans=ans, & + tsize=tsize) END PROCEDURE LagrangeCoeff_Pyramid1 !---------------------------------------------------------------------------- @@ -173,12 +169,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Pyramid2 -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info -vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Pyramid2_(order=order, i=i, v=v, & + isVandermonde=.TRUE., ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff_Pyramid2 !---------------------------------------------------------------------------- @@ -186,9 +179,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Pyramid3 -INTEGER(I4B) :: info -ans = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Pyramid3_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff_Pyramid3 !---------------------------------------------------------------------------- @@ -196,10 +189,74 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Pyramid4 -ans = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) -CALL GetInvMat(ans) +INTEGER(I4B) :: nrow, ncol + +CALL LagrangeCoeff_Pyramid4_(order=order, xij=xij, basisType=basisType, & + refPyramid=refPyramid, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + END PROCEDURE LagrangeCoeff_Pyramid4 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid1_ +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info, nrow, ncol + +tsize = SIZE(xij, 2) + +ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Pyramid, & + ans=V, nrow=nrow, ncol=ncol) + +CALL GetLU(A=V, IPIV=ipiv, info=info) + +CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid2_ +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info + +tsize = SIZE(v, 1) + +vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid3_ +INTEGER(I4B) :: info + +tsize = SIZE(v, 1) + +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid4_ +CALL LagrangeVandermonde_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol, elemType=Pyramid) +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Pyramid4_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Pyramid !---------------------------------------------------------------------------- From 51634913ea38ed2014baa04d75985251328f0d6f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 16:34:05 +0900 Subject: [PATCH 113/359] Updates in HexahedronInterpolationUtility --- .../src/HexahedronInterpolationUtility.F90 | 82 ++++++++ ...HexahedronInterpolationUtility@Methods.F90 | 190 ++++++++++++------ 2 files changed, 214 insertions(+), 58 deletions(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index d58da7a93..744b42141 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -47,6 +47,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: HeirarchicalBasis_Hexahedron PUBLIC :: QuadraturePoint_Hexahedron PUBLIC :: LagrangeEvalAll_Hexahedron +PUBLIC :: LagrangeEvalAll_Hexahedron_ PUBLIC :: GetVertexDOF_Hexahedron PUBLIC :: GetEdgeDOF_Hexahedron PUBLIC :: GetFacetDOF_Hexahedron @@ -2570,6 +2571,48 @@ MODULE FUNCTION LagrangeEvalAll_Hexahedron1( & END FUNCTION LagrangeEvalAll_Hexahedron1 END INTERFACE LagrangeEvalAll_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Hexahedron_ + MODULE SUBROUTINE LagrangeEvalAll_Hexahedron1_(order, x, xij, ans, tsize, coeff, & + firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: tsize + !! ans(SIZE(xij, 2)) + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be computed and returned + !! by this routine. + !! If firstCall is False, then coeff should be given, which will be + !! used. + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Hexahedron1_ +END INTERFACE LagrangeEvalAll_Hexahedron_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Hexahedron !---------------------------------------------------------------------------- @@ -2624,6 +2667,45 @@ MODULE FUNCTION LagrangeEvalAll_Hexahedron2( & END FUNCTION LagrangeEvalAll_Hexahedron2 END INTERFACE LagrangeEvalAll_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Hexahedron_ + MODULE SUBROUTINE LagrangeEvalAll_Hexahedron2_(order, x, xij, ans, nrow, & + ncol, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Value of n+1 Lagrange polynomials at point x + !! ans(SIZE(x, 2), SIZE(xij, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns in ans + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Hexahedron2_ +END INTERFACE LagrangeEvalAll_Hexahedron_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Hexahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index d72e51d1d..6c8d9d1ea 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2450,39 +2450,35 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE LagrangeEvalAll_Hexahedron2 +MODULE PROCEDURE LagrangeEvalAll_Hexahedron1_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof +INTEGER(I4B) :: ii, basisType0, indx(7) INTEGER(I4B) :: degree(SIZE(xij, 2), 3) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) -REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), & + x31(3, 1) + +tsize = SIZE(xij, 2) basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN IF (firstCall0) THEN - coeff = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = coeff - ELSE - coeff0 = coeff + + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff, nrow=indx(1), ncol=indx(2)) + END IF + + coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) + ELSE - coeff0 = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) + + ! coeff0 = LagrangeCoeff_Hexahedron(& + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, ans=coeff0, & + nrow=indx(1), ncol=indx(2), basisType=basisType0, alpha=alpha, & + beta=beta, lambda=lambda) END IF SELECT CASE (basisType0) @@ -2490,58 +2486,136 @@ CASE (Monomial) degree = LagrangeDegree_Hexahedron(order=order) - tdof = SIZE(xij, 2) - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Hexahedron1", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + + IF (tsize .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Hexahedron1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF - DO ii = 1, tdof - xx(:, ii) = x(1, :)**degree(ii, 1) & - & * x(2, :)**degree(ii, 2) & - & * x(3, :)**degree(ii, 3) +#endif + + DO ii = 1, tsize + indx(1:3) = degree(ii, 1:3) + xx(1, ii) = x(1)**indx(1) * x(2)**indx(2) * x(3)**indx(3) END DO CASE (Heirarchical) - xx = HeirarchicalBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=x) + x31(1:3, 1) = x(1:3) + xx = HeirarchicalBasis_Hexahedron(p=order, q=order, r=order, xij=x31) CASE DEFAULT - xx = TensorProdBasis_Hexahedron( & - & p=order, & - & q=order, & - & r=order, & - & xij=x, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & basisType3=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda) + x31(1:3, 1) = x(1:3) + + xx = TensorProdBasis_Hexahedron(p=order, q=order, r=order, xij=x31, & + basisType1=basisType0, basisType2=basisType0, basisType3=basisType0, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda) END SELECT -ans = MATMUL(xx, coeff0) +DO ii = 1, tsize + ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) +END DO + +END PROCEDURE LagrangeEvalAll_Hexahedron1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +MODULE PROCEDURE LagrangeEvalAll_Hexahedron2 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Hexahedron2_(order=order, x=x, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE LagrangeEvalAll_Hexahedron2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Hexahedron2_ +LOGICAL(LGT) :: firstCall0 +INTEGER(I4B) :: ii, jj, basisType0, indx(3), degree(SIZE(xij, 2), 3) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & + xx(SIZE(x, 2), SIZE(xij, 2)), areal + +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) + +basisType0 = INPUT(default=Monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + ! coeff = LagrangeCoeff_Hexahedron(& + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff, & + nrow=indx(1), ncol=indx(2)) + + END IF + + coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) + +ELSE + + ! coeff0 = LagrangeCoeff_Hexahedron(& + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & + nrow=indx(1), ncol=indx(2)) + +END IF + +SELECT CASE (basisType0) + +CASE (Monomial) + + degree = LagrangeDegree_Hexahedron(order=order) + +#ifdef DEBUG_VER + IF (ncol .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="ncol is not same as size(degree,1)", & + routine="LagrangeEvalAll_Hexahedron1", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN + END IF +#endif + + DO ii = 1, ncol + + indx(1:3) = degree(ii, 1:3) + + DO jj = 1, nrow + areal = x(1, jj)**indx(1) * x(2, jj)**indx(2) * x(3, jj)**indx(3) + xx(jj, ii) = areal + END DO + + END DO + +CASE (Heirarchical) + + xx = HeirarchicalBasis_Hexahedron(p=order, q=order, r=order, xij=x) + +CASE DEFAULT + + xx = TensorProdBasis_Hexahedron(p=order, q=order, r=order, xij=x, & + basisType1=basisType0, basisType2=basisType0, basisType3=basisType0, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda) + +END SELECT + +! ans = MATMUL(xx, coeff0) +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0) + +END PROCEDURE LagrangeEvalAll_Hexahedron2_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Hexahedron !---------------------------------------------------------------------------- From 609f65499dd54c0a3f9d79868727665d6d17e76f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 16:34:12 +0900 Subject: [PATCH 114/359] Updates in QuadrangleInterpolationUtility --- ...QuadrangleInterpolationUtility@Methods.F90 | 154 +++++++++--------- 1 file changed, 78 insertions(+), 76 deletions(-) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 5b045f769..877e60593 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -1680,9 +1680,9 @@ MODULE PROCEDURE LagrangeEvalAll_Quadrangle1_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, nrow, ncol -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)) +INTEGER(I4B) :: ii, basisType0, degree(SIZE(xij, 2), 2), indx(2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), & + x21(2, 1) tsize = SIZE(xij, 2) @@ -1695,7 +1695,7 @@ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & basisType=basisType0, alpha=alpha, & beta=beta, lambda=lambda, & - ans=coeff, nrow=nrow, ncol=ncol) + ans=coeff, nrow=indx(1), ncol=indx(2)) END IF ! coeff0 = TRANSPOSE(coeff) @@ -1705,7 +1705,8 @@ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & - ans=coeff0, nrow=nrow, ncol=ncol) + ans=coeff0, nrow=indx(1), ncol=indx(2)) + ! coeff0 = TRANSPOSE(coeff0) END IF @@ -1714,9 +1715,8 @@ CASE (Monomial) - degree = LagrangeDegree_Quadrangle(order=order) -! CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=nrow, ncol=ncol) - + CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & + ncol=indx(2)) #ifdef DEBUG_VER IF (tsize .NE. SIZE(degree, 1)) THEN @@ -1729,29 +1729,24 @@ #endif DO ii = 1, tsize - xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) + 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( & - ! CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, & - ! xij=RESHAPE(x, [2, 1]), ans=xx, nrow=nrow, ncol=ncol) + x21(1:2, 1) = x(1:2) + CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, & + xij=x21, ans=xx, nrow=indx(1), ncol=indx(2)) CASE DEFAULT - xx = TensorProdBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=RESHAPE(x, [2, 1]), & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) + x21(1:2, 1) = x(1:2) + CALL TensorProdBasis_Quadrangle_(p=order, q=order, xij=x21, & + basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & + nrow=indx(1), ncol=indx(2)) END SELECT @@ -1762,91 +1757,98 @@ END PROCEDURE LagrangeEvalAll_Quadrangle1_ !---------------------------------------------------------------------------- -! LagrangeEvalAll_Quadrangle2 +! !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Quadrangle2_(order=order, x=x, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE LagrangeEvalAll_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle2_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) -REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2)) +INTEGER(I4B) :: ii, jj, basisType0, indx(2), degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) ,xx(SIZE(x, 2), SIZE(xij, 2)), & + aval + +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN - coeff = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = coeff - ELSE - coeff0 = coeff + + ! coeff = LagrangeCoeff_Quadrangle(& + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff, nrow=indx(1), ncol=indx(2)) END IF + + coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) + ELSE - coeff0 = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) + + ! coeff0 = LagrangeCoeff_Quadrangle(& + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & + nrow=indx(1), ncol=indx(2)) + END IF SELECT CASE (basisType0) CASE (Monomial) - degree = LagrangeDegree_Quadrangle(order=order) - tdof = SIZE(xij, 2) + ! degree = LagrangeDegree_Quadrangle(order=order) + CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & + ncol=indx(2)) - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Quadrangle1", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + IF (ncol .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Quadrangle1", file=__FILE__, line=__LINE__, & + unitno=stderr) + RETURN END IF +#endif - DO ii = 1, tdof - xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2) + DO ii = 1, ncol + indx(1:2) = degree(ii, 1:2) + DO jj = 1, nrow + aval = x(1, jj)**indx(1) * x(2, jj)**indx(2) + xx(jj, ii) = aval + END DO END DO CASE (Heirarchical) - xx = HeirarchicalBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=x) + ! xx = HeirarchicalBasis_Quadrangle( & + CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & + nrow=indx(1), ncol=indx(2)) CASE DEFAULT - xx = TensorProdBasis_Quadrangle( & - & p=order, & - & q=order, & - & xij=x, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) + ! xx = TensorProdBasis_Quadrangle( & + CALL TensorProdBasis_Quadrangle_(p=order, q=order, xij=x, & + basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & + nrow=indx(1), ncol=indx(2)) END SELECT -ans = MATMUL(xx, coeff0) +! ans = MATMUL(xx, coeff0) +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0) -END PROCEDURE LagrangeEvalAll_Quadrangle2 +END PROCEDURE LagrangeEvalAll_Quadrangle2_ !---------------------------------------------------------------------------- ! QuadraturePoint_Quadrangle From fae3a7efb4c6cb2274b40fb86305f6964394b2ee Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 16:35:10 +0900 Subject: [PATCH 115/359] Updates in tetrahedron interpolation --- .../src/TetrahedronInterpolationUtility@Methods.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index d01863753..bb00b6b4b 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -2292,8 +2292,8 @@ END SUBROUTINE IJK2VEFC_Triangle !FIXME: x31(1:3, 1) = x(1:3) - CALL OrthogonalBasis_Tetrahedron(order=order, xij=x31, refTetrahedron=ref0, & - ans=xx, nrow=nrow, ncol=ncol) +CALL OrthogonalBasis_Tetrahedron_(order=order, xij=x31, refTetrahedron=ref0, & + ans=xx, nrow=nrow, ncol=ncol) END SELECT @@ -2392,7 +2392,7 @@ END SUBROUTINE IJK2VEFC_Triangle CASE DEFAULT CALL OrthogonalBasis_Tetrahedron_(order=order, xij=x, refTetrahedron=ref0, & - ans=xx, nrows=indx(1), ncols=indx(2)) + ans=xx, nrow=indx(1), ncol=indx(2)) END SELECT From 9256e6231c9c83cf9a067c732fa5de46662a1ccb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 16:43:29 +0900 Subject: [PATCH 116/359] Updates in prism utility --- .../src/PrismInterpolationUtility.F90 | 94 +++++++++++++++++++ 1 file changed, 94 insertions(+) diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index 290bbfdd9..f8772c379 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -33,6 +33,7 @@ MODULE PrismInterpolationUtility PUBLIC :: TensorQuadraturePoint_Prism PUBLIC :: RefElemDomain_Prism PUBLIC :: LagrangeEvalAll_Prism +PUBLIC :: LagrangeEvalAll_Prism_ PUBLIC :: LagrangeGradientEvalAll_Prism PUBLIC :: EdgeConnectivity_Prism PUBLIC :: FacetConnectivity_Prism @@ -692,6 +693,58 @@ MODULE FUNCTION LagrangeEvalAll_Prism1( & END FUNCTION LagrangeEvalAll_Prism1 END INTERFACE LagrangeEvalAll_Prism +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Prism_ + MODULE SUBROUTINE LagrangeEvalAll_Prism1_(order, x, xij, ans, tsize, & + refPrism, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: tsize + !! ans(SIZE(xij, 2)) + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be computed and returned + !! by this routine. + !! If firstCall is False, then coeff should be given, which will be + !! used. + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Prism1_ +END INTERFACE LagrangeEvalAll_Prism_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Prism !---------------------------------------------------------------------------- @@ -751,6 +804,47 @@ MODULE FUNCTION LagrangeEvalAll_Prism2( & END FUNCTION LagrangeEvalAll_Prism2 END INTERFACE LagrangeEvalAll_Prism +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Prism_ + MODULE SUBROUTINE LagrangeEvalAll_Prism2_(order, x, xij, ans, nrow, ncol, & + refPrism, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Value of n+1 Lagrange polynomials at point x + !! ans(SIZE(x, 2), SIZE(xij, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns in ans + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Prism2_ +END INTERFACE LagrangeEvalAll_Prism_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Prism !---------------------------------------------------------------------------- From 9455731f4c987099f8ba3df153ca1d05fc20642a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 17:42:03 +0900 Subject: [PATCH 117/359] Updates in PyramidInterpolationUtility --- .../src/PyramidInterpolationUtility.F90 | 101 ++++++++++++++++++ .../src/PrismInterpolationUtility@Methods.F90 | 42 +++++--- .../PyramidInterpolationUtility@Methods.F90 | 41 ++++--- 3 files changed, 156 insertions(+), 28 deletions(-) diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 index 6d0b43211..0d671c352 100644 --- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 @@ -33,6 +33,7 @@ MODULE PyramidInterpolationUtility PUBLIC :: TensorQuadraturePoint_Pyramid PUBLIC :: RefElemDomain_Pyramid PUBLIC :: LagrangeEvalAll_Pyramid +PUBLIC :: LagrangeEvalAll_Pyramid_ PUBLIC :: LagrangeGradientEvalAll_Pyramid PUBLIC :: EdgeConnectivity_Pyramid PUBLIC :: FacetConnectivity_Pyramid @@ -689,6 +690,58 @@ MODULE FUNCTION LagrangeEvalAll_Pyramid1( & END FUNCTION LagrangeEvalAll_Pyramid1 END INTERFACE LagrangeEvalAll_Pyramid +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Pyramid_ + MODULE SUBROUTINE LagrangeEvalAll_Pyramid1_(order, x, xij, ans, tsize, & + refPyramid, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(3) + !! point of evaluation + !! x(1) is x coord + !! x(2) is y coord + !! x(3) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + !! The number of rows in xij is 3 + !! The number of columns in xij should be equal to total + !! degree of freedom + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: tsize + !! ans(SIZE(xij, 2)) + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be computed and returned + !! by this routine. + !! If firstCall is False, then coeff should be given, which will be + !! used. + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Pyramid1_ +END INTERFACE LagrangeEvalAll_Pyramid_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Pyramid !---------------------------------------------------------------------------- @@ -748,6 +801,54 @@ MODULE FUNCTION LagrangeEvalAll_Pyramid2( & END FUNCTION LagrangeEvalAll_Pyramid2 END INTERFACE LagrangeEvalAll_Pyramid +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_Pyramid_ + MODULE SUBROUTINE LagrangeEvalAll_Pyramid2_(order, x, xij, ans, nrow, & + ncol, refPyramid, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x, 2), + !! ncol = SIZE(xij, 2) + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Legendre + !! Lobatto + !! Chebyshev + !! Jacobi + !! Ultraspherical + !! Heirarchical + !! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Pyramid2_ +END INTERFACE LagrangeEvalAll_Pyramid_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Pyramid !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 index a0daa9a53..819de72af 100644 --- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 @@ -311,29 +311,43 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Prism1 -! FIX: Implement LagrangeEvalAll_Prism1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Prism1()", & -& file=__FILE__) +INTEGER(I4B) :: tsize +CALL LagrangeEvalAll_Prism1_(order=order, x=x, xij=xij, ans=ans, & + tsize=tsize, refPrism=refPrism, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE LagrangeEvalAll_Prism1 !---------------------------------------------------------------------------- ! LagrangeEvalAll_Prism !---------------------------------------------------------------------------- +MODULE PROCEDURE LagrangeEvalAll_Prism1_ +! FIX: Implement LagrangeEvalAll_Prism1 +CALL ErrorMsg(msg="Work in progress", routine="LagrangeEvalAll_Prism1_()", & + unitno=stdout, line=__LINE__, file=__FILE__) +END PROCEDURE LagrangeEvalAll_Prism1_ + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Prism +!---------------------------------------------------------------------------- + MODULE PROCEDURE LagrangeEvalAll_Prism2 -! FIX: Implement LagrangeEvalAll_Prism2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Prism2()", & -& file=__FILE__) +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Prism2_(order=order, x=x, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol, refPrism=refPrism, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE LagrangeEvalAll_Prism2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Prism2_ +! FIX: Implement LagrangeEvalAll_Prism2 +CALL ErrorMsg(msg="Work in progress", routine="LagrangeEvalAll_Prism2_()", & + unitno=stdout, line=__LINE__, file=__FILE__) +END PROCEDURE LagrangeEvalAll_Prism2_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Prism !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 index dc3a3ed1d..10950438e 100644 --- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 @@ -318,29 +318,42 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Pyramid1 -!FIX: LagrangeEvalAll_Pyramid1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Pyramid1()", & -& file=__FILE__) +INTEGER(I4B) :: tsize + END PROCEDURE LagrangeEvalAll_Pyramid1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Pyramid1_ +!FIX: LagrangeEvalAll_Pyramid1 +CALL ErrorMsg(msg="Work in progress", routine="LagrangeEvalAll_Pyramid1()", & + unitno=stdout, line=__LINE__, file=__FILE__) +END PROCEDURE LagrangeEvalAll_Pyramid1_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Pyramid !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Pyramid2 -!FIX: LagrangeEvalAll_Pyramid2 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeEvalAll_Pyramid2()", & -& file=__FILE__) +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Pyramid2_(order=order, x=x, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol, refPyramid=refPyramid, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) END PROCEDURE LagrangeEvalAll_Pyramid2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Pyramid2_ +!FIX: LagrangeEvalAll_Pyramid2 +CALL ErrorMsg(msg="Work in progress", unitno=stdout, line=__LINE__, & + routine="LagrangeEvalAll_Pyramid2()", file=__FILE__) +END PROCEDURE LagrangeEvalAll_Pyramid2_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Pyramid !---------------------------------------------------------------------------- From b156d87f24c0e6d4d861ef13e3b50465dbe05e89 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 19:01:13 +0900 Subject: [PATCH 118/359] Updates in LagrangePolynomialUtility --- .../src/LagrangePolynomialUtility.F90 | 42 +++ .../src/LagrangePolynomialUtility@Methods.F90 | 342 ++++-------------- 2 files changed, 119 insertions(+), 265 deletions(-) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index 6716999f2..6a98cdf1c 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -36,6 +36,7 @@ MODULE LagrangePolynomialUtility PUBLIC :: InterpolationPoint_ PUBLIC :: LagrangeCoeff PUBLIC :: LagrangeEvalAll +PUBLIC :: LagrangeEvalAll_ PUBLIC :: LagrangeGradientEvalAll !---------------------------------------------------------------------------- @@ -480,6 +481,47 @@ MODULE FUNCTION LagrangeEvalAll1(order, elemType, x, xij, domainName, & END FUNCTION LagrangeEvalAll1 END INTERFACE LagrangeEvalAll +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeEvalAll_ + MODULE SUBROUTINE LagrangeEvalAll1_(order, elemType, x, xij, ans, & + nrow, ncol, domainName, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x, 2) + !! ncol = SIZE(xij, 2) + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE LagrangeEvalAll1_ +END INTERFACE LagrangeEvalAll_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index fddcb5741..26dde296f 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -21,7 +21,7 @@ USE ErrorHandling, ONLY: Errormsg -USE ReferenceElement_Method, ONLY: ElementTopology +USE ReferenceElement_Method, ONLY: ElementTopology, XiDimension USE LineInterpolationUtility, ONLY: LagrangeDOF_Line, & LagrangeInDOF_Line, & @@ -31,7 +31,7 @@ InterpolationPoint_Line_, & LagrangeCoeff_Line, & LagrangeCoeff_Line_, & - LagrangeEvalAll_Line, & + LagrangeEvalAll_Line_, & LagrangeGradientEvalAll_Line USE TriangleInterpolationUtility, ONLY: LagrangeDOF_Triangle, & @@ -42,7 +42,7 @@ InterpolationPoint_Triangle_, & LagrangeCoeff_Triangle, & LagrangeCoeff_Triangle_, & - LagrangeEvalAll_Triangle, & + LagrangeEvalAll_Triangle_, & LagrangeGradientEvalAll_Triangle USE QuadrangleInterpolationUtility, ONLY: LagrangeDOF_Quadrangle, & @@ -53,7 +53,7 @@ InterpolationPoint_Quadrangle_, & LagrangeCoeff_Quadrangle, & LagrangeCoeff_Quadrangle_, & - LagrangeEvalAll_Quadrangle, & + LagrangeEvalAll_Quadrangle_, & LagrangeGradientEvalAll_Quadrangle USE TetrahedronInterpolationUtility, ONLY: LagrangeDOF_Tetrahedron, & @@ -64,7 +64,7 @@ InterpolationPoint_Tetrahedron_, & LagrangeCoeff_Tetrahedron, & LagrangeCoeff_Tetrahedron_, & - LagrangeEvalAll_Tetrahedron, & + LagrangeEvalAll_Tetrahedron_, & LagrangeGradientEvalAll_Tetrahedron USE HexahedronInterpolationUtility, ONLY: LagrangeDOF_Hexahedron, & @@ -75,7 +75,7 @@ InterpolationPoint_Hexahedron_, & LagrangeCoeff_Hexahedron, & LagrangeCoeff_Hexahedron_, & - LagrangeEvalAll_Hexahedron, & + LagrangeEvalAll_Hexahedron_, & LagrangeGradientEvalAll_Hexahedron USE PrismInterpolationUtility, ONLY: LagrangeDOF_Prism, & @@ -86,7 +86,7 @@ InterpolationPoint_Prism_, & LagrangeCoeff_Prism, & LagrangeCoeff_Prism_, & - LagrangeEvalAll_Prism, & + LagrangeEvalAll_Prism_, & LagrangeGradientEvalAll_Prism USE PyramidInterpolationUtility, ONLY: LagrangeDOF_Pyramid, & @@ -97,7 +97,7 @@ InterpolationPoint_Pyramid_, & LagrangeCoeff_Pyramid, & LagrangeCoeff_Pyramid_, & - LagrangeEvalAll_Pyramid, & + LagrangeEvalAll_Pyramid_, & LagrangeGradientEvalAll_Pyramid USE ReallocateUtility, ONLY: Reallocate @@ -299,53 +299,20 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) - -CASE (Point) - IF (PRESENT(xij)) THEN - ans = xij - ELSE - ALLOCATE (ans(0, 0)) - END IF - -CASE (Line) - ans = InterpolationPoint_Line(order=order, ipType=ipType, & - xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) - -CASE (Triangle) - ans = InterpolationPoint_Triangle(order=order, ipType=ipType, & - xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) - -CASE (Quadrangle) - ans = InterpolationPoint_Quadrangle(order=order, ipType=ipType, & - xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) +INTEGER(I4B) :: nrow, ncol -CASE (Tetrahedron) - ans = InterpolationPoint_Tetrahedron(order=order, ipType=ipType, & - xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda) +IF (PRESENT(xij)) THEN + nrow = SIZE(Xij, 1) +ELSE + nrow = XiDimension(elemType) +END IF -CASE (Hexahedron) - ans = InterpolationPoint_Hexahedron(order=order, ipType=ipType, xij=xij, & - layout=layout, alpha=alpha, beta=beta, lambda=lambda) - -CASE (Prism) - ans = InterpolationPoint_Prism(order=order, ipType=ipType, xij=xij, & - layout=layout, alpha=alpha, beta=beta, lambda=lambda) +ncol = LagrangeDOF(order=order, elemType=elemType) +ALLOCATE (ans(nrow, ncol)) -CASE (Pyramid) - ans = InterpolationPoint_Pyramid(order=order, ipType=ipType, xij=xij, & - layout=layout, alpha=alpha, beta=beta, lambda=lambda) - -CASE DEFAULT - CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & - unitno=stdout, line=__LINE__, routine="InterpolationPoint()", & - file=__FILE__) - RETURN -END SELECT +CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType, & + xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE InterpolationPoint @@ -616,40 +583,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff1 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) - -CASE (Point) -CASE (Line) - ans = LagrangeCoeff_Line(order=order, xij=xij, i=i) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, xij=xij, i=i) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, xij=xij, i=i) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij, i=i) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, xij=xij, i=i) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, xij=xij, i=i) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, xij=xij, i=i) - -CASE DEFAULT - CALL Errormsg( & - msg="No CASE FOUND: elemType="//ToString(elemType), & - routine="LagrangeCoeff1()", unitno=stdout, line=__LINE__, file=__FILE__) - RETURN -END SELECT +INTEGER(I4B) :: tsize +CALL LagrangeCoeff1_(order=order, elemType=elemType, i=i, xij=xij, ans=ans, & + tsize=tsize) END PROCEDURE LagrangeCoeff1 @@ -658,40 +594,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff2 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - ans = LagrangeCoeff_Line(order=order, xij=xij) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, xij=xij) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, xij=xij) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, xij=xij) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, xij=xij) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, xij=xij) +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff2_(order=order, elemType=elemType, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) -CASE DEFAULT - CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & - unitno=stdout, line=__LINE__, routine="LagrangeCoeff2()", & - file=__FILE__) - RETURN -END SELECT END PROCEDURE LagrangeCoeff2 !---------------------------------------------------------------------------- @@ -699,41 +605,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff3 -INTEGER(I4B) :: topo -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - ans = LagrangeCoeff_Line(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, isVandermonde=.TRUE.) - -CASE DEFAULT - CALL Errormsg( & - msg="No CASE FOUND: elemType="//ToString(elemType), & - routine="LagrangeCoeff3()", & - unitno=stdout, line=__LINE__, file=__FILE__) - RETURN -END SELECT - +INTEGER(I4B) :: tsize +CALL LagrangeCoeff3_(order=order, elemType=elemType, i=i, v=v, & + isVandermonde=isVandermonde, ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff3 !---------------------------------------------------------------------------- @@ -741,42 +615,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff4 -INTEGER(I4B) :: topo - -topo = ElementTopology(elemType) - -SELECT CASE (topo) -CASE (Point) - -CASE (Line) - ans = LagrangeCoeff_Line(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Triangle) - ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Quadrangle) - ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Tetrahedron) - ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Hexahedron) - ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Prism) - ans = LagrangeCoeff_Prism(order=order, i=i, v=v, ipiv=ipiv) - -CASE (Pyramid) - ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, ipiv=ipiv) - -CASE DEFAULT - CALL Errormsg( & - msg="No CASE FOUND: elemType="//ToString(elemType), & - routine="LagrangeCoeff2()", & - unitno=stdout, line=__LINE__, file=__FILE__) - RETURN -END SELECT - +INTEGER(I4B) :: tsize +CALL LagrangeCoeff4_(order=order, elemType=elemType, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) END PROCEDURE LagrangeCoeff4 !---------------------------------------------------------------------------- @@ -784,6 +625,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll1 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll1_(order=order, elemType=elemType, x=x, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol, domainName=domainName, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE LagrangeEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll1_ INTEGER(I4B) :: topo topo = ElementTopology(elemType) @@ -792,92 +645,51 @@ CASE (Point) CASE (Line) - ans = LagrangeEvalAll_Line( & - & order=order, & - & xij=xij, & - & x=x, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + ! ans = LagrangeEvalAll_Line( & + CALL LagrangeEvalAll_Line_(order=order, xij=xij, x=x, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) CASE (Triangle) - ans = LagrangeEvalAll_Triangle( & - & order=order, & - & x=x, & - & xij=xij, & - & refTriangle=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + ! ans = LagrangeEvalAll_Triangle( & + CALL LagrangeEvalAll_Triangle_(order=order, x=x, xij=xij, & + refTriangle=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) CASE (Quadrangle) - ans = LagrangeEvalAll_Quadrangle( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + ! ans = LagrangeEvalAll_Quadrangle( & + CALL LagrangeEvalAll_Quadrangle_(order=order, x=x, xij=xij, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) CASE (Tetrahedron) - ans = LagrangeEvalAll_Tetrahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & refTetrahedron=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + ! ans = LagrangeEvalAll_Tetrahedron( & + CALL LagrangeEvalAll_Tetrahedron_(order=order, x=x, xij=xij, & + refTetrahedron=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) CASE (Hexahedron) - ans = LagrangeEvalAll_Hexahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + + ! ans = LagrangeEvalAll_Hexahedron( & + CALL LagrangeEvalAll_Hexahedron_(order=order, x=x, xij=xij, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) CASE (Prism) - ans = LagrangeEvalAll_Prism( & - & order=order, & - & x=x, & - & xij=xij, & - & refPrism=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + ! ans = LagrangeEvalAll_Prism( & + CALL LagrangeEvalAll_Prism_(order=order, x=x, xij=xij, & + refPrism=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) CASE (Pyramid) - ans = LagrangeEvalAll_Pyramid( & - & order=order, & - & x=x, & - & xij=xij, & - & refPyramid=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + ! ans = LagrangeEvalAll_Pyramid( & + CALL LagrangeEvalAll_Pyramid_(order=order, x=x, xij=xij, & + refPyramid=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) CASE DEFAULT CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & @@ -886,7 +698,7 @@ RETURN END SELECT -END PROCEDURE LagrangeEvalAll1 +END PROCEDURE LagrangeEvalAll1_ !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll From 6a92cb2da626afb34b4aef0501224590bc9888c8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 20:14:27 +0900 Subject: [PATCH 119/359] Updates in JacobiPolynomialUtility --- .../src/JacobiPolynomialUtility.F90 | 41 +++++++ .../src/JacobiPolynomialUtility@Methods.F90 | 108 ++++++++++++++---- 2 files changed, 126 insertions(+), 23 deletions(-) diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index c0d12a71d..bc14e9fe0 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -49,6 +49,7 @@ MODULE JacobiPolynomialUtility PUBLIC :: JacobiEvalSum PUBLIC :: JacobiGradientEval PUBLIC :: JacobiGradientEvalAll +PUBLIC :: JacobiGradientEvalAll_ PUBLIC :: JacobiGradientEvalSum PUBLIC :: JacobiTransform PUBLIC :: JacobiInvTransform @@ -771,6 +772,28 @@ MODULE PURE FUNCTION JacobiGradientEvalAll1(n, alpha, beta, x) RESULT(ans) END FUNCTION JacobiGradientEvalAll1 END INTERFACE JacobiGradientEvalAll +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE JacobiGradientEvalAll_ + MODULE PURE SUBROUTINE JacobiGradientEvalAll1_(n, alpha, beta, x, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(n + 1) + !! Derivative of Jacobi polynomial of order n at point x + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE JacobiGradientEvalAll1_ +END INTERFACE JacobiGradientEvalAll_ + !---------------------------------------------------------------------------- ! JacobiGradientEvalAll !---------------------------------------------------------------------------- @@ -790,6 +813,24 @@ MODULE PURE FUNCTION JacobiGradientEvalAll2(n, alpha, beta, x) RESULT(ans) END FUNCTION JacobiGradientEvalAll2 END INTERFACE JacobiGradientEvalAll +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE JacobiGradientEvalAll_ + MODULE PURE SUBROUTINE JacobiGradientEvalAll2_(n, alpha, beta, x, & + ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), n + 1) + !! Derivative of Jacobi polynomial of order n at x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE JacobiGradientEvalAll2_ +END INTERFACE JacobiGradientEvalAll_ + !---------------------------------------------------------------------------- ! JacobiGradientEvalSum !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index 5dd7e4f6d..207dd1dcc 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -875,51 +875,58 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiGradientEvalAll1 -!! +INTEGER(I4B) :: tsize +CALL JacobiGradientEvalAll1_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, & + tsize=tsize) +END PROCEDURE JacobiGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalAll1_ INTEGER(I4B) :: ii REAL(DFP) :: j REAL(DFP), DIMENSION(n + 1) :: p REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 -!! -IF (n < 0) THEN - RETURN -END IF -!! + +tsize = 0 + +IF (n < 0) RETURN + +tsize = n + 1 + p(1) = 1.0_DFP ans(1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -!! + +IF (n < 1) RETURN + ab = alpha + beta amb = alpha - beta p(2) = 0.5 * (ab + 2.0) * x + 0.5 * amb ans(2) = 0.5 * (ab + 2.0) -!! + DO ii = 2, n - !! + j = REAL(ii, KIND=DFP) - !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & - & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & - & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); - !! + / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); p(ii + 1) = (a1 * x + a2) * p(ii) - a3 * p(ii - 1) - !! + j = j - 1.0 b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) - !! + ans(ii + 1) = (p(ii) - b1 * ans(ii - 1) - b2 * ans(ii)) / b3 - !! + END DO -!! -END PROCEDURE JacobiGradientEvalAll1 + +END PROCEDURE JacobiGradientEvalAll1_ !---------------------------------------------------------------------------- ! JacobiGradientEvalAll @@ -971,6 +978,61 @@ !! END PROCEDURE JacobiGradientEvalAll2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalAll2_ +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP), DIMENSION(SIZE(x), n + 1) :: p +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 + +nrow = 0 +ncol = 0 + +IF (n < 0) RETURN + +nrow = SIZE(x) +ncol = 1 + n + +p(1:nrow, 1) = 1.0_DFP +ans(1:nrow, 1) = 0.0_DFP + +IF (n < 1) RETURN + +ab = alpha + beta +amb = alpha - beta +p(:, 2) = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans(:, 2) = 0.5 * (ab + 2.0) + +DO ii = 2, n + j = REAL(ii, KIND=DFP) + + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)) + + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)) + + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)) + + p(1:nrow, ii + 1) = (a1 * x + a2) * p(1:nrow, ii) - a3 * p(1:nrow, ii - 1) + + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + + ans(1:nrow, ii + 1) = p(1:nrow, ii) - b1 * ans(1:nrow, ii - 1) & + - b2 * ans(1:nrow, ii) + + ans(1:nrow, ii + 1) = ans(1:nrow, ii + 1) / b3 + +END DO + +END PROCEDURE JacobiGradientEvalAll2_ + !---------------------------------------------------------------------------- ! JacobiGradientEvalSum !---------------------------------------------------------------------------- From f4c3ebd919cde8fa43fb86fa7f842b2a1d6559bf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 21:09:52 +0900 Subject: [PATCH 120/359] Updates in LegendrePolynomial utility --- .../src/LegendrePolynomialUtility.F90 | 147 +++++++----------- .../src/LegendrePolynomialUtility@Methods.F90 | 104 +++++++------ 2 files changed, 118 insertions(+), 133 deletions(-) diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index b540a4d00..783a86868 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -49,6 +49,7 @@ MODULE LegendrePolynomialUtility PUBLIC :: LegendreMonomialExpansionAll PUBLIC :: LegendreMonomialExpansion PUBLIC :: LegendreGradientEvalAll +PUBLIC :: LegendreGradientEvalAll_ PUBLIC :: LegendreGradientEval PUBLIC :: LegendreEvalSum PUBLIC :: LegendreGradientEvalSum @@ -709,6 +710,25 @@ END FUNCTION LegendreGradientEvalAll1 ! !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n + +INTERFACE LegendreGradientEvalAll_ + MODULE PURE SUBROUTINE LegendreGradientEvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(1:n + 1) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size + END SUBROUTINE LegendreGradientEvalAll1_ +END INTERFACE LegendreGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of legendre polynomial of order upto n @@ -725,6 +745,22 @@ END FUNCTION LegendreGradientEvalAll2 ! !---------------------------------------------------------------------------- +INTERFACE LegendreGradientEvalAll_ + MODULE PURE SUBROUTINE LegendreGradientEvalAll2_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(1:SIZE(x), 1:n + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x) + !! ncol = n + 1 + END SUBROUTINE LegendreGradientEvalAll2_ +END INTERFACE LegendreGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of legendre polynomial of order upto n @@ -733,17 +769,12 @@ END FUNCTION LegendreGradientEvalAll2 ! ! Evaluate gradient of legendre polynomial of order upto n. -INTERFACE +INTERFACE LegendreGradientEval MODULE PURE FUNCTION LegendreGradientEval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans END FUNCTION LegendreGradientEval1 -END INTERFACE -!! - -INTERFACE LegendreGradientEval - MODULE PROCEDURE LegendreGradientEval1 END INTERFACE LegendreGradientEval !---------------------------------------------------------------------------- @@ -758,17 +789,12 @@ END FUNCTION LegendreGradientEval1 ! ! Evaluate gradient of legendre polynomial of order upto n. -INTERFACE +INTERFACE LegendreGradientEval MODULE PURE FUNCTION LegendreGradientEval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(1:SIZE(x)) END FUNCTION LegendreGradientEval2 -END INTERFACE -!! - -INTERFACE LegendreGradientEval - MODULE PROCEDURE LegendreGradientEval2 END INTERFACE LegendreGradientEval !---------------------------------------------------------------------------- @@ -779,7 +805,7 @@ END FUNCTION LegendreGradientEval2 ! date: 6 Sept 2022 ! summary: Evaluate finite sum of Legendre polynomials at point x -INTERFACE +INTERFACE LegendreEvalSum MODULE PURE FUNCTION LegendreEvalSum1(n, x, coeff) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -791,10 +817,6 @@ MODULE PURE FUNCTION LegendreEvalSum1(n, x, coeff) & REAL(DFP) :: ans !! Evaluate Legendre polynomial of order n at point x END FUNCTION LegendreEvalSum1 -END INTERFACE - -INTERFACE LegendreEvalSum - MODULE PROCEDURE LegendreEvalSum1 END INTERFACE LegendreEvalSum !---------------------------------------------------------------------------- @@ -805,7 +827,7 @@ END FUNCTION LegendreEvalSum1 ! date: 6 Sept 2022 ! summary: Evaluate finite sum of Legendre polynomials at several x -INTERFACE +INTERFACE LegendreEvalSum MODULE PURE FUNCTION LegendreEvalSum2(n, x, coeff) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -816,10 +838,6 @@ MODULE PURE FUNCTION LegendreEvalSum2(n, x, coeff) RESULT(ans) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Legendre polynomial of order n at point x END FUNCTION LegendreEvalSum2 -END INTERFACE - -INTERFACE LegendreEvalSum - MODULE PROCEDURE LegendreEvalSum2 END INTERFACE LegendreEvalSum !---------------------------------------------------------------------------- @@ -831,7 +849,7 @@ END FUNCTION LegendreEvalSum2 ! summary: Evaluate the gradient of finite sum of Legendre polynomials ! at point x -INTERFACE +INTERFACE LegendreGradientEvalSum MODULE PURE FUNCTION LegendreGradientEvalSum1(n, x, coeff) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -842,10 +860,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum1(n, x, coeff) RESULT(ans) REAL(DFP) :: ans !! Evaluate Legendre polynomial of order n at point x END FUNCTION LegendreGradientEvalSum1 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum1 END INTERFACE LegendreGradientEvalSum !---------------------------------------------------------------------------- @@ -857,9 +871,8 @@ END FUNCTION LegendreGradientEvalSum1 ! summary: Evaluate the gradient of finite sum of Legendre polynomials ! at several x -INTERFACE - MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) & - & RESULT(ans) +INTERFACE LegendreGradientEvalSum + MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: x(:) @@ -869,10 +882,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) & REAL(DFP) :: ans(SIZE(x)) !! Evaluate Legendre polynomial of order n at point x END FUNCTION LegendreGradientEvalSum2 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum2 END INTERFACE LegendreGradientEvalSum !---------------------------------------------------------------------------- @@ -884,7 +893,7 @@ END FUNCTION LegendreGradientEvalSum2 ! summary: Evaluate the kth derivative of finite sum of Legendre ! polynomials at point x -INTERFACE +INTERFACE LegendreGradientEvalSum MODULE PURE FUNCTION LegendreGradientEvalSum3(n, x, coeff, k) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -897,10 +906,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum3(n, x, coeff, k) RESULT(ans) REAL(DFP) :: ans !! Evaluate Legendre polynomial of order n at point x END FUNCTION LegendreGradientEvalSum3 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum3 END INTERFACE LegendreGradientEvalSum !---------------------------------------------------------------------------- @@ -912,7 +917,7 @@ END FUNCTION LegendreGradientEvalSum3 ! summary: Evaluate the kth gradient of finite sum of Legendre ! polynomials at several x -INTERFACE +INTERFACE LegendreGradientEvalSum MODULE PURE FUNCTION LegendreGradientEvalSum4(n, x, coeff, k) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -925,10 +930,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum4(n, x, coeff, k) RESULT(ans) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Legendre polynomial of order n at point x END FUNCTION LegendreGradientEvalSum4 -END INTERFACE - -INTERFACE LegendreGradientEvalSum - MODULE PROCEDURE LegendreGradientEvalSum4 END INTERFACE LegendreGradientEvalSum !---------------------------------------------------------------------------- @@ -939,7 +940,7 @@ END FUNCTION LegendreGradientEvalSum4 ! date: 13 Oct 2022 ! summary: Discrete Legendre Transform -INTERFACE +INTERFACE LegendreTransform MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & & quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -956,10 +957,6 @@ MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION LegendreTransform1 -END INTERFACE - -INTERFACE LegendreTransform - MODULE PROCEDURE LegendreTransform1 END INTERFACE LegendreTransform !---------------------------------------------------------------------------- @@ -970,7 +967,7 @@ END FUNCTION LegendreTransform1 ! date: 13 Oct 2022 ! summary: Columnwise Discrete Legendre Transform -INTERFACE +INTERFACE LegendreTransform MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & & quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -987,14 +984,10 @@ MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) !! modal values or coefficients for each column of val END FUNCTION LegendreTransform2 -END INTERFACE - -INTERFACE LegendreTransform - MODULE PROCEDURE LegendreTransform2 END INTERFACE LegendreTransform !---------------------------------------------------------------------------- -! LegendreTransform +! LegendreTransform !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1021,7 +1014,7 @@ END FUNCTION LegendreTransform2 ! `LegendreQuadrature` which is not pure due to Lapack call. !@endnote -INTERFACE +INTERFACE LegendreTransform MODULE FUNCTION LegendreTransform3(n, f, quadType) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1034,21 +1027,17 @@ MODULE FUNCTION LegendreTransform3(n, f, quadType) & REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION LegendreTransform3 -END INTERFACE - -INTERFACE LegendreTransform - MODULE PROCEDURE LegendreTransform3 END INTERFACE LegendreTransform !---------------------------------------------------------------------------- -! LegendreInvTransform +! LegendreInvTransform !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 13 Oct 2022 ! summary: Inverse Legendre Transform -INTERFACE +INTERFACE LegendreInvTransform MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1060,21 +1049,17 @@ MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) & REAL(DFP) :: ans !! value in physical space END FUNCTION LegendreInvTransform1 -END INTERFACE - -INTERFACE LegendreInvTransform - MODULE PROCEDURE LegendreInvTransform1 END INTERFACE LegendreInvTransform !---------------------------------------------------------------------------- -! LegendreInvTransform +! LegendreInvTransform !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 13 Oct 2022 ! summary: Inverse Legendre Transform -INTERFACE +INTERFACE LegendreInvTransform MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1086,14 +1071,10 @@ MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) & REAL(DFP) :: ans(SIZE(x)) !! value in physical space END FUNCTION LegendreInvTransform2 -END INTERFACE - -INTERFACE LegendreInvTransform - MODULE PROCEDURE LegendreInvTransform2 END INTERFACE LegendreInvTransform !---------------------------------------------------------------------------- -! LegendreGradientCoeff +! LegendreGradientCoeff !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1106,7 +1087,7 @@ END FUNCTION LegendreInvTransform2 !- Input is coefficient of Legendre expansion (modal values) !- Output is coefficient of derivative of legendre expansion (modal values) -INTERFACE +INTERFACE LegendreGradientCoeff MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1116,10 +1097,6 @@ MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) & REAL(DFP) :: ans(0:n) !! coefficient of gradient END FUNCTION LegendreGradientCoeff1 -END INTERFACE - -INTERFACE LegendreGradientCoeff - MODULE PROCEDURE LegendreGradientCoeff1 END INTERFACE LegendreGradientCoeff !---------------------------------------------------------------------------- @@ -1130,7 +1107,7 @@ END FUNCTION LegendreGradientCoeff1 ! date: 15 Oct 2022 ! summary: Returns differentiation matrix for Legendre expansion -INTERFACE +INTERFACE LegendreDMatrix MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1142,21 +1119,17 @@ MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) & REAL(DFP) :: ans(0:n, 0:n) !! D matrix END FUNCTION LegendreDMatrix1 -END INTERFACE - -INTERFACE LegendreDMatrix - MODULE PROCEDURE LegendreDMatrix1 END INTERFACE LegendreDMatrix !---------------------------------------------------------------------------- -! LegendreDMatEvenOdd +! LegendreDMatEvenOdd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 15 Oct 2022 ! summary: Performs even and odd decomposition of Differential matrix -INTERFACE +INTERFACE LegendreDMatEvenOdd MODULE PURE SUBROUTINE LegendreDMatEvenOdd1(n, D, e, o) INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomial @@ -1167,10 +1140,6 @@ MODULE PURE SUBROUTINE LegendreDMatEvenOdd1(n, D, e, o) REAL(DFP), INTENT(OUT) :: o(0:, 0:) !! odd decomposition, 0:n/2, 0:n/2 END SUBROUTINE LegendreDMatEvenOdd1 -END INTERFACE - -INTERFACE LegendreDMatEvenOdd - MODULE PROCEDURE LegendreDMatEvenOdd1 END INTERFACE LegendreDMatEvenOdd !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index baba400bf..4cf8512b6 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -581,76 +581,92 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEvalAll1 - !! +INTEGER(I4B) :: tsize +CALL LegendreGradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize) +END PROCEDURE LegendreGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalAll1_ INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP) :: p(1:n + 1) - !! -IF (n < 0) THEN - RETURN -END IF -!! + +tsize = 0 + +IF (n < 0) RETURN + +tsize = n + 1 p(1) = 1.0_DFP ans(1) = 0.0_DFP - !! -IF (n < 1) THEN - RETURN -END IF -!! + +IF (n < 1) RETURN + p(2) = x ans(2) = 1.0_DFP - !! + DO ii = 2, n - !! r_ii = REAL(ii, KIND=DFP) - !! + p(ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(ii) & & - (r_ii - 1.0_DFP) * p(ii - 1)) & & / r_ii - !! + ans(ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(ii) + ans(ii - 1) - !! + END DO -!! -END PROCEDURE LegendreGradientEvalAll1 + +END PROCEDURE LegendreGradientEvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEvalAll2 -!! +INTEGER(I4B) :: nrow, ncol +CALL LegendreGradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LegendreGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalAll2_ INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP) :: p(1:SIZE(x), 1:n + 1) -!! -IF (n < 0) THEN - RETURN -END IF -!! -p(:, 1) = 1.0_DFP -ans(:, 1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -p(:, 2) = x -ans(:, 2) = 1.0_DFP -!! + +nrow = 0; ncol = 0 + +IF (n < 0) RETURN + +nrow = SIZE(x) +ncol = n + 1 + +p(1:nrow, 1) = 1.0_DFP +ans(1:nrow, 1) = 0.0_DFP + +IF (n < 1) RETURN + +p(1:nrow, 2) = x +ans(1:nrow, 2) = 1.0_DFP + DO ii = 2, n - !! + r_ii = REAL(ii, KIND=DFP) - !! - p(:, ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(:, ii) & - & - (r_ii - 1.0_DFP) * p(:, ii - 1)) & - & / r_ii - !! - ans(:, ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(:, ii) + ans(:, ii - 1) - !! + + p(1:nrow, ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(1:nrow, ii) & + - (r_ii - 1.0_DFP) * p(1:nrow, ii - 1)) & + / r_ii + + ans(1:nrow, ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(1:nrow, ii) & + + ans(1:nrow, ii - 1) + END DO -!! -END PROCEDURE LegendreGradientEvalAll2 + +END PROCEDURE LegendreGradientEvalAll2_ !---------------------------------------------------------------------------- ! From c6a023243ccfca89404dae137c721e831a9fa83a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 21:24:55 +0900 Subject: [PATCH 121/359] Updates in Chebyshev1PolynomialUtility --- .../src/Chebyshev1PolynomialUtility.F90 | 150 ++++++------------ .../Chebyshev1PolynomialUtility@Methods.F90 | 110 +++++++------ 2 files changed, 111 insertions(+), 149 deletions(-) diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index 5866376d7..04057051b 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -41,6 +41,7 @@ MODULE Chebyshev1PolynomialUtility PUBLIC :: Chebyshev1MonomialExpansionAll PUBLIC :: Chebyshev1MonomialExpansion PUBLIC :: Chebyshev1GradientEvalAll +PUBLIC :: Chebyshev1GradientEvalAll_ PUBLIC :: Chebyshev1GradientEval PUBLIC :: Chebyshev1EvalSum PUBLIC :: Chebyshev1GradientEvalSum @@ -407,7 +408,7 @@ END SUBROUTINE Chebyshev1Quadrature ! date: 6 Sept 2022 ! summary: Evaluate Chebyshev1 polynomials of order = n at single x -INTERFACE +INTERFACE Chebyshev1Eval MODULE PURE FUNCTION Chebyshev1Eval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -416,10 +417,6 @@ MODULE PURE FUNCTION Chebyshev1Eval1(n, x) RESULT(ans) REAL(DFP) :: ans !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1Eval1 -END INTERFACE - -INTERFACE Chebyshev1Eval - MODULE PROCEDURE Chebyshev1Eval1 END INTERFACE Chebyshev1Eval !---------------------------------------------------------------------------- @@ -430,7 +427,7 @@ END FUNCTION Chebyshev1Eval1 ! date: 6 Sept 2022 ! summary: Evaluate Chebyshev1 polynomials of order n at several points -INTERFACE +INTERFACE Chebyshev1Eval MODULE PURE FUNCTION Chebyshev1Eval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -439,10 +436,6 @@ MODULE PURE FUNCTION Chebyshev1Eval2(n, x) RESULT(ans) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1Eval2 -END INTERFACE - -INTERFACE Chebyshev1Eval - MODULE PROCEDURE Chebyshev1Eval2 END INTERFACE Chebyshev1Eval !---------------------------------------------------------------------------- @@ -610,22 +603,32 @@ END FUNCTION Chebyshev1MonomialExpansion ! ! Evaluate gradient of Chebyshev1 polynomial of order upto n. -INTERFACE +INTERFACE Chebyshev1GradientEvalAll MODULE PURE FUNCTION Chebyshev1GradientEvalAll1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans(1:n + 1) END FUNCTION Chebyshev1GradientEvalAll1 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalAll - MODULE PROCEDURE Chebyshev1GradientEvalAll1 END INTERFACE Chebyshev1GradientEvalAll !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +INTERFACE Chebyshev1GradientEvalAll_ + MODULE PURE SUBROUTINE Chebyshev1GradientEvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + !! ans(1:n + 1) + END SUBROUTINE Chebyshev1GradientEvalAll1_ +END INTERFACE Chebyshev1GradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n @@ -634,22 +637,32 @@ END FUNCTION Chebyshev1GradientEvalAll1 ! ! Evaluate gradient of Chebyshev1 polynomial of order upto n. -INTERFACE +INTERFACE Chebyshev1GradientEvalAll MODULE PURE FUNCTION Chebyshev1GradientEvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) END FUNCTION Chebyshev1GradientEvalAll2 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalAll - MODULE PROCEDURE Chebyshev1GradientEvalAll2 END INTERFACE Chebyshev1GradientEvalAll !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +INTERFACE Chebyshev1GradientEvalAll_ + MODULE PURE SUBROUTINE Chebyshev1GradientEvalAll2_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(1:SIZE(x), 1:n + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Chebyshev1GradientEvalAll2_ +END INTERFACE Chebyshev1GradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n @@ -658,17 +671,12 @@ END FUNCTION Chebyshev1GradientEvalAll2 ! ! Evaluate gradient of Chebyshev1 polynomial of order upto n. -INTERFACE +INTERFACE Chebyshev1GradientEval MODULE PURE FUNCTION Chebyshev1GradientEval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans END FUNCTION Chebyshev1GradientEval1 -END INTERFACE -!! - -INTERFACE Chebyshev1GradientEval - MODULE PROCEDURE Chebyshev1GradientEval1 END INTERFACE Chebyshev1GradientEval !---------------------------------------------------------------------------- @@ -683,16 +691,12 @@ END FUNCTION Chebyshev1GradientEval1 ! ! Evaluate gradient of Chebyshev1 polynomial of order upto n. -INTERFACE +INTERFACE Chebyshev1GradientEval MODULE PURE FUNCTION Chebyshev1GradientEval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(1:SIZE(x)) END FUNCTION Chebyshev1GradientEval2 -END INTERFACE - -INTERFACE Chebyshev1GradientEval - MODULE PROCEDURE Chebyshev1GradientEval2 END INTERFACE Chebyshev1GradientEval !---------------------------------------------------------------------------- @@ -703,7 +707,7 @@ END FUNCTION Chebyshev1GradientEval2 ! date: 6 Sept 2022 ! summary: Evaluate finite sum of Chebyshev1 polynomials at point x -INTERFACE +INTERFACE Chebyshev1EvalSum MODULE PURE FUNCTION Chebyshev1EvalSum1(n, x, coeff) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -715,10 +719,6 @@ MODULE PURE FUNCTION Chebyshev1EvalSum1(n, x, coeff) & REAL(DFP) :: ans !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1EvalSum1 -END INTERFACE - -INTERFACE Chebyshev1EvalSum - MODULE PROCEDURE Chebyshev1EvalSum1 END INTERFACE Chebyshev1EvalSum !---------------------------------------------------------------------------- @@ -729,7 +729,7 @@ END FUNCTION Chebyshev1EvalSum1 ! date: 6 Sept 2022 ! summary: Evaluate finite sum of Chebyshev1 polynomials at several x -INTERFACE +INTERFACE Chebyshev1EvalSum MODULE PURE FUNCTION Chebyshev1EvalSum2(n, x, coeff) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -740,10 +740,6 @@ MODULE PURE FUNCTION Chebyshev1EvalSum2(n, x, coeff) RESULT(ans) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1EvalSum2 -END INTERFACE - -INTERFACE Chebyshev1EvalSum - MODULE PROCEDURE Chebyshev1EvalSum2 END INTERFACE Chebyshev1EvalSum !---------------------------------------------------------------------------- @@ -755,7 +751,7 @@ END FUNCTION Chebyshev1EvalSum2 ! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials ! at point x -INTERFACE +INTERFACE Chebyshev1GradientEvalSum MODULE PURE FUNCTION Chebyshev1GradientEvalSum1(n, x, coeff) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -766,10 +762,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum1(n, x, coeff) RESULT(ans) REAL(DFP) :: ans !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1GradientEvalSum1 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum1 END INTERFACE Chebyshev1GradientEvalSum !---------------------------------------------------------------------------- @@ -781,7 +773,7 @@ END FUNCTION Chebyshev1GradientEvalSum1 ! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials ! at several x -INTERFACE +INTERFACE Chebyshev1GradientEvalSum MODULE PURE FUNCTION Chebyshev1GradientEvalSum2(n, x, coeff) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -793,10 +785,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum2(n, x, coeff) & REAL(DFP) :: ans(SIZE(x)) !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1GradientEvalSum2 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum2 END INTERFACE Chebyshev1GradientEvalSum !---------------------------------------------------------------------------- @@ -808,7 +796,7 @@ END FUNCTION Chebyshev1GradientEvalSum2 ! summary: Evaluate the kth derivative of finite sum of Chebyshev1 ! polynomials at point x -INTERFACE +INTERFACE Chebyshev1GradientEvalSum MODULE PURE FUNCTION Chebyshev1GradientEvalSum3(n, x, coeff, k) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -821,10 +809,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum3(n, x, coeff, k) RESULT(ans) REAL(DFP) :: ans !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1GradientEvalSum3 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum3 END INTERFACE Chebyshev1GradientEvalSum !---------------------------------------------------------------------------- @@ -836,7 +820,7 @@ END FUNCTION Chebyshev1GradientEvalSum3 ! summary: Evaluate the kth gradient of finite sum of Chebyshev1 ! polynomials at several x -INTERFACE +INTERFACE Chebyshev1GradientEvalSum MODULE PURE FUNCTION Chebyshev1GradientEvalSum4(n, x, coeff, k) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -849,10 +833,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum4(n, x, coeff, k) RESULT(ans) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Chebyshev1 polynomial of order n at point x END FUNCTION Chebyshev1GradientEvalSum4 -END INTERFACE - -INTERFACE Chebyshev1GradientEvalSum - MODULE PROCEDURE Chebyshev1GradientEvalSum4 END INTERFACE Chebyshev1GradientEvalSum !---------------------------------------------------------------------------- @@ -863,7 +843,7 @@ END FUNCTION Chebyshev1GradientEvalSum4 ! date: 13 Oct 2022 ! summary: Discrete Chebyshev1 Transform -INTERFACE +INTERFACE Chebyshev1Transform MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, & & quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -880,10 +860,6 @@ MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, & REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION Chebyshev1Transform1 -END INTERFACE - -INTERFACE Chebyshev1Transform - MODULE PROCEDURE Chebyshev1Transform1 END INTERFACE Chebyshev1Transform !---------------------------------------------------------------------------- @@ -894,7 +870,7 @@ END FUNCTION Chebyshev1Transform1 ! date: 13 Oct 2022 ! summary: Columnwise Discrete Chebyshev1 Transform -INTERFACE +INTERFACE Chebyshev1Transform MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, & & quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -911,10 +887,6 @@ MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, & REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) !! modal values or coefficients for each column of val END FUNCTION Chebyshev1Transform2 -END INTERFACE - -INTERFACE Chebyshev1Transform - MODULE PROCEDURE Chebyshev1Transform2 END INTERFACE Chebyshev1Transform !---------------------------------------------------------------------------- @@ -945,7 +917,7 @@ END FUNCTION Chebyshev1Transform2 ! `Chebyshev1Quadrature` which is not pure due to Lapack call. !@endnote -INTERFACE +INTERFACE Chebyshev1Transform MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -958,10 +930,6 @@ MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) & REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION Chebyshev1Transform3 -END INTERFACE - -INTERFACE Chebyshev1Transform - MODULE PROCEDURE Chebyshev1Transform3 END INTERFACE Chebyshev1Transform !---------------------------------------------------------------------------- @@ -998,7 +966,7 @@ END FUNCTION Chebyshev1Transform4 ! date: 13 Oct 2022 ! summary: Inverse Chebyshev1 Transform -INTERFACE +INTERFACE Chebyshev1InvTransform MODULE PURE FUNCTION Chebyshev1InvTransform1(n, coeff, x) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1010,10 +978,6 @@ MODULE PURE FUNCTION Chebyshev1InvTransform1(n, coeff, x) & REAL(DFP) :: ans !! value in physical space END FUNCTION Chebyshev1InvTransform1 -END INTERFACE - -INTERFACE Chebyshev1InvTransform - MODULE PROCEDURE Chebyshev1InvTransform1 END INTERFACE Chebyshev1InvTransform !---------------------------------------------------------------------------- @@ -1024,7 +988,7 @@ END FUNCTION Chebyshev1InvTransform1 ! date: 13 Oct 2022 ! summary: Inverse Chebyshev1 Transform -INTERFACE +INTERFACE Chebyshev1InvTransform MODULE PURE FUNCTION Chebyshev1InvTransform2(n, coeff, x) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1036,10 +1000,6 @@ MODULE PURE FUNCTION Chebyshev1InvTransform2(n, coeff, x) & REAL(DFP) :: ans(SIZE(x)) !! value in physical space END FUNCTION Chebyshev1InvTransform2 -END INTERFACE - -INTERFACE Chebyshev1InvTransform - MODULE PROCEDURE Chebyshev1InvTransform2 END INTERFACE Chebyshev1InvTransform !---------------------------------------------------------------------------- @@ -1056,7 +1016,7 @@ END FUNCTION Chebyshev1InvTransform2 !- Input is coefficient of Chebyshev1 expansion (modal values) !- Output is coefficient of derivative of Chebyshev1 expansion (modal values) -INTERFACE +INTERFACE Chebyshev1GradientCoeff MODULE PURE FUNCTION Chebyshev1GradientCoeff1(n, coeff) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1066,10 +1026,6 @@ MODULE PURE FUNCTION Chebyshev1GradientCoeff1(n, coeff) & REAL(DFP) :: ans(0:n) !! coefficient of gradient END FUNCTION Chebyshev1GradientCoeff1 -END INTERFACE - -INTERFACE Chebyshev1GradientCoeff - MODULE PROCEDURE Chebyshev1GradientCoeff1 END INTERFACE Chebyshev1GradientCoeff !---------------------------------------------------------------------------- @@ -1080,7 +1036,7 @@ END FUNCTION Chebyshev1GradientCoeff1 ! date: 15 Oct 2022 ! summary: Returns differentiation matrix for Chebyshev1 expansion -INTERFACE +INTERFACE Chebyshev1DMatrix MODULE PURE FUNCTION Chebyshev1DMatrix1(n, x, quadType) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1092,10 +1048,6 @@ MODULE PURE FUNCTION Chebyshev1DMatrix1(n, x, quadType) & REAL(DFP) :: ans(0:n, 0:n) !! D matrix END FUNCTION Chebyshev1DMatrix1 -END INTERFACE - -INTERFACE Chebyshev1DMatrix - MODULE PROCEDURE Chebyshev1DMatrix1 END INTERFACE Chebyshev1DMatrix !---------------------------------------------------------------------------- @@ -1106,7 +1058,7 @@ END FUNCTION Chebyshev1DMatrix1 ! date: 15 Oct 2022 ! summary: Performs even and odd decomposition of Differential matrix -INTERFACE +INTERFACE Chebyshev1DMatEvenOdd MODULE PURE SUBROUTINE Chebyshev1DMatEvenOdd1(n, D, e, o) INTEGER(I4B), INTENT(IN) :: n !! order of Chebyshev1 polynomial @@ -1117,10 +1069,6 @@ MODULE PURE SUBROUTINE Chebyshev1DMatEvenOdd1(n, D, e, o) REAL(DFP), INTENT(OUT) :: o(0:, 0:) !! odd decomposition, 0:n/2, 0:n/2 END SUBROUTINE Chebyshev1DMatEvenOdd1 -END INTERFACE - -INTERFACE Chebyshev1DMatEvenOdd - MODULE PROCEDURE Chebyshev1DMatEvenOdd1 END INTERFACE Chebyshev1DMatEvenOdd END MODULE Chebyshev1PolynomialUtility diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index 22cb2e167..cd675f95d 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -474,82 +474,96 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GradientEvalAll1 -!! +INTEGER(I4B) :: tsize +CALL Chebyshev1GradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize) +END PROCEDURE Chebyshev1GradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalAll1_ INTEGER(I4B) :: ii REAL(DFP) :: p(1:n + 1), r_ii -!! -IF (n < 0) THEN - RETURN -END IF -!! + +tsize = 0 +IF (n < 0) RETURN + +tsize = n + 1 p(1) = 1.0_DFP ans(1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -IF (n .EQ. 0_I4B) RETURN -!! + +IF (n < 1) RETURN + p(2) = x ans(2) = 1.0_DFP -!! + IF (n .EQ. 1_I4B) RETURN -!! + p(3) = 2.0_DFP * x**2 - 1.0_DFP ans(3) = 4.0_DFP * x -!! + DO ii = 3, n - !! + r_ii = REAL(ii, KIND=DFP) p(ii + 1) = (2.0_DFP * x) * p(ii) - p(ii - 1) + ans(ii + 1) = 2.0_DFP * r_ii * p(ii) & & + r_ii * ans(ii - 1) / (r_ii - 2.0_DFP) - !! + END DO -!! -END PROCEDURE Chebyshev1GradientEvalAll1 + +END PROCEDURE Chebyshev1GradientEvalAll1_ !---------------------------------------------------------------------------- ! Chebyshev1GradientEvalAll2 !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GradientEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL Chebyshev1GradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE Chebyshev1GradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalAll2_ !! INTEGER(I4B) :: ii REAL(DFP) :: p(1:SIZE(x), 1:n + 1), r_ii -!! -IF (n < 0) THEN - RETURN -END IF -!! -p(:, 1) = 1.0_DFP -ans(:, 1) = 0.0_DFP -!! -IF (n < 1) THEN - RETURN -END IF -!! -IF (n .EQ. 0_I4B) RETURN -!! -p(:, 2) = x -ans(:, 2) = 1.0_DFP -!! + +nrow = 0; ncol = 0 + +IF (n < 0) RETURN + +nrow = SIZE(x) +ncol = n + 1 + +p(1:nrow, 1) = 1.0_DFP +ans(1:nrow, 1) = 0.0_DFP + +IF (n < 1) RETURN + +p(1:nrow, 2) = x +ans(1:nrow, 2) = 1.0_DFP + IF (n .EQ. 1_I4B) RETURN -!! -p(:, 3) = 2.0_DFP * x**2 - 1.0_DFP -ans(:, 3) = 4.0_DFP * x -!! + +p(1:nrow, 3) = 2.0_DFP * x**2 - 1.0_DFP +ans(1:nrow, 3) = 4.0_DFP * x + DO ii = 3, n - !! + r_ii = REAL(ii, KIND=DFP) - p(:, ii + 1) = (2.0_DFP * x) * p(:, ii) - p(:, ii - 1) - ans(:, ii + 1) = 2.0_DFP * r_ii * p(:, ii) & - & + r_ii * ans(:, ii - 1) / (r_ii - 2.0_DFP) - !! + p(1:nrow, ii + 1) = (2.0_DFP * x) * p(1:nrow, ii) - p(1:nrow, ii - 1) + + ans(1:nrow, ii + 1) = 2.0_DFP * r_ii * p(1:nrow, ii) & + + r_ii * ans(1:nrow, ii - 1) / (r_ii - 2.0_DFP) + END DO -!! -END PROCEDURE Chebyshev1GradientEvalAll2 + +END PROCEDURE Chebyshev1GradientEvalAll2_ !---------------------------------------------------------------------------- ! Chebyshev1GradientEval1 From d2f96b1bff9a2bff920d69c225f03a1eb41a648a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 22:09:25 +0900 Subject: [PATCH 122/359] updates in lobatto polynomial --- .../src/LobattoPolynomialUtility.F90 | 54 +++++++++++-------- 1 file changed, 33 insertions(+), 21 deletions(-) diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index 02bd6c6d7..5ed9fa613 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -110,17 +110,13 @@ END FUNCTION LobattoZeros !- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point ! X. -INTERFACE +INTERFACE LobattoEval MODULE PURE FUNCTION LobattoEval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans !! Evaluate Lobatto polynomial of order n at point x END FUNCTION LobattoEval1 -END INTERFACE - -INTERFACE LobattoEval - MODULE PROCEDURE LobattoEval1 END INTERFACE LobattoEval !---------------------------------------------------------------------------- @@ -142,17 +138,13 @@ END FUNCTION LobattoEval1 !- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point ! X. -INTERFACE +INTERFACE LobattoEval MODULE PURE FUNCTION LobattoEval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Lobatto polynomial of order n at point x END FUNCTION LobattoEval2 -END INTERFACE - -INTERFACE LobattoEval - MODULE PROCEDURE LobattoEval2 END INTERFACE LobattoEval !---------------------------------------------------------------------------- @@ -418,6 +410,20 @@ END FUNCTION LobattoGradientEvalAll1 ! !---------------------------------------------------------------------------- +INTERFACE LobattoGradientEvalAll_ + MODULE PURE SUBROUTINE LobattoGradientEvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(1:n + 1) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LobattoGradientEvalAll1_ +END INTERFACE LobattoGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of Lobatto polynomial of order upto n @@ -438,6 +444,20 @@ END FUNCTION LobattoGradientEvalAll2 ! !---------------------------------------------------------------------------- +INTERFACE LobattoGradientEvalAll_ + MODULE PURE SUBROUTINE LobattoGradientEvalAll2_(n, x, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + ! ans(1:SIZE(x), 1:n + 1) + END SUBROUTINE LobattoGradientEvalAll2_ +END INTERFACE LobattoGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of Lobatto polynomial of order upto n @@ -446,18 +466,14 @@ END FUNCTION LobattoGradientEvalAll2 ! ! Evaluate gradient of Lobatto polynomial of order upto n. -INTERFACE +INTERFACE LobattoGradientEval MODULE PURE FUNCTION LobattoGradientEval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans END FUNCTION LobattoGradientEval1 -END INTERFACE -!! - -INTERFACE LobattoGradientEval - MODULE PROCEDURE LobattoGradientEval1 END INTERFACE LobattoGradientEval +!! !---------------------------------------------------------------------------- ! @@ -471,16 +487,12 @@ END FUNCTION LobattoGradientEval1 ! ! Evaluate gradient of Lobatto polynomial of order upto n. -INTERFACE +INTERFACE LobattoGradientEval MODULE PURE FUNCTION LobattoGradientEval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(1:SIZE(x)) END FUNCTION LobattoGradientEval2 -END INTERFACE - -INTERFACE LobattoGradientEval - MODULE PROCEDURE LobattoGradientEval2 END INTERFACE LobattoGradientEval !---------------------------------------------------------------------------- From d86c052ace2ed247965203d1e0a35d1798c16205 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 30 Jun 2024 22:35:47 +0900 Subject: [PATCH 123/359] updates in lobatto polynomial --- .../src/LobattoPolynomialUtility@Methods.F90 | 68 +++++++++++++------ 1 file changed, 49 insertions(+), 19 deletions(-) diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 index 59c22d3ea..3dff6e8c6 100644 --- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -309,60 +309,90 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LobattoGradientEvalAll1 +INTEGER(I4B) :: tsize +CALL LobattoGradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize) +END PROCEDURE LobattoGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEvalAll1_ REAL(DFP) :: p(n), avar, m INTEGER(I4B) :: ii - !! + +tsize = n + 1 + SELECT CASE (n) + CASE (0) ans(1) = -0.5_DFP + CASE (1) ans(1) = -0.5_DFP ans(2) = 0.5_DFP + CASE DEFAULT ans(1) = -0.5_DFP ans(2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! + + CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, tsize=ii) + DO ii = 1, n - 1 m = REAL(ii - 1, DFP) avar = SQRT((2.0_DFP * m + 3.0) / 2.0) ans(ii + 2) = avar * p(ii + 1) - ! ans(3:) = p(2:) + END DO - !! + END SELECT -END PROCEDURE LobattoGradientEvalAll1 +END PROCEDURE LobattoGradientEvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE LobattoGradientEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL LobattoGradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LobattoGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEvalAll2_ REAL(DFP) :: p(SIZE(x), n), avar, m INTEGER(I4B) :: ii - !! + +nrow = SIZE(x) +ncol = n + 1 + SELECT CASE (n) CASE (0) - ans(:, 1) = -0.5_DFP + ans(1:nrow, 1) = -0.5_DFP + CASE (1) - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP + ans(1:nrow, 1) = -0.5_DFP + ans(1:nrow, 2) = 0.5_DFP + CASE DEFAULT - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! + ans(1:nrow, 1) = -0.5_DFP + ans(1:nrow, 2) = 0.5_DFP + + !! p = LegendreEvalAll(n=n - 1_I4B, x=x) + CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, nrow=nrow, ncol=ii) + DO ii = 1, n - 1 m = REAL(ii - 1, DFP) avar = SQRT((2.0_DFP * m + 3.0) / 2.0) - ans(:, ii + 2) = avar * p(:, ii + 1) + ans(1:nrow, ii + 2) = avar * p(1:nrow, ii + 1) ! ans(3:) = p(2:) END DO - !! + END SELECT -END PROCEDURE LobattoGradientEvalAll2 + +END PROCEDURE LobattoGradientEvalAll2_ !---------------------------------------------------------------------------- ! From eb9a5f25a635b9de469899c73381d2caeea4502c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 12:16:38 +0900 Subject: [PATCH 124/359] Updates in polynomial utility --- .../src/LagrangePolynomialUtility.F90 | 52 +- .../src/LobattoPolynomialUtility.F90 | 3 + .../src/OrthogonalPolynomialUtility.F90 | 91 +-- .../src/UnscaledLobattoPolynomialUtility.F90 | 73 +-- ...s sharma's conflicted copy 2024-06-26).F90 | 537 ------------------ .../src/LagrangePolynomialUtility@Methods.F90 | 219 ++++--- .../src/LineInterpolationUtility@Methods.F90 | 71 +++ .../OrthogonalPolynomialUtility@Methods.F90 | 40 +- ...scaledLobattoPolynomialUtility@Methods.F90 | 66 ++- 9 files changed, 389 insertions(+), 763 deletions(-) delete mode 100644 src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index 6a98cdf1c..f4886363a 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -29,15 +29,18 @@ MODULE LagrangePolynomialUtility PUBLIC :: LagrangeDOF PUBLIC :: LagrangeInDOF PUBLIC :: LagrangeDegree +PUBLIC :: EquidistancePoint + PUBLIC :: LagrangeVandermonde PUBLIC :: LagrangeVandermonde_ -PUBLIC :: EquidistancePoint PUBLIC :: InterpolationPoint PUBLIC :: InterpolationPoint_ PUBLIC :: LagrangeCoeff +PUBLIC :: LagrangeCoeff_ PUBLIC :: LagrangeEvalAll PUBLIC :: LagrangeEvalAll_ PUBLIC :: LagrangeGradientEvalAll +PUBLIC :: LagrangeGradientEvalAll_ !---------------------------------------------------------------------------- ! LagrangeDOF@BasisMethods @@ -564,4 +567,51 @@ END FUNCTION LagrangeGradientEvalAll1 ! !---------------------------------------------------------------------------- +INTERFACE LagrangeGradientEvalAll_ + MODULE SUBROUTINE LagrangeGradientEvalAll1_(order, elemType, x, xij, ans, & + dim1, dim2, dim3, domainName, coeff, firstCall, basisType, alpha, & + beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of n+1 Lagrange polynomials at point x + !! dim1 = SIZE(x, 2) + !! dim2 = SIZE(xij, 2) + !! dim3 = SIZE(x, 1) + !! ans(:, :, 1) denotes x gradient + !! ans(:,:, 2) denotes y gradient + !! ans(:,:, 3) denotes z gradient + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! data written in ans + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE LagrangeGradientEvalAll1_ +END INTERFACE LagrangeGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE LagrangePolynomialUtility diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index 5ed9fa613..ac6b54e8d 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -36,7 +36,10 @@ MODULE LobattoPolynomialUtility PUBLIC :: LobattoKernelGradientEvalAll_ PUBLIC :: LobattoMonomialExpansionAll PUBLIC :: LobattoMonomialExpansion + PUBLIC :: LobattoGradientEvalAll +PUBLIC :: LobattoGradientEvalAll_ + PUBLIC :: LobattoGradientEval PUBLIC :: LobattoMassMatrix PUBLIC :: LobattoStiffnessMatrix diff --git a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 index f5b8fd8b9..723784bec 100644 --- a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 @@ -17,20 +17,26 @@ MODULE OrthogonalPolynomialUtility USE GlobalData + IMPLICIT NONE + PRIVATE + PUBLIC :: Clenshaw PUBLIC :: ChebClenshaw PUBLIC :: JacobiMatrix + PUBLIC :: EvalAllOrthopol PUBLIC :: EvalAllOrthopol_ + PUBLIC :: GradientEvalAllOrthopol +PUBLIC :: GradientEvalAllOrthopol_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE +INTERFACE Clenshaw MODULE PURE FUNCTION Clenshaw_1(x, alpha, beta, y0, ym1, c) RESULT(ans) REAL(DFP), INTENT(IN) :: x REAL(DFP), INTENT(IN) :: alpha(0:) @@ -42,17 +48,13 @@ MODULE PURE FUNCTION Clenshaw_1(x, alpha, beta, y0, ym1, c) RESULT(ans) REAL(DFP), INTENT(IN) :: c(0:) REAL(DFP) :: ans END FUNCTION Clenshaw_1 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE Clenshaw_1 END INTERFACE Clenshaw !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE +INTERFACE Clenshaw MODULE PURE FUNCTION Clenshaw_2(x, alpha, beta, y0, ym1, c) RESULT(ans) REAL(DFP), INTENT(IN) :: x(:) REAL(DFP), INTENT(IN) :: alpha(0:) @@ -64,10 +66,6 @@ MODULE PURE FUNCTION Clenshaw_2(x, alpha, beta, y0, ym1, c) RESULT(ans) REAL(DFP), INTENT(IN) :: c(0:) REAL(DFP) :: ans(SIZE(x)) END FUNCTION Clenshaw_2 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE Clenshaw_2 END INTERFACE Clenshaw !---------------------------------------------------------------------------- @@ -86,22 +84,14 @@ END FUNCTION Clenshaw_2 ! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x) !$$ -INTERFACE +INTERFACE Clenshaw MODULE PURE FUNCTION ChebClenshaw_1(x, c) RESULT(ans) REAL(DFP), INTENT(IN) :: x REAL(DFP), INTENT(IN) :: c(0:) REAL(DFP) :: ans END FUNCTION ChebClenshaw_1 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE ChebClenshaw_1 END INTERFACE Clenshaw -INTERFACE ChebClenshaw - MODULE PROCEDURE ChebClenshaw_1 -END INTERFACE ChebClenshaw - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -118,16 +108,12 @@ END FUNCTION ChebClenshaw_1 ! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x) !$$ -INTERFACE +INTERFACE Clenshaw MODULE PURE FUNCTION ChebClenshaw_2(x, c) RESULT(ans) REAL(DFP), INTENT(IN) :: x(:) REAL(DFP), INTENT(IN) :: c(0:) REAL(DFP) :: ans(SIZE(x)) END FUNCTION ChebClenshaw_2 -END INTERFACE - -INTERFACE Clenshaw - MODULE PROCEDURE ChebClenshaw_2 END INTERFACE Clenshaw INTERFACE ChebClenshaw @@ -138,7 +124,7 @@ END FUNCTION ChebClenshaw_2 ! JacobiMatrix !---------------------------------------------------------------------------- -INTERFACE +INTERFACE JacobiMatrix MODULE PURE SUBROUTINE JacobiMatrix_1(alphaCoeff, betaCoeff, D, E) REAL(DFP), INTENT(IN) :: alphaCoeff(0:) !! size n, from 0 to n-1 @@ -149,10 +135,6 @@ MODULE PURE SUBROUTINE JacobiMatrix_1(alphaCoeff, betaCoeff, D, E) REAL(DFP), INTENT(OUT) :: E(:) !! entry from 1 to n-1 are filled END SUBROUTINE JacobiMatrix_1 -END INTERFACE - -INTERFACE JacobiMatrix - MODULE PROCEDURE JacobiMatrix_1 END INTERFACE JacobiMatrix !---------------------------------------------------------------------------- @@ -168,11 +150,7 @@ MODULE PURE FUNCTION EvalAllOrthopol(n, x, orthopol, alpha, beta, & !! points of evaluation INTEGER(I4B), INTENT(IN) :: orthopol !! orthogonal polynomial family - !! Legendre - !! Jacobi - !! Lobatto - !! Chebyshev - !! Ultraspherical + !! Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! alpha1 needed when orthopol1 is "Jacobi" REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -200,12 +178,8 @@ MODULE PURE FUNCTION GradientEvalAllOrthopol(n, x, orthopol, alpha, & REAL(DFP), INTENT(IN) :: x(:) !! points of evaluation INTEGER(I4B), INTENT(IN) :: orthopol - !! orthogonal polynomial family - !! Legendre - !! Jacobi - !! Lobatto - !! Chebyshev - !! Ultraspherical + !! Orthogonal polynomial family + !! Legendre Jacobi Lobatto Chebyshev Ultraspherical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! alpha1 needed when orthopol1 is "Jacobi" REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -221,6 +195,37 @@ MODULE PURE FUNCTION GradientEvalAllOrthopol(n, x, orthopol, alpha, & END FUNCTION GradientEvalAllOrthopol END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE GradientEvalAllOrthopol_(n, x, orthopol, ans, & + nrow, ncol, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! points of evaluation + INTEGER(I4B), INTENT(IN) :: orthopol + !! Orthogonal polynomial family + !! Legendre Jacobi Lobatto Chebyshev Ultraspherical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), n + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! The number of rows in ans is equal to the number of points. + !! The number of columns are equal to the orthogonal + !! polynomials from order = 0 to n + !! Therefore, jth column is denotes the value of jth polynomial + !! at all the points. + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha1 needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta1 is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda1 is needed when orthopol1 is "Ultraspherical" + END SUBROUTINE GradientEvalAllOrthopol_ +END INTERFACE + !---------------------------------------------------------------------------- ! EvalAllOrthopol_ !---------------------------------------------------------------------------- @@ -234,11 +239,7 @@ MODULE PURE SUBROUTINE EvalAllOrthopol_(n, x, orthopol, alpha, beta, & !! points of evaluation INTEGER(I4B), INTENT(IN) :: orthopol !! orthogonal polynomial family - !! Legendre - !! Jacobi - !! Lobatto - !! Chebyshev - !! Ultraspherical + !! Legendre Jacobi ! Lobatto ! Chebyshev ! Ultraspherical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! alpha1 needed when orthopol1 is "Jacobi" REAL(DFP), OPTIONAL, INTENT(IN) :: beta diff --git a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 index 95fec7495..555c42fb9 100644 --- a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 @@ -33,6 +33,7 @@ MODULE UnscaledLobattoPolynomialUtility PUBLIC :: UnscaledLobattoMonomialExpansionAll PUBLIC :: UnscaledLobattoMonomialExpansion PUBLIC :: UnscaledLobattoGradientEvalAll +PUBLIC :: UnscaledLobattoGradientEvalAll_ PUBLIC :: UnscaledLobattoGradientEval PUBLIC :: UnscaledLobattoMassMatrix PUBLIC :: UnscaledLobattoStiffnessMatrix @@ -93,7 +94,7 @@ END FUNCTION UnscaledLobattoZeros !> author: Vikas Sharma, Ph. D. ! date: 6 Sept 2022 -! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n ! !# Introduction ! @@ -106,17 +107,13 @@ END FUNCTION UnscaledLobattoZeros !- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto ! polynomials at the point X. -INTERFACE +INTERFACE UnscaledLobattoEval MODULE PURE FUNCTION UnscaledLobattoEval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans !! Evaluate UnscaledLobatto polynomial of order n at point x END FUNCTION UnscaledLobattoEval1 -END INTERFACE - -INTERFACE UnscaledLobattoEval - MODULE PROCEDURE UnscaledLobattoEval1 END INTERFACE UnscaledLobattoEval !---------------------------------------------------------------------------- @@ -139,17 +136,13 @@ END FUNCTION UnscaledLobattoEval1 !- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at ! the point X. -INTERFACE +INTERFACE UnscaledLobattoEval MODULE PURE FUNCTION UnscaledLobattoEval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(SIZE(x)) !! Evaluate UnscaledLobatto polynomial of order n at point x END FUNCTION UnscaledLobattoEval2 -END INTERFACE - -INTERFACE UnscaledLobattoEval - MODULE PROCEDURE UnscaledLobattoEval2 END INTERFACE UnscaledLobattoEval !---------------------------------------------------------------------------- @@ -314,23 +307,32 @@ END FUNCTION UnscaledLobattoMonomialExpansion ! ! Evaluate gradient of UnscaledLobatto polynomial of order upto n. -INTERFACE +INTERFACE UnscaledLobattoGradientEvalAll MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans(1:n + 1) END FUNCTION UnscaledLobattoGradientEvalAll1 -END INTERFACE -!! - -INTERFACE UnscaledLobattoGradientEvalAll - MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 END INTERFACE UnscaledLobattoGradientEvalAll !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +INTERFACE UnscaledLobattoGradientEvalAll_ + MODULE PURE SUBROUTINE UnscaledLobattoGradientEvalAll1_(n, x, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + !! ans(1:n + 1) + END SUBROUTINE UnscaledLobattoGradientEvalAll1_ +END INTERFACE UnscaledLobattoGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n @@ -339,23 +341,34 @@ END FUNCTION UnscaledLobattoGradientEvalAll1 ! ! Evaluate gradient of UnscaledLobatto polynomial of order upto n. -INTERFACE +INTERFACE UnscaledLobattoGradientEvalAll MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) END FUNCTION UnscaledLobattoGradientEvalAll2 -END INTERFACE -!! - -INTERFACE UnscaledLobattoGradientEvalAll - MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 END INTERFACE UnscaledLobattoGradientEvalAll !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +INTERFACE UnscaledLobattoGradientEvalAll_ + MODULE PURE SUBROUTINE UnscaledLobattoGradientEvalAll2_(n, x, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x) + !! ncol = n + 1 + END SUBROUTINE UnscaledLobattoGradientEvalAll2_ +END INTERFACE UnscaledLobattoGradientEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 ! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n @@ -364,18 +377,14 @@ END FUNCTION UnscaledLobattoGradientEvalAll2 ! ! Evaluate gradient of UnscaledLobatto polynomial of order upto n. -INTERFACE +INTERFACE UnscaledLobattoGradientEval MODULE PURE FUNCTION UnscaledLobattoGradientEval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans END FUNCTION UnscaledLobattoGradientEval1 -END INTERFACE -!! - -INTERFACE UnscaledLobattoGradientEval - MODULE PROCEDURE UnscaledLobattoGradientEval1 END INTERFACE UnscaledLobattoGradientEval +!! !---------------------------------------------------------------------------- ! @@ -389,16 +398,12 @@ END FUNCTION UnscaledLobattoGradientEval1 ! ! Evaluate gradient of UnscaledLobatto polynomial of order upto n. -INTERFACE +INTERFACE UnscaledLobattoGradientEval MODULE PURE FUNCTION UnscaledLobattoGradientEval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(1:SIZE(x)) END FUNCTION UnscaledLobattoGradientEval2 -END INTERFACE - -INTERFACE UnscaledLobattoGradientEval - MODULE PROCEDURE UnscaledLobattoGradientEval2 END INTERFACE UnscaledLobattoGradientEval !---------------------------------------------------------------------------- diff --git a/src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 b/src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 deleted file mode 100644 index 1f1067657..000000000 --- a/src/modules/Utility/src/IntegerUtility (vikas sharma's conflicted copy 2024-06-26).F90 +++ /dev/null @@ -1,537 +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 IntegerUtility -USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, & - REAL32, REAL64 -IMPLICIT NONE -PRIVATE - -PUBLIC :: OPERATOR(.in.) -PUBLIC :: OPERATOR(.isin.) -PUBLIC :: RemoveDuplicates -PUBLIC :: RemoveDuplicates_ -PUBLIC :: Repeat -PUBLIC :: SIZE -PUBLIC :: GetMultiIndices -PUBLIC :: GetIndex -PUBLIC :: Get -PUBLIC :: GetIntersection -PUBLIC :: Get1DIndexFortran - -!---------------------------------------------------------------------------- -! Size@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get the number of touples - -INTERFACE Size - MODULE PURE FUNCTION obj_Size1(n, d) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - INTEGER(I4B) :: ans - END FUNCTION obj_Size1 -END INTERFACE Size - -!---------------------------------------------------------------------------- -! Size@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get the number of touples - -INTERFACE Size - MODULE PURE FUNCTION obj_Size2(n, d, upto) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - LOGICAL(LGT), INTENT(IN) :: upto - INTEGER(I4B) :: ans - END FUNCTION obj_Size2 -END INTERFACE Size - -!---------------------------------------------------------------------------- -! GetIndices@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get Indices - -INTERFACE GetMultiIndices - MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices1(n, d) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_GetMultiIndices1 -END INTERFACE GetMultiIndices - -!---------------------------------------------------------------------------- -! GetIndices@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 Sept 2022 -! summary: Get Indices upto order n - -INTERFACE GetMultiIndices - MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n, d - LOGICAL(LGT), INTENT(IN) :: upto - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION obj_GetMultiIndices2 -END INTERFACE GetMultiIndices - -!---------------------------------------------------------------------------- -! Operator(.in.)@IntegerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another - -INTERFACE OPERATOR(.in.) - MODULE PURE FUNCTION in_1a(a, b) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1a - - MODULE PURE FUNCTION in_1b(a, b) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1b - - MODULE PURE FUNCTION in_1c(a, b) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1c - - MODULE PURE FUNCTION in_1d(a, b) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_1d - -END INTERFACE OPERATOR(.in.) - -!---------------------------------------------------------------------------- -! Operator(.in.)@IntegerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another -! -!# Introduction -! -! This function returns a vector of booleans -! if a(i) is inside the b, then ans(i) is true, otherwise false. - -INTERFACE OPERATOR(.isin.) - MODULE PURE FUNCTION isin_1a(a, b) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a(:) - INTEGER(INT8), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1a - - MODULE PURE FUNCTION isin_1b(a, b) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a(:) - INTEGER(INT16), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1b - - MODULE PURE FUNCTION isin_1c(a, b) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a(:) - INTEGER(INT32), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1c - - MODULE PURE FUNCTION isin_1d(a, b) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a(:) - INTEGER(INT64), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans(SIZE(a)) - END FUNCTION isin_1d -END INTERFACE OPERATOR(.isin.) - -!---------------------------------------------------------------------------- -! Operator(.in.)@IntegerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-11 -! update: 2021-11-11 -! summary: Returns true if a integer set is inside another - -INTERFACE OPERATOR(.in.) - - MODULE PURE FUNCTION in_2a(a, b) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: a - INTEGER(INT8), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2a - - MODULE PURE FUNCTION in_2b(a, b) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: a - INTEGER(INT16), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2b - - MODULE PURE FUNCTION in_2c(a, b) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: a - INTEGER(INT32), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2c - - MODULE PURE FUNCTION in_2d(a, b) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: a - INTEGER(INT64), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans - END FUNCTION in_2d - -END INTERFACE OPERATOR(.in.) - -INTERFACE OPERATOR(.isin.) - MODULE PROCEDURE in_2a, in_2b, in_2c, in_2d -END INTERFACE OPERATOR(.isin.) - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-12 -! summary: Remove duplicates entries - -INTERFACE RemoveDuplicates - MODULE PURE SUBROUTINE RemoveDuplicates_1a(obj) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1a - MODULE PURE SUBROUTINE RemoveDuplicates_1b(obj) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1b - MODULE PURE SUBROUTINE RemoveDuplicates_1c(obj) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1c - MODULE PURE SUBROUTINE RemoveDuplicates_1d(obj) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: obj(:) - END SUBROUTINE RemoveDuplicates_1d -END INTERFACE RemoveDuplicates - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-12 -! summary: Remove duplicates with no allocation - -INTERFACE RemoveDuplicates_ - MODULE PURE SUBROUTINE RemoveDuplicates_1a_(obj, tsize, isSorted) - INTEGER(INT8), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1a_ - - MODULE PURE SUBROUTINE RemoveDuplicates_1b_(obj, tsize, isSorted) - INTEGER(INT16), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1b_ - - MODULE PURE SUBROUTINE RemoveDuplicates_1c_(obj, tsize, isSorted) - INTEGER(INT32), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1c_ - - MODULE PURE SUBROUTINE RemoveDuplicates_1d_(obj, tsize, isSorted) - INTEGER(INT64), INTENT(INOUT) :: obj(:) - !! obj(1:tsize) will have unique entries - LOGICAL(LGT), INTENT(IN) :: isSorted - !! if obj is sorted then set isSorted to true - INTEGER(I4B), INTENT(OUT) :: tsize - !! number of unique entries found - END SUBROUTINE RemoveDuplicates_1d_ - -END INTERFACE RemoveDuplicates_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE Repeat - MODULE PURE FUNCTION Repeat_1a(Val, rtimes) RESULT(Ans) - INTEGER(INT8), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT8) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1a - MODULE PURE FUNCTION Repeat_1b(Val, rtimes) RESULT(Ans) - INTEGER(INT16), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT16) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1b - MODULE PURE FUNCTION Repeat_1c(Val, rtimes) RESULT(Ans) - INTEGER(INT32), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT32) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1c - MODULE PURE FUNCTION Repeat_1d(Val, rtimes) RESULT(Ans) - INTEGER(INT64), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - INTEGER(INT64) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1d - MODULE PURE FUNCTION Repeat_1e(Val, rtimes) RESULT(Ans) - REAL(REAL32), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - REAL(REAL32) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1e - MODULE PURE FUNCTION Repeat_1f(Val, rtimes) RESULT(Ans) - REAL(REAL64), INTENT(IN) :: Val(:) - INTEGER(I4B), INTENT(IN) :: rtimes - REAL(REAL64) :: Ans(SIZE(Val) * rtimes) - END FUNCTION Repeat_1f -END INTERFACE Repeat - -!---------------------------------------------------------------------------- -! getIndex@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PURE FUNCTION GetIndex1(obj, val) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: val - INTEGER(I4B) :: ans - END FUNCTION GetIndex1 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! getIndex@getMethod -!---------------------------------------------------------------------------- - -INTERFACE GetIndex - MODULE PURE FUNCTION GetIndex2(obj, Val) RESULT(Ans) - INTEGER(I4B), INTENT(IN) :: obj(:) - INTEGER(I4B), INTENT(IN) :: Val(:) - INTEGER(I4B), ALLOCATABLE :: Ans(:) - END FUNCTION GetIndex2 -END INTERFACE GetIndex - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION Get1_Int8(val, indx) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT8) :: ans - END FUNCTION Get1_Int8 - - MODULE PURE FUNCTION Get1_Int16(val, indx) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT16) :: ans - END FUNCTION Get1_Int16 - - MODULE PURE FUNCTION Get1_Int32(val, indx) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT32) :: ans - END FUNCTION Get1_Int32 - - MODULE PURE FUNCTION Get1_Int64(val, indx) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT64) :: ans - END FUNCTION Get1_Int64 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION Get2_Int8(val, indx) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT8) :: ans(SIZE(indx)) - END FUNCTION Get2_Int8 - - MODULE PURE FUNCTION Get2_Int16(val, indx) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT16) :: ans(SIZE(indx)) - END FUNCTION Get2_Int16 - - MODULE PURE FUNCTION Get2_Int32(val, indx) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT32) :: ans(SIZE(indx)) - END FUNCTION Get2_Int32 - - MODULE PURE FUNCTION Get2_Int64(val, indx) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: indx(:) - INTEGER(INT64) :: ans(SIZE(indx)) - END FUNCTION Get2_Int64 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! Get -!---------------------------------------------------------------------------- - -INTERFACE Get - MODULE PURE FUNCTION Get3_Int8(val, istart, iend, stride) RESULT(ans) - INTEGER(INT8), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT8) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int8 - - MODULE PURE FUNCTION Get3_Int16(val, istart, iend, stride) RESULT(ans) - INTEGER(INT16), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT16) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int16 - - MODULE PURE FUNCTION Get3_Int32(val, istart, iend, stride) RESULT(ans) - INTEGER(INT32), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT32) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int32 - - MODULE PURE FUNCTION Get3_Int64(val, istart, iend, stride) RESULT(ans) - INTEGER(INT64), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(IN) :: istart, iend, stride - INTEGER(INT64) :: ans(INT((iend - istart) / stride) + 1) - END FUNCTION Get3_Int64 -END INTERFACE Get - -!---------------------------------------------------------------------------- -! GetIntersection -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-05-22 -! summary: Get the intersection fo two integer vectors - -INTERFACE GetIntersection - MODULE PURE SUBROUTINE GetIntersection1(a, b, c, tsize) - INTEGER(INT8), INTENT(IN) :: a(:), b(:) - INTEGER(INT8), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection1 - - MODULE PURE SUBROUTINE GetIntersection2(a, b, c, tsize) - INTEGER(INT16), INTENT(IN) :: a(:), b(:) - INTEGER(INT16), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection2 - - MODULE PURE SUBROUTINE GetIntersection3(a, b, c, tsize) - INTEGER(INT32), INTENT(IN) :: a(:), b(:) - INTEGER(INT32), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection3 - - MODULE PURE SUBROUTINE GetIntersection4(a, b, c, tsize) - INTEGER(INT64), INTENT(IN) :: a(:), b(:) - INTEGER(INT64), INTENT(INOUT) :: c(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE GetIntersection4 -END INTERFACE GetIntersection - -!---------------------------------------------------------------------------- -! Get1DIndexFrom2DIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-14 -! summary: Convert (i,j) to ans from Fortran2D array to 1D array - -INTERFACE Get1DIndexFortran - MODULE PURE FUNCTION Get1DIndexFrom2DFortranIndex(i, j, dim1, dim2) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: i - INTEGER(I4B), INTENT(IN) :: j - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B) :: ans - END FUNCTION Get1DIndexFrom2DFortranIndex -END INTERFACE Get1DIndexFortran - -!---------------------------------------------------------------------------- -! Get1DIndexFrom2DIndex -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-14 -! summary: Convert (i,j,k) to ans from Fortran3D array to 1D array - -INTERFACE Get1DIndexFortran - MODULE PURE FUNCTION Get1DIndexFrom3DFortranIndex(i, j, k, dim1, dim2, & - dim3) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: i - INTEGER(I4B), INTENT(IN) :: j - INTEGER(I4B), INTENT(IN) :: k - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B) :: ans - END FUNCTION Get1DIndexFrom3DFortranIndex -END INTERFACE Get1DIndexFortran - -!---------------------------------------------------------------------------- -! Get1DIndexFortran -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-14 -! summary: Convert (i,j,k,l) to ans from Fortran4D array to 1D array - -INTERFACE Get1DIndexFortran - MODULE PURE FUNCTION Get1DIndexFrom4DFortranIndex(i, j, k, l, dim1, dim2, & - dim3, dim4) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: i - INTEGER(I4B), INTENT(IN) :: j - INTEGER(I4B), INTENT(IN) :: k - INTEGER(I4B), INTENT(IN) :: l - INTEGER(I4B), INTENT(IN) :: dim1 - INTEGER(I4B), INTENT(IN) :: dim2 - INTEGER(I4B), INTENT(IN) :: dim3 - INTEGER(I4B), INTENT(IN) :: dim4 - INTEGER(I4B) :: ans - END FUNCTION Get1DIndexFrom4DFortranIndex -END INTERFACE Get1DIndexFortran - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE IntegerUtility diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index 26dde296f..05e687f9d 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -705,182 +705,157 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll1_(order=order, elemType=elemType, x=x, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, domainName=domainName, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) +END PROCEDURE LagrangeGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll1_ INTEGER(I4B) :: topo +dim1 = SIZE(x, 2) +dim2 = SIZE(xij, 2) +dim3 = SIZE(x, 1) + topo = ElementTopology(elemType) SELECT CASE (topo) CASE (Point) CASE (Line) + +#ifdef DEBUG_VER + IF (SIZE(x, 1) .NE. 1 .OR. SIZE(xij, 1) .NE. 1) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 1", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) + CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 1", & + routine="LagrangeGradientEvalAll1", unitno=stderr, & + line=__LINE__, file=__FILE__) RETURN END IF - ans(:, :, 1:1) = LagrangeGradientEvalAll_Line( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +#endif + + ans(1:dim1, 1:dim2, 1:1) = LagrangeGradientEvalAll_Line(order=order, & + x=x, xij=xij, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) CASE (Triangle) +#ifdef DEBUG_VER + IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) + CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & + routine="LagrangeGradientEvalAll1", & + unitno=stderr, line=__LINE__, file=__FILE__) RETURN END IF - ans(:, :, 1:2) = LagrangeGradientEvalAll_Triangle( & - & order=order, & - & x=x, & - & xij=xij, & - & refTriangle=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +#endif + + ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Triangle(order=order, & + x=x, xij=xij, refTriangle=domainName, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) CASE (Quadrangle) +#ifdef DEBUG_VER IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) + msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", & + routine="LagrangeGradientEvalAll1", & + unitno=stderr, line=__LINE__, file=__FILE__) RETURN END IF - ans(:, :, 1:2) = LagrangeGradientEvalAll_Quadrangle( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + +#endif + + ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Quadrangle( & + order=order, x=x, xij=xij, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) CASE (Tetrahedron) +#ifdef DEBUG_VER + IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) + CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + routine="LagrangeGradientEvalAll1", & + unitno=stderr, line=__LINE__, file=__FILE__) RETURN END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Tetrahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & refTetrahedron=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + +#endif + + ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Tetrahedron( & + order=order, x=x, xij=xij, refTetrahedron=domainName, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) CASE (Hexahedron) +#ifdef DEBUG_VER + IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) + CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + routine="LagrangeGradientEvalAll1", & + unitno=stderr, line=__LINE__, file=__FILE__) RETURN END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Hexahedron( & - & order=order, & - & x=x, & - & xij=xij, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + +#endif + + ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Hexahedron( & + order=order, x=x, xij=xij, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) CASE (Prism) +#ifdef DEBUG_VER IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) + CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + routine="LagrangeGradientEvalAll1", & + unitno=stderr, line=__LINE__, file=__FILE__) RETURN END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Prism( & - & order=order, & - & x=x, & - & xij=xij, & - & refPrism=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +#endif + + ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Prism(order=order, & + x=x, xij=xij, refPrism=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) CASE (Pyramid) +#ifdef DEBUG_VER + IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN - CALL Errormsg( & - & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & - & unitno=stderr, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1", & - & file=__FILE__) + CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", & + routine="LagrangeGradientEvalAll1", & + unitno=stderr, line=__LINE__, file=__FILE__) RETURN END IF - ans(:, :, 1:3) = LagrangeGradientEvalAll_Pyramid( & - & order=order, & - & x=x, & - & xij=xij, & - & refPyramid=domainName, & - & coeff=coeff, & - & firstCall=firstCall, & - & basisType=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) + +#endif + + ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Pyramid(order=order, & + x=x, xij=xij, refPyramid=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="LagrangeGradientEvalAll1()", & - & file=__FILE__) + + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="LagrangeGradientEvalAll1()", & + unitno=stdout, line=__LINE__, file=__FILE__) RETURN + END SELECT -END PROCEDURE LagrangeGradientEvalAll1 +END PROCEDURE LagrangeGradientEvalAll1_ !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index dc36c40f9..1cf23f292 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -1484,6 +1484,77 @@ END SUBROUTINE handle_error 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, :), & + orthopol=orthopol0, alpha=alpha, beta=beta, lambda=lambda) + +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_ + !---------------------------------------------------------------------------- ! BasisEvalAll_Line !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index 0604f96bb..3c9e50dc1 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -163,20 +163,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GradientEvalAllOrthopol +INTEGER(I4B) :: nrow, ncol +CALL GradientEvalAllOrthopol_(n=n, x=x, orthopol=orthopol, ans=ans, & + nrow=nrow, ncol=ncol, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE GradientEvalAllOrthopol + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GradientEvalAllOrthopol_ + SELECT CASE (orthopol) CASE (Jacobi) - ans = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) + ! ans(1:nrow, 1:ncol) = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) + CALL JacobiGradientEvalAll_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, & + nrow=nrow, ncol=ncol) + CASE (Ultraspherical) - ans = UltraSphericalGradientEvalAll(n=n, lambda=lambda, x=x) + ! ans(1:nrow, 1:ncol) = UltraSphericalGradientEvalAll(n=n, lambda=lambda, x=x) + CALL UltraSphericalGradientEvalAll_(n=n, lambda=lambda, x=x, ans=ans, & + nrow=nrow, ncol=ncol) + CASE (Legendre) - ans = LegendreGradientEvalAll(n=n, x=x) + ! ans(1:nrow, 1:ncol) = LegendreGradientEvalAll(n=n, x=x) + CALL LegendreGradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) + CASE (Chebyshev) - ans = Chebyshev1GradientEvalAll(n=n, x=x) + ! ans(1:nrow, 1:ncol) = Chebyshev1GradientEvalAll(n=n, x=x) + CALL Chebyshev1GradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) + CASE (Lobatto) - ans = LobattoGradientEvalAll(n=n, x=x) + ! ans(1:nrow, 1:ncol) = LobattoGradientEvalAll(n=n, x=x) + CALL LobattoGradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) + CASE (UnscaledLobatto) - ans = UnscaledLobattoGradientEvalAll(n=n, x=x) + ! ans(1:nrow, 1:ncol) = UnscaledLobattoGradientEvalAll(n=n, x=x) + CALL UnscaledLobattoGradientEvalAll_(n=n, x=x, ans=ans, & + nrow=nrow, ncol=ncol) + END SELECT -END PROCEDURE GradientEvalAllOrthopol +END PROCEDURE GradientEvalAllOrthopol_ END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 index 1b4ef8182..92a324a16 100644 --- a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 @@ -251,56 +251,88 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 +INTEGER(I4B) :: tsize +CALL UnscaledLobattoGradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize) +END PROCEDURE UnscaledLobattoGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEvalAll1_ REAL(DFP) :: p(n) INTEGER(I4B) :: ii - !! + +tsize = n + 1 + SELECT CASE (n) CASE (0) ans(1) = -0.5_DFP + CASE (1) ans(1) = -0.5_DFP ans(2) = 0.5_DFP + CASE DEFAULT ans(1) = -0.5_DFP ans(2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! + + ! p = LegendreEvalAll(n=n - 1_I4B, x=x) + CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, tsize=ii) + DO ii = 1, n - 1 ans(ii + 2) = p(ii + 1) ! ans(3:) = p(2:) END DO - !! + END SELECT -END PROCEDURE UnscaledLobattoGradientEvalAll1 + +END PROCEDURE UnscaledLobattoGradientEvalAll1_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 +INTEGER(I4B) :: nrow, ncol +CALL UnscaledLobattoGradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, & + ncol=ncol) + +END PROCEDURE UnscaledLobattoGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEvalAll2_ REAL(DFP) :: p(SIZE(x), n) INTEGER(I4B) :: ii - !! + +nrow = SIZE(x) +ncol = n + 1 + SELECT CASE (n) CASE (0) - ans(:, 1) = -0.5_DFP + ans(1:nrow, 1) = -0.5_DFP + CASE (1) - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP + ans(1:nrow, 1) = -0.5_DFP + ans(1:nrow, 2) = 0.5_DFP + CASE DEFAULT - ans(:, 1) = -0.5_DFP - ans(:, 2) = 0.5_DFP - !! - p = LegendreEvalAll(n=n - 1_I4B, x=x) - !! + ans(1:nrow, 1) = -0.5_DFP + ans(1:nrow, 2) = 0.5_DFP + + ! p = LegendreEvalAll(n=n - 1_I4B, x=x) + CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, nrow=nrow, ncol=ii) + DO ii = 1, n - 1 - ans(:, ii + 2) = p(:, ii + 1) + ans(1:nrow, ii + 2) = p(1:nrow, ii + 1) ! ans(3:) = p(2:) END DO !! END SELECT -END PROCEDURE UnscaledLobattoGradientEvalAll2 +END PROCEDURE UnscaledLobattoGradientEvalAll2_ !---------------------------------------------------------------------------- ! From 9c3fb28f4dc2f3b25b73ad7066c68fd2290d0a99 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 15:39:23 +0900 Subject: [PATCH 125/359] Updates in line interpolation --- .../src/LineInterpolationUtility.F90 | 106 ++++++++ .../src/LineInterpolationUtility@Methods.F90 | 240 +++++++++++------- .../OrthogonalPolynomialUtility@Methods.F90 | 5 +- 3 files changed, 258 insertions(+), 93 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 2e87c6a7f..22bf0ae0a 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -38,9 +38,11 @@ MODULE LineInterpolationUtility PUBLIC :: LagrangeEvalAll_Line PUBLIC :: LagrangeEvalAll_Line_ PUBLIC :: LagrangeGradientEvalAll_Line +PUBLIC :: LagrangeGradientEvalAll_Line_ PUBLIC :: BasisEvalAll_Line PUBLIC :: BasisEvalAll_Line_ PUBLIC :: BasisGradientEvalAll_Line +PUBLIC :: BasisGradientEvalAll_Line_ PUBLIC :: QuadraturePoint_Line PUBLIC :: ToVEFC_Line PUBLIC :: QuadratureNumber_Line @@ -986,6 +988,47 @@ MODULE FUNCTION LagrangeGradientEvalAll_Line1(order, x, xij, coeff, & END FUNCTION LagrangeGradientEvalAll_Line1 END INTERFACE LagrangeGradientEvalAll_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeGradientEvalAll_Line_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_(order, x, xij, ans, & + dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! ans(SIZE(x, 2), SIZE(xij, 2), 1) + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Line1_ +END INTERFACE LagrangeGradientEvalAll_Line_ + !---------------------------------------------------------------------------- ! BasisEvalAll_Line !---------------------------------------------------------------------------- @@ -1297,6 +1340,36 @@ MODULE FUNCTION BasisGradientEvalAll_Line1(order, x, refLine, basisType, & END FUNCTION BasisGradientEvalAll_Line1 END INTERFACE BasisGradientEvalAll_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE BasisGradientEvalAll_Line_ + MODULE SUBROUTINE BasisGradientEvalAll_Line1_(order, x, refLine, & + basisType, alpha, beta, lambda, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(order + 1) + !! Value of n+1 polynomials at point x + INTEGER(I4B), INTENT(OUT) :: tsize + !! order + 1 + CHARACTER(*), INTENT(IN) :: refLine + !! Refline should be BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev + !! Lobatto ! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE BasisGradientEvalAll_Line1_ +END INTERFACE BasisGradientEvalAll_Line_ + !---------------------------------------------------------------------------- ! BasisEvalAll_Line !---------------------------------------------------------------------------- @@ -1336,6 +1409,39 @@ MODULE FUNCTION BasisGradientEvalAll_Line2(order, x, refLine, basisType, & END FUNCTION BasisGradientEvalAll_Line2 END INTERFACE BasisGradientEvalAll_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE BasisGradientEvalAll_Line_ + MODULE SUBROUTINE BasisGradientEvalAll_Line2_(order, x, ans, nrow, ncol, & + refLine, basisType, alpha, beta, lambda) + + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: x(:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x), order + 1) + !! Value of n+1 polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT ! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev + !! Lobatto ! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE BasisGradientEvalAll_Line2_ +END INTERFACE BasisGradientEvalAll_Line_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Line !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 1cf23f292..f60d3fc02 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -30,6 +30,7 @@ FromUnitLine2BiUnitLine USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol, & + GradientEvalAllOrthopol_, & EvalAllOrthopol, & EvalAllOrthopol_ @@ -1045,63 +1046,176 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE BasisGradientEvalAll_Line1 +INTEGER(I4B) :: tsize +CALL BasisGradientEvalAll_Line1_(order=order, x=x, refLine=refLine, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + tsize=tsize) +END PROCEDURE BasisGradientEvalAll_Line1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisGradientEvalAll_Line1_ INTEGER(I4B) :: ii, basisType0 -TYPE(String) :: astr -astr = UpperCase(refLine) +CHARACTER(:), ALLOCATABLE :: astr +REAL(DFP) :: areal, breal, x1(1), temp(1, order + 1) -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) +astr = UpperCase(refline) + +tsize = order + 1 + +#ifdef DEBUG_VER + +IF (astr .EQ. "UNIT") THEN + CALL Errormsg(msg="refLine should be BIUNIT", & + routine="BasisGradientEvalAll_Line1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF -basisType0 = input(default=polyopt%Monomial, option=basisType) +#endif + +basisType0 = Input(default=polyopt%Monomial, option=basisType) SELECT CASE (basisType0) + CASE (polyopt%Monomial) + ans(1) = 0.0_DFP DO ii = 1, order - ans(ii + 1) = REAL(ii, dfp) * x**(ii - 1) + areal = REAL(ii, kind=DFP) + breal = x**(ii - 1) + ans(ii + 1) = areal * breal END DO + CASE DEFAULT +#ifdef DEBUG_VER + IF (basisType0 .EQ. polyopt%Jacobi) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg( & + msg="alpha and beta should be present for basisType=Jacobi", & + routine="BasisGradientEvalAll_Line1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF + END IF IF (basisType0 .EQ. polyopt%Ultraspherical) THEN + IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg( & + msg="lambda should be present for basisType=Ultraspherical", & + routine="BasisGradientEvalAll_Line1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF + END IF - ans = RESHAPE(GradientEvalAllOrthopol(& - & n=order, & - & x=[x], & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda), [order + 1]) +#endif + + x1(1) = x + CALL GradientEvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, ans=temp, nrow=ii, ncol=tsize) + + ans(1:tsize) = temp(1, 1:tsize) + END SELECT -END PROCEDURE BasisGradientEvalAll_Line1 +END PROCEDURE BasisGradientEvalAll_Line1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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 @@ -1189,65 +1303,6 @@ END SUBROUTINE handle_error ! BasisGradientEvalAll_Line !---------------------------------------------------------------------------- -MODULE PROCEDURE BasisGradientEvalAll_Line2 -INTEGER(I4B) :: ii, basisType0 -TYPE(String) :: astr -astr = UpperCase(refLine) - -IF (astr%chars() .EQ. "UNIT") THEN - CALL Errormsg(& - & msg="refLine should be BIUNIT", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END IF - -basisType0 = input(default=polyopt%Monomial, option=basisType) -SELECT CASE (basisType0) -CASE (polyopt%Monomial) - ans(:, 1) = 0.0_DFP - DO ii = 1, order - ans(:, ii + 1) = REAL(ii, dfp) * x**(ii - 1) - END DO -CASE DEFAULT - - IF (basisType0 .EQ. polyopt%Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - 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", & - & file=__FILE__, & - & routine="BasisGradientEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - END IF - - ans = GradientEvalAllOrthopol(& - & n=order, & - & x=x, & - & orthopol=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT - -END PROCEDURE BasisGradientEvalAll_Line2 - !---------------------------------------------------------------------------- ! QuadraturePoint_Line !---------------------------------------------------------------------------- @@ -1545,8 +1600,9 @@ END SUBROUTINE handle_error CASE DEFAULT - xx(1:dim1, 1:dim2) = GradientEvalAllOrthopol(n=order, x=x(1, :), & - orthopol=orthopol0, alpha=alpha, beta=beta, lambda=lambda) + ! 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 diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index 3c9e50dc1..143c35aea 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -173,7 +173,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GradientEvalAllOrthopol_ - SELECT CASE (orthopol) CASE (Jacobi) ! ans(1:nrow, 1:ncol) = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) @@ -205,4 +204,8 @@ END SELECT END PROCEDURE GradientEvalAllOrthopol_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE Methods From 870ea89fb3a8d59ed2f414666f1b29df5018b65d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 19:29:00 +0900 Subject: [PATCH 126/359] Updates in TriangleInterpolationUtility --- .../src/TriangleInterpolationUtility.F90 | 63 ++++++++++++++++--- ...erpolationUtility@LagrangeBasisMethods.F90 | 27 ++++++-- 2 files changed, 78 insertions(+), 12 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index e58e4ffd9..e4b0a2986 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -1643,13 +1643,9 @@ END FUNCTION TensorQuadraturePoint_Triangle2 END INTERFACE TensorQuadraturePoint_Triangle !---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Triangle +! !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Lagrange polynomials of n at several points - INTERFACE LagrangeGradientEvalAll_Triangle MODULE FUNCTION LagrangeGradientEvalAll_Triangle1( & & order, & @@ -1701,6 +1697,57 @@ MODULE FUNCTION LagrangeGradientEvalAll_Triangle1( & END FUNCTION LagrangeGradientEvalAll_Triangle1 END INTERFACE LagrangeGradientEvalAll_Triangle +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Lagrange polynomials of n at several points + +INTERFACE LagrangeGradientEvalAll_Triangle_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Triangle1_(order, x, xij, ans, & + dim1, dim2, dim3, refTriangle, coeff, firstCall, basisType, alpha, & + beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! ans(SIZE(x, 2), SIZE(xij, 2), 2) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! SIZE(x, 2), SIZE(xij, 2), 2 + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Triangle1_ +END INTERFACE LagrangeGradientEvalAll_Triangle_ + !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Triangle !---------------------------------------------------------------------------- @@ -1768,9 +1815,9 @@ MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_(order, pe1, pe2, pe3,& !! UNIT: in this case xij is in unit Triangle. !! BIUNIT: in this case xij is in biunit triangle. REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - !! ans( & - !! & SIZE(xij, 2), & - !! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 2) + !! tsize1 = SIZE(xij, 2) + !! tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) + !! tsize3 = 2 INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 END SUBROUTINE HeirarchicalBasisGradient_Triangle1_ END INTERFACE HeirarchicalBasisGradient_Triangle_ diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index 3d6159048..ff0ef79d0 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -359,11 +359,29 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll_Triangle1 +INTEGER(I4B) :: dim1, dim2, dim3 + +CALL LagrangeGradientEvalAll_Triangle1_(order=order, x=x, xij=xij, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3, refTriangle=refTriangle, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) + +END PROCEDURE LagrangeGradientEvalAll_Triangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Triangle1_ LOGICAL(LGT) :: firstCall0 INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, s(3) INTEGER(I4B) :: degree(SIZE(xij, 2), 2) REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br + xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br + +dim1 = SIZE(x, 2) +dim2 = SIZE(xij, 2) +dim3 = 2 basisType0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) @@ -374,7 +392,8 @@ refTriangle=refTriangle, ans=coeff, nrow=s(1), ncol=s(2)) END IF - coeff0 = coeff + coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) + ELSE CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & refTriangle=refTriangle, ans=coeff0, nrow=s(1), ncol=s(2)) @@ -413,10 +432,10 @@ DO ii = 1, 2 ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) + ans(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0) END DO -END PROCEDURE LagrangeGradientEvalAll_Triangle1 +END PROCEDURE LagrangeGradientEvalAll_Triangle1_ !---------------------------------------------------------------------------- ! From 4db69626132995b8ec1935c10b72872b649a56f6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 22:44:14 +0900 Subject: [PATCH 127/359] Updates in Quadrangle interpolation utility --- .../src/QuadrangleInterpolationUtility.F90 | 243 ++++++++--- ...QuadrangleInterpolationUtility@Methods.F90 | 388 ++++++++++-------- 2 files changed, 402 insertions(+), 229 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index a6797878a..e099e1383 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -1,4 +1,4 @@ -! This program is a part of EASIFEM library + ! Copyright (C) 2020-2021 Vikas Sharma, Ph.D ! ! This program is free software: you can redistribute it and/or modify @@ -46,6 +46,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: FacetConnectivity_Quadrangle PUBLIC :: RefElemDomain_Quadrangle PUBLIC :: LagrangeGradientEvalAll_Quadrangle +PUBLIC :: LagrangeGradientEvalAll_Quadrangle_ PUBLIC :: HeirarchicalBasisGradient_Quadrangle PUBLIC :: TensorProdBasisGradient_Quadrangle PUBLIC :: OrthogonalBasisGradient_Quadrangle @@ -1556,22 +1557,23 @@ END SUBROUTINE VertexBasis_Quadrangle3_ ! summary: Returns the vertex basis functions on biunit quadrangle INTERFACE - MODULE PURE FUNCTION VertexBasisGradient_Quadrangle2( & - & L1, & - & L2, & - & dL1, & - & dL2) RESULT(ans) + MODULE 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 + !! L1 Lobatto polynomial evaluated at x coordinates REAL(DFP), INTENT(IN) :: L2(1:, 0:) - !! L2 is Lobatto polynomial evaluated at y coordinates + !! L2 is Lobatto polynomial evaluated at y coordinates REAL(DFP), INTENT(IN) :: dL1(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates + !! L1 Lobatto polynomial evaluated at x coordinates REAL(DFP), INTENT(IN) :: dL2(1:, 0:) - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP) :: ans(SIZE(L1, 1), 4, 2) - !! Gradient of vertex basis - END FUNCTION VertexBasisGradient_Quadrangle2 + !! 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 + END SUBROUTINE VertexBasisGradient_Quadrangle2_ END INTERFACE !---------------------------------------------------------------------------- @@ -1669,14 +1671,8 @@ END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION VerticalEdgeBasisGradient_Quadrangle2( & - & qe1, & - & qe2, & - & L1, & - & L2, & - & dL1, & - & dL2) & - & RESULT(ans) + MODULE PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_(qe1, qe2, & + L1, L2, dL1, dL2, ans, dim1, dim2, dim3) INTEGER(I4B), INTENT(IN) :: qe1 !! order on left vertical edge (e1), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: qe2 @@ -1685,8 +1681,12 @@ MODULE PURE FUNCTION VerticalEdgeBasisGradient_Quadrangle2( & !! Lobatto polynomials in x and y direction. REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) !! Lobatto polynomials in x and y direction. - REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2, 2) - END FUNCTION VerticalEdgeBasisGradient_Quadrangle2 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1=SIZE(L1, 1) + !! dim2=qe1 + qe2 - 2 + !! dim3= 2 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ END INTERFACE !---------------------------------------------------------------------------- @@ -1704,8 +1704,7 @@ END FUNCTION VerticalEdgeBasisGradient_Quadrangle2 ! pe3 and pe4 should be greater than or equal to 2 INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) & - & RESULT(ans) + MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe3 !! order on bottom vertical edge (e3), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: pe4 @@ -1736,7 +1735,7 @@ END SUBROUTINE HorizontalEdgeBasis_Quadrangle_ END INTERFACE !---------------------------------------------------------------------------- -! +!: !---------------------------------------------------------------------------- INTERFACE @@ -1776,16 +1775,20 @@ END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasisGradient_Quadrangle2(pe3, pe4, & - L1, L2, dL1, dL2) RESULT(ans) + MODULE PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_(pe3, pe4, & + L1, L2, dL1, dL2, ans, dim1, dim2, dim3) INTEGER(I4B), INTENT(IN) :: pe3 !! order on bottom vertical edge (e3), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: pe4 !! order on top vertical edge(e4), it should be greater than 1 REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2, 2) - END FUNCTION HorizontalEdgeBasisGradient_Quadrangle2 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(L1, 1) + !! dim2 = pe3 + pe4 - 2 + !! dim3 = 2 + END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ END INTERFACE !---------------------------------------------------------------------------- @@ -1871,21 +1874,20 @@ END SUBROUTINE CellBasis_Quadrangle2_ !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION CellBasisGradient_Quadrangle2( & - & pb, & - & qb, & - & L1, & - & L2, & - & dL1, & - & dL2) RESULT(ans) + MODULE PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & + dL1, dL2, ans, dim1, dim2, dim3) INTEGER(I4B), INTENT(IN) :: pb !! order on bottom vertical edge (e3), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: qb !! order on top vertical edge(e4), it should be greater than 1 REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1), 2) - END FUNCTION CellBasisGradient_Quadrangle2 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1=SIZE(L1, 1) + !! dim2=(pb - 1) * (qb - 1) + !! dim3=2 + END SUBROUTINE CellBasisGradient_Quadrangle2_ END INTERFACE !---------------------------------------------------------------------------- @@ -2465,6 +2467,51 @@ MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( & END FUNCTION LagrangeGradientEvalAll_Quadrangle1 END INTERFACE LagrangeGradientEvalAll_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeGradientEvalAll_Quadrangle_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_(order, x, xij, & + ans, dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, & + lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1 = SIZE(x, 2) + !! dim2 = SIZE(xij, 2) + !! dim3 = 2 + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_ +END INTERFACE LagrangeGradientEvalAll_Quadrangle_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Quadrangle !---------------------------------------------------------------------------- @@ -2512,6 +2559,35 @@ MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle1( & END FUNCTION HeirarchicalBasisGradient_Quadrangle1 END INTERFACE HeirarchicalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Quadrangle_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Quadrangle1_(pb, qb, pe3, & + pe4, qe1, qe2, xij, ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1 = SIZE(xij, 2) + !! dim2 = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 + !! dim3 = 2 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE HeirarchicalBasisGradient_Quadrangle1_ +END INTERFACE HeirarchicalBasisGradient_Quadrangle_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Quadrangle !---------------------------------------------------------------------------- @@ -2521,10 +2597,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle1 ! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle INTERFACE HeirarchicalBasisGradient_Quadrangle - MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle2( & - & p, & - & q, & - & xij) RESULT(ans) + MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle2(p, q, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order of interpolation inside the quadrangle in x1 direction INTEGER(I4B), INTENT(IN) :: q @@ -2535,6 +2608,27 @@ MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle2( & END FUNCTION HeirarchicalBasisGradient_Quadrangle2 END INTERFACE HeirarchicalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Quadrangle_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_(p, q, xij, & + ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: p + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! order of interpolation inside the quadrangle in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(xij, 2) + !! dim2 = (p+1)*(q+1) + !! dim3 = 2 + END SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_ +END INTERFACE HeirarchicalBasisGradient_Quadrangle_ + !---------------------------------------------------------------------------- ! TensorProdBasisGradient_Quadrangle !---------------------------------------------------------------------------- @@ -2565,19 +2659,11 @@ MODULE FUNCTION TensorProdBasisGradient_Quadrangle1( & !! points of evaluation in xij format INTEGER(I4B), INTENT(IN) :: basisType1 !! basis type in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical INTEGER(I4B), INTENT(IN) :: basisType2 !! basis type in x2 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 !! alpha1 needed when basisType1 "Jacobi" @@ -2600,4 +2686,55 @@ END FUNCTION TensorProdBasisGradient_Quadrangle1 MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 END INTERFACE OrthogonalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE TensorProdBasisGradient_Quadrangle_ + MODULE SUBROUTINE TensorProdBasisGradient_Quadrangle1_(p, q, xij, ans, & + dim1, dim2, dim3, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, & + beta2, lambda2) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1 = SIZE(xij, 2) + !! dim2 = (p + 1) * (q + 1) + !! dim3 = 2 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dimension of data written in ans + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basis type in x1 direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basis type in x2 direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + END SUBROUTINE TensorProdBasisGradient_Quadrangle1_ +END INTERFACE TensorProdBasisGradient_Quadrangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE OrthogonalBasisGradient_Quadrangle_ + MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_ +END INTERFACE OrthogonalBasisGradient_Quadrangle_ + END MODULE QuadrangleInterpolationUtility diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 877e60593..6deed943c 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -1274,19 +1274,22 @@ END PROCEDURE VertexBasis_Quadrangle3_ !---------------------------------------------------------------------------- -! VertexBasisGradient_Quadrangle2 +! VertexBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- -MODULE PROCEDURE VertexBasisGradient_Quadrangle2 -ans(:, 1, 1) = dL1(:, 0) * L2(:, 0) -ans(:, 2, 1) = dL1(:, 1) * L2(:, 0) -ans(:, 3, 1) = dL1(:, 1) * L2(:, 1) -ans(:, 4, 1) = dL1(:, 0) * L2(:, 1) -ans(:, 1, 2) = L1(:, 0) * dL2(:, 0) -ans(:, 2, 2) = L1(:, 1) * dL2(:, 0) -ans(:, 3, 2) = L1(:, 1) * dL2(:, 1) -ans(:, 4, 2) = L1(:, 0) * dL2(:, 1) -END PROCEDURE VertexBasisGradient_Quadrangle2 +MODULE PROCEDURE VertexBasisGradient_Quadrangle2_ +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 PROCEDURE VertexBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- ! VerticalEdgeBasis_Quadrangle @@ -1368,20 +1371,27 @@ ! VerticalEdgeBasisGradient_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE VerticalEdgeBasisGradient_Quadrangle2 +MODULE PROCEDURE VerticalEdgeBasisGradient_Quadrangle2_ INTEGER(I4B) :: k2, cnt + +dim1 = SIZE(L1, 1) +dim2 = qe1 + qe2 - 2 +dim3 = 2 + cnt = 0 + DO k2 = 2, qe1 cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 0) * L2(:, k2) - ans(:, cnt, 2) = L1(:, 0) * dL2(:, k2) + ans(1:dim1, cnt, 1) = dL1(1:dim1, 0) * L2(1:dim1, k2) + ans(1:dim1, cnt, 2) = L1(1:dim1, 0) * dL2(1:dim1, k2) END DO + DO k2 = 2, qe2 cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, 1) * L2(:, k2) - ans(:, cnt, 2) = L1(:, 1) * dL2(:, k2) + ans(1:dim1, cnt, 1) = dL1(1:dim1, 1) * L2(1:dim1, k2) + ans(1:dim1, cnt, 2) = L1(1:dim1, 1) * dL2(1:dim1, k2) END DO -END PROCEDURE VerticalEdgeBasisGradient_Quadrangle2 +END PROCEDURE VerticalEdgeBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- ! HorizontalEdgeBasis_Quadrangle @@ -1464,20 +1474,27 @@ ! HorizontalEdgeBasisGradient_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2 +MODULE PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2_ INTEGER(I4B) :: k1, cnt + +dim1 = SIZE(L1, 1) +dim2 = pe3 + pe4 - 2 +dim3 = 2 + cnt = 0 + DO k1 = 2, pe3 cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0) + ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 0) + ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 0) END DO + DO k1 = 2, pe4 cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1) + ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 1) + ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 1) END DO -END PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2 +END PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- ! CellBasis_Quadrangle @@ -1552,17 +1569,22 @@ ! CellBasisGradient_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE CellBasisGradient_Quadrangle2 +MODULE PROCEDURE CellBasisGradient_Quadrangle2_ INTEGER(I4B) :: k1, k2, cnt + +dim1 = SIZE(L1, 1) +dim2 = (pb - 1) * (qb - 1) +dim3 = 2 + cnt = 0 DO k1 = 2, pb DO k2 = 2, qb cnt = cnt + 1 - ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2) - ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2) + ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, k2) + ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, k2) END DO END DO -END PROCEDURE CellBasisGradient_Quadrangle2 +END PROCEDURE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- ! HeirarchicalBasis_Quadrangle @@ -2046,246 +2068,260 @@ END PROCEDURE QuadraturePoint_Quadrangle4 !---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Quadrangle +! !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll_Quadrangle1_(order=order, x=x, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE LagrangeGradientEvalAll_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ai, bi -INTEGER(I4B) :: degree(SIZE(xij, 2), 2) +INTEGER(I4B) :: ii, basisType0, ai, bi, indx(3), degree(SIZE(xij, 2), 2), & + jj REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br + xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br, areal, breal + +dim1 = SIZE(x, 2) +dim2 = SIZE(xij, 2) +dim3 = 2 basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN - coeff = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) - coeff0 = coeff - ELSE - coeff0 = coeff + + ! coeff = LagrangeCoeff_Quadrangle(& + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff, & + nrow=indx(1), ncol=indx(2)) END IF + + coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) + ELSE - coeff0 = LagrangeCoeff_Quadrangle(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) + + ! coeff0 = LagrangeCoeff_Quadrangle(& + CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=indx(1), & + ncol=indx(2)) END IF SELECT CASE (basisType0) CASE (Monomial) - degree = LagrangeDegree_Quadrangle(order=order) - tdof = SIZE(xij, 2) + ! degree = LagrangeDegree_Quadrangle(order=order) + CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & + ncol=indx(2)) + +#ifdef DEBUG_VER - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Quadrangle1", & - & line=__LINE__, & - & unitno=stderr) + IF (dim2 .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Quadrangle1", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN END IF - DO ii = 1, tdof +#endif + + DO ii = 1, dim2 ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) ar = REAL(degree(ii, 1_I4B), DFP) br = REAL(degree(ii, 2_I4B), DFP) - xx(:, ii, 1) = (ar * x(1, :)**ai) * x(2, :)**degree(ii, 2) - xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi) + + indx(1:2) = degree(ii, 1:2) + + DO jj = 1, dim1 + areal = (ar * x(1, jj)**ai) * x(2, jj)**indx(2) + breal = x(1, jj)**indx(1) * (br * x(2, jj)**bi) + xx(jj, ii, 1) = areal + xx(jj, ii, 2) = breal + + END DO + END DO CASE (Heirarchical) - xx = HeirarchicalBasisGradient_Quadrangle( & - & p=order, & - & q=order, & - & xij=x) + ! xx = HeirarchicalBasisGradient_Quadrangle( & + CALL HeirarchicalBasisGradient_Quadrangle_(p=order, q=order, xij=x, & + ans=xx, dim1=indx(1), dim2=indx(2), dim3=indx(3)) CASE DEFAULT - xx = OrthogonalBasisGradient_Quadrangle( & - & p=order, & - & q=order, & - & xij=x, & - & basisType1=basisType0, & - & basisType2=basisType0, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda) + ! xx = OrthogonalBasisGradient_Quadrangle( & + CALL OrthogonalBasisGradient_Quadrangle_(p=order, q=order, xij=x, & + basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & + dim1=indx(1), dim2=indx(2), dim3=indx(3)) END SELECT DO ii = 1, 2 ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) + ans(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0) END DO -END PROCEDURE LagrangeGradientEvalAll_Quadrangle1 +END PROCEDURE LagrangeGradientEvalAll_Quadrangle1_ !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1 -INTEGER(I4B) :: a, b, maxP, maxQ -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) -REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) -REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL HeirarchicalBasisGradient_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & + qe1=qe1, qe2=qe2, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1_ +INTEGER(I4B) :: maxP, maxQ, indx(3) +REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :), dL1(:, :), dL2(:, :) + +dim1 = SIZE(xij, 2) +dim2 = 0 +dim3 = 2 maxP = MAX(pe3, pe4, pb) maxQ = MAX(qe1, qe2, qb) -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) -dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :)) -dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :)) +ALLOCATE (L1(1:dim1, 0:maxP), L2(1:dim1, 0:maxQ), & + dL1(1:dim1, 0:maxP), dL2(1:dim1, 0:maxQ)) -! Vertex basis function -ans(:, 1:4, 1:2) = VertexBasisGradient_Quadrangle2( & -& L1=L1, & -& L2=L2, & -& dL1=dL1, & -& dL2=dL2 & -& ) +CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) +CALL LobattoGradientEvalAll_(n=maxP, x=xij(1, :), ans=dL1, nrow=indx(1), & + ncol=indx(2)) +CALL LobattoGradientEvalAll_(n=maxQ, x=xij(2, :), ans=dL2, nrow=indx(1), & + ncol=indx(2)) + +CALL VertexBasisGradient_Quadrangle2_(L1=L1, L2=L2, dL1=dL1, dL2=dL2, & + ans=ans, dim1=indx(1), dim2=indx(2), dim3=indx(3)) + +dim2 = indx(2) -! Edge basis function -b = 4 IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 - ans(:, a:b, 1:2) = VerticalEdgeBasisGradient_Quadrangle2( & - & qe1=qe1, & - & qe2=qe2, & - & L1=L1, & - & L2=L2, & - & dL1=dL1, & - & dL2=dL2 & - & ) + 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)) + + dim2 = dim2 + indx(2) + END IF ! Edge basis function IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 - ans(:, a:b, 1:2) = HorizontalEdgeBasisGradient_Quadrangle2( & - & pe3=pe3, & - & pe4=pe4, & - & L1=L1, & - & L2=L2, & - & dL1=dL1, & - & dL2=dL2 & - & ) + 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)) + dim2 = dim2 + indx(2) END IF ! Cell basis function IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + (pb - 1) * (qb - 1) - ans(:, a:b, 1:2) = CellBasisGradient_Quadrangle2( & - & pb=pb, & - & qb=qb, & - & L1=L1, & - & L2=L2, & - & dL1=dL1, & - & dL2=dL2 & - & ) + 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)) + + dim2 = dim2 + indx(2) END IF -END PROCEDURE HeirarchicalBasisGradient_Quadrangle1 + +END PROCEDURE HeirarchicalBasisGradient_Quadrangle1_ !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2 -ans = HeirarchicalBasisGradient_Quadrangle1( & - & pb=p, & - & pe3=p, & - & pe4=p, & - & qb=q, & - & qe1=q, & - & qe2=q, & - & xij=xij) +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_ + !---------------------------------------------------------------------------- ! TensorProdBasisGradient_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL TensorProdBasisGradient_Quadrangle1_(p=p, q=q, xij=xij, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3, basisType1=basisType1, & + basisType2=basisType2, alpha1=alpha1, beta1=beta1, lambda1=lambda1, & + alpha2=alpha2, beta2=beta2, lambda2=lambda2) +END PROCEDURE TensorProdBasisGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_ REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: ii, k1, k2, cnt +INTEGER(I4B) :: ii, k1, k2, cnt, indx(3) -x = xij(1, :) -y = xij(2, :) +dim1 = SIZE(xij, 2) +dim2 = (p + 1) * (q + 1) +dim3 = 2 -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) +! 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( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) +! 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( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) +! 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( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) +! dQ1 = BasisGradientEvalAll_Line( & +CALL BasisGradientEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & + basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=dQ1, & + nrow=indx(1), ncol=indx(2)) cnt = 0 DO k2 = 1, q + 1 + DO k1 = 1, p + 1 cnt = cnt + 1 - ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2) - ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2) + ans(1:dim1, cnt, 1) = dP1(1:dim1, k1) * Q1(1:dim1, k2) + ans(1:dim1, cnt, 2) = P1(1:dim1, k1) * dQ1(1:dim1, k2) END DO + END DO -END PROCEDURE TensorProdBasisGradient_Quadrangle1 +END PROCEDURE TensorProdBasisGradient_Quadrangle1_ !---------------------------------------------------------------------------- ! QuadraturePoint_Quadrangle3 From bbe0c4c5816ce7c97a3a24564bce9b8dfcbd9a4d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 23:17:43 +0900 Subject: [PATCH 128/359] Updates in tetrahedron interpolation utility --- .../src/TetrahedronInterpolationUtility.F90 | 44 +++++++ ...etrahedronInterpolationUtility@Methods.F90 | 114 +++++++++--------- 2 files changed, 104 insertions(+), 54 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index fa1554ece..626949ae9 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -52,6 +52,7 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: QuadraturePoint_Tetrahedron PUBLIC :: RefElemDomain_Tetrahedron PUBLIC :: LagrangeGradientEvalAll_Tetrahedron +PUBLIC :: LagrangeGradientEvalAll_Tetrahedron_ PUBLIC :: HeirarchicalBasisGradient_Tetrahedron PUBLIC :: OrthogonalBasisGradient_Tetrahedron PUBLIC :: GetTotalDOF_Tetrahedron @@ -2494,6 +2495,49 @@ MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( & END FUNCTION LagrangeGradientEvalAll_Tetrahedron1 END INTERFACE LagrangeGradientEvalAll_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeGradientEvalAll_Tetrahedron_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Tetrahedron1_(order, x, xij, & + ans, dim1, dim2, dim3, refTetrahedron, coeff, firstCall, basisType, & + alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord ! x(2, :) is y coord ! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1, dim2, dim3 = SIZE(x, 2), SIZE(xij, 2), 3 + CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron + !! UNIT *default ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default ! Orthogonal + !! Legendre ! Lobatto ! Chebyshev ! Jacobi ! Ultraspherical ! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Tetrahedron1_ +END INTERFACE LagrangeGradientEvalAll_Tetrahedron_ + !---------------------------------------------------------------------------- ! OrthogonalBasisGradient_Tetrahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index bb00b6b4b..19176af36 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -2559,12 +2559,28 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll_Tetrahedron1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll_Tetrahedron1_(order=order, x=x, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, refTetrahedron=refTetrahedron, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) +END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Tetrahedron1_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci -INTEGER(I4B) :: degree(SIZE(xij, 2), 3) +INTEGER(I4B) :: ii, basisType0, ai, bi, ci, degree(SIZE(xij, 2), 3), & + indx(3), jj REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr -TYPE(String) :: ref0 + xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr, areal, breal, creal +CHARACTER(:), ALLOCATABLE :: ref0 + +dim1 = SIZE(x, 2) +dim2 = SIZE(xij, 2) +dim3 = 3 basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) @@ -2572,47 +2588,40 @@ END SUBROUTINE IJK2VEFC_Triangle IF (PRESENT(coeff)) THEN IF (firstCall0) THEN - coeff = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) + ! coeff = LagrangeCoeff_Tetrahedron(order=order, xij=xij, & + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + refTetrahedron=ref0, ans=coeff, nrow=indx(1), ncol=indx(2)) + END IF - coeff0 = coeff + + coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) + ELSE - coeff0 = LagrangeCoeff_Tetrahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda, & - & refTetrahedron=ref0%chars() & - & ) + + CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, ans=coeff0, & + nrow=indx(1), ncol=indx(2), basisType=basisType0, alpha=alpha, & + beta=beta, lambda=lambda, refTetrahedron=ref0) END IF SELECT CASE (basisType0) CASE (Monomial) - degree = LagrangeDegree_Tetrahedron(order=order) - tdof = SIZE(xij, 2) + CALL LagrangeDegree_Tetrahedron_(order=order, ans=degree, nrow=indx(1), & + ncol=indx(2)) - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Tetrahedron1", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + IF (dim2 .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Tetrahedron1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF - DO ii = 1, tdof +#endif + + DO ii = 1, dim2 ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) ci = MAX(degree(ii, 3_I4B) - 1_I4B, 0_I4B) @@ -2621,42 +2630,39 @@ END SUBROUTINE IJK2VEFC_Triangle br = REAL(degree(ii, 2_I4B), DFP) cr = REAL(degree(ii, 3_I4B), DFP) - xx(:, ii, 1) = (ar * x(1, :)**ai) * & - & x(2, :)**degree(ii, 2) * & - & x(3, :)**degree(ii, 3) + indx(1:3) = degree(ii, 1:3) - xx(:, ii, 2) = x(1, :)**degree(ii, 1) * & - & (br * x(2, :)**bi) * & - & x(3, :)**degree(ii, 3) + DO jj = 1, dim1 + areal = (ar * x(1, jj)**ai) * x(2, jj)**indx(2) * x(3, jj)**indx(3) + breal = x(1, jj)**indx(1) * (br * x(2, jj)**bi) * x(3, jj)**indx(3) + creal = x(1, jj)**indx(1) * x(2, jj)**indx(2) * (cr * x(2, jj)**ci) + + xx(jj, ii, 1) = areal + xx(jj, ii, 2) = breal + xx(jj, ii, 3) = creal + END DO - xx(:, ii, 3) = x(1, :)**degree(ii, 1) * & - & x(2, :)**degree(ii, 2) * & - & (cr * x(2, :)**ci) END DO CASE (Heirarchical) - xx = HeirarchicalBasisGradient_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars()) + xx = HeirarchicalBasisGradient_Tetrahedron(order=order, xij=x, & + refTetrahedron=ref0) CASE DEFAULT - - xx = OrthogonalBasisGradient_Tetrahedron( & - & order=order, & - & xij=x, & - & refTetrahedron=ref0%chars() & - & ) + xx = OrthogonalBasisGradient_Tetrahedron(order=order, xij=x, & + refTetrahedron=ref0) END SELECT DO ii = 1, 3 ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) + ans(1:dim1, 1:dim2, ii) = MATMUL(xx(:, :, ii), coeff0) END DO -END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1 +ref0 = "" + +END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1_ !---------------------------------------------------------------------------- ! OrthogonalBasisGradient_Tetrahedron From ec08b6fe2d824f002389ef4943c8d036fed69241 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 23:27:45 +0900 Subject: [PATCH 129/359] Updates in hexahedron utility --- .../src/HexahedronInterpolationUtility.F90 | 39 ++++++++++ ...HexahedronInterpolationUtility@Methods.F90 | 73 +++++++++++-------- 2 files changed, 81 insertions(+), 31 deletions(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index 744b42141..cf6713b3f 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -54,6 +54,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: GetCellDOF_Hexahedron PUBLIC :: RefElemDomain_Hexahedron PUBLIC :: LagrangeGradientEvalAll_Hexahedron +PUBLIC :: LagrangeGradientEvalAll_Hexahedron_ PUBLIC :: OrthogonalBasisGradient_Hexahedron PUBLIC :: TensorProdBasisGradient_Hexahedron PUBLIC :: HeirarchicalBasisGradient_Hexahedron @@ -2759,6 +2760,44 @@ MODULE FUNCTION LagrangeGradientEvalAll_Hexahedron1( & END FUNCTION LagrangeGradientEvalAll_Hexahedron1 END INTERFACE LagrangeGradientEvalAll_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeGradientEvalAll_Hexahedron_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Hexahedron1_(order, x, xij, ans, & + dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1, dim2, dim3 = SIZE(x, 2), SIZE(xij, 2), 3 + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Hexahedron1_ +END INTERFACE LagrangeGradientEvalAll_Hexahedron_ + !---------------------------------------------------------------------------- ! TensorProdBasisGradient_Hexahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index 6c8d9d1ea..d6ec30ccb 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2617,58 +2617,69 @@ END PROCEDURE LagrangeEvalAll_Hexahedron2_ !---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Hexahedron +! !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll_Hexahedron1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll_Hexahedron1_(order=order, x=x, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE LagrangeGradientEvalAll_Hexahedron1 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Hexahedron1_ LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci -INTEGER(I4B) :: degree(SIZE(xij, 2), 3), d1, d2, d3 +INTEGER(I4B) :: ii, basisType0, ai, bi, ci,d1, d2, d3, degree(SIZE(xij, 2), 3), indx(3) REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr + xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr + +dim1 = SIZE(x, 2) +dim2 = SIZE(xij, 2) +dim3 = 3 basisType0 = INPUT(default=Monomial, option=basisType) firstCall0 = INPUT(default=.TRUE., option=firstCall) IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN - coeff = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) + ! coeff = LagrangeCoeff_Hexahedron(& + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, & + basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff, nrow=indx(1), ncol=indx(2)) END IF - coeff0 = coeff + coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) + ELSE - coeff0 = LagrangeCoeff_Hexahedron(& - & order=order, & - & xij=xij, & - & basisType=basisType0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) + + CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrows=indx(1), & + ncols=indx(2)) + END IF SELECT CASE (basisType0) CASE (Monomial) + degree = LagrangeDegree_Hexahedron(order=order) - tdof = SIZE(xij, 2) - IF (tdof .NE. SIZE(degree, 1)) THEN - CALL Errormsg(& - & msg="tdof is not same as size(degree,1)", & - & file=__FILE__, & - & routine="LagrangeEvalAll_Hexahedron1", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + + IF (dim2 .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Hexahedron1", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END IF +#endif + DO ii = 1, tdof d1 = degree(ii, 1) d2 = degree(ii, 2) @@ -2726,10 +2737,10 @@ DO ii = 1, 3 ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0) + ans(1:dim1, 1:dim2, ii) = MATMUL(xx(:, :, ii), coeff0) END DO -END PROCEDURE LagrangeGradientEvalAll_Hexahedron1 +END PROCEDURE LagrangeGradientEvalAll_Hexahedron1_ !---------------------------------------------------------------------------- ! TensorProdBasisGradient_Hexahedron From e23bf410a3cedafdd2fe101e79d92783a2d7ed6a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 23:28:28 +0900 Subject: [PATCH 130/359] Updates in hexahedron utility --- .../Polynomial/src/HexahedronInterpolationUtility@Methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index d6ec30ccb..58c647b7e 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2680,7 +2680,7 @@ #endif - DO ii = 1, tdof + DO ii = 1, dim2 d1 = degree(ii, 1) d2 = degree(ii, 2) d3 = degree(ii, 3) From 702c085780a038dfd959f328f780a3c0f04e0f22 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Jul 2024 23:30:12 +0900 Subject: [PATCH 131/359] updates in hexahedron interpolation utility --- .../Polynomial/src/HexahedronInterpolationUtility@Methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index 58c647b7e..ee65c98cd 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2658,8 +2658,8 @@ ELSE CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrows=indx(1), & - ncols=indx(2)) + alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=indx(1), & + ncol=indx(2)) END IF From b945a37d7b439354553ddac71edeb515e1c85190 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Jul 2024 00:46:17 +0900 Subject: [PATCH 132/359] Updates in prism interpolation utility --- .../src/PrismInterpolationUtility.F90 | 50 ++++++++++++++++++- .../src/PrismInterpolationUtility@Methods.F90 | 26 +++++++--- 2 files changed, 67 insertions(+), 9 deletions(-) diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index f8772c379..e5ec3feeb 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -35,6 +35,8 @@ MODULE PrismInterpolationUtility PUBLIC :: LagrangeEvalAll_Prism PUBLIC :: LagrangeEvalAll_Prism_ PUBLIC :: LagrangeGradientEvalAll_Prism +PUBLIC :: LagrangeGradientEvalAll_Prism_ + PUBLIC :: EdgeConnectivity_Prism PUBLIC :: FacetConnectivity_Prism PUBLIC :: GetTotalDOF_Prism @@ -879,7 +881,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Prism1( & !! UNIT *default !! BIUNIT REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials + !!!! Coefficient of Lagrange polynomials LOGICAL(LGT), OPTIONAL :: firstCall !! If firstCall is true, then coeff will be made !! If firstCall is False, then coeff will be used @@ -912,4 +914,50 @@ END FUNCTION LagrangeGradientEvalAll_Prism1 ! !---------------------------------------------------------------------------- +INTERFACE LagrangeGradientEvalAll_Prism_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Prism1_(order, x, xij, ans, & + dim1, dim2, dim3, refPrism, coeff, firstCall, basisType, alpha, beta, & + lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! SIZE(x, 2), SIZE(xij, 2), 3 + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism + !! UNIT *default + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default ! Legendre ! Lobatto ! Chebyshev ! Jacobi + !! Ultraspherical ! Heirarchical ! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Prism1_ +END INTERFACE LagrangeGradientEvalAll_Prism_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE PrismInterpolationUtility diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 index 819de72af..d9b30b5ef 100644 --- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 @@ -349,19 +349,29 @@ END PROCEDURE LagrangeEvalAll_Prism2_ !---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Prism +! !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll_Prism1 -!FIX: Implement LagrangeGradientEvalAll_Prism1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeGradientEvalAll_Prism1()", & -& file=__FILE__) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll_Prism1_(order=order, x=x, xij=xij, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3, refPrism=refPrism, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) END PROCEDURE LagrangeGradientEvalAll_Prism1 +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Prism1_ +!FIX: Implement LagrangeGradientEvalAll_Prism1_ +CALL ErrorMsg(msg="Work in progress", & + routine="LagrangeGradientEvalAll_Prism1_()", & + unitno=stdout, line=__LINE__, file=__FILE__) +RETURN +END PROCEDURE LagrangeGradientEvalAll_Prism1_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From de7e835efe7f4bc085bd48c33b6a870cba83b2d2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Jul 2024 00:46:34 +0900 Subject: [PATCH 133/359] updates in pyramid interpolation utility --- .../src/PyramidInterpolationUtility.F90 | 46 +++++++++++++++++++ .../PyramidInterpolationUtility@Methods.F90 | 26 +++++++---- 2 files changed, 64 insertions(+), 8 deletions(-) diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 index 0d671c352..61eeb24c2 100644 --- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 @@ -35,6 +35,7 @@ MODULE PyramidInterpolationUtility PUBLIC :: LagrangeEvalAll_Pyramid PUBLIC :: LagrangeEvalAll_Pyramid_ PUBLIC :: LagrangeGradientEvalAll_Pyramid +PUBLIC :: LagrangeGradientEvalAll_Pyramid_ PUBLIC :: EdgeConnectivity_Pyramid PUBLIC :: FacetConnectivity_Pyramid PUBLIC :: GetTotalDOF_Pyramid @@ -916,4 +917,49 @@ END FUNCTION LagrangeGradientEvalAll_Pyramid1 ! !---------------------------------------------------------------------------- +INTERFACE LagrangeGradientEvalAll_Pyramid_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Pyramid1_(order, x, xij, ans, & + dim1, dim2, dim3, refPyramid, coeff, firstCall, basisType, alpha, & + beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! (SIZE(x, 2), SIZE(xij, 2), 3 + CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid + !! UNIT *default ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default ! Legendre ! Lobatto ! Chebyshev ! Jacobi + !! Ultraspherical ! Heirarchical ! Orthogonal + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Pyramid1_ +END INTERFACE LagrangeGradientEvalAll_Pyramid_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE PyramidInterpolationUtility diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 index 10950438e..2e2f801ac 100644 --- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 @@ -355,17 +355,27 @@ END PROCEDURE LagrangeEvalAll_Pyramid2_ !---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Pyramid +! !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll_Pyramid1 -!FIX: LagrangeGradientEvalAll_Pyramid1 -CALL ErrorMsg(& -& msg="Work in progress", & -& unitno=stdout, & -& line=__LINE__, & -& routine="LagrangeGradientEvalAll_Pyramid1()", & -& file=__FILE__) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll_Pyramid1_(order=order, x=x, xij=xij, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3, refPyramid=refPyramid, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) END PROCEDURE LagrangeGradientEvalAll_Pyramid1 +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Pyramid1_ +!FIX: Implement LagrangeGradientEvalAll_Pyramid1_ +CALL ErrorMsg(msg="Work in progress", & + routine="LagrangeGradientEvalAll_Pyramid1_()", & + unitno=stdout, line=__LINE__, file=__FILE__) +RETURN +END PROCEDURE LagrangeGradientEvalAll_Pyramid1_ + END SUBMODULE Methods From fb987daff6540d77e90baeb7d6bdb7c5dbb86b48 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Jul 2024 00:58:01 +0900 Subject: [PATCH 134/359] updates in triangle interpolation --- src/modules/Polynomial/src/TriangleInterpolationUtility.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index e4b0a2986..43ac62fa6 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -44,6 +44,8 @@ MODULE TriangleInterpolationUtility PUBLIC :: LagrangeEvalAll_Triangle_ PUBLIC :: LagrangeGradientEvalAll_Triangle +PUBLIC :: LagrangeGradientEvalAll_Triangle_ + PUBLIC :: QuadraturePoint_Triangle PUBLIC :: IJ2VEFC_Triangle PUBLIC :: FacetConnectivity_Triangle From d783a2681470cf9fc6942f3743b1715e2f7dfad9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Jul 2024 00:58:23 +0900 Subject: [PATCH 135/359] updates in lagrange polynomial utility --- .../src/LagrangePolynomialUtility@Methods.F90 | 67 +++++++++++-------- 1 file changed, 38 insertions(+), 29 deletions(-) diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index 05e687f9d..db114f510 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -32,7 +32,7 @@ LagrangeCoeff_Line, & LagrangeCoeff_Line_, & LagrangeEvalAll_Line_, & - LagrangeGradientEvalAll_Line + LagrangeGradientEvalAll_Line_ USE TriangleInterpolationUtility, ONLY: LagrangeDOF_Triangle, & LagrangeInDOF_Triangle, & @@ -43,7 +43,7 @@ LagrangeCoeff_Triangle, & LagrangeCoeff_Triangle_, & LagrangeEvalAll_Triangle_, & - LagrangeGradientEvalAll_Triangle + LagrangeGradientEvalAll_Triangle_ USE QuadrangleInterpolationUtility, ONLY: LagrangeDOF_Quadrangle, & LagrangeInDOF_Quadrangle, & @@ -54,7 +54,7 @@ LagrangeCoeff_Quadrangle, & LagrangeCoeff_Quadrangle_, & LagrangeEvalAll_Quadrangle_, & - LagrangeGradientEvalAll_Quadrangle + LagrangeGradientEvalAll_Quadrangle_ USE TetrahedronInterpolationUtility, ONLY: LagrangeDOF_Tetrahedron, & LagrangeInDOF_Tetrahedron, & @@ -65,7 +65,7 @@ LagrangeCoeff_Tetrahedron, & LagrangeCoeff_Tetrahedron_, & LagrangeEvalAll_Tetrahedron_, & - LagrangeGradientEvalAll_Tetrahedron + LagrangeGradientEvalAll_Tetrahedron_ USE HexahedronInterpolationUtility, ONLY: LagrangeDOF_Hexahedron, & LagrangeInDOF_Hexahedron, & @@ -76,7 +76,7 @@ LagrangeCoeff_Hexahedron, & LagrangeCoeff_Hexahedron_, & LagrangeEvalAll_Hexahedron_, & - LagrangeGradientEvalAll_Hexahedron + LagrangeGradientEvalAll_Hexahedron_ USE PrismInterpolationUtility, ONLY: LagrangeDOF_Prism, & LagrangeInDOF_Prism, & @@ -87,7 +87,7 @@ LagrangeCoeff_Prism, & LagrangeCoeff_Prism_, & LagrangeEvalAll_Prism_, & - LagrangeGradientEvalAll_Prism + LagrangeGradientEvalAll_Prism_ USE PyramidInterpolationUtility, ONLY: LagrangeDOF_Pyramid, & LagrangeInDOF_Pyramid, & @@ -98,7 +98,7 @@ LagrangeCoeff_Pyramid, & LagrangeCoeff_Pyramid_, & LagrangeEvalAll_Pyramid_, & - LagrangeGradientEvalAll_Pyramid + LagrangeGradientEvalAll_Pyramid_ USE ReallocateUtility, ONLY: Reallocate @@ -741,9 +741,10 @@ #endif - ans(1:dim1, 1:dim2, 1:1) = LagrangeGradientEvalAll_Line(order=order, & - x=x, xij=xij, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) + ! ans(1:dim1, 1:dim2, 1:1) = LagrangeGradientEvalAll_Line(order=order, & + CALL LagrangeGradientEvalAll_Line_(order=order, x=x, xij=xij, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) CASE (Triangle) @@ -758,10 +759,11 @@ #endif - ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Triangle(order=order, & - x=x, xij=xij, refTriangle=domainName, coeff=coeff, & + ! ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Triangle(order=order, & + CALL LagrangeGradientEvalAll_Triangle_(order=order, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3, x=x, xij=xij, refTriangle=domainName, coeff=coeff, & firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda) + lambda=lambda) CASE (Quadrangle) @@ -776,9 +778,10 @@ #endif - ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Quadrangle( & - order=order, x=x, xij=xij, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) + ! ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Quadrangle( & + CALL LagrangeGradientEvalAll_Quadrangle_(order=order, x=x, xij=xij, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) CASE (Tetrahedron) @@ -793,10 +796,11 @@ #endif - ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Tetrahedron( & - order=order, x=x, xij=xij, refTetrahedron=domainName, coeff=coeff, & - firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda) + ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Tetrahedron( & + CALL LagrangeGradientEvalAll_Tetrahedron_(order=order, x=x, xij=xij, & + refTetrahedron=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) CASE (Hexahedron) @@ -811,9 +815,10 @@ #endif - ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Hexahedron( & - order=order, x=x, xij=xij, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) + ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Hexahedron( & + CALL LagrangeGradientEvalAll_Hexahedron_(order=order, x=x, xij=xij, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) CASE (Prism) @@ -826,9 +831,11 @@ END IF #endif - ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Prism(order=order, & - x=x, xij=xij, refPrism=domainName, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) + ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Prism(order=order, & + CALL LagrangeGradientEvalAll_Prism_(order=order, x=x, xij=xij, & + refPrism=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) CASE (Pyramid) @@ -843,9 +850,11 @@ #endif - ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Pyramid(order=order, & - x=x, xij=xij, refPyramid=domainName, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) + ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Pyramid(order=order, & + CALL LagrangeGradientEvalAll_Pyramid_(order=order, x=x, xij=xij, & + refPyramid=domainName, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) CASE DEFAULT From 56505e10dd5968ff37ebe68d15c3b0acdaa5e3b5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Jul 2024 09:40:03 +0900 Subject: [PATCH 136/359] updates in quadrangle interpolation utility --- .../src/QuadrangleInterpolationUtility.F90 | 54 ++++- ...QuadrangleInterpolationUtility@Methods.F90 | 215 ++++++++++-------- 2 files changed, 173 insertions(+), 96 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index e099e1383..0eb5cd570 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -23,6 +23,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: LagrangeDOF_Quadrangle PUBLIC :: LagrangeInDOF_Quadrangle PUBLIC :: EquidistancePoint_Quadrangle +! PUBLIC :: EquidistancePoint_Quadrangle_ PUBLIC :: EquidistanceInPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle_ @@ -312,7 +313,7 @@ END FUNCTION LagrangeInDOF_Quadrangle2 INTERFACE EquidistancePoint_Quadrangle MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) @@ -326,6 +327,28 @@ MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & END FUNCTION EquidistancePoint_Quadrangle1 END INTERFACE EquidistancePoint_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EquidistancePoint_Quadrangle_ + MODULE RECURSIVE PURE SUBROUTINE EquidistancePoint_Quadrangle1_(order, & + ans, nrow, ncol, xij) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 + !! number of cols = 4 + END SUBROUTINE EquidistancePoint_Quadrangle1_ +END INTERFACE EquidistancePoint_Quadrangle_ + !---------------------------------------------------------------------------- ! EquidistancePoint_Quadrangle !---------------------------------------------------------------------------- @@ -345,7 +368,7 @@ END FUNCTION EquidistancePoint_Quadrangle1 INTERFACE EquidistancePoint_Quadrangle MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, & - & xij) RESULT(ans) + xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order in x direction INTEGER(I4B), INTENT(IN) :: q @@ -361,6 +384,29 @@ MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, & END FUNCTION EquidistancePoint_Quadrangle2 END INTERFACE EquidistancePoint_Quadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EquidistancePoint_Quadrangle_ + MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle2_(p, q, ans, & + nrow, ncol, xij) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 or 3 + !! number of cols = 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE EquidistancePoint_Quadrangle2_ +END INTERFACE EquidistancePoint_Quadrangle_ + !---------------------------------------------------------------------------- ! EquidistanceInPoint_Quadrangle !---------------------------------------------------------------------------- @@ -376,7 +422,7 @@ END FUNCTION EquidistancePoint_Quadrangle2 INTERFACE EquidistanceInPoint_Quadrangle MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) @@ -405,7 +451,7 @@ END FUNCTION EquidistanceInPoint_Quadrangle1 INTERFACE EquidistanceInPoint_Quadrangle MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order in x direction INTEGER(I4B), INTENT(IN) :: q diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 6deed943c..8a2b3b3e3 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -176,124 +176,155 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Quadrangle1 -INTEGER(I4B) :: nsd, n, ne, i1, i2 -REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu +INTEGER(I4B) :: nrow, ncol + +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_ +INTEGER(I4B) :: ne, i1, i2, indx(3) +REAL(DFP) :: x(3, 5), xin(3, 4), e1(3), e2(3), lam, avar, mu x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP + IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - x(1:nsd, 1:4) = xij(1:nsd, 1:4) + nrow = SIZE(xij, 1) + x(1:nrow, 1:4) = xij(1:nrow, 1:4) ELSE - nsd = 2_I4B - x = 0.0_DFP - x(1:2, :) = RefQuadrangleCoord("BIUNIT") + nrow = 2_I4B + x(1:2, 1:4) = RefQuadrangleCoord("BIUNIT") + x(3:4, 1:4) = 0.0_DFP END IF -n = LagrangeDOF_Quadrangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP +IF (order .EQ. 0_I4B) THEN + ncol = 1 + ans(1:nrow, 1) = SUM(x(1:nrow, 1:4), dim=2_I4B) / 4.0_DFP + RETURN +END IF + +x(:, 5) = x(:, 1) !! cycic effect +ncol = LagrangeDOF_Quadrangle(order=order) ! points on vertex -ans(1:nsd, 1:4) = x(1:nsd, 1:4) + +ans(1:nrow, 1:4) = x(1:nrow, 1:4) + +IF (order .EQ. 1_I4B) RETURN ! points on edge ne = LagrangeInDOF_Line(order=order) i2 = 4 -IF (order .GT. 1_I4B) THEN - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [1, 2])) - - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [2, 3])) - - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [3, 4])) - - i1 = i2 + 1; i2 = i1 + ne - 1 - ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( & - & order=order, & - & xij=x(1:nsd, [4, 1])) +i1 = i2 + 1; i2 = i1 + ne - 1 +CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 1:2), & + ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) -END IF +i1 = i2 + 1; i2 = i1 + ne - 1 +CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 2:3), & + ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) -! points on face -IF (order .GT. 1_I4B) THEN - - IF (order .EQ. 2_I4B) THEN - i1 = i2 + 1 - ans(1:nsd, i1) = SUM(x(1:nsd, :), dim=2_I4B) / 4.0_DFP - ELSE +i1 = i2 + 1; i2 = i1 + ne - 1 +CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 3:4), & + ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 2) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 4) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 4) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd) - - i1 = i2 + 1 - ans(1:nsd, i1:) = EquidistancePoint_Quadrangle( & - & order=order - 2, & - & xij=xin(1:nsd, 1:4)) +i1 = i2 + 1; i2 = i1 + ne - 1 +CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 4:5), & + ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) - END IF +IF (order .EQ. 2_I4B) THEN + i1 = i2 + 1 + ans(1:nrow, i1) = SUM(x(1:nrow, 1:4), dim=2_I4B) / 4.0_DFP + RETURN END IF -END PROCEDURE EquidistancePoint_Quadrangle1 + +! points on face +! IF (order .GT. 2_I4B) THEN + +e1 = x(:, 2) - x(:, 1) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 4) - x(:, 1) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 1) = x(1:nrow, 1) + lam * e1(1:nrow) + mu * e2(1:nrow) + +e1 = x(:, 3) - x(:, 2) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 1) - x(:, 2) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 2) = x(1:nrow, 2) + lam * e1(1:nrow) + mu * e2(1:nrow) + +e1 = x(:, 2) - x(:, 3) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 4) - x(:, 3) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow) + +e1 = x(:, 3) - x(:, 4) +avar = NORM2(e1) +e1 = e1 / avar +lam = avar / order +e2 = x(:, 1) - x(:, 4) +avar = NORM2(e2) +e2 = e2 / avar +mu = avar / order +xin(1:nrow, 4) = x(1:nrow, 4) + lam * e1(1:nrow) + mu * e2(1:nrow) + +i1 = i2 + 1 +! ans(1:nsd, i1:) = EquidistancePoint_Quadrangle( & +CALL EquidistancePoint_Quadrangle_(order=order - 2, xij=xin(1:nrow, 1:4), & + ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) + +END PROCEDURE EquidistancePoint_Quadrangle1_ !---------------------------------------------------------------------------- ! EquidistancePoint_Quadrangle !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Quadrangle2 -ans = InterpolationPoint_Quadrangle2( & - & p=p, & - & q=q, & - & xij=xij, & - & ipType1=Equidistance, & - & ipType2=Equidistance, & - & layout="VEFC") +INTEGER(I4B) :: nrow, ncol +nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) +ncol = (p + 1) * (q + 1) +ALLOCATE (ans(nrow, ncol)) +CALL EquidistancePoint_Quadrangle2_(p=p, q=q, ans=ans, nrow=nrow, ncol=ncol, & + xij=xij) END PROCEDURE EquidistancePoint_Quadrangle2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Quadrangle2_ +CALL InterpolationPoint_Quadrangle2_(p=p, q=q, ipType1=Equidistance, & + ipType2=Equidistance, ans=ans, nrow=nrow, ncol=ncol, layout="VEFC", xij=xij) +END PROCEDURE EquidistancePoint_Quadrangle2_ + !---------------------------------------------------------------------------- ! EquidistanceInPoint_Quadrangle !---------------------------------------------------------------------------- From f785101874fdb81e878ec820f909ffcf44e093fe Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Jul 2024 10:48:55 +0900 Subject: [PATCH 137/359] updates in tetrahedron --- .../src/TetrahedronInterpolationUtility.F90 | 20 +++++++++++++++++++ ...etrahedronInterpolationUtility@Methods.F90 | 20 +++++++++++++------ 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index 626949ae9..e818160ac 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -26,6 +26,7 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: LagrangeInDOF_Tetrahedron PUBLIC :: EquidistanceInPoint_Tetrahedron PUBLIC :: EquidistancePoint_Tetrahedron +PUBLIC :: EquidistancePoint_Tetrahedron_ PUBLIC :: LagrangeCoeff_Tetrahedron PUBLIC :: LagrangeCoeff_Tetrahedron_ PUBLIC :: InterpolationPoint_Tetrahedron @@ -416,6 +417,25 @@ MODULE FUNCTION EquidistancePoint_Tetrahedron(order, xij) RESULT(ans) END FUNCTION EquidistancePoint_Tetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE EquidistancePoint_Tetrahedron_(order, xij, ans, nrow, & + ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE EquidistancePoint_Tetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! EquidistancePoint_Tetrahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index 19176af36..5959110cc 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -450,14 +450,22 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Tetrahedron -ans = InterpolationPoint_Tetrahedron( & - & order=order, & - & ipType=Equidistance, & - & layout="VEFC", & - & xij=xij & - &) +INTEGER(I4B) :: nrow, ncol +ncol = SIZE(n=order, d=3) +ALLOCATE (ans(3, ncol)) +CALL EquidistancePoint_Tetrahedron_(order=order, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE EquidistancePoint_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Tetrahedron_ +CALL InterpolationPoint_Tetrahedron_(order=order, ipType=Equidistance, & + layout="VEFC", xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE EquidistancePoint_Tetrahedron_ + !---------------------------------------------------------------------------- ! EquidistanceInPoint_Tetrahedron !---------------------------------------------------------------------------- From abf389339709fb338b6702f8d2c00075928dd19c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:55:57 +0900 Subject: [PATCH 138/359] updates in hexahedron interpollation --- .../src/HexahedronInterpolationUtility.F90 | 41 +++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index cf6713b3f..012eb03c6 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -24,6 +24,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: LagrangeDOF_Hexahedron PUBLIC :: LagrangeInDOF_Hexahedron PUBLIC :: EquidistancePoint_Hexahedron +PUBLIC :: EquidistancePoint_Hexahedron_ PUBLIC :: EquidistanceInPoint_Hexahedron PUBLIC :: InterpolationPoint_Hexahedron PUBLIC :: InterpolationPoint_Hexahedron_ @@ -567,6 +568,24 @@ MODULE PURE FUNCTION EquidistancePoint_Hexahedron1(order, xij) RESULT(ans) END FUNCTION EquidistancePoint_Hexahedron1 END INTERFACE EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EquidistancePoint_Hexahedron_ + MODULE PURE SUBROUTINE EquidistancePoint_Hexahedron1_(order, ans, nrow, & + ncol, xij) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! number of rows = 3 + !! number of cols = 8 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE EquidistancePoint_Hexahedron1_ +END INTERFACE EquidistancePoint_Hexahedron_ + !---------------------------------------------------------------------------- ! EquidistancePoint_Hexahedron !---------------------------------------------------------------------------- @@ -601,6 +620,28 @@ MODULE PURE FUNCTION EquidistancePoint_Hexahedron2(p, q, r, xij) & END FUNCTION EquidistancePoint_Hexahedron2 END INTERFACE EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE EquidistancePoint_Hexahedron_ + MODULE PURE SUBROUTINE EquidistancePoint_Hexahedron2_(p, q, r, ans, nrow, & + ncol, xij) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order in z direction + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! number of rows = 3 + !! number of cols = 8 + END SUBROUTINE EquidistancePoint_Hexahedron2_ +END INTERFACE EquidistancePoint_Hexahedron_ + !---------------------------------------------------------------------------- ! InterpolationPoint_Hexahedron !---------------------------------------------------------------------------- From ae56943d1e38bbf4dd44a337d9b14c6debd4beb2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:56:08 +0900 Subject: [PATCH 139/359] updates in lagrange polynomial --- .../src/LagrangePolynomialUtility.F90 | 38 +++++++++++++++++-- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index f4886363a..e2219ff59 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -29,16 +29,22 @@ MODULE LagrangePolynomialUtility PUBLIC :: LagrangeDOF PUBLIC :: LagrangeInDOF PUBLIC :: LagrangeDegree + PUBLIC :: EquidistancePoint +PUBLIC :: EquidistancePoint_ PUBLIC :: LagrangeVandermonde PUBLIC :: LagrangeVandermonde_ + PUBLIC :: InterpolationPoint PUBLIC :: InterpolationPoint_ + PUBLIC :: LagrangeCoeff PUBLIC :: LagrangeCoeff_ + PUBLIC :: LagrangeEvalAll PUBLIC :: LagrangeEvalAll_ + PUBLIC :: LagrangeGradientEvalAll PUBLIC :: LagrangeGradientEvalAll_ @@ -163,10 +169,7 @@ MODULE FUNCTION EquidistancePoint(order, elemType, xij) RESULT(ans) REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! nodal coordinates of linear elements !! Default values: - !! Biunit line - !! Unit triangle - !! Biunit Quadrangle - !! Unit Tetrahedron + !! Biunit line ! Unit triangle ! Biunit Quadrangle ! Unit Tetrahedron !! Biunit Hexahedron REAL(DFP), ALLOCATABLE :: ans(:, :) !! Equidistance points in xij format @@ -176,6 +179,33 @@ MODULE FUNCTION EquidistancePoint(order, elemType, xij) RESULT(ans) END FUNCTION EquidistancePoint END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE EquidistancePoint_(order, elemType, ans, nrow, ncol, xij) + INTEGER(I4B), INTENT(IN) :: order + !! Order of element + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type + !! Point, Line, Triangle, Quadrangle, Tetrahedron + !! Hexahedron, Prism, Pyramid + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Equidistance points in xij format + !! Number of rows = nsd + !! Number of columns = Number of points + !! The number of points depend upon the order and elemType + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of linear elements + !! Default values: + !! Biunit line ! Unit triangle ! Biunit Quadrangle ! Unit Tetrahedron + !! Biunit Hexahedron + END SUBROUTINE EquidistancePoint_ +END INTERFACE + !---------------------------------------------------------------------------- ! InterpolationPoint !---------------------------------------------------------------------------- From eef1067b966472efe978ea660cc14f95c245530d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:56:17 +0900 Subject: [PATCH 140/359] updates in prism interpolation --- .../src/PrismInterpolationUtility.F90 | 33 ++++++++++++++++--- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index e5ec3feeb..bb024a8d5 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -24,7 +24,10 @@ MODULE PrismInterpolationUtility PUBLIC :: LagrangeDOF_Prism PUBLIC :: LagrangeInDOF_Prism PUBLIC :: EquidistanceInPoint_Prism + PUBLIC :: EquidistancePoint_Prism +PUBLIC :: EquidistancePoint_Prism_ + PUBLIC :: InterpolationPoint_Prism PUBLIC :: InterpolationPoint_Prism_ PUBLIC :: LagrangeCoeff_Prism @@ -253,16 +256,36 @@ END FUNCTION EquidistanceInPoint_Prism INTERFACE MODULE PURE FUNCTION EquidistancePoint_Prism(order, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order + !! order REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 3 + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates in $x_{iJ}$ format + !! returned coordinates in $x_{iJ}$ format END FUNCTION EquidistancePoint_Prism END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE EquidistancePoint_Prism_(order, ans, nrow, ncol, & + xij) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! equidistance points in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + END SUBROUTINE EquidistancePoint_Prism_ +END INTERFACE + !---------------------------------------------------------------------------- ! InterpolationPoint_Prism !---------------------------------------------------------------------------- From 33db60b4831bcb11237de166f54b802e5e09f464 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:56:26 +0900 Subject: [PATCH 141/359] updates in pyramid interpolation --- .../src/PyramidInterpolationUtility.F90 | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 index 61eeb24c2..ba78b888e 100644 --- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 @@ -25,6 +25,7 @@ MODULE PyramidInterpolationUtility PUBLIC :: LagrangeInDOF_Pyramid PUBLIC :: EquidistanceInPoint_Pyramid PUBLIC :: EquidistancePoint_Pyramid +PUBLIC :: EquidistancePoint_Pyramid_ PUBLIC :: InterpolationPoint_Pyramid PUBLIC :: InterpolationPoint_Pyramid_ PUBLIC :: LagrangeCoeff_Pyramid @@ -262,6 +263,26 @@ MODULE PURE FUNCTION EquidistancePoint_Pyramid(order, xij) RESULT(ans) END FUNCTION EquidistancePoint_Pyramid END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE EquidistancePoint_Pyramid_(order, ans, nrow, ncol, & + xij) + INTEGER(I4B), INTENT(IN) :: order + !! order + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates in $x_{iJ}$ format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 3 + END SUBROUTINE EquidistancePoint_Pyramid_ +END INTERFACE + !---------------------------------------------------------------------------- ! InterpolationPoint_Pyramid !---------------------------------------------------------------------------- From 07b24abf5b6196495da626c63eccf7a16235c513 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:56:37 +0900 Subject: [PATCH 142/359] updates in quadrangle interpolation --- src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 0eb5cd570..250b3a1fd 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -23,7 +23,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: LagrangeDOF_Quadrangle PUBLIC :: LagrangeInDOF_Quadrangle PUBLIC :: EquidistancePoint_Quadrangle -! PUBLIC :: EquidistancePoint_Quadrangle_ +PUBLIC :: EquidistancePoint_Quadrangle_ PUBLIC :: EquidistanceInPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle_ From 121ebe25fe35af153bd4ce2ac98f02f6b6c91fd3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:56:45 +0900 Subject: [PATCH 143/359] updates in triangle interpolation --- .../Polynomial/src/TriangleInterpolationUtility.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 43ac62fa6..ab11b3e9d 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -24,7 +24,10 @@ MODULE TriangleInterpolationUtility PUBLIC :: LagrangeDOF_Triangle PUBLIC :: LagrangeInDOF_Triangle PUBLIC :: EquidistanceInPoint_Triangle + PUBLIC :: EquidistancePoint_Triangle +PUBLIC :: EquidistancePoint_Triangle_ + PUBLIC :: InterpolationPoint_Triangle PUBLIC :: InterpolationPoint_Triangle_ PUBLIC :: LagrangeCoeff_Triangle @@ -320,6 +323,10 @@ MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Triangle(order, xij) RESULT(ans END FUNCTION EquidistancePoint_Triangle END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE MODULE RECURSIVE PURE SUBROUTINE EquidistancePoint_Triangle_(order, ans, & nrow, ncol, xij) From dcc4d679b9024451a9386c973033a5f12500f599 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:56:52 +0900 Subject: [PATCH 144/359] updates in swap util --- src/modules/Utility/src/SwapUtility.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/modules/Utility/src/SwapUtility.F90 b/src/modules/Utility/src/SwapUtility.F90 index 0375e0f00..0304fc55f 100644 --- a/src/modules/Utility/src/SwapUtility.F90 +++ b/src/modules/Utility/src/SwapUtility.F90 @@ -558,6 +558,13 @@ MODULE PURE SUBROUTINE Swap_index_1(a, b, i1, i2) !! make sure i2 is less than or equal to 2 END SUBROUTINE Swap_index_1 +END INTERFACE Swap_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Swap_ MODULE PURE SUBROUTINE Swap_index_2(a, b, i1, i2) REAL(REAL64), INTENT(INOUT) :: a(:, :) !! the returned array From b266019afa08bc6dc52b4557c82643b1982b41a9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:57:11 +0900 Subject: [PATCH 145/359] update in elemshapedata lagrange --- src/submodules/ElemshapeData/CMakeLists.txt | 1 - ...lemshapeData_H1Methods@LagrangeMethods.F90 | 112 --------------- .../ElemshapeData_Lagrange@Methods.F90 | 132 +++++++++++------- 3 files changed, 84 insertions(+), 161 deletions(-) delete mode 100644 src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt index 8937f2d22..742055dca 100644 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -25,7 +25,6 @@ target_sources( ${src_path}/Lagrange/ElemshapeData_Lagrange@Methods.F90 ${src_path}/H1/ElemshapeData_H1Methods@HermitMethods.F90 ${src_path}/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 ${src_path}/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 ${src_path}/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 ${src_path}/DG/ElemshapeData_DGMethods@HermitMethods.F90 diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 deleted file mode 100644 index 7b0f7a94b..000000000 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 +++ /dev/null @@ -1,112 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_H1Methods) LagrangeMethods -USE InputUtility, ONLY: Input - -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate - -USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE - -USE LagrangePolynomialUtility, ONLY: LagrangeDOF, & - InterpolationPoint, & - LagrangeEvalAll, & - LagrangeGradientEvalAll - -USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & - QuadraturePoint_Size => Size - -USE BaseType, ONLY: TypeQuadratureOpt, & - TypePolynomialOpt - -USE SwapUtility, ONLY: SWAP - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE H1_Lagrange1 -REAL(DFP), ALLOCATABLE :: pt(:, :), xij(:, :), dNdXi(:, :, :), coeff0(:, :) -INTEGER(I4B) :: nsd, xidim, ipType0, basisType0, tsize, nns - -ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType) -basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType) - -! CALL DEALLOCATE (obj) -CALL Refelem_Initiate(obj%refelem, refelem) - -nsd = refelem%nsd - -xidim = refelem%xiDimension - -CALL GetQuadraturePoints(obj=quad, points=pt, weights=obj%ws) - -obj%quad = quad - -tsize = QuadraturePoint_Size(quad, 2) - -nns = LagrangeDOF(order=order, elemType=refelem%name) -CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=tsize) - -xij = InterpolationPoint(order=order, elemType=refelem%name, ipType=ipType0, & - layout="VEFC", xij=refelem%xij(1:xidim, :), alpha=alpha, beta=beta, & - lambda=lambda) - -ALLOCATE (coeff0(SIZE(xij, 2), SIZE(xij, 2))) - -IF (PRESENT(coeff)) THEN - - obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=refelem%name, & - x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff, firstCall=firstCall)) - - dNdXi = LagrangeGradientEvalAll(order=order, elemType=refelem%name, & - x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff, firstCall=.FALSE.) - - CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) - -ELSE - - obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=refelem%name, & - x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff0, firstCall=.TRUE.)) - - dNdXi = LagrangeGradientEvalAll(order=order, elemType=refelem%name, & - x=pt(1:xidim, :), xij=xij, domainName=refelem%domainName, & - basisType=basisType0, alpha=alpha, beta=beta, & - lambda=lambda, coeff=coeff0, firstCall=.FALSE.) - - CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) - -END IF - -IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) -IF (ALLOCATED(xij)) DEALLOCATE (xij) -IF (ALLOCATED(pt)) DEALLOCATE (pt) -IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0) - -END PROCEDURE H1_Lagrange1 - -END SUBMODULE LagrangeMethods diff --git a/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 index 8e7929c45..83c0c67be 100644 --- a/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 @@ -25,7 +25,8 @@ USE LagrangePolynomialUtility, ONLY: LagrangeDOF, & InterpolationPoint_, & LagrangeEvalAll, & - LagrangeGradientEvalAll + LagrangeEvalAll_, & + LagrangeGradientEvalAll_ USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & QuadraturePoint_Size => Size @@ -33,7 +34,7 @@ USE BaseType, ONLY: TypeQuadratureOpt, & TypePolynomialOpt -USE SwapUtility, ONLY: SWAP +USE SwapUtility, ONLY: SWAP_ USE Display_Method, ONLY: Display @@ -45,77 +46,112 @@ ! ElemshapeData_InitiateLagrange !---------------------------------------------------------------------------- -MODULE PROCEDURE ElemshapeData_InitiateLagrange1 -REAL(DFP), ALLOCATABLE :: xij(:, :), dNdXi(:, :, :), coeff0(:, :) -INTEGER(I4B) :: ipType0, basisType0, tsize, nns, nrow, ncol +MODULE PROCEDURE LagrangeElemShapeData1 +REAL(DFP), ALLOCATABLE :: xij(:, :), coeff0(:, :), temp(:, :, :) +INTEGER(I4B) :: ipType0, basisType0, nips, nns, indx(10) ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType) basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType) ! CALL DEALLOCATE (obj) -tsize = SIZE(quad%points, 2) -! pt = quad%points(1:obj%txi, 1:tsize) -! wt = quad%points(obj%txi + 1, 1:tsize) +nips = SIZE(quad%points, 2) +! pt = quad%points(1:quad%txi, 1:nips) +! wt = quad%points(quad%txi + 1, 1:nips) nns = LagrangeDOF(order=order, elemType=elemType) -CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=tsize) +CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) -obj%ws = quad%points(quad%txi + 1, 1:tsize) +obj%ws = quad%points(quad%txi + 1, 1:nips) -ncol = LagrangeDOF(order=order, elemType=elemType) -ALLOCATE (xij(3, ncol)) +ALLOCATE (xij(3, nns), temp(nips, nns, 3)) CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType0, & layout="VEFC", xij=refelemCoord(1:xidim, :), alpha=alpha, beta=beta, & - lambda=lambda, ans=xij, nrow=nrow, ncol=ncol) + lambda=lambda, ans=xij, nrow=indx(1), ncol=indx(2)) IF (PRESENT(coeff)) THEN - obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, & - x=quad%points(1:quad%txi, 1:tsize), & - xij=xij(1:xidim, :), & - domainName=refelemDomain, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff, firstCall=firstCall)) - - dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, & - x=quad%points(1:quad%txi, 1:tsize), & - xij=xij(1:xidim, :), & - domainName=refelemDomain, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff, firstCall=.FALSE.) + CALL LagrangeEvalAll_(order=order, & + elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff, firstCall=firstCall, & + ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2)) + + obj%N(1:nns, 1:nips) = TRANSPOSE(temp(1:nips, 1:nns, 1)) + + CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff, firstCall=.FALSE., & + ans=temp, & + dim1=indx(1), dim2=indx(2), dim3=indx(3)) ELSE - ALLOCATE (coeff0(SIZE(xij, 2), SIZE(xij, 2))) - - obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, & - x=quad%points(1:quad%txi, 1:tsize), & - xij=xij(1:xidim, :), & - domainName=refelemDomain, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff0, firstCall=.TRUE.)) - - dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, & - x=quad%points(1:quad%txi, 1:tsize), & - xij=xij(1:xidim, :), & - domainName=refelemDomain, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff0, firstCall=.FALSE.) + ALLOCATE (coeff0(nns, nns)) + + ! obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, & + CALL LagrangeEvalAll_(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff0, firstCall=.TRUE., & + ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2)) + + obj%N(1:nns, 1:nips) = TRANSPOSE(temp(1:nips, 1:nns, 1)) + + ! dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, & + CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=refelemDomain, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff0, firstCall=.FALSE., & + ans=temp, & + dim1=indx(1), dim2=indx(2), dim3=indx(3)) END IF -CALL SWAP(a=obj%dNdXi, b=dNdXi, i1=2, i2=3, i3=1) +CALL SWAP_(a=obj%dNdXi, b=temp(1:indx(1), 1:indx(2), 1:indx(3)), i1=2, & + i2=3, i3=1) -IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi) +IF (ALLOCATED(temp)) DEALLOCATE (temp) IF (ALLOCATED(xij)) DEALLOCATE (xij) IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0) -END PROCEDURE ElemshapeData_InitiateLagrange1 +END PROCEDURE LagrangeElemShapeData1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeElemShapeData2 +CALL LagrangeElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & + xidim=refelem%xidimension, elemType=refelem%name, & + refelemCoord=refelem%xij, refelemDomain=refelem%domainName, order=order, & + ipType=ipType, basisType=basisType, coeff=coeff, firstCall=firstCall, & + alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE LagrangeElemShapeData2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeElemShapeData3 +CALL LagrangeElemShapeData2(obj=obj, quad=quad, refelem=refelem, & + order=order, ipType=ipType, basisType=basisType, coeff=coeff, & + firstCall=firstCall, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE LagrangeElemShapeData3 END SUBMODULE Methods From 347168d22349a56424bb0a06d31b399a0f58660a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:57:18 +0900 Subject: [PATCH 146/359] updates in hexahedron --- ...HexahedronInterpolationUtility@Methods.F90 | 102 ++++++++++-------- 1 file changed, 56 insertions(+), 46 deletions(-) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index ee65c98cd..b978f198f 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -273,90 +273,100 @@ END PROCEDURE LagrangeInDOF_Hexahedron2 !---------------------------------------------------------------------------- -! EquidistancePoint_Hexahedron +! !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Hexahedron1 -ans = EquidistancePoint_Hexahedron2(p=order, q=order, r=order, xij=xij) +INTEGER(I4B) :: nrow, ncol +nrow = 3 +ncol = LagrangeDOF_Hexahedron(order=order) +ALLOCATE (ans(nrow, ncol)) +CALL EquidistancePoint_Hexahedron1_(order=order, ans=ans, nrow=nrow, & + ncol=ncol, xij=xij) END PROCEDURE EquidistancePoint_Hexahedron1 !---------------------------------------------------------------------------- -! EquidistancePoint_Hexahedron +! EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Hexahedron1_ +CALL EquidistancePoint_Hexahedron2_(p=order, q=order, r=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE EquidistancePoint_Hexahedron1_ + +!---------------------------------------------------------------------------- +! !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Hexahedron2 +INTEGER(I4B) :: nrow, ncol +nrow = 3 +ncol = LagrangeDOF_Hexahedron(p=p, q=q, r=r) +ALLOCATE (ans(nrow, ncol)) +CALL EquidistancePoint_Hexahedron2_(p=p, q=q, r=r, ans=ans, nrow=nrow, & + ncol=ncol, xij=xij) +END PROCEDURE EquidistancePoint_Hexahedron2 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Hexahedron2_ ! internal variables REAL(DFP) :: x(p + 1), y(q + 1), z(r + 1), temp0 REAL(DFP), DIMENSION(p + 1, q + 1, r + 1) :: xi, eta, zeta REAL(DFP) :: temp(3, (p + 1) * (q + 1) * (r + 1)) INTEGER(I4B) :: ii, jj, kk, nsd +nrow = 3 +ncol = LagrangeDOF_Hexahedron(p=p, q=q, r=r) + x = EquidistancePoint_Line(order=p, xij=[-1.0_DFP, 1.0_DFP]) y = EquidistancePoint_Line(order=q, xij=[-1.0_DFP, 1.0_DFP]) z = EquidistancePoint_Line(order=r, xij=[-1.0_DFP, 1.0_DFP]) -IF (p .GT. 0_I4B) THEN - temp0 = x(2) -END IF -DO ii = 2, p + +IF (p .GT. 0_I4B) temp0 = x(2) +DO CONCURRENT(ii=2:p) x(ii) = x(ii + 1) END DO x(p + 1) = temp0 -IF (q .GT. 0_I4B) THEN - temp0 = y(2) -END IF -DO ii = 2, q +IF (q .GT. 0_I4B) temp0 = y(2) +DO CONCURRENT(ii=2:q) y(ii) = y(ii + 1) END DO y(q + 1) = temp0 -IF (r .GT. 0_I4B) THEN - temp0 = z(2) -END IF -DO ii = 2, r +IF (r .GT. 0_I4B) temp0 = z(2) +DO CONCURRENT(ii=2:r) z(ii) = z(ii + 1) END DO z(r + 1) = temp0 -nsd = 3 -CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1)) +! nsd = 3 +! CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1)) -DO ii = 1, p + 1 - DO jj = 1, q + 1 - DO kk = 1, r + 1 - xi(ii, jj, kk) = x(ii) - eta(ii, jj, kk) = y(jj) - zeta(ii, jj, kk) = z(kk) - END DO - END DO +DO CONCURRENT(ii=1:p + 1, jj=1:q + 1, kk=1:r + 1) + xi(ii, jj, kk) = x(ii) + eta(ii, jj, kk) = y(jj) + zeta(ii, jj, kk) = z(kk) END DO -CALL IJK2VEFC_Hexahedron( & - & xi=xi, & - & eta=eta, & - & zeta=zeta, & - & temp=temp, & - & p=p, & - & q=q, & - & r=r) +CALL IJK2VEFC_Hexahedron(xi=xi, eta=eta, zeta=zeta, temp=temp, p=p, q=q, r=r) IF (PRESENT(xij)) THEN - ans = FromBiUnitHexahedron2Hexahedron( & - & xin=temp, & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8) & - & ) + + ans(1:nrow, 1:ncol) = FromBiUnitHexahedron2Hexahedron(xin=temp, & + x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), & + x5=xij(:, 5), x6=xij(:, 6), x7=xij(:, 7), x8=xij(:, 8)) + ELSE - ans = temp + + ans(1:nrow, 1:ncol) = temp + END IF -END PROCEDURE EquidistancePoint_Hexahedron2 +END PROCEDURE EquidistancePoint_Hexahedron2_ !---------------------------------------------------------------------------- ! EquidistanceInPoint_Hexahedron From 362509f6ab03667053510d6a130fc822c7850a09 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:57:28 +0900 Subject: [PATCH 147/359] updates in lagrange polynomial --- .../src/LagrangePolynomialUtility@Methods.F90 | 83 +++++++++++++++---- 1 file changed, 67 insertions(+), 16 deletions(-) diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index db114f510..7c6523c1e 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -27,6 +27,7 @@ LagrangeInDOF_Line, & LagrangeDegree_Line, & EquidistancePoint_Line, & + EquidistancePoint_Line_, & InterpolationPoint_Line, & InterpolationPoint_Line_, & LagrangeCoeff_Line, & @@ -38,6 +39,7 @@ LagrangeInDOF_Triangle, & LagrangeDegree_Triangle, & EquidistancePoint_Triangle, & + EquidistancePoint_Triangle_, & InterpolationPoint_Triangle, & InterpolationPoint_Triangle_, & LagrangeCoeff_Triangle, & @@ -49,6 +51,7 @@ LagrangeInDOF_Quadrangle, & LagrangeDegree_Quadrangle, & EquidistancePoint_Quadrangle, & + EquidistancePoint_Quadrangle_, & InterpolationPoint_Quadrangle, & InterpolationPoint_Quadrangle_, & LagrangeCoeff_Quadrangle, & @@ -60,6 +63,7 @@ LagrangeInDOF_Tetrahedron, & LagrangeDegree_Tetrahedron, & EquidistancePoint_Tetrahedron, & + EquidistancePoint_Tetrahedron_, & InterpolationPoint_Tetrahedron, & InterpolationPoint_Tetrahedron_, & LagrangeCoeff_Tetrahedron, & @@ -71,6 +75,7 @@ LagrangeInDOF_Hexahedron, & LagrangeDegree_Hexahedron, & EquidistancePoint_Hexahedron, & + EquidistancePoint_Hexahedron_, & InterpolationPoint_Hexahedron, & InterpolationPoint_Hexahedron_, & LagrangeCoeff_Hexahedron, & @@ -82,6 +87,7 @@ LagrangeInDOF_Prism, & LagrangeDegree_Prism, & EquidistancePoint_Prism, & + EquidistancePoint_Prism_, & InterpolationPoint_Prism, & InterpolationPoint_Prism_, & LagrangeCoeff_Prism, & @@ -93,6 +99,7 @@ LagrangeInDOF_Pyramid, & LagrangeDegree_Pyramid, & EquidistancePoint_Pyramid, & + EquidistancePoint_Pyramid_, & InterpolationPoint_Pyramid, & InterpolationPoint_Pyramid_, & LagrangeCoeff_Pyramid, & @@ -250,49 +257,93 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = XiDimension(elemType) +END IF + +ncol = LagrangeDOF(order=order, elemType=elemType) + +ALLOCATE (ans(nrow, ncol)) + +CALL EquidistancePoint_(order=order, elemType=elemType, ans=ans, nrow=nrow, & + ncol=ncol, xij=xij) + +END PROCEDURE EquidistancePoint + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_ INTEGER(I4B) :: topo topo = ElementTopology(elemType) +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = XiDimension(topo) +END IF + +ncol = LagrangeDOF(order=order, elemType=elemType) + SELECT CASE (topo) CASE (Point) + IF (PRESENT(xij)) THEN - ans = xij + ncol = 1 + ans(1:nrow, 1) = xij(1:nrow, 1) ELSE - ALLOCATE (ans(0, 0)) + nrow = 0 + ncol = 0 + ! ALLOCATE (ans(0, 0)) END IF CASE (Line) - ans = EquidistancePoint_Line(order=order, xij=xij) + ! ans(1:nrow, 1:ncol) = EquidistancePoint_Line(order=order, xij=xij) + CALL EquidistancePoint_Line_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) CASE (Triangle) - ans = EquidistancePoint_Triangle(order=order, xij=xij) + ! ans(1:nrow, 1:ncol) = EquidistancePoint_Triangle(order=order, xij=xij) + CALL EquidistancePoint_Triangle_(order=order, xij=xij, nrow=nrow, & + ncol=ncol, ans=ans) CASE (Quadrangle) - ans = EquidistancePoint_Quadrangle(order=order, xij=xij) + ! ans(1:nrow, 1:ncol) = EquidistancePoint_Quadrangle(order=order, xij=xij) + CALL EquidistancePoint_Quadrangle_(order=order, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) CASE (Tetrahedron) - ans = EquidistancePoint_Tetrahedron(order=order, xij=xij) + ! ans(1:nrow, 1:ncol) = EquidistancePoint_Tetrahedron(order=order, xij=xij) + CALL EquidistancePoint_Tetrahedron_(order=order, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) CASE (Hexahedron) - ans = EquidistancePoint_Hexahedron(order=order, xij=xij) + CALL EquidistancePoint_Hexahedron_(order=order, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) CASE (Prism) - ans = EquidistancePoint_Prism(order=order, xij=xij) + CALL EquidistancePoint_Prism_(order=order, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) CASE (Pyramid) - ans = EquidistancePoint_Pyramid(order=order, xij=xij) + CALL EquidistancePoint_Pyramid_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) CASE DEFAULT - CALL Errormsg(& - & msg="No CASE FOUND: elemType="//ToString(elemType), & - & unitno=stdout, & - & line=__LINE__, & - & routine="EquidistancePoint()", & - & file=__FILE__) + CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), & + routine="EquidistancePoint()", & + unitno=stdout, line=__LINE__, file=__FILE__) + RETURN END SELECT -END PROCEDURE EquidistancePoint + +END PROCEDURE EquidistancePoint_ !---------------------------------------------------------------------------- ! InterpolationPoint From 93585cf645c77238969797b02494e9915fbb0ac3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:57:37 +0900 Subject: [PATCH 148/359] update in prism interpolation --- .../src/PrismInterpolationUtility@Methods.F90 | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 index d9b30b5ef..921320e47 100644 --- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 @@ -102,6 +102,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Prism +INTEGER(I4B) :: nrow, ncol +nrow = 3 +ncol = LagrangeDOF_Prism(order=order) +ALLOCATE (ans(nrow, ncol)) +CALL EquidistancePoint_Prism_(order=order, ans=ans, nrow=nrow, ncol=ncol, & + xij=xij) +END PROCEDURE EquidistancePoint_Prism + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Prism_ ! nodecoord( :, 1 ) = [0,0,-1] ! nodecoord( :, 2 ) = [1,0,-1] ! nodecoord( :, 3 ) = [0,1,-1] @@ -109,7 +122,9 @@ ! nodecoord( :, 5 ) = [1,0,1] ! nodecoord( :, 6 ) = [0,1,1] !ISSUE: #160 Implement EquidistancePoint_Prism routine -END PROCEDURE EquidistancePoint_Prism +nrow = 3 +ncol = LagrangeDOF_Prism(order=order) +END PROCEDURE EquidistancePoint_Prism_ !---------------------------------------------------------------------------- ! EquidistanceInPoint_Prism From 198d7f370b7d8846daab485cc717dbcdf298f0e1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:57:45 +0900 Subject: [PATCH 149/359] update in pyramid interpolation --- .../PyramidInterpolationUtility@Methods.F90 | 31 ++++++++++++------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 index 2e2f801ac..93585e06e 100644 --- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 @@ -53,12 +53,9 @@ MODULE PROCEDURE RefElemDomain_Pyramid !FIX: Implement RefElemDomain -CALL Errormsg(& - & msg="[WORK IN PROGRESS] We are working on it", & - & file=__FILE__, & - & line=__LINE__,& - & routine="RefElemDomain_Pyramid()", & - & unitno=stderr) +CALL Errormsg(msg="[WORK IN PROGRESS] We are working on it", & + routine="RefElemDomain_Pyramid()", & + file=__FILE__, line=__LINE__, unitno=stderr) END PROCEDURE RefElemDomain_Pyramid !---------------------------------------------------------------------------- @@ -102,18 +99,31 @@ END PROCEDURE GetTotalInDOF_Pyramid !---------------------------------------------------------------------------- -! EquidistancePoint_Pyramid +! EquidistancePoint_Prism !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Pyramid -!FIX: Implement EquidistancePoint_Pyramid -!ISSUE: #161 Implement EquidistancePoint_Pyramid routine +INTEGER(I4B) :: nrow, ncol +nrow = 3 +ncol = LagrangeDOF_Pyramid(order=order) +ALLOCATE (ans(nrow, ncol)) +CALL EquidistancePoint_Pyramid_(order=order, ans=ans, nrow=nrow, ncol=ncol, & + xij=xij) +END PROCEDURE EquidistancePoint_Pyramid + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Pyramid_ +nrow = 3 +ncol = LagrangeDOF_Pyramid(order=order) ! nodecoord(:, 1) = [-1, -1, 0] ! nodecoord(:, 2) = [1, -1, 0] ! nodecoord(:, 3) = [1, 1, 0] ! nodecoord(:, 4) = [-1, 1, 0] ! nodecoord(:, 5) = [0, 0, 1] -END PROCEDURE EquidistancePoint_Pyramid +END PROCEDURE EquidistancePoint_Pyramid_ !---------------------------------------------------------------------------- ! EquidistanceInPoint_Pyramid @@ -122,7 +132,6 @@ MODULE PROCEDURE EquidistanceInPoint_Pyramid ! FIX: Implement EquidistanceInPoint_Pyramid ! ISSUE: #161 Implement EquidistanceInPoint_Pyramid routine - END PROCEDURE EquidistanceInPoint_Pyramid !---------------------------------------------------------------------------- From db931bd9b63ed702aab8a9aea1e512454f6a9be3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:57:52 +0900 Subject: [PATCH 150/359] update in quadrangle interpolation --- ...QuadrangleInterpolationUtility@Methods.F90 | 33 ++++++++++--------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 8a2b3b3e3..9c3b35b73 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -198,11 +198,13 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Quadrangle1_ -INTEGER(I4B) :: ne, i1, i2, indx(3) +INTEGER(I4B) :: ne, indx(3) REAL(DFP) :: x(3, 5), xin(3, 4), e1(3), e2(3), lam, avar, mu x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP +ncol = 0 + IF (PRESENT(xij)) THEN nrow = SIZE(xij, 1) x(1:nrow, 1:4) = xij(1:nrow, 1:4) @@ -220,36 +222,36 @@ x(:, 5) = x(:, 1) !! cycic effect -ncol = LagrangeDOF_Quadrangle(order=order) +! ncol = LagrangeDOF_Quadrangle(order=order) ! points on vertex ans(1:nrow, 1:4) = x(1:nrow, 1:4) +ncol = 4 IF (order .EQ. 1_I4B) RETURN ! points on edge ne = LagrangeInDOF_Line(order=order) -i2 = 4 -i1 = i2 + 1; i2 = i1 + ne - 1 CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 1:2), & - ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) +ncol = ncol + indx(2) -i1 = i2 + 1; i2 = i1 + ne - 1 CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 2:3), & - ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) +ncol = ncol + indx(2) -i1 = i2 + 1; i2 = i1 + ne - 1 CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 3:4), & - ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) +ncol = ncol + indx(2) -i1 = i2 + 1; i2 = i1 + ne - 1 CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 4:5), & - ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) +ncol = ncol + indx(2) IF (order .EQ. 2_I4B) THEN - i1 = i2 + 1 - ans(1:nrow, i1) = SUM(x(1:nrow, 1:4), dim=2_I4B) / 4.0_DFP + ans(1:nrow, ncol + 1) = SUM(x(1:nrow, 1:4), dim=2_I4B) / 4.0_DFP + ncol = ncol + 1 RETURN END IF @@ -296,10 +298,11 @@ mu = avar / order xin(1:nrow, 4) = x(1:nrow, 4) + lam * e1(1:nrow) + mu * e2(1:nrow) -i1 = i2 + 1 ! ans(1:nsd, i1:) = EquidistancePoint_Quadrangle( & CALL EquidistancePoint_Quadrangle_(order=order - 2, xij=xin(1:nrow, 1:4), & - ans=ans(:, i1:), nrow=indx(1), ncol=indx(2)) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) + +ncol = ncol + indx(2) END PROCEDURE EquidistancePoint_Quadrangle1_ From 91f002d97bbde3c8f0a2b210a3a3d49965a2c210 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 14:58:01 +0900 Subject: [PATCH 151/359] update in elemshape data --- .../src/ElemshapeData_H1Methods.F90 | 37 +------ .../src/ElemshapeData_Lagrange.F90 | 97 ++++++++++++++++--- .../src/ElemshapeData_Method.F90 | 1 + 3 files changed, 87 insertions(+), 48 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 index 6e42b9047..185537cb6 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 @@ -26,43 +26,12 @@ MODULE ElemshapeData_H1Methods SerendipityInterpolation_ USE GlobalData, ONLY: I4B, DFP, LGT -IMPLICIT NONE -PRIVATE -PUBLIC :: Initiate -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- +IMPLICIT NONE -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-16 -! summary: This routine initiate the shape data +PRIVATE -INTERFACE Initiate - MODULE SUBROUTINE H1_Lagrange1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, coeff, firstCall, & - alpha, beta, lambda) - CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad - CLASS(ReferenceElement_), INTENT(IN) :: refelem - CLASS(H1_), INTENT(IN) :: baseContinuity - CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType - !! Interpolation point type - !! Default value is Equidistance - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Basis function types - !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - END SUBROUTINE H1_Lagrange1 -END INTERFACE Initiate +PUBLIC :: Initiate !---------------------------------------------------------------------------- ! Initiate@H1Hierarchy diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 index 1a9ac69a8..0c6f4021f 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 @@ -19,11 +19,7 @@ MODULE ElemshapeData_Lagrange QuadraturePoint_, & ReferenceElement_, & H1_, & - LagrangeInterpolation_, & - HierarchyInterpolation_, & - OrthogonalInterpolation_, & - HermitInterpolation_, & - SerendipityInterpolation_ + LagrangeInterpolation_ USE GlobalData, ONLY: I4B, DFP, LGT @@ -31,7 +27,8 @@ MODULE ElemshapeData_Lagrange PRIVATE -PUBLIC :: ElemshapeData_InitiateLagrange +PUBLIC :: LagrangeElemShapeData +PUBLIC :: Initiate !---------------------------------------------------------------------------- ! Initiate@Methods @@ -41,20 +38,88 @@ MODULE ElemshapeData_Lagrange ! date: 2023-08-16 ! summary: This routine initiate the shape data -INTERFACE ElemshapeData_InitiateLagrange - MODULE SUBROUTINE ElemshapeData_InitiateLagrange1(obj, quad, nsd, xidim, & - elemType, refelemCoord, refelemDomain, baseContinuity, & - baseInterpolation, order, ipType, basisType, & +INTERFACE LagrangeElemShapeData + MODULE SUBROUTINE LagrangeElemShapeData1(obj, quad, nsd, xidim, & + elemType, refelemCoord, refelemDomain, order, ipType, basisType, & coeff, firstCall, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! element shape data TYPE(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point INTEGER(I4B), INTENT(IN) :: nsd + !! number of spatial dimension INTEGER(I4B), INTENT(IN) :: xidim + !! dimension of xi INTEGER(I4B), INTENT(IN) :: elemType + !! element type REAL(DFP), INTENT(IN) :: refelemCoord(:, :) + !! coordinate of reference element CHARACTER(*), INTENT(IN) :: refelemDomain - CHARACTER(*), INTENT(IN) :: baseContinuity - CHARACTER(*), INTENT(IN) :: baseInterpolation + !! 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, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is false, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Jacobi parameter and Ultra-spherical parameter + END SUBROUTINE LagrangeElemShapeData1 +END INTERFACE LagrangeElemShapeData + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE LagrangeElemShapeData + MODULE SUBROUTINE LagrangeElemShapeData2(obj, quad, refelem, order, & + ipType, basisType, coeff, firstCall, alpha, beta, lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + TYPE(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation point type + !! Default value is Equidistance + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function types + !! Default value is Monomial + REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE LagrangeElemShapeData2 +END INTERFACE LagrangeElemShapeData + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE LagrangeElemShapeData +MODULE SUBROUTINE LagrangeElemShapeData3(obj, quad, refelem, baseContinuity, & + baseInterpolation, order, ipType, basisType, coeff, firstCall, & + alpha, beta, lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + CLASS(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + CLASS(H1_), INTENT(IN) :: baseContinuity + CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType !! Interpolation point type @@ -69,7 +134,11 @@ MODULE SUBROUTINE ElemshapeData_InitiateLagrange1(obj, quad, nsd, xidim, & !! If firstCall is False, then coeff will be used !! Default value of firstCall is True REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda - END SUBROUTINE ElemshapeData_InitiateLagrange1 -END INTERFACE ElemshapeData_InitiateLagrange + END SUBROUTINE LagrangeElemShapeData3 +END INTERFACE LagrangeElemShapeData + +INTERFACE Initiate + MODULE PROCEDURE LagrangeElemShapeData3 +END INTERFACE Initiate END MODULE ElemshapeData_Lagrange diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 index 1df4c3ff0..2528abbc8 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -21,6 +21,7 @@ MODULE ElemshapeData_Method USE ElemshapeData_GetMethods USE ElemshapeData_GradientMethods USE ElemshapeData_H1Methods +USE ElemshapeData_Lagrange USE ElemshapeData_HCurlMethods USE ElemshapeData_HDivMethods USE ElemshapeData_HRGNParamMethods From c7386915d7f8184233ad6da3a8aaaba65bafa577 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Jul 2024 18:12:57 +0900 Subject: [PATCH 152/359] updates in mapping uitl --- src/modules/Utility/src/MappingUtility.F90 | 19 +++++++++++++++++++ .../Utility/src/MappingUtility@Methods.F90 | 12 +++++++++++- 2 files changed, 30 insertions(+), 1 deletion(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index d961eae5c..e5792e2d9 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -30,6 +30,7 @@ MODULE MappingUtility PUBLIC :: FromBiunitLine2Segment_ PUBLIC :: FromBiUnitLine2UnitLine PUBLIC :: FromUnitLine2BiUnitLine +PUBLIC :: FromUnitLine2BiUnitLine_ PUBLIC :: FromLine2Line_ PUBLIC :: FromBiUnitQuadrangle2Quadrangle @@ -456,6 +457,24 @@ MODULE PURE FUNCTION FromUnitLine2BiUnitLine(xin) RESULT(ans) END FUNCTION FromUnitLine2BiUnitLine END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-03 +! summary: from unit line to bi unit line without allocation + +INTERFACE + MODULE PURE SUBROUTINE FromUnitLine2BiUnitLine_(xin, ans, tsize) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in unit line + REAL(DFP), INTENT(INOUT) :: ans(:) + !! mapped coordinates of xin in biunit line + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE FromUnitLine2BiUnitLine_ +END INTERFACE + !---------------------------------------------------------------------------- ! FromLine2Line_ !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index 7a478de7a..9eb9db023 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -84,9 +84,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromUnitLine2BiUnitLine -ans = 2.0_DFP * xin - 1.0_DFP +INTEGER(I4B) :: tsize +CALL FromUnitLine2BiUnitLine_(xin=xin, ans=ans, tsize=tsize) END PROCEDURE FromUnitLine2BiUnitLine +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitLine2BiUnitLine_ +tsize = SIZE(xin) +ans(1:tsize) = 2.0_DFP * xin(1:tsize) - 1.0_DFP +END PROCEDURE FromUnitLine2BiUnitLine_ + !---------------------------------------------------------------------------- ! FromLine2Line !---------------------------------------------------------------------------- From faf219bd5f0fcfa852c703cacb078c8f8bf7cbd0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:10:55 +0900 Subject: [PATCH 153/359] updates in hexahedron interpolation --- .../src/HexahedronInterpolationUtility.F90 | 146 ++++++++++++++++-- 1 file changed, 134 insertions(+), 12 deletions(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index 012eb03c6..6856fd2cb 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -46,6 +46,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: FacetBasis_Hexahedron PUBLIC :: CellBasis_Hexahedron PUBLIC :: HeirarchicalBasis_Hexahedron +PUBLIC :: HeirarchicalBasis_Hexahedron_ PUBLIC :: QuadraturePoint_Hexahedron PUBLIC :: LagrangeEvalAll_Hexahedron PUBLIC :: LagrangeEvalAll_Hexahedron_ @@ -59,6 +60,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: OrthogonalBasisGradient_Hexahedron PUBLIC :: TensorProdBasisGradient_Hexahedron PUBLIC :: HeirarchicalBasisGradient_Hexahedron +PUBLIC :: HeirarchicalBasisGradient_Hexahedron_ PUBLIC :: GetTotalDOF_Hexahedron PUBLIC :: GetTotalInDOF_Hexahedron @@ -2264,15 +2266,9 @@ END FUNCTION CellBasisGradient_Hexahedron2 ! summary: Returns the HeirarchicalBasis on Hexahedron INTERFACE HeirarchicalBasis_Hexahedron - MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1( & - & pb1, pb2, pb3, & - & pxy1, pxy2, & - & pxz1, pxz2, & - & pyz1, pyz2, & - & px1, px2, px3, px4, & - & py1, py2, py3, py4, & - & pz1, pz2, pz3, pz4, & - & xij) RESULT(ans) + MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1(pb1, pb2, pb3, pxy1, & + pxy2, pxz1, pxz2, pyz1, pyz2, px1, px2, px3, px4, py1, py2, py3, py4, & + pz1, pz2, pz3, pz4, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3 !! order of interpolation inside the element in x, y, and z dirs INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 @@ -2304,6 +2300,44 @@ MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1( & END FUNCTION HeirarchicalBasis_Hexahedron1 END INTERFACE HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Hexahedron_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Hexahedron1_(pb1, pb2, pb3, pxy1, & + pxy2, pxz1, pxz2, pyz1, pyz2, px1, px2, px3, px4, py1, py2, py3, py4, & + pz1, pz2, pz3, pz4, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3 + !! order of interpolation inside the element in x, y, and z dirs + INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 + !! order of interpolation on facets parallel to xy plane + INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 + !! order of interpolation on facets parallel to xz plane + INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 + !! order of interpolation on facets parallel to yz plane + INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 + !! order of interpolation on edges parallel to x-axis + INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 + !! order of interpolation on edges parallel to y-axis + INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 + !! order of interpolation on edges parallel to z-axis + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xij, 2) + !! ncol = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & + !! + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & + !! + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & + !! + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & + !! + (px1 + px2 + px3 + px4 - 4_I4B) & + !! + (py1 + py2 + py3 + py4 - 4_I4B) & + !! + (pz1 + pz2 + pz3 + pz4 - 4_I4B) & + END SUBROUTINE HeirarchicalBasis_Hexahedron1_ +END INTERFACE HeirarchicalBasis_Hexahedron_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Hexahedron !---------------------------------------------------------------------------- @@ -2313,9 +2347,7 @@ END FUNCTION HeirarchicalBasis_Hexahedron1 ! summary: Returns the HeirarchicalBasis on Hexahedron INTERFACE HeirarchicalBasis_Hexahedron - MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2( & - & p, q, r, & - & xij) RESULT(ans) + MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2(p, q, r, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p, q, r !! order of interpolation in x, y, and z dirs REAL(DFP), INTENT(IN) :: xij(:, :) @@ -2335,6 +2367,31 @@ MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2( & END FUNCTION HeirarchicalBasis_Hexahedron2 END INTERFACE HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Hexahedron_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Hexahedron2_(p, q, r, xij, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! order of interpolation in x, y, and z dirs + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xij, 2) + !! ncol = 8_I4B + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) & + !! + (p - 1_I4B) * (q - 1_I4B) * 2_I4B & + !! + (p - 1_I4B) * (r - 1_I4B) * 2_I4B & + !! + (q - 1_I4B) * (r - 1_I4B) * 2_I4B & + !! + (4_I4B * p - 4_I4B) & + !! + (4_I4B * q - 4_I4B) & + !! + (4_I4B * r - 4_I4B) & + END SUBROUTINE HeirarchicalBasis_Hexahedron2_ +END INTERFACE HeirarchicalBasis_Hexahedron_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Hexahedron !---------------------------------------------------------------------------- @@ -2956,6 +3013,45 @@ MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron1( & END FUNCTION HeirarchicalBasisGradient_Hexahedron1 END INTERFACE HeirarchicalBasisGradient_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Hexahedron_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Hexahedron1_(pb1, pb2, pb3, & + pxy1, pxy2, pxz1, pxz2, pyz1, pyz2, px1, px2, px3, px4, py1, py2, py3, & + py4, pz1, pz2, pz3, pz4, xij, ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3 + !! order of interpolation inside the element in x, y, and z dirs + INTEGER(I4B), INTENT(IN) :: pxy1, pxy2 + !! order of interpolation on facets parallel to xy plane + INTEGER(I4B), INTENT(IN) :: pxz1, pxz2 + !! order of interpolation on facets parallel to xz plane + INTEGER(I4B), INTENT(IN) :: pyz1, pyz2 + !! order of interpolation on facets parallel to yz plane + INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4 + !! order of interpolation on edges parallel to x-axis + INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4 + !! order of interpolation on edges parallel to y-axis + INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4 + !! order of interpolation on edges parallel to z-axis + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(xij, 2) + !! dim2 = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & + !! & + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & + !! & + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & + !! & + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & + !! & + (px1 + px2 + px3 + px4 - 4_I4B) & + !! & + (py1 + py2 + py3 + py4 - 4_I4B) & + !! & + (pz1 + pz2 + pz3 + pz4 - 4_I4B) + !! dim3 = 3_I4B + END SUBROUTINE HeirarchicalBasisGradient_Hexahedron1_ +END INTERFACE HeirarchicalBasisGradient_Hexahedron_ + !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Hexahedron !---------------------------------------------------------------------------- @@ -2986,4 +3082,30 @@ MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron2( & END FUNCTION HeirarchicalBasisGradient_Hexahedron2 END INTERFACE HeirarchicalBasisGradient_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Hexahedron_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Hexahedron2_(p, q, r, xij, & + ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! order of interpolation in x, y, and z dirs + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + ! + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(xij, 2) + !! dim2 = 8_I4B + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) & + !! + (p - 1_I4B) * (q - 1_I4B) * 2_I4B & + !! + (p - 1_I4B) * (r - 1_I4B) * 2_I4B & + !! + (q - 1_I4B) * (r - 1_I4B) * 2_I4B & + !! + (4_I4B * p - 4_I4B) & + !! + (4_I4B * q - 4_I4B) & + !! + (4_I4B * r - 4_I4B) + !! dim3 = 3_I4B + END SUBROUTINE HeirarchicalBasisGradient_Hexahedron2_ +END INTERFACE HeirarchicalBasisGradient_Hexahedron_ + END MODULE HexahedronInterpolationUtility From 945368f0e4a8e0195903f97e296e0f18c0f0afb8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:11:08 +0900 Subject: [PATCH 154/359] updates in hierarchical polynomails --- .../src/HierarchicalPolynomialUtility.F90 | 251 ++++++++++++++++++ 1 file changed, 251 insertions(+) create mode 100644 src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 diff --git a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 new file mode 100644 index 000000000..c4ea73b2e --- /dev/null +++ b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 @@ -0,0 +1,251 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE HierarchicalPolynomialUtility +USE GlobalData, ONLY: DFP, I4B, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: HierarchicalDOF +PUBLIC :: VertexDOF +PUBLIC :: EdgeDOF +PUBLIC :: FaceDOF +PUBLIC :: CellDOF + +PUBLIC :: HierarchicalEvalAll_ +PUBLIC :: HierarchicalEvalAll + +PUBLIC :: HierarchicalGradientEvalAll_ +PUBLIC :: HierarchicalGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-03 +! summary: Returns the total number of degree of freedom + +INTERFACE + MODULE PURE FUNCTION HierarchicalDOF(elemType, cellOrder, faceOrder, & + edgeOrder) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, alkways needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order needed for 1D elements + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION HierarchicalDOF +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-03 +! summary: Returns the total number of degree of freedom + +INTERFACE + MODULE PURE FUNCTION VertexDOF(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION VertexDOF +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION EdgeDOF(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order(:) + !! order + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION EdgeDOF +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION FaceDOF(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order(:, :) + !! order + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION FaceDOF +END INTERFACE + +!---------------------------------------------------------------------------- +! j +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION CellDOF(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order(:) + !! order + INTEGER(I4B), INTENT(IN) :: elemType + !! + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION CellDOF +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION HierarchicalEvalAll(order, elemType, xij, domainName, & + cellOrder, faceOrder, edgeOrder) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Hierarchical polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Value of n+1 Hierarchical polynomials at point x + END FUNCTION HierarchicalEvalAll +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE HierarchicalEvalAll_(order, elemType, xij, ans, & + nrow, ncol, domainName, cellOrder, faceOrder, edgeOrder) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Hierarchical polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Value of n+1 Hierarchical polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x, 2) + !! ncol = SIZE(xij, 2) + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + END SUBROUTINE HierarchicalEvalAll_ +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION HierarchicalGradientEvalAll(order, elemType, xij, domainName, & + cellOrder, faceOrder, edgeOrder) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Hierarchical polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + !! Value of n+1 Hierarchical polynomials at point x + END FUNCTION HierarchicalGradientEvalAll +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE HierarchicalGradientEvalAll_(order, elemType, xij, ans, & + dim1, dim2, dim3, domainName, cellOrder, faceOrder, edgeOrder) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Hierarchical polynomials + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of n+1 Hierarchical polynomials at point x + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! nrow = SIZE(x, 2) + !! ncol = SIZE(xij, 2) + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + END SUBROUTINE HierarchicalGradientEvalAll_ +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE HierarchicalPolynomialUtility From 2f02d12ccce20f9e9756840dd5b23933b27efa0c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:11:19 +0900 Subject: [PATCH 155/359] updates in line interpolation util --- .../src/LineInterpolationUtility.F90 | 75 ++++++++++++++++--- 1 file changed, 63 insertions(+), 12 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 22bf0ae0a..636f83de6 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -39,16 +39,24 @@ MODULE LineInterpolationUtility PUBLIC :: LagrangeEvalAll_Line_ PUBLIC :: LagrangeGradientEvalAll_Line PUBLIC :: LagrangeGradientEvalAll_Line_ + PUBLIC :: BasisEvalAll_Line PUBLIC :: BasisEvalAll_Line_ + PUBLIC :: BasisGradientEvalAll_Line PUBLIC :: BasisGradientEvalAll_Line_ + PUBLIC :: QuadraturePoint_Line PUBLIC :: ToVEFC_Line PUBLIC :: QuadratureNumber_Line PUBLIC :: RefElemDomain_Line + PUBLIC :: HeirarchicalBasis_Line -PUBLIC :: HeirarchicalGradientBasis_Line +PUBLIC :: HeirarchicalBasis_Line_ + +PUBLIC :: HeirarchicalBasisGradient_Line +PUBLIC :: HeirarchicalBasisGradient_Line_ + PUBLIC :: OrthogonalBasis_Line PUBLIC :: OrthogonalBasisGradient_Line @@ -186,7 +194,9 @@ MODULE PURE FUNCTION GetTotalDOF_Line(order, baseContinuity, & baseInterpolation) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order CHARACTER(*), INTENT(IN) :: baseContinuity + !! not used CHARACTER(*), INTENT(IN) :: baseInterpolation + !! not used INTEGER(I4B) :: ans END FUNCTION GetTotalDOF_Line END INTERFACE @@ -1278,6 +1288,29 @@ MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans) END FUNCTION HeirarchicalBasis_Line1 END INTERFACE HeirarchicalBasis_Line +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Line_ + MODULE SUBROUTINE HeirarchicalBasis_Line1_(order, xij, refLine, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! Polynomial order of interpolation + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + CHARACTER(*), INTENT(IN) :: refLine + !! This parameter denotes the type of reference line. + !! It can take following values: + !! UNIT: in this case xij is in unit Line. + !! BIUNIT: in this case xij is in biunit Line. + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Hierarchical basis + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! SIZE(xij, 2), order + 1 + END SUBROUTINE HeirarchicalBasis_Line1_ +END INTERFACE HeirarchicalBasis_Line_ + !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Line !---------------------------------------------------------------------------- @@ -1286,7 +1319,7 @@ END FUNCTION HeirarchicalBasis_Line1 ! date: 27 Oct 2022 ! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line -INTERFACE HeirarchicalGradientBasis_Line +INTERFACE HeirarchicalBasisGradient_Line MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -1302,7 +1335,31 @@ 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 HeirarchicalGradientBasis_Line +END INTERFACE HeirarchicalBasisGradient_Line + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Line_ + MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_(order, xij, refLine, & + ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: order + !! Polynomial order of interpolation + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + !! size(xij, 1) should be 1 + CHARACTER(*), INTENT(IN) :: refLine + !! This parameter denotes the type of reference line. + !! It can take following values: + !! UNIT: in this case xij is in unit Line. + !! BIUNIT: in this case xij is in biunit Line. + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Gradient of Hierarchical basis + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! SIZE(xij, 2), order + 1, 1 + END SUBROUTINE HeirarchicalGradientBasis_Line1_ +END INTERFACE HeirarchicalBasisGradient_Line_ !---------------------------------------------------------------------------- ! BasisGradientEvalAll_Line @@ -1386,16 +1443,10 @@ MODULE FUNCTION BasisGradientEvalAll_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 + !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev + !! Lobatto ! UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta From 083f6c7573387fce4b72a0e73cdb822de2ce252f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:11:27 +0900 Subject: [PATCH 156/359] update in quadrangle interpolation --- .../src/QuadrangleInterpolationUtility.F90 | 26 +++++++------------ 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 250b3a1fd..0bce703a8 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -37,7 +37,10 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: VerticalEdgeBasis_Quadrangle PUBLIC :: HorizontalEdgeBasis_Quadrangle PUBLIC :: CellBasis_Quadrangle + PUBLIC :: HeirarchicalBasis_Quadrangle +PUBLIC :: HeirarchicalBasis_Quadrangle_ + PUBLIC :: IJ2VEFC_Quadrangle_Clockwise PUBLIC :: IJ2VEFC_Quadrangle_AntiClockwise PUBLIC :: LagrangeEvalAll_Quadrangle @@ -48,7 +51,10 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: RefElemDomain_Quadrangle PUBLIC :: LagrangeGradientEvalAll_Quadrangle PUBLIC :: LagrangeGradientEvalAll_Quadrangle_ + PUBLIC :: HeirarchicalBasisGradient_Quadrangle +PUBLIC :: HeirarchicalBasisGradient_Quadrangle_ + PUBLIC :: TensorProdBasisGradient_Quadrangle PUBLIC :: OrthogonalBasisGradient_Quadrangle PUBLIC :: DubinerGradient_Quadrangle @@ -1958,7 +1964,7 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ INTERFACE HeirarchicalBasis_Quadrangle MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle1(pb, qb, pe3, pe4, & - & qe1, qe2, xij) RESULT(ans) + qe1, qe2, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pb !! order of interpolation inside the quadrangle in x1 direction INTEGER(I4B), INTENT(IN) :: qb @@ -2062,16 +2068,8 @@ END SUBROUTINE HeirarchicalBasis_Quadrangle2_ ! 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) @@ -2093,11 +2091,7 @@ MODULE FUNCTION LagrangeEvalAll_Quadrangle1( & !! Default value of firstCall is True INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical + !! Legendre ! Lobatto ! Chebyshev ! Jacobi ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter From c73767af247832597dbecaa7d5fd5bdc003c65d8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:11:36 +0900 Subject: [PATCH 157/359] update in tetrahedron interpolation --- .../src/TetrahedronInterpolationUtility.F90 | 126 ++++++++++++------ 1 file changed, 86 insertions(+), 40 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index e818160ac..b346d50c1 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -41,7 +41,10 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: EdgeBasis_Tetrahedron PUBLIC :: FacetBasis_Tetrahedron PUBLIC :: CellBasis_Tetrahedron + PUBLIC :: HeirarchicalBasis_Tetrahedron +PUBLIC :: HeirarchicalBasis_Tetrahedron_ + PUBLIC :: FacetConnectivity_Tetrahedron PUBLIC :: EdgeConnectivity_Tetrahedron PUBLIC :: GetVertexDOF_Tetrahedron @@ -54,7 +57,10 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: RefElemDomain_Tetrahedron PUBLIC :: LagrangeGradientEvalAll_Tetrahedron PUBLIC :: LagrangeGradientEvalAll_Tetrahedron_ + PUBLIC :: HeirarchicalBasisGradient_Tetrahedron +PUBLIC :: HeirarchicalBasisGradient_Tetrahedron_ + PUBLIC :: OrthogonalBasisGradient_Tetrahedron PUBLIC :: GetTotalDOF_Tetrahedron PUBLIC :: GetTotalInDOF_Tetrahedron @@ -1985,21 +1991,9 @@ END SUBROUTINE CellBasis_Tetrahedron_ ! summary: Returns the heirarchical basis functions on Tetrahedron INTERFACE HeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & xij, & - & refTetrahedron) & - & RESULT(ans) + MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1(order, pe1, pe2, & + pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 INTEGER(I4B), INTENT(IN) :: pe1 @@ -2090,11 +2084,8 @@ END SUBROUTINE HeirarchicalBasis_Tetrahedron1_ ! summary: Returns the heirarchical basis functions on Tetrahedron INTERFACE HeirarchicalBasis_Tetrahedron - MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2( & - & order, & - & xij, & - & refTetrahedron) & - & RESULT(ans) + MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2(order, xij, & + refTetrahedron) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 REAL(DFP), INTENT(IN) :: xij(:, :) @@ -2599,21 +2590,9 @@ END FUNCTION OrthogonalBasisGradient_Tetrahedron1 ! summary: Returns the heirarchical basis functions on Tetrahedron INTERFACE HeirarchicalBasisGradient_Tetrahedron - MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1( & - & order, & - & pe1, & - & pe2, & - & pe3, & - & pe4, & - & pe5, & - & pe6, & - & ps1, & - & ps2, & - & ps3, & - & ps4, & - & xij, & - & refTetrahedron) & - & RESULT(ans) + MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1(order, pe1, pe2, & + pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 INTEGER(I4B), INTENT(IN) :: pe1 @@ -2652,6 +2631,55 @@ MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1( & END FUNCTION HeirarchicalBasisGradient_Tetrahedron1 END INTERFACE HeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Tetrahedron_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Tetrahedron1_(order, pe1, pe2, & + pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron, & + ans, dim1, dim2, dim3) + + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge parallel to x + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge parallel to y + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge parallel to z + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge parallel to xy + INTEGER(I4B), INTENT(IN) :: pe5 + !! order of interpolation on edge parallel to xz + INTEGER(I4B), INTENT(IN) :: pe6 + !! order of interpolation on edge parallel to yz + INTEGER(I4B), INTENT(IN) :: ps1 + !! order of interpolation on facet parallel to xy + INTEGER(I4B), INTENT(IN) :: ps2 + !! order of interpolation on facet parallel to xz + INTEGER(I4B), INTENT(IN) :: ps3 + !! order of interpolation on facet parallel to yz + INTEGER(I4B), INTENT(IN) :: ps4 + !! order of interpolation on facet parallel to xyz + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(xij, 2) + !! dim2 = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + !! + (ps1 - 1) * (ps1 - 2) / 2 & + !! + (ps2 - 1) * (ps2 - 2) / 2 & + !! + (ps3 - 1) * (ps3 - 2) / 2 & + !! + (ps4 - 1) * (ps4 - 2) / 2 & + !! + (order - 1) * (order - 2) * (order - 3) / 6_I4B + !! dim3 = 3 + END SUBROUTINE HeirarchicalBasisGradient_Tetrahedron1_ +END INTERFACE HeirarchicalBasisGradient_Tetrahedron_ + !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Tetrahedron !---------------------------------------------------------------------------- @@ -2660,12 +2688,30 @@ END FUNCTION HeirarchicalBasisGradient_Tetrahedron1 ! date: 28 Oct 2022 ! summary: Returns the heirarchical basis functions on Tetrahedron +INTERFACE HeirarchicalBasisGradient_Tetrahedron_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Tetrahedron2_(order, xij, & + refTetrahedron, ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! order on xij + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! UNIT or BIUNIT + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(xij, 2) + !! dim2 = (order + 1) * (order + 2) * (order + 3) / 6_I4B + !! dim3 = 3 + END SUBROUTINE HeirarchicalBasisGradient_Tetrahedron2_ +END INTERFACE HeirarchicalBasisGradient_Tetrahedron_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE HeirarchicalBasisGradient_Tetrahedron - MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron2( & - & order, & - & xij, & - & refTetrahedron) & - & RESULT(ans) + MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron2(order, xij, refTetrahedron) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 REAL(DFP), INTENT(IN) :: xij(:, :) From 6fed623b921b72055ab7aedfde8825c78c474b00 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:11:42 +0900 Subject: [PATCH 158/359] update in triangle interpoaltion --- .../src/TriangleInterpolationUtility.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index ab11b3e9d..cd0597e0e 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -40,8 +40,12 @@ MODULE TriangleInterpolationUtility PUBLIC :: VertexBasis_Triangle PUBLIC :: EdgeBasis_Triangle PUBLIC :: CellBasis_Triangle + PUBLIC :: HeirarchicalBasis_Triangle +PUBLIC :: HeirarchicalBasis_Triangle_ + PUBLIC :: HeirarchicalBasisGradient_Triangle +PUBLIC :: HeirarchicalBasisGradient_Triangle_ PUBLIC :: LagrangeEvalAll_Triangle PUBLIC :: LagrangeEvalAll_Triangle_ @@ -1152,8 +1156,8 @@ END SUBROUTINE BarycentricHeirarchicalBasis_Triangle2 ! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle INTERFACE HeirarchicalBasis_Triangle - MODULE PURE FUNCTION HeirarchicalBasis_Triangle1(order, pe1, pe2, pe3,& - & xij, refTriangle) RESULT(ans) + MODULE PURE FUNCTION HeirarchicalBasis_Triangle1(order, pe1, pe2, pe3, & + xij, refTriangle) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of approximation inside the triangle (i.e., cell) !! it should be greater than 2 for cell bubble to exist @@ -1802,8 +1806,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 @@ -1869,10 +1873,8 @@ END SUBROUTINE HeirarchicalBasisGradient_Triangle1_ !$$ INTERFACE OrthogonalBasisGradient_Triangle - MODULE FUNCTION OrthogonalBasisGradient_Triangle1( & - & order, & - & xij, & - & refTriangle) RESULT(ans) + MODULE FUNCTION OrthogonalBasisGradient_Triangle1(order, xij, refTriangle) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial space REAL(DFP), INTENT(IN) :: xij(:, :) From 752c88109df5474d055f95c22d368a7281714b71 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:11:53 +0900 Subject: [PATCH 159/359] update in poly cmake --- src/modules/Polynomial/CMakeLists.txt | 69 ++++++++++++++------------- 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index 86560150e..e5c71feed 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -1,39 +1,40 @@ -# This program is a part of EASIFEM library -# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D # -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. # -# You should have received a copy of the GNU General Public License -# along with this program. If not, see +# You should have received a copy of the GNU General Public License along with +# this program. If not, see # -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/InterpolationUtility.F90 - ${src_path}/LagrangePolynomialUtility.F90 - ${src_path}/OrthogonalPolynomialUtility.F90 - ${src_path}/JacobiPolynomialUtility.F90 - ${src_path}/UltrasphericalPolynomialUtility.F90 - ${src_path}/LegendrePolynomialUtility.F90 - ${src_path}/LobattoPolynomialUtility.F90 - ${src_path}/UnscaledLobattoPolynomialUtility.F90 - ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/LineInterpolationUtility.F90 - ${src_path}/TriangleInterpolationUtility.F90 - ${src_path}/QuadrangleInterpolationUtility.F90 - ${src_path}/TetrahedronInterpolationUtility.F90 - ${src_path}/HexahedronInterpolationUtility.F90 - ${src_path}/PrismInterpolationUtility.F90 - ${src_path}/PyramidInterpolationUtility.F90 - ${src_path}/RecursiveNodesUtility.F90 - ${src_path}/PolynomialUtility.F90 -) \ No newline at end of file +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/InterpolationUtility.F90 + ${src_path}/LagrangePolynomialUtility.F90 + ${src_path}/HierarchicalPolynomialUtility.F90 + ${src_path}/OrthogonalPolynomialUtility.F90 + ${src_path}/JacobiPolynomialUtility.F90 + ${src_path}/UltrasphericalPolynomialUtility.F90 + ${src_path}/LegendrePolynomialUtility.F90 + ${src_path}/LobattoPolynomialUtility.F90 + ${src_path}/UnscaledLobattoPolynomialUtility.F90 + ${src_path}/Chebyshev1PolynomialUtility.F90 + ${src_path}/LineInterpolationUtility.F90 + ${src_path}/TriangleInterpolationUtility.F90 + ${src_path}/QuadrangleInterpolationUtility.F90 + ${src_path}/TetrahedronInterpolationUtility.F90 + ${src_path}/HexahedronInterpolationUtility.F90 + ${src_path}/PrismInterpolationUtility.F90 + ${src_path}/PyramidInterpolationUtility.F90 + ${src_path}/RecursiveNodesUtility.F90 + ${src_path}/PolynomialUtility.F90) + From d5aef1de150a8224367e07290d534354c6cb69cc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:12:07 +0900 Subject: [PATCH 160/359] update in elemshape data h1 methods --- .../src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 index 80d203300..c56617c06 100644 --- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 +++ b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 @@ -50,7 +50,7 @@ & xij=xij, & & refLine=refelem%domainName) - dNdXi = HeirarchicalGradientBasis_Line( & + dNdXi = HeirarchicalBasisGradient_Line( & & order=order, & & xij=xij, & & refLine=refelem%domainName) From 17f4f9eb8486d3d17974d7c1eed646217ab09d0b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:12:21 +0900 Subject: [PATCH 161/359] update in hexahedron interpolation util --- ...HexahedronInterpolationUtility@Methods.F90 | 318 ++++++++---------- 1 file changed, 149 insertions(+), 169 deletions(-) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index b978f198f..b5da94b7a 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2026,59 +2026,69 @@ END PROCEDURE CellBasisGradient_Hexahedron2 !---------------------------------------------------------------------------- -! HeirarchicalBasis_Hexahedron +! !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Hexahedron1 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Hexahedron1_(pb1=pb1, pb2=pb2, pb3=pb3, pxy1=pxy1, & + pxy2=pxy2, pxz1=pxz1, pxz2=pxz2, pyz1=pyz1, pyz2=pyz2, px1=px1, px2=px2, & + px3=px3, px4=px4, py1=py1, py2=py2, py3=py3, py4=py4, pz1=pz1, pz2=pz2, & + pz3=pz3, pz4=pz4, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Hexahedron1 -#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1]) -#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1]) -#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2]) +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- -INTEGER(I4B) :: a, b, maxP, maxQ, maxR -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_) -REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_) +MODULE PROCEDURE HeirarchicalBasis_Hexahedron1_ +INTEGER(I4B) :: a, b, maxP, maxQ, maxR, indx(2) +REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :), L3(:, :) -#undef _maxP_ -#undef _maxQ_ -#undef _maxR_ +nrow = SIZE(xij, 2) +ncol = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & + + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & + + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & + + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & + + (px1 + px2 + px3 + px4 - 4_I4B) & + + (py1 + py2 + py3 + py4 - 4_I4B) & + + (pz1 + pz2 + pz3 + pz4 - 4_I4B) -maxP = SIZE(L1, 2) - 1 -maxQ = SIZE(L2, 2) - 1 -maxR = SIZE(L3, 2) - 1 +maxP = MAX(pb1, px1, px2, px3, px4, pxy1, pxz1) +maxQ = MAX(pb2, py1, py2, py3, py4, pxy2, pyz1) +maxR = MAX(pb3, pz1, pz2, pz3, pz4, pxz2, pyz2) -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) -L3 = LobattoEvalAll(n=maxR, x=xij(3, :)) +ALLOCATE (L1(1:nrow, 0:maxP), L2(1:nrow, 0:maxQ), L3(1:nrow, 0:maxR)) -! Vertex basis function +CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxR, x=xij(3, :), ans=L3, nrow=indx(1), ncol=indx(2)) -ans(:, 1:8) = VertexBasis_Hexahedron2(L1=L1, L2=L2, L3=L3) +! Vertex basis function +ans(1:nrow, 1:8) = VertexBasis_Hexahedron2(L1=L1, L2=L2, L3=L3) ! Edge basis function - b = 8 IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + px1 + px2 + px3 + px4 - 4 - ans(:, a:b) = xEdgeBasis_Hexahedron2( & - & pe1=px1, pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3) + ans(1:nrow, a:b) = xEdgeBasis_Hexahedron2( & + pe1=px1, pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3) END IF IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + py1 + py2 + py3 + py4 - 4 - ans(:, a:b) = yEdgeBasis_Hexahedron2( & - & pe1=py1, pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3) + ans(1:nrow, a:b) = yEdgeBasis_Hexahedron2( & + pe1=py1, pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3) END IF IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4 - ans(:, a:b) = zEdgeBasis_Hexahedron2( & - & pe1=pz1, pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3) + ans(1:nrow, a:b) = zEdgeBasis_Hexahedron2( & + pe1=pz1, pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3) END IF ! Facet basis function @@ -2086,48 +2096,53 @@ IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1) - ans(:, a:b) = xyFacetBasis_Hexahedron2( & - & n1=pxy1, n2=pxy2, L1=L1, L2=L2, L3=L3) + ans(1:nrow, a:b) = xyFacetBasis_Hexahedron2( & + n1=pxy1, n2=pxy2, L1=L1, L2=L2, L3=L3) END IF IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1) - ans(:, a:b) = xzFacetBasis_Hexahedron2( & - & n1=pxz1, n2=pxz2, L1=L1, L2=L2, L3=L3) + ans(1:nrow, a:b) = xzFacetBasis_Hexahedron2( & + n1=pxz1, n2=pxz2, L1=L1, L2=L2, L3=L3) END IF IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1) - ans(:, a:b) = yzFacetBasis_Hexahedron2( & - & n1=pyz1, n2=pyz2, L1=L1, L2=L2, L3=L3) + ans(1:nrow, a:b) = yzFacetBasis_Hexahedron2( & + n1=pyz1, n2=pyz2, L1=L1, L2=L2, L3=L3) END IF IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1) - ans(:, a:b) = cellBasis_Hexahedron2( & - & n1=pb1, n2=pb2, n3=pb3, L1=L1, L2=L2, L3=L3) + ans(1:nrow, a:b) = cellBasis_Hexahedron2( & + n1=pb1, n2=pb2, n3=pb3, L1=L1, L2=L2, L3=L3) END IF -END PROCEDURE HeirarchicalBasis_Hexahedron1 +END PROCEDURE HeirarchicalBasis_Hexahedron1_ !---------------------------------------------------------------------------- -! HeirarchicalBasis_Hexahedron +! !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Hexahedron2 -ans = HeirarchicalBasis_Hexahedron1(& - & pb1=p, pb2=q, pb3=r, & - & pxy1=p, pxy2=q, & - & pxz1=p, pxz2=r, & - & pyz1=q, pyz2=r, & - & px1=p, px2=p, px3=p, px4=p, & - & py1=q, py2=q, py3=q, py4=q, & - & pz1=r, pz2=r, pz3=r, pz4=r, & - & xij=xij) +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Hexahedron2_(p=p, q=q, r=r, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE HeirarchicalBasis_Hexahedron2 +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Hexahedron2_ +CALL HeirarchicalBasis_Hexahedron1_(pb1=p, pb2=q, pb3=r, pxy1=p, pxy2=q, & + pxz1=p, pxz2=r, pyz1=q, pyz2=r, px1=p, px2=p, px3=p, px4=p, py1=q, py2=q, & + py3=q, py4=q, pz1=r, pz2=r, pz3=r, pz4=r, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE HeirarchicalBasis_Hexahedron2_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Hexahedron !---------------------------------------------------------------------------- @@ -2840,47 +2855,66 @@ END PROCEDURE TensorProdBasisGradient_Hexahedron1 !---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Hexahedron1 +! !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron1 -#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1]) -#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1]) -#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2]) - -INTEGER(I4B) :: a, b, maxP, maxQ, maxR -REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_) -REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_) -REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_) -REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:_maxP_) -REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:_maxQ_) -REAL(DFP) :: dL3(1:SIZE(xij, 2), 0:_maxR_) - -#undef _maxP_ -#undef _maxQ_ -#undef _maxR_ - -maxP = SIZE(L1, 2) - 1 -maxQ = SIZE(L2, 2) - 1 -maxR = SIZE(L3, 2) - 1 - -L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) -L3 = LobattoEvalAll(n=maxR, x=xij(3, :)) - -dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :)) -dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :)) -dL3 = LobattoGradientEvalAll(n=maxR, x=xij(3, :)) +INTEGER(I4B) :: dim1, dim2, dim3 + +CALL HeirarchicalBasisGradient_Hexahedron1_(pb1=pb1, pb2=pb2, pb3=pb3, & + pxy1=pxy1, pxy2=pxy2, pxz1=pxz1, pxz2=pxz2, pyz1=pyz1, pyz2=pyz2, px1=px1, & + px2=px2, px3=px3, px4=px4, py1=py1, py2=py2, py3=py3, py4=py4, pz1=pz1, & + pz2=pz2, pz3=pz3, pz4=pz4, xij=xij, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Hexahedron1 + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Hexahedron1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron1_ +INTEGER(I4B) :: a, b, maxP, maxQ, maxR, indx(2) +REAL( DFP ), ALLOCATABLE :: L1(:,:), L2(:,:), L3(:,:), dL1(:,:), dL2(:,:), & + dL3(:, :) + +dim1 = SIZE(xij, 2) + +dim2 = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) & + + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B & + + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B & + + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B & + + (px1 + px2 + px3 + px4 - 4_I4B) & + + (py1 + py2 + py3 + py4 - 4_I4B) & + + (pz1 + pz2 + pz3 + pz4 - 4_I4B) + +dim3 = 3_I4B + +maxP = MAX(pb1, px1, px2, px3, px4, pxy1, pxz1) +maxQ = MAX(pb2, py1, py2, py3, py4, pxy2, pyz1) +maxR = MAX(pb3, pz1, pz2, pz3, pz4, pxz2, pyz2) + +ALLOCATE (L1(1:dim1, 0:maxP), L2(1:dim1, 0:maxQ), L3(1:dim1, 0:maxR), & + dL1(1:dim1, 0:maxP), dL2(1:dim1, 0:maxQ), dL3(1:dim1, 0:maxR)) + +CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxR, x=xij(3, :), ans=L3, nrow=indx(1), ncol=indx(2)) + +! dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :)) +CALL LobattoGradientEvalAll_(n=maxP, x=xij(1, :), ans=dL1, nrow=indx(1), & + ncol=indx(2)) + +! dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :)) +CALL LobattoGradientEvalAll_(n=maxQ, x=xij(2, :), ans=dL2, nrow=indx(1), & + ncol=indx(2)) + +! dL3 = LobattoGradientEvalAll(n=maxR, x=xij(3, :)) +CALL LobattoGradientEvalAll_(n=maxR, x=xij(3, :), ans=dL3, nrow=indx(1), & + ncol=indx(2)) ! Vertex basis function -ans(:, 1:8, :) = VertexBasisGradient_Hexahedron2( & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) +ans(1:dim1, 1:8, 1:dim3) = VertexBasisGradient_Hexahedron2(L1=L1, L2=L2, & + L3=L3, dL1=dL1, dL2=dL2, dL3=dL3) ! Edge basis function b = 8 @@ -2888,52 +2922,25 @@ IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + px1 + px2 + px3 + px4 - 4 - ans(:, a:b, :) = xEdgeBasisGradient_Hexahedron2( & - & pe1=px1, & - & pe2=px2, & - & pe3=px3, & - & pe4=px4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) + ans(1:dim1, a:b, 1:dim3) = xEdgeBasisGradient_Hexahedron2(pe1=px1, & + pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, & + dL3=dL3) END IF IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + py1 + py2 + py3 + py4 - 4 - ans(:, a:b, :) = yEdgeBasisGradient_Hexahedron2( & - & pe1=py1, & - & pe2=py2, & - & pe3=py3, & - & pe4=py4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) + ans(1:dim1, a:b, 1:dim3) = yEdgeBasisGradient_Hexahedron2(pe1=py1, & + pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, & + dL3=dL3) END IF IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4 - ans(:, a:b, :) = zEdgeBasisGradient_Hexahedron2( & - & pe1=pz1, & - & pe2=pz2, & - & pe3=pz3, & - & pe4=pz4, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) + ans(1:dim1, a:b, 1:dim3) = zEdgeBasisGradient_Hexahedron2(pe1=pz1, & + pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, & + dL3=dL3) END IF ! Facet basis function @@ -2941,85 +2948,58 @@ IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1) - ans(:, a:b, :) = xyFacetBasisGradient_Hexahedron2( & - & n1=pxy1, & - & n2=pxy2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) + ans(1:dim1, a:b, 1:dim3) = xyFacetBasisGradient_Hexahedron2(n1=pxy1, & + n2=pxy2, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3) END IF -IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN +IF & + (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1) - ans(:, a:b, :) = xzFacetBasisGradient_Hexahedron2( & - & n1=pxz1, & - & n2=pxz2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) + ans(1:dim1, a:b, 1:dim3) = xzFacetBasisGradient_Hexahedron2(n1=pxz1, & + n2=pxz2, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3) END IF IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1) - ans(:, a:b, :) = yzFacetBasisGradient_Hexahedron2( & - & n1=pyz1, & - & n2=pyz2, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) + ans(1:dim1, a:b, 1:dim3) = yzFacetBasisGradient_Hexahedron2(n1=pyz1, & + n2=pyz2, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3) END IF IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN a = b + 1 b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1) - ans(:, a:b, :) = cellBasisGradient_Hexahedron2( & - & n1=pb1, & - & n2=pb2, & - & n3=pb3, & - & L1=L1, & - & L2=L2, & - & L3=L3, & - & dL1=dL1, & - & dL2=dL2, & - & dL3=dL3 & - & ) + ans(1:dim1, a:b, 1:dim3) = cellBasisGradient_Hexahedron2(n1=pb1, n2=pb2, & + n3=pb3, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3) END IF -END PROCEDURE HeirarchicalBasisGradient_Hexahedron1 +END PROCEDURE HeirarchicalBasisGradient_Hexahedron1_ !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Hexahedron2 !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron2 -ans = HeirarchicalBasisGradient_Hexahedron1(& - & pb1=p, pb2=q, pb3=r, & - & pxy1=p, pxy2=q, & - & pxz1=p, pxz2=r, & - & pyz1=q, pyz2=r, & - & px1=p, px2=p, px3=p, px4=p, & - & py1=q, py2=q, py3=q, py4=q, & - & pz1=r, pz2=r, pz3=r, pz4=r, & - & xij=xij) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL HeirarchicalBasisGradient_Hexahedron2_(p=p, q=q, r=r, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE HeirarchicalBasisGradient_Hexahedron2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron2_ +CALL HeirarchicalBasisGradient_Hexahedron1_(pb1=p, pb2=q, pb3=r, pxy1=p, & + pxy2=q, pxz1=p, pxz2=r, pyz1=q, pyz2=r, px1=p, px2=p, px3=p, px4=p, py1=q, & + py2=q, py3=q, py4=q, pz1=r, pz2=r, pz3=r, pz4=r, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Hexahedron2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE InterpolationPoint_Hexahedron1_ CALL ErrorMsg(& & msg="InterpolationPoint_Hexahedron1_ is not implemented", & From 080f7877bceed4cebfdecbb5b9cf7586407fec82 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:12:28 +0900 Subject: [PATCH 162/359] update in hierarchical poly --- .../HierarchicalPolynomialUtility@Methods.F90 | 483 ++++++++++++++++++ 1 file changed, 483 insertions(+) create mode 100644 src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..a1ad87684 --- /dev/null +++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 @@ -0,0 +1,483 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! Vikas Sharma, Ph.D., vickysharma0812@gmail.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(HierarchicalPolynomialUtility) Methods +USE GlobalData, ONLY: stderr + +USE ReferenceElement_Method, ONLY: XiDimension, & + GetTotalNodes, & + ElementTopology + +USE ErrorHandling, ONLY: ErrorMsg + +USE BaseType, ONLY: elemopt => TypeElemNameOpt + +USE LineInterpolationUtility, ONLY: HeirarchicalBasis_Line_, & + HeirarchicalBasisGradient_Line_ + +USE TriangleInterpolationUtility, ONLY: HeirarchicalBasis_Triangle_, & + HeirarchicalBasisGradient_Triangle_ + +USE QuadrangleInterpolationUtility, ONLY: HeirarchicalBasis_Quadrangle_, & + HeirarchicalBasisGradient_Quadrangle_ + +USE TetrahedronInterpolationUtility, ONLY: HeirarchicalBasis_Tetrahedron_, & + HeirarchicalBasisGradient_Tetrahedron_ + +USE HexahedronInterpolationUtility, ONLY: HeirarchicalBasis_Hexahedron_, & + HeirarchicalBasisGradient_Hexahedron_ + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalDOF +ans = 0 +END PROCEDURE HierarchicalDOF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexDOF +ans = GetTotalNodes(elemType) +END PROCEDURE VertexDOF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeDOF +ans = 0 +END PROCEDURE EdgeDOF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FaceDOF +ans = 0 +END PROCEDURE FaceDOF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellDOF +ans = 0 +END PROCEDURE CellDOF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalEvalAll +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(xij, 2) +ncol = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder) + +ALLOCATE (ans(nrow, ncol)) + +CALL HierarchicalEvalAll_(order=order, elemType=elemType, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol, domainName=domainName, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder) + +END PROCEDURE HierarchicalEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalEvalAll_ +#ifdef DEBUG_VER +INTEGER(I4B) :: ierr, tedge, tface, nsd +LOGICAL(LGT) :: isok +CHARACTER(:), ALLOCATABLE :: errmsg +#endif + +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (elemopt%Line) + +#ifdef DEBUG_VER + nsd = 1 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasis_Line_(order=cellOrder(1), xij=xij, ans=ans, & + nrow=nrow, ncol=ncol, refLine=domainName) + +CASE (elemopt%Triangle) + +#ifdef DEBUG_VER + nsd = 2; tFace = 3 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasis_Triangle_(order=cellOrder(1), pe1=faceOrder(1, 1), & + pe2=faceOrder(1, 2), pe3=faceOrder(1, 3), xij=xij, refTriangle=domainName, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (elemopt%Quadrangle) + +#ifdef DEBUG_VER + nsd = 2; tFace = 4 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasis_Quadrangle_(pb=cellOrder(1), qb=cellOrder(2), & + pe3=faceOrder(1, 1), pe4=faceOrder(1, 3), qe1=faceOrder(1, 4), & + qe2=faceOrder(1, 2), xij=xij, ans=ans, nrow=nrow, ncol=ncol) + +CASE (elemopt%Tetrahedron) + +#ifdef DEBUG_VER + nsd = 3; tFace = 4; tEdge = 6 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasis_Tetrahedron_(order=cellOrder(1), pe1=edgeOrder(1), & + pe2=edgeOrder(2), pe3=edgeOrder(3), pe4=edgeOrder(4), pe5=edgeOrder(5), & + pe6=edgeOrder(6), ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), & + ps3=faceOrder(1, 3), ps4=faceOrder(1, 4), xij=xij, & + refTetrahedron=domainName, ans=ans, & + nrow=nrow, ncol=ncol) + +CASE (elemopt%Hexahedron) + +#ifdef DEBUG_VER + !! FIXME: Currently we consiering only three faces + nsd = 3; tFace = 3; tEdge = 12 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasis_Hexahedron_( & + pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), & + pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), & + pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), & + pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), & + px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), & + py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), & + pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), & + pz4=edgeOrder(12), xij=xij, ans=ans, nrow=nrow, ncol=ncol) + +! CASE (elemopt%Prism) + +! CASE (elemopt%Pyramid) + +CASE DEFAULT + CALL ErrorMsg(msg="No case found for topology", & + routine='HierarchicalEvalAll_()', & + file=__FILE__, line=__LINE__, unitno=stderr) + + RETURN +END SELECT + +#ifdef DEBUG_VER + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +SUBROUTINE check_error + + isok = PRESENT(cellOrder) + IF (.NOT. isok) THEN + ierr = -1 + errmsg = "cellOrder is not present" + RETURN + END IF + + IF (nsd .GT. 1) THEN + + isok = PRESENT(faceOrder) + IF (.NOT. isok) THEN + ierr = -2 + errmsg = "faceOrder is not present" + RETURN + END IF + + isok = SIZE(faceOrder, 2) .EQ. tface + IF (.NOT. isok) THEN + ierr = -3 + errmsg = "the size of faceOrder should be total face in elements" + RETURN + END IF + + END IF + + IF (nsd .EQ. 2) THEN + + isok = PRESENT(edgeOrder) + IF (.NOT. isok) THEN + ierr = -4 + errmsg = "edgeOrder is not present" + RETURN + END IF + + isok = SIZE(edgeOrder) .EQ. tEdge + IF (.NOT. isok) THEN + ierr = -5 + errmsg = "the size of faceOrder should be total face in elements" + RETURN + END IF + + END IF + +END SUBROUTINE check_error + +SUBROUTINE printError + CALL ErrorMsg(msg=errmsg, routine='HierarchicalEvalAll_()', & + file=__FILE__, line=__LINE__, unitno=stderr) +END SUBROUTINE printError + +#endif + +END PROCEDURE HierarchicalEvalAll_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalGradientEvalAll +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = SIZE(xij, 2) +dim2 = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder) +dim3 = XiDimension(elemType) + +ALLOCATE (ans(dim1, dim2, dim3)) + +CALL HierarchicalGradientEvalAll_(order=order, elemType=elemType, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, domainName=domainName, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder) + +END PROCEDURE HierarchicalGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalGradientEvalAll_ + +#ifdef DEBUG_VER +INTEGER(I4B) :: ierr, tedge, tface, nsd +LOGICAL(LGT) :: isok +CHARACTER(:), ALLOCATABLE :: errmsg +#endif + +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (elemopt%Line) + +#ifdef DEBUG_VER + nsd = 1 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasisGradient_Line_(order=cellOrder(1), xij=xij, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3, refLine=domainName) + +CASE (elemopt%Triangle) + +#ifdef DEBUG_VER + nsd = 2; tFace = 3 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasisGradient_Triangle_(order=cellOrder(1), & + pe1=faceOrder(1, 1), pe2=faceOrder(1, 2), pe3=faceOrder(1, 3), xij=xij, & + refTriangle=domainName, ans=ans, tsize1=dim1, tsize2=dim2, tsize3=dim3) + +CASE (elemopt%Quadrangle) + +#ifdef DEBUG_VER + nsd = 2; tFace = 4 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + +CALL HeirarchicalBasisGradient_Quadrangle_(pb=cellOrder(1), qb=cellOrder(2), & + pe3=faceOrder(1, 1), pe4=faceOrder(1, 3), qe1=faceOrder(1, 4), & + qe2=faceOrder(1, 2), xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (elemopt%Tetrahedron) + +#ifdef DEBUG_VER + nsd = 3; tFace = 4; tEdge = 6 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasisGradient_Tetrahedron_(order=cellOrder(1), & + pe1=edgeOrder(1), pe2=edgeOrder(2), pe3=edgeOrder(3), & + pe4=edgeOrder(4), pe5=edgeOrder(5), pe6=edgeOrder(6), & + ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), ps3=faceOrder(1, 3), & + ps4=faceOrder(1, 4), xij=xij, refTetrahedron=domainName, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (elemopt%Hexahedron) + +#ifdef DEBUG_VER + !! FIXME: Currently we consiering only three faces + nsd = 3; tFace = 3; tEdge = 12 + CALL check_error + IF (ierr .LT. 0) THEN + CALL printError + RETURN + END IF +#endif + + CALL HeirarchicalBasisGradient_Hexahedron_( & + pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), & + pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), & + pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), & + pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), & + px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), & + py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), & + pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), & + pz4=edgeOrder(12), xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +! CASE (elemopt%Prism) + +! CASE (elemopt%Pyramid) + +CASE DEFAULT + CALL ErrorMsg(msg="No case found for topology", & + routine='HierarchicalEvalAll_()', & + file=__FILE__, line=__LINE__, unitno=stderr) + + RETURN +END SELECT + +#ifdef DEBUG_VER + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +CONTAINS + +SUBROUTINE check_error + + isok = PRESENT(cellOrder) + IF (.NOT. isok) THEN + ierr = -1 + errmsg = "cellOrder is not present" + RETURN + END IF + + IF (nsd .GT. 1) THEN + + isok = PRESENT(faceOrder) + IF (.NOT. isok) THEN + ierr = -2 + errmsg = "faceOrder is not present" + RETURN + END IF + + isok = SIZE(faceOrder, 2) .EQ. tface + IF (.NOT. isok) THEN + ierr = -3 + errmsg = "the size of faceOrder should be total face in elements" + RETURN + END IF + + END IF + + IF (nsd .EQ. 2) THEN + + isok = PRESENT(edgeOrder) + IF (.NOT. isok) THEN + ierr = -4 + errmsg = "edgeOrder is not present" + RETURN + END IF + + isok = SIZE(edgeOrder) .EQ. tEdge + IF (.NOT. isok) THEN + ierr = -5 + errmsg = "the size of faceOrder should be total face in elements" + RETURN + END IF + + END IF + +END SUBROUTINE check_error + +SUBROUTINE printError + CALL ErrorMsg(msg=errmsg, routine='HierarchicalEvalAll_()', & + file=__FILE__, line=__LINE__, unitno=stderr) +END SUBROUTINE printError + +#endif + +END PROCEDURE HierarchicalGradientEvalAll_ + +END SUBMODULE Methods From 39e59bf60e37efbef6d6d98f1cb0a6645c46853c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:12:33 +0900 Subject: [PATCH 163/359] update in line interpolation --- .../src/LineInterpolationUtility@Methods.F90 | 123 +++++++++++------- 1 file changed, 77 insertions(+), 46 deletions(-) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index f60d3fc02..953239d57 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -27,7 +27,8 @@ USE MappingUtility, ONLY: FromBiunitLine2Segment_, & FromBiunitLine2Segment, & - FromUnitLine2BiUnitLine + FromUnitLine2BiUnitLine, & + FromUnitLine2BiUnitLine_ USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol, & GradientEvalAllOrthopol_, & @@ -1612,69 +1613,99 @@ END SUBROUTINE handle_error END PROCEDURE LagrangeGradientEvalAll_Line1_ !---------------------------------------------------------------------------- -! BasisEvalAll_Line +! !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Line1 -TYPE(String) :: astr -astr = UpperCase(refLine) +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_ +CHARACTER(1) :: astr +REAL(DFP) :: temp(SIZE(xij, 2)) + +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) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = EvalAllOrthopol( & - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=polyopt%Lobatto) -CASE ("BIUNIT") - ans = EvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=polyopt%Lobatto) CASE DEFAULT - ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refline.", & - & file=__FILE__, & - & routine="HeirarchicalBasis_Line1", & - & line=__LINE__, & - & unitno=stderr) + nrow = 0 + ncol = 0 + + CALL Errormsg(msg="No case found for refLine.", & + routine="HeirarchicalBasis_Line1_()", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END SELECT -END PROCEDURE HeirarchicalBasis_Line1 +END PROCEDURE HeirarchicalBasis_Line1_ !---------------------------------------------------------------------------- -! HeirarchicalGradientBasis_Line +! !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalGradientBasis_Line1 -TYPE(String) :: astr -astr = UpperCase(refLine) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL HeirarchicalGradientBasis_Line1_(order=order, xij=xij, refLine=refLine, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalGradientBasis_Line1 + +!---------------------------------------------------------------------------- +! HeirarchicalGradientBasis_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalGradientBasis_Line1_ +CHARACTER(1) :: astr +REAL(DFP) :: temp(SIZE(xij, 2)) + +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) + + ans(1:dim1, 1:dim2, 1) = ans(1:dim1, 1:dim2, 1) * 2.0_DFP + +CASE ("B") + + CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), & + orthopol=polyopt%Lobatto, ans=ans(:, :, 1), nrow=dim1, ncol=dim2) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=polyopt%Lobatto) - ans = ans * 2.0_DFP -CASE ("BIUNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=polyopt%Lobatto) CASE DEFAULT - ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refline.", & - & file=__FILE__, & - & routine="HeirarchicalGradientBasis_Line1", & - & line=__LINE__, & - & unitno=stderr) + + dim1 = 0 + dim2 = 0 + dim3 = 0 + CALL Errormsg(msg="No case found for refline.", & + routine="HeirarchicalGradientBasis_Line1_()", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN END SELECT -END PROCEDURE HeirarchicalGradientBasis_Line1 +END PROCEDURE HeirarchicalGradientBasis_Line1_ !---------------------------------------------------------------------------- ! OrthogonalBasis_Line From 218c5c5a3dcc9c86e5d846f613055c531f4d39d6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:12:40 +0900 Subject: [PATCH 164/359] update in tetrahedron interpolation --- ...etrahedronInterpolationUtility@Methods.F90 | 74 ++++++++++++------- 1 file changed, 47 insertions(+), 27 deletions(-) diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index 5959110cc..77a451f9c 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -2807,42 +2807,62 @@ END SUBROUTINE IJK2VEFC_Triangle END PROCEDURE OrthogonalBasisGradient_Tetrahedron1 !---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Tetrahedron +! !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron1 -TYPE(String) :: name -REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), 4) -ans0 = BarycentricHeirarchicalBasisGradient_Tetrahedron(& - & lambda=BarycentricCoordTetrahedron( & - & xin=xij, & - & refTetrahedron=refTetrahedron), & - & order=order, & - & pe1=pe1, & - & pe2=pe2, & - & pe3=pe3, & - & pe4=pe4, & - & pe5=pe5, & - & pe6=pe6, & - & ps1=ps1, & - & ps2=ps2, & - & ps3=ps3, & - & ps4=ps4) - -ans(:, :, 1) = ans0(:, :, 2) - ans0(:, :, 1) -ans(:, :, 2) = ans0(:, :, 3) - ans0(:, :, 1) -ans(:, :, 3) = ans0(:, :, 4) - ans0(:, :, 1) - -name = UpperCase(refTetrahedron) -IF (name == "BIUNIT") THEN - ans = 0.5_DFP * ans -END IF +INTEGER(I4B) :: dim1, dim2, dim3 +CALL HeirarchicalBasisGradient_Tetrahedron1_(order=order, pe1=pe1, pe2=pe2, & + pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4, & + xij=xij, refTetrahedron=refTetrahedron, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3) END PROCEDURE HeirarchicalBasisGradient_Tetrahedron1 !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Tetrahedron !---------------------------------------------------------------------------- +MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron1_ +CHARACTER(1) :: name +REAL(DFP), ALLOCATABLE :: ans0(:, :, :), lambda(:, :) +INTEGER(I4B) :: indx(2) + +dim1 = SIZE(xij, 2) + +dim2 = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 & + + (ps1 - 1) * (ps1 - 2) / 2 & + + (ps2 - 1) * (ps2 - 2) / 2 & + + (ps3 - 1) * (ps3 - 2) / 2 & + + (ps4 - 1) * (ps4 - 2) / 2 & + + (order - 1) * (order - 2) * (order - 3) / 6_I4B + +dim3 = 3 + +ALLOCATE (ans0(dim1, dim2, dim3 + 1), lambda(4, dim1)) + +CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, & + ans=lambda, nrow=indx(1), ncol=indx(2)) + +ans0 = BarycentricHeirarchicalBasisGradient_Tetrahedron(lambda=lambda, & + order=order, pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, & + ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4) + +ans(1:dim1, 1:dim2, 1) = ans0(:, :, 2) - ans0(:, :, 1) +ans(1:dim1, 1:dim2, 2) = ans0(:, :, 3) - ans0(:, :, 1) +ans(1:dim1, 1:dim2, 3) = ans0(:, :, 4) - ans0(:, :, 1) + +name = UpperCase(refTetrahedron(1:1)) +IF (name .EQ. "B") THEN + ans(1:dim1, 1:dim2, 1:dim3) = 0.5_DFP * ans(1:dim1, 1:dim2, 1:dim3) +END IF + +DEALLOCATE (ans0, lambda) +END PROCEDURE HeirarchicalBasisGradient_Tetrahedron1_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron2 ans = HeirarchicalBasisGradient_Tetrahedron1( & & order=order, & From 123e281df7a260ad5b165f63ac96420c5cfabd9e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Jul 2024 15:12:47 +0900 Subject: [PATCH 165/359] update in cmake of poly --- src/submodules/Polynomial/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 90b4a65e5..8cdab8754 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -33,6 +33,7 @@ target_sources( ${src_path}/PyramidInterpolationUtility@Methods.F90 ${src_path}/InterpolationUtility@Methods.F90 ${src_path}/LagrangePolynomialUtility@Methods.F90 + ${src_path}/HierarchicalPolynomialUtility@Methods.F90 ${src_path}/JacobiPolynomialUtility@Methods.F90 ${src_path}/UltrasphericalPolynomialUtility@Methods.F90 ${src_path}/LegendrePolynomialUtility@Methods.F90 From 62a5e189ad69421442880fe98b268ca405e66032 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 5 Jul 2024 09:17:27 +0900 Subject: [PATCH 166/359] updates in lineinterpolation --- .../src/LineInterpolationUtility.F90 | 58 +++++++++++++++-- .../src/LineInterpolationUtility@Methods.F90 | 65 ++++++++++++++++++- 2 files changed, 114 insertions(+), 9 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 636f83de6..1441e36ce 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -1311,6 +1311,31 @@ MODULE SUBROUTINE HeirarchicalBasis_Line1_(order, xij, refLine, ans, & END SUBROUTINE HeirarchicalBasis_Line1_ END INTERFACE HeirarchicalBasis_Line_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Line_ +MODULE SUBROUTINE HeirarchicalBasis_Line2_(order, xij, refLine, orient, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! Polynomial order of interpolation + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + CHARACTER(*), INTENT(IN) :: refLine + !! This parameter denotes the type of reference line. + !! It can take following values: + !! UNIT: in this case xij is in unit Line. + !! BIUNIT: in this case xij is in biunit Line. + INTEGER(I4B), INTENT(IN) :: orient + !! orientation of line: 1 or -1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Hierarchical basis + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! SIZE(xij, 2), order + 1 + END SUBROUTINE HeirarchicalBasis_Line2_ +END INTERFACE HeirarchicalBasis_Line_ + !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Line !---------------------------------------------------------------------------- @@ -1361,6 +1386,32 @@ MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_(order, xij, refLine, & END SUBROUTINE HeirarchicalGradientBasis_Line1_ END INTERFACE HeirarchicalBasisGradient_Line_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Line_ + MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_(order, xij, refLine, & + orient, ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: order + !! Polynomial order of interpolation + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + !! size(xij, 1) should be 1 + CHARACTER(*), INTENT(IN) :: refLine + !! This parameter denotes the type of reference line. + !! It can take following values: + !! UNIT: in this case xij is in unit Line. + !! BIUNIT: in this case xij is in biunit Line. + INTEGER(I4B), INTENT(IN) :: orient + !! orientation of line: 1 or -1 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Gradient of Hierarchical basis + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! SIZE(xij, 2), order + 1, 1 + END SUBROUTINE HeirarchicalGradientBasis_Line2_ +END INTERFACE HeirarchicalBasisGradient_Line_ + !---------------------------------------------------------------------------- ! BasisGradientEvalAll_Line !---------------------------------------------------------------------------- @@ -1379,12 +1430,7 @@ MODULE FUNCTION BasisGradientEvalAll_Line1(order, x, refLine, basisType, & CHARACTER(*), INTENT(IN) :: refLine !! Refline should be BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto + !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev ! Lobatto !! UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 953239d57..69382768a 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -57,6 +57,16 @@ USE F95_BLAS, ONLY: GEMM +#ifndef USE_BLAS95 + +USE SwapUtility, ONLY: Swap + +#else + +USE F95_BLAS, ONLY: Swap + +#endif + IMPLICIT NONE CONTAINS @@ -1627,6 +1637,16 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- 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)) @@ -1638,10 +1658,27 @@ END SUBROUTINE handle_error SELECT CASE (astr) CASE ("U") CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=nrow) + IF (orient .EQ. -1) temp(1:nrow) = -1.0_DFP * temp(1:nrow) CALL EvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, ans=ans, & nrow=nrow, ncol=ncol) + !! Only the internal modes depends on the orientation + !! So we are reverting removing the effect of orientation from + !! vertex basis functions, this is equivalent to swapping the + !! the value of vertex basis functions + CALL SWAP(ans(1:nrow, 1), ans(1:nrow, 2)) + CASE ("B") + + IF (orient .EQ. -1) THEN + temp(1:nrow) = -1.0_DFP * xij(1, 1:nrow) + CALL EvalAllOrthopol_(n=order, x=temp(1:nrow), & + orthopol=polyopt%Lobatto, ans=ans, nrow=nrow, ncol=ncol) + + CALL SWAP(ans(1:nrow, 1), ans(1:nrow, 2)) + RETURN + END IF + CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=polyopt%Lobatto, & ans=ans, nrow=nrow, ncol=ncol) @@ -1655,7 +1692,7 @@ END SUBROUTINE handle_error RETURN END SELECT -END PROCEDURE HeirarchicalBasis_Line1_ +END PROCEDURE HeirarchicalBasis_Line2_ !---------------------------------------------------------------------------- ! @@ -1672,11 +1709,22 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- 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_ CHARACTER(1) :: astr REAL(DFP) :: temp(SIZE(xij, 2)) astr = UpperCase(refLine(1:1)) +dim1 = SIZE(xij, 2) dim3 = 1 SELECT CASE (astr) @@ -1684,6 +1732,8 @@ END SUBROUTINE handle_error CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=dim1) + IF (orient .EQ. -1) temp(1:dim1) = -1.0_DFP * temp(1:dim1) + CALL GradientEvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, & ans=ans(:, :, 1), nrow=dim1, ncol=dim2) @@ -1691,8 +1741,17 @@ END SUBROUTINE handle_error CASE ("B") - CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), & + IF (orient .EQ. -1) THEN + + temp(1:dim1) = -1.0_DFP * xij(1, 1:dim1) + + CALL GradientEvalAllOrthopol_(n=order, x=temp, & + orthopol=polyopt%Lobatto, ans=ans(:, :, 1), nrow=dim1, ncol=dim2) + ELSE + + CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), & orthopol=polyopt%Lobatto, ans=ans(:, :, 1), nrow=dim1, ncol=dim2) + END IF CASE DEFAULT @@ -1705,7 +1764,7 @@ END SUBROUTINE handle_error RETURN END SELECT -END PROCEDURE HeirarchicalGradientBasis_Line1_ +END PROCEDURE HeirarchicalGradientBasis_Line2_ !---------------------------------------------------------------------------- ! OrthogonalBasis_Line From 28889eb9c42a1cb23fb133330bfa99bb0742dfdd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 5 Jul 2024 09:17:52 +0900 Subject: [PATCH 167/359] updates in triangle interpolation utility --- .../src/TriangleInterpolationUtility.F90 | 86 ++++++- ...lationUtility@HeirarchicalBasisMethods.F90 | 241 +++++++++++++----- 2 files changed, 259 insertions(+), 68 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index cd0597e0e..197c96045 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -61,11 +61,6 @@ MODULE TriangleInterpolationUtility PUBLIC :: GetTotalDOF_Triangle PUBLIC :: GetTotalInDOF_Triangle -! PUBLIC :: BarycentricVertexBasis_Triangle -! PUBLIC :: BarycentricEdgeBasis_Triangle -! PUBLIC :: BarycentricHeirarchicalBasis_Triangle -! PUBLIC :: BarycentricHeirarchicalBasisGradient_Triangle - !---------------------------------------------------------------------------- ! GetTotalDOF_Triangle !---------------------------------------------------------------------------- @@ -1096,7 +1091,7 @@ END FUNCTION CellBasis_Triangle INTERFACE BarycentricHeirarchicalBasis_Triangle MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle1(order, & - & pe1, pe2, pe3, lambda, refTriangle, ans, nrow, ncol) + pe1, pe2, pe3, lambda, refTriangle, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 INTEGER(I4B), INTENT(IN) :: pe1 @@ -1147,6 +1142,41 @@ MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle2(order, lambda, & END SUBROUTINE BarycentricHeirarchicalBasis_Triangle2 END INTERFACE BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE BarycentricHeirarchicalBasis_Triangle + MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle3(order, & + pe1, pe2, pe3, lambda, refTriangle, edgeOrient1, edgeOrient2, & + edgeOrient3, faceOrient, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge e1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge e2 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 3 + !! number of cols = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 + !! edge orientation 1 or -1 + INTEGER(I4B), INTENT(IN) :: faceOrient(:) + !! face orientation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans( & + ! & SIZE(lambda, 2), & + ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE BarycentricHeirarchicalBasis_Triangle3 +END INTERFACE BarycentricHeirarchicalBasis_Triangle + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Triangle !---------------------------------------------------------------------------- @@ -1280,6 +1310,50 @@ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle2_(order, xij, & END SUBROUTINE HeirarchicalBasis_Triangle2_ END INTERFACE HeirarchicalBasis_Triangle_ +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-04 +! 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) + 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. + INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 + !! edge orientation, 1 or -1 + INTEGER(I4B), INTENT(IN) :: faceOrient(:) + !! face orient, size is 2, 1 or -1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! REAL(DFP) :: ans( & + ! & SIZE(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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 index df48713f1..c56627c28 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 @@ -47,6 +47,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricEdgeBasis_Triangle +INTEGER(I4B), PARAMETER :: orient = 1 REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) INTEGER(I4B) :: maxP, tPoints, ii, jj @@ -66,7 +67,8 @@ CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=ii, ncol=jj) CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, ans=ans) + lambda=lambda, phi=phi, ans=ans, nrow=ii, ncol=jj, edgeOrient1=orient, & + edgeOrient2=orient, edgeOrient3=orient) END PROCEDURE BarycentricEdgeBasis_Triangle @@ -80,55 +82,75 @@ ! (internal only) MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & - lambda, phi, ans) + lambda, phi, ans, nrow, ncol, edgeOrient1, edgeOrient2, edgeOrient3) INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) + !! order on edge (e1) INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) + !! order on edge (e2) INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) + !! order on edge (e3) REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP), INTENT(INOUT) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) + !! ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = size(lambda, 2) + !! ncol = pe1 + pe2 + pe3 - 3 + INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 - INTEGER(I4B) :: tPoints, a, ii - REAL(DFP) :: temp(SIZE(lambda, 2)) - !FIXME: Remove this temp, I want no allocation in this routine + !! Internal variables - ans = 0.0_DFP - tPoints = SIZE(lambda, 2) - a = 0 + INTEGER(I4B) :: a, ii, jj + REAL(DFP) :: temp, areal - !FIXME: Make these loop parallel + nrow = SIZE(lambda, 2) + ! tPoints = SIZE(lambda, 2) + ncol = pe1 + pe2 + pe3 - 3 + + ! ans = 0.0_DFP + a = 0 ! edge(1) = 1 -> 2 - temp = lambda(1, :) * lambda(2, :) DO ii = 1, pe1 - 1 - ans(:, a + ii) = temp * phi(1:tPoints, ii - 1) + areal = REAL(edgeOrient1**(ii + 1), kind=DFP) + ! ans(1:nrow, a + ii) = areal * temp * phi(1:nrow, ii - 1) + + DO jj = 1, nrow + temp = lambda(1, jj) * lambda(2, jj) * areal + ans(jj, a + ii) = temp * phi(jj, ii - 1) + END DO END DO ! edge(2) = 2 -> 3 a = pe1 - 1 - temp = lambda(2, :) * lambda(3, :) + DO ii = 1, pe2 - 1 - ans(:, a + ii) = temp & - * phi(1 + tPoints:2 * tPoints, ii - 1) + areal = REAL(edgeOrient2**(ii + 1), kind=DFP) + + DO jj = 1, nrow + temp = lambda(2, jj) * lambda(3, jj) * areal + ans(jj, a + ii) = temp * phi(jj + nrow, ii - 1) + END DO + END DO ! edge(3) = 3 -> 1 a = pe1 - 1 + pe2 - 1 - temp = lambda(3, :) * lambda(1, :) + DO ii = 1, pe3 - 1 - ans(:, a + ii) = temp & - * phi(1 + 2 * tPoints:3 * tPoints, ii - 1) + areal = REAL(edgeOrient3**(ii + 1), kind=DFP) + + DO jj = 1, nrow + temp = areal * lambda(3, jj) * lambda(1, jj) + ans(jj, a + ii) = temp * phi(jj + 2 * nrow, ii - 1) + END DO END DO END SUBROUTINE BarycentricEdgeBasis_Triangle2 @@ -151,6 +173,7 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle2 REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:order - 2) INTEGER(I4B) :: maxP, tPoints, ii, nrow, ncol +INTEGER(I4B), PARAMETER :: faceOrient(2) = [0, 1] tPoints = SIZE(lambda, 2) maxP = order - 2 @@ -167,10 +190,70 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle2 CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=ans, nrow=nrow, ncol=ncol) CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & - ans=ans) + ans=ans, nrow=nrow, ncol=ncol, faceOrient=faceOrient) END PROCEDURE BarycentricCellBasis_Triangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MakeFaceCase_Triangle(faceOrient, nrow, id, indx) + INTEGER(I4B), INTENT(IN) :: faceOrient(2) + INTEGER(I4B), INTENT(IN) :: nrow + INTEGER(I4B), INTENT(OUT) :: id + INTEGER(I4B), INTENT(OUT) :: indx(2, 2) + !! main program + + IF (faceOrient(2) .LT. 0) THEN + SELECT CASE (faceOrient(1)) + CASE (1) + id = 2 + indx(1, 1) = 2 + indx(1, 2) = 1 + + CASE (2) + id = 3 + indx(1, 1) = 3 + indx(1, 2) = 2 + + CASE DEFAULT + id = 1 + indx(1, 1) = 1 + indx(1, 2) = 3 + + END SELECT + + ELSE + + SELECT CASE (faceOrient(1)) + CASE (1) + id = 5 + indx(1, 1) = 2 + indx(1, 2) = 3 + + CASE (2) + id = 6 + indx(1, 1) = 1 + indx(1, 2) = 2 + + CASE default + id = 4 + indx(1, 1) = 3 + indx(1, 2) = 1 + + END SELECT + + END IF + + indx(1, 1) = nrow * (indx(1, 1) - 1) + 1 + indx(2, 1) = indx(1, 1) + nrow - 1 + + indx(1, 2) = nrow * (indx(1, 2) - 1) + 1 + indx(2, 2) = indx(1, 2) + nrow - 1 + +END SUBROUTINE MakeFaceCase_Triangle + !---------------------------------------------------------------------------- ! BarycentricCellBasis_Triangle !---------------------------------------------------------------------------- @@ -179,36 +262,56 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle2 ! date: 28 Oct 2022 ! summary: Eval basis in the cell of reference triangle (internal only) -PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans) +PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans, & + nrow, ncol, faceOrient) INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 + !! order in the cell of triangle, it should be greater than 2 REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barcentric coordinates + !! point of evaluation in terms of barcentric coordinates REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points - !! (lambda2-lambda1), - !! (lambda3-lambda2), - !! (lambda1-lambda3) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points + !! (lambda2-lambda1), + !! (lambda3-lambda2), + !! (lambda1-lambda3) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 REAL(DFP), INTENT(INOUT) :: ans(:, :) ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = size(lambda, 2) + !! ncol = INT((order - 1) * (order - 2) / 2) + INTEGER(I4B), INTENT(IN) :: faceOrient(2) - INTEGER(I4B) :: tp, k1, k2, cnt - REAL(DFP) :: temp(SIZE(lambda, 2)) - !! FIXME: Remove this temp from there, no allocation is our goal + INTEGER(I4B) :: k1, k2, cnt, id, indx(2, 2), aint, bint, ii + REAL(DFP) :: temp, areal, breal + + nrow = SIZE(lambda, 2) + ncol = INT((order - 1) * (order - 2) / 2) - tp = SIZE(lambda, 2) - temp = lambda(1, :) * lambda(2, :) * lambda(3, :) cnt = 0 - ! FIXME: Make this loop parallel + CALL MakeFaceCase_Triangle(faceOrient=faceOrient, nrow=nrow, id=id, & + indx=indx) + + aint = indx(1, 1) - 1 + bint = indx(1, 2) - 1 DO k1 = 1, order - 2 + areal = REAL(faceOrient(2)**(k1 + 1), kind=DFP) + DO k2 = 1, order - 1 - k1 + breal = REAL(faceOrient(2)**(k2 + 1), kind=DFP) + breal = breal * areal + cnt = cnt + 1 - ans(:, cnt) = temp * phi(1:tp, k1 - 1) * & - & phi(1 + 2 * tp:3 * tp, k2 - 1) + + DO ii = 1, nrow + + temp = lambda(1, ii) * lambda(2, ii) * lambda(3, ii) * breal + + ans(ii, cnt) = temp * phi(aint + ii, k1 - 1) * phi(bint + ii, k2 - 1) + END DO + END DO END DO @@ -229,8 +332,30 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle1 -INTEGER(I4B) :: a, b, ii -INTEGER(I4B) :: maxP +INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1] + +CALL BarycentricHeirarchicalBasis_Triangle3(order=order, pe1=pe1, pe2=pe2, & + pe3=pe3, lambda=lambda, refTriangle=refTriangle, edgeOrient1=orient, & + edgeOrient2=orient, edgeOrient3=orient, faceOrient=faceOrient, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricHeirarchicalBasis_Triangle1 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2 +CALL BarycentricHeirarchicalBasis_Triangle1(order=order, pe1=order, & + pe2=order, pe3=order, lambda=lambda, & + refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE BarycentricHeirarchicalBasis_Triangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle3 +INTEGER(I4B) :: a, b, ii, maxP, indx(2) REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), & 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)) REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) @@ -253,7 +378,7 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) ! Vertex basis function -ans = 0.0_DFP +!FIXME: Add nrow and ncol info in BarycentricVertexBasis_Triangle CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3)) ! Edge basis function @@ -264,7 +389,9 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 a = b + 1 b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, ans=ans(:, a:b)) + lambda=lambda, phi=phi, ans=ans(:, a:), nrow=indx(1), & + ncol=indx(2), edgeOrient1=edgeOrient1, edgeOrient2=edgeOrient2, & + edgeOrient3=edgeOrient3) END IF ! Cell basis function @@ -272,20 +399,10 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 a = b + 1 b = a - 1 + INT((order - 1) * (order - 2) / 2) CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & - ans=ans(:, a:b)) + ans=ans(1:nrow, a:b), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient) END IF -END PROCEDURE BarycentricHeirarchicalBasis_Triangle1 - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2 -CALL BarycentricHeirarchicalBasis_Triangle1(order=order, pe1=order, & - pe2=order, pe3=order, lambda=lambda, & - refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE BarycentricHeirarchicalBasis_Triangle2 +END PROCEDURE BarycentricHeirarchicalBasis_Triangle3 !---------------------------------------------------------------------------- ! HeirarchicalBasis_Triangle From dd526ca731820dd413a7c71a808cfea92ee5c0ee Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 5 Jul 2024 09:50:23 +0900 Subject: [PATCH 168/359] update in triangle interpolation --- src/modules/Polynomial/src/TriangleInterpolationUtility.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 197c96045..f2a594c88 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -1021,7 +1021,7 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle INTERFACE MODULE PURE FUNCTION EdgeBasis_Triangle(pe1, pe2, pe3, xij, refTriangle) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe1 !! order on left vertical edge (e1), should be greater than 1 INTEGER(I4B), INTENT(IN) :: pe2 From 97f31c2666c382cca27511f32b97e802cba78ddc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 5 Jul 2024 10:09:44 +0900 Subject: [PATCH 169/359] updates in quadrangle interpolation --- .../src/QuadrangleInterpolationUtility.F90 | 137 +++++------------- 1 file changed, 36 insertions(+), 101 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 0bce703a8..23fbfe91a 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -116,7 +116,7 @@ END FUNCTION GetTotalInDOF_Quadrangle INTERFACE MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) & - & RESULT(ans) + RESULT(ans) CHARACTER(*), INTENT(IN) :: baseContinuity !! Cointinuity (conformity) of basis functions !! "H1", "HDiv", "HCurl", "DG" @@ -137,8 +137,8 @@ END FUNCTION RefElemDomain_Quadrangle INTERFACE MODULE FUNCTION FacetConnectivity_Quadrangle( & - & baseInterpol, & - & baseContinuity) RESULT(ans) + baseInterpol, & + baseContinuity) RESULT(ans) CHARACTER(*), INTENT(IN) :: baseInterpol CHARACTER(*), INTENT(IN) :: baseContinuity INTEGER(I4B) :: ans(2, 4) @@ -152,11 +152,8 @@ END FUNCTION FacetConnectivity_Quadrangle !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION QuadratureNumber_Quadrangle( & - & p, & - & q, & - & quadType1, & - & quadType2) RESULT(ans) + MODULE PURE FUNCTION QuadratureNumber_Quadrangle(p, q, quadType1, & + quadType2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p, q INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 INTEGER(I4B) :: ans(2) @@ -696,7 +693,7 @@ END SUBROUTINE IJ2VEFC_Quadrangle INTERFACE MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_Clockwise( & - & xi, eta, temp, p, q, startNode) + xi, eta, temp, p, q, startNode) REAL(DFP), INTENT(IN) :: xi(:, :) REAL(DFP), INTENT(IN) :: eta(:, :) REAL(DFP), INTENT(OUT) :: temp(:, :) @@ -716,7 +713,7 @@ END SUBROUTINE IJ2VEFC_Quadrangle_Clockwise INTERFACE MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise( & - & xi, eta, temp, p, q, startNode) + xi, eta, temp, p, q, startNode) REAL(DFP), INTENT(IN) :: xi(:, :) REAL(DFP), INTENT(IN) :: eta(:, :) REAL(DFP), INTENT(OUT) :: temp(:, :) @@ -768,7 +765,7 @@ END SUBROUTINE LagrangeCoeff_Quadrangle1_ INTERFACE LagrangeCoeff_Quadrangle MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial, it should be SIZE(v,2)-1 INTEGER(I4B), INTENT(IN) :: i @@ -1209,8 +1206,8 @@ MODULE PURE FUNCTION DubinerGradient_Quadrangle1(order, xij) RESULT(ans) !! points in biunit quadrangle, shape functions will be evaluated !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points REAL(DFP) :: ans(SIZE(xij, 2), & - & (order + 1_I4B) * (order + 2_I4B) / 2_I4B, & - & 2_I4B) + (order + 1_I4B) * (order + 2_I4B) / 2_I4B, & + 2_I4B) !! shape functions !! ans(:, j), jth shape functions at all points !! ans(j, :), all shape functions at jth point @@ -1288,19 +1285,8 @@ END SUBROUTINE DubinerGradient_Quadrangle1_ ! polynomial on biunit quadrangle. INTERFACE TensorProdBasis_Quadrangle - MODULE FUNCTION TensorProdBasis_Quadrangle1( & - & p, & - & q, & - & xij, & - & basisType1, & - & basisType2, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2) & - & RESULT(ans) + MODULE FUNCTION TensorProdBasis_Quadrangle1(p, q, xij, basisType1, & + basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q @@ -1401,20 +1387,8 @@ END SUBROUTINE TensorProdBasis_Quadrangle1_ ! outer product of x and y INTERFACE TensorProdBasis_Quadrangle - MODULE FUNCTION TensorProdBasis_Quadrangle2( & - & p, & - & q, & - & x, & - & y, & - & basisType1, & - & basisType2, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2) & - & RESULT(ans) + MODULE FUNCTION TensorProdBasis_Quadrangle2(p, q, x, y, basisType1, & + basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q @@ -1510,8 +1484,7 @@ END SUBROUTINE TensorProdBasis_Quadrangle2_ ! summary: Returns the vertex basis functions on biunit quadrangle INTERFACE VertexBasis_Quadrangle - MODULE PURE FUNCTION VertexBasis_Quadrangle1(x, y) & - & RESULT(ans) + MODULE PURE FUNCTION VertexBasis_Quadrangle1(x, y) RESULT(ans) REAL(DFP), INTENT(IN) :: x(:), y(:) !! point of evaluation REAL(DFP) :: ans(SIZE(x), 4) @@ -1646,7 +1619,7 @@ END SUBROUTINE VertexBasisGradient_Quadrangle2_ INTERFACE MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle(qe1, qe2, x, y) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: qe1 !! order on left vertical edge (e1), it should be greater than 1 !! It should be greater than 2 @@ -1688,7 +1661,7 @@ END SUBROUTINE VerticalEdgeBasis_Quadrangle_ INTERFACE MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle2(qe1, qe2, L1, L2) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: qe1 !! order on left vertical edge (e1), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: qe2 @@ -1792,7 +1765,7 @@ END SUBROUTINE HorizontalEdgeBasis_Quadrangle_ INTERFACE MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle2(pe3, pe4, L1, L2) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe3 !! order on bottom vertical edge (e3), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: pe4 @@ -2162,17 +2135,8 @@ 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(:, :) @@ -2251,14 +2215,8 @@ END SUBROUTINE LagrangeEvalAll_Quadrangle2_ ! summary: Returns quadrature points on reference quadrangle INTERFACE QuadraturePoint_Quadrangle - MODULE FUNCTION QuadraturePoint_Quadrangle1( & - & order, & - & quadType, & - & refQuadrangle, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Quadrangle1(order, quadType, & + refQuadrangle, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of integrand in x and y direction INTEGER(I4B), INTENT(IN) :: quadType @@ -2301,9 +2259,9 @@ END FUNCTION QuadraturePoint_Quadrangle1 !---------------------------------------------------------------------------- INTERFACE QuadraturePoint_Quadrangle - MODULE FUNCTION QuadraturePoint_Quadrangle2( & - & p, q, quadType1, quadType2, refQuadrangle, xij, alpha1, beta1, & - & lambda1, alpha2, beta2, lambda2) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Quadrangle2(p, q, quadType1, quadType2, & + refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order of integrand in x direction INTEGER(I4B), INTENT(IN) :: q @@ -2360,7 +2318,7 @@ END FUNCTION QuadraturePoint_Quadrangle2 INTERFACE QuadraturePoint_Quadrangle MODULE FUNCTION QuadraturePoint_Quadrangle3(nips, quadType, & - & refQuadrangle, xij, alpha, beta, lambda) RESULT(ans) + refQuadrangle, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: nips(1) !! number of integration points in x and y direction INTEGER(I4B), INTENT(IN) :: quadType @@ -2403,10 +2361,9 @@ END FUNCTION QuadraturePoint_Quadrangle3 !---------------------------------------------------------------------------- INTERFACE QuadraturePoint_Quadrangle - MODULE FUNCTION QuadraturePoint_Quadrangle4( & - & nipsx, nipsy, quadType1, quadType2, & - & refQuadrangle, xij, alpha1, beta1, & - & lambda1, alpha2, beta2, lambda2) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Quadrangle4(nipsx, nipsy, quadType1, & + quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: nipsx(1) !! order of integrand in x direction INTEGER(I4B), INTENT(IN) :: nipsy(1) @@ -2462,14 +2419,8 @@ END FUNCTION QuadraturePoint_Quadrangle4 ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeGradientEvalAll_Quadrangle - MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( & - & order, & - & x, & - & xij, & - & coeff, & - & firstCall, & - & basisType, & - & alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1(order, x, xij, coeff, & + firstCall, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -2572,14 +2523,8 @@ END SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_ ! Ultraspherical polynomials with lambda = 3/2. INTERFACE HeirarchicalBasisGradient_Quadrangle - MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle1( & - & pb, & - & qb, & - & pe3, & - & pe4, & - & qe1, & - & qe2, & - & xij) RESULT(ans) + MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle1(pb, qb, pe3, pe4, & + qe1, qe2, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pb !! order of interpolation inside the quadrangle in x1 direction INTEGER(I4B), INTENT(IN) :: qb @@ -2678,19 +2623,9 @@ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_ ! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle INTERFACE TensorProdBasisGradient_Quadrangle - MODULE FUNCTION TensorProdBasisGradient_Quadrangle1( & - & p, & - & q, & - & xij, & - & basisType1, & - & basisType2, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2) & - & RESULT(ans) + MODULE FUNCTION TensorProdBasisGradient_Quadrangle1(p, q, xij, & + basisType1, basisType2, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q From 4ed479b8c98779d59466b67485b43dcd159bc6fa Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 6 Jul 2024 10:47:24 +0900 Subject: [PATCH 170/359] updates in line interpolation utility --- .../Polynomial/src/LineInterpolationUtility.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 1441e36ce..8e0904e84 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -285,15 +285,15 @@ END SUBROUTINE EquidistanceInPoint_Line1_ INTERFACE EquidistanceInPoint_Line MODULE PURE FUNCTION EquidistanceInPoint_Line2(order, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order + !! order REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! coordinates of point 1 and point 2 in $x_{iJ}$ format - !! number of rows = nsd - !! number of cols = 2 + !! coordinates of point 1 and point 2 in $x_{iJ}$ format + !! number of rows = nsd + !! number of cols = 2 REAL(DFP), ALLOCATABLE :: ans(:, :) - !! Equidistnace points in $x_{iJ}$ format - !! The number of rows is equal to the number of rows in xij - !! (if xij present), otherwise, it is 1. + !! Equidistnace points in $x_{iJ}$ format + !! The number of rows is equal to the number of rows in xij + !! (if xij present), otherwise, it is 1. END FUNCTION EquidistanceInPoint_Line2 END INTERFACE EquidistanceInPoint_Line From 1e0c00539b5327ad8efce3c5f2d5205e25c04ec7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 6 Jul 2024 11:36:22 +0900 Subject: [PATCH 171/359] updates in quadrangle interpolation utility --- .../src/QuadrangleInterpolationUtility.F90 | 298 +--- ...QuadrangleInterpolationUtility@Methods.F90 | 1278 ++++++++--------- 2 files changed, 710 insertions(+), 866 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 23fbfe91a..92c47f195 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -17,25 +17,42 @@ MODULE QuadrangleInterpolationUtility USE GlobalData USE String_Class, ONLY: String + IMPLICIT NONE + PRIVATE + PUBLIC :: LagrangeDegree_Quadrangle PUBLIC :: LagrangeDOF_Quadrangle PUBLIC :: LagrangeInDOF_Quadrangle + PUBLIC :: EquidistancePoint_Quadrangle PUBLIC :: EquidistancePoint_Quadrangle_ + PUBLIC :: EquidistanceInPoint_Quadrangle + PUBLIC :: InterpolationPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle_ + PUBLIC :: LagrangeCoeff_Quadrangle PUBLIC :: LagrangeCoeff_Quadrangle_ + PUBLIC :: Dubiner_Quadrangle PUBLIC :: Dubiner_Quadrangle_ + +PUBLIC :: DubinerGradient_Quadrangle +PUBLIC :: DubinerGradient_Quadrangle_ + PUBLIC :: TensorProdBasis_Quadrangle + PUBLIC :: OrthogonalBasis_Quadrangle + PUBLIC :: VertexBasis_Quadrangle + PUBLIC :: VerticalEdgeBasis_Quadrangle + PUBLIC :: HorizontalEdgeBasis_Quadrangle + PUBLIC :: CellBasis_Quadrangle PUBLIC :: HeirarchicalBasis_Quadrangle @@ -43,12 +60,16 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: IJ2VEFC_Quadrangle_Clockwise PUBLIC :: IJ2VEFC_Quadrangle_AntiClockwise + PUBLIC :: LagrangeEvalAll_Quadrangle PUBLIC :: LagrangeEvalAll_Quadrangle_ + PUBLIC :: QuadraturePoint_Quadrangle PUBLIC :: QuadratureNumber_Quadrangle + PUBLIC :: FacetConnectivity_Quadrangle PUBLIC :: RefElemDomain_Quadrangle + PUBLIC :: LagrangeGradientEvalAll_Quadrangle PUBLIC :: LagrangeGradientEvalAll_Quadrangle_ @@ -56,9 +77,9 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: HeirarchicalBasisGradient_Quadrangle_ PUBLIC :: TensorProdBasisGradient_Quadrangle + PUBLIC :: OrthogonalBasisGradient_Quadrangle -PUBLIC :: DubinerGradient_Quadrangle -PUBLIC :: DubinerGradient_Quadrangle_ + PUBLIC :: GetTotalDOF_Quadrangle PUBLIC :: GetTotalInDOF_Quadrangle @@ -136,9 +157,8 @@ END FUNCTION RefElemDomain_Quadrangle ! summary: This function returns the edge connectivity of Quadrangle INTERFACE - MODULE FUNCTION FacetConnectivity_Quadrangle( & - baseInterpol, & - baseContinuity) RESULT(ans) + MODULE FUNCTION FacetConnectivity_Quadrangle(baseInterpol, baseContinuity) & + RESULT(ans) CHARACTER(*), INTENT(IN) :: baseInterpol CHARACTER(*), INTENT(IN) :: baseContinuity INTEGER(I4B) :: ans(2, 4) @@ -315,7 +335,7 @@ END FUNCTION LagrangeInDOF_Quadrangle2 !- The node numbering is according to Gmsh convention. INTERFACE EquidistancePoint_Quadrangle - MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & + MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order @@ -335,7 +355,7 @@ END FUNCTION EquidistancePoint_Quadrangle1 !---------------------------------------------------------------------------- INTERFACE EquidistancePoint_Quadrangle_ - MODULE RECURSIVE PURE SUBROUTINE EquidistancePoint_Quadrangle1_(order, & + MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle1_(order, & ans, nrow, ncol, xij) INTEGER(I4B), INTENT(IN) :: order !! order @@ -424,7 +444,7 @@ END SUBROUTINE EquidistancePoint_Quadrangle2_ !- All points are inside the Quadrangle INTERFACE EquidistanceInPoint_Quadrangle - MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & + MODULE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order @@ -453,7 +473,7 @@ END FUNCTION EquidistanceInPoint_Quadrangle1 !- All points are inside the Quadrangle INTERFACE EquidistanceInPoint_Quadrangle - MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & + MODULE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order in x direction @@ -1507,40 +1527,6 @@ MODULE PURE SUBROUTINE VertexBasis_Quadrangle1_(x, y, ans, nrow, ncol) END SUBROUTINE VertexBasis_Quadrangle1_ END INTERFACE VertexBasis_Quadrangle_ -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE - MODULE PURE FUNCTION VertexBasis_Quadrangle2(L1, L2) RESULT(ans) - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP) :: ans(SIZE(L1, 1), 4) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE VertexBasis_Quadrangle2_(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 - END SUBROUTINE VertexBasis_Quadrangle2_ -END INTERFACE - !---------------------------------------------------------------------------- ! VertexBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1550,12 +1536,12 @@ END SUBROUTINE VertexBasis_Quadrangle2_ ! summary: Returns the vertex basis functions on biunit quadrangle INTERFACE VertexBasis_Quadrangle - MODULE PURE FUNCTION VertexBasis_Quadrangle3(xij) RESULT(ans) + MODULE PURE FUNCTION VertexBasis_Quadrangle2(xij) RESULT(ans) REAL(DFP), INTENT(IN) :: xij(:, :) !! point of evaluation REAL(DFP) :: ans(SIZE(xij, 2), 4) !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Quadrangle3 + END FUNCTION VertexBasis_Quadrangle2 END INTERFACE VertexBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1563,44 +1549,16 @@ END FUNCTION VertexBasis_Quadrangle3 !---------------------------------------------------------------------------- INTERFACE VertexBasis_Quadrangle_ - MODULE PURE SUBROUTINE VertexBasis_Quadrangle3_(xij, ans, nrow, ncol) + MODULE PURE SUBROUTINE VertexBasis_Quadrangle2_(xij, ans, nrow, ncol) REAL(DFP), INTENT(IN) :: xij(:, :) !! point of evaluation REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(SIZE(xij, 2), 4) !! ans(:,v1) basis function of vertex v1 at all points INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE VertexBasis_Quadrangle3_ + END SUBROUTINE VertexBasis_Quadrangle2_ END INTERFACE VertexBasis_Quadrangle_ -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -INTERFACE - MODULE PURE 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 - END SUBROUTINE VertexBasisGradient_Quadrangle2_ -END INTERFACE - !---------------------------------------------------------------------------- ! VerticalEdgeBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1655,65 +1613,6 @@ MODULE PURE SUBROUTINE VerticalEdgeBasis_Quadrangle_(qe1, qe2, x, y, & END SUBROUTINE VerticalEdgeBasis_Quadrangle_ END INTERFACE -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle2(qe1, qe2, L1, L2) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2) - END FUNCTION VerticalEdgeBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, & - ans, nrow, ncol) - 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 - END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_(qe1, qe2, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3) - 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 - END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ -END INTERFACE - !---------------------------------------------------------------------------- ! HorizontalEdgeBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1759,63 +1658,6 @@ MODULE PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle_(pe3, pe4, x, y, & END SUBROUTINE HorizontalEdgeBasis_Quadrangle_ END INTERFACE -!---------------------------------------------------------------------------- -!: -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle2(pe3, pe4, L1, L2) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2) - END FUNCTION HorizontalEdgeBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle2_(pe3, pe4, L1, L2, & - ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), pe3 + pe4 - 2) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_(pe3, pe4, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3) - 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 - END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ -END INTERFACE - !---------------------------------------------------------------------------- ! CellBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1859,41 +1701,6 @@ MODULE PURE SUBROUTINE CellBasis_Quadrangle_(pb, qb, x, y, ans, nrow, & END SUBROUTINE CellBasis_Quadrangle_ END INTERFACE -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION CellBasis_Quadrangle2(pb, qb, L1, L2) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) - END FUNCTION CellBasis_Quadrangle2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, & - ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE CellBasis_Quadrangle2_ -END INTERFACE - !---------------------------------------------------------------------------- ! CellBasisGradient_Quadrangle !---------------------------------------------------------------------------- @@ -2032,6 +1839,45 @@ MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle2_(p, q, xij, ans, & END SUBROUTINE HeirarchicalBasis_Quadrangle2_ END INTERFACE HeirarchicalBasis_Quadrangle_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Quadrangle_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle3_(pb, qb, pe3, pe4, & + qe1, qe2, xij, pe3Orient, pe4Orient, qe1Orient, qe2Orient, & + faceOrient, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: pe3Orient + !! orientation of edge 1 + INTEGER(I4B), INTENT(IN) :: pe4Orient + !! orientation of edge 2 + INTEGER(I4B), INTENT(IN) :: qe1Orient + !! orientation of edge 3 + INTEGER(I4B), INTENT(IN) :: qe2Orient + !! orientation of edge 4 + INTEGER(I4B), INTENT(IN) :: faceOrient(:) + !! orientation of face + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2), & + !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Quadrangle3_ +END INTERFACE HeirarchicalBasis_Quadrangle_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Quadrangle !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 9c3b35b73..db36fec8c 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -38,15 +38,15 @@ SELECT CASE (bi) CASE ("HIE", "HEI", "ORT") - ans(:, 1) = [1, 2] - ans(:, 2) = [4, 3] - ans(:, 3) = [1, 4] - ans(:, 4) = [2, 3] + ans(1:2, 1) = [1, 2] + ans(1:2, 2) = [4, 3] + ans(1:2, 3) = [1, 4] + ans(1:2, 4) = [2, 3] CASE DEFAULT - ans(:, 1) = [1, 2] - ans(:, 2) = [2, 3] - ans(:, 3) = [3, 4] - ans(:, 4) = [4, 1] + 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 SELECT END PROCEDURE FacetConnectivity_Quadrangle @@ -75,20 +75,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeDegree_Quadrangle1_ -INTEGER(I4B) :: ii, jj, kk - -nrow = LagrangeDOF_Quadrangle(order=order) -ncol = 2 - -kk = 0 -DO jj = 0, order - DO ii = 0, order - kk = kk + 1 - ans(kk, 1) = ii - ans(kk, 2) = jj - END DO -END DO - +CALL LagrangeDegree_Quadrangle2_(ans=ans, p=order, q=order, nrow=nrow, & + ncol=ncol) END PROCEDURE LagrangeDegree_Quadrangle1_ !---------------------------------------------------------------------------- @@ -109,18 +97,17 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeDegree_Quadrangle2_ -INTEGER(I4B) :: ii, jj, kk +INTEGER(I4B) :: ii, jj, p1 + nrow = LagrangeDOF_Quadrangle(p=p, q=q) ncol = 2 +p1 = p1 + 1 -kk = 0 -DO jj = 0, q - DO ii = 0, p - kk = kk + 1 - ans(kk, 1) = ii - ans(kk, 2) = jj - END DO +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_ !---------------------------------------------------------------------------- @@ -198,112 +185,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Quadrangle1_ -INTEGER(I4B) :: ne, indx(3) -REAL(DFP) :: x(3, 5), xin(3, 4), e1(3), e2(3), lam, avar, mu - -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP - -ncol = 0 - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) - x(1:nrow, 1:4) = xij(1:nrow, 1:4) -ELSE - nrow = 2_I4B - x(1:2, 1:4) = RefQuadrangleCoord("BIUNIT") - x(3:4, 1:4) = 0.0_DFP -END IF - -IF (order .EQ. 0_I4B) THEN - ncol = 1 - ans(1:nrow, 1) = SUM(x(1:nrow, 1:4), dim=2_I4B) / 4.0_DFP - RETURN -END IF - -x(:, 5) = x(:, 1) !! cycic effect - -! ncol = LagrangeDOF_Quadrangle(order=order) -! points on vertex - -ans(1:nrow, 1:4) = x(1:nrow, 1:4) -ncol = 4 - -IF (order .EQ. 1_I4B) RETURN - -! points on edge -ne = LagrangeInDOF_Line(order=order) - -CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 1:2), & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) -ncol = ncol + indx(2) - -CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 2:3), & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) -ncol = ncol + indx(2) - -CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 3:4), & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) -ncol = ncol + indx(2) - -CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, 4:5), & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) -ncol = ncol + indx(2) - -IF (order .EQ. 2_I4B) THEN - ans(1:nrow, ncol + 1) = SUM(x(1:nrow, 1:4), dim=2_I4B) / 4.0_DFP - ncol = ncol + 1 - RETURN -END IF - -! points on face -! IF (order .GT. 2_I4B) THEN - -e1 = x(:, 2) - x(:, 1) -avar = NORM2(e1) -e1 = e1 / avar -lam = avar / order -e2 = x(:, 4) - x(:, 1) -avar = NORM2(e2) -e2 = e2 / avar -mu = avar / order -xin(1:nrow, 1) = x(1:nrow, 1) + lam * e1(1:nrow) + mu * e2(1:nrow) - -e1 = x(:, 3) - x(:, 2) -avar = NORM2(e1) -e1 = e1 / avar -lam = avar / order -e2 = x(:, 1) - x(:, 2) -avar = NORM2(e2) -e2 = e2 / avar -mu = avar / order -xin(1:nrow, 2) = x(1:nrow, 2) + lam * e1(1:nrow) + mu * e2(1:nrow) - -e1 = x(:, 2) - x(:, 3) -avar = NORM2(e1) -e1 = e1 / avar -lam = avar / order -e2 = x(:, 4) - x(:, 3) -avar = NORM2(e2) -e2 = e2 / avar -mu = avar / order -xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow) - -e1 = x(:, 3) - x(:, 4) -avar = NORM2(e1) -e1 = e1 / avar -lam = avar / order -e2 = x(:, 1) - x(:, 4) -avar = NORM2(e2) -e2 = e2 / avar -mu = avar / order -xin(1:nrow, 4) = x(1:nrow, 4) + lam * e1(1:nrow) + mu * e2(1:nrow) - -! ans(1:nsd, i1:) = EquidistancePoint_Quadrangle( & -CALL EquidistancePoint_Quadrangle_(order=order - 2, xij=xin(1:nrow, 1:4), & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2)) - -ncol = ncol + indx(2) - +CALL EquidistancePoint_Quadrangle2_(p=order, q=order, ans=ans, nrow=nrow, & + ncol=ncol, xij=xij) END PROCEDURE EquidistancePoint_Quadrangle1_ !---------------------------------------------------------------------------- @@ -333,87 +216,58 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistanceInPoint_Quadrangle1 -INTEGER(I4B) :: nsd, n, ne, i1, i2 -REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 2 +END IF + +ncol = LagrangeInDOF_Quadrangle(order=order) -IF (order .LT. 2_I4B) THEN +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 -x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP +!---------------------------------------------------------------------------- +! 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 - nsd = SIZE(xij, 1) - x(1:nsd, 1:4) = xij(1:nsd, 1:4) + nrow = SIZE(xij, 1) ELSE - nsd = 2_I4B - x(1:nsd, 1) = [-1.0, -1.0] - x(1:nsd, 2) = [1.0, -1.0] - x(1:nsd, 3) = [1.0, 1.0] - x(1:nsd, 4) = [-1.0, 1.0] + nrow = 2 END IF -n = LagrangeInDOF_Quadrangle(order=order) -ALLOCATE (ans(nsd, n)) -ans = 0.0_DFP +ALLOCATE (temp(nrow, a)) + +CALL EquidistancePoint_Quadrangle2_(p=p, q=q, xij=xij, ans=temp, & + nrow=nrow, ncol=ncol) -! points on face -IF (order .EQ. 2_I4B) THEN - ans(1:nsd, 1) = SUM(x, dim=2_I4B) / 4.0_DFP +IF (b .EQ. 0) THEN + ALLOCATE (ans(0, 0)) ELSE - e1 = x(:, 2) - x(:, 1) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 1) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 2) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 2) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 2) - x(:, 3) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 4) - x(:, 3) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd) - - e1 = x(:, 3) - x(:, 4) - avar = NORM2(e1) - e1 = e1 / avar - lam = avar / order - e2 = x(:, 1) - x(:, 4) - avar = NORM2(e2) - e2 = e2 / avar - mu = avar / order - xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd) - - ans(1:nsd, 1:) = EquidistancePoint_Quadrangle1( & - & order=order - 2, & - & xij=xin(1:nsd, 1:4)) + ALLOCATE (ans(nrow, b)) + ans(1:nrow, 1:b) = temp(1:nrow, a - b + 1:) END IF -END PROCEDURE EquidistanceInPoint_Quadrangle1 -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- +DEALLOCATE (temp) -MODULE PROCEDURE EquidistanceInPoint_Quadrangle2 END PROCEDURE EquidistanceInPoint_Quadrangle2 !---------------------------------------------------------------------------- @@ -428,170 +282,243 @@ ! !---------------------------------------------------------------------------- +PURE SUBROUTINE GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, & + startNode) + INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) + INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) + INTEGER(I4B), INTENT(IN) :: startNode + + SELECT CASE (startNode) + CASE (1) + edgeConnectivity(1:2, 1) = [1, 2] + edgeConnectivity(1:2, 2) = [2, 3] + edgeConnectivity(1:2, 3) = [3, 4] + edgeConnectivity(1:2, 4) = [4, 1] + pointsOrder = [1, 2, 3, 4] + CASE (2) + edgeConnectivity(1:2, 1) = [2, 3] + edgeConnectivity(1:2, 2) = [3, 4] + edgeConnectivity(1:2, 3) = [4, 1] + edgeConnectivity(1:2, 4) = [1, 2] + pointsOrder = [2, 3, 4, 1] + CASE (3) + edgeConnectivity(1:2, 1) = [3, 4] + edgeConnectivity(1:2, 2) = [4, 1] + edgeConnectivity(1:2, 3) = [1, 2] + edgeConnectivity(1:2, 4) = [2, 3] + pointsOrder = [3, 4, 1, 2] + CASE (4) + edgeConnectivity(1:2, 1) = [4, 1] + edgeConnectivity(1:2, 2) = [1, 2] + edgeConnectivity(1:2, 3) = [2, 3] + edgeConnectivity(1:2, 4) = [3, 4] + pointsOrder = [4, 1, 2, 3] + END SELECT + +END SUBROUTINE GetEdgeConnectivityHelpAntiClock + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, & + startNode) + INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) + INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) + INTEGER(I4B), INTENT(IN) :: startNode + + SELECT CASE (startNode) + CASE (1) + edgeConnectivity(1:2, 1) = [1, 4] + edgeConnectivity(1:2, 2) = [4, 3] + edgeConnectivity(1:2, 3) = [3, 2] + edgeConnectivity(1:2, 4) = [2, 1] + pointsOrder = [1, 4, 3, 2] + CASE (2) + edgeConnectivity(1:2, 1) = [2, 1] + edgeConnectivity(1:2, 2) = [1, 4] + edgeConnectivity(1:2, 3) = [4, 3] + edgeConnectivity(1:2, 4) = [3, 2] + pointsOrder = [2, 1, 4, 3] + CASE (3) + edgeConnectivity(1:2, 1) = [3, 2] + edgeConnectivity(1:2, 2) = [2, 1] + edgeConnectivity(1:2, 3) = [1, 4] + edgeConnectivity(1:2, 4) = [4, 3] + pointsOrder = [3, 2, 1, 4] + CASE (4) + edgeConnectivity(1:2, 1) = [4, 3] + edgeConnectivity(1:2, 2) = [3, 2] + edgeConnectivity(1:2, 3) = [2, 1] + edgeConnectivity(1:2, 4) = [1, 4] + pointsOrder = [4, 3, 2, 1] + END SELECT + +END SUBROUTINE GetEdgeConnectivityHelpClock + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise ! internal variables -INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2 +INTEGER(I4B) :: cnt, m, ii, jj, ll, N, ij(2, 4), iedge, p1, p2 INTEGER(I4B), PARAMETER :: tEdges = 4 INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & -& pointsOrder(4) -REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & - & temp_in(:, :) + pointsOrder(4) +REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & + temp_in(:, :) + +LOGICAL(LGT) :: isok, abool ! vertices N = (p + 1) * (q + 1) cnt = 0 ll = -1 -SELECT CASE (startNode) -CASE (1) - edgeConnectivity(:, 1) = [1, 4] - edgeConnectivity(:, 2) = [4, 3] - edgeConnectivity(:, 3) = [3, 2] - edgeConnectivity(:, 4) = [2, 1] - pointsOrder = [1, 4, 3, 2] -CASE (2) - edgeConnectivity(:, 1) = [2, 1] - edgeConnectivity(:, 2) = [1, 4] - edgeConnectivity(:, 3) = [4, 3] - edgeConnectivity(:, 4) = [3, 2] - pointsOrder = [2, 1, 4, 3] -CASE (3) - edgeConnectivity(:, 1) = [3, 2] - edgeConnectivity(:, 2) = [2, 1] - edgeConnectivity(:, 3) = [1, 4] - edgeConnectivity(:, 4) = [4, 3] - pointsOrder = [3, 2, 1, 4] -CASE (4) - edgeConnectivity(:, 1) = [4, 3] - edgeConnectivity(:, 2) = [3, 2] - edgeConnectivity(:, 3) = [2, 1] - edgeConnectivity(:, 4) = [1, 4] - pointsOrder = [4, 3, 2, 1] -END SELECT +CALL GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, startNode) -IF (ALL([p, q] .EQ. 0_I4B)) THEN - temp(:, 1) = [xi(1, 1), eta(1, 1)] +isok = (p .EQ. 0) .AND. (q .EQ. 0) +IF (isok) THEN + temp(1, 1) = xi(1, 1) + temp(2, 1) = eta(1, 1) RETURN END IF -ij(:, 1) = [1, 1] -ij(:, 2) = [p + 1, 1] -ij(:, 3) = [p + 1, q + 1] -ij(:, 4) = [1, q + 1] +! INFO: This case is p = 0 and q .GE. 1 +abool = (p .EQ. 0) .AND. (q .GE. 1) +IF (abool) THEN + DO jj = 1, q + 1 + cnt = cnt + 1 + temp(1, jj) = xi(1, jj) + temp(2, jj) = eta(1, jj) + END DO + RETURN +END IF -IF (ALL([p, q] .GE. 1_I4B)) THEN - DO ii = 1, 4 +! INFO: This case is q = 0 and p .GE. 1 +abool = (q .EQ. 0) .AND. (p .GE. 1) +IF (abool) THEN + DO ii = 1, p + 1 cnt = cnt + 1 - jj = pointsOrder(ii) - temp(1:2, ii) = [ & - & xi(ij(1, jj), ij(2, jj)), & - & eta(ij(1, jj), ij(2, jj)) & - & ] + temp(1, ii) = xi(ii, 1) + temp(2, ii) = eta(ii, 1) END DO - IF (ALL([p, q] .EQ. 1_I4B)) RETURN + RETURN +END IF -ELSE - IF (p .EQ. 0_I4B) THEN - DO jj = 1, q + 1 - cnt = cnt + 1 - temp(1:2, jj) = [xi(1, jj), eta(1, jj)] - END DO - END IF +ij(1, 1) = 1 +ij(2, 1) = 1 - IF (q .EQ. 0_I4B) THEN - DO ii = 1, p + 1 - cnt = cnt + 1 - temp(1:2, ii) = [xi(ii, 1), eta(ii, 1)] - END DO - END IF +ij(1, 2) = p + 1 +ij(2, 2) = 1 -END IF +ij(1, 3) = p + 1 +ij(2, 3) = q + 1 -IF (ALL([p, q] .GE. 1_I4B)) THEN - DO iedge = 1, tEdges - p1 = edgeConnectivity(1, iedge) - p2 = edgeConnectivity(2, iedge) +ij(1, 4) = 1 +ij(2, 4) = q + 1 - IF (ij(1, p1) .EQ. ij(1, p2)) THEN - ii1 = ij(1, p1) - ii2 = ii1 - dii = 1 - ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN - ii1 = ij(1, p1) + 1 - ii2 = ij(1, p2) - 1 - dii = 1 - ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN - ii1 = ij(1, p1) - 1 - ii2 = ij(1, p2) + 1 - dii = -1 - END IF +isok = (p .GE. 1) .AND. (q .GE. 1) - IF (ij(2, p1) .EQ. ij(2, p2)) THEN - jj1 = ij(2, p1) - jj2 = jj1 - djj = 1 - ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN - jj1 = ij(2, p1) + 1 - jj2 = ij(2, p2) - 1 - djj = 1 - ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN - jj1 = ij(2, p1) - 1 - jj2 = ij(2, p2) + 1 - djj = -1 - END IF +IF (isok) THEN + + DO ii = 1, 4 + cnt = cnt + 1 + jj = pointsOrder(ii) + temp(1, ii) = xi(ij(1, jj), ij(2, jj)) + + temp(2, ii) = eta(ij(1, jj), ij(2, jj)) - DO ii = ii1, ii2, dii - DO jj = jj1, jj2, djj - cnt = cnt + 1 - temp(:, cnt) = [xi(ii, jj), eta(ii, jj)] - END DO - END DO END DO - ! internal nodes - IF (ALL([p, q] .GE. 2_I4B)) THEN +END IF - CALL Reallocate( & - & xi_in, & - & MAX(p - 1, 1_I4B), & - & MAX(q - 1_I4B, 1_I4B)) - CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) - CALL Reallocate(temp_in, 2, SIZE(xi_in)) +abool = (p .EQ. 1) .AND. (q .EQ. 1) +IF (abool) RETURN + +isok = (p .GE. 1) .AND. (q .GE. 1) +IF (.NOT. isok) RETURN + +DO iedge = 1, tEdges + p1 = edgeConnectivity(1, iedge) + p2 = edgeConnectivity(2, iedge) + + IF (ij(1, p1) .EQ. ij(1, p2)) THEN + ii1 = ij(1, p1) + ii2 = ii1 + dii = 1 + ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN + ii1 = ij(1, p1) + 1 + ii2 = ij(1, p2) - 1 + dii = 1 + ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN + ii1 = ij(1, p1) - 1 + ii2 = ij(1, p2) + 1 + dii = -1 + END IF - IF (p .LE. 1_I4B) THEN - ii1 = 1 - ii2 = 1 - ELSE - ii1 = 2 - ii2 = p - END IF + IF (ij(2, p1) .EQ. ij(2, p2)) THEN + jj1 = ij(2, p1) + jj2 = jj1 + djj = 1 + ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN + jj1 = ij(2, p1) + 1 + jj2 = ij(2, p2) - 1 + djj = 1 + ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN + jj1 = ij(2, p1) - 1 + jj2 = ij(2, p2) + 1 + djj = -1 + END IF - IF (q .LE. 1_I4B) THEN - jj1 = 1 - jj2 = 1 - ELSE - jj1 = 2 - jj2 = q - END IF + DO ii = ii1, ii2, dii + DO jj = jj1, jj2, djj + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END DO +END DO - xi_in = xi(ii1:ii2, jj1:jj2) - eta_in = eta(ii1:ii2, jj1:jj2) +! internal nodes +isok = (p .GE. 2) .AND. (q .GE. 2) +IF (.NOT. isok) RETURN - CALL IJ2VEFC_Quadrangle_Clockwise( & - & xi=xi_in, & - & eta=eta_in, & - & temp=temp_in, & - & p=MAX(p - 2, 0_I4B), & - & q=MAX(q - 2, 0_I4B), & - & startNode=startNode) +CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B)) +CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) +CALL Reallocate(temp_in, 2, SIZE(xi_in)) - ii1 = cnt + 1 - ii2 = ii1 + SIZE(temp_in, 2) - 1 - temp(1:2, ii1:ii2) = temp_in - END IF +IF (p .LE. 1_I4B) THEN + ii1 = 1 + ii2 = 1 +ELSE + ii1 = 2 + ii2 = p +END IF +IF (q .LE. 1_I4B) THEN + jj1 = 1 + jj2 = 1 +ELSE + jj1 = 2 + jj2 = q END IF +xi_in = xi(ii1:ii2, jj1:jj2) +eta_in = eta(ii1:ii2, jj1:jj2) + +CALL IJ2VEFC_Quadrangle_Clockwise(xi=xi_in, & + eta=eta_in, & + temp=temp_in, & + p=MAX(p - 2, 0_I4B), & + q=MAX(q - 2, 0_I4B), & + startNode=startNode) + +ii1 = cnt + 1 +ii2 = ii1 + SIZE(temp_in, 2) - 1 +temp(1:2, ii1:ii2) = temp_in + IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) @@ -604,56 +531,35 @@ MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise ! internal variables -INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2 +INTEGER(I4B) :: cnt, ii, jj, ll, N, ij(2, 4), iedge, p1, p2 INTEGER(I4B), PARAMETER :: tEdges = 4 INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & -& pointsOrder(4) -REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & - & temp_in(:, :) + pointsOrder(4) +REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & + temp_in(:, :) +LOGICAL(LGT) :: isok, abool ! vertices N = (p + 1) * (q + 1) cnt = 0 ll = -1 -SELECT CASE (startNode) -CASE (1) - edgeConnectivity(:, 1) = [1, 2] - edgeConnectivity(:, 2) = [2, 3] - edgeConnectivity(:, 3) = [3, 4] - edgeConnectivity(:, 4) = [4, 1] - pointsOrder = [1, 2, 3, 4] -CASE (2) - edgeConnectivity(:, 1) = [2, 3] - edgeConnectivity(:, 2) = [3, 4] - edgeConnectivity(:, 3) = [4, 1] - edgeConnectivity(:, 4) = [1, 2] - pointsOrder = [2, 3, 4, 1] -CASE (3) - edgeConnectivity(:, 1) = [3, 4] - edgeConnectivity(:, 2) = [4, 1] - edgeConnectivity(:, 3) = [1, 2] - edgeConnectivity(:, 4) = [2, 3] - pointsOrder = [3, 4, 1, 2] -CASE (4) - edgeConnectivity(:, 1) = [4, 1] - edgeConnectivity(:, 2) = [1, 2] - edgeConnectivity(:, 3) = [2, 3] - edgeConnectivity(:, 4) = [3, 4] - pointsOrder = [4, 1, 2, 3] -END SELECT +CALL GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, startNode) -IF (ALL([p, q] .EQ. 0_I4B)) THEN - temp(:, 1) = [xi(1, 1), eta(1, 1)] +isok = (p .EQ. 0) .AND. (q .EQ. 0) +IF (isok) THEN + temp(1, 1) = xi(1, 1) + temp(2, 1) = eta(1, 1) RETURN END IF -ij(:, 1) = [1, 1] -ij(:, 2) = [p + 1, 1] -ij(:, 3) = [p + 1, q + 1] -ij(:, 4) = [1, q + 1] +ij(1:2, 1) = [1, 1] +ij(1:2, 2) = [p + 1, 1] +ij(1:2, 3) = [p + 1, q + 1] +ij(1:2, 4) = [1, q + 1] -IF (ALL([p, q] .GE. 1_I4B)) THEN +isok = (p .GE. 1) .AND. (q .GE. 1) +IF (isok) THEN DO ii = 1, 4 cnt = cnt + 1 jj = pointsOrder(ii) @@ -662,9 +568,12 @@ & eta(ij(1, jj), ij(2, jj)) & & ] END DO - IF (ALL([p, q] .EQ. 1_I4B)) RETURN + + abool = (p .EQ. 1) .AND. (q .EQ. 1) + IF (abool) RETURN ELSE + DO ii = 1, MIN(p, 1) + 1 DO jj = 1, MIN(q, 1) + 1 cnt = cnt + 1 @@ -828,11 +737,6 @@ layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, & ans=y, tsize=tsize) -! CALL Reallocate(ans, nsd, (p + 1) * (q + 1)) -! CALL Reallocate(temp, 2, (p + 1) * (q + 1)) -! xi = 0.0_DFP -! eta = 0.0_DFP - kk = 0 DO ii = 1, p + 1 DO jj = 1, q + 1 @@ -950,7 +854,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Quadrangle4_ -INTEGER(I4B) :: basisType0, ii, jj, indx +INTEGER(I4B) :: basisType0 basisType0 = Input(default=Monomial, option=basisType) @@ -987,7 +891,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Quadrangle5_ -INTEGER(I4B) :: ii, jj, kk, indx, basisType(2) +INTEGER(I4B) :: jj, kk, basisType(2) basisType(1) = Input(default=Monomial, option=basisType1) basisType(2) = Input(default=Monomial, option=basisType2) @@ -1026,36 +930,57 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Dubiner_Quadrangle1_ -REAL(DFP) :: P1(SIZE(xij, 2), order + 1), P2(SIZE(xij, 2), order + 1) -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) -REAL(DFP) :: avec(SIZE(xij, 2)), alpha, beta -INTEGER(I4B) :: k1, k2, max_k2, cnt +#define TP size(xij, 2) + +REAL(DFP) :: P1(TP, order + 1), P2(TP, order + 1), temp(TP, 3) + +REAL(DFP) :: alpha, beta + +INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii + +#undef TP -x = xij(1, :) -y = xij(2, :) nrow = SIZE(xij, 2) ncol = (order + 1) * (order + 2) / 2 -P1 = LegendreEvalAll(n=order, x=x) +CALL LegendreEvalAll_(n=order, x=xij(1, :), ans=P1, nrow=indx(1), & + ncol=indx(2)) ! we do not need x now, so let store (1-y)/2 in x -x = 0.5_DFP * (1.0_DFP - y) +DO CONCURRENT(ii=1:nrow) + temp(ii, 3) = xij(2, ii) + temp(ii, 1) = 0.5_DFP * (1.0_DFP - temp(ii, 3)) +END DO + alpha = 0.0_DFP beta = 0.0_DFP cnt = 0 +! temp1 = 0.5 * (1.0 - y) +! temp3 = y + DO k1 = 0, order - avec = (x)**k1 ! note here x = 0.5_DFP*(1-y) + !! note here temp1 is + !! note here x = 0.5_DFP*(1-y) + DO CONCURRENT(ii=1:nrow) + temp(ii, 2) = temp(ii, 1)**k1 + END DO + alpha = 2.0_DFP * k1 + 1.0_DFP max_k2 = order - k1 - P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta) + ! P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta) + CALL JacobiEvalAll_(n=max_k2, x=temp(:, 3), alpha=alpha, beta=beta, ans=P2, & + nrow=indx(1), ncol=indx(2)) DO k2 = 0, max_k2 cnt = cnt + 1 - ans(:, cnt) = P1(:, k1 + 1) * avec * P2(:, k2 + 1) + + DO CONCURRENT(ii=1:nrow) + ans(ii, cnt) = P1(ii, k1 + 1) * temp(ii, 2) * P2(ii, k2 + 1) + END DO END DO END DO @@ -1079,8 +1004,8 @@ MODULE PROCEDURE DubinerGradient_Quadrangle1_ REAL(DFP), DIMENSION(SIZE(xij, 2), order + 1) :: P1, P2, dP1, dP2 REAL(DFP), DIMENSION(SIZE(xij, 2)) :: avec, bvec, x, y -REAL(DFP) :: alpha, beta -INTEGER(I4B) :: k1, k2, max_k2, cnt +REAL(DFP) :: alpha, beta, areal +INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii tsize1 = SIZE(xij, 2) tsize2 = (order + 1) * (order + 2) / 2 @@ -1088,8 +1013,13 @@ x = xij(1, :) y = xij(2, :) -P1 = LegendreEvalAll(n=order, x=x) -dP1 = LegendreGradientEvalAll(n=order, x=x) + +! P1 = LegendreEvalAll(n=order, x=x) +CALL LegendreEvalAll_(n=order, x=x, ans=P1, nrow=indx(1), ncol=indx(2)) + +! dP1 = LegendreGradientEvalAll(n=order, x=x) +CALL LegendreGradientEvalAll_(n=order, x=x, ans=dP1, nrow=indx(1), & + ncol=indx(2)) ! we do not need x now, so let store (1-y)/2 in x x = 0.5_DFP * (1.0_DFP - y) @@ -1104,24 +1034,25 @@ max_k2 = order - k1 - P2(:, 1:max_k2 + 1) = JacobiEvalAll( & - & n=max_k2, & - & x=y, & - & alpha=alpha, & - & beta=beta) + CALL JacobiEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, & + ans=P2, nrow=indx(1), ncol=indx(2)) - dP2(:, 1:max_k2 + 1) = JacobiGradientEvalAll( & - & n=max_k2, & - & x=y, & - & alpha=alpha, & - & beta=beta) + CALL JacobiGradientEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, & + ans=dP2, nrow=indx(1), ncol=indx(2)) + + areal = REAL(k1, DFP) DO k2 = 0, max_k2 cnt = cnt + 1 - ans(:, cnt, 1) = dP1(:, k1 + 1) * avec * P2(:, k2 + 1) - ans(:, cnt, 2) = P1(:, k1 + 1) * bvec * & - & (x * dP2(:, k2 + 1) - 0.5_DFP * REAL(k1, DFP) * P2(:, k2 + 1)) + + DO CONCURRENT(ii=1:tsize1) + ans(ii, cnt, 1) = dP1(ii, k1 + 1) * avec(ii) * P2(ii, k2 + 1) + ans(ii, cnt, 2) = P1(ii, k1 + 1) * bvec(ii) * & + (x(ii) * dP2(ii, k2 + 1) - 0.5_DFP * areal * P2(ii, k2 + 1)) + END DO + END DO + END DO END PROCEDURE DubinerGradient_Quadrangle1_ @@ -1174,7 +1105,7 @@ MODULE PROCEDURE TensorProdBasis_Quadrangle1_ REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: ii, k1, k2, cnt, aint, bint +INTEGER(I4B) :: k1, k2, cnt, aint, bint nrow = SIZE(xij, 2) ncol = (p + 1) * (q + 1) @@ -1260,70 +1191,86 @@ ans(1:nrow, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y) END PROCEDURE VertexBasis_Quadrangle1_ -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL VertexBasis_Quadrangle2_(L1, L2, ans, nrow, ncol) -END PROCEDURE VertexBasis_Quadrangle2 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE VertexBasis_Quadrangle2_ -INTEGER(I4B) :: ii +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 -nrow = SIZE(L1, 1) -ncol = 4 + !! internal variable + INTEGER(I4B) :: ii -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 + nrow = SIZE(L1, 1) + ncol = 4 -END PROCEDURE VertexBasis_Quadrangle2_ + 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_Quadrangle3 +MODULE PROCEDURE VertexBasis_Quadrangle2 INTEGER(I4B) :: nrow, ncol -CALL VertexBasis_Quadrangle3_(xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE VertexBasis_Quadrangle3 +CALL VertexBasis_Quadrangle2_(xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE VertexBasis_Quadrangle2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE VertexBasis_Quadrangle3_ -! ans = VertexBasis_Quadrangle1( & +MODULE PROCEDURE VertexBasis_Quadrangle2_ CALL VertexBasis_Quadrangle1_(x=xij(1, :), y=xij(2, :), ans=ans, & nrow=nrow, ncol=ncol) -END PROCEDURE VertexBasis_Quadrangle3_ +END PROCEDURE VertexBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! VertexBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- -MODULE PROCEDURE VertexBasisGradient_Quadrangle2_ -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 PROCEDURE 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 @@ -1331,7 +1278,8 @@ MODULE PROCEDURE VerticalEdgeBasis_Quadrangle INTEGER(I4B) :: nrow, ncol -CALL VerticalEdgeBasis_Quadrangle_(qe1, qe2, x, y, ans, nrow, ncol) +CALL VerticalEdgeBasis_Quadrangle_(qe1=qe1, qe2=qe2, x=x, y=y, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE VerticalEdgeBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1341,91 +1289,114 @@ MODULE PROCEDURE VerticalEdgeBasis_Quadrangle_ ! REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) INTEGER(I4B) :: maxQ, k2, cnt, aint, bint -REAL(DFP), ALLOCATABLE :: L2(:, :) - -nrow = SIZE(x) -ncol = qe1 + qe2 - 2 +INTEGER(I4B), PARAMETER :: maxP = 1, orient = 1 +REAL(DFP), ALLOCATABLE :: L2(:, :), L1(:, :) maxQ = MAX(qe1, qe2) -ALLOCATE (L2(1:SIZE(y), 0:maxQ)) +cnt = SIZE(y) +ALLOCATE (L2(1:cnt, 0:maxQ), L1(1:cnt, 0:maxP)) ! L2 = LobattoEvalAll(n=maxQ, x=y) CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) +CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, 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) -cnt = 0 - -DO k2 = 2, qe1 - cnt = cnt + 1 - ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP - x(1:nrow)) * L2(1:nrow, k2) -END DO - -DO k2 = 2, qe2 - cnt = cnt + 1 - ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP + x(1:nrow)) * L2(1:nrow, k2) -END DO - -DEALLOCATE (L2) +DEALLOCATE (L2, L1) END PROCEDURE VerticalEdgeBasis_Quadrangle_ -!---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, ans, nrow, ncol) -END PROCEDURE VerticalEdgeBasis_Quadrangle2 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2_ -INTEGER(I4B) :: k2, cnt - -nrow = SIZE(L1, 1) -ncol = qe1 + qe2 - 2 - -cnt = 0 -DO k2 = 2, qe1 - cnt = cnt + 1 - ans(1:nrow, cnt) = L1(1:nrow, 0) * L2(1:nrow, k2) -END DO +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 -DO k2 = 2, qe2 - cnt = cnt + 1 - ans(1:nrow, cnt) = L1(1:nrow, 1) * L2(1:nrow, k2) -END DO + !! right vertical + DO CONCURRENT(k2=2:qe2, ii=1:nrow) + ans(ii, cnt + k2 - 1) = (o2**k2) * L1(ii, 1) * L2(ii, k2) + END DO -END PROCEDURE VerticalEdgeBasis_Quadrangle2_ +END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! VerticalEdgeBasisGradient_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE VerticalEdgeBasisGradient_Quadrangle2_ -INTEGER(I4B) :: k2, cnt +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle -dim1 = SIZE(L1, 1) -dim2 = qe1 + qe2 - 2 -dim3 = 2 +PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_(qe1, qe2, & + L1, L2, dL1, dL2, ans, dim1, dim2, dim3) + 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 -cnt = 0 + INTEGER(I4B) :: k2, cnt -DO k2 = 2, qe1 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, 0) * L2(1:dim1, k2) - ans(1:dim1, cnt, 2) = L1(1:dim1, 0) * dL2(1:dim1, k2) -END DO + dim1 = SIZE(L1, 1) + dim2 = qe1 + qe2 - 2 + dim3 = 2 -DO k2 = 2, qe2 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, 1) * L2(1:dim1, k2) - ans(1:dim1, cnt, 2) = L1(1:dim1, 1) * dL2(1:dim1, k2) -END DO -END PROCEDURE VerticalEdgeBasisGradient_Quadrangle2_ + cnt = 0 + + DO k2 = 2, qe1 + cnt = cnt + 1 + ans(1:dim1, cnt, 1) = dL1(1:dim1, 0) * L2(1:dim1, k2) + ans(1:dim1, cnt, 2) = L1(1:dim1, 0) * dL2(1:dim1, k2) + END DO + + DO k2 = 2, qe2 + cnt = cnt + 1 + ans(1:dim1, cnt, 1) = dL1(1:dim1, 1) * L2(1:dim1, k2) + ans(1:dim1, cnt, 2) = L1(1:dim1, 1) * dL2(1:dim1, k2) + END DO + +END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- ! HorizontalEdgeBasis_Quadrangle @@ -1471,64 +1442,89 @@ END PROCEDURE HorizontalEdgeBasis_Quadrangle_ -!---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HorizontalEdgeBasis_Quadrangle2 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2_ -INTEGER(I4B) :: k1, cnt - -nrow = SIZE(L1, 1) -ncol = pe3 + pe4 - 2 - -cnt = 0 -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, 0) -END DO +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 -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, 1) -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 PROCEDURE HorizontalEdgeBasis_Quadrangle2_ +END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! HorizontalEdgeBasisGradient_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2_ -INTEGER(I4B) :: k1, cnt +PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_(pe3, pe4, & + L1, L2, dL1, dL2, ans, dim1, dim2, dim3) + 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 -dim1 = SIZE(L1, 1) -dim2 = pe3 + pe4 - 2 -dim3 = 2 + INTEGER(I4B) :: k1, cnt -cnt = 0 + dim1 = SIZE(L1, 1) + dim2 = pe3 + pe4 - 2 + dim3 = 2 -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 0) - ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 0) -END DO + cnt = 0 -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 1) - ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 1) -END DO -END PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2_ + DO k1 = 2, pe3 + cnt = cnt + 1 + ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 0) + ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 0) + END DO + + DO k1 = 2, pe4 + cnt = cnt + 1 + ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 1) + ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 1) + END DO + +END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- ! CellBasis_Quadrangle @@ -1569,35 +1565,48 @@ END PROCEDURE CellBasis_Quadrangle_ -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE CellBasis_Quadrangle2 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE CellBasis_Quadrangle2_ -INTEGER(I4B) :: k1, k2, cnt - -nrow = SIZE(L1, 1) -ncol = (pb - 1) * (qb - 1) - -cnt = 0 +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, 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 k1 = 2, pb - DO k2 = 2, qb - cnt = cnt + 1 - ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, k2) + DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow) + ans(ii, (q - 1) * (k1 - 2) + k2 - 1) = & + (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2) END DO -END DO -END PROCEDURE CellBasis_Quadrangle2_ + +END SUBROUTINE CellBasis_Quadrangle2_ !---------------------------------------------------------------------------- ! CellBasisGradient_Quadrangle @@ -1635,89 +1644,89 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_ -INTEGER(I4B) :: a, b, maxP, maxQ -! REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) -! REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) +INTEGER(I4B), 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) :: a, b, indx(4), maxP, maxQ REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) +LOGICAL(LGT) :: isok, abool nrow = SIZE(xij, 2) -ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 +! ncol = 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)) -! L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) -! L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) - -CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=a, ncol=b) -CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=a, ncol=b) +CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) ! Vertex basis function +CALL VertexBasis_Quadrangle3_(L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2)) -! ans(1:nrow, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) -CALL VertexBasis_Quadrangle2_(L1=L1, L2=L2, ans=ans, nrow=maxP, ncol=maxQ) +ncol = indx(2) ! Edge basis function - -b = 4 -IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2 - ! ans(1:nrow, a:b) = VerticalEdgeBasis_Quadrangle2( & - ! qe1=qe1, qe2=qe2, L1=L1, L2=L2) - +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(:, a:), nrow=maxP, ncol=maxQ) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), qe1Orient=qe1Orient, & + qe2Orient=qe2Orient) + + ncol = ncol + indx(2) END IF ! Edge basis function - -IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2 - ! ans(1:nrow, a:b) = HorizontalEdgeBasis_Quadrangle2( & - ! pe3=pe3, pe4=pe4, L1=L1, L2=L2) - +isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) +IF (isok) THEN CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & - ans=ans(:, a:), nrow=maxP, ncol=maxQ) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), pe3Orient=pe3Orient, & + pe4Orient=pe4Orient) + ncol = ncol + indx(2) END IF ! Cell basis function - -IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN - a = b + 1 - b = a - 1 + (pb - 1) * (qb - 1) - ! ans(1:nrow, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) +isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) +IF (isok) THEN CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, & - ans=ans(:, a:), nrow=maxP, ncol=maxQ) + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient) + ncol = ncol + indx(2) END IF DEALLOCATE (L1, L2) -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_ +END PROCEDURE HeirarchicalBasis_Quadrangle3_ !---------------------------------------------------------------------------- ! LagrangeEvallAll_Quadrangle @@ -1911,20 +1920,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Quadrangle1 -ans = QuadraturePoint_Quadrangle2( & - & p=order, & - & q=order, & - & quadType1=quadType, & - & quadType2=quadType, & - & xij=xij, & - & refQuadrangle=refQuadrangle, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda & - & ) +ans = QuadraturePoint_Quadrangle2(p=order, q=order, quadType1=quadType, & + quadType2=quadType, xij=xij, refQuadrangle=refQuadrangle, alpha1=alpha, & + beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda) END PROCEDURE QuadraturePoint_Quadrangle1 !---------------------------------------------------------------------------- @@ -2317,7 +2315,7 @@ MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_ REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: ii, k1, k2, cnt, indx(3) +INTEGER(I4B) :: k1, k2, cnt, indx(3) dim1 = SIZE(xij, 2) dim2 = (p + 1) * (q + 1) From 19863edf47f57e37586df97e0b0dee0b565ea74e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 6 Jul 2024 14:51:14 +0900 Subject: [PATCH 172/359] updates in quadrangle interpolation --- .../src/QuadrangleInterpolationUtility.F90 | 189 ++++++--- ...QuadrangleInterpolationUtility@Methods.F90 | 378 ++++++++++-------- 2 files changed, 350 insertions(+), 217 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 92c47f195..f6013fca8 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -712,8 +712,8 @@ END SUBROUTINE IJ2VEFC_Quadrangle ! summary: Convert format from IJ to VEFC INTERFACE - MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_Clockwise( & - xi, eta, temp, p, q, startNode) + MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_Clockwise(xi, eta, & + temp, p, q, startNode) REAL(DFP), INTENT(IN) :: xi(:, :) REAL(DFP), INTENT(IN) :: eta(:, :) REAL(DFP), INTENT(OUT) :: temp(:, :) @@ -732,8 +732,8 @@ END SUBROUTINE IJ2VEFC_Quadrangle_Clockwise ! summary: Convert format from IJ to VEFC INTERFACE - MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise( & - xi, eta, temp, p, q, startNode) + MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, & + temp, p, q, startNode) REAL(DFP), INTENT(IN) :: xi(:, :) REAL(DFP), INTENT(IN) :: eta(:, :) REAL(DFP), INTENT(OUT) :: temp(:, :) @@ -901,11 +901,7 @@ MODULE SUBROUTINE LagrangeCoeff_Quadrangle4_(order, xij, basisType, & REAL(DFP), INTENT(IN) :: xij(:, :) !! points in xij format, size(xij,2) INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! This parameter is needed when basisType is Jacobi @@ -935,19 +931,11 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle5(p, q, xij, basisType1, & !! points in xij format, size(xij,2) INTEGER(I4B), INTENT(IN) :: basisType1 !! basisType in x direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical INTEGER(I4B), INTENT(IN) :: basisType2 !! basisType in y direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 !! This parameter is needed when basisType is Jacobi @@ -982,19 +970,11 @@ MODULE SUBROUTINE LagrangeCoeff_Quadrangle5_(p, q, xij, basisType1, & !! points in xij format, size(xij,2) INTEGER(I4B), INTENT(IN) :: basisType1 !! basisType in x direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical INTEGER(I4B), INTENT(IN) :: basisType2 !! basisType in y direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 !! This parameter is needed when basisType is Jacobi @@ -1315,19 +1295,11 @@ MODULE FUNCTION TensorProdBasis_Quadrangle1(p, q, xij, basisType1, & !! points of evaluation in xij format INTEGER(I4B), INTENT(IN) :: basisType1 !! basis type in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical INTEGER(I4B), INTENT(IN) :: basisType2 !! basis type in x2 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 !! alpha1 needed when basisType1 "Jacobi" @@ -1701,27 +1673,6 @@ MODULE PURE SUBROUTINE CellBasis_Quadrangle_(pb, qb, x, y, ans, nrow, & END SUBROUTINE CellBasis_Quadrangle_ END INTERFACE -!---------------------------------------------------------------------------- -! CellBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & - dL1, dL2, ans, dim1, dim2, dim3) - 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 - END SUBROUTINE CellBasisGradient_Quadrangle2_ -END INTERFACE - !---------------------------------------------------------------------------- ! HeirarchicalBasis_Quadrangle !---------------------------------------------------------------------------- @@ -1843,6 +1794,44 @@ END SUBROUTINE HeirarchicalBasis_Quadrangle2_ ! !---------------------------------------------------------------------------- +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, & @@ -2460,6 +2449,86 @@ MODULE SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_(p, q, xij, & END SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_ END INTERFACE HeirarchicalBasisGradient_Quadrangle_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-06 +! summary: Basis gradient + +INTERFACE HeirarchicalBasisGradient_Quadrangle + MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle3(pb, qb, pe3, pe4, & + qe1, qe2, xij, qe1Orient, qe2Orient, pe3Orient, pe4Orient, faceOrient) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: qe1Orient + !! left vertical edge orientation + INTEGER(I4B), INTENT(IN) :: qe2Orient + !! right vertical edge orientation + INTEGER(I4B), INTENT(IN) :: pe3Orient + !! orientation of bottom horizontal edge + INTEGER(I4B), INTENT(IN) :: pe4Orient + !! orientation of top horizontal edge + INTEGER(I4B), INTENT(IN) :: faceOrient(3) + !! orientation of faces + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION HeirarchicalBasisGradient_Quadrangle3 +END INTERFACE HeirarchicalBasisGradient_Quadrangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Quadrangle_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Quadrangle3_(pb, qb, pe3, pe4, & + qe1, qe2, xij, qe1Orient, qe2Orient, pe3Orient, pe4Orient, faceOrient, & + ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: qe1Orient + !! left vertical edge orientation + INTEGER(I4B), INTENT(IN) :: qe2Orient + !! right vertical edge orientation + INTEGER(I4B), INTENT(IN) :: pe3Orient + !! orientation of bottom horizontal edge + INTEGER(I4B), INTENT(IN) :: pe4Orient + !! orientation of top horizontal edge + INTEGER(I4B), INTENT(IN) :: faceOrient(3) + !! orientation of faces + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1 = SIZE(xij, 2) + !! dim2 = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 + !! dim3 = 2 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE HeirarchicalBasisGradient_Quadrangle3_ +END INTERFACE HeirarchicalBasisGradient_Quadrangle_ + !---------------------------------------------------------------------------- ! TensorProdBasisGradient_Quadrangle !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index db36fec8c..b0b49a81c 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -32,22 +32,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FacetConnectivity_Quadrangle -CHARACTER(3) :: bi - -bi = UpperCase(baseInterpol(1:3)) - -SELECT CASE (bi) -CASE ("HIE", "HEI", "ORT") - ans(1:2, 1) = [1, 2] - ans(1:2, 2) = [4, 3] - ans(1:2, 3) = [1, 4] - ans(1:2, 4) = [2, 3] -CASE DEFAULT - 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 SELECT +ans(1:2, 1) = [1, 2] +ans(1:2, 2) = [2, 3] +ans(1:2, 3) = [3, 4] +ans(1:2, 4) = [4, 1] END PROCEDURE FacetConnectivity_Quadrangle !---------------------------------------------------------------------------- @@ -1105,28 +1093,21 @@ END SUBROUTINE GetEdgeConnectivityHelpClock MODULE PROCEDURE TensorProdBasis_Quadrangle1_ REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: k1, k2, cnt, aint, bint +INTEGER(I4B) :: k1, k2, ii nrow = SIZE(xij, 2) ncol = (p + 1) * (q + 1) -! P1 = BasisEvalAll_Line( & CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, ans=P1, & - nrow=aint, ncol=bint) + nrow=k1, ncol=k2) -! Q1 = BasisEvalAll_Line( & CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, & - nrow=aint, ncol=bint) - -cnt = 0 + nrow=k1, ncol=k2) -DO k2 = 1, q + 1 - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(1:nrow, cnt) = P1(1:nrow, k1) * Q1(1:nrow, k2) - END DO +DO CONCURRENT(k1=1:p + 1, k2=1:q + 1, ii=1:nrow) + ans(ii, (k2 - 1) * (p + 1) + k1) = P1(ii, k1) * Q1(ii, k2) END DO END PROCEDURE TensorProdBasis_Quadrangle1_ @@ -1149,23 +1130,20 @@ END SUBROUTINE GetEdgeConnectivityHelpClock MODULE PROCEDURE TensorProdBasis_Quadrangle2_ REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) -INTEGER(I4B) :: ii, jj, cnt +INTEGER(I4B) :: ii, jj -xij = 0.0_DFP -cnt = 0 +nrow = SIZE(x) +ncol = SIZE(y) -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 +DO CONCURRENT(ii=1:nrow, jj=1:ncol) + xij(1, ncol * (ii - 1) + jj) = x(ii) + xij(2, ncol * (ii - 1) + jj) = y(jj) END DO -! ans = TensorProdBasis_Quadrangle1( & 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) + beta2=beta2, lambda1=lambda1, lambda2=lambda2, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorProdBasis_Quadrangle2_ @@ -1288,18 +1266,19 @@ END SUBROUTINE VertexBasisGradient_Quadrangle2_ MODULE PROCEDURE VerticalEdgeBasis_Quadrangle_ ! REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) -INTEGER(I4B) :: maxQ, k2, cnt, aint, bint +INTEGER(I4B) :: maxQ, aint, bint INTEGER(I4B), PARAMETER :: maxP = 1, orient = 1 REAL(DFP), ALLOCATABLE :: L2(:, :), L1(:, :) maxQ = MAX(qe1, qe2) -cnt = SIZE(y) -ALLOCATE (L2(1:cnt, 0:maxQ), L1(1:cnt, 0:maxP)) +aint = SIZE(y) +nrow = SIZE(x) +ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ)) -! L2 = LobattoEvalAll(n=maxQ, x=y) -CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) 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) @@ -1331,9 +1310,8 @@ PURE SUBROUTINE VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, & 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 + ! 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) @@ -1361,39 +1339,47 @@ END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ ! summary: Returns the vertex basis functions on biunit quadrangle PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_(qe1, qe2, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3) + 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 + !! 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 + !! 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. + !! Lobatto polynomials in x and y direction. REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - !! Lobatto polynomials in x and y direction. + !! Lobatto polynomials in x and y direction. REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - !! dim1=SIZE(L1, 1) - !! dim2=qe1 + qe2 - 2 - !! dim3= 2 + !! 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 - INTEGER(I4B) :: k2, cnt + 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 = 0 + cnt = qe1 - 1 - DO k2 = 2, qe1 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, 0) * L2(1:dim1, k2) - ans(1:dim1, cnt, 2) = L1(1:dim1, 0) * dL2(1:dim1, k2) + 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 k2 = 2, qe2 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, 1) * L2(1:dim1, k2) - ans(1:dim1, cnt, 2) = L1(1:dim1, 1) * dL2(1:dim1, k2) + 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_ @@ -1412,33 +1398,25 @@ END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle_ -! REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4)) -INTEGER(I4B) :: maxP, k1, cnt, aint, bint -REAL(DFP), ALLOCATABLE :: L1(:, :) +INTEGER(I4B) :: maxP, aint, bint +INTEGER(I4B), PARAMETER :: maxQ = 1, orient = 1 -nrow = SIZE(x) -ncol = pe3 + pe4 - 2 +REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) maxP = MAX(pe3, pe4) -ALLOCATE (L1(1:nrow, 0:maxP)) - -! L1 = LobattoEvalAll(n=maxP, x=x) -CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) +nrow = SIZE(x) +aint = SIZE(y) -cnt = 0 +ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ)) -DO k1 = 2, pe3 - cnt = cnt + 1 - ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP - y(1:nrow)) * L1(1:nrow, k1) -END DO +CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) +CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) -DO k1 = 2, pe4 - cnt = cnt + 1 - ans(1:nrow, cnt) = 0.5_DFP * (1.0_DFP + y(1:nrow)) * L1(1:nrow, k1) -END DO +CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & + ans=ans, nrow=nrow, ncol=ncol, pe3Orient=orient, pe4Orient=orient) -DEALLOCATE (L1) +DEALLOCATE (L1, L2) END PROCEDURE HorizontalEdgeBasis_Quadrangle_ @@ -1491,37 +1469,46 @@ END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ !---------------------------------------------------------------------------- PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_(pe3, pe4, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3) + 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 + !! 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 + !! 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 + !! 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) - INTEGER(I4B) :: k1, cnt + 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 - cnt = 0 - - DO k1 = 2, pe3 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 0) - ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 0) + !! 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 - DO k1 = 2, pe4 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, 1) - ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, 1) + !! 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_ @@ -1543,25 +1530,13 @@ END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ MODULE PROCEDURE CellBasis_Quadrangle_ REAL(DFP) :: L1(1:SIZE(x), 0:pb) REAL(DFP) :: L2(1:SIZE(y), 0:qb) -INTEGER(I4B) :: k1, k2, cnt, aint, bint +INTEGER(I4B), PARAMETER :: faceOrient(3) = [1, 1, 1] -nrow = SIZE(x) -ncol = (pb - 1) * (qb - 1) - -! L1 = LobattoEvalAll(n=pb, x=x) -! L2 = LobattoEvalAll(n=qb, x=y) - -CALL LobattoEvalAll_(n=pb, x=x, ans=L1, nrow=aint, ncol=bint) -CALL LobattoEvalAll_(n=qb, x=y, ans=L2, nrow=aint, ncol=bint) +CALL LobattoEvalAll_(n=pb, x=x, ans=L1, nrow=nrow, ncol=ncol) +CALL LobattoEvalAll_(n=qb, x=y, ans=L2, nrow=nrow, ncol=ncol) -cnt = 0 - -DO k1 = 2, pb - DO k2 = 2, qb - cnt = cnt + 1 - ans(1:nrow, cnt) = L1(1:nrow, k1) * L2(1:nrow, k2) - END DO -END DO +CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, ans=ans, nrow=nrow, & + ncol=ncol, faceOrient=faceOrient) END PROCEDURE CellBasis_Quadrangle_ @@ -1585,7 +1560,8 @@ PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & !! face orientation !! Internal variables - INTEGER(I4B) :: k1, k2, ii, p, q, o1, o2 + INTEGER(I4B) :: k1, k2, ii, p, q + REAL(DFP) :: o1, o2 nrow = SIZE(L1, 1) ncol = (pb - 1) * (qb - 1) @@ -1612,22 +1588,51 @@ END SUBROUTINE CellBasis_Quadrangle2_ ! CellBasisGradient_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE CellBasisGradient_Quadrangle2_ -INTEGER(I4B) :: k1, k2, cnt +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) -dim1 = SIZE(L1, 1) -dim2 = (pb - 1) * (qb - 1) -dim3 = 2 + !! 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) -cnt = 0 -DO k1 = 2, pb - DO k2 = 2, qb - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dL1(1:dim1, k1) * L2(1:dim1, k2) - ans(1:dim1, cnt, 2) = L1(1:dim1, k1) * dL2(1:dim1, k2) END DO -END DO -END PROCEDURE CellBasisGradient_Quadrangle2_ + +END SUBROUTINE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- ! HeirarchicalBasis_Quadrangle @@ -1675,6 +1680,25 @@ END SUBROUTINE CellBasis_Quadrangle2_ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE HeirarchicalBasis_Quadrangle3 +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(xij, 2) +ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL HeirarchicalBasis_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & + qe1=qe1, qe2=qe2, xij=xij, pe3Orient=pe3Orient, pe4Orient=pe4Orient, & + qe1Orient=qe1Orient, qe2Orient=qe2Orient, faceOrient=faceOrient, & + ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE HeirarchicalBasis_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE HeirarchicalBasis_Quadrangle3_ INTEGER(I4B) :: a, b, indx(4), maxP, maxQ REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) @@ -2224,8 +2248,61 @@ END SUBROUTINE CellBasis_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) + +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 @@ -2249,52 +2326,39 @@ END SUBROUTINE CellBasis_Quadrangle2_ dim2 = indx(2) -IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN +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)) + dim2=indx(2), dim3=indx(3), qe1Orient=qe1Orient, qe2Orient=qe2Orient) dim2 = dim2 + indx(2) END IF ! Edge basis function -IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN +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)) + dim2=indx(2), dim3=indx(3), pe3Orient=pe3Orient, pe4Orient=pe4Orient) dim2 = dim2 + indx(2) END IF ! Cell basis function -IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN +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)) + dim2=indx(2), dim3=indx(3), faceOrient=faceOrient) dim2 = dim2 + indx(2) END IF -END PROCEDURE HeirarchicalBasisGradient_Quadrangle1_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Quadrangle -!---------------------------------------------------------------------------- +DEALLOCATE (L1, L2, dL1, dL2) -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2 -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_ +END PROCEDURE HeirarchicalBasisGradient_Quadrangle3_ !---------------------------------------------------------------------------- ! TensorProdBasisGradient_Quadrangle From b81346b445344f04d72ace86dd79705bf511b995 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 6 Jul 2024 15:45:42 +0900 Subject: [PATCH 173/359] updates in line interpolation --- .../src/LineInterpolationUtility.F90 | 9 +- .../src/LineInterpolationUtility@Methods.F90 | 158 ++++++++---------- 2 files changed, 69 insertions(+), 98 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 8e0904e84..2045e8627 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -1203,14 +1203,9 @@ MODULE FUNCTION OrthogonalBasis_Line1(order, xij, refLine, basisType, & !! point of evaluation !! Number of rows in xij is 1 CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! UNIT ! BIUNIT INTEGER(I4B), INTENT(IN) :: basisType - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto + !! Jacobi ! Ultraspherical ! Legendre ! Chebyshev ! Lobatto !! UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 69382768a..160b4a2db 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -1648,50 +1648,34 @@ END SUBROUTINE handle_error MODULE PROCEDURE HeirarchicalBasis_Line2_ CHARACTER(1) :: astr -REAL(DFP) :: temp(SIZE(xij, 2)) +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 +! nrow = SIZE(xij, 2) +! ncol = order + 1 SELECT CASE (astr) CASE ("U") CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=nrow) - IF (orient .EQ. -1) temp(1:nrow) = -1.0_DFP * temp(1:nrow) CALL EvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, ans=ans, & nrow=nrow, ncol=ncol) - !! Only the internal modes depends on the orientation - !! So we are reverting removing the effect of orientation from - !! vertex basis functions, this is equivalent to swapping the - !! the value of vertex basis functions - CALL SWAP(ans(1:nrow, 1), ans(1:nrow, 2)) - CASE ("B") - - IF (orient .EQ. -1) THEN - temp(1:nrow) = -1.0_DFP * xij(1, 1:nrow) - CALL EvalAllOrthopol_(n=order, x=temp(1:nrow), & - orthopol=polyopt%Lobatto, ans=ans, nrow=nrow, ncol=ncol) - - CALL SWAP(ans(1:nrow, 1), ans(1:nrow, 2)) - RETURN - END IF - CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=polyopt%Lobatto, & ans=ans, nrow=nrow, ncol=ncol) CASE DEFAULT nrow = 0 ncol = 0 - - CALL Errormsg(msg="No case found for refLine.", & - routine="HeirarchicalBasis_Line1_()", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN 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_ !---------------------------------------------------------------------------- @@ -1720,50 +1704,39 @@ END SUBROUTINE handle_error MODULE PROCEDURE HeirarchicalGradientBasis_Line2_ CHARACTER(1) :: astr -REAL(DFP) :: temp(SIZE(xij, 2)) +REAL(DFP) :: temp(SIZE(xij, 2)), o1 +INTEGER(I4B) :: ii, jj, k +o1 = REAL(orient, kind=DFP) astr = UpperCase(refLine(1:1)) -dim1 = SIZE(xij, 2) dim3 = 1 SELECT CASE (astr) -CASE ("U") +CASE ("U") CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=dim1) - - IF (orient .EQ. -1) temp(1:dim1) = -1.0_DFP * temp(1:dim1) - CALL GradientEvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, & ans=ans(:, :, 1), nrow=dim1, ncol=dim2) - ans(1:dim1, 1:dim2, 1) = ans(1:dim1, 1:dim2, 1) * 2.0_DFP + DO CONCURRENT(ii=1:dim1, jj=1:dim2) + ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP + END DO CASE ("B") - - IF (orient .EQ. -1) THEN - - temp(1:dim1) = -1.0_DFP * xij(1, 1:dim1) - - CALL GradientEvalAllOrthopol_(n=order, x=temp, & + CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), & orthopol=polyopt%Lobatto, ans=ans(:, :, 1), nrow=dim1, ncol=dim2) - ELSE - - CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), & - orthopol=polyopt%Lobatto, ans=ans(:, :, 1), nrow=dim1, ncol=dim2) - END IF CASE DEFAULT - - dim1 = 0 - dim2 = 0 - dim3 = 0 - CALL Errormsg(msg="No case found for refline.", & - routine="HeirarchicalGradientBasis_Line1_()", & - file=__FILE__, line=__LINE__, unitno=stderr) + 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_ !---------------------------------------------------------------------------- @@ -1772,63 +1745,66 @@ END SUBROUTINE handle_error MODULE PROCEDURE OrthogonalBasis_Line1 INTEGER(I4B) :: ii -TYPE(String) :: astr +CHARACTER(1) :: astr +LOGICAL(LGT) :: isok, abool ans = 0.0_DFP -astr = UpperCase(refLine) -IF (basisType .EQ. polyopt%Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg(& - & msg="alpha and beta should be present for basisType=Jacobi", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) +#ifdef DEBUG_VER + +isok = basisType .EQ. polyopt%Jacobi + +IF (isok) THEN + abool = (.NOT. PRESENT(alpha)) .OR. (.NOT. PRESENT(beta)) + + IF (abool) THEN + CALL Errormsg(routine="OrthogonalBasis_Line1()", & + msg="alpha and beta should be present for basisType=Jacobi", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN END IF + END IF -IF (basisType .EQ. polyopt%Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg(& - & msg="lambda should be present for basisType=Ultraspherical", & - & file=__FILE__, & - & routine="BasisEvalAll_Line2", & - & line=__LINE__, & - & unitno=stderr) +isok = basisType .EQ. polyopt%Ultraspherical +IF (isok) THEN + + abool = .NOT. PRESENT(lambda) + + IF (abool) THEN + CALL Errormsg(routine="OrthogonalBasis_Line1()", file=__FILE__, & + msg="lambda should be present for basisType=Ultraspherical", & + line=__LINE__, unitno=stderr) RETURN END IF + END IF -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans = EvalAllOrthopol(& - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +#endif -CASE ("BIUNIT") - ans = EvalAllOrthopol(& - & n=order, & - & x=xij(1, :), & - & orthopol=basisType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +astr = UpperCase(refLine(1:1)) + +SELECT CASE (astr) +CASE ("U") + + ans = EvalAllOrthopol(n=order, & + x=FromUnitLine2BiUnitLine(xin=xij(1, :)), orthopol=basisType, & + alpha=alpha, beta=beta, lambda=lambda) + +CASE ("B") + + ans = EvalAllOrthopol(n=order, x=xij(1, :), orthopol=basisType, & + alpha=alpha, beta=beta, lambda=lambda) CASE DEFAULT + ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refLine.", & - & file=__FILE__, & - & routine="OrthogonalBasis_Line1()", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg(msg="No case found for refLine.", & + routine="OrthogonalBasis_Line1()", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN + END SELECT END PROCEDURE OrthogonalBasis_Line1 From c6cff26274990c62690c90b09f389e1bb1013f87 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:40:48 +0900 Subject: [PATCH 174/359] Updates in hexahedron interpolation utils --- .../src/HexahedronInterpolationUtility.F90 | 23 +++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index 6856fd2cb..ff51dd784 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -98,15 +98,30 @@ END FUNCTION GetTotalDOF_Hexahedron ! lagrange polynomial on an edge of a Hexahedron !- These dof are strictly inside the Hexahedron -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Hexahedron(order, baseContinuity, & +INTERFACE GetTotalInDOF_Hexahedron + MODULE PURE FUNCTION GetTotalInDOF_Hexahedron1(order, baseContinuity, & baseInterpolation) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order CHARACTER(*), INTENT(IN) :: baseContinuity CHARACTER(*), INTENT(IN) :: baseInterpolation INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Hexahedron -END INTERFACE + END FUNCTION GetTotalInDOF_Hexahedron1 +END INTERFACE GetTotalInDOF_Hexahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE GetTotalInDOF_Hexahedron + MODULE PURE FUNCTION GetTotalInDOF_Hexahedron2(p, q, r, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! order in x, y and z direction + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Hexahedron2 +END INTERFACE GetTotalInDOF_Hexahedron !---------------------------------------------------------------------------- ! RefElemDomain_Hexahedron From c3c26138d44bbafaeeb064b58f37cd14ddf7acf3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:41:16 +0900 Subject: [PATCH 175/359] updates in hierarchical polynomial utility --- .../src/HierarchicalPolynomialUtility.F90 | 72 +++++++++++++------ 1 file changed, 52 insertions(+), 20 deletions(-) diff --git a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 index c4ea73b2e..81fde64e8 100644 --- a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 @@ -24,10 +24,10 @@ MODULE HierarchicalPolynomialUtility PRIVATE PUBLIC :: HierarchicalDOF -PUBLIC :: VertexDOF -PUBLIC :: EdgeDOF -PUBLIC :: FaceDOF -PUBLIC :: CellDOF +PUBLIC :: HierarchicalVertexDOF +PUBLIC :: HierarchicalEdgeDOF +PUBLIC :: HierarchicalFaceDOF +PUBLIC :: HierarchicalCellDOF PUBLIC :: HierarchicalEvalAll_ PUBLIC :: HierarchicalEvalAll @@ -68,11 +68,11 @@ END FUNCTION HierarchicalDOF ! summary: Returns the total number of degree of freedom INTERFACE - MODULE PURE FUNCTION VertexDOF(elemType) RESULT(ans) + MODULE PURE FUNCTION HierarchicalVertexDOF(elemType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: elemType INTEGER(I4B) :: ans !! number of degree of freedom - END FUNCTION VertexDOF + END FUNCTION HierarchicalVertexDOF END INTERFACE !---------------------------------------------------------------------------- @@ -80,13 +80,15 @@ END FUNCTION VertexDOF !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION EdgeDOF(order, elemType) RESULT(ans) + MODULE PURE FUNCTION HierarchicalEdgeDOF(order, elemType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order(:) - !! order + !! order, + !! the size of order should be same as + !! the total number of edges in element INTEGER(I4B), INTENT(IN) :: elemType INTEGER(I4B) :: ans !! number of degree of freedom - END FUNCTION EdgeDOF + END FUNCTION HierarchicalEdgeDOF END INTERFACE !---------------------------------------------------------------------------- @@ -94,13 +96,13 @@ END FUNCTION EdgeDOF !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION FaceDOF(order, elemType) RESULT(ans) + MODULE PURE FUNCTION HierarchicalFaceDOF(order, elemType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order(:, :) !! order INTEGER(I4B), INTENT(IN) :: elemType INTEGER(I4B) :: ans !! number of degree of freedom - END FUNCTION FaceDOF + END FUNCTION HierarchicalFaceDOF END INTERFACE !---------------------------------------------------------------------------- @@ -108,14 +110,15 @@ END FUNCTION FaceDOF !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION CellDOF(order, elemType) RESULT(ans) + MODULE PURE FUNCTION HierarchicalCellDOF(order, elemType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order(:) !! order + !! for quadrangle element, size of order should be 2 INTEGER(I4B), INTENT(IN) :: elemType - !! + !! element type INTEGER(I4B) :: ans !! number of degree of freedom - END FUNCTION CellDOF + END FUNCTION HierarchicalCellDOF END INTERFACE !---------------------------------------------------------------------------- @@ -124,7 +127,8 @@ END FUNCTION CellDOF INTERFACE MODULE FUNCTION HierarchicalEvalAll(order, elemType, xij, domainName, & - cellOrder, faceOrder, edgeOrder) RESULT(ans) + cellOrder, faceOrder, edgeOrder, cellOrient, faceOrient, & + edgeOrient) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType @@ -145,6 +149,12 @@ MODULE FUNCTION HierarchicalEvalAll(order, elemType, xij, domainName, & !! edge order, needed for 3D elements only REAL(DFP), ALLOCATABLE :: ans(:, :) !! Value of n+1 Hierarchical polynomials at point x + INTEGER(I4B), INTENT(IN) :: edgeOrient(:) + !! edge orientation + INTEGER(I4B), INTENT(IN) :: faceOrient(:, :) + !! face orientation + INTEGER(I4B), INTENT(IN) :: cellOrient(:) + !! cell orientation END FUNCTION HierarchicalEvalAll END INTERFACE @@ -153,8 +163,9 @@ END FUNCTION HierarchicalEvalAll !---------------------------------------------------------------------------- INTERFACE - MODULE SUBROUTINE HierarchicalEvalAll_(order, elemType, xij, ans, & - nrow, ncol, domainName, cellOrder, faceOrder, edgeOrder) + MODULE SUBROUTINE HierarchicalEvalAll_(order, elemType, xij, ans, nrow, & + ncol, domainName, cellOrder, faceOrder, edgeOrder, & + cellOrient, faceOrient, edgeOrient) INTEGER(I4B), INTENT(IN) :: order !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType @@ -178,6 +189,12 @@ MODULE SUBROUTINE HierarchicalEvalAll_(order, elemType, xij, ans, & !! face order, needed for 2D and 3D elements INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) !! edge order, needed for 3D elements only + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) + !! orientation of cell + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) + !! orientation of face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) + !! edge orientation END SUBROUTINE HierarchicalEvalAll_ END INTERFACE @@ -186,8 +203,9 @@ END SUBROUTINE HierarchicalEvalAll_ !---------------------------------------------------------------------------- INTERFACE - MODULE FUNCTION HierarchicalGradientEvalAll(order, elemType, xij, domainName, & - cellOrder, faceOrder, edgeOrder) RESULT(ans) + MODULE FUNCTION HierarchicalGradientEvalAll(order, elemType, xij, & + domainName, cellOrder, faceOrder, edgeOrder, cellOrient, faceOrient, & + edgeOrient) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType @@ -208,6 +226,12 @@ MODULE FUNCTION HierarchicalGradientEvalAll(order, elemType, xij, domainName, & !! edge order, needed for 3D elements only REAL(DFP), ALLOCATABLE :: ans(:, :, :) !! Value of n+1 Hierarchical polynomials at point x + INTEGER(I4B), INTENT(IN) :: edgeOrient(:) + !! edge orientation + INTEGER(I4B), INTENT(IN) :: faceOrient(:, :) + !! face orientation + INTEGER(I4B), INTENT(IN) :: cellOrient(:) + !! cell orientation END FUNCTION HierarchicalGradientEvalAll END INTERFACE @@ -217,7 +241,8 @@ END FUNCTION HierarchicalGradientEvalAll INTERFACE MODULE SUBROUTINE HierarchicalGradientEvalAll_(order, elemType, xij, ans, & - dim1, dim2, dim3, domainName, cellOrder, faceOrder, edgeOrder) + dim1, dim2, dim3, domainName, cellOrder, faceOrder, edgeOrder, & + cellOrient, faceOrient, edgeOrient) INTEGER(I4B), INTENT(IN) :: order !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType @@ -241,6 +266,13 @@ MODULE SUBROUTINE HierarchicalGradientEvalAll_(order, elemType, xij, ans, & !! face order, needed for 2D and 3D elements INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) !! edge order, needed for 3D elements only + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) + !! orientation of cell + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) + !! orientation of face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) + !! edge orientation END SUBROUTINE HierarchicalGradientEvalAll_ END INTERFACE From 3d8ee8e5a89a46e906a901b6b6550c9802916659 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:41:40 +0900 Subject: [PATCH 176/359] line interpolation utility --- .../src/LineInterpolationUtility.F90 | 139 +++++++++++++----- 1 file changed, 100 insertions(+), 39 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 2045e8627..7718bc8b6 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -1311,8 +1311,8 @@ END SUBROUTINE HeirarchicalBasis_Line1_ !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasis_Line_ -MODULE SUBROUTINE HeirarchicalBasis_Line2_(order, xij, refLine, orient, ans, & - nrow, ncol) + 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(:, :) @@ -1385,6 +1385,31 @@ END SUBROUTINE HeirarchicalGradientBasis_Line1_ ! !---------------------------------------------------------------------------- +INTERFACE HeirarchicalBasisGradient_Line + MODULE FUNCTION HeirarchicalGradientBasis_Line2(order, xij, refLine, & + orient) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Polynomial order of interpolation + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + !! size(xij, 1) should be 1 + CHARACTER(*), INTENT(IN) :: refLine + !! This parameter denotes the type of reference line. + !! It can take following values: + !! UNIT: in this case xij is in unit Line. + !! BIUNIT: in this case xij is in biunit Line. + INTEGER(I4B), INTENT(IN) :: orient + !! orientation of line: 1 or -1 + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + !! Gradient of Hierarchical basis + !! SIZE(xij, 2), order + 1, 1 + END FUNCTION HeirarchicalGradientBasis_Line2 +END INTERFACE HeirarchicalBasisGradient_Line + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE HeirarchicalBasisGradient_Line_ MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_(order, xij, refLine, & orient, ans, dim1, dim2, dim3) @@ -1541,6 +1566,10 @@ END SUBROUTINE BasisGradientEvalAll_Line2_ !> author: Vikas Sharma, Ph. D. ! date: 2023-07-19 ! summary: Returns quadrature points +! +!# Introduction +! +! This function calls QuadraturePoint_Line3 function INTERFACE QuadraturePoint_Line MODULE FUNCTION QuadraturePoint_Line1(order, quadType, layout, xij, & @@ -1549,16 +1578,11 @@ MODULE FUNCTION QuadraturePoint_Line1(order, quadType, layout, xij, & !! Order of interpolation INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature point type - !! Equidistance, - !! GaussLegendre, - !! GaussLegendreLobatto, - !! GaussChebyshev, - !! GaussChebyshevLobatto, - !! GaussJacobi, + !! Equidistance, ! GaussLegendre, ! GaussLegendreLobatto, + !! GaussChebyshev, ! GaussChebyshevLobatto, ! GaussJacobi, !! GaussJacobiLobatto CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" + !! "VEFC" ! "INCREASING" REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! domain of interpolation REAL(DFP), OPTIONAL, INTENT(IN) :: alpha @@ -1585,6 +1609,10 @@ END FUNCTION QuadraturePoint_Line1 !> author: Vikas Sharma, Ph. D. ! date: 27 Aug 2022 ! summary: Returns the interpolation point +! +!# Introduction +! +! This function calls QuadraturePoint_Line1 function INTERFACE QuadraturePoint_Line MODULE FUNCTION QuadraturePoint_Line2(order, quadType, xij, layout, & @@ -1593,13 +1621,8 @@ MODULE FUNCTION QuadraturePoint_Line2(order, quadType, xij, layout, & !! order of interpolation INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto ! GaussChebyshev, + !! GaussChebyshevLobatto ! GaussJacobi ! GaussJacobiLobatto REAL(DFP), INTENT(IN) :: xij(2) !! end points CHARACTER(*), INTENT(IN) :: layout @@ -1616,6 +1639,43 @@ MODULE FUNCTION QuadraturePoint_Line2(order, quadType, xij, layout, & END FUNCTION QuadraturePoint_Line2 END INTERFACE QuadraturePoint_Line +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Aug 2022 +! summary: Returns the interpolation point +! +!# Introduction +! +! This function calls QuadraturePoint_Line3 + +INTERFACE QuadraturePoint_Line + MODULE FUNCTION QuadraturePoint_Line4(nips, quadType, xij, layout, & + alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature point type + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto ! GaussChebyshev, + !! GaussChebyshevLobatto ! GaussJacobi ! GaussJacobiLobatto + REAL(DFP), INTENT(IN) :: xij(2) + !! end points + CHARACTER(*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! one dimensional interpolation point + END FUNCTION QuadraturePoint_Line4 +END INTERFACE QuadraturePoint_Line + !---------------------------------------------------------------------------- ! QuadraturePoint_Line !---------------------------------------------------------------------------- @@ -1661,41 +1721,42 @@ END FUNCTION QuadraturePoint_Line3 END INTERFACE QuadraturePoint_Line !---------------------------------------------------------------------------- -! QuadraturePoint_Line +! !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Aug 2022 -! summary: Returns the interpolation point +! date: 2024-07-07 +! summary: Quadrature point on line -INTERFACE QuadraturePoint_Line - MODULE FUNCTION QuadraturePoint_Line4(nips, quadType, xij, layout, & - alpha, beta, lambda) RESULT(ans) +INTERFACE QuadraturePoint_Line_ + MODULE SUBROUTINE QuadraturePoint_Line1_(nips, quadType, layout, xij, & + alpha, beta, lambda, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: nips(1) - !! order of interpolation + !! Order of interpolation INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto - REAL(DFP), INTENT(IN) :: xij(2) - !! end points + !! Equidistance, ! GaussLegendre, ! GaussLegendreLobatto, ! GaussChebyshev, + !! GaussChebyshevLobatto, ! GaussJacobi, ! GaussJacobiLobatto CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" + !! "VEFC" ! "INCREASING" + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! domain of interpolation REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! one dimensional interpolation point - END FUNCTION QuadraturePoint_Line4 -END INTERFACE QuadraturePoint_Line + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! quadrature points + !! If xij is present then the number of rows in ans + !! is same as size(xij,1) + 1. + !! If xij is not present then the number of rows in + !! ans is 2 + !! The last row of ans contains the weights + !! The first few rows contains the quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE QuadraturePoint_Line1_ +END INTERFACE QuadraturePoint_Line_ END MODULE LineInterpolationUtility From ec4a0bf1218f7930da7d46dbf2850bd0c335e4b6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:41:53 +0900 Subject: [PATCH 177/359] quadrangle interpolation util --- .../src/QuadrangleInterpolationUtility.F90 | 22 +++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index f6013fca8..7d2bbb372 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -117,15 +117,29 @@ END FUNCTION GetTotalDOF_Quadrangle ! lagrange polynomial on an edge of a Quadrangle !- These dof are strictly inside the Quadrangle -INTERFACE - MODULE PURE FUNCTION GetTotalInDOF_Quadrangle(order, baseContinuity, & +INTERFACE GetTotalInDOF_Quadrangle + MODULE PURE FUNCTION GetTotalInDOF_Quadrangle1(order, baseContinuity, & baseInterpolation) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order CHARACTER(*), INTENT(IN) :: baseContinuity CHARACTER(*), INTENT(IN) :: baseInterpolation INTEGER(I4B) :: ans - END FUNCTION GetTotalInDOF_Quadrangle -END INTERFACE + END FUNCTION GetTotalInDOF_Quadrangle1 +END INTERFACE GetTotalInDOF_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE GetTotalInDOF_Quadrangle + MODULE PURE FUNCTION GetTotalInDOF_Quadrangle2(p, q, baseContinuity, & + baseInterpolation) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q + CHARACTER(*), INTENT(IN) :: baseContinuity + CHARACTER(*), INTENT(IN) :: baseInterpolation + INTEGER(I4B) :: ans + END FUNCTION GetTotalInDOF_Quadrangle2 +END INTERFACE GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- ! RefElemDomain_Quadrangle From 9de419f8e7336e3bb8897bfbc0966389da3195da Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:42:01 +0900 Subject: [PATCH 178/359] triangle interpolation util --- .../src/TriangleInterpolationUtility.F90 | 318 +++--------------- 1 file changed, 45 insertions(+), 273 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index f2a594c88..7e5d8c0a7 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -935,26 +935,6 @@ MODULE PURE SUBROUTINE Dubiner_Triangle2_(order, x, y, refTriangle, ans, & END SUBROUTINE Dubiner_Triangle2_ END INTERFACE Dubiner_Triangle_ -!---------------------------------------------------------------------------- -! BarycentricVertexBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on reference Triangle - -INTERFACE - MODULE PURE SUBROUTINE BarycentricVertexBasis_Triangle(lambda, ans) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentrix coords - !! number of rows = 3 corresponding to three coordinates - !! number of columns = number of points - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), 3) - !! ans(:,v1) basis function of vertex v1 at all points - END SUBROUTINE BarycentricVertexBasis_Triangle -END INTERFACE - !---------------------------------------------------------------------------- ! VertexBasis_Triangle !---------------------------------------------------------------------------- @@ -974,37 +954,6 @@ MODULE PURE FUNCTION VertexBasis_Triangle(xij, refTriangle) RESULT(ans) END FUNCTION VertexBasis_Triangle END INTERFACE -!---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on edge of triangle -! -!# Introduction -! -! Evaluate basis functions on edges of triangle -! pe1, pe2, pe3 should be greater than or equal to 2 - -INTERFACE - MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle(pe1, pe2, pe3, & - lambda, ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! Number of rows in lambda is equal to three corresponding to - !! three coordinates - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) - END SUBROUTINE BarycentricEdgeBasis_Triangle -END INTERFACE - !---------------------------------------------------------------------------- ! EdgeBasis_Triangle !---------------------------------------------------------------------------- @@ -1036,27 +985,6 @@ MODULE PURE FUNCTION EdgeBasis_Triangle(pe1, pe2, pe3, xij, refTriangle) & END FUNCTION EdgeBasis_Triangle END INTERFACE -!---------------------------------------------------------------------------- -! BarycentricCellBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the Cell basis functions on reference Triangle - -INTERFACE - MODULE PURE SUBROUTINE BarycentricCellBasis_Triangle(order, lambda, ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in this cell, it should be greater than 2 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentrix coords - !! number of rows = 3 corresponding to three coordinates - !! number of columns = number of points - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) - END SUBROUTINE BarycentricCellBasis_Triangle -END INTERFACE - !---------------------------------------------------------------------------- ! CellBasis_Triangle !---------------------------------------------------------------------------- @@ -1081,102 +1009,6 @@ MODULE PURE FUNCTION CellBasis_Triangle(order, xij, refTriangle) RESULT(ans) END FUNCTION CellBasis_Triangle END INTERFACE -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE BarycentricHeirarchicalBasis_Triangle - MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle1(order, & - pe1, pe2, pe3, lambda, refTriangle, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge e1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge e2 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge e3 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 3 - !! number of cols = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! reference triangle, "BIUNIT", "UNIT" - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans( & - ! & SIZE(lambda, 2), & - ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) - !! - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE BarycentricHeirarchicalBasis_Triangle1 -END INTERFACE BarycentricHeirarchicalBasis_Triangle - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle - -INTERFACE BarycentricHeirarchicalBasis_Triangle -MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle2(order, lambda, & - & refTriangle, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order of approximation on triangle - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 3 - !! number of cols = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! reference triangle, "BIUNIT", "UNIT" - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans( & - ! & SIZE(lambda, 2), & - ! & INT((order + 1) * (order + 2) / 2)) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE BarycentricHeirarchicalBasis_Triangle2 -END INTERFACE BarycentricHeirarchicalBasis_Triangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE BarycentricHeirarchicalBasis_Triangle - MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle3(order, & - pe1, pe2, pe3, lambda, refTriangle, edgeOrient1, edgeOrient2, & - edgeOrient3, faceOrient, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge e1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge e2 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge e3 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 3 - !! number of cols = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! reference triangle, "BIUNIT", "UNIT" - INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 - !! edge orientation 1 or -1 - INTEGER(I4B), INTENT(IN) :: faceOrient(:) - !! face orientation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - ! REAL(DFP) :: ans( & - ! & SIZE(lambda, 2), & - ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) - !! - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE BarycentricHeirarchicalBasis_Triangle3 -END INTERFACE BarycentricHeirarchicalBasis_Triangle - !---------------------------------------------------------------------------- ! HeirarchicalBasis_Triangle !---------------------------------------------------------------------------- @@ -1354,109 +1186,6 @@ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_(order, pe1, pe2, pe3, & END SUBROUTINE HeirarchicalBasis_Triangle3_ END INTERFACE HeirarchicalBasis_Triangle_ -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-21 -! summary: Evaluate the gradient of the edge basis on triangle -! using barycentric coordinate - -INTERFACE - MODULE PURE SUBROUTINE BarycentricVertexBasisGradient_Triangle(lambda, ans) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! ans(SIZE(lambda, 2), 3, 3) - END SUBROUTINE BarycentricVertexBasisGradient_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-04-21 -! summary: Evaluate the gradient of the edge basis on triangle -! using barycentric coordinate - -INTERFACE - MODULE PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle(pe1, pe2, pe3, & - lambda, ans) - INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) - INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) - END SUBROUTINE BarycentricEdgeBasisGradient_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2024-04-21 -! summary: Evaluate the gradient of the edge basis on triangle -! using barycentric coordinate - -INTERFACE - MODULE PURE SUBROUTINE BarycentricCellBasisGradient_Triangle(order, lambda, & - ans) - INTEGER(I4B), INTENT(IN) :: order - !! order on Cell (e1) - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), 3*order - 3, 3) - END SUBROUTINE BarycentricCellBasisGradient_Triangle -END INTERFACE - -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasisGradient_Triangle -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu and Vikas Sharma -! date: 2024-04-21 -! summary: Evaluate the gradient of the Hierarchical basis on triangle - -INTERFACE BarycentricHeirarchicalBasisGradient_Triangle -MODULE PURE SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1(order, & - & pe1, pe2, pe3, lambda, refTriangle, ans) - INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 - INTEGER(I4B), INTENT(IN) :: pe1 - !! order of interpolation on edge e1 - INTEGER(I4B), INTENT(IN) :: pe2 - !! order of interpolation on edge e2 - INTEGER(I4B), INTENT(IN) :: pe3 - !! order of interpolation on edge e3 - REAL(DFP), INTENT(IN) :: lambda(:, :) - !! Barycenteric coordinates - !! number of rows = 3 - !! number of cols = number of points - CHARACTER(*), INTENT(IN) :: refTriangle - !! reference triangle, "BIUNIT", "UNIT" - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans( & - ! & SIZE(lambda, 2), & - ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 3) - !! - END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1 -END INTERFACE BarycentricHeirarchicalBasisGradient_Triangle - !---------------------------------------------------------------------------- ! LagrangeEvalAll_Triangle !---------------------------------------------------------------------------- @@ -1844,8 +1573,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 @@ -1909,6 +1638,49 @@ MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_(order, pe1, pe2, & END SUBROUTINE HeirarchicalBasisGradient_Triangle1_ END INTERFACE HeirarchicalBasisGradient_Triangle_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasisGradient_Triangle_ + MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle2_(order, pe1, pe2, & + pe3, xij, edgeOrient1, edgeOrient2, edgeOrient3, faceOrient, & + refTriangle, ans, tsize1, tsize2, tsize3) + INTEGER(I4B), INTENT(IN) :: order + !! Order of approximation inside the triangle (i.e., cell) + !! it should be greater than 2 for cell bubble to exist + INTEGER(I4B), INTENT(IN) :: pe1 + !! Order of interpolation on edge e1 + !! It should be greater than 1 for edge bubble to exists + INTEGER(I4B), INTENT(IN) :: pe2 + !! Order of interpolation on edge e2 + !! It should be greater than 1 for edge bubble to exists + INTEGER(I4B), INTENT(IN) :: pe3 + !! Order of interpolation on edge e3 + !! It should be greater than 1 for edge bubble to exists + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: edgeOrient1 + !! edge orientation, 1 or -1 + INTEGER(I4B), INTENT(IN) :: edgeOrient2 + !! edge orientation, 1 or -1 + INTEGER(I4B), INTENT(IN) :: edgeOrient3 + !! edge orientation, 1 or -1 + INTEGER(I4B), INTENT(IN) :: faceOrient(:) + !! orientation of face + CHARACTER(*), INTENT(IN) :: refTriangle + !! This parameter denotes the type of reference triangle. + !! It can take following values: + !! UNIT: in this case xij is in unit Triangle. + !! BIUNIT: in this case xij is in biunit triangle. + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! tsize1 = SIZE(xij, 2) + !! tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) + !! tsize3 = 2 + INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3 + END SUBROUTINE HeirarchicalBasisGradient_Triangle2_ +END INTERFACE HeirarchicalBasisGradient_Triangle_ + !---------------------------------------------------------------------------- ! OrthogonalBasisGradient_Triangle !---------------------------------------------------------------------------- From a63429369a81f16183fbb2f8d30414c2d58f0c33 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:42:12 +0900 Subject: [PATCH 179/359] updates in quadrature point --- .../src/QuadraturePoint_Method.F90 | 192 ++++++++++-------- 1 file changed, 102 insertions(+), 90 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index 341110e9e..d833339b0 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -22,18 +22,24 @@ MODULE QuadraturePoint_Method USE BaseType USE GlobalData USE String_Class, ONLY: String + IMPLICIT NONE + PRIVATE + PUBLIC :: Initiate PUBLIC :: QuadraturePoint PUBLIC :: QuadraturePoint_Pointer PUBLIC :: DEALLOCATE PUBLIC :: SIZE PUBLIC :: GetTotalQuadraturepoints + PUBLIC :: GetQuadraturepoints +PUBLIC :: GetQuadraturepoints_ + PUBLIC :: Outerprod PUBLIC :: Display -PUBLIC :: QuadraturePoint_MdEncode +! PUBLIC :: QuadraturePoint_MdEncode PUBLIC :: QuadraturePointIdToName PUBLIC :: QuadraturePointNameToId PUBLIC :: MdEncode @@ -74,17 +80,17 @@ END FUNCTION QuadraturePointIdToName !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiates the quadrature points +! summary: This routine Initiates the quadrature points INTERFACE Initiate - MODULE PURE SUBROUTINE quad_initiate1(obj, points) - CLASS(QuadraturePoint_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_Initiate1(obj, points) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj REAL(DFP), INTENT(IN) :: points(:, :) !! points contains the quadrature points and weights !! points( :, ipoint ) contains quadrature points and weights of ipoint !! quadrature point. The last row contains the weight. The rest of the !! rows contains the coordinates of quadrature. - END SUBROUTINE quad_initiate1 + END SUBROUTINE obj_Initiate1 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -93,11 +99,11 @@ END SUBROUTINE quad_initiate1 !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiates the quadrature points +! summary: This routine Initiates the quadrature points INTERFACE Initiate - MODULE PURE SUBROUTINE quad_initiate2(obj, tXi, tpoints) - CLASS(QuadraturePoint_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_Initiate2(obj, tXi, tpoints) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: tXi !! Total number of xidimension !! For line tXi=1 @@ -105,7 +111,7 @@ MODULE PURE SUBROUTINE quad_initiate2(obj, tXi, tpoints) !! For 3D element tXi=3 INTEGER(I4B), INTENT(IN) :: tpoints !! Total number quadrature points - END SUBROUTINE quad_initiate2 + END SUBROUTINE obj_Initiate2 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -114,11 +120,15 @@ END SUBROUTINE quad_initiate2 !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiates the quadrature points +! summary: This routine Initiates the quadrature points +! +!# Introduction +! +! We call obj_Initiate5 in this routine INTERFACE Initiate - MODULE SUBROUTINE quad_initiate3(obj, refElem, order, quadratureType, & - & alpha, beta, lambda) + MODULE SUBROUTINE obj_Initiate3(obj, refElem, order, quadratureType, & + alpha, beta, lambda) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -127,21 +137,18 @@ MODULE SUBROUTINE quad_initiate3(obj, refElem, order, quadratureType, & !! order of integrand CHARACTER(*), INTENT(IN) :: quadratureType !! Type of quadrature points - !! "GaussLegendre" - !! "GaussLegendreLobatto" + !! "GaussLegendre" ! "GaussLegendreLobatto" !! "GaussLegendreRadau", "GaussLegendreRadauLeft" - !! "GaussLegendreRadauRight" - !! "GaussChebyshev" - !! "GaussChebyshevLobatto" - !! "GaussChebyshevRadau", "GaussChebyshevRadauLeft" - !! "GaussChebyshevRadauRight" + !! "GaussLegendreRadauRight" ! "GaussChebyshev" + !! "GaussChebyshevLobatto" ! "GaussChebyshevRadau", + !! "GaussChebyshevRadauLeft" ! "GaussChebyshevRadauRight" REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter - END SUBROUTINE quad_initiate3 + END SUBROUTINE obj_Initiate3 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -150,11 +157,15 @@ END SUBROUTINE quad_initiate3 !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiates the quadrature points +! summary: This routine Initiates the quadrature points +! +!# Introduction +! +! We call obj_Initiate6 in this routine INTERFACE Initiate - MODULE SUBROUTINE quad_initiate4(obj, refElem, nips, quadratureType, & - & alpha, beta, lambda) + MODULE SUBROUTINE obj_Initiate4(obj, refElem, nips, quadratureType, & + alpha, beta, lambda) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -169,7 +180,7 @@ MODULE SUBROUTINE quad_initiate4(obj, refElem, nips, quadratureType, & !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter - END SUBROUTINE quad_initiate4 + END SUBROUTINE obj_Initiate4 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -181,8 +192,8 @@ END SUBROUTINE quad_initiate4 ! summary: This routine constructs the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate5(obj, refElem, order, quadratureType, & - alpha, beta, lambda) + MODULE SUBROUTINE obj_Initiate5(obj, refElem, order, quadratureType, & + alpha, beta, lambda) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -190,24 +201,17 @@ MODULE SUBROUTINE quad_initiate5(obj, refElem, order, quadratureType, & INTEGER(I4B), INTENT(IN) :: order !! order of integrand INTEGER(I4B), INTENT(IN) :: quadratureType - !! Type of quadrature points - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadau - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev - !! GaussChebyshevLobatto - !! GaussChebyshevRadau - !! GaussChebyshevRadauLeft - !! GaussChebyshevRadauRight + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter - END SUBROUTINE quad_initiate5 + END SUBROUTINE obj_Initiate5 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -216,11 +220,11 @@ END SUBROUTINE quad_initiate5 !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiates the quadrature points +! summary: This routine Initiates the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate6(obj, refElem, nips, quadratureType, & - alpha, beta, lambda) + MODULE SUBROUTINE obj_Initiate6(obj, refElem, nips, quadratureType, & + alpha, beta, lambda) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -229,15 +233,9 @@ MODULE SUBROUTINE quad_initiate6(obj, refElem, nips, quadratureType, & !! order of integrand INTEGER(I4B), INTENT(IN) :: quadratureType !! Type of quadrature points - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadau - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev - !! GaussChebyshevLobatto - !! GaussChebyshevRadau - !! GaussChebyshevRadauLeft + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev + !! GaussChebyshevLobatto ! GaussChebyshevRadau ! GaussChebyshevRadauLeft !! GaussChebyshevRadauRight REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter @@ -245,7 +243,7 @@ MODULE SUBROUTINE quad_initiate6(obj, refElem, nips, quadratureType, & !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter - END SUBROUTINE quad_initiate6 + END SUBROUTINE obj_Initiate6 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -254,12 +252,12 @@ END SUBROUTINE quad_initiate6 !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiates the quadrature points +! summary: This routine Initiates the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate7(obj, refElem, p, q, r, quadratureType1, & + MODULE SUBROUTINE obj_Initiate7(obj, refElem, p, q, r, quadratureType1, & quadratureType2, quadratureType3, alpha1, beta1, lambda1, alpha2, & - beta2, lambda2, alpha3, beta3, lambda3) + beta2, lambda2, alpha3, beta3, lambda3) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -292,7 +290,7 @@ MODULE SUBROUTINE quad_initiate7(obj, refElem, p, q, r, quadratureType1, & !! Jacobi parameter and Ultraspherical parameters REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 !! Jacobi parameter and Ultraspherical parameters - END SUBROUTINE quad_initiate7 + END SUBROUTINE obj_Initiate7 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -301,10 +299,10 @@ END SUBROUTINE quad_initiate7 !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiates the quadrature points +! summary: This routine Initiates the quadrature points INTERFACE Initiate - MODULE SUBROUTINE quad_initiate8(obj, refElem, nipsx, nipsy, nipsz, & + MODULE SUBROUTINE obj_Initiate8(obj, refElem, nipsx, nipsy, nipsz, & quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj @@ -339,7 +337,7 @@ MODULE SUBROUTINE quad_initiate8(obj, refElem, nipsx, nipsy, nipsz, & !! Jacobi parameter and Ultraspherical parameter REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 !! Jacobi parameter and Ultraspherical parameter - END SUBROUTINE quad_initiate8 + END SUBROUTINE obj_Initiate8 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -348,7 +346,7 @@ END SUBROUTINE quad_initiate8 !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiate an instance of quadrature points +! summary: This routine Initiate an instance of quadrature points INTERFACE QuadraturePoint MODULE PURE FUNCTION quad_Constructor1(points) RESULT(obj) @@ -367,7 +365,7 @@ END FUNCTION quad_Constructor1 INTERFACE QuadraturePoint_Pointer MODULE PURE FUNCTION quad_Constructor_1(points) RESULT(obj) - CLASS(QuadraturePoint_), POINTER :: obj + TYPE(QuadraturePoint_), POINTER :: obj REAL(DFP), INTENT(IN) :: points(:, :) END FUNCTION quad_Constructor_1 END INTERFACE QuadraturePoint_Pointer @@ -382,7 +380,7 @@ END FUNCTION quad_Constructor_1 INTERFACE DEALLOCATE MODULE PURE SUBROUTINE quad_Deallocate(obj) - CLASS(QuadraturePoint_), INTENT(INOUT) :: obj + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj END SUBROUTINE quad_Deallocate END INTERFACE DEALLOCATE @@ -395,11 +393,11 @@ END SUBROUTINE quad_Deallocate ! summary: This routine returns the size of obj%points, INTERFACE SIZE - MODULE PURE FUNCTION quad_Size(obj, dims) RESULT(ans) - CLASS(QuadraturePoint_), INTENT(IN) :: obj + MODULE PURE FUNCTION obj_Size(obj, dims) RESULT(ans) + TYPE(QuadraturePoint_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: dims INTEGER(I4B) :: ans - END FUNCTION quad_Size + END FUNCTION obj_Size END INTERFACE SIZE !---------------------------------------------------------------------------- @@ -411,11 +409,11 @@ END FUNCTION quad_Size ! summary: This routine returns total number of quadrature points INTERFACE GetTotalQuadraturepoints - MODULE PURE FUNCTION quad_getTotalQuadraturepoints(obj, dims) RESULT(ans) - CLASS(QuadraturePoint_), INTENT(IN) :: obj + MODULE PURE FUNCTION obj_GetTotalQuadraturepoints(obj, dims) RESULT(ans) + TYPE(QuadraturePoint_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: dims INTEGER(I4B) :: ans - END FUNCTION quad_getTotalQuadraturepoints + END FUNCTION obj_GetTotalQuadraturepoints END INTERFACE GetTotalQuadraturepoints !---------------------------------------------------------------------------- @@ -426,21 +424,17 @@ END FUNCTION quad_getTotalQuadraturepoints ! date: 23 July 2021 ! summary: This routine returns quadrature points -INTERFACE - MODULE PURE SUBROUTINE quad_GetQuadraturepoints1(obj, points, weights, num) - CLASS(QuadraturePoint_), INTENT(IN) :: obj +INTERFACE GetQuadraturePoints + MODULE PURE SUBROUTINE obj_GetQuadraturepoints1(obj, points, weights, num) + TYPE(QuadraturePoint_), INTENT(IN) :: obj REAL(DFP), INTENT(INOUT) :: points(3) !! [xi, eta, zeta] REAL(DFP), INTENT(INOUT) :: weights !! weights INTEGER(I4B), INTENT(IN) :: num !! quadrature number - END SUBROUTINE quad_GetQuadraturepoints1 -END INTERFACE - -INTERFACE GetQuadraturepoints - MODULE PROCEDURE quad_GetQuadraturepoints1 -END INTERFACE + END SUBROUTINE obj_GetQuadraturepoints1 +END INTERFACE GetQuadraturePoints !---------------------------------------------------------------------------- ! GetQuadraturePoint@GetMethods @@ -450,19 +444,37 @@ END SUBROUTINE quad_GetQuadraturepoints1 ! date: 23 July 2021 ! summary: This routine returns total number of quadrature points -INTERFACE - MODULE PURE SUBROUTINE quad_GetQuadraturepoints2(obj, points, weights) - CLASS(QuadraturePoint_), INTENT(IN) :: obj +INTERFACE GetQuadraturePoints + MODULE PURE SUBROUTINE obj_GetQuadraturepoints2(obj, points, weights) + TYPE(QuadraturePoint_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: points(:, :) !! Point( :, j ) = [xi, eta, zeta] of jth quadrature point REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: weights(:) !! Weight(j) weight of jth quadrature point - END SUBROUTINE quad_GetQuadraturepoints2 -END INTERFACE + END SUBROUTINE obj_GetQuadraturepoints2 +END INTERFACE GetQuadraturePoints -INTERFACE GetQuadraturepoints - MODULE PROCEDURE quad_GetQuadraturepoints2 -END INTERFACE +!---------------------------------------------------------------------------- +! GetQuadraturePoint@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-07 +! summary: This routine returns total number of quadrature points + +INTERFACE GetQuadraturePoints_ + MODULE PURE SUBROUTINE obj_GetQuadraturepoints1_(obj, points, weights, & + nrow, ncol) + TYPE(QuadraturePoint_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: points(:, :) + !! Point( :, j ) = [xi, eta, zeta] of jth quadrature point + REAL(DFP), INTENT(INOUT) :: weights(:) + !! Weight(j) weight of jth quadrature point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns + !! ncol is number of columns in points and weights + END SUBROUTINE obj_GetQuadraturepoints1_ +END INTERFACE GetQuadraturePoints_ !---------------------------------------------------------------------------- ! OuterProd@GetMethods @@ -473,14 +485,14 @@ END SUBROUTINE quad_GetQuadraturepoints2 ! summary: Performs outerproduct of quadrature points INTERFACE Outerprod - MODULE PURE FUNCTION quad_Outerprod(obj1, obj2) RESULT(ans) + MODULE PURE FUNCTION obj_Outerprod(obj1, obj2) RESULT(ans) CLASS(QuadraturePoint_), INTENT(IN) :: obj1 !! quadrature points in 1D CLASS(QuadraturePoint_), INTENT(IN) :: obj2 !! quadrature points in 1D TYPE(QuadraturePoint_) :: ans !! quadrature points in 2D - END FUNCTION quad_Outerprod + END FUNCTION obj_Outerprod END INTERFACE Outerprod !---------------------------------------------------------------------------- @@ -492,11 +504,11 @@ END FUNCTION quad_Outerprod ! summary: Display the content of quadrature point INTERFACE Display - MODULE SUBROUTINE quad_Display(obj, msg, unitno) + MODULE SUBROUTINE obj_Display(obj, msg, unitno) CLASS(QuadraturePoint_), INTENT(IN) :: obj CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno - END SUBROUTINE quad_Display + END SUBROUTINE obj_Display END INTERFACE Display !---------------------------------------------------------------------------- @@ -508,10 +520,10 @@ END SUBROUTINE quad_Display ! summary: Display the content of quadrature point INTERFACE MdEncode - MODULE FUNCTION QuadraturePoint_MdEncode(obj) RESULT(ans) + MODULE FUNCTION obj_MdEncode(obj) RESULT(ans) CLASS(QuadraturePoint_), INTENT(IN) :: obj TYPE(String) :: ans - END FUNCTION QuadraturePoint_MdEncode + END FUNCTION obj_MdEncode END INTERFACE MdEncode !---------------------------------------------------------------------------- From 0c2dbf88d808fa527611eced15df46226530357b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:42:27 +0900 Subject: [PATCH 180/359] updates in hexahedron interpolation --- .../src/HexahedronInterpolationUtility@Methods.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index b5da94b7a..1875eff02 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -236,9 +236,17 @@ ! GetTotalInDOF_Hexahedron !---------------------------------------------------------------------------- -MODULE PROCEDURE GetTotalInDOF_Hexahedron +MODULE PROCEDURE GetTotalInDOF_Hexahedron1 ans = (order - 1)**3 -END PROCEDURE GetTotalInDOF_Hexahedron +END PROCEDURE GetTotalInDOF_Hexahedron1 + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Hexahedron2 +ans = (p - 1) * (q - 1) * (r - 1) +END PROCEDURE GetTotalInDOF_Hexahedron2 !---------------------------------------------------------------------------- ! LagrangeDOF_Hexahedron From 397b42f90e767d07e01aa36050f8cb9fe71ec3d7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:42:39 +0900 Subject: [PATCH 181/359] updates in hierarchical polynomial util --- .../HierarchicalPolynomialUtility@Methods.F90 | 612 ++++++++++-------- 1 file changed, 358 insertions(+), 254 deletions(-) diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 index a1ad87684..c0f2589ff 100644 --- a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 @@ -22,26 +22,36 @@ USE ReferenceElement_Method, ONLY: XiDimension, & GetTotalNodes, & - ElementTopology + ElementTopology, & + GetTotalEdges USE ErrorHandling, ONLY: ErrorMsg USE BaseType, ONLY: elemopt => TypeElemNameOpt USE LineInterpolationUtility, ONLY: HeirarchicalBasis_Line_, & - HeirarchicalBasisGradient_Line_ + HeirarchicalBasisGradient_Line_, & + GetTotalInDOF_Line USE TriangleInterpolationUtility, ONLY: HeirarchicalBasis_Triangle_, & - HeirarchicalBasisGradient_Triangle_ + HeirarchicalBasisGradient_Triangle_, & + GetTotalInDOF_Triangle USE QuadrangleInterpolationUtility, ONLY: HeirarchicalBasis_Quadrangle_, & - HeirarchicalBasisGradient_Quadrangle_ + HeirarchicalBasisGradient_Quadrangle_, & + GetTotalInDOF_Quadrangle USE TetrahedronInterpolationUtility, ONLY: HeirarchicalBasis_Tetrahedron_, & - HeirarchicalBasisGradient_Tetrahedron_ + HeirarchicalBasisGradient_Tetrahedron_, & + GetTotalInDOF_Tetrahedron USE HexahedronInterpolationUtility, ONLY: HeirarchicalBasis_Hexahedron_, & - HeirarchicalBasisGradient_Hexahedron_ + HeirarchicalBasisGradient_Hexahedron_, & + GetTotalInDOF_Hexahedron + +USE PrismInterpolationUtility, ONLY: GetTotalInDOF_Prism + +USE PyramidInterpolationUtility, ONLY: GetTotalInDOF_Pyramid IMPLICIT NONE CONTAINS @@ -51,40 +61,153 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE HierarchicalDOF +INTEGER(I4B) :: ii + ans = 0 + +ii = HierarchicalVertexDOF(elemType=elemType) +ans = ans + ii + +IF (PRESENT(cellOrder)) THEN + ii = HierarchicalCellDOF(elemType=elemType, order=cellOrder) + ans = ans + ii +END IF + +IF (PRESENT(faceOrder)) THEN + ii = HierarchicalFaceDOF(elemType=elemType, order=faceOrder) + ans = ans + ii +END IF + +IF (PRESENT(edgeOrder)) THEN + ii = HierarchicalEdgeDOF(elemType=elemType, order=edgeOrder) + ans = ans + ii +END IF + END PROCEDURE HierarchicalDOF !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE VertexDOF +MODULE PROCEDURE HierarchicalVertexDOF ans = GetTotalNodes(elemType) -END PROCEDURE VertexDOF +END PROCEDURE HierarchicalVertexDOF !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE EdgeDOF +MODULE PROCEDURE HierarchicalEdgeDOF +INTEGER(I4B) :: topo, ii, tedges + +topo = ElementTopology(elemType) ans = 0 -END PROCEDURE EdgeDOF + +SELECT CASE (topo) +CASE (elemopt%Tetrahedron, elemopt%Hexahedron, elemopt%Prism, elemopt%Pyramid) + + tedges = GetTotalEdges(topo) + + DO ii = 1, tedges + ans = ans + GetTotalInDOF_Line(order=order(ii), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") + END DO + +END SELECT + +END PROCEDURE HierarchicalEdgeDOF !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE FaceDOF +MODULE PROCEDURE HierarchicalFaceDOF +INTEGER(I4B) :: topo, jj, ii + +topo = ElementTopology(elemType) + ans = 0 -END PROCEDURE FaceDOF + +SELECT CASE (topo) +CASE (elemopt%Point) + ans = 0 + +CASE (elemopt%Line) + ans = 0 + +CASE (elemopt%Triangle) + DO ii = 1, 3 + jj = GetTotalInDOF_Line(order=order(1, ii), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") + ans = ans + jj + END DO + +CASE (elemopt%Quadrangle) + DO ii = 1, 4 + jj = GetTotalInDOF_Line(order=order(1, ii), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") + ans = ans + jj + END DO + +CASE (elemopt%Tetrahedron) + DO ii = 1, 4 + jj = GetTotalInDOF_Triangle(order=order(1, ii), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") + ans = ans + jj + END DO + +CASE (elemopt%Hexahedron) + DO ii = 1, 6 + jj = GetTotalInDOF_Quadrangle(p=order(1, ii), q=order(2, ii), & + baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") + ans = ans + jj + END DO + +! CASE (elemopt%Prism) +! CASE (elemopt%Pyramid) +END SELECT +END PROCEDURE HierarchicalFaceDOF !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE CellDOF +MODULE PROCEDURE HierarchicalCellDOF +INTEGER(I4B) :: topo + ans = 0 -END PROCEDURE CellDOF +topo = ElementTopology(elemType) +SELECT CASE (topo) +CASE (elemopt%Point) + ans = 0 +CASE (elemopt%Line) + ans = GetTotalInDOF_Line(order=order(1), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") +CASE (elemopt%Triangle) + ans = GetTotalInDOF_Triangle(order=order(1), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") +CASE (elemopt%Quadrangle) + ans = GetTotalInDOF_Quadrangle(p=order(1), q=order(2), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") +CASE (elemopt%Tetrahedron) + ans = GetTotalInDOF_Tetrahedron(order=order(1), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") + +CASE (elemopt%Hexahedron) + ans = GetTotalInDOF_Hexahedron(p=order(1), q=order(2), r=order(3), & + baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") + +CASE (elemopt%Prism) + ans = GetTotalInDOF_Prism(order=order(1), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") +CASE (elemopt%Pyramid) + + ans = GetTotalInDOF_Pyramid(order=order(1), baseContinuity="H1", & + baseInterpolation="HEIRARCHICAL") +END SELECT +END PROCEDURE HierarchicalCellDOF !---------------------------------------------------------------------------- ! @@ -101,7 +224,8 @@ CALL HierarchicalEvalAll_(order=order, elemType=elemType, xij=xij, ans=ans, & nrow=nrow, ncol=ncol, domainName=domainName, cellOrder=cellOrder, & - faceOrder=faceOrder, edgeOrder=edgeOrder) + faceOrder=faceOrder, edgeOrder=edgeOrder, cellOrient=cellOrient, & + faceOrient=faceOrient, edgeOrient=edgeOrient) END PROCEDURE HierarchicalEvalAll @@ -111,13 +235,14 @@ MODULE PROCEDURE HierarchicalEvalAll_ #ifdef DEBUG_VER -INTEGER(I4B) :: ierr, tedge, tface, nsd -LOGICAL(LGT) :: isok -CHARACTER(:), ALLOCATABLE :: errmsg +INTEGER(I4B) :: ierr +CHARACTER(*), PARAMETER :: routine = "HierarchicalEvalAll_()" #endif INTEGER(I4B) :: topo +nrow = 0; ncol = 0 + topo = ElementTopology(elemType) SELECT CASE (topo) @@ -125,86 +250,79 @@ CASE (elemopt%Line) #ifdef DEBUG_VER - nsd = 1 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF + CALL check_error_1d(ierr=ierr, routine=routine, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + IF (ierr .LT. 0) RETURN #endif CALL HeirarchicalBasis_Line_(order=cellOrder(1), xij=xij, ans=ans, & - nrow=nrow, ncol=ncol, refLine=domainName) + nrow=nrow, ncol=ncol, refLine=domainName, orient=cellOrient(1)) CASE (elemopt%Triangle) #ifdef DEBUG_VER - nsd = 2; tFace = 3 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF + CALL check_error_2d(ierr=ierr, tface=3, routine=routine, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + IF (ierr .LT. 0) RETURN #endif - CALL HeirarchicalBasis_Triangle_(order=cellOrder(1), pe1=faceOrder(1, 1), & - pe2=faceOrder(1, 2), pe3=faceOrder(1, 3), xij=xij, refTriangle=domainName, & - ans=ans, nrow=nrow, ncol=ncol) + CALL HeirarchicalBasis_Triangle_(order=cellOrder(1), & + pe1=faceOrder(1, 1), & + pe2=faceOrder(1, 2), & + pe3=faceOrder(1, 3), & + xij=xij, & + refTriangle=domainName, & + ans=ans, nrow=nrow, ncol=ncol, & + edgeOrient1=faceOrient(1, 1), & + edgeOrient2=faceOrient(1, 2), & + edgeOrient3=faceOrient(1, 3), & + faceOrient=cellOrient) CASE (elemopt%Quadrangle) #ifdef DEBUG_VER - nsd = 2; tFace = 4 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF + CALL check_error_2d(ierr=ierr, tface=4, routine=routine, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + IF (ierr .LT. 0) RETURN #endif - CALL HeirarchicalBasis_Quadrangle_(pb=cellOrder(1), qb=cellOrder(2), & - pe3=faceOrder(1, 1), pe4=faceOrder(1, 3), qe1=faceOrder(1, 4), & - qe2=faceOrder(1, 2), xij=xij, ans=ans, nrow=nrow, ncol=ncol) - -CASE (elemopt%Tetrahedron) - -#ifdef DEBUG_VER - nsd = 3; tFace = 4; tEdge = 6 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF -#endif - - CALL HeirarchicalBasis_Tetrahedron_(order=cellOrder(1), pe1=edgeOrder(1), & - pe2=edgeOrder(2), pe3=edgeOrder(3), pe4=edgeOrder(4), pe5=edgeOrder(5), & - pe6=edgeOrder(6), ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), & - ps3=faceOrder(1, 3), ps4=faceOrder(1, 4), xij=xij, & - refTetrahedron=domainName, ans=ans, & - nrow=nrow, ncol=ncol) - -CASE (elemopt%Hexahedron) - -#ifdef DEBUG_VER - !! FIXME: Currently we consiering only three faces - nsd = 3; tFace = 3; tEdge = 12 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF -#endif - - CALL HeirarchicalBasis_Hexahedron_( & - pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), & - pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), & - pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), & - pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), & - px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), & - py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), & - pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), & - pz4=edgeOrder(12), xij=xij, ans=ans, nrow=nrow, ncol=ncol) + CALL HeirarchicalBasis_Quadrangle_(pb=cellOrder(1), & + qb=cellOrder(2), & + pe3=faceOrder(1, 1), & + pe4=faceOrder(1, 3), & + qe1=faceOrder(1, 4), & + qe2=faceOrder(1, 2), & + xij=xij, & + ans=ans, nrow=nrow, ncol=ncol, & + pe3Orient=faceOrient(1, 1), & + pe4Orient=faceOrient(1, 3), & + qe1Orient=faceOrient(1, 4), & + qe2Orient=faceOrient(1, 2), & + faceOrient=cellOrient) + +! CASE (elemopt%Tetrahedron) + +! CALL HeirarchicalBasis_Tetrahedron_(order=cellOrder(1), pe1=edgeOrder(1), & +! pe2=edgeOrder(2), pe3=edgeOrder(3), pe4=edgeOrder(4), pe5=edgeOrder(5), & +! pe6=edgeOrder(6), ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), & +! ps3=faceOrder(1, 3), ps4=faceOrder(1, 4), xij=xij, & +! refTetrahedron=domainName, ans=ans, & +! nrow=nrow, ncol=ncol) + +! CASE (elemopt%Hexahedron) + +! CALL HeirarchicalBasis_Hexahedron_( & +! pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), & +! pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), & +! pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), & +! pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), & +! px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), & +! py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), & +! pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), & +! pz4=edgeOrder(12), xij=xij, ans=ans, nrow=nrow, ncol=ncol) ! CASE (elemopt%Prism) @@ -218,68 +336,6 @@ RETURN END SELECT -#ifdef DEBUG_VER - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -CONTAINS - -SUBROUTINE check_error - - isok = PRESENT(cellOrder) - IF (.NOT. isok) THEN - ierr = -1 - errmsg = "cellOrder is not present" - RETURN - END IF - - IF (nsd .GT. 1) THEN - - isok = PRESENT(faceOrder) - IF (.NOT. isok) THEN - ierr = -2 - errmsg = "faceOrder is not present" - RETURN - END IF - - isok = SIZE(faceOrder, 2) .EQ. tface - IF (.NOT. isok) THEN - ierr = -3 - errmsg = "the size of faceOrder should be total face in elements" - RETURN - END IF - - END IF - - IF (nsd .EQ. 2) THEN - - isok = PRESENT(edgeOrder) - IF (.NOT. isok) THEN - ierr = -4 - errmsg = "edgeOrder is not present" - RETURN - END IF - - isok = SIZE(edgeOrder) .EQ. tEdge - IF (.NOT. isok) THEN - ierr = -5 - errmsg = "the size of faceOrder should be total face in elements" - RETURN - END IF - - END IF - -END SUBROUTINE check_error - -SUBROUTINE printError - CALL ErrorMsg(msg=errmsg, routine='HierarchicalEvalAll_()', & - file=__FILE__, line=__LINE__, unitno=stderr) -END SUBROUTINE printError - -#endif - END PROCEDURE HierarchicalEvalAll_ !---------------------------------------------------------------------------- @@ -298,8 +354,8 @@ END SUBROUTINE printError CALL HierarchicalGradientEvalAll_(order=order, elemType=elemType, xij=xij, & ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, domainName=domainName, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder) - + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) END PROCEDURE HierarchicalGradientEvalAll !---------------------------------------------------------------------------- @@ -307,11 +363,9 @@ END SUBROUTINE printError !---------------------------------------------------------------------------- MODULE PROCEDURE HierarchicalGradientEvalAll_ - #ifdef DEBUG_VER -INTEGER(I4B) :: ierr, tedge, tface, nsd -LOGICAL(LGT) :: isok -CHARACTER(:), ALLOCATABLE :: errmsg +INTEGER(I4B) :: ierr +CHARACTER(*), PARAMETER :: routine = "HierarchicalGradientEvalAll_()" #endif INTEGER(I4B) :: topo @@ -323,86 +377,81 @@ END SUBROUTINE printError CASE (elemopt%Line) #ifdef DEBUG_VER - nsd = 1 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF + CALL check_error_2d(ierr=ierr, tface=3, routine=routine, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + IF (ierr .LT. 0) RETURN #endif CALL HeirarchicalBasisGradient_Line_(order=cellOrder(1), xij=xij, ans=ans, & - dim1=dim1, dim2=dim2, dim3=dim3, refLine=domainName) + dim1=dim1, dim2=dim2, dim3=dim3, refLine=domainName, orient=cellOrient(1)) CASE (elemopt%Triangle) #ifdef DEBUG_VER - nsd = 2; tFace = 3 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF + CALL check_error_2d(ierr=ierr, tface=3, routine=routine, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + IF (ierr .LT. 0) RETURN #endif CALL HeirarchicalBasisGradient_Triangle_(order=cellOrder(1), & - pe1=faceOrder(1, 1), pe2=faceOrder(1, 2), pe3=faceOrder(1, 3), xij=xij, & - refTriangle=domainName, ans=ans, tsize1=dim1, tsize2=dim2, tsize3=dim3) + pe1=faceOrder(1, 1), & + pe2=faceOrder(1, 2), & + pe3=faceOrder(1, 3), & + xij=xij, & + refTriangle=domainName, & + ans=ans, tsize1=dim1, & + tsize2=dim2, tsize3=dim3, & + edgeOrient1=faceOrient(1, 1), & + edgeOrient2=faceOrient(1, 2), & + edgeOrient3=faceOrient(1, 3), & + faceOrient=cellOrient) CASE (elemopt%Quadrangle) #ifdef DEBUG_VER - nsd = 2; tFace = 4 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF + CALL check_error_2d(ierr=ierr, tface=4, routine=routine, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + IF (ierr .LT. 0) RETURN #endif -CALL HeirarchicalBasisGradient_Quadrangle_(pb=cellOrder(1), qb=cellOrder(2), & - pe3=faceOrder(1, 1), pe4=faceOrder(1, 3), qe1=faceOrder(1, 4), & - qe2=faceOrder(1, 2), xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) - -CASE (elemopt%Tetrahedron) - -#ifdef DEBUG_VER - nsd = 3; tFace = 4; tEdge = 6 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF -#endif - - CALL HeirarchicalBasisGradient_Tetrahedron_(order=cellOrder(1), & - pe1=edgeOrder(1), pe2=edgeOrder(2), pe3=edgeOrder(3), & - pe4=edgeOrder(4), pe5=edgeOrder(5), pe6=edgeOrder(6), & - ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), ps3=faceOrder(1, 3), & - ps4=faceOrder(1, 4), xij=xij, refTetrahedron=domainName, & - ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) - -CASE (elemopt%Hexahedron) - -#ifdef DEBUG_VER - !! FIXME: Currently we consiering only three faces - nsd = 3; tFace = 3; tEdge = 12 - CALL check_error - IF (ierr .LT. 0) THEN - CALL printError - RETURN - END IF -#endif - - CALL HeirarchicalBasisGradient_Hexahedron_( & - pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), & - pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), & - pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), & - pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), & - px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), & - py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), & - pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), & - pz4=edgeOrder(12), xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + CALL HeirarchicalBasisGradient_Quadrangle_(pb=cellOrder(1), & + qb=cellOrder(2), & + pe3=faceOrder(1, 1), & + qe2=faceOrder(1, 2), & + pe4=faceOrder(1, 3), & + qe1=faceOrder(1, 4), & + xij=xij, & + ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3, & + pe3Orient=faceOrient(1, 1), & + qe2Orient=faceOrient(1, 2), & + pe4Orient=faceOrient(1, 3), & + qe1Orient=faceOrient(1, 4), & + faceOrient=cellOrient) + +! CASE (elemopt%Tetrahedron) + + ! CALL HeirarchicalBasisGradient_Tetrahedron_(order=cellOrder(1), & + ! pe1=edgeOrder(1), pe2=edgeOrder(2), pe3=edgeOrder(3), & + ! pe4=edgeOrder(4), pe5=edgeOrder(5), pe6=edgeOrder(6), & + ! ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), ps3=faceOrder(1, 3), & + ! ps4=faceOrder(1, 4), xij=xij, refTetrahedron=domainName, & + ! ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +! CASE (elemopt%Hexahedron) + + ! CALL HeirarchicalBasisGradient_Hexahedron_( & + ! pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), & + ! pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), & + ! pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), & + ! pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), & + ! px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), & + ! py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), & + ! pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), & + ! pz4=edgeOrder(12), xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) ! CASE (elemopt%Prism) @@ -416,68 +465,123 @@ END SUBROUTINE printError RETURN END SELECT -#ifdef DEBUG_VER +END PROCEDURE HierarchicalGradientEvalAll_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -CONTAINS - -SUBROUTINE check_error - +SUBROUTINE check_error_1d(ierr, routine, cellOrder, faceOrder, edgeOrder, & + cellOrient, faceOrient, edgeOrient) + INTEGER(I4B), INTENT(OUT) :: ierr + CHARACTER(*), INTENT(IN) :: routine + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) + + ! internal variables + LOGICAL(LGT) :: isok + CHARACTER(:), ALLOCATABLE :: errmsg + + ierr = 0 isok = PRESENT(cellOrder) IF (.NOT. isok) THEN ierr = -1 errmsg = "cellOrder is not present" + END IF + + isok = PRESENT(cellOrient) + IF (.NOT. isok) THEN + ierr = -2 + errmsg = "cellOrient is not present" + END IF + + IF (.NOT. isok) THEN + CALL ErrorMsg(msg=errmsg, routine=routine, file=__FILE__, & + line=__LINE__, unitno=stderr) RETURN END IF - IF (nsd .GT. 1) THEN +END SUBROUTINE check_error_1d - isok = PRESENT(faceOrder) - IF (.NOT. isok) THEN - ierr = -2 - errmsg = "faceOrder is not present" - RETURN - END IF +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- - isok = SIZE(faceOrder, 2) .EQ. tface - IF (.NOT. isok) THEN - ierr = -3 - errmsg = "the size of faceOrder should be total face in elements" - RETURN - END IF +SUBROUTINE check_error_2d(ierr, tface, routine, cellOrder, & + faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) + INTEGER(I4B), INTENT(OUT) :: ierr + INTEGER(I4B), INTENT(IN) :: tface + CHARACTER(*), INTENT(IN) :: routine + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) - END IF + LOGICAL(LGT) :: isok + CHARACTER(:), ALLOCATABLE :: errmsg - IF (nsd .EQ. 2) THEN + ierr = 0 - isok = PRESENT(edgeOrder) - IF (.NOT. isok) THEN - ierr = -4 - errmsg = "edgeOrder is not present" - RETURN - END IF + isok = PRESENT(cellOrder) + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "cellOrder is not present" + CALL print_error + RETURN + END IF - isok = SIZE(edgeOrder) .EQ. tEdge - IF (.NOT. isok) THEN - ierr = -5 - errmsg = "the size of faceOrder should be total face in elements" - RETURN - END IF + isok = PRESENT(cellOrient) + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "cellOrient is not present" + CALL print_error + RETURN + END IF + isok = PRESENT(faceOrder) + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "faceOrder is not present" + CALL print_error + RETURN END IF -END SUBROUTINE check_error + isok = SIZE(faceOrder, 2) .EQ. tface + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "the size of faceOrder should be total face in elements" + CALL print_error + RETURN + END IF -SUBROUTINE printError - CALL ErrorMsg(msg=errmsg, routine='HierarchicalEvalAll_()', & - file=__FILE__, line=__LINE__, unitno=stderr) -END SUBROUTINE printError + isok = PRESENT(faceOrient) + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "faceOrient is not present" + CALL print_error + RETURN + END IF -#endif + isok = SIZE(faceOrient, 2) .EQ. tface + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "number of cols in faceOrient should be total face in elements" + CALL print_error + RETURN + END IF -END PROCEDURE HierarchicalGradientEvalAll_ +CONTAINS + SUBROUTINE print_error + CALL ErrorMsg(msg=errmsg, routine=routine, file=__FILE__, & + line=__LINE__, unitno=stderr) + END SUBROUTINE print_error + +END SUBROUTINE check_error_2d END SUBMODULE Methods From c537791d3ef4f9f84e1df2e3829959d37beb7fd2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:42:47 +0900 Subject: [PATCH 182/359] updates in line interpolation --- .../src/LineInterpolationUtility@Methods.F90 | 180 ++++++++++++++++-- 1 file changed, 164 insertions(+), 16 deletions(-) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 160b4a2db..7d218f4df 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -1330,14 +1330,8 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Line2 -ans = QuadraturePoint_Line1(& - & order=order, & - & quadType=quadType, & - & layout=layout, & - & xij=RESHAPE(xij, [1, 2]), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +ans = QuadraturePoint_Line1(order=order, quadType=quadType, layout=layout, & + xij=RESHAPE(xij, [1, 2]), alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE QuadraturePoint_Line2 !---------------------------------------------------------------------------- @@ -1345,14 +1339,8 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Line4 -ans = QuadraturePoint_Line3(& - & nips=nips, & - & quadType=quadType, & - & layout=layout, & - & xij=RESHAPE(xij, [1, 2]), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) +ans = QuadraturePoint_Line3(nips=nips, quadType=quadType, layout=layout, & + xij=RESHAPE(xij, [1, 2]), alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE QuadraturePoint_Line4 !---------------------------------------------------------------------------- @@ -1485,6 +1473,148 @@ END SUBROUTINE handle_error END IF END PROCEDURE QuadraturePoint_Line3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line1_ +#ifdef DEBUG_VER +LOGICAL(LGT) :: isok, abool +#endif + +CHARACTER(20) :: astr +INTEGER(I4B) :: np, nsd, ii +REAL(DFP) :: pt(nips(1)), wt(nips(1)) +REAL(DFP) :: t1 +LOGICAL(LGT) :: changeLayout + +#ifdef DEBUG_VER + +abool = ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType) +IF (isok) THEN +END IF + +#endif + +IF (isok) THEN + IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN + CALL ErrorMsg(& + & msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & + & routine="QuadraturePoint_Line3", & + & file=__FILE__, line=__LINE__, unitno=stderr) + END IF + RETURN + +ELSEIF (ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType)) THEN + IF (.NOT. PRESENT(lambda)) THEN + CALL ErrorMsg(& + & msg="lambda should be present for quadType=ipopt%GaussUltraspherical", & + & file=__FILE__, & + & routine="QuadraturePoint_Line3", & + & line=__LINE__, & + & unitno=stderr) + END IF + RETURN + +END IF + +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 1 +END IF + +astr = TRIM(UpperCase(layout)) +np = nips(1) +! CALL Reallocate(ans, nsd + 1_I4B, np) +ALLOCATE (ans(nsd + 1_I4B, np)) +changeLayout = .FALSE. + +SELECT CASE (quadType) + +CASE (ipopt%GaussLegendre) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) + +CASE (ipopt%GaussLegendreRadauLeft) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft) + +CASE (ipopt%GaussLegendreRadauRight) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight) + +CASE (ipopt%GaussLegendreLobatto) + CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +CASE (ipopt%GaussChebyshev) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) + +CASE (ipopt%GaussChebyshevRadauLeft) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft) + +CASE (ipopt%GaussChebyshevRadauRight) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight) + +CASE (ipopt%GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +CASE (ipopt%GaussJacobi) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & + alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiRadauLeft) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft, & + alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiRadauRight) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight, & + alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiLobatto) + CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto, & + alpha=alpha, beta=beta) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +CASE (ipopt%GaussUltraspherical) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & + lambda=lambda) + +CASE (ipopt%GaussUltrasphericalRadauLeft) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & + quadType=ipopt%GaussRadauLeft, lambda=lambda) + +CASE (ipopt%GaussUltrasphericalRadauRight) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & + quadType=ipopt%GaussRadauRight, lambda=lambda) + +CASE (ipopt%GaussUltrasphericalLobatto) + CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & + quadType=ipopt%GaussLobatto, lambda=lambda) + IF (layout .EQ. "VEFC") changeLayout = .TRUE. + +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(pt) + CALL ToVEFC_Line(wt) +END IF + +IF (PRESENT(xij)) THEN + ans(1:nsd, :) = FromBiunitLine2Segment( & + & xin=pt, & + & x1=xij(:, 1), & + & x2=xij(:, 2)) + ans(nsd + 1, :) = wt * NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP +ELSE + ans(1, :) = pt + ans(nsd + 1, :) = wt +END IF +END PROCEDURE QuadraturePoint_Line1_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Line !---------------------------------------------------------------------------- @@ -1702,6 +1832,24 @@ END SUBROUTINE handle_error ! !---------------------------------------------------------------------------- +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 From df856ff5bc25028baa05a076acf84f1c56c409c4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:42:56 +0900 Subject: [PATCH 183/359] update in quadrangle interpolation --- .../src/QuadrangleInterpolationUtility@Methods.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index b0b49a81c..289e2a10b 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -110,9 +110,17 @@ ! GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE GetTotalInDOF_Quadrangle +MODULE PROCEDURE GetTotalInDOF_Quadrangle1 ans = (order - 1)**2 -END PROCEDURE GetTotalInDOF_Quadrangle +END PROCEDURE GetTotalInDOF_Quadrangle1 + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Quadrangle2 +ans = (p - 1) * (q - 1) +END PROCEDURE GetTotalInDOF_Quadrangle2 !---------------------------------------------------------------------------- ! LagrangeDOF_Quadrangle From 40337ed092ccc342b5565060549d0b80da662868 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:43:05 +0900 Subject: [PATCH 184/359] update in triangle interpolation util --- ...lationUtility@HeirarchicalBasisMethods.F90 | 923 ++++++++++++------ 1 file changed, 612 insertions(+), 311 deletions(-) diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 index c56627c28..b516b00d9 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 @@ -23,54 +23,110 @@ CONTAINS !---------------------------------------------------------------------------- -! BarycentricVertexBasis_Triangle +! BarycentricVertexBasis_Triangle !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricVertexBasis_Triangle -INTEGER(I4B) :: a(2) -a = SHAPE(lambda) -ans(1:a(2), 1:a(1)) = TRANSPOSE(lambda) -END PROCEDURE BarycentricVertexBasis_Triangle +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on reference Triangle + +PURE SUBROUTINE BarycentricVertexBasis_Triangle(lambda, ans, nrow, & + ncol) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + !! number of rows = 3 corresponding to three coordinates + !! number of columns = number of points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! REAL(DFP) :: ans(SIZE(lambda, 2), 3) + !! ans(:,v1) basis function of vertex v1 at all points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = size(lambda, 2) + !! ncol = 3 + + !! internal variables + INTEGER(I4B) :: ii, jj + + nrow = SIZE(lambda, 2) + ncol = SIZE(lambda, 1) + + DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = lambda(jj, ii) + END DO + +END SUBROUTINE BarycentricVertexBasis_Triangle !---------------------------------------------------------------------------- ! VertexBasis_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE VertexBasis_Triangle +INTEGER(I4B) :: nrow, ncol REAL(DFP) :: lambda(3, SIZE(xij, 2)) CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans) +CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans, nrow=nrow, & + ncol=ncol) END PROCEDURE VertexBasis_Triangle !---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Triangle +! BarycentricEdgeBasis_Triangle !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricEdgeBasis_Triangle -INTEGER(I4B), PARAMETER :: orient = 1 -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) -INTEGER(I4B) :: maxP, tPoints, ii, jj +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edge of triangle +! +!# Introduction +! +! Evaluate basis functions on edges of triangle +! pe1, pe2, pe3 should be greater than or equal to 2 -tPoints = SIZE(lambda, 2) -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) +PURE SUBROUTINE BarycentricEdgeBasis_Triangle(pe1, pe2, pe3, lambda, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge (e1) + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge (e2) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge (e3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! Number of rows in lambda is equal to three corresponding to + !! three coordinates + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow=SIZE(lambda, 2) + !! ncol=pe1 + pe2 + pe3 - 3 -DO CONCURRENT(ii=1:tpoints) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) -END DO + INTEGER(I4B), PARAMETER :: orient = 1 + REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) + ! REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) + REAL(DFP), ALLOCATABLE :: phi(:, :) -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=ii, ncol=jj) + INTEGER(I4B) :: maxP, ii -CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, ans=ans, nrow=ii, ncol=jj, edgeOrient1=orient, & - edgeOrient2=orient, edgeOrient3=orient) + nrow = SIZE(lambda, 2) + ! ncol = pe1 + pe2 + pe3 - 3 + maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) + + ALLOCATE (phi(1:3 * nrow, 0:maxP)) + + DO CONCURRENT(ii=1:nrow) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii) + END DO -END PROCEDURE BarycentricEdgeBasis_Triangle + CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol) + + CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & + lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol, & + edgeOrient1=orient, edgeOrient2=orient, edgeOrient3=orient) + +END SUBROUTINE BarycentricEdgeBasis_Triangle !---------------------------------------------------------------------------- ! @@ -95,9 +151,11 @@ MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & !! size(lambda,2) = number of points of evaluation REAL(DFP), INTENT(IN) :: phi(1:, 0:) !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 1) = 3*number of points !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + !! (lambda2-lambda1), + !! (lambda3-lambda2), + !! (lambda1-lambda3) REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) INTEGER(I4B), INTENT(OUT) :: nrow, ncol @@ -106,20 +164,23 @@ MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 !! Internal variables - INTEGER(I4B) :: a, ii, jj - REAL(DFP) :: temp, areal + REAL(DFP) :: temp, areal, o1, o2, o3 nrow = SIZE(lambda, 2) ! tPoints = SIZE(lambda, 2) ncol = pe1 + pe2 + pe3 - 3 + o1 = REAL(edgeOrient1, kind=DFP) + o2 = REAL(edgeOrient2, kind=DFP) + o3 = REAL(edgeOrient3, kind=DFP) + ! ans = 0.0_DFP a = 0 ! edge(1) = 1 -> 2 DO ii = 1, pe1 - 1 - areal = REAL(edgeOrient1**(ii + 1), kind=DFP) + areal = o1**(ii + 1) ! ans(1:nrow, a + ii) = areal * temp * phi(1:nrow, ii - 1) DO jj = 1, nrow @@ -132,7 +193,7 @@ MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & a = pe1 - 1 DO ii = 1, pe2 - 1 - areal = REAL(edgeOrient2**(ii + 1), kind=DFP) + areal = o2**(ii + 1) DO jj = 1, nrow temp = lambda(2, jj) * lambda(3, jj) * areal @@ -145,7 +206,7 @@ MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & a = pe1 - 1 + pe2 - 1 DO ii = 1, pe3 - 1 - areal = REAL(edgeOrient3**(ii + 1), kind=DFP) + areal = o3**(ii + 1) DO jj = 1, nrow temp = areal * lambda(3, jj) * lambda(1, jj) @@ -160,39 +221,59 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle2 MODULE PROCEDURE EdgeBasis_Triangle REAL(DFP) :: lambda(3, SIZE(xij, 2)) +INTEGER(I4B) :: nrow, ncol + CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) CALL BarycentricEdgeBasis_Triangle(lambda=lambda, ans=ans, pe1=pe1, & - pe2=pe2, pe3=pe3) + pe2=pe2, pe3=pe3, nrow=nrow, ncol=ncol) END PROCEDURE EdgeBasis_Triangle !---------------------------------------------------------------------------- -! BarycentricEdgeBasis_Triangle +! BarycentricCellBasis_Triangle !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricCellBasis_Triangle -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:order - 2) -INTEGER(I4B) :: maxP, tPoints, ii, nrow, ncol -INTEGER(I4B), PARAMETER :: faceOrient(2) = [0, 1] +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the Cell basis functions on reference Triangle + +PURE SUBROUTINE BarycentricCellBasis_Triangle(order, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order in this cell, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + !! number of rows = 3 corresponding to three coordinates + !! number of columns = number of points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(lambda, 2) + !! ncol = INT((order - 1) * (order - 2) / 2) -tPoints = SIZE(lambda, 2) -maxP = order - 2 + !! internal variables + REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) + REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:order - 2) + INTEGER(I4B) :: maxP, ii + INTEGER(I4B), PARAMETER :: faceOrient(2) = [0, 1] -DO CONCURRENT(ii=1:tpoints) - ! Cell 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! Cell 2 -> 3 - d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) - ! Cell 3 -> 1 - d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) -END DO + nrow = SIZE(lambda, 2) + maxP = order - 2 + + DO CONCURRENT(ii=1:nrow) + ! Cell 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! Cell 2 -> 3 + d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii) + ! Cell 3 -> 1 + d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii) + END DO -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=ans, nrow=nrow, ncol=ncol) + CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=ans, nrow=nrow, & + ncol=ncol) -CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & + CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & ans=ans, nrow=nrow, ncol=ncol, faceOrient=faceOrient) -END PROCEDURE BarycentricCellBasis_Triangle +END SUBROUTINE BarycentricCellBasis_Triangle !---------------------------------------------------------------------------- ! @@ -283,7 +364,7 @@ PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans, & INTEGER(I4B), INTENT(IN) :: faceOrient(2) INTEGER(I4B) :: k1, k2, cnt, id, indx(2, 2), aint, bint, ii - REAL(DFP) :: temp, areal, breal + REAL(DFP) :: temp, areal, breal, o1 nrow = SIZE(lambda, 2) ncol = INT((order - 1) * (order - 2) / 2) @@ -296,11 +377,13 @@ PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans, & aint = indx(1, 1) - 1 bint = indx(1, 2) - 1 + o1 = REAL(faceOrient(2), kind=DFP) + DO k1 = 1, order - 2 - areal = REAL(faceOrient(2)**(k1 + 1), kind=DFP) + areal = o1**(k1 + 1) DO k2 = 1, order - 1 - k1 - breal = REAL(faceOrient(2)**(k2 + 1), kind=DFP) + breal = o1**(k2 + 1) breal = breal * areal cnt = cnt + 1 @@ -323,86 +406,97 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 MODULE PROCEDURE CellBasis_Triangle REAL(DFP) :: lambda(3, SIZE(xij, 2)) +INTEGER(I4B) :: nrow, ncol CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricCellBasis_Triangle(lambda=lambda, ans=ans, order=order) +CALL BarycentricCellBasis_Triangle(lambda=lambda, ans=ans, order=order, & + nrow=nrow, ncol=ncol) END PROCEDURE CellBasis_Triangle !---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle +! !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle1 -INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1] - -CALL BarycentricHeirarchicalBasis_Triangle3(order=order, pe1=pe1, pe2=pe2, & - pe3=pe3, lambda=lambda, refTriangle=refTriangle, edgeOrient1=orient, & - edgeOrient2=orient, edgeOrient3=orient, faceOrient=faceOrient, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE BarycentricHeirarchicalBasis_Triangle1 +MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle(order, & + pe1, pe2, pe3, lambda, refTriangle, edgeOrient1, edgeOrient2, & + edgeOrient3, faceOrient, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge e1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge e2 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 3 + !! number of cols = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 + !! edge orientation 1 or -1 + INTEGER(I4B), INTENT(IN) :: faceOrient(:) + !! face orientation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(lambda, 2) + !! ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) -!---------------------------------------------------------------------------- -! BarycentricHeirarchicalBasis_Triangle -!---------------------------------------------------------------------------- + !! Internal variables + INTEGER(I4B) :: ii, maxP, indx(3) + REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) + REAL(DFP), ALLOCATABLE :: phi(:, :) + LOGICAL(LGT) :: isok -MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2 -CALL BarycentricHeirarchicalBasis_Triangle1(order=order, pe1=order, & - pe2=order, pe3=order, lambda=lambda, & - refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE BarycentricHeirarchicalBasis_Triangle2 + nrow = SIZE(lambda, 2) + ! ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) + ncol = 0 -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- + maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) -MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle3 -INTEGER(I4B) :: a, b, ii, maxP, indx(2) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), & - 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)) -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -LOGICAL(LGT) :: isok + ALLOCATE (phi(1:3 * nrow, 0:maxP)) -nrow = SIZE(lambda, 2) -ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) + DO CONCURRENT(ii=1:nrow) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii) + END DO -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) + CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=indx(1), & + ncol=indx(2)) -DO CONCURRENT(ii=1:nrow) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii) -END DO + !! Vertex basis function + CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3), & + nrow=indx(1), ncol=indx(2)) -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + !! Edge basis function + ncol = ncol + indx(2) -! Vertex basis function -!FIXME: Add nrow and ncol info in BarycentricVertexBasis_Triangle -CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3)) + isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) + IF (isok) THEN + CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & + lambda=lambda, phi=phi, ans=ans(:, ncol + 1:), nrow=indx(1), & + ncol=indx(2), edgeOrient1=edgeOrient1, edgeOrient2=edgeOrient2, & + edgeOrient3=edgeOrient3) -! Edge basis function -b = 3 + ncol = ncol + indx(2) + END IF -isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) -IF (isok) THEN - a = b + 1 - b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 - CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, ans=ans(:, a:), nrow=indx(1), & - ncol=indx(2), edgeOrient1=edgeOrient1, edgeOrient2=edgeOrient2, & - edgeOrient3=edgeOrient3) -END IF + !! Cell basis function + isok = order .GT. 2_I4B + IF (isok) THEN + CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & + ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient) + ncol = ncol + indx(2) + END IF -! Cell basis function -IF (order .GT. 2_I4B) THEN - a = b + 1 - b = a - 1 + INT((order - 1) * (order - 2) / 2) - CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, & - ans=ans(1:nrow, a:b), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient) -END IF + DEALLOCATE (phi) -END PROCEDURE BarycentricHeirarchicalBasis_Triangle3 +END SUBROUTINE BarycentricHeirarchicalBasis_Triangle !---------------------------------------------------------------------------- ! HeirarchicalBasis_Triangle @@ -419,11 +513,11 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Triangle1_ -REAL(DFP) :: lambda(3, SIZE(xij, 2)) -CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricHeirarchicalBasis_Triangle(order=order, pe1=pe1, pe2=pe2, & - pe3=pe3, lambda=lambda, refTriangle=refTriangle, ans=ans, nrow=nrow, & - ncol=ncol) +INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [0, 1] +CALL HeirarchicalBasis_Triangle3_(order=order, pe1=pe1, pe2=pe2, pe3=pe3, & + xij=xij, refTriangle=refTriangle, edgeOrient1=orient, & + edgeOrient2=orient, edgeOrient3=orient, faceOrient=faceOrient, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE HeirarchicalBasis_Triangle1_ !---------------------------------------------------------------------------- @@ -441,58 +535,175 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Triangle2_ -REAL(DFP) :: lambda(3, SIZE(xij, 2)) -CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) -CALL BarycentricHeirarchicalBasis_Triangle(order=order, lambda=lambda, & - refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) +INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [0, 1] +CALL HeirarchicalBasis_Triangle3_(order=order, pe1=order, pe2=order, pe3=order, & + xij=xij, refTriangle=refTriangle, edgeOrient1=orient, & + edgeOrient2=orient, edgeOrient3=orient, faceOrient=faceOrient, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE HeirarchicalBasis_Triangle2_ !---------------------------------------------------------------------------- -! BarycentricVertexBasisGradient_Triangle +! HeirarchicalBasis_Triangle !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricVertexBasisGradient_Triangle -INTEGER(I4B) :: ii, tp - -tp = SIZE(lambda, 2) -ans(1:tp, 1:3, 1:3) = 0.0_DFP -DO CONCURRENT(ii=1:3) - ans(1:tp, ii, ii) = 1.0_DFP -END DO - -END PROCEDURE BarycentricVertexBasisGradient_Triangle +MODULE PROCEDURE HeirarchicalBasis_Triangle3_ +REAL(DFP) :: lambda(3, SIZE(xij, 2)) +CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij) +CALL BarycentricHeirarchicalBasis_Triangle(order=order, pe1=pe1, pe2=pe2, & + pe3=pe3, lambda=lambda, refTriangle=refTriangle, edgeOrient1=edgeOrient1, & + edgeOrient2=edgeOrient2, edgeOrient3=edgeOrient3, faceOrient=faceOrient, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Triangle3_ !---------------------------------------------------------------------------- -! BarycentricEdgeBasisGradient_Triangle2 +! !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricEdgeBasisGradient_Triangle -REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) -REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) -REAL(DFP) :: gradientPhi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) -INTEGER(I4B) :: maxP, tPoints, ii, a, b +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-21 +! summary: Evaluate the gradient of the edge basis on triangle +! using barycentric coordinate -tPoints = SIZE(lambda, 2) -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) +PURE SUBROUTINE BarycentricVertexBasisGradient_Triangle(lambda, ans, & + dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! ans(SIZE(lambda, 2), 3, 3) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(lambda, 2) + !! dim2 = 3 + !! dim3 = 3 -DO CONCURRENT(ii=1:tpoints) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii) -END DO + INTEGER(I4B) :: ii -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + dim1 = SIZE(lambda, 2) + dim2 = 3 + dim3 = 3 -CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & - nrow=a, ncol=b) + ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + DO CONCURRENT(ii=1:dim2) + ans(1:dim1, ii, ii) = 1.0_DFP + END DO +END SUBROUTINE BarycentricVertexBasisGradient_Triangle -CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & - lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans) +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -END PROCEDURE BarycentricEdgeBasisGradient_Triangle +!> author: Shion Shimizu +! date: 2024-04-21 +! summary: Evaluate the gradient of the edge basis on triangle +! using barycentric coordinate + +! PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle(pe1, pe2, pe3, lambda, & +! ans, dim1, dim2, dim3) +! INTEGER(I4B), INTENT(IN) :: pe1 +! !! order on edge (e1) +! INTEGER(I4B), INTENT(IN) :: pe2 +! !! order on edge (e2) +! INTEGER(I4B), INTENT(IN) :: pe3 +! !! order on edge (e3) +! REAL(DFP), INTENT(IN) :: lambda(:, :) +! !! point of evaluation in terms of barycentric coordinates +! !! size(lambda,1) = 3 +! !! size(lambda,2) = number of points of evaluation +! REAL(DFP), INTENT(INOUT) :: ans(:, :, :) +! !! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) +! INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 +! !! dim1=SIZE(lambda, 2) +! !! dim2=pe1 + pe2 + pe3 - 3 +! !! dim3=3 +! +! REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) +! REAL(DFP), ALLOCATABLE :: gradientPhi(:, :), phi(:, :) +! INTEGER(I4B) :: maxP, ii +! +! dim1 = SIZE(lambda, 2) +! ! dim2 = pe1 + pe2 + pe3 - 3 +! ! dim3 = 3 +! +! maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) +! +! ALLOCATE (gradientPhi(1:3 * dim1, 0:maxP), phi(1:3 * dim1, 0:maxP)) +! +! DO CONCURRENT(ii=1:dim1) +! ! edge 1 -> 2 +! d_lambda(ii) = lambda(2, ii) - lambda(1, ii) +! ! edge 2 -> 3 +! d_lambda(ii + dim1) = lambda(3, ii) - lambda(2, ii) +! ! edge 3 -> 1 +! d_lambda(ii + 2 * dim1) = lambda(1, ii) - lambda(3, ii) +! END DO +! +! CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=dim1, ncol=dim2) +! +! CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & +! nrow=dim1, ncol=dim2) +! +! CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & +! lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans, & +! dim1=dim1, dim2=dim2, dim3=dim3) +! +! DEALLOCATE (gradientPhi, phi) +! +! END SUBROUTINE BarycentricEdgeBasisGradient_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2024-04-21 +! summary: Evaluate the gradient of the edge basis on triangle +! using barycentric coordinate +! +! PURE SUBROUTINE BarycentricCellBasisGradient_Triangle(order, lambda, ans, & +! dim1, dim2, dim3) +! INTEGER(I4B), INTENT(IN) :: order +! !! order on Cell (e1) +! REAL(DFP), INTENT(IN) :: lambda(:, :) +! !! point of evaluation in terms of barycentric coordinates +! !! size(lambda,1) = 3 +! !! size(lambda,2) = number of points of evaluation +! REAL(DFP), INTENT(INOUT) :: ans(:, :, :) +! ! REAL(DFP) :: ans(SIZE(lambda, 2), 3*order - 3, 3) +! INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 +! !! dim1=SIZE(lambda, 2) +! !! dim2=3*order - 3 +! !! dim3=3 +! +! !! internal variables +! INTEGER(I4B) :: a, b, ii, maxP, tp +! REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) +! +! dim1 = SIZE(lambda, 2) +! maxP = order - 2 +! +! a = 3 * dim1; b = maxP +! ALLOCATE (phi(a, b), gradientPhi(a, b), d_lambda(a)) +! +! DO CONCURRENT(ii=1:dim1) +! ! edge 1 -> 2 +! d_lambda(ii) = lambda(2, ii) - lambda(1, ii) +! ! edge 2 -> 3 +! d_lambda(ii + dim1) = lambda(3, ii) - lambda(2, ii) +! ! edge 3 -> 1 +! d_lambda(ii + 2 * dim1) = lambda(1, ii) - lambda(3, ii) +! END DO +! +! CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=dim1, ncol=dim2) +! +! CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & +! nrow=dim1, ncol=dim2) +! +! CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & +! phi=phi, gradientPhi=gradientPhi, ans=ans, dim1=dim1, dim2=dim2, & +! dim3=dim3, faceOrient=faceOrient) +! +! END SUBROUTINE BarycentricCellBasisGradient_Triangle !---------------------------------------------------------------------------- ! @@ -504,111 +715,132 @@ END SUBROUTINE BarycentricCellBasis_Triangle2 ! using barycentric coordinate PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle2(pe1, pe2, pe3, & - lambda, phi, gradientPhi, ans) + lambda, phi, gradientPhi, ans, dim1, dim2, dim3, & + edgeOrient1, edgeOrient2, edgeOrient3) INTEGER(I4B), INTENT(IN) :: pe1 - !! order on edge (e1) + !! order on edge (e1) INTEGER(I4B), INTENT(IN) :: pe2 - !! order on edge (e2) + !! order on edge (e2) INTEGER(I4B), INTENT(IN) :: pe3 - !! order on edge (e3) + !! order on edge (e3) REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation in terms of barycentric coordinates - !! size(lambda,1) = 3 - !! size(lambda,2) = number of points of evaluation + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + !! (lambda2-lambda1) + !! (lambda3-lambda2) + !! (lambda1-lambda3) REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:) - !! gradients of lobatto kernel functions + !! gradients of lobatto kernel functions REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) + !! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1=SIZE(lambda, 2) + !! dim2=pe1 + pe2 + pe3 - 3 + !! dim3=3 + INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 + !! edge orientation - INTEGER(I4B) :: tp, a, ii - REAL(DFP) :: temp(SIZE(lambda, 2)) - ! FIXME: Remove this temp + !! Internal variables + INTEGER(I4B) :: a, ii, jj + REAL(DFP) :: rr(10), o1, o2, o3 - tp = SIZE(lambda, 2) + dim1 = SIZE(lambda, 2) + dim2 = pe1 + pe2 + pe3 - 3 + dim3 = 3 - !FIXME: Make these loop parallel + o1 = REAL(edgeOrient1, kind=DFP) + o2 = REAL(edgeOrient2, kind=DFP) + o3 = REAL(edgeOrient3, kind=DFP) a = 0 ! edge(1) = 1 -> 2 - temp = lambda(1, :) * lambda(2, :) + DO ii = 1, pe1 - 1 - ans(1:tp, a + ii, 1) = lambda(2, :) * phi(1:tp, ii - 1) - & - temp * gradientPhi(1:tp, ii - 1) - ans(1:tp, a + ii, 2) = lambda(1, :) * phi(1:tp, ii - 1) + & - temp * gradientPhi(1:tp, ii - 1) - ans(1:tp, a + ii, 3) = 0.0_DFP + rr(1) = o1**(ii + 1) + rr(2) = o1**(ii) + + DO jj = 1, dim1 + rr(3) = lambda(1, jj) * lambda(2, jj) + + rr(4) = rr(1) * lambda(2, jj) * phi(jj, ii - 1) + + rr(5) = rr(2) * rr(3) * gradientPhi(jj, ii - 1) + + ans(jj, a + ii, 1) = rr(4) - rr(5) + + rr(4) = rr(1) * lambda(1, jj) * phi(jj, ii - 1) + + rr(5) = rr(2) * rr(3) * gradientPhi(jj, ii - 1) + + ans(jj, a + ii, 2) = rr(4) + rr(5) + + ans(jj, a + ii, 3) = 0.0_DFP + + END DO + END DO ! edge(2) = 2 -> 3 a = pe1 - 1 - temp = lambda(2, :) * lambda(3, :) + DO ii = 1, pe2 - 1 - ans(1:tp, a + ii, 1) = 0.0_DFP + rr(1) = o2**(ii + 1) + rr(2) = o2**(ii) + + DO jj = 1, dim1 + rr(3) = lambda(2, jj) * lambda(3, jj) + + ans(jj, a + ii, 1) = 0.0_DFP + + rr(4) = rr(1) * lambda(3, jj) * phi(jj + dim1, ii - 1) + rr(5) = rr(2) * rr(3) * gradientPhi(jj + dim1, ii - 1) + + ans(jj, a + ii, 2) = rr(4) - rr(5) - ans(1:tp, a + ii, 2) = lambda(3, :) * & - phi(1 + tp:2 * tp, ii - 1) - & - temp * gradientPhi(1 + tp:2 * tp, ii - 1) + rr(4) = rr(1) * lambda(2, jj) * phi(jj + dim1, ii - 1) + rr(5) = rr(2) * rr(3) * gradientPhi(jj + dim1, ii - 1) + + ans(jj, a + ii, 3) = rr(4) + rr(5) + + END DO - ans(1:tp, a + ii, 3) = lambda(2, :) * & - phi(1 + tp:2 * tp, ii - 1) + & - temp * gradientPhi(1 + tp:2 * tp, ii - 1) END DO ! edge(3) = 3 -> 1 a = pe1 - 1 + pe2 - 1 - temp = lambda(3, :) * lambda(1, :) + DO ii = 1, pe3 - 1 - ans(1:tp, a + ii, 1) = lambda(3, :) * & - phi(1 + 2 * tp:3 * tp, ii - 1) + & - temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1) + rr(1) = o3**(ii + 1) + rr(2) = o3**(ii) - ans(1:tp, a + ii, 2) = 0.0_DFP + DO jj = 1, dim1 + rr(3) = lambda(3, jj) * lambda(1, jj) - ans(1:tp, a + ii, 3) = lambda(1, :) * & - phi(1 + 2 * tp:3 * tp, ii - 1) - & - temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1) - END DO -END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2 + rr(4) = rr(1) * lambda(3, jj) * phi(jj + 2 * dim1, ii - 1) + rr(5) = rr(2) * rr(3) * gradientPhi(jj + 2 * dim1, ii - 1) -!---------------------------------------------------------------------------- -! BarycentricVertexBasisGradient_Triangle -!---------------------------------------------------------------------------- + ans(jj, a + ii, 1) = rr(4) + rr(5) -MODULE PROCEDURE BarycentricCellBasisGradient_Triangle -INTEGER(I4B) :: a, b, ii, maxP, tp -REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) + ans(jj, a + ii, 2) = 0.0_DFP -tp = SIZE(lambda, 2) -maxP = order - 2 + rr(4) = rr(1) * lambda(1, jj) * phi(jj + 2 * dim1, ii - 1) + rr(5) = rr(2) * rr(3) * gradientPhi(jj + 2 * dim1, ii - 1) -a = 3 * tp; b = maxP -ALLOCATE (phi(a, b), gradientPhi(a, b), d_lambda(a)) + ans(jj, a + ii, 3) = rr(4) - rr(5) -DO CONCURRENT(ii=1:tp) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii) -END DO - -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + END DO -CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & - nrow=a, ncol=b) + END DO -CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & - phi=phi, gradientPhi=gradientPhi, ans=ans) -END PROCEDURE BarycentricCellBasisGradient_Triangle +END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2 !---------------------------------------------------------------------------- -! BarycentricCellBasisGradient_Triangle +! BarycentricCellBasisGradient_Triangle2 !---------------------------------------------------------------------------- !> author: Shion Shimizu @@ -616,53 +848,71 @@ END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2 ! summary: Evaluate the gradient of the cell basis on triangle PURE SUBROUTINE BarycentricCellBasisGradient_Triangle2(order, lambda, phi, & - gradientPhi, ans) + gradientPhi, ans, dim1, dim2, dim3, faceOrient) INTEGER(I4B), INTENT(IN) :: order - !! order in the cell of triangle, it should be greater than 2 + !! order in the cell of triangle, it should be greater than 2 REAL(DFP), INTENT(IN) :: lambda(:, :) - !! point of evaluation + !! point of evaluation REAL(DFP), INTENT(IN) :: phi(1:, 0:) - !! lobatto kernel values - !! size(phi1, 1) = 3*number of points (lambda2-lambda1), - !! (lambda3-lambda1), (lambda3-lambda2) - !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:) - !! gradients of lobatto kernel functions + !! gradients of lobatto kernel functions REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2), 3) + !! gradient + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(lambda, 2) + !! dim2 = INT((order - 1) * (order - 2) / 2) + !! dim3 = 3 + INTEGER(I4B), INTENT(IN) :: faceOrient(2) + !! face orientation ! internal variables - INTEGER(I4B) :: tPoints, k1, k2, cnt - REAL(DFP) :: temp1(SIZE(lambda, 2)), temp2(SIZE(lambda, 2)) - REAL(DFP) :: temp3(SIZE(lambda, 2)), temp4(SIZE(lambda, 2)) + INTEGER(I4B) :: k1, k2, cnt, ii + REAL(DFP) :: rr(10) - ! FIXME: Remove these temps + dim1 = SIZE(lambda, 2) + dim2 = INT((order - 1) * (order - 2) / 2) + dim3 = 3 - tPoints = SIZE(lambda, 2) - temp1 = lambda(1, :) * lambda(2, :) * lambda(3, :) - temp2 = lambda(2, :) * lambda(3, :) - temp3 = lambda(1, :) * lambda(3, :) - temp4 = lambda(1, :) * lambda(2, :) cnt = 0 - ! FIXME: make these loop parallel - DO k1 = 1, order - 2 DO k2 = 1, order - 1 - k1 + cnt = cnt + 1 - ans(:, cnt, 1) = temp2 * phi(1:tPoints, k1 - 1) * & - phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & - temp1 * (gradientPhi(1:tPoints, k1 - 1) * & - phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & - phi(1:tPoints, k1 - 1) * & - gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1)) - ans(:, cnt, 2) = (temp3 * phi(1:tPoints, k1 - 1) + & - temp1 * gradientPhi(1:tPoints, k1 - 1)) * & - phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - ans(:, cnt, 3) = (temp4 * phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - & - temp1 * gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1)) * & - phi(1:tPoints, k1 - 1) + + DO ii = 1, dim1 + + rr(1) = lambda(1, ii) * lambda(2, ii) * lambda(3, ii) + rr(2) = lambda(2, ii) * lambda(3, ii) + rr(3) = lambda(1, ii) * lambda(3, ii) + rr(4) = lambda(1, ii) * lambda(2, ii) + + rr(5) = rr(2) * phi(ii, k1 - 1) * phi(ii + 2 * dim1, k2 - 1) + rr(6) = phi(ii + 2 * dim1, k2 - 1) * gradientPhi(ii, k1 - 1) + rr(7) = phi(ii, k1 - 1) * gradientPhi(ii + 2 * dim1, k2 - 1) + rr(8) = rr(6) - rr(7) + ans(ii, cnt, 1) = rr(5) - rr(1) * rr(8) + + rr(5) = rr(3) * phi(ii, k1 - 1) + rr(6) = rr(1) * gradientPhi(ii, k1 - 1) + rr(7) = rr(5) + rr(6) + rr(8) = phi(ii + 2 * dim1, k2 - 1) + ans(ii, cnt, 2) = rr(7) * rr(8) + + rr(5) = rr(4) * phi(ii + 2 * dim1, k2 - 1) + rr(6) = rr(1) * gradientPhi(ii + 2 * dim1, k2 - 1) + rr(7) = rr(5) - rr(6) + rr(8) = phi(ii, k1 - 1) + ans(ii, cnt, 3) = rr(7) * rr(8) + + END DO + END DO + END DO END SUBROUTINE BarycentricCellBasisGradient_Triangle2 @@ -670,58 +920,93 @@ END SUBROUTINE BarycentricCellBasisGradient_Triangle2 ! BarycentricHeirarchicalBasis_Triangle !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1 -INTEGER(I4B) :: a, b, ii, maxP, tp -REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) -LOGICAL(LGT) :: isok +PURE SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle(order, pe1, & + pe2, pe3, lambda, refTriangle, ans, dim1, dim2, dim3, edgeOrient1, & + edgeOrient2, edgeOrient3, faceOrient) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge e1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge e2 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! Barycenteric coordinates + !! number of rows = 3 + !! number of cols = number of points + CHARACTER(*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1=SIZE(lambda, 2) + !! dim2=pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) + !! dim3=3 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! range of data written in ans + INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3 + !! edge orientation + INTEGER(I4B), INTENT(IN) :: faceOrient(2) + !! face orientation -tp = SIZE(lambda, 2) -maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) + INTEGER(I4B) :: a, b, ii, maxP, indx(3) + REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:) + LOGICAL(LGT) :: isok -a = 3 * tp; b = maxP -ALLOCATE (phi(a, 0:b), gradientPhi(a, 0:b), d_lambda(a)) + dim1 = SIZE(lambda, 2) + dim2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) + dim3 = 3 -DO CONCURRENT(ii=1:tp) - ! edge 1 -> 2 - d_lambda(ii) = lambda(2, ii) - lambda(1, ii) - ! edge 2 -> 3 - d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii) - ! edge 3 -> 1 - d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii) -END DO + maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) -CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b) + a = 3 * dim1; b = maxP + ALLOCATE (phi(a, 0:b), gradientPhi(a, 0:b), d_lambda(a)) -CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & - nrow=a, ncol=b) + DO CONCURRENT(ii=1:dim1) + ! edge 1 -> 2 + d_lambda(ii) = lambda(2, ii) - lambda(1, ii) + ! edge 2 -> 3 + d_lambda(ii + dim1) = lambda(3, ii) - lambda(2, ii) + ! edge 3 -> 1 + d_lambda(ii + 2 * dim1) = lambda(1, ii) - lambda(3, ii) + END DO -! gradient of vertex basis -ans(1:tp, 1:3, 1:3) = 0.0_DFP -DO CONCURRENT(ii=1:3) - ans(1:tp, ii, ii) = 1.0_DFP -END DO + CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=indx(1), & + ncol=indx(2)) + + CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, & + nrow=indx(1), ncol=indx(2)) + + ! gradient of vertex basis + ans(1:dim1, 1:3, 1:3) = 0.0_DFP + DO CONCURRENT(ii=1:3) + ans(1:dim1, ii, ii) = 1.0_DFP + END DO -! gradient of Edge basis function -b = 3 -isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) -IF (isok) THEN - a = b + 1 - b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 - CALL BarycentricEdgeBasisGradient_Triangle2( & - pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, & - phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :)) -END IF - -! gradient of Cell basis function -IF (order .GT. 2_I4B) THEN - a = b + 1 - b = a - 1 + INT((order - 1) * (order - 2) / 2) - CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & - phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :)) -END IF - -DEALLOCATE (phi, gradientPhi, d_lambda) -END PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1 + ! gradient of Edge basis function + b = 3 + isok = ANY([pe1, pe2, pe3] .GE. 2_I4B) + IF (isok) THEN + a = b + 1 + b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 + CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & + lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :), & + dim1=indx(1), dim2=indx(2), dim3=indx(3), edgeOrient1=edgeOrient1, & + edgeOrient2=edgeOrient2, edgeOrient3=edgeOrient3) + END IF + + ! gradient of Cell basis function + isok = order .GT. 2_I4B + IF (isok) THEN + a = b + 1 + b = a - 1 + INT((order - 1) * (order - 2) / 2) + CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, & + phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :), & + dim1=indx(1), dim2=indx(2), dim3=indx(3), faceOrient=faceOrient) + END IF + + DEALLOCATE (phi, gradientPhi, d_lambda) + +END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Triangle @@ -739,21 +1024,37 @@ END SUBROUTINE BarycentricCellBasisGradient_Triangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1_ +INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [0, 1] + +CALL HeirarchicalBasisGradient_Triangle2_(order=order, pe1=pe1, pe2=pe2, & + pe3=pe3, xij=xij, edgeOrient1=orient, edgeOrient2=orient, & + edgeOrient3=orient, faceOrient=faceOrient, refTriangle=refTriangle, & + ans=ans, tsize1=tsize1, tsize2=tsize2, tsize3=tsize3) +END PROCEDURE HeirarchicalBasisGradient_Triangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Triangle2_ REAL(DFP) :: jac(3, 2) REAL(DFP), ALLOCATABLE :: lambda(:, :), dPhi(:, :, :) -INTEGER(I4B) :: ii, jj, kk +INTEGER(I4B) :: ii, jj, kk, indx(3) ii = SIZE(xij, 2) jj = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) ALLOCATE (lambda(3, ii), dPhi(ii, jj, 3)) + tsize1 = SIZE(xij, 2) tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2) tsize3 = 2 CALL BarycentricCoordTriangle_(xin=xij, refTriangle=refTriangle, ans=lambda) -CALL BarycentricHeirarchicalBasisGradient_Triangle( & - order=order, pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, & - refTriangle=refTriangle, ans=dPhi) + +CALL BarycentricHeirarchicalBasisGradient_Triangle(order=order, pe1=pe1, & + pe2=pe2, pe3=pe3, lambda=lambda, refTriangle=refTriangle, ans=dPhi, & + dim1=indx(1), dim2=indx(2), dim3=indx(3), edgeOrient1=edgeOrient1, & + edgeOrient2=edgeOrient2, edgeOrient3=edgeOrient3, faceOrient=faceOrient) SELECT CASE (refTriangle(1:1)) CASE ("B", "b") @@ -774,7 +1075,7 @@ END SUBROUTINE BarycentricCellBasisGradient_Triangle2 DEALLOCATE (lambda, dPhi) -END PROCEDURE HeirarchicalBasisGradient_Triangle1_ +END PROCEDURE HeirarchicalBasisGradient_Triangle2_ !---------------------------------------------------------------------------- ! From d00426276852eeebfc42063b24eb4c5c5a7d55bf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:43:15 +0900 Subject: [PATCH 185/359] update in quadrature point --- ...draturePoint_Method@ConstructorMethods.F90 | 1825 +++++++++-------- 1 file changed, 977 insertions(+), 848 deletions(-) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index 9387b1aab..42fee7005 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -20,8 +20,14 @@ ! summary: Constructor methods for [[QuadraturePoint_]] SUBMODULE(QuadraturePoint_Method) ConstructorMethods -USE BaseMethod +USE BaseInterpolation_Method, ONLY: BaseInterpolation_ToString, & + BaseInterpolation_ToInteger +USE ReallocateUtility, ONLY: Reallocate + +USE ReferenceElement_Method, ONLY: ElementTopology + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -44,894 +50,1017 @@ ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate1 -obj%points = points -obj%tXi = SIZE(points, 1) - 1 -! No of row minus one -END PROCEDURE quad_initiate1 +MODULE PROCEDURE obj_Initiate1 +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(points, 1) +ncol = SIZE(points, 2) + +CALL Reallocate(obj%points, nrow, ncol) + +obj%points(1:nrow, 1:ncol) = points +obj%tXi = nrow - 1 +END PROCEDURE obj_Initiate1 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate2 +MODULE PROCEDURE obj_Initiate2 obj%tXi = tXi CALL Reallocate(obj%points, tXi + 1, tpoints) -END PROCEDURE quad_initiate2 +END PROCEDURE obj_Initiate2 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate3 +MODULE PROCEDURE obj_Initiate3 INTEGER(I4B) :: quadType + quadType = QuadraturePointNameToId(quadratureType) -CALL Initiate( & - & obj=obj, & - & refElem=refElem, & - & order=order, & - & quadratureType=quadType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END PROCEDURE quad_initiate3 +CALL Initiate(obj=obj, refElem=refElem, order=order, & + quadratureType=quadType, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE obj_Initiate3 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate4 +MODULE PROCEDURE obj_Initiate4 INTEGER(I4B) :: quadType quadType = QuadraturePointNameToId(quadratureType) -CALL Initiate( & - & obj=obj, & - & refElem=refElem, & - & nips=nips, & - & quadratureType=quadType, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END PROCEDURE quad_initiate4 +CALL Initiate(obj=obj, refElem=refElem, nips=nips, & + quadratureType=quadType, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE obj_Initiate4 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate5 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=order, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=order, & - & quadType=quadratureType, & - & refTriangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & order=order, & - & quadType=quadratureType, & - & refQuadrangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=order, & - & quadType=quadratureType, & - & refTetrahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & order=order, & - & quadType=quadratureType, & - & refHexahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=order, & - & quadType=quadratureType, & - & refPrism=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=order, & - & quadType=quadratureType, & - & refPyramid=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=order, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=order, & - & quadType=quadratureType, & - & refTriangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & order=order, & - & quadType=quadratureType, & - & refQuadrangle=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=order, & - & quadType=quadratureType, & - & refTetrahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & order=order, & - & quadType=quadratureType, & - & refHexahedron=refelem%domainName, & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=order, & - & quadType=quadratureType, & - & refPrism=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=order, & - & quadType=quadratureType, & - & refPyramid=refelem%domainName, & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="[NO CASE FOUND] for the type of refelem", & - & file=__FILE__, & - & routine="quad_initiate5()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate5 +! MODULE PROCEDURE obj_Initiate5 +! +! SELECT TYPE (refelem) +! +! TYPE IS (ReferenceLine_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & order=order, & +! & quadType=quadratureType, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! +! TYPE IS (ReferenceTriangle_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & order=order, & +! & quadType=quadratureType, & +! & refTriangle=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceQuadrangle_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & order=order, & +! & quadType=quadratureType, & +! & refQuadrangle=refelem%domainName, & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! +! TYPE IS (ReferenceTetrahedron_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & order=order, & +! & quadType=quadratureType, & +! & refTetrahedron=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceHexahedron_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & order=order, & +! & quadType=quadratureType, & +! & refHexahedron=refelem%domainName, & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! +! TYPE IS (ReferencePrism_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & order=order, & +! & quadType=quadratureType, & +! & refPrism=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferencePyramid_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & order=order, & +! & quadType=quadratureType, & +! & refPyramid=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceElement_) +! +! IF (isLine(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & order=order, & +! & quadType=quadratureType, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isTriangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & order=order, & +! & quadType=quadratureType, & +! & refTriangle=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isQuadrangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & order=order, & +! & quadType=quadratureType, & +! & refQuadrangle=refelem%domainName, & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isTetrahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & order=order, & +! & quadType=quadratureType, & +! & refTetrahedron=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isHexahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & order=order, & +! & quadType=quadratureType, & +! & refHexahedron=refelem%domainName, & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isPrism(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & order=order, & +! & quadType=quadratureType, & +! & refPrism=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isPyramid(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & order=order, & +! & quadType=quadratureType, & +! & refPyramid=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! CLASS DEFAULT +! CALL ErrorMsg(msg="[NO CASE FOUND] for the type of refelem", & +! routine="obj_Initiate5()", & +! file=__FILE__, line=__LINE__, unitno=stderr) +! RETURN +! END SELECT +! +! END PROCEDURE obj_Initiate5 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +! MODULE PROCEDURE obj_Initiate9 +! INTEGER(I4B) :: topo +! +! topo = ElementTopology(elemType) +! +! SELECT CASE (topo) +! CASE (Line) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & order=order, & +! & quadType=quadratureType, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! CASE (Triangle) +! CASE (Quadrangle) +! CASE (Tetrahedron) +! CASE (Hexahedron) +! CASE (Prism) +! CASE (Pyramid) +! END SELECT +! +! IF (isLine(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & order=order, & +! & quadType=quadratureType, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isTriangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & order=order, & +! & quadType=quadratureType, & +! & refTriangle=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isQuadrangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & order=order, & +! & quadType=quadratureType, & +! & refQuadrangle=refelem%domainName, & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isTetrahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & order=order, & +! & quadType=quadratureType, & +! & refTetrahedron=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isHexahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & order=order, & +! & quadType=quadratureType, & +! & refHexahedron=refelem%domainName, & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isPrism(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & order=order, & +! & quadType=quadratureType, & +! & refPrism=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isPyramid(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & order=order, & +! & quadType=quadratureType, & +! & refPyramid=refelem%domainName, & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! END PROCEDURE obj_Initiate9 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate6 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nips, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nips, & - & quadType=quadratureType, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nips=nips, & - & quadType=quadratureType, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nips, & - & quadType=quadratureType, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nips, & - & quadType=quadratureType, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nips, & - & quadType=quadratureType, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nips, & - & quadType=quadratureType, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nips=nips, & - & quadType=quadratureType, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nips=nips, & - & quadType=quadratureType, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) & - & ) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nips, & - & quadType=quadratureType, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nips, & - & quadType=quadratureType, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="No case found", & - & file=__FILE__, & - & routine="quad_initiate6()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate6 +! MODULE PROCEDURE obj_Initiate6 +! +! SELECT TYPE (refelem) +! TYPE IS (ReferenceLine_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & nips=nips, & +! & quadType=quadratureType, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! +! TYPE IS (ReferenceTriangle_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refTriangle="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceQuadrangle_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refQuadrangle="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! +! TYPE IS (ReferenceTetrahedron_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refTetrahedron="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceHexahedron_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refHexahedron="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! +! TYPE IS (ReferencePrism_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refPrism="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferencePyramid_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refPyramid="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceElement_) +! +! IF (isLine(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & nips=nips, & +! & quadType=quadratureType, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isTriangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refTriangle="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isQuadrangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refQuadrangle="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isTetrahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refTetrahedron="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isHexahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refHexahedron="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha, & +! & beta=beta, & +! & lambda=lambda) & +! & ) +! RETURN +! END IF +! +! IF (isPrism(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refPrism="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isPyramid(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & nips=nips, & +! & quadType=quadratureType, & +! & refPyramid="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! CLASS DEFAULT +! CALL ErrorMsg(& +! & msg="No case found", & +! & file=__FILE__, & +! & routine="obj_Initiate6()", & +! & line=__LINE__, & +! & unitno=stderr) +! RETURN +! END SELECT +! +! END PROCEDURE obj_Initiate6 !---------------------------------------------------------------------------- ! QuadraturePoint !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate7 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=p, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=p, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & p=p, & - & q=q, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=p, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & p=p, & - & q=q, & - & r=r, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=p, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=p, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & order=p, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & order=p, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & p=p, & - & q=q, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & order=p, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & p=p, & - & q=q, & - & r=r, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & order=p, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & order=p, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="No case found", & - & file=__FILE__, & - & routine="quad_initiate7()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate7 +! MODULE PROCEDURE obj_Initiate7 +! +! SELECT TYPE (refelem) +! TYPE IS (ReferenceLine_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & order=p, & +! & quadType=quadratureType1, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha1, & +! & beta=beta1, & +! & lambda=lambda1) & +! & ) +! +! TYPE IS (ReferenceTriangle_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & order=p, & +! & quadType=quadratureType1, & +! & refTriangle="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceQuadrangle_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & p=p, & +! & q=q, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & refQuadrangle="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2 & +! & )) +! +! TYPE IS (ReferenceTetrahedron_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & order=p, & +! & quadType=quadratureType1, & +! & refTetrahedron="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceHexahedron_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & p=p, & +! & q=q, & +! & r=r, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & quadType3=quadratureType3, & +! & refHexahedron="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2, & +! & alpha3=alpha3, & +! & beta3=beta3, & +! & lambda3=lambda3 & +! & )) +! +! TYPE IS (ReferencePrism_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & order=p, & +! & quadType=quadratureType1, & +! & refPrism="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferencePyramid_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & order=p, & +! & quadType=quadratureType1, & +! & refPyramid="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceElement_) +! +! IF (isLine(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & order=p, & +! & quadType=quadratureType1, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha1, & +! & beta=beta1, & +! & lambda=lambda1) & +! & ) +! RETURN +! END IF +! +! IF (isTriangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & order=p, & +! & quadType=quadratureType1, & +! & refTriangle="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isQuadrangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & p=p, & +! & q=q, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & refQuadrangle="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2 & +! & )) +! RETURN +! END IF +! +! IF (isTetrahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & order=p, & +! & quadType=quadratureType1, & +! & refTetrahedron="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isHexahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & p=p, & +! & q=q, & +! & r=r, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & quadType3=quadratureType3, & +! & refHexahedron="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2, & +! & alpha3=alpha3, & +! & beta3=beta3, & +! & lambda3=lambda3 & +! & )) +! RETURN +! END IF +! +! IF (isPrism(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & order=p, & +! & quadType=quadratureType1, & +! & refPrism="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isPyramid(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & order=p, & +! & quadType=quadratureType1, & +! & refPyramid="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! CLASS DEFAULT +! CALL ErrorMsg(& +! & msg="No case found", & +! & file=__FILE__, & +! & routine="obj_Initiate7()", & +! & line=__LINE__, & +! & unitno=stderr) +! RETURN +! END SELECT +! +! END PROCEDURE obj_Initiate7 !---------------------------------------------------------------------------- ! QuadraturePoint !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_initiate8 - -SELECT TYPE (refelem) -TYPE IS (ReferenceLine_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - -TYPE IS (ReferenceTriangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceQuadrangle_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - -TYPE IS (ReferenceTetrahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceHexahedron_) - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & nipsz=nipsz, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - -TYPE IS (ReferencePrism_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferencePyramid_) - - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - -TYPE IS (ReferenceElement_) - - IF (isLine(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadratureType1, & - & layout="INCREASING", & - & xij=LocalNodeCoord(refElem), & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) & - & ) - RETURN - END IF - - IF (isTriangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Triangle( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTriangle="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isQuadrangle(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Quadrangle( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & refQuadrangle="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2 & - & )) - RETURN - END IF - - IF (isTetrahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Tetrahedron( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refTetrahedron="UNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isHexahedron(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Hexahedron( & - & nipsx=nipsx, & - & nipsy=nipsy, & - & nipsz=nipsz, & - & quadType1=quadratureType1, & - & quadType2=quadratureType2, & - & quadType3=quadratureType3, & - & refHexahedron="BIUNIT", & - & xij=LocalNodeCoord(refElem), & - & alpha1=alpha1, & - & beta1=beta1, & - & lambda1=lambda1, & - & alpha2=alpha2, & - & beta2=beta2, & - & lambda2=lambda2, & - & alpha3=alpha3, & - & beta3=beta3, & - & lambda3=lambda3 & - & )) - RETURN - END IF - - IF (isPrism(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Prism( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPrism="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - - IF (isPyramid(refelem%name)) THEN - CALL Initiate( & - & obj=obj, & - & points=QuadraturePoint_Pyramid( & - & nips=nipsx, & - & quadType=quadratureType1, & - & refPyramid="BIUNIT", & - & xij=LocalNodeCoord(refElem)) & - & ) - RETURN - END IF - -CLASS DEFAULT - CALL ErrorMsg(& - & msg="No case found", & - & file=__FILE__, & - & routine="quad_initiate7()", & - & line=__LINE__, & - & unitno=stderr) - RETURN -END SELECT - -END PROCEDURE quad_initiate8 +! MODULE PROCEDURE obj_Initiate8 +! +! SELECT TYPE (refelem) +! TYPE IS (ReferenceLine_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha1, & +! & beta=beta1, & +! & lambda=lambda1) & +! & ) +! +! TYPE IS (ReferenceTriangle_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refTriangle="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceQuadrangle_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & nipsx=nipsx, & +! & nipsy=nipsy, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & refQuadrangle="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2 & +! & )) +! +! TYPE IS (ReferenceTetrahedron_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refTetrahedron="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceHexahedron_) +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & nipsx=nipsx, & +! & nipsy=nipsy, & +! & nipsz=nipsz, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & quadType3=quadratureType3, & +! & refHexahedron="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2, & +! & alpha3=alpha3, & +! & beta3=beta3, & +! & lambda3=lambda3 & +! & )) +! +! TYPE IS (ReferencePrism_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refPrism="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferencePyramid_) +! +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refPyramid="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! +! TYPE IS (ReferenceElement_) +! +! IF (isLine(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Line( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & layout="INCREASING", & +! & xij=LocalNodeCoord(refElem), & +! & alpha=alpha1, & +! & beta=beta1, & +! & lambda=lambda1) & +! & ) +! RETURN +! END IF +! +! IF (isTriangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Triangle( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refTriangle="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isQuadrangle(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Quadrangle( & +! & nipsx=nipsx, & +! & nipsy=nipsy, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & refQuadrangle="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2 & +! & )) +! RETURN +! END IF +! +! IF (isTetrahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Tetrahedron( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refTetrahedron="UNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isHexahedron(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Hexahedron( & +! & nipsx=nipsx, & +! & nipsy=nipsy, & +! & nipsz=nipsz, & +! & quadType1=quadratureType1, & +! & quadType2=quadratureType2, & +! & quadType3=quadratureType3, & +! & refHexahedron="BIUNIT", & +! & xij=LocalNodeCoord(refElem), & +! & alpha1=alpha1, & +! & beta1=beta1, & +! & lambda1=lambda1, & +! & alpha2=alpha2, & +! & beta2=beta2, & +! & lambda2=lambda2, & +! & alpha3=alpha3, & +! & beta3=beta3, & +! & lambda3=lambda3 & +! & )) +! RETURN +! END IF +! +! IF (isPrism(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Prism( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refPrism="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! IF (isPyramid(refelem%name)) THEN +! CALL Initiate( & +! & obj=obj, & +! & points=QuadraturePoint_Pyramid( & +! & nips=nipsx, & +! & quadType=quadratureType1, & +! & refPyramid="BIUNIT", & +! & xij=LocalNodeCoord(refElem)) & +! & ) +! RETURN +! END IF +! +! CLASS DEFAULT +! CALL ErrorMsg(& +! & msg="No case found", & +! & file=__FILE__, & +! & routine="obj_Initiate7()", & +! & line=__LINE__, & +! & unitno=stderr) +! RETURN +! END SELECT +! +! END PROCEDURE obj_Initiate8 !---------------------------------------------------------------------------- ! QuadraturePoint From 557deac4a2c1a2c79d9d4641777223ec9edb7516 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:43:21 +0900 Subject: [PATCH 186/359] update in quadrature point --- .../src/QuadraturePoint_Method@GetMethods.F90 | 54 ++++++++++++------- 1 file changed, 36 insertions(+), 18 deletions(-) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 index 126af77a7..ee399c49d 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 @@ -20,7 +20,8 @@ ! summary: Constructor methods for [[Quadraturepoints_]] SUBMODULE(QuadraturePoint_Method) GetMethods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate + IMPLICIT NONE CONTAINS @@ -28,46 +29,58 @@ ! SIZE !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_Size +MODULE PROCEDURE obj_Size ans = SIZE(obj%points, dims) -END PROCEDURE quad_Size +END PROCEDURE obj_Size !---------------------------------------------------------------------------- ! getTotalQuadraturepoints !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_getTotalQuadraturepoints +MODULE PROCEDURE obj_GetTotalQuadraturepoints ans = SIZE(obj, 2) -END PROCEDURE quad_getTotalQuadraturepoints +END PROCEDURE obj_GetTotalQuadraturepoints !---------------------------------------------------------------------------- ! getQuadraturepoints !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_GetQuadraturePoints1 +MODULE PROCEDURE obj_GetQuadraturePoints1 points = 0.0_DFP points(1:obj%tXi) = obj%points(1:obj%tXi, Num) weights = obj%points(obj%tXi + 1, Num) -END PROCEDURE quad_GetQuadraturePoints1 +END PROCEDURE obj_GetQuadraturePoints1 !---------------------------------------------------------------------------- ! getQuadraturepoints !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_GetQuadraturePoints2 +MODULE PROCEDURE obj_GetQuadraturePoints2 INTEGER(I4B) :: n n = SIZE(obj%points, 2) !#column CALL Reallocate(points, 3, n) points(1:obj%tXi, 1:n) = obj%points(1:obj%tXi, 1:n) weights = obj%points(obj%tXi + 1, 1:n) -END PROCEDURE quad_GetQuadraturePoints2 +END PROCEDURE obj_GetQuadraturePoints2 + +!---------------------------------------------------------------------------- +! getQuadraturepoints +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetQuadraturePoints1_ +nrow = 3 +ncol = SIZE(obj%points, 2) !#column + +! CALL Reallocate(points, 3, n) +points(1:obj%tXi, 1:ncol) = obj%points(1:obj%tXi, 1:ncol) +weights(1:ncol) = obj%points(obj%tXi + 1, 1:ncol) +END PROCEDURE obj_GetQuadraturePoints1_ !---------------------------------------------------------------------------- ! Outerprod !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_Outerprod -REAL(DFP), ALLOCATABLE :: points(:, :) +MODULE PROCEDURE obj_Outerprod INTEGER(I4B) :: n1, n2, n INTEGER(I4B) :: ii, a, b @@ -75,17 +88,22 @@ n2 = SIZE(obj2, 2) n = n1 * n2 -CALL Reallocate(points, 3, n) +CALL Reallocate(ans%points, 3, n) + DO ii = 1, n1 a = (ii - 1) * n2 + 1 b = ii * n2 - points(1, a:b) = obj1%points(1, ii) - points(2, a:b) = obj2%points(1, :) - points(3, a:b) = obj1%points(2, ii) * obj2%points(2, :) + ans%points(1, a:b) = obj1%points(1, ii) + ans%points(2, a:b) = obj2%points(1, :) + ans%points(3, a:b) = obj1%points(2, ii) * obj2%points(2, :) END DO -CALL Initiate(obj=ans, points=points) -IF (ALLOCATED(points)) DEALLOCATE (points) -END PROCEDURE quad_Outerprod +! CALL Initiate(obj=ans, points=points) +ans%tXi = SIZE(ans%points, 1) - 1 +END PROCEDURE obj_Outerprod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- END SUBMODULE GetMethods From 3913c5ccc6fdd5807eb18123c51c92cacf22a200 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 7 Jul 2024 19:43:32 +0900 Subject: [PATCH 187/359] update in quadrature point --- .../src/QuadraturePoint_Method@IOMethods.F90 | 41 ++++++++++++------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 index 698838d8d..acb6f1270 100644 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 @@ -20,28 +20,35 @@ ! summary: This submodule contains the IO method for [[QuadraturePoint_]] SUBMODULE(QuadraturePoint_Method) IOMethods -USE BaseMethod +USE Display_Method, ONLY: Util_Display => Display, Tostring +USE MdEncode_Method, ONLY: Util_MdEncode => MdEncode + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- ! Display !---------------------------------------------------------------------------- -MODULE PROCEDURE quad_Display -CALL Display(msg, unitno=unitno) -IF (.NOT. ALLOCATED(obj%points)) THEN - RETURN -END IF -CALL Display(obj%points, msg="# points :", unitno=unitno) -CALL Display(obj%txi, msg="# txi :", unitno=unitno) -END PROCEDURE quad_Display +MODULE PROCEDURE obj_Display +LOGICAL(LGT) :: isok + +CALL Util_Display(msg, unitno=unitno) + +isok = ALLOCATED(obj%points) +IF (.NOT. isok) RETURN + +CALL Util_Display(obj%points, msg="points:", unitno=unitno) +CALL Util_Display(obj%txi, msg="txi:", unitno=unitno) + +END PROCEDURE obj_Display !---------------------------------------------------------------------------- ! MdEncode !---------------------------------------------------------------------------- -MODULE PROCEDURE QuadraturePoint_MdEncode +MODULE PROCEDURE obj_MdEncode INTEGER(I4B) :: ii, n, jj TYPE(String), ALLOCATABLE :: rh(:), ch(:) @@ -51,8 +58,10 @@ END IF n = SIZE(obj%points, 2) -CALL Reallocate(rh, SIZE(obj, 1)) -CALL Reallocate(ch, SIZE(obj, 2)) +ii = SIZE(obj, 1) +jj = SIZE(obj, 2) + +ALLOCATE (rh(ii), ch(jj)) DO ii = 1, SIZE(rh) - 1 rh(ii) = "`x"//tostring(ii)//"`" @@ -63,8 +72,12 @@ ch(ii) = "`p"//tostring(ii)//"`" END DO -ans = MdEncode(obj%points, rh=rh, ch=ch) +ans = Util_MdEncode(obj%points, rh=rh, ch=ch) + +END PROCEDURE obj_MdEncode -END PROCEDURE QuadraturePoint_MdEncode +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- END SUBMODULE IOMethods From 10d8da33072fa58959589e6577944b4a63f1cc97 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 8 Jul 2024 11:31:15 +0900 Subject: [PATCH 188/359] updates in line interpolation --- .../src/LineInterpolationUtility.F90 | 2 + .../src/LineInterpolationUtility@Methods.F90 | 264 +++++++----------- 2 files changed, 104 insertions(+), 162 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 7718bc8b6..9a5040523 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -47,6 +47,8 @@ MODULE LineInterpolationUtility PUBLIC :: BasisGradientEvalAll_Line_ PUBLIC :: QuadraturePoint_Line +PUBLIC :: QuadraturePoint_Line_ + PUBLIC :: ToVEFC_Line PUBLIC :: QuadratureNumber_Line PUBLIC :: RefElemDomain_Line diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 7d218f4df..4b59ee09e 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -1319,10 +1319,25 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Line1 -INTEGER(I4B) :: nips(1) +INTEGER(I4B) :: nips(1), nrow, ncol + nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) -ans = QuadraturePoint_Line3(nips=nips, quadType=quadType, & -& layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda) + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 1 +END IF + +nrow = nrow + 1 +ncol = nips(1) + +ALLOCATE (ans(nrow, ncol)) + +CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & + xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & + ncol=ncol) + END PROCEDURE QuadraturePoint_Line1 !---------------------------------------------------------------------------- @@ -1330,148 +1345,66 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Line2 -ans = QuadraturePoint_Line1(order=order, quadType=quadType, layout=layout, & - xij=RESHAPE(xij, [1, 2]), alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE QuadraturePoint_Line2 +INTEGER(I4B) :: nips(1), nrow, ncol +REAL(DFP) :: x12(1, 2) -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- +nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) +nrow = 2 +ncol = nips(1) -MODULE PROCEDURE QuadraturePoint_Line4 -ans = QuadraturePoint_Line3(nips=nips, quadType=quadType, layout=layout, & - xij=RESHAPE(xij, [1, 2]), alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE QuadraturePoint_Line4 +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 -CHARACTER(20) :: astr -INTEGER(I4B) :: np, nsd, ii -REAL(DFP) :: pt(nips(1)), wt(nips(1)) -REAL(DFP) :: t1 -LOGICAL(LGT) :: changeLayout - -IF (ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType)) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & - & routine="QuadraturePoint_Line3", & - & file=__FILE__, line=__LINE__, unitno=stderr) - END IF - RETURN - -ELSEIF (ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType)) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for quadType=ipopt%GaussUltraspherical", & - & file=__FILE__, & - & routine="QuadraturePoint_Line3", & - & line=__LINE__, & - & unitno=stderr) - END IF - RETURN - -END IF +INTEGER(I4B) :: nrow, ncol IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) + nrow = SIZE(xij, 1) ELSE - nsd = 1 + nrow = 1 END IF -astr = TRIM(UpperCase(layout)) -np = nips(1) -! CALL Reallocate(ans, nsd + 1_I4B, np) -ALLOCATE (ans(nsd + 1_I4B, np)) -changeLayout = .FALSE. - -SELECT CASE (quadType) +nrow = nrow + 1 +ncol = nips(1) -CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) - -CASE (ipopt%GaussLegendreRadauLeft) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft) - -CASE (ipopt%GaussLegendreRadauRight) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight) - -CASE (ipopt%GaussLegendreLobatto) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. - -CASE (ipopt%GaussChebyshev) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) - -CASE (ipopt%GaussChebyshevRadauLeft) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft) - -CASE (ipopt%GaussChebyshevRadauRight) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight) - -CASE (ipopt%GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. - -CASE (ipopt%GaussJacobi) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & - alpha=alpha, beta=beta) - -CASE (ipopt%GaussJacobiRadauLeft) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauLeft, & - alpha=alpha, beta=beta) +ALLOCATE (ans(nrow, ncol)) -CASE (ipopt%GaussJacobiRadauRight) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussRadauRight, & - alpha=alpha, beta=beta) +CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & + xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & + ncol=ncol) -CASE (ipopt%GaussJacobiLobatto) - CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto, & - alpha=alpha, beta=beta) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. +END PROCEDURE QuadraturePoint_Line3 -CASE (ipopt%GaussUltraspherical) - CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & - lambda=lambda) +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- -CASE (ipopt%GaussUltrasphericalRadauLeft) - CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & - quadType=ipopt%GaussRadauLeft, lambda=lambda) +MODULE PROCEDURE QuadraturePoint_Line4 +REAL(DFP) :: x12(1, 2) +INTEGER(I4B) :: nrow, ncol -CASE (ipopt%GaussUltrasphericalRadauRight) - CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & - quadType=ipopt%GaussRadauRight, lambda=lambda) +nrow = 2 +ncol = nips(1) -CASE (ipopt%GaussUltrasphericalLobatto) - CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & - quadType=ipopt%GaussLobatto, lambda=lambda) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. +ALLOCATE (ans(nrow, ncol)) -CASE DEFAULT - CALL ErrorMsg(msg="Unknown iptype", routine="QuadraturePoint_Line3", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END SELECT +x12(1, 1:2) = xij(1:2) -IF (changeLayout) THEN - CALL ToVEFC_Line(pt) - CALL ToVEFC_Line(wt) -END IF +CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & + xij=x12, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & + ncol=ncol) -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiunitLine2Segment( & - & xin=pt, & - & x1=xij(:, 1), & - & x2=xij(:, 2)) - ans(nsd + 1, :) = wt * NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP -ELSE - ans(1, :) = pt - ans(nsd + 1, :) = wt -END IF -END PROCEDURE QuadraturePoint_Line3 +END PROCEDURE QuadraturePoint_Line4 !---------------------------------------------------------------------------- ! @@ -1482,41 +1415,43 @@ END SUBROUTINE handle_error LOGICAL(LGT) :: isok, abool #endif -CHARACTER(20) :: astr -INTEGER(I4B) :: np, nsd, ii -REAL(DFP) :: pt(nips(1)), wt(nips(1)) -REAL(DFP) :: t1 +INTEGER(I4B) :: np, nsd, ii, jj +REAL(DFP) :: pt(nips(1)), wt(nips(1)), areal LOGICAL(LGT) :: changeLayout +nrow = 0 +ncol = 0 + #ifdef DEBUG_VER -abool = ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType) -IF (isok) THEN -END IF +SELECT CASE (quadType) +CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto, & + ipopt%GaussJacobiRadauLeft, ipopt%GaussJacobiRadauRight) -#endif + isok = PRESENT(alpha) .AND. PRESENT(beta) -IF (isok) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL ErrorMsg(& - & msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & - & routine="QuadraturePoint_Line3", & - & file=__FILE__, line=__LINE__, unitno=stderr) + IF (.NOT. isok) THEN + CALL ErrorMsg(routine="QuadraturePoint_Line3", & + msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN END IF - RETURN -ELSEIF (ANY([ipopt%GaussJacobi, ipopt%GaussJacobiLobatto] .EQ. quadType)) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL ErrorMsg(& - & msg="lambda should be present for quadType=ipopt%GaussUltraspherical", & - & file=__FILE__, & - & routine="QuadraturePoint_Line3", & - & line=__LINE__, & - & unitno=stderr) +CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto, & + ipopt%GaussUltraSphericalRadauLeft, ipopt%GaussUltraSphericalRadauRight) + + isok = PRESENT(lambda) + + IF (.NOT. isok) THEN + CALL ErrorMsg(routine="QuadraturePoint_Line3", & + msg="lambda should be present for quadType=ipopt%GaussUltraspherical", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN END IF - RETURN -END IF +END SELECT + +#endif IF (PRESENT(xij)) THEN nsd = SIZE(xij, 1) @@ -1524,11 +1459,12 @@ END SUBROUTINE handle_error nsd = 1 END IF -astr = TRIM(UpperCase(layout)) np = nips(1) -! CALL Reallocate(ans, nsd + 1_I4B, np) -ALLOCATE (ans(nsd + 1_I4B, np)) +nrow = nsd + 1 +ncol = nips(1) + changeLayout = .FALSE. +IF (layout(1:1) .EQ. "V") changeLayout = .TRUE. SELECT CASE (quadType) @@ -1543,7 +1479,6 @@ END SUBROUTINE handle_error CASE (ipopt%GaussLegendreLobatto) CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE (ipopt%GaussChebyshev) CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) @@ -1556,7 +1491,6 @@ END SUBROUTINE handle_error CASE (ipopt%GaussChebyshevLobatto) CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE (ipopt%GaussJacobi) CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & @@ -1573,7 +1507,6 @@ END SUBROUTINE handle_error CASE (ipopt%GaussJacobiLobatto) CALL JacobiQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%GaussLobatto, & alpha=alpha, beta=beta) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE (ipopt%GaussUltraspherical) CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss, & @@ -1590,7 +1523,6 @@ END SUBROUTINE handle_error CASE (ipopt%GaussUltrasphericalLobatto) CALL UltrasphericalQuadrature(n=np, pt=pt, wt=wt, & quadType=ipopt%GaussLobatto, lambda=lambda) - IF (layout .EQ. "VEFC") changeLayout = .TRUE. CASE DEFAULT CALL ErrorMsg(msg="Unknown iptype", routine="QuadraturePoint_Line3", & @@ -1604,15 +1536,23 @@ END SUBROUTINE handle_error END IF IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiunitLine2Segment( & - & xin=pt, & - & x1=xij(:, 1), & - & x2=xij(:, 2)) - ans(nsd + 1, :) = wt * NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP -ELSE - ans(1, :) = pt - ans(nsd + 1, :) = wt + CALL FromBiunitLine2Segment_(xin=pt, 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(nsd + 1, ii) = wt(ii) * areal + END DO + + RETURN END IF + +DO CONCURRENT(ii=1:ncol) + ans(1, ii) = pt(ii) + ans(nsd + 1, ii) = wt(ii) +END DO + END PROCEDURE QuadraturePoint_Line1_ !---------------------------------------------------------------------------- From 3608f0d784ed5bcacf4341671da800fd3ad2ecaa Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 8 Jul 2024 11:31:29 +0900 Subject: [PATCH 189/359] update in quadrangle interpolation --- .../src/QuadrangleInterpolationUtility.F90 | 156 ++++++----- ...QuadrangleInterpolationUtility@Methods.F90 | 248 +++++++++--------- 2 files changed, 194 insertions(+), 210 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 7d2bbb372..6cfa1d059 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -65,6 +65,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: LagrangeEvalAll_Quadrangle_ PUBLIC :: QuadraturePoint_Quadrangle +PUBLIC :: QuadraturePoint_Quadrangle_ PUBLIC :: QuadratureNumber_Quadrangle PUBLIC :: FacetConnectivity_Quadrangle @@ -2070,26 +2071,15 @@ MODULE FUNCTION QuadraturePoint_Quadrangle1(order, quadType, & !! Order of integrand in x and y direction INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature point type - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft + !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight + !! GaussUltraspherical ! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight + !! GaussJacobi ! GaussJacobiLobatto + !! GaussJacobiRadauLeft ! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle - !! UNIT - !! BIUNIT + !! Reference quadrangle ! UNIT ! BIUNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! four vertices of quadrangle in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha @@ -2117,27 +2107,15 @@ MODULE FUNCTION QuadraturePoint_Quadrangle2(p, q, quadType1, quadType2, & !! order of integrand in y direction INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 !! quadrature point type in x direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle - !! UNIT - !! BIUNIT + !! Reference quadrangle ! UNIT ! BIUNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! four vertices of quadrangle in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 @@ -2171,27 +2149,15 @@ MODULE FUNCTION QuadraturePoint_Quadrangle3(nips, quadType, & INTEGER(I4B), INTENT(IN) :: nips(1) !! number of integration points in x and y direction INTEGER(I4B), INTENT(IN) :: quadType - !! interpolation point type - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight + !! interpolation point type ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle - !! UNIT - !! BIUNIT + !! Reference quadrangle ! UNIT ! BIUNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! four vertices of quadrangle in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha @@ -2219,27 +2185,15 @@ MODULE FUNCTION QuadraturePoint_Quadrangle4(nipsx, nipsy, quadType1, & !! order of integrand in y direction INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 !! interpolation point type in x direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle - !! UNIT - !! BIUNIT + !! Reference quadrangle ! UNIT ! BIUNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! four vertices of quadrangle in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 @@ -2259,6 +2213,50 @@ MODULE FUNCTION QuadraturePoint_Quadrangle4(nipsx, nipsy, quadType1, & 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 289e2a10b..4400aa610 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -1952,9 +1952,26 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Quadrangle1 -ans = QuadraturePoint_Quadrangle2(p=order, q=order, quadType1=quadType, & - quadType2=quadType, xij=xij, refQuadrangle=refQuadrangle, alpha1=alpha, & - beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda) +INTEGER(I4B) :: nips(1), nrow, ncol + +nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2) +ELSE + nrow = 2 +END IF + +nrow = nrow + 1 +ncol = nips(1) * nips(1) + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, & + quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, & + xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & + beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) + END PROCEDURE QuadraturePoint_Quadrangle1 !---------------------------------------------------------------------------- @@ -1962,77 +1979,26 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Quadrangle2 -! internal variables -REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), temp(:, :) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq -TYPE(String) :: astr - -astr = TRIM(UpperCase(refQuadrangle)) - -x = QuadraturePoint_Line( & - & order=p, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) +INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol -np = SIZE(x, 2) - -y = QuadraturePoint_Line( & - & order=q, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -nq = SIZE(y, 2) +nipsx(1) = QuadratureNumber_Line(order=p, quadType=quadType1) +nipsy(1) = QuadratureNumber_Line(order=q, quadType=quadType2) IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) + nrow = MAX(SIZE(xij, 1), 2) ELSE - nsd = 2 + nrow = 2 END IF -CALL Reallocate(ans, nsd + 1_I4B, np * nq) -CALL Reallocate(temp, 3_I4B, np * nq) +nrow = nrow + 1 +ncol = nipsx(1) * nipsy(1) -kk = 0 -DO ii = 1, np - DO jj = 1, nq - kk = kk + 1 - temp(1, kk) = x(1, ii) - temp(2, kk) = y(1, jj) - temp(3, kk) = x(2, ii) * y(2, jj) - END DO -END DO - -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( & - & xin=temp(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="QUADRANGLE", xij=xij) -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( & - & xin=temp(1:2, :)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF -END IF +ALLOCATE (ans(1:nrow, 1:ncol)) -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(x)) DEALLOCATE (x) -IF (ALLOCATED(y)) DEALLOCATE (y) +CALL QuadraturePoint_Quadrangle1_(nipsx=nipsx, nipsy=nipsy, & + quadType1=quadType1, quadType2=quadType2, refQuadrangle=refQuadrangle, & + xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & + beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Quadrangle2 @@ -2041,20 +2007,24 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Quadrangle3 -ans = QuadraturePoint_Quadrangle4( & - & nipsx=nips, & - & nipsy=nips, & - & quadType1=quadType, & - & quadType2=quadType, & - & refQuadrangle=refQuadrangle, & - & xij=xij, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda & - & ) +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2) +ELSE + nrow = 2 +END IF + +nrow = nrow + 1 +ncol = nips(1) * nips(1) + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, & + quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, & + xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & + beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) + END PROCEDURE QuadraturePoint_Quadrangle3 !---------------------------------------------------------------------------- @@ -2062,74 +2032,90 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Quadrangle4 -! internal variables -REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), temp(3, nipsy(1) * nipsx(1)) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq -TYPE(String) :: astr +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2) +ELSE + nrow = 2 +END IF -astr = TRIM(UpperCase(refQuadrangle)) +nrow = nrow + 1 +ncol = nipsx(1) * nipsy(1) -x = QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) +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) -np = SIZE(x, 2) +END PROCEDURE QuadraturePoint_Quadrangle4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -y = QuadraturePoint_Line( & - & nips=nipsy, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) +MODULE PROCEDURE QuadraturePoint_Quadrangle1_ +! internal variables +REAL(DFP) :: x(4, nipsx(1)), y(2, nipsy(1)), areal +INTEGER(I4B) :: ii, jj, kk, nsd, np, nq +CHARACTER(len=1) :: astr -nq = SIZE(y, 2) +REAL(DFP), PARAMETER :: x12(1, 2) = RESHAPE([-1.0_DFP, 1.0_DFP], [1, 2]) IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) + nsd = MAX(SIZE(xij, 1), 2) ELSE nsd = 2 END IF -CALL Reallocate(ans, nsd + 1_I4B, np * nq) +! CALL Reallocate(ans, nsd + 1_I4B, np * nq) +nrow = nsd + 1 +ncol = nipsx(1) * nipsy(1) -kk = 0 -DO ii = 1, np - DO jj = 1, nq - kk = kk + 1 - temp(1, kk) = x(1, ii) - temp(2, kk) = y(1, jj) - temp(3, kk) = x(2, ii) * y(2, jj) - END DO +CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadType1, xij=x12, & + layout="INCREASING", alpha=alpha1, beta=beta1, lambda=lambda1, ans=x, & + nrow=ii, ncol=np) + +CALL QuadraturePoint_Line_(nips=nipsy, quadType=quadType2, xij=x12, & + layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, ans=y, & + nrow=ii, ncol=nq) + +DO CONCURRENT(ii=1:np, jj=1:nq) + ans(1, nq * (ii - 1) + jj) = x(1, ii) + ans(2, nq * (ii - 1) + jj) = y(1, jj) + ans(nrow, nq * (ii - 1) + jj) = x(2, ii) * y(2, jj) END DO IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( & - & xin=temp(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="QUADRANGLE", xij=xij) -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( & - & xin=temp(1:2, :)) - ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF + CALL FromBiUnitQuadrangle2Quadrangle_(xin=ans(1:2, :), x1=xij(:, 1), & + x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, nrow=ii, ncol=jj) + + areal = JacobianQuadrangle(from="BIUNIT", to="QUADRANGLE", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN END IF -END PROCEDURE QuadraturePoint_Quadrangle4 +astr = UpperCase(refQuadrangle(1:1)) +IF (astr .EQ. "U") THEN + CALL FromBiUnitQuadrangle2UnitQuadrangle_(xin=ans(1:2, :), ans=ans, & + nrow=ii, ncol=jj) + + areal = JacobianQuadrangle(from="BIUNIT", to="UNIT", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN +END IF + +END PROCEDURE QuadraturePoint_Quadrangle1_ !---------------------------------------------------------------------------- ! From d6d3d26ecf9f14dd9d91ccbf2f948e8aee457341 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 8 Jul 2024 11:31:37 +0900 Subject: [PATCH 190/359] update in mapping util --- src/modules/Utility/src/MappingUtility.F90 | 20 ++++++++++++++++++ .../Utility/src/MappingUtility@Methods.F90 | 21 +++++++++++++------ 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index e5792e2d9..6395f5543 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -37,6 +37,7 @@ MODULE MappingUtility PUBLIC :: FromBiUnitQuadrangle2Quadrangle_ PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle +PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle_ PUBLIC :: FromUnitQuadrangle2BiUnitQuadrangle PUBLIC :: FromBiUnitHexahedron2Hexahedron @@ -258,6 +259,25 @@ MODULE PURE FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1(xin) & END FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1 END INTERFACE FromBiUnitQuadrangle2UnitQuadrangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE FromBiUnitQuadrangle2UnitQuadrangle_ + MODULE PURE SUBROUTINE FromBiUnitQuadrangle2UnitQuadrangle1_(xin, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Quadrangle in xij format + !! SIZE(xin,1) = 2 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xin, 1) + !! ncol = SIZE(xin, 2) + END SUBROUTINE FromBiUnitQuadrangle2UnitQuadrangle1_ +END INTERFACE FromBiUnitQuadrangle2UnitQuadrangle_ + !---------------------------------------------------------------------------- ! FromUnitQuadrangle2BiUnitQuadrangle !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index 9eb9db023..5298f19c1 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -163,14 +163,23 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1 -ans = FromBiUnitQuadrangle2Quadrangle(& - & xin=xin, & - & x1=[0.0_DFP, 0.0_DFP], & - & x2=[1.0_DFP, 0.0_DFP], & - & x3=[1.0_DFP, 1.0_DFP], & - & x4=[0.0_DFP, 1.0_DFP]) +INTEGER(I4B) :: nrow, ncol +CALL FromBiUnitQuadrangle2UnitQuadrangle1_(xin=xin, ans=ans, nrow=nrow, & + ncol=ncol) END PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1_ +REAL(DFP), PARAMETER :: azero = 0.0_DFP, aone = 1.0_DFP +REAL(DFP), PARAMETER :: x1(2) = [azero, azero], x2(2) = [aone, azero], & + x3(2) = [aone, aone], x4(2) = [azero, aone] +CALL FromBiUnitQuadrangle2Quadrangle_(xin=xin, x1=x1, x2=x2, x3=x3, x4=x4, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1_ + !---------------------------------------------------------------------------- ! FromBiUnitQuadrangle2UnitQuadrangle !---------------------------------------------------------------------------- From 21fde4b071b2fb3ab955e11c19030a6b412e6358 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 8 Jul 2024 18:25:45 +0900 Subject: [PATCH 191/359] updating triangle interpolation utility --- .../src/TriangleInterpolationUtility.F90 | 114 +++++- ...InterpolationUtility@QuadratureMethods.F90 | 330 +++++++++++------- 2 files changed, 311 insertions(+), 133 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 7e5d8c0a7..d2ee51917 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -1354,8 +1354,7 @@ MODULE FUNCTION QuadraturePoint_Triangle1(order, quadType, refTriangle, & !! currently this variable is not used CHARACTER(*), INTENT(IN) :: refTriangle !! Reference triangle - !! Biunit - !! Unit + !! Biunit ! Unit !! If xij is present,then this parameter is not used REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! nodal coordinates of triangle. @@ -1366,6 +1365,32 @@ MODULE FUNCTION QuadraturePoint_Triangle1(order, quadType, refTriangle, & END FUNCTION QuadraturePoint_Triangle1 END INTERFACE QuadraturePoint_Triangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Triangle_ + MODULE SUBROUTINE QuadraturePoint_Triangle1_(order, quadType, refTriangle, & + xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit ! Unit + !! If xij is present,then this parameter is not used + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE QuadraturePoint_Triangle1_ +END INTERFACE QuadraturePoint_Triangle_ + !---------------------------------------------------------------------------- ! QuadraturePoints_Triangle !---------------------------------------------------------------------------- @@ -1387,8 +1412,7 @@ MODULE FUNCTION QuadraturePoint_Triangle2(nips, quadType, refTriangle, & !! currently this variable is not used CHARACTER(*), INTENT(IN) :: refTriangle !! Reference triangle - !! Biunit - !! Unit + !! Biunit ! Unit REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! nodal coordinates of triangle. !! The number of rows in xij can be 2 or 3. @@ -1398,6 +1422,34 @@ MODULE FUNCTION QuadraturePoint_Triangle2(nips, quadType, refTriangle, & END FUNCTION QuadraturePoint_Triangle2 END INTERFACE QuadraturePoint_Triangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Triangle_ + MODULE SUBROUTINE QuadraturePoint_Triangle2_(nips, quadType, refTriangle, & + xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! nips(1) .LE. 79, then we call + !! economical quadrature rules. + !! Otherwise, this routine will retport + !! error + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type, + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit ! Unit + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE QuadraturePoint_Triangle2_ +END INTERFACE QuadraturePoint_Triangle_ + !---------------------------------------------------------------------------- ! TensorQuadraturePoints_Triangle !---------------------------------------------------------------------------- @@ -1427,6 +1479,31 @@ MODULE FUNCTION TensorQuadraturePoint_Triangle1(order, quadType, & END FUNCTION TensorQuadraturePoint_Triangle1 END INTERFACE TensorQuadraturePoint_Triangle +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE TensorQuadraturePoint_Triangle_ + MODULE SUBROUTINE TensorQuadraturePoint_Triangle1_(order, quadType, & + refTriangle, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle ! Biunit ! Unit + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + END SUBROUTINE TensorQuadraturePoint_Triangle1_ +END INTERFACE TensorQuadraturePoint_Triangle_ + !---------------------------------------------------------------------------- ! TensorQuadraturePoints_Triangle !---------------------------------------------------------------------------- @@ -1462,6 +1539,35 @@ END FUNCTION TensorQuadraturePoint_Triangle2 ! !---------------------------------------------------------------------------- +INTERFACE TensorQuadraturePoint_Triangle_ + MODULE SUBROUTINE TensorQuadraturePoint_Triangle2_(nipsx, nipsy, quadType, & + refTriangle, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle + !! Biunit + !! Unit + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 2 or 3. + !! The number of columns in xij should be 3 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + END SUBROUTINE TensorQuadraturePoint_Triangle2_ +END INTERFACE TensorQuadraturePoint_Triangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE LagrangeGradientEvalAll_Triangle MODULE FUNCTION LagrangeGradientEvalAll_Triangle1( & & order, & diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 index 26a49cb99..85d77be22 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -27,190 +27,262 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE TensorQuadraturePoint_Triangle1 -INTEGER(I4B) :: np(1), nq(1), n -n = 1_I4B + INT(order / 2, kind=I4B) -np(1) = n + 1 -nq(1) = n -ans = TensorQuadraturePoint_Triangle2( & - & nipsx=np, & - & nipsy=nq, & - & quadType=quadType, & - & refTriangle=refTriangle, & - & xij=xij) +INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol + +nrow = 1_I4B + INT(order / 2, kind=I4B) +nipsx(1) = nrow + 1 +nipsy(1) = nrow + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2_I4B) +ELSE + nrow = 2_I4B +END IF + +nrow = nrow + 1_I4B +ncol = nipsx(1) * nipsy(1) + +ALLOCATE (ans(nrow, ncol)) + +CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, & + quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) END PROCEDURE TensorQuadraturePoint_Triangle1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Triangle1_ +INTEGER(I4B) :: nipsx(1), nipsy(1), n + +n = 1_I4B + INT(order / 2, kind=I4B) +nipsx(1) = n + 1 +nipsy(1) = n + +CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, & + quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE TensorQuadraturePoint_Triangle1_ + !---------------------------------------------------------------------------- ! TensorQuadraturePoint_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE TensorQuadraturePoint_Triangle2 -INTEGER(I4B) :: np(1), nq(1), nsd -REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :) -TYPE(String) :: astr - -astr = TRIM(UpperCase(refTriangle)) -np(1) = nipsx(1) -nq(1) = nipsy(1) - -temp_q = QuadraturePoint_Quadrangle(& - & nipsx=np, & - & nipsy=nq, & - & quadType1=GaussLegendreLobatto, & - & quadType2=GaussJacobiRadauLeft, & - & refQuadrangle="BIUNIT", & - & alpha2=1.0_DFP, & - & beta2=0.0_DFP) - -CALL Reallocate(temp_t, SIZE(temp_q, 1, kind=I4B), SIZE(temp_q, 2, kind=I4B)) -temp_t(1:2, :) = FromBiUnitSqr2UnitTriangle(xin=temp_q(1:2, :)) -temp_t(3, :) = temp_q(3, :) / 8.0_DFP +INTEGER(I4B) :: nrow, ncol IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) + nrow = MAX(SIZE(xij, 1), 2_I4B) ELSE - nsd = 2_I4B + nrow = 2_I4B END IF -CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_q, 2, kind=I4B)) +nrow = nrow + 1_I4B +ncol = nipsx(1) * nipsy(1) + +ALLOCATE (ans(nrow, ncol)) + +CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, & + quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE TensorQuadraturePoint_Triangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Triangle2_ +INTEGER(I4B) :: nsd, ii, jj +REAL(DFP), ALLOCATABLE :: temp(:, :) +REAL(DFP) :: areal +REAL(DFP), PARAMETER :: oneby8 = 1.0_DFP / 8.0_DFP + +CHARACTER(1) :: astr IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromUnitTriangle2Triangle( & - & xin=temp_t(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="TRIANGLE", & - & xij=xij) + nsd = MAX(SIZE(xij, 1), 2_I4B) ELSE - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) + nsd = 2_I4B +END IF + +nrow = nsd + 1_I4B +ncol = nipsx(1) * nipsy(1) + +! ALLOCATE (temp(nrow, ncol)) + +CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, & + quadType1=GaussLegendreLobatto, quadType2=GaussJacobiRadauLeft, & + refQuadrangle="BIUNIT", alpha2=1.0_DFP, beta2=0.0_DFP, ans=ans, & + nrow=ii, ncol=jj) + +! temp_t(1:2, :) = FromBiUnitSqr2UnitTriangle(xin=temp_q(1:2, :)) +CALL FromSquare2Triangle_(xin=ans(1:2, :), ans=ans, nrow=ii, ncol=jj, & + from="BIUNIT", to="UNIT") + +DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * oneby8 +END DO + +IF (PRESENT(xij)) THEN + CALL FromUnitTriangle2Triangle_(xin=ans(1:2, :), x1=xij(:, 1), & + x2=xij(:, 2), x3=xij(:, 3), ans=ans, nrow=ii, ncol=jj) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="BIUNIT") + areal = JacobianTriangle(from="UNIT", to="TRIANGLE", xij=xij) - ELSE - ans = temp_t - END IF + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN END IF -IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q) -IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) +astr = UpperCase(refTriangle(1:1)) -END PROCEDURE TensorQuadraturePoint_Triangle2 +IF (astr .EQ. "B") THEN + CALL FromTriangle2Triangle_(xin=ans(1:2, :), ans=ans, nrow=ii, & + ncol=jj, from="UNIT", to="BIUNIT") + + areal = JacobianTriangle(from="UNIT", to="BIUNIT") + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN + +END IF + +END PROCEDURE TensorQuadraturePoint_Triangle2_ !---------------------------------------------------------------------------- ! QuadraturePoint_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Triangle1 -INTEGER(I4B) :: nips(1), nsd, ii, jj -REAL(DFP), ALLOCATABLE :: temp_t(:, :) +INTEGER(I4B) :: nrow, ncol LOGICAL(LGT) :: abool +ncol = QuadratureNumberTriangleSolin(order=order) + +nrow = 2_I4B +abool = PRESENT(xij) +IF (abool) nrow = SIZE(xij, 1) +nrow = nrow + 1 + +ALLOCATE (ans(nrow, ncol)) + +CALL QuadraturePoint_Triangle1_(order=order, quadType=quadType, & + refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Triangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Triangle1_ +INTEGER(I4B) :: nips(1) + nips(1) = QuadratureNumberTriangleSolin(order=order) IF (nips(1) .LE. 0) THEN - ans = TensorQuadraturepoint_Triangle(order=order, quadtype=quadtype, & - reftriangle=reftriangle, xij=xij) + CALL TensorQuadraturepoint_Triangle_(order=order, quadtype=quadtype, & + reftriangle=reftriangle, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) RETURN END IF -ALLOCATE (temp_t(3, nips(1))) -CALL QuadraturePointTriangleSolin_(nips=nips, ans=temp_t, nrow=ii, & - ncol=jj) +CALL QuadraturePoint_Triangle2_(nips=nips, quadType=quadType, & + refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) -nsd = 2_I4B +END PROCEDURE QuadraturePoint_Triangle1_ + +!---------------------------------------------------------------------------- +! QuadraturePoint_Triangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Triangle2 +INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: abool + +nrow = 2_I4B abool = PRESENT(xij) -IF (abool) nsd = SIZE(xij, 1) +IF (abool) nrow = SIZE(xij, 1) -ii = nsd + 1 -ALLOCATE (ans(ii, jj)) +nrow = nrow + 1 +ncol = nips(1) -IF (abool) THEN +ALLOCATE (ans(nrow, ncol)) - CALL FromTriangle2Triangle_(xin=temp_t(1:2, :), x1=xij(1:nsd, 1), & - x2=xij(1:nsd, 2), x3=xij(1:nsd, 3), ans=ans(1:nsd, :), & - from="U", to="T") +CALL QuadraturePoint_Triangle2_(nips=nips, quadType=quadType, & + refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", & - to="TRIANGLE", xij=xij) +END PROCEDURE QuadraturePoint_Triangle2 - RETURN +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Triangle2_ +INTEGER(I4B) :: nsd, ii, jj +LOGICAL(LGT) :: abool +REAL(DFP) :: areal +CHARACTER(1) :: astr +nrow = 0 +ncol = 0 + +ii = QuadratureNumberTriangleSolin(order=20) +abool = nips(1) .GT. ii +IF (abool) THEN + CALL Errormsg(msg="This routine should be called for economical & + & quadrature points only, otherwise call QuadraturePoint_Triangle1()", & + routine="QuadraturePoint_Triangle2()", & + file=__FILE__, line=__LINE__, unitNo=stdout) + RETURN END IF -abool = reftriangle(1:1) == "B" .OR. reftriangle(1:1) == "b" +nsd = 2_I4B +abool = PRESENT(xij) +IF (abool) nsd = SIZE(xij, 1) + +nrow = nsd + 1 +ncol = nips(1) + +CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=ii, ncol=jj) IF (abool) THEN - ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", to="BIUNIT") + CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), x1=xij(1:nsd, 1), & + x2=xij(1:nsd, 2), x3=xij(1:nsd, 3), ans=ans, & + from="U", to="T", nrow=ii, ncol=jj) + + areal = JacobianTriangle(from="UNIT", to="TRIANGLE", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + RETURN + END IF -ans = temp_t +astr = UpperCase(reftriangle(1:1)) +abool = astr == "B" -IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) +IF (abool) THEN + CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), ans=ans, & + from="U", to="B", nrow=ii, ncol=jj) -END PROCEDURE QuadraturePoint_Triangle1 + areal = JacobianTriangle(from="UNIT", to="BIUNIT") -!---------------------------------------------------------------------------- -! QuadraturePoint_Triangle2 -!---------------------------------------------------------------------------- + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO -MODULE PROCEDURE QuadraturePoint_Triangle2 -INTEGER(I4B) :: nsd -REAL(DFP), ALLOCATABLE :: temp_t(:, :) -TYPE(string) :: astr - -IF (nips(1) .LE. QuadratureNumberTriangleSolin(order=20_I4B)) THEN - astr = TRIM(UpperCase(refTriangle)) - temp_t = QuadraturePointTriangleSolin(nips=nips) - - IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) - ELSE - nsd = 2_I4B - END IF - - CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_t, 2, kind=I4B)) - - IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromUnitTriangle2Triangle( & - & xin=temp_t(1:2, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="TRIANGLE", & - & xij=xij) - ELSE - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :)) - ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( & - & from="UNIT", & - & to="BIUNIT") - - ELSE - ans = temp_t - END IF - END IF - - IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) -ELSE - CALL Errormsg( & - & msg="This routine should be called for economical"// & - & " quadrature points only, otherwise call QuadraturePoint_Triangle1()", & - & file=__FILE__, & - & line=__LINE__, & - & routine="QuadraturePoint_Triangle2()", & - & unitNo=stdout) RETURN END IF -END PROCEDURE QuadraturePoint_Triangle2 + +END PROCEDURE QuadraturePoint_Triangle2_ !---------------------------------------------------------------------------- ! From bc220ffdbb51916506ec05a68de6671b4774e0e2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 8 Jul 2024 18:25:55 +0900 Subject: [PATCH 192/359] updating mapping utility --- src/modules/Utility/src/MappingUtility.F90 | 14 ++- .../Utility/src/MappingUtility@Methods.F90 | 94 ++++++++++++++----- 2 files changed, 84 insertions(+), 24 deletions(-) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 6395f5543..b78280b83 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -57,6 +57,7 @@ MODULE MappingUtility PUBLIC :: FromBiUnitQuadrangle2UnitTriangle PUBLIC :: FromTriangle2Square_ +PUBLIC :: FromSquare2Triangle_ PUBLIC :: FromUnitTriangle2Triangle PUBLIC :: FromUnitTriangle2Triangle_ @@ -615,12 +616,17 @@ END FUNCTION FromBiUnitSqr2UnitTriangle ! summary: Map from triangle to square INTERFACE - MODULE PURE SUBROUTINE FromTriangle2Triangle_(xin, ans, from, to, x1, x2, x3) + MODULE PURE SUBROUTINE FromTriangle2Triangle_(xin, ans, nrow, ncol, & + from, to, x1, x2, x3) REAL(DFP), INTENT(IN) :: xin(:, :) !! coordinates in bi-unit square in xij coordinate REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(2, SIZE(xin, 2)) !! coordinates in biunit triangle + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + !! nrow=2 + !! ncol=SIZE(xin, 2) CHARACTER(*), INTENT(IN) :: from CHARACTER(*), INTENT(IN) :: to REAL(DFP), OPTIONAL, INTENT(IN) :: x1(:) @@ -661,7 +667,7 @@ END SUBROUTINE FromTriangle2Square_ ! summary: Map from triangle to square INTERFACE - MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to) + MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to, nrow, ncol) REAL(DFP), INTENT(IN) :: xin(:, :) !! coordinates in bi-unit square in xij coordinate REAL(DFP), INTENT(INOUT) :: ans(:, :) @@ -669,6 +675,10 @@ MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to) !! coordinates in biunit triangle CHARACTER(*), INTENT(IN) :: from CHARACTER(*), INTENT(IN) :: to + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + !! nrow = 2 + !! ncol = SIZE(xin, 2) END SUBROUTINE FromSquare2Triangle_ END INTERFACE diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index 5298f19c1..0da05da97 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -348,6 +348,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromUnitTriangle2BiUnitSqr +INTEGER(I4B) :: nrow, ncol CALL FromTriangle2Square_(xin=xin, ans=ans, from="U", to="B") END PROCEDURE FromUnitTriangle2BiUnitSqr @@ -356,21 +357,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromSquare2Triangle_ +REAL(DFP) :: rr(4) +INTEGER(I4B) :: ii CHARACTER(2) :: acase -acase = from(1:1)//to(1:1) + +acase(1:1) = UpperCase(from(1:1)) +acase(2:2) = UpperCase(to(1:1)) + +nrow = 2 +ncol = SIZE(xin, 2) SELECT CASE (acase) -CASE ("BB", "bb", "Bb", "bB") +CASE ("BB") - ans(1, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) & - - 1.0_DFP - ans(2, :) = xin(2, :) + DO ii = 1, ncol -CASE ("BU", "bu", "Bu", "bU") + rr(1) = xin(2, ii) + rr(2) = xin(1, ii) + rr(3) = 0.5_DFP * (1.0_DFP + rr(2)) + rr(4) = 1.0_DFP - rr(1) + rr(2) = rr(3) * rr(4) - 1.0_DFP - ans(1, :) = 0.25_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) - ans(2, :) = 0.5_DFP * (xin(2, :) + 1.0_DFP) + ans(1, ii) = rr(2) + ans(2, ii) = rr(1) + + END DO + +CASE ("BU") + + DO ii = 1, ncol + rr(1) = xin(1, ii) + rr(2) = xin(2, ii) + rr(3) = 0.25_DFP * (1.0_DFP + rr(1)) + rr(4) = 1.0_DFP - rr(2) + rr(1) = rr(3) * rr(4) + rr(3) = 0.5_DFP * (rr(2) + 1.0_DFP) + + ans(1, ii) = rr(1) + ans(2, ii) = rr(3) + END DO END SELECT END PROCEDURE FromSquare2Triangle_ @@ -380,7 +406,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitSqr2BiUnitTriangle -CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="B") +INTEGER(I4B) :: nrow, ncol +CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="B", nrow=nrow, & + ncol=ncol) END PROCEDURE FromBiUnitSqr2BiUnitTriangle !---------------------------------------------------------------------------- @@ -388,7 +416,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitSqr2UnitTriangle -CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="U") +INTEGER(I4B) :: nrow, ncol +CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="U", nrow=nrow, & + ncol=ncol) END PROCEDURE FromBiUnitSqr2UnitTriangle !---------------------------------------------------------------------------- @@ -439,25 +469,41 @@ MODULE PROCEDURE FromTriangle2Triangle_ CHARACTER(2) :: acase -INTEGER(I4B) :: ii, n +INTEGER(I4B) :: ii, jj +REAL(DFP) :: x21(3), x31(3) -acase = from(1:1)//to(1:1) +ncol = SIZE(xin, 2) + +acase(1:1) = Uppercase(from(1:1)) +acase(2:2) = Uppercase(to(1:1)) SELECT CASE (acase) -CASE ("BU", "bu", "bU", "Bu") +CASE ("BU") - ans = 0.5_DFP * (1.0_DFP + xin) + nrow = SIZE(xin, 1) -CASE ("UB", "ub", "Ub", "uB") + DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = 0.5_DFP * (1.0_DFP + xin(ii, jj)) + END DO - ans = -1.0_DFP + 2.0_DFP * xin +CASE ("UB") -CASE ("UT", "ut", "Ut", "uT") + nrow = SIZE(xin, 1) - n = SIZE(xin, 2) - DO CONCURRENT(ii=1:n) - ans(:, ii) = x1 + (x2 - x1) * xin(1, ii) + (x3 - x1) * xin(2, ii) + DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = -1.0_DFP + 2.0_DFP * xin(ii, jj) + END DO + +CASE ("UT") + + nrow = SIZE(x1) + + x21(1:nrow) = x2(1:nrow) - x1(1:nrow) + x31(1:nrow) = x3(1:nrow) - x1(1:nrow) + + DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = x1(ii) + x21(ii) * xin(1, jj) + x31(ii) * xin(2, jj) END DO END SELECT @@ -468,7 +514,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitTriangle2UnitTriangle -CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="B", to="U") +INTEGER(I4B) :: nrow, ncol +CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="B", to="U", nrow=nrow, & + ncol=ncol) END PROCEDURE FromBiUnitTriangle2UnitTriangle !---------------------------------------------------------------------------- @@ -476,7 +524,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromUnitTriangle2BiUnitTriangle -CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="U", to="B") +INTEGER(I4B) :: nrow, ncol +CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="U", to="B", nrow=nrow, & + ncol=ncol) END PROCEDURE FromUnitTriangle2BiUnitTriangle !---------------------------------------------------------------------------- From fb34dd9832ea0dd91c7260089bc0df6b3f1f6057 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 8 Jul 2024 18:29:11 +0900 Subject: [PATCH 193/359] udpates in quadrature points --- src/submodules/QuadraturePoint/CMakeLists.txt | 38 ++++++------- ...draturePoint_Method@ConstructorMethods.F90 | 56 +++++++++---------- 2 files changed, 46 insertions(+), 48 deletions(-) diff --git a/src/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt index 69ce7a34f..9e9866be4 100644 --- a/src/submodules/QuadraturePoint/CMakeLists.txt +++ b/src/submodules/QuadraturePoint/CMakeLists.txt @@ -1,25 +1,23 @@ -# This program is a part of EASIFEM library -# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D # -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. # -# You should have received a copy of the GNU General Public License -# along with this program. If not, see +# You should have received a copy of the GNU General Public License along with +# this program. If not, see # -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/QuadraturePoint_Method@IOMethods.F90 - ${src_path}/QuadraturePoint_Method@GetMethods.F90 - ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90 -) - +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/QuadraturePoint_Method@IOMethods.F90 + ${src_path}/QuadraturePoint_Method@GetMethods.F90 + ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index 42fee7005..e427e1424 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -46,6 +46,34 @@ ans = BaseInterpolation_ToInteger(name) END PROCEDURE QuadraturePointNameToID +!---------------------------------------------------------------------------- +! QuadraturePoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Constructor1 +obj%points = points +obj%tXi = SIZE(points, 1) - 1 +END PROCEDURE quad_Constructor1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Pointer +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Constructor_1 +ALLOCATE (obj) +obj%points = points +obj%tXi = SIZE(points, 1) - 1 +END PROCEDURE quad_Constructor_1 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE quad_Deallocate +IF (ALLOCATED(obj%points)) DEALLOCATE (obj%points) +obj%tXi = -1 +END PROCEDURE quad_Deallocate + !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- @@ -1062,32 +1090,4 @@ ! ! END PROCEDURE obj_Initiate8 -!---------------------------------------------------------------------------- -! QuadraturePoint -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Constructor1 -obj%points = points -obj%tXi = SIZE(points, 1) - 1 -END PROCEDURE quad_Constructor1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Pointer -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Constructor_1 -ALLOCATE (obj) -obj%points = points -obj%tXi = SIZE(points, 1) - 1 -END PROCEDURE quad_Constructor_1 - -!---------------------------------------------------------------------------- -! Deallocate -!---------------------------------------------------------------------------- - -MODULE PROCEDURE quad_Deallocate -IF (ALLOCATED(obj%points)) DEALLOCATE (obj%points) -obj%tXi = -1 -END PROCEDURE quad_Deallocate - END SUBMODULE ConstructorMethods From b086ed8bfc75ebfea028304195050c0523b96e52 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 00:10:30 +0900 Subject: [PATCH 194/359] update in triangle interpol --- .../src/TriangleInterpolationUtility.F90 | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index d2ee51917..99678de66 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -53,7 +53,10 @@ MODULE TriangleInterpolationUtility PUBLIC :: LagrangeGradientEvalAll_Triangle PUBLIC :: LagrangeGradientEvalAll_Triangle_ +PUBLIC :: QuadratureNumber_Triangle PUBLIC :: QuadraturePoint_Triangle +PUBLIC :: QuadraturePoint_Triangle_ + PUBLIC :: IJ2VEFC_Triangle PUBLIC :: FacetConnectivity_Triangle PUBLIC :: RefElemDomain_Triangle @@ -1336,6 +1339,22 @@ MODULE SUBROUTINE LagrangeEvalAll_Triangle2_(order, x, xij, ans, nrow, & END SUBROUTINE LagrangeEvalAll_Triangle2_ END INTERFACE LagrangeEvalAll_Triangle_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION QuadratureNumber_Triangle(order, quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + INTEGER(I4B) :: ans + !! Quadrature points + END FUNCTION QuadratureNumber_Triangle +END INTERFACE + !---------------------------------------------------------------------------- ! QuadraturePoints_Triangle !---------------------------------------------------------------------------- From f9db67f7d4a8bb9b56359a1cc17ac0c58182797b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 00:10:39 +0900 Subject: [PATCH 195/359] update in quadrature point --- .../src/QuadraturePoint_Method.F90 | 200 ++++++++++++++++-- 1 file changed, 178 insertions(+), 22 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index d833339b0..ffedc3b1b 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -74,6 +74,29 @@ MODULE FUNCTION QuadraturePointIdToName(name) RESULT(ans) END FUNCTION QuadraturePointIdToName END INTERFACE +!---------------------------------------------------------------------------- +! QuadratureNumber@ConstructorMethods +!---------------------------------------------------------------------------- + +INTERFACE QuadratureNumber + MODULE FUNCTION obj_QuadratureNumber1(topo, order, quadratureType) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: topo + !! Reference-element + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadratureType + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight + INTEGER(I4B) :: ans + !! quadrature number + !! for quadrangle element ans is number of quadrature points in x and y + !! so total number of quadrature points are ans*ans + END FUNCTION obj_QuadratureNumber1 +END INTERFACE QuadratureNumber + !---------------------------------------------------------------------------- ! Initiate@ConstructorMethods !---------------------------------------------------------------------------- @@ -230,7 +253,7 @@ MODULE SUBROUTINE obj_Initiate6(obj, refElem, nips, quadratureType, & CLASS(ReferenceElement_), INTENT(IN) :: refElem !! Reference element INTEGER(I4B), INTENT(IN) :: nips(1) - !! order of integrand + !! number of integration points INTEGER(I4B), INTENT(IN) :: quadratureType !! Type of quadrature points !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau @@ -245,7 +268,6 @@ MODULE SUBROUTINE obj_Initiate6(obj, refElem, nips, quadratureType, & !! Ultraspherical parameter END SUBROUTINE obj_Initiate6 END INTERFACE Initiate - !---------------------------------------------------------------------------- ! Initiate@ConstructorMethods !---------------------------------------------------------------------------- @@ -269,17 +291,10 @@ MODULE SUBROUTINE obj_Initiate7(obj, refElem, p, q, r, quadratureType1, & INTEGER(I4B), INTENT(IN) :: r !! order of integrand in z direction INTEGER(I4B), INTENT(IN) :: quadratureType1 - !! Type of quadrature points - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadau - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev - !! GaussChebyshevLobatto - !! GaussChebyshevRadau - !! GaussChebyshevRadauLeft - !! GaussChebyshevRadauRight + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight INTEGER(I4B), INTENT(IN) :: quadratureType2 !! Type of quadrature points INTEGER(I4B), INTENT(IN) :: quadratureType3 @@ -317,15 +332,9 @@ MODULE SUBROUTINE obj_Initiate8(obj, refElem, nipsx, nipsy, nipsz, & !! number of integration points in z direction INTEGER(I4B), INTENT(IN) :: quadratureType1 !! Type of quadrature points - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadau - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev - !! GaussChebyshevLobatto - !! GaussChebyshevRadau - !! GaussChebyshevRadauLeft + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev + !! GaussChebyshevLobatto ! GaussChebyshevRadau ! GaussChebyshevRadauLeft !! GaussChebyshevRadauRight INTEGER(I4B), INTENT(IN) :: quadratureType2 !! Type of quadrature points @@ -340,6 +349,153 @@ MODULE SUBROUTINE obj_Initiate8(obj, refElem, nipsx, nipsy, nipsz, & END SUBROUTINE obj_Initiate8 END INTERFACE Initiate +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate9(obj, elemType, domainName, order, & + quadratureType, alpha, beta, lambda, xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + INTEGER(I4B), INTENT(IN) :: elemType + !! element name + CHARACTER(*), INTENT(IN) :: domainName + !! domain name + !! unit or biunit + !! Reference-element + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadratureType + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + END SUBROUTINE obj_Initiate9 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate10(obj, elemType, domainName, nips, & + quadratureType, alpha, beta, lambda, xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + INTEGER(I4B), INTENT(IN) :: elemType + !! element name + CHARACTER(*), INTENT(IN) :: domainName + !! domain name + !! unit or biunit + !! Reference-element + INTEGER(I4B), INTENT(IN) :: nips(1) + !! order of integrand + !! in the case of quadrangle element nips(1) denotes the + !! number of quadrature points in the x and y direction + !! so the total number of quadrature points are nips(1)*nips(1) + INTEGER(I4B), INTENT(IN) :: quadratureType + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + END SUBROUTINE obj_Initiate10 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate11(obj, elemType, domainName, p, q, r, & + quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & + lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + INTEGER(I4B), INTENT(IN) :: elemtype + !! Reference-element + CHARACTER(*), INTENT(IN) :: domainName + !! domain name + INTEGER(I4B), INTENT(IN) :: p + !! order of integrand in x + INTEGER(I4B), INTENT(IN) :: q + !! order of integrand in y + INTEGER(I4B), INTENT(IN) :: r + !! order of integrand in z direction + INTEGER(I4B), INTENT(IN) :: quadratureType1 + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight + INTEGER(I4B), INTENT(IN) :: quadratureType2 + !! Type of quadrature points + INTEGER(I4B), INTENT(IN) :: quadratureType3 + !! Type of quadrature points + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi parameter and Ultraspherical parameters + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi parameter and Ultraspherical parameters + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi parameter and Ultraspherical parameters + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + END SUBROUTINE obj_Initiate11 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE Initiate + MODULE SUBROUTINE obj_Initiate12(obj, elemType, domainName, nipsx, nipsy, & + nipsz, quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & + lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + CHARACTER(*), INTENT(IN) :: domainName + !! domain name + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! number of integration points in z direction + INTEGER(I4B), INTENT(IN) :: quadratureType1 + !! Type of quadrature points + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev + !! GaussChebyshevLobatto ! GaussChebyshevRadau ! GaussChebyshevRadauLeft + !! GaussChebyshevRadauRight + INTEGER(I4B), INTENT(IN) :: quadratureType2 + !! Type of quadrature points + INTEGER(I4B), INTENT(IN) :: quadratureType3 + !! Type of quadrature points + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! coordinates of reference element + END SUBROUTINE obj_Initiate12 +END INTERFACE Initiate + !---------------------------------------------------------------------------- ! QuadraturePoint@ConstructureMethods !---------------------------------------------------------------------------- From 514ef525f0c699c9326eca31e53895b83b59fc5c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 00:10:45 +0900 Subject: [PATCH 196/359] update in triangle interpol --- ...iangleInterpolationUtility@QuadratureMethods.F90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 index 85d77be22..0badc8787 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -22,6 +22,19 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Triangle +ans = QuadratureNumberTriangleSolin(order=order) + +IF (ans .LE. 0) THEN + ans = 1_I4B + INT(order / 2, kind=I4B) + ans = ans * (ans + 1) +END IF +END PROCEDURE QuadratureNumber_Triangle + !---------------------------------------------------------------------------- ! TensorQuadraturePoint_Triangle !---------------------------------------------------------------------------- From 3f61542509227c305672bcf91ca4fba83c4fb8b9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 00:10:55 +0900 Subject: [PATCH 197/359] update in quadrature point mehtod --- ...iangleInterpolationUtility@QuadratureMethods.F90 | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 index 0badc8787..85d77be22 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -22,19 +22,6 @@ IMPLICIT NONE CONTAINS -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadratureNumber_Triangle -ans = QuadratureNumberTriangleSolin(order=order) - -IF (ans .LE. 0) THEN - ans = 1_I4B + INT(order / 2, kind=I4B) - ans = ans * (ans + 1) -END IF -END PROCEDURE QuadratureNumber_Triangle - !---------------------------------------------------------------------------- ! TensorQuadraturePoint_Triangle !---------------------------------------------------------------------------- From c4493dc2ba97e97e0ff3ff26e64843fea1ba4eb5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 00:11:06 +0900 Subject: [PATCH 198/359] update in triangle interpol --- ...iangleInterpolationUtility@QuadratureMethods.F90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 index 85d77be22..0badc8787 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -22,6 +22,19 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Triangle +ans = QuadratureNumberTriangleSolin(order=order) + +IF (ans .LE. 0) THEN + ans = 1_I4B + INT(order / 2, kind=I4B) + ans = ans * (ans + 1) +END IF +END PROCEDURE QuadratureNumber_Triangle + !---------------------------------------------------------------------------- ! TensorQuadraturePoint_Triangle !---------------------------------------------------------------------------- From 0bf2644b042058203e13939bba11fffaae0b08fd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 00:11:17 +0900 Subject: [PATCH 199/359] update in quadrature point method --- ...draturePoint_Method@ConstructorMethods.F90 | 1158 +++-------------- 1 file changed, 213 insertions(+), 945 deletions(-) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index e427e1424..d1ec00a0e 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -24,7 +24,16 @@ BaseInterpolation_ToInteger USE ReallocateUtility, ONLY: Reallocate -USE ReferenceElement_Method, ONLY: ElementTopology +USE ReferenceElement_Method, ONLY: ElementTopology, & + XiDimension + +USE LineInterpolationUtility, ONLY: QuadratureNumber_Line, & + QuadraturePoint_Line_ +USE TriangleInterpolationUtility, ONLY: QuadraturePoint_Triangle_, & + QuadratureNumber_Triangle + +USE QuadrangleInterpolationUtility, ONLY: QuadraturePoint_Quadrangle_, & + QuadratureNumber_Quadrangle IMPLICIT NONE @@ -74,6 +83,40 @@ obj%tXi = -1 END PROCEDURE quad_Deallocate +!---------------------------------------------------------------------------- +! QuadraturePoint +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_QuadratureNumber1 +INTEGER(I4B) :: ncol + +SELECT CASE (topo) + +CASE (Line) + + ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) + +CASE (Triangle) + + ans = QuadratureNumber_Triangle(order=order, quadtype=quadratureType) + +CASE (Quadrangle) + + ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) + +CASE (Tetrahedron) + ! ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) + +CASE (Hexahedron) + +CASE (Prism) + +CASE (Pyramid) + +END SELECT + +END PROCEDURE obj_QuadratureNumber1 + !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- @@ -126,968 +169,193 @@ ! Initiate !---------------------------------------------------------------------------- -! MODULE PROCEDURE obj_Initiate5 -! -! SELECT TYPE (refelem) -! -! TYPE IS (ReferenceLine_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & order=order, & -! & quadType=quadratureType, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! -! TYPE IS (ReferenceTriangle_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & order=order, & -! & quadType=quadratureType, & -! & refTriangle=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceQuadrangle_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & order=order, & -! & quadType=quadratureType, & -! & refQuadrangle=refelem%domainName, & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! -! TYPE IS (ReferenceTetrahedron_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & order=order, & -! & quadType=quadratureType, & -! & refTetrahedron=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceHexahedron_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & order=order, & -! & quadType=quadratureType, & -! & refHexahedron=refelem%domainName, & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! -! TYPE IS (ReferencePrism_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & order=order, & -! & quadType=quadratureType, & -! & refPrism=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferencePyramid_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & order=order, & -! & quadType=quadratureType, & -! & refPyramid=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceElement_) -! -! IF (isLine(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & order=order, & -! & quadType=quadratureType, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isTriangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & order=order, & -! & quadType=quadratureType, & -! & refTriangle=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isQuadrangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & order=order, & -! & quadType=quadratureType, & -! & refQuadrangle=refelem%domainName, & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isTetrahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & order=order, & -! & quadType=quadratureType, & -! & refTetrahedron=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isHexahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & order=order, & -! & quadType=quadratureType, & -! & refHexahedron=refelem%domainName, & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isPrism(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & order=order, & -! & quadType=quadratureType, & -! & refPrism=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isPyramid(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & order=order, & -! & quadType=quadratureType, & -! & refPyramid=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! CLASS DEFAULT -! CALL ErrorMsg(msg="[NO CASE FOUND] for the type of refelem", & -! routine="obj_Initiate5()", & -! file=__FILE__, line=__LINE__, unitno=stderr) -! RETURN -! END SELECT -! -! END PROCEDURE obj_Initiate5 +MODULE PROCEDURE obj_Initiate5 +CALL obj_Initiate9(obj=obj, elemType=refelem%name, & + domainName=refelem%domainName, order=order, quadratureType=quadratureType, & + alpha=alpha, beta=beta, lambda=lambda, xij=refelem%xij) +END PROCEDURE obj_Initiate5 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -! MODULE PROCEDURE obj_Initiate9 -! INTEGER(I4B) :: topo -! -! topo = ElementTopology(elemType) -! -! SELECT CASE (topo) -! CASE (Line) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & order=order, & -! & quadType=quadratureType, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! CASE (Triangle) -! CASE (Quadrangle) -! CASE (Tetrahedron) -! CASE (Hexahedron) -! CASE (Prism) -! CASE (Pyramid) -! END SELECT -! -! IF (isLine(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & order=order, & -! & quadType=quadratureType, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isTriangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & order=order, & -! & quadType=quadratureType, & -! & refTriangle=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isQuadrangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & order=order, & -! & quadType=quadratureType, & -! & refQuadrangle=refelem%domainName, & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isTetrahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & order=order, & -! & quadType=quadratureType, & -! & refTetrahedron=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isHexahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & order=order, & -! & quadType=quadratureType, & -! & refHexahedron=refelem%domainName, & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isPrism(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & order=order, & -! & quadType=quadratureType, & -! & refPrism=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isPyramid(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & order=order, & -! & quadType=quadratureType, & -! & refPyramid=refelem%domainName, & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! END PROCEDURE obj_Initiate9 +MODULE PROCEDURE obj_Initiate6 +CALL obj_Initiate10(obj=obj, elemType=refelem%name, & + domainName=refelem%domainName, nips=nips, quadratureType=quadratureType, & + alpha=alpha, beta=beta, lambda=lambda, xij=refelem%xij) +END PROCEDURE obj_Initiate6 !---------------------------------------------------------------------------- -! Initiate +! Initiate !---------------------------------------------------------------------------- -! MODULE PROCEDURE obj_Initiate6 -! -! SELECT TYPE (refelem) -! TYPE IS (ReferenceLine_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & nips=nips, & -! & quadType=quadratureType, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! -! TYPE IS (ReferenceTriangle_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refTriangle="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceQuadrangle_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refQuadrangle="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! -! TYPE IS (ReferenceTetrahedron_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refTetrahedron="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceHexahedron_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refHexahedron="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! -! TYPE IS (ReferencePrism_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refPrism="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferencePyramid_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refPyramid="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceElement_) -! -! IF (isLine(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & nips=nips, & -! & quadType=quadratureType, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isTriangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refTriangle="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isQuadrangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refQuadrangle="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isTetrahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refTetrahedron="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isHexahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refHexahedron="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha, & -! & beta=beta, & -! & lambda=lambda) & -! & ) -! RETURN -! END IF -! -! IF (isPrism(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refPrism="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isPyramid(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & nips=nips, & -! & quadType=quadratureType, & -! & refPyramid="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! CLASS DEFAULT -! CALL ErrorMsg(& -! & msg="No case found", & -! & file=__FILE__, & -! & routine="obj_Initiate6()", & -! & line=__LINE__, & -! & unitno=stderr) -! RETURN -! END SELECT -! -! END PROCEDURE obj_Initiate6 +MODULE PROCEDURE obj_Initiate8 +CALL obj_Initiate12(obj=obj, elemType=refelem%name, & + domainName=refelem%domainName, nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadratureType1=quadratureType1, quadratureType2=quadratureType2, & + quadratureType3=quadratureType3, alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + alpha3=alpha3, beta3=beta3, lambda3=lambda3, xij=refelem%xij) +END PROCEDURE obj_Initiate8 !---------------------------------------------------------------------------- -! QuadraturePoint +! Initiate !---------------------------------------------------------------------------- -! MODULE PROCEDURE obj_Initiate7 -! -! SELECT TYPE (refelem) -! TYPE IS (ReferenceLine_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & order=p, & -! & quadType=quadratureType1, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha1, & -! & beta=beta1, & -! & lambda=lambda1) & -! & ) -! -! TYPE IS (ReferenceTriangle_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & order=p, & -! & quadType=quadratureType1, & -! & refTriangle="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceQuadrangle_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & p=p, & -! & q=q, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & refQuadrangle="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2 & -! & )) -! -! TYPE IS (ReferenceTetrahedron_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & order=p, & -! & quadType=quadratureType1, & -! & refTetrahedron="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceHexahedron_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & p=p, & -! & q=q, & -! & r=r, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & quadType3=quadratureType3, & -! & refHexahedron="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2, & -! & alpha3=alpha3, & -! & beta3=beta3, & -! & lambda3=lambda3 & -! & )) -! -! TYPE IS (ReferencePrism_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & order=p, & -! & quadType=quadratureType1, & -! & refPrism="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferencePyramid_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & order=p, & -! & quadType=quadratureType1, & -! & refPyramid="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceElement_) -! -! IF (isLine(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & order=p, & -! & quadType=quadratureType1, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha1, & -! & beta=beta1, & -! & lambda=lambda1) & -! & ) -! RETURN -! END IF -! -! IF (isTriangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & order=p, & -! & quadType=quadratureType1, & -! & refTriangle="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isQuadrangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & p=p, & -! & q=q, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & refQuadrangle="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2 & -! & )) -! RETURN -! END IF -! -! IF (isTetrahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & order=p, & -! & quadType=quadratureType1, & -! & refTetrahedron="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isHexahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & p=p, & -! & q=q, & -! & r=r, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & quadType3=quadratureType3, & -! & refHexahedron="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2, & -! & alpha3=alpha3, & -! & beta3=beta3, & -! & lambda3=lambda3 & -! & )) -! RETURN -! END IF -! -! IF (isPrism(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & order=p, & -! & quadType=quadratureType1, & -! & refPrism="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isPyramid(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & order=p, & -! & quadType=quadratureType1, & -! & refPyramid="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! CLASS DEFAULT -! CALL ErrorMsg(& -! & msg="No case found", & -! & file=__FILE__, & -! & routine="obj_Initiate7()", & -! & line=__LINE__, & -! & unitno=stderr) -! RETURN -! END SELECT -! -! END PROCEDURE obj_Initiate7 +MODULE PROCEDURE obj_Initiate9 +CALL obj_Initiate11(obj=obj, elemType=elemtype, domainName=domainname, & + p=order, q=order, r=order, quadratureType1=quadratureType, & + quadratureType2=quadratureType, quadratureType3=quadratureType, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, xij=xij) +END PROCEDURE obj_Initiate9 !---------------------------------------------------------------------------- -! QuadraturePoint +! Initiate !---------------------------------------------------------------------------- -! MODULE PROCEDURE obj_Initiate8 -! -! SELECT TYPE (refelem) -! TYPE IS (ReferenceLine_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha1, & -! & beta=beta1, & -! & lambda=lambda1) & -! & ) -! -! TYPE IS (ReferenceTriangle_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refTriangle="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceQuadrangle_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & nipsx=nipsx, & -! & nipsy=nipsy, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & refQuadrangle="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2 & -! & )) -! -! TYPE IS (ReferenceTetrahedron_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refTetrahedron="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceHexahedron_) -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & nipsx=nipsx, & -! & nipsy=nipsy, & -! & nipsz=nipsz, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & quadType3=quadratureType3, & -! & refHexahedron="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2, & -! & alpha3=alpha3, & -! & beta3=beta3, & -! & lambda3=lambda3 & -! & )) -! -! TYPE IS (ReferencePrism_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refPrism="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferencePyramid_) -! -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refPyramid="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! -! TYPE IS (ReferenceElement_) -! -! IF (isLine(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Line( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & layout="INCREASING", & -! & xij=LocalNodeCoord(refElem), & -! & alpha=alpha1, & -! & beta=beta1, & -! & lambda=lambda1) & -! & ) -! RETURN -! END IF -! -! IF (isTriangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Triangle( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refTriangle="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isQuadrangle(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Quadrangle( & -! & nipsx=nipsx, & -! & nipsy=nipsy, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & refQuadrangle="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2 & -! & )) -! RETURN -! END IF -! -! IF (isTetrahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Tetrahedron( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refTetrahedron="UNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isHexahedron(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Hexahedron( & -! & nipsx=nipsx, & -! & nipsy=nipsy, & -! & nipsz=nipsz, & -! & quadType1=quadratureType1, & -! & quadType2=quadratureType2, & -! & quadType3=quadratureType3, & -! & refHexahedron="BIUNIT", & -! & xij=LocalNodeCoord(refElem), & -! & alpha1=alpha1, & -! & beta1=beta1, & -! & lambda1=lambda1, & -! & alpha2=alpha2, & -! & beta2=beta2, & -! & lambda2=lambda2, & -! & alpha3=alpha3, & -! & beta3=beta3, & -! & lambda3=lambda3 & -! & )) -! RETURN -! END IF -! -! IF (isPrism(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Prism( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refPrism="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF -! -! IF (isPyramid(refelem%name)) THEN -! CALL Initiate( & -! & obj=obj, & -! & points=QuadraturePoint_Pyramid( & -! & nips=nipsx, & -! & quadType=quadratureType1, & -! & refPyramid="BIUNIT", & -! & xij=LocalNodeCoord(refElem)) & -! & ) -! RETURN -! END IF +MODULE PROCEDURE obj_Initiate10 +CALL obj_Initiate12(obj=obj, elemType=elemtype, domainName=domainName, & + nipsx=nips, nipsy=nips, nipsz=nips, quadratureType1=quadratureType, & + quadratureType2=quadratureType, quadratureType3=quadratureType, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, xij=xij) +END PROCEDURE obj_Initiate10 + +!---------------------------------------------------------------------------- ! -! CLASS DEFAULT -! CALL ErrorMsg(& -! & msg="No case found", & -! & file=__FILE__, & -! & routine="obj_Initiate7()", & -! & line=__LINE__, & -! & unitno=stderr) -! RETURN -! END SELECT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate11 +INTEGER(I4B) :: topo, nrow, ncol, ii, nipsx(1), nipsy(1), nipsz(1) + +topo = ElementTopology(elemType) + +ii = XiDimension(elemType) + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), ii) +ELSE + nrow = ii +END IF + +nrow = nrow + 1 + +SELECT CASE (topo) + +CASE (Line) + + nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) + + ncol = nipsx(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadratureType1, & + layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, & + lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol) + +CASE (Triangle) + + nipsx(1) = QuadratureNumber_Triangle(order=p, quadtype=quadratureType1) + ncol = nipsx(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, & + refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + +CASE (Quadrangle) + + nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) + nipsy(1) = QuadratureNumber_Line(order=q, quadtype=quadratureType2) + + ncol = nipsx(1) * nipsy(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, & + quadType1=quadratureType1, quadType2=quadratureType2, & + refQuadrangle=domainName, xij=xij, alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + ans=obj%points, nrow=nrow, ncol=ncol) + +CASE (Tetrahedron) + +CASE (Hexahedron) + +CASE (Prism) + +CASE (Pyramid) + +END SELECT + +obj%txi = SIZE(obj%points, 1) - 1 + +END PROCEDURE obj_Initiate11 + +!---------------------------------------------------------------------------- ! -! END PROCEDURE obj_Initiate8 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate12 +INTEGER(I4B) :: topo, nrow, ncol, ii + +topo = ElementTopology(elemType) + +ii = XiDimension(elemType) + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), ii) +ELSE + nrow = ii +END IF + +nrow = nrow + 1 + +SELECT CASE (topo) + +CASE (Line) + ncol = nipsx(1) + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadratureType1, & + layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, & + lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol) + +CASE (Triangle) + + ncol = nipsx(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, & + refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + +CASE (Quadrangle) + + ncol = nipsx(1) * nipsy(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, & + quadType1=quadratureType1, quadType2=quadratureType2, & + refQuadrangle=domainName, xij=xij, alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + ans=obj%points, nrow=nrow, ncol=ncol) + +CASE (Tetrahedron) + +CASE (Hexahedron) + +CASE (Prism) + +CASE (Pyramid) + +END SELECT + +obj%txi = SIZE(obj%points, 1) - 1 + +END PROCEDURE obj_Initiate12 END SUBMODULE ConstructorMethods From e3c532ba8b4220b51efc4619571615878eb13513 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 16:40:34 +0900 Subject: [PATCH 200/359] updates in hexahedron --- .../src/HexahedronInterpolationUtility.F90 | 311 +++++++++++------- 1 file changed, 192 insertions(+), 119 deletions(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index ff51dd784..39111f1fb 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -47,7 +47,10 @@ MODULE HexahedronInterpolationUtility PUBLIC :: CellBasis_Hexahedron PUBLIC :: HeirarchicalBasis_Hexahedron PUBLIC :: HeirarchicalBasis_Hexahedron_ + PUBLIC :: QuadraturePoint_Hexahedron +PUBLIC :: QuadraturePoint_Hexahedron_ + PUBLIC :: LagrangeEvalAll_Hexahedron PUBLIC :: LagrangeEvalAll_Hexahedron_ PUBLIC :: GetVertexDOF_Hexahedron @@ -347,13 +350,8 @@ END FUNCTION GetCellDOF_Hexahedron2 !---------------------------------------------------------------------------- INTERFACE - MODULE PURE FUNCTION QuadratureNumber_Hexahedron( & - & p, & - & q, & - & r, & - & quadType1, & - & quadType2, & - & quadType3) RESULT(ans) + MODULE PURE FUNCTION QuadratureNumber_Hexahedron(p, q, r, quadType1, & + quadType2, quadType3) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p, q, r INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 INTEGER(I4B) :: ans(3) @@ -369,9 +367,8 @@ END FUNCTION QuadratureNumber_Hexahedron ! summary: This function returns the edge connectivity of Hexahedron INTERFACE - MODULE PURE FUNCTION FacetConnectivity_Hexahedron( & - & baseInterpol, & - & baseContinuity) RESULT(ans) + MODULE PURE FUNCTION FacetConnectivity_Hexahedron(baseInterpol, & + baseContinuity) RESULT(ans) CHARACTER(*), INTENT(IN) :: baseInterpol CHARACTER(*), INTENT(IN) :: baseContinuity INTEGER(I4B) :: ans(4, 6) @@ -387,9 +384,8 @@ END FUNCTION FacetConnectivity_Hexahedron ! summary: This function returns the edge connectivity of Hexahedron INTERFACE - MODULE PURE FUNCTION EdgeConnectivity_Hexahedron( & - & baseInterpol, & - & baseContinuity) RESULT(ans) + MODULE PURE FUNCTION EdgeConnectivity_Hexahedron(baseInterpol, & + baseContinuity) RESULT(ans) CHARACTER(*), INTENT(IN) :: baseInterpol CHARACTER(*), INTENT(IN) :: baseContinuity INTEGER(I4B) :: ans(2, 12) @@ -2416,38 +2412,21 @@ END SUBROUTINE HeirarchicalBasis_Hexahedron2_ ! summary: Returns quadrature points on reference hexahedron INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron1( & - & order, & - & quadType, & - & refHexahedron, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Hexahedron1(order, quadType, & + refHexahedron, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of integrand in x, y, and z direction INTEGER(I4B), INTENT(IN) :: quadType !! quadrature point type - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft + !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight + !! GaussUltraspherical ! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight + !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft !! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refHexahedron - !! Reference hexahedron - !! UNIT - !! BIUNIT + !! Reference hexahedron ! UNIT ! BIUNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! nodal coordiantes of hexahedron in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha @@ -2461,20 +2440,49 @@ MODULE FUNCTION QuadraturePoint_Hexahedron1( & END FUNCTION QuadraturePoint_Hexahedron1 END INTERFACE QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Hexahedron_ + MODULE SUBROUTINE QuadraturePoint_Hexahedron1_(order, quadType, & + refHexahedron, xij, alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand in x, y, and z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft + !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight + !! GaussUltraspherical ! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight + !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refHexahedron + !! Reference hexahedron ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordiantes of hexahedron in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! quadrature points in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + END SUBROUTINE QuadraturePoint_Hexahedron1_ +END INTERFACE QuadraturePoint_Hexahedron_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Hexahedron !---------------------------------------------------------------------------- INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron2( & - & p, q, r, & - & quadType1, quadType2, quadType3, & - & refHexahedron, & - & xij, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3 & - & ) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Hexahedron2(p, q, r, quadType1, & + quadType2, quadType3, refHexahedron, xij, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order of integrand in x direction INTEGER(I4B), INTENT(IN) :: q @@ -2483,27 +2491,15 @@ MODULE FUNCTION QuadraturePoint_Hexahedron2( & !! order of integrand in z direction INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 !! quadrature point type in x direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refHexahedron - !! Reference hexahedron - !! UNIT - !! BIUNIT + !! Reference hexahedron ! UNIT ! BIUNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! four vertices of quadrangle in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 @@ -2517,6 +2513,45 @@ MODULE FUNCTION QuadraturePoint_Hexahedron2( & END FUNCTION QuadraturePoint_Hexahedron2 END INTERFACE QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Hexahedron_ + MODULE SUBROUTINE QuadraturePoint_Hexahedron2_(p, q, r, quadType1, & + quadType2, quadType3, refHexahedron, xij, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, alpha3, beta3, lambda3, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: r + !! order of integrand in z direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 + !! quadrature point type in x direction + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refHexahedron + !! Reference hexahedron ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE QuadraturePoint_Hexahedron2_ +END INTERFACE QuadraturePoint_Hexahedron_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Hexahedron !---------------------------------------------------------------------------- @@ -2526,33 +2561,18 @@ END FUNCTION QuadraturePoint_Hexahedron2 ! summary: Returns quadrature points on reference quadrangle INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron3( & - & nips, & - & quadType, & - & refHexahedron, & - & xij, & - & alpha, & - & beta, & - & lambda) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Hexahedron3(nips, quadType, & + refHexahedron, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: nips(1) !! number of integration points in x, y, and z direction INTEGER(I4B), INTENT(IN) :: quadType !! interpolation point type - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft + !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight + !! GaussUltraspherical ! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight + !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft !! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refHexahedron !! Reference hexahedron @@ -2571,20 +2591,43 @@ MODULE FUNCTION QuadraturePoint_Hexahedron3( & END FUNCTION QuadraturePoint_Hexahedron3 END INTERFACE QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Hexahedron_ + MODULE SUBROUTINE QuadraturePoint_Hexahedron3_(nips, quadType, & + refHexahedron, xij, alpha, beta, lambda, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! number of integration points in x, y, and z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! interpolation point type + CHARACTER(*), INTENT(IN) :: refHexahedron + !! Reference hexahedron + !! UNIT + !! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE QuadraturePoint_Hexahedron3_ +END INTERFACE QuadraturePoint_Hexahedron_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Hexahedron !---------------------------------------------------------------------------- INTERFACE QuadraturePoint_Hexahedron - MODULE FUNCTION QuadraturePoint_Hexahedron4( & - & nipsx, nipsy, nipsz, & - & quadType1, quadType2, quadType3, & - & refHexahedron, & - & xij, & - & alpha1, beta1, lambda1, & - & alpha2, beta2, lambda2, & - & alpha3, beta3, lambda3 & - & ) RESULT(ans) + MODULE FUNCTION QuadraturePoint_Hexahedron4(nipsx, nipsy, nipsz, & + quadType1, quadType2, quadType3, refHexahedron, xij, alpha1, beta1, & + lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans) INTEGER(I4B), INTENT(IN) :: nipsx(1) !! order of integrand in x direction INTEGER(I4B), INTENT(IN) :: nipsy(1) @@ -2593,27 +2636,16 @@ MODULE FUNCTION QuadraturePoint_Hexahedron4( & !! order of integrand in z direction INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 !! quadrature point type in x, y, and z direction - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev1 ! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight + !! GaussUltraspherical ! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight + !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft !! GaussJacobiRadauRight CHARACTER(*), INTENT(IN) :: refHexahedron - !! Reference hexahedron - !! UNIT - !! BIUNIT + !! Reference hexahedron ! UNIT ! BIUNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! four vertices of quadrangle in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 @@ -2627,6 +2659,47 @@ MODULE FUNCTION QuadraturePoint_Hexahedron4( & END FUNCTION QuadraturePoint_Hexahedron4 END INTERFACE QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Hexahedron_ + MODULE SUBROUTINE QuadraturePoint_Hexahedron4_(nipsx, nipsy, nipsz, & + quadType1, quadType2, quadType3, refhexahedron, xij, alpha1, beta1, & + lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! Order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! Order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! Order of integrand in z direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3 + !! Quadrature point type in x, y, and z direction + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev1 ! GaussChebyshev1Lobatto + !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight + !! GaussUltraspherical ! GaussUltrasphericalLobatto + !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight + !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft + !! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refhexahedron + !! Reference hexahedron ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi and Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! results + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns + END SUBROUTINE QuadraturePoint_Hexahedron4_ +END INTERFACE QuadraturePoint_Hexahedron_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Hexahedron !---------------------------------------------------------------------------- From ba84884075a617838603f36fb9402adf5d6a8802 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 16:40:41 +0900 Subject: [PATCH 201/359] update in mapping --- src/modules/Utility/src/MappingUtility.F90 | 78 ++++++++++++++++++++++ 1 file changed, 78 insertions(+) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index b78280b83..19b1acced 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -39,6 +39,9 @@ MODULE MappingUtility PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle_ PUBLIC :: FromUnitQuadrangle2BiUnitQuadrangle +PUBLIC :: FromBiUnitHexahedron2Hexahedron_ +PUBLIC :: FromBiUnitHexahedron2UnitHexahedron_ +PUBLIC :: FromUnitHexahedron2BiUnitHexahedron_ PUBLIC :: FromBiUnitHexahedron2Hexahedron PUBLIC :: FromBiUnitHexahedron2UnitHexahedron @@ -394,6 +397,41 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2Hexahedron1(xin, & END FUNCTION FromBiUnitHexahedron2Hexahedron1 END INTERFACE FromBiUnitHexahedron2Hexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE FromBiUnitHexahedron2Hexahedron_ + MODULE PURE SUBROUTINE FromBiUnitHexahedron2Hexahedron1_(xin, x1, x2, x3, & + x4, x5, x6, x7, x8, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Hexahedron in xij format + !! SIZE(xin,1) = 3 + REAL(DFP), INTENT(IN) :: x1(:) + !! vertex x1 of physical domain, size(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! vertex x2 of physical domain, size(x2) = nsd + REAL(DFP), INTENT(IN) :: x3(:) + !! vertex x3 of physical domain, size(x3) = nsd + REAL(DFP), INTENT(IN) :: x4(:) + !! vertex x4 of physical domain, size(x4) = nsd + REAL(DFP), INTENT(IN) :: x5(:) + !! vertex x5 of physical domain, size(x5) = nsd + REAL(DFP), INTENT(IN) :: x6(:) + !! vertex x6 of physical domain, size(x6) = nsd + REAL(DFP), INTENT(IN) :: x7(:) + !! vertex x7 of physical domain, size(x7) = nsd + REAL(DFP), INTENT(IN) :: x8(:) + !! vertex x8 of physical domain, size(x8) = nsd + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x1) + !! ncol = SIZE(xin, 2) + END SUBROUTINE FromBiUnitHexahedron2Hexahedron1_ +END INTERFACE FromBiUnitHexahedron2Hexahedron_ + !---------------------------------------------------------------------------- ! FromBiUnitHexahedron2Hexahedron !---------------------------------------------------------------------------- @@ -414,6 +452,26 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2UnitHexahedron1(xin) & END FUNCTION FromBiUnitHexahedron2UnitHexahedron1 END INTERFACE FromBiUnitHexahedron2UnitHexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE FromBiUnitHexahedron2UnitHexahedron_ + MODULE PURE SUBROUTINE FromBiUnitHexahedron2UnitHexahedron1_(xin, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Hexahedron in xij format + !! SIZE(xin,1) = 3 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + !! nrow = SIZE(xin, 1) + !! ncol = SIZE(xin, 2) + END SUBROUTINE FromBiUnitHexahedron2UnitHexahedron1_ +END INTERFACE FromBiUnitHexahedron2UnitHexahedron_ + !---------------------------------------------------------------------------- ! FromBiUnitHexahedron2Hexahedron !---------------------------------------------------------------------------- @@ -434,6 +492,26 @@ MODULE PURE FUNCTION FromUnitHexahedron2BiUnitHexahedron1(xin) & END FUNCTION FromUnitHexahedron2BiUnitHexahedron1 END INTERFACE FromUnitHexahedron2BiUnitHexahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE FromUnitHexahedron2BiUnitHexahedron_ + + MODULE PURE SUBROUTINE FromUnitHexahedron2BiUnitHexahedron1_(xin, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of biunit Hexahedron in xij format + !! SIZE(xin,1) = 3 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xin, 1) + !! ncol = SIZE(xin, 2) + END SUBROUTINE FromUnitHexahedron2BiUnitHexahedron1_ +END INTERFACE FromUnitHexahedron2BiUnitHexahedron_ + !---------------------------------------------------------------------------- ! FromBiUnitLine2UnitLine !---------------------------------------------------------------------------- From 45b0a8b53355cf8c5a5f7bdd556a540e4b8f04e4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 16:40:46 +0900 Subject: [PATCH 202/359] update in hexahedron --- ...HexahedronInterpolationUtility@Methods.F90 | 300 +++++++----------- 1 file changed, 116 insertions(+), 184 deletions(-) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index 1875eff02..e37ff7b53 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2156,116 +2156,51 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Hexahedron1 -ans = QuadraturePoint_Hexahedron2( & - & p=order, & - & q=order, & - & r=order, & - & quadType1=quadType, & - & quadType2=quadType, & - & quadType3=quadType, & - & refHexahedron=refHexahedron, & - & xij=xij, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda & - & ) -END PROCEDURE QuadraturePoint_Hexahedron1 +INTEGER(I4B) :: nrow, ncol, nips(1) -!---------------------------------------------------------------------------- -! QuadraturePoint_Hexahedron -!---------------------------------------------------------------------------- +nips(1) = QuadratureNumber_Line(quadType=quadType, order=order) -MODULE PROCEDURE QuadraturePoint_Hexahedron2 -! internal variables -REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), z(:, :), temp(:, :) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt -TYPE(String) :: astr - -astr = UpperCase(refHexahedron) +nrow = 4 +ncol = nips(1) * nips(1) * nips(1) -x = QuadraturePoint_Line( & - & order=p, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) -np = SIZE(x, 2) +ALLOCATE (ans(nrow, ncol)) -y = QuadraturePoint_Line( & - & order=q, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) -nq = SIZE(y, 2) +CALL QuadraturePoint_Hexahedron4_(nipsx=nips, nipsy=nips, nipsz=nips, & + quadType1=quadType, quadType2=quadType, quadType3=quadType, & + refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, & + beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Hexahedron1 -z = QuadraturePoint_Line( & - & order=r, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) -nr = SIZE(z, 2) +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -nsd = 3 -CALL Reallocate(ans, 4_I4B, np * nq * nr) -CALL Reallocate(temp, 4_I4B, np * nq * nr) +MODULE PROCEDURE QuadraturePoint_Hexahedron1_ +CALL QuadraturePoint_Hexahedron2_(p=order, q=order, r=order, & + quadType1=quadType, quadType2=quadType, quadType3=quadType, & + refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, & + beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Hexahedron1_ -cnt = 0 -DO ii = 1, np - DO jj = 1, nq - DO kk = 1, nr - cnt = cnt + 1 - temp(1, cnt) = x(1, ii) - temp(2, cnt) = y(1, jj) - temp(3, cnt) = z(1, kk) - temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk) - END DO - END DO -END DO +!---------------------------------------------------------------------------- +! QuadraturePoint_Hexahedron +!---------------------------------------------------------------------------- -IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( & - & xin=temp(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8) & - & ) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="HEXAHEDRON", xij=xij) +MODULE PROCEDURE QuadraturePoint_Hexahedron2 +INTEGER(I4B), DIMENSION(1) :: nipsx, nipsy, nipsz +INTEGER(I4B) :: nrow, ncol -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( & - & xin=temp(1:3, :)) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF -END IF +nipsx(1) = QuadratureNumber_Line(quadType=quadType1, order=p) +nipsy(1) = QuadratureNumber_Line(quadType=quadType2, order=q) +nipsz(1) = QuadratureNumber_Line(quadType=quadType3, order=r) -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(x)) DEALLOCATE (x) -IF (ALLOCATED(y)) DEALLOCATE (y) -IF (ALLOCATED(z)) DEALLOCATE (z) +CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadType1=quadType1, quadType2=quadType2, quadType3=quadType3, & + refHexahedron=refHexahedron, xij=xij, alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + alpha3=alpha3, beta3=beta3, lambda3=lambda3, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Hexahedron2 @@ -2274,25 +2209,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Hexahedron3 -ans = QuadraturePoint_Hexahedron4( & - & nipsx=nips, & - & nipsy=nips, & - & nipsz=nips, & - & quadType1=quadType, & - & quadType2=quadType, & - & quadType3=quadType, & - & refHexahedron=refHexahedron, & - & xij=xij, & - & alpha1=alpha, & - & beta1=beta, & - & lambda1=lambda, & - & alpha2=alpha, & - & beta2=beta, & - & lambda2=lambda, & - & alpha3=alpha, & - & beta3=beta, & - & lambda3=lambda & - & ) +INTEGER(I4B) :: nrow, ncol + +ALLOCATE (ans(nrow, ncol)) + +CALL QuadraturePoint_Hexahedron4_(nipsx=nips, nipsy=nips, nipsz=nips, & + quadType1=quadType, quadType2=quadType, quadType3=quadType, & + refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, & + beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol) + END PROCEDURE QuadraturePoint_Hexahedron3 !---------------------------------------------------------------------------- @@ -2300,87 +2226,93 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Hexahedron4 -! internal variables -REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), z(2, nipsz(1)), & -& temp(4, nipsy(1) * nipsx(1) * nipsz(1)) -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt -TYPE(String) :: astr +INTEGER(I4B) :: nrow, ncol -astr = UpperCase(refHexahedron) +ALLOCATE (ans(nrow, ncol)) -x = QuadraturePoint_Line( & - & nips=nipsx, & - & quadType=quadType1, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) -np = SIZE(x, 2) +CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadType1=quadType1, quadType2=quadType2, quadType3=quadType3, & + refHexahedron=refHexahedron, xij=xij, alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + alpha3=alpha3, beta3=beta3, lambda3=lambda3, ans=ans, nrow=nrow, ncol=ncol) -y = QuadraturePoint_Line( & - & nips=nipsy, & - & quadType=quadType2, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) -nq = SIZE(y, 2) +END PROCEDURE QuadraturePoint_Hexahedron4 -z = QuadraturePoint_Line( & - & nips=nipsz, & - & quadType=quadType3, & - & xij=[-1.0_DFP, 1.0_DFP], & - & layout="INCREASING", & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) -nr = SIZE(z, 2) +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -nsd = 3 -CALL Reallocate(ans, 4_I4B, np * nq * nr) +MODULE PROCEDURE QuadraturePoint_Hexahedron4_ +INTEGER(I4B), PARAMETER :: nsd = 3 + +REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), z(2, nipsz(1)), areal + +INTEGER(I4B) :: ii, jj, kk, cnt + +REAL(DFP), PARAMETER :: x12(1, 2) = RESHAPE([-1.0_DFP, 1.0_DFP], [1, 2]) + +CHARACTER(len=1) :: astr + +nrow = 4 +ncol = nipsx(1) * nipsy(1) * nipsz(1) + +CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadType1, xij=x12, & + layout="INCREASING", alpha=alpha1, beta=beta1, & + lambda=lambda1, ans=x, nrow=ii, ncol=jj) + +CALL QuadraturePoint_Line_(nips=nipsy, quadType=quadType2, xij=x12, & + layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, & + ans=y, nrow=ii, ncol=jj) + +CALL QuadraturePoint_Line_(nips=nipsz, quadType=quadType3, xij=x12, & + layout="INCREASING", alpha=alpha3, beta=beta3, lambda=lambda3, ans=z, & + nrow=ii, ncol=jj) cnt = 0 -DO ii = 1, np - DO jj = 1, nq - DO kk = 1, nr +DO ii = 1, nipsx(1) + DO jj = 1, nipsy(1) + DO kk = 1, nipsz(1) cnt = cnt + 1 - temp(1, cnt) = x(1, ii) - temp(2, cnt) = y(1, jj) - temp(3, cnt) = z(1, kk) - temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk) + ans(1, cnt) = x(1, ii) + ans(2, cnt) = y(1, jj) + ans(3, cnt) = z(1, kk) + ans(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk) END DO END DO END DO IF (PRESENT(xij)) THEN - ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( & - & xin=temp(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8) & - & ) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="HEXAHEDRON", xij=xij) + ! ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( & + CALL FromBiUnitHexahedron2Hexahedron_(xin=ans(1:nsd, 1:ncol), x1=xij(:, 1), & + x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), x5=xij(:, 5), x6=xij(:, 6), & + x7=xij(:, 7), x8=xij(:, 8), ans=ans, nrow=ii, ncol=jj) + + areal = JacobianHexahedron(from="BIUNIT", to="HEXAHEDRON", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN -ELSE - IF (astr%chars() .EQ. "UNIT") THEN - ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( & - & xin=temp(1:3, :)) - ans(4, :) = temp(4, :) * JacobianHexahedron( & - & from="BIUNIT", to="UNIT", xij=xij) - ELSE - ans = temp - END IF END IF -END PROCEDURE QuadraturePoint_Hexahedron4 +astr = UpperCase(refhexahedron(1:1)) + +IF (astr .EQ. "U") THEN + CALL FromBiUnitHexahedron2UnitHexahedron_(xin=ans(1:nsd, 1:ncol), ans=ans, & + nrow=ii, ncol=jj) + + areal = JacobianHexahedron(from="BIUNIT", to="UNIT", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN +END IF + +END PROCEDURE QuadraturePoint_Hexahedron4_ !---------------------------------------------------------------------------- ! LagrangeEvallAll_Hexahedron From c41cca20befb182be3c00996ca8b8330f37987d2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 16:40:53 +0900 Subject: [PATCH 203/359] update in mapping util --- .../Utility/src/MappingUtility@Methods.F90 | 69 ++++++++++++++----- 1 file changed, 50 insertions(+), 19 deletions(-) diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index 0da05da97..58f5cf81c 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -241,11 +241,25 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitHexahedron2Hexahedron1 +INTEGER(I4B) :: nrow, ncol +CALL FromBiUnitHexahedron2Hexahedron1_(xin, x1, x2, x3, x4, x5, x6, x7, x8, & + ans, nrow, ncol) + +END PROCEDURE FromBiUnitHexahedron2Hexahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitHexahedron2Hexahedron1_ INTEGER(I4B) :: ii REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP -DO ii = 1, SIZE(ans, 2) +nrow = SIZE(x1) +ncol = SIZE(xin, 2) + +DO ii = 1, ncol xi = xin(1, ii) eta = xin(2, ii) zeta = xin(3, ii) @@ -257,35 +271,48 @@ p6 = p125 * (one + xi) * (one - eta) * (one + zeta) p7 = p125 * (one + xi) * (one + eta) * (one + zeta) p8 = p125 * (one - xi) * (one + eta) * (one + zeta) - ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 + & - & x5 * p5 + x6 * p6 + x7 * p7 + x8 * p8 + ans(1:nrow, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 + & + x5 * p5 + x6 * p6 + x7 * p7 + x8 * p8 END DO -END PROCEDURE FromBiUnitHexahedron2Hexahedron1 +END PROCEDURE FromBiUnitHexahedron2Hexahedron1_ !---------------------------------------------------------------------------- ! FromBiUnitHexahedron2UnitHexahedron !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitHexahedron2UnitHexahedron1 +INTEGER(I4B) :: nrow, ncol +CALL FromBiUnitHexahedron2UnitHexahedron1_(xin, ans, nrow, ncol) +END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitHexahedron2UnitHexahedron1_ REAL(DFP) :: xij(3, 8) + xij = RefCoord_Hexahedron(refHexahedron="UNIT") -ans = FromBiUnitHexahedron2Hexahedron(& - & xin=xin, & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4), & - & x5=xij(:, 5), & - & x6=xij(:, 6), & - & x7=xij(:, 7), & - & x8=xij(:, 8)) -END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1 + +CALL FromBiUnitHexahedron2Hexahedron_(xin=xin, x1=xij(:, 1), x2=xij(:, 2), & + x3=xij(:, 3), x4=xij(:, 4), x5=xij(:, 5), x6=xij(:, 6), x7=xij(:, 7), & + x8=xij(:, 8), ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1_ !---------------------------------------------------------------------------- ! FromBiUnitHexahedron2Hexahedron !---------------------------------------------------------------------------- MODULE PROCEDURE FromUnitHexahedron2BiUnitHexahedron1 +INTEGER(I4B) :: nrow, ncol +CALL FromUnitHexahedron2BiUnitHexahedron1_(xin, ans, nrow, ncol) +END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitHexahedron2BiUnitHexahedron1_ INTEGER(I4B) :: ii REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP @@ -293,7 +320,10 @@ x = RefCoord_Hexahedron(refHexahedron="BIUNIT") -DO ii = 1, SIZE(ans, 2) +nrow = SIZE(xin, 1) +ncol = SIZE(xin, 2) + +DO ii = 1, ncol xi = xin(1, ii) eta = xin(2, ii) zeta = xin(3, ii) @@ -305,10 +335,11 @@ p6 = (xi) * (one - eta) * (zeta) p7 = (xi) * (eta) * (zeta) p8 = (one - xi) * (eta) * (zeta) - ans(:, ii) = x(:, 1) * p1 + x(:, 2) * p2 + x(:, 3) * p3 + x(:, 4) * p4 + & - & x(:, 5) * p5 + x(:, 6) * p6 + x(:, 7) * p7 + x(:, 8) * p8 + ans(1:nrow, ii) = x(1:nrow, 1) * p1 + x(1:nrow, 2) * p2 + x(1:nrow, 3) * p3 & + + x(1:nrow, 4) * p4 + x(1:nrow, 5) * p5 + x(1:nrow, 6) * p6 & + + x(1:nrow, 7) * p7 + x(1:nrow, 8) * p8 END DO -END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1 +END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1_ !---------------------------------------------------------------------------- ! FromTriangle2Square_ From a7da2988bc11b71bb1fbb46e3f9cf13848dbb47b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 16:43:04 +0900 Subject: [PATCH 204/359] update in hexahedron --- .../src/HexahedronInterpolationUtility@Methods.F90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index e37ff7b53..d71ed58e9 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2196,6 +2196,11 @@ nipsy(1) = QuadratureNumber_Line(quadType=quadType2, order=q) nipsz(1) = QuadratureNumber_Line(quadType=quadType3, order=r) +nrow = 4 +ncol = nipsx(1) * nipsy(1) * nipsz(1) + +ALLOCATE (ans(nrow, ncol)) + CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & quadType1=quadType1, quadType2=quadType2, quadType3=quadType3, & refHexahedron=refHexahedron, xij=xij, alpha1=alpha1, beta1=beta1, & @@ -2211,6 +2216,9 @@ MODULE PROCEDURE QuadraturePoint_Hexahedron3 INTEGER(I4B) :: nrow, ncol +nrow = 4 +ncol = nips(1) * nips(1) * nips(1) + ALLOCATE (ans(nrow, ncol)) CALL QuadraturePoint_Hexahedron4_(nipsx=nips, nipsy=nips, nipsz=nips, & @@ -2228,6 +2236,9 @@ MODULE PROCEDURE QuadraturePoint_Hexahedron4 INTEGER(I4B) :: nrow, ncol +nrow = 4 +ncol = nipsx(1) * nipsy(1) * nipsz(1) + ALLOCATE (ans(nrow, ncol)) CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & From 4f32ae156ee21c9dd7d95a8d3491dd3adf38b662 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 19:57:32 +0900 Subject: [PATCH 205/359] update in tetrahedron --- .../src/TetrahedronInterpolationUtility.F90 | 114 ++++++++++++++++++ 1 file changed, 114 insertions(+) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index b346d50c1..317a25e35 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -2340,6 +2340,33 @@ MODULE FUNCTION QuadraturePoint_Tetrahedron1(& END FUNCTION QuadraturePoint_Tetrahedron1 END INTERFACE QuadraturePoint_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Tetrahedron_ + MODULE SUBROUTINE QuadraturePoint_Tetrahedron1_(order, quadType, & + refTetrahedron, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + !! If xij is present then this argument is ignored + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3. + !! The number of columns in xij should be 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE QuadraturePoint_Tetrahedron1_ +END INTERFACE QuadraturePoint_Tetrahedron_ + !---------------------------------------------------------------------------- ! QuadraturePoints_Tetrahedron !---------------------------------------------------------------------------- @@ -2376,6 +2403,37 @@ MODULE FUNCTION QuadraturePoint_Tetrahedron2(& END FUNCTION QuadraturePoint_Tetrahedron2 END INTERFACE QuadraturePoint_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Tetrahedron_ + MODULE SUBROUTINE QuadraturePoint_Tetrahedron2_(nips, quadType, & + refTetrahedron, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! nips(1) .LE. 79, then we call + !! economical quadrature rules. + !! Otherwise, this routine will retport + !! error + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type, + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + !! If xij is present then this argument is ignored + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows ans columns + END SUBROUTINE QuadraturePoint_Tetrahedron2_ +END INTERFACE QuadraturePoint_Tetrahedron_ + !---------------------------------------------------------------------------- ! TensorQuadraturePoints_Tetrahedron !---------------------------------------------------------------------------- @@ -2405,6 +2463,32 @@ MODULE FUNCTION TensorQuadraturePoint_Tetrahedron1(order, quadType, & END FUNCTION TensorQuadraturePoint_Tetrahedron1 END INTERFACE TensorQuadraturePoint_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE TensorQuadraturePoint_Tetrahedron_ + MODULE SUBROUTINE TensorQuadraturePoint_Tetrahedron1_(order, quadType, & + refTetrahedron, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij can be 4. + !! The number of columns in xij should be 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE TensorQuadraturePoint_Tetrahedron1_ +END INTERFACE TensorQuadraturePoint_Tetrahedron_ + !---------------------------------------------------------------------------- ! TensorQuadraturePoints_Tetrahedron !---------------------------------------------------------------------------- @@ -2443,6 +2527,36 @@ MODULE FUNCTION TensorQuadraturePoint_Tetrahedron2( & END FUNCTION TensorQuadraturePoint_Tetrahedron2 END INTERFACE TensorQuadraturePoint_Tetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE TensorQuadraturePoint_Tetrahedron_ + MODULE SUBROUTINE TensorQuadraturePoint_Tetrahedron2_(nipsx, nipsy, & + nipsz, quadType, refTetrahedron, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! number of integration points in z direction + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! Reference triangle + !! BIUNIT + !! UNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! nodal coordinates of triangle. + !! The number of rows in xij should be 3 + !! The number of columns in xij should be 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Quadrature points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE TensorQuadraturePoint_Tetrahedron2_ +END INTERFACE TensorQuadraturePoint_Tetrahedron_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Tetrahedron !---------------------------------------------------------------------------- From 248b1ce96d097ca8a075a107e78f440bf3f3fdfb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 19:57:37 +0900 Subject: [PATCH 206/359] update in mapping --- src/modules/Utility/src/MappingUtility.F90 | 71 ++++++++++++++++++++++ 1 file changed, 71 insertions(+) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 19b1acced..050034abe 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -80,6 +80,8 @@ MODULE MappingUtility PUBLIC :: FromTriangle2Triangle_ PUBLIC :: FromUnitTetrahedron2BiUnitTetrahedron +PUBLIC :: FromUnitTetrahedron2BiUnitTetrahedron_ + PUBLIC :: FromBiUnitTetrahedron2UnitTetrahedron PUBLIC :: FromUnitTetrahedron2Tetrahedron PUBLIC :: FromUnitTetrahedron2Tetrahedron_ @@ -91,9 +93,14 @@ MODULE MappingUtility PUBLIC :: BarycentricCoordTetrahedron PUBLIC :: BarycentricCoordTetrahedron_ PUBLIC :: FromBiUnitTetrahedron2BiUnitHexahedron + PUBLIC :: FromBiUnitHexahedron2BiUnitTetrahedron +PUBLIC :: FromBiUnitHexahedron2BiUnitTetrahedron_ + PUBLIC :: FromUnitTetrahedron2BiUnitHexahedron + PUBLIC :: FromBiUnitHexahedron2UnitTetrahedron +PUBLIC :: FromBiUnitHexahedron2UnitTetrahedron_ PUBLIC :: JacobianLine PUBLIC :: JacobianTriangle @@ -864,8 +871,23 @@ MODULE PURE FUNCTION FromBiUnitTetrahedron2UnitTetrahedron(xin) RESULT(ans) END FUNCTION FromBiUnitTetrahedron2UnitTetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE FromBiUnitTetrahedron2UnitTetrahedron_(xin, & + ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + ! REAL(DFP) :: ans(3, SIZE(xin, 2)) + END SUBROUTINE FromBiUnitTetrahedron2UnitTetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! FromUnitTetrahedron2BiUnitTetrahedron + !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -879,6 +901,20 @@ MODULE PURE FUNCTION FromUnitTetrahedron2BiUnitTetrahedron(xin) RESULT(ans) END FUNCTION FromUnitTetrahedron2BiUnitTetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE FromUnitTetrahedron2BiUnitTetrahedron_(xin, & + ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + ! REAL(DFP) :: ans(3, SIZE(xin, 2)) + END SUBROUTINE FromUnitTetrahedron2BiUnitTetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! FromBiUnitTetrahedron2Tetrahedron !---------------------------------------------------------------------------- @@ -1079,6 +1115,22 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron(xin) RESULT(ans) END FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE FromBiUnitHexahedron2BiUnitTetrahedron_(xin, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit hexahedron in xij coordinate + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + ! REAL(DFP) :: ans(3, SIZE(xin, 2)) + !! coordinates in biunit tetrahedron + END SUBROUTINE FromBiUnitHexahedron2BiUnitTetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! FromUnitTetrahedron2BiUnitHexahedron !---------------------------------------------------------------------------- @@ -1113,6 +1165,25 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2UnitTetrahedron(xin) RESULT(ans) END FUNCTION FromBiUnitHexahedron2UnitTetrahedron END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + + MODULE PURE SUBROUTINE FromBiUnitHexahedron2UnitTetrahedron_(xin, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in biunit hexahedron in xij coordinate + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = 3 + !! ncol = SIZE(xin, 2) + !! coordinates in unit tetrahedron + END SUBROUTINE FromBiUnitHexahedron2UnitTetrahedron_ +END INTERFACE + !---------------------------------------------------------------------------- ! JacobianLine !---------------------------------------------------------------------------- From 46a49741b314605654f70366111dc0174425ab30 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 19:57:47 +0900 Subject: [PATCH 207/359] update in tetrahdedron quad --- .../src/include/Tetrahedron/order1.F90 | 14 + .../src/include/Tetrahedron/order10.F90 | 10 + .../src/include/Tetrahedron/order11.F90 | 137 +++ .../src/include/Tetrahedron/order12.F90 | 10 + .../src/include/Tetrahedron/order13.F90 | 221 ++++ .../src/include/Tetrahedron/order14.F90 | 10 + .../src/include/Tetrahedron/order15.F90 | 341 ++++++ .../src/include/Tetrahedron/order16.F90 | 10 + .../src/include/Tetrahedron/order17.F90 | 508 +++++++++ .../src/include/Tetrahedron/order18.F90 | 10 + .../src/include/Tetrahedron/order19.F90 | 726 ++++++++++++ .../src/include/Tetrahedron/order2.F90 | 28 + .../src/include/Tetrahedron/order20.F90 | 10 + .../src/include/Tetrahedron/order21.F90 | 1012 +++++++++++++++++ .../src/include/Tetrahedron/order3.F90 | 25 + .../src/include/Tetrahedron/order4.F90 | 22 + .../src/include/Tetrahedron/order5.F90 | 24 + .../src/include/Tetrahedron/order6.F90 | 36 + .../src/include/Tetrahedron/order7.F90 | 43 + .../src/include/Tetrahedron/order8.F90 | 55 + .../src/include/Tetrahedron/order9.F90 | 64 ++ 21 files changed, 3316 insertions(+) create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 create mode 100644 src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 new file mode 100644 index 000000000..c787dfffe --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 @@ -0,0 +1,14 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order1(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + nrow = 4 + ncol = 1 + + ans(1, 1) = 0.250000000000000 + ans(2, 1) = 0.250000000000000 + ans(3, 1) = 0.250000000000000 + ans(4, 1) = 0.166666666666667 + +END SUBROUTINE QP_Tetrahedron_Order1 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 new file mode 100644 index 000000000..a82c7d727 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 @@ -0,0 +1,10 @@ +PURE SUBROUTINE QP_Tetrahedron_Order10(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 126) + nrow = 4; ncol = 126 + + CALL QP_Tetrahedron_Order11(ans, nrow, ncol) + +END SUBROUTINE QP_Tetrahedron_Order10 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 new file mode 100644 index 000000000..95106d811 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 @@ -0,0 +1,137 @@ +PURE subroutine QP_Tetrahedron_Order11(ans, nrow, ncol) + real(DFP), intent(INOUT) :: ans(:, :) + integer(I4B), intent(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 126) + nrow=4;ncol= 126 + + ans = RESHAPE([ & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.4062316284e-05 & + & ], [4, 126]) + +END subroutine QP_Tetrahedron_Order11 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 new file mode 100644 index 000000000..2f5998ce2 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 @@ -0,0 +1,10 @@ +PURE SUBROUTINE QP_Tetrahedron_Order12(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 210) + nrow = 4; ncol = 210 + + CALL QP_Tetrahedron_Order13(ans, nrow, ncol) + +END SUBROUTINE QP_Tetrahedron_Order12 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 new file mode 100644 index 000000000..3a6672b0d --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 @@ -0,0 +1,221 @@ +PURE subroutine QP_Tetrahedron_Order13(ans, nrow, ncol) + real(DFP), intent(INOUT) :: ans(:, :) + integer(I4B), intent(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 210) + nrow=4;ncol= 210 + + ans = RESHAPE([ & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 & + & ], [4, 210]) + +ENDsubroutine diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 new file mode 100644 index 000000000..5bb9d74c3 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 @@ -0,0 +1,10 @@ +PURE SUBROUTINE QP_Tetrahedron_Order14(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 330) + nrow = 4; ncol = 330 + + CALL QP_Tetrahedron_Order15(ans, nrow, ncol) + +END SUBROUTINE diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 new file mode 100644 index 000000000..608700781 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 @@ -0,0 +1,341 @@ +PURE subroutine QP_Tetrahedron_Order15(ans, nrow, ncol) + real(DFP), intent(INOUT) :: ans(:, :) + integer(I4B), intent(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 330) + nrow=4;ncol= 330 + + ans = RESHAPE([ & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 & + & ], [4, 330]) + +END subroutine QP_Tetrahedron_Order15 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 new file mode 100644 index 000000000..dcbf7801d --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 @@ -0,0 +1,10 @@ +PURE SUBROUTINE QP_Tetrahedron_Order16(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 495) + nrow = 4; ncol = 495 + + CALL QP_Tetrahedron_Order17(ans, nrow, ncol) + +END SUBROUTINE QP_Tetrahedron_Order16 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 new file mode 100644 index 000000000..45a6e7bf5 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 @@ -0,0 +1,508 @@ +PURE subroutine QP_Tetrahedron_Order17(ans, nrow, ncol) + real(DFP), intent(INOUT) :: ans(:, :) + integer(I4B), intent(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 495) + nrow=4;ncol= 495 + + ans = RESHAPE([ & + & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3573205875e-08 & + & ], [4, 495]) + +END subroutine QP_Tetrahedron_Order17 + + diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 new file mode 100644 index 000000000..874e97f62 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 @@ -0,0 +1,10 @@ +PURE SUBROUTINE QP_Tetrahedron_Order18(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 715) + nrow = 4; ncol = 715 + + CALL QP_Tetrahedron_Order19(ans, nrow, ncol) + +END SUBROUTINE QP_Tetrahedron_Order18 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 new file mode 100644 index 000000000..156d62dbd --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 @@ -0,0 +1,726 @@ +PURE subroutine QP_Tetrahedron_Order19(ans, nrow, ncol) + real(DFP), intent(INOUT) :: ans(:, :) + integer(I4B), intent(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 715) + nrow=4;ncol= 715 + + ans = RESHAPE([ & + & 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & + & 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & + & 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & + & 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 & + & ], [4, 715]) + +END subroutine QP_Tetrahedron_Order19 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 new file mode 100644 index 000000000..7482d5c7c --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 @@ -0,0 +1,28 @@ +PURE SUBROUTINE QP_Tetrahedron_Order2(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + nrow = 4 + ncol = 4 + + ans(1, 1) = 0.585410196624969 + ans(2, 1) = 0.138196601125011 + ans(3, 1) = 0.138196601125011 + ans(4, 1) = 0.041666666666667 + + ans(1, 2) = 0.138196601125011 + ans(2, 2) = 0.138196601125011 + ans(3, 2) = 0.138196601125011 + ans(4, 2) = 0.041666666666667 + + ans(1, 3) = 0.138196601125011 + ans(2, 3) = 0.138196601125011 + ans(3, 3) = 0.585410196624969 + ans(4, 3) = 0.041666666666667 + + ans(1, 4) = 0.138196601125011 + ans(2, 4) = 0.585410196624969 + ans(3, 4) = 0.138196601125011 + ans(4, 4) = 0.041666666666667 + +END SUBROUTINE QP_Tetrahedron_Order2 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 new file mode 100644 index 000000000..a3655aa76 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 @@ -0,0 +1,10 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order20(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 1001) + nrow = 4; ncol = 1001 + + CALL QP_Tetrahedron_Order21(ans, nrow, ncol) +END SUBROUTINE QP_Tetrahedron_Order20 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 new file mode 100644 index 000000000..b1daf12b7 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 @@ -0,0 +1,1012 @@ +PURE subroutine QP_Tetrahedron_Order21(ans, nrow, ncol) + real(DFP), intent(INOUT) :: ans(:, :) + integer(I4B), intent(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 1001) + nrow=4;ncol= 1001 + + ans = RESHAPE([ & + & 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & + & 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & + & 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & + & 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & + & 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & + & 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & + & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & + & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & + & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & + & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & + & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & + & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & + & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & + & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & + & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & + & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & + & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333, & + & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & + & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & + & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & + & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & + & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & + & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & + & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & + & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & + & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & + & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & + & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550, & + & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550, & + & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & + & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & + & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & + & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & + & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & + & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & + & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & + & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & + & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & + & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & + & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & + & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & + & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & + & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & + & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & + & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & + & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08, & + & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08, & + & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & + & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & + & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 & + & ], [4, 1001]) + +END subroutine QP_Tetrahedron_Order21 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 new file mode 100644 index 000000000..c6da40c22 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 @@ -0,0 +1,25 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order3(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + ! ans(4, 5) + + nrow = 4; ncol = 5 + + ans(1, 1) = 0.250000000000000 + ans(2, 1) = 0.250000000000000 + ans(3, 1) = 0.250000000000000 + ans(4, 1) = -0.133333333333333 + + ans(1, 2) = 0.500000000000000 + ans(2, 2) = 0.166666666666667 + ans(3, 2) = 0.166666666666667 + ans(4, 2) = 0.075000000000000 + + ans(1:nrow, 3) = [0.166666666666667, 0.166666666666667, 0.166666666666667, 0.075000000000000 ] + + ans(1:nrow, 4) = [0.166666666666667, 0.166666666666667, 0.500000000000000, 0.075000000000000 ] + + ans(1:nrow, 5) = [0.166666666666667, 0.500000000000000, 0.166666666666667, 0.075000000000000 ] + +END SUBROUTINE QP_Tetrahedron_Order3 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 new file mode 100644 index 000000000..8157b586d --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 @@ -0,0 +1,22 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order4(ans, nrow, ncol) + REAL(DFP), INTENT(inout) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 11) + nrow = 4; ncol = 11 + + ans = RESHAPE([ & + & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555, & + & 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222, & + & 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222, & + & 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222, & + & 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222, & + & 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888, & + & 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888, & + & 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888, & + & 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888, & + & 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888, & + & 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 & + & ], [4, 11]) +END SUBROUTINE QP_Tetrahedron_Order4 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 new file mode 100644 index 000000000..7e674928a --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 @@ -0,0 +1,24 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order5(ans, nrow, ncol) + REAL(DFP), INTENT(inout) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + nrow = 4; ncol = 14 + + ans = RESHAPE([ & + & 0.0927352503109, 0.0927352503109, 0.0927352503109, 0.01224884051940, & + & 0.7217942490670, 0.0927352503109, 0.0927352503109, 0.01224884051940, & + & 0.0927352503109, 0.7217942490670, 0.0927352503109, 0.01224884051940, & + & 0.0927352503109, 0.0927352503109, 0.7217942490670, 0.01224884051940, & + & 0.3108859192630, 0.3108859192630, 0.3108859192630, 0.01878132095300, & + & 0.0673422422101, 0.3108859192630, 0.3108859192630, 0.01878132095300, & + & 0.3108859192630, 0.0673422422101, 0.3108859192630, 0.01878132095300, & + & 0.3108859192630, 0.3108859192630, 0.0673422422101, 0.01878132095300, & + & 0.4544962958740, 0.4544962958740, 0.0455037041256, 0.00709100346285, & + & 0.4544962958740, 0.0455037041256, 0.4544962958740, 0.00709100346285, & + & 0.0455037041256, 0.4544962958740, 0.4544962958740, 0.00709100346285, & + & 0.4544962958740, 0.0455037041256, 0.0455037041256, 0.00709100346285, & + & 0.0455037041256, 0.4544962958740, 0.0455037041256, 0.00709100346285, & + & 0.0455037041256, 0.0455037041256, 0.4544962958740, 0.00709100346285 & + & ], [4, 14]) +END SUBROUTINE QP_Tetrahedron_Order5 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 new file mode 100644 index 000000000..288f12e5c --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 @@ -0,0 +1,36 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order6(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 24) + nrow = 4; ncol = 24 + + ans = RESHAPE([ & + & 0.2146028712590, 0.2146028712590, 0.2146028712590, 0.006653791709700, & + & 0.3561913862230, 0.2146028712590, 0.2146028712590, 0.006653791709700, & + & 0.2146028712590, 0.3561913862230, 0.2146028712590, 0.006653791709700, & + & 0.2146028712590, 0.2146028712590, 0.3561913862230, 0.006653791709700, & + & 0.0406739585346, 0.0406739585346, 0.0406739585346, 0.001679535175883, & + & 0.8779781243960, 0.0406739585346, 0.0406739585346, 0.001679535175883, & + & 0.0406739585346, 0.8779781243960, 0.0406739585346, 0.001679535175883, & + & 0.0406739585346, 0.0406739585346, 0.8779781243960, 0.001679535175883, & + & 0.3223378901420, 0.3223378901420, 0.3223378901420, 0.009226196923950, & + & 0.0329863295732, 0.3223378901420, 0.3223378901420, 0.009226196923950, & + & 0.3223378901420, 0.0329863295732, 0.3223378901420, 0.009226196923950, & + & 0.3223378901420, 0.3223378901420, 0.0329863295732, 0.009226196923950, & + & 0.0636610018750, 0.0636610018750, 0.2696723314580, 0.008035714285717, & + & 0.0636610018750, 0.2696723314580, 0.0636610018750, 0.008035714285717, & + & 0.0636610018750, 0.0636610018750, 0.6030056647920, 0.008035714285717, & + & 0.0636610018750, 0.6030056647920, 0.0636610018750, 0.008035714285717, & + & 0.0636610018750, 0.2696723314580, 0.6030056647920, 0.008035714285717, & + & 0.0636610018750, 0.6030056647920, 0.2696723314580, 0.008035714285717, & + & 0.2696723314580, 0.0636610018750, 0.0636610018750, 0.008035714285717, & + & 0.2696723314580, 0.0636610018750, 0.6030056647920, 0.008035714285717, & + & 0.2696723314580, 0.6030056647920, 0.0636610018750, 0.008035714285717, & + & 0.6030056647920, 0.0636610018750, 0.2696723314580, 0.008035714285717, & + & 0.6030056647920, 0.0636610018750, 0.0636610018750, 0.008035714285717, & + & 0.6030056647920, 0.2696723314580, 0.0636610018750, 0.008035714285717 & + & ], [4, 24]) + +END SUBROUTINE QP_Tetrahedron_Order6 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 new file mode 100644 index 000000000..92ae76869 --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 @@ -0,0 +1,43 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order7(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 31) + nrow = 4; ncol = 31 + + ans = RESHAPE([ & + & 0.50000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685, & + & 0.50000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685, & + & 0.00000000000000, 0.50000000000000, 0.50000000000000, +0.000970017636685, & + & 0.00000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685, & + & 0.00000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685, & + & 0.50000000000000, 0.00000000000000, 0.00000000000000, +0.000970017636685, & + & 0.25000000000000, 0.25000000000000, 0.25000000000000, +0.018264223466167, & + & 0.07821319233030, 0.07821319233030, 0.07821319233030, +0.010599941524417, & + & 0.07821319233030, 0.07821319233030, 0.76536042300900, +0.010599941524417, & + & 0.07821319233030, 0.76536042300900, 0.07821319233030, +0.010599941524417, & + & 0.76536042300900, 0.07821319233030, 0.07821319233030, +0.010599941524417, & + & 0.12184321666400, 0.12184321666400, 0.12184321666400, -0.062517740114333, & + & 0.12184321666400, 0.12184321666400, 0.63447035000800, -0.062517740114333, & + & 0.12184321666400, 0.63447035000800, 0.12184321666400, -0.062517740114333, & + & 0.63447035000800, 0.12184321666400, 0.12184321666400, -0.062517740114333, & + & 0.33253916444600, 0.33253916444600, 0.33253916444600, +0.004891425263067, & + & 0.33253916444600, 0.33253916444600, 0.00238250666074, +0.004891425263067, & + & 0.33253916444600, 0.00238250666074, 0.33253916444600, +0.004891425263067, & + & 0.00238250666074, 0.33253916444600, 0.33253916444600, +0.004891425263067, & + & 0.10000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000, & + & 0.10000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000, & + & 0.10000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000, & + & 0.10000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000, & + & 0.10000000000000, 0.20000000000000, 0.60000000000000, +0.027557319224000, & + & 0.10000000000000, 0.60000000000000, 0.20000000000000, +0.027557319224000, & + & 0.20000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000, & + & 0.20000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000, & + & 0.20000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000, & + & 0.60000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000, & + & 0.60000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000, & + & 0.60000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000 & + & ], [4, 31]) + +END SUBROUTINE QP_Tetrahedron_Order7 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 new file mode 100644 index 000000000..1d14bf6ab --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 @@ -0,0 +1,55 @@ + +PURE SUBROUTINE QP_Tetrahedron_Order8(ans, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 43) + nrow = 4; ncol = 43 + + ans = RESHAPE([ & + & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.020500188658667, & + & 0.2068299316110, 0.2068299316110, 0.2068299316110, +0.014250305822867, & + & 0.2068299316110, 0.2068299316110, 0.3795102051680, +0.014250305822867, & + & 0.2068299316110, 0.3795102051680, 0.2068299316110, +0.014250305822867, & + & 0.3795102051680, 0.2068299316110, 0.2068299316110, +0.014250305822867, & + & 0.0821035883105, 0.0821035883105, 0.0821035883105, +0.001967033313133, & + & 0.0821035883105, 0.0821035883105, 0.7536892350680, +0.001967033313133, & + & 0.0821035883105, 0.7536892350680, 0.0821035883105, +0.001967033313133, & + & 0.7536892350680, 0.0821035883105, 0.0821035883105, +0.001967033313133, & + & 0.0057819505052, 0.0057819505052, 0.0057819505052, +0.000169834109093, & + & 0.0057819505052, 0.0057819505052, 0.9826541484840, +0.000169834109093, & + & 0.0057819505052, 0.9826541484840, 0.0057819505052, +0.000169834109093, & + & 0.9826541484840, 0.0057819505052, 0.0057819505052, +0.000169834109093, & + & 0.0505327400189, 0.0505327400189, 0.4494672599810, +0.004579683824467, & + & 0.0505327400189, 0.4494672599810, 0.0505327400189, +0.004579683824467, & + & 0.4494672599810, 0.0505327400189, 0.0505327400189, +0.004579683824467, & + & 0.0505327400189, 0.4494672599810, 0.4494672599810, +0.004579683824467, & + & 0.4494672599810, 0.0505327400189, 0.4494672599810, +0.004579683824467, & + & 0.4494672599810, 0.4494672599810, 0.0505327400189, +0.004579683824467, & + & 0.2290665361170, 0.2290665361170, 0.0356395827885, +0.005704485808683, & + & 0.2290665361170, 0.0356395827885, 0.2290665361170, +0.005704485808683, & + & 0.2290665361170, 0.2290665361170, 0.5062273449780, +0.005704485808683, & + & 0.2290665361170, 0.5062273449780, 0.2290665361170, +0.005704485808683, & + & 0.2290665361170, 0.0356395827885, 0.5062273449780, +0.005704485808683, & + & 0.2290665361170, 0.5062273449780, 0.0356395827885, +0.005704485808683, & + & 0.0356395827885, 0.2290665361170, 0.2290665361170, +0.005704485808683, & + & 0.0356395827885, 0.2290665361170, 0.5062273449780, +0.005704485808683, & + & 0.0356395827885, 0.5062273449780, 0.2290665361170, +0.005704485808683, & + & 0.5062273449780, 0.2290665361170, 0.0356395827885, +0.005704485808683, & + & 0.5062273449780, 0.2290665361170, 0.2290665361170, +0.005704485808683, & + & 0.5062273449780, 0.0356395827885, 0.2290665361170, +0.005704485808683, & + & 0.0366077495532, 0.0366077495532, 0.1904860419350, +0.002140519141167, & + & 0.0366077495532, 0.1904860419350, 0.0366077495532, +0.002140519141167, & + & 0.0366077495532, 0.0366077495532, 0.7362984589590, +0.002140519141167, & + & 0.0366077495532, 0.7362984589590, 0.0366077495532, +0.002140519141167, & + & 0.0366077495532, 0.1904860419350, 0.7362984589590, +0.002140519141167, & + & 0.0366077495532, 0.7362984589590, 0.1904860419350, +0.002140519141167, & + & 0.1904860419350, 0.0366077495532, 0.0366077495532, +0.002140519141167, & + & 0.1904860419350, 0.0366077495532, 0.7362984589590, +0.002140519141167, & + & 0.1904860419350, 0.7362984589590, 0.0366077495532, +0.002140519141167, & + & 0.7362984589590, 0.0366077495532, 0.1904860419350, +0.002140519141167, & + & 0.7362984589590, 0.0366077495532, 0.0366077495532, +0.002140519141167, & + & 0.7362984589590, 0.1904860419350, 0.0366077495532, +0.002140519141167 & + & ], [4, 43]) + +END SUBROUTINE QP_Tetrahedron_Order8 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 new file mode 100644 index 000000000..68eda66ae --- /dev/null +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 @@ -0,0 +1,64 @@ +PURE subroutine QP_Tetrahedron_Order9(ans, nrow, ncol) + real(DFP), intent(INOUT) :: ans(:, :) + integer(I4B), intent(OUT) :: nrow, ncol + + !! REAL(DFP) :: ans(4, 53) + nrow=4;ncol= 53 + + ans = RESHAPE([ & + & +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167, & + & +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & + & +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083, & + & +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083, & + & +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & + & +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & + & +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500, & + & +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500, & + & +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & + & +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & + & +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167, & + & +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167, & + & +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & + & +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & + & +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500, & + & +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500, & + & +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & + & +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & + & +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & + & +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & + & +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & + & +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500, & + & +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500, & + & +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & + & +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & + & +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & + & +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & + & +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & + & +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & + & +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & + & +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & + & +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & + & +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & + & +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667, & + & +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667, & + & +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & + & +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & + & +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & + & +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & + & +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & + & +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & + & -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & + & -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557, & + & -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & + & -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & + & -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557, & + & -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557, & + & +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & + & +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & + & +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & + & +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & + & +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & + & +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 & + & ], [4, 53]) + +END subroutine QP_Tetrahedron_Order9 From 1822f082ea52fc272b1d03d79f9d8cec69f13573 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 19:57:56 +0900 Subject: [PATCH 208/359] update in quadrature point --- .../src/QuadraturePoint_Tetrahedron_Solin.F90 | 3362 +---------------- 1 file changed, 63 insertions(+), 3299 deletions(-) diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 index 810e3c6cb..b1fe4e11e 100644 --- a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 +++ b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 @@ -17,17 +17,21 @@ MODULE QuadraturePoint_Tetrahedron_Solin USE GlobalData, ONLY: DFP, I4B, LGT + IMPLICIT NONE -PRIVATE + +PRIVATE + PUBLIC :: QuadraturePointTetrahedronSolin PUBLIC :: QuadratureOrderTetrahedronSolin PUBLIC :: QuadratureNumberTetrahedronSolin -INTEGER( I4B ), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN=21 - -CONTAINS + +INTEGER(I4B), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN = 21 + +CONTAINS !---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans) @@ -69,7 +73,7 @@ PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans) END FUNCTION QuadratureOrderTetrahedronSolin !---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans) @@ -123,3327 +127,87 @@ PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans) END FUNCTION QuadratureNumberTetrahedronSolin !---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- - -PURE FUNCTION QuadraturePointTetrahedronSolin(order) RESULT(ans) - REAL(DFP), ALLOCATABLE :: ans(:, :) + +PURE SUBROUTINE QuadraturePointTetrahedronSolin(order, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + SELECT CASE (order) CASE (0, 1) - ans = QP_Tetrahedron_Order1() + CALL QP_Tetrahedron_Order1(ans=ans, nrow=nrow, ncol=ncol) CASE (2) - ans = QP_Tetrahedron_Order2() + CALL QP_Tetrahedron_Order2(ans=ans, nrow=nrow, ncol=ncol) CASE (3) - ans = QP_Tetrahedron_Order3() + CALL QP_Tetrahedron_Order3(ans=ans, nrow=nrow, ncol=ncol) CASE (4) - ans = QP_Tetrahedron_Order4() + CALL QP_Tetrahedron_Order4(ans=ans, nrow=nrow, ncol=ncol) CASE (5) - ans = QP_Tetrahedron_Order5() + CALL QP_Tetrahedron_Order5(ans=ans, nrow=nrow, ncol=ncol) CASE (6) - ans = QP_Tetrahedron_Order6() + CALL QP_Tetrahedron_Order6(ans=ans, nrow=nrow, ncol=ncol) CASE (7) - ans = QP_Tetrahedron_Order7() + CALL QP_Tetrahedron_Order7(ans=ans, nrow=nrow, ncol=ncol) CASE (8) - ans = QP_Tetrahedron_Order8() + CALL QP_Tetrahedron_Order8(ans=ans, nrow=nrow, ncol=ncol) CASE (9) - ans = QP_Tetrahedron_Order9() + CALL QP_Tetrahedron_Order9(ans=ans, nrow=nrow, ncol=ncol) CASE (10) - ans = QP_Tetrahedron_Order10() + CALL QP_Tetrahedron_Order10(ans=ans, nrow=nrow, ncol=ncol) CASE (11) - ans = QP_Tetrahedron_Order11() + CALL QP_Tetrahedron_Order11(ans=ans, nrow=nrow, ncol=ncol) CASE (12) - ans = QP_Tetrahedron_Order12() + CALL QP_Tetrahedron_Order12(ans=ans, nrow=nrow, ncol=ncol) CASE (13) - ans = QP_Tetrahedron_Order13() + CALL QP_Tetrahedron_Order13(ans=ans, nrow=nrow, ncol=ncol) CASE (14) - ans = QP_Tetrahedron_Order14() + CALL QP_Tetrahedron_Order14(ans=ans, nrow=nrow, ncol=ncol) CASE (15) - ans = QP_Tetrahedron_Order15() + CALL QP_Tetrahedron_Order15(ans=ans, nrow=nrow, ncol=ncol) CASE (16) - ans = QP_Tetrahedron_Order16() + CALL QP_Tetrahedron_Order16(ans=ans, nrow=nrow, ncol=ncol) CASE (17) - ans = QP_Tetrahedron_Order17() + CALL QP_Tetrahedron_Order17(ans=ans, nrow=nrow, ncol=ncol) CASE (18) - ans = QP_Tetrahedron_Order18() + CALL QP_Tetrahedron_Order18(ans=ans, nrow=nrow, ncol=ncol) CASE (19) - ans = QP_Tetrahedron_Order19() + CALL QP_Tetrahedron_Order19(ans=ans, nrow=nrow, ncol=ncol) CASE (20) - ans = QP_Tetrahedron_Order20() + CALL QP_Tetrahedron_Order20(ans=ans, nrow=nrow, ncol=ncol) CASE (21) - ans = QP_Tetrahedron_Order21() + CALL QP_Tetrahedron_Order21(ans=ans, nrow=nrow, ncol=ncol) END SELECT -END FUNCTION QuadraturePointTetrahedronSolin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order1() RESULT(ans) - REAL(DFP) :: ans(4, 1) - ans = RESHAPE([ & - & 0.250000000000000, 0.250000000000000, 0.250000000000000, 0.166666666666667 & - & ], [4, 1]) -END FUNCTION QP_Tetrahedron_Order1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order2() RESULT(ans) - REAL(DFP) :: ans(4, 4) - ans = RESHAPE([ & - & 0.585410196624969, 0.138196601125011, 0.138196601125011, 0.041666666666667, & - & 0.138196601125011, 0.138196601125011, 0.138196601125011, 0.041666666666667, & - & 0.138196601125011, 0.138196601125011, 0.585410196624969, 0.041666666666667, & - & 0.138196601125011, 0.585410196624969, 0.138196601125011, 0.041666666666667 & - & ], [4, 4]) -END FUNCTION QP_Tetrahedron_Order2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order3() RESULT(ans) - REAL(DFP) :: ans(4, 5) - ans = RESHAPE([ & - & 0.250000000000000, 0.250000000000000, 0.250000000000000, -0.133333333333333, & - & 0.500000000000000, 0.166666666666667, 0.166666666666667, 0.075000000000000, & - & 0.166666666666667, 0.166666666666667, 0.166666666666667, 0.075000000000000, & - & 0.166666666666667, 0.166666666666667, 0.500000000000000, 0.075000000000000, & - & 0.166666666666667, 0.500000000000000, 0.166666666666667, 0.075000000000000 & - & ], [4, 5]) -END FUNCTION QP_Tetrahedron_Order3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- -PURE FUNCTION QP_Tetrahedron_Order4() RESULT(ans) - REAL(DFP) :: ans(4, 11) - ans = RESHAPE([ & - & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222, & - & 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888, & - & 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888, & - & 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888, & - & 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888, & - & 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888, & - & 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 & - & ], [4, 11]) -END FUNCTION QP_Tetrahedron_Order4 +CONTAINS + +#include "./include/Tetrahedron/order1.F90" +#include "./include/Tetrahedron/order2.F90" +#include "./include/Tetrahedron/order3.F90" +#include "./include/Tetrahedron/order4.F90" +#include "./include/Tetrahedron/order5.F90" +#include "./include/Tetrahedron/order6.F90" +#include "./include/Tetrahedron/order7.F90" +#include "./include/Tetrahedron/order8.F90" +#include "./include/Tetrahedron/order9.F90" +#include "./include/Tetrahedron/order10.F90" +#include "./include/Tetrahedron/order11.F90" +#include "./include/Tetrahedron/order12.F90" +#include "./include/Tetrahedron/order13.F90" +#include "./include/Tetrahedron/order14.F90" +#include "./include/Tetrahedron/order15.F90" +#include "./include/Tetrahedron/order16.F90" +#include "./include/Tetrahedron/order17.F90" +#include "./include/Tetrahedron/order18.F90" +#include "./include/Tetrahedron/order19.F90" +#include "./include/Tetrahedron/order20.F90" +#include "./include/Tetrahedron/order21.F90" + +END SUBROUTINE QuadraturePointTetrahedronSolin !---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order5() RESULT(ans) - REAL(DFP) :: ans(4, 14) - ans = RESHAPE([ & - & 0.0927352503109, 0.0927352503109, 0.0927352503109 , 0.01224884051940, & - & 0.7217942490670, 0.0927352503109, 0.0927352503109 , 0.01224884051940, & - & 0.0927352503109, 0.7217942490670, 0.0927352503109 , 0.01224884051940, & - & 0.0927352503109, 0.0927352503109, 0.7217942490670 , 0.01224884051940, & - & 0.3108859192630, 0.3108859192630, 0.3108859192630 , 0.01878132095300, & - & 0.0673422422101, 0.3108859192630, 0.3108859192630 , 0.01878132095300, & - & 0.3108859192630, 0.0673422422101, 0.3108859192630 , 0.01878132095300, & - & 0.3108859192630, 0.3108859192630, 0.0673422422101 , 0.01878132095300, & - & 0.4544962958740, 0.4544962958740, 0.0455037041256 , 0.00709100346285, & - & 0.4544962958740, 0.0455037041256, 0.4544962958740 , 0.00709100346285, & - & 0.0455037041256, 0.4544962958740, 0.4544962958740 , 0.00709100346285, & - & 0.4544962958740, 0.0455037041256, 0.0455037041256 , 0.00709100346285, & - & 0.0455037041256, 0.4544962958740, 0.0455037041256 , 0.00709100346285, & - & 0.0455037041256, 0.0455037041256, 0.4544962958740 , 0.00709100346285 & - & ], [4, 14]) -END FUNCTION QP_Tetrahedron_Order5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order6() RESULT(ans) - REAL(DFP) :: ans(4, 24) - ans = RESHAPE([ & - & 0.2146028712590, 0.2146028712590, 0.2146028712590 , 0.006653791709700, & - & 0.3561913862230, 0.2146028712590, 0.2146028712590 , 0.006653791709700, & - & 0.2146028712590, 0.3561913862230, 0.2146028712590 , 0.006653791709700, & - & 0.2146028712590, 0.2146028712590, 0.3561913862230 , 0.006653791709700, & - & 0.0406739585346, 0.0406739585346, 0.0406739585346 , 0.001679535175883, & - & 0.8779781243960, 0.0406739585346, 0.0406739585346 , 0.001679535175883, & - & 0.0406739585346, 0.8779781243960, 0.0406739585346 , 0.001679535175883, & - & 0.0406739585346, 0.0406739585346, 0.8779781243960 , 0.001679535175883, & - & 0.3223378901420, 0.3223378901420, 0.3223378901420 , 0.009226196923950, & - & 0.0329863295732, 0.3223378901420, 0.3223378901420 , 0.009226196923950, & - & 0.3223378901420, 0.0329863295732, 0.3223378901420 , 0.009226196923950, & - & 0.3223378901420, 0.3223378901420, 0.0329863295732 , 0.009226196923950, & - & 0.0636610018750, 0.0636610018750, 0.2696723314580 , 0.008035714285717, & - & 0.0636610018750, 0.2696723314580, 0.0636610018750 , 0.008035714285717, & - & 0.0636610018750, 0.0636610018750, 0.6030056647920 , 0.008035714285717, & - & 0.0636610018750, 0.6030056647920, 0.0636610018750 , 0.008035714285717, & - & 0.0636610018750, 0.2696723314580, 0.6030056647920 , 0.008035714285717, & - & 0.0636610018750, 0.6030056647920, 0.2696723314580 , 0.008035714285717, & - & 0.2696723314580, 0.0636610018750, 0.0636610018750 , 0.008035714285717, & - & 0.2696723314580, 0.0636610018750, 0.6030056647920 , 0.008035714285717, & - & 0.2696723314580, 0.6030056647920, 0.0636610018750 , 0.008035714285717, & - & 0.6030056647920, 0.0636610018750, 0.2696723314580 , 0.008035714285717, & - & 0.6030056647920, 0.0636610018750, 0.0636610018750 , 0.008035714285717, & - & 0.6030056647920, 0.2696723314580, 0.0636610018750 , 0.008035714285717 & - & ], [4, 24]) -END FUNCTION QP_Tetrahedron_Order6 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order7() RESULT(ans) - REAL(DFP) :: ans(4, 31) - ans = RESHAPE([ & - & 0.50000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, & - & 0.50000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, & - & 0.00000000000000, 0.50000000000000, 0.50000000000000 , +0.000970017636685, & - & 0.00000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, & - & 0.00000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, & - & 0.50000000000000, 0.00000000000000, 0.00000000000000 , +0.000970017636685, & - & 0.25000000000000, 0.25000000000000, 0.25000000000000 , +0.018264223466167, & - & 0.07821319233030, 0.07821319233030, 0.07821319233030 , +0.010599941524417, & - & 0.07821319233030, 0.07821319233030, 0.76536042300900 , +0.010599941524417, & - & 0.07821319233030, 0.76536042300900, 0.07821319233030 , +0.010599941524417, & - & 0.76536042300900, 0.07821319233030, 0.07821319233030 , +0.010599941524417, & - & 0.12184321666400, 0.12184321666400, 0.12184321666400 , -0.062517740114333, & - & 0.12184321666400, 0.12184321666400, 0.63447035000800 , -0.062517740114333, & - & 0.12184321666400, 0.63447035000800, 0.12184321666400 , -0.062517740114333, & - & 0.63447035000800, 0.12184321666400, 0.12184321666400 , -0.062517740114333, & - & 0.33253916444600, 0.33253916444600, 0.33253916444600 , +0.004891425263067, & - & 0.33253916444600, 0.33253916444600, 0.00238250666074 , +0.004891425263067, & - & 0.33253916444600, 0.00238250666074, 0.33253916444600 , +0.004891425263067, & - & 0.00238250666074, 0.33253916444600, 0.33253916444600 , +0.004891425263067, & - & 0.10000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.20000000000000, 0.60000000000000 , +0.027557319224000, & - & 0.10000000000000, 0.60000000000000, 0.20000000000000 , +0.027557319224000, & - & 0.20000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.20000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, & - & 0.20000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.60000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, & - & 0.60000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, & - & 0.60000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000 & - & ], [4, 31]) -END FUNCTION QP_Tetrahedron_Order7 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order8() RESULT(ans) - REAL(DFP) :: ans(4, 43) - ans = RESHAPE([ & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.020500188658667, & - & 0.2068299316110, 0.2068299316110, 0.2068299316110 , +0.014250305822867, & - & 0.2068299316110, 0.2068299316110, 0.3795102051680 , +0.014250305822867, & - & 0.2068299316110, 0.3795102051680, 0.2068299316110 , +0.014250305822867, & - & 0.3795102051680, 0.2068299316110, 0.2068299316110 , +0.014250305822867, & - & 0.0821035883105, 0.0821035883105, 0.0821035883105 , +0.001967033313133, & - & 0.0821035883105, 0.0821035883105, 0.7536892350680 , +0.001967033313133, & - & 0.0821035883105, 0.7536892350680, 0.0821035883105 , +0.001967033313133, & - & 0.7536892350680, 0.0821035883105, 0.0821035883105 , +0.001967033313133, & - & 0.0057819505052, 0.0057819505052, 0.0057819505052 , +0.000169834109093, & - & 0.0057819505052, 0.0057819505052, 0.9826541484840 , +0.000169834109093, & - & 0.0057819505052, 0.9826541484840, 0.0057819505052 , +0.000169834109093, & - & 0.9826541484840, 0.0057819505052, 0.0057819505052 , +0.000169834109093, & - & 0.0505327400189, 0.0505327400189, 0.4494672599810 , +0.004579683824467, & - & 0.0505327400189, 0.4494672599810, 0.0505327400189 , +0.004579683824467, & - & 0.4494672599810, 0.0505327400189, 0.0505327400189 , +0.004579683824467, & - & 0.0505327400189, 0.4494672599810, 0.4494672599810 , +0.004579683824467, & - & 0.4494672599810, 0.0505327400189, 0.4494672599810 , +0.004579683824467, & - & 0.4494672599810, 0.4494672599810, 0.0505327400189 , +0.004579683824467, & - & 0.2290665361170, 0.2290665361170, 0.0356395827885 , +0.005704485808683, & - & 0.2290665361170, 0.0356395827885, 0.2290665361170 , +0.005704485808683, & - & 0.2290665361170, 0.2290665361170, 0.5062273449780 , +0.005704485808683, & - & 0.2290665361170, 0.5062273449780, 0.2290665361170 , +0.005704485808683, & - & 0.2290665361170, 0.0356395827885, 0.5062273449780 , +0.005704485808683, & - & 0.2290665361170, 0.5062273449780, 0.0356395827885 , +0.005704485808683, & - & 0.0356395827885, 0.2290665361170, 0.2290665361170 , +0.005704485808683, & - & 0.0356395827885, 0.2290665361170, 0.5062273449780 , +0.005704485808683, & - & 0.0356395827885, 0.5062273449780, 0.2290665361170 , +0.005704485808683, & - & 0.5062273449780, 0.2290665361170, 0.0356395827885 , +0.005704485808683, & - & 0.5062273449780, 0.2290665361170, 0.2290665361170 , +0.005704485808683, & - & 0.5062273449780, 0.0356395827885, 0.2290665361170 , +0.005704485808683, & - & 0.0366077495532, 0.0366077495532, 0.1904860419350 , +0.002140519141167, & - & 0.0366077495532, 0.1904860419350, 0.0366077495532 , +0.002140519141167, & - & 0.0366077495532, 0.0366077495532, 0.7362984589590 , +0.002140519141167, & - & 0.0366077495532, 0.7362984589590, 0.0366077495532 , +0.002140519141167, & - & 0.0366077495532, 0.1904860419350, 0.7362984589590 , +0.002140519141167, & - & 0.0366077495532, 0.7362984589590, 0.1904860419350 , +0.002140519141167, & - & 0.1904860419350, 0.0366077495532, 0.0366077495532 , +0.002140519141167, & - & 0.1904860419350, 0.0366077495532, 0.7362984589590 , +0.002140519141167, & - & 0.1904860419350, 0.7362984589590, 0.0366077495532 , +0.002140519141167, & - & 0.7362984589590, 0.0366077495532, 0.1904860419350 , +0.002140519141167, & - & 0.7362984589590, 0.0366077495532, 0.0366077495532 , +0.002140519141167, & - & 0.7362984589590, 0.1904860419350, 0.0366077495532 , +0.002140519141167 & - & ], [4, 43]) -END FUNCTION QP_Tetrahedron_Order8 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order9() RESULT(ans) - REAL(DFP) :: ans(4, 53) - ans = RESHAPE([ & - & +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167, & - & +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & - & +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083, & - & +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083, & - & +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & - & +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & - & +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500, & - & +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500, & - & +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & - & +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & - & +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167, & - & +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167, & - & +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & - & +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & - & +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500, & - & +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500, & - & +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & - & +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & - & +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & - & +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & - & +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & - & +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500, & - & +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500, & - & +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & - & +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & - & +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & - & +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & - & +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & - & +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & - & +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & - & +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & - & +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & - & +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & - & +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667, & - & +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667, & - & +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & - & +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & - & +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & - & +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & - & +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & - & +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & - & -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & - & -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557, & - & -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & - & -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & - & -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557, & - & -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557, & - & +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & - & +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & - & +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & - & +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & - & +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & - & +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 & - & ], [4, 53]) -END FUNCTION QP_Tetrahedron_Order9 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order10() RESULT(ans) - REAL(DFP) :: ans(4, 126) - ans = QP_Tetrahedron_Order11() -END FUNCTION QP_Tetrahedron_Order10 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order11() RESULT(ans) - REAL(DFP) :: ans(4, 126) - ans = RESHAPE([ & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.4062316284e-05 & - & ], [4, 126]) -END FUNCTION QP_Tetrahedron_Order11 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order12() RESULT(ans) - REAL(DFP) :: ans(4, 210) - ans = QP_Tetrahedron_Order13() -END FUNCTION QP_Tetrahedron_Order12 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order13() RESULT(ans) - REAL(DFP) :: ans(4, 210) - ans = RESHAPE([ & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 & - & ], [4, 210]) -END FUNCTION - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order14() RESULT(ans) - REAL(DFP) :: ans(4, 330) - ans = QP_Tetrahedron_Order15() -END FUNCTION - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order15() RESULT(ans) - REAL(DFP) :: ans(4, 330) - ans = RESHAPE([ & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 & - & ], [4, 330]) -END FUNCTION QP_Tetrahedron_Order15 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order16() RESULT(ans) - REAL(DFP) :: ans(4, 495) - ans = QP_Tetrahedron_Order17() -END FUNCTION QP_Tetrahedron_Order16 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order17() RESULT(ans) - REAL(DFP) :: ans(4, 495) - ans = RESHAPE([ & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3573205875e-08 & - & ], [4, 495]) -END FUNCTION QP_Tetrahedron_Order17 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order18() RESULT(ans) - REAL(DFP) :: ans(4, 715) - ans = QP_Tetrahedron_Order19() -END FUNCTION QP_Tetrahedron_Order18 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order19() RESULT(ans) - REAL(DFP) :: ans(4, 715) - ans = RESHAPE([ & - & 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 & - & ], [4, 715]) -END FUNCTION QP_Tetrahedron_Order19 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order20() RESULT(ans) - REAL(DFP) :: ans(4, 1001) - ans = QP_Tetrahedron_Order21() -END FUNCTION QP_Tetrahedron_Order20 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE FUNCTION QP_Tetrahedron_Order21() RESULT(ans) - REAL(DFP) :: ans(4, 1001) - ans = RESHAPE([ & - & 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 & - & ], [4, 1001]) -END FUNCTION QP_Tetrahedron_Order21 - -!---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- END MODULE QuadraturePoint_Tetrahedron_Solin From fc02fea0281f4970a916bf25d28064250b970193 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 19:58:07 +0900 Subject: [PATCH 209/359] update in tetrahedron --- ...etrahedronInterpolationUtility@Methods.F90 | 301 +++++++++++------- 1 file changed, 191 insertions(+), 110 deletions(-) diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index 77a451f9c..d09dc7860 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -2415,152 +2415,233 @@ END SUBROUTINE IJK2VEFC_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Tetrahedron1 -REAL(DFP), ALLOCATABLE :: temp_t(:, :) -TYPE(string) :: astr - -IF (order .LE. MAX_ORDER_TETRAHEDRON_SOLIN) THEN - astr = TRIM(UpperCase(refTetrahedron)) - temp_t = QuadraturePointTetrahedronSolin(order=order) - CALL Reallocate(ans, 4_I4B, SIZE(temp_t, 2, kind=I4B)) - - IF (PRESENT(xij)) THEN - ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & - & xin=temp_t(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4) & - & ) +INTEGER(I4B) :: nrow, ncol, n - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="TETRAHEDRON", & - & xij=xij) +nrow = 4 +ncol = QuadratureNumberTetrahedronSolin(order=order) - ELSE +IF (ncol .LT. 0) THEN + n = 1_I4B + INT(order / 2, kind=I4B) + ncol = n * (n + 1) * n +END IF - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :)) - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="BIUNIT") +ALLOCATE (ans(nrow, ncol)) - ELSE - ans = temp_t - END IF - END IF +CALL QuadraturePoint_Tetrahedron1_(order, quadType, refTetrahedron, xij, & + ans, nrow, ncol) - IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) -ELSE - ans = TensorQuadraturepoint_Tetrahedron( & - & order=order, & - & quadtype=quadtype, & - & refTetrahedron=refTetrahedron, & - & xij=xij) -END IF END PROCEDURE QuadraturePoint_Tetrahedron1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Tetrahedron1_ +INTEGER(I4B), PARAMETER :: nsd = 3 +CHARACTER(1) :: astr +INTEGER(I4B) :: ii, jj +REAL(DFP) :: areal +LOGICAL(LGT) :: abool + +abool = order .GT. MAX_ORDER_TETRAHEDRON_SOLIN +IF (abool) THEN + CALL TensorQuadraturepoint_Tetrahedron_(order=order, quadtype=quadtype, & + refTetrahedron=refTetrahedron, xij=xij, ans=ans, nrow=nrow, ncol=ncol) + RETURN +END IF + +CALL QuadraturePointTetrahedronSolin(order=order, ans=ans, nrow=nrow, & + ncol=ncol) + +! CALL Reallocate(ans, 4_I4B, SIZE(temp_t, 2, kind=I4B)) + +IF (PRESENT(xij)) THEN + ! ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & + CALL FromUnitTetrahedron2Tetrahedron_(xin=ans(1:nsd, 1:ncol), & + x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, & + nrow=ii, ncol=jj) + + areal = JacobianTetrahedron(from="UNIT", to="TETRAHEDRON", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN + +END IF + +astr = UpperCase(reftetrahedron(1:1)) + +IF (astr .EQ. "B") THEN + + CALL FromUnitTetrahedron2BiUnitTetrahedron_(xin=ans(1:nsd, 1:ncol), & + nrow=ii, ncol=jj, ans=ans) + + areal = JacobianTetrahedron(from="UNIT", to="BIUNIT") + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + +END IF + +END PROCEDURE QuadraturePoint_Tetrahedron1_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Tetrahedron2 !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Tetrahedron2 +INTEGER(I4B) :: nrow, ncol +nrow = 4 +ncol = nips(1) +ALLOCATE (ans(nrow, ncol)) +CALL QuadraturePoint_Tetrahedron2_(nips=nips, quadType=quadType, & + refTetrahedron=refTetrahedron, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Tetrahedron2_ INTEGER(I4B) :: order + order = QuadratureOrderTetrahedronSolin(nips(1)) + IF (order .LT. 0) THEN - ans = Quadraturepoint_Tetrahedron1( & - & order=order, & - & quadtype=quadType, & - & refTetrahedron=refTetrahedron, & - & xij=xij) -ELSE - CALL Errormsg(& - & msg="This routine is available for nips = [ & - & 1, 4, 5, 11, 14, 24, 31, 43, 53, 126, 210, 330, 495, 715, 1001] & + + CALL Errormsg( & + msg="This routine is available for nips = [& + & 1, 4, 5, 11, 14, 24, 31, 43, 53, 126, 210, 330, 495, 715, 1001] & & TRY CALLING TensorQuadraturePoint_Tetrahedron() instead.", & - & file=__FILE__, & - & routine="QuadraturePoint_Tetrahedron2()", & - & line=__LINE__, & - & unitno=stderr) + routine="QuadraturePoint_Tetrahedron2()", & + file=__FILE__, line=__LINE__, unitno=stderr) + + nrow = 0; ncol = 0 + RETURN + END IF -END PROCEDURE QuadraturePoint_Tetrahedron2 + +CALL Quadraturepoint_Tetrahedron1_(order=order, quadtype=quadType, & + refTetrahedron=refTetrahedron, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Tetrahedron2_ !---------------------------------------------------------------------------- ! TensorQuadraturePoint_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron1 -INTEGER(I4B) :: n(4) +INTEGER(I4B) :: n(3), nrow, ncol + n = 1_I4B + INT(order / 2, kind=I4B) n(2) = n(2) + 1 -ans = TensorQuadraturePoint_Tetrahedron2( & - & nipsx=n(1), & - & nipsy=n(2), & - & nipsz=n(3), & - & quadType=quadType, & - & refTetrahedron=refTetrahedron, & - & xij=xij) + +nrow = 4 +ncol = n(1) * n(2) * n(3) + +ALLOCATE (ans(nrow, ncol)) + +CALL TensorQuadraturePoint_Tetrahedron2_(nipsx=n(1), nipsy=n(2), & + nipsz=n(3), quadType=quadType, reftetrahedron=reftetrahedron, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorQuadraturePoint_Tetrahedron1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron1_ +INTEGER(I4B) :: n(3) + +n = 1_I4B + INT(order / 2, kind=I4B) +n(2) = n(2) + 1 + +CALL TensorQuadraturePoint_Tetrahedron2_(nipsx=n(1), nipsy=n(2), & + nipsz=n(3), quadType=quadType, refTetrahedron=refTetrahedron, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE TensorQuadraturePoint_Tetrahedron1_ + !---------------------------------------------------------------------------- ! TensorQuadraturePoint_Tetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron2 -INTEGER(I4B) :: n(3), nsd -REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :) -TYPE(String) :: astr - -astr = TRIM(UpperCase(refTetrahedron)) -n(1) = nipsx(1) -n(2) = nipsy(1) -n(3) = nipsz(1) - -temp_q = QuadraturePoint_Hexahedron(& - & nipsx=n(1:1), & - & nipsy=n(2:2), & - & nipsz=n(3:3), & - & quadType1=GaussLegendreLobatto, & - & quadType2=GaussJacobiRadauLeft, & - & quadType3=GaussJacobiRadauLeft, & - & refHexahedron="BIUNIT", & - & alpha2=1.0_DFP, & - & beta2=0.0_DFP, & - & alpha3=2.0_DFP, & - & beta3=0.0_DFP) - -CALL Reallocate(temp_t, SIZE(temp_q, 1, KIND=I4B), SIZE(temp_q, 2, KIND=I4B)) -temp_t(1:3, :) = FromBiUnitHexahedron2UnitTetrahedron(xin=temp_q(1:3, :)) -temp_t(4, :) = temp_q(4, :) / 8.0_DFP -nsd = 3_I4B -CALL Reallocate(ans, 4_I4B, SIZE(temp_q, 2, KIND=I4B)) +INTEGER(I4B) :: nrow, ncol + +nrow = 4 +ncol = nipsx(1) * nipsy(1) * nipsz(1) + +ALLOCATE (ans(nrow, ncol)) + +CALL TensorQuadraturePoint_Tetrahedron2_(nipsx=nipsx, nipsy=nipsy, & + nipsz=nipsz, quadType=quadType, refTetrahedron=refTetrahedron, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE TensorQuadraturePoint_Tetrahedron2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron2_ +INTEGER(I4B), PARAMETER :: nsd = 3 +REAL(DFP), PARAMETER :: one_by_8 = 1.0_DFP / 8.0_DFP + +REAL(DFP) :: areal + +INTEGER(I4B) :: ii, jj +CHARACTER(1) :: astr + +nrow = 4 +ncol = nipsx(1) * nipsy(1) * nipsz(1) + +! temp_q = QuadraturePoint_Hexahedron(& +CALL QuadraturePoint_Hexahedron_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadType1=GaussLegendreLobatto, quadType2=GaussJacobiRadauLeft, & + quadType3=GaussJacobiRadauLeft, refHexahedron="BIUNIT", alpha2=1.0_DFP, & + beta2=0.0_DFP, alpha3=2.0_DFP, beta3=0.0_DFP, ans=ans, nrow=ii, ncol=jj) + +! ans(1:nsd, :) = FromBiUnitHexahedron2UnitTetrahedron(xin=temp_q(1:3, :)) +CALL FromBiUnitHexahedron2UnitTetrahedron_(xin=ans(1:nsd, 1:ncol), ans=ans, & + nrow=ii, ncol=jj) + +DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * one_by_8 +END DO IF (PRESENT(xij)) THEN - ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & - & xin=temp_t(1:3, :), & - & x1=xij(:, 1), & - & x2=xij(:, 2), & - & x3=xij(:, 3), & - & x4=xij(:, 4) & - & ) - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="TETRAHEDRON", & - & xij=xij) -ELSE - IF (astr%chars() .EQ. "BIUNIT") THEN - ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :)) - ans(4, :) = temp_t(4, :) * JacobianTetrahedron( & - & from="UNIT", & - & to="BIUNIT") - ELSE - ans = temp_t - END IF + + ! ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( & + CALL FromUnitTetrahedron2Tetrahedron_(xin=ans(1:nsd, 1:ncol), & + x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, & + nrow=ii, ncol=jj) + + areal = JacobianTetrahedron(from="UNIT", to="TETRAHEDRON", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN END IF -IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q) -IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t) -END PROCEDURE TensorQuadraturePoint_Tetrahedron2 +astr = UpperCase(reftetrahedron(1:1)) + +IF (astr .EQ. "B") THEN + CALL FromUnitTetrahedron2BiUnitTetrahedron_(xin=ans(1:nsd, 1:ncol), & + ans=ans, nrow=ii, ncol=jj) + + areal = JacobianTetrahedron(from="UNIT", to="BIUNIT") + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + RETURN +END IF + +END PROCEDURE TensorQuadraturePoint_Tetrahedron2_ !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Tetrahedron From 7ced9ff11bdcbe7864ec303d31b2d7be8b343094 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 19:58:14 +0900 Subject: [PATCH 210/359] update in mapping --- .../Utility/src/MappingUtility@Methods.F90 | 115 +++++++++++++++--- 1 file changed, 96 insertions(+), 19 deletions(-) diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index 58f5cf81c..e39785260 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -565,17 +565,53 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron -ans = 0.5_DFP * (1.0_DFP + xin) +INTEGER(I4B) :: nrow, ncol +CALL FromBiUnitTetrahedron2UnitTetrahedron_(xin, ans, nrow, ncol) END PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron_ +INTEGER(I4B) :: ii, jj +REAL(DFP), PARAMETER :: half = 0.5_DFP, one = 1.0_DFP + +nrow = SIZE(xin, 1) +ncol = SIZE(xin, 2) + +DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = half * (one + xin(ii, jj)) +END DO + +END PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron_ + !---------------------------------------------------------------------------- ! FromUnitTetrahedron2BiUnitTetrahedron !---------------------------------------------------------------------------- MODULE PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron -ans = -1.0_DFP + 2.0_DFP * xin +INTEGER(I4B) :: nrow, ncol +CALL FromUnitTetrahedron2BiUnitTetrahedron_(xin, ans, nrow, ncol) END PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron_ +REAL(DFP), PARAMETER :: minus_one = -1.0_DFP, two = 2.0_DFP +INTEGER(I4B) :: ii, jj + +nrow = SIZE(xin, 1) +ncol = SIZE(xin, 2) + +DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = minus_one + two * xin(ii, jj) +END DO + +END PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron_ + !---------------------------------------------------------------------------- ! FromBiUnitTetrahedron2Tetrahedron !---------------------------------------------------------------------------- @@ -607,16 +643,19 @@ MODULE PROCEDURE FromUnitTetrahedron2Tetrahedron_ INTEGER(I4B) :: ii +REAL(DFP), PARAMETER :: one = 1.0_DFP +REAL(DFP) :: rr(10) -nrow = 3 +nrow = SIZE(x1) ncol = SIZE(xin, 2) DO ii = 1, ncol - ans(1:3, ii) = & - (1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii)) * x1(1:3) & - + xin(1, ii) * x2(1:3) & - + xin(2, ii) * x3(1:3) & - + xin(3, ii) * x4(1:3) + + rr(1:3) = xin(1:3, ii) + rr(4) = one - rr(1) - rr(2) - rr(3) + + ans(1:nrow, ii) = rr(4) * x1(1:nrow) + rr(1) * x2(1:nrow) + rr(2) * x3(1:nrow) & + + rr(3) * x4(1:nrow) END DO END PROCEDURE FromUnitTetrahedron2Tetrahedron_ @@ -737,17 +776,41 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron -ans(1, :) = 0.25_DFP & - & * (1.0_DFP + xin(1, :)) & - & * (1.0_DFP - xin(2, :)) & - & * (1.0_DFP - xin(3, :)) - 1.0_DFP +INTEGER(I4B) :: nrow, ncol +CALL FromBiUnitHexahedron2BiUnitTetrahedron_(xin, ans, nrow, ncol) +END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -ans(2, :) = 0.5_DFP & - & * (1.0_DFP + xin(2, :)) & - & * (1.0_DFP - xin(3, :)) - 1.0_DFP +MODULE PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron_ -ans(3, :) = xin(3, :) -END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron +INTEGER(I4B) :: ii +REAL(DFP) :: rr(10) +REAL(DFP), PARAMETER :: one = 1.0_DFP + +nrow = 3 +ncol = SIZE(xin, 2) + +DO ii = 1, ncol + + rr(1:3) = xin(1:3, ii) + + rr(4) = one + rr(1) + rr(5) = one - rr(2) + rr(6) = one - rr(3) + rr(7) = 0.25_DFP * rr(4) * rr(5) * rr(6) + rr(8) = one + rr(2) + rr(9) = 0.5_DFP * rr(8) * rr(6) + + ans(1, ii) = rr(7) - one + ans(2, ii) = rr(9) - one + ans(3, ii) = rr(3) + +END DO + +END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron_ !---------------------------------------------------------------------------- ! FromUnitTetrahedron2BiUnitHexahedron @@ -763,10 +826,24 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FromBiUnitHexahedron2UnitTetrahedron -ans = FromBiUnitTetrahedron2UnitTetrahedron( & - & FromBiUnitHexahedron2BiUnitTetrahedron(xin)) +INTEGER(I4B) :: nrow, ncol +CALL FromBiUnitHexahedron2UnitTetrahedron_(xin, ans, nrow, ncol) END PROCEDURE FromBiUnitHexahedron2UnitTetrahedron +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitHexahedron2UnitTetrahedron_ + +CALL FromBiUnitHexahedron2BiUnitTetrahedron_(xin=xin, ans=ans, & + nrow=nrow, ncol=ncol) + +CALL FromBiUnitTetrahedron2UnitTetrahedron_(xin=ans, ans=ans, nrow=nrow, & + ncol=ncol) + +END PROCEDURE FromBiUnitHexahedron2UnitTetrahedron_ + !---------------------------------------------------------------------------- ! JacobianLine !---------------------------------------------------------------------------- From 7e706774138c23d5d93a3afabf15bbd5579bda26 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 22:48:06 +0900 Subject: [PATCH 211/359] update in tetraheedron interpol --- .../src/TetrahedronInterpolationUtility.F90 | 37 +++++++++++++------ 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index 317a25e35..2a1755fe4 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -51,9 +51,14 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: GetEdgeDOF_Tetrahedron PUBLIC :: GetFacetDOF_Tetrahedron PUBLIC :: GetCellDOF_Tetrahedron + PUBLIC :: LagrangeEvalAll_Tetrahedron PUBLIC :: LagrangeEvalAll_Tetrahedron_ + PUBLIC :: QuadraturePoint_Tetrahedron +PUBLIC :: QuadraturePoint_Tetrahedron_ +PUBLIC :: QuadratureNumber_Tetrahedron + PUBLIC :: RefElemDomain_Tetrahedron PUBLIC :: LagrangeGradientEvalAll_Tetrahedron PUBLIC :: LagrangeGradientEvalAll_Tetrahedron_ @@ -2307,6 +2312,22 @@ MODULE SUBROUTINE LagrangeEvalAll_Tetrahedron2_(order, x, xij, ans, & END SUBROUTINE LagrangeEvalAll_Tetrahedron2_ END INTERFACE LagrangeEvalAll_Tetrahedron_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION QuadratureNumber_Tetrahedron(order, quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadType + !! quadrature point type + !! currently this variable is not used + INTEGER(I4B) :: ans + !! Quadrature points + END FUNCTION QuadratureNumber_Tetrahedron +END INTERFACE + !---------------------------------------------------------------------------- ! QuadraturePoints_Tetrahedron !---------------------------------------------------------------------------- @@ -2490,7 +2511,7 @@ END SUBROUTINE TensorQuadraturePoint_Tetrahedron1_ END INTERFACE TensorQuadraturePoint_Tetrahedron_ !---------------------------------------------------------------------------- -! TensorQuadraturePoints_Tetrahedron +! TensorQuadraturePoints_Tetrahedron !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2515,9 +2536,7 @@ MODULE FUNCTION TensorQuadraturePoint_Tetrahedron2( & !! quadrature point type !! currently this variable is not used CHARACTER(*), INTENT(IN) :: refTetrahedron - !! Reference triangle - !! BIUNIT - !! UNIT + !! Reference triangle ! BIUNIT ! UNIT REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! nodal coordinates of triangle. !! The number of rows in xij should be 3 @@ -2588,8 +2607,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( & REAL(DFP), INTENT(INOUT) :: xij(:, :) !! Interpolation points CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron - !! UNIT *default - !! BIUNIT + !! UNIT *default ! BIUNIT REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) !! Coefficient of Lagrange polynomials LOGICAL(LGT), OPTIONAL :: firstCall @@ -2598,12 +2616,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( & !! Default value of firstCall is True INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical + !! Legendre ! Lobatto ! Chebyshev ! Jacobi ! Ultraspherical ! Heirarchical !! Orthogonal REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter From f297df2b53392e172561107d41d42d507cc51d4f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 22:48:12 +0900 Subject: [PATCH 212/359] update in tetrahedron quad --- .../src/include/Tetrahedron/order11.F90 | 254 ++- .../src/include/Tetrahedron/order13.F90 | 425 ++-- .../src/include/Tetrahedron/order14.F90 | 2 +- .../src/include/Tetrahedron/order15.F90 | 662 +++--- .../src/include/Tetrahedron/order17.F90 | 992 ++++---- .../src/include/Tetrahedron/order19.F90 | 1432 ++++++------ .../src/include/Tetrahedron/order21.F90 | 2004 ++++++++--------- .../src/include/Tetrahedron/order4.F90 | 25 +- .../src/include/Tetrahedron/order5.F90 | 31 +- .../src/include/Tetrahedron/order6.F90 | 50 +- .../src/include/Tetrahedron/order7.F90 | 64 +- .../src/include/Tetrahedron/order8.F90 | 88 +- .../src/include/Tetrahedron/order9.F90 | 108 +- 13 files changed, 3058 insertions(+), 3079 deletions(-) diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 index 95106d811..b91e8d3ca 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 @@ -5,133 +5,131 @@ PURE subroutine QP_Tetrahedron_Order11(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 126) nrow=4;ncol= 126 - ans = RESHAPE([ & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.4062316284e-05 & - & ], [4, 126]) +ans(1:nrow, 1) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000 ] +ans(1:nrow, 2) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000 ] +ans(1:nrow, 3) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000 ] +ans(1:nrow, 4) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 5) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 6) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 7) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000 ] +ans(1:nrow, 8) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000 ] +ans(1:nrow, 9) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 10) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 11) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 12) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000 ] +ans(1:nrow, 13) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 14) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 15) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 16) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 17) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 18) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 19) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 20) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 21) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 22) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000 ] +ans(1:nrow, 23) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000 ] +ans(1:nrow, 24) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 25) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 26) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 27) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000 ] +ans(1:nrow, 28) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 29) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 30) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 31) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 32) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 33) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 34) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 35) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 36) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 37) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000 ] +ans(1:nrow, 38) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 39) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 40) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 41) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 42) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 43) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 44) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 45) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 46) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 47) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ] +ans(1:nrow, 48) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 49) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 50) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 51) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 52) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 53) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ] +ans(1:nrow, 54) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 55) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 56) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ] +ans(1:nrow, 57) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500 ] +ans(1:nrow, 58) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500 ] +ans(1:nrow, 59) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500 ] +ans(1:nrow, 60) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 61) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 62) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500 ] +ans(1:nrow, 63) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500 ] +ans(1:nrow, 64) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 65) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 66) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500 ] +ans(1:nrow, 67) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 68) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 69) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 70) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 71) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 72) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500 ] +ans(1:nrow, 73) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500 ] +ans(1:nrow, 74) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 75) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 76) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500 ] +ans(1:nrow, 77) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 78) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 79) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 80) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 81) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 82) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500 ] +ans(1:nrow, 83) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 84) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 85) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 86) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 87) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 88) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ] +ans(1:nrow, 89) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 90) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 91) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ] +ans(1:nrow, 92) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833 ] +ans(1:nrow, 93) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833 ] +ans(1:nrow, 94) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833 ] +ans(1:nrow, 95) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 96) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833 ] +ans(1:nrow, 97) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833 ] +ans(1:nrow, 98) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 99) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833 ] +ans(1:nrow, 100) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 101) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 102) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833 ] +ans(1:nrow, 103) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833 ] +ans(1:nrow, 104) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 105) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833 ] +ans(1:nrow, 106) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 107) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 108) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833 ] +ans(1:nrow, 109) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 110) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 111) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ] +ans(1:nrow, 112) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500 ] +ans(1:nrow, 113) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500 ] +ans(1:nrow, 114) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500 ] +ans(1:nrow, 115) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500 ] +ans(1:nrow, 116) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500 ] +ans(1:nrow, 117) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500 ] +ans(1:nrow, 118) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500 ] +ans(1:nrow, 119) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500 ] +ans(1:nrow, 120) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500 ] +ans(1:nrow, 121) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500 ] +ans(1:nrow, 122) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150 ] +ans(1:nrow, 123) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150 ] +ans(1:nrow, 124) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150 ] +ans(1:nrow, 125) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150 ] +ans(1:nrow, 126) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.062316284e-05 ] END subroutine QP_Tetrahedron_Order11 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 index 3a6672b0d..9069c47b6 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 @@ -5,217 +5,216 @@ PURE subroutine QP_Tetrahedron_Order13(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 210) nrow=4;ncol= 210 - ans = RESHAPE([ & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 & - & ], [4, 210]) +ans(1:nrow, 1) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500 ] +ans(1:nrow, 2) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500 ] +ans(1:nrow, 3) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500 ] +ans(1:nrow, 4) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 5) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 6) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 7) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 8) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500 ] +ans(1:nrow, 9) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500 ] +ans(1:nrow, 10) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 11) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 12) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 13) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 14) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500 ] +ans(1:nrow, 15) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 16) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 17) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 18) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 19) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 20) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 21) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 22) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 23) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 24) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 25) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 26) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 27) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 28) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 29) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500 ] +ans(1:nrow, 30) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500 ] +ans(1:nrow, 31) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 32) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 33) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 34) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 35) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500 ] +ans(1:nrow, 36) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 37) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 38) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 39) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 40) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 41) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 42) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 43) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 44) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 45) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 46) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 47) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 48) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 49) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 50) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500 ] +ans(1:nrow, 51) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 52) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 53) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 54) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 55) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 56) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 57) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 58) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 59) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 60) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 61) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 62) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 63) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 64) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 65) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ] +ans(1:nrow, 66) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 67) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 68) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 69) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 70) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 71) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 72) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 73) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 74) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 75) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ] +ans(1:nrow, 76) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 77) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 78) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 79) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 80) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 81) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ] +ans(1:nrow, 82) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 83) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 84) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ] +ans(1:nrow, 85) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333 ] +ans(1:nrow, 86) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333 ] +ans(1:nrow, 87) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333 ] +ans(1:nrow, 88) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 89) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 90) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 91) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333 ] +ans(1:nrow, 92) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333 ] +ans(1:nrow, 93) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 94) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 95) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 96) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333 ] +ans(1:nrow, 97) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 98) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 99) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 100) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 101) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 102) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 103) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 104) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 105) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 106) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333 ] +ans(1:nrow, 107) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333 ] +ans(1:nrow, 108) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 109) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 110) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 111) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333 ] +ans(1:nrow, 112) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 113) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 114) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 115) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 116) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 117) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 118) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 119) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 120) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 121) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333 ] +ans(1:nrow, 122) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 123) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 124) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 125) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 126) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 127) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 128) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 129) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 130) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 131) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ] +ans(1:nrow, 132) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 133) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 134) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 135) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 136) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 137) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ] +ans(1:nrow, 138) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 139) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 140) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ] +ans(1:nrow, 141) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333 ] +ans(1:nrow, 142) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333 ] +ans(1:nrow, 143) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333 ] +ans(1:nrow, 144) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 145) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 146) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333 ] +ans(1:nrow, 147) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333 ] +ans(1:nrow, 148) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 149) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 150) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333 ] +ans(1:nrow, 151) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 152) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 153) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 154) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 155) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 156) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333 ] +ans(1:nrow, 157) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333 ] +ans(1:nrow, 158) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 159) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 160) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333 ] +ans(1:nrow, 161) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 162) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 163) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 164) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 165) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 166) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333 ] +ans(1:nrow, 167) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 168) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 169) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 170) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 171) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 172) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ] +ans(1:nrow, 173) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 174) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 175) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ] +ans(1:nrow, 176) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667 ] +ans(1:nrow, 177) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667 ] +ans(1:nrow, 178) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667 ] +ans(1:nrow, 179) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 180) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667 ] +ans(1:nrow, 181) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667 ] +ans(1:nrow, 182) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 183) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667 ] +ans(1:nrow, 184) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 185) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 186) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667 ] +ans(1:nrow, 187) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667 ] +ans(1:nrow, 188) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 189) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667 ] +ans(1:nrow, 190) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 191) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 192) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667 ] +ans(1:nrow, 193) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 194) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 195) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ] +ans(1:nrow, 196) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167 ] +ans(1:nrow, 197) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167 ] +ans(1:nrow, 198) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167 ] +ans(1:nrow, 199) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167 ] +ans(1:nrow, 200) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167 ] +ans(1:nrow, 201) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167 ] +ans(1:nrow, 202) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167 ] +ans(1:nrow, 203) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167 ] +ans(1:nrow, 204) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167 ] +ans(1:nrow, 205) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167 ] +ans(1:nrow, 206) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623 ] +ans(1:nrow, 207) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623 ] +ans(1:nrow, 208) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623 ] +ans(1:nrow, 209) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623 ] +ans(1:nrow, 210) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 ] + +END subroutine QP_Tetrahedron_Order13 -ENDsubroutine diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 index 5bb9d74c3..007cf086d 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 @@ -7,4 +7,4 @@ PURE SUBROUTINE QP_Tetrahedron_Order14(ans, nrow, ncol) CALL QP_Tetrahedron_Order15(ans, nrow, ncol) -END SUBROUTINE +END SUBROUTINE QP_Tetrahedron_Order14 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 index 608700781..3d8499718 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 @@ -5,337 +5,335 @@ PURE subroutine QP_Tetrahedron_Order15(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 330) nrow=4;ncol= 330 - ans = RESHAPE([ & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 & - & ], [4, 330]) +ans(1:nrow, 1) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667 ] +ans(1:nrow, 2) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667 ] +ans(1:nrow, 3) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667 ] +ans(1:nrow, 4) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 5) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 6) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 7) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 8) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 9) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667 ] +ans(1:nrow, 10) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667 ] +ans(1:nrow, 11) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 12) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 13) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 14) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 15) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 16) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667 ] +ans(1:nrow, 17) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 18) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 19) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 20) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 21) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 22) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 23) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 24) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 25) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 26) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 27) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 28) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 29) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 30) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 31) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 32) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 33) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 34) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 35) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 36) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 37) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667 ] +ans(1:nrow, 38) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667 ] +ans(1:nrow, 39) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 40) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 41) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 42) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 43) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 44) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667 ] +ans(1:nrow, 45) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 46) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 47) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 48) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 49) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 50) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 51) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 52) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 53) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 54) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 55) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 56) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 57) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 58) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 59) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 60) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 61) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 62) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 63) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 64) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 65) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667 ] +ans(1:nrow, 66) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 67) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 68) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 69) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 70) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 71) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 72) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 73) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 74) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 75) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 76) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 77) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 78) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 79) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 80) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 81) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 82) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 83) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 84) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 85) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 86) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ] +ans(1:nrow, 87) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 88) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 89) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 90) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 91) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 92) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 93) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 94) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 95) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 96) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 97) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 98) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 99) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 100) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 101) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ] +ans(1:nrow, 102) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 103) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 104) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 105) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 106) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 107) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 108) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 109) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 110) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 111) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ] +ans(1:nrow, 112) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 113) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 114) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 115) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 116) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 117) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ] +ans(1:nrow, 118) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 119) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 120) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ] +ans(1:nrow, 121) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667 ] +ans(1:nrow, 122) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667 ] +ans(1:nrow, 123) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667 ] +ans(1:nrow, 124) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 125) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 126) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 127) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 128) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667 ] +ans(1:nrow, 129) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667 ] +ans(1:nrow, 130) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 131) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 132) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 133) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 134) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667 ] +ans(1:nrow, 135) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 136) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 137) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 138) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 139) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 140) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 141) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 142) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 143) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 144) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 145) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 146) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 147) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 148) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 149) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667 ] +ans(1:nrow, 150) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667 ] +ans(1:nrow, 151) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 152) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 153) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 154) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 155) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667 ] +ans(1:nrow, 156) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 157) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 158) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 159) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 160) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 161) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 162) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 163) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 164) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 165) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 166) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 167) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 168) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 169) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 170) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667 ] +ans(1:nrow, 171) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 172) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 173) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 174) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 175) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 176) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 177) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 178) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 179) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 180) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 181) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 182) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 183) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 184) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 185) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ] +ans(1:nrow, 186) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 187) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 188) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 189) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 190) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 191) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 192) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 193) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 194) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 195) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ] +ans(1:nrow, 196) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 197) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 198) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 199) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 200) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 201) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ] +ans(1:nrow, 202) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 203) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 204) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ] +ans(1:nrow, 205) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333 ] +ans(1:nrow, 206) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333 ] +ans(1:nrow, 207) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333 ] +ans(1:nrow, 208) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 209) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 210) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 211) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333 ] +ans(1:nrow, 212) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333 ] +ans(1:nrow, 213) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 214) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 215) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 216) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333 ] +ans(1:nrow, 217) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 218) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 219) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 220) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 221) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 222) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 223) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 224) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 225) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 226) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333 ] +ans(1:nrow, 227) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333 ] +ans(1:nrow, 228) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 229) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 230) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 231) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333 ] +ans(1:nrow, 232) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 233) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 234) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 235) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 236) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 237) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 238) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 239) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 240) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 241) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333 ] +ans(1:nrow, 242) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 243) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 244) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 245) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 246) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 247) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 248) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 249) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 250) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 251) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ] +ans(1:nrow, 252) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 253) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 254) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 255) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 256) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 257) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ] +ans(1:nrow, 258) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 259) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 260) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ] +ans(1:nrow, 261) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833 ] +ans(1:nrow, 262) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833 ] +ans(1:nrow, 263) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833 ] +ans(1:nrow, 264) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 265) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 266) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833 ] +ans(1:nrow, 267) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833 ] +ans(1:nrow, 268) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 269) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 270) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833 ] +ans(1:nrow, 271) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 272) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 273) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 274) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 275) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 276) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833 ] +ans(1:nrow, 277) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833 ] +ans(1:nrow, 278) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 279) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 280) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833 ] +ans(1:nrow, 281) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 282) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 283) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 284) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 285) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 286) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833 ] +ans(1:nrow, 287) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 288) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 289) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 290) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 291) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 292) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ] +ans(1:nrow, 293) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 294) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 295) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ] +ans(1:nrow, 296) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500 ] +ans(1:nrow, 297) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500 ] +ans(1:nrow, 298) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500 ] +ans(1:nrow, 299) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 300) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500 ] +ans(1:nrow, 301) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500 ] +ans(1:nrow, 302) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 303) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500 ] +ans(1:nrow, 304) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 305) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 306) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500 ] +ans(1:nrow, 307) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500 ] +ans(1:nrow, 308) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 309) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500 ] +ans(1:nrow, 310) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 311) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 312) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500 ] +ans(1:nrow, 313) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 314) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 315) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ] +ans(1:nrow, 316) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833 ] +ans(1:nrow, 317) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833 ] +ans(1:nrow, 318) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833 ] +ans(1:nrow, 319) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833 ] +ans(1:nrow, 320) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833 ] +ans(1:nrow, 321) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833 ] +ans(1:nrow, 322) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833 ] +ans(1:nrow, 323) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833 ] +ans(1:nrow, 324) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833 ] +ans(1:nrow, 325) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833 ] +ans(1:nrow, 326) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05 ] +ans(1:nrow, 327) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05 ] +ans(1:nrow, 328) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05 ] +ans(1:nrow, 329) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05 ] +ans(1:nrow, 330) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 ] END subroutine QP_Tetrahedron_Order15 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 index 45a6e7bf5..e9285b136 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 @@ -5,503 +5,501 @@ PURE subroutine QP_Tetrahedron_Order17(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 495) nrow=4;ncol= 495 - ans = RESHAPE([ & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3573205875e-08 & - & ], [4, 495]) +ans(1:nrow, 1) = [ 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167 ] +ans(1:nrow, 2) = [ 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167 ] +ans(1:nrow, 3) = [ 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167 ] +ans(1:nrow, 4) = [ 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 5) = [ 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 6) = [ 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 7) = [ 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 8) = [ 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 9) = [ 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 10) = [ 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167 ] +ans(1:nrow, 11) = [ 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167 ] +ans(1:nrow, 12) = [ 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 13) = [ 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 14) = [ 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 15) = [ 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 16) = [ 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 17) = [ 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 18) = [ 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167 ] +ans(1:nrow, 19) = [ 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 20) = [ 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 21) = [ 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 22) = [ 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 23) = [ 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 24) = [ 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 25) = [ 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 26) = [ 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 27) = [ 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 28) = [ 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 29) = [ 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 30) = [ 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 31) = [ 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 32) = [ 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 33) = [ 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 34) = [ 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 35) = [ 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 36) = [ 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 37) = [ 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 38) = [ 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 39) = [ 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 40) = [ 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 41) = [ 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 42) = [ 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 43) = [ 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 44) = [ 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 45) = [ 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 46) = [ 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167 ] +ans(1:nrow, 47) = [ 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167 ] +ans(1:nrow, 48) = [ 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 49) = [ 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 50) = [ 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 51) = [ 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 52) = [ 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 53) = [ 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 54) = [ 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167 ] +ans(1:nrow, 55) = [ 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 56) = [ 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 57) = [ 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 58) = [ 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 59) = [ 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 60) = [ 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 61) = [ 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 62) = [ 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 63) = [ 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 64) = [ 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 65) = [ 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 66) = [ 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 67) = [ 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 68) = [ 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 69) = [ 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 70) = [ 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 71) = [ 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 72) = [ 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 73) = [ 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 74) = [ 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 75) = [ 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 76) = [ 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 77) = [ 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 78) = [ 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 79) = [ 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 80) = [ 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 81) = [ 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 82) = [ 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167 ] +ans(1:nrow, 83) = [ 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 84) = [ 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 85) = [ 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 86) = [ 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 87) = [ 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 88) = [ 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 89) = [ 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 90) = [ 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 91) = [ 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 92) = [ 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 93) = [ 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 94) = [ 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 95) = [ 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 96) = [ 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 97) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 98) = [ 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 99) = [ 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 100) = [ 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 101) = [ 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 102) = [ 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 103) = [ 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 104) = [ 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 105) = [ 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 106) = [ 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 107) = [ 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 108) = [ 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 109) = [ 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 110) = [ 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ] +ans(1:nrow, 111) = [ 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 112) = [ 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 113) = [ 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 114) = [ 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 115) = [ 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 116) = [ 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 117) = [ 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 118) = [ 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 119) = [ 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 120) = [ 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 121) = [ 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 122) = [ 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 123) = [ 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 124) = [ 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 125) = [ 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 126) = [ 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 127) = [ 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 128) = [ 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 129) = [ 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 130) = [ 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 131) = [ 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ] +ans(1:nrow, 132) = [ 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 133) = [ 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 134) = [ 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 135) = [ 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 136) = [ 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 137) = [ 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 138) = [ 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 139) = [ 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 140) = [ 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 141) = [ 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 142) = [ 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 143) = [ 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 144) = [ 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 145) = [ 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 146) = [ 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ] +ans(1:nrow, 147) = [ 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 148) = [ 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 149) = [ 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 150) = [ 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 151) = [ 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 152) = [ 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 153) = [ 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 154) = [ 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 155) = [ 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 156) = [ 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ] +ans(1:nrow, 157) = [ 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 158) = [ 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 159) = [ 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 160) = [ 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 161) = [ 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 162) = [ 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ] +ans(1:nrow, 163) = [ 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 164) = [ 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 165) = [ 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ] +ans(1:nrow, 166) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000 ] +ans(1:nrow, 167) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000 ] +ans(1:nrow, 168) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000 ] +ans(1:nrow, 169) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 170) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 171) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 172) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 173) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 174) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000 ] +ans(1:nrow, 175) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000 ] +ans(1:nrow, 176) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 177) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 178) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 179) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 180) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 181) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000 ] +ans(1:nrow, 182) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 183) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 184) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 185) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 186) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 187) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 188) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 189) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 190) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 191) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 192) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 193) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 194) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 195) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 196) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 197) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 198) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 199) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 200) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 201) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 202) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000 ] +ans(1:nrow, 203) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000 ] +ans(1:nrow, 204) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 205) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 206) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 207) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 208) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 209) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000 ] +ans(1:nrow, 210) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 211) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 212) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 213) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 214) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 215) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 216) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 217) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 218) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 219) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 220) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 221) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 222) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 223) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 224) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 225) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 226) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 227) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 228) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 229) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 230) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000 ] +ans(1:nrow, 231) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 232) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 233) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 234) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 235) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 236) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 237) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 238) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 239) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 240) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 241) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 242) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 243) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 244) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 245) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 246) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 247) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 248) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 249) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 250) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 251) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ] +ans(1:nrow, 252) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 253) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 254) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 255) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 256) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 257) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 258) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 259) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 260) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 261) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 262) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 263) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 264) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 265) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 266) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ] +ans(1:nrow, 267) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 268) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 269) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 270) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 271) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 272) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 273) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 274) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 275) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 276) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ] +ans(1:nrow, 277) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 278) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 279) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 280) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 281) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 282) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ] +ans(1:nrow, 283) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 284) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 285) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ] +ans(1:nrow, 286) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333 ] +ans(1:nrow, 287) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333 ] +ans(1:nrow, 288) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333 ] +ans(1:nrow, 289) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 290) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 291) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 292) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 293) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333 ] +ans(1:nrow, 294) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333 ] +ans(1:nrow, 295) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 296) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 297) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 298) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 299) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333 ] +ans(1:nrow, 300) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 301) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 302) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 303) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 304) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 305) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 306) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 307) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 308) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 309) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 310) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 311) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 312) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 313) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 314) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333 ] +ans(1:nrow, 315) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333 ] +ans(1:nrow, 316) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 317) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 318) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 319) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 320) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333 ] +ans(1:nrow, 321) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 322) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 323) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 324) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 325) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 326) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 327) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 328) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 329) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 330) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 331) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 332) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 333) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 334) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 335) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333 ] +ans(1:nrow, 336) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 337) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 338) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 339) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 340) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 341) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 342) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 343) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 344) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 345) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 346) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 347) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 348) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 349) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 350) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ] +ans(1:nrow, 351) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 352) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 353) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 354) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 355) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 356) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 357) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 358) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 359) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 360) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ] +ans(1:nrow, 361) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 362) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 363) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 364) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 365) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 366) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ] +ans(1:nrow, 367) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 368) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 369) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ] +ans(1:nrow, 370) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000 ] +ans(1:nrow, 371) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000 ] +ans(1:nrow, 372) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000 ] +ans(1:nrow, 373) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 374) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 375) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 376) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000 ] +ans(1:nrow, 377) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000 ] +ans(1:nrow, 378) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 379) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 380) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 381) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000 ] +ans(1:nrow, 382) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 383) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 384) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 385) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 386) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 387) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 388) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 389) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 390) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 391) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000 ] +ans(1:nrow, 392) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000 ] +ans(1:nrow, 393) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 394) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 395) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 396) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000 ] +ans(1:nrow, 397) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 398) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 399) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 400) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 401) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 402) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 403) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 404) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 405) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 406) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000 ] +ans(1:nrow, 407) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 408) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 409) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 410) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 411) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 412) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 413) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 414) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 415) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 416) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ] +ans(1:nrow, 417) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 418) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 419) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 420) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 421) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 422) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ] +ans(1:nrow, 423) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 424) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 425) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ] +ans(1:nrow, 426) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333 ] +ans(1:nrow, 427) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333 ] +ans(1:nrow, 428) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333 ] +ans(1:nrow, 429) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 430) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 431) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333 ] +ans(1:nrow, 432) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333 ] +ans(1:nrow, 433) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 434) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 435) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333 ] +ans(1:nrow, 436) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 437) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 438) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 439) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 440) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 441) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333 ] +ans(1:nrow, 442) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333 ] +ans(1:nrow, 443) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 444) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 445) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333 ] +ans(1:nrow, 446) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 447) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 448) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 449) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 450) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 451) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333 ] +ans(1:nrow, 452) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 453) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 454) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 455) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 456) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 457) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ] +ans(1:nrow, 458) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 459) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 460) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ] +ans(1:nrow, 461) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850 ] +ans(1:nrow, 462) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850 ] +ans(1:nrow, 463) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850 ] +ans(1:nrow, 464) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 465) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850 ] +ans(1:nrow, 466) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850 ] +ans(1:nrow, 467) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 468) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850 ] +ans(1:nrow, 469) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 470) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 471) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850 ] +ans(1:nrow, 472) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850 ] +ans(1:nrow, 473) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 474) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850 ] +ans(1:nrow, 475) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 476) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 477) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850 ] +ans(1:nrow, 478) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 479) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 480) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ] +ans(1:nrow, 481) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255 ] +ans(1:nrow, 482) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255 ] +ans(1:nrow, 483) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255 ] +ans(1:nrow, 484) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255 ] +ans(1:nrow, 485) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255 ] +ans(1:nrow, 486) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255 ] +ans(1:nrow, 487) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255 ] +ans(1:nrow, 488) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255 ] +ans(1:nrow, 489) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255 ] +ans(1:nrow, 490) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255 ] +ans(1:nrow, 491) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06 ] +ans(1:nrow, 492) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06 ] +ans(1:nrow, 493) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06 ] +ans(1:nrow, 494) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06 ] +ans(1:nrow, 495) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.573205875e-08 ] END subroutine QP_Tetrahedron_Order17 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 index 156d62dbd..76002848e 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 @@ -5,722 +5,720 @@ PURE subroutine QP_Tetrahedron_Order19(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 715) nrow=4;ncol= 715 - ans = RESHAPE([ & - & 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333, & - & 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333, & - & 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333, & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 & - & ], [4, 715]) +ans(1:nrow, 1) = [ 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333 ] +ans(1:nrow, 2) = [ 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333 ] +ans(1:nrow, 3) = [ 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333 ] +ans(1:nrow, 4) = [ 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 5) = [ 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 6) = [ 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 7) = [ 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 8) = [ 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 9) = [ 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 10) = [ 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 11) = [ 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333 ] +ans(1:nrow, 12) = [ 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333 ] +ans(1:nrow, 13) = [ 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 14) = [ 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 15) = [ 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 16) = [ 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 17) = [ 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 18) = [ 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 19) = [ 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 20) = [ 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333 ] +ans(1:nrow, 21) = [ 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 22) = [ 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 23) = [ 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 24) = [ 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 25) = [ 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 26) = [ 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 27) = [ 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 28) = [ 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 29) = [ 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 30) = [ 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 31) = [ 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 32) = [ 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 33) = [ 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 34) = [ 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 35) = [ 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 36) = [ 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 37) = [ 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 38) = [ 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 39) = [ 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 40) = [ 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 41) = [ 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 42) = [ 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 43) = [ 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 44) = [ 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 45) = [ 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 46) = [ 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 47) = [ 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 48) = [ 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 49) = [ 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 50) = [ 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 51) = [ 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 52) = [ 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 53) = [ 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 54) = [ 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 55) = [ 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 56) = [ 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333 ] +ans(1:nrow, 57) = [ 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333 ] +ans(1:nrow, 58) = [ 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 59) = [ 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 60) = [ 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 61) = [ 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 62) = [ 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 63) = [ 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 64) = [ 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 65) = [ 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333 ] +ans(1:nrow, 66) = [ 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 67) = [ 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 68) = [ 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 69) = [ 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 70) = [ 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 71) = [ 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 72) = [ 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 73) = [ 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 74) = [ 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 75) = [ 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 76) = [ 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 77) = [ 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 78) = [ 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 79) = [ 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 80) = [ 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 81) = [ 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 82) = [ 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 83) = [ 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 84) = [ 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 85) = [ 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 86) = [ 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 87) = [ 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 88) = [ 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 89) = [ 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 90) = [ 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 91) = [ 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 92) = [ 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 93) = [ 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 94) = [ 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 95) = [ 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 96) = [ 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 97) = [ 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 98) = [ 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 99) = [ 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 100) = [ 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 101) = [ 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333 ] +ans(1:nrow, 102) = [ 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 103) = [ 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 104) = [ 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 105) = [ 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 106) = [ 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 107) = [ 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 108) = [ 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 109) = [ 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 110) = [ 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 111) = [ 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 112) = [ 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 113) = [ 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 114) = [ 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 115) = [ 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 116) = [ 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 117) = [ 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 118) = [ 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 119) = [ 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 120) = [ 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 121) = [ 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 122) = [ 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 123) = [ 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 124) = [ 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 125) = [ 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 126) = [ 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 127) = [ 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 128) = [ 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 129) = [ 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 130) = [ 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 131) = [ 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 132) = [ 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 133) = [ 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 134) = [ 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 135) = [ 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 136) = [ 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 137) = [ 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ] +ans(1:nrow, 138) = [ 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 139) = [ 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 140) = [ 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 141) = [ 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 142) = [ 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 143) = [ 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 144) = [ 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 145) = [ 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 146) = [ 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 147) = [ 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 148) = [ 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 149) = [ 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 150) = [ 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 151) = [ 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 152) = [ 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 153) = [ 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 154) = [ 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 155) = [ 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 156) = [ 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 157) = [ 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 158) = [ 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 159) = [ 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 160) = [ 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 161) = [ 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 162) = [ 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 163) = [ 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 164) = [ 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 165) = [ 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ] +ans(1:nrow, 166) = [ 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 167) = [ 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 168) = [ 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 169) = [ 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 170) = [ 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 171) = [ 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 172) = [ 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 173) = [ 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 174) = [ 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 175) = [ 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 176) = [ 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 177) = [ 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 178) = [ 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 179) = [ 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 180) = [ 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 181) = [ 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 182) = [ 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 183) = [ 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 184) = [ 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 185) = [ 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 186) = [ 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ] +ans(1:nrow, 187) = [ 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 188) = [ 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 189) = [ 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 190) = [ 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 191) = [ 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 192) = [ 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 193) = [ 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 194) = [ 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 195) = [ 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 196) = [ 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 197) = [ 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 198) = [ 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 199) = [ 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 200) = [ 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 201) = [ 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ] +ans(1:nrow, 202) = [ 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 203) = [ 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 204) = [ 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 205) = [ 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 206) = [ 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 207) = [ 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 208) = [ 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 209) = [ 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 210) = [ 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 211) = [ 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ] +ans(1:nrow, 212) = [ 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 213) = [ 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 214) = [ 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 215) = [ 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 216) = [ 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 217) = [ 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ] +ans(1:nrow, 218) = [ 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 219) = [ 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 220) = [ 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ] +ans(1:nrow, 221) = [ 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333 ] +ans(1:nrow, 222) = [ 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333 ] +ans(1:nrow, 223) = [ 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333 ] +ans(1:nrow, 224) = [ 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 225) = [ 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 226) = [ 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 227) = [ 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 228) = [ 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 229) = [ 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 230) = [ 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333 ] +ans(1:nrow, 231) = [ 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333 ] +ans(1:nrow, 232) = [ 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 233) = [ 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 234) = [ 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 235) = [ 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 236) = [ 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 237) = [ 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 238) = [ 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333 ] +ans(1:nrow, 239) = [ 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 240) = [ 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 241) = [ 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 242) = [ 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 243) = [ 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 244) = [ 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 245) = [ 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 246) = [ 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 247) = [ 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 248) = [ 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 249) = [ 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 250) = [ 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 251) = [ 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 252) = [ 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 253) = [ 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 254) = [ 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 255) = [ 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 256) = [ 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 257) = [ 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 258) = [ 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 259) = [ 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 260) = [ 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 261) = [ 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 262) = [ 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 263) = [ 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 264) = [ 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 265) = [ 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 266) = [ 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333 ] +ans(1:nrow, 267) = [ 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333 ] +ans(1:nrow, 268) = [ 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 269) = [ 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 270) = [ 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 271) = [ 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 272) = [ 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 273) = [ 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 274) = [ 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333 ] +ans(1:nrow, 275) = [ 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 276) = [ 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 277) = [ 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 278) = [ 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 279) = [ 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 280) = [ 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 281) = [ 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 282) = [ 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 283) = [ 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 284) = [ 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 285) = [ 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 286) = [ 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 287) = [ 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 288) = [ 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 289) = [ 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 290) = [ 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 291) = [ 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 292) = [ 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 293) = [ 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 294) = [ 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 295) = [ 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 296) = [ 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 297) = [ 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 298) = [ 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 299) = [ 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 300) = [ 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 301) = [ 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 302) = [ 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333 ] +ans(1:nrow, 303) = [ 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 304) = [ 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 305) = [ 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 306) = [ 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 307) = [ 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 308) = [ 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 309) = [ 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 310) = [ 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 311) = [ 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 312) = [ 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 313) = [ 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 314) = [ 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 315) = [ 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 316) = [ 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 317) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 318) = [ 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 319) = [ 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 320) = [ 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 321) = [ 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 322) = [ 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 323) = [ 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 324) = [ 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 325) = [ 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 326) = [ 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 327) = [ 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 328) = [ 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 329) = [ 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 330) = [ 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ] +ans(1:nrow, 331) = [ 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 332) = [ 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 333) = [ 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 334) = [ 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 335) = [ 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 336) = [ 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 337) = [ 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 338) = [ 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 339) = [ 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 340) = [ 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 341) = [ 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 342) = [ 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 343) = [ 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 344) = [ 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 345) = [ 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 346) = [ 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 347) = [ 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 348) = [ 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 349) = [ 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 350) = [ 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 351) = [ 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ] +ans(1:nrow, 352) = [ 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 353) = [ 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 354) = [ 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 355) = [ 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 356) = [ 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 357) = [ 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 358) = [ 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 359) = [ 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 360) = [ 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 361) = [ 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 362) = [ 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 363) = [ 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 364) = [ 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 365) = [ 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 366) = [ 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ] +ans(1:nrow, 367) = [ 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 368) = [ 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 369) = [ 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 370) = [ 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 371) = [ 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 372) = [ 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 373) = [ 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 374) = [ 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 375) = [ 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 376) = [ 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ] +ans(1:nrow, 377) = [ 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 378) = [ 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 379) = [ 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 380) = [ 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 381) = [ 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 382) = [ 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ] +ans(1:nrow, 383) = [ 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 384) = [ 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 385) = [ 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ] +ans(1:nrow, 386) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333 ] +ans(1:nrow, 387) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333 ] +ans(1:nrow, 388) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333 ] +ans(1:nrow, 389) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 390) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 391) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 392) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 393) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 394) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333 ] +ans(1:nrow, 395) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333 ] +ans(1:nrow, 396) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 397) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 398) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 399) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 400) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 401) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333 ] +ans(1:nrow, 402) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 403) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 404) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 405) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 406) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 407) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 408) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 409) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 410) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 411) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 412) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 413) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 414) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 415) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 416) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 417) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 418) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 419) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 420) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 421) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 422) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333 ] +ans(1:nrow, 423) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333 ] +ans(1:nrow, 424) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 425) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 426) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 427) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 428) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 429) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333 ] +ans(1:nrow, 430) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 431) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 432) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 433) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 434) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 435) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 436) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 437) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 438) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 439) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 440) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 441) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 442) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 443) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 444) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 445) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 446) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 447) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 448) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 449) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 450) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333 ] +ans(1:nrow, 451) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 452) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 453) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 454) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 455) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 456) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 457) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 458) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 459) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 460) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 461) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 462) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 463) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 464) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 465) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 466) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 467) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 468) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 469) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 470) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 471) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ] +ans(1:nrow, 472) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 473) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 474) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 475) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 476) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 477) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 478) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 479) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 480) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 481) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 482) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 483) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 484) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 485) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 486) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ] +ans(1:nrow, 487) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 488) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 489) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 490) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 491) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 492) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 493) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 494) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 495) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 496) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ] +ans(1:nrow, 497) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 498) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 499) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 500) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 501) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 502) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ] +ans(1:nrow, 503) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 504) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 505) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ] +ans(1:nrow, 506) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667 ] +ans(1:nrow, 507) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667 ] +ans(1:nrow, 508) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667 ] +ans(1:nrow, 509) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 510) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 511) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 512) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 513) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667 ] +ans(1:nrow, 514) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667 ] +ans(1:nrow, 515) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 516) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 517) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 518) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 519) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667 ] +ans(1:nrow, 520) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 521) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 522) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 523) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 524) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 525) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 526) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 527) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 528) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 529) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 530) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 531) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 532) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 533) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 534) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667 ] +ans(1:nrow, 535) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667 ] +ans(1:nrow, 536) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 537) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 538) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 539) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 540) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667 ] +ans(1:nrow, 541) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 542) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 543) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 544) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 545) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 546) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 547) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 548) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 549) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 550) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 551) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 552) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 553) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 554) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 555) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667 ] +ans(1:nrow, 556) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 557) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 558) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 559) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 560) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 561) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 562) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 563) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 564) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 565) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 566) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 567) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 568) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 569) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 570) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ] +ans(1:nrow, 571) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 572) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 573) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 574) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 575) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 576) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 577) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 578) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 579) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 580) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ] +ans(1:nrow, 581) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 582) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 583) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 584) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 585) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 586) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ] +ans(1:nrow, 587) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 588) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 589) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ] +ans(1:nrow, 590) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000 ] +ans(1:nrow, 591) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000 ] +ans(1:nrow, 592) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000 ] +ans(1:nrow, 593) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 594) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 595) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 596) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000 ] +ans(1:nrow, 597) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000 ] +ans(1:nrow, 598) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 599) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 600) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 601) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000 ] +ans(1:nrow, 602) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 603) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 604) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 605) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 606) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 607) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 608) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 609) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 610) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 611) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000 ] +ans(1:nrow, 612) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000 ] +ans(1:nrow, 613) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 614) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 615) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 616) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000 ] +ans(1:nrow, 617) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 618) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 619) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 620) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 621) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 622) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 623) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 624) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 625) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 626) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000 ] +ans(1:nrow, 627) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 628) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 629) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 630) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 631) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 632) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 633) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 634) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 635) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 636) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ] +ans(1:nrow, 637) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 638) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 639) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 640) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 641) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 642) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ] +ans(1:nrow, 643) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 644) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 645) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ] +ans(1:nrow, 646) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667 ] +ans(1:nrow, 647) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667 ] +ans(1:nrow, 648) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667 ] +ans(1:nrow, 649) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 650) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 651) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667 ] +ans(1:nrow, 652) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667 ] +ans(1:nrow, 653) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 654) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 655) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667 ] +ans(1:nrow, 656) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 657) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 658) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 659) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 660) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 661) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667 ] +ans(1:nrow, 662) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667 ] +ans(1:nrow, 663) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 664) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 665) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667 ] +ans(1:nrow, 666) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 667) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 668) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 669) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 670) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 671) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667 ] +ans(1:nrow, 672) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 673) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 674) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 675) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 676) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 677) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ] +ans(1:nrow, 678) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 679) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 680) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ] +ans(1:nrow, 681) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850 ] +ans(1:nrow, 682) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850 ] +ans(1:nrow, 683) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850 ] +ans(1:nrow, 684) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 685) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850 ] +ans(1:nrow, 686) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850 ] +ans(1:nrow, 687) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 688) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850 ] +ans(1:nrow, 689) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 690) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 691) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850 ] +ans(1:nrow, 692) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850 ] +ans(1:nrow, 693) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 694) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850 ] +ans(1:nrow, 695) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 696) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 697) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850 ] +ans(1:nrow, 698) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 699) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 700) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ] +ans(1:nrow, 701) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05 ] +ans(1:nrow, 702) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05 ] +ans(1:nrow, 703) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05 ] +ans(1:nrow, 704) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05 ] +ans(1:nrow, 705) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05 ] +ans(1:nrow, 706) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05 ] +ans(1:nrow, 707) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05 ] +ans(1:nrow, 708) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05 ] +ans(1:nrow, 709) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05 ] +ans(1:nrow, 710) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05 ] +ans(1:nrow, 711) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07 ] +ans(1:nrow, 712) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07 ] +ans(1:nrow, 713) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07 ] +ans(1:nrow, 714) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07 ] +ans(1:nrow, 715) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 ] END subroutine QP_Tetrahedron_Order19 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 index b1daf12b7..a513352e7 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 @@ -5,1008 +5,1006 @@ PURE subroutine QP_Tetrahedron_Order21(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 1001) nrow=4;ncol= 1001 - ans = RESHAPE([ & - & 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500, & - & 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500, & - & 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500, & - & 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667, & - & 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667, & - & 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667, & - & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, & - & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000, & - & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000, & - & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000, & - & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, & - & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, & - & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333, & - & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333, & - & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333, & - & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & - & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550, & - & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550, & - & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550, & - & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, & - & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, & - & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08, & - & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08, & - & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & - & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, & - & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 & - & ], [4, 1001]) +ans(1:nrow, 1) = [ 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500 ] +ans(1:nrow, 2) = [ 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500 ] +ans(1:nrow, 3) = [ 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500 ] +ans(1:nrow, 4) = [ 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 5) = [ 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 6) = [ 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 7) = [ 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 8) = [ 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 9) = [ 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 10) = [ 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 11) = [ 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 12) = [ 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500 ] +ans(1:nrow, 13) = [ 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500 ] +ans(1:nrow, 14) = [ 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 15) = [ 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 16) = [ 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 17) = [ 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 18) = [ 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 19) = [ 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 20) = [ 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 21) = [ 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 22) = [ 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500 ] +ans(1:nrow, 23) = [ 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 24) = [ 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 25) = [ 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 26) = [ 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 27) = [ 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 28) = [ 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 29) = [ 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 30) = [ 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 31) = [ 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 32) = [ 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 33) = [ 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 34) = [ 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 35) = [ 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 36) = [ 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 37) = [ 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 38) = [ 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 39) = [ 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 40) = [ 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 41) = [ 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 42) = [ 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 43) = [ 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 44) = [ 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 45) = [ 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 46) = [ 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 47) = [ 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 48) = [ 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 49) = [ 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 50) = [ 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 51) = [ 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 52) = [ 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 53) = [ 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 54) = [ 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 55) = [ 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 56) = [ 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 57) = [ 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 58) = [ 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 59) = [ 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 60) = [ 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 61) = [ 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 62) = [ 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 63) = [ 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 64) = [ 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 65) = [ 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 66) = [ 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 67) = [ 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500 ] +ans(1:nrow, 68) = [ 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500 ] +ans(1:nrow, 69) = [ 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 70) = [ 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 71) = [ 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 72) = [ 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 73) = [ 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 74) = [ 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 75) = [ 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 76) = [ 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 77) = [ 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500 ] +ans(1:nrow, 78) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 79) = [ 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 80) = [ 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 81) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 82) = [ 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 83) = [ 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 84) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 85) = [ 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 86) = [ 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 87) = [ 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 88) = [ 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 89) = [ 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 90) = [ 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 91) = [ 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 92) = [ 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 93) = [ 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 94) = [ 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 95) = [ 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 96) = [ 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 97) = [ 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 98) = [ 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 99) = [ 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 100) = [ 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 101) = [ 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 102) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 103) = [ 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 104) = [ 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 105) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 106) = [ 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 107) = [ 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 108) = [ 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 109) = [ 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 110) = [ 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 111) = [ 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 112) = [ 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 113) = [ 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 114) = [ 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 115) = [ 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 116) = [ 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 117) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 118) = [ 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 119) = [ 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 120) = [ 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 121) = [ 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 122) = [ 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500 ] +ans(1:nrow, 123) = [ 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 124) = [ 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 125) = [ 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 126) = [ 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 127) = [ 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 128) = [ 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 129) = [ 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 130) = [ 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 131) = [ 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 132) = [ 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 133) = [ 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 134) = [ 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 135) = [ 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 136) = [ 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 137) = [ 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 138) = [ 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 139) = [ 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 140) = [ 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 141) = [ 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 142) = [ 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 143) = [ 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 144) = [ 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 145) = [ 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 146) = [ 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 147) = [ 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 148) = [ 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 149) = [ 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 150) = [ 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 151) = [ 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 152) = [ 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 153) = [ 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 154) = [ 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 155) = [ 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 156) = [ 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 157) = [ 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 158) = [ 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 159) = [ 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 160) = [ 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 161) = [ 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 162) = [ 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 163) = [ 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 164) = [ 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 165) = [ 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 166) = [ 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 167) = [ 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ] +ans(1:nrow, 168) = [ 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 169) = [ 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 170) = [ 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 171) = [ 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 172) = [ 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 173) = [ 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 174) = [ 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 175) = [ 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 176) = [ 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 177) = [ 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 178) = [ 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 179) = [ 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 180) = [ 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 181) = [ 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 182) = [ 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 183) = [ 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 184) = [ 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 185) = [ 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 186) = [ 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 187) = [ 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 188) = [ 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 189) = [ 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 190) = [ 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 191) = [ 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 192) = [ 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 193) = [ 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 194) = [ 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 195) = [ 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 196) = [ 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 197) = [ 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 198) = [ 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 199) = [ 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 200) = [ 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 201) = [ 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 202) = [ 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 203) = [ 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ] +ans(1:nrow, 204) = [ 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 205) = [ 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 206) = [ 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 207) = [ 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 208) = [ 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 209) = [ 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 210) = [ 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 211) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 212) = [ 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 213) = [ 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 214) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 215) = [ 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 216) = [ 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 217) = [ 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 218) = [ 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 219) = [ 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 220) = [ 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 221) = [ 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 222) = [ 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 223) = [ 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 224) = [ 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 225) = [ 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 226) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 227) = [ 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 228) = [ 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 229) = [ 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 230) = [ 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 231) = [ 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ] +ans(1:nrow, 232) = [ 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 233) = [ 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 234) = [ 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 235) = [ 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 236) = [ 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 237) = [ 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 238) = [ 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 239) = [ 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 240) = [ 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 241) = [ 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 242) = [ 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 243) = [ 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 244) = [ 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 245) = [ 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 246) = [ 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 247) = [ 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 248) = [ 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 249) = [ 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 250) = [ 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 251) = [ 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 252) = [ 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ] +ans(1:nrow, 253) = [ 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 254) = [ 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 255) = [ 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 256) = [ 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 257) = [ 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 258) = [ 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 259) = [ 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 260) = [ 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 261) = [ 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 262) = [ 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 263) = [ 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 264) = [ 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 265) = [ 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 266) = [ 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 267) = [ 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ] +ans(1:nrow, 268) = [ 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 269) = [ 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 270) = [ 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 271) = [ 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 272) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 273) = [ 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 274) = [ 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 275) = [ 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 276) = [ 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 277) = [ 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ] +ans(1:nrow, 278) = [ 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 279) = [ 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 280) = [ 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 281) = [ 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 282) = [ 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 283) = [ 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ] +ans(1:nrow, 284) = [ 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 285) = [ 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 286) = [ 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ] +ans(1:nrow, 287) = [ 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667 ] +ans(1:nrow, 288) = [ 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667 ] +ans(1:nrow, 289) = [ 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667 ] +ans(1:nrow, 290) = [ 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 291) = [ 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 292) = [ 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 293) = [ 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 294) = [ 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 295) = [ 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 296) = [ 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 297) = [ 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667 ] +ans(1:nrow, 298) = [ 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667 ] +ans(1:nrow, 299) = [ 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 300) = [ 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 301) = [ 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 302) = [ 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 303) = [ 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 304) = [ 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 305) = [ 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 306) = [ 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667 ] +ans(1:nrow, 307) = [ 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 308) = [ 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 309) = [ 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 310) = [ 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 311) = [ 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 312) = [ 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 313) = [ 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 314) = [ 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 315) = [ 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 316) = [ 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 317) = [ 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 318) = [ 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 319) = [ 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 320) = [ 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 321) = [ 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 322) = [ 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 323) = [ 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 324) = [ 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 325) = [ 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 326) = [ 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 327) = [ 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 328) = [ 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 329) = [ 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 330) = [ 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 331) = [ 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 332) = [ 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 333) = [ 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 334) = [ 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 335) = [ 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 336) = [ 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 337) = [ 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 338) = [ 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 339) = [ 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 340) = [ 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 341) = [ 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 342) = [ 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667 ] +ans(1:nrow, 343) = [ 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667 ] +ans(1:nrow, 344) = [ 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 345) = [ 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 346) = [ 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 347) = [ 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 348) = [ 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 349) = [ 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 350) = [ 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 351) = [ 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667 ] +ans(1:nrow, 352) = [ 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 353) = [ 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 354) = [ 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 355) = [ 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 356) = [ 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 357) = [ 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 358) = [ 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 359) = [ 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 360) = [ 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 361) = [ 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 362) = [ 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 363) = [ 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 364) = [ 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 365) = [ 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 366) = [ 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 367) = [ 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 368) = [ 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 369) = [ 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 370) = [ 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 371) = [ 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 372) = [ 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 373) = [ 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 374) = [ 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 375) = [ 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 376) = [ 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 377) = [ 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 378) = [ 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 379) = [ 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 380) = [ 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 381) = [ 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 382) = [ 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 383) = [ 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 384) = [ 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 385) = [ 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 386) = [ 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 387) = [ 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667 ] +ans(1:nrow, 388) = [ 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 389) = [ 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 390) = [ 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 391) = [ 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 392) = [ 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 393) = [ 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 394) = [ 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 395) = [ 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 396) = [ 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 397) = [ 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 398) = [ 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 399) = [ 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 400) = [ 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 401) = [ 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 402) = [ 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 403) = [ 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 404) = [ 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 405) = [ 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 406) = [ 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 407) = [ 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 408) = [ 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 409) = [ 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 410) = [ 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 411) = [ 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 412) = [ 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 413) = [ 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 414) = [ 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 415) = [ 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 416) = [ 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 417) = [ 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 418) = [ 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 419) = [ 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 420) = [ 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 421) = [ 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 422) = [ 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 423) = [ 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ] +ans(1:nrow, 424) = [ 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 425) = [ 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 426) = [ 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 427) = [ 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 428) = [ 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 429) = [ 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 430) = [ 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 431) = [ 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 432) = [ 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 433) = [ 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 434) = [ 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 435) = [ 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 436) = [ 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 437) = [ 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 438) = [ 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 439) = [ 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 440) = [ 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 441) = [ 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 442) = [ 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 443) = [ 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 444) = [ 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 445) = [ 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 446) = [ 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 447) = [ 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 448) = [ 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 449) = [ 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 450) = [ 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 451) = [ 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ] +ans(1:nrow, 452) = [ 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 453) = [ 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 454) = [ 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 455) = [ 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 456) = [ 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 457) = [ 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 458) = [ 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 459) = [ 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 460) = [ 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 461) = [ 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 462) = [ 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 463) = [ 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 464) = [ 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 465) = [ 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 466) = [ 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 467) = [ 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 468) = [ 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 469) = [ 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 470) = [ 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 471) = [ 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 472) = [ 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ] +ans(1:nrow, 473) = [ 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 474) = [ 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 475) = [ 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 476) = [ 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 477) = [ 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 478) = [ 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 479) = [ 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 480) = [ 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 481) = [ 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 482) = [ 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 483) = [ 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 484) = [ 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 485) = [ 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 486) = [ 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 487) = [ 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ] +ans(1:nrow, 488) = [ 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 489) = [ 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 490) = [ 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 491) = [ 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 492) = [ 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 493) = [ 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 494) = [ 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 495) = [ 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 496) = [ 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 497) = [ 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ] +ans(1:nrow, 498) = [ 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 499) = [ 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 500) = [ 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 501) = [ 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 502) = [ 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 503) = [ 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ] +ans(1:nrow, 504) = [ 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 505) = [ 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 506) = [ 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ] +ans(1:nrow, 507) = [ 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000 ] +ans(1:nrow, 508) = [ 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000 ] +ans(1:nrow, 509) = [ 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000 ] +ans(1:nrow, 510) = [ 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 511) = [ 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 512) = [ 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 513) = [ 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 514) = [ 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 515) = [ 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 516) = [ 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000 ] +ans(1:nrow, 517) = [ 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000 ] +ans(1:nrow, 518) = [ 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 519) = [ 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 520) = [ 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 521) = [ 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 522) = [ 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 523) = [ 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 524) = [ 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000 ] +ans(1:nrow, 525) = [ 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 526) = [ 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 527) = [ 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 528) = [ 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 529) = [ 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 530) = [ 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 531) = [ 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 532) = [ 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 533) = [ 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 534) = [ 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 535) = [ 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 536) = [ 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 537) = [ 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 538) = [ 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 539) = [ 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 540) = [ 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 541) = [ 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 542) = [ 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 543) = [ 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 544) = [ 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 545) = [ 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 546) = [ 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 547) = [ 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 548) = [ 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 549) = [ 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 550) = [ 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 551) = [ 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 552) = [ 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000 ] +ans(1:nrow, 553) = [ 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000 ] +ans(1:nrow, 554) = [ 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 555) = [ 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 556) = [ 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 557) = [ 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 558) = [ 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 559) = [ 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 560) = [ 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000 ] +ans(1:nrow, 561) = [ 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 562) = [ 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 563) = [ 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 564) = [ 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 565) = [ 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 566) = [ 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 567) = [ 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 568) = [ 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 569) = [ 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 570) = [ 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 571) = [ 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 572) = [ 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 573) = [ 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 574) = [ 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 575) = [ 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 576) = [ 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 577) = [ 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 578) = [ 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 579) = [ 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 580) = [ 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 581) = [ 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 582) = [ 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 583) = [ 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 584) = [ 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 585) = [ 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 586) = [ 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 587) = [ 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 588) = [ 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000 ] +ans(1:nrow, 589) = [ 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 590) = [ 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 591) = [ 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 592) = [ 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 593) = [ 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 594) = [ 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 595) = [ 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 596) = [ 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 597) = [ 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 598) = [ 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 599) = [ 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 600) = [ 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 601) = [ 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 602) = [ 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 603) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 604) = [ 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 605) = [ 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 606) = [ 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 607) = [ 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 608) = [ 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 609) = [ 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 610) = [ 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 611) = [ 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 612) = [ 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 613) = [ 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 614) = [ 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 615) = [ 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 616) = [ 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ] +ans(1:nrow, 617) = [ 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 618) = [ 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 619) = [ 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 620) = [ 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 621) = [ 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 622) = [ 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 623) = [ 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 624) = [ 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 625) = [ 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 626) = [ 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 627) = [ 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 628) = [ 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 629) = [ 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 630) = [ 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 631) = [ 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 632) = [ 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 633) = [ 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 634) = [ 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 635) = [ 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 636) = [ 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 637) = [ 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ] +ans(1:nrow, 638) = [ 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 639) = [ 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 640) = [ 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 641) = [ 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 642) = [ 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 643) = [ 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 644) = [ 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 645) = [ 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 646) = [ 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 647) = [ 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 648) = [ 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 649) = [ 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 650) = [ 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 651) = [ 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 652) = [ 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ] +ans(1:nrow, 653) = [ 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 654) = [ 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 655) = [ 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 656) = [ 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 657) = [ 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 658) = [ 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 659) = [ 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 660) = [ 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 661) = [ 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 662) = [ 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ] +ans(1:nrow, 663) = [ 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 664) = [ 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 665) = [ 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 666) = [ 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 667) = [ 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 668) = [ 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ] +ans(1:nrow, 669) = [ 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 670) = [ 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 671) = [ 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ] +ans(1:nrow, 672) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000 ] +ans(1:nrow, 673) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000 ] +ans(1:nrow, 674) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000 ] +ans(1:nrow, 675) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 676) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 677) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 678) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 679) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 680) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000 ] +ans(1:nrow, 681) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000 ] +ans(1:nrow, 682) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 683) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 684) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 685) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 686) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 687) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000 ] +ans(1:nrow, 688) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 689) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 690) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 691) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 692) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 693) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 694) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 695) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 696) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 697) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 698) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 699) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 700) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 701) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 702) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 703) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 704) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 705) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 706) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 707) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 708) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000 ] +ans(1:nrow, 709) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000 ] +ans(1:nrow, 710) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 711) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 712) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 713) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 714) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 715) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000 ] +ans(1:nrow, 716) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 717) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 718) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 719) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 720) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 721) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 722) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 723) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 724) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 725) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 726) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 727) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 728) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 729) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 730) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 731) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 732) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 733) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 734) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 735) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 736) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000 ] +ans(1:nrow, 737) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 738) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 739) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 740) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 741) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 742) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 743) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 744) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 745) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 746) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 747) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 748) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 749) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 750) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 751) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 752) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 753) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 754) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 755) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 756) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 757) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ] +ans(1:nrow, 758) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 759) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 760) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 761) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 762) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 763) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 764) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 765) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 766) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 767) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 768) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 769) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 770) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 771) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 772) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ] +ans(1:nrow, 773) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 774) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 775) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 776) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 777) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 778) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 779) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 780) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 781) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 782) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ] +ans(1:nrow, 783) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 784) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 785) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 786) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 787) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 788) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ] +ans(1:nrow, 789) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 790) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 791) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ] +ans(1:nrow, 792) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000 ] +ans(1:nrow, 793) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000 ] +ans(1:nrow, 794) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000 ] +ans(1:nrow, 795) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 796) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 797) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 798) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 799) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000 ] +ans(1:nrow, 800) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000 ] +ans(1:nrow, 801) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 802) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 803) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 804) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 805) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000 ] +ans(1:nrow, 806) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 807) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 808) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 809) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 810) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 811) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 812) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 813) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 814) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 815) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 816) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 817) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 818) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 819) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 820) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000 ] +ans(1:nrow, 821) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000 ] +ans(1:nrow, 822) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 823) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 824) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 825) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 826) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000 ] +ans(1:nrow, 827) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 828) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 829) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 830) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 831) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 832) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 833) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 834) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 835) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 836) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 837) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 838) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 839) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 840) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 841) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000 ] +ans(1:nrow, 842) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 843) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 844) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 845) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 846) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 847) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 848) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 849) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 850) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 851) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 852) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 853) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 854) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 855) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 856) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ] +ans(1:nrow, 857) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 858) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 859) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 860) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 861) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 862) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 863) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 864) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 865) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 866) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ] +ans(1:nrow, 867) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 868) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 869) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 870) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 871) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 872) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ] +ans(1:nrow, 873) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 874) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 875) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ] +ans(1:nrow, 876) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333 ] +ans(1:nrow, 877) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333 ] +ans(1:nrow, 878) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333 ] +ans(1:nrow, 879) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 880) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 881) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 882) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333 ] +ans(1:nrow, 883) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333 ] +ans(1:nrow, 884) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 885) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 886) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 887) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333 ] +ans(1:nrow, 888) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 889) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 890) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 891) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 892) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 893) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 894) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 895) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 896) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 897) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333 ] +ans(1:nrow, 898) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333 ] +ans(1:nrow, 899) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 900) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 901) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 902) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333 ] +ans(1:nrow, 903) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 904) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 905) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 906) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 907) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 908) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 909) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 910) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 911) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 912) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333 ] +ans(1:nrow, 913) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 914) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 915) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 916) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 917) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 918) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 919) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 920) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 921) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 922) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ] +ans(1:nrow, 923) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 924) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 925) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 926) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 927) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 928) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ] +ans(1:nrow, 929) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 930) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 931) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ] +ans(1:nrow, 932) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550 ] +ans(1:nrow, 933) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550 ] +ans(1:nrow, 934) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550 ] +ans(1:nrow, 935) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 936) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 937) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550 ] +ans(1:nrow, 938) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550 ] +ans(1:nrow, 939) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 940) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 941) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550 ] +ans(1:nrow, 942) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 943) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 944) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 945) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 946) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 947) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550 ] +ans(1:nrow, 948) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550 ] +ans(1:nrow, 949) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 950) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 951) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550 ] +ans(1:nrow, 952) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 953) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 954) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 955) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 956) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 957) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550 ] +ans(1:nrow, 958) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 959) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 960) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 961) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 962) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 963) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ] +ans(1:nrow, 964) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 965) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 966) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ] +ans(1:nrow, 967) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878 ] +ans(1:nrow, 968) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878 ] +ans(1:nrow, 969) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878 ] +ans(1:nrow, 970) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 971) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878 ] +ans(1:nrow, 972) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878 ] +ans(1:nrow, 973) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 974) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878 ] +ans(1:nrow, 975) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 976) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 977) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878 ] +ans(1:nrow, 978) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878 ] +ans(1:nrow, 979) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 980) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878 ] +ans(1:nrow, 981) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 982) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 983) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878 ] +ans(1:nrow, 984) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 985) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 986) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ] +ans(1:nrow, 987) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05 ] +ans(1:nrow, 988) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05 ] +ans(1:nrow, 989) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05 ] +ans(1:nrow, 990) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05 ] +ans(1:nrow, 991) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05 ] +ans(1:nrow, 992) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05 ] +ans(1:nrow, 993) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05 ] +ans(1:nrow, 994) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05 ] +ans(1:nrow, 995) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05 ] +ans(1:nrow, 996) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05 ] +ans(1:nrow, 997) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08 ] +ans(1:nrow, 998) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08 ] +ans(1:nrow, 999) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08 ] +ans(1:nrow, 1000) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08 ] +ans(1:nrow, 1001) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 ] END subroutine QP_Tetrahedron_Order21 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 index 8157b586d..5b1a8632b 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 @@ -6,17 +6,16 @@ PURE SUBROUTINE QP_Tetrahedron_Order4(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 11) nrow = 4; ncol = 11 - ans = RESHAPE([ & - & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555, & - & 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222, & - & 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222, & - & 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222, & - & 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222, & - & 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888, & - & 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888, & - & 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888, & - & 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888, & - & 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888, & - & 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 & - & ], [4, 11]) +ans(1:nrow, 1) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555 ] +ans(1:nrow, 2) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222 ] +ans(1:nrow, 3) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222 ] +ans(1:nrow, 4) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222 ] +ans(1:nrow, 5) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222 ] +ans(1:nrow, 6) = [ 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888 ] +ans(1:nrow, 7) = [ 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888 ] +ans(1:nrow, 8) = [ 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888 ] +ans(1:nrow, 9) = [ 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888 ] +ans(1:nrow, 10) = [ 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888 ] +ans(1:nrow, 11) = [ 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 ] + END SUBROUTINE QP_Tetrahedron_Order4 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 index 7e674928a..09336ae93 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 @@ -5,20 +5,19 @@ PURE SUBROUTINE QP_Tetrahedron_Order5(ans, nrow, ncol) nrow = 4; ncol = 14 - ans = RESHAPE([ & - & 0.0927352503109, 0.0927352503109, 0.0927352503109, 0.01224884051940, & - & 0.7217942490670, 0.0927352503109, 0.0927352503109, 0.01224884051940, & - & 0.0927352503109, 0.7217942490670, 0.0927352503109, 0.01224884051940, & - & 0.0927352503109, 0.0927352503109, 0.7217942490670, 0.01224884051940, & - & 0.3108859192630, 0.3108859192630, 0.3108859192630, 0.01878132095300, & - & 0.0673422422101, 0.3108859192630, 0.3108859192630, 0.01878132095300, & - & 0.3108859192630, 0.0673422422101, 0.3108859192630, 0.01878132095300, & - & 0.3108859192630, 0.3108859192630, 0.0673422422101, 0.01878132095300, & - & 0.4544962958740, 0.4544962958740, 0.0455037041256, 0.00709100346285, & - & 0.4544962958740, 0.0455037041256, 0.4544962958740, 0.00709100346285, & - & 0.0455037041256, 0.4544962958740, 0.4544962958740, 0.00709100346285, & - & 0.4544962958740, 0.0455037041256, 0.0455037041256, 0.00709100346285, & - & 0.0455037041256, 0.4544962958740, 0.0455037041256, 0.00709100346285, & - & 0.0455037041256, 0.0455037041256, 0.4544962958740, 0.00709100346285 & - & ], [4, 14]) +ans(1:nrow, 1) = [ 0.0927352503109, 0.0927352503109, 0.0927352503109, 0.01224884051940 ] +ans(1:nrow, 2) = [ 0.7217942490670, 0.0927352503109, 0.0927352503109, 0.01224884051940 ] +ans(1:nrow, 3) = [ 0.0927352503109, 0.7217942490670, 0.0927352503109, 0.01224884051940 ] +ans(1:nrow, 4) = [ 0.0927352503109, 0.0927352503109, 0.7217942490670, 0.01224884051940 ] +ans(1:nrow, 5) = [ 0.3108859192630, 0.3108859192630, 0.3108859192630, 0.01878132095300 ] +ans(1:nrow, 6) = [ 0.0673422422101, 0.3108859192630, 0.3108859192630, 0.01878132095300 ] +ans(1:nrow, 7) = [ 0.3108859192630, 0.0673422422101, 0.3108859192630, 0.01878132095300 ] +ans(1:nrow, 8) = [ 0.3108859192630, 0.3108859192630, 0.0673422422101, 0.01878132095300 ] +ans(1:nrow, 9) = [ 0.4544962958740, 0.4544962958740, 0.0455037041256, 0.00709100346285 ] +ans(1:nrow, 10) = [ 0.4544962958740, 0.0455037041256, 0.4544962958740, 0.00709100346285 ] +ans(1:nrow, 11) = [ 0.0455037041256, 0.4544962958740, 0.4544962958740, 0.00709100346285 ] +ans(1:nrow, 12) = [ 0.4544962958740, 0.0455037041256, 0.0455037041256, 0.00709100346285 ] +ans(1:nrow, 13) = [ 0.0455037041256, 0.4544962958740, 0.0455037041256, 0.00709100346285 ] +ans(1:nrow, 14) = [ 0.0455037041256, 0.0455037041256, 0.4544962958740, 0.0709100346285 ] + END SUBROUTINE QP_Tetrahedron_Order5 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 index 288f12e5c..decef7a90 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 @@ -6,31 +6,29 @@ PURE SUBROUTINE QP_Tetrahedron_Order6(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 24) nrow = 4; ncol = 24 - ans = RESHAPE([ & - & 0.2146028712590, 0.2146028712590, 0.2146028712590, 0.006653791709700, & - & 0.3561913862230, 0.2146028712590, 0.2146028712590, 0.006653791709700, & - & 0.2146028712590, 0.3561913862230, 0.2146028712590, 0.006653791709700, & - & 0.2146028712590, 0.2146028712590, 0.3561913862230, 0.006653791709700, & - & 0.0406739585346, 0.0406739585346, 0.0406739585346, 0.001679535175883, & - & 0.8779781243960, 0.0406739585346, 0.0406739585346, 0.001679535175883, & - & 0.0406739585346, 0.8779781243960, 0.0406739585346, 0.001679535175883, & - & 0.0406739585346, 0.0406739585346, 0.8779781243960, 0.001679535175883, & - & 0.3223378901420, 0.3223378901420, 0.3223378901420, 0.009226196923950, & - & 0.0329863295732, 0.3223378901420, 0.3223378901420, 0.009226196923950, & - & 0.3223378901420, 0.0329863295732, 0.3223378901420, 0.009226196923950, & - & 0.3223378901420, 0.3223378901420, 0.0329863295732, 0.009226196923950, & - & 0.0636610018750, 0.0636610018750, 0.2696723314580, 0.008035714285717, & - & 0.0636610018750, 0.2696723314580, 0.0636610018750, 0.008035714285717, & - & 0.0636610018750, 0.0636610018750, 0.6030056647920, 0.008035714285717, & - & 0.0636610018750, 0.6030056647920, 0.0636610018750, 0.008035714285717, & - & 0.0636610018750, 0.2696723314580, 0.6030056647920, 0.008035714285717, & - & 0.0636610018750, 0.6030056647920, 0.2696723314580, 0.008035714285717, & - & 0.2696723314580, 0.0636610018750, 0.0636610018750, 0.008035714285717, & - & 0.2696723314580, 0.0636610018750, 0.6030056647920, 0.008035714285717, & - & 0.2696723314580, 0.6030056647920, 0.0636610018750, 0.008035714285717, & - & 0.6030056647920, 0.0636610018750, 0.2696723314580, 0.008035714285717, & - & 0.6030056647920, 0.0636610018750, 0.0636610018750, 0.008035714285717, & - & 0.6030056647920, 0.2696723314580, 0.0636610018750, 0.008035714285717 & - & ], [4, 24]) +ans(1:nrow, 1) = [ 0.2146028712590, 0.2146028712590, 0.2146028712590, 0.006653791709700 ] +ans(1:nrow, 2) = [ 0.3561913862230, 0.2146028712590, 0.2146028712590, 0.006653791709700 ] +ans(1:nrow, 3) = [ 0.2146028712590, 0.3561913862230, 0.2146028712590, 0.006653791709700 ] +ans(1:nrow, 4) = [ 0.2146028712590, 0.2146028712590, 0.3561913862230, 0.006653791709700 ] +ans(1:nrow, 5) = [ 0.0406739585346, 0.0406739585346, 0.0406739585346, 0.001679535175883 ] +ans(1:nrow, 6) = [ 0.8779781243960, 0.0406739585346, 0.0406739585346, 0.001679535175883 ] +ans(1:nrow, 7) = [ 0.0406739585346, 0.8779781243960, 0.0406739585346, 0.001679535175883 ] +ans(1:nrow, 8) = [ 0.0406739585346, 0.0406739585346, 0.8779781243960, 0.001679535175883 ] +ans(1:nrow, 9) = [ 0.3223378901420, 0.3223378901420, 0.3223378901420, 0.009226196923950 ] +ans(1:nrow, 10) = [ 0.0329863295732, 0.3223378901420, 0.3223378901420, 0.009226196923950 ] +ans(1:nrow, 11) = [ 0.3223378901420, 0.0329863295732, 0.3223378901420, 0.009226196923950 ] +ans(1:nrow, 12) = [ 0.3223378901420, 0.3223378901420, 0.0329863295732, 0.009226196923950 ] +ans(1:nrow, 13) = [ 0.0636610018750, 0.0636610018750, 0.2696723314580, 0.008035714285717 ] +ans(1:nrow, 14) = [ 0.0636610018750, 0.2696723314580, 0.0636610018750, 0.008035714285717 ] +ans(1:nrow, 15) = [ 0.0636610018750, 0.0636610018750, 0.6030056647920, 0.008035714285717 ] +ans(1:nrow, 16) = [ 0.0636610018750, 0.6030056647920, 0.0636610018750, 0.008035714285717 ] +ans(1:nrow, 17) = [ 0.0636610018750, 0.2696723314580, 0.6030056647920, 0.008035714285717 ] +ans(1:nrow, 18) = [ 0.0636610018750, 0.6030056647920, 0.2696723314580, 0.008035714285717 ] +ans(1:nrow, 19) = [ 0.2696723314580, 0.0636610018750, 0.0636610018750, 0.008035714285717 ] +ans(1:nrow, 20) = [ 0.2696723314580, 0.0636610018750, 0.6030056647920, 0.008035714285717 ] +ans(1:nrow, 21) = [ 0.2696723314580, 0.6030056647920, 0.0636610018750, 0.008035714285717 ] +ans(1:nrow, 22) = [ 0.6030056647920, 0.0636610018750, 0.2696723314580, 0.008035714285717 ] +ans(1:nrow, 23) = [ 0.6030056647920, 0.0636610018750, 0.0636610018750, 0.008035714285717 ] +ans(1:nrow, 24) = [ 0.6030056647920, 0.2696723314580, 0.0636610018750, 0.08035714285717 ] END SUBROUTINE QP_Tetrahedron_Order6 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 index 92ae76869..a2954187c 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 @@ -6,38 +6,36 @@ PURE SUBROUTINE QP_Tetrahedron_Order7(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 31) nrow = 4; ncol = 31 - ans = RESHAPE([ & - & 0.50000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685, & - & 0.50000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685, & - & 0.00000000000000, 0.50000000000000, 0.50000000000000, +0.000970017636685, & - & 0.00000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685, & - & 0.00000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685, & - & 0.50000000000000, 0.00000000000000, 0.00000000000000, +0.000970017636685, & - & 0.25000000000000, 0.25000000000000, 0.25000000000000, +0.018264223466167, & - & 0.07821319233030, 0.07821319233030, 0.07821319233030, +0.010599941524417, & - & 0.07821319233030, 0.07821319233030, 0.76536042300900, +0.010599941524417, & - & 0.07821319233030, 0.76536042300900, 0.07821319233030, +0.010599941524417, & - & 0.76536042300900, 0.07821319233030, 0.07821319233030, +0.010599941524417, & - & 0.12184321666400, 0.12184321666400, 0.12184321666400, -0.062517740114333, & - & 0.12184321666400, 0.12184321666400, 0.63447035000800, -0.062517740114333, & - & 0.12184321666400, 0.63447035000800, 0.12184321666400, -0.062517740114333, & - & 0.63447035000800, 0.12184321666400, 0.12184321666400, -0.062517740114333, & - & 0.33253916444600, 0.33253916444600, 0.33253916444600, +0.004891425263067, & - & 0.33253916444600, 0.33253916444600, 0.00238250666074, +0.004891425263067, & - & 0.33253916444600, 0.00238250666074, 0.33253916444600, +0.004891425263067, & - & 0.00238250666074, 0.33253916444600, 0.33253916444600, +0.004891425263067, & - & 0.10000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000, & - & 0.10000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000, & - & 0.10000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000, & - & 0.10000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000, & - & 0.10000000000000, 0.20000000000000, 0.60000000000000, +0.027557319224000, & - & 0.10000000000000, 0.60000000000000, 0.20000000000000, +0.027557319224000, & - & 0.20000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000, & - & 0.20000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000, & - & 0.20000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000, & - & 0.60000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000, & - & 0.60000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000, & - & 0.60000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000 & - & ], [4, 31]) +ans(1:nrow, 1) = [ 0.50000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685 ] +ans(1:nrow, 2) = [ 0.50000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685 ] +ans(1:nrow, 3) = [ 0.00000000000000, 0.50000000000000, 0.50000000000000, +0.000970017636685 ] +ans(1:nrow, 4) = [ 0.00000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685 ] +ans(1:nrow, 5) = [ 0.00000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685 ] +ans(1:nrow, 6) = [ 0.50000000000000, 0.00000000000000, 0.00000000000000, +0.000970017636685 ] +ans(1:nrow, 7) = [ 0.25000000000000, 0.25000000000000, 0.25000000000000, +0.018264223466167 ] +ans(1:nrow, 8) = [ 0.07821319233030, 0.07821319233030, 0.07821319233030, +0.010599941524417 ] +ans(1:nrow, 9) = [ 0.07821319233030, 0.07821319233030, 0.76536042300900, +0.010599941524417 ] +ans(1:nrow, 10) = [ 0.07821319233030, 0.76536042300900, 0.07821319233030, +0.010599941524417 ] +ans(1:nrow, 11) = [ 0.76536042300900, 0.07821319233030, 0.07821319233030, +0.010599941524417 ] +ans(1:nrow, 12) = [ 0.12184321666400, 0.12184321666400, 0.12184321666400, -0.062517740114333 ] +ans(1:nrow, 13) = [ 0.12184321666400, 0.12184321666400, 0.63447035000800, -0.062517740114333 ] +ans(1:nrow, 14) = [ 0.12184321666400, 0.63447035000800, 0.12184321666400, -0.062517740114333 ] +ans(1:nrow, 15) = [ 0.63447035000800, 0.12184321666400, 0.12184321666400, -0.062517740114333 ] +ans(1:nrow, 16) = [ 0.33253916444600, 0.33253916444600, 0.33253916444600, +0.004891425263067 ] +ans(1:nrow, 17) = [ 0.33253916444600, 0.33253916444600, 0.00238250666074, +0.004891425263067 ] +ans(1:nrow, 18) = [ 0.33253916444600, 0.00238250666074, 0.33253916444600, +0.004891425263067 ] +ans(1:nrow, 19) = [ 0.00238250666074, 0.33253916444600, 0.33253916444600, +0.004891425263067 ] +ans(1:nrow, 20) = [ 0.10000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000 ] +ans(1:nrow, 21) = [ 0.10000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000 ] +ans(1:nrow, 22) = [ 0.10000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000 ] +ans(1:nrow, 23) = [ 0.10000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000 ] +ans(1:nrow, 24) = [ 0.10000000000000, 0.20000000000000, 0.60000000000000, +0.027557319224000 ] +ans(1:nrow, 25) = [ 0.10000000000000, 0.60000000000000, 0.20000000000000, +0.027557319224000 ] +ans(1:nrow, 26) = [ 0.20000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000 ] +ans(1:nrow, 27) = [ 0.20000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000 ] +ans(1:nrow, 28) = [ 0.20000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000 ] +ans(1:nrow, 29) = [ 0.60000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000 ] +ans(1:nrow, 30) = [ 0.60000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000 ] +ans(1:nrow, 31) = [ 0.60000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000 ] END SUBROUTINE QP_Tetrahedron_Order7 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 index 1d14bf6ab..b5c57003b 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 @@ -6,50 +6,48 @@ PURE SUBROUTINE QP_Tetrahedron_Order8(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 43) nrow = 4; ncol = 43 - ans = RESHAPE([ & - & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.020500188658667, & - & 0.2068299316110, 0.2068299316110, 0.2068299316110, +0.014250305822867, & - & 0.2068299316110, 0.2068299316110, 0.3795102051680, +0.014250305822867, & - & 0.2068299316110, 0.3795102051680, 0.2068299316110, +0.014250305822867, & - & 0.3795102051680, 0.2068299316110, 0.2068299316110, +0.014250305822867, & - & 0.0821035883105, 0.0821035883105, 0.0821035883105, +0.001967033313133, & - & 0.0821035883105, 0.0821035883105, 0.7536892350680, +0.001967033313133, & - & 0.0821035883105, 0.7536892350680, 0.0821035883105, +0.001967033313133, & - & 0.7536892350680, 0.0821035883105, 0.0821035883105, +0.001967033313133, & - & 0.0057819505052, 0.0057819505052, 0.0057819505052, +0.000169834109093, & - & 0.0057819505052, 0.0057819505052, 0.9826541484840, +0.000169834109093, & - & 0.0057819505052, 0.9826541484840, 0.0057819505052, +0.000169834109093, & - & 0.9826541484840, 0.0057819505052, 0.0057819505052, +0.000169834109093, & - & 0.0505327400189, 0.0505327400189, 0.4494672599810, +0.004579683824467, & - & 0.0505327400189, 0.4494672599810, 0.0505327400189, +0.004579683824467, & - & 0.4494672599810, 0.0505327400189, 0.0505327400189, +0.004579683824467, & - & 0.0505327400189, 0.4494672599810, 0.4494672599810, +0.004579683824467, & - & 0.4494672599810, 0.0505327400189, 0.4494672599810, +0.004579683824467, & - & 0.4494672599810, 0.4494672599810, 0.0505327400189, +0.004579683824467, & - & 0.2290665361170, 0.2290665361170, 0.0356395827885, +0.005704485808683, & - & 0.2290665361170, 0.0356395827885, 0.2290665361170, +0.005704485808683, & - & 0.2290665361170, 0.2290665361170, 0.5062273449780, +0.005704485808683, & - & 0.2290665361170, 0.5062273449780, 0.2290665361170, +0.005704485808683, & - & 0.2290665361170, 0.0356395827885, 0.5062273449780, +0.005704485808683, & - & 0.2290665361170, 0.5062273449780, 0.0356395827885, +0.005704485808683, & - & 0.0356395827885, 0.2290665361170, 0.2290665361170, +0.005704485808683, & - & 0.0356395827885, 0.2290665361170, 0.5062273449780, +0.005704485808683, & - & 0.0356395827885, 0.5062273449780, 0.2290665361170, +0.005704485808683, & - & 0.5062273449780, 0.2290665361170, 0.0356395827885, +0.005704485808683, & - & 0.5062273449780, 0.2290665361170, 0.2290665361170, +0.005704485808683, & - & 0.5062273449780, 0.0356395827885, 0.2290665361170, +0.005704485808683, & - & 0.0366077495532, 0.0366077495532, 0.1904860419350, +0.002140519141167, & - & 0.0366077495532, 0.1904860419350, 0.0366077495532, +0.002140519141167, & - & 0.0366077495532, 0.0366077495532, 0.7362984589590, +0.002140519141167, & - & 0.0366077495532, 0.7362984589590, 0.0366077495532, +0.002140519141167, & - & 0.0366077495532, 0.1904860419350, 0.7362984589590, +0.002140519141167, & - & 0.0366077495532, 0.7362984589590, 0.1904860419350, +0.002140519141167, & - & 0.1904860419350, 0.0366077495532, 0.0366077495532, +0.002140519141167, & - & 0.1904860419350, 0.0366077495532, 0.7362984589590, +0.002140519141167, & - & 0.1904860419350, 0.7362984589590, 0.0366077495532, +0.002140519141167, & - & 0.7362984589590, 0.0366077495532, 0.1904860419350, +0.002140519141167, & - & 0.7362984589590, 0.0366077495532, 0.0366077495532, +0.002140519141167, & - & 0.7362984589590, 0.1904860419350, 0.0366077495532, +0.002140519141167 & - & ], [4, 43]) +ans(1:nrow, 1) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.020500188658667 ] +ans(1:nrow, 2) = [ 0.2068299316110, 0.2068299316110, 0.2068299316110, +0.014250305822867 ] +ans(1:nrow, 3) = [ 0.2068299316110, 0.2068299316110, 0.3795102051680, +0.014250305822867 ] +ans(1:nrow, 4) = [ 0.2068299316110, 0.3795102051680, 0.2068299316110, +0.014250305822867 ] +ans(1:nrow, 5) = [ 0.3795102051680, 0.2068299316110, 0.2068299316110, +0.014250305822867 ] +ans(1:nrow, 6) = [ 0.0821035883105, 0.0821035883105, 0.0821035883105, +0.001967033313133 ] +ans(1:nrow, 7) = [ 0.0821035883105, 0.0821035883105, 0.7536892350680, +0.001967033313133 ] +ans(1:nrow, 8) = [ 0.0821035883105, 0.7536892350680, 0.0821035883105, +0.001967033313133 ] +ans(1:nrow, 9) = [ 0.7536892350680, 0.0821035883105, 0.0821035883105, +0.001967033313133 ] +ans(1:nrow, 10) = [ 0.0057819505052, 0.0057819505052, 0.0057819505052, +0.000169834109093 ] +ans(1:nrow, 11) = [ 0.0057819505052, 0.0057819505052, 0.9826541484840, +0.000169834109093 ] +ans(1:nrow, 12) = [ 0.0057819505052, 0.9826541484840, 0.0057819505052, +0.000169834109093 ] +ans(1:nrow, 13) = [ 0.9826541484840, 0.0057819505052, 0.0057819505052, +0.000169834109093 ] +ans(1:nrow, 14) = [ 0.0505327400189, 0.0505327400189, 0.4494672599810, +0.004579683824467 ] +ans(1:nrow, 15) = [ 0.0505327400189, 0.4494672599810, 0.0505327400189, +0.004579683824467 ] +ans(1:nrow, 16) = [ 0.4494672599810, 0.0505327400189, 0.0505327400189, +0.004579683824467 ] +ans(1:nrow, 17) = [ 0.0505327400189, 0.4494672599810, 0.4494672599810, +0.004579683824467 ] +ans(1:nrow, 18) = [ 0.4494672599810, 0.0505327400189, 0.4494672599810, +0.004579683824467 ] +ans(1:nrow, 19) = [ 0.4494672599810, 0.4494672599810, 0.0505327400189, +0.004579683824467 ] +ans(1:nrow, 20) = [ 0.2290665361170, 0.2290665361170, 0.0356395827885, +0.005704485808683 ] +ans(1:nrow, 21) = [ 0.2290665361170, 0.0356395827885, 0.2290665361170, +0.005704485808683 ] +ans(1:nrow, 22) = [ 0.2290665361170, 0.2290665361170, 0.5062273449780, +0.005704485808683 ] +ans(1:nrow, 23) = [ 0.2290665361170, 0.5062273449780, 0.2290665361170, +0.005704485808683 ] +ans(1:nrow, 24) = [ 0.2290665361170, 0.0356395827885, 0.5062273449780, +0.005704485808683 ] +ans(1:nrow, 25) = [ 0.2290665361170, 0.5062273449780, 0.0356395827885, +0.005704485808683 ] +ans(1:nrow, 26) = [ 0.0356395827885, 0.2290665361170, 0.2290665361170, +0.005704485808683 ] +ans(1:nrow, 27) = [ 0.0356395827885, 0.2290665361170, 0.5062273449780, +0.005704485808683 ] +ans(1:nrow, 28) = [ 0.0356395827885, 0.5062273449780, 0.2290665361170, +0.005704485808683 ] +ans(1:nrow, 29) = [ 0.5062273449780, 0.2290665361170, 0.0356395827885, +0.005704485808683 ] +ans(1:nrow, 30) = [ 0.5062273449780, 0.2290665361170, 0.2290665361170, +0.005704485808683 ] +ans(1:nrow, 31) = [ 0.5062273449780, 0.0356395827885, 0.2290665361170, +0.005704485808683 ] +ans(1:nrow, 32) = [ 0.0366077495532, 0.0366077495532, 0.1904860419350, +0.002140519141167 ] +ans(1:nrow, 33) = [ 0.0366077495532, 0.1904860419350, 0.0366077495532, +0.002140519141167 ] +ans(1:nrow, 34) = [ 0.0366077495532, 0.0366077495532, 0.7362984589590, +0.002140519141167 ] +ans(1:nrow, 35) = [ 0.0366077495532, 0.7362984589590, 0.0366077495532, +0.002140519141167 ] +ans(1:nrow, 36) = [ 0.0366077495532, 0.1904860419350, 0.7362984589590, +0.002140519141167 ] +ans(1:nrow, 37) = [ 0.0366077495532, 0.7362984589590, 0.1904860419350, +0.002140519141167 ] +ans(1:nrow, 38) = [ 0.1904860419350, 0.0366077495532, 0.0366077495532, +0.002140519141167 ] +ans(1:nrow, 39) = [ 0.1904860419350, 0.0366077495532, 0.7362984589590, +0.002140519141167 ] +ans(1:nrow, 40) = [ 0.1904860419350, 0.7362984589590, 0.0366077495532, +0.002140519141167 ] +ans(1:nrow, 41) = [ 0.7362984589590, 0.0366077495532, 0.1904860419350, +0.002140519141167 ] +ans(1:nrow, 42) = [ 0.7362984589590, 0.0366077495532, 0.0366077495532, +0.002140519141167 ] +ans(1:nrow, 43) = [ 0.7362984589590, 0.1904860419350, 0.0366077495532, +0.002140519141167 ] END SUBROUTINE QP_Tetrahedron_Order8 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 index 68eda66ae..73fe78efe 100644 --- a/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 +++ b/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 @@ -5,60 +5,58 @@ PURE subroutine QP_Tetrahedron_Order9(ans, nrow, ncol) !! REAL(DFP) :: ans(4, 53) nrow=4;ncol= 53 - ans = RESHAPE([ & - & +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167, & - & +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & - & +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083, & - & +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083, & - & +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083, & - & +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & - & +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500, & - & +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500, & - & +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500, & - & +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & - & +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167, & - & +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167, & - & +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167, & - & +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & - & +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500, & - & +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500, & - & +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500, & - & +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & - & +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & - & +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & - & +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & - & +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500, & - & +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500, & - & +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & - & +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500, & - & +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500, & - & +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500, & - & +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500, & - & +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500, & - & +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & - & +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & - & +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & - & +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & - & +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667, & - & +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667, & - & +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & - & +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667, & - & +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667, & - & +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667, & - & +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667, & - & +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667, & - & -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & - & -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557, & - & -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & - & -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & - & -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557, & - & -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557, & - & +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & - & +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557, & - & +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557, & - & +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557, & - & +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557, & - & +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 & - & ], [4, 53]) +ans(1:nrow, 1) = [ +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167 ] +ans(1:nrow, 2) = [ +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083 ] +ans(1:nrow, 3) = [ +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083 ] +ans(1:nrow, 4) = [ +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083 ] +ans(1:nrow, 5) = [ +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083 ] +ans(1:nrow, 6) = [ +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500 ] +ans(1:nrow, 7) = [ +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500 ] +ans(1:nrow, 8) = [ +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500 ] +ans(1:nrow, 9) = [ +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500 ] +ans(1:nrow, 10) = [ +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167 ] +ans(1:nrow, 11) = [ +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167 ] +ans(1:nrow, 12) = [ +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167 ] +ans(1:nrow, 13) = [ +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167 ] +ans(1:nrow, 14) = [ +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500 ] +ans(1:nrow, 15) = [ +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500 ] +ans(1:nrow, 16) = [ +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500 ] +ans(1:nrow, 17) = [ +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500 ] +ans(1:nrow, 18) = [ +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500 ] +ans(1:nrow, 19) = [ +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500 ] +ans(1:nrow, 20) = [ +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500 ] +ans(1:nrow, 21) = [ +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500 ] +ans(1:nrow, 22) = [ +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500 ] +ans(1:nrow, 23) = [ +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500 ] +ans(1:nrow, 24) = [ +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500 ] +ans(1:nrow, 25) = [ +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500 ] +ans(1:nrow, 26) = [ +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500 ] +ans(1:nrow, 27) = [ +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500 ] +ans(1:nrow, 28) = [ +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500 ] +ans(1:nrow, 29) = [ +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500 ] +ans(1:nrow, 30) = [ +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667 ] +ans(1:nrow, 31) = [ +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667 ] +ans(1:nrow, 32) = [ +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667 ] +ans(1:nrow, 33) = [ +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667 ] +ans(1:nrow, 34) = [ +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667 ] +ans(1:nrow, 35) = [ +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667 ] +ans(1:nrow, 36) = [ +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667 ] +ans(1:nrow, 37) = [ +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667 ] +ans(1:nrow, 38) = [ +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667 ] +ans(1:nrow, 39) = [ +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667 ] +ans(1:nrow, 40) = [ +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667 ] +ans(1:nrow, 41) = [ +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667 ] +ans(1:nrow, 42) = [ -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557 ] +ans(1:nrow, 43) = [ -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557 ] +ans(1:nrow, 44) = [ -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557 ] +ans(1:nrow, 45) = [ -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557 ] +ans(1:nrow, 46) = [ -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557 ] +ans(1:nrow, 47) = [ -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557 ] +ans(1:nrow, 48) = [ +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557 ] +ans(1:nrow, 49) = [ +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557 ] +ans(1:nrow, 50) = [ +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557 ] +ans(1:nrow, 51) = [ +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557 ] +ans(1:nrow, 52) = [ +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557 ] +ans(1:nrow, 53) = [ +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 ] END subroutine QP_Tetrahedron_Order9 From 4ea81a9f518efaaea8de4bd38fa901e16d212fe6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Jul 2024 22:48:22 +0900 Subject: [PATCH 213/359] update in tetrahedron interpolation util --- ...etrahedronInterpolationUtility@Methods.F90 | 23 ++++++++++++++----- 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index d09dc7860..2f844cc8a 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -2410,6 +2410,22 @@ END SUBROUTINE IJK2VEFC_Triangle END PROCEDURE LagrangeEvalAll_Tetrahedron2_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Tetrahedron +INTEGER(I4B) :: n + +ans = QuadratureNumberTetrahedronSolin(order=order) + +IF (ans .LT. 0) THEN + n = 1_I4B + INT(order / 2, kind=I4B) + ans = n * (n + 1) * n +END IF + +END PROCEDURE QuadratureNumber_Tetrahedron + !---------------------------------------------------------------------------- ! QuadraturePoint_Tetrahedron !---------------------------------------------------------------------------- @@ -2418,12 +2434,7 @@ END SUBROUTINE IJK2VEFC_Triangle INTEGER(I4B) :: nrow, ncol, n nrow = 4 -ncol = QuadratureNumberTetrahedronSolin(order=order) - -IF (ncol .LT. 0) THEN - n = 1_I4B + INT(order / 2, kind=I4B) - ncol = n * (n + 1) * n -END IF +ncol = QuadratureNumber_Tetrahedron(order=order, quadType=quadType) ALLOCATE (ans(nrow, ncol)) From 6931a78d280ad432b744dcb006504d1be24ddc1b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Jul 2024 09:13:58 +0900 Subject: [PATCH 214/359] update hexahedron interpolation --- src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index 39111f1fb..4c513bcf1 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -32,7 +32,6 @@ MODULE HexahedronInterpolationUtility PUBLIC :: LagrangeCoeff_Hexahedron_ PUBLIC :: EdgeConnectivity_Hexahedron PUBLIC :: FacetConnectivity_Hexahedron -PUBLIC :: QuadratureNumber_Hexahedron PUBLIC :: TensorProdBasis_Hexahedron PUBLIC :: OrthogonalBasis_Hexahedron PUBLIC :: VertexBasis_Hexahedron @@ -48,6 +47,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: HeirarchicalBasis_Hexahedron PUBLIC :: HeirarchicalBasis_Hexahedron_ +PUBLIC :: QuadratureNumber_Hexahedron PUBLIC :: QuadraturePoint_Hexahedron PUBLIC :: QuadraturePoint_Hexahedron_ From c8a8b709ff4c17dbe293017ce91c57002ba700cf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Jul 2024 09:14:06 +0900 Subject: [PATCH 215/359] update hexahedron interpolation --- ...HexahedronInterpolationUtility@Methods.F90 | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index d71ed58e9..e0a7ae536 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -2209,6 +2209,25 @@ END PROCEDURE QuadraturePoint_Hexahedron2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Hexahedron2_ +INTEGER(I4B), DIMENSION(1) :: nipsx, nipsy, nipsz + +nipsx(1) = QuadratureNumber_Line(quadType=quadType1, order=p) +nipsy(1) = QuadratureNumber_Line(quadType=quadType2, order=q) +nipsz(1) = QuadratureNumber_Line(quadType=quadType3, order=r) + +CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadType1=quadType1, quadType2=quadType2, quadType3=quadType3, & + refHexahedron=refHexahedron, xij=xij, alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + alpha3=alpha3, beta3=beta3, lambda3=lambda3, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE QuadraturePoint_Hexahedron2_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Hexahedron !---------------------------------------------------------------------------- @@ -2229,6 +2248,18 @@ END PROCEDURE QuadraturePoint_Hexahedron3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Hexahedron3_ +CALL QuadraturePoint_Hexahedron4_(nipsx=nips, nipsy=nips, nipsz=nips, & + quadType1=quadType, quadType2=quadType, quadType3=quadType, & + refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, & + beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Hexahedron3_ + !---------------------------------------------------------------------------- ! QuadraturePoint_Hexahedron !---------------------------------------------------------------------------- From 4b8663b6f2791c482374c6172ddea01a33c9846e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Jul 2024 09:14:15 +0900 Subject: [PATCH 216/359] update in quadrature point --- ...draturePoint_Method@ConstructorMethods.F90 | 56 ++++++++++++++++++- 1 file changed, 55 insertions(+), 1 deletion(-) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index d1ec00a0e..133616e09 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -35,6 +35,12 @@ USE QuadrangleInterpolationUtility, ONLY: QuadraturePoint_Quadrangle_, & QuadratureNumber_Quadrangle +USE TetrahedronInterpolationUtility, ONLY: QuadraturePoint_Tetrahedron_, & + QuadratureNumber_Tetrahedron + +USE HexahedronInterpolationUtility, ONLY: QuadraturePoint_Hexahedron_, & + QuadratureNumber_Hexahedron + IMPLICIT NONE CONTAINS @@ -105,7 +111,7 @@ ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) CASE (Tetrahedron) - ! ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) + ans = QuadratureNumber_Tetrahedron(order=order, quadtype=quadratureType) CASE (Hexahedron) @@ -282,8 +288,34 @@ CASE (Tetrahedron) + nipsx(1) = QuadratureNumber_Tetrahedron(order=p, quadtype=quadratureType1) + ncol = nipsx(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, & + refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + CASE (Hexahedron) + nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) + nipsy(1) = QuadratureNumber_Line(order=q, quadtype=quadratureType2) + nipsz(1) = QuadratureNumber_Line(order=r, quadtype=quadratureType3) + + ncol = nipsx(1) * nipsy(1) * nipsz(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Hexahedron_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadType1=quadratureType1, & + quadType2=quadratureType2, & + quadType3=quadratureType3, & + refHexahedron=domainName, xij=xij, & + alpha1=alpha1, beta1=beta1, lambda1=lambda1, & + alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + alpha3=alpha3, beta3=beta3, lambda3=lambda3, & + ans=obj%points, nrow=nrow, ncol=ncol) + CASE (Prism) CASE (Pyramid) @@ -346,8 +378,30 @@ CASE (Tetrahedron) + ncol = nipsx(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, & + refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + CASE (Hexahedron) + ncol = nipsx(1) * nipsy(1) * nipsz(1) + + CALL Reallocate(obj%points, nrow, ncol) + + CALL QuadraturePoint_Hexahedron_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadType1=quadratureType1, & + quadType2=quadratureType2, & + quadType3=quadratureType3, & + refHexahedron=domainName, & + xij=xij, & + alpha1=alpha1, beta1=beta1, lambda1=lambda1, & + alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + alpha3=alpha3, beta3=beta3, lambda3=lambda3, & + ans=obj%points, nrow=nrow, ncol=ncol) + CASE (Prism) CASE (Pyramid) From 739506a6638ad58451bb3d7d6a1c4b9c1276ada4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:25:16 +0900 Subject: [PATCH 217/359] update in basetype --- src/modules/BaseType/src/BaseType.F90 | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 7701f44b3..57a36e195 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -196,6 +196,7 @@ MODULE BaseType PUBLIC :: TypePolynomialOpt PUBLIC :: TypeQuadratureOpt PUBLIC :: TypeInterpolationOpt +PUBLIC :: TypeFEVariableOpt INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 @@ -1918,4 +1919,24 @@ END FUNCTION iface_MatrixFunction TYPE(QuadratureOpt_), PARAMETER :: TypeQuadratureOpt = QuadratureOpt_() TYPE(QuadratureOpt_), PARAMETER :: TypeInterpolationOpt = QuadratureOpt_() +!---------------------------------------------------------------------------- +! TypeFeVariableOpt +!---------------------------------------------------------------------------- + +TYPE :: FEVariableOpt_ + INTEGER(I4B) :: scalar = scalar + INTEGER(I4B) :: vector = vector + INTEGER(I4B) :: matrix = matrix + INTEGER(I4B) :: nodal = nodal + INTEGER(i4b) :: quadrature = quadrature + INTEGER(I4B) :: constant = constant + INTEGER(I4B) :: space = space + INTEGER(I4B) :: time = time + INTEGER(I4B) :: spacetime = spacetime + INTEGER(I4B) :: solutionDependent = solutionDependent + INTEGER(I4B) :: randomSpace = randomSpace +END TYPE FEVariableOpt_ + +TYPE(FEVariableOpt_), PARAMETER :: TypeFEVariableOpt = FEVariableOpt_() + END MODULE BaseType From 21edff9580fac3db7b752e8df339dc744ec37878 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:25:25 +0900 Subject: [PATCH 218/359] update in element hierarchical --- .../src/ElemshapeData_Hierarchical.F90 | 138 ++++++++++++++++++ 1 file changed, 138 insertions(+) create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 new file mode 100644 index 000000000..15c3184f6 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 @@ -0,0 +1,138 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_Hierarchical +USE BaseType, ONLY: ElemshapeData_, & + QuadraturePoint_, & + ReferenceElement_, & + H1_, & + HierarchyInterpolation_ + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: HierarchicalElemShapeData +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE HierarchicalElemShapeData + MODULE SUBROUTINE HierarchicalElemShapeData1(obj, quad, nsd, xidim, & + elemType, refelemCoord, domainName, cellOrder, faceOrder, edgeOrder, & + cellOrient, faceOrient, edgeOrient) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj + !! element shape data + TYPE(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point + INTEGER(I4B), INTENT(IN) :: nsd + !! number of spatial dimension + INTEGER(I4B), INTENT(IN) :: xidim + !! dimension of xi + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: refelemCoord(:, :) + !! coordinate of reference element + CHARACTER(*), INTENT(IN) :: domainName + !! name of reference element domain + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) + !! orientation of cell + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) + !! orientation of face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) + !! edge orientation + END SUBROUTINE HierarchicalElemShapeData1 +END INTERFACE HierarchicalElemShapeData + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE HierarchicalElemShapeData + MODULE SUBROUTINE HierarchicalElemShapeData2(obj, quad, refelem, cellOrder, & + faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj + TYPE(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) + !! orientation of cell + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) + !! orientation of face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) + !! edge orientation + END SUBROUTINE HierarchicalElemShapeData2 +END INTERFACE HierarchicalElemShapeData + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE HierarchicalElemShapeData + MODULE SUBROUTINE HierarchicalElemShapeData3(obj, quad, refelem, & + baseContinuity, baseInterpolation, cellOrder, & + faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj + TYPE(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! reference element + TYPE(H1_), INTENT(IN) :: baseContinuity + !! base continuity + TYPE(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation + !! base interpolation + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) + !! orientation of cell + INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) + !! orientation of face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) + !! edge orientation + END SUBROUTINE HierarchicalElemShapeData3 +END INTERFACE HierarchicalElemShapeData + +INTERFACE Initiate + MODULE PROCEDURE HierarchicalElemShapeData3 +END INTERFACE Initiate + +END MODULE ElemshapeData_Hierarchical From 6ebe128c3b6b00416b37e9fda0f4868f84eddec1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:25:32 +0900 Subject: [PATCH 219/359] update in elemeshapedata lagrange --- .../ElemshapeData/src/ElemshapeData_Lagrange.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 index 0c6f4021f..96afeff73 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 @@ -40,7 +40,7 @@ MODULE ElemshapeData_Lagrange INTERFACE LagrangeElemShapeData MODULE SUBROUTINE LagrangeElemShapeData1(obj, quad, nsd, xidim, & - elemType, refelemCoord, refelemDomain, order, ipType, basisType, & + elemType, refelemCoord, domainName, order, ipType, basisType, & coeff, firstCall, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! element shape data @@ -54,7 +54,7 @@ MODULE SUBROUTINE LagrangeElemShapeData1(obj, quad, nsd, xidim, & !! element type REAL(DFP), INTENT(IN) :: refelemCoord(:, :) !! coordinate of reference element - CHARACTER(*), INTENT(IN) :: refelemDomain + CHARACTER(*), INTENT(IN) :: domainName !! name of reference element domain INTEGER(I4B), INTENT(IN) :: order !! order of interpolation @@ -64,7 +64,7 @@ MODULE SUBROUTINE LagrangeElemShapeData1(obj, quad, nsd, xidim, & INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType !! Basis function types !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) !! Coefficient of Lagrange polynomials LOGICAL(LGT), OPTIONAL :: firstCall !! If firstCall is true, then coeff will be made @@ -97,7 +97,7 @@ MODULE SUBROUTINE LagrangeElemShapeData2(obj, quad, refelem, order, & INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType !! Basis function types !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) !! Coefficient of Lagrange polynomials LOGICAL(LGT), OPTIONAL :: firstCall !! If firstCall is true, then coeff will be made @@ -127,7 +127,7 @@ MODULE SUBROUTINE LagrangeElemShapeData3(obj, quad, refelem, baseContinuity, & INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType !! Basis function types !! Default value is Monomial - REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :) + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) !! Coefficient of Lagrange polynomials LOGICAL(LGT), OPTIONAL :: firstCall !! If firstCall is true, then coeff will be made From 785bae07d84c63dcb478e14a7756ad9d6245ee31 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:25:43 +0900 Subject: [PATCH 220/359] update in cmake of element shape data --- src/modules/ElemshapeData/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt index f8e09790a..407eb9713 100644 --- a/src/modules/ElemshapeData/CMakeLists.txt +++ b/src/modules/ElemshapeData/CMakeLists.txt @@ -28,6 +28,7 @@ target_sources( ${src_path}/ElemshapeData_HDivMethods.F90 ${src_path}/ElemshapeData_HCurlMethods.F90 ${src_path}/ElemshapeData_Lagrange.F90 + ${src_path}/ElemshapeData_Hierarchical.F90 ${src_path}/ElemshapeData_HminHmaxMethods.F90 ${src_path}/ElemshapeData_HRGNParamMethods.F90 ${src_path}/ElemshapeData_HRQIParamMethods.F90 From 15e67202c51ea1fde71ffd9c666fe247b9c7a71d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:25:52 +0900 Subject: [PATCH 221/359] update in reference element method --- .../Geometry/src/ReferenceElement_Method.F90 | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index 4a410b019..47c8a2b5a 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -76,6 +76,7 @@ MODULE ReferenceElement_Method PUBLIC :: Reallocate PUBLIC :: RefTopoReallocate PUBLIC :: RefCoord +PUBLIC :: RefCoord_ INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_FACES = 6 INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_EDGES = 12 @@ -152,6 +153,22 @@ MODULE PURE FUNCTION RefCoord(elemType, refElem) RESULT(ans) END FUNCTION RefCoord END INTERFACE +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE RefCoord_(elemType, refElem, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type + CHARACTER(*), INTENT(IN) :: refElem + !! "UNIT" ! "BIUNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! xij coordinate + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE RefCoord_ +END INTERFACE + !---------------------------------------------------------------------------- ! GetElementIndex@GeometryMethods !---------------------------------------------------------------------------- From 5e4d2809bb5a57159884178c9358ea6af6dc0048 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:26:01 +0900 Subject: [PATCH 222/359] update in hierarchical poly util --- .../src/HierarchicalPolynomialUtility.F90 | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 index 81fde64e8..f886dfcf2 100644 --- a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 @@ -126,11 +126,9 @@ END FUNCTION HierarchicalCellDOF !---------------------------------------------------------------------------- INTERFACE - MODULE FUNCTION HierarchicalEvalAll(order, elemType, xij, domainName, & + MODULE FUNCTION HierarchicalEvalAll(elemType, xij, domainName, & cellOrder, faceOrder, edgeOrder, cellOrient, faceOrient, & edgeOrient) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType !! element type REAL(DFP), INTENT(IN) :: xij(:, :) @@ -163,11 +161,9 @@ END FUNCTION HierarchicalEvalAll !---------------------------------------------------------------------------- INTERFACE - MODULE SUBROUTINE HierarchicalEvalAll_(order, elemType, xij, ans, nrow, & + MODULE SUBROUTINE HierarchicalEvalAll_(elemType, xij, ans, nrow, & ncol, domainName, cellOrder, faceOrder, edgeOrder, & cellOrient, faceOrient, edgeOrient) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType !! element type REAL(DFP), INTENT(IN) :: xij(:, :) @@ -203,11 +199,9 @@ END SUBROUTINE HierarchicalEvalAll_ !---------------------------------------------------------------------------- INTERFACE - MODULE FUNCTION HierarchicalGradientEvalAll(order, elemType, xij, & + MODULE FUNCTION HierarchicalGradientEvalAll(elemType, xij, & domainName, cellOrder, faceOrder, edgeOrder, cellOrient, faceOrient, & edgeOrient) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType !! element type REAL(DFP), INTENT(IN) :: xij(:, :) @@ -240,11 +234,9 @@ END FUNCTION HierarchicalGradientEvalAll !---------------------------------------------------------------------------- INTERFACE - MODULE SUBROUTINE HierarchicalGradientEvalAll_(order, elemType, xij, ans, & + MODULE SUBROUTINE HierarchicalGradientEvalAll_(elemType, xij, ans, & dim1, dim2, dim3, domainName, cellOrder, faceOrder, edgeOrder, & cellOrient, faceOrient, edgeOrient) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Hierarchical polynomials INTEGER(I4B), INTENT(IN) :: elemType !! element type REAL(DFP), INTENT(IN) :: xij(:, :) From a9011314b9492fd87627408a4a9d0db0b55c9c27 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:26:08 +0900 Subject: [PATCH 223/359] update in lagrange poly util --- .../src/LagrangePolynomialUtility.F90 | 28 ++++++++++++++++--- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index e2219ff59..dde8431a2 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -56,15 +56,35 @@ MODULE LagrangePolynomialUtility ! date: 12 Aug 2022 ! summary: Returns the number of dof for lagrange polynomial -INTERFACE - MODULE PURE FUNCTION LagrangeDOF(order, elemType) RESULT(ans) +INTERFACE LagrangeDOF + MODULE PURE FUNCTION LagrangeDOF1(order, elemType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: elemType INTEGER(I4B) :: ans !! number of degree of freedom - END FUNCTION LagrangeDOF -END INTERFACE + END FUNCTION LagrangeDOF1 +END INTERFACE LagrangeDOF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-11 +! summary: Get lagrange degree of freedom + +INTERFACE LagrangeDOF + MODULE PURE FUNCTION LagrangeDOF2(p, q, r, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q, r + !! order in x, y, and z direction + INTEGER(I4B), INTENT(IN) :: elemType + !! for line, triangle, tetrahedron, prism , and pyramid only p is used + !! for quadrangle and hexahedron, pq are used and pqr are used + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION LagrangeDOF2 +END INTERFACE LagrangeDOF !---------------------------------------------------------------------------- ! LagrangeInDOF@BasisMethods From 70480d7613c675dcf9cf4a27eec67b033621f45a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:26:18 +0900 Subject: [PATCH 224/359] update in element shape data --- src/submodules/ElemshapeData/CMakeLists.txt | 27 +--- .../ElemshapeData/src/DG/CMakeLists.txt | 25 ++++ .../ElemshapeData_DGMethods@HermitMethods.F90 | 0 ...emshapeData_DGMethods@HierarchyMethods.F90 | 0 ...lemshapeData_DGMethods@LagrangeMethods.F90 | 0 ...mshapeData_DGMethods@OrthogonalMethods.F90 | 0 ...shapeData_DGMethods@SerendipityMethods.F90 | 0 .../ElemshapeData/src/H1/CMakeLists.txt | 24 ++++ .../ElemshapeData_H1Methods@HermitMethods.F90 | 0 ...emshapeData_H1Methods@HierarchyMethods.F90 | 0 ...mshapeData_H1Methods@OrthogonalMethods.F90 | 0 ...shapeData_H1Methods@SerendipityMethods.F90 | 0 .../ElemshapeData/src/HCurl/CMakeLists.txt | 25 ++++ ...emshapeData_HCurlMethods@HermitMethods.F90 | 0 ...hapeData_HCurlMethods@HierarchyMethods.F90 | 0 ...shapeData_HCurlMethods@LagrangeMethods.F90 | 0 ...apeData_HCurlMethods@OrthogonalMethods.F90 | 0 ...peData_HCurlMethods@SerendipityMethods.F90 | 0 .../ElemshapeData/src/HDiv/CMakeLists.txt | 25 ++++ ...lemshapeData_HDivMethods@HermitMethods.F90 | 0 ...shapeData_HDivMethods@HierarchyMethods.F90 | 0 ...mshapeData_HDivMethods@LagrangeMethods.F90 | 0 ...hapeData_HDivMethods@OrthogonalMethods.F90 | 0 ...apeData_HDivMethods@SerendipityMethods.F90 | 0 .../src/Hierarchical/CMakeLists.txt | 21 +++ .../ElemshapeData_Hierarchical@Methods.F90 | 120 ++++++++++++++++++ .../ElemshapeData/src/Lagrange/CMakeLists.txt | 20 +++ .../ElemshapeData_Lagrange@Methods.F90 | 21 +-- 28 files changed, 279 insertions(+), 29 deletions(-) create mode 100644 src/submodules/ElemshapeData/src/DG/CMakeLists.txt rename src/submodules/ElemshapeData/src/DG/{ => src}/ElemshapeData_DGMethods@HermitMethods.F90 (100%) rename src/submodules/ElemshapeData/src/DG/{ => src}/ElemshapeData_DGMethods@HierarchyMethods.F90 (100%) rename src/submodules/ElemshapeData/src/DG/{ => src}/ElemshapeData_DGMethods@LagrangeMethods.F90 (100%) rename src/submodules/ElemshapeData/src/DG/{ => src}/ElemshapeData_DGMethods@OrthogonalMethods.F90 (100%) rename src/submodules/ElemshapeData/src/DG/{ => src}/ElemshapeData_DGMethods@SerendipityMethods.F90 (100%) create mode 100644 src/submodules/ElemshapeData/src/H1/CMakeLists.txt rename src/submodules/ElemshapeData/src/H1/{ => src}/ElemshapeData_H1Methods@HermitMethods.F90 (100%) rename src/submodules/ElemshapeData/src/H1/{ => src}/ElemshapeData_H1Methods@HierarchyMethods.F90 (100%) rename src/submodules/ElemshapeData/src/H1/{ => src}/ElemshapeData_H1Methods@OrthogonalMethods.F90 (100%) rename src/submodules/ElemshapeData/src/H1/{ => src}/ElemshapeData_H1Methods@SerendipityMethods.F90 (100%) create mode 100644 src/submodules/ElemshapeData/src/HCurl/CMakeLists.txt rename src/submodules/ElemshapeData/src/HCurl/{ => src}/ElemshapeData_HCurlMethods@HermitMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HCurl/{ => src}/ElemshapeData_HCurlMethods@HierarchyMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HCurl/{ => src}/ElemshapeData_HCurlMethods@LagrangeMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HCurl/{ => src}/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HCurl/{ => src}/ElemshapeData_HCurlMethods@SerendipityMethods.F90 (100%) create mode 100644 src/submodules/ElemshapeData/src/HDiv/CMakeLists.txt rename src/submodules/ElemshapeData/src/HDiv/{ => src}/ElemshapeData_HDivMethods@HermitMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HDiv/{ => src}/ElemshapeData_HDivMethods@HierarchyMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HDiv/{ => src}/ElemshapeData_HDivMethods@LagrangeMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HDiv/{ => src}/ElemshapeData_HDivMethods@OrthogonalMethods.F90 (100%) rename src/submodules/ElemshapeData/src/HDiv/{ => src}/ElemshapeData_HDivMethods@SerendipityMethods.F90 (100%) create mode 100644 src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt create mode 100644 src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/Lagrange/CMakeLists.txt rename src/submodules/ElemshapeData/src/Lagrange/{ => src}/ElemshapeData_Lagrange@Methods.F90 (90%) diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt index 742055dca..1be380742 100644 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -22,26 +22,6 @@ target_sources( ${src_path}/ElemshapeData_DivergenceMethods@Methods.F90 ${src_path}/ElemshapeData_GetMethods@Methods.F90 ${src_path}/ElemshapeData_GradientMethods@Methods.F90 - ${src_path}/Lagrange/ElemshapeData_Lagrange@Methods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@HermitMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 - ${src_path}/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@HermitMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 - ${src_path}/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 - ${src_path}/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 - ${src_path}/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 ${src_path}/ElemshapeData_HminHmaxMethods@Methods.F90 ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90 ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90 @@ -55,3 +35,10 @@ target_sources( ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90 ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90) + +include(${src_path}/H1/CMakeLists.txt) +include(${src_path}/HDiv/CMakeLists.txt) +include(${src_path}/HCurl/CMakeLists.txt) +include(${src_path}/DG/CMakeLists.txt) +include(${src_path}/Lagrange/CMakeLists.txt) +include(${src_path}/Hierarchical/CMakeLists.txt) diff --git a/src/submodules/ElemshapeData/src/DG/CMakeLists.txt b/src/submodules/ElemshapeData/src/DG/CMakeLists.txt new file mode 100644 index 000000000..1ca0cb2ca --- /dev/null +++ b/src/submodules/ElemshapeData/src/DG/CMakeLists.txt @@ -0,0 +1,25 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path0 "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path0}/ElemshapeData_DGMethods@HermitMethods.F90 + ${src_path0}/ElemshapeData_DGMethods@HierarchyMethods.F90 + ${src_path0}/ElemshapeData_DGMethods@LagrangeMethods.F90 + ${src_path0}/ElemshapeData_DGMethods@OrthogonalMethods.F90 + ${src_path0}/ElemshapeData_DGMethods@SerendipityMethods.F90) diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HermitMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HermitMethods.F90 diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HierarchyMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HierarchyMethods.F90 diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@LagrangeMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@LagrangeMethods.F90 diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@OrthogonalMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@OrthogonalMethods.F90 diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@SerendipityMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@SerendipityMethods.F90 diff --git a/src/submodules/ElemshapeData/src/H1/CMakeLists.txt b/src/submodules/ElemshapeData/src/H1/CMakeLists.txt new file mode 100644 index 000000000..d65a69823 --- /dev/null +++ b/src/submodules/ElemshapeData/src/H1/CMakeLists.txt @@ -0,0 +1,24 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path0 "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path0}/ElemshapeData_H1Methods@HermitMethods.F90 + ${src_path0}/ElemshapeData_H1Methods@HierarchyMethods.F90 + ${src_path0}/ElemshapeData_H1Methods@OrthogonalMethods.F90 + ${src_path0}/ElemshapeData_H1Methods@SerendipityMethods.F90) diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HermitMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HermitMethods.F90 diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90 diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90 diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@SerendipityMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@SerendipityMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HCurl/CMakeLists.txt b/src/submodules/ElemshapeData/src/HCurl/CMakeLists.txt new file mode 100644 index 000000000..9ab6dce6c --- /dev/null +++ b/src/submodules/ElemshapeData/src/HCurl/CMakeLists.txt @@ -0,0 +1,25 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path0 "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path0}/ElemshapeData_HCurlMethods@HermitMethods.F90 + ${src_path0}/ElemshapeData_HCurlMethods@HierarchyMethods.F90 + ${src_path0}/ElemshapeData_HCurlMethods@LagrangeMethods.F90 + ${src_path0}/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 + ${src_path0}/ElemshapeData_HCurlMethods@SerendipityMethods.F90) diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HermitMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HermitMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HierarchyMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HierarchyMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@LagrangeMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@LagrangeMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@SerendipityMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@SerendipityMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HDiv/CMakeLists.txt b/src/submodules/ElemshapeData/src/HDiv/CMakeLists.txt new file mode 100644 index 000000000..fde44344d --- /dev/null +++ b/src/submodules/ElemshapeData/src/HDiv/CMakeLists.txt @@ -0,0 +1,25 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path0 "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path0}/ElemshapeData_HDivMethods@HermitMethods.F90 + ${src_path0}/ElemshapeData_HDivMethods@HierarchyMethods.F90 + ${src_path0}/ElemshapeData_HDivMethods@LagrangeMethods.F90 + ${src_path0}/ElemshapeData_HDivMethods@OrthogonalMethods.F90 + ${src_path0}/ElemshapeData_HDivMethods@SerendipityMethods.F90) diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HermitMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HermitMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HierarchyMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HierarchyMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@LagrangeMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@LagrangeMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@OrthogonalMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@OrthogonalMethods.F90 diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@SerendipityMethods.F90 similarity index 100% rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@SerendipityMethods.F90 diff --git a/src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt b/src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt new file mode 100644 index 000000000..79a33828b --- /dev/null +++ b/src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt @@ -0,0 +1,21 @@ +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} + PRIVATE ${src_path}/ElemshapeData_Hierarchical@Methods.F90) diff --git a/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 new file mode 100644 index 000000000..cd080f6b7 --- /dev/null +++ b/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 @@ -0,0 +1,120 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_Hierarchical) Methods +USE InputUtility, ONLY: Input + +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate + +USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE + +USE HierarchicalPolynomialUtility, ONLY: HierarchicalDOF, & + HierarchicalEvalAll_, & + HierarchicalGradientEvalAll_ + +USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & + QuadraturePoint_Size => Size + +USE BaseType, ONLY: TypeQuadratureOpt, & + TypePolynomialOpt + +USE SwapUtility, ONLY: SWAP_ + +USE Display_Method, ONLY: Display + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! ElemshapeData_InitiateHierarchical +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalElemShapeData1 +REAL(DFP), ALLOCATABLE :: temp(:, :, :) +INTEGER(I4B) :: ipType0, basisType0, nips, nns, ii, jj, kk + +! CALL DEALLOCATE (obj) + +nips = SIZE(quad%points, 2) +! pt = quad%points(1:quad%txi, 1:nips) +! wt = quad%points(quad%txi + 1, 1:nips) + +nns = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder) + +CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) + +obj%ws = quad%points(1 + xidim, 1:nips) + +ALLOCATE (temp(nips, nns, 3)) + +CALL HierarchicalEvalAll_(elemType=elemType, & + xij=quad%points(1:xidim, 1:nips), & + ans=temp(:, :, 1), nrow=ii, ncol=jj, & + domainName=domainName, & + cellOrder=cellOrder, & + faceOrder=faceOrder, & + edgeOrder=edgeOrder, & + cellOrient=cellOrient, & + faceOrient=faceOrient, & + edgeOrient=edgeOrient) + +DO CONCURRENT(ii=1:nns, jj=1:nips) + obj%N(ii, jj) = temp(jj, ii, 1) +END DO + +CALL HierarchicalGradientEvalAll_(elemType=elemType, & + xij=quad%points(1:xidim, 1:nips), ans=temp, & + dim1=ii, dim2=jj, dim3=kk, & + domainName=domainName, & + cellOrder=cellOrder, & + faceOrder=faceOrder, & + edgeOrder=edgeOrder, & + cellOrient=cellOrient, & + faceOrient=faceOrient, & + edgeOrient=edgeOrient) + +CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=2, i2=3, i3=1) + +IF (ALLOCATED(temp)) DEALLOCATE (temp) + +END PROCEDURE HierarchicalElemShapeData1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalElemShapeData2 +CALL HierarchicalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & + xidim=refelem%xidimension, elemType=refelem%name, & + refelemCoord=refelem%xij, domainName=refelem%domainName, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +END PROCEDURE HierarchicalElemShapeData2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalElemShapeData3 +CALL HierarchicalElemShapeData2(obj=obj, quad=quad, refelem=refelem, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +END PROCEDURE HierarchicalElemShapeData3 + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/Lagrange/CMakeLists.txt b/src/submodules/ElemshapeData/src/Lagrange/CMakeLists.txt new file mode 100644 index 000000000..11d4222f0 --- /dev/null +++ b/src/submodules/ElemshapeData/src/Lagrange/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_path0 "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} + PRIVATE ${src_path0}/ElemshapeData_Lagrange@Methods.F90) diff --git a/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 similarity index 90% rename from src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 rename to src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 index 83c0c67be..58080616b 100644 --- a/src/submodules/ElemshapeData/src/Lagrange/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 @@ -48,7 +48,7 @@ MODULE PROCEDURE LagrangeElemShapeData1 REAL(DFP), ALLOCATABLE :: xij(:, :), coeff0(:, :), temp(:, :, :) -INTEGER(I4B) :: ipType0, basisType0, nips, nns, indx(10) +INTEGER(I4B) :: ipType0, basisType0, nips, nns, indx(10), ii, jj ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType) basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType) @@ -77,21 +77,24 @@ elemType=elemType, & x=quad%points(1:quad%txi, 1:nips), & xij=xij(1:xidim, :), & - domainName=refelemDomain, & + domainName=domainName, & basisType=basisType0, & alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff, firstCall=firstCall, & + coeff=coeff(1:nns, 1:nns), firstCall=firstCall, & ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2)) - obj%N(1:nns, 1:nips) = TRANSPOSE(temp(1:nips, 1:nns, 1)) + DO CONCURRENT(ii=1:nns, jj=1:nips) + obj%N(ii, jj) = temp(jj, ii, 1) + END DO CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & x=quad%points(1:quad%txi, 1:nips), & xij=xij(1:xidim, :), & - domainName=refelemDomain, & + domainName=domainName, & basisType=basisType0, & alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff, firstCall=.FALSE., & + coeff=coeff(1:nns, 1:nns), & + firstCall=.FALSE., & ans=temp, & dim1=indx(1), dim2=indx(2), dim3=indx(3)) @@ -103,7 +106,7 @@ CALL LagrangeEvalAll_(order=order, elemType=elemType, & x=quad%points(1:quad%txi, 1:nips), & xij=xij(1:xidim, :), & - domainName=refelemDomain, & + domainName=domainName, & basisType=basisType0, & alpha=alpha, beta=beta, lambda=lambda, & coeff=coeff0, firstCall=.TRUE., & @@ -115,7 +118,7 @@ CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & x=quad%points(1:quad%txi, 1:nips), & xij=xij(1:xidim, :), & - domainName=refelemDomain, & + domainName=domainName, & basisType=basisType0, & alpha=alpha, beta=beta, lambda=lambda, & coeff=coeff0, firstCall=.FALSE., & @@ -139,7 +142,7 @@ MODULE PROCEDURE LagrangeElemShapeData2 CALL LagrangeElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & xidim=refelem%xidimension, elemType=refelem%name, & - refelemCoord=refelem%xij, refelemDomain=refelem%domainName, order=order, & + 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 From b39a96b3a18c23e466c7a049dcc8d096fd165407 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:26:24 +0900 Subject: [PATCH 225/359] update in geometry --- ...eferenceElement_Method@GeometryMethods.F90 | 55 ++++++++++++++++++- .../ReferenceHexahedron_Method@Methods.F90 | 13 +++-- .../src/ReferenceLine_Method@Methods.F90 | 15 ++--- .../ReferenceQuadrangle_Method@Methods.F90 | 19 ++++--- .../ReferenceTetrahedron_Method@Methods.F90 | 29 +++++----- .../src/ReferenceTriangle_Method@Methods.F90 | 26 +++++---- 6 files changed, 109 insertions(+), 48 deletions(-) diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 index fa416a8ee..cfd0697ba 100644 --- a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 +++ b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 @@ -17,6 +17,7 @@ SUBMODULE(ReferenceElement_Method) GeometryMethods USE ErrorHandling, ONLY: Errormsg + USE Display_Method USE ReferencePoint_Method, ONLY: Measure_Simplex_Point, Point_quality, & @@ -124,10 +125,62 @@ CASE (Pyramid) ans = RefCoord_Pyramid(refElem) - END SELECT END PROCEDURE RefCoord +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefCoord_ +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Point) + nrow = 3 + ncol = 1 + ans(1:nrow, 1:ncol) = 0.0_DFP + +CASE (Line) + nrow = 1 + ncol = 2 + ans(1:nrow, 1:ncol) = RefCoord_Line(refElem) + +CASE (Triangle) + nrow = 2 + ncol = 3 + ans(1:nrow, 1:ncol) = RefCoord_Triangle(refElem) + +CASE (Quadrangle) + nrow = 2 + ncol = 4 + ans(1:nrow, 1:ncol) = RefCoord_Quadrangle(refElem) + +CASE (Tetrahedron) + nrow = 3 + ncol = 4 + ans(1:nrow, 1:ncol) = RefCoord_Tetrahedron(refElem) + +CASE (Hexahedron) + nrow = 3 + ncol = 8 + ans(1:nrow, 1:ncol) = RefCoord_Hexahedron(refElem) + +CASE (Prism) + nrow = 3 + ncol = 6 + ans(1:nrow, 1:ncol) = RefCoord_Prism(refElem) + +CASE (Pyramid) + nrow = 3 + ncol = 5 + ans(1:nrow, 1:ncol) = RefCoord_Pyramid(refElem) +END SELECT +END PROCEDURE RefCoord_ + !---------------------------------------------------------------------------- ! GetElementIndex !---------------------------------------------------------------------------- diff --git a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 index 82e3b9346..fadad220e 100644 --- a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 @@ -504,25 +504,26 @@ MODULE PROCEDURE RefHexahedronCoord REAL(DFP) :: one, mone -CHARACTER(:), ALLOCATABLE :: astr +CHARACTER(1), ALLOCATABLE :: astr -astr = UpperCase(refHexahedron) +astr = refHexahedron(1:1) SELECT CASE (astr) -CASE ("UNIT") +CASE ("U", "u") one = 1.0_DFP mone = 0.0_DFP -CASE ("BIUNIT") + +CASE ("B", "b") one = 1.0_DFP mone = -1.0_DFP -END SELECT -astr = "" +END SELECT ans(3, 1:4) = mone ans(3, 5:8) = one ans(1:2, 1:4) = RefQuadrangleCoord(refHexahedron) ans(1:2, 5:8) = ans(1:2, 1:4) + END PROCEDURE RefHexahedronCoord !---------------------------------------------------------------------------- diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 index 2c2b10e85..b6805ae2e 100644 --- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 @@ -346,13 +346,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE RefLineCoord -TYPE(String) :: astr -astr = UpperCase(refLine) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans(1, :) = [0.0_DFP, 1.0_DFP] -CASE ("BIUNIT") - ans(1, :) = [-1.0_DFP, 1.0_DFP] +CHARACTER(1) :: astr + +astr = refline(1:1) +SELECT CASE (astr) +CASE ("U", "u") + ans(1, 1:2) = [0.0_DFP, 1.0_DFP] +CASE ("B", "b") + ans(1, 1:2) = [-1.0_DFP, 1.0_DFP] END SELECT END PROCEDURE RefLineCoord diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 index c4cf08816..b7f438a7f 100644 --- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 @@ -555,17 +555,18 @@ END SUBROUTINE PARALLELOGRAMAREA2D !---------------------------------------------------------------------------- MODULE PROCEDURE RefQuadrangleCoord -CHARACTER(:), ALLOCATABLE :: astr -astr = UpperCase(refQuadrangle) +CHARACTER(1) :: astr +astr = refQuadrangle(1:1) + SELECT CASE (astr) -CASE ("UNIT") - ans(1, :) = [0.0_DFP, 1.0_DFP, 1.0_DFP, 0.0_DFP] - ans(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP, 1.0_DFP] -CASE ("BIUNIT") - ans(1, :) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, -1.0_DFP] - ans(2, :) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP] +CASE ("U", "u") + ans(1, 1:4) = [0.0_DFP, 1.0_DFP, 1.0_DFP, 0.0_DFP] + ans(2, 1:4) = [0.0_DFP, 0.0_DFP, 1.0_DFP, 1.0_DFP] + +CASE ("B", "b") + ans(1, 1:4) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, -1.0_DFP] + ans(2, 1:4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP] END SELECT -astr = "" END PROCEDURE RefQuadrangleCoord !---------------------------------------------------------------------------- diff --git a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 index 1e84e2ad5..9073009d2 100644 --- a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 @@ -489,21 +489,24 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE RefCoord_Tetrahedron -CHARACTER(:), ALLOCATABLE :: layout -layout = UpperCase(refTetrahedron) +CHARACTER(1) :: layout + +layout = refTetrahedron(1:1) + SELECT CASE (layout) -CASE ("BIUNIT") - ans(:, 1) = [-1.0_DFP, -1.0_DFP, -1.0_DFP] - ans(:, 2) = [1.0_DFP, -1.0_DFP, -1.0_DFP] - ans(:, 3) = [-1.0_DFP, 1.0_DFP, -1.0_DFP] - ans(:, 4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP] -CASE ("UNIT") - ans(:, 1) = [0.0_DFP, 0.0_DFP, 0.0_DFP] - ans(:, 2) = [1.0_DFP, 0.0_DFP, 0.0_DFP] - ans(:, 3) = [0.0_DFP, 1.0_DFP, 0.0_DFP] - ans(:, 4) = [0.0_DFP, 0.0_DFP, 1.0_DFP] +CASE ("B", "b") + ans(1:3, 1) = [-1.0_DFP, -1.0_DFP, -1.0_DFP] + ans(1:3, 2) = [1.0_DFP, -1.0_DFP, -1.0_DFP] + ans(1:3, 3) = [-1.0_DFP, 1.0_DFP, -1.0_DFP] + ans(1:3, 4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP] + +CASE ("U", "u") + ans(1:3, 1) = [0.0_DFP, 0.0_DFP, 0.0_DFP] + ans(1:3, 2) = [1.0_DFP, 0.0_DFP, 0.0_DFP] + ans(1:3, 3) = [0.0_DFP, 1.0_DFP, 0.0_DFP] + ans(1:3, 4) = [0.0_DFP, 0.0_DFP, 1.0_DFP] + END SELECT -layout = "" END PROCEDURE RefCoord_Tetrahedron !---------------------------------------------------------------------------- diff --git a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 index c1bfa8f99..11712ee97 100644 --- a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 @@ -740,19 +740,21 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE RefTriangleCoord -CHARACTER(:), ALLOCATABLE :: layout -layout = UpperCase(refTriangle) -SELECT CASE (layout) -CASE ("BIUNIT") - ans(:, 1) = [-1.0_DFP, -1.0_DFP] - ans(:, 2) = [1.0_DFP, -1.0_DFP] - ans(:, 3) = [-1.0_DFP, 1.0_DFP] -CASE ("UNIT") - ans(:, 1) = [0.0_DFP, 0.0_DFP] - ans(:, 2) = [1.0_DFP, 0.0_DFP] - ans(:, 3) = [0.0_DFP, 1.0_DFP] +CHARACTER(1) :: astr + +astr = reftriangle(1:1) + +SELECT CASE (astr) +CASE ("B", "b") + ans(1:2, 1) = [-1.0_DFP, -1.0_DFP] + ans(1:2, 2) = [1.0_DFP, -1.0_DFP] + ans(1:2, 3) = [-1.0_DFP, 1.0_DFP] + +CASE ("U", "u") + ans(1:2, 1) = [0.0_DFP, 0.0_DFP] + ans(1:2, 2) = [1.0_DFP, 0.0_DFP] + ans(1:2, 3) = [0.0_DFP, 1.0_DFP] END SELECT -layout = "" END PROCEDURE RefTriangleCoord !---------------------------------------------------------------------------- From 2e01cb1e52584b3dd36bef1f75f81b4482c2a677 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Jul 2024 17:26:32 +0900 Subject: [PATCH 226/359] update in hierarchical poly --- .../HierarchicalPolynomialUtility@Methods.F90 | 4 +-- .../src/LagrangePolynomialUtility@Methods.F90 | 33 +++++++++++++++++-- .../src/LineInterpolationUtility@Methods.F90 | 7 ++-- 3 files changed, 35 insertions(+), 9 deletions(-) diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 index c0f2589ff..f58b2ed3b 100644 --- a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 @@ -222,7 +222,7 @@ ALLOCATE (ans(nrow, ncol)) -CALL HierarchicalEvalAll_(order=order, elemType=elemType, xij=xij, ans=ans, & +CALL HierarchicalEvalAll_(elemType=elemType, xij=xij, ans=ans, & nrow=nrow, ncol=ncol, domainName=domainName, cellOrder=cellOrder, & faceOrder=faceOrder, edgeOrder=edgeOrder, cellOrient=cellOrient, & faceOrient=faceOrient, edgeOrient=edgeOrient) @@ -352,7 +352,7 @@ ALLOCATE (ans(dim1, dim2, dim3)) -CALL HierarchicalGradientEvalAll_(order=order, elemType=elemType, xij=xij, & +CALL HierarchicalGradientEvalAll_(elemType=elemType, xij=xij, & ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, domainName=domainName, & cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index 7c6523c1e..2f872d7ea 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -118,7 +118,7 @@ ! LagrangeDOF !---------------------------------------------------------------------------- -MODULE PROCEDURE LagrangeDOF +MODULE PROCEDURE LagrangeDOF1 INTEGER(I4B) :: topo topo = ElementTopology(elemType) @@ -141,7 +141,36 @@ CASE (Pyramid) ans = LagrangeDOF_Pyramid(order=order) END SELECT -END PROCEDURE LagrangeDOF +END PROCEDURE LagrangeDOF1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF2 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (Point) + ans = 1 +CASE (Line) + ans = LagrangeDOF_Line(order=p) +CASE (Triangle) + ans = LagrangeDOF_Triangle(order=p) +CASE (Quadrangle) + ans = LagrangeDOF_Quadrangle(p=p, q=q) +CASE (Tetrahedron) + ans = LagrangeDOF_Tetrahedron(order=p) +CASE (Hexahedron) + ans = LagrangeDOF_Hexahedron(p=p, q=q, r=r) +CASE (Prism) + ans = LagrangeDOF_Prism(order=p) +CASE (Pyramid) + ans = LagrangeDOF_Pyramid(order=p) +END SELECT +END PROCEDURE LagrangeDOF2 !---------------------------------------------------------------------------- ! LagrangeInDOF diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 4b59ee09e..e1ec30894 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -476,13 +476,12 @@ CONTAINS SUBROUTINE handle_vefc - INTEGER(I4B) :: jj REAL(DFP) :: t1 IF (layout(1:2) .EQ. "VE") THEN t1 = temp(order + 1) IF (order .GE. 2) THEN - temp(3:) = temp(2:order) + temp(3:order + 1) = temp(2:order) END IF temp(2) = t1 END IF @@ -615,7 +614,6 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- SUBROUTINE handle_vefc - INTEGER(I4B) :: jj REAL(DFP) :: t1 IF (layout(1:2) .EQ. "VE") THEN @@ -1412,7 +1410,7 @@ END SUBROUTINE handle_error MODULE PROCEDURE QuadraturePoint_Line1_ #ifdef DEBUG_VER -LOGICAL(LGT) :: isok, abool +LOGICAL(LGT) :: isok #endif INTEGER(I4B) :: np, nsd, ii, jj @@ -1832,7 +1830,6 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE OrthogonalBasis_Line1 -INTEGER(I4B) :: ii CHARACTER(1) :: astr LOGICAL(LGT) :: isok, abool From 81c013c793d1425e71fbd26f0bcbf918e0221c24 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 12 Jul 2024 18:48:05 +0900 Subject: [PATCH 227/359] update in elemeshape data --- src/modules/ElemshapeData/src/ElemshapeData_Method.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 index 2528abbc8..7df24ee59 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -20,10 +20,14 @@ MODULE ElemshapeData_Method USE ElemshapeData_DivergenceMethods USE ElemshapeData_GetMethods USE ElemshapeData_GradientMethods + USE ElemshapeData_H1Methods -USE ElemshapeData_Lagrange USE ElemshapeData_HCurlMethods USE ElemshapeData_HDivMethods + +USE ElemshapeData_Lagrange +USE ElemshapeData_Hierarchical + USE ElemshapeData_HRGNParamMethods USE ElemshapeData_HRQIParamMethods USE ElemshapeData_HminHmaxMethods From 01bd3d7818879c29e2767afc8ca06ce0637b1743 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 12 Jul 2024 18:48:12 +0900 Subject: [PATCH 228/359] update in reference element method --- .../Geometry/src/ReferenceElement_Method.F90 | 49 +++++++++++-------- 1 file changed, 28 insertions(+), 21 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index 47c8a2b5a..a3292e2a2 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -23,8 +23,11 @@ MODULE ReferenceElement_Method USE BaseType USE String_Class, ONLY: String USE GlobalData + IMPLICIT NONE + PRIVATE + PUBLIC :: Display PUBLIC :: MdEncode PUBLIC :: ReactEncode @@ -100,35 +103,39 @@ MODULE ReferenceElement_Method INTEGER(I4B) :: tElemTopologyType_2D = 2 INTEGER(I4B) :: tElemTopologyType_3D = 4 INTEGER(I4B) :: tElemTopologyType = 8 - INTEGER(I4B) :: elemTopologyname(8) = [ & - & Point, & - & Line, & - & Triangle, & - & Quadrangle, & - & Tetrahedron, Hexahedron, Prism, Pyramid] + INTEGER(I4B) :: elemTopologyname(8) = & + [Point, Line, Triangle, Quadrangle, Tetrahedron, Hexahedron, Prism, Pyramid] INTEGER(I4B) :: maxFaces = PARAM_REFELEM_MAX_FACES INTEGER(I4B) :: maxEdges = PARAM_REFELEM_MAX_EDGES INTEGER(I4B) :: maxPoints = PARAM_REFELEM_MAX_POINTS - INTEGER(I4B) :: tCells(8) = [0, 0, 0, 0, 1, 1, 1, 1] + INTEGER(I4B) :: tCells(8) = [1, 1, 1, 1, 1, 1, 1, 1] !! Here cell is a topology for which xidim = 3 - INTEGER(I4B) :: tFaces(8) = [0, 0, 1, 1, 4, 6, 5, 5] + INTEGER(I4B) :: tFaces(8) = [0, 2, 3, 4, 4, 6, 5, 5] !! Here facet is topology entity for which xidim = 2 - INTEGER(I4B) :: tEdges(8) = [0, 0, 3, 4, 6, 12, 9, 8] + INTEGER(I4B) :: tEdges(8) = [0, 0, 0, 0, 6, 12, 9, 8] !! Here edge is topology entity for which xidim = 1 INTEGER(I4B) :: tPoints(8) = [1, 2, 3, 4, 4, 8, 6, 5] !! A point is topology entity for which xidim = 0 - INTEGER(I4B) :: nne_in_face_triangle(1) = [3] - !! number of nodes in each face of triangle - INTEGER(I4B) :: nne_in_face_quadrangle(1) = [4] - !! number of nodes in each face of quadrangle - INTEGER(I4B) :: nne_in_face_tetrahedron(4) = [3, 3, 3, 3] - !! number of nodes in each face of tetrahedron - INTEGER(I4B) :: nne_in_face_hexahedron(6) = [4, 4, 4, 4, 4, 4] - !! number of nodes in each face of tetrahedron - INTEGER(I4B) :: nne_in_face_prism(5) = [3, 4, 4, 4, 3] - !! number of nodes in each face of tetrahedron - INTEGER(I4B) :: nne_in_face_pyramid(5) = [4, 3, 3, 3, 3] - !! number of nodes in each face of tetrahedron + !! + INTEGER(I4B) :: faceElemTypeLine(2) = Point + !! element types of face of Line + INTEGER(I4B) :: faceElemTypeTriangle(3) = Line + !! element types of faces of triangle + + INTEGER(I4B) :: faceElemTypeQuadrangle(4) = Line + !! element types of faces of triangle + + INTEGER(I4B) :: faceElemTypeTetrahedron(4) = Triangle + !! element types of faces of triangle + + INTEGER(I4B) :: faceElemTypeHexahedron(6) = Quadrangle + !! element types of faces of triangle + + INTEGER(I4B) :: faceElemTypePrism(5) = 0 + INTEGER(I4B) :: faceElemTypePyramid(5) = 0 + !! TODO: add faceElemTypePrism and faceElemTypePyramid + + !! element types of faces of triangle END TYPE ReferenceElementInfo_ TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = & From fa7418cf9f9df869ebbff527d65a28f1be7d6ceb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 12 Jul 2024 18:48:21 +0900 Subject: [PATCH 229/359] update in line interpolation utility methods --- .../src/LineInterpolationUtility@Methods.F90 | 67 ++++++++++--------- 1 file changed, 35 insertions(+), 32 deletions(-) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index e1ec30894..35d72c00a 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -1414,7 +1414,7 @@ END SUBROUTINE handle_error #endif INTEGER(I4B) :: np, nsd, ii, jj -REAL(DFP) :: pt(nips(1)), wt(nips(1)), areal +REAL(DFP) :: areal LOGICAL(LGT) :: changeLayout nrow = 0 @@ -1467,59 +1467,67 @@ END SUBROUTINE handle_error SELECT CASE (quadType) CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=ipopt%Gauss) + 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=pt, wt=wt, quadType=ipopt%GaussRadauLeft) + 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=pt, wt=wt, quadType=ipopt%GaussRadauRight) + 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=pt, wt=wt, quadType=ipopt%GaussLobatto) + 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=pt, wt=wt, quadType=ipopt%Gauss) + 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=pt, wt=wt, quadType=ipopt%GaussRadauLeft) + 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=pt, wt=wt, quadType=ipopt%GaussRadauRight) + 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=pt, wt=wt, quadType=ipopt%GaussLobatto) + 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=pt, wt=wt, quadType=ipopt%Gauss, & - alpha=alpha, beta=beta) + 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=pt, wt=wt, quadType=ipopt%GaussRadauLeft, & - alpha=alpha, beta=beta) + 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=pt, wt=wt, quadType=ipopt%GaussRadauRight, & - alpha=alpha, beta=beta) + 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=pt, wt=wt, quadType=ipopt%GaussLobatto, & - alpha=alpha, beta=beta) + 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=pt, wt=wt, quadType=ipopt%Gauss, & - lambda=lambda) +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=pt, wt=wt, & +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=pt, wt=wt, & +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=pt, wt=wt, & +CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & quadType=ipopt%GaussLobatto, lambda=lambda) CASE DEFAULT @@ -1529,28 +1537,23 @@ END SUBROUTINE handle_error END SELECT IF (changeLayout) THEN - CALL ToVEFC_Line(pt) - CALL ToVEFC_Line(wt) + CALL ToVEFC_Line(ans(1, 1:ncol)) + CALL ToVEFC_Line(ans(nrow, 1:ncol)) END IF IF (PRESENT(xij)) THEN - CALL FromBiunitLine2Segment_(xin=pt, x1=xij(:, 1), x2=xij(:, 2), ans=ans, & - nrow=ii, ncol=jj) + CALL FromBiunitLine2Segment_(xin=ans(1, 1:nrow), 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(nsd + 1, ii) = wt(ii) * areal + ans(nrow, ii) = ans(nrow, ii) * areal END DO RETURN END IF -DO CONCURRENT(ii=1:ncol) - ans(1, ii) = pt(ii) - ans(nsd + 1, ii) = wt(ii) -END DO - END PROCEDURE QuadraturePoint_Line1_ !---------------------------------------------------------------------------- From 30222c16bd0b42763ad62a848ed1e7aea7a21ff1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 15 Jul 2024 14:55:57 +0900 Subject: [PATCH 230/359] update in elemshapedata --- .../src/ElemshapeData_Method.F90 | 2 +- .../Utility/src/Reallocate/reallocate1.F90 | 41 +++++ .../Utility/src/Reallocate/reallocate10.F90 | 42 +++++ .../Utility/src/Reallocate/reallocate2.F90 | 66 ++++++++ .../Utility/src/Reallocate/reallocate3.F90 | 25 +++ .../Utility/src/Reallocate/reallocate4.F90 | 25 +++ .../Utility/src/Reallocate/reallocate5.F90 | 29 ++++ .../Utility/src/Reallocate/reallocate6.F90 | 30 ++++ .../Utility/src/Reallocate/reallocate7.F90 | 31 ++++ .../Utility/src/Reallocate/reallocate8.F90 | 160 ++++++++++++++++++ .../Utility/src/Reallocate/reallocate9.F90 | 61 +++++++ 11 files changed, 511 insertions(+), 1 deletion(-) create mode 100644 src/submodules/Utility/src/Reallocate/reallocate1.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate10.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate2.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate3.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate4.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate5.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate6.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate7.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate8.F90 create mode 100644 src/submodules/Utility/src/Reallocate/reallocate9.F90 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 index 7df24ee59..1f5ec1700 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -16,7 +16,6 @@ MODULE ElemshapeData_Method USE ElemshapeData_ConstructorMethods -USE ElemshapeData_DGMethods USE ElemshapeData_DivergenceMethods USE ElemshapeData_GetMethods USE ElemshapeData_GradientMethods @@ -24,6 +23,7 @@ MODULE ElemshapeData_Method USE ElemshapeData_H1Methods USE ElemshapeData_HCurlMethods USE ElemshapeData_HDivMethods +USE ElemshapeData_DGMethods USE ElemshapeData_Lagrange USE ElemshapeData_Hierarchical diff --git a/src/submodules/Utility/src/Reallocate/reallocate1.F90 b/src/submodules/Utility/src/Reallocate/reallocate1.F90 new file mode 100644 index 000000000..c076b4f0c --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate1.F90 @@ -0,0 +1,41 @@ +LOGICAL :: isok, abool, ex, acase +INTEGER(I4B) :: ii, fac + +ex = .FALSE. +IF (PRESENT(isExpand)) ex = isExpand + +fac = 1 +IF (PRESENT(expandFactor)) fac = expandFactor + +isok = ALLOCATED(mat) + +acase = isok .AND. (.NOT. ex) +IF (acase) THEN + abool = SIZE(mat) .NE. row + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(row)) + END IF + + ! CALL setzeros + DO CONCURRENT(ii=1:row); mat(ii) = ZEROVALUE; END DO + RETURN +END IF + +acase = isok .AND. ex +IF (acase) THEN + + abool = SIZE(mat) .LT. row + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(row * fac)) + END IF + + DO CONCURRENT(ii=1:row); mat(ii) = ZEROVALUE; END DO + RETURN +END IF + +ALLOCATE (mat(row * fac)) +DO CONCURRENT(ii=1:row); mat(ii) = ZEROVALUE; END DO +! CALL setzeros diff --git a/src/submodules/Utility/src/Reallocate/reallocate10.F90 b/src/submodules/Utility/src/Reallocate/reallocate10.F90 new file mode 100644 index 000000000..b9d96a983 --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate10.F90 @@ -0,0 +1,42 @@ +LOGICAL(LGT) :: isok, abool +INTEGER(I4B) :: ii + +isok = ALLOCATED(A) + +IF (isok) THEN + + abool = SIZE(A) .NE. nA + + IF (abool) THEN + DEALLOCATE (A) + ALLOCATE (A(nA)) + END IF + +ELSE + + ALLOCATE (A(nA)) + +END IF + +DO CONCURRENT(ii=1:nA) + A(ii) = 0.0 +END DO + +isok = ALLOCATED(IA) + +IF (isok) THEN + + abool = SIZE(IA) .NE. nIA + + IF (abool) THEN + DEALLOCATE (IA) + ALLOCATE (IA(nIA)) + END IF + +ELSE + ALLOCATE (IA(nIA)) +END IF + +DO CONCURRENT(ii=1:nIA) + IA(ii) = 0 +END DO diff --git a/src/submodules/Utility/src/Reallocate/reallocate2.F90 b/src/submodules/Utility/src/Reallocate/reallocate2.F90 new file mode 100644 index 000000000..570150ba5 --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate2.F90 @@ -0,0 +1,66 @@ +LOGICAL :: isok, abool, ex, acase +INTEGER(I4B) :: s(2), ii, jj, fac + +ex = .FALSE. +IF (PRESENT(isExpand)) ex = isExpand + +fac = 1 +IF (PRESENT(expandFactor)) fac = expandFactor + +isok = ALLOCATED(mat) + +acase = isok .AND. (.NOT. ex) + +IF (acase) THEN + + s = SHAPE(mat) + + abool = s(1) .NE. row .OR. s(2) .NE. col + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(row, col)) + END IF + + DO CONCURRENT(ii=1:row, jj=1:col) + mat(ii, jj) = ZEROVALUE + END DO + RETURN + +END IF + +acase = isok .AND. ex + +IF (acase) THEN + + s = SHAPE(mat) + + abool = (s(1) .LT. row) .OR. & + (s(2) .LT. col) + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(row * fac, col * fac)) + END IF + + DO CONCURRENT(ii=1:row, jj=1:col) + mat(ii, jj) = ZEROVALUE + END DO + RETURN + +END IF + +ALLOCATE (mat(row * fac, col * fac)) + +DO CONCURRENT(ii=1:row, jj=1:col) + mat(ii, jj) = ZEROVALUE +END DO + +! IF (ALLOCATED(mat)) THEN +! IF ((SIZE(mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN +! DEALLOCATE (mat) +! ALLOCATE (mat(row, col)) +! END IF +! ELSE +! ALLOCATE (mat(row, col)) +! END IF diff --git a/src/submodules/Utility/src/Reallocate/reallocate3.F90 b/src/submodules/Utility/src/Reallocate/reallocate3.F90 new file mode 100644 index 000000000..cf5b6380e --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate3.F90 @@ -0,0 +1,25 @@ +LOGICAL :: isok, abool +INTEGER(I4B) :: s(3), ii, jj, kk + +isok = ALLOCATED(mat) + +IF (isok) THEN + + s = SHAPE(mat) + + abool = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(i1, i2, i3)) + END IF + +ELSE + + ALLOCATE (mat(i1, i2, i3)) + +END IF + +DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3) + mat(ii, jj, kk) = ZEROVALUE +END DO diff --git a/src/submodules/Utility/src/Reallocate/reallocate4.F90 b/src/submodules/Utility/src/Reallocate/reallocate4.F90 new file mode 100644 index 000000000..52ca3200a --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate4.F90 @@ -0,0 +1,25 @@ +LOGICAL :: isok, abool +INTEGER(I4B) :: s(4), ii, jj, kk, ll + +isok = ALLOCATED(mat) + +IF (isok) THEN + + s = SHAPE(mat) + + abool = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 .OR. s(4) .NE. i4 + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(i1, i2, i3, i4)) + END IF + +ELSE + + ALLOCATE (mat(i1, i2, i3, i4)) + +END IF + +DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4) + mat(ii, jj, kk, ll) = ZEROVALUE +END DO diff --git a/src/submodules/Utility/src/Reallocate/reallocate5.F90 b/src/submodules/Utility/src/Reallocate/reallocate5.F90 new file mode 100644 index 000000000..9b373357a --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate5.F90 @@ -0,0 +1,29 @@ +LOGICAL :: isok, abool +INTEGER(I4B) :: s(5), ii, jj, kk, ll, mm + +isok = ALLOCATED(mat) + +IF (isok) THEN + + s = SHAPE(mat) + + abool = (s(1) .NE. i1) .OR. & + (s(2) .NE. i2) .OR. & + s(3) .NE. i3 .OR. & + s(4) .NE. i4 .OR. & + s(5) .NE. i5 + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(i1, i2, i3, i4, i5)) + END IF + +ELSE + + ALLOCATE (mat(i1, i2, i3, i4, i5)) + +END IF + +DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4, mm=1:i5) + mat(ii, jj, kk, ll, mm) = ZEROVALUE +END DO diff --git a/src/submodules/Utility/src/Reallocate/reallocate6.F90 b/src/submodules/Utility/src/Reallocate/reallocate6.F90 new file mode 100644 index 000000000..596eb4be7 --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate6.F90 @@ -0,0 +1,30 @@ +LOGICAL :: isok, abool +INTEGER(I4B) :: s(6), ii, jj, kk, ll, mm, nn + +isok = ALLOCATED(mat) + +IF (isok) THEN + + s = SHAPE(mat) + + abool = (s(1) .NE. i1) .OR. & + (s(2) .NE. i2) .OR. & + s(3) .NE. i3 .OR. & + s(4) .NE. i4 .OR. & + s(5) .NE. i5 .OR. & + s(6) .NE. i6 + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(i1, i2, i3, i4, i5, i6)) + END IF + +ELSE + + ALLOCATE (mat(i1, i2, i3, i4, i5, i6)) + +END IF + +DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4, mm=1:i5, nn=1:i6) + mat(ii, jj, kk, ll, mm, nn) = ZEROVALUE +END DO diff --git a/src/submodules/Utility/src/Reallocate/reallocate7.F90 b/src/submodules/Utility/src/Reallocate/reallocate7.F90 new file mode 100644 index 000000000..ebbc04acf --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate7.F90 @@ -0,0 +1,31 @@ +LOGICAL :: isok, abool +INTEGER(I4B) :: s(7), ii, jj, kk, ll, mm, nn, oo + +isok = ALLOCATED(mat) + +IF (isok) THEN + + s = SHAPE(mat) + + abool = (s(1) .NE. i1) .OR. & + (s(2) .NE. i2) .OR. & + (s(3) .NE. i3) .OR. & + (s(4) .NE. i4) .OR. & + (s(5) .NE. i5) .OR. & + (s(6) .NE. i6) .OR. & + (s(7) .NE. i7) + + IF (abool) THEN + DEALLOCATE (mat) + ALLOCATE (mat(i1, i2, i3, i4, i5, i6, i7)) + END IF + +ELSE + + ALLOCATE (mat(i1, i2, i3, i4, i5, i6, i7)) + +END IF + +DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4, mm=1:i5, nn=1:i6, oo=1:i7) + mat(ii, jj, kk, ll, mm, nn, oo) = ZEROVALUE +END DO diff --git a/src/submodules/Utility/src/Reallocate/reallocate8.F90 b/src/submodules/Utility/src/Reallocate/reallocate8.F90 new file mode 100644 index 000000000..60cf9b2c9 --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate8.F90 @@ -0,0 +1,160 @@ +LOGICAL(LGT) :: isok, abool, ispresent +INTEGER(I4B) :: ii + +isok = ALLOCATED(vec1) + +IF (isok) THEN + + abool = SIZE(Vec1) .NE. n1 + + IF (abool) THEN + DEALLOCATE (Vec1) + ALLOCATE (Vec1(n1)) + END IF + +ELSE + ALLOCATE (Vec1(n1)) +END IF + +DO CONCURRENT(ii=1:n1) + vec1(ii) = ZERO1 +END DO + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +isok = ALLOCATED(vec2) + +IF (isok) THEN + + abool = SIZE(Vec2) .NE. n2 + + IF (abool) THEN + DEALLOCATE (Vec2) + ALLOCATE (Vec2(n2)) + END IF + +ELSE + ALLOCATE (Vec2(n2)) +END IF + +DO CONCURRENT(ii=1:n2) + vec2(ii) = ZERO2 +END DO + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ispresent = PRESENT(vec3) + +IF (ispresent) THEN + + isok = ALLOCATED(vec3) + + IF (isok) THEN + + abool = SIZE(Vec3) .NE. n3 + + IF (abool) THEN + DEALLOCATE (Vec3) + ALLOCATE (Vec3(n3)) + END IF + + ELSE + ALLOCATE (Vec3(n3)) + END IF + + DO CONCURRENT(ii=1:n3) + vec3(ii) = ZERO3 + END DO + +END IF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ispresent = PRESENT(vec4) + +IF (ispresent) THEN + + isok = ALLOCATED(vec4) + + IF (isok) THEN + + abool = SIZE(Vec4) .NE. n4 + + IF (abool) THEN + DEALLOCATE (Vec4) + ALLOCATE (Vec4(n4)) + END IF + + ELSE + ALLOCATE (Vec4(n4)) + END IF + + DO CONCURRENT(ii=1:n4) + vec4(ii) = ZERO4 + END DO + +END IF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ispresent = PRESENT(vec5) + +IF (ispresent) THEN + + isok = ALLOCATED(vec5) + + IF (isok) THEN + + abool = SIZE(Vec5) .NE. n5 + + IF (abool) THEN + DEALLOCATE (Vec5) + ALLOCATE (Vec5(n5)) + END IF + + ELSE + ALLOCATE (Vec5(n5)) + END IF + + DO CONCURRENT(ii=1:n5) + vec5(ii) = ZERO5 + END DO + +END IF + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ispresent = PRESENT(vec6) + +IF (ispresent) THEN + + isok = ALLOCATED(vec6) + + IF (isok) THEN + + abool = SIZE(Vec6) .NE. n6 + + IF (abool) THEN + DEALLOCATE (Vec6) + ALLOCATE (Vec6(n6)) + END IF + + ELSE + ALLOCATE (Vec6(n6)) + END IF + + DO CONCURRENT(ii=1:n6) + vec6(ii) = ZERO6 + END DO + +END IF diff --git a/src/submodules/Utility/src/Reallocate/reallocate9.F90 b/src/submodules/Utility/src/Reallocate/reallocate9.F90 new file mode 100644 index 000000000..5e0927306 --- /dev/null +++ b/src/submodules/Utility/src/Reallocate/reallocate9.F90 @@ -0,0 +1,61 @@ +LOGICAL(LGT) :: isok, abool +INTEGER(I4B) :: ii + +isok = ALLOCATED(A) + +IF (isok) THEN + + abool = SIZE(A) .NE. nA + + IF (abool) THEN + DEALLOCATE (A) + ALLOCATE (A(nA)) + END IF + +ELSE + + ALLOCATE (A(nA)) + +END IF + +DO CONCURRENT(ii=1:nA) + A(ii) = 0.0 +END DO + +isok = ALLOCATED(IA) + +IF (isok) THEN + + abool = SIZE(IA) .NE. nIA + + IF (abool) THEN + DEALLOCATE (IA) + ALLOCATE (IA(nIA)) + END IF + +ELSE + ALLOCATE (IA(nIA)) +END IF + +DO CONCURRENT(ii=1:nIA) + IA(ii) = 0 +END DO + +isok = ALLOCATED(JA) + +IF (isok) THEN + + abool = SIZE(JA) .NE. nJA + + IF (abool) THEN + DEALLOCATE (JA) + ALLOCATE (JA(nJA)) + END IF + +ELSE + ALLOCATE (JA(nJA)) +END IF + +DO CONCURRENT(ii=1:nJA) + JA(ii) = 0 +END DO From bb691cd6de28f2f8ebe7bcc8ded4e3f0ba29c93b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 15 Jul 2024 14:56:07 +0900 Subject: [PATCH 231/359] update in hierarchical poly nomial --- .../Polynomial/src/HierarchicalPolynomialUtility.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 index f886dfcf2..bd2596980 100644 --- a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 @@ -245,10 +245,10 @@ MODULE SUBROUTINE HierarchicalGradientEvalAll_(elemType, xij, ans, & !! x(2, :) is y coord !! x(3, :) is z coord REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - !! Value of n+1 Hierarchical polynomials at point x + !! gradient of polynomials at quadrature points INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! nrow = SIZE(x, 2) - !! ncol = SIZE(xij, 2) + !! dim1 = SIZE(xij, 2) + !! dim2 = SIZE(xij, 2) CHARACTER(*), INTENT(IN) :: domainName !! domain of reference element !! UNIT ! BIUNIT From 80a1ca31796c360026f219b29711e4121095f2f1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 15 Jul 2024 14:56:13 +0900 Subject: [PATCH 232/359] update in reallocate utility --- src/modules/Utility/src/ReallocateUtility.F90 | 680 ++++++++++++++---- 1 file changed, 528 insertions(+), 152 deletions(-) diff --git a/src/modules/Utility/src/ReallocateUtility.F90 b/src/modules/Utility/src/ReallocateUtility.F90 index 132063cdf..8d9f989f7 100644 --- a/src/modules/Utility/src/ReallocateUtility.F90 +++ b/src/modules/Utility/src/ReallocateUtility.F90 @@ -16,8 +16,11 @@ ! MODULE ReallocateUtility -USE GlobalData +USE GlobalData, ONLY: DFP, LGT, I4B, REAL32, REAL64, REAL128, & + INT8, INT16, INT32, INT64 + IMPLICIT NONE + PRIVATE PUBLIC :: Reallocate @@ -27,9 +30,15 @@ MODULE ReallocateUtility !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_logical(Mat, row) - LOGICAL(LGT), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_logical(mat, row, isExpand, expandFactor) + LOGICAL(LGT), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: row + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size if more than required + !! in this case if the size is not enough then the new size + !! is expandFactor time row + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor + !! expand factor, used when isExpand is true. END SUBROUTINE Reallocate_logical END INTERFACE Reallocate @@ -38,9 +47,14 @@ END SUBROUTINE Reallocate_logical !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R1(Mat, row) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Real64_R1(mat, row, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: row + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R1 END INTERFACE Reallocate @@ -49,9 +63,14 @@ END SUBROUTINE Reallocate_Real64_R1 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R1b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Real64_R1b(mat, s, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R1b END INTERFACE Reallocate @@ -60,9 +79,14 @@ END SUBROUTINE Reallocate_Real64_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R1(Mat, row) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Real32_R1(mat, row, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: row + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R1 END INTERFACE Reallocate @@ -71,9 +95,14 @@ END SUBROUTINE Reallocate_Real32_R1 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R1b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Real32_R1b(mat, s, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R1b END INTERFACE Reallocate @@ -82,9 +111,14 @@ END SUBROUTINE Reallocate_Real32_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R2(Mat, row, col) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R2(mat, row, col, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R2 END INTERFACE Reallocate @@ -93,9 +127,14 @@ END SUBROUTINE Reallocate_Real64_R2 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R2b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R2b(mat, s, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R2b END INTERFACE Reallocate @@ -104,9 +143,14 @@ END SUBROUTINE Reallocate_Real64_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R2(Mat, row, col) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R2(mat, row, col, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R2 END INTERFACE Reallocate @@ -115,9 +159,14 @@ END SUBROUTINE Reallocate_Real32_R2 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R2b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R2b(mat, s, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R2b END INTERFACE Reallocate @@ -126,9 +175,14 @@ END SUBROUTINE Reallocate_Real32_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R3(Mat, i1, i2, i3) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R3(mat, i1, i2, i3, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R3 END INTERFACE Reallocate @@ -137,9 +191,14 @@ END SUBROUTINE Reallocate_Real64_R3 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R3b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R3b(mat, s, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R3b END INTERFACE Reallocate @@ -148,9 +207,14 @@ END SUBROUTINE Reallocate_Real64_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R3(Mat, i1, i2, i3) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R3(mat, i1, i2, i3, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R3 END INTERFACE Reallocate @@ -159,9 +223,14 @@ END SUBROUTINE Reallocate_Real32_R3 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R3b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R3b(mat, s, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R3b END INTERFACE Reallocate @@ -170,9 +239,14 @@ END SUBROUTINE Reallocate_Real32_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R4(Mat, i1, i2, i3, i4) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R4 END INTERFACE Reallocate @@ -181,9 +255,14 @@ END SUBROUTINE Reallocate_Real64_R4 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R4b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R4b(mat, s, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R4b END INTERFACE Reallocate @@ -192,9 +271,14 @@ END SUBROUTINE Reallocate_Real64_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R4(Mat, i1, i2, i3, i4) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R4 END INTERFACE Reallocate @@ -203,9 +287,14 @@ END SUBROUTINE Reallocate_Real32_R4 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R4b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R4b(mat, s, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R4b END INTERFACE Reallocate @@ -214,9 +303,14 @@ END SUBROUTINE Reallocate_Real32_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R5(Mat, i1, i2, i3, i4, i5) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R5 END INTERFACE Reallocate @@ -225,9 +319,14 @@ END SUBROUTINE Reallocate_Real64_R5 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R5b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R5b(mat, s, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R5b END INTERFACE Reallocate @@ -236,9 +335,14 @@ END SUBROUTINE Reallocate_Real64_R5b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R5(Mat, i1, i2, i3, i4, i5) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R5 END INTERFACE Reallocate @@ -247,9 +351,14 @@ END SUBROUTINE Reallocate_Real32_R5 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R5b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R5b(mat, s, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R5b END INTERFACE Reallocate @@ -258,9 +367,15 @@ END SUBROUTINE Reallocate_Real32_R5b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R6(Mat, i1, i2, i3, i4, i5, i6) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R6(mat, i1, i2, i3, i4, i5, i6, & + isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R6 END INTERFACE Reallocate @@ -269,9 +384,14 @@ END SUBROUTINE Reallocate_Real64_R6 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R6b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R6b(mat, s, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R6b END INTERFACE Reallocate @@ -280,9 +400,14 @@ END SUBROUTINE Reallocate_Real64_R6b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R6(Mat, i1, i2, i3, i4, i5, i6) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R6(mat, i1, i2, i3, i4, i5, i6, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R6 END INTERFACE Reallocate @@ -291,9 +416,14 @@ END SUBROUTINE Reallocate_Real32_R6 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R6b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R6b(mat, s, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R6b END INTERFACE Reallocate @@ -302,10 +432,15 @@ END SUBROUTINE Reallocate_Real32_R6b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R7(Mat, i1, i2, i3, i4, i5, & - & i6, i7) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R7(mat, i1, i2, i3, i4, i5, & + & i6, i7, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R7 END INTERFACE Reallocate @@ -314,9 +449,14 @@ END SUBROUTINE Reallocate_Real64_R7 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R7b(Mat, s) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real64_R7b(mat, s, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R7b END INTERFACE Reallocate @@ -325,9 +465,15 @@ END SUBROUTINE Reallocate_Real64_R7b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R7(Mat, i1, i2, i3, i4, i5, i6, i7) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R7(mat, i1, i2, i3, i4, i5, i6, & + i7, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R7 END INTERFACE Reallocate @@ -336,9 +482,14 @@ END SUBROUTINE Reallocate_Real32_R7 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R7b(Mat, s) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Real32_R7b(mat, s, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R7b END INTERFACE Reallocate @@ -347,9 +498,14 @@ END SUBROUTINE Reallocate_Real32_R7b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R1(Mat, row) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int64_R1(mat, row, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: row + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R1 END INTERFACE Reallocate @@ -358,9 +514,14 @@ END SUBROUTINE Reallocate_Int64_R1 !---------------------------------------------------------------------------- INTERFACE - MODULE PURE SUBROUTINE Reallocate_Int64_R1b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int64_R1b(mat, s, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R1b END INTERFACE @@ -373,9 +534,14 @@ END SUBROUTINE Reallocate_Int64_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R1(Mat, row) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int32_R1(mat, row, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: row + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R1 END INTERFACE Reallocate @@ -384,9 +550,14 @@ END SUBROUTINE Reallocate_Int32_R1 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R1b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int32_R1b(mat, s, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R1b END INTERFACE Reallocate @@ -395,9 +566,14 @@ END SUBROUTINE Reallocate_Int32_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int16_R1(Mat, row) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int16_R1(mat, row, isExpand, expandFactor) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: row + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int16_R1 END INTERFACE Reallocate @@ -406,9 +582,14 @@ END SUBROUTINE Reallocate_Int16_R1 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int16_R1b(Mat, s) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int16_R1b(mat, s, isExpand, expandFactor) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int16_R1b END INTERFACE Reallocate @@ -417,9 +598,14 @@ END SUBROUTINE Reallocate_Int16_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int8_R1(Mat, row) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int8_R1(mat, row, isExpand, expandFactor) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: row + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int8_R1 END INTERFACE Reallocate @@ -428,9 +614,14 @@ END SUBROUTINE Reallocate_Int8_R1 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int8_R1b(Mat, s) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:) + MODULE PURE SUBROUTINE Reallocate_Int8_R1b(mat, s, isExpand, expandFactor) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int8_R1b END INTERFACE Reallocate @@ -439,44 +630,84 @@ END SUBROUTINE Reallocate_Int8_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R2(Mat, row, col) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R2(mat, row, col, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R2 - MODULE PURE SUBROUTINE Reallocate_Int64_R2b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R2b(mat, s, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R2b - MODULE PURE SUBROUTINE Reallocate_Int32_R2(Mat, row, col) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R2(mat, row, col, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R2 - MODULE PURE SUBROUTINE Reallocate_Int32_R2b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R2b(mat, s, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R2b - MODULE PURE SUBROUTINE Reallocate_Int16_R2(Mat, row, col) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int16_R2(mat, row, col, isExpand, expandFactor) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int16_R2 - MODULE PURE SUBROUTINE Reallocate_Int16_R2b(Mat, s) - INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int16_R2b(mat, s, isExpand, expandFactor) + INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int16_R2b - MODULE PURE SUBROUTINE Reallocate_Int8_R2(Mat, row, col) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int8_R2(mat, row, col, isExpand, expandFactor) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int8_R2 - MODULE PURE SUBROUTINE Reallocate_Int8_R2b(Mat, s) - INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) + MODULE PURE SUBROUTINE Reallocate_Int8_R2b(mat, s, isExpand, expandFactor) + INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int8_R2b END INTERFACE Reallocate @@ -485,9 +716,14 @@ END SUBROUTINE Reallocate_Int8_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R3(Mat, i1, i2, i3) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R3(mat, i1, i2, i3, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R3 END INTERFACE Reallocate @@ -496,9 +732,14 @@ END SUBROUTINE Reallocate_Int64_R3 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R3b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R3b(mat, s, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R3b END INTERFACE Reallocate @@ -507,9 +748,14 @@ END SUBROUTINE Reallocate_Int64_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R3(Mat, i1, i2, i3) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R3(mat, i1, i2, i3, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R3 END INTERFACE Reallocate @@ -518,9 +764,14 @@ END SUBROUTINE Reallocate_Int32_R3 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R3b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R3b(mat, s, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R3b END INTERFACE Reallocate @@ -529,9 +780,15 @@ END SUBROUTINE Reallocate_Int32_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R4(Mat, i1, i2, i3, i4) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R4(mat, i1, & + i2, i3, i4, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R4 END INTERFACE Reallocate @@ -540,9 +797,14 @@ END SUBROUTINE Reallocate_Int64_R4 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R4b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R4b(mat, s, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R4b END INTERFACE Reallocate @@ -551,9 +813,14 @@ END SUBROUTINE Reallocate_Int64_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R4(Mat, i1, i2, i3, i4) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R4 END INTERFACE Reallocate @@ -562,9 +829,14 @@ END SUBROUTINE Reallocate_Int32_R4 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R4b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R4b(mat, s, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R4b END INTERFACE Reallocate @@ -573,9 +845,15 @@ END SUBROUTINE Reallocate_Int32_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R5(Mat, i1, i2, i3, i4, i5) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R5(mat, i1, i2, i3, i4, i5, & + isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R5 END INTERFACE Reallocate @@ -584,9 +862,14 @@ END SUBROUTINE Reallocate_Int64_R5 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R5b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R5b(mat, s, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R5b END INTERFACE Reallocate @@ -595,9 +878,15 @@ END SUBROUTINE Reallocate_Int64_R5b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R5(Mat, i1, i2, i3, i4, i5) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R5(mat, i1, i2, i3, i4, i5, & + isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R5 END INTERFACE Reallocate @@ -606,9 +895,14 @@ END SUBROUTINE Reallocate_Int32_R5 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R5b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R5b(mat, s, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R5b END INTERFACE Reallocate @@ -617,9 +911,15 @@ END SUBROUTINE Reallocate_Int32_R5b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R6(Mat, i1, i2, i3, i4, i5, i6) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R6(mat, i1, i2, i3, i4, i5, i6, & + isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R6 END INTERFACE Reallocate @@ -628,9 +928,14 @@ END SUBROUTINE Reallocate_Int64_R6 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R6b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R6b(mat, s, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R6b END INTERFACE Reallocate @@ -639,9 +944,15 @@ END SUBROUTINE Reallocate_Int64_R6b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R6(Mat, i1, i2, i3, i4, i5, i6) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R6(mat, i1, i2, i3, i4, i5, i6, & + isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R6 END INTERFACE Reallocate @@ -650,9 +961,14 @@ END SUBROUTINE Reallocate_Int32_R6 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R6b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R6b(mat, s, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R6b END INTERFACE Reallocate @@ -661,10 +977,15 @@ END SUBROUTINE Reallocate_Int32_R6b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R7(Mat, i1, i2, i3, i4, i5, & - & i6, i7) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R7(mat, i1, i2, i3, i4, i5, & + & i6, i7, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R7 END INTERFACE Reallocate @@ -673,9 +994,14 @@ END SUBROUTINE Reallocate_Int64_R7 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R7b(Mat, s) - INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int64_R7b(mat, s, isExpand, expandFactor) + INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R7b END INTERFACE Reallocate @@ -684,9 +1010,15 @@ END SUBROUTINE Reallocate_Int64_R7b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R7(Mat, i1, i2, i3, i4, i5, i6, i7) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R7(mat, i1, i2, i3, i4, i5, i6, & + i7, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R7 END INTERFACE Reallocate @@ -695,9 +1027,14 @@ END SUBROUTINE Reallocate_Int32_R7 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R7b(Mat, s) - INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :) + MODULE PURE SUBROUTINE Reallocate_Int32_R7b(mat, s, isExpand, expandFactor) + INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: s(:) + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R7b END INTERFACE Reallocate @@ -706,13 +1043,18 @@ END SUBROUTINE Reallocate_Int32_R7b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R1_6(Vec1, n1, Vec2, n2, Vec3, & - & n3, Vec4, n4, Vec5, n5, Vec6, n6) - INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) - INTEGER(I4B), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & - & Vec4(:), Vec5(:), Vec6(:) + MODULE PURE SUBROUTINE Reallocate_Int32_R1_6(vec1, n1, vec2, n2, vec3, & + n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor) + INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:) + INTEGER(I4B), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), & + vec4(:), vec5(:), vec6(:) INTEGER(I4B), INTENT(IN) :: n1, n2 INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R1_6 END INTERFACE Reallocate @@ -721,13 +1063,18 @@ END SUBROUTINE Reallocate_Int32_R1_6 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R1_6(Vec1, n1, Vec2, & - & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6) - REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) - REAL(REAL64), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & - & Vec4(:), Vec5(:), Vec6(:) + MODULE PURE SUBROUTINE Reallocate_Real64_R1_6(vec1, n1, vec2, & + n2, vec3, n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor) + REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:) + REAL(REAL64), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), & + vec4(:), vec5(:), vec6(:) INTEGER(I4B), INTENT(IN) :: n1, n2 INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_R1_6 END INTERFACE Reallocate @@ -736,13 +1083,18 @@ END SUBROUTINE Reallocate_Real64_R1_6 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R1_6(Vec1, n1, Vec2, & - & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6) - REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:) - REAL(REAL32), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), & - & Vec4(:), Vec5(:), Vec6(:) + MODULE PURE SUBROUTINE Reallocate_Real32_R1_6(vec1, n1, vec2, & + n2, vec3, n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor) + REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:) + REAL(REAL32), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), & + vec4(:), vec5(:), vec6(:) INTEGER(I4B), INTENT(IN) :: n1, n2 INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6 + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_R1_6 END INTERFACE Reallocate @@ -751,10 +1103,16 @@ END SUBROUTINE Reallocate_Real32_R1_6 !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_AIJ(A, nA, IA, nIA, JA, nJA) + MODULE PURE SUBROUTINE Reallocate_Real64_AIJ(A, nA, IA, nIA, JA, nJA, & + isExpand, expandFactor) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:) INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:) INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_AIJ END INTERFACE Reallocate @@ -763,10 +1121,16 @@ END SUBROUTINE Reallocate_Real64_AIJ !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_AIJ(A, nA, IA, nIA, JA, nJA) + MODULE PURE SUBROUTINE Reallocate_Real32_AIJ(A, nA, IA, nIA, JA, nJA, & + isExpand, expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:) INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:) INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_AIJ END INTERFACE Reallocate @@ -775,10 +1139,16 @@ END SUBROUTINE Reallocate_Real32_AIJ !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_AI(A, nA, IA, nIA) + MODULE PURE SUBROUTINE Reallocate_Real64_AI(A, nA, IA, nIA, isExpand, & + expandFactor) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:) INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:) INTEGER(I4B), INTENT(IN) :: nA, nIA + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real64_AI END INTERFACE Reallocate @@ -787,10 +1157,16 @@ END SUBROUTINE Reallocate_Real64_AI !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_AI(A, nA, IA, nIA) + MODULE PURE SUBROUTINE Reallocate_Real32_AI(A, nA, IA, nIA, isExpand, & + expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:) INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:) INTEGER(I4B), INTENT(IN) :: nA, nIA + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand + !! if true then we do not allocate if current size is more than required + !! in this case if the size is not enough then the new size + !! is expandFactor times required size + INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Real32_AI END INTERFACE Reallocate From 2a7cdfc7030926eed4a1a8d97f0923effd1e8594 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 15 Jul 2024 14:56:25 +0900 Subject: [PATCH 233/359] update in elemshapedata hierarchical methods --- .../Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 index cd080f6b7..4e7c7ad5e 100644 --- a/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 +++ b/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 @@ -89,7 +89,8 @@ faceOrient=faceOrient, & edgeOrient=edgeOrient) -CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=2, i2=3, i3=1) +CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:kk), i1=2, i2=3, i3=1) +! CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=3, i2=1, i3=2) IF (ALLOCATED(temp)) DEALLOCATE (temp) From 7b379d4c17d9094f3d6987a83a53afed835af419 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 15 Jul 2024 14:56:34 +0900 Subject: [PATCH 234/359] update in elemshapedata set methods --- .../ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 index 2353d3d0f..143d1bb7f 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -92,7 +92,9 @@ REAL(DFP), ALLOCATABLE :: InvJacobian(:, :, :) NSD = obj%RefElem%NSD + XiDim = obj%RefElem%XiDimension + IF (NSD .NE. XiDim) THEN obj%dNdXt = 0.0_DFP ELSE From 76ae5576af76d0d7cb55551b0f90b3189909974a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 15 Jul 2024 14:56:47 +0900 Subject: [PATCH 235/359] update in hierarchical polynomial utility --- .../HierarchicalPolynomialUtility@Methods.F90 | 24 +++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 index f58b2ed3b..576237b23 100644 --- a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 @@ -552,10 +552,18 @@ SUBROUTINE check_error_2d(ierr, tface, routine, cellOrder, & RETURN END IF - isok = SIZE(faceOrder, 2) .EQ. tface + isok = SIZE(faceOrder, 2) .GE. tface IF (.NOT. isok) THEN ierr = ierr - 1 - errmsg = "the size of faceOrder should be total face in elements" + errmsg = "colsize of faceOrder should be at least total face in elements" + CALL print_error + RETURN + END IF + + isok = SIZE(faceOrder, 1) .GE. 3_I4B + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "rowsize of faceOrder should be at least 3" CALL print_error RETURN END IF @@ -568,10 +576,18 @@ SUBROUTINE check_error_2d(ierr, tface, routine, cellOrder, & RETURN END IF - isok = SIZE(faceOrient, 2) .EQ. tface + isok = SIZE(faceOrient, 1) .GE. 3 + IF (.NOT. isok) THEN + ierr = ierr - 1 + errmsg = "rowsize of faceOrient should be at least 3" + CALL print_error + RETURN + END IF + + isok = SIZE(faceOrient, 2) .GE. tface IF (.NOT. isok) THEN ierr = ierr - 1 - errmsg = "number of cols in faceOrient should be total face in elements" + errmsg = "colsize of faceOrient should be at least total face in elements" CALL print_error RETURN END IF From c4df43edcc5cf5396f99656ff0fca84b479043f4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 15 Jul 2024 14:56:57 +0900 Subject: [PATCH 236/359] update in reallocate utility --- .../Utility/src/ReallocateUtility@Methods.F90 | 838 ++++-------------- 1 file changed, 186 insertions(+), 652 deletions(-) diff --git a/src/submodules/Utility/src/ReallocateUtility@Methods.F90 b/src/submodules/Utility/src/ReallocateUtility@Methods.F90 index a468f09db..2e4a87c96 100644 --- a/src/submodules/Utility/src/ReallocateUtility@Methods.F90 +++ b/src/submodules/Utility/src/ReallocateUtility@Methods.F90 @@ -20,7 +20,6 @@ ! summary: Methods for reallocating arrays SUBMODULE(ReallocateUtility) Methods -USE BaseMethod IMPLICIT NONE CONTAINS @@ -29,15 +28,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_logical -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = .FALSE. +#define ZEROVALUE .FALSE. +#include "./Reallocate/reallocate1.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_logical !---------------------------------------------------------------------------- @@ -45,15 +38,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0.0_DFP +#define ZEROVALUE 0.0_Real64 +#include "./Reallocate/reallocate1.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real64_R1 !---------------------------------------------------------------------------- @@ -61,7 +48,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R1b -CALL Reallocate_Real64_R1(mat, s(1)) +CALL Reallocate_Real64_R1(mat, s(1), isExpand, expandFactor) END PROCEDURE Reallocate_Real64_R1b !---------------------------------------------------------------------------- @@ -69,15 +56,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real32 +#include "./Reallocate/reallocate1.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real32_R1 !---------------------------------------------------------------------------- @@ -85,7 +66,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R1b -CALL Reallocate_Real32_R1(mat, s(1)) +CALL Reallocate_Real32_R1(mat, s(1), isExpand, expandFactor) END PROCEDURE Reallocate_Real32_R1b !---------------------------------------------------------------------------- @@ -93,15 +74,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0.0_DFP +#define ZEROVALUE 0.0_Real64 +#include "./Reallocate/reallocate2.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real64_R2 !---------------------------------------------------------------------------- @@ -109,7 +84,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R2b -CALL Reallocate_Real64_R2(mat, s(1), s(2)) +CALL Reallocate_Real64_R2(mat, s(1), s(2), isExpand, expandFactor) END PROCEDURE Reallocate_Real64_R2b !---------------------------------------------------------------------------- @@ -117,15 +92,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real32 +#include "./Reallocate/reallocate2.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real32_R2 !---------------------------------------------------------------------------- @@ -133,7 +102,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R2b -CALL Reallocate_Real32_R2(mat, s(1), s(2)) +CALL Reallocate_Real32_R2(mat, s(1), s(2), isExpand, expandFactor) END PROCEDURE Reallocate_Real32_R2b !--------------------------------------------------------------------------- @@ -141,17 +110,9 @@ !--------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0.0_DFP +#define ZEROVALUE 0.0_Real64 +#include "./Reallocate/reallocate3.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real64_R3 !---------------------------------------------------------------------------- @@ -159,7 +120,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R3b -CALL Reallocate_Real64_R3(mat, s(1), s(2), s(3)) +CALL Reallocate_Real64_R3(mat, s(1), s(2), s(3), isExpand, expandFactor) END PROCEDURE Reallocate_Real64_R3b !--------------------------------------------------------------------------- @@ -167,17 +128,9 @@ !--------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real32 +#include "./Reallocate/reallocate3.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real32_R3 !---------------------------------------------------------------------------- @@ -185,7 +138,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R3b -CALL Reallocate_Real32_R3(mat, s(1), s(2), s(3)) +CALL Reallocate_Real32_R3(mat, s(1), s(2), s(3), isExpand, expandFactor) END PROCEDURE Reallocate_Real32_R3b !---------------------------------------------------------------------------- @@ -193,19 +146,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real64 +#include "./Reallocate/reallocate4.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real64_R4 !---------------------------------------------------------------------------- @@ -213,7 +156,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R4b -CALL Reallocate_Real64_R4(mat, s(1), s(2), s(3), s(4)) +CALL Reallocate_Real64_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor) END PROCEDURE Reallocate_Real64_R4b !---------------------------------------------------------------------------- @@ -221,19 +164,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real32 +#include "./Reallocate/reallocate4.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real32_R4 !---------------------------------------------------------------------------- @@ -241,7 +174,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R4b -CALL Reallocate_Real32_R4(mat, s(1), s(2), s(3), s(4)) +CALL Reallocate_Real32_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor) END PROCEDURE Reallocate_Real32_R4b !---------------------------------------------------------------------------- @@ -249,15 +182,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real64 +#include "./Reallocate/reallocate5.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real64_R5 !---------------------------------------------------------------------------- @@ -265,7 +192,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R5b -CALL Reallocate_Real64_R5(mat, s(1), s(2), s(3), s(4), s(5)) +CALL Reallocate_Real64_R5(mat, s(1), s(2), s(3), s(4), s(5), & + isExpand, expandFactor) END PROCEDURE Reallocate_Real64_R5b !---------------------------------------------------------------------------- @@ -273,15 +201,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real32 +#include "./Reallocate/reallocate5.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real32_R5 !---------------------------------------------------------------------------- @@ -289,7 +211,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R5b -CALL Reallocate_Real32_R5(mat, s(1), s(2), s(3), s(4), s(5)) +CALL Reallocate_Real32_R5(mat, s(1), s(2), s(3), s(4), s(5), & + isExpand, expandFactor) END PROCEDURE Reallocate_Real32_R5b !---------------------------------------------------------------------------- @@ -297,15 +220,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real64 +#include "./Reallocate/reallocate6.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real64_R6 !---------------------------------------------------------------------------- @@ -313,7 +230,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R6b -CALL Reallocate_Real64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +CALL Reallocate_Real64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), & + isExpand, expandFactor) END PROCEDURE Reallocate_Real64_R6b !---------------------------------------------------------------------------- @@ -321,15 +239,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real32 +#include "./Reallocate/reallocate6.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real32_R6 !---------------------------------------------------------------------------- @@ -337,7 +249,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R6b -CALL Reallocate_Real32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +CALL Reallocate_Real32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), & + isExpand, expandFactor) END PROCEDURE Reallocate_Real32_R6b !---------------------------------------------------------------------------- @@ -345,15 +258,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real64 +#include "./Reallocate/reallocate7.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real64_R7 !---------------------------------------------------------------------------- @@ -361,7 +268,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R7b -CALL Reallocate_Real64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +CALL Reallocate_Real64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), & + isExpand, expandFactor) END PROCEDURE Reallocate_Real64_R7b !---------------------------------------------------------------------------- @@ -369,15 +277,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0.0 +#define ZEROVALUE 0.0_Real32 +#include "./Reallocate/reallocate7.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Real32_R7 !---------------------------------------------------------------------------- @@ -385,7 +287,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R7b -CALL Reallocate_Real32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +CALL Reallocate_Real32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), & + isExpand, expandFactor) END PROCEDURE Reallocate_Real32_R7b !---------------------------------------------------------------------------- @@ -393,15 +296,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int64 +#include "./Reallocate/reallocate1.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int64_R1 !---------------------------------------------------------------------------- @@ -409,7 +306,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R1b -CALL Reallocate_Int64_R1(mat, s(1)) +CALL Reallocate_Int64_R1(mat, s(1), isExpand, expandFactor) END PROCEDURE Reallocate_Int64_R1b !---------------------------------------------------------------------------- @@ -417,15 +314,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int32 +#include "./Reallocate/reallocate1.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int32_R1 !---------------------------------------------------------------------------- @@ -433,7 +324,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R1b -CALL Reallocate_Int32_R1(mat, s(1)) +CALL Reallocate_Int32_R1(mat, s(1), isExpand, expandFactor) END PROCEDURE Reallocate_Int32_R1b !---------------------------------------------------------------------------- @@ -441,15 +332,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int16_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int16 +#include "./Reallocate/reallocate1.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int16_R1 !---------------------------------------------------------------------------- @@ -457,7 +342,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int16_R1b -CALL Reallocate_Int16_R1(mat, s(1)) +CALL Reallocate_Int16_R1(mat, s(1), isExpand, expandFactor) END PROCEDURE Reallocate_Int16_R1b !---------------------------------------------------------------------------- @@ -465,15 +350,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int8_R1 -IF (ALLOCATED(Mat)) THEN - IF (SIZE(Mat) .NE. row) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row)) - END IF -ELSE - ALLOCATE (Mat(row)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int8 +#include "./Reallocate/reallocate1.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int8_R1 !---------------------------------------------------------------------------- @@ -481,7 +360,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int8_R1b -CALL Reallocate_Int8_R1(mat, s(1)) +CALL Reallocate_Int8_R1(mat, s(1), isExpand, expandFactor) END PROCEDURE Reallocate_Int8_R1b !---------------------------------------------------------------------------- @@ -489,15 +368,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0_DFP +#define ZEROVALUE 0_Int64 +#include "./Reallocate/reallocate2.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int64_R2 !---------------------------------------------------------------------------- @@ -505,7 +378,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R2b -CALL Reallocate_Int64_R2(mat, s(1), s(2)) +CALL Reallocate_Int64_R2(mat, s(1), s(2), isExpand, expandFactor) END PROCEDURE Reallocate_Int64_R2b !---------------------------------------------------------------------------- @@ -513,15 +386,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int32 +#include "./Reallocate/reallocate2.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int32_R2 !---------------------------------------------------------------------------- @@ -529,7 +396,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R2b -CALL Reallocate_Int32_R2(mat, s(1), s(2)) +CALL Reallocate_Int32_R2(mat, s(1), s(2), isExpand, expandFactor) END PROCEDURE Reallocate_Int32_R2b !---------------------------------------------------------------------------- @@ -537,15 +404,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int16_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int16 +#include "./Reallocate/reallocate2.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int16_R2 !---------------------------------------------------------------------------- @@ -553,7 +414,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int16_R2b -CALL Reallocate_Int16_R2(mat, s(1), s(2)) +CALL Reallocate_Int16_R2(mat, s(1), s(2), isExpand, expandFactor) END PROCEDURE Reallocate_Int16_R2b !---------------------------------------------------------------------------- @@ -561,15 +422,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int8_R2 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(row, col)) - END IF -ELSE - ALLOCATE (Mat(row, col)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int8 +#include "./Reallocate/reallocate2.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int8_R2 !---------------------------------------------------------------------------- @@ -577,7 +432,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int8_R2b -CALL Reallocate_Int8_R2(mat, s(1), s(2)) +CALL Reallocate_Int8_R2(mat, s(1), s(2), isExpand, expandFactor) END PROCEDURE Reallocate_Int8_R2b !--------------------------------------------------------------------------- @@ -585,17 +440,9 @@ !--------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0_DFP +#define ZEROVALUE 0_Int64 +#include "./Reallocate/reallocate3.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int64_R3 !---------------------------------------------------------------------------- @@ -603,7 +450,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R3b -CALL Reallocate_Int64_R3(mat, s(1), s(2), s(3)) +CALL Reallocate_Int64_R3(mat, s(1), s(2), s(3), isExpand, expandFactor) END PROCEDURE Reallocate_Int64_R3b !--------------------------------------------------------------------------- @@ -611,17 +458,9 @@ !--------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R3 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3)) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int32 +#include "./Reallocate/reallocate3.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int32_R3 !---------------------------------------------------------------------------- @@ -629,7 +468,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R3b -CALL Reallocate_Int32_R3(mat, s(1), s(2), s(3)) +CALL Reallocate_Int32_R3(mat, s(1), s(2), s(3), isExpand, expandFactor) END PROCEDURE Reallocate_Int32_R3b !---------------------------------------------------------------------------- @@ -637,19 +476,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int64 +#include "./Reallocate/reallocate4.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int64_R4 !---------------------------------------------------------------------------- @@ -657,7 +486,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R4b -CALL Reallocate_Int64_R4(mat, s(1), s(2), s(3), s(4)) +CALL Reallocate_Int64_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor) END PROCEDURE Reallocate_Int64_R4b !---------------------------------------------------------------------------- @@ -665,19 +494,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R4 -IF (ALLOCATED(Mat)) THEN - IF ((SIZE(Mat, 1) .NE. i1) & - & .OR. (SIZE(Mat, 2) .NE. i2) & - & .OR. (SIZE(Mat, 3) .NE. i3) & - & .OR. (SIZE(Mat, 4) .NE. i4) & - & ) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int32 +#include "./Reallocate/reallocate4.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int32_R4 !---------------------------------------------------------------------------- @@ -685,7 +504,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R4b -CALL Reallocate_Int32_R4(mat, s(1), s(2), s(3), s(4)) +CALL Reallocate_Int32_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor) END PROCEDURE Reallocate_Int32_R4b !---------------------------------------------------------------------------- @@ -693,15 +512,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int64 +#include "./Reallocate/reallocate5.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int64_R5 !---------------------------------------------------------------------------- @@ -709,7 +522,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R5b -CALL Reallocate_Int64_R5(mat, s(1), s(2), s(3), s(4), s(5)) +CALL Reallocate_Int64_R5(mat, s(1), s(2), s(3), s(4), s(5), isExpand, & + expandFactor) END PROCEDURE Reallocate_Int64_R5b !---------------------------------------------------------------------------- @@ -717,15 +531,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R5 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5)) -END IF -Mat = 0 +#define ZEROVALUE 0_Int32 +#include "./Reallocate/reallocate5.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int32_R5 !---------------------------------------------------------------------------- @@ -733,7 +541,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R5b -CALL Reallocate_Int32_R5(mat, s(1), s(2), s(3), s(4), s(5)) +CALL Reallocate_Int32_R5(mat, s(1), s(2), s(3), s(4), s(5), & + isExpand, expandFactor) END PROCEDURE Reallocate_Int32_R5b !---------------------------------------------------------------------------- @@ -741,15 +550,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0 +#define ZEROVALUE 0.0_Int64 +#include "./Reallocate/reallocate6.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int64_R6 !---------------------------------------------------------------------------- @@ -757,7 +560,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R6b -CALL Reallocate_Int64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +CALL Reallocate_Int64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), & + isExpand, expandFactor) END PROCEDURE Reallocate_Int64_R6b !---------------------------------------------------------------------------- @@ -765,15 +569,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R6 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6)) -END IF -Mat = 0 +#define ZEROVALUE 0.0_Int32 +#include "./Reallocate/reallocate6.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int32_R6 !---------------------------------------------------------------------------- @@ -781,7 +579,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R6b -CALL Reallocate_Int32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6)) +CALL Reallocate_Int32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), & + isExpand, expandFactor) END PROCEDURE Reallocate_Int32_R6b !---------------------------------------------------------------------------- @@ -789,15 +588,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0 +#define ZEROVALUE 0.0_Int64 +#include "./Reallocate/reallocate7.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int64_R7 !---------------------------------------------------------------------------- @@ -805,7 +598,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int64_R7b -CALL Reallocate_Int64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +CALL Reallocate_Int64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), & + isExpand, expandFactor) END PROCEDURE Reallocate_Int64_R7b !---------------------------------------------------------------------------- @@ -813,15 +607,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R7 -IF (ALLOCATED(Mat)) THEN - IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN - DEALLOCATE (Mat) - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) - END IF -ELSE - ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7)) -END IF -Mat = 0 +#define ZEROVALUE 0.0_Int32 +#include "./Reallocate/reallocate7.F90" +#undef ZEROVALUE END PROCEDURE Reallocate_Int32_R7 !---------------------------------------------------------------------------- @@ -829,7 +617,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R7b -CALL Reallocate_Int32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7)) +CALL Reallocate_Int32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), & + isExpand, expandFactor) END PROCEDURE Reallocate_Int32_R7b !---------------------------------------------------------------------------- @@ -837,74 +626,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Int32_R1_6 -IF (ALLOCATED(Vec1)) THEN - IF (SIZE(Vec1) .NE. n1) THEN - DEALLOCATE (Vec1) - ALLOCATE (Vec1(n1)) - END IF -ELSE - ALLOCATE (Vec1(n1)) -END IF -Vec1 = 0 - -IF (ALLOCATED(Vec2)) THEN - IF (SIZE(Vec2) .NE. n2) THEN - DEALLOCATE (Vec2) - ALLOCATE (Vec2(n2)) - END IF -ELSE - ALLOCATE (Vec2(n2)) -END IF -Vec2 = 0 - -IF (PRESENT(Vec3)) THEN - IF (ALLOCATED(Vec3)) THEN - IF (SIZE(Vec3) .NE. n3) THEN - DEALLOCATE (Vec3) - ALLOCATE (Vec3(n3)) - END IF - ELSE - ALLOCATE (Vec3(n3)) - END IF - Vec3 = 0 -END IF - -IF (PRESENT(Vec4)) THEN - IF (ALLOCATED(Vec4)) THEN - IF (SIZE(Vec4) .NE. n4) THEN - DEALLOCATE (Vec4) - ALLOCATE (Vec4(n4)) - END IF - ELSE - ALLOCATE (Vec4(n4)) - END IF - Vec4 = 0 -END IF - -IF (PRESENT(Vec5)) THEN - IF (ALLOCATED(Vec5)) THEN - IF (SIZE(Vec5) .NE. n5) THEN - DEALLOCATE (Vec5) - ALLOCATE (Vec5(n5)) - END IF - ELSE - ALLOCATE (Vec5(n5)) - END IF - Vec5 = 0 -END IF - -IF (PRESENT(Vec6)) THEN - IF (ALLOCATED(Vec6)) THEN - IF (SIZE(Vec6) .NE. n6) THEN - DEALLOCATE (Vec6) - ALLOCATE (Vec6(n6)) - END IF - ELSE - ALLOCATE (Vec6(n6)) - END IF - Vec6 = 0 -END IF - +#define ZERO1 0_I4B +#define ZERO2 0_I4B +#define ZERO3 0_I4B +#define ZERO4 0_I4B +#define ZERO5 0_I4B +#define ZERO6 0_I4B +#include "./Reallocate/reallocate8.F90" +#undef ZERO1 +#undef ZERO2 +#undef ZERO3 +#undef ZERO4 +#undef ZERO5 +#undef ZERO6 END PROCEDURE Reallocate_Int32_R1_6 !---------------------------------------------------------------------------- @@ -912,73 +646,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_R1_6 -IF (ALLOCATED(Vec1)) THEN - IF (SIZE(Vec1) .NE. n1) THEN - DEALLOCATE (Vec1) - ALLOCATE (Vec1(n1)) - END IF -ELSE - ALLOCATE (Vec1(n1)) -END IF -Vec1 = 0.0 - -IF (ALLOCATED(Vec2)) THEN - IF (SIZE(Vec2) .NE. n2) THEN - DEALLOCATE (Vec2) - ALLOCATE (Vec2(n2)) - END IF -ELSE - ALLOCATE (Vec2(n2)) -END IF -Vec2 = 0.0 - -IF (PRESENT(Vec3)) THEN - IF (ALLOCATED(Vec3)) THEN - IF (SIZE(Vec3) .NE. n3) THEN - DEALLOCATE (Vec3) - ALLOCATE (Vec3(n3)) - END IF - ELSE - ALLOCATE (Vec3(n3)) - END IF - Vec3 = 0.0 -END IF - -IF (PRESENT(Vec4)) THEN - IF (ALLOCATED(Vec4)) THEN - IF (SIZE(Vec4) .NE. n4) THEN - DEALLOCATE (Vec4) - ALLOCATE (Vec4(n4)) - END IF - ELSE - ALLOCATE (Vec4(n4)) - END IF - Vec4 = 0.0 -END IF - -IF (PRESENT(Vec5)) THEN - IF (ALLOCATED(Vec5)) THEN - IF (SIZE(Vec5) .NE. n5) THEN - DEALLOCATE (Vec5) - ALLOCATE (Vec5(n5)) - END IF - ELSE - ALLOCATE (Vec5(n5)) - END IF - Vec5 = 0.0 -END IF - -IF (PRESENT(Vec6)) THEN - IF (ALLOCATED(Vec6)) THEN - IF (SIZE(Vec6) .NE. n6) THEN - DEALLOCATE (Vec6) - ALLOCATE (Vec6(n6)) - END IF - ELSE - ALLOCATE (Vec6(n6)) - END IF - Vec6 = 0.0 -END IF +#define ZERO1 0.0_Real64 +#define ZERO2 0.0_Real64 +#define ZERO3 0.0_Real64 +#define ZERO4 0.0_Real64 +#define ZERO5 0.0_Real64 +#define ZERO6 0.0_Real64 +#include "./Reallocate/reallocate8.F90" +#undef ZERO1 +#undef ZERO2 +#undef ZERO3 +#undef ZERO4 +#undef ZERO5 +#undef ZERO6 END PROCEDURE Reallocate_Real64_R1_6 !---------------------------------------------------------------------------- @@ -986,73 +666,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_R1_6 -IF (ALLOCATED(Vec1)) THEN - IF (SIZE(Vec1) .NE. n1) THEN - DEALLOCATE (Vec1) - ALLOCATE (Vec1(n1)) - END IF -ELSE - ALLOCATE (Vec1(n1)) -END IF -Vec1 = 0.0 - -IF (ALLOCATED(Vec2)) THEN - IF (SIZE(Vec2) .NE. n2) THEN - DEALLOCATE (Vec2) - ALLOCATE (Vec2(n2)) - END IF -ELSE - ALLOCATE (Vec2(n2)) -END IF -Vec2 = 0.0 - -IF (PRESENT(Vec3)) THEN - IF (ALLOCATED(Vec3)) THEN - IF (SIZE(Vec3) .NE. n3) THEN - DEALLOCATE (Vec3) - ALLOCATE (Vec3(n3)) - END IF - ELSE - ALLOCATE (Vec3(n3)) - END IF - Vec3 = 0.0 -END IF - -IF (PRESENT(Vec4)) THEN - IF (ALLOCATED(Vec4)) THEN - IF (SIZE(Vec4) .NE. n4) THEN - DEALLOCATE (Vec4) - ALLOCATE (Vec4(n4)) - END IF - ELSE - ALLOCATE (Vec4(n4)) - END IF - Vec4 = 0.0 -END IF - -IF (PRESENT(Vec5)) THEN - IF (ALLOCATED(Vec5)) THEN - IF (SIZE(Vec5) .NE. n5) THEN - DEALLOCATE (Vec5) - ALLOCATE (Vec5(n5)) - END IF - ELSE - ALLOCATE (Vec5(n5)) - END IF - Vec5 = 0.0 -END IF - -IF (PRESENT(Vec6)) THEN - IF (ALLOCATED(Vec6)) THEN - IF (SIZE(Vec6) .NE. n6) THEN - DEALLOCATE (Vec6) - ALLOCATE (Vec6(n6)) - END IF - ELSE - ALLOCATE (Vec6(n6)) - END IF - Vec6 = 0.0 -END IF +#define ZERO1 0.0_Real32 +#define ZERO2 0.0_Real32 +#define ZERO3 0.0_Real32 +#define ZERO4 0.0_Real32 +#define ZERO5 0.0_Real32 +#define ZERO6 0.0_Real32 +#include "./Reallocate/reallocate8.F90" +#undef ZERO1 +#undef ZERO2 +#undef ZERO3 +#undef ZERO4 +#undef ZERO5 +#undef ZERO6 END PROCEDURE Reallocate_Real32_R1_6 !---------------------------------------------------------------------------- @@ -1060,35 +686,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_AIJ -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 - -IF (ALLOCATED(JA)) THEN - IF (SIZE(JA) .NE. nJA) THEN - DEALLOCATE (JA) - ALLOCATE (JA(nJA)) - END IF -ELSE - ALLOCATE (JA(nJA)) -END IF -JA = 0 +#include "./Reallocate/reallocate9.F90" END PROCEDURE Reallocate_Real64_AIJ !---------------------------------------------------------------------------- @@ -1096,35 +694,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_AIJ -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 - -IF (ALLOCATED(JA)) THEN - IF (SIZE(JA) .NE. nJA) THEN - DEALLOCATE (JA) - ALLOCATE (JA(nJA)) - END IF -ELSE - ALLOCATE (JA(nJA)) -END IF -JA = 0 +#include "./Reallocate/reallocate9.F90" END PROCEDURE Reallocate_Real32_AIJ !---------------------------------------------------------------------------- @@ -1132,25 +702,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real64_AI -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 +#include "./Reallocate/reallocate10.F90" END PROCEDURE Reallocate_Real64_AI !---------------------------------------------------------------------------- @@ -1158,25 +710,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Reallocate_Real32_AI -IF (ALLOCATED(A)) THEN - IF (SIZE(A) .NE. nA) THEN - DEALLOCATE (A) - ALLOCATE (A(nA)) - END IF -ELSE - ALLOCATE (A(nA)) -END IF -A = 0.0 - -IF (ALLOCATED(IA)) THEN - IF (SIZE(IA) .NE. nIA) THEN - DEALLOCATE (IA) - ALLOCATE (IA(nIA)) - END IF -ELSE - ALLOCATE (IA(nIA)) -END IF -IA = 0 +#include "./Reallocate/reallocate10.F90" END PROCEDURE Reallocate_Real32_AI !---------------------------------------------------------------------------- From 4e377c5075014d759e1f54e24b80486a4f64ed6e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:31:54 +0900 Subject: [PATCH 237/359] update in base type --- src/modules/BaseType/src/BaseType.F90 | 97 ++++++++++++++------------- 1 file changed, 51 insertions(+), 46 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 57a36e195..ecc3e7eb1 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -1460,41 +1460,47 @@ END SUBROUTINE highorder_refelem !{!pages/docs-api/ElemShapeData/ElemshapeData_.md!} ! TYPE :: ElemShapeData_ + INTEGER(I4B) :: nsd = 0 + !! spatial dimension of an element + INTEGER(I4B) :: xidim = 0 + !! xidimension + INTEGER(I4B) :: nips = 0 + !! number of integration points + INTEGER(I4B) :: nns = 0 + !! total degrees of freedom + !! number of shape functions REAL(DFP), ALLOCATABLE :: N(:, :) - !! Shape function value `N(I, ips)` + !! Shape function value `N(I, ips)` + !! nrow = nns + !! ncol = nips REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) - !! Local derivative of a shape function + !! Local derivative of a shape function + !! shape = nns, xidim, nips REAL(DFP), ALLOCATABLE :: jacobian(:, :, :) - !! Jacobian of mapping `J(:,:,ips)` also $\mathbf{F}_{\Xi x}$ + !! Jacobian of mapping `J(:,:,ips)` also $\mathbf{F}_{\Xi x}$ + !! shape = nsd, xidim, nips REAL(DFP), ALLOCATABLE :: js(:) - !! Determinant of Jacobian at ips + !! Determinant of Jacobian at ips + !! nips REAL(DFP), ALLOCATABLE :: ws(:) - !! Weighting functions + !! Weighting functions + !! nips REAL(DFP), ALLOCATABLE :: dNdXt(:, :, :) - !! Spatial derivative of shape function + !! Spatial derivative of shape function + !! shape = nns, nsd, nips REAL(DFP), ALLOCATABLE :: thickness(:) - !! Thickness of element + !! Thickness of element + !! nips REAL(DFP), ALLOCATABLE :: coord(:, :) - !! Barycentric coordinate + !! Barycentric coordinate + !! shape = nsd, nips REAL(DFP), ALLOCATABLE :: normal(:, :) - !! Normal in case of facet element - TYPE(ReferenceElement_) :: refelem - !! Refererece element - TYPE(QuadraturePoint_) :: quad - !! Quadrature points + !! Normal in case of facet element END TYPE ElemShapeData_ -TYPE(ElemShapeData_), PARAMETER :: & - & TypeElemShapeData = ElemShapeData_( & - & N=NULL(), & - & dNdXi=NULL(), & - & Jacobian=NULL(), & - & Js=NULL(), & - & Ws=NULL(), & - & dNdXt=NULL(), & - & Thickness=NULL(), & - & Coord=NULL(), & - & Normal=NULL()) +TYPE(ElemShapeData_), PARAMETER :: TypeElemShapeData = & + ElemShapeData_(N=NULL(), dNdXi=NULL(), Jacobian=NULL(), Js=NULL(), & + Ws=NULL(), dNdXt=NULL(), Thickness=NULL(), Coord=NULL(), Normal=NULL()) TYPE :: ElemShapeDataPointer_ CLASS(ShapeDataPointer_), POINTER :: ptr => NULL() @@ -1511,35 +1517,34 @@ END SUBROUTINE highorder_refelem TYPE, EXTENDS(ElemShapeData_) :: STElemShapeData_ REAL(DFP) :: wt = 0.0 - !! Weight of gauss point in time domain - REAL(DFP) :: theta = 0.0 - !! Gauss point in time domain + !! Weight of gauss point in time domain + ! REAL(DFP) :: theta = 0.0 + ! Gauss point in time domain REAL(DFP) :: jt = 0.0 - !! Jacobian $\frac{dt}{d\theta}$ + !! Jacobian $\frac{dt}{d\theta}$ + INTEGER(I4B) :: nnt = 0 + !! number of nodes in time domain REAL(DFP), ALLOCATABLE :: T(:) - !! Shape function in time domain + !! Shape function in time domain + !! size is nnt REAL(DFP), ALLOCATABLE :: dTdTheta(:) - !! Local shape function derivative in time domain + !! Local shape function derivative in time domain + !! size if nnt REAL(DFP), ALLOCATABLE :: dNTdt(:, :, :) + !! size is nns, nnt, nips REAL(DFP), ALLOCATABLE :: dNTdXt(:, :, :, :) - !! (I, a, i, ips) + !! (I, a, i, ips) + !! size is nns, nnt, nsd, nips + !! dim1 = nns + !! dim2 = nnt + !! dim3 = nsd + !! dim4 = nips END TYPE STElemShapeData_ -TYPE(STElemShapeData_), PARAMETER :: & - & TypeSTElemShapeData = STElemShapeData_( & - & N=NULL(), & - & dNdXi=NULL(), & - & Jacobian=NULL(), & - & Js=NULL(), & - & Ws=NULL(), & - & dNdXt=NULL(), & - & Thickness=NULL(), & - & Coord=NULL(), & - & Normal=NULL(), & - & T=NULL(), & - & dTdTheta=NULL(), & - & dNTdt=NULL(), & - & dNTdXt=NULL()) +TYPE(STElemShapeData_), PARAMETER :: TypeSTElemShapeData = & + STElemShapeData_(N=NULL(), dNdXi=NULL(), Jacobian=NULL(), Js=NULL(), & + Ws=NULL(), dNdXt=NULL(), Thickness=NULL(), Coord=NULL(), Normal=NULL(), & + T=NULL(), dTdTheta=NULL(), dNTdt=NULL(), dNTdXt=NULL()) !---------------------------------------------------------------------------- ! Meshquality_ From 214773f98b1417811c1ecad160c9d2201020c0ae Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:32:05 +0900 Subject: [PATCH 238/359] update in elemshapedata constructor methods --- .../src/ElemshapeData_ConstructorMethods.F90 | 99 +++---------------- 1 file changed, 15 insertions(+), 84 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 index e740cd001..48406b880 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 @@ -40,7 +40,7 @@ MODULE ElemshapeData_ConstructorMethods !- This subroutine belongs to the generic interface called `Allocate()`. INTERFACE ALLOCATE - MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips) + MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips, nnt) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! object to be returned INTEGER(I4B), INTENT(IN) :: nsd @@ -51,6 +51,8 @@ MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips) !! number of nodes in element INTEGER(I4B), INTENT(IN) :: nips !! number of integration points + INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnt + !! it is used when elemshape data is STElemShapeData END SUBROUTINE elemsd_Allocate END INTERFACE ALLOCATE @@ -60,11 +62,11 @@ END SUBROUTINE elemsd_Allocate !> author: Vikas Sharma, Ph. D. ! date: 23 July 2021 -! summary: This routine initiate the element shapefunction data +! summary: This routine Initiate the element shapefunction data INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate1(obj, quad, refelem, continuityType, & - & interpolType) + MODULE SUBROUTINE elemsd_Initiate1(obj, quad, refelem, continuityType, & + interpolType) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! ElemshapeData to be formed CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -75,7 +77,7 @@ MODULE SUBROUTINE elemsd_initiate1(obj, quad, refelem, continuityType, & !! - continuity/ conformity of shape function (basis functions) CHARACTER(*), INTENT(IN) :: interpolType !! interpolation/polynomial family for basis functions - END SUBROUTINE elemsd_initiate1 + END SUBROUTINE elemsd_Initiate1 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -87,85 +89,14 @@ END SUBROUTINE elemsd_initiate1 ! summary: Copy data from an instance of elemshapedata to another instance INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate2(obj1, obj2) - TYPE(ElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(ElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate2 + MODULE SUBROUTINE elemsd_Initiate2(obj1, obj2) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj1 + CLASS(ElemshapeData_), INTENT(IN) :: obj2 + END SUBROUTINE elemsd_Initiate2 END INTERFACE Initiate INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Initiate an instance of ElemshapeData from STElemshapeData -! -!# Introduction -! -! This subroutine initiates an instance of ElemshapeData by copying data -! from an instance of STElemshapeData. - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate3(obj1, obj2) - TYPE(ElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(STElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate3 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: This routine initiates an instance of STElemshapeData -! -!# Introduction -! -! This routine initiate an instance of STElemshapeData by copying data -! from the instance of ElemshapeData - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate4(obj1, obj2) - TYPE(STElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(ElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate4 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate4 -END INTERFACE - -!---------------------------------------------------------------------------- -! Initiate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 20 May 2022 -! summary: Initiate an instance of STElemshapeData from instance of same class -! -!# Introduction -! This routine initiates an instance of STElemshapeData by copying data -! from the instance of STElemshapeData. - -INTERFACE Initiate - MODULE SUBROUTINE elemsd_initiate5(obj1, obj2) - TYPE(STElemshapeData_), INTENT(INOUT) :: obj1 - TYPE(STElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_initiate5 -END INTERFACE Initiate - -INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_initiate5 + MODULE PROCEDURE elemsd_Initiate2 END INTERFACE !---------------------------------------------------------------------------- @@ -178,7 +109,7 @@ END SUBROUTINE elemsd_initiate5 ! !# Introduction ! -! - This subroutine initiates the shape-function data related to time +! - This subroutine Initiates the shape-function data related to time ! domain in the instance of [[stelemshapedata_]]. ! - User should provide an instance of [[Elemshapedata_]] elemsd, ! - The `elemsd`, actually contains the information of @@ -194,11 +125,11 @@ END SUBROUTINE elemsd_initiate5 ! INTERFACE Initiate - MODULE PURE SUBROUTINE stsd_initiate(obj, elemsd) + MODULE PURE SUBROUTINE stsd_Initiate(obj, elemsd) TYPE(STElemshapeData_), ALLOCATABLE, INTENT(INOUT) :: obj(:) TYPE(ElemshapeData_), INTENT(IN) :: elemsd !! It has information about location shape function for time element - END SUBROUTINE stsd_initiate + END SUBROUTINE stsd_Initiate END INTERFACE Initiate !---------------------------------------------------------------------------- From b56179f67737f26cc82bccaf892adc51f0bcfc3c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:32:13 +0900 Subject: [PATCH 239/359] update in elemshape data divergence methods --- .../src/ElemshapeData_DivergenceMethods.F90 | 194 ++++++++---------- 1 file changed, 88 insertions(+), 106 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 index a22cb4207..141b2dea2 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 @@ -15,17 +15,19 @@ ! along with this program. If not, see ! -module ElemshapeData_DivergenceMethods -USE BaseType -USE GlobalData +MODULE ElemshapeData_DivergenceMethods +USE BaseType, ONLY: ElemShapeData_, STElemshapeData_, FEVariable_ +USE GlobalData, ONLY: DFP, I4B, LGT + IMPLICIT NONE + PRIVATE -PUBLIC :: getDivergence +PUBLIC :: GetDivergence PUBLIC :: Divergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -33,47 +35,45 @@ module ElemshapeData_DivergenceMethods ! update: 2021-11-26 ! summary: This subroutine returns the Divergence of a vector -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_1(obj, lg, val) +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_1(obj, val, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! Divergence at integration points REAL(DFP), INTENT(IN) :: val(:, :) !! space nodal values of vector in `xiJ` format !! row index: space component !! col index: node number - END SUBROUTINE elemsd_getDivergence_1 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_1 -END INTERFACE getDivergence + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Divergence at integration points + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of ans + END SUBROUTINE elemsd_GetDivergence_1 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2021-11-26 ! update: 2021-11-26 ! summary: This subroutine returns the Divergence of a vector -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_2(obj, lg, val) + +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_2(obj, val, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! Divergence at integration points REAL(DFP), INTENT(IN) :: val(:, :, :) !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE elemsd_getDivergence_2 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_2 -END INTERFACE getDivergence + !! spaceComponent + !! number of nodes in space + !! number of nodes in time + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Divergence at integration points + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE elemsd_GetDivergence_2 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -81,22 +81,20 @@ END SUBROUTINE elemsd_getDivergence_2 ! update: 2021-11-26 ! summary: This subroutine returns the Divergence of a vector ! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_3(obj, lg, val) +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_3(obj, val, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:) - !! Divergence of vector at integration points TYPE(FEVariable_), INTENT(IN) :: val !! vector finite-element variable - END SUBROUTINE elemsd_getDivergence_3 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_3 -END INTERFACE getDivergence + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Divergence of vector at integration points + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE elemsd_GetDivergence_3 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -104,22 +102,22 @@ END SUBROUTINE elemsd_getDivergence_3 ! update: 2021-11-26 ! summary: This subroutine returns the Divergence of a matrix -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_4(obj, lg, val) +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_4(obj, val, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Divergence at integration points REAL(DFP), INTENT(IN) :: val(:, :, :) !! space nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getDivergence_4 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_4 -END INTERFACE getDivergence + !! dim1 = component + !! dim2 = component + !! dim3 = nns + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Divergence at integration points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE elemsd_GetDivergence_4 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -127,22 +125,20 @@ END SUBROUTINE elemsd_getDivergence_4 ! update: 2021-11-26 ! summary: This subroutine returns the Divergence of a vector -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_5(obj, lg, val) +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_5(obj, val, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Divergence at integration points REAL(DFP), INTENT(IN) :: val(:, :, :, :) !! space-time nodal values of matrix in (i,j,I,a) format - END SUBROUTINE elemsd_getDivergence_5 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_5 -END INTERFACE getDivergence + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Divergence at integration points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns of ans + END SUBROUTINE elemsd_GetDivergence_5 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -150,44 +146,38 @@ END SUBROUTINE elemsd_getDivergence_5 ! update: 2021-11-26 ! summary: This subroutine returns the Divergence of a vector -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_6(obj, lg, val) +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_6(obj, val, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :) - !! Divergence at integration points TYPE(FEVariable_), INTENT(IN) :: val !! space/space-time nodal values of matrix in (i,j,I) format - END SUBROUTINE elemsd_getDivergence_6 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_6 -END INTERFACE getDivergence + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Divergence at integration points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns of ans + END SUBROUTINE elemsd_GetDivergence_6 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2021-11-26 ! update: 2021-11-26 ! summary: This subroutine returns the Divergence -! -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_7(obj, lg, val) + +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_7(obj, val, ans) CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! Divergence of scalar/vector/matrix at space integration points TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE elemsd_getDivergence_7 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_7 -END INTERFACE getDivergence + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Divergence of scalar/vector/matrix at space integration points + END SUBROUTINE elemsd_GetDivergence_7 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- -! getDivergence@DivergenceMethods +! GetDivergence@DivergenceMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -195,51 +185,43 @@ END SUBROUTINE elemsd_getDivergence_7 ! update: 2021-11-26 ! summary: This subroutine returns the Divergence -INTERFACE - MODULE PURE SUBROUTINE elemsd_getDivergence_8(obj, lg, val) +INTERFACE GetDivergence + MODULE PURE SUBROUTINE elemsd_GetDivergence_8(obj, val, ans) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - TYPE(FEVariable_), INTENT(INOUT) :: lg - !! Divergence of scalar/vector/matrix at space-time - !! integration points TYPE(FEVariable_), INTENT(IN) :: val !! space time nodal values of scalar/vector/matrix - END SUBROUTINE elemsd_getDivergence_8 -END INTERFACE - -INTERFACE getDivergence - MODULE PROCEDURE elemsd_getDivergence_8 -END INTERFACE getDivergence + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Divergence of scalar/vector/matrix at space-time + !! integration points + END SUBROUTINE elemsd_GetDivergence_8 +END INTERFACE GetDivergence !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE +INTERFACE Divergence MODULE PURE FUNCTION elemsd_Divergence_1(obj, val) RESULT(Ans) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(IN) :: val TYPE(FEVariable_) :: ans END FUNCTION elemsd_Divergence_1 -END INTERFACE - -INTERFACE Divergence - MODULE PROCEDURE elemsd_Divergence_1 END INTERFACE Divergence !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE +INTERFACE Divergence MODULE PURE FUNCTION elemsd_Divergence_2(obj, val) RESULT(Ans) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) TYPE(FEVariable_), INTENT(IN) :: val TYPE(FEVariable_) :: ans END FUNCTION elemsd_Divergence_2 -END INTERFACE - -INTERFACE Divergence - MODULE PROCEDURE elemsd_Divergence_2 END INTERFACE Divergence -end module ElemshapeData_DivergenceMethods +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ElemshapeData_DivergenceMethods From 21aa8f86068b73305f9c436c3efac940fc437a45 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:35:24 +0900 Subject: [PATCH 240/359] update in elemshape data get methods --- .../src/ElemshapeData_GetMethods.F90 | 36 +++++++------------ 1 file changed, 13 insertions(+), 23 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 index 084e82e6a..373e1bb72 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 @@ -15,13 +15,15 @@ ! along with this program. If not, see ! -module ElemshapeData_GetMethods -USE BaseType -USE GlobalData +MODULE ElemshapeData_GetMethods +USE BaseType, ONLY: ElemshapeData_, STElemshapeData_, FEVariable_ + +USE GlobalData, ONLY: DFP, I4B, LGT + IMPLICIT NONE PRIVATE -PUBLIC :: getNormal +PUBLIC :: GetNormal !---------------------------------------------------------------------------- ! GetNormal @@ -32,18 +34,14 @@ module ElemshapeData_GetMethods ! update: 28 Jan 2022 ! summary: This routine returns the normal vector stored in [[ElemShapeData_]] -INTERFACE +INTERFACE GetNormal MODULE PURE SUBROUTINE elemsd_getNormal_1(obj, normal, nsd) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: normal(:, :) !! normal(1:3, 1:nip) = obj%normal INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd END SUBROUTINE elemsd_getNormal_1 -END INTERFACE - -INTERFACE getNormal - MODULE PROCEDURE elemsd_getNormal_1 -END INTERFACE getNormal +END INTERFACE GetNormal !---------------------------------------------------------------------------- ! GetNormal @@ -54,7 +52,7 @@ END SUBROUTINE elemsd_getNormal_1 ! update: 28 Jan 2022 ! summary: This routine returns the normal vector stored in [[ElemShapeData_]] -INTERFACE +INTERFACE GetNormal MODULE PURE SUBROUTINE elemsd_getNormal_2(obj, normal, nsd) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(INOUT) :: normal @@ -62,11 +60,7 @@ MODULE PURE SUBROUTINE elemsd_getNormal_2(obj, normal, nsd) !! Quadrature, Vector, Space INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd END SUBROUTINE elemsd_getNormal_2 -END INTERFACE - -INTERFACE getNormal - MODULE PROCEDURE elemsd_getNormal_2 -END INTERFACE getNormal +END INTERFACE GetNormal !---------------------------------------------------------------------------- ! GetNormal @@ -77,7 +71,7 @@ END SUBROUTINE elemsd_getNormal_2 ! update: 28 Jan 2022 ! summary: This routine returns the normal vector stored in [[ElemShapeData_]] -INTERFACE +INTERFACE GetNormal MODULE PURE SUBROUTINE elemsd_getNormal_3(obj, normal, nsd) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) TYPE(FEVariable_), INTENT(INOUT) :: normal @@ -85,10 +79,6 @@ MODULE PURE SUBROUTINE elemsd_getNormal_3(obj, normal, nsd) !! Quadrature, Vector, SpaceTime INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd END SUBROUTINE elemsd_getNormal_3 -END INTERFACE - -INTERFACE getNormal - MODULE PROCEDURE elemsd_getNormal_3 -END INTERFACE getNormal +END INTERFACE GetNormal -end module ElemshapeData_GetMethods +END MODULE ElemshapeData_GetMethods From 2ba1eecc68e28e9ded75a0e31ff450e758f7d9b3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:35:31 +0900 Subject: [PATCH 241/359] update in elemshape data io methods --- src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 index 3ddeaf0f5..f2d64dfaa 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 @@ -16,9 +16,12 @@ ! MODULE ElemshapeData_IOMethods -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemshapeData_, STElemShapeData_ + +USE GlobalData, ONLY: I4B, DFP, LGT + USE String_Class, ONLY: String + IMPLICIT NONE PRIVATE From d8f84d80e8b2b6a1dafe3b1880bd59296c439fc0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:35:43 +0900 Subject: [PATCH 242/359] update in elemshape data --- src/modules/ElemshapeData/src/ElemshapeData_Method.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 index 1f5ec1700..1d2867420 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -20,10 +20,10 @@ MODULE ElemshapeData_Method USE ElemshapeData_GetMethods USE ElemshapeData_GradientMethods -USE ElemshapeData_H1Methods -USE ElemshapeData_HCurlMethods -USE ElemshapeData_HDivMethods -USE ElemshapeData_DGMethods +! USE ElemshapeData_H1Methods +! USE ElemshapeData_HCurlMethods +! USE ElemshapeData_HDivMethods +! USE ElemshapeData_DGMethods USE ElemshapeData_Lagrange USE ElemshapeData_Hierarchical From 5e91016705d302b5d1e407a9d69a56e9b305e770 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:35:50 +0900 Subject: [PATCH 243/359] update in elemshape data set methods --- .../src/ElemshapeData_SetMethods.F90 | 37 ++++++++++++++++--- 1 file changed, 32 insertions(+), 5 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 index 74069ca7f..77772c3b7 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 @@ -15,9 +15,11 @@ ! along with this program. If not, see MODULE ElemshapeData_SetMethods -USE BaSetype -USE GlobalData +USE BaseType, ONLY: ElemshapeData_, STElemshapeData_, ElemshapeDataPointer_ +USE GlobalData, ONLY: DFP, I4B, LGT + IMPLICIT NONE + PRIVATE PUBLIC :: Set @@ -66,6 +68,8 @@ MODULE PURE SUBROUTINE elemsd_SetThickness(obj, val, N) !! Nodal values of thickness REAL(DFP), INTENT(IN) :: N(:, :) !! Shape function values at quadrature points + !! number of rows in n should be same as size of val + !! number of columns in N should be equal to nips in obj END SUBROUTINE elemsd_SetThickness END INTERFACE SetThickness @@ -89,6 +93,10 @@ MODULE PURE SUBROUTINE stsd_SetThickness(obj, val, N, T) CLASS(STElemshapeData_), INTENT(INOUT) :: obj REAL(DFP), INTENT(IN) :: val(:, :) !! Space-time nodal values of thickness + !! rows represent space + !! columns represets time value + !! colsize should be same as size of T + !! row size should be same as the number of rows in N REAL(DFP), INTENT(IN) :: N(:, :) !! Shape function at spatial quadrature REAL(DFP), INTENT(IN) :: T(:) @@ -116,8 +124,12 @@ MODULE PURE SUBROUTINE elemsd_SetBarycentricCoord(obj, val, N) CLASS(ElemshapeData_), INTENT(INOUT) :: obj REAL(DFP), INTENT(IN) :: val(:, :) !! Nodal coordinates in `xiJ` format + !! colsize of N should be nns + !! row size should be same as nsd REAL(DFP), INTENT(IN) :: N(:, :) !! When element is not an isoparametric we can supply N. + !! row size should be nns + !! col size should be nips END SUBROUTINE elemsd_SetBarycentricCoord END INTERFACE SetBarycentricCoord @@ -141,6 +153,7 @@ MODULE PURE SUBROUTINE stsd_SetBarycentricCoord(obj, val, N, T) CLASS(STElemshapeData_), INTENT(INOUT) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) !! space-time Nodal coordinates in `xiJ` format + !! REAL(DFP), INTENT(IN) :: N(:, :), T(:) !! N and T are required to handle non isoparametric elements END SUBROUTINE stsd_SetBarycentricCoord @@ -199,7 +212,12 @@ MODULE PURE SUBROUTINE elemsd_SetJacobian(obj, val, dNdXi) CLASS(ElemshapeData_), INTENT(INOUT) :: obj REAL(DFP), INTENT(IN) :: val(:, :) !! nodal coordinates in `xiJ` format + !! rowsize is equal to nsd + !! colsize equal to nns REAL(DFP), INTENT(IN) :: dNdXi(:, :, :) + !! dim1 is equal to nns + !! dim2 is equal to xidim + !! dim3 is equal to nips END SUBROUTINE elemsd_SetJacobian END INTERFACE SetJacobian @@ -256,6 +274,9 @@ MODULE PURE SUBROUTINE stsd_SetdNTdt(obj, val) CLASS(STElemshapeData_), INTENT(INOUT) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) !! Space-time nodal values + !! dim1 = nsd + !! dim2 = nns + !! dim3 = nnt END SUBROUTINE stsd_SetdNTdt END INTERFACE SetdNTdt @@ -310,7 +331,7 @@ END SUBROUTINE stsd_SetdNTdXt ! coordinates of spatial nodes at some time in [tn, tn+1] !@endnote ! -! The number of cols in val should be same as the number of rows +! The number of cols in val should be same as the number of rows ! in N and size of first index of dNdXi. INTERFACE Set @@ -365,7 +386,7 @@ END SUBROUTINE elemsd_Set1 INTERFACE Set MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & - & celldNdXi, facetN, facetdNdXi) + celldNdXi, facetN, facetdNdXi, facetNptrs) CLASS(ElemshapeData_), INTENT(INOUT) :: facetobj CLASS(ElemshapeData_), INTENT(INOUT) :: cellobj REAL(DFP), INTENT(IN) :: cellval(:, :) @@ -377,6 +398,7 @@ MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & REAL(DFP), INTENT(IN) :: celldNdXi(:, :, :) REAL(DFP), INTENT(IN) :: facetdNdXi(:, :, :) !! Local derivative of shape functions for geometry + INTEGER(I4B), INTENT(IN) :: facetNptrs(:) END SUBROUTINE elemsd_Set2 END INTERFACE Set @@ -401,13 +423,15 @@ MODULE PURE SUBROUTINE elemsd_Set3( & & masterCelldNdXi, & & masterFacetN, & & masterFacetdNdXi, & + & masterFacetNptrs, & & slaveFacetobj, & & slaveCellobj, & & slaveCellval, & & slaveCellN, & & slaveCelldNdXi, & & slaveFacetN, & - & slaveFacetdNdXi) + & slaveFacetdNdXi, & + & slaveFacetNptrs) CLASS(ElemshapeData_), INTENT(INOUT) :: masterFacetobj CLASS(ElemshapeData_), INTENT(INOUT) :: masterCellobj REAL(DFP), INTENT(IN) :: masterCellval(:, :) @@ -421,6 +445,8 @@ MODULE PURE SUBROUTINE elemsd_Set3( & REAL(DFP), INTENT(IN) :: masterFacetdNdXi(:, :, :) !! Local gradient of shape functions for geometry of !! facet element of master cell + INTEGER(I4B), INTENT(IN) :: masterFacetNptrs(:) + !! CLASS(ElemshapeData_), INTENT(INOUT) :: slaveFacetobj !! Shape function data for facet element of slave cell CLASS(ElemshapeData_), INTENT(INOUT) :: slaveCellobj @@ -437,6 +463,7 @@ MODULE PURE SUBROUTINE elemsd_Set3( & REAL(DFP), INTENT(IN) :: slaveFacetdNdXi(:, :, :) !! Local derivative of shape function for geometry of facet element !! of slave + INTEGER(I4B), INTENT(IN) :: slaveFacetNptrs(:) END SUBROUTINE elemsd_Set3 END INTERFACE Set From c5667292f5a86fff987aa77e3d9988df7276d856 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:01 +0900 Subject: [PATCH 244/359] update in cmake of elemshape data --- src/modules/ElemshapeData/CMakeLists.txt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt index 407eb9713..d110a44bb 100644 --- a/src/modules/ElemshapeData/CMakeLists.txt +++ b/src/modules/ElemshapeData/CMakeLists.txt @@ -23,10 +23,10 @@ target_sources( ${src_path}/ElemshapeData_DivergenceMethods.F90 ${src_path}/ElemshapeData_GradientMethods.F90 ${src_path}/ElemshapeData_GetMethods.F90 - ${src_path}/ElemshapeData_H1Methods.F90 - ${src_path}/ElemshapeData_DGMethods.F90 - ${src_path}/ElemshapeData_HDivMethods.F90 - ${src_path}/ElemshapeData_HCurlMethods.F90 + # ${src_path}/ElemshapeData_H1Methods.F90 + # ${src_path}/ElemshapeData_DGMethods.F90 + # ${src_path}/ElemshapeData_HDivMethods.F90 + # ${src_path}/ElemshapeData_HCurlMethods.F90 ${src_path}/ElemshapeData_Lagrange.F90 ${src_path}/ElemshapeData_Hierarchical.F90 ${src_path}/ElemshapeData_HminHmaxMethods.F90 From f33a4344d926bbad8e64523f352f4ba12837ac07 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:09 +0900 Subject: [PATCH 245/359] update in convective matrix --- src/submodules/ConvectiveMatrix/src/CM_10.inc | 4 ++-- src/submodules/ConvectiveMatrix/src/CM_5.inc | 4 ++-- src/submodules/ConvectiveMatrix/src/CM_6.inc | 4 ++-- src/submodules/ConvectiveMatrix/src/CM_9.inc | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/submodules/ConvectiveMatrix/src/CM_10.inc b/src/submodules/ConvectiveMatrix/src/CM_10.inc index 8d647f718..d3a880c66 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_10.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_10.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE CM_10(ans, test, trial, term1, term2, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) + & trial%nsd, 1) ! DO ips = 1, SIZE(realval) DO ii = 1, SIZE(m4, 3) @@ -58,7 +58,7 @@ PURE SUBROUTINE CM_10(ans, test, trial, term1, term2, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) + & 1, trial%nsd) ! DO ips = 1, SIZE(realval) DO ii = 1, SIZE(m4, 4) diff --git a/src/submodules/ConvectiveMatrix/src/CM_5.inc b/src/submodules/ConvectiveMatrix/src/CM_5.inc index a4cfc20a8..572670b68 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_5.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_5.inc @@ -49,7 +49,7 @@ PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) + & trial%nsd, 1) !! !! test: rowConcat !! @@ -61,7 +61,7 @@ PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) + & 1, trial%nsd) !! !! test: rowConcat !! diff --git a/src/submodules/ConvectiveMatrix/src/CM_6.inc b/src/submodules/ConvectiveMatrix/src/CM_6.inc index 06cfb876f..c260ddaa5 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_6.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_6.inc @@ -49,7 +49,7 @@ PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) + & trial%nsd, 1) !! DO ips = 1, SIZE(realval) do ii = 1, size(m4, 3) @@ -62,7 +62,7 @@ PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) + & 1, trial%nsd) !! DO ips = 1, SIZE(realval) do ii = 1, size(m4, 4) diff --git a/src/submodules/ConvectiveMatrix/src/CM_9.inc b/src/submodules/ConvectiveMatrix/src/CM_9.inc index d7cb134f9..02d011979 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_9.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_9.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE CM_9(ans, test, trial, term1, term2, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & trial%refelem%nsd, 1) + & trial%nsd, 1) !! DO ips = 1, SIZE(realval) DO ii = 1, SIZE(m4, 3) @@ -57,7 +57,7 @@ PURE SUBROUTINE CM_9(ans, test, trial, term1, term2, opt) CALL Reallocate(m4, & & SIZE(test%N, 1), & & SIZE(trial%N, 1), & - & 1, trial%refelem%nsd) + & 1, trial%nsd) !! DO ips = 1, SIZE(realval) DO ii = 1, SIZE( m4, 4) From abc4536aec4b4fed7aa62dd5588ff7c7234fd9c4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:14 +0900 Subject: [PATCH 246/359] update in diffusion matrix --- .../src/DiffusionMatrix_Method@Methods.F90 | 450 +++++++++--------- 1 file changed, 225 insertions(+), 225 deletions(-) diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 index 755daed8f..edbc83a10 100644 --- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 @@ -25,21 +25,21 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_1 - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ii !! !! main !! - CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - realval = trial%js * trial%ws * trial%thickness - DO ii = 1, SIZE(trial%N, 2) - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO +CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) +realval = trial%js * trial%ws * trial%thickness +DO ii = 1, SIZE(trial%N, 2) + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) !! - DEALLOCATE (realval) +DEALLOCATE (realval) !! END PROCEDURE DiffusionMatrix_1 @@ -48,27 +48,27 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_2 - REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) +INTEGER(I4B) :: ii !! !! main !! - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) +CALL getInterpolation(obj=trial, Interpol=kbar, val=k) !! - realval = trial%js * trial%ws * trial%thickness * kbar +realval = trial%js * trial%ws * trial%thickness * kbar !! - 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) +DO ii = 1, SIZE(realval) !! - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) !! - END DO +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) !! - DEALLOCATE (kbar, realval) +DEALLOCATE (kbar, realval) END PROCEDURE DiffusionMatrix_2 !---------------------------------------------------------------------------- @@ -77,25 +77,25 @@ MODULE PROCEDURE DiffusionMatrix_3 !! - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) +INTEGER(I4B) :: ii !! !! main !! - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) +CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) +CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) !! - realval = trial%js * trial%ws * trial%thickness +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 +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) !! - DEALLOCATE (c1bar, c2bar, realval) +DEALLOCATE (c1bar, c2bar, realval) !! END PROCEDURE DiffusionMatrix_3 @@ -104,27 +104,27 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_4 - ! CALL DM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) +! CALL DM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) !! internal variable - REAL(DFP), ALLOCATABLE :: kbar(:, :, :) - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: kbar(:, :, :) +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) +CALL getInterpolation(obj=trial, Interpol=kbar, val=k) !! - realval = trial%js * trial%ws * trial%thickness +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) * MATMUL(& - & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(& + & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) !! - DEALLOCATE (kbar, realval) +DEALLOCATE (kbar, realval) !! END PROCEDURE DiffusionMatrix_4 @@ -136,21 +136,21 @@ !! scalar !! scalar !! CALL DM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) +INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, Interpol=realval, val=c2) - realval = realval * trial%js * trial%ws * trial%thickness * cbar - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (cbar, realval) +CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) +CALL getInterpolation(obj=trial, Interpol=realval, val=c2) +realval = realval * trial%js * trial%ws * trial%thickness * cbar +CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) +END DO + !! +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! +DEALLOCATE (cbar, realval) END PROCEDURE DiffusionMatrix_5 !---------------------------------------------------------------------------- @@ -162,21 +162,21 @@ !! vector !! CALL DM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) !! - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) +INTEGER(I4B) :: ii !! main - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) - CALL getInterpolation(obj=trial, interpol=realval, val=c1) - realval = realval * trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO +CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) +CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) +CALL getInterpolation(obj=trial, interpol=realval, val=c1) +realval = realval * trial%js * trial%ws * trial%thickness +CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) !! - DEALLOCATE (c1bar, c2bar, realval) +DEALLOCATE (c1bar, c2bar, realval) !! END PROCEDURE DiffusionMatrix_6 @@ -186,24 +186,24 @@ MODULE PROCEDURE DiffusionMatrix_7 !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: kbar(:, :,:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :) +INTEGER(I4B) :: ii !! !! main !! - CALL getInterpolation(obj=trial, Interpol=realval, val=c1) - CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) - realval = realval * trial%js * trial%ws * trial%thickness +CALL getInterpolation(obj=trial, Interpol=realval, val=c1) +CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) +realval = realval * trial%js * trial%ws * trial%thickness !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * MATMUL(& - & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - END DO +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * MATMUL(& + & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - DEALLOCATE(realval, kbar) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +DEALLOCATE (realval, kbar) !! END PROCEDURE DiffusionMatrix_7 @@ -213,14 +213,14 @@ MODULE PROCEDURE DiffusionMatrix_8 !! - ans = DiffusionMatrix( & - & test=test, & - & trial=trial, & - & c1=c2, & - & c2=c1, & - & c1rank=TypeFEVariableScalar, & - & c2rank=TypeFEVariableVector, & - & opt=opt) +ans = DiffusionMatrix( & + & test=test, & + & trial=trial, & + & c1=c2, & + & c2=c1, & + & c1rank=TypeFEVariableScalar, & + & c2rank=TypeFEVariableVector, & + & opt=opt) !! END PROCEDURE DiffusionMatrix_8 @@ -230,22 +230,22 @@ MODULE PROCEDURE DiffusionMatrix_9 !! Internal variable - REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) +INTEGER(I4B) :: ii !! !! main !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) - realval = trial%js * trial%ws * trial%thickness +CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) +CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) +CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) +realval = trial%js * trial%ws * trial%thickness !! - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - DEALLOCATE (c1bar, c2bar, realval) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +DEALLOCATE (c1bar, c2bar, realval) !! END PROCEDURE DiffusionMatrix_9 @@ -255,33 +255,33 @@ MODULE PROCEDURE DiffusionMatrix_10 !! internal variable - REAL(DFP), ALLOCATABLE :: matbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - TYPE(FEVariable_) :: k - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: matbar(:, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +REAL(DFP), ALLOCATABLE :: realval(:) +TYPE(FEVariable_) :: k +INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) - CALL getInterpolation(obj=trial, interpol=matbar, val=c2) - CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) +CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) +CALL getInterpolation(obj=trial, interpol=matbar, val=c2) +CALL Reallocate(c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) !! - DO ii = 1, SIZE(c2bar, 2) - c1bar(:,ii) = MATMUL(c2bar(:,ii), matbar(:,:,ii)) - END DO +DO ii = 1, SIZE(c2bar, 2) + c1bar(:, ii) = MATMUL(c2bar(:, ii), matbar(:, :, ii)) +END DO !! - k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - realval = trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO +k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace) +CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) +CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) +realval = trial%js * trial%ws * trial%thickness +CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) !! - DEALLOCATE (c1bar, c2bar, realval, matbar) +DEALLOCATE (c1bar, c2bar, realval, matbar) !! END PROCEDURE DiffusionMatrix_10 @@ -291,13 +291,13 @@ MODULE PROCEDURE DiffusionMatrix_11 !! - ans = DiffusionMatrix( & - & test=test, & - & trial=trial, & - & c1=c2, c2=c1, & - & c1rank=TypeFEVariableScalar, & - & c2rank=TypeFEVariableMatrix, & - & opt=opt ) +ans = DiffusionMatrix( & + & test=test, & + & trial=trial, & + & c1=c2, c2=c1, & + & c1rank=TypeFEVariableScalar, & + & c2rank=TypeFEVariableMatrix, & + & opt=opt) !! END PROCEDURE DiffusionMatrix_11 @@ -307,33 +307,33 @@ MODULE PROCEDURE DiffusionMatrix_12 !! internal variable - REAL(DFP), ALLOCATABLE :: matbar(:, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - REAL(DFP), ALLOCATABLE :: realval(:) - TYPE(FEVariable_) :: k - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: matbar(:, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +REAL(DFP), ALLOCATABLE :: realval(:) +TYPE(FEVariable_) :: k +INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, interpol=matbar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) - CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) - !! - DO ii = 1, SIZE(c2bar, 2) - c1bar(:,ii) = MATMUL(matbar(:,:,ii), c2bar(:,ii)) - END DO - !! - k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace ) - CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) - CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - realval = trial%js * trial%ws * trial%thickness - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - DO ii = 1, SIZE(realval) - ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) - END DO - !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (c1bar, c2bar, realval, matbar) +CALL getInterpolation(obj=trial, interpol=matbar, val=c1) +CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) +CALL Reallocate(c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) + !! +DO ii = 1, SIZE(c2bar, 2) + c1bar(:, ii) = MATMUL(matbar(:, :, ii), c2bar(:, ii)) +END DO + !! +k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace) +CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) +CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) +realval = trial%js * trial%ws * trial%thickness +CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) +DO ii = 1, SIZE(realval) + ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) +END DO + !! +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) + !! +DEALLOCATE (c1bar, c2bar, realval, matbar) END PROCEDURE DiffusionMatrix_12 !---------------------------------------------------------------------------- @@ -342,25 +342,25 @@ MODULE PROCEDURE DiffusionMatrix_13 !! internal variable - REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) - INTEGER(I4B) :: ii +REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) +INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) - CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - realval = trial%js * trial%ws * trial%thickness +CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) +CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) +CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) +realval = trial%js * trial%ws * trial%thickness !! - DO ii = 1, SIZE(realval) +DO ii = 1, SIZE(realval) !! - ans = ans + realval(ii) * MATMUL( & - & MATMUL(test%dNdXt(:, :, ii),& - & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) + ans = ans + realval(ii) * MATMUL( & + & MATMUL(test%dNdXt(:, :, ii),& + & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), & + & TRANSPOSE(trial%dNdXt(:, :, ii))) !! - END DO +END DO !! - IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - DEALLOCATE (k1bar, k2bar, realval) +IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) +DEALLOCATE (k1bar, k2bar, realval) END PROCEDURE DiffusionMatrix_13 !---------------------------------------------------------------------------- @@ -369,12 +369,12 @@ MODULE PROCEDURE DiffusionMatrix_14 !! - SELECT CASE( opt(1) ) - CASE( 1 ) - CALL DiffusionMatrix_14a( test, trial, ans ) - CASE( 2 ) - CALL DiffusionMatrix_14b( test, trial, ans ) - END SELECT +SELECT CASE (opt(1)) +CASE (1) + CALL DiffusionMatrix_14a(test, trial, ans) +CASE (2) + CALL DiffusionMatrix_14b(test, trial, ans) +END SELECT !! END PROCEDURE DiffusionMatrix_14 @@ -382,31 +382,31 @@ ! DiffusionMatrix !---------------------------------------------------------------------------- -PURE SUBROUTINE DiffusionMatrix_14a( test, trial, ans ) +PURE SUBROUTINE DiffusionMatrix_14a(test, trial, ans) !! CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) !! - REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : ) + REAL(DFP), ALLOCATABLE :: realval(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips !! realval = trial%js * trial%ws * trial%thickness - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + nsd = test%nsd + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, ii, ips ), & - & trial%dNdXt(:, jj, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & test%dNdXt(:, ii, ips), & + & trial%dNdXt(:, jj, ips)) END DO END DO END DO !! - CALL Convert( from=m4, to=ans ) + CALL Convert(from=m4, to=ans) !! DEALLOCATE (realval, m4) !! @@ -416,31 +416,31 @@ END SUBROUTINE DiffusionMatrix_14a ! DiffusionMatrix !---------------------------------------------------------------------------- -PURE SUBROUTINE DiffusionMatrix_14b( test, trial, ans ) +PURE SUBROUTINE DiffusionMatrix_14b(test, trial, ans) !! CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) !! - REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : ) + REAL(DFP), ALLOCATABLE :: realval(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips !! realval = trial%js * trial%ws * trial%thickness - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + nsd = test%nsd + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, jj, ips ), & - & trial%dNdXt(:, ii, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & test%dNdXt(:, jj, ips), & + & trial%dNdXt(:, ii, ips)) END DO END DO END DO !! - CALL Convert( from=m4, to=ans ) + CALL Convert(from=m4, to=ans) !! DEALLOCATE (realval, m4) !! @@ -452,12 +452,12 @@ END SUBROUTINE DiffusionMatrix_14b MODULE PROCEDURE DiffusionMatrix_15 !! - SELECT CASE( opt(1) ) - CASE( 1 ) - CALL DiffusionMatrix_15a( test, trial, k, ans ) - CASE( 2 ) - CALL DiffusionMatrix_15b( test, trial, k, ans ) - END SELECT +SELECT CASE (opt(1)) +CASE (1) + CALL DiffusionMatrix_15a(test, trial, k, ans) +CASE (2) + CALL DiffusionMatrix_15b(test, trial, k, ans) +END SELECT !! END PROCEDURE DiffusionMatrix_15 @@ -465,39 +465,39 @@ END SUBROUTINE DiffusionMatrix_14b ! DiffusionMatrix !---------------------------------------------------------------------------- -PURE SUBROUTINE DiffusionMatrix_15a( test, trial, k, ans ) +PURE SUBROUTINE DiffusionMatrix_15a(test, trial, k, ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! test function CLASS(ElemshapeData_), INTENT(IN) :: trial !! trial function CLASS(FEVariable_), INTENT(IN) :: k !! scalar - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) !! !! internal variables !! - REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : ) + REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips !! !! main !! - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + nsd = test%nsd + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) CALL getInterpolation(obj=trial, Interpol=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, ii, ips ), & - & trial%dNdXt(:, jj, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & test%dNdXt(:, ii, ips), & + & trial%dNdXt(:, jj, ips)) END DO END DO END DO !! - CALL Convert( from=m4, to=ans ) + CALL Convert(from=m4, to=ans) !! DEALLOCATE (kbar, realval, m4) !! @@ -507,39 +507,39 @@ END SUBROUTINE DiffusionMatrix_15a ! DiffusionMatrix !---------------------------------------------------------------------------- -PURE SUBROUTINE DiffusionMatrix_15b( test, trial, k, ans ) +PURE SUBROUTINE DiffusionMatrix_15b(test, trial, k, ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! test function CLASS(ElemshapeData_), INTENT(IN) :: trial !! trial function CLASS(FEVariable_), INTENT(IN) :: k !! scalar - REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : ) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) !! !! internal variables !! - REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : ) + REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips !! !! main !! - nsd = test%refelem%nsd - CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd ) + nsd = test%nsd + CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) CALL getInterpolation(obj=trial, Interpol=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & test%dNdXt( :, jj, ips ), & - & trial%dNdXt(:, ii, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & test%dNdXt(:, jj, ips), & + & trial%dNdXt(:, ii, ips)) END DO END DO END DO !! - CALL Convert( from=m4, to=ans ) + CALL Convert(from=m4, to=ans) !! DEALLOCATE (kbar, realval, m4) !! From 7732c71faffec5f0e33184d0ea8ef142ce5044ee Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:20 +0900 Subject: [PATCH 247/359] update in elastic nitsche matrix --- .../src/ElasticNitscheMatrix_Method@Matrix1.F90 | 8 ++++---- .../src/ElasticNitscheMatrix_Method@Matrix2.F90 | 4 ++-- .../src/ElasticNitscheMatrix_Method@Matrix3.F90 | 10 +++++----- .../src/ElasticNitscheMatrix_Method@MatrixNormal.F90 | 4 ++-- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 index 8a82a9b17..4d43bd2a3 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 @@ -75,7 +75,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) realval = trial%Ws * trial%Js * trial%Thickness ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP @@ -124,7 +124,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) realval = trial%Ws * trial%Js * trial%Thickness ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) @@ -208,7 +208,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) realval = trial%Ws * trial%Js * trial%Thickness ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) @@ -256,7 +256,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) realval = trial%Ws * trial%Js * trial%Thickness ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 index efb294ac2..8b9178127 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 @@ -30,7 +30,7 @@ INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2 nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd +nips = SIZE(trial%N, 2); nsd = trial%nsd !<--- make integration parameters realval = trial%Ws * trial%Thickness * trial%Js !<--- allocate ans @@ -74,7 +74,7 @@ INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2 nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1) -nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd +nips = SIZE(trial%N, 2); nsd = trial%nsd SELECT CASE (lambda%VarType) CASE (Constant) diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 index f18d33209..0424b6a0f 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 @@ -58,7 +58,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd realval = trial%Ws * trial%Js * trial%Thickness * alpha ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) ans = 0.0_DFP @@ -99,7 +99,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd realval = trial%Ws * trial%Js * trial%Thickness * alpha ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) ans = 0.0_DFP @@ -140,7 +140,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd realval = trial%Ws * trial%Js * trial%Thickness * alpha ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2)) ans = 0.0_DFP @@ -191,7 +191,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd realval = trial%Ws * trial%Js * trial%Thickness * alpha ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) ans = 0.0_DFP @@ -217,7 +217,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd realval = trial%Ws * trial%Js * trial%Thickness * alpha ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) ans = 0.0_DFP diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 index 73d82b6a7..3a5fb73d3 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 @@ -33,7 +33,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) realval = trial%Ws * trial%Js * trial%Thickness ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) @@ -81,7 +81,7 @@ nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) nips = SIZE(trial%N, 2) -nsd = trial%refElem%nsd +nsd = trial%nsd ALLOCATE (ff(nns1, nsd * nns2), realval(nips)) realval = trial%Ws * trial%Js * trial%Thickness ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) From 11e453b282616de13e1355906d81b48cbd666cfc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:28 +0900 Subject: [PATCH 248/359] update in h1 methods --- .../src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90 index c56617c06..002659362 100644 --- a/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90 +++ b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90 @@ -30,11 +30,9 @@ INTEGER(I4B) :: nsd, xidim CALL DEALLOCATE (obj) -CALL Initiate(obj%refelem, refelem) nsd = refelem%nsd xidim = refelem%xiDimension CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws) -obj%quad = quad CALL ALLOCATE ( & & obj=obj, & From 983ce84594f16a2ada6a6f1b177a7320989f3893 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:31 +0900 Subject: [PATCH 249/359] update in h1 methods --- ...mshapeData_H1Methods@OrthogonalMethods.F90 | 62 +++++++++---------- 1 file changed, 30 insertions(+), 32 deletions(-) diff --git a/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90 index f104a5c00..870ec9bbe 100644 --- a/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90 +++ b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90 @@ -32,11 +32,9 @@ basisType0 = Input(option=basisType, default=Legendre) CALL DEALLOCATE (obj) -CALL Initiate(obj%refelem, refelem) nsd = refelem%nsd xidim = refelem%xiDimension CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws) -obj%quad = quad CALL ALLOCATE ( & & obj=obj, & @@ -79,12 +77,12 @@ & xij=xij, & & basisType1=basisType0, & & basisType2=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda1 = lambda, & - & lambda2 = lambda ) + & alpha1=alpha, & + & beta1=beta, & + & alpha2=alpha, & + & beta2=beta, & + & lambda1=lambda, & + & lambda2=lambda) dNdXi = OrthogonalBasisGradient_Quadrangle( & & p=order, & @@ -92,12 +90,12 @@ & xij=xij, & & basisType1=basisType0, & & basisType2=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda1 = lambda, & - & lambda2 = lambda ) + & alpha1=alpha, & + & beta1=beta, & + & alpha2=alpha, & + & beta2=beta, & + & lambda1=lambda, & + & lambda2=lambda) CASE (Tetrahedron) N = OrthogonalBasis_Tetrahedron( & @@ -119,15 +117,15 @@ & basisType1=basisType0, & & basisType2=basisType0, & & basisType3=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & lambda1 = lambda, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda2 = lambda, & - & alpha3 = alpha, & - & beta3 = beta, & - & lambda3 = lambda & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda, & + & alpha3=alpha, & + & beta3=beta, & + & lambda3=lambda & & ) dNdXi = OrthogonalBasisGradient_Hexahedron( & @@ -138,15 +136,15 @@ & basisType1=basisType0, & & basisType2=basisType0, & & basisType3=basisType0, & - & alpha1 = alpha, & - & beta1 = beta, & - & lambda1 = lambda, & - & alpha2 = alpha, & - & beta2 = beta, & - & lambda2 = lambda, & - & alpha3 = alpha, & - & beta3 = beta, & - & lambda3 = lambda & + & alpha1=alpha, & + & beta1=beta, & + & lambda1=lambda, & + & alpha2=alpha, & + & beta2=beta, & + & lambda2=lambda, & + & alpha3=alpha, & + & beta3=beta, & + & lambda3=lambda & & ) CASE DEFAULT From 9a9dbe275fadded64fa0d6a4ec4a28e7a56be795 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:38 +0900 Subject: [PATCH 250/359] update in constructor methods --- ...emshapeData_ConstructorMethods@Methods.F90 | 394 ++++++------------ 1 file changed, 128 insertions(+), 266 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 index 6c88af6d2..3a56bd4af 100755 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 @@ -20,7 +20,12 @@ ! summary: Constructor method for ElemshapeData_ and STElemshapeData_ SUBMODULE(ElemshapeData_ConstructorMethods) Methods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate + +USE QuadraturePoint_Method, ONLY: GetQuadraturePoints + +USE ErrorHandling, ONLY: Errormsg + IMPLICIT NONE CONTAINS @@ -29,15 +34,36 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Allocate -CALL reallocate(obj%N, nns, nips) -CALL reallocate(obj%dNdXi, nns, xidim, nips) -CALL reallocate(obj%Normal, 3, nips) -CALL reallocate(obj%dNdXt, nns, nsd, nips) -CALL reallocate(obj%Jacobian, nsd, xidim, nips) -CALL reallocate(obj%Js, nips) -CALL reallocate(obj%Thickness, nips) -obj%Thickness = 1.0_DFP -CALL reallocate(obj%Coord, nsd, nips) +LOGICAL(LGT) :: isok + +CALL Reallocate(obj%N, nns, nips) +CALL Reallocate(obj%dNdXi, nns, xidim, nips) +CALL Reallocate(obj%Normal, 3, nips) +CALL Reallocate(obj%dNdXt, nns, nsd, nips) +CALL Reallocate(obj%jacobian, nsd, xidim, nips) +CALL Reallocate(obj%js, nips) +CALL Reallocate(obj%thickness, nips) +obj%thickness = 1.0_DFP +CALL Reallocate(obj%coord, nsd, nips) +obj%nsd = nsd +obj%xidim = xidim +obj%nips = nips +obj%nns = nns + +isok = PRESENT(nnt) + +IF (isok) THEN + SELECT TYPE (obj); TYPE is (STElemShapeData_) + obj%nnt = nnt + + CALL Reallocate(obj%T, nnt) + CALL Reallocate(obj%dTdTheta, nnt) + CALL Reallocate(obj%dNTdt, nns, nnt, nips) + CALL Reallocate(obj%dNTdXt, nns, nnt, nsd, nips) + + END SELECT +END IF + END PROCEDURE elemsd_Allocate !---------------------------------------------------------------------------- @@ -53,262 +79,86 @@ & Line=__LINE__, & & UnitNo=stdout) STOP - -! SELECT CASE (TRIM(interpolType)//TRIM(continuityType)) -! CASE ("LagrangeInterpolation"//"H1") -! CALL Initiate( & -! & obj=obj, & -! & quad=quad, & -! & refElem=refElem, & -! & continuityType=TypeH1, & -! & interpolType=TypeLagrangeInterpolation) -! -! CASE ("LagrangeInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: LagrangeInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("LagrangeInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: LagrangeInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("LagrangeInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: LagrangeInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"H1") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: H1", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HermitInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HermitInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"H1") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: H1", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("SerendipityInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: SerendipityInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"H1") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: H1", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"HDiv") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: HDiv", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"HCurl") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: HCurl", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE ("HierarchyInterpolation"//"DG") -! CALL ErrorMSG( & -! & Msg="BaseInterpolation: HierarchyInterpolation & -! & BaseContinuityType: DG", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! STOP -! -! CASE DEFAULT -! CALL ErrorMSG( & -! & Msg="Unknown child name of BaseInterpolation & -! & and BaseContinuityType", & -! & File="ElemshapeData_Method@Constructor.F90", & -! & Routine="elemsd_Initiate1()", & -! & Line=__LINE__, & -! & UnitNo=stdout) -! END SELECT - END PROCEDURE elemsd_Initiate1 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_initiate2 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -END PROCEDURE elemsd_initiate2 +MODULE PROCEDURE elemsd_Initiate2 +INTEGER(I4B) :: ii, jj, kk, nns, nsd, xidim, nips, nnt, ll, nnt -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- +nns = obj2%nns +nsd = obj2%nsd +xidim = obj2%xidim +nips = obj2%nips -MODULE PROCEDURE elemsd_initiate3 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -END PROCEDURE elemsd_initiate3 +SELECT TYPE (obj2); TYPE is (STElemShapeData_) + nnt = obj2%nnt +END SELECT -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- +CALL elemsd_Allocate(obj=obj1, nsd=nsd, xidim=xidim, nns=nns, & + nips=nips, nnt=nnt) -MODULE PROCEDURE elemsd_initiate4 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -END PROCEDURE elemsd_initiate4 +DO CONCURRENT(jj=1:nips, ii=1:nns) + obj1%N(ii, jj) = obj2%N(ii, jj) +END DO -!---------------------------------------------------------------------------- -! Initiate -!---------------------------------------------------------------------------- +DO CONCURRENT(kk=1:nips, jj=1:xidim, ii=1:nns) + obj1%dNdXi(ii, jj, kk) = obj2%dNdXi(ii, jj, kk) +END DO + +DO CONCURRENT(kk=1:nips, jj=1:nsd, ii=1:nns) + obj1%dNdXt(ii, jj, kk) = obj2%dNdXt(ii, jj, kk) +END DO + +DO CONCURRENT(ii=1:nsd, jj=1:xidim, kk=1:nips) + obj1%jacobian(ii, jj, kk) = obj2%jacobian(ii, jj, kk) +END DO + +DO CONCURRENT(ii=1:nips) + obj1%js(ii) = obj2%js(ii) + obj1%ws(ii) = obj2%ws(ii) + obj1%thickness(ii) = obj2%thickness(ii) + obj1%coord(1:nsd, ii) = obj2%coord(1:nsd, ii) + obj1%normal(1:3, ii) = obj2%normal(1:3, ii) +END DO + +SELECT TYPE (obj1); TYPE is (STElemShapeData_) + SELECT TYPE (obj2); TYPE is (STElemShapeData_) + obj1%wt = obj2%wt +! obj1%theta = obj2%theta + obj1%jt = obj2%jt + obj1%nnt = obj2%nnt + nnt = obj1%nnt + + DO CONCURRENT(ii=1:nnt) + obj1%T(ii) = obj2%T(ii) + obj1%dTdTheta(ii) = obj2%dTdTheta(ii) + END DO + + DO CONCURRENT(ii=1:nns, jj=1:nnt, kk=1:nips) + obj1%dNTdt(ii, jj, kk) = obj2%dNTdt(ii, jj, kk) + END DO + + DO CONCURRENT(ii=1:nns, jj=1:nnt, kk=1:nsd, ll=1:nips) + obj1%dNTdXt(ii, jj, kk, ll) = obj2%dNTdXt(ii, jj, kk, ll) + END DO + + END SELECT +END SELECT -MODULE PROCEDURE elemsd_initiate5 -IF (ALLOCATED(obj2%N)) obj1%N = obj2%N -IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi -IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian -IF (ALLOCATED(obj2%js)) obj1%js = obj2%js -IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws -IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt -IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness -IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord -IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal -obj1%refElem = obj2%refElem -obj1%wt = obj2%wt -obj1%theta = obj2%theta -obj1%jt = obj2%jt -IF (ALLOCATED(obj2%T)) obj1%T = obj2%T -IF (ALLOCATED(obj2%dTdTheta)) obj1%dTdTheta = obj2%dTdTheta -IF (ALLOCATED(obj2%dNTdt)) obj1%dNTdt = obj2%dNTdt -IF (ALLOCATED(obj2%dNTdXt)) obj1%dNTdXt = obj2%dNTdXt -END PROCEDURE elemsd_initiate5 +END PROCEDURE elemsd_Initiate2 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE stsd_initiate -INTEGER(I4B) :: tip, ip -REAL(DFP) :: x(3) +MODULE PROCEDURE stsd_Initiate +INTEGER(I4B) :: tip, ip, nnt + +tip = elemsd%nips -tip = SIZE(elemsd%N, 2) IF (ALLOCATED(obj)) THEN DO ip = 1, SIZE(obj) CALL DEALLOCATE (obj(ip)) @@ -317,37 +167,49 @@ END IF ALLOCATE (obj(tip)) + +nnt = elemsd%nns + DO ip = 1, tip - obj(ip)%T = elemsd%N(:, ip) - obj(ip)%dTdTheta = elemsd%dNdXi(:, 1, ip) - obj(ip)%Jt = elemsd%Js(ip) - CALL getQuadraturePoints( & - & obj=elemsd%quad, & - & weights=obj(ip)%wt,& - & points=x, & - & num=ip) - obj(ip)%theta = x(1) + obj(ip)%jt = elemsd%js(ip) + obj(ip)%wt = elemsd%ws(ip) + obj(ip)%nnt = nnt + + CALL Reallocate(obj(ip)%T, nnt) + obj(ip)%T(1:nnt) = elemsd%N(1:nnt, ip) + + CALL Reallocate(obj(ip)%dTdTheta, nnt) + obj(ip)%dTdTheta(1:nnt) = elemsd%dNdXi(1:nnt, 1, ip) END DO -END PROCEDURE stsd_initiate + +END PROCEDURE stsd_Initiate !---------------------------------------------------------------------------- ! Deallocate !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Deallocate -IF (ALLOCATED(obj%Normal)) DEALLOCATE (obj%Normal) +IF (ALLOCATED(obj%normal)) DEALLOCATE (obj%normal) IF (ALLOCATED(obj%N)) DEALLOCATE (obj%N) IF (ALLOCATED(obj%dNdXi)) DEALLOCATE (obj%dNdXi) IF (ALLOCATED(obj%dNdXt)) DEALLOCATE (obj%dNdXt) -IF (ALLOCATED(obj%Jacobian)) DEALLOCATE (obj%Jacobian) -IF (ALLOCATED(obj%Js)) DEALLOCATE (obj%Js) -IF (ALLOCATED(obj%Ws)) DEALLOCATE (obj%Ws) -IF (ALLOCATED(obj%Thickness)) DEALLOCATE (obj%Thickness) -IF (ALLOCATED(obj%Coord)) DEALLOCATE (obj%Coord) -CALL DEALLOCATE (obj%Quad) -CALL DEALLOCATE (obj%refelem) +IF (ALLOCATED(obj%jacobian)) DEALLOCATE (obj%jacobian) +IF (ALLOCATED(obj%js)) DEALLOCATE (obj%js) +IF (ALLOCATED(obj%ws)) DEALLOCATE (obj%ws) +IF (ALLOCATED(obj%thickness)) DEALLOCATE (obj%thickness) +IF (ALLOCATED(obj%coord)) DEALLOCATE (obj%coord) + +obj%nsd = 0 +obj%xidim = 0 +obj%nips = 0 +obj%nns = 0 +! CALL DEALLOCATE (obj%Quad) +! CALL DEALLOCATE (obj%refelem) SELECT TYPE (obj) TYPE IS (STElemShapeData_) + obj%nnt = 0 + obj%wt = 0 + obj%jt = 0 IF (ALLOCATED(obj%T)) DEALLOCATE (obj%T) IF (ALLOCATED(obj%dTdTheta)) DEALLOCATE (obj%dTdTheta) IF (ALLOCATED(obj%dNTdt)) DEALLOCATE (obj%dNTdt) From 6a0dca8f0581cc5b1e399c8ddb5f313942019c90 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:43 +0900 Subject: [PATCH 251/359] update in divergnce methods --- ...lemshapeData_DivergenceMethods@Methods.F90 | 310 ++++++++++++------ 1 file changed, 202 insertions(+), 108 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 index 7f245d9b9..29ff85e9c 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 @@ -16,178 +16,272 @@ ! SUBMODULE(ElemshapeData_DivergenceMethods) Methods -USE BaseMethod +USE ContractionUtility, ONLY: Contraction + +USE SwapUtility, ONLY: Swap + +USE ReallocateUtility, ONLY: Reallocate + +USE FEVariable_Method, ONLY: QuadratureVariable, NodalVariable, shape, Get + +USE Basetype, ONLY: TypeFEVariableOpt, TypeFEVariableScalar, & + TypeFEVariableVector, TypeFEVariableMatrix, TypeFEVariableConstant, & + TypeFEVariableSpace, TypeFEVariableTime, TypeFEVariableSpaceTime + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- -! getDivergence +! GetDivergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_1 -lg = Contraction(a1=TRANSPOSE(val), a2=obj%dNdXt) -END PROCEDURE elemsd_getDivergence_1 +MODULE PROCEDURE elemsd_GetDivergence_1 +INTEGER(I4B) :: ii, jj, ips + +tsize = obj%nips + +DO ips = 1, tsize + ans(ips) = 0.0_DFP + + DO jj = 1, obj%nns + DO ii = 1, obj%nsd + ans(ips) = ans(ips) + val(ii, jj) * obj%dNdXt(jj, ii, ips) + END DO + END DO +END DO + +END PROCEDURE elemsd_GetDivergence_1 !---------------------------------------------------------------------------- -! getDivergence +! GetDivergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_2 -REAL(DFP), ALLOCATABLE :: r3(:, :, :) -!! main -SELECT TYPE (obj) -TYPE IS (STElemshapeData_) - CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1) - lg = Contraction(r3, obj%dNTdXt) - DEALLOCATE (r3) +MODULE PROCEDURE elemsd_GetDivergence_2 +INTEGER(I4B) :: ips, I, ii, a, ips + +tsize = obj%nips + +SELECT TYPE (obj); TYPE is (STElemShapeData_) + + DO ips = 1, tsize + ans(ips) = 0.0_DFP + + DO a = 1, obj%nnt + DO I = 1, obj%nns + DO ii = 1, obj%nsd + ans(ips) = ans(ips) + val(ii, I, a) * obj%dNTdXt(I, a, ii, ips) + END DO + END DO + END DO + + END DO + END SELECT -END PROCEDURE elemsd_getDivergence_2 + +END PROCEDURE elemsd_GetDivergence_2 !---------------------------------------------------------------------------- -! getDivergence +! GetDivergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_3 +MODULE PROCEDURE elemsd_GetDivergence_3 +tsize = obj%nips + SELECT CASE (val%varType) -CASE (constant) - CALL reallocate(lg, SIZE(obj%N, 2)) -CASE (space) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) +CASE (TypeFEVariableOpt%constant) + ! CALL Reallocate(lg, SIZE(obj%N, 2)) + ans(1:tsize) = 0.0 + +CASE (TypeFEVariableOpt%space) + CALL GetDivergence(obj=obj, ans=ans, tsize=tsize, & + Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) + +CASE (TypeFEVariableOpt%spacetime) + + SELECT TYPE (obj); TYPE is (STElemShapeData_) + + CALL GetDivergence(obj=obj, ans=ans, tsize=tsize, & + Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) END SELECT + END SELECT -END PROCEDURE elemsd_getDivergence_3 +END PROCEDURE elemsd_GetDivergence_3 !---------------------------------------------------------------------------- -! getDivergence +! GetDivergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_4 -INTEGER(I4B) :: ii, n -!! -n = SIZE(obj%N, 2) -CALL reallocate(lg, SIZE(val, 1), n) -DO ii = 1, n - lg(:, ii) = contraction(val, TRANSPOSE(obj%dNdXt(:, :, ii))) +MODULE PROCEDURE elemsd_GetDivergence_4 +INTEGER(I4B) :: ii, jj, ips, I + +nrow = SIZE(val, 1) +ncol = obj%nips + +DO ips = 1, ncol + DO jj = 1, nrow + + ans(jj, ips) = 0.0_DFP + + DO I = 1, obj%nns + DO ii = 1, obj%nsd + ans(jj, ips) = ans(jj, ips) + val(ii, jj, I) * obj%dNdXt(I, ii, ips) + END DO + END DO + END DO END DO -END PROCEDURE elemsd_getDivergence_4 + +END PROCEDURE elemsd_GetDivergence_4 !---------------------------------------------------------------------------- -! getDivergence +! GetDivergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_5 -REAL(DFP), ALLOCATABLE :: r4(:, :, :, :) -INTEGER(I4B) :: ii -!! -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - CALL SWAP(a=r4, b=val, i1=3, i2=4, i3=2, i4=1) - CALL Reallocate(lg, size(obj%N, 2), size(val, 1)) - DO ii = 1, SIZE(r4, 4) - lg(:, ii) = Contraction(a1=r4(:, :, :, ii), a2=obj%dNTdXt) +MODULE PROCEDURE elemsd_GetDivergence_5 +INTEGER(I4B) :: ii, jj, ips, I, a + +nrow = SIZE(val, 1) +ncol = obj%nips + +SELECT TYPE (obj); TYPE IS (STElemShapeData_) + + DO ips = 1, ncol + DO jj = 1, nrow + + ans(jj, ips) = 0.0_DFP + + DO a = 1, obj%nnt + DO I = 1, obj%nns + DO ii = 1, obj%nsd + ans(jj, ips) = ans(jj, ips) + & + val(ii, jj, I, a) * obj%dNTdXt(I, a, ii, ips) + END DO + END DO + END DO + END DO END DO - lg = TRANSPOSE(lg) - Deallocate (r4) + END SELECT -!! -END PROCEDURE elemsd_getDivergence_5 + +END PROCEDURE elemsd_GetDivergence_5 !---------------------------------------------------------------------------- -! getDivergence +! GetDivergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_6 +MODULE PROCEDURE elemsd_GetDivergence_6 INTEGER(I4B) :: s(2) -!! + SELECT CASE (val%varType) -CASE (constant) + +CASE (TypeFEVariableOpt%constant) s = SHAPE(val) - CALL reallocate(lg, s(1), SIZE(obj%N, 2)) -CASE (space) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) -CASE (spacetime) - SELECT TYPE (obj) - TYPE is (STElemShapeData_) - CALL getDivergence(obj=obj, lg=lg, & - & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) + ! CALL Reallocate(lg, s(1), SIZE(obj%N, 2)) + nrow = s(1) + ncol = obj%nips + ans(1:nrow, 1:ncol) = 0.0 + +CASE (TypeFEVariableOpt%space) + CALL GetDivergence(obj=obj, ans=ans, nrow=nrow, ncol=ncol, & + Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) + +CASE (TypeFEVariableOpt%spacetime) + SELECT TYPE (obj); TYPE IS (STElemShapeData_) + + CALL GetDivergence(obj=obj, ans=ans, nrow=nrow, ncol=ncol, & + Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) + END SELECT + END SELECT -END PROCEDURE elemsd_getDivergence_6 +END PROCEDURE elemsd_GetDivergence_6 !---------------------------------------------------------------------------- -! getDivergence +! GetDivergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_7 +MODULE PROCEDURE elemsd_GetDivergence_7 REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :) -!! +INTEGER(I4B) :: ii, jj, s(2) + SELECT CASE (val%rank) -CASE (vector) - CALL getDivergence(obj=obj, lg=r1, val=val) - lg = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace) + +CASE (TypeFEVariableOpt%vector) + ALLOCATE (r1(obj%nips)) + CALL GetDivergence(obj=obj, ans=r1, val=val, tsize=ii) + ans = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace) DEALLOCATE (r1) -CASE (matrix) - CALL getDivergence(obj=obj, lg=r2, val=val) - lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) + +CASE (TypeFEVariableOpt%matrix) + s = SHAPE(val) + ALLOCATE (r2(s(1), obj%nips)) + CALL GetDivergence(obj=obj, ans=r2, val=val, nrow=ii, ncol=jj) + ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) DEALLOCATE (r2) + END SELECT -END PROCEDURE elemsd_getDivergence_7 +END PROCEDURE elemsd_GetDivergence_7 !---------------------------------------------------------------------------- ! Divergence !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getDivergence_8 +MODULE PROCEDURE elemsd_GetDivergence_8 REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :) -INTEGER(I4B) :: ii -!! +INTEGER(I4B) :: ii, nipt, jj, kk, s(2) + +nipt = SIZE(obj) + SELECT CASE (val%rank) -!! -!! vector -!! -CASE (vector) - DO ii = 1, SIZE(obj) - CALL getDivergence(obj=obj(ii), lg=r1, val=val) - IF (.NOT. ALLOCATED(r2)) THEN - CALL reallocate(r2, SIZE(r1, 1), SIZE(obj)) - END IF - !! - r2(:, ii) = r1 + +CASE (TypeFEVariableOpt%vector) + + ii = 0 + DO jj = 1, nipt + IF (obj(jj)%nips .GT. ii) ii = obj(jj)%nips END DO - lg = QuadratureVariable(r2, typeFEVariableScalar,& - & typeFEVariableSpaceTime) + + ALLOCATE (r1(ii), r2(ii, nipt)) + + DO ii = 1, nipt + CALL GetDivergence(obj=obj(ii), ans=r1(1:obj(ii)%nips), val=val, tsize=jj) + r2(1:obj(ii)%nips, ii) = r1(1:obj(ii)%nips) + END DO + + ans = QuadratureVariable(r2(1:obj(ii)%nips, 1:nipt), typeFEVariableScalar, & + typeFEVariableSpaceTime) DEALLOCATE (r2, r1) -!! -!! matrix -!! -CASE (matrix) - DO ii = 1, SIZE(obj) - CALL getDivergence(obj=obj(ii), lg=r2, val=val) - IF (.NOT. ALLOCATED(r3)) THEN - CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) - END IF - !! - r3(:, :, ii) = r2 + +CASE (TypeFEVariableOpt%matrix) + + nipt = SIZE(obj) + + ii = 0 + DO jj = 1, nipt + IF (obj(jj)%nips .GT. ii) ii = obj(jj)%nips + END DO + + s = SHAPE(val) + kk = s(1) + + ALLOCATE (r2(kk, ii), r3(kk, ii, nipt)) + + DO ii = 1, nipt + CALL GetDivergence(obj=obj(ii), ans=r2, val=val, nrow=jj, ncol=kk) + r3(1:jj, 1:kk, ii) = r2(1:jj, 1:kk) END DO - lg = QuadratureVariable(r3, typeFEVariableVector,& - & typeFEVariableSpaceTime) + + ans = QuadratureVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime) DEALLOCATE (r2, r3) END SELECT -END PROCEDURE elemsd_getDivergence_8 +END PROCEDURE elemsd_GetDivergence_8 !---------------------------------------------------------------------------- ! Divergence !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Divergence_1 -CALL getDivergence(obj=obj, lg=ans, val=val) +CALL GetDivergence(obj=obj, ans=ans, val=val) END PROCEDURE elemsd_Divergence_1 !---------------------------------------------------------------------------- @@ -195,7 +289,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Divergence_2 -CALL getDivergence(obj=obj, lg=ans, val=val) +CALL GetDivergence(obj=obj, ans=ans, val=val) END PROCEDURE elemsd_Divergence_2 !---------------------------------------------------------------------------- From 2d81966ed3b6e7045f62a7597d214542d5d9ae83 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:50 +0900 Subject: [PATCH 252/359] update in elemshape data get methods --- .../src/ElemshapeData_GetMethods@Methods.F90 | 76 +++++++++---------- 1 file changed, 37 insertions(+), 39 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 index 15a59dba9..e4c61a46e 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 @@ -16,7 +16,14 @@ ! SUBMODULE(ElemshapeData_GetMethods) Methods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate + +USE FEVariable_Method, ONLY: QuadratureVariable, NodalVariable + +USE BaseType, ONLY: TypeFEVariableSpace, & + TypeFEVariableVector, & + TypeFEVariableSpaceTime + IMPLICIT NONE CONTAINS @@ -26,9 +33,11 @@ MODULE PROCEDURE elemsd_getnormal_1 IF (PRESENT(nsd)) THEN - normal = obj%normal(1:nsd, :) + CALL Reallocate(normal, nsd, obj%nips) + normal(1:nsd, 1:obj%nips) = obj%normal(1:nsd, 1:obj%nips) ELSE - normal = obj%normal + CALL Reallocate(normal, 3, obj%nips) + normal(1:3, 1:obj%nips) = obj%normal(1:3, 1:obj%nips) END IF END PROCEDURE elemsd_GetNormal_1 @@ -38,13 +47,13 @@ MODULE PROCEDURE elemsd_getnormal_2 IF (PRESENT(nsd)) THEN - normal = QuadratureVariable(obj%normal(1:nsd, :), & - & TypeFEVariableVector, & - & TypeFEVariableSpace) + normal = QuadratureVariable(obj%normal(1:nsd, 1:obj%nips), & + TypeFEVariableVector, & + TypeFEVariableSpace) ELSE - normal = QuadratureVariable(obj%normal, & - & TypeFEVariableVector, & - & TypeFEVariableSpace) + normal = QuadratureVariable(obj%normal(1:3, 1:obj%nips), & + TypeFEVariableVector, & + TypeFEVariableSpace) END IF END PROCEDURE elemsd_getnormal_2 @@ -53,39 +62,28 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_getnormal_3 - !! REAL(DFP), ALLOCATABLE :: m3(:, :, :) -INTEGER(I4B) :: ii - !! -IF (PRESENT(nsd)) THEN - !! - CALL Reallocate(m3, & - & nsd, & - & SIZE(obj(1)%normal, 2), & - & SIZE(obj)) - !! - DO ii = 1, SIZE(obj) - m3(1:nsd, :, ii) = obj(ii)%normal(1:nsd, :) - END DO - !! -ELSE - !! - CALL Reallocate(m3, & - & SIZE(obj(1)%normal, 1), & - & SIZE(obj(1)%normal, 2), & - & SIZE(obj)) - !! - DO ii = 1, SIZE(obj) - m3(:, :, ii) = obj(ii)%normal - END DO - !! -END IF - !! +INTEGER(I4B) :: ii, nips, nipt, nsd0 + +nipt = SIZE(obj) +nips = 0 +DO ii = 1, nipt + IF (obj(ii)%nips > nips) nips = obj(ii)%nips +END DO + +nsd0 = 3 +IF (PRESENT(nsd)) nsd0 = nsd + +ALLOCATE (m3(nsd0, nips, nipt)) + +DO ii = 1, nipt + m3(1:nsd0, 1:obj(ii)%nips, ii) = obj(ii)%normal(1:nsd0, 1:obj(ii)%nips) +END DO + normal = QuadratureVariable(m3, TypeFEVariableVector, & - & TypeFEVariableSpaceTime) - !! + TypeFEVariableSpaceTime) + DEALLOCATE (m3) - !! END PROCEDURE elemsd_getnormal_3 !---------------------------------------------------------------------------- From b56738090da8e47f308a035e6f45c14a0bda1d45 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:36:57 +0900 Subject: [PATCH 253/359] update in elemshape data gradient methods --- .../ElemshapeData_GradientMethods@Methods.F90 | 142 +++++++++--------- 1 file changed, 69 insertions(+), 73 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 index 62717e546..cffae78a7 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 @@ -17,145 +17,142 @@ SUBMODULE(ElemshapeData_GradientMethods) Methods USE BaseMethod + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_1 -IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN +MODULE PROCEDURE elemsd_GetSpatialGradient_1 +IF (obj%nsd .EQ. obj%xidim) THEN lg = MATMUL(Val, obj%dNdXt) ELSE - CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) + CALL Reallocate(lg, obj%nsd, obj%nips) END IF -END PROCEDURE elemsd_getSpatialGradient_1 +END PROCEDURE elemsd_GetSpatialGradient_1 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_2 -IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN +MODULE PROCEDURE elemsd_GetSpatialGradient_2 +IF (obj%nsd .EQ. obj%xidim) THEN lg = MATMUL(Val, obj%dNdXt) ELSE - CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, & - & SIZE(obj%N, 2)) + CALL Reallocate(lg, SIZE(val, 1), obj%nsd, obj%nips) END IF -END PROCEDURE elemsd_getSpatialGradient_2 +END PROCEDURE elemsd_GetSpatialGradient_2 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_3 +MODULE PROCEDURE elemsd_GetSpatialGradient_3 SELECT TYPE (obj) TYPE IS (STElemshapeData_) - IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + IF (obj%nsd .EQ. obj%xidim) THEN lg = Contraction(val, obj%dNTdXt) ELSE - CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) + CALL Reallocate(lg, obj%nsd, obj%nips) END IF END SELECT -END PROCEDURE elemsd_getSpatialGradient_3 +END PROCEDURE elemsd_GetSpatialGradient_3 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_4 +MODULE PROCEDURE elemsd_GetSpatialGradient_4 INTEGER(I4B) :: ii, jj, ips REAL(DFP), ALLOCATABLE :: r3(:, :, :) - !! -CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, & - & SIZE(obj%N, 2)) - !! + +CALL Reallocate(lg, SIZE(val, 1), obj%nsd, obj%nips) + SELECT TYPE (obj) TYPE IS (STElemshapeData_) - IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + IF (obj%nsd .EQ. obj%xidim) THEN CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1) DO ips = 1, SIZE(lg, 3) DO jj = 1, SIZE(lg, 2) DO ii = 1, SIZE(lg, 1) lg(ii, jj, ips) = contraction(a1=r3(:, :, ii), & - & a2=obj%dNTdXt(:, :, jj, ips)) + a2=obj%dNTdXt(:, :, jj, ips)) END DO END DO END DO DEALLOCATE (r3) END IF END SELECT -END PROCEDURE elemsd_getSpatialGradient_4 +END PROCEDURE elemsd_GetSpatialGradient_4 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_5 +MODULE PROCEDURE elemsd_GetSpatialGradient_5 SELECT CASE (val%varType) CASE (constant) - CALL reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2)) + CALL Reallocate(lg, obj%nsd, obj%nips) CASE (space) - CALL getSpatialGradient(obj=obj, lg=lg, & + CALL GetSpatialGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) CASE (spacetime) SELECT TYPE (obj) TYPE IS (STElemShapeData_) - CALL getSpatialGradient(obj=obj, lg=lg, & + CALL GetSpatialGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) END SELECT END SELECT -END PROCEDURE elemsd_getSpatialGradient_5 +END PROCEDURE elemsd_GetSpatialGradient_5 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_6 +MODULE PROCEDURE elemsd_GetSpatialGradient_6 INTEGER(I4B) :: s(1) SELECT CASE (val%varType) CASE (constant) s = SHAPE(val) - CALL reallocate(lg, s(1), obj%refelem%nsd, & - & SIZE(obj%N, 2)) + CALL Reallocate(lg, s(1), obj%nsd, obj%nips) CASE (space) - CALL getSpatialGradient(obj=obj, lg=lg, & + CALL GetSpatialGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) CASE (spacetime) SELECT TYPE (obj) TYPE is (STElemShapeData_) - CALL getSpatialGradient(obj=obj, lg=lg, & + CALL GetSpatialGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) END SELECT END SELECT -END PROCEDURE elemsd_getSpatialGradient_6 +END PROCEDURE elemsd_GetSpatialGradient_6 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_7 -IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN +MODULE PROCEDURE elemsd_GetSpatialGradient_7 +IF (obj%nsd .EQ. obj%xidim) THEN lg = MATMUL(Val, obj%dNdXt) ELSE - CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), & - & obj%refelem%nsd, SIZE(obj%N, 2)) + CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%nsd, obj%nips) END IF -END PROCEDURE elemsd_getSpatialGradient_7 +END PROCEDURE elemsd_GetSpatialGradient_7 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_8 +MODULE PROCEDURE elemsd_GetSpatialGradient_8 INTEGER(I4B) :: ii, jj !! -CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%refelem%nsd, & - & SIZE(obj%N, 2)) +CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%nsd, obj%nips) SELECT TYPE (obj) TYPE IS (STElemshapeData_) - IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN + IF (obj%nsd .EQ. obj%xidim) THEN DO jj = 1, SIZE(lg, 4) DO ii = 1, SIZE(lg, 3) lg(:, :, ii, jj) = contraction(a1=val, & @@ -164,45 +161,44 @@ END DO END IF END SELECT -END PROCEDURE elemsd_getSpatialGradient_8 +END PROCEDURE elemsd_GetSpatialGradient_8 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_9 +MODULE PROCEDURE elemsd_GetSpatialGradient_9 INTEGER(I4B) :: s(2) SELECT CASE (val%varType) CASE (constant) s = SHAPE(val) - CALL reallocate(lg, s(1), s(2), & - & obj%refelem%nsd, SIZE(obj%N, 2)) + CALL Reallocate(lg, s(1), s(2), obj%nsd, obj%nips) CASE (space) - CALL getSpatialGradient(obj=obj, lg=lg, & + CALL GetSpatialGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) CASE (spacetime) SELECT TYPE (obj) TYPE is (STElemShapeData_) - CALL getSpatialGradient(obj=obj, lg=lg, & + CALL GetSpatialGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) END SELECT END SELECT -END PROCEDURE elemsd_getSpatialGradient_9 +END PROCEDURE elemsd_GetSpatialGradient_9 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_10 +MODULE PROCEDURE elemsd_GetSpatialGradient_10 REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) !! SELECT CASE (val%rank) CASE (scalar) - CALL getSpatialGradient(obj=obj, lg=r2, val=val) + CALL GetSpatialGradient(obj=obj, lg=r2, val=val) lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) DEALLOCATE (r2) CASE (vector) - CALL getSpatialGradient(obj=obj, lg=r3, val=val) + CALL GetSpatialGradient(obj=obj, lg=r3, val=val) lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) DEALLOCATE (r3) CASE (matrix) @@ -210,13 +206,13 @@ !! TODO Extend FEVariable to support r3, which is necessary to keep !! the gradient of rank02 tensors END SELECT -END PROCEDURE elemsd_getSpatialGradient_10 +END PROCEDURE elemsd_GetSpatialGradient_10 !---------------------------------------------------------------------------- -! getSpatialGradient +! GetSpatialGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getSpatialGradient_11 +MODULE PROCEDURE elemsd_GetSpatialGradient_11 REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) INTEGER(I4B) :: ii !! @@ -226,9 +222,9 @@ !! CASE (scalar) DO ii = 1, SIZE(obj) - CALL getSpatialGradient(obj=obj(ii), lg=r2, val=val) + CALL GetSpatialGradient(obj=obj(ii), lg=r2, val=val) IF (.NOT. ALLOCATED(r3)) THEN - CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) END IF !! r3(:, :, ii) = r2(:, :) @@ -241,15 +237,15 @@ !! CASE (vector) DO ii = 1, SIZE(obj) - CALL getSpatialGradient(obj=obj(ii), lg=r3, val=val) + CALL GetSpatialGradient(obj=obj(ii), lg=r3, val=val) IF (.NOT. ALLOCATED(r4)) THEN - CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) + CALL Reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) END IF !! r4(:, :, :, ii) = r3(:, :, :) END DO - lg = QuadratureVariable(r4, typeFEVariableMatrix,& - & typeFEVariableSpaceTime) + lg = QuadratureVariable(r4, typeFEVariableMatrix, & + typeFEVariableSpaceTime) DEALLOCATE (r3, r4) !! !! matrix TODO @@ -259,14 +255,14 @@ !! TODO Extend FEVariable to support r3, which is necessary to keep !! the gradient of rank02 tensors END SELECT -END PROCEDURE elemsd_getSpatialGradient_11 +END PROCEDURE elemsd_GetSpatialGradient_11 !---------------------------------------------------------------------------- ! SpatialGradient !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SpatialGradient_1 -CALL getSpatialGradient(obj=obj, lg=ans, val=val) +CALL GetSpatialGradient(obj=obj, lg=ans, val=val) END PROCEDURE elemsd_SpatialGradient_1 !---------------------------------------------------------------------------- @@ -274,7 +270,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SpatialGradient_2 -CALL getSpatialGradient(obj=obj, lg=ans, val=val) +CALL GetSpatialGradient(obj=obj, lg=ans, val=val) END PROCEDURE elemsd_SpatialGradient_2 !---------------------------------------------------------------------------- From ff8a825a9f22178d20e363efd4f4c81ae09c9cde Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:14 +0900 Subject: [PATCH 254/359] update in elemshape data --- .../src/ElemshapeData_HRQIParamMethods@Methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 index 915f5b7f5..db4beba3a 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 @@ -40,7 +40,7 @@ !! Main !! nips = SIZE(obj%N, 2) -nsd = obj%refelem%nsd +nsd = obj%nsd CALL Reallocate(h, nips) CALL Reallocate(G, nsd, nsd, nips) CALL Reallocate(FFT, nsd, nsd) @@ -276,7 +276,7 @@ !! nips = SIZE(obj(1)%N, 2) nipt = SIZE(obj) -nsd = obj(1)%refelem%nsd +nsd = obj(1)%nsd !! CALL Reallocate(h, nips, nipt) !! From f70bbe73b9ef4ca3d96b1c3aec7a6a4aa2b45a65 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:20 +0900 Subject: [PATCH 255/359] update in elemshape data --- .../src/ElemshapeData_HminHmaxMethods@Methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 index 3828c6c28..3304ec2d8 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 @@ -33,7 +33,7 @@ !! Main !! nips = SIZE(obj%N, 2) -nsd = obj%refelem%nsd +nsd = obj%nsd !! CALL Reallocate(G, nsd, nsd) CALL Reallocate(w, nsd) @@ -68,7 +68,7 @@ !! Main !! nips = SIZE(obj%N, 2) -nsd = obj%refelem%nsd +nsd = obj%nsd !! CALL Reallocate(w, nsd) CALL Reallocate(hmax, nips, hmin, nips) From 0a6bc4e280db78cf55922b9c896403b67d87be7a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:26 +0900 Subject: [PATCH 256/359] update in elemshape data --- .../src/ElemshapeData_IOMethods@Methods.F90 | 196 +++++++++--------- 1 file changed, 100 insertions(+), 96 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 index 9b91a6d5a..ac841e4b0 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 @@ -20,7 +20,14 @@ ! summary: Methods for IO of [[elemshapedata_]] and [[stelemshapedata_]] SUBMODULE(ElemshapeData_IOMethods) Methods -USE BaseMethod +USE Display_Method, ONLY: Util_Display => Display, Tostring + +USE MdEncode_Method, ONLY: Util_MdEncode => MdEncode + +USE GlobalData, ONLY: CHAR_LF2 + +USE String_Class, ONLY: StringReallocate => Reallocate + IMPLICIT NONE CONTAINS @@ -40,139 +47,138 @@ INTEGER(I4B) :: ii TYPE(String), ALLOCATABLE :: rh(:), ch(:) -ans = MdEncode(obj%quad)//CHAR_LF2 - IF (ALLOCATED(obj%N)) THEN - CALL Reallocate(rh, SIZE(obj%N, 1)) - CALL Reallocate(ch, SIZE(obj%N, 2)) - DO ii = 1, SIZE(obj%N, 1) + CALL StringReallocate(rh, obj%nns) + CALL StringReallocate(ch, obj%nips) + + DO ii = 1, obj%nns rh(ii) = "$N_{"//tostring(ii)//"}$" END DO - DO ii = 1, SIZE(obj%N, 2) + + DO ii = 1, obj%nips ch(ii) = "$ips_{"//tostring(ii)//"}$" END DO - ans = ans//"**N**"//CHAR_LF2//MdEncode(val=obj%N, rh=rh, ch=ch)//CHAR_LF2 + +ans = ans//"**N**"//CHAR_LF2//Util_MdEncode(val=obj%N, rh=rh, ch=ch)//CHAR_LF2 + ELSE ans = ans//"**N Not ALLOCATED**"//CHAR_LF2 END IF IF (ALLOCATED(obj%dNdXi)) THEN - CALL Reallocate(rh, SIZE(obj%dNdXi, 1)) - CALL Reallocate(ch, SIZE(obj%dNdXi, 2)) - DO ii = 1, SIZE(obj%dNdXi, 1) + CALL StringReallocate(rh, obj%nns) + CALL StringReallocate(ch, obj%xidim) + + DO ii = 1, obj%nns rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial \xi}$" END DO - DO ii = 1, SIZE(obj%dNdXi, 2) + + DO ii = 1, obj%xidim ch(ii) = "$\frac{\partial N}{\partial \xi_{"//tostring(ii)//"}}$" END DO - DO ii = 1, SIZE(obj%dNdXi, 3) + + DO ii = 1, obj%nips ans = ans//"**dNdXi(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & - & MdEncode(val=obj%dNdXi(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 + Util_MdEncode(val=obj%dNdXi(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 END DO + ELSE + ans = ans//"**dNdXi Not ALLOCATED**"//CHAR_LF2 + END IF IF (ALLOCATED(obj%dNdXt)) THEN - CALL Reallocate(rh, SIZE(obj%dNdXt, 1)) - CALL Reallocate(ch, SIZE(obj%dNdXt, 2)) - DO ii = 1, SIZE(obj%dNdXt, 1) + CALL StringReallocate(rh, obj%nns) + CALL StringReallocate(ch, obj%nsd) + + DO ii = 1, obj%nns rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial x}$" END DO - DO ii = 1, SIZE(obj%dNdXt, 2) + + DO ii = 1, obj%nsd ch(ii) = "$\frac{\partial N}{\partial {x}_{"//tostring(ii)//"}}$" END DO - DO ii = 1, SIZE(obj%dNdXt, 3) + + DO ii = 1, obj%nips ans = ans//"**dNdXt(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & - & MdEncode(val=obj%dNdXt(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 + Util_MdEncode(val=obj%dNdXt(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 END DO + ELSE + ans = ans//"**dNdXt Not ALLOCATED**"//CHAR_LF2 + END IF IF (ALLOCATED(obj%jacobian)) THEN - CALL Reallocate(rh, SIZE(obj%jacobian, 1)) - CALL Reallocate(ch, SIZE(obj%jacobian, 2)) - DO ii = 1, SIZE(obj%jacobian, 1) + CALL StringReallocate(rh, obj%nsd) + CALL StringReallocate(ch, obj%xidim) + + DO ii = 1, obj%nsd rh(ii) = "row-"//tostring(ii) END DO - DO ii = 1, SIZE(obj%jacobian, 2) + + DO ii = 1, obj%xidim ch(ii) = "col-"//tostring(ii) END DO - DO ii = 1, SIZE(obj%jacobian, 3) + + DO ii = 1, obj%nips ans = ans//"**jacobian(:, :, "//tostring(ii)//" )**"//CHAR_LF2// & - & MdEncode(val=obj%jacobian(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 + Util_MdEncode(val=obj%jacobian(:, :, ii), rh=rh, ch=ch)//CHAR_LF2 END DO + ELSE ans = ans//"**jacobian Not ALLOCATED**"//CHAR_LF2 END IF IF (ALLOCATED(obj%js)) THEN - CALL Reallocate(rh, 1) - CALL Reallocate(ch, SIZE(obj%js, 1)) + CALL StringReallocate(rh, 1) + CALL StringReallocate(ch, obj%nips) rh(1) = "js" - DO ii = 1, SIZE(obj%js, 1) + DO ii = 1, obj%nips ch(ii) = "$js_{"//tostring(ii)//"}$" END DO - ans = ans//"**Js**"//CHAR_LF2//MdEncode(val=obj%js, rh=rh, ch=ch)//CHAR_LF2 + + ans = ans//"**Js**"//CHAR_LF2//Util_MdEncode(val=obj%js, rh=rh, ch=ch)//CHAR_LF2 + ELSE ans = ans//"**js Not ALLOCATED**"//CHAR_LF2 END IF IF (ALLOCATED(obj%thickness)) THEN - CALL Reallocate(rh, 1) - CALL Reallocate(ch, SIZE(obj%thickness, 1)) + CALL StringReallocate(rh, 1) + CALL StringReallocate(ch, obj%nips) + rh(1) = "thickness" - DO ii = 1, SIZE(obj%thickness, 1) + DO ii = 1, obj%nips ch(ii) = "thickness${}_{"//tostring(ii)//"}$" END DO + ans = ans//"**thickness**"//CHAR_LF2// & - & MdEncode(val=obj%thickness, rh=rh, ch=ch)//CHAR_LF2 + Util_MdEncode(val=obj%thickness, rh=rh, ch=ch)//CHAR_LF2 ELSE ans = ans//"**thickness Not ALLOCATED**"//CHAR_LF2 END IF IF (ALLOCATED(obj%normal)) THEN - CALL Reallocate(rh, SIZE(obj%normal, 1)) - CALL Reallocate(ch, SIZE(obj%normal, 2)) + CALL StringReallocate(rh, SIZE(obj%normal, 1)) + CALL StringReallocate(ch, obj%nips) + DO ii = 1, SIZE(obj%normal, 1) rh(ii) = "$n_{"//tostring(ii)//"}$" END DO - DO ii = 1, SIZE(obj%normal, 2) + + DO ii = 1, obj%nips ch(ii) = "$ips_{"//tostring(ii)//"}$" END DO + ans = ans//"**normal**"//CHAR_LF2// & - & MdEncode(val=obj%normal, rh=rh, ch=ch)//CHAR_LF2 + Util_MdEncode(val=obj%normal, rh=rh, ch=ch)//CHAR_LF2 ELSE ans = ans//"**normal not ALLOCATED**"//CHAR_LF2 END IF -! SELECT TYPE (obj); TYPE IS (STElemShapeData_) -! CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno) -! CALL Display(obj%jt, "# jt: ", unitno=unitno) -! CALL Display(obj%theta, "# theta: ", unitno=unitno) -! CALL Display(obj%wt, "# wt: ", unitno=unitno) -! IF (ALLOCATED(obj%T)) THEN -! CALL Display(obj%T, "# T: ", unitno=unitno) -! ELSE -! CALL Display("# T: NOT ALLOCATED", unitno=unitno) -! END IF -! IF (ALLOCATED(obj%dTdTheta)) THEN -! CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno) -! ELSE -! CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno) -! END IF -! IF (ALLOCATED(obj%dNTdt)) THEN -! CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno) -! ELSE -! CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno) -! END IF -! IF (ALLOCATED(obj%dNTdXt)) THEN -! CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno) -! ELSE -! CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno) -! END IF -! END SELECT END PROCEDURE ElemshapeData_MdEncode !---------------------------------------------------------------------------- @@ -180,73 +186,71 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_display_1 -CALL Display(msg, unitno=unitno) -CALL Display("# SHAPE FUNCTION IN SPACE: ", unitno=unitno) -CALL Display(obj%Quad, "# Quadrature Point: ", unitno=unitno) +CALL Util_Display(msg, unitno=unitno) +CALL Util_Display("SHAPE FUNCTION IN SPACE: ", unitno=unitno) IF (ALLOCATED(obj%N)) THEN - CALL Display(obj%N, "# N: ", unitno) + CALL Util_Display(obj%N, "N: ", unitno) ELSE - CALL Display("# N: NOT ALLOCATED", unitno) + CALL Util_Display("N: NOT ALLOCATED", unitno) END IF IF (ALLOCATED(obj%dNdXi)) THEN - CALL Display(obj%dNdXi, "# dNdXi: ", unitno) + CALL Util_Display(obj%dNdXi, "dNdXi: ", unitno) ELSE - CALL Display("# dNdXi: NOT ALLOCATED", unitno) + CALL Util_Display("dNdXi: NOT ALLOCATED", unitno) END IF IF (ALLOCATED(obj%dNdXt)) THEN - CALL Display(obj%dNdXt, "# dNdXt: ", unitno) + CALL Util_Display(obj%dNdXt, "dNdXt: ", unitno) ELSE - CALL Display("# dNdXt: NOT ALLOCATED", unitno) + CALL Util_Display("dNdXt: NOT ALLOCATED", unitno) END IF IF (ALLOCATED(obj%jacobian)) THEN - CALL Display(obj%Jacobian, "# jacobian: ", unitno) + CALL Util_Display(obj%Jacobian, "jacobian: ", unitno) ELSE - CALL Display("# jacobian: NOT ALLOCATED", unitno) + CALL Util_Display("jacobian: NOT ALLOCATED", unitno) END IF IF (ALLOCATED(obj%js)) THEN - CALL Display(obj%js, "# js: ", unitno) + CALL Util_Display(obj%js, "js: ", unitno) ELSE - CALL Display("# js: NOT ALLOCATED", unitno) + CALL Util_Display("js: NOT ALLOCATED", unitno) END IF IF (ALLOCATED(obj%thickness)) THEN - CALL Display(obj%thickness, "# thickness: ", unitno) + CALL Util_Display(obj%thickness, "thickness: ", unitno) ELSE - CALL Display("# thickness: NOT ALLOCATED", unitno) + CALL Util_Display("thickness: NOT ALLOCATED", unitno) END IF IF (ALLOCATED(obj%coord)) THEN - CALL Display(obj%coord, "# coord: ", unitno) + CALL Util_Display(obj%coord, "coord: ", unitno) ELSE - CALL Display("# coord: NOT ALLOCATED", unitno) + CALL Util_Display("coord: NOT ALLOCATED", unitno) END IF IF (ALLOCATED(obj%normal)) THEN - CALL Display(obj%normal, "# normal: ", unitno) + CALL Util_Display(obj%normal, "normal: ", unitno) ELSE - CALL Display("# normal: NOT ALLOCATED", unitno) + CALL Util_Display("normal: NOT ALLOCATED", unitno) END IF SELECT TYPE (obj); TYPE IS (STElemShapeData_) - CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno) - CALL Display(obj%jt, "# jt: ", unitno=unitno) - CALL Display(obj%theta, "# theta: ", unitno=unitno) - CALL Display(obj%wt, "# wt: ", unitno=unitno) + CALL Util_Display("SHAPE FUNCTION IN TIME: ", unitno=unitno) + CALL Util_Display(obj%jt, "jt: ", unitno=unitno) + CALL Util_Display(obj%wt, "wt: ", unitno=unitno) IF (ALLOCATED(obj%T)) THEN - CALL Display(obj%T, "# T: ", unitno=unitno) + CALL Util_Display(obj%T, "T: ", unitno=unitno) ELSE - CALL Display("# T: NOT ALLOCATED", unitno=unitno) + CALL Util_Display("T: NOT ALLOCATED", unitno=unitno) END IF IF (ALLOCATED(obj%dTdTheta)) THEN - CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno) + CALL Util_Display(obj%dTdTheta, "dTdTheta: ", unitno=unitno) ELSE - CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno) + CALL Util_Display("dTdTheta: NOT ALLOCATED", unitno=unitno) END IF IF (ALLOCATED(obj%dNTdt)) THEN - CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno) + CALL Util_Display(obj%dNTdt, "dNTdt: ", unitno=unitno) ELSE - CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno) + CALL Util_Display("dNTdt: NOT ALLOCATED", unitno=unitno) END IF IF (ALLOCATED(obj%dNTdXt)) THEN - CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno) + CALL Util_Display(obj%dNTdXt, "dNTdXt: ", unitno=unitno) ELSE - CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno) + CALL Util_Display("dNTdXt: NOT ALLOCATED", unitno=unitno) END IF END SELECT END PROCEDURE elemsd_display_1 @@ -259,7 +263,7 @@ INTEGER(I4B) :: ii DO ii = 1, SIZE(obj) CALL Display(obj=obj(ii), msg=TRIM(msg)//"("//tostring(ii)//"): ", & - & unitno=unitno) + unitno=unitno) END DO END PROCEDURE elemsd_display_2 From a870dc13797071e1c501c63e2a7ec1a89589249b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:34 +0900 Subject: [PATCH 257/359] update in elemshape data --- ...shapeData_LocalGradientMethods@Methods.F90 | 101 +++++++++--------- 1 file changed, 50 insertions(+), 51 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 index 82ee7c65f..d998a2392 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 @@ -21,148 +21,147 @@ CONTAINS !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_1 +MODULE PROCEDURE elemsd_GetLocalGradient_1 lg = MATMUL(Val, obj%dNdXi) !! matmul r1 r3 -END PROCEDURE elemsd_getLocalGradient_1 +END PROCEDURE elemsd_GetLocalGradient_1 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_2 +MODULE PROCEDURE elemsd_GetLocalGradient_2 lg = MATMUL(Val, obj%dNdXi) !! matmul r2 r3 -END PROCEDURE elemsd_getLocalGradient_2 +END PROCEDURE elemsd_GetLocalGradient_2 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_3 +MODULE PROCEDURE elemsd_GetLocalGradient_3 SELECT TYPE (obj) TYPE IS (STElemshapeData_) lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) !! matmul r1 r3 END SELECT -END PROCEDURE elemsd_getLocalGradient_3 +END PROCEDURE elemsd_GetLocalGradient_3 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_4 +MODULE PROCEDURE elemsd_GetLocalGradient_4 SELECT TYPE (obj) TYPE IS (STElemshapeData_) lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) !! (r3.r1).r3 => r2.r3 END SELECT -END PROCEDURE elemsd_getLocalGradient_4 +END PROCEDURE elemsd_GetLocalGradient_4 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_5 +MODULE PROCEDURE elemsd_GetLocalGradient_5 SELECT CASE (val%varType) CASE (constant) - CALL reallocate(lg, obj%refelem%xidimension, SIZE(obj%N, 2)) + CALL Reallocate(lg, obj%xidim, obj%nips) CASE (space) - CALL getLocalGradient(obj=obj, lg=lg, & + CALL GetLocalGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) CASE (spacetime) SELECT TYPE (obj) TYPE is (STElemShapeData_) - CALL getLocalGradient(obj=obj, lg=lg, & + CALL GetLocalGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) END SELECT END SELECT -END PROCEDURE elemsd_getLocalGradient_5 +END PROCEDURE elemsd_GetLocalGradient_5 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_6 +MODULE PROCEDURE elemsd_GetLocalGradient_6 INTEGER(I4B) :: s(1) !! SELECT CASE (val%varType) CASE (constant) s = SHAPE(val) - CALL reallocate(lg, s(1), obj%refelem%xidimension, SIZE(obj%N, 2)) + CALL Reallocate(lg, s(1), obj%xidim, obj%nips) CASE (space) - CALL getLocalGradient(obj=obj, lg=lg, & + CALL GetLocalGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace)) CASE (spacetime) SELECT TYPE (obj) TYPE is (STElemShapeData_) - CALL getLocalGradient(obj=obj, lg=lg, & + CALL GetLocalGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) END SELECT END SELECT -END PROCEDURE elemsd_getLocalGradient_6 +END PROCEDURE elemsd_GetLocalGradient_6 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_7 +MODULE PROCEDURE elemsd_GetLocalGradient_7 lg = MATMUL(val, obj%dNdXi) !! r3.r4 -END PROCEDURE elemsd_getLocalGradient_7 +END PROCEDURE elemsd_GetLocalGradient_7 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_8 +MODULE PROCEDURE elemsd_GetLocalGradient_8 SELECT TYPE (obj) TYPE IS (STElemShapeData_) lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi) !! (r4.r1).r3 END SELECT -END PROCEDURE elemsd_getLocalGradient_8 +END PROCEDURE elemsd_GetLocalGradient_8 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_9 +MODULE PROCEDURE elemsd_GetLocalGradient_9 INTEGER(I4B) :: s(2) SELECT CASE (val%varType) CASE (constant) s = SHAPE(val) - CALL reallocate(lg, s(1), s(2), & - & obj%refelem%xidimension, SIZE(obj%N, 2)) + CALL Reallocate(lg, s(1), s(2), obj%xidim, obj%nips) CASE (space) - CALL getLocalGradient(obj=obj, lg=lg, & + CALL GetLocalGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) CASE (spacetime) SELECT TYPE (obj) TYPE is (STElemShapeData_) - CALL getLocalGradient(obj=obj, lg=lg, & + CALL GetLocalGradient(obj=obj, lg=lg, & & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) END SELECT END SELECT -END PROCEDURE elemsd_getLocalGradient_9 +END PROCEDURE elemsd_GetLocalGradient_9 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_10 +MODULE PROCEDURE elemsd_GetLocalGradient_10 REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :) !! SELECT CASE (val%rank) CASE (scalar) - CALL getLocalGradient(obj=obj, lg=r2, val=val) + CALL GetLocalGradient(obj=obj, lg=r2, val=val) lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace) DEALLOCATE (r2) CASE (vector) - CALL getLocalGradient(obj=obj, lg=r3, val=val) + CALL GetLocalGradient(obj=obj, lg=r3, val=val) lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace) DEALLOCATE (r3) CASE (matrix) @@ -170,13 +169,13 @@ !! TODO Extend FEVariable to support r3, which is necessary to keep !! the gradient of rank02 tensors END SELECT -END PROCEDURE elemsd_getLocalGradient_10 +END PROCEDURE elemsd_GetLocalGradient_10 !---------------------------------------------------------------------------- -! getLocalGradient +! GetLocalGradient !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_getLocalGradient_11 +MODULE PROCEDURE elemsd_GetLocalGradient_11 REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) INTEGER(I4B) :: ii !! @@ -186,9 +185,9 @@ !! CASE (scalar) DO ii = 1, SIZE(obj) - CALL getLocalGradient(obj=obj(ii), lg=r2, val=val) + CALL GetLocalGradient(obj=obj(ii), lg=r2, val=val) IF (.NOT. ALLOCATED(r3)) THEN - CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) + CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj)) END IF !! r3(:, :, ii) = r2(:, :) @@ -201,9 +200,9 @@ !! CASE (vector) DO ii = 1, SIZE(obj) - CALL getLocalGradient(obj=obj(ii), lg=r3, val=val) + CALL GetLocalGradient(obj=obj(ii), lg=r3, val=val) IF (.NOT. ALLOCATED(r4)) THEN - CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) + CALL Reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj)) END IF !! r4(:, :, :, ii) = r3(:, :, :) @@ -219,14 +218,14 @@ !! TODO Extend FEVariable to support r3, which is necessary to keep !! the gradient of rank02 tensors END SELECT -END PROCEDURE elemsd_getLocalGradient_11 +END PROCEDURE elemsd_GetLocalGradient_11 !---------------------------------------------------------------------------- ! LocalGradient !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_LocalGradient_1 -CALL getLocalGradient(obj=obj, lg=ans, val=val) +CALL GetLocalGradient(obj=obj, lg=ans, val=val) END PROCEDURE elemsd_LocalGradient_1 !---------------------------------------------------------------------------- @@ -234,7 +233,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_LocalGradient_2 -CALL getLocalGradient(obj=obj, lg=ans, val=val) +CALL GetLocalGradient(obj=obj, lg=ans, val=val) END PROCEDURE elemsd_LocalGradient_2 !---------------------------------------------------------------------------- From 79e06846a5c5c19740da71e0553eeaaf21e1e5ed Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:38 +0900 Subject: [PATCH 258/359] update in elemshape data --- .../src/ElemshapeData_SetMethods@Methods.F90 | 209 +++++++++++------- 1 file changed, 125 insertions(+), 84 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 index 143d1bb7f..8b773d8d3 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -16,7 +16,14 @@ ! SUBMODULE(ElemshapeData_SetMethods) Methods -USE BaseMethod +USE ProductUtility, ONLY: VectorProduct, OuterProd + +USE InvUtility, ONLY: Det, Inv + +USE ReallocateUtility, ONLY: Reallocate + +USE MatmulUtility + IMPLICIT NONE CONTAINS @@ -26,7 +33,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SetThickness -obj%Thickness = MATMUL(val, N) +obj%thickness(1:obj%nips) = MATMUL(val, N) END PROCEDURE elemsd_SetThickness !---------------------------------------------------------------------------- @@ -42,7 +49,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SetBarycentricCoord -obj%Coord = MATMUL(val, N) +obj%coord(1:obj%nsd, 1:obj%nips) = MATMUL(val, N) END PROCEDURE elemsd_SetBarycentricCoord !---------------------------------------------------------------------------- @@ -59,27 +66,40 @@ MODULE PROCEDURE elemsd_SetJs ! Define internal variable -INTEGER(I4B) :: xidim, nsd, nips, ips +INTEGER(I4B) :: ips, caseid + REAL(DFP) :: aa, bb, ab -! -xidim = obj%RefElem%XiDimension -nsd = obj%RefElem%nsd -nips = SIZE(obj%N, 2) -! -DO ips = 1, nips - IF (nsd .EQ. xidim) THEN - obj%Js(ips) = det(obj%Jacobian(:, :, ips)) - ELSE IF (xidim .EQ. 1 .AND. xidim .NE. nsd) THEN - obj%Js(ips) = & - & SQRT(DOT_PRODUCT(obj%Jacobian(:, 1, ips), & - & obj%Jacobian(:, 1, ips))) - ELSE IF (xidim .EQ. 2 .AND. xidim .NE. nsd) THEN - aa = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 1, ips)) - bb = DOT_PRODUCT(obj%Jacobian(:, 2, ips), obj%Jacobian(:, 2, ips)) - ab = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 2, ips)) - obj%Js(ips) = SQRT(aa * bb - ab * ab) - END IF -END DO + +caseid = obj%xidim + +IF (obj%nsd .EQ. obj%xidim) THEN + caseid = 3 +END IF + +SELECT CASE (caseid) + +CASE (1) + DO ips = 1, obj%nips + obj%js(ips) = NORM2(obj%jacobian(1:obj%nsd, 1, ips)) + END DO + +CASE (2) + + DO ips = 1, obj%nips + aa = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), obj%jacobian(1:obj%nsd, 1, ips)) + bb = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 2, ips), obj%jacobian(1:obj%nsd, 2, ips)) + ab = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), obj%jacobian(1:obj%nsd, 2, ips)) + obj%js(ips) = SQRT(aa * bb - ab * ab) + END DO + +CASE (3) + + DO ips = 1, obj%nips + obj%js(ips) = Det(obj%jacobian(1:obj%nsd, 1:obj%xidim, ips)) + END DO + +END SELECT + END PROCEDURE elemsd_SetJs !---------------------------------------------------------------------------- @@ -88,26 +108,27 @@ MODULE PROCEDURE elemsd_SetdNdXt ! Define internal variables -INTEGER(I4B) :: NSD, XiDim, ips, nips -REAL(DFP), ALLOCATABLE :: InvJacobian(:, :, :) - -NSD = obj%RefElem%NSD - -XiDim = obj%RefElem%XiDimension - -IF (NSD .NE. XiDim) THEN - obj%dNdXt = 0.0_DFP -ELSE - ! Compute inverse of Jacobian - nips = SIZE(obj%N, 2) - ALLOCATE (InvJacobian(NSD, NSD, nips)) - CALL Inv(InvA=InvJacobian, A=obj%Jacobian) - DO ips = 1, nips - obj%dNdXt(:, :, ips) = & - & MATMUL(obj%dNdXi(:, :, ips), InvJacobian(:, :, ips)) - END DO - DEALLOCATE (InvJacobian) +INTEGER(I4B) :: ips + +REAL(DFP) :: invJacobian(3, 3) + +LOGICAL(LGT) :: abool + +abool = obj%nsd .NE. obj%xidim + +IF (abool) THEN + obj%dNdXt(1:obj%nns, 1:obj%nsd, 1:obj%nips) = 0.0_DFP + RETURN END IF + +DO ips = 1, obj%nips + CALL Inv(InvA=invJacobian, A=obj%jacobian(1:obj%nsd, 1:obj%nsd, ips)) + + obj%dNdXt(1:obj%nns, 1:obj%nsd, ips) = & + MATMUL(obj%dNdXi(1:obj%nns, 1:obj%xidim, ips), & + invJacobian(1:obj%nsd, 1:obj%nsd)) +END DO + END PROCEDURE elemsd_SetdNdXt !---------------------------------------------------------------------------- @@ -115,7 +136,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SetJacobian -obj%jacobian = MATMUL(val, dNdXi) +obj%jacobian(1:obj%nsd, 1:obj%xidim, 1:obj%nips) = MATMUL(val, dNdXi) END PROCEDURE elemsd_SetJacobian !---------------------------------------------------------------------------- @@ -131,17 +152,35 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE stsd_SetdNTdt -REAL(DFP), ALLOCATABLE :: v(:, :) -INTEGER(I4B) :: ip +REAL(DFP), ALLOCATABLE :: v(:, :), mat2(:, :) +REAL(DFP) :: areal + +INTEGER(I4B) :: ip, tsize ! get mesh velocity at space integration points -v = MATMUL(MATMUL(val, obj%dTdTheta / obj%Jt), obj%N) -CALL Reallocate(obj%dNTdt, SIZE(obj%N, 1), SIZE(obj%T), & - & SIZE(obj%N, 2)) -DO ip = 1, SIZE(obj%N, 2) - obj%dNTdt(:, :, ip) = OUTERPROD(obj%N(:, ip), obj%dTdTheta / obj%Jt) & - & - MATMUL(obj%dNTdXt(:, :, :, ip), v(:, ip)) + +! CALL Reallocate(obj%dNTdt, obj%nns, obj%nnt, obj%nips) +areal = 1.0_DFP / obj%jt + +tsize = MAX(obj%nns, obj%nips) +ALLOCATE (v(3, tsize), mat2(obj%nns, obj%nnt)) + +v(1:obj%nsd, 1:obj%nns) = MATMUL(val, obj%dTdTheta) +v(1:obj%nsd, 1:obj%nns) = v(1:obj%nsd, 1:obj%nns) * areal +v(1:obj%nsd, 1:obj%nips) = MATMUL(v(1:obj%nsd, 1:obj%nns), & + obj%N(1:obj%nns, 1:obj%nips)) + +DO ip = 1, obj%nips + mat2(1:obj%nns, 1:obj%nnt) = OUTERPROD(obj%N(1:obj%nns, ip), obj%dTdTheta(1:obj%nnt)) + mat2 = mat2 * areal + + obj%dNTdt(1:obj%nns, 1:obj%nnt, ip) = mat2 - & + MATMUL(obj%dNTdXt(1:obj%nns, 1:obj%nnt, 1:obj%nsd, ip), v(1:obj%nsd, ip)) + END DO + +DEALLOCATE (v, mat2) + END PROCEDURE stsd_SetdNTdt !---------------------------------------------------------------------------- @@ -149,29 +188,30 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE stsd_SetdNTdXt -! +REAL(DFP) :: Q(3, 3), temp(obj%nns, obj%nsd) INTEGER(I4B) :: ip, j -REAL(DFP), ALLOCATABLE :: Q(:, :), Temp(:, :) -! -CALL Reallocate(obj%dNTdXt, SIZE(obj%N, 1), SIZE(obj%T), & - & SIZE(obj%Jacobian, 1), SIZE(obj%N, 2)) -! -IF (obj%RefElem%XiDimension .NE. obj%RefElem%NSD) THEN + +CALL Reallocate(obj%dNTdXt, obj%nns, obj%nnt, obj%nsd, obj%nips) + +IF (obj%xidim .NE. obj%nsd) THEN RETURN END IF -! -Q = obj%Jacobian(:, :, 1) -! -DO ip = 1, SIZE(obj%N, 2) - CALL INV(A=obj%Jacobian(:, :, ip), INVA=Q) - Temp = MATMUL(obj%dNdXi(:, :, ip), Q) - DO j = 1, SIZE(Q, 1) - obj%dNTdXt(:, :, j, ip) = OUTERPROD(Temp(:, j), obj%T) + +DO ip = 1, obj%nips + + CALL INV(A=obj%jacobian(1:obj%nsd, 1:obj%xidim, ip), & + INVA=Q(1:obj%nsd, 1:obj%nsd)) + + temp = MATMUL(obj%dNdXi(1:obj%nns, 1:obj%xidim, ip), & + Q(1:obj%nsd, 1:obj%nsd)) + + DO j = 1, obj%nsd + obj%dNTdXt(1:obj%nns, 1:obj%nnt, j, ip) = OUTERPROD(temp(1:obj%nns, j), & + obj%T(1:obj%nnt)) END DO + END DO -! -DEALLOCATE (Q, Temp) -! + END PROCEDURE stsd_SetdNTdXt !---------------------------------------------------------------------------- @@ -190,20 +230,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Set2 -INTEGER(I4B), ALLOCATABLE :: facetNptrs(:) - CALL SetJacobian(obj=cellobj, val=cellVal, dNdXi=celldNdXi) CALL SetJs(obj=cellobj) CALL SetdNdXt(obj=cellobj) CALL SetBarycentricCoord(obj=cellobj, val=cellval, N=cellN) -facetNptrs = GetConnectivity(facetobj%refelem) - CALL SetJacobian(obj=facetobj, val=cellVal(:, facetNptrs), & - & dNdXi=facetdNdXi) + dNdXi=facetdNdXi) CALL SetJs(obj=facetobj) CALL SetBarycentricCoord(obj=facetobj, val=cellval(:, facetNptrs), & - & N=facetN) + N=facetN) CALL SetNormal(obj=facetobj) @@ -220,7 +256,6 @@ cellobj%Js = facetobj%Js cellobj%Ws = facetobj%Ws -IF (ALLOCATED(facetNptrs)) DEALLOCATE (facetNptrs) END PROCEDURE elemsd_Set2 !---------------------------------------------------------------------------- @@ -236,7 +271,7 @@ & cellN=masterCellN, & & celldNdXi=masterCelldNdXi, & & facetN=masterFacetN, & - & facetdNdXi=masterFacetdNdXi) + & facetdNdXi=masterFacetdNdXi, facetNptrs=masterFacetNptrs) ! CALL Set( & & facetobj=slaveFacetObj, & @@ -245,7 +280,7 @@ & cellN=slaveCellN, & & celldNdXi=slaveCelldNdXi, & & facetN=slaveFacetN, & - & facetdNdXi=slaveFacetdNdXi) + & facetdNdXi=slaveFacetdNdXi, facetNptrs=slaveFacetNptrs) ! END PROCEDURE elemsd_Set3 @@ -269,14 +304,20 @@ MODULE PROCEDURE elemsd_SetNormal REAL(DFP) :: vec(3, 3) INTEGER(I4B) :: i, xidim, nsd + vec = 0.0_DFP vec(3, 2) = 1.0_DFP -xidim = obj%RefElem%XiDimension -nsd = obj%refElem%nsd -DO i = 1, SIZE(obj%N, 2) - Vec(1:nsd, 1:xidim) = obj%Jacobian(1:nsd, 1:xidim, i) - obj%Normal(:, i) = & - & VectorProduct(Vec(:, 1), Vec(:, 2)) / obj%Js(i) + +xidim = obj%xidim + +nsd = obj%nsd + +DO i = 1, obj%nips + + vec(1:nsd, 1:xidim) = obj%jacobian(1:nsd, 1:xidim, i) + obj%normal(1:3, i) = & + VectorProduct(vec(:, 1), vec(:, 2)) / obj%js(i) + END DO END PROCEDURE elemsd_SetNormal From 379cd14e42204b1e1bfead751b4d06db8ff947a2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:42 +0900 Subject: [PATCH 259/359] update in elemshape data --- ...lemshapeData_UnitNormalMethods@Methods.F90 | 90 +++++++++---------- 1 file changed, 45 insertions(+), 45 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 index 07a7d5fae..15aa50970 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 @@ -31,7 +31,7 @@ !! main CALL getInterpolation(obj=obj, Val=val, Interpol=p) CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) -CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2)) +CALL Reallocate(R, obj%nsd, obj%nips) pnorm = NORM2(dp, DIM=1) !! DO ii = 1, SIZE(p) @@ -66,7 +66,7 @@ !! get gradient of nodal values CALL getSpatialGradient(obj=obj, lg=dp, Val=val) pnorm = NORM2(p, DIM=1) -CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2)) +CALL Reallocate(R, obj%nsd, obj%nips) DO i = 1, SIZE(pnorm) IF (pnorm(i) .GT. Zero) THEN p(:, i) = p(:, i) / pnorm(i) @@ -104,27 +104,27 @@ PURE SUBROUTINE scalar_getUnitNormal_3(obj, r, val) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :) TYPE(FEVariable_), INTENT(IN) :: val ! Define internal variables -REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) -INTEGER(I4B) :: ii + REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) + INTEGER(I4B) :: ii !! main -CALL getInterpolation(obj=obj, Val=val, Interpol=p) -CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) -CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2)) -pnorm = NORM2(dp, DIM=1) + CALL getInterpolation(obj=obj, Val=val, Interpol=p) + CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) + CALL Reallocate(R, obj%nsd, obj%nips) + pnorm = NORM2(dp, DIM=1) !! -DO ii = 1, SIZE(p) - IF (pnorm(ii) .GT. zero) THEN - IF (p(ii) .GE. 0.0_DFP) THEN - R(:, ii) = dp(:, ii) / pnorm(ii) - ELSE - R(:, ii) = -dp(:, ii) / pnorm(ii) + DO ii = 1, SIZE(p) + IF (pnorm(ii) .GT. zero) THEN + IF (p(ii) .GE. 0.0_DFP) THEN + R(:, ii) = dp(:, ii) / pnorm(ii) + ELSE + R(:, ii) = -dp(:, ii) / pnorm(ii) + END IF END IF - END IF -END DO + END DO !! -IF (ALLOCATED(dp)) DEALLOCATE (dp) -IF (ALLOCATED(p)) DEALLOCATE (p) -IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) + IF (ALLOCATED(dp)) DEALLOCATE (dp) + IF (ALLOCATED(p)) DEALLOCATE (p) + IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) END SUBROUTINE scalar_getUnitNormal_3 !! PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val) @@ -132,35 +132,35 @@ PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :) TYPE(FEVariable_), INTENT(IN) :: val !! Define internal variables -REAL(DFP), ALLOCATABLE :: dp(:, :, :) -REAL(DFP), ALLOCATABLE :: p(:, :) -REAL(DFP), ALLOCATABLE :: mv(:) -REAL(DFP), ALLOCATABLE :: pnorm(:) -REAL(DFP) :: nrm -INTEGER(I4B) :: i + REAL(DFP), ALLOCATABLE :: dp(:, :, :) + REAL(DFP), ALLOCATABLE :: p(:, :) + REAL(DFP), ALLOCATABLE :: mv(:) + REAL(DFP), ALLOCATABLE :: pnorm(:) + REAL(DFP) :: nrm + INTEGER(I4B) :: i !! main !! interpolate the vector -CALL getInterpolation(obj=obj, Interpol=p, Val=val) + CALL getInterpolation(obj=obj, Interpol=p, Val=val) !! get gradient of nodal values -CALL getSpatialGradient(obj=obj, lg=dp, Val=val) -pnorm = NORM2(p, DIM=1) -CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2)) -DO i = 1, SIZE(pnorm) - IF (pnorm(i) .GT. Zero) THEN - p(:, i) = p(:, i) / pnorm(i) - ELSE - p(:, i) = 1.0 - END IF - mv = MATMUL(p(:, i), dp(:, :, i)) - nrm = NORM2(mv) - IF (nrm .GT. Zero) THEN - R(:, i) = mv / nrm - END IF -END DO -IF (ALLOCATED(dp)) DEALLOCATE (dp) -IF (ALLOCATED(p)) DEALLOCATE (p) -IF (ALLOCATED(mv)) DEALLOCATE (mv) -IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) + CALL getSpatialGradient(obj=obj, lg=dp, Val=val) + pnorm = NORM2(p, DIM=1) + CALL Reallocate(R, obj%nsd, obj%nips) + DO i = 1, SIZE(pnorm) + IF (pnorm(i) .GT. Zero) THEN + p(:, i) = p(:, i) / pnorm(i) + ELSE + p(:, i) = 1.0 + END IF + mv = MATMUL(p(:, i), dp(:, :, i)) + nrm = NORM2(mv) + IF (nrm .GT. Zero) THEN + R(:, i) = mv / nrm + END IF + END DO + IF (ALLOCATED(dp)) DEALLOCATE (dp) + IF (ALLOCATED(p)) DEALLOCATE (p) + IF (ALLOCATED(mv)) DEALLOCATE (mv) + IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm) END SUBROUTINE vector_getUnitNormal_3 !! END PROCEDURE getUnitNormal_3 From 8323a0fdc3cca985580bce554b6f92ce7a007cdf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:53 +0900 Subject: [PATCH 260/359] update in elemshape data --- src/submodules/ElemshapeData/CMakeLists.txt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt index 1be380742..7d9338761 100644 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -36,9 +36,9 @@ target_sources( ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90) -include(${src_path}/H1/CMakeLists.txt) -include(${src_path}/HDiv/CMakeLists.txt) -include(${src_path}/HCurl/CMakeLists.txt) -include(${src_path}/DG/CMakeLists.txt) +# include(${src_path}/H1/CMakeLists.txt) +# include(${src_path}/HDiv/CMakeLists.txt) +# include(${src_path}/HCurl/CMakeLists.txt) +# include(${src_path}/DG/CMakeLists.txt) include(${src_path}/Lagrange/CMakeLists.txt) include(${src_path}/Hierarchical/CMakeLists.txt) From 36dd4762a2e682b5dd2cb718adf634f29623a8f6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:37:59 +0900 Subject: [PATCH 261/359] update in facet matrix --- ...acetMatrix_Method@FacetMatrix11Methods.F90 | 356 +++++++++--------- 1 file changed, 178 insertions(+), 178 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 index b9cf81703..e6d2ef714 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 @@ -26,46 +26,46 @@ MODULE PROCEDURE FacetMatrix11_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C1(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns = nns1 + nns2 - nsd = masterElemSD%refelem%nsd +nns1 = SIZE(masterElemSD%dNdXt, 1) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nips = SIZE(masterElemSD%dNdXt, 3) +nns = nns1 + nns2 +nsd = masterElemSD%nsd !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP +ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - ans = ans + & - & realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + ans = ans + & + & realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) !! - END DO +END DO !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) !! - DEALLOCATE( realval, masterC1, slaveC1, C1 ) +DEALLOCATE (realval, masterC1, slaveC1, C1) !! END PROCEDURE FacetMatrix11_1 @@ -75,49 +75,49 @@ MODULE PROCEDURE FacetMatrix11_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), slaveC1(:,:), & - & C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), slaveC1(:, :), & + & C1(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP +ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - masterC1 = masterC1 * muMaster - slaveC1 = slaveC1 * muSlave +masterC1 = masterC1 * muMaster +slaveC1 = slaveC1 * muSlave !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) + ans = ans & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) !! - END DO +END DO !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) !! - DEALLOCATE( realval, masterC1, slaveC1, C1 ) +DEALLOCATE (realval, masterC1, slaveC1, C1) !! END PROCEDURE FacetMatrix11_2 @@ -127,50 +127,50 @@ MODULE PROCEDURE FacetMatrix11_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), taubar( : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), taubar(:), C1(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP +ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) !! - masterC1 = masterC1 * muMaster - slaveC1 = slaveC1 * muSlave +masterC1 = masterC1 * muMaster +slaveC1 = slaveC1 * muSlave !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * & - & taubar +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * & + & taubar !! - DO ips = 1, nips - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO +DO ips = 1, nips + ans = ans & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) !! - DEALLOCATE( realval, masterC1, slaveC1, taubar, C1 ) +DEALLOCATE (realval, masterC1, slaveC1, taubar, C1) !! END PROCEDURE FacetMatrix11_3 @@ -180,56 +180,56 @@ MODULE PROCEDURE FacetMatrix11_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & muMasterBar( : ), muSlaveBar( : ), slaveC1( :, : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & muMasterBar(:), muSlaveBar(:), slaveC1(:, :), C1(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP +ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster) !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave) !! - DO ips = 1, nips - slaveips = quadMap( ips ) - masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO +DO ips = 1, nips + slaveips = quadMap(ips) + masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips) + slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO +DO ips = 1, nips + ans = ans & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) !! - DEALLOCATE( realval, masterC1, slaveC1, C1, muMasterBar, muSlaveBar ) +DEALLOCATE (realval, masterC1, slaveC1, C1, muMasterBar, muSlaveBar) !! END PROCEDURE FacetMatrix11_4 @@ -239,63 +239,63 @@ MODULE PROCEDURE FacetMatrix11_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & muMasterBar( : ), muSlaveBar( : ), tauBar( : ), slaveC1( :, : ), & - & C1(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & muMasterBar(:), muSlaveBar(:), tauBar(:), slaveC1(:, :), & + & C1(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 !! - ALLOCATE( C1( nns, nips ), ans( nns, nns ) ) +ALLOCATE (C1(nns, nips), ans(nns, nns)) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster) !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave) !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauBar, & - & val=tauvar ) +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauBar, & + & val=tauvar) !! - DO ips = 1, nips - slaveips = quadMap( ips ) - masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips) - END DO +DO ips = 1, nips + slaveips = quadMap(ips) + masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips) + slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) +END DO !! - realval = masterElemSD%js*masterElemSD%ws*masterElemSD%thickness*tauBar +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * tauBar !! - DO ips = 1, nips - ans = ans & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO +DO ips = 1, nips + ans = ans & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO !! - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) !! - DEALLOCATE( realval, masterC1, slaveC1, muMasterBar, & - & muSlaveBar, C1 ) +DEALLOCATE (realval, masterC1, slaveC1, muMasterBar, & + & muSlaveBar, C1) !! END PROCEDURE FacetMatrix11_5 @@ -303,4 +303,4 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE FacetMatrix11Methods \ No newline at end of file +END SUBMODULE FacetMatrix11Methods From 7b4f93b152e22d40305a004c47f5bd44e41a114e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:38:08 +0900 Subject: [PATCH 262/359] update in facet matrix method\ --- ...acetMatrix_Method@FacetMatrix12Methods.F90 | 170 +++++++++--------- 1 file changed, 85 insertions(+), 85 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 index 85cd9bb10..584a75829 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 @@ -26,24 +26,24 @@ MODULE PROCEDURE FacetMatrix12_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns, nsd +REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :) +INTEGER(I4B) :: ips, nips, nns, nsd !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal ) - realval = elemsd%js * elemsd%ws * elemsd%thickness - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1 ) +nns = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +CALL Reallocate(ans, nns, nns) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=C1, & + & val=elemsd%normal) +realval = elemsd%js * elemsd%ws * elemsd%thickness +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) +DEALLOCATE (realval, C1) !! END PROCEDURE FacetMatrix12_1 @@ -53,24 +53,24 @@ MODULE PROCEDURE FacetMatrix12_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ) - INTEGER( I4B ) :: ips, nips, nns, nsd +REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :) +INTEGER(I4B) :: ips, nips, nns, nsd !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal ) - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1 ) +nns = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +CALL Reallocate(ans, nns, nns) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=C1, & + & val=elemsd%normal) +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) +DEALLOCATE (realval, C1) !! END PROCEDURE FacetMatrix12_2 @@ -80,25 +80,25 @@ MODULE PROCEDURE FacetMatrix12_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), taubar( : ) - INTEGER( I4B ) :: ips, nips, nns, nsd +REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :), taubar(:) +INTEGER(I4B) :: ips, nips, nns, nsd !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal ) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1, taubar ) +nns = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +CALL Reallocate(ans, nns, nns) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=C1, & + & val=elemsd%normal) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) +DEALLOCATE (realval, C1, taubar) !! END PROCEDURE FacetMatrix12_3 @@ -108,22 +108,22 @@ MODULE PROCEDURE FacetMatrix12_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), muBar( : ) - INTEGER( I4B ) :: ips, nips, nns, nsd +REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :), muBar(:) +INTEGER(I4B) :: ips, nips, nns, nsd !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) - realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1, muBar ) +nns = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +CALL Reallocate(ans, nns, nns) +CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal) +CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) +realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) +DEALLOCATE (realval, C1, muBar) !! END PROCEDURE FacetMatrix12_4 @@ -133,25 +133,25 @@ MODULE PROCEDURE FacetMatrix12_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), & - & muBar( : ), tauBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns, nsd +REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :), & + & muBar(:), tauBar(:) +INTEGER(I4B) :: ips, ii, jj, nips, nns, nsd !! - nns = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - CALL Reallocate(ans, nns, nns) - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) - CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar ) - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) ) - END DO - IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy) - DEALLOCATE( realval, C1, muBar ) +nns = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +CALL Reallocate(ans, nns, nns) +CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal) +CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) +CALL getInterpolation(obj=elemsd, interpol=tauBar, val=tauvar) +realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips)) +END DO +IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy) +DEALLOCATE (realval, C1, muBar) !! END PROCEDURE FacetMatrix12_5 -END SUBMODULE FacetMatrix12Methods \ No newline at end of file +END SUBMODULE FacetMatrix12Methods From 214855fba04c9b020893127754337c9c1bc3d13e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:38:14 +0900 Subject: [PATCH 263/359] update in facet matrix methods --- ...acetMatrix_Method@FacetMatrix13Methods.F90 | 377 +++++++++--------- 1 file changed, 188 insertions(+), 189 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 index 124c1dc20..d48566e36 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 @@ -26,251 +26,250 @@ MODULE PROCEDURE FacetMatrix13_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO - END DO - END DO - !! - CALL Convert( from=m4, to=ans ) - !! - DEALLOCATE( m4, realval, masterC1 ) +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! +nns1 = SIZE(elemsd%dNdXt, 1) +nns2 = SIZE(elemsd%N, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! -END PROCEDURE FacetMatrix13_1 - -!---------------------------------------------------------------------------- -! FacetMatrix13 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE FacetMatrix13_2 +realval = elemsd%js * elemsd%ws * elemsd%thickness !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), & + & elemsd%N(:, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1 ) +DEALLOCATE (m4, realval, masterC1) !! -END PROCEDURE FacetMatrix13_2 +END PROCEDURE FacetMatrix13_1 !---------------------------------------------------------------------------- ! FacetMatrix13 !---------------------------------------------------------------------------- -MODULE PROCEDURE FacetMatrix13_3 +MODULE PROCEDURE FacetMatrix13_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%dNdXt, 1) +nns2 = SIZE(elemsd%N, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & +CALL getProjectionOfdNdXt( & & obj=elemsd, & & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + & val=elemsd%normal) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), & + & elemsd%N(:, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, taubar ) +DEALLOCATE (m4, realval, masterC1) !! -END PROCEDURE FacetMatrix13_3 - +END PROCEDURE FacetMatrix13_2 !---------------------------------------------------------------------------- ! FacetMatrix13 !---------------------------------------------------------------------------- -MODULE PROCEDURE FacetMatrix13_4 +MODULE PROCEDURE FacetMatrix13_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :), taubar(:) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! +nns1 = SIZE(elemsd%dNdXt, 1) +nns2 = SIZE(elemsd%N, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & +& obj=elemsd, & +& cdNdXt=masterC1, & +& val=elemsd%normal) + !! +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar + !! +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), & + & elemsd%N(:, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, mubar ) +DEALLOCATE (m4, realval, masterC1, taubar) !! -END PROCEDURE FacetMatrix13_4 +END PROCEDURE FacetMatrix13_3 !---------------------------------------------------------------------------- ! FacetMatrix13 !---------------------------------------------------------------------------- -MODULE PROCEDURE FacetMatrix13_5 +MODULE PROCEDURE FacetMatrix13_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :), mubar(:) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nns2 = SIZE( elemsd%N, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%dNdXt, 1) +nns2 = SIZE(elemsd%N, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & +CALL getProjectionOfdNdXt( & & obj=elemsd, & & cdNdXt=masterC1, & - & val=elemsd%normal ) + & val=elemsd%normal) + !! +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar + !! +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), & + & elemsd%N(:, ips)) + END DO + END DO +END DO + !! +CALL Convert(from=m4, to=ans) !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +DEALLOCATE (m4, realval, masterC1, mubar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar +END PROCEDURE FacetMatrix13_4 + +!---------------------------------------------------------------------------- +! FacetMatrix13 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetMatrix13_5 !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), & - & elemsd%N( :, ips ) ) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :), mubar(:), taubar(:) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj + !! +nns1 = SIZE(elemsd%dNdXt, 1) +nns2 = SIZE(elemsd%N, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & +& obj=elemsd, & +& cdNdXt=masterC1, & +& val=elemsd%normal) + !! +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar + !! +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), & + & elemsd%N(:, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, mubar, taubar ) +DEALLOCATE (m4, realval, masterC1, mubar, taubar) !! END PROCEDURE FacetMatrix13_5 -END SUBMODULE FacetMatrix13Methods \ No newline at end of file +END SUBMODULE FacetMatrix13Methods From 7b1e4652c2d7d7b0577412eef1b5d1f025ca37ae Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:38:19 +0900 Subject: [PATCH 264/359] update in facet matrix --- ...acetMatrix_Method@FacetMatrix14Methods.F90 | 365 +++++++++--------- 1 file changed, 182 insertions(+), 183 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 index 805bf3938..f9979feae 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 @@ -26,45 +26,45 @@ MODULE PROCEDURE FacetMatrix14_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :) +INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 + !! +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) + !! +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness + !! +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1 ) +DEALLOCATE (m4, realval, masterC1) !! END PROCEDURE FacetMatrix14_1 @@ -74,45 +74,45 @@ MODULE PROCEDURE FacetMatrix14_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :) +INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2 + !! +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu + !! +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1 ) +DEALLOCATE (m4, realval, masterC1) !! END PROCEDURE FacetMatrix14_2 @@ -122,99 +122,98 @@ MODULE PROCEDURE FacetMatrix14_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :), taubar(:) +INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & +& obj=elemsd, & +& cdNdXt=masterC1, & +& val=elemsd%normal) + !! + !! +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar + !! +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, taubar ) +DEALLOCATE (m4, realval, masterC1, taubar) !! END PROCEDURE FacetMatrix14_3 - !---------------------------------------------------------------------------- ! FacetMatrix14 !---------------------------------------------------------------------------- MODULE PROCEDURE FacetMatrix14_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar - !! - DO ips = 1, nips - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :), mubar(:) +INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) + !! +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar + !! +DO ips = 1, nips + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips)) END DO END DO +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, mubar ) +DEALLOCATE (m4, realval, masterC1, mubar) !! END PROCEDURE FacetMatrix14_4 @@ -224,53 +223,53 @@ MODULE PROCEDURE FacetMatrix14_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & m4( :, :, :, : ), mubar( : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & m4(:, :, :, :), mubar(:), taubar(:) +INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj + !! +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getProjectionOfdNdXt( & +& obj=elemsd, & +& cdNdXt=masterC1, & +& val=elemsd%normal) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - DO ips = 1, nips +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar + !! +DO ips = 1, nips !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, mubar, taubar ) +DEALLOCATE (m4, realval, masterC1, mubar, taubar) !! END PROCEDURE FacetMatrix14_5 -END SUBMODULE FacetMatrix14Methods \ No newline at end of file +END SUBMODULE FacetMatrix14Methods From 2f793e9fc5b321a425c0460eaa129510afbe066f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:38:25 +0900 Subject: [PATCH 265/359] updat ein face matrix --- ...acetMatrix_Method@FacetMatrix15Methods.F90 | 706 +++++++++--------- 1 file changed, 353 insertions(+), 353 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 index 45b5cddd3..41aaef053 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 @@ -26,66 +26,66 @@ MODULE PROCEDURE FacetMatrix15_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) - !! - C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 +IF (opt .EQ. 1) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2)) +m4 = 0.0_DFP + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) + !! +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) + !! +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) + !! + C2(1:nns1, :, ips) = 0.5_DFP * masterElemSD%dNdXt(:, :, ips) + C2(nns1 + 1:, :, ips) = 0.5_DFP * slaveElemSD%dNdXt(:, :, slaveips) +END DO + !! +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! +DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) +DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4) !! END PROCEDURE FacetMatrix15_1 @@ -95,69 +95,69 @@ MODULE PROCEDURE FacetMatrix15_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) - !! - C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 +IF (opt .EQ. 1) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2)) +m4 = 0.0_DFP + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - DO ips = 1, nips +masterC1 = muMaster * masterC1 +slaveC1 = muSlave * slaveC1 + !! +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) + !! + C2(1:nns1, :, ips) = 0.5_DFP * masterElemSD%dNdXt(:, :, ips) + C2(nns1 + 1:, :, ips) = 0.5_DFP * slaveElemSD%dNdXt(:, :, slaveips) +END DO + !! +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! +DO ips = 1, nips !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) +DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4) !! END PROCEDURE FacetMatrix15_2 @@ -167,71 +167,71 @@ MODULE PROCEDURE FacetMatrix15_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 +IF (opt .EQ. 1) THEN !! - nsd1 = nsd - nsd2 = 1 + nsd1 = nsd + nsd2 = 1 !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP +ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2)) +m4 = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 +masterC1 = muMaster * masterC1 +slaveC1 = muSlave * slaveC1 !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) + slaveips = quadMap(ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) !! - C2(1:nns1, :, ips)=(0.5_DFP*tauMaster)*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=(0.5_DFP*tauSlave)*slaveElemSD%dNdXt(:, :, slaveips) + C2(1:nns1, :, ips) = (0.5_DFP * tauMaster) * masterElemSD%dNdXt(:, :, ips) + C2(nns1+1:, :, ips)=(0.5_DFP*tauSlave)*slaveElemSD%dNdXt(:, :, slaveips) !! - END DO +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 ) +DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4) !! END PROCEDURE FacetMatrix15_3 @@ -241,80 +241,80 @@ MODULE PROCEDURE FacetMatrix15_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :), & + & muMasterBar(:), muSlaveBar(:) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 !! - IF( opt .EQ. 1 ) THEN +IF (opt .EQ. 1) THEN !! - nsd1 = nsd - nsd2 = 1 + nsd1 = nsd + nsd2 = 1 !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP +ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2)) +m4 = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster) !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave) !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = muMasterBar(ips) * masterC1(:, ips) + C1(1 + nns1:, ips) = muSlaveBar(ips) * slaveC1(:, ips) !! - C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips) - END DO + C2(1:nns1, :, ips) = 0.5_DFP * masterElemSD%dNdXt(:, :, ips) + C2(nns1 + 1:, :, ips) = 0.5_DFP * slaveElemSD%dNdXt(:, :, slaveips) +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, muMasterBar, & - & muSlaveBar ) +DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4, muMasterBar, & + & muSlaveBar) !! END PROCEDURE FacetMatrix15_4 @@ -324,83 +324,83 @@ MODULE PROCEDURE FacetMatrix15_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & tauMasterBar( : ), tauSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = masterC1(:, ips) - C1( 1+nns1:, ips ) = slaveC1(:, slaveips ) - !! - C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) & - & *slaveElemSD%dNdXt(:, :, slaveips) +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :), & + & tauMasterBar(:), tauSlaveBar(:) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 +IF (opt .EQ. 1) THEN !! - END DO + nsd1 = nsd + nsd2 = 1 + !! +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2)) +m4 = 0.0_DFP + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) + !! +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) + !! +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster) + !! +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave) + !! +masterC1 = muMaster * masterC1 +slaveC1 = muSlave * slaveC1 + !! +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = masterC1(:, ips) + C1(1 + nns1:, ips) = slaveC1(:, slaveips) + !! + C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) + C2(nns1 + 1:, :, ips) = (0.5_DFP * tauSlaveBar(slaveips)) & + & * slaveElemSD%dNdXt(:, :, slaveips) + !! +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & - & tauSlaveBar ) +DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & + & tauSlaveBar) !! END PROCEDURE FacetMatrix15_5 @@ -410,92 +410,92 @@ MODULE PROCEDURE FacetMatrix15_6 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & tauMasterBar( : ), tauSlaveBar( : ), muMasterBar( : ), & - & muSlaveBar( : ), C( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - IF( opt .EQ. 1 ) THEN - !! - nsd1 = nsd - nsd2 = 1 - !! - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) ) - m4 = 0.0_DFP - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) - !! - DO ips = 1, nips - slaveips = quadMap( ips ) - C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips ) - C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips ) - !! - C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) - C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) & - & *slaveElemSD%dNdXt(:, :, slaveips) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :), & + & tauMasterBar(:), tauSlaveBar(:), muMasterBar(:), & + & muSlaveBar(:), C(:) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 +IF (opt .EQ. 1) THEN + !! + nsd1 = nsd + nsd2 = 1 + !! +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2)) +m4 = 0.0_DFP + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) + !! +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) + !! +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster) + !! +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave) + !! +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster) + !! +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave) + !! +DO ips = 1, nips + slaveips = quadMap(ips) + C1(1:nns1, ips) = muMasterBar(ips) * masterC1(:, ips) + C1(1 + nns1:, ips) = muSlaveBar(ips) * slaveC1(:, ips) + !! + C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips) + C2(nns1 + 1:, :, ips) = (0.5_DFP * tauSlaveBar(slaveips)) & + & * slaveElemSD%dNdXt(:, :, slaveips) + !! +END DO + !! +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! +DO ips = 1, nips + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & - & tauSlaveBar, muMasterBar, muSlaveBar ) +DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, & + & tauSlaveBar, muMasterBar, muSlaveBar) !! END PROCEDURE FacetMatrix15_6 -END SUBMODULE FacetMatrix15Methods \ No newline at end of file +END SUBMODULE FacetMatrix15Methods From a7152d05614f1cd792c647fab14e84637c96db1d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:38:28 +0900 Subject: [PATCH 266/359] update in facet matrix --- ...FacetMatrix_Method@FacetMatrix1Methods.F90 | 426 +++++++++--------- 1 file changed, 213 insertions(+), 213 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 index eb6aed951..cf3741f65 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 @@ -26,63 +26,63 @@ MODULE PROCEDURE FacetMatrix1_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal) !! - i3 = eye( nsd ) +i3 = eye(nsd) !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) +CALL Reallocate(G12, nns1 + nns2, nsd, nsd) +CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd) !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = OUTERPROD( & + & masterC1(:, ips), i3) & + & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 ) +DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3) !! END PROCEDURE FacetMatrix1_1 @@ -92,63 +92,63 @@ MODULE PROCEDURE FacetMatrix1_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal) !! - i3 = eye( nsd ) +i3 = eye(nsd) !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) +CALL Reallocate(G12, nns1 + nns2, nsd, nsd) +CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd) !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = muMaster*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = muMaster * OUTERPROD( & + & masterC1(:, ips), i3) & + & + muMaster * OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = muSlave*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = muSlave * OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + muSlave * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 ) +DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3) !! END PROCEDURE FacetMatrix1_2 @@ -158,67 +158,67 @@ MODULE PROCEDURE FacetMatrix1_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & - & taubar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :), & + & taubar(:) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal) !! - CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) !! - i3 = eye( nsd ) +i3 = eye(nsd) !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) +CALL Reallocate(G12, nns1 + nns2, nsd, nsd) +CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd) !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & - & * taubar +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & + & * taubar !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = muMaster*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = muMaster * OUTERPROD( & + & masterC1(:, ips), i3) & + & + muMaster * OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = muSlave*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = muSlave * OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + muSlave * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, taubar ) +DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3, taubar) !! END PROCEDURE FacetMatrix1_3 @@ -228,70 +228,70 @@ MODULE PROCEDURE FacetMatrix1_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & - & muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :), & + & muMasterBar(:), muSlaveBar(:) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal) !! - CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, & - & val=muMaster ) - CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, & - & val=muSlave ) +CALL getInterpolation(obj=masterElemSD, interpol=muMasterBar, & + & val=muMaster) +CALL getInterpolation(obj=slaveElemSD, interpol=muSlaveBar, & + & val=muSlave) !! - i3 = eye( nsd ) +i3 = eye(nsd) !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) +CALL Reallocate(G12, nns1 + nns2, nsd, nsd) +CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd) !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = muMasterBar(ips) * OUTERPROD( & + & masterC1(:, ips), i3) & + & + muMasterBar(ips) * OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = muSlaveBar(slaveips) * OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + muSlaveBar(slaveips) * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & - & muSlaveBar ) +DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & + & muSlaveBar) !! END PROCEDURE FacetMatrix1_4 @@ -301,73 +301,73 @@ MODULE PROCEDURE FacetMatrix1_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), & - & muMasterBar( : ), muSlaveBar( : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :), & + & muMasterBar(:), muSlaveBar(:), taubar(:) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemSD, & + & cdNdXt=masterC1, & + & val=masterElemSD%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemSD, & + & cdNdXt=slaveC1, & + & val=slaveElemSD%normal) !! - CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, & - & val=muMaster ) - CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, & - & val=muSlave ) - CALL getInterpolation( obj=masterElemSD, interpol=taubar, val=tauvar ) +CALL getInterpolation(obj=masterElemSD, interpol=muMasterBar, & + & val=muMaster) +CALL getInterpolation(obj=slaveElemSD, interpol=muSlaveBar, & + & val=muSlave) +CALL getInterpolation(obj=masterElemSD, interpol=taubar, val=tauvar) !! - i3 = eye( nsd ) +i3 = eye(nsd) !! - CALL Reallocate( G12, nns1+nns2, nsd, nsd ) - CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd ) +CALL Reallocate(G12, nns1 + nns2, nsd, nsd) +CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd) !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & - & * taubar +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness & + & * taubar !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = muMasterBar(ips) * OUTERPROD( & + & masterC1(:, ips), i3) & + & + muMasterBar(ips) * OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = muSlaveBar(slaveips) * OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + muSlaveBar(slaveips) * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & - & muSlaveBar, taubar ) +DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, & + & muSlaveBar, taubar) !! END PROCEDURE FacetMatrix1_5 -END SUBMODULE FacetMatrix1Methods \ No newline at end of file +END SUBMODULE FacetMatrix1Methods From 365c93d6bc2b22af8c65edb4ed89e61e0eb13782 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:38:33 +0900 Subject: [PATCH 267/359] update in facet mattrix --- ...acetMatrix_Method@FacetMatrix21Methods.F90 | 118 +++++++++--------- 1 file changed, 59 insertions(+), 59 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 index 275164a2f..7c67006be 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 @@ -26,31 +26,31 @@ MODULE PROCEDURE FacetMatrix21_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :) +INTEGER(I4B) :: ips, nips, nns2, nns1 !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%N, 1) +nns2 = SIZE(elemsd%dNdXt, 1) +nips = SIZE(elemsd%dNdXt, 3) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - ALLOCATE( ans( nns1, nns2 ) ) - ans = 0.0_DFP +ALLOCATE (ans(nns1, nns2)) +ans = 0.0_DFP !! - realval = elemsd%js * elemsd%ws * elemsd%thickness +realval = elemsd%js * elemsd%ws * elemsd%thickness !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips )) - END DO +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips)) +END DO !! - DEALLOCATE( realval, masterC1 ) +DEALLOCATE (realval, masterC1) !! END PROCEDURE FacetMatrix21_1 @@ -60,31 +60,31 @@ MODULE PROCEDURE FacetMatrix21_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :) +INTEGER(I4B) :: ips, nips, nns2, nns1 !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%N, 1) +nns2 = SIZE(elemsd%dNdXt, 1) +nips = SIZE(elemsd%dNdXt, 3) !! - ALLOCATE( ans( nns1, nns2 ) ) - ans = 0.0_DFP +ALLOCATE (ans(nns1, nns2)) +ans = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar +realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips )) - END DO +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips)) +END DO !! - DEALLOCATE( realval, masterC1 ) +DEALLOCATE (realval, masterC1) !! END PROCEDURE FacetMatrix21_2 @@ -94,34 +94,34 @@ MODULE PROCEDURE FacetMatrix21_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), taubar(:) +INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%N, 1) +nns2 = SIZE(elemsd%dNdXt, 1) +nips = SIZE(elemsd%dNdXt, 3) !! - ALLOCATE( ans( nns1, nns2 ) ) - ans = 0.0_DFP +ALLOCATE (ans(nns1, nns2)) +ans = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & masterC1( :, ips )) - END DO +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & masterC1(:, ips)) +END DO !! - DEALLOCATE( realval, masterC1, taubar ) +DEALLOCATE (realval, masterC1, taubar) !! END PROCEDURE FacetMatrix21_3 -END SUBMODULE FacetMatrix21Methods \ No newline at end of file +END SUBMODULE FacetMatrix21Methods From b83f8c6b3c4886aaf9264629a1995ecc96eddc13 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:39:55 +0900 Subject: [PATCH 268/359] update in facet matrix --- ...acetMatrix_Method@FacetMatrix22Methods.F90 | 118 +++++++++--------- 1 file changed, 59 insertions(+), 59 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 index 0f18edd6e..ef4a4f7ee 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 @@ -26,31 +26,31 @@ MODULE PROCEDURE FacetMatrix22_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :) +INTEGER(I4B) :: ips, nips, nns2, nns1 !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%N, 1) +nns2 = SIZE(elemsd%dNdXt, 1) +nips = SIZE(elemsd%dNdXt, 3) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - ALLOCATE( ans( nns2, nns1 ) ) - ans = 0.0_DFP +ALLOCATE (ans(nns2, nns1)) +ans = 0.0_DFP !! - realval = elemsd%js * elemsd%ws * elemsd%thickness +realval = elemsd%js * elemsd%ws * elemsd%thickness !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ), & - & elemsd%N( :, ips )) - END DO +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips), & + & elemsd%N(:, ips)) +END DO !! - DEALLOCATE( realval, masterC1 ) +DEALLOCATE (realval, masterC1) !! END PROCEDURE FacetMatrix22_1 @@ -60,31 +60,31 @@ MODULE PROCEDURE FacetMatrix22_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ) - INTEGER( I4B ) :: ips, nips, nns2, nns1 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :) +INTEGER(I4B) :: ips, nips, nns2, nns1 !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%N, 1) +nns2 = SIZE(elemsd%dNdXt, 1) +nips = SIZE(elemsd%dNdXt, 3) !! - ALLOCATE( ans( nns2, nns1 ) ) - ans = 0.0_DFP +ALLOCATE (ans(nns2, nns1)) +ans = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar +realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ), & - & elemsd%N( :, ips )) - END DO +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips), & + & elemsd%N(:, ips)) +END DO !! - DEALLOCATE( realval, masterC1 ) +DEALLOCATE (realval, masterC1) !! END PROCEDURE FacetMatrix22_2 @@ -94,34 +94,34 @@ MODULE PROCEDURE FacetMatrix22_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), taubar(:) +INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj !! - nns1 = SIZE( elemsd%N, 1 ) - nns2 = SIZE( elemsd%dNdXt, 1 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%N, 1) +nns2 = SIZE(elemsd%dNdXt, 1) +nips = SIZE(elemsd%dNdXt, 3) !! - ALLOCATE( ans( nns2, nns ) ) - ans = 0.0_DFP +ALLOCATE (ans(nns2, nns)) +ans = 0.0_DFP !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar !! - DO ips = 1, nips - ans( :, : ) = ans( :, : ) & - & + realval( ips ) * OUTERPROD( & - & masterC1( :, ips ), & - & elemsd%N( :, ips )) - END DO +DO ips = 1, nips + ans(:, :) = ans(:, :) & + & + realval(ips) * OUTERPROD( & + & masterC1(:, ips), & + & elemsd%N(:, ips)) +END DO !! - DEALLOCATE( realval, masterC1, taubar ) +DEALLOCATE (realval, masterC1, taubar) !! END PROCEDURE FacetMatrix22_3 -END SUBMODULE FacetMatrix22Methods \ No newline at end of file +END SUBMODULE FacetMatrix22Methods From cf9358ba38362ccf5e14518df1f0cefc0f2ffbe7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:39:58 +0900 Subject: [PATCH 269/359] update in facet matrix --- ...FacetMatrix_Method@FacetMatrix2Methods.F90 | 262 +++++++++--------- 1 file changed, 131 insertions(+), 131 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 index 37485f0e5..bf1ab204f 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 @@ -26,47 +26,47 @@ MODULE PROCEDURE FacetMatrix2_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns1, nsd, nsd) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness +realval = elemsd%js * elemsd%ws * elemsd%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, G12, m4 ) +DEALLOCATE (realval, masterC1, G12, m4) !! END PROCEDURE FacetMatrix2_1 @@ -76,45 +76,45 @@ MODULE PROCEDURE FacetMatrix2_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns1, nsd, nsd) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, G12, m4 ) +DEALLOCATE (realval, masterC1, G12, m4) !! END PROCEDURE FacetMatrix2_2 @@ -124,47 +124,47 @@ MODULE PROCEDURE FacetMatrix2_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), taubar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), taubar(:) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu +realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns1, nsd, nsd) !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, G12, taubar, m4 ) +DEALLOCATE (realval, masterC1, G12, taubar, m4) !! END PROCEDURE FacetMatrix2_3 @@ -174,45 +174,45 @@ MODULE PROCEDURE FacetMatrix2_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), muBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), muBar(:) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) +CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) +CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns1, nsd, nsd) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar +realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, G12, muBar, m4 ) +DEALLOCATE (realval, masterC1, G12, muBar, m4) !! END PROCEDURE FacetMatrix2_4 @@ -222,47 +222,47 @@ MODULE PROCEDURE FacetMatrix2_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), muBar( : ), & - & tauBar( : ) - INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), muBar(:), & + & tauBar(:) +INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) !! - CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal ) - CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu ) - CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar ) +CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) +CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) +CALL getInterpolation(obj=elemsd, interpol=tauBar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar +realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns1, nsd, nsd) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns1, nsd, nsd) !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * MATMUL( G12( :, :, ii ), & - & TRANSPOSE( G12( :, :, jj ) ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii), & + & TRANSPOSE(G12(:, :, jj))) !! - END DO - !! END DO - !! + !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, G12, muBar, taubar, m4 ) +DEALLOCATE (realval, masterC1, G12, muBar, taubar, m4) !! END PROCEDURE FacetMatrix2_5 @@ -270,4 +270,4 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE FacetMatrix2Methods \ No newline at end of file +END SUBMODULE FacetMatrix2Methods From ac3c30946f3ee0798ee3b60644580ce765c559e0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:40:04 +0900 Subject: [PATCH 270/359] update in facetmatrix --- ...FacetMatrix_Method@FacetMatrix3Methods.F90 | 392 +++++++++--------- 1 file changed, 196 insertions(+), 196 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 index bc9995afb..9756a37c1 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 @@ -26,55 +26,55 @@ MODULE PROCEDURE FacetMatrix3_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj - !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj + !! +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +nns2 = SIZE(elemsd%N, 1) +i3 = Eye(nsd) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness + !! +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - END DO + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), & + & elemsd%N(:, ips)) END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, i3) !! END PROCEDURE FacetMatrix3_1 @@ -84,55 +84,55 @@ MODULE PROCEDURE FacetMatrix3_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +nns2 = SIZE(elemsd%N, 1) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - END DO + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), & + & elemsd%N(:, ips)) END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12 ) +DEALLOCATE (m4, realval, masterC1, G12) !! END PROCEDURE FacetMatrix3_2 @@ -142,57 +142,57 @@ MODULE PROCEDURE FacetMatrix3_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), taubar(:), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +nns2 = SIZE(elemsd%N, 1) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) - END DO + DO jj = 1, nsd2 + DO ii = 1, nsd1 + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), & + & elemsd%N(:, ips)) END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, taubar, i3) !! END PROCEDURE FacetMatrix3_3 @@ -202,59 +202,59 @@ MODULE PROCEDURE FacetMatrix3_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), mubar(:), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +nns2 = SIZE(elemsd%N, 1) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), & + & elemsd%N(:, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, mubar, i3) !! END PROCEDURE FacetMatrix3_4 @@ -264,61 +264,61 @@ MODULE PROCEDURE FacetMatrix3_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), mubar(:), taubar(:), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj !! - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - nns2 = SIZE( elemsd%N, 1 ) - i3 = Eye( nsd ) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +nns2 = SIZE(elemsd%N, 1) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns1, nns2, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), & - & elemsd%N( :, ips ) ) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), & + & elemsd%N(:, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar ) +DEALLOCATE (m4, realval, masterC1, G12, mubar, taubar) !! END PROCEDURE FacetMatrix3_5 -END SUBMODULE FacetMatrix3Methods \ No newline at end of file +END SUBMODULE FacetMatrix3Methods From 60a326729de908e83a5de679949dd866c0979d01 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:40:08 +0900 Subject: [PATCH 271/359] update in facetmatrix --- ...FacetMatrix_Method@FacetMatrix4Methods.F90 | 392 +++++++++--------- 1 file changed, 196 insertions(+), 196 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 index c685e4619..fa6f400a6 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 @@ -26,57 +26,57 @@ MODULE PROCEDURE FacetMatrix4_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj - !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) - !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) - !! - realval = elemsd%js * elemsd%ws * elemsd%thickness - !! - DO ips = 1, nips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj + !! +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +i3 = Eye(nsd) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) + !! +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) + !! +realval = elemsd%js * elemsd%ws * elemsd%thickness + !! +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips))) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, i3) !! END PROCEDURE FacetMatrix4_1 @@ -86,57 +86,57 @@ MODULE PROCEDURE FacetMatrix4_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips))) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, i3) !! END PROCEDURE FacetMatrix4_2 @@ -146,59 +146,59 @@ MODULE PROCEDURE FacetMatrix4_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), taubar(:), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips))) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, taubar, i3) !! END PROCEDURE FacetMatrix4_3 @@ -208,59 +208,59 @@ MODULE PROCEDURE FacetMatrix4_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : ) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), mubar(:), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2 !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips))) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, mubar, i3) !! END PROCEDURE FacetMatrix4_4 @@ -270,60 +270,60 @@ MODULE PROCEDURE FacetMatrix4_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3(:,:) - INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & G12(:, :, :), m4(:, :, :, :), mubar(:), taubar(:), i3(:, :) +INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj !! - nns2 = SIZE( elemsd%N, 1 ) - nns1 = SIZE( elemsd%dNdXt, 1 ) - nsd = SIZE( elemsd%dNdXt, 2 ) - nips = SIZE( elemsd%dNdXt, 3 ) - i3 = Eye( nsd ) +nns2 = SIZE(elemsd%N, 1) +nns1 = SIZE(elemsd%dNdXt, 1) +nsd = SIZE(elemsd%dNdXt, 2) +nips = SIZE(elemsd%dNdXt, 3) +i3 = Eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - CALL Reallocate(G12, nns1, nsd, nsd) - CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) +CALL Reallocate(G12, nns1, nsd, nsd) +CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) !! - CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=elemsd, & + & cdNdXt=masterC1, & + & val=elemsd%normal) !! - CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) - CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) !! - realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar +realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! - DO ips = 1, nips +DO ips = 1, nips !! - G12 = OUTERPROD( masterC1( :, ips ), i3 ) & - & + OUTERPROD( elemsd%dNdXt( :, :, ips ), & - & elemsd%normal( 1:nsd, ips ) ) + G12 = OUTERPROD(masterC1(:, ips), i3) & + & + OUTERPROD(elemsd%dNdXt(:, :, ips), & + & elemsd%normal(1:nsd, ips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval( ips ) * OUTERPROD( & - & elemsd%N( :, ips ), & - & MATMUL( & - & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ))) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * OUTERPROD( & + & elemsd%N(:, ips), & + & MATMUL( & + & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips))) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar, i3 ) +DEALLOCATE (m4, realval, masterC1, G12, mubar, taubar, i3) !! END PROCEDURE FacetMatrix4_5 @@ -331,4 +331,4 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE FacetMatrix4Methods \ No newline at end of file +END SUBMODULE FacetMatrix4Methods From ebd16c19590a33f406dbb09a8436b3bdc94fa287 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:40:15 +0900 Subject: [PATCH 272/359] update in facetmatrix --- ...FacetMatrix_Method@FacetMatrix5Methods.F90 | 858 +++++++++--------- 1 file changed, 429 insertions(+), 429 deletions(-) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 index ef1f352f7..7d5da6e4f 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 @@ -26,81 +26,81 @@ MODULE PROCEDURE FacetMatrix5_1 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), & + & G12(:, :, :), i3(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 + !! +i3 = eye(nsd) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE ( & + & G12(nns, nsd, nsd), & + & C2(nsd, nns, nips), & + & m4(nns, nns, nsd1, nsd2)) + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) + !! +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) + !! +DO ips = 1, nips !! - END DO + slaveips = quadMap(ips) + C2(:, 1:nns1, ips) = 0.5_DFP * TRANSPOSE(masterElemSD%dNdXt(:, :, ips)) +C2(:, nns1 + 1:, ips) = 0.5_DFP * TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) + !! +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = OUTERPROD( & + & masterC1(:, ips), i3) & + & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) +DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, G12) !! END PROCEDURE FacetMatrix5_1 @@ -110,84 +110,84 @@ MODULE PROCEDURE FacetMatrix5_2 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), & + & G12(:, :, :), i3(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 !! - i3 = eye( nsd ) +i3 = eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) +ALLOCATE ( & + & G12(nns, nsd, nsd), & + & C2(nsd, nns, nips), & + & m4(nns, nns, nsd1, nsd2)) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 +masterC1 = muMaster * masterC1 +slaveC1 = muSlave * slaveC1 !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) + slaveips = quadMap(ips) + C2(:, 1:nns1, ips) = 0.5_DFP * TRANSPOSE(masterElemSD%dNdXt(:, :, ips)) +C2(:, nns1 + 1:, ips) = 0.5_DFP * TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips)) !! - END DO +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = OUTERPROD( & + & masterC1(:, ips), i3) & + & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) +DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, G12) !! END PROCEDURE FacetMatrix5_2 @@ -197,86 +197,86 @@ MODULE PROCEDURE FacetMatrix5_3 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=(0.5_DFP*tauMaster)*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=(0.5_DFP*tauSlave)*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), & + & G12(:, :, :), i3(:, :) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 + !! +i3 = eye(nsd) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE ( & + & G12(nns, nsd, nsd), & + & C2(nsd, nns, nips), & + & m4(nns, nns, nsd1, nsd2)) + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) + !! +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) + !! +masterC1 = muMaster * masterC1 +slaveC1 = muSlave * slaveC1 + !! +DO ips = 1, nips !! - END DO + slaveips = quadMap(ips) + C2(:, 1:nns1, ips) = (0.5_DFP * tauMaster) * TRANSPOSE( & + & masterElemSD%dNdXt(:, :, ips)) + C2(:, nns1 + 1:, ips) = (0.5_DFP * tauSlave) * TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) + !! +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = OUTERPROD( & + & masterC1(:, ips), i3) & + & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 ) +DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, G12) !! END PROCEDURE FacetMatrix5_3 @@ -286,99 +286,99 @@ MODULE PROCEDURE FacetMatrix5_4 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:), muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - DO ips = 1, nips - masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips ) - END DO - !! - DO ips = 1, nips - !! - slaveips = quadMap( ips ) - C2(:,1:nns1,ips)=(0.5_DFP)*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) - C2(:,nns1+1:,ips)=(0.5_DFP)*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) - !! - END DO - !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness - !! - DO ips = 1, nips - !! - slaveips=quadMap(ips) - !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) - !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) - !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), & + & G12(:, :, :), i3(:, :), muMasterBar(:), muSlaveBar(:) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips + !! +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 + !! +i3 = eye(nsd) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE ( & + & G12(nns, nsd, nsd), & + & C2(nsd, nns, nips), & + & m4(nns, nns, nsd1, nsd2)) + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) + !! +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) + !! +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster) + !! +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave) + !! +DO ips = 1, nips + masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips) + slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips) +END DO + !! +DO ips = 1, nips + !! + slaveips = quadMap(ips) + C2(:, 1:nns1, ips) = (0.5_DFP) * TRANSPOSE( & + & masterElemSD%dNdXt(:, :, ips)) + C2(:, nns1 + 1:, ips) = (0.5_DFP) * TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) + !! +END DO + !! +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness + !! +DO ips = 1, nips + !! + slaveips = quadMap(ips) + !! + G12(1:nns1, :, :) = OUTERPROD( & + & masterC1(:, ips), i3) & + & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) + !! + G12(nns1 + 1:, :, :) = OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) + !! + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & - & muMasterBar, muSlaveBar, G12 ) +DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, & + & muMasterBar, muSlaveBar, G12) !! END PROCEDURE FacetMatrix5_4 @@ -388,99 +388,99 @@ MODULE PROCEDURE FacetMatrix5_5 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), & + & G12(:, :, :), i3(:, :), tauMasterBar(:), tauSlaveBar(:) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 !! - i3 = eye( nsd ) +i3 = eye(nsd) !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) +ALLOCATE ( & + & G12(nns, nsd, nsd), & + & C2(nsd, nns, nips), & + & m4(nns, nns, nsd1, nsd2)) !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster) !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave) !! - masterC1 = muMaster * masterC1 - slaveC1 = muSlave * slaveC1 +masterC1 = muMaster * masterC1 +slaveC1 = muSlave * slaveC1 !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips = quadMap( ips ) + slaveips = quadMap(ips) !! - C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) + C2(:, 1:nns1, ips) = (0.5_DFP * tauMasterBar(ips)) * TRANSPOSE( & + & masterElemSD%dNdXt(:, :, ips)) !! - C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) + C2(:, nns1 + 1:, ips) = (0.5_DFP * tauSlaveBar(slaveips)) * TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) !! - END DO +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = OUTERPROD( & + & masterC1(:, ips), i3) & + & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & - & tauMasterBar, tauSlaveBar, G12 ) +DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, & + & tauMasterBar, tauSlaveBar, G12) !! END PROCEDURE FacetMatrix5_5 @@ -490,113 +490,113 @@ MODULE PROCEDURE FacetMatrix5_6 !! - REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), & - & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), & - & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : ), & - & muMasterBar( : ), muSlaveBar( : ) - INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & - & slaveips - !! - nns1 = SIZE( masterElemSD%dNdXt, 1 ) - nsd = SIZE( masterElemSD%dNdXt, 2 ) - nips = SIZE( masterElemSD%dNdXt, 3 ) - nns2 = SIZE( slaveElemSD%dNdXt, 1 ) - nns = nns1 + nns2 - !! - i3 = eye( nsd ) - !! - IF( opt .EQ. 1 ) THEN - nsd1 = nsd - nsd2 = 1 - ELSE - nsd1 = 1 - nsd2 = nsd - END IF - !! - ALLOCATE( & - & G12( nns, nsd, nsd ), & - & C2( nsd, nns, nips ), & - & m4( nns, nns, nsd1, nsd2 )) - !! - CALL getProjectionOfdNdXt( & - & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal ) - !! - CALL getProjectionOfdNdXt( & - & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave ) - !! - CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster ) - !! - CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave ) - !! - DO ips = 1, nips - masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips ) - slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips ) - END DO +REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), & + & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), & + & G12(:, :, :), i3(:, :), tauMasterBar(:), tauSlaveBar(:), & + & muMasterBar(:), muSlaveBar(:) +INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, & + & slaveips !! - DO ips = 1, nips +nns1 = SIZE(masterElemSD%dNdXt, 1) +nsd = SIZE(masterElemSD%dNdXt, 2) +nips = SIZE(masterElemSD%dNdXt, 3) +nns2 = SIZE(slaveElemSD%dNdXt, 1) +nns = nns1 + nns2 + !! +i3 = eye(nsd) + !! +IF (opt .EQ. 1) THEN + nsd1 = nsd + nsd2 = 1 +ELSE + nsd1 = 1 + nsd2 = nsd +END IF + !! +ALLOCATE ( & + & G12(nns, nsd, nsd), & + & C2(nsd, nns, nips), & + & m4(nns, nns, nsd1, nsd2)) + !! +CALL getProjectionOfdNdXt( & + & obj=masterElemsd, & + & cdNdXt=masterC1, & + & val=masterElemsd%normal) + !! +CALL getProjectionOfdNdXt( & + & obj=slaveElemsd, & + & cdNdXt=slaveC1, & + & val=slaveElemsd%normal) + !! +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=muMasterBar, & + & val=muMaster) + !! +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=muSlaveBar, & + & val=muSlave) + !! +CALL getInterpolation( & + & obj=masterElemSD, & + & interpol=tauMasterBar, & + & val=tauMaster) + !! +CALL getInterpolation( & + & obj=slaveElemSD, & + & interpol=tauSlaveBar, & + & val=tauSlave) + !! +DO ips = 1, nips + masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips) + slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips) +END DO + !! +DO ips = 1, nips !! - slaveips = quadMap( ips ) + slaveips = quadMap(ips) !! - C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( & - & masterElemSD%dNdXt(:,:,ips)) + C2(:, 1:nns1, ips) = (0.5_DFP * tauMasterBar(ips)) * TRANSPOSE( & + & masterElemSD%dNdXt(:, :, ips)) !! - C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( & - & slaveElemSD%dNdXt(:, :, slaveips)) + C2(:, nns1 + 1:, ips) = (0.5_DFP * tauSlaveBar(slaveips)) * TRANSPOSE( & + & slaveElemSD%dNdXt(:, :, slaveips)) !! - END DO +END DO !! - realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness +realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness !! - DO ips = 1, nips +DO ips = 1, nips !! - slaveips=quadMap(ips) + slaveips = quadMap(ips) !! - G12( 1:nns1, :, : ) = OUTERPROD( & - & masterC1( :, ips ), i3 ) & - & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), & - & masterElemSD%normal( 1:nsd, ips ) ) + G12(1:nns1, :, :) = OUTERPROD( & + & masterC1(:, ips), i3) & + & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), & + & masterElemSD%normal(1:nsd, ips)) !! - G12( nns1+1:, :, : ) = OUTERPROD( & - & slaveC1( :, slaveips ), i3 ) & - & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), & - & slaveElemSD%normal( 1:nsd, slaveips ) ) + G12(nns1 + 1:, :, :) = OUTERPROD( & + & slaveC1(:, slaveips), i3) & + & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), & + & slaveElemSD%normal(1:nsd, slaveips)) !! - DO jj = 1, nsd2 - DO ii = 1, nsd1 + DO jj = 1, nsd2 + DO ii = 1, nsd1 !! - m4( :, :, ii, jj ) = m4( :, :, ii, jj ) & - & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips)) + m4(:, :, ii, jj) = m4(:, :, ii, jj) & + & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips)) !! - END DO END DO - !! END DO + !! +END DO !! - CALL Convert( from=m4, to=ans ) +CALL Convert(from=m4, to=ans) !! - DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, & - & tauMasterBar, tauSlaveBar, muMasterBar, muSlaveBar, G12 ) +DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, & + & tauMasterBar, tauSlaveBar, muMasterBar, muSlaveBar, G12) !! END PROCEDURE FacetMatrix5_6 -END SUBMODULE FacetMatrix5Methods \ No newline at end of file +END SUBMODULE FacetMatrix5Methods From e00c077efca6305f43a7f2ac2ea55d1d850b85cd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:40:19 +0900 Subject: [PATCH 273/359] update in mass matrix --- src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 880619fef..2a8aaef11 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -292,7 +292,7 @@ END SUBROUTINE MM_2d bcoeff = SQRT(rhoBar * muBar) acoeff = SQRT(rhoBar * (lambdaBar + 2.0_DFP * muBar)) - bcoeff -nsd = trial%refelem%nsd +nsd = trial%nsd eyemat = Eye(nsd, 1.0_DFP) nns = SIZE(test%N, 1) ALLOCATE (m4(nns, nns, nsd, nsd)) From bbf0bb36b595f094112ded4752bbe9c07bb4abee Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:40:31 +0900 Subject: [PATCH 274/359] update in stconvective matrix --- src/submodules/STConvectiveMatrix/src/STCM_11.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_13.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_14.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_15.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_16.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_17.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_3.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_5.inc | 8 ++++---- src/submodules/STConvectiveMatrix/src/STCM_7.inc | 8 ++++---- 9 files changed, 36 insertions(+), 36 deletions(-) diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc index afe947737..1b76e4d6d 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_11.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_11.inc @@ -50,7 +50,7 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -81,7 +81,7 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -150,7 +150,7 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -180,7 +180,7 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_13.inc b/src/submodules/STConvectiveMatrix/src/STCM_13.inc index 6e5dfa2e7..dfe461067 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_13.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_13.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_13a(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -109,7 +109,7 @@ PURE SUBROUTINE STCM_13b(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -173,7 +173,7 @@ PURE SUBROUTINE STCM_13c(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -237,7 +237,7 @@ PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_14.inc b/src/submodules/STConvectiveMatrix/src/STCM_14.inc index 20a7621fe..8e7a0fae7 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_14.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_14.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_14a(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -109,7 +109,7 @@ PURE SUBROUTINE STCM_14b(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -173,7 +173,7 @@ PURE SUBROUTINE STCM_14c(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -237,7 +237,7 @@ PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_15.inc b/src/submodules/STConvectiveMatrix/src/STCM_15.inc index 6b86dda81..07bc3e9c8 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_15.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_15.inc @@ -50,7 +50,7 @@ PURE SUBROUTINE STCM_15a(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -119,7 +119,7 @@ PURE SUBROUTINE STCM_15b(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -188,7 +188,7 @@ PURE SUBROUTINE STCM_15c(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -257,7 +257,7 @@ PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_16.inc b/src/submodules/STConvectiveMatrix/src/STCM_16.inc index 06ac2870a..42d6fde39 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_16.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_16.inc @@ -50,7 +50,7 @@ PURE SUBROUTINE STCM_16a(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -119,7 +119,7 @@ PURE SUBROUTINE STCM_16b(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -188,7 +188,7 @@ PURE SUBROUTINE STCM_16c(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -257,7 +257,7 @@ PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_17.inc b/src/submodules/STConvectiveMatrix/src/STCM_17.inc index 3f52946a9..091bf4901 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_17.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_17.inc @@ -53,7 +53,7 @@ PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -127,7 +127,7 @@ PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -201,7 +201,7 @@ PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & SIZE(vbar, 1), trial(1)%refelem%nsd, & + & SIZE(vbar, 1), trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -274,7 +274,7 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, SIZE(vbar, 1), & + & trial(1)%nsd, SIZE(vbar, 1), & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_3.inc b/src/submodules/STConvectiveMatrix/src/STCM_3.inc index 7ff2ee6e7..dbaf727b9 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_3.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_3.inc @@ -56,7 +56,7 @@ PURE SUBROUTINE STCM_3a(ans, test, trial, term1, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -91,7 +91,7 @@ PURE SUBROUTINE STCM_3a(ans, test, trial, term1, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -167,7 +167,7 @@ PURE SUBROUTINE STCM_3b(ans, test, trial, term1, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -198,7 +198,7 @@ PURE SUBROUTINE STCM_3b(ans, test, trial, term1, & CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_5.inc b/src/submodules/STConvectiveMatrix/src/STCM_5.inc index 6eb81e2d8..0e0019c5c 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_5.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_5.inc @@ -56,7 +56,7 @@ PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -85,7 +85,7 @@ PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -156,7 +156,7 @@ PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -184,7 +184,7 @@ PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_7.inc b/src/submodules/STConvectiveMatrix/src/STCM_7.inc index ac7faec21..949ebea9b 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_7.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_7.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -75,7 +75,7 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -137,7 +137,7 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, 1, & + & trial(1)%nsd, 1, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! @@ -167,7 +167,7 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & 1, trial(1)%refelem%nsd, & + & 1, trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! From 83d2e7750746dd1174c30617b9d795bf012ee316 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 16 Jul 2024 10:40:37 +0900 Subject: [PATCH 275/359] update in stdiffusionmatrix --- .../src/STDiffusionMatrix_Method@Methods.F90 | 434 +++++++++--------- 1 file changed, 217 insertions(+), 217 deletions(-) diff --git a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 index 03386ddca..de726de3e 100644 --- a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 @@ -46,14 +46,14 @@ PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & + & trial(1)%nsd, & + & trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! CALL getInterpolation(obj=trial, interpol=kbar, val=k) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! @@ -112,14 +112,14 @@ PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & + & trial(1)%nsd, & + & trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! CALL getInterpolation(obj=trial, interpol=kbar, val=k) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! @@ -195,7 +195,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! @@ -210,7 +210,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) DO b = 1, SIZE(IJab, 4) DO a = 1, SIZE(IJab, 3) !! - IJab(:,:,a,b) = IJab(:,:,a,b) & + IJab(:, :, a, b) = IJab(:, :, a, b) & & + OUTERPROD( & & test(ipt)%dNTdXt(:, a, ii, ips), & & trial(ipt)%dNTdXt(:, b, ii, ips)) @@ -220,15 +220,15 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) END DO !! DO ii = 1, SIZE(m6, 3) - m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & + m6(:, :, ii, 1, :, :) = m6(:, :, ii, 1, :, :) & + & + realval(ips) * vbar(ii, ips, ipt) & & * IJab END DO !! END DO END DO !! - CALL Convert( from=m6, to=ans) + CALL Convert(from=m6, to=ans) !! DEALLOCATE (realval, IJab, vbar, m6) !! @@ -277,7 +277,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! @@ -292,7 +292,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) DO b = 1, SIZE(IJab, 4) DO a = 1, SIZE(IJab, 3) !! - IJab(:,:,a,b) = IJab(:,:,a,b) & + IJab(:, :, a, b) = IJab(:, :, a, b) & & + OUTERPROD( & & test(ipt)%dNTdXt(:, a, ii, ips), & & trial(ipt)%dNTdXt(:, b, ii, ips)) @@ -302,8 +302,8 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) END DO !! DO ii = 1, SIZE(m6, 4) - m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & + m6(:, :, 1, ii, :, :) = m6(:, :, 1, ii, :, :) & + & + realval(ips) * vbar(ii, ips, ipt) & & * IJab END DO !! @@ -311,7 +311,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) !! END DO !! - CALL Convert( from=m6, to=ans) + CALL Convert(from=m6, to=ans) !! DEALLOCATE (realval, IJab, vbar, m6) !! @@ -346,15 +346,15 @@ PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & + & trial(1)%nsd, & + & trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! @@ -416,20 +416,20 @@ PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt) CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & & SIZE(trial(1)%N, 1), & - & trial(1)%refelem%nsd, & - & trial(1)%refelem%nsd, & + & trial(1)%nsd, & + & trial(1)%nsd, & & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:,ipt) + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:, ipt) !! DO ips = 1, SIZE(realval) !! @@ -504,7 +504,7 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! @@ -519,7 +519,7 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) DO b = 1, SIZE(IJab, 4) DO a = 1, SIZE(IJab, 3) !! - IJab(:,:,a,b) = IJab(:,:,a,b) & + IJab(:, :, a, b) = IJab(:, :, a, b) & & + OUTERPROD( & & test(ipt)%dNTdXt(:, a, ii, ips), & & trial(ipt)%dNTdXt(:, b, ii, ips)) @@ -529,15 +529,15 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) END DO !! DO ii = 1, SIZE(m6, 3) - m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & + m6(:, :, ii, 1, :, :) = m6(:, :, ii, 1, :, :) & + & + realval(ips) * vbar(ii, ips, ipt) & & * IJab END DO !! END DO END DO !! - CALL Convert( from=m6, to=ans) + CALL Convert(from=m6, to=ans) !! DEALLOCATE (realval, IJab, vbar, m6, cbar) !! @@ -590,12 +590,12 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - nsd = trial(1)%refelem%nsd + nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * cbar(:,ipt) + & * trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt) !! DO ips = 1, SIZE(realval) !! @@ -605,7 +605,7 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) DO b = 1, SIZE(IJab, 4) DO a = 1, SIZE(IJab, 3) !! - IJab(:,:,a,b) = IJab(:,:,a,b) & + IJab(:, :, a, b) = IJab(:, :, a, b) & & + OUTERPROD( & & test(ipt)%dNTdXt(:, a, ii, ips), & & trial(ipt)%dNTdXt(:, b, ii, ips)) @@ -615,8 +615,8 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) END DO !! DO ii = 1, SIZE(m6, 4) - m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) & - & + realval( ips ) * vbar(ii, ips, ipt) & + m6(:, :, 1, ii, :, :) = m6(:, :, 1, ii, :, :) & + & + realval(ips) * vbar(ii, ips, ipt) & & * IJab END DO !! @@ -624,7 +624,7 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) !! END DO !! - CALL Convert( from=m6, to=ans) + CALL Convert(from=m6, to=ans) !! DEALLOCATE (realval, IJab, vbar, m6) !! @@ -672,7 +672,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) -nsd = trial(1)%refelem%nsd +nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & @@ -688,7 +688,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) !! -if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! DEALLOCATE (realval, iajb) END PROCEDURE mat4_STDiffusionMatrix_1 @@ -698,42 +698,42 @@ END SUBROUTINE MakeDiagonalCopiesIJab !---------------------------------------------------------------------------- MODULE PROCEDURE mat4_STDiffusionMatrix_2 - ! CALL STDM_1(ans=ans, test=test, trial=trial, k=k, opt=opt) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd +! CALL STDM_1(ans=ans, test=test, trial=trial, k=k, opt=opt) +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :) +INTEGER(I4B) :: ips, ipt, ii, nsd !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) +CALL getInterpolation(obj=trial, interpol=kbar, val=k) !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - nsd = trial(1)%refelem%nsd +nsd = trial(1)%nsd !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt) !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - DO ii = 1, nsd + DO ii = 1, nsd !! - iajb = iajb + realval(ips) & - & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& - & trial(ipt)%dNTdXt(:, :, ii, ips)) + iajb = iajb + realval(ips) & + & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& + & trial(ipt)%dNTdXt(:, :, ii, ips)) !! - END DO END DO END DO +END DO !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, iajb, kbar) +DEALLOCATE (realval, iajb, kbar) END PROCEDURE mat4_STDiffusionMatrix_2 !---------------------------------------------------------------------------- @@ -741,39 +741,39 @@ END SUBROUTINE MakeDiagonalCopiesIJab !---------------------------------------------------------------------------- MODULE PROCEDURE mat4_STDiffusionMatrix_3 - ! CALL STDM_2(ans=ans, test=test, trial=trial, k=k, opt=opt) +! CALL STDM_2(ans=ans, test=test, trial=trial, k=k, opt=opt) !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :) +REAL(DFP), ALLOCATABLE :: p2(:, :, :) +INTEGER(I4B) :: ips, ipt !! !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=k) + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=k) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k) !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) !! - END DO END DO +END DO !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, iajb, p1, p2) +DEALLOCATE (realval, iajb, p1, p2) END PROCEDURE mat4_STDiffusionMatrix_3 !---------------------------------------------------------------------------- @@ -781,44 +781,44 @@ END SUBROUTINE MakeDiagonalCopiesIJab !---------------------------------------------------------------------------- MODULE PROCEDURE mat4_STDiffusionMatrix_4 - ! CALL STDM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd +! CALL STDM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +INTEGER(I4B) :: ips, ipt, ii, jj, nsd !! !! main - CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) +CALL getInterpolation(obj=trial, interpol=kbar, val=k) !! - nsd = trial(1)%refelem%nsd +nsd = trial(1)%nsd !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) + IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) !! - END DO END DO END DO END DO +END DO !! - CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, KBar, IaJb) +DEALLOCATE (realval, KBar, IaJb) END PROCEDURE mat4_STDiffusionMatrix_4 !---------------------------------------------------------------------------- @@ -830,48 +830,48 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! scalar !! scalar !! - ! CALL STDM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) +! CALL STDM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) !! !! !! Internal variable !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: c1bar(:, :) - REAL(DFP), ALLOCATABLE :: c2bar(:, :) - INTEGER(I4B) :: ips, ipt, ii, nsd +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +INTEGER(I4B) :: ips, ipt, ii, nsd !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - nsd = trial(1)%refelem%nsd +nsd = trial(1)%nsd !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & - & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt) + realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness & + & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt) !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - DO ii = 1, nsd + DO ii = 1, nsd !! - iajb = iajb + realval(ips) & - & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& - & trial(ipt)%dNTdXt(:, :, ii, ips)) + iajb = iajb + realval(ips) & + & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),& + & trial(ipt)%dNTdXt(:, :, ii, ips)) !! - END DO END DO END DO +END DO !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, iajb, c1bar, c2bar) +DEALLOCATE (realval, iajb, c1bar, c2bar) END PROCEDURE mat4_STDiffusionMatrix_5 !---------------------------------------------------------------------------- @@ -883,40 +883,40 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! scalar !! vector !! - ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) +! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) !! !! Internal variable !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: c1bar(:,:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: c1bar(:, :) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :) +REAL(DFP), ALLOCATABLE :: p2(:, :, :) +INTEGER(I4B) :: ips, ipt !! !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt) - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) !! - END DO END DO +END DO !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, c1bar, iajb, p1, p2) +DEALLOCATE (realval, c1bar, iajb, p1, p2) !! END PROCEDURE mat4_STDiffusionMatrix_6 @@ -929,49 +929,49 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! scalar !! matrix !! - ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) +! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) !! !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: rhobar(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: rhobar(:, :) +REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :) +INTEGER(I4B) :: ips, ipt, ii, jj, nsd !! !! main !! - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=rhobar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +CALL getInterpolation(obj=trial, interpol=rhobar, val=c1) +CALL getInterpolation(obj=trial, interpol=kbar, val=c2) !! - nsd = trial(1)%refelem%nsd +nsd = trial(1)%nsd !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) + iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) !! - END DO END DO END DO END DO +END DO !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, iajb, rhobar, kbar) +DEALLOCATE (realval, iajb, rhobar, kbar) END PROCEDURE mat4_STDiffusionMatrix_7 !---------------------------------------------------------------------------- @@ -983,10 +983,10 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! vector !! scalar !! - ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) +! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) !! - ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & - & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableVector, opt=opt ) +ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & + & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableVector, opt=opt) END PROCEDURE mat4_STDiffusionMatrix_8 !---------------------------------------------------------------------------- @@ -998,38 +998,38 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! vector !! vector !! - ! CALL STDM_4(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) +! CALL STDM_4(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) !! !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: p1(:, :, :) - REAL(DFP), ALLOCATABLE :: p2(:, :, :) - INTEGER(I4B) :: ips, ipt +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: p1(:, :, :) +REAL(DFP), ALLOCATABLE :: p2(:, :, :) +INTEGER(I4B) :: ips, ipt !! !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt + CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) + iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips)) !! - END DO END DO +END DO !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, iajb, p1, p2) +DEALLOCATE (realval, iajb, p1, p2) END PROCEDURE mat4_STDiffusionMatrix_9 !---------------------------------------------------------------------------- @@ -1054,10 +1054,10 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! matrix !! scalar !! - ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) +! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt) !! - ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & - & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableMatrix, opt=opt) +ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, & + & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableMatrix, opt=opt) !! END PROCEDURE mat4_STDiffusionMatrix_11 @@ -1083,49 +1083,49 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! matrix !! matrix !! - ! CALL STDM_8(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) +! CALL STDM_8(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) !! !! Internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) - REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :) - REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :) - INTEGER(I4B) :: ips, ipt, ii, jj, nsd +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: m2(:, :) +REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :) +REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :) +REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :) +INTEGER(I4B) :: ips, ipt, ii, jj, nsd !! !! main - CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & - & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) - nsd = trial(1)%refelem%nsd +CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & + & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) +CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) +CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) +nsd = trial(1)%nsd !! - DO ipt = 1, SIZE(trial) +DO ipt = 1, SIZE(trial) !! - realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & - & * trial(ipt)%wt * trial(ipt)%jt + realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & + & * trial(ipt)%wt * trial(ipt)%jt !! - DO ips = 1, SIZE(realval) + DO ips = 1, SIZE(realval) !! - m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt)) + m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt)) !! - DO jj = 1, nsd + DO jj = 1, nsd !! - DO ii = 1, nsd + DO ii = 1, nsd !! - iajb = iajb + realval(ips) * m2(ii, jj) * & - & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & - & trial(ipt)%dNTdXt(:, :, jj, ips)) + iajb = iajb + realval(ips) * m2(ii, jj) * & + & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), & + & trial(ipt)%dNTdXt(:, :, jj, ips)) !! - END DO END DO END DO END DO +END DO !! - CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) - if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt) +CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4) +IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt) !! - DEALLOCATE (realval, m2, iajb, k1bar, k2bar) +DEALLOCATE (realval, m2, iajb, k1bar, k2bar) !! END PROCEDURE mat4_STDiffusionMatrix_13 From 14c11a7d3da32442a1d087d0141e9e2c0307d055 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 20 Jul 2024 13:45:17 +0900 Subject: [PATCH 276/359] updates in intvector --- src/modules/IntVector/src/IntVector_ConstructorMethod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 index 37c0ded01..cd3af48cd 100644 --- a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 +++ b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 @@ -17,12 +17,12 @@ MODULE IntVector_ConstructorMethod USE BaseType, ONLY: IntVector_ USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, & -& REAL64, REAL32 + REAL64, REAL32 PRIVATE PUBLIC :: Shape PUBLIC :: SIZE -PUBLIC :: getTotalDimension +PUBLIC :: GetTotalDimension PUBLIC :: ALLOCATE PUBLIC :: DEALLOCATE PUBLIC :: Reallocate From 28a66dddbcd89514bc6fb23880f9a973849a07a6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 20 Jul 2024 13:45:25 +0900 Subject: [PATCH 277/359] updates in intvector get methods --- .../IntVector/src/IntVector_GetMethod.F90 | 241 +++++++++--------- 1 file changed, 121 insertions(+), 120 deletions(-) diff --git a/src/modules/IntVector/src/IntVector_GetMethod.F90 b/src/modules/IntVector/src/IntVector_GetMethod.F90 index f04c4768c..866b6248a 100644 --- a/src/modules/IntVector/src/IntVector_GetMethod.F90 +++ b/src/modules/IntVector/src/IntVector_GetMethod.F90 @@ -18,6 +18,7 @@ MODULE IntVector_GetMethod USE GlobalData, ONLY: DFP, I4B, LGT, INT8, INT16, INT32, INT64 USE BaseType, ONLY: IntVector_ + PRIVATE PUBLIC :: GET @@ -34,10 +35,10 @@ MODULE IntVector_GetMethod ! summary: Returns IntVector instance INTERFACE Get - MODULE PURE FUNCTION intVec_get_1(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_1(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_) :: Val + TYPE(IntVector_), INTENT(IN) :: datatype + TYPE(IntVector_) :: val END FUNCTION intVec_get_1 END INTERFACE Get @@ -51,12 +52,12 @@ END FUNCTION intVec_get_1 ! summary: Returns an instance of [[intvector_]], obj(indx) INTERFACE Get - MODULE PURE FUNCTION intVec_get_2(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_2(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj - TYPE(IntVector_), INTENT(IN) :: DataType + TYPE(IntVector_), INTENT(IN) :: datatype INTEGER(I4B), INTENT(IN) :: Indx(:) - TYPE(IntVector_) :: Val + TYPE(IntVector_) :: val END FUNCTION intVec_get_2 END INTERFACE Get @@ -71,16 +72,16 @@ END FUNCTION intVec_get_2 INTERFACE Get MODULE PURE FUNCTION intVec_get_3(obj, istart, iend, & - & stride, DataType) RESULT(Val) + & stride, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj - TYPE(IntVector_), INTENT(IN) :: DataType + TYPE(IntVector_), INTENT(IN) :: datatype !! an instance of [[IntVector_]] INTEGER(I4B), INTENT(IN) :: istart !! starting index value INTEGER(I4B), OPTIONAL, INTENT(IN) :: iend, stride !! iend is optional, default value is size(obj) !! stride is optional, default value is 1. - TYPE(IntVector_) :: Val + TYPE(IntVector_) :: val !! returned value END FUNCTION intVec_get_3 END INTERFACE Get @@ -105,10 +106,10 @@ END FUNCTION intVec_get_3 ! The size of val is size(obj(1)) + size(obj(2)) + ... INTERFACE Get - MODULE PURE FUNCTION intVec_get_4(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_4(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_) :: Val + TYPE(IntVector_), INTENT(IN) :: datatype + TYPE(IntVector_) :: val END FUNCTION intVec_get_4 END INTERFACE Get @@ -122,12 +123,12 @@ END FUNCTION intVec_get_4 ! summary: Serialized the vector of [[IntVector_]], select values by indx INTERFACE Get - MODULE PURE FUNCTION intVec_get_5(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_5(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - TYPE(IntVector_), INTENT(IN) :: DataType + TYPE(IntVector_), INTENT(IN) :: datatype INTEGER(I4B), INTENT(IN) :: Indx(:) - TYPE(IntVector_) :: Val + TYPE(IntVector_) :: val END FUNCTION intVec_get_5 END INTERFACE Get @@ -137,11 +138,11 @@ END FUNCTION intVec_get_5 INTERFACE Get MODULE PURE FUNCTION intVec_get_6(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) + & Stride, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_) :: Val + TYPE(IntVector_), INTENT(IN) :: datatype + TYPE(IntVector_) :: val END FUNCTION intVec_get_6 END INTERFACE Get @@ -150,25 +151,25 @@ END FUNCTION intVec_get_6 !---------------------------------------------------------------------------- INTERFACE Get - MODULE PURE FUNCTION intVec_get_7a(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_7a(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8), ALLOCATABLE :: val(:) END FUNCTION intVec_get_7a - MODULE PURE FUNCTION intVec_get_7b(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_7b(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16), ALLOCATABLE :: val(:) END FUNCTION intVec_get_7b - MODULE PURE FUNCTION intVec_get_7c(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_7c(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32), ALLOCATABLE :: val(:) END FUNCTION intVec_get_7c - MODULE PURE FUNCTION intVec_get_7d(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_7d(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64), ALLOCATABLE :: val(:) END FUNCTION intVec_get_7d END INTERFACE Get @@ -177,33 +178,33 @@ END FUNCTION intVec_get_7d !---------------------------------------------------------------------------- INTERFACE Get - MODULE PURE FUNCTION intVec_get_8a(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_8a(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8), ALLOCATABLE :: val(:) END FUNCTION intVec_get_8a - MODULE PURE FUNCTION intVec_get_8b(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_8b(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16), ALLOCATABLE :: val(:) END FUNCTION intVec_get_8b - MODULE PURE FUNCTION intVec_get_8c(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_8c(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32), ALLOCATABLE :: val(:) END FUNCTION intVec_get_8c - MODULE PURE FUNCTION intVec_get_8d(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_8d(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64), ALLOCATABLE :: val(:) END FUNCTION intVec_get_8d END INTERFACE Get @@ -213,32 +214,32 @@ END FUNCTION intVec_get_8d INTERFACE Get MODULE PURE FUNCTION intVec_get_9a(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) + & datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8), ALLOCATABLE :: val(:) END FUNCTION intVec_get_9a MODULE PURE FUNCTION intVec_get_9b(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) + & datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16), ALLOCATABLE :: val(:) END FUNCTION intVec_get_9b MODULE PURE FUNCTION intVec_get_9c(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) + & datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32), ALLOCATABLE :: val(:) END FUNCTION intVec_get_9c MODULE PURE FUNCTION intVec_get_9d(obj, iStart, iEnd, Stride,& - & DataType) RESULT(Val) + & datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64), ALLOCATABLE :: val(:) END FUNCTION intVec_get_9d END INTERFACE Get @@ -247,25 +248,25 @@ END FUNCTION intVec_get_9d !---------------------------------------------------------------------------- INTERFACE Get - MODULE PURE FUNCTION intVec_get_10a(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_10a(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8), ALLOCATABLE :: val(:) END FUNCTION intVec_get_10a - MODULE PURE FUNCTION intVec_get_10b(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_10b(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16), ALLOCATABLE :: val(:) END FUNCTION intVec_get_10b - MODULE PURE FUNCTION intVec_get_10c(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_10c(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32), ALLOCATABLE :: val(:) END FUNCTION intVec_get_10c - MODULE PURE FUNCTION intVec_get_10d(obj, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_10d(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64), ALLOCATABLE :: val(:) END FUNCTION intVec_get_10d END INTERFACE Get @@ -274,33 +275,33 @@ END FUNCTION intVec_get_10d !---------------------------------------------------------------------------- INTERFACE Get - MODULE PURE FUNCTION intVec_get_11a(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_11a(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8), INTENT(IN) :: datatype INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT8), ALLOCATABLE :: Val(:) + INTEGER(INT8), ALLOCATABLE :: val(:) END FUNCTION intVec_get_11a - MODULE PURE FUNCTION intVec_get_11b(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_11b(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16), INTENT(IN) :: datatype INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT16), ALLOCATABLE :: Val(:) + INTEGER(INT16), ALLOCATABLE :: val(:) END FUNCTION intVec_get_11b - MODULE PURE FUNCTION intVec_get_11c(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_11c(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32), INTENT(IN) :: datatype INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT32), ALLOCATABLE :: Val(:) + INTEGER(INT32), ALLOCATABLE :: val(:) END FUNCTION intVec_get_11c - MODULE PURE FUNCTION intVec_get_11d(obj, Indx, DataType) & - & RESULT(Val) + MODULE PURE FUNCTION intVec_get_11d(obj, Indx, datatype) & + & RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) - INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64), INTENT(IN) :: datatype INTEGER(I4B), INTENT(IN) :: Indx(:) - INTEGER(INT64), ALLOCATABLE :: Val(:) + INTEGER(INT64), ALLOCATABLE :: val(:) END FUNCTION intVec_get_11d END INTERFACE Get @@ -310,32 +311,32 @@ END FUNCTION intVec_get_11d INTERFACE Get MODULE PURE FUNCTION intVec_get_12a(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) + & Stride, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT8), INTENT(IN) :: DataType - INTEGER(INT8), ALLOCATABLE :: Val(:) + INTEGER(INT8), INTENT(IN) :: datatype + INTEGER(INT8), ALLOCATABLE :: val(:) END FUNCTION intVec_get_12a MODULE PURE FUNCTION intVec_get_12b(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) + & Stride, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT16), INTENT(IN) :: DataType - INTEGER(INT16), ALLOCATABLE :: Val(:) + INTEGER(INT16), INTENT(IN) :: datatype + INTEGER(INT16), ALLOCATABLE :: val(:) END FUNCTION intVec_get_12b MODULE PURE FUNCTION intVec_get_12c(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) + & Stride, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT32), INTENT(IN) :: DataType - INTEGER(INT32), ALLOCATABLE :: Val(:) + INTEGER(INT32), INTENT(IN) :: datatype + INTEGER(INT32), ALLOCATABLE :: val(:) END FUNCTION intVec_get_12c MODULE PURE FUNCTION intVec_get_12d(obj, iStart, iEnd, & - & Stride, DataType) RESULT(Val) + & Stride, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj(:) INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride - INTEGER(INT64), INTENT(IN) :: DataType - INTEGER(INT64), ALLOCATABLE :: Val(:) + INTEGER(INT64), INTENT(IN) :: datatype + INTEGER(INT64), ALLOCATABLE :: val(:) END FUNCTION intVec_get_12d END INTERFACE Get @@ -344,28 +345,28 @@ END FUNCTION intVec_get_12d !---------------------------------------------------------------------------- INTERFACE Get - MODULE PURE FUNCTION intVec_get_13a(obj, indx, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_13a(obj, indx, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT8), INTENT(IN) :: DataType + INTEGER(INT8), INTENT(IN) :: datatype INTEGER(INT8) :: val END FUNCTION intVec_get_13a - MODULE PURE FUNCTION intVec_get_13b(obj, indx, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_13b(obj, indx, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT16), INTENT(IN) :: DataType + INTEGER(INT16), INTENT(IN) :: datatype INTEGER(INT16) :: val END FUNCTION intVec_get_13b - MODULE PURE FUNCTION intVec_get_13c(obj, indx, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_13c(obj, indx, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT32), INTENT(IN) :: DataType + INTEGER(INT32), INTENT(IN) :: datatype INTEGER(INT32) :: val END FUNCTION intVec_get_13c - MODULE PURE FUNCTION intVec_get_13d(obj, indx, DataType) RESULT(Val) + MODULE PURE FUNCTION intVec_get_13d(obj, indx, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx - INTEGER(INT64), INTENT(IN) :: DataType + INTEGER(INT64), INTENT(IN) :: datatype INTEGER(INT64) :: val END FUNCTION intVec_get_13d END INTERFACE Get @@ -375,10 +376,10 @@ END FUNCTION intVec_get_13d !---------------------------------------------------------------------------- INTERFACE GetPointer - MODULE FUNCTION intVec_getPointer_1(obj, DataType) RESULT(Val) + MODULE FUNCTION intVec_getPointer_1(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN), TARGET :: obj - TYPE(IntVector_), INTENT(IN) :: DataType - TYPE(IntVector_), POINTER :: Val + TYPE(IntVector_), INTENT(IN) :: datatype + TYPE(IntVector_), POINTER :: val END FUNCTION intVec_getPointer_1 END INTERFACE GetPointer @@ -387,10 +388,10 @@ END FUNCTION intVec_getPointer_1 !---------------------------------------------------------------------------- INTERFACE GetPointer - MODULE FUNCTION intVec_getPointer_2(obj, DataType) RESULT(Val) + MODULE FUNCTION intVec_getPointer_2(obj, datatype) RESULT(val) CLASS(IntVector_), INTENT(IN), TARGET :: obj - INTEGER(I4B), INTENT(IN) :: DataType - INTEGER(I4B), POINTER :: Val(:) + INTEGER(I4B), INTENT(IN) :: datatype + INTEGER(I4B), POINTER :: val(:) END FUNCTION intVec_getPointer_2 END INTERFACE GetPointer @@ -399,10 +400,10 @@ END FUNCTION intVec_getPointer_2 !---------------------------------------------------------------------------- INTERFACE GetIndex - MODULE PURE FUNCTION intVec_getIndex1(obj, Val) RESULT(Ans) + MODULE PURE FUNCTION intVec_getIndex1(obj, val) RESULT(ans) CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Val - INTEGER(I4B) :: Ans + INTEGER(I4B), INTENT(IN) :: val + INTEGER(I4B) :: ans END FUNCTION intVec_getIndex1 END INTERFACE GetIndex @@ -411,10 +412,10 @@ END FUNCTION intVec_getIndex1 !---------------------------------------------------------------------------- INTERFACE GetIndex - MODULE PURE FUNCTION intVec_getIndex2(obj, Val) RESULT(Ans) + MODULE PURE FUNCTION intVec_getIndex2(obj, val) RESULT(ans) CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: Val(:) - INTEGER(I4B), ALLOCATABLE :: Ans(:) + INTEGER(I4B), INTENT(IN) :: val(:) + INTEGER(I4B), ALLOCATABLE :: ans(:) END FUNCTION intVec_getIndex2 END INTERFACE GetIndex From 0eb08a4ecabe811998f32c9282e7bfcefacc1afe Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 20 Jul 2024 13:45:32 +0900 Subject: [PATCH 278/359] update in intvector getmethods --- .../src/IntVector_GetMethod@Methods.F90 | 90 +++++++++---------- 1 file changed, 45 insertions(+), 45 deletions(-) diff --git a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 index 48e791fee..cab95a6a9 100644 --- a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 +++ b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 @@ -30,8 +30,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_1 -IF (ALLOCATED(obj%Val)) THEN - Val = IntVector(obj%Val) +IF (ALLOCATED(obj%val)) THEN + val = IntVector(obj%val) END IF END PROCEDURE intVec_get_1 @@ -40,8 +40,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_2 -IF (ALLOCATED(obj%Val)) THEN - Val = IntVector(obj%Val(Indx)) +IF (ALLOCATED(obj%val)) THEN + val = IntVector(obj%val(Indx)) END IF END PROCEDURE intVec_get_2 @@ -50,8 +50,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_3 -IF (ALLOCATED(obj%Val)) THEN - Val = IntVector(obj%Val( & +IF (ALLOCATED(obj%val)) THEN + val = IntVector(obj%val( & & istart:& & Input(default=SIZE(obj), option=iend):& & Input(option=stride, default=1))) @@ -63,7 +63,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_4 -Val = IntVector(get(obj, TypeInt)) +val = IntVector(get(obj, TypeInt)) END PROCEDURE intVec_get_4 !---------------------------------------------------------------------------- @@ -71,7 +71,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_5 -Val = IntVector(get(obj, Indx, TypeInt)) +val = IntVector(get(obj, Indx, TypeInt)) END PROCEDURE intVec_get_5 !---------------------------------------------------------------------------- @@ -79,7 +79,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_6 -Val = IntVector(get(obj, iStart, iEnd, Stride, & +val = IntVector(get(obj, iStart, iEnd, Stride, & & TypeInt)) END PROCEDURE intVec_get_6 @@ -88,23 +88,23 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_7a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val +IF (ALLOCATED(obj%val)) THEN + val = obj%val END IF END PROCEDURE intVec_get_7a MODULE PROCEDURE intVec_get_7b -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val +IF (ALLOCATED(obj%val)) THEN + val = obj%val END IF END PROCEDURE intVec_get_7b MODULE PROCEDURE intVec_get_7c -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val +IF (ALLOCATED(obj%val)) THEN + val = obj%val END IF END PROCEDURE intVec_get_7c MODULE PROCEDURE intVec_get_7d -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val +IF (ALLOCATED(obj%val)) THEN + val = obj%val END IF END PROCEDURE intVec_get_7d @@ -113,26 +113,26 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_8a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(Indx) END IF END PROCEDURE intVec_get_8a MODULE PROCEDURE intVec_get_8b -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(Indx) END IF END PROCEDURE intVec_get_8b MODULE PROCEDURE intVec_get_8c -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(Indx) END IF END PROCEDURE intVec_get_8c MODULE PROCEDURE intVec_get_8d -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(Indx) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(Indx) END IF END PROCEDURE intVec_get_8d @@ -141,26 +141,26 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_get_9a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(iStart:iEnd:Stride) END IF END PROCEDURE intVec_get_9a MODULE PROCEDURE intVec_get_9b -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(iStart:iEnd:Stride) END IF END PROCEDURE intVec_get_9b MODULE PROCEDURE intVec_get_9c -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(iStart:iEnd:Stride) END IF END PROCEDURE intVec_get_9c MODULE PROCEDURE intVec_get_9d -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val(iStart:iEnd:Stride) +IF (ALLOCATED(obj%val)) THEN + val = obj%val(iStart:iEnd:Stride) END IF END PROCEDURE intVec_get_9d @@ -237,7 +237,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_getPointer_1 -Val => obj +val => obj END PROCEDURE intVec_getPointer_1 !---------------------------------------------------------------------------- @@ -245,7 +245,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_getPointer_2 -Val => obj%Val +val => obj%val END PROCEDURE intVec_getPointer_2 !---------------------------------------------------------------------------- @@ -253,7 +253,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_getIndex1 -Ans = MINLOC(ABS(obj%Val - val), 1) +ans = MINLOC(ABS(obj%val - val), 1) END PROCEDURE intVec_getIndex1 !---------------------------------------------------------------------------- @@ -262,19 +262,19 @@ MODULE PROCEDURE intVec_getIndex2 INTEGER(I4B) :: i, j, m -LOGICAL(LGT), ALLOCATABLE :: Search(:) +LOGICAL(LGT), ALLOCATABLE :: search(:) ! m = SIZE(val) -ALLOCATE (Search(m), Ans(m)) -Search = .TRUE. -Ans = 0 +ALLOCATE (search(m), ans(m)) +search = .TRUE. +ans = 0 -DO i = 1, SIZE(obj%Val) +DO i = 1, SIZE(obj%val) DO j = 1, m - IF (Search(j)) THEN - IF (val(j) .EQ. obj%Val(i)) THEN - Search(j) = .FALSE. - Ans(j) = i + IF (search(j)) THEN + IF (val(j) .EQ. obj%val(i)) THEN + search(j) = .FALSE. + ans(j) = i END IF END IF END DO From 85f03b6ef07451adfe2f86f0bd69ed4d7ce902df Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 20 Jul 2024 13:45:40 +0900 Subject: [PATCH 279/359] update in integer utility --- .../Utility/src/In/{In_1.inc => In_1.F90} | 1 - .../Utility/src/In/{IsIn_1.inc => IsIn_1.F90} | 0 .../Utility/src/IntegerUtility@Methods.F90 | 16 ++++++++-------- 3 files changed, 8 insertions(+), 9 deletions(-) rename src/submodules/Utility/src/In/{In_1.inc => In_1.F90} (99%) rename src/submodules/Utility/src/In/{IsIn_1.inc => IsIn_1.F90} (100%) diff --git a/src/submodules/Utility/src/In/In_1.inc b/src/submodules/Utility/src/In/In_1.F90 similarity index 99% rename from src/submodules/Utility/src/In/In_1.inc rename to src/submodules/Utility/src/In/In_1.F90 index 1bbf7c7cf..66065b8a6 100644 --- a/src/submodules/Utility/src/In/In_1.inc +++ b/src/submodules/Utility/src/In/In_1.F90 @@ -15,7 +15,6 @@ ! along with this program. If not, see ! - INTEGER(I4B) :: ii ans = .TRUE. diff --git a/src/submodules/Utility/src/In/IsIn_1.inc b/src/submodules/Utility/src/In/IsIn_1.F90 similarity index 100% rename from src/submodules/Utility/src/In/IsIn_1.inc rename to src/submodules/Utility/src/In/IsIn_1.F90 diff --git a/src/submodules/Utility/src/IntegerUtility@Methods.F90 b/src/submodules/Utility/src/IntegerUtility@Methods.F90 index df2ecb24c..295fd8e6e 100644 --- a/src/submodules/Utility/src/IntegerUtility@Methods.F90 +++ b/src/submodules/Utility/src/IntegerUtility@Methods.F90 @@ -131,19 +131,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE in_1a -#include "./In/In_1.inc" +#include "./In/In_1.F90" END PROCEDURE in_1a MODULE PROCEDURE in_1b -#include "./In/In_1.inc" +#include "./In/In_1.F90" END PROCEDURE in_1b MODULE PROCEDURE in_1c -#include "./In/In_1.inc" +#include "./In/In_1.F90" END PROCEDURE in_1c MODULE PROCEDURE in_1d -#include "./In/In_1.inc" +#include "./In/In_1.F90" END PROCEDURE in_1d !---------------------------------------------------------------------------- @@ -151,19 +151,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE IsIn_1a -#include "./In/IsIn_1.inc" +#include "./In/IsIn_1.F90" END PROCEDURE IsIn_1a MODULE PROCEDURE IsIn_1b -#include "./In/IsIn_1.inc" +#include "./In/IsIn_1.F90" END PROCEDURE IsIn_1b MODULE PROCEDURE IsIn_1c -#include "./In/IsIn_1.inc" +#include "./In/IsIn_1.F90" END PROCEDURE IsIn_1c MODULE PROCEDURE IsIn_1d -#include "./In/IsIn_1.inc" +#include "./In/IsIn_1.F90" END PROCEDURE IsIn_1d !---------------------------------------------------------------------------- From 3f5d0eac5a074f9d56770d0533b0715f3f56a6c5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:39:11 +0900 Subject: [PATCH 280/359] diffusion matrix method --- .../src/DiffusionMatrix_Method.F90 | 126 +++++++----------- 1 file changed, 48 insertions(+), 78 deletions(-) diff --git a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 index dfa236fbd..9347beac4 100644 --- a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 +++ b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 @@ -20,15 +20,23 @@ ! summary: This module contains method to construct finite element matrices MODULE DiffusionMatrix_Method -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemShapeData_, & + FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_ + +USE GlobalData, ONLY: I4B, DFP, LGT + IMPLICIT NONE + PRIVATE PUBLIC :: DiffusionMatrix +PUBLIC :: DiffusionMatrix_ !---------------------------------------------------------------------------- -! DiffusionMatrix@DiffusionMatrixMethods +! DiffusionMatrix !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -51,19 +59,33 @@ MODULE DiffusionMatrix_Method ! {\partial x_{k}}\frac{\partial N^{J}}{\partial x_{k}}d\Omega ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_1(test, trial, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_1 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_1 END INTERFACE DiffusionMatrix +!---------------------------------------------------------------------------- +! DiffusionMatrix_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-28 +! summary: DiffusionMatrix_1 without allocation + +INTERFACE DiffusionMatrix_ + MODULE PURE SUBROUTINE DiffusionMatrix1_(test, trial, ans, nrow, ncol, opt) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + END SUBROUTINE DiffusionMatrix1_ +END INTERFACE DiffusionMatrix_ + !---------------------------------------------------------------------------- ! DiffusionMatrix@DiffusionMatrixMethods !---------------------------------------------------------------------------- @@ -80,7 +102,7 @@ END FUNCTION DiffusionMatrix_1 ! $$ ! -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_2(test, trial, k, krank, opt) & & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -94,10 +116,6 @@ MODULE PURE FUNCTION DiffusionMatrix_2(test, trial, k, krank, opt) & INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_2 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_2 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -115,7 +133,7 @@ END FUNCTION DiffusionMatrix_2 ! \frac{\partial N^{J}}{\partial x_{j}}d\Omega ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_3(test, trial, k, krank, opt) & & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -129,10 +147,6 @@ MODULE PURE FUNCTION DiffusionMatrix_3(test, trial, k, krank, opt) & INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_3 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_3 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -150,7 +164,7 @@ END FUNCTION DiffusionMatrix_3 ! \frac{\partial N^{J}}{\partial x_{j}}d\Omega ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_4(test, trial, k, krank, opt) & & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -165,10 +179,6 @@ MODULE PURE FUNCTION DiffusionMatrix_4(test, trial, k, krank, opt) & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_4 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_4 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -186,7 +196,7 @@ END FUNCTION DiffusionMatrix_4 ! \frac{\partial N^{J}}{\partial x_{j}}d\Omega ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_5(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -205,10 +215,6 @@ MODULE PURE FUNCTION DiffusionMatrix_5(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_5 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_5 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -226,7 +232,7 @@ END FUNCTION DiffusionMatrix_5 ! \frac{\partial N^{J}}{\partial x_{j}}d\Omega ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_6(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -245,10 +251,6 @@ MODULE PURE FUNCTION DiffusionMatrix_6(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_6 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_6 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -266,7 +268,7 @@ END FUNCTION DiffusionMatrix_6 ! \frac{\partial N^{J}}{\partial x_{j}}d\Omega ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_7(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -285,10 +287,6 @@ MODULE PURE FUNCTION DiffusionMatrix_7(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_7 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_7 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -305,7 +303,7 @@ END FUNCTION DiffusionMatrix_7 ! ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_8(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -324,10 +322,6 @@ MODULE PURE FUNCTION DiffusionMatrix_8(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_8 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_8 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -344,7 +338,7 @@ END FUNCTION DiffusionMatrix_8 ! ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_9(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -363,10 +357,6 @@ MODULE PURE FUNCTION DiffusionMatrix_9(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_9 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_9 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -377,7 +367,7 @@ END FUNCTION DiffusionMatrix_9 ! date: 6 March 2021 ! summary: This subroutine returns the diffusion matrix in space domain -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_10(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -396,10 +386,6 @@ MODULE PURE FUNCTION DiffusionMatrix_10(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_10 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_10 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -410,7 +396,7 @@ END FUNCTION DiffusionMatrix_10 ! date: 6 March 2021 ! summary: This subroutine returns the diffusion matrix in space domain -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_11(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -429,10 +415,6 @@ MODULE PURE FUNCTION DiffusionMatrix_11(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_11 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_11 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -443,7 +425,7 @@ END FUNCTION DiffusionMatrix_11 ! date: 6 March 2021 ! summary: This subroutine returns the diffusion matrix in space domain -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_12(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -462,10 +444,6 @@ MODULE PURE FUNCTION DiffusionMatrix_12(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_12 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_12 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -476,7 +454,7 @@ END FUNCTION DiffusionMatrix_12 ! date: 6 March 2021 ! summary: This subroutine returns the diffusion matrix in space domain -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_13(test, trial, c1, c2, c1rank, & & c2rank, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -495,10 +473,6 @@ MODULE PURE FUNCTION DiffusionMatrix_13(test, trial, c1, c2, c1rank, & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_13 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_13 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -525,17 +499,13 @@ END FUNCTION DiffusionMatrix_13 ! \frac{\partial N^{J}}{\partial x_{i}}d\Omega ! $$ -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_14(test, trial, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial INTEGER(I4B), INTENT(IN) :: opt(1) REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_14 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_14 END INTERFACE DiffusionMatrix !---------------------------------------------------------------------------- @@ -554,7 +524,7 @@ END FUNCTION DiffusionMatrix_14 ! $$ ! -INTERFACE +INTERFACE DiffusionMatrix MODULE PURE FUNCTION DiffusionMatrix_15(test, trial, k, krank, opt) & & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -568,10 +538,10 @@ MODULE PURE FUNCTION DiffusionMatrix_15(test, trial, k, krank, opt) & INTEGER(I4B), INTENT(IN) :: opt(1) REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION DiffusionMatrix_15 -END INTERFACE - -INTERFACE DiffusionMatrix - MODULE PROCEDURE DiffusionMatrix_15 END INTERFACE DiffusionMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE DiffusionMatrix_Method From 2d2b49a90c36acad04b24fe0b99524e41e01c686 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:39:20 +0900 Subject: [PATCH 281/359] update in elemshapedata lagrange --- src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 index 96afeff73..9e35d13e3 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 @@ -116,10 +116,10 @@ MODULE SUBROUTINE LagrangeElemShapeData3(obj, quad, refelem, baseContinuity, & baseInterpolation, order, ipType, basisType, coeff, firstCall, & alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj - CLASS(QuadraturePoint_), INTENT(IN) :: quad + TYPE(QuadraturePoint_), INTENT(IN) :: quad CLASS(ReferenceElement_), INTENT(IN) :: refelem - CLASS(H1_), INTENT(IN) :: baseContinuity - CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation + TYPE(H1_), INTENT(IN) :: baseContinuity + TYPE(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType !! Interpolation point type From 63a1e8a2da85e66ffa6ae2cb3ab5986f4175c576 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:39:24 +0900 Subject: [PATCH 282/359] update real matrix --- .../RealMatrix/src/RealMatrix_Method.F90 | 129 +++++++++++------- 1 file changed, 80 insertions(+), 49 deletions(-) diff --git a/src/modules/RealMatrix/src/RealMatrix_Method.F90 b/src/modules/RealMatrix/src/RealMatrix_Method.F90 index 79fdc3b4c..66c64f68a 100644 --- a/src/modules/RealMatrix/src/RealMatrix_Method.F90 +++ b/src/modules/RealMatrix/src/RealMatrix_Method.F90 @@ -27,8 +27,8 @@ MODULE RealMatrix_Method PUBLIC :: Shape PUBLIC :: Size -PUBLIC :: TotalDimension -PUBLIC :: SetTotalDimension +PUBLIC :: totalDimension +PUBLIC :: SettotalDimension PUBLIC :: ALLOCATE PUBLIC :: DEALLOCATE PUBLIC :: Initiate @@ -39,6 +39,7 @@ MODULE RealMatrix_Method PUBLIC :: SYM PUBLIC :: SkewSym PUBLIC :: MakeDiagonalCopies +PUBLIC :: MakeDiagonalCopies_ PUBLIC :: RANDOM_NUMBER PUBLIC :: TestMatrix PUBLIC :: ASSIGNMENT(=) @@ -108,7 +109,7 @@ END FUNCTION Get_size END INTERFACE Size !---------------------------------------------------------------------------- -! TotalDimension@ConstructorMethods +! totalDimension@ConstructorMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -119,15 +120,15 @@ END FUNCTION Get_size ! ! This function returns the total dimension (or rank) of an array, -INTERFACE TotalDimension +INTERFACE totalDimension MODULE PURE FUNCTION Get_tdimension(obj) RESULT(Ans) CLASS(RealMatrix_), INTENT(IN) :: obj INTEGER(I4B) :: Ans END FUNCTION Get_tdimension -END INTERFACE TotalDimension +END INTERFACE totalDimension !---------------------------------------------------------------------------- -! SetTotalDimension@GetMethods +! SettotalDimension@GetMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -138,12 +139,12 @@ END FUNCTION Get_tdimension ! ! This subroutine Sets the rank(total dimension) of an array -INTERFACE SetTotalDimension +INTERFACE SettotalDimension MODULE PURE SUBROUTINE Set_tdimension(obj, tDimension) CLASS(RealMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: tDimension END SUBROUTINE Set_tdimension -END INTERFACE SetTotalDimension +END INTERFACE SettotalDimension !---------------------------------------------------------------------------- ! Allocate@ConstructorMethods @@ -402,14 +403,14 @@ END FUNCTION realMat_eye1 ! INTERFACE Convert - MODULE PURE SUBROUTINE realmat_convert_1(From, To, Conversion, & + MODULE PURE SUBROUTINE realmat_convert_1(from, to, Conversion, & & nns, tdof) - TYPE(RealMatrix_), INTENT(IN) :: From + TYPE(RealMatrix_), INTENT(IN) :: from !! Matrix in one format - TYPE(RealMatrix_), INTENT(INOUT) :: To + TYPE(RealMatrix_), INTENT(INOUT) :: to !! Matrix in one format INTEGER(I4B), INTENT(IN) :: Conversion - !! `Conversion` can be `NodesToDOF` or `DOFToNodes` + !! `Conversion` can be `NodestoDOF` or `DOFToNodes` INTEGER(I4B), INTENT(IN) :: nns, tdof END SUBROUTINE realmat_convert_1 END INTERFACE Convert @@ -539,46 +540,72 @@ END FUNCTION SkewSym_array ! !# Introduction ! -! This subroutine makes `nCopy` diagonal copies of `Mat` The size of `Mat` on -! return is nCopy * SIZE( Mat, 1 ) +! This subroutine makes `ncopy` diagonal copies of `Mat` The size of `Mat` on +! return is ncopy * SIZE( Mat, 1 ) ! !### Usage ! !```fortran -! call MakeDiagonalCopies( Mat, nCopy ) +! call MakeDiagonalCopies( Mat, ncopy ) !``` INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy1(Mat, nCopy) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :) - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy1 + MODULE PURE SUBROUTINE MakeDiagonalCopies1(mat, ncopy) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) + INTEGER(I4B), INTENT(IN) :: ncopy + END SUBROUTINE MakeDiagonalCopies1 END INTERFACE MakeDiagonalCopies !---------------------------------------------------------------------------- ! MakeDiagonalCopies@ConstructorMethods !---------------------------------------------------------------------------- +INTERFACE MakeDiagonalCopies_ + MODULE PURE SUBROUTINE MakeDiagonalCopies1_(mat, ncopy, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: mat(:, :) + INTEGER(I4B), INTENT(IN) :: ncopy + INTEGER(i4b), INTENT(IN) :: nrow, ncol + !! nrow and ncol are size of data which is used for making + !! diagonal copies + END SUBROUTINE MakeDiagonalCopies1_ +END INTERFACE MakeDiagonalCopies_ + +!---------------------------------------------------------------------------- +! MakeDiagonalCopies@ConstructorMethods +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 6 March 2021 ! summary: Make diagonal copies of Matrix ! -! This subroutine makes `nCopy` diagonal copies of `Mat` +! This subroutine makes `ncopy` diagonal copies of `Mat` ! !### Usage ! !```fortran -! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy ) +! call MakeDiagonalCopies( from = Mat, to = anotherMat, ncopy = nCopy ) !``` INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy2(From, To, nCopy) - REAL(DFP), INTENT(IN) :: From(:, :) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy2 + MODULE PURE SUBROUTINE MakeDiagonalCopies2(from, to, ncopy) + REAL(DFP), INTENT(IN) :: from(:, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :) + INTEGER(I4B), INTENT(IN) :: ncopy + END SUBROUTINE MakeDiagonalCopies2 END INTERFACE MakeDiagonalCopies +!---------------------------------------------------------------------------- +! MakeDiagonalCopies +!---------------------------------------------------------------------------- + +INTERFACE MakeDiagonalCopies_ + MODULE PURE SUBROUTINE MakeDiagonalCopies2_(from, to, ncopy) + REAL(DFP), INTENT(IN) :: from(:, :) + REAL(DFP), INTENT(INOUT) :: to(:, :) + INTEGER(I4B), INTENT(IN) :: ncopy + END SUBROUTINE MakeDiagonalCopies2_ +END INTERFACE MakeDiagonalCopies_ + !---------------------------------------------------------------------------- ! MakeDiagonalCopies@ConstructorMethods !---------------------------------------------------------------------------- @@ -587,22 +614,26 @@ END SUBROUTINE realmat_make_diag_Copy2 ! date: 6 March 2021 ! summary: Make diagonal copies of [[realmatrix_]] ! -! This subroutine makes `nCopy` diagonal copies of `Mat`, The size of `Mat` -! on return is nCopy * SIZE( Mat, 1 ) +! This subroutine makes `ncopy` diagonal copies of `Mat`, The size of `Mat` +! on return is ncopy * SIZE( Mat, 1 ) ! !### Usage ! !```fortran -! call MakeDiagonalCopies( Mat, nCopy ) +! call MakeDiagonalCopies( Mat, ncopy ) !``` INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy3(Mat, nCopy) + MODULE PURE SUBROUTINE MakeDiagonalCopies3(Mat, ncopy) TYPE(RealMatrix_), INTENT(INOUT) :: Mat - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy3 + INTEGER(I4B), INTENT(IN) :: ncopy + END SUBROUTINE MakeDiagonalCopies3 END INTERFACE MakeDiagonalCopies +!---------------------------------------------------------------------------- +! MakeDiagonalCopies +!---------------------------------------------------------------------------- + !---------------------------------------------------------------------------- ! MakeDiagonalCopies@ConstructorMethods !---------------------------------------------------------------------------- @@ -613,20 +644,20 @@ END SUBROUTINE realmat_make_diag_Copy3 ! !# Introduction ! -! This subroutine makes `nCopy` diagonal copies of `Mat` +! This subroutine makes `ncopy` diagonal copies of `Mat` ! !### Usage ! !```fortran -! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy ) +! call MakeDiagonalCopies( from = Mat, to = anotherMat, ncopy = nCopy ) !``` INTERFACE MakeDiagonalCopies - MODULE PURE SUBROUTINE realmat_make_diag_Copy4(From, To, nCopy) - TYPE(RealMatrix_), INTENT(IN) :: From - TYPE(RealMatrix_), INTENT(INOUT) :: To - INTEGER(I4B), INTENT(IN) :: nCopy - END SUBROUTINE realmat_make_diag_Copy4 + MODULE PURE SUBROUTINE MakeDiagonalCopies4(from, to, ncopy) + TYPE(RealMatrix_), INTENT(IN) :: from + TYPE(RealMatrix_), INTENT(INOUT) :: to + INTEGER(I4B), INTENT(IN) :: ncopy + END SUBROUTINE MakeDiagonalCopies4 END INTERFACE MakeDiagonalCopies !---------------------------------------------------------------------------- @@ -900,9 +931,9 @@ END FUNCTION realmat_Get8 ! fortran array INTERFACE Copy - MODULE PURE SUBROUTINE realmat_Copy1(From, To) - TYPE(RealMatrix_), INTENT(IN) :: From - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) + MODULE PURE SUBROUTINE realmat_Copy1(from, to) + TYPE(RealMatrix_), INTENT(IN) :: from + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :) END SUBROUTINE realmat_Copy1 END INTERFACE Copy @@ -924,9 +955,9 @@ END SUBROUTINE realmat_Copy1 ! RealMatrix object INTERFACE Copy - MODULE PURE SUBROUTINE realmat_Copy2(From, To) - TYPE(RealMatrix_), INTENT(IN) :: From - TYPE(RealMatrix_), INTENT(INOUT) :: To + MODULE PURE SUBROUTINE realmat_Copy2(from, to) + TYPE(RealMatrix_), INTENT(IN) :: from + TYPE(RealMatrix_), INTENT(INOUT) :: to END SUBROUTINE realmat_Copy2 END INTERFACE Copy @@ -952,9 +983,9 @@ END SUBROUTINE realmat_Copy2 ! object INTERFACE Copy - MODULE PURE SUBROUTINE realmat_Copy3(From, To) - REAL(DFP), INTENT(IN) :: From(:, :) - TYPE(RealMatrix_), INTENT(INOUT) :: To + MODULE PURE SUBROUTINE realmat_Copy3(from, to) + REAL(DFP), INTENT(IN) :: from(:, :) + TYPE(RealMatrix_), INTENT(INOUT) :: to END SUBROUTINE realmat_Copy3 END INTERFACE Copy @@ -1038,7 +1069,7 @@ MODULE PURE SUBROUTINE realmat_CG_1(mat, rhs, sol, maxIter, & INTEGER(I4B), OPTIONAL, INTENT(IN) :: convergenceIn !! convergenceInRes <-- default !! convergenceInSol - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: relativeToRHS + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: relativetoRHS !! FALSE <--- relative converfence is checked with respect to ||res|| !! TRUE Convergence is checked with respect to ||rhs|| INTEGER(I4B), OPTIONAL, INTENT(IN) :: restartAfter From be0ba3c7f2f188e3081dc2372e50af61680103d8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:39:31 +0900 Subject: [PATCH 283/359] update in product util --- src/modules/Utility/src/ProductUtility.F90 | 758 ++++++++------------- 1 file changed, 294 insertions(+), 464 deletions(-) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index 8bbe18966..7617e138a 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -16,10 +16,15 @@ ! MODULE ProductUtility -USE GlobalData +USE GlobalData, ONLY: DFP, REAL32, REAL64, LGT, I4B + IMPLICIT NONE + PRIVATE -PUBLIC :: OUTERPROD + +PUBLIC :: OuterProd +PUBLIC :: OuterProd_ + PUBLIC :: Cross_Product PUBLIC :: Vector_Product PUBLIC :: VectorProduct @@ -36,86 +41,103 @@ MODULE ProductUtility ! This FUNCTION evaluate vectors products ! $$\mathbf{ans} = \mathbf{a} \times \mathbf{b}$$ -INTERFACE +INTERFACE Vector_Product MODULE PURE FUNCTION vectorProduct_1(a, b) RESULT(c) ! Define INTENT of dummy argument REAL(REAL64), INTENT(IN) :: a(3), b(3) REAL(REAL64) :: c(3) END FUNCTION vectorProduct_1 -END INTERFACE +END INTERFACE Vector_Product -INTERFACE +INTERFACE Vector_Product MODULE PURE FUNCTION vectorProduct_2(a, b) RESULT(c) ! Define INTENT of dummy argument REAL(REAL32), INTENT(IN) :: a(3), b(3) REAL(REAL32) :: c(3) END FUNCTION vectorProduct_2 -END INTERFACE +END INTERFACE Vector_Product INTERFACE Cross_Product MODULE PROCEDURE vectorProduct_1, vectorProduct_2 END INTERFACE Cross_Product -INTERFACE Vector_Product - MODULE PROCEDURE vectorProduct_1, vectorProduct_2 -END INTERFACE Vector_Product - INTERFACE VectorProduct MODULE PROCEDURE vectorProduct_1, vectorProduct_2 END INTERFACE VectorProduct !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 -! summary: This FUNCTION returns outerproduct(matrix) of two vectors +! summary: This FUNCTION returns OuterProduct(matrix) of two vectors ! !# Introduction ! ! $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1(a, b) RESULT(ans) REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans - END FUNCTION outerprod_r1r1 -END INTERFACE + END FUNCTION OuterProd_r1r1 +END INTERFACE OuterProd -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1 -END INTERFACE OUTERPROD +INTERFACE OuterProd_ + MODULE PURE SUBROUTINE OuterProd_r1r1_(a, b, anscoeff, scale, ans, nrow, & + ncol) + REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b + REAL(DFP), INTENT(IN) :: anscoeff + !! coefficient of ans + !! ans = anscoeff * ans + scale * a \otimes b + REAL(DFP), INTENT(IN) :: scale + !! coefficient of a \otimes b + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! outerprod + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of data written in ans + END SUBROUTINE OuterProd_r1r1_ +END INTERFACE OuterProd_ !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 -! summary: This FUNCTION returns outerproduct +! summary: This FUNCTION returns OuterProduct ! !# Introduction ! -! This FUNCTION returns outerproduct(matrix) of two vectors +! This FUNCTION returns OuterProduct(matrix) of two vectors ! - $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ -! - If `Sym` is .true. THEN symmetric part is returned +! - If `sym` is .true. THEN symmetric part is returned -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1s(a, b, Sym) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1s(a, b, sym) RESULT(ans) ! Define INTENT of dummy variables REAL(DFP), INTENT(IN) :: a(:), b(:) REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans - LOGICAL(LGT), INTENT(IN) :: Sym - END FUNCTION outerprod_r1r1s -END INTERFACE + LOGICAL(LGT), INTENT(IN) :: sym + END FUNCTION OuterProd_r1r1s +END INTERFACE OuterProd -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1s -END INTERFACE OUTERPROD +INTERFACE OuterProd_ + MODULE PURE SUBROUTINE OuterProd_r1r1s_(a, b, sym, anscoeff, scale, ans, & + nrow, ncol) + ! Define INTENT of dummy variables + REAL(DFP), INTENT(IN) :: a(:), b(:) + LOGICAL(LGT), INTENT(IN) :: sym + REAL(DFP), INTENT(IN) :: anscoeff + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE OuterProd_r1r1s_ +END INTERFACE OuterProd_ !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -123,20 +145,16 @@ END FUNCTION outerprod_r1r1s ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r1r2(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2)) - END FUNCTION outerprod_r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -144,20 +162,16 @@ END FUNCTION outerprod_r1r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r1r3(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r3(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3)) - END FUNCTION outerprod_r1r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r3 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r3 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -165,20 +179,16 @@ END FUNCTION outerprod_r1r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r1r4(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r4(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), SIZE(b, 4)) - END FUNCTION outerprod_r1r4 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r4 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r4 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -186,8 +196,8 @@ END FUNCTION outerprod_r1r4 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r1r5(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r5(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :, :, :) REAL(DFP) :: ans(& @@ -197,35 +207,27 @@ MODULE PURE FUNCTION outerprod_r1r5(a, b) RESULT(ans) & SIZE(b, 3),& & SIZE(b, 4),& & SIZE(b, 5)) - END FUNCTION outerprod_r1r5 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r5 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r5 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 -! summary: This FUNCTION returns outerproduct +! summary: This FUNCTION returns OuterProduct -INTERFACE - MODULE PURE FUNCTION outerprod_r2r1(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b)) - END FUNCTION outerprod_r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -233,8 +235,8 @@ END FUNCTION outerprod_r2r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r2r2(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP) :: ans( & @@ -242,15 +244,11 @@ MODULE PURE FUNCTION outerprod_r2r2(a, b) RESULT(ans) & SIZE(a, 2),& & SIZE(b, 1),& & SIZE(b, 2)) - END FUNCTION outerprod_r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -258,8 +256,8 @@ END FUNCTION outerprod_r2r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r2r3(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r3(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP) :: ans( & @@ -268,15 +266,11 @@ MODULE PURE FUNCTION outerprod_r2r3(a, b) RESULT(ans) & SIZE(b, 1),& & SIZE(b, 2),& & SIZE(b, 3)) - END FUNCTION outerprod_r2r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r3 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r3 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -284,8 +278,8 @@ END FUNCTION outerprod_r2r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r2r4(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r4(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :, :, :) REAL(DFP) :: ans( & @@ -295,15 +289,11 @@ MODULE PURE FUNCTION outerprod_r2r4(a, b) RESULT(ans) & SIZE(b, 2),& & SIZE(b, 3),& & SIZE(b, 4)) - END FUNCTION outerprod_r2r4 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r4 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r4 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -311,8 +301,8 @@ END FUNCTION outerprod_r2r4 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r3r1(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r3r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP) :: ans(& @@ -320,15 +310,11 @@ MODULE PURE FUNCTION outerprod_r3r1(a, b) RESULT(ans) & SIZE(a, 2),& & SIZE(a, 3),& & SIZE(b)) - END FUNCTION outerprod_r3r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r3r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -336,8 +322,8 @@ END FUNCTION outerprod_r3r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r3r2(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r3r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP) :: ans(& @@ -346,15 +332,11 @@ MODULE PURE FUNCTION outerprod_r3r2(a, b) RESULT(ans) & SIZE(a, 3),& & SIZE(b, 1),& & SIZE(b, 2)) - END FUNCTION outerprod_r3r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r3r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -362,8 +344,8 @@ END FUNCTION outerprod_r3r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r3r3(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r3r3(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP) :: ans(& @@ -373,15 +355,11 @@ MODULE PURE FUNCTION outerprod_r3r3(a, b) RESULT(ans) & SIZE(b, 1),& & SIZE(b, 2),& & SIZE(b, 3)) - END FUNCTION outerprod_r3r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r3 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r3r3 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -389,8 +367,8 @@ END FUNCTION outerprod_r3r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r4r1(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r4r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP) :: ans(& @@ -399,15 +377,11 @@ MODULE PURE FUNCTION outerprod_r4r1(a, b) RESULT(ans) & SIZE(a, 3),& & SIZE(a, 4),& & SIZE(b, 1)) - END FUNCTION outerprod_r4r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r4r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r4r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -415,8 +389,8 @@ END FUNCTION outerprod_r4r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r4r2(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r4r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP) :: ans(& @@ -426,15 +400,11 @@ MODULE PURE FUNCTION outerprod_r4r2(a, b) RESULT(ans) & SIZE(a, 4),& & SIZE(b, 1),& & SIZE(b, 2)) - END FUNCTION outerprod_r4r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r4r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r4r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@ProductMethods +! OuterProd@ProductMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -442,8 +412,8 @@ END FUNCTION outerprod_r4r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE - MODULE PURE FUNCTION outerprod_r5r1(a, b) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r5r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP) :: ans(& @@ -453,15 +423,11 @@ MODULE PURE FUNCTION outerprod_r5r1(a, b) RESULT(ans) & SIZE(a, 4),& & SIZE(a, 5),& & SIZE(b, 1)) - END FUNCTION outerprod_r5r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r5r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r5r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -469,8 +435,8 @@ END FUNCTION outerprod_r5r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -478,15 +444,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1(a, b, c) RESULT(ans) & SIZE(a, 1),& & SIZE(b, 1),& & SIZE(c, 1)) - END FUNCTION outerprod_r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -494,8 +456,8 @@ END FUNCTION outerprod_r1r1r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r2(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) @@ -504,15 +466,11 @@ MODULE PURE FUNCTION outerprod_r1r1r2(a, b, c) RESULT(ans) & SIZE(b, 1),& & SIZE(c, 1),& & SIZE(c, 2)) - END FUNCTION outerprod_r1r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -520,8 +478,8 @@ END FUNCTION outerprod_r1r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r3(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r3(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :, :) @@ -531,15 +489,11 @@ MODULE PURE FUNCTION outerprod_r1r1r3(a, b, c) RESULT(ans) & SIZE(c, 1),& & SIZE(c, 2),& & SIZE(c, 3)) - END FUNCTION outerprod_r1r1r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r3 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r3 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -547,8 +501,8 @@ END FUNCTION outerprod_r1r1r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r4(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r4(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :, :, :) @@ -559,15 +513,11 @@ MODULE PURE FUNCTION outerprod_r1r1r4(a, b, c) RESULT(ans) & SIZE(c, 2),& & SIZE(c, 3),& & SIZE(c, 4)) - END FUNCTION outerprod_r1r1r4 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r4 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r4 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -575,8 +525,8 @@ END FUNCTION outerprod_r1r1r4 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r2r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r2r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) @@ -585,15 +535,11 @@ MODULE PURE FUNCTION outerprod_r1r2r1(a, b, c) RESULT(ans) & SIZE(b, 1),& & SIZE(b, 2),& & SIZE(c, 1)) - END FUNCTION outerprod_r1r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r2r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -601,8 +547,8 @@ END FUNCTION outerprod_r1r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r2r2(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r2r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :) @@ -612,15 +558,11 @@ MODULE PURE FUNCTION outerprod_r1r2r2(a, b, c) RESULT(ans) & SIZE(b, 2),& & SIZE(c, 1),& & SIZE(c, 2)) - END FUNCTION outerprod_r1r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r2r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -628,8 +570,8 @@ END FUNCTION outerprod_r1r2r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r2r3(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r2r3(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :, :) @@ -640,15 +582,11 @@ MODULE PURE FUNCTION outerprod_r1r2r3(a, b, c) RESULT(ans) & SIZE(c, 1),& & SIZE(c, 2),& & SIZE(c, 3)) - END FUNCTION outerprod_r1r2r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r3 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r2r3 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -656,8 +594,8 @@ END FUNCTION outerprod_r1r2r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r3r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r3r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP), INTENT(IN) :: c(:) @@ -667,15 +605,11 @@ MODULE PURE FUNCTION outerprod_r1r3r1(a, b, c) RESULT(ans) & SIZE(b, 2),& & SIZE(b, 3),& & SIZE(c, 1)) - END FUNCTION outerprod_r1r3r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r3r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r3r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -683,8 +617,8 @@ END FUNCTION outerprod_r1r3r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r3r2(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r3r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP), INTENT(IN) :: c(:, :) @@ -695,15 +629,11 @@ MODULE PURE FUNCTION outerprod_r1r3r2(a, b, c) RESULT(ans) & SIZE(b, 3),& & SIZE(c, 1),& & SIZE(c, 2)) - END FUNCTION outerprod_r1r3r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r3r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r3r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -711,8 +641,8 @@ END FUNCTION outerprod_r1r3r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r1r4r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r4r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :, :) REAL(DFP), INTENT(IN) :: c(:) @@ -723,15 +653,11 @@ MODULE PURE FUNCTION outerprod_r1r4r1(a, b, c) RESULT(ans) & SIZE(b, 3),& & SIZE(b, 4),& & SIZE(c, 1)) - END FUNCTION outerprod_r1r4r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r4r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r4r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -739,8 +665,8 @@ END FUNCTION outerprod_r1r4r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r2r1r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -749,15 +675,11 @@ MODULE PURE FUNCTION outerprod_r2r1r1(a, b, c) RESULT(ans) & SIZE(a, 2),& & SIZE(b, 1),& & SIZE(c, 1)) - END FUNCTION outerprod_r2r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -765,8 +687,8 @@ END FUNCTION outerprod_r2r1r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r2r1r2(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r1r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) @@ -776,15 +698,11 @@ MODULE PURE FUNCTION outerprod_r2r1r2(a, b, c) RESULT(ans) & SIZE(b, 1),& & SIZE(c, 1),& & SIZE(c, 2)) - END FUNCTION outerprod_r2r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r1r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -792,8 +710,8 @@ END FUNCTION outerprod_r2r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r2r1r3(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r1r3(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :, :) @@ -804,15 +722,11 @@ MODULE PURE FUNCTION outerprod_r2r1r3(a, b, c) RESULT(ans) & SIZE(c, 1),& & SIZE(c, 2),& & SIZE(c, 3)) - END FUNCTION outerprod_r2r1r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r3 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r1r3 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -820,8 +734,8 @@ END FUNCTION outerprod_r2r1r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r2r2r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r2r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) @@ -831,15 +745,11 @@ MODULE PURE FUNCTION outerprod_r2r2r1(a, b, c) RESULT(ans) & SIZE(b, 1),& & SIZE(b, 2),& & SIZE(c, 1)) - END FUNCTION outerprod_r2r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r2r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -847,8 +757,8 @@ END FUNCTION outerprod_r2r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r2r2r2(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r2r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :) @@ -859,15 +769,11 @@ MODULE PURE FUNCTION outerprod_r2r2r2(a, b, c) RESULT(ans) & SIZE(b, 2),& & SIZE(c, 1),& & SIZE(c, 2)) - END FUNCTION outerprod_r2r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r2r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -875,8 +781,8 @@ END FUNCTION outerprod_r2r2r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r3r1r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r3r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -886,15 +792,11 @@ MODULE PURE FUNCTION outerprod_r3r1r1(a, b, c) RESULT(ans) & SIZE(a, 3),& & SIZE(b, 1),& & SIZE(c, 1)) - END FUNCTION outerprod_r3r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r3r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -902,8 +804,8 @@ END FUNCTION outerprod_r3r1r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r3r1r2(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r3r1r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) @@ -914,15 +816,11 @@ MODULE PURE FUNCTION outerprod_r3r1r2(a, b, c) RESULT(ans) & SIZE(b, 1),& & SIZE(c, 1),& & SIZE(c, 2)) - END FUNCTION outerprod_r3r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r3r1r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -930,8 +828,8 @@ END FUNCTION outerprod_r3r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r3r2r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r3r2r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) @@ -942,15 +840,11 @@ MODULE PURE FUNCTION outerprod_r3r2r1(a, b, c) RESULT(ans) & SIZE(b, 1),& & SIZE(b, 2),& & SIZE(c, 1)) - END FUNCTION outerprod_r3r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r2r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r3r2r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -958,8 +852,8 @@ END FUNCTION outerprod_r3r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE - MODULE PURE FUNCTION outerprod_r4r1r1(a, b, c) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r4r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -970,15 +864,11 @@ MODULE PURE FUNCTION outerprod_r4r1r1(a, b, c) RESULT(ans) & SIZE(a, 4),& & SIZE(b, 1),& & SIZE(c, 1)) - END FUNCTION outerprod_r4r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r4r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r4r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -986,8 +876,8 @@ END FUNCTION outerprod_r4r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r1r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -997,15 +887,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1r1(a, b, c, d) RESULT(ans) & SIZE(b, 1),& & SIZE(c, 1),& & SIZE(d, 1)) - END FUNCTION outerprod_r1r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1013,8 +899,8 @@ END FUNCTION outerprod_r1r1r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r1r2(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r1r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -1025,15 +911,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1r2(a, b, c, d) RESULT(ans) & SIZE(c, 1),& & SIZE(d, 1),& & SIZE(d, 2)) - END FUNCTION outerprod_r1r1r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r1r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1041,8 +923,8 @@ END FUNCTION outerprod_r1r1r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r1r3(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r1r3(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -1054,15 +936,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1r3(a, b, c, d) RESULT(ans) & SIZE(d, 1),& & SIZE(d, 2),& & SIZE(d, 3)) - END FUNCTION outerprod_r1r1r1r3 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r1r3 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r1r3 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1070,8 +948,8 @@ END FUNCTION outerprod_r1r1r1r3 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r2r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r2r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) @@ -1082,15 +960,11 @@ MODULE PURE FUNCTION outerprod_r1r1r2r1(a, b, c, d) RESULT(ans) & SIZE(c, 1),& & SIZE(c, 2),& & SIZE(d, 1)) - END FUNCTION outerprod_r1r1r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r2r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r2r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1098,8 +972,8 @@ END FUNCTION outerprod_r1r1r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r2r2(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r2r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) @@ -1111,15 +985,11 @@ MODULE PURE FUNCTION outerprod_r1r1r2r2(a, b, c, d) RESULT(ans) & SIZE(c, 2),& & SIZE(d, 1),& & SIZE(d, 2)) - END FUNCTION outerprod_r1r1r2r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r2r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r2r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1127,8 +997,8 @@ END FUNCTION outerprod_r1r1r2r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r1r3r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r1r3r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :, :) @@ -1140,15 +1010,11 @@ MODULE PURE FUNCTION outerprod_r1r1r3r1(a, b, c, d) RESULT(ans) & SIZE(c, 2),& & SIZE(c, 3),& & SIZE(d, 1)) - END FUNCTION outerprod_r1r1r3r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r1r3r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r1r3r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1156,8 +1022,8 @@ END FUNCTION outerprod_r1r1r3r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r2r1r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r2r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) @@ -1168,15 +1034,11 @@ MODULE PURE FUNCTION outerprod_r1r2r1r1(a, b, c, d) RESULT(ans) & SIZE(b, 2),& & SIZE(c, 1),& & SIZE(d, 1)) - END FUNCTION outerprod_r1r2r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r2r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1184,8 +1046,8 @@ END FUNCTION outerprod_r1r2r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r2r1r2(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r2r1r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) @@ -1197,15 +1059,11 @@ MODULE PURE FUNCTION outerprod_r1r2r1r2(a, b, c, d) RESULT(ans) & SIZE(c, 1),& & SIZE(d, 1),& & SIZE(d, 2)) - END FUNCTION outerprod_r1r2r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r1r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r2r1r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1213,8 +1071,8 @@ END FUNCTION outerprod_r1r2r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r2r2r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r2r2r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :) @@ -1226,15 +1084,11 @@ MODULE PURE FUNCTION outerprod_r1r2r2r1(a, b, c, d) RESULT(ans) & SIZE(c, 1),& & SIZE(c, 2),& & SIZE(d, 1)) - END FUNCTION outerprod_r1r2r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r2r2r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r2r2r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1242,8 +1096,8 @@ END FUNCTION outerprod_r1r2r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r1r3r1r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r1r3r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP), INTENT(IN) :: c(:) @@ -1255,15 +1109,11 @@ MODULE PURE FUNCTION outerprod_r1r3r1r1(a, b, c, d) RESULT(ans) & SIZE(b, 3),& & SIZE(c, 1),& & SIZE(d, 1)) - END FUNCTION outerprod_r1r3r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r1r3r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r1r3r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1271,8 +1121,8 @@ END FUNCTION outerprod_r1r3r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r2r1r1r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r1r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -1283,15 +1133,11 @@ MODULE PURE FUNCTION outerprod_r2r1r1r1(a, b, c, d) RESULT(ans) & SIZE(b, 1),& & SIZE(c, 1),& & SIZE(d, 1)) - END FUNCTION outerprod_r2r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r1r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1299,8 +1145,8 @@ END FUNCTION outerprod_r2r1r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r2r1r1r2(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r1r1r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -1312,15 +1158,11 @@ MODULE PURE FUNCTION outerprod_r2r1r1r2(a, b, c, d) RESULT(ans) & SIZE(c, 1),& & SIZE(d, 1),& & SIZE(d, 2)) - END FUNCTION outerprod_r2r1r1r2 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r1r2 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r1r1r2 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1328,8 +1170,8 @@ END FUNCTION outerprod_r2r1r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r2r1r2r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r1r2r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) @@ -1341,15 +1183,11 @@ MODULE PURE FUNCTION outerprod_r2r1r2r1(a, b, c, d) RESULT(ans) & SIZE(c, 1),& & SIZE(c, 2),& & SIZE(d, 1)) - END FUNCTION outerprod_r2r1r2r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r1r2r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r1r2r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1357,8 +1195,8 @@ END FUNCTION outerprod_r2r1r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r2r2r1r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r2r2r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) @@ -1370,15 +1208,11 @@ MODULE PURE FUNCTION outerprod_r2r2r1r1(a, b, c, d) RESULT(ans) & SIZE(b, 2),& & SIZE(c, 1),& & SIZE(d, 1)) - END FUNCTION outerprod_r2r2r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r2r2r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r2r2r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OUTERPROD@PROD +! OuterProd@PROD !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1386,8 +1220,8 @@ END FUNCTION outerprod_r2r2r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE - MODULE PURE FUNCTION outerprod_r3r1r1r1(a, b, c, d) RESULT(ans) +INTERFACE OuterProd + MODULE PURE FUNCTION OuterProd_r3r1r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) @@ -1399,12 +1233,8 @@ MODULE PURE FUNCTION outerprod_r3r1r1r1(a, b, c, d) RESULT(ans) & SIZE(b, 1),& & SIZE(c, 1),& & SIZE(d, 1)) - END FUNCTION outerprod_r3r1r1r1 -END INTERFACE - -INTERFACE OUTERPROD - MODULE PROCEDURE outerprod_r3r1r1r1 -END INTERFACE OUTERPROD + END FUNCTION OuterProd_r3r1r1r1 +END INTERFACE OuterProd !---------------------------------------------------------------------------- ! From f3e1b812bb788cd324c44d6c8ec742b8a4168d66 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:39:36 +0900 Subject: [PATCH 284/359] update in diffusion matrix --- .../src/DiffusionMatrix_Method@Methods.F90 | 168 ++++-------------- 1 file changed, 37 insertions(+), 131 deletions(-) diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 index edbc83a10..346b4b480 100644 --- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 @@ -27,22 +27,49 @@ MODULE PROCEDURE DiffusionMatrix_1 REAL(DFP), ALLOCATABLE :: realval(:) INTEGER(I4B) :: ii - !! - !! main - !! + CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) realval = trial%js * trial%ws * trial%thickness DO ii = 1, SIZE(trial%N, 2) ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) + TRANSPOSE(trial%dNdXt(:, :, ii))) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (realval) - !! END PROCEDURE DiffusionMatrix_1 +!---------------------------------------------------------------------------- +! DiffusionMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix1_ +REAL(DFP), PARAMETER :: one = 1.0_DFP +REAL(DFP) :: realval +INTEGER(I4B) :: ii, jj, ips, dim + +nrow = test%nns +ncol = trial%nns +ans(1:nrow, 1:ncol) = 0.0 + +DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + + DO dim = 1, trial%nsd + CALL OuterProd_(a=test%dNdXt(1:nrow, dim, ips), & + b=trial%dNdXt(1:ncol, dim, ips), & + nrow=ii, ncol=jj, ans=ans, scale=realval, anscoeff=one) + END DO + +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF + +END PROCEDURE DiffusionMatrix1_ + !---------------------------------------------------------------------------- ! DiffusionMatrix !---------------------------------------------------------------------------- @@ -50,24 +77,14 @@ MODULE PROCEDURE DiffusionMatrix_2 REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) INTEGER(I4B) :: ii - !! - !! main - !! -CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - !! +CALL GetInterpolation(obj=trial, Interpol=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar - !! -CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! +CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) - !! ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & - & TRANSPOSE(trial%dNdXt(:, :, ii))) - !! + TRANSPOSE(trial%dNdXt(:, :, ii))) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (kbar, realval) END PROCEDURE DiffusionMatrix_2 @@ -76,27 +93,17 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_3 - !! REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) INTEGER(I4B) :: ii - !! - !! main - !! CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) - !! realval = trial%js * trial%ws * trial%thickness - !! CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! DO ii = 1, SIZE(realval) ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (c1bar, c2bar, realval) - !! END PROCEDURE DiffusionMatrix_3 !---------------------------------------------------------------------------- @@ -105,27 +112,19 @@ MODULE PROCEDURE DiffusionMatrix_4 ! CALL DM_3(ans=ans, test=test, trial=trial, k=k, opt=opt) - !! internal variable REAL(DFP), ALLOCATABLE :: kbar(:, :, :) REAL(DFP), ALLOCATABLE :: realval(:) INTEGER(I4B) :: ii - !! main CALL getInterpolation(obj=trial, Interpol=kbar, val=k) - !! realval = trial%js * trial%ws * trial%thickness - !! CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - !! DO ii = 1, SIZE(realval) ans = ans + realval(ii) * MATMUL(& & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & & TRANSPOSE(trial%dNdXt(:, :, ii))) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (kbar, realval) - !! END PROCEDURE DiffusionMatrix_4 !---------------------------------------------------------------------------- @@ -133,12 +132,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_5 - !! scalar - !! scalar - !! CALL DM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) INTEGER(I4B) :: ii - !! main CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) CALL getInterpolation(obj=trial, Interpol=realval, val=c2) realval = realval * trial%js * trial%ws * trial%thickness * cbar @@ -147,9 +142,7 @@ ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & & TRANSPOSE(trial%dNdXt(:, :, ii))) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (cbar, realval) END PROCEDURE DiffusionMatrix_5 @@ -158,13 +151,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_6 - !! scalar - !! vector - !! CALL DM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt) - !! REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) INTEGER(I4B) :: ii - !! main CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) CALL getInterpolation(obj=trial, interpol=realval, val=c1) @@ -173,11 +161,8 @@ DO ii = 1, SIZE(realval) ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (c1bar, c2bar, realval) - !! END PROCEDURE DiffusionMatrix_6 !---------------------------------------------------------------------------- @@ -185,26 +170,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_7 - !! REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: kbar(:, :, :) INTEGER(I4B) :: ii - !! - !! main - !! CALL getInterpolation(obj=trial, Interpol=realval, val=c1) CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) realval = realval * trial%js * trial%ws * trial%thickness - !! DO ii = 1, SIZE(realval) ans = ans + realval(ii) * MATMUL(& & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & & TRANSPOSE(trial%dNdXt(:, :, ii))) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) DEALLOCATE (realval, kbar) - !! END PROCEDURE DiffusionMatrix_7 !---------------------------------------------------------------------------- @@ -212,7 +190,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_8 - !! ans = DiffusionMatrix( & & test=test, & & trial=trial, & @@ -221,7 +198,6 @@ & c1rank=TypeFEVariableScalar, & & c2rank=TypeFEVariableVector, & & opt=opt) - !! END PROCEDURE DiffusionMatrix_8 !---------------------------------------------------------------------------- @@ -229,24 +205,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_9 - !! Internal variable REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) INTEGER(I4B) :: ii - !! !! main - !! CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) realval = trial%js * trial%ws * trial%thickness - !! DO ii = 1, SIZE(realval) ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) DEALLOCATE (c1bar, c2bar, realval) - !! END PROCEDURE DiffusionMatrix_9 !---------------------------------------------------------------------------- @@ -254,22 +224,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_10 - !! internal variable REAL(DFP), ALLOCATABLE :: matbar(:, :, :) REAL(DFP), ALLOCATABLE :: c1bar(:, :) REAL(DFP), ALLOCATABLE :: c2bar(:, :) REAL(DFP), ALLOCATABLE :: realval(:) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii - !! main CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) CALL getInterpolation(obj=trial, interpol=matbar, val=c2) CALL Reallocate(c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) - !! DO ii = 1, SIZE(c2bar, 2) c1bar(:, ii) = MATMUL(c2bar(:, ii), matbar(:, :, ii)) END DO - !! k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace) CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) @@ -278,11 +244,8 @@ DO ii = 1, SIZE(realval) ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (c1bar, c2bar, realval, matbar) - !! END PROCEDURE DiffusionMatrix_10 !---------------------------------------------------------------------------- @@ -290,7 +253,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_11 - !! ans = DiffusionMatrix( & & test=test, & & trial=trial, & @@ -298,7 +260,6 @@ & c1rank=TypeFEVariableScalar, & & c2rank=TypeFEVariableMatrix, & & opt=opt) - !! END PROCEDURE DiffusionMatrix_11 !---------------------------------------------------------------------------- @@ -306,22 +267,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_12 - !! internal variable REAL(DFP), ALLOCATABLE :: matbar(:, :, :) REAL(DFP), ALLOCATABLE :: c1bar(:, :) REAL(DFP), ALLOCATABLE :: c2bar(:, :) REAL(DFP), ALLOCATABLE :: realval(:) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii - !! main CALL getInterpolation(obj=trial, interpol=matbar, val=c1) CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) CALL Reallocate(c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) - !! DO ii = 1, SIZE(c2bar, 2) c1bar(:, ii) = MATMUL(matbar(:, :, ii), c2bar(:, ii)) END DO - !! k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace) CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) @@ -330,9 +287,7 @@ DO ii = 1, SIZE(realval) ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) - !! DEALLOCATE (c1bar, c2bar, realval, matbar) END PROCEDURE DiffusionMatrix_12 @@ -341,24 +296,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_13 - !! internal variable REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) INTEGER(I4B) :: ii - !! main CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) realval = trial%js * trial%ws * trial%thickness - !! DO ii = 1, SIZE(realval) - !! ans = ans + realval(ii) * MATMUL( & & MATMUL(test%dNdXt(:, :, ii),& & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), & & TRANSPOSE(trial%dNdXt(:, :, ii))) - !! END DO - !! IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) DEALLOCATE (k1bar, k2bar, realval) END PROCEDURE DiffusionMatrix_13 @@ -368,14 +317,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_14 - !! SELECT CASE (opt(1)) CASE (1) CALL DiffusionMatrix_14a(test, trial, ans) CASE (2) CALL DiffusionMatrix_14b(test, trial, ans) END SELECT - !! END PROCEDURE DiffusionMatrix_14 !---------------------------------------------------------------------------- @@ -383,18 +330,14 @@ !---------------------------------------------------------------------------- PURE SUBROUTINE DiffusionMatrix_14a(test, trial, ans) - !! CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - !! REAL(DFP), ALLOCATABLE :: realval(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips - !! realval = trial%js * trial%ws * trial%thickness nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) - !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd @@ -405,11 +348,8 @@ PURE SUBROUTINE DiffusionMatrix_14a(test, trial, ans) END DO END DO END DO - !! CALL Convert(from=m4, to=ans) - !! DEALLOCATE (realval, m4) - !! END SUBROUTINE DiffusionMatrix_14a !---------------------------------------------------------------------------- @@ -417,18 +357,14 @@ END SUBROUTINE DiffusionMatrix_14a !---------------------------------------------------------------------------- PURE SUBROUTINE DiffusionMatrix_14b(test, trial, ans) - !! CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - !! REAL(DFP), ALLOCATABLE :: realval(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips - !! realval = trial%js * trial%ws * trial%thickness nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) - !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd @@ -439,11 +375,8 @@ PURE SUBROUTINE DiffusionMatrix_14b(test, trial, ans) END DO END DO END DO - !! CALL Convert(from=m4, to=ans) - !! DEALLOCATE (realval, m4) - !! END SUBROUTINE DiffusionMatrix_14b !---------------------------------------------------------------------------- @@ -451,14 +384,12 @@ END SUBROUTINE DiffusionMatrix_14b !---------------------------------------------------------------------------- MODULE PROCEDURE DiffusionMatrix_15 - !! SELECT CASE (opt(1)) CASE (1) CALL DiffusionMatrix_15a(test, trial, k, ans) CASE (2) CALL DiffusionMatrix_15b(test, trial, k, ans) END SELECT - !! END PROCEDURE DiffusionMatrix_15 !---------------------------------------------------------------------------- @@ -467,25 +398,15 @@ END SUBROUTINE DiffusionMatrix_14b PURE SUBROUTINE DiffusionMatrix_15a(test, trial, k, ans) CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function CLASS(FEVariable_), INTENT(IN) :: k - !! scalar REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - !! - !! internal variables - !! REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips - !! - !! main - !! nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) CALL getInterpolation(obj=trial, Interpol=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar - !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd @@ -496,11 +417,8 @@ PURE SUBROUTINE DiffusionMatrix_15a(test, trial, k, ans) END DO END DO END DO - !! CALL Convert(from=m4, to=ans) - !! DEALLOCATE (kbar, realval, m4) - !! END SUBROUTINE DiffusionMatrix_15a !---------------------------------------------------------------------------- @@ -509,25 +427,16 @@ END SUBROUTINE DiffusionMatrix_15a PURE SUBROUTINE DiffusionMatrix_15b(test, trial, k, ans) CLASS(ElemshapeData_), INTENT(IN) :: test - !! test function CLASS(ElemshapeData_), INTENT(IN) :: trial - !! trial function CLASS(FEVariable_), INTENT(IN) :: k - !! scalar REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - !! !! internal variables - !! REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4(:, :, :, :) INTEGER(I4B) :: ii, jj, nsd, ips - !! - !! main - !! nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) CALL getInterpolation(obj=trial, Interpol=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar - !! DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd DO ii = 1, nsd @@ -538,11 +447,8 @@ PURE SUBROUTINE DiffusionMatrix_15b(test, trial, k, ans) END DO END DO END DO - !! CALL Convert(from=m4, to=ans) - !! DEALLOCATE (kbar, realval, m4) - !! END SUBROUTINE DiffusionMatrix_15b END SUBMODULE Methods From b8d760f14860e22412efe5f7f94f4a10a15e8abe Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:39:43 +0900 Subject: [PATCH 285/359] update in elemshapedata lagrange --- .../src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 index 58080616b..3e22c4efd 100644 --- a/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 @@ -61,6 +61,13 @@ nns = LagrangeDOF(order=order, elemType=elemType) +#ifdef DEBUG_VER +IF (nns .EQ. 0) THEN + CALL Display("Error: LagrangeDOF returned zero DOF") + STOP +END IF +#endif + CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) obj%ws = quad%points(quad%txi + 1, 1:nips) From 6935446c301bb64968dc0e7d7bf60ac022e52ee0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:39:52 +0900 Subject: [PATCH 286/359] update elemshapedata iomethod --- .../ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 index ac841e4b0..b545bf524 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 @@ -187,7 +187,11 @@ MODULE PROCEDURE elemsd_display_1 CALL Util_Display(msg, unitno=unitno) -CALL Util_Display("SHAPE FUNCTION IN SPACE: ", unitno=unitno) +CALL Util_Display(obj%nsd, "nsd: ", unitno) +CALL Util_Display(obj%xidim, "xidim: ", unitno) +CALL Util_Display(obj%nns, "nns: ", unitno) +CALL Util_Display(obj%nips, "nips: ", unitno) + IF (ALLOCATED(obj%N)) THEN CALL Util_Display(obj%N, "N: ", unitno) ELSE From d22cd3595df063c4244c9a128cab0758aac2fed0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:40:02 +0900 Subject: [PATCH 287/359] update lagrange polynomial util --- .../Polynomial/src/LagrangePolynomialUtility@Methods.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index 2f872d7ea..313f99916 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -123,6 +123,8 @@ topo = ElementTopology(elemType) +ans = 0 + SELECT CASE (topo) CASE (Point) ans = 1 From 71b76847ad94d0bfd69097a82d4d2978e3a2cc8d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:40:09 +0900 Subject: [PATCH 288/359] update realmatrix constructor --- .../RealMatrix_Method@ConstructorMethods.F90 | 244 ++++++++++-------- 1 file changed, 138 insertions(+), 106 deletions(-) diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 index 32bae5ad0..ab9bb0fa7 100644 --- a/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 +++ b/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE (RealMatrix_Method) ConstructorMethods +SUBMODULE(RealMatrix_Method) ConstructorMethods USE BaseMethod IMPLICIT NONE CONTAINS @@ -25,11 +25,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE get_shape - IF( ALLOCATED( obj%val ) ) THEN - Ans = SHAPE( obj%val ) - ELSE - Ans = 0 - END IF +IF (ALLOCATED(obj%val)) THEN + Ans = SHAPE(obj%val) +ELSE + Ans = 0 +END IF END PROCEDURE get_shape !---------------------------------------------------------------------------- @@ -37,18 +37,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE get_size - !Define internal variables - INTEGER( I4B ) :: S( 2 ) - IF( ALLOCATED( obj%val ) ) THEN - S = SHAPE( obj%val ) - IF( PRESENT( Dims ) ) THEN - Ans = S( Dims ) - ELSE - Ans = S( 1 ) * S( 2 ) - END IF +!Define internal variables +INTEGER(I4B) :: S(2) +IF (ALLOCATED(obj%val)) THEN + S = SHAPE(obj%val) + IF (PRESENT(Dims)) THEN + Ans = S(Dims) ELSE - Ans = 0 + Ans = S(1) * S(2) END IF +ELSE + Ans = 0 +END IF END PROCEDURE get_size !---------------------------------------------------------------------------- @@ -56,7 +56,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE get_tdimension - ans = obj%tDimension +ans = obj%tDimension END PROCEDURE get_tdimension !---------------------------------------------------------------------------- @@ -64,7 +64,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE set_tdimension - obj%tDimension = tDimension +obj%tDimension = tDimension END PROCEDURE set_tdimension !---------------------------------------------------------------------------- @@ -72,8 +72,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE allocate_data - CALL Reallocate( obj%val, Dims(1), Dims(2) ) - CALL setTotalDimension( obj, 2_I4B ) +CALL Reallocate(obj%val, Dims(1), Dims(2)) +CALL setTotalDimension(obj, 2_I4B) END PROCEDURE allocate_data !---------------------------------------------------------------------------- @@ -81,8 +81,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Deallocate_Data - IF( ALLOCATED( obj%val ) ) DEALLOCATE( obj%val ) - CALL setTotalDimension( obj, 0 ) +IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) +CALL setTotalDimension(obj, 0) END PROCEDURE Deallocate_Data !---------------------------------------------------------------------------- @@ -90,7 +90,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE realmat_initiate1 - CALL Allocate( obj, Dims ) +CALL ALLOCATE (obj, Dims) END PROCEDURE realmat_initiate1 !---------------------------------------------------------------------------- @@ -98,7 +98,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE realmat_initiate2 - CALL Allocate( obj, [nrow, ncol] ) +CALL ALLOCATE (obj, [nrow, ncol]) END PROCEDURE realmat_initiate2 !---------------------------------------------------------------------------- @@ -106,10 +106,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE realmat_initiate3 - INTEGER( I4B ) :: j - DO j = 1, SIZE( obj ) - CALL Allocate( obj( j ), Dims ) - END DO +INTEGER(I4B) :: j +DO j = 1, SIZE(obj) + CALL ALLOCATE (obj(j), Dims) +END DO END PROCEDURE realmat_initiate3 !---------------------------------------------------------------------------- @@ -117,10 +117,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE realmat_initiate4 - INTEGER( I4B ) :: j - DO j = 1, SIZE( obj ) - CALL Allocate( obj( j ), Dims( j, : ) ) - END DO +INTEGER(I4B) :: j +DO j = 1, SIZE(obj) + CALL ALLOCATE (obj(j), Dims(j, :)) +END DO END PROCEDURE realmat_initiate4 !---------------------------------------------------------------------------- @@ -128,8 +128,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE realmat_initiate5 - obj%val = val - CALL setTotalDimension( obj, 2_I4B ) +obj%val = val +CALL setTotalDimension(obj, 2_I4B) END PROCEDURE realmat_initiate5 !---------------------------------------------------------------------------- @@ -137,7 +137,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Constructor1 - CALL Initiate( obj, Dims ) +CALL Initiate(obj, Dims) END PROCEDURE Constructor1 !---------------------------------------------------------------------------- @@ -145,11 +145,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE realMat_eye1 - INTEGER( I4B ) :: i - CALL Initiate( Ans, [m,m] ) - DO i = 1, m - Ans%val ( i, i ) = 1.0 - END DO +INTEGER(I4B) :: i +CALL Initiate(Ans, [m, m]) +DO i = 1, m + Ans%val(i, i) = 1.0 +END DO END PROCEDURE realMat_eye1 !---------------------------------------------------------------------------- @@ -157,8 +157,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE realmat_convert_1 - CALL Convert( From=From%val, To=To%val, Conversion=Conversion, nns=nns, & - & tdof=tdof ) +CALL Convert(From=From%val, To=To%val, Conversion=Conversion, nns=nns, & + & tdof=tdof) END PROCEDURE realmat_convert_1 !---------------------------------------------------------------------------- @@ -166,7 +166,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE sym_array - Ans = 0.5_DFP * ( obj + TRANSPOSE( obj ) ) +Ans = 0.5_DFP * (obj + TRANSPOSE(obj)) END PROCEDURE sym_array !---------------------------------------------------------------------------- @@ -174,7 +174,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE sym_obj - Ans%val = 0.5_DFP * ( obj%val + TRANSPOSE( obj%val ) ) +Ans%val = 0.5_DFP * (obj%val + TRANSPOSE(obj%val)) END PROCEDURE sym_obj !---------------------------------------------------------------------------- @@ -182,7 +182,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE SkewSym_array - Ans = 0.5_DFP * ( obj - TRANSPOSE( obj ) ) +Ans = 0.5_DFP * (obj - TRANSPOSE(obj)) END PROCEDURE SkewSym_array !---------------------------------------------------------------------------- @@ -190,87 +190,119 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE SkewSym_obj - Ans%val = 0.5_DFP * ( obj%val - TRANSPOSE( obj%val ) ) +Ans%val = 0.5_DFP * (obj%val - TRANSPOSE(obj%val)) END PROCEDURE SkewSym_obj !---------------------------------------------------------------------------- ! MakeDiagonalCopies !---------------------------------------------------------------------------- -MODULE PROCEDURE realmat_make_diag_copy1 - INTEGER( I4B ) :: I, s( 2 ) - REAL( DFP ), ALLOCATABLE :: DummyMat2( :, : ) - - IF( ALLOCATED( mat ) ) THEN - s = SHAPE( mat ) - DummyMat2 = mat - CALL Reallocate( mat, s( 1 )*nCopy, s( 2 )*nCopy ) - DO I = 1, nCopy - mat( ( I - 1 ) * s( 1 ) + 1 : I * s( 1 ), & - & ( I - 1 ) * s( 2 ) + 1 : I * s( 2 ) ) & - & = DummyMat2( :, : ) - END DO - DEALLOCATE( DummyMat2 ) - END IF -END PROCEDURE realmat_make_diag_copy1 +MODULE PROCEDURE MakeDiagonalCopies1 +INTEGER(I4B) :: I, s(2) +REAL(DFP), ALLOCATABLE :: DummyMat2(:, :) + +IF (ALLOCATED(mat)) THEN + s = SHAPE(mat) + DummyMat2 = mat + CALL Reallocate(mat, s(1) * nCopy, s(2) * nCopy) + DO I = 1, nCopy + mat((I - 1) * s(1) + 1:I * s(1), & + & (I - 1) * s(2) + 1:I * s(2)) & + & = DummyMat2(:, :) + END DO + DEALLOCATE (DummyMat2) +END IF +END PROCEDURE MakeDiagonalCopies1 !---------------------------------------------------------------------------- -! MakeDiagonalCopies +! MakeDiaginalCopies !---------------------------------------------------------------------------- -MODULE PROCEDURE realmat_make_diag_copy2 - INTEGER( I4B ) :: I, S( 2 ) - S = SHAPE( From ) - CALL Reallocate( To, S( 1 )*nCopy, S( 2 )*nCopy ) - To = 0.0_DFP - DO I = 1, nCopy - To( ( I - 1 ) * S( 1 ) + 1 : I * S( 1 ), & - & ( I - 1 ) * S( 2 ) + 1 : I * S( 2 ) ) & - & = From( :, : ) +MODULE PROCEDURE MakeDiagonalCopies1_ +INTEGER(I4B) :: ii, jj, kk + +DO ii = 2, ncopy + DO CONCURRENT(jj=1:nrow, kk=1:ncol) + mat((ii - 1) * nrow + jj, (ii - 1) * ncol + kk) = mat(jj, kk) END DO -END PROCEDURE realmat_make_diag_copy2 +END DO + +END PROCEDURE MakeDiagonalCopies1_ !---------------------------------------------------------------------------- ! MakeDiagonalCopies !---------------------------------------------------------------------------- -MODULE PROCEDURE realmat_make_diag_copy3 - CALL realmat_make_diag_copy1( Mat = Mat%val, nCopy = nCopy ) -END PROCEDURE realmat_make_diag_copy3 +MODULE PROCEDURE MakeDiagonalCopies2 +INTEGER(I4B) :: I, S(2) +S = SHAPE(From) +CALL Reallocate(To, S(1) * nCopy, S(2) * nCopy) +To = 0.0_DFP +DO I = 1, nCopy + To((I - 1) * S(1) + 1:I * S(1), & + & (I - 1) * S(2) + 1:I * S(2)) & + & = From(:, :) +END DO +END PROCEDURE MakeDiagonalCopies2 !---------------------------------------------------------------------------- ! MakeDiagonalCopies !---------------------------------------------------------------------------- -MODULE PROCEDURE realmat_make_diag_copy4 - CALL realmat_make_diag_copy2( From = From%val, To = To%val, & - & nCopy = nCopy ) -END PROCEDURE realmat_make_diag_copy4 +MODULE PROCEDURE MakeDiagonalCopies2_ +INTEGER(I4B) :: ii, jj, kk, nrow, ncol + +nrow = SIZE(from, 1) +ncol = SIZE(from, 2) + +DO ii = 1, ncopy + DO CONCURRENT(jj=1:nrow, kk=1:ncol) + to((ii - 1) * nrow + jj, (ii - 1) * ncol + kk) = from(jj, kk) + END DO +END DO +END PROCEDURE MakeDiagonalCopies2_ !---------------------------------------------------------------------------- -! Random_Number +! MakeDiagonalCopies !---------------------------------------------------------------------------- -MODULE PROCEDURE realmat_random_number - IF( PRESENT( m ) .AND. PRESENT( n ) ) THEN - CALL Reallocate( obj%val, m, n ) - CALL RANDOM_NUMBER( obj%val ) - RETURN - END IF +MODULE PROCEDURE MakeDiagonalCopies3 +CALL MakeDiagonalCopies(Mat=Mat%val, nCopy=nCopy) +END PROCEDURE MakeDiagonalCopies3 - IF( PRESENT( m ) ) THEN - CALL Reallocate( obj%val, m, m ) - CALL RANDOM_NUMBER( obj%val ) - RETURN - END IF +!---------------------------------------------------------------------------- +! MakeDiagonalCopies +!---------------------------------------------------------------------------- - IF( PRESENT( n ) ) THEN - CALL Reallocate( obj%val, n, n ) - CALL RANDOM_NUMBER( obj%val ) - RETURN - END IF +MODULE PROCEDURE MakeDiagonalCopies4 +CALL MakeDiagonalCopies(From=From%val, To=To%val, & + nCopy=nCopy) +END PROCEDURE MakeDiagonalCopies4 - CALL RANDOM_NUMBER( obj%val ) +!---------------------------------------------------------------------------- +! Random_Number +!---------------------------------------------------------------------------- + +MODULE PROCEDURE realmat_random_number +IF (PRESENT(m) .AND. PRESENT(n)) THEN + CALL Reallocate(obj%val, m, n) + CALL RANDOM_NUMBER(obj%val) + RETURN +END IF + +IF (PRESENT(m)) THEN + CALL Reallocate(obj%val, m, m) + CALL RANDOM_NUMBER(obj%val) + RETURN +END IF + +IF (PRESENT(n)) THEN + CALL Reallocate(obj%val, n, n) + CALL RANDOM_NUMBER(obj%val) + RETURN +END IF + +CALL RANDOM_NUMBER(obj%val) END PROCEDURE realmat_random_number @@ -279,14 +311,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE TestMatrix - SELECT CASE( matNo ) - CASE( 1 ) - ALLOCATE( Ans( 4, 4 ) ) - Ans( :, 1 ) = [3.0, -3.0, 6.0, -9.0] - Ans( :, 2 ) = [-7.0, 5.0, -4.0, 5.0] - Ans( :, 3 ) = [-2.0, 1.0, 0.0, -5.0] - Ans( :, 4 ) = [2.0, 0.0, -5.0, 12.0] - END SELECT +SELECT CASE (matNo) +CASE (1) + ALLOCATE (Ans(4, 4)) + Ans(:, 1) = [3.0, -3.0, 6.0, -9.0] + Ans(:, 2) = [-7.0, 5.0, -4.0, 5.0] + Ans(:, 3) = [-2.0, 1.0, 0.0, -5.0] + Ans(:, 4) = [2.0, 0.0, -5.0, 12.0] +END SELECT END PROCEDURE TestMatrix !---------------------------------------------------------------------------- From 5ec41cc98554e4b847b6fb914d04ff09a3b89ef4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 00:40:16 +0900 Subject: [PATCH 289/359] update in product utility method --- .../Utility/src/ProductUtility@Methods.F90 | 361 ++++++++++-------- 1 file changed, 200 insertions(+), 161 deletions(-) diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index e68c7588c..ab9451d99 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -17,10 +17,9 @@ !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 -! summary: This submodule contains outerprod +! summary: This submodule contains OuterProd SUBMODULE(ProductUtility) Methods -USE BaseMethod IMPLICIT NONE CONTAINS @@ -48,453 +47,493 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1 +MODULE PROCEDURE OuterProd_r1r1 ans = 0.0_DFP ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * & - & SPREAD(b, dim=1, ncopies=SIZE(a)) -END PROCEDURE outerprod_r1r1 + SPREAD(b, dim=1, ncopies=SIZE(a)) +END PROCEDURE OuterProd_r1r1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OuterProd_r1r1_ +INTEGER(I4B) :: ii, jj + +nrow = SIZE(a) +ncol = SIZE(b) +DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = anscoeff * ans(ii, jj) + scale * a(ii) * b(jj) +END DO +END PROCEDURE OuterProd_r1r1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OuterProd_r1r1s_ +INTEGER(I4B) :: ii, jj +REAL(DFP) :: s + +IF (sym) THEN + nrow = SIZE(a) + ncol = SIZE(b) + s = 0.5_DFP * scale + + DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = anscoeff * ans(ii, jj) + s * a(ii) * b(jj) + & + s * b(ii) * a(jj) + END DO + + RETURN +END IF + +CALL OuterProd_(a=a, b=b, ans=ans, anscoeff=anscoeff, scale=scale, & + nrow=nrow, ncol=ncol) + +END PROCEDURE OuterProd_r1r1s_ !-------------------------------------------------------------------- ! !-------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1s +MODULE PROCEDURE OuterProd_r1r1s ans = 0.0_DFP IF (Sym) THEN ans = SPREAD(0.5_DFP * a, dim=2, ncopies=SIZE(b)) & - & * SPREAD(b, dim=1, ncopies=SIZE(a)) & - & + SPREAD(0.5_DFP * b, dim=2, ncopies=SIZE(a)) & - & * SPREAD(a, dim=1, ncopies=SIZE(b)) + * SPREAD(b, dim=1, ncopies=SIZE(a)) & + + SPREAD(0.5_DFP * b, dim=2, ncopies=SIZE(a)) & + * SPREAD(a, dim=1, ncopies=SIZE(b)) ELSE ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * & - & SPREAD(b, dim=1, ncopies=SIZE(a)) + SPREAD(b, dim=1, ncopies=SIZE(a)) END IF -END PROCEDURE outerprod_r1r1s +END PROCEDURE OuterProd_r1r1s !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r2 +MODULE PROCEDURE OuterProd_r1r2 INTEGER(I4B) :: ii -do ii = 1, size(b, 2) - ans(:, :, ii) = outerprod(a, b(:, ii)) -end do -END PROCEDURE outerprod_r1r2 +DO ii = 1, SIZE(b, 2) + ans(:, :, ii) = OuterProd(a, b(:, ii)) +END DO +END PROCEDURE OuterProd_r1r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r3 +MODULE PROCEDURE OuterProd_r1r3 INTEGER(I4B) :: ii -do ii = 1, size(b, 3) - ans(:, :, :, ii) = outerprod(a, b(:, :, ii)) -end do -END PROCEDURE outerprod_r1r3 +DO ii = 1, SIZE(b, 3) + ans(:, :, :, ii) = OuterProd(a, b(:, :, ii)) +END DO +END PROCEDURE OuterProd_r1r3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r4 +MODULE PROCEDURE OuterProd_r1r4 INTEGER(I4B) :: ii -do ii = 1, size(b, 4) - ans(:, :, :, :, ii) = outerprod(a, b(:, :, :, ii)) -end do -END PROCEDURE outerprod_r1r4 +DO ii = 1, SIZE(b, 4) + ans(:, :, :, :, ii) = OuterProd(a, b(:, :, :, ii)) +END DO +END PROCEDURE OuterProd_r1r4 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r5 +MODULE PROCEDURE OuterProd_r1r5 INTEGER(I4B) :: ii -do ii = 1, size(b, 5) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, :, ii)) -end do -END PROCEDURE outerprod_r1r5 +DO ii = 1, SIZE(b, 5) + ans(:, :, :, :, :, ii) = OuterProd(a, b(:, :, :, :, ii)) +END DO +END PROCEDURE OuterProd_r1r5 !-------------------------------------------------------------------- ! !-------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r1 +MODULE PROCEDURE OuterProd_r2r1 INTEGER(I4B) :: ii -do ii = 1, size(b, 1) +DO ii = 1, SIZE(b, 1) ans(:, :, ii) = a * b(ii) -end do -END PROCEDURE outerprod_r2r1 +END DO +END PROCEDURE OuterProd_r2r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r2 +MODULE PROCEDURE OuterProd_r2r2 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 2) - ans(:, :, :, ii) = outerprod(a, b(:, ii)) + ans(:, :, :, ii) = OuterProd(a, b(:, ii)) END DO -END PROCEDURE outerprod_r2r2 +END PROCEDURE OuterProd_r2r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r3 +MODULE PROCEDURE OuterProd_r2r3 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 3) - ans(:, :, :, :, ii) = outerprod(a, b(:, :, ii)) + ans(:, :, :, :, ii) = OuterProd(a, b(:, :, ii)) END DO -END PROCEDURE outerprod_r2r3 +END PROCEDURE OuterProd_r2r3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r4 +MODULE PROCEDURE OuterProd_r2r4 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 4) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, ii)) + ans(:, :, :, :, :, ii) = OuterProd(a, b(:, :, :, ii)) END DO -END PROCEDURE outerprod_r2r4 +END PROCEDURE OuterProd_r2r4 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r3r1 +MODULE PROCEDURE OuterProd_r3r1 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 1) ans(:, :, :, ii) = a(:, :, :) * b(ii) END DO -END PROCEDURE outerprod_r3r1 +END PROCEDURE OuterProd_r3r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r3r2 +MODULE PROCEDURE OuterProd_r3r2 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 2) - ans(:, :, :, :, ii) = outerprod(a, b(:, ii)) + ans(:, :, :, :, ii) = OuterProd(a, b(:, ii)) END DO -END PROCEDURE outerprod_r3r2 +END PROCEDURE OuterProd_r3r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r3r3 +MODULE PROCEDURE OuterProd_r3r3 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 3) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, ii)) + ans(:, :, :, :, :, ii) = OuterProd(a, b(:, :, ii)) END DO -END PROCEDURE outerprod_r3r3 +END PROCEDURE OuterProd_r3r3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r4r1 +MODULE PROCEDURE OuterProd_r4r1 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 1) ans(:, :, :, :, ii) = a * b(ii) END DO -END PROCEDURE outerprod_r4r1 +END PROCEDURE OuterProd_r4r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r4r2 +MODULE PROCEDURE OuterProd_r4r2 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 2) - ans(:, :, :, :, :, ii) = outerprod(a, b(:, ii)) + ans(:, :, :, :, :, ii) = OuterProd(a, b(:, ii)) END DO -END PROCEDURE outerprod_r4r2 +END PROCEDURE OuterProd_r4r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r5r1 +MODULE PROCEDURE OuterProd_r5r1 INTEGER(I4B) :: ii DO ii = 1, SIZE(b) ans(:, :, :, :, :, ii) = a * b(ii) END DO -END PROCEDURE outerprod_r5r1 +END PROCEDURE OuterProd_r5r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r1 +MODULE PROCEDURE OuterProd_r1r1r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r2 +MODULE PROCEDURE OuterProd_r1r1r2 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r1r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r3 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r3 +MODULE PROCEDURE OuterProd_r1r1r3 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r1r3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r4 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r1r4 +MODULE PROCEDURE OuterProd_r1r1r4 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r1r4 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r2r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r2r1 +MODULE PROCEDURE OuterProd_r1r2r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r2r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r2r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r2r2 +MODULE PROCEDURE OuterProd_r1r2r2 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r2r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r2r3 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r2r3 +MODULE PROCEDURE OuterProd_r1r2r3 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r2r3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r3r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r3r1 +MODULE PROCEDURE OuterProd_r1r3r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r3r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r3r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r3r2 +MODULE PROCEDURE OuterProd_r1r3r2 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r3r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r4r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r1r4r1 +MODULE PROCEDURE OuterProd_r1r4r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r1r4r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r1r1 +MODULE PROCEDURE OuterProd_r2r1r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r2r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r1r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r1r2 +MODULE PROCEDURE OuterProd_r2r1r2 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r2r1r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r1r3 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r1r3 +MODULE PROCEDURE OuterProd_r2r1r3 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r2r1r3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r2r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r2r1 +MODULE PROCEDURE OuterProd_r2r2r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r2r2r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r2r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r2r2r2 +MODULE PROCEDURE OuterProd_r2r2r2 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r2r2r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r3r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r3r1r1 +MODULE PROCEDURE OuterProd_r3r1r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r3r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r3r1r2 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r3r1r2 +MODULE PROCEDURE OuterProd_r3r1r2 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r3r1r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r3r2r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r3r2r1 +MODULE PROCEDURE OuterProd_r3r2r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r3r2r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r4r1r1 -ans = outerprod(outerprod(a, b), c) -END PROCEDURE outerprod_r4r1r1 +MODULE PROCEDURE OuterProd_r4r1r1 +ans = OuterProd(OuterProd(a, b), c) +END PROCEDURE OuterProd_r4r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r1r1 +MODULE PROCEDURE OuterProd_r1r1r1r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r1r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r1r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r1r2 +MODULE PROCEDURE OuterProd_r1r1r1r2 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r1r1r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r1r3 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r1r3 +MODULE PROCEDURE OuterProd_r1r1r1r3 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r1r1r3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r2r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r2r1 +MODULE PROCEDURE OuterProd_r1r1r2r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r1r2r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r2r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r2r2 +MODULE PROCEDURE OuterProd_r1r1r2r2 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r1r2r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r1r3r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r1r3r1 +MODULE PROCEDURE OuterProd_r1r1r3r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r1r3r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r2r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r2r1r1 +MODULE PROCEDURE OuterProd_r1r2r1r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r2r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r2r1r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r2r1r2 +MODULE PROCEDURE OuterProd_r1r2r1r2 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r2r1r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r2r2r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r2r2r1 +MODULE PROCEDURE OuterProd_r1r2r2r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r2r2r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r1r3r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r1r3r1r1 +MODULE PROCEDURE OuterProd_r1r3r1r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r1r3r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r1r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r1r1r1 +MODULE PROCEDURE OuterProd_r2r1r1r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r2r1r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r1r1r2 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r1r1r2 +MODULE PROCEDURE OuterProd_r2r1r1r2 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r2r1r1r2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r1r2r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r1r2r1 +MODULE PROCEDURE OuterProd_r2r1r2r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r2r1r2r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r2r2r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r2r2r1r1 +MODULE PROCEDURE OuterProd_r2r2r1r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r2r2r1r1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE outerprod_r3r1r1r1 -ans = outerprod(outerprod(a, outerprod(b, c)), d) -END PROCEDURE outerprod_r3r1r1r1 +MODULE PROCEDURE OuterProd_r3r1r1r1 +ans = OuterProd(OuterProd(a, OuterProd(b, c)), d) +END PROCEDURE OuterProd_r3r1r1r1 END SUBMODULE Methods From c7ae822166a910e378c58b2e4187fa9cadbf7ab5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 29 Jul 2024 11:52:56 +0900 Subject: [PATCH 290/359] update in reference element method --- .../Geometry/src/ReferenceElement_Method.F90 | 24 +++- .../ReferenceElement_Method@VTKMethods.F90 | 130 +++++++++++++++++- 2 files changed, 147 insertions(+), 7 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index a3292e2a2..dae820c5f 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -65,7 +65,8 @@ MODULE ReferenceElement_Method PUBLIC :: ContainsPoint PUBLIC :: TotalEntities PUBLIC :: GetFacetTopology -PUBLIC :: GetVTKelementType +PUBLIC :: GetVTKElementType +PUBLIC :: GetVTKElementType_ PUBLIC :: GetEdgeConnectivity PUBLIC :: GetFaceConnectivity PUBLIC :: GetTotalNodes @@ -1380,12 +1381,25 @@ END FUNCTION refelem_TotalEntities ! getVTKelementType@VTKMethods !---------------------------------------------------------------------------- -INTERFACE GetVTKelementType - MODULE PURE SUBROUTINE get_vtk_elemType(elemType, vtk_type, nptrs) +INTERFACE GetVTKElementType + MODULE PURE SUBROUTINE GetVTKElementType1(elemType, vtk_type, nptrs) INTEGER(I4B), INTENT(IN) :: elemType INTEGER(INT8), INTENT(OUT) :: vtk_type INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: nptrs(:) - END SUBROUTINE get_vtk_elemType -END INTERFACE GetVTKelementType + END SUBROUTINE GetVTKElementType1 +END INTERFACE GetVTKElementType + +!---------------------------------------------------------------------------- +! GetVTKElementType@VTKMethods +!---------------------------------------------------------------------------- + +INTERFACE GetVTKElementType_ + MODULE PURE SUBROUTINE GetVTKElementType1_(elemType, vtk_type, nptrs, tsize) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(INT8), INTENT(OUT) :: vtk_type + INTEGER(I4B), INTENT(INOUT) :: nptrs(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetVTKElementType1_ +END INTERFACE GetVTKElementType_ END MODULE ReferenceElement_Method diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 index 17ecc9228..f54ae27ec 100644 --- a/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 +++ b/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 @@ -51,7 +51,7 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE get_vtk_elemType +MODULE PROCEDURE GetVTKElementType1 SELECT CASE (ElemType) CASE (Point1) @@ -149,6 +149,132 @@ nptrs = [1, 2, 3, 4, 5, 6, 7, 8, 10, 9, & 12, 11, 13, 14, 16, 15] END SELECT -END PROCEDURE get_vtk_elemType +END PROCEDURE GetVTKElementType1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetVTKElementType1_ + +SELECT CASE (ElemType) +CASE (Point1) + vtk_type = vtk_point + tsize = 1 + nptrs(1:tsize) = [1] + +CASE (Line2) + vtk_type = vtk_line2 + tsize = 2 + nptrs(1:tsize) = [1, 2] + +CASE (Triangle3) + vtk_type = vtk_triangle3 + tsize = 3 + nptrs(1:tsize) = [1, 2, 3] + +CASE (Quadrangle4) + vtk_type = vtk_quadrangle4 + tsize = 4 + nptrs(1:tsize) = [1, 2, 3, 4] + +CASE (Tetrahedron4) + vtk_type = vtk_Tetrahedron4 + tsize = 4 + nptrs(1:tsize) = [1, 2, 3, 4] + +CASE (Hexahedron8) + vtk_type = vtk_Hexahedron8 + tsize = 8 + nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8] + +CASE (Prism6) + vtk_type = vtk_Prism6 + tsize = 6 + nptrs(1:tsize) = [1, 2, 3, 4, 5, 6] + +CASE (Pyramid5) + vtk_type = vtk_Pyramid5 + tsize = 5 + nptrs(1:tsize) = [1, 2, 3, 4, 5] + + !! Order=2 elements +CASE (Line3) + vtk_type = vtk_line3 + tsize = 3 + nptrs(1:tsize) = [1, 2, 3] + +CASE (Triangle6) + vtk_type = vtk_Triangle6 + tsize = 6 + nptrs(1:tsize) = [1, 2, 3, 4, 5, 6] + +CASE (Quadrangle9) + vtk_type = vtk_Quadrangle9 + tsize = 9 + nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8, 9] + +CASE (Quadrangle8) + vtk_type = vtk_Quadrangle8 + tsize = 8 + nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8] + +CASE (Tetrahedron10) + vtk_type = vtk_Tetrahedron10 + tsize = 10 + nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, 6, 7, 9, 8] + +CASE (Hexahedron20) + vtk_type = vtk_Hexahedron20 + tsize = 20 + nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, 6, 7, & + 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14] + +CASE (Hexahedron27) + vtk_type = vtk_Hexahedron27 + tsize = 27 + nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, 6, 7, & + 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14, & + 24, 22, 20, 21, 23, 25, 26] + +CASE (Prism15) + vtk_type = vtk_Prism15 + tsize = 15 + nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, & + 6, 8, 12, 7, 13, 14, 9, 11, 10] + +CASE (Prism18) + vtk_type = vtk_Prism18 + tsize = 18 + nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, & + 6, 8, 12, 7, 13, 14, 9, 11, 10, & + 15, 17, 16] + +CASE (Pyramid13) + vtk_type = vtk_Pyramid13 + tsize = 13 + nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, & + 5, 8, 9, 6, 10, 7, 11, 12] + +CASE (Pyramid14) + vtk_type = vtk_Pyramid13 + tsize = 14 + nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, & + 5, 8, 9, 6, 10, 7, 11, 12] + + !! order=3 element +CASE (Line4) + vtk_type = vtk_line4 + tsize = 4 + nptrs(1:tsize) = [1, 2, 3, 4] + +CASE (Quadrangle16) + vtk_type = vtk_Quadrangle16 + tsize = 16 + nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8, 10, 9, & + 12, 11, 13, 14, 16, 15] +END SELECT + +END PROCEDURE GetVTKElementType1_ END SUBMODULE VTKMethods From db4f70f68f1b6900f106ebd45e26e69ab5d2e2ee Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 2 Aug 2024 09:38:24 +0900 Subject: [PATCH 291/359] update in GlobalData --- src/modules/GlobalData/src/GlobalData.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 index 1f40bac1f..2adf09ce3 100755 --- a/src/modules/GlobalData/src/GlobalData.F90 +++ b/src/modules/GlobalData/src/GlobalData.F90 @@ -16,7 +16,7 @@ MODULE GlobalData USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INPUT_UNIT, & - & OUTPUT_UNIT, ERROR_UNIT + OUTPUT_UNIT, ERROR_UNIT IMPLICIT NONE PUBLIC From e11a09c51b734a126647478d6eca1237d83b7103 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:27:01 +0900 Subject: [PATCH 292/359] updates in BaseContinuity_Method updates in BaseInterpolation_Method --- .../src/BaseContinuity_Method.F90 | 100 ++-- .../src/BaseInterpolation_Method.F90 | 526 +++++++++++------- 2 files changed, 371 insertions(+), 255 deletions(-) diff --git a/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 b/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 index 703f34c6c..6a1b4b190 100644 --- a/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 +++ b/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 @@ -18,12 +18,23 @@ MODULE BaseContinuity_Method USE ErrorHandling, ONLY: Errormsg -USE GlobalData + +USE GlobalData, ONLY: I4B, LGT, stderr + USE String_Class, ONLY: String -USE BaseType -USE Utility, ONLY: UpperCase + +USE BaseType, ONLY: BaseContinuity_, & + H1_, & + HCURL_, & + HDIV_, & + DG_ + +USE StringUtility, ONLY: UpperCase + IMPLICIT NONE + PRIVATE + PUBLIC :: ASSIGNMENT(=) PUBLIC :: BaseContinuity_ToString PUBLIC :: BaseContinuity_FromString @@ -47,26 +58,28 @@ FUNCTION BaseContinuityPointer_FromString(name) RESULT(ans) CHARACTER(*), INTENT(IN) :: name CLASS(BaseContinuity_), POINTER :: ans !! - TYPE(String) :: astr - astr = TRIM(UpperCase(name)) + CHARACTER(len=2) :: astr - SELECT CASE (astr%chars()) + astr = UpperCase(name(1:2)) + + SELECT CASE (astr) CASE ("H1") ALLOCATE (H1_ :: ans) - CASE ("HDIV") + + CASE ("HD") ALLOCATE (HDiv_ :: ans) - CASE ("HCURL") + + CASE ("HC") ALLOCATE (HCurl_ :: ans) + CASE ("DG") ALLOCATE (DG_ :: ans) + CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for given name="//astr, & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuityPointer_FromString()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="NO CASE FOUND for given name="//astr, & + routine="BaseContinuityPointer_FromString()", & + line=__LINE__, unitno=stderr, file=__FILE__) + STOP END SELECT END FUNCTION BaseContinuityPointer_FromString @@ -89,20 +102,21 @@ SUBROUTINE BaseContinuity_Copy(obj1, obj2) SELECT TYPE (obj2) CLASS IS (H1_) ALLOCATE (H1_ :: obj1) + CLASS IS (HDiv_) ALLOCATE (HDiv_ :: obj1) + CLASS IS (HCurl_) ALLOCATE (HCurl_ :: obj1) + CLASS IS (DG_) ALLOCATE (DG_ :: obj1) + CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuity_Copy()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="NO CASE FOUND for type of obj2", & + routine="BaseContinuity_Copy()", line=__LINE__, & + unitno=stderr, file=__FILE__) + STOP END SELECT END SUBROUTINE BaseContinuity_Copy @@ -118,6 +132,7 @@ END SUBROUTINE BaseContinuity_Copy FUNCTION BaseContinuity_ToString(obj) RESULT(ans) CLASS(BaseContinuity_), INTENT(IN) :: obj TYPE(String) :: ans + SELECT TYPE (obj) CLASS IS (H1_) ans = "H1" @@ -128,13 +143,10 @@ FUNCTION BaseContinuity_ToString(obj) RESULT(ans) CLASS IS (DG_) ans = "DG" CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuity_toString()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="NO CASE FOUND for type of obj", & + routine="BaseContinuity_toString()", & + line=__LINE__, unitno=stderr, file=__FILE__) + STOP END SELECT END FUNCTION BaseContinuity_ToString @@ -147,30 +159,34 @@ END FUNCTION BaseContinuity_ToString ! summary: Returns a string name of base interpolation type SUBROUTINE BaseContinuity_FromString(obj, name) - CLASS(BaseContinuity_), ALLOCATABLE, INTENT(OUT) :: obj + CLASS(BaseContinuity_), ALLOCATABLE, INTENT(INOUT) :: obj CHARACTER(*), INTENT(IN) :: name - TYPE(String) :: ans - ans = UpperCase(name) + CHARACTER(len=2) :: ans + + ans = UpperCase(name(1:2)) + IF (ALLOCATED(obj)) DEALLOCATE (obj) - SELECT CASE (ans%chars()) + SELECT CASE (ans) + CASE ("H1") ALLOCATE (H1_ :: obj) - CASE ("HDIV") + + CASE ("HD") ALLOCATE (HDiv_ :: obj) - CASE ("HCURL") + + CASE ("HC") ALLOCATE (HCurl_ :: obj) + CASE ("DG") ALLOCATE (DG_ :: obj) + CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for given name="//TRIM(name), & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseContinuity_fromString()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="NO CASE FOUND for given name="//TRIM(name), & + routine="BaseContinuity_fromString()", & + line=__LINE__, unitno=stderr, file=__FILE__) + STOP END SELECT END SUBROUTINE BaseContinuity_FromString diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 index cf3eb88a5..79ddf60c0 100644 --- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 +++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 @@ -18,25 +18,44 @@ MODULE BaseInterpolation_Method USE ErrorHandling, ONLY: Errormsg -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT, stdout, stderr USE String_Class, ONLY: String -USE BaseType -USE Utility, ONLY: UpperCase +USE StringUtility, ONLY: UpperCase USE Display_Method, ONLY: Tostring +USE BaseType, ONLY: poly => TypePolynomialOpt, & + ip => TypeQuadratureOpt, & + BaseInterpolation_, & + LagrangeInterpolation_, & + SerendipityInterpolation_, & + HermitInterpolation_, & + HierarchyInterpolation_, & + OrthogonalInterpolation_ + IMPLICIT NONE + PRIVATE + PUBLIC :: ASSIGNMENT(=) PUBLIC :: BaseInterpolation_ToInteger PUBLIC :: BaseInterpolation_FromInteger -PUBLIC :: BaseInterpolation_ToString PUBLIC :: BaseInterpolation_FromString PUBLIC :: BaseInterpolationPointer_FromString +PUBLIC :: BaseType_ToInteger + +PUBLIC :: BaseInterpolation_ToString +PUBLIC :: BaseType_ToChar +PUBLIC :: BaseInterpolation_ToChar INTERFACE BaseInterpolation_ToInteger MODULE PROCEDURE BaseInterpolation_ToInteger1 MODULE PROCEDURE BaseInterpolation_ToInteger2 END INTERFACE BaseInterpolation_ToInteger +INTERFACE BaseType_ToInteger + MODULE PROCEDURE BaseInterpolation_ToInteger1 + MODULE PROCEDURE BaseType_ToInteger1 +END INTERFACE BaseType_ToInteger + INTERFACE BaseInterpolation_ToString MODULE PROCEDURE BaseInterpolation_ToString1 MODULE PROCEDURE BaseInterpolation_ToString2 @@ -59,36 +78,35 @@ MODULE BaseInterpolation_Method FUNCTION BaseInterpolationPointer_FromString(name) RESULT(Ans) CHARACTER(*), INTENT(IN) :: name CLASS(BaseInterpolation_), POINTER :: ans - !! - TYPE(String) :: astr - astr = TRIM(UpperCase(name)) - SELECT CASE (astr%chars()) - CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") + CHARACTER(LEN=4) :: astr + + astr = UpperCase(name(1:4)) + + SELECT CASE (astr) + + CASE ("LAGR") ALLOCATE (LagrangeInterpolation_ :: ans) - CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") + + CASE ("SERE") ALLOCATE (SerendipityInterpolation_ :: ans) - CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") + + CASE ("HERM") ALLOCATE (HermitInterpolation_ :: ans) - CASE ( & - & "HIERARCHICALPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHICALPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION") + + CASE ("HIER", "HEIR") ALLOCATE (HierarchyInterpolation_ :: ans) - CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") + + CASE ("ORTH") ALLOCATE (OrthogonalInterpolation_ :: ans) + CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of name="//astr, & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolationPointer_FromString()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="NO CASE FOUND for type of name="//astr, & + routine="BaseInterpolationPointer_FromString()", & + unitno=stdout, line=__LINE__, file=__FILE__) + STOP END SELECT + END FUNCTION BaseInterpolationPointer_FromString !---------------------------------------------------------------------------- @@ -107,94 +125,87 @@ SUBROUTINE BaseInterpolation_Copy(obj1, obj2) DEALLOCATE (obj1) END IF - SELECT TYPE (obj2) - CLASS IS (LagrangeInterpolation_) - ALLOCATE (LagrangeInterpolation_ :: obj1) - CLASS IS (SerendipityInterpolation_) - ALLOCATE (SerendipityInterpolation_ :: obj1) - CLASS IS (HermitInterpolation_) - ALLOCATE (HermitInterpolation_ :: obj1) - CLASS IS (HierarchyInterpolation_) - ALLOCATE (HierarchyInterpolation_ :: obj1) - CLASS IS (OrthogonalInterpolation_) - ALLOCATE (OrthogonalInterpolation_ :: obj1) - CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_Copy()", & - & file=__FILE__ & - & ) + ALLOCATE (obj1, source=obj2) - END SELECT END SUBROUTINE BaseInterpolation_Copy !---------------------------------------------------------------------------- -! BaseInterpolation_toString +! BaseInterpolation_toInteger !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -FUNCTION BaseInterpolation_ToString1(obj) RESULT(ans) +FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) CLASS(BaseInterpolation_), INTENT(IN) :: obj - TYPE(String) :: ans + INTEGER(I4B) :: ans + SELECT TYPE (obj) CLASS IS (LagrangeInterpolation_) - ans = "LagrangeInterpolation" + ans = poly%lagrange + CLASS IS (SerendipityInterpolation_) - ans = "SerendipityInterpolation" + ans = poly%serendipity + CLASS IS (HermitInterpolation_) - ans = "HermitInterpolation" + ans = poly%hermit + CLASS IS (HierarchyInterpolation_) - ans = "HierarchyInterpolation" + ans = poly%hierarchical + CLASS IS (OrthogonalInterpolation_) - ans = "OrthogonalInterpolation" + ans = poly%orthogonal + CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_tostring()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="NO CASE FOUND for type of obj2", & + routine="BaseInterpolation_toInteger()", & + line=__LINE__, unitno=stdout, file=__FILE__) + + STOP + END SELECT -END FUNCTION BaseInterpolation_ToString1 +END FUNCTION BaseInterpolation_ToInteger1 !---------------------------------------------------------------------------- -! BaseInterpolation_toInteger +! !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-09 -! summary: Returns a string name of base interpolation type - -FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) - CLASS(BaseInterpolation_), INTENT(IN) :: obj +FUNCTION BaseType_ToInteger1(name) RESULT(ans) + CHARACTER(*), INTENT(IN) :: name INTEGER(I4B) :: ans - SELECT TYPE (obj) - CLASS IS (LagrangeInterpolation_) - ans = LagrangePolynomial - CLASS IS (SerendipityInterpolation_) - ans = SerendipityPolynomial - CLASS IS (HermitInterpolation_) - ans = HermitPolynomial - CLASS IS (HierarchyInterpolation_) - ans = HeirarchicalPolynomial - CLASS IS (OrthogonalInterpolation_) - ans = OrthogonalPolynomial - CLASS DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of obj2", & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_toInteger()", & - & file=__FILE__ & - & ) + + CHARACTER(4) :: astr + + astr = UpperCase(name(1:4)) + + SELECT CASE (astr) + CASE ("MONO") + ans = poly%monomial + + CASE ("LAGR") + ans = poly%lagrange + + CASE ("SERE") + ans = poly%serendipity + + CASE ("HERM") + ans = poly%hermit + + CASE ("HIER", "HEIR") + ans = poly%hierarchical + + CASE ("ORTH") + ans = poly%orthogonal + + CASE DEFAULT + CALL ErrorMsg(msg="NO CASE FOUND for name: "//astr, & + routine="BaseType_ToInteger1()", & + line=__LINE__, unitno=stdout, file=__FILE__) + STOP + END SELECT -END FUNCTION BaseInterpolation_ToInteger1 +END FUNCTION BaseType_ToInteger1 !---------------------------------------------------------------------------- ! BaseInterpolation_toInteger @@ -208,242 +219,331 @@ FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) CHARACTER(*), INTENT(IN) :: name INTEGER(I4B) :: ans - SELECT CASE (TRIM(UpperCase(name))) + CHARACTER(:), ALLOCATABLE :: astr + + astr = UpperCase(name) + + SELECT CASE (astr) + CASE ("EQUIDISTANCE") - ans = Equidistance + ans = ip%equidistance CASE ("GAUSSLEGENDRE") - ans = GaussLegendre + ans = ip%GaussLegendre CASE ("GAUSSLEGENDRELOBATTO") - ans = GaussLegendreLobatto + ans = ip%GaussLegendreLobatto CASE ("GAUSSLEGENDRERADAU") - ans = GaussLegendreRadau + ans = ip%GaussLegendreRadau CASE ("GAUSSLEGENDRERADAULEFT") - ans = GaussLegendreRadauLeft + ans = ip%GaussLegendreRadauLeft CASE ("GAUSSLEGENDRERADAURIGHT") - ans = GaussLegendreRadauRight + ans = ip%GaussLegendreRadauRight CASE ("GAUSSCHEBYSHEV") - ans = GaussChebyshev + ans = ip%GaussChebyshev CASE ("GAUSSCHEBYSHEVLOBATTO") - ans = GaussChebyshevLobatto + ans = ip%GaussChebyshevLobatto CASE ("GAUSSCHEBYSHEVRADAU") - ans = GaussChebyshevRadau + ans = ip%GaussChebyshevRadau CASE ("GAUSSCHEBYSHEVRADAULEFT") - ans = GaussChebyshevRadauLeft + ans = ip%GaussChebyshevRadauLeft CASE ("GAUSSCHEBYSHEVRADAURIGHT") - ans = GaussChebyshevRadauRight + ans = ip%GaussChebyshevRadauRight CASE ("GAUSSJACOBI") - ans = GaussJacobi + ans = ip%GaussJacobi CASE ("GAUSSJACOBILOBATTO") - ans = GaussJacobiLobatto + ans = ip%GaussJacobiLobatto CASE ("GAUSSJACOBIRADAU") - ans = GaussJacobiRadau + ans = ip%GaussJacobiRadau CASE ("GAUSSJACOBIRADAULEFT") - ans = GaussJacobiRadauLeft + ans = ip%GaussJacobiRadauLeft CASE ("GAUSSJACOBIRADAURIGHT") - ans = GaussJacobiRadauRight + ans = ip%GaussJacobiRadauRight CASE ("GAUSSULTRASPHERICAL") - ans = GaussUltraspherical + ans = ip%GaussUltraspherical CASE ("GAUSSULTRASPHERICALLOBATTO") - ans = GaussUltrasphericalLobatto + ans = ip%GaussUltrasphericalLobatto CASE ("GAUSSULTRASPHERICALRADAU") - ans = GaussUltrasphericalRadau + ans = ip%GaussUltrasphericalRadau CASE ("GAUSSULTRASPHERICALRADAULEFT") - ans = GaussUltrasphericalRadauLeft + ans = ip%GaussUltrasphericalRadauLeft CASE ("GAUSSULTRASPHERICALRADAURIGHT") - ans = GaussUltrasphericalRadauRight + ans = ip%GaussUltrasphericalRadauRight CASE DEFAULT + ans = -1_I4B - CALL Errormsg(& - & msg="No case found for given baseInterpolation name", & - & file=__FILE__, & - & line=__LINE__,& - & routine="BaseInterpolation_ToInteger2()", & - & unitno=stderr) - RETURN + CALL Errormsg(msg="No case found for baseInterpolation ="//name, & + routine="BaseInterpolation_ToInteger2()", & + file=__FILE__, line=__LINE__, unitno=stderr) + STOP END SELECT + + astr = "" END FUNCTION BaseInterpolation_ToInteger2 !---------------------------------------------------------------------------- -! BaseInterpolation_fromString +! BaseInterpolation_fromInteger !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -SUBROUTINE BaseInterpolation_FromString(obj, name) +SUBROUTINE BaseInterpolation_FromInteger(obj, name) CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj + INTEGER(I4B), INTENT(IN) :: name + + SELECT CASE (name) + CASE (poly%lagrange) + ALLOCATE (LagrangeInterpolation_ :: obj) + + CASE (poly%serendipity) + ALLOCATE (SerendipityInterpolation_ :: obj) + + CASE (poly%hermit) + ALLOCATE (HermitInterpolation_ :: obj) + + CASE (poly%orthogonal) + ALLOCATE (OrthogonalInterpolation_ :: obj) + + CASE (poly%hierarchical) + ALLOCATE (HierarchyInterpolation_ :: obj) + + CASE DEFAULT + CALL ErrorMsg(msg="NO CASE FOUND for given name="//tostring(name), & + routine="BaseInterpolation_fromInteger()", & + line=__LINE__, unitno=stdout, file=__FILE__) + STOP + END SELECT + +END SUBROUTINE BaseInterpolation_FromInteger + +!---------------------------------------------------------------------------- +! BaseInterpolation_fromString +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-09 +! summary: Returns a string name of base interpolation type + +SUBROUTINE BaseInterpolation_FromString(obj, name) + CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(INOUT) :: obj CHARACTER(*), INTENT(IN) :: name - TYPE(String) :: ans - ans = UpperCase(name) + CHARACTER(4) :: ans + + ans = UpperCase(name(1:4)) + IF (ALLOCATED(obj)) DEALLOCATE (obj) - SELECT CASE (ans%chars()) - CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION") + SELECT CASE (ans) + + CASE ("LAGR") ALLOCATE (LagrangeInterpolation_ :: obj) - CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION") + + CASE ("SERE") ALLOCATE (SerendipityInterpolation_ :: obj) - CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION") + + CASE ("HERM") ALLOCATE (HermitInterpolation_ :: obj) - CASE ( & - & "HIERARCHICALPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHICALPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION") + + CASE ("HIER", "HEIR") ALLOCATE (HierarchyInterpolation_ :: obj) - CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION") + + CASE ("ORTH") ALLOCATE (OrthogonalInterpolation_ :: obj) + CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for type of name="//TRIM(name), & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_fromString()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="NO CASE FOUND for type of name="//name, & + routine="BaseInterpolation_fromString()", & + line=__LINE__, unitno=stderr, file=__FILE__) + STOP END SELECT + END SUBROUTINE BaseInterpolation_FromString !---------------------------------------------------------------------------- -! BaseInterpolation_fromInteger +! BaseInterpolation_toString !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -SUBROUTINE BaseInterpolation_FromInteger(obj, name) - CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj +FUNCTION BaseInterpolation_ToString1(obj) RESULT(ans) + CLASS(BaseInterpolation_), INTENT(IN) :: obj + TYPE(String) :: ans + + SELECT TYPE (obj) + CLASS IS (LagrangeInterpolation_) + ans = "LagrangeInterpolation" + + CLASS IS (SerendipityInterpolation_) + ans = "SerendipityInterpolation" + + CLASS IS (HermitInterpolation_) + ans = "HermitInterpolation" + + CLASS IS (HierarchyInterpolation_) + ans = "HierarchyInterpolation" + + CLASS IS (OrthogonalInterpolation_) + ans = "OrthogonalInterpolation" + + CLASS DEFAULT + CALL ErrorMsg(msg="No Case Found For Type of obj2", & + routine="BaseInterpolation_ToString1()", & + line=__LINE__, unitno=stdout, file=__FILE__) + STOP + END SELECT + +END FUNCTION BaseInterpolation_ToString1 + +!---------------------------------------------------------------------------- +! BaseType_ToChar +!---------------------------------------------------------------------------- + +FUNCTION BaseType_ToChar(name) RESULT(ans) INTEGER(I4B), INTENT(IN) :: name + CHARACTER(:), ALLOCATABLE :: ans SELECT CASE (name) - CASE (LagrangePolynomial) - ALLOCATE (LagrangeInterpolation_ :: obj) - CASE (SerendipityPolynomial) - ALLOCATE (SerendipityInterpolation_ :: obj) - CASE (HermitPolynomial) - ALLOCATE (HermitInterpolation_ :: obj) - CASE (OrthogonalPolynomial) - ALLOCATE (OrthogonalInterpolation_ :: obj) - CASE (HeirarchicalPolynomial) - ALLOCATE (HierarchyInterpolation_ :: obj) + CASE (poly%monomial) + ans = "Monomial" + + CASE (poly%lagrange) + ans = "LagrangeInterpolation" + + CASE (poly%serendipity) + ans = "SerendipityInterpolation" + + CASE (poly%hermit) + ans = "HermitInterpolation" + + CASE (poly%hierarchical) + ans = "HierarchyInterpolation" + + CASE (poly%orthogonal) + ans = "OrthogonalInterpolation" + CASE DEFAULT - CALL ErrorMsg(& - & msg="NO CASE FOUND for given name="//tostring(name), & - & line=__LINE__, & - & unitno=stdout, & - & routine="BaseInterpolation_fromInteger()", & - & file=__FILE__ & - & ) + CALL ErrorMsg(msg="No Case Found For name "//tostring(name), & + routine="BaseType_ToChar()", & + line=__LINE__, unitno=stdout, file=__FILE__) + STOP END SELECT -END SUBROUTINE BaseInterpolation_FromInteger +END FUNCTION BaseType_ToChar !---------------------------------------------------------------------------- -! QuadraturePointIDToName +! QuadraturePointIDToName !---------------------------------------------------------------------------- FUNCTION BaseInterpolation_ToString2(name) RESULT(ans) INTEGER(I4B), INTENT(IN) :: name TYPE(String) :: ans + ans = BaseInterpolation_ToChar(name) +END FUNCTION BaseInterpolation_ToString2 + +!---------------------------------------------------------------------------- +! BaseInterpolation_ToChar +!---------------------------------------------------------------------------- + +FUNCTION BaseInterpolation_ToChar(name) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: name + CHARACTER(:), ALLOCATABLE :: ans SELECT CASE (name) - CASE (Equidistance) - ans = "EQUIDISTANCE" + CASE (ip%equidistance) + ans = "Equidistance" - CASE (GaussLegendre) - ans = "GAUSSLEGENDRE" + CASE (ip%GaussLegendre) + ans = "GaussLegendre" - CASE (GaussLegendreLobatto) - ans = "GAUSSLEGENDRELOBATTO" + CASE (ip%GaussLegendreLobatto) + ans = "GaussLegendreLobatto" - CASE (GaussLegendreRadau) - ans = "GAUSSLEGENDRERADAU" + CASE (ip%GaussLegendreRadau) + ans = "GaussLegendreRadau" - CASE (GaussLegendreRadauLeft) - ans = "GAUSSLEGENDRERADAULEFT" + CASE (ip%GaussLegendreRadauLeft) + ans = "GaussLegendreRadauLeft" - CASE (GaussLegendreRadauRight) - ans = "GAUSSLEGENDRERADAURIGHT" + CASE (ip%GaussLegendreRadauRight) + ans = "GaussLegendreRadauRight" - CASE (GaussChebyshev) - ans = "GAUSSCHEBYSHEV" + CASE (ip%GaussChebyshev) + ans = "GaussChebyshev" - CASE (GaussChebyshevLobatto) - ans = "GAUSSCHEBYSHEVLOBATTO" + CASE (ip%GaussChebyshevLobatto) + ans = "GaussChebyshevLobatto" - CASE (GaussChebyshevRadau) - ans = "GAUSSCHEBYSHEVRADAU" + CASE (ip%GaussChebyshevRadau) + ans = "GaussChebyshevRadau" - CASE (GaussChebyshevRadauLeft) - ans = "GAUSSCHEBYSHEVRADAULEFT" + CASE (ip%GaussChebyshevRadauLeft) + ans = "GaussChebyshevRadauLeft" - CASE (GaussChebyshevRadauRight) - ans = "GAUSSCHEBYSHEVRADAURIGHT" + CASE (ip%GaussChebyshevRadauRight) + ans = "GaussChebyshevRadauRight" - CASE (GaussJacobi) - ans = "GAUSSJACOBI" + CASE (ip%GaussJacobi) + ans = "GaussJacobi" - CASE (GaussJacobiLobatto) - ans = "GAUSSJACOBILOBATTO" + CASE (ip%GaussJacobiLobatto) + ans = "GaussJacobiLobatto" - CASE (GaussJacobiRadau) - ans = "GAUSSJACOBIRADAU" + CASE (ip%GaussJacobiRadau) + ans = "GaussJacobiRadau" - CASE (GaussJacobiRadauLeft) - ans = "GAUSSJACOBIRADAULEFT" + CASE (ip%GaussJacobiRadauLeft) + ans = "GaussJacobiRadauLeft" - CASE (GaussJacobiRadauRight) - ans = "GAUSSJACOBIRADAURIGHT" + CASE (ip%GaussJacobiRadauRight) + ans = "GaussJacobiRadauRight" - CASE (GaussUltraspherical) - ans = "GAUSSULTRASPHERICAL" + CASE (ip%GaussUltraspherical) + ans = "GaussUltraspherical" - CASE (GaussUltrasphericalLobatto) - ans = "GAUSSULTRASPHERICALLOBATTO" + CASE (ip%GaussUltrasphericalLobatto) + ans = "GaussUltrasphericalLobatto" - CASE (GaussUltrasphericalRadau) - ans = "GAUSSULTRASPHERICALRADAU" + CASE (ip%GaussUltrasphericalRadau) + ans = "GaussUltrasphericalRadau" - CASE (GaussUltrasphericalRadauLeft) - ans = "GAUSSULTRASPHERICALRADAULEFT" + CASE (ip%GaussUltrasphericalRadauLeft) + ans = "GaussUltrasphericalRadauLeft" - CASE (GaussUltrasphericalRadauRight) - ans = "GAUSSULTRASPHERICALRADAURIGHT" + CASE (ip%GaussUltrasphericalRadauRight) + ans = "GaussUltrasphericalRadauRight" CASE DEFAULT - CALL Errormsg(& - & msg="No case found for given quadratureType name", & - & file=__FILE__, & - & line=__LINE__,& - & routine="QuadraturePointIDToName()", & - & unitno=stderr) - RETURN + CALL Errormsg(msg="No case found for given quadratureType name", & + routine="BaseInterpolation_ToChar()", & + file=__FILE__, line=__LINE__, unitno=stderr) + ans = "" + STOP END SELECT -END FUNCTION BaseInterpolation_ToString2 + +END FUNCTION BaseInterpolation_ToChar END MODULE BaseInterpolation_Method From aed5e2687ee8ccd9356bcb4f80ca4d73cfa230dd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:27:28 +0900 Subject: [PATCH 293/359] Updats in base type --- src/modules/BaseType/src/BaseType.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index ecc3e7eb1..ab3584f78 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -1893,6 +1893,7 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: Gauss = GaussQP INTEGER(I4B) :: GaussLegendre = GaussLegendreQP INTEGER(I4B) :: GaussLegendreLobatto = GaussLegendreLobattoQP + INTEGER(I4B) :: GaussLegendreRadau = GaussLegendreRadau INTEGER(I4B) :: GaussLegendreRadauLeft = GaussLegendreRadauLeft INTEGER(I4B) :: GaussLegendreRadauRight = GaussLegendreRadauRight INTEGER(I4B) :: GaussRadau = GaussRadauQP @@ -1901,14 +1902,17 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: GaussLobatto = GaussLobattoQP INTEGER(I4B) :: GaussChebyshev = GaussChebyshevQP INTEGER(I4B) :: GaussChebyshevLobatto = GaussChebyshevLobattoQP + INTEGER(I4B) :: GaussChebyshevRadau = GaussChebyshevRadau INTEGER(I4B) :: GaussChebyshevRadauLeft = GaussChebyshevRadauLeft INTEGER(I4B) :: GaussChebyshevRadauRight = GaussChebyshevRadauRight INTEGER(I4B) :: GaussJacobi = GaussJacobiQP INTEGER(I4B) :: GaussJacobiLobatto = GaussJacobiLobattoQP + INTEGER(I4B) :: GaussJacobiRadau = GaussJacobiRadau INTEGER(I4B) :: GaussJacobiRadauLeft = GaussJacobiRadauLeft INTEGER(I4B) :: GaussJacobiRadauRight = GaussJacobiRadauRight INTEGER(I4B) :: GaussUltraSpherical = GaussUltraSphericalQP INTEGER(I4B) :: GaussUltraSphericalLobatto = GaussUltraSphericalLobattoQP + INTEGER(I4B) :: GaussUltraSphericalRadau = GaussUltraSphericalRadau INTEGER(I4B) :: GaussUltraSphericalRadauLeft = GaussUltraSphericalRadauLeft INTEGER(I4B) :: GaussUltraSphericalRadauRight = & GaussUltraSphericalRadauRight From f2929de1159d48b1e0938901e108aa1f2e661c6e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:27:36 +0900 Subject: [PATCH 294/359] updates in csrmatrix add methods --- .../CSRMatrix/src/CSRMatrix_AddMethods.F90 | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 index 90411faa2..245733347 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 @@ -177,7 +177,7 @@ END SUBROUTINE obj_Add5 INTERFACE Add MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, & - & ivar, jvar, VALUE, scale) + ivar, jvar, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum(:) INTEGER(I4B), INTENT(IN) :: jNodeNum(:) @@ -247,8 +247,8 @@ END SUBROUTINE obj_Add7 ! summary: Adds the specific row and column entry to a given value INTERFACE Add - MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE, scale) + MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, & + jvar, iDOF, jDOF, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum(:) !! row node number @@ -297,8 +297,8 @@ END SUBROUTINE obj_Add8 !@endnote INTERFACE Add - MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) + MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, & + jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number @@ -339,7 +339,7 @@ END SUBROUTINE obj_Add9 INTERFACE Add MODULE PURE SUBROUTINE obj_Add10(obj, iNodeNum, jNodeNum, & - & ivar, jvar, VALUE, scale) + ivar, jvar, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum(:) INTEGER(I4B), INTENT(IN) :: jNodeNum(:) @@ -359,8 +359,8 @@ END SUBROUTINE obj_Add10 ! summary: Adds the specific row and column entry to a given value INTERFACE Add - MODULE PURE SUBROUTINE obj_Add11(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE, scale) + MODULE PURE SUBROUTINE obj_Add11(obj, iNodeNum, jNodeNum, ivar, & + jvar, iDOF, jDOF, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum(:) !! row node number @@ -389,8 +389,8 @@ END SUBROUTINE obj_Add11 ! summary: Adds the specific row and column entry to a given value INTERFACE Add - MODULE PURE SUBROUTINE obj_Add12(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) + MODULE PURE SUBROUTINE obj_Add12(obj, iNodeNum, jNodeNum, ivar, & + jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum(:) !! row node number @@ -419,17 +419,17 @@ END SUBROUTINE obj_Add12 ! summary: Adds the specific row and column entry to a given value INTERFACE Add - MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, & - & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) + MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, & + jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum(:) !! row node number INTEGER(I4B), INTENT(IN) :: jNodeNum(:) !! column node number INTEGER(I4B), INTENT(IN) :: ivar - !! + !! row variable INTEGER(I4B), INTENT(IN) :: jvar - !! + !! column variable INTEGER(I4B), INTENT(IN) :: ispacecompo INTEGER(I4B), INTENT(IN) :: itimecompo(:) INTEGER(I4B), INTENT(IN) :: jspacecompo From ae82a434c8fc0c0d718e58c5c813910fc300e619 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:27:46 +0900 Subject: [PATCH 295/359] updates in dof constructor methods --- .../DOF/src/DOF_ConstructorMethods.F90 | 54 +++++++++---------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/modules/DOF/src/DOF_ConstructorMethods.F90 b/src/modules/DOF/src/DOF_ConstructorMethods.F90 index f70e5bd71..d0dec8331 100644 --- a/src/modules/DOF/src/DOF_ConstructorMethods.F90 +++ b/src/modules/DOF/src/DOF_ConstructorMethods.F90 @@ -37,18 +37,18 @@ MODULE DOF_ConstructorMethods !> author: Vikas Sharma, Ph. D. ! date: 23 Feb 2021 -! summary: This subroutine initiate DOF_ object +! summary: This subroutine Initiate DOF_ object ! !# Introduction ! -! This subroutine initiate DOF_ object +! This subroutine Initiate DOF_ object ! !- If the size of all physical variables are equal then set ! tNodes = [tNodes] otherwise we need to provide size of each dof !- For a scalar physical variable such as pressure and temperature, ! `spacecompo` is set to -1. !- For a time independent physical variable `timecompo` is set to 1. -!- The size of `Names`, `spacecompo`, `timecompo` should be same +!- The size of `names`, `spacecompo`, `timecompo` should be same ! !@note ! $\matbf{v}$ is a physical variable, however, @@ -56,21 +56,21 @@ MODULE DOF_ConstructorMethods !@endnote INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate1(obj, tNodes, Names, spacecompo, & - & timecompo, StorageFMT) + MODULE PURE SUBROUTINE obj_Initiate1(obj, tNodes, names, spacecompo, & + timecompo, storagefmt) CLASS(DOF_), INTENT(INOUT) :: obj !! degree of freedom object INTEGER(I4B), INTENT(IN) :: tNodes(:) !! number of nodes for each physical variable - CHARACTER(1), INTENT(IN) :: Names(:) - !! Names of each physical variable + CHARACTER(1), INTENT(IN) :: names(:) + !! names of each physical variable INTEGER(I4B), INTENT(IN) :: spacecompo(:) !! Space component of each physical variable INTEGER(I4B), INTENT(IN) :: timecompo(:) !! Time component of each physical variable - INTEGER(I4B), INTENT(IN) :: StorageFMT + INTEGER(I4B), INTENT(IN) :: storagefmt !! Storage format `FMT_DOF`, `FMT_Nodes` - END SUBROUTINE obj_initiate1 + END SUBROUTINE obj_Initiate1 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -83,18 +83,18 @@ END SUBROUTINE obj_initiate1 ! !# Introduction ! -! This subroutine initiates a fortran vector (rank-1 fortran array ) of +! This subroutine Initiates a fortran vector (rank-1 fortran array ) of ! real using the information stored inside DOF_ object. This subroutine ! gets the size of array from the DOF_ object and then reallocates ! `val` and set its all values to zero. INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate2(val, obj) + MODULE PURE SUBROUTINE obj_Initiate2(val, obj) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: val(:) - !! This vector will be initiated by using obj + !! This vector will be Initiated by using obj CLASS(DOF_), INTENT(IN) :: obj !! DOF object - END SUBROUTINE obj_initiate2 + END SUBROUTINE obj_Initiate2 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -107,14 +107,14 @@ END SUBROUTINE obj_initiate2 ! !# Introduction ! -! This subroutine can initiate two fortran vectors (rank-1 fortran arrays) +! This subroutine can Initiate two fortran vectors (rank-1 fortran arrays) ! using the information stored inside the DOF_ object INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate3(Val1, Val2, obj) + MODULE PURE SUBROUTINE obj_Initiate3(Val1, Val2, obj) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Val1(:), Val2(:) CLASS(DOF_), INTENT(IN) :: obj - END SUBROUTINE obj_initiate3 + END SUBROUTINE obj_Initiate3 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -130,14 +130,14 @@ END SUBROUTINE obj_initiate3 ! This routine copy obj2 into obj1. It also define an assignment operator INTERFACE Initiate - MODULE PURE SUBROUTINE obj_initiate4(obj1, obj2) + MODULE PURE SUBROUTINE obj_Initiate4(obj1, obj2) CLASS(DOF_), INTENT(INOUT) :: obj1 CLASS(DOF_), INTENT(IN) :: obj2 - END SUBROUTINE obj_initiate4 + END SUBROUTINE obj_Initiate4 END INTERFACE Initiate INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE obj_initiate4 + MODULE PROCEDURE obj_Initiate4 END INTERFACE ASSIGNMENT(=) !---------------------------------------------------------------------------- @@ -155,12 +155,12 @@ END SUBROUTINE obj_initiate4 ! for more see dof_ INTERFACE DOF - MODULE PURE FUNCTION obj_Constructor1(tNodes, Names, spacecompo, timecompo, & - & StorageFMT) RESULT(obj) + MODULE PURE FUNCTION obj_Constructor1(tNodes, names, spacecompo, timecompo, & + & storagefmt) RESULT(obj) TYPE(DOF_) :: obj INTEGER(I4B), INTENT(IN) :: tNodes(:), spacecompo(:), & - & timecompo(:), StorageFMT - CHARACTER(1), INTENT(IN) :: Names(:) + & timecompo(:), storagefmt + CHARACTER(1), INTENT(IN) :: names(:) END FUNCTION obj_Constructor1 END INTERFACE DOF @@ -178,19 +178,19 @@ END FUNCTION obj_Constructor1 ! for more see dof_ INTERFACE DOF_Pointer - MODULE FUNCTION obj_Constructor_1(tNodes, Names, spacecompo, timecompo, & - & StorageFMT) RESULT(obj) + MODULE FUNCTION obj_Constructor_1(tNodes, names, spacecompo, timecompo, & + & storagefmt) RESULT(obj) CLASS(DOF_), POINTER :: obj !! dof_ object INTEGER(I4B), INTENT(IN) :: tNodes(:) !! total number of nodes for each dof - CHARACTER(1), INTENT(IN) :: Names(:) + CHARACTER(1), INTENT(IN) :: names(:) !! name of each dof INTEGER(I4B), INTENT(IN) :: spacecompo(:) !! space components for each dof INTEGER(I4B), INTENT(IN) :: timecompo(:) !! time component for each dof - INTEGER(I4B), INTENT(IN) :: StorageFMT + INTEGER(I4B), INTENT(IN) :: storagefmt !! storage format for dof END FUNCTION obj_Constructor_1 END INTERFACE DOF_Pointer From 740e83940572bce21d5cf4f2b1ef82c7c77e4929 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:27:58 +0900 Subject: [PATCH 296/359] updates in interpolation utility --- src/modules/Polynomial/src/InterpolationUtility.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/modules/Polynomial/src/InterpolationUtility.F90 b/src/modules/Polynomial/src/InterpolationUtility.F90 index d2e860faa..bfe3038ad 100644 --- a/src/modules/Polynomial/src/InterpolationUtility.F90 +++ b/src/modules/Polynomial/src/InterpolationUtility.F90 @@ -20,7 +20,9 @@ MODULE InterpolationUtility USE String_Class, ONLY: String IMPLICIT NONE + PRIVATE + PUBLIC :: VandermondeMatrix PUBLIC :: GetTotalInDOF PUBLIC :: GetTotalDOF From 1ca6669b094387b89284f49af21d5156d12bb418 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:28:12 +0900 Subject: [PATCH 297/359] update in jacobi polynomial Utility --- .../src/JacobiPolynomialUtility.F90 | 132 ++++++++++++++++-- 1 file changed, 117 insertions(+), 15 deletions(-) diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index bc14e9fe0..dc806f081 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -24,8 +24,11 @@ MODULE JacobiPolynomialUtility USE GlobalData USE BaseType, ONLY: iface_1DFunction + IMPLICIT NONE + PRIVATE + PUBLIC :: GetJacobiRecurrenceCoeff PUBLIC :: GetJacobiRecurrenceCoeff2 PUBLIC :: JacobiAlpha @@ -52,6 +55,7 @@ MODULE JacobiPolynomialUtility PUBLIC :: JacobiGradientEvalAll_ PUBLIC :: JacobiGradientEvalSum PUBLIC :: JacobiTransform +PUBLIC :: JacobiTransform_ PUBLIC :: JacobiInvTransform PUBLIC :: JacobiGradientCoeff PUBLIC :: JacobiDMatrix @@ -70,7 +74,7 @@ MODULE JacobiPolynomialUtility INTERFACE MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff(n, alpha, beta, & - & alphaCoeff, betaCoeff) + alphaCoeff, betaCoeff) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial, it should be greater than 1 REAL(DFP), INTENT(IN) :: alpha @@ -99,7 +103,7 @@ END SUBROUTINE GetJacobiRecurrenceCoeff INTERFACE MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff2(n, alpha, beta, & - & A, B, C) + A, B, C) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial, it should be greater than 1 REAL(DFP), INTENT(IN) :: alpha @@ -269,7 +273,7 @@ END FUNCTION JacobiNormSQRRatio INTERFACE MODULE PURE SUBROUTINE JacobiJacobiMatrix(n, alpha, beta, D, E, & - & alphaCoeff, betaCoeff) + alphaCoeff, betaCoeff) INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 REAL(DFP), INTENT(IN) :: alpha @@ -320,7 +324,7 @@ END SUBROUTINE JacobiGaussQuadrature INTERFACE MODULE PURE SUBROUTINE JacobiJacobiRadauMatrix(a, n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff) + E, alphaCoeff, betaCoeff) REAL(DFP), INTENT(IN) :: a !! one of the end of the domain INTEGER(I4B), INTENT(IN) :: n @@ -387,7 +391,7 @@ END SUBROUTINE JacobiGaussRadauQuadrature INTERFACE MODULE PURE SUBROUTINE JacobiJacobiLobattoMatrix(n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff) + E, alphaCoeff, betaCoeff) INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 REAL(DFP), INTENT(IN) :: alpha @@ -869,7 +873,7 @@ END FUNCTION JacobiGradientEvalSum1 INTERFACE JacobiGradientEvalSum MODULE PURE FUNCTION JacobiGradientEvalSum2(n, alpha, beta, x, coeff) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: alpha @@ -896,7 +900,7 @@ END FUNCTION JacobiGradientEvalSum2 INTERFACE JacobiGradientEvalSum MODULE PURE FUNCTION JacobiGradientEvalSum3(n, alpha, beta, x, coeff, k) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: alpha @@ -925,7 +929,7 @@ END FUNCTION JacobiGradientEvalSum3 INTERFACE JacobiGradientEvalSum MODULE PURE FUNCTION JacobiGradientEvalSum4(n, alpha, beta, x, coeff, k) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: alpha @@ -953,7 +957,7 @@ END FUNCTION JacobiGradientEvalSum4 INTERFACE JacobiTransform MODULE PURE FUNCTION JacobiTransform1(n, alpha, beta, coeff, x, w, & - & quadType) RESULT(ans) + quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: alpha @@ -974,6 +978,35 @@ MODULE PURE FUNCTION JacobiTransform1(n, alpha, beta, coeff, x, w, & END FUNCTION JacobiTransform1 END INTERFACE JacobiTransform +!---------------------------------------------------------------------------- +! JacobiTransform_ +!---------------------------------------------------------------------------- + +INTERFACE JacobiTransform_ + MODULE PURE SUBROUTINE JacobiTransform1_(n, alpha, beta, coeff, x, w, & + quadType, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! n+1 + END SUBROUTINE JacobiTransform1_ +END INTERFACE JacobiTransform_ + !---------------------------------------------------------------------------- ! JacobiTransform !---------------------------------------------------------------------------- @@ -984,7 +1017,7 @@ END FUNCTION JacobiTransform1 INTERFACE JacobiTransform MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & - & quadType) RESULT(ans) + quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: alpha @@ -1005,6 +1038,41 @@ MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & END FUNCTION JacobiTransform2 END INTERFACE JacobiTransform +!---------------------------------------------------------------------------- +! JacobiTransform_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Jacobi transform + +INTERFACE JacobiTransform_ + MODULE PURE SUBROUTINE JacobiTransform2_(n, alpha, beta, coeff, x, w, & + quadType, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = n+1 + !! ncol = SIZE(coeff, 2) + END SUBROUTINE JacobiTransform2_ +END INTERFACE JacobiTransform_ + !---------------------------------------------------------------------------- ! JacobiTransform !---------------------------------------------------------------------------- @@ -1012,7 +1080,7 @@ END FUNCTION JacobiTransform2 !> author: Vikas Sharma, Ph. D. ! date: 13 Oct 2022 ! summary: Discrete Jacobi Transform of a function on [-1,1] -! + !# Introduction ! ! This function performs the jacobi transformation of a function defined @@ -1034,8 +1102,8 @@ END FUNCTION JacobiTransform2 !@endnote INTERFACE JacobiTransform - MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType) & - & RESULT(ans) + MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType, x1, x2) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: alpha @@ -1047,11 +1115,45 @@ MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType) & INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 + !! domain of function f REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION JacobiTransform3 END INTERFACE JacobiTransform +!---------------------------------------------------------------------------- +! JacobiTransform_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Jacobi transform + +INTERFACE JacobiTransform_ + MODULE SUBROUTINE JacobiTransform3_(n, alpha, beta, f, quadType, x1, x2, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 + !! domain of function f + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! n+1 + END SUBROUTINE JacobiTransform3_ +END INTERFACE JacobiTransform_ + !---------------------------------------------------------------------------- ! JacobiInvTransform !---------------------------------------------------------------------------- @@ -1062,7 +1164,7 @@ END FUNCTION JacobiTransform3 INTERFACE JacobiInvTransform MODULE PURE FUNCTION JacobiInvTransform1(n, alpha, beta, coeff, x) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: alpha @@ -1088,7 +1190,7 @@ END FUNCTION JacobiInvTransform1 INTERFACE JacobiInvTransform MODULE PURE FUNCTION JacobiInvTransform2(n, alpha, beta, coeff, x) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: alpha From b47119da7270174d7d56bd4578f2fac0afe9857b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:28:28 +0900 Subject: [PATCH 298/359] update in LegendrePolynomialUtility --- .../src/LegendrePolynomialUtility.F90 | 109 ++++++++++++++++-- 1 file changed, 98 insertions(+), 11 deletions(-) diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index 783a86868..0963efee0 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -54,6 +54,7 @@ MODULE LegendrePolynomialUtility PUBLIC :: LegendreEvalSum PUBLIC :: LegendreGradientEvalSum PUBLIC :: LegendreTransform +PUBLIC :: LegendreTransform_ PUBLIC :: LegendreInvTransform PUBLIC :: LegendreGradientCoeff PUBLIC :: LegendreDMatrix @@ -942,23 +943,59 @@ END FUNCTION LegendreGradientEvalSum4 INTERFACE LegendreTransform MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & - & quadType) RESULT(ans) + quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomials + !! n+1 coefficient (modal values) REAL(DFP), INTENT(IN) :: coeff(0:n) - !! nodal value (at quad points) + !! value of function at quadrature points REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points + !! These quadrature points are used in LegendreEvalAll method REAL(DFP), INTENT(IN) :: w(0:n) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight REAL(DFP) :: ans(0:n) - !! modal values or coefficients + !! modal values or coefficients of Legendre polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on END FUNCTION LegendreTransform1 END INTERFACE LegendreTransform +!---------------------------------------------------------------------------- +! LegendreTransform@Methods +!---------------------------------------------------------------------------- + +INTERFACE LegendreTransform_ + MODULE PURE SUBROUTINE LegendreTransform1_(n, coeff, x, w, quadType, ans, & + tsize) + INTEGER(I4B), INTENT(IN) :: n + !! Order of Legendre polynomials + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Value of function at quadrature points + REAL(DFP), INTENT(IN) :: x(0:n) + !! Quadrature points + !! These quadrature points are used in LegendreEvalAll method + REAL(DFP), INTENT(IN) :: w(0:n) + !! Weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients of Legendre polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on + ! REAL(DFP) :: ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE LegendreTransform1_ +END INTERFACE LegendreTransform_ + !---------------------------------------------------------------------------- ! LegendreTransform !---------------------------------------------------------------------------- @@ -969,11 +1006,11 @@ END FUNCTION LegendreTransform1 INTERFACE LegendreTransform MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & - & quadType) RESULT(ans) + quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) + !! values of function at quadrature points REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points REAL(DFP), INTENT(IN) :: w(0:n) @@ -986,6 +1023,32 @@ MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & END FUNCTION LegendreTransform2 END INTERFACE LegendreTransform +!---------------------------------------------------------------------------- +! LegendreTransform@Methods +!---------------------------------------------------------------------------- + +INTERFACE LegendreTransform_ + MODULE PURE SUBROUTINE LegendreTransform2_(n, coeff, x, w, & + quadType, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! values of function at quadrature points + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! modal values or coefficients for each column of val + ! REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns writen in ans + END SUBROUTINE LegendreTransform2_ +END INTERFACE LegendreTransform_ + !---------------------------------------------------------------------------- ! LegendreTransform !---------------------------------------------------------------------------- @@ -1015,8 +1078,7 @@ END FUNCTION LegendreTransform2 !@endnote INTERFACE LegendreTransform - MODULE FUNCTION LegendreTransform3(n, f, quadType) & - & RESULT(ans) + MODULE FUNCTION LegendreTransform3(n, f, quadType, x1, x2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f @@ -1024,11 +1086,36 @@ MODULE FUNCTION LegendreTransform3(n, f, quadType) & INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 + !! domain of function f REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION LegendreTransform3 END INTERFACE LegendreTransform +!---------------------------------------------------------------------------- +! LegendreTransform@Methods +!---------------------------------------------------------------------------- + +INTERFACE LegendreTransform_ + MODULE SUBROUTINE LegendreTransform3_(n, f, quadType, x1, x2, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 + !! domain of function f + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients + !! ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! n+1 + END SUBROUTINE LegendreTransform3_ +END INTERFACE LegendreTransform_ + !---------------------------------------------------------------------------- ! LegendreInvTransform !---------------------------------------------------------------------------- @@ -1039,7 +1126,7 @@ END FUNCTION LegendreTransform3 INTERFACE LegendreInvTransform MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: coeff(0:n) @@ -1061,7 +1148,7 @@ END FUNCTION LegendreInvTransform1 INTERFACE LegendreInvTransform MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: coeff(0:n) @@ -1089,7 +1176,7 @@ END FUNCTION LegendreInvTransform2 INTERFACE LegendreGradientCoeff MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: coeff(0:n) @@ -1109,7 +1196,7 @@ END FUNCTION LegendreGradientCoeff1 INTERFACE LegendreDMatrix MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomial REAL(DFP), INTENT(IN) :: x(0:n) From 434885d4823742dea506ba95c1536b85b9e67b68 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:28:36 +0900 Subject: [PATCH 299/359] update in PolynomialUtility --- .../Polynomial/src/PolynomialUtility.F90 | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/modules/Polynomial/src/PolynomialUtility.F90 b/src/modules/Polynomial/src/PolynomialUtility.F90 index 362d8fcc0..2033e9cba 100644 --- a/src/modules/Polynomial/src/PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/PolynomialUtility.F90 @@ -16,21 +16,22 @@ ! MODULE PolynomialUtility +USE Chebyshev1PolynomialUtility +USE HexahedronInterpolationUtility +USE HierarchicalPolynomialUtility USE InterpolationUtility -USE LagrangePolynomialUtility -USE OrthogonalPolynomialUtility USE JacobiPolynomialUtility -USE UltrasphericalPolynomialUtility +USE LagrangePolynomialUtility USE LegendrePolynomialUtility -USE LobattoPolynomialUtility -USE UnscaledLobattoPolynomialUtility -USE Chebyshev1PolynomialUtility USE LineInterpolationUtility -USE TriangleInterpolationUtility -USE QuadrangleInterpolationUtility -USE TetrahedronInterpolationUtility -USE HexahedronInterpolationUtility +USE LobattoPolynomialUtility +USE OrthogonalPolynomialUtility USE PrismInterpolationUtility USE PyramidInterpolationUtility +USE QuadrangleInterpolationUtility USE RecursiveNodesUtility +USE TetrahedronInterpolationUtility +USE TriangleInterpolationUtility +USE UltrasphericalPolynomialUtility +USE UnscaledLobattoPolynomialUtility END MODULE PolynomialUtility From c073312e8ba307c6b55e126feed5483e8343e993 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:28:43 +0900 Subject: [PATCH 300/359] update in QuadraturePoint_Method --- .../src/QuadraturePoint_Method.F90 | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index ffedc3b1b..a0c952316 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -19,8 +19,8 @@ ! summary: This module contains the methods for data type [[QuadraturePoint_]] MODULE QuadraturePoint_Method -USE BaseType -USE GlobalData +USE BaseType, ONLY: QuadraturePoint_, ReferenceElement_ +USE GlobalData, ONLY: DFP, I4B, LGT USE String_Class, ONLY: String IMPLICIT NONE @@ -41,6 +41,7 @@ MODULE QuadraturePoint_Method PUBLIC :: Display ! PUBLIC :: QuadraturePoint_MdEncode PUBLIC :: QuadraturePointIdToName +PUBLIC :: QuadraturePoint_ToChar PUBLIC :: QuadraturePointNameToId PUBLIC :: MdEncode @@ -74,6 +75,17 @@ MODULE FUNCTION QuadraturePointIdToName(name) RESULT(ans) END FUNCTION QuadraturePointIdToName END INTERFACE +!---------------------------------------------------------------------------- +! QuadraturePoint_ToChar@ConstructorMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION QuadraturePoint_ToChar(name) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: name + TYPE(String) :: ans + END FUNCTION QuadraturePoint_ToChar +END INTERFACE + !---------------------------------------------------------------------------- ! QuadratureNumber@ConstructorMethods !---------------------------------------------------------------------------- From 20515f4ccf7dea75b8dcbbbf4d8bf080412d52fd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:28:52 +0900 Subject: [PATCH 301/359] update in realvector add methods --- .../RealVector/src/RealVector_AddMethods.F90 | 36 +++++++++---------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/modules/RealVector/src/RealVector_AddMethods.F90 b/src/modules/RealVector/src/RealVector_AddMethods.F90 index 9ee9b14dc..e0ea0f749 100644 --- a/src/modules/RealVector/src/RealVector_AddMethods.F90 +++ b/src/modules/RealVector/src/RealVector_AddMethods.F90 @@ -177,7 +177,7 @@ END SUBROUTINE obj_Add7 MODULE SUBROUTINE obj_Add8(obj, dofobj, nodenum, VALUE, & scale, conversion) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE(:) REAL(DFP), INTENT(IN) :: scale @@ -197,7 +197,7 @@ END SUBROUTINE obj_Add8 MODULE SUBROUTINE obj_Add9(obj, dofobj, nodenum, VALUE, & scale) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -216,7 +216,7 @@ END SUBROUTINE obj_Add9 MODULE SUBROUTINE obj_Add10(obj, dofobj, nodenum, VALUE, & scale, idof) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE(:) REAL(DFP), INTENT(IN) :: scale @@ -236,7 +236,7 @@ END SUBROUTINE obj_Add10 MODULE SUBROUTINE obj_Add11(obj, dofobj, nodenum, VALUE, & scale, idof) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -256,7 +256,7 @@ END SUBROUTINE obj_Add11 MODULE SUBROUTINE obj_Add12(obj, dofobj, nodenum, VALUE, & scale, ivar, idof) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE(:) REAL(DFP), INTENT(IN) :: scale @@ -277,7 +277,7 @@ END SUBROUTINE obj_Add12 MODULE SUBROUTINE obj_Add13(obj, dofobj, nodenum, VALUE, & scale, ivar, idof) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -298,7 +298,7 @@ END SUBROUTINE obj_Add13 MODULE SUBROUTINE obj_Add14(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE(:) REAL(DFP), INTENT(IN) :: scale @@ -320,7 +320,7 @@ END SUBROUTINE obj_Add14 MODULE SUBROUTINE obj_Add15(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -342,7 +342,7 @@ END SUBROUTINE obj_Add15 MODULE SUBROUTINE obj_Add16(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE(:) REAL(DFP), INTENT(IN) :: scale @@ -364,7 +364,7 @@ END SUBROUTINE obj_Add16 MODULE SUBROUTINE obj_Add17(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -386,7 +386,7 @@ END SUBROUTINE obj_Add17 MODULE SUBROUTINE obj_Add18(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE(:) REAL(DFP), INTENT(IN) :: scale @@ -408,7 +408,7 @@ END SUBROUTINE obj_Add18 MODULE SUBROUTINE obj_Add19(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -430,7 +430,7 @@ END SUBROUTINE obj_Add19 MODULE SUBROUTINE obj_Add20(obj, dofobj, nodenum, VALUE, & scale) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -449,7 +449,7 @@ END SUBROUTINE obj_Add20 MODULE SUBROUTINE obj_Add21(obj, dofobj, nodenum, VALUE, & scale, idof) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -469,7 +469,7 @@ END SUBROUTINE obj_Add21 MODULE SUBROUTINE obj_Add22(obj, dofobj, nodenum, VALUE, & scale, ivar, idof) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -490,7 +490,7 @@ END SUBROUTINE obj_Add22 MODULE SUBROUTINE obj_Add23(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -512,7 +512,7 @@ END SUBROUTINE obj_Add23 MODULE SUBROUTINE obj_Add24(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale @@ -534,7 +534,7 @@ END SUBROUTINE obj_Add24 MODULE SUBROUTINE obj_Add25(obj, dofobj, nodenum, VALUE, & scale, ivar, spacecompo, timecompo) TYPE(Realvector_), INTENT(INOUT) :: obj - CLASS(DOF_), INTENT(IN) :: dofobj + TYPE(DOF_), INTENT(IN) :: dofobj INTEGER(I4B), INTENT(IN) :: nodenum REAL(DFP), INTENT(IN) :: VALUE REAL(DFP), INTENT(IN) :: scale From 52c030d833aea928e54645364a562c9c3f5b043c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:29:02 +0900 Subject: [PATCH 302/359] update in csrsparsity method constructor methods --- src/modules/Utility/src/ProductUtility.F90 | 40 ++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index 7617e138a..58f221cf6 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -25,10 +25,50 @@ MODULE ProductUtility PUBLIC :: OuterProd PUBLIC :: OuterProd_ +PUBLIC :: OTimesTilda + PUBLIC :: Cross_Product PUBLIC :: Vector_Product PUBLIC :: VectorProduct +!---------------------------------------------------------------------------- +! OTimesTilda@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-13 +! summary: returns a space-time matrix from time and space matrix + +INTERFACE OTimesTilda + MODULE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: anscoeff + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE OTimesTilda1 +END INTERFACE OTimesTilda + +!---------------------------------------------------------------------------- +! OtimesTilda@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-13 +! summary: returns a space-time vector from time and space vector + +INTERFACE OTimesTilda + MODULE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + REAL(DFP), INTENT(IN) :: anscoeff + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE OTimesTilda2 +END INTERFACE OTimesTilda + !---------------------------------------------------------------------------- ! Cross_Product@ProductMethods !---------------------------------------------------------------------------- From 860015b962456178fc827b23e73c2efbf364c84a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:29:14 +0900 Subject: [PATCH 303/359] update in csrsparsity method constructor methods --- .../src/CSRSparsity_Method@ConstructorMethods.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 index 4f0a1cf4a..6ed92c1a6 100644 --- a/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 +++ b/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 @@ -63,11 +63,14 @@ problem = tnodes1 .NE. nrow .OR. tnodes2 .NE. ncol IF (problem) THEN CALL ErrorMSG( & - & "Size of the matrix does not conform with the dof data! "// & - & "tNodes1 = "//tostring(tnodes1)//" tNodes2="//tostring(tNodes2), & - & "CSRSparsity_Method@Constructor.F90", & - & "obj_initiate1()", & - & __LINE__, stderr) + msg="Size of the matrix does not conform with the dof data! "// & + "tNodes in idof = "//tostring(tnodes1)// & + " it should be "//tostring(nrow)// & + " tnodes in jdof ="//tostring(tNodes2)// & + " it should be "//tostring(ncol), & + file="CSRSparsity_Method@Constructor.F90", & + routine="obj_initiate1()", & + line=__LINE__, unitno=stderr) STOP END IF END IF From bf281d64930053048a28061b39c3fc0c035d4e38 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:29:35 +0900 Subject: [PATCH 304/359] updates in LegendrePolynomialUtility --- .../src/LegendrePolynomialUtility@Methods.F90 | 238 +++++++++++------- 1 file changed, 153 insertions(+), 85 deletions(-) diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index 4cf8512b6..14dc809bf 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -16,8 +16,23 @@ ! SUBMODULE(LegendrePolynomialUtility) Methods -USE BaseMethod +USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalDMatEvenOdd, & + UltrasphericalGradientCoeff + +USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix + +#ifdef USE_LAPACK95 +USE F95_Lapack, ONLY: STEV +#endif + +USE JacobiPolynomialUtility, ONLY: JacobiZeros + +USE ErrorHandling, ONLY: ErrorMsg + +USE MiscUtility, ONLY: Factorial + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -34,7 +49,7 @@ MODULE PROCEDURE LegendreBeta REAL(DFP) :: avar -!! + IF (n .EQ. 0_I4B) THEN ans = 2.0_DFP ELSE @@ -51,18 +66,18 @@ REAL(DFP), PARAMETER :: one = 1.0_DFP, two = 2.0_DFP, four = 4.0_DFP REAL(DFP) :: avar INTEGER(I4B) :: ii -!! + IF (n .LE. 0) RETURN -!! + alphaCoeff = 0.0_DFP betaCoeff(0) = two IF (n .EQ. 1) RETURN -!! + DO ii = 1, n - 1 avar = REAL(ii**2, KIND=DFP) betaCoeff(ii) = avar / (four * avar - one) END DO -!! + END PROCEDURE GetLegendreRecurrenceCoeff !---------------------------------------------------------------------------- @@ -72,16 +87,16 @@ MODULE PROCEDURE GetLegendreRecurrenceCoeff2 REAL(DFP) :: j INTEGER(I4B) :: ii -!! + IF (n .LT. 1) RETURN B = 0.0_DFP -!! + DO ii = 1, n j = REAL(ii, KIND=DFP) - A(ii - 1) = (2.0_DFP * j - 1.0_DFP) / j; - C(ii - 1) = (j - 1.0_DFP) / j; + A(ii - 1) = (2.0_DFP * j - 1.0_DFP) / j + C(ii - 1) = (j - 1.0_DFP) / j END DO -!! + END PROCEDURE GetLegendreRecurrenceCoeff2 !---------------------------------------------------------------------------- @@ -137,17 +152,17 @@ MODULE PROCEDURE LegendreJacobiMatrix REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0 -!! + IF (n .LT. 1) RETURN -!! + CALL GetLegendreRecurrenceCoeff(n=n, alphaCoeff=alphaCoeff0, & - & betaCoeff=betaCoeff0) + betaCoeff=betaCoeff0) IF (PRESENT(alphaCoeff)) alphaCoeff(0:n - 1) = alphaCoeff0 IF (PRESENT(betaCoeff)) betaCoeff(0:n - 1) = betaCoeff0 -!! + CALL JacobiMatrix(alphaCoeff=alphaCoeff0, & & betaCoeff=betaCoeff0, D=D, E=E) -!! + END PROCEDURE LegendreJacobiMatrix !---------------------------------------------------------------------------- @@ -157,12 +172,12 @@ MODULE PROCEDURE LegendreGaussQuadrature REAL(DFP) :: pn(n), fixvar INTEGER(I4B) :: ii -!! + CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) -!! + #ifdef USE_LAPACK95 CALL STEV(D=pt, E=pn) -!! + IF (PRESENT(wt)) THEN wt = pn pn = LegendreEval(n=n - 1, x=pt) @@ -171,16 +186,15 @@ wt(ii) = fixvar * (1.0_DFP - pt(ii)**2) / (pn(ii)**2) END DO END IF - !! + #else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="LegendreGaussQuadrature", & - & line=__LINE__, & - & unitno=stdout) +CALL ErrorMsg(msg="The subroutine requires Lapack95 package", & + file=__FILE__, & + routine="LegendreGaussQuadrature", & + line=__LINE__, & + unitno=stdout) #endif - !! + END PROCEDURE LegendreGaussQuadrature !---------------------------------------------------------------------------- @@ -189,21 +203,21 @@ MODULE PROCEDURE LegendreJacobiRadauMatrix REAL(DFP) :: avar, r1, r2 -!! + IF (n .LT. 1) RETURN -!! + CALL LegendreJacobiMatrix(n=n, D=D, E=E, & & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) -!! + r1 = a * REAL(n + 1, KIND=DFP) r2 = REAL(2 * n + 1, KIND=DFP) D(n + 1) = r1 / r2 -!! + r1 = REAL(n**2, KIND=DFP) r2 = 4.0_DFP * r1 - 1.0_DFP -!! + E(n) = SQRT(r1 / r2) -!! + END PROCEDURE LegendreJacobiRadauMatrix !---------------------------------------------------------------------------- @@ -926,80 +940,134 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreTransform1 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +INTEGER(I4B) :: tsize +CALL LegendreTransform1_(n=n, coeff=coeff, x=x, w=w, quadType=quadType, & + ans=ans, tsize=tsize) +END PROCEDURE LegendreTransform1 + +!---------------------------------------------------------------------------- +! LegendreTransform_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform1_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -REAL(DFP) :: rn -!! -nrmsqr = LegendreNormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP / rn -END IF -!! -PP = LegendreEvalAll(n=n, x=x) -!! +INTEGER(I4B) :: ii, jj +REAL(DFP) :: nrmsqr, areal + +tsize = n + 1 + +! PP = LegendreEvalAll(n=n, x=x) +CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) + DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / nrmsqr(jj) + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + nrmsqr = LegendreNormSQR(n=jj) + ans(jj) = areal / nrmsqr END DO -!! -END PROCEDURE LegendreTransform1 + +IF (quadType .EQ. GaussLobatto) THEN + areal = 0.0_DFP + jj = n + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + + nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) + ans(jj) = areal / nrmsqr +END IF + +END PROCEDURE LegendreTransform1_ !---------------------------------------------------------------------------- ! LegendreTransform !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreTransform2 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +INTEGER(I4B) :: ii, jj +CALL LegendreTransform2_(n=n, coeff=coeff, x=x, w=w, quadType=quadType, & + ans=ans, nrow=ii, ncol=jj) +END PROCEDURE LegendreTransform2 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform2_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -REAL(DFP) :: rn -!! -nrmsqr = LegendreNormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP / rn -END IF -!! -PP = LegendreEvalAll(n=n, x=x) -!! -DO kk = 1, SIZE(coeff, 2) +INTEGER(I4B) :: ii, jj, kk +REAL(DFP) :: nrmsqr, areal + +nrow = n + 1 +ncol = SIZE(coeff, 2) + +CALL LegendreEvalAll_(n=n, x=x, nrow=ii, ncol=jj, ans=PP) + +DO kk = 1, ncol DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / nrmsqr(jj) + + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + nrmsqr = LegendreNormSQR(n=jj) + ans(jj, kk) = areal / nrmsqr + END DO END DO -!! -END PROCEDURE LegendreTransform2 + +IF (quadType .EQ. GaussLobatto) THEN + + jj = n + nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) + + DO kk = 1, ncol + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + ans(jj, kk) = areal / nrmsqr + END DO + +END IF + +END PROCEDURE LegendreTransform2_ !---------------------------------------------------------------------------- ! LegendreTransform !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreTransform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: tsize +CALL LegendreTransform3_(n=n, f=f, x1=x1, x2=x2, quadType=quadType, & + ans=ans, tsize=tsize) +END PROCEDURE LegendreTransform3 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform3_ +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x +REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP INTEGER(I4B) :: ii -!! -CALL LegendreQuadrature(n=n + 1, pt=pt, wt=wt,& - & quadType=quadType) -!! + +CALL LegendreQuadrature(n=n + 1, pt=pt, wt=wt, quadType=quadType) + DO ii = 0, n - coeff(ii) = f(pt(ii)) + x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2 + x = x * half + coeff(ii) = f(x) END DO -!! -ans = LegendreTransform(n=n, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) -!! -END PROCEDURE LegendreTransform3 + +CALL LegendreTransform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, & + ans=ans, tsize=tsize) + +END PROCEDURE LegendreTransform3_ !---------------------------------------------------------------------------- ! LegendreInvTransform From 0eb020a2a9b82fb17941bc488f0f8ddb1468cdef Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:29:52 +0900 Subject: [PATCH 305/359] updates in JacobiPolynomialUtility --- .../src/JacobiPolynomialUtility@Methods.F90 | 158 ++++++++++++------ 1 file changed, 111 insertions(+), 47 deletions(-) diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index 207dd1dcc..655d016f3 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -1207,75 +1207,139 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiTransform1 -REAL(DFP), DIMENSION(0:n) :: Gamma, temp +INTEGER(I4B) :: tsize +CALL JacobiTransform1_(n, alpha, beta, coeff, x, w, quadType, ans, tsize) +END PROCEDURE JacobiTransform1 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform1_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -!! -Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) -!! -!! Correct Gamma(n) -!! -IF (quadType .EQ. GaussLobatto) THEN - GAMMA(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & - & * GAMMA(n) -END IF -!! +REAL(DFP) :: nrmsqr, areal +INTEGER(I4B) :: jj, ii + +tsize = n + 1 + PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) -!! + DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / GAMMA(jj) + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + + nrmsqr = JacobiNormSQR(n=jj, alpha=alpha, beta=beta) + ans(jj) = areal / nrmsqr + END DO -!! -END PROCEDURE JacobiTransform1 + +IF (quadType .EQ. GaussLobatto) THEN + + areal = 0.0_DFP + jj = n + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + + nrmsqr = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) * nrmsqr + + ans(jj) = areal / nrmsqr + +END IF + +END PROCEDURE JacobiTransform1_ !---------------------------------------------------------------------------- ! JacobiTransform !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiTransform2 -REAL(DFP), DIMENSION(0:n) :: Gamma, temp +INTEGER(I4B) :: nrow, ncol +CALL JacobiTransform2_(n, alpha, beta, coeff, x, w, quadType, ans, nrow, ncol) +END PROCEDURE JacobiTransform2 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform2_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -!! -Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) -!! -!! Correct Gamma(n) -!! -IF (quadType .EQ. GaussLobatto) THEN - GAMMA(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & - & * GAMMA(n) -END IF -!! +REAL(DFP) :: nrmsqr, areal +INTEGER(I4B) :: jj, ii, kk + +nrow = n + 1 +ncol = SIZE(coeff, 2) + PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) -!! -DO kk = 1, SIZE(coeff, 2) + +DO kk = 1, ncol DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / GAMMA(jj) + + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + nrmsqr = JacobiNormSQR(n=jj, alpha=alpha, beta=beta) + ans(jj, kk) = areal / nrmsqr + END DO END DO -!! -END PROCEDURE JacobiTransform2 + +IF (quadType .EQ. GaussLobatto) THEN + + jj = n + + nrmsqr = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) * nrmsqr + + DO kk = 1, ncol + + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + ans(jj, kk) = areal / nrmsqr + END DO + +END IF + +END PROCEDURE JacobiTransform2_ !---------------------------------------------------------------------------- ! JacobiTransform !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiTransform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: tsize +CALL JacobiTransform3_(n, alpha, beta, f, quadType, x1, x2, ans, tsize) +END PROCEDURE JacobiTransform3 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform3_ +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x +REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP INTEGER(I4B) :: ii -!! -CALL JacobiQuadrature(n=n + 1, alpha=alpha, beta=beta, pt=pt, wt=wt,& - & quadType=quadType) -!! + +CALL JacobiQuadrature(n=n + 1, alpha=alpha, beta=beta, pt=pt, wt=wt, & + quadType=quadType) + DO ii = 0, n - coeff(ii) = f(pt(ii)) + x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2 + x = x * half + coeff(ii) = f(x) END DO -!! -ans = JacobiTransform(n=n, alpha=alpha, beta=beta, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) -END PROCEDURE JacobiTransform3 + +CALL JacobiTransform_(n=n, alpha=alpha, beta=beta, coeff=coeff, x=pt, & + w=wt, quadType=quadType, ans=ans, tsize=tsize) +END PROCEDURE JacobiTransform3_ !---------------------------------------------------------------------------- ! JacobiInvTransform @@ -1283,7 +1347,7 @@ MODULE PROCEDURE JacobiInvTransform1 ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & - & x=x) + x=x) END PROCEDURE JacobiInvTransform1 !---------------------------------------------------------------------------- @@ -1292,7 +1356,7 @@ MODULE PROCEDURE JacobiInvTransform2 ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & - & x=x) + x=x) END PROCEDURE JacobiInvTransform2 !---------------------------------------------------------------------------- From d3f2f69ec7725acce495e12efc3a880190f7c4d2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:30:11 +0900 Subject: [PATCH 306/359] updates in ProductUtility --- .../Utility/src/ProductUtility@Methods.F90 | 42 +++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index ab9451d99..3d2684690 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -23,6 +23,48 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! OTimesTilda +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OTimesTilda1 +INTEGER(I4B) :: sa(2), sb(2) +INTEGER(I4B) :: ii, jj, pp, qq + +sa = SHAPE(a) +sb = SHAPE(b) + +nrow = sa(1) * sb(1) +ncol = sa(2) * sb(2) + +DO CONCURRENT(ii=1:sa(1), jj=1:sa(2), pp=1:sb(1), qq=1:sb(2)) + ans((ii - 1) * sb(1) + pp, (jj - 1) * sb(2) + qq) = & + anscoeff * ans((ii - 1) * sb(1) + pp, (jj - 1) * sb(2) + qq) + & + scale * a(ii, jj) * b(pp, qq) +END DO + +END PROCEDURE OTimesTilda1 + +!---------------------------------------------------------------------------- +! OTimesTilda +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OTimesTilda2 +INTEGER(I4B) :: sa, sb +INTEGER(I4B) :: ii, jj + +sa = SIZE(a) +sb = SIZE(b) + +tsize = sa * sb + +DO CONCURRENT(ii=1:sa, jj=1:sb) + ans((ii - 1) * sb + jj) = & + anscoeff * ans((ii - 1) * sb + jj) + scale * a(ii) * b(jj) +END DO + +END PROCEDURE OTimesTilda2 + !---------------------------------------------------------------------------- ! VectorProd !---------------------------------------------------------------------------- From b23631e202eebeed429e9f4cc4ed846d2c47505f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:30:20 +0900 Subject: [PATCH 307/359] updates in QuadraturePoint_Method --- ...draturePoint_Method@ConstructorMethods.F90 | 84 ++++++++++++++----- 1 file changed, 61 insertions(+), 23 deletions(-) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index 133616e09..38be36089 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -20,8 +20,13 @@ ! summary: Constructor methods for [[QuadraturePoint_]] SUBMODULE(QuadraturePoint_Method) ConstructorMethods +USE GlobalData, ONLY: stderr + +USE ErrorHandling, ONLY: ErrorMsg + USE BaseInterpolation_Method, ONLY: BaseInterpolation_ToString, & - BaseInterpolation_ToInteger + BaseInterpolation_ToInteger, & + BaseInterpolation_ToChar USE ReallocateUtility, ONLY: Reallocate USE ReferenceElement_Method, ONLY: ElementTopology, & @@ -41,6 +46,8 @@ USE HexahedronInterpolationUtility, ONLY: QuadraturePoint_Hexahedron_, & QuadratureNumber_Hexahedron +USE BaseType, ONLY: elem => TypeElemNameOpt + IMPLICIT NONE CONTAINS @@ -53,6 +60,14 @@ ans = BaseInterpolation_ToString(name) END PROCEDURE QuadraturePointIDToName +!---------------------------------------------------------------------------- +! QuadraturePointIDToName +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_ToChar +ans = BaseInterpolation_ToChar(name) +END PROCEDURE QuadraturePoint_ToChar + !---------------------------------------------------------------------------- ! QuadraturePointNameToID !---------------------------------------------------------------------------- @@ -98,26 +113,33 @@ SELECT CASE (topo) -CASE (Line) +CASE (elem%line) ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) -CASE (Triangle) +CASE (elem%triangle) ans = QuadratureNumber_Triangle(order=order, quadtype=quadratureType) -CASE (Quadrangle) +CASE (elem%quadrangle) ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) -CASE (Tetrahedron) - ans = QuadratureNumber_Tetrahedron(order=order, quadtype=quadratureType) +CASE (elem%tetrahedron) -CASE (Hexahedron) + ans = QuadratureNumber_Tetrahedron(order=order, quadtype=quadratureType) -CASE (Prism) +! CASE (elem%hexahedron) +! +! CASE (elem%prism) +! +! CASE (elem%pyramid) -CASE (Pyramid) +CASE DEFAULT + CALL Errormsg(msg="No case found for give topo", & + file=__FILE__, routine="obj_QuadratureNumber1()", line=__LINE__, & + unitno=stderr) + STOP END SELECT @@ -249,7 +271,7 @@ SELECT CASE (topo) -CASE (Line) +CASE (elem%line) nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) @@ -261,7 +283,7 @@ layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, & lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Triangle) +CASE (elem%triangle) nipsx(1) = QuadratureNumber_Triangle(order=p, quadtype=quadratureType1) ncol = nipsx(1) @@ -271,7 +293,7 @@ CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, & refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Quadrangle) +CASE (elem%quadrangle) nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) nipsy(1) = QuadratureNumber_Line(order=q, quadtype=quadratureType2) @@ -286,7 +308,7 @@ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Tetrahedron) +CASE (elem%tetrahedron) nipsx(1) = QuadratureNumber_Tetrahedron(order=p, quadtype=quadratureType1) ncol = nipsx(1) @@ -296,7 +318,7 @@ CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, & refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Hexahedron) +CASE (elem%hexahedron) nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) nipsy(1) = QuadratureNumber_Line(order=q, quadtype=quadratureType2) @@ -316,9 +338,15 @@ alpha3=alpha3, beta3=beta3, lambda3=lambda3, & ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Prism) +! CASE (Prism) -CASE (Pyramid) +! CASE (Pyramid) + +CASE DEFAULT + CALL Errormsg(msg="No case found for give topo", & + file=__FILE__, routine="obj_Initiate11()", line=__LINE__, & + unitno=stderr) + STOP END SELECT @@ -347,7 +375,7 @@ SELECT CASE (topo) -CASE (Line) +CASE (elem%line) ncol = nipsx(1) CALL Reallocate(obj%points, nrow, ncol) @@ -355,7 +383,7 @@ layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, & lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Triangle) +CASE (elem%triangle) ncol = nipsx(1) @@ -364,7 +392,7 @@ CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, & refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Quadrangle) +CASE (elem%quadrangle) ncol = nipsx(1) * nipsy(1) @@ -376,7 +404,7 @@ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Tetrahedron) +CASE (elem%tetrahedron) ncol = nipsx(1) @@ -385,7 +413,7 @@ CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, & refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Hexahedron) +CASE (elem%hexahedron) ncol = nipsx(1) * nipsy(1) * nipsz(1) @@ -402,9 +430,15 @@ alpha3=alpha3, beta3=beta3, lambda3=lambda3, & ans=obj%points, nrow=nrow, ncol=ncol) -CASE (Prism) +! CASE (Prism) +! +! CASE (Pyramid) -CASE (Pyramid) +CASE DEFAULT + CALL Errormsg(msg="No case found for give topo", & + file=__FILE__, routine="obj_Initiate12()", line=__LINE__, & + unitno=stderr) + STOP END SELECT @@ -412,4 +446,8 @@ END PROCEDURE obj_Initiate12 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE ConstructorMethods From 2b3c9a4d2bfee7212941df861f7e5ea91fe9265e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 11:33:13 +0900 Subject: [PATCH 308/359] updates in LegendrePoly and JacobiPoly --- .../Polynomial/src/JacobiPolynomialUtility.F90 | 3 ++- .../Polynomial/src/LegendrePolynomialUtility.F90 | 6 +++++- .../src/JacobiPolynomialUtility@Methods.F90 | 11 ++++++++++- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index dc806f081..25920c6d0 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -22,7 +22,8 @@ !{!pages/JacobiPolynomialUtility.md!} MODULE JacobiPolynomialUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT + USE BaseType, ONLY: iface_1DFunction IMPLICIT NONE diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index 0963efee0..81b7d96a0 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -22,10 +22,14 @@ !{!pages/LegendrePolynomialUtility.md!} MODULE LegendrePolynomialUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT + USE BaseType, ONLY: iface_1DFunction + IMPLICIT NONE + PRIVATE + PUBLIC :: LegendreAlpha PUBLIC :: LegendreBeta PUBLIC :: GetLegendreRecurrenceCoeff diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index 655d016f3..b6a4d3215 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -16,7 +16,16 @@ ! SUBMODULE(JacobiPolynomialUtility) Methods -USE BaseMethod +USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix + +#ifdef USE_LAPACK95 +USE F95_Lapack, ONLY: STEV +#endif + +USE ErrorHandling, ONLY: ErrorMsg + +USE MiscUtility, ONLY: Factorial + IMPLICIT NONE CONTAINS From c78150e5409db9270829d1a251a89a2e79d43c8a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 13:58:39 +0900 Subject: [PATCH 309/359] Update Chebyshev1PolynomialUtility --- .../src/Chebyshev1PolynomialUtility.F90 | 130 ++++++++- .../Chebyshev1PolynomialUtility@Methods.F90 | 262 ++++++++++++------ 2 files changed, 297 insertions(+), 95 deletions(-) diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index 04057051b..7f2fd24eb 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -16,9 +16,12 @@ ! MODULE Chebyshev1PolynomialUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT + USE BaseType, ONLY: iface_1DFunction + IMPLICIT NONE + PUBLIC :: Chebyshev1Alpha PUBLIC :: Chebyshev1Beta PUBLIC :: GetChebyshev1RecurrenceCoeff @@ -46,6 +49,7 @@ MODULE Chebyshev1PolynomialUtility PUBLIC :: Chebyshev1EvalSum PUBLIC :: Chebyshev1GradientEvalSum PUBLIC :: Chebyshev1Transform +PUBLIC :: Chebyshev1Transform_ PUBLIC :: Chebyshev1InvTransform PUBLIC :: Chebyshev1GradientCoeff PUBLIC :: Chebyshev1DMatrix @@ -862,6 +866,36 @@ MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, & END FUNCTION Chebyshev1Transform1 END INTERFACE Chebyshev1Transform +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Discrete Chebyshev1 Transform + +INTERFACE Chebyshev1Transform_ + MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, & + quadType, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! tsize = n+1 + END SUBROUTINE Chebyshev1Transform1_ +END INTERFACE Chebyshev1Transform_ + !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- @@ -871,8 +905,8 @@ END FUNCTION Chebyshev1Transform1 ! summary: Columnwise Discrete Chebyshev1 Transform INTERFACE Chebyshev1Transform - MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, & - & quadType) RESULT(ans) + MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, quadType) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial REAL(DFP), INTENT(IN) :: coeff(0:, 1:) @@ -889,6 +923,37 @@ MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, & END FUNCTION Chebyshev1Transform2 END INTERFACE Chebyshev1Transform +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Columnwise Discrete Chebyshev1 Transform + +INTERFACE Chebyshev1Transform_ + MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, x, w, & + quadType, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = n+1 + !! ncol = SIZE(coeff, 2) + END SUBROUTINE Chebyshev1Transform2_ +END INTERFACE Chebyshev1Transform_ + !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- @@ -918,8 +983,7 @@ END FUNCTION Chebyshev1Transform2 !@endnote INTERFACE Chebyshev1Transform - MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) & - & RESULT(ans) + MODULE FUNCTION Chebyshev1Transform3(n, f, quadType, x1, x2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f @@ -927,11 +991,39 @@ MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) & INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 + !! x1, x2 are the end points of the interval REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION Chebyshev1Transform3 END INTERFACE Chebyshev1Transform +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Chebyshev1 Transform of a function on [-1,1] + +INTERFACE Chebyshev1Transform_ + MODULE SUBROUTINE Chebyshev1Transform3_(n, f, quadType, x1, x2, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 + !! x1, x2 are the end points of the interval + REAL(DFP) :: ans(0:) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! tsize = n+1 + END SUBROUTINE Chebyshev1Transform3_ +END INTERFACE Chebyshev1Transform_ + !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- @@ -944,7 +1036,7 @@ END FUNCTION Chebyshev1Transform3 ! Discrete Chebyshev transform. We calculate weights and quadrature points ! internally. -INTERFACE +INTERFACE Chebyshev1Transform MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial @@ -956,7 +1048,31 @@ MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION Chebyshev1Transform4 -END INTERFACE +END INTERFACE Chebyshev1Transform + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: +! summary: Discrete Chebyshev1 Transform + +INTERFACE Chebyshev1Transform_ + MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! tsize = n+1 + END SUBROUTINE Chebyshev1Transform4_ +END INTERFACE Chebyshev1Transform_ !---------------------------------------------------------------------------- ! Chebyshev1InvTransform diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index cd675f95d..48f8e8013 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -16,8 +16,28 @@ ! SUBMODULE(Chebyshev1PolynomialUtility) Methods -USE BaseMethod +USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix + +#ifdef USE_LAPACK95 +USE F95_Lapack, ONLY: STEV +#endif + +USE ErrorHandling, ONLY: ErrorMsg + +USE MiscUtility, ONLY: Factorial + +USE BaseType, ONLY: qp => TypeQuadratureOpt + +USE GlobalData, ONLY: pi + +USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalDMatEvenOdd + +USE JacobiPolynomialUtility, ONLY: JacobiJacobiMatrix, & + JacobiJacobiRadauMatrix, & + JacobiJacobiLobattoMatrix + IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -243,12 +263,12 @@ END IF !! SELECT CASE (QuadType) -CASE (Gauss) +CASE (qp%Gauss) !! order = n CALL Chebyshev1GaussQuadrature(n=order, pt=pt, wt=wt) !! -CASE (GaussRadau, GaussRadauLeft) +CASE (qp%GaussRadau, qp%GaussRadauLeft) !! IF (inside) THEN order = n @@ -261,7 +281,7 @@ CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) END IF !! -CASE (GaussRadauRight) +CASE (qp%GaussRadauRight) !! IF (inside) THEN order = n @@ -273,7 +293,7 @@ CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) END IF !! -CASE (GaussLobatto) +CASE (qp%GaussLobatto) !! IF (inside) THEN order = n @@ -831,127 +851,193 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1Transform1 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +INTEGER(I4B) :: tsize +CALL Chebyshev1Transform1_(n, coeff, x, w, quadType, ans, tsize) +END PROCEDURE Chebyshev1Transform1 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform1_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -REAL(DFP) :: rn -!! -nrmsqr = Chebyshev1NormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = pi -END IF -!! -PP = Chebyshev1EvalAll(n=n, x=x) -!! +INTEGER(I4B) :: ii, jj +REAL(DFP) :: nrmsqr, areal + +tsize = n + 1 +CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) + DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / nrmsqr(jj) + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + nrmsqr = Chebyshev1NormSQR(n=jj) + ans(jj) = areal / nrmsqr END DO -!! -END PROCEDURE Chebyshev1Transform1 + +IF (quadType .EQ. qp%GaussLobatto) THEN + areal = 0.0_DFP + jj = n + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + + nrmsqr = pi + ans(jj) = areal / nrmsqr +END IF + +END PROCEDURE Chebyshev1Transform1_ !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1Transform2 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +INTEGER(I4B) :: nrow, ncol +CALL Chebyshev1Transform2_(n, coeff, x, w, quadType, ans, nrow, ncol) +END PROCEDURE Chebyshev1Transform2 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform2_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -REAL(DFP) :: rn -!! -nrmsqr = Chebyshev1NormSQR2(n=n) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = pi -END IF -!! -PP = Chebyshev1EvalAll(n=n, x=x) -!! -DO kk = 1, SIZE(coeff, 2) +INTEGER(I4B) :: ii, jj, kk +REAL(DFP) :: nrmsqr, areal + +nrow = n + 1 +ncol = SIZE(coeff, 2) + +CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) + +DO kk = 1, ncol DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / nrmsqr(jj) + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, jj) + END DO + nrmsqr = Chebyshev1NormSQR(n=jj) + ans(jj, kk) = areal / nrmsqr END DO END DO -!! -END PROCEDURE Chebyshev1Transform2 + +IF (quadType .EQ. qp%GaussLobatto) THEN + + nrmsqr = pi + jj = n + + DO kk = 1, ncol + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + ans(jj, kk) = areal / nrmsqr + END DO + +END IF + +END PROCEDURE Chebyshev1Transform2_ !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1Transform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: tsize +CALL Chebyshev1Transform3_(n, f, quadType, x1, x2, ans, tsize) +END PROCEDURE Chebyshev1Transform3 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform3_ +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x +REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP INTEGER(I4B) :: ii -!! -CALL Chebyshev1Quadrature(n=n + 1, pt=pt, wt=wt,& - & quadType=quadType) -!! + +CALL Chebyshev1Quadrature(n=n + 1, pt=pt, wt=wt, quadType=quadType) + DO ii = 0, n - coeff(ii) = f(pt(ii)) + x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2 + x = x * half + coeff(ii) = f(x) END DO -!! -ans = Chebyshev1Transform(n=n, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) -!! -END PROCEDURE Chebyshev1Transform3 + +CALL Chebyshev1Transform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, & + ans=ans, tsize=tsize) + +END PROCEDURE Chebyshev1Transform3_ !---------------------------------------------------------------------------- ! Chebyshev1Transform4 !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1Transform4 +INTEGER(I4B) :: tsize +CALL Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) +END PROCEDURE Chebyshev1Transform4 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform4_ INTEGER(I4B) :: ii, jj -REAL(DFP) :: avar -!! -ans = 0.0_DFP -!! -IF (quadType .EQ. GaussLobatto) THEN - !! +REAL(DFP) :: avar, asign, pi_by_n, one_by_n +REAL(DFP), PARAMETER :: half = 0.5_DFP, minusOne = -1.0_DFP + +tsize = n + 1 +ans(1:tsize) = 0.0_DFP + +one_by_n = 1.0_DFP / REAL(n, KIND=DFP) +pi_by_n = pi * one_by_n + +IF (quadType .EQ. qp%GaussLobatto) THEN + DO jj = 0, n - !! - ans(jj) = coeff(0) * 0.5_DFP + coeff(n) * 0.5_DFP * (-1.0)**jj - !! + + asign = minusOne**jj + + ans(jj) = coeff(0) * half + coeff(n) * half * asign + DO ii = 1, n - 1 - ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi * ii / n) + ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi_by_n * ii) END DO - !! - ans(jj) = ans(jj) * 2.0_DFP / n - !! + + ans(jj) = ans(jj) * 2.0_DFP * one_by_n + END DO - !! - ans(0) = ans(0) * 0.5_DFP - ans(n) = ans(n) * 0.5_DFP - !! + + ans(0) = ans(0) * half + ans(n) = ans(n) * half + ELSE - !! + + one_by_n = 1.0_DFP / REAL(n + 1, KIND=DFP) + pi_by_n = pi * half * one_by_n + DO jj = 0, n - !! - avar = jj * pi * 0.5_DFP / (n + 1.0_DFP) - !! + + avar = jj * pi_by_n + DO ii = 0, n ans(jj) = ans(jj) + coeff(ii) * COS((2.0 * ii + 1.0) * avar) END DO - !! - ans(jj) = ans(jj) * 2.0_DFP / (n + 1.0) - !! + + ans(jj) = ans(jj) * 2.0_DFP * one_by_n + END DO - !! - ans(0) = ans(0) * 0.5_DFP - !! + + ans(0) = ans(0) * half + END IF -!! -END PROCEDURE Chebyshev1Transform4 + +END PROCEDURE Chebyshev1Transform4_ !---------------------------------------------------------------------------- ! Chebyshev1InvTransform @@ -1004,9 +1090,9 @@ MODULE PROCEDURE Chebyshev1DMatrix1 SELECT CASE (quadType) -CASE (GaussLobatto) +CASE (qp%GaussLobatto) CALL Chebyshev1DMatrixGL2(n=n, x=x, D=ans) -CASE (Gauss) +CASE (qp%Gauss) CALL Chebyshev1DMatrixG2(n=n, x=x, D=ans) END SELECT END PROCEDURE Chebyshev1DMatrix1 From 963a1150c342ec1e645bab74a203aacfb42a6fb2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 13:58:53 +0900 Subject: [PATCH 310/359] Update UltrasphericalPolynomialUtility --- .../src/UltrasphericalPolynomialUtility.F90 | 176 ++++++++++------ ...ltrasphericalPolynomialUtility@Methods.F90 | 199 ++++++++++++------ 2 files changed, 246 insertions(+), 129 deletions(-) diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 index b60a68710..5e22415c9 100644 --- a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 @@ -22,9 +22,12 @@ !{!pages/UltrasphericalPolynomialUtility.md!} MODULE UltrasphericalPolynomialUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT + USE BaseType, ONLY: iface_1DFunction + IMPLICIT NONE + PRIVATE PUBLIC :: UltrasphericalAlpha PUBLIC :: UltrasphericalBeta @@ -52,6 +55,7 @@ MODULE UltrasphericalPolynomialUtility PUBLIC :: UltrasphericalEvalSum PUBLIC :: UltrasphericalGradientEvalSum PUBLIC :: UltrasphericalTransform +PUBLIC :: UltrasphericalTransform_ PUBLIC :: UltrasphericalInvTransform PUBLIC :: UltrasphericalGradientCoeff PUBLIC :: UltrasphericalDMatrix @@ -456,7 +460,7 @@ END SUBROUTINE UltrasphericalQuadrature ! the point ! X. -INTERFACE +INTERFACE UltrasphericalEval MODULE PURE FUNCTION UltrasphericalEval1(n, lambda, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -466,10 +470,6 @@ MODULE PURE FUNCTION UltrasphericalEval1(n, lambda, x) RESULT(ans) REAL(DFP) :: ans !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalEval1 -END INTERFACE - -INTERFACE UltrasphericalEval - MODULE PROCEDURE UltrasphericalEval1 END INTERFACE UltrasphericalEval !---------------------------------------------------------------------------- @@ -493,7 +493,7 @@ END FUNCTION UltrasphericalEval1 ! the point ! X. -INTERFACE +INTERFACE UltrasphericalEval MODULE PURE FUNCTION UltrasphericalEval2(n, lambda, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -503,10 +503,6 @@ MODULE PURE FUNCTION UltrasphericalEval2(n, lambda, x) RESULT(ans) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalEval2 -END INTERFACE - -INTERFACE UltrasphericalEval - MODULE PROCEDURE UltrasphericalEval2 END INTERFACE UltrasphericalEval !---------------------------------------------------------------------------- @@ -762,7 +758,7 @@ END SUBROUTINE UltrasphericalGradientEvalAll2_ ! ! Evaluate gradient of Ultraspherical polynomial of order upto n. -INTERFACE +INTERFACE UltrasphericalGradientEval MODULE PURE FUNCTION UltrasphericalGradientEval1(n, lambda, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -771,11 +767,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEval1(n, lambda, x) RESULT(ans) REAL(DFP), INTENT(IN) :: x REAL(DFP) :: ans END FUNCTION UltrasphericalGradientEval1 -END INTERFACE -!! - -INTERFACE UltrasphericalGradientEval - MODULE PROCEDURE UltrasphericalGradientEval1 END INTERFACE UltrasphericalGradientEval !---------------------------------------------------------------------------- @@ -790,7 +781,7 @@ END FUNCTION UltrasphericalGradientEval1 ! ! Evaluate gradient of Ultraspherical polynomial of order upto n. -INTERFACE +INTERFACE UltrasphericalGradientEval MODULE PURE FUNCTION UltrasphericalGradientEval2(n, lambda, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -799,10 +790,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEval2(n, lambda, x) RESULT(ans) REAL(DFP), INTENT(IN) :: x(:) REAL(DFP) :: ans(1:SIZE(x)) END FUNCTION UltrasphericalGradientEval2 -END INTERFACE - -INTERFACE UltrasphericalGradientEval - MODULE PROCEDURE UltrasphericalGradientEval2 END INTERFACE UltrasphericalGradientEval !---------------------------------------------------------------------------- @@ -813,7 +800,7 @@ END FUNCTION UltrasphericalGradientEval2 ! date: 6 Sept 2022 ! summary: Evaluate finite sum of Ultraspherical polynomials at point x -INTERFACE +INTERFACE UltrasphericalEvalSum MODULE PURE FUNCTION UltrasphericalEvalSum1(n, lambda, x, coeff) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -827,10 +814,6 @@ MODULE PURE FUNCTION UltrasphericalEvalSum1(n, lambda, x, coeff) & REAL(DFP) :: ans !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalEvalSum1 -END INTERFACE - -INTERFACE UltrasphericalEvalSum - MODULE PROCEDURE UltrasphericalEvalSum1 END INTERFACE UltrasphericalEvalSum !---------------------------------------------------------------------------- @@ -841,7 +824,7 @@ END FUNCTION UltrasphericalEvalSum1 ! date: 6 Sept 2022 ! summary: Evaluate finite sum of Ultraspherical polynomials at several x -INTERFACE +INTERFACE UltrasphericalEvalSum MODULE PURE FUNCTION UltrasphericalEvalSum2(n, lambda, x, coeff) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of polynomial @@ -854,10 +837,6 @@ MODULE PURE FUNCTION UltrasphericalEvalSum2(n, lambda, x, coeff) RESULT(ans) REAL(DFP) :: ans(SIZE(x)) !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalEvalSum2 -END INTERFACE - -INTERFACE UltrasphericalEvalSum - MODULE PROCEDURE UltrasphericalEvalSum2 END INTERFACE UltrasphericalEvalSum !---------------------------------------------------------------------------- @@ -869,7 +848,7 @@ END FUNCTION UltrasphericalEvalSum2 ! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials ! at point x -INTERFACE +INTERFACE UltrasphericalGradientEvalSum MODULE PURE FUNCTION UltrasphericalGradientEvalSum1(n, lambda, x, & & coeff) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -883,10 +862,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum1(n, lambda, x, & REAL(DFP) :: ans !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalGradientEvalSum1 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum1 END INTERFACE UltrasphericalGradientEvalSum !---------------------------------------------------------------------------- @@ -898,7 +873,7 @@ END FUNCTION UltrasphericalGradientEvalSum1 ! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials ! at several x -INTERFACE +INTERFACE UltrasphericalGradientEvalSum MODULE PURE FUNCTION UltrasphericalGradientEvalSum2(n, lambda, x, coeff) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -912,10 +887,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum2(n, lambda, x, coeff) & REAL(DFP) :: ans(SIZE(x)) !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalGradientEvalSum2 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum2 END INTERFACE UltrasphericalGradientEvalSum !---------------------------------------------------------------------------- @@ -927,7 +898,7 @@ END FUNCTION UltrasphericalGradientEvalSum2 ! summary: Evaluate the kth derivative of finite sum of Ultraspherical ! polynomials at point x -INTERFACE +INTERFACE UltrasphericalGradientEvalSum MODULE PURE FUNCTION UltrasphericalGradientEvalSum3(n, lambda, x, & & coeff, k) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -943,10 +914,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum3(n, lambda, x, & REAL(DFP) :: ans !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalGradientEvalSum3 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum3 END INTERFACE UltrasphericalGradientEvalSum !---------------------------------------------------------------------------- @@ -958,7 +925,7 @@ END FUNCTION UltrasphericalGradientEvalSum3 ! summary: Evaluate the kth gradient of finite sum of Ultraspherical ! polynomials at several x -INTERFACE +INTERFACE UltrasphericalGradientEvalSum MODULE PURE FUNCTION UltrasphericalGradientEvalSum4(n, lambda, x, & & coeff, k) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -974,10 +941,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum4(n, lambda, x, & REAL(DFP) :: ans(SIZE(x)) !! Evaluate Ultraspherical polynomial of order n at point x END FUNCTION UltrasphericalGradientEvalSum4 -END INTERFACE - -INTERFACE UltrasphericalGradientEvalSum - MODULE PROCEDURE UltrasphericalGradientEvalSum4 END INTERFACE UltrasphericalGradientEvalSum !---------------------------------------------------------------------------- @@ -988,7 +951,7 @@ END FUNCTION UltrasphericalGradientEvalSum4 ! date: 13 Oct 2022 ! summary: Discrete Ultraspherical Transform -INTERFACE +INTERFACE UltrasphericalTransform MODULE PURE FUNCTION UltrasphericalTransform1(n, lambda, coeff, x, w, & & quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1007,21 +970,50 @@ MODULE PURE FUNCTION UltrasphericalTransform1(n, lambda, coeff, x, w, & REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION UltrasphericalTransform1 -END INTERFACE - -INTERFACE UltrasphericalTransform - MODULE PROCEDURE UltrasphericalTransform1 END INTERFACE UltrasphericalTransform !---------------------------------------------------------------------------- ! UltrasphericalTransform !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Ultraspherical transform + +INTERFACE UltrasphericalTransform_ + MODULE PURE SUBROUTINE UltrasphericalTransform1_(n, lambda, coeff, x, w, & + quadType, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of ans + !! n + 1 + END SUBROUTINE UltrasphericalTransform1_ +END INTERFACE UltrasphericalTransform_ + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 13 Oct 2022 ! summary: Columnwise Discrete Ultraspherical Transform -INTERFACE +INTERFACE UltrasphericalTransform MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & & quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n @@ -1040,12 +1032,36 @@ MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) !! modal values or coefficients for each column of val END FUNCTION UltrasphericalTransform2 -END INTERFACE - -INTERFACE UltrasphericalTransform - MODULE PROCEDURE UltrasphericalTransform2 END INTERFACE UltrasphericalTransform +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +INTERFACE UltrasphericalTransform_ + MODULE PURE SUBROUTINE UltrasphericalTransform2_(n, lambda, coeff, x, w, & + quadType, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! n+1, size(coeff, 2) + END SUBROUTINE UltrasphericalTransform2_ +END INTERFACE UltrasphericalTransform_ + !---------------------------------------------------------------------------- ! UltrasphericalTransform !---------------------------------------------------------------------------- @@ -1074,9 +1090,9 @@ END FUNCTION UltrasphericalTransform2 ! `UltrasphericalQuadrature` which is not pure due to Lapack call. !@endnote -INTERFACE - MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType) & - & RESULT(ans) +INTERFACE UltrasphericalTransform + MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType, x1, x2) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: lambda @@ -1086,15 +1102,37 @@ MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType) & INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 REAL(DFP) :: ans(0:n) !! modal values or coefficients END FUNCTION UltrasphericalTransform3 -END INTERFACE - -INTERFACE UltrasphericalTransform - MODULE PROCEDURE UltrasphericalTransform3 END INTERFACE UltrasphericalTransform +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +INTERFACE UltrasphericalTransform_ + MODULE SUBROUTINE UltrasphericalTransform3_(n, lambda, f, quadType, & + x1, x2, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(IN) :: x1, x2 + !! domain of function f + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE UltrasphericalTransform3_ +END INTERFACE UltrasphericalTransform_ + !---------------------------------------------------------------------------- ! UltrasphericalInvTransform !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 index 441b6b7fa..833c4ea2e 100644 --- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -16,7 +16,28 @@ ! SUBMODULE(UltrasphericalPolynomialUtility) Methods -USE BaseMethod +USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix + +#ifdef USE_LAPACK95 +USE F95_Lapack, ONLY: STEV +#endif + +USE ErrorHandling, ONLY: ErrorMsg + +USE MiscUtility, ONLY: Factorial + +USE BaseType, ONLY: qp => TypeQuadratureOpt + +USE GlobalData, ONLY: pi + +USE JacobiPolynomialUtility, ONLY: JacobiGaussQuadrature, & + JacobiGaussRadauQuadrature, & + JacobiGaussLobattoQuadrature, & + JacobiJacobiMatrix, & + JacobiJacobiRadauMatrix, & + JacobiJacobiLobattoMatrix, & + JacobiZeros + IMPLICIT NONE CONTAINS @@ -254,12 +275,12 @@ END IF !! SELECT CASE (QuadType) -CASE (Gauss) +CASE (qp%Gauss) !! order = n CALL UltrasphericalGaussQuadrature(n=order, lambda=lambda, pt=pt, wt=wt) !! -CASE (GaussRadau, GaussRadauLeft) +CASE (qp%GaussRadau, qp%GaussRadauLeft) !! IF (inside) THEN order = n @@ -274,7 +295,7 @@ & n=order, pt=pt, wt=wt) END IF !! -CASE (GaussRadauRight) +CASE (qp%GaussRadauRight) !! IF (inside) THEN order = n @@ -288,7 +309,7 @@ & n=order, pt=pt, wt=wt) END IF !! -CASE (GaussLobatto) +CASE (qp%GaussLobatto) !! IF (inside) THEN order = n @@ -548,7 +569,7 @@ p(1:nrow, ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(1:nrow, ii) & & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(1:nrow, ii - 1)) & - & / r_ii + & / r_ii ans(1:nrow, ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(1:nrow, ii) & & + ans(1:nrow, ii - 1) @@ -839,80 +860,140 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE UltrasphericalTransform1 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +INTEGER(I4B) :: tsize +CALL UltrasphericalTransform1_(n, lambda, coeff, x, w, quadType, ans, tsize) +END PROCEDURE UltrasphericalTransform1 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform1_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj -REAL(DFP) :: rn -!! -nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) -END IF -!! -PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) -!! +REAL(DFP) :: nrmsqr, areal, rn +INTEGER(I4B) :: jj, ii + +tsize = n + 1 + +CALL UltrasphericalEvalAll_(n=n, lambda=lambda, x=x, ans=PP, nrow=ii, ncol=jj) + DO jj = 0, n - temp = PP(:, jj) * w * coeff - ans(jj) = SUM(temp) / nrmsqr(jj) + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + + nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) + ans(jj) = areal / nrmsqr + END DO -!! -END PROCEDURE UltrasphericalTransform1 + +IF (quadType .EQ. qp%GaussLobatto) THEN + + areal = 0.0_DFP + jj = n + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + + rn = REAL(n, KIND=DFP) + nrmsqr = 2.0_DFP * (rn + lambda) / rn * nrmsqr + + ans(jj) = areal / nrmsqr + +END IF + +END PROCEDURE UltrasphericalTransform1_ !---------------------------------------------------------------------------- ! UltrasphericalTransform !---------------------------------------------------------------------------- MODULE PROCEDURE UltrasphericalTransform2 -REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +INTEGER(I4B) :: nrow, ncol +CALL UltrasphericalTransform2_(n, lambda, coeff, x, w, quadType, ans, nrow, & + ncol) +END PROCEDURE UltrasphericalTransform2 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform2_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, kk -REAL(DFP) :: rn -!! -nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) -!! -!! Correct nrmsqr(n) -!! -rn = REAL(n, KIND=DFP) -!! -IF (quadType .EQ. GaussLobatto) THEN - nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) -END IF -!! -PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) -!! -DO kk = 1, SIZE(coeff, 2) +REAL(DFP) :: nrmsqr, areal, rn +INTEGER(I4B) :: jj, ii, kk + +nrow = n + 1 +ncol = SIZE(coeff, 2) + +CALL UltrasphericalEvalAll_(n=n, lambda=lambda, x=x, ans=PP, nrow=ii, ncol=jj) + +DO kk = 1, ncol DO jj = 0, n - temp = PP(:, jj) * w * coeff(:, kk) - ans(jj, kk) = SUM(temp) / nrmsqr(jj) + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) + ans(jj, kk) = areal / nrmsqr + END DO END DO -!! -END PROCEDURE UltrasphericalTransform2 + +IF (quadType .EQ. qp%GaussLobatto) THEN + jj = n + rn = REAL(n, KIND=DFP) + nrmsqr = 2.0_DFP * (rn + lambda) / rn * nrmsqr + + DO kk = 1, ncol + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + ans(jj, kk) = areal / nrmsqr + END DO + +END IF + +END PROCEDURE UltrasphericalTransform2_ !---------------------------------------------------------------------------- ! UltrasphericalTransform !---------------------------------------------------------------------------- MODULE PROCEDURE UltrasphericalTransform3 -REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: tsize +CALL UltrasphericalTransform3_(n=n, lambda=lambda, x1=x1, x2=x2, f=f, & + ans=ans, tsize=tsize, quadType=quadType) +END PROCEDURE UltrasphericalTransform3 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform3_ +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x +REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP INTEGER(I4B) :: ii -CALL UltrasphericalQuadrature(n=n + 1, lambda=lambda, pt=pt, wt=wt,& - & quadType=quadType) +CALL UltrasphericalQuadrature(n=n + 1, lambda=lambda, pt=pt, wt=wt, & + quadType=quadType) DO ii = 0, n - coeff(ii) = f(pt(ii)) + x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2 + x = x * half + coeff(ii) = f(x) END DO -ans = UltrasphericalTransform(n=n, lambda=lambda, coeff=coeff, x=pt, & - & w=wt, quadType=quadType) +CALL UltrasphericalTransform_(n=n, lambda=lambda, coeff=coeff, x=pt, & + w=wt, quadType=quadType, ans=ans, tsize=tsize) -END PROCEDURE UltrasphericalTransform3 +END PROCEDURE UltrasphericalTransform3_ !---------------------------------------------------------------------------- ! UltrasphericalInvTransform @@ -962,12 +1043,10 @@ MODULE PROCEDURE UltrasphericalDMatrix1 SELECT CASE (quadType) -CASE (GaussLobatto) - CALL UltrasphericalDMatrixGL2(n=n, lambda=lambda, x=x,& - & D=ans) -CASE (Gauss) - CALL UltrasphericalDMatrixG2(n=n, lambda=lambda, x=x, & - & D=ans) +CASE (qp%GaussLobatto) + CALL UltrasphericalDMatrixGL2(n=n, lambda=lambda, x=x, D=ans) +CASE (qp%Gauss) + CALL UltrasphericalDMatrixG2(n=n, lambda=lambda, x=x, D=ans) END SELECT END PROCEDURE UltrasphericalDMatrix1 From ffc05a775679901a99fb8999e1103b152d6edeec Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 13:59:02 +0900 Subject: [PATCH 311/359] Update JacobiPolynomialUtility --- .../src/JacobiPolynomialUtility@Methods.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index b6a4d3215..10119088c 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -26,6 +26,8 @@ USE MiscUtility, ONLY: Factorial +USE BaseType, ONLY: qp => TypeQuadratureOpt + IMPLICIT NONE CONTAINS @@ -445,19 +447,19 @@ REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP !! SELECT CASE (quadType) -CASE (Gauss) +CASE (qp%Gauss) order = n CALL JacobiGaussQuadrature(n=order, alpha=alpha, beta=beta, & & pt=pt, wt=wt) -CASE (GaussRadau, GaussRadauLeft) +CASE (qp%GaussRadau, qp%GaussRadauLeft) order = n - 1 CALL JacobiGaussRadauQuadrature(a=left, n=order, alpha=alpha, beta=beta, & & pt=pt, wt=wt) -CASE (GaussRadauRight) +CASE (qp%GaussRadauRight) order = n - 1 CALL JacobiGaussRadauQuadrature(a=right, n=order, alpha=alpha, beta=beta, & & pt=pt, wt=wt) -CASE (GaussLobatto) +CASE (qp%GaussLobatto) order = n - 2 CALL JacobiGaussLobattoQuadrature(n=order, alpha=alpha, beta=beta, & & pt=pt, wt=wt) @@ -1245,7 +1247,7 @@ END DO -IF (quadType .EQ. GaussLobatto) THEN +IF (quadType .EQ. qp%GaussLobatto) THEN areal = 0.0_DFP jj = n @@ -1299,7 +1301,7 @@ END DO END DO -IF (quadType .EQ. GaussLobatto) THEN +IF (quadType .EQ. qp%GaussLobatto) THEN jj = n @@ -1413,10 +1415,10 @@ MODULE PROCEDURE JacobiDMatrix1 SELECT CASE (quadType) -CASE (GaussLobatto) +CASE (qp%GaussLobatto) CALL JacobiDMatrixGL(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType,& & D=ans) -CASE (Gauss) +CASE (qp%Gauss) CALL JacobiDMatrixG(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType, & & D=ans) END SELECT From 57983c7956ffd3bd4ef2d8c9a1bfaad66ce0715b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 13:59:12 +0900 Subject: [PATCH 312/359] Update LegendrePolynomialUtility --- .../src/LegendrePolynomialUtility@Methods.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index 14dc809bf..2e2ee5b59 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -31,6 +31,8 @@ USE MiscUtility, ONLY: Factorial +USE BaseType, ONLY: qp => TypeQuadratureOpt + IMPLICIT NONE CONTAINS @@ -340,12 +342,12 @@ END IF !! SELECT CASE (QuadType) -CASE (Gauss) +CASE (qp%Gauss) !! order = n CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt) !! -CASE (GaussRadau, GaussRadauLeft) +CASE (qp%GaussRadau, qp%GaussRadauLeft) !! IF (inside) THEN order = n @@ -358,7 +360,7 @@ CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) END IF !! -CASE (GaussRadauRight) +CASE (qp%GaussRadauRight) !! IF (inside) THEN order = n @@ -370,7 +372,7 @@ CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) END IF !! -CASE (GaussLobatto) +CASE (qp%GaussLobatto) !! IF (inside) THEN order = n @@ -968,7 +970,7 @@ ans(jj) = areal / nrmsqr END DO -IF (quadType .EQ. GaussLobatto) THEN +IF (quadType .EQ. qp%GaussLobatto) THEN areal = 0.0_DFP jj = n DO ii = 0, n @@ -1020,7 +1022,7 @@ END DO END DO -IF (quadType .EQ. GaussLobatto) THEN +IF (quadType .EQ. qp%GaussLobatto) THEN jj = n nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) @@ -1099,9 +1101,9 @@ MODULE PROCEDURE LegendreDMatrix1 SELECT CASE (quadType) -CASE (GaussLobatto) +CASE (qp%GaussLobatto) CALL LegendreDMatrixGL2(n=n, x=x, D=ans) -CASE (Gauss) +CASE (qp%Gauss) CALL LegendreDMatrixG2(n=n, x=x, D=ans) END SELECT END PROCEDURE LegendreDMatrix1 From cab92a96a847ad2b1a090cec283ec88714977560 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 19 Aug 2024 15:10:00 +0900 Subject: [PATCH 313/359] Minor updates --- src/modules/BeFoR64/src/befor64.F90 | 1972 ++++++++--------- .../BeFoR64/src/befor64_pack_data_m.F90 | 1576 ++++++------- src/modules/Display/src/Display_Method.F90 | 17 +- src/modules/Display/src/disp/disp_charmod.F90 | 166 +- src/modules/Display/src/disp/disp_i1mod.F90 | 428 ++-- src/modules/Display/src/disp/disp_i2mod.F90 | 468 ++-- src/modules/Display/src/disp/disp_i4mod.F90 | 462 ++-- src/modules/Display/src/disp/disp_i8mod.F90 | 458 ++-- src/modules/Display/src/disp/disp_l1mod.F90 | 362 +-- src/modules/Display/src/disp/disp_r16mod.F90 | 986 ++++----- src/modules/Display/src/disp/disp_r4mod.F90 | 934 ++++---- src/modules/Display/src/disp/disp_r8mod.F90 | 982 ++++---- src/modules/Display/src/disp/putstrmodule.F90 | 42 +- src/modules/FACE/src/face.F90 | 476 ++-- src/modules/PENF/src/penf.F90 | 346 +-- src/modules/PENF/src/penf_b_size.F90 | 154 +- .../src/penf_global_parameters_variables.F90 | 248 +-- src/modules/PENF/src/penf_stringify.F90 | 2 +- 18 files changed, 5038 insertions(+), 5041 deletions(-) diff --git a/src/modules/BeFoR64/src/befor64.F90 b/src/modules/BeFoR64/src/befor64.F90 index 1ed72dc2d..744db0d23 100644 --- a/src/modules/BeFoR64/src/befor64.F90 +++ b/src/modules/BeFoR64/src/befor64.F90 @@ -1,21 +1,21 @@ !< BeFoR64, Base64 encoding/decoding library for FoRtran poor people. -module befor64 +MODULE befor64 !< BeFoR64, Base64 encoding/decoding library for FoRtran poor people. -use penf -use befor64_pack_data_m +USE penf +USE befor64_pack_data_m -implicit none -private -public :: is_b64_initialized, b64_init -public :: b64_encode, b64_encode_up -public :: b64_decode, b64_decode_up -public :: pack_data +IMPLICIT NONE +PRIVATE +PUBLIC :: is_b64_initialized, b64_init +PUBLIC :: b64_encode, b64_encode_up +PUBLIC :: b64_decode, b64_decode_up +PUBLIC :: pack_data -logical :: is_b64_initialized=.false. !< Flag for checking the initialization of the library. +LOGICAL :: is_b64_initialized = .FALSE. !< Flag for checking the initialization of the library. character(64) :: base64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" !< Base64 alphabet. -interface b64_encode +INTERFACE b64_encode !< Encode numbers (integer and real) to base64. !< !< This is an interface for encoding integer and real numbers of any kinds into a base64 string. This interface can encode both @@ -48,20 +48,20 @@ module befor64 !< procedure. !< !< @warning The encoding of array of strings is admitted only if each string of the array has the same length. - module procedure & + MODULE PROCEDURE & #if defined _R16P - b64_encode_R16, b64_encode_R16_a, & + b64_encode_R16, b64_encode_R16_a, & #endif - b64_encode_R8, b64_encode_R8_a, & - b64_encode_R4, b64_encode_R4_a, & - b64_encode_I8, b64_encode_I8_a, & - b64_encode_I4, b64_encode_I4_a, & - b64_encode_I2, b64_encode_I2_a, & - b64_encode_I1, b64_encode_I1_a, & - b64_encode_string, b64_encode_string_a -endinterface - -interface b64_encode_up + b64_encode_R8, b64_encode_R8_a, & + b64_encode_R4, b64_encode_R4_a, & + b64_encode_I8, b64_encode_I8_a, & + b64_encode_I4, b64_encode_I4_a, & + b64_encode_I2, b64_encode_I2_a, & + b64_encode_I1, b64_encode_I1_a, & + b64_encode_string, b64_encode_string_a +END INTERFACE + +INTERFACE b64_encode_up !< Encode unlimited polymorphic variable to base64. !< !< This is an interface for encoding both scalar and array. @@ -93,10 +93,10 @@ module befor64 !< procedure. !< !< @warning The encoding of array of strings is admitted only if each string of the array has the same length. - module procedure b64_encode_up, b64_encode_up_a -endinterface + MODULE PROCEDURE b64_encode_up, b64_encode_up_a +END INTERFACE -interface b64_decode +INTERFACE b64_decode !< Decode numbers (integer and real) from base64. !< !< This is an interface for decoding integer and real numbers of any kinds from a base64 string. This interface can decode both @@ -126,20 +126,20 @@ module befor64 !< procedure. !< !< @warning The decoding of array of strings is admitted only if each string of the array has the same length. - module procedure & + MODULE PROCEDURE & #if defined _R16P - b64_decode_R16, b64_decode_R16_a, & + b64_decode_R16, b64_decode_R16_a, & #endif - b64_decode_R8, b64_decode_R8_a, & - b64_decode_R4, b64_decode_R4_a, & - b64_decode_I8, b64_decode_I8_a, & - b64_decode_I4, b64_decode_I4_a, & - b64_decode_I2, b64_decode_I2_a, & - b64_decode_I1, b64_decode_I1_a, & - b64_decode_string, b64_decode_string_a -endinterface - -interface b64_decode_up + b64_decode_R8, b64_decode_R8_a, & + b64_decode_R4, b64_decode_R4_a, & + b64_decode_I8, b64_decode_I8_a, & + b64_decode_I4, b64_decode_I4_a, & + b64_decode_I2, b64_decode_I2_a, & + b64_decode_I1, b64_decode_I1_a, & + b64_decode_string, b64_decode_string_a +END INTERFACE + +INTERFACE b64_decode_up !< Decode unlimited polymorphic variable from base64. !< !< This is an interface for decoding both scalar and array. @@ -168,955 +168,955 @@ module befor64 !< procedure. !< !< @warning The decoding of array of strings is admitted only if each string of the array has the same length. - module procedure b64_decode_up, b64_decode_up_a -endinterface - -contains - subroutine b64_init() - !< Initialize the BeFoR64 library. - !< - !< @note This procedure **must** be called before encoding/decoding anything! - !< - !<```fortran - !< use befor64 - !< call b64_init - !< print "(L1)", is_b64_initialized - !<``` - !=> T <<< - - if (.not.is_initialized) call penf_init - is_b64_initialized = .true. - endsubroutine b64_init - - pure subroutine encode_bits(bits, padd, code) - !< Encode a bits stream (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4). - !< - !< The bits stream are encoded in chunks of 24 bits as the following example (in little endian order) - !<``` - !< +--first octet--+-second octet--+--third octet--+ - !< |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0| - !< +-----------+---+-------+-------+---+-----------+ - !< |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0| - !< +--1.index--+--2.index--+--3.index--+--4.index--+ - !<``` - !< @note The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used. - !< - !< @note The number of paddings must be computed outside this procedure, into the calling scope. - !< - !< @warning This procedure is the backend of encoding, thus it must be never called outside the module. - integer(I1P), intent(in) :: bits(1:) !< Bits to be encoded. - integer(I4P), intent(in) :: padd !< Number of padding characters ('='). - character(*), intent(out) :: code !< Characters code. - integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. - integer(I8P) :: c !< Counter. - integer(I8P) :: e !< Counter. - integer(I8P) :: Nb !< Length of bits array. - - Nb=size(bits,dim=1,kind=I8P) - c = 1_I8P - do e=1_I8P,Nb,3_I8P ! loop over array elements: 3 bytes (24 bits) scanning - sixb = 0_I1P - call mvbits(bits(e ),2,6,sixb(1),0) - call mvbits(bits(e ),0,2,sixb(2),4) - if (e+1<=Nb) then - call mvbits(bits(e+1),4,4,sixb(2),0) - call mvbits(bits(e+1),0,4,sixb(3),2) - endif - if (e+2<=Nb) then - call mvbits(bits(e+2),6,2,sixb(3),0) - call mvbits(bits(e+2),0,6,sixb(4),0) - endif - sixb = sixb + 1_I1P - code(c :c ) = base64(sixb(1):sixb(1)) - code(c+1:c+1) = base64(sixb(2):sixb(2)) - code(c+2:c+2) = base64(sixb(3):sixb(3)) - code(c+3:c+3) = base64(sixb(4):sixb(4)) - c = c + 4_I8P - enddo - if (padd>0) code(len(code)-padd+1:)=repeat('=',padd) - endsubroutine encode_bits - - pure subroutine decode_bits(code, bits) - !< Decode a base64 string into a sequence of bits stream. - !< - !< The base64 string must be parsed with a strike of 4 characters and converted into a 3 bytes stream. Considering the base64 code - !< `QUJD` the decoding process must do - !<``` - !< +-b64 char--+-b64 char--+-b64 char--+-b64 char--+ - !< | Q | U | J | D | - !< +-b64 index-+-b64 index-+-b64 index-+-b64 index-+ - !< ! 16 | 20 | 9 | 3 | - !< +-6 bits----+-6 bits----+-6 bits----+-6 bits----+ - !< |0 1 0 0 0 0|0 1 0 1 0 0|0 0 1 0 0 1|0 0 0 0 1 1| - !< +-----------+---+-------+-------+---+-----------+ - !< |0 1 0 0 0 0 0 1|0 1 0 0 0 0 1 0|0 1 0 0 0 0 1 1| - !< +-----8 bits----+-----8 bits----+-----8 bits----+ - !<``` - !< @note The bits pattern is returned as a 1-byte element array, the dimension of witch must be computed outside this procedure. - !< - !< @warning This procedure is the backend of decoding, thus it must be never called outside the module. - character(*), intent(in) :: code !< Characters code. - integer(I1P), intent(out) :: bits(1:) !< Bits decoded. - integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. - integer(I8P) :: c !< Counter. - integer(I8P) :: e !< Counter. - integer(I8P) :: Nb !< Length of bits array. - - Nb=size(bits,dim=1,kind=I8P) - e = 1_I8P - do c=1_I8P,len(code),4_I8P ! loop over code characters: 3 bytes (24 bits) scanning - sixb = 0_I1P - sixb(1) = index(base64,code(c :c )) - 1 - sixb(2) = index(base64,code(c+1:c+1)) - 1 - sixb(3) = index(base64,code(c+2:c+2)) - 1 - sixb(4) = index(base64,code(c+3:c+3)) - 1 - call mvbits(sixb(1),0,6,bits(e ),2) ; call mvbits(sixb(2),4,2,bits(e ),0) - if (e+1<=Nb) then - call mvbits(sixb(2),0,4,bits(e+1),4) ; call mvbits(sixb(3),2,4,bits(e+1),0) - endif - if (e+2<=Nb) then - call mvbits(sixb(3),0,2,bits(e+2),6) ; call mvbits(sixb(4),0,6,bits(e+2),0) - endif - e = e + 3_I8P - enddo - endsubroutine decode_bits - - subroutine b64_encode_up(up, code) - !< Encode an unlimited polymorphic scalar to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode_up(up=1._R8P, code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAAAA8D8= <<< - class(*), intent(in) :: up !< Unlimited polymorphic variable to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - - select type(up) - type is(real(R8P)) - call b64_encode_R8(n=up,code=code) - type is(real(R4P)) - call b64_encode_R4(n=up,code=code) - type is(integer(I8P)) - call b64_encode_I8(n=up,code=code) - type is(integer(I4P)) - call b64_encode_I4(n=up,code=code) - type is(integer(I2P)) - call b64_encode_I2(n=up,code=code) - type is(integer(I1P)) - call b64_encode_I1(n=up,code=code) - type is(character(*)) - call b64_encode_string(s=up,code=code) - endselect - endsubroutine b64_encode_up - - pure subroutine b64_encode_up_a(up, code) - !< Encode an unlimited polymorphic array to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode_up(up=[0._R4P,-32.12_R4P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAOF6AMI= <<< - class(*), intent(in) :: up(1:) !< Unlimited polymorphic variable to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - - select type(up) - type is(real(R8P)) - call b64_encode_R8_a(n=up,code=code) - type is(real(R4P)) - call b64_encode_R4_a(n=up,code=code) - type is(integer(I8P)) - call b64_encode_I8_a(n=up,code=code) - type is(integer(I4P)) - call b64_encode_I4_a(n=up,code=code) - type is(integer(I2P)) - call b64_encode_I2_a(n=up,code=code) - type is(integer(I1P)) - call b64_encode_I1_a(n=up,code=code) - type is(character(*)) - call b64_encode_string_a(s=up,code=code) - endselect - endsubroutine b64_encode_up_a - - subroutine b64_decode_up(code, up) - !< Decode an unlimited polymorphic scalar from base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: scalar_I4 - !< call b64_decode_up(code='5wcAAA==',up=scalar_I4) - !< print "(L1)", scalar_I4==2023_I4P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - class(*), intent(out) :: up !< Unlimited polymorphic variable to be decoded. - - select type(up) - type is(real(R8P)) - call b64_decode_R8(code=code,n=up) - type is(real(R4P)) - call b64_decode_R4(code=code,n=up) - type is(integer(I8P)) - call b64_decode_I8(code=code,n=up) - type is(integer(I4P)) - call b64_decode_I4(code=code,n=up) - type is(integer(I2P)) - call b64_decode_I2(code=code,n=up) - type is(integer(I1P)) - call b64_decode_I1(code=code,n=up) - type is(character(*)) - call b64_decode_string(code=code,s=up) - endselect - endsubroutine b64_decode_up - - subroutine b64_decode_up_a(code, up) - !< Decode an unlimited polymorphic array from base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: array_I8(1:4) - !< call b64_decode_up(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=', up=array_I8) - !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - class(*), intent(out) :: up(1:) !< Unlimited polymorphic variable to be decoded. - - select type(up) - type is(real(R8P)) - call b64_decode_R8_a(code=code,n=up) - type is(real(R4P)) - call b64_decode_R4_a(code=code,n=up) - type is(integer(I8P)) - call b64_decode_I8_a(code=code,n=up) - type is(integer(I4P)) - call b64_decode_I4_a(code=code,n=up) - type is(integer(I2P)) - call b64_decode_I2_a(code=code,n=up) - type is(integer(I1P)) - call b64_decode_I1_a(code=code,n=up) - type is(character(*)) - call b64_decode_string_a(code=code,s=up) - endselect - endsubroutine b64_decode_up_a - - pure subroutine b64_encode_R16(n, code) - !< Encode scalar number to base64 (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=134.231_R16P, code=code64) - !< print "(A)", code64 - !<``` - !=> CKwcWmTHYEA= <<< - real(R16P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYR16P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYR16P+2)/3)*4) - nI1P = transfer(n,nI1P) + MODULE PROCEDURE b64_decode_up, b64_decode_up_a +END INTERFACE + +CONTAINS +SUBROUTINE b64_init() + !< Initialize the BeFoR64 library. + !< + !< @note This procedure **must** be called before encoding/decoding anything! + !< + !<```fortran + !< use befor64 + !< call b64_init + !< print "(L1)", is_b64_initialized + !<``` + !=> T <<< + + IF (.NOT. is_initialized) CALL penf_init + is_b64_initialized = .TRUE. +END SUBROUTINE b64_init + +PURE SUBROUTINE encode_bits(bits, padd, code) + !< Encode a bits stream (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4). + !< + !< The bits stream are encoded in chunks of 24 bits as the following example (in little endian order) + !<``` + !< +--first octet--+-second octet--+--third octet--+ + !< |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0| + !< +-----------+---+-------+-------+---+-----------+ + !< |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0| + !< +--1.index--+--2.index--+--3.index--+--4.index--+ + !<``` + !< @note The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used. + !< + !< @note The number of paddings must be computed outside this procedure, into the calling scope. + !< + !< @warning This procedure is the backend of encoding, thus it must be never called outside the module. + INTEGER(I1P), INTENT(in) :: bits(1:) !< Bits to be encoded. + INTEGER(I4P), INTENT(in) :: padd !< Number of padding characters ('='). + CHARACTER(*), INTENT(out) :: code !< Characters code. + INTEGER(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. + INTEGER(I8P) :: c !< Counter. + INTEGER(I8P) :: e !< Counter. + INTEGER(I8P) :: Nb !< Length of bits array. + + Nb = SIZE(bits, dim=1, kind=I8P) + c = 1_I8P + DO e = 1_I8P, Nb, 3_I8P ! loop over array elements: 3 bytes (24 bits) scanning + sixb = 0_I1P + CALL MVBITS(bits(e), 2, 6, sixb(1), 0) + CALL MVBITS(bits(e), 0, 2, sixb(2), 4) + IF (e + 1 <= Nb) THEN + CALL MVBITS(bits(e + 1), 4, 4, sixb(2), 0) + CALL MVBITS(bits(e + 1), 0, 4, sixb(3), 2) + END IF + IF (e + 2 <= Nb) THEN + CALL MVBITS(bits(e + 2), 6, 2, sixb(3), 0) + CALL MVBITS(bits(e + 2), 0, 6, sixb(4), 0) + END IF + sixb = sixb + 1_I1P + code(c:c) = base64(sixb(1):sixb(1)) + code(c + 1:c + 1) = base64(sixb(2):sixb(2)) + code(c + 2:c + 2) = base64(sixb(3):sixb(3)) + code(c + 3:c + 3) = base64(sixb(4):sixb(4)) + c = c + 4_I8P + END DO + IF (padd > 0) code(LEN(code) - padd + 1:) = REPEAT('=', padd) +END SUBROUTINE encode_bits + +PURE SUBROUTINE decode_bits(code, bits) + !< Decode a base64 string into a sequence of bits stream. + !< + !< The base64 string must be parsed with a strike of 4 characters and converted into a 3 bytes stream. Considering the base64 code + !< `QUJD` the decoding process must do + !<``` + !< +-b64 char--+-b64 char--+-b64 char--+-b64 char--+ + !< | Q | U | J | D | + !< +-b64 index-+-b64 index-+-b64 index-+-b64 index-+ + !< ! 16 | 20 | 9 | 3 | + !< +-6 bits----+-6 bits----+-6 bits----+-6 bits----+ + !< |0 1 0 0 0 0|0 1 0 1 0 0|0 0 1 0 0 1|0 0 0 0 1 1| + !< +-----------+---+-------+-------+---+-----------+ + !< |0 1 0 0 0 0 0 1|0 1 0 0 0 0 1 0|0 1 0 0 0 0 1 1| + !< +-----8 bits----+-----8 bits----+-----8 bits----+ + !<``` + !< @note The bits pattern is returned as a 1-byte element array, the dimension of witch must be computed outside this procedure. + !< + !< @warning This procedure is the backend of decoding, thus it must be never called outside the module. + CHARACTER(*), INTENT(in) :: code !< Characters code. + INTEGER(I1P), INTENT(out) :: bits(1:) !< Bits decoded. + INTEGER(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. + INTEGER(I8P) :: c !< Counter. + INTEGER(I8P) :: e !< Counter. + INTEGER(I8P) :: Nb !< Length of bits array. + + Nb = SIZE(bits, dim=1, kind=I8P) + e = 1_I8P + DO c = 1_I8P, LEN(code), 4_I8P ! loop over code characters: 3 bytes (24 bits) scanning + sixb = 0_I1P + sixb(1) = INDEX(base64, code(c:c)) - 1 + sixb(2) = INDEX(base64, code(c + 1:c + 1)) - 1 + sixb(3) = INDEX(base64, code(c + 2:c + 2)) - 1 + sixb(4) = INDEX(base64, code(c + 3:c + 3)) - 1 + CALL MVBITS(sixb(1), 0, 6, bits(e), 2); CALL MVBITS(sixb(2), 4, 2, bits(e), 0) + IF (e + 1 <= Nb) THEN + CALL MVBITS(sixb(2), 0, 4, bits(e + 1), 4); CALL MVBITS(sixb(3), 2, 4, bits(e + 1), 0) + END IF + IF (e + 2 <= Nb) THEN + CALL MVBITS(sixb(3), 0, 2, bits(e + 2), 6); CALL MVBITS(sixb(4), 0, 6, bits(e + 2), 0) + END IF + e = e + 3_I8P + END DO +END SUBROUTINE decode_bits + +SUBROUTINE b64_encode_up(up, code) + !< Encode an unlimited polymorphic scalar to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode_up(up=1._R8P, code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAAAA8D8= <<< + CLASS(*), INTENT(in) :: up !< Unlimited polymorphic variable to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + + SELECT TYPE (up) + TYPE is (REAL(R8P)) + CALL b64_encode_R8(n=up, code=code) + TYPE is (REAL(R4P)) + CALL b64_encode_R4(n=up, code=code) + TYPE is (INTEGER(I8P)) + CALL b64_encode_I8(n=up, code=code) + TYPE is (INTEGER(I4P)) + CALL b64_encode_I4(n=up, code=code) + TYPE is (INTEGER(I2P)) + CALL b64_encode_I2(n=up, code=code) + TYPE is (INTEGER(I1P)) + CALL b64_encode_I1(n=up, code=code) + TYPE is (CHARACTER(*)) + CALL b64_encode_string(s=up, code=code) + END SELECT +END SUBROUTINE b64_encode_up + +PURE SUBROUTINE b64_encode_up_a(up, code) + !< Encode an unlimited polymorphic array to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode_up(up=[0._R4P,-32.12_R4P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAOF6AMI= <<< + CLASS(*), INTENT(in) :: up(1:) !< Unlimited polymorphic variable to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + + SELECT TYPE (up) + TYPE is (REAL(R8P)) + CALL b64_encode_R8_a(n=up, code=code) + TYPE is (REAL(R4P)) + CALL b64_encode_R4_a(n=up, code=code) + TYPE is (INTEGER(I8P)) + CALL b64_encode_I8_a(n=up, code=code) + TYPE is (INTEGER(I4P)) + CALL b64_encode_I4_a(n=up, code=code) + TYPE is (INTEGER(I2P)) + CALL b64_encode_I2_a(n=up, code=code) + TYPE is (INTEGER(I1P)) + CALL b64_encode_I1_a(n=up, code=code) + TYPE is (CHARACTER(*)) + CALL b64_encode_string_a(s=up, code=code) + END SELECT +END SUBROUTINE b64_encode_up_a + +SUBROUTINE b64_decode_up(code, up) + !< Decode an unlimited polymorphic scalar from base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: scalar_I4 + !< call b64_decode_up(code='5wcAAA==',up=scalar_I4) + !< print "(L1)", scalar_I4==2023_I4P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + CLASS(*), INTENT(out) :: up !< Unlimited polymorphic variable to be decoded. + + SELECT TYPE (up) + TYPE is (REAL(R8P)) + CALL b64_decode_R8(code=code, n=up) + TYPE is (REAL(R4P)) + CALL b64_decode_R4(code=code, n=up) + TYPE is (INTEGER(I8P)) + CALL b64_decode_I8(code=code, n=up) + TYPE is (INTEGER(I4P)) + CALL b64_decode_I4(code=code, n=up) + TYPE is (INTEGER(I2P)) + CALL b64_decode_I2(code=code, n=up) + TYPE is (INTEGER(I1P)) + CALL b64_decode_I1(code=code, n=up) + TYPE is (CHARACTER(*)) + CALL b64_decode_string(code=code, s=up) + END SELECT +END SUBROUTINE b64_decode_up + +SUBROUTINE b64_decode_up_a(code, up) + !< Decode an unlimited polymorphic array from base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: array_I8(1:4) + !< call b64_decode_up(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=', up=array_I8) + !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + CLASS(*), INTENT(out) :: up(1:) !< Unlimited polymorphic variable to be decoded. + + SELECT TYPE (up) + TYPE is (REAL(R8P)) + CALL b64_decode_R8_a(code=code, n=up) + TYPE is (REAL(R4P)) + CALL b64_decode_R4_a(code=code, n=up) + TYPE is (INTEGER(I8P)) + CALL b64_decode_I8_a(code=code, n=up) + TYPE is (INTEGER(I4P)) + CALL b64_decode_I4_a(code=code, n=up) + TYPE is (INTEGER(I2P)) + CALL b64_decode_I2_a(code=code, n=up) + TYPE is (INTEGER(I1P)) + CALL b64_decode_I1_a(code=code, n=up) + TYPE is (CHARACTER(*)) + CALL b64_decode_string_a(code=code, s=up) + END SELECT +END SUBROUTINE b64_decode_up_a + +PURE SUBROUTINE b64_encode_R16(n, code) + !< Encode scalar number to base64 (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=134.231_R16P, code=code64) + !< print "(A)", code64 + !<``` + !=> CKwcWmTHYEA= <<< + REAL(R16P), INTENT(in) :: n !< Number to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + + ALLOCATE (nI1P(1:((BYR16P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYR16P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) #if defined _R16P - padd = mod((BYR16P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd + padd = MOD((BYR16P), 3_I2P); IF (padd > 0_I4P) padd = 3_I4P - padd #else - padd = mod((BYR16P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd + padd = MOD((BYR16P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd #endif - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R16 - - pure subroutine b64_encode_R8(n, code) - !< Encode scalar number to base64 (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=1._R8P, code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAAAA8D8= <<< - real(R8P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYR8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYR8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYR8P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R8 - - pure subroutine b64_encode_R4(n, code) - !< Encode scalar number to base64 (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=0._R4P, code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAA== <<< - real(R4P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYR4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYR4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYR4P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R4 - - pure subroutine b64_encode_I8(n, code) - !< Encode scalar number to base64 (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=23_I8P, code=code64) - !< print "(A)", code64 - !<``` - !=> FwAAAAAAAAA= <<< - integer(I8P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I8 - - pure subroutine b64_encode_I4(n, code) - !< Encode scalar number to base64 (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=2023_I4P, code=code64) - !< print "(A)", code64 - !<``` - !=> 5wcAAA== <<< - integer(I4P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI4P),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I4 - - pure subroutine b64_encode_I2(n, code) - !< Encode scalar number to base64 (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=-203_I2P, code=code64) - !< print "(A)", code64 - !<``` - !=> Nf8= <<< - integer(I2P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI2P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI2P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI2P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I2 - - pure subroutine b64_encode_I1(n, code) - !< Encode scalar number to base64 (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=120_I1P, code=code64) - !< print "(A)", code64 - !<``` - !=> eA== <<< - integer(I1P), intent(in) :: n !< Number to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - - allocate(nI1P(1:((BYI1P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYI1P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((BYI1P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I1 - - pure subroutine b64_encode_string(s, code) - !< Encode scalar string to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(s='hello', code=code64) - !< print "(A)", code64 - !<``` - !=> aGVsbG8= <<< - character(*), intent(in) :: s !< String to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I4P) :: BYCHS !< Bytes of character string. - - BYCHS = byte_size(s) - allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYCHS+2)/3)*4) - nI1P = transfer(s,nI1P) - padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_string - - pure subroutine b64_encode_R16_a(n, code) - !< Encode array numbers to base64 (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[121._R16P,2.32_R16P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAABAXkCPwvUoXI8CQA== <<< - real(R16P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYR16P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYR16P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYR16P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R16_a - - pure subroutine b64_encode_R8_a(n, code) - !< Encode array numbers to base64 (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[1._R8P,2._R8P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAAAA8D8AAAAAAAAAQA== <<< - real(R8P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYR8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYR8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYR8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R8_a - - pure subroutine b64_encode_R4_a(n, code) - !< Encode array numbers to base64 (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[0._R4P,-32.12_R4P], code=code64) - !< print "(A)", code64 - !<``` - !=> AAAAAOF6AMI= <<< - real(R4P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYR4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYR4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYR4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_R4_a - - pure subroutine b64_encode_I8_a(n, code) - !< Encode array numbers to base64 (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[23_I8P,324_I8P,25456656_I8P,2_I8P], code=code64) - !< print "(A)", code64 - !<``` - !=> FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA= <<< - integer(I8P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI8P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI8P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I8_a - - pure subroutine b64_encode_I4_a(n, code) - !< Encode array numbers to base64 (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[2023_I4P,-24_I4P], code=code64) - !< print "(A)", code64 - !<``` - !=> 5wcAAOj///8= <<< - integer(I4P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI4P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI4P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I4_a - - pure subroutine b64_encode_I2_a(n, code) - !< Encode array numbers to base64 (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[-203_I2P,-10_I2P], code=code64) - !< print "(A)", code64 - !<``` - !=> Nf/2/w== <<< - integer(I2P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI2P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI2P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI2P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I2_a - - pure subroutine b64_encode_I1_a(n, code) - !< Encode array numbers to base64 (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(n=[120_I1P,-1_I1P], code=code64) - !< print "(A)", code64 - !<``` - !=> eP8= <<< - integer(I1P), intent(in) :: n(1:) !< Array of numbers to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded array. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I8P) :: ns !< Size of n. - - ns = size(n,dim=1) - allocate(nI1P(1:((ns*BYI1P+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((ns*BYI1P+2)/3)*4) - nI1P = transfer(n,nI1P) - padd = mod((ns*BYI1P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_I1_a - - pure subroutine b64_encode_string_a(s, code) - !< Encode array string to base64. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(len=:), allocatable :: code64 - !< call b64_encode(s=['hello','world'], code=code64) - !< print "(A)", code64 - !<``` - !=> aGVsbG93b3JsZA== <<< - character(*), intent(in) :: s(1:) !< String to be encoded. - character(len=:), allocatable, intent(out) :: code !< Encoded scalar. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - integer(I4P) :: padd !< Number of padding characters ('='). - integer(I4P) :: BYCHS !< Bytes of character string. - - BYCHS = byte_size(s(1))*size(s,dim=1) - allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P - code = repeat(' ',((BYCHS+2)/3)*4) - nI1P = transfer(s,nI1P) - padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd - call encode_bits(bits=nI1P,padd=padd,code=code) - endsubroutine b64_encode_string_a - - elemental subroutine b64_decode_R16(code, n) - !< Decode a base64 code into a scalar number (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R16P) :: scalar_R16 - !< call b64_decode(code='CKwcWmTHYEA=',n=scalar_R16) - !< print "(L1)", scalar_R16==134.231_R16P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - real(R16P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYR16P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R16 - - elemental subroutine b64_decode_R8(code, n) - !< Decode a base64 code into a scalar number (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: scalar_R8 - !< call b64_decode(code='AAAAAAAA8D8=',n=scalar_R8) - !< print "(L1)", scalar_R8==1._R8P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - real(R8P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYR8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R8 - - elemental subroutine b64_decode_R4(code, n) - !< Decode a base64 code into a scalar number (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: scalar_R4 - !< call b64_decode(code='AAAAAA==',n=scalar_R4) - !< print "(L1)", scalar_R4==0._R4P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - real(R4P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYR4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R4 - - elemental subroutine b64_decode_I8(code, n) - !< Decode a base64 code into a scalar number (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: scalar_I8 - !< call b64_decode(code='FwAAAAAAAAA=',n=scalar_I8) - !< print "(L1)", scalar_I8==23_I8P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I8P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I8 - - elemental subroutine b64_decode_I4(code, n) - !< Decode a base64 code into a scalar number (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: scalar_I4 - !< call b64_decode(code='5wcAAA==',n=scalar_I4) - !< print "(L1)", scalar_I4==2023_I4P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I4P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I4 - - elemental subroutine b64_decode_I2(code, n) - !< Decode a base64 code into a scalar number (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: scalar_I2 - !< call b64_decode(code='Nf8=',n=scalar_I2) - !< print "(L1)", scalar_I2==-203_I2P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I2P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI2P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I2 - - elemental subroutine b64_decode_I1(code, n) - !< Decode a base64 code into a scalar number (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: scalar_I1 - !< call b64_decode(code='eA==',n=scalar_I1) - !< print "(L1)", scalar_I1==120_I1P - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - integer(I1P), intent(out) :: n !< Number to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:BYI1P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I1 - - elemental subroutine b64_decode_string(code, s) - !< Decode a base64 code into a scalar string. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(:), allocatable :: code64 - !< code64 = repeat(' ',5) - !< call b64_decode(code='aGVsbG8=',s=code64) - !< print "(L1)", code64=='hello' - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - character(*), intent(out) :: s !< String to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:byte_size(s))) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - s = transfer(nI1P,s) - endsubroutine b64_decode_string - - pure subroutine b64_decode_R16_a(code, n) - !< Decode a base64 code into an array numbers (R16P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R16P) :: array_R16(1:2) - !< call b64_decode(code='AAAAAABAXkCPwvUoXI8CQA==',n=array_R16) - !< print "(L1)", str(n=array_R16)==str(n=[121._R16P,2.32_R16P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - real(R16P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYR16P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R16_a - - pure subroutine b64_decode_R8_a(code, n) - !< Decode a base64 code into an array numbers (R8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: array_R8(1:2) - !< call b64_decode(code='AAAAAAAA8D8AAAAAAAAAQA==',n=array_R8) - !< print "(L1)", str(n=array_R8)==str(n=[1._R8P,2._R8P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - real(R8P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYR8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R8_a - - pure subroutine b64_decode_R4_a(code, n) - !< Decode a base64 code into an array numbers (R4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: array_R4(1:2) - !< call b64_decode(code='AAAAAOF6AMI=',n=array_R4) - !< print "(L1)", str(n=array_R4)==str(n=[0._R4P,-32.12_R4P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - real(R4P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYR4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_R4_a - - pure subroutine b64_decode_I8_a(code, n) - !< Decode a base64 code into an array numbers (I8P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: array_I8(1:4) - !< call b64_decode(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=',n=array_I8) - !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I8P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI8P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I8_a - - pure subroutine b64_decode_I4_a(code, n) - !< Decode a base64 code into an array numbers (I4P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: array_I4(1:2) - !< call b64_decode(code='5wcAAOj///8=',n=array_I4) - !< print "(L1)", str(n=array_I4)==str(n=[2023_I4P,-24_I4P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I4P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI4P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I4_a - - pure subroutine b64_decode_I2_a(code, n) - !< Decode a base64 code into an array numbers (I2P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: array_I2(1:2) - !< call b64_decode(code='Nf/2/w==',n=array_I2) - !< print "(L1)", str(n=array_I2)==str(n=[-203_I2P,-10_I2P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I2P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI2P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I2_a - - pure subroutine b64_decode_I1_a(code, n) - !< Decode a base64 code into an array numbers (I1P). - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: array_I1(1:2) - !< call b64_decode(code='eP8=',n=array_I1) - !< print "(L1)", str(n=array_I1)==str(n=[120_I1P,-1_I1P]) - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded array. - integer(I1P), intent(out) :: n(1:) !< Array of numbers to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:size(n,dim=1)*BYI1P)) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - n = transfer(nI1P,n) - endsubroutine b64_decode_I1_a - - pure subroutine b64_decode_string_a(code, s) - !< Decode a base64 code into an array of strings. - !< - !<```fortran - !< use befor64 - !< use penf - !< character(5) :: array_s(1:2) - !< call b64_decode(code='aGVsbG93b3JsZA==',s=array_s) - !< print "(L1)", array_s(1)//array_s(2)=='helloworld' - !<``` - !=> T <<< - character(*), intent(in) :: code !< Encoded scalar. - character(*), intent(out) :: s(1:) !< String to be decoded. - integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n. - - allocate(nI1P(1:byte_size(s(1))*size(s,dim=1))) ; nI1P = 0_I1P - call decode_bits(code=code,bits=nI1P) - s = transfer(nI1P,s) - endsubroutine b64_decode_string_a + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_R16 + +PURE SUBROUTINE b64_encode_R8(n, code) + !< Encode scalar number to base64 (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=1._R8P, code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAAAA8D8= <<< + REAL(R8P), INTENT(in) :: n !< Number to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + + ALLOCATE (nI1P(1:((BYR8P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYR8P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((BYR8P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_R8 + +PURE SUBROUTINE b64_encode_R4(n, code) + !< Encode scalar number to base64 (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=0._R4P, code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAA== <<< + REAL(R4P), INTENT(in) :: n !< Number to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + + ALLOCATE (nI1P(1:((BYR4P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYR4P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((BYR4P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_R4 + +PURE SUBROUTINE b64_encode_I8(n, code) + !< Encode scalar number to base64 (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=23_I8P, code=code64) + !< print "(A)", code64 + !<``` + !=> FwAAAAAAAAA= <<< + INTEGER(I8P), INTENT(in) :: n !< Number to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + + ALLOCATE (nI1P(1:((BYI8P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYI8P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((BYI8P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I8 + +PURE SUBROUTINE b64_encode_I4(n, code) + !< Encode scalar number to base64 (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=2023_I4P, code=code64) + !< print "(A)", code64 + !<``` + !=> 5wcAAA== <<< + INTEGER(I4P), INTENT(in) :: n !< Number to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + + ALLOCATE (nI1P(1:((BYI4P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYI4P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((BYI4P), 3_I4P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I4 + +PURE SUBROUTINE b64_encode_I2(n, code) + !< Encode scalar number to base64 (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=-203_I2P, code=code64) + !< print "(A)", code64 + !<``` + !=> Nf8= <<< + INTEGER(I2P), INTENT(in) :: n !< Number to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + + ALLOCATE (nI1P(1:((BYI2P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYI2P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((BYI2P), 3_I2P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I2 + +PURE SUBROUTINE b64_encode_I1(n, code) + !< Encode scalar number to base64 (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=120_I1P, code=code64) + !< print "(A)", code64 + !<``` + !=> eA== <<< + INTEGER(I1P), INTENT(in) :: n !< Number to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + + ALLOCATE (nI1P(1:((BYI1P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYI1P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((BYI1P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I1 + +PURE SUBROUTINE b64_encode_string(s, code) + !< Encode scalar string to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(s='hello', code=code64) + !< print "(A)", code64 + !<``` + !=> aGVsbG8= <<< + CHARACTER(*), INTENT(in) :: s !< String to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I4P) :: BYCHS !< Bytes of character string. + + BYCHS = byte_size(s) + ALLOCATE (nI1P(1:((BYCHS + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYCHS + 2) / 3) * 4) + nI1P = TRANSFER(s, nI1P) + padd = MOD((BYCHS), 3_I4P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_string + +PURE SUBROUTINE b64_encode_R16_a(n, code) + !< Encode array numbers to base64 (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[121._R16P,2.32_R16P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAABAXkCPwvUoXI8CQA== <<< + REAL(R16P), INTENT(in) :: n(1:) !< Array of numbers to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I8P) :: ns !< Size of n. + + ns = SIZE(n, dim=1) + ALLOCATE (nI1P(1:((ns * BYR16P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((ns * BYR16P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((ns * BYR16P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_R16_a + +PURE SUBROUTINE b64_encode_R8_a(n, code) + !< Encode array numbers to base64 (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[1._R8P,2._R8P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAAAA8D8AAAAAAAAAQA== <<< + REAL(R8P), INTENT(in) :: n(1:) !< Array of numbers to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I8P) :: ns !< Size of n. + + ns = SIZE(n, dim=1) + ALLOCATE (nI1P(1:((ns * BYR8P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((ns * BYR8P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((ns * BYR8P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_R8_a + +PURE SUBROUTINE b64_encode_R4_a(n, code) + !< Encode array numbers to base64 (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[0._R4P,-32.12_R4P], code=code64) + !< print "(A)", code64 + !<``` + !=> AAAAAOF6AMI= <<< + REAL(R4P), INTENT(in) :: n(1:) !< Array of numbers to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I8P) :: ns !< Size of n. + + ns = SIZE(n, dim=1) + ALLOCATE (nI1P(1:((ns * BYR4P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((ns * BYR4P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((ns * BYR4P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_R4_a + +PURE SUBROUTINE b64_encode_I8_a(n, code) + !< Encode array numbers to base64 (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[23_I8P,324_I8P,25456656_I8P,2_I8P], code=code64) + !< print "(A)", code64 + !<``` + !=> FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA= <<< + INTEGER(I8P), INTENT(in) :: n(1:) !< Array of numbers to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I8P) :: ns !< Size of n. + + ns = SIZE(n, dim=1) + ALLOCATE (nI1P(1:((ns * BYI8P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((ns * BYI8P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((ns * BYI8P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I8_a + +PURE SUBROUTINE b64_encode_I4_a(n, code) + !< Encode array numbers to base64 (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[2023_I4P,-24_I4P], code=code64) + !< print "(A)", code64 + !<``` + !=> 5wcAAOj///8= <<< + INTEGER(I4P), INTENT(in) :: n(1:) !< Array of numbers to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I8P) :: ns !< Size of n. + + ns = SIZE(n, dim=1) + ALLOCATE (nI1P(1:((ns * BYI4P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((ns * BYI4P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((ns * BYI4P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I4_a + +PURE SUBROUTINE b64_encode_I2_a(n, code) + !< Encode array numbers to base64 (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[-203_I2P,-10_I2P], code=code64) + !< print "(A)", code64 + !<``` + !=> Nf/2/w== <<< + INTEGER(I2P), INTENT(in) :: n(1:) !< Array of numbers to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I8P) :: ns !< Size of n. + + ns = SIZE(n, dim=1) + ALLOCATE (nI1P(1:((ns * BYI2P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((ns * BYI2P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((ns * BYI2P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I2_a + +PURE SUBROUTINE b64_encode_I1_a(n, code) + !< Encode array numbers to base64 (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(n=[120_I1P,-1_I1P], code=code64) + !< print "(A)", code64 + !<``` + !=> eP8= <<< + INTEGER(I1P), INTENT(in) :: n(1:) !< Array of numbers to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I8P) :: ns !< Size of n. + + ns = SIZE(n, dim=1) + ALLOCATE (nI1P(1:((ns * BYI1P + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((ns * BYI1P + 2) / 3) * 4) + nI1P = TRANSFER(n, nI1P) + padd = MOD((ns * BYI1P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_I1_a + +PURE SUBROUTINE b64_encode_string_a(s, code) + !< Encode array string to base64. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(len=:), allocatable :: code64 + !< call b64_encode(s=['hello','world'], code=code64) + !< print "(A)", code64 + !<``` + !=> aGVsbG93b3JsZA== <<< + CHARACTER(*), INTENT(in) :: s(1:) !< String to be encoded. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + INTEGER(I4P) :: padd !< Number of padding characters ('='). + INTEGER(I4P) :: BYCHS !< Bytes of character string. + + BYCHS = byte_size(s(1)) * SIZE(s, dim=1) + ALLOCATE (nI1P(1:((BYCHS + 2) / 3) * 3)); nI1P = 0_I1P + code = REPEAT(' ', ((BYCHS + 2) / 3) * 4) + nI1P = TRANSFER(s, nI1P) + padd = MOD((BYCHS), 3_I4P); IF (padd > 0_I4P) padd = 3_I4P - padd + CALL encode_bits(bits=nI1P, padd=padd, code=code) +END SUBROUTINE b64_encode_string_a + +ELEMENTAL SUBROUTINE b64_decode_R16(code, n) + !< Decode a base64 code into a scalar number (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R16P) :: scalar_R16 + !< call b64_decode(code='CKwcWmTHYEA=',n=scalar_R16) + !< print "(L1)", scalar_R16==134.231_R16P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + REAL(R16P), INTENT(out) :: n !< Number to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:BYR16P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_R16 + +ELEMENTAL SUBROUTINE b64_decode_R8(code, n) + !< Decode a base64 code into a scalar number (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: scalar_R8 + !< call b64_decode(code='AAAAAAAA8D8=',n=scalar_R8) + !< print "(L1)", scalar_R8==1._R8P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + REAL(R8P), INTENT(out) :: n !< Number to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:BYR8P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_R8 + +ELEMENTAL SUBROUTINE b64_decode_R4(code, n) + !< Decode a base64 code into a scalar number (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: scalar_R4 + !< call b64_decode(code='AAAAAA==',n=scalar_R4) + !< print "(L1)", scalar_R4==0._R4P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + REAL(R4P), INTENT(out) :: n !< Number to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:BYR4P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_R4 + +ELEMENTAL SUBROUTINE b64_decode_I8(code, n) + !< Decode a base64 code into a scalar number (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: scalar_I8 + !< call b64_decode(code='FwAAAAAAAAA=',n=scalar_I8) + !< print "(L1)", scalar_I8==23_I8P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + INTEGER(I8P), INTENT(out) :: n !< Number to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:BYI8P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I8 + +ELEMENTAL SUBROUTINE b64_decode_I4(code, n) + !< Decode a base64 code into a scalar number (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: scalar_I4 + !< call b64_decode(code='5wcAAA==',n=scalar_I4) + !< print "(L1)", scalar_I4==2023_I4P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + INTEGER(I4P), INTENT(out) :: n !< Number to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:BYI4P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I4 + +ELEMENTAL SUBROUTINE b64_decode_I2(code, n) + !< Decode a base64 code into a scalar number (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: scalar_I2 + !< call b64_decode(code='Nf8=',n=scalar_I2) + !< print "(L1)", scalar_I2==-203_I2P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + INTEGER(I2P), INTENT(out) :: n !< Number to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:BYI2P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I2 + +ELEMENTAL SUBROUTINE b64_decode_I1(code, n) + !< Decode a base64 code into a scalar number (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: scalar_I1 + !< call b64_decode(code='eA==',n=scalar_I1) + !< print "(L1)", scalar_I1==120_I1P + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + INTEGER(I1P), INTENT(out) :: n !< Number to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:BYI1P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I1 + +ELEMENTAL SUBROUTINE b64_decode_string(code, s) + !< Decode a base64 code into a scalar string. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(:), allocatable :: code64 + !< code64 = repeat(' ',5) + !< call b64_decode(code='aGVsbG8=',s=code64) + !< print "(L1)", code64=='hello' + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + CHARACTER(*), INTENT(out) :: s !< String to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:byte_size(s))); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + s = TRANSFER(nI1P, s) +END SUBROUTINE b64_decode_string + +PURE SUBROUTINE b64_decode_R16_a(code, n) + !< Decode a base64 code into an array numbers (R16P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R16P) :: array_R16(1:2) + !< call b64_decode(code='AAAAAABAXkCPwvUoXI8CQA==',n=array_R16) + !< print "(L1)", str(n=array_R16)==str(n=[121._R16P,2.32_R16P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + REAL(R16P), INTENT(out) :: n(1:) !< Array of numbers to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYR16P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_R16_a + +PURE SUBROUTINE b64_decode_R8_a(code, n) + !< Decode a base64 code into an array numbers (R8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: array_R8(1:2) + !< call b64_decode(code='AAAAAAAA8D8AAAAAAAAAQA==',n=array_R8) + !< print "(L1)", str(n=array_R8)==str(n=[1._R8P,2._R8P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + REAL(R8P), INTENT(out) :: n(1:) !< Array of numbers to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYR8P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_R8_a + +PURE SUBROUTINE b64_decode_R4_a(code, n) + !< Decode a base64 code into an array numbers (R4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: array_R4(1:2) + !< call b64_decode(code='AAAAAOF6AMI=',n=array_R4) + !< print "(L1)", str(n=array_R4)==str(n=[0._R4P,-32.12_R4P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + REAL(R4P), INTENT(out) :: n(1:) !< Array of numbers to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYR4P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_R4_a + +PURE SUBROUTINE b64_decode_I8_a(code, n) + !< Decode a base64 code into an array numbers (I8P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: array_I8(1:4) + !< call b64_decode(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=',n=array_I8) + !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + INTEGER(I8P), INTENT(out) :: n(1:) !< Array of numbers to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI8P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I8_a + +PURE SUBROUTINE b64_decode_I4_a(code, n) + !< Decode a base64 code into an array numbers (I4P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: array_I4(1:2) + !< call b64_decode(code='5wcAAOj///8=',n=array_I4) + !< print "(L1)", str(n=array_I4)==str(n=[2023_I4P,-24_I4P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + INTEGER(I4P), INTENT(out) :: n(1:) !< Array of numbers to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI4P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I4_a + +PURE SUBROUTINE b64_decode_I2_a(code, n) + !< Decode a base64 code into an array numbers (I2P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: array_I2(1:2) + !< call b64_decode(code='Nf/2/w==',n=array_I2) + !< print "(L1)", str(n=array_I2)==str(n=[-203_I2P,-10_I2P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + INTEGER(I2P), INTENT(out) :: n(1:) !< Array of numbers to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI2P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I2_a + +PURE SUBROUTINE b64_decode_I1_a(code, n) + !< Decode a base64 code into an array numbers (I1P). + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: array_I1(1:2) + !< call b64_decode(code='eP8=',n=array_I1) + !< print "(L1)", str(n=array_I1)==str(n=[120_I1P,-1_I1P]) + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded array. + INTEGER(I1P), INTENT(out) :: n(1:) !< Array of numbers to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI1P)); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + n = TRANSFER(nI1P, n) +END SUBROUTINE b64_decode_I1_a + +PURE SUBROUTINE b64_decode_string_a(code, s) + !< Decode a base64 code into an array of strings. + !< + !<```fortran + !< use befor64 + !< use penf + !< character(5) :: array_s(1:2) + !< call b64_decode(code='aGVsbG93b3JsZA==',s=array_s) + !< print "(L1)", array_s(1)//array_s(2)=='helloworld' + !<``` + !=> T <<< + CHARACTER(*), INTENT(in) :: code !< Encoded scalar. + CHARACTER(*), INTENT(out) :: s(1:) !< String to be decoded. + INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n. + + ALLOCATE (nI1P(1:byte_size(s(1)) * SIZE(s, dim=1))); nI1P = 0_I1P + CALL decode_bits(code=code, bits=nI1P) + s = TRANSFER(nI1P, s) +END SUBROUTINE b64_decode_string_a endmodule befor64 diff --git a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 index 29fddacf8..aa0dd389b 100644 --- a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 +++ b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 @@ -1,14 +1,14 @@ !< KISS library for packing heterogeneous data into single (homogeneous) packed one. ! -module befor64_pack_data_m +MODULE befor64_pack_data_m !< KISS library for packing heterogeneous data into single (homogeneous) packed one. -use penf +USE penf -implicit none -private -public :: pack_data +IMPLICIT NONE +PRIVATE +PUBLIC :: pack_data -interface pack_data +INTERFACE pack_data !< Pack different kinds of data into single I1P array. !< !< This is useful for encoding different (heterogeneous) kinds variables into a single (homogeneous) stream of bits. @@ -63,786 +63,786 @@ module befor64_pack_data_m pack_data_I4_R8, pack_data_I4_R4, pack_data_I4_I8, pack_data_I4_I2, pack_data_I4_I1, & pack_data_I2_R8, pack_data_I2_R4, pack_data_I2_I8, pack_data_I2_I4, pack_data_I2_I1, & pack_data_I1_R8, pack_data_I1_R4, pack_data_I1_I8, pack_data_I1_I4, pack_data_I1_I2 -endinterface - -contains - pure subroutine pack_data_R8_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - real(R8P), intent(in) :: a1(1:) !< Firs data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_R4 - - pure subroutine pack_data_R8_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I8 - - pure subroutine pack_data_R8_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I4 - - pure subroutine pack_data_R8_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I2 - - pure subroutine pack_data_R8_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R8P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - real(R8P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R8_I1 - - pure subroutine pack_data_R4_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - real(R4P), intent(in) :: a1(1:) !< Firs data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_R8 - - pure subroutine pack_data_R4_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I8 - - pure subroutine pack_data_R4_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I4 - - pure subroutine pack_data_R4_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I2 - - pure subroutine pack_data_R4_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< real(R4P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - real(R4P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_R4_I1 - - pure subroutine pack_data_I8_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_R8 - - pure subroutine pack_data_I8_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_R4 - - pure subroutine pack_data_I8_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_I4 - - pure subroutine pack_data_I8_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_I2 - - pure subroutine pack_data_I8_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I8P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(9) - !<``` - !=> 1 <<< - integer(I8P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I8_I1 - - pure subroutine pack_data_I4_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_R8 - - pure subroutine pack_data_I4_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_R4 - - pure subroutine pack_data_I4_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_I8 - - pure subroutine pack_data_I4_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_I2 - - pure subroutine pack_data_I4_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I4P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(5) - !<``` - !=> 1 <<< - integer(I4P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I4_I1 - - pure subroutine pack_data_I2_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_R8 - - pure subroutine pack_data_I2_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_R4 - - pure subroutine pack_data_I2_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(3) - !<``` - !=> 1 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_I8 - - pure subroutine pack_data_I2_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(3) - !<``` - !=> 1 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_I4 - - pure subroutine pack_data_I2_I1(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I2P) :: a1(1) - !< integer(I1P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(3) - !<``` - !=> 1 <<< - integer(I2P), intent(in) :: a1(1:) !< First data stream. - integer(I1P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I2_I1 - - pure subroutine pack_data_I1_R8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< real(R8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - real(R8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_R8 - - pure subroutine pack_data_I1_R4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< real(R4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(size(pack, dim=1)) - !<``` - !=> 63 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - real(R4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_R4 - - pure subroutine pack_data_I1_I8(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< integer(I8P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(2) - !<``` - !=> 1 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - integer(I8P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_I8 - - pure subroutine pack_data_I1_I4(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< integer(I4P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(2) - !<``` - !=> 1 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - integer(I4P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_I4 - - pure subroutine pack_data_I1_I2(a1, a2, packed) - !< Pack different kinds of data into single I1P array. - !< - !<```fortran - !< use befor64 - !< use penf - !< integer(I1P) :: a1(1) - !< integer(I2P) :: a2(1) - !< integer(I1P), allocatable :: pack(:) - !< a1(1) = 0 - !< a2(1) = 1 - !< call pack_data(a1=a1, a2=a2, packed=pack) - !< print *, pack(2) - !<``` - !=> 1 <<< - integer(I1P), intent(in) :: a1(1:) !< First data stream. - integer(I2P), intent(in) :: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream. - - p1 = transfer(a1,p1) - p2 = transfer(a2,p2) - packed = [p1,p2] - endsubroutine pack_data_I1_I2 +end interface + +CONTAINS +PURE SUBROUTINE pack_data_R8_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + REAL(R8P), INTENT(in) :: a1(1:) !< Firs data stream. + REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R8_R4 + +PURE SUBROUTINE pack_data_R8_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + REAL(R8P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R8_I8 + +PURE SUBROUTINE pack_data_R8_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + REAL(R8P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R8_I4 + +PURE SUBROUTINE pack_data_R8_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + REAL(R8P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R8_I2 + +PURE SUBROUTINE pack_data_R8_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R8P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + REAL(R8P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R8_I1 + +PURE SUBROUTINE pack_data_R4_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + REAL(R4P), INTENT(in) :: a1(1:) !< Firs data stream. + REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R4_R8 + +PURE SUBROUTINE pack_data_R4_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + REAL(R4P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R4_I8 + +PURE SUBROUTINE pack_data_R4_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + REAL(R4P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R4_I4 + +PURE SUBROUTINE pack_data_R4_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + REAL(R4P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R4_I2 + +PURE SUBROUTINE pack_data_R4_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< real(R4P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + REAL(R4P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_R4_I1 + +PURE SUBROUTINE pack_data_I8_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I8_R8 + +PURE SUBROUTINE pack_data_I8_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I8_R4 + +PURE SUBROUTINE pack_data_I8_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I8_I4 + +PURE SUBROUTINE pack_data_I8_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I8_I2 + +PURE SUBROUTINE pack_data_I8_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I8P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(9) + !<``` + !=> 1 <<< + INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I8_I1 + +PURE SUBROUTINE pack_data_I4_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I4_R8 + +PURE SUBROUTINE pack_data_I4_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I4_R4 + +PURE SUBROUTINE pack_data_I4_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I4_I8 + +PURE SUBROUTINE pack_data_I4_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I4_I2 + +PURE SUBROUTINE pack_data_I4_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I4P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(5) + !<``` + !=> 1 <<< + INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I4_I1 + +PURE SUBROUTINE pack_data_I2_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I2_R8 + +PURE SUBROUTINE pack_data_I2_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I2_R4 + +PURE SUBROUTINE pack_data_I2_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(3) + !<``` + !=> 1 <<< + INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I2_I8 + +PURE SUBROUTINE pack_data_I2_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(3) + !<``` + !=> 1 <<< + INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I2_I4 + +PURE SUBROUTINE pack_data_I2_I1(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I2P) :: a1(1) + !< integer(I1P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(3) + !<``` + !=> 1 <<< + INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I2_I1 + +PURE SUBROUTINE pack_data_I1_R8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< real(R8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I1_R8 + +PURE SUBROUTINE pack_data_I1_R4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< real(R4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(size(pack, dim=1)) + !<``` + !=> 63 <<< + INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream. + REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I1_R4 + +PURE SUBROUTINE pack_data_I1_I8(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< integer(I8P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(2) + !<``` + !=> 1 <<< + INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I1_I8 + +PURE SUBROUTINE pack_data_I1_I4(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< integer(I4P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(2) + !<``` + !=> 1 <<< + INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I1_I4 + +PURE SUBROUTINE pack_data_I1_I2(a1, a2, packed) + !< Pack different kinds of data into single I1P array. + !< + !<```fortran + !< use befor64 + !< use penf + !< integer(I1P) :: a1(1) + !< integer(I2P) :: a2(1) + !< integer(I1P), allocatable :: pack(:) + !< a1(1) = 0 + !< a2(1) = 1 + !< call pack_data(a1=a1, a2=a2, packed=pack) + !< print *, pack(2) + !<``` + !=> 1 <<< + INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream. + INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream. + INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array. + INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream. + INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream. + + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +end subroutine pack_data_I1_I2 endmodule befor64_pack_data_m diff --git a/src/modules/Display/src/Display_Method.F90 b/src/modules/Display/src/Display_Method.F90 index 2a7fd7d35..c516de534 100755 --- a/src/modules/Display/src/Display_Method.F90 +++ b/src/modules/Display/src/Display_Method.F90 @@ -43,17 +43,16 @@ MODULE Display_Method CHARACTER(*), PARAMETER :: COLOR_BG = "BLACK" CHARACTER(*), PARAMETER :: COLOR_STYLE = "BOLD_ON" -TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: & - & DisplayProfileTerminal = DISP_SETTINGS(& - & advance="YES", matsep=",", orient="COL", style="UNDERLINE", & - & trim="FALSE", ZEROAS=".") +TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: DisplayProfileTerminal = & + DISP_SETTINGS(advance="YES", matsep=",", orient="COL", style="UNDERLINE", & + trim="FALSE", ZEROAS=".") -TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: & - & DisplayProfilePrint = DISP_SETTINGS(& - & advance="YES", matsep=",", orient="COL", style="UNDERLINE", & - & trim="FALSE", ZEROAS="") +TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: DisplayProfilePrint = & + DISP_SETTINGS(advance="YES", matsep=",", orient="COL", style="UNDERLINE", & + trim="FALSE", ZEROAS="") + +! TYPE(DISP_SETTINGS), PARAMETER :: DisplayProfileOriginal = DISP_SETTINGS() -TYPE(DISP_SETTINGS), PARAMETER :: DisplayProfileOriginal = DISP_SETTINGS() LOGICAL(LGT) :: defaultSettingSet = .FALSE. !---------------------------------------------------------------------------- diff --git a/src/modules/Display/src/disp/disp_charmod.F90 b/src/modules/Display/src/disp/disp_charmod.F90 index cd12e191e..98f8cc22a 100755 --- a/src/modules/Display/src/disp/disp_charmod.F90 +++ b/src/modules/Display/src/disp/disp_charmod.F90 @@ -11,7 +11,7 @@ MODULE DISP_CHARMOD USE DISPMODULE_UTIL -USE GlobalData, ONLY: Real32 +USE GlobalData, ONLY: REAL32 PRIVATE PUBLIC DISP @@ -27,59 +27,59 @@ MODULE DISP_CHARMOD subroutine disp_v_dchr(x, fmt, advance, lbound, sep, style, trim, unit, orient) ! Default character vector without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - character(*), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tv_dchr('', x, fmt, advance, lbound, sep, style, trim, unit, orient) -end subroutine disp_v_dchr + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient + CHARACTER(*), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) +CALL disp_tv_dchr('', x, fmt, advance, lbound, sep, style, trim, unit, orient) +END SUBROUTINE disp_v_dchr !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -subroutine disp_m_dchr(x, fmt, advance, lbound, sep, style, trim, unit) +SUBROUTINE disp_m_dchr(x, fmt, advance, lbound, sep, style, trim, unit) ! Default character matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim - character(*), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_dchr('', x, fmt, advance, lbound, sep, style, trim, unit) -end subroutine disp_m_dchr + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim + CHARACTER(*), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) + CALL disp_tm_dchr('', x, fmt, advance, lbound, sep, style, trim, unit) +END SUBROUTINE disp_m_dchr !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -subroutine disp_ts_dchr(title, x, fmt, advance, sep, style, trim, unit) +SUBROUTINE disp_ts_dchr(title, x, fmt, advance, sep, style, trim, unit) ! Default character scalar with title - character(*), intent(in), optional :: title, x, fmt, advance, sep, style, trim - character(0) empty(1,0) - integer, intent(in), optional :: unit +CHARACTER(*), INTENT(in), OPTIONAL :: title, x, fmt, advance, sep, style, trim + CHARACTER(0) empty(1, 0) + INTEGER, INTENT(in), OPTIONAL :: unit empty = '' - if (present(title).and.present(x)) then + IF (PRESENT(title) .AND. PRESENT(x)) THEN call disp_nonopt_dchr(title, x, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) - elseif (present(x)) then + ELSEIF (PRESENT(x)) THEN call disp_nonopt_dchr('', x, fmt, advance, sep=sep, style='left', trim=trim, unit=unit) - elseif (present(title)) then + ELSEIF (PRESENT(title)) THEN call disp_nonopt_dchr('', title, fmt, advance, sep=sep, style='left', trim=trim, unit=unit) - else + ELSE call disp_tm_dchr('', empty, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) - end if -end subroutine disp_ts_dchr + END IF +END SUBROUTINE disp_ts_dchr !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -subroutine disp_nonopt_dchr(title, x, fmt, advance, sep, style, trim, unit) +SUBROUTINE disp_nonopt_dchr(title, x, fmt, advance, sep, style, trim, unit) ! This routine exists to circumvent bug in gfortran, that made it not possible to change scalar strings ! to matrices with reshape in calls of disp_tm_dchr. This intermediate routine provides work-around. - character(*), intent(in) :: title, x, fmt, advance, sep, style, trim - optional fmt, advance, sep, style, trim - integer, intent(in), optional :: unit - character(len(x)) :: xm(1,1) - xm(1,1) = x + CHARACTER(*), INTENT(in) :: title, x, fmt, advance, sep, style, trim + OPTIONAL fmt, advance, sep, style, trim + INTEGER, INTENT(in), OPTIONAL :: unit + CHARACTER(LEN(x)) :: xm(1, 1) + xm(1, 1) = x call disp_tm_dchr(title, xm, fmt, advance, sep=sep, style=style, trim=trim, unit=unit) -end subroutine disp_nonopt_dchr +END SUBROUTINE disp_nonopt_dchr !---------------------------------------------------------------------------- ! @@ -87,17 +87,17 @@ end subroutine disp_nonopt_dchr subroutine disp_tv_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit, orient) ! Default character vector with title - character(*), intent(in) :: title, x(:) - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE + CHARACTER(*), INTENT(in) :: title, x(:) + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient) - if (SE%row) then - call disp_dchr(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_dchr(title, reshape(x, (/size(x), 1/)), SE) - end if -end subroutine disp_tv_dchr + IF (SE%row) THEN + CALL disp_dchr(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_dchr(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_dchr !---------------------------------------------------------------------------- ! @@ -105,71 +105,71 @@ end subroutine disp_tv_dchr subroutine disp_tm_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit) ! Default character matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - character(*), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'A4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): see NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + CHARACTER(*), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'A4') + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): see NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x ! - type(settings) :: SE - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit) - call disp_dchr(title, x, SE) -end subroutine disp_tm_dchr + TYPE(settings) :: SE +CALL get_SE(SE, title, SHAPE(x), fmt, advance, lbound, sep, style, trim, unit) + CALL disp_dchr(title, x, SE) +END SUBROUTINE disp_tm_dchr !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -subroutine disp_dchr(title, x, SE) +SUBROUTINE disp_dchr(title, x, SE) ! Default character item to box - character(*), intent(in) :: title, x(:,:) - type(settings), intent(INOUT ) :: SE - character(13) :: edesc - character, pointer :: boxp(:,:) - integer :: m, n, j, lin1, wleft, lx, w - integer, dimension(size(x,2)) :: wid, nbl, n1, n2, widp - m = size(x,1) - n = size(x,2) - lx = len(x) + CHARACTER(*), INTENT(in) :: title, x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + CHARACTER(13) :: edesc + CHARACTER, POINTER :: boxp(:, :) + INTEGER :: m, n, j, lin1, wleft, lx, w + INTEGER, DIMENSION(SIZE(x, 2)) :: wid, nbl, n1, n2, widp + m = SIZE(x, 1) + n = SIZE(x, 2) + lx = LEN(x) w = SE%w - if (w <= 0) then + IF (w <= 0) THEN w = lx - if (w < 0) then + IF (w < 0) THEN edesc = '(A__________)' - write(edesc(3:12), '(SS,I10)') w + WRITE (edesc(3:12), '(SS,I10)') w SE%ed = edesc - end if - end if - if (SE%trm .and. size(x) > 0) then - n1 = minval(mod(verify(x, ' ') - w - 1, w + 1), 1) + w + 1 - n2 = maxval(verify(x, ' ', back = .true.), 1) + END IF + END IF + IF (SE%trm .AND. SIZE(x) > 0) THEN + n1 = MINVAL(MOD(VERIFY(x, ' ') - w - 1, w + 1), 1) + w + 1 + n2 = MAXVAL(VERIFY(x, ' ', back=.TRUE.), 1) wid = n2 - n1 + 1 nbl = w - wid - else + ELSE n1 = 1 n2 = w wid = w nbl = 0 - end if - if (all(wid == 0)) n = 0 + END IF + IF (ALL(wid == 0)) n = 0 SE%w = w - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (SE%trm) then + CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + DO j = 1, n + IF (SE%trm) THEN call copytobox(x(:,j)(n1(j):n2(j)), lin1, wid(j), widp(j), nbl(j), boxp, wleft) - else + ELSE if (widp(j) > lx) call copyseptobox(repeat(' ', widp(j)-lx), m, lin1, boxp, wleft) - call copytobox(x(:,j), lin1, lx, lx, 0, boxp, wleft) - end if - if (j 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) WRITE (s, SE%ed) x(:, j) + IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0) + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_byte - subroutine find_editdesc_byte(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid - integer(byte), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(out) :: wid(size(x,2)), nbl(size(x,2)) - ! - integer(byte) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm - logical xzero(size(x,2)), xallz(size(x,2)) - character(22) s - integer ww - ! - if (SE%w == 0) then - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - SE%w = max(SE%lzas, ww) - call replace_w(SE%ed, ww) - elseif (SE%w < 0) then ! obtain max-width of x - if (size(x) == 0) then - SE%ed = '()' - SE%w = 0 - wid = 0 - return - endif - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - ww = max(SE%lzas, ww) - SE%ed = '(SS,Ixx)' - write(SE%ed(6:7), '(SS,I2)') ww - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1) ! max in each column - xminv = minval(x, 1) ! min - xzero = any(x == 0_byte, 1) ! true where column has some zeros - xallz = all(x == 0_byte, 1) ! true where column has only zeros - call getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - else - wid = SE%w - nbl = 0 - endif - end subroutine find_editdesc_byte +SUBROUTINE find_editdesc_byte(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid + INTEGER(byte), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + ! + INTEGER(byte) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm + LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2)) + CHARACTER(22) s + INTEGER ww + ! + IF (SE%w == 0) THEN + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + SE%w = MAX(SE%lzas, ww) + CALL replace_w(SE%ed, ww) + ELSEIF (SE%w < 0) THEN ! obtain max-width of x + IF (SIZE(x) == 0) THEN + SE%ed = '()' + SE%w = 0 + wid = 0 + RETURN + END IF + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + ww = MAX(SE%lzas, ww) + SE%ed = '(SS,Ixx)' + WRITE (SE%ed(6:7), '(SS,I2)') ww + SE%w = ww + END IF + IF (SE%trm) THEN + xmaxv = MAXVAL(x, 1) ! max in each column + xminv = MINVAL(x, 1) ! min + xzero = ANY(x == 0_BYTE, 1) ! true where column has some zeros + xallz = ALL(x == 0_BYTE, 1) ! true where column has only zeros + CALL getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + ELSE + wid = SE%w + nbl = 0 + END IF +END SUBROUTINE find_editdesc_byte - subroutine getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - integer(byte), intent(in) :: xmaxv(:), xminv(:) - logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros - type(settings), intent(in) :: SE ! Settings - integer, intent(out) :: wid(:) ! Widths of columns - integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmax, SE%ed) xmaxv - write(stmin, SE%ed) xminv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - wid = w - nbl - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byte +SUBROUTINE getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + INTEGER(byte), INTENT(in) :: xmaxv(:), xminv(:) + LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros + TYPE(settings), INTENT(in) :: SE ! Settings + INTEGER, INTENT(out) :: wid(:) ! Widths of columns + INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid) + CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv)) + INTEGER w + w = SE%w + WRITE (stmax, SE%ed) xmaxv + WRITE (stmin, SE%ed) xminv + nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1)) + wid = w - nbl + IF (SE%lzas > 0) THEN + wid = MERGE(SE%lzas, wid, xallz) + wid = MAX(wid, MERGE(SE%lzas, 0, xzero)) + nbl = w - wid + END IF +END SUBROUTINE getwid_byte - ! ********* 1-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byte(x) result(st) - ! Scalar to string - integer(byte), intent(in) :: x - character(len_f_byte((/x/), tosset0%ifmt)) :: st - st = tostring_f_byte((/x/), tosset0%ifmt) - end function tostring_s_byte +! ********* 1-BYTE INTEGER TOSTRING PROCEDURES ********* +FUNCTION tostring_s_byte(x) RESULT(st) + ! Scalar to string + INTEGER(byte), INTENT(in) :: x + CHARACTER(len_f_byte((/x/), tosset0%ifmt)) :: st + st = tostring_f_byte((/x/), tosset0%ifmt) +END FUNCTION tostring_s_byte - function tostring_sf_byte(x, fmt) result(st) - ! Scalar with specified format to string - integer(byte),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byte((/x/), fmt)) :: st - st = tostring_f_byte((/x/), fmt) - end function tostring_sf_byte +FUNCTION tostring_sf_byte(x, fmt) RESULT(st) + ! Scalar with specified format to string + INTEGER(byte), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byte((/x/), fmt)) :: st + st = tostring_f_byte((/x/), fmt) +END FUNCTION tostring_sf_byte - function tostring_byte(x) result(st) - ! Vector to string - integer(byte), intent(in) :: x(:) - character(len_f_byte(x, tosset0%ifmt)) :: st - st = tostring_f_byte(x, tosset0%ifmt) - end function tostring_byte +FUNCTION tostring_byte(x) RESULT(st) + ! Vector to string + INTEGER(byte), INTENT(in) :: x(:) + CHARACTER(len_f_byte(x, tosset0%ifmt)) :: st + st = tostring_f_byte(x, tosset0%ifmt) +END FUNCTION tostring_byte - function tostring_f_byte(x, fmt) result(st) - ! Vector with specified format to string - integer(byte), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byte(x, fmt)) :: st - character(widthmax_byte(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byte +FUNCTION tostring_f_byte(x, fmt) RESULT(st) + ! Vector with specified format to string + INTEGER(byte), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byte(x, fmt)) :: st + CHARACTER(widthmax_byte(x, fmt)) :: sa(SIZE(x)) + INTEGER :: w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; st = errormsg; RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_byte - pure function len_f_byte(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byte), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byte(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byte +PURE FUNCTION len_f_byte(x, fmt) RESULT(wtot) + ! Total width of tostring representation of x + INTEGER(byte), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(widthmax_byte(x, fmt)) :: sa(SIZE(x)) + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_byte - pure function widthmax_byte(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byte), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byte +PURE FUNCTION widthmax_byte(x, fmt) RESULT(w) + ! Maximum width of string representation of an element in x + INTEGER(byte), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(RANGE(x) + 2) sx(2) + INTEGER w, d + LOGICAL gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w <= 0) THEN + WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x) + w = MAXVAL(LEN_TRIM(sx)) + END IF +END FUNCTION widthmax_byte END MODULE DISP_I1MOD diff --git a/src/modules/Display/src/disp/disp_i2mod.F90 b/src/modules/Display/src/disp/disp_i2mod.F90 index 3fa00b9b5..2047c0976 100755 --- a/src/modules/Display/src/disp/disp_i2mod.F90 +++ b/src/modules/Display/src/disp/disp_i2mod.F90 @@ -1,276 +1,276 @@ MODULE DISP_I2MOD - ! Add-on module to DISPMODULE to display 2-byte integers - ! (assuming that these are obtained with selected_int_kind(4)) - ! - ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from - ! from dispmodule.F90, replacing dint with byt2 and default integer' with 2-byte - ! integer (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. +! Add-on module to DISPMODULE to display 2-byte integers +! (assuming that these are obtained with selected_int_kind(4)) +! +! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from +! from dispmodule.F90, replacing dint with byt2 and default integer' with 2-byte +! integer (only appears in comments), and adding the DECLARATIONS section below. +! +! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of +! Iceland (jonasson@hi.is). This software is free. For details see the file README. - ! ******************************** DECLARATIONS ******************************************** - USE DISPMODULE_UTIL - USE GlobalData, ONLY: Int16 - IMPLICIT NONE - PRIVATE +! ******************************** DECLARATIONS ******************************************** +USE DISPMODULE_UTIL +USE GlobalData, ONLY: INT16 +IMPLICIT NONE +PRIVATE - PUBLIC DISP - PUBLIC TOSTRING +PUBLIC DISP +PUBLIC TOSTRING - interface Display +INTERFACE Display module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2 - end interface +END INTERFACE - interface disp +INTERFACE disp module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2 - end interface +END INTERFACE - interface tostring +INTERFACE tostring module procedure tostring_byt2, tostring_f_byt2, tostring_s_byt2, tostring_sf_byt2 - end interface +END INTERFACE - ! integer, parameter :: byt2 = selected_int_kind(4) - integer, parameter :: byt2 = Int16 +! integer, parameter :: byt2 = selected_int_kind(4) +INTEGER, PARAMETER :: byt2 = INT16 CONTAINS - ! ******************************** 2-BYTE INTEGER PROCEDURES ******************************* - subroutine disp_s_byt2(x, fmt, advance, sep, trim, unit, zeroas) - ! 2-byte integer scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - integer(byt2), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_byt2('', x, fmt, advance, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_byt2 +! ******************************** 2-BYTE INTEGER PROCEDURES ******************************* +SUBROUTINE disp_s_byt2(x, fmt, advance, sep, trim, unit, zeroas) + ! 2-byte integer scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas + INTEGER(byt2), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit + CALL disp_ts_byt2('', x, fmt, advance, sep, 'left', trim, unit, zeroas) +END SUBROUTINE disp_s_byt2 subroutine disp_v_byt2(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 2-byte integer vector without title + ! 2-byte integer vector without title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt2), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) + INTEGER(byt2), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) call disp_tv_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_byt2 +END SUBROUTINE disp_v_byt2 subroutine disp_m_byt2(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 2-byte integer matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt2), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_byt2 + ! 2-byte integer matrix without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + INTEGER(byt2), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) +CALL disp_tm_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) +END SUBROUTINE disp_m_byt2 subroutine disp_ts_byt2(title, x, fmt, advance, sep, style, trim, unit, zeroas) - ! 2-byte integer scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt2), intent(in) :: x - integer, intent(in), optional :: unit + ! 2-byte integer scalar with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + INTEGER(byt2), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit call disp_tm_byt2(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & - zeroas=zeroas) - end subroutine disp_ts_byt2 + zeroas=zeroas) +END SUBROUTINE disp_ts_byt2 subroutine disp_tv_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 2-byte integer vector with title - character(*), intent(in) :: title + ! 2-byte integer vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt2), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE + INTEGER(byt2), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - if (SE%row) then - call disp_byt2(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_byt2(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_byt2 + IF (SE%row) THEN + CALL disp_byt2(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_byt2(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_byt2 subroutine disp_tm_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 2-byte integer matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - integer(byt2),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE + ! 2-byte integer matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + INTEGER(byt2), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced by this string + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) - call disp_byt2(title, x, SE) - end subroutine disp_tm_byt2 + CALL disp_byt2(title, x, SE) +END SUBROUTINE disp_tm_byt2 - subroutine disp_byt2(title, x, SE) - ! 2-byte integer item - character(*), intent(in) :: title - integer(byt2), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_byt2(x, SE, wid, nbl) ! determine also SE%w - call tobox_byt2(title, x, SE, wid, nbl) - end subroutine disp_byt2 +SUBROUTINE disp_byt2(title, x, SE) + ! 2-byte integer item + CHARACTER(*), INTENT(in) :: title + INTEGER(byt2), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + CALL find_editdesc_byt2(x, SE, wid, nbl) ! determine also SE%w + CALL tobox_byt2(title, x, SE, wid, nbl) +END SUBROUTINE disp_byt2 - subroutine tobox_byt2(title, x, SE, wid, nbl) - ! Write 2-byte integer matrix to box - character(*), intent(in) :: title - integer(byt2), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) WRITE (s, SE%ed) x(:, j) + IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0) + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_byt2 - subroutine find_editdesc_byt2(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid - integer(byt2), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(out) :: wid(size(x,2)), nbl(size(x,2)) - ! - integer(byt2) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm - logical xzero(size(x,2)), xallz(size(x,2)) - character(22) s - integer ww - ! - if (SE%w == 0) then - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - SE%w = max(SE%lzas, ww) - call replace_w(SE%ed, ww) - elseif (SE%w < 0) then ! obtain max-width of x - if (size(x) == 0) then - SE%ed = '()' - SE%w = 0 - wid = 0 - return - endif - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - ww = max(SE%lzas, ww) - SE%ed = '(SS,Ixx)' - write(SE%ed(6:7), '(SS,I2)') ww - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1) ! max in each column - xminv = minval(x, 1) ! min - xzero = any(x == 0_byt2, 1) ! true where column has some zeros - xallz = all(x == 0_byt2, 1) ! true where column has only zeros - call getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - else - wid = SE%w - nbl = 0 - endif - end subroutine find_editdesc_byt2 +SUBROUTINE find_editdesc_byt2(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid + INTEGER(byt2), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + ! + INTEGER(byt2) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm + LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2)) + CHARACTER(22) s + INTEGER ww + ! + IF (SE%w == 0) THEN + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + SE%w = MAX(SE%lzas, ww) + CALL replace_w(SE%ed, ww) + ELSEIF (SE%w < 0) THEN ! obtain max-width of x + IF (SIZE(x) == 0) THEN + SE%ed = '()' + SE%w = 0 + wid = 0 + RETURN + END IF + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + ww = MAX(SE%lzas, ww) + SE%ed = '(SS,Ixx)' + WRITE (SE%ed(6:7), '(SS,I2)') ww + SE%w = ww + END IF + IF (SE%trm) THEN + xmaxv = MAXVAL(x, 1) ! max in each column + xminv = MINVAL(x, 1) ! min + xzero = ANY(x == 0_BYT2, 1) ! true where column has some zeros + xallz = ALL(x == 0_BYT2, 1) ! true where column has only zeros + CALL getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + ELSE + wid = SE%w + nbl = 0 + END IF +END SUBROUTINE find_editdesc_byt2 - subroutine getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - integer(byt2), intent(in) :: xmaxv(:), xminv(:) - logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros - type(settings), intent(in) :: SE ! Settings - integer, intent(out) :: wid(:) ! Widths of columns - integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmax, SE%ed) xmaxv - write(stmin, SE%ed) xminv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - wid = w - nbl - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byt2 +SUBROUTINE getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + INTEGER(byt2), INTENT(in) :: xmaxv(:), xminv(:) + LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros + TYPE(settings), INTENT(in) :: SE ! Settings + INTEGER, INTENT(out) :: wid(:) ! Widths of columns + INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid) + CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv)) + INTEGER w + w = SE%w + WRITE (stmax, SE%ed) xmaxv + WRITE (stmin, SE%ed) xminv + nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1)) + wid = w - nbl + IF (SE%lzas > 0) THEN + wid = MERGE(SE%lzas, wid, xallz) + wid = MAX(wid, MERGE(SE%lzas, 0, xzero)) + nbl = w - wid + END IF +END SUBROUTINE getwid_byt2 - ! ********* 2-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byt2(x) result(st) - ! Scalar to string - integer(byt2), intent(in) :: x - character(len_f_byt2((/x/), tosset0%ifmt)) :: st - st = tostring_f_byt2((/x/), tosset0%ifmt) - end function tostring_s_byt2 +! ********* 2-BYTE INTEGER TOSTRING PROCEDURES ********* +FUNCTION tostring_s_byt2(x) RESULT(st) + ! Scalar to string + INTEGER(byt2), INTENT(in) :: x + CHARACTER(len_f_byt2((/x/), tosset0%ifmt)) :: st + st = tostring_f_byt2((/x/), tosset0%ifmt) +END FUNCTION tostring_s_byt2 - function tostring_sf_byt2(x, fmt) result(st) - ! Scalar with specified format to string - integer(byt2),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byt2((/x/), fmt)) :: st - st = tostring_f_byt2((/x/), fmt) - end function tostring_sf_byt2 +FUNCTION tostring_sf_byt2(x, fmt) RESULT(st) + ! Scalar with specified format to string + INTEGER(byt2), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byt2((/x/), fmt)) :: st + st = tostring_f_byt2((/x/), fmt) +END FUNCTION tostring_sf_byt2 - function tostring_byt2(x) result(st) - ! Vector to string - integer(byt2), intent(in) :: x(:) - character(len_f_byt2(x, tosset0%ifmt)) :: st - st = tostring_f_byt2(x, tosset0%ifmt) - end function tostring_byt2 +FUNCTION tostring_byt2(x) RESULT(st) + ! Vector to string + INTEGER(byt2), INTENT(in) :: x(:) + CHARACTER(len_f_byt2(x, tosset0%ifmt)) :: st + st = tostring_f_byt2(x, tosset0%ifmt) +END FUNCTION tostring_byt2 - function tostring_f_byt2(x, fmt) result(st) - ! Vector with specified format to string - integer(byt2), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byt2(x, fmt)) :: st - character(widthmax_byt2(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byt2 +FUNCTION tostring_f_byt2(x, fmt) RESULT(st) + ! Vector with specified format to string + INTEGER(byt2), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byt2(x, fmt)) :: st + CHARACTER(widthmax_byt2(x, fmt)) :: sa(SIZE(x)) + INTEGER :: w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; st = errormsg; RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_byt2 - pure function len_f_byt2(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byt2), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byt2(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byt2 +PURE FUNCTION len_f_byt2(x, fmt) RESULT(wtot) + ! Total width of tostring representation of x + INTEGER(byt2), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(widthmax_byt2(x, fmt)) :: sa(SIZE(x)) + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_byt2 - pure function widthmax_byt2(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byt2), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byt2 - ! ************************************* END OF 2-BYTE INTEGER PROCEDURES ****************************************** +PURE FUNCTION widthmax_byt2(x, fmt) RESULT(w) + ! Maximum width of string representation of an element in x + INTEGER(byt2), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(RANGE(x) + 2) sx(2) + INTEGER w, d + LOGICAL gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w <= 0) THEN + WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x) + w = MAXVAL(LEN_TRIM(sx)) + END IF +END FUNCTION widthmax_byt2 +! ************************************* END OF 2-BYTE INTEGER PROCEDURES ****************************************** END MODULE DISP_I2MOD diff --git a/src/modules/Display/src/disp/disp_i4mod.F90 b/src/modules/Display/src/disp/disp_i4mod.F90 index 497fe3d7d..5c7835447 100755 --- a/src/modules/Display/src/disp/disp_i4mod.F90 +++ b/src/modules/Display/src/disp/disp_i4mod.F90 @@ -1,270 +1,270 @@ MODULE DISP_I4MOD - ! Add-on module to DISPMODULE to display 4-byte integers - ! (assuming that these are obtained with selected_int_kind(18)) - ! - ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from - ! from dispmodule.F90, replacing dint with byt4 and 'default integer' with 4-byte - ! integer (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. +! Add-on module to DISPMODULE to display 4-byte integers +! (assuming that these are obtained with selected_int_kind(18)) +! +! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from +! from dispmodule.F90, replacing dint with byt4 and 'default integer' with 4-byte +! integer (only appears in comments), and adding the DECLARATIONS section below. +! +! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of +! Iceland (jonasson@hi.is). This software is free. For details see the file README. - ! ******************************** DECLARATIONS ******************************************** - USE dispmodule_util - USE GlobalData, ONLY: Int32 - IMPLICIT NONE - PRIVATE - PUBLIC DISP - PUBLIC TOSTRING +! ******************************** DECLARATIONS ******************************************** +USE dispmodule_util +USE GlobalData, ONLY: INT32 +IMPLICIT NONE +PRIVATE +PUBLIC DISP +PUBLIC TOSTRING - interface disp +INTERFACE disp module procedure disp_s_byt4, disp_ts_byt4, disp_v_byt4, disp_tv_byt4, disp_m_byt4, disp_tm_byt4 - end interface +END INTERFACE - interface tostring +INTERFACE tostring module procedure tostring_byt4, tostring_f_byt4, tostring_s_byt4, tostring_sf_byt4 - end interface +END INTERFACE - integer, parameter :: byt4 = Int32 +INTEGER, PARAMETER :: byt4 = INT32 CONTAINS - ! ******************************** 4-BYTE INTEGER PROCEDURES ******************************* - subroutine disp_s_byt4(x, fmt, advance, sep, trim, unit, zeroas) - ! 4-byte integer scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - integer(byt4), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_byt4('', x, fmt, advance, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_byt4 +! ******************************** 4-BYTE INTEGER PROCEDURES ******************************* +SUBROUTINE disp_s_byt4(x, fmt, advance, sep, trim, unit, zeroas) + ! 4-byte integer scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas + INTEGER(byt4), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit + CALL disp_ts_byt4('', x, fmt, advance, sep, 'left', trim, unit, zeroas) +END SUBROUTINE disp_s_byt4 subroutine disp_v_byt4(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 4-byte integer vector without title + ! 4-byte integer vector without title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt4), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) + INTEGER(byt4), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) call disp_tv_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_byt4 +END SUBROUTINE disp_v_byt4 subroutine disp_m_byt4(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 4-byte integer matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt4), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_byt4 + ! 4-byte integer matrix without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + INTEGER(byt4), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) +CALL disp_tm_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) +END SUBROUTINE disp_m_byt4 subroutine disp_ts_byt4(title, x, fmt, advance, sep, style, trim, unit, zeroas) - ! 4-byte integer scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt4), intent(in) :: x - integer, intent(in), optional :: unit + ! 4-byte integer scalar with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + INTEGER(byt4), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit call disp_tm_byt4(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & - zeroas=zeroas) - end subroutine disp_ts_byt4 + zeroas=zeroas) +END SUBROUTINE disp_ts_byt4 subroutine disp_tv_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 4-byte integer vector with title - character(*), intent(in) :: title + ! 4-byte integer vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt4), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE + INTEGER(byt4), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - if (SE%row) then - call disp_byt4(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_byt4(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_byt4 + IF (SE%row) THEN + CALL disp_byt4(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_byt4(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_byt4 subroutine disp_tm_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 4-byte integer matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - integer(byt4),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE + ! 4-byte integer matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + INTEGER(byt4), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced by this string + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) - call disp_byt4(title, x, SE) - end subroutine disp_tm_byt4 + CALL disp_byt4(title, x, SE) +END SUBROUTINE disp_tm_byt4 - subroutine disp_byt4(title, x, SE) - ! 4-byte integer item - character(*), intent(in) :: title - integer(byt4), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_byt4(x, SE, wid, nbl) ! determine also SE%w - call tobox_byt4(title, x, SE, wid, nbl) - end subroutine disp_byt4 +SUBROUTINE disp_byt4(title, x, SE) + ! 4-byte integer item + CHARACTER(*), INTENT(in) :: title + INTEGER(byt4), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + CALL find_editdesc_byt4(x, SE, wid, nbl) ! determine also SE%w + CALL tobox_byt4(title, x, SE, wid, nbl) +END SUBROUTINE disp_byt4 - subroutine tobox_byt4(title, x, SE, wid, nbl) - ! Write 4-byte integer matrix to box - character(*), intent(in) :: title - integer(byt4), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) WRITE (s, SE%ed) x(:, j) + IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0) + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_byt4 - subroutine find_editdesc_byt4(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid - integer(byt4), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(out) :: wid(size(x,2)), nbl(size(x,2)) - ! - integer(byt4) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm - logical xzero(size(x,2)), xallz(size(x,2)) - character(22) s - integer ww - ! - if (SE%w == 0) then - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - SE%w = max(SE%lzas, ww) - call replace_w(SE%ed, ww) - elseif (SE%w < 0) then ! obtain max-width of x - if (size(x) == 0) then - SE%ed = '()' - SE%w = 0 - wid = 0 - return - endif - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - ww = max(SE%lzas, ww) - SE%ed = '(SS,Ixx)' - write(SE%ed(6:7), '(SS,I2)') ww - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1) ! max in each column - xminv = minval(x, 1) ! min - xzero = any(x == 0_byt4, 1) ! true where column has some zeros - xallz = all(x == 0_byt4, 1) ! true where column has only zeros - call getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - else - wid = SE%w - nbl = 0 - endif - end subroutine find_editdesc_byt4 +SUBROUTINE find_editdesc_byt4(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid + INTEGER(byt4), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + ! + INTEGER(byt4) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm + LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2)) + CHARACTER(22) s + INTEGER ww + ! + IF (SE%w == 0) THEN + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + SE%w = MAX(SE%lzas, ww) + CALL replace_w(SE%ed, ww) + ELSEIF (SE%w < 0) THEN ! obtain max-width of x + IF (SIZE(x) == 0) THEN + SE%ed = '()' + SE%w = 0 + wid = 0 + RETURN + END IF + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + ww = MAX(SE%lzas, ww) + SE%ed = '(SS,Ixx)' + WRITE (SE%ed(6:7), '(SS,I2)') ww + SE%w = ww + END IF + IF (SE%trm) THEN + xmaxv = MAXVAL(x, 1) ! max in each column + xminv = MINVAL(x, 1) ! min + xzero = ANY(x == 0_BYT4, 1) ! true where column has some zeros + xallz = ALL(x == 0_BYT4, 1) ! true where column has only zeros + CALL getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + ELSE + wid = SE%w + nbl = 0 + END IF +END SUBROUTINE find_editdesc_byt4 - subroutine getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - integer(byt4), intent(in) :: xmaxv(:), xminv(:) - logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros - type(settings), intent(in) :: SE ! Settings - integer, intent(out) :: wid(:) ! Widths of columns - integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmax, SE%ed) xmaxv - write(stmin, SE%ed) xminv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - wid = w - nbl - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byt4 +SUBROUTINE getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + INTEGER(byt4), INTENT(in) :: xmaxv(:), xminv(:) + LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros + TYPE(settings), INTENT(in) :: SE ! Settings + INTEGER, INTENT(out) :: wid(:) ! Widths of columns + INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid) + CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv)) + INTEGER w + w = SE%w + WRITE (stmax, SE%ed) xmaxv + WRITE (stmin, SE%ed) xminv + nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1)) + wid = w - nbl + IF (SE%lzas > 0) THEN + wid = MERGE(SE%lzas, wid, xallz) + wid = MAX(wid, MERGE(SE%lzas, 0, xzero)) + nbl = w - wid + END IF +END SUBROUTINE getwid_byt4 - ! ********* 4-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byt4(x) result(st) - ! Scalar to string - integer(byt4), intent(in) :: x - character(len_f_byt4((/x/), tosset0%ifmt)) :: st - st = tostring_f_byt4((/x/), tosset0%ifmt) - end function tostring_s_byt4 +! ********* 4-BYTE INTEGER TOSTRING PROCEDURES ********* +FUNCTION tostring_s_byt4(x) RESULT(st) + ! Scalar to string + INTEGER(byt4), INTENT(in) :: x + CHARACTER(len_f_byt4((/x/), tosset0%ifmt)) :: st + st = tostring_f_byt4((/x/), tosset0%ifmt) +END FUNCTION tostring_s_byt4 - function tostring_sf_byt4(x, fmt) result(st) - ! Scalar with specified format to string - integer(byt4),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byt4((/x/), fmt)) :: st - st = tostring_f_byt4((/x/), fmt) - end function tostring_sf_byt4 +FUNCTION tostring_sf_byt4(x, fmt) RESULT(st) + ! Scalar with specified format to string + INTEGER(byt4), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byt4((/x/), fmt)) :: st + st = tostring_f_byt4((/x/), fmt) +END FUNCTION tostring_sf_byt4 - function tostring_byt4(x) result(st) - ! Vector to string - integer(byt4), intent(in) :: x(:) - character(len_f_byt4(x, tosset0%ifmt)) :: st - st = tostring_f_byt4(x, tosset0%ifmt) - end function tostring_byt4 +FUNCTION tostring_byt4(x) RESULT(st) + ! Vector to string + INTEGER(byt4), INTENT(in) :: x(:) + CHARACTER(len_f_byt4(x, tosset0%ifmt)) :: st + st = tostring_f_byt4(x, tosset0%ifmt) +END FUNCTION tostring_byt4 - function tostring_f_byt4(x, fmt) result(st) - ! Vector with specified format to string - integer(byt4), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byt4(x, fmt)) :: st - character(widthmax_byt4(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byt4 +FUNCTION tostring_f_byt4(x, fmt) RESULT(st) + ! Vector with specified format to string + INTEGER(byt4), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byt4(x, fmt)) :: st + CHARACTER(widthmax_byt4(x, fmt)) :: sa(SIZE(x)) + INTEGER :: w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; st = errormsg; RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_byt4 - pure function len_f_byt4(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byt4), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byt4(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byt4 +PURE FUNCTION len_f_byt4(x, fmt) RESULT(wtot) + ! Total width of tostring representation of x + INTEGER(byt4), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(widthmax_byt4(x, fmt)) :: sa(SIZE(x)) + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_byt4 - pure function widthmax_byt4(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byt4), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byt4 - ! ************************************* END OF 4-BYTE INTEGER PROCEDURES ****************************************** +PURE FUNCTION widthmax_byt4(x, fmt) RESULT(w) + ! Maximum width of string representation of an element in x + INTEGER(byt4), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(RANGE(x) + 2) sx(2) + INTEGER w, d + LOGICAL gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w <= 0) THEN + WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x) + w = MAXVAL(LEN_TRIM(sx)) + END IF +END FUNCTION widthmax_byt4 +! ************************************* END OF 4-BYTE INTEGER PROCEDURES ****************************************** END MODULE DISP_I4MOD diff --git a/src/modules/Display/src/disp/disp_i8mod.F90 b/src/modules/Display/src/disp/disp_i8mod.F90 index 54794d25c..63be966de 100755 --- a/src/modules/Display/src/disp/disp_i8mod.F90 +++ b/src/modules/Display/src/disp/disp_i8mod.F90 @@ -1,270 +1,270 @@ MODULE DISP_I8MOD - ! Add-on module to DISPMODULE to display 8-byte integers - ! (assuming that these are obtained with selected_int_kind(18)) - ! - ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from - ! from dispmodule.F90, replacing dint with byt8 and 'default integer' with 8-byte - ! integer (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. +! Add-on module to DISPMODULE to display 8-byte integers +! (assuming that these are obtained with selected_int_kind(18)) +! +! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from +! from dispmodule.F90, replacing dint with byt8 and 'default integer' with 8-byte +! integer (only appears in comments), and adding the DECLARATIONS section below. +! +! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of +! Iceland (jonasson@hi.is). This software is free. For details see the file README. - USE DISPMODULE_UTIL - use GlobalData, ONLY: Int64 +USE DISPMODULE_UTIL +USE GlobalData, ONLY: INT64 - PUBLIC DISP - PUBLIC TOSTRING +PUBLIC DISP +PUBLIC TOSTRING - PRIVATE +PRIVATE - interface disp +INTERFACE disp module procedure disp_s_byt8, disp_ts_byt8, disp_v_byt8, disp_tv_byt8, disp_m_byt8, disp_tm_byt8 - end interface +END INTERFACE - interface tostring +INTERFACE tostring module procedure tostring_byt8, tostring_f_byt8, tostring_s_byt8, tostring_sf_byt8 - end interface +END INTERFACE - integer, parameter :: byt8 = Int64 +INTEGER, PARAMETER :: byt8 = INT64 CONTAINS - ! ******************************** 8-BYTE INTEGER PROCEDURES ******************************* - subroutine disp_s_byt8(x, fmt, advance, sep, trim, unit, zeroas) - ! 8-byte integer scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - integer(byt8), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_byt8('', x, fmt, advance, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_byt8 +! ******************************** 8-BYTE INTEGER PROCEDURES ******************************* +SUBROUTINE disp_s_byt8(x, fmt, advance, sep, trim, unit, zeroas) + ! 8-byte integer scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas + INTEGER(byt8), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit + CALL disp_ts_byt8('', x, fmt, advance, sep, 'left', trim, unit, zeroas) +END SUBROUTINE disp_s_byt8 subroutine disp_v_byt8(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 8-byte integer vector without title + ! 8-byte integer vector without title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt8), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) + INTEGER(byt8), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) call disp_tv_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_byt8 +END SUBROUTINE disp_v_byt8 subroutine disp_m_byt8(x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 8-byte integer matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt8), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_byt8 + ! 8-byte integer matrix without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + INTEGER(byt8), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) +CALL disp_tm_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas) +END SUBROUTINE disp_m_byt8 subroutine disp_ts_byt8(title, x, fmt, advance, sep, style, trim, unit, zeroas) - ! 8-byte integer scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - integer(byt8), intent(in) :: x - integer, intent(in), optional :: unit + ! 8-byte integer scalar with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + INTEGER(byt8), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit call disp_tm_byt8(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, & - zeroas=zeroas) - end subroutine disp_ts_byt8 + zeroas=zeroas) +END SUBROUTINE disp_ts_byt8 subroutine disp_tv_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - ! 8-byte integer vector with title - character(*), intent(in) :: title + ! 8-byte integer vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - integer(byt8), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE + INTEGER(byt8), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas) - if (SE%row) then - call disp_byt8(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_byt8(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_byt8 + IF (SE%row) THEN + CALL disp_byt8(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_byt8(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_byt8 subroutine disp_tm_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas) - ! 8-byte integer matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - integer(byt8),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE + ! 8-byte integer matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + INTEGER(byt8), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4') + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced by this string + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas) - call disp_byt8(title, x, SE) - end subroutine disp_tm_byt8 + CALL disp_byt8(title, x, SE) +END SUBROUTINE disp_tm_byt8 - subroutine disp_byt8(title, x, SE) - ! 8-byte integer item - character(*), intent(in) :: title - integer(byt8), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_byt8(x, SE, wid, nbl) ! determine also SE%w - call tobox_byt8(title, x, SE, wid, nbl) - end subroutine disp_byt8 +SUBROUTINE disp_byt8(title, x, SE) + ! 8-byte integer item + CHARACTER(*), INTENT(in) :: title + INTEGER(byt8), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + CALL find_editdesc_byt8(x, SE, wid, nbl) ! determine also SE%w + CALL tobox_byt8(title, x, SE, wid, nbl) +END SUBROUTINE disp_byt8 - subroutine tobox_byt8(title, x, SE, wid, nbl) - ! Write 8-byte integer matrix to box - character(*), intent(in) :: title - integer(byt8), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) x(:,j) - if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) WRITE (s, SE%ed) x(:, j) + IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0) + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_byt8 - subroutine find_editdesc_byt8(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid - integer(byt8), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(out) :: wid(size(x,2)), nbl(size(x,2)) - ! - integer(byt8) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm - logical xzero(size(x,2)), xallz(size(x,2)) - character(22) s - integer ww - ! - if (SE%w == 0) then - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - SE%w = max(SE%lzas, ww) - call replace_w(SE%ed, ww) - elseif (SE%w < 0) then ! obtain max-width of x - if (size(x) == 0) then - SE%ed = '()' - SE%w = 0 - wid = 0 - return - endif - xp = maxval(x) - xm = minval(x) - write(s, '(SS,I0)') xp; ww = len_trim(s) - write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s)) - ww = max(SE%lzas, ww) - SE%ed = '(SS,Ixx)' - write(SE%ed(6:7), '(SS,I2)') ww - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1) ! max in each column - xminv = minval(x, 1) ! min - xzero = any(x == 0_byt8, 1) ! true where column has some zeros - xallz = all(x == 0_byt8, 1) ! true where column has only zeros - call getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - else - wid = SE%w - nbl = 0 - endif - end subroutine find_editdesc_byt8 +SUBROUTINE find_editdesc_byt8(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid + INTEGER(byt8), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + ! + INTEGER(byt8) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm + LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2)) + CHARACTER(22) s + INTEGER ww + ! + IF (SE%w == 0) THEN + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + SE%w = MAX(SE%lzas, ww) + CALL replace_w(SE%ed, ww) + ELSEIF (SE%w < 0) THEN ! obtain max-width of x + IF (SIZE(x) == 0) THEN + SE%ed = '()' + SE%w = 0 + wid = 0 + RETURN + END IF + xp = MAXVAL(x) + xm = MINVAL(x) + WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s) + WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s)) + ww = MAX(SE%lzas, ww) + SE%ed = '(SS,Ixx)' + WRITE (SE%ed(6:7), '(SS,I2)') ww + SE%w = ww + END IF + IF (SE%trm) THEN + xmaxv = MAXVAL(x, 1) ! max in each column + xminv = MINVAL(x, 1) ! min + xzero = ANY(x == 0_BYT8, 1) ! true where column has some zeros + xallz = ALL(x == 0_BYT8, 1) ! true where column has only zeros + CALL getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + ELSE + wid = SE%w + nbl = 0 + END IF +END SUBROUTINE find_editdesc_byt8 - subroutine getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl) - integer(byt8), intent(in) :: xmaxv(:), xminv(:) - logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros - type(settings), intent(in) :: SE ! Settings - integer, intent(out) :: wid(:) ! Widths of columns - integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmax, SE%ed) xmaxv - write(stmin, SE%ed) xminv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - wid = w - nbl - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - nbl = w - wid - endif - end subroutine getwid_byt8 +SUBROUTINE getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl) + INTEGER(byt8), INTENT(in) :: xmaxv(:), xminv(:) + LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros + TYPE(settings), INTENT(in) :: SE ! Settings + INTEGER, INTENT(out) :: wid(:) ! Widths of columns + INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid) + CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv)) + INTEGER w + w = SE%w + WRITE (stmax, SE%ed) xmaxv + WRITE (stmin, SE%ed) xminv + nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1)) + wid = w - nbl + IF (SE%lzas > 0) THEN + wid = MERGE(SE%lzas, wid, xallz) + wid = MAX(wid, MERGE(SE%lzas, 0, xzero)) + nbl = w - wid + END IF +END SUBROUTINE getwid_byt8 - ! ********* 8-BYTE INTEGER TOSTRING PROCEDURES ********* - function tostring_s_byt8(x) result(st) - ! Scalar to string - integer(byt8), intent(in) :: x - character(len_f_byt8((/x/), tosset0%ifmt)) :: st - st = tostring_f_byt8((/x/), tosset0%ifmt) - end function tostring_s_byt8 +! ********* 8-BYTE INTEGER TOSTRING PROCEDURES ********* +FUNCTION tostring_s_byt8(x) RESULT(st) + ! Scalar to string + INTEGER(byt8), INTENT(in) :: x + CHARACTER(len_f_byt8((/x/), tosset0%ifmt)) :: st + st = tostring_f_byt8((/x/), tosset0%ifmt) +END FUNCTION tostring_s_byt8 - function tostring_sf_byt8(x, fmt) result(st) - ! Scalar with specified format to string - integer(byt8),intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_byt8((/x/), fmt)) :: st - st = tostring_f_byt8((/x/), fmt) - end function tostring_sf_byt8 +FUNCTION tostring_sf_byt8(x, fmt) RESULT(st) + ! Scalar with specified format to string + INTEGER(byt8), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byt8((/x/), fmt)) :: st + st = tostring_f_byt8((/x/), fmt) +END FUNCTION tostring_sf_byt8 - function tostring_byt8(x) result(st) - ! Vector to string - integer(byt8), intent(in) :: x(:) - character(len_f_byt8(x, tosset0%ifmt)) :: st - st = tostring_f_byt8(x, tosset0%ifmt) - end function tostring_byt8 +FUNCTION tostring_byt8(x) RESULT(st) + ! Vector to string + INTEGER(byt8), INTENT(in) :: x(:) + CHARACTER(len_f_byt8(x, tosset0%ifmt)) :: st + st = tostring_f_byt8(x, tosset0%ifmt) +END FUNCTION tostring_byt8 - function tostring_f_byt8(x, fmt) result(st) - ! Vector with specified format to string - integer(byt8), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_byt8(x, fmt)) :: st - character(widthmax_byt8(x, fmt)) :: sa(size(x)) - integer :: w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; st = errormsg; return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - call tostring_get(sa, st) - end function tostring_f_byt8 +FUNCTION tostring_f_byt8(x, fmt) RESULT(st) + ! Vector with specified format to string + INTEGER(byt8), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_byt8(x, fmt)) :: st + CHARACTER(widthmax_byt8(x, fmt)) :: sa(SIZE(x)) + INTEGER :: w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; st = errormsg; RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_byt8 - pure function len_f_byt8(x, fmt) result(wtot) - ! Total width of tostring representation of x - integer(byt8), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_byt8(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - write(sa, fmt1) x - if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_byt8 +PURE FUNCTION len_f_byt8(x, fmt) RESULT(wtot) + ! Total width of tostring representation of x + INTEGER(byt8), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(widthmax_byt8(x, fmt)) :: sa(SIZE(x)) + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa) + wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_byt8 - pure function widthmax_byt8(x, fmt) result(w) - ! Maximum width of string representation of an element in x - integer(byt8), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(range(x)+2) sx(2) - integer w, d - logical gedit - character(nnblk(fmt)+5) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w<=0) then - write(sx, '(SS,I0)') maxval(x), minval(x) - w = maxval(len_trim(sx)) - end if - end function widthmax_byt8 - ! ************************************* END OF 8-BYTE INTEGER PROCEDURES ****************************************** +PURE FUNCTION widthmax_byt8(x, fmt) RESULT(w) + ! Maximum width of string representation of an element in x + INTEGER(byt8), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(RANGE(x) + 2) sx(2) + INTEGER w, d + LOGICAL gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w <= 0) THEN + WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x) + w = MAXVAL(LEN_TRIM(sx)) + END IF +END FUNCTION widthmax_byt8 +! ************************************* END OF 8-BYTE INTEGER PROCEDURES ****************************************** END MODULE DISP_I8MOD diff --git a/src/modules/Display/src/disp/disp_l1mod.F90 b/src/modules/Display/src/disp/disp_l1mod.F90 index ae1012cac..7e371961f 100755 --- a/src/modules/Display/src/disp/disp_l1mod.F90 +++ b/src/modules/Display/src/disp/disp_l1mod.F90 @@ -1,202 +1,202 @@ MODULE DISP_L1MOD - ! Add-on module to DISPMODULE to display 1-byte logical items - ! (assuming that these have kind = 1) - ! - ! This module is obtained by copying the section DEFAULT LOGICAL PROCEDURES from - ! dispmodule.F90, replacing dlog with log1 and 'default logical' with '1-byte - ! logical' (only appears in comments), and adding the DECLARATIONS section below. - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. - - use dispmodule_util - USE GlobalData, ONLY: LGT - PUBLIC DISP - PUBLIC TOSTRING - - PRIVATE - - interface Display +! Add-on module to DISPMODULE to display 1-byte logical items +! (assuming that these have kind = 1) +! +! This module is obtained by copying the section DEFAULT LOGICAL PROCEDURES from +! dispmodule.F90, replacing dlog with log1 and 'default logical' with '1-byte +! logical' (only appears in comments), and adding the DECLARATIONS section below. +! +! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of +! Iceland (jonasson@hi.is). This software is free. For details see the file README. + +USE dispmodule_util +USE GlobalData, ONLY: LGT +PUBLIC DISP +PUBLIC TOSTRING + +PRIVATE + +INTERFACE Display module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1 - end interface +END INTERFACE - interface disp +INTERFACE disp module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1 - end interface +END INTERFACE - interface tostring +INTERFACE tostring module procedure tostring_log1, tostring_f_log1, tostring_s_log1, tostring_sf_log1 - end interface +END INTERFACE - integer, parameter :: log1 = LGT ! hopefully logical(1) is byte +INTEGER, PARAMETER :: log1 = LGT ! hopefully logical(1) is byte CONTAINS - ! ********************************************** 1-BYTE LOGICAL PROCEDURES ************************************************* - subroutine disp_s_log1(x, fmt, advance, sep, trim, unit) - ! 1-byte logical scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim - logical(log1), intent(in) :: x - integer, intent(in), optional :: unit - call disp_ts_log1('', x, fmt, advance, sep, 'left', trim, unit) - end subroutine disp_s_log1 +! ********************************************** 1-BYTE LOGICAL PROCEDURES ************************************************* +SUBROUTINE disp_s_log1(x, fmt, advance, sep, trim, unit) + ! 1-byte logical scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim + LOGICAL(log1), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit + CALL disp_ts_log1('', x, fmt, advance, sep, 'left', trim, unit) +END SUBROUTINE disp_s_log1 subroutine disp_v_log1(x, fmt, advance, lbound, sep, style, trim, unit, orient) - ! 1-byte logical vector without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - logical(log1), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tv_log1('', x, fmt, advance, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_log1 - - subroutine disp_m_log1(x, fmt, advance, lbound, sep, style, trim, unit) - ! 1-byte logical matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim - logical(log1), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, lbound(:) - call disp_tm_log1('', x, fmt, advance, lbound, sep, style, trim, unit) - end subroutine disp_m_log1 - - subroutine disp_ts_log1(title, x, fmt, advance, sep, style, trim, unit) - ! 1-byte logical scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim - logical(log1), intent(in) :: x - integer, intent(in), optional :: unit + ! 1-byte logical vector without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient + LOGICAL(log1), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) +CALL disp_tv_log1('', x, fmt, advance, lbound, sep, style, trim, unit, orient) +END SUBROUTINE disp_v_log1 + +SUBROUTINE disp_m_log1(x, fmt, advance, lbound, sep, style, trim, unit) + ! 1-byte logical matrix without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim + LOGICAL(log1), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) + CALL disp_tm_log1('', x, fmt, advance, lbound, sep, style, trim, unit) +END SUBROUTINE disp_m_log1 + +SUBROUTINE disp_ts_log1(title, x, fmt, advance, sep, style, trim, unit) + ! 1-byte logical scalar with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim + LOGICAL(log1), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit call disp_tm_log1(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit) - end subroutine disp_ts_log1 +END SUBROUTINE disp_ts_log1 subroutine disp_tv_log1(title, x, fmt, advance, lbound, sep, style, trim, unit, orient) - ! 1-byte logical vector with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient - logical(log1), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:) - type(settings) :: SE + ! 1-byte logical vector with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient + LOGICAL(log1), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:) + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient) - if (SE%row) then - call disp_log1(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_log1(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_log1 + IF (SE%row) THEN + CALL disp_log1(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_log1(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_log1 subroutine disp_tm_log1(title, x, fmt, advance, lbound, sep, style, trim, unit) - ! 1-byte logical matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - logical(log1),intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g. 'L1') - integer, intent(in), optional :: unit ! Unit to display on - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming, - ! ! 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - ! - call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit) - call disp_log1(title, x, SE) - end subroutine disp_tm_log1 - - subroutine disp_log1(title, x, SE) - ! Write 1-byte logical to box or unit - character(*), intent(in) :: title - logical(log1), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - if (SE%w <= 0 .or. SE%trm) then - SE%ed = '(L1)' - if (size(x) == 0) then - wid = 0 - else - wid = 1 - endif - SE%w = 1 - nbl = SE%w - wid - else - wid = SE%w - nbl = 0 - endif - call tobox_log1(title, x, SE, wid, nbl) - end subroutine disp_log1 - - subroutine tobox_log1(title, x, SE, wid, nbl) - character(*), intent(in) :: title - logical(log1), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer, intent(INOUT ) :: wid(:) - integer, intent(INOUT ) :: nbl(:) - character(SE%w) :: s(size(x,1)) - integer :: m, n, lin1, i, j, wleft, widp(size(wid)) - character, pointer :: boxp(:,:) - m = size(x,1) - n = size(x,2) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (x(i,j), i=1,m) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j 0) WRITE (s, SE%ed) (x(i, j), i=1, m) + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_log1 + +! ********** 1-BYTE LOGICAL TOSTRING PROCEDURES ********* +FUNCTION tostring_s_log1(x) RESULT(st) + LOGICAL(log1), INTENT(in) :: x + CHARACTER(1) :: st + st = tostring_f_log1((/x/), 'L1') +END FUNCTION tostring_s_log1 + +FUNCTION tostring_sf_log1(x, fmt) RESULT(st) + LOGICAL(log1), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_log1((/x/), fmt)) :: st + st = tostring_f_log1((/x/), fmt) +END FUNCTION tostring_sf_log1 + +FUNCTION tostring_log1(x) RESULT(st) + LOGICAL(log1), INTENT(in) :: x(:) + CHARACTER(1 + (SIZE(x) - 1)*(1 + tosset0%seplen)) :: st + st = tostring_f_log1(x, 'L1') +END FUNCTION tostring_log1 + +FUNCTION tostring_f_log1(x, fmt) RESULT(st) + LOGICAL(log1), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_log1(x, fmt)) :: st + CHARACTER(widthmax_log1(fmt)) :: sa(SIZE(x)) + INTEGER :: w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 2) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w <= 0) THEN; st = errormsg; RETURN; END IF + WRITE (sa, fmt1) x + IF (tosset0%trimb == 'YES') sa = ADJUSTL(sa) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_log1 + +PURE FUNCTION len_f_log1(x, fmt) RESULT(wtot) + LOGICAL(log1), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 2) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w <= 0) THEN; wtot = LEN(errormsg); RETURN; END IF + IF (tosset0%trimb == 'YES') wtot = SIZE(x) + IF (tosset0%trimb == 'NO') wtot = w * SIZE(x) + wtot = wtot + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_log1 + +PURE FUNCTION widthmax_log1(fmt) RESULT(w) + CHARACTER(*), INTENT(in) :: fmt + INTEGER w, d + LOGICAL gedit + CHARACTER(nnblk(fmt) + 5) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w <= 0) w = 1 +END FUNCTION widthmax_log1 END MODULE DISP_L1MOD diff --git a/src/modules/Display/src/disp/disp_r16mod.F90 b/src/modules/Display/src/disp/disp_r16mod.F90 index bd2b36fd0..0917be0b1 100755 --- a/src/modules/Display/src/disp/disp_r16mod.F90 +++ b/src/modules/Display/src/disp/disp_r16mod.F90 @@ -1,553 +1,553 @@ MODULE DISP_R16MOD #ifdef USE_Real128 - ! Add-on module to DISPMODULE to display selected_real_kind(25) reals - ! (these are probably 16 bytes and possibly quadruple precision) - ! - ! This module is obtained by copying the section SINGLE PRECSION PROCEDURES from - ! dispmodule.F90, replacing sngl with quad, single withe quadruple (only appears - ! in comments) and cplx with cplq, adding a DECLARATIONS section, and defining - ! the constant quad as selected_real_kind(25). - ! - ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of - ! Iceland (jonasson@hi.is). This software is free. For details see the file README. - - ! ******************************** DECLARATIONS ******************************************** - use dispmodule_util - USE GlobalData, ONLY: Real128 - PUBLIC DISP - PUBLIC TOSTRING - - PRIVATE - - interface Display +! Add-on module to DISPMODULE to display selected_real_kind(25) reals +! (these are probably 16 bytes and possibly quadruple precision) +! +! This module is obtained by copying the section SINGLE PRECSION PROCEDURES from +! dispmodule.F90, replacing sngl with quad, single withe quadruple (only appears +! in comments) and cplx with cplq, adding a DECLARATIONS section, and defining +! the constant quad as selected_real_kind(25). +! +! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of +! Iceland (jonasson@hi.is). This software is free. For details see the file README. + +! ******************************** DECLARATIONS ******************************************** +USE dispmodule_util +USE GlobalData, ONLY: REAL128 +PUBLIC DISP +PUBLIC TOSTRING + +PRIVATE + +INTERFACE Display module procedure disp_s_quad, disp_ts_quad, disp_v_quad, disp_tv_quad, disp_m_quad, disp_tm_quad module procedure disp_s_cplq, disp_ts_cplq, disp_v_cplq, disp_tv_cplq, disp_m_cplq, disp_tm_cplq - end interface +END INTERFACE - interface disp +INTERFACE disp module procedure disp_s_quad, disp_ts_quad, disp_v_quad, disp_tv_quad, disp_m_quad, disp_tm_quad module procedure disp_s_cplq, disp_ts_cplq, disp_v_cplq, disp_tv_cplq, disp_m_cplq, disp_tm_cplq - end interface +END INTERFACE - interface tostring +INTERFACE tostring module procedure tostring_quad, tostring_f_quad, tostring_s_quad, tostring_sf_quad module procedure tostring_cplq, tostring_f_cplq, tostring_s_cplq, tostring_sf_cplq - end interface +END INTERFACE - integer, parameter :: quad = Real128 +INTEGER, PARAMETER :: quad = REAL128 CONTAINS - ! **************************** QUADRUPLE PRECISION PROCEDURES ******************************* - subroutine disp_s_quad(x, fmt, advance, digmax, sep, trim, unit, zeroas) - ! quadruple precision scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - real(quad), intent(in) :: x - integer, intent(in), optional :: unit, digmax +! **************************** QUADRUPLE PRECISION PROCEDURES ******************************* +SUBROUTINE disp_s_quad(x, fmt, advance, digmax, sep, trim, unit, zeroas) + ! quadruple precision scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas + REAL(quad), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_ts_quad('', x, fmt, advance, digmax, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_quad +END SUBROUTINE disp_s_quad subroutine disp_v_quad(x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - ! quadruple precision vector without title + ! quadruple precision vector without title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - real(quad), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax + REAL(quad), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax call disp_tv_quad('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_quad +END SUBROUTINE disp_v_quad subroutine disp_m_quad(x, fmt, advance, lbound, sep, style, trim, unit, digmax, zeroas) - ! quadruple precision matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - real(quad), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) + ! quadruple precision matrix without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + REAL(quad), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) call disp_tm_quad('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_quad +END SUBROUTINE disp_m_quad subroutine disp_ts_quad(title, x, fmt, advance, digmax, sep, style, trim, unit, zeroas) - ! quadruple precision scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - real(quad), intent(in) :: x - integer, intent(in), optional :: unit, digmax + ! quadruple precision scalar with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + REAL(quad), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_tm_quad(title, reshape((/x/), (/1, 1/)), fmt, advance, digmax, sep=sep, style=style, trim=trim, & - unit=unit, zeroas=zeroas) - end subroutine disp_ts_quad + unit=unit, zeroas=zeroas) +END SUBROUTINE disp_ts_quad subroutine disp_tv_quad(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - ! quadruple precision vector with title - character(*), intent(in) :: title + ! quadruple precision vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - real(quad), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) :: SE + REAL(quad), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas, digmax) - if (SE%row) then - call disp_quad(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_quad(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_quad + IF (SE%row) THEN + CALL disp_quad(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_quad(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_quad subroutine disp_tm_quad(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas) - ! quadruple precision matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - real(quad), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2') - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in x - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced with this string if it is not empty - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - ! + ! quadruple precision matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + REAL(quad), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2') + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in x + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced with this string if it is not empty + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + TYPE(settings) :: SE + ! call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas, digmax=digmax) - call disp_quad(title, x, SE) - end subroutine disp_tm_quad - - subroutine disp_quad(title, x, SE) - ! quadruple precision item - character(*), intent(in) :: title - real(quad), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_quad(x, SE, wid, nbl) ! determine also SE%w - call tobox_quad(title, x, SE, wid, nbl) - end subroutine disp_quad - - subroutine tobox_quad(title, x, SE, wid, nbl) - ! Write quadruple precision matrix to box - character(*), intent(in) :: title ! title - real(quad), intent(in) :: x(:,:) ! item - type(settings), intent(INOUT ) :: SE ! settings - integer, intent(INOUT ) :: wid(:) ! widths of columns - integer, intent(INOUT ) :: nbl(:) ! number of blanks to trim from left - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - real(quad) :: xj(size(x,1)), h - m = size(x,1) - n = size(x,2) - h = huge(x) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - xj = x(:, j) - if (m > 0) write(s, SE%ed) xj + CALL disp_quad(title, x, SE) +END SUBROUTINE disp_tm_quad + +SUBROUTINE disp_quad(title, x, SE) + ! quadruple precision item + CHARACTER(*), INTENT(in) :: title + REAL(quad), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + CALL find_editdesc_quad(x, SE, wid, nbl) ! determine also SE%w + CALL tobox_quad(title, x, SE, wid, nbl) +END SUBROUTINE disp_quad + +SUBROUTINE tobox_quad(title, x, SE, wid, nbl) + ! Write quadruple precision matrix to box + CHARACTER(*), INTENT(in) :: title ! title + REAL(quad), INTENT(in) :: x(:, :) ! item + TYPE(settings), INTENT(INOUT) :: SE ! settings + INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns + INTEGER, INTENT(INOUT) :: nbl(:) ! number of blanks to trim from left + CHARACTER(SE%w) :: s(SIZE(x, 1)) + INTEGER :: lin1, j, wleft, m, n, widp(SIZE(wid)) + CHARACTER, POINTER :: boxp(:, :) + REAL(quad) :: xj(SIZE(x, 1)), h + m = SIZE(x, 1) + n = SIZE(x, 2) + h = HUGE(x) + CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + DO j = 1, n + xj = x(:, j) + IF (m > 0) WRITE (s, SE%ed) xj call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (.not. any(xfinite)) then - w = 4 - else - xmax = maxval(x, mask=xfinite) - xmin = minval(x, mask=xfinite) - f1 = '(SS,ES9.0E4)' - write(s,f1) xmax, xmin - read(s(:)(5:9),'(I5)') expmax, expmin - w = max(0, expmax, expmin) + d + 4 - end if - if (.not. all(xfinite)) w = max(w, 4) - end function maxw_quad - - subroutine find_editdesc_quad(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid. - ! The if-block (*) is for safety: make f wider in case xm is written ok with the - ! ES format in fmt but overflows with F format (the feature has been tested through - ! manual changes to the program). - real(quad), intent(in) :: x(:,:) ! Item to be written - type(settings), intent(INOUT ) :: SE ! Settings - integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns - integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns - integer :: expmax, expmin, ww, dd, dmx - real(quad) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h - character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 - character(99) s + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_quad + +PURE FUNCTION maxw_quad(x, d) RESULT(w) + ! Find max field width needed (F0.d editing is specified) + REAL(quad), INTENT(in) :: x(:) + INTEGER, INTENT(in) :: d + INTEGER expmax, expmin, w + LOGICAL xfinite(SIZE(x)) + REAL(quad) xmax, xmin, h + CHARACTER(12) :: f1, s(2) + xmin = 0; xmax = 0; h = HUGE(h) + xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf + IF (.NOT. ANY(xfinite)) THEN + w = 4 + ELSE + xmax = MAXVAL(x, mask=xfinite) + xmin = MINVAL(x, mask=xfinite) + f1 = '(SS,ES9.0E4)' + WRITE (s, f1) xmax, xmin + READ (s(:) (5:9), '(I5)') expmax, expmin + w = MAX(0, expmax, expmin) + d + 4 + END IF + IF (.NOT. ALL(xfinite)) w = MAX(w, 4) +END FUNCTION maxw_quad + +SUBROUTINE find_editdesc_quad(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid. + ! The if-block (*) is for safety: make f wider in case xm is written ok with the + ! ES format in fmt but overflows with F format (the feature has been tested through + ! manual changes to the program). + REAL(quad), INTENT(in) :: x(:, :) ! Item to be written + TYPE(settings), INTENT(INOUT) :: SE ! Settings + INTEGER, INTENT(out) :: wid(SIZE(x, 2)) ! Widths of individual columns + INTEGER, INTENT(out) :: nbl(SIZE(x, 2)) ! Blanks to trim from left of individual columns + INTEGER :: expmax, expmin, ww, dd, dmx + REAL(quad) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm, h + CHARACTER(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 + CHARACTER(99) s logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) - ! - dmx = SE%dmx - h = huge(h) - xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (SE%w == 0) then ! Edit descriptor 'F0.d' specified - ww = maxw_quad(reshape(x, (/size(x)/)), SE%d) - if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas) - call replace_w(SE%ed, ww) - SE%w = ww - elseif (SE%w < 0) then ! No edit descriptor specified - if (size(x) == 0) then - SE%w = 0 - wid = 0 - nbl = 0 - return - endif - if (any(xfinite)) then - xp = maxval(x, mask=xfinite) - xm = minval(x, mask=xfinite) - write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 - write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax - write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin - call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) - if (.not. all(xfinite)) ww = max(ww, 4) - if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas) - if (SE%ed(5:5)=='F') then ! (*) - write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 - write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 - write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd - endif - else - ww = 4 - SE%ed = '(F4.0)' - endif - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1, mask=xfinite) ! max in each column - xminv = minval(x, 1, mask=xfinite) ! min - xzero = any(x == 0._quad, 1) ! true where column has some zeros - xallz = all(x == 0._quad, 1) ! true where column has only zeros - xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) - xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) - call getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - else - wid = SE%w + ! + dmx = SE%dmx + h = HUGE(h) + xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf + IF (SE%w == 0) THEN ! Edit descriptor 'F0.d' specified + ww = maxw_quad(RESHAPE(x, (/SIZE(x)/)), SE%d) + IF (SE%lzas > 0 .AND. ANY(x == 0._QUAD)) ww = MAX(ww, SE%lzas) + CALL replace_w(SE%ed, ww) + SE%w = ww + ELSEIF (SE%w < 0) THEN ! No edit descriptor specified + IF (SIZE(x) == 0) THEN + SE%w = 0 + wid = 0 nbl = 0 - endif - end subroutine find_editdesc_quad - - subroutine getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - ! determine length of the strings that result when writing with edit descriptor SE%ed a - ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output - real(quad), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column - logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros - logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals - type(settings), intent(in) :: SE ! settings - integer, intent(out) :: wid(:) ! widths of columns - integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmin, SE%ed) xminv - write(stmax, SE%ed) xmaxv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - if (SE%gedit) then - wid = w - else - wid = len_trim(adjustl(stmin)) - wid = max(wid, len_trim(adjustl(stmax))) - endif - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - endif - wid = merge(4, wid, xalln) - wid = max(wid, merge(4, 0, xnonn)) - nbl = w - wid - end subroutine getwid_quad - - ! ******** TOSTRING QUADRUPLE PRECISION PROCEDURES *********** - function tostring_s_quad(x) result(st) - ! Scalar to string - real(quad), intent(in) :: x - character(len_f_quad((/x/), tosset0%rfmt)) :: st - st = tostring_f_quad((/x/), tosset0%rfmt) - end function tostring_s_quad - - function tostring_sf_quad(x, fmt) result(st) - ! Scalar with specified format to string - real(quad), intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_quad((/x/), fmt)) :: st - st = tostring_f_quad((/x/), fmt) - end function tostring_sf_quad - - function tostring_quad(x) result(st) - ! Vector to string - real(quad), intent(in) :: x(:) - character(len_f_quad(x, tosset0%rfmt)) :: st - st = tostring_f_quad(x, tosset0%rfmt) - end function tostring_quad - - function tostring_f_quad(x, fmt) result(st) - ! Vector with specified format to string - real(quad) , intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_quad(x, fmt)) :: st - character(widthmax_quad(x, fmt)) :: sa(size(x)) - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - integer :: w, d, ww - logical :: gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then - st = errormsg - return - elseif (w == 0) then - ww = maxw_quad(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - call tostring_get(sa, st) - end function tostring_f_quad - - pure function len_f_quad(x, fmt) result(wtot) - ! Total length of returned string, vector s - real(quad), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_quad(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d, ww - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - if (w == 0) then - ww = maxw_quad(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_quad - - pure function widthmax_quad(x, fmt) result(w) - ! Maximum width of an element of x - real(quad), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(nnblk(fmt)+5) :: fmt1 - integer w, d - logical gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then ! illegal format, use 1 - w = 1 - elseif (w == 0) then - w = maxw_quad(x, d) - endif - end function widthmax_quad - - ! *************************************** END OF QUADRUPLE PRECISION PROCEDURES *************************************** - - ! *************************************** QUADRUPLE PRECISION COMPLEX PROCEDURES ************************************** - subroutine disp_s_cplq(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) - ! quadruple precision complex scalar without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim - complex(quad), intent(in) :: x - integer, intent(in), optional :: unit, digmax + RETURN + END IF + IF (ANY(xfinite)) THEN + xp = MAXVAL(x, mask=xfinite) + xm = MINVAL(x, mask=xfinite) + WRITE (f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 + WRITE (s, f1) xp; READ (s(dmx + 4:dmx + 8), '(I5)') expmax + WRITE (s, f1) xm; READ (s(dmx + 4:dmx + 8), '(I5)') expmin + CALL find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) + IF (.NOT. ALL(xfinite)) ww = MAX(ww, 4) + IF (SE%lzas > 0 .AND. ANY(x == 0._QUAD)) ww = MAX(ww, SE%lzas) + IF (SE%ed(5:5) == 'F') THEN ! (*) + WRITE (s, SE%ed) xp; IF (s(1:1) == '*') ww = ww + 1 + WRITE (s, SE%ed) xm; IF (s(1:1) == '*') ww = ww + 1 + WRITE (SE%ed(6:10), '(SS,I2,".",I2)') ww, dd + END IF + ELSE + ww = 4 + SE%ed = '(F4.0)' + END IF + SE%w = ww + END IF + IF (SE%trm) THEN + xmaxv = MAXVAL(x, 1, mask=xfinite) ! max in each column + xminv = MINVAL(x, 1, mask=xfinite) ! min + xzero = ANY(x == 0._QUAD, 1) ! true where column has some zeros + xallz = ALL(x == 0._QUAD, 1) ! true where column has only zeros + xnonn = ANY(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) + xalln = ALL(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) + CALL getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ELSE + wid = SE%w + nbl = 0 + END IF +END SUBROUTINE find_editdesc_quad + +SUBROUTINE getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ! determine length of the strings that result when writing with edit descriptor SE%ed a + ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output + REAL(quad), INTENT(in) :: xmaxv(:), xminv(:) ! max and min values in each column + LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros + LOGICAL, INTENT(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals + TYPE(settings), INTENT(in) :: SE ! settings + INTEGER, INTENT(out) :: wid(:) ! widths of columns + INTEGER, INTENT(out) :: nbl(:) ! number of blanks to peel from left (w-wid) + CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv)) + INTEGER w + w = SE%w + WRITE (stmin, SE%ed) xminv + WRITE (stmax, SE%ed) xmaxv + nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1)) + IF (SE%gedit) THEN + wid = w + ELSE + wid = LEN_TRIM(ADJUSTL(stmin)) + wid = MAX(wid, LEN_TRIM(ADJUSTL(stmax))) + END IF + IF (SE%lzas > 0) THEN + wid = MERGE(SE%lzas, wid, xallz) + wid = MAX(wid, MERGE(SE%lzas, 0, xzero)) + END IF + wid = MERGE(4, wid, xalln) + wid = MAX(wid, MERGE(4, 0, xnonn)) + nbl = w - wid +END SUBROUTINE getwid_quad + +! ******** TOSTRING QUADRUPLE PRECISION PROCEDURES *********** +FUNCTION tostring_s_quad(x) RESULT(st) + ! Scalar to string + REAL(quad), INTENT(in) :: x + CHARACTER(len_f_quad((/x/), tosset0%rfmt)) :: st + st = tostring_f_quad((/x/), tosset0%rfmt) +END FUNCTION tostring_s_quad + +FUNCTION tostring_sf_quad(x, fmt) RESULT(st) + ! Scalar with specified format to string + REAL(quad), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_quad((/x/), fmt)) :: st + st = tostring_f_quad((/x/), fmt) +END FUNCTION tostring_sf_quad + +FUNCTION tostring_quad(x) RESULT(st) + ! Vector to string + REAL(quad), INTENT(in) :: x(:) + CHARACTER(len_f_quad(x, tosset0%rfmt)) :: st + st = tostring_f_quad(x, tosset0%rfmt) +END FUNCTION tostring_quad + +FUNCTION tostring_f_quad(x, fmt) RESULT(st) + ! Vector with specified format to string + REAL(quad), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_quad(x, fmt)) :: st + CHARACTER(widthmax_quad(x, fmt)) :: sa(SIZE(x)) + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + INTEGER :: w, d, ww + LOGICAL :: gedit + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN + st = errormsg + RETURN + ELSEIF (w == 0) THEN + ww = maxw_quad(x, d) + CALL replace_w(fmt1, ww) + END IF + WRITE (sa, fmt1) x + CALL trim_real(sa, gedit, w) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_quad + +PURE FUNCTION len_f_quad(x, fmt) RESULT(wtot) + ! Total length of returned string, vector s + REAL(quad), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(widthmax_quad(x, fmt)) :: sa(SIZE(x)) + INTEGER :: wtot, w, d, ww + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + IF (w == 0) THEN + ww = maxw_quad(x, d) + CALL replace_w(fmt1, ww) + END IF + WRITE (sa, fmt1) x + CALL trim_real(sa, gedit, w) + wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_quad + +PURE FUNCTION widthmax_quad(x, fmt) RESULT(w) + ! Maximum width of an element of x + REAL(quad), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(nnblk(fmt) + 5) :: fmt1 + INTEGER w, d + LOGICAL gedit + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN ! illegal format, use 1 + w = 1 + ELSEIF (w == 0) THEN + w = maxw_quad(x, d) + END IF +END FUNCTION widthmax_quad + +! *************************************** END OF QUADRUPLE PRECISION PROCEDURES *************************************** + +! *************************************** QUADRUPLE PRECISION COMPLEX PROCEDURES ************************************** +SUBROUTINE disp_s_cplq(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) + ! quadruple precision complex scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, trim + COMPLEX(quad), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_ts_cplq('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) - end subroutine disp_s_cplq +END SUBROUTINE disp_s_cplq subroutine disp_v_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! quadruple precision complex vector without title + ! quadruple precision complex vector without title character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(quad), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax + COMPLEX(quad), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax call disp_tv_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_cplq +END SUBROUTINE disp_v_cplq subroutine disp_m_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! quadruple precision complex matrix without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(quad), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) + ! quadruple precision complex matrix without title +CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim + COMPLEX(quad), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) call disp_tm_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - end subroutine disp_m_cplq +END SUBROUTINE disp_m_cplq subroutine disp_ts_cplq(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) - ! quadruple precision complex scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(quad), intent(in) :: x - integer, intent(in), optional :: unit, digmax + ! quadruple precision complex scalar with title + CHARACTER(*), INTENT(in) :: title +CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim + COMPLEX(quad), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_tm_cplq(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, & - trim=trim, unit=unit) - end subroutine disp_ts_cplq + trim=trim, unit=unit) +END SUBROUTINE disp_ts_cplq subroutine disp_tv_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! quadruple precision complex vector with title - character(*), intent(in) :: title + ! quadruple precision complex vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(quad), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) SE, SEim + COMPLEX(quad), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax + TYPE(settings) SE, SEim call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - if (SE%row) then - call disp_cplq(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) - else - call disp_cplq(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) - end if - end subroutine disp_tv_cplq + IF (PRESENT(fmt_imag)) THEN + IF (.NOT. PRESENT(fmt)) THEN + CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN; + END IF + CALL get_SE(SEim, title, SHAPE(x), fmt_imag) + ELSE + SEim = SE + END IF + IF (SE%row) THEN + CALL disp_cplq(title, RESHAPE(x, (/1, SIZE(x)/)), SE, SEim, n=SIZE(x)) + ELSE + CALL disp_cplq(title, RESHAPE(x, (/SIZE(x), 1/)), SE, SEim, n=1) + END IF +END SUBROUTINE disp_tv_cplq subroutine disp_tm_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! quadruple precision complex matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - complex(quad), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & - ! ! is present) - character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & - ! ! and aimag(x) - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - ! - type(settings) :: SE, SEim + ! quadruple precision complex matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + COMPLEX(quad), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Edit descriptor for each element (real element when fmt_imag & + ! ! is present) + CHARACTER(*), INTENT(in), OPTIONAL :: fmt_imag ! Edit descriptor for each imaginary element + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in real(x) & + ! ! and aimag(x) + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + ! + TYPE(settings) :: SE, SEim call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - call disp_cplq(title, x, SE, SEim, n = size(x,2)) - end subroutine disp_tm_cplq - - subroutine disp_cplq(title, x, SE, SEim, n) - ! quadruple precision item - character(*), intent(in) :: title - complex(quad), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE, SEim - integer, intent(in) :: n - integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) - call find_editdesc_quad(real(x), SE, widre, nblre) ! determine also SE%w - call find_editdesc_quad(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w + IF (PRESENT(fmt_imag)) THEN + IF (.NOT. PRESENT(fmt)) THEN + CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN + END IF + CALL get_SE(SEim, title, SHAPE(x), fmt_imag) + ELSE + SEim = SE + END IF + CALL disp_cplq(title, x, SE, SEim, n=SIZE(x, 2)) +END SUBROUTINE disp_tm_cplq + +SUBROUTINE disp_cplq(title, x, SE, SEim, n) + ! quadruple precision item + CHARACTER(*), INTENT(in) :: title + COMPLEX(quad), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE, SEim + INTEGER, INTENT(in) :: n + INTEGER, DIMENSION(n) :: widre(n), widim(n), nblre(n), nblim(n) + CALL find_editdesc_quad(REAL(x), SE, widre, nblre) ! determine also SE%w + CALL find_editdesc_quad(ABS(AIMAG(x)), SEim, widim, nblim) ! determine also SEim%w call tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) - end subroutine disp_cplq - - subroutine tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) - ! Write quadruple precision complex matrix to box - character(*), intent(in) :: title - complex(quad), intent(in) :: x(:,:) - integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) - type(settings), intent(INOUT ) :: SE, SEim - character(SE%w) :: s(m) - character(SEim%w) :: sim(m) - character(3) :: sgn(m) - integer :: lin1, i, j, wleft, wid(n), widp(n) - character, pointer :: boxp(:,:) - SE%zas = '' - SEim%zas = '' - wid = widre + widim + 4 - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) +END SUBROUTINE disp_cplq + +SUBROUTINE tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) + ! Write quadruple precision complex matrix to box + CHARACTER(*), INTENT(in) :: title + COMPLEX(quad), INTENT(in) :: x(:, :) + INTEGER, INTENT(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) + TYPE(settings), INTENT(INOUT) :: SE, SEim + CHARACTER(SE%w) :: s(m) + CHARACTER(SEim%w) :: sim(m) + CHARACTER(3) :: sgn(m) + INTEGER :: lin1, i, j, wleft, wid(n), widp(n) + CHARACTER, POINTER :: boxp(:, :) + SE%zas = '' + SEim%zas = '' + wid = widre + widim + 4 + CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + DO j = 1, n + IF (m > 0) WRITE (s, SE%ed) (REAL(x(i, j)), i=1, m) call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) - do i=1,m - if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif - enddo - call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) - if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) - call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) - call copyseptobox('i', m, lin1, boxp, wleft) - if (j 0) WRITE (sim, SEim%ed) (ABS(AIMAG(x(i, j))), i=1, m) + CALL copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) + CALL copyseptobox('i', m, lin1, boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_cplq + +! ******* TOSTRING QUADRUPLE PRECISION COMPLEX PROCEDURES ******** + +FUNCTION tostring_s_cplq(x) RESULT(st) + COMPLEX(quad), INTENT(in) :: x + CHARACTER(len_s_cplq(x, tosset0%rfmt)) :: st + st = tostring_f_cplq((/x/), tosset0%rfmt) +END FUNCTION tostring_s_cplq + +FUNCTION tostring_sf_cplq(x, fmt) RESULT(st) + COMPLEX(quad), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_s_cplq(x, fmt)) :: st + st = tostring_f_cplq((/x/), fmt) +END FUNCTION tostring_sf_cplq + +FUNCTION tostring_cplq(x) RESULT(st) + COMPLEX(quad), INTENT(in) :: x(:) + CHARACTER(len_f_cplq(x, tosset0%rfmt)) :: st + st = tostring_f_cplq(x, tosset0%rfmt) +END FUNCTION tostring_cplq + +FUNCTION tostring_f_cplq(x, fmt) RESULT(st) + COMPLEX(quad), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_cplq(x, fmt)) :: st + CHARACTER(widthmax_quad(REAL(x), fmt)) :: sar(SIZE(x)) + CHARACTER(widthmax_quad(ABS(x - REAL(x)), fmt)) :: sai(SIZE(x)) ! x-real(x) instead of aimag(x) to enable the fnction + CHARACTER(1) :: sgn(SIZE(x)) ! to pass -stand:f95 switch of the ifort compiler. + INTEGER :: w, d, wr, wi, i + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + REAL(quad) :: xre(SIZE(x)), xim(SIZE(x)), h + CALL readfmt(fmt, fmt1, w, d, gedit) + xre = REAL(x) + xim = AIMAG(x) + h = HUGE(h) + IF (w < 0) THEN + st = errormsg + RETURN + ELSEIF (w == 0) THEN + wr = maxw_quad(xre, d) + wi = maxw_quad(xim, d) + CALL replace_w(fmt1, MAX(wr, wi)) + END IF + WRITE (sar, fmt1) REAL(x) + WRITE (sai, fmt1) ABS(AIMAG(x)) + CALL trim_real(sar, gedit, w) + CALL trim_real(sai, gedit, w) + DO i = 1, SIZE(x); IF (AIMAG(x(i)) < 0) THEN; sgn(i) = '-'; ELSE; sgn(i) = '+'; END IF; END DO + CALL tostring_get_complex(sar, sgn, sai, st) +END FUNCTION tostring_f_cplq + +PURE FUNCTION len_s_cplq(x, fmt) RESULT(wtot) + COMPLEX(quad), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + wtot = len_f_quad((/REAL(x)/), fmt) + len_f_quad((/ABS(AIMAG(x))/), fmt) + 4 +END FUNCTION len_s_cplq + +PURE FUNCTION len_f_cplq(x, fmt) RESULT(wtot) + COMPLEX(quad), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF wtot = len_f_quad(real(x), fmt) + len_f_quad(abs(aimag(x)), fmt) + size(x)*4 - (size(x) - 1)*(tosset0%seplen) - ! subtract seplen because it has been added twice in len_f_quad - end function len_f_cplq - ! *************************************** END OF QUADRUPLE PRECISION COMPLEX PROCEDURES ******************************** + ! subtract seplen because it has been added twice in len_f_quad +END FUNCTION len_f_cplq +! *************************************** END OF QUADRUPLE PRECISION COMPLEX PROCEDURES ******************************** #endif END MODULE DISP_R16MOD diff --git a/src/modules/Display/src/disp/disp_r4mod.F90 b/src/modules/Display/src/disp/disp_r4mod.F90 index b816a007a..94b5deb3e 100755 --- a/src/modules/Display/src/disp/disp_r4mod.F90 +++ b/src/modules/Display/src/disp/disp_r4mod.F90 @@ -11,7 +11,7 @@ MODULE DISP_R4MOD USE DISPMODULE_UTIL -USE GlobalData, ONLY: Real32 +USE GlobalData, ONLY: REAL32 PUBLIC DISP PUBLIC TOSTRING PRIVATE @@ -34,516 +34,516 @@ MODULE DISP_R4MOD MODULE PROCEDURE tostring_cplx, tostring_f_cplx, tostring_s_cplx, tostring_sf_cplx END INTERFACE TOSTRING -INTEGER, PARAMETER :: sngl = Real32 +INTEGER, PARAMETER :: sngl = REAL32 CONTAINS - subroutine disp_s_sngl(x, fmt, advance, digmax, sep, trim, unit, zeroas) - ! snglruple precision scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - real(sngl), intent(in) :: x - integer, intent(in), optional :: unit, digmax +SUBROUTINE disp_s_sngl(x, fmt, advance, digmax, sep, trim, unit, zeroas) + ! snglruple precision scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas + REAL(sngl), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_ts_sngl('', x, fmt, advance, digmax, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_sngl +END SUBROUTINE disp_s_sngl subroutine disp_v_sngl(x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - ! snglruple precision vector without title + ! snglruple precision vector without title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - real(sngl), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax + REAL(sngl), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax call disp_tv_sngl('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_sngl +END SUBROUTINE disp_v_sngl subroutine disp_m_sngl(x, fmt, advance, lbound, sep, style, trim, unit, digmax, zeroas) - ! snglruple precision matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - real(sngl), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) + ! snglruple precision matrix without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + REAL(sngl), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) call disp_tm_sngl('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_sngl +END SUBROUTINE disp_m_sngl subroutine disp_ts_sngl(title, x, fmt, advance, digmax, sep, style, trim, unit, zeroas) - ! snglruple precision scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - real(sngl), intent(in) :: x - integer, intent(in), optional :: unit, digmax + ! snglruple precision scalar with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + REAL(sngl), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_tm_sngl(title, reshape((/x/), (/1, 1/)), fmt, advance, digmax, sep=sep, style=style, trim=trim, & - unit=unit, zeroas=zeroas) - end subroutine disp_ts_sngl + unit=unit, zeroas=zeroas) +END SUBROUTINE disp_ts_sngl subroutine disp_tv_sngl(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - ! snglruple precision vector with title - character(*), intent(in) :: title + ! snglruple precision vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - real(sngl), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) :: SE + REAL(sngl), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas, digmax) - if (SE%row) then - call disp_sngl(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_sngl(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_sngl + IF (SE%row) THEN + CALL disp_sngl(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_sngl(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_sngl subroutine disp_tm_sngl(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas) - ! snglruple precision matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - real(sngl), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2') - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in x - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced with this string if it is not empty - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - ! + ! snglruple precision matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + REAL(sngl), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2') + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in x + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced with this string if it is not empty + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + TYPE(settings) :: SE + ! call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas, digmax=digmax) - call disp_sngl(title, x, SE) - end subroutine disp_tm_sngl - - subroutine disp_sngl(title, x, SE) - ! snglruple precision item - character(*), intent(in) :: title - real(sngl), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_sngl(x, SE, wid, nbl) ! determine also SE%w - call tobox_sngl(title, x, SE, wid, nbl) - end subroutine disp_sngl - - subroutine tobox_sngl(title, x, SE, wid, nbl) - ! Write snglruple precision matrix to box - character(*), intent(in) :: title ! title - real(sngl), intent(in) :: x(:,:) ! item - type(settings), intent(INOUT ) :: SE ! settings - integer, intent(INOUT ) :: wid(:) ! widths of columns - integer, intent(INOUT ) :: nbl(:) ! number of blanks to trim from left - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - real(sngl) :: xj(size(x,1)), h - m = size(x,1) - n = size(x,2) - h = huge(x) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - xj = x(:, j) - if (m > 0) write(s, SE%ed) xj + CALL disp_sngl(title, x, SE) +END SUBROUTINE disp_tm_sngl + +SUBROUTINE disp_sngl(title, x, SE) + ! snglruple precision item + CHARACTER(*), INTENT(in) :: title + REAL(sngl), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + CALL find_editdesc_sngl(x, SE, wid, nbl) ! determine also SE%w + CALL tobox_sngl(title, x, SE, wid, nbl) +END SUBROUTINE disp_sngl + +SUBROUTINE tobox_sngl(title, x, SE, wid, nbl) + ! Write snglruple precision matrix to box + CHARACTER(*), INTENT(in) :: title ! title + REAL(sngl), INTENT(in) :: x(:, :) ! item + TYPE(settings), INTENT(INOUT) :: SE ! settings + INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns + INTEGER, INTENT(INOUT) :: nbl(:) ! number of blanks to trim from left + CHARACTER(SE%w) :: s(SIZE(x, 1)) + INTEGER :: lin1, j, wleft, m, n, widp(SIZE(wid)) + CHARACTER, POINTER :: boxp(:, :) + REAL(sngl) :: xj(SIZE(x, 1)), h + m = SIZE(x, 1) + n = SIZE(x, 2) + h = HUGE(x) + CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + DO j = 1, n + xj = x(:, j) + IF (m > 0) WRITE (s, SE%ed) xj call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (.not. any(xfinite)) then - w = 4 - else - xmax = maxval(x, mask=xfinite) - xmin = minval(x, mask=xfinite) - f1 = '(SS,ES9.0E4)' - write(s,f1) xmax, xmin - read(s(:)(5:9),'(I5)') expmax, expmin - w = max(0, expmax, expmin) + d + 4 - end if - if (.not. all(xfinite)) w = max(w, 4) - end function maxw_sngl - - subroutine find_editdesc_sngl(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid. - ! The if-block (*) is for safety: make f wider in case xm is written ok with the - ! ES format in fmt but overflows with F format (the feature has been tested through - ! manual changes to the program). - real(sngl), intent(in) :: x(:,:) ! Item to be written - type(settings), intent(INOUT ) :: SE ! Settings - integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns - integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns - integer :: expmax, expmin, ww, dd, dmx - real(sngl) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h - character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 - character(99) s + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_sngl + +PURE FUNCTION maxw_sngl(x, d) RESULT(w) + ! Find max field width needed (F0.d editing is specified) + REAL(sngl), INTENT(in) :: x(:) + INTEGER, INTENT(in) :: d + INTEGER expmax, expmin, w + LOGICAL xfinite(SIZE(x)) + REAL(sngl) xmax, xmin, h + CHARACTER(12) :: f1, s(2) + xmin = 0; xmax = 0; h = HUGE(h) + xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf + IF (.NOT. ANY(xfinite)) THEN + w = 4 + ELSE + xmax = MAXVAL(x, mask=xfinite) + xmin = MINVAL(x, mask=xfinite) + f1 = '(SS,ES9.0E4)' + WRITE (s, f1) xmax, xmin + READ (s(:) (5:9), '(I5)') expmax, expmin + w = MAX(0, expmax, expmin) + d + 4 + END IF + IF (.NOT. ALL(xfinite)) w = MAX(w, 4) +END FUNCTION maxw_sngl + +SUBROUTINE find_editdesc_sngl(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid. + ! The if-block (*) is for safety: make f wider in case xm is written ok with the + ! ES format in fmt but overflows with F format (the feature has been tested through + ! manual changes to the program). + REAL(sngl), INTENT(in) :: x(:, :) ! Item to be written + TYPE(settings), INTENT(INOUT) :: SE ! Settings + INTEGER, INTENT(out) :: wid(SIZE(x, 2)) ! Widths of individual columns + INTEGER, INTENT(out) :: nbl(SIZE(x, 2)) ! Blanks to trim from left of individual columns + INTEGER :: expmax, expmin, ww, dd, dmx + REAL(sngl) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm, h + CHARACTER(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 + CHARACTER(99) s logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) - ! - dmx = SE%dmx - h = huge(h) - xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (SE%w == 0) then ! Edit descriptor 'F0.d' specified - ww = maxw_sngl(reshape(x, (/size(x)/)), SE%d) - if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas) - call replace_w(SE%ed, ww) - SE%w = ww - elseif (SE%w < 0) then ! No edit descriptor specified - if (size(x) == 0) then - SE%w = 0 - wid = 0 - nbl = 0 - return - endif - if (any(xfinite)) then - xp = maxval(x, mask=xfinite) - xm = minval(x, mask=xfinite) - write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 - write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax - write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin - call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) - if (.not. all(xfinite)) ww = max(ww, 4) - if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas) - if (SE%ed(5:5)=='F') then ! (*) - write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 - write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 - write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd - endif - else - ww = 4 - SE%ed = '(F4.0)' - endif - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1, mask=xfinite) ! max in each column - xminv = minval(x, 1, mask=xfinite) ! min - xzero = any(x == 0._sngl, 1) ! true where column has some zeros - xallz = all(x == 0._sngl, 1) ! true where column has only zeros - xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) - xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) - call getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - else - wid = SE%w + ! + dmx = SE%dmx + h = HUGE(h) + xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf + IF (SE%w == 0) THEN ! Edit descriptor 'F0.d' specified + ww = maxw_sngl(RESHAPE(x, (/SIZE(x)/)), SE%d) + IF (SE%lzas > 0 .AND. ANY(x == 0._SNGL)) ww = MAX(ww, SE%lzas) + CALL replace_w(SE%ed, ww) + SE%w = ww + ELSEIF (SE%w < 0) THEN ! No edit descriptor specified + IF (SIZE(x) == 0) THEN + SE%w = 0 + wid = 0 nbl = 0 - endif - end subroutine find_editdesc_sngl - - subroutine getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - ! determine length of the strings that result when writing with edit descriptor SE%ed a - ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output - real(sngl), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column - logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros - logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals - type(settings), intent(in) :: SE ! settings - integer, intent(out) :: wid(:) ! widths of columns - integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmin, SE%ed) xminv - write(stmax, SE%ed) xmaxv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - if (SE%gedit) then - wid = w - else - wid = len_trim(adjustl(stmin)) - wid = max(wid, len_trim(adjustl(stmax))) - endif - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - endif - wid = merge(4, wid, xalln) - wid = max(wid, merge(4, 0, xnonn)) - nbl = w - wid - end subroutine getwid_sngl - - ! ******** TOSTRING snglRUPLE PRECISION PROCEDURES *********** - function tostring_s_sngl(x) result(st) - ! Scalar to string - real(sngl), intent(in) :: x - character(len_f_sngl((/x/), tosset0%rfmt)) :: st - st = tostring_f_sngl((/x/), tosset0%rfmt) - end function tostring_s_sngl - - function tostring_sf_sngl(x, fmt) result(st) - ! Scalar with specified format to string - real(sngl), intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_sngl((/x/), fmt)) :: st - st = tostring_f_sngl((/x/), fmt) - end function tostring_sf_sngl - - function tostring_sngl(x) result(st) - ! Vector to string - real(sngl), intent(in) :: x(:) - character(len_f_sngl(x, tosset0%rfmt)) :: st - st = tostring_f_sngl(x, tosset0%rfmt) - end function tostring_sngl - - function tostring_f_sngl(x, fmt) result(st) - ! Vector with specified format to string - real(sngl) , intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_sngl(x, fmt)) :: st - character(widthmax_sngl(x, fmt)) :: sa(size(x)) - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - integer :: w, d, ww - logical :: gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then - st = errormsg - return - elseif (w == 0) then - ww = maxw_sngl(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - call tostring_get(sa, st) - end function tostring_f_sngl - - pure function len_f_sngl(x, fmt) result(wtot) - ! Total length of returned string, vector s - real(sngl), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_sngl(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d, ww - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - if (w == 0) then - ww = maxw_sngl(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_sngl - - pure function widthmax_sngl(x, fmt) result(w) - ! Maximum width of an element of x - real(sngl), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(nnblk(fmt)+5) :: fmt1 - integer w, d - logical gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then ! illegal format, use 1 - w = 1 - elseif (w == 0) then - w = maxw_sngl(x, d) - endif - end function widthmax_sngl - - ! *************************************** END OF snglRUPLE PRECISION PROCEDURES *************************************** - - ! *************************************** snglRUPLE PRECISION COMPLEX PROCEDURES ************************************** - subroutine disp_s_cplx(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) - ! snglruple precision complex scalar without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim - complex(sngl), intent(in) :: x - integer, intent(in), optional :: unit, digmax + RETURN + END IF + IF (ANY(xfinite)) THEN + xp = MAXVAL(x, mask=xfinite) + xm = MINVAL(x, mask=xfinite) + WRITE (f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 + WRITE (s, f1) xp; READ (s(dmx + 4:dmx + 8), '(I5)') expmax + WRITE (s, f1) xm; READ (s(dmx + 4:dmx + 8), '(I5)') expmin + CALL find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) + IF (.NOT. ALL(xfinite)) ww = MAX(ww, 4) + IF (SE%lzas > 0 .AND. ANY(x == 0._SNGL)) ww = MAX(ww, SE%lzas) + IF (SE%ed(5:5) == 'F') THEN ! (*) + WRITE (s, SE%ed) xp; IF (s(1:1) == '*') ww = ww + 1 + WRITE (s, SE%ed) xm; IF (s(1:1) == '*') ww = ww + 1 + WRITE (SE%ed(6:10), '(SS,I2,".",I2)') ww, dd + END IF + ELSE + ww = 4 + SE%ed = '(F4.0)' + END IF + SE%w = ww + END IF + IF (SE%trm) THEN + xmaxv = MAXVAL(x, 1, mask=xfinite) ! max in each column + xminv = MINVAL(x, 1, mask=xfinite) ! min + xzero = ANY(x == 0._SNGL, 1) ! true where column has some zeros + xallz = ALL(x == 0._SNGL, 1) ! true where column has only zeros + xnonn = ANY(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) + xalln = ALL(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) + CALL getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ELSE + wid = SE%w + nbl = 0 + END IF +END SUBROUTINE find_editdesc_sngl + +SUBROUTINE getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ! determine length of the strings that result when writing with edit descriptor SE%ed a + ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output + REAL(sngl), INTENT(in) :: xmaxv(:), xminv(:) ! max and min values in each column + LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros + LOGICAL, INTENT(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals + TYPE(settings), INTENT(in) :: SE ! settings + INTEGER, INTENT(out) :: wid(:) ! widths of columns + INTEGER, INTENT(out) :: nbl(:) ! number of blanks to peel from left (w-wid) + CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv)) + INTEGER w + w = SE%w + WRITE (stmin, SE%ed) xminv + WRITE (stmax, SE%ed) xmaxv + nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1)) + IF (SE%gedit) THEN + wid = w + ELSE + wid = LEN_TRIM(ADJUSTL(stmin)) + wid = MAX(wid, LEN_TRIM(ADJUSTL(stmax))) + END IF + IF (SE%lzas > 0) THEN + wid = MERGE(SE%lzas, wid, xallz) + wid = MAX(wid, MERGE(SE%lzas, 0, xzero)) + END IF + wid = MERGE(4, wid, xalln) + wid = MAX(wid, MERGE(4, 0, xnonn)) + nbl = w - wid +END SUBROUTINE getwid_sngl + +! ******** TOSTRING snglRUPLE PRECISION PROCEDURES *********** +FUNCTION tostring_s_sngl(x) RESULT(st) + ! Scalar to string + REAL(sngl), INTENT(in) :: x + CHARACTER(len_f_sngl((/x/), tosset0%rfmt)) :: st + st = tostring_f_sngl((/x/), tosset0%rfmt) +END FUNCTION tostring_s_sngl + +FUNCTION tostring_sf_sngl(x, fmt) RESULT(st) + ! Scalar with specified format to string + REAL(sngl), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_sngl((/x/), fmt)) :: st + st = tostring_f_sngl((/x/), fmt) +END FUNCTION tostring_sf_sngl + +FUNCTION tostring_sngl(x) RESULT(st) + ! Vector to string + REAL(sngl), INTENT(in) :: x(:) + CHARACTER(len_f_sngl(x, tosset0%rfmt)) :: st + st = tostring_f_sngl(x, tosset0%rfmt) +END FUNCTION tostring_sngl + +FUNCTION tostring_f_sngl(x, fmt) RESULT(st) + ! Vector with specified format to string + REAL(sngl), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_sngl(x, fmt)) :: st + CHARACTER(widthmax_sngl(x, fmt)) :: sa(SIZE(x)) + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + INTEGER :: w, d, ww + LOGICAL :: gedit + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN + st = errormsg + RETURN + ELSEIF (w == 0) THEN + ww = maxw_sngl(x, d) + CALL replace_w(fmt1, ww) + END IF + WRITE (sa, fmt1) x + CALL trim_real(sa, gedit, w) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_sngl + +PURE FUNCTION len_f_sngl(x, fmt) RESULT(wtot) + ! Total length of returned string, vector s + REAL(sngl), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(widthmax_sngl(x, fmt)) :: sa(SIZE(x)) + INTEGER :: wtot, w, d, ww + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + IF (w == 0) THEN + ww = maxw_sngl(x, d) + CALL replace_w(fmt1, ww) + END IF + WRITE (sa, fmt1) x + CALL trim_real(sa, gedit, w) + wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_sngl + +PURE FUNCTION widthmax_sngl(x, fmt) RESULT(w) + ! Maximum width of an element of x + REAL(sngl), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(nnblk(fmt) + 5) :: fmt1 + INTEGER w, d + LOGICAL gedit + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN ! illegal format, use 1 + w = 1 + ELSEIF (w == 0) THEN + w = maxw_sngl(x, d) + END IF +END FUNCTION widthmax_sngl + +! *************************************** END OF snglRUPLE PRECISION PROCEDURES *************************************** + +! *************************************** snglRUPLE PRECISION COMPLEX PROCEDURES ************************************** +SUBROUTINE disp_s_cplx(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) + ! snglruple precision complex scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, trim + COMPLEX(sngl), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_ts_cplx('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) - end subroutine disp_s_cplx +END SUBROUTINE disp_s_cplx subroutine disp_v_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! snglruple precision complex vector without title + ! snglruple precision complex vector without title character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(sngl), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax + COMPLEX(sngl), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax call disp_tv_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_cplx +END SUBROUTINE disp_v_cplx subroutine disp_m_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! snglruple precision complex matrix without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(sngl), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) + ! snglruple precision complex matrix without title +CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim + COMPLEX(sngl), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) call disp_tm_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - end subroutine disp_m_cplx +END SUBROUTINE disp_m_cplx subroutine disp_ts_cplx(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) - ! snglruple precision complex scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(sngl), intent(in) :: x - integer, intent(in), optional :: unit, digmax + ! snglruple precision complex scalar with title + CHARACTER(*), INTENT(in) :: title +CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim + COMPLEX(sngl), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_tm_cplx(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, & - trim=trim, unit=unit) - end subroutine disp_ts_cplx + trim=trim, unit=unit) +END SUBROUTINE disp_ts_cplx subroutine disp_tv_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! snglruple precision complex vector with title - character(*), intent(in) :: title + ! snglruple precision complex vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(sngl), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) SE, SEim + COMPLEX(sngl), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax + TYPE(settings) SE, SEim call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - if (SE%row) then - call disp_cplx(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) - else - call disp_cplx(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) - end if - end subroutine disp_tv_cplx + IF (PRESENT(fmt_imag)) THEN + IF (.NOT. PRESENT(fmt)) THEN + CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN; + END IF + CALL get_SE(SEim, title, SHAPE(x), fmt_imag) + ELSE + SEim = SE + END IF + IF (SE%row) THEN + CALL disp_cplx(title, RESHAPE(x, (/1, SIZE(x)/)), SE, SEim, n=SIZE(x)) + ELSE + CALL disp_cplx(title, RESHAPE(x, (/SIZE(x), 1/)), SE, SEim, n=1) + END IF +END SUBROUTINE disp_tv_cplx subroutine disp_tm_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! snglruple precision complex matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - complex(sngl), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & - ! ! is present) - character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & - ! ! and aimag(x) - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - ! - type(settings) :: SE, SEim + ! snglruple precision complex matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + COMPLEX(sngl), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Edit descriptor for each element (real element when fmt_imag & + ! ! is present) + CHARACTER(*), INTENT(in), OPTIONAL :: fmt_imag ! Edit descriptor for each imaginary element + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in real(x) & + ! ! and aimag(x) + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + ! + TYPE(settings) :: SE, SEim call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - call disp_cplx(title, x, SE, SEim, n = size(x,2)) - end subroutine disp_tm_cplx - - subroutine disp_cplx(title, x, SE, SEim, n) - ! snglruple precision item - character(*), intent(in) :: title - complex(sngl), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE, SEim - integer, intent(in) :: n - integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) - call find_editdesc_sngl(real(x), SE, widre, nblre) ! determine also SE%w - call find_editdesc_sngl(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w + IF (PRESENT(fmt_imag)) THEN + IF (.NOT. PRESENT(fmt)) THEN + CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN + END IF + CALL get_SE(SEim, title, SHAPE(x), fmt_imag) + ELSE + SEim = SE + END IF + CALL disp_cplx(title, x, SE, SEim, n=SIZE(x, 2)) +END SUBROUTINE disp_tm_cplx + +SUBROUTINE disp_cplx(title, x, SE, SEim, n) + ! snglruple precision item + CHARACTER(*), INTENT(in) :: title + COMPLEX(sngl), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE, SEim + INTEGER, INTENT(in) :: n + INTEGER, DIMENSION(n) :: widre(n), widim(n), nblre(n), nblim(n) + CALL find_editdesc_sngl(REAL(x), SE, widre, nblre) ! determine also SE%w + CALL find_editdesc_sngl(ABS(AIMAG(x)), SEim, widim, nblim) ! determine also SEim%w call tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) - end subroutine disp_cplx - - subroutine tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) - ! Write snglruple precision complex matrix to box - character(*), intent(in) :: title - complex(sngl), intent(in) :: x(:,:) - integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) - type(settings), intent(INOUT ) :: SE, SEim - character(SE%w) :: s(m) - character(SEim%w) :: sim(m) - character(3) :: sgn(m) - integer :: lin1, i, j, wleft, wid(n), widp(n) - character, pointer :: boxp(:,:) - SE%zas = '' - SEim%zas = '' - wid = widre + widim + 4 - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) +END SUBROUTINE disp_cplx + +SUBROUTINE tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) + ! Write snglruple precision complex matrix to box + CHARACTER(*), INTENT(in) :: title + COMPLEX(sngl), INTENT(in) :: x(:, :) + INTEGER, INTENT(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) + TYPE(settings), INTENT(INOUT) :: SE, SEim + CHARACTER(SE%w) :: s(m) + CHARACTER(SEim%w) :: sim(m) + CHARACTER(3) :: sgn(m) + INTEGER :: lin1, i, j, wleft, wid(n), widp(n) + CHARACTER, POINTER :: boxp(:, :) + SE%zas = '' + SEim%zas = '' + wid = widre + widim + 4 + CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + DO j = 1, n + IF (m > 0) WRITE (s, SE%ed) (REAL(x(i, j)), i=1, m) call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) - do i=1,m - if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif - enddo - call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) - if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) - call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) - call copyseptobox('i', m, lin1, boxp, wleft) - if (j 0) WRITE (sim, SEim%ed) (ABS(AIMAG(x(i, j))), i=1, m) + CALL copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) + CALL copyseptobox('i', m, lin1, boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_cplx + +! ******* TOSTRING snglRUPLE PRECISION COMPLEX PROCEDURES ******** + +FUNCTION tostring_s_cplx(x) RESULT(st) + COMPLEX(sngl), INTENT(in) :: x + CHARACTER(len_s_cplx(x, tosset0%rfmt)) :: st + st = tostring_f_cplx((/x/), tosset0%rfmt) +END FUNCTION tostring_s_cplx + +FUNCTION tostring_sf_cplx(x, fmt) RESULT(st) + COMPLEX(sngl), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_s_cplx(x, fmt)) :: st + st = tostring_f_cplx((/x/), fmt) +END FUNCTION tostring_sf_cplx + +FUNCTION tostring_cplx(x) RESULT(st) + COMPLEX(sngl), INTENT(in) :: x(:) + CHARACTER(len_f_cplx(x, tosset0%rfmt)) :: st + st = tostring_f_cplx(x, tosset0%rfmt) +END FUNCTION tostring_cplx + +FUNCTION tostring_f_cplx(x, fmt) RESULT(st) + COMPLEX(sngl), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_cplx(x, fmt)) :: st + CHARACTER(widthmax_sngl(REAL(x), fmt)) :: sar(SIZE(x)) + CHARACTER(widthmax_sngl(ABS(x - REAL(x)), fmt)) :: sai(SIZE(x)) ! x-real(x) instead of aimag(x) to enable the fnction + CHARACTER(1) :: sgn(SIZE(x)) ! to pass -stand:f95 switch of the ifort compiler. + INTEGER :: w, d, wr, wi, i + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + REAL(sngl) :: xre(SIZE(x)), xim(SIZE(x)), h + CALL readfmt(fmt, fmt1, w, d, gedit) + xre = REAL(x) + xim = AIMAG(x) + h = HUGE(h) + IF (w < 0) THEN + st = errormsg + RETURN + ELSEIF (w == 0) THEN + wr = maxw_sngl(xre, d) + wi = maxw_sngl(xim, d) + CALL replace_w(fmt1, MAX(wr, wi)) + END IF + WRITE (sar, fmt1) REAL(x) + WRITE (sai, fmt1) ABS(AIMAG(x)) + CALL trim_real(sar, gedit, w) + CALL trim_real(sai, gedit, w) + DO i = 1, SIZE(x); IF (AIMAG(x(i)) < 0) THEN; sgn(i) = '-'; ELSE; sgn(i) = '+'; END IF; END DO + CALL tostring_get_complex(sar, sgn, sai, st) +END FUNCTION tostring_f_cplx + +PURE FUNCTION len_s_cplx(x, fmt) RESULT(wtot) + COMPLEX(sngl), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + wtot = len_f_sngl((/REAL(x)/), fmt) + len_f_sngl((/ABS(AIMAG(x))/), fmt) + 4 +END FUNCTION len_s_cplx + +PURE FUNCTION len_f_cplx(x, fmt) RESULT(wtot) + COMPLEX(sngl), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF wtot = len_f_sngl(real(x), fmt) + len_f_sngl(abs(aimag(x)), fmt) + size(x)*4 - (size(x) - 1)*(tosset0%seplen) - ! subtract seplen because it has been added twice in len_f_sngl - end function len_f_cplx + ! subtract seplen because it has been added twice in len_f_sngl +END FUNCTION len_f_cplx END MODULE DISP_R4MOD diff --git a/src/modules/Display/src/disp/disp_r8mod.F90 b/src/modules/Display/src/disp/disp_r8mod.F90 index 5a32ff45d..7cdfae842 100755 --- a/src/modules/Display/src/disp/disp_r8mod.F90 +++ b/src/modules/Display/src/disp/disp_r8mod.F90 @@ -11,7 +11,7 @@ MODULE DISP_R8MOD USE DISPMODULE_UTIL -USE GlobalData, ONLY: Real64 +USE GlobalData, ONLY: REAL64 PUBLIC DISP PUBLIC TOSTRING PRIVATE @@ -34,7 +34,7 @@ MODULE DISP_R8MOD MODULE PROCEDURE tostring_cpld, tostring_f_cpld, tostring_s_cpld, tostring_sf_cpld END INTERFACE TOSTRING -INTEGER, PARAMETER :: dble = Real64 +INTEGER, PARAMETER :: dble = REAL64 CONTAINS @@ -42,625 +42,623 @@ MODULE DISP_R8MOD ! !---------------------------------------------------------------------------- - subroutine disp_s_dble(x, fmt, advance, digmax, sep, trim, unit, zeroas) - ! dbleruple precision scalar without title - character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas - real(dble), intent(in) :: x - integer, intent(in), optional :: unit, digmax +SUBROUTINE disp_s_dble(x, fmt, advance, digmax, sep, trim, unit, zeroas) + ! dbleruple precision scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas + REAL(dble), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_ts_dble('', x, fmt, advance, digmax, sep, 'left', trim, unit, zeroas) - end subroutine disp_s_dble +END SUBROUTINE disp_s_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_v_dble(x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - ! dbleruple precision vector without title + ! dbleruple precision vector without title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - real(dble), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax + REAL(dble), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax call disp_tv_dble('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - end subroutine disp_v_dble +END SUBROUTINE disp_v_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_m_dble(x, fmt, advance, lbound, sep, style, trim, unit, digmax, zeroas) - ! dbleruple precision matrix without title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - real(dble), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) + ! dbleruple precision matrix without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + REAL(dble), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) call disp_tm_dble('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas) - end subroutine disp_m_dble +END SUBROUTINE disp_m_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_ts_dble(title, x, fmt, advance, digmax, sep, style, trim, unit, zeroas) - ! dbleruple precision scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas - real(dble), intent(in) :: x - integer, intent(in), optional :: unit, digmax + ! dbleruple precision scalar with title + CHARACTER(*), INTENT(in) :: title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas + REAL(dble), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_tm_dble(title, reshape((/x/), (/1, 1/)), fmt, advance, digmax, sep=sep, style=style, trim=trim, & - & unit=unit, zeroas=zeroas) - end subroutine disp_ts_dble + & unit=unit, zeroas=zeroas) +END SUBROUTINE disp_ts_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_tv_dble(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas) - ! dbleruple precision vector with title - character(*), intent(in) :: title + ! dbleruple precision vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient - real(dble), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) :: SE + REAL(dble), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax + TYPE(settings) :: SE call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas, digmax) - if (SE%row) then - call disp_dble(title, reshape(x, (/1, size(x)/)), SE) - else - call disp_dble(title, reshape(x, (/size(x), 1/)), SE) - end if - end subroutine disp_tv_dble + IF (SE%row) THEN + CALL disp_dble(title, RESHAPE(x, (/1, SIZE(x)/)), SE) + ELSE + CALL disp_dble(title, RESHAPE(x, (/SIZE(x), 1/)), SE) + END IF +END SUBROUTINE disp_tv_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_tm_dble(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas) - ! dbleruple precision matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - real(dble), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2') - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in x - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: zeroas ! Zeros are replaced with this string if it is not empty - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - type(settings) :: SE - ! + ! dbleruple precision matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + REAL(dble), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2') + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in x + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced with this string if it is not empty + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + TYPE(settings) :: SE + ! call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas, digmax=digmax) - call disp_dble(title, x, SE) - end subroutine disp_tm_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_dble(title, x, SE) - ! dbleruple precision item - character(*), intent(in) :: title - real(dble), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE - integer wid(size(x,2)), nbl(size(x,2)) - call find_editdesc_dble(x, SE, wid, nbl) ! determine also SE%w - call tobox_dble(title, x, SE, wid, nbl) - end subroutine disp_dble - - subroutine tobox_dble(title, x, SE, wid, nbl) - ! Write dbleruple precision matrix to box - character(*), intent(in) :: title ! title - real(dble), intent(in) :: x(:,:) ! item - type(settings), intent(INOUT ) :: SE ! settings - integer, intent(INOUT ) :: wid(:) ! widths of columns - integer, intent(INOUT ) :: nbl(:) ! number of blanks to trim from left - character(SE%w) :: s(size(x,1)) - integer :: lin1, j, wleft, m, n, widp(size(wid)) - character, pointer :: boxp(:,:) - real(dble) :: xj(size(x,1)), h - m = size(x,1) - n = size(x,2) - h = huge(x) - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - xj = x(:, j) - if (m > 0) write(s, SE%ed) xj + CALL disp_dble(title, x, SE) +END SUBROUTINE disp_tm_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE disp_dble(title, x, SE) + ! dbleruple precision item + CHARACTER(*), INTENT(in) :: title + REAL(dble), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE + INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2)) + CALL find_editdesc_dble(x, SE, wid, nbl) ! determine also SE%w + CALL tobox_dble(title, x, SE, wid, nbl) +END SUBROUTINE disp_dble + +SUBROUTINE tobox_dble(title, x, SE, wid, nbl) + ! Write dbleruple precision matrix to box + CHARACTER(*), INTENT(in) :: title ! title + REAL(dble), INTENT(in) :: x(:, :) ! item + TYPE(settings), INTENT(INOUT) :: SE ! settings + INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns + INTEGER, INTENT(INOUT) :: nbl(:) ! number of blanks to trim from left + CHARACTER(SE%w) :: s(SIZE(x, 1)) + INTEGER :: lin1, j, wleft, m, n, widp(SIZE(wid)) + CHARACTER, POINTER :: boxp(:, :) + REAL(dble) :: xj(SIZE(x, 1)), h + m = SIZE(x, 1) + n = SIZE(x, 2) + h = HUGE(x) + CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + DO j = 1, n + xj = x(:, j) + IF (m > 0) WRITE (s, SE%ed) xj call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h) - call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) - if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (.not. any(xfinite)) then - w = 4 - else - xmax = maxval(x, mask=xfinite) - xmin = minval(x, mask=xfinite) - f1 = '(SS,ES9.0E4)' - write(s,f1) xmax, xmin - read(s(:)(5:9),'(I5)') expmax, expmin - w = max(0, expmax, expmin) + d + 4 - end if - if (.not. all(xfinite)) w = max(w, 4) - end function maxw_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine find_editdesc_dble(x, SE, wid, nbl) - ! Determine SE%ed, SE%w (unless specified) and wid. - ! The if-block (*) is for safety: make f wider in case xm is written ok with the - ! ES format in fmt but overflows with F format (the feature has been tested through - ! manual changes to the program). - real(dble), intent(in) :: x(:,:) ! Item to be written - type(settings), intent(INOUT ) :: SE ! Settings - integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns - integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns - integer :: expmax, expmin, ww, dd, dmx - real(dble) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h - character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 - character(99) s + CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION maxw_dble(x, d) RESULT(w) + ! Find max field width needed (F0.d editing is specified) + REAL(dble), INTENT(in) :: x(:) + INTEGER, INTENT(in) :: d + INTEGER expmax, expmin, w + LOGICAL xfinite(SIZE(x)) + REAL(dble) xmax, xmin, h + CHARACTER(12) :: f1, s(2) + xmin = 0; xmax = 0; h = HUGE(h) + xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf + IF (.NOT. ANY(xfinite)) THEN + w = 4 + ELSE + xmax = MAXVAL(x, mask=xfinite) + xmin = MINVAL(x, mask=xfinite) + f1 = '(SS,ES9.0E4)' + WRITE (s, f1) xmax, xmin + READ (s(:) (5:9), '(I5)') expmax, expmin + w = MAX(0, expmax, expmin) + d + 4 + END IF + IF (.NOT. ALL(xfinite)) w = MAX(w, 4) +END FUNCTION maxw_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE find_editdesc_dble(x, SE, wid, nbl) + ! Determine SE%ed, SE%w (unless specified) and wid. + ! The if-block (*) is for safety: make f wider in case xm is written ok with the + ! ES format in fmt but overflows with F format (the feature has been tested through + ! manual changes to the program). + REAL(dble), INTENT(in) :: x(:, :) ! Item to be written + TYPE(settings), INTENT(INOUT) :: SE ! Settings + INTEGER, INTENT(out) :: wid(SIZE(x, 2)) ! Widths of individual columns + INTEGER, INTENT(out) :: nbl(SIZE(x, 2)) ! Blanks to trim from left of individual columns + INTEGER :: expmax, expmin, ww, dd, dmx + REAL(dble) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm, h + CHARACTER(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4 + CHARACTER(99) s logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2)) - ! - dmx = SE%dmx - h = huge(h) - xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf - if (SE%w == 0) then ! Edit descriptor 'F0.d' specified - ww = maxw_dble(reshape(x, (/size(x)/)), SE%d) - if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas) - call replace_w(SE%ed, ww) - SE%w = ww - elseif (SE%w < 0) then ! No edit descriptor specified - if (size(x) == 0) then - SE%w = 0 - wid = 0 - nbl = 0 - return - endif - if (any(xfinite)) then - xp = maxval(x, mask=xfinite) - xm = minval(x, mask=xfinite) - write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 - write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax - write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin - call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) - if (.not. all(xfinite)) ww = max(ww, 4) - if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas) - if (SE%ed(5:5)=='F') then ! (*) - write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1 - write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1 - write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd - endif - else - ww = 4 - SE%ed = '(F4.0)' - endif - SE%w = ww - endif - if (SE%trm) then - xmaxv = maxval(x, 1, mask=xfinite) ! max in each column - xminv = minval(x, 1, mask=xfinite) ! min - xzero = any(x == 0._dble, 1) ! true where column has some zeros - xallz = all(x == 0._dble, 1) ! true where column has only zeros - xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) - xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) - call getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - else - wid = SE%w + ! + dmx = SE%dmx + h = HUGE(h) + xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf + IF (SE%w == 0) THEN ! Edit descriptor 'F0.d' specified + ww = maxw_dble(RESHAPE(x, (/SIZE(x)/)), SE%d) + IF (SE%lzas > 0 .AND. ANY(x == 0._DBLE)) ww = MAX(ww, SE%lzas) + CALL replace_w(SE%ed, ww) + SE%w = ww + ELSEIF (SE%w < 0) THEN ! No edit descriptor specified + IF (SIZE(x) == 0) THEN + SE%w = 0 + wid = 0 nbl = 0 - endif - end subroutine find_editdesc_dble + RETURN + END IF + IF (ANY(xfinite)) THEN + xp = MAXVAL(x, mask=xfinite) + xm = MINVAL(x, mask=xfinite) + WRITE (f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1 + WRITE (s, f1) xp; READ (s(dmx + 4:dmx + 8), '(I5)') expmax + WRITE (s, f1) xm; READ (s(dmx + 4:dmx + 8), '(I5)') expmin + CALL find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0) + IF (.NOT. ALL(xfinite)) ww = MAX(ww, 4) + IF (SE%lzas > 0 .AND. ANY(x == 0._DBLE)) ww = MAX(ww, SE%lzas) + IF (SE%ed(5:5) == 'F') THEN ! (*) + WRITE (s, SE%ed) xp; IF (s(1:1) == '*') ww = ww + 1 + WRITE (s, SE%ed) xm; IF (s(1:1) == '*') ww = ww + 1 + WRITE (SE%ed(6:10), '(SS,I2,".",I2)') ww, dd + END IF + ELSE + ww = 4 + SE%ed = '(F4.0)' + END IF + SE%w = ww + END IF + IF (SE%trm) THEN + xmaxv = MAXVAL(x, 1, mask=xfinite) ! max in each column + xminv = MINVAL(x, 1, mask=xfinite) ! min + xzero = ANY(x == 0._DBLE, 1) ! true where column has some zeros + xallz = ALL(x == 0._DBLE, 1) ! true where column has only zeros + xnonn = ANY(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan) + xalln = ALL(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan) + CALL getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ELSE + wid = SE%w + nbl = 0 + END IF +END SUBROUTINE find_editdesc_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) + ! determine length of the strings that result when writing with edit descriptor SE%ed a + ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output + REAL(dble), INTENT(in) :: xmaxv(:), xminv(:) ! max and min values in each column + LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros + LOGICAL, INTENT(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals + TYPE(settings), INTENT(in) :: SE ! settings + INTEGER, INTENT(out) :: wid(:) ! widths of columns + INTEGER, INTENT(out) :: nbl(:) ! number of blanks to peel from left (w-wid) + CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv)) + INTEGER w + w = SE%w + WRITE (stmin, SE%ed) xminv + WRITE (stmax, SE%ed) xmaxv + nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank + nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1)) + IF (SE%gedit) THEN + wid = w + ELSE + wid = LEN_TRIM(ADJUSTL(stmin)) + wid = MAX(wid, LEN_TRIM(ADJUSTL(stmax))) + END IF + IF (SE%lzas > 0) THEN + wid = MERGE(SE%lzas, wid, xallz) + wid = MAX(wid, MERGE(SE%lzas, 0, xzero)) + END IF + wid = MERGE(4, wid, xalln) + wid = MAX(wid, MERGE(4, 0, xnonn)) + nbl = w - wid +END SUBROUTINE getwid_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION tostring_s_dble(x) RESULT(st) + ! Scalar to string + REAL(dble), INTENT(in) :: x + CHARACTER(len_f_dble((/x/), tosset0%rfmt)) :: st + st = tostring_f_dble((/x/), tosset0%rfmt) +END FUNCTION tostring_s_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION tostring_sf_dble(x, fmt) RESULT(st) + ! Scalar with specified format to string + REAL(dble), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_dble((/x/), fmt)) :: st + st = tostring_f_dble((/x/), fmt) +END FUNCTION tostring_sf_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION tostring_dble(x) RESULT(st) + ! Vector to string + REAL(dble), INTENT(in) :: x(:) + CHARACTER(len_f_dble(x, tosset0%rfmt)) :: st + st = tostring_f_dble(x, tosset0%rfmt) +END FUNCTION tostring_dble + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +FUNCTION tostring_f_dble(x, fmt) RESULT(st) + ! Vector with specified format to string + REAL(dble), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_dble(x, fmt)) :: st + CHARACTER(widthmax_dble(x, fmt)) :: sa(SIZE(x)) + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + INTEGER :: w, d, ww + LOGICAL :: gedit + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN + st = errormsg + RETURN + ELSEIF (w == 0) THEN + ww = maxw_dble(x, d) + CALL replace_w(fmt1, ww) + END IF + WRITE (sa, fmt1) x + CALL trim_real(sa, gedit, w) + CALL tostring_get(sa, st) +END FUNCTION tostring_f_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - subroutine getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl) - ! determine length of the strings that result when writing with edit descriptor SE%ed a - ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output - real(dble), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column - logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros - logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals - type(settings), intent(in) :: SE ! settings - integer, intent(out) :: wid(:) ! widths of columns - integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid) - character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv)) - integer w - w = SE%w - write(stmin, SE%ed) xminv - write(stmax, SE%ed) xmaxv - nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank - nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1)) - if (SE%gedit) then - wid = w - else - wid = len_trim(adjustl(stmin)) - wid = max(wid, len_trim(adjustl(stmax))) - endif - if (SE%lzas > 0) then - wid = merge(SE%lzas, wid, xallz) - wid = max(wid, merge(SE%lzas, 0, xzero)) - endif - wid = merge(4, wid, xalln) - wid = max(wid, merge(4, 0, xnonn)) - nbl = w - wid - end subroutine getwid_dble - - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - function tostring_s_dble(x) result(st) - ! Scalar to string - real(dble), intent(in) :: x - character(len_f_dble((/x/), tosset0%rfmt)) :: st - st = tostring_f_dble((/x/), tosset0%rfmt) - end function tostring_s_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - function tostring_sf_dble(x, fmt) result(st) - ! Scalar with specified format to string - real(dble), intent(in) :: x - character(*), intent(in) :: fmt - character(len_f_dble((/x/), fmt)) :: st - st = tostring_f_dble((/x/), fmt) - end function tostring_sf_dble +PURE FUNCTION len_f_dble(x, fmt) RESULT(wtot) + ! Total length of returned string, vector s + REAL(dble), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(widthmax_dble(x, fmt)) :: sa(SIZE(x)) + INTEGER :: wtot, w, d, ww + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + IF (w == 0) THEN + ww = maxw_dble(x, d) + CALL replace_w(fmt1, ww) + END IF + WRITE (sa, fmt1) x + CALL trim_real(sa, gedit, w) + wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen) +END FUNCTION len_f_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - function tostring_dble(x) result(st) - ! Vector to string - real(dble), intent(in) :: x(:) - character(len_f_dble(x, tosset0%rfmt)) :: st - st = tostring_f_dble(x, tosset0%rfmt) - end function tostring_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - function tostring_f_dble(x, fmt) result(st) - ! Vector with specified format to string - real(dble) , intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_dble(x, fmt)) :: st - character(widthmax_dble(x, fmt)) :: sa(size(x)) - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - integer :: w, d, ww - logical :: gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then - st = errormsg - return - elseif (w == 0) then - ww = maxw_dble(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - call tostring_get(sa, st) - end function tostring_f_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - pure function len_f_dble(x, fmt) result(wtot) - ! Total length of returned string, vector s - real(dble), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(widthmax_dble(x, fmt)) :: sa(size(x)) - integer :: wtot, w, d, ww - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - if (w == 0) then - ww = maxw_dble(x, d) - call replace_w(fmt1, ww) - endif - write(sa, fmt1) x - call trim_real(sa, gedit, w) - wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen) - end function len_f_dble - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - pure function widthmax_dble(x, fmt) result(w) - ! Maximum width of an element of x - real(dble), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(nnblk(fmt)+5) :: fmt1 - integer w, d - logical gedit - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then ! illegal format, use 1 - w = 1 - elseif (w == 0) then - w = maxw_dble(x, d) - endif - end function widthmax_dble - +PURE FUNCTION widthmax_dble(x, fmt) RESULT(w) + ! Maximum width of an element of x + REAL(dble), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(nnblk(fmt) + 5) :: fmt1 + INTEGER w, d + LOGICAL gedit + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN ! illegal format, use 1 + w = 1 + ELSEIF (w == 0) THEN + w = maxw_dble(x, d) + END IF +END FUNCTION widthmax_dble !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - subroutine disp_s_cpld(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) - ! dbleruple precision complex scalar without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim - complex(dble), intent(in) :: x - integer, intent(in), optional :: unit, digmax +SUBROUTINE disp_s_cpld(x, fmt, fmt_imag, advance, digmax, sep, trim, unit) + ! dbleruple precision complex scalar without title + CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, trim + COMPLEX(dble), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax call disp_ts_cpld('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit) - end subroutine disp_s_cpld +END SUBROUTINE disp_s_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_v_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! dbleruple precision complex vector without title + ! dbleruple precision complex vector without title character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(dble), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax + COMPLEX(dble), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax call disp_tv_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - end subroutine disp_v_cpld +END SUBROUTINE disp_v_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_m_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! dbleruple precision complex matrix without title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(dble), intent(in) :: x(:,:) - integer, intent(in), optional :: unit, digmax, lbound(:) + ! dbleruple precision complex matrix without title +CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim + COMPLEX(dble), INTENT(in) :: x(:, :) + INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:) call disp_tm_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - end subroutine disp_m_cpld +END SUBROUTINE disp_m_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_ts_cpld(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit) - ! dbleruple precision complex scalar with title - character(*), intent(in) :: title - character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim - complex(dble), intent(in) :: x - integer, intent(in), optional :: unit, digmax - call disp_tm_cpld(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, & - & advance, digmax, sep=sep, style=style, trim=trim, unit=unit) - end subroutine disp_ts_cpld + ! dbleruple precision complex scalar with title + CHARACTER(*), INTENT(in) :: title +CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim + COMPLEX(dble), INTENT(in) :: x + INTEGER, INTENT(in), OPTIONAL :: unit, digmax + CALL disp_tm_cpld(title, RESHAPE((/x/), (/1, 1/)), fmt, fmt_imag, & + & advance, digmax, sep=sep, style=style, trim=trim, unit=unit) +END SUBROUTINE disp_ts_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_tv_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient) - ! dbleruple precision complex vector with title - character(*), intent(in) :: title + ! dbleruple precision complex vector with title + CHARACTER(*), INTENT(in) :: title character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient - complex(dble), intent(in) :: x(:) - integer, intent(in), optional :: unit, lbound(:), digmax - type(settings) SE, SEim + COMPLEX(dble), INTENT(in) :: x(:) + INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax + TYPE(settings) SE, SEim call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return; - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - if (SE%row) then - call disp_cpld(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x)) - else - call disp_cpld(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1) - end if - end subroutine disp_tv_cpld + IF (PRESENT(fmt_imag)) THEN + IF (.NOT. PRESENT(fmt)) THEN + CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN; + END IF + CALL get_SE(SEim, title, SHAPE(x), fmt_imag) + ELSE + SEim = SE + END IF + IF (SE%row) THEN + CALL disp_cpld(title, RESHAPE(x, (/1, SIZE(x)/)), SE, SEim, n=SIZE(x)) + ELSE + CALL disp_cpld(title, RESHAPE(x, (/SIZE(x), 1/)), SE, SEim, n=1) + END IF +END SUBROUTINE disp_tv_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- subroutine disp_tm_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit) - ! dbleruple precision complex matrix with title - character(*), intent(in) :: title ! The title to use for the matrix - complex(dble), intent(in) :: x(:,:) ! The matrix to be written - character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag & - ! ! is present) - character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element - integer, intent(in), optional :: unit ! Unit to display on - integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) & - ! ! and aimag(x) - character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' - character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ") - character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below - character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no - ! ! trimming, 'yes' for trimming - integer, intent(in), optional :: lbound(:) ! Lower bounds of x - ! - type(settings) :: SE, SEim + ! dbleruple precision complex matrix with title + CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix + COMPLEX(dble), INTENT(in) :: x(:, :) ! The matrix to be written + CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Edit descriptor for each element (real element when fmt_imag & + ! ! is present) + CHARACTER(*), INTENT(in), OPTIONAL :: fmt_imag ! Edit descriptor for each imaginary element + INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on + INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in real(x) & + ! ! and aimag(x) + CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes' + CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ") + CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below + CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no + ! ! trimming, 'yes' for trimming + INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x + ! + TYPE(settings) :: SE, SEim call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax) - if (present(fmt_imag)) then - if (.not.present(fmt)) then - call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return - endif - call get_SE(SEim, title, shape(x), fmt_imag) - else - SEim = SE - end if - call disp_cpld(title, x, SE, SEim, n = size(x,2)) - end subroutine disp_tm_cpld - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - - subroutine disp_cpld(title, x, SE, SEim, n) - ! dbleruple precision item - character(*), intent(in) :: title - complex(dble), intent(in) :: x(:,:) - type(settings), intent(INOUT ) :: SE, SEim - integer, intent(in) :: n - integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n) - call find_editdesc_dble(real(x), SE, widre, nblre) ! determine also SE%w - call find_editdesc_dble(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w + IF (PRESENT(fmt_imag)) THEN + IF (.NOT. PRESENT(fmt)) THEN + CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN + END IF + CALL get_SE(SEim, title, SHAPE(x), fmt_imag) + ELSE + SEim = SE + END IF + CALL disp_cpld(title, x, SE, SEim, n=SIZE(x, 2)) +END SUBROUTINE disp_tm_cpld + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE disp_cpld(title, x, SE, SEim, n) + ! dbleruple precision item + CHARACTER(*), INTENT(in) :: title + COMPLEX(dble), INTENT(in) :: x(:, :) + TYPE(settings), INTENT(INOUT) :: SE, SEim + INTEGER, INTENT(in) :: n + INTEGER, DIMENSION(n) :: widre(n), widim(n), nblre(n), nblim(n) + CALL find_editdesc_dble(REAL(x), SE, widre, nblre) ! determine also SE%w + CALL find_editdesc_dble(ABS(AIMAG(x)), SEim, widim, nblim) ! determine also SEim%w call tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2)) - end subroutine disp_cpld +END SUBROUTINE disp_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - subroutine tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) - ! Write dbleruple precision complex matrix to box - character(*), intent(in) :: title - complex(dble), intent(in) :: x(:,:) - integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) - type(settings), intent(INOUT ) :: SE, SEim - character(SE%w) :: s(m) - character(SEim%w) :: sim(m) - character(3) :: sgn(m) - integer :: lin1, i, j, wleft, wid(n), widp(n) - character, pointer :: boxp(:,:) - SE%zas = '' - SEim%zas = '' - wid = widre + widim + 4 - call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) - do j=1,n - if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m) +SUBROUTINE tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m, n) + ! Write dbleruple precision complex matrix to box + CHARACTER(*), INTENT(in) :: title + COMPLEX(dble), INTENT(in) :: x(:, :) + INTEGER, INTENT(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:) + TYPE(settings), INTENT(INOUT) :: SE, SEim + CHARACTER(SE%w) :: s(m) + CHARACTER(SEim%w) :: sim(m) + CHARACTER(3) :: sgn(m) + INTEGER :: lin1, i, j, wleft, wid(n), widp(n) + CHARACTER, POINTER :: boxp(:, :) + SE%zas = '' + SEim%zas = '' + wid = widre + widim + 4 + CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp) + DO j = 1, n + IF (m > 0) WRITE (s, SE%ed) (REAL(x(i, j)), i=1, m) call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft) - do i=1,m - if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif - enddo - call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft) - if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m) - call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) - call copyseptobox('i', m, lin1, boxp, wleft) - if (j 0) WRITE (sim, SEim%ed) (ABS(AIMAG(x(i, j))), i=1, m) + CALL copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft) + CALL copyseptobox('i', m, lin1, boxp, wleft) + IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft) + END DO + CALL finishbox(title, SE, boxp) +END SUBROUTINE tobox_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - function tostring_s_cpld(x) result(st) - complex(dble), intent(in) :: x - character(len_s_cpld(x, tosset0%rfmt)) :: st - st = tostring_f_cpld((/x/), tosset0%rfmt) - end function tostring_s_cpld +FUNCTION tostring_s_cpld(x) RESULT(st) + COMPLEX(dble), INTENT(in) :: x + CHARACTER(len_s_cpld(x, tosset0%rfmt)) :: st + st = tostring_f_cpld((/x/), tosset0%rfmt) +END FUNCTION tostring_s_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - function tostring_sf_cpld(x, fmt) result(st) - complex(dble), intent(in) :: x - character(*), intent(in) :: fmt - character(len_s_cpld(x, fmt)) :: st - st = tostring_f_cpld((/x/), fmt) - end function tostring_sf_cpld +FUNCTION tostring_sf_cpld(x, fmt) RESULT(st) + COMPLEX(dble), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_s_cpld(x, fmt)) :: st + st = tostring_f_cpld((/x/), fmt) +END FUNCTION tostring_sf_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - function tostring_cpld(x) result(st) - complex(dble), intent(in) :: x(:) - character(len_f_cpld(x, tosset0%rfmt)) :: st - st = tostring_f_cpld(x, tosset0%rfmt) - end function tostring_cpld +FUNCTION tostring_cpld(x) RESULT(st) + COMPLEX(dble), INTENT(in) :: x(:) + CHARACTER(len_f_cpld(x, tosset0%rfmt)) :: st + st = tostring_f_cpld(x, tosset0%rfmt) +END FUNCTION tostring_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - function tostring_f_cpld(x, fmt) result(st) - complex(dble), intent(in) :: x(:) - character(*), intent(in) :: fmt - character(len_f_cpld(x, fmt)) :: st - character(widthmax_dble(real(x), fmt)) :: sar(size(x)) - character(widthmax_dble(abs(x-real(x)), fmt)) :: sai(size(x)) ! x-real(x) instead of aimag(x) to enable the fnction - character(1) :: sgn(size(x)) ! to pass -stand:f95 switch of the ifort compiler. - integer :: w, d, wr, wi, i - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w) - real(dble) :: xre(size(x)), xim(size(x)), h - call readfmt(fmt, fmt1, w, d, gedit) - xre = real(x) - xim = aimag(x) - h = huge(h) - if (w < 0) then - st = errormsg - return - elseif (w == 0) then - wr = maxw_dble(xre, d) - wi = maxw_dble(xim, d) - call replace_w(fmt1, max(wr, wi)) - endif - write(sar, fmt1) real(x) - write(sai, fmt1) abs(aimag(x)) - call trim_real(sar, gedit, w) - call trim_real(sai, gedit, w) - do i = 1,size(x); if (aimag(x(i)) < 0) then; sgn(i) = '-'; else; sgn(i) = '+'; endif; enddo - call tostring_get_complex(sar, sgn, sai, st) - end function tostring_f_cpld +FUNCTION tostring_f_cpld(x, fmt) RESULT(st) + COMPLEX(dble), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + CHARACTER(len_f_cpld(x, fmt)) :: st + CHARACTER(widthmax_dble(REAL(x), fmt)) :: sar(SIZE(x)) + CHARACTER(widthmax_dble(ABS(x - REAL(x)), fmt)) :: sai(SIZE(x)) ! x-real(x) instead of aimag(x) to enable the fnction + CHARACTER(1) :: sgn(SIZE(x)) ! to pass -stand:f95 switch of the ifort compiler. + INTEGER :: w, d, wr, wi, i + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w) + REAL(dble) :: xre(SIZE(x)), xim(SIZE(x)), h + CALL readfmt(fmt, fmt1, w, d, gedit) + xre = REAL(x) + xim = AIMAG(x) + h = HUGE(h) + IF (w < 0) THEN + st = errormsg + RETURN + ELSEIF (w == 0) THEN + wr = maxw_dble(xre, d) + wi = maxw_dble(xim, d) + CALL replace_w(fmt1, MAX(wr, wi)) + END IF + WRITE (sar, fmt1) REAL(x) + WRITE (sai, fmt1) ABS(AIMAG(x)) + CALL trim_real(sar, gedit, w) + CALL trim_real(sai, gedit, w) + DO i = 1, SIZE(x); IF (AIMAG(x(i)) < 0) THEN; sgn(i) = '-'; ELSE; sgn(i) = '+'; END IF; END DO + CALL tostring_get_complex(sar, sgn, sai, st) +END FUNCTION tostring_f_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - pure function len_s_cpld(x, fmt) result(wtot) - complex(dble), intent(in) :: x - character(*), intent(in) :: fmt - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - wtot = len_f_dble((/real(x)/), fmt) + len_f_dble((/abs(aimag(x))/), fmt) + 4 - end function len_s_cpld +PURE FUNCTION len_s_cpld(x, fmt) RESULT(wtot) + COMPLEX(dble), INTENT(in) :: x + CHARACTER(*), INTENT(in) :: fmt + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + wtot = len_f_dble((/REAL(x)/), fmt) + len_f_dble((/ABS(AIMAG(x))/), fmt) + 4 +END FUNCTION len_s_cpld !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- - pure function len_f_cpld(x, fmt) result(wtot) - complex(dble), intent(in) :: x(:) - character(*), intent(in) :: fmt - integer :: wtot, w, d - logical :: gedit - character(nnblk(fmt)+8) :: fmt1 - call readfmt(fmt, fmt1, w, d, gedit) - if (w < 0) then; wtot = len(errormsg); return; endif - wtot = len_f_dble(real(x), fmt) + len_f_dble(abs(aimag(x)), fmt) & - & + size(x)*4 - (size(x) - 1)*(tosset0%seplen) - ! subtract seplen because it has been added twice in len_f_dble - end function len_f_cpld +PURE FUNCTION len_f_cpld(x, fmt) RESULT(wtot) + COMPLEX(dble), INTENT(in) :: x(:) + CHARACTER(*), INTENT(in) :: fmt + INTEGER :: wtot, w, d + LOGICAL :: gedit + CHARACTER(nnblk(fmt) + 8) :: fmt1 + CALL readfmt(fmt, fmt1, w, d, gedit) + IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF + wtot = len_f_dble(REAL(x), fmt) + len_f_dble(ABS(AIMAG(x)), fmt) & + & + SIZE(x) * 4 - (SIZE(x) - 1) * (tosset0%seplen) + ! subtract seplen because it has been added twice in len_f_dble +END FUNCTION len_f_cpld END MODULE DISP_R8MOD diff --git a/src/modules/Display/src/disp/putstrmodule.F90 b/src/modules/Display/src/disp/putstrmodule.F90 index 62823a946..2be3ccc06 100644 --- a/src/modules/Display/src/disp/putstrmodule.F90 +++ b/src/modules/Display/src/disp/putstrmodule.F90 @@ -1,25 +1,25 @@ MODULE PUTSTRMODULE ! DUMMY VERSION - ! An auxilliary module that accompanies DISPMODULE. This module contains dummy versions of the - ! subroutines putstr and putnl that do nothing. It is needed to avoid an "undefined symbol" link - ! error for these. In addition it defines the named constant (or parameter) DEFAULT_UNIT = -3, - ! which makes the asterisk unit (usually the screen) the default to display on. - ! - ! The purpose of having this module is to make displaying possible in situations where ordinary - ! print- and write-statements do not work. Then this module should be replaced by one defining - ! functional versions of putstr and putnl. An example is given by the commented out PUTSTRMODULE - ! for Matlab mex files below. - ! - integer, parameter :: DEFAULT_UNIT = -3 - ! +! An auxilliary module that accompanies DISPMODULE. This module contains dummy versions of the +! subroutines putstr and putnl that do nothing. It is needed to avoid an "undefined symbol" link +! error for these. In addition it defines the named constant (or parameter) DEFAULT_UNIT = -3, +! which makes the asterisk unit (usually the screen) the default to display on. +! +! The purpose of having this module is to make displaying possible in situations where ordinary +! print- and write-statements do not work. Then this module should be replaced by one defining +! functional versions of putstr and putnl. An example is given by the commented out PUTSTRMODULE +! for Matlab mex files below. +! +INTEGER, PARAMETER :: DEFAULT_UNIT = -3 +! CONTAINS - subroutine putstr(s) - character(*), intent(in) :: s - integer ldummy, ldummy1 ! these variables exist to avoid unused variable warnings - ldummy = len(s) - ldummy1 = ldummy - ldummy = ldummy1 - end subroutine putstr +SUBROUTINE putstr(s) + CHARACTER(*), INTENT(in) :: s + INTEGER ldummy, ldummy1 ! these variables exist to avoid unused variable warnings + ldummy = LEN(s) + ldummy1 = ldummy + ldummy = ldummy1 +END SUBROUTINE putstr - subroutine putnl() - end subroutine putnl +SUBROUTINE putnl() +END SUBROUTINE putnl END MODULE PUTSTRMODULE diff --git a/src/modules/FACE/src/face.F90 b/src/modules/FACE/src/face.F90 index 385355136..09242bda0 100644 --- a/src/modules/FACE/src/face.F90 +++ b/src/modules/FACE/src/face.F90 @@ -1,287 +1,287 @@ !< FACE, Fortran Ansi Colors Environment. -module face +MODULE face !< FACE, Fortran Ansi Colors Environment. -use, intrinsic :: iso_fortran_env, only: int32 +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT32 -implicit none -private -public :: colorize -public :: colors_samples -public :: styles_samples -public :: ASCII -public :: UCS4 +IMPLICIT NONE +PRIVATE +PUBLIC :: colorize +PUBLIC :: colors_samples +PUBLIC :: styles_samples +PUBLIC :: ASCII +PUBLIC :: UCS4 -interface colorize +INTERFACE colorize #if defined ASCII_SUPPORTED && defined ASCII_NEQ_DEFAULT - module procedure colorize_ascii - module procedure colorize_default + MODULE PROCEDURE colorize_ascii + MODULE PROCEDURE colorize_default #else - module procedure colorize_default + MODULE PROCEDURE colorize_default #endif #ifdef UCS4_SUPPORTED - module procedure colorize_ucs4 + MODULE PROCEDURE colorize_ucs4 #endif -endinterface +end interface ! kind parameters #ifdef ASCII_SUPPORTED -integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind. +INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('ascii') !< ASCII character set kind. #else -integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind. +INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('default') !< ASCII character set kind. #endif #ifdef UCS4_SUPPORTED -integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind. +INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('iso_10646') !< Unicode character set kind. #else -integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind. +INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('default') !< Unicode character set kind. #endif ! parameters -character(26), parameter :: UPPER_ALPHABET='ABCDEFGHIJKLMNOPQRSTUVWXYZ' !< Upper case alphabet. -character(26), parameter :: LOWER_ALPHABET='abcdefghijklmnopqrstuvwxyz' !< Lower case alphabet. -character(1), parameter :: NL=new_line('a') !< New line character. -character(1), parameter :: ESCAPE=achar(27) !< "\" character. +CHARACTER(26), PARAMETER :: UPPER_ALPHABET = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' !< Upper case alphabet. +CHARACTER(26), PARAMETER :: LOWER_ALPHABET = 'abcdefghijklmnopqrstuvwxyz' !< Lower case alphabet. +CHARACTER(1), PARAMETER :: NL = NEW_LINE('a') !< New line character. +CHARACTER(1), PARAMETER :: ESCAPE = ACHAR(27) !< "\" character. ! codes -character(2), parameter :: CODE_START=ESCAPE//'[' !< Start ansi code, "\[". -character(1), parameter :: CODE_END='m' !< End ansi code, "m". -character(4), parameter :: CODE_CLEAR=CODE_START//'0'//CODE_END !< Clear all styles, "\[0m". +CHARACTER(2), PARAMETER :: CODE_START = ESCAPE//'[' !< Start ansi code, "\[". +CHARACTER(1), PARAMETER :: CODE_END = 'm' !< End ansi code, "m". +CHARACTER(4), PARAMETER :: CODE_CLEAR = CODE_START//'0'//CODE_END !< Clear all styles, "\[0m". ! styles codes -character(17), parameter :: STYLES(1:2,1:16)=reshape([& - 'BOLD_ON ','1 ', & ! Bold on. - 'ITALICS_ON ','3 ', & ! Italics on. - 'UNDERLINE_ON ','4 ', & ! Underline on. - 'INVERSE_ON ','7 ', & ! Inverse on: reverse foreground and background colors. - 'STRIKETHROUGH_ON ','9 ', & ! Strikethrough on. - 'BOLD_OFF ','22 ', & ! Bold off. - 'ITALICS_OFF ','23 ', & ! Italics off. - 'UNDERLINE_OFF ','24 ', & ! Underline off. - 'INVERSE_OFF ','27 ', & ! Inverse off: reverse foreground and background colors. - 'STRIKETHROUGH_OFF','29 ', & ! Strikethrough off. - 'FRAMED_ON ','51 ', & ! Framed on. - 'ENCIRCLED_ON ','52 ', & ! Encircled on. - 'OVERLINED_ON ','53 ', & ! Overlined on. - 'FRAMED_OFF ','54 ', & ! Framed off. - 'ENCIRCLED_OFF ','54 ', & ! Encircled off. - 'OVERLINED_OFF ','55 ' & ! Overlined off. - ], [2,16]) !< Styles. +CHARACTER(17), PARAMETER :: STYLES(1:2, 1:16) = RESHAPE([ & + 'BOLD_ON ', '1 ', & ! Bold on. + 'ITALICS_ON ', '3 ', & ! Italics on. + 'UNDERLINE_ON ', '4 ', & ! Underline on. +'INVERSE_ON ', '7 ', & ! Inverse on: reverse foreground and background colors. + 'STRIKETHROUGH_ON ', '9 ', & ! Strikethrough on. + 'BOLD_OFF ', '22 ', & ! Bold off. + 'ITALICS_OFF ', '23 ', & ! Italics off. + 'UNDERLINE_OFF ', '24 ', & ! Underline off. +'INVERSE_OFF ', '27 ', & ! Inverse off: reverse foreground and background colors. + 'STRIKETHROUGH_OFF', '29 ', & ! Strikethrough off. + 'FRAMED_ON ', '51 ', & ! Framed on. + 'ENCIRCLED_ON ', '52 ', & ! Encircled on. + 'OVERLINED_ON ', '53 ', & ! Overlined on. + 'FRAMED_OFF ', '54 ', & ! Framed off. + 'ENCIRCLED_OFF ', '54 ', & ! Encircled off. + 'OVERLINED_OFF ', '55 ' & ! Overlined off. + ], [2, 16]) !< Styles. ! colors codes -character(15), parameter :: COLORS_FG(1:2,1:17)=reshape([& - 'BLACK ','30 ', & ! Black. - 'RED ','31 ', & ! Red. - 'GREEN ','32 ', & ! Green. - 'YELLOW ','33 ', & ! Yellow. - 'BLUE ','34 ', & ! Blue. - 'MAGENTA ','35 ', & ! Magenta. - 'CYAN ','36 ', & ! Cyan. - 'WHITE ','37 ', & ! White. - 'DEFAULT ','39 ', & ! Default (white). - 'BLACK_INTENSE ','90 ', & ! Black intense. - 'RED_INTENSE ','91 ', & ! Red intense. - 'GREEN_INTENSE ','92 ', & ! Green intense. - 'YELLOW_INTENSE ','93 ', & ! Yellow intense. - 'BLUE_INTENSE ','94 ', & ! Blue intense. - 'MAGENTA_INTENSE','95 ', & ! Magenta intense. - 'CYAN_INTENSE ','96 ', & ! Cyan intense. - 'WHITE_INTENSE ','97 ' & ! White intense. - ], [2,17]) !< Foreground colors. -character(15), parameter :: COLORS_BG(1:2,1:17)=reshape([& - 'BLACK ','40 ', & ! Black. - 'RED ','41 ', & ! Red. - 'GREEN ','42 ', & ! Green. - 'YELLOW ','43 ', & ! Yellow. - 'BLUE ','44 ', & ! Blue. - 'MAGENTA ','45 ', & ! Magenta. - 'CYAN ','46 ', & ! Cyan. - 'WHITE ','47 ', & ! White. - 'DEFAULT ','49 ', & ! Default (black). - 'BLACK_INTENSE ','100 ', & ! Black intense. - 'RED_INTENSE ','101 ', & ! Red intense. - 'GREEN_INTENSE ','102 ', & ! Green intense. - 'YELLOW_INTENSE ','103 ', & ! Yellow intense. - 'BLUE_INTENSE ','104 ', & ! Blue intense. - 'MAGENTA_INTENSE','105 ', & ! Magenta intense. - 'CYAN_INTENSE ','106 ', & ! Cyan intense. - 'WHITE_INTENSE ','107 ' & ! White intense. - ], [2,17]) !< Background colors. -contains - ! public procedures - subroutine colors_samples() - !< Print to standard output all colors samples. - integer(int32) :: c !< Counter. +CHARACTER(15), PARAMETER :: COLORS_FG(1:2, 1:17) = RESHAPE([ & + 'BLACK ', '30 ', & ! Black. + 'RED ', '31 ', & ! Red. + 'GREEN ', '32 ', & ! Green. + 'YELLOW ', '33 ', & ! Yellow. + 'BLUE ', '34 ', & ! Blue. + 'MAGENTA ', '35 ', & ! Magenta. + 'CYAN ', '36 ', & ! Cyan. + 'WHITE ', '37 ', & ! White. + 'DEFAULT ', '39 ', & ! Default (white). + 'BLACK_INTENSE ', '90 ', & ! Black intense. + 'RED_INTENSE ', '91 ', & ! Red intense. + 'GREEN_INTENSE ', '92 ', & ! Green intense. + 'YELLOW_INTENSE ', '93 ', & ! Yellow intense. + 'BLUE_INTENSE ', '94 ', & ! Blue intense. + 'MAGENTA_INTENSE', '95 ', & ! Magenta intense. + 'CYAN_INTENSE ', '96 ', & ! Cyan intense. + 'WHITE_INTENSE ', '97 ' & ! White intense. + ], [2, 17]) !< Foreground colors. +CHARACTER(15), PARAMETER :: COLORS_BG(1:2, 1:17) = RESHAPE([ & + 'BLACK ', '40 ', & ! Black. + 'RED ', '41 ', & ! Red. + 'GREEN ', '42 ', & ! Green. + 'YELLOW ', '43 ', & ! Yellow. + 'BLUE ', '44 ', & ! Blue. + 'MAGENTA ', '45 ', & ! Magenta. + 'CYAN ', '46 ', & ! Cyan. + 'WHITE ', '47 ', & ! White. + 'DEFAULT ', '49 ', & ! Default (black). + 'BLACK_INTENSE ', '100 ', & ! Black intense. + 'RED_INTENSE ', '101 ', & ! Red intense. + 'GREEN_INTENSE ', '102 ', & ! Green intense. + 'YELLOW_INTENSE ', '103 ', & ! Yellow intense. + 'BLUE_INTENSE ', '104 ', & ! Blue intense. + 'MAGENTA_INTENSE', '105 ', & ! Magenta intense. + 'CYAN_INTENSE ', '106 ', & ! Cyan intense. + 'WHITE_INTENSE ', '107 ' & ! White intense. + ], [2, 17]) !< Background colors. +CONTAINS +! public procedures +SUBROUTINE colors_samples() + !< Print to standard output all colors samples. + INTEGER(INT32) :: c !< Counter. - print '(A)', colorize('Foreground colors samples', color_fg='red_intense') - do c=1, size(COLORS_FG, dim=2) + PRINT '(A)', colorize('Foreground colors samples', color_fg='red_intense') + DO c = 1, SIZE(COLORS_FG, dim=2) print '(A)', ' colorize("'//COLORS_FG(1, c)//'", color_fg="'//COLORS_FG(1, c)//'") => '//& - colorize(COLORS_FG(1, c), color_fg=COLORS_FG(1, c))//& + colorize(COLORS_FG(1, c), color_fg=COLORS_FG(1, c))// & ' code: '//colorize(trim(COLORS_FG(2, c)), color_fg=COLORS_FG(1, c), style='inverse_on') - enddo - print '(A)', colorize('Background colors samples', color_fg='red_intense') - do c=1, size(COLORS_BG, dim=2) + END DO + PRINT '(A)', colorize('Background colors samples', color_fg='red_intense') + DO c = 1, SIZE(COLORS_BG, dim=2) print '(A)', ' colorize("'//COLORS_BG(1, c)//'", color_bg="'//COLORS_BG(1, c)//'") => '//& - colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))//& + colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))// & ' code: '//colorize(trim(COLORS_BG(2, c)), color_bg=COLORS_BG(1, c), style='inverse_on') - enddo - endsubroutine colors_samples + END DO +end subroutine colors_samples - subroutine styles_samples() - !< Print to standard output all styles samples. - integer(int32) :: s !< Counter. +SUBROUTINE styles_samples() + !< Print to standard output all styles samples. + INTEGER(INT32) :: s !< Counter. - print '(A)', colorize('Styles samples', color_fg='red_intense') - do s=1, size(STYLES, dim=2) + PRINT '(A)', colorize('Styles samples', color_fg='red_intense') + DO s = 1, SIZE(STYLES, dim=2) print '(A)', ' colorize("'//STYLES(1, s)//'", style="'//STYLES(1, s)//'") => '//& - colorize(STYLES(1, s), style=STYLES(1, s))//& + colorize(STYLES(1, s), style=STYLES(1, s))// & ' code: '//colorize(trim(STYLES(2, s)), color_fg='magenta', style='inverse_on') - enddo - endsubroutine styles_samples + END DO +end subroutine styles_samples - ! private procedures +! private procedures pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized) - !< Colorize and stylize strings, ASCII kind. - character(len=*, kind=ASCII), intent(in) :: string !< Input string. - character(len=*), intent(in), optional :: color_fg !< Foreground color definition. - character(len=*), intent(in), optional :: color_bg !< Background color definition. - character(len=*), intent(in), optional :: style !< Style definition. - character(len=:, kind=ASCII), allocatable :: colorized !< Colorized string. - character(len=:, kind=ASCII), allocatable :: buffer !< Temporary buffer. - integer(int32) :: i !< Counter. + !< Colorize and stylize strings, ASCII kind. + CHARACTER(len=*, kind=ASCII), INTENT(in) :: string !< Input string. + CHARACTER(len=*), INTENT(in), OPTIONAL :: color_fg !< Foreground color definition. + CHARACTER(len=*), INTENT(in), OPTIONAL :: color_bg !< Background color definition. + CHARACTER(len=*), INTENT(in), OPTIONAL :: style !< Style definition. + CHARACTER(len=:, kind=ASCII), ALLOCATABLE :: colorized !< Colorized string. + CHARACTER(len=:, kind=ASCII), ALLOCATABLE :: buffer !< Temporary buffer. + INTEGER(INT32) :: i !< Counter. - colorized = string - if (present(color_fg)) then - i = color_index(upper(color_fg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(color_bg)) then - i = color_index(upper(color_bg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(style)) then - i = style_index(upper(style)) - if (i>0) then - buffer = CODE_START//trim(STYLES(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - endfunction colorize_ascii + colorized = string + IF (PRESENT(color_fg)) THEN + i = color_index(upper(color_fg)) + IF (i > 0) THEN + buffer = CODE_START//TRIM(COLORS_FG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + END IF + END IF + IF (PRESENT(color_bg)) THEN + i = color_index(upper(color_bg)) + IF (i > 0) THEN + buffer = CODE_START//TRIM(COLORS_BG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + END IF + END IF + IF (PRESENT(style)) THEN + i = style_index(upper(style)) + IF (i > 0) THEN + buffer = CODE_START//TRIM(STYLES(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + END IF + END IF +end function colorize_ascii pure function colorize_default(string, color_fg, color_bg, style) result(colorized) - !< Colorize and stylize strings, DEFAULT kind. - character(len=*), intent(in) :: string !< Input string. - character(len=*), intent(in), optional :: color_fg !< Foreground color definition. - character(len=*), intent(in), optional :: color_bg !< Background color definition. - character(len=*), intent(in), optional :: style !< Style definition. - character(len=:), allocatable :: colorized !< Colorized string. - integer(int32) :: i !< Counter. + !< Colorize and stylize strings, DEFAULT kind. + CHARACTER(len=*), INTENT(in) :: string !< Input string. + CHARACTER(len=*), INTENT(in), OPTIONAL :: color_fg !< Foreground color definition. + CHARACTER(len=*), INTENT(in), OPTIONAL :: color_bg !< Background color definition. + CHARACTER(len=*), INTENT(in), OPTIONAL :: style !< Style definition. + CHARACTER(len=:), ALLOCATABLE :: colorized !< Colorized string. + INTEGER(INT32) :: i !< Counter. - colorized = string - if (present(color_fg)) then - i = color_index(upper(color_fg)) + colorized = string + IF (PRESENT(color_fg)) THEN + i = color_index(upper(color_fg)) if (i>0) colorized = CODE_START//trim(COLORS_FG(2, i))//CODE_END//colorized//CODE_CLEAR - endif - if (present(color_bg)) then - i = color_index(upper(color_bg)) + END IF + IF (PRESENT(color_bg)) THEN + i = color_index(upper(color_bg)) if (i>0) colorized = CODE_START//trim(COLORS_BG(2, i))//CODE_END//colorized//CODE_CLEAR - endif - if (present(style)) then - i = style_index(upper(style)) + END IF + IF (PRESENT(style)) THEN + i = style_index(upper(style)) if (i>0) colorized = CODE_START//trim(STYLES(2, i))//CODE_END//colorized//CODE_CLEAR - endif - endfunction colorize_default + END IF +end function colorize_default pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized) - !< Colorize and stylize strings, UCS4 kind. - character(len=*, kind=UCS4), intent(in) :: string !< Input string. - character(len=*), intent(in), optional :: color_fg !< Foreground color definition. - character(len=*), intent(in), optional :: color_bg !< Background color definition. - character(len=*), intent(in), optional :: style !< Style definition. - character(len=:, kind=UCS4), allocatable :: colorized !< Colorized string. - character(len=:, kind=UCS4), allocatable :: buffer !< Temporary buffer. - integer(int32) :: i !< Counter. + !< Colorize and stylize strings, UCS4 kind. + CHARACTER(len=*, kind=UCS4), INTENT(in) :: string !< Input string. + CHARACTER(len=*), INTENT(in), OPTIONAL :: color_fg !< Foreground color definition. + CHARACTER(len=*), INTENT(in), OPTIONAL :: color_bg !< Background color definition. + CHARACTER(len=*), INTENT(in), OPTIONAL :: style !< Style definition. + CHARACTER(len=:, kind=UCS4), ALLOCATABLE :: colorized !< Colorized string. + CHARACTER(len=:, kind=UCS4), ALLOCATABLE :: buffer !< Temporary buffer. + INTEGER(INT32) :: i !< Counter. - colorized = string - if (present(color_fg)) then - i = color_index(upper(color_fg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(color_bg)) then - i = color_index(upper(color_bg)) - if (i>0) then - buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - if (present(style)) then - i = style_index(upper(style)) - if (i>0) then - buffer = CODE_START//trim(STYLES(2, i))//CODE_END - colorized = buffer//colorized - buffer = CODE_CLEAR - colorized = colorized//buffer - endif - endif - endfunction colorize_ucs4 + colorized = string + IF (PRESENT(color_fg)) THEN + i = color_index(upper(color_fg)) + IF (i > 0) THEN + buffer = CODE_START//TRIM(COLORS_FG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + END IF + END IF + IF (PRESENT(color_bg)) THEN + i = color_index(upper(color_bg)) + IF (i > 0) THEN + buffer = CODE_START//TRIM(COLORS_BG(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + END IF + END IF + IF (PRESENT(style)) THEN + i = style_index(upper(style)) + IF (i > 0) THEN + buffer = CODE_START//TRIM(STYLES(2, i))//CODE_END + colorized = buffer//colorized + buffer = CODE_CLEAR + colorized = colorized//buffer + END IF + END IF +end function colorize_ucs4 - elemental function color_index(color) - !< Return the array-index corresponding to the queried color. - !< - !< @note Because Foreground and backround colors lists share the same name, no matter what array is used to find the color index. - !< Thus, the foreground array is used. - character(len=*), intent(in) :: color !< Color definition. - integer(int32) :: color_index !< Index into the colors arrays. - integer(int32) :: c !< Counter. +ELEMENTAL FUNCTION color_index(color) + !< Return the array-index corresponding to the queried color. + !< + !< @note Because Foreground and backround colors lists share the same name, no matter what array is used to find the color index. + !< Thus, the foreground array is used. + CHARACTER(len=*), INTENT(in) :: color !< Color definition. + INTEGER(INT32) :: color_index !< Index into the colors arrays. + INTEGER(INT32) :: c !< Counter. - color_index = 0 - do c=1, size(COLORS_FG, dim=2) - if (trim(COLORS_FG(1, c))==trim(adjustl(color))) then - color_index = c - exit - endif - enddo - endfunction color_index + color_index = 0 + DO c = 1, SIZE(COLORS_FG, dim=2) + IF (TRIM(COLORS_FG(1, c)) == TRIM(ADJUSTL(color))) THEN + color_index = c + EXIT + END IF + END DO +end function color_index - elemental function style_index(style) - !< Return the array-index corresponding to the queried style. - character(len=*), intent(in) :: style !< Style definition. - integer(int32) :: style_index !< Index into the styles array. - integer(int32) :: s !< Counter. +ELEMENTAL FUNCTION style_index(style) + !< Return the array-index corresponding to the queried style. + CHARACTER(len=*), INTENT(in) :: style !< Style definition. + INTEGER(INT32) :: style_index !< Index into the styles array. + INTEGER(INT32) :: s !< Counter. - style_index = 0 - do s=1, size(STYLES, dim=2) - if (trim(STYLES(1, s))==trim(adjustl(style))) then - style_index = s - exit - endif - enddo - endfunction style_index + style_index = 0 + DO s = 1, SIZE(STYLES, dim=2) + IF (TRIM(STYLES(1, s)) == TRIM(ADJUSTL(style))) THEN + style_index = s + EXIT + END IF + END DO +end function style_index - elemental function upper(string) - !< Return a string with all uppercase characters. - character(len=*), intent(in) :: string !< Input string. - character(len=len(string)) :: upper !< Upper case string. - integer :: n1 !< Characters counter. - integer :: n2 !< Characters counter. +ELEMENTAL FUNCTION upper(string) + !< Return a string with all uppercase characters. + CHARACTER(len=*), INTENT(in) :: string !< Input string. + CHARACTER(len=LEN(string)) :: upper !< Upper case string. + INTEGER :: n1 !< Characters counter. + INTEGER :: n2 !< Characters counter. - upper = string - do n1=1, len(string) - n2 = index(LOWER_ALPHABET, string(n1:n1)) - if (n2>0) upper(n1:n1) = UPPER_ALPHABET(n2:n2) - enddo - endfunction upper + upper = string + DO n1 = 1, LEN(string) + n2 = INDEX(LOWER_ALPHABET, string(n1:n1)) + IF (n2 > 0) upper(n1:n1) = UPPER_ALPHABET(n2:n2) + END DO +end function upper endmodule face diff --git a/src/modules/PENF/src/penf.F90 b/src/modules/PENF/src/penf.F90 index 720764b20..c444c6bb0 100644 --- a/src/modules/PENF/src/penf.F90 +++ b/src/modules/PENF/src/penf.F90 @@ -1,129 +1,129 @@ !< Portability Environment for Fortran poor people. -module penf +MODULE penf !< Portability Environment for Fortran poor people. -use penf_global_parameters_variables +USE penf_global_parameters_variables #ifdef __INTEL_COMPILER -use penf_b_size +USE penf_b_size #else -use penf_b_size, only : bit_size, byte_size +USE penf_b_size, ONLY: bit_size, byte_size #endif -use penf_stringify, only : str_ascii, str_ucs4, str, strz, cton, bstr, bcton +USE penf_stringify, ONLY: str_ascii, str_ucs4, str, strz, cton, bstr, bcton -implicit none -private -save +IMPLICIT NONE +PRIVATE +SAVE ! global parameters and variables -public :: endianL, endianB, endian, is_initialized -public :: ASCII, UCS4, CK +PUBLIC :: endianL, endianB, endian, is_initialized +PUBLIC :: ASCII, UCS4, CK public :: R16P, FR16P, DR16P, MinR16P, MaxR16P, BIR16P, BYR16P, smallR16P, ZeroR16P -public :: R8P, FR8P, DR8P, MinR8P, MaxR8P, BIR8P, BYR8P, smallR8P, ZeroR8P -public :: R4P, FR4P, DR4P, MinR4P, MaxR4P, BIR4P, BYR4P, smallR4P, ZeroR4P -public :: R_P, FR_P, DR_P, MinR_P, MaxR_P, BIR_P, BYR_P, smallR_P, ZeroR_P -public :: I8P, FI8P, DI8P, MinI8P, MaxI8P, BII8P, BYI8P -public :: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P -public :: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P -public :: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P -public :: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P -public :: CHARACTER_KINDS_LIST, REAL_KINDS_LIST, REAL_FORMATS_LIST -public :: INTEGER_KINDS_LIST, INTEGER_FORMATS_LIST +PUBLIC :: R8P, FR8P, DR8P, MinR8P, MaxR8P, BIR8P, BYR8P, smallR8P, ZeroR8P +PUBLIC :: R4P, FR4P, DR4P, MinR4P, MaxR4P, BIR4P, BYR4P, smallR4P, ZeroR4P +PUBLIC :: R_P, FR_P, DR_P, MinR_P, MaxR_P, BIR_P, BYR_P, smallR_P, ZeroR_P +PUBLIC :: I8P, FI8P, DI8P, MinI8P, MaxI8P, BII8P, BYI8P +PUBLIC :: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P +PUBLIC :: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P +PUBLIC :: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P +PUBLIC :: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P +PUBLIC :: CHARACTER_KINDS_LIST, REAL_KINDS_LIST, REAL_FORMATS_LIST +PUBLIC :: INTEGER_KINDS_LIST, INTEGER_FORMATS_LIST ! bit/byte size functions -public :: bit_size, byte_size +PUBLIC :: bit_size, byte_size ! stringify facility -public :: str_ascii, str_ucs4 -public :: str, strz, cton -public :: bstr, bcton +PUBLIC :: str_ascii, str_ucs4 +PUBLIC :: str, strz, cton +PUBLIC :: bstr, bcton ! miscellanea facility -public :: check_endian -public :: digit -public :: penf_Init -public :: penf_print +PUBLIC :: check_endian +PUBLIC :: digit +PUBLIC :: penf_Init +PUBLIC :: penf_print -integer, protected :: endian = endianL !< Bit ordering: Little endian (endianL), or Big endian (endianB). -logical, protected :: is_initialized = .false. !< Check the initialization of some variables that must be initialized. +INTEGER, PROTECTED :: endian = endianL !< Bit ordering: Little endian (endianL), or Big endian (endianB). +LOGICAL, PROTECTED :: is_initialized = .FALSE. !< Check the initialization of some variables that must be initialized. #ifdef __GFORTRAN__ ! work-around for strange gfortran bug... -interface bit_size +INTERFACE bit_size !< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables. -endinterface +END INTERFACE #endif -interface digit +INTERFACE digit !< Compute the number of digits in decimal base of the input integer. - module procedure digit_I8, digit_I4, digit_I2, digit_I1 -endinterface - -contains - ! public procedures - subroutine check_endian() - !< Check the type of bit ordering (big or little endian) of the running architecture. - !< - !> @note The result is stored into the *endian* global variable. - !< - !<```fortran - !< use penf - !< call check_endian - !< print *, endian - !<``` - !=> 1 <<< - if (is_little_endian()) then - endian = endianL - else - endian = endianB - endif - contains - pure function is_little_endian() result(is_little) - !< Check if the type of the bit ordering of the running architecture is little endian. - logical :: is_little !< Logical output: true is the running architecture uses little endian ordering, false otherwise. - integer(I1P) :: int1(1:4) !< One byte integer array for casting 4 bytes integer. - - int1 = transfer(1_I4P, int1) - is_little = (int1(1)==1_I1P) - endfunction is_little_endian - endsubroutine check_endian - - subroutine penf_init() - !< Initialize PENF's variables that are not initialized into the definition specification. - !< - !<```fortran - !< use penf - !< call penf_init - !< print FI1P, BYR4P - !<``` - !=> 4 <<< - - call check_endian - is_initialized = .true. - endsubroutine penf_init - - subroutine penf_print(unit, pref, iostat, iomsg) - !< Print to the specified unit the PENF's environment data. - !< - !<```fortran - !< use penf - !< integer :: u - !< open(newunit=u, status='scratch') - !< call penf_print(u) - !< close(u) - !< print "(A)", 'done' - !<``` - !=> done <<< - integer(I4P), intent(in) :: unit !< Logic unit. - character(*), intent(in), optional :: pref !< Prefixing string. - integer(I4P), intent(out), optional :: iostat !< IO error. - character(*), intent(out), optional :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - - if (.not.is_initialized) call penf_init - prefd = '' ; if (present(pref)) prefd = pref - if (endian==endianL) then + MODULE PROCEDURE digit_I8, digit_I4, digit_I2, digit_I1 +END INTERFACE + +CONTAINS +! public procedures +SUBROUTINE check_endian() + !< Check the type of bit ordering (big or little endian) of the running architecture. + !< + !> @note The result is stored into the *endian* global variable. + !< + !<```fortran + !< use penf + !< call check_endian + !< print *, endian + !<``` + !=> 1 <<< + IF (is_little_endian()) THEN + endian = endianL + ELSE + endian = endianB + END IF +CONTAINS + PURE FUNCTION is_little_endian() RESULT(is_little) + !< Check if the type of the bit ordering of the running architecture is little endian. + LOGICAL :: is_little !< Logical output: true is the running architecture uses little endian ordering, false otherwise. + INTEGER(I1P) :: int1(1:4) !< One byte integer array for casting 4 bytes integer. + + int1 = TRANSFER(1_I4P, int1) + is_little = (int1(1) == 1_I1P) + END FUNCTION is_little_endian +END SUBROUTINE check_endian + +SUBROUTINE penf_init() + !< Initialize PENF's variables that are not initialized into the definition specification. + !< + !<```fortran + !< use penf + !< call penf_init + !< print FI1P, BYR4P + !<``` + !=> 4 <<< + + CALL check_endian + is_initialized = .TRUE. +END SUBROUTINE penf_init + +SUBROUTINE penf_print(unit, pref, iostat, iomsg) + !< Print to the specified unit the PENF's environment data. + !< + !<```fortran + !< use penf + !< integer :: u + !< open(newunit=u, status='scratch') + !< call penf_print(u) + !< close(u) + !< print "(A)", 'done' + !<``` + !=> done <<< + INTEGER(I4P), INTENT(in) :: unit !< Logic unit. + CHARACTER(*), INTENT(in), OPTIONAL :: pref !< Prefixing string. + INTEGER(I4P), INTENT(out), OPTIONAL :: iostat !< IO error. + CHARACTER(*), INTENT(out), OPTIONAL :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + + IF (.NOT. is_initialized) CALL penf_init + prefd = ''; IF (PRESENT(pref)) prefd = pref + IF (endian == endianL) THEN write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has LITTLE Endian bit ordering' - else + ELSE write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has BIG Endian bit ordering' - endif + END IF write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Character kind:' write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ASCII: '//str(n=ASCII) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' UCS4: '//str(n=UCS4) @@ -163,77 +163,77 @@ subroutine penf_print(unit, pref, iostat, iomsg) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR8P: '//str(smallR8P, .true.) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR4P: '//str(smallR4P, .true.) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR_P: '//str(smallR_P, .true.) - write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Machine zero' + write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Machine zero' write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR16P: '//str(ZeroR16P, .true.) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR8P: '//str(ZeroR8P, .true.) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR4P: '//str(ZeroR4P, .true.) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR_P: '//str(ZeroR_P, .true.) - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - endsubroutine penf_print - - ! private procedures - elemental function digit_I8(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I8P) - !<``` - !=> 3 <<< - integer(I8P), intent(in) :: n !< Input integer. - character(DI8P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI8P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I8 - - elemental function digit_I4(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I4P) - !<``` - !=> 3 <<< - integer(I4P), intent(in) :: n !< Input integer. - character(DI4P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI4P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I4 - - elemental function digit_I2(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I2P) - !<``` - !=> 3 <<< - integer(I2P), intent(in) :: n !< Input integer. - character(DI2P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI2P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I2 - - elemental function digit_I1(n) result(digit) - !< Compute the number of digits in decimal base of the input integer. - !< - !<```fortran - !< use penf - !< print FI4P, digit(100_I1P) - !<``` - !=> 3 <<< - integer(I1P), intent(in) :: n !< Input integer. - character(DI1P) :: str !< Returned string containing input number plus padding zeros. - integer(I4P) :: digit !< Number of digits. - - write(str, FI1P) abs(n) ! Casting of n to string. - digit = len_trim(adjustl(str)) ! Calculating the digits number of n. - endfunction digit_I1 + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE penf_print + +! private procedures +ELEMENTAL FUNCTION digit_I8(n) RESULT(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I8P) + !<``` + !=> 3 <<< + INTEGER(I8P), INTENT(in) :: n !< Input integer. + CHARACTER(DI8P) :: str !< Returned string containing input number plus padding zeros. + INTEGER(I4P) :: digit !< Number of digits. + + WRITE (str, FI8P) ABS(n) ! Casting of n to string. + digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n. +END FUNCTION digit_I8 + +ELEMENTAL FUNCTION digit_I4(n) RESULT(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I4P) + !<``` + !=> 3 <<< + INTEGER(I4P), INTENT(in) :: n !< Input integer. + CHARACTER(DI4P) :: str !< Returned string containing input number plus padding zeros. + INTEGER(I4P) :: digit !< Number of digits. + + WRITE (str, FI4P) ABS(n) ! Casting of n to string. + digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n. +END FUNCTION digit_I4 + +ELEMENTAL FUNCTION digit_I2(n) RESULT(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I2P) + !<``` + !=> 3 <<< + INTEGER(I2P), INTENT(in) :: n !< Input integer. + CHARACTER(DI2P) :: str !< Returned string containing input number plus padding zeros. + INTEGER(I4P) :: digit !< Number of digits. + + WRITE (str, FI2P) ABS(n) ! Casting of n to string. + digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n. +END FUNCTION digit_I2 + +ELEMENTAL FUNCTION digit_I1(n) RESULT(digit) + !< Compute the number of digits in decimal base of the input integer. + !< + !<```fortran + !< use penf + !< print FI4P, digit(100_I1P) + !<``` + !=> 3 <<< + INTEGER(I1P), INTENT(in) :: n !< Input integer. + CHARACTER(DI1P) :: str !< Returned string containing input number plus padding zeros. + INTEGER(I4P) :: digit !< Number of digits. + + WRITE (str, FI1P) ABS(n) ! Casting of n to string. + digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n. +END FUNCTION digit_I1 endmodule penf diff --git a/src/modules/PENF/src/penf_b_size.F90 b/src/modules/PENF/src/penf_b_size.F90 index 13054b874..ff3b61dc1 100644 --- a/src/modules/PENF/src/penf_b_size.F90 +++ b/src/modules/PENF/src/penf_b_size.F90 @@ -17,29 +17,29 @@ !< PENF bit/byte size functions. -module penf_b_size +MODULE penf_b_size !< PENF bit/byte size functions. -use penf_global_parameters_variables +USE penf_global_parameters_variables -implicit none -private -save -public :: bit_size, byte_size +IMPLICIT NONE +PRIVATE +SAVE +PUBLIC :: bit_size, byte_size -interface bit_size +INTERFACE bit_size !< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables. - module procedure & + MODULE PROCEDURE & #if defined _R16P bit_size_R16P, & #endif bit_size_R8P, & bit_size_R4P, & bit_size_chr -end interface +END INTERFACE -interface byte_size +INTERFACE byte_size !< Compute the number of bytes of a variable. - module procedure & + MODULE PROCEDURE & byte_size_I8P, & byte_size_I4P, & byte_size_I2P, & @@ -50,10 +50,10 @@ module penf_b_size byte_size_R8P, & byte_size_R4P, & byte_size_chr -end interface +END INTERFACE -contains -elemental function bit_size_R16P(i) result(bits) +CONTAINS +ELEMENTAL FUNCTION bit_size_R16P(i) RESULT(bits) !< Compute the number of bits of a real variable. !< !<```fortran @@ -61,14 +61,14 @@ elemental function bit_size_R16P(i) result(bits) !< print FI2P, bit_size(1._R16P) !<``` !=> 128 <<< - real(R16P), intent(in) :: i !< Real variable whose number of bits must be computed. - integer(I2P) :: bits !< Number of bits of r. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + REAL(R16P), INTENT(in) :: i !< Real variable whose number of bits must be computed. + INTEGER(I2P) :: bits !< Number of bits of r. + INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - bits = size(transfer(i, mold), dim=1, kind=I2P) * 8_I2P -end function bit_size_R16P + bits = SIZE(TRANSFER(i, mold), dim=1, kind=I2P) * 8_I2P +END FUNCTION bit_size_R16P -elemental function bit_size_R8P(i) result(bits) +ELEMENTAL FUNCTION bit_size_R8P(i) RESULT(bits) !< Compute the number of bits of a real variable. !< !<```fortran @@ -76,14 +76,14 @@ elemental function bit_size_R8P(i) result(bits) !< print FI1P, bit_size(1._R8P) !<``` !=> 64 <<< - real(R8P), intent(in) :: i !< Real variable whose number of bits must be computed. - integer(I1P) :: bits !< Number of bits of r. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + REAL(R8P), INTENT(in) :: i !< Real variable whose number of bits must be computed. + INTEGER(I1P) :: bits !< Number of bits of r. + INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P -end function bit_size_R8P + bits = SIZE(TRANSFER(i, mold), dim=1, kind=I1P) * 8_I1P +END FUNCTION bit_size_R8P -elemental function bit_size_R4P(i) result(bits) +ELEMENTAL FUNCTION bit_size_R4P(i) RESULT(bits) !< Compute the number of bits of a real variable. !< !<```fortran @@ -91,14 +91,14 @@ elemental function bit_size_R4P(i) result(bits) !< print FI1P, bit_size(1._R4P) !<``` !=> 32 <<< - real(R4P), intent(in) :: i !< Real variable whose number of bits must be computed. - integer(I1P) :: bits !< Number of bits of r. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + REAL(R4P), INTENT(in) :: i !< Real variable whose number of bits must be computed. + INTEGER(I1P) :: bits !< Number of bits of r. + INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P -end function bit_size_R4P + bits = SIZE(TRANSFER(i, mold), dim=1, kind=I1P) * 8_I1P +END FUNCTION bit_size_R4P -elemental function bit_size_chr(i) result(bits) +ELEMENTAL FUNCTION bit_size_chr(i) RESULT(bits) !< Compute the number of bits of a character variable. !< !<```fortran @@ -106,14 +106,14 @@ elemental function bit_size_chr(i) result(bits) !< print FI4P, bit_size('ab') !<``` !=> 16 <<< - character(*), intent(IN) :: i !< Character variable whose number of bits must be computed. - integer(I4P) :: bits !< Number of bits of c. - integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. + CHARACTER(*), INTENT(IN) :: i !< Character variable whose number of bits must be computed. + INTEGER(I4P) :: bits !< Number of bits of c. + INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting. - bits = size(transfer(i, mold), dim=1, kind=I4P) * 8_I4P -end function bit_size_chr + bits = SIZE(TRANSFER(i, mold), dim=1, kind=I4P) * 8_I4P +END FUNCTION bit_size_chr -elemental function byte_size_R16P(i) result(bytes) +ELEMENTAL FUNCTION byte_size_R16P(i) RESULT(bytes) !< Compute the number of bytes of a real variable. !< !<```fortran @@ -121,13 +121,13 @@ elemental function byte_size_R16P(i) result(bytes) !< print FI1P, byte_size(1._R16P) !<``` !=> 16 <<< - real(R16P), intent(in) :: i !< Real variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of r. + REAL(R16P), INTENT(in) :: i !< Real variable whose number of bytes must be computed. + INTEGER(I1P) :: bytes !< Number of bytes of r. - bytes = bit_size(i) / 8_I1P -end function byte_size_R16P + bytes = BIT_SIZE(i) / 8_I1P +END FUNCTION byte_size_R16P -elemental function byte_size_R8P(i) result(bytes) +ELEMENTAL FUNCTION byte_size_R8P(i) RESULT(bytes) !< Compute the number of bytes of a real variable. !< !<```fortran @@ -135,13 +135,13 @@ elemental function byte_size_R8P(i) result(bytes) !< print FI1P, byte_size(1._R8P) !<``` !=> 8 <<< - real(R8P), intent(in) :: i !< Real variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of r. + REAL(R8P), INTENT(in) :: i !< Real variable whose number of bytes must be computed. + INTEGER(I1P) :: bytes !< Number of bytes of r. - bytes = bit_size(i) / 8_I1P -end function byte_size_R8P + bytes = BIT_SIZE(i) / 8_I1P +END FUNCTION byte_size_R8P -elemental function byte_size_R4P(i) result(bytes) +ELEMENTAL FUNCTION byte_size_R4P(i) RESULT(bytes) !< Compute the number of bytes of a real variable. !< !<```fortran @@ -149,13 +149,13 @@ elemental function byte_size_R4P(i) result(bytes) !< print FI1P, byte_size(1._R4P) !<``` !=> 4 <<< - real(R4P), intent(in) :: i !< Real variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of r. + REAL(R4P), INTENT(in) :: i !< Real variable whose number of bytes must be computed. + INTEGER(I1P) :: bytes !< Number of bytes of r. - bytes = bit_size(i) / 8_I1P -end function byte_size_R4P + bytes = BIT_SIZE(i) / 8_I1P +END FUNCTION byte_size_R4P -elemental function byte_size_chr(i) result(bytes) +ELEMENTAL FUNCTION byte_size_chr(i) RESULT(bytes) !< Compute the number of bytes of a character variable. !< !<```fortran @@ -163,13 +163,13 @@ elemental function byte_size_chr(i) result(bytes) !< print FI1P, byte_size('ab') !<``` !=> 2 <<< - character(*), intent(in) :: i !< Character variable whose number of bytes must be computed. - integer(I4P) :: bytes !< Number of bytes of c. + CHARACTER(*), INTENT(in) :: i !< Character variable whose number of bytes must be computed. + INTEGER(I4P) :: bytes !< Number of bytes of c. - bytes = bit_size(i) / 8_I4P -end function byte_size_chr + bytes = BIT_SIZE(i) / 8_I4P +END FUNCTION byte_size_chr -elemental function byte_size_I8P(i) result(bytes) +ELEMENTAL FUNCTION byte_size_I8P(i) RESULT(bytes) !< Compute the number of bytes of an integer variable. !< !<```fortran @@ -177,13 +177,13 @@ elemental function byte_size_I8P(i) result(bytes) !< print FI1P, byte_size(1_I8P) !<``` !=> 8 <<< - integer(I8P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. + INTEGER(I8P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed. + INTEGER(I1P) :: bytes !< Number of bytes of i. - bytes = bit_size(i) / 8_I1P -end function byte_size_I8P + bytes = BIT_SIZE(i) / 8_I1P +END FUNCTION byte_size_I8P -elemental function byte_size_I4P(i) result(bytes) +ELEMENTAL FUNCTION byte_size_I4P(i) RESULT(bytes) !< Compute the number of bytes of an integer variable. !< !<```fortran @@ -191,13 +191,13 @@ elemental function byte_size_I4P(i) result(bytes) !< print FI1P, byte_size(1_I4P) !<``` !=> 4 <<< - integer(I4P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. + INTEGER(I4P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed. + INTEGER(I1P) :: bytes !< Number of bytes of i. - bytes = bit_size(i) / 8_I1P -end function byte_size_I4P + bytes = BIT_SIZE(i) / 8_I1P +END FUNCTION byte_size_I4P -elemental function byte_size_I2P(i) result(bytes) +ELEMENTAL FUNCTION byte_size_I2P(i) RESULT(bytes) !< Compute the number of bytes of an integer variable. !< !<```fortran @@ -205,13 +205,13 @@ elemental function byte_size_I2P(i) result(bytes) !< print FI1P, byte_size(1_I2P) !<``` !=> 2 <<< - integer(I2P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. + INTEGER(I2P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed. + INTEGER(I1P) :: bytes !< Number of bytes of i. - bytes = bit_size(i) / 8_I1P -end function byte_size_I2P + bytes = BIT_SIZE(i) / 8_I1P +END FUNCTION byte_size_I2P -elemental function byte_size_I1P(i) result(bytes) +ELEMENTAL FUNCTION byte_size_I1P(i) RESULT(bytes) !< Compute the number of bytes of an integer variable. !< !<```fortran @@ -219,9 +219,9 @@ elemental function byte_size_I1P(i) result(bytes) !< print FI1P, byte_size(1_I1P) !<``` !=> 1 <<< - integer(I1P), intent(in) :: i !< Integer variable whose number of bytes must be computed. - integer(I1P) :: bytes !< Number of bytes of i. + INTEGER(I1P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed. + INTEGER(I1P) :: bytes !< Number of bytes of i. - bytes = bit_size(i) / 8_I1P -end function byte_size_I1P + bytes = BIT_SIZE(i) / 8_I1P +END FUNCTION byte_size_I1P endmodule penf_b_size diff --git a/src/modules/PENF/src/penf_global_parameters_variables.F90 b/src/modules/PENF/src/penf_global_parameters_variables.F90 index 356764dc9..8ebe73820 100644 --- a/src/modules/PENF/src/penf_global_parameters_variables.F90 +++ b/src/modules/PENF/src/penf_global_parameters_variables.F90 @@ -1,213 +1,213 @@ !< PENF global parameters and variables. -module penf_global_parameters_variables +MODULE penf_global_parameters_variables !< PENF global parameters and variables. !< !< @note All module defined entities are public. -implicit none -public -save +IMPLICIT NONE +PUBLIC +SAVE -integer, parameter :: endianL = 1 !< Little endian parameter. -integer, parameter :: endianB = 0 !< Big endian parameter. +INTEGER, PARAMETER :: endianL = 1 !< Little endian parameter. +INTEGER, PARAMETER :: endianB = 0 !< Big endian parameter. ! portable kind parameters #ifdef _ASCII_SUPPORTED -integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind. +INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('ascii') !< ASCII character set kind. #else -integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind defined as default set. +INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('default') !< ASCII character set kind defined as default set. #endif #ifdef _UCS4_SUPPORTED -integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind. +INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('iso_10646') !< Unicode character set kind. #else -integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind defined as default set. +INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('default') !< Unicode character set kind defined as default set. #endif #if defined _CK_IS_DEFAULT -integer, parameter :: CK = selected_char_kind('default') !< Default kind character. +INTEGER, PARAMETER :: CK = SELECTED_CHAR_KIND('default') !< Default kind character. #elif defined _CK_IS_ASCII -integer, parameter :: CK = ASCII !< Default kind character. +INTEGER, PARAMETER :: CK = ASCII !< Default kind character. #elif defined _CK_IS_UCS4 -integer, parameter :: CK = UCS4 !< Default kind character. +INTEGER, PARAMETER :: CK = UCS4 !< Default kind character. #else -integer, parameter :: CK = selected_char_kind('default') !< Default kind character. +INTEGER, PARAMETER :: CK = SELECTED_CHAR_KIND('default') !< Default kind character. #endif #if defined _R16P -integer, parameter :: R16P = selected_real_kind(33,4931) !< 33 digits, range \([10^{-4931}, 10^{+4931} - 1]\); 128 bits. +INTEGER, PARAMETER :: R16P = SELECTED_REAL_KIND(33, 4931) !< 33 digits, range \([10^{-4931}, 10^{+4931} - 1]\); 128 bits. #else -integer, parameter :: R16P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. +INTEGER, PARAMETER :: R16P = SELECTED_REAL_KIND(15, 307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. #endif -integer, parameter :: R8P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. -integer, parameter :: R4P = selected_real_kind(6,37) !< 6 digits, range \([10^{-37} , 10^{+37} - 1]\); 32 bits. +INTEGER, PARAMETER :: R8P = SELECTED_REAL_KIND(15, 307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits. +INTEGER, PARAMETER :: R4P = SELECTED_REAL_KIND(6, 37) !< 6 digits, range \([10^{-37} , 10^{+37} - 1]\); 32 bits. #if defined _R16P #if defined _R_P_IS_R16P -integer, parameter :: R_P = R16P !< Default real precision. +INTEGER, PARAMETER :: R_P = R16P !< Default real precision. #endif #endif #if defined _R_P_IS_R8P -integer, parameter :: R_P = R8P !< Default real precision. +INTEGER, PARAMETER :: R_P = R8P !< Default real precision. #elif defined _R_P_IS_R4P -integer, parameter :: R_P = R4P !< Default real precision. +INTEGER, PARAMETER :: R_P = R4P !< Default real precision. #else -integer, parameter :: R_P = R8P !< Default real precision. +INTEGER, PARAMETER :: R_P = R8P !< Default real precision. #endif -integer, parameter :: I8P = selected_int_kind(18) !< Range \([-2^{63},+2^{63} - 1]\), 19 digits plus sign; 64 bits. -integer, parameter :: I4P = selected_int_kind(9) !< Range \([-2^{31},+2^{31} - 1]\), 10 digits plus sign; 32 bits. -integer, parameter :: I2P = selected_int_kind(4) !< Range \([-2^{15},+2^{15} - 1]\), 5 digits plus sign; 16 bits. -integer, parameter :: I1P = selected_int_kind(2) !< Range \([-2^{7} ,+2^{7} - 1]\), 3 digits plus sign; 8 bits. -integer, parameter :: I_P = I4P !< Default integer precision. +INTEGER, PARAMETER :: I8P = SELECTED_INT_KIND(18) !< Range \([-2^{63},+2^{63} - 1]\), 19 digits plus sign; 64 bits. +INTEGER, PARAMETER :: I4P = SELECTED_INT_KIND(9) !< Range \([-2^{31},+2^{31} - 1]\), 10 digits plus sign; 32 bits. +INTEGER, PARAMETER :: I2P = SELECTED_INT_KIND(4) !< Range \([-2^{15},+2^{15} - 1]\), 5 digits plus sign; 16 bits. +INTEGER, PARAMETER :: I1P = SELECTED_INT_KIND(2) !< Range \([-2^{7} ,+2^{7} - 1]\), 3 digits plus sign; 8 bits. +INTEGER, PARAMETER :: I_P = I4P !< Default integer precision. ! format parameters #if defined _R16P -character(*), parameter :: FR16P = '(E42.33E4)' !< Output format for kind=R16P real. +CHARACTER(*), PARAMETER :: FR16P = '(E42.33E4)' !< Output format for kind=R16P real. #else -character(*), parameter :: FR16P = '(E23.15E3)' !< Output format for kind=R8P real. +CHARACTER(*), PARAMETER :: FR16P = '(E23.15E3)' !< Output format for kind=R8P real. #endif -character(*), parameter :: FR8P = '(E23.15E3)' !< Output format for kind=R8P real. -character(*), parameter :: FR4P = '(E13.6E2)' !< Output format for kind=R4P real. +CHARACTER(*), PARAMETER :: FR8P = '(E23.15E3)' !< Output format for kind=R8P real. +CHARACTER(*), PARAMETER :: FR4P = '(E13.6E2)' !< Output format for kind=R4P real. #if defined _R16P #if defined _R_P_IS_R16P -character(*), parameter :: FR_P = FR16P !< Output format for kind=R_P real. +CHARACTER(*), PARAMETER :: FR_P = FR16P !< Output format for kind=R_P real. #endif #endif #if defined _R_P_IS_R8P -character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real. +CHARACTER(*), PARAMETER :: FR_P = FR8P !< Output format for kind=R_P real. #elif defined _R_P_IS_R4P -character(*), parameter :: FR_P = FR4P !< Output format for kind=R_P real. +CHARACTER(*), PARAMETER :: FR_P = FR4P !< Output format for kind=R_P real. #else -character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real. +CHARACTER(*), PARAMETER :: FR_P = FR8P !< Output format for kind=R_P real. #endif -character(*), parameter :: FI8P = '(I20)' !< Output format for kind=I8P integer. -character(*), parameter :: FI8PZP = '(I20.19)' !< Output format for kind=I8P integer with zero prefixing. -character(*), parameter :: FI4P = '(I11)' !< Output format for kind=I4P integer. -character(*), parameter :: FI4PZP = '(I11.10)' !< Output format for kind=I4P integer with zero prefixing. -character(*), parameter :: FI2P = '(I6)' !< Output format for kind=I2P integer. -character(*), parameter :: FI2PZP = '(I6.5)' !< Output format for kind=I2P integer with zero prefixing. -character(*), parameter :: FI1P = '(I4)' !< Output format for kind=I1P integer. -character(*), parameter :: FI1PZP = '(I4.3)' !< Output format for kind=I1P integer with zero prefixing. -character(*), parameter :: FI_P = FI4P !< Output format for kind=I_P integer. -character(*), parameter :: FI_PZP = FI4PZP !< Output format for kind=I_P integer with zero prefixing. +CHARACTER(*), PARAMETER :: FI8P = '(I20)' !< Output format for kind=I8P integer. +CHARACTER(*), PARAMETER :: FI8PZP = '(I20.19)' !< Output format for kind=I8P integer with zero prefixing. +CHARACTER(*), PARAMETER :: FI4P = '(I11)' !< Output format for kind=I4P integer. +CHARACTER(*), PARAMETER :: FI4PZP = '(I11.10)' !< Output format for kind=I4P integer with zero prefixing. +CHARACTER(*), PARAMETER :: FI2P = '(I6)' !< Output format for kind=I2P integer. +CHARACTER(*), PARAMETER :: FI2PZP = '(I6.5)' !< Output format for kind=I2P integer with zero prefixing. +CHARACTER(*), PARAMETER :: FI1P = '(I4)' !< Output format for kind=I1P integer. +CHARACTER(*), PARAMETER :: FI1PZP = '(I4.3)' !< Output format for kind=I1P integer with zero prefixing. +CHARACTER(*), PARAMETER :: FI_P = FI4P !< Output format for kind=I_P integer. +CHARACTER(*), PARAMETER :: FI_PZP = FI4PZP !< Output format for kind=I_P integer with zero prefixing. ! length (number of digits) of formatted numbers #if defined _R16P -integer, parameter :: DR16P = 42 !< Number of digits of output format FR16P. +INTEGER, PARAMETER :: DR16P = 42 !< Number of digits of output format FR16P. #else -integer, parameter :: DR16P = 23 !< Number of digits of output format FR8P. +INTEGER, PARAMETER :: DR16P = 23 !< Number of digits of output format FR8P. #endif -integer, parameter :: DR8P = 23 !< Number of digits of output format FR8P. -integer, parameter :: DR4P = 13 !< Number of digits of output format FR4P. +INTEGER, PARAMETER :: DR8P = 23 !< Number of digits of output format FR8P. +INTEGER, PARAMETER :: DR4P = 13 !< Number of digits of output format FR4P. #if defined _R16P #if defined _R_P_IS_R16P -integer, parameter :: DR_P = DR16P !< Number of digits of output format FR_P. +INTEGER, PARAMETER :: DR_P = DR16P !< Number of digits of output format FR_P. #endif #endif #if defined _R_P_IS_R8P -integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P. +INTEGER, PARAMETER :: DR_P = DR8P !< Number of digits of output format FR_P. #elif defined _R_P_IS_R4P -integer, parameter :: DR_P = DR4P !< Number of digits of output format FR_P. +INTEGER, PARAMETER :: DR_P = DR4P !< Number of digits of output format FR_P. #else -integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P. +INTEGER, PARAMETER :: DR_P = DR8P !< Number of digits of output format FR_P. #endif -integer, parameter :: DI8P = 20 !< Number of digits of output format I8P. -integer, parameter :: DI4P = 11 !< Number of digits of output format I4P. -integer, parameter :: DI2P = 6 !< Number of digits of output format I2P. -integer, parameter :: DI1P = 4 !< Number of digits of output format I1P. -integer, parameter :: DI_P = DI4P !< Number of digits of output format I_P. +INTEGER, PARAMETER :: DI8P = 20 !< Number of digits of output format I8P. +INTEGER, PARAMETER :: DI4P = 11 !< Number of digits of output format I4P. +INTEGER, PARAMETER :: DI2P = 6 !< Number of digits of output format I2P. +INTEGER, PARAMETER :: DI1P = 4 !< Number of digits of output format I1P. +INTEGER, PARAMETER :: DI_P = DI4P !< Number of digits of output format I_P. ! list of kinds -integer, parameter :: CHARACTER_KINDS_LIST(1:3) = [ASCII, UCS4, CK] !< List of character kinds. +INTEGER, PARAMETER :: CHARACTER_KINDS_LIST(1:3) = [ASCII, UCS4, CK] !< List of character kinds. #if defined _R16P -integer, parameter :: REAL_KINDS_LIST(1:4) = [R16P, R8P, R4P, R_P] !< List of real kinds. +INTEGER, PARAMETER :: REAL_KINDS_LIST(1:4) = [R16P, R8P, R4P, R_P] !< List of real kinds. #else -integer, parameter :: REAL_KINDS_LIST(1:3) = [R8P, R4P, R_P] !< List of real kinds. +INTEGER, PARAMETER :: REAL_KINDS_LIST(1:3) = [R8P, R4P, R_P] !< List of real kinds. #endif #if defined _R16P character(*), parameter :: REAL_FORMATS_LIST(1:4) = [FR16P, FR8P, FR4P//' ', FR_P] !< List of real formats. #else -character(*), parameter :: REAL_FORMATS_LIST(1:3) = [FR8P, FR4P//' ', FR_P] !< List of real formats. +CHARACTER(*), PARAMETER :: REAL_FORMATS_LIST(1:3) = [FR8P, FR4P//' ', FR_P] !< List of real formats. #endif -integer, parameter :: INTEGER_KINDS_LIST(1:5) = [I8P, I4P, I2P, I1P,I_P] !< List of integer kinds. +INTEGER, PARAMETER :: INTEGER_KINDS_LIST(1:5) = [I8P, I4P, I2P, I1P, I_P] !< List of integer kinds. character(*), parameter :: INTEGER_FORMATS_LIST(1:5) = [FI8P, FI4P, FI2P//' ', FI1P//' ', FI_P] !< List of integer formats. ! minimum and maximum (representable) values #if defined _R16P -real(R16P), parameter :: MinR16P = -huge(1._R16P) !< Minimum value of kind=R16P real. -real(R16P), parameter :: MaxR16P = huge(1._R16P) !< Maximum value of kind=R16P real. -#else -real(R8P), parameter :: MinR16P = -huge(1._R8P ) !< Minimum value of kind=R8P real. -real(R8P), parameter :: MaxR16P = huge(1._R8P ) !< Maximum value of kind=R8P real. -#endif -real(R8P), parameter :: MinR8P = -huge(1._R8P ) !< Minimum value of kind=R8P real. -real(R8P), parameter :: MaxR8P = huge(1._R8P ) !< Maximum value of kind=R8P real. -real(R4P), parameter :: MinR4P = -huge(1._R4P ) !< Minimum value of kind=R4P real. -real(R4P), parameter :: MaxR4P = huge(1._R4P ) !< Maximum value of kind=R4P real. -real(R_P), parameter :: MinR_P = -huge(1._R_P ) !< Minimum value of kind=R_P real. -real(R_P), parameter :: MaxR_P = huge(1._R_P ) !< Maximum value of kind=R_P real. -integer(I8P), parameter :: MinI8P = -huge(1_I8P) !< Minimum value of kind=I8P integer. -integer(I4P), parameter :: MinI4P = -huge(1_I4P) !< Minimum value of kind=I4P integer. -integer(I2P), parameter :: MinI2P = -huge(1_I2P) !< Minimum value of kind=I2P integer. -integer(I1P), parameter :: MinI1P = -huge(1_I1P) !< Minimum value of kind=I1P integer. -integer(I_P), parameter :: MinI_P = -huge(1_I_P) !< Minimum value of kind=I_P integer. -integer(I8P), parameter :: MaxI8P = huge(1_I8P) !< Maximum value of kind=I8P integer. -integer(I4P), parameter :: MaxI4P = huge(1_I4P) !< Maximum value of kind=I4P integer. -integer(I2P), parameter :: MaxI2P = huge(1_I2P) !< Maximum value of kind=I2P integer. -integer(I1P), parameter :: MaxI1P = huge(1_I1P) !< Maximum value of kind=I1P integer. -integer(I_P), parameter :: MaxI_P = huge(1_I_P) !< Maximum value of kind=I_P integer. +REAL(R16P), PARAMETER :: MinR16P = -HUGE(1._R16P) !< Minimum value of kind=R16P real. +REAL(R16P), PARAMETER :: MaxR16P = HUGE(1._R16P) !< Maximum value of kind=R16P real. +#else +REAL(R8P), PARAMETER :: MinR16P = -HUGE(1._R8P) !< Minimum value of kind=R8P real. +REAL(R8P), PARAMETER :: MaxR16P = HUGE(1._R8P) !< Maximum value of kind=R8P real. +#endif +REAL(R8P), PARAMETER :: MinR8P = -HUGE(1._R8P) !< Minimum value of kind=R8P real. +REAL(R8P), PARAMETER :: MaxR8P = HUGE(1._R8P) !< Maximum value of kind=R8P real. +REAL(R4P), PARAMETER :: MinR4P = -HUGE(1._R4P) !< Minimum value of kind=R4P real. +REAL(R4P), PARAMETER :: MaxR4P = HUGE(1._R4P) !< Maximum value of kind=R4P real. +REAL(R_P), PARAMETER :: MinR_P = -HUGE(1._R_P) !< Minimum value of kind=R_P real. +REAL(R_P), PARAMETER :: MaxR_P = HUGE(1._R_P) !< Maximum value of kind=R_P real. +INTEGER(I8P), PARAMETER :: MinI8P = -HUGE(1_I8P) !< Minimum value of kind=I8P integer. +INTEGER(I4P), PARAMETER :: MinI4P = -HUGE(1_I4P) !< Minimum value of kind=I4P integer. +INTEGER(I2P), PARAMETER :: MinI2P = -HUGE(1_I2P) !< Minimum value of kind=I2P integer. +INTEGER(I1P), PARAMETER :: MinI1P = -HUGE(1_I1P) !< Minimum value of kind=I1P integer. +INTEGER(I_P), PARAMETER :: MinI_P = -HUGE(1_I_P) !< Minimum value of kind=I_P integer. +INTEGER(I8P), PARAMETER :: MaxI8P = HUGE(1_I8P) !< Maximum value of kind=I8P integer. +INTEGER(I4P), PARAMETER :: MaxI4P = HUGE(1_I4P) !< Maximum value of kind=I4P integer. +INTEGER(I2P), PARAMETER :: MaxI2P = HUGE(1_I2P) !< Maximum value of kind=I2P integer. +INTEGER(I1P), PARAMETER :: MaxI1P = HUGE(1_I1P) !< Maximum value of kind=I1P integer. +INTEGER(I_P), PARAMETER :: MaxI_P = HUGE(1_I_P) !< Maximum value of kind=I_P integer. ! real smallest (representable) values #if defined _R16P -real(R16P), parameter :: smallR16P = tiny(1._R16P) !< Smallest representable value of kind=R16P real. +REAL(R16P), PARAMETER :: smallR16P = TINY(1._R16P) !< Smallest representable value of kind=R16P real. #else -real(R8P), parameter :: smallR16P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real. +REAL(R8P), PARAMETER :: smallR16P = TINY(1._R8P) !< Smallest representable value of kind=R8P real. #endif -real(R8P), parameter :: smallR8P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real. -real(R4P), parameter :: smallR4P = tiny(1._R4P ) !< Smallest representable value of kind=R4P real. -real(R_P), parameter :: smallR_P = tiny(1._R_P ) !< Smallest representable value of kind=R_P real. +REAL(R8P), PARAMETER :: smallR8P = TINY(1._R8P) !< Smallest representable value of kind=R8P real. +REAL(R4P), PARAMETER :: smallR4P = TINY(1._R4P) !< Smallest representable value of kind=R4P real. +REAL(R_P), PARAMETER :: smallR_P = TINY(1._R_P) !< Smallest representable value of kind=R_P real. ! smallest real representable difference by the running calculator #if defined _R16P -real(R16P), parameter :: ZeroR16P = nearest(1._R16P, 1._R16P) - & - nearest(1._R16P,-1._R16P) !< Smallest representable difference of kind=R16P real. -#else -real(R8P), parameter :: ZeroR16P = 0._R8P !nearest(1._R8P, 1._R8P) - & - !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. -#endif -real(R8P), parameter :: ZeroR8P = 0._R8P !nearest(1._R8P, 1._R8P) - & - !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. -real(R4P), parameter :: ZeroR4P = 0._R4P !nearest(1._R4P, 1._R4P) - & - !nearest(1._R4P,-1._R4P) !< Smallest representable difference of kind=R4P real. -real(R_P), parameter :: ZeroR_P = 0._R_P !nearest(1._R_P, 1._R_P) - & - !nearest(1._R_P,-1._R_P) !< Smallest representable difference of kind=R_P real. +REAL(R16P), PARAMETER :: ZeroR16P = NEAREST(1._R16P, 1._R16P) - & + NEAREST(1._R16P, -1._R16P) !< Smallest representable difference of kind=R16P real. +#else +REAL(R8P), PARAMETER :: ZeroR16P = 0._R8P !nearest(1._R8P, 1._R8P) - & +!nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. +#endif +REAL(R8P), PARAMETER :: ZeroR8P = 0._R8P !nearest(1._R8P, 1._R8P) - & +!nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real. +REAL(R4P), PARAMETER :: ZeroR4P = 0._R4P !nearest(1._R4P, 1._R4P) - & +!nearest(1._R4P,-1._R4P) !< Smallest representable difference of kind=R4P real. +REAL(R_P), PARAMETER :: ZeroR_P = 0._R_P !nearest(1._R_P, 1._R_P) - & +!nearest(1._R_P,-1._R_P) !< Smallest representable difference of kind=R_P real. ! bits/bytes memory requirements #if defined _R16P -integer(I2P), parameter :: BIR16P = storage_size(MaxR16P) !< Number of bits of kind=R16P real. +INTEGER(I2P), PARAMETER :: BIR16P = STORAGE_SIZE(MaxR16P) !< Number of bits of kind=R16P real. #else -integer(I1P), parameter :: BIR16P = storage_size(MaxR8P) !< Number of bits of kind=R8P real. +INTEGER(I1P), PARAMETER :: BIR16P = STORAGE_SIZE(MaxR8P) !< Number of bits of kind=R8P real. #endif -integer(I1P), parameter :: BIR8P = storage_size(MaxR8P) !< Number of bits of kind=R8P real. -integer(I1P), parameter :: BIR4P = storage_size(MaxR4P) !< Number of bits of kind=R4P real. -integer(I1P), parameter :: BIR_P = storage_size(MaxR_P) !< Number of bits of kind=R_P real. +INTEGER(I1P), PARAMETER :: BIR8P = STORAGE_SIZE(MaxR8P) !< Number of bits of kind=R8P real. +INTEGER(I1P), PARAMETER :: BIR4P = STORAGE_SIZE(MaxR4P) !< Number of bits of kind=R4P real. +INTEGER(I1P), PARAMETER :: BIR_P = STORAGE_SIZE(MaxR_P) !< Number of bits of kind=R_P real. #if defined _R16P -integer(I2P), parameter :: BYR16P = BIR16P/8_I2P !< Number of bytes of kind=R16P real. -#else -integer(I1P), parameter :: BYR16P = BIR8P/8_I1P !< Number of bytes of kind=R8P real. -#endif -integer(I1P), parameter :: BYR8P = BIR8P/8_I1P !< Number of bytes of kind=R8P real. -integer(I1P), parameter :: BYR4P = BIR4P/8_I1P !< Number of bytes of kind=R4P real. -integer(I1P), parameter :: BYR_P = BIR_P/8_I1P !< Number of bytes of kind=R_P real. -integer(I8P), parameter :: BII8P = storage_size(MaxI8P) !< Number of bits of kind=I8P integer. -integer(I4P), parameter :: BII4P = storage_size(MaxI4P) !< Number of bits of kind=I4P integer. -integer(I2P), parameter :: BII2P = storage_size(MaxI2P) !< Number of bits of kind=I2P integer. -integer(I1P), parameter :: BII1P = storage_size(MaxI1P) !< Number of bits of kind=I1P integer. -integer(I_P), parameter :: BII_P = storage_size(MaxI_P) !< Number of bits of kind=I_P integer. -integer(I8P), parameter :: BYI8P = BII8P/8_I8P !< Number of bytes of kind=I8P integer. -integer(I4P), parameter :: BYI4P = BII4P/8_I4P !< Number of bytes of kind=I4P integer. -integer(I2P), parameter :: BYI2P = BII2P/8_I2P !< Number of bytes of kind=I2P integer. -integer(I1P), parameter :: BYI1P = BII1P/8_I1P !< Number of bytes of kind=I1P integer. -integer(I_P), parameter :: BYI_P = BII_P/8_I_P !< Number of bytes of kind=I_P integer. +INTEGER(I2P), PARAMETER :: BYR16P = BIR16P / 8_I2P !< Number of bytes of kind=R16P real. +#else +INTEGER(I1P), PARAMETER :: BYR16P = BIR8P / 8_I1P !< Number of bytes of kind=R8P real. +#endif +INTEGER(I1P), PARAMETER :: BYR8P = BIR8P / 8_I1P !< Number of bytes of kind=R8P real. +INTEGER(I1P), PARAMETER :: BYR4P = BIR4P / 8_I1P !< Number of bytes of kind=R4P real. +INTEGER(I1P), PARAMETER :: BYR_P = BIR_P / 8_I1P !< Number of bytes of kind=R_P real. +INTEGER(I8P), PARAMETER :: BII8P = STORAGE_SIZE(MaxI8P) !< Number of bits of kind=I8P integer. +INTEGER(I4P), PARAMETER :: BII4P = STORAGE_SIZE(MaxI4P) !< Number of bits of kind=I4P integer. +INTEGER(I2P), PARAMETER :: BII2P = STORAGE_SIZE(MaxI2P) !< Number of bits of kind=I2P integer. +INTEGER(I1P), PARAMETER :: BII1P = STORAGE_SIZE(MaxI1P) !< Number of bits of kind=I1P integer. +INTEGER(I_P), PARAMETER :: BII_P = STORAGE_SIZE(MaxI_P) !< Number of bits of kind=I_P integer. +INTEGER(I8P), PARAMETER :: BYI8P = BII8P / 8_I8P !< Number of bytes of kind=I8P integer. +INTEGER(I4P), PARAMETER :: BYI4P = BII4P / 8_I4P !< Number of bytes of kind=I4P integer. +INTEGER(I2P), PARAMETER :: BYI2P = BII2P / 8_I2P !< Number of bytes of kind=I2P integer. +INTEGER(I1P), PARAMETER :: BYI1P = BII1P / 8_I1P !< Number of bytes of kind=I1P integer. +INTEGER(I_P), PARAMETER :: BYI_P = BII_P / 8_I_P !< Number of bytes of kind=I_P integer. endmodule penf_global_parameters_variables diff --git a/src/modules/PENF/src/penf_stringify.F90 b/src/modules/PENF/src/penf_stringify.F90 index 979db78d1..e34edeedc 100644 --- a/src/modules/PENF/src/penf_stringify.F90 +++ b/src/modules/PENF/src/penf_stringify.F90 @@ -20,7 +20,7 @@ ! summary: PENF string-to-number (and viceversa) facility. MODULE PENF_STRINGIFY -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: stderr => error_unit +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: stderr => ERROR_UNIT USE PENF_B_SIZE USE PENF_GLOBAL_PARAMETERS_VARIABLES IMPLICIT NONE From d182e7b4391ba130844c00d79feeefe03c804fff Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 09:41:47 +0900 Subject: [PATCH 314/359] updates in Chebyshev1PolynomialUtility --- .../src/Chebyshev1PolynomialUtility.F90 | 76 ++++-------- .../Chebyshev1PolynomialUtility@Methods.F90 | 117 +++++++----------- 2 files changed, 67 insertions(+), 126 deletions(-) diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index 7f2fd24eb..5e6b35dc3 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -879,11 +879,11 @@ MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, & quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -896,62 +896,30 @@ MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, & END SUBROUTINE Chebyshev1Transform1_ END INTERFACE Chebyshev1Transform_ -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Chebyshev1 Transform - -INTERFACE Chebyshev1Transform - MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, quadType) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION Chebyshev1Transform2 -END INTERFACE Chebyshev1Transform - !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 2024-08-19 -! summary: Columnwise Discrete Chebyshev1 Transform - INTERFACE Chebyshev1Transform_ - MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, PP, w, & + quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: PP(0:, 0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! nrow = n+1 - !! ncol = SIZE(coeff, 2) - END SUBROUTINE Chebyshev1Transform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! tsize = n+1 + END SUBROUTINE Chebyshev1Transform4_ END INTERFACE Chebyshev1Transform_ !---------------------------------------------------------------------------- @@ -1037,17 +1005,18 @@ END SUBROUTINE Chebyshev1Transform3_ ! internally. INTERFACE Chebyshev1Transform - MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) + MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) + !! size if quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight REAL(DFP) :: ans(0:n) !! modal values or coefficients - END FUNCTION Chebyshev1Transform4 + END FUNCTION Chebyshev1Transform2 END INTERFACE Chebyshev1Transform !---------------------------------------------------------------------------- @@ -1059,11 +1028,12 @@ END FUNCTION Chebyshev1Transform4 ! summary: Discrete Chebyshev1 Transform INTERFACE Chebyshev1Transform_ - MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) + MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) + !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -1071,7 +1041,7 @@ MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) !! modal values or coefficients INTEGER(I4B), INTENT(OUT) :: tsize !! tsize = n+1 - END SUBROUTINE Chebyshev1Transform4_ + END SUBROUTINE Chebyshev1Transform2_ END INTERFACE Chebyshev1Transform_ !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index 48f8e8013..6a249eee8 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -862,85 +862,51 @@ MODULE PROCEDURE Chebyshev1Transform1_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP INTEGER(I4B) :: ii, jj -REAL(DFP) :: nrmsqr, areal -tsize = n + 1 CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) - -DO jj = 0, n - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) - END DO - nrmsqr = Chebyshev1NormSQR(n=jj) - ans(jj) = areal / nrmsqr -END DO - -IF (quadType .EQ. qp%GaussLobatto) THEN - areal = 0.0_DFP - jj = n - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) - END DO - - nrmsqr = pi - ans(jj) = areal / nrmsqr -END IF +CALL Chebyshev1Transform4_(n, coeff, PP, w, quadType, ans, tsize) END PROCEDURE Chebyshev1Transform1_ !---------------------------------------------------------------------------- -! Chebyshev1Transform +! Chebyshev1Transform !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform2 -INTEGER(I4B) :: nrow, ncol -CALL Chebyshev1Transform2_(n, coeff, x, w, quadType, ans, nrow, ncol) -END PROCEDURE Chebyshev1Transform2 - -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Transform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj, kk +MODULE PROCEDURE Chebyshev1Transform4_ +INTEGER(I4B) :: ii, jj, nips REAL(DFP) :: nrmsqr, areal +LOGICAL(LGT) :: abool -nrow = n + 1 -ncol = SIZE(coeff, 2) +tsize = n + 1 +nips = SIZE(coeff) -CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +DO jj = 0, n + areal = 0.0_DFP -DO kk = 1, ncol - DO jj = 0, n - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, jj) - END DO - nrmsqr = Chebyshev1NormSQR(n=jj) - ans(jj, kk) = areal / nrmsqr + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO -END DO -IF (quadType .EQ. qp%GaussLobatto) THEN + nrmsqr = Chebyshev1NormSQR(n=jj) + ans(jj) = areal / nrmsqr - nrmsqr = pi - jj = n +END DO - DO kk = 1, ncol - areal = 0.0_DFP +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO +IF (abool) THEN + areal = 0.0_DFP + jj = n - ans(jj, kk) = areal / nrmsqr + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO + nrmsqr = pi + ans(jj) = areal / nrmsqr END IF -END PROCEDURE Chebyshev1Transform2_ +END PROCEDURE Chebyshev1Transform4_ !---------------------------------------------------------------------------- ! Chebyshev1Transform @@ -977,27 +943,32 @@ ! Chebyshev1Transform4 !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform4 +MODULE PROCEDURE Chebyshev1Transform2 INTEGER(I4B) :: tsize -CALL Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) -END PROCEDURE Chebyshev1Transform4 +CALL Chebyshev1Transform2_(n, coeff, quadType, ans, tsize) +END PROCEDURE Chebyshev1Transform2 !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform4_ -INTEGER(I4B) :: ii, jj +MODULE PROCEDURE Chebyshev1Transform2_ +INTEGER(I4B) :: ii, jj, nips REAL(DFP) :: avar, asign, pi_by_n, one_by_n REAL(DFP), PARAMETER :: half = 0.5_DFP, minusOne = -1.0_DFP +LOGICAL(LGT) :: abool tsize = n + 1 ans(1:tsize) = 0.0_DFP +nips = SIZE(coeff) + one_by_n = 1.0_DFP / REAL(n, KIND=DFP) pi_by_n = pi * one_by_n -IF (quadType .EQ. qp%GaussLobatto) THEN +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) + +IF (abool) THEN DO jj = 0, n @@ -1005,7 +976,7 @@ ans(jj) = coeff(0) * half + coeff(n) * half * asign - DO ii = 1, n - 1 + DO ii = 1, nips - 1 ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi_by_n * ii) END DO @@ -1025,7 +996,7 @@ avar = jj * pi_by_n - DO ii = 0, n + DO ii = 0, nips - 1 ans(jj) = ans(jj) + coeff(ii) * COS((2.0 * ii + 1.0) * avar) END DO @@ -1037,7 +1008,7 @@ END IF -END PROCEDURE Chebyshev1Transform4_ +END PROCEDURE Chebyshev1Transform2_ !---------------------------------------------------------------------------- ! Chebyshev1InvTransform @@ -1060,28 +1031,28 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GradientCoeff1 -REAL(DFP) :: a, b, c +REAL(DFP) :: c INTEGER(I4B) :: ii REAL(DFP) :: jj -!! + ans(n) = 0.0_DFP IF (n .EQ. 0) RETURN -!! + IF (n .EQ. 1) THEN c = 2.0_DFP ELSE c = 1.0_DFP END IF -!! + ans(n - 1) = 2.0_DFP * n * coeff(n) / c -!! + DO ii = n - 1, 1, -1 jj = REAL(ii, KIND=DFP) ans(ii - 1) = 2.0_DFP * jj * coeff(ii) + ans(ii + 1) END DO -!! + ans(0) = 0.5_DFP * ans(0) -!! + END PROCEDURE Chebyshev1GradientCoeff1 !---------------------------------------------------------------------------- From 345fa8adfb0a7926e60ca4e1362911b2ebee68d4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 09:42:00 +0900 Subject: [PATCH 315/359] update in JacobiPolynomialUtility --- .../src/JacobiPolynomialUtility.F90 | 72 +++++----------- .../src/JacobiPolynomialUtility@Methods.F90 | 84 +++++-------------- 2 files changed, 41 insertions(+), 115 deletions(-) diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index 25920c6d0..23deb2412 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -992,12 +992,15 @@ MODULE PURE SUBROUTINE JacobiTransform1_(n, alpha, beta, coeff, x, w, & !! alpha of Jacobi polynomial > -1.0_DFP REAL(DFP), INTENT(IN) :: beta !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + !! size is quadrature points + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -1012,66 +1015,33 @@ END SUBROUTINE JacobiTransform1_ ! JacobiTransform !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Jacobi Transform - -INTERFACE JacobiTransform - MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & - quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION JacobiTransform2 -END INTERFACE JacobiTransform - -!---------------------------------------------------------------------------- -! JacobiTransform_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-08-19 -! summary: Jacobi transform - INTERFACE JacobiTransform_ - MODULE PURE SUBROUTINE JacobiTransform2_(n, alpha, beta, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE JacobiTransform4_(n, alpha, beta, coeff, PP, w, & + quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial + !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: alpha !! alpha of Jacobi polynomial > -1.0_DFP REAL(DFP), INTENT(IN) :: beta !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + !! number of rows in number of quadrature points + !! number of columns is n+1 + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! nrow = n+1 - !! ncol = SIZE(coeff, 2) - END SUBROUTINE JacobiTransform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! n+1 + END SUBROUTINE JacobiTransform4_ END INTERFACE JacobiTransform_ !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index 10119088c..e592ba1ec 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -1228,17 +1228,29 @@ MODULE PROCEDURE JacobiTransform1_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP -REAL(DFP) :: nrmsqr, areal INTEGER(I4B) :: jj, ii +CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, nrow=ii, ncol=jj, & + ans=PP) +CALL JacobiTransform4_(n, alpha, beta, coeff, PP, w, quadType, ans, tsize) +END PROCEDURE JacobiTransform1_ + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform4_ +REAL(DFP) :: nrmsqr, areal +INTEGER(I4B) :: jj, ii, nips +LOGICAL(LGT) :: abool tsize = n + 1 -PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +nips = SIZE(coeff) DO jj = 0, n areal = 0.0_DFP - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO @@ -1247,11 +1259,13 @@ END DO -IF (quadType .EQ. qp%GaussLobatto) THEN +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) + +IF (abool) THEN areal = 0.0_DFP jj = n - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO @@ -1261,65 +1275,7 @@ END IF -END PROCEDURE JacobiTransform1_ - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform2 -INTEGER(I4B) :: nrow, ncol -CALL JacobiTransform2_(n, alpha, beta, coeff, x, w, quadType, ans, nrow, ncol) -END PROCEDURE JacobiTransform2 - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -REAL(DFP) :: nrmsqr, areal -INTEGER(I4B) :: jj, ii, kk - -nrow = n + 1 -ncol = SIZE(coeff, 2) - -PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) - -DO kk = 1, ncol - DO jj = 0, n - - areal = 0.0_DFP - - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - nrmsqr = JacobiNormSQR(n=jj, alpha=alpha, beta=beta) - ans(jj, kk) = areal / nrmsqr - - END DO -END DO - -IF (quadType .EQ. qp%GaussLobatto) THEN - - jj = n - - nrmsqr = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) * nrmsqr - - DO kk = 1, ncol - - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - ans(jj, kk) = areal / nrmsqr - END DO - -END IF - -END PROCEDURE JacobiTransform2_ +END PROCEDURE JacobiTransform4_ !---------------------------------------------------------------------------- ! JacobiTransform From b908ca2d31a216c8f3b3bcdb0bd70005ac85cd7b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 09:42:15 +0900 Subject: [PATCH 316/359] update in LegendrePolynomialUtility --- .../src/LegendrePolynomialUtility.F90 | 91 +++++++++---------- .../src/LegendrePolynomialUtility@Methods.F90 | 82 ++++------------- 2 files changed, 59 insertions(+), 114 deletions(-) diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index 81b7d96a0..6312061c9 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -625,6 +625,10 @@ END FUNCTION LegendreEvalAll2 ! LegendreEvalAll_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Evaluate Legendre polynomials from 0 to n at several points + INTERFACE LegendreEvalAll_ MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: n @@ -635,6 +639,8 @@ MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol) REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(SIZE(x), n + 1) !! shape (M,N+1) + !! ans(:, jj) denotes value of Pjj at x + !! ans(ii, :) denotes value of all polynomials at x(ii) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE LegendreEvalAll2_ END INTERFACE LegendreEvalAll_ @@ -951,13 +957,17 @@ MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomials !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! value of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) + !! size if number of quadrature points + !! number of quadrature points should be at least n+1 + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points !! These quadrature points are used in LegendreEvalAll method - REAL(DFP), INTENT(IN) :: w(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size is number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -979,12 +989,12 @@ MODULE PURE SUBROUTINE LegendreTransform1_(n, coeff, x, w, quadType, ans, & INTEGER(I4B), INTENT(IN) :: n !! Order of Legendre polynomials !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! Value of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: x(0:) !! Quadrature points !! These quadrature points are used in LegendreEvalAll method - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! Weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -1001,56 +1011,37 @@ END SUBROUTINE LegendreTransform1_ END INTERFACE LegendreTransform_ !---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Legendre Transform - -INTERFACE LegendreTransform - MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & - quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! values of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION LegendreTransform2 -END INTERFACE LegendreTransform - -!---------------------------------------------------------------------------- -! LegendreTransform@Methods +! LegendreTransform !---------------------------------------------------------------------------- INTERFACE LegendreTransform_ - MODULE PURE SUBROUTINE LegendreTransform2_(n, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE LegendreTransform4_(n, coeff, PP, w, quadType, ans, & + tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! values of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights + !! Order of Legendre polynomials + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: coeff(0:) + !! Value of function at quadrature points + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) + !! Quadrature points + !! These quadrature points are used in LegendreEvalAll method + !! number of rows in PP is number of quadrature points + !! number of columns in PP is n+1 + REAL(DFP), INTENT(IN) :: w(0:) + !! Weights + !! soze of w is number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! modal values or coefficients for each column of val - ! REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns writen in ans - END SUBROUTINE LegendreTransform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients of Legendre polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on + ! REAL(DFP) :: ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE LegendreTransform4_ END INTERFACE LegendreTransform_ !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index 2e2ee5b59..ede3a3dd6 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -954,90 +954,44 @@ MODULE PROCEDURE LegendreTransform1_ REAL(DFP), DIMENSION(0:n, 0:n) :: PP INTEGER(I4B) :: ii, jj +CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +CALL LegendreTransform4_(n, coeff, PP, w, quadType, ans, tsize) +END PROCEDURE LegendreTransform1_ + +!---------------------------------------------------------------------------- +! LegendreTransform4_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform4_ +INTEGER(I4B) :: ii, jj, nips REAL(DFP) :: nrmsqr, areal +LOGICAL(LGT) :: abool tsize = n + 1 - -! PP = LegendreEvalAll(n=n, x=x) -CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +nips = SIZE(coeff) DO jj = 0, n areal = 0.0_DFP - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO nrmsqr = LegendreNormSQR(n=jj) ans(jj) = areal / nrmsqr END DO -IF (quadType .EQ. qp%GaussLobatto) THEN +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) + +IF (abool) THEN areal = 0.0_DFP jj = n - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) ans(jj) = areal / nrmsqr END IF - -END PROCEDURE LegendreTransform1_ - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform2 -INTEGER(I4B) :: ii, jj -CALL LegendreTransform2_(n=n, coeff=coeff, x=x, w=w, quadType=quadType, & - ans=ans, nrow=ii, ncol=jj) -END PROCEDURE LegendreTransform2 - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj, kk -REAL(DFP) :: nrmsqr, areal - -nrow = n + 1 -ncol = SIZE(coeff, 2) - -CALL LegendreEvalAll_(n=n, x=x, nrow=ii, ncol=jj, ans=PP) - -DO kk = 1, ncol - DO jj = 0, n - - areal = 0.0_DFP - - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - nrmsqr = LegendreNormSQR(n=jj) - ans(jj, kk) = areal / nrmsqr - - END DO -END DO - -IF (quadType .EQ. qp%GaussLobatto) THEN - - jj = n - nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) - - DO kk = 1, ncol - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - ans(jj, kk) = areal / nrmsqr - END DO - -END IF - -END PROCEDURE LegendreTransform2_ +END PROCEDURE LegendreTransform4_ !---------------------------------------------------------------------------- ! LegendreTransform From bf7f316c77f26fcb3d99533a09a0020936f1eec1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 09:42:27 +0900 Subject: [PATCH 317/359] update in UltrasphericalPolynomialUtility --- .../Lapack/src/Sym_LinearSolveMethods.F90 | 63 ++---------------- .../src/UltrasphericalPolynomialUtility.F90 | 66 ++++++------------- ...ltrasphericalPolynomialUtility@Methods.F90 | 57 +++++++--------- 3 files changed, 50 insertions(+), 136 deletions(-) diff --git a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 index 923cbdd6b..25c14a7a9 100644 --- a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 +++ b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 @@ -22,7 +22,6 @@ MODULE Sym_LinearSolveMethods IMPLICIT NONE PRIVATE -PUBLIC :: SymSolve PUBLIC :: SymLinSolve !---------------------------------------------------------------------------- @@ -59,9 +58,9 @@ MODULE Sym_LinearSolveMethods ! Therefore, when A is large this routine should be avoided. !@endnote -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & - & UPLO, INFO) + UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector to be found REAL(DFP), INTENT(IN) :: A(:, :) @@ -81,14 +80,6 @@ MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & !! "U" or "L", Default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_1 -END INTERFACE - -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_1 -END INTERFACE SymSolve - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_1 END INTERFACE SymLinSolve !---------------------------------------------------------------------------- @@ -107,7 +98,7 @@ END SUBROUTINE SymLinSolve_1 ! ! All other things are same as `ge_solve_1`. -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & & UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:, :) @@ -127,16 +118,8 @@ MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_2 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_2 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_2 -END INTERFACE SymSolve - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -153,7 +136,7 @@ END SUBROUTINE SymLinSolve_2 ! modified on return. Note that B will not be modified as we still ! make a copy of B. -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector solution @@ -169,16 +152,8 @@ MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_3 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_3 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_3 -END INTERFACE SymSolve - !---------------------------------------------------------------------------- ! LinSolve@LinearSolveMethods !---------------------------------------------------------------------------- @@ -187,7 +162,7 @@ END SUBROUTINE SymLinSolve_3 ! date: 7 July 2022 ! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:, :) !! Unknown vector or solution @@ -203,16 +178,8 @@ MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_4 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_4 END INTERFACE SymLinSolve -INTERFACE Solve - MODULE PROCEDURE SymLinSolve_4 -END INTERFACE Solve - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -228,7 +195,7 @@ END SUBROUTINE SymLinSolve_4 ! We do not make any copy of B. The solution is returned in B. This ! means B will be destroyed on return. -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square symmetric matrix, its content will be modified on @@ -243,16 +210,8 @@ MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) !! "L" or "U", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_5 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_5 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_5 -END INTERFACE SymSolve - !---------------------------------------------------------------------------- ! LinSolve@LinearSolveMethods !---------------------------------------------------------------------------- @@ -261,7 +220,7 @@ END SUBROUTINE SymLinSolve_5 ! date: 28 July 2022 ! summary: Solve Ax=y -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square/rectangle matrix, its content will be modifie @@ -277,14 +236,6 @@ MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_6 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_6 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_6 -END INTERFACE SymSolve - END MODULE Sym_LinearSolveMethods diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 index 5e22415c9..410ea9655 100644 --- a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 @@ -987,11 +987,11 @@ MODULE PURE SUBROUTINE UltrasphericalTransform1_(n, lambda, coeff, x, w, & !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: lambda !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -1009,57 +1009,33 @@ END SUBROUTINE UltrasphericalTransform1_ ! UltrasphericalTransform !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Ultraspherical Transform - -INTERFACE UltrasphericalTransform - MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION UltrasphericalTransform2 -END INTERFACE UltrasphericalTransform - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - INTERFACE UltrasphericalTransform_ - MODULE PURE SUBROUTINE UltrasphericalTransform2_(n, lambda, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE UltrasphericalTransform4_(n, lambda, coeff, PP, w, & + quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial + !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: lambda !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + !! number of rows is number of quadrature points + !! number of columns is n+1 + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size of number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! n+1, size(coeff, 2) - END SUBROUTINE UltrasphericalTransform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of ans + !! n + 1 + END SUBROUTINE UltrasphericalTransform4_ END INTERFACE UltrasphericalTransform_ !---------------------------------------------------------------------------- @@ -1143,7 +1119,7 @@ END SUBROUTINE UltrasphericalTransform3_ INTERFACE MODULE PURE FUNCTION UltrasphericalInvTransform1(n, lambda, coeff, x) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: lambda diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 index 833c4ea2e..e8866045e 100644 --- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -910,57 +910,44 @@ ! UltrasphericalTransform !---------------------------------------------------------------------------- -MODULE PROCEDURE UltrasphericalTransform2 -INTEGER(I4B) :: nrow, ncol -CALL UltrasphericalTransform2_(n, lambda, coeff, x, w, quadType, ans, nrow, & - ncol) -END PROCEDURE UltrasphericalTransform2 +MODULE PROCEDURE UltrasphericalTransform4_ +REAL(DFP) :: nrmsqr, areal, rn +INTEGER(I4B) :: jj, ii, nips +LOGICAL(LGT) :: abool -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- +tsize = n + 1 +nips = SIZE(coeff) -MODULE PROCEDURE UltrasphericalTransform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -REAL(DFP) :: nrmsqr, areal, rn -INTEGER(I4B) :: jj, ii, kk +DO jj = 0, n + areal = 0.0_DFP -nrow = n + 1 -ncol = SIZE(coeff, 2) + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO -CALL UltrasphericalEvalAll_(n=n, lambda=lambda, x=x, ans=PP, nrow=ii, ncol=jj) + nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) + ans(jj) = areal / nrmsqr -DO kk = 1, ncol - DO jj = 0, n - areal = 0.0_DFP +END DO - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) - nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) - ans(jj, kk) = areal / nrmsqr +IF (abool) THEN + areal = 0.0_DFP + jj = n + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO -END DO -IF (quadType .EQ. qp%GaussLobatto) THEN - jj = n rn = REAL(n, KIND=DFP) nrmsqr = 2.0_DFP * (rn + lambda) / rn * nrmsqr - DO kk = 1, ncol - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - ans(jj, kk) = areal / nrmsqr - END DO + ans(jj) = areal / nrmsqr END IF -END PROCEDURE UltrasphericalTransform2_ +END PROCEDURE UltrasphericalTransform4_ !---------------------------------------------------------------------------- ! UltrasphericalTransform From 728e7d9ac2c56b3a2bf652da2d5878179cede693 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 13:00:17 +0900 Subject: [PATCH 318/359] update in LobattoPolynomialUtility --- .../src/LobattoPolynomialUtility.F90 | 232 +++++++++++++++++- 1 file changed, 231 insertions(+), 1 deletion(-) diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index ac6b54e8d..a851dffd4 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -22,9 +22,14 @@ !{!pages/LobattoPolynomialUtility.md!} MODULE LobattoPolynomialUtility -USE GlobalData +USE GlobalData, ONLY: I4B, DFP, LGT + +USE BaseType, ONLY: iface_1DFunction + IMPLICIT NONE + PRIVATE + PUBLIC :: LobattoLeadingCoeff PUBLIC :: LobattoZeros PUBLIC :: LobattoEval @@ -44,6 +49,110 @@ MODULE LobattoPolynomialUtility PUBLIC :: LobattoMassMatrix PUBLIC :: LobattoStiffnessMatrix +PUBLIC :: LobattoTransform_ + +PUBLIC :: Lobatto0, Lobatto1, Lobatto2, Lobatto3, Lobatto4, Lobatto5 + +PUBLIC :: Lobatto6, Lobatto7, Lobatto8, Lobatto9, Lobatto10 + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +INTERFACE LobattoTransform_ + MODULE SUBROUTINE LobattoTransform1_(n, coeff, PP, w, quadType, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! Order of Legendre polynomials + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: coeff(0:) + !! Value of function at quadrature points + !! size of coeff is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) + !! Value of lobatto polynomials + !! PP(:, jj) value of Pjj at quadrature points + !! PP(ii, :) value of all lobatto polynomials at point ii + !! number of rows in PP is number of quadrature points + !! number of columns in PP is n+1 + REAL(DFP), INTENT(IN) :: w(0:) + !! Weights for each quadrature points + !! size of w is number of quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type + !! Gauss, GaussLobatto, GaussRadau, GaussRadauLeft GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients of Legendre polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on + ! REAL(DFP) :: ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE LobattoTransform1_ +END INTERFACE LobattoTransform_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-20 +! summary: LobattoTransform + +INTERFACE LobattoTransform_ + MODULE SUBROUTINE LobattoTransform2_(n, coeff, x, w, quadType, ans, & + tsize) + INTEGER(I4B), INTENT(IN) :: n + !! Order of Lobatto polynomials + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: coeff(0:) + !! Value of function at quadrature points + REAL(DFP), INTENT(IN) :: x(0:) + !! Quadrature points + !! These quadrature points are used in LobattoEvalAll method + REAL(DFP), INTENT(IN) :: w(0:) + !! Weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients of Lobatto polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on + ! REAL(DFP) :: ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE LobattoTransform2_ +END INTERFACE LobattoTransform_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-20 +! summary: LobattoTransform of function + +INTERFACE LobattoTransform_ + MODULE SUBROUTINE LobattoTransform3_(n, f, quadType, x1, x2, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type + !! Gauss, GaussLobatto, GaussRadau, GaussRadauLeft GaussRadauRight + !! We will use Legendre quadrature points + REAL(DFP), INTENT(IN) :: x1, x2 + !! domain of function f + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients + !! ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! n+1 + END SUBROUTINE LobattoTransform3_ +END INTERFACE LobattoTransform_ + !---------------------------------------------------------------------------- ! LobattoLeadingCoeff !---------------------------------------------------------------------------- @@ -528,6 +637,127 @@ MODULE PURE FUNCTION LobattoStiffnessMatrix(n) RESULT(ans) END FUNCTION LobattoStiffnessMatrix END INTERFACE +!---------------------------------------------------------------------------- +! Lobatto0 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto0(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto0 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto1 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto1(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto2 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto2(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto3 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto3(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto3 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto4 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto4(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto4 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto5 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto5(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto5 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto6 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto6(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto6 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto7 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto7(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto7 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto8 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto8(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto8 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto9 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto9(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto9 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto10 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto10(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto10 +END INTERFACE + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 3ac68a2ca1d2e4919597954bfebecdf2f1f72364 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 13:00:27 +0900 Subject: [PATCH 319/359] update in LobattoPolynomialUtility --- .../src/LobattoPolynomialUtility@Methods.F90 | 144 +++++++++++++++++- 1 file changed, 141 insertions(+), 3 deletions(-) diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 index 3dff6e8c6..c06f05c04 100644 --- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -16,17 +16,96 @@ ! SUBMODULE(LobattoPolynomialUtility) Methods -USE BaseMethod +USE Sym_LinearSolveMethods, ONLY: SymLinSolve + +USE LegendrePolynomialUtility, ONLY: LegendreLeadingCoeff, & + LegendreNormSqr, & + LegendreEval, & + LegendreEvalAll_, & + LegendreMonomialExpansionAll, & + LegendreQuadrature + +USE JacobiPolynomialUtility, ONLY: JacobiZeros + +USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalEvalAll_, & + UltrasphericalGradientEvalAll_, & + UltrasphericalGradientEvalAll + IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! LobattoTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoTransform1_ +INTEGER(I4B) :: ii, jj, nips +REAL(DFP) :: areal(0:n), massmat(0:n, 0:n) + +tsize = n + 1 +areal = 0.0_DFP +nips = SIZE(coeff) + +DO jj = 0, n + DO ii = 0, nips - 1 + areal(jj) = areal(jj) + PP(ii, jj) * w(ii) * coeff(ii) + END DO +END DO + +massmat = LobattoMassMatrix(n=n) + +CALL SymLinSolve(X=ans(0:n), A=massmat(0:n, 0:n), B=areal(0:n)) + +END PROCEDURE LobattoTransform1_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoTransform2_ +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips + +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) +CALL LobattoEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +CALL LobattoTransform_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, & + ans=ans, tsize=tsize) +DEALLOCATE (PP) +END PROCEDURE LobattoTransform2_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoTransform3_ +REAL(DFP) :: pt(0:n + 1), wt(0:n + 1), coeff(0:n + 1), x +REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP +INTEGER(I4B) :: ii, nips + +nips = n + 2 +CALL LegendreQuadrature(n=nips, pt=pt, wt=wt, quadType=quadType) +!! We are using n+2 quadrature points as it works well in case of +!! GaussLobatto quadrature points also + +DO ii = 0, nips - 1 + x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2 + x = x * half + coeff(ii) = f(x) +END DO + +CALL LobattoTransform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, & + ans=ans, tsize=tsize) + +END PROCEDURE LobattoTransform3_ + !---------------------------------------------------------------------------- ! LobattoLeadingCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE LobattoLeadingCoeff REAL(DFP) :: avar, m - !! + SELECT CASE (n) CASE (0) ans = 0.5_DFP @@ -380,7 +459,6 @@ ans(1:nrow, 1) = -0.5_DFP ans(1:nrow, 2) = 0.5_DFP - !! p = LegendreEvalAll(n=n - 1_I4B, x=x) CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, nrow=nrow, ncol=ii) DO ii = 1, n - 1 @@ -509,6 +587,66 @@ END PROCEDURE LobattoStiffnessMatrix +!---------------------------------------------------------------------------- +! Lobatto0 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Lobatto0 +ans = 0.5_DFP * (1.0_DFP - x) +END PROCEDURE Lobatto0 + +MODULE PROCEDURE Lobatto1 +ans = 0.5_DFP * (1.0_DFP + x) +END PROCEDURE Lobatto1 + +MODULE PROCEDURE Lobatto2 +REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(3.0_DFP) / SQRT(2.0_DFP) +ans = coeff * (x**2 - 1.0_DFP) +END PROCEDURE Lobatto2 + +MODULE PROCEDURE Lobatto3 +REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(5.0_DFP) / SQRT(2.0_DFP) +ans = coeff * (x**2 - 1.0_DFP) * x +END PROCEDURE Lobatto3 + +MODULE PROCEDURE Lobatto4 +REAL(DFP), PARAMETER :: coeff = SQRT(7.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (5.0_DFP * x**2 - 1.0_DFP) +END PROCEDURE Lobatto4 + +MODULE PROCEDURE Lobatto5 +REAL(DFP), PARAMETER :: coeff = SQRT(9.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (7.0_DFP * x**2 - 3.0_DFP) * x +END PROCEDURE Lobatto5 + +MODULE PROCEDURE Lobatto6 +REAL(DFP), PARAMETER :: coeff = SQRT(11.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (21.0_DFP * x**4 - 14.0_DFP * x**2 + 1.0_DFP) +END PROCEDURE Lobatto6 + +MODULE PROCEDURE Lobatto7 +REAL(DFP), PARAMETER :: coeff = SQRT(13.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (33.0_DFP * x**4 - 30.0_DFP * x**2 + 5.0_DFP) * x +END PROCEDURE Lobatto7 + +MODULE PROCEDURE Lobatto8 +REAL(DFP), PARAMETER :: coeff = SQRT(15.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (429.0_DFP * x**6 - 495.0_DFP * x**4 & + + 135.0_DFP * x**2 - 5.0_DFP) +END PROCEDURE Lobatto8 + +MODULE PROCEDURE Lobatto9 +REAL(DFP), PARAMETER :: coeff = SQRT(17.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (715.0_DFP * x**6 - 1001.0_DFP * x**4 & + + 385.0_DFP * x**2 - 35.0_DFP) * x +END PROCEDURE Lobatto9 + +MODULE PROCEDURE Lobatto10 +REAL(DFP), PARAMETER :: coeff = SQRT(19.0_DFP) / SQRT(2.0_DFP) / 256.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (2431.0_DFP * x**8 - 4004.0_DFP * x**6 & + + 2002.0_DFP * x**4 - 308.0_DFP * x**2 + 7.0_DFP) +END PROCEDURE Lobatto10 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 8099195e1bbe4ea5c7b723a7663a2d1ac77e64b7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 13:00:37 +0900 Subject: [PATCH 320/359] update in Chebyshev1PolynomialUtility --- .../src/Chebyshev1PolynomialUtility@Methods.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index 6a249eee8..a2c5ab5ab 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -860,12 +860,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1Transform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) CALL Chebyshev1Transform4_(n, coeff, PP, w, quadType, ans, tsize) +DEALLOCATE (PP) + END PROCEDURE Chebyshev1Transform1_ !---------------------------------------------------------------------------- From bbb2d1e5ba9935f18a310967427b39b3859739ad Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 13:00:51 +0900 Subject: [PATCH 321/359] update in JacobiPolynomialUtility --- .../Polynomial/src/JacobiPolynomialUtility@Methods.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index e592ba1ec..ac43e61c7 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -1227,11 +1227,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiTransform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: jj, ii +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, nrow=ii, ncol=jj, & ans=PP) CALL JacobiTransform4_(n, alpha, beta, coeff, PP, w, quadType, ans, tsize) +DEALLOCATE (PP) END PROCEDURE JacobiTransform1_ !---------------------------------------------------------------------------- From e56615048671f8926ba9d61282c58982a2f0dca9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 13:01:02 +0900 Subject: [PATCH 322/359] update in LegendrePolynomialUtility --- .../src/LegendrePolynomialUtility@Methods.F90 | 370 +++++++++--------- 1 file changed, 185 insertions(+), 185 deletions(-) diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index ede3a3dd6..2f3638d6b 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -33,6 +33,8 @@ USE BaseType, ONLY: qp => TypeQuadratureOpt +USE GlobalData, ONLY: stderr + IMPLICIT NONE CONTAINS @@ -172,12 +174,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussQuadrature -REAL(DFP) :: pn(n), fixvar +#ifdef USE_LAPACK95 +REAL(DFP) :: fixvar +REAL(DFP) :: pn(n) INTEGER(I4B) :: ii - -CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) +#endif #ifdef USE_LAPACK95 +CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) CALL STEV(D=pt, E=pn) IF (PRESENT(wt)) THEN @@ -194,7 +198,7 @@ file=__FILE__, & routine="LegendreGaussQuadrature", & line=__LINE__, & - unitno=stdout) + unitno=stderr) #endif END PROCEDURE LegendreGaussQuadrature @@ -204,7 +208,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreJacobiRadauMatrix -REAL(DFP) :: avar, r1, r2 +REAL(DFP) :: r1, r2 IF (n .LT. 1) RETURN @@ -227,34 +231,32 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussRadauQuadrature +#ifdef USE_LAPACK95 REAL(DFP) :: pn(n + 1), fixvar INTEGER(I4B) :: ii - !! + CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=pn) -!! -#ifdef USE_LAPACK95 -!! CALL STEV(D=pt, E=pn) -!! + IF (PRESENT(wt)) THEN wt = pn pn = LegendreEval(n=n, x=pt) fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) - !! + DO ii = 1, n + 1 wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) END DO END IF - !! + #else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="LegendreGaussRadauQuadrature", & - & line=__LINE__, & - & unitno=stdout) + +CALL ErrorMsg(msg="The subroutine requires Lapack95 package", & + file=__FILE__, & + routine="LegendreGaussRadauQuadrature", & + line=__LINE__, & + unitno=stderr) #endif - !! + END PROCEDURE LegendreGaussRadauQuadrature !---------------------------------------------------------------------------- @@ -262,24 +264,24 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreJacobiLobattoMatrix - !! + REAL(DFP) :: r1, r2 - !! + IF (n .LT. 0) RETURN - !! + CALL LegendreJacobiMatrix( & & n=n + 1, & & D=D, & & E=E, & & alphaCoeff=alphaCoeff, & & betaCoeff=betaCoeff) - !! + D(n + 2) = 0.0_DFP r1 = REAL(n + 1, KIND=DFP) r2 = REAL(2 * n + 1, KIND=DFP) - !! + E(n + 1) = SQRT(r1 / r2) - !! + END PROCEDURE LegendreJacobiLobattoMatrix !---------------------------------------------------------------------------- @@ -287,34 +289,33 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussLobattoQuadrature +#ifdef USE_LAPACK95 REAL(DFP) :: pn(n + 2), fixvar INTEGER(I4B) :: ii -!! + CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=pn) -!! -#ifdef USE_LAPACK95 -!! + CALL STEV(D=pt, E=pn) -!! + IF (PRESENT(wt)) THEN wt = pn pn = LegendreEval(n=n + 1, x=pt) fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) - !! + DO ii = 1, n + 2 wt(ii) = fixvar / (pn(ii)**2) END DO END IF - !! + #else CALL ErrorMsg( & & msg="The subroutine requires Lapack95 package", & & file=__FILE__, & & routine="LegendreGaussLobattoQuadrature", & & line=__LINE__, & - & unitno=stdout) + & unitno=stderr) #endif - !! + END PROCEDURE LegendreGaussLobattoQuadrature !---------------------------------------------------------------------------- @@ -334,21 +335,21 @@ REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP REAL(DFP), ALLOCATABLE :: p(:), w(:) LOGICAL(LGT) :: inside -!! + IF (PRESENT(onlyInside)) THEN inside = onlyInside ELSE inside = .FALSE. END IF -!! + SELECT CASE (QuadType) CASE (qp%Gauss) - !! + order = n CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt) - !! + CASE (qp%GaussRadau, qp%GaussRadauLeft) - !! + IF (inside) THEN order = n ALLOCATE (p(n + 1), w(n + 1)) @@ -359,9 +360,9 @@ order = n - 1 CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) END IF - !! + CASE (qp%GaussRadauRight) - !! + IF (inside) THEN order = n ALLOCATE (p(n + 1), w(n + 1)) @@ -371,9 +372,9 @@ order = n - 1 CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) END IF - !! + CASE (qp%GaussLobatto) - !! + IF (inside) THEN order = n ALLOCATE (p(n + 2), w(n + 2)) @@ -393,33 +394,33 @@ MODULE PROCEDURE LegendreEval1 INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i, ans_1, ans_2 -!! + ans = 0.0_DFP -!! + IF (n < 0) THEN RETURN END IF -!! + ans = 1.0_DFP ans_2 = ans -!! + IF (n .EQ. 0) THEN RETURN END IF -!! + ans = x -!! + DO i = 1, n - 1 - !! + r_i = REAL(i, kind=DFP) c1 = r_i + 1.0_DFP c2 = 2.0_DFP * r_i + 1.0_DFP c3 = -r_i - !! + ans_1 = ans ans = ((c2 * x) * ans + c3 * ans_2) / c1 ans_2 = ans_1 - !! + END DO END PROCEDURE LegendreEval1 @@ -431,33 +432,33 @@ INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! + ans = 0.0_DFP -!! + IF (n < 0) THEN RETURN END IF -!! + ans = 1.0_DFP ans_2 = ans -!! + IF (n .EQ. 0) THEN RETURN END IF -!! + ans = x -!! + DO i = 1, n - 1 - !! + r_i = REAL(i, kind=DFP) c1 = r_i + 1.0_DFP c2 = 2.0_DFP * r_i + 1.0_DFP c3 = -r_i - !! + ans_1 = ans ans = ((c2 * x) * ans + c3 * ans_2) / c1 ans_2 = ans_1 - !! + END DO END PROCEDURE LegendreEval2 @@ -555,30 +556,30 @@ MODULE PROCEDURE LegendreMonomialExpansionAll REAL(DFP) :: r_i INTEGER(I4B) :: ii - !! + IF (n < 0) THEN RETURN END IF -!! + ans = 0.0_DFP ans(1, 1) = 1.0_DFP - !! + IF (n .EQ. 0) THEN RETURN END IF - !! + ans(2, 2) = 1.0_DFP - !! + DO ii = 2, n - !! + r_i = REAL(ii, KIND=DFP) - !! + ans(1:ii - 1, ii + 1) = & & (-r_i + 1.0) * ans(1:ii - 1, ii - 1) / r_i - !! + ans(2:ii + 1, ii + 1) = ans(2:ii + 1, ii + 1) & & + (2.0 * r_i - 1.0) * ans(1:ii, ii) / r_i - !! + END DO END PROCEDURE LegendreMonomialExpansionAll @@ -689,46 +690,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEval1 - !! + INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP) :: p, p_1, p_2 REAL(DFP) :: ans_1, ans_2 -!! + IF (n < 0) THEN RETURN END IF -!! + p = 1.0_DFP ans = 0.0_DFP p_2 = p ans_2 = ans -!! + IF (n < 1) THEN RETURN END IF -!! + p = x ans = 1.0_DFP -!! + DO ii = 2, n - !! + r_ii = REAL(ii, KIND=DFP) - !! + p_1 = p - !! + p = ((2.0_DFP * r_ii - 1) * x * p & & - (r_ii - 1.0_DFP) * p_2) & & / r_ii - !! + p_2 = p_1 - !! + ans_1 = ans ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 ans_2 = ans_1 - !! + END DO -!! + END PROCEDURE LegendreGradientEval1 !---------------------------------------------------------------------------- @@ -736,46 +737,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEval2 -!! + INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! + IF (n < 0) THEN RETURN END IF -!! + p = 1.0_DFP ans = 0.0_DFP p_2 = p ans_2 = ans -!! + IF (n < 1) THEN RETURN END IF -!! + p = x ans = 1.0_DFP -!! + DO ii = 2, n - !! + r_ii = REAL(ii, KIND=DFP) - !! + p_1 = p - !! + p = ((2.0_DFP * r_ii - 1) * x * p & & - (r_ii - 1.0_DFP) * p_2) & & / r_ii - !! + p_2 = p_1 - !! + ans_1 = ans ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 ans_2 = ans_1 - !! + END DO -!! + END PROCEDURE LegendreGradientEval2 !---------------------------------------------------------------------------- @@ -786,21 +787,21 @@ REAL(DFP) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0.0_DFP b2 = 0.0_DFP -!! + DO j = n, 1, -1 i = REAL(j, KIND=DFP) t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) b2 = b1 b1 = t END DO -!! + ans = x * b1 - b2 / 2.0_DFP + coeff(0) -!! + END PROCEDURE LegendreEvalSum1 !---------------------------------------------------------------------------- @@ -811,21 +812,21 @@ REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0.0_DFP b2 = 0.0_DFP -!! + DO j = n, 1, -1 i = REAL(j, KIND=DFP) t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) b2 = b1 b1 = t END DO -!! + ans = x * b1 - b2 / 2.0_DFP + coeff(0) -!! + END PROCEDURE LegendreEvalSum2 !---------------------------------------------------------------------------- @@ -836,12 +837,12 @@ REAL(DFP) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 -!! + DO j = n - 1, 0, -1 i = REAL(j, KIND=DFP) t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); @@ -859,12 +860,12 @@ REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 -!! + DO j = n - 1, 0, -1 i = REAL(j, KIND=DFP) t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); @@ -883,17 +884,17 @@ REAL(DFP) :: s, A1, A2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 s = 1.0_DFP -!! + DO j = 2 * k - 1, 1, -2 s = j * s END DO -!! + DO j = n - k, 0, -1 i = REAL(j, KIND=DFP) A1 = (2 * i + 2 * k + 1) / (i + 1) * x; @@ -914,26 +915,26 @@ REAL(DFP) :: s, A2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 s = 1.0_DFP -!! + DO j = 2 * k - 1, 1, -2 s = j * s END DO -!! + DO j = n - k, 0, -1 i = REAL(j, KIND=DFP) - A1 = (2 * i + 2 * k + 1) / (i + 1) * x; - A2 = -(i + 2 * k + 1) / (i + 2); - t = A1 * b1 + A2 * b2 + coeff(j + k); - b2 = b1; - b1 = t; + A1 = (2 * i + 2 * k + 1) / (i + 1) * x + A2 = -(i + 2 * k + 1) / (i + 2) + t = A1 * b1 + A2 * b2 + coeff(j + k) + b2 = b1 + b1 = t END DO -!! + ans = s * b1 END PROCEDURE LegendreGradientEvalSum4 @@ -952,10 +953,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreTransform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) + CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) -CALL LegendreTransform4_(n, coeff, PP, w, quadType, ans, tsize) +CALL LegendreTransform4_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, & + ans=ans, tsize=tsize) +DEALLOCATE (PP) END PROCEDURE LegendreTransform1_ !---------------------------------------------------------------------------- @@ -1068,33 +1074,32 @@ PURE SUBROUTINE LegendreDMatrixGL(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! + ! D matrix + + ! main REAL(DFP) :: J(0:n) REAL(DFP) :: rn INTEGER(I4B) :: ii, jj - !! + rn = REAL(n, KIND=DFP) - !! + J = LegendreEval(n=n, x=x) - !! + D = 0.0_DFP D(0, 0) = 0.125_DFP * rn * (rn + 1.0_DFP) D(n, n) = -D(0, 0) - !! + DO jj = 0, n DO ii = 0, n IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - !! + END SUBROUTINE LegendreDMatrixGL !---------------------------------------------------------------------------- @@ -1103,45 +1108,45 @@ END SUBROUTINE LegendreDMatrixGL PURE SUBROUTINE LegendreDMatrixGL2(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! + ! D matrix + + ! main + REAL(DFP) :: J(0:n) REAL(DFP) :: rn INTEGER(I4B) :: ii, jj, nb2 - !! + nb2 = INT(n / 2) rn = REAL(n, KIND=DFP) - !! + J = LegendreEval(n=n, x=x) D = 0.0_DFP - !! + DO jj = 0, n DO ii = 0, nb2 IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - !! - !! correct diagonal entries - !! + + ! correct diagonal entries + DO ii = 0, nb2 D(ii, ii) = -SUM(D(ii, :)) END DO - !! - !! copy - !! + ! + ! copy + DO jj = 0, n DO ii = 0, nb2 D(n - ii, n - jj) = -D(ii, jj) END DO END DO - !! + END SUBROUTINE LegendreDMatrixGL2 !---------------------------------------------------------------------------- @@ -1150,21 +1155,21 @@ END SUBROUTINE LegendreDMatrixGL2 PURE SUBROUTINE LegendreDMatrixG(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! + ! D matrix + + ! main + REAL(DFP) :: J(0:n) INTEGER(I4B) :: ii, jj - !! - !! Compute dJ_{N-1}(a+1,b+1) - !! + + ! Compute dJ_{N-1}(a+1,b+1) + J = LegendreGradientEval(n=n + 1, x=x) - !! + DO jj = 0, n DO ii = 0, n IF (ii .EQ. jj) THEN @@ -1174,7 +1179,7 @@ PURE SUBROUTINE LegendreDMatrixG(n, x, D) END IF END DO END DO -!! + END SUBROUTINE LegendreDMatrixG !---------------------------------------------------------------------------- @@ -1183,45 +1188,40 @@ END SUBROUTINE LegendreDMatrixG PURE SUBROUTINE LegendreDMatrixG2(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! internal variables - !! + ! D matrix + + ! internal variables REAL(DFP) :: J(0:n) INTEGER(I4B) :: ii, jj, nb2 - !! - !! main - !! + + ! main nb2 = INT(n / 2) D = 0.0_DFP - !! + J = LegendreGradientEval(n=n + 1, x=x) - !! + DO jj = 0, n DO ii = 0, nb2 IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - !! - !! correct diagonal entries - !! + + ! correct diagonal entries DO ii = 0, nb2 D(ii, ii) = -SUM(D(ii, :)) END DO - !! - !! copy - !! + + ! copy DO jj = 0, n DO ii = 0, nb2 D(n - ii, n - jj) = -D(ii, jj) END DO END DO - !! END SUBROUTINE LegendreDMatrixG2 !---------------------------------------------------------------------------- From 749290975ba50293384066c453218cb5b6107b4f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 20 Aug 2024 13:01:15 +0900 Subject: [PATCH 323/359] update in UltrasphericalPolynomialUtility --- .../src/UltrasphericalPolynomialUtility@Methods.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 index e8866045e..2b580884c 100644 --- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -869,9 +869,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE UltrasphericalTransform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP REAL(DFP) :: nrmsqr, areal, rn -INTEGER(I4B) :: jj, ii +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) tsize = n + 1 @@ -904,6 +906,8 @@ END IF +DEALLOCATE (PP) + END PROCEDURE UltrasphericalTransform1_ !---------------------------------------------------------------------------- From e0f19164951b4d54e07d4ec20874f67129586ed9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:42:54 +0900 Subject: [PATCH 324/359] Updates in element shape data --- .../src/ElemshapeData_Orthogonal.F90 | 122 +++++ .../Lapack/src/Sym_LinearSolveMethods.F90 | 63 ++- .../src/Chebyshev1PolynomialUtility.F90 | 76 ++- .../src/JacobiPolynomialUtility.F90 | 72 ++- .../src/LegendrePolynomialUtility.F90 | 91 ++-- .../src/LobattoPolynomialUtility.F90 | 232 +-------- .../src/UltrasphericalPolynomialUtility.F90 | 66 ++- .../ElemshapeData_Hierarchical@Methods.F90 | 121 +++++ .../src/ElemshapeData_Lagrange@Methods.F90 | 167 +++++++ .../src/ElemshapeData_Orthogonal@Methods.F90 | 99 ++++ .../Chebyshev1PolynomialUtility@Methods.F90 | 123 +++-- .../src/JacobiPolynomialUtility@Methods.F90 | 89 +++- .../src/LegendrePolynomialUtility@Methods.F90 | 450 ++++++++++-------- .../src/LobattoPolynomialUtility@Methods.F90 | 144 +----- ...ltrasphericalPolynomialUtility@Methods.F90 | 65 +-- 15 files changed, 1192 insertions(+), 788 deletions(-) create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_Orthogonal.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_Orthogonal@Methods.F90 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Orthogonal.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Orthogonal.F90 new file mode 100644 index 000000000..0cd4cf1ab --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_Orthogonal.F90 @@ -0,0 +1,122 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE ElemshapeData_Orthogonal + +USE BaseType, ONLY: ElemshapeData_, & + QuadraturePoint_, & + ReferenceElement_, & + OrthogonalInterpolation_, & + H1_ + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: OrthogonalElemShapeData +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate orthogonal shape function data + +INTERFACE OrthogonalElemShapeData + MODULE SUBROUTINE OrthogonalElemShapeData1(obj, quad, nsd, xidim, & + elemType, refelemCoord, domainName, order, basisType, & + alpha, beta, lambda) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj + !! element shape data + TYPE(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point + INTEGER(I4B), INTENT(IN) :: nsd + !! number of spatial dimension + INTEGER(I4B), INTENT(IN) :: xidim + !! dimension of xi + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: refelemCoord(:, :) + !! coordinate of reference element + CHARACTER(*), INTENT(IN) :: domainName + !! name of reference element domain + INTEGER(I4B), INTENT(IN) :: order + !! cell order, always needed + INTEGER(I4B), INTENT(IN) :: basisType + !! basis type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! parameters for Jacobi and Ultraspherical poly + END SUBROUTINE OrthogonalElemShapeData1 +END INTERFACE OrthogonalElemShapeData + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE OrthogonalElemShapeData + MODULE SUBROUTINE OrthogonalElemShapeData2(obj, quad, refelem, order, & + basisType, alpha, beta, lambda) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj + !! element shape data + TYPE(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature points + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! reference element + INTEGER(I4B), INTENT(IN) :: order + !! cell order, always needed + INTEGER(I4B), INTENT(IN) :: basisType + !! basis type + !! needed for line, quad, and hexa element + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE OrthogonalElemShapeData2 +END INTERFACE OrthogonalElemShapeData + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE OrthogonalElemShapeData + MODULE SUBROUTINE OrthogonalElemShapeData3(obj, quad, refelem, & + baseContinuity, baseInterpolation, order, basisType, alpha, beta, lambda) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj + TYPE(QuadraturePoint_), INTENT(IN) :: quad + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! reference element + TYPE(H1_), INTENT(IN) :: baseContinuity + !! base continuity + TYPE(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation + !! base interpolation + INTEGER(I4B), INTENT(IN) :: order + !! cell order, always needed + INTEGER(I4B), INTENT(IN) :: basisType + !! basis type + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + END SUBROUTINE OrthogonalElemShapeData3 +END INTERFACE OrthogonalElemShapeData + +INTERFACE Initiate + MODULE PROCEDURE OrthogonalElemShapeData3 +END INTERFACE Initiate + +END MODULE ElemshapeData_Orthogonal diff --git a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 index 25c14a7a9..923cbdd6b 100644 --- a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 +++ b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 @@ -22,6 +22,7 @@ MODULE Sym_LinearSolveMethods IMPLICIT NONE PRIVATE +PUBLIC :: SymSolve PUBLIC :: SymLinSolve !---------------------------------------------------------------------------- @@ -58,9 +59,9 @@ MODULE Sym_LinearSolveMethods ! Therefore, when A is large this routine should be avoided. !@endnote -INTERFACE SymLinSolve +INTERFACE MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & - UPLO, INFO) + & UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector to be found REAL(DFP), INTENT(IN) :: A(:, :) @@ -80,6 +81,14 @@ MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & !! "U" or "L", Default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_1 +END INTERFACE + +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_1 +END INTERFACE SymSolve + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_1 END INTERFACE SymLinSolve !---------------------------------------------------------------------------- @@ -98,7 +107,7 @@ END SUBROUTINE SymLinSolve_1 ! ! All other things are same as `ge_solve_1`. -INTERFACE SymLinSolve +INTERFACE MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & & UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:, :) @@ -118,8 +127,16 @@ MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_2 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_2 END INTERFACE SymLinSolve +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_2 +END INTERFACE SymSolve + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -136,7 +153,7 @@ END SUBROUTINE SymLinSolve_2 ! modified on return. Note that B will not be modified as we still ! make a copy of B. -INTERFACE SymLinSolve +INTERFACE MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector solution @@ -152,8 +169,16 @@ MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_3 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_3 END INTERFACE SymLinSolve +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_3 +END INTERFACE SymSolve + !---------------------------------------------------------------------------- ! LinSolve@LinearSolveMethods !---------------------------------------------------------------------------- @@ -162,7 +187,7 @@ END SUBROUTINE SymLinSolve_3 ! date: 7 July 2022 ! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays -INTERFACE SymLinSolve +INTERFACE MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:, :) !! Unknown vector or solution @@ -178,8 +203,16 @@ MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_4 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_4 END INTERFACE SymLinSolve +INTERFACE Solve + MODULE PROCEDURE SymLinSolve_4 +END INTERFACE Solve + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -195,7 +228,7 @@ END SUBROUTINE SymLinSolve_4 ! We do not make any copy of B. The solution is returned in B. This ! means B will be destroyed on return. -INTERFACE SymLinSolve +INTERFACE MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square symmetric matrix, its content will be modified on @@ -210,8 +243,16 @@ MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) !! "L" or "U", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_5 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_5 END INTERFACE SymLinSolve +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_5 +END INTERFACE SymSolve + !---------------------------------------------------------------------------- ! LinSolve@LinearSolveMethods !---------------------------------------------------------------------------- @@ -220,7 +261,7 @@ END SUBROUTINE SymLinSolve_5 ! date: 28 July 2022 ! summary: Solve Ax=y -INTERFACE SymLinSolve +INTERFACE MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square/rectangle matrix, its content will be modifie @@ -236,6 +277,14 @@ MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_6 +END INTERFACE + +INTERFACE SymLinSolve + MODULE PROCEDURE SymLinSolve_6 END INTERFACE SymLinSolve +INTERFACE SymSolve + MODULE PROCEDURE SymLinSolve_6 +END INTERFACE SymSolve + END MODULE Sym_LinearSolveMethods diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index 5e6b35dc3..7f2fd24eb 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -879,11 +879,11 @@ MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, & quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:n) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -896,30 +896,62 @@ MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, & END SUBROUTINE Chebyshev1Transform1_ END INTERFACE Chebyshev1Transform_ +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Chebyshev1 Transform + +INTERFACE Chebyshev1Transform + MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, quadType) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION Chebyshev1Transform2 +END INTERFACE Chebyshev1Transform + !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Columnwise Discrete Chebyshev1 Transform + INTERFACE Chebyshev1Transform_ - MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, PP, w, & - quadType, ans, tsize) + MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, x, w, & + quadType, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:) + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: PP(0:, 0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:) - !! ans(0:n) - !! modal values or coefficients - INTEGER(I4B), INTENT(OUT) :: tsize - !! tsize = n+1 - END SUBROUTINE Chebyshev1Transform4_ + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = n+1 + !! ncol = SIZE(coeff, 2) + END SUBROUTINE Chebyshev1Transform2_ END INTERFACE Chebyshev1Transform_ !---------------------------------------------------------------------------- @@ -1005,18 +1037,17 @@ END SUBROUTINE Chebyshev1Transform3_ ! internally. INTERFACE Chebyshev1Transform - MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, quadType) RESULT(ans) + MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:n) !! nodal value (at quad points) - !! size if quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight REAL(DFP) :: ans(0:n) !! modal values or coefficients - END FUNCTION Chebyshev1Transform2 + END FUNCTION Chebyshev1Transform4 END INTERFACE Chebyshev1Transform !---------------------------------------------------------------------------- @@ -1028,12 +1059,11 @@ END FUNCTION Chebyshev1Transform2 ! summary: Discrete Chebyshev1 Transform INTERFACE Chebyshev1Transform_ - MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, quadType, ans, tsize) + MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:n) !! nodal value (at quad points) - !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -1041,7 +1071,7 @@ MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, quadType, ans, tsize) !! modal values or coefficients INTEGER(I4B), INTENT(OUT) :: tsize !! tsize = n+1 - END SUBROUTINE Chebyshev1Transform2_ + END SUBROUTINE Chebyshev1Transform4_ END INTERFACE Chebyshev1Transform_ !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index 23deb2412..25920c6d0 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -992,15 +992,12 @@ MODULE PURE SUBROUTINE JacobiTransform1_(n, alpha, beta, coeff, x, w, & !! alpha of Jacobi polynomial > -1.0_DFP REAL(DFP), INTENT(IN) :: beta !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:n) !! nodal value (at quad points) - !! size is number of quadrature points - REAL(DFP), INTENT(IN) :: x(0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points - !! size is quadrature points - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! weights - !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -1015,33 +1012,66 @@ END SUBROUTINE JacobiTransform1_ ! JacobiTransform !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Jacobi Transform + +INTERFACE JacobiTransform + MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & + quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION JacobiTransform2 +END INTERFACE JacobiTransform + +!---------------------------------------------------------------------------- +! JacobiTransform_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Jacobi transform + INTERFACE JacobiTransform_ - MODULE PURE SUBROUTINE JacobiTransform4_(n, alpha, beta, coeff, PP, w, & - quadType, ans, tsize) + MODULE PURE SUBROUTINE JacobiTransform2_(n, alpha, beta, coeff, x, w, & + quadType, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial + !! order of polynomial REAL(DFP), INTENT(IN) :: alpha !! alpha of Jacobi polynomial > -1.0_DFP REAL(DFP), INTENT(IN) :: beta !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) !! nodal value (at quad points) - !! size is number of quadrature points - REAL(DFP), INTENT(IN) :: PP(0:, 0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points - !! number of rows in number of quadrature points - !! number of columns is n+1 - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! weights - !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:) - !! modal values or coefficients - INTEGER(I4B), INTENT(OUT) :: tsize - !! n+1 - END SUBROUTINE JacobiTransform4_ + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = n+1 + !! ncol = SIZE(coeff, 2) + END SUBROUTINE JacobiTransform2_ END INTERFACE JacobiTransform_ !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index 6312061c9..81b7d96a0 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -625,10 +625,6 @@ END FUNCTION LegendreEvalAll2 ! LegendreEvalAll_ !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 2024-08-19 -! summary: Evaluate Legendre polynomials from 0 to n at several points - INTERFACE LegendreEvalAll_ MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: n @@ -639,8 +635,6 @@ MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol) REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(SIZE(x), n + 1) !! shape (M,N+1) - !! ans(:, jj) denotes value of Pjj at x - !! ans(ii, :) denotes value of all polynomials at x(ii) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE LegendreEvalAll2_ END INTERFACE LegendreEvalAll_ @@ -957,17 +951,13 @@ MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomials !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:n) !! value of function at quadrature points - !! size if number of quadrature points - !! number of quadrature points should be at least n+1 - REAL(DFP), INTENT(IN) :: x(0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points !! These quadrature points are used in LegendreEvalAll method - !! size is number of quadrature points - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! weights - !! size is number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -989,12 +979,12 @@ MODULE PURE SUBROUTINE LegendreTransform1_(n, coeff, x, w, quadType, ans, & INTEGER(I4B), INTENT(IN) :: n !! Order of Legendre polynomials !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:n) !! Value of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! Quadrature points !! These quadrature points are used in LegendreEvalAll method - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! Weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -1011,37 +1001,56 @@ END SUBROUTINE LegendreTransform1_ END INTERFACE LegendreTransform_ !---------------------------------------------------------------------------- -! LegendreTransform +! LegendreTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Legendre Transform + +INTERFACE LegendreTransform + MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & + quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! values of function at quadrature points + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION LegendreTransform2 +END INTERFACE LegendreTransform + +!---------------------------------------------------------------------------- +! LegendreTransform@Methods !---------------------------------------------------------------------------- INTERFACE LegendreTransform_ - MODULE PURE SUBROUTINE LegendreTransform4_(n, coeff, PP, w, quadType, ans, & - tsize) + MODULE PURE SUBROUTINE LegendreTransform2_(n, coeff, x, w, & + quadType, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: n - !! Order of Legendre polynomials - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:) - !! Value of function at quadrature points - !! size is number of quadrature points - REAL(DFP), INTENT(IN) :: PP(0:, 0:) - !! Quadrature points - !! These quadrature points are used in LegendreEvalAll method - !! number of rows in PP is number of quadrature points - !! number of columns in PP is n+1 - REAL(DFP), INTENT(IN) :: w(0:) - !! Weights - !! soze of w is number of quadrature points + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! values of function at quadrature points + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - REAL(DFP), INTENT(INOUT) :: ans(0:) - !! modal values or coefficients of Legendre polynomial - !! ans(0) is coefficient of P0 - !! ans(1) is coefficient of P1 - !! and so on - ! REAL(DFP) :: ans(0:n) - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size of ans - END SUBROUTINE LegendreTransform4_ + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! modal values or coefficients for each column of val + ! REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns writen in ans + END SUBROUTINE LegendreTransform2_ END INTERFACE LegendreTransform_ !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index a851dffd4..ac6b54e8d 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -22,14 +22,9 @@ !{!pages/LobattoPolynomialUtility.md!} MODULE LobattoPolynomialUtility -USE GlobalData, ONLY: I4B, DFP, LGT - -USE BaseType, ONLY: iface_1DFunction - +USE GlobalData IMPLICIT NONE - PRIVATE - PUBLIC :: LobattoLeadingCoeff PUBLIC :: LobattoZeros PUBLIC :: LobattoEval @@ -49,110 +44,6 @@ MODULE LobattoPolynomialUtility PUBLIC :: LobattoMassMatrix PUBLIC :: LobattoStiffnessMatrix -PUBLIC :: LobattoTransform_ - -PUBLIC :: Lobatto0, Lobatto1, Lobatto2, Lobatto3, Lobatto4, Lobatto5 - -PUBLIC :: Lobatto6, Lobatto7, Lobatto8, Lobatto9, Lobatto10 - -!---------------------------------------------------------------------------- -! LobattoTransform_ -!---------------------------------------------------------------------------- - -INTERFACE LobattoTransform_ - MODULE SUBROUTINE LobattoTransform1_(n, coeff, PP, w, quadType, ans, tsize) - INTEGER(I4B), INTENT(IN) :: n - !! Order of Legendre polynomials - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:) - !! Value of function at quadrature points - !! size of coeff is number of quadrature points - REAL(DFP), INTENT(IN) :: PP(0:, 0:) - !! Value of lobatto polynomials - !! PP(:, jj) value of Pjj at quadrature points - !! PP(ii, :) value of all lobatto polynomials at point ii - !! number of rows in PP is number of quadrature points - !! number of columns in PP is n+1 - REAL(DFP), INTENT(IN) :: w(0:) - !! Weights for each quadrature points - !! size of w is number of quadrature points - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type - !! Gauss, GaussLobatto, GaussRadau, GaussRadauLeft GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:) - !! modal values or coefficients of Legendre polynomial - !! ans(0) is coefficient of P0 - !! ans(1) is coefficient of P1 - !! and so on - ! REAL(DFP) :: ans(0:n) - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size of ans - END SUBROUTINE LobattoTransform1_ -END INTERFACE LobattoTransform_ - -!---------------------------------------------------------------------------- -! LobattoTransform_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-08-20 -! summary: LobattoTransform - -INTERFACE LobattoTransform_ - MODULE SUBROUTINE LobattoTransform2_(n, coeff, x, w, quadType, ans, & - tsize) - INTEGER(I4B), INTENT(IN) :: n - !! Order of Lobatto polynomials - !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:) - !! Value of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:) - !! Quadrature points - !! These quadrature points are used in LobattoEvalAll method - REAL(DFP), INTENT(IN) :: w(0:) - !! Weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:) - !! modal values or coefficients of Lobatto polynomial - !! ans(0) is coefficient of P0 - !! ans(1) is coefficient of P1 - !! and so on - ! REAL(DFP) :: ans(0:n) - INTEGER(I4B), INTENT(OUT) :: tsize - !! total size of ans - END SUBROUTINE LobattoTransform2_ -END INTERFACE LobattoTransform_ - -!---------------------------------------------------------------------------- -! LobattoTransform_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-08-20 -! summary: LobattoTransform of function - -INTERFACE LobattoTransform_ - MODULE SUBROUTINE LobattoTransform3_(n, f, quadType, x1, x2, ans, tsize) - INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial - PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f - !! 1D space function - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type - !! Gauss, GaussLobatto, GaussRadau, GaussRadauLeft GaussRadauRight - !! We will use Legendre quadrature points - REAL(DFP), INTENT(IN) :: x1, x2 - !! domain of function f - REAL(DFP), INTENT(INOUT) :: ans(0:) - !! modal values or coefficients - !! ans(0:n) - INTEGER(I4B), INTENT(OUT) :: tsize - !! n+1 - END SUBROUTINE LobattoTransform3_ -END INTERFACE LobattoTransform_ - !---------------------------------------------------------------------------- ! LobattoLeadingCoeff !---------------------------------------------------------------------------- @@ -637,127 +528,6 @@ MODULE PURE FUNCTION LobattoStiffnessMatrix(n) RESULT(ans) END FUNCTION LobattoStiffnessMatrix END INTERFACE -!---------------------------------------------------------------------------- -! Lobatto0 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto0(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto0 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto1 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto1(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto2 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto2(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto3 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto3(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto4 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto4(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto4 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto5 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto5(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto5 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto6 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto6(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto6 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto7 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto7(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto7 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto8 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto8(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto8 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto9 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto9(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto9 -END INTERFACE - -!---------------------------------------------------------------------------- -! Lobatto10 -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION Lobatto10(x) RESULT(ans) - REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - END FUNCTION Lobatto10 -END INTERFACE - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 index 410ea9655..5e22415c9 100644 --- a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 @@ -987,11 +987,11 @@ MODULE PURE SUBROUTINE UltrasphericalTransform1_(n, lambda, coeff, x, w, & !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: lambda !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:n) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -1009,33 +1009,57 @@ END SUBROUTINE UltrasphericalTransform1_ ! UltrasphericalTransform !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Ultraspherical Transform + +INTERFACE UltrasphericalTransform + MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION UltrasphericalTransform2 +END INTERFACE UltrasphericalTransform + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + INTERFACE UltrasphericalTransform_ - MODULE PURE SUBROUTINE UltrasphericalTransform4_(n, lambda, coeff, PP, w, & - quadType, ans, tsize) + MODULE PURE SUBROUTINE UltrasphericalTransform2_(n, lambda, coeff, x, w, & + quadType, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial + !! order of polynomial REAL(DFP), INTENT(IN) :: lambda !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:) + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) !! nodal value (at quad points) - !! size is number of quadrature points - REAL(DFP), INTENT(IN) :: PP(0:, 0:) + REAL(DFP), INTENT(IN) :: x(0:n) !! quadrature points - !! number of rows is number of quadrature points - !! number of columns is n+1 - REAL(DFP), INTENT(IN) :: w(0:) + REAL(DFP), INTENT(IN) :: w(0:n) !! weights - !! size of number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:) - !! ans(0:n) - !! modal values or coefficients - INTEGER(I4B), INTENT(OUT) :: tsize - !! size of ans - !! n + 1 - END SUBROUTINE UltrasphericalTransform4_ + REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) + !! ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! n+1, size(coeff, 2) + END SUBROUTINE UltrasphericalTransform2_ END INTERFACE UltrasphericalTransform_ !---------------------------------------------------------------------------- @@ -1119,7 +1143,7 @@ END SUBROUTINE UltrasphericalTransform3_ INTERFACE MODULE PURE FUNCTION UltrasphericalInvTransform1(n, lambda, coeff, x) & - RESULT(ans) + & RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: lambda diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 new file mode 100644 index 000000000..4e7c7ad5e --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 @@ -0,0 +1,121 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_Hierarchical) Methods +USE InputUtility, ONLY: Input + +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate + +USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE + +USE HierarchicalPolynomialUtility, ONLY: HierarchicalDOF, & + HierarchicalEvalAll_, & + HierarchicalGradientEvalAll_ + +USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & + QuadraturePoint_Size => Size + +USE BaseType, ONLY: TypeQuadratureOpt, & + TypePolynomialOpt + +USE SwapUtility, ONLY: SWAP_ + +USE Display_Method, ONLY: Display + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! ElemshapeData_InitiateHierarchical +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalElemShapeData1 +REAL(DFP), ALLOCATABLE :: temp(:, :, :) +INTEGER(I4B) :: ipType0, basisType0, nips, nns, ii, jj, kk + +! CALL DEALLOCATE (obj) + +nips = SIZE(quad%points, 2) +! pt = quad%points(1:quad%txi, 1:nips) +! wt = quad%points(quad%txi + 1, 1:nips) + +nns = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder) + +CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) + +obj%ws = quad%points(1 + xidim, 1:nips) + +ALLOCATE (temp(nips, nns, 3)) + +CALL HierarchicalEvalAll_(elemType=elemType, & + xij=quad%points(1:xidim, 1:nips), & + ans=temp(:, :, 1), nrow=ii, ncol=jj, & + domainName=domainName, & + cellOrder=cellOrder, & + faceOrder=faceOrder, & + edgeOrder=edgeOrder, & + cellOrient=cellOrient, & + faceOrient=faceOrient, & + edgeOrient=edgeOrient) + +DO CONCURRENT(ii=1:nns, jj=1:nips) + obj%N(ii, jj) = temp(jj, ii, 1) +END DO + +CALL HierarchicalGradientEvalAll_(elemType=elemType, & + xij=quad%points(1:xidim, 1:nips), ans=temp, & + dim1=ii, dim2=jj, dim3=kk, & + domainName=domainName, & + cellOrder=cellOrder, & + faceOrder=faceOrder, & + edgeOrder=edgeOrder, & + cellOrient=cellOrient, & + faceOrient=faceOrient, & + edgeOrient=edgeOrient) + +CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:kk), i1=2, i2=3, i3=1) +! CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=3, i2=1, i3=2) + +IF (ALLOCATED(temp)) DEALLOCATE (temp) + +END PROCEDURE HierarchicalElemShapeData1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalElemShapeData2 +CALL HierarchicalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & + xidim=refelem%xidimension, elemType=refelem%name, & + refelemCoord=refelem%xij, domainName=refelem%domainName, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +END PROCEDURE HierarchicalElemShapeData2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalElemShapeData3 +CALL HierarchicalElemShapeData2(obj=obj, quad=quad, refelem=refelem, & + cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +END PROCEDURE HierarchicalElemShapeData3 + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 new file mode 100644 index 000000000..3e22c4efd --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 @@ -0,0 +1,167 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_Lagrange) Methods +USE InputUtility, ONLY: Input + +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate + +USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE + +USE LagrangePolynomialUtility, ONLY: LagrangeDOF, & + InterpolationPoint_, & + LagrangeEvalAll, & + LagrangeEvalAll_, & + LagrangeGradientEvalAll_ + +USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & + QuadraturePoint_Size => Size + +USE BaseType, ONLY: TypeQuadratureOpt, & + TypePolynomialOpt + +USE SwapUtility, ONLY: SWAP_ + +USE Display_Method, ONLY: Display + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! ElemshapeData_InitiateLagrange +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeElemShapeData1 +REAL(DFP), ALLOCATABLE :: xij(:, :), coeff0(:, :), temp(:, :, :) +INTEGER(I4B) :: ipType0, basisType0, nips, nns, indx(10), ii, jj + +ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType) +basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType) + +! CALL DEALLOCATE (obj) + +nips = SIZE(quad%points, 2) +! pt = quad%points(1:quad%txi, 1:nips) +! wt = quad%points(quad%txi + 1, 1:nips) + +nns = LagrangeDOF(order=order, elemType=elemType) + +#ifdef DEBUG_VER +IF (nns .EQ. 0) THEN + CALL Display("Error: LagrangeDOF returned zero DOF") + STOP +END IF +#endif + +CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) + +obj%ws = quad%points(quad%txi + 1, 1:nips) + +ALLOCATE (xij(3, nns), temp(nips, nns, 3)) + +CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType0, & + layout="VEFC", xij=refelemCoord(1:xidim, :), alpha=alpha, beta=beta, & + lambda=lambda, ans=xij, nrow=indx(1), ncol=indx(2)) + +IF (PRESENT(coeff)) THEN + + CALL LagrangeEvalAll_(order=order, & + elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=domainName, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff(1:nns, 1:nns), firstCall=firstCall, & + ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2)) + + DO CONCURRENT(ii=1:nns, jj=1:nips) + obj%N(ii, jj) = temp(jj, ii, 1) + END DO + + CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=domainName, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff(1:nns, 1:nns), & + firstCall=.FALSE., & + ans=temp, & + dim1=indx(1), dim2=indx(2), dim3=indx(3)) + +ELSE + + ALLOCATE (coeff0(nns, nns)) + + ! obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, & + CALL LagrangeEvalAll_(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=domainName, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff0, firstCall=.TRUE., & + ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2)) + + obj%N(1:nns, 1:nips) = TRANSPOSE(temp(1:nips, 1:nns, 1)) + + ! dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, & + CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & + x=quad%points(1:quad%txi, 1:nips), & + xij=xij(1:xidim, :), & + domainName=domainName, & + basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + coeff=coeff0, firstCall=.FALSE., & + ans=temp, & + dim1=indx(1), dim2=indx(2), dim3=indx(3)) +END IF + +CALL SWAP_(a=obj%dNdXi, b=temp(1:indx(1), 1:indx(2), 1:indx(3)), i1=2, & + i2=3, i3=1) + +IF (ALLOCATED(temp)) DEALLOCATE (temp) +IF (ALLOCATED(xij)) DEALLOCATE (xij) +IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0) + +END PROCEDURE LagrangeElemShapeData1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeElemShapeData2 +CALL LagrangeElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & + xidim=refelem%xidimension, elemType=refelem%name, & + refelemCoord=refelem%xij, domainName=refelem%domainName, order=order, & + ipType=ipType, basisType=basisType, coeff=coeff, firstCall=firstCall, & + alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE LagrangeElemShapeData2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeElemShapeData3 +CALL LagrangeElemShapeData2(obj=obj, quad=quad, refelem=refelem, & + order=order, ipType=ipType, basisType=basisType, coeff=coeff, & + firstCall=firstCall, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE LagrangeElemShapeData3 + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Orthogonal@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Orthogonal@Methods.F90 new file mode 100644 index 000000000..c2e542cbe --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Orthogonal@Methods.F90 @@ -0,0 +1,99 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemShapeData_Orthogonal) Methods +USE LagrangePolynomialUtility, ONLY: LagrangeDOF + +USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE + +USE OrthogonalPolynomialUtility, ONLY: OrthogonalEvalAll_, & + OrthogonalGradientEvalAll_ + +USE SwapUtility, ONLY: SWAP_ + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! ElemshapeData_InitiateOrthogonal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalElemShapeData1 +REAL(DFP), ALLOCATABLE :: temp(:, :, :) +INTEGER(I4B) :: nips, nns, ii, jj, kk + +! CALL DEALLOCATE (obj) + +nips = SIZE(quad%points, 2) +! INFO: +! pt = quad%points(1:quad%txi, 1:nips) +! wt = quad%points(quad%txi + 1, 1:nips) + +nns = LagrangeDOF(elemType=elemType, order=order) + +CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) + +DO CONCURRENT(jj=1:nips) + obj%ws(jj) = quad%points(1 + xidim, jj) +END DO + +ALLOCATE (temp(nips, nns, 3)) + +CALL OrthogonalEvalAll_(elemType=elemType, xij=quad%points(1:xidim, 1:nips), & + ans=temp(:, :, 1), nrow=ii, ncol=jj, domainName=domainName, order=order, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) + +DO CONCURRENT(ii=1:nns, jj=1:nips) + obj%N(ii, jj) = temp(jj, ii, 1) +END DO + +CALL OrthogonalGradientEvalAll_(elemType=elemType, & + xij=quad%points(1:xidim, 1:nips), ans=temp, & + dim1=ii, dim2=jj, dim3=kk, & + domainName=domainName, order=order, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) + +CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:kk), i1=2, i2=3, i3=1) +! CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=3, i2=1, i3=2) + +DEALLOCATE (temp) + +END PROCEDURE OrthogonalElemShapeData1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalElemShapeData2 +CALL OrthogonalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & + xidim=refelem%xidimension, elemType=refelem%name, refelemCoord=refelem%xij, & + domainName=refelem%domainName, order=order, basisType=basisType, & + alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE OrthogonalElemShapeData2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalElemShapeData3 +CALL OrthogonalElemShapeData2(obj=obj, quad=quad, refelem=refelem, & + order=order, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE OrthogonalElemShapeData3 + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index a2c5ab5ab..48f8e8013 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -860,57 +860,87 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1Transform1_ -REAL(DFP), ALLOCATABLE :: PP(:, :) -INTEGER(I4B) :: ii, jj, nips -nips = SIZE(coeff) -ALLOCATE (PP(nips, n + 1)) +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: ii, jj +REAL(DFP) :: nrmsqr, areal +tsize = n + 1 CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) -CALL Chebyshev1Transform4_(n, coeff, PP, w, quadType, ans, tsize) -DEALLOCATE (PP) +DO jj = 0, n + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + nrmsqr = Chebyshev1NormSQR(n=jj) + ans(jj) = areal / nrmsqr +END DO + +IF (quadType .EQ. qp%GaussLobatto) THEN + areal = 0.0_DFP + jj = n + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO + + nrmsqr = pi + ans(jj) = areal / nrmsqr +END IF END PROCEDURE Chebyshev1Transform1_ !---------------------------------------------------------------------------- -! Chebyshev1Transform +! Chebyshev1Transform !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform4_ -INTEGER(I4B) :: ii, jj, nips -REAL(DFP) :: nrmsqr, areal -LOGICAL(LGT) :: abool +MODULE PROCEDURE Chebyshev1Transform2 +INTEGER(I4B) :: nrow, ncol +CALL Chebyshev1Transform2_(n, coeff, x, w, quadType, ans, nrow, ncol) +END PROCEDURE Chebyshev1Transform2 -tsize = n + 1 -nips = SIZE(coeff) +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- -DO jj = 0, n - areal = 0.0_DFP +MODULE PROCEDURE Chebyshev1Transform2_ +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: ii, jj, kk +REAL(DFP) :: nrmsqr, areal - DO ii = 0, nips - 1 - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) - END DO +nrow = n + 1 +ncol = SIZE(coeff, 2) - nrmsqr = Chebyshev1NormSQR(n=jj) - ans(jj) = areal / nrmsqr +CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +DO kk = 1, ncol + DO jj = 0, n + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, jj) + END DO + nrmsqr = Chebyshev1NormSQR(n=jj) + ans(jj, kk) = areal / nrmsqr + END DO END DO -abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) +IF (quadType .EQ. qp%GaussLobatto) THEN -IF (abool) THEN - areal = 0.0_DFP + nrmsqr = pi jj = n - DO ii = 0, nips - 1 - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + DO kk = 1, ncol + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + ans(jj, kk) = areal / nrmsqr END DO - nrmsqr = pi - ans(jj) = areal / nrmsqr END IF -END PROCEDURE Chebyshev1Transform4_ +END PROCEDURE Chebyshev1Transform2_ !---------------------------------------------------------------------------- ! Chebyshev1Transform @@ -947,32 +977,27 @@ ! Chebyshev1Transform4 !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform2 +MODULE PROCEDURE Chebyshev1Transform4 INTEGER(I4B) :: tsize -CALL Chebyshev1Transform2_(n, coeff, quadType, ans, tsize) -END PROCEDURE Chebyshev1Transform2 +CALL Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) +END PROCEDURE Chebyshev1Transform4 !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform2_ -INTEGER(I4B) :: ii, jj, nips +MODULE PROCEDURE Chebyshev1Transform4_ +INTEGER(I4B) :: ii, jj REAL(DFP) :: avar, asign, pi_by_n, one_by_n REAL(DFP), PARAMETER :: half = 0.5_DFP, minusOne = -1.0_DFP -LOGICAL(LGT) :: abool tsize = n + 1 ans(1:tsize) = 0.0_DFP -nips = SIZE(coeff) - one_by_n = 1.0_DFP / REAL(n, KIND=DFP) pi_by_n = pi * one_by_n -abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) - -IF (abool) THEN +IF (quadType .EQ. qp%GaussLobatto) THEN DO jj = 0, n @@ -980,7 +1005,7 @@ ans(jj) = coeff(0) * half + coeff(n) * half * asign - DO ii = 1, nips - 1 + DO ii = 1, n - 1 ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi_by_n * ii) END DO @@ -1000,7 +1025,7 @@ avar = jj * pi_by_n - DO ii = 0, nips - 1 + DO ii = 0, n ans(jj) = ans(jj) + coeff(ii) * COS((2.0 * ii + 1.0) * avar) END DO @@ -1012,7 +1037,7 @@ END IF -END PROCEDURE Chebyshev1Transform2_ +END PROCEDURE Chebyshev1Transform4_ !---------------------------------------------------------------------------- ! Chebyshev1InvTransform @@ -1035,28 +1060,28 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GradientCoeff1 -REAL(DFP) :: c +REAL(DFP) :: a, b, c INTEGER(I4B) :: ii REAL(DFP) :: jj - +!! ans(n) = 0.0_DFP IF (n .EQ. 0) RETURN - +!! IF (n .EQ. 1) THEN c = 2.0_DFP ELSE c = 1.0_DFP END IF - +!! ans(n - 1) = 2.0_DFP * n * coeff(n) / c - +!! DO ii = n - 1, 1, -1 jj = REAL(ii, KIND=DFP) ans(ii - 1) = 2.0_DFP * jj * coeff(ii) + ans(ii + 1) END DO - +!! ans(0) = 0.5_DFP * ans(0) - +!! END PROCEDURE Chebyshev1GradientCoeff1 !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index ac43e61c7..10119088c 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -1227,33 +1227,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiTransform1_ -REAL(DFP), ALLOCATABLE :: PP(:, :) -INTEGER(I4B) :: ii, jj, nips -nips = SIZE(coeff) -ALLOCATE (PP(nips, n + 1)) -CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, nrow=ii, ncol=jj, & - ans=PP) -CALL JacobiTransform4_(n, alpha, beta, coeff, PP, w, quadType, ans, tsize) -DEALLOCATE (PP) -END PROCEDURE JacobiTransform1_ - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform4_ +REAL(DFP), DIMENSION(0:n, 0:n) :: PP REAL(DFP) :: nrmsqr, areal -INTEGER(I4B) :: jj, ii, nips -LOGICAL(LGT) :: abool +INTEGER(I4B) :: jj, ii tsize = n + 1 -nips = SIZE(coeff) +PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) DO jj = 0, n areal = 0.0_DFP - DO ii = 0, nips - 1 + DO ii = 0, n areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO @@ -1262,13 +1247,11 @@ END DO -abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) - -IF (abool) THEN +IF (quadType .EQ. qp%GaussLobatto) THEN areal = 0.0_DFP jj = n - DO ii = 0, nips - 1 + DO ii = 0, n areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO @@ -1278,7 +1261,65 @@ END IF -END PROCEDURE JacobiTransform4_ +END PROCEDURE JacobiTransform1_ + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform2 +INTEGER(I4B) :: nrow, ncol +CALL JacobiTransform2_(n, alpha, beta, coeff, x, w, quadType, ans, nrow, ncol) +END PROCEDURE JacobiTransform2 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform2_ +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +REAL(DFP) :: nrmsqr, areal +INTEGER(I4B) :: jj, ii, kk + +nrow = n + 1 +ncol = SIZE(coeff, 2) + +PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) + +DO kk = 1, ncol + DO jj = 0, n + + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + nrmsqr = JacobiNormSQR(n=jj, alpha=alpha, beta=beta) + ans(jj, kk) = areal / nrmsqr + + END DO +END DO + +IF (quadType .EQ. qp%GaussLobatto) THEN + + jj = n + + nrmsqr = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) * nrmsqr + + DO kk = 1, ncol + + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + ans(jj, kk) = areal / nrmsqr + END DO + +END IF + +END PROCEDURE JacobiTransform2_ !---------------------------------------------------------------------------- ! JacobiTransform diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index 2f3638d6b..2e2ee5b59 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -33,8 +33,6 @@ USE BaseType, ONLY: qp => TypeQuadratureOpt -USE GlobalData, ONLY: stderr - IMPLICIT NONE CONTAINS @@ -174,14 +172,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussQuadrature -#ifdef USE_LAPACK95 -REAL(DFP) :: fixvar -REAL(DFP) :: pn(n) +REAL(DFP) :: pn(n), fixvar INTEGER(I4B) :: ii -#endif -#ifdef USE_LAPACK95 CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) + +#ifdef USE_LAPACK95 CALL STEV(D=pt, E=pn) IF (PRESENT(wt)) THEN @@ -198,7 +194,7 @@ file=__FILE__, & routine="LegendreGaussQuadrature", & line=__LINE__, & - unitno=stderr) + unitno=stdout) #endif END PROCEDURE LegendreGaussQuadrature @@ -208,7 +204,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreJacobiRadauMatrix -REAL(DFP) :: r1, r2 +REAL(DFP) :: avar, r1, r2 IF (n .LT. 1) RETURN @@ -231,32 +227,34 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussRadauQuadrature -#ifdef USE_LAPACK95 REAL(DFP) :: pn(n + 1), fixvar INTEGER(I4B) :: ii - + !! CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=pn) +!! +#ifdef USE_LAPACK95 +!! CALL STEV(D=pt, E=pn) - +!! IF (PRESENT(wt)) THEN wt = pn pn = LegendreEval(n=n, x=pt) fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) - + !! DO ii = 1, n + 1 wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) END DO END IF - + !! #else - -CALL ErrorMsg(msg="The subroutine requires Lapack95 package", & - file=__FILE__, & - routine="LegendreGaussRadauQuadrature", & - line=__LINE__, & - unitno=stderr) +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="LegendreGaussRadauQuadrature", & + & line=__LINE__, & + & unitno=stdout) #endif - + !! END PROCEDURE LegendreGaussRadauQuadrature !---------------------------------------------------------------------------- @@ -264,24 +262,24 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreJacobiLobattoMatrix - + !! REAL(DFP) :: r1, r2 - + !! IF (n .LT. 0) RETURN - + !! CALL LegendreJacobiMatrix( & & n=n + 1, & & D=D, & & E=E, & & alphaCoeff=alphaCoeff, & & betaCoeff=betaCoeff) - + !! D(n + 2) = 0.0_DFP r1 = REAL(n + 1, KIND=DFP) r2 = REAL(2 * n + 1, KIND=DFP) - + !! E(n + 1) = SQRT(r1 / r2) - + !! END PROCEDURE LegendreJacobiLobattoMatrix !---------------------------------------------------------------------------- @@ -289,33 +287,34 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussLobattoQuadrature -#ifdef USE_LAPACK95 REAL(DFP) :: pn(n + 2), fixvar INTEGER(I4B) :: ii - +!! CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=pn) - +!! +#ifdef USE_LAPACK95 +!! CALL STEV(D=pt, E=pn) - +!! IF (PRESENT(wt)) THEN wt = pn pn = LegendreEval(n=n + 1, x=pt) fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) - + !! DO ii = 1, n + 2 wt(ii) = fixvar / (pn(ii)**2) END DO END IF - + !! #else CALL ErrorMsg( & & msg="The subroutine requires Lapack95 package", & & file=__FILE__, & & routine="LegendreGaussLobattoQuadrature", & & line=__LINE__, & - & unitno=stderr) + & unitno=stdout) #endif - + !! END PROCEDURE LegendreGaussLobattoQuadrature !---------------------------------------------------------------------------- @@ -335,21 +334,21 @@ REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP REAL(DFP), ALLOCATABLE :: p(:), w(:) LOGICAL(LGT) :: inside - +!! IF (PRESENT(onlyInside)) THEN inside = onlyInside ELSE inside = .FALSE. END IF - +!! SELECT CASE (QuadType) CASE (qp%Gauss) - + !! order = n CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt) - + !! CASE (qp%GaussRadau, qp%GaussRadauLeft) - + !! IF (inside) THEN order = n ALLOCATE (p(n + 1), w(n + 1)) @@ -360,9 +359,9 @@ order = n - 1 CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) END IF - + !! CASE (qp%GaussRadauRight) - + !! IF (inside) THEN order = n ALLOCATE (p(n + 1), w(n + 1)) @@ -372,9 +371,9 @@ order = n - 1 CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) END IF - + !! CASE (qp%GaussLobatto) - + !! IF (inside) THEN order = n ALLOCATE (p(n + 2), w(n + 2)) @@ -394,33 +393,33 @@ MODULE PROCEDURE LegendreEval1 INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i, ans_1, ans_2 - +!! ans = 0.0_DFP - +!! IF (n < 0) THEN RETURN END IF - +!! ans = 1.0_DFP ans_2 = ans - +!! IF (n .EQ. 0) THEN RETURN END IF - +!! ans = x - +!! DO i = 1, n - 1 - + !! r_i = REAL(i, kind=DFP) c1 = r_i + 1.0_DFP c2 = 2.0_DFP * r_i + 1.0_DFP c3 = -r_i - + !! ans_1 = ans ans = ((c2 * x) * ans + c3 * ans_2) / c1 ans_2 = ans_1 - + !! END DO END PROCEDURE LegendreEval1 @@ -432,33 +431,33 @@ INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 - +!! ans = 0.0_DFP - +!! IF (n < 0) THEN RETURN END IF - +!! ans = 1.0_DFP ans_2 = ans - +!! IF (n .EQ. 0) THEN RETURN END IF - +!! ans = x - +!! DO i = 1, n - 1 - + !! r_i = REAL(i, kind=DFP) c1 = r_i + 1.0_DFP c2 = 2.0_DFP * r_i + 1.0_DFP c3 = -r_i - + !! ans_1 = ans ans = ((c2 * x) * ans + c3 * ans_2) / c1 ans_2 = ans_1 - + !! END DO END PROCEDURE LegendreEval2 @@ -556,30 +555,30 @@ MODULE PROCEDURE LegendreMonomialExpansionAll REAL(DFP) :: r_i INTEGER(I4B) :: ii - + !! IF (n < 0) THEN RETURN END IF - +!! ans = 0.0_DFP ans(1, 1) = 1.0_DFP - + !! IF (n .EQ. 0) THEN RETURN END IF - + !! ans(2, 2) = 1.0_DFP - + !! DO ii = 2, n - + !! r_i = REAL(ii, KIND=DFP) - + !! ans(1:ii - 1, ii + 1) = & & (-r_i + 1.0) * ans(1:ii - 1, ii - 1) / r_i - + !! ans(2:ii + 1, ii + 1) = ans(2:ii + 1, ii + 1) & & + (2.0 * r_i - 1.0) * ans(1:ii, ii) / r_i - + !! END DO END PROCEDURE LegendreMonomialExpansionAll @@ -690,46 +689,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEval1 - + !! INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP) :: p, p_1, p_2 REAL(DFP) :: ans_1, ans_2 - +!! IF (n < 0) THEN RETURN END IF - +!! p = 1.0_DFP ans = 0.0_DFP p_2 = p ans_2 = ans - +!! IF (n < 1) THEN RETURN END IF - +!! p = x ans = 1.0_DFP - +!! DO ii = 2, n - + !! r_ii = REAL(ii, KIND=DFP) - + !! p_1 = p - + !! p = ((2.0_DFP * r_ii - 1) * x * p & & - (r_ii - 1.0_DFP) * p_2) & & / r_ii - + !! p_2 = p_1 - + !! ans_1 = ans ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 ans_2 = ans_1 - + !! END DO - +!! END PROCEDURE LegendreGradientEval1 !---------------------------------------------------------------------------- @@ -737,46 +736,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEval2 - +!! INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 - +!! IF (n < 0) THEN RETURN END IF - +!! p = 1.0_DFP ans = 0.0_DFP p_2 = p ans_2 = ans - +!! IF (n < 1) THEN RETURN END IF - +!! p = x ans = 1.0_DFP - +!! DO ii = 2, n - + !! r_ii = REAL(ii, KIND=DFP) - + !! p_1 = p - + !! p = ((2.0_DFP * r_ii - 1) * x * p & & - (r_ii - 1.0_DFP) * p_2) & & / r_ii - + !! p_2 = p_1 - + !! ans_1 = ans ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 ans_2 = ans_1 - + !! END DO - +!! END PROCEDURE LegendreGradientEval2 !---------------------------------------------------------------------------- @@ -787,21 +786,21 @@ REAL(DFP) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i - +!! IF (n .LT. 0) RETURN - +!! b1 = 0.0_DFP b2 = 0.0_DFP - +!! DO j = n, 1, -1 i = REAL(j, KIND=DFP) t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) b2 = b1 b1 = t END DO - +!! ans = x * b1 - b2 / 2.0_DFP + coeff(0) - +!! END PROCEDURE LegendreEvalSum1 !---------------------------------------------------------------------------- @@ -812,21 +811,21 @@ REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i - +!! IF (n .LT. 0) RETURN - +!! b1 = 0.0_DFP b2 = 0.0_DFP - +!! DO j = n, 1, -1 i = REAL(j, KIND=DFP) t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) b2 = b1 b1 = t END DO - +!! ans = x * b1 - b2 / 2.0_DFP + coeff(0) - +!! END PROCEDURE LegendreEvalSum2 !---------------------------------------------------------------------------- @@ -837,12 +836,12 @@ REAL(DFP) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i - +!! IF (n .LT. 0) RETURN - +!! b1 = 0 b2 = 0 - +!! DO j = n - 1, 0, -1 i = REAL(j, KIND=DFP) t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); @@ -860,12 +859,12 @@ REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i - +!! IF (n .LT. 0) RETURN - +!! b1 = 0 b2 = 0 - +!! DO j = n - 1, 0, -1 i = REAL(j, KIND=DFP) t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); @@ -884,17 +883,17 @@ REAL(DFP) :: s, A1, A2 INTEGER(I4B) :: j REAL(DFP) :: i - +!! IF (n .LT. 0) RETURN - +!! b1 = 0 b2 = 0 s = 1.0_DFP - +!! DO j = 2 * k - 1, 1, -2 s = j * s END DO - +!! DO j = n - k, 0, -1 i = REAL(j, KIND=DFP) A1 = (2 * i + 2 * k + 1) / (i + 1) * x; @@ -915,26 +914,26 @@ REAL(DFP) :: s, A2 INTEGER(I4B) :: j REAL(DFP) :: i - +!! IF (n .LT. 0) RETURN - +!! b1 = 0 b2 = 0 s = 1.0_DFP - +!! DO j = 2 * k - 1, 1, -2 s = j * s END DO - +!! DO j = n - k, 0, -1 i = REAL(j, KIND=DFP) - A1 = (2 * i + 2 * k + 1) / (i + 1) * x - A2 = -(i + 2 * k + 1) / (i + 2) - t = A1 * b1 + A2 * b2 + coeff(j + k) - b2 = b1 - b1 = t + A1 = (2 * i + 2 * k + 1) / (i + 1) * x; + A2 = -(i + 2 * k + 1) / (i + 2); + t = A1 * b1 + A2 * b2 + coeff(j + k); + b2 = b1; + b1 = t; END DO - +!! ans = s * b1 END PROCEDURE LegendreGradientEvalSum4 @@ -953,51 +952,92 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreTransform1_ -REAL(DFP), ALLOCATABLE :: PP(:, :) -INTEGER(I4B) :: ii, jj, nips -nips = SIZE(coeff) -ALLOCATE (PP(nips, n + 1)) - -CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) -CALL LegendreTransform4_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, & - ans=ans, tsize=tsize) -DEALLOCATE (PP) -END PROCEDURE LegendreTransform1_ - -!---------------------------------------------------------------------------- -! LegendreTransform4_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform4_ -INTEGER(I4B) :: ii, jj, nips +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: ii, jj REAL(DFP) :: nrmsqr, areal -LOGICAL(LGT) :: abool tsize = n + 1 -nips = SIZE(coeff) + +! PP = LegendreEvalAll(n=n, x=x) +CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) DO jj = 0, n areal = 0.0_DFP - DO ii = 0, nips - 1 + DO ii = 0, n areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO nrmsqr = LegendreNormSQR(n=jj) ans(jj) = areal / nrmsqr END DO -abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) - -IF (abool) THEN +IF (quadType .EQ. qp%GaussLobatto) THEN areal = 0.0_DFP jj = n - DO ii = 0, nips - 1 + DO ii = 0, n areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) ans(jj) = areal / nrmsqr END IF -END PROCEDURE LegendreTransform4_ + +END PROCEDURE LegendreTransform1_ + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform2 +INTEGER(I4B) :: ii, jj +CALL LegendreTransform2_(n=n, coeff=coeff, x=x, w=w, quadType=quadType, & + ans=ans, nrow=ii, ncol=jj) +END PROCEDURE LegendreTransform2 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform2_ +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: ii, jj, kk +REAL(DFP) :: nrmsqr, areal + +nrow = n + 1 +ncol = SIZE(coeff, 2) + +CALL LegendreEvalAll_(n=n, x=x, nrow=ii, ncol=jj, ans=PP) + +DO kk = 1, ncol + DO jj = 0, n + + areal = 0.0_DFP + + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + nrmsqr = LegendreNormSQR(n=jj) + ans(jj, kk) = areal / nrmsqr + + END DO +END DO + +IF (quadType .EQ. qp%GaussLobatto) THEN + + jj = n + nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) + + DO kk = 1, ncol + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + ans(jj, kk) = areal / nrmsqr + END DO + +END IF + +END PROCEDURE LegendreTransform2_ !---------------------------------------------------------------------------- ! LegendreTransform @@ -1074,32 +1114,33 @@ PURE SUBROUTINE LegendreDMatrixGL(n, x, D) INTEGER(I4B), INTENT(IN) :: n - ! order of Jacobi polynomial + !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - ! quadrature points + !! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - ! D matrix - - ! main + !! D matrix + !! + !! main + !! REAL(DFP) :: J(0:n) REAL(DFP) :: rn INTEGER(I4B) :: ii, jj - + !! rn = REAL(n, KIND=DFP) - + !! J = LegendreEval(n=n, x=x) - + !! D = 0.0_DFP D(0, 0) = 0.125_DFP * rn * (rn + 1.0_DFP) D(n, n) = -D(0, 0) - + !! DO jj = 0, n DO ii = 0, n IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - + !! END SUBROUTINE LegendreDMatrixGL !---------------------------------------------------------------------------- @@ -1108,45 +1149,45 @@ END SUBROUTINE LegendreDMatrixGL PURE SUBROUTINE LegendreDMatrixGL2(n, x, D) INTEGER(I4B), INTENT(IN) :: n - ! order of Jacobi polynomial + !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - ! quadrature points + !! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - ! D matrix - - ! main - + !! D matrix + !! + !! main + !! REAL(DFP) :: J(0:n) REAL(DFP) :: rn INTEGER(I4B) :: ii, jj, nb2 - + !! nb2 = INT(n / 2) rn = REAL(n, KIND=DFP) - + !! J = LegendreEval(n=n, x=x) D = 0.0_DFP - + !! DO jj = 0, n DO ii = 0, nb2 IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - - ! correct diagonal entries - + !! + !! correct diagonal entries + !! DO ii = 0, nb2 D(ii, ii) = -SUM(D(ii, :)) END DO - ! - ! copy - + !! + !! copy + !! DO jj = 0, n DO ii = 0, nb2 D(n - ii, n - jj) = -D(ii, jj) END DO END DO - + !! END SUBROUTINE LegendreDMatrixGL2 !---------------------------------------------------------------------------- @@ -1155,21 +1196,21 @@ END SUBROUTINE LegendreDMatrixGL2 PURE SUBROUTINE LegendreDMatrixG(n, x, D) INTEGER(I4B), INTENT(IN) :: n - ! order of Jacobi polynomial + !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - ! quadrature points + !! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - ! D matrix - - ! main - + !! D matrix + !! + !! main + !! REAL(DFP) :: J(0:n) INTEGER(I4B) :: ii, jj - - ! Compute dJ_{N-1}(a+1,b+1) - + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! J = LegendreGradientEval(n=n + 1, x=x) - + !! DO jj = 0, n DO ii = 0, n IF (ii .EQ. jj) THEN @@ -1179,7 +1220,7 @@ PURE SUBROUTINE LegendreDMatrixG(n, x, D) END IF END DO END DO - +!! END SUBROUTINE LegendreDMatrixG !---------------------------------------------------------------------------- @@ -1188,40 +1229,45 @@ END SUBROUTINE LegendreDMatrixG PURE SUBROUTINE LegendreDMatrixG2(n, x, D) INTEGER(I4B), INTENT(IN) :: n - ! order of Jacobi polynomial + !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - ! quadrature points + !! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - ! D matrix - - ! internal variables + !! D matrix + !! + !! internal variables + !! REAL(DFP) :: J(0:n) INTEGER(I4B) :: ii, jj, nb2 - - ! main + !! + !! main + !! nb2 = INT(n / 2) D = 0.0_DFP - + !! J = LegendreGradientEval(n=n + 1, x=x) - + !! DO jj = 0, n DO ii = 0, nb2 IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - - ! correct diagonal entries + !! + !! correct diagonal entries + !! DO ii = 0, nb2 D(ii, ii) = -SUM(D(ii, :)) END DO - - ! copy + !! + !! copy + !! DO jj = 0, n DO ii = 0, nb2 D(n - ii, n - jj) = -D(ii, jj) END DO END DO + !! END SUBROUTINE LegendreDMatrixG2 !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 index c06f05c04..3dff6e8c6 100644 --- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -16,96 +16,17 @@ ! SUBMODULE(LobattoPolynomialUtility) Methods -USE Sym_LinearSolveMethods, ONLY: SymLinSolve - -USE LegendrePolynomialUtility, ONLY: LegendreLeadingCoeff, & - LegendreNormSqr, & - LegendreEval, & - LegendreEvalAll_, & - LegendreMonomialExpansionAll, & - LegendreQuadrature - -USE JacobiPolynomialUtility, ONLY: JacobiZeros - -USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalEvalAll_, & - UltrasphericalGradientEvalAll_, & - UltrasphericalGradientEvalAll - +USE BaseMethod IMPLICIT NONE CONTAINS -!---------------------------------------------------------------------------- -! LobattoTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoTransform1_ -INTEGER(I4B) :: ii, jj, nips -REAL(DFP) :: areal(0:n), massmat(0:n, 0:n) - -tsize = n + 1 -areal = 0.0_DFP -nips = SIZE(coeff) - -DO jj = 0, n - DO ii = 0, nips - 1 - areal(jj) = areal(jj) + PP(ii, jj) * w(ii) * coeff(ii) - END DO -END DO - -massmat = LobattoMassMatrix(n=n) - -CALL SymLinSolve(X=ans(0:n), A=massmat(0:n, 0:n), B=areal(0:n)) - -END PROCEDURE LobattoTransform1_ - -!---------------------------------------------------------------------------- -! LobattoTransform_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoTransform2_ -REAL(DFP), ALLOCATABLE :: PP(:, :) -INTEGER(I4B) :: ii, jj, nips - -nips = SIZE(coeff) -ALLOCATE (PP(nips, n + 1)) -CALL LobattoEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) -CALL LobattoTransform_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, & - ans=ans, tsize=tsize) -DEALLOCATE (PP) -END PROCEDURE LobattoTransform2_ - -!---------------------------------------------------------------------------- -! LobattoTransform_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LobattoTransform3_ -REAL(DFP) :: pt(0:n + 1), wt(0:n + 1), coeff(0:n + 1), x -REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP -INTEGER(I4B) :: ii, nips - -nips = n + 2 -CALL LegendreQuadrature(n=nips, pt=pt, wt=wt, quadType=quadType) -!! We are using n+2 quadrature points as it works well in case of -!! GaussLobatto quadrature points also - -DO ii = 0, nips - 1 - x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2 - x = x * half - coeff(ii) = f(x) -END DO - -CALL LobattoTransform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, & - ans=ans, tsize=tsize) - -END PROCEDURE LobattoTransform3_ - !---------------------------------------------------------------------------- ! LobattoLeadingCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE LobattoLeadingCoeff REAL(DFP) :: avar, m - + !! SELECT CASE (n) CASE (0) ans = 0.5_DFP @@ -459,6 +380,7 @@ ans(1:nrow, 1) = -0.5_DFP ans(1:nrow, 2) = 0.5_DFP + !! p = LegendreEvalAll(n=n - 1_I4B, x=x) CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, nrow=nrow, ncol=ii) DO ii = 1, n - 1 @@ -587,66 +509,6 @@ END PROCEDURE LobattoStiffnessMatrix -!---------------------------------------------------------------------------- -! Lobatto0 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Lobatto0 -ans = 0.5_DFP * (1.0_DFP - x) -END PROCEDURE Lobatto0 - -MODULE PROCEDURE Lobatto1 -ans = 0.5_DFP * (1.0_DFP + x) -END PROCEDURE Lobatto1 - -MODULE PROCEDURE Lobatto2 -REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(3.0_DFP) / SQRT(2.0_DFP) -ans = coeff * (x**2 - 1.0_DFP) -END PROCEDURE Lobatto2 - -MODULE PROCEDURE Lobatto3 -REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(5.0_DFP) / SQRT(2.0_DFP) -ans = coeff * (x**2 - 1.0_DFP) * x -END PROCEDURE Lobatto3 - -MODULE PROCEDURE Lobatto4 -REAL(DFP), PARAMETER :: coeff = SQRT(7.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP -ans = coeff * (x**2 - 1.0_DFP) * (5.0_DFP * x**2 - 1.0_DFP) -END PROCEDURE Lobatto4 - -MODULE PROCEDURE Lobatto5 -REAL(DFP), PARAMETER :: coeff = SQRT(9.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP -ans = coeff * (x**2 - 1.0_DFP) * (7.0_DFP * x**2 - 3.0_DFP) * x -END PROCEDURE Lobatto5 - -MODULE PROCEDURE Lobatto6 -REAL(DFP), PARAMETER :: coeff = SQRT(11.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP -ans = coeff * (x**2 - 1.0_DFP) * (21.0_DFP * x**4 - 14.0_DFP * x**2 + 1.0_DFP) -END PROCEDURE Lobatto6 - -MODULE PROCEDURE Lobatto7 -REAL(DFP), PARAMETER :: coeff = SQRT(13.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP -ans = coeff * (x**2 - 1.0_DFP) * (33.0_DFP * x**4 - 30.0_DFP * x**2 + 5.0_DFP) * x -END PROCEDURE Lobatto7 - -MODULE PROCEDURE Lobatto8 -REAL(DFP), PARAMETER :: coeff = SQRT(15.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP -ans = coeff * (x**2 - 1.0_DFP) * (429.0_DFP * x**6 - 495.0_DFP * x**4 & - + 135.0_DFP * x**2 - 5.0_DFP) -END PROCEDURE Lobatto8 - -MODULE PROCEDURE Lobatto9 -REAL(DFP), PARAMETER :: coeff = SQRT(17.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP -ans = coeff * (x**2 - 1.0_DFP) * (715.0_DFP * x**6 - 1001.0_DFP * x**4 & - + 385.0_DFP * x**2 - 35.0_DFP) * x -END PROCEDURE Lobatto9 - -MODULE PROCEDURE Lobatto10 -REAL(DFP), PARAMETER :: coeff = SQRT(19.0_DFP) / SQRT(2.0_DFP) / 256.0_DFP -ans = coeff * (x**2 - 1.0_DFP) * (2431.0_DFP * x**8 - 4004.0_DFP * x**6 & - + 2002.0_DFP * x**4 - 308.0_DFP * x**2 + 7.0_DFP) -END PROCEDURE Lobatto10 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 index 2b580884c..833c4ea2e 100644 --- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -869,11 +869,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE UltrasphericalTransform1_ +REAL(DFP), DIMENSION(0:n, 0:n) :: PP REAL(DFP) :: nrmsqr, areal, rn -REAL(DFP), ALLOCATABLE :: PP(:, :) -INTEGER(I4B) :: ii, jj, nips -nips = SIZE(coeff) -ALLOCATE (PP(nips, n + 1)) +INTEGER(I4B) :: jj, ii tsize = n + 1 @@ -906,52 +904,63 @@ END IF -DEALLOCATE (PP) - END PROCEDURE UltrasphericalTransform1_ !---------------------------------------------------------------------------- ! UltrasphericalTransform !---------------------------------------------------------------------------- -MODULE PROCEDURE UltrasphericalTransform4_ -REAL(DFP) :: nrmsqr, areal, rn -INTEGER(I4B) :: jj, ii, nips -LOGICAL(LGT) :: abool +MODULE PROCEDURE UltrasphericalTransform2 +INTEGER(I4B) :: nrow, ncol +CALL UltrasphericalTransform2_(n, lambda, coeff, x, w, quadType, ans, nrow, & + ncol) +END PROCEDURE UltrasphericalTransform2 -tsize = n + 1 -nips = SIZE(coeff) +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- -DO jj = 0, n - areal = 0.0_DFP +MODULE PROCEDURE UltrasphericalTransform2_ +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +REAL(DFP) :: nrmsqr, areal, rn +INTEGER(I4B) :: jj, ii, kk - DO ii = 0, nips - 1 - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) - END DO +nrow = n + 1 +ncol = SIZE(coeff, 2) - nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) - ans(jj) = areal / nrmsqr +CALL UltrasphericalEvalAll_(n=n, lambda=lambda, x=x, ans=PP, nrow=ii, ncol=jj) -END DO +DO kk = 1, ncol + DO jj = 0, n + areal = 0.0_DFP -abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO -IF (abool) THEN + nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) + ans(jj, kk) = areal / nrmsqr - areal = 0.0_DFP - jj = n - DO ii = 0, nips - 1 - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO +END DO +IF (quadType .EQ. qp%GaussLobatto) THEN + jj = n rn = REAL(n, KIND=DFP) nrmsqr = 2.0_DFP * (rn + lambda) / rn * nrmsqr - ans(jj) = areal / nrmsqr + DO kk = 1, ncol + areal = 0.0_DFP + DO ii = 0, n + areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) + END DO + + ans(jj, kk) = areal / nrmsqr + END DO END IF -END PROCEDURE UltrasphericalTransform4_ +END PROCEDURE UltrasphericalTransform2_ !---------------------------------------------------------------------------- ! UltrasphericalTransform From bd8d3e78901227171cf21836fb271d325b535efa Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:43:18 +0900 Subject: [PATCH 325/359] update in BaseInterpolation --- .../src/BaseInterpolation_Method.F90 | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 index 79ddf60c0..a97d6691e 100644 --- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 +++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 @@ -198,6 +198,18 @@ FUNCTION BaseType_ToInteger1(name) RESULT(ans) CASE ("ORTH") ans = poly%orthogonal + CASE ("LEGE") + ans = poly%legendre + + CASE ("JACO") + ans = poly%jacobi + + CASE ("ULTR") + ans = poly%ultraspherical + + CASE ("CHEB") + ans = poly%chebyshev + CASE DEFAULT CALL ErrorMsg(msg="NO CASE FOUND for name: "//astr, & routine="BaseType_ToInteger1()", & @@ -445,6 +457,18 @@ FUNCTION BaseType_ToChar(name) RESULT(ans) CASE (poly%orthogonal) ans = "OrthogonalInterpolation" + CASE (poly%legendre) + ans = "LegendreInterpolation" + + CASE (poly%jacobi) + ans = "JacobiInterpolation" + + CASE (poly%ultraspherical) + ans = "UltrasphericalInterpolation" + + CASE (poly%chebyshev) + ans = "ChebyshevInterpolation" + CASE DEFAULT CALL ErrorMsg(msg="No Case Found For name "//tostring(name), & routine="BaseType_ToChar()", & From a7c45b4e1e5f30329bf2311d37ed947819dac0cb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:43:29 +0900 Subject: [PATCH 326/359] update in CInterface --- src/modules/CInterface/src/CInterface.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/CInterface/src/CInterface.F90 b/src/modules/CInterface/src/CInterface.F90 index ae30ad133..a52bc6332 100644 --- a/src/modules/CInterface/src/CInterface.F90 +++ b/src/modules/CInterface/src/CInterface.F90 @@ -18,8 +18,8 @@ MODULE CInterface USE GlobalData USE String_Class, ONLY: String USE, INTRINSIC :: ISO_C_BINDING, C_PTR => C_PTR, & - & C_CHAR_PTR => C_PTR, C_CONST_CHAR_PTR => C_PTR, & - & C_void_ptr => C_PTR, C_CONST_VOID_PTR => C_PTR + C_CHAR_PTR => C_PTR, C_CONST_CHAR_PTR => C_PTR, & + C_void_ptr => C_PTR, C_CONST_VOID_PTR => C_PTR IMPLICIT NONE PRIVATE From 66bd9fd0523907e0b9d03aecdbb88fd143aba248 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:43:50 +0900 Subject: [PATCH 327/359] update in csrmatrix --- .../CSRMatrix/src/CSRMatrix_DBCMethods.F90 | 2 +- .../CSRMatrix/src/CSRMatrix_MatVecMethods.F90 | 22 +++++++++-- .../CSRMatrix/src/CSRMatrix_Method.F90 | 38 +++++++++---------- 3 files changed, 39 insertions(+), 23 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 index ee8c251ca..1b7dc5f2a 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 @@ -17,7 +17,7 @@ MODULE CSRMatrix_DBCMethods USE BaseType, ONLY: CSRMatrix_ -USE GlobalData, ONLY: I4B +USE GlobalData, ONLY: I4B, LGT, DFP IMPLICIT NONE PRIVATE PUBLIC :: ApplyDBC diff --git a/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 index 674e73388..2014bc6bb 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 @@ -17,7 +17,7 @@ MODULE CSRMatrix_MatVecMethods USE GlobalData, ONLY: I4B, DFP, LGT -USE BaseType, ONLY: CSRMatrix_ +USE BaseType, ONLY: CSRMatrix_, RealVector_ IMPLICIT NONE PRIVATE @@ -216,7 +216,7 @@ END SUBROUTINE csrMat_AtMatvec INTERFACE MatVec MODULE SUBROUTINE csrMat_MatVec1(obj, x, y, isTranspose, addContribution, & - & scale) + scale) TYPE(CSRMatrix_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: x(:) REAL(DFP), INTENT(INOUT) :: y(:) @@ -240,7 +240,7 @@ END SUBROUTINE csrMat_MatVec1 INTERFACE MatVec MODULE SUBROUTINE csrMat_MatVec2(A, JA, x, y, addContribution, & - & scale) + scale) REAL(DFP), INTENT(IN) :: A(:) INTEGER(I4B), INTENT(IN) :: JA(:) REAL(DFP), INTENT(IN) :: x(:) @@ -250,6 +250,22 @@ MODULE SUBROUTINE csrMat_MatVec2(A, JA, x, y, addContribution, & END SUBROUTINE csrMat_MatVec2 END INTERFACE MatVec +!---------------------------------------------------------------------------- +! Matvec@MatVec +!---------------------------------------------------------------------------- + +INTERFACE MatVec + MODULE SUBROUTINE csrMat_MatVec3(obj, x, y, isTranspose, addContribution, & + scale) + TYPE(CSRMatrix_), INTENT(IN) :: obj + TYPE(RealVector_), INTENT(IN) :: x + TYPE(RealVector_), INTENT(INOUT) :: y + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + END SUBROUTINE csrMat_MatVec3 +END INTERFACE MatVec + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 b/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 index 41cf2828c..4c18fd50a 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 @@ -16,34 +16,34 @@ ! MODULE CSRMatrix_Method -USE CSRMatrix_ConstructorMethods -USE CSRMatrix_IOMethods -USE CSRMatrix_SparsityMethods -USE CSRMatrix_SetMethods USE CSRMatrix_AddMethods -USE CSRMatrix_SetRowMethods -USE CSRMatrix_SetColMethods -USE CSRMatrix_SetBlockRowMethods -USE CSRMatrix_SetBlockColMethods +USE CSRMatrix_ConstructorMethods +USE CSRMatrix_DBCMethods +USE CSRMatrix_DiagonalScalingMethods +USE CSRMatrix_GetBlockColMethods +USE CSRMatrix_GetBlockRowMethods +USE CSRMatrix_GetColMethods USE CSRMatrix_GetMethods USE CSRMatrix_GetRowMethods -USE CSRMatrix_GetColMethods USE CSRMatrix_GetSubMatrixMethods -USE CSRMatrix_GetBlockRowMethods -USE CSRMatrix_GetBlockColMethods -USE CSRMatrix_UnaryMethods USE CSRMatrix_ILUMethods +USE CSRMatrix_IOMethods USE CSRMatrix_LUSolveMethods +USE CSRMatrix_LinSolveMethods USE CSRMatrix_MatVecMethods -USE CSRMatrix_SymMatmulMethods -USE CSRMatrix_ReorderingMethods -USE CSRMatrix_DiagonalScalingMethods USE CSRMatrix_MatrixMarketIO -USE CSRMatrix_Superlu -USE CSRMatrix_SpectralMethods +USE CSRMatrix_ReorderingMethods USE CSRMatrix_SchurMethods -USE CSRMatrix_DBCMethods -USE CSRMatrix_LinSolveMethods +USE CSRMatrix_SetBlockColMethods +USE CSRMatrix_SetBlockRowMethods +USE CSRMatrix_SetColMethods +USE CSRMatrix_SetMethods +USE CSRMatrix_SetRowMethods +USE CSRMatrix_SparsityMethods +USE CSRMatrix_SpectralMethods +USE CSRMatrix_Superlu +USE CSRMatrix_SymMatmulMethods +USE CSRMatrix_UnaryMethods USE GlobalData, ONLY: I4B INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_CSR = 0 INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_COO = 1 From ecb47f601cf3bab141649b1b19d8f65fd87092b5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:43:57 +0900 Subject: [PATCH 328/359] update in elemshapedata --- src/modules/ElemshapeData/CMakeLists.txt | 1 + src/modules/ElemshapeData/src/ElemshapeData_Method.F90 | 2 ++ 2 files changed, 3 insertions(+) diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt index d110a44bb..1ce516e03 100644 --- a/src/modules/ElemshapeData/CMakeLists.txt +++ b/src/modules/ElemshapeData/CMakeLists.txt @@ -29,6 +29,7 @@ target_sources( # ${src_path}/ElemshapeData_HCurlMethods.F90 ${src_path}/ElemshapeData_Lagrange.F90 ${src_path}/ElemshapeData_Hierarchical.F90 + ${src_path}/ElemshapeData_Orthogonal.F90 ${src_path}/ElemshapeData_HminHmaxMethods.F90 ${src_path}/ElemshapeData_HRGNParamMethods.F90 ${src_path}/ElemshapeData_HRQIParamMethods.F90 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 index 1d2867420..841d55eda 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -27,6 +27,7 @@ MODULE ElemshapeData_Method USE ElemshapeData_Lagrange USE ElemshapeData_Hierarchical +USE ElemshapeData_Orthogonal USE ElemshapeData_HRGNParamMethods USE ElemshapeData_HRQIParamMethods @@ -39,4 +40,5 @@ MODULE ElemshapeData_Method USE ElemshapeData_SetMethods USE ElemshapeData_StabilizationParamMethods USE ElemshapeData_UnitNormalMethods + END MODULE ElemshapeData_Method From 06e7a14691eac1167d55adc0d4d8028683e3a231 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:44:09 +0900 Subject: [PATCH 329/359] update in lapack --- .../Lapack/src/Sym_LinearSolveMethods.F90 | 63 +++---------------- 1 file changed, 7 insertions(+), 56 deletions(-) diff --git a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 index 923cbdd6b..25c14a7a9 100644 --- a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 +++ b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 @@ -22,7 +22,6 @@ MODULE Sym_LinearSolveMethods IMPLICIT NONE PRIVATE -PUBLIC :: SymSolve PUBLIC :: SymLinSolve !---------------------------------------------------------------------------- @@ -59,9 +58,9 @@ MODULE Sym_LinearSolveMethods ! Therefore, when A is large this routine should be avoided. !@endnote -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & - & UPLO, INFO) + UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector to be found REAL(DFP), INTENT(IN) :: A(:, :) @@ -81,14 +80,6 @@ MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, & !! "U" or "L", Default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_1 -END INTERFACE - -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_1 -END INTERFACE SymSolve - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_1 END INTERFACE SymLinSolve !---------------------------------------------------------------------------- @@ -107,7 +98,7 @@ END SUBROUTINE SymLinSolve_1 ! ! All other things are same as `ge_solve_1`. -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & & UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:, :) @@ -127,16 +118,8 @@ MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, & !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_2 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_2 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_2 -END INTERFACE SymSolve - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -153,7 +136,7 @@ END SUBROUTINE SymLinSolve_2 ! modified on return. Note that B will not be modified as we still ! make a copy of B. -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector solution @@ -169,16 +152,8 @@ MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_3 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_3 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_3 -END INTERFACE SymSolve - !---------------------------------------------------------------------------- ! LinSolve@LinearSolveMethods !---------------------------------------------------------------------------- @@ -187,7 +162,7 @@ END SUBROUTINE SymLinSolve_3 ! date: 7 July 2022 ! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: X(:, :) !! Unknown vector or solution @@ -203,16 +178,8 @@ MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_4 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_4 END INTERFACE SymLinSolve -INTERFACE Solve - MODULE PROCEDURE SymLinSolve_4 -END INTERFACE Solve - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -228,7 +195,7 @@ END SUBROUTINE SymLinSolve_4 ! We do not make any copy of B. The solution is returned in B. This ! means B will be destroyed on return. -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square symmetric matrix, its content will be modified on @@ -243,16 +210,8 @@ MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info) !! "L" or "U", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_5 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_5 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_5 -END INTERFACE SymSolve - !---------------------------------------------------------------------------- ! LinSolve@LinearSolveMethods !---------------------------------------------------------------------------- @@ -261,7 +220,7 @@ END SUBROUTINE SymLinSolve_5 ! date: 28 July 2022 ! summary: Solve Ax=y -INTERFACE +INTERFACE SymLinSolve MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square/rectangle matrix, its content will be modifie @@ -277,14 +236,6 @@ MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO) !! "U" or "L", default is "U" INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO END SUBROUTINE SymLinSolve_6 -END INTERFACE - -INTERFACE SymLinSolve - MODULE PROCEDURE SymLinSolve_6 END INTERFACE SymLinSolve -INTERFACE SymSolve - MODULE PROCEDURE SymLinSolve_6 -END INTERFACE SymSolve - END MODULE Sym_LinearSolveMethods From 963e28659617e5ef1bd289ad3422a2d70ff0e794 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:44:39 +0900 Subject: [PATCH 330/359] update in polynomial class --- .../src/Chebyshev1PolynomialUtility.F90 | 76 ++---- .../src/HexahedronInterpolationUtility.F90 | 224 +++++++++++++---- .../src/JacobiPolynomialUtility.F90 | 72 ++---- .../src/LegendrePolynomialUtility.F90 | 91 ++++--- .../src/LineInterpolationUtility.F90 | 80 ++++++ .../src/LobattoPolynomialUtility.F90 | 232 +++++++++++++++++- .../src/OrthogonalPolynomialUtility.F90 | 160 +++++++++++- .../src/PrismInterpolationUtility.F90 | 9 +- .../src/QuadrangleInterpolationUtility.F90 | 10 +- .../src/TetrahedronInterpolationUtility.F90 | 50 +++- .../src/TriangleInterpolationUtility.F90 | 13 + .../src/UltrasphericalPolynomialUtility.F90 | 66 ++--- 12 files changed, 815 insertions(+), 268 deletions(-) diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index 7f2fd24eb..5e6b35dc3 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -879,11 +879,11 @@ MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, & quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -896,62 +896,30 @@ MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, & END SUBROUTINE Chebyshev1Transform1_ END INTERFACE Chebyshev1Transform_ -!---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Chebyshev1 Transform - -INTERFACE Chebyshev1Transform - MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, quadType) & - RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION Chebyshev1Transform2 -END INTERFACE Chebyshev1Transform - !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 2024-08-19 -! summary: Columnwise Discrete Chebyshev1 Transform - INTERFACE Chebyshev1Transform_ - MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, PP, w, & + quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: PP(0:, 0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! nrow = n+1 - !! ncol = SIZE(coeff, 2) - END SUBROUTINE Chebyshev1Transform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! tsize = n+1 + END SUBROUTINE Chebyshev1Transform4_ END INTERFACE Chebyshev1Transform_ !---------------------------------------------------------------------------- @@ -1037,17 +1005,18 @@ END SUBROUTINE Chebyshev1Transform3_ ! internally. INTERFACE Chebyshev1Transform - MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) + MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, quadType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) + !! size if quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight REAL(DFP) :: ans(0:n) !! modal values or coefficients - END FUNCTION Chebyshev1Transform4 + END FUNCTION Chebyshev1Transform2 END INTERFACE Chebyshev1Transform !---------------------------------------------------------------------------- @@ -1059,11 +1028,12 @@ END FUNCTION Chebyshev1Transform4 ! summary: Discrete Chebyshev1 Transform INTERFACE Chebyshev1Transform_ - MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) + MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) + !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -1071,7 +1041,7 @@ MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) !! modal values or coefficients INTEGER(I4B), INTENT(OUT) :: tsize !! tsize = n+1 - END SUBROUTINE Chebyshev1Transform4_ + END SUBROUTINE Chebyshev1Transform2_ END INTERFACE Chebyshev1Transform_ !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index 4c513bcf1..cc4adabad 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -18,6 +18,7 @@ MODULE HexahedronInterpolationUtility USE GlobalData USE String_Class, ONLY: String + IMPLICIT NONE PRIVATE PUBLIC :: LagrangeDegree_Hexahedron @@ -33,7 +34,10 @@ MODULE HexahedronInterpolationUtility PUBLIC :: EdgeConnectivity_Hexahedron PUBLIC :: FacetConnectivity_Hexahedron PUBLIC :: TensorProdBasis_Hexahedron + PUBLIC :: OrthogonalBasis_Hexahedron +PUBLIC :: OrthogonalBasis_Hexahedron_ + PUBLIC :: VertexBasis_Hexahedron PUBLIC :: xEdgeBasis_Hexahedron PUBLIC :: yEdgeBasis_Hexahedron @@ -44,6 +48,7 @@ MODULE HexahedronInterpolationUtility PUBLIC :: xzFacetBasis_Hexahedron PUBLIC :: FacetBasis_Hexahedron PUBLIC :: CellBasis_Hexahedron + PUBLIC :: HeirarchicalBasis_Hexahedron PUBLIC :: HeirarchicalBasis_Hexahedron_ @@ -60,10 +65,15 @@ MODULE HexahedronInterpolationUtility PUBLIC :: RefElemDomain_Hexahedron PUBLIC :: LagrangeGradientEvalAll_Hexahedron PUBLIC :: LagrangeGradientEvalAll_Hexahedron_ + PUBLIC :: OrthogonalBasisGradient_Hexahedron +PUBLIC :: OrthogonalBasisGradient_Hexahedron_ + PUBLIC :: TensorProdBasisGradient_Hexahedron + PUBLIC :: HeirarchicalBasisGradient_Hexahedron PUBLIC :: HeirarchicalBasisGradient_Hexahedron_ + PUBLIC :: GetTotalDOF_Hexahedron PUBLIC :: GetTotalInDOF_Hexahedron @@ -1228,6 +1238,59 @@ END FUNCTION TensorProdBasis_Hexahedron1 MODULE PROCEDURE TensorProdBasis_Hexahedron1 END INTERFACE OrthogonalBasis_Hexahedron +!---------------------------------------------------------------------------- +! OrthogonalBasis_Hexahedron_ +!---------------------------------------------------------------------------- + +INTERFACE TensorProdBasis_Hexahedron_ + MODULE SUBROUTINE TensorProdBasis_Hexahedron1_(p, q, r, xij, basisType1, & + basisType2, basisType3, ans, nrow, ncol, & + alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, alpha3, beta3, lambda3) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + INTEGER(I4B), INTENT(IN) :: r + !! highest order in x3 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 + !! basis type in x1 direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Tensor basis + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and cols + !! nrow = SIZE(xij, 2) + !! ncol = (p + 1) * (q + 1) * (r + 1) + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! alpha3 needed when basisType3 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! beta3 is needed when basisType3 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! lambda3 is needed when basisType3 is "Ultraspherical" + !! + END SUBROUTINE TensorProdBasis_Hexahedron1_ +END INTERFACE TensorProdBasis_Hexahedron_ + +INTERFACE OrthogonalBasis_Hexahedron_ + MODULE PROCEDURE TensorProdBasis_Hexahedron1_ +END INTERFACE OrthogonalBasis_Hexahedron_ + !---------------------------------------------------------------------------- ! TensorProdBasis_Hexahedron !---------------------------------------------------------------------------- @@ -1243,26 +1306,10 @@ END FUNCTION TensorProdBasis_Hexahedron1 ! outer product of x and y INTERFACE TensorProdBasis_Hexahedron - MODULE FUNCTION TensorProdBasis_Hexahedron2( & - & p, & - & q, & - & r, & - & x, & - & y, & - & z, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3) & - & RESULT(ans) + MODULE FUNCTION TensorProdBasis_Hexahedron2(p, q, r, x, y, z, basisType1, & + basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, alpha3, beta3, lambda3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q @@ -1273,11 +1320,7 @@ MODULE FUNCTION TensorProdBasis_Hexahedron2( & !! points of evaluation in xij format INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 !! orthogonal polynomial family in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 @@ -1293,6 +1336,54 @@ END FUNCTION TensorProdBasis_Hexahedron2 MODULE PROCEDURE TensorProdBasis_Hexahedron2 END INTERFACE OrthogonalBasis_Hexahedron +!---------------------------------------------------------------------------- +! OrthogonalBasis_Hexahedron_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle +! +!# Introduction +! +! This function returns the tensor product expansion of orthogonal +! polynomial on biunit quadrangle. Here xij is obtained by +! outer product of x and y + +INTERFACE TensorProdBasis_Hexahedron_ + MODULE SUBROUTINE TensorProdBasis_Hexahedron2_(p, q, r, x, & + y, z, basisType1, basisType2, basisType3, ans, nrow, ncol, & + alpha1, beta1, lambda1, alpha2, beta2, lambda2, & + alpha3, beta3, lambda3) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + INTEGER(I4B), INTENT(IN) :: r + !! highest order in x3 direction + REAL(DFP), INTENT(IN) :: x(:), y(:), z(:) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 + !! orthogonal polynomial family in x1 direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Tensor basis + !! The number of rows corresponds to the + !! total number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(x) * SIZE(y) * SIZE(z) + !! ncol = (p + 1) * (q + 1) * (r + 1) + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + END SUBROUTINE TensorProdBasis_Hexahedron2_ +END INTERFACE TensorProdBasis_Hexahedron_ + +INTERFACE OrthogonalBasis_Hexahedron_ + MODULE PROCEDURE TensorProdBasis_Hexahedron2_ +END INTERFACE OrthogonalBasis_Hexahedron_ + !---------------------------------------------------------------------------- ! VertexBasis_Hexahedron !---------------------------------------------------------------------------- @@ -2993,24 +3084,9 @@ END SUBROUTINE LagrangeGradientEvalAll_Hexahedron1_ ! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron INTERFACE TensorProdBasisGradient_Hexahedron - MODULE FUNCTION TensorProdBasisGradient_Hexahedron1( & - & p, & - & q, & - & r, & - & xij, & - & basisType1, & - & basisType2, & - & basisType3, & - & alpha1, & - & beta1, & - & lambda1, & - & alpha2, & - & beta2, & - & lambda2, & - & alpha3, & - & beta3, & - & lambda3) & - & RESULT(ans) + MODULE FUNCTION TensorProdBasisGradient_Hexahedron1(p, q, r, xij, & + basisType1, basisType2, basisType3, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q @@ -3021,11 +3097,7 @@ MODULE FUNCTION TensorProdBasisGradient_Hexahedron1( & !! points of evaluation in xij format INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 !! basis type in x1 direction - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 !! alpha1 needed when basisType1 "Jacobi" @@ -3053,6 +3125,62 @@ END FUNCTION TensorProdBasisGradient_Hexahedron1 MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1 END INTERFACE OrthogonalBasisGradient_Hexahedron +!---------------------------------------------------------------------------- +! TensorProdBasisGradient_Hexahedron_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron + +INTERFACE TensorProdBasisGradient_Hexahedron_ + MODULE SUBROUTINE TensorProdBasisGradient_Hexahedron1_(p, q, r, & + xij, basisType1, basisType2, basisType3, & + ans, dim1, dim2, dim3, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, alpha3, beta3, lambda3) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + INTEGER(I4B), INTENT(IN) :: r + !! highest order in x3 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3 + !! basis type in x1 direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of gradient of nth order Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(xij, 2) + !! dim2 = (p + 1) * (q + 1) * (r + 1) + !! dim3 = 3 + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3 + !! alpha3 needed when basisType3 "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta3 + !! beta3 is needed when basisType3 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3 + !! lambda3 is needed when basisType3 is "Ultraspherical" + END SUBROUTINE TensorProdBasisGradient_Hexahedron1_ +END INTERFACE TensorProdBasisGradient_Hexahedron_ + +INTERFACE OrthogonalBasisGradient_Hexahedron_ + MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1_ +END INTERFACE OrthogonalBasisGradient_Hexahedron_ + !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Hexahedron !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index 25920c6d0..23deb2412 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -992,12 +992,15 @@ MODULE PURE SUBROUTINE JacobiTransform1_(n, alpha, beta, coeff, x, w, & !! alpha of Jacobi polynomial > -1.0_DFP REAL(DFP), INTENT(IN) :: beta !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + !! size is quadrature points + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -1012,66 +1015,33 @@ END SUBROUTINE JacobiTransform1_ ! JacobiTransform !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Jacobi Transform - -INTERFACE JacobiTransform - MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & - quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: beta - !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION JacobiTransform2 -END INTERFACE JacobiTransform - -!---------------------------------------------------------------------------- -! JacobiTransform_ -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-08-19 -! summary: Jacobi transform - INTERFACE JacobiTransform_ - MODULE PURE SUBROUTINE JacobiTransform2_(n, alpha, beta, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE JacobiTransform4_(n, alpha, beta, coeff, PP, w, & + quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial + !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: alpha !! alpha of Jacobi polynomial > -1.0_DFP REAL(DFP), INTENT(IN) :: beta !! beta of Jacobi polynomial > -1.0_DFP - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + !! number of rows in number of quadrature points + !! number of columns is n+1 + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size is quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! nrow = n+1 - !! ncol = SIZE(coeff, 2) - END SUBROUTINE JacobiTransform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! n+1 + END SUBROUTINE JacobiTransform4_ END INTERFACE JacobiTransform_ !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index 81b7d96a0..6312061c9 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -625,6 +625,10 @@ END FUNCTION LegendreEvalAll2 ! LegendreEvalAll_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-19 +! summary: Evaluate Legendre polynomials from 0 to n at several points + INTERFACE LegendreEvalAll_ MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: n @@ -635,6 +639,8 @@ MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol) REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(SIZE(x), n + 1) !! shape (M,N+1) + !! ans(:, jj) denotes value of Pjj at x + !! ans(ii, :) denotes value of all polynomials at x(ii) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE LegendreEvalAll2_ END INTERFACE LegendreEvalAll_ @@ -951,13 +957,17 @@ MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomials !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! value of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) + !! size if number of quadrature points + !! number of quadrature points should be at least n+1 + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points !! These quadrature points are used in LegendreEvalAll method - REAL(DFP), INTENT(IN) :: w(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size is number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight @@ -979,12 +989,12 @@ MODULE PURE SUBROUTINE LegendreTransform1_(n, coeff, x, w, quadType, ans, & INTEGER(I4B), INTENT(IN) :: n !! Order of Legendre polynomials !! n+1 coefficient (modal values) - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! Value of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: x(0:) !! Quadrature points !! These quadrature points are used in LegendreEvalAll method - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! Weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -1001,56 +1011,37 @@ END SUBROUTINE LegendreTransform1_ END INTERFACE LegendreTransform_ !---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Legendre Transform - -INTERFACE LegendreTransform - MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & - quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! values of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION LegendreTransform2 -END INTERFACE LegendreTransform - -!---------------------------------------------------------------------------- -! LegendreTransform@Methods +! LegendreTransform !---------------------------------------------------------------------------- INTERFACE LegendreTransform_ - MODULE PURE SUBROUTINE LegendreTransform2_(n, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE LegendreTransform4_(n, coeff, PP, w, quadType, ans, & + tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! values of function at quadrature points - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights + !! Order of Legendre polynomials + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: coeff(0:) + !! Value of function at quadrature points + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) + !! Quadrature points + !! These quadrature points are used in LegendreEvalAll method + !! number of rows in PP is number of quadrature points + !! number of columns in PP is n+1 + REAL(DFP), INTENT(IN) :: w(0:) + !! Weights + !! soze of w is number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! modal values or coefficients for each column of val - ! REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns writen in ans - END SUBROUTINE LegendreTransform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients of Legendre polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on + ! REAL(DFP) :: ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE LegendreTransform4_ END INTERFACE LegendreTransform_ !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 9a5040523..f7fec78cd 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -60,7 +60,9 @@ MODULE LineInterpolationUtility PUBLIC :: HeirarchicalBasisGradient_Line_ PUBLIC :: OrthogonalBasis_Line +PUBLIC :: OrthogonalBasis_Line_ PUBLIC :: OrthogonalBasisGradient_Line +PUBLIC :: OrthogonalBasisGradient_Line_ !---------------------------------------------------------------------------- ! RefElemDomain_Line @@ -1222,6 +1224,40 @@ MODULE FUNCTION OrthogonalBasis_Line1(order, xij, refLine, basisType, & END FUNCTION OrthogonalBasis_Line1 END INTERFACE OrthogonalBasis_Line +!---------------------------------------------------------------------------- +! OrthogonalBasis_Line_ +!---------------------------------------------------------------------------- + +INTERFACE OrthogonalBasis_Line_ + MODULE SUBROUTINE OrthogonalBasis_Line1_(order, xij, refLine, basisType, & + ans, nrow, ncol, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + !! Number of rows in xij is 1 + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT ! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! Jacobi ! Ultraspherical ! Legendre ! Chebyshev ! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Value of n+1 polynomials at point x + ! ans(SIZE(xij, 2), order + 1) + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = size(xij, 2) + !! ncol = order+1 + END SUBROUTINE OrthogonalBasis_Line1_ +END INTERFACE OrthogonalBasis_Line_ + !---------------------------------------------------------------------------- ! BasisEvalAll_Line !---------------------------------------------------------------------------- @@ -1261,6 +1297,50 @@ MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, & END FUNCTION OrthogonalBasisGradient_Line1 END INTERFACE OrthogonalBasisGradient_Line +!---------------------------------------------------------------------------- +! OrthgonalBasisGradient_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-09-10 +! summary: gradient of orthogonal basis without allocation + +INTERFACE OrthogonalBasisGradient_Line_ + MODULE SUBROUTINE OrthogonalBasisGradient_Line1_(order, xij, refLine, & + basisType, ans, dim1, dim2, dim3, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomials + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + !! Number of rows in xij is 1 + CHARACTER(*), INTENT(IN) :: refLine + !! UNIT + !! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! Jacobi + !! Ultraspherical + !! Legendre + !! Chebyshev + !! Lobatto + !! UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! ans(SIZE(xij, 2), order + 1, 1) + !! Value of n+1 polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = size(xij,2) + !! dim2 = order+1 + !! dim3 = 1 + END SUBROUTINE OrthogonalBasisGradient_Line1_ +END INTERFACE OrthogonalBasisGradient_Line_ + !---------------------------------------------------------------------------- ! HeirarchicalBasis_Line !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index ac6b54e8d..a851dffd4 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -22,9 +22,14 @@ !{!pages/LobattoPolynomialUtility.md!} MODULE LobattoPolynomialUtility -USE GlobalData +USE GlobalData, ONLY: I4B, DFP, LGT + +USE BaseType, ONLY: iface_1DFunction + IMPLICIT NONE + PRIVATE + PUBLIC :: LobattoLeadingCoeff PUBLIC :: LobattoZeros PUBLIC :: LobattoEval @@ -44,6 +49,110 @@ MODULE LobattoPolynomialUtility PUBLIC :: LobattoMassMatrix PUBLIC :: LobattoStiffnessMatrix +PUBLIC :: LobattoTransform_ + +PUBLIC :: Lobatto0, Lobatto1, Lobatto2, Lobatto3, Lobatto4, Lobatto5 + +PUBLIC :: Lobatto6, Lobatto7, Lobatto8, Lobatto9, Lobatto10 + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +INTERFACE LobattoTransform_ + MODULE SUBROUTINE LobattoTransform1_(n, coeff, PP, w, quadType, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! Order of Legendre polynomials + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: coeff(0:) + !! Value of function at quadrature points + !! size of coeff is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) + !! Value of lobatto polynomials + !! PP(:, jj) value of Pjj at quadrature points + !! PP(ii, :) value of all lobatto polynomials at point ii + !! number of rows in PP is number of quadrature points + !! number of columns in PP is n+1 + REAL(DFP), INTENT(IN) :: w(0:) + !! Weights for each quadrature points + !! size of w is number of quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type + !! Gauss, GaussLobatto, GaussRadau, GaussRadauLeft GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients of Legendre polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on + ! REAL(DFP) :: ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE LobattoTransform1_ +END INTERFACE LobattoTransform_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-20 +! summary: LobattoTransform + +INTERFACE LobattoTransform_ + MODULE SUBROUTINE LobattoTransform2_(n, coeff, x, w, quadType, ans, & + tsize) + INTEGER(I4B), INTENT(IN) :: n + !! Order of Lobatto polynomials + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: coeff(0:) + !! Value of function at quadrature points + REAL(DFP), INTENT(IN) :: x(0:) + !! Quadrature points + !! These quadrature points are used in LobattoEvalAll method + REAL(DFP), INTENT(IN) :: w(0:) + !! Weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients of Lobatto polynomial + !! ans(0) is coefficient of P0 + !! ans(1) is coefficient of P1 + !! and so on + ! REAL(DFP) :: ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! total size of ans + END SUBROUTINE LobattoTransform2_ +END INTERFACE LobattoTransform_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-20 +! summary: LobattoTransform of function + +INTERFACE LobattoTransform_ + MODULE SUBROUTINE LobattoTransform3_(n, f, quadType, x1, x2, ans, tsize) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type + !! Gauss, GaussLobatto, GaussRadau, GaussRadauLeft GaussRadauRight + !! We will use Legendre quadrature points + REAL(DFP), INTENT(IN) :: x1, x2 + !! domain of function f + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! modal values or coefficients + !! ans(0:n) + INTEGER(I4B), INTENT(OUT) :: tsize + !! n+1 + END SUBROUTINE LobattoTransform3_ +END INTERFACE LobattoTransform_ + !---------------------------------------------------------------------------- ! LobattoLeadingCoeff !---------------------------------------------------------------------------- @@ -528,6 +637,127 @@ MODULE PURE FUNCTION LobattoStiffnessMatrix(n) RESULT(ans) END FUNCTION LobattoStiffnessMatrix END INTERFACE +!---------------------------------------------------------------------------- +! Lobatto0 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto0(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto0 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto1 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto1(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto1 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto2 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto2(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto2 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto3 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto3(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto3 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto4 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto4(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto4 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto5 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto5(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto5 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto6 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto6(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto6 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto7 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto7(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto7 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto8 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto8(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto8 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto9 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto9(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto9 +END INTERFACE + +!---------------------------------------------------------------------------- +! Lobatto10 +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Lobatto10(x) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Lobatto10 +END INTERFACE + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 index 723784bec..bec4626ac 100644 --- a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 @@ -16,7 +16,7 @@ ! MODULE OrthogonalPolynomialUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT IMPLICIT NONE @@ -32,6 +32,12 @@ MODULE OrthogonalPolynomialUtility PUBLIC :: GradientEvalAllOrthopol PUBLIC :: GradientEvalAllOrthopol_ +PUBLIC :: OrthogonalEvalAll_ +PUBLIC :: OrthogonalEvalAll + +PUBLIC :: OrthogonalGradientEvalAll_ +PUBLIC :: OrthogonalGradientEvalAll + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -257,4 +263,156 @@ MODULE PURE SUBROUTINE EvalAllOrthopol_(n, x, orthopol, alpha, beta, & END SUBROUTINE EvalAllOrthopol_ END INTERFACE +!---------------------------------------------------------------------------- +! OrthogonalEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-09-10 +! summary: Evaluate orthogonal polynomials + +INTERFACE + MODULE FUNCTION OrthogonalEvalAll(order, elemType, xij, domainName, & + basisType, alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! basis type + !! used for line, quadrangle, and hexahedron element + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda is needed when orthopol1 is "Ultraspherical" + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Value of n+1 Orthogonal polynomials at point x + END FUNCTION OrthogonalEvalAll +END INTERFACE + +!---------------------------------------------------------------------------- +! OrthogonalGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-09-10 +! summary: Evaluate orthogonal polynomials + +INTERFACE + MODULE SUBROUTINE OrthogonalEvalAll_(order, elemType, xij, domainName, & + basisType, ans, nrow, ncol, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! basis type + !! used for line, quadrangle, and hexahedron element + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda is needed when orthopol1 is "Ultraspherical" + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Value of n+1 Orthogonal polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and cols in ans + END SUBROUTINE OrthogonalEvalAll_ +END INTERFACE + +!---------------------------------------------------------------------------- +! OrthogonalGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-09-10 +! summary: Evaluate orthogonal polynomials + +INTERFACE + MODULE FUNCTION OrthogonalGradientEvalAll(order, elemType, xij, domainName, & + basisType, alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! basis type + !! used for line, quadrangle, and hexahedron element + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda is needed when orthopol1 is "Ultraspherical" + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + !! Value of n+1 Orthogonal polynomials at point x + END FUNCTION OrthogonalGradientEvalAll +END INTERFACE + +!---------------------------------------------------------------------------- +! OrthogonalGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-09-10 +! summary: Evaluate orthogonal polynomials + +INTERFACE + MODULE SUBROUTINE OrthogonalGradientEvalAll_(order, elemType, xij, & + domainName, basisType, ans, dim1, dim2, dim3, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + !! x(3, :) is z coord + CHARACTER(*), INTENT(IN) :: domainName + !! domain of reference element + !! UNIT ! BIUNIT + INTEGER(I4B), INTENT(IN) :: basisType + !! basis type + !! used for line, quadrangle, and hexahedron element + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda is needed when orthopol1 is "Ultraspherical" + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of n+1 Orthogonal polynomials at point x + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! number of rows and cols in ans + END SUBROUTINE OrthogonalGradientEvalAll_ +END INTERFACE + END MODULE OrthogonalPolynomialUtility diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index bb024a8d5..adebc985b 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -18,8 +18,11 @@ MODULE PrismInterpolationUtility USE GlobalData USE String_Class, ONLY: String + IMPLICIT NONE + PRIVATE + PUBLIC :: LagrangeDegree_Prism PUBLIC :: LagrangeDOF_Prism PUBLIC :: LagrangeInDOF_Prism @@ -72,7 +75,7 @@ END FUNCTION GetTotalDOF_Prism END INTERFACE !---------------------------------------------------------------------------- -! LagrangeInDOF_Prism +! LagrangeInDOF_Prism !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -651,10 +654,6 @@ MODULE FUNCTION TensorQuadraturePoint_Prism2( & END FUNCTION TensorQuadraturePoint_Prism2 END INTERFACE TensorQuadraturePoint_Prism -INTERFACE OrthogonalBasisGradient_Prism - MODULE PROCEDURE TensorQuadraturePoint_Prism2 -END INTERFACE OrthogonalBasisGradient_Prism - !---------------------------------------------------------------------------- ! LagrangeEvalAll_Prism !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 6cfa1d059..05a408880 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -46,6 +46,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: TensorProdBasis_Quadrangle PUBLIC :: OrthogonalBasis_Quadrangle +PUBLIC :: OrthogonalBasis_Quadrangle_ PUBLIC :: VertexBasis_Quadrangle @@ -80,6 +81,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: TensorProdBasisGradient_Quadrangle PUBLIC :: OrthogonalBasisGradient_Quadrangle +PUBLIC :: OrthogonalBasisGradient_Quadrangle_ PUBLIC :: GetTotalDOF_Quadrangle PUBLIC :: GetTotalInDOF_Quadrangle @@ -1482,6 +1484,10 @@ MODULE SUBROUTINE TensorProdBasis_Quadrangle2_(p, q, x, y, ans, nrow, & END SUBROUTINE TensorProdBasis_Quadrangle2_ END INTERFACE TensorProdBasis_Quadrangle_ +INTERFACE OrthogonalBasis_Quadrangle_ + MODULE PROCEDURE TensorProdBasis_Quadrangle2_ +END INTERFACE OrthogonalBasis_Quadrangle_ + !---------------------------------------------------------------------------- ! VertexBasis_Quadrangle !---------------------------------------------------------------------------- @@ -2631,10 +2637,6 @@ MODULE SUBROUTINE TensorProdBasisGradient_Quadrangle1_(p, q, xij, ans, & END SUBROUTINE TensorProdBasisGradient_Quadrangle1_ END INTERFACE TensorProdBasisGradient_Quadrangle_ -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - INTERFACE OrthogonalBasisGradient_Quadrangle_ MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_ END INTERFACE OrthogonalBasisGradient_Quadrangle_ diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index 2a1755fe4..c30160f2b 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -31,7 +31,10 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: LagrangeCoeff_Tetrahedron_ PUBLIC :: InterpolationPoint_Tetrahedron PUBLIC :: InterpolationPoint_Tetrahedron_ + PUBLIC :: OrthogonalBasis_Tetrahedron +PUBLIC :: OrthogonalBasis_Tetrahedron_ + PUBLIC :: BarycentricVertexBasis_Tetrahedron PUBLIC :: BarycentricEdgeBasis_Tetrahedron PUBLIC :: BarycentricFacetBasis_Tetrahedron @@ -67,6 +70,8 @@ MODULE TetrahedronInterpolationUtility PUBLIC :: HeirarchicalBasisGradient_Tetrahedron_ PUBLIC :: OrthogonalBasisGradient_Tetrahedron +PUBLIC :: OrthogonalBasisGradient_Tetrahedron_ + PUBLIC :: GetTotalDOF_Tetrahedron PUBLIC :: GetTotalInDOF_Tetrahedron @@ -903,9 +908,8 @@ END SUBROUTINE OrthogonalBasis_Tetrahedron1_ ! summary: Orthogongal basis on Tetrahedron INTERFACE OrthogonalBasis_Tetrahedron - MODULE FUNCTION OrthogonalBasis_Tetrahedron2( & - & order, & - & x, y, z, refTetrahedron) RESULT(ans) + MODULE FUNCTION OrthogonalBasis_Tetrahedron2(order, x, y, z, & + refTetrahedron) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial space REAL(DFP), INTENT(IN) :: x(:) @@ -2685,10 +2689,8 @@ END SUBROUTINE LagrangeGradientEvalAll_Tetrahedron1_ ! summary: Orthogongal basis on Tetrahedron INTERFACE OrthogonalBasisGradient_Tetrahedron - MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1( & - & order, & - & xij, & - & refTetrahedron) RESULT(ans) + MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1(order, xij, & + refTetrahedron) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial space REAL(DFP), INTENT(IN) :: xij(:, :) @@ -2699,15 +2701,43 @@ MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1( & CHARACTER(*), INTENT(IN) :: refTetrahedron !! "UNIT" !! "BIUNIT" - REAL(DFP) :: ans( & - & SIZE(xij, 2), & - & (order + 1) * (order + 2) * (order + 3) / 6, 3) + REAL(DFP) :: ans(SIZE(xij, 2), & + (order + 1) * (order + 2) * (order + 3) / 6, 3) !! shape functions !! ans(:, j), jth shape functions at all points !! ans(j, :), all shape functions at jth point END FUNCTION OrthogonalBasisGradient_Tetrahedron1 END INTERFACE OrthogonalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Tetrahedron_ +!---------------------------------------------------------------------------- + +INTERFACE OrthogonalBasisGradient_Tetrahedron_ + MODULE SUBROUTINE OrthogonalBasisGradient_Tetrahedron1_(order, xij, & + refTetrahedron, ans, dim1, dim2, dim3) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! Points of evaluation in reference Tetrahedron. + !! The shape functions will be evaluated + !! at these points. + !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points + CHARACTER(*), INTENT(IN) :: refTetrahedron + !! "UNIT" + !! "BIUNIT" + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! gradient of shape functions + !! first dimension = evaluation point + !! second dimension = shape function number + !! third dimension = spatial dimension + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = size(xij, 2) + !! dim2 = (order + 1) * (order + 2) * (order + 3) / 6 + !! dim3 = 3 + END SUBROUTINE OrthogonalBasisGradient_Tetrahedron1_ +END INTERFACE OrthogonalBasisGradient_Tetrahedron_ + !---------------------------------------------------------------------------- ! HeirarchicalBasisGradient_Tetrahedron !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 99678de66..f52b2de36 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -34,8 +34,13 @@ MODULE TriangleInterpolationUtility PUBLIC :: LagrangeCoeff_Triangle_ PUBLIC :: Dubiner_Triangle +PUBLIC :: Dubiner_Triangle_ + PUBLIC :: OrthogonalBasis_Triangle +PUBLIC :: OrthogonalBasis_Triangle_ + PUBLIC :: OrthogonalBasisGradient_Triangle +PUBLIC :: OrthogonalBasisGradient_Triangle_ PUBLIC :: VertexBasis_Triangle PUBLIC :: EdgeBasis_Triangle @@ -865,6 +870,10 @@ MODULE PURE SUBROUTINE Dubiner_Triangle1_(order, xij, refTriangle, ans, & END SUBROUTINE Dubiner_Triangle1_ END INTERFACE Dubiner_Triangle_ +INTERFACE OrthogonalBasis_Triangle_ + MODULE PROCEDURE Dubiner_Triangle1_ +END INTERFACE OrthogonalBasis_Triangle_ + !---------------------------------------------------------------------------- ! DubinerPolynomial !---------------------------------------------------------------------------- @@ -938,6 +947,10 @@ MODULE PURE SUBROUTINE Dubiner_Triangle2_(order, x, y, refTriangle, ans, & END SUBROUTINE Dubiner_Triangle2_ END INTERFACE Dubiner_Triangle_ +INTERFACE OrthogonalBasis_Triangle_ + MODULE PROCEDURE Dubiner_Triangle2_ +END INTERFACE OrthogonalBasis_Triangle_ + !---------------------------------------------------------------------------- ! VertexBasis_Triangle !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 index 5e22415c9..410ea9655 100644 --- a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 @@ -987,11 +987,11 @@ MODULE PURE SUBROUTINE UltrasphericalTransform1_(n, lambda, coeff, x, w, & !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: lambda !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:n) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + REAL(DFP), INTENT(IN) :: x(0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + REAL(DFP), INTENT(IN) :: w(0:) !! weights INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft @@ -1009,57 +1009,33 @@ END SUBROUTINE UltrasphericalTransform1_ ! UltrasphericalTransform !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 13 Oct 2022 -! summary: Columnwise Discrete Ultraspherical Transform - -INTERFACE UltrasphericalTransform - MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & - & quadType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial - REAL(DFP), INTENT(IN) :: lambda - !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) - !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) - !! weights - INTEGER(I4B), INTENT(IN) :: quadType - !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft - !! GaussRadauRight - REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - END FUNCTION UltrasphericalTransform2 -END INTERFACE UltrasphericalTransform - -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- - INTERFACE UltrasphericalTransform_ - MODULE PURE SUBROUTINE UltrasphericalTransform2_(n, lambda, coeff, x, w, & - quadType, ans, nrow, ncol) + MODULE PURE SUBROUTINE UltrasphericalTransform4_(n, lambda, coeff, PP, w, & + quadType, ans, tsize) INTEGER(I4B), INTENT(IN) :: n - !! order of polynomial + !! order of jacobi polynomial REAL(DFP), INTENT(IN) :: lambda !! $\lambda > -0.5, \lambda \ne 0.0$ - REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + REAL(DFP), INTENT(IN) :: coeff(0:) !! nodal value (at quad points) - REAL(DFP), INTENT(IN) :: x(0:n) + !! size is number of quadrature points + REAL(DFP), INTENT(IN) :: PP(0:, 0:) !! quadrature points - REAL(DFP), INTENT(IN) :: w(0:n) + !! number of rows is number of quadrature points + !! number of columns is n+1 + REAL(DFP), INTENT(IN) :: w(0:) !! weights + !! size of number of quadrature points INTEGER(I4B), INTENT(IN) :: quadType !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft !! GaussRadauRight - REAL(DFP), INTENT(INOUT) :: ans(0:, 1:) - !! ans(0:n, 1:SIZE(coeff, 2)) - !! modal values or coefficients for each column of val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! n+1, size(coeff, 2) - END SUBROUTINE UltrasphericalTransform2_ + REAL(DFP), INTENT(INOUT) :: ans(0:) + !! ans(0:n) + !! modal values or coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of ans + !! n + 1 + END SUBROUTINE UltrasphericalTransform4_ END INTERFACE UltrasphericalTransform_ !---------------------------------------------------------------------------- @@ -1143,7 +1119,7 @@ END SUBROUTINE UltrasphericalTransform3_ INTERFACE MODULE PURE FUNCTION UltrasphericalInvTransform1(n, lambda, coeff, x) & - & RESULT(ans) + RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: lambda From 6440640a6e38f4db6448151b00e4f95cd198ea6c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:44:51 +0900 Subject: [PATCH 331/359] update in csrmatrix --- .../src/CSRMatrix_DBCMethods@Methods.F90 | 9 ++- .../CSRMatrix_GetSubMatrixMethods@Methods.F90 | 23 ++++--- .../src/CSRMatrix_MatVecMethods@Methods.F90 | 62 ++++++++++++------- 3 files changed, 59 insertions(+), 35 deletions(-) diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 index 83e6b7807..39bb81b70 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 @@ -20,7 +20,8 @@ ! summary: This submodule contains the methods for sparse matrix SUBMODULE(CSRMatrix_DBCMethods) Methods -USE BaseMethod +USE CSRMatrix_Method, ONLY: GetDiagonal, SIZE + IMPLICIT NONE CONTAINS @@ -29,7 +30,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE csrMat_ApplyDBC -INTEGER(I4B) :: i, ii, nrow +INTEGER(I4B) :: i, ii, nrow, tdbcptrs LOGICAL(LGT), ALLOCATABLE :: mask(:) REAL(DFP), ALLOCATABLE :: diag_entries(:) @@ -42,7 +43,9 @@ ! make row zeros - DO CONCURRENT(i=1:SIZE(dbcPtrs)) + tdbcptrs = SIZE(dbcPtrs) + + DO CONCURRENT(i=1:tdbcptrs) ii = dbcPtrs(i) A(IA(ii):IA(ii + 1) - 1) = 0.0_DFP END DO diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 index 57773f75f..0abd51aae 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 @@ -25,10 +25,10 @@ MODULE PROCEDURE obj_GetSubMatrix1 LOGICAL(LGT), ALLOCATABLE :: selectCol(:) -INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), & -& icol, jj +INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), & + icol, jj REAL(DFP) :: aval -TYPE(String) :: astr +CHARACTER(:), ALLOCATABLE :: astr nnz = GetNNZ(obj=obj) nrow = SIZE(obj, 1) @@ -41,16 +41,19 @@ nn = SIZE(cols) DO ii = 1, nn jj = cols(ii) + +#ifdef DEBUG_VER IF (jj .GT. ncol) THEN - astr = "Error cols( "//tostring(ii)//") is greater than "// & - & "ncol = "//tostring(ncol) - CALL ErrorMSG( & - & astr%chars(), & - & "CSRMatrix_GetSubMatrixMethods@Methods.F90", & - & "obj_GetSubMatrix1()", & - & __LINE__, stderr) + astr = "Error cols( "//tostring(ii)//") is greater than "// & + "ncol = "//tostring(ncol) + CALL ErrorMSG(msg=astr, & + file="CSRMatrix_GetSubMatrixMethods@Methods.F90", & + routine="obj_GetSubMatrix1()", & + line=__LINE__, unitno=stderr) STOP END IF +#endif + selectCol(jj) = .TRUE. END DO diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 index ae4631d4d..5e08cd97f 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 @@ -20,7 +20,15 @@ ! summary: This submodule contains the methods for sparse matrix SUBMODULE(CSRMatrix_MatVecMethods) Methods -USE BaseMethod +USE RealVector_Method, ONLY: RealVector_Size => Size +USE InputUtility, ONLY: Input +USE F95_BLAS, ONLY: AXPY, SCAL +USE Display_Method, ONLY: ToString +USE GlobalData, ONLY: stderr +USE ErrorHandling, ONLY: Errormsg +USE CSRMatrix_Method, ONLY: IsSquare, IsRectangle, & + CSRMatrix_Size => Size + IMPLICIT NONE CONTAINS @@ -139,8 +147,8 @@ REAL(DFP) :: scale0 INTEGER(I4B) :: tsize -add0 = input(default=.FALSE., option=addContribution) -scale0 = input(default=1.0_DFP, option=scale) +add0 = Input(default=.FALSE., option=addContribution) +scale0 = Input(default=1.0_DFP, option=scale) tsize = SIZE(y) IF (add0) THEN @@ -149,8 +157,8 @@ RETURN END IF -CALL CSRMatrixAMUX(n=tsize, x=x, y=y, a=obj%A, & - & ja=obj%csr%JA, ia=obj%csr%IA, s=scale0) +CALL CSRMatrixAMUX(n=tsize, x=x, y=y, a=obj%A, & + ja=obj%csr%JA, ia=obj%csr%IA, s=scale0) END PROCEDURE csrMat_AMatvec1 @@ -164,8 +172,8 @@ REAL(DFP) :: scale0 INTEGER(I4B) :: tsize -add0 = input(default=.FALSE., option=addContribution) -scale0 = input(default=1.0_DFP, option=scale) +add0 = Input(default=.FALSE., option=addContribution) +scale0 = Input(default=1.0_DFP, option=scale) tsize = SIZE(y) IF (add0) THEN @@ -190,14 +198,14 @@ LOGICAL(LGT) :: squareCase, problem, rectCase add0 = INPUT(default=.FALSE., option=addContribution) -scale0 = input(default=1.0_DFP, option=scale) +scale0 = Input(default=1.0_DFP, option=scale) ty = SIZE(y) tx = SIZE(x) -squareCase = isSquare(obj) -rectCase = isRectangle(obj) +squareCase = IsSquare(obj) +rectCase = IsRectangle(obj) -ncol = SIZE(obj, 2) !ncol -nrow = SIZE(obj, 1) !nrow +ncol = CSRMatrix_Size(obj, 2) !ncol +nrow = CSRMatrix_Size(obj, 1) !nrow problem = tx .NE. nrow .OR. ty .NE. ncol @@ -208,14 +216,13 @@ END IF IF (add0 .AND. rectCase .AND. problem) THEN - CALL Errormsg( & - & msg="Mismatch in shapes... nrow = "//tostring(nrow)// & - & " ncol = "//tostring(ncol)//" size(x) = "//tostring(tx)// & - & " size(y) = "//tostring(ty), & - & file=__FILE__, & - & routine="csrMat_AtMatvec()", & - & line=__LINE__, & - & unitno=stderr) + CALL Errormsg(msg="Mismatch in shapes... nrow = "//ToString(nrow)// & + " ncol = "//ToString(ncol)//" size(x) = "//ToString(tx)// & + " size(y) = "//ToString(ty), & + file=__FILE__, & + routine="csrMat_AtMatvec()", & + line=__LINE__, & + unitno=stderr) RETURN END IF @@ -241,7 +248,7 @@ MODULE PROCEDURE csrMat_MatVec1 LOGICAL(LGT) :: trans -trans = INPUT(option=isTranspose, default=.FALSE.) +trans = Input(option=isTranspose, default=.FALSE.) IF (trans) THEN CALL AtMatvec(obj=obj, x=x, y=y, addContribution=addContribution, & @@ -259,7 +266,18 @@ MODULE PROCEDURE csrMat_MatVec2 CALL AMatvec(A=A, JA=JA, x=x, y=y, addContribution=addContribution, & - & scale=scale) + scale=scale) END PROCEDURE csrMat_MatVec2 +!---------------------------------------------------------------------------- +! MatVec +!---------------------------------------------------------------------------- + +MODULE PROCEDURE csrMat_MatVec3 +INTEGER(I4B) :: n +n = RealVector_Size(x) +CALL csrMat_MatVec1(obj=obj, x=x%val(1:n), y=y%val(1:n), & + isTranspose=isTranspose, addContribution=addContribution, scale=scale) +END PROCEDURE csrMat_MatVec3 + END SUBMODULE Methods From 1075d8b80b0e74c0af876972877c888666814686 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:45:00 +0900 Subject: [PATCH 332/359] update in elemshapedata --- src/submodules/ElemshapeData/CMakeLists.txt | 12 +- ...emshapeData_ConstructorMethods@Methods.F90 | 1 + .../src/Hierarchical/CMakeLists.txt | 21 --- .../ElemshapeData_Hierarchical@Methods.F90 | 121 ------------- .../ElemshapeData/src/Lagrange/CMakeLists.txt | 20 --- .../src/ElemshapeData_Lagrange@Methods.F90 | 167 ------------------ 6 files changed, 5 insertions(+), 337 deletions(-) delete mode 100644 src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt delete mode 100644 src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 delete mode 100644 src/submodules/ElemshapeData/src/Lagrange/CMakeLists.txt delete mode 100644 src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt index 7d9338761..bc0b5a57d 100644 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -34,11 +34,7 @@ target_sources( ${src_path}/ElemshapeData_StabilizationParamMethods@SUGN3.F90 ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90 ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 - ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90) - -# include(${src_path}/H1/CMakeLists.txt) -# include(${src_path}/HDiv/CMakeLists.txt) -# include(${src_path}/HCurl/CMakeLists.txt) -# include(${src_path}/DG/CMakeLists.txt) -include(${src_path}/Lagrange/CMakeLists.txt) -include(${src_path}/Hierarchical/CMakeLists.txt) + ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90 + ${src_path}/ElemshapeData_Lagrange@Methods.F90 + ${src_path}/ElemshapeData_Hierarchical@Methods.F90 + ${src_path}/ElemshapeData_Orthogonal@Methods.F90) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 index 3a56bd4af..9c8f20e39 100755 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 @@ -45,6 +45,7 @@ CALL Reallocate(obj%thickness, nips) obj%thickness = 1.0_DFP CALL Reallocate(obj%coord, nsd, nips) +CALL Reallocate(obj%ws, nips) obj%nsd = nsd obj%xidim = xidim obj%nips = nips diff --git a/src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt b/src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt deleted file mode 100644 index 79a33828b..000000000 --- a/src/submodules/ElemshapeData/src/Hierarchical/CMakeLists.txt +++ /dev/null @@ -1,21 +0,0 @@ -# This program is a part of EASIFEM library Expandable And Scalable -# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas -# Sharma, Ph.D., vickysharma0812@gmail.com -# -# This program is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along with -# this program. If not, see -# - -set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources(${PROJECT_NAME} - PRIVATE ${src_path}/ElemshapeData_Hierarchical@Methods.F90) diff --git a/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 deleted file mode 100644 index 4e7c7ad5e..000000000 --- a/src/submodules/ElemshapeData/src/Hierarchical/src/ElemshapeData_Hierarchical@Methods.F90 +++ /dev/null @@ -1,121 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_Hierarchical) Methods -USE InputUtility, ONLY: Input - -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate - -USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE - -USE HierarchicalPolynomialUtility, ONLY: HierarchicalDOF, & - HierarchicalEvalAll_, & - HierarchicalGradientEvalAll_ - -USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & - QuadraturePoint_Size => Size - -USE BaseType, ONLY: TypeQuadratureOpt, & - TypePolynomialOpt - -USE SwapUtility, ONLY: SWAP_ - -USE Display_Method, ONLY: Display - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! ElemshapeData_InitiateHierarchical -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HierarchicalElemShapeData1 -REAL(DFP), ALLOCATABLE :: temp(:, :, :) -INTEGER(I4B) :: ipType0, basisType0, nips, nns, ii, jj, kk - -! CALL DEALLOCATE (obj) - -nips = SIZE(quad%points, 2) -! pt = quad%points(1:quad%txi, 1:nips) -! wt = quad%points(quad%txi + 1, 1:nips) - -nns = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, & - faceOrder=faceOrder, edgeOrder=edgeOrder) - -CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) - -obj%ws = quad%points(1 + xidim, 1:nips) - -ALLOCATE (temp(nips, nns, 3)) - -CALL HierarchicalEvalAll_(elemType=elemType, & - xij=quad%points(1:xidim, 1:nips), & - ans=temp(:, :, 1), nrow=ii, ncol=jj, & - domainName=domainName, & - cellOrder=cellOrder, & - faceOrder=faceOrder, & - edgeOrder=edgeOrder, & - cellOrient=cellOrient, & - faceOrient=faceOrient, & - edgeOrient=edgeOrient) - -DO CONCURRENT(ii=1:nns, jj=1:nips) - obj%N(ii, jj) = temp(jj, ii, 1) -END DO - -CALL HierarchicalGradientEvalAll_(elemType=elemType, & - xij=quad%points(1:xidim, 1:nips), ans=temp, & - dim1=ii, dim2=jj, dim3=kk, & - domainName=domainName, & - cellOrder=cellOrder, & - faceOrder=faceOrder, & - edgeOrder=edgeOrder, & - cellOrient=cellOrient, & - faceOrient=faceOrient, & - edgeOrient=edgeOrient) - -CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:kk), i1=2, i2=3, i3=1) -! CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=3, i2=1, i3=2) - -IF (ALLOCATED(temp)) DEALLOCATE (temp) - -END PROCEDURE HierarchicalElemShapeData1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HierarchicalElemShapeData2 -CALL HierarchicalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & - xidim=refelem%xidimension, elemType=refelem%name, & - refelemCoord=refelem%xij, domainName=refelem%domainName, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) -END PROCEDURE HierarchicalElemShapeData2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HierarchicalElemShapeData3 -CALL HierarchicalElemShapeData2(obj=obj, quad=quad, refelem=refelem, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) -END PROCEDURE HierarchicalElemShapeData3 - -END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/Lagrange/CMakeLists.txt b/src/submodules/ElemshapeData/src/Lagrange/CMakeLists.txt deleted file mode 100644 index 11d4222f0..000000000 --- a/src/submodules/ElemshapeData/src/Lagrange/CMakeLists.txt +++ /dev/null @@ -1,20 +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 -# - -set(src_path0 "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources(${PROJECT_NAME} - PRIVATE ${src_path0}/ElemshapeData_Lagrange@Methods.F90) diff --git a/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 deleted file mode 100644 index 3e22c4efd..000000000 --- a/src/submodules/ElemshapeData/src/Lagrange/src/ElemshapeData_Lagrange@Methods.F90 +++ /dev/null @@ -1,167 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(ElemShapeData_Lagrange) Methods -USE InputUtility, ONLY: Input - -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate - -USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE - -USE LagrangePolynomialUtility, ONLY: LagrangeDOF, & - InterpolationPoint_, & - LagrangeEvalAll, & - LagrangeEvalAll_, & - LagrangeGradientEvalAll_ - -USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & - QuadraturePoint_Size => Size - -USE BaseType, ONLY: TypeQuadratureOpt, & - TypePolynomialOpt - -USE SwapUtility, ONLY: SWAP_ - -USE Display_Method, ONLY: Display - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! ElemshapeData_InitiateLagrange -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeElemShapeData1 -REAL(DFP), ALLOCATABLE :: xij(:, :), coeff0(:, :), temp(:, :, :) -INTEGER(I4B) :: ipType0, basisType0, nips, nns, indx(10), ii, jj - -ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType) -basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType) - -! CALL DEALLOCATE (obj) - -nips = SIZE(quad%points, 2) -! pt = quad%points(1:quad%txi, 1:nips) -! wt = quad%points(quad%txi + 1, 1:nips) - -nns = LagrangeDOF(order=order, elemType=elemType) - -#ifdef DEBUG_VER -IF (nns .EQ. 0) THEN - CALL Display("Error: LagrangeDOF returned zero DOF") - STOP -END IF -#endif - -CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) - -obj%ws = quad%points(quad%txi + 1, 1:nips) - -ALLOCATE (xij(3, nns), temp(nips, nns, 3)) - -CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType0, & - layout="VEFC", xij=refelemCoord(1:xidim, :), alpha=alpha, beta=beta, & - lambda=lambda, ans=xij, nrow=indx(1), ncol=indx(2)) - -IF (PRESENT(coeff)) THEN - - CALL LagrangeEvalAll_(order=order, & - elemType=elemType, & - x=quad%points(1:quad%txi, 1:nips), & - xij=xij(1:xidim, :), & - domainName=domainName, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff(1:nns, 1:nns), firstCall=firstCall, & - ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2)) - - DO CONCURRENT(ii=1:nns, jj=1:nips) - obj%N(ii, jj) = temp(jj, ii, 1) - END DO - - CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & - x=quad%points(1:quad%txi, 1:nips), & - xij=xij(1:xidim, :), & - domainName=domainName, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff(1:nns, 1:nns), & - firstCall=.FALSE., & - ans=temp, & - dim1=indx(1), dim2=indx(2), dim3=indx(3)) - -ELSE - - ALLOCATE (coeff0(nns, nns)) - - ! obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, & - CALL LagrangeEvalAll_(order=order, elemType=elemType, & - x=quad%points(1:quad%txi, 1:nips), & - xij=xij(1:xidim, :), & - domainName=domainName, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff0, firstCall=.TRUE., & - ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2)) - - obj%N(1:nns, 1:nips) = TRANSPOSE(temp(1:nips, 1:nns, 1)) - - ! dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, & - CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, & - x=quad%points(1:quad%txi, 1:nips), & - xij=xij(1:xidim, :), & - domainName=domainName, & - basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, & - coeff=coeff0, firstCall=.FALSE., & - ans=temp, & - dim1=indx(1), dim2=indx(2), dim3=indx(3)) -END IF - -CALL SWAP_(a=obj%dNdXi, b=temp(1:indx(1), 1:indx(2), 1:indx(3)), i1=2, & - i2=3, i3=1) - -IF (ALLOCATED(temp)) DEALLOCATE (temp) -IF (ALLOCATED(xij)) DEALLOCATE (xij) -IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0) - -END PROCEDURE LagrangeElemShapeData1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeElemShapeData2 -CALL LagrangeElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & - xidim=refelem%xidimension, elemType=refelem%name, & - refelemCoord=refelem%xij, domainName=refelem%domainName, order=order, & - ipType=ipType, basisType=basisType, coeff=coeff, firstCall=firstCall, & - alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE LagrangeElemShapeData2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeElemShapeData3 -CALL LagrangeElemShapeData2(obj=obj, quad=quad, refelem=refelem, & - order=order, ipType=ipType, basisType=basisType, coeff=coeff, & - firstCall=firstCall, alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE LagrangeElemShapeData3 - -END SUBMODULE Methods From 900d78d2729668909f32fc25ef5bc5064e60d650 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 17 Sep 2024 09:45:57 +0900 Subject: [PATCH 333/359] update in polynomial --- .../Chebyshev1PolynomialUtility@Methods.F90 | 123 ++--- ...HexahedronInterpolationUtility@Methods.F90 | 327 +++++++------ .../HierarchicalPolynomialUtility@Methods.F90 | 17 +- .../src/JacobiPolynomialUtility@Methods.F90 | 89 +--- .../src/LegendrePolynomialUtility@Methods.F90 | 450 ++++++++---------- .../src/LineInterpolationUtility@Methods.F90 | 103 ++-- .../src/LobattoPolynomialUtility@Methods.F90 | 144 +++++- .../OrthogonalPolynomialUtility@Methods.F90 | 241 +++++++++- ...etrahedronInterpolationUtility@Methods.F90 | 165 ++++++- ...ltrasphericalPolynomialUtility@Methods.F90 | 65 ++- 10 files changed, 1052 insertions(+), 672 deletions(-) diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index 48f8e8013..a2c5ab5ab 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -860,87 +860,57 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1Transform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj -REAL(DFP) :: nrmsqr, areal +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) -tsize = n + 1 CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +CALL Chebyshev1Transform4_(n, coeff, PP, w, quadType, ans, tsize) -DO jj = 0, n - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) - END DO - nrmsqr = Chebyshev1NormSQR(n=jj) - ans(jj) = areal / nrmsqr -END DO - -IF (quadType .EQ. qp%GaussLobatto) THEN - areal = 0.0_DFP - jj = n - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii) - END DO - - nrmsqr = pi - ans(jj) = areal / nrmsqr -END IF +DEALLOCATE (PP) END PROCEDURE Chebyshev1Transform1_ !---------------------------------------------------------------------------- -! Chebyshev1Transform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Chebyshev1Transform2 -INTEGER(I4B) :: nrow, ncol -CALL Chebyshev1Transform2_(n, coeff, x, w, quadType, ans, nrow, ncol) -END PROCEDURE Chebyshev1Transform2 - -!---------------------------------------------------------------------------- -! Chebyshev1Transform +! Chebyshev1Transform !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj, kk +MODULE PROCEDURE Chebyshev1Transform4_ +INTEGER(I4B) :: ii, jj, nips REAL(DFP) :: nrmsqr, areal +LOGICAL(LGT) :: abool -nrow = n + 1 -ncol = SIZE(coeff, 2) +tsize = n + 1 +nips = SIZE(coeff) -CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +DO jj = 0, n + areal = 0.0_DFP -DO kk = 1, ncol - DO jj = 0, n - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, jj) - END DO - nrmsqr = Chebyshev1NormSQR(n=jj) - ans(jj, kk) = areal / nrmsqr + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO -END DO -IF (quadType .EQ. qp%GaussLobatto) THEN + nrmsqr = Chebyshev1NormSQR(n=jj) + ans(jj) = areal / nrmsqr - nrmsqr = pi - jj = n +END DO - DO kk = 1, ncol - areal = 0.0_DFP +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO +IF (abool) THEN + areal = 0.0_DFP + jj = n - ans(jj, kk) = areal / nrmsqr + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO + nrmsqr = pi + ans(jj) = areal / nrmsqr END IF -END PROCEDURE Chebyshev1Transform2_ +END PROCEDURE Chebyshev1Transform4_ !---------------------------------------------------------------------------- ! Chebyshev1Transform @@ -977,27 +947,32 @@ ! Chebyshev1Transform4 !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform4 +MODULE PROCEDURE Chebyshev1Transform2 INTEGER(I4B) :: tsize -CALL Chebyshev1Transform4_(n, coeff, quadType, ans, tsize) -END PROCEDURE Chebyshev1Transform4 +CALL Chebyshev1Transform2_(n, coeff, quadType, ans, tsize) +END PROCEDURE Chebyshev1Transform2 !---------------------------------------------------------------------------- ! Chebyshev1Transform !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Transform4_ -INTEGER(I4B) :: ii, jj +MODULE PROCEDURE Chebyshev1Transform2_ +INTEGER(I4B) :: ii, jj, nips REAL(DFP) :: avar, asign, pi_by_n, one_by_n REAL(DFP), PARAMETER :: half = 0.5_DFP, minusOne = -1.0_DFP +LOGICAL(LGT) :: abool tsize = n + 1 ans(1:tsize) = 0.0_DFP +nips = SIZE(coeff) + one_by_n = 1.0_DFP / REAL(n, KIND=DFP) pi_by_n = pi * one_by_n -IF (quadType .EQ. qp%GaussLobatto) THEN +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) + +IF (abool) THEN DO jj = 0, n @@ -1005,7 +980,7 @@ ans(jj) = coeff(0) * half + coeff(n) * half * asign - DO ii = 1, n - 1 + DO ii = 1, nips - 1 ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi_by_n * ii) END DO @@ -1025,7 +1000,7 @@ avar = jj * pi_by_n - DO ii = 0, n + DO ii = 0, nips - 1 ans(jj) = ans(jj) + coeff(ii) * COS((2.0 * ii + 1.0) * avar) END DO @@ -1037,7 +1012,7 @@ END IF -END PROCEDURE Chebyshev1Transform4_ +END PROCEDURE Chebyshev1Transform2_ !---------------------------------------------------------------------------- ! Chebyshev1InvTransform @@ -1060,28 +1035,28 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GradientCoeff1 -REAL(DFP) :: a, b, c +REAL(DFP) :: c INTEGER(I4B) :: ii REAL(DFP) :: jj -!! + ans(n) = 0.0_DFP IF (n .EQ. 0) RETURN -!! + IF (n .EQ. 1) THEN c = 2.0_DFP ELSE c = 1.0_DFP END IF -!! + ans(n - 1) = 2.0_DFP * n * coeff(n) / c -!! + DO ii = n - 1, 1, -1 jj = REAL(ii, KIND=DFP) ans(ii - 1) = 2.0_DFP * jj * coeff(ii) + ans(ii + 1) END DO -!! + ans(0) = 0.5_DFP * ans(0) -!! + END PROCEDURE Chebyshev1GradientCoeff1 !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index e0a7ae536..0bb3ab173 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -49,8 +49,8 @@ MODULE PROCEDURE GetEdgeDOF_Hexahedron2 ans = GetEdgeDOF_Hexahedron(p, p, p, p) & - & + GetEdgeDOF_Hexahedron(q, q, q, q) & - & + GetEdgeDOF_Hexahedron(r, r, r, r) + + GetEdgeDOF_Hexahedron(q, q, q, q) & + + GetEdgeDOF_Hexahedron(r, r, r, r) END PROCEDURE GetEdgeDOF_Hexahedron2 !---------------------------------------------------------------------------- @@ -67,8 +67,8 @@ MODULE PROCEDURE GetEdgeDOF_Hexahedron4 ans = GetEdgeDOF_Hexahedron(px1, px2, px3, px4) & - & + GetEdgeDOF_Hexahedron(py1, py2, py3, py4) & - & + GetEdgeDOF_Hexahedron(pz1, pz2, pz3, pz4) + + GetEdgeDOF_Hexahedron(py1, py2, py3, py4) & + + GetEdgeDOF_Hexahedron(pz1, pz2, pz3, pz4) END PROCEDURE GetEdgeDOF_Hexahedron4 !---------------------------------------------------------------------------- @@ -77,8 +77,8 @@ MODULE PROCEDURE GetFacetDOF_Hexahedron1 ans = GetFacetDOF_Hexahedron(pxy1, pxy2) & - & + GetFacetDOF_Hexahedron(pxz1, pxz2) & - & + GetFacetDOF_Hexahedron(pyz1, pyz2) + + GetFacetDOF_Hexahedron(pxz1, pxz2) & + + GetFacetDOF_Hexahedron(pyz1, pyz2) ans = 2_I4B * ans END PROCEDURE GetFacetDOF_Hexahedron1 @@ -88,8 +88,8 @@ MODULE PROCEDURE GetFacetDOF_Hexahedron2 ans = GetFacetDOF_Hexahedron(p, q) & - & + GetFacetDOF_Hexahedron(p, r) & - & + GetFacetDOF_Hexahedron(q, r) + + GetFacetDOF_Hexahedron(p, r) & + + GetFacetDOF_Hexahedron(q, r) ans = ans * 2_I4B END PROCEDURE GetFacetDOF_Hexahedron2 @@ -523,9 +523,9 @@ MODULE PROCEDURE IJK2VEFC_Hexahedron ! internal variables -INTEGER(I4B) :: cnt, ii, jj, kk, ll, N, & +INTEGER(I4B) :: cnt, ii, jj, kk, N, & & ii1, ii2, jj1, jj2, kk1, kk2, ijk(3, 8), & - & iedge, iface, p1, p2, dii, djj, dkk, startNode + & iedge, p1, p2, dii, djj, dkk, startNode INTEGER(I4B), PARAMETER :: tPoints = 8, tEdges = 12, tFacets = 6 INTEGER(I4B) :: edgeConnectivity(2, tEdges) INTEGER(I4B) :: facetConnectivity(4, tFacets) @@ -1043,96 +1043,98 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE TensorProdBasis_Hexahedron1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), p + 1) -REAL(DFP) :: Q1(SIZE(xij, 2), q + 1) -REAL(DFP) :: R1(SIZE(xij, 2), r + 1) -INTEGER(I4B) :: ii, k1, k2, k3, cnt - -x = xij(1, :) -y = xij(2, :) -z = xij(3, :) - -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -Q1 = BasisEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -R1 = BasisEvalAll_Line( & - & order=r, & - & x=z, & - & refLine="BIUNIT", & - & basisType=basisType3, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) +INTEGER(I4B) :: nrow, ncol +CALL TensorProdBasis_Hexahedron1_(p, q, r, xij, basisType1, & + basisType2, basisType3, ans, nrow, ncol, & + alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, alpha3, beta3, lambda3) +END PROCEDURE TensorProdBasis_Hexahedron1 -cnt = 0 +!---------------------------------------------------------------------------- +! TensorProdBasis_Hexahedron +!---------------------------------------------------------------------------- -DO k3 = 1, r + 1 - DO k2 = 1, q + 1 - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(:, cnt) = P1(:, k1) * Q1(:, k2) * R1(:, k3) - END DO - END DO +MODULE PROCEDURE TensorProdBasis_Hexahedron1_ +INTEGER(I4B) :: ii, k1, k2, k3, o(3), p1, q1, r1 +REAL(DFP), ALLOCATABLE :: temp(:, :) + +nrow = SIZE(xij, 2) +p1 = p + 1 +q1 = q + 1 +r1 = r + 1 +ncol = p1 * q1 * r1 + +ALLOCATE (temp(nrow, ncol)) + +o(1) = 0 +o(2) = o(1) + p1 +o(3) = o(2) + q1 + +k1 = 1 +CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & + basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, & + ans=temp(:, k1:), nrow=k2, ncol=k3) +k1 = k1 + k3 + +CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & + basisType=basisType2, alpha=alpha2, beta=beta2, lambda=lambda2, & + ans=temp(:, k1:), nrow=k2, ncol=k3) +k1 = k1 + k3 + +CALL BasisEvalAll_Line_(order=r, x=xij(3, :), refLine="BIUNIT", & + basisType=basisType3, alpha=alpha3, beta=beta3, lambda=lambda3, & + ans=temp(:, k1:), nrow=k2, ncol=k3) +k1 = k1 + k3 + +DO CONCURRENT(ii=1:nrow, k1=1:p1, k2=1:q1, k3=1:r1) + ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = & + temp(ii, o(1) + k1) * temp(ii, o(2) + k2) * temp(ii, o(3) + k3) END DO -END PROCEDURE TensorProdBasis_Hexahedron1 +DEALLOCATE (temp) + +END PROCEDURE TensorProdBasis_Hexahedron1_ !---------------------------------------------------------------------------- ! TensorProdBasis_Hexahedron !---------------------------------------------------------------------------- MODULE PROCEDURE TensorProdBasis_Hexahedron2 -REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z)) -INTEGER(I4B) :: ii, jj, cnt, kk +INTEGER(I4B) :: nrow, ncol +CALL TensorProdBasis_Hexahedron2_(p, q, r, x, y, z, basisType1, basisType2, & + basisType3, ans, nrow, ncol, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, alpha3, beta3, lambda3) +END PROCEDURE TensorProdBasis_Hexahedron2 -xij = 0.0_DFP -cnt = 0 -DO ii = 1, SIZE(x) - DO jj = 1, SIZE(y) - DO kk = 1, SIZE(z) - cnt = cnt + 1 - xij(1, cnt) = x(ii) - xij(2, cnt) = y(jj) - xij(3, cnt) = z(kk) - END DO - END DO +!---------------------------------------------------------------------------- +! TensorProdBasis_Hexahedron2_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Hexahedron2_ +REAL(DFP), ALLOCATABLE :: xij(:, :) +INTEGER(I4B) :: ii, p1, q1, r1, k1, k2, k3 + +p1 = SIZE(x, 1) +q1 = SIZE(y, 1) +r1 = SIZE(z, 1) +ii = p1 * q1 * r1 +ALLOCATE (xij(3, ii)) + +DO CONCURRENT(k1=1:p1, k2=1:q1, k3=1:r1) + xij(1, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = x(k1) + xij(2, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = y(k2) + xij(3, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = z(k3) END DO -ans = TensorProdBasis_Hexahedron1( & - & p=p, & - & q=q, & - & r=r, & - & xij=xij, & - & basisType1=basisType1, & - & basisType2=basisType2, & - & basisType3=basisType3, & - & alpha1=alpha1, & - & alpha2=alpha2, & - & alpha3=alpha3, & - & beta1=beta1, & - & beta2=beta2, & - & beta3=beta3, & - & lambda1=lambda1, & - & lambda2=lambda2, & - & lambda3=lambda3) +CALL TensorProdBasis_Hexahedron1_(p=p, q=q, r=r, xij=xij, & + basisType1=basisType1, basisType2=basisType2, basisType3=basisType3, & + alpha1=alpha1, alpha2=alpha2, alpha3=alpha3, beta1=beta1, beta2=beta2, & + beta3=beta3, lambda1=lambda1, lambda2=lambda2, lambda3=lambda3, & + ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE TensorProdBasis_Hexahedron2 +DEALLOCATE (xij) + +END PROCEDURE TensorProdBasis_Hexahedron2_ !---------------------------------------------------------------------------- ! VertexBasis_Hexahedron @@ -2754,87 +2756,84 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1 -REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2)) -REAL(DFP) :: P1(SIZE(xij, 2), p + 1) -REAL(DFP) :: Q1(SIZE(xij, 2), q + 1) -REAL(DFP) :: R1(SIZE(xij, 2), r + 1) -REAL(DFP) :: dP1(SIZE(xij, 2), p + 1) -REAL(DFP) :: dQ1(SIZE(xij, 2), q + 1) -REAL(DFP) :: dR1(SIZE(xij, 2), r + 1) - -INTEGER(I4B) :: ii, k1, k2, k3, cnt - -x = xij(1, :) -y = xij(2, :) -z = xij(3, :) - -P1 = BasisEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -Q1 = BasisEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -R1 = BasisEvalAll_Line( & - & order=r, & - & x=z, & - & refLine="BIUNIT", & - & basisType=basisType3, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) - -dP1 = BasisGradientEvalAll_Line( & - & order=p, & - & x=x, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha1, & - & beta=beta1, & - & lambda=lambda1) - -dQ1 = BasisGradientEvalAll_Line( & - & order=q, & - & x=y, & - & refLine="BIUNIT", & - & basisType=basisType1, & - & alpha=alpha2, & - & beta=beta2, & - & lambda=lambda2) - -dR1 = BasisGradientEvalAll_Line( & - & order=r, & - & x=z, & - & refLine="BIUNIT", & - & basisType=basisType3, & - & alpha=alpha3, & - & beta=beta3, & - & lambda=lambda3) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL TensorProdBasisGradient_Hexahedron1_(p, q, r, xij, & + basisType1, basisType2, basisType3, ans, dim1, dim2, dim3, & + alpha1, beta1, lambda1, alpha2, beta2, lambda2, & + alpha3, beta3, lambda3) +END PROCEDURE TensorProdBasisGradient_Hexahedron1 -cnt = 0 +!---------------------------------------------------------------------------- +! TensorProdBasisGradient_Hexahedron +!---------------------------------------------------------------------------- -DO k3 = 1, r + 1 - DO k2 = 1, q + 1 - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2) * R1(:, k3) - ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2) * R1(:, k3) - ans(:, cnt, 3) = P1(:, k1) * Q1(:, k2) * dR1(:, k3) - END DO - END DO +MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1_ +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: ii, k1, k2, k3, p1, q1, r1, o(6) + +p1 = p + 1 +q1 = q + 1 +r1 = r + 1 + +dim1 = SIZE(xij, 2) +dim2 = p1 * q1 * r1 +dim3 = 3 + +ii = 2 * dim2 +ALLOCATE (temp(dim1, ii)) + +o(1) = 0 +o(2) = o(1) + p1 +o(3) = o(2) + q1 +o(4) = o(3) + r1 +o(5) = o(4) + p1 +o(6) = o(5) + q1 + +k1 = 1 +CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & + basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, & + ans=temp(1:, 1:), nrow=ii, ncol=k2) +k1 = k1 + k2 + +CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & + basisType=basisType2, alpha=alpha2, beta=beta2, lambda=lambda2, & + ans=temp(1:, k1:), nrow=ii, ncol=k2) +k1 = k1 + k2 + +CALL BasisEvalAll_Line_(order=r, x=xij(3, :), refLine="BIUNIT", & + basisType=basisType3, alpha=alpha3, beta=beta3, lambda=lambda3, & + ans=temp(1:, k1:), nrow=ii, ncol=k2) +k1 = k1 + k2 + +CALL BasisGradientEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & + basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, & + ans=temp(1:, k1:), nrow=ii, ncol=k2) +k1 = k1 + k2 + +CALL BasisGradientEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & + basisType=basisType2, alpha=alpha2, beta=beta2, lambda=lambda2, & + ans=temp(1:, k1:), nrow=ii, ncol=k2) +k1 = k1 + k2 + +CALL BasisGradientEvalAll_Line_(order=r, x=xij(3, :), refLine="BIUNIT", & + basisType=basisType3, alpha=alpha3, beta=beta3, lambda=lambda3, & + ans=temp(1:, k1:), nrow=ii, ncol=k2) +k1 = k1 + k2 + +DO CONCURRENT(ii=1:dim1, k1=1:p1, k2=1:q1, k3=1:r1) + ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1), 1) = & + temp(ii, o(4) + k1) * temp(ii, o(2) + k2) * temp(ii, o(3) + k3) + + ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1), 2) = & + temp(ii, o(1) + k1) * temp(ii, o(5) + k2) * temp(ii, o(2) + k3) + + ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1), 3) = & + temp(ii, o(1) + k1) * temp(ii, o(2) + k2) * temp(ii, o(6) + k3) END DO -END PROCEDURE TensorProdBasisGradient_Hexahedron1 + +DEALLOCATE (temp) + +END PROCEDURE TensorProdBasisGradient_Hexahedron1_ !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 index 576237b23..462fefdbf 100644 --- a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 @@ -251,8 +251,8 @@ #ifdef DEBUG_VER CALL check_error_1d(ierr=ierr, routine=routine, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + cellOrder=cellOrder, cellOrient=cellOrient) + IF (ierr .LT. 0) RETURN #endif @@ -377,9 +377,9 @@ CASE (elemopt%Line) #ifdef DEBUG_VER - CALL check_error_2d(ierr=ierr, tface=3, routine=routine, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) + CALL check_error_1d(ierr=ierr, routine=routine, cellOrder=cellOrder, & + cellOrient=cellOrient) + IF (ierr .LT. 0) RETURN #endif @@ -471,16 +471,11 @@ ! !---------------------------------------------------------------------------- -SUBROUTINE check_error_1d(ierr, routine, cellOrder, faceOrder, edgeOrder, & - cellOrient, faceOrient, edgeOrient) +SUBROUTINE check_error_1d(ierr, routine, cellOrder, cellOrient) INTEGER(I4B), INTENT(OUT) :: ierr CHARACTER(*), INTENT(IN) :: routine INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:) INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:) ! internal variables LOGICAL(LGT) :: isok diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index 10119088c..ac43e61c7 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -1227,18 +1227,33 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiTransform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) +CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, nrow=ii, ncol=jj, & + ans=PP) +CALL JacobiTransform4_(n, alpha, beta, coeff, PP, w, quadType, ans, tsize) +DEALLOCATE (PP) +END PROCEDURE JacobiTransform1_ + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform4_ REAL(DFP) :: nrmsqr, areal -INTEGER(I4B) :: jj, ii +INTEGER(I4B) :: jj, ii, nips +LOGICAL(LGT) :: abool tsize = n + 1 -PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +nips = SIZE(coeff) DO jj = 0, n areal = 0.0_DFP - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO @@ -1247,11 +1262,13 @@ END DO -IF (quadType .EQ. qp%GaussLobatto) THEN +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) + +IF (abool) THEN areal = 0.0_DFP jj = n - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO @@ -1261,65 +1278,7 @@ END IF -END PROCEDURE JacobiTransform1_ - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform2 -INTEGER(I4B) :: nrow, ncol -CALL JacobiTransform2_(n, alpha, beta, coeff, x, w, quadType, ans, nrow, ncol) -END PROCEDURE JacobiTransform2 - -!---------------------------------------------------------------------------- -! JacobiTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE JacobiTransform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -REAL(DFP) :: nrmsqr, areal -INTEGER(I4B) :: jj, ii, kk - -nrow = n + 1 -ncol = SIZE(coeff, 2) - -PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) - -DO kk = 1, ncol - DO jj = 0, n - - areal = 0.0_DFP - - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - nrmsqr = JacobiNormSQR(n=jj, alpha=alpha, beta=beta) - ans(jj, kk) = areal / nrmsqr - - END DO -END DO - -IF (quadType .EQ. qp%GaussLobatto) THEN - - jj = n - - nrmsqr = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) * nrmsqr - - DO kk = 1, ncol - - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - ans(jj, kk) = areal / nrmsqr - END DO - -END IF - -END PROCEDURE JacobiTransform2_ +END PROCEDURE JacobiTransform4_ !---------------------------------------------------------------------------- ! JacobiTransform diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index 2e2ee5b59..2f3638d6b 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -33,6 +33,8 @@ USE BaseType, ONLY: qp => TypeQuadratureOpt +USE GlobalData, ONLY: stderr + IMPLICIT NONE CONTAINS @@ -172,12 +174,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussQuadrature -REAL(DFP) :: pn(n), fixvar +#ifdef USE_LAPACK95 +REAL(DFP) :: fixvar +REAL(DFP) :: pn(n) INTEGER(I4B) :: ii - -CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) +#endif #ifdef USE_LAPACK95 +CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) CALL STEV(D=pt, E=pn) IF (PRESENT(wt)) THEN @@ -194,7 +198,7 @@ file=__FILE__, & routine="LegendreGaussQuadrature", & line=__LINE__, & - unitno=stdout) + unitno=stderr) #endif END PROCEDURE LegendreGaussQuadrature @@ -204,7 +208,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreJacobiRadauMatrix -REAL(DFP) :: avar, r1, r2 +REAL(DFP) :: r1, r2 IF (n .LT. 1) RETURN @@ -227,34 +231,32 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussRadauQuadrature +#ifdef USE_LAPACK95 REAL(DFP) :: pn(n + 1), fixvar INTEGER(I4B) :: ii - !! + CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=pn) -!! -#ifdef USE_LAPACK95 -!! CALL STEV(D=pt, E=pn) -!! + IF (PRESENT(wt)) THEN wt = pn pn = LegendreEval(n=n, x=pt) fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) - !! + DO ii = 1, n + 1 wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) END DO END IF - !! + #else -CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file=__FILE__, & - & routine="LegendreGaussRadauQuadrature", & - & line=__LINE__, & - & unitno=stdout) + +CALL ErrorMsg(msg="The subroutine requires Lapack95 package", & + file=__FILE__, & + routine="LegendreGaussRadauQuadrature", & + line=__LINE__, & + unitno=stderr) #endif - !! + END PROCEDURE LegendreGaussRadauQuadrature !---------------------------------------------------------------------------- @@ -262,24 +264,24 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreJacobiLobattoMatrix - !! + REAL(DFP) :: r1, r2 - !! + IF (n .LT. 0) RETURN - !! + CALL LegendreJacobiMatrix( & & n=n + 1, & & D=D, & & E=E, & & alphaCoeff=alphaCoeff, & & betaCoeff=betaCoeff) - !! + D(n + 2) = 0.0_DFP r1 = REAL(n + 1, KIND=DFP) r2 = REAL(2 * n + 1, KIND=DFP) - !! + E(n + 1) = SQRT(r1 / r2) - !! + END PROCEDURE LegendreJacobiLobattoMatrix !---------------------------------------------------------------------------- @@ -287,34 +289,33 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGaussLobattoQuadrature +#ifdef USE_LAPACK95 REAL(DFP) :: pn(n + 2), fixvar INTEGER(I4B) :: ii -!! + CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=pn) -!! -#ifdef USE_LAPACK95 -!! + CALL STEV(D=pt, E=pn) -!! + IF (PRESENT(wt)) THEN wt = pn pn = LegendreEval(n=n + 1, x=pt) fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) - !! + DO ii = 1, n + 2 wt(ii) = fixvar / (pn(ii)**2) END DO END IF - !! + #else CALL ErrorMsg( & & msg="The subroutine requires Lapack95 package", & & file=__FILE__, & & routine="LegendreGaussLobattoQuadrature", & & line=__LINE__, & - & unitno=stdout) + & unitno=stderr) #endif - !! + END PROCEDURE LegendreGaussLobattoQuadrature !---------------------------------------------------------------------------- @@ -334,21 +335,21 @@ REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP REAL(DFP), ALLOCATABLE :: p(:), w(:) LOGICAL(LGT) :: inside -!! + IF (PRESENT(onlyInside)) THEN inside = onlyInside ELSE inside = .FALSE. END IF -!! + SELECT CASE (QuadType) CASE (qp%Gauss) - !! + order = n CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt) - !! + CASE (qp%GaussRadau, qp%GaussRadauLeft) - !! + IF (inside) THEN order = n ALLOCATE (p(n + 1), w(n + 1)) @@ -359,9 +360,9 @@ order = n - 1 CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) END IF - !! + CASE (qp%GaussRadauRight) - !! + IF (inside) THEN order = n ALLOCATE (p(n + 1), w(n + 1)) @@ -371,9 +372,9 @@ order = n - 1 CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) END IF - !! + CASE (qp%GaussLobatto) - !! + IF (inside) THEN order = n ALLOCATE (p(n + 2), w(n + 2)) @@ -393,33 +394,33 @@ MODULE PROCEDURE LegendreEval1 INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i, ans_1, ans_2 -!! + ans = 0.0_DFP -!! + IF (n < 0) THEN RETURN END IF -!! + ans = 1.0_DFP ans_2 = ans -!! + IF (n .EQ. 0) THEN RETURN END IF -!! + ans = x -!! + DO i = 1, n - 1 - !! + r_i = REAL(i, kind=DFP) c1 = r_i + 1.0_DFP c2 = 2.0_DFP * r_i + 1.0_DFP c3 = -r_i - !! + ans_1 = ans ans = ((c2 * x) * ans + c3 * ans_2) / c1 ans_2 = ans_1 - !! + END DO END PROCEDURE LegendreEval1 @@ -431,33 +432,33 @@ INTEGER(I4B) :: i REAL(DFP) :: c1, c2, c3, r_i REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! + ans = 0.0_DFP -!! + IF (n < 0) THEN RETURN END IF -!! + ans = 1.0_DFP ans_2 = ans -!! + IF (n .EQ. 0) THEN RETURN END IF -!! + ans = x -!! + DO i = 1, n - 1 - !! + r_i = REAL(i, kind=DFP) c1 = r_i + 1.0_DFP c2 = 2.0_DFP * r_i + 1.0_DFP c3 = -r_i - !! + ans_1 = ans ans = ((c2 * x) * ans + c3 * ans_2) / c1 ans_2 = ans_1 - !! + END DO END PROCEDURE LegendreEval2 @@ -555,30 +556,30 @@ MODULE PROCEDURE LegendreMonomialExpansionAll REAL(DFP) :: r_i INTEGER(I4B) :: ii - !! + IF (n < 0) THEN RETURN END IF -!! + ans = 0.0_DFP ans(1, 1) = 1.0_DFP - !! + IF (n .EQ. 0) THEN RETURN END IF - !! + ans(2, 2) = 1.0_DFP - !! + DO ii = 2, n - !! + r_i = REAL(ii, KIND=DFP) - !! + ans(1:ii - 1, ii + 1) = & & (-r_i + 1.0) * ans(1:ii - 1, ii - 1) / r_i - !! + ans(2:ii + 1, ii + 1) = ans(2:ii + 1, ii + 1) & & + (2.0 * r_i - 1.0) * ans(1:ii, ii) / r_i - !! + END DO END PROCEDURE LegendreMonomialExpansionAll @@ -689,46 +690,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEval1 - !! + INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP) :: p, p_1, p_2 REAL(DFP) :: ans_1, ans_2 -!! + IF (n < 0) THEN RETURN END IF -!! + p = 1.0_DFP ans = 0.0_DFP p_2 = p ans_2 = ans -!! + IF (n < 1) THEN RETURN END IF -!! + p = x ans = 1.0_DFP -!! + DO ii = 2, n - !! + r_ii = REAL(ii, KIND=DFP) - !! + p_1 = p - !! + p = ((2.0_DFP * r_ii - 1) * x * p & & - (r_ii - 1.0_DFP) * p_2) & & / r_ii - !! + p_2 = p_1 - !! + ans_1 = ans ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 ans_2 = ans_1 - !! + END DO -!! + END PROCEDURE LegendreGradientEval1 !---------------------------------------------------------------------------- @@ -736,46 +737,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreGradientEval2 -!! + INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 -!! + IF (n < 0) THEN RETURN END IF -!! + p = 1.0_DFP ans = 0.0_DFP p_2 = p ans_2 = ans -!! + IF (n < 1) THEN RETURN END IF -!! + p = x ans = 1.0_DFP -!! + DO ii = 2, n - !! + r_ii = REAL(ii, KIND=DFP) - !! + p_1 = p - !! + p = ((2.0_DFP * r_ii - 1) * x * p & & - (r_ii - 1.0_DFP) * p_2) & & / r_ii - !! + p_2 = p_1 - !! + ans_1 = ans ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 ans_2 = ans_1 - !! + END DO -!! + END PROCEDURE LegendreGradientEval2 !---------------------------------------------------------------------------- @@ -786,21 +787,21 @@ REAL(DFP) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0.0_DFP b2 = 0.0_DFP -!! + DO j = n, 1, -1 i = REAL(j, KIND=DFP) t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) b2 = b1 b1 = t END DO -!! + ans = x * b1 - b2 / 2.0_DFP + coeff(0) -!! + END PROCEDURE LegendreEvalSum1 !---------------------------------------------------------------------------- @@ -811,21 +812,21 @@ REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0.0_DFP b2 = 0.0_DFP -!! + DO j = n, 1, -1 i = REAL(j, KIND=DFP) t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) b2 = b1 b1 = t END DO -!! + ans = x * b1 - b2 / 2.0_DFP + coeff(0) -!! + END PROCEDURE LegendreEvalSum2 !---------------------------------------------------------------------------- @@ -836,12 +837,12 @@ REAL(DFP) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 -!! + DO j = n - 1, 0, -1 i = REAL(j, KIND=DFP) t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); @@ -859,12 +860,12 @@ REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 -!! + DO j = n - 1, 0, -1 i = REAL(j, KIND=DFP) t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); @@ -883,17 +884,17 @@ REAL(DFP) :: s, A1, A2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 s = 1.0_DFP -!! + DO j = 2 * k - 1, 1, -2 s = j * s END DO -!! + DO j = n - k, 0, -1 i = REAL(j, KIND=DFP) A1 = (2 * i + 2 * k + 1) / (i + 1) * x; @@ -914,26 +915,26 @@ REAL(DFP) :: s, A2 INTEGER(I4B) :: j REAL(DFP) :: i -!! + IF (n .LT. 0) RETURN -!! + b1 = 0 b2 = 0 s = 1.0_DFP -!! + DO j = 2 * k - 1, 1, -2 s = j * s END DO -!! + DO j = n - k, 0, -1 i = REAL(j, KIND=DFP) - A1 = (2 * i + 2 * k + 1) / (i + 1) * x; - A2 = -(i + 2 * k + 1) / (i + 2); - t = A1 * b1 + A2 * b2 + coeff(j + k); - b2 = b1; - b1 = t; + A1 = (2 * i + 2 * k + 1) / (i + 1) * x + A2 = -(i + 2 * k + 1) / (i + 2) + t = A1 * b1 + A2 * b2 + coeff(j + k) + b2 = b1 + b1 = t END DO -!! + ans = s * b1 END PROCEDURE LegendreGradientEvalSum4 @@ -952,92 +953,51 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LegendreTransform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) + +CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +CALL LegendreTransform4_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, & + ans=ans, tsize=tsize) +DEALLOCATE (PP) +END PROCEDURE LegendreTransform1_ + +!---------------------------------------------------------------------------- +! LegendreTransform4_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform4_ +INTEGER(I4B) :: ii, jj, nips REAL(DFP) :: nrmsqr, areal +LOGICAL(LGT) :: abool tsize = n + 1 - -! PP = LegendreEvalAll(n=n, x=x) -CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +nips = SIZE(coeff) DO jj = 0, n areal = 0.0_DFP - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO nrmsqr = LegendreNormSQR(n=jj) ans(jj) = areal / nrmsqr END DO -IF (quadType .EQ. qp%GaussLobatto) THEN +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) + +IF (abool) THEN areal = 0.0_DFP jj = n - DO ii = 0, n + DO ii = 0, nips - 1 areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) ans(jj) = areal / nrmsqr END IF - -END PROCEDURE LegendreTransform1_ - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform2 -INTEGER(I4B) :: ii, jj -CALL LegendreTransform2_(n=n, coeff=coeff, x=x, w=w, quadType=quadType, & - ans=ans, nrow=ii, ncol=jj) -END PROCEDURE LegendreTransform2 - -!---------------------------------------------------------------------------- -! LegendreTransform -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LegendreTransform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -INTEGER(I4B) :: ii, jj, kk -REAL(DFP) :: nrmsqr, areal - -nrow = n + 1 -ncol = SIZE(coeff, 2) - -CALL LegendreEvalAll_(n=n, x=x, nrow=ii, ncol=jj, ans=PP) - -DO kk = 1, ncol - DO jj = 0, n - - areal = 0.0_DFP - - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - nrmsqr = LegendreNormSQR(n=jj) - ans(jj, kk) = areal / nrmsqr - - END DO -END DO - -IF (quadType .EQ. qp%GaussLobatto) THEN - - jj = n - nrmsqr = 2.0_DFP / REAL(n, KIND=DFP) - - DO kk = 1, ncol - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - ans(jj, kk) = areal / nrmsqr - END DO - -END IF - -END PROCEDURE LegendreTransform2_ +END PROCEDURE LegendreTransform4_ !---------------------------------------------------------------------------- ! LegendreTransform @@ -1114,33 +1074,32 @@ PURE SUBROUTINE LegendreDMatrixGL(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! + ! D matrix + + ! main REAL(DFP) :: J(0:n) REAL(DFP) :: rn INTEGER(I4B) :: ii, jj - !! + rn = REAL(n, KIND=DFP) - !! + J = LegendreEval(n=n, x=x) - !! + D = 0.0_DFP D(0, 0) = 0.125_DFP * rn * (rn + 1.0_DFP) D(n, n) = -D(0, 0) - !! + DO jj = 0, n DO ii = 0, n IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - !! + END SUBROUTINE LegendreDMatrixGL !---------------------------------------------------------------------------- @@ -1149,45 +1108,45 @@ END SUBROUTINE LegendreDMatrixGL PURE SUBROUTINE LegendreDMatrixGL2(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! + ! D matrix + + ! main + REAL(DFP) :: J(0:n) REAL(DFP) :: rn INTEGER(I4B) :: ii, jj, nb2 - !! + nb2 = INT(n / 2) rn = REAL(n, KIND=DFP) - !! + J = LegendreEval(n=n, x=x) D = 0.0_DFP - !! + DO jj = 0, n DO ii = 0, nb2 IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - !! - !! correct diagonal entries - !! + + ! correct diagonal entries + DO ii = 0, nb2 D(ii, ii) = -SUM(D(ii, :)) END DO - !! - !! copy - !! + ! + ! copy + DO jj = 0, n DO ii = 0, nb2 D(n - ii, n - jj) = -D(ii, jj) END DO END DO - !! + END SUBROUTINE LegendreDMatrixGL2 !---------------------------------------------------------------------------- @@ -1196,21 +1155,21 @@ END SUBROUTINE LegendreDMatrixGL2 PURE SUBROUTINE LegendreDMatrixG(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! main - !! + ! D matrix + + ! main + REAL(DFP) :: J(0:n) INTEGER(I4B) :: ii, jj - !! - !! Compute dJ_{N-1}(a+1,b+1) - !! + + ! Compute dJ_{N-1}(a+1,b+1) + J = LegendreGradientEval(n=n + 1, x=x) - !! + DO jj = 0, n DO ii = 0, n IF (ii .EQ. jj) THEN @@ -1220,7 +1179,7 @@ PURE SUBROUTINE LegendreDMatrixG(n, x, D) END IF END DO END DO -!! + END SUBROUTINE LegendreDMatrixG !---------------------------------------------------------------------------- @@ -1229,45 +1188,40 @@ END SUBROUTINE LegendreDMatrixG PURE SUBROUTINE LegendreDMatrixG2(n, x, D) INTEGER(I4B), INTENT(IN) :: n - !! order of Jacobi polynomial + ! order of Jacobi polynomial REAL(DFP), INTENT(IN) :: x(0:n) - !! quadrature points + ! quadrature points REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) - !! D matrix - !! - !! internal variables - !! + ! D matrix + + ! internal variables REAL(DFP) :: J(0:n) INTEGER(I4B) :: ii, jj, nb2 - !! - !! main - !! + + ! main nb2 = INT(n / 2) D = 0.0_DFP - !! + J = LegendreGradientEval(n=n + 1, x=x) - !! + DO jj = 0, n DO ii = 0, nb2 IF (ii .NE. jj) & & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) END DO END DO - !! - !! correct diagonal entries - !! + + ! correct diagonal entries DO ii = 0, nb2 D(ii, ii) = -SUM(D(ii, :)) END DO - !! - !! copy - !! + + ! copy DO jj = 0, n DO ii = 0, nb2 D(n - ii, n - jj) = -D(ii, jj) END DO END DO - !! END SUBROUTINE LegendreDMatrixG2 !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 35d72c00a..585bee1dd 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -1833,13 +1833,31 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE OrthogonalBasis_Line1 -CHARACTER(1) :: astr +INTEGER(I4B) :: nrow, ncol +CALL OrthogonalBasis_Line1_(order=order, xij=xij, refline=refline, & + basisType=basisType, ans=ans, nrow=nrow, ncol=ncol, & + alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE OrthogonalBasis_Line1 + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Line1_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Line1_ LOGICAL(LGT) :: isok, abool +#ifdef DEBUG_VER +#endif + +CHARACTER(1) :: astr +REAL(DFP) :: x(SIZE(xij, 2)) -ans = 0.0_DFP +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 @@ -1849,7 +1867,6 @@ END SUBROUTINE handle_error CALL Errormsg(routine="OrthogonalBasis_Line1()", & msg="alpha and beta should be present for basisType=Jacobi", & file=__FILE__, line=__LINE__, unitno=stderr) - RETURN END IF @@ -1875,19 +1892,18 @@ END SUBROUTINE handle_error SELECT CASE (astr) CASE ("U") - - ans = EvalAllOrthopol(n=order, & - x=FromUnitLine2BiUnitLine(xin=xij(1, :)), orthopol=basisType, & - alpha=alpha, beta=beta, lambda=lambda) + 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") - - ans = EvalAllOrthopol(n=order, x=xij(1, :), orthopol=basisType, & - alpha=alpha, beta=beta, lambda=lambda) + CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, & + alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) CASE DEFAULT - ans = 0.0_DFP + 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) @@ -1895,39 +1911,58 @@ END SUBROUTINE handle_error END SELECT -END PROCEDURE OrthogonalBasis_Line1 +END PROCEDURE OrthogonalBasis_Line1_ !---------------------------------------------------------------------------- ! OrthogonalBasisGradient_Line1 !---------------------------------------------------------------------------- MODULE PROCEDURE OrthogonalBasisGradient_Line1 -TYPE(String) :: astr -astr = UpperCase(refLine) +INTEGER(I4B) :: dim1, dim2, dim3 +CALL OrthogonalBasisGradient_Line1_(order=order, xij=xij, refline=refline, & + basisType=basisType, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE OrthogonalBasisGradient_Line1 + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Line1_ +CHARACTER(1) :: astr +REAL(DFP) :: x(SIZE(xij, 2)) +INTEGER(I4B) :: ii, jj + +astr = UpperCase(refline(1:1)) +dim1 = SIZE(xij, 2) +dim2 = order + 1 +dim3 = 1 + +SELECT CASE (astr) +CASE ("U") + + CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=x, tsize=dim1) + CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType, & + ans=ans(:, :, 1), nrow=dim1, ncol=dim2) + + DO CONCURRENT(ii=1:dim1, jj=1:dim2) + ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP + END DO + +CASE ("B") + CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, & + ans=ans(:, :, 1), nrow=dim1, ncol=dim2) -SELECT CASE (astr%chars()) -CASE ("UNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), & - & orthopol=basisType) - ans = ans * 2.0_DFP -CASE ("BIUNIT") - ans(:, :, 1) = GradientEvalAllOrthopol( & - & n=order, & - & x=xij(1, :), & - & orthopol=basisType) CASE DEFAULT - ans = 0.0_DFP - CALL Errormsg(& - & msg="No case found for refline.", & - & file=__FILE__, & - & routine=" OrthogonalBasisGradient_Line1", & - & line=__LINE__, & - & unitno=stderr) + + ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + CALL Errormsg(msg="No case found for refline.", & + routine=" OrthogonalBasisGradient_Line1_", & + file=__FILE__, line=__LINE__, unitno=stderr) RETURN + END SELECT -END PROCEDURE OrthogonalBasisGradient_Line1 +END PROCEDURE OrthogonalBasisGradient_Line1_ !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 index 3dff6e8c6..c06f05c04 100644 --- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -16,17 +16,96 @@ ! SUBMODULE(LobattoPolynomialUtility) Methods -USE BaseMethod +USE Sym_LinearSolveMethods, ONLY: SymLinSolve + +USE LegendrePolynomialUtility, ONLY: LegendreLeadingCoeff, & + LegendreNormSqr, & + LegendreEval, & + LegendreEvalAll_, & + LegendreMonomialExpansionAll, & + LegendreQuadrature + +USE JacobiPolynomialUtility, ONLY: JacobiZeros + +USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalEvalAll_, & + UltrasphericalGradientEvalAll_, & + UltrasphericalGradientEvalAll + IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! LobattoTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoTransform1_ +INTEGER(I4B) :: ii, jj, nips +REAL(DFP) :: areal(0:n), massmat(0:n, 0:n) + +tsize = n + 1 +areal = 0.0_DFP +nips = SIZE(coeff) + +DO jj = 0, n + DO ii = 0, nips - 1 + areal(jj) = areal(jj) + PP(ii, jj) * w(ii) * coeff(ii) + END DO +END DO + +massmat = LobattoMassMatrix(n=n) + +CALL SymLinSolve(X=ans(0:n), A=massmat(0:n, 0:n), B=areal(0:n)) + +END PROCEDURE LobattoTransform1_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoTransform2_ +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips + +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) +CALL LobattoEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj) +CALL LobattoTransform_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, & + ans=ans, tsize=tsize) +DEALLOCATE (PP) +END PROCEDURE LobattoTransform2_ + +!---------------------------------------------------------------------------- +! LobattoTransform_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoTransform3_ +REAL(DFP) :: pt(0:n + 1), wt(0:n + 1), coeff(0:n + 1), x +REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP +INTEGER(I4B) :: ii, nips + +nips = n + 2 +CALL LegendreQuadrature(n=nips, pt=pt, wt=wt, quadType=quadType) +!! We are using n+2 quadrature points as it works well in case of +!! GaussLobatto quadrature points also + +DO ii = 0, nips - 1 + x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2 + x = x * half + coeff(ii) = f(x) +END DO + +CALL LobattoTransform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, & + ans=ans, tsize=tsize) + +END PROCEDURE LobattoTransform3_ + !---------------------------------------------------------------------------- ! LobattoLeadingCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE LobattoLeadingCoeff REAL(DFP) :: avar, m - !! + SELECT CASE (n) CASE (0) ans = 0.5_DFP @@ -380,7 +459,6 @@ ans(1:nrow, 1) = -0.5_DFP ans(1:nrow, 2) = 0.5_DFP - !! p = LegendreEvalAll(n=n - 1_I4B, x=x) CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, nrow=nrow, ncol=ii) DO ii = 1, n - 1 @@ -509,6 +587,66 @@ END PROCEDURE LobattoStiffnessMatrix +!---------------------------------------------------------------------------- +! Lobatto0 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Lobatto0 +ans = 0.5_DFP * (1.0_DFP - x) +END PROCEDURE Lobatto0 + +MODULE PROCEDURE Lobatto1 +ans = 0.5_DFP * (1.0_DFP + x) +END PROCEDURE Lobatto1 + +MODULE PROCEDURE Lobatto2 +REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(3.0_DFP) / SQRT(2.0_DFP) +ans = coeff * (x**2 - 1.0_DFP) +END PROCEDURE Lobatto2 + +MODULE PROCEDURE Lobatto3 +REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(5.0_DFP) / SQRT(2.0_DFP) +ans = coeff * (x**2 - 1.0_DFP) * x +END PROCEDURE Lobatto3 + +MODULE PROCEDURE Lobatto4 +REAL(DFP), PARAMETER :: coeff = SQRT(7.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (5.0_DFP * x**2 - 1.0_DFP) +END PROCEDURE Lobatto4 + +MODULE PROCEDURE Lobatto5 +REAL(DFP), PARAMETER :: coeff = SQRT(9.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (7.0_DFP * x**2 - 3.0_DFP) * x +END PROCEDURE Lobatto5 + +MODULE PROCEDURE Lobatto6 +REAL(DFP), PARAMETER :: coeff = SQRT(11.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (21.0_DFP * x**4 - 14.0_DFP * x**2 + 1.0_DFP) +END PROCEDURE Lobatto6 + +MODULE PROCEDURE Lobatto7 +REAL(DFP), PARAMETER :: coeff = SQRT(13.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (33.0_DFP * x**4 - 30.0_DFP * x**2 + 5.0_DFP) * x +END PROCEDURE Lobatto7 + +MODULE PROCEDURE Lobatto8 +REAL(DFP), PARAMETER :: coeff = SQRT(15.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (429.0_DFP * x**6 - 495.0_DFP * x**4 & + + 135.0_DFP * x**2 - 5.0_DFP) +END PROCEDURE Lobatto8 + +MODULE PROCEDURE Lobatto9 +REAL(DFP), PARAMETER :: coeff = SQRT(17.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (715.0_DFP * x**6 - 1001.0_DFP * x**4 & + + 385.0_DFP * x**2 - 35.0_DFP) * x +END PROCEDURE Lobatto9 + +MODULE PROCEDURE Lobatto10 +REAL(DFP), PARAMETER :: coeff = SQRT(19.0_DFP) / SQRT(2.0_DFP) / 256.0_DFP +ans = coeff * (x**2 - 1.0_DFP) * (2431.0_DFP * x**8 - 4004.0_DFP * x**6 & + + 2002.0_DFP * x**4 - 308.0_DFP * x**2 + 7.0_DFP) +END PROCEDURE Lobatto10 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index 143c35aea..45bbc689c 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -16,7 +16,68 @@ ! SUBMODULE(OrthogonalPolynomialUtility) Methods -USE BaseMethod +USE GlobalData, ONLY: stderr + +USE ReferenceElement_Method, ONLY: XiDimension + +USE InputUtility, ONLY: Input + +USE ErrorHandling, ONLY: ErrorMsg + +USE BaseType, ONLY: poly => TypePolynomialOpt, & + elem => TypeElemNameOpt + +USE LagrangePolynomialUtility, ONLY: LagrangeDOF + +USE JacobiPolynomialUtility, ONLY: JacobiEvalAll, & + JacobiEvalAll_, & + JacobiGradientEvalAll, & + JacobiGradientEvalAll_ + +USE UltrasphericalPolynomialUtility, ONLY: UltraSphericalEvalAll, & + UltraSphericalEvalAll_, & + UltraSphericalGradientEvalAll, & + UltraSphericalGradientEvalAll_ + +USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1EvalAll, & + Chebyshev1EvalAll_, & + Chebyshev1GradientEvalAll, & + Chebyshev1GradientEvalAll_ + +USE LegendrePolynomialUtility, ONLY: LegendreEvalAll, & + LegendreEvalAll_, & + LegendreGradientEvalAll, & + LegendreGradientEvalAll_ + +USE LobattoPolynomialUtility, ONLY: LobattoEvalAll, & + LobattoEvalAll_, & + LobattoGradientEvalAll, & + LobattoGradientEvalAll_ + +USE UnscaledLobattoPolynomialUtility, ONLY: UnscaledLobattoEvalAll, & + UnscaledLobattoEvalAll_, & + UnscaledLobattoGradientEvalAll, & + UnscaledLobattoGradientEvalAll_ + +USE LineInterpolationUtility, ONLY: OrthogonalBasis_Line_, & + OrthogonalBasisGradient_Line_ + +USE TriangleInterpolationUtility, ONLY: OrthogonalBasis_Triangle_, & + OrthogonalBasisGradient_Triangle_ + +USE QuadrangleInterpolationUtility, ONLY: OrthogonalBasis_Quadrangle_, & + OrthogonalBasisGradient_Quadrangle_ + +USE TetrahedronInterpolationUtility, ONLY: OrthogonalBasis_Tetrahedron_, & + OrthogonalBasisGradient_Tetrahedron_ + +USE HexahedronInterpolationUtility, ONLY: OrthogonalBasis_Hexahedron_, & + OrthogonalBasisGradient_Hexahedron_ + +! USE PrismInterpolationUtility, ONLY: OrthogonalBasis_Prism_ + +! USE PyramidInterpolationUtility, ONLY: OrthogonalBasis_Pyramid_ + IMPLICIT NONE CONTAINS @@ -29,8 +90,8 @@ INTEGER(I4B) :: ii, n REAL(DFP) :: y00, ym10 -y00 = INPUT(default=1.0_DFP, option=y0) -ym10 = INPUT(default=0.0_DFP, option=ym1) +y00 = Input(default=1.0_DFP, option=y0) +ym10 = Input(default=0.0_DFP, option=ym1) !! The size of c, alpha, beta should be same n+1: 0 to n !! The size of u is n+2, 0 to n+1 @@ -51,8 +112,8 @@ REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c)) :: u INTEGER(I4B) :: ii, n REAL(DFP) :: y00, ym10 -y00 = INPUT(default=1.0_DFP, option=y0) -ym10 = INPUT(default=0.0_DFP, option=ym1) +y00 = Input(default=1.0_DFP, option=y0) +ym10 = Input(default=0.0_DFP, option=ym1) !! The size of c, alpha, beta should be same n+1: 0 to n !! The size of u is n+2, 0 to n+1 n = SIZE(c) - 1 @@ -120,17 +181,17 @@ MODULE PROCEDURE EvalAllOrthopol SELECT CASE (orthopol) -CASE (Jacobi) +CASE (poly%Jacobi) ans = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) -CASE (Ultraspherical) +CASE (poly%Ultraspherical) ans = UltraSphericalEvalAll(n=n, lambda=lambda, x=x) -CASE (Legendre) +CASE (poly%Legendre) ans = LegendreEvalAll(n=n, x=x) -CASE (Chebyshev) +CASE (poly%Chebyshev) ans = Chebyshev1EvalAll(n=n, x=x) -CASE (Lobatto) +CASE (poly%Lobatto) ans = LobattoEvalAll(n=n, x=x) -CASE (UnscaledLobatto) +CASE (poly%UnscaledLobatto) ans = UnscaledLobattoEvalAll(n=n, x=x) END SELECT END PROCEDURE EvalAllOrthopol @@ -141,19 +202,22 @@ MODULE PROCEDURE EvalAllOrthopol_ SELECT CASE (orthopol) -CASE (Jacobi) +CASE (poly%Jacobi) CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, nrow=nrow, & ncol=ncol) -CASE (Ultraspherical) +CASE (poly%Ultraspherical) CALL UltraSphericalEvalAll_(n=n, lambda=lambda, x=x, ans=ans, nrow=nrow, & ncol=ncol) -CASE (Legendre) +CASE (poly%Legendre) CALL LegendreEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) -CASE (Chebyshev) + +CASE (poly%Chebyshev) CALL Chebyshev1EvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) -CASE (Lobatto) + +CASE (poly%Lobatto) CALL LobattoEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) -CASE (UnscaledLobatto) + +CASE (poly%UnscaledLobatto) CALL UnscaledLobattoEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) END SELECT END PROCEDURE EvalAllOrthopol_ @@ -174,29 +238,29 @@ MODULE PROCEDURE GradientEvalAllOrthopol_ SELECT CASE (orthopol) -CASE (Jacobi) +CASE (poly%Jacobi) ! ans(1:nrow, 1:ncol) = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) CALL JacobiGradientEvalAll_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, & nrow=nrow, ncol=ncol) -CASE (Ultraspherical) +CASE (poly%Ultraspherical) ! ans(1:nrow, 1:ncol) = UltraSphericalGradientEvalAll(n=n, lambda=lambda, x=x) CALL UltraSphericalGradientEvalAll_(n=n, lambda=lambda, x=x, ans=ans, & nrow=nrow, ncol=ncol) -CASE (Legendre) +CASE (poly%Legendre) ! ans(1:nrow, 1:ncol) = LegendreGradientEvalAll(n=n, x=x) CALL LegendreGradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) -CASE (Chebyshev) +CASE (poly%Chebyshev) ! ans(1:nrow, 1:ncol) = Chebyshev1GradientEvalAll(n=n, x=x) CALL Chebyshev1GradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) -CASE (Lobatto) +CASE (poly%Lobatto) ! ans(1:nrow, 1:ncol) = LobattoGradientEvalAll(n=n, x=x) CALL LobattoGradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) -CASE (UnscaledLobatto) +CASE (poly%UnscaledLobatto) ! ans(1:nrow, 1:ncol) = UnscaledLobattoGradientEvalAll(n=n, x=x) CALL UnscaledLobattoGradientEvalAll_(n=n, x=x, ans=ans, & nrow=nrow, ncol=ncol) @@ -204,6 +268,137 @@ END SELECT END PROCEDURE GradientEvalAllOrthopol_ +!---------------------------------------------------------------------------- +! OrthogonalEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalEvalAll +INTEGER(I4B) :: nrow, ncol +nrow = SIZE(xij, 2) +ncol = LagrangeDOF(order=order, elemType=elemType) +ALLOCATE (ans(nrow, ncol)) +CALL OrthogonalEvalAll_(order=order, elemType=elemType, xij=xij, & + domainName=domainName, basisType=basisType, ans=ans, nrow=nrow, & + ncol=ncol, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE OrthogonalEvalAll + +!---------------------------------------------------------------------------- +! OrthogonalEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalEvalAll_ +SELECT CASE (elemType) + +CASE (elem%Line) + + CALL OrthogonalBasis_Line_(order=order, xij=xij, & + refLine=domainName, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) + +CASE (elem%Triangle) + + CALL OrthogonalBasis_Triangle_(order=order, xij=xij, & + reftriangle=domainName, ans=ans, nrow=nrow, ncol=ncol) + +CASE (elem%Quadrangle) + + CALL OrthogonalBasis_Quadrangle_(p=order, q=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol, basisType1=basisType, & + basisType2=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, & + alpha2=alpha, beta2=beta, lambda2=lambda) + +CASE (elem%Tetrahedron) + + CALL OrthogonalBasis_Tetrahedron_(order=order, xij=xij, & + refTetrahedron=domainName, ans=ans, nrow=nrow, ncol=ncol) + +CASE (elem%Hexahedron) + + CALL OrthogonalBasis_Hexahedron_(p=order, q=order, r=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol, & + basisType1=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, & + basisType2=basisType, alpha2=alpha, beta2=beta, lambda2=lambda, & + basisType3=basisType, alpha3=alpha, beta3=beta, lambda3=lambda) + +CASE DEFAULT + + CALL ErrorMsg(msg="No case found for topology", & + routine='OrthogonalEvalAll_()', & + file=__FILE__, line=__LINE__, unitno=stderr) + + RETURN + +END SELECT + +END PROCEDURE OrthogonalEvalAll_ + +!---------------------------------------------------------------------------- +! OrthogonalGradientEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalGradientEvalAll +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = SIZE(xij, 2) +dim2 = LagrangeDOF(order=order, elemType=elemType) +dim3 = XiDimension(elemType) +ALLOCATE (ans(dim1, dim2, dim3)) + +CALL OrthogonalGradientEvalAll_(order, elemType, xij, domainName, basisType, & + ans, dim1, dim2, dim3, alpha, beta, lambda) + +END PROCEDURE OrthogonalGradientEvalAll + +!---------------------------------------------------------------------------- +! OrthogonalGradientEvalAll_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalGradientEvalAll_ + +SELECT CASE (elemType) + +CASE (elem%Line) + + CALL OrthogonalBasisGradient_Line_(order=order, xij=xij, & + refLine=domainName, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (elem%Triangle) + + CALL OrthogonalBasisGradient_Triangle_(order=order, xij=xij, & + reftriangle=domainName, ans=ans, tsize1=dim1, tsize2=dim2, tsize3=dim3) + +CASE (elem%Quadrangle) + + CALL OrthogonalBasisGradient_Quadrangle_(p=order, q=order, xij=xij, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, basisType1=basisType, & + basisType2=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, & + alpha2=alpha, beta2=beta, lambda2=lambda) + +CASE (elem%Tetrahedron) + + CALL OrthogonalBasisGradient_Tetrahedron_(order=order, xij=xij, & + refTetrahedron=domainName, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (elem%Hexahedron) + + CALL OrthogonalBasisGradient_Hexahedron_(p=order, q=order, r=order, & + xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + basisType1=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, & + basisType2=basisType, alpha2=alpha, beta2=beta, lambda2=lambda, & + basisType3=basisType, alpha3=alpha, beta3=beta, lambda3=lambda) + +CASE DEFAULT + + CALL ErrorMsg(msg="No case found for topology", & + routine='OrthogonalGradientEvalAll_()', & + file=__FILE__, line=__LINE__, unitno=stderr) + + RETURN + +END SELECT +END PROCEDURE OrthogonalGradientEvalAll_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index 2f844cc8a..fc5d4241e 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -97,10 +97,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetFacetDOF_Tetrahedron1 -ans = (ps1 - 1) * (ps1 - 2) / 2 & - & + (ps2 - 1) * (ps2 - 2) / 2 & - & + (ps3 - 1) * (ps3 - 2) / 2 & - & + (ps4 - 1) * (ps4 - 2) / 2 +ans = (ps1 - 1) * (ps1 - 2) / 2 & + + (ps2 - 1) * (ps2 - 2) / 2 & + + (ps3 - 1) * (ps3 - 2) / 2 & + + (ps4 - 1) * (ps4 - 2) / 2 END PROCEDURE GetFacetDOF_Tetrahedron1 !---------------------------------------------------------------------------- @@ -145,15 +145,15 @@ SELECT CASE (baseInterpol0%chars()) CASE ( & - & "HIERARCHYPOLYNOMIAL", & - & "HIERARCHY", & - & "HEIRARCHYPOLYNOMIAL", & - & "HEIRARCHY", & - & "HIERARCHYINTERPOLATION", & - & "HEIRARCHYINTERPOLATION", & - & "ORTHOGONALPOLYNOMIAL", & - & "ORTHOGONAL", & - & "ORTHOGONALINTERPOLATION") + "HIERARCHYPOLYNOMIAL", & + "HIERARCHY", & + "HEIRARCHYPOLYNOMIAL", & + "HEIRARCHY", & + "HIERARCHYINTERPOLATION", & + "HEIRARCHYINTERPOLATION", & + "ORTHOGONALPOLYNOMIAL", & + "ORTHOGONAL", & + "ORTHOGONALINTERPOLATION") ans(:, 1) = [1, 2, 3] ans(:, 2) = [1, 2, 4] ans(:, 3) = [1, 3, 4] @@ -2898,6 +2898,145 @@ END SUBROUTINE IJK2VEFC_Triangle END PROCEDURE OrthogonalBasisGradient_Tetrahedron1 +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Tetrahedron1_ +CHARACTER(1) :: layout +REAL(DFP) :: x(1:3, 1:SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), 0:order) +REAL(DFP) :: Q1(SIZE(xij, 2), 0:order) +REAL(DFP) :: R1(SIZE(xij, 2), 0:order) +REAL(DFP) :: dP1(SIZE(xij, 2), 0:order) +REAL(DFP) :: dQ1(SIZE(xij, 2), 0:order) +REAL(DFP) :: dR1(SIZE(xij, 2), 0:order) +REAL(DFP) :: temp(SIZE(xij, 2), 10), areal, breal +INTEGER(I4B) :: cnt +INTEGER(I4B) :: p, q, r +LOGICAL(LGT) :: isBiunit +REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), SIZE(ans, 3)) + +dim1 = SIZE(xij, 2) +dim2 = (order + 1) * (order + 2) * (order + 3) / 6 +dim3 = 3 + +ans0 = 0.0_DFP +layout = UpperCase(refTetrahedron(1:1)) + +SELECT CASE (layout) +CASE ("B") + x = FromBiUnitTetrahedron2BiUnitHexahedron(xin=xij) + isBiunit = .TRUE. +CASE ("U") + x = FromUnitTetrahedron2BiUnitHexahedron(xin=xij) + isBiunit = .FALSE. +END SELECT + +temp(:, 1) = 0.5_DFP * (1.0_DFP - x(2, :)) +temp(:, 2) = 0.5_DFP * (1.0_DFP - x(3, :)) + +P1 = LegendreEvalAll(n=order, x=x(1, :)) +dP1 = LegendreGradientEvalAll(n=order, x=x(1, :)) +cnt = 0 + +DO p = 0, order + areal = -0.5_DFP * REAL(p, DFP) + + Q1 = JacobiEvalAll( & + & n=order, & + & x=x(2, :), & + & alpha=REAL(2 * p + 1, DFP), & + & beta=0.0_DFP & + & ) + + dQ1 = JacobiGradientEvalAll( & + & n=order, & + & x=x(2, :), & + & alpha=REAL(2 * p + 1, DFP), & + & beta=0.0_DFP & + & ) + + temp(:, 3) = temp(:, 1)**MAX(p - 1_I4B, 0_I4B) + temp(:, 4) = temp(:, 3) * temp(:, 1) + + DO q = 0, order - p + + breal = -0.5_DFP * REAL(p + q, DFP) + + R1 = JacobiEvalAll( & + & n=order, & + & x=x(3, :), & + & alpha=REAL(2 * p + 2 * q + 2, DFP), & + & beta=0.0_DFP & + & ) + + dR1 = JacobiGradientEvalAll( & + & n=order, & + & x=x(3, :), & + & alpha=REAL(2 * p + 2 * q + 2, DFP), & + & beta=0.0_DFP & + & ) + + temp(:, 5) = P1(:, p) * Q1(:, q) + temp(:, 6) = P1(:, p) * dQ1(:, q) + temp(:, 7) = dP1(:, p) * Q1(:, q) + temp(:, 9) = temp(:, 2)**MAX(p + q - 1_I4B, 0_I4B) + temp(:, 10) = temp(:, 9) * temp(:, 2) + + DO r = 0, order - p - q + temp(:, 8) = temp(:, 5) * R1(:, r) + cnt = cnt + 1 + ans0(:, cnt, 1) = temp(:, 7) * R1(:, r) * temp(:, 4) * temp(:, 10) + ans0(:, cnt, 2) = temp(:, 8) * areal * temp(:, 3) * temp(:, 10) & + + temp(:, 6) * R1(:, r) * temp(:, 4) * temp(:, 10) + ans0(:, cnt, 2) = temp(:, 8) * breal * temp(:, 4) * temp(:, 9) & + + temp(:, 5) * dR1(:, r) * temp(:, 4) * temp(:, 10) + END DO + END DO +END DO + +IF (isBiunit) THEN + temp(:, 1) = x(1, :) + temp(:, 2) = x(2, :) + temp(:, 3) = x(3, :) + + temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3)) + temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3)) + temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3)) + temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2 + + DO CONCURRENT(p=1:dim2) + ans(1:dim1, p, 1) = -temp(:, 4) * ans0(:, p, 1) + ans(1:dim1, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2) + ans(1:dim1, p, 3) = temp(:, 5) * ans0(:, p, 1) & + + temp(:, 7) * ans0(:, p, 2) & + + ans0(:, p, 3) + END DO + +ELSE + + temp(:, 1:3) = FromUnitTetrahedron2BiUnitTetrahedron(x) + + temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3)) + temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3)) + temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3)) + temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2 + + DO CONCURRENT(p=1:dim2) + ans(1:dim1, p, 1) = -temp(:, 4) * ans0(:, p, 1) + ans(1:dim1, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2) + ans(1:dim1, p, 3) = temp(:, 5) * ans0(:, p, 1) & + & + temp(:, 7) * ans0(:, p, 2) & + & + ans0(:, p, 3) + END DO + + ans(1:dim1, 1:dim2, 1:dim3) = 2.0_DFP * ans(1:dim1, 1:dim2, 1:dim3) + +END IF + +END PROCEDURE OrthogonalBasisGradient_Tetrahedron1_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 index 833c4ea2e..2b580884c 100644 --- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -869,9 +869,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE UltrasphericalTransform1_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP REAL(DFP) :: nrmsqr, areal, rn -INTEGER(I4B) :: jj, ii +REAL(DFP), ALLOCATABLE :: PP(:, :) +INTEGER(I4B) :: ii, jj, nips +nips = SIZE(coeff) +ALLOCATE (PP(nips, n + 1)) tsize = n + 1 @@ -904,63 +906,52 @@ END IF +DEALLOCATE (PP) + END PROCEDURE UltrasphericalTransform1_ !---------------------------------------------------------------------------- ! UltrasphericalTransform !---------------------------------------------------------------------------- -MODULE PROCEDURE UltrasphericalTransform2 -INTEGER(I4B) :: nrow, ncol -CALL UltrasphericalTransform2_(n, lambda, coeff, x, w, quadType, ans, nrow, & - ncol) -END PROCEDURE UltrasphericalTransform2 +MODULE PROCEDURE UltrasphericalTransform4_ +REAL(DFP) :: nrmsqr, areal, rn +INTEGER(I4B) :: jj, ii, nips +LOGICAL(LGT) :: abool -!---------------------------------------------------------------------------- -! UltrasphericalTransform -!---------------------------------------------------------------------------- +tsize = n + 1 +nips = SIZE(coeff) -MODULE PROCEDURE UltrasphericalTransform2_ -REAL(DFP), DIMENSION(0:n, 0:n) :: PP -REAL(DFP) :: nrmsqr, areal, rn -INTEGER(I4B) :: jj, ii, kk +DO jj = 0, n + areal = 0.0_DFP -nrow = n + 1 -ncol = SIZE(coeff, 2) + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) + END DO -CALL UltrasphericalEvalAll_(n=n, lambda=lambda, x=x, ans=PP, nrow=ii, ncol=jj) + nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) + ans(jj) = areal / nrmsqr -DO kk = 1, ncol - DO jj = 0, n - areal = 0.0_DFP +END DO - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO +abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1) - nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda) - ans(jj, kk) = areal / nrmsqr +IF (abool) THEN + areal = 0.0_DFP + jj = n + DO ii = 0, nips - 1 + areal = areal + PP(ii, jj) * w(ii) * coeff(ii) END DO -END DO -IF (quadType .EQ. qp%GaussLobatto) THEN - jj = n rn = REAL(n, KIND=DFP) nrmsqr = 2.0_DFP * (rn + lambda) / rn * nrmsqr - DO kk = 1, ncol - areal = 0.0_DFP - DO ii = 0, n - areal = areal + PP(ii, jj) * w(ii) * coeff(ii, kk) - END DO - - ans(jj, kk) = areal / nrmsqr - END DO + ans(jj) = areal / nrmsqr END IF -END PROCEDURE UltrasphericalTransform2_ +END PROCEDURE UltrasphericalTransform4_ !---------------------------------------------------------------------------- ! UltrasphericalTransform From fed61396373e309cc38f21d416ade5ef5ae9cac3 Mon Sep 17 00:00:00 2001 From: shion Date: Tue, 17 Sep 2024 11:17:39 +0900 Subject: [PATCH 334/359] Updating BaseType - fixing minor issue --- src/modules/BaseType/src/BaseType.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index ab3584f78..9e22b3853 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -1418,7 +1418,7 @@ END SUBROUTINE highorder_refelem & Jacobian=NULL()) TYPE :: ShapeDataPointer_ - CLASS(ShapeDataPointer_), POINTER :: ptr => NULL() + CLASS(ShapeData_), POINTER :: ptr => NULL() END TYPE ShapeDataPointer_ !---------------------------------------------------------------------------- @@ -1503,7 +1503,7 @@ END SUBROUTINE highorder_refelem Ws=NULL(), dNdXt=NULL(), Thickness=NULL(), Coord=NULL(), Normal=NULL()) TYPE :: ElemShapeDataPointer_ - CLASS(ShapeDataPointer_), POINTER :: ptr => NULL() + CLASS(ElemShapeData_), POINTER :: ptr => NULL() END TYPE ElemShapeDataPointer_ !---------------------------------------------------------------------------- From 8fe0145a7cdd6d4b12a80e1b7bf914f18f2555ce Mon Sep 17 00:00:00 2001 From: shion Date: Mon, 23 Sep 2024 15:13:16 +0900 Subject: [PATCH 335/359] Updates GridPointUtility - fixing the issue for MeshGrid2D --- .../Utility/src/GridPointUtility@Methods.F90 | 36 +++++++++---------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/submodules/Utility/src/GridPointUtility@Methods.F90 b/src/submodules/Utility/src/GridPointUtility@Methods.F90 index a01b11291..d98d73f10 100644 --- a/src/submodules/Utility/src/GridPointUtility@Methods.F90 +++ b/src/submodules/Utility/src/GridPointUtility@Methods.F90 @@ -38,7 +38,7 @@ beta = LOG(a) / (N - 1) alpha = (rmax - rmin) / (EXP(beta * N) - 1) DO i = 1, N + 1 - ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin + ans(i) = alpha * (EXP(beta * (i - 1)) - 1) + rmin END DO ELSE IF (N .EQ. 1) THEN ans(1) = rmin @@ -54,19 +54,19 @@ MODULE PROCEDURE ExpMesh_Real32 INTEGER(I4B) :: i -REAL(Real32) :: alpha, beta +REAL(REAL32) :: alpha, beta !! IF (ABS(a - 1) .LT. TINY(1.0_DFP)) THEN alpha = (rmax - rmin) / N DO i = 1, N + 1 - ans(i) = alpha * (i - 1.0_Real32) + rmin + ans(i) = alpha * (i - 1.0_REAL32) + rmin END DO ELSE IF (N .GT. 1) THEN beta = LOG(a) / (N - 1) alpha = (rmax - rmin) / (EXP(beta * N) - 1) DO i = 1, N + 1 - ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin + ans(i) = alpha * (EXP(beta * (i - 1)) - 1) + rmin END DO ELSE IF (N .EQ. 1) THEN ans(1) = rmin @@ -82,7 +82,7 @@ MODULE PROCEDURE LinSpace_Real32 ! Local vars -REAL(Real32) :: dx +REAL(REAL32) :: dx INTEGER(I4B) :: i INTEGER(I4B) :: nn !! main @@ -91,7 +91,7 @@ ans = [a] ELSE ALLOCATE (ans(nn)) - dx = (b - a) / REAL((nn - 1), Real32) + dx = (b - a) / REAL((nn - 1), REAL32) ans = [(i * dx + a, i=0, nn - 1)] END IF END PROCEDURE LinSpace_Real32 @@ -102,7 +102,7 @@ MODULE PROCEDURE LinSpace_Real64 ! Local vars -REAL(Real64) :: dx +REAL(REAL64) :: dx INTEGER(I4B) :: i INTEGER(I4B) :: nn !> main @@ -111,7 +111,7 @@ ans = [a] ELSE ALLOCATE (ans(nn)) - dx = (b - a) / REAL((nn - 1), Real64) + dx = (b - a) / REAL((nn - 1), REAL64) ans = [(i * dx + a, i=0, nn - 1)] END IF END PROCEDURE LinSpace_Real64 @@ -123,7 +123,7 @@ MODULE PROCEDURE LogSpace_Real32 INTEGER(I4B) :: base0, n0 LOGICAL(LGT) :: endpoint0 -REAL(Real32), ALLOCATABLE :: ans0(:) +REAL(REAL32), ALLOCATABLE :: ans0(:) !! endpoint0 = INPUT(option=endPoint, default=.TRUE.) base0 = INPUT(option=base, default=10) @@ -147,7 +147,7 @@ MODULE PROCEDURE LogSpace_Real64 INTEGER(I4B) :: base0, n0 LOGICAL(LGT) :: endpoint0 -REAL(Real64), ALLOCATABLE :: ans0(:) +REAL(REAL64), ALLOCATABLE :: ans0(:) !! endpoint0 = INPUT(option=endPoint, default=.TRUE.) base0 = INPUT(option=base, default=10) @@ -175,8 +175,8 @@ ! Initial setting nx = SIZE(xgv, dim=1) ny = SIZE(ygv, dim=1) -CALL Reallocate(x, ny, nx) -CALL Reallocate(y, ny, nx) +CALL Reallocate(x, nx, ny) +CALL Reallocate(y, nx, ny) x(:, :) = SPREAD(xgv, dim=2, ncopies=ny) y(:, :) = SPREAD(ygv, dim=1, ncopies=nx) END PROCEDURE MeshGrid2D_Real64 @@ -192,8 +192,8 @@ ! Initial setting nx = SIZE(xgv, dim=1) ny = SIZE(ygv, dim=1) -CALL Reallocate(x, ny, nx) -CALL Reallocate(y, ny, nx) +CALL Reallocate(x, nx, ny) +CALL Reallocate(y, nx, ny) x(:, :) = SPREAD(xgv, dim=2, ncopies=ny) y(:, :) = SPREAD(ygv, dim=1, ncopies=nx) END PROCEDURE MeshGrid2D_Real32 @@ -203,8 +203,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE MeshGrid3D_Real64 -integer :: nx, ny, nz, i -nx = size(xgv); ny = size(ygv); nz = size(zgv) +INTEGER :: nx, ny, nz, i +nx = SIZE(xgv); ny = SIZE(ygv); nz = SIZE(zgv) CALL Reallocate(x, nx, ny, nz) CALL Reallocate(y, nx, ny, nz) CALL Reallocate(z, nx, ny, nz) @@ -222,8 +222,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE MeshGrid3D_Real32 -integer :: nx, ny, nz, i -nx = size(xgv); ny = size(ygv); nz = size(zgv) +INTEGER :: nx, ny, nz, i +nx = SIZE(xgv); ny = SIZE(ygv); nz = SIZE(zgv) CALL Reallocate(x, ny, nx, nz) CALL Reallocate(y, ny, nx, nz) CALL Reallocate(z, ny, nx, nz) From e466dbce504186de4cd7fa93afe7b69048dfea5e Mon Sep 17 00:00:00 2001 From: shion Date: Mon, 23 Sep 2024 15:15:36 +0900 Subject: [PATCH 336/359] Updates BaseMethod - cleaning ogpf (Gnuplot utility) - now gnuplot can be controlled through Gnuplot_Class in easifemClasses --- src/modules/BaseMethod/src/BaseMethod.F90 | 2 +- src/modules/CMakeLists.txt | 2 +- src/modules/Gnuplot/CMakeLists.txt | 13 - src/modules/Gnuplot/src/ogpf.F90 | 2662 --------------------- 4 files changed, 2 insertions(+), 2677 deletions(-) delete mode 100644 src/modules/Gnuplot/CMakeLists.txt delete mode 100644 src/modules/Gnuplot/src/ogpf.F90 diff --git a/src/modules/BaseMethod/src/BaseMethod.F90 b/src/modules/BaseMethod/src/BaseMethod.F90 index 04f1ed78f..05e20dc46 100644 --- a/src/modules/BaseMethod/src/BaseMethod.F90 +++ b/src/modules/BaseMethod/src/BaseMethod.F90 @@ -83,7 +83,7 @@ MODULE BaseMethod USE OpenMP_Method USE GlobalData USE Hashing32 -USE OGPF +! USE OGPF USE Test_Method USE MdEncode_Method ! USE DISPMODULE diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 18beb64bf..396c467c6 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -61,7 +61,7 @@ include(${CMAKE_CURRENT_LIST_DIR}/ARPACK/CMakeLists.txt) include(${CMAKE_CURRENT_LIST_DIR}/Hashing/CMakeLists.txt) # Gnuplot -include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt) +# include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt) # CInterface include(${CMAKE_CURRENT_LIST_DIR}/CInterface/CMakeLists.txt) diff --git a/src/modules/Gnuplot/CMakeLists.txt b/src/modules/Gnuplot/CMakeLists.txt deleted file mode 100644 index 78b80f677..000000000 --- a/src/modules/Gnuplot/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved -# -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- - -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ogpf.F90 -) \ No newline at end of file diff --git a/src/modules/Gnuplot/src/ogpf.F90 b/src/modules/Gnuplot/src/ogpf.F90 deleted file mode 100644 index ff86405a8..000000000 --- a/src/modules/Gnuplot/src/ogpf.F90 +++ /dev/null @@ -1,2662 +0,0 @@ -!------------------------------------------------------------------------------- -! GnuPlot Interface -!------------------------------------------------------------------------------- -! Purpose: Object Based Interface to GnuPlot from Fortran (ogpf) -! Platform: Windows XP/Vista/7/10 -! (It should work on other platforms, see the finalize_plot subroutine below) -! Language: Fortran 2003 and 2008 -! Requires: 1. Fortran 2003 compiler (e.g gfortran 5, IVF 12.1, ...) -! There is only two more features needs Fortran 2008 standard -! execute_command_line and passing internal function as argument. -! 2. gnuplot 5 and higher (other previous version can be used -! Author: Mohammad Rahmani -! Chem Eng Dep., Amirkabir Uni. of Tech -! Tehran, Ir -! url: aut.ac.ir/m.rahmani -! github: github.com/kookma -! email: m[dot]rahmani[at]aut[dot]ac[dot]ir -! -! -! Acknowledgement: -! Special thanks to Hagen Wierstorf (http://www.gnuplotting.org) -! For vluable codes and examples on using gnuplot -! Some examples and color palletes are provided by gnuplotting. -! - - -! Revision History - -! Revision 0.22 -! Date: Mar 9th, 2018 -! - a new procedure called use_extra_configuration is used to set general gnuplot settings -! - new type for labels (xlabel, ylabel, zlabel, title,...) -! - all lables now accept text color, font name, font size, rorate by degree -! - Secondary axes can use different scale (linear or logarithmic) -! - subroutine plot2d_matrix_vs_matrix(xmat,ymat) -! now plots a matrix columns ymat aganist another matrix column xmat -! - added more examples - -! Revision 0.21 -! Date: Mar 8th, 2018 -! - new axes to plot command to use secondary axes added! - - -! Revision: 0.20 -! Date: Feb 20th, 2018 -! - ogpf now supports animation for 2D and 3D plots -! - rewrite contour and surface plot -! - select_precision has been merged into ogpf -! - new add_script procedure replaced old script -! - new run_script procedure -! - writestring procedure removed -! - linespec for plor2d_matrix_vs_plot now is a single dynamic string -! - splot now uses datablok instead of inline data -! - meshgrid now support full grid vector -! - arange a numpy similar function to create a range in the form of [xa, xa+dx, xa+2*dx, ...] -! - new num2str routines - - - -! Revision: 0.19 -! Date: Jan 15th, 2018 -! - new contour plot procedure - - -! Revision: 0.18 -! Date: Dec 22th, 2017 -! Major revision -! - The dynamic string allocation of Fortran 2003 is used (some old compilers -! does not support this capability) -! - Multiple windows plot now supported -! - Multiplot now supported -! - Gnuplot script file extension is changed from .plt to .gp -! - Default window size (canvas) changed to 640x480 -! - Persist set to on (true) by default -! - A separate subroutine is used now to create the output file for gnuplot commands -! - A separate subroutine is used now to finalize the output - -! - - -! Revision: 0.17 -! Date: Dec 18th, 2017 -! Minor corrections -! - Correct the meshgrid for wrong dy calculation when ygv is sent by two elements. -! - Remove the subroutine ErrHandler (development postponed to future release) - - -! Revision: 0.16 -! Date: Feb 11th, 2016 -! Minor corrections -! Correct the lspec processing in plot2D_matrix_vs_vector -! Now, it is possible to send less line specification and gpf will cycle through lspec - -! Revision: 0.15 -! Date: Apr 20th, 2012 -! Minor corrections -! Use of select_precision module and working precision: wp - -! Revision: 0.14 -! Date: Mar 28th, 2012 -! Minor corrections -! Use of import keyboard and removing the Precision module -! Length of Title string increased by 80 chars - - -! Revision: 0.13 -! Date: Feb 12th, 2012 -! Minor corrections -! Added axis method which sets the axis limits for x-axis, y-axis and z-axis -! Added Precision module - - - -! Version: 0.12 -! Date: Feb 9th, 2012 -! Minor corrections -! New semilogx, semilogy, loglog methods -! New options method, allow to be called several times to set the gnuplot options - - - -! Version: 0.11 -! Date: Feb 9th, 2012 -! Minor corrections -! Use of NEWUINT specifier from Fortran 2008 -! Added configuration parameters -! Extra procedures have been removed -! Temporary file is now deleted using close(...,status='delete') - -! -! Version: 0.1 -! Date: Jan 5th, 2012 -! First object-based version - -MODULE OGPF -USE GlobalData, ONLY: wp=>DFP, sp=>Real32, dp=>Real64 -IMPLICIT NONE -PRIVATE -! Library information -CHARACTER(LEN=*), PARAMETER :: md_name = 'ogpf libray' -CHARACTER(LEN=*), PARAMETER :: md_rev = 'Rev. 0.22 of March 9th, 2018' -CHARACTER(LEN=*), PARAMETER :: md_lic = 'Licence: MIT' - -! ogpf Configuration parameters -! The terminal and font have been set for Windows operating system -! Correct to meet the requirements on other OS like Linux and Mac. -CHARACTER(LEN=*), PARAMETER :: gnuplot_term_type = 'wxt' -!! Output terminal -CHARACTER(LEN=*), PARAMETER :: gnuplot_term_font = 'verdana,10' -!! font -CHARACTER(LEN=*), PARAMETER :: gnuplot_term_size = '640,480' -!! '960,840' ! plot window size -CHARACTER(LEN=*), PARAMETER :: gnuplot_output_filename='ogpf_temp_script.gp' !! temporary file for output -!! extra configuration can be set using ogpf object - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! module procedure -! convert integer, real, double precision into string -INTERFACE num2str - MODULE PROCEDURE num2str_i4, num2str_r4, num2str_r8 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 0.22 -! tplabel is a structure for gnuplot labels including -! title, xlabel, x2label, ylabel, ... -INTEGER, PARAMETER, PRIVATE :: NOT_INITIALIZED = -32000 -TYPE TPLABEL - LOGICAL :: has_label = .false. - CHARACTER(LEN=:), ALLOCATABLE :: lbltext - CHARACTER(LEN=:), ALLOCATABLE :: lblcolor - CHARACTER(LEN=:), ALLOCATABLE :: lblfontname - INTEGER :: lblfontsize = NOT_INITIALIZED - INTEGER :: lblrotate = NOT_INITIALIZED -END TYPE TPLABEL - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! the gpf class implement the object for using gnuplot from fortran in a semi-interactive mode! -! the fortran actually do the job and write out the commands and data in a single file and then -! calls the gnuplot by shell command to plot the data - -TYPE, PUBLIC :: GPF - PRIVATE - !> 0.22 - TYPE(TPLABEL) :: tpplottitle - TYPE(TPLABEL) :: tpxlabel - TYPE(TPLABEL) :: tpx2label - TYPE(TPLABEL) :: tpylabel - TYPE(TPLABEL) :: tpy2label - TYPE(TPLABEL) :: tpzlabel - CHARACTER(LEN=:), ALLOCATABLE :: txtoptions - !! a long string to store all type of gnuplot options - CHARACTER(LEN=:), ALLOCATABLE :: txtscript - !! a long string to store gnuplot script - CHARACTER(LEN=:), ALLOCATABLE :: txtdatastyle - !! lines, points, linepoints - LOGICAL :: hasxrange = .false. - LOGICAL :: hasx2range = .false. - LOGICAL :: hasyrange = .false. - LOGICAL :: hasy2range = .false. - LOGICAL :: haszrange = .false. - LOGICAL :: hasoptions = .false. - LOGICAL :: hasanimation = .false. - LOGICAL :: hasfilename = .false. - LOGICAL :: hasfileopen = .false. - REAL(wp) :: xrange(2), yrange(2), zrange(2) - REAL(wp) :: x2range(2), y2range(2) - CHARACTER(len=8) :: plotscale - ! multiplot parameters - LOGICAL :: hasmultiplot = .false. - INTEGER :: multiplot_rows - INTEGER :: multiplot_cols - INTEGER :: multiplot_total_plots - ! animation - INTEGER :: pause_seconds = 0 - !! keep plot on screen for this value in seconds - INTEGER :: frame_number - !! frame number in animation - ! use for debugging and error handling - CHARACTER(LEN=:), ALLOCATABLE :: msg - !! Message from plot procedures - INTEGER :: status=0 - !!Status from plot procedures - INTEGER :: file_unit - !! file unit identifier - CHARACTER(LEN=:), ALLOCATABLE :: txtfilename - !! the name of physical file to write the gnuplot script - ! ogpf preset configuration (kind of gnuplot initialization) - LOGICAL :: preset_configuration = .true. - CONTAINS - PRIVATE - ! local private procedures - PROCEDURE, PASS, PRIVATE :: preset_gnuplot_config - PROCEDURE, PASS, PRIVATE :: plot2d_vector_vs_vector - PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_vector - PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_matrix - PROCEDURE, PASS, PRIVATE :: semilogxv - PROCEDURE, PASS, PRIVATE :: semilogxm - PROCEDURE, PASS, PRIVATE :: semilogyv - PROCEDURE, PASS, PRIVATE :: semilogym - PROCEDURE, PASS, PRIVATE :: loglogv - PROCEDURE, PASS, PRIVATE :: loglogm - !> 0.22 - PROCEDURE, PASS, PRIVATE :: set_label - ! public procedures - PROCEDURE, PASS, PUBLIC :: options => set_options - PROCEDURE, PASS, PUBLIC :: title => set_plottitle - PROCEDURE, PASS, PUBLIC :: xlabel => set_xlabel - PROCEDURE, PASS, PUBLIC :: x2label => set_x2label - PROCEDURE, PASS, PUBLIC :: ylabel => set_ylabel - PROCEDURE, PASS, PUBLIC :: y2label => set_y2label - PROCEDURE, PASS, PUBLIC :: zlabel => set_zlabel - PROCEDURE, PASS, PUBLIC :: axis => set_axis - PROCEDURE, PASS, PUBLIC :: axis_sc => set_secondary_axis - PROCEDURE, PASS, PUBLIC :: filename => set_filename - PROCEDURE, PASS, PUBLIC :: reset => reset_to_defaults - PROCEDURE, PASS, PUBLIC :: preset => use_preset_configuration - PROCEDURE, PASS, PUBLIC :: multiplot => sub_multiplot - GENERIC, PUBLIC :: plot => & - & plot2d_vector_vs_vector, & - & plot2d_matrix_vs_vector, & - & plot2d_matrix_vs_matrix - GENERIC, PUBLIC :: semilogx => semilogxv, semilogxm - GENERIC, PUBLIC :: semilogy => semilogyv, semilogym - GENERIC, PUBLIC :: loglog => loglogv, loglogm - PROCEDURE, PASS, PUBLIC :: surf => splot ! 3D surface plot - PROCEDURE, PASS, PUBLIC :: lplot => lplot3d ! 3D line plot - PROCEDURE, PASS, PUBLIC :: contour => cplot ! contour plot - PROCEDURE, PASS, PUBLIC :: fplot => function_plot - PROCEDURE, PASS, PUBLIC :: add_script => addscript - PROCEDURE, PASS, PUBLIC :: run_script => runscript - PROCEDURE, PASS, PUBLIC :: animation_start => sub_animation_start - PROCEDURE, PASS, PUBLIC :: animation_show => sub_animation_show -END TYPE GPF - -CONTAINS - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section One: Set/Get Methods for ogpf object - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine use_preset_configuration(this,flag) - !.............................................................................. - !Set a flag to tell ogpf if the customized gnuplot configuration should - !be used - !.............................................................................. - - class(gpf):: this - logical, intent(in) :: flag - - ! default is true - this%preset_configuration = flag - - end subroutine use_preset_configuration - - - - subroutine set_filename(this,string) - !.............................................................................. - !Set a file name for plot command output - !This file can be used later by gnuplot as an script file to reproduce the plot - !.............................................................................. - - class(gpf):: this - character(len=*), intent(in) :: string - - this%txtfilename = trim(string) - this%hasfilename = .true. - - end subroutine set_filename - - - subroutine set_options(this,stropt) - !.............................................................................. - ! Set the plot options. This is a very powerfull procedure accepts many types - ! of gnuplot command and customization - !.............................................................................. - - class(gpf):: this - character(len=*), intent(in) :: stropt - - if(.not.allocated(this%txtoptions))this%txtoptions='' - if (len_trim(this%txtoptions) == 0 ) then - this%txtoptions = '' ! initialize string - end if - if ( len_trim(stropt)>0 ) then - this%txtoptions = this%txtoptions // splitstr(stropt) - end if - - this%hasoptions=.true. - - end subroutine set_options - - - - - subroutine set_axis(this,rng) - !.............................................................................. - !Set the axes limits in form of [xmin, xmax, ymin, ymax, zmin, zmax] - !.............................................................................. - - class(gpf):: this - real(wp), intent(in) :: rng(:) - integer :: n - n=size(rng,dim=1) - select case(n) - case(2) !Only the range for x-axis has been sent - this%hasxrange=.true. - this%xrange=rng(1:2) - case(4) - this%hasxrange=.true. - this%hasyrange=.true. - this%xrange=rng(1:2) - this%yrange=rng(3:4) - case(6) - this%hasxrange=.true. - this%hasyrange=.true. - this%haszrange=.true. - this%xrange=rng(1:2) - this%yrange=rng(3:4) - this%zrange=rng(5:6) - case default - print*, 'gpf error: wrong axis range setting!' - return - end select - - end subroutine set_axis - - - subroutine set_secondary_axis(this,rng) - !.............................................................................. - !Set the secondary axes limits in form of [x2min, x2max, y2min, y2max] - !.............................................................................. - - class(gpf):: this - real(wp), intent(in) :: rng(:) - integer :: n - n=size(rng,dim=1) - select case(n) - case(2) !Only the range for x2-axis has been sent - this%hasx2range=.true. - this%x2range=rng(1:2) - case(4) - this%hasx2range=.true. - this%hasy2range=.true. - this%x2range=rng(1:2) - this%y2range=rng(3:4) - case default - print*, 'gpf error: wrong axis range setting!' - return - end select - - end subroutine set_secondary_axis - - - subroutine set_plottitle(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the plot title - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('plot_title', string, textcolor, font_size, font_name, rotate) - - end subroutine set_plottitle - - - subroutine set_xlabel(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the xlabel - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('xlabel', string, textcolor, font_size, font_name, rotate) - - end subroutine set_xlabel - - - subroutine set_x2label(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the x2label - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('x2label', string, textcolor, font_size, font_name, rotate) - - end subroutine set_x2label - - - subroutine set_ylabel(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the ylabel - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('ylabel', string, textcolor, font_size, font_name, rotate) - - end subroutine set_ylabel - - - - subroutine set_y2label(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the y2label - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('y2label', string, textcolor, font_size, font_name, rotate) - - end subroutine set_y2label - - - subroutine set_zlabel(this, string, textcolor, font_size, font_name, rotate) - !.............................................................................. - !Set the zlabel - !.............................................................................. - class(gpf):: this - character(len=*), intent(in) :: string - character(len=*), intent(in), optional :: textcolor - integer, optional :: font_size - character(len=*), intent(in), optional :: font_name - integer, optional :: rotate - - call this%set_label('zlabel', string, textcolor, font_size, font_name, rotate) - - end subroutine set_zlabel - - - !> 0.22 - - subroutine set_label(this, lblname, lbltext, lblcolor, font_size, font_name, rotate) - !.............................................................................. - ! Set the text, color, font, size and rotation for labels including - ! title, xlabel, x2label, ylabel, .... - !.............................................................................. - - class(gpf):: this - character(len=*), intent(in) :: lblname - character(len=*), intent(in) :: lbltext - character(len=*), intent(in), optional :: lblcolor - character(len=*), intent(in), optional :: font_name - integer, optional :: font_size - integer, optional :: rotate - - ! local variable - type(tplabel) :: label - - label%has_label = .true. - label%lbltext = trim(lbltext) - - if (present(lblcolor)) then - label%lblcolor = lblcolor - end if - - if (present(font_name)) then - label%lblfontname = font_name - else - if(.not.allocated(label%lblfontname))then - label%lblfontname = '' - endif - end if - - if (present(font_size)) then - label%lblfontsize = font_size - end if - - if (present(rotate)) then - label%lblrotate = rotate - end if - - select case (lblname) - case ('xlabel') - this%tpxlabel = label - case ('x2label') - this%tpx2label = label - case ('ylabel') - this%tpylabel = label - case ('y2label') - this%tpy2label = label - case ('zlabel') - this%tpzlabel = label - case ('plot_title') - this%tpplottitle = label - end select - - - end subroutine set_label - - - - subroutine reset_to_defaults(this) - !.............................................................................. - !Reset all ogpf properties (params to their default values - !............................................................................... - class(gpf):: this - - this%preset_configuration = .true. - this%txtfilename = gnuplot_output_filename - - if (allocated(this%txtoptions)) deallocate(this%txtoptions) - if (allocated(this%txtscript)) deallocate(this%txtscript) - if (allocated(this%txtdatastyle)) deallocate(this%txtdatastyle) - if (allocated(this%msg)) deallocate(this%msg) - - this%hasoptions = .false. - - this%hasxrange = .false. - this%hasx2range = .false. - this%hasyrange = .false. - this%hasy2range = .false. - this%haszrange = .false. - - this%pause_seconds = 0 - this%status = 0 - this%hasanimation = .false. - this%hasfileopen = .false. - this%hasmultiplot = .false. - - this%plotscale = '' - this%tpplottitle%has_label =.false. - this%tpxlabel%has_label =.false. - this%tpx2label%has_label =.false. - this%tpylabel%has_label =.false. - this%tpy2label%has_label =.false. - this%tpzlabel%has_label =.false. - - - end subroutine reset_to_defaults - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Two: Main Plotting Routines - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine sub_multiplot(this, rows, cols) - !.............................................................................. - ! This subroutine sets flag and number of rows and columns in case - ! of multiplot layout - !.............................................................................. - - class(gpf):: this - integer, intent(in) :: rows - integer, intent(in) :: cols - - ! ogpf does not support multiplot in animation mode - if (this%hasanimation) then - print*, md_name // ': ogpf does not support animation in multiplot mode' - stop - end if - - ! set multiplot cols and rows - if (rows> 0 ) then - this%multiplot_rows = rows - else - - end if - if (cols > 0 ) then - this%multiplot_cols = cols - else - - end if - - ! set the multiplot layout flag and plot numbers - this%hasmultiplot = .true. - this%multiplot_total_plots = 0 - - ! create the ouput file for writting gnuplot script - call create_outputfile(this) - - - end subroutine sub_multiplot - - - subroutine plot2d_vector_vs_vector(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - !.............................................................................. - ! This procedure plots: - ! 1. A vector against another vector (xy plot) - ! 2. A vector versus its element indices (yi plot). - ! 3. Can accept up to 4 data sets as x,y pairs! - ! Arguments - ! xi, yi vectors of data series, - ! lsi a string maximum 80 characters containing the line specification, - ! legends, ... - ! axesi is the axes for plotting: secondary axes are x2, and y2 - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - - ! Local variables - !---------------------------------------------------------------------- - - integer:: nx1 - integer:: ny1 - integer:: nx2 - integer:: ny2 - integer:: nx3 - integer:: ny3 - integer:: nx4 - integer:: ny4 - integer:: number_of_plots - character(len=3):: plottype - integer:: i - character(len=80) :: pltstring(4) ! Four 80 characters string - - !Initialize variables - plottype = '' - pltstring = '' - - ! Check the input - nx1=size(x1) - if ((present(y1) )) then - ny1=size(y1) - if (checkdim(nx1,ny1)) then - plottype='xy1' - number_of_plots=1 - else - print*, md_name // ':plot2d_vector_vs_vector:' // 'length of x1 and y1 does not match' - return - end if - else !plot only x againest its element indices - plottype='xi' - number_of_plots=1 - end if - - !Process line spec and axes set for first data set if present - call process_linespec(1, pltstring(1), ls1, axes1) - - - if (present(x2) .and. present (y2)) then - nx2=size(x2) - ny2=size(y2) - if (checkdim(nx2,ny2)) then - plottype='xy2' - number_of_plots=2 - else - return - end if - !Process line spec for 2nd data set if present - call process_linespec(2, pltstring(2), ls2, axes2) - end if - - if (present(x3) .and. present (y3)) then - nx3=size(x3) - ny3=size(y3) - if (checkdim(nx3,ny3)) then - plottype='xy3' - number_of_plots=3 - else - return - end if - !Process line spec for 3rd data set if present - call process_linespec(3, pltstring(3), ls3, axes3) - end if - - if (present(x4) .and. present (y4)) then - nx4=size(x4) - ny4=size(y4) - if (checkdim(nx4,ny4)) then - plottype='xy4' - number_of_plots=4 - else - return - end if - !Process line spec for 4th data set if present - call process_linespec(4, pltstring(4), ls4, axes4) - end if - - - call create_outputfile(this) - - ! Write plot title, axis labels and other annotations - call processcmd(this) - - ! Write plot command and line styles and legend if any - if (number_of_plots ==1) then - write ( this%file_unit, '(a)' ) trim(pltstring(1)) - else - write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_plots-1) - write ( this%file_unit, '(a)' ) trim(pltstring(number_of_plots)) - end if - ! Write xy data into file - select case (plottype) - case ('xi') - call write_xydata(this%file_unit,nx1,x1) - case ('xy1') - call write_xydata(this%file_unit,nx1,x1,y1) - case ('xy2') - call write_xydata(this%file_unit,nx1,x1,y1) - call write_xydata(this%file_unit,nx2,x2,y2) - case ('xy3') - call write_xydata(this%file_unit,nx1,x1,y1) - call write_xydata(this%file_unit,nx2,x2,y2) - call write_xydata(this%file_unit,nx3,x3,y3) - case ('xy4') - call write_xydata(this%file_unit,nx1,x1,y1) - call write_xydata(this%file_unit,nx2,x2,y2) - call write_xydata(this%file_unit,nx3,x3,y3) - call write_xydata(this%file_unit,nx4,x4,y4) - end select - - !> Rev 0.2 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - - !: End of plot2D_vector_vs_vector - end subroutine plot2d_vector_vs_vector - - - - subroutine plot2d_matrix_vs_vector(this, xv,ymat, lspec) - !.............................................................................. - ! plot2D_matrix_vs_vector accepts a vector xv and a matrix ymat and plots - ! columns of ymat against xv. lspec is an optional array defines the line - ! specification for each data series. If a single element array is sent for - ! lspec then all series are plotted using the same linespec - !.............................................................................. - - implicit none - class(gpf):: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - !---------------------------------------------------------------------- - ! Local variables - integer:: nx - integer:: ny - integer:: ns - integer:: number_of_curves - integer:: i - integer:: j - integer:: ierr - character(len=80), allocatable :: pltstring(:), lst(:) - ! - - !******************************************************************************* - ! Check the input - nx=size(xv) - ny=size(ymat,dim=1) - if (.not. checkdim(nx,ny)) then - print*, md_name // ':plot2d_matrix_vs_vector:' // 'The length of arrays does not match' - return - end if - ! create the outfile to write the gnuplot script - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write plot command and line styles and legend if any - number_of_curves=size(ymat,dim=2) - allocate(pltstring(number_of_curves), stat=ierr) - if (ierr /=0) then - print*, 'allocation error' - return - end if - - ! assume no linespec is available - pltstring(1:number_of_curves) = '' - - if ( present(lspec) ) then - - call splitstring2array(lspec,lst,';') - ns = size(lst, dim=1) - - if (ns == number_of_curves) then - ! there is a linespec for each curve - pltstring = lst - elseif (ns < number_of_curves) then - ! not enough linespec - do i=1, ns - pltstring(i) = lst(i) - end do - else ! ns > number_of curves - print*, 'ogpf: plot2d_matrix_vs_vector: wrong number of linespec' - print*, 'semicolon ";" acts as delimiter, check the linespec' - end if - end if - - if ( present(lspec) ) then - - call process_linespec(1,pltstring(1),lst(1)) - ns=size(lst) - ! gpf will cylce through line specification, if number of specification passed - ! is less than number of plots - do i=1, number_of_curves - j=mod(i-1, ns) + 1 - call process_linespec(i, pltstring(i), lst(j)) - end do - else !No lspec is available - pltstring(1)=' plot "-" notitle,' - pltstring(2:number_of_curves-1)='"-" notitle,' - pltstring(number_of_curves)='"-" notitle' - end if - - ! Write plot command and line styles and legend if any - write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1) - write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves)) - - ! Write data into script file - do j=1, number_of_curves - do i = 1, nx - write ( this%file_unit, * ) xv(i),ymat(i,j) - end do - write ( this%file_unit, '(a)' ) 'e' !end of jth set of data - end do - - - !> Rev 0.2 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !Release memory - if (allocated(pltstring)) then - deallocate(pltstring) - end if - !: End of plot2D_matrix_vs_vector - end subroutine plot2d_matrix_vs_vector - - - - subroutine plot2d_matrix_vs_matrix(this, xmat,ymat, lspec) - !.............................................................................. - ! plot2D_matrix_vs_matrix accepts a matrix xmat and a matrix ymat and plots - ! columns of ymat against columns of xmat. lspec is an optional array defines - ! the line specification for each data series. If a single element array is - ! sent for lspec then all series are plotted using the same linespec - !.............................................................................. - - implicit none - class(gpf):: this - ! Input arrays - real(wp), intent(in) :: xmat(:,:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - !---------------------------------------------------------------------- - ! Local variables - integer:: mx, nx - integer:: my, ny - integer:: ns - integer:: number_of_curves - integer:: i - integer:: j - integer:: ierr - character(len=80), allocatable :: pltstring(:), lst(:) - ! - - !******************************************************************************* - ! Check the input - ! check number of rows - mx=size(xmat,dim=1) - my=size(ymat,dim=1) - if (.not. checkdim(mx,my)) then - print*, md_name // ':plot2d_matrix_vs_matrix:' // 'The length of arrays does not match' - return - end if - ! check number of rows - nx=size(xmat,dim=2) - ny=size(ymat,dim=2) - if (.not. checkdim(nx,ny)) then - print*, 'gpf error: The number of columns are different, check xmat, ymat' - return - end if - - - ! create the outfile to write the gnuplot script - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write plot command and line styles and legend if any - number_of_curves=size(ymat,dim=2) - allocate(pltstring(number_of_curves), stat=ierr) - if (ierr /=0) then - print*, 'allocation error' - return - end if - - ! assume no linespec is available - pltstring(1:number_of_curves) = '' - - if ( present(lspec) ) then - - call splitstring2array(lspec,lst,';') - ns = size(lst, dim=1) - - if (ns == number_of_curves) then - ! there is a linespec for each curve - pltstring = lst - elseif (ns < number_of_curves) then - ! not enough linespec - do i=1, ns - pltstring(i) = lst(i) - end do - else ! ns > number_of curves - print*, md_name // ': plot2d_matrix_vs_matrix:'//' wrong number of linespec' - print*, 'semicolon ";" acts as delimiter, check the linespec' - end if - end if - - if ( present(lspec) ) then - - call process_linespec(1,pltstring(1),lst(1)) - ns=size(lst) - ! gpf will cylce through line specification, if number of specification passed - ! is less than number of plots - do i=1, number_of_curves - j=mod(i-1, ns) + 1 - call process_linespec(i, pltstring(i), lst(j)) - end do - else !No lspec is available - pltstring(1)=' plot "-" notitle,' - pltstring(2:number_of_curves-1)='"-" notitle,' - pltstring(number_of_curves)='"-" notitle' - end if - - ! Write plot command and line styles and legend if any - write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1) - write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves)) - - ! Write data into script file - do j=1, number_of_curves - do i = 1, mx - write ( this%file_unit, * ) xmat(i,j),ymat(i,j) - end do - write ( this%file_unit, '(a)' ) 'e' !end of jth set of data - end do - - !> Rev 0.2 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !Release memory - if (allocated(pltstring)) then - deallocate(pltstring) - end if - !: End of plot2D_matrix_vs_vector - end subroutine plot2d_matrix_vs_matrix - - - subroutine splot(this, x, y, z, lspec, palette) - !.............................................................................. - ! splot create a surface plot - ! datablock is used instead of gnuplot inline file "-" - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x(:,:) - real(wp), intent(in), optional :: y(:,:) - real(wp), intent(in), optional :: z(:,:) - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: palette - - ! Local variables - !---------------------------------------------------------------------- - integer:: ncx - integer:: nrx - integer:: i - integer:: j - logical:: xyz_data - character(len=80):: pltstring - character(len=*), parameter :: datablock = '$xyz' - - pltstring='' - ! Check the input data - ncx=size(x,dim=2) - nrx=size(x,dim=1) - if (present(y) .and. present(z)) then - xyz_data=.true. - elseif (present(y)) then - print*, "gpf error: Z matrix was not sent to 3D plot routine" - return - else - xyz_data=.false. - end if - - ! set default line style for 3D plot, can be overwritten - this%txtdatastyle = 'lines' - ! create the script file for writting gnuplot commands and data - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write xy data into file - write ( this%file_unit, '(a)' ) '#data x y z' - ! Rev 0.20 - ! write the $xyz datablocks - write( this%file_unit, '(a)' ) datablock // ' << EOD' - if (xyz_data) then - do j=1,ncx - do i=1, nrx - write ( this%file_unit, * ) x(i,j), y(i,j), z(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - else !only Z has been sent (i.e. single matrix data) - do j=1,ncx - do i=1, nrx - write ( this%file_unit, * ) i, j, x(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - end if - - - !write the color palette into gnuplot script file - if (present(palette)) then - write ( this%file_unit, '(a)' ) color_palettes(palette) - write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec - end if - - - if ( present(lspec) ) then - if (hastitle(lspec)) then - pltstring='splot ' // datablock // ' ' // trim(lspec) - else - pltstring='splot ' // datablock // ' notitle '//trim(lspec) - end if - else - pltstring='splot ' // datablock // ' notitle ' - end if - - write ( this%file_unit, '(a)' ) trim(pltstring) - - - !> Rev 0.2: animation - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !: End of splot - end subroutine splot - - - subroutine cplot(this, x, y, z, lspec, palette) - !.............................................................................. - ! Rev 0.19 - ! cplot creates a contour plot based on the three dimensional data - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x(:,:) - real(wp), intent(in), optional :: y(:,:) - real(wp), intent(in), optional :: z(:,:) - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: palette - - ! Local variables - !---------------------------------------------------------------------- - - integer:: ncx - integer:: nrx - integer:: i - integer:: j - logical:: xyz_data - character(len=80):: pltstring - character(len=*), parameter :: datablock = '$xyz' - ! character(len=*), parameter :: cntr_table = '$xyz_contour' - - pltstring='' - ! Check the input data - ncx=size(x,dim=2) - nrx=size(x,dim=1) - if (present(y) .and. present(z)) then - xyz_data=.true. - elseif (present(y)) then - print*, "gpf error: Z matrix was not sent to 3D plot routine" - return - else - xyz_data=.false. - end if - - ! set default line style for 3D plot, can be overwritten - this%txtdatastyle = 'lines' - ! create the script file for writting gnuplot commands and data - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write xy data into file - write ( this%file_unit, '(a)' ) '#data x y z' - ! write the $xyz datablocks - write( this%file_unit, '(a)' ) datablock // ' << EOD' - if (xyz_data) then - do j=1,ncx - do i=1, nrx - write ( this%file_unit, fmt=* ) x(i,j), y(i,j), z(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - else !only Z has been sent (i.e. single matrix data) - do j=1,ncx - do i=1, nrx - write ( this%file_unit, fmt=* ) i, j, x(i,j) - enddo - write( this%file_unit, '(a)' ) !put an empty line - enddo - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - end if - - - ! create the contour lines - write ( this%file_unit, '(a)' ) ! empty line - write ( this%file_unit, '(a)' ) '# create the contour' - write ( this%file_unit, '(a)' ) 'set contour base' - write ( this%file_unit, '(a)' ) 'set cntrparam levels 14' - write ( this%file_unit, '(a)' ) 'unset surface' - write ( this%file_unit, '(a)' ) 'set view map' - - - !write the color palette into gnuplot script file - if (present(palette)) then - write ( this%file_unit, '(a)' ) color_palettes(palette) - write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec - end if - - - write ( this%file_unit, '(a)' ) ! empty line - - if ( present(lspec) ) then - if (hastitle(lspec)) then - pltstring='splot ' // datablock // ' ' // trim(lspec) - else - pltstring='splot ' // datablock // ' notitle '//trim(lspec) - end if - else - pltstring='splot ' // datablock // ' notitle ' - end if - - write ( this%file_unit, '(a)' ) trim(pltstring) - - !> Rev 0.20 - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !: End of cplot - end subroutine cplot - - subroutine lplot3d(this, x, y, z, lspec, palette) - !.............................................................................. - ! lplot3d create a line plot in 3d - ! datablock is used instead of gnuplot inline file "-" - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x(:) - real(wp), intent(in), optional :: y(:) - real(wp), intent(in), optional :: z(:) - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: palette - - ! Local variables - !---------------------------------------------------------------------- - integer:: ncx - integer:: nrx - integer:: i - integer:: j - logical:: xyz_data - character(len=80):: pltstring - character(len=*), parameter :: datablock = '$xyz' - - pltstring='' - ! Check the input data - nrx=size(x) - if (present(y) .and. present(z)) then - xyz_data=.true. - elseif (present(y)) then - print*, "gpf error: Z matrix was not sent to 3D plot routine" - return - else - xyz_data=.false. - end if - - ! set default line style for 3D plot, can be overwritten - this%txtdatastyle = 'lines' - ! create the script file for writing gnuplot commands and data - call create_outputfile(this) - - ! Write titles and other annotations - call processcmd(this) - - ! Write xy data into file - write ( this%file_unit, '(a)' ) '#data x y z' - ! Rev 0.20 - ! write the $xyz datablocks - write( this%file_unit, '(a)' ) datablock // ' << EOD' - if (xyz_data) then - do i=1, nrx - write ( this%file_unit, * ) x(i), y(i), z(i) - enddo - write( this%file_unit, '(a)' ) !put an empty line - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - else !only Z has been sent (i.e. single matrix data) - do i=1, nrx - write ( this%file_unit, * ) i, x(i) - enddo - write( this%file_unit, '(a)' ) !put an empty line - write ( this%file_unit, '(a)' ) 'EOD' !end of datablock - end if - - - !write the color palette into gnuplot script file - if (present(palette)) then - write ( this%file_unit, '(a)' ) color_palettes(palette) - write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec - end if - - - if ( present(lspec) ) then - if (hastitle(lspec)) then - pltstring='splot ' // datablock // ' ' // trim(lspec) // 'with lines' - else - pltstring='splot ' // datablock // ' notitle '//trim(lspec) // 'with lines' - end if - else - pltstring='splot ' // datablock // ' notitle with lines' - end if - - write ( this%file_unit, '(a)' ) trim(pltstring) - - - !> Rev 0.2: animation - ! if there is no animation finalize - if (.not. (this%hasanimation)) then - call finalize_plot(this) - else - write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds - end if - - !: End of lplot3d - end subroutine lplot3d - - subroutine function_plot(this, func,xrange,np) - !.............................................................................. - ! fplot, plot a function in the range xrange=[xmin, xamx] with np points - ! if np is not sent, then np=50 is assumed! - ! func is the name of function to be plotted - !.............................................................................. - - class(gpf):: this - interface - function func(x) - import :: wp - real(wp), intent(in) :: x - real(wp) :: func - end function func - end interface - real(wp), intent(in) :: xrange(2) - integer, optional, intent(in):: np - - integer:: n - integer:: i - integer:: alloc_err - real(wp), allocatable :: x(:) - real(wp), allocatable :: y(:) - - if (present(np)) then - n=np - else - n=50 - end if - allocate(x(1:n), y(1:n), stat=alloc_err) - if (alloc_err /=0) then - stop "Allocation error in fplot procedure..." - end if - !Create set of xy data - x=linspace(xrange(1),xrange(2), n) - y=[ (func(x(i)), i=1, n) ] - - call plot2d_vector_vs_vector(this,x,y) - - ! cleanup memory - if (allocated(x)) deallocate(x) - if (allocated(y)) deallocate(y) - - - end subroutine function_plot - - - subroutine semilogxv(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - !.............................................................................. - ! This procedure is the same as plotXY with logarithmic x1 and x2 axes - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - this%plotscale='semilogx' - call plot2d_vector_vs_vector(this, & - x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - end subroutine semilogxv - - - !.............................................................................. - subroutine semilogyv(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4,axes4 ) - !.............................................................................. - ! This procedure is the same as plotXY with logarithmic y1 and y2 axes - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - - this%plotscale='semilogy' - call plot2d_vector_vs_vector(this, & - x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine semilogyv - - - - subroutine loglogv(this, x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - !.............................................................................. - ! This procedure is the same as plotXY with logarithmic x1, y1, x2, y2 axes - !.............................................................................. - - class(gpf):: this - ! Input vector - real(wp), intent(in) :: x1(:) ! vector of data for x - real(wp), intent(in), optional :: y1(:) ! vector of data for y - character(len=*), intent(in), optional :: ls1 ! line specification - character(len=*), intent(in), optional :: axes1 - - real(wp), intent(in), dimension(:), optional :: x2 - real(wp), intent(in), dimension(:), optional :: y2 - character(len=*), intent(in), optional :: ls2 - character(len=*), intent(in), optional :: axes2 - - real(wp), intent(in), dimension(:), optional :: x3 - real(wp), intent(in), dimension(:), optional :: y3 - character(len=*), intent(in), optional :: ls3 - character(len=*), intent(in), optional :: axes3 - - real(wp), intent(in), dimension(:), optional :: x4 - real(wp), intent(in), dimension(:), optional :: y4 - character(len=*), intent(in), optional :: ls4 - character(len=*), intent(in), optional :: axes4 - - - this%plotscale='loglog' - call plot2d_vector_vs_vector(this, & - x1, y1, ls1, axes1, & - x2, y2, ls2, axes2, & - x3, y3, ls3, axes3, & - x4, y4, ls4, axes4 ) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - end subroutine loglogv - - - - subroutine semilogxm(this, xv, ymat, lspec) - !.............................................................................. - !Plots a matrix against a vector with logarithmic x-axis - !For more information see plot2D_matrix_vs_vector procedure - !Everything is the same except the x-axis scale - !.............................................................................. - - implicit none - class(gpf) :: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - - this%plotscale='semilogx' - call plot2d_matrix_vs_vector(this, xv,ymat, lspec) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine semilogxm - - - - subroutine semilogym(this, xv,ymat, lspec) - !.............................................................................. - !Plots a matrix against a vector with logarithmic y-axis - !For more information see plot2D_matrix_vs_vector procedure - !Everything is the same except the x-axis scale - !.............................................................................. - - implicit none - class(gpf) :: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - - this%plotscale='semilogy' - call plot2d_matrix_vs_vector(this, xv,ymat, lspec) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine semilogym - - - subroutine loglogm(this, xv,ymat, lspec) - !.............................................................................. - !Plots a matrix against a vector with logarithmic x-axis and y-axis - !For more information see plot2D_matrix_vs_vector procedure - !Everything is the same except the axes scale - !.............................................................................. - - implicit none - class(gpf) :: this - ! Input arrays - real(wp), intent(in) :: xv(:) - real(wp), intent(in) :: ymat(:,:) - character(len=*), intent(in), optional :: lspec - - this%plotscale='loglog' - call plot2d_matrix_vs_vector(this, xv,ymat, lspec) - ! Set the plot scale as linear. It means log scale is off - this%plotscale='linear' - - - end subroutine loglogm - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Three: Animation Routines - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine sub_animation_start(this, pause_seconds) - !------------------------------------------------------------------------------- - ! sub_animation_start: set the setting to start an animation - ! it simply set flags and open a script file to write data - !------------------------------------------------------------------------------- - class(gpf) :: this - integer, intent(in), optional :: pause_seconds - - - ! ogpf does not support multiplot with animation at the same time - if (this%hasmultiplot) then - print*, md_name // ': does not support animation in multiplot mode!' - stop - end if - - - if (present(pause_seconds)) then - this%pause_seconds = pause_seconds - else - this%pause_seconds = 2 ! delay in second - end if - - this%frame_number = 0 - - ! create the ouput file for writting gnuplot script - call create_outputfile(this) - this%hasfileopen = .true. - this%hasanimation = .true. - - end subroutine sub_animation_start - - - subroutine sub_animation_show(this) - !------------------------------------------------------------------------------- - ! sub_animation_show: simply resets the animation flags - ! and finalize the plotting. - !------------------------------------------------------------------------------- - - class(gpf) :: this - - this%frame_number = 0 - this%hasanimation = .false. - - call finalize_plot(this) - - end subroutine sub_animation_show - - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Four: Gnuplot direct scriptting - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - subroutine addscript(this,strcmd) - !.............................................................................. - ! addscript: accepts all type of gnuplot command as a string and store it - ! in global txtscript to be later sent to gnuplot - !.............................................................................. - - class(gpf) :: this - character(len=*), intent(in) :: strcmd - - if (.not.allocated(this%txtscript)) this%txtscript='' - if (len_trim(this%txtscript) == 0 ) then - this%txtscript = '' ! initialize string - end if - if ( len_trim(strcmd)>0 ) then - this%txtscript = this%txtscript // splitstr(strcmd) - end if - - end subroutine addscript - - - - subroutine runscript(this) - !.............................................................................. - ! runscript sends the the script string (txtstring) into a script - ! file to be run by gnuplot - !.............................................................................. - - class(gpf):: this - - !REV 0.18: a dedicated subroutine is used to create the output file - call create_outputfile(this) - - !write the script - call processcmd(this) - write(unit=this%file_unit, fmt='(a)') this%txtscript - - ! close the file and call gnuplot - call finalize_plot(this) - - end subroutine runscript - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Five: gnuplot command processing and data writing to script file - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - subroutine process_axes_set(axes_set, axes) - !.............................................................................. - ! process_axesspec accepts the axes set and interpret it into - ! a format to be sent to gnuplot. - ! the axes set can be one of the following set - ! x1y1, x1y2, x2y1, x2y2 - !.............................................................................. - - character(len=*), intent(in) :: axes_set - character(len=4), intent(out) :: axes - - - if (len_trim (adjustl(axes_set)) == 0) then - axes='' - return - end if - - select case ( lcase(trim (adjustl (axes_set) ) ) ) - case ('x1y1') - axes='x1y1' - case ('x1y2') - axes='x1y2' - case ('x2y1') - axes='x2y1' - case ('x2y2') - axes='x2y2' - case default ! wrong strings - print*, md_name // ':process_axes_set:' // ' wrong axes set is sent.'// new_line(' ') & - // 'axes set can be on of: x1y1, x1y2, x2y1, x2y2' - axes='' - return - end select - - end subroutine process_axes_set - - - - subroutine process_linespec(order, lsstring, lspec, axes_set) - !.............................................................................. - ! process_linespec accepts the line specification and interpret it into - ! a format to be sent to gnuplot - !.............................................................................. - - integer, intent(in) :: order !1 for the first data series - character(len=*), intent(out) :: lsstring - character(len=*), intent(in), optional :: lspec - character(len=*), intent(in), optional :: axes_set - - !local variables - character(len=4) :: axes - character(len=10) :: axes_setting - - !check the axes set - axes_setting = '' - if ( present (axes_set)) then - call process_axes_set(axes_set, axes) - if (len(trim(axes))> 0 ) then - axes_setting = ' axes ' // axes - end if - end if - - select case(order) - case(1) - if ( present(lspec) ) then - if (hastitle(lspec)) then - lsstring='plot "-" '//trim(lspec) // axes_setting - else - lsstring='plot "-" notitle '//trim(lspec) // axes_setting - end if - else - lsstring='plot "-" notitle' // axes_setting - end if - case default !e.g. 2, 3, 4, ... - if (present(lspec)) then - if (hastitle(lspec)) then - lsstring=', "-" '// trim(lspec) // axes_setting - else - lsstring=', "-" notitle '// trim(lspec) // axes_setting - end if - else - lsstring=', "-" notitle' // axes_setting - end if - end select - end subroutine process_linespec - - - - subroutine processcmd(this) - !.............................................................................. - ! This subroutine writes all the data into plot file - ! to be read by gnuplot - !.............................................................................. - - class(gpf) :: this - - ! write the plot style for data - ! this is used only when 3D plots (splot, cplot) is used - if (allocated(this%txtdatastyle)) then - write ( this%file_unit, '("set style data ", a)' ) this%txtdatastyle - write ( this%file_unit, '(a)' ) - end if - - - ! Write options - if ( this%hasoptions ) then - write ( this%file_unit, '(" ")' ) - write ( this%file_unit, '("# options")' ) - write ( this%file_unit, '(a)' ) this%txtoptions - write ( this%file_unit, '(a)' ) - end if - - ! Check with plot scale: i.e linear, logx, logy, or log xy - write( this%file_unit, '(" ")' ) - write( this%file_unit, '("# plot scale")' ) - select case (this%plotscale) - case ('semilogx') - write ( this%file_unit, '("set logscale x")' ) - case ('semilogy') - write ( this%file_unit, '("set logscale y")' ) - case ('loglog') - write ( this%file_unit, '("set logscale xy")' ) - case default !for no setting - !pass - end select - - !!>0.22 - ! write annotation - write ( this%file_unit, '(" ")' ) - write ( this%file_unit, '("# Annotation: title and labels")' ) - call write_label(this, 'plot_title') - call write_label(this, 'xlabel' ) - call write_label(this, 'x2label' ) - call write_label(this, 'ylabel' ) - call write_label(this, 'y2label' ) - call write_label(this, 'zlabel' ) - - ! axes range - write ( this%file_unit, '(" ")') - write ( this%file_unit, '("# axes setting")') - if (this%hasxrange) then - write ( this%file_unit, '("set xrange [",G0,":",G0,"]")' ) this%xrange - end if - if (this%hasyrange) then - write ( this%file_unit, '("set yrange [",G0,":",G0,"]")' ) this%yrange - end if - if (this%haszrange) then - write ( this%file_unit, '("set zrange [",G0,":",G0,"]")' ) this%zrange - end if - - ! secondary axes range - if (this%hasx2range) then - write ( this%file_unit, '("set x2range [",G0,":",G0,"]")' ) this%x2range - end if - if (this%hasy2range) then - write ( this%file_unit, '("set y2range [",G0,":",G0,"]")' ) this%y2range - end if - ! finish by new line - write ( this%file_unit, '(a)' ) ! emptyline - - end subroutine processcmd - - - - subroutine write_label(this, lblname) - !.............................................................................. - ! This subroutine writes the labels into plot file - ! to be read by gnuplot - !.............................................................................. - - - ! write_label - class(gpf) :: this - character(len=*) :: lblname - - ! local var - character(len=:), allocatable :: lblstring - character(len=:), allocatable :: lblset - type(tplabel) :: label - - select case (lblname) - case ('xlabel') - if (.not. (this%tpxlabel%has_label) ) then - return ! there is no label - end if - lblset = 'set xlabel "' - label = this%tpxlabel - case ('x2label') - if (.not. (this%tpx2label%has_label) ) then - return ! there is no label - end if - lblset = 'set x2label "' - label = this%tpx2label - case ('ylabel') - if (.not. (this%tpylabel%has_label) ) then - return ! there is no label - end if - lblset = 'set ylabel "' - label = this%tpylabel - case ('y2label') - if (.not. (this%tpy2label%has_label) ) then - return ! there is no label - end if - lblset = 'set y2label "' - label = this%tpy2label - case ('zlabel') - if (.not. (this%tpzlabel%has_label) ) then - return ! there is no label - end if - lblset = 'set zlabel "' - label = this%tpzlabel - case ('plot_title') - if (.not. (this%tpplottitle%has_label) ) then - return ! there is no label - end if - lblset = 'set title "' - label = this%tpplottitle - end select - - lblstring = '' - ! if there is a label continue to set it - lblstring = lblstring // lblset // trim(label%lbltext)//'"' - if (allocated(label%lblcolor)) then - lblstring = lblstring // ' tc "' //trim(label%lblcolor) // '"' - end if - ! set font and size - if (allocated(this%tpxlabel%lblfontname)) then - lblstring = lblstring // ' font "'// trim(label%lblfontname) // ',' - if (label%lblfontsize /= NOT_INITIALIZED) then - lblstring = lblstring // num2str(label%lblfontsize) //'"' - else - lblstring = lblstring //'"' - end if - else ! check if only font size has been given - if (label%lblfontsize /= NOT_INITIALIZED ) then - lblstring = lblstring // ' font ",' // num2str(label%lblfontsize) //'"' - end if - end if - ! set rotation - if (label%lblrotate /= NOT_INITIALIZED ) then - lblstring = lblstring // ' rotate by ' // num2str(label%lblrotate ) - end if - - - ! write to ogpf script file - write ( this%file_unit, '(a)' ) lblstring - - - end subroutine write_label - - - - function color_palettes(palette_name) result(str) - !............................................................................... - ! color_palettes create color palette as a - ! string to be written into gnuplot script file - ! the palettes credit goes to: Anna Schnider (https://github.com/aschn) and - ! Hagen Wierstorf (https://github.com/hagenw) - !............................................................................... - character(len=*), intent(in) :: palette_name - character(len=:), allocatable :: str - - ! local variables - character(len=1) :: strnumber - character(len=11) :: strblank - integer :: j - integer :: maxcolors - - ! define the color palettes - character(len=:), allocatable :: pltname - character(len=7) :: palette(9) ! palettes with maximum 9 colors - - maxcolors = 8 ! default number of discrete colors - palette='' - select case ( lcase(trim(adjustl(palette_name))) ) - case ('set1') - pltname='set1' - palette(1:maxcolors)=[& - "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", & - "#FF7F00", "#FFFF33", "#A65628", "#F781BF" ] - case ('set2') - pltname='set2' - palette(1:maxcolors)=[& - "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", & - "#A6D854", "#FFD92F", "#E5C494", "#B3B3B3" ] - case ('set3') - pltname='set3' - palette(1:maxcolors)=[& - "#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072", & - "#80B1D3", "#FDB462", "#B3DE69", "#FCCDE5" ] - case ('palette1') - pltname='palette1' - palette(1:maxcolors)=[& - "#FBB4AE", "#B3CDE3", "#CCEBC5", "#DECBE4", & - "#FED9A6", "#FFFFCC", "#E5D8BD", "#FDDAEC" ] - case ('palette2') - pltname='palette2' - palette(1:maxcolors)=[& - "#B3E2CD", "#FDCDAC", "#CDB5E8", "#F4CAE4", & - "#D6F5C9", "#FFF2AE", "#F1E2CC", "#CCCCCC" ] - case ('paired') - pltname='paired' - palette(1:maxcolors)=[& - "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", & - "#FB9A99", "#E31A1C", "#FDBF6F", "#FF7F00" ] - case ('dark2') - pltname='dark2' - palette(1:maxcolors)=[& - "#1B9E77", "#D95F02", "#7570B3", "#E7298A", & - "#66A61E", "#E6AB02", "#A6761D", "#666666" ] - case ('accent') - pltname='accent' - palette(1:maxcolors)=[& - "#7FC97F", "#BEAED4", "#FDC086", "#FFFF99", & - "#386CB0", "#F0027F", "#BF5B17", "#666666" ] - case ('jet') - ! Matlab jet palette - maxcolors = 9 - pltname='jet' - palette(1:maxcolors)=[& - '#000090', '#000fff', '#0090ff', '#0fffee', & - '#90ff70', '#ffee00', '#ff7000', '#ee0000', '#7f0000' ] - case default - print*, md_name // ": color_palettes: wrong palette name" - print*, 'gnuplot default palette will be used!' - str=' ' ! empty palette is returned! - return - end select - - ! generate the gnuplot palette as a single multiline string - str = '# Define the ' // pltname // ' pallete' // new_line(' ') - str = str // 'set palette defined ( \' // new_line(' ') - strblank = ' ' ! pad certain number of paces - do j=1, maxcolors - 1 - write(unit =strnumber, fmt='(I1)' ) j-1 - str = str // strblank // strnumber // ' "' // palette(j) // '",\' // new_line(' ') - end do - - j =maxcolors - write(strnumber, fmt='(I1)') j - str = str // strblank // strnumber // ' "' // palette(j) // '" )' // new_line(' ') - - end function color_palettes - - - - subroutine write_xydata(file_unit,ndata,x,y) - !.............................................................................. - ! Writes set of xy data into a file - !.............................................................................. - - integer, intent(in) :: file_unit - integer, intent(in) :: ndata - real(wp), intent(in) :: x(:) - real(wp), intent(in), optional :: y(:) - - integer:: i - - ! TODO (Mohammad#1#12/22/17): The format string shall be modified to write the - ! number in more suitable form - ! Rev 0.18 - if (present(y) ) then !both x and y are present, data are xy set - do i = 1, ndata - write ( file_unit, * ) x(i), y(i) - end do - else !only x is passed, data are index-x set - do i = 1, ndata - write ( file_unit, * ) x(i) - end do - end if - write ( file_unit, '(a)' ) 'e' !end of set of data - - end subroutine write_xydata - - - - subroutine create_outputfile(this) - !.............................................................................. - ! Create an output file, assign a file_unit - ! for writing the gnuplot commands - !.............................................................................. - - ! Rev 0.18 - class(gpf), intent(INOUT ) :: this - - if (this%hasfileopen) then - ! there is nothing to do, file has been already open! - return - end if - - !> Rev 0.2 animation - - ! animation handling - if (this%hasanimation ) then - this%frame_number = this%frame_number + 1 ! for future use - end if - - ! Open the output file - - if (.not. (this%hasfilename)) then ! check if no file has been set by user - this%txtfilename=gnuplot_output_filename - end if - - open ( newunit = this%file_unit, file = this%txtfilename, status = 'replace', iostat = this%status ) - - - if (this%status /= 0 ) then - print*, "md_helperproc, create_outputfile: cannot open file for output" - stop - end if - - - ! Set the gnuplot terminal, write ogpf configuration (customized setting) - ! Can be overwritten by options - - ! write signature - write ( this%file_unit, '(a)' ) '# ' // md_name - write ( this%file_unit, '(a)' ) '# ' // md_rev - write ( this%file_unit, '(a)' ) '# ' // md_lic - write ( this%file_unit, '(a)' ) ! emptyline - - ! write the global settings - write ( this%file_unit, '(a)' ) '# gnuplot global setting' - write(unit=this%file_unit, fmt='(a)') 'set term ' // gnuplot_term_type // & - ' size ' // gnuplot_term_size // ' enhanced font "' // & - gnuplot_term_font // '"' // & - ' title "' // md_name // ': ' // md_rev //'"' ! library name and version - - ! write the preset configuration for gnuplot (ogpf customized settings) - if (this%preset_configuration) then - call this%preset_gnuplot_config() - end if - ! write multiplot setting - if (this%hasmultiplot) then - write(this%file_unit, fmt='(a, I2, a, I2)') 'set multiplot layout ', & - this%multiplot_rows, ',', this%multiplot_cols - end if - ! set flag true for file is opened - this%hasfileopen = .true. - - end subroutine create_outputfile - - - subroutine preset_gnuplot_config(this) - !.............................................................................. - ! To write the preset configuration for gnuplot (ogpf customized settings) - !.............................................................................. - class(gpf) :: this - - write(this%file_unit, fmt='(a)') - write(this%file_unit, fmt='(a)') '# ogpf extra configuration' - write(this%file_unit, fmt='(a)') '# -------------------------------------------' - - - ! color definition - write(this%file_unit, fmt='(a)') '# color definitions' - write(this%file_unit, fmt='(a)') 'set style line 1 lc rgb "#800000" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 2 lc rgb "#ff0000" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 3 lc rgb "#ff4500" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 4 lc rgb "#ffa500" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 5 lc rgb "#006400" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 6 lc rgb "#0000ff" lt 1 lw 2' - write(this%file_unit, fmt='(a)') 'set style line 7 lc rgb "#9400d3" lt 1 lw 2' - write(this%file_unit, fmt='(a)') - ! axes setting - write(this%file_unit, fmt='(a)') '# Axes' - write(this%file_unit, fmt='(a)') 'set border linewidth 1.15' - write(this%file_unit, fmt='(a)') 'set tics nomirror' - write(this%file_unit, fmt='(a)') - - write(this%file_unit, fmt='(a)') '# grid' - write(this%file_unit, fmt='(a)') '# Add light grid to plot' - write(this%file_unit, fmt='(a)') 'set style line 102 lc rgb "#d6d7d9" lt 0 lw 1' - write(this%file_unit, fmt='(a)') 'set grid back ls 102' - write(this%file_unit, fmt='(a)') - ! set the plot style - write(this%file_unit, fmt='(a)') '# plot style' - write(this%file_unit, fmt='(a)') 'set style data linespoints' - write(this%file_unit, fmt='(a)') - - write(this%file_unit, fmt='(a)') '# -------------------------------------------' - write(this%file_unit, fmt='(a)') '' - - - end subroutine preset_gnuplot_config - - - - subroutine finalize_plot(this) - !.............................................................................. - ! To finalize the writing of gnuplot commands/data and close the output file. - !.............................................................................. - class(gpf) :: this - - ! check for multiplots - if (this%hasmultiplot) then - if (this%multiplot_total_plots < this%multiplot_rows * this%multiplot_cols - 1 ) then - ! increment the number of plots - this%multiplot_total_plots = this%multiplot_total_plots + 1 - return ! do not finalize plot, still there is places in multiplot - else - ! close multiplot - write(this%file_unit, fmt='(a)') 'unset multiplot' - ! reset multiplot flag - this%hasmultiplot = .false. - - end if - end if - - close ( unit = this%file_unit ) ! close the script file - this%hasfileopen = .false. ! reset file open flag - this%hasanimation = .false. - ! Use shell command to run gnuplot - if (get_os_type() == 1) then - call execute_command_line ('wgnuplot -persist ' // this%txtfilename) ! Now plot the results - else - call execute_command_line ('gnuplot -persist ' // this%txtfilename) ! Now plot the results - end if - contains - integer function get_os_type() result(r) - !! Returns one of OS_WINDOWS, others - !! At first, the environment variable `OS` is checked, which is usually - !! found on Windows. - !! Copy from fpm/fpm_environment: https://github.com/fortran-lang/fpm/blob/master/src/fpm_environment.F90 - character(len=32) :: val - integer :: length, rc - - integer, parameter :: OS_OTHERS = 0 - integer, parameter :: OS_WINDOWS = 1 - - r = OS_OTHERS - ! Check environment variable `OS`. - call get_environment_variable('OS', val, length, rc) - - if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then - r = OS_WINDOWS - return - end if - - end function - - end subroutine finalize_plot - - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Six: Utility and helper procedures - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - function hastitle(string) - !.............................................................................. - ! check to see if the plot title (used as legend = key) - !.............................................................................. - - character(len=*), intent(in) :: string - logical:: hastitle - integer:: idx1 - integer:: idx2 - - idx1=index( lcase(string),'title') !Check if title is passed - idx2=index(' ' // lcase(string),' t ') !Check if the abbreviated title 't' is passed. Extra space is added - ! at the beginning of string to find starting 't' - if (idx1 /=0 .or. idx2 /=0 ) then - hastitle=.true. - else - hastitle=.false. - end if - - end function hastitle - - - function checkdim(nx,ny) - !.............................................................................. - ! checkdim checks the equality of dimensions of two vector - !.............................................................................. - - integer, intent(in):: nx - integer, intent(in):: ny - logical:: checkdim - if (nx/=ny) then - checkdim=.false. - else - checkdim=.true. - end if - - end function checkdim - - - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !> Section Seven: String utility Routines - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - - pure function splitstr(str) result(spstr) - !.............................................................................. - !splitstr, separate a string using ";" delimiters - !.............................................................................. - - character(len=*), intent(in) :: str - - ! local variables - character, parameter :: delimiter=';' - character(len=:), allocatable :: spstr - integer :: n - integer :: m - integer :: k - - - k=len_trim(str) !length with removed trailing blanks - n=scan(str,delimiter) - if (n==0) then ! This is a single statement - spstr = adjustl(str) // new_line(' ') - return - end if - - ! for two or more statements separated by ; - spstr = '' - m=1 - do while (n/=0 .and. m=65 .and. n <= 90) then - lcase(i:i)=char(n+32) - else - lcase(i:i)=chr - end if - end do - end function lcase - - - function num2str_i4(number_in) - !.............................................................................. - ! num2str_int: converts integer number to string - !.............................................................................. - - integer(kind=kind(1)), intent(in) :: number_in - character(len=:), allocatable :: num2str_i4 - - ! local variable - character(len=range(number_in)) :: strnm - write(unit=strnm, fmt='(I0)') number_in - num2str_i4 = trim(strnm) - - end function num2str_i4 - - function num2str_r4(number_in, strfmt) - !.............................................................................. - ! num2str_r4: converts single precision real number to string - ! strfmt is the optional format string - !.............................................................................. - - real(kind=sp), intent(in) :: number_in - character(len=*), intent(in), optional :: strfmt - character(len=:), allocatable :: num2str_r4 - - ! local variable - character(len=range(number_in)) :: strnm - - - if (present(strfmt)) then - write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in - else - write(unit=strnm, fmt='(G0)') number_in - end if - - num2str_r4 = trim(strnm) - - end function num2str_r4 - - - function num2str_r8(number_in, strfmt) - !.............................................................................. - ! num2str_real: converts double precision real number to string - ! strfmt is the optional format string - !.............................................................................. - - real(kind=dp), intent(in) :: number_in - character(len=*), intent(in), optional :: strfmt - character(len=:), allocatable :: num2str_r8 - - ! local variable - character(len=range(number_in)) :: strnm - - if (present(strfmt)) then - write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in - else - write(unit=strnm, fmt='(G0)') number_in - end if - - num2str_r8 = trim(strnm) - - end function num2str_r8 - - - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !!> Section Eight: Math helper function - !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - function arange(xa, xb, dx) - !.............................................................................. - ! returns a vector in the form of [xa, xa+dx, xa+2*dx, ...] - ! the number of elements is calculated as m = n+ 1, - ! where n= int ( (xa-xb)/dx) ). - ! arange is similar to colon in Matlab and arange in Python! - ! - ! NOTE: - ! - If n calculated as zero, result is [xa] - ! - If n calculated as Inf (dx=0), a fatal error will be raised - ! - If n calculated as negative value (e.g xa 0.0 " - stop - end if - else - dxl = 1.0_wp - end if - - if ( (xa < xb) .and. (dx < 0.0_wp) ) then - print*, "arange procedure: Fatal Error: wrong dx, use a dx > 0.0 " - stop - end if - - n = int( (xb-xa)/ dxl) ! n+1 is the number of elements - - allocate(arange(n), stat=ierr) - - if (ierr /= 0) then - print*, "arange procedure: Fatal Error, allocation failed in arange function" - stop - end if - - arange = [(xa + i*dxl, i=0, n)] - - end function arange - - - function linspace(a,b,n_elements) - !.............................................................................. - ! returns a linearly spaced vector with n points in [a, b] - ! if n is omitted, 100 points will be considered - !.............................................................................. - - real(wp), intent(in) :: a - real(wp), intent(in) :: b - integer, intent(in), optional :: n_elements - real(wp), allocatable :: linspace(:) - - ! Local vars - real(wp) :: dx - integer :: i - integer :: n - integer :: ierr - - if (present(n_elements)) then - if (n_elements <=1 ) then - print*, "linspace procedure: Error: wrong value of n_elements, use an n_elements > 1" - stop - end if - n=n_elements - else - n=100 - end if - - allocate(linspace(n), stat=ierr) - if (ierr /= 0) then - print*, "linspace procedure: Fatal Error, Allocation failed in linspace function" - stop - end if - - dx=(b-a)/real((n-1),wp) - linspace=[(i*dx+a, i=0,n-1)] - - end function linspace - - - - subroutine meshgrid(x,y,xgv,ygv, ierr) - !.............................................................................. - !meshgrid generate mesh grid over a rectangular domain of [xmin xmax, ymin, ymax] - ! Inputs: - ! xgv, ygv are grid vectors in form of full grid data - ! Outputs: - ! X and Y are matrix each of size [ny by nx] contains the grid data. - ! The coordinates of point (i,j) is [X(i,j), Y(i,j)] - ! ierr: The error flag - ! """ - ! # Example - ! # call meshgrid(X, Y, [0.,1.,2.,3.],[5.,6.,7.,8.]) - ! # X - ! # [0.0, 1.0, 2.0, 3.0, - ! # 0.0, 1.0, 2.0, 3.0, - ! # 0.0, 1.0, 2.0, 3.0, - ! # 0.0, 1.0, 2.0, 3.0] - ! # - ! #Y - ! #[ 5.0, 5.0, 5.0, 5.0, - ! # 6.0, 6.0, 6.0, 6.0, - ! # 7.0, 7.0, 7.0, 7.0, - ! # 8.0, 8.0, 8.0, 8.0] - !.............................................................................. - ! Rev 0.2, Feb 2018 - ! New feature added: xgv and ygv as full grid vector are accepted now - - ! Arguments - real(wp), intent(out), allocatable :: x(:,:) - real(wp), intent(out), allocatable :: y(:,:) - real(wp), intent(in) :: xgv(:) ! x grid vector [start, stop, step] or [start, stop] - real(wp), intent(in), optional :: ygv(:) ! y grid vector [start, stop, step] or [start, stop] - integer, intent(out), optional :: ierr ! the error value - - ! Local variables - integer:: sv - integer:: nx - integer:: ny - logical:: only_xgv_available - - ! Initial setting - only_xgv_available = .false. - sv=0 !Assume no error - - nx=size(xgv, dim=1) - - if (present(ygv)) then - ny = size(ygv, dim=1) - else - only_xgv_available=.true. - ny=nx - end if - - allocate(x(ny,nx),y(ny,nx),stat=sv) - if (sv /=0) then - print*, "allocataion erro in meshgrid" - stop - end if - - x(1,:) = xgv - x(2:ny,:) = spread(xgv, dim=1, ncopies=ny-1) - - if (only_xgv_available) then - y=transpose(x) - else - y(:,1) = ygv - y(:,2:nx) = spread(ygv,dim=2,ncopies=nx-1) - end if - - if (present(ierr)) then - ierr=sv - end if - - end subroutine meshgrid - - - !End of ogpf -end module ogpf From 1f7c9955d9dc4bed0d45118a6e4d4d0735877e2d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 3 Dec 2024 12:17:51 +0900 Subject: [PATCH 337/359] Minor updates in BaseInterpolation methods --- .../BaseInterpolation/src/BaseInterpolation_Method.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 index a97d6691e..52ba9a828 100644 --- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 +++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 @@ -303,10 +303,10 @@ FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) CASE DEFAULT ans = -1_I4B - CALL Errormsg(msg="No case found for baseInterpolation ="//name, & - routine="BaseInterpolation_ToInteger2()", & - file=__FILE__, line=__LINE__, unitno=stderr) - STOP + ! CALL Errormsg(msg="No case found for baseInterpolation ="//name, & + ! routine="BaseInterpolation_ToInteger2()", & + ! file=__FILE__, line=__LINE__, unitno=stderr) + ! STOP END SELECT astr = "" From ba7096dd8ce9a9cb8ecbaaf5d8820c7b190f593c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 3 Dec 2024 12:18:38 +0900 Subject: [PATCH 338/359] Updates in base interpolation methods --- src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 index 52ba9a828..0b77c81b1 100644 --- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 +++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 @@ -313,7 +313,7 @@ FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) END FUNCTION BaseInterpolation_ToInteger2 !---------------------------------------------------------------------------- -! BaseInterpolation_fromInteger +! BaseInterpolation_fromInteger !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. From c036f33b3114d97cf7bd528e6c81bd45647a0bb1 Mon Sep 17 00:00:00 2001 From: easifem Date: Wed, 15 Jan 2025 17:42:22 +0900 Subject: [PATCH 339/359] version update in cmake --- CMakeLists.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d5bd3362b..f6a2809f7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -24,8 +24,8 @@ project(${PROJECT_NAME}) enable_language(C Fortran CXX) set(VERSION_MAJOR "24") -set(VERSION_MINOR "4") -set(VERSION_BugFix "5") +set(VERSION_MINOR "10") +set(VERSION_BugFix "3") set(PROJECT_VERSION ${VERSION_MAJOR}.${VERSION_MINOR}.${VERSION_BugFix}) From cc54b8246fb83411e43a626256d4d954daf3b84f Mon Sep 17 00:00:00 2001 From: shion Date: Sun, 2 Mar 2025 20:14:04 +0900 Subject: [PATCH 340/359] Updates in Polynomial - minor bug fixed for quadrangle --- .../Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 4400aa610..32243f79b 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -89,7 +89,7 @@ nrow = LagrangeDOF_Quadrangle(p=p, q=q) ncol = 2 -p1 = p1 + 1 +p1 = p + 1 DO CONCURRENT(jj=0:q, ii=0:p) ans(p1 * jj + ii + 1, 1) = ii From fe99fbb7127dd231806c683c82a81671d156b7df Mon Sep 17 00:00:00 2001 From: shion Shimizu Date: Mon, 3 Mar 2025 22:24:40 +0900 Subject: [PATCH 341/359] Updates ConvertUtility - adding new method without allocation --- src/modules/Utility/src/ConvertUtility.F90 | 33 +++++++++++ .../Utility/src/ConvertUtility@Methods.F90 | 57 +++++++++++++++++++ 2 files changed, 90 insertions(+) diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90 index 9deec4303..2037e78d7 100644 --- a/src/modules/Utility/src/ConvertUtility.F90 +++ b/src/modules/Utility/src/ConvertUtility.F90 @@ -21,6 +21,7 @@ MODULE ConvertUtility PRIVATE PUBLIC :: Convert +PUBLIC :: Convert_ PUBLIC :: ConvertSafe !---------------------------------------------------------------------------- @@ -126,6 +127,22 @@ MODULE PURE SUBROUTINE convert_2(From, To) END SUBROUTINE convert_2 END INTERFACE Convert +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: convert without allocation + +INTERFACE Convert_ + MODULE PURE SUBROUTINE convert2_(From, To, nrow, ncol) + REAL(DFP), INTENT(IN) :: From(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: To(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE convert2_ +END INTERFACE Convert_ + !---------------------------------------------------------------------------- ! Convert@ConvertMethods !---------------------------------------------------------------------------- @@ -148,4 +165,20 @@ END SUBROUTINE convert_3 ! !---------------------------------------------------------------------------- +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: convert without allocation + +INTERFACE Convert_ + MODULE PURE SUBROUTINE convert3_(From, To, dim1, dim2, dim3, dim4) + REAL(DFP), INTENT(IN) :: From(:, :, :, :, :, :) + REAL(DFP), INTENT(INOUT) :: To(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE convert3_ +END INTERFACE Convert_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE ConvertUtility diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90 index 658b358e7..20e817b35 100644 --- a/src/submodules/Utility/src/ConvertUtility@Methods.F90 +++ b/src/submodules/Utility/src/ConvertUtility@Methods.F90 @@ -96,6 +96,35 @@ END DO END PROCEDURE convert_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE convert2_ +INTEGER(I4B) :: a, b, r1, r2, c1, c2 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 + +dim1 = SIZE(From, 1) +dim2 = SIZE(From, 2) +dim3 = SIZE(From, 3) +dim4 = SIZE(From, 4) +nrow = dim1 * dim3 +ncol = dim2 * dim4 +c1 = 0; c2 = 0 + +DO b = 1, dim4 + c1 = c2 + 1 + c2 = b * dim2 + r1 = 0; r2 = 0 + DO a = 1, dim3 + r1 = r2 + 1; + r2 = a * dim1 + To(r1:r2, c1:c2) = From(1:dim1, 1:dim2, a, b) + END DO +END DO + +END PROCEDURE convert2_ + !---------------------------------------------------------------------------- ! Convert !---------------------------------------------------------------------------- @@ -120,4 +149,32 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE convert3_ +INTEGER(I4B) :: a, b +INTEGER(I4B) :: n1, n2, n3, n4, n5, n6 + +n1 = SIZE(from, 1) +n2 = SIZE(from, 2) +n3 = SIZE(from, 3) +n4 = SIZE(from, 4) +n5 = SIZE(from, 5) +n6 = SIZE(from, 6) + +dim3 = n5 +dim4 = n6 + +DO b = 1, n6 + DO a = 1, n5 + CALL Convert_(from=from(1:n1, 1:n2, 1:n3, 1:n4, a, b), & + to=to(1:n1 * n3, 1:n2 * n4, a, b), & + nrow=dim1, ncol=dim2) + END DO +END DO + +END PROCEDURE convert3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE Methods From 2937b00b1bc17b0374e458ad50a4e58f89a54b4d Mon Sep 17 00:00:00 2001 From: shion Shimizu Date: Mon, 3 Mar 2025 23:57:45 +0900 Subject: [PATCH 342/359] Updates Interpolation method - adding no allocation subroutine (wip) - finish up to vector interpolation --- .../src/ElemshapeData_InterpolMethods.F90 | 246 +++++++++++++----- .../ElemshapeData_InterpolMethods@Methods.F90 | 242 +++++++++++++++++ 2 files changed, 430 insertions(+), 58 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index 1074afee6..577769bc4 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -17,13 +17,14 @@ ! ! This file contains the interpolation methods interfaces\ -module ElemshapeData_InterpolMethods +MODULE ElemshapeData_InterpolMethods USE BaseType USE GlobalData IMPLICIT NONE PRIVATE -PUBLIC :: getInterpolation +PUBLIC :: GetInterpolation +PUBLIC :: GetInterpolation_ PUBLIC :: Interpolation PUBLIC :: STInterpolation @@ -44,7 +45,7 @@ module ElemshapeData_InterpolMethods ! ! - TODO Make it work when the size of val is not the same as NNS -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) @@ -52,11 +53,24 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:) !! spatial nodal values of scalar END SUBROUTINE scalar_getInterpolation_1 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_1 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE scalar_getInterpolation1_(obj, interpol, val, tsize) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE scalar_getInterpolation1_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -76,7 +90,7 @@ END SUBROUTINE scalar_getInterpolation_1 ! The resultant represents the interpolation value of `val` at ! spatial-quadrature points -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:) @@ -84,11 +98,20 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:, :) !! space-time nodal values of scalar END SUBROUTINE scalar_getInterpolation_2 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_2 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE scalar_getInterpolation2_(obj, interpol, val, tsize) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE scalar_getInterpolation2_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -108,7 +131,7 @@ END SUBROUTINE scalar_getInterpolation_2 ! The resultant represents the interpolation value of `val` at ! spatial-temporal quadrature points -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) @@ -116,11 +139,25 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:, :) !! space-time nodal values of scalar END SUBROUTINE scalar_getInterpolation_3 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_3 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE scalar_getInterpolation3_(obj, interpol, val, & + nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE scalar_getInterpolation3_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -144,7 +181,7 @@ END SUBROUTINE scalar_getInterpolation_3 !This routine calls [[Interpolation]] function from the same module. !@endnote -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE scalar_getInterpolation_4(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) @@ -152,11 +189,24 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_4(obj, interpol, val) TYPE(FEVariable_), INTENT(IN) :: val !! Scalar FE variable END SUBROUTINE scalar_getInterpolation_4 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE 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 @@ -181,7 +231,7 @@ END SUBROUTINE scalar_getInterpolation_4 ! The resultant represents the interpolation value of `val` at ! spatial-quadrature points -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) @@ -189,11 +239,25 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val) TYPE(FEVariable_), INTENT(IN) :: val !! scalar FE variable END SUBROUTINE scalar_getInterpolation_5 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE scalar_getInterpolation_5 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE scalar_getInterpolation5_(obj, interpol, val, & + nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE scalar_getInterpolation5_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -210,7 +274,7 @@ END SUBROUTINE scalar_getInterpolation_5 ! ! $$u_{i}=u_{iI}N^{I}$$ -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) @@ -218,11 +282,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:, :) !! nodal values of vector in `xiJ` format END SUBROUTINE vector_getInterpolation_1 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_1 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation1_(obj, interpol, val, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE vector_getInterpolation1_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -239,7 +317,7 @@ END SUBROUTINE vector_getInterpolation_1 ! ! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) @@ -247,11 +325,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:, :, :) !! space-time nodal values of vector in `xiJa` format END SUBROUTINE vector_getInterpolation_2 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_2 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, interpol, val, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE vector_getInterpolation2_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -268,7 +360,7 @@ END SUBROUTINE vector_getInterpolation_2 ! ! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) @@ -276,11 +368,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:, :, :) !! space-time nodal values of vector in `xiJa` format END SUBROUTINE vector_getInterpolation_3 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_3 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation3_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE vector_getInterpolation3_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -302,7 +408,7 @@ END SUBROUTINE vector_getInterpolation_3 ! ! NOTE This routine calls [[Interpolation]] function from the same module. ! -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) @@ -310,11 +416,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val) TYPE(FEVariable_), INTENT(IN) :: val !! vector FEvariable END SUBROUTINE vector_getInterpolation_4 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_4 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation4_(obj, interpol, val, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE vector_getInterpolation4_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -336,7 +456,7 @@ END SUBROUTINE vector_getInterpolation_4 ! ! NOTE This routine calls [[Interpolation]] function from the same module. ! -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, interpol, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) @@ -344,11 +464,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, interpol, val) TYPE(FEVariable_), INTENT(IN) :: val !! vector FEvariable END SUBROUTINE vector_getInterpolation_5 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE vector_getInterpolation_5 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation5_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE vector_getInterpolation5_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -537,16 +671,12 @@ END SUBROUTINE master_getInterpolation_2 ! date: 4 March 2021 ! summary: This function returns the interpolation of a scalar -INTERFACE +INTERFACE Interpolation MODULE PURE FUNCTION scalar_interpolation_1(obj, val) RESULT(interpol) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:) REAL(DFP), ALLOCATABLE :: interpol(:) END FUNCTION scalar_interpolation_1 -END INTERFACE - -INTERFACE Interpolation - MODULE PROCEDURE scalar_interpolation_1 END INTERFACE Interpolation !---------------------------------------------------------------------------- @@ -692,4 +822,4 @@ END FUNCTION matrix_stinterpolation_1 MODULE PROCEDURE matrix_stinterpolation_1 END INTERFACE STInterpolation -end module ElemshapeData_InterpolMethods +END MODULE ElemshapeData_InterpolMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index 3b6cc592c..061e4acfa 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -28,6 +28,15 @@ interpol = MATMUL(val, obj%N) END PROCEDURE scalar_getinterpolation_1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalar_getinterpolation1_ +tsize = SIZE(obj%N, 2) +interpol(1:tsize) = MATMUL(val, obj%N) +END PROCEDURE scalar_getinterpolation1_ + !---------------------------------------------------------------------------- ! getSTinterpolation !---------------------------------------------------------------------------- @@ -39,6 +48,18 @@ END SELECT END PROCEDURE scalar_getinterpolation_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalar_getinterpolation2_ +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + tsize = SIZE(obj%N, 2) + interpol = MATMUL(MATMUL(val, obj%T), obj%N) +END SELECT +END PROCEDURE scalar_getinterpolation2_ + !---------------------------------------------------------------------------- ! getSTinterpolation !---------------------------------------------------------------------------- @@ -51,6 +72,19 @@ END DO END PROCEDURE scalar_getinterpolation_3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE scalar_getinterpolation3_ +INTEGER(I4B) :: ipt +nrow = SIZE(obj(1)%N, 2) +ncol = SIZE(obj) +DO ipt = 1, ncol + interpol(1:nrow, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N) +END DO +END PROCEDURE scalar_getinterpolation3_ + !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- @@ -78,6 +112,37 @@ 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 + interpol(1:tsize) = Get(val, TypeFEVariableScalar, TypeFEVariableSpace) + END IF +CASE (SpaceTime) + SELECT TYPE (obj) + TYPE IS (STElemShapeData_) + IF (val%DefineOn .EQ. Nodal) THEN + CALL GetInterpolation_(obj=obj, interpol=interpol, & + val=Get(val, TypeFEVariableScalar, & + TypeFEVariableSpaceTime), & + tsize=tsize) + END IF + END SELECT +END SELECT +END PROCEDURE scalar_getinterpolation4_ + !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- @@ -148,6 +213,50 @@ !! 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 + interpol(1:nrow, 1) = Get(val, TypeFEVariableScalar, & + TypeFEVariableSpace) + 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 + interpol(1:nrow, 1:ncol) = Get(val, TypeFEVariableScalar, & + typeFEVariableSpaceTime) + END IF +END SELECT + +END PROCEDURE scalar_getinterpolation5_ + !--------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- @@ -156,6 +265,16 @@ interpol = MATMUL(val, obj%N) END PROCEDURE vector_getinterpolation_1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation1_ +nrow = SIZE(val, 1) +ncol = SIZE(obj%N, 2) +interpol(1:nrow, 1:ncol) = MATMUL(val, obj%N) +END PROCEDURE vector_getinterpolation1_ + !---------------------------------------------------------------------------- ! getSTinterpolation !---------------------------------------------------------------------------- @@ -167,6 +286,19 @@ END SELECT END PROCEDURE vector_getinterpolation_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation2_ +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + nrow = SIZE(val, 1) + ncol = SIZE(obj%N, 2) + interpol(1:nrow, 1:ncol) = MATMUL(MATMUL(val, obj%T), obj%N) +END SELECT +END PROCEDURE vector_getinterpolation2_ + !---------------------------------------------------------------------------- ! getSTinterpolation !---------------------------------------------------------------------------- @@ -180,6 +312,22 @@ END DO END PROCEDURE vector_getinterpolation_3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation3_ +INTEGER(I4B) :: ipt + +dim1 = SIZE(val, 1) +dim2 = SIZE(obj(1)%N, 2) +dim3 = SIZE(obj) +DO ipt = 1, dim3 + interpol(1:dim1, 1:dim2, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), & + obj(ipt)%N) +END DO +END PROCEDURE vector_getinterpolation3_ + !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- @@ -227,6 +375,47 @@ !! END PROCEDURE vector_getinterpolation_4 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation4_ +REAL(DFP), ALLOCATABLE :: m1(:) +INTEGER(I4B) :: ii + +SELECT CASE (val%vartype) +CASE (Constant) + m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant) + nrow = SIZE(m1) + ncol = SIZE(obj%N, 2) + DO ii = 1, ncol + interpol(1:nrow, ii) = m1 + END DO + DEALLOCATE (m1) +CASE (Space) + IF (val%DefineOn .EQ. Nodal) THEN + CALL GetInterpolation_(obj=obj, & + val=Get(val, TypeFEVariableVector, & + TypeFEVariableSpace), & + interpol=interpol, & + nrow=nrow, ncol=ncol) + ELSE + ! TODO: edit after change get method + interpol = Get(val, TypeFEVariableVector, TypeFEVariableSpace) + END IF +CASE (SpaceTime) + SELECT TYPE (obj) + TYPE IS (STElemShapeData_) + CALL GetInterpolation_(obj=obj, & + val=Get(val, TypeFEVariableVector, & + TypeFEVariableSpaceTime), & + interpol=interpol, & + nrow=nrow, ncol=ncol) + END SELECT +END SELECT + +END PROCEDURE vector_getinterpolation4_ + !---------------------------------------------------------------------------- ! getSTinterpolation !---------------------------------------------------------------------------- @@ -311,6 +500,59 @@ !! END PROCEDURE vector_getinterpolation_5 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation5_ +REAL(DFP), ALLOCATABLE :: m1(:) +INTEGER(I4B) :: ii, jj + +dim1 = SIZE(val, 1) +dim2 = SIZE(obj(1)%N, 2) +dim3 = SIZE(obj) +SELECT CASE (val%vartype) +CASE (Constant) + m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant) + DO jj = 1, dim3 + DO ii = 1, dim2 + interpol(1:dim1, ii, jj) = m1 + END DO + END DO + DEALLOCATE (m1) +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 + interpol(1:dim1, 1:dim2, 1) = Get(val, TypeFEVariableVector, & + TypeFEVariableSpace) + 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 + interpol(1:dim1, 1:dim2, 1:dim3) = Get(val, TypeFEVariableVector, & + typeFEVariableSpaceTime) + END IF +END SELECT + +END PROCEDURE vector_getinterpolation5_ + !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- From 5376d787dc0cb123415b8e82c5266d67e8e66061 Mon Sep 17 00:00:00 2001 From: shion Date: Tue, 4 Mar 2025 18:46:12 +0900 Subject: [PATCH 343/359] Updates in FEVariable_method - adding get methods where no allocation happens --- .../FEVariable/src/FEVariable_Method.F90 | 207 ++++++++++++++++++ .../src/FEVariable_Method@GetMethods.F90 | 169 ++++++++++++++ 2 files changed, 376 insertions(+) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 965542d7e..718aba242 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -42,6 +42,7 @@ MODULE FEVariable_Method PUBLIC :: isNodalVariable PUBLIC :: isQuadratureVariable PUBLIC :: Get +PUBLIC :: Get_ PUBLIC :: OPERATOR(+) PUBLIC :: OPERATOR(-) PUBLIC :: OPERATOR(*) @@ -1077,6 +1078,24 @@ MODULE PURE FUNCTION Scalar_Space(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1094,6 +1113,24 @@ MODULE PURE FUNCTION Scalar_Time(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1111,6 +1148,25 @@ MODULE PURE FUNCTION Scalar_SpaceTime(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1128,6 +1184,24 @@ MODULE PURE FUNCTION Vector_Constant(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1145,6 +1219,25 @@ MODULE PURE FUNCTION Vector_Space(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1162,6 +1255,25 @@ MODULE PURE FUNCTION Vector_Time(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1179,6 +1291,25 @@ MODULE PURE FUNCTION Vector_SpaceTime(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1196,6 +1327,25 @@ MODULE PURE FUNCTION Matrix_Constant(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1213,6 +1363,25 @@ MODULE PURE FUNCTION Matrix_Space(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1230,6 +1399,25 @@ MODULE PURE FUNCTION Matrix_Time(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- @@ -1247,6 +1435,25 @@ MODULE PURE FUNCTION Matrix_SpaceTime(obj, rank, vartype) RESULT(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 !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 index 573b6700b..dc39463e2 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 @@ -137,6 +137,69 @@ val = obj%val(1) END PROCEDURE Scalar_Constant +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Master_Get_vec_(obj, val, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + + tsize = obj%len + val(1:tsize) = obj%val(1:tsize) + +END SUBROUTINE Master_Get_vec_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Master_Get_mat_(obj, val, nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + INTEGER(I4B) :: ii, jj, cnt + + nrow = obj%s(1) + ncol = obj%s(2) + + cnt = 0 + DO jj = 1, ncol + DO ii = 1, nrow + cnt = cnt + 1 + val(ii, jj) = obj%val(cnt) + END DO + END DO +END SUBROUTINE Master_Get_mat_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Master_get_mat3_(obj, val, dim1, dim2, dim3) + CLASS(FEVariable_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + INTEGER(I4B) :: ii, jj, kk, cnt + + dim1 = obj%s(1) + dim2 = obj%s(2) + dim3 = obj%s(3) + + cnt = 0 + DO kk = 1, dim3 + DO jj = 1, dim2 + DO ii = 1, dim1 + cnt = cnt + 1 + val(ii, jj, kk) = obj%val(cnt) + END DO + END DO + END DO + +END SUBROUTINE Master_get_mat3_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -146,6 +209,14 @@ val = obj%val(1:obj%len) END PROCEDURE Scalar_Space +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_Space_ +CALL Master_Get_vec_(obj, val, tsize) +END PROCEDURE Scalar_Space_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -155,6 +226,14 @@ val = obj%val(1:obj%len) END PROCEDURE Scalar_Time +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_Time_ +CALL Master_Get_vec_(obj, val, tsize) +END PROCEDURE Scalar_Time_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -175,6 +254,14 @@ END PROCEDURE Scalar_SpaceTime +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Scalar_SpaceTime_ +CALL Master_Get_mat_(obj, val, nrow, ncol) +END PROCEDURE Scalar_SpaceTime_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -184,6 +271,14 @@ val = obj%val(1:obj%len) END PROCEDURE Vector_Constant +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_Constant_ +CALL Master_Get_vec_(obj, val, tsize) +END PROCEDURE Vector_Constant_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -203,6 +298,14 @@ END PROCEDURE Vector_Space +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_Space_ +CALL Master_Get_mat_(obj, val, nrow, ncol) +END PROCEDURE Vector_Space_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -221,6 +324,14 @@ END DO END PROCEDURE Vector_Time +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_Time_ +CALL Master_Get_mat_(obj, val, nrow, ncol) +END PROCEDURE Vector_Time_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -241,6 +352,14 @@ END DO END PROCEDURE Vector_SpaceTime +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Vector_SpaceTime_ +CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +END PROCEDURE Vector_SpaceTime_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -259,6 +378,14 @@ END DO END PROCEDURE Matrix_Constant +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Matrix_Constant_ +CALL Master_Get_mat_(obj, val, nrow, ncol) +END PROCEDURE Matrix_Constant_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -279,6 +406,14 @@ END DO END PROCEDURE Matrix_Space +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Matrix_Space_ +CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +END PROCEDURE Matrix_Space_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -299,6 +434,14 @@ END DO END PROCEDURE Matrix_Time +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Matrix_Time_ +CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +END PROCEDURE Matrix_Time_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- @@ -325,4 +468,30 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE Matrix_SpaceTime_ +INTEGER(I4B) :: ii, jj, kk, ll, cnt + +dim1 = obj%s(1) +dim2 = obj%s(2) +dim3 = obj%s(3) +dim4 = obj%s(4) + +cnt = 0 +DO ll = 1, dim4 + DO kk = 1, dim3 + DO jj = 1, dim2 + DO ii = 1, dim1 + cnt = cnt + 1 + val(ii, jj, kk, ll) = obj%val(cnt) + END DO + END DO + END DO +END DO + +END PROCEDURE Matrix_SpaceTime_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE GetMethods From 026b2bd61d8b27020e7f3fd89faf10904b2fd90b Mon Sep 17 00:00:00 2001 From: shion Date: Tue, 4 Mar 2025 19:49:46 +0900 Subject: [PATCH 344/359] Updates in ElemShapeData method - adding GetInterpolation methods where no allocation happens --- .../src/ElemshapeData_InterpolMethods.F90 | 120 ++++++++---- .../ElemshapeData_InterpolMethods@Methods.F90 | 173 +++++++++++++++--- 2 files changed, 234 insertions(+), 59 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index 577769bc4..f6ab5ef77 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -492,7 +492,7 @@ END SUBROUTINE vector_getInterpolation5_ ! date: 4 March 2021 ! summary: This subroutine performs interpolation of matrix -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) @@ -500,11 +500,25 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:, :, :) !! nodal value of matrix END SUBROUTINE matrix_getInterpolation_1 -END INTERFACE +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_1 -END INTERFACE getInterpolation +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 @@ -519,18 +533,32 @@ END SUBROUTINE matrix_getInterpolation_1 ! This subroutine performs interpolation of matrix from its space-time ! nodal values -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) REAL(DFP), INTENT(IN) :: val(:, :, :, :) !! space-time nodal value of matrix END SUBROUTINE matrix_getInterpolation_2 -END INTERFACE +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_2 -END INTERFACE getInterpolation +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matrix_getInterpolation2_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -545,7 +573,7 @@ END SUBROUTINE matrix_getInterpolation_2 ! This subroutine performs interpolation of matrix from its space-time ! nodal values -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :, :) @@ -553,11 +581,7 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val) REAL(DFP), INTENT(IN) :: val(:, :, :, :) !! space-time nodal value of matrix END SUBROUTINE matrix_getInterpolation_3 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_3 -END INTERFACE getInterpolation +END INTERFACE GetInterpolation !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -567,7 +591,7 @@ END SUBROUTINE matrix_getInterpolation_3 ! date: 4 March 2021 ! summary: This subroutine performs interpolation of matrix FEVariable ! -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) @@ -575,17 +599,31 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val) TYPE(FEVariable_), INTENT(IN) :: val !! matrix fe variable END SUBROUTINE matrix_getInterpolation_4 -END INTERFACE +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_4 -END INTERFACE getInterpolation +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matrix_getInterpolation4_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods !---------------------------------------------------------------------------- -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :, :) @@ -593,11 +631,25 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val) TYPE(FEVariable_), INTENT(IN) :: val !! matrix fe variable END SUBROUTINE matrix_getInterpolation_5 -END INTERFACE +END INTERFACE GetInterpolation -INTERFACE getInterpolation - MODULE PROCEDURE matrix_getInterpolation_5 -END INTERFACE getInterpolation +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE matrix_getInterpolation5_(obj, interpol, val, & + dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE matrix_getInterpolation5_ +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -619,17 +671,13 @@ END SUBROUTINE matrix_getInterpolation_5 ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime ! -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE master_getInterpolation_1(obj, interpol, val) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(INOUT) :: interpol TYPE(FEVariable_), INTENT(IN) :: val END SUBROUTINE master_getInterpolation_1 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE master_getInterpolation_1 -END INTERFACE getInterpolation +END INTERFACE GetInterpolation !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -651,17 +699,13 @@ END SUBROUTINE master_getInterpolation_1 ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime ! -INTERFACE +INTERFACE GetInterpolation MODULE PURE SUBROUTINE master_getInterpolation_2(obj, interpol, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) TYPE(FEVariable_), INTENT(INOUT) :: interpol TYPE(FEVariable_), INTENT(IN) :: val END SUBROUTINE master_getInterpolation_2 -END INTERFACE - -INTERFACE getInterpolation - MODULE PROCEDURE master_getInterpolation_2 -END INTERFACE getInterpolation +END INTERFACE GetInterpolation !---------------------------------------------------------------------------- ! Interpolation@InterpolMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index 061e4acfa..321a86582 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -128,7 +128,9 @@ TypeFEVariableSpace), & tsize=tsize) ELSE - interpol(1:tsize) = Get(val, TypeFEVariableScalar, TypeFEVariableSpace) + CALL Get_(obj=val, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpace, & + val=interpol, tsize=tsize) END IF CASE (SpaceTime) SELECT TYPE (obj) @@ -234,8 +236,9 @@ tsize=nrow) END DO ELSE - interpol(1:nrow, 1) = Get(val, TypeFEVariableScalar, & - TypeFEVariableSpace) + 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 @@ -250,8 +253,9 @@ tsize=nrow) END DO ELSE - interpol(1:nrow, 1:ncol) = Get(val, TypeFEVariableScalar, & - typeFEVariableSpaceTime) + CALL Get_(obj=val, rank=TypeFEVariableScalar, & + vartype=typeFEVariableSpaceTime, & + val=interpol, nrow=nrow, ncol=ncol) END IF END SELECT @@ -380,18 +384,17 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE vector_getinterpolation4_ -REAL(DFP), ALLOCATABLE :: m1(:) INTEGER(I4B) :: ii SELECT CASE (val%vartype) CASE (Constant) - m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant) - nrow = SIZE(m1) + CALL Get_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableConstant, & + val=interpol(:, 1), tsize=nrow) ncol = SIZE(obj%N, 2) - DO ii = 1, ncol - interpol(1:nrow, ii) = m1 + DO ii = 2, ncol + interpol(1:nrow, ii) = interpol(1:nrow, 1) END DO - DEALLOCATE (m1) CASE (Space) IF (val%DefineOn .EQ. Nodal) THEN CALL GetInterpolation_(obj=obj, & @@ -400,8 +403,9 @@ interpol=interpol, & nrow=nrow, ncol=ncol) ELSE - ! TODO: edit after change get method - interpol = Get(val, TypeFEVariableVector, TypeFEVariableSpace) + CALL Get_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpace, & + val=interpol, nrow=nrow, ncol=ncol) END IF CASE (SpaceTime) SELECT TYPE (obj) @@ -505,7 +509,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE vector_getinterpolation5_ -REAL(DFP), ALLOCATABLE :: m1(:) INTEGER(I4B) :: ii, jj dim1 = SIZE(val, 1) @@ -513,13 +516,15 @@ dim3 = SIZE(obj) SELECT CASE (val%vartype) CASE (Constant) - m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant) + CALL Get_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableConstant, & + val=interpol(:, 1, 1), tsize=dim1) DO jj = 1, dim3 DO ii = 1, dim2 - interpol(1:dim1, ii, jj) = m1 + IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE + interpol(1:dim1, ii, jj) = interpol(1:dim1, 1, 1) END DO END DO - DEALLOCATE (m1) CASE (Space) IF (val%DefineOn .EQ. Nodal) THEN DO ii = 1, dim3 @@ -530,8 +535,9 @@ nrow=dim1, ncol=dim2) END DO ELSE - interpol(1:dim1, 1:dim2, 1) = Get(val, TypeFEVariableVector, & - TypeFEVariableSpace) + 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 @@ -546,8 +552,9 @@ nrow=dim1, ncol=dim2) END DO ELSE - interpol(1:dim1, 1:dim2, 1:dim3) = Get(val, TypeFEVariableVector, & - typeFEVariableSpaceTime) + CALL Get_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpaceTime, & + val=interpol, dim1=dim1, dim2=dim2, dim3=dim3) END IF END SELECT @@ -561,6 +568,17 @@ interpol = MATMUL(val, obj%N) END PROCEDURE matrix_getinterpolation_1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation1_ +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = SIZE(obj%N, 2) +interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(val, obj%N) +END PROCEDURE matrix_getinterpolation1_ + !---------------------------------------------------------------------------- ! getSTinterpolation !---------------------------------------------------------------------------- @@ -572,6 +590,20 @@ END SELECT END PROCEDURE matrix_getinterpolation_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation2_ +SELECT TYPE (obj) +TYPE IS (STElemShapeData_) + dim1 = SIZE(val, 1) + dim2 = SIZE(val, 2) + dim3 = SIZE(obj%N, 2) + interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(MATMUL(val, obj%T), obj%N) +END SELECT +END PROCEDURE matrix_getinterpolation2_ + !---------------------------------------------------------------------------- ! getSTinterpolation !---------------------------------------------------------------------------- @@ -615,6 +647,48 @@ END SELECT END PROCEDURE matrix_getinterpolation_4 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation4_ +INTEGER(I4B) :: ii + +SELECT CASE (val%vartype) +CASE (Constant) + dim3 = SIZE(obj%N, 2) + CALL Get_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableConstant, & + val=interpol(:, :, 1), nrow=dim1, ncol=dim2) + DO ii = 2, dim3 + interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) + END DO +CASE (Space) + IF (val%DefineOn .EQ. Nodal) THEN + CALL GetInterpolation_(obj=obj, & + val=Get(val, TypeFEVariableMatrix, & + TypeFEVariableSpace), & + interpol=interpol, & + dim1=dim1, dim2=dim2, dim3=dim3) + ELSE + CALL Get_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpace, val=interpol, & + dim1=dim1, dim2=dim2, dim3=dim3) + END IF +CASE (SpaceTime) + SELECT TYPE (obj) + TYPE IS (STElemShapeData_) + IF (val%DefineOn .EQ. Nodal) THEN + CALL GetInterpolation_(obj=obj, & + val=Get(val, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime), & + interpol=interpol, & + dim1=dim1, dim2=dim2, dim3=dim3) + END IF + END SELECT +END SELECT +END PROCEDURE matrix_getinterpolation4_ + !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- @@ -703,6 +777,63 @@ !! END PROCEDURE matrix_getinterpolation_5 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation5_ +INTEGER(I4B) :: ii, jj +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = SIZE(obj(1)%N, 2) +dim4 = SIZE(obj) + +SELECT CASE (val%vartype) +CASE (Constant) + CALL Get_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableConstant, val=interpol(:, :, 1, 1), & + nrow=dim1, ncol=dim2) + DO jj = 1, dim3 + DO ii = 1, dim4 + IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE + interpol(1:dim1, 1:dim2, ii, jj) = interpol(1:dim1, 1:dim2, 1, 1) + END DO + END DO +CASE (Space) + IF (val%DefineOn .EQ. Nodal) THEN + DO ii = 1, dim4 + CALL GetInterpolation_(obj=obj(ii), & + val=Get(val, TypeFEVariableMatrix, & + TypeFEVariableSpace), & + interpol=interpol(:, :, :, ii), & + dim1=dim1, dim2=dim2, dim3=dim3) + END DO + ELSE + CALL Get_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpace, val=interpol(:, :, :, 1), & + dim1=dim1, dim2=dim2, dim3=dim3) + DO ii = 2, dim4 + interpol(1:dim1, 1:dim2, 1:dim3, ii) = & + interpol(1:dim1, 1:dim2, 1:dim3, 1) + END DO + END IF +CASE (SpaceTime) + IF (val%DefineOn .EQ. Nodal) THEN + DO ii = 1, dim4 + CALL GetInterpolation_(obj=obj(ii), & + val=Get(val, TypeFEVariableMatrix, & + TypeFEVariableSpaceTime), & + interpol=interpol(:, :, :, ii), & + dim1=dim1, dim2=dim2, dim3=dim3) + END DO + ELSE + CALL Get_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpaceTime, val=interpol, & + dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) + END IF +END SELECT +END PROCEDURE matrix_getinterpolation5_ + !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- From aff9d55ca6903b8cd221f8a5938da57e551b3a70 Mon Sep 17 00:00:00 2001 From: shion Date: Wed, 5 Mar 2025 13:44:39 +0900 Subject: [PATCH 345/359] Updates ElemshapeData methods - adding projection methods in which no allocation occurs --- .../src/ElemshapeData_ProjectionMethods.F90 | 96 ++++++++++++------- ...lemshapeData_ProjectionMethods@Methods.F90 | 52 ++++++++++ 2 files changed, 113 insertions(+), 35 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 index 4d78a673c..0f71ae33b 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -15,14 +15,17 @@ ! along with this program. If not, see ! -module ElemshapeData_ProjectionMethods +MODULE ElemshapeData_ProjectionMethods USE BaseType USE GlobalData IMPLICIT NONE PRIVATE PUBLIC :: getProjectionOfdNdXt +PUBLIC :: getProjectionOfdNdXt_ PUBLIC :: getProjectionOfdNTdXt +! TODO: implement +! PUBLIC :: getProjectionOfdNTdXt_ !---------------------------------------------------------------------------- ! getProjectionOfdNdXt@ProjectionMethods @@ -40,7 +43,7 @@ module ElemshapeData_ProjectionMethods ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE +INTERFACE GetProjectionOfdNdXt MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :) @@ -48,11 +51,24 @@ MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val) REAL(DFP), INTENT(IN) :: val(:) !! constant value of vector END SUBROUTINE getProjectionOfdNdXt_1 -END INTERFACE +END INTERFACE GetProjectionOfdNdXt -INTERFACE getProjectionOfdNdXt - MODULE PROCEDURE getProjectionOfdNdXt_1 -END INTERFACE getProjectionOfdNdXt +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-05 +! summary: get interpolation of vector without allocation + +INTERFACE GetProjectionOfdNdXt_ + MODULE PURE SUBROUTINE getProjectionOfdNdXt1_(obj, cdNdXt, val, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE getProjectionOfdNdXt1_ +END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- ! getProjectionOfdNdXt@getMethod @@ -70,7 +86,7 @@ END SUBROUTINE getProjectionOfdNdXt_1 ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE +INTERFACE GetProjectionOfdNdXt MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val) CLASS(ElemshapeData_), INTENT(IN) :: obj !! ElemshapeData object @@ -79,11 +95,20 @@ MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val) CLASS(FEVariable_), INTENT(IN) :: val !! FEVariable vector END SUBROUTINE getProjectionOfdNdXt_2 -END INTERFACE +END INTERFACE GetProjectionOfdNdXt -INTERFACE getProjectionOfdNdXt - MODULE PROCEDURE getProjectionOfdNdXt_2 -END INTERFACE getProjectionOfdNdXt +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE GetProjectionOfdNdXt_ + MODULE PURE SUBROUTINE getProjectionOfdNdXt2_(obj, cdNdXt, val, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) + CLASS(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE getProjectionOfdNdXt2_ +END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- ! getProjectionOfdNdXt@getMethod @@ -101,7 +126,7 @@ END SUBROUTINE getProjectionOfdNdXt_2 ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE +INTERFACE GetProjectionOfdNdXt MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val) CLASS(ElemshapeData_), INTENT(IN) :: obj !! ElemshapeData object @@ -110,11 +135,24 @@ MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val) REAL(DFP), INTENT(IN) :: val(:, :) !! a vector, defined over quadrature points END SUBROUTINE getProjectionOfdNdXt_3 -END INTERFACE +END INTERFACE GetProjectionOfdNdXt + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -INTERFACE getProjectionOfdNdXt - MODULE PROCEDURE getProjectionOfdNdXt_3 -END INTERFACE getProjectionOfdNdXt +!> author: Shion Shimizu +! date: 2025-03-05 +! summary: get interpolation of vector without allocation + +INTERFACE GetProjectionOfdNdXt_ + MODULE PURE SUBROUTINE getProjectionOfdNdXt3_(obj, cdNdXt, val, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE getProjectionOfdNdXt3_ +END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt@getMethod @@ -130,7 +168,7 @@ END SUBROUTINE getProjectionOfdNdXt_3 ! ! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ -INTERFACE +INTERFACE GetProjectionOfdNTdXt MODULE PURE SUBROUTINE getProjectionOfdNTdXt_1(obj, cdNTdXt, val) CLASS(STElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :) @@ -138,11 +176,7 @@ MODULE PURE SUBROUTINE getProjectionOfdNTdXt_1(obj, cdNTdXt, val) REAL(DFP), INTENT(IN) :: val(:) !! constant value of vector END SUBROUTINE getProjectionOfdNTdXt_1 -END INTERFACE - -INTERFACE getProjectionOfdNTdXt - MODULE PROCEDURE getProjectionOfdNTdXt_1 -END INTERFACE getProjectionOfdNTdXt +END INTERFACE GetProjectionOfdNTdXt !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt@getMethod @@ -164,7 +198,7 @@ END SUBROUTINE getProjectionOfdNTdXt_1 ! ! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ ! -INTERFACE +INTERFACE GetProjectionOfdNTdXt MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val) CLASS(STElemshapeData_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :) @@ -172,11 +206,7 @@ MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val) TYPE(FEVariable_), INTENT(IN) :: val !! constant value of vector END SUBROUTINE getProjectionOfdNTdXt_2 -END INTERFACE - -INTERFACE getProjectionOfdNTdXt - MODULE PROCEDURE getProjectionOfdNTdXt_2 -END INTERFACE getProjectionOfdNTdXt +END INTERFACE GetProjectionOfdNTdXt !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt@getMethod @@ -199,16 +229,12 @@ END SUBROUTINE getProjectionOfdNTdXt_2 ! ! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ ! -INTERFACE +INTERFACE GetProjectionOfdNTdXt MODULE PURE SUBROUTINE getProjectionOfdNTdXt_3(obj, cdNTdXt, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :, :) TYPE(FEVariable_), INTENT(IN) :: val END SUBROUTINE getProjectionOfdNTdXt_3 -END INTERFACE - -INTERFACE getProjectionOfdNTdXt - MODULE PROCEDURE getProjectionOfdNTdXt_3 -END INTERFACE getProjectionOfdNTdXt +END INTERFACE GetProjectionOfdNTdXt -end module ElemshapeData_ProjectionMethods +END MODULE ElemshapeData_ProjectionMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index 2998cf756..c4819ecda 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -38,6 +38,23 @@ !! END PROCEDURE getProjectionOfdNdXt_1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getProjectionOfdNdXt1_ +INTEGER(I4B) :: ii, nsd + +nrow = SIZE(obj%dNdXt, 1) +ncol = SIZE(obj%dNdXt, 3) +nsd = SIZE(obj%dNdXt, 2) + +DO ii = 1, ncol + cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), Val(1:nsd)) +END DO + +END PROCEDURE getProjectionOfdNdXt1_ + !---------------------------------------------------------------------------- ! getProjectionOfdNdXt !---------------------------------------------------------------------------- @@ -59,6 +76,24 @@ !! END PROCEDURE getProjectionOfdNdXt_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getProjectionOfdNdXt2_ +INTEGER(I4B) :: ii, nsd +REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3)) + +CALL GetInterpolation_(obj=obj, val=val, interpol=cbar, nrow=nrow, ncol=ncol) +nsd = nrow +nrow = SIZE(obj%dNdXt, 1) + +DO ii = 1, ncol + cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), cbar(1:nsd, ii)) +END DO + +END PROCEDURE getProjectionOfdNdXt2_ + !---------------------------------------------------------------------------- ! getProjectionOfdNdXt !---------------------------------------------------------------------------- @@ -77,6 +112,23 @@ !! END PROCEDURE getProjectionOfdNdXt_3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE getProjectionOfdNdXt3_ +INTEGER(I4B) :: ii, nsd + +nrow = SIZE(obj%dNdXt, 1) +ncol = SIZE(obj%dNdXt, 3) +nsd = SIZE(obj%dNdXt, 2) + +DO ii = 1, ncol + cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), val(1:nsd, ii)) +END DO + +END PROCEDURE getProjectionOfdNdXt3_ + !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt !---------------------------------------------------------------------------- From f0da3ade2d0026631cf10d14b412fd4841151ddf Mon Sep 17 00:00:00 2001 From: shion Date: Wed, 5 Mar 2025 15:01:54 +0900 Subject: [PATCH 346/359] Updates Convective Matrix - adding new subroutines in which no allocation occur --- .../src/ConvectiveMatrix_Method.F90 | 92 ++- src/modules/Utility/src/ProductUtility.F90 | 15 + .../src/ConvectiveMatrix_Method@Methods.F90 | 567 ++++++++++++++++-- .../Utility/src/ProductUtility@Methods.F90 | 16 + 4 files changed, 622 insertions(+), 68 deletions(-) diff --git a/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 b/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 index b38be47e3..367b49e0a 100644 --- a/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 +++ b/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 @@ -26,6 +26,7 @@ MODULE ConvectiveMatrix_Method PRIVATE PUBLIC :: ConvectiveMatrix +PUBLIC :: ConvectiveMatrix_ !---------------------------------------------------------------------------- ! ConvectiveMatrix@ConvectiveMatrixMethods @@ -36,7 +37,7 @@ MODULE ConvectiveMatrix_Method ! update: 2021-11-21 ! summary: returns the convective matrix -INTERFACE +INTERFACE ConvectiveMatrix MODULE PURE FUNCTION ConvectiveMatrix_1(test, trial, term1, & & term2, opt) RESULT(Ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -45,15 +46,32 @@ MODULE PURE FUNCTION ConvectiveMatrix_1(test, trial, term1, & !! del_x, del_y, del_z, del_x_all, del_none INTEGER(I4B), INTENT(IN) :: term2 !! del_x, del_y, del_z, del_x_all, del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION ConvectiveMatrix_1 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE ConvectiveMatrix_1 END INTERFACE ConvectiveMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-05 +! summary: Convective matrix without allcation + +INTERFACE ConvectiveMatrix_ + MODULE PURE SUBROUTINE ConvectiveMatrix1_(test, trial, term1, & + & term2, nrow, ncol, opt, ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(inout) :: ans(:, :) + END SUBROUTINE ConvectiveMatrix1_ +END INTERFACE ConvectiveMatrix_ + !---------------------------------------------------------------------------- ! ConvectiveMatrix@ConvectiveMatrixMethods !---------------------------------------------------------------------------- @@ -63,7 +81,7 @@ END FUNCTION ConvectiveMatrix_1 ! update: 2021-11-21 ! summary: returns the convective matrix -INTERFACE +INTERFACE ConvectiveMatrix MODULE PURE FUNCTION ConvectiveMatrix_2(test, trial, c, crank, term1, & & term2, opt) RESULT(Ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -76,16 +94,35 @@ MODULE PURE FUNCTION ConvectiveMatrix_2(test, trial, c, crank, term1, & !! del_x, del_y, del_z, del_x_all, del_none INTEGER(I4B), INTENT(IN) :: term2 !! del_x, del_y, del_z, del_x_all, del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt !! number of copies REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION ConvectiveMatrix_2 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE ConvectiveMatrix_2 END INTERFACE ConvectiveMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-05 +! summary: Convective matrix without allcation + +INTERFACE ConvectiveMatrix_ + MODULE PURE SUBROUTINE ConvectiveMatrix2_(test, trial, c, crank, term1, & + & term2, opt, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(inout) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE ConvectiveMatrix2_ +END INTERFACE ConvectiveMatrix_ + !---------------------------------------------------------------------------- ! ConvectiveMatrix@ConvectiveMatrixMethods !---------------------------------------------------------------------------- @@ -95,7 +132,7 @@ END FUNCTION ConvectiveMatrix_2 ! update: 2021-11-21 ! summary: returns the convective matrix -INTERFACE +INTERFACE ConvectiveMatrix MODULE PURE FUNCTION ConvectiveMatrix_3(test, trial, c, crank, term1, & & term2, opt) RESULT(Ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -108,18 +145,37 @@ MODULE PURE FUNCTION ConvectiveMatrix_3(test, trial, c, crank, term1, & !! del_x, del_y, del_z, del_x_all, del_none INTEGER(I4B), INTENT(IN) :: term2 !! del_x, del_y, del_z, del_x_all, del_none - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt !! number of copies REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION ConvectiveMatrix_3 -END INTERFACE - -INTERFACE ConvectiveMatrix - MODULE PROCEDURE ConvectiveMatrix_3 END INTERFACE ConvectiveMatrix !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +!> author: Shion Shimizu +! date: 2025-03-05 +! summary: Convective matrix without allcation + +INTERFACE ConvectiveMatrix_ + MODULE PURE SUBROUTINE ConvectiveMatrix3_(test, trial, c, crank, term1, & + & term2, opt, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(inout) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE ConvectiveMatrix3_ +END INTERFACE ConvectiveMatrix_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE ConvectiveMatrix_Method diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index 58f221cf6..b076bf7ea 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -193,6 +193,21 @@ MODULE PURE FUNCTION OuterProd_r1r2(a, b) RESULT(ans) END FUNCTION OuterProd_r1r2 END INTERFACE OuterProd +!> author: Shion Shimizu +! date: 2025-03-05 +! summary: a x b + +INTERFACE OuterProd_ + MODULE PURE SUBROUTINE OuterProd_r1r2_(a, b, anscoeff, scale, ans, & + dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(IN) :: anscoeff, scale + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE OuterProd_r1r2_ +END INTERFACE OuterProd_ + !---------------------------------------------------------------------------- ! OuterProd@ProductMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 index 838cc5b12..bad5cdb52 100644 --- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 +++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 @@ -35,98 +35,127 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ConvectiveMatrix_1 -IF( term1 .EQ. DEL_NONE ) THEN -!! -!! -!! -!! - IF( term2 .EQ. DEL_X_ALL ) THEN - !! +IF (term1 .EQ. DEL_NONE) THEN + IF (term2 .EQ. DEL_X_ALL) THEN !! del_none !! del_x_all - !! CALL CM_9(ans=ans, test=test, trial=trial, & & term1=term2, term2=term2, opt=opt) - !! ELSE - !! !! del_none !! del_x, del_y, del_z - !! CALL CM_7(ans=ans, test=test, trial=trial, & & term1=term2, term2=term2, opt=opt) !! END IF -!! -!! -!! -!! ELSE - !! !! term2 .eq. del_none - !! - IF( term1 .EQ. del_x_all ) THEN - !! + IF (term1 .EQ. del_x_all) THEN !! del_x_all !! del_none - !! CALL CM_10(ans=ans, test=test, trial=trial, & & term1=term2, term2=term2, opt=opt) - !! ELSE - !! !! del_x, del_y, del_z !! del_none - !! CALL CM_8(ans=ans, test=test, trial=trial, & & term1=term2, term2=term2, opt=opt) - !! END IF END IF -!! + END PROCEDURE ConvectiveMatrix_1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ConvectiveMatrix1_ + +IF (term1 .EQ. DEL_NONE) THEN + IF (term2 .EQ. DEL_X_ALL) THEN + CALL CM9_(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, nrow=nrow, ncol=ncol, opt=opt) + ELSE + CALL CM7_(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol) + END IF +ELSE + IF (term1 .EQ. del_x_all) THEN + CALL CM10_(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol) + ELSE + CALL CM8_(ans=ans, test=test, trial=trial, & + & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol) + END IF +END IF + +END PROCEDURE ConvectiveMatrix1_ + !---------------------------------------------------------------------------- ! ConvectiveMatrix !---------------------------------------------------------------------------- MODULE PROCEDURE ConvectiveMatrix_2 - !! - !! scalar - !! - IF( term1 .EQ. del_none ) THEN - IF( term2 .EQ. del_x_all ) THEN - CALL CM_5(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - ELSE - CALL CM_3(ans=ans, test=test, trial=trial, c=c, & - & term1=term2, term2=term2, opt=opt) - END IF + +IF (term1 .EQ. del_none) THEN + IF (term2 .EQ. del_x_all) THEN + CALL CM_5(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) ELSE - IF( term1 .EQ. del_x_all ) THEN - CALL CM_6(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - ELSE - CALL CM_4(ans=ans, test=test, trial=trial, c=c, & - & term1=term2, term2=term2, opt=opt) - END IF + CALL CM_3(ans=ans, test=test, trial=trial, c=c, & + & term1=term2, term2=term2, opt=opt) END IF +ELSE + IF (term1 .EQ. del_x_all) THEN + CALL CM_6(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) + ELSE + CALL CM_4(ans=ans, test=test, trial=trial, c=c, & + & term1=term2, term2=term2, opt=opt) + END IF +END IF !! END PROCEDURE ConvectiveMatrix_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ConvectiveMatrix2_ + +IF (term1 .EQ. del_none) THEN + IF (term2 .EQ. del_x_all) THEN + CALL CM5_(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol) + ELSE + CALL CM3_(ans=ans, test=test, trial=trial, c=c, & + & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol) + END IF +ELSE + IF (term1 .EQ. del_x_all) THEN + CALL CM6_(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol) + ELSE + CALL CM4_(ans=ans, test=test, trial=trial, c=c, & + & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol) + END IF +END IF + +END PROCEDURE ConvectiveMatrix2_ + !---------------------------------------------------------------------------- ! ConvectiveMatrix !---------------------------------------------------------------------------- MODULE PROCEDURE ConvectiveMatrix_3 !! - IF( term1 .EQ. del_none ) THEN - CALL CM_1(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - ELSE - CALL CM_2(ans=ans, test=test, trial=trial, c=c, & - & term1=term1, term2=term2, opt=opt) - END IF +IF (term1 .EQ. del_none) THEN + CALL CM_1(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) +ELSE + CALL CM_2(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt) +END IF !! END PROCEDURE ConvectiveMatrix_3 @@ -134,4 +163,442 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE ConvectiveMatrix3_ +IF (term1 .EQ. del_none) THEN + CALL CM1_(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol) +ELSE + CALL CM2_(ans=ans, test=test, trial=trial, c=c, & + & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol) +END IF +END PROCEDURE ConvectiveMatrix3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM1_(ans, test, trial, c, term1, term2, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj + REAL(DFP) :: p(trial%nns, trial%nips) + REAL(DFP), PARAMETER :: one = 1.0_DFP + REAL(DFP) :: realVal + + nrow = test%nns + ncol = trial%nns + ans(1:nrow, 1:ncol) = 0.0_DFP + + CALL GetProjectionOfdNdXt_(obj=trial, cdNdXt=p, val=c, nrow=ii, ncol=jj) + !! + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=p(1:ncol, ips), & + nrow=ii, ncol=jj, ans=ans, & + scale=realval, anscoeff=one) + END DO + + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol + END IF + +END SUBROUTINE CM1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM2_(ans, test, trial, c, term1, term2, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj + REAL(DFP) :: p(test%nns, test%nips) + REAL(DFP) :: realval + REAL(DFP), PARAMETER :: one = 1.0_DFP + + nrow = test%nns + ncol = trial%nns + ans(1:nrow, 1:ncol) = 0.0_DFP + + CALL GetProjectionOfdNdXt_(obj=test, cdNdXt=p, val=c, nrow=ii, ncol=jj) + + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + CALL OuterProd_(a=p(1:nrow, ips), & + b=trial%N(1:ncol, ips), & + nrow=ii, ncol=jj, ans=ans, & + scale=realval, anscoeff=one) + END DO + + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol + END IF +END SUBROUTINE CM2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM3_(ans, test, trial, term1, term2, c, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj + REAL(DFP) :: realval(trial%nips) + REAL(DFP), PARAMETER :: one = 1.0_DFP + + nrow = test%nns + ncol = trial%nns + ans(1:nrow, 1:ncol) = 0.0_DFP + + CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii) + + DO ips = 1, trial%nips + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%dNdXt(1:ncol, term2, ips), & + nrow=ii, ncol=jj, ans=ans, & + scale=realval(ips), anscoeff=one) + END DO + + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol + END IF +END SUBROUTINE CM3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM4_(ans, test, trial, term1, term2, c, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj + REAL(DFP) :: realval(trial%nips) + REAL(DFP), PARAMETER :: one = 1.0_DFP + + nrow = SIZE(test%N, 1) + ncol = SIZE(trial%N, 1) + ans(1:nrow, 1:ncol) = 0.0_DFP + + CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii) + + DO ips = 1, trial%nips + CALL OuterProd_(a=test%dNdXt(1:nrow, term1, ips), & + b=trial%N(1:ncol, ips), & + nrow=ii, ncol=jj, ans=ans, & + scale=realval(ips), anscoeff=one) + END DO + + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol + END IF +END SUBROUTINE CM4_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM5_(ans, test, trial, term1, term2, c, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER(I4B), INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj, kk, nsd + REAL(DFP) :: realval(trial%nips) + REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1) + REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd) + REAL(DFP), PARAMETER :: one = 1.0_DFP + + CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + realval(1:trial%nips) = trial%js * trial%ws * trial%thickness * realval(1:trial%nips) + + nrow = test%nns + ncol = trial%nns + nsd = trial%nsd + + IF (opt .EQ. 1) THEN + m4_1 = 0.0_DFP + DO ips = 1, trial%nips + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%dNdXt(1:ncol, 1:nsd, ips), & + dim1=ii, dim2=jj, dim3=kk, & + ans=m4_1(1:nrow, 1:ncol, 1:nsd, 1), & + scale=realval(ips), anscoeff=one) + END DO + CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol) + ELSE + m4_2 = 0.0_DFP + DO ips = 1, trial%nips + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%dNdXt(1:ncol, 1:nsd, ips), & + dim1=ii, dim2=jj, dim3=kk, & + ans=m4_1(1:nrow, 1:ncol, 1, 1:nsd), & + scale=realval(ips), anscoeff=one) + END DO + CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol) + END IF + +END SUBROUTINE CM5_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM6_(ans, test, trial, term1, term2, c, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + TYPE(FEVariable_), INTENT(IN) :: c + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj, kk + REAL(DFP) :: realval(trial%nips) + REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1) + REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd) + REAL(DFP), PARAMETER :: one = 1.0_DFP + + nrow = test%nns + ncol = trial%nns + + CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii) + + IF (opt .EQ. 1) THEN + m4_1 = 0.0_DFP + DO ips = 1, trial%nips + DO ii = 1, trial%nsd + CALL OuterProd_(a=trial%dNdXt(1:nrow, ii, ips), & + b=test%N(1:ncol, ips), & + nrow=jj, ncol=kk, ans=m4_1(1:nrow, 1:ncol, ii, 1), & + scale=realval(ips), anscoeff=one) + END DO + END DO + CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol) + ELSE + m4_2 = 0.0_DFP + DO ips = 1, trial%nips + DO ii = 1, trial%nsd + CALL OuterProd_(a=trial%dNdXt(1:nrow, ii, ips), & + b=test%N(1:ncol, ips), & + nrow=jj, ncol=kk, ans=m4_2(1:nrow, 1:ncol, 1, ii), & + scale=realval(ips), anscoeff=one) + END DO + END DO + CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol) + END IF + +END SUBROUTINE CM6_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM7_(ans, test, trial, term1, term2, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj + REAL(DFP) :: realval + REAL(DFP), PARAMETER :: one = 1.0_DFP + + nrow = test%nns + ncol = trial%nns + ans(1:nrow, 1:ncol) = 0.0_DFP + + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%dNdXt(1:ncol, term2, ips), & + nrow=ii, ncol=jj, ans=ans, & + scale=realval, anscoeff=one) + END DO + + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol + END IF + +END SUBROUTINE CM7_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM8_(ans, test, trial, term1, term2, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj + REAL(DFP) :: realval + REAL(DFP), PARAMETER :: one = 1.0_DFP + + nrow = test%nns + ncol = trial%nns + ans(1:nrow, 1:ncol) = 0.0_DFP + + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + CALL OuterProd_(a=test%dNdXt(1:nrow, term1, ips), & + b=trial%N(1:ncol, ips), & + nrow=ii, ncol=jj, ans=ans, & + scale=realval, anscoeff=one) + END DO + + IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol + END IF + +END SUBROUTINE CM8_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM9_(ans, test, trial, term1, term2, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj, kk + REAL(DFP), PARAMETER :: one = 1.0_DFP + REAL(DFP) :: realval + REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1) + REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd) + + nrow = test%nns + ncol = trial%nns + IF (opt .EQ. 1) THEN + m4_1 = 0.0_DFP + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + DO ii = 1, trial%nsd + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%dNdXt(1:ncol, ii, ips), & + nrow=jj, ncol=kk, ans=m4_1(1:nrow, 1:ncol, ii, 1), & + scale=realval, anscoeff=one) + END DO + END DO + CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol) + ELSE + m4_2 = 0.0_DFP + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + DO ii = 1, trial%nsd + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%dNdXt(1:ncol, ii, ips), & + nrow=jj, ncol=kk, ans=m4_2(1:nrow, 1:ncol, 1, ii), & + scale=realval, anscoeff=one) + END DO + END DO + CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol) + END IF + +END SUBROUTINE CM9_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CM10_(ans, test, trial, term1, term2, opt, nrow, ncol) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + INTEGER(I4B), INTENT(IN) :: term1 + INTEGER(I4B), INTENT(IN) :: term2 + INTEGER(I4B), INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B) :: ips, ii, jj, kk + REAL(DFP), PARAMETER :: one = 1.0_DFP + REAL(DFP) :: realval + REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1) + REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd) + + nrow = test%nns + ncol = trial%nns + IF (opt .EQ. 1) THEN + m4_1 = 0.0_DFP + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + DO ii = 1, trial%nsd + CALL OuterProd_(a=test%dNdXt(1:nrow, ii, ips), & + b=trial%N(1:ncol, ips), & + nrow=jj, ncol=kk, ans=m4_1(1:nrow, 1:ncol, ii, 1), & + scale=realval, anscoeff=one) + END DO + END DO + CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol) + ELSE + m4_2 = 0.0_DFP + DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + DO ii = 1, trial%nsd + CALL OuterProd_(a=test%dNdXt(1:nrow, ii, ips), & + b=trial%N(1:ncol, ips), & + nrow=jj, ncol=kk, ans=m4_2(1:nrow, 1:ncol, 1, ii), & + scale=realval, anscoeff=one) + END DO + END DO + CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol) + END IF + +END SUBROUTINE CM10_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index 3d2684690..2ec17697f 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -167,6 +167,22 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE OuterProd_r1r2_ +INTEGER(I4B) :: ii +dim1 = SIZE(a) +dim2 = SIZE(b, 1) +dim3 = SIZE(b, 2) +DO ii = 1, dim3 + CALL OuterProd_(a=a, b=b(1:dim2, ii), ans=ans(1:dim1, 1:dim2, ii), & + anscoeff=anscoeff, scale=scale, & + nrow=dim1, ncol=dim2) +END DO +END PROCEDURE OuterProd_r1r2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE OuterProd_r1r3 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 3) From 366d028dc1fda83c0b9bd48a15ef5762792870ba Mon Sep 17 00:00:00 2001 From: shion Date: Wed, 5 Mar 2025 19:55:33 +0900 Subject: [PATCH 347/359] Updates in StiffnessMatrix - adding subroutines in which no allocation happens --- .../src/StiffnessMatrix_Method.F90 | 76 +++++ .../src/StiffnessMatrix_Method@Methods.F90 | 305 ++++++++++++++++++ 2 files changed, 381 insertions(+) diff --git a/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 b/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 index 2f9b0479a..67bf4f160 100644 --- a/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 +++ b/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 @@ -26,6 +26,7 @@ MODULE StiffnessMatrix_Method PRIVATE PUBLIC :: StiffnessMatrix +PUBLIC :: StiffnessMatrix_ !---------------------------------------------------------------------------- ! StiffnessMatrix@StiffnessMatrixMethods @@ -40,6 +41,23 @@ MODULE PURE FUNCTION obj_StiffnessMatrix1(test, trial, Cijkl) & END FUNCTION obj_StiffnessMatrix1 END INTERFACE StiffnessMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-02-28 +! summary: subroutine to calculate stiffness matrix + +INTERFACE StiffnessMatrix_ + MODULE PURE SUBROUTINE obj_StiffnessMatrix1_(test, trial, Cijkl, nrow,ncol, ans) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + CLASS(FEVariable_), INTENT(IN) :: Cijkl + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(INOUT) :: ans(:, :) + END SUBROUTINE obj_StiffnessMatrix1_ +END INTERFACE StiffnessMatrix_ + !---------------------------------------------------------------------------- ! StiffnessMatrix@StiffnessMatrixMethods !---------------------------------------------------------------------------- @@ -57,6 +75,21 @@ MODULE PURE FUNCTION obj_StiffnessMatrix2(test, trial, lambda, mu, & END FUNCTION obj_StiffnessMatrix2 END INTERFACE StiffnessMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix_ + MODULE PURE SUBROUTINE obj_StiffnessMatrix2_(test, trial, lambda, mu, & + isLambdaYoungsModulus, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + CLASS(FEVariable_), INTENT(IN) :: lambda, mu + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isLambdaYoungsModulus + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_StiffnessMatrix2_ +END INTERFACE StiffnessMatrix_ + !---------------------------------------------------------------------------- ! StiffnessMatrix@StiffnessMatrixMethods !---------------------------------------------------------------------------- @@ -70,6 +103,20 @@ MODULE PURE FUNCTION obj_StiffnessMatrix3(test, trial, lambda, & END FUNCTION obj_StiffnessMatrix3 END INTERFACE StiffnessMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix_ + MODULE PURE SUBROUTINE obj_StiffnessMatrix3_(test, trial, lambda, & + mu, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: lambda, mu + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_StiffnessMatrix3_ +END INTERFACE StiffnessMatrix_ + !---------------------------------------------------------------------------- ! StiffnessMatrix@StiffnessMatrixMethods !---------------------------------------------------------------------------- @@ -83,6 +130,20 @@ MODULE PURE FUNCTION obj_StiffnessMatrix4(test, trial, Cijkl) & END FUNCTION obj_StiffnessMatrix4 END INTERFACE StiffnessMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE StiffnessMatrix_ + MODULE PURE SUBROUTINE obj_StiffnessMatrix4_(test, trial, Cijkl, ans, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: Cijkl(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_StiffnessMatrix4_ +END INTERFACE StiffnessMatrix_ + !---------------------------------------------------------------------------- ! StiffnessMatrix@StiffnessMatrixMethods !---------------------------------------------------------------------------- @@ -101,4 +162,19 @@ END FUNCTION obj_StiffnessMatrix5 ! !---------------------------------------------------------------------------- +INTERFACE StiffnessMatrix_ + MODULE PURE SUBROUTINE obj_StiffnessMatrix5_(test, trial, lambda, mu, & + ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test, trial + REAL(DFP), INTENT(IN) :: lambda(:) + REAL(DFP), INTENT(IN) :: mu(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_StiffnessMatrix5_ +END INTERFACE StiffnessMatrix_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE StiffnessMatrix_Method diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 index 11e983a30..e2ae890d6 100644 --- a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 +++ b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 @@ -83,6 +83,66 @@ END PROCEDURE obj_StiffnessMatrix1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix1_ +REAL(DFP) :: Cbar(test%nsd, trial%nsd, trial%nips), & + Ce(test%nsd * test%nsd, trial%nsd * trial%nsd), & + BMat1(test%nsd * test%nns, trial%nsd * trial%nsd), & + BMat2(trial%nsd * trial%nns, trial%nsd * trial%nsd) +INTEGER(I4B) :: nips, nns1, nns2, ips, nsd, ii, jj, kk +INTEGER(I4B) :: indx(3, 3) +REAL(DFP) :: realval + +nns1 = test%nns +nns2 = trial%nns +nips = trial%nips +nsd = trial%nsd +nrow = nns1 * nsd +ncol = nns2 * nsd +ans(1:nrow, 1:ncol) = 0.0 + +CALL GetInterpolation_(obj=test, interpol=CBar, val=Cijkl, & + dim1=ii, dim2=jj, dim3=kk) + +SELECT CASE (nsd) +CASE (1) + indx(1, 1) = 1 +CASE (2) + indx(1:2, 1:2) = RESHAPE([1, 3, 3, 2], [2, 2]) +CASE (3) + indx(1:3, 1:3) = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3]) +END SELECT + +BMat1 = 0.0_DFP +BMat2 = 0.0_DFP + +DO ips = 1, nips + realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips) + + DO jj = 1, nsd + DO ii = 1, nsd + Ce((ii - 1) * nsd + 1:ii * nsd, (jj - 1) * nsd + 1:jj * nsd) & + & = CBar(indx(1:nsd, ii), indx(1:nsd, jj), ips) + END DO + END DO + + DO ii = 1, nsd + BMat1((ii - 1) * nns1 + 1:ii * nns1, (ii - 1) * nsd + 1:ii * nsd) = & + & test%dNdXt(1:nns1, 1:nsd, ips) + BMat2((ii - 1) * nns2 + 1:ii * nns2, (ii - 1) * nsd + 1:ii * nsd) = & + & trial%dNdXt(1:nns2, 1:nsd, ips) + END DO + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2)) + +END DO + +END PROCEDURE obj_StiffnessMatrix1_ + !---------------------------------------------------------------------------- ! StiffnessMatrix !---------------------------------------------------------------------------- @@ -163,6 +223,83 @@ END PROCEDURE obj_StiffnessMatrix2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix2_ +REAL(DFP) :: lambdaBar(trial%nips), muBar(trial%nips), & + Ke11(test%nns, trial%nns) +REAL(DFP) :: realval +REAL(DFP) :: real1, real2, real3 +INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, ii, jj, & + r1, r2, ips, kk, ll +LOGICAL(LGT) :: abool +TYPE(FEVariable_) :: lambda0 +REAL(DFP), PARAMETER :: one = 1.0_DFP, zero = 0.0_DFP + +abool = Input(default=.FALSE., option=isLambdaYoungsModulus) +IF (abool) THEN + CALL GetLambdaFromYoungsModulus(lambda=lambda0, & + & youngsModulus=lambda, shearModulus=mu) +ELSE + lambda0 = lambda +END IF + +nns1 = test%nns +nns2 = trial%nns +nips = trial%nips +nsd = trial%nsd +nrow = nns1 * nsd +ncol = nns2 * nsd +ans(1:nrow, 1:ncol) = zero + +CALL GetInterpolation_(obj=test, interpol=lambdaBar, val=lambda0, tsize=ii) +CALL GetInterpolation_(obj=test, interpol=muBar, val=mu, tsize=ii) + +DO ips = 1, nips + + realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips) + real1 = muBar(ips) * realval + real2 = (lambdaBar(ips) + muBar(ips)) * realval + real3 = lambdaBar(ips) * realval + c1 = 0 + c2 = 0 + + DO jj = 1, nsd + c1 = c2 + 1 + c2 = jj * nns2 + r1 = 0 + r2 = 0 + DO ii = 1, nsd + r1 = r2 + 1 + r2 = ii * nns1 + IF (ii .EQ. jj) THEN + Ke11(1:nns1, 1:nns2) = real1 * MATMUL(test%dNdXt(:, :, ips), & + & TRANSPOSE(trial%dNdXt(:, :, ips))) + CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), & + b=trial%dNdXt(1:nns2, ii, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real2, anscoeff=one) + ELSE + CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), & + b=trial%dNdXt(1:nns2, jj, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real3, anscoeff=zero) + CALL OuterProd_(a=test%dNdXt(1:nns1, jj, ips), & + b=trial%dNdXt(1:nns2, ii, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real1, anscoeff=one) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11 + END DO + END DO +END DO + +CALL DEALLOCATE (lambda0) + +END PROCEDURE obj_StiffnessMatrix2_ + !---------------------------------------------------------------------------- ! Stiffnessmatrix !---------------------------------------------------------------------------- @@ -213,6 +350,59 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE obj_StiffnessMatrix3_ +INTEGER(I4B) :: nns1, nns2, nips, ips, nsd, c1, c2, & + r1, r2, ii, jj, kk, ll +REAL(DFP) :: realval, Ke11(test%nns, trial%nns) +REAL(DFP) :: real1, real2, real3 +REAL(DFP), PARAMETER :: one = 1.0_DFP, zero = 0.0_DFP + +nns1 = test%nns +nns2 = trial%nns +nips = trial%nips +nsd = trial%nsd +nrow = nns1 * nsd +ncol = nns2 * nsd +ans(1:nrow, 1:ncol) = zero + +DO ips = 1, nips + realval = trial%ws(ips) * trial%thickness(ips) * trial%js(ips) + real1 = mu * realval + real2 = (lambda + mu) * realval + real3 = lambda * realval + c1 = 0; c2 = 0; + DO jj = 1, nsd + c1 = c2 + 1; c2 = jj * nns2; r1 = 0; r2 = 0 + DO ii = 1, nsd + r1 = r2 + 1; r2 = ii * nns1 + IF (ii .EQ. jj) THEN + Ke11 = real1 * MATMUL(test%dNdXt(:, :, ips), & + TRANSPOSE(trial%dNdXt(:, :, ips))) + CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), & + b=trial%dNdXt(1:nns2, ii, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real2, anscoeff=one) + ELSE + CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), & + b=trial%dNdXt(1:nns2, jj, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real3, anscoeff=zero) + CALL OuterProd_(a=test%dNdXt(1:nns1, jj, ips), & + b=trial%dNdXt(1:nns2, ii, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real1, anscoeff=one) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11(1:nns1, 1:nns2) + END DO + END DO +END DO + +END PROCEDURE obj_StiffnessMatrix3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE obj_StiffnessMatrix4 REAL(DFP), ALLOCATABLE :: realval(:), Ce(:, :), BMat1(:, :), BMat2(:, :) INTEGER(I4B) :: nips, nns1, nns2, i, j, ips, nsd @@ -271,6 +461,62 @@ END PROCEDURE obj_StiffnessMatrix4 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_StiffnessMatrix4_ +REAL(DFP) :: realval +REAL(DFP) :: Ce(test%nsd * test%nsd, trial%nsd * trial%nsd), & + BMat1(test%nsd * test%nns, test%nsd * test%nsd), & + BMat2(trial%nsd * trial%nns, trial%nsd * trial%nsd) +INTEGER(I4B) :: nips, nns1, nns2, ii, jj, ips, nsd +INTEGER(I4B), ALLOCATABLE :: indx(:, :) + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = SIZE(trial%dNdXt, 2) + +nrow = nns1 * nsd +ncol = nns2 * nsd + +SELECT CASE (nsd) +CASE (1) + indx(1, 1) = 1 +CASE (2) + indx(1:2, 1:2) = RESHAPE([1, 3, 3, 2], [2, 2]) +CASE (3) + indx(1:3, 1:3) = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3]) +END SELECT + +BMat1 = 0.0_DFP +BMat2 = 0.0_DFP + +DO ips = 1, nips + + realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips) + DO jj = 1, nsd + DO ii = 1, nsd + Ce((ii - 1) * nsd + 1:ii * nsd, (jj - 1) * nsd + 1:jj * nsd) & + & = Cijkl(indx(1:nsd, ii), indx(1:nsd, jj)) + END DO + END DO + + DO ii = 1, nsd + BMat1((ii - 1) * nns1 + 1:ii * nns1, (ii - 1) * nsd + 1:ii * nsd) = & + & test%dNdXt(:, :, ips) + BMat2((ii - 1) * nns2 + 1:ii * nns2, (ii - 1) * nsd + 1:ii * nsd) = & + & trial%dNdXt(:, :, ips) + END DO + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2)) + +END DO + +END PROCEDURE obj_StiffnessMatrix4_ + !---------------------------------------------------------------------------- ! StiffnessMatrix !---------------------------------------------------------------------------- @@ -335,4 +581,63 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE obj_StiffnessMatrix5_ +REAL(DFP) :: realval, Ke11(test%nns, trial%nns) +REAL(DFP) :: real1, real2, real3 +INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, ii, jj, & + r1, r2, ips, kk, ll +REAL(DFP), PARAMETER :: one = 1.0_DFP, zero = 0.0_DFP + +nns1 = SIZE(test%N, 1) +nns2 = SIZE(trial%N, 1) +nips = SIZE(trial%N, 2) +nsd = SIZE(trial%dNdXt, 2) +nrow = nns1 * nsd +ncol = nns2 * nsd +ans(1:nrow, 1:ncol) = zero + +DO ips = 1, nips + realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips) + real1 = mu(ips) * realval + real2 = (lambda(ips) + mu(ips)) * realval + real3 = lambda(ips) * realval + c1 = 0 + c2 = 0 + DO jj = 1, nsd + c1 = c2 + 1 + c2 = jj * nns2 + r1 = 0 + r2 = 0 + DO ii = 1, nsd + r1 = r2 + 1 + r2 = ii * nns1 + IF (ii .EQ. jj) THEN + Ke11 = real1 * MATMUL( & + test%dNdXt(:, :, ips), & + TRANSPOSE(trial%dNdXt(:, :, ips))) + CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), & + b=trial%dNdXt(1:nns2, ii, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real2, anscoeff=one) + ELSE + CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), & + b=trial%dNdXt(1:nns2, jj, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real3, anscoeff=zero) + CALL OuterProd_(a=test%dNdXt(1:nns1, jj, ips), & + b=trial%dNdXt(1:nns2, ii, ips), & + nrow=kk, ncol=ll, ans=Ke11, & + scale=real1, anscoeff=one) + END IF + ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11(1:nns1, 1:nns2) + END DO + END DO +END DO + +END PROCEDURE obj_StiffnessMatrix5_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE Methods From 4d11aa8400249ec8d78b204c8381460c9ff6bc3e Mon Sep 17 00:00:00 2001 From: shion Date: Wed, 5 Mar 2025 19:56:35 +0900 Subject: [PATCH 348/359] Updates in MassMatrix - adding subroutines in which no allocation happens --- .../MassMatrix/src/MassMatrix_Method.F90 | 74 ++++++++++++++++++ .../src/MassMatrix_Method@Methods.F90 | 77 +++++++++++++++++++ 2 files changed, 151 insertions(+) diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 index c2b6ab317..7b7eeafa6 100644 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -26,6 +26,7 @@ MODULE MassMatrix_Method PRIVATE PUBLIC :: MassMatrix +PUBLIC :: MassMatrix_ PUBLIC :: ViscousBoundaryMassMatrix !---------------------------------------------------------------------------- @@ -56,6 +57,20 @@ MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans) END FUNCTION MassMatrix_1 END INTERFACE MassMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE MassMatrix_ + MODULE PURE SUBROUTINE MassMatrix1_(test, trial, ans, nrow, ncol, opt) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + END SUBROUTINE MassMatrix1_ +END INTERFACE MassMatrix_ + !---------------------------------------------------------------------------- ! MassMatrix@MassMatrixMethods !---------------------------------------------------------------------------- @@ -80,6 +95,23 @@ MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) & END FUNCTION MassMatrix_2 END INTERFACE MassMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE MassMatrix_ + MODULE PURE SUBROUTINE MassMatrix2_(test, trial, rho, rhorank, & + ans, nrow, ncol, opt) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: rho + TYPE(FEVariableScalar_), INTENT(IN) :: rhorank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + END SUBROUTINE MassMatrix2_ +END INTERFACE MassMatrix_ + !---------------------------------------------------------------------------- ! MassMatrix@MassMatrixMethods !---------------------------------------------------------------------------- @@ -104,6 +136,27 @@ MODULE PURE FUNCTION MassMatrix_3(test, trial, rho, rhorank, opt) & END FUNCTION MassMatrix_3 END INTERFACE MassMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-02 +! summary: mass matrix in space +! notice: not implemented yet + +INTERFACE MassMatrix_ + MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, & + opt, nrow, ncol, ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: rho + INTEGER(I4B), INTENT(IN) :: opt + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(INOUT) :: ans(:, :) + END SUBROUTINE MassMatrix3_ +END INTERFACE MassMatrix_ + !---------------------------------------------------------------------------- ! MassMatrix@MassMatrixMethods !---------------------------------------------------------------------------- @@ -126,6 +179,27 @@ MODULE PURE FUNCTION MassMatrix_4(test, trial, rho, rhorank) & END FUNCTION MassMatrix_4 END INTERFACE MassMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-02 +! summary: mass matrix in space +! notice: not implemented yet + +INTERFACE MassMatrix_ + MODULE PURE SUBROUTINE MassMatrix4_(test, trial, rho, rhorank, & + nrow, ncol, ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: rho + TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(INOUT) :: ans(:, :) + END SUBROUTINE MassMatrix4_ +END INTERFACE MassMatrix_ + !---------------------------------------------------------------------------- ! MassMatrix@MassMatrixMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 2a8aaef11..009ca1ada 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -196,6 +196,36 @@ END SUBROUTINE MM_2d DEALLOCATE (realval) END PROCEDURE MassMatrix_1 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Massmatrix1_ +REAL(DFP), PARAMETER :: one = 1.0_DFP +REAL(DFP) :: realval +INTEGER(I4B) :: ii, jj, ips + +nrow = test%nns +ncol = trial%nns +ans(1:nrow, 1:ncol) = 0.0 + +DO ips = 1, trial%nips + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%N(1:ncol, ips), & + nrow=ii, ncol=jj, ans=ans, scale=realval, anscoeff=one) + +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF + +END PROCEDURE Massmatrix1_ + !---------------------------------------------------------------------------- ! MassMatrix !---------------------------------------------------------------------------- @@ -218,6 +248,37 @@ END SUBROUTINE MM_2d DEALLOCATE (realval) END PROCEDURE MassMatrix_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix2_ +REAL(DFP) :: realval(trial%nips) +REAL(DFP), PARAMETER :: one = 1.0_DFP +INTEGER(I4B) :: ips, ii, jj + +nrow = test%nns +ncol = trial%nns +realval = 0.0_DFP +CALL GetInterpolation_(obj=trial, interpol=realval, & + val=rho, tsize=ii) +realval = trial%js * trial%ws * trial%thickness * realval + +DO ips = 1, SIZE(realval) + CALL OuterProd_(a=test%N(1:nrow, ips), & + b=trial%N(1:ncol, ips), & + nrow=ii, ncol=jj, ans=ans, scale=realval(ips), & + anscoeff=one) +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF + +END PROCEDURE MassMatrix2_ + !---------------------------------------------------------------------------- ! MassMatrix !---------------------------------------------------------------------------- @@ -235,6 +296,14 @@ END SUBROUTINE MM_2d END SELECT END PROCEDURE MassMatrix_3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE massmatrix3_ +! TODO: implement +END PROCEDURE massmatrix3_ + !---------------------------------------------------------------------------- ! MassMatrix !---------------------------------------------------------------------------- @@ -267,6 +336,14 @@ END SUBROUTINE MM_2d DEALLOCATE (realval, m2, kbar, m4) END PROCEDURE MassMatrix_4 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix4_ +! TODO: implement +END PROCEDURE MassMatrix4_ + !---------------------------------------------------------------------------- ! MassMatrix !---------------------------------------------------------------------------- From 8248c460b24a5ad54b616b5fe66aa4e7ff15c35e Mon Sep 17 00:00:00 2001 From: shion Date: Thu, 6 Mar 2025 11:50:23 +0900 Subject: [PATCH 349/359] Updates in Diffusion matrix - adding subroutines in which allocation is minimized --- .../src/DiffusionMatrix_Method.F90 | 89 ++++++++++ .../src/DiffusionMatrix_Method@Methods.F90 | 154 ++++++++++++++++++ 2 files changed, 243 insertions(+) diff --git a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 index 9347beac4..899f090fd 100644 --- a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 +++ b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 @@ -118,6 +118,23 @@ MODULE PURE FUNCTION DiffusionMatrix_2(test, trial, k, krank, opt) & END FUNCTION DiffusionMatrix_2 END INTERFACE DiffusionMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DiffusionMatrix_ + MODULE PURE SUBROUTINE DiffusionMatrix2_(test, trial, k, krank, opt, & + ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableScalar_), INTENT(IN) :: krank + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE DiffusionMatrix2_ +END INTERFACE DiffusionMatrix_ + !---------------------------------------------------------------------------- ! DiffusionMatrix@DiffusionMatrixMethods !---------------------------------------------------------------------------- @@ -149,6 +166,23 @@ MODULE PURE FUNCTION DiffusionMatrix_3(test, trial, k, krank, opt) & END FUNCTION DiffusionMatrix_3 END INTERFACE DiffusionMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DiffusionMatrix_ + MODULE PURE SUBROUTINE DiffusionMatrix3_(test, trial, k, krank, opt, & + ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableVector_), INTENT(IN) :: krank + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE DiffusionMatrix3_ +END INTERFACE DiffusionMatrix_ + !---------------------------------------------------------------------------- ! DiffusionMatrix@DiffusionMatrixMethods !---------------------------------------------------------------------------- @@ -181,6 +215,23 @@ MODULE PURE FUNCTION DiffusionMatrix_4(test, trial, k, krank, opt) & END FUNCTION DiffusionMatrix_4 END INTERFACE DiffusionMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DiffusionMatrix_ + MODULE PURE SUBROUTINE DiffusionMatrix4_(test, trial, k, krank, opt, & + ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: k + TYPE(FEVariableMatrix_), INTENT(IN) :: krank + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE DiffusionMatrix4_ +END INTERFACE DiffusionMatrix_ + !---------------------------------------------------------------------------- ! DiffusionMatrix@DiffusionMatrixMethods !---------------------------------------------------------------------------- @@ -217,6 +268,25 @@ MODULE PURE FUNCTION DiffusionMatrix_5(test, trial, c1, c2, c1rank, & END FUNCTION DiffusionMatrix_5 END INTERFACE DiffusionMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DiffusionMatrix_ + MODULE PURE SUBROUTINE DiffusionMatrix5_(test, trial, c1, c2, c1rank, & + c2rank, opt, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE DiffusionMatrix5_ +END INTERFACE DiffusionMatrix_ + !---------------------------------------------------------------------------- ! DiffusionMatrix@DiffusionMatrixMethods !---------------------------------------------------------------------------- @@ -253,6 +323,25 @@ MODULE PURE FUNCTION DiffusionMatrix_6(test, trial, c1, c2, c1rank, & END FUNCTION DiffusionMatrix_6 END INTERFACE DiffusionMatrix +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE DiffusionMatrix_ + MODULE PURE SUBROUTINE DiffusionMatrix6_(test, trial, c1, c2, c1rank, & + c2rank, opt, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + CLASS(ElemshapeData_), INTENT(IN) :: trial + CLASS(FEVariable_), INTENT(IN) :: c1 + CLASS(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE DiffusionMatrix6_ +END INTERFACE DiffusionMatrix_ + !---------------------------------------------------------------------------- ! DiffusionMatrix@DiffusionMatrixMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 index 346b4b480..358c371d7 100644 --- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 @@ -88,6 +88,34 @@ DEALLOCATE (kbar, realval) END PROCEDURE DiffusionMatrix_2 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix2_ +REAL(DFP) :: realval, kbar(trial%nips) +INTEGER(I4B) :: ii + +CALL GetInterpolation_(obj=trial, Interpol=kbar, val=k, tsize=ii) +nrow = test%nns +ncol = trial%nns +ans(1:nrow, 1:ncol) = 0.0 + +DO ii = 1, trial%nips + realval = trial%js(ii) * trial%ws(ii) * trial%thickness(ii) * kbar(ii) + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * MATMUL(test%dNdXt(:, :, ii), & + TRANSPOSE(trial%dNdXt(:, :, ii))) +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF + +END PROCEDURE DiffusionMatrix2_ + !---------------------------------------------------------------------------- ! DiffusionMatrix !---------------------------------------------------------------------------- @@ -106,6 +134,35 @@ DEALLOCATE (c1bar, c2bar, realval) END PROCEDURE DiffusionMatrix_3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix3_ +REAL(DFP) :: c1bar(test%nns, test%nips), c2bar(trial%nns, trial%nips) +REAL(DFP) :: realval +INTEGER(I4B) :: ii, jj, kk +REAL(DFP), PARAMETER :: one = 1.0_DFP + +CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=k, nrow=nrow, ncol=ii) +CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=k, nrow=ncol, ncol=ii) + +ans(1:nrow, 1:ncol) = 0.0 + +DO ii = 1, trial%nips + realval = trial%js(ii) * trial%ws(ii) * trial%thickness(ii) + CALL OuterProd_(a=c1bar(1:nrow, ii), b=c2bar(1:ncol, ii), & + nrow=jj, ncol=kk, ans=ans, & + scale=realval, anscoeff=one) +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF +END PROCEDURE DiffusionMatrix3_ + !---------------------------------------------------------------------------- ! DiffusionMatrix !---------------------------------------------------------------------------- @@ -127,6 +184,37 @@ DEALLOCATE (kbar, realval) END PROCEDURE DiffusionMatrix_4 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix4_ +REAL(DFP) :: kbar(test%nsd, test%nsd, trial%nips) +REAL(DFP) :: realval +REAL(DFP), PARAMETER :: one = 1.0_DFP +INTEGER(I4B) :: ii, jj, kk + +CALL getInterpolation_(obj=trial, Interpol=kbar, val=k, & + dim1=ii, dim2=jj, dim3=kk) +nrow = test%nns +ncol = trial%nns +ans(1:nrow, 1:ncol) = 0.0 + +DO ii = 1, trial%nips + realval = trial%js(ii) * trial%ws(ii) * trial%thickness(ii) + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * MATMUL(MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), & + TRANSPOSE(trial%dNdXt(:, :, ii))) +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF + +END PROCEDURE DiffusionMatrix4_ + !---------------------------------------------------------------------------- ! DiffusionMatrix !---------------------------------------------------------------------------- @@ -146,6 +234,36 @@ DEALLOCATE (cbar, realval) END PROCEDURE DiffusionMatrix_5 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix5_ +REAL(DFP) :: realval(trial%nips), cbar(trial%nips) +INTEGER(I4B) :: ii + +CALL getInterpolation_(obj=trial, Interpol=cbar, val=c1, tsize=ii) +CALL getInterpolation_(obj=trial, Interpol=realval, val=c2, tsize=ii) +realval = realval * trial%js * trial%ws * trial%thickness * cbar + +nrow = test%nns +ncol = trial%nns +ans(1:nrow, 1:ncol) = 0.0 + +DO ii = 1, trial%nips + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval(ii) * MATMUL(test%dNdXt(:, :, ii), & + TRANSPOSE(trial%dNdXt(:, :, ii))) +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF + +END PROCEDURE DiffusionMatrix5_ + !---------------------------------------------------------------------------- ! DiffusionMatrix !---------------------------------------------------------------------------- @@ -165,6 +283,42 @@ DEALLOCATE (c1bar, c2bar, realval) END PROCEDURE DiffusionMatrix_6 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DiffusionMatrix6_ +REAL(DFP) :: c1bar(test%nns, test%nips), c2bar(trial%nns, trial%nips), & + realval(trial%nips) +INTEGER(I4B) :: ii, jj, kk +REAL(DFP), PARAMETER :: one = 1.0_DFP + +CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=c2, & + nrow=nrow, ncol=ii) +CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=c2, & + nrow=ncol, ncol=ii) + +CALL getInterpolation_(obj=trial, interpol=realval, val=c1, & + tsize=ii) + +realval = realval * trial%js * trial%ws * trial%thickness + +ans(1:nrow, 1:ncol) = 0.0 + +DO ii = 1, trial%nips + CALL OuterProd_(a=c1bar(1:nrow, ii), b=c2bar(1:ncol, ii), & + nrow=jj, ncol=kk, ans=ans, & + scale=realval(ii), anscoeff=one) +END DO + +IF (PRESENT(opt)) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) + nrow = opt * nrow + ncol = opt * ncol +END IF + +END PROCEDURE DiffusionMatrix6_ + !---------------------------------------------------------------------------- ! DiffusionMatrix !---------------------------------------------------------------------------- From c246dde24a7f945fc3438e1880f596b82a520790 Mon Sep 17 00:00:00 2001 From: shion Date: Thu, 6 Mar 2025 12:17:33 +0900 Subject: [PATCH 350/359] Updates in Stiffness matrix - fixing the mistake --- .../StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 index e2ae890d6..65c2c2283 100644 --- a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 +++ b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 @@ -88,7 +88,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_StiffnessMatrix1_ -REAL(DFP) :: Cbar(test%nsd, trial%nsd, trial%nips), & +REAL(DFP) :: Cbar(test%nsd * (test%nsd + 1) / 2, & + trial%nsd * (trial%nsd + 1) / 2, & + trial%nips), & Ce(test%nsd * test%nsd, trial%nsd * trial%nsd), & BMat1(test%nsd * test%nns, trial%nsd * trial%nsd), & BMat2(trial%nsd * trial%nns, trial%nsd * trial%nsd) From 3e2b2165adb49a0b578680f7882d42ce31a02633 Mon Sep 17 00:00:00 2001 From: shion Date: Tue, 29 Apr 2025 19:05:23 +0900 Subject: [PATCH 351/359] Updates in LineInterpolationUtility - fixing minor bug --- .../Polynomial/src/LineInterpolationUtility@Methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 585bee1dd..32f34c324 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -1542,7 +1542,7 @@ END SUBROUTINE handle_error END IF IF (PRESENT(xij)) THEN - CALL FromBiunitLine2Segment_(xin=ans(1, 1:nrow), x1=xij(:, 1), & + 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 From 551e1f16b81a13fc44872b8bbea8e3973d5ecf51 Mon Sep 17 00:00:00 2001 From: easifem Date: Mon, 20 Jan 2025 12:38:34 +0900 Subject: [PATCH 352/359] update in cmake --- CMakeLists.txt | 2 + cmake/Config.cmake.in | 117 ++++++++++++++++++++---------------------- cmake/addGmsh.cmake | 32 ++++++++++++ cmake/addHDF5.cmake | 33 ++++++++++++ cmake/addLIS.cmake | 1 - cmake/addToml.cmake | 2 +- 6 files changed, 124 insertions(+), 63 deletions(-) create mode 100644 cmake/addGmsh.cmake create mode 100644 cmake/addHDF5.cmake diff --git a/CMakeLists.txt b/CMakeLists.txt index f6a2809f7..9a2e44281 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -314,6 +314,8 @@ include(${PROJECT_SOURCE_DIR}/cmake/addPLPLOT.cmake) include(${PROJECT_SOURCE_DIR}/cmake/addFFTW.cmake) include(${PROJECT_SOURCE_DIR}/cmake/addGTKFortran.cmake) include(${PROJECT_SOURCE_DIR}/cmake/addLua.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addGmsh.cmake) +include(${PROJECT_SOURCE_DIR}/cmake/addHDF5.cmake) # Add source files include(src/modules/CMakeLists.txt) diff --git a/cmake/Config.cmake.in b/cmake/Config.cmake.in index 3758fb80e..73153f1db 100644 --- a/cmake/Config.cmake.in +++ b/cmake/Config.cmake.in @@ -1,75 +1,70 @@ @PACKAGE_INIT@ -LIST( - APPEND - ExternalLibs - Sparsekit - toml-f -) +list(APPEND ExternalLibs Sparsekit toml-f) -IF( @USE_LAPACK95@ ) - LIST(APPEND - ExternalLibs - LAPACK95 - ) -ENDIF() +if(@USE_LAPACK95@) + list(APPEND ExternalLibs LAPACK95) +endif() -IF( @USE_ARPACK@ ) - LIST(APPEND - ExternalLibs - arpackng - ) -ENDIF() +if(@USE_ARPACK@) + list(APPEND ExternalLibs arpackng) +endif() -IF( @USE_RAYLIB@ ) - LIST(APPEND - ExternalLibs - raylib - ) -ENDIF() +if(@USE_RAYLIB@) + list(APPEND ExternalLibs raylib) +endif() -FOREACH(LIB ${ExternalLibs}) - FIND_PACKAGE(${LIB} REQUIRED) -ENDFOREACH() +foreach(LIB ${ExternalLibs}) + find_package(${LIB} REQUIRED) +endforeach() -IF( @USE_OPENMP@ ) - IF(APPLE) - IF(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES "AppleClang") - SET(OpenMP_C "${CMAKE_C_COMPILER}" CACHE STRING "" FORCE) - SET(OpenMP_C_FLAGS - "-fopenmp=libomp -Wno-unused-command-line-argument" - CACHE STRING - "" - FORCE - ) - SET(OpenMP_C_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE) - SET(OpenMP_libomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) - SET(OpenMP_libgomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) - SET(OpenMP_libiomp5_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE) +if(@USE_GMSH_SDK@) + find_library(GMSH_LIBRARIES NAMES gmsh gmsh.4.13.0 gmsh.4.13 REQUIRED) +endif() - SET(OpenMP_CXX "${CMAKE_CXX_COMPILER}" CACHE STRING "" FORCE) - SET( - OpenMP_CXX_FLAGS - "-fopenmp=libomp -Wno-unused-command-line-argument" - CACHE STRING - "" - FORCE - ) +find_package(HDF5 REQUIRED COMPONENTS Fortran HL) - SET(OpenMP_CXX_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE) - ENDIF() - ENDIF() +if(@USE_OPENMP@) + if(APPLE) + if(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES + "AppleClang") + set(OpenMP_C + "${CMAKE_C_COMPILER}" + CACHE STRING "" FORCE) + set(OpenMP_C_FLAGS + "-fopenmp=libomp -Wno-unused-command-line-argument" + CACHE STRING "" FORCE) + set(OpenMP_C_LIB_NAMES + "libomp" "libgomp" "libiomp5" + CACHE STRING "" FORCE) + set(OpenMP_libomp_LIBRARY + ${OpenMP_C_LIB_NAMES} + CACHE STRING "" FORCE) + set(OpenMP_libgomp_LIBRARY + ${OpenMP_C_LIB_NAMES} + CACHE STRING "" FORCE) + set(OpenMP_libiomp5_LIBRARY + ${OpenMP_C_LIB_NAMES} + CACHE STRING "" FORCE) - FIND_PACKAGE(OpenMP REQUIRED) -ENDIF() + set(OpenMP_CXX + "${CMAKE_CXX_COMPILER}" + CACHE STRING "" FORCE) + set(OpenMP_CXX_FLAGS + "-fopenmp=libomp -Wno-unused-command-line-argument" + CACHE STRING "" FORCE) + set(OpenMP_CXX_LIB_NAMES + "libomp" "libgomp" "libiomp5" + CACHE STRING "" FORCE) + endif() + endif() -set_and_check( - "@PROJECT_NAME@_INCLUDE_DIR" "@PACKAGE_INSTALL_INCLUDEDIR@") + find_package(OpenMP REQUIRED) +endif() -include( - "${CMAKE_CURRENT_LIST_DIR}/@TARGETS_EXPORT_NAME@.cmake") +set_and_check("@PROJECT_NAME@_INCLUDE_DIR" "@PACKAGE_INSTALL_INCLUDEDIR@") -check_required_components( - "@PROJECT_NAME@" - ) +include("${CMAKE_CURRENT_LIST_DIR}/@TARGETS_EXPORT_NAME@.cmake") + +check_required_components("@PROJECT_NAME@") diff --git a/cmake/addGmsh.cmake b/cmake/addGmsh.cmake new file mode 100644 index 000000000..cda7ea718 --- /dev/null +++ b/cmake/addGmsh.cmake @@ -0,0 +1,32 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see + +option(USE_GMSH_SDK OFF) +if(USE_GMSH_SDK) + + message(STATUS "USING GMSH SDK") + list(APPEND TARGET_COMPILE_DEF "-DUSE_GMSH_SDK") + + find_library(GMSH_LIBRARIES NAMES gmsh gmsh.4.13.0 gmsh.4.13 REQUIRED) + + target_link_libraries(${PROJECT_NAME} PUBLIC ${GMSH_LIBRARIES}) + message(STATUS "GMSH_LIBRARIES : ${GMSH_LIBRARIES}") + +else() + + message(STATUS "NOT USING GMSH SDK") + +endif() diff --git a/cmake/addHDF5.cmake b/cmake/addHDF5.cmake new file mode 100644 index 000000000..1c04bec08 --- /dev/null +++ b/cmake/addHDF5.cmake @@ -0,0 +1,33 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +# SET(HDF5_NO_FIND_PACKAGE_CONFIG_FILE true CACHE BOOL "Set true to skip trying +# to find hdf5-config.cmake" FORCE) +find_package(HDF5 REQUIRED COMPONENTS Fortran HL) +if(HDF5_VERSION VERSION_LESS 1.8.7) + message(WARNING "HDF5 VERSION SHOULD BE >= 1.8.7") +endif() +if(HDF5_FOUND) + message(STATUS "HDF5 FOUND: ") + list(APPEND TARGET_COMPILE_DEF "-DUSE_HDF5") + list(APPEND TARGET_COMPILE_DEF "${HDF5_Fortran_DEFINITIONS}") + message(STATUS "HDF5 fortran lib :: ${HDF5_Fortran_LIBRARIES}") +else() + message(ERROR "HDF5 NOT FOUND") +endif() +target_link_libraries(${PROJECT_NAME} PUBLIC ${HDF5_Fortran_LIBRARIES}) +target_include_directories(${PROJECT_NAME} PUBLIC ${HDF5_Fortran_INCLUDE_DIRS}) diff --git a/cmake/addLIS.cmake b/cmake/addLIS.cmake index 9ad7dd5f9..fe6693c0d 100644 --- a/cmake/addLIS.cmake +++ b/cmake/addLIS.cmake @@ -14,7 +14,6 @@ # # You should have received a copy of the GNU General Public License along with # this program. If not, see -# option(USE_LIS OFF) if(USE_LIS) diff --git a/cmake/addToml.cmake b/cmake/addToml.cmake index 295bf1efd..76fc2eb77 100644 --- a/cmake/addToml.cmake +++ b/cmake/addToml.cmake @@ -18,7 +18,7 @@ find_package(toml-f REQUIRED) -if(Sparsekit_FOUND) +if(toml-f_FOUND) message(STATUS "[INFO] :: FOUND toml-f") target_link_libraries(${PROJECT_NAME} PUBLIC toml-f::toml-f) From 5cebac9ab3c0c3349e2801076b0eebf64a8888fe Mon Sep 17 00:00:00 2001 From: easifem Date: Mon, 20 Jan 2025 12:38:52 +0900 Subject: [PATCH 353/359] update in elemshapedata --- .../ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 index b545bf524..2e6816a8f 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 @@ -212,11 +212,19 @@ ELSE CALL Util_Display("jacobian: NOT ALLOCATED", unitno) END IF + IF (ALLOCATED(obj%js)) THEN CALL Util_Display(obj%js, "js: ", unitno) ELSE CALL Util_Display("js: NOT ALLOCATED", unitno) END IF + +IF (ALLOCATED(obj%ws)) THEN + CALL Util_Display(obj%ws, "ws: ", unitno) +ELSE + CALL Util_Display("ws: NOT ALLOCATED", unitno) +END IF + IF (ALLOCATED(obj%thickness)) THEN CALL Util_Display(obj%thickness, "thickness: ", unitno) ELSE From ea33b29cae14adbc607e8523db2a01c543230c4b Mon Sep 17 00:00:00 2001 From: easifem Date: Mon, 20 Jan 2025 12:42:46 +0900 Subject: [PATCH 354/359] update in gettotalquadraturepoints removed dims --- src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index a0c952316..bacaf080e 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -577,9 +577,8 @@ END FUNCTION obj_Size ! summary: This routine returns total number of quadrature points INTERFACE GetTotalQuadraturepoints - MODULE PURE FUNCTION obj_GetTotalQuadraturepoints(obj, dims) RESULT(ans) + MODULE PURE FUNCTION obj_GetTotalQuadraturepoints(obj) RESULT(ans) TYPE(QuadraturePoint_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: dims INTEGER(I4B) :: ans END FUNCTION obj_GetTotalQuadraturepoints END INTERFACE GetTotalQuadraturepoints From 0a3b3f34e07c608b2c39466ca4f46a6c6dce33ed Mon Sep 17 00:00:00 2001 From: easifem Date: Mon, 20 Jan 2025 12:52:22 +0900 Subject: [PATCH 355/359] adding getquadratureweight method --- .../src/QuadraturePoint_Method.F90 | 41 ++++++++++++++----- .../src/QuadraturePoint_Method@GetMethods.F90 | 9 ++++ 2 files changed, 39 insertions(+), 11 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index bacaf080e..e00778429 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -32,10 +32,11 @@ MODULE QuadraturePoint_Method PUBLIC :: QuadraturePoint_Pointer PUBLIC :: DEALLOCATE PUBLIC :: SIZE -PUBLIC :: GetTotalQuadraturepoints +PUBLIC :: GetTotalQuadraturePoints -PUBLIC :: GetQuadraturepoints -PUBLIC :: GetQuadraturepoints_ +PUBLIC :: GetQuadraturePoints +PUBLIC :: GetQuadraturePoints_ +PUBLIC :: GetQuadratureWeights_ PUBLIC :: Outerprod PUBLIC :: Display @@ -577,10 +578,10 @@ 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_GetTotalQuadraturePoints(obj) RESULT(ans) TYPE(QuadraturePoint_), INTENT(IN) :: obj INTEGER(I4B) :: ans - END FUNCTION obj_GetTotalQuadraturepoints + END FUNCTION obj_GetTotalQuadraturePoints END INTERFACE GetTotalQuadraturepoints !---------------------------------------------------------------------------- @@ -592,7 +593,7 @@ END FUNCTION obj_GetTotalQuadraturepoints ! summary: This routine returns quadrature points INTERFACE GetQuadraturePoints - MODULE PURE SUBROUTINE obj_GetQuadraturepoints1(obj, points, weights, num) + MODULE PURE SUBROUTINE obj_GetQuadraturePoints1(obj, points, weights, num) TYPE(QuadraturePoint_), INTENT(IN) :: obj REAL(DFP), INTENT(INOUT) :: points(3) !! [xi, eta, zeta] @@ -600,7 +601,7 @@ MODULE PURE SUBROUTINE obj_GetQuadraturepoints1(obj, points, weights, num) !! weights INTEGER(I4B), INTENT(IN) :: num !! quadrature number - END SUBROUTINE obj_GetQuadraturepoints1 + END SUBROUTINE obj_GetQuadraturePoints1 END INTERFACE GetQuadraturePoints !---------------------------------------------------------------------------- @@ -612,13 +613,13 @@ END SUBROUTINE obj_GetQuadraturepoints1 ! summary: This routine returns total number of quadrature points INTERFACE GetQuadraturePoints - MODULE PURE SUBROUTINE obj_GetQuadraturepoints2(obj, points, weights) + MODULE PURE SUBROUTINE obj_GetQuadraturePoints2(obj, points, weights) TYPE(QuadraturePoint_), INTENT(IN) :: obj REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: points(:, :) !! Point( :, j ) = [xi, eta, zeta] of jth quadrature point REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: weights(:) !! Weight(j) weight of jth quadrature point - END SUBROUTINE obj_GetQuadraturepoints2 + END SUBROUTINE obj_GetQuadraturePoints2 END INTERFACE GetQuadraturePoints !---------------------------------------------------------------------------- @@ -630,7 +631,7 @@ END SUBROUTINE obj_GetQuadraturepoints2 ! summary: This routine returns total number of quadrature points INTERFACE GetQuadraturePoints_ - MODULE PURE SUBROUTINE obj_GetQuadraturepoints1_(obj, points, weights, & + MODULE PURE SUBROUTINE obj_GetQuadraturePoints1_(obj, points, weights, & nrow, ncol) TYPE(QuadraturePoint_), INTENT(IN) :: obj REAL(DFP), INTENT(INOUT) :: points(:, :) @@ -640,9 +641,27 @@ MODULE PURE SUBROUTINE obj_GetQuadraturepoints1_(obj, points, weights, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of rows and columns !! ncol is number of columns in points and weights - END SUBROUTINE obj_GetQuadraturepoints1_ + END SUBROUTINE obj_GetQuadraturePoints1_ END INTERFACE GetQuadraturePoints_ +!---------------------------------------------------------------------------- +! GetQuadratureWeight@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-07-07 +! summary: This routine returns the quadrature weights + +INTERFACE GetQuadratureWeights_ + MODULE PURE SUBROUTINE obj_GetQuadratureWeights1_(obj, weights, tsize) + TYPE(QuadraturePoint_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: weights(:) + !! Weight(j) weight of jth quadrature point + INTEGER(I4B), INTENT(OUT) :: tsize + !! The number of data written in weights + END SUBROUTINE obj_GetQuadratureWeights1_ +END INTERFACE GetQuadratureWeights_ + !---------------------------------------------------------------------------- ! OuterProd@GetMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 index ee399c49d..61cc73fc2 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 @@ -63,6 +63,15 @@ weights = obj%points(obj%tXi + 1, 1:n) END PROCEDURE obj_GetQuadraturePoints2 +!---------------------------------------------------------------------------- +! GetQuadratureWeights +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetQuadratureWeights1_ +tsize = SIZE(obj%points, 2) !#column +weights(1:tsize) = obj%points(obj%tXi + 1, 1:tsize) +END PROCEDURE obj_GetQuadratureWeights1_ + !---------------------------------------------------------------------------- ! getQuadraturepoints !---------------------------------------------------------------------------- From bc5ec72bc87de5287c96f36679aef313260fc446 Mon Sep 17 00:00:00 2001 From: easifem Date: Mon, 20 Jan 2025 14:58:50 +0900 Subject: [PATCH 356/359] updates in HierarchicalElemShapeData1 --- .../src/ElemshapeData_Hierarchical@Methods.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 index 4e7c7ad5e..e6fc71cdd 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 @@ -27,7 +27,9 @@ HierarchicalGradientEvalAll_ USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & - QuadraturePoint_Size => Size + QuadraturePoint_Size => Size, & + GetTotalQuadraturePoints, & + GetQuadratureWeights_ USE BaseType, ONLY: TypeQuadratureOpt, & TypePolynomialOpt @@ -50,7 +52,7 @@ ! CALL DEALLOCATE (obj) -nips = SIZE(quad%points, 2) +nips = GetTotalQuadraturePoints(obj=quad) ! pt = quad%points(1:quad%txi, 1:nips) ! wt = quad%points(quad%txi + 1, 1:nips) @@ -59,7 +61,7 @@ CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) -obj%ws = quad%points(1 + xidim, 1:nips) +CALL GetQuadratureWeights_(obj=quad, weights=obj%ws, tsize=nips) ALLOCATE (temp(nips, nns, 3)) From 56c2c8850d2eebfac4bc5de535a430ac0ab68683 Mon Sep 17 00:00:00 2001 From: easifem Date: Mon, 20 Jan 2025 15:13:36 +0900 Subject: [PATCH 357/359] Updates in hierarchicalelemshapedata1 --- .../ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 index e6fc71cdd..6c7862129 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 @@ -53,8 +53,6 @@ ! CALL DEALLOCATE (obj) nips = GetTotalQuadraturePoints(obj=quad) -! pt = quad%points(1:quad%txi, 1:nips) -! wt = quad%points(quad%txi + 1, 1:nips) nns = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, & faceOrder=faceOrder, edgeOrder=edgeOrder) From 9625b82784783f2994aae03ae817a6a02d9948f6 Mon Sep 17 00:00:00 2001 From: easifem Date: Mon, 20 Jan 2025 15:13:44 +0900 Subject: [PATCH 358/359] update in lagrangeelemshapedata1 --- .../ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 index 3e22c4efd..ad274c688 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 @@ -29,7 +29,9 @@ LagrangeGradientEvalAll_ USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, & - QuadraturePoint_Size => Size + QuadraturePoint_Size => Size, & + GetTotalQuadraturePoints, & + GetQuadratureWeights_ USE BaseType, ONLY: TypeQuadratureOpt, & TypePolynomialOpt @@ -55,7 +57,7 @@ ! CALL DEALLOCATE (obj) -nips = SIZE(quad%points, 2) +nips = GetTotalQuadraturePoints(obj=quad) ! pt = quad%points(1:quad%txi, 1:nips) ! wt = quad%points(quad%txi + 1, 1:nips) @@ -70,7 +72,7 @@ CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips) -obj%ws = quad%points(quad%txi + 1, 1:nips) +CALL GetQuadratureWeights_(obj=quad, weights=obj%ws, tsize=nips) ALLOCATE (xij(3, nns), temp(nips, nns, 3)) From 56c9521382597a86a3551c967e7a24db21d5262f Mon Sep 17 00:00:00 2001 From: easifem Date: Tue, 6 May 2025 16:18:34 +0900 Subject: [PATCH 359/359] minor updates in reallocate --- .../Utility/src/Reallocate/reallocate1.F90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/submodules/Utility/src/Reallocate/reallocate1.F90 b/src/submodules/Utility/src/Reallocate/reallocate1.F90 index c076b4f0c..1f3d1e269 100644 --- a/src/submodules/Utility/src/Reallocate/reallocate1.F90 +++ b/src/submodules/Utility/src/Reallocate/reallocate1.F90 @@ -19,7 +19,9 @@ END IF ! CALL setzeros - DO CONCURRENT(ii=1:row); mat(ii) = ZEROVALUE; END DO + DO CONCURRENT(ii=1:row) + mat(ii) = ZEROVALUE + END DO RETURN END IF @@ -32,10 +34,14 @@ ALLOCATE (mat(row * fac)) END IF - DO CONCURRENT(ii=1:row); mat(ii) = ZEROVALUE; END DO + DO CONCURRENT(ii=1:row) + mat(ii) = ZEROVALUE + END DO RETURN END IF ALLOCATE (mat(row * fac)) -DO CONCURRENT(ii=1:row); mat(ii) = ZEROVALUE; END DO +DO CONCURRENT(ii=1:row) + mat(ii) = ZEROVALUE +END DO ! CALL setzeros